From cb96604593994f2530f478c5016b01457c284605 Mon Sep 17 00:00:00 2001 From: Jan Mandel Date: Sat, 23 Apr 2016 22:15:31 -0600 Subject: [PATCH 01/15] WRFV3.6 --- wrfv2_fire/Makefile | 86 +- wrfv2_fire/README | 34 +- wrfv2_fire/README.DA | 64 +- wrfv2_fire/README.hydro | 2 +- wrfv2_fire/README.windturbine | 189 +- wrfv2_fire/Registry/Registry.CONVERT | 8 +- wrfv2_fire/Registry/Registry.EM | 12 +- wrfv2_fire/Registry/Registry.EM_CHEM | 12 +- wrfv2_fire/Registry/Registry.EM_COMMON | 682 +- wrfv2_fire/Registry/Registry.NMM | 190 +- wrfv2_fire/Registry/Registry.NMM_CHEM | 1580 -- wrfv2_fire/Registry/Registry.NMM_HWRF | 385 +- wrfv2_fire/Registry/Registry.NMM_NEST | 184 +- wrfv2_fire/Registry/registry.bdy_perturb | 8 +- wrfv2_fire/Registry/registry.cam | 27 +- wrfv2_fire/Registry/registry.chem | 334 +- wrfv2_fire/Registry/registry.clm | 198 +- wrfv2_fire/Registry/registry.dimspec | 8 + wrfv2_fire/Registry/registry.io_boilerplate | 4 + wrfv2_fire/Registry/registry.lake | 40 + wrfv2_fire/Registry/registry.sbm | 310 + wrfv2_fire/Registry/registry.stoch | 111 +- wrfv2_fire/Registry/registry.var | 39 +- wrfv2_fire/Registry/registry.var_chem | 2 + wrfv2_fire/arch/Config_new.pl | 23 +- wrfv2_fire/arch/configure_new.defaults | 302 +- wrfv2_fire/arch/noopt_exceptions | 8 +- wrfv2_fire/arch/noopt_exceptions_f | 2 +- wrfv2_fire/arch/postamble_new | 14 +- ...gs_to_update_rconst_cri_mosaic_4bin_aq.inc | 7 + ..._args_update_rconst_cri_mosaic_4bin_aq.inc | 6 + ...decls_update_rconst_cri_mosaic_4bin_aq.inc | 8 + .../kpp_mechd_a_cri_mosaic_4bin_aq.inc | 1 + .../kpp_mechd_b_cri_mosaic_4bin_aq.inc | 1 + .../kpp_mechd_e_cri_mosaic_4bin_aq.inc | 1 + .../kpp_mechd_ia_cri_mosaic_4bin_aq.inc | 1 + .../kpp_mechd_ib_cri_mosaic_4bin_aq.inc | 1 + .../kpp_mechd_ibu_cri_mosaic_4bin_aq.inc | 17 + .../kpp_mechd_l_cri_mosaic_4bin_aq.inc | 4 + .../kpp_mechd_u_cri_mosaic_4bin_aq.inc | 1 + ...gs_to_update_rconst_cri_mosaic_8bin_aq.inc | 7 + ..._args_update_rconst_cri_mosaic_8bin_aq.inc | 6 + ...decls_update_rconst_cri_mosaic_8bin_aq.inc | 8 + .../kpp_mechd_a_cri_mosaic_8bin_aq.inc | 1 + .../kpp_mechd_b_cri_mosaic_8bin_aq.inc | 1 + .../kpp_mechd_e_cri_mosaic_8bin_aq.inc | 1 + .../kpp_mechd_ia_cri_mosaic_8bin_aq.inc | 1 + .../kpp_mechd_ib_cri_mosaic_8bin_aq.inc | 1 + .../kpp_mechd_ibu_cri_mosaic_8bin_aq.inc | 17 + .../kpp_mechd_l_cri_mosaic_8bin_aq.inc | 4 + .../kpp_mechd_u_cri_mosaic_8bin_aq.inc | 1 + .../extra_args_to_update_rconst_crimech.inc | 7 + .../extra_args_update_rconst_crimech.inc | 6 + .../extra_decls_update_rconst_crimech.inc | 8 + .../KPP/inc/crimech/kpp_mechd_a_crimech.inc | 1 + .../KPP/inc/crimech/kpp_mechd_b_crimech.inc | 1 + .../KPP/inc/crimech/kpp_mechd_e_crimech.inc | 1 + .../KPP/inc/crimech/kpp_mechd_ia_crimech.inc | 1 + .../KPP/inc/crimech/kpp_mechd_ib_crimech.inc | 1 + .../KPP/inc/crimech/kpp_mechd_ibu_crimech.inc | 17 + .../KPP/inc/crimech/kpp_mechd_l_crimech.inc | 4 + .../KPP/inc/crimech/kpp_mechd_u_crimech.inc | 1 + .../chem/KPP/mechanisms/cbmz_bb/cbmz_bb.eqn | 6 +- .../chem/KPP/mechanisms/cbmz_bb/cbmz_bb.spc | 2 +- .../mechanisms/cbmz_bb/cbmz_bb_wrfkpp.equiv | 2 +- .../mechanisms/cbmz_mosaic/cbmz_mosaic.eqn | 6 +- .../mechanisms/cbmz_mosaic/cbmz_mosaic.spc | 2 +- .../cbmz_mosaic/cbmz_mosaic_wrfkpp.equiv | 2 +- .../mechanisms/cri_mosaic_4bin_aq/atoms_red | 107 + .../cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.def | 171 + .../cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.eqn | 639 + .../cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.kpp | 9 + .../cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.spc | 238 + .../cri_mosaic_4bin_aq_wrfkpp.equiv | 14 + .../mechanisms/cri_mosaic_8bin_aq/atoms_red | 107 + .../cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.def | 171 + .../cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.eqn | 638 + .../cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.kpp | 9 + .../cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.spc | 238 + .../cri_mosaic_8bin_aq_wrfkpp.equiv | 14 + .../chem/KPP/mechanisms/crimech/atoms_red | 107 + .../chem/KPP/mechanisms/crimech/crimech.def | 171 + .../chem/KPP/mechanisms/crimech/crimech.eqn | 638 + .../chem/KPP/mechanisms/crimech/crimech.kpp | 9 + .../chem/KPP/mechanisms/crimech/crimech.spc | 238 + .../mechanisms/crimech/crimech_wrfkpp.equiv | 14 + .../chem/KPP/mechanisms/mozart/mozart.def | 4 +- .../mozart_mosaic_4bin_vbs0.def | 2 +- .../chem/KPP/mechanisms/mozcart/mozcart.def | 2 +- .../mechanisms/racm_esrlsorg_aqchem/atoms_red | 107 + .../racm_esrlsorg_aqchem.def | 62 + .../racm_esrlsorg_aqchem.eqn | 246 + .../racm_esrlsorg_aqchem.kpp | 10 + .../racm_esrlsorg_aqchem.spc | 88 + .../racm_esrlsorg_aqchem_wrfkpp.equiv | 9 + .../KPP/mechanisms/racmsorg_aqchem/atoms_red | 107 + .../racmsorg_aqchem/racmsorg_aqchem.def | 21 + .../racmsorg_aqchem/racmsorg_aqchem.eqn | 242 + .../racmsorg_aqchem/racmsorg_aqchem.kpp | 10 + .../racmsorg_aqchem/racmsorg_aqchem.spc | 81 + .../racmsorg_aqchem_wrfkpp.equiv | 9 + wrfv2_fire/chem/Makefile | 4 + wrfv2_fire/chem/aerosol_driver.F | 12 +- wrfv2_fire/chem/chem_driver.F | 478 +- wrfv2_fire/chem/chemics_init.F | 167 +- wrfv2_fire/chem/cloudchem_driver.F | 4 +- wrfv2_fire/chem/convert_emiss.F | 23 + wrfv2_fire/chem/depend.chem | 6 +- wrfv2_fire/chem/dry_dep_driver.F | 104 +- wrfv2_fire/chem/emissions_driver.F | 118 +- wrfv2_fire/chem/mechanism_driver.F | 2 +- wrfv2_fire/chem/module_add_emis_cptec.F | 18 +- wrfv2_fire/chem/module_add_emiss_burn.F | 20 +- wrfv2_fire/chem/module_bioemi_megan2.F | 149 +- wrfv2_fire/chem/module_cam_mam_init.F | 6 +- wrfv2_fire/chem/module_cbmz_addemiss.F | 7 + .../chem/module_chem_plumerise_scalar.F | 381 +- wrfv2_fire/chem/module_ctrans_grell.F | 16 +- wrfv2_fire/chem/module_data_mgn2mech.F | 210 + wrfv2_fire/chem/module_data_mosaic_other.F | 2 + wrfv2_fire/chem/module_data_mosaic_therm.F | 23 +- wrfv2_fire/chem/module_dep_simple.F | 642 +- wrfv2_fire/chem/module_dust_load.F | 59 + .../chem/module_emissions_anthropogenics.F | 91 +- wrfv2_fire/chem/module_ftuv_driver.F | 158 +- wrfv2_fire/chem/module_ftuv_subs.F | 277 +- wrfv2_fire/chem/module_gocart_drydep.F | 15 + wrfv2_fire/chem/module_gocart_settling.F | 596 +- wrfv2_fire/chem/module_input_chem_data.F | 487 +- .../chem/module_lightning_nox_decaria.F | 23 +- wrfv2_fire/chem/module_lightning_nox_driver.F | 2 +- wrfv2_fire/chem/module_mosaic_addemiss.F | 724 +- wrfv2_fire/chem/module_mosaic_driver.F | 53 +- wrfv2_fire/chem/module_mosaic_newnuc.F | 2 +- wrfv2_fire/chem/module_mosaic_therm.F | 972 +- wrfv2_fire/chem/module_mosaic_wetscav.F | 48 +- wrfv2_fire/chem/module_mozcart_wetscav.F | 71 +- wrfv2_fire/chem/module_optical_averaging.F | 70 +- wrfv2_fire/chem/module_phot_fastj.F | 9 +- wrfv2_fire/chem/module_qf03.F | 573 + wrfv2_fire/chem/module_soilpsd.F | 64 + wrfv2_fire/chem/module_sorgam_aqchem.F | 2 +- wrfv2_fire/chem/module_uoc_dust.F | 333 + wrfv2_fire/chem/module_vash_settling.F | 2 + wrfv2_fire/chem/module_wetscav_driver.F | 20 +- wrfv2_fire/chem/module_zero_plumegen_coms.F | 19 +- wrfv2_fire/chem/optical_driver.F | 13 +- wrfv2_fire/chem/photolysis_driver.F | 3 + wrfv2_fire/clean | 11 +- wrfv2_fire/compile | 30 +- wrfv2_fire/configure | 45 +- wrfv2_fire/configure.nc4 | 932 ++ wrfv2_fire/dyn_em/Makefile | 3 +- wrfv2_fire/dyn_em/adapt_timestep_em.F | 25 +- wrfv2_fire/dyn_em/depend.dyn_em | 12 +- wrfv2_fire/dyn_em/module_advect_em.F | 7 +- wrfv2_fire/dyn_em/module_after_all_rk_steps.F | 150 + .../dyn_em/module_big_step_utilities_em.F | 10 +- wrfv2_fire/dyn_em/module_diffusion_em.F | 39 +- wrfv2_fire/dyn_em/module_em.F | 76 +- .../dyn_em/module_first_rk_step_part1.F | 157 +- .../dyn_em/module_first_rk_step_part2.F | 47 +- wrfv2_fire/dyn_em/module_force_scm.F | 6 +- wrfv2_fire/dyn_em/module_initialize_b_wave.F | 26 +- wrfv2_fire/dyn_em/module_initialize_les.F | 5 +- .../dyn_em/module_initialize_quarter_ss.F | 42 +- wrfv2_fire/dyn_em/module_initialize_real.F | 588 +- .../dyn_em/module_initialize_seabreeze2d_x.F | 14 +- .../module_initialize_tropical_cyclone.F | 27 +- wrfv2_fire/dyn_em/module_polarfft.F | 113 +- wrfv2_fire/dyn_em/module_stoch.F | 792 +- wrfv2_fire/dyn_em/module_wps_io_arw.F | 106 +- wrfv2_fire/dyn_em/solve_em.F | 382 +- wrfv2_fire/dyn_em/start_em.F | 149 +- wrfv2_fire/dyn_nmm/Makefile | 3 + wrfv2_fire/dyn_nmm/depend.dyn_nmm | 6 +- wrfv2_fire/dyn_nmm/module_BNDRY_COND.F | 40 +- wrfv2_fire/dyn_nmm/module_GWD.F | 21 +- wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F | 201 +- wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F | 420 +- .../module_initialize_tropical_cyclone.F | 76 +- wrfv2_fire/dyn_nmm/module_membrane_mslp.F | 726 + wrfv2_fire/dyn_nmm/module_relax.F | 221 + wrfv2_fire/dyn_nmm/module_si_io_nmm.F | 19 + wrfv2_fire/dyn_nmm/module_tracker.F | 990 ++ wrfv2_fire/dyn_nmm/solve_nmm.F | 128 +- wrfv2_fire/dyn_nmm/start_domain_nmm.F | 189 +- wrfv2_fire/external/Makefile | 2 +- wrfv2_fire/external/RSL_LITE/c_code.c | 22 + wrfv2_fire/external/RSL_LITE/module_dm.F | 259 +- wrfv2_fire/external/atm_ocn/Makefile | 2 +- wrfv2_fire/external/esmf_time_f90/Makefile | 8 +- wrfv2_fire/external/fftpack/77to90.csh | 30 +- wrfv2_fire/external/fftpack/README | 55 +- wrfv2_fire/external/fftpack/convert.f90 | 1710 -- wrfv2_fire/external/fftpack/f90split.f90 | 1666 ++ wrfv2_fire/external/fftpack/f90split.sh | 22 + wrfv2_fire/external/fftpack/fftpack5/Makefile | 28 +- .../external/fftpack/fftpack5/Makefile-orig | 49 - wrfv2_fire/external/fftpack/fftpack5/README | 174 - wrfv2_fire/external/fftpack/fftpack5/c1f2kb.F | 136 +- wrfv2_fire/external/fftpack/fftpack5/c1f2kf.F | 155 +- wrfv2_fire/external/fftpack/fftpack5/c1f3kb.F | 196 +- wrfv2_fire/external/fftpack/fftpack5/c1f3kf.F | 237 +- wrfv2_fire/external/fftpack/fftpack5/c1f4kb.F | 221 +- wrfv2_fire/external/fftpack/fftpack5/c1f4kf.F | 267 +- wrfv2_fire/external/fftpack/fftpack5/c1f5kb.F | 304 +- wrfv2_fire/external/fftpack/fftpack5/c1f5kf.F | 387 +- wrfv2_fire/external/fftpack/fftpack5/c1fgkb.F | 289 +- wrfv2_fire/external/fftpack/fftpack5/c1fgkf.F | 334 +- wrfv2_fire/external/fftpack/fftpack5/c1fm1b.F | 159 +- wrfv2_fire/external/fftpack/fftpack5/c1fm1f.F | 159 +- wrfv2_fire/external/fftpack/fftpack5/cfft1b.F | 159 +- wrfv2_fire/external/fftpack/fftpack5/cfft1f.F | 159 +- wrfv2_fire/external/fftpack/fftpack5/cfft1i.F | 111 +- wrfv2_fire/external/fftpack/fftpack5/cfft2b.F | 208 +- wrfv2_fire/external/fftpack/fftpack5/cfft2f.F | 209 +- wrfv2_fire/external/fftpack/fftpack5/cfft2i.F | 150 +- wrfv2_fire/external/fftpack/fftpack5/cfftmb.F | 187 +- wrfv2_fire/external/fftpack/fftpack5/cfftmf.F | 186 +- wrfv2_fire/external/fftpack/fftpack5/cfftmi.F | 109 +- wrfv2_fire/external/fftpack/fftpack5/cmf2kb.F | 164 +- wrfv2_fire/external/fftpack/fftpack5/cmf2kf.F | 193 +- wrfv2_fire/external/fftpack/fftpack5/cmf3kb.F | 221 +- wrfv2_fire/external/fftpack/fftpack5/cmf3kf.F | 261 +- wrfv2_fire/external/fftpack/fftpack5/cmf4kb.F | 247 +- wrfv2_fire/external/fftpack/fftpack5/cmf4kf.F | 300 +- wrfv2_fire/external/fftpack/fftpack5/cmf5kb.F | 337 +- wrfv2_fire/external/fftpack/fftpack5/cmf5kf.F | 419 +- wrfv2_fire/external/fftpack/fftpack5/cmfgkb.F | 380 +- wrfv2_fire/external/fftpack/fftpack5/cmfgkf.F | 439 +- wrfv2_fire/external/fftpack/fftpack5/cmfm1b.F | 159 +- wrfv2_fire/external/fftpack/fftpack5/cmfm1f.F | 159 +- wrfv2_fire/external/fftpack/fftpack5/cosq1b.F | 182 +- wrfv2_fire/external/fftpack/fftpack5/cosq1f.F | 183 +- wrfv2_fire/external/fftpack/fftpack5/cosq1i.F | 139 +- wrfv2_fire/external/fftpack/fftpack5/cosqb1.F | 155 +- wrfv2_fire/external/fftpack/fftpack5/cosqf1.F | 150 +- wrfv2_fire/external/fftpack/fftpack5/cosqmb.F | 224 +- wrfv2_fire/external/fftpack/fftpack5/cosqmf.F | 221 +- wrfv2_fire/external/fftpack/fftpack5/cosqmi.F | 141 +- wrfv2_fire/external/fftpack/fftpack5/cost1b.F | 162 +- wrfv2_fire/external/fftpack/fftpack5/cost1f.F | 162 +- wrfv2_fire/external/fftpack/fftpack5/cost1i.F | 158 +- wrfv2_fire/external/fftpack/fftpack5/costb1.F | 219 +- wrfv2_fire/external/fftpack/fftpack5/costf1.F | 213 +- wrfv2_fire/external/fftpack/fftpack5/costmb.F | 191 +- wrfv2_fire/external/fftpack/fftpack5/costmf.F | 192 +- wrfv2_fire/external/fftpack/fftpack5/costmi.F | 159 +- wrfv2_fire/external/fftpack/fftpack5/d1f2kb.F | 88 + wrfv2_fire/external/fftpack/fftpack5/d1f2kf.F | 88 + wrfv2_fire/external/fftpack/fftpack5/d1f3kb.F | 100 + wrfv2_fire/external/fftpack/fftpack5/d1f3kf.F | 102 + wrfv2_fire/external/fftpack/fftpack5/d1f4kb.F | 120 + wrfv2_fire/external/fftpack/fftpack5/d1f4kf.F | 123 + wrfv2_fire/external/fftpack/fftpack5/d1f5kb.F | 170 + wrfv2_fire/external/fftpack/fftpack5/d1f5kf.F | 176 + wrfv2_fire/external/fftpack/fftpack5/d1fgkb.F | 273 + wrfv2_fire/external/fftpack/fftpack5/d1fgkf.F | 283 + .../external/fftpack/fftpack5/dcosq1b.F | 135 + .../external/fftpack/fftpack5/dcosq1f.F | 135 + .../external/fftpack/fftpack5/dcosq1i.F | 100 + .../external/fftpack/fftpack5/dcosqb1.F | 103 + .../external/fftpack/fftpack5/dcosqf1.F | 100 + .../external/fftpack/fftpack5/dcost1b.F | 121 + .../external/fftpack/fftpack5/dcost1f.F | 121 + .../external/fftpack/fftpack5/dcost1i.F | 112 + .../external/fftpack/fftpack5/dcostb1.F | 144 + .../external/fftpack/fftpack5/dcostf1.F | 140 + wrfv2_fire/external/fftpack/fftpack5/dfft1b.F | 119 + wrfv2_fire/external/fftpack/fftpack5/dfft1f.F | 114 + wrfv2_fire/external/fftpack/fftpack5/dfft1i.F | 80 + wrfv2_fire/external/fftpack/fftpack5/dfftb1.F | 183 + wrfv2_fire/external/fftpack/fftpack5/dfftf1.F | 177 + wrfv2_fire/external/fftpack/fftpack5/dffti1.F | 154 + .../external/fftpack/fftpack5/dsint1b.F | 121 + .../external/fftpack/fftpack5/dsint1f.F | 121 + .../external/fftpack/fftpack5/dsint1i.F | 106 + .../external/fftpack/fftpack5/dsintb1.F | 124 + .../external/fftpack/fftpack5/dsintf1.F | 124 + wrfv2_fire/external/fftpack/fftpack5/mcsqb1.F | 201 +- wrfv2_fire/external/fftpack/fftpack5/mcsqf1.F | 195 +- wrfv2_fire/external/fftpack/fftpack5/mcstb1.F | 294 +- wrfv2_fire/external/fftpack/fftpack5/mcstf1.F | 288 +- wrfv2_fire/external/fftpack/fftpack5/mradb2.F | 161 +- wrfv2_fire/external/fftpack/fftpack5/mradb3.F | 196 +- wrfv2_fire/external/fftpack/fftpack5/mradb4.F | 226 +- wrfv2_fire/external/fftpack/fftpack5/mradb5.F | 308 +- wrfv2_fire/external/fftpack/fftpack5/mradbg.F | 589 +- wrfv2_fire/external/fftpack/fftpack5/mradf2.F | 165 +- wrfv2_fire/external/fftpack/fftpack5/mradf3.F | 189 +- wrfv2_fire/external/fftpack/fftpack5/mradf4.F | 240 +- wrfv2_fire/external/fftpack/fftpack5/mradf5.F | 323 +- wrfv2_fire/external/fftpack/fftpack5/mradfg.F | 609 +- wrfv2_fire/external/fftpack/fftpack5/mrftb1.F | 313 +- wrfv2_fire/external/fftpack/fftpack5/mrftf1.F | 330 +- wrfv2_fire/external/fftpack/fftpack5/mrfti1.F | 225 +- wrfv2_fire/external/fftpack/fftpack5/msntb1.F | 254 +- wrfv2_fire/external/fftpack/fftpack5/msntf1.F | 248 +- wrfv2_fire/external/fftpack/fftpack5/r1f2kb.F | 130 +- wrfv2_fire/external/fftpack/fftpack5/r1f2kf.F | 129 +- wrfv2_fire/external/fftpack/fftpack5/r1f3kb.F | 161 +- wrfv2_fire/external/fftpack/fftpack5/r1f3kf.F | 162 +- wrfv2_fire/external/fftpack/fftpack5/r1f4kb.F | 191 +- wrfv2_fire/external/fftpack/fftpack5/r1f4kf.F | 201 +- wrfv2_fire/external/fftpack/fftpack5/r1f5kb.F | 287 +- wrfv2_fire/external/fftpack/fftpack5/r1f5kf.F | 301 +- wrfv2_fire/external/fftpack/fftpack5/r1fgkb.F | 452 +- wrfv2_fire/external/fftpack/fftpack5/r1fgkf.F | 467 +- .../external/fftpack/fftpack5/r4_factor.F | 92 + .../external/fftpack/fftpack5/r4_mcfti1.F | 69 + .../external/fftpack/fftpack5/r4_tables.F | 74 + .../external/fftpack/fftpack5/r8_factor.F | 90 + .../external/fftpack/fftpack5/r8_mcfti1.F | 67 + .../external/fftpack/fftpack5/r8_tables.F | 72 + wrfv2_fire/external/fftpack/fftpack5/rfft1b.F | 154 +- wrfv2_fire/external/fftpack/fftpack5/rfft1f.F | 149 +- wrfv2_fire/external/fftpack/fftpack5/rfft1i.F | 108 +- wrfv2_fire/external/fftpack/fftpack5/rfft2b.F | 243 +- wrfv2_fire/external/fftpack/fftpack5/rfft2f.F | 247 +- wrfv2_fire/external/fftpack/fftpack5/rfft2i.F | 155 +- wrfv2_fire/external/fftpack/fftpack5/rfftb1.F | 280 +- wrfv2_fire/external/fftpack/fftpack5/rfftf1.F | 269 +- wrfv2_fire/external/fftpack/fftpack5/rffti1.F | 226 +- wrfv2_fire/external/fftpack/fftpack5/rfftmb.F | 175 +- wrfv2_fire/external/fftpack/fftpack5/rfftmf.F | 175 +- wrfv2_fire/external/fftpack/fftpack5/rfftmi.F | 108 +- wrfv2_fire/external/fftpack/fftpack5/sinq1b.F | 194 +- wrfv2_fire/external/fftpack/fftpack5/sinq1f.F | 194 +- wrfv2_fire/external/fftpack/fftpack5/sinq1i.F | 115 +- wrfv2_fire/external/fftpack/fftpack5/sinqmb.F | 237 +- wrfv2_fire/external/fftpack/fftpack5/sinqmf.F | 234 +- wrfv2_fire/external/fftpack/fftpack5/sinqmi.F | 116 +- wrfv2_fire/external/fftpack/fftpack5/sint1b.F | 163 +- wrfv2_fire/external/fftpack/fftpack5/sint1f.F | 161 +- wrfv2_fire/external/fftpack/fftpack5/sint1i.F | 148 +- wrfv2_fire/external/fftpack/fftpack5/sintb1.F | 186 +- wrfv2_fire/external/fftpack/fftpack5/sintf1.F | 185 +- wrfv2_fire/external/fftpack/fftpack5/sintmb.F | 194 +- wrfv2_fire/external/fftpack/fftpack5/sintmf.F | 193 +- wrfv2_fire/external/fftpack/fftpack5/sintmi.F | 148 +- wrfv2_fire/external/fftpack/fftpack5/xercon.F | 139 +- wrfv2_fire/external/fftpack/fftpack5/xerfft.F | 161 +- wrfv2_fire/external/fftpack/fftpack5/z1f2kb.F | 92 + wrfv2_fire/external/fftpack/fftpack5/z1f2kf.F | 103 + wrfv2_fire/external/fftpack/fftpack5/z1f3kb.F | 127 + wrfv2_fire/external/fftpack/fftpack5/z1f3kf.F | 150 + wrfv2_fire/external/fftpack/fftpack5/z1f4kb.F | 136 + wrfv2_fire/external/fftpack/fftpack5/z1f4kf.F | 163 + wrfv2_fire/external/fftpack/fftpack5/z1f5kb.F | 184 + wrfv2_fire/external/fftpack/fftpack5/z1f5kf.F | 236 + wrfv2_fire/external/fftpack/fftpack5/z1fgkb.F | 176 + wrfv2_fire/external/fftpack/fftpack5/z1fgkf.F | 202 + wrfv2_fire/external/fftpack/fftpack5/z1fm1b.F | 102 + wrfv2_fire/external/fftpack/fftpack5/z1fm1f.F | 101 + wrfv2_fire/external/fftpack/fftpack5/zfft1b.F | 121 + wrfv2_fire/external/fftpack/fftpack5/zfft1f.F | 121 + wrfv2_fire/external/fftpack/fftpack5/zfft1i.F | 82 + wrfv2_fire/external/fftpack/fftpack5/zfft2b.F | 147 + wrfv2_fire/external/fftpack/fftpack5/zfft2f.F | 148 + wrfv2_fire/external/fftpack/fftpack5/zfft2i.F | 107 + wrfv2_fire/external/fftpack/fftpack5/zfftmb.F | 145 + wrfv2_fire/external/fftpack/fftpack5/zfftmf.F | 144 + wrfv2_fire/external/fftpack/fftpack5/zfftmi.F | 80 + wrfv2_fire/external/fftpack/fftpack5/zmf2kb.F | 111 + wrfv2_fire/external/fftpack/fftpack5/zmf2kf.F | 129 + wrfv2_fire/external/fftpack/fftpack5/zmf3kb.F | 143 + wrfv2_fire/external/fftpack/fftpack5/zmf3kf.F | 164 + wrfv2_fire/external/fftpack/fftpack5/zmf4kb.F | 154 + wrfv2_fire/external/fftpack/fftpack5/zmf4kf.F | 184 + wrfv2_fire/external/fftpack/fftpack5/zmf5kb.F | 208 + wrfv2_fire/external/fftpack/fftpack5/zmf5kf.F | 251 + wrfv2_fire/external/fftpack/fftpack5/zmfgkb.F | 234 + wrfv2_fire/external/fftpack/fftpack5/zmfgkf.F | 265 + wrfv2_fire/external/fftpack/fftpack5/zmfm1b.F | 103 + wrfv2_fire/external/fftpack/fftpack5/zmfm1f.F | 103 + wrfv2_fire/external/io_esmf/makefile | 2 +- .../external/io_grib2/g2lib/utest/Makefile | 2 +- wrfv2_fire/external/io_int/makefile | 16 +- ...e_io_int_idx.f90 => module_io_int_idx.F90} | 10 + .../external/io_int/module_io_int_read.F90 | 10 + .../{test_io_idx.f90 => test_io_idx.F90} | 10 + wrfv2_fire/external/io_mcel/makefile | 2 +- .../io_netcdf/ext_ncd_put_dom_ti.code | 2 +- wrfv2_fire/external/io_netcdf/makefile | 7 +- wrfv2_fire/external/io_netcdf/wrf_io.F90 | 19 + wrfv2_fire/external/io_phdf5/Makefile | 2 +- wrfv2_fire/external/io_pnetcdf/makefile | 2 +- wrfv2_fire/frame/Makefile | 4 +- wrfv2_fire/frame/module_bdywrite.F | 37 +- wrfv2_fire/frame/module_cpl.F | 521 + wrfv2_fire/frame/module_cpl_oasis3.F | 531 + wrfv2_fire/frame/module_dm_stubs.F | 7 + wrfv2_fire/frame/module_domain.F | 64 +- wrfv2_fire/frame/module_driver_constants.F | 19 +- wrfv2_fire/frame/module_integrate.F | 3 + wrfv2_fire/frame/module_io.F | 21 +- wrfv2_fire/frame/module_io_quilt.F | 19 +- wrfv2_fire/frame/module_quilt_outbuf_ops.F | 3 +- wrfv2_fire/frame/module_wrf_error.F | 5 + wrfv2_fire/hydro/CPL/WRF_cpl/Makefile | 34 + wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl | 9 + .../hydro/CPL/WRF_cpl/module_wrf_HYDRO.F | 321 + wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F | 31 + wrfv2_fire/hydro/Data_Rec/Makefile | 28 + .../hydro/Data_Rec/gw_field_include.inc | 26 + .../hydro/Data_Rec/module_GW_baseflow_data.F | 9 + wrfv2_fire/hydro/Data_Rec/module_RT_data.F | 10 + wrfv2_fire/hydro/Data_Rec/module_namelist.F | 202 + wrfv2_fire/hydro/Data_Rec/namelist.inc | 38 + wrfv2_fire/hydro/Data_Rec/rt_include.inc | 169 + wrfv2_fire/hydro/HYDRO_drv/Makefile | 28 + wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F | 1152 ++ wrfv2_fire/hydro/MPP/CPL_WRF.F | 159 + wrfv2_fire/hydro/MPP/Makefile | 26 + wrfv2_fire/hydro/MPP/mpp_land.F | 1559 ++ wrfv2_fire/hydro/Routing/Makefile | 54 + wrfv2_fire/hydro/Routing/Noah_distr_routing.F | 2778 ++++ wrfv2_fire/hydro/Routing/module_GW_baseflow.F | 809 + wrfv2_fire/hydro/Routing/module_HYDRO_io.F | 5114 ++++++ wrfv2_fire/hydro/Routing/module_HYDRO_utils.F | 414 + wrfv2_fire/hydro/Routing/module_RT.F | 854 + .../hydro/Routing/module_channel_routing.F | 1210 ++ .../hydro/Routing/module_date_utilities_rt.F | 1040 ++ wrfv2_fire/hydro/Routing/module_lsm_forcing.F | 1721 ++ .../Routing/module_noah_chan_param_init_rt.F | 87 + wrfv2_fire/hydro/Routing/rtFunction.F | 222 + wrfv2_fire/hydro/Run/HYDRO.TBL | 50 + wrfv2_fire/hydro/Run/hydro.namelist | 104 + wrfv2_fire/hydro/arc/Makefile.mpp | 17 + wrfv2_fire/hydro/arc/Makefile.seq | 30 + wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r | 33 + wrfv2_fire/hydro/arc/macros.mpp.gfort | 29 + wrfv2_fire/hydro/arc/macros.mpp.ifort | 32 + wrfv2_fire/hydro/arc/macros.mpp.linux | 31 + wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r | 32 + wrfv2_fire/hydro/arc/macros.seq.gfort | 30 + wrfv2_fire/hydro/arc/macros.seq.ifort | 32 + wrfv2_fire/hydro/arc/macros.seq.linux | 32 + wrfv2_fire/hydro/configure | 101 + wrfv2_fire/hydro/wrf_hydro_config | 28 + wrfv2_fire/inc/version_decl | 2 +- wrfv2_fire/main/depend.common | 111 +- wrfv2_fire/main/module_wrf_top.F | 17 +- wrfv2_fire/main/nup_em.F | 2 +- wrfv2_fire/main/real_em.F | 89 +- wrfv2_fire/main/real_nmm.F | 3 - wrfv2_fire/phys/Makefile | 38 +- wrfv2_fire/phys/module_bl_acm.F | 168 +- wrfv2_fire/phys/module_bl_camuwpbl_driver.F | 4 +- wrfv2_fire/phys/module_bl_fogdes.F | 164 + wrfv2_fire/phys/module_bl_gbmpbl.F | 32 +- wrfv2_fire/phys/module_bl_gfs.F | 111 +- wrfv2_fire/phys/module_bl_mynn.F | 1263 +- wrfv2_fire/phys/module_bl_temf.F | 269 +- wrfv2_fire/phys/module_bl_ysu.F | 18 +- wrfv2_fire/phys/module_cam_bl_eddy_diff.F | 3 +- .../phys/module_cam_mp_cldwat2m_micro.F | 12 +- wrfv2_fire/phys/module_cam_mp_microp_aero.F | 4 +- wrfv2_fire/phys/module_cu_gf.F | 237 +- wrfv2_fire/phys/module_cu_kfeta.F | 120 +- wrfv2_fire/phys/module_cu_mesosas.F | 7780 +++++++++ wrfv2_fire/phys/module_cu_nsas.F | 2401 +-- wrfv2_fire/phys/module_cu_tiedtke.F | 2 +- wrfv2_fire/phys/module_cumulus_driver.F | 65 +- wrfv2_fire/phys/module_diag_afwa.F | 2357 +++ wrfv2_fire/phys/module_diag_cl.F | 424 + wrfv2_fire/phys/module_diag_misc.F | 726 + wrfv2_fire/phys/module_diag_pld.F | 197 + wrfv2_fire/phys/module_diag_refl.F | 89 + wrfv2_fire/phys/module_diagnostics.F | 1351 -- wrfv2_fire/phys/module_diagnostics_driver.F | 452 + wrfv2_fire/phys/module_fddagd_driver.F | 9 +- wrfv2_fire/phys/module_fddaobs_driver.F | 21 +- wrfv2_fire/phys/module_fddaobs_rtfdda.F | 220 +- wrfv2_fire/phys/module_ltng_crmpr92.F | 6 +- wrfv2_fire/phys/module_microphysics_driver.F | 263 +- wrfv2_fire/phys/module_mixactivate.F | 4 +- wrfv2_fire/phys/module_mp_HWRF.F | 4 +- wrfv2_fire/phys/module_mp_cammgmp_driver.F | 22 +- wrfv2_fire/phys/module_mp_etanew.F | 7 +- wrfv2_fire/phys/module_mp_etaold.F | 4 +- wrfv2_fire/phys/module_mp_fast_sbm.F | 8980 +++++++++++ wrfv2_fire/phys/module_mp_full_sbm.F | 13422 ++++++++++++++++ wrfv2_fire/phys/module_mp_milbrandt2mom.F | 3727 ++--- wrfv2_fire/phys/module_mp_morr_two_moment.F | 90 +- wrfv2_fire/phys/module_mp_nssl_2mom.F | 4208 +++-- wrfv2_fire/phys/module_mp_thompson.F | 1596 +- wrfv2_fire/phys/module_pbl_driver.F | 421 +- wrfv2_fire/phys/module_physics_addtendc.F | 58 +- wrfv2_fire/phys/module_physics_init.F | 590 +- wrfv2_fire/phys/module_ra_aerosol.F | 1372 ++ wrfv2_fire/phys/module_ra_cam.F | 77 +- wrfv2_fire/phys/module_ra_flg.F | 5 +- wrfv2_fire/phys/module_ra_goddard.F | 121 +- wrfv2_fire/phys/module_ra_gsfcsw.F | 35 +- wrfv2_fire/phys/module_ra_rrtmg_lw.F | 337 +- wrfv2_fire/phys/module_ra_rrtmg_sw.F | 533 +- wrfv2_fire/phys/module_ra_sw.F | 55 +- wrfv2_fire/phys/module_radiation_driver.F | 625 +- wrfv2_fire/phys/module_sf_clm.F | 186 +- wrfv2_fire/phys/module_sf_fogdes.F | 253 + wrfv2_fire/phys/module_sf_gfdl.F | 24 +- wrfv2_fire/phys/module_sf_lake.F | 5400 +++++++ wrfv2_fire/phys/module_sf_mynn.F | 985 +- wrfv2_fire/phys/module_sf_noahdrv.F | 2684 ++- wrfv2_fire/phys/module_sf_noahlsm.F | 2 +- wrfv2_fire/phys/module_sf_noahmp_glacier.F | 315 +- .../phys/module_sf_noahmp_groundwater.F | 610 + wrfv2_fire/phys/module_sf_noahmpdrv.F | 442 +- wrfv2_fire/phys/module_sf_noahmplsm.F | 466 +- wrfv2_fire/phys/module_sf_pxlsm.F | 2 + wrfv2_fire/phys/module_sf_qnsesfc.F | 20 +- wrfv2_fire/phys/module_sf_ruclsm.F | 216 +- wrfv2_fire/phys/module_sf_sfclay.F | 19 +- wrfv2_fire/phys/module_sf_sfclayrev.F | 59 +- wrfv2_fire/phys/module_sf_ssib.F | 46 +- wrfv2_fire/phys/module_sf_temfsfclay.F | 21 +- wrfv2_fire/phys/module_sf_urban.F | 3 +- wrfv2_fire/phys/module_shcu_camuwshcu.F | 20 +- .../phys/module_shcu_camuwshcu_driver.F | 10 +- wrfv2_fire/phys/module_shcu_grims.F | 772 +- wrfv2_fire/phys/module_surface_driver.F | 2561 ++- wrfv2_fire/phys/module_wind_fitch.F | 633 +- wrfv2_fire/phys/module_wind_generic.F | 140 - wrfv2_fire/run/CCN_ACTIVATE.BIN | Bin 0 -> 35288 bytes wrfv2_fire/run/MPTABLE.TBL | 126 +- wrfv2_fire/run/README.namelist | 159 +- wrfv2_fire/run/bulkdens.asc_s_0_03_0_9 | 39 + wrfv2_fire/run/bulkradii.asc_s_0_03_0_9 | 39 + wrfv2_fire/run/capacity.asc | 39 + wrfv2_fire/run/coeff_p.asc | 3080 ++++ wrfv2_fire/run/coeff_q.asc | 326 + wrfv2_fire/run/constants.asc | 50 + wrfv2_fire/run/kernels.asc_s_0_03_0_9 | 8894 ++++++++++ wrfv2_fire/run/kernels_z.asc | 545 + wrfv2_fire/run/masses.asc | 39 + wrfv2_fire/run/termvels.asc | 40 + wrfv2_fire/run/wind-turbine-1.tbl | 24 + wrfv2_fire/share/dfi.F | 48 +- wrfv2_fire/share/input_wrf.F | 128 +- wrfv2_fire/share/interp_fcn.F | 884 +- wrfv2_fire/share/landread.c | 881 +- wrfv2_fire/share/landread.c.dist | 58 + wrfv2_fire/share/mediation_feedback_domain.F | 10 +- wrfv2_fire/share/mediation_force_domain.F | 10 +- wrfv2_fire/share/mediation_integrate.F | 45 +- wrfv2_fire/share/mediation_interp_domain.F | 14 +- wrfv2_fire/share/mediation_nest_move.F | 2 +- wrfv2_fire/share/mediation_wrfmain.F | 30 + wrfv2_fire/share/module_bc.F | 117 +- wrfv2_fire/share/module_check_a_mundo.F | 247 +- wrfv2_fire/share/module_compute_geop.F | 5 +- wrfv2_fire/share/module_interp_nmm.F | 133 +- wrfv2_fire/share/module_llxy.F | 1 + wrfv2_fire/share/module_optional_input.F | 55 +- wrfv2_fire/share/module_soil_pre.F | 7 +- wrfv2_fire/share/output_wrf.F | 77 +- wrfv2_fire/share/wrf_fddaobs_in.F | 4 +- wrfv2_fire/test/em_b_wave/namelist.input | 4 +- .../test/em_b_wave/namelist.input.backwards | 4 +- .../em_esmf_exp/namelist.input.jan00.ESMFSST | 4 +- .../namelist.input.jan00.NETCDFSST | 4 +- .../test/em_fire/hill_simple/namelist.input | 4 +- .../test/em_fire/two_fires/namelist.input | 4 +- wrfv2_fire/test/em_grav2d_x/namelist.input | 4 +- .../test/em_grav2d_x/namelist.input.100m | 4 +- .../test/em_grav2d_x/namelist.input.200m | 4 +- .../test/em_grav2d_x/namelist.input.400m | 4 +- wrfv2_fire/test/em_heldsuarez/namelist.input | 4 +- wrfv2_fire/test/em_hill2d_x/namelist.input | 4 +- wrfv2_fire/test/em_les/namelist.input | 4 +- wrfv2_fire/test/em_quarter_ss/input_sounding | 271 +- .../em_quarter_ss/input_sounding_preWRFV3.6 | 48 + wrfv2_fire/test/em_quarter_ss/namelist.input | 4 +- .../test/em_quarter_ss/namelist.input_2to1 | 116 + .../test/em_quarter_ss/namelist.input_3to1 | 116 + .../test/em_quarter_ss/namelist.input_4to1 | 116 + .../test/em_quarter_ss/namelist.input_5to1 | 116 + wrfv2_fire/test/em_real/examples.namelist | 78 +- wrfv2_fire/test/em_real/namelist.input | 4 +- wrfv2_fire/test/em_real/namelist.input.4km | 10 +- wrfv2_fire/test/em_real/namelist.input.chem | 4 +- wrfv2_fire/test/em_real/namelist.input.diags | 4 +- wrfv2_fire/test/em_real/namelist.input.fire | 4 +- wrfv2_fire/test/em_real/namelist.input.global | 4 +- wrfv2_fire/test/em_real/namelist.input.jan00 | 8 +- wrfv2_fire/test/em_real/namelist.input.jun01 | 10 +- .../test/em_real/namelist.input.ndown_1 | 4 +- .../test/em_real/namelist.input.ndown_2 | 4 +- .../test/em_real/namelist.input.ndown_3 | 4 +- wrfv2_fire/test/em_real/namelist.input.volc | 4 +- wrfv2_fire/test/em_real/wind-turbine-1.tbl | 23 + wrfv2_fire/test/em_real/windturbines.txt | 3 + wrfv2_fire/test/em_scm_xy/namelist.input | 4 +- .../test/em_seabreeze2d_x/README.seabreeze | 10 +- .../test/em_seabreeze2d_x/namelist.input | 16 +- ...st.input.ideal => namelist.input.windfarm} | 94 +- .../em_seabreeze2d_x/namelist.input.windspec | 109 - .../test/em_seabreeze2d_x/run_me_first.csh | 1 + wrfv2_fire/test/em_seabreeze2d_x/windspec.in | 104 - wrfv2_fire/test/em_squall2d_x/namelist.input | 4 +- wrfv2_fire/test/em_squall2d_y/namelist.input | 4 +- .../test/em_tropical_cyclone/namelist.input | 4 +- wrfv2_fire/test/exp_real/namelist.input | 4 +- wrfv2_fire/test/nmm_real/namelist.input.HWRF | 152 + .../test/nmm_real/namelist.input.chem_nmm | 132 - .../README.NMM.TROPICAL_CYCLONE | 36 + wrfv2_fire/test/nmm_tropical_cyclone/input.d | 4 + .../test/nmm_tropical_cyclone/namelist.input | 137 + .../test/nmm_tropical_cyclone/namelist.wps | 49 + wrfv2_fire/test/nmm_tropical_cyclone/sigma.d | 23 + wrfv2_fire/test/nmm_tropical_cyclone/sound.d | 30 + .../test/nmm_tropical_cyclone/sound_gfdl.d | 30 + .../test/nmm_tropical_cyclone/sound_jordan.d | 30 + .../test/nmm_tropical_cyclone/sound_wet.d | 30 + .../test/nmm_tropical_cyclone/storm.center | 2 + ...n_2003_test.F => fortran_2003_ieee_test.F} | 0 wrfv2_fire/tools/fortran_2003_iso_c_test.F | 24 + wrfv2_fire/tools/gen_config.c | 4 +- wrfv2_fire/tools/gen_interp.c | 7 +- 621 files changed, 143905 insertions(+), 25891 deletions(-) delete mode 100755 wrfv2_fire/Registry/Registry.NMM_CHEM create mode 100644 wrfv2_fire/Registry/registry.lake create mode 100644 wrfv2_fire/Registry/registry.sbm create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_args_to_update_rconst_cri_mosaic_4bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_args_update_rconst_cri_mosaic_4bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_decls_update_rconst_cri_mosaic_4bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_a_cri_mosaic_4bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_b_cri_mosaic_4bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_e_cri_mosaic_4bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ia_cri_mosaic_4bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ib_cri_mosaic_4bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ibu_cri_mosaic_4bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_l_cri_mosaic_4bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_u_cri_mosaic_4bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_args_to_update_rconst_cri_mosaic_8bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_args_update_rconst_cri_mosaic_8bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_decls_update_rconst_cri_mosaic_8bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_a_cri_mosaic_8bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_b_cri_mosaic_8bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_e_cri_mosaic_8bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ia_cri_mosaic_8bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ib_cri_mosaic_8bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ibu_cri_mosaic_8bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_l_cri_mosaic_8bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_u_cri_mosaic_8bin_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/crimech/extra_args_to_update_rconst_crimech.inc create mode 100644 wrfv2_fire/chem/KPP/inc/crimech/extra_args_update_rconst_crimech.inc create mode 100644 wrfv2_fire/chem/KPP/inc/crimech/extra_decls_update_rconst_crimech.inc create mode 100644 wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_a_crimech.inc create mode 100644 wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_b_crimech.inc create mode 100644 wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_e_crimech.inc create mode 100644 wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ia_crimech.inc create mode 100644 wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ib_crimech.inc create mode 100644 wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ibu_crimech.inc create mode 100644 wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_l_crimech.inc create mode 100644 wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_u_crimech.inc create mode 100755 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/atoms_red create mode 100644 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.def create mode 100644 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.eqn create mode 100644 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.kpp create mode 100644 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.spc create mode 100644 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq_wrfkpp.equiv create mode 100755 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/atoms_red create mode 100644 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.def create mode 100644 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.eqn create mode 100644 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.kpp create mode 100644 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.spc create mode 100644 wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq_wrfkpp.equiv create mode 100755 wrfv2_fire/chem/KPP/mechanisms/crimech/atoms_red create mode 100644 wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.def create mode 100644 wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.eqn create mode 100644 wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.kpp create mode 100644 wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.spc create mode 100644 wrfv2_fire/chem/KPP/mechanisms/crimech/crimech_wrfkpp.equiv create mode 100755 wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/atoms_red create mode 100755 wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.def create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.eqn create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.kpp create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.spc create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem_wrfkpp.equiv create mode 100755 wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/atoms_red create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.def create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.eqn create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.kpp create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.spc create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem_wrfkpp.equiv create mode 100644 wrfv2_fire/chem/module_dust_load.F create mode 100644 wrfv2_fire/chem/module_qf03.F create mode 100644 wrfv2_fire/chem/module_soilpsd.F create mode 100644 wrfv2_fire/chem/module_uoc_dust.F create mode 100755 wrfv2_fire/configure.nc4 create mode 100644 wrfv2_fire/dyn_em/module_after_all_rk_steps.F create mode 100644 wrfv2_fire/dyn_nmm/module_membrane_mslp.F create mode 100644 wrfv2_fire/dyn_nmm/module_relax.F create mode 100644 wrfv2_fire/dyn_nmm/module_tracker.F delete mode 100644 wrfv2_fire/external/fftpack/convert.f90 create mode 100644 wrfv2_fire/external/fftpack/f90split.f90 create mode 100755 wrfv2_fire/external/fftpack/f90split.sh delete mode 100644 wrfv2_fire/external/fftpack/fftpack5/Makefile-orig delete mode 100644 wrfv2_fire/external/fftpack/fftpack5/README create mode 100644 wrfv2_fire/external/fftpack/fftpack5/d1f2kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/d1f2kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/d1f3kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/d1f3kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/d1f4kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/d1f4kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/d1f5kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/d1f5kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/d1fgkb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/d1fgkf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dcosq1b.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dcosq1f.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dcosq1i.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dcosqb1.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dcosqf1.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dcost1b.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dcost1f.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dcost1i.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dcostb1.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dcostf1.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dfft1b.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dfft1f.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dfft1i.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dfftb1.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dfftf1.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dffti1.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dsint1b.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dsint1f.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dsint1i.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dsintb1.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/dsintf1.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/r4_factor.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/r4_mcfti1.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/r4_tables.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/r8_factor.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/r8_mcfti1.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/r8_tables.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1f2kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1f2kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1f3kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1f3kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1f4kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1f4kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1f5kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1f5kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1fgkb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1fgkf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1fm1b.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/z1fm1f.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zfft1b.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zfft1f.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zfft1i.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zfft2b.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zfft2f.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zfft2i.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zfftmb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zfftmf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zfftmi.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmf2kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmf2kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmf3kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmf3kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmf4kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmf4kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmf5kb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmf5kf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmfgkb.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmfgkf.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmfm1b.F create mode 100644 wrfv2_fire/external/fftpack/fftpack5/zmfm1f.F rename wrfv2_fire/external/io_int/{module_io_int_idx.f90 => module_io_int_idx.F90} (97%) rename wrfv2_fire/external/io_int/{test_io_idx.f90 => test_io_idx.F90} (85%) create mode 100644 wrfv2_fire/frame/module_cpl.F create mode 100644 wrfv2_fire/frame/module_cpl_oasis3.F create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/Makefile create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F create mode 100644 wrfv2_fire/hydro/Data_Rec/Makefile create mode 100644 wrfv2_fire/hydro/Data_Rec/gw_field_include.inc create mode 100644 wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F create mode 100644 wrfv2_fire/hydro/Data_Rec/module_RT_data.F create mode 100644 wrfv2_fire/hydro/Data_Rec/module_namelist.F create mode 100644 wrfv2_fire/hydro/Data_Rec/namelist.inc create mode 100644 wrfv2_fire/hydro/Data_Rec/rt_include.inc create mode 100644 wrfv2_fire/hydro/HYDRO_drv/Makefile create mode 100644 wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F create mode 100644 wrfv2_fire/hydro/MPP/CPL_WRF.F create mode 100644 wrfv2_fire/hydro/MPP/Makefile create mode 100644 wrfv2_fire/hydro/MPP/mpp_land.F create mode 100644 wrfv2_fire/hydro/Routing/Makefile create mode 100644 wrfv2_fire/hydro/Routing/Noah_distr_routing.F create mode 100644 wrfv2_fire/hydro/Routing/module_GW_baseflow.F create mode 100644 wrfv2_fire/hydro/Routing/module_HYDRO_io.F create mode 100644 wrfv2_fire/hydro/Routing/module_HYDRO_utils.F create mode 100644 wrfv2_fire/hydro/Routing/module_RT.F create mode 100644 wrfv2_fire/hydro/Routing/module_channel_routing.F create mode 100644 wrfv2_fire/hydro/Routing/module_date_utilities_rt.F create mode 100644 wrfv2_fire/hydro/Routing/module_lsm_forcing.F create mode 100644 wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F create mode 100644 wrfv2_fire/hydro/Routing/rtFunction.F create mode 100644 wrfv2_fire/hydro/Run/HYDRO.TBL create mode 100644 wrfv2_fire/hydro/Run/hydro.namelist create mode 100644 wrfv2_fire/hydro/arc/Makefile.mpp create mode 100644 wrfv2_fire/hydro/arc/Makefile.seq create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.gfort create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.ifort create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.linux create mode 100644 wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r create mode 100644 wrfv2_fire/hydro/arc/macros.seq.gfort create mode 100644 wrfv2_fire/hydro/arc/macros.seq.ifort create mode 100644 wrfv2_fire/hydro/arc/macros.seq.linux create mode 100755 wrfv2_fire/hydro/configure create mode 100755 wrfv2_fire/hydro/wrf_hydro_config create mode 100644 wrfv2_fire/phys/module_bl_fogdes.F create mode 100644 wrfv2_fire/phys/module_cu_mesosas.F create mode 100644 wrfv2_fire/phys/module_diag_afwa.F create mode 100644 wrfv2_fire/phys/module_diag_cl.F create mode 100644 wrfv2_fire/phys/module_diag_misc.F create mode 100644 wrfv2_fire/phys/module_diag_pld.F create mode 100644 wrfv2_fire/phys/module_diag_refl.F delete mode 100644 wrfv2_fire/phys/module_diagnostics.F create mode 100644 wrfv2_fire/phys/module_diagnostics_driver.F create mode 100644 wrfv2_fire/phys/module_mp_fast_sbm.F create mode 100644 wrfv2_fire/phys/module_mp_full_sbm.F create mode 100644 wrfv2_fire/phys/module_ra_aerosol.F create mode 100644 wrfv2_fire/phys/module_sf_fogdes.F create mode 100644 wrfv2_fire/phys/module_sf_lake.F create mode 100644 wrfv2_fire/phys/module_sf_noahmp_groundwater.F delete mode 100644 wrfv2_fire/phys/module_wind_generic.F create mode 100644 wrfv2_fire/run/CCN_ACTIVATE.BIN create mode 100644 wrfv2_fire/run/bulkdens.asc_s_0_03_0_9 create mode 100644 wrfv2_fire/run/bulkradii.asc_s_0_03_0_9 create mode 100644 wrfv2_fire/run/capacity.asc create mode 100644 wrfv2_fire/run/coeff_p.asc create mode 100644 wrfv2_fire/run/coeff_q.asc create mode 100644 wrfv2_fire/run/constants.asc create mode 100644 wrfv2_fire/run/kernels.asc_s_0_03_0_9 create mode 100644 wrfv2_fire/run/kernels_z.asc create mode 100644 wrfv2_fire/run/masses.asc create mode 100644 wrfv2_fire/run/termvels.asc create mode 100644 wrfv2_fire/run/wind-turbine-1.tbl create mode 100644 wrfv2_fire/share/landread.c.dist create mode 100644 wrfv2_fire/test/em_quarter_ss/input_sounding_preWRFV3.6 create mode 100644 wrfv2_fire/test/em_quarter_ss/namelist.input_2to1 create mode 100644 wrfv2_fire/test/em_quarter_ss/namelist.input_3to1 create mode 100644 wrfv2_fire/test/em_quarter_ss/namelist.input_4to1 create mode 100644 wrfv2_fire/test/em_quarter_ss/namelist.input_5to1 create mode 100644 wrfv2_fire/test/em_real/wind-turbine-1.tbl create mode 100644 wrfv2_fire/test/em_real/windturbines.txt rename wrfv2_fire/test/em_seabreeze2d_x/{namelist.input.ideal => namelist.input.windfarm} (50%) delete mode 100644 wrfv2_fire/test/em_seabreeze2d_x/namelist.input.windspec delete mode 100644 wrfv2_fire/test/em_seabreeze2d_x/windspec.in create mode 100644 wrfv2_fire/test/nmm_real/namelist.input.HWRF delete mode 100644 wrfv2_fire/test/nmm_real/namelist.input.chem_nmm create mode 100644 wrfv2_fire/test/nmm_tropical_cyclone/README.NMM.TROPICAL_CYCLONE create mode 100644 wrfv2_fire/test/nmm_tropical_cyclone/input.d create mode 100644 wrfv2_fire/test/nmm_tropical_cyclone/namelist.input create mode 100644 wrfv2_fire/test/nmm_tropical_cyclone/namelist.wps create mode 100644 wrfv2_fire/test/nmm_tropical_cyclone/sigma.d create mode 100644 wrfv2_fire/test/nmm_tropical_cyclone/sound.d create mode 100644 wrfv2_fire/test/nmm_tropical_cyclone/sound_gfdl.d create mode 100644 wrfv2_fire/test/nmm_tropical_cyclone/sound_jordan.d create mode 100644 wrfv2_fire/test/nmm_tropical_cyclone/sound_wet.d create mode 100644 wrfv2_fire/test/nmm_tropical_cyclone/storm.center rename wrfv2_fire/tools/{fortran_2003_test.F => fortran_2003_ieee_test.F} (100%) create mode 100644 wrfv2_fire/tools/fortran_2003_iso_c_test.F diff --git a/wrfv2_fire/Makefile b/wrfv2_fire/Makefile index 83327f73..aa6a092a 100644 --- a/wrfv2_fire/Makefile +++ b/wrfv2_fire/Makefile @@ -77,7 +77,7 @@ all_wrfvar : $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" ext $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" toolsdir if [ $(CRTM) ] ; then \ - (cd var/external/crtm; \ + (cd var/external/crtm_2.1.3; \ export ABI_CRTM="${ABI_CRTM}"; . configure/$(SFC_CRTM).setup; $(MAKE) $(J) ) ; \ fi if [ $(BUFR) ] ; then \ @@ -123,7 +123,7 @@ em_fire : wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_fire/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_fire/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_fire/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -136,10 +136,20 @@ em_quarter_ss : wrf ( cd test/em_quarter_ss ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd test/em_quarter_ss ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . ) ( cd test/em_quarter_ss ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . ) + ( cd test/em_quarter_ss ; /bin/rm -f bulkdens.asc_s_0_03_0_9 ; ln -s ../../run/bulkdens.asc_s_0_03_0_9 . ) + ( cd test/em_quarter_ss ; /bin/rm -f bulkradii.asc_s_0_03_0_9 ; ln -s ../../run/bulkradii.asc_s_0_03_0_9 . ) + ( cd test/em_quarter_ss ; /bin/rm -f capacity.asc ; ln -s ../../run/capacity.asc . ) + ( cd test/em_quarter_ss ; /bin/rm -f coeff_p.asc ; ln -s ../../run/coeff_p.asc . ) + ( cd test/em_quarter_ss ; /bin/rm -f coeff_q.asc ; ln -s ../../run/coeff_q.asc . ) + ( cd test/em_quarter_ss ; /bin/rm -f constants.asc ; ln -s ../../run/constants.asc . ) + ( cd test/em_quarter_ss ; /bin/rm -f kernels.asc_s_0_03_0_9 ; ln -s ../../run/kernels.asc_s_0_03_0_9 . ) + ( cd test/em_quarter_ss ; /bin/rm -f kernels_z.asc ; ln -s ../../run/kernels_z.asc . ) + ( cd test/em_quarter_ss ; /bin/rm -f masses.asc ; ln -s ../../run/masses.asc . ) + ( cd test/em_quarter_ss ; /bin/rm -f termvels.asc ; ln -s ../../run/termvels.asc . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_quarter_ss/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_quarter_ss/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_quarter_ss/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -155,7 +165,7 @@ em_squall2d_x : wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_squall2d_x/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_squall2d_x/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_squall2d_x/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -171,7 +181,7 @@ em_squall2d_y : wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_squall2d_y/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_squall2d_y/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_squall2d_y/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -187,7 +197,7 @@ em_b_wave : wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_b_wave/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_b_wave/namelist.input . ) ( cd run ; /bin/rm -f input_jet ; ln -s ../test/em_b_wave/input_jet . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -203,7 +213,7 @@ em_les : wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_les/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_les/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_les/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -219,7 +229,7 @@ em_seabreeze2d_x : wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_seabreeze2d_x/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_seabreeze2d_x/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_seabreeze2d_x/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -233,7 +243,7 @@ em_tropical_cyclone : wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_tropical_cyclone/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_tropical_cyclone/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_tropical_cyclone/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -247,7 +257,7 @@ em_scm_xy : wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_scm_xy/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_scm_xy/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_scm_xy/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -302,6 +312,7 @@ em_real : wrf ln -sf ../../run/aerosol_lat.formatted . ; \ ln -sf ../../run/aerosol_lon.formatted . ; \ ln -sf ../../run/aerosol_plev.formatted . ; \ + ln -sf ../../run/CCN_ACTIVATE.BIN . ; \ if [ $(RWORDSIZE) -eq 8 ] ; then \ ln -sf ../../run/ETAMPNEW_DATA_DBL ETAMPNEW_DATA ; \ ln -sf ../../run/ETAMPNEW_DATA.expanded_rain_DBL ETAMPNEW_DATA.expanded_rain ; \ @@ -356,6 +367,17 @@ em_real : wrf ln -sf ../../run/aerosol_lat.formatted . ; \ ln -sf ../../run/aerosol_lon.formatted . ; \ ln -sf ../../run/aerosol_plev.formatted . ; \ + ln -sf ../../run/capacity.asc . ; \ + ln -sf ../../run/coeff_p.asc . ; \ + ln -sf ../../run/coeff_q.asc . ; \ + ln -sf ../../run/constants.asc . ; \ + ln -sf ../../run/masses.asc . ; \ + ln -sf ../../run/termvels.asc . ; \ + ln -sf ../../run/kernels.asc_s_0_03_0_9 . ; \ + ln -sf ../../run/kernels_z.asc . ; \ + ln -sf ../../run/bulkdens.asc_s_0_03_0_9 . ; \ + ln -sf ../../run/bulkradii.asc_s_0_03_0_9 . ; \ + ln -sf ../../run/CCN_ACTIVATE.BIN . ; \ if [ $(RWORDSIZE) -eq 8 ] ; then \ ln -sf ../../run/ETAMPNEW_DATA_DBL ETAMPNEW_DATA ; \ ln -sf ../../run/ETAMPNEW_DATA.expanded_rain_DBL ETAMPNEW_DATA.expanded_rain ; \ @@ -380,7 +402,7 @@ em_real : wrf ( cd run ; /bin/rm -f nup.exe ; ln -s ../main/nup.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_real/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -396,7 +418,7 @@ em_hill2d_x : wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_hill2d_x/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_hill2d_x/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_hill2d_x/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -412,7 +434,7 @@ em_grav2d_x : wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_grav2d_x/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_grav2d_x/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_grav2d_x/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -428,7 +450,7 @@ em_heldsuarez : wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_heldsuarez/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_heldsuarez/namelist.input . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -441,7 +463,7 @@ emi_conv : wrf ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_real/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) #### emissions opt 3 converter @@ -452,7 +474,7 @@ opt3_conv : wrf ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_real/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) #### biogenic emissions converter @@ -463,7 +485,7 @@ bio_conv : wrf ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_real/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) bioemiss_conv_megan2 : wrf @ echo '--------------------------------------' @@ -472,7 +494,7 @@ bioemiss_conv_megan2 : wrf ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_real/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) #### DMS emissions converter @@ -483,7 +505,7 @@ dms_conv : wrf ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_real/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) #### Dust errosion factor emissions converter @@ -495,7 +517,7 @@ dust_conv : wrf ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_real/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) #### GOCART background state for oh, no3 and h2o2 converter @@ -506,7 +528,7 @@ gocart_conv : wrf ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/em_real/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) #### nmm converter @@ -521,7 +543,7 @@ nmm_tropical_cyclone : nmm_wrf ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/nmm_tropical_cyclone/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/nmm_tropical_cyclone/namelist.input . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -554,13 +576,21 @@ nmm_real : nmm_wrf ( cd run ; /bin/rm -f real_nmm.exe ; ln -s ../main/real_nmm.exe . ) ( cd run ; if test -f namelist.input ; then \ /bin/cp -f namelist.input namelist.input.backup ; fi ; \ - /bin/rm -f namelist.input ; ln -s ../test/nmm_real/namelist.input . ) + /bin/rm -f namelist.input ; cp ../test/nmm_real/namelist.input . ) # semi-Lagrangian initializations +io : + @ echo '--------------------------------------' + ( cd tools ; $(MAKE) standard.exe ) + ( cd frame ; $(MAKE) io_only ) + ( cd frame ; $(MAKE) module_driver_constants.o pack_utils.o module_machine.o module_internal_header_util.o wrf_debug.o ) + ( cd frame ; $(AR) $(ARFLAGS) ../main/libwrflib.a module_driver_constants.o pack_utils.o module_machine.o \ + module_internal_header_util.o module_wrf_error.o wrf_debug.o ) + ext : @ echo '--------------------------------------' ( cd frame ; $(MAKE) externals ) @@ -598,7 +628,7 @@ shared : wrf_hydro : @ echo '----------wrf_hydro-----------------------' - if [ $(WRF_HYDRO) -eq 1 ] ; then (cd hydro/WRF_cpl; make -f Makefile.cpl) ; fi + if [ $(WRF_HYDRO) -eq 1 ] ; then (cd hydro/CPL/WRF_cpl; make -f Makefile.cpl) ; fi chemics : @ echo '--------------------------------------' @@ -644,8 +674,12 @@ nc4_test: @cd tools ; /bin/rm -f nc4_test.{exe,nc,o} ; $(SCC) -o nc4_test.exe nc4_test.c -I$(NETCDF)/include -L$(NETCDF)/lib -lnetcdf $(NETCDF4_DEP_LIB) ; cd .. # rule used by configure to test if Fortran 2003 IEEE signaling is available -fortran_2003_test: - @cd tools ; /bin/rm -f fortran_2003_test.{exe,o} ; $(SFC) -o fortran_2003_test.exe fortran_2003_test.F ; cd .. +fortran_2003_ieee_test: + @cd tools ; /bin/rm -f fortran_2003_ieee_test.{exe,o} ; $(SFC) -o fortran_2003_ieee_test.exe fortran_2003_ieee_test.F ; cd .. + +# rule used by configure to test if Fortran 2003 ISO_C support is available +fortran_2003_iso_c_test: + @cd tools ; /bin/rm -f fortran_2003_iso_c_test.{exe,o} ; $(SFC) -o fortran_2003_iso_c_test.exe fortran_2003_iso_c_test.F ; cd .. ### 3.b. sub-rule to build the expimental core diff --git a/wrfv2_fire/README b/wrfv2_fire/README index 80c4863b..63e8bca1 100644 --- a/wrfv2_fire/README +++ b/wrfv2_fire/README @@ -1,4 +1,4 @@ -WRF Model Version 3.5 (April 18, 2013) +WRF Model Version 3.6 (April 18, 2014) http://wrf-model.org/users/users.php ------------------------ @@ -27,6 +27,24 @@ infringement actions. This is the main directory for the WRF Version 3 source code release. ====================================== +V3.6 Release Notes (4/18/14) (rev 7412): +------------------- + +- For more information on WRF V3.6 release, visit WRF User's home pages + http://www.mmm.ucar.edu/wrf/users/, and + http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide. + +====================================== + +V3.5.1 Release Notes (9/23/13) (rev 6868): +------------------- + +- For more information on WRF V3.5.1 release, visit WRF User's home pages + http://www.mmm.ucar.edu/wrf/users/, and + http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide. + +====================================== + V3.5 Release Notes (4/18/13) (rev 6660): ------------------- @@ -182,6 +200,10 @@ WRF update history: - V3.2.1: August 18, 2010 - V3.3: April 6, 2011 - V3.3.1: Sept 16, 2011 +- V3.4: April 6, 2012 +- V3.4.1: Aug 16, 2012 +- V3.5: April 18, 2013 +- V3.5.1: Sept 23, 2013 ====================================== @@ -297,13 +319,14 @@ What is in WRF V3? - Physics options: * microphysics (Kessler/ WRF Single Moment 3, 5 and 6 classes / Lin et al./ Mibrandt 2-moment / Eta Ferrier / Thompson / Goddard / 2-moment Morrison / WRF Double Moment 5 and 6 classes / - SBU-Lin 5-classes / NSSL 2-moment and 1-moment / CAM 5.1 ) + SBU-Lin 5-classes / NSSL 2-moment and 1-moment / CAM 5.1 ) / Thompson aerosol-aware / + HUJI full and fast SBM * cumulus parameterization (Kain-Fritsch with shallow convection / Betts-Miller-Janjic / Grell-Devenyi ensemble / Grell 3D (with shallow convection option) / Grell-Freitas ensemble / Tiedtke (with shallow conv and momentum transport) / NSAS (with shallow conv and momentum transport) / SAS (with shallow conv for ARW) / Zhang-McFarlane (with momentum transport) ) - * UW shallow convection + * UW shallow convection / GRIMS shallow convection * planetary boundary layer (Yosei University / Mellor-Yamada-Janjic / ACM2 / QNSE-EDMF / MYNN / BouLac / UW / TEMF / Grenier-Bretherton-McCaa ) * slab soil model (5-layer thermal diffusion / Noah land-surface model (4 levels) / @@ -322,9 +345,10 @@ What is in WRF V3? * Options for modifying SST, sea ice, vegetation fraction, albedo, and deep soil temp for long simulations * fractional sea ice option for polar regions; modified snow/ice physics - * single-column ocean mixed layer model - * 3D Price-Weller-Pinkel (PWP) ocean model + * single-column ocean mixed layer model / 3D Price-Weller-Pinkel (PWP) ocean model * drag and enthalpy flux formulation for hurricane applications + * CLM lake model + * windfarm drag - Nudging: * three-dimensional and surface analysis nudging diff --git a/wrfv2_fire/README.DA b/wrfv2_fire/README.DA index d7278d87..be7c2be3 100644 --- a/wrfv2_fire/README.DA +++ b/wrfv2_fire/README.DA @@ -22,6 +22,55 @@ WRFDA, including infringement actions. This is the main directory for the WRFDA Version 3 source code release. ====================================== +V3.6 Release Notes : +------------------- + +Version 3.6 was released on April 18, 2014. + + For more information on WRFDA, visit the WRFDA Users home page + http://www.mmm.ucar.edu/wrf/users/wrfda/index.html + + New features: + + -Dual-resolution hybrid assimilation has been implemented + -New instruments can be assimilated: + -Meteosat SEVIRI + -Metop-B instruments + -AIREP humidity observations + -Observation thinning for conventional observations in ASCII format + + Updated features: + + -GPS Radio Occultation data can now be read separately from other conventional data types + -Wind speed/direction assimilation has been updated, and namelist options have changed. See the + relevant section of the User's Guide for more information. + -Updated libraries: + -CRTM Version 2.1.3 + -BUFR Version 10.2.3 + -RTTOV interface is now for RTTOV Version 11.1 + -Bug fixes and performance improvements + -WRFPLUS has been upgraded to V3.6. + +====================================== +V3.5.1 Release Notes : +------------------- + +Version 3.5.1 is released on September 23, 2013. + + For more information on WRFDA, visit the WRFDA Users home page + http://www.mmm.ucar.edu/wrf/users/wrfda/index.html + + + The following bugs have been fixed: + -BUFR libraries have been updated to allow WRFDA to read and assimilate NCEP PREPBUFR files of + any endianness. + -Compilation failure with some older Fortran95 compilers + -A problem with Variational Bias Correction (VARBC) on some platforms + -A problem with OBSPROC's built-in observation error file (obserr.txt) on some platforms + -A bug causing failures when "print_detail_outerloop=true" + -A few more miscellaneous fixes + +====================================== V3.5 Release Notes : ------------------- @@ -32,7 +81,8 @@ Version 3.5 is released on April 18. 2013. New features: - -Wind Speed/Direction Assimilation: Wind speed/direction observations can now be directly assimilated. + -Wind Speed/Direction Assimilation: Wind speed/direction observations can now be directly + assimilated. -New satellite instruments can be assimilated: -METOP Infrared Atmospheric Sounding Interferometer (IASI) -NPP Advanced Technology Microwave Sounder (ATMS) @@ -44,7 +94,8 @@ Version 3.5 is released on April 18. 2013. Yellowstone have been added. -Updated I/O for improved back-compatability with previous versions of WRF and WRFDA -WRFDA-3DVAR can now read two different PREPBUFR observation files at once - -The "ntmax" namelist variable is now a vector, and can be set to a different value for each outer loop + -The "ntmax" namelist variable is now a vector, and can be set to a different value for each + outer loop -WRFPLUS has been upgraded to V3.5 and it is consistent with the released WRF version 3.5. ====================================== @@ -67,7 +118,8 @@ V3.4 Release Notes : Version 3.4 is released on April 6, 2012. -- The WRFPLUS (WRF adjoint and tangent linear model) has been upgraded to V3.4 and it is consistent with the released WRF version 3.4. Added parallel WRF TL/AD based on WRF 3.4. +- The WRFPLUS (WRF adjoint and tangent linear model) has been upgraded to V3.4 and it is consistent + with the released WRF version 3.4. Added parallel WRF TL/AD based on WRF 3.4. - WRFDA 4D-Var now supports compilation to run in parallel. @@ -84,7 +136,8 @@ V3.3.1 Release Notes : Version 3.3.1 is released on September 27, 2011. -- WRF 4D-Var has been improved on lateral boundary condition control, analysis scheme for surface observation etc. +- WRF 4D-Var has been improved on lateral boundary condition control, analysis scheme for surface + observation etc. - Lots of bug fixes. @@ -222,7 +275,8 @@ WRFDA update history: - V3.4: Apr 6, 2012 - V3.4.1: Aug 16, 2012 - V3.5: Apr 18, 2013 - +- V3.5.1: Sep 23, 2013 +- V3.6: Apr 15, 2014 ====================================== How to compile and run? diff --git a/wrfv2_fire/README.hydro b/wrfv2_fire/README.hydro index 8e2509a6..7150d846 100644 --- a/wrfv2_fire/README.hydro +++ b/wrfv2_fire/README.hydro @@ -71,7 +71,7 @@ The basic steps to do so are as follows: 1) Edit "hydro/configure", and add "exit(0);" to the second line so that "configure" will not be executed. 2) Edit "hydro/macros" to set desired compiling options. -3) Under hydro/WRF_cpl directory: +3) Under hydro/CPL/WRF_cpl directory: "make -f Makefile.cpl clean" "make -f Makefile.cpl " diff --git a/wrfv2_fire/README.windturbine b/wrfv2_fire/README.windturbine index b916c966..3b1b6edb 100644 --- a/wrfv2_fire/README.windturbine +++ b/wrfv2_fire/README.windturbine @@ -1,96 +1,115 @@ README for wind turbine drag parameterization schemes, added 20101220. JM + The code was modified to introduce the power curve and the thrust + coefficient using tables. The parameterization is activated in the + physics part of the namelist. + NOTE: For V3.6 (April 2014) the namelist options and idealized set-up + have been changed. Further description below and in README.namelist. + The scheme is now activated with windfarm_opt = 1 in the physics namelist. -*Compiling the code.* no different from normal -*Running the code.* There are new variables added to the phys block of -the namelist.input file. The string valued variable windturbines_spec -controls the overall operation of the scheme. If it's set to "none" -(quotes included) the wind turbine scheme is off. If it's set to -"ideal", the turbine drag scheme is in idealized mode and other namelist -variables in the block control the geometry and characteristics of the -wind farm. If it's set to the name of a file in the run directory -- -for example, "windspec.in" -- then the scheme is on and the location and -characteristics of each turbine is set individually from the contents of -that file. Which scheme is active will be controlled by another variable -TBD (not yet implemented, since there's only one scheme right now). - -*Idealized configuration.* If windturbines_spec is set to "ideal", the -geometry and characteristics of the farm are controlled by the following -additional variables in the phys block of the namelist.input file: - - name type sample description - value - turbgridid integer 1 id of the WRF domain containing the farm - hubheight real 100. height in meters of all turbine hubs in farm - diameter real 100. diameter in meters of all turbine rotors in farm - stdthrcoef real 0.158 standing thrust coefficient of all turbines in farm - cutinspeed real 3.5 cut in speed (m/s) of all turbines in farm - cutoutspeed real 30. cut out speed (m/s) of all turbines in farm - power real 5.0 nominal power (MW) of all turbines in farm - turbpercell real 1.0 number of turbines per grid cell - ewfx integer 10 x-extent of rectangular wind farm in grid cells - ewfy integer 10 y-extent of rectangular wind farm in grid cells - pwfx integer 45 x-coordinate of grid cell in sw corner of farm - pwfy integer 45 y-coordinate of grid cell in sw corner of farm - - -*Real-world configuration.* The location and characteristics of each -turbine is specified individually in the file named by the variable -windturbines_spec. Each line of the file specifies one turbine. -The entries of a line are separated by spaces. The entries are listed -in order on the line and specify the following, by position on the line: - - 1. The WRF grid id into which the turbine is placed [integer] - 2. True latitude of the wind turbine in degrees [real] - 3. True longitude of the wind turbine in degrees [real] - 4. Height in meters of the turbine hub [real] - 5. Diameter in meters of the rotor [real] - 6. Standing thrust coefficient [real] - 7. Nominal power of turbine (MW) [real] - 8. Cutin speed (m/s) [real] - 9. Cutout speed (m/s) [real] +*Specific note for the Fitch scheme.* -The location of each turbine is specified using the lat and lon elements -for the turbine's entry in the windspec file. That is, the i,j index -in the grid is computed from the true latitude (entry 2) and the true -longitude (entry 3). The coordinate in the j dimension is computed by -checking true latitude against the LAT_V field in the wrfinput initial -conditions file. The i dimension is computed by checking the true -longitude against LONG_U field in the wrfinput file. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! NOTICE +!! The following paper should be cited whenever presenting results using this scheme +!! (using either the original version or any modified versions of the scheme): +!! Fitch, A. C. et al. 2012: Local and Mesoscale Impacts of Wind Farms as Parameterized in a +!! Mesoscale NWP Model. Monthly Weather Review, doi:http://dx.doi.org/10.1175/MWR-D-11-00352.1 +!! +!! Anna C. Fitch, National Center for Atmospheric Research (formerly University of Bergen) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -*Pseudo-real configuration.* This mode is only for testing the real-world -specification mechanism. The contents of the windspec.in file in the -em_seabreeze2d_x directory contains a specification that is identical -to the ideal specification shown above. However, instead of true -latitude and true longitude, elements 2 and 3 of each entry specify -the i,j grid coordinates of the turbine. The code knows to treat -these as grid coordinates instead of latitude and longitude because -for idealized WRF cases, the LAT and LONG fields in wrfinput files are -set to all zero. When the model reads a wrfinput file for an idealized -case, it checks to see if the lat and lon fields of the case have data -in them or if they are just zeros. If they do not have data in them -(just have zeros) fields 2 and 3 of the windspec file are treated as i,j -coordinates are used. A sample windspec file for a pseudo-real run is -in test/em_seabreeze2d_x/windspec.in). - -*Specific note for the Fitch scheme.* The Fitch scheme is based on -Blahak et al, 2010, of Wetter Jetzt GbR. The specific implementation -comes from Anna Fitch, Alok Gupta, and Idar Barstad at Uni Bergen, +The Fitch scheme is based on Blahak et al. (2010) of Wetter Jetzt GbR. +It differs in that the kinetic energy (KE) extracted is based on the +thrust coefficient of the turbine (representing the total fraction of KE extracted +from the atmosphere due to the turbine), rather than the power coefficient plus an +estimated loss factor. In addition the TKE generated is a function of wind speed. +The thrust coefficients and the power curve should be obtained from the turbine manufacturer +for the turbines of interest and incorporated into a table as described below. +If you do not have access to these data an idealized wind turbine is provided in this +release (./run/wind-turbine-1.tbl). It is strongly recomended to use the data from the manufacturer. +The parameterization works with the MYNN PBL and modifies the QKE field representing 2xTKE +to include the TKE produced by wind turbines. QKE can be advected as a part +of the scalar 4D tracer array in WRF using the bl_mynn_tkeadvect switch for each domain (default =.false.) + +It is not recommended to run the parameterization at resolutions higher than 5 rotor diameters - +at this resolution rotation of the rotor blades should be included (not represented in the current +model). See 1st reference below and Wu and Porte-Agel (2011) and Porte-Agel et al. (2011). + +The specific implementation comes from Anna Fitch, Alok Gupta, and Idar Barstad at Uni Bergen, Norway. It was added to this release of WRF by Jimy Dudhia, Joe Olson (NOAA), Julie Lundquist (U. Colorado/NREL), and John Michalakes (NREL). -It works with the MYNN PBL and modifies the QKE field representing 2xTKE -to include the TKE produced by wind turbines. QKE is advected as a part -of the scalar 4D tracer array in WRF. +Further development comes from Pedro A. Jimenez (CIEMAT/NCAR) who introduced the capability +of introducing the manufacturer information via user specified tables as well as other functionalities. + +References: +Fitch, A. C. et al. 2012: Local and Mesoscale Impacts of Wind Farms as Parameterized in a + Mesoscale NWP Model. Monthly Weather Review, doi:http://dx.doi.org/10.1175/MWR-D-11-00352.1 +Fitch, A. C. et al. 2013: Mesoscale Influences of Wind Farms Throughout a Diurnal Cycle. + Monthly Weather Review, doi:http://dx.doi.org/10.1175/MWR-D-12-00185.1 +Fitch, A. C. et al. 2013: Parameterization of Wind Farms in Climate Models. + Journal of Climate, doi:http://dx.doi.org/10.1175/JCLI-D-12-00376.1 +Jimenez, P.A., J. Navarro, A.M. Palomares and J. Dudhia: Mesoscale modeling of offshore + wind turbines wakes at the wind farm resolving scale: a composite-based analysis with + the WRF model over Horns Rev. Wind Energy, (In Press.). DOI: 10.1002/we.1708 + +*Compiling the code.* no different from normal -References: +*Running the code* To activate the parameterization the user needs +to set the domain dependent variable windfarm_opt to 1 in the physics part of the +namelist. WRF is expected to find a file called "windturbines.txt". Each line of +the file specifies one turbine. The entries of a line are separated by spaces. +The entries are listed in order on the line and specify the following, +by position on the line: -Fitch, A. C., J. B. Olson, J. K. Lundquist, J. Dudhia, A. K. Gupta, -J. Michalakes, and I. Barstad, 2012: Local and Mesoscale Impacts -of Wind Farms as Parameterized in a Mesoscale NWP Model. -Monthly Weather Review, doi:10.1175/MWR-D-11-00352.1. + 1. True latitude of the wind turbine in degrees [real] + 2. True longitude of the wind turbine in degrees [real] + 3. Turbine type [integer] -Fitch, A. C., J. K. Lundquist, and J. B. Olson, 2012: Mesoscale -Influences of Wind Farms Throughout a Diurnal Cycle. -Monthly Weather Review, in press. -doi: http://journals.ametsoc.org/doi/abs/10.1175/MWR-D-12-00185.1 +For example: + 55.574051 6.883480 1 + 55.569066 6.884697 1 + 30.000000 -77.000000 1 + +The location of each turbine is specified using the lat and lon elements +for the turbine's entry in the windturbines.txt file. That is, the i, j index +in the grid is computed from the true latitude (entry 1) and the true +longitude (entry 2). The type of turbine (entry 3) points to the file that + contains the turbine specifications. If the turbine type is set to 1, WRF is expecting +to find the file wind-turbine-1.tbl. The first line of the table is an integer, + N, indicating the number of pairs entries for the power curve and the +thrust coefficient; the second line contains 4 real values specifying the + characteristics of the turbine: + +1.- Height in meters of the turbine hub [real] +2.- Diameter in meters of the rotor [real] +3.- Standing thrust coefficient [real] +4.- Nominal power of turbine (MW) [real] + + and the following N lines contain 3 real values with the + wind speed, thrust coefficient and power production (kW). + + For example: + +23 +80. 85. 0.1 2.0 +3. 0.7 80. | +4. 0.75 150. | +..... | + | 23 lines +..... | +25. 0.05 2000.0 | + +*Pseudo-real configuration.* This mode is only for testing the real-world +specification mechanism. This option allows to define the position of the +turbines using the i and j coordinates on the grid instead of the latitude +and longitude. To activate this option the user needs to set the variable +windfarm_ij to 1 in the physics part of the namelist. WRF is expecting to +find a file "windturbines-ij.txt". Each line of the file is associated with +a turbine and each line has three columns corresponding to the I (entry 1), J + (entry 2) and kind of turbine (entry 3). +For example: +10 10 1 +10 10 1 +10 11 1 diff --git a/wrfv2_fire/Registry/Registry.CONVERT b/wrfv2_fire/Registry/Registry.CONVERT index 134964a3..2e0423dd 100644 --- a/wrfv2_fire/Registry/Registry.CONVERT +++ b/wrfv2_fire/Registry/Registry.CONVERT @@ -299,7 +299,7 @@ rconfig integer num_land_cat namelist,physics 1 24 rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" -rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig real seaice_threshold namelist,physics 1 100 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" rconfig integer co2tf namelist,physics 1 0 - "GFDL radiation co2 flag" "" "" @@ -309,9 +309,9 @@ rconfig integer co2tf namelist,physics 1 0 rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" # diff_opt 1=old diffusion, 2=new -rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +rconfig integer diff_opt namelist,dynamics max_domains -1 irh "diff_opt" "" "" # km_opt 1=old coefs, 2=tke, 3=Smagorinksy -rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer km_opt namelist,dynamics max_domains -1 irh "km_opt" "" "" rconfig integer damp_opt namelist,dynamics 1 0 irh "damp_opt" "" "" rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" rconfig real dampcoef namelist,dynamics max_domains 0. h "dampcoef" "" "" @@ -483,7 +483,7 @@ package swradscheme ra_sw_physics==1 - - package gsfcswscheme ra_sw_physics==2 - - package gfdlswscheme ra_sw_physics==99 - - -package sfclayscheme sf_sfclay_physics==1 - - +package sfclayscheme sf_sfclay_physics==91 - - package myjsfcscheme sf_sfclay_physics==2 - - package gfssfcscheme sf_sfclay_physics==3 - - package slabscheme sf_surface_physics==1 - - diff --git a/wrfv2_fire/Registry/Registry.EM b/wrfv2_fire/Registry/Registry.EM index 524553ad..d1796307 100644 --- a/wrfv2_fire/Registry/Registry.EM +++ b/wrfv2_fire/Registry/Registry.EM @@ -12,17 +12,21 @@ include registry.les include registry.cam include registry.clm include registry.ssib +include registry.lake include registry.diags +include registry.sbm include registry.bdy_perturb # added to output 5 for ESMF -state real landmask ij misc 1 - i0125rh05d=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" +state real landmask ij misc 1 - i0125rh05d=(interp_fcnm_imask)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" +state real lakemask ij misc 1 - i012rhd=(interp_fcnm_imask)u=(copy_fcnm) "LAKEMASK" "LAKE MASK (1 FOR LAKE, 0 FOR NON-LAKE)" "" # Masked SST interpolation from the CG -#state real SST ij misc 1 - i01245rh05d=(interp_mask_water_field:lu_index,iswater)f=(p2c_mask:lu_index,tslb,num_soil_layers,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" +#state real SST ij misc 1 - i01245rh05d=(interp_mask_field:lu_index,iswater)f=(p2c_mask:lu_index,tslb,num_soil_layers,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" # Simple SST interpolation from the CG -#state real SST ij misc 1 - i01245rh05d=(interp_mask_water_field:lu_index,iswater)f=(p2c) "SST" "SEA SURFACE TEMPERATURE" "K" -state real SST ij misc 1 - i01245rh05d=(interp_mask_water_field:lu_index,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" +#state real SST ij misc 1 - i01245rh05d=(interp_mask_field:lu_index,iswater)f=(p2c) "SST" "SEA SURFACE TEMPERATURE" "K" +state real SST ij misc 1 - i01245rh05d=(interp_mask_field:lu_index,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" +state real SST_INPUT ij misc 1 - rh "SST_INPUT" "SEA SURFACE TEMPERATURE FROM WRFLOWINPUT FILE" "K" # Registry entries that are exclusive to Registry.EM diff --git a/wrfv2_fire/Registry/Registry.EM_CHEM b/wrfv2_fire/Registry/Registry.EM_CHEM index 586a38ff..782d61ab 100644 --- a/wrfv2_fire/Registry/Registry.EM_CHEM +++ b/wrfv2_fire/Registry/Registry.EM_CHEM @@ -11,14 +11,18 @@ include registry.stoch include registry.les include registry.cam include registry.clm +include registry.lake include registry.ssib +include registry.sbm include registry.diags include registry.bdy_perturb -state real landmask ij misc 1 - i012rh0d=(interp_fcnm)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" +state real landmask ij misc 1 - i012rh0d=(interp_fcnm_imask)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" +state real lakemask ij misc 1 - i012rh0d=(interp_fcnm_imask)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" # Masked SST interpolation from the CG -#state real SST ij misc 1 - i0124rh0d=(interp_mask_water_field:lu_index,iswater)f=(p2c_mask:lu_index,tslb,num_soil_layers,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" +#state real SST ij misc 1 - i0124rh0d=(interp_mask_field:lu_index,iswater)f=(p2c_mask:lu_index,tslb,num_soil_layers,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" # Simple SST interpolation from the CG -#state real SST ij misc 1 - i0124rh0d=(interp_mask_water_field:lu_index,iswater)f=(p2c) "SST" "SEA SURFACE TEMPERATURE" "K" -state real SST ij misc 1 - i0124rh0d=(interp_mask_water_field:lu_index,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" +#state real SST ij misc 1 - i0124rh0d=(interp_mask_field:lu_index,iswater)f=(p2c) "SST" "SEA SURFACE TEMPERATURE" "K" +state real SST ij misc 1 - i0124rh0d=(interp_mask_field:lu_index,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" +state real SST_INPUT ij misc 1 - rh "SST_INPUT" "SEA SURFACE TEMPERATURE FROM WRFLOWINPUT FILE" "K" diff --git a/wrfv2_fire/Registry/Registry.EM_COMMON b/wrfv2_fire/Registry/Registry.EM_COMMON index 6a8972d6..5d2a7c37 100644 --- a/wrfv2_fire/Registry/Registry.EM_COMMON +++ b/wrfv2_fire/Registry/Registry.EM_COMMON @@ -50,12 +50,14 @@ # table entries are of the form # # +state real XLAT ij misc 1 - i0123rh01du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG ij misc 1 - i0123rh01du=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" # It is required that LU_INDEX appears before any variable that is # interpolated with a mask, as lu_index supplies that mask. # this next 1 is for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling # with wave model, only if compiled with -DMCELIO, JM 2003/05/29 -state real LU_INDEX ij misc 1 - i012rh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" +state real LU_INDEX ij misc 1 - i012rh01d=(interp_fcnm_lu:xlat,xlong,dx,grid_id)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" # znw, znu, dzs, and zs must be listed before any 3-d fields @@ -99,6 +101,7 @@ state real sct_dom_gc ij dyn_em 1 - i1 "SCT_DOM" state real scb_dom_gc ij dyn_em 1 - i1 "SCB_DOM" "Dominant soil (bottom) category from GEOGRID" "cat" state real greenfrac imj dyn_em 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" state real albedo12m imj dyn_em 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real lai12m imj dyn_em 1 Z i1 "LAI12M" "monthly LAI" "m2/m2" state real pd_gc igj dyn_em 1 Z - "PD" "dry pressure" "Pa" state real pdrho_gc igj dyn_em 1 Z - "PDRHO" "dry pressure for UM data for the variables U and V" "Pa" state real psfc_gc ij dyn_em 1 - - "PSFC_GC" "surface pressure" "Pa" @@ -113,8 +116,36 @@ state real qs_gc igj dyn_em 1 Z i1 "QS" " state real qi_gc igj dyn_em 1 Z i1 "QI" "cloud ice mixing ratio" "kg kg-1" state real qg_gc igj dyn_em 1 Z i1 "QG" "graupel mixing ratio" "kg kg-1" state real qh_gc igj dyn_em 1 Z i1 "QH" "hail mixing ratio" "kg kg-1" -state real qni_gc igj dyn_em 1 Z i1 "QNI" "ice no concentration" "m-3" -state real qnr_gc igj dyn_em 1 Z i1 "QNR" "rain no concentration" "m-3" +state real qni_gc igj dyn_em 1 Z i1 "QNI" "ice num concentration" "m-3" +state real qnr_gc igj dyn_em 1 Z i1 "QNR" "rain num concentration" "m-3" +state real qnwfa_now igj dyn_em 1 Z - "QNWFA_NOW" "num water-friendly aerosol Now" "kg-1" +state real qnwfa_jan igj dyn_em 1 Z i1 "QNWFA_JAN" "num water-friendly aerosol Jan" "kg-1" +state real qnwfa_feb igj dyn_em 1 Z i1 "QNWFA_FEB" "num water-friendly aerosol Feb" "kg-1" +state real qnwfa_mar igj dyn_em 1 Z i1 "QNWFA_MAR" "num water-friendly aerosol Mar" "kg-1" +state real qnwfa_apr igj dyn_em 1 Z i1 "QNWFA_APR" "num water-friendly aerosol Apr" "kg-1" +state real qnwfa_may igj dyn_em 1 Z i1 "QNWFA_MAY" "num water-friendly aerosol May" "kg-1" +state real qnwfa_jun igj dyn_em 1 Z i1 "QNWFA_JUN" "num water-friendly aerosol Jun" "kg-1" +state real qnwfa_jul igj dyn_em 1 Z i1 "QNWFA_JUL" "num water-friendly aerosol Jul" "kg-1" +state real qnwfa_aug igj dyn_em 1 Z i1 "QNWFA_AUG" "num water-friendly aerosol Aug" "kg-1" +state real qnwfa_sep igj dyn_em 1 Z i1 "QNWFA_SEP" "num water-friendly aerosol Sep" "kg-1" +state real qnwfa_oct igj dyn_em 1 Z i1 "QNWFA_OCT" "num water-friendly aerosol Oct" "kg-1" +state real qnwfa_nov igj dyn_em 1 Z i1 "QNWFA_NOV" "num water-friendly aerosol Nov" "kg-1" +state real qnwfa_dec igj dyn_em 1 Z i1 "QNWFA_DEC" "num water-friendly aerosol Dec" "kg-1" +state real qnifa_now igj dyn_em 1 Z - "QNIFA_NOW" "num ice-friendly aerosol Now" "kg-1" +state real qnifa_jan igj dyn_em 1 Z i1 "QNIFA_JAN" "num ice-friendly aerosol Jan" "kg-1" +state real qnifa_feb igj dyn_em 1 Z i1 "QNIFA_FEB" "num ice-friendly aerosol Feb" "kg-1" +state real qnifa_mar igj dyn_em 1 Z i1 "QNIFA_MAR" "num ice-friendly aerosol Mar" "kg-1" +state real qnifa_apr igj dyn_em 1 Z i1 "QNIFA_APR" "num ice-friendly aerosol Apr" "kg-1" +state real qnifa_may igj dyn_em 1 Z i1 "QNIFA_MAY" "num ice-friendly aerosol May" "kg-1" +state real qnifa_jun igj dyn_em 1 Z i1 "QNIFA_JUN" "num ice-friendly aerosol Jun" "kg-1" +state real qnifa_jul igj dyn_em 1 Z i1 "QNIFA_JUL" "num ice-friendly aerosol Jul" "kg-1" +state real qnifa_aug igj dyn_em 1 Z i1 "QNIFA_AUG" "num ice-friendly aerosol Aug" "kg-1" +state real qnifa_sep igj dyn_em 1 Z i1 "QNIFA_SEP" "num ice-friendly aerosol Sep" "kg-1" +state real qnifa_oct igj dyn_em 1 Z i1 "QNIFA_OCT" "num ice-friendly aerosol Oct" "kg-1" +state real qnifa_nov igj dyn_em 1 Z i1 "QNIFA_NOV" "num ice-friendly aerosol Nov" "kg-1" +state real qnifa_dec igj dyn_em 1 Z i1 "QNIFA_DEC" "num ice-friendly aerosol Dec" "kg-1" +state real qntemp imj dyn_em 1 Z - "QNTEMP" "temporary var for time interp" "" +state real qntemp2 ij dyn_em 1 - - "QNTEMP2" "temporary var2D for time interp" "" state real t_max_p ij dyn_em 1 - i0d "T_MAX_P" "temperature at max pressure" "K" state real ght_max_p ij dyn_em 1 - i0d "GHT_MAX_P" "geopotential height at max pressure" "m" state real max_p ij dyn_em 1 - i0d "MAX_P" "max pressure " "Pa" @@ -303,7 +334,7 @@ i1 real alpha ikj dyn_em 1 - i1 real a ikj dyn_em 1 - i1 real gamma ikj dyn_em 1 - i1 real c2a ikj dyn_em 1 - - -i1 real rho ikj dyn_em 1 - - +state real rho ikj misc 1 - r "RHO" "DENSITY" "Kg m-3" i1 real phm ikj dyn_em 1 - - i1 real cqu ikj dyn_em 1 - - i1 real cqv ikj dyn_em 1 - - @@ -370,6 +401,8 @@ state integer number_at_same_level - - - - - state real radtacttime - - - - r "radtacttime" "RADTACTTIME" "LW SW ACTIVATION TIME in s" state real bldtacttime - - - - r "bldtacttime" "BLDTACTTIME" "PBL ACTIVATION TIME in s" state real cudtacttime - - - - r "cudtacttime" "CUDTACTTIME" "CPS ACTIVATION TIME in s" +state real power ij misc 1 - irh "Power" "Power production" "W" + # State for derived time quantities. state integer itimestep - - - - rh "itimestep" "" "" @@ -438,7 +471,16 @@ state real dfi_qg ikjftb dfi_moist 1 - \ state real dfi_qh ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QHAIL" "Hail mixing ratio" "kg kg-1" state real rimi ikj misc 1 - irh "RIMI" "riming intensity" "fraction" - +state real qnwfa2d ij misc 1 - rhdu "QNWFA2D" "Surface aerosol number conc emission" "kg-1 s-1" +state real re_cloud ikj misc 1 - r "RE_CLOUD" "Effective radius cloud water" "m" +state real re_ice ikj misc 1 - r "RE_ICE" "Effective radius cloud ice" "m" +state real re_snow ikj misc 1 - r "RE_SNOW" "Effective radius snow" "m" +state real dfi_re_cloud ikj misc 1 - - "DFI_RE_CLOUD" "DFI Effective radius cloud water" "m" +state real dfi_re_ice ikj misc 1 - - "DFI_RE_ICE" "DFI Effective radius cloud ice" "m" +state real dfi_re_snow ikj misc 1 - - "DFI_RE_SNOW" "DFI Effective radius snow" "m" +state integer has_reqc - misc 1 - r "has_reqc" "Flag for having effective radius cloud water" "" +state integer has_reqi - misc 1 - r "has_reqi" "Flag for having effective radius cloud ice" "" +state integer has_reqs - misc 1 - r "has_reqs" "Flag for having effective radius snow" "" # Other Scalars state real - ikjftb scalar 1 - - - @@ -460,34 +502,43 @@ state real qnn ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QNCCN" "CCN Number concentration" "# kg(-1)" state real qnc ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" +state real qnwfa ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" +state real qnifa ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" state real qvolg ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" #state real qvolh ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QVHAIL" "Hail Particle Volume" "m(3) kg(-1)"" + state real - ikjftb dfi_scalar 1 - - - state real dfi_qndrop ikjftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNDROP" "Droplet number mixing ratio" "# kg-1" + rusdf=(bdy_interp:dt) "DFI_QNDROP" "DFI Droplet number mixing ratio" "# kg-1" state real dfi_qni ikjftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNICE" "Ice Number concentration" "# kg-1" + rusdf=(bdy_interp:dt) "DFI_QNICE" "DFI Ice Number concentration" "# kg-1" state real dfi_qt ikjftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_CWM" "Total condensate mixing ratio" "kg kg-1" + rusdf=(bdy_interp:dt) "DFI_CWM" "DFI Total condensate mixing ratio" "kg kg-1" state real dfi_qns ikjftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNSNOW" "Snow Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNSNOW" "DFI Snow Number concentration" "# kg(-1)" state real dfi_qnr ikjftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNRAIN" "Rain Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNRAIN" "DFI Rain Number concentration" "# kg(-1)" state real dfi_qng ikjftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "DFI Graupel Number concentration" "# kg(-1)" state real dfi_qnh ikjftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNHAIL" "Hail Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNHAIL" "DFI Hail Number concentration" "# kg(-1)" state real dfi_qnn ikjftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNCC" "CNN Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNCC" "DFI CNN Number concentration" "# kg(-1)" state real dfi_qnc ikjftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "Cloud Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "DFI Cloud Number concentration" "# kg(-1)" +state real dfi_qnwfa ikjftb dfi_scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "DFI_QNWFA" "DFI water-friendly aerosol number con" "# kg(-1)" +state real dfi_qnifa ikjftb dfi_scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" state real dfi_qvolg ikjftb dfi_scalar 1 - \ - rhusdf=(bdy_interp:dt) "DFI_QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" + rhusdf=(bdy_interp:dt) "DFI_QVGRAUPEL" "DFI Graupel Particle Volume" "m(3) kg(-1)" #state real dfi_qvolh ikjftb dfi_scalar 1 - \ - rhusdf=(bdy_interp:dt) "DFI_QVHAIL" "Hail Particle Volume" "m(3) kg(-1)" + rhusdf=(bdy_interp:dt) "DFI_QVHAIL" "DFI Hail Particle Volume" "m(3) kg(-1)" #----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -558,8 +609,8 @@ state real toposlpx ij misc 1 - i012rdu "TOPO state real toposlpy ij misc 1 - i012rdu "TOPOSLPY" "ELEVATION Y SLOPE" "" state real slope ij misc 1 - rdu "SLOPE" "ELEVATION SLOPE" "" state real slp_azi ij misc 1 - rdu "SLP_AZI" "ELEVATION SLOPE AZIMUTH" "rad" -state real shdmax ij misc 1 - i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SHDMAX" "ANNUAL MAX VEG FRACTION" "" -state real shdmin ij misc 1 - i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SHDMIN" "ANNUAL MIN VEG FRACTION" "" +state real shdmax ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SHDMAX" "ANNUAL MAX VEG FRACTION" "" +state real shdmin ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SHDMIN" "ANNUAL MIN VEG FRACTION" "" state real snoalb ij misc 1 - i012rh "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" state real slopecat ij misc 1 - i12 "SLOPECAT" "SLOPE CATEGORY" "" state real toposoil ij misc 1 - i12 "SOILHGT" "ELEVATION OF LSM DATA" "m" @@ -575,7 +626,7 @@ state real vegcat ij misc 1 - i12 "VEGC # soil model variables (Note that they are marked as staggered in the vertical dimension # because they are "fully dimensioned" -- they use every element in that dim -state real TSLB ilj misc 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TSLB" "SOIL TEMPERATURE" "K" +state real TSLB ilj misc 1 Z i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TSLB" "SOIL TEMPERATURE" "K" # Time series variables state real ts_hour ?! misc - - - "TS_HOUR" "Model integration time, hours" @@ -632,43 +683,47 @@ state real ZDR_URB2D i{udr}j misc 1 Z - "ZDR_URB2D" # lsm State Variables -state real SMOIS ilj - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SMOIS" "SOIL MOISTURE" "m3 m-3" -state real SH2O ilj - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SH2O" "SOIL LIQUID WATER" "m3 m-3" -state real SMCREL ilj - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SMCREL" "RELATIVE SOIL MOISTURE" "" -state real XICE ij misc 1 - i0124rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm) "SEAICE" "SEA ICE FLAG" "" -state real ICEDEPTH ij misc 1 - i0124rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm) "ICEDEPTH" "SEA ICE THICKNESS" "m" -state real XICEM ij misc 1 - rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm) "XICEM" "SEA ICE FLAG (PREVIOUS STEP)" "" -state real ALBSI ij misc 1 - i0124rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm) "ALBSI" "SEA ICE ALBEDO" "" -state real SNOWSI ij misc 1 - i0124rhd=(interp_mask_water_field:lu_index,isice)u=(copy_fcnm) "SNOWSI" "SNOW DEPTH ON SEA ICE" "m" -state real SMSTAV ij misc 1 - rd=(interp_mask_land_field:lu_index) "SMSTAV" "MOISTURE AVAILABILITY" "" +state real SMOIS ilj - 1 Z i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SMOIS" "SOIL MOISTURE" "m3 m-3" +state real SH2O ilj - 1 Z i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SH2O" "SOIL LIQUID WATER" "m3 m-3" +state real SMCREL ilj - 1 Z i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SMCREL" "RELATIVE SOIL MOISTURE" "" +state real XICE ij misc 1 - i0124rhd=(interp_mask_field:lu_index,isice)u=(copy_fcnm) "SEAICE" "SEA ICE FLAG" "" +state real ICEDEPTH ij misc 1 - i0124rhd=(interp_mask_field:lu_index,isice)u=(copy_fcnm) "ICEDEPTH" "SEA ICE THICKNESS" "m" +state real XICEM ij misc 1 - rhd=(interp_mask_field:lu_index,isice)u=(copy_fcnm) "XICEM" "SEA ICE FLAG (PREVIOUS STEP)" "" +state real ALBSI ij misc 1 - i0124rhd=(interp_mask_field:lu_index,isice)u=(copy_fcnm) "ALBSI" "SEA ICE ALBEDO" "" +state real SNOWSI ij misc 1 - i0124rhd=(interp_mask_field:lu_index,isice)u=(copy_fcnm) "SNOWSI" "SNOW DEPTH ON SEA ICE" "m" +state real SMSTAV ij misc 1 - rd=(interp_mask_field:lu_index,iswater) "SMSTAV" "MOISTURE AVAILABILITY" "" state real SMSTOT ij misc 1 - r "SMSTOT" "TOTAL SOIL MOISTURE" "m3 m-3" state real SOLDRAIN ij misc 1 - r "SOLDRAIN" "soil column drainage" "mm" state real SFCHEADRT ij misc 1 - r "SFCHEADRT" "surface water depth" "mm" state real INFXSRT ij misc 1 - r "INFXSRT" "time step infiltration excess" "mm" -state real SFCRUNOFF ij misc 1 - rhd=(interp_mask_land_field:lu_index) "SFROFF" "SURFACE RUNOFF" "mm" -state real UDRUNOFF ij misc 1 - rhd=(interp_mask_land_field:lu_index) "UDROFF" "UNDERGROUND RUNOFF" "mm" +state real SFCRUNOFF ij misc 1 - rhd=(interp_mask_field:lu_index,iswater) "SFROFF" "SURFACE RUNOFF" "mm" +state real UDRUNOFF ij misc 1 - rhd=(interp_mask_field:lu_index,iswater) "UDROFF" "UNDERGROUND RUNOFF" "mm" state integer IVGTYP ij misc 1 - i02rhd=(interp_fcni)u=(copy_fcni) "IVGTYP" "DOMINANT VEGETATION CATEGORY" "" -state integer ISLTYP ij misc 1 - i02rhd=(interp_fcni)u=(copy_fcni) "ISLTYP" "DOMINANT SOIL CATEGORY" "" -state real VEGFRA ij misc 1 - i024rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "VEGFRA" "VEGETATION FRACTION" "" +state integer ISLTYP ij misc 1 - i02rhd=(interp_mask_soil:lu_index)u=(copy_fcni) "ISLTYP" "DOMINANT SOIL CATEGORY" "" +state real VEGFRA ij misc 1 - i024rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "VEGFRA" "VEGETATION FRACTION" "" state real SFCEVP ij misc 1 - r "SFCEVP" "ACCUMULATED SURFACE EVAPORATION" "kg m-2" state real GRDFLX ij misc 1 - rh "GRDFLX" "GROUND HEAT FLUX" "W m-2" state real ACGRDFLX ij misc 1 - rhdu "ACGRDFLX" "ACCUMULATED GROUND HEAT FLUX" "J m-2" state real SFCEXC ij misc 1 - r "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "m s-1" -state real ACSNOW ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ACSNOW" "ACCUMULATED SNOW" "kg m-2" -state real ACSNOM ij misc 1 - rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" -state real SNOW ij misc 1 - i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" -state real SNOWH ij misc 1 - i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWH" "PHYSICAL SNOW DEPTH" "m" -#state real RHOSN ij misc 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "RHOSN" " SNOW DENSITY" "kg m-3" -state real CANWAT ij misc 1 - i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "CANWAT" "CANOPY WATER" "kg m-2" +state real ACSNOW ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "ACSNOW" "ACCUMULATED SNOW" "kg m-2" +state real ACSNOM ij misc 1 - rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" +state real SNOW ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" +state real SNOWH ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOWH" "PHYSICAL SNOW DEPTH" "m" +#state real RHOSN ij misc 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "RHOSN" " SNOW DENSITY" "kg m-3" +state real CANWAT ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "CANWAT" "CANOPY WATER" "kg m-2" state integer IFNDSNOWH - misc 1 - i "FNDSNOWH" "SNOWH_LOGICAL" state integer IFNDSOILW - misc 1 - i "FNDSOILW" "SOILW_LOGICAL" -state integer IFNDALBSI - misc 1 - i "FNDALBSI" "ALBSI_LOGICAL" -state integer IFNDSNOWSI - misc 1 - i "FNDSNOWSI" "SNOWSI_LOGICAL" -state integer IFNDICEDEPTH - misc 1 - i "FNDICEDEPTH" "ICEDEPTH_LOGICAL" +state integer IFNDALBSI - misc 1 - ir "FNDALBSI" "ALBSI_LOGICAL" +state integer IFNDSNOWSI - misc 1 - ir "FNDSNOWSI" "SNOWSI_LOGICAL" +state integer IFNDICEDEPTH - misc 1 - ir "FNDICEDEPTH" "ICEDEPTH_LOGICAL" # SKIN SST -state real SSTSK ij misc 1 - rhd=(interp_mask_water_field:lu_index,iswater) "SSTSK" "SKIN SEA SURFACE TEMPERATURE" "K" +state real SSTSK ij misc 1 - rhd=(interp_mask_field:lu_index,iswater) "SSTSK" "SKIN SEA SURFACE TEMPERATURE" "K" +state real lake_depth ij misc 1 - i012rd=(interp_mask_water_field:lu_index,iswater) "lake_depth" "lake depth" "m" state real DTW ij misc 1 - r "DTW" "WARM LAYER TEMP DIFF" "C" +# Ocean surface currents +state real UOCE ij misc 1 - i0124rd=(interp_mask_water_field:lu_index,iswater) "UOCE" "SEA SURFACE ZONAL CURRENTS" "m s-1" +state real VOCE ij misc 1 - i0124rd=(interp_mask_water_field:lu_index,iswater) "VOCE" "SEA SURFACE MERIDIONAL CURRENTS" "m s-1" # DFI variables state real hcoeff {ndfi} misc 1 - - "HCOEFF" "initialization weights" @@ -699,19 +754,19 @@ state real dfi_SMFR3D ilj misc 1 Z r "SMFR3D_df state real dfi_KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG_dfi" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" # urban state variables -state real TR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TR_URB" "URBAN ROOF SKIN TEMPERATURE" "K" -state real TB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TB_URB" "URBAN WALL SKIN TEMPERATURE" "K" -state real TG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TG_URB" "URBAN ROAD SKIN TEMPERATURE" "K" -state real TC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TC_URB" "URBAN CANOPY TEMPERATURE" "K" -state real QC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "QC_URB" "URBAN CANOPY HUMIDITY" "kg kg{-1}" -state real UC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "UC_URB" "URBAN CANOPY WIND" "m s{-1}" -state real XXXR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXR_URB" "M-O LENGTH ABOVE URBAN ROOF" "dimensionless" -state real XXXB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXB_URB" "M-O LENGTH ABOVE URBAN WALL" "dimensionless" -state real XXXG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXG_URB" "M-O LENGTH ABOVE URBAN ROAD" "dimensionless" -state real XXXC_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "XXXC_URB" "M-O LENGTH ABOVE URBAN CANOPY" "dimensionless" -state real TRL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TRL_URB" "ROOF LAYER TEMPERATURE" "K" -state real TBL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TBL_URB" "WALL LAYER TEMPERATURE" "K" -state real TGL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TGL_URB" "ROAD LAYER TEMPERATURE" "K" +state real TR_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TR_URB" "URBAN ROOF SKIN TEMPERATURE" "K" +state real TB_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TB_URB" "URBAN WALL SKIN TEMPERATURE" "K" +state real TG_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TG_URB" "URBAN ROAD SKIN TEMPERATURE" "K" +state real TC_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TC_URB" "URBAN CANOPY TEMPERATURE" "K" +state real QC_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "QC_URB" "URBAN CANOPY HUMIDITY" "kg kg{-1}" +state real UC_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "UC_URB" "URBAN CANOPY WIND" "m s{-1}" +state real XXXR_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "XXXR_URB" "M-O LENGTH ABOVE URBAN ROOF" "dimensionless" +state real XXXB_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "XXXB_URB" "M-O LENGTH ABOVE URBAN WALL" "dimensionless" +state real XXXG_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "XXXG_URB" "M-O LENGTH ABOVE URBAN ROAD" "dimensionless" +state real XXXC_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "XXXC_URB" "M-O LENGTH ABOVE URBAN CANOPY" "dimensionless" +state real TRL_URB3D ilj misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TRL_URB" "ROOF LAYER TEMPERATURE" "K" +state real TBL_URB3D ilj misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TBL_URB" "WALL LAYER TEMPERATURE" "K" +state real TGL_URB3D ilj misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TGL_URB" "ROAD LAYER TEMPERATURE" "K" state real SH_URB2D ij misc 1 - r "SH_URB" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" state real LH_URB2D ij misc 1 - r "LH_URB" "LATENT HEAT FLUX FROM URBAN SFC" "W m{-2}" state real G_URB2D ij misc 1 - r "G_URB" "GROUND HEAT FLUX INTO URBAN" "W m{-2}" @@ -747,7 +802,7 @@ state real CHC_SFCDIF ij misc 1 - r "C # solar location variables from radiation driver -state real COSZEN ij misc 1 - r "COSZEN" "COS of SOLAR ZENITH ANGLE" "dimensionless" +state real COSZEN ij misc 1 - rh "COSZEN" "COS of SOLAR ZENITH ANGLE" "dimensionless" state real HRANG ij misc 1 - r "HRANG" "SOLAR HOUR ANGLE" "radians" state real DECLIN - misc 1 - r "DECLIN" "SOLAR DECLINATION" "radians" state real SOLCON - misc 1 - r "SOLCON" "SOLAR CONSTANT" "W m-2" @@ -769,7 +824,7 @@ state real ALSWNIRDIF ij misc 1 Z r "A # Additional for P-X PBL and LSM state real RA ij misc 1 - r "RA" "AERODYNAMIC RESISTANCE" "s m-1" state real RS ij misc 1 - r "RS" "SURFACE RESISTANCE" "s m-1" -state real LAI ij misc 1 - i0124rh "LAI" "Leaf area index" "area/area" +state real LAI ij misc 1 - i0124rh "LAI" "LEAF AREA INDEX" "m-2/m-2" state real VEGF_PX ij misc 1 - r "VEGF_PX" "Vegetation Fraction for PX LSM" "area/area" state real T2OBS ij misc 1 - r "T2OBS" "2-m temperature from analysis " "K" state real Q2OBS ij misc 1 - r "Q2OBS" "2-m mixing ratio from analysis " "kg/kg" @@ -784,8 +839,8 @@ i1 real GZ1OZ0 ij misc 1 - - "GZ1O i1 real BR ij misc 1 - - "BR" "Bulk Richardson" "" # ysupbl variables for grims shallow convection -state real WSTAR_YSU ij misc 1 - - "WSTAR_YSU" "mixed-layer velocity scale from ysupbl" "m/s" -state real DELTA_YSU ij misc 1 - - "DELTA_YSU" "entrainment layer depth from ysupbl" "m" +state real WSTAR_YSU ij misc 1 - - "WSTAR_YSU" "mixed-layer velocity scale from ysupbl" "m/s" +state real DELTA_YSU ij misc 1 - - "DELTA_YSU" "entrainment layer depth from ysupbl" "m" # MYJ PBL variables; GBM PBL: EXCH_H, EXCH_M state real EXCH_H ikj misc 1 Z r "EXCH_H" "SCALAR EXCHANGE COEFFICIENTS " @@ -844,20 +899,26 @@ state real wm_temf ij misc 1 - rh "wm # MYNN PBL variables state real qke_adv ikjftb scalar 1 - i0rusdf=(bdy_interp:dt) "qke_adv" "twice TKE from MYNN" "m2 s-2" state real qke ikj misc 1 - irh "qke" "twice TKE from MYNN" "m2 s-2" -state real EL_MYNN ikj misc 1 - h "el_mynn" "MIXING LENGTH FROM MYNN" "m" -state real qSHEAR ikj misc 1 - h "qSHEAR" "TKE Production - shear" "m2 s-2" -state real qBUOY ikj misc 1 - h "qBUOY" "TKE Production - buoyancy" "m2 s-2" -state real qDISS ikj misc 1 - h "qDISS" "TKE dissipation" "m2 s-2" -state real qWT ikj misc 1 - h "qWT" "TKE vertical transport" "m2 s-2" +#state real EL_MYNN ikj misc 1 Z h "el_mynn" "MIXING LENGTH FROM MYNN" "m" +state real qSHEAR ikj misc 1 Z h "qSHEAR" "TKE Production - shear" "m2 s-2" +state real qBUOY ikj misc 1 Z h "qBUOY" "TKE Production - buoyancy" "m2 s-2" +state real qDISS ikj misc 1 Z h "qDISS" "TKE dissipation" "m2 s-2" +state real qWT ikj misc 1 Z h "qWT" "TKE vertical transport" "m2 s-2" state real dqke ikj misc 1 - h "Dtke" "TKE change" "m2 s-2" state real tsq ikj misc 1 - r "tsq" "liquid water pottemp variance" "K2" state real qsq ikj misc 1 - r "qsq" "liquid water variance" "(kg/kg)**2" state real cov ikj misc 1 - r "cov" "liquid water-liquid water pottemp covariance" "K kg/kg" -state real ch ij misc 1 - - "ch" "drag coeff for heat" "" +state real Sh3d ikj misc 1 - r "Sh3d" "Stability function for heat" "" +state real ch ij misc 1 - - "ch" "surface exchange coeff for heat" "m s-1" #state real K_m ikj misc 1 - - "K_m" "EXCHANGE COEFFICIENT for momentum " #state real K_h ikj misc 1 - - "K_h" "EXCHANGE COEFFICIENT for heat " #state real K_q ikj misc 1 - - "K_q" "EXCHANGE COEFFICIENT for qke " +#FogDES variables +state real fgdp ij misc 1 - - "fgdp" "Accumulated fog deposition" "mm" +state real dfgdp ij misc 1 - - "dfgdp" "Fog deposition during timestep" "mm" +state real vdfg ij misc 1 - - "vdfg" "Deposition velocity of fog" "m/s" + # GBM PBL variable state real exch_tke ikj misc 1 - h "EXCH_TKE" "Exchange coefficient TKE enhanced" "m2 s-1" @@ -1010,12 +1071,13 @@ state real ht ij misc 1 - i012rhdus " state real ht_fine ij misc 1 - - "HGT_FINE" "Fine Terrain Height" "m" state real ht_int ij misc 1 - - "HGT_INT" "Terrain Height Horizontally Interpolated" "m" state real ht_input ij misc 1 - - "HGT_INPUT" "Terrain Height from FG Input File" "m" +state real ht_smooth ij misc 1 - - "HGT_SMOOTH" "Terrain Height Smoothed with External Model Topo (d1 only)" "m" state real ht_shad ijb misc 1 - df=(bdy_interp:dt) "HGT_SHAD" "Height of orographic shadow" "m" i1 real ht_loc ij misc 1 - - state integer shadowmask ij misc 1 - - state integer min_ptchsz - misc 1 - r -state real TSK ij misc 1 - i012rhdu=(copy_fcnm) "TSK" "SURFACE SKIN TEMPERATURE" "K" +state real TSK ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TSK" "SURFACE SKIN TEMPERATURE" "K" state real dfi_TSK ij misc 1 - r "TSK_dfi" "saved SURFACE SKIN TEMPERATURE" state real TSK_SAVE ij misc 1 - - "TSK_SAVE" "SURFACE SKIN TEMPERATURE, EXTRA COPY FOR SEA ICE TESTS in REAL" "K" state real u_base k misc 1 - ir "u_base" "BASE STATE X WIND IN IDEALIZED CASES" "" @@ -1033,6 +1095,7 @@ state real v_frame - misc 1 - ir "v # collision between a metadata name and a field record in the I/O data # resolve this how? Have the real program throw a switch to tell the code to get it # from the metadata? Otherwise it's a field? +state logical just_read_auxinput4 - misc - - r "we_just_read_sst" "1=AUXINPUT4 ALARM RINGING, 0=NO AUXINPUT4 ALARM" "-" state real p_top - misc - - irh "p_top" "PRESSURE TOP OF THE MODEL" "Pa" state real t00 - misc - - i02rh "t00" "BASE STATE TEMPERATURE " "K" state real p00 - misc - - i02rh "p00" "BASE STATE PRESURE" "Pa" @@ -1098,6 +1161,9 @@ state real refl_10cm ikj dyn_em 1 - hdu "r state real NCA ij misc 1 - r "NCA" "COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME" "" state integer LOWLYR ij misc 1 - - "LOWLYR" "INDEX OF LOWEST MODEL LAYER ABOVE THE GROUND IN BMJ SCHEME" "" state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb hour-1" +# ckay +state real cldfra_dp ikj misc 1 - - "CLDFRA_DP" "DEEP CONVECTIVE CLOUD FRACTION FROM KF" "" +state real cldfra_sh ikj misc 1 - - "CLDFRA_SH" "SHALLOW CONVECTIVE CLOUD FRACTION FROM KF" "" state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL" "mm hour-1" state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W" "mm hour-1" state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm hour-1" @@ -1128,8 +1194,8 @@ state real RAINCV_A ij misc 1 - r "R state real RAINCV_B ij misc 1 - r "RAINCV_B" "taveragd TIME-STEP CUMULUS PRECIPITATION" "mm" state real GD_CLOUD_A ikj misc 1 - r "GD_CLOUD_A" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" state real GD_CLOUD2_A ikj misc 1 - r "GD_CLOUD2_A" "taveragd cloud ice mix ratio in GD" "kg kg-1" -state real GD_CLOUD_B ikj misc 1 - r "GD_CLOUD_B" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2_B ikj misc 1 - r "GD_CLOUD2_B" "taveragd cloud ice mix ratio in GD" "kg kg-1" +state real QC_CU ikj misc 1 - r "QC_CU" "CLOUD WATER MIXING RATIO FROM A CU SCHEME" "kg kg-1" +state real QI_CU ikj misc 1 - r "QI_CU" "CLOUD ICE MIXUNG RATIO FROM A CU SCHEME" "kg kg-1" state integer STEPAVE_COUNT - misc 1 - r "STEPAVE_COUNT" "time steps contained in averages for convective transport" "" # @@ -1149,6 +1215,23 @@ state real SWDOWNC ij misc 1 - - "S state real GSW ij misc 1 - rd "GSW" "NET SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GLW ij misc 1 - rhd "GLW" "DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" state real SWNORM ij misc 1 - rhd "SWNORM" "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)" "W m-2" +# WRF-Solar +state real swddir ij misc 1 - rd "SWDDIR" "Shortwave surface downward direct irradiance" "W/m^2" "" +state real swddni ij misc 1 - rd "SWDDNI" "Shortwave surface downward direct normal irradiance" "W/m^2" "" +state real swddif ij misc 1 - rd "SWDDIF" "Shortwave surface downward diffuse irradiance" "W/m^2" "" +state real Gx ij misc 1 - rd "Gx" "" "" +state real Bx ij misc 1 - rd "Bx" "" "" +state real gg ij misc 1 - rd "gg" "" "" +state real bb ij misc 1 - rd "bb" "" "" +state real coszen_ref ij misc 1 - - "coszen_ref" "" "" +state real swdown_ref ij misc 1 - - "swdown_ref" "" "" +state real swddir_ref ij misc 1 - - "swddir_ref" "" "" +# jararias 2013/11 +state real aod5502d ij misc 1 - i{15}r "AOD5502D" "Total aerosol optical depth at 550 nm" "" +state real angexp2d ij misc 1 - i{15}r "ANGEXP2D" "Aerosol Angstrom exponent" "" +state real aerssa2d ij misc 1 - i{15}r "AERSSA2D" "Aerosol single-scattering albedo" "" +state real aerasy2d ij misc 1 - i{15}r "AERASY2D" "Aerosol asymmetry factor" "" +state real aod5503d ikj misc 1 - r "AOD5503D" "3D aerosol optical depth at 550 nm" "" # CLWRF-WRF4G state real T2MIN ij misc 1 - rh3 "T2MIN" "MINIMUM TEMPERATURE AT 2M HEIGHT IN DIAGNOSTIC OUTPUT INTERVAL" "K" @@ -1244,8 +1327,6 @@ state real OLR ij misc 1 - rh " # these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling # with wave model, only if compiled with -DMCELIO, JM 2003/05/29 -state real XLAT ij misc 1 - i0123rh01du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" -state real XLONG ij misc 1 - i0123rh01du=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" state real XLAT_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLAT_U" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" state real XLONG_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLONG_U" "LONGITUDE, WEST IS NEGATIVE" "degree_east" state real XLAT_V ij dyn_em 1 Y i012rh01du=(copy_fcnm) "XLAT_V" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" @@ -1269,87 +1350,147 @@ state real RQIBLTEN ikj misc 1 - r "R state real RQNIBLTEN ikj misc 1 - r "RQNIBLTEN" "COUPLED Q_NI TENDENCY DUE TO PBL PARAMETERIZATION" "Pa # kg-1 s-1" # For Noah UA changes -state real flx4 ij - 1 - h "FLX4" "sensible heat from canopy" "W m{-2}" -state real fvb ij - 1 - h "FVB" "fraction of vegetation with snow below" "" -state real fbur ij - 1 - h "FBUR" "fraction of vegetation covered by snow" "" -state real fgsn ij - 1 - h "FGSN" "fraction of ground covered by snow" "" +state real flx4 ij - 1 - - "FLX4" "sensible heat from canopy" "W m{-2}" +state real fvb ij - 1 - - "FVB" "fraction of vegetation with snow below" "" +state real fbur ij - 1 - - "FBUR" "fraction of vegetation covered by snow" "" +state real fgsn ij - 1 - - "FGSN" "fraction of ground covered by snow" "" # For Noah-MP -state integer isnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "isnow" "no. of snow layer" "m3 m-3" -state real tvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tv" "vegetation leaf temperature" "K" -state real tgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tg" "bulk ground temperature" "K" -state real canicexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "canice" "intercepted ice mass" "mm" -state real canliqxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "canliq" "intercepted liquid water" "mm" -state real eahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "eah" "canopy air vapor pressure" "pa" -state real tahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tah" "canopy air temperature" "K" -state real cmxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "cm" "surf. exchange coeff. for momentum" "m/s" -state real chxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ch" "surf. exchange coeff. for heat" "m/s" -state real fwetxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fwet" "wetted or snowed canopy fraction" "-" -state real sneqvoxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sneqvo" "snow mass at last time step" "mm" -state real alboldxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "albold" "snow albedo at last timestep" "-" -state real qsnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "qsnowxy" "snowfall on the ground" "mm/s" -state real wslakexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wslake" "lake water storage" "mm" -state real zwtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "zwt" "water table depth" "m" -state real waxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wa" "water in the acquifer" "mm" -state real wtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wt" "groundwater storage" "mm" -state real tsnoxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tsno" "snow temperature" "K" -state real zsnsoxy i{snsl}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "zsnso" "layer-bottom depth from snow surf" "m" -state real snicexy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "snice" "snow layer ice" "mm" -state real snliqxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "snliq" "snow layer liquid" "mm" -state real lfmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "lfmass" "leaf mass" "g/m2" -state real rtmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rtmass" "mass of fine roots" "g/m2" -state real stmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "stmass" "stem mass" "g/m2" -state real woodxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wood" "mass of wood" "g/m2" -state real stblcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "stblcp" "stable carbon pool" "g/m2" -state real fastcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fastcp" "short-lived carbon" "g/m2" -state real xsaixy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "xsai" "stem area index" "-" +state integer isnowxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "isnow" "no. of snow layer" "m3 m-3" +state real tvxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "tv" "vegetation leaf temperature" "K" +state real tgxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "tg" "bulk ground temperature" "K" +state real canicexy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "canice" "intercepted ice mass" "mm" +state real canliqxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "canliq" "intercepted liquid water" "mm" +state real eahxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "eah" "canopy air vapor pressure" "pa" +state real tahxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "tah" "canopy air temperature" "K" +state real cmxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "cm" "surf. exchange coeff. for momentum" "m/s" +state real chxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "ch" "surf. exchange coeff. for heat" "m/s" +state real fwetxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "fwet" "wetted or snowed canopy fraction" "-" +state real sneqvoxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "sneqvo" "snow mass at last time step" "mm" +state real alboldxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "albold" "snow albedo at last timestep" "-" +state real qsnowxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "qsnowxy" "snowfall on the ground" "mm/s" +state real wslakexy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "wslake" "lake water storage" "mm" +state real zwtxy ij - 1 - i027rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "zwt" "water table depth" "m" +state real waxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "wa" "water in the acquifer" "mm" +state real wtxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "wt" "groundwater storage" "mm" +state real tsnoxy i{snly}j - 1 Z i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "tsno" "snow temperature" "K" +state real zsnsoxy i{snsl}j - 1 Z i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "zsnso" "layer-bottom depth from snow surf" "m" +state real snicexy i{snly}j - 1 Z i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "snice" "snow layer ice" "mm" +state real snliqxy i{snly}j - 1 Z i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "snliq" "snow layer liquid" "mm" +state real lfmassxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "lfmass" "leaf mass" "g/m2" +state real rtmassxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "rtmass" "mass of fine roots" "g/m2" +state real stmassxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "stmass" "stem mass" "g/m2" +state real woodxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "wood" "mass of wood" "g/m2" +state real stblcpxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "stblcp" "stable carbon pool" "g/m2" +state real fastcpxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "fastcp" "short-lived carbon" "g/m2" +state real xsaixy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "xsai" "stem area index" "-" state real taussxy ij - 1 - rh "tauss" "non-dimensional snow age" "" -state real t2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "t2v" "2 meter temperature over canopy" "K" -state real t2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "t2b" "2 meter temperature over bare ground" "K" -state real q2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "q2v" "2 meter mixing ratio over canopy" "kg kg-1" -state real q2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "q2b" "2 meter mixing ratio over bare ground" "kg kg-1" -state real tradxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "trad" "surface radiative temperature" "K" -state real neexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "nee" "net ecosystem exchange" "g/m2/s CO2" -state real gppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "gpp" "gross primary productivity" "g/m2/s C" -state real nppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "npp" "net primary productivity" "g/m2/s C" -state real fvegxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fveg" "Noah-MP vegetation fraction" "" -state real qinxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "qin" "groundwater recharge" "mm/s" -state real runsfxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "runsf" "surface runoff" "mm/s" -state real runsbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "runsb" "subsurface runoff" "mm/s" -state real ecanxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ecan" "evaporation of intercepted water" "mm/s" -state real edirxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "edir" "ground surface evaporation rate" "mm/s" -state real etranxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "etran" "transpiration rate" "mm/s" -state real fsaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fsa" "total absorbed solar radiation" "W/m2" -state real firaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fira" "total net longwave rad" "W/m2" -state real aparxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "apar" "photosyn active energy by canopy" "W/m2" -state real psnxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "psn" "total photosynthesis" "umol co2/m2/s" -state real savxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sav" "solar rad absorbed by veg" "W/m2" -state real sagxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sag" "solar rad absorbed by ground" "W/m2" -state real rssunxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rssun" "sunlit stomatal resistance" "s/m" -state real rsshaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rssha" "shaded stomatal resistance" "s/m" -state real bgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "bgap" "between canopy gap" "fraction" -state real wgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wgap" "within canopy gap" "fraction" -state real tgvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tgv" "ground temp. under canopy" "K" -state real tgbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tgb" "bare ground temperature" "K" -state real chvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv" "vegetated heat exchange coefficient" "m/s" -state real chbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb" "bare-ground heat exchange coefficient" "m/s" -state real shgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shg" "sensible heat flux: ground to canopy" "W/m2" -state real shcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shc" "sensible heat flux: leaf to canopy" "W/m2" -state real shbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shb" "sensible heat flux: bare grnd to atmo" "W/m2" -state real evgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evg" "latent heat flux: ground to canopy" "W/m2" -state real evbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evb" "latent heat flux: bare grnd to atmo" "W/m2" -state real ghvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ghv" "heat flux into soil: under canopy" "W/m2" -state real ghbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ghb" "heat flux into soil: bare fraction" "W/m2" -state real irgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irg" "net longwave at below canopy surface" "W/m2" -state real ircxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irc" "net longwave in canopy" "W/m2" -state real irbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irb" "net longwave at bare fraction surface" "W/m2" -state real trxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tr" "transpiration" "W/m2" -state real evcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evc" "canopy evaporation" "W/m2" -state real chleafxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chleaf" "leaf exchange coefficient" "m/s" -state real chucxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chuc" "under canopy exchange coefficient" "m/s" -state real chv2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv2" "leaf exchange coefficient" "m/s" -state real chb2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb2" "under canopy exchange coefficient" "m/s" -state real chstarxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chstar" "dummy exchange coefficient" "m/s" +state real t2mvxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "t2v" "2 meter temperature over canopy" "K" +state real t2mbxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "t2b" "2 meter temperature over bare ground" "K" +state real q2mvxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "q2v" "2 meter mixing ratio over canopy" "kg kg-1" +state real q2mbxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "q2b" "2 meter mixing ratio over bare ground" "kg kg-1" +state real tradxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "trad" "surface radiative temperature" "K" +state real neexy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "nee" "net ecosystem exchange" "g/m2/s CO2" +state real gppxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "gpp" "gross primary productivity" "g/m2/s C" +state real nppxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "npp" "net primary productivity" "g/m2/s C" +state real fvegxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "fveg" "Noah-MP vegetation fraction" "" +state real qinxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "qin" "groundwater recharge" "mm/s" +state real runsfxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "runsf" "surface runoff" "mm/s" +state real runsbxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "runsb" "subsurface runoff" "mm/s" +state real ecanxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "ecan" "evaporation of intercepted water" "mm/s" +state real edirxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "edir" "ground surface evaporation rate" "mm/s" +state real etranxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "etran" "transpiration rate" "mm/s" +state real fsaxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "fsa" "total absorbed solar radiation" "W/m2" +state real firaxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "fira" "total net longwave rad" "W/m2" +state real aparxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "apar" "photosyn active energy by canopy" "W/m2" +state real psnxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "psn" "total photosynthesis" "umol co2/m2/s" +state real savxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "sav" "solar rad absorbed by veg" "W/m2" +state real sagxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "sag" "solar rad absorbed by ground" "W/m2" +state real rssunxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "rssun" "sunlit stomatal resistance" "s/m" +state real rsshaxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "rssha" "shaded stomatal resistance" "s/m" +state real bgapxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "bgap" "between canopy gap" "fraction" +state real wgapxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "wgap" "within canopy gap" "fraction" +state real tgvxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "tgv" "ground temp. under canopy" "K" +state real tgbxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "tgb" "bare ground temperature" "K" +state real chvxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "chv" "vegetated heat exchange coefficient" "m/s" +state real chbxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "chb" "bare-ground heat exchange coefficient" "m/s" +state real shgxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "shg" "sensible heat flux: ground to canopy" "W/m2" +state real shcxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "shc" "sensible heat flux: leaf to canopy" "W/m2" +state real shbxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "shb" "sensible heat flux: bare grnd to atmo" "W/m2" +state real evgxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "evg" "latent heat flux: ground to canopy" "W/m2" +state real evbxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "evb" "latent heat flux: bare grnd to atmo" "W/m2" +state real ghvxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "ghv" "heat flux into soil: under canopy" "W/m2" +state real ghbxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "ghb" "heat flux into soil: bare fraction" "W/m2" +state real irgxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "irg" "net longwave at below canopy surface" "W/m2" +state real ircxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "irc" "net longwave in canopy" "W/m2" +state real irbxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "irb" "net longwave at bare fraction surface" "W/m2" +state real trxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "tr" "transpiration" "W/m2" +state real evcxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "evc" "canopy evaporation" "W/m2" +state real chleafxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "chleaf" "leaf exchange coefficient" "m/s" +state real chucxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "chuc" "under canopy exchange coefficient" "m/s" +state real chv2xy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "chv2" "leaf exchange coefficient" "m/s" +state real chb2xy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "chb2" "under canopy exchange coefficient" "m/s" +state real chstarxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "chstar" "dummy exchange coefficient" "m/s" +state real SMOISEQ ilj - 1 Z r "SMOISEQ" "EQ. SOIL MOISTURE" "m3 m-3" +state real smcwtdxy ij - 1 - rh "smcwtd" "deep soil moisture " "m3 m-3" +state real rechxy ij - 1 - h "rech" "water table recharge" "mm" +state real deeprechxy ij - 1 - r "deeprech" "deep water table recharge" "mm" +state real fdepthxy ij - 1 - i027r "fdepth" "e-folding depth for transmissivity " "m" +state real areaxy ij - 1 - r "area" "area of grid boxes" "m2" +state real rivercondxy ij - 1 - i027r "rivercond" "river conductance" "Kg m s-1" +state real riverbedxy ij - 1 - i027r "riverbed" "river bed depth" "m" +state real eqzwt ij - 1 - i027r "eqzwt" "equilibrium water table depth " "m" +state real pexpxy ij - 1 - i027r "pexp" "exponent for river conductance" "Kg m s-1" +state real qrfxy ij - 1 - r "qrf" "baseflow " "m" +state real qrfsxy ij - 1 - h "qrfs" "sum baseflow " "mm" +state real qspringxy ij - 1 - r "qspring" "seeping water " "m" +state real qspringsxy ij - 1 - h "qsprings" "sum seeping water " "mm" +state real qslatxy ij - 1 - h "qslat" "sum lateral flow " "mm" +state integer STEPWTD - misc 1 - r "STEPWTD" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN WTD CALLS" "" + +# For Noah-Mosaic danli + +state real TSK_mosaic i{mocat}j misc 1 - i02rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TSK_mosaic" "vegetation temperature" "K" +state real QSFC_mosaic i{mocat}j misc 1 - i02rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "QSFC_mosaic" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "" +state real TSLB_mosaic i{mocat2}j misc 1 Z i02rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TSLB_mosaic" "SOIL TEMPERATURE" "K" +state real SMOIS_mosaic i{mocat2}j misc 1 Z i02rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SMOIS_mosaic" "SOIL MOISTURE" "m3 m-3" +state real SH2O_mosaic i{mocat2}j misc 1 Z i02rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SH2O_mosaic" "SOIL LIQUID WATER" "m3 m-3" +state real CANWAT_mosaic i{mocat}j misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "CANWAT_mosaic" "CANOPY WATER" "kg m-2" +state real SNOW_mosaic i{mocat}j misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOW_mosaic" "SNOW WATER EQUIVALENT" "kg m-2" +state real SNOWH_mosaic i{mocat}j misc 1 - i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWH_mosaic" "PHYSICAL SNOW DEPTH" "m" +state real SNOWC_mosaic i{mocat}j misc 1 - ird=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWC_mosaic" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" + +state real ALBEDO_mosaic i{mocat}j misc 1 - r "ALBEDO_mosaic" "albedo" "" +state real ALBBCK_mosaic i{mocat}j misc 1 - r "ALBBCK_mosaic" "background albedo" "" +state real EMISS_mosaic i{mocat}j misc 1 - r "EMISS_mosaic" "emissivity" "" +state real EMBCK_mosaic i{mocat}j misc 1 - r "EMBCK_mosaic" "background emissivity" "" +state real ZNT_mosaic i{mocat}j misc 1 - r "ZNT_mosaic" "time_varying roughness length" "m" +state real Z0_mosaic i{mocat}j misc 1 - r "Z0_mosaic" "background roughness length" "m" + +state real HFX_mosaic i{mocat}j misc 1 - r "HFX_mosaic" "UPWARD HEAT FLUX AT THE SURFACE" "W m-2" +state real QFX_mosaic i{mocat}j misc 1 - r "QFX_mosaic" "UPWARD MOISTURE FLUX AT THE SURFACE" "kg m-2 s-1" +state real LH_mosaic i{mocat}j misc 1 - r "LH_mosaic" "LATENT HEAT FLUX AT THE SURFACE" "W m-2" +state real GRDFLX_mosaic i{mocat}j misc 1 - r "GRDFLX_mosaic" "GROUND HEAT FLUX" "W m-2" +state real SNOTIME_mosaic i{mocat}j misc 1 - r "SNOTIME_mosaic" "SNOTIME" "" + +state real TR_URB2D_mosaic i{mocat}j misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TR_URB2D_mosaic" "ROOF TEMPERATURE" "K" +state real TB_URB2D_mosaic i{mocat}j misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TB_URB2D_mosaic" "WALL TEMPERATURE" "K" +state real TG_URB2D_mosaic i{mocat}j misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TG_URB2D_mosaic" "GROUND TEMPERATURE" "K" +state real TC_URB2D_mosaic i{mocat}j misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TC_URB2D_mosaic" "CANYON TEMPERATURE" "K" +state real TS_URB2D_mosaic i{mocat}j misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TS_URB2D_mosaic" "URBAN TEMPERATURE" "K" +state real TS_RUL2D_mosaic i{mocat}j misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TS_RUL2D_mosaic" "RURAL TEMPERATURE" "K" +state real QC_URB2D_mosaic i{mocat}j misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TC_URB2D_mosaic" "CANYON SPECIFIC HUMIDITY" "" +state real UC_URB2D_mosaic i{mocat}j misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TC_URB2D_mosaic" "CANYON WIND SPEED" "m s-1" +state real TRL_URB3D_mosaic i{mocat2}j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TRL_URB3D_mosaic" "ROOF LAYER TEMPERATURE" "K" +state real TBL_URB3D_mosaic i{mocat2}j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TBL_URB3D_mosaic" "WALL LAYER TEMPERATURE" "K" +state real TGL_URB3D_mosaic i{mocat2}j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TGL_URB3D_mosaic" "ROAD LAYER TEMPERATURE" "K" +state real SH_URB2D_mosaic i{mocat}j misc 1 - r "SH_URB2D_mosaic" "UPWARD HEAT FLUX AT THE SURFACE" "W m-2" +state real LH_URB2D_mosaic i{mocat}j misc 1 - r "LH_URB2D_mosaic" "LATENT HEAT FLUX AT THE SURFACE" "kg m-2 s-1" +state real G_URB2D_mosaic i{mocat}j misc 1 - r "G_URB2D_mosaic" "GROUND HEAT FLUX AT THE SURFACE" "W m-2" +state real RN_URB2D_mosaic i{mocat}j misc 1 - r "RN_URB2D_mosaic" "NET RADIATION" "W m-2" + +state integer mosaic_cat_index iuj misc 1 Z i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "mosaic_cat_index" " " "" +state real landusef2 iuj misc 1 Z i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "LANDUSEF2" "sorted landuse fraction" "" # State vector for etampnew microphysics. Must be declared state because it is not read-once and is needed for restarting. state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" @@ -1364,27 +1505,28 @@ state integer landuse_luseas - misc - - r state integer landuse_isn - misc - - r state real lu_state p misc - - r -i1 real th_phy ikj misc 1 - -i1 real pi_phy ikj misc 1 - -i1 real p_phy ikj misc 1 - +i1 real th_phy ikj misc 1 - +i1 real pi_phy ikj misc 1 - +i1 real p_phy ikj misc 1 - state real t_phy ikj misc 1 - r "T_PHY" "Temperature" "K" -i1 real u_phy ikj misc 1 - -i1 real v_phy ikj misc 1 - -i1 real dz8w ikj misc 1 Z -i1 real p8w ikj misc 1 Z -i1 real t8w ikj misc 1 Z -i1 real rho_phy ikj misc 1 - +state real u_phy ikj misc 1 - r "U_PHY" "x-wind component at mass point" "m s-1" +state real v_phy ikj misc 1 - r "V_PHY" "y-wind component at mass point" "m s-1" +i1 real dz8w ikj misc 1 Z +i1 real p8w ikj misc 1 Z +i1 real t8w ikj misc 1 Z +i1 real rho_phy ikj misc 1 - i1 logical CU_ACT_FLAG ij misc 1 - -state real TMN ij misc 1 - i012rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TMN" "SOIL TEMPERATURE AT LOWER BOUNDARY" "K" -state real TYR ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TYR" "ANNUAL MEAN SFC TEMPERATURE" "K" -state real TYRA ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TYRA" "ACCUMULATED YEARLY SFC TEMPERATURE FOR CURRENT YEAR" "K" -state real TDLY ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TDLY" "ACCUMULATED DAILY SFC TEMPERATURE FOR CURRENT DAY" "K" -state real TLAG i&j misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TLAG" "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS" "K" +state real TMN ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TMN" "SOIL TEMPERATURE AT LOWER BOUNDARY" "K" +state real TYR ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TYR" "ANNUAL MEAN SFC TEMPERATURE" "K" +state real TYRA ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TYRA" "ACCUMULATED YEARLY SFC TEMPERATURE FOR CURRENT YEAR" "K" +state real TDLY ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TDLY" "ACCUMULATED DAILY SFC TEMPERATURE FOR CURRENT DAY" "K" +state real TLAG i&j misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TLAG" "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS" "K" state integer NYEAR - misc 1 - r "NYEAR" "ACCUM DAYS IN A YEAR" "" state real NDAY - misc 1 - r "NDAY" "ACCUM TIMESTEPS IN A DAY" "" -state real XLAND ij misc 1 - i02rhd=(interp_fcnm)u=(copy_fcnm) "XLAND" "LAND MASK (1 FOR LAND, 2 FOR WATER)" "" +state real XLAND ij misc 1 - i02rhd=(interp_fcnm_imask)u=(copy_fcnm) "XLAND" "LAND MASK (1 FOR LAND, 2 FOR WATER)" "" +state real cplmask i{ncpldom}j misc 1 z i0r "CPLMASK" "COUPLING MASK (0:VALUE FROM SST UPDATE; 1:VALUE FROM COUPLED OCEAN), vertical dim is number of external domains" "" state real ZNT ij misc 1 - i3r "ZNT" "TIME-VARYING ROUGHNESS LENGTH" "m" state real CK ij misc 1 - r "CK" "ENTHALPY EXCHANGE COEFF AT 10 m" "" state real CKA ij misc 1 - r "CKA" "ENTHALPY EXCHANGE COEFF AT LOWEST MODEL LVL" "" @@ -1415,7 +1557,7 @@ state real dfi_SOILT1 ij misc 1 - r "S state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" state real dfi_TSNAV ij misc 1 - r "TSNAV_dfi" "AVERAGE SNOW TEMPERATURE " "C" state real REGIME ij misc 1 - r "REGIME" "FLAGS: 1=Night/Stable, 2=Mechanical Turbulent, 3=Forced Conv, 4=Free Conv" "" -state real SNOWC ij misc 1 - irhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" +state real SNOWC ij misc 1 - irhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" state real dfi_SNOWC ij misc 1 - r "SNOWC_dfi" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" state real MAVAIL ij misc 1 - r "MAVAIL" "SURFACE MOISTURE AVAILABILITY" "" @@ -1428,7 +1570,6 @@ state real soiltb ij dyn_em 1 - r "s state integer STEPBL - misc 1 - r "STEPBL" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN PBL CALLS" "" state real taucldi ikj misc 1 - r "TAUCLDI" "CLOUD OPTICAL THICKNESS FOR ICE" "" state real taucldc ikj misc 1 - r "TAUCLDC" "CLOUD OPTICAL THICKNESS FOR WATER" "" - state real defor11 ikj misc 1 - r "defor11" "DEFORMATION 11" "s-1" state real defor22 ikj misc 1 - r "defor22" "DEFORMATION 22" "s-1" state real defor12 ikj misc 1 - r "defor12" "DEFORMATION 12" "s-1" @@ -1514,9 +1655,9 @@ state real UP_HELI_MAX ij misc 1 - rh state real W_MEAN ij misc 1 - rh "W_MEAN" "HOURLY MEAN Z-WIND" "m s-1" state real GRPL_MAX ij misc 1 - rh "GRPL_MAX" "MAX COL INT GRAUPEL" "kg m-2" state real UH ij misc 1 - r "UH" "UPDRAFT HELICITY" "m2 s-2" -i1 real W_COLMEAN ij misc 1 - - "W_COLMEAN" "COLUMN MEAN Z-WIND" "m s-1" -i1 real NUMCOLPTS ij misc 1 - - "NUMCOLPTS" "NUMBER OF COLUMN PTS" "dimensionless" -i1 real GRPL_COLINT ij misc 1 - - "GRPL_COLINT" "COL INT GRAUPEL" "kg m-2" +state real W_COLMEAN ij misc 1 - - "W_COLMEAN" "COLUMN MEAN Z-WIND" "m s-1" +state real NUMCOLPTS ij misc 1 - - "NUMCOLPTS" "NUMBER OF COLUMN PTS" "dimensionless" +state real GRPL_COLINT ij misc 1 - - "GRPL_COLINT" "COL INT GRAUPEL" "kg m-2" state real max_cfl - misc 1 - - "max_cfl" "maximum CFL value in grid at a time" "-" @@ -1524,6 +1665,52 @@ state real prec_acc_c ij misc 1 - rh "pr state real prec_acc_nc ij misc 1 - rh "prec_acc_nc" "ACCUMULATED GRID SCALE PRECIPITATION OVER prec_acc_dt PERIODS OF TIME" "mm" state real snow_acc_nc ij misc 1 - rh "snow_acc_nc" "ACCUMULATED SNOW WATER EQUIVALENT OVER prec_acc_dt PERIODS OF TIME" "mm" +# GAC--> +# These variables are for the AFWA diagnostics package. Note, in V3.5, some of these have been added +# inside the NSSL WRF diagnostics (above), and have been commented out. We need to merge these +# diagnostics packages together as they are largely duplicated. GAC 20130724 +#state real WSPD10MAX ij misc 1 - rh "WSPD10MAX" "WIND SPD MAX 10 M" "m s-1" +#state real W_UP_MAX ij misc 1 - rh "W_UP_MAX" "MAX Z-WIND UPDRAFT" "m s-1" +#state real W_DN_MAX ij misc 1 - rh "W_DN_MAX" "MAX Z-WIND DOWNDRAFT" "m s-1" +#state real REFD_MAX ij misc 1 - rh02 "REFD_MAX" "MAX DERIVED RADAR REFL" "dbZ" +#state real UP_HELI_MAX ij misc 1 - rh "UP_HELI_MAX" "MAX UPDRAFT HELICITY" "m2 s-2" +#state real UH ij misc 1 - r "UH" "UPDRAFT HELICITY" "m2 s-2" +state real TCOLI_MAX ij misc 1 - rh "TCOLI_MAX" "MAX TOTAL COLUMN INTEGRATED ICE" "kg m-2" +state real REFD_COM ij misc 1 - rh02 "REFD_COM" "DERIVED COMPOSITE RADAR REFL" "dbZ" +state real REFD ij misc 1 - rh02 "REFD" "DERIVED RADAR REFL" "dbZ" +state real VIL ij misc 1 - rh02 "VIL" "VERTICALLY INTEGRATED LIQUID WATER" "kg m-2" +state real RADARVIL ij misc 1 - rh02 "RADARVIL" "VERTICALLY INTEGRATED LIQUID WATER FROM Ze" "kg m-2" +state real ECHOTOP ij misc 1 - rh02 "ECHOTOP" "ECHO TOP HEIGHT FROM Ze" "m" +state real FZLEV ij misc 1 - rh02 "FZLEV" "FREEZING LEVEL" "m" +state real ICINGTOP ij misc 1 - rh02 "ICINGTOP" "TOPMOST ICING LEVEL" "m" +state real ICINGBOT ij misc 1 - rh02 "ICINGBOT" "BOTTOMMOST ICING LEVEL" "m" +state real QICING_LG ikj misc 1 - r "QICING_LG" "SUPERCOOLED WATER MIXING RATIO (>50 um)" "kg kg-1" +state real QICING_SM ikj misc 1 - r "QICING_SM" "SUPERCOOLED WATER MIXING RATIO (<50 um)" "kg kg-1" +state real QICING_LG_MAX ij misc 1 - rh02 "QICING_LG_MAX" "COLUMN MAX ICING MIXING RATIO (>50 um)" "kg kg-1" +state real QICING_SM_MAX ij misc 1 - rh02 "QICING_SM_MAX" "COLUMN MAX ICING MIXING RATIO (<50 um)" "kg kg-1" +state real ICING_LG ij misc 1 - rh02 "ICING_LG" "TOTAL COLUMN INTEGRATED ICING (>50 um)" "kg m-2" +state real ICING_SM ij misc 1 - rh02 "ICING_SM" "TOTAL COLUMN INTEGRATED ICING (<50 um)" "kg m-2" +state real AFWA_PRECIP ij misc 1 - r "AFWA_PRECIP" "AFWA Diagnostic: Precipitation bucket" "mm" +state real AFWA_RAIN ij misc 1 - rh02 "AFWA_RAIN" "AFWA Diagnostic: Rain fall" "mm" +state real AFWA_SNOW ij misc 1 - rh02 "AFWA_SNOW" "AFWA Diagnostic: Liq Equiv Snow fall" "mm" +state real AFWA_ICE ij misc 1 - rh02 "AFWA_ICE" "AFWA Diagnostic: Ice fall" "mm" +state real AFWA_FZRA ij misc 1 - rh02 "AFWA_FZRA" "AFWA Diagnostic: Freezing rain fall" "mm" +state real AFWA_SNOWFALL ij misc 1 - rh02 "AFWA_SNOWFALL" "AFWA Diagnostic: Snow fall" "mm" +state real AFWA_VIS ij misc 1 - rh02 "AFWA_VIS" "AFWA Diagnostic: Visibility" "m" +state real AFWA_VIS_DUST ij misc 1 - rh02 "AFWA_VIS_DUST" "AFWA Diagnostic: Visibility due to dust" "m" +state real AFWA_CLOUD ij misc 1 - rh02 "AFWA_CLOUD" "AFWA Diagnostic: Cloud cover fraction" "fraction" +state real AFWA_CLOUD_CEIL ij misc 1 - rh02 "AFWA_CLOUD_CEIL" "AFWA Diagnostic: Cloud ceiling" "m" +state real AFWA_CAPE ij misc 1 - rh02 "AFWA_CAPE" "AFWA Diagnostic: Convective Avail Pot Energy" "J kg-1" +state real AFWA_ZLFC ij misc 1 - rh02 "AFWA_ZLFC" "AFWA Diagnostic: Level of Free Convection" "m" +state real AFWA_PLFC ij misc 1 - rh02 "AFWA_PLFC" "AFWA Diagnostic: Pressure of LFC" "Pa" +state real MIDRH_MIN ij misc 1 - rh02 "MIDRH_MIN" "Min Mid-level relative humidity" "%" +state real MIDRH_MIN_OLD ij misc 1 - - "MIDRH_MIN_OLD" "Previous Min Mid-level relative humidity" "%" +state real AFWA_HAIL ij misc 1 - rh02 "AFWA_HAIL" "AFWA Diagnostic: Hail Diameter (Weibull)" "mm" +state real AFWA_LLWS ij misc 1 - rh02 "AFWA_LLWS" "AFWA Diagnostic: 0-2000 ft wind shear" "m s-1" +state real AFWA_TORNADO ij misc 1 - rh02 "AFWA_TORNADO" "AFWA Diagnostic: Tornado wind speed (Weibull)" "m s-1" +# <--GAC + + # Placeholder for decoupled advective tendency diagnostics for non-chem state real - ikjf advh_t 1 - - - state real advh_qv ikjf advh_t 1 - - "advh_qv" "ACCUMULATED HORIZONTAL TENDENCY FOR WATER VAPOR" "kg kg-1" @@ -1532,13 +1719,13 @@ state real - ikjf advz_t 1 - - - state real advz_qv ikjf advz_t 1 - - "advz_qv" "ACCUMULATED VERTICAL TENDENCY FOR WATER VAPOR" "kg kg-1" # Ocean Mixed-Layer State Variables -state real TML ij misc 1 - rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "TML" "OCEAN MIXED-LAYER TEMPERATURE" "K" -state real T0ML ij misc 1 - rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "T0ML" "INITIAL OCEAN MIXED-LAYER TEMPERATURE" "K" -state real HML ij misc 1 - rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "HML" "OCEAN MIXED-LAYER DEPTH" "m" -state real H0ML ij misc 1 - i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "H0ML" "INITIAL OCEAN MIXED-LAYER DEPTH" "m" -state real HUML ij misc 1 - rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "HUML" "OCEAN MIXED-LAYER DEPTH * U-CURRENT" " m2s-1 " -state real HVML ij misc 1 - rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "HVML" "OCEAN MIXED-LAYER DEPTH * V-CURRENT" " m2s-1 " -state real TMOML ij misc 1 - i012rhd=(interp_mask_water_field:lu_index,iswater)u=(copy_fcnm) "TMOML" "OCEAN LAYER MEAN TEMPERATURE " "K" +state real TML ij misc 1 - rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TML" "OCEAN MIXED-LAYER TEMPERATURE" "K" +state real T0ML ij misc 1 - rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T0ML" "INITIAL OCEAN MIXED-LAYER TEMPERATURE" "K" +state real HML ij misc 1 - rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "HML" "OCEAN MIXED-LAYER DEPTH" "m" +state real H0ML ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H0ML" "INITIAL OCEAN MIXED-LAYER DEPTH" "m" +state real HUML ij misc 1 - rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "HUML" "OCEAN MIXED-LAYER DEPTH * U-CURRENT" " m2s-1 " +state real HVML ij misc 1 - rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "HVML" "OCEAN MIXED-LAYER DEPTH * V-CURRENT" " m2s-1 " +state real TMOML ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TMOML" "OCEAN LAYER MEAN TEMPERATURE " "K" # track output state real track_z {tl}k misc 1 - - "track_z" "mid-level Height" "m" state real track_t {tl}k misc 1 - - "track_t" "mid-level temperature" "K" @@ -1641,11 +1828,14 @@ rconfig integer time_step_fract_den namelist,domains 1 1 rconfig integer time_step_dfi namelist,domains 1 - ih "time_step_dfi" rconfig integer min_time_step namelist,domains max_domains -1 h "min_time_step" +rconfig integer min_time_step_den namelist,domains max_domains 0 h "min_time_step denominator" rconfig integer max_time_step namelist,domains max_domains -1 h "max_time_step" +rconfig integer max_time_step_den namelist,domains max_domains 0 h "max_time_step denominator" rconfig real target_cfl namelist,domains max_domains 1.2 h "target_cfl" rconfig real target_hcfl namelist,domains max_domains 0.84 h "target_hcfl" rconfig integer max_step_increase_pct namelist,domains max_domains 5 h "max_step_increase_pct" rconfig integer starting_time_step namelist,domains max_domains -1 h "starting_time_step" +rconfig integer starting_time_step_den namelist,domains max_domains 0 h "starting_time_step denominator" rconfig logical step_to_output_time namelist,domains 1 .true. h "step_to_output_time" rconfig integer adaptation_domain namelist,domains 1 1 h "adaptation_domain" rconfig logical use_adaptive_time_step namelist,domains 1 .false. h "use_adaptive_time_step" @@ -1747,6 +1937,9 @@ rconfig integer max_ts_level namelist,domains 1 15 # track input rconfig integer track_loc_in namelist,domains 1 0 - "Number of track locations input" "" "" +# number of external model domains for coupling +rconfig integer num_ext_model_couple_dom namelist,domains 1 1 - "number of external models domains for coupling, used for the coupling mask" "" "" + # TC (tropical cyclone bogusing) rconfig logical insert_bogus_storm namelist,tc 1 .false. irh "insert_bogus_storm" "T/F for inserting a bogus typhoon" "flag" rconfig logical remove_storm namelist,tc 1 .false. irh "remove_storm" "T/F for only removing the original typhoon" "flag" @@ -1787,13 +1980,15 @@ rconfig integer sf_surface_physics namelist,physics max_domains 0 rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" rconfig integer bl_mynn_tkebudget namelist,physics max_domains 0 rh "bl_mynn_tkebudget" "" "" rconfig logical bl_mynn_tkeadvect namelist,physics max_domains .false. rh "bl_mynn_tkeadvect" "" "" +rconfig integer bl_mynn_cloudpdf namelist,physics 1 0 irh "bl_mynn_cloudpdf" "" "" rconfig integer mfshconv namelist,physics max_domains 1 rh "mfshconv" "To activate mass flux scheme with qnse, 1=true or 0=false" "" rconfig integer sf_urban_physics namelist,physics max_domains 0 rh "sf_urban_physics" "activate urban model 0=no, 1=Noah_UCM 2=BEP_UCM" "" rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" rconfig integer shcu_physics namelist,physics max_domains 0 rh "shcu_physics" "" "" -rconfig integer cu_diag namelist,physics max_domains 0 rh "cu_diag" " additional t-averaged stuff for cuphys" "" -rconfig integer kfeta_trigger namelist,physics 1 1 rh "KFETA Trigger function" "" "" +rconfig integer cu_diag namelist,physics max_domains 0 rh "cu_diag" "additional t-averaged stuff for cuphys" "" +rconfig integer kfeta_trigger namelist,physics 1 1 rh "KFETA Trigger function" "" "" +rconfig integer nsas_dx_factor namelist,physics 1 1 rh "NSAS DX-dependent option" "" "" rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" @@ -1806,10 +2001,13 @@ rconfig integer maxpatch namelist,physics 1 10 rconfig integer num_snow_layers namelist,physics 1 3 irh "num_snow_layers" "" "" rconfig integer num_snso_layers namelist,physics 1 7 irh "num_snso_layers" "" "" rconfig integer num_urban_layers namelist,physics 1 400 irh "num_urban_layers" "" "" -rconfig integer num_urban_hi namelist,physics 1 15 irh "num_urban_hi" "" "" +rconfig integer num_urban_hi namelist,physics 1 15 irh "num_urban_hi" "" "" rconfig integer num_months namelist,physics 1 12 irh "num_months" "" "" -rconfig integer mosaic_lu namelist,physics 1 0 irh "mosaic_lu" "" "" -rconfig integer mosaic_soil namelist,physics 1 0 irh "mosaic_soil" "" "" +rconfig integer sf_surface_mosaic namelist,physics 1 0 rh "sf_surface_mosaic" "1= mosaic, 0=no mosaic method, add by danli" "" +rconfig integer mosaic_cat namelist,physics 1 3 rh "mosaic_cat" "works when sf_surface_mosaic=1; it is the number of mosaic tiles" "" +rconfig integer mosaic_cat_soil derived 1 12 rh "mosaic_cat_soil" "should be the number of soil layers times the mosaic_cat" "" +rconfig integer mosaic_lu namelist,physics 1 0 irh "mosaic_lu" "" "" +rconfig integer mosaic_soil namelist,physics 1 0 irh "mosaic_soil" "" "" rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" @@ -1824,8 +2022,9 @@ rconfig integer num_land_cat namelist,physics 1 24 rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" -rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig real seaice_threshold namelist,physics 1 100 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" rconfig integer sst_update namelist,physics 1 0 h "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" + rconfig integer sst_skin namelist,physics 1 0 h "sst_skin" "calculate sst skin temperature 0=no, 1=yes" "" rconfig integer tmn_update namelist,physics 1 0 h "tmn_update" "update tmn from calculation 0=no, 1=yes" "" rconfig logical usemonalb namelist,physics 1 .false. h "usemonalb" "use 2d field vs table values false=table, True=2d" "" @@ -1844,7 +2043,18 @@ rconfig integer no_src_types namelist,physics 1 1 rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" rconfig integer o3input namelist,physics 1 0 - "o3input" "ozone input option for radiation" "" rconfig integer aer_opt namelist,physics 1 0 - "aer_opt" "aerosol input option for radiation" "" -rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" "" +rconfig integer swint_opt namelist,physics 1 0 - "swint_opt" "interpolation option for sw radiation" "" +rconfig integer aer_type namelist,physics max_domains 1 irh "aer_type" "aerosol type: 1 is SF79 rural, 2 is SF79 urban" "" +rconfig integer aer_aod550_opt namelist,physics max_domains 1 irh "aer_aod550_opt" "input option for aerosol optical depth at 550 nm" "" +rconfig integer aer_angexp_opt namelist,physics max_domains 1 irh "aer_angexp_opt" "input option for aerosol Angstrom exponent" "" +rconfig integer aer_ssa_opt namelist,physics max_domains 1 irh "aer_ssa_opt" "input option for aerosol single-scattering albedo" "" +rconfig integer aer_asy_opt namelist,physics max_domains 1 irh "aer_asy_opt" "input option for aerosol asymmetry parameter" "" +rconfig real aer_aod550_val namelist,physics max_domains 0.12 irh "aer_aod550_val" "fixed value for aerosol optical depth at 550 nm. Valid when aer_aod550_opt=1" "" +rconfig real aer_angexp_val namelist,physics max_domains 1.3 irh "aer_angexp_val" "fixed value for aerosol Angstrom exponent. Valid when aer_angexp_opt=1" "" +rconfig real aer_ssa_val namelist,physics max_domains 0.85 irh "aer_ssa_val" "fixed value for aerosol single-scattering albedo. Valid when aer_ssa_opt=1" "" +rconfig real aer_asy_val namelist,physics max_domains 0.90 irh "aer_asy_val" "fixed value for aerosol asymmetry parameter. Valid when aer_asy_opt=1" "" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. irh "feedback of cumulus cloud to radiation" "" +rconfig integer ICLOUD_CU derived 1 0 - "ICLOUD_CU" "" "" rconfig integer pxlsm_smois_init namelist,physics max_domains 1 irh "PXLSM_SMOIS_INIT" "Soil moisture initialization option 0-From analysis 1-From MAVAIL" "" rconfig integer omlcall namelist,physics 1 0 h "omlcall" "temporary holder to allow checking for new name: oml_opt" rconfig integer sf_ocean_physics namelist,physics 1 0 h "sf_ocean_physics" "activate ocean model 0=no, 1=1d mixed layer, 2=3D PWP" "" @@ -1879,6 +2089,26 @@ rconfig integer bucketr_opt derived 1 0 rconfig integer process_time_series derived 1 0 - "process_time_series" "0=no, 1=yes" "" rconfig integer grav_settling namelist,physics max_domains 0 h "grav_settling" "activate gravitationalsettling of fog 0=no, 1=yes" +rconfig real sas_pgcon namelist,physics max_domains 0.55 irh "sas_pgcon" "convectively forced pressure gradient factor (SAS scheme)" "" +rconfig integer scalar_pblmix namelist,physics max_domains 0 h "mix 4d scalar variables with pbl scheme 0=no 1=yes" "" +rconfig integer tracer_pblmix namelist,physics max_domains 1 h "mix 4d tracer variables with pbl scheme 0=no 1=yes" "" +rconfig logical use_aero_icbc namelist,physics 1 .false. rh "use_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero" "logical flag" + +# GAC--> +# AFWA Diagnostics package namelist options +rconfig integer afwa_diag_opt namelist,afwa max_domains 0 rh "afwa_diag_opt" "AFWA Diagnostic option, 1: on" "" +rconfig integer afwa_ptype_opt namelist,afwa max_domains 0 rh "afwa_ptype_opt" "AFWA Diagnostic: Precip type option, 1: on" "" +rconfig integer afwa_vil_opt namelist,afwa max_domains 0 rh "afwa_vil_opt" "AFWA Diagnostic: Vert Int Liquid option, 1: on" "" +rconfig integer afwa_radar_opt namelist,afwa max_domains 0 rh "afwa_radar_opt" "AFWA Diagnostic: Radar option, 1: on" "" +rconfig integer afwa_severe_opt namelist,afwa max_domains 0 rh "afwa_severe_opt" "AFWA Diagnostic: Severe Wx option, 1: on" "" +rconfig integer afwa_icing_opt namelist,afwa max_domains 0 rh "afwa_icing_opt" "AFWA Diagnostic: Icing option, 1: on" "" +rconfig integer afwa_vis_opt namelist,afwa max_domains 0 rh "afwa_vis_opt" "AFWA Diagnostic: Visibility option, 1: on" "" +rconfig integer afwa_cloud_opt namelist,afwa max_domains 0 rh "afwa_cloud_opt" "AFWA Diagnostic: Cloud option, 1: on" "" +rconfig real afwa_ptype_ccn_tmp namelist,afwa 1 264.15 h "afwa_ptype_ccn_tmp" "AFWA Diagnostic: CCN temperature for precipitation type calculation" "K" +rconfig real afwa_ptype_tot_melt namelist,afwa 1 50.0 h "afwa_ptype_tot_melt" "AFWA Diagnostic: Total melting energy for precipitation type calculation" "J kg-1" +rconfig real afwa_ccn_conc namelist,afwa 1 1.0E8 h "afwa_ccn_conc" "AFWA Diagnostic: CCN concentration" "# m-3" +rconfig integer afwa_hail_opt namelist,afwa 1 0 rh "afwa_hail_opt" "AFWA Diagnostic: Hail/Graupel switch, 1:hail, 0:graupel" "" +# <--GAC # For Noah-MP rconfig integer dveg namelist,noah_mp 1 4 h "dveg" "dynamic vegetation (1 -> off ; 2 -> on)" "" @@ -1893,6 +2123,7 @@ rconfig integer opt_alb namelist,noah_mp 1 2 h " rconfig integer opt_snf namelist,noah_mp 1 1 h "opt_snf" "rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah)" "" rconfig integer opt_tbot namelist,noah_mp 1 2 h "opt_tbot" "lower boundary of soil temperature (1->zero-flux; 2->Noah)" "" rconfig integer opt_stc namelist,noah_mp 1 1 h "opt_stc" "soil/snow temperature time scheme 1->semi-implicit; 2->full-implicit (original Noah)" "" +rconfig real WTDDT namelist,physics max_domains 30. h "wtddt" "minutes between calls to lateral hydro" "" # For WRF Hydro rconfig integer wrf_hydro derived 1 0 h "wrf_hydro" "descrip" "unit" @@ -1988,6 +2219,7 @@ rconfig logical obs_ipf_in4dob namelist,fdda 1 rconfig logical obs_ipf_errob namelist,fdda 1 .false. h "obs_ipf_errob" "Print obs error diagnostics" "" rconfig logical obs_ipf_nudob namelist,fdda 1 .false. h "obs_ipf_nudob" "Print obs nudge diagnostics" "" rconfig logical obs_ipf_init namelist,fdda 1 .true. h "obs_ipf_init" "Enable obs init warning messages" "" +rconfig integer obs_scl_neg_qv_innov namelist,fdda 1 0 h "obs_scl_neg_qv_innov" "Scale certain negative QV innovations" "" # Single-column model (SCM) rconfig integer scm_force namelist,scm 1 0 rh "scm_force" "SCM forcing switch" "" @@ -2022,15 +2254,16 @@ rconfig integer dyn_opt namelist,dynamics 1 2 rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" # diff_opt 1=old diffusion, 2=new -rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +rconfig integer diff_opt namelist,dynamics max_domains -1 irh "diff_opt" "" "" +# diff_opt_dfi is needed for backwards integration in dfi +rconfig integer diff_opt_dfi namelist,dynamics max_domains 0 irh "diff_opt_dfi" "" "" # km_opt 1=old coefs, 2=tke, 3=Smagorinksy -rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer km_opt namelist,dynamics max_domains -1 irh "km_opt" "" "" # km_opt_dfi is needed for backward integration in dfi -rconfig integer km_opt_dfi namelist,dynamics 1 1 irh "km_opt_dfi" "" "" +rconfig integer km_opt_dfi namelist,dynamics max_domains 1 irh "km_opt_dfi" "" "" rconfig integer damp_opt namelist,dynamics 1 0 irh "damp_opt" "" "" rconfig integer rad_nudge namelist,dynamics 1 0 irh "rad_nudge" "" "" rconfig integer gwd_opt namelist,dynamics 1 0 irh "gwd_opt" "" "" -rconfig real sas_pgcon namelist,physics max_domains 0.55 irh "sas_pgcon" "convectively forced pressure gradient factor (SAS scheme)" "" rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" rconfig real dampcoef namelist,dynamics max_domains 0. h "dampcoef" "" "" rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" @@ -2100,6 +2333,8 @@ rconfig logical polar namelist,bdy_control max_domains .f rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" rconfig real spec_exp namelist,bdy_control 1 0. irh "spec_exp" "" "" rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" +rconfig logical have_bcs_moist namelist,bdy_control max_domains .false. rh "have_bcs_moist" "" "" +rconfig logical have_bcs_scalar namelist,bdy_control max_domains .false. rh "have_bcs_scalar" "" "" rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" @@ -2108,7 +2343,7 @@ rconfig integer compression namelist,grib2 1 40 r # NAMELIST DERIVED rconfig integer nobs_ndg_vars derived 1 6 - "num_ndg_vars" "Number of nudging variables" "" -rconfig integer nobs_err_flds derived 1 9 - "num_err_flds" "Number of error fields" "" +rconfig integer nobs_err_flds derived 1 10 - "num_err_flds" "Number of error fields" "" rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" @@ -2148,25 +2383,9 @@ rconfig integer mp_physics_dfi derived max_domains # Single dummy declaration to define a nodyn dyn option state integer nodyn_dummy - dyn_nodyn - - - "" "" "" -# Turbine drag (td) physics -# Turbine positions and characteristics for real-data cases are specified in a file -# whose name is given in the windturbines_spec variable. If the setting is "ideal", -# the td_ variables specify idealized wind farm geometries and turbine characteristics. -# If the setting is "none" then wind turbine drag physics is turned off. -rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name" -rconfig integer td_turbgridid namelist,physics 1 -1 - - "" "which grid id has turbines in it" -rconfig real td_hubheight namelist,physics 1 100. - - "" "hub height (m)" -rconfig real td_diameter namelist,physics 1 60. - - "" "turbine diameter (m)" -rconfig real td_stdthrcoef namelist,physics 1 .158 - - "" "standing thrust coefficient" -rconfig real td_cutinspeed namelist,physics 1 4. - - "" "cut-in speed (m/s)" -rconfig real td_cutoutspeed namelist,physics 1 27. - - "" "cut-out speed (m/s)" -rconfig real td_power namelist,physics 1 2. - - "" "turbine power (MW)" -rconfig real td_turbpercell namelist,physics 1 1. - - "" "number of turbines per cell" -rconfig integer td_ewfx namelist,physics 1 0 - - "" "extent of wind farm in x-cells" -rconfig integer td_ewfy namelist,physics 1 0 - - "" "extent of wind farm in y-cells" -rconfig integer td_pwfx namelist,physics 1 1 - - "" "southwest corner of wind farm in x-cells" -rconfig integer td_pwfy namelist,physics 1 1 - - "" "southwest corner of wind farm in y-cells" - +# Turbine drag physics. +rconfig integer windfarm_opt namelist,physics max_domains 0 rh "windfarm_opt" "" "" +rconfig integer windfarm_ij namelist,physics 1 0 rh "windfarm_ij" "" "" # #--------------------------------------------------------------------------------------------------------------------------------------- # Package Declarations @@ -2185,10 +2404,11 @@ package wsm5scheme mp_physics==4 - moist:qv,qc,q package etampnew mp_physics==5 - moist:qv,qc,qr,qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg -package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr;state:re_cloud,re_ice,re_snow +package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng -package cammgmpscheme mp_physics==11 - moist:qv,qc,qi,qr,qs;scalar:qnc,qni,qnr,qns;state:rh_old_mp,lcd_old_mp,cldfra_old_mp,cldfra_mp,cldfra_mp_all,cldfra_conv,cldfrai,cldfral,turbtype3d,smaw3d,wsedl3d,icwmrdp3d,dp3d,shfrc3d,dlf,dlf2,tke_pbl +package cammgmpscheme mp_physics==11 - moist:qv,qc,qi,qr,qs;scalar:qnc,qni,qnr,qns;state:rh_old_mp,lcd_old_mp,cldfra_old_mp,cldfra_mp,cldfra_mp_all,cldfra_conv,cldfrai,cldfral,turbtype3d,smaw3d,wsedl3d,icwmrdp3d,dp3d,shfrc3d,dlf,dlf2,tke_pbl,lradius,iradius #package milbrandt3mom mp_physics==12 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qzr,qzi,qzs,qzg,qzh package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs;state:rimi package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr @@ -2209,7 +2429,8 @@ package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr +package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng #package milbrandt3mom_dfi mp_physics_dfi==12 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qzr,dfi_qzi,dfi_qzs,dfi_qzg,dfi_qzh @@ -2241,14 +2462,14 @@ package goddardswscheme ra_sw_physics==5 - state:tswdn,t package flgswscheme ra_sw_physics==7 - - package gfdlswscheme ra_sw_physics==99 - - -package sfclayscheme sf_sfclay_physics==1 - - +package sfclayscheme sf_sfclay_physics==91 - - package myjsfcscheme sf_sfclay_physics==2 - state:tke_pbl package gfssfcscheme sf_sfclay_physics==3 - - package qnsesfcscheme sf_sfclay_physics==4 - - -package mynnsfcscheme sf_sfclay_physics==5 - state:qke,tsq,qsq,cov +package mynnsfcscheme sf_sfclay_physics==5 - state:sh3d,tsq,qsq,cov package pxsfcscheme sf_sfclay_physics==7 - - package temfsfcscheme sf_sfclay_physics==10 - state:wm_temf -package sfclayrevscheme sf_sfclay_physics==11 - - +package sfclayrevscheme sf_sfclay_physics==1 - - package idealscmsfcscheme sf_sfclay_physics==89 - - package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,mh_urb2d,stdh_urb2d,lf_urb2d,lp_urb2d,hgt_urb2d,lb_urb2d @@ -2258,18 +2479,20 @@ package bep_bemscheme sf_urban_physics==3 - state:a_u_bep package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag,soilt1 -package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy +package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy,fdepthxy,areaxy,rivercondxy,riverbedxy,eqzwt,pexpxy,qrfxy,qrfsxy,qspringxy,qspringsxy,qslatxy,stepwtd package clmscheme sf_surface_physics==5 - state:numc,nump,sabv,sabg,lwup,lhsoi,lhveg,lhtran,snl,snowdp,wtc,wtp,h2osno,t_grnd,t_veg,h2ocan,h2ocan_col,t2m_max,t2m_min,t2clm,t_ref2m,h2osoi_liq_s1,h2osoi_liq_s2,h2osoi_liq_s3,h2osoi_liq_s4,h2osoi_liq_s5,h2osoi_liq1,h2osoi_liq2,h2osoi_liq3,h2osoi_liq4,h2osoi_liq5,h2osoi_liq6,h2osoi_liq7,h2osoi_liq8,h2osoi_liq9,h2osoi_liq10,h2osoi_ice_s1,h2osoi_ice_s2,h2osoi_ice_s3,h2osoi_ice_s4,h2osoi_ice_s5,h2osoi_ice1,h2osoi_ice2,h2osoi_ice3,h2osoi_ice4,h2osoi_ice5,h2osoi_ice6,h2osoi_ice7,h2osoi_ice8,h2osoi_ice9,h2osoi_ice10,t_soisno_s1,t_soisno_s2,t_soisno_s3,t_soisno_s4,t_soisno_s5,t_soisno1,t_soisno2,t_soisno3,t_soisno4,t_soisno5,t_soisno6,t_soisno7,t_soisno8,t_soisno9,t_soisno10,dzsnow1,dzsnow2,dzsnow3,dzsnow4,dzsnow5,snowrds1,snowrds2,snowrds3,snowrds4,snowrds5,t_lake1,t_lake2,t_lake3,t_lake4,t_lake5,t_lake6,t_lake7,t_lake8,t_lake9,t_lake10,h2osoi_vol1,h2osoi_vol2,h2osoi_vol3,h2osoi_vol4,h2osoi_vol5,h2osoi_vol6,h2osoi_vol7,h2osoi_vol8,h2osoi_vol9,h2osoi_vol10,albedosubgrid,lhsubgrid,hfxsubgrid,lwupsubgrid,q2subgrid,sabvsubgrid,sabgsubgrid,nrasubgrid,swupsubgrid package pxlsmscheme sf_surface_physics==7 - state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old package ssibscheme sf_surface_physics==8 - state:ssib_fm,ssib_fh,ssib_cm,ssibxdd,ssib_br,ssib_lhf,ssib_shf,ssib_ghf,ssib_egs,ssib_eci,ssib_ect,ssib_egi,ssib_egt,ssib_sdn,ssib_sup,ssib_ldn,ssib_lup,ssib_wat,ssib_shc,ssib_shg,ssib_lai,ssib_vcf,ssib_z00,ssib_veg,isnow,swe,snowden,snowdepth,tkair,dzo1,wo1,tssn1,tssno1,bwo1,bto1,cto1,fio1,flo1,bio1,blo1,ho1,dzo2,wo2,tssn2,tssno2,bwo2,bto2,cto2,fio2,flo2,bio2,blo2,ho2,dzo3,wo3,tssn3,tssno3,bwo3,bto3,cto3,fio3,flo3,bio3,blo3,ho3,dzo4,wo4,tssn4,tssno4,bwo4,bto4,cto4,fio4,flo4,bio4,blo4,ho4 +package noahmosaicscheme sf_surface_mosaic==1 - state:TSK_mosaic,QSFC_mosaic,TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic,CANWAT_mosaic,SNOW_mosaic,SNOWH_mosaic,SNOWC_mosaic,ALBEDO_mosaic,ALBBCK_mosaic,EMISS_mosaic,EMBCK_mosaic,ZNT_mosaic,Z0_mosaic,HFX_mosaic,QFX_mosaic,LH_mosaic,GRDFLX_mosaic,SNOTIME_mosaic,TR_URB2D_mosaic,TB_URB2D_mosaic,TG_URB2D_mosaic,TC_URB2D_mosaic,TS_URB2D_mosaic,TS_RUL2D_mosaic,QC_URB2D_mosaic,UC_URB2D_mosaic,TRL_URB3D_mosaic,TBL_URB3D_mosaic,TGL_URB3D_mosaic,SH_URB2D_mosaic,LH_URB2D_mosaic,G_URB2D_mosaic,RN_URB2D_mosaic,mosaic_cat_index,landusef2 + package ysuscheme bl_pbl_physics==1 - - package myjpblscheme bl_pbl_physics==2 - state:tke_pbl,el_pbl package gfsscheme bl_pbl_physics==3 - - package qnsepblscheme bl_pbl_physics==4 - state:tke_pbl,el_pbl,massflux_EDKF,entr_EDKF,detr_EDKF,thl_up,thv_up,rv_up,rt_up,rc_up,u_up,v_up,frac_up,rc_mf package qnsepbl09scheme bl_pbl_physics==94 - state:tke_pbl,el_pbl -package mynnpblscheme2 bl_pbl_physics==5 - scalar:qke_adv;state:qke,tsq,qsq,cov,el_mynn -package mynnpblscheme3 bl_pbl_physics==6 - scalar:qke_adv;state:qke,tsq,qsq,cov,el_mynn +package mynnpblscheme2 bl_pbl_physics==5 - scalar:qke_adv;state:qke,tke_pbl,sh3d,tsq,qsq,cov,el_pbl +package mynnpblscheme3 bl_pbl_physics==6 - scalar:qke_adv;state:qke,tke_pbl,sh3d,tsq,qsq,cov,el_pbl package mynn_tkebudget bl_mynn_tkebudget==1 - state:qSHEAR,qBUOY,qDISS,qWT,dqke package acmpblscheme bl_pbl_physics==7 - - package boulacscheme bl_pbl_physics==8 - state:el_pbl,tke_pbl,wu_tur,wv_tur,wt_tur,wq_tur @@ -2281,11 +2504,12 @@ package kfetascheme cu_physics==1 - - package bmjscheme cu_physics==2 - - package gdscheme cu_physics==93 - - package sasscheme cu_physics==84 - - +package meso_sas cu_physics==85 - - package osasscheme cu_physics==4 - - package g3scheme cu_physics==5 - state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow package gfscheme cu_physics==3 - state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow package camzmscheme cu_physics==7 - state:precz,zmdt,zmdq,zmdice,zmdliq,evaptzm,fzsntzm,evsntzm,evapqzm,zmflxprc,zmflxsnw,zmntprpd,zmntsnpd,zmeiheat,cmfmc,cmfmcdzm,preccdzm,pconvb,pconvt,cape,zmmtu,zmmtv,zmmu,zmmd,zmupgu,zmupgd,zmvpgu,zmvpgd,zmicuu,zmicud,zmicvu,zmicvd,evapcdp3d,icwmrdp3d,rprddp3d,dp3d,du3d,ed3d,eu3d,md3d,mu3d,dsubcld2d,ideep2d,jt2d,maxg2d,lengath2d,dlf,rliq,tpert2d -package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD_B,GD_CLOUD2_A,GD_CLOUD2_B,kbcon_deep,ktop_deep,k22_deep +package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep package tiedtkescheme cu_physics==6 - - package nsasscheme cu_physics==14 - - package kfscheme cu_physics==99 - - @@ -2294,6 +2518,10 @@ package g3shcuscheme shcu_physics==1 - - package camuwshcuscheme shcu_physics==2 - state:shfrc3d,dlf,dlf2,cmfmc,cmfmc2,qtflx_cu,slflx_cu,uflx_cu,vflx_cu,qtten_cu,slten_cu,uten_cu,vten_cu,qvten_cu,qlten_cu,qiten_cu,cbmf_cu,ufrcinvbase_cu,ufrclcl_cu,winvbase_cu,wlcl_cu,plcl_cu,pinv_cu,plfc_cu,pbup_cu,ppen_cu,qtsrc_cu,thlsrc_cu,thvlsrc_cu,emkfbup_cu,cin_cu,cinlcl_cu,cbmflimit_cu,tkeavg_cu,zinv_cu,rcwp_cu,rlwp_cu,riwp_cu,tophgt_cu,wu_cu,ufrc_cu,qtu_cu,thlu_cu,thvu_cu,uu_cu,vu_cu,qtu_emf_cu,thlu_emf_cu,uu_emf_cu,vu_emf_cu,umf_cu,uemf_cu,qcu_cu,qlu_cu,qiu_cu,cufrc_cu,fer_cu,fdr_cu,dwten_cu,diten_cu,qrten_cu,qsten_cu,flxrain_cu,flxsnow_cu,ntraprd_cu,ntsnprd_cu,excessu_cu,excessu0_cu,xc_cu,aquad_cu,bquad_cu,cquad_cu,bogbot_cu,bogtop_cu,exit_uwcu_cu,exit_conden_cu,exit_klclmkx_cu,exit_klfcmkx_cu,exit_ufrc_cu,exit_wtw_cu,exit_drycore_cu,exit_wu_cu,exit_cufliter_cu,exit_kinv1_cu,exit_rei_cu,limit_shcu_cu,limit_negcon_cu,limit_ufrc_cu,limit_ppen_cu,limit_emf_cu,limit_cinlcl_cu,limit_cin_cu,limit_cbmf_cu,limit_rei_cu,ind_delcin_cu,evapcsh,cmfsl,cmflq,cldfrash,cush,icwmrsh,snowsh,rprdsh,rliq2,rliq package grimsshcuscheme shcu_physics==3 - - +package fogsettling0 grav_settling==0 - state:vdfg +package fogsettling1 grav_settling==1 - state:vdfg,fgdp,dfgdp +package fogsettling2 grav_settling==2 - state:vdfg,fgdp,dfgdp + package psufddagd grid_fdda==1 - fdda3d:u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,ph_ndg_old,u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,ph_ndg_new;fdda2d:mu_ndg_old,mu_ndg_new;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten package psusfddagd grid_sfdda==1 - state:u10_ndg_old,v10_ndg_old,t2_ndg_old,th2_ndg_old,q2_ndg_old,rh_ndg_old,psl_ndg_old,ps_ndg_old,u10_ndg_new,v10_ndg_new,t2_ndg_new,th2_ndg_new,q2_ndg_new,rh_ndg_new,psl_ndg_new,ps_ndg_new,tob_ndg_old,odis_ndg_old,tob_ndg_new,odis_ndg_new @@ -2323,6 +2551,18 @@ package wenopd_scalar moist_adv_opt==4 - - package maxmin_output output_diagnostics==1 - state:t2min,t2max,tt2min,tt2max,t2mean,t2std,q2min,q2max,tq2min,tq2max,q2mean,q2std,skintempmin,skintempmax,tskintempmin,tskintempmax,skintempmean,skintempstd,u10max,v10max,spduv10max,tspduv10max,u10mean,v10mean,spduv10mean,u10std,v10std,spduv10std,raincvmax,rainncvmax,traincvmax,trainncvmax,raincvmean,rainncvmean,raincvstd,rainncvstd package nwp_output nwp_diagnostics==1 - state:wspd10max,w_up_max,w_dn_max,up_heli_max,w_mean,grpl_max +# GAC--> +# Package declaration for AFWA diagnostics +package afwa_diag afwa_diag_opt==1 - - +package afwa_ptype afwa_ptype_opt==1 - state:afwa_precip,afwa_rain,afwa_snow,afwa_ice,afwa_fzra,afwa_snowfall +package afwa_vil afwa_vil_opt==1 - state:vil,radarvil +package afwa_radar afwa_radar_opt==1 - state:echotop,refd_com,refd +package afwa_severe afwa_severe_opt==1 - state:wspd10max,w_up_max,w_dn_max,tcoli_max +package afwa_icing afwa_icing_opt==1 - state:fzlev,icingtop,icingbot,qicing_lg,qicing_sm,icing_lg,icing_sm,qicing_lg_max,qicing_sm_max +package afwa_cloud afwa_cloud_opt==1 - state:afwa_cloud +package afwa_vis afwa_vis_opt==1 - state:afwa_vis,afwa_vis_dust +# <--GAC + package dfi_setup dfi_stage==0 - - package dfi_bck dfi_stage==1 - - package dfi_fwd dfi_stage==2 - - @@ -2335,7 +2575,7 @@ package dfi_nodfi dfi_opt==0 - - package dfi_dfl dfi_opt==1 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad -package realonly use_wps_input==1 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc,sm000007,sm007028,sm028100,sm100255,st000007,st007028,st028100,st100255,sm000010,sm010040,sm040100,sm100200,sm010200,soilm000,soilm005,soilm020,soilm040,soilm160,soilm300,sw000010,sw010040,sw040100,sw100200,sw010200,soilw000,soilw005,soilw020,soilw040,soilw160,soilw300,st000010,st010040,st040100,st100200,st010200,soilt000,soilt005,soilt020,soilt040,soilt160,soilt300,fad0_urb2d,fad135_urb2d,fad45_urb2d,pad_urb2d,fad90_urb2d,rad_urb2d,car_urb2d,h2w_urb2d,svf_urb2d,z0s_urb2d,z0r_urb2d,z0m_urb2d,zds_urb2d,zdm_urb2d,zdr_urb2d +package realonly use_wps_input==1 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc,sm000007,sm007028,sm028100,sm100255,st000007,st007028,st028100,st100255,sm000010,sm010040,sm040100,sm100200,sm010200,soilm000,soilm005,soilm020,soilm040,soilm160,soilm300,sw000010,sw010040,sw040100,sw100200,sw010200,soilw000,soilw005,soilw020,soilw040,soilw160,soilw300,st000010,st010040,st040100,st100200,st010200,soilt000,soilt005,soilt020,soilt040,soilt160,soilt300,fad0_urb2d,fad135_urb2d,fad45_urb2d,pad_urb2d,fad90_urb2d,rad_urb2d,car_urb2d,h2w_urb2d,svf_urb2d,z0s_urb2d,z0r_urb2d,z0m_urb2d,zds_urb2d,zdm_urb2d,zdr_urb2d,qnwfa_now,qnwfa_jan,qnwfa_feb,qnwfa_mar,qnwfa_apr,qnwfa_may,qnwfa_jun,qnwfa_jul,qnwfa_aug,qnwfa_sep,qnwfa_oct,qnwfa_nov,qnwfa_dec,qnifa_now,qnifa_jan,qnifa_feb,qnifa_mar,qnifa_apr,qnifa_may,qnifa_jun,qnifa_jul,qnifa_aug,qnifa_sep,qnifa_oct,qnifa_nov,qnifa_dec,qntemp,qntemp2 package tconly use_wps_input==2 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc package reg_interp nest_interp_coord==0 - - package flat_p_interp nest_interp_coord==1 - state:t_max_p,ght_max_p,max_p,t_min_p,ght_min_p,min_p @@ -2378,6 +2618,7 @@ rconfig real iccg_prescribed_num namelist,physics max_domains 0 rconfig real iccg_prescribed_den namelist,physics max_domains 1.0 - "iccg_prescribed_dem" "Denominator of user-specified prescribed IC:CG" "" rconfig integer cellcount_method namelist,physics max_domains 0 - "cellcount_method" "0=auto, 1=tile, 2=domain" "" rconfig real cldtop_adjustment namelist,physics max_domains 0. - "cldtop_adjustment" "Adjustment to cloud top for ltng param" "km" +rconfig integer sf_lake_physics namelist,physics max_domains 0 - "sf_lake_physics" "activate lake model 0=no, 1=yes" "" state real iccg_in_num ij misc 1 - i{16}r "iccg_in_num" "IC:CG input numerator" "" state real iccg_in_den ij misc 1 - i{16}r "iccg_in_den" "IC:CG input denominator" "" @@ -2406,6 +2647,10 @@ package io_pnetcdf io_form_restart==11 - - package no_wrfhydro wrf_hydro==0 - - package wrfhydro wrf_hydro==1 - state:SOLDRAIN, SFCHEADRT, INFXSRT +#WRF Windfarm +package no_windfarm windfarm_opt==0 - - +package fitchscheme windfarm_opt==1 - state:power + #--------------------------------------------------------------------------------------------------------------------------------------- ## communications @@ -2427,6 +2672,7 @@ halo HALO_EM_PHYS_SHCU dyn_em 4:rushten,rvshten halo HALO_EM_FDDA dyn_em 4:rundgdten,rvndgdten halo HALO_EM_FDDA_SFC dyn_em 48:z,z_at_w,pblh,regime,znt,odis_ndg_old,odis_ndg_new halo HALO_EM_PHYS_DIFFUSION dyn_em 4:defor11,defor22,defor12,defor13,defor23,div,xkmv,xkmh,xkhv,xkhh,tke_1,tke_2 +halo HALO_EM_SBM dyn_em 8:p_phy,pi_phy,dz8w,th_phy,rho,qv_old,th_old,u_phy,v_phy,moist halo HALO_EM_TKE_ADVECT_3 dyn_em 24:tke_2 halo HALO_EM_TKE_ADVECT_5 dyn_em 48:tke_2 halo HALO_EM_TKE_A dyn_em 4:ph_2,phb @@ -2483,6 +2729,8 @@ halo HALO_EM_SCALAR_OLD_E_7 dyn_em 80:scalar_old halo HALO_EM_FEEDBACK dyn_em 48:ht halo HALO_EM_HYDRO_UV dyn_em 8:u_2,v_2 +halo HALO_EM_HYDRO_NOAHMP dyn_em 8:ZWTXY +halo HALO_EM_HYDRO_NOAHMP_INIT dyn_em 8:ZWTXY,FDEPTHXY,HT,ISLTYP halo HALO_EM_COUPLE_A dyn_em 24:mub,mu_1,mu_2 period PERIOD_EM_COUPLE_A dyn_em 2:mub,mu_1,mu_2 diff --git a/wrfv2_fire/Registry/Registry.NMM b/wrfv2_fire/Registry/Registry.NMM index 5692131a..2585295a 100644 --- a/wrfv2_fire/Registry/Registry.NMM +++ b/wrfv2_fire/Registry/Registry.NMM @@ -40,6 +40,7 @@ # include registry.dimspec +include registry.lake #### 7. Edit the Registry file and create the state data assocaited with this #### solver. Single entry: @@ -120,6 +121,7 @@ state real t_gc ijg dyn_nmm 1 Z i1 "TT" state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" state real greenfrac_gc ijm dyn_nmm 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" state real albedo12m_gc ijm dyn_nmm 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real lai12m_gc ijm dyn_nmm 1 Z i1 "LAI12M" "monthly LAI" "m2/m2" state real soilcbot_gc ijs misc 1 Z i1 "SOILCBOT" "description" "units" state real soilctop_gc ijs misc 1 Z i1 "SOILCTOP" "description" "units" state real tmn_gc ij dyn_nmm 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" @@ -131,6 +133,12 @@ state real vlat_gc ij dyn_nmm 1 - i1 "XLAT_V state real hlon_gc ij dyn_nmm 1 - i1 "XLONG_M" "longitude, positive east" "degrees" state real hlat_gc ij dyn_nmm 1 - i1 "XLAT_M" "latitude, positive north" "degrees" + +# Smoother work variables: +state real relaxwork ij dyn_nmm 1 - r "relaxwork" "Temporary Tv storage array for the membrane MSLP overrelaxation loops" "K" +state integer relaximask ij dyn_nmm 1 - r "relaximask" "Integer mask array for the membrane MSLP overrelaxation loops" "K" +state logical relaxmask ij dyn_nmm 1 - r "relaxmask" "Mask array for the membrane MSLP overrelaxation loops" "K" + ############################################################## # Variables for nmm dynamics # @@ -157,6 +165,12 @@ state integer randstate4 ij dyn_nmm 1 - r "randstate4" "ran state real random ij dyn_nmm 1 - rh "random" "random number in [0,1) used by SAS" rconfig integer random_seed namelist,physics max_domains 0 irh "random_seed" "random number generator seed" +# Projection south and west bounds for Post: +rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain in rotated coordinates" +rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain in rotated coordinates" +state real wbd0var - dyn_nmm 0 - h "wbd0var" "western boundary of the domain in rotated coordinates" +state real sbd0var - dyn_nmm 0 - h "sbd0var" "southern boundary of the domain in rotated coordinates" + # # module_MASKS # @@ -274,6 +288,10 @@ state real pblh ij dyn_nmm 1 - rh "PBLH" "PBL Heig state integer lpbl ij dyn_nmm 1 - ir "LPBL" "Model layer of PBL top" "" state real mixht ij dyn_nmm 1 - rh "MIXHT" "MXL HEIGHT" "m" state real ustar ij dyn_nmm 1 - irh "USTAR" "Friction velocity" "m s-1" +state real mz0 ij dyn_nmm 1 - h "MZ0" "momentum Roughness length" "m" +state real rc2d ij dyn_nmm 1 - h "RC2D" "critical Richardson number" "m" +state real dku3d ijk dyn_nmm 1 - h "DKU3D" "Momentum Diffusivity" "m*m/s" +state real dkt3d ijk dyn_nmm 1 - h "DKT3D" "Thermal Diffusivity" "m*m/s" state real z0 ij dyn_nmm 1 - i01rh "Z0" "Roughness height" "m" state real hpbl2d ij dyn_nmm 1 - irh "HPBL2D" "HEIGHT OF PBL from new2010 GFS pbl" "m" state real heat2d ij dyn_nmm 1 - irh "HEAT2D" "" "" @@ -344,9 +362,59 @@ state real GD_CLOUD ikj misc 1 - r "GD_CLOUD" "CLOUD WA state real GD_CLOUD2 ikj misc 1 - r "GD_CLOUD2" "TEST for GD CLOUD" "kg kg-1" state real GD_CLOUD_A ikj misc 1 - r "GD_CLOUD_A" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" state real GD_CLOUD2_A ikj misc 1 - r "GD_CLOUD2_A" "taveragd cloud ice mix ratio in GD" "kg kg-1" -state real GD_CLOUD_B ikj misc 1 - r "GD_CLOUD_B" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2_B ikj misc 1 - r "GD_CLOUD2_B" "taveragd cloud ice mix ratio in GD" "kg kg-1" +state real QC_CU ikj misc 1 - r "QC_CU" "CLOUD WATER MIXING RATIO FROM A CU SCHEME" "kg kg-1" +state real QI_CU ikj misc 1 - r "QI_CU" "CLOUD ICE MIXUNG RATIO FROM A CU SCHEME" "kg kg-1" state real GD_CLDFR ikj misc 1 - r "GD_CLDFR" "GD CLOUD Fraction" " ? " +# upward and downward clearsky and total diagnostic fluxes for radiation (RRTMG) +state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWUPTC ij misc 1 - rhdu "ACSWUPTC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWDNT ij misc 1 - rhdu "ACSWDNT" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWDNTC ij misc 1 - rhdu "ACSWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWUPB ij misc 1 - rhdu "ACSWUPB" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACSWUPBC ij misc 1 - rhdu "ACSWUPBC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACSWDNB ij misc 1 - rhdu "ACSWDNB" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACSWDNBC ij misc 1 - rhdu "ACSWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWUPT ij misc 1 - rhdu "ACLWUPT" "ACCUMULATED UPWELLING LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWUPTC ij misc 1 - rhdu "ACLWUPTC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWDNT ij misc 1 - rhdu "ACLWDNT" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWDNTC ij misc 1 - rhdu "ACLWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWUPB ij misc 1 - rhdu "ACLWUPB" "ACCUMULATED UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWUPBC ij misc 1 - rhdu "ACLWUPBC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWDNB ij misc 1 - rhdu "ACLWDNB" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWDNBC ij misc 1 - rhdu "ACLWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +state real SWUPT ij misc 1 - rhdu "SWUPT" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real SWUPTC ij misc 1 - rhdu "SWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" +state real SWDNT ij misc 1 - rhdu "SWDNT" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real SWDNTC ij misc 1 - rhdu "SWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" +state real SWUPB ij misc 1 - rhdu "SWUPB" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWUPBC ij misc 1 - rhdu "SWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWDNB ij misc 1 - rhdu "SWDNB" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWDNBC ij misc 1 - rhdu "SWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real LWUPT ij misc 1 - rhdu "LWUPT" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP" "W m-2" +state real LWUPTC ij misc 1 - rhdu "LWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2" +state real LWDNT ij misc 1 - rhdu "LWDNT" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP" "W m-2" +state real LWDNTC ij misc 1 - rhdu "LWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2" +state real LWUPB ij misc 1 - rhdu "LWUPB" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" +state real LWUPBC ij misc 1 - rhdu "LWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2" +state real LWDNB ij misc 1 - rhdu "LWDNB" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" +state real LWDNBC ij misc 1 - rhdu "LWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "Wm-2" +state real SWVISDIR ij misc 1 Z r "SWVISDIR" "SWR VIS DIR component" "" +state real SWVISDIF ij misc 1 Z r "SWVISDIF" "SWR VIS DIF component" "" +state real SWNIRDIR ij misc 1 Z r "SWNIRDIR" "SWR NIR DIR component" "" +state real SWNIRDIF ij misc 1 Z r "SWNIRDIF" "SWR NIR DIF component" "" + +state real refl_10cm ikj dyn_nmm 1 - h "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" +state real REFD_MAX ij misc 1 - h "REFD_MAX" "MAX DERIVED RADAR REFL" "dbZ" +state real qnwfa2d ij misc 1 - rhdu "QNWFA2D" "Surface aerosol number conc emission" "kg-1 s-1" +state real re_cloud ikj misc 1 - r "re_cloud" "Effective radius, cloud drops" "m" +state real re_ice ikj misc 1 - r "re_ice" "Effective radius, cloud ice" "m" +state real re_snow ikj misc 1 - r "re_snow" "Effective radius, snow" "m" +state real dfi_re_cloud ikj misc 1 - - "DFI_RE_CLOUD" "DFI Effective radius cloud water" "m" +state real dfi_re_ice ikj misc 1 - - "DFI_RE_ICE" "DFI Effective radius cloud ice" "m" +state real dfi_re_snow ikj misc 1 - - "DFI_RE_SNOW" "DFI Effective radius snow" "m" +state integer has_reqc - misc 1 - r "has_reqc" "Flag for has effective radius of cloud water" "" +state integer has_reqi - misc 1 - r "has_reqi" "Flag for has effective radius of cloud ice" "" +state integer has_reqs - misc 1 - r "has_reqs" "Flag for has effective radius of snow" "" # # module_CLDWTR.F @@ -611,6 +679,7 @@ state real dfi_qnh ijkft dfi_moist 1 - r "Q # Other Scalars state real - ijkftb scalar 1 - - - state real qni ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNI" "Ice Number concentration" "# kg(-1)" +state real qt ikjftb scalar 1 - i0rhusdf=(bdy_interp:dt) "QT" "Total condensate mixing ratio" "kg kg-1" state real qns ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNS" "Snow Number concentration" "# kg(-1)" state real qnr ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNR" "Rain Number concentration" "# kg(-1)" state real qng ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNG" "Graupel Number concentration" "# kg(-1)" @@ -618,24 +687,33 @@ state real qnh ijkftb scalar 1 - i01rusdf=(bdy state real qnn ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNCCN" "CCN Number concentration" "# kg(-1)" state real qnc ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" +state real qnwfa ikjftb scalar 1 - i0rhusdf=(bdy_interp:dt) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" +state real qnifa ikjftb scalar 1 - i0rhusdf=(bdy_interp:dt) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" + +state real qvolg ikjftb scalar 1 - i0rhusdf=(bdy_interp:dt) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" state real - ijkftb dfi_scalar 1 - - - state real dfi_qndrop ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNDROP" "Droplet number mixing ratio" "# kg-1" + rusdf=(bdy_interp:dt) "DFI_QNDROP" "DFI Droplet number mixing ratio" "# kg-1" state real dfi_qni ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNICE" "Ice Number concentration" "# kg-1" + rusdf=(bdy_interp:dt) "DFI_QNICE" "DFI Ice Number concentration" "# kg-1" state real dfi_qt ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_CWM" "Total condensate mixing ratio" "kg kg-1" + rusdf=(bdy_interp:dt) "DFI_CWM" "DFI Total condensate mixing ratio" "kg kg-1" state real dfi_qns ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNSNOW" "Snow Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNSNOW" "DFI Snow Number concentration" "# kg(-1)" state real dfi_qnr ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNRAIN" "Rain Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNRAIN" "DFI Rain Number concentration" "# kg(-1)" state real dfi_qng ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "DFI Graupel Number concentration" "# kg(-1)" state real dfi_qnn ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNCC" "CNN Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNCC" "DFI CNN Number concentration" "# kg(-1)" state real dfi_qnc ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "Cloud Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "DFI Cloud Number concentration" "# kg(-1)" +state real dfi_qnwfa ikjftb dfi_scalar 1 - \ + rusdf=(bdy_interp:dt) "DFI_QNWFA" "DFI water-friendly aerosol number con" "# kg(-1)" +state real dfi_qnifa ikjftb dfi_scalar 1 - \ + rusdf=(bdy_interp:dt) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" + #----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -666,6 +744,7 @@ state real - ikjft chem 1 - - - state real SMOIS ilj - 1 Z rh "SMOIS" "SOIL MOISTURE" "" state real SMCREL ilj - 1 Z r "SMCREL" "RELATIVE SOIL MOISTURE" "" state real TSLB ilj - 1 Z r "TSLB" "SOIL TEMPERATURE" "" +state real lake_depth ij misc 1 - rd=(interp_mask_water_field:lu_index,iswater) "lake_depth" "lake depth" "m" # MYJ PBL variables @@ -711,6 +790,31 @@ state real RAINCV ij misc 1 - - "" # other misc variables (all cores) ################################################################# +# added WRF-Solar +state real swddir ij misc 1 - rhd "SWDDIR" "Shortwave surface downward direct irradiance" "W/m^2" "" +state real swddni ij misc 1 - rhd "SWDDNI" "Shortwave surface downward direct normal irradiance" "W/m^2" "" +state real swddif ij misc 1 - rhd "SWDDIF" "Shortwave surface downward diffuse irradiance" "W/m^2" "" +state real Gx ij misc 1 - rd "Gx" "" "" +state real Bx ij misc 1 - rd "Bx" "" "" +state real gg ij misc 1 - rd "gg" "" "" +state real bb ij misc 1 - rd "bb" "" "" +state real coszen_ref ij misc 1 - - "coszen_ref" "" "" +state real coszen ij misc 1 - - "coszen " "" "" +state real hrang ij misc 1 - - "hrang" "" "" +state real swdown_ref ij misc 1 - - "swdown_ref" "" "" +state real swddir_ref ij misc 1 - - "swddir_ref" "" "" +rconfig integer swint_opt namelist,physics 1 0 - "swint_opt" "interpolation option for sw radiation" "" +# add aerosol namelist +rconfig integer aer_type namelist,physics max_domains 1 irh "aer_type" "aerosol type: 1 is SF79 rural, 2 is SF79 urban" "" +rconfig integer aer_aod550_opt namelist,physics max_domains 1 irh "aer_aod550_opt" "input option for aerosol optical depth at 550 nm" "" +rconfig integer aer_angexp_opt namelist,physics max_domains 1 irh "aer_angexp_opt" "input option for aerosol Angstrom exponent" "" +rconfig integer aer_ssa_opt namelist,physics max_domains 1 irh "aer_ssa_opt" "input option for aerosol single-scattering albedo" "" +rconfig integer aer_asy_opt namelist,physics max_domains 1 irh "aer_asy_opt" "input option for aerosol asymmetry parameter" "" +rconfig real aer_aod550_val namelist,physics max_domains 0.12 irh "aer_aod550_val" "fixed value for aerosol optical depth at 550 nm. Valid when aer_aod550_opt=1" "" +rconfig real aer_angexp_val namelist,physics max_domains 1.3 irh "aer_angexp_val" "fixed value for aerosol Angstrom exponent. Valid when aer_angexp_opt=1" "" +rconfig real aer_ssa_val namelist,physics max_domains 0.85 irh "aer_ssa_val" "fixed value for aerosol single-scattering albedo. Valid when aer_ssa_opt=1" "" +rconfig real aer_asy_val namelist,physics max_domains 0.90 irh "aer_asy_val" "fixed value for aerosol asymmetry parameter. Valid when aer_asy_opt=1" "" + # added for surface_driver state real PSFC ij misc 1 - i1rh "PSFC" "SFC PRESSURE" state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" @@ -744,6 +848,8 @@ state real RMOL ij misc 1 - ir "RM state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" state real SST ij misc 1 - i014rh "SST" "SEA SURFACE TEMPERATURE" "K" +state real UOCE ij misc 1 - i014rh "UOCE" "SEA SURFACE ZONAL CURRENTS" "m s-1" +state real VOCE ij misc 1 - i014rh "VOCE" "SEA SURFACE MERIDIONAL CURRENTS" "m s-1" state real WEASD ij misc 1 - i01rh "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "kg m-2" state real ZNT ij misc 1 - ir "ZNT" "TIME-VARYING ROUGHNESS LENGTH" state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" @@ -810,7 +916,6 @@ state real SMFR3D ilj misc 1 Z rh "S state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" state real rc_mf ikj misc 1 - r "RC_MF" "RC IN THE GRID COMPUTED BY EDKF" "kg/kg" -# For Noah-MP rconfig integer dveg namelist,noah_mp 1 4 h "dveg" "dynamic vegetation (1 -> off ; 2 -> on)" "" rconfig integer opt_crs namelist,noah_mp 1 1 h "opt_crs" "canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis)" "" rconfig integer opt_btr namelist,noah_mp 1 1 h "opt_btr" "soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB)" "" @@ -909,6 +1014,10 @@ state real chucxy ij - 1 - i02rhd=(interp_mask_land state real chv2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv2" "leaf exchange coefficient" "m/s" state real chb2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb2" "under canopy exchange coefficient" "m/s" state real chstarxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chstar" "dummy exchange coefficient" "m/s" +state real SMOISEQ ilj - 1 Z r "SMOISEQ" "EQ. SOIL MOISTURE" "m3 m-3" +state real smcwtdxy ij - 1 - rh "smcwtd" "deep soil moisture " "m3 m-3" +state real rechxy ij - 1 - h "rech" "water table recharge" "mm" +state real deeprechxy ij - 1 - r "deeprech" "deep water table recharge" "mm" # added state for etampnew microphysics (needed for restarts) state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" @@ -928,6 +1037,7 @@ state real lu_state p misc - - - # state integer number_at_same_level - - - - - "number_at_same_level" "" "" +state real power ij misc 1 - irh "Power" "Power production" "W" # State for derived time quantities. state integer itimestep - - - - h "itimestep" "" "" @@ -1080,12 +1190,15 @@ rconfig integer mp_physics namelist,physics max_domains 0 rconfig real mommix namelist,physics max_domains 0.7 irh "MOMENTUM MIXING FOR SAS CONVECTION SCHEME" rconfig logical disheat namelist,physics max_domains .true. irh "nmm input 7" rconfig integer vortex_tracker namelist,physics max_domains 1 - "vortex_tracker" "Vortex Tracking Algorithm" "" +rconfig integer do_radar_ref namelist,physics 1 0 rh "compute radar reflectivity for a number of schemes" rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig integer windfarm_opt namelist,physics max_domains 0 rh "windfarm_opt" "" "" +rconfig integer windfarm_ij namelist,physics 1 0 rh "windfarm_ij" "" "" rconfig integer mfshconv namelist,physics max_domains 1 rh "mfshconv" "To activate mass flux scheme with qnse, 1=true; 0=false" "" rconfig integer sf_urban_physics namelist,physics max_domains 0 rh "sf_urban_physics" "" "" rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" @@ -1102,6 +1215,9 @@ rconfig integer surface_input_source namelist,physics 1 1 rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" rconfig integer num_urban_layers namelist,physics 1 400 irh "num_urban_layers" "" "" rconfig integer num_urban_hi namelist,physics 1 15 irh "num_urban_hi" "" "" +rconfig integer sf_surface_mosaic namelist,physics 1 0 rh "sf_surface_mosaic" "1= mosaic, 0=no mosaic method, add by danli" "" +rconfig integer mosaic_cat namelist,physics 1 3 rh "mosaic_cat" "works when sf_surface_mosaic=1; it is the number of mosaic tiles" "" +rconfig integer mosaic_cat_soil derived 1 12 rh "mosaic_cat_soil" "should be the number of soil layers times the mosaic_cat" "" rconfig integer mosaic_lu namelist,physics 1 0 irh "mosaic_lu" "" "" rconfig integer mosaic_soil namelist,physics 1 0 irh "mosaic_soil" "" "" rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" @@ -1115,7 +1231,7 @@ rconfig integer num_soil_cat namelist,physics 1 16 rconfig integer topo_wind namelist,physics max_domains 0 - "topo_wind" "2: Use Mass sfc drag scheme, 1: improve effects topography over surface wind, 0:not" "" rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" -rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig real seaice_threshold namelist,physics 1 100 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seiace" "Fractional sea-ice option" rconfig integer seaice_albedo_opt namelist,physics 1 0 - "seaice_albedo_opt" "Method for setting albedo over sea ice" rconfig real seaice_albedo_default namelist,physics 1 0.65 - "seaice_albedo_default" "Default value for sea-ice over albedo with seaice_albeo_opt=0" @@ -1138,6 +1254,8 @@ rconfig integer sas_shal_conv namelist,physics max_domains 0 rconfig real sas_mass_flux namelist,physics max_domains 9e9 - "sas_mass_flux" "mass flux limit (SAS scheme)" "" rconfig integer random_seed namelist,physics max_domains 0 irh "random_seed" "random number generator seed" + + # nmm variables rconfig integer idtad namelist,physics max_domains 2 irh "idtad" "fundamental timesteps between calls to NMM passive advection scheme" rconfig integer nsoil namelist,physics max_domains 4 irh "nsoil" "number of soil layers" @@ -1166,9 +1284,13 @@ rconfig integer no_src_types namelist,physics 1 1 rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" rconfig integer o3input namelist,physics 1 0 - "o3input" "ozone input option for radiation" "" rconfig integer aer_opt namelist,physics 1 0 - "aer_opt" "aerosol input option for radiation" "" -rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback of cumulus cloud to radiation" +rconfig integer ICLOUD_CU derived 1 0 - "ICLOUD_CU" "" "" rconfig integer num_snso_layers namelist,physics 1 7 irh "num_snso_layers" "" "" rconfig integer num_snow_layers namelist,physics 1 3 irh "num_snow_layers" "" "" +rconfig logical use_aero_icbc namelist,physics 1 .false. rh "use_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero" "logical flag" +rconfig integer sf_lake_physics namelist,physics max_domains 0 h "sf_lake_physics" "activate lake model 0=no, 1=yes" "" +# For Noah-MP # Dynamics # dynamics option (see package definitions, below) @@ -1176,9 +1298,9 @@ rconfig integer dyn_opt namelist,dynamics 1 - rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" # diff_opt 1=old diffusion, 2=new -rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +rconfig integer diff_opt namelist,dynamics max_domains -1 irh "diff_opt" "" "" # km_opt 1=old coefs, 2=tke, 3=Smagorinksy -rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer km_opt namelist,dynamics max_domains -1 irh "km_opt" "" "" rconfig integer damp_opt namelist,dynamics 1 1 irh "damp_opt" "" "" rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" @@ -1272,24 +1394,6 @@ rconfig integer mp_physics_dfi derived max_domains # Single dummy declaration to define a nodyn dyn option state integer nodyn_dummy - dyn_nodyn - - - "" "" "" -# Turbine drag (td) physics -# Turbine positions and characteristics for real-data cases are specified in a file -# whose name is given in the windturbines_spec variable. If the setting is "ideal", -# the td_ variables specify idealized wind farm geometries and turbine characteristics. -# If the setting is "none" then wind turbine drag physics is turned off. -rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name" -rconfig integer td_turbgridid namelist,physics 1 -1 - - "" "which grid id has turbines in it" -rconfig real td_hubheight namelist,physics 1 100. - - "" "hub height (m)" -rconfig real td_diameter namelist,physics 1 60. - - "" "turbine diameter (m)" -rconfig real td_stdthrcoef namelist,physics 1 .158 - - "" "standing thrust coefficient" -rconfig real td_cutinspeed namelist,physics 1 4. - - "" "cut-in speed (m/s)" -rconfig real td_cutoutspeed namelist,physics 1 27. - - "" "cut-out speed (m/s)" -rconfig real td_power namelist,physics 1 2. - - "" "turbine power (MW)" -rconfig real td_turbpercell namelist,physics 1 1. - - "" "number of turbines per cell" -rconfig integer td_ewfx namelist,physics 1 0 - - "" "extent of wind farm in x-cells" -rconfig integer td_ewfy namelist,physics 1 0 - - "" "extent of wind farm in y-cells" -rconfig integer td_pwfx namelist,physics 1 1 - - "" "southwest corner of wind farm in x-cells" -rconfig integer td_pwfy namelist,physics 1 1 - - "" "southwest corner of wind farm in y-cells" rconfig integer maxpatch namelist,physics 1 10 irh "maxpatch" "" "" #key package associated package associated 4d scalars @@ -1304,7 +1408,8 @@ package wsm5scheme mp_physics==4 - moist:qv,qc,q package etampnew mp_physics==5 - moist:qv,qc,qr,qs package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg -package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr;state:re_cloud,re_ice,re_snow +package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs @@ -1322,7 +1427,9 @@ package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr +package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow + package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng #package milbrandt3mom_dfi mp_physics_dfi==12 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_q_qzr,dfi_qzi,dfi_qzs,dfi_qzg,dfi_qzh @@ -1354,20 +1461,21 @@ package flgswscheme ra_sw_physics==7 - - package gfdlswscheme ra_sw_physics==99 - - package hwrfswscheme ra_sw_physics==98 -package sfclayscheme sf_sfclay_physics==1 - - +package sfclayscheme sf_sfclay_physics==91 - - package myjsfcscheme sf_sfclay_physics==2 - - package gfssfcscheme sf_sfclay_physics==3 - - package gfdlsfcscheme sf_sfclay_physics==88 - - package qnsesfcscheme sf_sfclay_physics==4 - - package pxsfcscheme sf_sfclay_physics==7 - - package temfsfcscheme sf_sfclay_physics==10 - - -package sfclayrevscheme sf_sfclay_physics==11 - - +package sfclayrevscheme sf_sfclay_physics==1 - - package idealscmsfcscheme sf_sfclay_physics==89 - - package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn package ruclsmscheme sf_surface_physics==3 - - -package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy +package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy + package clmscheme sf_surface_physics==5 - - package gfdlslab sf_surface_physics==88 - - @@ -1385,16 +1493,18 @@ package camuwpblscheme bl_pbl_physics==9 - - package mrfscheme bl_pbl_physics==99 - - package temfpblscheme bl_pbl_physics==10 - - package gbmpblscheme bl_pbl_physics==12 - - +package fitchscheme windfarm_opt==1 - - package kfetascheme cu_physics==1 - - package bmjscheme cu_physics==2 - - package gdscheme cu_physics==93 - - package sasscheme cu_physics==84 - state:hpbl2d,heat2d,evap2d +package meso_sas cu_physics==85 - - package osasscheme cu_physics==4 - state:randstate1,randstate2,randstate3,randstate4,random package g3scheme cu_physics==5 - - package gfscheme cu_physics==3 - - package camzmscheme cu_physics==7 - - -package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD_B,GD_CLOUD2_A,GD_CLOUD2_B,kbcon_deep,ktop_deep,k22_deep +package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep package tiedtkescheme cu_physics==6 - - package nsasscheme cu_physics==14 - - package kfscheme cu_physics==99 - - @@ -1509,6 +1619,8 @@ halo HALO_NMM_D dyn_nmm 24:pd halo HALO_NMM_E dyn_nmm 24:petdt halo HALO_NMM_F dyn_nmm 24:t,u,v halo HALO_NMM_F1 dyn_nmm 80:pdslo +halo HALO_NMM_MEMBRANE_RELAX dyn_nmm 8:relaxwork +halo HALO_NMM_MEMBRANE_MASK dyn_nmm 8:relaximask halo HALO_NMM_G dyn_nmm 24:u,v;24:z halo HALO_NMM_H dyn_nmm 24:w halo HALO_NMM_I dyn_nmm 48:q,q2,cwm diff --git a/wrfv2_fire/Registry/Registry.NMM_CHEM b/wrfv2_fire/Registry/Registry.NMM_CHEM deleted file mode 100755 index a032d6aa..00000000 --- a/wrfv2_fire/Registry/Registry.NMM_CHEM +++ /dev/null @@ -1,1580 +0,0 @@ -# Registry file NMM_CHEM -# -# At the present time this file is managed manually and edited by hand. -# -################################################################################ -# Dimension specifications -# -# This section of the Registry file is used to specify the dimensions -# that will be used to define arrays. Dim is the one-letter name of the -# dimension. How defined can either be "standard_domain", which means -# that the dimension (1) is one of the three spatial dimensions and (2) -# it will be set using the standard namelist mechanism and domain data -# structure dimension fields (e.g. sd31,ed31,sd32...). -# -# Order refers to which of the three sets of just-mentioned internal -# dimension variables the dimension is referred to by in the driver. -# That is, is it the first, second, or third dimension. The registry -# infers the mapping of its internal dimensions according to the -# combination of Order and Coord-axis that are specified in this table. -# Note that it is all right to more than one dimension name for, say, the -# x dimension. However, the Order and Coord-axis relationship must be -# consistent throughout. -# -# Note: these entries do not enforce storage order on a particular field. -# That is determined by the dimension strings for each field. But it does -# relate the dimspec to the internal data structures that the driver uses -# to maintain the three physical domain dimensions. -# -# "How defined" can also specify the name of a namelist variable from which -# the definition for the dimension will come; this is specified as -# "namelist=". The namelist variable must have been -# defined as an integer and with only one entry in the rconfig table. Or -# a constant can be specified. The coordinate axis for the dimension is -# either X, Y, Z, or C (for "not a spatial dimension"). The Dimname is -# the descriptive name of the dimension that will be included in the -# metadata in data sets. Note that the b, f, and t modifiers that appear -# as the last characters of dimension strings used # in state and # i1 -# registry definitions are not dimensions and do not need to be declared -# here. -# - -include registry.dimspec - -################################################################################ -################################################################################ -################################################################################ - -# Lines that start with the word 'state' form a table that is -# used by the script use_registry to generate module_state_descript.F -# and other files. Also see documentation in use_registry. -# -# It is reauired that LU_INDEX appears before any variable that is -# interpolated with a mask, as lu_index supplies that mask. -# -state real LU_INDEX ij misc 1 - irh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" -state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" -################################################################################ -################################################################################ - -################################ -## WPS-specific Variables -################################ - -state real p_gc ijg dyn_nmm 1 Z i1 "PRES" "pressure" "Pa" -state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" -state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" -state real input_soil_cat ij misc 1 - i12 "SOIL_CAT" "SOIL CAT DOMINANT TYPE" "" -state real tsk_gc ij dyn_nmm 1 - i1 "SKINTEMP" "skin temperature" "K" -state real XICE_gc ij misc 1 - i014r "SEAICE" "SEA ICE" "" -state real ght_gc ijg dyn_nmm 1 Z i1 "GHT" "geopotential height" "m" -state real rh_gc ijg dyn_nmm 1 Z i1 "RH" "relative humidity" "%" -state real v_gc ijg dyn_nmm 1 Z i1 "VV" "y-wind component" "m s-1" -state real u_gc ijg dyn_nmm 1 Z i1 "UU" "x-wind component" "m s-1" -state real t_gc ijg dyn_nmm 1 Z i1 "TT" "temperature" "K" -state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" -state real greenfrac_gc ijm dyn_nmm 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" -state real albedo12m_gc ijm dyn_nmm 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" -state real soilcbot_gc ijs misc 1 Z i1 "SOILCBOT" "description" "units" -state real soilctop_gc ijs misc 1 Z i1 "SOILCTOP" "description" "units" -state real tmn_gc ij dyn_nmm 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" -state real htv_gc ij dyn_nmm 1 - i1 "HGT_V" "wind point topography elevation" "m" -state real ht_gc ij dyn_nmm 1 - i1 "HGT_M" "mass point topography elevation" "m" -state real landusef_gc iju misc 1 Z i1 "LANDUSEF" "description" "units" -state real vlon_gc ij dyn_nmm 1 - i1 "XLONG_V" "longitude, positive east" "degrees" -state real vlat_gc ij dyn_nmm 1 - i1 "XLAT_V" "latitude, positive north" "degrees" -state real hlon_gc ij dyn_nmm 1 - i1 "XLONG_M" "longitude, positive east" "degrees" -state real hlat_gc ij dyn_nmm 1 - i1 "XLAT_M" "latitude, positive north" "degrees" - - -# Variables for nmm dynamics -# -# module_BC -# -# pdb is only 2d but registry doesn't support 2d bdy arrays right now... - -# The following arrays were added to avoid using _b and _bt arrays for nesting. -# This is gopal' doing: - -#for HWRF: zhang's doing: added a 'r' at end to store these variables in restart file -state real pdnest_b ij dyn_nmm 1 - r -state real pdnest_bt ij dyn_nmm 1 - r -state real tnest_b ijk dyn_nmm 1 - r -state real tnest_bt ijk dyn_nmm 1 - r -state real qnest_b ijk dyn_nmm 1 - r -state real qnest_bt ijk dyn_nmm 1 - r -state real unest_b ijk dyn_nmm 1 - r -state real unest_bt ijk dyn_nmm 1 - r -state real vnest_b ijk dyn_nmm 1 - r -state real vnest_bt ijk dyn_nmm 1 - r -state real q2nest_b ijk dyn_nmm 1 - r -state real q2nest_bt ijk dyn_nmm 1 - r -state real cwmnest_b ijk dyn_nmm 1 - r -state real cwmnest_bt ijk dyn_nmm 1 - r - -# -# For the moving nest. This is gopal's doing -# - -state real pdyn ij dyn_nmm 1 - r "PDYN" "DYNAMIC PRESSURE USED FOR TRACKING GRID MOTION" -state real mslp ij dyn_nmm 1 - r "MSLP" "MSLP USED TO DETERMINE STORM LOCATION" -state real sqws ij dyn_nmm 1 - r "SQWS" "SQUARE OF WIND SPEED AT LEVEL 10" -state integer xloc - dyn_nmm 2 - r "XLOC" "I-LOCATION OF MINIMUM DYNAMIC PRESSURE" -state integer yloc - dyn_nmm 2 - r "YLOC" "J-LOCATION OF MINIMUM DYNAMIC PRESSURE" -state logical mvnest - dyn_nmm 1 - rm "MVNEST" "LOGICAL SWITCH FOR NMM GRID MOTION" -#for HWRF: zhang's doing added to calculate radiation constant for moving nest for restart -state integer julyr_rst - dyn_nmm 1 - r "JULYR_RST" "JULYR for restart moving nest " -state integer julday_rst - dyn_nmm 1 - r "JULDAY_RST" "JULDAY for restart moving nest " -state real gmt_rst - dyn_nmm 1 - r "GMT_RST" "GMT for restart moving nest " -state integer NTIME0 - dyn_nmm 1 - r "NTIME0" "COUNT FOR PREVIOUS MOVING NEST" - -#for HWRF: -# flag for nest movement -state logical moved - misc 1 - r - -state real ducudt ijk misc 1 - rh "UMMIX" "U TENDENCY MOMENTUM MIXING IN SAS" -state real dvcudt ijk misc 1 - rh "VMMIX" "V TENDENCY MOMENTUM MIXING IN SAS" -state integer randstate1 ij dyn_nmm 1 - r "randstate1" "random number generator state word 1" -state integer randstate2 ij dyn_nmm 1 - r "randstate2" "random number generator state word 2" -state integer randstate3 ij dyn_nmm 1 - r "randstate3" "random number generator state word 3" -state integer randstate4 ij dyn_nmm 1 - r "randstate4" "random number generator state word 4" -state real random ij dyn_nmm 1 - rh "random" "random number in [0,1) used by SAS" - - -# Location of the SOUTH-WEST nested pointed in terms of parent grid - -state integer IIH ij dyn_nmm 1 - r -state integer JJH ij dyn_nmm 1 - r -state integer IIV ij dyn_nmm 1 - r -state integer JJV ij dyn_nmm 1 - r - -# Bi-linear weights - -state real HBWGT1 ij dyn_nmm 1 - r -state real HBWGT2 ij dyn_nmm 1 - r -state real HBWGT3 ij dyn_nmm 1 - r -state real HBWGT4 ij dyn_nmm 1 - r -state real VBWGT1 ij dyn_nmm 1 - r -state real VBWGT2 ij dyn_nmm 1 - r -state real VBWGT3 ij dyn_nmm 1 - r -state real VBWGT4 ij dyn_nmm 1 - r -#end of HWRF: - -# -state real HLON ij dyn_nmm 1 - d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) -state real HLAT ij dyn_nmm 1 - d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) -state real VLON ij dyn_nmm 1 - irh -state real VLAT ij dyn_nmm 1 - irh - -# -rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain" -rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain" -#for HWRF: -rconfig logical analysis namelist,time_control max_domains .false. irh "days" "analysis control for the nested domain" - -state real PSTD k dyn_nmm 1 Z r -state integer KZMAX - dyn_nmm - - r -state real Z3D ijk dyn_nmm 1 Z rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "Z3D" "HEIGHT ARRAY FIELD VALID FOR PARENT ONLY" -state real T3D ijk dyn_nmm 1 - rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "T3D" "TEMPERATURE ARRAY ON STANDARD PRESSURE LEVELS" -state real Q3D ijk dyn_nmm 1 - rd=(nmm_copy:IIH,JJH)f=(nmm_copy:IIH,JJH) "Q3D" "SP HUMIDITY ARRAY ON STANDARD PRESSURE LEVELS" -#end of HWRF: - -state real HRES_FIS ij dyn_nmm 1 - r "HRES_FIS" "HIGH RESOLUTION TERRAIN DATA FOR NESTED DOMAIN" -state real HRES_AVC ij dyn_nmm 1 - - "HRES_AVC" "TEMPORARY STORAGE OF HRES_FIS/9.81" -state real HRES_LND ij dyn_nmm 1 - - "HRES_LND" "TEMPORARY STORAGE OF HIGH-RES LND" - -# -# module_MASKS -# -state real hbm2 ij dyn_nmm 1 - irh "HBM2" "Height boundary mask; =0 outer 2 rows on H points" "" -state real hbm3 ij dyn_nmm 1 - irh "HBM3" "Height boundary mask; =0 outer 3 rows on H points" "" -state real vbm2 ij dyn_nmm 1 - irh "VBM2" "Velocity boundary mask; =0 outer 2 rows on V points" "" -state real vbm3 ij dyn_nmm 1 - irh "VBM3" "Velocity boundary mask; =0 outer 3 rows on V points" "" -state real sm ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SM" "Sea mask; =1 for sea, =0 for land" "" -state real sice ij dyn_nmm 1 - irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" -# -# module_VRBLS -# -state integer ntsd - dyn_nmm - - r "NTSD" "Number of timesteps done" "" -state integer nstart_hour - dyn_nmm - - r "NSTART_HOUR" "Forecast hour at start of integration" "" -state real pd ijb dyn_nmm 1 - i01rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_mass_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Z3D,HRES_FIS,SM,PDTOP,PT,PSTD,KZMAX)f=(nmm_bdymass_hinterp:pdnest_b,pdnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Z3D,HRES_FIS,SM,PDTOP,PT,PSTD,KZMAX) "PD" "Mass at I,J in the sigma domain" "Pa" -state real fis ij dyn_nmm 1 - i01rh "FIS" "Surface geopotential" "m2 s-2" -state real res ij dyn_nmm 1 - irh "RES" "Reciprocal of surface sigma" "" -state real t ijkb dyn_nmm 1 - i01rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_scalar_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,T3D,PD,PSTD,PDTOP,PT,ETA1,ETA2)f=(nmm_bdy_scalar:dt,tnest_b,tnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,T3d,PD,PSTD,PDTOP,PT,ETA1,ETA2) "T" "Sensible temperature" "K" -state real q ijkb dyn_nmm 1 - i01rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_scalar_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Q3D,PD,PSTD,PDTOP,PT,ETA1,ETA2)f=(nmm_bdy_scalar:dt,qnest_b,qnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,Q3d,PD,PSTD,PDTOP,PT,ETA1,ETA2) "Q" "Specific humidity" "kg kg-1" -state real u ijkb dyn_nmm 1 - i01rhu=(nmm_vfeedback:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)d=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)f=(nmm_bdy_vinterp:unest_b,unest_bt,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "U" "U component of wind" "m s-1" -state real v ijkb dyn_nmm 1 - i01rhu=(nmm_vfeedback:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)d=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4)f=(nmm_bdy_vinterp:vnest_b,vnest_bt,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "V" "V component of wind" "m s-1" -state real told ijk dyn_nmm 1 - r "TOLD" "T from previous timestep" "K" -state real uold ijk dyn_nmm 1 - r "UOLD" "U from previous timestep" "m s-1" -state real vold ijk dyn_nmm 1 - r "VOLD" "V from previous timestep" "m s-1" -# -# NMM DFI -# -state real hcoeff {ndfi} misc 1 - - "HCOEFF" "initialization weights" -state real hcoeff_tot - misc 1 - - "HCOEFF_TOT" "initialization weights" - -state real dfi_pd ij misc 1 - r "DFI_PD" "Mass at I,J in the sigma domain" "Pa" -state real dfi_pint ijk misc 1 Z r "DFI_PINT" "Model layer interface pressure" "Pa" -state real dfi_dwdt ijk misc 1 - r "DFI_DWDT" "dwdt and 1+(dwdt)/g" "m s-2" -state real dfi_t ijk misc 1 - r "DFI_T" "Sensible temperature" "K" -state real dfi_q ijk misc 1 - r "DFI_Q" "Specific humidity" "kg kg-1" -state real dfi_u ijk misc 1 - r "DFI_U" "U component of wind" "m s-1" -state real dfi_v ijk misc 1 - r "DFI_V" "V component of wind" "m s-1" -state real dfi_q2 ijk misc 1 - r "DFI_Q2" "2 * Turbulence kinetic energy" "m2 s-2" -state real dfi_cwm ijk misc 1 - r "DFI_CWM" "Total condensate" "kg kg-1" -state real dfi_rrw ijk misc 1 - r "DFI_RRW" "Tracer" "kg kg-1" -### remaining simply set aside, and restored to original values after filtering. -### If a two-hour window, do the 00h fields get placed when restarting at f01? -### -state real dfi_STC ilj misc 1 Z r "DFI_STC" "SOIL TEMPERATURE" "K" -state real dfi_SMC ilj misc 1 Z r "DFI_SMC" "SOIL MOISTURE" "m3 m-3" -state real dfi_SH2O ilj misc 1 Z r "DFI_SH2O" "UNFROZEN SOIL MOISTURE" "m3 m-3" - -state real dfi_SNOW ij misc 1 - r "dfi_SNOW" "SNOW WATER EQUIVALENT" "kg m-2" -state real dfi_SNOWH ij misc 1 - r "dfi_SNOWH" "PHYSICAL SNOW DEPTH" "m" -state real dfi_CANWAT ij misc 1 - r "dfi_CANWAT" "CANOPY WATER" "kg m-2" -state real dfi_NMM_TSK ij misc 1 - r "dfi_NMM_TSK" "saved SURFACE SKIN TEMPERATURE" -state real dfi_SNOWC ij misc 1 - r "dfi_SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" -# -# module_DYNAM -# -state real dx_nmm ij dyn_nmm 1 - irh "DX_NMM" "East-west distance H-to-V points" "m" -state real wpdar ij dyn_nmm 1 - ir -state real cpgfu ij dyn_nmm 1 - ir -state real curv ij dyn_nmm 1 - ir "CURV" "Curvature term= .5*DT*TAN(phi)/RadEarth" "s m-1" -state real fcp ij dyn_nmm 1 - ir -state real fdiv ij dyn_nmm 1 - ir -state real f ij dyn_nmm 1 - ir "F" "Coriolis * DT/2" "" -state real fad ij dyn_nmm 1 - ir -state real ddmpu ij dyn_nmm 1 - ir "DDMPU" "Divergence damping term for U" "m" -state real ddmpv ij dyn_nmm 1 - ir "DDMPV" "Divergence damping term for V" "m" -state real deta k dyn_nmm 1 - i01r "DETA" "Delta sigma in sigma domain" "" -state real rdeta k dyn_nmm 1 - ir "RDETA" "Reciprocal of DETA" "" -state real aeta k dyn_nmm 1 - i01r -state real f4q2 k dyn_nmm 1 - ir -state real etax k dyn_nmm 1 - i01r -state real dfl k dyn_nmm 1 Z i01r "DFL" "Standard atmosphere geopotential" "m2 s-2" -state real deta1 k dyn_nmm 1 - i01rh "DETA1" "Delta sigma in pressure domain" "" -state real aeta1 k dyn_nmm 1 - i01rh "AETA1" "Midlayer sigma value in pressure domain" "" -state real eta1 k dyn_nmm 1 Z i01rh "ETA1" "Interface sigma value in pressure domain" "" -state real deta2 k dyn_nmm 1 - i01rh "DETA2" "Delta sigma in sigma domain" "" -state real aeta2 k dyn_nmm 1 - i01rh "AETA2" "Midlayer sigma value in sigma domain" "" -state real eta2 k dyn_nmm 1 Z i01rh "ETA2" "Interface sigma value in sigma domain" "" -state real em q dyn_nmm 1 - ir -state real emt q dyn_nmm 1 - ir -#for HWRF: add to restart -state real adt ij dyn_nmm 1 - r "ADT" "Change of T due to advection" "K" -state real adu ij dyn_nmm 1 - r "ADU" "Change of U due to advection" "m s-1" -state real adv ij dyn_nmm 1 - r "ADV" "Change of V due to advection" "m s-1" -#end HWRF: -state real em_loc q dyn_nmm 1 - r -state real emt_loc q dyn_nmm 1 - r -state real dy_nmm - dyn_nmm - - ir "DY_NMM" "North-south distance H-to-V points" "m" -state real cpgfv - dyn_nmm - - ir -state real en - dyn_nmm - - ir -state real ent - dyn_nmm - - ir -state real f4d - dyn_nmm - - ir -state real f4q - dyn_nmm - - ir -state real ef4t - dyn_nmm - - ir -state logical upstrm - dyn_nmm - - - "UPSTRM" ".TRUE. => In upstream advec region of grid" "" -#end HWRF: -state real dlmd - dyn_nmm - - irh "DLMD" "East-west angular distance H-to-V points" "degrees" -state real dphd - dyn_nmm - - irh "DPHD" "North-south angular distance H-to-V points" "degrees" -state real pdtop - dyn_nmm - - i01rh "PDTOP" "Mass at I,J in pressure domain" "Pa" -state real pt - dyn_nmm - - i01rh "PT" "Pressure at top of domain" "Pa" -# -# module_CONTIN -# -#for HWRF: add to restart -state real pdsl ij dyn_nmm 1 - r "PDSL" "Sigma-domain pressure at sigma=1" "Pa" -state real pdslo ij dyn_nmm 1 - r "PDSLO" "PDSL from previous timestep" "Pa" -#end HWRF: -state real psdt ij dyn_nmm 1 - r "PSDT" "Surface pressure tendency" "Pa s-1" -state real div ijk dyn_nmm 1 - r "DIV" "Divergence" "Pa s-1" -state real def3d ijk dyn_nmm 1 - r "DEF3D" "Deformation term from horizontal diffusion" "" -#for HWRF: add to restart -state real few ijk dyn_nmm 1 - r "FEW" "Integrated east-west mass flux" "Pa m2 s-1" -state real fne ijk dyn_nmm 1 - r "FNE" "Integrated northeast-southwest mass flux" "Pa m2 s-1" -state real fns ijk dyn_nmm 1 - r "FNS" "Integrated north-south mass flux" "Pa m2 s-1" -state real fse ijk dyn_nmm 1 - r "FSE" "Integrated southeast-northwest mass flux" "Pa m2 s-1" -#end HWRF: -state real omgalf ijk dyn_nmm 1 - r "OMGALF" "Omega-alpha" "K" -#for HWRF: add to restart -state real petdt ijk dyn_nmm 1 - r "PETDT" "Vertical mass flux" "Pa s-1" -#end HWRF: -state real rtop ijk dyn_nmm 1 - r "RTOP" "Rd * Tv / P" "m3 kg-1" -# -# module_PVRBLS -# -state real pblh ij dyn_nmm 1 - rh "PBLH" "PBL Height" "m" -state integer lpbl ij dyn_nmm 1 - ir "LPBL" "Model layer of PBL top" "" -state real mixht ij dyn_nmm 1 - rh "MIXHT" "MXL HEIGHT" "m" -state real ustar ij dyn_nmm 1 - irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "USTAR" "Friction velocity" "m s-1" -state real z0 ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "Z0" "Roughness height" "m" -state real hpbl2d ij dyn_nmm 1 - irh "HPBL2D" "HEIGHT OF PBL from new2010 GFS pbl" - "m" -state real heat2d ij dyn_nmm 1 - irh "HEAT2D" "" "" -state real evap2d ij dyn_nmm 1 - irh "EVAP2D" "" "" -state real z0base ij dyn_nmm 1 - ir "Z0BASE" "Base roughness height" "m" -state real ths ij dyn_nmm 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "THS" "Surface potential temperature" "K" -state real mavail ij dyn_nmm 1 - i -state real qsh ij dyn_nmm 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "QS" "Surface specific humidity" "kg kg-1" -state real twbs ij dyn_nmm 1 - irh "TWBS" "Instantaneous sensible heat flux" "W m-2" -state real qwbs ij dyn_nmm 1 - irh "QWBS" "Instantaneous latent heat flux" "W m-2" -state real taux ij dyn_nmm 1 - irh "TAUX" "Instantaneous stress along X direction in KG/M/S^2" -state real tauy ij dyn_nmm 1 - irh "TAUY" "Instantaneous stress along Y direction in KG/M/S^2" -state real prec ij dyn_nmm 1 - rh "PREC" "Precipitation in physics timestep" "m" -state real aprec ij dyn_nmm 1 - rh -state real acprec ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ACPREC" "Accumulated total precipitation" "m" -state real cuprec ij dyn_nmm 1 - rh "CUPREC" "Accumulated convective precipitation" "m" -state real lspa ij dyn_nmm 1 - h "LSPA" "Land Surface Precipitation Accumulation" "kg m-2" -state real ddata ij dyn_nmm 1 - - "DDATA" "Observed precip to each physics timestep" "kg m-2" -state real accliq ij dyn_nmm 1 - r -state real sno ij dyn_nmm 1 - irh "SNO" "Liquid water eqiv of snow on ground" "kg m-2" -state real si ij dyn_nmm 1 - irh "SI" "Depth of snow on ground" "mm" -state real cldefi ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CLDEFI" "Convective cloud efficiency" "" -state real deep ij dyn_nmm 1 - r "DEEP" "Deep convection =>.TRUE." "" -state real rf ij dyn_nmm 1 - r -state real th10 ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "TH10" "10-m potential temperature from MYJ" "K" -state real q10 ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "Q10" "10-m specific humidity from MYJ" "kg kg-1" -state real pshltr ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "PSHLTR" "2-m pressure from MYJ" "Pa" -state real tshltr ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "TSHLTR" "2-m potential temperature from MYJ" "K" -state real qshltr ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "QSHLTR" "2-m specific humidity from MYJ" "kg kg-1" -state real q2 ijkb dyn_nmm 1 - irhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)f=(nmm_bdy_hinterp:q2nest_b,q2nest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "Q2" "2 * Turbulence kinetic energy" "m2 s-2" -state real t_adj ijk dyn_nmm 1 - rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "T_ADJ" "T change due to precip in phys step" "K" -state real t_old ijk dyn_nmm 1 - r "T_OLD" "T before last call to precip" "K" -state real zero_3d ijk dyn_nmm 1 - r -state real W0AVG ikj dyn_nmm 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" -state real AKHS_OUT ij dyn_nmm 1 - rh "AKHS_OUT" "Output sfc exch coeff for heat" "m2 s-1" -state real AKMS_OUT ij dyn_nmm 1 - rh "AKMS_OUT" "Output sfc exch coeff for momentum" "m2 s-1" -# -# module_PHYS -# -state real albase ij dyn_nmm 1 - i01rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ALBASE" "Base albedo" "" -state real albedo ij dyn_nmm 1 - irh "ALBEDO" "Dynamic albedo" "" -state real cnvbot ij dyn_nmm 1 - irh "CNVBOT" "Lowest convec cloud bottom lyr between outputs" "" -state real cnvtop ij dyn_nmm 1 - irh "CNVTOP" "Highest convec cloud top lyr between outputs" "" -state real czen ij dyn_nmm 1 - irh "CZEN" "Cosine of solar zenith angle" "" -state real czmean ij dyn_nmm 1 - irh "CZMEAN" "Mean CZEN between SW radiation calls" "" -state real embck ij dyn_nmm 1 - ir "EMBCK" "Background radiative emissivity" "" -state real epsr ij dyn_nmm 1 - irh "EPSR" "Radiative emissivity" "" -state real gffc ij dyn_nmm 1 - ir -state real glat ij dyn_nmm 1 - i01rh "GLAT" "Geographic latitude, radians" "" -state real glon ij dyn_nmm 1 - i01rh "GLON" "Geographic longitude, radians" "" -state real NMM_TSK ij dyn_nmm 1 - i01rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "TSK" "Skin temperature" "K" -state real hdac ij dyn_nmm 1 - ir "HDAC" "Composite diffusion coeff for mass points" "s m-1" -state real hdacv ij dyn_nmm 1 - ir "HDACV" "Composite diffusion coeff for velocity points" "s m-1" -state real mxsnal ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "MXSNAL" "Maximum deep snow albedo" "" -state real radin ij dyn_nmm 1 - r -state real radot ij dyn_nmm 1 - rh "RADOT" "Radiative emission from surface" "W m-2" -state real sigt4 ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SIGT4" "Stefan-Boltzmann * T**4" "W m-2" -state real tg ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "TGROUND" "Deep ground soil temperature" "K" -state real dfrlg k dyn_nmm 1 Z i01r "DFRLG" "Std atmosphere height of model layer interfaces" "m" -state integer lvl ij dyn_nmm 1 - ir -state integer k22_deep ij misc 1 - - "K22_DEEP" "K22 LEVEL FROM DEEPCONVECTION (G3 only)" "" -state integer kbcon_deep ij misc 1 - - "KBCON_DEEP" "KBCON LEVEL FROM DEEP CONVECTION (G3 only)" "" -state integer ktop_deep ij misc 1 - - "KTOP_DEEP" "KTOP LEVEL FROM DEEP CONVECTION (G3 only)" "" -state real RAINCV_A ij misc 1 - r "RAINCV_A" "taveragd TIME-STEP CUMULUS PRECIPITATION" "mm" -state real RAINCV_B ij misc 1 - r "RAINCV_B" "taveragd TIME-STEP CUMULUS PRECIPITATION" "mm" -state real GD_CLOUD ikj misc 1 - r "GD_CLOUD" "CLOUD WATER/ICE MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2 ikj misc 1 - r "GD_CLOUD2" "TEST for GD CLOUD" "kg kg-1" -state real GD_CLOUD_A ikj misc 1 - r "GD_CLOUD_A" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2_A ikj misc 1 - r "GD_CLOUD2_A" "taveragd cloud ice mix ratio in GD" "kg kg-1" -state real GD_CLOUD_B ikj misc 1 - r "GD_CLOUD_B" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2_B ikj misc 1 - r "GD_CLOUD2_B" "taveragd cloud ice mix ratio in GD" "kg kg-1" -state real GD_CLDFR ikj misc 1 - r "GD_CLDFR" "GD CLOUD Fraction" " ? " - -# -# module_CLDWTR.F -# -state real cwm ijkb dyn_nmm 1 - rhu=(nmm_feedback:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)d=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4)f=(nmm_bdy_hinterp:cwmnest_b,cwmnest_bt,IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CWM" "Total condensate" "kg kg-1" -state real rrw ijkb dyn_nmm 1 - rh "RRW" "Tracer" "kg kg-1" -state real f_ice ikj dyn_nmm 1 - rhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_ICE" "Frozen fraction of CWM" "" -state real f_rain ikj dyn_nmm 1 - rhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_RAIN" "Rain fraction of liquid part of CWM" "" -state real f_rimef ikj dyn_nmm 1 - rhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "F_RIMEF" "Rime factor" "" -state real cldfra ijk dyn_nmm 1 - rh "CLDFRA" "Cloud fraction" "" -state real sr ij dyn_nmm 1 - irh "SR" "Timestep mass ratio of snow:precip" "" -state real cfrach ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CFRACH" "High cloud fraction" "" -state real cfracl ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CFRACL" "Low cloud fraction" "" -state real cfracm ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CFRACM" "Middle cloud fraction" "" -state logical micro_start - dyn_nmm - - - -# -# module_SOIL.F -# -state integer islope ij dyn_nmm 1 - i01rhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ISLOPE" -state real dzsoil k dyn_nmm 1 - irh "DZSOIL" "Thickness of soil layers" "m" -state real rtdpth k dyn_nmm 1 - i01r -state real sldpth k dyn_nmm 1 - i01rh "SLDPTH" "Depths of centers of soil layers" "m" -state real cmc ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CMC" "Canopy moisture" "m" -state real grnflx ij dyn_nmm 1 - irh "GRNFLX" "Deep soil heat flux" "W m-2" -state real pctsno ij dyn_nmm 1 - irh -state real soiltb ij dyn_nmm 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SOILTB" "Deep ground soil temperature" "K" -state real vegfrc ij dyn_nmm 1 - i014rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "VEGFRC" "Vegetation fraction" "" -state real shdmin ij dyn_nmm 1 - - -state real shdmax ij dyn_nmm 1 - - -state real sh2o ilj dyn_nmm 1 Z irhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SH2O" "Unfrozen soil moisture volume fraction" "" -state real smc ilj dyn_nmm 1 Z irhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SMC" "Soil moisture volume fraction" "" -state real stc ilj dyn_nmm 1 Z irhd=(interp_hnear_ikj_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "STC" "Soil temperature" "K" -# -# module_GWD.F -# -state real hstdv ij dyn_nmm 1 - i01rh "HSTDV" "Standard deviation of height" "m" -state real hcnvx ij dyn_nmm 1 - i01rh "HCNVX" "Normalized 4th moment of orographic convexity" "" -state real hasyw ij dyn_nmm 1 - i01rh "HASYW" "Orographic asymmetry in W-E plane" "" -state real hasys ij dyn_nmm 1 - i01rh "HASYS" "Orographic asymmetry in S-N plane" "" -state real hasysw ij dyn_nmm 1 - i01rh "HASYSW" "Orographic asymmetry in SW-NE plane" "" -state real hasynw ij dyn_nmm 1 - i01rh "HASYNW" "Orographic asymmetry in NW-SE plane" "" -state real hlenw ij dyn_nmm 1 - i01rh "HLENW" "Orographic length scale in W-E plane" "" -state real hlens ij dyn_nmm 1 - i01rh "HLENS" "Orographic length scale in S-N plane" "" -state real hlensw ij dyn_nmm 1 - i01rh "HLENSW" "Orographic length scale in SW-NE plane" "" -state real hlennw ij dyn_nmm 1 - i01rh "HLENNW" "Orographic length scale in NW-SE plane" "" -state real hangl ij dyn_nmm 1 - i01rh "HANGL" "Angle of the mountain range w/r/t east" "deg" -state real hanis ij dyn_nmm 1 - i01rh "HANIS" "Anisotropy/aspect ratio of orography" "" -state real hslop ij dyn_nmm 1 - i01rh "HSLOP" "Slope of orography" "" -state real hzmax ij dyn_nmm 1 - i01rh "HZMAX" "Maximum height above mean orography" "m" -state real crot ij dyn_nmm 1 - - "CROT" "Cosine of angle between model and earth coordinates" "" -state real srot ij dyn_nmm 1 - - "SROT" "Sine of angle between model and earth coordinates" "" -state real UGWDsfc ij dyn_nmm 1 - h "UGWDsfc" "Surface zonal wind stress due to gravity wave drag" "N m-2" -state real VGWDsfc ij dyn_nmm 1 - h "VGWDsfc" "Surface meridional wind stress due to gravity wave drag" "N m-2" -# -# Additional for topo_wind -# -state real ctopo ij misc 1 - rdu "ctopo" "Correction for topography" "" -state real ctopo2 ij misc 1 - rdu "ctopo2" "Correction for topography 2" "" -# -# module_NHYDRO.F -# -state logical hydro - dyn_nmm - - - "HYDRO" ".FALSE. => nonhydrostatic" "" -state real dwdtmn ij dyn_nmm 1 - - "DWDTMN" "Minimum value for DWDT" "m s-2" -state real dwdtmx ij dyn_nmm 1 - - "DWDTMX" "Maximum value for DWDT" "m s-2" -state real baro ij dyn_nmm 1 - - "BARO" "external mode vvel" "m s-1" -state real dwdt ijk dyn_nmm 1 - rd=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" -state real pdwdt ijk dyn_nmm 1 - r -state real pint ijk dyn_nmm 1 Z irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "PINT" "Model layer interface pressure" "Pa" -state real w ijk dyn_nmm 1 Z r "W" "Vertical velocity" "m s-1" -state real w_tot ijk dyn_nmm 1 Z h "W" "Vertical velocity" "m s-1" -state real z ijk dyn_nmm 1 Z - "Z" "Distance from ground" "m" -# -# module_ACCUM.F -# -state real acfrcv ij dyn_nmm 1 - rh "ACFRCV" "Accum convective cloud fraction" "" -state real acfrst ij dyn_nmm 1 - rh "ACFRST" "Accum stratiform cloud fraction" "" -state real ssroff ij dyn_nmm 1 - rh "SSROFF" "Surface runoff" "mm" -state real bgroff ij dyn_nmm 1 - rh "BGROFF" "Subsurface runoff" "mm" -state real rlwin ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RLWIN" "Downward longwave at surface" "W m-2" -state real rlwout ij dyn_nmm 1 - - -state real rlwtoa ij dyn_nmm 1 - rh "RLWTOA" "Outgoing LW flux at top of atmos" "W m-2" -state real alwin ij dyn_nmm 1 - rh "ALWIN" "Accum LW down at surface" "W m-2" -state real alwout ij dyn_nmm 1 - rh "ALWOUT" "Accum RADOT (see above)" "W m-2" -state real alwtoa ij dyn_nmm 1 - rh "ALWTOA" "Accum RLWTOA" "W m-2" -state real rswin ij dyn_nmm 1 - rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RSWIN" "Downward shortwave at surface" "W m-2" -state real rswinc ij dyn_nmm 1 - rh "RSWINC" "Clear-sky equivalent of RSWIN" "W m-2" -state real rswout ij dyn_nmm 1 - rh "RSWOUT" "Upward shortwave at surface" "W m-2" -#for HWRF: add to restart -state real rswtoa ij dyn_nmm 1 - r "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" -#end HWRF -state real aswin ij dyn_nmm 1 - rh "ASWIN" "Accum SW down at surface" "W m-2" -state real aswout ij dyn_nmm 1 - rh "ASWOUT" "Accum RSWOUT" "W m-2" -state real aswtoa ij dyn_nmm 1 - rh "ASWTOA" "Accum RSWTOA" "W m-2" -state real sfcshx ij dyn_nmm 1 - rh "SFCSHX" "Accum sfc sensible heat flux" "W m-2" -state real sfclhx ij dyn_nmm 1 - rh "SFCLHX" "Accum sfc latent heat flux" "W m-2" -state real subshx ij dyn_nmm 1 - rh "SUBSHX" "Accum deep soil heat flux" "W m-2" -state real snopcx ij dyn_nmm 1 - rh "SNOPCX" "Snow phase change heat flux" "W m-2" -state real sfcuvx ij dyn_nmm 1 - rh -state real potevp ij dyn_nmm 1 - rh "POTEVP" "Accum potential evaporation" "m" -state real potflx ij dyn_nmm 1 - rh "POTFLX" "Energy equivalent of POTEVP" "W m-2" -state real tlmin ij dyn_nmm 1 - rh "TLMIN" "" -state real tlmax ij dyn_nmm 1 - rh "TLMAX" "" -state real t02_min ij dyn_nmm 1 - rh "T02_MIN" "Hourly Min Shelter Temperature" "K" -state real t02_max ij dyn_nmm 1 - rh "T02_MAX" "Hourly Max Shelter Temperature" "K" -state real rh02_min ij dyn_nmm 1 - rh "RH02_MIN" "Hourly Min Relative Humidity" "" -state real rh02_max ij dyn_nmm 1 - rh "RH02_MAX" "Hourly Max Relative Humidity" "" -state real rlwtt ijk dyn_nmm 1 - rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RLWTT" "Longwave temperature tendency" "K s-1" -state real rswtt ijk dyn_nmm 1 - rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RSWTT" "Shortwave temperature tendency" "K s-1" -#for HWRF: add to restart -state real tcucn ijk dyn_nmm 1 - r "TCUCN" "Accum convec temperature tendency" "K s-1" -state real train ijk dyn_nmm 1 - r "TRAIN" "Accum stratiform temp tendency" "K s-1" -#end HWRF -state integer ncfrcv ij dyn_nmm 1 - irh "NCFRCV" "# times convec cloud >0 between rad calls" "" -state integer ncfrst ij dyn_nmm 1 - irh "NCFRST" "# times stratiform cloud >0 between rad calls" "" -state integer nphs0 - dyn_nmm - - rh -state integer ncnvc0 - dyn_nmm - - rh -state integer nprec - dyn_nmm - - irh "NPREC" "# timesteps between resetting precip bucket" "" -state integer nclod - dyn_nmm - - irh "NCLOD" "# timesteps between resetting cloud frac accum" "" -state integer nheat - dyn_nmm - - irh "NHEAT" "# timesteps between resetting latent heat accum" "" -state integer nrdlw - dyn_nmm - - irh "NRDLW" "# timesteps between resetting longwave accums" "" -state integer nrdsw - dyn_nmm - - irh "NRDSW" "# timesteps between resetting shortwave accums" "" -state integer nsrfc - dyn_nmm - - irh "NSRFC" "# timesteps between resetting sfcflux accums" "" -state real avrain - dyn_nmm - - irh "AVRAIN" "# of times gridscale precip called in NHEAT steps" "" -state real avcnvc - dyn_nmm - - irh "AVCNVC" "# of times convective precip called in NHEAT steps" "" -state real aratim - dyn_nmm - - ir -state real acutim - dyn_nmm - - irh -state real ardlw - dyn_nmm - - irh "ARDLW" "# of times LW fluxes summed before resetting" "" -state real ardsw - dyn_nmm - - irh "ARDSW" "# of times SW fluxes summed before resetting" "" -state real asrfc - dyn_nmm - - irh "ASRFC" "# of times sfc fluxes summed before resetting" "" -state real aphtim - dyn_nmm - - irh -# -# module_INDX.F -# -state integer ihe j dyn_nmm 1 - - "IHE" "0 or +1 to obtain I index of V point east of H point" "" -state integer ihw j dyn_nmm 1 - - "IHW" "0 or -1 to obtain I index of V point west of H point" "" -state integer ive j dyn_nmm 1 - - "IVE" "0 or +1 to obtain I index of H point east of V point" "" -state integer ivw j dyn_nmm 1 - - "IVW" "0 or -1 to obtain I index of H point west of V point" "" -state integer irad i dyn_nmm 1 - - -#definitions for NMM east-west orientation on E grid -state integer iheg q dyn_nmm 1 - - -state integer ihwg q dyn_nmm 1 - - -state integer iveg q dyn_nmm 1 - - -state integer ivwg q dyn_nmm 1 - - -state integer iradg r dyn_nmm 1 - - -state integer n_iup_h j dyn_nmm 1 - - "N_IUP_H" "# mass points needed in each row for upstream advection" "" -state integer n_iup_v j dyn_nmm 1 - - "N_IUP_V" "# velocity points needed in each row for upstream advection" "" -state integer n_iup_adh j dyn_nmm 1 - - "N_IUP_ADH" "# mass points in each row of upstream advection" "" -state integer n_iup_adv j dyn_nmm 1 - - "N_IUP_ADV" "# velocity points in each row of upstream advection" "" -state integer iup_h ij dyn_nmm 1 - - -state integer iup_v ij dyn_nmm 1 - - -state integer iup_adh ij dyn_nmm 1 - - -state integer iup_adv ij dyn_nmm 1 - - -state integer imicrogram - misc - - r "imicrogram" "flag 0/1 0=mixratio, 1=mcrograms/m3" "" - -# -# table entries are of the form -#
-# -# Mask for moving nest interpolations -state integer imask_nostag ij misc - -state integer imask_xstag ij misc X -state integer imask_ystag ij misc Y -state integer imask_xystag ij misc XY -#--------------------------------------------------------------------------------------------------------------------------------- -# SI - start variables from netCDF format from Standard Initialization, most eventually for use in LSM schemes -#--------------------------------------------------------------------------------------------------------------------------------- - -state real sm000007 ij misc 1 - i1 "SM000007" "LAYER SOIL MOISTURE" "m3 m-3" -state real sm007028 ij misc 1 - i1 "SM007028" "LAYER SOIL MOISTURE" "m3 m-3" -state real sm028100 ij misc 1 - i1 "SM028100" "LAYER SOIL MOISTURE" "m3 m-3" -state real sm100255 ij misc 1 - i1 "SM100255" "LAYER SOIL MOISTURE" "m3 m-3" -state real st000007 ij misc 1 - i1 "ST000007" "LAYER SOIL TEMPERATURE" "K" -state real st007028 ij misc 1 - i1 "ST007028" "LAYER SOIL TEMPERATURE" "K" -state real st028100 ij misc 1 - i1 "ST028100" "LAYER SOIL TEMPERATURE" "K" -state real st100255 ij misc 1 - i1 "ST100255" "LAYER SOIL TEMPERATURE" "K" -state real sm000010 ij misc 1 - i1 "SM000010" "description" "units" -state real sm010040 ij misc 1 - i1 "SM010040 " "description" "units" -state real sm040100 ij misc 1 - i1 "SM040100 " "description" "units" -state real sm100200 ij misc 1 - i1 "SM100200 " "description" "units" -state real sm010200 ij misc 1 - i1 "SM010200" "description" "units" -state real soilm000 ij misc 1 - i1 "SOILM000" "description" "units" -state real soilm005 ij misc 1 - i1 "SOILM005" "description" "units" -state real soilm020 ij misc 1 - i1 "SOILM020" "description" "units" -state real soilm040 ij misc 1 - i1 "SOILM040" "description" "units" -state real soilm160 ij misc 1 - i1 "SOILM160" "description" "units" -state real soilm300 ij misc 1 - i1 "SOILM300" "description" "units" -state real sw000010 ij misc 1 - i1 "SW000010" "description" "units" -state real sw010040 ij misc 1 - i1 "SW010040" "description" "units" -state real sw040100 ij misc 1 - i1 "SW040100" "description" "units" -state real sw100200 ij misc 1 - i1 "SW100200" "description" "units" -state real sw010200 ij misc 1 - i1 "SW010200" "description" "units" -state real soilw000 ij misc 1 - i1 "SOILW000" "description" "units" -state real soilw005 ij misc 1 - i1 "SOILW005" "description" "units" -state real soilw020 ij misc 1 - i1 "SOILW020" "description" "units" -state real soilw040 ij misc 1 - i1 "SOILW040" "description" "units" -state real soilw160 ij misc 1 - i1 "SOILW160" "description" "units" -state real soilw300 ij misc 1 - i1 "SOILW300" "description" "units" -state real st000010 ij misc 1 - i1 "ST000010" "description" "units" -state real st010040 ij misc 1 - i1 "ST010040" "description" "units" -state real st040100 ij misc 1 - i1 "ST040100" "description" "units" -state real st100200 ij misc 1 - i1 "ST100200" "description" "units" -state real st010200 ij misc 1 - i1 "ST010200" "description" "units" -state real soilt000 ij misc 1 - i1 "SOILT000" "description" "units" -state real soilt005 ij misc 1 - i1 "SOILT005" "description" "units" -state real soilt020 ij misc 1 - i1 "SOILT020" "description" "units" -state real soilt040 ij misc 1 - i1 "SOILT040" "description" "units" -state real soilt160 ij misc 1 - i1 "SOILT160" "description" "units" -state real soilt300 ij misc 1 - i1 "SOILT300" "description" "units" -state real landmask ij misc 1 - i01rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "LANDMASK" "description" "units" -state real topostdv ij misc 1 - i1 "TOPOSTDV" "description" "units" -state real toposlpx ij misc 1 - i1 "TOPOSLPX" "description" "units" -state real toposlpy ij misc 1 - i1 "TOPOSLPY" "description" "units" -state real greenmax ij misc 1 - i1 "GREENMAX" "description" "units" -state real greenmin ij misc 1 - i1 "GREENMIN" "description" "units" -state real albedomx ij misc 1 - i1 "ALBEDOMX" "description" "units" -state real slopecat ij misc 1 - i1 "SLOPECAT" "description" "units" -state real toposoil ij misc 1 - i1d=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4 "SOILHGT" "description" "units" -state real landusef iuj misc 1 Z - "LANDUSEF" "description" "units" -state real soilctop isj misc 1 Z - "SOILCTOP" "description" "units" -state real soilcbot isj misc 1 Z - "SOILCBOT" "description" "units" - -#------------------------------------------------------------------------------------------------------------------------------- -# SI - end variables from netCDF format from Standard Initialization -#------------------------------------------------------------------------------------------------------------------------------- - -# Time series variables -state real ts_hour ?! misc - - - "TS_HOUR" "Model integration time, hours" -state real ts_u ?! misc - - - "TS_U" "Surface wind U-component, earth-relative" -state real ts_v ?! misc - - - "TS_V" "Surface wind V-component, earth-relative" -state real ts_q ?! misc - - - "TS_Q" "Surface mixing ratio" -state real ts_t ?! misc - - - "TS_T" "Surface temperature" -state real ts_psfc ?! misc - - - "TS_PSFC" "Surface pressure" -state real ts_tsk ?! misc - - - "TS_TSK" "Skin temperature" -state real ts_tslb ?! misc - - - "TS_TSLB" "Soil temperature" -state real ts_clw ?! misc - - - "TS_CLW" "Column integrated cloud water" - -#----------------------------------------------------------------------------------------------------------------------------------------------------------------- - - -# Moist Scalars - both height and mass coordinate models -# -# The first line ensures that there will be identifiers named moist and -# moist_tend even if there are not any moist scalars (so the essentially -# dry code will will still link properly) -# -state real - ijkft moist 1 - - - -state real qv ijkft moist 1 - rh "QVAPOR" "Water vapor mixing ratio" "kg kg-1" -state real qc ijkft moist 1 - rh "QCLOUD" "Cloud water mixing ratio" "kg kg-1" -state real qr ijkft moist 1 - rh "QRAIN" "Rain water mixing ratio" "kg kg-1" -state real qi ijkft moist 1 - rh "QICE" "Ice mixing ratio" "kg kg-1" -state real qs ijkft moist 1 - rh "QSNOW" "Snow mixing ratio" "kg kg-1" -state real qg ijkft moist 1 - rh "QGRAUP" "Graupel mixing ratio" "kg kg-1" - -state real - ijkft dfi_moist 1 - - - -state real dfi_qv ijkft dfi_moist 1 - r "QVAPOR" "Water vapor mixing ratio" "kg kg-1" -state real dfi_qc ijkft dfi_moist 1 - r "QCLOUD" "Cloud water mixing ratio" "kg kg-1" -state real dfi_qr ijkft dfi_moist 1 - r "QRAIN" "Rain water mixing ratio" "kg kg-1" -state real dfi_qi ijkft dfi_moist 1 - r "QICE" "Ice mixing ratio" "kg kg-1" -state real dfi_qs ijkft dfi_moist 1 - r "QSNOW" "Snow mixing ratio" "kg kg-1" -state real dfi_qg ijkft dfi_moist 1 - r "QGRAUP" "Graupel mixing ratio" "kg kg-1" - -# -# Other Scalars -state real - ijkftb scalar 1 - - - -state real qni ijkftb scalar 1 - i01rhusdf=(bdy_interp:dt) "QNI" "Ice Number concentration" "# kg(-1)" -state real qns ijkftb scalar 1 - i01rhusdf=(bdy_interp:dt) "QNS" "Snow Number concentration" "# kg(-1)" -state real qnr ijkftb scalar 1 - i01rhusdf=(bdy_interp:dt) "QNR" "Rain Number concentration" "# kg(-1)" -state real qng ijkftb scalar 1 - i01rhusdf=(bdy_interp:dt) "QNG" "Graupel Number concentration" "# kg(-1)" -state real qndrop ijkftb scalar 1 - i01rhusdf=(bdy_interp:dt) "QNDROP" "Droplet number mixing ratio" "# kg-1" -state real qnn ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNCCN" "CCN Number concentration" "# kg(-1)" -state real qnc ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" - -state real - ijkftb dfi_scalar 1 - - - -state real dfi_qndrop ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNDROP" "Droplet number mixing ratio" "# kg-1" -state real dfi_qni ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNICE" "Ice Number concentration" "# kg-1" -state real dfi_qt ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_CWM" "Total condensate mixing ratio" "kg kg-1" -state real dfi_qns ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNSNOW" "Snow Number concentration" "# kg(-1)" -state real dfi_qnr ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNRAIN" "Rain Number concentration" "# kg(-1)" -state real dfi_qng ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" -state real dfi_qnn ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNCC" "CNN Number concentration" "# kg(-1)" -state real dfi_qnc ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "Cloud Number concentration" "# kg(-1)" - - -#----------------------------------------------------------------------------------------------------------------------------------------------------------------- - -# specified LBC arrays, first, Eulerian height coordinate model - - -# specified LBC arrays, next, Eulerian mass coordinate model - - -# specified LBC variables shared between the mass and height coordinate models - - -# soil model variables (Note that they are marked as staggered in the vertical dimension -# because they are "fully dimensioned" -- they use every element in that dim - - -# 2m and 10m output diagnostics - - -# lsm State Variables - -state real SMOIS ilj - 1 Z rh "SMOIS" "SOIL MOISTURE" "" -state real SMCREL ilj - 1 Z r "SMCREL" "RELATIVE SOIL MOISTURE" "" -state real TSLB ilj - 1 Z rh "TSLB" "SOIL TEMPERATURE" "" - - -# MYJ PBL variables - - -# gfdl (eta) radiation State Variables - -# eta microphpysics State Variables - - -# new eta microphpysics State Variables - -# some mass-coordinate-model-specific variables - - - - - - -# was em_only - -################################################################# -# Physics Variables (em core) - - - -################################################################# -# Physics Variables (eh core) ; should be same as em - - - - -################################################################# -# variables added for CHEMISTRY compatibility with ARW core - kludge -################################################################# -state real GSW ij misc 1 - - "" "" -state real XLAT ij misc 1 - - "" "" -state real XLONG ij misc 1 - - "" "" -state real XLAND ij misc 1 - - "" "" -state real TSK ij misc 1 - - "" "" -state real UST ij misc 1 - - "" "" -state real RAINCV ij misc 1 - - "" "" - -################################################################# -# other misc variables (all cores) -################################################################# - -# added for surface_driver -state real PSFC ij misc 1 - i1rh "PSFC" "SFC PRESSURE" -state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" -state real TH2 ij misc 1 - irh "TH2" "POT TEMP at 2 M" "" -state real T2 ij misc 1 - ir "T2" "TEMP at 2 M" "" -state real U10 ij misc 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "U10" "U at 10 M" " " -state real V10 ij misc 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "V10" "V at 10 M" " " -state real XICE ij misc 1 - i01rd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "XICE" "SEA ICE" "" -state real ICEDEPTH ij misc 1 - i0124rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ICEDEPTH" "SEA ICE THICKNESS" "m" -state real ALBSI ij misc 1 - i0124rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ALBSI" "SEA ICE ALBEDO" " " -state real SNOWSI ij misc 1 - i0124rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SNOWSI" "SNOW DEPTH ON SEA ICE" "m" -state real LAI ij misc 1 - i0124rh "LAI" "Leaf area index" "area/area" -state real SMSTAV ij misc 1 - irh "SMSTAV" "MOISTURE VARIBILITY" "" -state real SMSTOT ij misc 1 - irh "SMSTOT" "TOTAL SOIL MOISTURE" "" -state real SOLDRAIN ij misc 1 - r "SOLDRAIN" "soil column drainage" "mm" -state real SFCHEADRT ij misc 1 - r "SFCHEADRT" "surface water depth" "mm" -state real INFXSRT ij misc 1 - r "INFXSRT" "time step infiltration excess" "mm" -state real SFCRUNOFF ij misc 1 - rh "SFROFF" "SURFACE RUNOFF" "" -state real UDRUNOFF ij misc 1 - rh "UDROFF" "UNDERGROUND RUNOFF" "" -state integer IVGTYP ij misc 1 - irhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "IVGTYP" "VEGETATION TYPE" "" -state integer ISLTYP ij misc 1 - irhd=(interp_int_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ISLTYP" "SOIL TYPE" " " -state real VEGFRA ij misc 1 - i014rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "VEGFRA" "VEGETATION FRACTION" "" -state real SFCEVP ij misc 1 - irh "SFCEVP" "SURFACE EVAPORATION" "" -state real GRDFLX ij misc 1 - irh "GRDFLX" "GROUND HEAT FLUX" "" -state real ALBBCK ij misc 1 - i0124r "ALBBCK" "BACKGROUND ALBEDO" "NA" -state real SFCEXC ij misc 1 - irh "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" -state real SNOTIME ij misc 1 - r "SNOTIME" "SNOTIME" "" -state real ACSNOW ij misc 1 - irh "ACSNOW" "ACCUMULATED SNOW" "kg m-2" -state real ACSNOM ij misc 1 - irh "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" -state real RMOL ij misc 1 - irh "RMOL" "" "" -state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" -state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" -state real SST ij misc 1 - i014rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4 "SST" "SEA SURFACE TEM -PERATURE" "K" -state real WEASD ij misc 1 - i01rh "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "kg m-2" -state real ZNT ij misc 1 - irh "ZNT" "TIME-VARYING ROUGHNESS LENGTH" -state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" -state real NOAHRES ij misc 1 - rh "NOAHRES" "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}" - -state real tke_pbl ijk misc 1 Z r "TKE_PBL" "TKE FROM PBL SCHEME" "m2 s-2" -state real el_pbl ikj misc 1 Z - "EL_PBL" "MIXING LENGTH FROM PBL SCHEME" "m" -state real EXCH_H ikj misc 1 Z r "EXCH_H" "EXCHANGE COEFFICIENTS FOR HEAT" "m2 s-1" -state real EXCH_M ikj misc 1 Z r "EXCH_M" "EXCHANGE COEFFICIENTS FOR MOMENTUM" "m2 s-1" -state real THZ0 ij misc 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "THZ0" "POT. TEMPERATURE AT TOP OF VISC. SUBLYR" "K" -state real QZ0 ij misc 1 - irhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "QZ0" "SPECIFIC HUMIDITY AT TOP OF VISC. SUBLYR" "kg kg-1" -state real UZ0 ij misc 1 - irhd=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "UZ0" "U WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" -state real VZ0 ij misc 1 - irhd=(interp_v_nmm:IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4) "VZ0" "V WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" -state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" -state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" -state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" -state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" -state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" -state real DEW ij misc 1 - r "DEW" "DEW MIXING RATIO AT THE SURFACE" "kg kg-1" -state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" -state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" -# added as state for HALO_NMM_MG2, mep -state real psfc_out ij dyn_nmm 1 - - -# added as state for HALO_NMM_TURBL, jm -state real UZ0h ij misc 1 - - -state real VZ0h ij misc 1 - - -state real dudt ijk misc 1 - - -state real dvdt ijk misc 1 - - - -state real QSFC ij misc 1 - irh "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" -state real AKHS ij misc 1 - ir "AKHS" "SFC EXCH COEFF FOR HEAT /DELTA Z" "m s-1" -state real AKMS ij misc 1 - ir "AKMS" "SFC EXCH COEFF FOR MOMENTUM /DELTA Z" "m s-1" -i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" -state real HTOP ij misc 1 - irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "HTOP" "TOP OF CONVECTION LEVEL" "" -state real HBOT ij misc 1 - irhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "HBOT" "BOT OF CONVECTION LEVEL" "" -state real HTOPR ij misc 1 - ird=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" -state real HBOTR ij misc 1 - ird=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" -state real HTOPD ij misc 1 - rh "HTOPD" "TOP DEEP CONVECTION LEVEL" "" -state real HBOTD ij misc 1 - rh "HBOTD" "BOT DEEP CONVECTION LEVEL" "" -state real HTOPS ij misc 1 - rh "HTOPS" "TOP SHALLOW CONVECTION LEVEL" "" -state real HBOTS ij misc 1 - rh "HBOTS" "BOT SHALLOW CONVECTION LEVEL" "" -state REAL CUPPT ij misc 1 - rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINCE LAST CALL TO THE RADIATION" "" -state REAL CPRATE ij misc 1 - rh "CPRATE" "INSTANTANEOUS CONVECTIVE PRECIPITATION RATE" "" # 1-17-06a -state real F_ICE_PHY ikj misc 1 - - "F_ICE_PHY" "FRACTION OF ICE" "" -state real F_RAIN_PHY ikj misc 1 - - "F_RAIN_PHY" "FRACTION OF RAIN " "" -state real F_RIMEF_PHY ikj misc 1 - - "F_RIMEF_PHY" "MASS RATIO OF RIMED ICE " "" -state real ccn1 ijk misc 1 - h "ccn1" "CCN concentration at S=0.02%" "#/cm3" -state real ccn2 ijk misc 1 - h "ccn2" "CCN concentration at S=0.05%" "#/cm3" -state real ccn3 ijk misc 1 - h "ccn3" "CCN concentration at S=0.1%" "#/cm3" -state real ccn4 ijk misc 1 - h "ccn4" "CCN concentration at S=0.2%" "#/cm3" -state real ccn5 ijk misc 1 - h "ccn5" "CCN concentration at S=0.5%" "#/cm3" -state real ccn6 ijk misc 1 - h "ccn6" "CCN concentration at S=1.0%" "#/cm3" -state real qndropsource ijk misc 1 - h "qndropsource" "Droplet number source" "#/kg/s" -# cloud water fractional removal rate needed for wet scavenging -state real qlsink ijk misc 1 - rduh "qlsink" "CLOUD WATER SINK" "/S" -state real precr ijk misc 1 - rduh "precr" "RAIN PRECIPITATION RATE" "KG/M2/S" -state real preci ijk misc 1 - rduh "preci" "ICE PRECIPITATION RATE" "KG/M2/S" -state real precs ijk misc 1 - rduh "precs" "SNOW PRECIPITATION RATE" "KG/M2/S" -state real precg ijk misc 1 - rduh "precg" "GRAUPEL PRECIPITATION RATE" "KG/M2/S" - -state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb/hour" -state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL " "mm/hour" -state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W " "mm/hour" -state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm/hour" -state real apr_st ij misc 1 - r "APR_ST" "PRECIP FROM CLOSURE STABILITY " "mm/hour" -state real apr_as ij misc 1 - r "APR_AS" "PRECIP FROM CLOSURE AS-TYPE " "mm/hour" -state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm/hour" -state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm/hour" -state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm/hour" -state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" -state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" -state real GD_CLOUD ijk misc 1 - rh "GD_CLOUD" "CLOUD WATER/ICE MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2 ijk misc 1 - rh "GD_CLOUD2" "TEST for GD CLOUD" "kg kg-1" -# time averaged stuff -state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TOTAL ADVECTIVE POTENTIAL TEMPERATURE TENDENCY" "K s-1" -state real RQVFTEN ikj misc 1 - r "RQVFTEN" "TOTAL ADVECTIVE MOISTURE TENDENCY" "kg kg-1 s-1" -state real SNOWH ij misc 1 - i01rhd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SNOWH" "PHYSICAL SNOW DEPTH" "m" -state real RHOSN ij misc 1 - i01rd=(interp_h_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "RHOSN" " SNOW DENSITY" "kg m-3" -state real SMFR3D ilj misc 1 Z rh "SMFR3D" "SOIL ICE" "" -state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" -state real rc_mf ikj misc 1 - r "RC_MF" "RC IN THE GRID COMPUTED BY EDKF" "kg/kg" - -# For Noah-MP -rconfig integer dveg namelist,noah_mp 1 4 h "dveg" "dynamic vegetation (1 -> off ; 2 -> on)" "" -rconfig integer opt_crs namelist,noah_mp 1 1 h "opt_crs" "canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis)" "" -rconfig integer opt_btr namelist,noah_mp 1 1 h "opt_btr" "soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB)" "" -rconfig integer opt_run namelist,noah_mp 1 1 h "opt_run" "runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS)" "" -rconfig integer opt_sfc namelist,noah_mp 1 1 h "opt_sfc" "surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97)" "" -rconfig integer opt_frz namelist,noah_mp 1 1 h "opt_frz" "supercooled liquid water (1-> NY06; 2->Koren99)" "" -rconfig integer opt_inf namelist,noah_mp 1 1 h "opt_inf" "frozen soil permeability (1-> NY06; 2->Koren99)" "" -rconfig integer opt_rad namelist,noah_mp 1 3 h "opt_rad" "radiation transfer (1->gap=F(3D,cosz); 2->gap=0; 3->gap=1-Fveg)" "" -rconfig integer opt_alb namelist,noah_mp 1 2 h "opt_alb" "snow surface albedo (1->BATS; 2->CLASS)" "" -rconfig integer opt_snf namelist,noah_mp 1 1 h "opt_snf" "rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah)" "" -rconfig integer opt_tbot namelist,noah_mp 1 2 h "opt_tbot" "lower boundary of soil temperature (1->zero-flux; 2->Noah)" "" -rconfig integer opt_stc namelist,noah_mp 1 1 h "opt_stc" "soil/snow temperature time scheme 1->semi-implicit; 2->full-implicit (original Noah)" "" - -# For WRF Hydro -rconfig integer wrf_hydro derived 1 0 h "wrf_hydro" "descrip" "unit" - -# For Noah UA changes -state real flx4 ij - 1 - h "FLX4" "sensible heat from canopy" "W m{-2}" -state real fvb ij - 1 - h "FVB" "fraction of vegetation with snow below" "" -state real fbur ij - 1 - h "FBUR" "fraction of vegetation covered by snow" "" -state real fgsn ij - 1 - h "FGSN" "fraction of ground covered by snow" "" - -# For Noah-MP -state integer isnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "isnow" "no. of snow layer" "m3 m-3" -state real tvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tv" "vegetation leaf temperature" "K" -state real tgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tg" "bulk ground temperature" "K" -state real canicexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "canice" "intercepted ice mass" "mm" -state real canliqxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "canliq" "intercepted liquid water" "mm" -state real eahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "eah" "canopy air vapor pressure" "pa" -state real tahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tah" "canopy air temperature" "K" -state real cmxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "cm" "surf. exchange coeff. for momentum" "m/s" -state real chxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ch" "surf. exchange coeff. for heat" "m/s" -state real fwetxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fwet" "wetted or snowed canopy fraction" "-" -state real sneqvoxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sneqvo" "snow mass at last time step" "mm" -state real alboldxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "albold" "snow albedo at last timestep" "-" -state real qsnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "qsnowxy" "snowfall on the ground" "mm/s" -state real wslakexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wslake" "lake water storage" "mm" -state real zwtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "zwt" "water table depth" "m" -state real waxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wa" "water in the acquifer" "mm" -state real wtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wt" "groundwater storage" "mm" -state real tsnoxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tsno" "snow temperature" "K" -state real zsnsoxy i{snsl}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "zsnso" "layer-bottom depth from snow surf" "m" -state real snicexy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "snice" "snow layer ice" "mm" -state real snliqxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "snliq" "snow layer liquid" "mm" -state real lfmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "lfmass" "leaf mass" "g/m2" -state real rtmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rtmass" "mass of fine roots" "g/m2" -state real stmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "stmass" "stem mass" "g/m2" -state real woodxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wood" "mass of wood" "g/m2" -state real stblcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "stblcp" "stable carbon pool" "g/m2" -state real fastcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fastcp" "short-lived carbon" "g/m2" -state real xsaixy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "xsai" "stem area index" "-" -state real taussxy ij - 1 - rh "tauss" "non-dimensional snow age" "" -state real t2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "t2v" "2 meter temperature over canopy" "K" -state real t2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "t2b" "2 meter temperature over bare ground" "K" -state real q2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "q2v" "2 meter mixing ratio over canopy" "kg kg-1" -state real q2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "q2b" "2 meter mixing ratio over bare ground" "kg kg-1" -state real tradxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "trad" "surface radiative temperature" "K" -state real neexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "nee" "net ecosystem exchange" "g/m2/s CO2" -state real gppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "gpp" "gross primary productivity" "g/m2/s C" -state real nppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "npp" "net primary productivity" "g/m2/s C" -state real fvegxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fveg" "Noah-MP vegetation fraction" "" -state real qinxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "qin" "groundwater recharge" "mm/s" -state real runsfxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "runsf" "surface runoff" "mm/s" -state real runsbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "runsb" "subsurface runoff" "mm/s" -state real ecanxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ecan" "evaporation of intercepted water" "mm/s" -state real edirxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "edir" "ground surface evaporation rate" "mm/s" -state real etranxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "etran" "transpiration rate" "mm/s" -state real fsaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fsa" "total absorbed solar radiation" "W/m2" -state real firaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fira" "total net longwave rad" "W/m2" -state real aparxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "apar" "photosyn active energy by canopy" "W/m2" -state real psnxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "psn" "total photosynthesis" "umol co2/m2/s" -state real savxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sav" "solar rad absorbed by veg" "W/m2" -state real sagxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sag" "solar rad absorbed by ground" "W/m2" -state real rssunxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rssun" "sunlit stomatal resistance" "s/m" -state real rsshaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rssha" "shaded stomatal resistance" "s/m" -state real bgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "bgap" "between canopy gap" "fraction" -state real wgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wgap" "within canopy gap" "fraction" -state real tgvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tgv" "ground temp. under canopy""K" -state real tgbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tgb" "bare ground temperature" "K" -state real chvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv" "vegetated heat exchange coefficient" "m/s" -state real chbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb" "bare-ground heat exchange coefficient" "m/s" -state real shgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shg" "sensible heat flux: ground to canopy" "W/m2" -state real shcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shc" "sensible heat flux: leaf to canopy" "W/m2" -state real shbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shb" "sensible heat flux: bare grnd to atmo" "W/m2" -state real evgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evg" "latent heat flux: ground to canopy" "W/m2" -state real evbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evb" "latent heat flux: bare grnd to atmo" "W/m2" -state real ghvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ghv" "heat flux into soil: under canopy" "W/m2" -state real ghbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ghb" "heat flux into soil: bare fraction" "W/m2" -state real irgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irg" "net longwave at below canopy surface" "W/m2" -state real ircxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irc" "net longwave in canopy" "W/m2" -state real irbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irb" "net longwave at bare fraction surface" "W/m2" -state real trxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tr" "transpiration" "W/m2" -state real evcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evc" "canopy evaporation" "W/m2" -state real chleafxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chleaf" "leaf exchange coefficient" "m/s" -state real chucxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chuc" "under canopy exchange coefficient" "m/s" -state real chv2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv2" "leaf exchange coefficient" "m/s" -state real chb2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb2" "under canopy exchange coefficient" "m/s" -state real chstarxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chstar" "dummy exchange coefficient" "m/s" - -# added state for etampnew microphysics (needed for restarts) -state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" -state real tbpvs_state p misc 1 - r "TBPVS_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" -state real tbpvs0_state p misc 1 - r "TBPVS0_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" - -# State variables for landuse_init, Must be declared state because the are read in and needed for restarts. Had been SAVE vars in -# landuse_init (phys/module_physics_init.F) -state integer landuse_isice - misc - - - -state integer landuse_lucats - misc - - - -state integer landuse_luseas - misc - - - -state integer landuse_isn - misc - - - -state real lu_state p misc - - - - - -################################################################# -# - -state integer number_at_same_level - - - - - "number_at_same_level" "" "" - -# State for derived time quantities. -#for HWRF: add to restart -state integer itimestep - - - - rh "itimestep" "" "" -state real xtime - - - - h "xtime" "minutes since simulation start" "" -state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" - -# input file descriptor for lbcs on parent domain - had2chem_tim=had2chem_tim+timef()-btimx -state integer lbc_fid - - - - - "lbc_fid" "" "" - -# indicates if tiling has been computed -state logical tiled - - - - - "tiled" "" "" -# indicates if patches have been computed -state logical patched - - - - - "patched" "" "" -# indicates whether to read input from file or generate -#state logical input_from_file - - - - - "input_from_file" "" "" - -# vortex center indices; need for restarts of moving nests -state real xi - misc - - r -state real xj - misc - - r -state real vc_i - misc - - r -state real vc_j - misc - - r - -###### -# -# Variables that are set at run-time to control configuration (namelist-settable) -# -#
- - -# Time Control -rconfig integer run_days namelist,time_control 1 0 irh "run_days" "NUMBER OF DAYS TO RUN" -rconfig integer run_hours namelist,time_control 1 0 irh "run_hours" "NUMBER OF HOURS TO RUN" -rconfig integer run_minutes namelist,time_control 1 0 irh "run_minutes" "NUMBER OF MINUTES TO RUN" -rconfig integer run_seconds namelist,time_control 1 0 irh "run_seconds" "NUMBER OF SECONDS TO RUN" -rconfig integer start_year namelist,time_control max_domains 1993 irh "start_year" "4 DIGIT YEAR OF START OF MODEL" "YEARS" -rconfig integer start_month namelist,time_control max_domains 03 irh "start_month" "2 DIGIT MONTH OF THE YEAR OF START OF MODEL, 1-12" "MONTHS" -rconfig integer start_day namelist,time_control max_domains 13 irh "start_day" "2 DIGIT DAY OF THE MONTH OF START OF MODEL, 1-31" "DAYS" -rconfig integer start_hour namelist,time_control max_domains 12 irh "start_hour" "2 DIGIT HOUR OF THE DAY OF START OF MODEL, 0-23" "HOURS" -rconfig integer start_minute namelist,time_control max_domains 00 irh "start_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF MODEL, 0-59" "MINUTES" -rconfig integer start_second namelist,time_control max_domains 00 irh "start_second" "2 DIGIT SECOND OF THE MINUTE OF START OF MODEL, 0-59" "SECONDS" -rconfig integer end_year namelist,time_control max_domains 1993 irh "end_year" "4 DIGIT YEAR OF END OF MODEL" "YEARS" -rconfig integer end_month namelist,time_control max_domains 03 irh "end_month" "2 DIGIT MONTH OF THE YEAR OF END OF MODEL, 1-12" "MONTHS" -rconfig integer end_day namelist,time_control max_domains 14 irh "end_day" "2 DIGIT DAY OF THE MONTH OF END OF MODEL, 1-31" "DAYS" -rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" -rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" -rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" -rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" -rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" -rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 5, WHAT INPUT STREAM IS FINE GRID IC FROM" "" - -include registry.io_boilerplate -include registry.chem - -#for HWRF: added a 'r' for restart -rconfig integer JULYR namelist,time_control max_domains 0 hr "JULYR" "" "" -rconfig integer JULDAY namelist,time_control max_domains 1 hr "JULDAY" "" "" -rconfig real GMT namelist,time_control max_domains 0. hr "GMT" "" "" -#for HWRF: end -rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" -rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" -rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" -rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" -rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" -rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" -#for HWRF: -rconfig character anl_outname namelist,time_control max_domains "wrfanl_d_" - "name of analysis outfile" "" "" -rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" -rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" -rconfig logical write_hist_at_0h_rst namelist,time_control 1 .false. h "write_hist_at_0h_rst" "T/F write hist at 0 h of restarted forecast" -rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" -rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" -rconfig real tstart namelist,time_control max_domains 0. irh "tstart" "forecast hour at the start of the NMM integration" -rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" -rconfig logical cycling namelist,time_control 1 .false. - "true for cycling (using wrfout file as input data)" - -# DFI namelist -rconfig integer dfi_opt namelist,dfi_control 1 0 rh "dfi_opt" "" "" -rconfig integer dfi_nfilter namelist,dfi_control 1 7 rh "dfi_nfilter" "Digital filter type" "" -rconfig logical dfi_write_filtered_input namelist,dfi_control 1 .true. rh "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?" "" -rconfig logical dfi_write_dfi_history namelist,dfi_control 1 .false. rh "dfi_write_dfi_history" "Write history files during filtering?" "" -rconfig integer dfi_cutoff_seconds namelist,dfi_control 1 3600 rh "dfi_cutoff_seconds" "Digital filter cutoff time" "" -rconfig integer dfi_time_dim namelist,dfi_control 1 1000 rh "dfi_time_dim" "MAX DIMENSION FOR HCOEFF" -rconfig integer dfi_fwdstop_year namelist,dfi_control 1 2004 rh "dfi_fwdstop_year" "4 DIGIT YEAR OF START OF DFI" "YEARS" -rconfig integer dfi_fwdstop_month namelist,dfi_control 1 03 rh "dfi_fwdstop_month" "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS" -rconfig integer dfi_fwdstop_day namelist,dfi_control 1 13 rh "dfi_fwdstop_day" "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS" -rconfig integer dfi_fwdstop_hour namelist,dfi_control 1 12 rh "dfi_fwdstop_hour" "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS" -rconfig integer dfi_fwdstop_minute namelist,dfi_control 1 00 rh "dfi_fwdstop_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES" -rconfig integer dfi_fwdstop_second namelist,dfi_control 1 00 rh "dfi_fwdstop_second" "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS" -rconfig integer dfi_bckstop_year namelist,dfi_control 1 2004 rh "dfi_bckstop_year" "4 DIGIT YEAR OF END OF DFI" "YEARS" -rconfig integer dfi_bckstop_month namelist,dfi_control 1 03 rh "dfi_bckstop_month" "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS" -rconfig integer dfi_bckstop_day namelist,dfi_control 1 14 rh "dfi_bckstop_day" "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS" -rconfig integer dfi_bckstop_hour namelist,dfi_control 1 12 rh "dfi_bckstop_hour" "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS" -rconfig integer dfi_bckstop_minute namelist,dfi_control 1 00 rh "dfi_bckstop_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES" -rconfig integer dfi_bckstop_second namelist,dfi_control 1 00 rh "dfi_bckstop_second" "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS" - - -# Domains -rconfig integer time_step namelist,domains 1 - ih "time_step" -rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" -rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" -rconfig integer time_step_dfi namelist,domains 1 - ih "time_step_dfi" -rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" -rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" -rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" -rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" -rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" -rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" -rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" -rconfig integer num_metgrid_soil_levels namelist,domains 1 4 irh "num_metgrid_soil_levels" "number of input levels or layers in 3D sm, st, sw arrays" "" -rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" -rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" -rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" -rconfig logical grid_allowed namelist,domains max_domains .true. irh "allowed" "" "" -rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" -rconfig integer i_parent_start namelist,domains max_domains 1 h "i_parent_start" "" "" -rconfig integer j_parent_start namelist,domains max_domains 1 h "j_parent_start" "" "" -rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" -rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" -rconfig integer feedback namelist,domains 1 1 h "feedback" "" "" -rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" -rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" -rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" -rconfig integer moad_time_step_ratio namelist,domains max_domains 1 h "moad_time_step_ratio" "" "" -rconfig integer shw namelist,domains max_domains 2 h "stencil_half_width" "HORIZONTAL INTERPOLATION STENCIL HALF-WIDTH" "GRID POINTS" -rconfig integer tile_sz_x namelist,domains 1 0 - "tile_sz_x" "" "" -rconfig integer tile_sz_y namelist,domains 1 0 - "tile_sz_y" "" "" -rconfig integer numtiles namelist,domains 1 1 - "numtiles" "" "" -rconfig integer numtiles_inc namelist,domains 1 0 - "numtiles_inc" "" "" -rconfig integer numtiles_x namelist,domains 1 0 - "numtiles_x" "" "" -rconfig integer numtiles_y namelist,domains 1 0 - "numtiles_y" "" "" -rconfig integer tile_strategy namelist,domains 1 0 - "tile_strategy" "" "" -rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" -rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" -rconfig integer irand namelist,domains 1 0 - "irand" "" "" -rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" -rconfig integer ts_buf_size namelist,domains 1 200 - "ts_buf_size" "Size of time series buffer" -rconfig integer max_ts_locs namelist,domains 1 5 - "max_ts_locs" "Maximum number of time series locations" -rconfig integer num_moves namelist,domains 1 0 -rconfig integer vortex_interval namelist,domains max_domains 15 - "" "" "minutes" -rconfig integer corral_dist namelist,domains max_domains 8 -rconfig integer move_id namelist,domains max_moves 0 -rconfig integer move_interval namelist,domains max_moves 999999999 -rconfig integer move_cd_x namelist,domains max_moves 0 -rconfig integer move_cd_y namelist,domains max_moves 0 -rconfig logical swap_x namelist,domains max_domains .false. rh "swap_x" "" "" -rconfig logical swap_y namelist,domains max_domains .false. rh "swap_y" "" "" -rconfig logical cycle_x namelist,domains max_domains .false. rh "cycle_x" "" "" -rconfig logical cycle_y namelist,domains max_domains .false. rh "cycle_y" "" "" -rconfig logical reorder_mesh namelist,domains 1 .false. rh "reorder_mesh" "" "" -rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" -# WPS related -rconfig real eta_levels namelist,domains max_eta -1. -rconfig real ptsgm namelist,domains 1 42000. -rconfig integer num_metgrid_levels namelist,domains 1 43 irh "num_metgrid_levels" "" "" -rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" - -# Physics -rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" -#for HWRF: -rconfig real mommix namelist,physics max_domains 0.7 irh "MOMENTUM MIXING FOR SAS CONVECTION SCHEME" -rconfig logical disheat namelist,physics max_domains .true. irh "nmm input 7" -#end HWRF: -rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" -rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" -rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" -rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" -rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" -rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" -rconfig integer mfshconv namelist,physics max_domains 1 rh "mfshconv" "To activate mass flux scheme with qnse, 1=true; 0=false" "" -rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" -rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" -rconfig integer shcu_physics namelist,physics max_domains 0 rh "shcu_physics" "" "" -rconfig integer cu_diag namelist,physics max_domains 0 rh "cu_diag" " additional t-averaged stuff for cuphys" "" -rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" -rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" -rconfig integer progn namelist,physics max_domains 0 rh "progn" "" "" -rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" -rconfig integer IFSNOW namelist,physics 1 1 irh "IFSNOW" "" "" -rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" -rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" -rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" -rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" -rconfig integer num_urban_layers namelist,physics 1 400 irh "num_urban_layers" "" "" -rconfig integer num_urban_hi namelist,physics 1 15 irh "num_urban_hi" "" "" -rconfig integer mosaic_lu namelist,physics 1 0 irh "mosaic_lu" "" "" -rconfig integer mosaic_soil namelist,physics 1 0 irh "mosaic_soil" "" "" -rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" -rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" -rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" -rconfig integer maxens3 namelist,physics 1 16 irh "maxens3" "" "" -rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" -rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" -rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" -rconfig integer topo_wind namelist,physics max_domains 0 - "topo_wind" "2: Use Mass sfc drag scheme, 1: improve effects topography over surface wind, 0:not" "" -rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" -rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" -rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" -rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seiace" "Fractional sea-ice option" -rconfig integer seaice_albedo_opt namelist,physics 1 0 - "seaice_albedo_opt" "Method for setting albedo over sea ice" -rconfig real seaice_albedo_default namelist,physics 1 0.65 - "seaice_albedo_default" "Default value for sea-ice over albedo with seaice_albeo_opt=0" -rconfig integer seaice_snowdepth_opt namelist,physics 1 0 - "seaice_snowdepth_opt" "Method for treating snow depth on sea ice" -rconfig real seaice_snowdepth_max namelist,physics 1 1.E10 - "seaice_snowdepth_max" "Maximum allowed accumulation (m) of snow on sea ice" -rconfig real seaice_snowdepth_min namelist,physics 1 0.001 - "seaice_snowdepth_min" "Minimum snow depth (m) on sea ice" -rconfig integer seaice_thickness_opt namelist,physics 1 0 - "seaice_thickness_opt" "Method for setting sea ice thickness" -rconfig real seaice_thickness_default namelist,physics 1 3.0 - "seaice_thickness_default" "Default value for sea-ice thickness" -rconfig logical tice2tsk_if2cold namelist,physics 1 .false. - "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent" -rconfig integer sst_update namelist,physics 1 0 i01rh "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" -rconfig integer sf_urban_physics namelist,physics max_domains 0 h "sf_urban_physics" "activate urban model 0=no, 1=Noah_UCM, 2=BEP_UCM" "" -rconfig logical usemonalb namelist,physics 1 .true. h "usemonalb" "use 2d field vs table values false=table, True=2d" "" -rconfig logical rdmaxalb namelist,physics 1 .true. h "rdmaxalb" "false set it to table values" "" -rconfig logical rdlai2d namelist,physics 1 .false. h "rdlai2d" "false set it to table values" "" -rconfig logical ua_phys namelist,physics 1 .false. h "ua_phys" "activate UA Noah changes" "" -rconfig integer gwd_opt namelist,physics max_domains 0 irh "gwd_opt" "activate gravity wave drag: 0=off, 1=ARW, 2=NMM" "" -rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" -rconfig real sas_pgcon namelist,physics max_domains 0.55 irh "sas_pgcon" "convectively forced pressure gradient factor (SAS scheme)" "" -rconfig real sas_shal_pgcon namelist,physics max_domains -1 irh "sas_shal_pgcon" "convectively forced pressure gradient factor, -1 means use sas_pgcon (SAS shallow conv)" "" -rconfig integer sas_shal_conv namelist,physics max_domains 0 - "sas_shal_conv" "1=enable shallow convection in SAS (must use bl_pbl_physics=83)" -rconfig real sas_mass_flux namelist,physics max_domains 9e9 - "sas_mass_flux" "mass flux limit (SAS scheme)" "" -rconfig integer random_seed namelist,physics max_domains 0 irh "random_seed" "random number generator seed" -rconfig integer maxpatch namelist,physics 1 10 irh "maxpatch" "" "" - -# nmm variables -rconfig integer idtad namelist,physics max_domains 2 irh "idtad" "fundamental timesteps between calls to NMM passive advection scheme" -rconfig integer nsoil namelist,physics max_domains 4 irh "nsoil" "number of soil layers" -rconfig integer nphs namelist,physics max_domains 10 irh "nphs" "fundamental timesteps between calls to NMM turbulence" -rconfig integer ncnvc namelist,physics max_domains 10 irh "ncnvc" "fundamental timesteps between calls to NMM convection" -rconfig integer nrand namelist,physics max_domains 10 irh "nrand" "fundamental timesteps between random number generator updates (0=use ncnvc)" -rconfig integer nrads namelist,physics max_domains 200 irh "nrads" "fundamental timesteps between calls to NMM shortwave radiation" -rconfig integer nradl namelist,physics max_domains 200 irh "nradl" "fundamental timesteps between calls to NMM longwave radiation" -rconfig real tprec namelist,physics max_domains 3. irh "tprec" "number of hours in bucket for total precipitation" -rconfig real theat namelist,physics max_domains 6. irh "theat" "number of hours in bucket for gridscale and convective heating rates" -rconfig real tclod namelist,physics max_domains 6. irh "tclod" "number of hours in bucket for cloud amounts" -rconfig real trdsw namelist,physics max_domains 6. irh "trdsw" "number of hours in bucket for short wave fluxes" -rconfig real trdlw namelist,physics max_domains 6. irh "trdlw" "number of hours in bucket for long wave fluxes" -rconfig real tsrfc namelist,physics max_domains 6. irh "tsrfc" "number of hours in bucket for evaporation / sfc fluxes" -rconfig logical pcpflg namelist,physics max_domains .false. irh "pcpflg" "logical switch that turns on/off the precipitation assimilation" -rconfig integer sigma namelist,physics max_domains 1 irh "sigma" "logical switch for NMM vertical coordinate (sigma or hybrid)" -rconfig real sfenth namelist,physics max_domains 1.0 irh "sea spray parameter" -rconfig integer co2tf namelist,physics 1 0 - "co2tf" "GFDL radiation co2 flag" -rconfig integer ra_call_offset namelist,physics 1 -1 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" -rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" -rconfig integer levsiz namelist,physics 1 1 - "levsiz" "Number of ozone data levels for CAM radiation (59)" "" -rconfig integer paerlev namelist,physics 1 1 - "paerlev" "Number of aerosol data levels for CAM radiation (29)" "" -rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" -rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" -rconfig integer no_src_types namelist,physics 1 1 - "no_src_types" "Number of aerosoal types from EC (6)" "" -rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" -rconfig integer o3input namelist,physics 1 0 - "o3input" "ozone input option for radiation" "" -rconfig integer aer_opt namelist,physics 1 0 - "aer_opt" "aerosol input option for radiation" "" -rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" "" -rconfig real h_diff namelist,physics max_domains 0.1 irh "nmm input 9" -rconfig integer movemin namelist,physics max_domains 10 irh "nmm input 12" -rconfig integer num_snso_layers namelist,physics 1 7 irh "num_snso_layers" "" "" -rconfig integer num_snow_layers namelist,physics 1 3 irh "num_snow_layers" "" "" - - -# Dynamics -# dynamics option (see package definitions, below) -rconfig integer dyn_opt namelist,dynamics 1 - -rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" -rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" -# diff_opt 1=old diffusion, 2=new -rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" -# km_opt 1=old coefs, 2=tke, 3=Smagorinksy -rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" -rconfig integer damp_opt namelist,dynamics 1 1 irh "damp_opt" "" "" -rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" -rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" -rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" -rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" -rconfig real iso_temp namelist,dynamics 1 0. h "iso_temp" "Isothermal temperature in stratosphere, real only" "K" -rconfig real dampcoef namelist,dynamics max_domains 0.2 h "dampcoef" "" "" -rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" -rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" -rconfig real c_s namelist,dynamics max_domains 0.25 h "c_s" "Smagorinsky coeff" "" -rconfig real c_k namelist,dynamics max_domains 0.15 h "c_k" "TKE coeff" "" -rconfig real smdiv namelist,dynamics max_domains 0. h "smdiv" "" "" -rconfig real emdiv namelist,dynamics max_domains 0. h "emdiv" "" "" -rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" -rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" -rconfig integer time_step_sound namelist,dynamics max_domains 10 h "time_step_sound" "" "" -rconfig integer h_mom_adv_order namelist,dynamics max_domains 3 rh "h_mom_adv_order" "" "" -rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rh "v_mom_adv_order" "" "" -rconfig integer h_sca_adv_order namelist,dynamics max_domains 3 rh "h_sca_adv_order" "" "" -rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" -rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" -rconfig real tke_upper_bound namelist,dynamics max_domains 1000. h "tke_upper_bound" "" "" -rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "" -rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "" -rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" -rconfig logical euler_adv namelist,dynamics 1 .true. irh "euler_adv" "Logical flag to turn on/off Eulerian pasive advection" "" -rconfig integer idtadt namelist,dynamics 1 1 irh "idtadt" "Fundamental timesteps between calls to Eulerian advection for dynamics" "" -rconfig integer idtadc namelist,dynamics 1 1 irh "idtadc" "Fundamental timesteps between calls to Eulerian advection for chemistry" "" -rconfig real codamp namelist,dynamics max_domains 6.4 irh "codamp" "divergence damping weighting factor (larger = more damping) " "" -rconfig real coac namelist,dynamics max_domains 1.6 irh "coac" "horizontal diffusion weighting factor (larger = more diffusion) " "" -rconfig real slophc namelist,dynamics max_domains 6.363961e-3 irh "slophc" "Maximum model level slope (dZ/dy) for which hor diffusion is applied" "" -rconfig real wp namelist,dynamics max_domains 0. irh "wp" "Off-centering weight in the updating of nonhyrostatic eps" - - -# Bdy_control -rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" -rconfig integer spec_zone namelist,bdy_control 1 1 irh "spec_zone" "" "" -rconfig integer relax_zone namelist,bdy_control 1 4 irh "relax_zone" "" "" -rconfig logical specified namelist,bdy_control max_domains .false. rh "specified" "" "" -rconfig logical periodic_x namelist,bdy_control max_domains .false. rh "periodic_x" "" "" -rconfig logical symmetric_xs namelist,bdy_control max_domains .false. rh "symmetric_xs" "" "" -rconfig logical symmetric_xe namelist,bdy_control max_domains .false. rh "symmetric_xe" "" "" -rconfig logical open_xs namelist,bdy_control max_domains .false. rh "open_xs" "" "" -rconfig logical open_xe namelist,bdy_control max_domains .false. rh "open_xe" "" "" -rconfig logical periodic_y namelist,bdy_control max_domains .false. rh "periodic_y" "" "" -rconfig logical symmetric_ys namelist,bdy_control max_domains .false. rh "symmetric_ys" "" "" -rconfig logical symmetric_ye namelist,bdy_control max_domains .false. rh "symmetric_ye" "" "" -rconfig logical open_ys namelist,bdy_control max_domains .false. rh "open_ys" "" "" -rconfig logical open_ye namelist,bdy_control max_domains .false. rh "open_ye" "" "" -rconfig logical polar namelist,bdy_control max_domains .false. rh "polar" "" "" -rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" -rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" - -rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" -rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" -rconfig integer production_status namelist,grib2 1 255 rh "production_status" "Background processing id for grib2" "" -rconfig integer compression namelist,grib2 1 40 rh "compression" "grib2 compression, 40 for JPEG2000 or 41 for PNG" "" - -# NAMELIST DERIVED -rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" -rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" -rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" -rconfig real truelat2 derived max_domains 0 - "true_lat2" "second standard parallel" "degrees, negative is south" -rconfig real moad_cen_lat derived max_domains 0 - "moad_cen_lat" "center latitude of the most coarse grid" "degrees, negative is south" -rconfig real stand_lon derived max_domains 0 - "stand_lon" "standard longitude, parallel to j-direction, perpendicular to i-direction " "degrees, negative is west" -rconfig integer FLAG_METGRID derived 1 0 - "FLAG_METGRID" "Flag in global attributes for metgrid data" -rconfig integer FLAG_SNOW derived 1 0 - "FLAG_SNOW" "Flag for snow in the global attributes for metgrid data" -rconfig integer FLAG_PSFC derived 1 0 - "FLAG_PSFC" "Flag for surface pressure in the global attributes for metgrid data" -rconfig integer FLAG_SM000010 derived 1 0 - "FLAG_SM000010" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_SM010040 derived 1 0 - "FLAG_SM010040" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_SM040100 derived 1 0 - "FLAG_SM040100" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_SM100200 derived 1 0 - "FLAG_SM100200" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_ST000010 derived 1 0 - "FLAG_ST000010" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_ST010040 derived 1 0 - "FLAG_ST000010" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_ST040100 derived 1 0 - "FLAG_ST010040" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_ST100200 derived 1 0 - "FLAG_ST100200" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_SLP derived 1 0 - "FLAG_SLP" "Flag for sea level pressure in the global attributes for metgrid data" -rconfig integer FLAG_SOILHGT derived 1 0 - "FLAG_SOILHGT" "Flag for soil height in the global attributes for metgrid data" -rconfig integer FLAG_MF_XY derived 1 0 - "FLAG_MF_XY" "Flag for MF_XYin the global attributes for metgrid data" -rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" -rconfig character mminlu derived max_domains " " - "mminlu" "land use dataset" "" -rconfig real emifrq derived max_domains 0 - "emifrq" "chem emissions input frequency" "seconds" -rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" -rconfig integer islake derived max_domains 0 - "islake" "land use index of inland lake" "index category" -rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" -rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" -rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" -rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" -#rconfig integer simulation_start_year derived 1 0 h "simulation_start_year" "start of simulation through restarts" "4-digit year" -#rconfig integer simulation_start_month derived 1 0 h "simulation_start_month" "start of simulation through restarts" "2-digit month" -#rconfig integer simulation_start_day derived 1 0 h "simulation_start_day" "start of simulation through restarts" "2-digit day" -#rconfig integer simulation_start_hour derived 1 0 h "simulation_start_hour" "start of simulation through restarts" "2-digit hour" -#rconfig integer simulation_start_minute derived 1 0 h "simulation_start_minute" "start of simulation through restarts" "2-digit minute" -#rconfig integer simulation_start_second derived 1 0 h "simulation_start_second" "start of simulation through restarts" "2-digit second" - -# -# Single dummy declaration to define a nodyn dyn option -state integer nodyn_dummy - dyn_nodyn - - - "" "" "" - -#key package associated package associated 4d scalars -# name namelist choice state vars - -#### 9. Edit the Registry file to set up '5' as the value of the -**** namelist variable dyn_opt that means to select our exp dyncore. -package dyn_exp dyn_opt==5 - - - - -package noprogn progn==0 - - -package progndrop progn==1 - scalar:qndrop -package passiveqv mp_physics==0 - moist:qv -package kesslerscheme mp_physics==1 - moist:qv,qc,qr -package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg -package wsm3scheme mp_physics==3 - moist:qv,qc,qr -package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs -package etampnew mp_physics==5 - moist:qv,qc,qr,qs -package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg -package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg -package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr -package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh -package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng -package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs -package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr -package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr -package etamp_hwrf mp_physics==85 - moist:qv,qc,qr,qi,qs -package etampold mp_physics==95 - moist:qv,qc,qr,qs - -package rrtmscheme ra_lw_physics==1 - - -package camlwscheme ra_lw_physics==3 - - -package rrtmg_lwscheme ra_lw_physics==4 - - -package goddardlwscheme ra_lw_physics==5 - - -package flglwscheme ra_lw_physics==7 - - -package gfdllwscheme ra_lw_physics==99 - moist:qv,qc,qr,qi -package hwrflwscheme ra_lw_physics==98 - -package swradscheme ra_sw_physics==1 - - -package gsfcswscheme ra_sw_physics==2 - - -package camswscheme ra_sw_physics==3 - - -package rrtmg_swscheme ra_sw_physics==4 - - -package goddardswscheme ra_sw_physics==5 - - -package flgswscheme ra_sw_physics==7 - - -package gfdlswscheme ra_sw_physics==99 - - -package hwrfswscheme ra_sw_physics==98 -package heldsuarez ra_lw_physics==31 - - - -package sfclayscheme sf_sfclay_physics==1 - - -package myjsfcscheme sf_sfclay_physics==2 - - -package gfssfcscheme sf_sfclay_physics==3 - - -package gfdlsfcscheme sf_sfclay_physics==88 - - -package qnsesfcscheme sf_sfclay_physics==4 - - -package pxsfcscheme sf_sfclay_physics==7 - - -package temfsfcscheme sf_sfclay_physics==10 - - -package sfclayrevscheme sf_sfclay_physics==11 - - -package idealscmsfcscheme sf_sfclay_physics==89 - - -package gbmpblscheme sf_sfclay_physics==12 - - - -package slabscheme sf_surface_physics==1 - - -package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn -package ruclsmscheme sf_surface_physics==3 - - -package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy -package clmscheme sf_surface_physics==5 - - -package gfdlslab sf_surface_physics==88 - - -package pxlsmscheme sf_surface_physics==7 - - -package ssibscheme sf_surface_physics==8 - - -package ysuscheme bl_pbl_physics==1 - - -package myjpblscheme bl_pbl_physics==2 - - -package gfsscheme bl_pbl_physics==3 - - -package gfs2011scheme bl_pbl_physics==83 - state:hpbl2d,heat2d,evap2d -package gfs2011scheme bl_pbl_physics==83 - state:hpbl2d,heat2d,evap2d -package qnsepblscheme bl_pbl_physics==4 - - -package qnsepbl09scheme bl_pbl_physics==94 - - -package acmpblscheme bl_pbl_physics==7 - - -package boulacscheme bl_pbl_physics==8 - - -package camuwpblscheme bl_pbl_physics==9 - - -package mrfscheme bl_pbl_physics==99 - - -package temfpblscheme bl_pbl_physics==10 - - - -package kfetascheme cu_physics==1 - - -package bmjscheme cu_physics==2 - - -package gdscheme cu_physics==93 - - -package sasscheme cu_physics==84 - state:hpbl2d,heat2d,evap2d -package osasscheme cu_physics==4 - state:randstate1,randstate2,randstate3,randstate4,random -package g3scheme cu_physics==5 - - -package gfscheme cu_physics==3 - - -package tiedtkescheme cu_physics==6 - - -package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD_B,GD_CLOUD2_A,GD_CLOUD2_B,kbcon_deep,ktop_deep,k22_deep -package camzmscheme cu_physics==7 - - -package nsasscheme cu_physics==14 - - -package kfscheme cu_physics==99 - - - -package g3shcuscheme shcu_physics==1 - - -package camuwshcuscheme shcu_physics==2 - - -package grimsshcuscheme shcu_physics==3 - - - -package dfi_setup dfi_stage==0 - - -package dfi_bck dfi_stage==1 - - -package dfi_fwd dfi_stage==2 - - -package dfi_fst dfi_stage==3 - - -package dfi_startfwd dfi_stage==4 - - -package dfi_startbck dfi_stage==5 - - -package dfi_nodfi dfi_opt==0 - - -package dfi_dfl dfi_opt==1 - \ - state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC -package dfi_ddfi dfi_opt==2 - \ - state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC -package dfi_tdfi dfi_opt==3 - \ - state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC - -package albsi_zero seaice_albedo_opt==0 - - -package albsi_one seaice_albedo_opt==1 - - -package albsi_two seaice_albedo_opt==2 - state:albsi -package snowsi_zero seaice_snowdepth_opt==0 - - -package snowsi_one seaice_snowdepth_opt==1 - state:snowsi -package icedepth_zero seaice_thickness_opt==0 - - -package icedepth_one seaice_thickness_opt==1 - state:icedepth - -# only need to specify these once; not for every io_form* variable -package io_intio io_form_restart==1 - - -package io_netcdf io_form_restart==2 - - -# Placeholders for additional packages (we can go beyond zzz -# but that will entail modifying frame/module_io.F and frame/md_calls.m4) -# Please note these are placeholders; HDF has not been implemented yet. -package io_hdf io_form_restart==3 - - -package io_phdf5 io_form_restart==4 - - -package io_grib1 io_form_restart==5 - - -package io_mcel io_form_restart==6 - - -package io_esmf io_form_restart==7 - - -package io_yyy io_form_restart==8 - - -package io_zzz io_form_restart==9 - - -package io_grib2 io_form_restart==10 - - -package io_pnetcdf io_form_restart==11 - - - -#lightning -package ltng_none lightning_option==0 - - -package ltng_crm_PR92w lightning_option==1 - - -package ltng_crm_PR92z lightning_option==2 - - -package ltng_cpm_PR92z lightning_option==11 - - - -#WRF Hydro -package no_wrfhydro wrf_hydro==0 - - -package wrfhydro wrf_hydro==1 - state:SOLDRAIN, SFCHEADRT, INFXSRT - - -## communications - -### 8. Edit the Registry file and create a halo-exchange for x_1. - -# NMM communications - -halo HALO_NMM_INIT_1 dyn_nmm 120:HBM2 -halo HALO_NMM_INIT_2 dyn_nmm 120:HBM3,VBM2,VBM3 -halo HALO_NMM_INIT_3 dyn_nmm 120:SM,SICE -halo HALO_NMM_INIT_4 dyn_nmm 120:DX_NMM,WPDAR -halo HALO_NMM_INIT_5 dyn_nmm 120:CPGFU,CURV,FCP -halo HALO_NMM_INIT_6 dyn_nmm 120:FDIV,FAD,F -halo HALO_NMM_INIT_7 dyn_nmm 120:DDMPU,DDMPV,GLAT -halo HALO_NMM_INIT_8 dyn_nmm 120:GLON,EPSR,TG -halo HALO_NMM_INIT_9 dyn_nmm 120:GFFC,SST,ALBASE -#halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV,IVGTYP -halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV -#halo HALO_NMM_INIT_11 dyn_nmm 120:ISLTYP,ISLOPE,VEGFRC -halo HALO_NMM_INIT_11 dyn_nmm 120:VEGFRC -halo HALO_NMM_INIT_12 dyn_nmm 120:DIV,OMGALF,PD,RES -halo HALO_NMM_INIT_13 dyn_nmm 120:FIS,T,U -halo HALO_NMM_INIT_14 dyn_nmm 120:V,Q,Q2,CHEM -halo HALO_NMM_INIT_15 dyn_nmm 120:CWM,TRAIN,TCUCN -halo HALO_NMM_INIT_15B dyn_nmm 120:moist,scalar -halo HALO_NMM_INIT_16 dyn_nmm 120:RSWIN,RSWOUT,TG -halo HALO_NMM_INIT_17 dyn_nmm 120:Z0,AKMS,CZEN -halo HALO_NMM_INIT_18 dyn_nmm 120:AKHS,THS,QSH -halo HALO_NMM_INIT_19 dyn_nmm 120:TWBS,QWBS,HBOT -halo HALO_NMM_INIT_20 dyn_nmm 120:CFRACL,THZ0,QZ0 -halo HALO_NMM_INIT_21 dyn_nmm 120:UZ0,VZ0,USTAR -halo HALO_NMM_INIT_22 dyn_nmm 120:HTOP,CFRACM,SNO -halo HALO_NMM_INIT_23 dyn_nmm 120:SI,CLDEFI,RF -halo HALO_NMM_INIT_24 dyn_nmm 120:CUPPT,CFRACH,SOILTB -halo HALO_NMM_INIT_25 dyn_nmm 120:SFCEXC,SMSTAV,SMSTOT -halo HALO_NMM_INIT_26 dyn_nmm 120:GRNFLX,PCTSNO,RLWIN -halo HALO_NMM_INIT_27 dyn_nmm 120:RADOT,CZMEAN,SIGT4 -halo HALO_NMM_INIT_28 dyn_nmm 120:SR -halo HALO_NMM_INIT_29 dyn_nmm 120:PREC,ACPREC,ACCLIQ -halo HALO_NMM_INIT_30 dyn_nmm 120:ACFRST,ACSNOW -halo HALO_NMM_INIT_31 dyn_nmm 120:ACSNOM,SSROFF,BGROFF -halo HALO_NMM_INIT_32 dyn_nmm 120:SFCSHX,SFCLHX,SUBSHX -halo HALO_NMM_INIT_33 dyn_nmm 120:SNOPCX,SFCUVX,SFCEVP -halo HALO_NMM_INIT_34 dyn_nmm 120:POTEVP,ASWIN,ASWOUT -halo HALO_NMM_INIT_35 dyn_nmm 120:ASWTOA,ALWIN,ALWOUT -halo HALO_NMM_INIT_36 dyn_nmm 120:ALWTOA,SMC,CMC -halo HALO_NMM_INIT_37 dyn_nmm 120:STC,SH2O,ALBEDO -halo HALO_NMM_INIT_38 dyn_nmm 120:PINT,Z,DWDT -halo HALO_NMM_INIT_39 dyn_nmm 120:TOLD,UOLD,VOLD - -#for HWRF: zhang increase halo width to fix feedback bug for HALO_NMM_A (24 => 48) -#for HWRF: zhang HALO_NMM_C (24 => 48), HALO_NMM_G (24 => 48), HALO_NMM_K (8 => 24) -halo HALO_NMM_A dyn_nmm 48:pd,t,u,v,q,cwm,dwdt,div;24:pint -halo HALO_NMM_A_3 dyn_nmm 24:moist,scalar -halo HALO_NMM_B dyn_nmm 24:div -halo HALO_NMM_C dyn_nmm 48:u,v -halo HALO_NMM_D dyn_nmm 48:pd -halo HALO_NMM_E dyn_nmm 24:petdt -halo HALO_NMM_F dyn_nmm 24:t,u,v -halo HALO_NMM_F1 dyn_nmm 80:pdslo -halo HALO_NMM_G dyn_nmm 48:u,v;24:z -halo HALO_NMM_H dyn_nmm 24:w -halo HALO_NMM_I dyn_nmm 48:q,q2,cwm,rrw -halo HALO_NMM_I_2 dyn_nmm 48:CHEM -halo HALO_NMM_I_3 dyn_nmm 48:moist,scalar -halo HALO_NMM_J dyn_nmm 8:pd,uz0,vz0,t,q,cwm -halo HALO_NMM_J_2 dyn_nmm 8:CHEM -halo HALO_NMM_J_3 dyn_nmm 8:moist,scalar -halo HALO_NMM_K dyn_nmm 24:q2;24:t,u,v,q,w,z -halo HALO_NMM_L dyn_nmm 8:pd,t,q,cwm,q2 -halo HALO_NMM_L_2 dyn_nmm 8:CHEM -halo HALO_NMM_L_3 dyn_nmm 8:moist,scalar -halo HALO_NMM_MG dyn_nmm 8:ht_gc -halo HALO_NMM_MG2 dyn_nmm 8:pd,psfc_out -halo HALO_NMM_MG3 dyn_nmm 8:p_gc - -halo HALO_NMM_TURBL_A dyn_nmm 8:uz0h,vz0h,hbm2 -halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt - -# following halos added for nesting purpose (gopal's doing): - -halo HALO_NMM_ZZ dyn_nmm 8:pdnest_b,unest_b,vnest_b,tnest_b,qnest_b,cwmnest_b,q2nest_b,pdnest_bt,unest_bt,vnest_bt,tnest_bt,qnest_bt,cwmnest_bt,q2nest_bt -halo HALO_NMM_TRACK dyn_nmm 120:sm,pdyn,mslp,sqws -halo HALO_NMM_TERRAIN_SMOOTH dyn_nmm 24:HRES_AVC -halo HALO_NMM_INTERP_DOWN1 dyn_nmm 120:sm,fis,t,u,v,q,q2,z3d,q3d,t3d,pd,albase,nmm_tsk,mxsnal,tg,islope,cmc,soiltb,vegfrc,sh2o,smc,stc,toposoil,xice,ivgtyp,isltyp,vegfra,sst,weasd,snowh,hlat,hlon,z0,landmask,cwm,ustar,ths,qsh,cldefi,pshltr,dwdt,acprec,thz0,qz0,uz0,vz0,htop,hbot,cuppt,rlwtt,rswtt,t_adj,f_ice,f_rain,f_rimef -halo HALO_NMM_FORCE_DOWN1 dyn_nmm 120:t,u,v,q,q2,cwm,z3d,q3d,t3d #,qv,qc,qr,qi,qs,qg -halo HALO_NMM_WEIGHTS dyn_nmm 48:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4 - -halo HALO_NMM_SAS_A dyn_nmm 24:uz0h,vz0h,hbm2 -halo HALO_NMM_SAS_B dyn_nmm 24:ducudt,dvcudt -halo HALO_TRACERS dyn_nmm 48:szj,s1z,spz,tcs - diff --git a/wrfv2_fire/Registry/Registry.NMM_HWRF b/wrfv2_fire/Registry/Registry.NMM_HWRF index 45b254f4..fe94da98 100644 --- a/wrfv2_fire/Registry/Registry.NMM_HWRF +++ b/wrfv2_fire/Registry/Registry.NMM_HWRF @@ -40,6 +40,7 @@ # include registry.dimspec +include registry.lake ############# rconfig integer ntracers namelist,physics 1 4 - @@ -115,6 +116,7 @@ state real t_gc ijg dyn_nmm 1 Z i1 "TT" state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" state real greenfrac_gc ijm dyn_nmm 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" state real albedo12m_gc ijm dyn_nmm 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real lai12m_gc ijm dyn_nmm 1 Z i1 "LAI12M" "monthly LAI" "m2/m2" state real soilcbot_gc ijs misc 1 Z i1 "SOILCBOT" "description" "units" state real soilctop_gc ijs misc 1 Z i1 "SOILCTOP" "description" "units" state real tmn_gc ij dyn_nmm 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" @@ -144,11 +146,52 @@ state real guessdtc - dyn_nmm 1 - irh "GUESSD state integer nrnd1 k dyn_nmm 1 - r "NRND1" +# +# For the Inlined NCEP Tracker +# + +state real track_stderr_m1 - dyn_nmm 1 - rh "track_stderr_m1" "Standard deviation of tracker centers one hour ago" "km" +state real track_stderr_m2 - dyn_nmm 1 - rh "track_stderr_m2" "Standard deviation of tracker centers two hours ago" "km" +state real track_stderr_m3 - dyn_nmm 1 - rh "track_stderr_m3" "Standard deviation of tracker centers three hours ago" "km" +state integer track_last_hour - dyn_nmm 1 - rh "track_last_hour" "Last completed forecast hour" "hours" +state integer tracker_fixes ij dyn_nmm 1 - rh "tracker_fixes" "Tracker fix information" "" +state real tracker_fixlon - dyn_nmm 1 - rh "tracker_fixlon" "Storm fix longitude according to inline NCEP tracker" "degrees" +state real tracker_fixlat - dyn_nmm 1 - rh "tracker_fixlat" "Storm fix latitude according to inline NCEP tracker" "degrees" +state integer tracker_ifix - dyn_nmm 1 - rh "tracker_ifix" "Storm fix i location (H grid)" "" +state integer tracker_jfix - dyn_nmm 1 - rh "tracker_jfix" "Storm fix j location (H grid)" "" +state logical tracker_havefix - dyn_nmm 1 - rh "tracker_havefix" "True = storm fix locations are valid" "" +state logical tracker_gave_up - dyn_nmm 1 - rh "tracker_gave_up" "True = inline tracker gave up on tracking the storm" "" + +state real membrane_mslp ij dyn_nmm 1 - rh "membrane_mslp" "Mean Sea Level Pressure using UPP Membrane MSLP method" "Pa" +state real relaxwork ij dyn_nmm 1 - r "relaxwork" "Temporary Tv storage array for the membrane MSLP overrelaxation loops" "K" +state integer relaximask ij dyn_nmm 1 - r "relaximask" "Integer mask array for the membrane MSLP overrelaxation loops" "K" +state logical relaxmask ij dyn_nmm 1 - r "relaxmask" "Mask array for the membrane MSLP overrelaxation loops" "K" + +state real p850rv ij dyn_nmm 1 - rh "P850rv" "Relative vorticity at 850mbar mass points" "s^-1" +state real p700rv ij dyn_nmm 1 - rh "P700rv" "Relative vorticity at 700mbar mass points" "s^-1" +state real p850wind ij dyn_nmm 1 - rh "P850wind" "Wind magnitude at 850mbar mass points" "m/s" +state real p700wind ij dyn_nmm 1 - rh "P700wind" "Wind magnitude at 700mbar mass points" "m/s" +state real p850z ij dyn_nmm 1 - rh "P850z" "Height at 850mbar mass points" "m" +state real p700z ij dyn_nmm 1 - rh "P700z" "Height at 700mbar mass points" "m" +state real m10wind ij dyn_nmm 1 - rh "m10wind" "Wind magnitude at 10m mass points" "m/s" +state real m10rv ij dyn_nmm 1 - rh "m10rv" "Relative vorticity at 10m mass points" "m/s" + +state real sp850rv ij dyn_nmm 1 - rh "sP850rv" "Smoothed relative vorticity at 850mbar mass points" "s^-1" +state real sp700rv ij dyn_nmm 1 - rh "sP700rv" "Smoothed relative vorticity at 700mbar mass points" "s^-1" +state real sp850wind ij dyn_nmm 1 - rh "sP850wind" "Smoothed wind magnitude at 850mbar mass points" "m/s" +state real sp700wind ij dyn_nmm 1 - rh "sP700wind" "Smoothed wind magnitude at 700mbar mass points" "m/s" +state real sp850z ij dyn_nmm 1 - rh "sP850z" "Smoothed height at 850mbar mass points" "m" +state real sp700z ij dyn_nmm 1 - rh "sP700z" "Smoothed height at 700mbar mass points" "m" +state real sm10wind ij dyn_nmm 1 - rh "sm10wind" "Smoothed wind magnitude at 10m mass points" "m/s" +state real sm10rv ij dyn_nmm 1 - rh "sm10rv" "Smoothed relative vorticity at 10m mass points" "m/s" + +state real smslp ij dyn_nmm 1 - rh "smslp" "Smoothed membrane_mslp" "Pa" + # # For the moving nest. This is gopal's doing # -state real pdyn ij dyn_nmm 1 - rh "PDYN" "DYNAMIC PRESSURE USED FOR TRACKING GRID MOTION" +state real pdyn ij dyn_nmm 1 - rh "PDYN" "Dynamic pressure at mean sea level" state real mslp ij dyn_nmm 1 - rh "MSLP" "MSLP USED TO DETERMINE STORM LOCATION" state real sqws ij dyn_nmm 1 - r "SQWS" "SQUARE OF WIND SPEED AT LEVEL 10" state integer xloc - dyn_nmm 2 - r "XLOC" "I-LOCATION OF MINIMUM DYNAMIC PRESSURE" @@ -175,40 +218,42 @@ state real random ij dyn_nmm 1 - rh "random" "random # Location of the SOUTH-WEST nested pointed in terms of parent grid -state integer IIH ij dyn_nmm 1 - rh -state integer JJH ij dyn_nmm 1 - rh -state integer IIV ij dyn_nmm 1 - rh -state integer JJV ij dyn_nmm 1 - rh +state integer IIH ij dyn_nmm 1 - r +state integer JJH ij dyn_nmm 1 - r +state integer IIV ij dyn_nmm 1 - r +state integer JJV ij dyn_nmm 1 - r # Location of nearest parent point: -state integer hnear_i ij dyn_nmm 1 - rh "HNEAR_I" "I index of nearest parent point on H grid" -state integer hnear_j ij dyn_nmm 1 - rh "HNEAR_J" "J index of nearest parent point on H grid" +state integer hnear_i ij dyn_nmm 1 - r "HNEAR_I" "I index of nearest parent point on H grid" +state integer hnear_j ij dyn_nmm 1 - r "HNEAR_J" "J index of nearest parent point on H grid" # Bi-linear weights -state real HBWGT1 ij dyn_nmm 1 - rh -state real HBWGT2 ij dyn_nmm 1 - rh -state real HBWGT3 ij dyn_nmm 1 - rh -state real HBWGT4 ij dyn_nmm 1 - rh -state real VBWGT1 ij dyn_nmm 1 - rh -state real VBWGT2 ij dyn_nmm 1 - rh -state real VBWGT3 ij dyn_nmm 1 - rh -state real VBWGT4 ij dyn_nmm 1 - rh +state real HBWGT1 ij dyn_nmm 1 - r +state real HBWGT2 ij dyn_nmm 1 - r +state real HBWGT3 ij dyn_nmm 1 - r +state real HBWGT4 ij dyn_nmm 1 - r +state real VBWGT1 ij dyn_nmm 1 - r +state real VBWGT2 ij dyn_nmm 1 - r +state real VBWGT3 ij dyn_nmm 1 - r +state real VBWGT4 ij dyn_nmm 1 - r #end of HWRF: # -state real HLON ij dyn_nmm 1 - h01d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) -state real HLAT ij dyn_nmm 1 - h01d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) +state real HLON ij dyn_nmm 1 - h01 +state real HLAT ij dyn_nmm 1 - h01 state real VLON ij dyn_nmm 1 - irh state real VLAT ij dyn_nmm 1 - irh state integer hifreq_lun - dyn_nmm 0 - - +# Projection south and west bounds for Post: +rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain in rotated coordinates" +rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain in rotated coordinates" +state real wbd0var - dyn_nmm 0 - h "wbd0var" "western boundary of the domain in rotated coordinates" +state real sbd0var - dyn_nmm 0 - h "sbd0var" "southern boundary of the domain in rotated coordinates" -# -rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain" -rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain" #for HWRF: rconfig logical analysis namelist,time_control max_domains .false. irh "analysis flag" "analysis control for the nested domain" rconfig logical write_analysis namelist,time_control max_domains .true. irh "analysis output flag" "if analysis=F and write_analysis=T then analysis file is written" @@ -231,22 +276,22 @@ state real hbm2 ij dyn_nmm 1 - irh "HBM2" "Heig state real hbm3 ij dyn_nmm 1 - irh "HBM3" "Height boundary mask; =0 outer 3 rows on H points" "" state real vbm2 ij dyn_nmm 1 - irh "VBM2" "Velocity boundary mask; =0 outer 2 rows on V points" "" state real vbm3 ij dyn_nmm 1 - irh "VBM3" "Velocity boundary mask; =0 outer 3 rows on V points" "" -state real sm ij dyn_nmm 1 - i01rhd=(DownNear) "SM" "Sea mask; =1 for sea, =0 for land" "" -state real sice ij dyn_nmm 1 - irhd=(DownNear) "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" +state real sm ij dyn_nmm 1 - i01rh02d=(DownNear) "SM" "Sea mask; =1 for sea, =0 for land" "" +state real sice ij dyn_nmm 1 - irh02d=(DownNear) "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" # # module_VRBLS # state integer ntsd - dyn_nmm - - rh "NTSD" "Number of timesteps done" "" state integer nstart_hour - dyn_nmm - - r "NSTART_HOUR" "Forecast hour at start of integration" "" -state real pd ijb dyn_nmm 1 - i01rhu=(NoInterp)d=(NoInterp)f=(NoInterp) "PD" "Mass at I,J in the sigma domain" "Pa" -state real fis ij dyn_nmm 1 - i01rhu=(NoInterp)d=(NoInterp)f=(NoInterp) "FIS" "Surface geopotential" "m2 s-2" +state real pd ijb dyn_nmm 1 - i01rh02u=(NoInterp)d=(NoInterp)f=(NoInterp) "PD" "Mass at I,J in the sigma domain" "Pa" +state real fis ij dyn_nmm 1 - i01rh02u=(NoInterp)d=(NoInterp)f=(NoInterp) "FIS" "Surface geopotential" "m2 s-2" state real res ij dyn_nmm 1 - irh "RES" "Reciprocal of surface sigma" "" -state real t ijkb dyn_nmm 1 - i01rhu=(NoInterp)d=(NoInterp)f=(NoInterp) "T" "Sensible temperature" "K" -state real q ijkb dyn_nmm 1 - i01rhu=(NoInterp)d=(NoInterp)f=(NoInterp) "Q" "Specific humidity" "kg kg-1" +state real t ijkb dyn_nmm 1 - i01rh02u=(NoInterp)d=(NoInterp)f=(NoInterp) "T" "Sensible temperature" "K" +state real q ijkb dyn_nmm 1 - i01rh02u=(NoInterp)d=(NoInterp)f=(NoInterp) "Q" "Specific humidity" "kg kg-1" state real test_vgrid ij dyn_nmm 1 v - "test_vgrid" "Testing V grid staggering" "gibbletrons" -state real u ijkb dyn_nmm 1 v i01rhu=(UpVel)d=(DownVel)f=(BdyVel) "U" "U component of wind" "m s-1" -state real v ijkb dyn_nmm 1 v i01rhu=(UpVel)d=(DownVel)f=(BdyVel) "V" "V component of wind" "m s-1" +state real u ijkb dyn_nmm 1 v i01rh02u=(UpVel)d=(DownVel)f=(BdyVel) "U" "U component of wind" "m s-1" +state real v ijkb dyn_nmm 1 v i01rh02u=(UpVel)d=(DownVel)f=(BdyVel) "V" "V component of wind" "m s-1" state real told ijk dyn_nmm 1 - r "TOLD" "T from previous timestep" "K" state real uold ijk dyn_nmm 1 - r "UOLD" "U from previous timestep" "m s-1" state real vold ijk dyn_nmm 1 - r "VOLD" "V from previous timestep" "m s-1" @@ -281,7 +326,7 @@ state real dfi_SNOWC ij misc 1 - r "dfi_SNOWC # # module_DYNAM # -state real dx_nmm ij dyn_nmm 1 - irh "DX_NMM" "East-west distance H-to-V points" "m" +state real dx_nmm ij dyn_nmm 1 - irh02 "DX_NMM" "East-west distance H-to-V points" "m" state real wpdar ij dyn_nmm 1 - ir state real cpgfu ij dyn_nmm 1 - ir state real curv ij dyn_nmm 1 - ir "CURV" "Curvature term= .5*DT*TAN(phi)/RadEarth" "s m-1" @@ -297,12 +342,12 @@ state real aeta k dyn_nmm 1 - i01r state real f4q2 k dyn_nmm 1 - ir state real etax k dyn_nmm 1 - i01r state real dfl k dyn_nmm 1 Z i01r "DFL" "Standard atmosphere geopotential" "m2 s-2" -state real deta1 k dyn_nmm 1 - i01rh "DETA1" "Delta sigma in pressure domain" "" -state real aeta1 k dyn_nmm 1 - i01rh "AETA1" "Midlayer sigma value in pressure domain" "" -state real eta1 k dyn_nmm 1 Z i01rh "ETA1" "Interface sigma value in pressure domain" "" -state real deta2 k dyn_nmm 1 - i01rh "DETA2" "Delta sigma in sigma domain" "" -state real aeta2 k dyn_nmm 1 - i01rh "AETA2" "Midlayer sigma value in sigma domain" "" -state real eta2 k dyn_nmm 1 Z i01rh "ETA2" "Interface sigma value in sigma domain" "" +state real deta1 k dyn_nmm 1 - i01rh02 "DETA1" "Delta sigma in pressure domain" "" +state real aeta1 k dyn_nmm 1 - i01rh02 "AETA1" "Midlayer sigma value in pressure domain" "" +state real eta1 k dyn_nmm 1 Z i01rh02 "ETA1" "Interface sigma value in pressure domain" "" +state real deta2 k dyn_nmm 1 - i01rh02 "DETA2" "Delta sigma in sigma domain" "" +state real aeta2 k dyn_nmm 1 - i01rh02 "AETA2" "Midlayer sigma value in sigma domain" "" +state real eta2 k dyn_nmm 1 Z i01rh02 "ETA2" "Interface sigma value in sigma domain" "" state real em q dyn_nmm 1 - ir state real emt q dyn_nmm 1 - ir #for HWRF: add to restart @@ -312,7 +357,7 @@ state real adv ij dyn_nmm 1 - r "ADV" "Chan #end HWRF: state real em_loc q dyn_nmm 1 - r state real emt_loc q dyn_nmm 1 - r -state real dy_nmm - dyn_nmm - - ir "DY_NMM" "North-south distance H-to-V points" "m" +state real dy_nmm - dyn_nmm - - irh02 "DY_NMM" "North-south distance H-to-V points" "m" state real cpgfv - dyn_nmm - - ir state real en - dyn_nmm - - ir state real ent - dyn_nmm - - ir @@ -322,10 +367,10 @@ state real ef4t - dyn_nmm - - ir #for HWRF: add to restart state logical upstrm - dyn_nmm - - - "UPSTRM" ".TRUE. => In upstream advec region of grid" "" #end HWRF: -state real dlmd - dyn_nmm - - irh "DLMD" "East-west angular distance H-to-V points" "degrees" -state real dphd - dyn_nmm - - irh "DPHD" "North-south angular distance H-to-V points" "degrees" -state real pdtop - dyn_nmm - - i01rh "PDTOP" "Mass at I,J in pressure domain" "Pa" -state real pt - dyn_nmm - - i01rh "PT" "Pressure at top of domain" "Pa" +state real dlmd - dyn_nmm - - irh02 "DLMD" "East-west angular distance H-to-V points" "degrees" +state real dphd - dyn_nmm - - irh02 "DPHD" "North-south angular distance H-to-V points" "degrees" +state real pdtop - dyn_nmm - - i01rh02 "PDTOP" "Mass at I,J in pressure domain" "Pa" +state real pt - dyn_nmm - - i01rh02 "PT" "Pressure at top of domain" "Pa" # # module_CONTIN # @@ -354,7 +399,11 @@ state real pblh ij dyn_nmm 1 - rh "PBLH" "PBL Heig state integer lpbl ij dyn_nmm 1 - ir "LPBL" "Model layer of PBL top" "" state real mixht ij dyn_nmm 1 - rh "MIXHT" "MXL HEIGHT" "m" state real ustar ij dyn_nmm 1 - irhd=(DownNear) "USTAR" "Friction velocity" "m s-1" -state real z0 ij dyn_nmm 1 - i01rhd=(DownNear) "Z0" "Roughness height" "m" +state real z0 ij dyn_nmm 1 - i01rhd=(DownNear) "Z0" "Thermal Roughness length" "m" +state real mz0 ij dyn_nmm 1 - h "MZ0" "momentum Roughness length" "m" +state real rc2d ij dyn_nmm 1 - h "RC2D" "critical Richardson number" "m" +state real dku3d ijk dyn_nmm 1 - h "DKU3D" "Momentum Diffusivity" "m*m/s" +state real dkt3d ijk dyn_nmm 1 - h "DKT3D" "Thermal Diffusivity" "m*m/s" state real hpbl2d ij dyn_nmm 1 - irh "HPBL2D" "HEIGHT OF PBL from new GFS pbl" "m" state real heat2d ij dyn_nmm 1 - irh "HEAT2D" "" "" state real evap2d ij dyn_nmm 1 - irh "EVAP2D" "" "" @@ -373,7 +422,7 @@ state real cuprec ij dyn_nmm 1 - rh "CUPREC" "Accumula state real lspa ij dyn_nmm 1 - h "LSPA" "Land Surface Precipitation Accumulation" "kg m-2" state real ddata ij dyn_nmm 1 - - "DDATA" "Observed precip to each physics timestep" "kg m-2" state real accliq ij dyn_nmm 1 - r -state real sno ij dyn_nmm 1 - irh "SNO" "Liquid water eqiv of snow on ground" "kg m-2" +state real sno ij dyn_nmm 1 - irh02 "SNO" "Liquid water eqiv of snow on ground" "kg m-2" state real si ij dyn_nmm 1 - irh "SI" "Depth of snow on ground" "mm" state real cldefi ij dyn_nmm 1 - rhd=(DownCopy) "CLDEFI" "Convective cloud efficiency" "" state real deep ij dyn_nmm 1 - r "DEEP" "Deep convection =>.TRUE." "" @@ -402,9 +451,9 @@ state real czmean ij dyn_nmm 1 - irh "CZMEAN" "Mean CZ state real embck ij dyn_nmm 1 - ir "EMBCK" "Background radiative emissivity" "" state real epsr ij dyn_nmm 1 - irh "EPSR" "Radiative emissivity" "" state real gffc ij dyn_nmm 1 - ir -state real glat ij dyn_nmm 1 - i01rh "GLAT" "Geographic latitude, radians" "" -state real glon ij dyn_nmm 1 - i01rh "GLON" "Geographic longitude, radians" "" -state real NMM_TSK ij dyn_nmm 1 - i01rd=(DownNear) "TSK" "Skin temperature" "K" +state real glat ij dyn_nmm 1 - i01rh02 "GLAT" "Geographic latitude, radians" "" +state real glon ij dyn_nmm 1 - i01rh02 "GLON" "Geographic longitude, radians" "" +state real NMM_TSK ij dyn_nmm 1 - i01rh02d=(DownNear) "TSK" "Skin temperature" "K" state real hdac ij dyn_nmm 1 - ir "HDAC" "Composite diffusion coeff for mass points" "s m-1" state real hdacv ij dyn_nmm 1 - ir "HDACV" "Composite diffusion coeff for velocity points" "s m-1" state real mxsnal ij dyn_nmm 1 - i01rhd=(DownNear) "MXSNAL" "Maximum deep snow albedo" "" @@ -423,14 +472,89 @@ state real GD_CLOUD ikj misc 1 - r "GD_CLOUD" "CLOUD WA state real GD_CLOUD2 ikj misc 1 - r "GD_CLOUD2" "TEST for GD CLOUD" "kg kg-1" state real GD_CLOUD_A ikj misc 1 - r "GD_CLOUD_A" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" state real GD_CLOUD2_A ikj misc 1 - r "GD_CLOUD2_A" "taveragd cloud ice mix ratio in GD" "kg kg-1" -state real GD_CLOUD_B ikj misc 1 - r "GD_CLOUD_B" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2_B ikj misc 1 - r "GD_CLOUD2_B" "taveragd cloud ice mix ratio in GD" "kg kg-1" +state real QC_CU ikj misc 1 - r "QC_CU" "CLOUD WATER MIXING RATIO FROM A CU SCHEME" "kg kg-1" +state real QI_CU ikj misc 1 - r "QI_CU" "CLOUD ICE MIXUNG RATIO FROM A CU SCHEME" "kg kg-1" state real GD_CLDFR ikj misc 1 - r "GD_CLDFR" "GD CLOUD Fraction" " ? " +# upward and downward clearsky and total diagnostic fluxes for radiation (RRTMG) +state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWUPTC ij misc 1 - rhdu "ACSWUPTC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWDNT ij misc 1 - rhdu "ACSWDNT" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWDNTC ij misc 1 - rhdu "ACSWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWUPB ij misc 1 - rhdu "ACSWUPB" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACSWUPBC ij misc 1 - rhdu "ACSWUPBC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACSWDNB ij misc 1 - rhdu "ACSWDNB" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACSWDNBC ij misc 1 - rhdu "ACSWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWUPT ij misc 1 - rhdu "ACLWUPT" "ACCUMULATED UPWELLING LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWUPTC ij misc 1 - rhdu "ACLWUPTC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWDNT ij misc 1 - rhdu "ACLWDNT" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWDNTC ij misc 1 - rhdu "ACLWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWUPB ij misc 1 - rhdu "ACLWUPB" "ACCUMULATED UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWUPBC ij misc 1 - rhdu "ACLWUPBC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWDNB ij misc 1 - rhdu "ACLWDNB" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWDNBC ij misc 1 - rhdu "ACLWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +state real SWUPT ij misc 1 - rhdu "SWUPT" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real SWUPTC ij misc 1 - rhdu "SWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" +state real SWDNT ij misc 1 - rhdu "SWDNT" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real SWDNTC ij misc 1 - rhdu "SWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" +state real SWUPB ij misc 1 - rhdu "SWUPB" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWUPBC ij misc 1 - rhdu "SWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWDNB ij misc 1 - rhdu "SWDNB" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWDNBC ij misc 1 - rhdu "SWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real LWUPT ij misc 1 - rhdu "LWUPT" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP" "W m-2" +state real LWUPTC ij misc 1 - rhdu "LWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2" +state real LWDNT ij misc 1 - rhdu "LWDNT" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP" "W m-2" +state real LWDNTC ij misc 1 - rhdu "LWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2" +state real LWUPB ij misc 1 - rhdu "LWUPB" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" +state real LWUPBC ij misc 1 - rhdu "LWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2" +state real LWDNB ij misc 1 - rhdu "LWDNB" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" +state real LWDNBC ij misc 1 - rhdu "LWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "Wm-2" +state real SWVISDIR ij misc 1 Z r "SWVISDIR" "SWR VIS DIR component" "" +state real SWVISDIF ij misc 1 Z r "SWVISDIF" "SWR VIS DIF component" "" +state real SWNIRDIR ij misc 1 Z r "SWNIRDIR" "SWR NIR DIR component" "" +state real SWNIRDIF ij misc 1 Z r "SWNIRDIF" "SWR NIR DIF component" "" + +state real refl_10cm ikj dyn_nmm 1 - h "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" +state real REFD_MAX ij misc 1 - h "REFD_MAX" "MAX DERIVED RADAR REFL" "dbZ" +state real qnwfa2d ij misc 1 - rhdu "QNWFA2D" "Surface aerosol number conc emission" "kg-1 s-1" +state real re_cloud ikj misc 1 - r "re_cloud" "Effective radius, cloud drops" "m" +state real re_ice ikj misc 1 - r "re_ice" "Effective radius, cloud ice" "m" +state real re_snow ikj misc 1 - r "re_snow" "Effective radius, snow" "m" +state real dfi_re_cloud ikj misc 1 - - "DFI_RE_CLOUD" "DFI Effective radius cloud water" "m" +state real dfi_re_ice ikj misc 1 - - "DFI_RE_ICE" "DFI Effective radius cloud ice" "m" +state real dfi_re_snow ikj misc 1 - - "DFI_RE_SNOW" "DFI Effective radius snow" "m" +state integer has_reqc - misc 1 - r "has_reqc" "Flag for has effective radius of cloud water" "" +state integer has_reqi - misc 1 - r "has_reqi" "Flag for has effective radius of cloud ice" "" +state integer has_reqs - misc 1 - r "has_reqs" "Flag for has effective radius of snow" "" # +# added WRF-Solar +state real swddir ij misc 1 - rhd "SWDDIR" "Shortwave surface downward direct irradiance" "W/m^2" "" +state real swddni ij misc 1 - rhd "SWDDNI" "Shortwave surface downward direct normal irradiance" "W/m^2" "" +state real swddif ij misc 1 - rhd "SWDDIF" "Shortwave surface downward diffuse irradiance" "W/m^2" "" +state real Gx ij misc 1 - rd "Gx" "" "" +state real Bx ij misc 1 - rd "Bx" "" "" +state real gg ij misc 1 - rd "gg" "" "" +state real bb ij misc 1 - rd "bb" "" "" +state real coszen_ref ij misc 1 - - "coszen_ref" "" "" +state real coszen ij misc 1 - - "coszen " "" "" +state real hrang ij misc 1 - - "hrang" "" "" +state real swdown_ref ij misc 1 - - "swdown_ref" "" "" +state real swddir_ref ij misc 1 - - "swddir_ref" "" "" +rconfig integer swint_opt namelist,physics 1 0 - "swint_opt" "interpolation option for sw radiation" "" +# add aerosol namelists +rconfig integer aer_type namelist,physics max_domains 1 irh "aer_type" "aerosol type: 1 is SF79 rural, 2 is SF79 urban" "" +rconfig integer aer_aod550_opt namelist,physics max_domains 1 irh "aer_aod550_opt" "input option for aerosol optical depth at 550 nm" "" +rconfig integer aer_angexp_opt namelist,physics max_domains 1 irh "aer_angexp_opt" "input option for aerosol Angstrom exponent" "" +rconfig integer aer_ssa_opt namelist,physics max_domains 1 irh "aer_ssa_opt" "input option for aerosol single-scattering albedo" "" +rconfig integer aer_asy_opt namelist,physics max_domains 1 irh "aer_asy_opt" "input option for aerosol asymmetry parameter" "" +rconfig real aer_aod550_val namelist,physics max_domains 0.12 irh "aer_aod550_val" "fixed value for aerosol optical depth at 550 nm. Valid when aer_aod550_opt=1" "" +rconfig real aer_angexp_val namelist,physics max_domains 1.3 irh "aer_angexp_val" "fixed value for aerosol Angstrom exponent. Valid when aer_angexp_opt=1" "" +rconfig real aer_ssa_val namelist,physics max_domains 0.85 irh "aer_ssa_val" "fixed value for aerosol single-scattering albedo. Valid when aer_ssa_opt=1" "" +rconfig real aer_asy_val namelist,physics max_domains 0.90 irh "aer_asy_val" "fixed value for aerosol asymmetry parameter. Valid when aer_asy_opt=1" "" + # module_CLDWTR.F # -state real cwm ijkb dyn_nmm 1 - rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "CWM" "Total condensate" "kg kg-1" +state real cwm ijkb dyn_nmm 1 - rh02u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "CWM" "Total condensate" "kg kg-1" state real rrw ijkb dyn_nmm 1 - rh "RRW" "Tracer" "kg kg-1" state real f_ice ikj dyn_nmm 1 - rhd=(DownMassIKJ:@EExtrap,0.0)u=(UpMassIKJ:@EExtrap,0.0) "F_ICE" "Frozen fraction of CWM" "" state real f_rain ikj dyn_nmm 1 - rhd=(DownMassIKJ:@EExtrap,0.0)u=(UpMassIKJ:@EExtrap,0.0) "F_RAIN" "Rain fraction of liquid part of CWM" "" @@ -452,12 +576,12 @@ state real cmc ij dyn_nmm 1 - i01rhd=(DownNear) "CMC" state real grnflx ij dyn_nmm 1 - irh "GRNFLX" "Deep soil heat flux" "W m-2" state real pctsno ij dyn_nmm 1 - irh state real soiltb ij dyn_nmm 1 - i01rhd=(DownNear) "SOILTB" "Deep ground soil temperature" "K" -state real vegfrc ij dyn_nmm 1 - i014rhd=(DownNear) "VEGFRC" "Vegetation fraction" "" +state real vegfrc ij dyn_nmm 1 - i014rh02d=(DownNear) "VEGFRC" "Vegetation fraction" "" state real shdmin ij dyn_nmm 1 - - state real shdmax ij dyn_nmm 1 - - state real sh2o ilj dyn_nmm 1 Z irhd=(DownNearIKJ) "SH2O" "Unfrozen soil moisture volume fraction" "" -state real smc ilj dyn_nmm 1 Z irhd=(DownNearIKJ) "SMC" "Soil moisture volume fraction" "" -state real stc ilj dyn_nmm 1 Z irhd=(DownNearIKJ) "STC" "Soil temperature" "K" +state real smc ilj dyn_nmm 1 Z irh02d=(DownNearIKJ) "SMC" "Soil moisture volume fraction" "" +state real stc ilj dyn_nmm 1 Z irh02d=(DownNearIKJ) "STC" "Soil temperature" "K" # # module_GWD.F # @@ -493,10 +617,10 @@ state real dwdtmx ij dyn_nmm 1 - - "DWDTMX" "Maximum state real baro ij dyn_nmm 1 - - "BARO" "external mode vvel" "m s-1" state real dwdt ijk dyn_nmm 1 - rd=(DownCopy) "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" state real pdwdt ijk dyn_nmm 1 - r -state real pint ijk dyn_nmm 1 Z irhd=(DownCopy)u=(NoInterp)f=(NoInterp) "PINT" "Model layer interface pressure" "Pa" +state real pint ijk dyn_nmm 1 Z irh02d=(DownCopy)u=(NoInterp)f=(NoInterp) "PINT" "Model layer interface pressure" "Pa" state real w ijk dyn_nmm 1 Z rd=(DownCopy) "W" "Vertical velocity" "m s-1" state real w_tot ijk dyn_nmm 1 Z hd=(DownCopy) "W" "Vertical velocity" "m s-1" -state real z ijk dyn_nmm 1 Z - "Z" "Distance from ground" "m" +state real z ijk dyn_nmm 1 Z hd=(DownCopy) "Z" "Distance from ground" "m" # # module_ACCUM.F # @@ -580,16 +704,30 @@ state integer iup_adh ij dyn_nmm 1 - - state integer iup_adv ij dyn_nmm 1 - - state integer imicrogram - misc - - r "imicrogram" "flag 0/1 0=mixratio, 1=mcrograms/m3" "" -# -# Vortex Tracker #4 Variables -# -state real distsq ij dyn_nmm 1 - irh "DISTSQ" "Approximate square of distance from nest center for vortex tracker #4" "m2" -state real weightout ij dyn_nmm 1 - irh "WEIGHTOUT" "Vortex center finder weight array for vortex tracker #4" "" -state integer mslp_noisy ij dyn_nmm 1 - irh "MSLP_NOISY" "0=okay, 1=noisy MSLP, 2=outside search radius, 3=boundary (vortex tracker #4)" "" +# Vortex Tracker Variables + +# Revised Centroid Method (tracker #4) +state real distsq ij dyn_nmm 1 - rh "DISTSQ" "Approximate square of distance from nest center for vortex tracker #4" "m2" +state real weightout ij dyn_nmm 1 - rh "WEIGHTOUT" "Vortex center finder weight array for vortex tracker #4" "" +state integer mslp_noisy ij dyn_nmm 1 - rh "MSLP_NOISY" "0=okay, 1=noisy MSLP, 2=outside search radius, 3=boundary (vortex tracker #4)" "" + +# Dynamic Pressure Method (tracker #5) +state real vt5searchrad - dyn_nmm 1 - rh "vt5searchrad" "Search radius from domain center" "m" + +# Smoothed Dynamic Pressure (needed for #5, must be passed down by all) + +state integer pdyn_parent_age - dyn_nmm 1 - rh "PDYN_PARENT_AGE" "Last update of parent pdyn_parent propagated to this nest" "" +state integer pdyn_smooth_age - dyn_nmm 1 - rh "PDYN_SMOOTH_AGE" "Counter of updates of pdyn_smooth" "" +state real pdyn_smooth ij dyn_nmm 1 - rhd=(NoInterp)f=(NoInterp)u=(NoInterp) "PDYN_SMOOTH" "Average of PDYN and PDYN_PARENT" "Pa" +state real pdyn_parent ij dyn_nmm 1 - rhu=(NoInterp)\ +d=(DownAged2D:0,n%pdyn_parent_age,c%pdyn_smooth)\ +f=(DownAged2D:c%pdyn_smooth_age,n%pdyn_parent_age,c%pdyn_smooth)\ + "PDYN_PARENT" "Parent PDYN_SMOOTH for tracking grid motion" "Pa" + # Interpolation information -state real winfo ijkb dyn_nmm 1 Z hu=(NoInterp)d=(NoInterp) "winfo" "Nest-parent interpolation/extrapolation weight" "" -state integer iinfo ijkb dyn_nmm 1 Z hu=(NoInterp)d=(NoInterp) "iinfo" "Nest-parent interpolation index" "" +state real winfo ijkb dyn_nmm 1 Z u=(NoInterp)d=(NoInterp) "winfo" "Nest-parent interpolation/extrapolation weight" "" +state integer iinfo ijkb dyn_nmm 1 Z u=(NoInterp)d=(NoInterp) "iinfo" "Nest-parent interpolation index" "" # # table entries are of the form @@ -708,31 +846,39 @@ state real dfi_qnh ijkfbt dfi_moist 1 m r " # Other Scalars state real - ijkftb scalar 1 m - - state real qni ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNICE" "Ice Number concentration" "# kg(-1)" +state real qt ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QT" "Total condensate mixing ratio" "kg kg-1" state real qns ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNSNOW" "Snow Number concentration" "# kg(-1)" state real qnr ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNRAIN" "Rain Number concentration" "# kg(-1)" state real qng ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNGRAUP" "Graupel Number concentration" "# kg(-1)" state real qnh ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNHAIL" "Hail Number concentration" "# kg(-1)" state real qnn ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCCN" "CCN Number concentration" "# kg(-1)" state real qnc ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" +state real qvolg ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" +state real qnwfa ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" +state real qnifa ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" state real - ijkftb dfi_scalar 1 m - - state real dfi_qndrop ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNDROP" "Droplet number mixing ratio" "# kg-1" + rusdf=(bdy_interp:dt) "DFI_QNDROP" "DFI Droplet number mixing ratio" "# kg-1" state real dfi_qni ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNICE" "Ice Number concentration" "# kg-1" + rusdf=(bdy_interp:dt) "DFI_QNICE" "DFI Ice Number concentration" "# kg-1" state real dfi_qt ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_CWM" "Total condensate mixing ratio" "kg kg-1" + rusdf=(bdy_interp:dt) "DFI_CWM" "DFI Total condensate mixing ratio" "kg kg-1" state real dfi_qns ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNSNOW" "Snow Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNSNOW" "DFI Snow Number concentration" "# kg(-1)" state real dfi_qnr ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNRAIN" "Rain Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNRAIN" "DFI Rain Number concentration" "# kg(-1)" state real dfi_qng ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "DFI Graupel Number concentration" "# kg(-1)" state real dfi_qnn ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNCC" "CNN Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNCC" "DFI CNN Number concentration" "# kg(-1)" state real dfi_qnc ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "Cloud Number concentration" "# kg(-1)" + rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "DFI Cloud Number concentration" "# kg(-1)" +state real dfi_qnwfa ikjftb dfi_scalar 1 m \ + rusdf=(bdy_interp:dt) "DFI_QNWFA" "DFI water-friendly aerosol number con" "# kg(-1)" +state real dfi_qnifa ikjftb dfi_scalar 1 m \ + rusdf=(bdy_interp:dt) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" #----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -762,6 +908,7 @@ state real - ikjft chem 1 - - - state real SMOIS ilj - 1 Z rh "SMOIS" "SOIL MOISTURE" "" state real TSLB ilj - 1 Z r "TSLB" "SOIL TEMPERATURE" "" +state real lake_depth ij misc 1 - rd=(interp_mask_water_field:lu_index,iswater) "lake_depth" "lake depth" "m" # MYJ PBL variables @@ -836,9 +983,9 @@ state real SFCHEADRT ij misc 1 - r state real INFXSRT ij misc 1 - r "INFXSRT" "time step infiltration excess" "mm" state real SFCRUNOFF ij misc 1 - rh "SFROFF" "SURFACE RUNOFF" "" state real UDRUNOFF ij misc 1 - rh "UDROFF" "UNDERGROUND RUNOFF" "" -state integer IVGTYP ij misc 1 - irhd=(DownINear) "IVGTYP" "VEGETATION TYPE" "" -state integer ISLTYP ij misc 1 - irhd=(DownINear) "ISLTYP" "SOIL TYPE" " " -state real VEGFRA ij misc 1 - i014rhd=(DownNear) "VEGFRA" "VEGETATION FRACTION" "" +state integer IVGTYP ij misc 1 - irh02d=(DownINear) "IVGTYP" "VEGETATION TYPE" "" +state integer ISLTYP ij misc 1 - irh02d=(DownINear) "ISLTYP" "SOIL TYPE" " " +state real VEGFRA ij misc 1 - i014rh02d=(DownNear) "VEGFRA" "VEGETATION FRACTION" "" state real SFCEVP ij misc 1 - irh "SFCEVP" "SURFACE EVAPORATION" "" state real GRDFLX ij misc 1 - irh "GRDFLX" "GROUND HEAT FLUX" "" state real ALBBCK ij misc 1 - i0124r "ALBBCK" "BACKGROUND ALBEDO" "NA" @@ -850,7 +997,9 @@ state real RMOL ij misc 1 - ir "RM state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" state integer FORCE_SST k misc 1 - - "FORCE_SST" "IF FORCE_SST(1) IS 1, FEED SST FROM PARENT EVERY DT" "" -state real SST ij misc 1 - i014rhd=(DownNear)f=(force_sst_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,FORCE_SST) "SST" "SEA SURFACE TEMPERATURE" "K" +state real SST ij misc 1 - i014rh02d=(DownNear)f=(force_sst_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,FORCE_SST) "SST" "SEA SURFACE TEMPERATURE" "K" +state real UOCE ij misc 1 - i014rh "UOCE" "SEA SURFACE ZONAL CURRENTS" "m s-1" +state real VOCE ij misc 1 - i014rh "VOCE" "SEA SURFACE MERIDIONAL CURRENTS" "m s-1" state real WEASD ij misc 1 - i01rhd=(DownNear) "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "kg m-2" state real ZNT ij misc 1 - irh "ZNT" "TIME-VARYING ROUGHNESS LENGTH" state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" @@ -1016,6 +1165,10 @@ state real chucxy ij - 1 - i02rhd=(interp_mask_land state real chv2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv2" "leaf exchange coefficient" "m/s" state real chb2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb2" "under canopy exchange coefficient" "m/s" state real chstarxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chstar" "dummy exchange coefficient" "m/s" +state real SMOISEQ ilj - 1 Z r "SMOISEQ" "EQ. SOIL MOISTURE" "m3 m-3" +state real smcwtdxy ij - 1 - rh "smcwtd" "deep soil moisture " "m3 m-3" +state real rechxy ij - 1 - h "rech" "water table recharge" "mm" +state real deeprechxy ij - 1 - r "deeprech" "deep water table recharge" "mm" # added state for etampnew microphysics (needed for restarts) state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" @@ -1035,6 +1188,7 @@ state real lu_state p misc - - - # state integer number_at_same_level - - - - - "number_at_same_level" "" "" +state real power ij misc 1 - irh "Power" "Power production" "W" # State for derived time quantities. #for HWRF: add to restart @@ -1198,19 +1352,22 @@ rconfig integer mp_physics namelist,physics max_domains 0 rconfig real mommix namelist,physics max_domains 0.7 irh "MOMENTUM MIXING FOR SAS CONVECTION SCHEME" rconfig logical disheat namelist,physics max_domains .true. irh "nmm input 7" #end HWRF: +rconfig integer do_radar_ref namelist,physics 1 0 rh "compute radar reflectivity for a number of schemes" rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig integer windfarm_opt namelist,physics max_domains 0 rh "windfarm_opt" "" "" +rconfig integer windfarm_ij namelist,physics 1 0 rh "windfarm_ij" "" "" rconfig integer mfshconv namelist,physics max_domains 1 rh "mfshconv" "To activate mass flux scheme with qnse, 1=true; 0=false" "" rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" rconfig integer shcu_physics namelist,physics max_domains 0 rh "shcu_physics" "" "" rconfig integer cu_diag namelist,physics max_domains 0 rh "cu_diag" " additional t-averaged stuff for cuphys" "" -rconfig integer vortex_tracker namelist,physics max_domains 1 - "vortex_tracker" "Vortex Tracking Algorithm" "" +rconfig integer vortex_tracker namelist,physics max_domains 6 - "vortex_tracker" "Vortex Tracking Algorithm" "" rconfig real gfs_alpha namelist,physics max_domains 1 irh "boundary depth factor" "" "" rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" @@ -1222,6 +1379,9 @@ rconfig real swrad_scat namelist,physics 1 1 rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" rconfig integer num_urban_layers namelist,physics 1 400 irh "num_urban_layers" "" "" +rconfig integer sf_surface_mosaic namelist,physics 1 0 rh "sf_surface_mosaic" "1= mosaic, 0=no mosaic method, add by danli" "" +rconfig integer mosaic_cat namelist,physics 1 3 rh "mosaic_cat" "works when sf_surface_mosaic=1; it is the number of mosaic tiles" "" +rconfig integer mosaic_cat_soil derived 1 12 rh "mosaic_cat_soil" "should be the number of soil layers times the mosaic_cat" "" rconfig integer num_urban_hi namelist,physics 1 15 irh "num_urban_hi" "" "" rconfig integer mosaic_lu namelist,physics 1 0 irh "mosaic_lu" "" "" rconfig integer mosaic_soil namelist,physics 1 0 irh "mosaic_soil" "" "" @@ -1236,7 +1396,7 @@ rconfig integer num_soil_cat namelist,physics 1 16 rconfig integer topo_wind namelist,physics max_domains 0 - "topo_wind" "2: Use Mass sfc drag scheme, 1: improve effects topography over surface wind, 0:not" "" rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" -rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig real seaice_threshold namelist,physics 1 100 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seiace" "Fractional sea-ice option" rconfig integer seaice_albedo_opt namelist,physics 1 0 - "seaice_albedo_opt" "Method for setting albedo over sea ice" rconfig real seaice_albedo_default namelist,physics 1 0.65 - "seaice_albedo_default" "Default value for sea-ice over albedo with seaice_albeo_opt=0" @@ -1258,8 +1418,12 @@ rconfig real sas_pgcon namelist,physics max_domains 0.5 rconfig real sas_shal_pgcon namelist,physics max_domains -1 irh "sas_shal_pgcon" "convectively forced pressure gradient factor, -1 means use sas_pgcon (SAS shallow conv)" "" rconfig integer sas_shal_conv namelist,physics max_domains 1 - "sas_shal_conv" "1=enable shallow convection in SAS (must use bl_pbl_physics=83)" rconfig real sas_mass_flux namelist,physics max_domains 9e9 - "sas_mass_flux" "mass flux limit (SAS scheme)" "" +rconfig real var_ric namelist,physics 1 1. - "1: use variable Ric 0: constant Ric" +rconfig real coef_ric_l namelist,physics 1 0.16 - "Regression coeff for Ric 0.16:origianl value over land" +rconfig real coef_ric_s namelist,physics 1 0.16 - "Regression coeff for Ric 0.16:origianl value OVER SEA" rconfig integer random_seed namelist,physics max_domains 0 irh "random_seed" "random number generator seed" + # Vortex Tracking (physics namelist) rconfig integer vortex_tracker namelist,physics max_domains 1 - "vortex_tracker" "Vortex Tracking Algorithm" "" # Only for algorithm 4: @@ -1272,6 +1436,7 @@ rconfig real vt4_noise_pmin namelist,physics max_domains 850 rconfig real vt4_noise_dpdr namelist,physics max_domains 0.6 - "vt4_noise_dpdr" "Noise Removal: Maximum Realistic dMSLP/dr" "Pa/m" rconfig integer vt4_noise_iter namelist,physics max_domains 2 - "vt4_noise_iter" "Noise Removal: number of iterations" "" + # nmm variables rconfig integer idtad namelist,physics max_domains 2 irh "idtad" "fundamental timesteps between calls to NMM passive advection scheme" rconfig integer nsoil namelist,physics max_domains 4 irh "nsoil" "number of soil layers" @@ -1300,12 +1465,16 @@ rconfig integer no_src_types namelist,physics 1 1 rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" rconfig integer o3input namelist,physics 1 0 - "o3input" "ozone input option for radiation" "" rconfig integer aer_opt namelist,physics 1 0 - "aer_opt" "aerosol input option for radiation" "" -rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" "" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback of cumulus cloud to radiation" +rconfig integer ICLOUD_CU derived 1 0 - "ICLOUD_CU" "" "" rconfig real h_diff namelist,physics max_domains 0.1 irh "nmm input 9" rconfig integer movemin namelist,physics max_domains 10 irh "movemin" "nest movement timestep (multiples of nphs)" rconfig real nomove_freq namelist,physics max_domains -1.0 irh "nomove_freq" "nest will not move at analysis time or multiples of this hour (if positive)" rconfig integer num_snso_layers namelist,physics 1 7 irh "num_snso_layers" "" "" rconfig integer num_snow_layers namelist,physics 1 3 irh "num_snow_layers" "" "" +rconfig logical use_aero_icbc namelist,physics 1 .false. rh "use_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero" "logical flag" +rconfig integer sf_lake_physics namelist,physics max_domains 0 h "sf_lake_physics" "activate lake model 0=no, 1=yes" "" + # Dynamics # dynamics option (see package definitions, below) @@ -1313,9 +1482,9 @@ rconfig integer dyn_opt namelist,dynamics 1 - rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" # diff_opt 1=old diffusion, 2=new -rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +rconfig integer diff_opt namelist,dynamics max_domains -1 irh "diff_opt" "" "" # km_opt 1=old coefs, 2=tke, 3=Smagorinksy -rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer km_opt namelist,dynamics max_domains -1 irh "km_opt" "" "" rconfig integer damp_opt namelist,dynamics 1 1 irh "damp_opt" "" "" rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" @@ -1419,24 +1588,6 @@ rconfig integer mp_physics_dfi derived max_domains # Single dummy declaration to define a nodyn dyn option state integer nodyn_dummy - dyn_nodyn - - - "" "" "" -# Turbine drag (td) physics -# Turbine positions and characteristics for real-data cases are specified in a file -# whose name is given in the windturbines_spec variable. If the setting is "ideal", -# the td_ variables specify idealized wind farm geometries and turbine characteristics. -# If the setting is "none" then wind turbine drag physics is turned off. -rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name" -rconfig integer td_turbgridid namelist,physics 1 -1 - - "" "which grid id has turbines in it" -rconfig real td_hubheight namelist,physics 1 100. - - "" "hub height (m)" -rconfig real td_diameter namelist,physics 1 60. - - "" "turbine diameter (m)" -rconfig real td_stdthrcoef namelist,physics 1 .158 - - "" "standing thrust coefficient" -rconfig real td_cutinspeed namelist,physics 1 4. - - "" "cut-in speed (m/s)" -rconfig real td_cutoutspeed namelist,physics 1 27. - - "" "cut-out speed (m/s)" -rconfig real td_power namelist,physics 1 2. - - "" "turbine power (MW)" -rconfig real td_turbpercell namelist,physics 1 1. - - "" "number of turbines per cell" -rconfig integer td_ewfx namelist,physics 1 0 - - "" "extent of wind farm in x-cells" -rconfig integer td_ewfy namelist,physics 1 0 - - "" "extent of wind farm in y-cells" -rconfig integer td_pwfx namelist,physics 1 1 - - "" "southwest corner of wind farm in x-cells" -rconfig integer td_pwfy namelist,physics 1 1 - - "" "southwest corner of wind farm in y-cells" rconfig integer maxpatch namelist,physics 1 10 irh "maxpatch" "" "" #key package associated package associated 4d scalars @@ -1446,9 +1597,19 @@ rconfig integer maxpatch namelist,physics 1 10 **** namelist variable dyn_opt that means to select our exp dyncore. package dyn_exp dyn_opt==5 - - -package vt4 vortex_tracker==4 - state:weightout,mslp_noisy,distsq +#--------------------------------------------------------------- +# Vortex tracker options + +# NOTE: ALL methods except #1 must use pdyn_parent and pdyn_smooth, +# if ANY domains use option #5 -#package passivec1 chem_opt==0 - +package vt_old_hwrf vortex_tracker==1 - - +package vt_track_nest vortex_tracker==2 - state:pdyn_parent,pdyn_smooth +package vt_centroid vortex_tracker==3 - state:pdyn_parent,pdyn_smooth +package vt_rev_centr vortex_tracker==4 - state:weightout,mslp_noisy,pdyn_parent,pdyn_smooth,distsq +package vt_pdyn vortex_tracker==5 - state:pdyn_parent,pdyn_smooth,distsq +package vt_ncep vortex_tracker==6 - state:pdyn_parent,pdyn_smooth,p850rv,p700rv,p850wind,p700wind,p850z,p700z,m10wind,m10rv,sp850rv,sp700rv,sp850wind,sp700wind,sp850z,sp700z,sm10wind,sm10rv,smslp,tracker_fixes,distsq +#--------------------------------------------------------------- package passiveqv mp_physics==0 - moist:qv package kesslerscheme mp_physics==1 - moist:qv,qc,qr package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg @@ -1457,7 +1618,8 @@ package wsm5scheme mp_physics==4 - moist:qv,qc,q package etampnew mp_physics==5 - moist:qv,qc,qr,qs;state:f_ice,f_rain,f_rimef package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg -package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr;state:re_cloud,re_ice,re_snow +package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs @@ -1475,7 +1637,8 @@ package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr +package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng package sbu_ylinscheme_dfi mp_physics==13 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs @@ -1504,14 +1667,14 @@ package gfdlswscheme ra_sw_physics==99 - - package hwrfswscheme ra_sw_physics==98 package heldsuarez ra_lw_physics==31 - - -package sfclayscheme sf_sfclay_physics==1 - - +package sfclayscheme sf_sfclay_physics==91 - - package myjsfcscheme sf_sfclay_physics==2 - - package gfssfcscheme sf_sfclay_physics==3 - - package gfdlsfcscheme sf_sfclay_physics==88 - - package qnsesfcscheme sf_sfclay_physics==4 - - package pxsfcscheme sf_sfclay_physics==7 - - package temfsfcscheme sf_sfclay_physics==10 - - -package sfclayrevscheme sf_sfclay_physics==11 - - +package sfclayrevscheme sf_sfclay_physics==1 - - package idealscmsfcscheme sf_sfclay_physics==89 - - package gbmpblscheme sf_sfclay_physics==12 - - @@ -1519,7 +1682,7 @@ package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn package ruclsmscheme sf_surface_physics==3 - - -package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy +package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy package clmscheme sf_surface_physics==5 - - package gfdlslab sf_surface_physics==88 - - @@ -1527,7 +1690,7 @@ package pxlsmscheme sf_surface_physics==7 - - package ssibscheme sf_surface_physics==8 - - package ysuscheme bl_pbl_physics==1 - - package myjpblscheme bl_pbl_physics==2 - - -package gfsscheme bl_pbl_physics==3 - state:hpbl2d,heat2d,evap2d +package gfsscheme bl_pbl_physics==3 - state:hpbl2d,heat2d,evap2d,rc2d package gfs2011scheme bl_pbl_physics==83 - state:hpbl2d,heat2d,evap2d package qnsepblscheme bl_pbl_physics==4 - - package qnsepbl09scheme bl_pbl_physics==94 - - @@ -1536,16 +1699,18 @@ package boulacscheme bl_pbl_physics==8 - - package camuwpblscheme bl_pbl_physics==9 - - package mrfscheme bl_pbl_physics==99 - - package temfpblscheme bl_pbl_physics==10 - - +package fitchscheme windfarm_opt==1 - - package kfetascheme cu_physics==1 - - package bmjscheme cu_physics==2 - - package gdscheme cu_physics==93 - - package sasscheme cu_physics==84 - state:hpbl2d,heat2d,evap2d +package meso_sas cu_physics==85 - state:hpbl2d,heat2d,evap2d package osasscheme cu_physics==4 - state:randstate1,randstate2,randstate3,randstate4,random package g3scheme cu_physics==5 - - package gfscheme cu_physics==3 - - package camzmscheme cu_physics==7 - - -package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD_B,GD_CLOUD2_A,GD_CLOUD2_B,kbcon_deep,ktop_deep,k22_deep +package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep package tiedtkescheme cu_physics==6 - - package nsasscheme cu_physics==14 - - package kfscheme cu_physics==99 - - @@ -1681,9 +1846,9 @@ halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt # following halos added for nesting purpose (gopal's doing): halo HALO_NMM_TRACK dyn_nmm 120:sm,pdyn,mslp,sqws -halo HALO_NMM_INTERP_DOWN1 dyn_nmm 24:sm,fis,t,u,v,q,q2,pd,albase,nmm_tsk,mxsnal,tg,islope,cmc,soiltb,vegfrc,sh2o,smc,stc,toposoil,xice,ivgtyp,isltyp,vegfra,sst,weasd,snowh,hlat,hlon,z0,landmask,cwm,ustar,ths,qsh,cldefi,pshltr,dwdt,acprec,thz0,qz0,uz0,vz0,htop,hbot,cuppt,rlwtt,rswtt,t_adj,f_ice,f_rain,f_rimef,pint,hres_fis +halo HALO_NMM_INTERP_DOWN1 dyn_nmm 24:sm,fis,t,u,v,q,q2,pd,albase,nmm_tsk,mxsnal,tg,islope,cmc,soiltb,vegfrc,sh2o,smc,stc,toposoil,xice,ivgtyp,isltyp,vegfra,sst,weasd,snowh,hlat,hlon,z0,landmask,cwm,ustar,ths,qsh,cldefi,pshltr,dwdt,acprec,thz0,qz0,uz0,vz0,htop,hbot,cuppt,rlwtt,rswtt,t_adj,f_ice,f_rain,f_rimef,pint,hres_fis,pdyn_parent,pdyn_smooth halo HALO_NMM_INTERP_DOWN1M dyn_nmm 24:MOIST,SCALAR -halo HALO_NMM_FORCE_DOWN1 dyn_nmm 24:t,u,v,q,q2,cwm,pint,pd,hres_fis,fis +halo HALO_NMM_FORCE_DOWN1 dyn_nmm 24:t,u,v,q,q2,cwm,pint,pd,hres_fis,fis,pdyn_parent,pdyn_smooth halo HALO_NMM_FORCE_DOWN1M dyn_nmm 24:MOIST,SCALAR halo HALO_NMM_WEIGHTS dyn_nmm 48:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4,HNEAR_I,HNEAR_J @@ -1695,8 +1860,14 @@ halo HALO_NMM_FORCE_DOWN_SST dyn_nmm 120:sst halo HALO_NMM_TERRAIN_SMOOTH dyn_nmm 24:HRES_AVC +halo HALO_NMM_MSLP dyn_nmm 24:MSLP + halo HALO_NMM_VT4_MSLP dyn_nmm 8:mslp halo HALO_NMM_VT4_NOISE dyn_nmm 8:mslp_noisy halo HALO_NMM_INTERP_INFO dyn_nmm 8:pd,iinfo,winfo,pint halo HALO_NMM_INT_UP dyn_nmm 8:pd,fis,hres_fis,sm + +halo HALO_NMM_MEMBRANE_RELAX dyn_nmm 8:relaxwork +halo HALO_NMM_MEMBRANE_MASK dyn_nmm 8:relaximask +halo HALO_NMM_MEMBRANE_INTERP dyn_nmm 8:u10,v10,u,v diff --git a/wrfv2_fire/Registry/Registry.NMM_NEST b/wrfv2_fire/Registry/Registry.NMM_NEST index a1d354c4..09258d85 100644 --- a/wrfv2_fire/Registry/Registry.NMM_NEST +++ b/wrfv2_fire/Registry/Registry.NMM_NEST @@ -40,6 +40,7 @@ # include registry.dimspec +include registry.lake ############# rconfig integer ntracers namelist,physics 1 4 - @@ -115,6 +116,7 @@ state real t_gc ijg dyn_nmm 1 Z i1 "TT" state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" state real greenfrac_gc ijm dyn_nmm 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" state real albedo12m_gc ijm dyn_nmm 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" +state real lai12m_gc ijm dyn_nmm 1 Z i1 "LAI12M" "monthly LAI" "m2/m2" state real soilcbot_gc ijs misc 1 Z i1 "SOILCBOT" "description" "units" state real soilctop_gc ijs misc 1 Z i1 "SOILCTOP" "description" "units" state real tmn_gc ij dyn_nmm 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" @@ -142,6 +144,10 @@ state integer nrnd1 k dyn_nmm 1 - r "NRND1" # For the moving nest. This is gopal's doing # +state real relaxwork ij dyn_nmm 1 - r "relaxwork" "Temporary Tv storage array for the membrane MSLP overrelaxation loops" "K" +state integer relaximask ij dyn_nmm 1 - r "relaximask" "Integer mask array for the membrane MSLP overrelaxation loops" "K" +state logical relaxmask ij dyn_nmm 1 - r "relaxmask" "Mask array for the membrane MSLP overrelaxation loops" "K" + state real pdyn ij dyn_nmm 1 - r "PDYN" "DYNAMIC PRESSURE USED FOR TRACKING GRID MOTION" state real mslp ij dyn_nmm 1 - rh "MSLP" "MSLP USED TO DETERMINE STORM LOCATION" state real sqws ij dyn_nmm 1 - r "SQWS" "SQUARE OF WIND SPEED AT LEVEL 10" @@ -197,9 +203,12 @@ state real HLAT ij dyn_nmm 1 - h01d=(test_nmm:IIH,JJ state real VLON ij dyn_nmm 1 - irh state real VLAT ij dyn_nmm 1 - irh -# -rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain" -rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain" +# Projection south and west bounds for Post: +rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain in rotated coordinates" +rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain in rotated coordinates" +state real wbd0var - dyn_nmm 0 - h "wbd0var" "western boundary of the domain in rotated coordinates" +state real sbd0var - dyn_nmm 0 - h "sbd0var" "southern boundary of the domain in rotated coordinates" + #for HWRF: rconfig logical analysis namelist,time_control max_domains .false. irh "days" "analysis control for the nested domain" @@ -342,6 +351,10 @@ state integer lpbl ij dyn_nmm 1 - ir "LPBL" "Model la state real mixht ij dyn_nmm 1 - rh "MIXHT" "MXL HEIGHT" "m" state real ustar ij dyn_nmm 1 - irhd=(DownNear) "USTAR" "Friction velocity" "m s-1" state real z0 ij dyn_nmm 1 - i01rhd=(DownNear) "Z0" "Roughness height" "m" +state real mz0 ij dyn_nmm 1 - h "MZ0" "momentum Roughness length" "m" +state real rc2d ij dyn_nmm 1 - h "RC2D" "critical Richardson number" "m" +state real dku3d ijk dyn_nmm 1 - h "DKU3D" "Momentum Diffusivity" "m*m/s" +state real dkt3d ijk dyn_nmm 1 - h "DKT3D" "Thermal Diffusivity" "m*m/s" state real hpbl2d ij dyn_nmm 1 - irh "HPBL2D" "HEIGHT OF PBL from new GFS pbl" "m" state real heat2d ij dyn_nmm 1 - irh "HEAT2D" "" "" state real evap2d ij dyn_nmm 1 - irh "EVAP2D" "" "" @@ -410,11 +423,86 @@ state real GD_CLOUD ikj misc 1 - r "GD_CLOUD" "CLOUD WA state real GD_CLOUD2 ikj misc 1 - r "GD_CLOUD2" "TEST for GD CLOUD" "kg kg-1" state real GD_CLOUD_A ikj misc 1 - r "GD_CLOUD_A" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" state real GD_CLOUD2_A ikj misc 1 - r "GD_CLOUD2_A" "taveragd cloud ice mix ratio in GD" "kg kg-1" -state real GD_CLOUD_B ikj misc 1 - r "GD_CLOUD_B" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2_B ikj misc 1 - r "GD_CLOUD2_B" "taveragd cloud ice mix ratio in GD" "kg kg-1" +state real QC_CU ikj misc 1 - r "QC_CU" "CLOUD WATER MIXING RATIO FROM A CU SCHEME" "kg kg-1" +state real QI_CU ikj misc 1 - r "QI_CU" "CLOUD ICE MIXUNG RATIO FROM A CU SCHEME" "kg kg-1" state real GD_CLDFR ikj misc 1 - r "GD_CLDFR" "GD CLOUD Fraction" " ? " ++# upward and downward clearsky and total diagnostic fluxes for radiation (RRTMG) +state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWUPTC ij misc 1 - rhdu "ACSWUPTC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWDNT ij misc 1 - rhdu "ACSWDNT" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWDNTC ij misc 1 - rhdu "ACSWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWUPB ij misc 1 - rhdu "ACSWUPB" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACSWUPBC ij misc 1 - rhdu "ACSWUPBC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACSWDNB ij misc 1 - rhdu "ACSWDNB" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACSWDNBC ij misc 1 - rhdu "ACSWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWUPT ij misc 1 - rhdu "ACLWUPT" "ACCUMULATED UPWELLING LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWUPTC ij misc 1 - rhdu "ACLWUPTC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWDNT ij misc 1 - rhdu "ACLWDNT" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWDNTC ij misc 1 - rhdu "ACLWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" +state real ACLWUPB ij misc 1 - rhdu "ACLWUPB" "ACCUMULATED UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWUPBC ij misc 1 - rhdu "ACLWUPBC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWDNB ij misc 1 - rhdu "ACLWDNB" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" +state real ACLWDNBC ij misc 1 - rhdu "ACLWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" +state real SWUPT ij misc 1 - rhdu "SWUPT" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real SWUPTC ij misc 1 - rhdu "SWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" +state real SWDNT ij misc 1 - rhdu "SWDNT" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real SWDNTC ij misc 1 - rhdu "SWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" +state real SWUPB ij misc 1 - rhdu "SWUPB" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWUPBC ij misc 1 - rhdu "SWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWDNB ij misc 1 - rhdu "SWDNB" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWDNBC ij misc 1 - rhdu "SWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real LWUPT ij misc 1 - rhdu "LWUPT" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP" "W m-2" +state real LWUPTC ij misc 1 - rhdu "LWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2" +state real LWDNT ij misc 1 - rhdu "LWDNT" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP" "W m-2" +state real LWDNTC ij misc 1 - rhdu "LWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2" +state real LWUPB ij misc 1 - rhdu "LWUPB" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" +state real LWUPBC ij misc 1 - rhdu "LWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2" +state real LWDNB ij misc 1 - rhdu "LWDNB" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" +state real LWDNBC ij misc 1 - rhdu "LWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "Wm-2" +state real SWVISDIR ij misc 1 Z r "SWVISDIR" "SWR VIS DIR component" "" +state real SWVISDIF ij misc 1 Z r "SWVISDIF" "SWR VIS DIF component" "" +state real SWNIRDIR ij misc 1 Z r "SWNIRDIR" "SWR NIR DIR component" "" +state real SWNIRDIF ij misc 1 Z r "SWNIRDIF" "SWR NIR DIF component" "" + +state real refl_10cm ikj dyn_nmm 1 - h "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" +state real REFD_MAX ij misc 1 - h "REFD_MAX" "MAX DERIVED RADAR REFL" "dbZ" +state real qnwfa2d ij misc 1 - rhdu "QNWFA2D" "Surface aerosol number conc emission" "kg-1 s-1" +state real re_cloud ikj misc 1 - r "re_cloud" "Effective radius, cloud drops" "m" +state real re_ice ikj misc 1 - r "re_ice" "Effective radius, cloud ice" "m" +state real re_snow ikj misc 1 - r "re_snow" "Effective radius, snow" "m" +state real dfi_re_cloud ikj misc 1 - - "DFI_RE_CLOUD" "DFI Effective radius cloud water" "m" +state real dfi_re_ice ikj misc 1 - - "DFI_RE_ICE" "DFI Effective radius cloud ice" "m" +state real dfi_re_snow ikj misc 1 - - "DFI_RE_SNOW" "DFI Effective radius snow" "m" +state integer has_reqc - misc 1 - r "has_reqc" "Flag for has effective radius of cloud water" "" +state integer has_reqi - misc 1 - r "has_reqi" "Flag for has effective radius of cloud ice" "" +state integer has_reqs - misc 1 - r "has_reqs" "Flag for has effective radius of snow" "" # +# added WRF-Solar +state real swddir ij misc 1 - rhd "SWDDIR" "Shortwave surface downward direct irradiance" "W/m^2" "" +state real swddni ij misc 1 - rhd "SWDDNI" "Shortwave surface downward direct normal irradiance" "W/m^2" "" +state real swddif ij misc 1 - rhd "SWDDIF" "Shortwave surface downward diffuse irradiance" "W/m^2" "" +state real Gx ij misc 1 - rd "Gx" "" "" +state real Bx ij misc 1 - rd "Bx" "" "" +state real gg ij misc 1 - rd "gg" "" "" +state real bb ij misc 1 - rd "bb" "" "" +state real coszen_ref ij misc 1 - - "coszen_ref" "" "" +state real coszen ij misc 1 - - "coszen " "" "" +state real hrang ij misc 1 - - "hrang" "" "" +state real swdown_ref ij misc 1 - - "swdown_ref" "" "" +state real swddir_ref ij misc 1 - - "swddir_ref" "" "" +rconfig integer swint_opt namelist,physics 1 0 - "swint_opt" "interpolation option for sw radiation" "" +# add aerosol namelists +rconfig integer aer_type namelist,physics max_domains 1 irh "aer_type" "aerosol type: 1 is SF79 rural, 2 is SF79 urban" "" +rconfig integer aer_aod550_opt namelist,physics max_domains 1 irh "aer_aod550_opt" "input option for aerosol optical depth at 550 nm" "" +rconfig integer aer_angexp_opt namelist,physics max_domains 1 irh "aer_angexp_opt" "input option for aerosol Angstrom exponent" "" +rconfig integer aer_ssa_opt namelist,physics max_domains 1 irh "aer_ssa_opt" "input option for aerosol single-scattering albedo" "" +rconfig integer aer_asy_opt namelist,physics max_domains 1 irh "aer_asy_opt" "input option for aerosol asymmetry parameter" "" +rconfig real aer_aod550_val namelist,physics max_domains 0.12 irh "aer_aod550_val" "fixed value for aerosol optical depth at 550 nm. Valid when aer_aod550_opt=1" "" +rconfig real aer_angexp_val namelist,physics max_domains 1.3 irh "aer_angexp_val" "fixed value for aerosol Angstrom exponent. Valid when aer_angexp_opt=1" "" +rconfig real aer_ssa_val namelist,physics max_domains 0.85 irh "aer_ssa_val" "fixed value for aerosol single-scattering albedo. Valid when aer_ssa_opt=1" "" +rconfig real aer_asy_val namelist,physics max_domains 0.90 irh "aer_asy_val" "fixed value for aerosol asymmetry parameter. Valid when aer_asy_opt=1" "" + # module_CLDWTR.F # state real cwm ijkb dyn_nmm 1 - rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "CWM" "Total condensate" "kg kg-1" @@ -688,31 +776,39 @@ state real dfi_qnh ijkfbt dfi_moist 1 m r " # Other Scalars state real - ijkftb scalar 1 m - - state real qni ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNICE" "Ice Number concentration" "# kg(-1)" +state real qt ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QT" "Total condensate mixing ratio" "kg kg-1" state real qns ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNSNOW" "Snow Number concentration" "# kg(-1)" state real qnr ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNRAIN" "Rain Number concentration" "# kg(-1)" state real qng ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNGRAUP" "Graupel Number concentration" "# kg(-1)" state real qnh ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNHAIL" "Hail Number concentration" "# kg(-1)" state real qnn ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCCN" "CCN Number concentration" "# kg(-1)" state real qnc ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" +state real qnwfa ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" +state real qnifa ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" +state real qvolg ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" state real - ijkftb dfi_scalar 1 m - - state real dfi_qndrop ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNDROP" "Droplet number mixing ratio" "# kg-1" + rusdf=(BdyMass:@ECopy,0.0) "DFI_QNDROP" "DFI Droplet number mixing ratio" "# kg-1" state real dfi_qni ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNICE" "Ice Number concentration" "# kg-1" + rusdf=(BdyMass:@ECopy,0.0) "DFI_QNICE" "DFI Ice Number concentration" "# kg-1" state real dfi_qt ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_CWM" "Total condensate mixing ratio" "kg kg-1" + rusdf=(BdyMass:@ECopy,0.0) "DFI_CWM" "DFI Total condensate mixing ratio" "kg kg-1" state real dfi_qns ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNSNOW" "Snow Number concentration" "# kg(-1)" + rusdf=(BdyMass:@ECopy,0.0) "DFI_QNSNOW" "DFI Snow Number concentration" "# kg(-1)" state real dfi_qnr ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNRAIN" "Rain Number concentration" "# kg(-1)" + rusdf=(BdyMass:@ECopy,0.0) "DFI_QNRAIN" "DFI Rain Number concentration" "# kg(-1)" state real dfi_qng ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNGRAUPEL" "Graupel Number concentration" "# kg(-1)" + rusdf=(BdyMass:@ECopy,0.0) "DFI_QNGRAUPEL" "DFI Graupel Number concentration" "# kg(-1)" state real dfi_qnn ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNCC" "CNN Number concentration" "# kg(-1)" + rusdf=(BdyMass:@ECopy,0.0) "DFI_QNCC" "DFI CNN Number concentration" "# kg(-1)" state real dfi_qnc ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNCLOUD" "Cloud Number concentration" "# kg(-1)" + rusdf=(BdyMass:@ECopy,0.0) "DFI_QNCLOUD" "DFI Cloud Number concentration" "# kg(-1)" +state real dfi_qnwfa ikjftb dfi_scalar 1 m \ + rusdf=(BdyMass:@ECopy,0.0) "DFI_QNWFA" "DFI water-friendly aerosol number con" "# kg(-1)" +state real dfi_qnifa ikjftb dfi_scalar 1 m \ + rusdf=(BdyMass:@ECopy,0.0) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" #----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -742,6 +838,7 @@ state real - ikjft chem 1 - - - state real SMOIS ilj - 1 Z rh "SMOIS" "SOIL MOISTURE" "" state real TSLB ilj - 1 Z r "TSLB" "SOIL TEMPERATURE" "" +state real lake_depth ij misc 1 - rd=(interp_mask_water_field:lu_index,iswater) "lake_depth" "lake depth" "m" # MYJ PBL variables @@ -821,6 +918,8 @@ state real SNOW ij misc 1 - i01rh state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" state integer FORCE_SST k misc 1 - - "FORCE_SST" "IF FORCE_SST(1) IS 1, FEED SST FROM PARENT EVERY DT" "" state real SST ij misc 1 - i014rhd=(DownNear)f=(force_sst_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,FORCE_SST) "SST" "SEA SURFACE TEMPERATURE" "K" +state real UOCE ij misc 1 - i014rh "UOCE" "SEA SURFACE ZONAL CURRENTS" "m s-1" +state real VOCE ij misc 1 - i014rh "VOCE" "SEA SURFACE MERIDIONAL CURRENTS" "m s-1" state real WEASD ij misc 1 - i01rhd=(DownNear) "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "kg m-2" state real ZNT ij misc 1 - irh "ZNT" "TIME-VARYING ROUGHNESS LENGTH" state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" @@ -986,6 +1085,10 @@ state real chucxy ij - 1 - i02rhd=(interp_mask_land state real chv2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv2" "leaf exchange coefficient" "m/s" state real chb2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb2" "under canopy exchange coefficient" "m/s" state real chstarxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chstar" "dummy exchange coefficient" "m/s" +state real SMOISEQ ilj - 1 Z r "SMOISEQ" "EQ. SOIL MOISTURE" "m3 m-3" +state real smcwtdxy ij - 1 - rh "smcwtd" "deep soil moisture " "m3 m-3" +state real rechxy ij - 1 - h "rech" "water table recharge" "mm" +state real deeprechxy ij - 1 - r "deeprech" "deep water table recharge" "mm" # added state for etampnew microphysics (needed for restarts) state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" @@ -1005,6 +1108,7 @@ state real lu_state p misc - - - # state integer number_at_same_level - - - - - "number_at_same_level" "" "" +state real power ij misc 1 - irh "Power" "Power production" "W" # State for derived time quantities. #for HWRF: add to restart @@ -1168,12 +1272,15 @@ rconfig real mommix namelist,physics max_domains 0.7 rconfig logical disheat namelist,physics max_domains .true. irh "nmm input 7" rconfig integer vortex_tracker namelist,physics max_domains 1 - "vortex_tracker" "Vortex Tracking Algorithm" "" #end HWRF: +rconfig integer do_radar_ref namelist,physics 1 0 rh "compute radar reflectivity for a number of schemes" rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig integer windfarm_opt namelist,physics max_domains 0 rh "windfarm_opt" "" "" +rconfig integer windfarm_ij namelist,physics 1 0 rh "windfarm_ij" "" "" rconfig integer mfshconv namelist,physics max_domains 1 rh "mfshconv" "To activate mass flux scheme with qnse, 1=true; 0=false" "" rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" @@ -1189,6 +1296,9 @@ rconfig integer surface_input_source namelist,physics 1 1 rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" rconfig integer num_urban_layers namelist,physics 1 400 irh "num_urban_layers" "" "" rconfig integer num_urban_hi namelist,physics 1 15 irh "num_urban_hi" "" "" +rconfig integer sf_surface_mosaic namelist,physics 1 0 rh "sf_surface_mosaic" "1= mosaic, 0=no mosaic method, add by danli" "" +rconfig integer mosaic_cat namelist,physics 1 3 rh "mosaic_cat" "works when sf_surface_mosaic=1; it is the number of mosaic tiles" "" +rconfig integer mosaic_cat_soil derived 1 12 rh "mosaic_cat_soil" "should be the number of soil layers times the mosaic_cat" "" rconfig integer mosaic_lu namelist,physics 1 0 irh "mosaic_lu" "" "" rconfig integer mosaic_soil namelist,physics 1 0 irh "mosaic_soil" "" "" rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" @@ -1202,7 +1312,7 @@ rconfig integer num_soil_cat namelist,physics 1 16 rconfig integer topo_wind namelist,physics max_domains 0 - "topo_wind" "2: Use Mass sfc drag scheme, 1: improve effects topography over surface wind, 0:not" "" rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" -rconfig real seaice_threshold namelist,physics 1 271 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" +rconfig real seaice_threshold namelist,physics 1 100 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seiace" "Fractional sea-ice option" rconfig integer seaice_albedo_opt namelist,physics 1 0 - "seaice_albedo_opt" "Method for setting albedo over sea ice" rconfig real seaice_albedo_default namelist,physics 1 0.65 - "seaice_albedo_default" "Default value for sea-ice over albedo with seaice_albeo_opt=0" @@ -1254,11 +1364,14 @@ rconfig integer no_src_types namelist,physics 1 1 rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" rconfig integer o3input namelist,physics 1 0 - "o3input" "ozone input option for radiation" "" rconfig integer aer_opt namelist,physics 1 0 - "aer_opt" "aerosol input option for radiation" "" -rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback cumulus to radiation" "" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback of cumulus cloud to radiation" +rconfig integer ICLOUD_CU derived 1 0 - "ICLOUD_CU" "" "" rconfig real h_diff namelist,physics max_domains 0.1 irh "nmm input 9" rconfig integer movemin namelist,physics max_domains 0 irh "nmm input 12" rconfig integer num_snso_layers namelist,physics 1 7 irh "num_snso_layers" "" "" rconfig integer num_snow_layers namelist,physics 1 3 irh "num_snow_layers" "" "" +rconfig logical use_aero_icbc namelist,physics 1 .false. rh "use_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero" "logical flag" +rconfig integer sf_lake_physics namelist,physics max_domains 0 h "sf_lake_physics" "activate lake model 0=no, 1=yes" "" # Dynamics @@ -1267,9 +1380,9 @@ rconfig integer dyn_opt namelist,dynamics 1 - rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" # diff_opt 1=old diffusion, 2=new -rconfig integer diff_opt namelist,dynamics 1 1 irh "diff_opt" "" "" +rconfig integer diff_opt namelist,dynamics max_domains -1 irh "diff_opt" "" "" # km_opt 1=old coefs, 2=tke, 3=Smagorinksy -rconfig integer km_opt namelist,dynamics 1 1 irh "km_opt" "" "" +rconfig integer km_opt namelist,dynamics max_domains -1 irh "km_opt" "" "" rconfig integer damp_opt namelist,dynamics 1 1 irh "damp_opt" "" "" rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" @@ -1373,24 +1486,6 @@ rconfig integer mp_physics_dfi derived max_domains # Single dummy declaration to define a nodyn dyn option state integer nodyn_dummy - dyn_nodyn - - - "" "" "" -# Turbine drag (td) physics -# Turbine positions and characteristics for real-data cases are specified in a file -# whose name is given in the windturbines_spec variable. If the setting is "ideal", -# the td_ variables specify idealized wind farm geometries and turbine characteristics. -# If the setting is "none" then wind turbine drag physics is turned off. -rconfig character windturbines_spec namelist,physics 1 "none" - - "" "none, ideal, or a file name" -rconfig integer td_turbgridid namelist,physics 1 -1 - - "" "which grid id has turbines in it" -rconfig real td_hubheight namelist,physics 1 100. - - "" "hub height (m)" -rconfig real td_diameter namelist,physics 1 60. - - "" "turbine diameter (m)" -rconfig real td_stdthrcoef namelist,physics 1 .158 - - "" "standing thrust coefficient" -rconfig real td_cutinspeed namelist,physics 1 4. - - "" "cut-in speed (m/s)" -rconfig real td_cutoutspeed namelist,physics 1 27. - - "" "cut-out speed (m/s)" -rconfig real td_power namelist,physics 1 2. - - "" "turbine power (MW)" -rconfig real td_turbpercell namelist,physics 1 1. - - "" "number of turbines per cell" -rconfig integer td_ewfx namelist,physics 1 0 - - "" "extent of wind farm in x-cells" -rconfig integer td_ewfy namelist,physics 1 0 - - "" "extent of wind farm in y-cells" -rconfig integer td_pwfx namelist,physics 1 1 - - "" "southwest corner of wind farm in x-cells" -rconfig integer td_pwfy namelist,physics 1 1 - - "" "southwest corner of wind farm in y-cells" rconfig integer maxpatch namelist,physics 1 10 irh "maxpatch" "" "" #key package associated package associated 4d scalars @@ -1409,7 +1504,8 @@ package wsm5scheme mp_physics==4 - moist:qv,qc,q package etampnew mp_physics==5 - moist:qv,qc,qr,qs;state:f_ice,f_rain,f_rimef package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg -package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr;state:re_cloud,re_ice,re_snow +package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs @@ -1427,7 +1523,8 @@ package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr +package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng package sbu_ylinscheme_dfi mp_physics==13 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs @@ -1456,21 +1553,21 @@ package gfdlswscheme ra_sw_physics==99 - - package hwrfswscheme ra_sw_physics==98 package heldsuarez ra_lw_physics==31 - - -package sfclayscheme sf_sfclay_physics==1 - - +package sfclayscheme sf_sfclay_physics==91 - - package myjsfcscheme sf_sfclay_physics==2 - - package gfssfcscheme sf_sfclay_physics==3 - - package gfdlsfcscheme sf_sfclay_physics==88 - - package qnsesfcscheme sf_sfclay_physics==4 - - package pxsfcscheme sf_sfclay_physics==7 - - package temfsfcscheme sf_sfclay_physics==10 - - -package sfclayrevscheme sf_sfclay_physics==11 - - +package sfclayrevscheme sf_sfclay_physics==1 - - package idealscmsfcscheme sf_sfclay_physics==89 - - package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn package ruclsmscheme sf_surface_physics==3 - - -package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy +package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy package clmscheme sf_surface_physics==5 - - package gfdlslab sf_surface_physics==88 - - @@ -1488,16 +1585,18 @@ package camuwpblscheme bl_pbl_physics==9 - - package mrfscheme bl_pbl_physics==99 - - package temfpblscheme bl_pbl_physics==10 - - package gbmpblscheme bl_pbl_physics==12 - - +package fitchscheme windfarm_opt==1 - - package kfetascheme cu_physics==1 - - package bmjscheme cu_physics==2 - - package gdscheme cu_physics==93 - - package sasscheme cu_physics==84 - state:hpbl2d,heat2d,evap2d +package meso_sas cu_physics==85 - - package osasscheme cu_physics==4 - state:randstate1,randstate2,randstate3,randstate4,random package g3scheme cu_physics==5 - - package gfscheme cu_physics==3 - - package camzmscheme cu_physics==7 - - -package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD_B,GD_CLOUD2_A,GD_CLOUD2_B,kbcon_deep,ktop_deep,k22_deep +package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep package tiedtkescheme cu_physics==6 - - package nsasscheme cu_physics==14 - - package kfscheme cu_physics==99 - - @@ -1632,6 +1731,9 @@ halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt # following halos added for nesting purpose (gopal's doing): + +halo HALO_NMM_MEMBRANE_RELAX dyn_nmm 8:relaxwork +halo HALO_NMM_MEMBRANE_MASK dyn_nmm 8:relaximask halo HALO_NMM_TRACK dyn_nmm 120:sm,pdyn,mslp,sqws halo HALO_NMM_INTERP_DOWN1 dyn_nmm 24:sm,fis,t,u,v,q,q2,pd,albase,nmm_tsk,mxsnal,tg,islope,cmc,soiltb,vegfrc,sh2o,smc,stc,toposoil,xice,ivgtyp,isltyp,vegfra,sst,weasd,snowh,hlat,hlon,z0,landmask,cwm,ustar,ths,qsh,cldefi,pshltr,dwdt,acprec,thz0,qz0,uz0,vz0,htop,hbot,cuppt,rlwtt,rswtt,t_adj,f_ice,f_rain,f_rimef,pint,hres_fis halo HALO_NMM_INTERP_DOWN1M dyn_nmm 24:MOIST,SCALAR diff --git a/wrfv2_fire/Registry/registry.bdy_perturb b/wrfv2_fire/Registry/registry.bdy_perturb index 8d27d351..18df34e6 100644 --- a/wrfv2_fire/Registry/registry.bdy_perturb +++ b/wrfv2_fire/Registry/registry.bdy_perturb @@ -1,12 +1,12 @@ # Perturb boundary condition option # 3D arrays - state real field_u_tend_perturb ikj dyn_em 1 X rhdf=(p2c) "field_u_tend_perturb" "field used to perturb u in the boundaries" "" - state real field_v_tend_perturb ikj dyn_em 1 Y rhdf=(p2c) "field_v_tend_perturb" "field used to perturb v in the boundaries" "" - state real field_t_tend_perturb ikj dyn_em 1 - rhdf=(p2c) "field_t_tend_perturb" "field used to perturb t in the boundaries" "" +state real field_u_tend_perturb ikj dyn_em 1 X rhdf=(p2c) "field_u_tend_perturb" "field used to perturb u in the boundaries" "" +state real field_v_tend_perturb ikj dyn_em 1 Y rhdf=(p2c) "field_v_tend_perturb" "field used to perturb v in the boundaries" "" +state real field_t_tend_perturb ikj dyn_em 1 - rhdf=(p2c) "field_t_tend_perturb" "field used to perturb t in the boundaries" "" # Namelist parameter -rconfig integer perturb_bdy namelist,bdy_control 1 0 - "perturb boundaries option: 0=off, 1=on with SKEBS pattern, 2=on with user provided pattern" +rconfig integer perturb_bdy namelist,stoch 1 0 - "perturb boundaries option: 0=off, 1=on with SKEBS pattern, 2=on with user provided pattern" # Package declarations package no_perturb_bdy perturb_bdy==0 - - diff --git a/wrfv2_fire/Registry/registry.cam b/wrfv2_fire/Registry/registry.cam index 21d3ec04..a865e235 100644 --- a/wrfv2_fire/Registry/registry.cam +++ b/wrfv2_fire/Registry/registry.cam @@ -166,14 +166,16 @@ state real limit_rei_cu ij misc 1 - h6 "LIMIT_REI_CU" "limit_re state real ind_delcin_cu ij misc 1 - h6 "IND_DELCIN_CU" "ind_delcin_cu" "" #CAMMGMP -state real rh_old_mp ikj misc 1 - r "RH_OLD_MP" "previous time level RH for CAMMGMP microphysics" "" -state real lcd_old_mp ikj misc 1 - r "LCD_OLD_MP" "previous time level liquid cldfra for CAMMGMP microphysics" "" -state real CLDFRA_OLD_MP ikj misc 1 - r "CLDFRA_OLD_MP" "previous time level cldfra for CAMMGMP microphysics" "" -state real CLDFRA_MP ikj misc 1 - rh "CLDFRA_MP" "current time level cldfra for CAMMGMP microphysics" "" -state real CLDFRA_MP_ALL ikj misc 1 - rh "CLDFRA_MP_ALL" "current time level cldfra for CAMMGMP microphysics" "" -state real CLDFRA_CONV ikj misc 1 - rh "CLDFRA_CONV" "current time level cldfra for CAMMGMP microphysics" "" -state real CLDFRAI ikj misc 1 - rh "CLDFRAI" "current time level cldfrai for CAMMGMP microphysics" "" -state real CLDFRAL ikj misc 1 - rh "CLDFRAL" "current time level cldfral for CAMMGMP microphysics" "" +state real rh_old_mp ikj misc 1 - r "RH_OLD_MP" "previous time level RH for CAMMGMP microphysics" "" +state real lcd_old_mp ikj misc 1 - r "LCD_OLD_MP" "previous time level liquid cldfra for CAMMGMP microphysics" "" +state real CLDFRA_OLD_MP ikj misc 1 - r "CLDFRA_OLD_MP" "previous time level cldfra for CAMMGMP microphysics" "" +state real CLDFRA_MP ikj misc 1 - rh "CLDFRA_MP" "current time level cldfra for CAMMGMP microphysics" "" +state real CLDFRA_MP_ALL ikj misc 1 - rh "CLDFRA_MP_ALL" "current time level cldfra for CAMMGMP microphysics" "" +state real IRADIUS ikj misc 1 - rh "IRADIUS" "effective radius of ice condensate" "" +state real LRADIUS ikj misc 1 - rh "LRADIUS" "effective radius of liquid condensate" "" +state real CLDFRA_CONV ikj misc 1 - rh "CLDFRA_CONV" "current time level cldfra for CAMMGMP microphysics" "" +state real CLDFRAI ikj misc 1 - rh "CLDFRAI" "current time level cldfrai for CAMMGMP microphysics" "" +state real CLDFRAL ikj misc 1 - rh "CLDFRAL" "current time level cldfral for CAMMGMP microphysics" "" state logical is_CAMMGMP_used - misc - - r "is_CAMMGMP_used" "" ifdef BUILD_CHEM=1 @@ -187,6 +189,15 @@ state real RATE1ORD_CW2PR_ST3D ikj misc 1 - r "R state real dvmrdt_sv13d ikj{nspecmam} misc 1 - r "DVMRDT_SV13D" "Volume mixing ration tendency for interstitial aerosols" "" state real dvmrcwdt_sv13d ikj{nspecmam} misc 1 - r "DVMCWRDT_SV13D" "Volume mixing ration tendency for cloud borne aerosols" "" +# MAM chemistry interactions with cloud microphysics requires dgnum to be saved in restart files for each mode. +# 4D DGNUM4D is not saved correctly, so use these as a workaround. +state real dgnum_a1 ikj misc 1 - r "DG_NUM_A1" "Accum. mode mean diameter" "" +state real dgnum_a2 ikj misc 1 - r "DG_NUM_A2" "Aitken mode mean diameter" "" +state real dgnum_a3 ikj misc 1 - r "DG_NUM_A3" "Coarse mode mean diameter" "" +state real dgnumwet_a1 ikj misc 1 - r "DG_NUMWET_A1" "Accum. mode mean diameter" "" +state real dgnumwet_a2 ikj misc 1 - r "DG_NUMWET_A2" "Aitken mode mean diameter" "" +state real dgnumwet_a3 ikj misc 1 - r "DG_NUMWET_A3" "Coarse mode mean diameter" "" + #CAM5's wet scavenging output variables state real FRACIS3D ikj{nspecmam} misc 1 - r "FRACIS3D" "fraction of transported species that are insoluble" "" endif diff --git a/wrfv2_fire/Registry/registry.chem b/wrfv2_fire/Registry/registry.chem index 0becc43a..c3a7d1ad 100644 --- a/wrfv2_fire/Registry/registry.chem +++ b/wrfv2_fire/Registry/registry.chem @@ -98,6 +98,35 @@ state real e_c10h16 i+jf emis_ant 1 Z i5h "E_C state real e_voca i+jf emis_ant 1 Z i5 "E_VOCA" "VOCA emissions" "mol km^-2 hr^-1" state real e_vocbb i+jf emis_ant 1 Z i5 "E_VOCBB" "VOCBB emissions" "mol km^-2 hr^-1" +# Additional crimech emission variables... +state real e_c5h8 i+jf emis_ant 1 Z i5h "E_C5H8" "EMISSIONS C5H8" "mol km^-2 hr^-1" +state real e_tm123b i+jf emis_ant 1 Z i5h "E_TM123B" "EMISSIONS TM123B" "mol km^-2 hr^-1" +state real e_tm124b i+jf emis_ant 1 Z i5h "E_TM124B" "EMISSIONS TM124B" "mol km^-2 hr^-1" +state real e_tm135b i+jf emis_ant 1 Z i5h "E_TM135B" "EMISSIONS TM124B" "mol km^-2 hr^-1" +state real e_oethtol i+jf emis_ant 1 Z i5h "E_OETHTOL" "EMISSIONS OETHTOL" "mol km^-2 hr^-1" +state real e_methtol i+jf emis_ant 1 Z i5h "E_METHTOL" "EMISSIONS METHTOL" "mol km^-2 hr^-1" +state real e_pethtol i+jf emis_ant 1 Z i5h "E_PETHTOL" "EMISSIONS PETHTOL" "mol km^-2 hr^-1" +state real e_dime35eb i+jf emis_ant 1 Z i5h "E_DIME35EB" "EMISSIONS DIME35EB" "mol km^-2 hr^-1" +state real e_c2h5cho i+jf emis_ant 1 Z i5h "E_C2H5CHO" "EMISSIONS C2H5CHO" "mol km^-2 hr^-1" +state real e_benzene i+jf emis_ant 1 Z i5h "E_BENZENE" "EMISSIONS BENZENE" "mol km^-2 hr^-1" +state real e_nc4h10 i+jf emis_ant 1 Z i5h "E_NC4H10" "EMISSIONS NC4H10" "mol km^-2 hr^-1" +state real e_oxyl i+jf emis_ant 1 Z i5h "E_OXYL" "EMISSIONS OXYL" "mol km^-2 hr^-1" +state real e_tbut2ene i+jf emis_ant 1 Z i5h "E_TBUT2ENE" "EMISSIONS TBUT2ENE" "mol km^-2 hr^-1" +state real e_ch3co2h i+jf emis_ant 1 Z i5h "E_CH3CO2H" "EMISSIONS CH3CO2H" "mol km^-2 hr^-1" + +# Additional TNO emission variables for the UK +state real e_bc_1 i+jf emis_ant 1 Z i5h "E_BC_1" "EMISSION RATE OF BLACK CARBON 1UM MODE" "ug/m3 m/s" +state real e_ec_1_25 i+jf emis_ant 1 Z i5h "E_EC_1_25" "EMISSION RATE OF ELEMENTAL CARBON 1UM-2.5UM MODE" "ug/m3 m/s" +state real e_ec_25_10 i+jf emis_ant 1 Z i5h "E_EC_25_10" "EMISSION RATE OF ELEMENTAL CARBON 2.5UM-10UM MODE" "ug/m3 m/s" +state real e_oc_dom i+jf emis_ant 1 Z i5h "E_OC_DOM" "EMISSION RATE OF ORGANIC CARBON 2.5UM MODE (Domestic combustion)" "ug/m3 m/s" +state real e_oc_tra i+jf emis_ant 1 Z i5h "E_OC_TRA" "EMISSION RATE OF ORGANIC CARBON 2.5UM MODE (Traffic and other sources)" "ug/m3 m/s" +state real e_oc_25_10 i+jf emis_ant 1 Z i5h "E_OC_25_10" "EMISSION RATE OF ORGANIC CARBON 2.5UM-10UM MODE" "ug/m3 m/s" +state real e_pm25 i+jf emis_ant 1 Z i5h "E_PM25" "EMISSION RATE OF PARTICULATE MATTER 2.5UM MODE" "ug/m3 m/s" +state real e_pm10 i+jf emis_ant 1 Z i5h "E_PM10" "EMISSION RATE OF PARTICULATE MATTER 10UM MODE" "ug/m3 m/s" +state real e_oin_25 i+jf emis_ant 1 Z i5h "E_OIN_25" "EMISSION RATE OF PARTICULATE MATTER OTHER INORGANICS 2.5UM MODE" "ug/m3 m/s" +state real e_oin_10 i+jf emis_ant 1 Z i5h "E_OIN_10" "EMISSION RATE OF PARTICULATE MATTER OTHER INORGANICS 10UM MODE" "ug/m3 m/s" + + # Additional CBMZ and MOSAIC emission variables... state real e_no2 i+jf emis_ant 1 Z i5 "E_NO2" "EMISSIONS NO2" "mol km^-2 hr^-1" state real e_ch3oh i+jf emis_ant 1 Z i5 "E_CH3OH" "EMISSIONS CH3OH" "mol km^-2 hr^-1" @@ -133,7 +162,34 @@ state real e_ecj_num i+jf emis_ant 1 Z i5 "E state real e_so4j_num i+jf emis_ant 1 Z i5 "E_SO4J_NUM" "J-MODE SO4 NUMBER" "particle/m2/s" state real e_so4i_num i+jf emis_ant 1 Z i5 "E_SO4I_NUM" "I-MODE SO4 NUMBER" "particle/m2/s" state real e_num_a3 i+jf emis_ant 1 Z i5 "E_NUM_A3" "COARSE MODE NUMBER" "particle/m2/s" - +state real e_dms i+jf emis_ant 1 Z i5r "E_DMS" "EMISSIONS" "mol km^-2 hr^-1" + + +# soiltexturef is texture category fraction for each grid cell +state real ust_t ij misc 1 - i012rh "UST_T" "Threshold Friction Velocity" "m s-1" +state real rough_cor ij misc 1 - rh "Rough_cor" "roughness elements correction" "" +state real smois_cor ij misc 1 - rh "Smois_cor" "soil moisture correction" "" +state real dustload_1 ij misc 1 - rh "dustload_1" "dust loading for size 1" "ug/m2" +state real dustload_2 ij misc 1 - rh "dustload_2" "dust loading for size 2" "ug/m2" +state real dustload_3 ij misc 1 - rh "dustload_3" "dust loading for size 3" "ug/m2" +state real dustload_4 ij misc 1 - rh "dustload_4" "dust loading for size 4" "ug/m2" +state real dustload_5 ij misc 1 - rh "dustload_5" "total dust loading" "ug/m2" +state real depvelocity ij misc 1 - rh "drydepvel" "dust dry deposition velocity " "m/s" +state real setvel_1 ij misc 1 - rh "setvel_1" "dust gravitational settling velocity for size 1" "m/s" +state real setvel_2 ij misc 1 - rh "setvel_2" "dust gravitational settling velocity for size 2" "m/s" +state real setvel_3 ij misc 1 - rh "setvel_3" "dust gravitational settling velocity for size 3" "m/s" +state real setvel_4 ij misc 1 - rh "setvel_4" "dust gravitational settling velocity for size 4" "m/s" +state real setvel_5 ij misc 1 - rh "setvel_5" "effective gravitational settling velocity for total" "m/s" +state real dustgraset_1 ij misc 1 - rh "graset_1" "dust gravitational settling for size 1" "ug/m2/s" +state real dustgraset_2 ij misc 1 - rh "graset_2" "dust gravitational settling for size 2" "ug/m2/s" +state real dustgraset_3 ij misc 1 - rh "graset_3" "dust gravitational settling for size 3" "ug/m2/s" +state real dustgraset_4 ij misc 1 - rh "graset_4" "dust gravitational settling for size 4" "ug/m2/s" +state real dustgraset_5 ij misc 1 - rh "graset_5" "dust gravitational settling for size 5" "ug/m2/s" +state real dustdrydep_1 ij misc 1 - rh "drydep_1" "dust dry deposition for size 1" "ug/m2/s" +state real dustdrydep_2 ij misc 1 - rh "drydep_2" "dust dry deposition for size 2" "ug/m2/s" +state real dustdrydep_3 ij misc 1 - rh "drydep_3" "dust dry deposition for size 3" "ug/m2/s" +state real dustdrydep_4 ij misc 1 - rh "drydep_4" "dust dry deposition for size 4" "ug/m2/s" +state real dustdrydep_5 ij misc 1 - rh "drydep_5" "dust dry deposition for size 5" "ug/m2/s" #SAPRCNOV additional emissions, automatically created using diff_mechEmiss_wrfRegistry.m script (pablo-saide@uiowa.edu) state real e_c2h2 i+jf emis_ant 1 Z i5 "E_C2H2" "C2H2 emissions" "mol km^-2 hr^-1" @@ -221,8 +277,8 @@ state real ebu_hc8 ikjf ebu 1 Z - "eb state real ebu_ete ikjf ebu 1 Z - "ebu_ete" "biomass burning emiss" "mol km^-2 hr^-1" state real ebu_olt ikjf ebu 1 Z - "ebu_olt" "biomass burning emiss" "mol km^-2 hr^-1" state real ebu_oli ikjf ebu 1 Z - "ebu_oli" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_pm25 ikjf ebu 1 Z - "ebu_pm25" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_pm10 ikjf ebu 1 Z - "ebu_pm10" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_pm25 ikjf ebu 1 Z - "ebu_pm25" "biomass burning emiss" "ug/m2/s" +state real ebu_pm10 ikjf ebu 1 Z - "ebu_pm10" "biomass burning emiss" "ug/m2/s" state real ebu_dien ikjf ebu 1 Z - "ebu_dien" "biomass burning emiss" "mol km^-2 hr^-1" state real ebu_iso ikjf ebu 1 Z - "ebu_iso" "biomass burning emiss" "mol km^-2 hr^-1" state real ebu_api ikjf ebu 1 Z - "ebu_api" "biomass burning emiss" "mol km^-2 hr^-1" @@ -239,8 +295,8 @@ state real ebu_ora2 ikjf ebu 1 Z - "eb state real ebu_nh3 ikjf ebu 1 Z - "ebu_nh3" "biomass burning emiss" "mol km^-2 hr^-1" state real ebu_so2 ikjf ebu 1 Z - "ebu_so2" "biomass burning emiss" "mol km^-2 hr^-1" state real ebu_dms ikjf ebu 1 Z - "ebu_dms" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_oc ikjf ebu 1 Z h "ebu_oc" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_bc ikjf ebu 1 Z - "ebu_bc" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_oc ikjf ebu 1 Z h "ebu_oc" "biomass burning emiss" "ug/m2/s" +state real ebu_bc ikjf ebu 1 Z - "ebu_bc" "biomass burning emiss" "ug/m2/s" state real ebu_sulf ikjf ebu 1 Z - "ebu_sulf" "biomass burning emiss" "mol km^-2 hr^-1" # additional arrays for mozcart biomass burning state real ebu_bigalk ikjf ebu 1 Z h "ebu_bigalk" "biomass burning emiss" "mol km^-2 hr^-1" @@ -283,8 +339,8 @@ state real ebu_in_hc8 i]jf ebu_in 1 - i07 state real ebu_in_ete i]jf ebu_in 1 - i07 "ebu_in_ete" "EMISSIONS" "mol km^-2 hr^-1" state real ebu_in_olt i]jf ebu_in 1 - i07 "ebu_in_olt" "EMISSIONS" "mol km^-2 hr^-1" state real ebu_in_oli i]jf ebu_in 1 - i07 "ebu_in_oli" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_pm25 i]jf ebu_in 1 - i07 "ebu_in_pm25" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_pm10 i]jf ebu_in 1 - i07 "ebu_in_pm10" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_pm25 i]jf ebu_in 1 - i07 "ebu_in_pm25" "EMISSIONS" "ug/m2/s" +state real ebu_in_pm10 i]jf ebu_in 1 - i07 "ebu_in_pm10" "EMISSIONS" "ug/m2/s" state real ebu_in_dien i]jf ebu_in 1 - i07 "ebu_in_dien" "EMISSIONS" "mol km^-2 hr^-1" state real ebu_in_iso i]jf ebu_in 1 - i07 "ebu_in_iso" "EMISSIONS" "mol km^-2 hr^-1" state real ebu_in_api i]jf ebu_in 1 - i07 "ebu_in_api" "EMISSIONS" "mol km^-2 hr^-1" @@ -301,10 +357,10 @@ state real ebu_in_ora2 i]jf ebu_in 1 - i07 state real ebu_in_nh3 i]jf ebu_in 1 - i07 "ebu_in_nh3" "EMISSIONS" "mol km^-2 hr^-1" state real ebu_in_so2 i]jf ebu_in 1 - i07 "ebu_in_so2" "EMISSIONS" "mol km^-2 hr^-1" state real ebu_in_dms i]jf ebu_in 1 - i07 "ebu_in_dms" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_oc i]jf ebu_in 1 - i07 "ebu_in_oc" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_bc i]jf ebu_in 1 - i07 "ebu_in_bc" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_oc i]jf ebu_in 1 - i07 "ebu_in_oc" "EMISSIONS" "ug/m2/s" +state real ebu_in_bc i]jf ebu_in 1 - i07 "ebu_in_bc" "EMISSIONS" "ug/m2/s" state real ebu_in_sulf i]jf ebu_in 1 - i07 "ebu_in_sulf" "EMISSIONS" "mol km^-2 hr^-1" -state real ebu_in_ash i]jf ebu_in 1 - i07 "ebu_in_ash" "EMISSIONS" "mol km^-2 hr^-1" +state real ebu_in_ash i]jf ebu_in 1 - i07 "ebu_in_ash" "EMISSIONS" "ug/m2/s" # additional arrays for mozcart biomass burning state real ebu_in_bigalk i]jf ebu_in 1 - i07 "ebu_in_bigalk" "EMISSIONS" "mol km^-2 hr^-1" state real ebu_in_bigene i]jf ebu_in 1 - i07 "ebu_in_bigene" "EMISSIONS" "mol km^-2 hr^-1" @@ -463,6 +519,16 @@ state real ebio_c3h6 ij misc 1 - - "ebi state real ebio_c3h8 ij misc 1 - - "ebio_c3h8" "Actual biog emiss" "mol km^-2 hr^-1" state real ebio_so2 ij misc 1 - - "ebio_so2" "Actual biog emiss" "mol km^-2 hr^-1" state real ebio_dms ij misc 1 - - "ebio_dms" "Actual biog emiss" "mol km^-2 hr^-1" +# crimech megan2 bio emission species +state real ebio_c5h8 ij misc 1 - - "ebio_c5h8" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_apinene ij misc 1 - - "ebio_apinene" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_bpinene ij misc 1 - - "ebio_bpinene" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_toluene ij misc 1 - - "ebio_toluene" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ch3cho ij misc 1 - - "ebio_ch3cho" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ch3co2h ij misc 1 - - "ebio_ch3co2h" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_tbut2ene ij misc 1 - - "ebio_tbut2ene" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_c2h5cho ij misc 1 - - "ebio_c2h5cho" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_nc4h10 ij misc 1 - - "ebio_nc4h10" "Actual biog emiss" "mol km^-2 hr^-1" # Ocean CO2 fluxes for the GHG options state real ebio_co2oce ij misc 1 - i06rh "ebio_co2oce" "Ocean CO2 fluxes" "mol km^-2 hr^-1" @@ -590,6 +656,9 @@ state real dvel_ald i%jf dvel 1 - - "d state real dvel_ch3cooh i%jf dvel 1 - - "dvel_ch3cooh" "CH3COOH deposition velocity " "cm/s" state real dvel_acet i%jf dvel 1 - - "dvel_acet" "ACET deposition velocity " "cm/s" state real dvel_mgly i%jf dvel 1 - - "dvel_mgly" "MGLY deposition velocity " "cm/s" +# 20130816 acd_ck_glysoa start +state real dvel_gly i%jf dvel 1 - - "dvel_gly" "GLY deposition velocity " "cm/s" +# 20130816 acd_ck_glysoa end state real dvel_paa i%jf dvel 1 - - "dvel_paa" "PAA deposition velocity " "cm/s" state real dvel_pooh i%jf dvel 1 - - "dvel_pooh" "POOH deposition velocity " "cm/s" state real dvel_pan i%jf dvel 1 - - "dvel_pan" "PAN deposition velocity " "cm/s" @@ -614,6 +683,11 @@ state real dvel_so2 i%jf dvel 1 - - "d state real dvel_so4 i%jf dvel 1 - - "dvel_so4" "SO4 deposition velocity " "cm/s" state real dvel_terpooh i%jf dvel 1 - - "dvel_terpooh" "TERPOOH deposition velocity " "cm/s" +# deposition velocities for diagnostic package, feel free to add if you like! +# +state real dep_vel i{kdv}j{ndv} misc 1 Z r "DEP_VEL" "deposition velocity" "cm/s" +state integer num_vert_mix - misc - - r "num_vert_mix" "Number of chemical species used in deposition; num_gas or num_chem" "" + # # Wet deposition # @@ -1138,6 +1212,207 @@ state real vash_8 ikjftb chem 1 - i0{12}rhusdf=(bdy_in state real vash_9 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "vash_9" "vash9 mixing ratio" "ug/kg-dryair" state real vash_10 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "vash_10" "vash10 mixing ratio" "ug/kg-dryair" +#Additional crimech gas variables inside the chem array... +state real hso3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hso3" "HSO3 concentration" "ppmv" +state real so3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "so3" "SO3 concentration" "ppmv" +state real nc4h10 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nc4h10" "NC4H10 concentration" "ppmv" +state real benzene ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "benzene" "BENZENE concentration" "ppmv" +state real oxyl ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oxyl" "OXYL concentration" "ppmv" +state real npropol ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "npropol" "NPROPOL concentration" "ppmv" +state real tbut2ene ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tbut2ene" "TBUT2ENE concentration" "ppmv" +state real c2h5cho ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "c2h5cho" "C2H5CHO concentration" "ppmv" +state real ch3co2h ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch3co2h" "CH3CO2H concentration" "ppmv" +state real ic3h7no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ic3h7no3" "IC3H7NO3 concentration" "ppmv" +state real ipropol ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ipropol" "IPROPOL concentration" "ppmv" +state real ch3no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch3no3" "CH3NO3 concentration" "ppmv" +state real c2h5no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "c2h5no3" "C2H5NO3 concentration" "ppmv" +state real hoc2h4no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hoc2h4no3" "HOC2H4NO3 concentration" "ppmv" +state real hoc2h4ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hoc2h4ooh" "HOC2H4OOH concentration" "ppmv" +state real carb14 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb14" "CARB14 concentration" "ppmv" +state real carb17 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb17" "CARB17 concentration" "ppmv" +state real rn10no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn10no3" "RN10NO3 concentration" "ppmv" +state real rn13no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn13no3" "RN13NO3 concentration" "ppmv" +state real rn19no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn19no3" "RN19NO3 concentration" "ppmv" +state real rn9no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn9no3" "RN9NO3 concentration" "ppmv" +state real rn12no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn12no3" "RN12NO3 concentration" "ppmv" +state real rn15no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn15no3" "RN15NO3 concentration" "ppmv" +state real rn18no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn18no3" "RN18NO3 concentration" "ppmv" +state real rn16no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn16no3" "RN16NO3 concentration" "ppmv" +state real rn10ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn10ooh" "RN10OOH concentration" "ppmv" +state real rn13ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn13ooh" "RN13OOH concentration" "ppmv" +state real rn16ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn16ooh" "RN16OOH concentration" "ppmv" +state real rn19ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn19ooh" "RN19OOH concentration" "ppmv" +state real rn8ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn8ooh" "RN8OOH concentration" "ppmv" +state real rn11ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn11ooh" "RN11OOH concentration" "ppmv" +state real rn14ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn14ooh" "RN14OOH concentration" "ppmv" +state real rn17ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn17ooh" "RN17OOH concentration" "ppmv" +state real rn9ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn9ooh" "RN9OOH concentration" "ppmv" +state real rn12ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn12ooh" "RN12OOH concentration" "ppmv" +state real rn15ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn15ooh" "RN15OOH concentration" "ppmv" +state real rn18ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn18ooh" "RN18OOH concentration" "ppmv" +state real nrn6ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nrn6ooh" "NRN6OOH concentration" "ppmv" +state real nrn9ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nrn9ooh" "NRN9OOH concentration" "ppmv" +state real nrn12ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nrn12ooh" "NRN12OOH concentration" "ppmv" +state real apinene ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "apinene" "APINENE concentration" "ppmv" +state real bpinene ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bpinene" "BPINENE concentration" "ppmv" +state real carb7 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb7" "CARB7 concentration" "ppmv" +state real carb10 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb10" "CARB10 concentration" "ppmv" +state real carb13 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb13" "CARB13 concentration" "ppmv" +state real carb16 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb16" "CARB16 concentration" "ppmv" +state real carb3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb3" "CARB3 concentration" "ppmv" +state real carb6 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb6" "CARB6 concentration" "ppmv" +state real carb9 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb9" "CARB9 concentration" "ppmv" +state real carb12 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb12" "CARB12 concentration" "ppmv" +state real carb15 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb15" "CARB15 concentration" "ppmv" +state real c2h5co3h ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "c2h5co3h" "C2H5CO3H concentration" "ppmv" +state real c2h5co3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "c2h5co3" "C2H5CO3 concentration" "ppmv" +state real ppn ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ppn" "PPN concentration" "ppmv" +state real hoch2cho ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hoch2cho" "HOCH2CHO concentration" "ppmv" +state real hoch2co3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hoch2co3" "HOCH2CO3 concentration" "ppmv" +state real hoch2co3h ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hoch2co3h" "HOCH2CO3H concentration" "ppmv" +state real phan ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "phan" "PHAN concentration" "ppmv" +state real ccarb12 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ccarb12" "CCARB12 concentration" "ppmv" +state real ch3cl ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch3cl" "CH3CL concentration" "ppmv" +state real ch2cl2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch2cl2" "CH2CL2 concentration" "ppmv" +state real chcl3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "chcl3" "CHCL3 concentration" "ppmv" +state real ch3ccl3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch3ccl3" "CH3CCL3 concentration" "ppmv" +state real cdicleth ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cdicleth" "CDICLETH concentration" "ppmv" +state real tdicleth ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tdicleth" "TDICLETH concentration" "ppmv" +state real tricleth ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tricleth" "TRICLETH concentration" "ppmv" +state real tce ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tce" "TCE concentration" "ppmv" +state real ucarb12 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ucarb12" "UCARB12 concentration" "ppmv" +state real ucarb10 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ucarb10" "UCARB10 concentration" "ppmv" +state real ru14no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ru14no3" "RU14NO3 concentration" "ppmv" +state real ru14ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ru14ooh" "RU14OOH concentration" "ppmv" +state real ru12ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ru12ooh" "RU12OOH concentration" "ppmv" +state real ru10ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ru10ooh" "RU10OOH concentration" "ppmv" +state real ru12pan ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ru12pan" "RU12PAN concentration" "ppmv" +state real nucarb12 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nucarb12" "NUCARB12 concentration" "ppmv" +state real nru14ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nru14ooh" "NRU14OOH concentration" "ppmv" +state real nru12ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nru12ooh" "NRU12OOH concentration" "ppmv" +state real noa ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "noa" "NOA concentration" "ppmv" +state real ra13no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra13no3" "RA13NO3 concentration" "ppmv" +state real ra13ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra13ooh" "RA13OOH concentration" "ppmv" +state real udcarb8 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "udcarb8" "UDCARB8 concentration" "ppmv" +state real aroh14 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "aroh14" "AROH14 concentration" "ppmv" +state real raroh14 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "raroh14" "RAROH14 concentration" "ppmv" +state real arnoh14 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "arnoh14" "ARNOH14 concentration" "ppmv" +state real ra16no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra16no3" "RA16NO3 concentration" "ppmv" +state real ra16ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra16ooh" "RA16OOH concentration" "ppmv" +state real udcarb11 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "udcarb11" "UDCARB11 concentration" "ppmv" +state real aroh17 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "aroh17" "AROH17 concentration" "ppmv" +state real raroh17 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "raroh17" "RAROH17 concentration" "ppmv" +state real arnoh17 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "arnoh17" "ARNOH17 concentration" "ppmv" +state real udcarb14 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "udcarb14" "UDCARB14 concentration" "ppmv" +state real ra19no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra19no3" "RA19NO3 concentration" "ppmv" +state real ra19ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra19ooh" "RA19OOH concentration" "ppmv" +state real rtn28no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn28no3" "RTN28NO3 concentration" "ppmv" +state real rtn28ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn28ooh" "RTN28OOH concentration" "ppmv" +state real tncarb26 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tncarb26" "TNCARB26 concentration" "ppmv" +state real rtn26ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn26ooh" "RTN26OOH concentration" "ppmv" +state real nrtn28ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nrtn28ooh" "NRTN28OOH concentration" "ppmv" +state real rtn26pan ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn26pan" "RTN26PAN concentration" "ppmv" +state real rtn25ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn25ooh" "RTN25OOH concentration" "ppmv" +state real rtn24ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn24ooh" "RTN24OOH concentration" "ppmv" +state real rtn23ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn23ooh" "RTN23OOH concentration" "ppmv" +state real rtn14ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn14ooh" "RTN14OOH concentration" "ppmv" +state real rtn10ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn10ooh" "RTN10OOH concentration" "ppmv" +state real tncarb10 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tncarb10" "TNCARB10 concentration" "ppmv" +state real rtn25no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn25no3" "RTN25NO3 concentration" "ppmv" +state real tncarb15 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tncarb15" "TNCARB15 concentration" "ppmv" +state real rcooh25 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rcooh25" "RCOOH25 concentration" "ppmv" +state real rtx28no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtx28no3" "RTX28NO3 concentration" "ppmv" +state real rtx28ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtx28ooh" "RTX28OOH concentration" "ppmv" +state real txcarb24 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "txcarb24" "TXCARB24 concentration" "ppmv" +state real rtx24no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtx24no3" "RTX24NO3 concentration" "ppmv" +state real rtx24ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtx24ooh" "RTX24OOH concentration" "ppmv" +state real txcarb22 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "txcarb22" "TXCARB22 concentration" "ppmv" +state real rtx22no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtx22no3" "RTX22NO3 concentration" "ppmv" +state real rtx22ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtx22ooh" "RTX22OOH concentration" "ppmv" +state real nrtx28ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nrtx28ooh" "NRTX28OOH concentration" "ppmv" +state real carb11a ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "carb11a" "CARB11A concentration" "ppmv" +state real anhy ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "anhy" "ANHY concentration" "ppmv" +state real ch3o2no2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch3o2no2" "CH3O2NO2 concentration" "ppmv" +state real c2h5ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "c2h5ooh" "C2H5OOH concentration" "ppmv" +state real ch3cho ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch3cho" "CH3CHO concentration" "ppmv" +state real c5h8 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "c5h8" "C5H8 concentration" "ppmv" +state real toluene ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "toluene" "TOLUENE concentration" "ppmv" + + +state real rtn23no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn23no3" "rtn23no3 concentration" "ppmv" + +state real tncarb12 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tncarb12" "tncarb12 concentration" "ppmv" +state real tncarb11 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tncarb11" "tncarb11 concentration" "ppmv" +state real tm123b ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tm123b" "tm123b concentration" "ppmv" +state real tm124b ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tm124b" "tm124b concentration" "ppmv" +state real tm135b ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tm135b" "tm135b concentration" "ppmv" +state real oethtol ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oethtol" "oethtol concentration" "ppmv" + +state real methtol ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "methtol" "methtol concentration" "ppmv" +state real pethtol ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pethtol" "pethtol concentration" "ppmv" +state real ra22no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra22no3" "ra22no3 concentration" "ppmv" +state real ra22ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra22ooh" "ra22ooh concentration" "ppmv" + +state real dime35eb ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "dime35eb" "dime35eb concentration" "ppmv" +state real ra25no3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra25no3" "ra25no3 concentration" "ppmv" +state real udcarb17 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "udcarb17" "udcarb17 concentration" "ppmv" + +state real ra25ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra25ooh" "ra25ooh concentration" "ppmv" + +state real ch3s ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch3s" "CH3S concentration" "ppmv" +state real ch3so ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch3so" "CH3SO concentration" "ppmv" +state real msia ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "msia" "MSIA concentration" "ppmv" + +state real clno2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "clno2" "ClNO2 concentration" "ppmv" + +state real ch3oo ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch3oo" "CH3OO concentration" "ppmv" +state real c2h5o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "c2h5o2" "C2H5O2 concentration" "ppmv" +state real hoch2ch2o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hoch2ch2o2" "HOCH2CH2O2 concentration" "ppmv" +state real ic3h7o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ic3h7o2" "IC3H7O2 concentration" "ppmv" +state real rn10o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn10o2" "RN10O2 concentration" "ppmv" +state real rn13o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn13o2" "RN13O2 concentration" "ppmv" +state real rn16o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn16o2" "RN16O2 concentration" "ppmv" +state real rn19o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn19o2" "RN19O2 concentration" "ppmv" +state real rn9o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn9o2" "RN9O2 concentration" "ppmv" +state real rn12o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn12o2" "RN12O2 concentration" "ppmv" +state real rn15o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn15o2" "RN15O2 concentration" "ppmv" +state real rn18o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn18o2" "RN18O2 concentration" "ppmv" +state real nrn6o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nrn6o2" "NRN6O2 concentration" "ppmv" +state real nrn9o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nrn9o2" "NRN9O2 concentration" "ppmv" +state real nrn12o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nrn12o2" "NRN12O2 concentration" "ppmv" +state real rn11o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn11o2" "RN11O2 concentration" "ppmv" +state real rn14o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn14o2" "RN14O2 concentration" "ppmv" +state real rn8o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn8o2" "RN8O2 concentration" "ppmv" +state real rn17o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn17o2" "RN17O2 concentration" "ppmv" +state real rn13ao2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn13ao2" "RN13AO2 concentration" "ppmv" +state real rn16ao2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn16ao2" "RN16AO2 concentration" "ppmv" +state real rn15ao2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn15ao2" "RN15AO2 concentration" "ppmv" +state real rn18ao2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rn18ao2" "RN18AO2 concentration" "ppmv" +state real ru10o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ru10o2" "RU10O2 concentration" "ppmv" +state real nru14o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nru14o2" "NRU14O2 concentration" "ppmv" +state real nru12o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nru12o2" "NRU12O2 concentration" "ppmv" +state real ra13o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra13o2" "RA13O2 concentration" "ppmv" +state real nrtx28o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nrtx28o2" "NRTX28O2 concentration" "ppmv" +state real rtx24o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtx24o2" "RTX24O2 concentration" "ppmv" +state real rtx28o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtx28o2" "RTX28O2 concentration" "ppmv" +state real rtn25o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn25o2" "RTN25O2 concentration" "ppmv" +state real rtn24o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn24o2" "RTN24O2 concentration" "ppmv" +state real rtn23o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn23o2" "RTN23O2 concentration" "ppmv" +state real rtn14o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn14o2" "RTN14O2 concentration" "ppmv" +state real rtn10o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn10o2" "RTN10O2 concentration" "ppmv" +state real nrtn28o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nrtn28o2" "NRTN28O2 concentration" "ppmv" +state real rtn26o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn26o2" "RTN26O2 concentration" "ppmv" +state real rtn28o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtn28o2" "RTN28O2 concentration" "ppmv" +state real ra19ao2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra19ao2" "RA19AO2 concentration" "ppmv" +state real ru14o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ru14o2" "RU14O2 concentration" "ppmv" +state real ru12o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ru12o2" "RU12O2 concentration" "ppmv" +state real ra16o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra16o2" "RA16O2 concentration" "ppmv" +state real rtx22o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "rtx22o2" "RTX22O2 concentration" "ppmv" +state real ra22ao2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra22ao2" "RA22AO2 concentration" "ppmv" +state real ra22bo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra22bo2" "RA22BO2 concentration" "ppmv" +state real ra25o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra25o2" "RA25O2 concentration" "ppmv" +state real ra19co2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ra19co2" "RA19CO2 concentration" "ppmv" + #tracer variables inside the chem array...for ensemble run or not # @@ -2451,10 +2726,12 @@ rconfig integer kfuture namelist,chem 1 1 rconfig integer kfire namelist,chem 1 1 - "kfire" "" "" rconfig integer kemit_aircraft namelist,chem 1 1 - "kemit_aircraft" "" "" rconfig integer kdvel namelist,chem 1 1 - "kdvel" "" "" +rconfig integer ndepvel namelist,chem 1 140 - "ndepvel" "" "" +rconfig integer kdepvel namelist,chem 1 1 - "kdepvel" "" "" rconfig integer erosion_dim namelist,chem 1 3 - "erosion_dim" "" "" rconfig integer biomass_emiss_opt namelist,chem max_domains 0 rh "biomass_emiss_opt" "" "" rconfig integer cam_mam_mode namelist,chem 1 3 irh "cam_mam_mode" "" "" -rconfig integer cam_mam_nspec namelist,chem 1 74 irh "cam_mam_nspec" "" "" +rconfig integer cam_mam_nspec namelist,chem 1 85 irh "cam_mam_nspec" "" "" rconfig logical CAM_MP_MAM_cpled namelist,chem 1 .true. irh "CAM_MP_MAM_cpled" "" "" # Lightning rconfig integer lightning_opt namelist,chem max_domains 0 rh "lightning_opt" "" "" @@ -2503,6 +2780,7 @@ rconfig integer aer_aerodynres_opt namelist,chem max_domains rconfig integer emiss_opt namelist,chem max_domains 4 rh "emiss_opt" "" "" rconfig integer emiss_opt_vol namelist,chem max_domains 0 rh "emiss_opt_vol" "" "" rconfig integer dust_opt namelist,chem 1 0 rh "dust_opt" "" "" +rconfig integer dust_schme namelist,chem 1 2 rh "dust_schme" "" "" rconfig integer dmsemis_opt namelist,chem 1 0 rh "dmsemis_opt" "" "" rconfig integer seas_opt namelist,chem 1 0 rh "seas_opt" "" "" rconfig integer bio_emiss_opt namelist,chem max_domains 0 rh "bio_emiss_opt" "" "" @@ -2552,6 +2830,9 @@ rconfig integer track_rad_num namelist,chem 1 17 rconfig integer track_tuv_num namelist,chem 1 30 - "tuv_jmax in module_wave_data" "" "" rconfig integer track_tuv_lev namelist,chem 1 51 - "nref in module_ftuv_driver" "" "" +# control for N2O5 heterogenenous chemistry option in MOSAIC +rconfig integer n2o5_hetchem namelist,chem 1 0 rh "n2o5_hetchem" "" "" + # CHEMISTRY PACKAGE DEFINITIONS # package prescribe_aerosol chem_opt==0 - - @@ -2585,7 +2866,8 @@ package cbmz_mosaic_dms_8bin_aq chem_opt==34 - chem:so2,sulf package cbmzsorg_aq chem_opt==35 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,nacwj,nacwi,clcwj,clcwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw package radm2sorg_aqchem chem_opt==41 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,hcl,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,nacwj,nacwi,clcwj,clcwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw -package racmsorg_aqchem chem_opt==42 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,nacwj,nacwi,clcwj,clcwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw +package racmsorg_aqchem_kpp chem_opt==42 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,nacwj,nacwi,clcwj,clcwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw +package racm_esrlsorg_aqchem_kpp chem_opt==43 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,hace,ishp,ison,mahp,mpan,nald,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,nacwj,nacwi,clcwj,clcwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw #cms++ package radm2_kpp chem_opt==101 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,ho,ho2 @@ -2610,7 +2892,7 @@ package cbm4_kpp chem_opt==110 - chem:no,no package mozart_kpp chem_opt==111 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,c10h16,terpo2,tol,cres,to2,xoh,onit,isopn,dms,nh3,meko2 # KPP mechanism from mozart + gocart -package mozcart_kpp chem_opt==112 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,c10h16,terpo2,tol,cres,to2,xoh,onit,isopn,dms,nh3,meko2,p25,p10,bc1,bc2,oc1,oc2,dust_1,dust_2,dust_3,dust_4,dust_5,seas_1,seas_2,seas_3,seas_4 +package mozcart_kpp chem_opt==112 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,c10h16,terpo2,tol,cres,to2,xoh,onit,isopn,dms,nh3,meko2,p25,bc1,bc2,oc1,oc2,dust_1,dust_2,dust_3,dust_4,dust_5,seas_1,seas_2,seas_3,seas_4,p10 # KPP mechanism from CBMZ package cbmz_bb_kpp chem_opt==120 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,ch4,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2 @@ -2656,7 +2938,7 @@ package cbmz_cam_mam3_noaq chem_opt==501 - chem:so2, package cbmz_cam_mam7_noaq chem_opt==502 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,soag,so4_a1,nh4_a1,pom_a1,soa_a1,bc_a1,ncl_a1,wtr_a1,num_a1,so4_a2,nh4_a2,soa_a2,ncl_a2,wtr_a2,num_a2,pom_a3,bc_a3,wtr_a3,num_a3,ncl_a4,so4_a4,nh4_a4,wtr_a4,num_a4,dst_a5,so4_a5,nh4_a5,wtr_a5,num_a5,ncl_a6,so4_a6,nh4_a6,wtr_a6,num_a6,dst_a7,so4_a7,nh4_a7,wtr_a7,num_a7 -package cbmz_cam_mam3_aq chem_opt==503 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,soag,so4_a1,pom_a1,soa_a1,bc_a1,dst_a1,ncl_a1,wtr_a1,num_a1,so4_a2,soa_a2,ncl_a2,wtr_a2,num_a2,dst_a3,ncl_a3,so4_a3,wtr_a3,num_a3,so4_c1,pom_c1,soa_c1,bc_c1,dst_c1,ncl_c1,num_c1,so4_c2,soa_c2,ncl_c2,num_c2,dst_c3,ncl_c3,so4_c3,num_c3 +package cbmz_cam_mam3_aq chem_opt==503 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,dms,msa,dmso,dmso2,ch3so2h,ch3sch2oo,ch3so2,ch3so3,ch3so2oo,ch3so2ch2oo,mtf,soag,so4_a1,pom_a1,soa_a1,bc_a1,dst_a1,ncl_a1,wtr_a1,num_a1,so4_a2,soa_a2,ncl_a2,wtr_a2,num_a2,dst_a3,ncl_a3,so4_a3,wtr_a3,num_a3,so4_c1,pom_c1,soa_c1,bc_c1,dst_c1,ncl_c1,num_c1,so4_c2,soa_c2,ncl_c2,num_c2,dst_c3,ncl_c3,so4_c3,num_c3 package cbmz_cam_mam7_aq chem_opt==504 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,soag,so4_a1,nh4_a1,pom_a1,soa_a1,bc_a1,ncl_a1,wtr_a1,num_a1,so4_a2,nh4_a2,soa_a2,ncl_a2,wtr_a2,num_a2,pom_a3,bc_a3,wtr_a3,num_a3,ncl_a4,so4_a4,nh4_a4,wtr_a4,num_a4,dst_a5,so4_a5,nh4_a5,wtr_a5,num_a5,ncl_a6,so4_a6,nh4_a6,wtr_a6,num_a6,dst_a7,so4_a7,nh4_a7,wtr_a7,num_a7,so4_c1,nh4_c1,pom_c1,soa_c1,bc_c1,ncl_c1,num_c1,so4_c2,nh4_c2,soa_c2,ncl_c2,num_c2,pom_c3,bc_c3,num_c3,ncl_c4,so4_c4,nh4_c4,num_c4,dst_c5,so4_c5,nh4_c5,num_c5,ncl_c6,so4_c6,nh4_c6,num_c6,dst_c7,so4_c7,nh4_c7,num_c7 @@ -2665,6 +2947,14 @@ package cbmz_cam_mam7_aq chem_opt==504 - chem:so2,su #package radm2_cam_mam7 chem_opt==412 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,hcl,ho,ho2,soag,so4_a1,nh4_a1,pom_a1,soa_a1,bc_a1,ncl_a1,wtr_a1,num_a1,so4_a2,nh4_a2,soa_a2,ncl_a2,wtr_a2,num_a2,pom_a3,bc_a3,wtr_a3,num_a3,ncl_a4,so4_a4,nh4_a4,wtr_a4,num_a4,dst_a5,so4_a5,nh4_a5,wtr_a5,num_a5,ncl_a6,so4_a6,nh4_a6,wtr_a6,num_a6,dst_a7,so4_a7,nh4_a7,wtr_a7,num_a7 # # + +# CRIMECH gas phase +package crimech_kpp chem_opt==600 - chem:dms,dmso,dmso2,ch3sch2oo,ch3s,ch3so,ch3so2,ch3so3,msa,msia,nh3,hcl,so2,hso3,no2,o3,hno3,h2o2,ch3cho,hcho,ch3ooh,c2h5ooh,paa,hcooh,n2o5,no3,pan,c3h8,nc4h10,c2h6,co,c2h4,toluene,oxyl,aco3,hono,hno4,ket,c5h8,ho,ho2,so3,no,benzene,npropol,c2h2,c3h6,tbut2ene,c2h5cho,ch3co2h,mek,ch3oh,c2h5oh,ipropol,ch3no3,c2h5no3,hoc2h4no3,prooh,hoc2h4ooh,carb14,carb17,rn10no3,rn13no3,rn19no3,rn9no3,rn12no3,rn15no3,rn18no3,rn16no3,rn10ooh,rn13ooh,rn16ooh,rn19ooh,rn8ooh,rn11ooh,rn14ooh,rn17ooh,rn9ooh,rn12ooh,rn15ooh,rn18ooh,nrn6ooh,nrn9ooh,nrn12ooh,apinene,bpinene,carb7,carb10,carb13,carb16,carb3,carb6,carb9,carb12,carb15,c2h5co3h,c2h5co3,ppn,hoch2cho,hoch2co3,hoch2co3h,phan,ccarb12,ch3cl,ch2cl2,chcl3,ch3ccl3,cdicleth,tdicleth,tricleth,tce,ucarb12,ucarb10,ru14no3,ru14ooh,ru12ooh,ru10ooh,mpan,ru12pan,nucarb12,nru14ooh,nru12ooh,noa,ra13no3,ra13ooh,udcarb8,aroh14,raroh14,arnoh14,ra16no3,ra16ooh,udcarb11,aroh17,raroh17,arnoh17,udcarb14,ra19co2,ra19no3,ra19ooh,rtn28no3,rtn28ooh,tncarb26,rtn26ooh,nrtn28ooh,rtn26pan,rtn25ooh,rtn24ooh,rtn23ooh,rtn14ooh,rtn10ooh,tncarb10,rtn25no3,tncarb15,rcooh25,rtx28no3,rtx28ooh,txcarb24,rtx24no3,rtx24ooh,txcarb22,rtx22no3,rtx22ooh,nrtx28ooh,carb11a,anhy,ch3o2no2,ch4,sulf,rtn23no3,tncarb12,tncarb11,tm123b,tm124b,tm135b,oethtol,methtol,pethtol,ra22no3,ra22ooh,dime35eb,ra25no3,udcarb17,ra25ooh,ch3oo,c2h5o2,hoch2ch2o2,ic3h7o2,rn10o2,rn13o2,rn16o2,rn19o2,rn9o2,rn12o2,rn15o2,rn18o2,nrn6o2,nrn9o2,nrn12o2,rn11o2,rn14o2,rn8o2,rn17o2,rn13ao2,rn16ao2,rn15ao2,rn18ao2,ru10o2,nru14o2,nru12o2,ra13o2,nrtx28o2,rtx24o2,rtx28o2,rtn25o2,rtn24o2,rtn23o2,rtn14o2,rtn10o2,nrtn28o2,rtn26o2,rtn28o2,ra19ao2,ru14o2,ru12o2,ra16o2,rtx22o2,ra22ao2,ra22bo2,ra25o2,ic3h7no3 +# CRIMECH gas phase and original aqueous MOSAIC +package cri_mosaic_8bin_aq_kpp chem_opt==601 - chem:dms,dmso,dmso2,ch3sch2oo,ch3s,ch3so,ch3so2,ch3so3,msa,msia,nh3,hcl,so2,hso3,no2,o3,hno3,h2o2,ch3cho,hcho,ch3ooh,c2h5ooh,paa,hcooh,n2o5,no3,pan,c3h8,nc4h10,c2h6,co,c2h4,toluene,oxyl,aco3,hono,hno4,ket,c5h8,ho,ho2,so3,no,benzene,npropol,c2h2,c3h6,tbut2ene,c2h5cho,ch3co2h,mek,ch3oh,c2h5oh,ipropol,ch3no3,c2h5no3,hoc2h4no3,prooh,hoc2h4ooh,carb14,carb17,rn10no3,rn13no3,rn19no3,rn9no3,rn12no3,rn15no3,rn18no3,rn16no3,rn10ooh,rn13ooh,rn16ooh,rn19ooh,rn8ooh,rn11ooh,rn14ooh,rn17ooh,rn9ooh,rn12ooh,rn15ooh,rn18ooh,nrn6ooh,nrn9ooh,nrn12ooh,apinene,bpinene,carb7,carb10,carb13,carb16,carb3,carb6,carb9,carb12,carb15,c2h5co3h,c2h5co3,ppn,hoch2cho,hoch2co3,hoch2co3h,phan,ccarb12,ch3cl,ch2cl2,chcl3,ch3ccl3,cdicleth,tdicleth,tricleth,tce,ucarb12,ucarb10,ru14no3,ru14ooh,ru12ooh,ru10ooh,mpan,ru12pan,nucarb12,nru14ooh,nru12ooh,noa,ra13no3,ra13ooh,udcarb8,aroh14,raroh14,arnoh14,ra16no3,ra16ooh,udcarb11,aroh17,raroh17,arnoh17,udcarb14,ra19co2,ra19no3,ra19ooh,rtn28no3,rtn28ooh,tncarb26,rtn26ooh,nrtn28ooh,rtn26pan,rtn25ooh,rtn24ooh,rtn23ooh,rtn14ooh,rtn10ooh,tncarb10,rtn25no3,tncarb15,rcooh25,rtx28no3,rtx28ooh,txcarb24,rtx24no3,rtx24ooh,txcarb22,rtx22no3,rtx22ooh,nrtx28ooh,carb11a,anhy,ch3o2no2,ch4,sulf,rtn23no3,tncarb12,tncarb11,tm123b,tm124b,tm135b,oethtol,methtol,pethtol,ra22no3,ra22ooh,dime35eb,ra25no3,udcarb17,ra25ooh,clno2,ch3oo,c2h5o2,hoch2ch2o2,ic3h7o2,rn10o2,rn13o2,rn16o2,rn19o2,rn9o2,rn12o2,rn15o2,rn18o2,nrn6o2,nrn9o2,nrn12o2,rn11o2,rn14o2,rn8o2,rn17o2,rn13ao2,rn16ao2,rn15ao2,rn18ao2,ru10o2,nru14o2,nru12o2,ra13o2,nrtx28o2,rtx24o2,rtx28o2,rtn25o2,rtn24o2,rtn23o2,rtn14o2,rtn10o2,nrtn28o2,rtn26o2,rtn28o2,ra19ao2,ru14o2,ru12o2,ra16o2,rtx22o2,ra22ao2,ra22bo2,ra25o2,ic3h7no3,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,num_a08,so4_cw01,no3_cw01,cl_cw01,nh4_cw01,na_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,cl_cw02,nh4_cw02,na_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,cl_cw03,nh4_cw03,na_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,cl_cw04,nh4_cw04,na_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04,so4_cw05,no3_cw05,cl_cw05,nh4_cw05,na_cw05,oin_cw05,oc_cw05,bc_cw05,num_cw05,so4_cw06,no3_cw06,cl_cw06,nh4_cw06,na_cw06,oin_cw06,oc_cw06,bc_cw06,num_cw06,so4_cw07,no3_cw07,cl_cw07,nh4_cw07,na_cw07,oin_cw07,oc_cw07,bc_cw07,num_cw07,so4_cw08,no3_cw08,cl_cw08,nh4_cw08,na_cw08,oin_cw08,oc_cw08,bc_cw08,num_cw08 +package cri_mosaic_4bin_aq_kpp chem_opt==611 - chem:dms,dmso,dmso2,ch3sch2oo,ch3s,ch3so,ch3so2,ch3so3,msa,msia,nh3,hcl,so2,hso3,no2,o3,hno3,h2o2,ch3cho,hcho,ch3ooh,c2h5ooh,paa,hcooh,n2o5,no3,pan,c3h8,nc4h10,c2h6,co,c2h4,toluene,oxyl,aco3,hono,hno4,ket,c5h8,ho,ho2,so3,no,benzene,npropol,c2h2,c3h6,tbut2ene,c2h5cho,ch3co2h,mek,ch3oh,c2h5oh,ipropol,ch3no3,c2h5no3,hoc2h4no3,prooh,hoc2h4ooh,carb14,carb17,rn10no3,rn13no3,rn19no3,rn9no3,rn12no3,rn15no3,rn18no3,rn16no3,rn10ooh,rn13ooh,rn16ooh,rn19ooh,rn8ooh,rn11ooh,rn14ooh,rn17ooh,rn9ooh,rn12ooh,rn15ooh,rn18ooh,nrn6ooh,nrn9ooh,nrn12ooh,apinene,bpinene,carb7,carb10,carb13,carb16,carb3,carb6,carb9,carb12,carb15,c2h5co3h,c2h5co3,ppn,hoch2cho,hoch2co3,hoch2co3h,phan,ccarb12,ch3cl,ch2cl2,chcl3,ch3ccl3,cdicleth,tdicleth,tricleth,tce,ucarb12,ucarb10,ru14no3,ru14ooh,ru12ooh,ru10ooh,mpan,ru12pan,nucarb12,nru14ooh,nru12ooh,noa,ra13no3,ra13ooh,udcarb8,aroh14,raroh14,arnoh14,ra16no3,ra16ooh,udcarb11,aroh17,raroh17,arnoh17,udcarb14,ra19co2,ra19no3,ra19ooh,rtn28no3,rtn28ooh,tncarb26,rtn26ooh,nrtn28ooh,rtn26pan,rtn25ooh,rtn24ooh,rtn23ooh,rtn14ooh,rtn10ooh,tncarb10,rtn25no3,tncarb15,rcooh25,rtx28no3,rtx28ooh,txcarb24,rtx24no3,rtx24ooh,txcarb22,rtx22no3,rtx22ooh,nrtx28ooh,carb11a,anhy,ch3o2no2,ch4,sulf,rtn23no3,tncarb12,tncarb11,tm123b,tm124b,tm135b,oethtol,methtol,pethtol,ra22no3,ra22ooh,dime35eb,ra25no3,udcarb17,ra25ooh,clno2,ch3oo,c2h5o2,hoch2ch2o2,ic3h7o2,rn10o2,rn13o2,rn16o2,rn19o2,rn9o2,rn12o2,rn15o2,rn18o2,nrn6o2,nrn9o2,nrn12o2,rn11o2,rn14o2,rn8o2,rn17o2,rn13ao2,rn16ao2,rn15ao2,rn18ao2,ru10o2,nru14o2,nru12o2,ra13o2,nrtx28o2,rtx24o2,rtx28o2,rtn25o2,rtn24o2,rtn23o2,rtn14o2,rtn10o2,nrtn28o2,rtn26o2,rtn28o2,ra19ao2,ru14o2,ru12o2,ra16o2,rtx22o2,ra22ao2,ra22bo2,ra25o2,ic3h7no3,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_cw01,no3_cw01,cl_cw01,nh4_cw01,na_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,cl_cw02,nh4_cw02,na_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,cl_cw03,nh4_cw03,na_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,cl_cw04,nh4_cw04,na_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04 + + #emission package definitions # package eradm emiss_opt==2 - emis_ant:e_iso,e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt,e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_nh3 @@ -2674,12 +2964,15 @@ package ecptec emiss_opt==5 - emis_ant: package gocart_ecptec emiss_opt==6 - emis_ant:e_so2,e_sulf,e_bc,e_oc,e_pm_25,e_pm_10 package mozem emiss_opt==7 - emis_ant:e_co,e_no,e_no2,e_bigalk,e_bigene,e_c2h4,e_c2h5oh,e_c2h6,e_c3h6,e_c3h8,e_ch2o,e_ch3cho,e_ch3coch3,e_ch3oh,e_mek,e_so2,e_toluene,e_nh3,e_isop,e_c10h16,e_sulf package mozcem emiss_opt==8 - emis_ant:e_co,e_no,e_no2,e_bigalk,e_bigene,e_c2h4,e_c2h5oh,e_c2h6,e_c3h6,e_c3h8,e_ch2o,e_ch3cho,e_ch3coch3,e_ch3oh,e_mek,e_so2,e_toluene,e_nh3,e_isop,e_c10h16,e_pm_10,e_pm_25,e_bc,e_oc,e_sulf -package cammam emiss_opt==9 - emis_ant:e_iso,e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt,e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_nh3,e_ecj,e_orgj,e_so4i,e_so4j,e_soag_bigene,e_soag_isoprene,e_soag_terpene,e_soag_toluene,e_dust_a1,e_dust_a3,e_ncl_a1,e_ncl_a2,e_ncl_a3,e_orgj_num,e_ecj_num,e_so4j_num,e_so4i_num +package cammam emiss_opt==9 - emis_ant:e_iso,e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt,e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_nh3,e_dms,e_ecj,e_orgj,e_so4i,e_so4j,e_soag_bigene,e_soag_isoprene,e_soag_terpene,e_soag_toluene,e_dust_a1,e_dust_a3,e_ncl_a1,e_ncl_a2,e_ncl_a3,e_orgj_num,e_ecj_num,e_so4j_num,e_so4i_num + package mozmem emiss_opt==10 - emis_ant:e_co,e_no,e_no2,e_bigalk,e_bigene,e_c2h4,e_c2h5oh,e_c2h6,e_c3h6,e_c3h8,e_ch2o,e_ch3cho,e_ch3coch3,e_ch3oh,e_mek,e_so2,e_toluene,e_nh3,e_isop,e_c10h16,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_co_a,e_orgj_a,e_co_bb,e_orgj_bb,e_voca,e_vocbb package esaprcnov emiss_opt==13 - emis_ant:e_so2,e_c2h6,e_c3h8,e_c2h2,e_alk3,e_alk4,e_alk5,e_ethene,e_c3h6,e_ole1,e_ole2,e_aro1,e_aro2,e_hcho,e_ccho,e_rcho,e_acet,e_mek,e_isoprene,e_terp,e_sesq,e_co,e_no,e_no2,e_phen,e_cres,e_meoh,e_gly,e_mgly,e_bacl,e_isoprod,e_methacro,e_mvk,e_prod2,e_ch4,e_bald,e_hcooh,e_cco_oh,e_rco_oh,e_nh3,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_orgi_a,e_orgj_a,e_orgi_bb,e_orgj_bb # Anthropogenic CO2, CO and CH4 emissions: package eco2 emiss_opt==16 - emis_ant:e_co2,e_co2tst,e_co package eghg emiss_opt==17 - emis_ant:e_co2,e_co2tst,e_co,e_cotst,e_ch4,e_ch4tst +package ecrimech emiss_opt==19 - emis_ant:e_co,e_no,e_no2,e_so2,e_nh3,e_c2h6,e_c3h8,e_c2h4,e_c3h6,e_c5h8,e_tm123b,e_tm124b,e_tm135b,e_oethtol,e_methtol,e_pethtol,e_dime35eb,e_hcho,e_ch3cho,e_c2h5cho,e_ket,e_mek,e_ch3oh,e_c2h5oh,e_c2h2,e_benzene,e_nc4h10,e_toluene,e_oxyl,e_tbut2ene,e_ch3co2h +package ecrimechtno emiss_opt==20 - emis_ant:e_co,e_no,e_no2,e_so2,e_nh3,e_c2h6,e_c3h8,e_c2h4,e_c3h6,e_c5h8,e_tm123b,e_tm124b,e_tm135b,e_oethtol,e_methtol,e_pethtol,e_dime35eb,e_hcho,e_ch3cho,e_c2h5cho,e_ket,e_mek,e_ch3oh,e_c2h5oh,e_c2h2,e_benzene,e_nc4h10,e_toluene,e_oxyl,e_tbut2ene,e_ch3co2h,e_bc_1,e_ec_1_25,e_ec_25_10,e_oc_dom,e_oc_tra,e_oc_25_10,e_pm25,e_oin_25,e_oin_10 # package vash emiss_opt_vol==1 - emis_vol:e_vash1,e_vash2,e_vash3,e_vash4,e_vash5,e_vash6,e_vash7,e_vash8,e_vash9,e_vash10 package vashso2 emiss_opt_vol==2 - emis_vol:e_vash1,e_vash2,e_vash3,e_vash4,e_vash5,e_vash6,e_vash7,e_vash8,e_vash9,e_vash10,e_vso2 @@ -2697,7 +2990,9 @@ package wesely gas_drydep_opt==1 - - # # diagnostic packages, first for deposition velocities (original package for Mozart) # -package depvel1 diagnostic_chem==1 - dvel:dvel_o3,dvel_no,dvel_no2,dvel_nh3,dvel_hno3,dvel_hno4,dvel_h2o2,dvel_co,dvel_ch3ooh,dvel_hcho,dvel_ch3oh,dvel_eo2,dvel_ald,dvel_ch3cooh,dvel_acet,dvel_mgly,dvel_paa,dvel_pooh,dvel_pan,dvel_mpan,dvel_mco3,dvel_mvkooh,dvel_c2h5oh,dvel_etooh,dvel_prooh,dvel_acetp,dvel_onit,dvel_onitr,dvel_isooh,dvel_acetol,dvel_glyald,dvel_hydrald,dvel_alkooh,dvel_mekooh,dvel_tolooh,dvel_xooh,dvel_so2,dvel_so4,dvel_terpooh +# 20130925 acd_ck_bugfix start +package depvel1 diagnostic_chem==1 - dvel:dvel_o3,dvel_no,dvel_no2,dvel_nh3,dvel_hno3,dvel_hno4,dvel_h2o2,dvel_co,dvel_ch3ooh,dvel_hcho,dvel_ch3oh,dvel_eo2,dvel_ald,dvel_ch3cooh,dvel_acet,dvel_mgly,dvel_gly,dvel_paa,dvel_pooh,dvel_pan,dvel_mpan,dvel_mco3,dvel_mvkooh,dvel_c2h5oh,dvel_etooh,dvel_prooh,dvel_acetp,dvel_onit,dvel_onitr,dvel_isooh,dvel_acetol,dvel_glyald,dvel_hydrald,dvel_alkooh,dvel_mekooh,dvel_tolooh,dvel_xooh,dvel_so2,dvel_so4,dvel_terpooh +# 20130925 acd_ck_bugfix end # package gunther1 bio_emiss_opt==1 - - package beis314 bio_emiss_opt==2 - - @@ -2721,6 +3016,10 @@ package opt_out opt_pars_out==1 - ext_coef:extcof3,e # dust and sea salt packages package dustgocart dust_opt==1 - emis_dust:edust1,edust2,edust3,edust4,edust5 package dustgocartafwa dust_opt==3 - emis_dust:edust1,edust2,edust3,edust4,edust5 +package dustuoc dust_opt==4 - emis_dust:edust1,edust2,edust3,edust4,edust5 +package shao_2001 dust_schme==1 - emis_dust:edust1,edust2,edust3,edust4,edust5 +package shao_2004 dust_schme==2 - emis_dust:edust1,edust2,edust3,edust4,edust5 +package shao_2011 dust_schme==3 - emis_dust:edust1,edust2,edust3,edust4,edust5 package seasgocart seas_opt==1 - emis_seas:eseas1,eseas2,eseas3,eseas4 package dmsgocart dmsemis_opt==1 - - package volume_approx aer_op_opt==1 - - @@ -2742,6 +3041,8 @@ package emiss_inpt_cb4 emiss_inpt_opt==103 - package emiss_inpt_pnnl_mam emiss_inpt_opt==104 - - package emiss_inpt_mozcem emiss_inpt_opt==111 - - package emiss_inpt_mozmem emiss_inpt_opt==112 - - +package emiss_inpt_tno emiss_inpt_opt==121 - - + # gas/aer_bc/ic_default = bc/ic in "standard(=grell)" wrf-chem for radm2-sorgam species, # and first-cut implementation for cbmz-mosaic species @@ -2790,3 +3091,4 @@ rconfig real ltng_temp_lower namelist,physics max_domains - package lnox_opt_none lnox_opt==0 - - package lnox_opt_ott lnox_opt==1 - tracer:lnox_total package lnox_opt_decaria lnox_opt==2 - tracer:lnox_ic,lnox_cg + diff --git a/wrfv2_fire/Registry/registry.clm b/wrfv2_fire/Registry/registry.clm index cc82bfa1..ff42b1d5 100644 --- a/wrfv2_fire/Registry/registry.clm +++ b/wrfv2_fire/Registry/registry.clm @@ -1,113 +1,113 @@ # CLM Variables -state integer NUMC ij misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "NUMC" "NUMBER OF COLUMN SUBGRIDS" " " -state integer NUMP ij misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "NUMP" "NUMBER OF PFT SUBGRIDS" " " +state integer NUMC ij misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "NUMC" "NUMBER OF COLUMN SUBGRIDS" " " +state integer NUMP ij misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "NUMP" "NUMBER OF PFT SUBGRIDS" " " state real SABV ij misc 1 Z h "SABV" "NET VEGETATION SOLAR RADIATION" "W m-2" state real SABG ij misc 1 Z h "SABG" "NET SOIL SOLAR RADIATION" "W m-2" state real LWUP ij misc 1 Z h "LWUP" "OUTGOING LONGWAVE RADIATION" "W m-2" state real LHSOI i4j misc 1 Z h "LHSOI" "LH from soil" "W/m^2" state real LHVEG i4j misc 1 Z h "LHVEG" "LH from vegetation" "W/m^2" state real LHTRAN i4j misc 1 Z h "LHTRAN" "LH from transpiration" "W/m^2" -state integer SNL i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNL" "NUMBER OF SNOW LAYERS" " " -state real SNOWDP i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWDP" "SUBGRID SNOW DEPTH" "m" -state real WTC i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "WTC" "COLUMN WEIGHT" "fraction" -state real WTP i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "WTP" "PFT WEIGHT" "fraction" -state real H2OSNO i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSNO" "SUBGRID SNOW WATER EQUIVALENT" "kg m-2" -state real T_GRND i4j misc 1 Z rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_GRND" "SUBGRID GROUND TEMPERATURE" "K" -state real T_VEG i4j misc 1 Z rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_VEG" "SUBGRID VEGETATION TEMPERATURE" "K" -state real H2OCAN i4j misc 1 Z rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OCAN" "SUBGRID VEGETATION INTERCEP WATER" "kg m-2" -state real H2OCAN_COL i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OCAN_COL" "COLUMN VEGETATION INTERCEP WATER" "kg m-2" -state real T2M_MAX ij misc 1 Z rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T2M_MAX" "MAX TEMPERATURE AT 2 M" "K" -state real T2M_MIN ij misc 1 Z rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T2M_MIN" "MIN TEMPERATURE AT 2 M" "K" -state real T2CLM ij misc 1 Z rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T2CLM" "2M TEMPERATURE IN CLM" "K" -state real T_REF2M i4j misc 1 Z rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_REF2M" "TEMPERATURE AT 2 M" "K" -state real H2OSOI_LIQ_S1 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ_S1" "1ST SNOWLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ_S2 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ_S2" "2ND SNOWLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ_S3 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ_S3" "3RD SNOWLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ_S4 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ_S4" "4TH SNOWLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ_S5 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ_S5" "5TH SNOWLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ1 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ1" "1ST SOILLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ2 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ2" "2ND SOILLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ3 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ3" "3RD SOILLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ4 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ4" "4TH SOILLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ5 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ5" "5TH SOILLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ6 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ6" "6TH SOILLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ7 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ7" "7TH SOILLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ8 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ8" "8TH SOILLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ9 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ9" "9TH SOILLAYER LIQ WATER" "mm" -state real H2OSOI_LIQ10 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_LIQ10" "10TH SOILLAYER LIQ WATER" "mm" -state real H2OSOI_ICE_S1 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE_S1" "1ST SNOWLAYER ICE WATER" "mm" -state real H2OSOI_ICE_S2 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE_S2" "2ND SNOWLAYER ICE WATER" "mm" -state real H2OSOI_ICE_S3 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE_S3" "3RD SNOWLAYER ICE WATER" "mm" -state real H2OSOI_ICE_S4 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE_S4" "4TH SNOWLAYER ICE WATER" "mm" -state real H2OSOI_ICE_S5 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE_S5" "5TH SNOWLAYER ICE WATER" "mm" -state real H2OSOI_ICE1 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE1" "1ST SOILLAYER ICE WATER" "mm" -state real H2OSOI_ICE2 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE2" "2ND SOILLAYER ICE WATER" "mm" -state real H2OSOI_ICE3 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE3" "3RD SOILLAYER ICE WATER" "mm" -state real H2OSOI_ICE4 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE4" "4TH SOILLAYER ICE WATER" "mm" -state real H2OSOI_ICE5 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE5" "5TH SOILLAYER ICE WATER" "mm" -state real H2OSOI_ICE6 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE6" "6TH SOILLAYER ICE WATER" "mm" -state real H2OSOI_ICE7 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE7" "7TH SOILLAYER ICE WATER" "mm" -state real H2OSOI_ICE8 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE8" "8TH SOILLAYER ICE WATER" "mm" -state real H2OSOI_ICE9 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE9" "9TH SOILLAYER ICE WATER" "mm" -state real H2OSOI_ICE10 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_ICE10" "10TH SOILLAYER ICE WATER" "mm" -state real T_SOISNO_S1 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO_S1" "1ST SNOWLAYER TEMPERATURE" "K" -state real T_SOISNO_S2 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO_S2" "2ND SNOWLAYER TEMPERATURE" "K" -state real T_SOISNO_S3 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO_S3" "3RD SNOWLAYER TEMPERATURE" "K" -state real T_SOISNO_S4 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO_S4" "4TH SNOWLAYER TEMPERATURE" "K" -state real T_SOISNO_S5 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO_S5" "5TH SNOWLAYER TEMPERATURE" "K" -state real T_SOISNO1 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO1" "1ST SOILLAYER TEMPERATURE" "K" -state real T_SOISNO2 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO2" "2ND SOILLAYER TEMPERATURE" "K" -state real T_SOISNO3 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO3" "3RD SOILLAYER TEMPERATURE" "K" -state real T_SOISNO4 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO4" "4TH SOILLAYER TEMPERATURE" "K" -state real T_SOISNO5 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO5" "5TH SOILLAYER TEMPERATURE" "K" -state real T_SOISNO6 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO6" "6TH SOILLAYER TEMPERATURE" "K" -state real T_SOISNO7 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO7" "7TH SOILLAYER TEMPERATURE" "K" -state real T_SOISNO8 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO8" "8TH SOILLAYER TEMPERATURE" "K" -state real T_SOISNO9 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO9" "9TH SOILLAYER TEMPERATURE" "K" -state real T_SOISNO10 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_SOISNO10" "10TH SOILLAYER TEMPERATURE" "K" -state real DZSNOW1 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "DZSNOW1" "FIRST SNOW LAYER THKNESS(FROM BOTM)" "m" -state real DZSNOW2 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "DZSNOW2" "SECOND SNOW LAYER THKNESS(FROM BOTM)" "m" -state real DZSNOW3 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "DZSNOW3" "THIRD SNOW LAYER THKNESS(FROM BOTM)" "m" -state real DZSNOW4 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "DZSNOW4" "FOURTH SNOW LAYER THKNESS(FROM BOTM)" "m" -state real DZSNOW5 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "DZSNOW5" "FIFTH SNOW LAYER THKNESS(FROM BOTM)" "m" +state integer SNL i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNL" "NUMBER OF SNOW LAYERS" " " +state real SNOWDP i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOWDP" "SUBGRID SNOW DEPTH" "m" +state real WTC i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "WTC" "COLUMN WEIGHT" "fraction" +state real WTP i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "WTP" "PFT WEIGHT" "fraction" +state real H2OSNO i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSNO" "SUBGRID SNOW WATER EQUIVALENT" "kg m-2" +state real T_GRND i4j misc 1 Z rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_GRND" "SUBGRID GROUND TEMPERATURE" "K" +state real T_VEG i4j misc 1 Z rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_VEG" "SUBGRID VEGETATION TEMPERATURE" "K" +state real H2OCAN i4j misc 1 Z rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OCAN" "SUBGRID VEGETATION INTERCEP WATER" "kg m-2" +state real H2OCAN_COL i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OCAN_COL" "COLUMN VEGETATION INTERCEP WATER" "kg m-2" +state real T2M_MAX ij misc 1 Z rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T2M_MAX" "MAX TEMPERATURE AT 2 M" "K" +state real T2M_MIN ij misc 1 Z rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T2M_MIN" "MIN TEMPERATURE AT 2 M" "K" +state real T2CLM ij misc 1 Z rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T2CLM" "2M TEMPERATURE IN CLM" "K" +state real T_REF2M i4j misc 1 Z rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_REF2M" "TEMPERATURE AT 2 M" "K" +state real H2OSOI_LIQ_S1 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ_S1" "1ST SNOWLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ_S2 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ_S2" "2ND SNOWLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ_S3 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ_S3" "3RD SNOWLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ_S4 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ_S4" "4TH SNOWLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ_S5 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ_S5" "5TH SNOWLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ1 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ1" "1ST SOILLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ2 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ2" "2ND SOILLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ3 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ3" "3RD SOILLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ4 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ4" "4TH SOILLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ5 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ5" "5TH SOILLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ6 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ6" "6TH SOILLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ7 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ7" "7TH SOILLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ8 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ8" "8TH SOILLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ9 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ9" "9TH SOILLAYER LIQ WATER" "mm" +state real H2OSOI_LIQ10 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_LIQ10" "10TH SOILLAYER LIQ WATER" "mm" +state real H2OSOI_ICE_S1 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE_S1" "1ST SNOWLAYER ICE WATER" "mm" +state real H2OSOI_ICE_S2 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE_S2" "2ND SNOWLAYER ICE WATER" "mm" +state real H2OSOI_ICE_S3 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE_S3" "3RD SNOWLAYER ICE WATER" "mm" +state real H2OSOI_ICE_S4 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE_S4" "4TH SNOWLAYER ICE WATER" "mm" +state real H2OSOI_ICE_S5 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE_S5" "5TH SNOWLAYER ICE WATER" "mm" +state real H2OSOI_ICE1 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE1" "1ST SOILLAYER ICE WATER" "mm" +state real H2OSOI_ICE2 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE2" "2ND SOILLAYER ICE WATER" "mm" +state real H2OSOI_ICE3 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE3" "3RD SOILLAYER ICE WATER" "mm" +state real H2OSOI_ICE4 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE4" "4TH SOILLAYER ICE WATER" "mm" +state real H2OSOI_ICE5 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE5" "5TH SOILLAYER ICE WATER" "mm" +state real H2OSOI_ICE6 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE6" "6TH SOILLAYER ICE WATER" "mm" +state real H2OSOI_ICE7 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE7" "7TH SOILLAYER ICE WATER" "mm" +state real H2OSOI_ICE8 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE8" "8TH SOILLAYER ICE WATER" "mm" +state real H2OSOI_ICE9 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE9" "9TH SOILLAYER ICE WATER" "mm" +state real H2OSOI_ICE10 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_ICE10" "10TH SOILLAYER ICE WATER" "mm" +state real T_SOISNO_S1 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO_S1" "1ST SNOWLAYER TEMPERATURE" "K" +state real T_SOISNO_S2 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO_S2" "2ND SNOWLAYER TEMPERATURE" "K" +state real T_SOISNO_S3 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO_S3" "3RD SNOWLAYER TEMPERATURE" "K" +state real T_SOISNO_S4 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO_S4" "4TH SNOWLAYER TEMPERATURE" "K" +state real T_SOISNO_S5 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO_S5" "5TH SNOWLAYER TEMPERATURE" "K" +state real T_SOISNO1 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO1" "1ST SOILLAYER TEMPERATURE" "K" +state real T_SOISNO2 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO2" "2ND SOILLAYER TEMPERATURE" "K" +state real T_SOISNO3 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO3" "3RD SOILLAYER TEMPERATURE" "K" +state real T_SOISNO4 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO4" "4TH SOILLAYER TEMPERATURE" "K" +state real T_SOISNO5 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO5" "5TH SOILLAYER TEMPERATURE" "K" +state real T_SOISNO6 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO6" "6TH SOILLAYER TEMPERATURE" "K" +state real T_SOISNO7 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO7" "7TH SOILLAYER TEMPERATURE" "K" +state real T_SOISNO8 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO8" "8TH SOILLAYER TEMPERATURE" "K" +state real T_SOISNO9 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO9" "9TH SOILLAYER TEMPERATURE" "K" +state real T_SOISNO10 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_SOISNO10" "10TH SOILLAYER TEMPERATURE" "K" +state real DZSNOW1 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "DZSNOW1" "FIRST SNOW LAYER THKNESS(FROM BOTM)" "m" +state real DZSNOW2 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "DZSNOW2" "SECOND SNOW LAYER THKNESS(FROM BOTM)" "m" +state real DZSNOW3 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "DZSNOW3" "THIRD SNOW LAYER THKNESS(FROM BOTM)" "m" +state real DZSNOW4 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "DZSNOW4" "FOURTH SNOW LAYER THKNESS(FROM BOTM)" "m" +state real DZSNOW5 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "DZSNOW5" "FIFTH SNOW LAYER THKNESS(FROM BOTM)" "m" -state real SNOWRDS1 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWRDS1" "FIRST SNOW LAYER EFFECTIVE RADIUS" "micron" -state real SNOWRDS2 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWRDS2" "SECOND SNOW LAYER EFFECTIVE RADIUS" "micron" -state real SNOWRDS3 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWRDS3" "THIRD SNOW LAYER EFFECTIVE RADIUS" "micron" -state real SNOWRDS4 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWRDS4" "FOURTH SNOW LAYER EFFECTIVE RADIUS" "micron" -state real SNOWRDS5 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWRDS5" "FIFTH SNOW LAYER EFFECTIVE RADIUS" "micron" +state real SNOWRDS1 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOWRDS1" "FIRST SNOW LAYER EFFECTIVE RADIUS" "micron" +state real SNOWRDS2 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOWRDS2" "SECOND SNOW LAYER EFFECTIVE RADIUS" "micron" +state real SNOWRDS3 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOWRDS3" "THIRD SNOW LAYER EFFECTIVE RADIUS" "micron" +state real SNOWRDS4 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOWRDS4" "FOURTH SNOW LAYER EFFECTIVE RADIUS" "micron" +state real SNOWRDS5 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOWRDS5" "FIFTH SNOW LAYER EFFECTIVE RADIUS" "micron" -state real T_LAKE1 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_LAKE1" "1ST LAKELAYER TEMPERATURE" "K" -state real T_LAKE2 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_LAKE2" "2ND LAKELAYER TEMPERATURE" "K" -state real T_LAKE3 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_LAKE3" "3RD LAKELAYER TEMPERATURE" "K" -state real T_LAKE4 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_LAKE4" "4TH LAKELAYER TEMPERATURE" "K" -state real T_LAKE5 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_LAKE5" "5TH LAKELAYER TEMPERATURE" "K" -state real T_LAKE6 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_LAKE6" "6TH LAKELAYER TEMPERATURE" "K" -state real T_LAKE7 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_LAKE7" "7TH LAKELAYER TEMPERATURE" "K" -state real T_LAKE8 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_LAKE8" "8TH LAKELAYER TEMPERATURE" "K" -state real T_LAKE9 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_LAKE9" "9TH LAKELAYER TEMPERATURE" "K" -state real T_LAKE10 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "T_LAKE10" "10TH LAKELAYER TEMPERATURE" "K" -state real H2OSOI_VOL1 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_VOL1" "1ST SOILLAYER VOL MOIST" "fraction" -state real H2OSOI_VOL2 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_VOL2" "2ND SOILLAYER VOL MOIST" "fraction" -state real H2OSOI_VOL3 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_VOL3" "3RD SOILLAYER VOL MOIST" "fraction" -state real H2OSOI_VOL4 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_VOL4" "4TH SOILLAYER VOL MOIST" "fraction" -state real H2OSOI_VOL5 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_VOL5" "5TH SOILLAYER VOL MOIST" "fraction" -state real H2OSOI_VOL6 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_VOL6" "6TH SOILLAYER VOL MOIST" "fraction" -state real H2OSOI_VOL7 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_VOL7" "7TH SOILLAYER VOL MOIST" "fraction" -state real H2OSOI_VOL8 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_VOL8" "8TH SOILLAYER VOL MOIST" "fraction" -state real H2OSOI_VOL9 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_VOL9" "9TH SOILLAYER VOL MOIST" "fraction" -state real H2OSOI_VOL10 i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "H2OSOI_VOL10" "10TH SOILLAYER VOL MOIST" "fraction" +state real T_LAKE1 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_LAKE1" "1ST LAKELAYER TEMPERATURE" "K" +state real T_LAKE2 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_LAKE2" "2ND LAKELAYER TEMPERATURE" "K" +state real T_LAKE3 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_LAKE3" "3RD LAKELAYER TEMPERATURE" "K" +state real T_LAKE4 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_LAKE4" "4TH LAKELAYER TEMPERATURE" "K" +state real T_LAKE5 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_LAKE5" "5TH LAKELAYER TEMPERATURE" "K" +state real T_LAKE6 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_LAKE6" "6TH LAKELAYER TEMPERATURE" "K" +state real T_LAKE7 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_LAKE7" "7TH LAKELAYER TEMPERATURE" "K" +state real T_LAKE8 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_LAKE8" "8TH LAKELAYER TEMPERATURE" "K" +state real T_LAKE9 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_LAKE9" "9TH LAKELAYER TEMPERATURE" "K" +state real T_LAKE10 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "T_LAKE10" "10TH LAKELAYER TEMPERATURE" "K" +state real H2OSOI_VOL1 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_VOL1" "1ST SOILLAYER VOL MOIST" "fraction" +state real H2OSOI_VOL2 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_VOL2" "2ND SOILLAYER VOL MOIST" "fraction" +state real H2OSOI_VOL3 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_VOL3" "3RD SOILLAYER VOL MOIST" "fraction" +state real H2OSOI_VOL4 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_VOL4" "4TH SOILLAYER VOL MOIST" "fraction" +state real H2OSOI_VOL5 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_VOL5" "5TH SOILLAYER VOL MOIST" "fraction" +state real H2OSOI_VOL6 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_VOL6" "6TH SOILLAYER VOL MOIST" "fraction" +state real H2OSOI_VOL7 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_VOL7" "7TH SOILLAYER VOL MOIST" "fraction" +state real H2OSOI_VOL8 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_VOL8" "8TH SOILLAYER VOL MOIST" "fraction" +state real H2OSOI_VOL9 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_VOL9" "9TH SOILLAYER VOL MOIST" "fraction" +state real H2OSOI_VOL10 i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "H2OSOI_VOL10" "10TH SOILLAYER VOL MOIST" "fraction" #Extra subgrid (PFT-level) output variables -state real ALBEDOsubgrid i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ALBEDOsubgrid" "PFT-level ALBEDO" "" -state real LHsubgrid i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "LHsubgrid" "PFT-level Latent Heat" "W/m^2" -state real HFXsubgrid i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "HFXsubgrid" "PFT-level Sensible Heat" "W/m^2" -state real LWUPsubgrid i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "LWUPsubgrid" "PFT-level Longwave Up" "W/m^2" -state real Q2subgrid i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "Q2subgrid" "PFT-level 2m Moisture" "mixing ratio" -state real SABVsubgrid i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SABVsubgrid" "PFT-level SABV" "W/m^2" -state real SABGsubgrid i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SABGsubgrid" "PFT-level SABG" "W/m^2" -state real NRAsubgrid i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "NRAsubgrid" "PFT-level Net Radiation" "W/m^2" -state real SWUPsubgrid i4j misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SWUPsubgrid" "PFT-level Shortwave Up" "W/m^2" +state real ALBEDOsubgrid i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "ALBEDOsubgrid" "PFT-level ALBEDO" "" +state real LHsubgrid i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "LHsubgrid" "PFT-level Latent Heat" "W/m^2" +state real HFXsubgrid i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "HFXsubgrid" "PFT-level Sensible Heat" "W/m^2" +state real LWUPsubgrid i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "LWUPsubgrid" "PFT-level Longwave Up" "W/m^2" +state real Q2subgrid i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "Q2subgrid" "PFT-level 2m Moisture" "mixing ratio" +state real SABVsubgrid i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SABVsubgrid" "PFT-level SABV" "W/m^2" +state real SABGsubgrid i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SABGsubgrid" "PFT-level SABG" "W/m^2" +state real NRAsubgrid i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "NRAsubgrid" "PFT-level Net Radiation" "W/m^2" +state real SWUPsubgrid i4j misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SWUPsubgrid" "PFT-level Shortwave Up" "W/m^2" # end of CLM variables --------------------------------------------------------------------------------- diff --git a/wrfv2_fire/Registry/registry.dimspec b/wrfv2_fire/Registry/registry.dimspec index e8ba2a4f..a212c6bf 100644 --- a/wrfv2_fire/Registry/registry.dimspec +++ b/wrfv2_fire/Registry/registry.dimspec @@ -19,6 +19,7 @@ dimspec k 3 standard_domain z bottom_top dimspec 9 4 namelist=ensdim_alpha c alpha ensemble dimension endif +dimspec ncpldom 2 namelist=num_ext_model_couple_dom z num_ext_model_couple_dom dimspec lin 2 namelist=num_metgrid_soil_levels z num_metgrid_soil_levels dimspec | 2 namelist=num_force_layers z force_layers dimspec ndfi 1 namelist=dfi_time_dim c dfi time dimension @@ -46,6 +47,8 @@ dimspec snly 2 namelist=num_snow_layers z snow_layers dimspec l 2 namelist=num_soil_layers z soil_layers dimspec snsl 2 namelist=num_snso_layers z snso_layers dimspec ulay 2 namelist=num_urban_layers z urban_layers +dimspec mocat 2 namelist=mosaic_cat z mosaic categories # danli +dimspec mocat2 2 namelist=mosaic_cat_soil z mosaic categories * soil layers # danli dimspec uhi 2 namelist=num_urban_hi z urban_vertical_layers dimspec udr 2 constant=4 z urban_wind_directions dimspec urb 2 constant=132 z num_urb_params @@ -66,6 +69,9 @@ dimspec ? - namelist=ts_buf_size c ts_buf_size dimspec ! - namelist=max_ts_locs c max_ts_locs dimspec v - constant=1 z one dimspec = - constant=4 c num_bands +dimspec lake_ssl 2 constant=15 z snow_and_soil_levels +dimspec lake_intl 2 constant=16 z interface_levels +dimspec lake_sll 2 constant=10 z soil_levels_or_lake_levels # Dimensions required only for Chemistry @@ -73,6 +79,8 @@ ifdef BUILD_CHEM=1 dimspec o 3 namelist=ne_area z bio_emissions_dimension dimspec + 2 namelist=kemit z emissions_zdim dimspec nm 2 namelist=nmegan z megan_species +dimspec ndv 3 namelist=ndepvel z deposition_velocity_species +dimspec kdv 2 namelist=kdepvel z deposition_velocity_vert_levels dimspec dust 2 namelist=kfuture z klevs_for_dust dimspec ] 2 namelist=kfire z klevs_for_fire dimspec % 2 namelist=kdvel z klevs_for_dvel diff --git a/wrfv2_fire/Registry/registry.io_boilerplate b/wrfv2_fire/Registry/registry.io_boilerplate index 93c118a0..33c68da5 100644 --- a/wrfv2_fire/Registry/registry.io_boilerplate +++ b/wrfv2_fire/Registry/registry.io_boilerplate @@ -141,3 +141,7 @@ endif rconfig character iofields_filename namelist,time_control max_domains "NONE_SPECIFIED" rconfig logical ignore_iofields_warning namelist,time_control 1 .true. +# for controlling whether NetCDF writes using the FILL or NOFILL option +# nofill = true means only a single write, not the write/read/write sequence +rconfig logical ncd_nofill namelist,time_control 1 .true. + diff --git a/wrfv2_fire/Registry/registry.lake b/wrfv2_fire/Registry/registry.lake new file mode 100644 index 00000000..fd69b817 --- /dev/null +++ b/wrfv2_fire/Registry/registry.lake @@ -0,0 +1,40 @@ +# Lake variables + +state logical lake2d ij misc 1 - - "lake2d" "T/F: whether grid is lake" +state real lakedepth2d ij misc 1 - rh "lakedepth2d" "lake depth" "m" +state real savedtke12d ij misc 1 - irh "savedtke12d" "top level eddy conductivity from previous timestep" "W/m.K" +state real snowdp2d ij misc 1 - irh "snowdp2d" "snow depth" "m" +state real h2osno2d ij misc 1 - irh "h2osno2d" "snow water" "mm" +state real snl2d ij misc 1 - irh "snl2d" "number of snow layers" +state real t_grnd2d ij misc 1 - irh "t_grnd2d" "ground temperature" "k" +state real t_lake3d i{lake_sll}j misc 1 z irh "t_lake3d" "lake temperature" "k" +state real lake_icefrac3d i{lake_sll}j misc 1 z irh "lake_icefrac3d" "mass fraction of lake layer that is frozen" +state real z_lake3d i{lake_sll}j misc 1 z irh "z_lake3d" "layer depth for lake" "m" +state real dz_lake3d i{lake_sll}j misc 1 z irh "dz_lake3d" "layer thickness for lake" "m" +state real t_soisno3d i{lake_ssl}j misc 1 z irh "t_soisno3d" "soil (or snow) temperature" "m" +state real h2osoi_ice3d i{lake_ssl}j misc 1 z irh "h2osoi_ice3d" "ice lens" "kg/m2" +state real h2osoi_liq3d i{lake_ssl}j misc 1 z irh "h2osoi_liq3d" "liquid water" "kg/m2" +state real h2osoi_vol3d i{lake_ssl}j misc 1 z irh "h2osoi_vol3d" "volumetric soil water (0<=h2osoi_vol<=watsat)" "m3/m3" +state real z3d i{lake_ssl}j misc 1 z irh "z3d" "layer depth for snow & soil" "m" +state real dz3d i{lake_ssl}j misc 1 z irh "dz3d" "layer thickness for soil or snow" "m" +state real zi3d i{lake_intl}j misc 1 z irh "zi3d" "interface level below a "z" level" "m" +state real watsat3d i{lake_sll}j misc 1 z irh "watsat3d" "volumetric soil water at saturation (porosity)" +state real csol3d i{lake_sll}j misc 1 z irh "csol3d" "heat capacity, soil solids" "J/m**3/Kelvin" +state real tkmg3d i{lake_sll}j misc 1 z irh "tkmg3d" "thermal conductivity, soil minerals" "W/m-K" +state real tkdry3d i{lake_sll}j misc 1 z irh "tkdry3d" "thermal conductivity, dry soil" "W/m/Kelvin" +state real tksatu3d i{lake_sll}j misc 1 z irh "tksatu3d" "thermal conductivity, saturated soil" "W/m-K" + +state integer LAKEFLAG - misc 1 - i0 "LAKEFLAG" "Flag for lake in the global attributes for metgrid data" +state integer LAKE_DEPTH_FLAG - misc 1 - i0 "LAKE_DEPTH_FLAG" "Flag for lakedepth in the global attributes for metgrid data" + +# Lake namelist options + +rconfig real lakedepth_default namelist,physics max_domains 50 rh "lakedepth_default" "default lake depth" "m" +rconfig real lake_min_elev namelist,physics max_domains 5 rh "lake_min_elev" "" "" +rconfig integer use_lakedepth namelist,physics max_domains 1 rh "use_lakedepth" "" "" + + +# Lake packages + +package nolake sf_lake_physics==0 - - +package simple_lake sf_lake_physics==1 - scalar:lake2d,lakedepth2d,savedtke12d,snowdp2d,h2osno2d,snl2d,t_grnd2d,t_lake3d,lake_icefrac3d,z_lake3d,dz_lake3d,t_soisno3d,h2osoi_ice3d,h2osoi_liq3d,h2osoi_vol3d,z3d,dz3d,zi3d,watsat3d,csol3d,tkmg3d,tkdry3d,tksatu3d diff --git a/wrfv2_fire/Registry/registry.sbm b/wrfv2_fire/Registry/registry.sbm new file mode 100644 index 00000000..7c423c10 --- /dev/null +++ b/wrfv2_fire/Registry/registry.sbm @@ -0,0 +1,310 @@ +# SBM Scalars +# state real - ikjftb scalar 1 - - - +state real ff1i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i01" "cloud/rain bin 1" "# kg kg^-1" +state real ff1i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i02" "cloud/rain bin 2" "# kg kg^-1" +state real ff1i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i03" "cloud/rain bin 3" "# kg kg^-1" +state real ff1i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i04" "cloud/rain bin 4" "# kg kg^-1" +state real ff1i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i05" "cloud/rain bin 5" "# kg kg^-1" +state real ff1i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i06" "cloud/rain bin 6" "# kg kg^-1" +state real ff1i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i07" "cloud/rain bin 7" "# kg kg^-1" +state real ff1i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i08" "cloud/rain bin 8" "# kg kg^-1" +state real ff1i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i09" "cloud/rain bin 9" "# kg kg^-1" +state real ff1i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i10" "cloud/rain bin 10" "# kg kg^-1" +state real ff1i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i11" "cloud/rain bin 11" "# kg kg^-1" +state real ff1i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i12" "cloud/rain bin 12" "# kg kg^-1" +state real ff1i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i13" "cloud/rain bin 13" "# kg kg^-1" +state real ff1i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i14" "cloud/rain bin 14" "# kg kg^-1" +state real ff1i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i15" "cloud/rain bin 15" "# kg kg^-1" +state real ff1i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i16" "cloud/rain bin 16" "# kg kg^-1" +state real ff1i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i17" "cloud/rain bin 17" "# kg kg^-1" +state real ff1i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i18" "cloud/rain bin 18" "# kg kg^-1" +state real ff1i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i19" "cloud/rain bin 19" "# kg kg^-1" +state real ff1i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i20" "cloud/rain bin 20" "# kg kg^-1" +state real ff1i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i21" "cloud/rain bin 21" "# kg kg^-1" +state real ff1i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i22" "cloud/rain bin 22" "# kg kg^-1" +state real ff1i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i23" "cloud/rain bin 23" "# kg kg^-1" +state real ff1i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i24" "cloud/rain bin 24" "# kg kg^-1" +state real ff1i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i25" "cloud/rain bin 25" "# kg kg^-1" +state real ff1i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i26" "cloud/rain bin 26" "# kg kg^-1" +state real ff1i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i27" "cloud/rain bin 27" "# kg kg^-1" +state real ff1i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i28" "cloud/rain bin 28" "# kg kg^-1" +state real ff1i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i29" "cloud/rain bin 29" "# kg kg^-1" +state real ff1i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i30" "cloud/rain bin 30" "# kg kg^-1" +state real ff1i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i31" "cloud/rain bin 31" "# kg kg^-1" +state real ff1i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i32" "cloud/rain bin 32" "# kg kg^-1" +state real ff1i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i33" "cloud/rain bin 33" "# kg kg^-1" +state real ff5i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i01" "snow bin 1" "# kg kg^-1" +state real ff5i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i02" "snow bin 2" "# kg kg^-1" +state real ff5i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i03" "snow bin 3" "# kg kg^-1" +state real ff5i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i04" "snow bin 4" "# kg kg^-1" +state real ff5i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i05" "snow bin 5" "# kg kg^-1" +state real ff5i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i06" "snow bin 6" "# kg kg^-1" +state real ff5i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i07" "snow bin 7" "# kg kg^-1" +state real ff5i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i08" "snow bin 8" "# kg kg^-1" +state real ff5i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i09" "snow bin 9" "# kg kg^-1" +state real ff5i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i10" "snow bin 10" "# kg kg^-1" +state real ff5i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i11" "snow bin 11" "# kg kg^-1" +state real ff5i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i12" "snow bin 12" "# kg kg^-1" +state real ff5i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i13" "snow bin 13" "# kg kg^-1" +state real ff5i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i14" "snow bin 14" "# kg kg^-1" +state real ff5i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i15" "snow bin 15" "# kg kg^-1" +state real ff5i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i16" "snow bin 16" "# kg kg^-1" +state real ff5i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i17" "snow bin 17" "# kg kg^-1" +state real ff5i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i18" "snow bin 18" "# kg kg^-1" +state real ff5i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i19" "snow bin 19" "# kg kg^-1" +state real ff5i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i20" "snow bin 20" "# kg kg^-1" +state real ff5i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i21" "snow bin 21" "# kg kg^-1" +state real ff5i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i22" "snow bin 22" "# kg kg^-1" +state real ff5i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i23" "snow bin 23" "# kg kg^-1" +state real ff5i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i24" "snow bin 24" "# kg kg^-1" +state real ff5i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i25" "snow bin 25" "# kg kg^-1" +state real ff5i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i26" "snow bin 26" "# kg kg^-1" +state real ff5i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i27" "snow bin 27" "# kg kg^-1" +state real ff5i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i28" "snow bin 28" "# kg kg^-1" +state real ff5i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i29" "snow bin 29" "# kg kg^-1" +state real ff5i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i30" "snow bin 30" "# kg kg^-1" +state real ff5i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i31" "snow bin 31" "# kg kg^-1" +state real ff5i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i32" "snow bin 32" "# kg kg^-1" +state real ff5i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i33" "snow bin 33" "# kg kg^-1" +state real ff6i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i01" "graupel bin 1" "# kg kg^-1" +state real ff6i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i02" "graupel bin 2" "# kg kg^-1" +state real ff6i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i03" "graupel bin 3" "# kg kg^-1" +state real ff6i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i04" "graupel bin 4" "# kg kg^-1" +state real ff6i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i05" "graupel bin 5" "# kg kg^-1" +state real ff6i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i06" "graupel bin 6" "# kg kg^-1" +state real ff6i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i07" "graupel bin 7" "# kg kg^-1" +state real ff6i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i08" "graupel bin 8" "# kg kg^-1" +state real ff6i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i09" "graupel bin 9" "# kg kg^-1" +state real ff6i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i10" "graupel bin 10" "# kg kg^-1" +state real ff6i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i11" "graupel bin 11" "# kg kg^-1" +state real ff6i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i12" "graupel bin 12" "# kg kg^-1" +state real ff6i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i13" "graupel bin 13" "# kg kg^-1" +state real ff6i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i14" "graupel bin 14" "# kg kg^-1" +state real ff6i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i15" "graupel bin 15" "# kg kg^-1" +state real ff6i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i16" "graupel bin 16" "# kg kg^-1" +state real ff6i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i17" "graupel bin 17" "# kg kg^-1" +state real ff6i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i18" "graupel bin 18" "# kg kg^-1" +state real ff6i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i19" "graupel bin 19" "# kg kg^-1" +state real ff6i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i20" "graupel bin 20" "# kg kg^-1" +state real ff6i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i21" "graupel bin 21" "# kg kg^-1" +state real ff6i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i22" "graupel bin 22" "# kg kg^-1" +state real ff6i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i23" "graupel bin 23" "# kg kg^-1" +state real ff6i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i24" "graupel bin 24" "# kg kg^-1" +state real ff6i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i25" "graupel bin 25" "# kg kg^-1" +state real ff6i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i26" "graupel bin 26" "# kg kg^-1" +state real ff6i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i27" "graupel bin 27" "# kg kg^-1" +state real ff6i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i28" "graupel bin 28" "# kg kg^-1" +state real ff6i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i29" "graupel bin 29" "# kg kg^-1" +state real ff6i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i30" "graupel bin 30" "# kg kg^-1" +state real ff6i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i31" "graupel bin 31" "# kg kg^-1" +state real ff6i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i32" "graupel bin 32" "# kg kg^-1" +state real ff6i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i33" "graupel bin 33" "# kg kg^-1" +state real ff8i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i01" "aerosols bin 1" "# kg^-1" +state real ff8i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i02" "aerosols bin 2" "# kg^-1" +state real ff8i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i03" "aerosols bin 3" "# kg^-1" +state real ff8i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i04" "aerosols bin 4" "# kg^-1" +state real ff8i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i05" "aerosols bin 5" "# kg^-1" +state real ff8i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i06" "aerosols bin 6" "# kg^-1" +state real ff8i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i07" "aerosols bin 7" "# kg^-1" +state real ff8i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i08" "aerosols bin 8" "# kg^-1" +state real ff8i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i09" "aerosols bin 9" "# kg^-1" +state real ff8i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i10" "aerosols bin 10" "# kg^-1" +state real ff8i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i11" "aerosols bin 11" "# kg^-1" +state real ff8i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i12" "aerosols bin 12" "# kg^-1" +state real ff8i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i13" "aerosols bin 13" "# kg^-1" +state real ff8i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i14" "aerosols bin 14" "# kg^-1" +state real ff8i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i15" "aerosols bin 15" "# kg^-1" +state real ff8i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i16" "aerosols bin 16" "# kg^-1" +state real ff8i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i17" "aerosols bin 17" "# kg^-1" +state real ff8i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i18" "aerosols bin 18" "# kg^-1" +state real ff8i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i19" "aerosols bin 19" "# kg^-1" +state real ff8i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i20" "aerosols bin 20" "# kg^-1" +state real ff8i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i21" "aerosols bin 21" "# kg^-1" +state real ff8i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i22" "aerosols bin 22" "# kg^-1" +state real ff8i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i23" "aerosols bin 23" "# kg^-1" +state real ff8i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i24" "aerosols bin 24" "# kg^-1" +state real ff8i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i25" "aerosols bin 25" "# kg^-1" +state real ff8i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i26" "aerosols bin 26" "# kg^-1" +state real ff8i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i27" "aerosols bin 27" "# kg^-1" +state real ff8i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i28" "aerosols bin 28" "# kg^-1" +state real ff8i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i29" "aerosols bin 29" "# kg^-1" +state real ff8i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i30" "aerosols bin 30" "# kg^-1" +state real ff8i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i31" "aerosols bin 31" "# kg^-1" +state real ff8i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i32" "aerosols bin 32" "# kg^-1" +state real ff8i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i33" "aerosols bin 33" "# kg^-1" +state real ff2i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i01" "ice/columns bin 1" "# kg kg^-1" +state real ff2i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i02" "ice/columns bin 2" "# kg kg^-1" +state real ff2i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i03" "ice/columns bin 3" "# kg kg^-1" +state real ff2i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i04" "ice/columns bin 4" "# kg kg^-1" +state real ff2i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i05" "ice/columns bin 5" "# kg kg^-1" +state real ff2i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i06" "ice/columns bin 6" "# kg kg^-1" +state real ff2i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i07" "ice/columns bin 7" "# kg kg^-1" +state real ff2i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i08" "ice/columns bin 8" "# kg kg^-1" +state real ff2i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i09" "ice/columns bin 9" "# kg kg^-1" +state real ff2i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i10" "ice/columns bin 10" "# kg kg^-1" +state real ff2i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i14" "ice/columns bin 14" "# kg kg^-1" +state real ff2i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i15" "ice/columns bin 15" "# kg kg^-1" +state real ff2i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i16" "ice/columns bin 16" "# kg kg^-1" +state real ff2i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i17" "ice/columns bin 17" "# kg kg^-1" +state real ff2i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i18" "ice/columns bin 18" "# kg kg^-1" +state real ff2i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i19" "ice/columns bin 19" "# kg kg^-1" +state real ff2i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i20" "ice/columns bin 20" "# kg kg^-1" +state real ff2i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i21" "ice/columns bin 21" "# kg kg^-1" +state real ff2i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i22" "ice/columns bin 22" "# kg kg^-1" +state real ff2i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i23" "ice/columns bin 23" "# kg kg^-1" +state real ff2i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i24" "ice/columns bin 24" "# kg kg^-1" +state real ff2i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i25" "ice/columns bin 25" "# kg kg^-1" +state real ff2i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i26" "ice/columns bin 26" "# kg kg^-1" +state real ff2i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i27" "ice/columns bin 27" "# kg kg^-1" +state real ff2i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i28" "ice/columns bin 28" "# kg kg^-1" +state real ff2i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i29" "ice/columns bin 29" "# kg kg^-1" +state real ff2i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i30" "ice/columns bin 30" "# kg kg^-1" +state real ff2i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i31" "ice/columns bin 31" "# kg kg^-1" +state real ff2i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i32" "ice/columns bin 32" "# kg kg^-1" +state real ff2i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i33" "ice/columns bin 33" "# kg kg^-1" +state real ff3i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i01" "ice/plates bin 1" "# kg kg^-1" +state real ff3i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i02" "ice/plates bin 2" "# kg kg^-1" +state real ff3i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i03" "ice/plates bin 3" "# kg kg^-1" +state real ff3i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i04" "ice/plates bin 4" "# kg kg^-1" +state real ff3i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i05" "ice/plates bin 5" "# kg kg^-1" +state real ff3i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i06" "ice/plates bin 6" "# kg kg^-1" +state real ff3i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i07" "ice/plates bin 7" "# kg kg^-1" +state real ff3i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i08" "ice/plates bin 8" "# kg kg^-1" +state real ff3i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i09" "ice/plates bin 9" "# kg kg^-1" +state real ff3i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i10" "ice/plates bin 10" "# kg kg^-1" +state real ff3i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i11" "ice/plates bin 11" "# kg kg^-1" +state real ff3i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i12" "ice/plates bin 12" "# kg kg^-1" +state real ff3i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i13" "ice/plates bin 13" "# kg kg^-1" +state real ff3i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i14" "ice/plates bin 14" "# kg kg^-1" +state real ff3i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i15" "ice/plates bin 15" "# kg kg^-1" +state real ff3i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i16" "ice/plates bin 16" "# kg kg^-1" +state real ff3i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i17" "ice/plates bin 17" "# kg kg^-1" +state real ff3i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i18" "ice/plates bin 18" "# kg kg^-1" +state real ff3i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i19" "ice/plates bin 19" "# kg kg^-1" +state real ff3i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i20" "ice/plates bin 20" "# kg kg^-1" +state real ff3i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i21" "ice/plates bin 21" "# kg kg^-1" +state real ff3i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i22" "ice/plates bin 22" "# kg kg^-1" +state real ff3i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i23" "ice/plates bin 23" "# kg kg^-1" +state real ff3i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i24" "ice/plates bin 24" "# kg kg^-1" +state real ff3i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i25" "ice/plates bin 25" "# kg kg^-1" +state real ff3i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i26" "ice/plates bin 26" "# kg kg^-1" +state real ff3i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i27" "ice/plates bin 27" "# kg kg^-1" +state real ff3i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i28" "ice/plates bin 28" "# kg kg^-1" +state real ff3i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i29" "ice/plates bin 29" "# kg kg^-1" +state real ff3i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i30" "ice/plates bin 30" "# kg kg^-1" +state real ff3i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i31" "ice/plates bin 31" "# kg kg^-1" +state real ff3i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i32" "ice/plates bin 32" "# kg kg^-1" +state real ff3i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i33" "ice/plates bin 33" "# kg kg^-1" +state real ff4i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i01" "ice/dendrites bin 1" "# kg kg^-1" +state real ff4i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i02" "ice/dendrites bin 2" "# kg kg^-1" +state real ff4i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i03" "ice/dendrites bin 3" "# kg kg^-1" +state real ff4i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i04" "ice/dendrites bin 4" "# kg kg^-1" +state real ff4i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i05" "ice/dendrites bin 5" "# kg kg^-1" +state real ff4i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i06" "ice/dendrites bin 6" "# kg kg^-1" +state real ff4i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i07" "ice/dendrites bin 7" "# kg kg^-1" +state real ff4i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i08" "ice/dendrites bin 8" "# kg kg^-1" +state real ff4i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i09" "ice/dendrites bin 9" "# kg kg^-1" +state real ff4i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i10" "ice/dendrites bin 10" "# kg kg^-1" +state real ff4i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i11" "ice/dendrites bin 11" "# kg kg^-1" +state real ff4i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i12" "ice/dendrites bin 12" "# kg kg^-1" +state real ff4i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i13" "ice/dendrites bin 13" "# kg kg^-1" +state real ff4i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i14" "ice/dendrites bin 14" "# kg kg^-1" +state real ff4i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i15" "ice/dendrites bin 15" "# kg kg^-1" +state real ff4i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i16" "ice/dendrites bin 16" "# kg kg^-1" +state real ff4i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i17" "ice/dendrites bin 17" "# kg kg^-1" +state real ff4i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i18" "ice/dendrites bin 18" "# kg kg^-1" +state real ff4i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i19" "ice/dendrites bin 19" "# kg kg^-1" +state real ff4i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i20" "ice/dendrites bin 20" "# kg kg^-1" +state real ff4i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i21" "ice/dendrites bin 21" "# kg kg^-1" +state real ff4i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i22" "ice/dendrites bin 22" "# kg kg^-1" +state real ff4i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i23" "ice/dendrites bin 23" "# kg kg^-1" +state real ff4i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i24" "ice/dendrites bin 24" "# kg kg^-1" +state real ff4i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i25" "ice/dendrites bin 25" "# kg kg^-1" +state real ff4i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i26" "ice/dendrites bin 26" "# kg kg^-1" +state real ff4i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i27" "ice/dendrites bin 27" "# kg kg^-1" +state real ff4i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i28" "ice/dendrites bin 28" "# kg kg^-1" +state real ff4i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i29" "ice/dendrites bin 29" "# kg kg^-1" +state real ff4i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i30" "ice/dendrites bin 30" "# kg kg^-1" +state real ff4i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i31" "ice/dendrites bin 31" "# kg kg^-1" +state real ff4i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i32" "ice/dendrites bin 32" "# kg kg^-1" +state real ff4i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i33" "ice/dendrites bin 33" "# kg kg^-1" +state real ff7i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i01" "hail bin 1" "# kg kg^-1" +state real ff7i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i02" "hail bin 2" "# kg kg^-1" +state real ff7i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i03" "hail bin 3" "# kg kg^-1" +state real ff7i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i04" "hail bin 4" "# kg kg^-1" +state real ff7i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i05" "hail bin 5" "# kg kg^-1" +state real ff7i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i06" "hail bin 6" "# kg kg^-1" +state real ff7i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i07" "hail bin 7" "# kg kg^-1" +state real ff7i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i08" "hail bin 8" "# kg kg^-1" +state real ff7i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i09" "hail bin 9" "# kg kg^-1" +state real ff7i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i10" "hail bin 10" "# kg kg^-1" +state real ff7i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i11" "hail bin 11" "# kg kg^-1" +state real ff7i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i12" "hail bin 12" "# kg kg^-1" +state real ff7i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i13" "hail bin 13" "# kg kg^-1" +state real ff7i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i14" "hail bin 14" "# kg kg^-1" +state real ff7i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i15" "hail bin 15" "# kg kg^-1" +state real ff7i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i16" "hail bin 16" "# kg kg^-1" +state real ff7i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i17" "hail bin 17" "# kg kg^-1" +state real ff7i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i18" "hail bin 18" "# kg kg^-1" +state real ff7i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i19" "hail bin 19" "# kg kg^-1" +state real ff7i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i20" "hail bin 20" "# kg kg^-1" +state real ff7i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i21" "hail bin 21" "# kg kg^-1" +state real ff7i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i22" "hail bin 22" "# kg kg^-1" +state real ff7i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i23" "hail bin 23" "# kg kg^-1" +state real ff7i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i24" "hail bin 24" "# kg kg^-1" +state real ff7i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i25" "hail bin 25" "# kg kg^-1" +state real ff7i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i26" "hail bin 26" "# kg kg^-1" +state real ff7i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i27" "hail bin 27" "# kg kg^-1" +state real ff7i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i28" "hail bin 28" "# kg kg^-1" +state real ff7i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i29" "hail bin 29" "# kg kg^-1" +state real ff7i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i30" "hail bin 30" "# kg kg^-1" +state real ff7i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i31" "hail bin 31" "# kg kg^-1" +state real ff7i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i32" "hail bin 32" "# kg kg^-1" +state real ff7i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i33" "hail bin 33" "# kg kg^-1" + +state real qip ikjftb moist 1 - \ + i0rhusdf=(bdy_interp:dt) "QICEP" "Plate Ice mixing ratio" "kg kg-1" +state real qic ikjftb moist 1 - \ + i0rhusdf=(bdy_interp:dt) "QICEC" "Column Ice mixing ratio" "kg kg-1" +state real qid ikjftb moist 1 - \ + i0rhusdf=(bdy_interp:dt) "QICED" "Dendrite Ice mixing ratio" "kg kg-1" +state real qnip ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QNICEP" "Plate Ice Number concentration" "# kg-1" +state real qnic ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QNICEC" "Column Ice Number concentration" "# kg-1" +state real qnid ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QNICED" "Dendrite Ice Number concentration" "# kg-1" +state real effr ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "EFF_RADIUS" "Effective Radius" "Microns" +state real ice_effr ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "ICE_EFF_RADIUS" "Ice Effective Radius" "Microns" +state real tot_effr ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "TOT_EFF_RADIUS" "Tot Effective Radius" "Microns" +state real qic_effr ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QIC_EFF_RADIUS" "QIC Effective Radius" "Microns" +state real qip_effr ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QIP_EFF_RADIUS" "QIP Effective Radius" "Microns" +state real qid_effr ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QID_EFF_RADIUS" "QID Effective Radius" "Microns" + +state real th_old ikj misc 1 - rusd "TH_OLD" "Old Value of Th" "K" +state real qv_old ikj misc 1 - rusd "QV_OLD" "Old Value of qv" "kg kg^-1" + +state real kext_ql ikj misc 1 - rh05 "KEXT_QL" " Extinction Coefficient for water " "m-1" +state real kext_qic ikj misc 1 - rh05 "KEXT_QIC" " Extinction Coefficient for ice columns " "m-1" +state real kext_qip ikj misc 1 - rh05 "KEXT_QIP" " Extinction Coefficient for ice plates " "m-1" +state real kext_qid ikj misc 1 - rh05 "KEXT_QID" " Extinction Coefficient for ice dendrites " "m-1" +state real kext_qs ikj misc 1 - rh05 "KEXT_QS" " Extinction Coefficient for snow " "m-1" +state real kext_qg ikj misc 1 - rh05 "KEXT_QG" " Extinction Coefficient for graupel " "m-1" +state real kext_qh ikj misc 1 - rh05 "KEXT_QH" " Extinction Coefficient for hail " "m-1" +state real kext_qa ikj misc 1 - rh05 "KEXT_QA" " Extinction Coefficient for aerosols " "m-1" +state real kext_ft_qic ikj misc 1 - rh05 "KEXT_FT_QIC" " Extinction Adj. Coefficient for ice columns " "m-1" +state real kext_ft_qip ikj misc 1 - rh05 "KEXT_FT_QIP" " Extinction Adj. Coefficient for ice plates " "m-1" +state real kext_ft_qid ikj misc 1 - rh05 "KEXT_FT_QID" " Extinction Adj. Coefficient for ice dendrites " "m-1" +state real kext_ft_qs ikj misc 1 - rh05 "KEXT_FT_QS" " Extinction Adj. Coefficient for snow " "m-1" +state real kext_ft_qg ikj misc 1 - rh05 "KEXT_FT_QG" " Extinction Adj. Coefficient for graupel " "m-1" +state real height ikj misc 1 - rh5 "HEIGHT" " Height " "m" +state real tempc ikj misc 1 - rh5 "TEMPC" " Temperature " "C" +package fast_khain_lynn mp_physics==30 - moist:qv,qc,qr,qi,qs,qg;scalar:ff1i01,ff1i02,ff1i03,ff1i04,ff1i05,ff1i06,ff1i07,ff1i08,ff1i09,ff1i10,ff1i11,ff1i12,ff1i13,ff1i14,ff1i15,ff1i16,ff1i17,ff1i18,ff1i19,ff1i20,ff1i21,ff1i22,ff1i23,ff1i24,ff1i25,ff1i26,ff1i27,ff1i28,ff1i29,ff1i30,ff1i31,ff1i32,ff1i33,ff5i01,ff5i02,ff5i03,ff5i04,ff5i05,ff5i06,ff5i07,ff5i08,ff5i09,ff5i10,ff5i11,ff5i12,ff5i13,ff5i14,ff5i15,ff5i16,ff5i17,ff5i18,ff5i19,ff5i20,ff5i21,ff5i22,ff5i23,ff5i24,ff5i25,ff5i26,ff5i27,ff5i28,ff5i29,ff5i30,ff5i31,ff5i32,ff5i33,ff6i01,ff6i02,ff6i03,ff6i04,ff6i05,ff6i06,ff6i07,ff6i08,ff6i09,ff6i10,ff6i11,ff6i12,ff6i13,ff6i14,ff6i15,ff6i16,ff6i17,ff6i18,ff6i19,ff6i20,ff6i21,ff6i22,ff6i23,ff6i24,ff6i25,ff6i26,ff6i27,ff6i28,ff6i29,ff6i30,ff6i31,ff6i32,ff6i33,ff8i01,ff8i02,ff8i03,ff8i04,ff8i05,ff8i06,ff8i07,ff8i08,ff8i09,ff8i10,ff8i11,ff8i12,ff8i13,ff8i14,ff8i15,ff8i16,ff8i17,ff8i18,ff8i19,ff8i20,ff8i21,ff8i22,ff8i23,ff8i24,ff8i25,ff8i26,ff8i27,ff8i28,ff8i29,ff8i30,ff8i31,ff8i32,ff8i33,qnn,qnc,qnr,qni,qns,qng,effr,ice_effr,tot_effr +package full_khain_lynn mp_physics==32 - moist:qv,qc,qr,qi,qic,qip,qid,qs,qg,qh;scalar:ff1i01,ff1i02,ff1i03,ff1i04,ff1i05,ff1i06,ff1i07,ff1i08,ff1i09,ff1i10,ff1i11,ff1i12,ff1i13,ff1i14,ff1i15,ff1i16,ff1i17,ff1i18,ff1i19,ff1i20,ff1i21,ff1i22,ff1i23,ff1i24,ff1i25,ff1i26,ff1i27,ff1i28,ff1i29,ff1i30,ff1i31,ff1i32,ff1i33,ff5i01,ff5i02,ff5i03,ff5i04,ff5i05,ff5i06,ff5i07,ff5i08,ff5i09,ff5i10,ff5i11,ff5i12,ff5i13,ff5i14,ff5i15,ff5i16,ff5i17,ff5i18,ff5i19,ff5i20,ff5i21,ff5i22,ff5i23,ff5i24,ff5i25,ff5i26,ff5i27,ff5i28,ff5i29,ff5i30,ff5i31,ff5i32,ff5i33,ff6i01,ff6i02,ff6i03,ff6i04,ff6i05,ff6i06,ff6i07,ff6i08,ff6i09,ff6i10,ff6i11,ff6i12,ff6i13,ff6i14,ff6i15,ff6i16,ff6i17,ff6i18,ff6i19,ff6i20,ff6i21,ff6i22,ff6i23,ff6i24,ff6i25,ff6i26,ff6i27,ff6i28,ff6i29,ff6i30,ff6i31,ff6i32,ff6i33,ff8i01,ff8i02,ff8i03,ff8i04,ff8i05,ff8i06,ff8i07,ff8i08,ff8i09,ff8i10,ff8i11,ff8i12,ff8i13,ff8i14,ff8i15,ff8i16,ff8i17,ff8i18,ff8i19,ff8i20,ff8i21,ff8i22,ff8i23,ff8i24,ff8i25,ff8i26,ff8i27,ff8i28,ff8i29,ff8i30,ff8i31,ff8i32,ff8i33,ff2i01,ff2i02,ff2i03,ff2i04,ff2i05,ff2i06,ff2i07,ff2i08,ff2i09,ff2i10,ff2i11,ff2i12,ff2i13,ff2i14,ff2i15,ff2i16,ff2i17,ff2i18,ff2i19,ff2i20,ff2i21,ff2i22,ff2i23,ff2i24,ff2i25,ff2i26,ff2i27,ff2i28,ff2i29,ff2i30,ff2i31,ff2i32,ff2i33,ff3i01,ff3i02,ff3i03,ff3i04,ff3i05,ff3i06,ff3i07,ff3i08,ff3i09,ff3i10,ff3i11,ff3i12,ff3i13,ff3i14,ff3i15,ff3i16,ff3i17,ff3i18,ff3i19,ff3i20,ff3i21,ff3i22,ff3i23,ff3i24,ff3i25,ff3i26,ff3i27,ff3i28,ff3i29,ff3i30,ff3i31,ff3i32,ff3i33,ff4i01,ff4i02,ff4i03,ff4i04,ff4i05,ff4i06,ff4i07,ff4i08,ff4i09,ff4i10,ff4i11,ff4i12,ff4i13,ff4i14,ff4i15,ff4i16,ff4i17,ff4i18,ff4i19,ff4i20,ff4i21,ff4i22,ff4i23,ff4i24,ff4i25,ff4i26,ff4i27,ff4i28,ff4i29,ff4i30,ff4i31,ff4i32,ff4i33,ff7i01,ff7i02,ff7i03,ff7i04,ff7i05,ff7i06,ff7i07,ff7i08,ff7i09,ff7i10,ff7i11,ff7i12,ff7i13,ff7i14,ff7i15,ff7i16,ff7i17,ff7i18,ff7i19,ff7i20,ff7i21,ff7i22,ff7i23,ff7i24,ff7i25,ff7i26,ff7i27,ff7i28,ff7i29,ff7i30,ff7i31,ff7i32,ff7i33,qnn,qnc,qnr,qni,qnic,qnip,qnid,qns,qng,qnh,effr,ice_effr,tot_effr,qic_effr,qip_effr,qid_effr;state:kext_ql,kext_qic,kext_qip,kext_qid,kext_qs,kext_qg,kext_qh,kext_qa,kext_ft_qic,kext_ft_qip,kext_ft_qid,kext_ft_qs,kext_ft_qg + diff --git a/wrfv2_fire/Registry/registry.stoch b/wrfv2_fire/Registry/registry.stoch index 503ae0a0..51dccf7c 100644 --- a/wrfv2_fire/Registry/registry.stoch +++ b/wrfv2_fire/Registry/registry.stoch @@ -1,40 +1,44 @@ # Stochastic forcing option, for ARW only # 3D arrays -state real VERTSTRUCC ikj dyn_em 1 - rhd "VERTSTRUCC " "vertical structure for stoch. forcing " "" -state real VERTSTRUCS ikj dyn_em 1 - rhd "VERTSTRUCS " "vertical structure for stoch. forcing " "" - -state real ru_tendf_stoch ikj dyn_em 1 X rhdf=(p2c) "ru_tendf_stoch" "stochastic forcing, U " "m/s" -state real rv_tendf_stoch ikj dyn_em 1 Y rhdf=(p2c) "rv_tendf_stoch" "stochastic forcing, V " "m/s" -state real rt_tendf_stoch ikj dyn_em 1 - rhdf=(p2c) "rt_tendf_stoch" "stochastic forcing, T " "K/s" +state real VERTSTRUCC ikj dyn_em 1 - rd "VERTSTRUCC" "vertical structure for stoch. forcing " "" +state real VERTSTRUCS ikj dyn_em 1 - rd "VERTSTRUCS" "vertical structure for stoch. forcing " "" + +state real ru_tendf_stoch ikj dyn_em 1 X rhdf=(p2c) "ru_tendf_stoch" "stochastic forcing, U " "m/s^2" +state real rv_tendf_stoch ikj dyn_em 1 Y rhdf=(p2c) "rv_tendf_stoch" "stochastic forcing, V " "m/s^2" +state real rt_tendf_stoch ikj dyn_em 1 - rhdf=(p2c) "rt_tendf_stoch" "stochastic forcing, T " "K/s" # 2d arrays -state real SPSTREAMFORCC ij misc 1 - r "SPSTREAMFORCC" "real spect. coeff. of stoch. streamfunction perturb." "" -state real SPSTREAMFORCS ij misc 1 - r "SPSTREAMFORCS" "imag. spect. coeff. of stoch. streamfunction perturb." "" -state real SPTFORCC ij misc 1 - r "SPTFORCC" "real spect. coeff. of stoch. temperature perturb." "" "" -state real SPTFORCS ij misc 1 - r "SPTFORCS" "imag. spect. coeff. of stoch. temperature perturb." "" "" -state real SPSTREAM_AMP ij misc 1 - r "SPSTREAM_AMP" "amplitude of stoch. streamfunction perturb." "" "" -state real SPT_AMP ij misc 1 - r "SPT_AMP" "amplitude of stoch. temperature perturb." "" "" +state real SPSTREAMFORCC ij misc 1 - r "SPSTREAMFORCC" "real spect. coeff. of stoch. streamfunction perturb." "" +state real SPSTREAMFORCS ij misc 1 - r "SPSTREAMFORCS" "imag. spect. coeff. of stoch. streamfunction perturb." "" +state real SPTFORCC ij misc 1 - r "SPTFORCC" "real spect. coeff. of stoch. temperature perturb." "" "" +state real SPTFORCS ij misc 1 - r "SPTFORCS" "imag. spect. coeff. of stoch. temperature perturb." "" "" +state real SPSTREAM_AMP ij misc 1 - r "SPSTREAM_AMP" "amplitude of stoch. streamfunction perturb." "" "" +state real SPT_AMP ij misc 1 - r "SPT_AMP" "amplitude of stoch. temperature perturb." "" "" + +# 1d arrays +state real VERTAMPT k misc 1 - r "VERTAMPT" "vert. amplitude of stoch. temperature perturb." "" "" +state real VERTAMPUV k misc 1 - r "VERTAMPUV" "vert. amplitude of stoch. u,v perturb." "" "" # 1d arrays for FFT transpose -state real RU_REAL ikj dyn_em 1 XYZ -state real RU_IMAG ikj dyn_em 1 XYZ -state real RU_REAL_xxx ikjx dyn_em 1 XYZ -state real RU_REAL_yyy ikjy dyn_em 1 XYZ -state real RU_IMAG_xxx ikjx dyn_em 1 XYZ -state real RU_IMAG_yyy ikjy dyn_em 1 XYZ -state real RV_REAL ikj dyn_em 1 XYZ -state real RV_IMAG ikj dyn_em 1 XYZ -state real RV_REAL_xxx ikjx dyn_em 1 XYZ -state real RV_REAL_yyy ikjy dyn_em 1 XYZ -state real RV_IMAG_xxx ikjx dyn_em 1 XYZ -state real RV_IMAG_yyy ikjy dyn_em 1 XYZ -state real RT_REAL ikj dyn_em 1 XYZ -state real RT_IMAG ikj dyn_em 1 XYZ -state real RT_REAL_xxx ikjx dyn_em 1 XYZ -state real RT_REAL_yyy ikjy dyn_em 1 XYZ -state real RT_IMAG_xxx ikjx dyn_em 1 XYZ -state real RT_IMAG_yyy ikjy dyn_em 1 XYZ +state real RU_REAL ikj dyn_em 1 XYZ +state real RU_IMAG ikj dyn_em 1 XYZ +state real RU_REAL_xxx ikjx dyn_em 1 XYZ +state real RU_REAL_yyy ikjy dyn_em 1 XYZ +state real RU_IMAG_xxx ikjx dyn_em 1 XYZ +state real RU_IMAG_yyy ikjy dyn_em 1 XYZ +state real RV_REAL ikj dyn_em 1 XYZ +state real RV_IMAG ikj dyn_em 1 XYZ +state real RV_REAL_xxx ikjx dyn_em 1 XYZ +state real RV_REAL_yyy ikjy dyn_em 1 XYZ +state real RV_IMAG_xxx ikjx dyn_em 1 XYZ +state real RV_IMAG_yyy ikjy dyn_em 1 XYZ +state real RT_REAL ikj dyn_em 1 XYZ +state real RT_IMAG ikj dyn_em 1 XYZ +state real RT_REAL_xxx ikjx dyn_em 1 XYZ +state real RT_REAL_yyy ikjy dyn_em 1 XYZ +state real RT_IMAG_xxx ikjx dyn_em 1 XYZ +state real RT_IMAG_yyy ikjy dyn_em 1 XYZ xpose XPOSE_STOCH_BACK_U_REAL dyn_em RU_REAL,RU_REAL_xxx,RU_REAL_yyy xpose XPOSE_STOCH_BACK_U_IMAG dyn_em RU_IMAG,RU_IMAG_xxx,RU_IMAG_yyy @@ -48,16 +52,45 @@ state integer SEED1 - misc 1 - rh "S state integer SEED2 - misc 1 - rh "SEED2" "RANDOM SEED NUMBER 2" "" state logical did_stoch - misc 1 - r "DID_STOCH" "Logical to tell us that we already did the initialization for dom 1" "" -# Namelist parameters -rconfig integer stoch_force_opt namelist,physics max_domains 0 - "stochastic forcing option: 0=none, 1=backscatter" -rconfig integer stoch_vertstruc_opt namelist,physics max_domains 0 - "vertical structure for stochastic forcing: 0=constant, 1=random phase" -rconfig integer nens namelist,physics 1 1 - "random number seed for ensemble members " "" "" -rconfig real tot_backscat_psi namelist,physics max_domains 1.0E-05 - "total backscattered dissipation rate for streamfunction m2 s-3" "" -rconfig real tot_backscat_t namelist,physics max_domains 1.0E-06 - "total backscattered dissipation rate for temperature" "m2 s-3" "" +# Namelist parameters general +rconfig integer stoch_force_opt namelist,stoch max_domains 0 - "stochastic forcing option: 0=none, 1=SKEBS, 2=SPPT" +rconfig integer stoch_vertstruc_opt namelist,stoch max_domains 0 - "vertical structure for stochastic forcing: 0=constant, 1=random phase, 2=user determined" +rconfig integer nens namelist,stoch 1 1 - "random number seed for ensemble members " "" "" + +# Namelist parameters SKEBS +rconfig real tot_backscat_psi namelist,stoch max_domains 1.0E-05 - "total backscattered diss. for streamfunction m2 s-3" "" +rconfig real tot_backscat_t namelist,stoch max_domains 1.0E-06 - "total backscattered diss. rate for pot. temperature" "m2 s-3" "" +rconfig real ztau_psi namelist,stoch 1 10800.0 - "decorr. time of noise for psi perturb." +rconfig real ztau_t namelist,stoch 1 10800.0 - "decorr. time of noise for theta perturb." "s" "" +rconfig real rexponent_psi namelist,stoch 1 -1.83 - "spectral slope of forcing for psi" "" "" +rconfig real rexponent_t namelist,stoch 1 -1.83 - "spectral slope of forcing for theta " "" "" +rconfig real zsigma2_eps namelist,stoch 1 0.0833 - "variance of noise for psi perturb." "" "" +rconfig real zsigma2_eta namelist,stoch 1 0.0833 - "variance of noise for theta perturb." "" "" +rconfig integer kminforc namelist,stoch 1 1 - "min. forcing wavenumber in lon. for psi perturb." "" "" +rconfig integer lminforc namelist,stoch 1 1 - "min. forcing wavenumber in lat. for psi perturb." "" "" +rconfig integer kminforct namelist,stoch 1 1 - "min. forcing wavenumber in lon. for theta perturb." "" "" +rconfig integer lminforct namelist,stoch 1 1 - "min. forcing wavenumber in lat. for theta perturb." "" "" +rconfig integer kmaxforc namelist,stoch 1 1000000 - "max. forcing wavenumber in lon. for psi perturb." "" "" +rconfig integer lmaxforc namelist,stoch 1 1000000 - "max. forcing wavenumber in lat. for psi perturb." "" "" +rconfig integer kmaxforct namelist,stoch 1 1000000 - "max. forcing wavenumber in lon. for theta perturb." "" "" +rconfig integer lmaxforct namelist,stoch 1 1000000 - "max. forcing wavenumber in lat. for theta perturb." "" "" +rconfig integer kmaxforch derived 1 0 - "sneak variable to make it work" "" "" +rconfig integer lmaxforch derived 1 0 - "sneak variable to make it work" "" "" +rconfig integer kmaxforcth derived 1 0 - "sneak variable to make it work" "" "" +rconfig integer lmaxforcth derived 1 0 - "sneak variable to make it work" "" "" -rconfig real stoch_force_global_opt derived 1 0 h "stoch_force_global_opt" "global (across domains) stochastic forcing option" "" +# Namelist parameters SPPT +rconfig real gridpointvariance namelist,stoch max_domains 0.25 - "gridpoint variance" +rconfig real sppt_thresh_fact namelist,stoch max_domains 2.0 - "threshold for SPPT perturbations in std dev of gridpointvariance" +rconfig real l_sppt namelist,stoch max_domains 15000.0 - "Length scale in meters" +rconfig real tau_sppt namelist,stoch max_domains 21600.0 - "Decorrelation time scale in s" +rconfig integer stoch_force_global_opt derived 1 0 - "stoch_force_global_opt" "global (across domains) stochastic forcing option" "" # Package declarations -package no_stoch_force stoch_force_global_opt==0 - - -package stoch_backscatter stoch_force_global_opt==1 - state:ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch,SPSTREAMFORCC,SPSTREAMFORCS,SPTFORCC,SPTFORCS,SPSTREAM_AMP,SPT_AMP,VERTSTRUCC,VERTSTRUCS,RU_IMAG,RU_REAL_xxx,RU_REAL_yyy,RU_IMAG_xxx,RU_IMAG_yyy,RV_IMAG,RV_REAL_xxx,RV_REAL_yyy,RV_IMAG_xxx,RV_IMAG_yyy,RT_IMAG,RT_REAL_xxx,RT_REAL_yyy,RT_IMAG_xxx,RT_IMAG_yyy,RU_REAL,RV_REAL,RT_REAL +package no_stoch_force stoch_force_opt==0 - - + +package stoch_backscatter stoch_force_opt==1 - state:ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch,SPSTREAMFORCC,SPSTREAMFORCS,SPTFORCC,SPTFORCS,SPSTREAM_AMP,SPT_AMP,VERTSTRUCC,VERTSTRUCS,RU_IMAG,RU_REAL_xxx,RU_REAL_yyy,RU_IMAG_xxx,RU_IMAG_yyy,RV_IMAG,RV_REAL_xxx,RV_REAL_yyy,RV_IMAG_xxx,RV_IMAG_yyy,RT_IMAG,RT_REAL_xxx,RT_REAL_yyy,RT_IMAG_xxx,RT_IMAG_yyy,RU_REAL,RV_REAL,RT_REAL,VERTAMPT,VERTAMPUV + +package perturb_tendf stoch_force_opt==2 - state:ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch,SPSTREAMFORCC,SPSTREAMFORCS,SPTFORCC,SPTFORCS,SPSTREAM_AMP,SPT_AMP,VERTSTRUCC,VERTSTRUCS,RU_IMAG,RU_REAL_xxx,RU_REAL_yyy,RU_IMAG_xxx,RU_IMAG_yyy,RV_IMAG,RV_REAL_xxx,RV_REAL_yyy,RV_IMAG_xxx,RV_IMAG_yyy,RT_IMAG,RT_REAL_xxx,RT_REAL_yyy,RT_IMAG_xxx,RT_IMAG_yyy,RU_REAL,RV_REAL,RT_REAL,VERTAMPT,VERTAMPUV + diff --git a/wrfv2_fire/Registry/registry.var b/wrfv2_fire/Registry/registry.var index 6a8f2fc8..9d1c3c14 100644 --- a/wrfv2_fire/Registry/registry.var +++ b/wrfv2_fire/Registry/registry.var @@ -107,13 +107,29 @@ rconfig integer analysis_accu namelist,wrfvar2 1 900 - "an rconfig logical calc_w_increment namelist,wrfvar2 1 .false. - "calc_w_increment" "" "" rconfig logical dt_cloud_model namelist,wrfvar2 1 .false. - "dt_cloud_model" "" "" rconfig logical write_mod_filtered_obs namelist,wrfvar2 1 .false. - "write_mod_filtered_obs" "" "" -rconfig logical var_wind namelist,wrfvar2 1 .false. - "var_wind" "" "" +rconfig logical wind_sd namelist,wrfvar2 1 .false. - "assimilation of wind speed and direction" +rconfig logical wind_sd_buoy namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_synop namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_ships namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_metar namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_sound namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_pilot namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_airep namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_qscat namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_tamdar namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_geoamv namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_mtgirs namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_polaramv namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_sd_profiler namelist,wrfvar2 1 .false. - "obs. types employing wind_sd" +rconfig logical wind_stats_sd namelist,wrfvar2 1 .false. - "statistics output as sd" "" "" rconfig logical qc_rej_both namelist,wrfvar2 1 .false. - "qc_rej_both" "" "" rconfig integer fg_format namelist,wrfvar3 1 1 - "fg_format" "" "1=WRF-ARW, 2=WRF-NMM, 3=WRF-GLOBAL, 4=KMA" rconfig integer ob_format namelist,wrfvar3 1 2 - "ob_format" "" "1=BUFR,2=ASCII" +rconfig integer ob_format_gpsro namelist,wrfvar3 1 2 - "ob_format_gpsro" "" "1=BUFR,2=ASCII" rconfig integer num_fgat_time namelist,wrfvar3 1 1 - "num_fgat_time" "" "" rconfig logical thin_conv namelist,wrfvar4 1 .true. - "thin_conv" "" "" -rconfig real thin_mesh_conv namelist,wrfvar4 max_instruments 20.0 - "thin_mesh_conv" "" "" +rconfig logical thin_conv_ascii namelist,wrfvar4 1 .false. - "thin_conv_ascii" "" "" +rconfig real thin_mesh_conv namelist,wrfvar4 num_ob_indexes 20.0 - "thin_mesh_conv" "" "" rconfig logical thin_rainobs namelist,wrfvar4 1 .true. - "thin_rainobs" "" "" rconfig logical use_synopobs namelist,wrfvar4 1 .true. - "use_synopobs" "" "" rconfig logical use_shipsobs namelist,wrfvar4 1 .true. - "use_shipsobs" "" "" @@ -158,6 +174,7 @@ rconfig logical use_eos_amsuaobs namelist,wrfvar4 1 .false. - "use rconfig logical use_hsbobs namelist,wrfvar4 1 .false. - "use_hsbobs" "" "" rconfig logical use_ssmisobs namelist,wrfvar4 1 .false. - "use_ssmisobs" "" "" rconfig logical use_iasiobs namelist,wrfvar4 1 .false. - "use_iasiobs" "" "" +rconfig logical use_seviriobs namelist,wrfvar4 1 .false. - "use_seviriobs" "" "" rconfig logical use_kma1dvar namelist,wrfvar4 1 .false. - "use_kma1dvar" "" "" rconfig logical use_filtered_rad namelist,wrfvar4 1 .false. - "use_filtered_rad" "" "" rconfig logical use_obs_errfac namelist,wrfvar4 1 .false. - "use_obs_errfac" "" "" @@ -167,10 +184,10 @@ rconfig logical use_mwhsobs namelist,wrfvar4 1 .false. - "use rconfig logical check_max_iv namelist,wrfvar5 1 .true. - "check_max_iv" "" "" rconfig real max_error_t namelist,wrfvar5 1 5.0 - "max_error_t" "" "" rconfig real max_error_uv namelist,wrfvar5 1 5.0 - "max_error_uv" "" "" -rconfig real max_error_sp namelist,wrfvar5 1 5.0 - "max_error_sp" "" "" +rconfig real max_error_spd namelist,wrfvar5 1 5.0 - "max_error_spd" "" "" rconfig real max_error_dir namelist,wrfvar5 1 5.0 - "max_error_dir" "" "" -rconfig real max_omb_sp namelist,wrfvar5 1 14.0 - "max_omb_sp" "" "" -rconfig real max_omb_dir namelist,wrfvar5 1 135.0 - "max_omb_dir" "" "" +rconfig real max_omb_spd namelist,wrfvar5 1 100.0 - "max_omb_spd" "" "" +rconfig real max_omb_dir namelist,wrfvar5 1 1000.0 - "max_omb_dir" "" "" rconfig real max_error_pw namelist,wrfvar5 1 5.0 - "max_error_pw" "" "" rconfig real max_error_ref namelist,wrfvar5 1 5.0 - "max_error_ref" "" "" rconfig real max_error_rh namelist,wrfvar5 1 5.0 - "max_error_rh" "" "" @@ -332,7 +349,7 @@ rconfig integer rtminit_satid namelist,wrfvar14 max_instruments - rconfig integer rtminit_sensor namelist,wrfvar14 max_instruments -1.0 - "rtminit_sensor" "" "" rconfig integer rad_monitoring namelist,wrfvar14 max_instruments 0 - "rad_monitoring" "" "" rconfig real thinning_mesh namelist,wrfvar14 max_instruments 60.0 - "thinning_mesh" "" "" -rconfig logical thinning namelist,wrfvar14 1 .false. - "thinning " "" "" +rconfig logical thinning namelist,wrfvar14 1 .true. - "thinning " "" "" rconfig logical read_biascoef namelist,wrfvar14 1 .false. - "read_biascoef" "" "" rconfig logical biascorr namelist,wrfvar14 1 .false. - "biascorr" "" "" rconfig logical biasprep namelist,wrfvar14 1 .false. - "biasprep" "" "" @@ -352,7 +369,7 @@ rconfig integer mw_emis_sea namelist,wrfvar14 1 1 - "mw rconfig integer tovs_min_transfer namelist,wrfvar14 1 10 - "tovs_min_transfer" "" "" rconfig logical tovs_batch namelist,wrfvar14 1 .false. - "tovs_batch" "" "" rconfig integer rtm_option namelist,wrfvar14 1 1 - "rtm_option" "" "" -rconfig logical use_crtm_kmatrix namelist,wrfvar14 1 .false. - "use_crtm_kmatrix" "" "" +rconfig logical use_crtm_kmatrix namelist,wrfvar14 1 .true. - "use_crtm_kmatrix" "" "" rconfig logical use_rttov_kmatrix namelist,wrfvar14 1 .false. - "use_rttov_kmatrix" "" "" rconfig logical crtm_cloud namelist,wrfvar14 1 .false. - "crtm_cloud" "" "" rconfig logical only_sea_rad namelist,wrfvar14 1 .false. - "only_sea_rad" "" "" @@ -379,6 +396,11 @@ rconfig logical airs_warmest_fov namelist,wrfvar14 1 .false. - "ai rconfig logical use_satcv namelist,wrfvar14 2 .false. - "use_satcv" "" "" rconfig logical use_blacklist_rad namelist,wrfvar14 1 .false. - "use_blacklist_rad" "" "" rconfig logical calc_weightfunc namelist,wrfvar14 1 .false. - "calc_weightfunc" "" "" +rconfig character crtm_coef_path namelist,wrfvar14 1 "./crtm_coeffs" - "crtm_coef_path" "" "" +rconfig character crtm_irwater_coef namelist,wrfvar14 1 "Nalli.IRwater.EmisCoeff.bin" - "crtm_irwater_coef" "" "" +rconfig character crtm_mwwater_coef namelist,wrfvar14 1 "FASTEM5.MWwater.EmisCoeff.bin" - "crtm_mwwater_coef" "" "" +rconfig character crtm_irland_coef namelist,wrfvar14 1 "USGS.IRland.EmisCoeff.bin" - "crtm_irland_coef" "" "" +rconfig character crtm_visland_coef namelist,wrfvar14 1 "USGS.VISland.EmisCoeff.bin" - "crtm_visland_coef" "" "" rconfig integer num_pseudo namelist,wrfvar15 1 0 - "num_pseudo" "" "" rconfig real pseudo_x namelist,wrfvar15 1 1.0 - "pseudo_x" "" "" rconfig real pseudo_y namelist,wrfvar15 1 1.0 - "pseudo_y" "" "" @@ -393,6 +415,8 @@ rconfig real alpha_corr_scale namelist,wrfvar16 1 1500.0 - "al rconfig real alpha_std_dev namelist,wrfvar16 1 1.0 - "alpha_std_dev" "" "" rconfig logical alpha_vertloc namelist,wrfvar16 1 .false. - "alpha_vertloc" "" "" rconfig logical alpha_hydrometeors namelist,wrfvar16 1 .false. - "alpha_hydrometeors" "" "" +rconfig logical hybrid_dual_res namelist,wrfvar16 1 .false. - "hybrid_dual_res" "" "" +rconfig integer dual_res_upscale_opt namelist,wrfvar16 1 3 - "dual_res_upscale_opt" "" "" rconfig character analysis_type namelist,wrfvar17 1 "3D-VAR" - "analysis_type" "" "" rconfig integer sensitivity_option namelist,wrfvar17 1 -1 - "sensitivity_option" "" "" rconfig logical adj_sens namelist,wrfvar17 1 .false. - "adj_sens" "" "" @@ -407,6 +431,7 @@ rconfig real jcdfi_penalty namelist,perturbation 1 10. - rconfig logical enable_identity namelist,perturbation 1 .false. - "enable identity AD/TL model" "" "" rconfig logical trajectory_io namelist,perturbation 1 .true. - "0:disk IO;1:memory IO" "" "" rconfig logical var4d_detail_out namelist,perturbation 1 .false. - "true:output perturbation, gradient to disk" "" "" +rconfig logical var4d_run namelist,perturbation 1 .true. - "true: exlcude the P calculation in start_em" "" "" # NAMELIST DERIVED rconfig integer mp_physics_4dvar derived max_domains -1 - "mp_physics_4dvar" "" "-1 = no 4dvar and so no need to allocate a_ and g_ moist and scalar variables, >0 = running 4dvar, so allocate a_ and g_ moist and scalar variables appropriate for selected microphysics package" # diff --git a/wrfv2_fire/Registry/registry.var_chem b/wrfv2_fire/Registry/registry.var_chem index 8e6bdae0..c3d019e8 100644 --- a/wrfv2_fire/Registry/registry.var_chem +++ b/wrfv2_fire/Registry/registry.var_chem @@ -1,6 +1,8 @@ dimspec o 3 namelist=ne_area z bio_emissions_dimension dimspec + 2 namelist=kemit z emissions_zdim dimspec nm 2 namelist=nmegan z megan_species +dimspec ndv 3 namelist=ndepvel z deposition_velocity_species +dimspec kdv 2 namelist=kdepvel z deposition_velocity_vert_levels dimspec dust 2 namelist=kfuture z klevs_for_dust dimspec ] 2 namelist=kfire z klevs_for_fire dimspec % 2 namelist=kdvel z klevs_for_dvel diff --git a/wrfv2_fire/arch/Config_new.pl b/wrfv2_fire/arch/Config_new.pl index c8ad8661..0aa046d9 100644 --- a/wrfv2_fire/arch/Config_new.pl +++ b/wrfv2_fire/arch/Config_new.pl @@ -45,6 +45,7 @@ $sw_gpfs_lib = "-lgpfs"; $sw_curl_path = ""; $sw_curl_lib = "-lcurl"; +$sw_terrain_and_landuse = ""; while ( substr( $ARGV[0], 0, 1 ) eq "-" ) { if ( substr( $ARGV[0], 1, 5 ) eq "perl=" ) @@ -338,7 +339,11 @@ printf "------------------------------------------------------------------------\n" ; $optchoice = $response ; - +if ( $response == 2 || $response == 3 ) { + if ( $ENV{'TERRAIN_AND_LANDUSE'} eq "1" && index($sw_wrf_core, "EM_CORE") > -1 ) { + $sw_terrain_and_landuse =" -DTERRAIN_AND_LANDUSE" ; + } +} open CONFIGURE_DEFAULTS, "cat ./arch/configure_new.defaults |" ; $latchon = 0 ; while ( ) @@ -446,6 +451,14 @@ $_ =~ s:CONFIGURE_GRIB2_LIB::g ; } + if ( $sw_terrain_and_landuse ) + { + $_ =~ s/CONFIGURE_TERRAIN_AND_LANDUSE/$sw_terrain_and_landuse/g; + } + else + { + $_ =~ s:CONFIGURE_TERRAIN_AND_LANDUSE::g; + } # ESMF substitutions in configure.defaults if ( $sw_esmflib_path && $sw_esmfinc_path ) @@ -585,8 +598,16 @@ } if ( $response == 2 ) { $sw_nest_opt = "-DMOVE_NESTS" ; + if ( $ENV{'TERRAIN_AND_LANDUSE'} eq "1" ) { + $sw_terrain_and_landuse =" -DTERRAIN_AND_LANDUSE" ; + $sw_nest_opt = $sw_nest_opt . $sw_terrain_and_landuse; + } } elsif ( $response == 3 ) { $sw_nest_opt = "-DMOVE_NESTS -DVORTEX_CENTER" ; + if ( $ENV{'TERRAIN_AND_LANDUSE'} eq "1" ) { + $sw_terrain_and_landuse =" -DTERRAIN_AND_LANDUSE" ; + $sw_nest_opt = $sw_nest_opt . $sw_terrain_and_landuse; + } } if ( $paropt eq 'smpar' || $paropt eq 'dm+sm' ) { $sw_ompparallel = "OMP" ; } if ( $paropt eq 'dmpar' || $paropt eq 'dm+sm' ) { diff --git a/wrfv2_fire/arch/configure_new.defaults b/wrfv2_fire/arch/configure_new.defaults index fe0c6eab..92b8908f 100644 --- a/wrfv2_fire/arch/configure_new.defaults +++ b/wrfv2_fire/arch/configure_new.defaults @@ -16,7 +16,7 @@ LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = # -fdefault-real-8 # uncomment manually ARCH_LOCAL = -DNEC -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM -CFLAGS_LOCAL = -c -DLANDREAD_STUB +CFLAGS_LOCAL = -c #-DNCARIBM_NOC99 -Xa -Kc99 LDFLAGS_LOCAL = -Wl,-h nodefs CPLUSPLUSLIB = @@ -33,7 +33,7 @@ FCBASEOPTS_NO_G = -w -Wf'-M noflunf -M nozdiv' $(FORMAT_FREE) $(BYTESWAPIO FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -I/SX/usr/include/module/dwdadW64/ TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = sxar ARFLAGS = ru M4 = m4 -B 14000 @@ -59,7 +59,7 @@ LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = # -fdefault-real-8 # uncomment manually ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM -CFLAGS_LOCAL = -w -O3 -c -DLANDREAD_STUB +CFLAGS_LOCAL = -w -O3 -c LDFLAGS_LOCAL = CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) @@ -75,7 +75,7 @@ FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -116,7 +116,7 @@ FCBASEOPTS_NO_G = -Wno=101,139,155,158 $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -fmod=$(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -133,8 +133,8 @@ OMPCC = # -mp SFC = pgf90 SCC = gcc CCOMP = pgcc -DM_FC = mpif90 -f90=$(SFC) -DM_CC = mpicc -cc=$(SCC) +DM_FC = mpif90 +DM_CC = mpicc FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) @@ -157,49 +157,7 @@ FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional -CPP = /lib/cpp -C -P -AR = ar -ARFLAGS = ru -M4 = m4 -B 14000 -RANLIB = ranlib -CC_TOOLS = $(SCC) - -########################################################### -#ARCH Linux x86_64 i486 i586 i686 PGI compiler with pgcc YELLOWSTONE # serial smpar dmpar dm+sm -# - -DMPARALLEL = # 1 -OMPCPP = # -D_OPENMP -OMP = # -mp -Minfo=mp -Mrecursive -OMPCC = # -mp -SFC = pgf90 -SCC = pgcc -CCOMP = pgcc -DM_FC = mpif90 -f90=$(SFC) -DM_CC = mpicc -cc=$(SCC) -FC = CONFIGURE_FC -CC = CONFIGURE_CC -LD = $(FC) -RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM -CFLAGS_LOCAL = -w -O3 -LDFLAGS_LOCAL = -CPLUSPLUSLIB = -ESMF_LDFLAG = $(CPLUSPLUSLIB) -FCOPTIM = -O3 #-fastsse -Mvect=noaltcode -Msmartalloc -Mprefetch=distance:8 -Mfprelaxed # -Minfo=all =Mneginfo=all -FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O0 -FCDEBUG = # -g $(FCNOOPT) # -C -Ktrap=fp -traceback -FORMAT_FIXED = -Mfixed -FORMAT_FREE = -Mfree -FCSUFFIX = -BYTESWAPIO = -byteswapio -FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) -FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) -MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -240,7 +198,7 @@ FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -257,8 +215,8 @@ OMPCC = # -mp SFC = pgf90 SCC = gcc CCOMP = pgcc -DM_FC = mpif90 -f90=$(SFC) -DM_CC = mpicc -cc=$(SCC) +DM_FC = mpif90 +DM_CC = mpicc FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) @@ -280,7 +238,7 @@ BYTESWAPIO = -byteswapio FCBASEOPTS = -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -354,7 +312,7 @@ FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FO FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 @@ -373,13 +331,13 @@ SFC = ifort -mmic SCC = icc -mmic CCOMP = icc -mmic DM_FC = mpiifort -mmic -DM_CC = mpicc -mmic +DM_CC = mpiicc -mmic FC = $(DM_FC) CC = $(DM_CC) LD = $(FC) RWORDSIZE = $(NATIVE_RWORDSIZE) PROMOTION = -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DCHUNK=16 -DXEON_OPTIMIZED_WSM5 -DOPTIMIZE_CFL_TEST -DFSEEKO64_OK -DINTEL_YSU_KLUDGE -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DCHUNK=16 -DXEON_OPTIMIZED_WSM5 -DXEON_SIMD -DOPTIMIZE_CFL_TEST -DFSEEKO64_OK -DINTEL_YSU_KLUDGE -DWRF_USE_CLM OPTNOSIMD = OPTKNC = -fimf-precision=low -fimf-domain-exclusion=15 -opt-assume-safe-padding -opt-streaming-stores always -opt-streaming-cache-evict=0 -mP2OPT_hlo_pref_use_outer_strategy=F CFLAGS_LOCAL = -w -O3 $(OPTKNC) @@ -398,7 +356,7 @@ FCBASEOPTS_NO_G = -w -openmp -auto -ftz -fno-alias -fp-model fast=1 -no-pr FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 @@ -423,7 +381,7 @@ CC = $(DM_CC) LD = $(FC) RWORDSIZE = $(NATIVE_RWORDSIZE) PROMOTION = -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DINTEL_ALIGN64 -DCHUNK=64 -DXEON_OPTIMIZED_WSM5 -DOPTIMIZE_CFL_TEST -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DCHUNK=64 -DXEON_OPTIMIZED_WSM5 -DOPTIMIZE_CFL_TEST -DWRF_USE_CLM OPTNOSIMD = OPTAVX = -xAVX CFLAGS_LOCAL = -w -O3 $(OPTAVX) @@ -442,55 +400,13 @@ FCBASEOPTS_NO_G = -w $(OMP) -auto -ftz -fno-alias -fp-model fast=1 -no-pre FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 RANLIB = ranlib CC_TOOLS = gcc -########################################################### -#ARCH Linux x86_64 i486 i586 i686, ifort compiler with icc YELLOWSTONE #serial smpar dmpar dm+sm -# - -DMPARALLEL = # 1 -OMPCPP = # -D_OPENMP -OMP = # -openmp -fpp -auto -OMPCC = # -openmp -fpp -auto -SFC = ifort -SCC = icc -CCOMP = icc -DM_FC = mpif90 -f90=$(SFC) -DM_CC = mpicc -cc=$(SCC) -FC = CONFIGURE_FC -CC = CONFIGURE_CC -LD = $(FC) -RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM -CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars -LDFLAGS_LOCAL = -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common -CPLUSPLUSLIB = -ESMF_LDFLAG = $(CPLUSPLUSLIB) -FCOPTIM = -O3 -FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O0 -fno-inline -fno-ip -FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u -FORMAT_FIXED = -FI -FORMAT_FREE = -FR -FCSUFFIX = -BYTESWAPIO = -convert big_endian -FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common -FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) -MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -C -P -AR = ar -ARFLAGS = ru -M4 = m4 -RANLIB = ranlib -CC_TOOLS = $(SCC) - ########################################################### #ARCH Linux x86_64 i486 i586 i686, ifort compiler with icc, SGI MPT #serial smpar dmpar dm+sm # @@ -552,7 +468,7 @@ FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FO FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 @@ -598,7 +514,7 @@ FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FO FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 @@ -676,7 +592,7 @@ FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) LIB_LOCAL = -L/usr/lib -lmpi MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 @@ -756,7 +672,7 @@ FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) LIB_LOCAL = -L/usr/lib -lmpi MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 @@ -797,7 +713,7 @@ FCBASEOPTS_NO_G = -w -fno-second-underscore $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -822,7 +738,7 @@ LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = # -fdefault-real-8 # uncomment manually ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM -CFLAGS_LOCAL = -w -O3 -c -DLANDREAD_STUB +CFLAGS_LOCAL = -w -O3 -c LDFLAGS_LOCAL = CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) @@ -838,7 +754,7 @@ FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 -G @@ -855,8 +771,8 @@ OMPCC = # -mp SFC = pgf90 SCC = pgcc CCOMP = pgcc -DM_FC = mpif90 -f90=$(SFC) -DM_CC = mpicc -cc=$(SCC) +DM_FC = mpif90 +DM_CC = mpicc FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) @@ -879,7 +795,7 @@ FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) -Mnomod MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional -CPP = cpp -C -P -xassembler-with-cpp +CPP = cpp -P -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -922,7 +838,7 @@ FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FO FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = cpp -C -P -xassembler-with-cpp +CPP = cpp -P -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -965,7 +881,7 @@ FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FO FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = cpp -C -P -xassembler-with-cpp +CPP = cpp -P -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1007,7 +923,7 @@ FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) LIB_LOCAL = -L/usr/lib -lSystemStubs MODULE_SRCH_FLAG = -fmod=$(WRF_SRC_ROOT_DIR)/main TRADFLAG = -traditional -CPP = cpp -C -P -xassembler-with-cpp +CPP = cpp -P -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1032,7 +948,7 @@ LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = # -fdefault-real-8 # uncomment manually ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DMACOS -DWRF_USE_CLM -CFLAGS_LOCAL = -w -O3 -c -DLANDREAD_STUB -DMACOS +CFLAGS_LOCAL = -w -O3 -c -DMACOS LDFLAGS_LOCAL = CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) @@ -1048,7 +964,7 @@ FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = cpp -C -P -xassembler-with-cpp +CPP = cpp -P -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1090,8 +1006,8 @@ BYTESWAPIO = FCBASEOPTS_NO_G = -qsave -qmaxmem=32767 -qspillsize=32767 -w FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -fmod=$(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -CPP = cpp -C -P +TRADFLAG = -traditional +CPP = cpp -P AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1134,14 +1050,74 @@ BYTESWAPIO = FCBASEOPTS_NO_G = -w -qspill=81920 -qmaxmem=-1 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap -C # -qinitauto=7FF7FFFF FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -CPP = /lib/cpp -C -P +TRADFLAG = -traditional +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib CC_TOOLS = cc +########################################################### +#ARCH Cray XT CLE/Linux x86_64, PGI compiler with gcc # serial dmpar smpar dm+sm +# +# Recommended CLE/Linux memory allocation settings at run time: +# export MALLOC_MMAP_MAX_=0 +# export MALLOC_TRIM_THRESHOLD_=536870912 +# +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -mp -Mrecursive +OMPCC = # -mp +SFC = ftn +SCC = gcc +CCOMP = pgcc +DM_FC = ftn +DM_CC = gcc -I$(MPICH_DIR)/include +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -r$(RWORDSIZE) -i4 +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR +CFLAGS_LOCAL = -w -O3 +LDFLAGS_LOCAL = +# module load libfast to use Cray XT fast math library +#LIB_LOCAL = -lfast_mv +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +# PGI recommended +FCOPTIM = -O3 #-fastsse -Mvect=noaltcode -Msmartalloc -Mprefetch=distance:8 -Mfprelaxed # -Minfo=all =Mneginfo=all +# For Pathscale compiler +#FCOPTIM = -O3 -OPT:Ofast +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 +OPTERON_TYPE = +# Use this for AMD Opteron quad-core +#OPTERON_TYPE = -tp barcelona-64 +#OPTERON_TYPE = -tp shanghai-64 +# Use this for AMD Opteron six-way Istanbul +#OPTERON_TYPE = -tp istanbul +FCDEBUG = # -g $(FCNOOPT) # -C -Ktrap=fp -traceback +FORMAT_FIXED = -Mfixed +FORMAT_FREE = -Mfree +# For Pathscale compiler +#OPTERON_TYPE = -march=barcelona -msse4a +#FORMAT_FIXED = -fixedform +#FORMAT_FREE = -freeform +FCSUFFIX = +BYTESWAPIO = -byteswapio +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OPTERON_TYPE) $(OMP) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = +TRADFLAG = -traditional +CPP = /lib/cpp -P $(TRADFLAG) +AR = ar +ARFLAGS = ru +M4 = m4 -B 14000 +RANLIB = ranlib +CC_TOOLS = $(SCC) + ########################################################### #ARCH Cray XE and XC30 CLE/Linux x86_64, Cray CCE compiler # serial dmpar smpar dm+sm # Use this for both XE6 systems with AMD Opteron and XC30 with Intel SB or IB @@ -1177,7 +1153,7 @@ FCBASEOPTS_NO_G = -h noomp -N255 $(FORMAT_FREE) $(BYTESWAPIO) #-ra FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 @@ -1221,7 +1197,7 @@ FCBASEOPTS_NO_G = -w -ftz -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-vec-re FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 @@ -1229,7 +1205,7 @@ RANLIB = ranlib CC_TOOLS = gcc ########################################################### -#ARCH Linux x86_64, Fujitsu FX10 mpifrtpx and mpifccpx compilers #serial smpar dmpar dm+sm +#ARCH Fujitsu FX10 Linux SPARC64IXfx, mpifrtpx and mpifccpx compilers #serial smpar dmpar dm+sm # DMPARALLEL = # 1 OMPCPP = # -D_OPENMP @@ -1239,7 +1215,7 @@ SFC = frtpx SCC = fccpx CCOMP = fccpx DM_FC = mpifrtpx -DM_CC = mpifccpx +DM_CC = mpifccpx -DMPI2_SUPPORT -DMPI2_THREAD_SUPPORT FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) @@ -1262,7 +1238,7 @@ FCBASEOPTS_NO_G = -Kautoobjstack,ocl -V -Qa,d,i,p,t,x -Koptmsg=2 $(FORMAT_ FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional -CPP = /lib/cpp -C -P +CPP = /lib/cpp -P AR = ar ARFLAGS = ru M4 = m4 @@ -1290,8 +1266,8 @@ LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 # If system has even more processors, set VERY_LARGE_MAXPROC to that number -ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DLANDREAD_STUB -DVERY_LARGE_MAXPROC=36768 -DBLUEGENE -DWRF_USE_CLM -CFLAGS_LOCAL = -DNOUNDERSCORE -DNCARIBM_NOC99 $(MPI_INC) -DLANDREAD_STUB +ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DVERY_LARGE_MAXPROC=36768 -DBLUEGENE -DWRF_USE_CLM +CFLAGS_LOCAL = -DNOUNDERSCORE -DNCARIBM_NOC99 $(MPI_INC) LIB_LOCAL = $(MPI_LIB) LDFLAGS_LOCAL = -Wl,--allow-multiple-definition -qstatic CPLUSPLUSLIB = @@ -1306,12 +1282,12 @@ BYTESWAPIO = FCBASEOPTS_NO_G = -w -qspill=20000 -qmaxmem=64000 $(FORMAT_FREE) $(BYTESWAPIO) $(MPI_INC) #-qflttrap=zerodivide:invalid:enable -qsigtrap FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = +TRADFLAG = -traditional # this might be different on different systems but we want the xlf version of cpp, not Linux's # NYBlue -CPP = /opt/ibmcmp/xlf/bg/10.1/exe/cpp -C -P +CPP = /opt/ibmcmp/xlf/bg/10.1/exe/cpp -P # frost.ucar.edu -CPP = /opt/ibmcmp/xlf/9.1/exe/cpp -C -P +CPP = /opt/ibmcmp/xlf/9.1/exe/cpp -P AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1337,8 +1313,8 @@ LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 # If system has even more processors, set VERY_LARGE_MAXPROC to that number -ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DLANDREAD_STUB -DVERY_LARGE_MAXPROC=36768 -DBLUEGENE -DWRF_USE_CLM -CFLAGS_LOCAL = -DNOUNDERSCORE -DLANDREAD_STUB +ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DVERY_LARGE_MAXPROC=36768 -DBLUEGENE -DWRF_USE_CLM +CFLAGS_LOCAL = -DNOUNDERSCORE LIB_LOCAL = LDFLAGS_LOCAL = -Wl,--allow-multiple-definition,--relax -qstatic CPLUSPLUSLIB = @@ -1353,10 +1329,10 @@ BYTESWAPIO = FCBASEOPTS_NO_G = -w -qspill=20000 -qmaxmem=64000 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = +TRADFLAG = -traditional # this might be different on different systems but we want the xlf version of cpp, not Linux's # surveyor.alcf.anl.gov -CPP = /opt/ibmcmp/xlf/bg/11.1/exe/cpp -C -P +CPP = /opt/ibmcmp/xlf/bg/11.1/exe/cpp -P AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1381,8 +1357,8 @@ LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 # If system has even more processors, set VERY_LARGE_MAXPROC to that number -ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DLANDREAD_STUB -DVERY_LARGE_MAXPROC=36768 -DWRF_USE_CLM -CFLAGS_LOCAL = -DNOUNDERSCORE -DLANDREAD_STUB +ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DVERY_LARGE_MAXPROC=36768 -DWRF_USE_CLM +CFLAGS_LOCAL = -DNOUNDERSCORE LDFLAGS_LOCAL = CPLUSPLUSLIB = -lC ESMF_LDFLAG = $(CPLUSPLUSLIB) @@ -1396,14 +1372,56 @@ BYTESWAPIO = FCBASEOPTS_NO_G = -w -qspill=20000 -qmaxmem=32767 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = +TRADFLAG = -traditional # this might be different on different systems but we want the xlf version of cpp, not Linux -CPP = /opt/ibmcmp/xlf/11.1/exe/cpp -C -P +CPP = /opt/ibmcmp/xlf/11.1/exe/cpp -P AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib CC_TOOLS = xlc -q64 + +########################################################### +#ARCH Linux x86_64 i486 i586 i686, PGI compiler with pgcc # serial smpar dmpar dm+sm +# +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -mp -Minfo=mp -Mrecursive +OMPCC = # -mp +SFC = pgf90 +SCC = pgcc +CCOMP = pgcc +DM_FC = mpif90 +DM_CC = mpicc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -r$(RWORDSIZE) -i4 +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +CFLAGS_LOCAL = -w -O3 +LDFLAGS_LOCAL = +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -O3 #-fastsse -Mvect=noaltcode -Msmartalloc -Mprefetch=distance:8 -Mfprelaxed # -Minfo=all =Mneginfo=all +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 +FCDEBUG = # -g $(FCNOOPT) # -C -Ktrap=fp -traceback +FORMAT_FIXED = -Mfixed +FORMAT_FREE = -Mfree +FCSUFFIX = +BYTESWAPIO = -byteswapio +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main +TRADFLAG = -traditional +CPP = /lib/cpp -P +AR = ar +ARFLAGS = ru +M4 = m4 -B 14000 +RANLIB = ranlib +CC_TOOLS = $(SCC) + ########################################################### #ARCH CYGWIN_NT i686, PGI compiler on Windows # serial smpar dmpar dm+sm # @@ -1414,15 +1432,15 @@ OMPCC = # -mp SFC = pgf90 SCC = pgcc CCOMP = pgcc -DM_FC = pgf90 -Mmpi=msmpi -DM_CC = pgcc -Mmpi=msmpi +DM_FC = pgf90 +DM_CC = pgcc FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -D_WIN32 -DWRF_USE_CLM -CFLAGS_LOCAL = -w -O3 -DMEMCPY_FOR_BCOPY -DLANDREAD_STUB +CFLAGS_LOCAL = -w -O3 -DMEMCPY_FOR_BCOPY LDFLAGS_LOCAL = Ws2_32.lib # -lnetcdff CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) diff --git a/wrfv2_fire/arch/noopt_exceptions b/wrfv2_fire/arch/noopt_exceptions index 156a0ae4..95544e54 100644 --- a/wrfv2_fire/arch/noopt_exceptions +++ b/wrfv2_fire/arch/noopt_exceptions @@ -148,7 +148,7 @@ wrf_fddaobs_in.o \ wrf_tsin.o : $(RM) $@ $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F > $*.bb - $(SED_FTN) $*.bb | $(CPP) > $*.f90 + $(SED_FTN) $*.bb | $(CPP) $(TRADFLAG) > $*.f90 $(RM) $*.b $*.bb @ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \ echo COMPILING $*.F for 4DVAR ; \ @@ -166,7 +166,7 @@ wrf_tsin.o : solve_em.o : $(RM) $@ $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F > $*.bb - $(SED_FTN) $*.bb | $(CPP) > $*.f90 + $(SED_FTN) $*.bb | $(CPP) $(TRADFLAG) > $*.f90 $(RM) $*.b $*.bb $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $(SOLVE_EM_SPECIAL) $(FCSUFFIX) $*.f90 @@ -175,7 +175,7 @@ module_sf_ruclsm.o : module_sf_ruclsm.F module_sf_ruclsm.o : $(RM) $@ $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F > $*.bb - $(SED_FTN) $*.bb | $(CPP) > $*.f90 + $(SED_FTN) $*.bb | $(CPP) $(TRADFLAG) > $*.f90 $(RM) $*.b $*.bb if $(FGREP) '!$$OMP' $*.f90 ; then \ if [ -n "$(OMP)" ] ; then echo COMPILING $*.F WITH OMP ; fi ; \ @@ -266,7 +266,7 @@ module_comm_nesting_dm.o \ module_configure.o : $(RM) $@ $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F > $*.bb - $(SED_FTN) $*.bb | $(CPP) > $*.f90 + $(SED_FTN) $*.bb | $(CPP) $(TRADFLAG) > $*.f90 @ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \ echo COMPILING $*.F for 4DVAR ; \ $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \ diff --git a/wrfv2_fire/arch/noopt_exceptions_f b/wrfv2_fire/arch/noopt_exceptions_f index 91664770..ad8cd99e 100644 --- a/wrfv2_fire/arch/noopt_exceptions_f +++ b/wrfv2_fire/arch/noopt_exceptions_f @@ -175,7 +175,7 @@ module_comm_nesting_dm.o \ module_configure.o : $(RM) $@ $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F > $*.bb - $(SED_FTN) $*.bb | $(CPP) > $*.f90 + $(SED_FTN) $*.bb | $(CPP) $(TRADFLAG) > $*.f90 @ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \ echo COMPILING $*.F for 4DVAR ; \ $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \ diff --git a/wrfv2_fire/arch/postamble_new b/wrfv2_fire/arch/postamble_new index 2c1d5229..10c7cf9c 100644 --- a/wrfv2_fire/arch/postamble_new +++ b/wrfv2_fire/arch/postamble_new @@ -66,11 +66,14 @@ CPPFLAGS = $(ARCHFLAGS) $(ENVCOMPDEFS) -I$(LIBINCLUDE) $(TRADFLAG) CON NETCDFPATH = CONFIGURE_NETCDF_PATH PNETCDFPATH = CONFIGURE_PNETCDF_PATH -bundled: wrf_ioapi_includes wrfio_grib_share wrfio_grib1 wrfio_int esmf_time fftpack CONFIGURE_ATMOCN -external: CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_PNF CONFIGURE_WRFIO_GRIB2 CONFIGURE_COMMS_EXTERNAL $(ESMF_TARGET) +bundled: io_only CONFIGURE_ATMOCN +external: io_only CONFIGURE_COMMS_EXTERNAL $(ESMF_TARGET) +io_only: esmf_time CONFIGURE_WRFIO_NF CONFIGURE_WRFIO_PNF CONFIGURE_WRFIO_GRIB2 \ + wrf_ioapi_includes wrfio_grib_share wrfio_grib1 wrfio_int fftpack + ###################### -externals: bundled external +externals: io_only bundled external gen_comms_serial : ( /bin/rm -f $(WRF_SRC_ROOT_DIR)/tools/gen_comms.c ) @@ -128,7 +131,8 @@ esmf_time : fftpack : ( cd $(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 ; \ - make $(J) FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ) + make $(J) FC="$(SFC)" FFLAGS="$(PROMOTION) $(FCDEBUG) $(FCBASEOPTS)" RANLIB="$(RANLIB)" AR="$(AR)" \ + ARFLAGS="$(ARFLAGS)" CPP="$(CPP)" CPPFLAGS="$(CPPFLAGS)" RM="$(RM)" ) atm_ocn : ( cd $(WRF_SRC_ROOT_DIR)/external/atm_ocn ; \ @@ -173,7 +177,7 @@ wrfio_esmf : .F.o: $(RM) $@ $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F > $*.bb - $(SED_FTN) $*.bb | $(CPP) > $*.f90 + $(SED_FTN) $*.bb | $(CPP) $(TRADFLAG) > $*.f90 $(RM) $*.b $*.bb @ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \ echo COMPILING $*.F for 4DVAR ; \ diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_args_to_update_rconst_cri_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_args_to_update_rconst_cri_mosaic_4bin_aq.inc new file mode 100644 index 00000000..9e479f6b --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_args_to_update_rconst_cri_mosaic_4bin_aq.inc @@ -0,0 +1,7 @@ +! +RO2, & +! +var,nvar,ind_ru14o2,ind_no,ind_oh,ind_rtn23o2,ind_rtn26o2,ind_ho2, & +ind_rtx28o2,ind_rn19o2,ind_nrn12ooh,ind_hoch2co3,ind_no2, & +! + diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_args_update_rconst_cri_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_args_update_rconst_cri_mosaic_4bin_aq.inc new file mode 100644 index 00000000..48b75a3a --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_args_update_rconst_cri_mosaic_4bin_aq.inc @@ -0,0 +1,6 @@ +! +RO2, & +var,nvar,ind_ru14o2,ind_no,ind_oh,ind_rtn23o2,ind_rtn26o2,ind_ho2, & +ind_rtx28o2,ind_rn19o2,ind_nrn12ooh,ind_hoch2co3,ind_no2, & +! + diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_decls_update_rconst_cri_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_decls_update_rconst_cri_mosaic_4bin_aq.inc new file mode 100644 index 00000000..3e1917a4 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/extra_decls_update_rconst_cri_mosaic_4bin_aq.inc @@ -0,0 +1,8 @@ +! + REAL(KIND=dp) :: RO2 + INTEGER, INTENT(in) :: nvar + REAL(KIND=dp), DIMENSION(nvar), INTENT(IN) :: var + INTEGER, INTENT(in) :: & + ind_ru14o2,ind_no,ind_oh,ind_rtn23o2,ind_rtn26o2,ind_ho2, & + ind_rtx28o2,ind_rn19o2,ind_nrn12ooh,ind_hoch2co3,ind_no2 + diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_a_cri_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_a_cri_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_a_cri_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_b_cri_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_b_cri_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_b_cri_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_e_cri_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_e_cri_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_e_cri_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ia_cri_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ia_cri_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ia_cri_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ib_cri_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ib_cri_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ib_cri_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ibu_cri_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ibu_cri_mosaic_4bin_aq.inc new file mode 100644 index 00000000..eed7a07d --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_ibu_cri_mosaic_4bin_aq.inc @@ -0,0 +1,17 @@ +! +! calculate summation for RO2 species + + RO2 = & + REAL(var(ind_CH3OO) + var(ind_C2H5O2) + var(ind_RN10O2) + var(ind_IC3H7O2) & + + var(ind_RN13O2) + var(ind_RN13AO2) + var(ind_RN16AO2) + var(ind_RN16O2) & + + var(ind_RN19O2) + var(ind_HOCH2CH2O2) + var(ind_RN9O2) + var(ind_RN12O2) & + + var(ind_RN15O2)+ var(ind_RN18O2)+ var(ind_RN15AO2) + var(ind_RN18AO2) & + + var(ind_CH3CO3) + var(ind_C2H5CO3)+ var(ind_RN11O2)+ var(ind_RN14O2) & + + var(ind_RN17O2) + var(ind_HOCH2CO3)+ var(ind_RU14O2)+ var(ind_RU12O2) & + + var(ind_RU10O2)+ var(ind_NRN6O2)+ var(ind_NRN9O2)+ var(ind_NRN12O2) & + + var(ind_RTN28O2) + var(ind_NRU14O2)+ var(ind_NRU12O2) + var(ind_RA13O2) & + + var(ind_RA16O2) + var(ind_RA19AO2) + var(ind_RA19CO2)+ var(ind_RN8O2) & + + var(ind_RTN26O2) + var(ind_NRTN28O2) + var(ind_RTN25O2) + var(ind_RTN24O2) & + + var(ind_RTN23O2)+ var(ind_RTN14O2)+ var(ind_RTN10O2)+ var(ind_RTX28O2) & + + var(ind_RTX24O2)+ var(ind_RTX22O2)+ var(ind_NRTX28O2), KIND=dp) +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_l_cri_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_l_cri_mosaic_4bin_aq.inc new file mode 100644 index 00000000..0703e4bd --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_l_cri_mosaic_4bin_aq.inc @@ -0,0 +1,4 @@ +! + REAL( KIND = dp ) :: RO2 +! ro2 declaration for... + diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_u_cri_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_u_cri_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_4bin_aq/kpp_mechd_u_cri_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_args_to_update_rconst_cri_mosaic_8bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_args_to_update_rconst_cri_mosaic_8bin_aq.inc new file mode 100644 index 00000000..9e479f6b --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_args_to_update_rconst_cri_mosaic_8bin_aq.inc @@ -0,0 +1,7 @@ +! +RO2, & +! +var,nvar,ind_ru14o2,ind_no,ind_oh,ind_rtn23o2,ind_rtn26o2,ind_ho2, & +ind_rtx28o2,ind_rn19o2,ind_nrn12ooh,ind_hoch2co3,ind_no2, & +! + diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_args_update_rconst_cri_mosaic_8bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_args_update_rconst_cri_mosaic_8bin_aq.inc new file mode 100644 index 00000000..48b75a3a --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_args_update_rconst_cri_mosaic_8bin_aq.inc @@ -0,0 +1,6 @@ +! +RO2, & +var,nvar,ind_ru14o2,ind_no,ind_oh,ind_rtn23o2,ind_rtn26o2,ind_ho2, & +ind_rtx28o2,ind_rn19o2,ind_nrn12ooh,ind_hoch2co3,ind_no2, & +! + diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_decls_update_rconst_cri_mosaic_8bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_decls_update_rconst_cri_mosaic_8bin_aq.inc new file mode 100644 index 00000000..3e1917a4 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/extra_decls_update_rconst_cri_mosaic_8bin_aq.inc @@ -0,0 +1,8 @@ +! + REAL(KIND=dp) :: RO2 + INTEGER, INTENT(in) :: nvar + REAL(KIND=dp), DIMENSION(nvar), INTENT(IN) :: var + INTEGER, INTENT(in) :: & + ind_ru14o2,ind_no,ind_oh,ind_rtn23o2,ind_rtn26o2,ind_ho2, & + ind_rtx28o2,ind_rn19o2,ind_nrn12ooh,ind_hoch2co3,ind_no2 + diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_a_cri_mosaic_8bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_a_cri_mosaic_8bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_a_cri_mosaic_8bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_b_cri_mosaic_8bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_b_cri_mosaic_8bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_b_cri_mosaic_8bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_e_cri_mosaic_8bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_e_cri_mosaic_8bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_e_cri_mosaic_8bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ia_cri_mosaic_8bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ia_cri_mosaic_8bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ia_cri_mosaic_8bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ib_cri_mosaic_8bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ib_cri_mosaic_8bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ib_cri_mosaic_8bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ibu_cri_mosaic_8bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ibu_cri_mosaic_8bin_aq.inc new file mode 100644 index 00000000..eed7a07d --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_ibu_cri_mosaic_8bin_aq.inc @@ -0,0 +1,17 @@ +! +! calculate summation for RO2 species + + RO2 = & + REAL(var(ind_CH3OO) + var(ind_C2H5O2) + var(ind_RN10O2) + var(ind_IC3H7O2) & + + var(ind_RN13O2) + var(ind_RN13AO2) + var(ind_RN16AO2) + var(ind_RN16O2) & + + var(ind_RN19O2) + var(ind_HOCH2CH2O2) + var(ind_RN9O2) + var(ind_RN12O2) & + + var(ind_RN15O2)+ var(ind_RN18O2)+ var(ind_RN15AO2) + var(ind_RN18AO2) & + + var(ind_CH3CO3) + var(ind_C2H5CO3)+ var(ind_RN11O2)+ var(ind_RN14O2) & + + var(ind_RN17O2) + var(ind_HOCH2CO3)+ var(ind_RU14O2)+ var(ind_RU12O2) & + + var(ind_RU10O2)+ var(ind_NRN6O2)+ var(ind_NRN9O2)+ var(ind_NRN12O2) & + + var(ind_RTN28O2) + var(ind_NRU14O2)+ var(ind_NRU12O2) + var(ind_RA13O2) & + + var(ind_RA16O2) + var(ind_RA19AO2) + var(ind_RA19CO2)+ var(ind_RN8O2) & + + var(ind_RTN26O2) + var(ind_NRTN28O2) + var(ind_RTN25O2) + var(ind_RTN24O2) & + + var(ind_RTN23O2)+ var(ind_RTN14O2)+ var(ind_RTN10O2)+ var(ind_RTX28O2) & + + var(ind_RTX24O2)+ var(ind_RTX22O2)+ var(ind_NRTX28O2), KIND=dp) +! diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_l_cri_mosaic_8bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_l_cri_mosaic_8bin_aq.inc new file mode 100644 index 00000000..0703e4bd --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_l_cri_mosaic_8bin_aq.inc @@ -0,0 +1,4 @@ +! + REAL( KIND = dp ) :: RO2 +! ro2 declaration for... + diff --git a/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_u_cri_mosaic_8bin_aq.inc b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_u_cri_mosaic_8bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cri_mosaic_8bin_aq/kpp_mechd_u_cri_mosaic_8bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/crimech/extra_args_to_update_rconst_crimech.inc b/wrfv2_fire/chem/KPP/inc/crimech/extra_args_to_update_rconst_crimech.inc new file mode 100644 index 00000000..9e479f6b --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/crimech/extra_args_to_update_rconst_crimech.inc @@ -0,0 +1,7 @@ +! +RO2, & +! +var,nvar,ind_ru14o2,ind_no,ind_oh,ind_rtn23o2,ind_rtn26o2,ind_ho2, & +ind_rtx28o2,ind_rn19o2,ind_nrn12ooh,ind_hoch2co3,ind_no2, & +! + diff --git a/wrfv2_fire/chem/KPP/inc/crimech/extra_args_update_rconst_crimech.inc b/wrfv2_fire/chem/KPP/inc/crimech/extra_args_update_rconst_crimech.inc new file mode 100644 index 00000000..48b75a3a --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/crimech/extra_args_update_rconst_crimech.inc @@ -0,0 +1,6 @@ +! +RO2, & +var,nvar,ind_ru14o2,ind_no,ind_oh,ind_rtn23o2,ind_rtn26o2,ind_ho2, & +ind_rtx28o2,ind_rn19o2,ind_nrn12ooh,ind_hoch2co3,ind_no2, & +! + diff --git a/wrfv2_fire/chem/KPP/inc/crimech/extra_decls_update_rconst_crimech.inc b/wrfv2_fire/chem/KPP/inc/crimech/extra_decls_update_rconst_crimech.inc new file mode 100644 index 00000000..3e1917a4 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/crimech/extra_decls_update_rconst_crimech.inc @@ -0,0 +1,8 @@ +! + REAL(KIND=dp) :: RO2 + INTEGER, INTENT(in) :: nvar + REAL(KIND=dp), DIMENSION(nvar), INTENT(IN) :: var + INTEGER, INTENT(in) :: & + ind_ru14o2,ind_no,ind_oh,ind_rtn23o2,ind_rtn26o2,ind_ho2, & + ind_rtx28o2,ind_rn19o2,ind_nrn12ooh,ind_hoch2co3,ind_no2 + diff --git a/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_a_crimech.inc b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_a_crimech.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_a_crimech.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_b_crimech.inc b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_b_crimech.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_b_crimech.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_e_crimech.inc b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_e_crimech.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_e_crimech.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ia_crimech.inc b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ia_crimech.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ia_crimech.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ib_crimech.inc b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ib_crimech.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ib_crimech.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ibu_crimech.inc b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ibu_crimech.inc new file mode 100644 index 00000000..eed7a07d --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_ibu_crimech.inc @@ -0,0 +1,17 @@ +! +! calculate summation for RO2 species + + RO2 = & + REAL(var(ind_CH3OO) + var(ind_C2H5O2) + var(ind_RN10O2) + var(ind_IC3H7O2) & + + var(ind_RN13O2) + var(ind_RN13AO2) + var(ind_RN16AO2) + var(ind_RN16O2) & + + var(ind_RN19O2) + var(ind_HOCH2CH2O2) + var(ind_RN9O2) + var(ind_RN12O2) & + + var(ind_RN15O2)+ var(ind_RN18O2)+ var(ind_RN15AO2) + var(ind_RN18AO2) & + + var(ind_CH3CO3) + var(ind_C2H5CO3)+ var(ind_RN11O2)+ var(ind_RN14O2) & + + var(ind_RN17O2) + var(ind_HOCH2CO3)+ var(ind_RU14O2)+ var(ind_RU12O2) & + + var(ind_RU10O2)+ var(ind_NRN6O2)+ var(ind_NRN9O2)+ var(ind_NRN12O2) & + + var(ind_RTN28O2) + var(ind_NRU14O2)+ var(ind_NRU12O2) + var(ind_RA13O2) & + + var(ind_RA16O2) + var(ind_RA19AO2) + var(ind_RA19CO2)+ var(ind_RN8O2) & + + var(ind_RTN26O2) + var(ind_NRTN28O2) + var(ind_RTN25O2) + var(ind_RTN24O2) & + + var(ind_RTN23O2)+ var(ind_RTN14O2)+ var(ind_RTN10O2)+ var(ind_RTX28O2) & + + var(ind_RTX24O2)+ var(ind_RTX22O2)+ var(ind_NRTX28O2), KIND=dp) +! diff --git a/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_l_crimech.inc b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_l_crimech.inc new file mode 100644 index 00000000..0703e4bd --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_l_crimech.inc @@ -0,0 +1,4 @@ +! + REAL( KIND = dp ) :: RO2 +! ro2 declaration for... + diff --git a/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_u_crimech.inc b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_u_crimech.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/crimech/kpp_mechd_u_crimech.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb.eqn b/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb.eqn index 0f036562..42209c14 100644 --- a/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb.eqn +++ b/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb.eqn @@ -27,7 +27,7 @@ {022:002} O1D+H2O = 2 OH : 2.2D-10 ; {023:003} O3P+M{+O2} = O3 : .21*ARR3MS(6.0D-34,2.3_dp,TEMP,C_M) ; {024:004} O3P + O3 =0.42M {2O2} : ARR3(8.0D-12, 2060._dp, TEMP) ; - {025:005} O3P + NO2 = NO : ARR3(6.5D-12, 120._dp, TEMP) ; + {025:005} O3P + NO2 = NO : ARR3(6.5D-12, -120._dp, TEMP) ; {026:006} O3P + NO2 = NO3 : TROEMS(9.0D-32, -2.0_dp, 2.2D-11, 0.0_dp, TEMP, C_M) ; {027:007} O3P + NO = NO2 : TROEMS(9.0D-32, -1.5_dp, 3.0D-11, 0.0_dp, TEMP, C_M) ; {028:008} O3 + NO = NO2 : ARR3(2.0D-12, 1400._dp, TEMP) ; @@ -68,9 +68,9 @@ {063:043} AONE + OH = ANO2 : TEMP**2 * ARR3(5.3D-18, 230._dp, TEMP) ; {064:044} MGLY + OH = XO2 + C2O3 : 1.7D-11 ; {065:045} MGLY + NO3 = HNO3 + C2O3 + CO : ARR3(1.4D-12, 1900._dp, TEMP) ; - {066:046} ETH + O3 = HCHO + .22 HO2 + .12 OH + + {066:046} C2H4 + O3 = HCHO + .22 HO2 + .12 OH + .24 CO {+ .24CO2} + .52 HCOOH : ARR3(1.2D-14, 2630._dp, TEMP) ; - {067:047} ETH + OH = XO2 + 1.56 HCHO + HO2 + .22 ALD2 : TROEMS(1.0D-28, -0.8_dp, 8.8D-12, 0.0_dp, TEMP, C_M) ; + {067:047} C2H4 + OH = XO2 + 1.56 HCHO + HO2 + .22 ALD2 : TROEMS(1.0D-28, -0.8_dp, 8.8D-12, 0.0_dp, TEMP, C_M) ; {068:048} OLET + O3 = .57 HCHO + .47 ALD2 + .33 OH + .26 HO2 {+ .08H2}+ .07 CH3O2 + .06 ETHP + diff --git a/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb.spc b/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb.spc index d2614b3b..5e7dddc6 100644 --- a/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb.spc +++ b/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb.spc @@ -34,7 +34,7 @@ PAR = IGNORE ; {paraffin carbon -C-} AONE = IGNORE ; {acetone} MGLY = IGNORE ; {methylglyoxal} - ETH = IGNORE ; {ethene} + C2H4 = IGNORE ; {ethene - is called ETH in the CBMZ docs} OLET = IGNORE ; {terminal olefin carbons C=C} OLEI = IGNORE ; {internal olefin carbons C=C} TOL = IGNORE ; {toluene} diff --git a/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb_wrfkpp.equiv index 5ea8ca30..e84a33a3 100644 --- a/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb_wrfkpp.equiv +++ b/wrfv2_fire/chem/KPP/mechanisms/cbmz_bb/cbmz_bb_wrfkpp.equiv @@ -10,7 +10,7 @@ SULF H2SO4 ETH C2H6 ALD ALD2 KET AONE -OL2 ETH +OL2 C2H4 OLT OLET OLI OLEI CSL CRES diff --git a/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic.eqn b/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic.eqn index 28d741ac..5ca7bebe 100755 --- a/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic.eqn +++ b/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic.eqn @@ -27,7 +27,7 @@ {022:002} O1D+H2O = 2 OH : 2.2D-10 ; {023:003} O3P+M{+O2} = O3 : .21*ARR3MS(6.0D-34,2.3_dp,TEMP,C_M) ; {024:004} O3P + O3 =0.42M {2O2} : ARR3(8.0D-12, 2060._dp, TEMP) ; - {025:005} O3P + NO2 = NO : ARR3(6.5D-12, 120._dp, TEMP) ; + {025:005} O3P + NO2 = NO : ARR3(6.5D-12, -120._dp, TEMP) ; {026:006} O3P + NO2 = NO3 : TROEMS(9.0D-32, -2.0_dp, 2.2D-11, 0.0_dp, TEMP, C_M) ; {027:007} O3P + NO = NO2 : TROEMS(9.0D-32, -1.5_dp, 3.0D-11, 0.0_dp, TEMP, C_M) ; {028:008} O3 + NO = NO2 : ARR3(2.0D-12, 1400._dp, TEMP) ; @@ -68,9 +68,9 @@ {063:043} AONE + OH = ANO2 : TEMP**2 * ARR3(5.3D-18, 230._dp, TEMP) ; {064:044} MGLY + OH = XO2 + C2O3 : 1.7D-11 ; {065:045} MGLY + NO3 = HNO3 + C2O3 + CO : ARR3(1.4D-12, 1900._dp, TEMP) ; - {066:046} ETH + O3 = HCHO + .22 HO2 + .12 OH + + {066:046} C2H4 + O3 = HCHO + .22 HO2 + .12 OH + .24 CO {+ .24CO2} + .52 HCOOH : ARR3(1.2D-14, 2630._dp, TEMP) ; - {067:047} ETH + OH = XO2 + 1.56 HCHO + HO2 + .22 ALD2 : TROEMS(1.0D-28, -0.8_dp, 8.8D-12, 0.0_dp, TEMP, C_M) ; + {067:047} C2H4 + OH = XO2 + 1.56 HCHO + HO2 + .22 ALD2 : TROEMS(1.0D-28, -0.8_dp, 8.8D-12, 0.0_dp, TEMP, C_M) ; {068:048} OLET + O3 = .57 HCHO + .47 ALD2 + .33 OH + .26 HO2 {+ .08H2}+ .07 CH3O2 + .06 ETHP + diff --git a/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic.spc b/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic.spc index 3836706a..0789f189 100755 --- a/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic.spc +++ b/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic.spc @@ -34,7 +34,7 @@ PAR = IGNORE ; {paraffin carbon -C-} AONE = IGNORE ; {acetone} MGLY = IGNORE ; {methylglyoxal} - ETH = IGNORE ; {ethene} + C2H4 = IGNORE ; {ethene - is called ETH in the CBMZ docs} OLET = IGNORE ; {terminal OLEfin carbons C=C} OLEI = IGNORE ; {internal OLEfin carbons C=C} TOL = IGNORE ; {toluene} diff --git a/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic_wrfkpp.equiv index 5ea8ca30..e84a33a3 100755 --- a/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic_wrfkpp.equiv +++ b/wrfv2_fire/chem/KPP/mechanisms/cbmz_mosaic/cbmz_mosaic_wrfkpp.equiv @@ -10,7 +10,7 @@ SULF H2SO4 ETH C2H6 ALD ALD2 KET AONE -OL2 ETH +OL2 C2H4 OLT OLET OLI OLEI CSL CRES diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.def b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.def new file mode 100644 index 00000000..c95c6735 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.def @@ -0,0 +1,171 @@ +#include atoms_red +#include ./cri_mosaic_4bin_aq.spc +#include ./cri_mosaic_4bin_aq.eqn + + + + +#INLINE F90_RATES +!************** SPECIAL RATE FUNCTIONS ********************** + +REAL(KIND=dp) FUNCTION k46( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=7.2E-15_dp * EXP(785._dp/TEMP) + k2=4.1E-16_dp * EXP(1440._dp/TEMP) + k3=1.9E-33_dp * EXP(725._dp/TEMP) * C_M + + k46=k0+k3/(1+k3/k2) + +! print*,'k46=',k46 +END FUNCTION k46 + +REAL(KIND=dp) FUNCTION k47( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, ki, fc, x, ssign, f12 + k0 = 3.00d-31*((temp/300.0)**(-3.3))*C_M + ki = 1.50d-12 + fc = 0.6 + x = 1.0d+0 + ssign = dsign(x,(k0-ki)) + f12 =10**(dlog10(fc)/(1.0+(ssign*(ABS(dlog10(k0/ki)))**(2.0)))) + k47=(k0*ki*f12)/(k0+ki) +! print*,'k47=',k47 +END FUNCTION k47 + +REAL(KIND=dp) FUNCTION k48( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, ki, fc, x, ssign, f17 + k0 = 5.00d-30*((temp/298.0)**(-1.5))*C_M + ki = 9.40d-12*EXP(-700.0/temp) + fc = (EXP(-temp/580.0) + EXP(-2320.0/temp)) + x = 1.0d+0 + ssign = dsign(x,(k0-ki)) + f17=10**(dlog10(fc)/(1.0+(ssign*(ABS(dlog10(k0/ki)))**(2.0)))) + k48=(k0*ki*f17)/(k0+ki) +! print*,'k48=',k48 +END FUNCTION k48 + + REAL(KIND=dp) FUNCTION RJPL( K0300, Q, KU300, R, M, T ) + REAL(KIND=dp) :: k0300,q,ku300,r,m,t + REAL(KIND=dp) :: tt,k0,ku,k0m,kk,lgkk,e,f +! JPL standard three body reaction rate format extended + TT= T / 3.D2 + K0= K0300 * exp(-1._dp*Q*log(TT)) + KU= KU300 * exp(-1._dp*R*log(TT)) + K0M= K0 * M + KK= K0M / KU + LGKK=0.43429448190324926_dp * LOG(KK) ! = log10(KK) + E=1.D0 / ( 1.D0 + LGKK*LGKK ) + F=exp(-0.5108256237659887_dp*E) ! -0.51=log(0.6) + RJPL = F * K0M / ( 1.D0 + KK ) +! print*,'RJPL=',RJPL + END FUNCTION +!--------------------------------------------------------------------- + + + + REAL(KIND=dp) FUNCTION RALKE( K0300, Q, KU, Fc, M, T ) + REAL(KIND=dp) :: k0300,q,m,t,Fc + real(KIND=dp) :: tt,k0,ku,k0m,kk,lgkk,e,f +! special function for alkene+OH reactions + TT= T / 3.D2 + K0= K0300 * exp(-1._dp*Q*log(TT)) + K0M= K0 * M + KK= K0M / KU + LGKK=0.43429448190324926_dp * LOG(KK) ! = log10(KK) + E=1.D0 / ( 1.D0 + LGKK*LGKK ) + F=exp(log(Fc)*E) + RALKE = F * K0M / ( 1.D0 + KK ) +! print*,'RALKE=',RALKE + END FUNCTION + + + real(kind=dp) function iupac_ch3sch3(a2,b2,a3,b3,cin_o2,temp) + !rate calculation for CH3SCH3 + OH = CH3SCH3OO + H2O + ! from IUPAC report (www.iupac-kinetic.ch.cam.ac.uk) + real(kind=dp) :: cin_o2, tr, temp + real(kind=dp) :: a2, b2, a3, b3 + + tr = 1._dp + ARR2(a3,b3,temp)*cin_o2 + iupac_ch3sch3 = ARR2(a2,b2,temp)*cin_o2/tr + + end function iupac_ch3sch3 + +!--------------------------------------------------------------------- + +!- SAN: adding standard 3-body reaction using convention of MCM & IUPAC recommendations +! - Explicit form of TROE reactions +! Based on Atkinson et. al. 2004 + +REAL(KIND=dp) FUNCTION KMT_IUPAC(k0_300K,n,kinf_300K,m,Fc,temp,cair) + + INTRINSIC LOG10 + + REAL(KIND=dp), INTENT(IN) :: temp ! temperature [K] + REAL(KIND=dp), INTENT(IN) :: cair ! air concentration [molecules/cm3] + REAL(KIND=dp), INTENT(IN) :: k0_300K ! low pressure limit at 300 K + REAL(KIND=dp), INTENT(IN) :: n ! exponent for low pressure limit + !!! n.b. - remember to flip sign of exponents from IUPAC data sheets !!! + REAL(KIND=dp), INTENT(IN) :: kinf_300K ! high pressure limit at 300 K + REAL(KIND=dp), INTENT(IN) :: m ! exponent for high pressure limit + REAL(KIND=dp), INTENT(IN) :: Fc ! Approximate broadening factor + + REAL(KIND=dp) :: zt_help, k0_T, kinf_T, k_ratio, Nint, F_exp + + zt_help = 300._dp/temp + k0_T = k0_300K * zt_help**(n) * cair ! k_0 at current T + kinf_T = kinf_300K * zt_help**(m) ! k_inf at current T + k_ratio = k0_T/kinf_T + Nint = 0.75_dp - 1.27_dp*LOG10(Fc) + ! Calculate explicit broadening factor: + F_exp = Fc ** (1._dp / (1._dp + ( LOG10(k_ratio) / Nint )**2._dp ) ) + + KMT_IUPAC = k0_T/(1._dp+k_ratio) * F_exp + +END FUNCTION KMT_IUPAC + +!--------------------------------------------------------------------- + +!- SAN: Function for calculating NO + OH [+ M] 3-body reaction +!- Explicit form of TROE reaction with temperature dependent Fc + +REAL(KIND=dp) FUNCTION KMT_OH_NO(temp,cair) + + INTRINSIC LOG10 + + REAL(KIND=dp), INTENT(IN) :: temp ! temperature [K] + REAL(KIND=dp), INTENT(IN) :: cair ! air concentration [molecules/cm3] + + REAL(KIND=dp) :: k0_300K, n, kinf_300K, m, zt_help + REAL(KIND=dp) :: k0_T, kinf_T, k_ratio, Nint, Fc, F_exp + + k0_300K = 7.4D-31 ! low pressure limit at 300 K + n = 2.4_dp ! exponent for low pressure limit + kinf_300K = 3.3D-11 ! high pressure limit at 300 K + m = 0.3_dp ! exponent for high pressure limit + + zt_help = 300._dp/temp + k0_T = k0_300K * zt_help**(n) * cair ! k_0 at current T + kinf_T = kinf_300K * zt_help**(m) ! k_inf at current T + k_ratio = k0_T/kinf_T + + ! OH + NO [+ M] uses temperature dependent Fc: + Fc = exp(-temp / 1420._dp) + + Nint = 0.75_dp - 1.27_dp*LOG10(Fc) + + ! Calculate explicit broadening factor: + F_exp = Fc ** (1._dp / (1._dp + ( LOG10(k_ratio) / Nint )**2._dp ) ) + + KMT_OH_NO = k0_T/(1._dp+k_ratio) * F_exp + +END FUNCTION KMT_OH_NO + + + + +#ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.eqn b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.eqn new file mode 100644 index 00000000..4196147d --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.eqn @@ -0,0 +1,639 @@ +#EQUATIONS {CRIMECH, check troe,troee, RJPL, RALKE, k46, k47, k48, RO2} +{001:J01} O3+hv=O1D{+O2} : j(Pj_o31d) ; +{002:J02} O3+hv=O3P{+O2} : j(Pj_o33p) ; +{003:J03} H2O2+hv=OH+OH : j(Pj_h2o2) ; +{004:J04} NO2+hv=NO+O3P : j(Pj_no2) ; +{005:J05} NO3+hv=NO : j(Pj_no3o2) ; +{006:J06} NO3+hv=NO2+O3P : j(Pj_no3o) ; +{007:J07} HONO+hv=OH+NO : j(Pj_hno2) ; +{008:J08} HNO3+hv=OH+NO2 : j(Pj_hno3) ; +{009:J09} HCHO+hv=CO+HO2+HO2 : j(Pj_ch2or) ; +{010:J10} HCHO+hv=CO : j(Pj_ch2om) ; +{011:J11} CH3CHO+hv=CH3OO+HO2+CO : 4.6D-4 * j(Pj_no2) ; +{012:J12} C2H5CHO+hv=C2H5O2+CO+HO2 : 4.19*4.6D-4 * j(Pj_no2) ; +{013:J13} CH3COCH3+hv=CH3CO3+CH3OO : 7.8D-5 * j(Pj_no2) ; +{014:J14} MEK+hv=CH3CO3+C2H5O2 : 7.047*7.8D-5 * j(Pj_no2) ; +{015:J15} CARB14+hv=CH3CO3+RN10O2 : 4.74*7.047*7.8D-5 * j(Pj_no2) ; +{016:J16} CARB17+hv=RN8O2+RN10O2 : 1.33*7.047*7.8D-5 * j(Pj_no2) ; +{017:J17} CARB11A+hv=CH3CO3+C2H5O2 : 7.047*7.8D-5 * j(Pj_no2) ; +{018:J18} CARB7+hv=CH3CO3+HCHO+HO2 : 7.047*7.8D-5 * j(Pj_no2) ; +{019:J19} CARB10+hv=CH3CO3+CH3CHO+HO2 : 7.047*7.8D-5 * j(Pj_no2) ; +{020:J20} CARB13+hv=RN8O2+CH3CHO+HO2 : 3.00*7.047*7.8D-5 * j(Pj_no2) ; +{021:J21} CARB16+hv=RN8O2+C2H5CHO+HO2 : 3.35*7.047*7.8D-5 * j(Pj_no2) ; +{022:J22} HOCH2CHO+hv=HCHO+CO+HO2+HO2 : 9.64_dp*j(pj_ch2or) ; +{023:J23} UCARB10+hv=CH3CO3+HCHO+HO2 : 2.0*1.9997*4.6D-4 * j(Pj_no2) ; +{024:J24} CARB3+hv=CO+CO+HO2+HO2 : 9.64_dp*j(pj_ch2or) ; +{025:J25} CARB6+hv=CH3CO3+CO+HO2 : 32.6088*4.6D-4 * j(Pj_no2); +{026:J26} CARB9+hv=CH3CO3+CH3CO3 : 2.149*32.6088*4.6D-4 * j(Pj_no2); +{027:J27} CARB12+hv=CH3CO3+RN8O2 : 2.149*32.6088*4.6D-4 * j(Pj_no2); +{028:J28} CARB15+hv=RN8O2+RN8O2 : 2.149*32.6088*4.6D-4 * j(Pj_no2); +{029:J29} UCARB12+hv=CH3CO3+HOCH2CHO+CO+HO2 : 2.0*1.9997*4.6D-4 * j(Pj_no2) ; +{030:J30} NUCARB12+hv=NOA+CO+CO+HO2+HO2 : 1.9997*4.6D-4 * j(Pj_no2) ; +{031:J31} NOA+hv=CH3CO3+HCHO+NO2 : 1.155*4.6D-4 * j(Pj_no2) + 0.4933*4.6D-4 * j(Pj_no2) ; +{032:J32} UDCARB8+hv=C2H5O2+HO2 : 0.02*j(Pj_no2) ; +{033:J33} UDCARB11+hv=RN10O2+HO2 : 0.02*j(Pj_no2) ; +{034:J34} UDCARB14+hv=RN13O2+HO2 : 0.02*j(Pj_no2) ; +{035:J35} TNCARB26+hv=RTN26O2+HO2 : 9.64_dp*j(pj_ch2or) ; +{036:J36} TNCARB10+hv=CH3CO3+CH3CO3+CO : 0.5*2.149*32.6088*4.6D-4 * j(Pj_no2); +{037:J37} CH3NO3+hv=HCHO+HO2+NO2 : 1.0D-4 * j(Pj_no2) ; +{038:J38} C2H5NO3+hv=CH3CHO+HO2+NO2 : 2.3248*7.8D-5 * j(Pj_no2) ; +{039:J39} RN10NO3+hv=C2H5CHO+HO2+NO2 : 3.079*7.8D-5 * j(Pj_no2) ; +{040:J40} IC3H7NO3+hv=CH3COCH3+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{041:J41} RN13NO3+hv= CH3CHO+C2H5O2+NO2 : 0.398*3.079*7.8D-5 * j(Pj_no2) ; +{042:J42} RN13NO3+hv= CARB11A+HO2+NO2 : 0.602*3.079*7.8D-5 * j(Pj_no2) ; +{043:J43} RN16NO3+hv=RN15O2+NO2 : 3.079*7.8D-5 * j(Pj_no2) ; +{044:J44} RN19NO3+hv=RN18O2+NO2 : 3.079*7.8D-5 * j(Pj_no2) ; +{045:J45} RA13NO3+hv=CARB3+UDCARB8+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{046:J46} RA16NO3+hv=CARB3+UDCARB11+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{047:J47} RA19NO3+hv=CARB6+UDCARB11+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{048:J48} RTX24NO3+hv=TXCARB22+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{049:J49} CH3OOH+hv=HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{050:J50} C2H5OOH+hv=CH3CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{051:J51} RN10OOH+hv=C2H5CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{052:J52} IC3H7OOH+hv=CH3COCH3+HO2+OH : 0.7 * j(Pj_h2o2) ; +{053:J53} RN13OOH+hv= CH3CHO+C2H5O2+OH : 0.398*0.7 * j(Pj_h2o2) ; +{054:J54} RN13OOH+hv= CARB11A+HO2+OH : 0.602*0.7 * j(Pj_h2o2) ; +{055:J55} RN16OOH+hv=RN15AO2+OH : 0.7 * j(Pj_h2o2) ; +{056:J56} RN19OOH+hv=RN18AO2+OH : 0.7 * j(Pj_h2o2) ; +{057:J57} CH3CO3H+hv=CH3OO+OH : 0.7 * j(Pj_h2o2) ; +{058:J58} C2H5CO3H+hv=C2H5O2+OH : 0.7 * j(Pj_h2o2) ; +{059:J59} HOCH2CO3H+hv=HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{060:J60} RN8OOH+hv=C2H5O2+OH : 0.7 * j(Pj_h2o2) ; +{061:J61} RN11OOH+hv=RN10O2+OH : 0.7 * j(Pj_h2o2) ; +{062:J62} RN14OOH+hv=RN13O2+OH : 0.7 * j(Pj_h2o2) ; +{063:J63} RN17OOH+hv=RN16O2+OH : 0.7 * j(Pj_h2o2) ; +{064:J64} RU14OOH+hv=UCARB12+HO2+OH : 0.252*0.7 * j(Pj_h2o2) ; +{065:J65} RU14OOH+hv=UCARB10+HCHO+HO2+OH : 0.748*0.7 * j(Pj_h2o2) ; +{066:J66} RU12OOH+hv=CARB6+HOCH2CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{067:J67} RU10OOH+hv=CH3CO3+HOCH2CHO+OH : 0.7 * j(Pj_h2o2) ; +{068:J68} NRU14OOH+hv=NUCARB12+HO2+OH : 0.7 * j(Pj_h2o2) ; +{069:J69} NRU12OOH+hv=NOA+CO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{070:J70} HOC2H4OOH+hv=HCHO+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{071:J71} RN9OOH+hv=CH3CHO+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{072:J72} RN12OOH+hv=CH3CHO+CH3CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{073:J73} RN15OOH+hv=C2H5CHO+CH3CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{074:J74} RN18OOH+hv=C2H5CHO+C2H5CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{075:J75} NRN6OOH+hv=HCHO+HCHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{076:J76} NRN9OOH+hv=CH3CHO+HCHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{077:J77} NRN12OOH+hv=CH3CHO+CH3CHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{078:J78} RA13OOH+hv=CARB3+UDCARB8+HO2+OH : 0.7 * j(Pj_h2o2) ; +{079:J79} RA16OOH+hv=CARB3+UDCARB11+HO2+OH : 0.7 * j(Pj_h2o2) ; +{080:J80} RA19OOH+hv=CARB6+UDCARB11+HO2+OH : 0.7 * j(Pj_h2o2) ; +{081:J81} RTN28OOH+hv=TNCARB26+HO2+OH : 0.7 * j(Pj_h2o2) ; +{082:J82} NRTN28OOH+hv=TNCARB26+NO2+OH : 0.7 * j(Pj_h2o2) ; +{083:J83} RTN26OOH+hv=RTN25O2+OH : 0.7 * j(Pj_h2o2) ; +{084:J84} RTN25OOH+hv=RTN24O2+OH : 0.7 * j(Pj_h2o2) ; +{085:J85} RTN24OOH+hv=RTN23O2+OH : 0.7 * j(Pj_h2o2) ; +{086:J86} RTN23OOH+hv=CH3COCH3+RTN14O2+OH : 0.7 * j(Pj_h2o2) ; +{087:J87} RTN14OOH+hv=TNCARB10+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{088:J88} RTN10OOH+hv=RN8O2+CO+OH : 0.7 * j(Pj_h2o2) ; +{089:J89} RTX28OOH+hv=TXCARB24+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{090:J90} RTX24OOH+hv=TXCARB22+HO2+OH : 0.7 * j(Pj_h2o2) ; +{091:J90} RTX22OOH+hv=CH3COCH3+RN13O2+OH : 0.7 * j(Pj_h2o2) ; +{092:J90} NRTX28OOH+hv=TXCARB24+HCHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{093:J90} UDCARB8+hv=ANHY+HO2+HO2 : 0.02*0.36*j(Pj_no2) ; +{094:J90} UDCARB11+hv=ANHY+HO2+CH3OO : 0.02*0.45*j(Pj_no2) ; +{095:J90} UDCARB14+hv=ANHY+HO2+C2H5O2 : 0.02*0.45*j(Pj_no2) ; +{096:001} O3P+M{+O2}=O3 : .20946e0*(C_M *6.00D-34*(TEMP/300)**(-2.6)); +{097:002} CH3O2NO2=CH3OO+NO2 : RJPL(1.3D-30,4.0_dp,7.5D-12,2.0_dp,C_M,TEMP)/(1.3D-28*exp(11200._dp/TEMP)); +{098:003} O3P+O3=M {2O2} : ARR2( 8.00D-12, 2060.0_dp, TEMP) ; +{099:004} O3P+NO=NO2 : TROE( 9.00D-32 , 1.5_dp , 3.00D-11 , 0.0_dp , TEMP, C_M) ; +{100:005} O3P+NO2=NO : ARR2( 5.50D-12, -188.0_dp, TEMP) ; +{101:006} O3P+NO2=NO3 : TROE( 9.00D-32 , 2.0_dp , 2.20D-11 , 0.0_dp , TEMP, C_M) ; +{102:007} O1D+M{=O2,N2} =O3P{+O2, N2} : .20946e0* ARR2( 3.20D-11, -70.0_dp, TEMP)+ .78084* ARR2( 1.80D-11, -110.0_dp, TEMP) ; +{103:008} NO+O3=NO2 : ARR2( 1.40D-12, 1310.0_dp, TEMP) ; +{104:009} NO2+O3=NO3 : ARR2( 1.40D-13, 2470.0_dp, TEMP) ; +{105:010} NO+NO+M{=O2}=NO2+NO2 : .20946e0* ARR2( 3.30D-39, -530.0_dp, TEMP) ; +{106:011} NO+NO3=NO2+NO2 : ARR2( 1.80D-11, -110.0_dp, TEMP) ; +{107:012} NO2+NO3=NO+NO2 : ARR2( 4.50D-14, 1260.0_dp, TEMP) ; +{108:013} NO2+NO3=N2O5 : TROE( 2.20D-30 , 3.9_dp , 1.50D-12 , 0.7_dp , TEMP, C_M) ; +{109:014} N2O5=NO3+NO2 : TROEE(3.70D26,11000.0_dp, 2.20D-30 , 3.9_dp , 1.50D-12 , 0.7_dp , TEMP, C_M ) ; +{110:015} O1D+H2O=OH+OH : 2.20D-10 ; +{111:016} OH+O3=HO2 : ARR2( 1.70D-12, 940.0_dp, TEMP) ; +{112:017} OH+M = HO2+H2O : 5.31D-7*ARR2( 7.70D-12, 2100.0_dp, TEMP) ; +{113:018} OH+CO=HO2 : 1.20D-13*(1.0 + ((0.6*C_M)/(2.652d+19*(273.0/temp)))) ; +{114:019} OH+H2O2=HO2 : ARR2( 2.90D-12, 160.0_dp, TEMP) ; +{115:020} HO2+O3=OH : 2.03D-16*((TEMP/300)**4.57)*EXP(693/TEMP) ; +{116:021} OH+HO2=H2O{+O2} : ARR2( 4.80D-11, -250.0_dp, TEMP) ; +{117:022} HO2+HO2=H2O2 : (2.2D-13*EXP(600./TEMP) + 1.9D-33* C_M *EXP(980._dp/TEMP)) ; +{118:023} HO2+HO2+H2O=H2O2 : (3.08D-34* EXP(2800._dp/TEMP)+ 2.66D-54* C_M *EXP(3180._dp/TEMP)) ; +{119:024} OH+NO=HONO : KMT_OH_NO( TEMP, C_M) ; +{120:025} OH+NO2=HNO3 : TROE( 2.60D-30 , 3.2_dp , 2.40D-11 , 1.3_dp , TEMP, C_M) ; +{121:026} OH+NO3=HO2+NO2 : 2.00D-11 ; +{122:027} HO2+NO=OH+NO2 : ARR2( 3.60D-12, -270.0_dp, TEMP) ; +{123:028} HO2+NO2=HNO4 : TROE( 1.80D-31 , 3.2_dp , 4.70D-12 , 1.4_dp , TEMP, C_M) ; +{124:029} HNO4=NO2+HO2 : TROEE( 4.76D26,10900.0_dp, 1.80D-31 , 3.2_dp , 4.70D-12 , 1.4_dp , TEMP, C_M ) ; +{125:030} OH+HNO4=NO2 : ARR2( 1.90D-12, -270.0_dp, TEMP) ; +{126:031} HO2+NO3=OH+NO2 : 4.00D-12 ; +{127:032} OH+HONO=NO2 : ARR2( 2.50D-12, -260.0_dp, TEMP) ; +{128:033} OH+HNO3=NO3 : k46(TEMP,C_M) ; +{129:034} O3P+SO2=SO3 : C_M*ARR2( 4.00D-32, 1000.0_dp, TEMP) ; +{130:035} OH+SO2=HSO3 : K47(TEMP,C_M) ; +{131:036} HSO3+M{=O2}=HO2+SO3 : .20946e0* ARR2( 1.30D-12, -330.0_dp, TEMP) ; +{134:039} SO3 + H2O + H2O = H2SO4 : ARR2(3.9d-41,-6830.6_dp,TEMP) ; {Jayne et al (1997) rate} +{135:040} OH+CH4=CH3OO : 9.65D-20*TEMP**2.58*EXP(-1082/TEMP) ; +{136:041} OH+C2H6=C2H5O2 : 1.52D-17*TEMP**2*EXP(-498/TEMP) ; +{137:042} OH+C3H8=IC3H7O2 : 1.55D-17*TEMP**2*EXP(-61/TEMP)*0.736 ; +{138:043} OH+C3H8=RN10O2 : 1.55D-17*TEMP**2*EXP(-61/TEMP)*0.264 ; +{139:044} OH+NC4H10=RN13O2 : 1.69D-17*TEMP**2*EXP(145/TEMP) ; +{140:045} OH+C2H4=HOCH2CH2O2 : KMT_IUPAC(8.6D-29, 3.1_dp, 9.0D-12, 0.85_dp, 0.48_dp, TEMP,C_M) ; +{141:046} OH+C3H6=RN9O2 : KMT_IUPAC(8.0D-27, 3.5_dp, 3.0D-11, 1.0_dp, 0.5_dp, TEMP,C_M) ; +{142:047} OH+TBUT2ENE=RN12O2 : ARR2( 1.01D-11, -550.0_dp, TEMP) ; +{143:048} NO3+C2H4=NRN6O2 : 2.10D-16 ; +{144:049} NO3+C3H6=NRN9O2 : 9.40D-15 ; +{145:050} NO3+TBUT2ENE=NRN12O2 : 3.90D-13 ; +{146:051} O3+C2H4=HCHO+CO+HO2+OH : 0.13*ARR2( 9.14D-15, 2580.0_dp, TEMP) ; +{147:052} O3+C2H4=HCHO+HCOOH : 0.87*ARR2( 9.14D-15, 2580.0_dp, TEMP) ; +{148:053} O3+C3H6=HCHO+CO+CH3OO+OH : 0.36*ARR2( 5.51D-15, 1878.0_dp, TEMP) ; +{149:054} O3+C3H6=HCHO+CH3CO2H : 0.64*ARR2( 5.51D-15, 1878.0_dp, TEMP) ; +{150:055} O3+TBUT2ENE=CH3CHO+CO+CH3OO+OH : 0.69*ARR2( 6.64D-15, 1059.0_dp, TEMP) ; +{151:056} O3+TBUT2ENE=CH3CHO+CH3CO2H : 0.31*ARR2( 6.64D-15, 1059.0_dp, TEMP) ; +{152:057} OH+C5H8=RU14O2 : ARR2( 2.54D-11, -410.0_dp, TEMP) ; +{153:058} NO3+C5H8=NRU14O2 : ARR2( 3.03D-12, 446.0_dp, TEMP) ; +{154:059} O3+C5H8=UCARB10+CO+HO2+OH : 0.27*ARR2( 7.86D-15, 1913.0_dp, TEMP) ; +{155:060} O3+C5H8=UCARB10+HCOOH : 0.73*ARR2( 7.86D-15, 1913.0_dp, TEMP) ; +{156:061} APINENE+OH=RTN28O2 : ARR2( 1.20D-11, -444.0_dp, TEMP) ; +{157:062} APINENE+NO3=NRTN28O2 : ARR2( 1.19D-12, -490.0_dp, TEMP) ; +{158:063} APINENE+O3=OH+CH3COCH3+RN18AO2 : 0.80*ARR2( 1.01D-15, 732.0_dp, TEMP) ; +{159:064} APINENE+O3=TNCARB26+H2O2 : 0.075*ARR2( 1.01D-15, 732.0_dp, TEMP) ; +{160:065} APINENE+O3=RCOOH25 : 0.125*ARR2( 1.01D-15, 732.0_dp, TEMP) ; +{161:066} BPINENE+OH=RTX28O2 : ARR2( 2.38D-11, -357.0_dp, TEMP) ; +{162:067} BPINENE+NO3=NRTX28O2 : 2.51D-12 ; +{163:068} BPINENE+O3= RTX24O2+OH : 1.50D-17*0.35 ; +{164:069} BPINENE+O3= HCHO+TXCARB24+H2O2 : 1.50D-17*0.20 ; +{165:070} BPINENE+O3= HCHO+TXCARB22 : 1.50D-17*0.25 ; +{166:071} BPINENE+O3= TXCARB24+CO : 1.50D-17*0.20 ; +{167:072} C2H2+OH=HCOOH+CO+HO2 : 0.364*KMT_IUPAC(5.0D-30, 1.5_dp, 1.0D-12, 0.0_dp, 0.37_dp, TEMP,C_M) ; +{168:073} C2H2+OH=CARB3+OH : 0.636*KMT_IUPAC(5.0D-30, 1.5_dp, 1.0D-12, 0.0_dp, 0.37_dp, TEMP,C_M) ; +{169:074} BENZENE+OH=RA13O2 : 0.47*ARR2( 2.33D-12, 193.0_dp, TEMP) ; +{170:075} BENZENE+OH=AROH14+HO2 : 0.53*ARR2( 2.33D-12, 193.0_dp, TEMP) ; +{171:076} TOLUENE+OH=RA16O2 : 0.82*ARR2( 1.81D-12, -338.0_dp, TEMP) ; +{172:077} TOLUENE+OH=AROH17+HO2 : 0.18*ARR2( 1.81D-12, -338.0_dp, TEMP) ; +{173:078} OXYL+OH=RA19AO2 : 1.36D-11*0.70 ; +{174:079} OXYL+OH=RA19CO2 : 1.36D-11*0.30 ; +{175:080} OH+HCHO=HO2+CO : 1.20D-14*TEMP*EXP(287/TEMP) ; +{176:081} OH+CH3CHO=CH3CO3 : ARR2( 5.55D-12, -311.0_dp, TEMP) ; +{177:082} OH+C2H5CHO=C2H5CO3 : 1.96D-11 ; +{178:083} NO3+HCHO=HO2+CO+HNO3 : 5.80D-16 ; +{179:084} NO3+CH3CHO=CH3CO3+HNO3 : 1.44d-12*EXP(-1862.0/temp) ; +{180:085} NO3+C2H5CHO=C2H5CO3+HNO3 : 1.44d-12*EXP(-1862.0/temp)*2.4 ; +{181:086} OH+CH3COCH3=RN8O2 : 5.34D-18*TEMP**2*EXP(-230/TEMP) ; +{182:087} MEK+OH=RN11O2 : 3.24D-18*TEMP**2*EXP(414/TEMP) ; +{183:088} OH+CH3OH=HO2+HCHO : 6.01D-18*TEMP**2*EXP(170/TEMP) ; +{184:089} OH+C2H5OH=CH3CHO+HO2 : 6.18D-18*TEMP**2*EXP(532/TEMP)*0.887 ; +{185:090} OH+C2H5OH=HOCH2CH2O2 : 6.18D-18*TEMP**2*EXP(532/TEMP)*0.113 ; +{186:091} NPROPOL+OH=C2H5CHO+HO2 : 5.53D-12*0.49 ; +{187:092} NPROPOL+OH=RN9O2 : 5.53D-12*0.51 ; +{188:093} OH+IPROPOL=CH3COCH3+HO2 : 4.06D-18*TEMP**2*EXP(788/TEMP)*0.86 ; +{189:094} OH+IPROPOL=RN9O2 : 4.06D-18*TEMP**2*EXP(788/TEMP)*0.14 ; +{190:095} HCOOH+OH=HO2 : 4.50D-13 ; +{191:096} CH3CO2H+OH=CH3OO : 8.00D-13 ; +{192:097} CH3OO+NO=HCHO+HO2+NO2 : 0.999*ARR2( 3.00D-12, -280.0_dp, TEMP) ; +{193:098} C2H5O2+NO=CH3CHO+HO2+NO2 : 0.991*ARR2( 2.60D-12, -365.0_dp, TEMP) ; +{194:099} RN10O2+NO=C2H5CHO+HO2+NO2 : 0.980*ARR2( 2.80D-12, -360.0_dp, TEMP) ; +{195:100} IC3H7O2+NO=CH3COCH3+HO2+NO2 : 0.958*ARR2( 2.70D-12, -360.0_dp, TEMP) ; +{196:101} RN13O2+NO=CH3CHO+C2H5O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.917*0.398 ; +{197:102} RN13O2+NO=CARB11A+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.917*0.602 ; +{198:103} RN16O2+NO=RN15AO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.877 ; +{199:104} RN19O2+NO=RN18AO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.788 ; +{200:105} RN13AO2+NO=RN12O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{201:106} RN16AO2+NO=RN15O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{202:107} RA13O2+NO=CARB3+UDCARB8+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.918 ; +{203:108} RA16O2+NO=CARB3+UDCARB11+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.889*0.7 ; +{204:109} RA16O2+NO=CARB6+UDCARB8+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.889*0.3 ; +{205:110} RA19AO2+NO=CARB3+UDCARB14+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.862 ; +{206:111} RA19CO2+NO=CARB9+UDCARB8+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.862 ; +{207:112} HOCH2CH2O2+NO=HCHO+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.995*0.776 ; +{208:113} HOCH2CH2O2+NO=HOCH2CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.995*0.224 ; +{209:114} RN9O2+NO=CH3CHO+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.979 ; +{210:115} RN12O2+NO=CH3CHO+CH3CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.959 ; +{211:116} RN15O2+NO=C2H5CHO+CH3CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.936 ; +{212:117} RN18O2+NO=C2H5CHO+C2H5CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.903 ; +{213:118} RN15AO2+NO=CARB13+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.975 ; +{214:119} RN18AO2+NO=CARB16+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.946 ; +{215:120} CH3CO3+NO=CH3OO+NO2 : 8.10d-12*EXP(270.0/temp) ; +{216:121} C2H5CO3+NO=C2H5O2+NO2 : 8.10d-12*EXP(270.0/temp) ; +{217:122} HOCH2CO3+NO=HO2+HCHO+NO2 : 8.10d-12*EXP(270.0/temp) ; +{218:123} RN8O2+NO=CH3CO3+HCHO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{219:124} RN11O2+NO=CH3CO3+CH3CHO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{220:125} RN14O2+NO=C2H5CO3+CH3CHO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{221:126} RN17O2+NO=RN16AO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{222:127} RU14O2+NO=UCARB12+HO2+ NO2 : 2.40d-12*EXP(360.0/temp)*0.900*0.252 ; +{223:128} RU14O2+NO=UCARB10+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.900*0.748 ; +{224:129} RU12O2+NO=CH3CO3+HOCH2CHO+NO2 : 2.40d-12*EXP(360.0/temp)*0.7 ; +{225:130} RU12O2+NO=CARB7+CO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.3 ; +{226:131} RU10O2+NO=CH3CO3+HOCH2CHO+NO2 : 2.40d-12*EXP(360.0/temp)*0.5 ; +{227:132} RU10O2+NO=CARB6+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.3 ; +{228:133} RU10O2+NO=CARB7+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.2 ; +{229:134} NRN6O2+NO=HCHO+HCHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{230:135} NRN9O2+NO=CH3CHO+HCHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{231:136} NRN12O2+NO=CH3CHO+CH3CHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{232:137} NRU14O2+NO=NUCARB12+HO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{233:138} NRU12O2+NO=NOA+CO+HO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{234:139} RTN28O2+NO=TNCARB26+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.915 ; +{235:140} RTN28O2+NO=CH3COCH3+RN19O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.085 ; +{236:141} NRTN28O2+NO=TNCARB26+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{237:142} RTN26O2+NO=RTN25O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{238:143} RTN25O2+NO=RTN24O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.840 ; +{239:144} RTN24O2+NO=RTN23O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{240:145} RTN23O2+NO=CH3COCH3+RTN14O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{241:146} RTN14O2+NO=HCHO+TNCARB10+HO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{242:147} RTN10O2+NO=RN8O2+CO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{243:148} RTX28O2+NO=TXCARB24+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.915 ; +{244:149} RTX28O2+NO=CH3COCH3+RN19O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.085 ; +{245:150} NRTX28O2+NO=TXCARB24+HCHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{246:151} RTX24O2+NO=TXCARB22+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.843*0.6 ; +{247:152} RTX24O2+NO=CH3COCH3+RN13AO2+HCHO+NO2 : 2.40d-12*EXP(360.0/temp)*0.843*0.4 ; +{248:153} RTX22O2+NO=CH3COCH3+RN13O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.700 ; +{249:154} CH3OO+NO=CH3NO3 : 0.001*ARR2( 3.00D-12, -280.0_dp, TEMP) ; +{250:155} C2H5O2+NO=C2H5NO3 : 0.009*ARR2( 2.60D-12, -365.0_dp, TEMP) ; +{251:156} RN10O2+NO=RN10NO3 : 0.020*ARR2( 2.80D-12, -360.0_dp, TEMP) ; +{252:157} IC3H7O2+NO=IC3H7NO3 : 0.042*ARR2( 2.70D-12, -360.0_dp, TEMP) ; +{253:158} RN13O2+NO=RN13NO3 : 2.40d-12*EXP(360.0/temp)*0.083 ; +{254:159} RN16O2+NO=RN16NO3 : 2.40d-12*EXP(360.0/temp)*0.123 ; +{255:160} RN19O2+NO=RN19NO3 : 2.40d-12*EXP(360.0/temp)*0.212 ; +{256:161} HOCH2CH2O2+NO=HOC2H4NO3 : 2.40d-12*EXP(360.0/temp)*0.005 ; +{257:162} RN9O2+NO=RN9NO3 : 2.40d-12*EXP(360.0/temp)*0.021 ; +{258:163} RN12O2+NO=RN12NO3 : 2.40d-12*EXP(360.0/temp)*0.041 ; +{259:164} RN15O2+NO=RN15NO3 : 2.40d-12*EXP(360.0/temp)*0.064 ; +{260:165} RN18O2+NO=RN18NO3 : 2.40d-12*EXP(360.0/temp)*0.097 ; +{261:166} RN15AO2+NO=RN15NO3 : 2.40d-12*EXP(360.0/temp)*0.025 ; +{262:167} RN18AO2+NO=RN18NO3 : 2.40d-12*EXP(360.0/temp)*0.054 ; +{263:168} RU14O2+NO=RU14NO3 : 2.40d-12*EXP(360.0/temp)*0.100 ; +{264:169} RA13O2+NO=RA13NO3 : 2.40d-12*EXP(360.0/temp)*0.082 ; +{265:170} RA16O2+NO=RA16NO3 : 2.40d-12*EXP(360.0/temp)*0.111 ; +{266:171} RA19AO2+NO=RA19NO3 : 2.40d-12*EXP(360.0/temp)*0.138 ; +{267:172} RA19CO2+NO=RA19NO3 : 2.40d-12*EXP(360.0/temp)*0.138 ; +{268:173} RTN28O2+NO=RTN28NO3 : 2.40d-12*EXP(360.0/temp)*0.233 ; +{269:174} RTN25O2+NO=RTN25NO3 : 2.40d-12*EXP(360.0/temp)*0.160 ; +{270:175} RTX28O2+NO=RTX28NO3 : 2.40d-12*EXP(360.0/temp)*0.233 ; +{271:176} RTX24O2+NO=RTX24NO3 : 2.40d-12*EXP(360.0/temp)*0.157 ; +{272:177} RTX22O2+NO=RTX22NO3 : 2.40d-12*EXP(360.0/temp)*0.300 ; +{273:178} CH3OO+NO3=HCHO+HO2+NO2 : 2.50d-12*0.40 ; +{274:179} C2H5O2+NO3=CH3CHO+HO2+NO2 : 2.50d-12 ; +{275:180} RN10O2+NO3=C2H5CHO+HO2+NO2 : 2.50d-12 ; +{276:181} IC3H7O2+NO3=CH3COCH3+HO2+NO2 : 2.50d-12 ; +{277:182} RN13O2+NO3=CH3CHO+C2H5O2+NO2 : 2.50d-12*0.398 ; +{278:183} RN13O2+NO3=CARB11A+HO2+NO2 : 2.50d-12*0.602 ; +{279:184} RN16O2+NO3=RN15AO2+NO2 : 2.50d-12 ; +{280:185} RN19O2+NO3=RN18AO2+NO2 : 2.50d-12 ; +{281:186} RN13AO2+NO3=RN12O2+NO2 : 2.50d-12 ; +{282:187} RN16AO2+NO3=RN15O2+NO2 : 2.50d-12 ; +{283:188} RA13O2+NO3=CARB3+UDCARB8+HO2+NO2 : 2.50d-12 ; +{284:189} RA16O2+NO3=CARB3+UDCARB11+HO2+NO2 : 2.50d-12*0.7 ; +{285:190} RA16O2+NO3=CARB6+UDCARB8+HO2+NO2 : 2.50d-12*0.3 ; +{286:191} RA19AO2+NO3=CARB3+UDCARB14+HO2+NO2 : 2.50d-12 ; +{287:192} RA19CO2+NO3=CARB9+UDCARB8+HO2+NO2 : 2.50d-12 ; +{288:193} HOCH2CH2O2+NO3=HCHO+HCHO+HO2+NO2 : 2.50d-12*0.776 ; +{289:194} HOCH2CH2O2+NO3=HOCH2CHO+HO2+NO2 : 2.50d-12*0.224 ; +{290:195} RN9O2+NO3=CH3CHO+HCHO+HO2+NO2 : 2.50d-12 ; +{291:196} RN12O2+NO3=CH3CHO+CH3CHO+HO2+NO2 : 2.50d-12 ; +{292:197} RN15O2+NO3=C2H5CHO+CH3CHO+HO2+NO2 : 2.50d-12 ; +{293:198} RN18O2+NO3=C2H5CHO+C2H5CHO+HO2+NO2 : 2.50d-12; +{294:199} RN15AO2+NO3=CARB13+HO2+NO2 : 2.50d-12 ; +{295:200} RN18AO2+NO3=CARB16+HO2+NO2 : 2.50d-12 ; +{296:201} CH3CO3+NO3=CH3OO+NO2 : 2.50d-12*1.60 ; +{297:202} C2H5CO3+NO3=C2H5O2+NO2 : 2.50d-12*1.60 ; +{298:203} HOCH2CO3+NO3=HO2+HCHO+NO2 : 2.50d-12*1.60 ; +{299:204} RN8O2+NO3=CH3CO3+HCHO+NO2 : 2.50d-12 ; +{300:205} RN11O2+NO3=CH3CO3+CH3CHO+NO2 : 2.50d-12 ; +{301:206} RN14O2+NO3=C2H5CO3+CH3CHO+NO2 : 2.50d-12 ; +{302:207} RN17O2+NO3=RN16AO2+NO2 : 2.50d-12 ; +{303:208} RU14O2+NO3=UCARB12+HO2+NO2 : 2.50d-12*0.252 ; +{304:209} RU14O2+NO3=UCARB10+HCHO+HO2+NO2 : 2.50d-12*0.748 ; +{305:210} RU12O2+NO3=CH3CO3+HOCH2CHO+NO2 : 2.50d-12*0.7 ; +{306:211} RU12O2+NO3=CARB7+CO+HO2+NO2 : 2.50d-12*0.3 ; +{307:212} RU10O2+NO3=CH3CO3+HOCH2CHO+NO2 : 2.50d-12*0.5 ; +{308:213} RU10O2+NO3=CARB6+HCHO+HO2+NO2 : 2.50d-12*0.3 ; +{309:214} RU10O2+NO3=CARB7+HCHO+HO2+NO2 : 2.50d-12*0.2 ; +{310:215} NRN6O2+NO3=HCHO+HCHO+NO2+NO2 : 2.50d-12 ; +{311:216} NRN9O2+NO3=CH3CHO+HCHO+NO2+NO2 : 2.50d-12 ; +{312:217} NRN12O2+NO3=CH3CHO+CH3CHO+NO2+NO2 : 2.50d-12 ; +{313:218} NRU14O2+NO3=NUCARB12+HO2+NO2 : 2.50d-12 ; +{314:219} NRU12O2+NO3=NOA+CO+HO2+NO2 : 2.50d-12 ; +{315:220} RTN28O2+NO3=TNCARB26+HO2+NO2 : 2.50d-12 ; +{316:221} NRTN28O2+NO3=TNCARB26+NO2+NO2 : 2.50d-12 ; +{317:222} RTN26O2+NO3=RTN25O2+NO2 : 2.50d-12 ; +{318:223} RTN25O2+NO3=RTN24O2+NO2 : 2.50d-12 ; +{319:224} RTN24O2+NO3=RTN23O2+NO2 : 2.50d-12 ; +{320:225} RTN23O2+NO3=CH3COCH3+RTN14O2+NO2 : 2.50d-12 ; +{321:226} RTN14O2+NO3=HCHO+TNCARB10+HO2+NO2 : 2.50d-12 ; +{322:227} RTN10O2+NO3=RN8O2+CO+NO2 : 2.50d-12 ; +{323:228} RTX28O2+NO3=TXCARB24+HCHO+HO2+NO2 : 2.50d-12 ; +{324:229} RTX24O2+NO3=TXCARB22+HO2+NO2 : 2.50d-12 ; +{325:230} RTX22O2+NO3=CH3COCH3+RN13O2+NO2 : 2.50d-12 ; +{326:231} NRTX28O2+NO3=TXCARB24+HCHO+NO2+NO2 : 2.50d-12 ; +{327:232} CH3OO+HO2=CH3OOH : ARR2( 3.80D-13, -780.0_dp, TEMP) ; +{328:233} C2H5O2+HO2=C2H5OOH : ARR2( 7.50D-13, -700.0_dp, TEMP) ; +{329:234} RN10O2+HO2=RN10OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{330:235} IC3H7O2+HO2=IC3H7OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{331:236} RN13O2+HO2=RN13OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{332:237} RN16O2+HO2=RN16OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{333:238} RN19O2+HO2=RN19OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{334:239} RN13AO2+HO2=RN13OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{335:240} RN16AO2+HO2=RN16OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{336:241} RA13O2+HO2=RA13OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{337:242} RA16O2+HO2=RA16OOH : 0.820*2.91d-13*EXP(1300.0/temp) ; +{338:243} RA19AO2+HO2=RA19OOH : 0.859*2.91d-13*EXP(1300.0/temp) ; +{339:244} RA19CO2+HO2=RA19OOH : 0.859*2.91d-13*EXP(1300.0/temp) ; +{340:245} HOCH2CH2O2+HO2=HOC2H4OOH : ARR2( 2.03D-13, -1250.0_dp, TEMP) ; +{341:246} RN9O2+HO2=RN9OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{342:247} RN12O2+HO2=RN12OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{343:248} RN15O2+HO2=RN15OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{344:249} RN18O2+HO2=RN18OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{345:250} RN15AO2+HO2=RN15OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{346:251} RN18AO2+HO2=RN18OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{347:252} CH3CO3+HO2=CH3CO3H : 4.30d-13*EXP(1040.0/temp) ; +{348:253} C2H5CO3+HO2=C2H5CO3H : 4.30d-13*EXP(1040.0/temp) ; +{349:254} HOCH2CO3+HO2=HOCH2CO3H : 4.30d-13*EXP(1040.0/temp) ; +{350:255} RN8O2+HO2=RN8OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{351:256} RN11O2+HO2=RN11OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{352:257} RN14O2+HO2=RN14OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{353:258} RN17O2+HO2=RN17OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{354:258} RU14O2+HO2=RU14OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{355:260} RU12O2+HO2=RU12OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{356:261} RU10O2+HO2=RU10OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{357:262} NRN6O2+HO2=NRN6OOH : 0.387*2.91d-13*EXP(1300.0/temp) ; +{358:263} NRN9O2+HO2=NRN9OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{359:264} NRN12O2+HO2=NRN12OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{360:265} NRU14O2+HO2=NRU14OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{361:266} NRU12O2+HO2=NRU12OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{362:267} RTN28O2+HO2=RTN28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{363:268} NRTN28O2+HO2=NRTN28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{364:269} RTN26O2+HO2=RTN26OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{365:270} RTN25O2+HO2=RTN25OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{366:271} RTN24O2+HO2=RTN24OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{367:272} RTN23O2+HO2=RTN23OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{368:273} RTN14O2+HO2=RTN14OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{369:274} RTN10O2+HO2=RTN10OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{370:275} RTX28O2+HO2=RTX28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{371:276} RTX24O2+HO2=RTX24OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{372:277} RTX22O2+HO2=RTX22OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{373:278} NRTX28O2+HO2=NRTX28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{374:279} CH3OO=HCHO+HO2 : 0.33*RO2*ARR2( 1.82D-13, -416.0_dp, TEMP) ; +{375:280} CH3OO=HCHO : 0.335*RO2*ARR2( 1.82D-13, -416.0_dp, TEMP) ; +{376:281} CH3OO=CH3OH : 0.335*RO2*ARR2( 1.82D-13, -416.0_dp, TEMP) ; +{377:282} C2H5O2=CH3CHO+HO2 : 3.10D-13*0.6*RO2 ; +{378:283} C2H5O2=CH3CHO : 3.10D-13*0.2*RO2 ; +{379:284} C2H5O2=C2H5OH : 3.10D-13*0.2*RO2 ; +{380:285} RN10O2=C2H5CHO+HO2 : 6.00D-13*0.6*RO2 ; +{381:286} RN10O2=C2H5CHO : 6.00D-13*0.2*RO2 ; +{382:287} RN10O2=NPROPOL : 6.00D-13*0.2*RO2 ; +{383:288} IC3H7O2=CH3COCH3+HO2 : 4.00D-14*0.6*RO2 ; +{384:289} IC3H7O2=CH3COCH3 : 4.00D-14*0.2*RO2 ; +{385:290} IC3H7O2=IPROPOL : 4.00D-14*0.2*RO2 ; +{386:291} RN13O2=CH3CHO+C2H5O2 : 2.50D-13*RO2*0.398 ; +{387:292} RN13O2=CARB11A+HO2 : 2.50D-13*RO2*0.602 ; +{388:293} RN13AO2=RN12O2 : 8.80D-13*RO2 ; +{389:294} RN16AO2=RN15O2 : 8.80D-13*RO2 ; +{390:295} RA13O2=CARB3+UDCARB8+HO2 : 8.80D-13*RO2 ; +{391:296} RA16O2=CARB3+UDCARB11+HO2 : 8.80D-13*RO2*0.7 ; +{392:297} RA16O2=CARB6+UDCARB8+HO2 : 8.80D-13*RO2*0.3 ; +{393:298} RA19AO2=CARB3+UDCARB14+HO2 : 8.80D-13*RO2 ; +{394:299} RA19CO2=CARB3+UDCARB14+HO2 : 8.80D-13*RO2 ; +{395:300} RN16O2=RN15AO2 : 2.50D-13*RO2 ; +{396:301} RN19O2=RN18AO2 : 2.50D-13*RO2 ; +{397:302} HOCH2CH2O2=HCHO+HCHO+HO2 : 2.00D-12*RO2*0.776 ; +{398:303} HOCH2CH2O2=HOCH2CHO+HO2 : 2.00D-12*RO2*0.224 ; +{399:304} RN9O2=CH3CHO+HCHO+HO2 : 8.80D-13*RO2 ; +{400:305} RN12O2=CH3CHO+CH3CHO+HO2 : 8.80D-13*RO2 ; +{401:306} RN15O2=C2H5CHO+CH3CHO+HO2 : 8.80D-13*RO2 ; +{402:307} RN18O2=C2H5CHO+C2H5CHO+HO2 : 8.80D-13*RO2 ; +{403:308} RN15AO2=CARB13+HO2 : 8.80D-13*RO2 ; +{404:309} RN18AO2=CARB16+HO2 : 8.80D-13*RO2 ; +{405:310} CH3CO3=CH3OO : 1.00D-11*RO2 ; +{406:311} C2H5CO3=C2H5O2 : 1.00D-11*RO2 ; +{407:312} HOCH2CO3=HCHO+HO2 : 1.00D-11*RO2 ; +{408:313} RN8O2=CH3CO3+HCHO : 1.40D-12*RO2 ; +{409:314} RN11O2=CH3CO3+CH3CHO : 1.40D-12*RO2 ; +{410:315} RN14O2=C2H5CO3+CH3CHO : 1.40D-12*RO2 ; +{411:316} RN17O2=RN16AO2 : 1.40D-12*RO2 ; +{412:317} RU14O2=UCARB12+HO2 : 1.71D-12*RO2*0.252 ; +{413:318} RU14O2=UCARB10+HCHO+HO2 : 1.71D-12*RO2*0.748 ; +{414:319} RU12O2=CH3CO3+HOCH2CHO : 2.00D-12*RO2*0.7 ; +{415:320} RU12O2=CARB7+HOCH2CHO+HO2 : 2.00D-12*RO2*0.3 ; +{416:321} RU10O2=CH3CO3+HOCH2CHO : 2.00D-12*RO2*0.5 ; +{417:322} RU10O2=CARB6+HCHO+HO2 : 2.00D-12*RO2*0.3 ; +{418:323} RU10O2=CARB7+HCHO+HO2 : 2.00D-12*RO2*0.2 ; +{419:324} NRN6O2=HCHO+HCHO+NO2 : 6.00D-13*RO2 ; +{420:325} NRN9O2=CH3CHO+HCHO+NO2 : 2.30D-13*RO2 ; +{421:326} NRN12O2=CH3CHO+CH3CHO+NO2 : 2.50D-13*RO2 ; +{422:327} NRU14O2=NUCARB12+HO2 : 1.30D-12*RO2 ; +{423:328} NRU12O2=NOA+CO+HO2 : 9.60D-13*RO2 ; +{424:329} RTN28O2=TNCARB26+HO2 : 2.85D-13*RO2 ; +{425:330} NRTN28O2=TNCARB26+NO2 : 1.00D-13*RO2 ; +{426:331} RTN26O2=RTN25O2 : 2.00D-12*RO2 ; +{427:332} RTN25O2=RTN24O2 : 1.30D-12*RO2 ; +{428:333} RTN24O2=RTN23O2 : 6.70D-15*RO2 ; +{429:334} RTN23O2=CH3COCH3+RTN14O2 : 6.70D-15*RO2 ; +{430:335} RTN14O2=HCHO+TNCARB10+HO2 : 8.80D-13*RO2 ; +{431:336} RTN10O2=RN8O2+CO : 2.00D-12*RO2 ; +{432:337} RTX28O2=TXCARB24+HCHO+HO2 : 2.00D-12*RO2 ; +{433:338} RTX24O2=TXCARB22+HO2 : 2.50D-13*RO2 ; +{434:339} RTX22O2=CH3COCH3+RN13O2 : 2.50D-13*RO2 ; +{435:340} NRTX28O2=TXCARB24+HCHO+NO2 : 9.20D-14*RO2 ; +{436:341} OH+CARB14=RN14O2 : 1.87D-11 ; +{437:342} OH+CARB17=RN17O2 : 4.36D-12 ; +{438:343} OH+CARB11A=RN11O2 : 3.24D-18*TEMP**2*EXP(414/TEMP) ; +{439:344} OH+CARB7=CARB6+HO2 : 3.00D-12 ; +{440:345} OH+CARB10=CARB9+HO2 : 5.86D-12 ; +{441:346} OH+CARB13=RN13O2 : 1.65D-11 ; +{442:347} OH+CARB16=RN16O2 : 1.25D-11 ; +{443:348} OH+UCARB10=RU10O2 : 2.50D-11 ; +{444:349} NO3+UCARB10=RU10O2+HNO3 : 1.44d-12*EXP(-1862.0/temp) ; +{445:350} O3+UCARB10=HCHO+CH3CO3+CO+OH : 2.85D-18*0.59 ; +{446:351} O3+UCARB10=HCHO+CARB6+H2O2 : 2.85D-18*0.41 ; +{447:352} OH+HOCH2CHO=HOCH2CO3 : 1.00D-11 ; +{448:353} NO3+HOCH2CHO=HOCH2CO3+HNO3 : 1.44d-12*EXP(-1862.0/temp) ; +{449:354} OH+CARB3=CO+CO+HO2 : 1.14D-11 ; +{450:355} OH+CARB6=CH3CO3+CO : 1.72D-11 ; +{451:356} OH+CARB9=RN9O2 : 2.40D-13 ; +{452:357} OH+CARB12=RN12O2 : 1.38D-12 ; +{453:358} OH+CARB15=RN15O2 : 4.81D-12 ; +{454:359} OH+CCARB12=RN12O2 : 4.79D-12 ; +{455:360} OH+UCARB12=RU12O2 : 4.52D-11 ; +{456:361} NO3+UCARB12=RU12O2+HNO3 : 1.44d-12*EXP(-1862.0/temp)*4.25 ; +{457:362} O3+UCARB12=HOCH2CHO+CH3CO3+CO+OH : 2.40D-17*0.89 ; +{458:363} O3+UCARB12=HOCH2CHO+CARB6+H2O2 : 2.40D-17*0.11 ; +{459:364} OH+NUCARB12=NRU12O2 : 4.16D-11 ; +{460:365} OH+NOA=CARB6+NO2 : 1.30D-13 ; +{461:366} OH+UDCARB8=C2H5O2 : 5.20D-11*0.5 ; +{462:367} OH+UDCARB11=RN10O2 : 5.58D-11*0.55 ; +{463:368} OH+UDCARB14=RN13O2 : 7.00D-11*0.55 ; +{464:369} OH+TNCARB26=RTN26O2 : 4.20D-11 ; +{465:370} OH+TNCARB15=RN15AO2 : 1.00D-12 ; +{466:371} OH+TNCARB10=RTN10O2 : 1.00D-10 ; +{467:372} NO3+TNCARB26=RTN26O2+HNO3 : 3.80D-14 ; +{468:373} NO3+TNCARB10=RTN10O2+HNO3 : 1.44d-12*EXP(-1862.0/temp)*5.5 ; +{469:374} OH+RCOOH25=RTN25O2 : 6.65D-12 ; +{470:375} OH+TXCARB24=RTX24O2 : 1.55D-11 ; +{471:376} OH+TXCARB22=RTX22O2 : 4.55D-12 ; +{472:377} OH+CH3NO3=HCHO+NO2 : ARR2( 1.00D-14, -1060.0_dp, TEMP) ; +{473:378} OH+C2H5NO3=CH3CHO+NO2 : ARR2( 4.40D-14, -720.0_dp, TEMP) ; +{474:379} OH+RN10NO3=C2H5CHO+NO2 : 7.30D-13 ; +{475:380} OH+IC3H7NO3=CH3COCH3+NO2 : 4.90D-13 ; +{476:381} OH+RN13NO3=CARB11A+NO2 : 9.20D-13 ; +{477:382} OH+RN16NO3=CARB14+NO2 : 1.85D-12 ; +{478:383} OH+RN19NO3=CARB17+NO2 : 3.02D-12 ; +{479:384} OH+HOC2H4NO3=HOCH2CHO+NO2 : 1.09D-12 ; +{480:385} OH+RN9NO3=CARB7+NO2 : 1.31D-12 ; +{481:386} OH+RN12NO3=CARB10+NO2 : 1.79D-12 ; +{482:387} OH+RN15NO3=CARB13+NO2 : 1.03D-11 ; +{483:388} OH+RN18NO3=CARB16+NO2 : 1.34D-11 ; +{484:389} OH+RU14NO3=UCARB12+NO2 : 5.55D-11 ; +{485:390} OH+RA13NO3=CARB3+UDCARB8+NO2 : 7.30D-11 ; +{486:391} OH+RA16NO3=CARB3+UDCARB11+NO2 : 7.16D-11 ; +{487:392} OH+RA19NO3=CARB6+UDCARB11+NO2 : 8.31D-11 ; +{488:393} OH+RTN28NO3=TNCARB26+NO2 : 4.35D-12 ; +{489:394} OH+RTN25NO3=CH3COCH3+TNCARB15+NO2 : 2.88D-12 ; +{490:395} OH+RTX28NO3=TXCARB24+HCHO+NO2 : 3.53D-12 ; +{491:396} OH+RTX24NO3=TXCARB22+NO2 : 6.48D-12 ; +{492:397} OH+RTX22NO3=CH3COCH3+CCARB12+NO2 : 4.74D-12 ; +{493:398} OH+AROH14=RAROH14 : 2.63D-11 ; +{494:399} NO3+AROH14=RAROH14+HNO3 : 3.78D-12 ; +{495:400} RAROH14+NO2=ARNOH14 : 2.08D-12 ; +{496:401} OH+ARNOH14=CARB13+NO2 : 9.00D-13 ; +{497:402} NO3+ARNOH14=CARB13+NO2+HNO3 : 9.00D-14 ; +{498:403} OH+AROH17=RAROH17 : 4.65D-11 ; +{499:404} NO3+AROH17=RAROH17+HNO3 : 1.25D-11 ; +{500:405} RAROH17+NO2=ARNOH17 : 2.08D-12 ; +{501:406} OH+ARNOH17=CARB16+NO2 : 1.53D-12 ; +{502:407} NO3+ARNOH17=CARB16+NO2+HNO3 : 3.13D-13 ; +{503:408} OH+CH3OOH=CH3OO : ARR2( 1.90D-12, -190.0_dp, TEMP) ; +{504:409} OH+CH3OOH=HCHO+OH : ARR2( 1.00D-12, -190.0_dp, TEMP) ; +{505:410} OH+C2H5OOH=CH3CHO+OH : 1.36D-11 ; +{506:411} OH+RN10OOH=C2H5CHO+OH : 1.89D-11 ; +{507:412} OH+IC3H7OOH=CH3COCH3+OH : 2.78D-11 ; +{508:413} OH+RN13OOH=CARB11A+OH : 3.57D-11 ; +{509:414} OH+RN16OOH=CARB14+OH : 4.21D-11 ; +{510:415} OH+RN19OOH=CARB17+OH : 4.71D-11 ; +{511:416} OH+CH3CO3H=CH3CO3 : 3.70D-12 ; +{512:417} OH+C2H5CO3H=C2H5CO3 : 4.42D-12 ; +{513:418} OH+HOCH2CO3H=HOCH2CO3 : 6.19D-12 ; +{514:419} OH+RN8OOH=CARB6+OH : 4.42D-12 ; +{515:420} OH+RN11OOH=CARB9+OH : 2.50D-11 ; +{516:421} OH+RN14OOH=CARB12+OH : 3.20D-11 ; +{517:422} OH+RN17OOH=CARB15+OH : 3.35D-11 ; +{518:423} OH+RU14OOH=UCARB12+OH : 7.51D-11 ; +{519:424} OH+RU12OOH=RU12O2 : 3.00D-11 ; +{520:425} OH+RU10OOH=RU10O2 : 3.00D-11 ; +{521:426} OH+NRU14OOH=NUCARB12+OH : 1.03D-10 ; +{522:427} OH+NRU12OOH=NOA+CO+OH : 2.65D-11 ; +{523:428} OH+HOC2H4OOH=HOCH2CHO+OH : 2.13D-11 ; +{524:429} OH+RN9OOH=CARB7+OH : 2.50D-11 ; +{525:430} OH+RN12OOH=CARB10+OH : 3.25D-11 ; +{526:431} OH+RN15OOH=CARB13+OH : 3.74D-11 ; +{527:432} OH+RN18OOH=CARB16+OH : 3.83D-11 ; +{528:433} OH+NRN6OOH=HCHO+HCHO+NO2+OH : 5.22D-12 ; +{529:434} OH+NRN9OOH=CH3CHO+HCHO+NO2+OH : 6.50D-12 ; +{530:435} OH+NRN12OOH=CH3CHO+CH3CHO+NO2+OH : 7.15D-12 ; +{531:436} OH+RA13OOH=CARB3+UDCARB8+OH : 9.77D-11 ; +{532:437} OH+RA16OOH=CARB3+UDCARB11+OH : 9.64D-11 ; +{533:438} OH+RA19OOH=CARB6+UDCARB11+OH : 1.12D-10 ; +{534:439} OH+RTN28OOH=TNCARB26+OH : 2.38D-11 ; +{535:440} OH+RTN26OOH=RTN26O2 : 1.20D-11 ; +{536:441} OH+NRTN28OOH=TNCARB26+NO2+OH : 9.50D-12 ; +{537:442} OH+RTN25OOH=RTN25O2 : 1.66D-11 ; +{538:443} OH+RTN24OOH=RTN24O2 : 1.05D-11 ; +{539:444} OH+RTN23OOH=RTN23O2 : 2.05D-11 ; +{540:445} OH+RTN14OOH=RTN14O2 : 8.69D-11 ; +{541:446} OH+RTN10OOH=RTN10O2 : 4.23D-12 ; +{542:447} OH+RTX28OOH=RTX28O2 : 2.00D-11 ; +{543:448} OH+RTX24OOH=TXCARB22+OH : 8.59D-11 ; +{544:449} OH+RTX22OOH=CH3COCH3+CCARB12+OH : 7.50D-11 ; +{545:450} OH+NRTX28OOH=NRTX28O2 : 9.58D-12 ; +{546:451} CH3CO3+NO2=PAN : TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp , TEMP, C_M) ; +{547:452} PAN=CH3CO3+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29 ,6.5_dp,1.1d-11,0._dp,TEMP,C_M) ; +{548:453} C2H5CO3+NO2=PPN : TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp , TEMP, C_M) ; +{549:454} PPN=C2H5CO3+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29,6.5_dp , 1.1d-11 , 0._dp,TEMP, C_M) ; +{550:455} HOCH2CO3+NO2=PHAN : TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp , TEMP, C_M) ; +{551:456} PHAN=HOCH2CO3+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29 , 6.5_dp,1.1d-11,0._dp,TEMP, C_M) ; +{552:457} OH+PAN=HCHO+CO+NO2 : ARR2( 9.50D-13, 650.0_dp, TEMP) ; +{553:458} OH+PPN=CH3CHO+CO+NO2 : 1.27D-12 ; +{554:459} OH+PHAN=HCHO+CO+NO2 : 1.12D-12 ; +{555:460} RU12O2+NO2=RU12PAN : 0.061*TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp ,TEMP, C_M) ; +{556:461} RU12PAN=RU12O2+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29,6.5_dp,1.1d-11,0._dp,TEMP, C_M) ; +{557:462} RU10O2+NO2=MPAN : 0.041*TROE( 8.5d-29,6.5_dp,1.1d-11,1._dp,TEMP,C_M) ; +{558:463} MPAN=RU10O2+NO2 : TROEE(1.111d28,14000._dp,8.5d-29,6.5_dp,1.1d-11,0._dp ,TEMP, C_M) ; +{559:464} OH+MPAN=CARB7+CO+NO2 : 3.60D-12 ; +{560:465} OH+RU12PAN=UCARB10+NO2 : 2.52D-11 ; +{561:466} RTN26O2+NO2=RTN26PAN : 0.722*TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp,TEMP, C_M) ; +{562:467} RTN26PAN=RTN26O2+NO2 : TROEE(1.111d28,14000._dp,8.5d-29,6.5_dp,1.1d-11,0._dp,TEMP, C_M) ; +{563:468} OH+RTN26PAN=CH3COCH3+CARB16+NO2 : 3.66D-12 ; +{564:469} OH+ANHY=HOCH2CH2O2 : 1.50D-12 ; +{565:470} OH+UDCARB8=ANHY+HO2 : 5.20D-11*0.50 ; +{566:471} OH+UDCARB11=ANHY+CH3OO : 5.58D-11*0.45 ; +{567:472} OH+UDCARB14=ANHY+C2H5O2 : 7.00D-11*0.45 ; +{568:473} OH+CH3CL=CH3OO : 7.33D-18*EXP(-809/TEMP)*TEMP**2 ; +{569:474} OH+CH2CL2=CH3OO : 6.14D-18*EXP(-389/TEMP)*TEMP**2 ; +{570:475} OH+CHCL3=CH3OO : 1.80D-18*EXP(-129/TEMP)*TEMP**2 ; +{571:476} OH+CH3CCL3=C2H5O2 : 2.25D-18*EXP(-910/TEMP)*TEMP**2 ; +{572:477} OH+TCE= HOCH2CH2O2 : ARR2( 9.64D-12, 1209.0_dp, TEMP) ; +{573:478} OH+TRICLETH=HOCH2CH2O2 : ARR2( 5.63D-13, -427.0_dp, TEMP) ; +{574:479} OH+CDICLETH=HOCH2CH2O2 : ARR2( 1.94D-12, -90.0_dp, TEMP) ; +{575:480} OH+TDICLETH=HOCH2CH2O2 : ARR2( 1.01D-12, -250.0_dp, TEMP) ; +{576:481} CH3OO+NO2=CH3O2NO2 : RJPL(1.3D-30,4.0_dp,7.5D-12,2.0_dp,C_M,TEMP) ; +{577:482} TNCARB12+hv = RN9O2 + HOCH2CO3 : 7.047*7.8D-5 * j(Pj_no2) ; +{578:483} TNCARB11+hv = RTN10O2 + CO + HO2 : 32.6088*4.6D-4 * j(Pj_no2) ; +{579:484} RA22NO3+hv = CARB6 + UDCARB14 + HO2 + NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{580:485} RA22OOH+hv = CARB6 + UDCARB14 + HO2 + OH : 0.7 * j(Pj_h2o2) ; +{581:486} RA25NO3+hv = CARB6 + UDCARB17 + HO2 + NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{582:487} RA25OOH+hv = CARB6 + UDCARB17 + HO2 + OH : 0.7 * j(Pj_h2o2) ; +{583:488} UDCARB17+hv = ANHY + HO2 + RN10O2 : 0.02*0.45*j(Pj_no2) ; +{584:489} UDCARB17+hv = RN16O2 + HO2 : 0.02*0.55*j(Pj_no2) ; +{585:490} RTN23O2 + NO = RTN23NO3 : 2.40d-12*EXP(360.0/temp)*0.118 ; +{586:491} RTN23NO3 + OH = CH3COCH3 + TNCARB12 + NO2 : 5.37D-12 ; +{587:492} TNCARB12 + OH = TNCARB11 + HO2 : 3.22D-12 ; +{588:493} TNCARB11 + OH = RTN10O2 + CO : 1.33D-11 ; +{589:494} TNCARB11 + NO3 = RTN10O2 + CO + HNO3 : 1.44d-12*EXP(-1862.0/temp)*5.5 ; +{590:495} TM123B + OH = RA22AO2 : 3.27D-11*0.50 ; +{591:496} TM123B + OH = RA22BO2 : 3.27D-11*0.50 ; +{592:497} TM124B + OH = RA22AO2 : 3.25D-11*0.50 ; +{593:498} TM124B + OH = RA22BO2 : 3.25D-11*0.50 ; +{594:499} TM135B + OH = RA22AO2 : 5.67D-11 ; +{595:500} OETHTOL + OH = RA22AO2 : 1.19D-11 ; +{596:501} METHTOL + OH = RA22AO2 : 1.86D-11 ; +{597:502} PETHTOL + OH = RA22AO2 : 1.18D-11 ; +{598:503} RA22AO2 + NO = CARB6 + UDCARB14 + HO2 + NO2 : 2.40d-12*EXP(360.0/temp)*0.843 ; +{599:504} RA22BO2 + NO = CARB9 + UDCARB11 + HO2 + NO2 : 2.40d-12*EXP(360.0/temp)*0.843 ; +{600:505} RA22AO2 + NO = RA22NO3 : 2.40d-12*EXP(360.0/temp)*0.157 ; +{601:506} RA22BO2 + NO = RA22NO3 : 2.40d-12*EXP(360.0/temp)*0.157 ; +{602:507} RA22AO2 + NO3 = CARB6 + UDCARB14 + HO2 + NO2 : 2.50d-12 ; +{603:508} RA22BO2 + NO3 = CARB9 + UDCARB11 + HO2 + NO2 : 2.50d-12 ; +{604:509} RA22AO2 + HO2 = RA22OOH : 0.520*2.91d-13*EXP(1300.0/temp)*0.890 ; +{605:510} RA22BO2 + HO2 = RA22OOH : 0.520*2.91d-13*EXP(1300.0/temp)*0.890 ; +{606:511} RA22AO2 = CARB6 + UDCARB14 + HO2 : 8.80D-13*RO2 ; +{607:512} RA22BO2 = CARB9 + UDCARB11 + HO2 : 8.80D-13*RO2 ; +{608:513} OH + RA22NO3 = CARB6 + UDCARB14 + NO2 : 9.45D-11 ; +{609:514} OH + RA22OOH = CARB6 + UDCARB14 + OH : 1.28D-10 ; +{610:515} DIME35EB + OH = RA25O2 : 5.67D-11 ; +{611:516} RA25O2 + NO = CARB6 + UDCARB17 + HO2 + NO2 : 2.40d-12*EXP(360.0/temp)*0.833 ; +{612:517} RA25O2 + NO = RA25NO3 : 2.40d-12*EXP(360.0/temp)*0.167 ; +{613:518} RA25O2 + NO3 = CARB6 + UDCARB17 + HO2 + NO2 : 2.50d-12 ; +{614:519} RA25O2 + HO2 = RA25OOH : 0.520*2.91d-13*EXP(1300.0/temp)*0.914 ; +{615:520} RA25O2 = CARB6 + UDCARB17 + HO2 : 8.80D-13*RO2 ; +{616:521} OH + RA25NO3 = CARB6 + UDCARB17 + NO2 : 9.57D-11 ; +{617:522} OH + RA25OOH = CARB6 + UDCARB17 + OH : 1.28D-10 ; +{618:523} OH + UDCARB17 = RN16O2 : 7.00D-11*0.55 ; +{619:524} OH + UDCARB17 = ANHY + RN10O2 : 7.00D-11*0.45 ; +{620:105} HCl = HCl : 1.0_dp ; {copied from cbmz_bb} +{621:106} NH3 = NH3 : 1.0_dp ; {copied from cbmz_bb} +{621:106} ClNO2 = ClNO2 : 1.0_dp ; {dummy} +{622:S04} DMS + OH = CH3SCH2OO + H2O : ARR2(1.12d-11,250._dp,temp) ; {CH3SCH3+OH->CH3SCH2+H2O ; CH3SCH2+O2->CH3SCH2OO - 1st step is slowest, so use that as reaction function (IUPAC preferred value)} +{623:S05} DMS + OH {+O2} = DMSO + HO2 : iupac_ch3sch3(9.5d-39,5270._dp,7.5d-29,5610._dp,C_M*0.2_dp,temp) ; {IUPAC preferred value} +{624:S06} DMS + NO3 {+O2} = CH3SCH2OO + HNO3 : ARR2(1.9d-13,-520._dp,temp) ; +{625:S12} CH3SCH2OO + NO = HCHO + CH3S + NO2 : ARR2(4.9d-12,-263._dp,temp) ; +{626:S13} CH3SCH2OO + CH3SCH2OO {+O2} = 2 HCHO + 2 CH3S : 1.0d-11 ; +{627:S14} CH3S + O3 = CH3SO {+ O2} : ARR2(1.15d-12,-432._dp,temp) ; +{628:S15} CH3S + NO2 = CH3SO + NO : ARR2(3.0d-11,-210._dp,temp) ; +{629:S16} CH3SO + NO2 {+O2} = 0.82 CH3SO2 + 0.18 SO2 + 0.18 CH3OO + NO : 1.2d-11 ; +{630:S17} CH3SO + O3 {+O2} = CH3SO2 : 6.0d-13 ; +{631:S18} CH3SO2 = SO2 + CH3OO : ARR2(5.0d13,9673._dp,temp) {ARR2(1.9d13,8661._dp,temp)} ; +{632:S19} CH3SO2 + NO2 = CH3SO3 + NO : 2.2d-12 ; +{633:S20} CH3SO2 + O3 = CH3SO3 : 3.0d-13 ; +{634:S21} CH3SO3 + HO2 = MSA : 5.0d-11 ; +{635:S22} CH3SO3 {+H2O+O2} = CH3OO + H2SO4 : ARR2(1.36d14,11071._dp,temp) ; +{636:S23} DMSO + OH = 0.95 MSIA + 0.95 CH3OO + 0.05 DMSO2 : 8.7d-11 ; +{637:S24} MSIA + OH = 0.95 CH3SO2 + 0.05 MSA + 0.05 HO2 + H2O : 9.d-11 ; +{638:S25} MSIA + NO3 = CH3SO2 + HNO3 : 1.0d-13 ; + diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.kpp b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.kpp new file mode 100644 index 00000000..00aa7be9 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.kpp @@ -0,0 +1,9 @@ +#MODEL cri_mosaic_4bin_aq +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.spc b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.spc new file mode 100644 index 00000000..01a45adf --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq.spc @@ -0,0 +1,238 @@ +#DEFVAR + HONO =IGNORE ; + O3 =IGNORE ; + HCHO =IGNORE ; + PAN =IGNORE ; + C2H4 =IGNORE ; + CO =IGNORE ; + HNO3 =IGNORE ; + N2O5 =IGNORE ; + HNO4 =IGNORE ; + NO3 =IGNORE ; + O1D =IGNORE ; + O3P =IGNORE ; + OH =IGNORE ; + HO2 =IGNORE ; + H2O2 =IGNORE ; + C2H6 =IGNORE ; + HCOOH =IGNORE ; + CH3CO3 =IGNORE ; + CH3OO =IGNORE ; + C2H5O2 =IGNORE ; + HSO3 =IGNORE ; + SO3 =IGNORE ; + SO2 =IGNORE ; + NO2 =IGNORE ; + NO =IGNORE ; + C3H8 =IGNORE ; + NC4H10 =IGNORE ; + HOCH2CH2O2 =IGNORE ; + IC3H7O2 =IGNORE ; + C5H8 =IGNORE ; + BENZENE =IGNORE ; + TOLUENE =IGNORE ; + OXYL =IGNORE ; + NPROPOL =IGNORE ; + C2H2 =IGNORE ; + C3H6 =IGNORE ; + TBUT2ENE =IGNORE ; + CH3CHO =IGNORE ; + C2H5CHO =IGNORE ; + CH3CO2H =IGNORE ; + CH3COCH3 =IGNORE ; + MEK =IGNORE ; + CH3OH =IGNORE ; + C2H5OH =IGNORE ; + IC3H7NO3 =IGNORE ; + IPROPOL =IGNORE ; + CH3NO3 =IGNORE ; + C2H5NO3 =IGNORE ; + HOC2H4NO3 =IGNORE ; + CH3OOH =IGNORE ; + C2H5OOH =IGNORE ; + IC3H7OOH =IGNORE ; + CH3CO3H =IGNORE ; + HOC2H4OOH =IGNORE ; + RN10O2 =IGNORE ; + RN13O2 =IGNORE ; + RN16O2 =IGNORE ; + RN19O2 =IGNORE ; + RN9O2 =IGNORE ; + RN12O2 =IGNORE ; + RN15O2 =IGNORE ; + RN18O2 =IGNORE ; + NRN6O2 =IGNORE ; + NRN9O2 =IGNORE ; + NRN12O2 =IGNORE ; + CARB14 =IGNORE ; + RN11O2 =IGNORE ; + RN14O2 =IGNORE ; + CARB17 =IGNORE ; + RN8O2 =IGNORE ; + RN17O2 =IGNORE ; + RN10NO3 =IGNORE ; + RN13NO3 =IGNORE ; + RN19NO3 =IGNORE ; + RN9NO3 =IGNORE ; + RN12NO3 =IGNORE ; + RN15NO3 =IGNORE ; + RN18NO3 =IGNORE ; + RN16NO3 =IGNORE ; + RN10OOH =IGNORE ; + RN13OOH =IGNORE ; + RN16OOH =IGNORE ; + RN19OOH =IGNORE ; + RN8OOH =IGNORE ; + RN11OOH =IGNORE ; + RN14OOH =IGNORE ; + RN17OOH =IGNORE ; + RN9OOH =IGNORE ; + RN12OOH =IGNORE ; + RN15OOH =IGNORE ; + RN18OOH =IGNORE ; + NRN6OOH =IGNORE ; + NRN9OOH =IGNORE ; + NRN12OOH =IGNORE ; + APINENE =IGNORE ; + BPINENE =IGNORE ; + RN13AO2 =IGNORE ; + RN16AO2 =IGNORE ; + RN15AO2 =IGNORE ; + RN18AO2 =IGNORE ; + CARB7 =IGNORE ; + CARB10 =IGNORE ; + CARB13 =IGNORE ; + CARB16 =IGNORE ; + CARB3 =IGNORE ; + CARB6 =IGNORE ; + CARB9 =IGNORE ; + CARB12 =IGNORE ; + CARB15 =IGNORE ; + C2H5CO3H =IGNORE ; + C2H5CO3 =IGNORE ; + PPN =IGNORE ; + HOCH2CHO =IGNORE ; + HOCH2CO3 =IGNORE ; + HOCH2CO3H =IGNORE ; + PHAN =IGNORE ; + CCARB12 =IGNORE ; + RU14O2 =IGNORE ; + RU12O2 =IGNORE ; + CH3CL =IGNORE ; + CH2CL2 =IGNORE ; + CHCL3 =IGNORE ; + CH3CCL3 =IGNORE ; + CDICLETH =IGNORE ; + TDICLETH =IGNORE ; + TRICLETH =IGNORE ; + TCE =IGNORE ; + RU10O2 =IGNORE ; + UCARB12 =IGNORE ; + UCARB10 =IGNORE ; + RU14NO3 =IGNORE ; + RU14OOH =IGNORE ; + RU12OOH =IGNORE ; + RU10OOH =IGNORE ; + MPAN =IGNORE ; + RU12PAN=IGNORE ; + NRU14O2 =IGNORE ; + NUCARB12 =IGNORE ; + NRU14OOH =IGNORE ; + NRU12O2 =IGNORE ; + NRU12OOH =IGNORE ; + NOA =IGNORE ; + RA13O2 =IGNORE ; + RA13NO3 =IGNORE ; + RA13OOH =IGNORE ; + UDCARB8 =IGNORE ; + AROH14 =IGNORE ; + RAROH14 =IGNORE ; + ARNOH14 =IGNORE ; + RA16O2 =IGNORE ; + RA16NO3 =IGNORE ; + RA16OOH =IGNORE ; + UDCARB11 =IGNORE ; + AROH17 =IGNORE ; + RAROH17 =IGNORE ; + ARNOH17 =IGNORE ; + UDCARB14 =IGNORE ; + RA19AO2 =IGNORE ; + RA19CO2 =IGNORE ; + RA19NO3 =IGNORE ; + RA19OOH =IGNORE ; + RTN28O2 =IGNORE ; + RTN28NO3 =IGNORE ; + RTN28OOH =IGNORE ; + TNCARB26 =IGNORE ; + RTN26O2 =IGNORE ; + RTN26OOH =IGNORE ; + NRTN28O2 =IGNORE ; + NRTN28OOH =IGNORE ; + RTN26PAN =IGNORE ; + RTN25O2 =IGNORE ; + RTN24O2 =IGNORE ; + RTN23O2 =IGNORE ; + RTN14O2 =IGNORE ; + RTN10O2 =IGNORE ; + RTN25OOH =IGNORE ; + RTN24OOH =IGNORE ; + RTN23OOH =IGNORE ; + RTN14OOH =IGNORE ; + RTN10OOH =IGNORE ; + TNCARB10 =IGNORE ; + RTN25NO3 =IGNORE ; + TNCARB15 =IGNORE ; + RCOOH25 =IGNORE ; + RTX28O2 =IGNORE ; + RTX28NO3 =IGNORE ; + RTX28OOH =IGNORE ; + TXCARB24 =IGNORE ; + RTX24O2 =IGNORE ; + RTX24NO3 =IGNORE ; + RTX24OOH =IGNORE ; + TXCARB22 =IGNORE ; + RTX22O2 =IGNORE ; + RTX22NO3 =IGNORE ; + RTX22OOH =IGNORE ; + NRTX28O2 =IGNORE ; + NRTX28OOH =IGNORE ; + CARB11A =IGNORE ; + ANHY =IGNORE ; + CH3O2NO2 =IGNORE ; + CH4 =IGNORE ; + H2SO4 =IGNORE ; + HCl =IGNORE ; + NH3 =IGNORE ; + RTN23NO3 =IGNORE ; + TNCARB12 =IGNORE ; + TNCARB11 =IGNORE ; + TM123B =IGNORE ; + TM124B =IGNORE ; + TM135B =IGNORE ; + OETHTOL =IGNORE ; + METHTOL =IGNORE ; + PETHTOL =IGNORE ; + RA22AO2 =IGNORE ; + RA22BO2 =IGNORE ; + RA22NO3 =IGNORE ; + RA22OOH =IGNORE ; + DIME35EB =IGNORE ; + RA25O2 =IGNORE ; + RA25NO3 =IGNORE ; + UDCARB17 =IGNORE ; + RA25OOH =IGNORE ; + DMS = IGNORE ; + CH3SCH2OO = IGNORE ; + DMSO = IGNORE ; + CH3S = IGNORE ; + CH3SO = IGNORE ; + CH3SO2 = IGNORE ; + CH3SO3 = IGNORE ; + MSA = IGNORE ; + MSIA = IGNORE ; + DMSO2 = IGNORE ; + ClNO2 = IGNORE ; +#DEFFIX + H2O =IGNORE ; + M =IGNORE ; +{H2 =IGNORE ;} diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq_wrfkpp.equiv new file mode 100644 index 00000000..4a0df53c --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_4bin_aq/cri_mosaic_4bin_aq_wrfkpp.equiv @@ -0,0 +1,14 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +HO OH +KET CH3COCH3 +ACO3 CH3CO3 +PAA CH3CO3H +PROOH IC3H7OOH +SULF H2SO4 + diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.def b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.def new file mode 100644 index 00000000..75c6cf12 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.def @@ -0,0 +1,171 @@ +#include atoms_red +#include ./cri_mosaic_8bin_aq.spc +#include ./cri_mosaic_8bin_aq.eqn + + + + +#INLINE F90_RATES +!************** SPECIAL RATE FUNCTIONS ********************** + +REAL(KIND=dp) FUNCTION k46( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=7.2E-15_dp * EXP(785._dp/TEMP) + k2=4.1E-16_dp * EXP(1440._dp/TEMP) + k3=1.9E-33_dp * EXP(725._dp/TEMP) * C_M + + k46=k0+k3/(1+k3/k2) + +! print*,'k46=',k46 +END FUNCTION k46 + +REAL(KIND=dp) FUNCTION k47( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, ki, fc, x, ssign, f12 + k0 = 3.00d-31*((temp/300.0)**(-3.3))*C_M + ki = 1.50d-12 + fc = 0.6 + x = 1.0d+0 + ssign = dsign(x,(k0-ki)) + f12 =10**(dlog10(fc)/(1.0+(ssign*(ABS(dlog10(k0/ki)))**(2.0)))) + k47=(k0*ki*f12)/(k0+ki) +! print*,'k47=',k47 +END FUNCTION k47 + +REAL(KIND=dp) FUNCTION k48( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, ki, fc, x, ssign, f17 + k0 = 5.00d-30*((temp/298.0)**(-1.5))*C_M + ki = 9.40d-12*EXP(-700.0/temp) + fc = (EXP(-temp/580.0) + EXP(-2320.0/temp)) + x = 1.0d+0 + ssign = dsign(x,(k0-ki)) + f17=10**(dlog10(fc)/(1.0+(ssign*(ABS(dlog10(k0/ki)))**(2.0)))) + k48=(k0*ki*f17)/(k0+ki) +! print*,'k48=',k48 +END FUNCTION k48 + + REAL(KIND=dp) FUNCTION RJPL( K0300, Q, KU300, R, M, T ) + REAL(KIND=dp) :: k0300,q,ku300,r,m,t + REAL(KIND=dp) :: tt,k0,ku,k0m,kk,lgkk,e,f +! JPL standard three body reaction rate format extended + TT= T / 3.D2 + K0= K0300 * exp(-1._dp*Q*log(TT)) + KU= KU300 * exp(-1._dp*R*log(TT)) + K0M= K0 * M + KK= K0M / KU + LGKK=0.43429448190324926_dp * LOG(KK) ! = log10(KK) + E=1.D0 / ( 1.D0 + LGKK*LGKK ) + F=exp(-0.5108256237659887_dp*E) ! -0.51=log(0.6) + RJPL = F * K0M / ( 1.D0 + KK ) +! print*,'RJPL=',RJPL + END FUNCTION +!--------------------------------------------------------------------- + + + + REAL(KIND=dp) FUNCTION RALKE( K0300, Q, KU, Fc, M, T ) + REAL(KIND=dp) :: k0300,q,m,t,Fc + real(KIND=dp) :: tt,k0,ku,k0m,kk,lgkk,e,f +! special function for alkene+OH reactions + TT= T / 3.D2 + K0= K0300 * exp(-1._dp*Q*log(TT)) + K0M= K0 * M + KK= K0M / KU + LGKK=0.43429448190324926_dp * LOG(KK) ! = log10(KK) + E=1.D0 / ( 1.D0 + LGKK*LGKK ) + F=exp(log(Fc)*E) + RALKE = F * K0M / ( 1.D0 + KK ) +! print*,'RALKE=',RALKE + END FUNCTION + + + real(kind=dp) function iupac_ch3sch3(a2,b2,a3,b3,cin_o2,temp) + !rate calculation for CH3SCH3 + OH = CH3SCH3OO + H2O + ! from IUPAC report (www.iupac-kinetic.ch.cam.ac.uk) + real(kind=dp) :: cin_o2, tr, temp + real(kind=dp) :: a2, b2, a3, b3 + + tr = 1._dp + ARR2(a3,b3,temp)*cin_o2 + iupac_ch3sch3 = ARR2(a2,b2,temp)*cin_o2/tr + + end function iupac_ch3sch3 + +!--------------------------------------------------------------------- + +!- SAN: adding standard 3-body reaction using convention of MCM & IUPAC recommendations +! - Explicit form of TROE reactions +! Based on Atkinson et. al. 2004 + +REAL(KIND=dp) FUNCTION KMT_IUPAC(k0_300K,n,kinf_300K,m,Fc,temp,cair) + + INTRINSIC LOG10 + + REAL(KIND=dp), INTENT(IN) :: temp ! temperature [K] + REAL(KIND=dp), INTENT(IN) :: cair ! air concentration [molecules/cm3] + REAL(KIND=dp), INTENT(IN) :: k0_300K ! low pressure limit at 300 K + REAL(KIND=dp), INTENT(IN) :: n ! exponent for low pressure limit + !!! n.b. - remember to flip sign of exponents from IUPAC data sheets !!! + REAL(KIND=dp), INTENT(IN) :: kinf_300K ! high pressure limit at 300 K + REAL(KIND=dp), INTENT(IN) :: m ! exponent for high pressure limit + REAL(KIND=dp), INTENT(IN) :: Fc ! Approximate broadening factor + + REAL(KIND=dp) :: zt_help, k0_T, kinf_T, k_ratio, Nint, F_exp + + zt_help = 300._dp/temp + k0_T = k0_300K * zt_help**(n) * cair ! k_0 at current T + kinf_T = kinf_300K * zt_help**(m) ! k_inf at current T + k_ratio = k0_T/kinf_T + Nint = 0.75_dp - 1.27_dp*LOG10(Fc) + ! Calculate explicit broadening factor: + F_exp = Fc ** (1._dp / (1._dp + ( LOG10(k_ratio) / Nint )**2._dp ) ) + + KMT_IUPAC = k0_T/(1._dp+k_ratio) * F_exp + +END FUNCTION KMT_IUPAC + +!--------------------------------------------------------------------- + +!- SAN: Function for calculating NO + OH [+ M] 3-body reaction +!- Explicit form of TROE reaction with temperature dependent Fc + +REAL(KIND=dp) FUNCTION KMT_OH_NO(temp,cair) + + INTRINSIC LOG10 + + REAL(KIND=dp), INTENT(IN) :: temp ! temperature [K] + REAL(KIND=dp), INTENT(IN) :: cair ! air concentration [molecules/cm3] + + REAL(KIND=dp) :: k0_300K, n, kinf_300K, m, zt_help + REAL(KIND=dp) :: k0_T, kinf_T, k_ratio, Nint, Fc, F_exp + + k0_300K = 7.4D-31 ! low pressure limit at 300 K + n = 2.4_dp ! exponent for low pressure limit + kinf_300K = 3.3D-11 ! high pressure limit at 300 K + m = 0.3_dp ! exponent for high pressure limit + + zt_help = 300._dp/temp + k0_T = k0_300K * zt_help**(n) * cair ! k_0 at current T + kinf_T = kinf_300K * zt_help**(m) ! k_inf at current T + k_ratio = k0_T/kinf_T + + ! OH + NO [+ M] uses temperature dependent Fc: + Fc = exp(-temp / 1420._dp) + + Nint = 0.75_dp - 1.27_dp*LOG10(Fc) + + ! Calculate explicit broadening factor: + F_exp = Fc ** (1._dp / (1._dp + ( LOG10(k_ratio) / Nint )**2._dp ) ) + + KMT_OH_NO = k0_T/(1._dp+k_ratio) * F_exp + +END FUNCTION KMT_OH_NO + + + + +#ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.eqn b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.eqn new file mode 100644 index 00000000..b97900d3 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.eqn @@ -0,0 +1,638 @@ +#EQUATIONS {CRIMECH, check troe,troee, RJPL, RALKE, k46, k47, k48, RO2} +{001:J01} O3+hv=O1D{+O2} : j(Pj_o31d) ; +{002:J02} O3+hv=O3P{+O2} : j(Pj_o33p) ; +{003:J03} H2O2+hv=OH+OH : j(Pj_h2o2) ; +{004:J04} NO2+hv=NO+O3P : j(Pj_no2) ; +{005:J05} NO3+hv=NO : j(Pj_no3o2) ; +{006:J06} NO3+hv=NO2+O3P : j(Pj_no3o) ; +{007:J07} HONO+hv=OH+NO : j(Pj_hno2) ; +{008:J08} HNO3+hv=OH+NO2 : j(Pj_hno3) ; +{009:J09} HCHO+hv=CO+HO2+HO2 : j(Pj_ch2or) ; +{010:J10} HCHO+hv=CO : j(Pj_ch2om) ; +{011:J11} CH3CHO+hv=CH3OO+HO2+CO : 4.6D-4 * j(Pj_no2) ; +{012:J12} C2H5CHO+hv=C2H5O2+CO+HO2 : 4.19*4.6D-4 * j(Pj_no2) ; +{013:J13} CH3COCH3+hv=CH3CO3+CH3OO : 7.8D-5 * j(Pj_no2) ; +{014:J14} MEK+hv=CH3CO3+C2H5O2 : 7.047*7.8D-5 * j(Pj_no2) ; +{015:J15} CARB14+hv=CH3CO3+RN10O2 : 4.74*7.047*7.8D-5 * j(Pj_no2) ; +{016:J16} CARB17+hv=RN8O2+RN10O2 : 1.33*7.047*7.8D-5 * j(Pj_no2) ; +{017:J17} CARB11A+hv=CH3CO3+C2H5O2 : 7.047*7.8D-5 * j(Pj_no2) ; +{018:J18} CARB7+hv=CH3CO3+HCHO+HO2 : 7.047*7.8D-5 * j(Pj_no2) ; +{019:J19} CARB10+hv=CH3CO3+CH3CHO+HO2 : 7.047*7.8D-5 * j(Pj_no2) ; +{020:J20} CARB13+hv=RN8O2+CH3CHO+HO2 : 3.00*7.047*7.8D-5 * j(Pj_no2) ; +{021:J21} CARB16+hv=RN8O2+C2H5CHO+HO2 : 3.35*7.047*7.8D-5 * j(Pj_no2) ; +{022:J22} HOCH2CHO+hv=HCHO+CO+HO2+HO2 : 9.64_dp*j(pj_ch2or) ; +{023:J23} UCARB10+hv=CH3CO3+HCHO+HO2 : 2.0*1.9997*4.6D-4 * j(Pj_no2) ; +{024:J24} CARB3+hv=CO+CO+HO2+HO2 : 9.64_dp*j(pj_ch2or) ; +{025:J25} CARB6+hv=CH3CO3+CO+HO2 : 32.6088*4.6D-4 * j(Pj_no2); +{026:J26} CARB9+hv=CH3CO3+CH3CO3 : 2.149*32.6088*4.6D-4 * j(Pj_no2); +{027:J27} CARB12+hv=CH3CO3+RN8O2 : 2.149*32.6088*4.6D-4 * j(Pj_no2); +{028:J28} CARB15+hv=RN8O2+RN8O2 : 2.149*32.6088*4.6D-4 * j(Pj_no2); +{029:J29} UCARB12+hv=CH3CO3+HOCH2CHO+CO+HO2 : 2.0*1.9997*4.6D-4 * j(Pj_no2) ; +{030:J30} NUCARB12+hv=NOA+CO+CO+HO2+HO2 : 1.9997*4.6D-4 * j(Pj_no2) ; +{031:J31} NOA+hv=CH3CO3+HCHO+NO2 : 1.155*4.6D-4 * j(Pj_no2) + 0.4933*4.6D-4 * j(Pj_no2) ; +{032:J32} UDCARB8+hv=C2H5O2+HO2 : 0.02*j(Pj_no2) ; +{033:J33} UDCARB11+hv=RN10O2+HO2 : 0.02*j(Pj_no2) ; +{034:J34} UDCARB14+hv=RN13O2+HO2 : 0.02*j(Pj_no2) ; +{035:J35} TNCARB26+hv=RTN26O2+HO2 : 9.64_dp*j(pj_ch2or) ; +{036:J36} TNCARB10+hv=CH3CO3+CH3CO3+CO : 0.5*2.149*32.6088*4.6D-4 * j(Pj_no2); +{037:J37} CH3NO3+hv=HCHO+HO2+NO2 : 1.0D-4 * j(Pj_no2) ; +{038:J38} C2H5NO3+hv=CH3CHO+HO2+NO2 : 2.3248*7.8D-5 * j(Pj_no2) ; +{039:J39} RN10NO3+hv=C2H5CHO+HO2+NO2 : 3.079*7.8D-5 * j(Pj_no2) ; +{040:J40} IC3H7NO3+hv=CH3COCH3+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{041:J41} RN13NO3+hv= CH3CHO+C2H5O2+NO2 : 0.398*3.079*7.8D-5 * j(Pj_no2) ; +{042:J42} RN13NO3+hv= CARB11A+HO2+NO2 : 0.602*3.079*7.8D-5 * j(Pj_no2) ; +{043:J43} RN16NO3+hv=RN15O2+NO2 : 3.079*7.8D-5 * j(Pj_no2) ; +{044:J44} RN19NO3+hv=RN18O2+NO2 : 3.079*7.8D-5 * j(Pj_no2) ; +{045:J45} RA13NO3+hv=CARB3+UDCARB8+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{046:J46} RA16NO3+hv=CARB3+UDCARB11+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{047:J47} RA19NO3+hv=CARB6+UDCARB11+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{048:J48} RTX24NO3+hv=TXCARB22+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{049:J49} CH3OOH+hv=HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{050:J50} C2H5OOH+hv=CH3CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{051:J51} RN10OOH+hv=C2H5CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{052:J52} IC3H7OOH+hv=CH3COCH3+HO2+OH : 0.7 * j(Pj_h2o2) ; +{053:J53} RN13OOH+hv= CH3CHO+C2H5O2+OH : 0.398*0.7 * j(Pj_h2o2) ; +{054:J54} RN13OOH+hv= CARB11A+HO2+OH : 0.602*0.7 * j(Pj_h2o2) ; +{055:J55} RN16OOH+hv=RN15AO2+OH : 0.7 * j(Pj_h2o2) ; +{056:J56} RN19OOH+hv=RN18AO2+OH : 0.7 * j(Pj_h2o2) ; +{057:J57} CH3CO3H+hv=CH3OO+OH : 0.7 * j(Pj_h2o2) ; +{058:J58} C2H5CO3H+hv=C2H5O2+OH : 0.7 * j(Pj_h2o2) ; +{059:J59} HOCH2CO3H+hv=HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{060:J60} RN8OOH+hv=C2H5O2+OH : 0.7 * j(Pj_h2o2) ; +{061:J61} RN11OOH+hv=RN10O2+OH : 0.7 * j(Pj_h2o2) ; +{062:J62} RN14OOH+hv=RN13O2+OH : 0.7 * j(Pj_h2o2) ; +{063:J63} RN17OOH+hv=RN16O2+OH : 0.7 * j(Pj_h2o2) ; +{064:J64} RU14OOH+hv=UCARB12+HO2+OH : 0.252*0.7 * j(Pj_h2o2) ; +{065:J65} RU14OOH+hv=UCARB10+HCHO+HO2+OH : 0.748*0.7 * j(Pj_h2o2) ; +{066:J66} RU12OOH+hv=CARB6+HOCH2CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{067:J67} RU10OOH+hv=CH3CO3+HOCH2CHO+OH : 0.7 * j(Pj_h2o2) ; +{068:J68} NRU14OOH+hv=NUCARB12+HO2+OH : 0.7 * j(Pj_h2o2) ; +{069:J69} NRU12OOH+hv=NOA+CO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{070:J70} HOC2H4OOH+hv=HCHO+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{071:J71} RN9OOH+hv=CH3CHO+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{072:J72} RN12OOH+hv=CH3CHO+CH3CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{073:J73} RN15OOH+hv=C2H5CHO+CH3CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{074:J74} RN18OOH+hv=C2H5CHO+C2H5CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{075:J75} NRN6OOH+hv=HCHO+HCHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{076:J76} NRN9OOH+hv=CH3CHO+HCHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{077:J77} NRN12OOH+hv=CH3CHO+CH3CHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{078:J78} RA13OOH+hv=CARB3+UDCARB8+HO2+OH : 0.7 * j(Pj_h2o2) ; +{079:J79} RA16OOH+hv=CARB3+UDCARB11+HO2+OH : 0.7 * j(Pj_h2o2) ; +{080:J80} RA19OOH+hv=CARB6+UDCARB11+HO2+OH : 0.7 * j(Pj_h2o2) ; +{081:J81} RTN28OOH+hv=TNCARB26+HO2+OH : 0.7 * j(Pj_h2o2) ; +{082:J82} NRTN28OOH+hv=TNCARB26+NO2+OH : 0.7 * j(Pj_h2o2) ; +{083:J83} RTN26OOH+hv=RTN25O2+OH : 0.7 * j(Pj_h2o2) ; +{084:J84} RTN25OOH+hv=RTN24O2+OH : 0.7 * j(Pj_h2o2) ; +{085:J85} RTN24OOH+hv=RTN23O2+OH : 0.7 * j(Pj_h2o2) ; +{086:J86} RTN23OOH+hv=CH3COCH3+RTN14O2+OH : 0.7 * j(Pj_h2o2) ; +{087:J87} RTN14OOH+hv=TNCARB10+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{088:J88} RTN10OOH+hv=RN8O2+CO+OH : 0.7 * j(Pj_h2o2) ; +{089:J89} RTX28OOH+hv=TXCARB24+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{090:J90} RTX24OOH+hv=TXCARB22+HO2+OH : 0.7 * j(Pj_h2o2) ; +{091:J90} RTX22OOH+hv=CH3COCH3+RN13O2+OH : 0.7 * j(Pj_h2o2) ; +{092:J90} NRTX28OOH+hv=TXCARB24+HCHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{093:J90} UDCARB8+hv=ANHY+HO2+HO2 : 0.02*0.36*j(Pj_no2) ; +{094:J90} UDCARB11+hv=ANHY+HO2+CH3OO : 0.02*0.45*j(Pj_no2) ; +{095:J90} UDCARB14+hv=ANHY+HO2+C2H5O2 : 0.02*0.45*j(Pj_no2) ; +{096:001} O3P+M{+O2}=O3 : .20946e0*(C_M *6.00D-34*(TEMP/300)**(-2.6)); +{097:002} CH3O2NO2=CH3OO+NO2 : RJPL(1.3D-30,4.0_dp,7.5D-12,2.0_dp,C_M,TEMP)/(1.3D-28*exp(11200._dp/TEMP)); +{098:003} O3P+O3=M {2O2} : ARR2( 8.00D-12, 2060.0_dp, TEMP) ; +{099:004} O3P+NO=NO2 : TROE( 9.00D-32 , 1.5_dp , 3.00D-11 , 0.0_dp , TEMP, C_M) ; +{100:005} O3P+NO2=NO : ARR2( 5.50D-12, -188.0_dp, TEMP) ; +{101:006} O3P+NO2=NO3 : TROE( 9.00D-32 , 2.0_dp , 2.20D-11 , 0.0_dp , TEMP, C_M) ; +{102:007} O1D+M{=O2,N2} =O3P{+O2, N2} : .20946e0* ARR2( 3.20D-11, -70.0_dp, TEMP)+ .78084* ARR2( 1.80D-11, -110.0_dp, TEMP) ; +{103:008} NO+O3=NO2 : ARR2( 1.40D-12, 1310.0_dp, TEMP) ; +{104:009} NO2+O3=NO3 : ARR2( 1.40D-13, 2470.0_dp, TEMP) ; +{105:010} NO+NO+M{=O2}=NO2+NO2 : .20946e0* ARR2( 3.30D-39, -530.0_dp, TEMP) ; +{106:011} NO+NO3=NO2+NO2 : ARR2( 1.80D-11, -110.0_dp, TEMP) ; +{107:012} NO2+NO3=NO+NO2 : ARR2( 4.50D-14, 1260.0_dp, TEMP) ; +{108:013} NO2+NO3=N2O5 : TROE( 2.20D-30 , 3.9_dp , 1.50D-12 , 0.7_dp , TEMP, C_M) ; +{109:014} N2O5=NO3+NO2 : TROEE(3.70D26,11000.0_dp, 2.20D-30 , 3.9_dp , 1.50D-12 , 0.7_dp , TEMP, C_M ) ; +{110:015} O1D+H2O=OH+OH : 2.20D-10 ; +{111:016} OH+O3=HO2 : ARR2( 1.70D-12, 940.0_dp, TEMP) ; +{112:017} OH+M = HO2+H2O : 5.31D-7*ARR2( 7.70D-12, 2100.0_dp, TEMP) ; +{113:018} OH+CO=HO2 : 1.20D-13*(1.0 + ((0.6*C_M)/(2.652d+19*(273.0/temp)))) ; +{114:019} OH+H2O2=HO2 : ARR2( 2.90D-12, 160.0_dp, TEMP) ; +{115:020} HO2+O3=OH : 2.03D-16*((TEMP/300)**4.57)*EXP(693/TEMP) ; +{116:021} OH+HO2=H2O{+O2} : ARR2( 4.80D-11, -250.0_dp, TEMP) ; +{117:022} HO2+HO2=H2O2 : (2.2D-13*EXP(600./TEMP) + 1.9D-33* C_M *EXP(980._dp/TEMP)) ; +{118:023} HO2+HO2+H2O=H2O2 : (3.08D-34* EXP(2800._dp/TEMP)+ 2.66D-54* C_M *EXP(3180._dp/TEMP)) ; +{119:024} OH+NO=HONO : KMT_OH_NO( TEMP, C_M) ; +{120:025} OH+NO2=HNO3 : TROE( 2.60D-30 , 3.2_dp , 2.40D-11 , 1.3_dp , TEMP, C_M) ; +{121:026} OH+NO3=HO2+NO2 : 2.00D-11 ; +{122:027} HO2+NO=OH+NO2 : ARR2( 3.60D-12, -270.0_dp, TEMP) ; +{123:028} HO2+NO2=HNO4 : TROE( 1.80D-31 , 3.2_dp , 4.70D-12 , 1.4_dp , TEMP, C_M) ; +{124:029} HNO4=NO2+HO2 : TROEE( 4.76D26,10900.0_dp, 1.80D-31 , 3.2_dp , 4.70D-12 , 1.4_dp , TEMP, C_M ) ; +{125:030} OH+HNO4=NO2 : ARR2( 1.90D-12, -270.0_dp, TEMP) ; +{126:031} HO2+NO3=OH+NO2 : 4.00D-12 ; +{127:032} OH+HONO=NO2 : ARR2( 2.50D-12, -260.0_dp, TEMP) ; +{128:033} OH+HNO3=NO3 : k46(TEMP,C_M) ; +{129:034} O3P+SO2=SO3 : C_M*ARR2( 4.00D-32, 1000.0_dp, TEMP) ; +{130:035} OH+SO2=HSO3 : K47(TEMP,C_M) ; +{131:036} HSO3+M{=O2}=HO2+SO3 : .20946e0* ARR2( 1.30D-12, -330.0_dp, TEMP) ; +{134:039} SO3 + H2O + H2O = H2SO4 : ARR2(3.9d-41,-6830.6_dp,TEMP) ; {Jayne et al (1997) rate} +{135:040} OH+CH4=CH3OO : 9.65D-20*TEMP**2.58*EXP(-1082/TEMP) ; +{136:041} OH+C2H6=C2H5O2 : 1.52D-17*TEMP**2*EXP(-498/TEMP) ; +{137:042} OH+C3H8=IC3H7O2 : 1.55D-17*TEMP**2*EXP(-61/TEMP)*0.736 ; +{138:043} OH+C3H8=RN10O2 : 1.55D-17*TEMP**2*EXP(-61/TEMP)*0.264 ; +{139:044} OH+NC4H10=RN13O2 : 1.69D-17*TEMP**2*EXP(145/TEMP) ; +{140:045} OH+C2H4=HOCH2CH2O2 : KMT_IUPAC(8.6D-29, 3.1_dp, 9.0D-12, 0.85_dp, 0.48_dp, TEMP,C_M) ; +{141:046} OH+C3H6=RN9O2 : KMT_IUPAC(8.0D-27, 3.5_dp, 3.0D-11, 1.0_dp, 0.5_dp, TEMP,C_M) ; +{142:047} OH+TBUT2ENE=RN12O2 : ARR2( 1.01D-11, -550.0_dp, TEMP) ; +{143:048} NO3+C2H4=NRN6O2 : 2.10D-16 ; +{144:049} NO3+C3H6=NRN9O2 : 9.40D-15 ; +{145:050} NO3+TBUT2ENE=NRN12O2 : 3.90D-13 ; +{146:051} O3+C2H4=HCHO+CO+HO2+OH : 0.13*ARR2( 9.14D-15, 2580.0_dp, TEMP) ; +{147:052} O3+C2H4=HCHO+HCOOH : 0.87*ARR2( 9.14D-15, 2580.0_dp, TEMP) ; +{148:053} O3+C3H6=HCHO+CO+CH3OO+OH : 0.36*ARR2( 5.51D-15, 1878.0_dp, TEMP) ; +{149:054} O3+C3H6=HCHO+CH3CO2H : 0.64*ARR2( 5.51D-15, 1878.0_dp, TEMP) ; +{150:055} O3+TBUT2ENE=CH3CHO+CO+CH3OO+OH : 0.69*ARR2( 6.64D-15, 1059.0_dp, TEMP) ; +{151:056} O3+TBUT2ENE=CH3CHO+CH3CO2H : 0.31*ARR2( 6.64D-15, 1059.0_dp, TEMP) ; +{152:057} OH+C5H8=RU14O2 : ARR2( 2.54D-11, -410.0_dp, TEMP) ; +{153:058} NO3+C5H8=NRU14O2 : ARR2( 3.03D-12, 446.0_dp, TEMP) ; +{154:059} O3+C5H8=UCARB10+CO+HO2+OH : 0.27*ARR2( 7.86D-15, 1913.0_dp, TEMP) ; +{155:060} O3+C5H8=UCARB10+HCOOH : 0.73*ARR2( 7.86D-15, 1913.0_dp, TEMP) ; +{156:061} APINENE+OH=RTN28O2 : ARR2( 1.20D-11, -444.0_dp, TEMP) ; +{157:062} APINENE+NO3=NRTN28O2 : ARR2( 1.19D-12, -490.0_dp, TEMP) ; +{158:063} APINENE+O3=OH+CH3COCH3+RN18AO2 : 0.80*ARR2( 1.01D-15, 732.0_dp, TEMP) ; +{159:064} APINENE+O3=TNCARB26+H2O2 : 0.075*ARR2( 1.01D-15, 732.0_dp, TEMP) ; +{160:065} APINENE+O3=RCOOH25 : 0.125*ARR2( 1.01D-15, 732.0_dp, TEMP) ; +{161:066} BPINENE+OH=RTX28O2 : ARR2( 2.38D-11, -357.0_dp, TEMP) ; +{162:067} BPINENE+NO3=NRTX28O2 : 2.51D-12 ; +{163:068} BPINENE+O3= RTX24O2+OH : 1.50D-17*0.35 ; +{164:069} BPINENE+O3= HCHO+TXCARB24+H2O2 : 1.50D-17*0.20 ; +{165:070} BPINENE+O3= HCHO+TXCARB22 : 1.50D-17*0.25 ; +{166:071} BPINENE+O3= TXCARB24+CO : 1.50D-17*0.20 ; +{167:072} C2H2+OH=HCOOH+CO+HO2 : 0.364*KMT_IUPAC(5.0D-30, 1.5_dp, 1.0D-12, 0.0_dp, 0.37_dp, TEMP,C_M) ; +{168:073} C2H2+OH=CARB3+OH : 0.636*KMT_IUPAC(5.0D-30, 1.5_dp, 1.0D-12, 0.0_dp, 0.37_dp, TEMP,C_M) ; +{169:074} BENZENE+OH=RA13O2 : 0.47*ARR2( 2.33D-12, 193.0_dp, TEMP) ; +{170:075} BENZENE+OH=AROH14+HO2 : 0.53*ARR2( 2.33D-12, 193.0_dp, TEMP) ; +{171:076} TOLUENE+OH=RA16O2 : 0.82*ARR2( 1.81D-12, -338.0_dp, TEMP) ; +{172:077} TOLUENE+OH=AROH17+HO2 : 0.18*ARR2( 1.81D-12, -338.0_dp, TEMP) ; +{173:078} OXYL+OH=RA19AO2 : 1.36D-11*0.70 ; +{174:079} OXYL+OH=RA19CO2 : 1.36D-11*0.30 ; +{175:080} OH+HCHO=HO2+CO : 1.20D-14*TEMP*EXP(287/TEMP) ; +{176:081} OH+CH3CHO=CH3CO3 : ARR2( 5.55D-12, -311.0_dp, TEMP) ; +{177:082} OH+C2H5CHO=C2H5CO3 : 1.96D-11 ; +{178:083} NO3+HCHO=HO2+CO+HNO3 : 5.80D-16 ; +{179:084} NO3+CH3CHO=CH3CO3+HNO3 : 1.44d-12*EXP(-1862.0/temp) ; +{180:085} NO3+C2H5CHO=C2H5CO3+HNO3 : 1.44d-12*EXP(-1862.0/temp)*2.4 ; +{181:086} OH+CH3COCH3=RN8O2 : 5.34D-18*TEMP**2*EXP(-230/TEMP) ; +{182:087} MEK+OH=RN11O2 : 3.24D-18*TEMP**2*EXP(414/TEMP) ; +{183:088} OH+CH3OH=HO2+HCHO : 6.01D-18*TEMP**2*EXP(170/TEMP) ; +{184:089} OH+C2H5OH=CH3CHO+HO2 : 6.18D-18*TEMP**2*EXP(532/TEMP)*0.887 ; +{185:090} OH+C2H5OH=HOCH2CH2O2 : 6.18D-18*TEMP**2*EXP(532/TEMP)*0.113 ; +{186:091} NPROPOL+OH=C2H5CHO+HO2 : 5.53D-12*0.49 ; +{187:092} NPROPOL+OH=RN9O2 : 5.53D-12*0.51 ; +{188:093} OH+IPROPOL=CH3COCH3+HO2 : 4.06D-18*TEMP**2*EXP(788/TEMP)*0.86 ; +{189:094} OH+IPROPOL=RN9O2 : 4.06D-18*TEMP**2*EXP(788/TEMP)*0.14 ; +{190:095} HCOOH+OH=HO2 : 4.50D-13 ; +{191:096} CH3CO2H+OH=CH3OO : 8.00D-13 ; +{192:097} CH3OO+NO=HCHO+HO2+NO2 : 0.999*ARR2( 3.00D-12, -280.0_dp, TEMP) ; +{193:098} C2H5O2+NO=CH3CHO+HO2+NO2 : 0.991*ARR2( 2.60D-12, -365.0_dp, TEMP) ; +{194:099} RN10O2+NO=C2H5CHO+HO2+NO2 : 0.980*ARR2( 2.80D-12, -360.0_dp, TEMP) ; +{195:100} IC3H7O2+NO=CH3COCH3+HO2+NO2 : 0.958*ARR2( 2.70D-12, -360.0_dp, TEMP) ; +{196:101} RN13O2+NO=CH3CHO+C2H5O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.917*0.398 ; +{197:102} RN13O2+NO=CARB11A+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.917*0.602 ; +{198:103} RN16O2+NO=RN15AO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.877 ; +{199:104} RN19O2+NO=RN18AO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.788 ; +{200:105} RN13AO2+NO=RN12O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{201:106} RN16AO2+NO=RN15O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{202:107} RA13O2+NO=CARB3+UDCARB8+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.918 ; +{203:108} RA16O2+NO=CARB3+UDCARB11+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.889*0.7 ; +{204:109} RA16O2+NO=CARB6+UDCARB8+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.889*0.3 ; +{205:110} RA19AO2+NO=CARB3+UDCARB14+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.862 ; +{206:111} RA19CO2+NO=CARB9+UDCARB8+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.862 ; +{207:112} HOCH2CH2O2+NO=HCHO+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.995*0.776 ; +{208:113} HOCH2CH2O2+NO=HOCH2CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.995*0.224 ; +{209:114} RN9O2+NO=CH3CHO+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.979 ; +{210:115} RN12O2+NO=CH3CHO+CH3CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.959 ; +{211:116} RN15O2+NO=C2H5CHO+CH3CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.936 ; +{212:117} RN18O2+NO=C2H5CHO+C2H5CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.903 ; +{213:118} RN15AO2+NO=CARB13+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.975 ; +{214:119} RN18AO2+NO=CARB16+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.946 ; +{215:120} CH3CO3+NO=CH3OO+NO2 : 8.10d-12*EXP(270.0/temp) ; +{216:121} C2H5CO3+NO=C2H5O2+NO2 : 8.10d-12*EXP(270.0/temp) ; +{217:122} HOCH2CO3+NO=HO2+HCHO+NO2 : 8.10d-12*EXP(270.0/temp) ; +{218:123} RN8O2+NO=CH3CO3+HCHO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{219:124} RN11O2+NO=CH3CO3+CH3CHO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{220:125} RN14O2+NO=C2H5CO3+CH3CHO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{221:126} RN17O2+NO=RN16AO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{222:127} RU14O2+NO=UCARB12+HO2+ NO2 : 2.40d-12*EXP(360.0/temp)*0.900*0.252 ; +{223:128} RU14O2+NO=UCARB10+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.900*0.748 ; +{224:129} RU12O2+NO=CH3CO3+HOCH2CHO+NO2 : 2.40d-12*EXP(360.0/temp)*0.7 ; +{225:130} RU12O2+NO=CARB7+CO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.3 ; +{226:131} RU10O2+NO=CH3CO3+HOCH2CHO+NO2 : 2.40d-12*EXP(360.0/temp)*0.5 ; +{227:132} RU10O2+NO=CARB6+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.3 ; +{228:133} RU10O2+NO=CARB7+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.2 ; +{229:134} NRN6O2+NO=HCHO+HCHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{230:135} NRN9O2+NO=CH3CHO+HCHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{231:136} NRN12O2+NO=CH3CHO+CH3CHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{232:137} NRU14O2+NO=NUCARB12+HO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{233:138} NRU12O2+NO=NOA+CO+HO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{234:139} RTN28O2+NO=TNCARB26+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.915 ; +{235:140} RTN28O2+NO=CH3COCH3+RN19O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.085 ; +{236:141} NRTN28O2+NO=TNCARB26+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{237:142} RTN26O2+NO=RTN25O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{238:143} RTN25O2+NO=RTN24O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.840 ; +{239:144} RTN24O2+NO=RTN23O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{240:145} RTN23O2+NO=CH3COCH3+RTN14O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{241:146} RTN14O2+NO=HCHO+TNCARB10+HO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{242:147} RTN10O2+NO=RN8O2+CO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{243:148} RTX28O2+NO=TXCARB24+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.915 ; +{244:149} RTX28O2+NO=CH3COCH3+RN19O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.085 ; +{245:150} NRTX28O2+NO=TXCARB24+HCHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{246:151} RTX24O2+NO=TXCARB22+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.843*0.6 ; +{247:152} RTX24O2+NO=CH3COCH3+RN13AO2+HCHO+NO2 : 2.40d-12*EXP(360.0/temp)*0.843*0.4 ; +{248:153} RTX22O2+NO=CH3COCH3+RN13O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.700 ; +{249:154} CH3OO+NO=CH3NO3 : 0.001*ARR2( 3.00D-12, -280.0_dp, TEMP) ; +{250:155} C2H5O2+NO=C2H5NO3 : 0.009*ARR2( 2.60D-12, -365.0_dp, TEMP) ; +{251:156} RN10O2+NO=RN10NO3 : 0.020*ARR2( 2.80D-12, -360.0_dp, TEMP) ; +{252:157} IC3H7O2+NO=IC3H7NO3 : 0.042*ARR2( 2.70D-12, -360.0_dp, TEMP) ; +{253:158} RN13O2+NO=RN13NO3 : 2.40d-12*EXP(360.0/temp)*0.083 ; +{254:159} RN16O2+NO=RN16NO3 : 2.40d-12*EXP(360.0/temp)*0.123 ; +{255:160} RN19O2+NO=RN19NO3 : 2.40d-12*EXP(360.0/temp)*0.212 ; +{256:161} HOCH2CH2O2+NO=HOC2H4NO3 : 2.40d-12*EXP(360.0/temp)*0.005 ; +{257:162} RN9O2+NO=RN9NO3 : 2.40d-12*EXP(360.0/temp)*0.021 ; +{258:163} RN12O2+NO=RN12NO3 : 2.40d-12*EXP(360.0/temp)*0.041 ; +{259:164} RN15O2+NO=RN15NO3 : 2.40d-12*EXP(360.0/temp)*0.064 ; +{260:165} RN18O2+NO=RN18NO3 : 2.40d-12*EXP(360.0/temp)*0.097 ; +{261:166} RN15AO2+NO=RN15NO3 : 2.40d-12*EXP(360.0/temp)*0.025 ; +{262:167} RN18AO2+NO=RN18NO3 : 2.40d-12*EXP(360.0/temp)*0.054 ; +{263:168} RU14O2+NO=RU14NO3 : 2.40d-12*EXP(360.0/temp)*0.100 ; +{264:169} RA13O2+NO=RA13NO3 : 2.40d-12*EXP(360.0/temp)*0.082 ; +{265:170} RA16O2+NO=RA16NO3 : 2.40d-12*EXP(360.0/temp)*0.111 ; +{266:171} RA19AO2+NO=RA19NO3 : 2.40d-12*EXP(360.0/temp)*0.138 ; +{267:172} RA19CO2+NO=RA19NO3 : 2.40d-12*EXP(360.0/temp)*0.138 ; +{268:173} RTN28O2+NO=RTN28NO3 : 2.40d-12*EXP(360.0/temp)*0.233 ; +{269:174} RTN25O2+NO=RTN25NO3 : 2.40d-12*EXP(360.0/temp)*0.160 ; +{270:175} RTX28O2+NO=RTX28NO3 : 2.40d-12*EXP(360.0/temp)*0.233 ; +{271:176} RTX24O2+NO=RTX24NO3 : 2.40d-12*EXP(360.0/temp)*0.157 ; +{272:177} RTX22O2+NO=RTX22NO3 : 2.40d-12*EXP(360.0/temp)*0.300 ; +{273:178} CH3OO+NO3=HCHO+HO2+NO2 : 2.50d-12*0.40 ; +{274:179} C2H5O2+NO3=CH3CHO+HO2+NO2 : 2.50d-12 ; +{275:180} RN10O2+NO3=C2H5CHO+HO2+NO2 : 2.50d-12 ; +{276:181} IC3H7O2+NO3=CH3COCH3+HO2+NO2 : 2.50d-12 ; +{277:182} RN13O2+NO3=CH3CHO+C2H5O2+NO2 : 2.50d-12*0.398 ; +{278:183} RN13O2+NO3=CARB11A+HO2+NO2 : 2.50d-12*0.602 ; +{279:184} RN16O2+NO3=RN15AO2+NO2 : 2.50d-12 ; +{280:185} RN19O2+NO3=RN18AO2+NO2 : 2.50d-12 ; +{281:186} RN13AO2+NO3=RN12O2+NO2 : 2.50d-12 ; +{282:187} RN16AO2+NO3=RN15O2+NO2 : 2.50d-12 ; +{283:188} RA13O2+NO3=CARB3+UDCARB8+HO2+NO2 : 2.50d-12 ; +{284:189} RA16O2+NO3=CARB3+UDCARB11+HO2+NO2 : 2.50d-12*0.7 ; +{285:190} RA16O2+NO3=CARB6+UDCARB8+HO2+NO2 : 2.50d-12*0.3 ; +{286:191} RA19AO2+NO3=CARB3+UDCARB14+HO2+NO2 : 2.50d-12 ; +{287:192} RA19CO2+NO3=CARB9+UDCARB8+HO2+NO2 : 2.50d-12 ; +{288:193} HOCH2CH2O2+NO3=HCHO+HCHO+HO2+NO2 : 2.50d-12*0.776 ; +{289:194} HOCH2CH2O2+NO3=HOCH2CHO+HO2+NO2 : 2.50d-12*0.224 ; +{290:195} RN9O2+NO3=CH3CHO+HCHO+HO2+NO2 : 2.50d-12 ; +{291:196} RN12O2+NO3=CH3CHO+CH3CHO+HO2+NO2 : 2.50d-12 ; +{292:197} RN15O2+NO3=C2H5CHO+CH3CHO+HO2+NO2 : 2.50d-12 ; +{293:198} RN18O2+NO3=C2H5CHO+C2H5CHO+HO2+NO2 : 2.50d-12; +{294:199} RN15AO2+NO3=CARB13+HO2+NO2 : 2.50d-12 ; +{295:200} RN18AO2+NO3=CARB16+HO2+NO2 : 2.50d-12 ; +{296:201} CH3CO3+NO3=CH3OO+NO2 : 2.50d-12*1.60 ; +{297:202} C2H5CO3+NO3=C2H5O2+NO2 : 2.50d-12*1.60 ; +{298:203} HOCH2CO3+NO3=HO2+HCHO+NO2 : 2.50d-12*1.60 ; +{299:204} RN8O2+NO3=CH3CO3+HCHO+NO2 : 2.50d-12 ; +{300:205} RN11O2+NO3=CH3CO3+CH3CHO+NO2 : 2.50d-12 ; +{301:206} RN14O2+NO3=C2H5CO3+CH3CHO+NO2 : 2.50d-12 ; +{302:207} RN17O2+NO3=RN16AO2+NO2 : 2.50d-12 ; +{303:208} RU14O2+NO3=UCARB12+HO2+NO2 : 2.50d-12*0.252 ; +{304:209} RU14O2+NO3=UCARB10+HCHO+HO2+NO2 : 2.50d-12*0.748 ; +{305:210} RU12O2+NO3=CH3CO3+HOCH2CHO+NO2 : 2.50d-12*0.7 ; +{306:211} RU12O2+NO3=CARB7+CO+HO2+NO2 : 2.50d-12*0.3 ; +{307:212} RU10O2+NO3=CH3CO3+HOCH2CHO+NO2 : 2.50d-12*0.5 ; +{308:213} RU10O2+NO3=CARB6+HCHO+HO2+NO2 : 2.50d-12*0.3 ; +{309:214} RU10O2+NO3=CARB7+HCHO+HO2+NO2 : 2.50d-12*0.2 ; +{310:215} NRN6O2+NO3=HCHO+HCHO+NO2+NO2 : 2.50d-12 ; +{311:216} NRN9O2+NO3=CH3CHO+HCHO+NO2+NO2 : 2.50d-12 ; +{312:217} NRN12O2+NO3=CH3CHO+CH3CHO+NO2+NO2 : 2.50d-12 ; +{313:218} NRU14O2+NO3=NUCARB12+HO2+NO2 : 2.50d-12 ; +{314:219} NRU12O2+NO3=NOA+CO+HO2+NO2 : 2.50d-12 ; +{315:220} RTN28O2+NO3=TNCARB26+HO2+NO2 : 2.50d-12 ; +{316:221} NRTN28O2+NO3=TNCARB26+NO2+NO2 : 2.50d-12 ; +{317:222} RTN26O2+NO3=RTN25O2+NO2 : 2.50d-12 ; +{318:223} RTN25O2+NO3=RTN24O2+NO2 : 2.50d-12 ; +{319:224} RTN24O2+NO3=RTN23O2+NO2 : 2.50d-12 ; +{320:225} RTN23O2+NO3=CH3COCH3+RTN14O2+NO2 : 2.50d-12 ; +{321:226} RTN14O2+NO3=HCHO+TNCARB10+HO2+NO2 : 2.50d-12 ; +{322:227} RTN10O2+NO3=RN8O2+CO+NO2 : 2.50d-12 ; +{323:228} RTX28O2+NO3=TXCARB24+HCHO+HO2+NO2 : 2.50d-12 ; +{324:229} RTX24O2+NO3=TXCARB22+HO2+NO2 : 2.50d-12 ; +{325:230} RTX22O2+NO3=CH3COCH3+RN13O2+NO2 : 2.50d-12 ; +{326:231} NRTX28O2+NO3=TXCARB24+HCHO+NO2+NO2 : 2.50d-12 ; +{327:232} CH3OO+HO2=CH3OOH : ARR2( 3.80D-13, -780.0_dp, TEMP) ; +{328:233} C2H5O2+HO2=C2H5OOH : ARR2( 7.50D-13, -700.0_dp, TEMP) ; +{329:234} RN10O2+HO2=RN10OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{330:235} IC3H7O2+HO2=IC3H7OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{331:236} RN13O2+HO2=RN13OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{332:237} RN16O2+HO2=RN16OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{333:238} RN19O2+HO2=RN19OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{334:239} RN13AO2+HO2=RN13OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{335:240} RN16AO2+HO2=RN16OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{336:241} RA13O2+HO2=RA13OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{337:242} RA16O2+HO2=RA16OOH : 0.820*2.91d-13*EXP(1300.0/temp) ; +{338:243} RA19AO2+HO2=RA19OOH : 0.859*2.91d-13*EXP(1300.0/temp) ; +{339:244} RA19CO2+HO2=RA19OOH : 0.859*2.91d-13*EXP(1300.0/temp) ; +{340:245} HOCH2CH2O2+HO2=HOC2H4OOH : ARR2( 2.03D-13, -1250.0_dp, TEMP) ; +{341:246} RN9O2+HO2=RN9OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{342:247} RN12O2+HO2=RN12OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{343:248} RN15O2+HO2=RN15OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{344:249} RN18O2+HO2=RN18OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{345:250} RN15AO2+HO2=RN15OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{346:251} RN18AO2+HO2=RN18OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{347:252} CH3CO3+HO2=CH3CO3H : 4.30d-13*EXP(1040.0/temp) ; +{348:253} C2H5CO3+HO2=C2H5CO3H : 4.30d-13*EXP(1040.0/temp) ; +{349:254} HOCH2CO3+HO2=HOCH2CO3H : 4.30d-13*EXP(1040.0/temp) ; +{350:255} RN8O2+HO2=RN8OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{351:256} RN11O2+HO2=RN11OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{352:257} RN14O2+HO2=RN14OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{353:258} RN17O2+HO2=RN17OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{354:258} RU14O2+HO2=RU14OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{355:260} RU12O2+HO2=RU12OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{356:261} RU10O2+HO2=RU10OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{357:262} NRN6O2+HO2=NRN6OOH : 0.387*2.91d-13*EXP(1300.0/temp) ; +{358:263} NRN9O2+HO2=NRN9OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{359:264} NRN12O2+HO2=NRN12OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{360:265} NRU14O2+HO2=NRU14OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{361:266} NRU12O2+HO2=NRU12OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{362:267} RTN28O2+HO2=RTN28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{363:268} NRTN28O2+HO2=NRTN28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{364:269} RTN26O2+HO2=RTN26OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{365:270} RTN25O2+HO2=RTN25OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{366:271} RTN24O2+HO2=RTN24OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{367:272} RTN23O2+HO2=RTN23OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{368:273} RTN14O2+HO2=RTN14OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{369:274} RTN10O2+HO2=RTN10OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{370:275} RTX28O2+HO2=RTX28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{371:276} RTX24O2+HO2=RTX24OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{372:277} RTX22O2+HO2=RTX22OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{373:278} NRTX28O2+HO2=NRTX28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{374:279} CH3OO=HCHO+HO2 : 0.33*RO2*ARR2( 1.82D-13, -416.0_dp, TEMP) ; +{375:280} CH3OO=HCHO : 0.335*RO2*ARR2( 1.82D-13, -416.0_dp, TEMP) ; +{376:281} CH3OO=CH3OH : 0.335*RO2*ARR2( 1.82D-13, -416.0_dp, TEMP) ; +{377:282} C2H5O2=CH3CHO+HO2 : 3.10D-13*0.6*RO2 ; +{378:283} C2H5O2=CH3CHO : 3.10D-13*0.2*RO2 ; +{379:284} C2H5O2=C2H5OH : 3.10D-13*0.2*RO2 ; +{380:285} RN10O2=C2H5CHO+HO2 : 6.00D-13*0.6*RO2 ; +{381:286} RN10O2=C2H5CHO : 6.00D-13*0.2*RO2 ; +{382:287} RN10O2=NPROPOL : 6.00D-13*0.2*RO2 ; +{383:288} IC3H7O2=CH3COCH3+HO2 : 4.00D-14*0.6*RO2 ; +{384:289} IC3H7O2=CH3COCH3 : 4.00D-14*0.2*RO2 ; +{385:290} IC3H7O2=IPROPOL : 4.00D-14*0.2*RO2 ; +{386:291} RN13O2=CH3CHO+C2H5O2 : 2.50D-13*RO2*0.398 ; +{387:292} RN13O2=CARB11A+HO2 : 2.50D-13*RO2*0.602 ; +{388:293} RN13AO2=RN12O2 : 8.80D-13*RO2 ; +{389:294} RN16AO2=RN15O2 : 8.80D-13*RO2 ; +{390:295} RA13O2=CARB3+UDCARB8+HO2 : 8.80D-13*RO2 ; +{391:296} RA16O2=CARB3+UDCARB11+HO2 : 8.80D-13*RO2*0.7 ; +{392:297} RA16O2=CARB6+UDCARB8+HO2 : 8.80D-13*RO2*0.3 ; +{393:298} RA19AO2=CARB3+UDCARB14+HO2 : 8.80D-13*RO2 ; +{394:299} RA19CO2=CARB3+UDCARB14+HO2 : 8.80D-13*RO2 ; +{395:300} RN16O2=RN15AO2 : 2.50D-13*RO2 ; +{396:301} RN19O2=RN18AO2 : 2.50D-13*RO2 ; +{397:302} HOCH2CH2O2=HCHO+HCHO+HO2 : 2.00D-12*RO2*0.776 ; +{398:303} HOCH2CH2O2=HOCH2CHO+HO2 : 2.00D-12*RO2*0.224 ; +{399:304} RN9O2=CH3CHO+HCHO+HO2 : 8.80D-13*RO2 ; +{400:305} RN12O2=CH3CHO+CH3CHO+HO2 : 8.80D-13*RO2 ; +{401:306} RN15O2=C2H5CHO+CH3CHO+HO2 : 8.80D-13*RO2 ; +{402:307} RN18O2=C2H5CHO+C2H5CHO+HO2 : 8.80D-13*RO2 ; +{403:308} RN15AO2=CARB13+HO2 : 8.80D-13*RO2 ; +{404:309} RN18AO2=CARB16+HO2 : 8.80D-13*RO2 ; +{405:310} CH3CO3=CH3OO : 1.00D-11*RO2 ; +{406:311} C2H5CO3=C2H5O2 : 1.00D-11*RO2 ; +{407:312} HOCH2CO3=HCHO+HO2 : 1.00D-11*RO2 ; +{408:313} RN8O2=CH3CO3+HCHO : 1.40D-12*RO2 ; +{409:314} RN11O2=CH3CO3+CH3CHO : 1.40D-12*RO2 ; +{410:315} RN14O2=C2H5CO3+CH3CHO : 1.40D-12*RO2 ; +{411:316} RN17O2=RN16AO2 : 1.40D-12*RO2 ; +{412:317} RU14O2=UCARB12+HO2 : 1.71D-12*RO2*0.252 ; +{413:318} RU14O2=UCARB10+HCHO+HO2 : 1.71D-12*RO2*0.748 ; +{414:319} RU12O2=CH3CO3+HOCH2CHO : 2.00D-12*RO2*0.7 ; +{415:320} RU12O2=CARB7+HOCH2CHO+HO2 : 2.00D-12*RO2*0.3 ; +{416:321} RU10O2=CH3CO3+HOCH2CHO : 2.00D-12*RO2*0.5 ; +{417:322} RU10O2=CARB6+HCHO+HO2 : 2.00D-12*RO2*0.3 ; +{418:323} RU10O2=CARB7+HCHO+HO2 : 2.00D-12*RO2*0.2 ; +{419:324} NRN6O2=HCHO+HCHO+NO2 : 6.00D-13*RO2 ; +{420:325} NRN9O2=CH3CHO+HCHO+NO2 : 2.30D-13*RO2 ; +{421:326} NRN12O2=CH3CHO+CH3CHO+NO2 : 2.50D-13*RO2 ; +{422:327} NRU14O2=NUCARB12+HO2 : 1.30D-12*RO2 ; +{423:328} NRU12O2=NOA+CO+HO2 : 9.60D-13*RO2 ; +{424:329} RTN28O2=TNCARB26+HO2 : 2.85D-13*RO2 ; +{425:330} NRTN28O2=TNCARB26+NO2 : 1.00D-13*RO2 ; +{426:331} RTN26O2=RTN25O2 : 2.00D-12*RO2 ; +{427:332} RTN25O2=RTN24O2 : 1.30D-12*RO2 ; +{428:333} RTN24O2=RTN23O2 : 6.70D-15*RO2 ; +{429:334} RTN23O2=CH3COCH3+RTN14O2 : 6.70D-15*RO2 ; +{430:335} RTN14O2=HCHO+TNCARB10+HO2 : 8.80D-13*RO2 ; +{431:336} RTN10O2=RN8O2+CO : 2.00D-12*RO2 ; +{432:337} RTX28O2=TXCARB24+HCHO+HO2 : 2.00D-12*RO2 ; +{433:338} RTX24O2=TXCARB22+HO2 : 2.50D-13*RO2 ; +{434:339} RTX22O2=CH3COCH3+RN13O2 : 2.50D-13*RO2 ; +{435:340} NRTX28O2=TXCARB24+HCHO+NO2 : 9.20D-14*RO2 ; +{436:341} OH+CARB14=RN14O2 : 1.87D-11 ; +{437:342} OH+CARB17=RN17O2 : 4.36D-12 ; +{438:343} OH+CARB11A=RN11O2 : 3.24D-18*TEMP**2*EXP(414/TEMP) ; +{439:344} OH+CARB7=CARB6+HO2 : 3.00D-12 ; +{440:345} OH+CARB10=CARB9+HO2 : 5.86D-12 ; +{441:346} OH+CARB13=RN13O2 : 1.65D-11 ; +{442:347} OH+CARB16=RN16O2 : 1.25D-11 ; +{443:348} OH+UCARB10=RU10O2 : 2.50D-11 ; +{444:349} NO3+UCARB10=RU10O2+HNO3 : 1.44d-12*EXP(-1862.0/temp) ; +{445:350} O3+UCARB10=HCHO+CH3CO3+CO+OH : 2.85D-18*0.59 ; +{446:351} O3+UCARB10=HCHO+CARB6+H2O2 : 2.85D-18*0.41 ; +{447:352} OH+HOCH2CHO=HOCH2CO3 : 1.00D-11 ; +{448:353} NO3+HOCH2CHO=HOCH2CO3+HNO3 : 1.44d-12*EXP(-1862.0/temp) ; +{449:354} OH+CARB3=CO+CO+HO2 : 1.14D-11 ; +{450:355} OH+CARB6=CH3CO3+CO : 1.72D-11 ; +{451:356} OH+CARB9=RN9O2 : 2.40D-13 ; +{452:357} OH+CARB12=RN12O2 : 1.38D-12 ; +{453:358} OH+CARB15=RN15O2 : 4.81D-12 ; +{454:359} OH+CCARB12=RN12O2 : 4.79D-12 ; +{455:360} OH+UCARB12=RU12O2 : 4.52D-11 ; +{456:361} NO3+UCARB12=RU12O2+HNO3 : 1.44d-12*EXP(-1862.0/temp)*4.25 ; +{457:362} O3+UCARB12=HOCH2CHO+CH3CO3+CO+OH : 2.40D-17*0.89 ; +{458:363} O3+UCARB12=HOCH2CHO+CARB6+H2O2 : 2.40D-17*0.11 ; +{459:364} OH+NUCARB12=NRU12O2 : 4.16D-11 ; +{460:365} OH+NOA=CARB6+NO2 : 1.30D-13 ; +{461:366} OH+UDCARB8=C2H5O2 : 5.20D-11*0.5 ; +{462:367} OH+UDCARB11=RN10O2 : 5.58D-11*0.55 ; +{463:368} OH+UDCARB14=RN13O2 : 7.00D-11*0.55 ; +{464:369} OH+TNCARB26=RTN26O2 : 4.20D-11 ; +{465:370} OH+TNCARB15=RN15AO2 : 1.00D-12 ; +{466:371} OH+TNCARB10=RTN10O2 : 1.00D-10 ; +{467:372} NO3+TNCARB26=RTN26O2+HNO3 : 3.80D-14 ; +{468:373} NO3+TNCARB10=RTN10O2+HNO3 : 1.44d-12*EXP(-1862.0/temp)*5.5 ; +{469:374} OH+RCOOH25=RTN25O2 : 6.65D-12 ; +{470:375} OH+TXCARB24=RTX24O2 : 1.55D-11 ; +{471:376} OH+TXCARB22=RTX22O2 : 4.55D-12 ; +{472:377} OH+CH3NO3=HCHO+NO2 : ARR2( 1.00D-14, -1060.0_dp, TEMP) ; +{473:378} OH+C2H5NO3=CH3CHO+NO2 : ARR2( 4.40D-14, -720.0_dp, TEMP) ; +{474:379} OH+RN10NO3=C2H5CHO+NO2 : 7.30D-13 ; +{475:380} OH+IC3H7NO3=CH3COCH3+NO2 : 4.90D-13 ; +{476:381} OH+RN13NO3=CARB11A+NO2 : 9.20D-13 ; +{477:382} OH+RN16NO3=CARB14+NO2 : 1.85D-12 ; +{478:383} OH+RN19NO3=CARB17+NO2 : 3.02D-12 ; +{479:384} OH+HOC2H4NO3=HOCH2CHO+NO2 : 1.09D-12 ; +{480:385} OH+RN9NO3=CARB7+NO2 : 1.31D-12 ; +{481:386} OH+RN12NO3=CARB10+NO2 : 1.79D-12 ; +{482:387} OH+RN15NO3=CARB13+NO2 : 1.03D-11 ; +{483:388} OH+RN18NO3=CARB16+NO2 : 1.34D-11 ; +{484:389} OH+RU14NO3=UCARB12+NO2 : 5.55D-11 ; +{485:390} OH+RA13NO3=CARB3+UDCARB8+NO2 : 7.30D-11 ; +{486:391} OH+RA16NO3=CARB3+UDCARB11+NO2 : 7.16D-11 ; +{487:392} OH+RA19NO3=CARB6+UDCARB11+NO2 : 8.31D-11 ; +{488:393} OH+RTN28NO3=TNCARB26+NO2 : 4.35D-12 ; +{489:394} OH+RTN25NO3=CH3COCH3+TNCARB15+NO2 : 2.88D-12 ; +{490:395} OH+RTX28NO3=TXCARB24+HCHO+NO2 : 3.53D-12 ; +{491:396} OH+RTX24NO3=TXCARB22+NO2 : 6.48D-12 ; +{492:397} OH+RTX22NO3=CH3COCH3+CCARB12+NO2 : 4.74D-12 ; +{493:398} OH+AROH14=RAROH14 : 2.63D-11 ; +{494:399} NO3+AROH14=RAROH14+HNO3 : 3.78D-12 ; +{495:400} RAROH14+NO2=ARNOH14 : 2.08D-12 ; +{496:401} OH+ARNOH14=CARB13+NO2 : 9.00D-13 ; +{497:402} NO3+ARNOH14=CARB13+NO2+HNO3 : 9.00D-14 ; +{498:403} OH+AROH17=RAROH17 : 4.65D-11 ; +{499:404} NO3+AROH17=RAROH17+HNO3 : 1.25D-11 ; +{500:405} RAROH17+NO2=ARNOH17 : 2.08D-12 ; +{501:406} OH+ARNOH17=CARB16+NO2 : 1.53D-12 ; +{502:407} NO3+ARNOH17=CARB16+NO2+HNO3 : 3.13D-13 ; +{503:408} OH+CH3OOH=CH3OO : ARR2( 1.90D-12, -190.0_dp, TEMP) ; +{504:409} OH+CH3OOH=HCHO+OH : ARR2( 1.00D-12, -190.0_dp, TEMP) ; +{505:410} OH+C2H5OOH=CH3CHO+OH : 1.36D-11 ; +{506:411} OH+RN10OOH=C2H5CHO+OH : 1.89D-11 ; +{507:412} OH+IC3H7OOH=CH3COCH3+OH : 2.78D-11 ; +{508:413} OH+RN13OOH=CARB11A+OH : 3.57D-11 ; +{509:414} OH+RN16OOH=CARB14+OH : 4.21D-11 ; +{510:415} OH+RN19OOH=CARB17+OH : 4.71D-11 ; +{511:416} OH+CH3CO3H=CH3CO3 : 3.70D-12 ; +{512:417} OH+C2H5CO3H=C2H5CO3 : 4.42D-12 ; +{513:418} OH+HOCH2CO3H=HOCH2CO3 : 6.19D-12 ; +{514:419} OH+RN8OOH=CARB6+OH : 4.42D-12 ; +{515:420} OH+RN11OOH=CARB9+OH : 2.50D-11 ; +{516:421} OH+RN14OOH=CARB12+OH : 3.20D-11 ; +{517:422} OH+RN17OOH=CARB15+OH : 3.35D-11 ; +{518:423} OH+RU14OOH=UCARB12+OH : 7.51D-11 ; +{519:424} OH+RU12OOH=RU12O2 : 3.00D-11 ; +{520:425} OH+RU10OOH=RU10O2 : 3.00D-11 ; +{521:426} OH+NRU14OOH=NUCARB12+OH : 1.03D-10 ; +{522:427} OH+NRU12OOH=NOA+CO+OH : 2.65D-11 ; +{523:428} OH+HOC2H4OOH=HOCH2CHO+OH : 2.13D-11 ; +{524:429} OH+RN9OOH=CARB7+OH : 2.50D-11 ; +{525:430} OH+RN12OOH=CARB10+OH : 3.25D-11 ; +{526:431} OH+RN15OOH=CARB13+OH : 3.74D-11 ; +{527:432} OH+RN18OOH=CARB16+OH : 3.83D-11 ; +{528:433} OH+NRN6OOH=HCHO+HCHO+NO2+OH : 5.22D-12 ; +{529:434} OH+NRN9OOH=CH3CHO+HCHO+NO2+OH : 6.50D-12 ; +{530:435} OH+NRN12OOH=CH3CHO+CH3CHO+NO2+OH : 7.15D-12 ; +{531:436} OH+RA13OOH=CARB3+UDCARB8+OH : 9.77D-11 ; +{532:437} OH+RA16OOH=CARB3+UDCARB11+OH : 9.64D-11 ; +{533:438} OH+RA19OOH=CARB6+UDCARB11+OH : 1.12D-10 ; +{534:439} OH+RTN28OOH=TNCARB26+OH : 2.38D-11 ; +{535:440} OH+RTN26OOH=RTN26O2 : 1.20D-11 ; +{536:441} OH+NRTN28OOH=TNCARB26+NO2+OH : 9.50D-12 ; +{537:442} OH+RTN25OOH=RTN25O2 : 1.66D-11 ; +{538:443} OH+RTN24OOH=RTN24O2 : 1.05D-11 ; +{539:444} OH+RTN23OOH=RTN23O2 : 2.05D-11 ; +{540:445} OH+RTN14OOH=RTN14O2 : 8.69D-11 ; +{541:446} OH+RTN10OOH=RTN10O2 : 4.23D-12 ; +{542:447} OH+RTX28OOH=RTX28O2 : 2.00D-11 ; +{543:448} OH+RTX24OOH=TXCARB22+OH : 8.59D-11 ; +{544:449} OH+RTX22OOH=CH3COCH3+CCARB12+OH : 7.50D-11 ; +{545:450} OH+NRTX28OOH=NRTX28O2 : 9.58D-12 ; +{546:451} CH3CO3+NO2=PAN : TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp , TEMP, C_M) ; +{547:452} PAN=CH3CO3+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29 ,6.5_dp,1.1d-11,0._dp,TEMP,C_M) ; +{548:453} C2H5CO3+NO2=PPN : TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp , TEMP, C_M) ; +{549:454} PPN=C2H5CO3+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29,6.5_dp , 1.1d-11 , 0._dp,TEMP, C_M) ; +{550:455} HOCH2CO3+NO2=PHAN : TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp , TEMP, C_M) ; +{551:456} PHAN=HOCH2CO3+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29 , 6.5_dp,1.1d-11,0._dp,TEMP, C_M) ; +{552:457} OH+PAN=HCHO+CO+NO2 : ARR2( 9.50D-13, 650.0_dp, TEMP) ; +{553:458} OH+PPN=CH3CHO+CO+NO2 : 1.27D-12 ; +{554:459} OH+PHAN=HCHO+CO+NO2 : 1.12D-12 ; +{555:460} RU12O2+NO2=RU12PAN : 0.061*TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp ,TEMP, C_M) ; +{556:461} RU12PAN=RU12O2+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29,6.5_dp,1.1d-11,0._dp,TEMP, C_M) ; +{557:462} RU10O2+NO2=MPAN : 0.041*TROE( 8.5d-29,6.5_dp,1.1d-11,1._dp,TEMP,C_M) ; +{558:463} MPAN=RU10O2+NO2 : TROEE(1.111d28,14000._dp,8.5d-29,6.5_dp,1.1d-11,0._dp ,TEMP, C_M) ; +{559:464} OH+MPAN=CARB7+CO+NO2 : 3.60D-12 ; +{560:465} OH+RU12PAN=UCARB10+NO2 : 2.52D-11 ; +{561:466} RTN26O2+NO2=RTN26PAN : 0.722*TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp,TEMP, C_M) ; +{562:467} RTN26PAN=RTN26O2+NO2 : TROEE(1.111d28,14000._dp,8.5d-29,6.5_dp,1.1d-11,0._dp,TEMP, C_M) ; +{563:468} OH+RTN26PAN=CH3COCH3+CARB16+NO2 : 3.66D-12 ; +{564:469} OH+ANHY=HOCH2CH2O2 : 1.50D-12 ; +{565:470} OH+UDCARB8=ANHY+HO2 : 5.20D-11*0.50 ; +{566:471} OH+UDCARB11=ANHY+CH3OO : 5.58D-11*0.45 ; +{567:472} OH+UDCARB14=ANHY+C2H5O2 : 7.00D-11*0.45 ; +{568:473} OH+CH3CL=CH3OO : 7.33D-18*EXP(-809/TEMP)*TEMP**2 ; +{569:474} OH+CH2CL2=CH3OO : 6.14D-18*EXP(-389/TEMP)*TEMP**2 ; +{570:475} OH+CHCL3=CH3OO : 1.80D-18*EXP(-129/TEMP)*TEMP**2 ; +{571:476} OH+CH3CCL3=C2H5O2 : 2.25D-18*EXP(-910/TEMP)*TEMP**2 ; +{572:477} OH+TCE= HOCH2CH2O2 : ARR2( 9.64D-12, 1209.0_dp, TEMP) ; +{573:478} OH+TRICLETH=HOCH2CH2O2 : ARR2( 5.63D-13, -427.0_dp, TEMP) ; +{574:479} OH+CDICLETH=HOCH2CH2O2 : ARR2( 1.94D-12, -90.0_dp, TEMP) ; +{575:480} OH+TDICLETH=HOCH2CH2O2 : ARR2( 1.01D-12, -250.0_dp, TEMP) ; +{576:481} CH3OO+NO2=CH3O2NO2 : RJPL(1.3D-30,4.0_dp,7.5D-12,2.0_dp,C_M,TEMP) ; +{577:482} TNCARB12+hv = RN9O2 + HOCH2CO3 : 7.047*7.8D-5 * j(Pj_no2) ; +{578:483} TNCARB11+hv = RTN10O2 + CO + HO2 : 32.6088*4.6D-4 * j(Pj_no2) ; +{579:484} RA22NO3+hv = CARB6 + UDCARB14 + HO2 + NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{580:485} RA22OOH+hv = CARB6 + UDCARB14 + HO2 + OH : 0.7 * j(Pj_h2o2) ; +{581:486} RA25NO3+hv = CARB6 + UDCARB17 + HO2 + NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{582:487} RA25OOH+hv = CARB6 + UDCARB17 + HO2 + OH : 0.7 * j(Pj_h2o2) ; +{583:488} UDCARB17+hv = ANHY + HO2 + RN10O2 : 0.02*0.45*j(Pj_no2) ; +{584:489} UDCARB17+hv = RN16O2 + HO2 : 0.02*0.55*j(Pj_no2) ; +{585:490} RTN23O2 + NO = RTN23NO3 : 2.40d-12*EXP(360.0/temp)*0.118 ; +{586:491} RTN23NO3 + OH = CH3COCH3 + TNCARB12 + NO2 : 5.37D-12 ; +{587:492} TNCARB12 + OH = TNCARB11 + HO2 : 3.22D-12 ; +{588:493} TNCARB11 + OH = RTN10O2 + CO : 1.33D-11 ; +{589:494} TNCARB11 + NO3 = RTN10O2 + CO + HNO3 : 1.44d-12*EXP(-1862.0/temp)*5.5 ; +{590:495} TM123B + OH = RA22AO2 : 3.27D-11*0.50 ; +{591:496} TM123B + OH = RA22BO2 : 3.27D-11*0.50 ; +{592:497} TM124B + OH = RA22AO2 : 3.25D-11*0.50 ; +{593:498} TM124B + OH = RA22BO2 : 3.25D-11*0.50 ; +{594:499} TM135B + OH = RA22AO2 : 5.67D-11 ; +{595:500} OETHTOL + OH = RA22AO2 : 1.19D-11 ; +{596:501} METHTOL + OH = RA22AO2 : 1.86D-11 ; +{597:502} PETHTOL + OH = RA22AO2 : 1.18D-11 ; +{598:503} RA22AO2 + NO = CARB6 + UDCARB14 + HO2 + NO2 : 2.40d-12*EXP(360.0/temp)*0.843 ; +{599:504} RA22BO2 + NO = CARB9 + UDCARB11 + HO2 + NO2 : 2.40d-12*EXP(360.0/temp)*0.843 ; +{600:505} RA22AO2 + NO = RA22NO3 : 2.40d-12*EXP(360.0/temp)*0.157 ; +{601:506} RA22BO2 + NO = RA22NO3 : 2.40d-12*EXP(360.0/temp)*0.157 ; +{602:507} RA22AO2 + NO3 = CARB6 + UDCARB14 + HO2 + NO2 : 2.50d-12 ; +{603:508} RA22BO2 + NO3 = CARB9 + UDCARB11 + HO2 + NO2 : 2.50d-12 ; +{604:509} RA22AO2 + HO2 = RA22OOH : 0.520*2.91d-13*EXP(1300.0/temp)*0.890 ; +{605:510} RA22BO2 + HO2 = RA22OOH : 0.520*2.91d-13*EXP(1300.0/temp)*0.890 ; +{606:511} RA22AO2 = CARB6 + UDCARB14 + HO2 : 8.80D-13*RO2 ; +{607:512} RA22BO2 = CARB9 + UDCARB11 + HO2 : 8.80D-13*RO2 ; +{608:513} OH + RA22NO3 = CARB6 + UDCARB14 + NO2 : 9.45D-11 ; +{609:514} OH + RA22OOH = CARB6 + UDCARB14 + OH : 1.28D-10 ; +{610:515} DIME35EB + OH = RA25O2 : 5.67D-11 ; +{611:516} RA25O2 + NO = CARB6 + UDCARB17 + HO2 + NO2 : 2.40d-12*EXP(360.0/temp)*0.833 ; +{612:517} RA25O2 + NO = RA25NO3 : 2.40d-12*EXP(360.0/temp)*0.167 ; +{613:518} RA25O2 + NO3 = CARB6 + UDCARB17 + HO2 + NO2 : 2.50d-12 ; +{614:519} RA25O2 + HO2 = RA25OOH : 0.520*2.91d-13*EXP(1300.0/temp)*0.914 ; +{615:520} RA25O2 = CARB6 + UDCARB17 + HO2 : 8.80D-13*RO2 ; +{616:521} OH + RA25NO3 = CARB6 + UDCARB17 + NO2 : 9.57D-11 ; +{617:522} OH + RA25OOH = CARB6 + UDCARB17 + OH : 1.28D-10 ; +{618:523} OH + UDCARB17 = RN16O2 : 7.00D-11*0.55 ; +{619:524} OH + UDCARB17 = ANHY + RN10O2 : 7.00D-11*0.45 ; +{620:105} HCl = HCl : 1.0_dp ; {copied from cbmz_bb} +{621:106} NH3 = NH3 : 1.0_dp ; {copied from cbmz_bb} +{621:106} ClNO2 = ClNO2 : 1.0_dp ; {dummy} +{622:S04} DMS + OH = CH3SCH2OO + H2O : ARR2(1.12d-11,250._dp,temp) ; {CH3SCH3+OH->CH3SCH2+H2O ; CH3SCH2+O2->CH3SCH2OO - 1st step is slowest, so use that as reaction function (IUPAC preferred value)} +{623:S05} DMS + OH {+O2} = DMSO + HO2 : iupac_ch3sch3(9.5d-39,5270._dp,7.5d-29,5610._dp,C_M*0.2_dp,temp) ; {IUPAC preferred value} +{624:S06} DMS + NO3 {+O2} = CH3SCH2OO + HNO3 : ARR2(1.9d-13,-520._dp,temp) ; +{625:S12} CH3SCH2OO + NO = HCHO + CH3S + NO2 : ARR2(4.9d-12,-263._dp,temp) ; +{626:S13} CH3SCH2OO + CH3SCH2OO {+O2} = 2 HCHO + 2 CH3S : 1.0d-11 ; +{627:S14} CH3S + O3 = CH3SO {+ O2} : ARR2(1.15d-12,-432._dp,temp) ; +{628:S15} CH3S + NO2 = CH3SO + NO : ARR2(3.0d-11,-210._dp,temp) ; +{629:S16} CH3SO + NO2 {+O2} = 0.82 CH3SO2 + 0.18 SO2 + 0.18 CH3OO + NO : 1.2d-11 ; +{630:S17} CH3SO + O3 {+O2} = CH3SO2 : 6.0d-13 ; +{631:S18} CH3SO2 = SO2 + CH3OO : ARR2(5.0d13,9673._dp,temp) {ARR2(1.9d13,8661._dp,temp)} ; +{632:S19} CH3SO2 + NO2 = CH3SO3 + NO : 2.2d-12 ; +{633:S20} CH3SO2 + O3 = CH3SO3 : 3.0d-13 ; +{634:S21} CH3SO3 + HO2 = MSA : 5.0d-11 ; +{635:S22} CH3SO3 {+H2O+O2} = CH3OO + H2SO4 : ARR2(1.36d14,11071._dp,temp) ; +{636:S23} DMSO + OH = 0.95 MSIA + 0.95 CH3OO + 0.05 DMSO2 : 8.7d-11 ; +{637:S24} MSIA + OH = 0.95 CH3SO2 + 0.05 MSA + 0.05 HO2 + H2O : 9.d-11 ; +{638:S25} MSIA + NO3 = CH3SO2 + HNO3 : 1.0d-13 ; diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.kpp b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.kpp new file mode 100644 index 00000000..0e514859 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.kpp @@ -0,0 +1,9 @@ +#MODEL cri_mosaic_8bin_aq +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.spc b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.spc new file mode 100644 index 00000000..01a45adf --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq.spc @@ -0,0 +1,238 @@ +#DEFVAR + HONO =IGNORE ; + O3 =IGNORE ; + HCHO =IGNORE ; + PAN =IGNORE ; + C2H4 =IGNORE ; + CO =IGNORE ; + HNO3 =IGNORE ; + N2O5 =IGNORE ; + HNO4 =IGNORE ; + NO3 =IGNORE ; + O1D =IGNORE ; + O3P =IGNORE ; + OH =IGNORE ; + HO2 =IGNORE ; + H2O2 =IGNORE ; + C2H6 =IGNORE ; + HCOOH =IGNORE ; + CH3CO3 =IGNORE ; + CH3OO =IGNORE ; + C2H5O2 =IGNORE ; + HSO3 =IGNORE ; + SO3 =IGNORE ; + SO2 =IGNORE ; + NO2 =IGNORE ; + NO =IGNORE ; + C3H8 =IGNORE ; + NC4H10 =IGNORE ; + HOCH2CH2O2 =IGNORE ; + IC3H7O2 =IGNORE ; + C5H8 =IGNORE ; + BENZENE =IGNORE ; + TOLUENE =IGNORE ; + OXYL =IGNORE ; + NPROPOL =IGNORE ; + C2H2 =IGNORE ; + C3H6 =IGNORE ; + TBUT2ENE =IGNORE ; + CH3CHO =IGNORE ; + C2H5CHO =IGNORE ; + CH3CO2H =IGNORE ; + CH3COCH3 =IGNORE ; + MEK =IGNORE ; + CH3OH =IGNORE ; + C2H5OH =IGNORE ; + IC3H7NO3 =IGNORE ; + IPROPOL =IGNORE ; + CH3NO3 =IGNORE ; + C2H5NO3 =IGNORE ; + HOC2H4NO3 =IGNORE ; + CH3OOH =IGNORE ; + C2H5OOH =IGNORE ; + IC3H7OOH =IGNORE ; + CH3CO3H =IGNORE ; + HOC2H4OOH =IGNORE ; + RN10O2 =IGNORE ; + RN13O2 =IGNORE ; + RN16O2 =IGNORE ; + RN19O2 =IGNORE ; + RN9O2 =IGNORE ; + RN12O2 =IGNORE ; + RN15O2 =IGNORE ; + RN18O2 =IGNORE ; + NRN6O2 =IGNORE ; + NRN9O2 =IGNORE ; + NRN12O2 =IGNORE ; + CARB14 =IGNORE ; + RN11O2 =IGNORE ; + RN14O2 =IGNORE ; + CARB17 =IGNORE ; + RN8O2 =IGNORE ; + RN17O2 =IGNORE ; + RN10NO3 =IGNORE ; + RN13NO3 =IGNORE ; + RN19NO3 =IGNORE ; + RN9NO3 =IGNORE ; + RN12NO3 =IGNORE ; + RN15NO3 =IGNORE ; + RN18NO3 =IGNORE ; + RN16NO3 =IGNORE ; + RN10OOH =IGNORE ; + RN13OOH =IGNORE ; + RN16OOH =IGNORE ; + RN19OOH =IGNORE ; + RN8OOH =IGNORE ; + RN11OOH =IGNORE ; + RN14OOH =IGNORE ; + RN17OOH =IGNORE ; + RN9OOH =IGNORE ; + RN12OOH =IGNORE ; + RN15OOH =IGNORE ; + RN18OOH =IGNORE ; + NRN6OOH =IGNORE ; + NRN9OOH =IGNORE ; + NRN12OOH =IGNORE ; + APINENE =IGNORE ; + BPINENE =IGNORE ; + RN13AO2 =IGNORE ; + RN16AO2 =IGNORE ; + RN15AO2 =IGNORE ; + RN18AO2 =IGNORE ; + CARB7 =IGNORE ; + CARB10 =IGNORE ; + CARB13 =IGNORE ; + CARB16 =IGNORE ; + CARB3 =IGNORE ; + CARB6 =IGNORE ; + CARB9 =IGNORE ; + CARB12 =IGNORE ; + CARB15 =IGNORE ; + C2H5CO3H =IGNORE ; + C2H5CO3 =IGNORE ; + PPN =IGNORE ; + HOCH2CHO =IGNORE ; + HOCH2CO3 =IGNORE ; + HOCH2CO3H =IGNORE ; + PHAN =IGNORE ; + CCARB12 =IGNORE ; + RU14O2 =IGNORE ; + RU12O2 =IGNORE ; + CH3CL =IGNORE ; + CH2CL2 =IGNORE ; + CHCL3 =IGNORE ; + CH3CCL3 =IGNORE ; + CDICLETH =IGNORE ; + TDICLETH =IGNORE ; + TRICLETH =IGNORE ; + TCE =IGNORE ; + RU10O2 =IGNORE ; + UCARB12 =IGNORE ; + UCARB10 =IGNORE ; + RU14NO3 =IGNORE ; + RU14OOH =IGNORE ; + RU12OOH =IGNORE ; + RU10OOH =IGNORE ; + MPAN =IGNORE ; + RU12PAN=IGNORE ; + NRU14O2 =IGNORE ; + NUCARB12 =IGNORE ; + NRU14OOH =IGNORE ; + NRU12O2 =IGNORE ; + NRU12OOH =IGNORE ; + NOA =IGNORE ; + RA13O2 =IGNORE ; + RA13NO3 =IGNORE ; + RA13OOH =IGNORE ; + UDCARB8 =IGNORE ; + AROH14 =IGNORE ; + RAROH14 =IGNORE ; + ARNOH14 =IGNORE ; + RA16O2 =IGNORE ; + RA16NO3 =IGNORE ; + RA16OOH =IGNORE ; + UDCARB11 =IGNORE ; + AROH17 =IGNORE ; + RAROH17 =IGNORE ; + ARNOH17 =IGNORE ; + UDCARB14 =IGNORE ; + RA19AO2 =IGNORE ; + RA19CO2 =IGNORE ; + RA19NO3 =IGNORE ; + RA19OOH =IGNORE ; + RTN28O2 =IGNORE ; + RTN28NO3 =IGNORE ; + RTN28OOH =IGNORE ; + TNCARB26 =IGNORE ; + RTN26O2 =IGNORE ; + RTN26OOH =IGNORE ; + NRTN28O2 =IGNORE ; + NRTN28OOH =IGNORE ; + RTN26PAN =IGNORE ; + RTN25O2 =IGNORE ; + RTN24O2 =IGNORE ; + RTN23O2 =IGNORE ; + RTN14O2 =IGNORE ; + RTN10O2 =IGNORE ; + RTN25OOH =IGNORE ; + RTN24OOH =IGNORE ; + RTN23OOH =IGNORE ; + RTN14OOH =IGNORE ; + RTN10OOH =IGNORE ; + TNCARB10 =IGNORE ; + RTN25NO3 =IGNORE ; + TNCARB15 =IGNORE ; + RCOOH25 =IGNORE ; + RTX28O2 =IGNORE ; + RTX28NO3 =IGNORE ; + RTX28OOH =IGNORE ; + TXCARB24 =IGNORE ; + RTX24O2 =IGNORE ; + RTX24NO3 =IGNORE ; + RTX24OOH =IGNORE ; + TXCARB22 =IGNORE ; + RTX22O2 =IGNORE ; + RTX22NO3 =IGNORE ; + RTX22OOH =IGNORE ; + NRTX28O2 =IGNORE ; + NRTX28OOH =IGNORE ; + CARB11A =IGNORE ; + ANHY =IGNORE ; + CH3O2NO2 =IGNORE ; + CH4 =IGNORE ; + H2SO4 =IGNORE ; + HCl =IGNORE ; + NH3 =IGNORE ; + RTN23NO3 =IGNORE ; + TNCARB12 =IGNORE ; + TNCARB11 =IGNORE ; + TM123B =IGNORE ; + TM124B =IGNORE ; + TM135B =IGNORE ; + OETHTOL =IGNORE ; + METHTOL =IGNORE ; + PETHTOL =IGNORE ; + RA22AO2 =IGNORE ; + RA22BO2 =IGNORE ; + RA22NO3 =IGNORE ; + RA22OOH =IGNORE ; + DIME35EB =IGNORE ; + RA25O2 =IGNORE ; + RA25NO3 =IGNORE ; + UDCARB17 =IGNORE ; + RA25OOH =IGNORE ; + DMS = IGNORE ; + CH3SCH2OO = IGNORE ; + DMSO = IGNORE ; + CH3S = IGNORE ; + CH3SO = IGNORE ; + CH3SO2 = IGNORE ; + CH3SO3 = IGNORE ; + MSA = IGNORE ; + MSIA = IGNORE ; + DMSO2 = IGNORE ; + ClNO2 = IGNORE ; +#DEFFIX + H2O =IGNORE ; + M =IGNORE ; +{H2 =IGNORE ;} diff --git a/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq_wrfkpp.equiv new file mode 100644 index 00000000..4a0df53c --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cri_mosaic_8bin_aq/cri_mosaic_8bin_aq_wrfkpp.equiv @@ -0,0 +1,14 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +HO OH +KET CH3COCH3 +ACO3 CH3CO3 +PAA CH3CO3H +PROOH IC3H7OOH +SULF H2SO4 + diff --git a/wrfv2_fire/chem/KPP/mechanisms/crimech/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/crimech/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/crimech/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.def b/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.def new file mode 100644 index 00000000..0a3151ec --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.def @@ -0,0 +1,171 @@ +#include atoms_red +#include ./crimech.spc +#include ./crimech.eqn + + + + +#INLINE F90_RATES +!************** SPECIAL RATE FUNCTIONS ********************** + +REAL(KIND=dp) FUNCTION k46( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=7.2E-15_dp * EXP(785._dp/TEMP) + k2=4.1E-16_dp * EXP(1440._dp/TEMP) + k3=1.9E-33_dp * EXP(725._dp/TEMP) * C_M + + k46=k0+k3/(1+k3/k2) + +! print*,'k46=',k46 +END FUNCTION k46 + +REAL(KIND=dp) FUNCTION k47( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, ki, fc, x, ssign, f12 + k0 = 3.00d-31*((temp/300.0)**(-3.3))*C_M + ki = 1.50d-12 + fc = 0.6 + x = 1.0d+0 + ssign = dsign(x,(k0-ki)) + f12 =10**(dlog10(fc)/(1.0+(ssign*(ABS(dlog10(k0/ki)))**(2.0)))) + k47=(k0*ki*f12)/(k0+ki) +! print*,'k47=',k47 +END FUNCTION k47 + +REAL(KIND=dp) FUNCTION k48( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, ki, fc, x, ssign, f17 + k0 = 5.00d-30*((temp/298.0)**(-1.5))*C_M + ki = 9.40d-12*EXP(-700.0/temp) + fc = (EXP(-temp/580.0) + EXP(-2320.0/temp)) + x = 1.0d+0 + ssign = dsign(x,(k0-ki)) + f17=10**(dlog10(fc)/(1.0+(ssign*(ABS(dlog10(k0/ki)))**(2.0)))) + k48=(k0*ki*f17)/(k0+ki) +! print*,'k48=',k48 +END FUNCTION k48 + + REAL(KIND=dp) FUNCTION RJPL( K0300, Q, KU300, R, M, T ) + REAL(KIND=dp) :: k0300,q,ku300,r,m,t + REAL(KIND=dp) :: tt,k0,ku,k0m,kk,lgkk,e,f +! JPL standard three body reaction rate format extended + TT= T / 3.D2 + K0= K0300 * exp(-1._dp*Q*log(TT)) + KU= KU300 * exp(-1._dp*R*log(TT)) + K0M= K0 * M + KK= K0M / KU + LGKK=0.43429448190324926_dp * LOG(KK) ! = log10(KK) + E=1.D0 / ( 1.D0 + LGKK*LGKK ) + F=exp(-0.5108256237659887_dp*E) ! -0.51=log(0.6) + RJPL = F * K0M / ( 1.D0 + KK ) +! print*,'RJPL=',RJPL + END FUNCTION +!--------------------------------------------------------------------- + + + + REAL(KIND=dp) FUNCTION RALKE( K0300, Q, KU, Fc, M, T ) + REAL(KIND=dp) :: k0300,q,m,t,Fc + real(KIND=dp) :: tt,k0,ku,k0m,kk,lgkk,e,f +! special function for alkene+OH reactions + TT= T / 3.D2 + K0= K0300 * exp(-1._dp*Q*log(TT)) + K0M= K0 * M + KK= K0M / KU + LGKK=0.43429448190324926_dp * LOG(KK) ! = log10(KK) + E=1.D0 / ( 1.D0 + LGKK*LGKK ) + F=exp(log(Fc)*E) + RALKE = F * K0M / ( 1.D0 + KK ) +! print*,'RALKE=',RALKE + END FUNCTION + + + real(kind=dp) function iupac_ch3sch3(a2,b2,a3,b3,cin_o2,temp) + !rate calculation for CH3SCH3 + OH = CH3SCH3OO + H2O + ! from IUPAC report (www.iupac-kinetic.ch.cam.ac.uk) + real(kind=dp) :: cin_o2, tr, temp + real(kind=dp) :: a2, b2, a3, b3 + + tr = 1._dp + ARR2(a3,b3,temp)*cin_o2 + iupac_ch3sch3 = ARR2(a2,b2,temp)*cin_o2/tr + + end function iupac_ch3sch3 + +!--------------------------------------------------------------------- + +!- SAN: adding standard 3-body reaction using convention of MCM & IUPAC recommendations +! - Explicit form of TROE reactions +! Based on Atkinson et. al. 2004 + +REAL(KIND=dp) FUNCTION KMT_IUPAC(k0_300K,n,kinf_300K,m,Fc,temp,cair) + + INTRINSIC LOG10 + + REAL(KIND=dp), INTENT(IN) :: temp ! temperature [K] + REAL(KIND=dp), INTENT(IN) :: cair ! air concentration [molecules/cm3] + REAL(KIND=dp), INTENT(IN) :: k0_300K ! low pressure limit at 300 K + REAL(KIND=dp), INTENT(IN) :: n ! exponent for low pressure limit + !!! n.b. - remember to flip sign of exponents from IUPAC data sheets !!! + REAL(KIND=dp), INTENT(IN) :: kinf_300K ! high pressure limit at 300 K + REAL(KIND=dp), INTENT(IN) :: m ! exponent for high pressure limit + REAL(KIND=dp), INTENT(IN) :: Fc ! Approximate broadening factor + + REAL(KIND=dp) :: zt_help, k0_T, kinf_T, k_ratio, Nint, F_exp + + zt_help = 300._dp/temp + k0_T = k0_300K * zt_help**(n) * cair ! k_0 at current T + kinf_T = kinf_300K * zt_help**(m) ! k_inf at current T + k_ratio = k0_T/kinf_T + Nint = 0.75_dp - 1.27_dp*LOG10(Fc) + ! Calculate explicit broadening factor: + F_exp = Fc ** (1._dp / (1._dp + ( LOG10(k_ratio) / Nint )**2._dp ) ) + + KMT_IUPAC = k0_T/(1._dp+k_ratio) * F_exp + +END FUNCTION KMT_IUPAC + +!--------------------------------------------------------------------- + +!- SAN: Function for calculating NO + OH [+ M] 3-body reaction +!- Explicit form of TROE reaction with temperature dependent Fc + +REAL(KIND=dp) FUNCTION KMT_OH_NO(temp,cair) + + INTRINSIC LOG10 + + REAL(KIND=dp), INTENT(IN) :: temp ! temperature [K] + REAL(KIND=dp), INTENT(IN) :: cair ! air concentration [molecules/cm3] + + REAL(KIND=dp) :: k0_300K, n, kinf_300K, m, zt_help + REAL(KIND=dp) :: k0_T, kinf_T, k_ratio, Nint, Fc, F_exp + + k0_300K = 7.4D-31 ! low pressure limit at 300 K + n = 2.4_dp ! exponent for low pressure limit + kinf_300K = 3.3D-11 ! high pressure limit at 300 K + m = 0.3_dp ! exponent for high pressure limit + + zt_help = 300._dp/temp + k0_T = k0_300K * zt_help**(n) * cair ! k_0 at current T + kinf_T = kinf_300K * zt_help**(m) ! k_inf at current T + k_ratio = k0_T/kinf_T + + ! OH + NO [+ M] uses temperature dependent Fc: + Fc = exp(-temp / 1420._dp) + + Nint = 0.75_dp - 1.27_dp*LOG10(Fc) + + ! Calculate explicit broadening factor: + F_exp = Fc ** (1._dp / (1._dp + ( LOG10(k_ratio) / Nint )**2._dp ) ) + + KMT_OH_NO = k0_T/(1._dp+k_ratio) * F_exp + +END FUNCTION KMT_OH_NO + + + + +#ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.eqn b/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.eqn new file mode 100644 index 00000000..de075259 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.eqn @@ -0,0 +1,638 @@ +#EQUATIONS {CRIMECH, check troe,troee, RJPL, RALKE, k46, k47, k48, RO2} +{001:J01} O3+hv=O1D{+O2} : j(Pj_o31d) ; +{002:J02} O3+hv=O3P{+O2} : j(Pj_o33p) ; +{003:J03} H2O2+hv=OH+OH : j(Pj_h2o2) ; +{004:J04} NO2+hv=NO+O3P : j(Pj_no2) ; +{005:J05} NO3+hv=NO : j(Pj_no3o2) ; +{006:J06} NO3+hv=NO2+O3P : j(Pj_no3o) ; +{007:J07} HONO+hv=OH+NO : j(Pj_hno2) ; +{008:J08} HNO3+hv=OH+NO2 : j(Pj_hno3) ; +{009:J09} HCHO+hv=CO+HO2+HO2 : j(Pj_ch2or) ; +{010:J10} HCHO+hv=CO : j(Pj_ch2om) ; +{011:J11} CH3CHO+hv=CH3OO+HO2+CO : 4.6D-4 * j(Pj_no2) ; +{012:J12} C2H5CHO+hv=C2H5O2+CO+HO2 : 4.19*4.6D-4 * j(Pj_no2) ; +{013:J13} CH3COCH3+hv=CH3CO3+CH3OO : 7.8D-5 * j(Pj_no2) ; +{014:J14} MEK+hv=CH3CO3+C2H5O2 : 7.047*7.8D-5 * j(Pj_no2) ; +{015:J15} CARB14+hv=CH3CO3+RN10O2 : 4.74*7.047*7.8D-5 * j(Pj_no2) ; +{016:J16} CARB17+hv=RN8O2+RN10O2 : 1.33*7.047*7.8D-5 * j(Pj_no2) ; +{017:J17} CARB11A+hv=CH3CO3+C2H5O2 : 7.047*7.8D-5 * j(Pj_no2) ; +{018:J18} CARB7+hv=CH3CO3+HCHO+HO2 : 7.047*7.8D-5 * j(Pj_no2) ; +{019:J19} CARB10+hv=CH3CO3+CH3CHO+HO2 : 7.047*7.8D-5 * j(Pj_no2) ; +{020:J20} CARB13+hv=RN8O2+CH3CHO+HO2 : 3.00*7.047*7.8D-5 * j(Pj_no2) ; +{021:J21} CARB16+hv=RN8O2+C2H5CHO+HO2 : 3.35*7.047*7.8D-5 * j(Pj_no2) ; +{022:J22} HOCH2CHO+hv=HCHO+CO+HO2+HO2 : 9.64_dp*j(pj_ch2or) ; +{023:J23} UCARB10+hv=CH3CO3+HCHO+HO2 : 2.0*1.9997*4.6D-4 * j(Pj_no2) ; +{024:J24} CARB3+hv=CO+CO+HO2+HO2 : 9.64_dp*j(pj_ch2or) ; +{025:J25} CARB6+hv=CH3CO3+CO+HO2 : 32.6088*4.6D-4 * j(Pj_no2); +{026:J26} CARB9+hv=CH3CO3+CH3CO3 : 2.149*32.6088*4.6D-4 * j(Pj_no2); +{027:J27} CARB12+hv=CH3CO3+RN8O2 : 2.149*32.6088*4.6D-4 * j(Pj_no2); +{028:J28} CARB15+hv=RN8O2+RN8O2 : 2.149*32.6088*4.6D-4 * j(Pj_no2); +{029:J29} UCARB12+hv=CH3CO3+HOCH2CHO+CO+HO2 : 2.0*1.9997*4.6D-4 * j(Pj_no2) ; +{030:J30} NUCARB12+hv=NOA+CO+CO+HO2+HO2 : 1.9997*4.6D-4 * j(Pj_no2) ; +{031:J31} NOA+hv=CH3CO3+HCHO+NO2 : 1.155*4.6D-4 * j(Pj_no2) + 0.4933*4.6D-4 * j(Pj_no2) ; +{032:J32} UDCARB8+hv=C2H5O2+HO2 : 0.02*j(Pj_no2) ; +{033:J33} UDCARB11+hv=RN10O2+HO2 : 0.02*j(Pj_no2) ; +{034:J34} UDCARB14+hv=RN13O2+HO2 : 0.02*j(Pj_no2) ; +{035:J35} TNCARB26+hv=RTN26O2+HO2 : 9.64_dp*j(pj_ch2or) ; +{036:J36} TNCARB10+hv=CH3CO3+CH3CO3+CO : 0.5*2.149*32.6088*4.6D-4 * j(Pj_no2); +{037:J37} CH3NO3+hv=HCHO+HO2+NO2 : 1.0D-4 * j(Pj_no2) ; +{038:J38} C2H5NO3+hv=CH3CHO+HO2+NO2 : 2.3248*7.8D-5 * j(Pj_no2) ; +{039:J39} RN10NO3+hv=C2H5CHO+HO2+NO2 : 3.079*7.8D-5 * j(Pj_no2) ; +{040:J40} IC3H7NO3+hv=CH3COCH3+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{041:J41} RN13NO3+hv= CH3CHO+C2H5O2+NO2 : 0.398*3.079*7.8D-5 * j(Pj_no2) ; +{042:J42} RN13NO3+hv= CARB11A+HO2+NO2 : 0.602*3.079*7.8D-5 * j(Pj_no2) ; +{043:J43} RN16NO3+hv=RN15O2+NO2 : 3.079*7.8D-5 * j(Pj_no2) ; +{044:J44} RN19NO3+hv=RN18O2+NO2 : 3.079*7.8D-5 * j(Pj_no2) ; +{045:J45} RA13NO3+hv=CARB3+UDCARB8+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{046:J46} RA16NO3+hv=CARB3+UDCARB11+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{047:J47} RA19NO3+hv=CARB6+UDCARB11+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{048:J48} RTX24NO3+hv=TXCARB22+HO2+NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{049:J49} CH3OOH+hv=HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{050:J50} C2H5OOH+hv=CH3CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{051:J51} RN10OOH+hv=C2H5CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{052:J52} IC3H7OOH+hv=CH3COCH3+HO2+OH : 0.7 * j(Pj_h2o2) ; +{053:J53} RN13OOH+hv= CH3CHO+C2H5O2+OH : 0.398*0.7 * j(Pj_h2o2) ; +{054:J54} RN13OOH+hv= CARB11A+HO2+OH : 0.602*0.7 * j(Pj_h2o2) ; +{055:J55} RN16OOH+hv=RN15AO2+OH : 0.7 * j(Pj_h2o2) ; +{056:J56} RN19OOH+hv=RN18AO2+OH : 0.7 * j(Pj_h2o2) ; +{057:J57} CH3CO3H+hv=CH3OO+OH : 0.7 * j(Pj_h2o2) ; +{058:J58} C2H5CO3H+hv=C2H5O2+OH : 0.7 * j(Pj_h2o2) ; +{059:J59} HOCH2CO3H+hv=HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{060:J60} RN8OOH+hv=C2H5O2+OH : 0.7 * j(Pj_h2o2) ; +{061:J61} RN11OOH+hv=RN10O2+OH : 0.7 * j(Pj_h2o2) ; +{062:J62} RN14OOH+hv=RN13O2+OH : 0.7 * j(Pj_h2o2) ; +{063:J63} RN17OOH+hv=RN16O2+OH : 0.7 * j(Pj_h2o2) ; +{064:J64} RU14OOH+hv=UCARB12+HO2+OH : 0.252*0.7 * j(Pj_h2o2) ; +{065:J65} RU14OOH+hv=UCARB10+HCHO+HO2+OH : 0.748*0.7 * j(Pj_h2o2) ; +{066:J66} RU12OOH+hv=CARB6+HOCH2CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{067:J67} RU10OOH+hv=CH3CO3+HOCH2CHO+OH : 0.7 * j(Pj_h2o2) ; +{068:J68} NRU14OOH+hv=NUCARB12+HO2+OH : 0.7 * j(Pj_h2o2) ; +{069:J69} NRU12OOH+hv=NOA+CO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{070:J70} HOC2H4OOH+hv=HCHO+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{071:J71} RN9OOH+hv=CH3CHO+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{072:J72} RN12OOH+hv=CH3CHO+CH3CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{073:J73} RN15OOH+hv=C2H5CHO+CH3CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{074:J74} RN18OOH+hv=C2H5CHO+C2H5CHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{075:J75} NRN6OOH+hv=HCHO+HCHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{076:J76} NRN9OOH+hv=CH3CHO+HCHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{077:J77} NRN12OOH+hv=CH3CHO+CH3CHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{078:J78} RA13OOH+hv=CARB3+UDCARB8+HO2+OH : 0.7 * j(Pj_h2o2) ; +{079:J79} RA16OOH+hv=CARB3+UDCARB11+HO2+OH : 0.7 * j(Pj_h2o2) ; +{080:J80} RA19OOH+hv=CARB6+UDCARB11+HO2+OH : 0.7 * j(Pj_h2o2) ; +{081:J81} RTN28OOH+hv=TNCARB26+HO2+OH : 0.7 * j(Pj_h2o2) ; +{082:J82} NRTN28OOH+hv=TNCARB26+NO2+OH : 0.7 * j(Pj_h2o2) ; +{083:J83} RTN26OOH+hv=RTN25O2+OH : 0.7 * j(Pj_h2o2) ; +{084:J84} RTN25OOH+hv=RTN24O2+OH : 0.7 * j(Pj_h2o2) ; +{085:J85} RTN24OOH+hv=RTN23O2+OH : 0.7 * j(Pj_h2o2) ; +{086:J86} RTN23OOH+hv=CH3COCH3+RTN14O2+OH : 0.7 * j(Pj_h2o2) ; +{087:J87} RTN14OOH+hv=TNCARB10+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{088:J88} RTN10OOH+hv=RN8O2+CO+OH : 0.7 * j(Pj_h2o2) ; +{089:J89} RTX28OOH+hv=TXCARB24+HCHO+HO2+OH : 0.7 * j(Pj_h2o2) ; +{090:J90} RTX24OOH+hv=TXCARB22+HO2+OH : 0.7 * j(Pj_h2o2) ; +{091:J90} RTX22OOH+hv=CH3COCH3+RN13O2+OH : 0.7 * j(Pj_h2o2) ; +{092:J90} NRTX28OOH+hv=TXCARB24+HCHO+NO2+OH : 0.7 * j(Pj_h2o2) ; +{093:J90} UDCARB8+hv=ANHY+HO2+HO2 : 0.02*0.36*j(Pj_no2) ; +{094:J90} UDCARB11+hv=ANHY+HO2+CH3OO : 0.02*0.45*j(Pj_no2) ; +{095:J90} UDCARB14+hv=ANHY+HO2+C2H5O2 : 0.02*0.45*j(Pj_no2) ; +{096:001} O3P+M{+O2}=O3 : .20946e0*(C_M *6.00D-34*(TEMP/300)**(-2.6)); +{097:002} CH3O2NO2=CH3OO+NO2 : RJPL(1.3D-30,4.0_dp,7.5D-12,2.0_dp,C_M,TEMP)/(1.3D-28*exp(11200._dp/TEMP)); +{098:003} O3P+O3=M {2O2} : ARR2( 8.00D-12, 2060.0_dp, TEMP) ; +{099:004} O3P+NO=NO2 : TROE( 9.00D-32 , 1.5_dp , 3.00D-11 , 0.0_dp , TEMP, C_M) ; +{100:005} O3P+NO2=NO : ARR2( 5.50D-12, -188.0_dp, TEMP) ; +{101:006} O3P+NO2=NO3 : TROE( 9.00D-32 , 2.0_dp , 2.20D-11 , 0.0_dp , TEMP, C_M) ; +{102:007} O1D+M{=O2,N2} =O3P{+O2, N2} : .20946e0* ARR2( 3.20D-11, -70.0_dp, TEMP)+ .78084* ARR2( 1.80D-11, -110.0_dp, TEMP) ; +{103:008} NO+O3=NO2 : ARR2( 1.40D-12, 1310.0_dp, TEMP) ; +{104:009} NO2+O3=NO3 : ARR2( 1.40D-13, 2470.0_dp, TEMP) ; +{105:010} NO+NO+M{=O2}=NO2+NO2 : .20946e0* ARR2( 3.30D-39, -530.0_dp, TEMP) ; +{106:011} NO+NO3=NO2+NO2 : ARR2( 1.80D-11, -110.0_dp, TEMP) ; +{107:012} NO2+NO3=NO+NO2 : ARR2( 4.50D-14, 1260.0_dp, TEMP) ; +{108:013} NO2+NO3=N2O5 : TROE( 2.20D-30 , 3.9_dp , 1.50D-12 , 0.7_dp , TEMP, C_M) ; +{109:014} N2O5=NO3+NO2 : TROEE(3.70D26,11000.0_dp, 2.20D-30 , 3.9_dp , 1.50D-12 , 0.7_dp , TEMP, C_M ) ; +{110:015} O1D+H2O=OH+OH : 2.20D-10 ; +{111:016} OH+O3=HO2 : ARR2( 1.70D-12, 940.0_dp, TEMP) ; +{112:017} OH+M = HO2+H2O : 5.31D-7*ARR2( 7.70D-12, 2100.0_dp, TEMP) ; +{113:018} OH+CO=HO2 : 1.20D-13*(1.0 + ((0.6*C_M)/(2.652d+19*(273.0/temp)))) ; +{114:019} OH+H2O2=HO2 : ARR2( 2.90D-12, 160.0_dp, TEMP) ; +{115:020} HO2+O3=OH : 2.03D-16*((TEMP/300)**4.57)*EXP(693/TEMP) ; +{116:021} OH+HO2=H2O{+O2} : ARR2( 4.80D-11, -250.0_dp, TEMP) ; +{117:022} HO2+HO2=H2O2 : (2.2D-13*EXP(600./TEMP) + 1.9D-33* C_M *EXP(980._dp/TEMP)) ; +{118:023} HO2+HO2+H2O=H2O2 : (3.08D-34* EXP(2800._dp/TEMP)+ 2.66D-54* C_M *EXP(3180._dp/TEMP)) ; +{119:024} OH+NO=HONO : KMT_OH_NO( TEMP, C_M) ; +{120:025} OH+NO2=HNO3 : TROE( 2.60D-30 , 3.2_dp , 2.40D-11 , 1.3_dp , TEMP, C_M) ; +{121:026} OH+NO3=HO2+NO2 : 2.00D-11 ; +{122:027} HO2+NO=OH+NO2 : ARR2( 3.60D-12, -270.0_dp, TEMP) ; +{123:028} HO2+NO2=HNO4 : TROE( 1.80D-31 , 3.2_dp , 4.70D-12 , 1.4_dp , TEMP, C_M) ; +{124:029} HNO4=NO2+HO2 : TROEE( 4.76D26,10900.0_dp, 1.80D-31 , 3.2_dp , 4.70D-12 , 1.4_dp , TEMP, C_M ) ; +{125:030} OH+HNO4=NO2 : ARR2( 1.90D-12, -270.0_dp, TEMP) ; +{126:031} HO2+NO3=OH+NO2 : 4.00D-12 ; +{127:032} OH+HONO=NO2 : ARR2( 2.50D-12, -260.0_dp, TEMP) ; +{128:033} OH+HNO3=NO3 : k46(TEMP,C_M) ; +{129:034} O3P+SO2=SO3 : C_M*ARR2( 4.00D-32, 1000.0_dp, TEMP) ; +{130:035} OH+SO2=HSO3 : K47(TEMP,C_M) ; +{131:036} HSO3+M{=O2}=HO2+SO3 : .20946e0* ARR2( 1.30D-12, -330.0_dp, TEMP) ; +{134:039} SO3 + H2O + H2O = H2SO4 : ARR2(3.9d-41,-6830.6_dp,TEMP) ; {Jayne et al (1997) rate} +{135:040} OH+CH4=CH3OO : 9.65D-20*TEMP**2.58*EXP(-1082/TEMP) ; +{136:041} OH+C2H6=C2H5O2 : 1.52D-17*TEMP**2*EXP(-498/TEMP) ; +{137:042} OH+C3H8=IC3H7O2 : 1.55D-17*TEMP**2*EXP(-61/TEMP)*0.736 ; +{138:043} OH+C3H8=RN10O2 : 1.55D-17*TEMP**2*EXP(-61/TEMP)*0.264 ; +{139:044} OH+NC4H10=RN13O2 : 1.69D-17*TEMP**2*EXP(145/TEMP) ; +{140:045} OH+C2H4=HOCH2CH2O2 : KMT_IUPAC(8.6D-29, 3.1_dp, 9.0D-12, 0.85_dp, 0.48_dp, TEMP,C_M) ; +{141:046} OH+C3H6=RN9O2 : KMT_IUPAC(8.0D-27, 3.5_dp, 3.0D-11, 1.0_dp, 0.5_dp, TEMP,C_M) ; +{142:047} OH+TBUT2ENE=RN12O2 : ARR2( 1.01D-11, -550.0_dp, TEMP) ; +{143:048} NO3+C2H4=NRN6O2 : 2.10D-16 ; +{144:049} NO3+C3H6=NRN9O2 : 9.40D-15 ; +{145:050} NO3+TBUT2ENE=NRN12O2 : 3.90D-13 ; +{146:051} O3+C2H4=HCHO+CO+HO2+OH : 0.13*ARR2( 9.14D-15, 2580.0_dp, TEMP) ; +{147:052} O3+C2H4=HCHO+HCOOH : 0.87*ARR2( 9.14D-15, 2580.0_dp, TEMP) ; +{148:053} O3+C3H6=HCHO+CO+CH3OO+OH : 0.36*ARR2( 5.51D-15, 1878.0_dp, TEMP) ; +{149:054} O3+C3H6=HCHO+CH3CO2H : 0.64*ARR2( 5.51D-15, 1878.0_dp, TEMP) ; +{150:055} O3+TBUT2ENE=CH3CHO+CO+CH3OO+OH : 0.69*ARR2( 6.64D-15, 1059.0_dp, TEMP) ; +{151:056} O3+TBUT2ENE=CH3CHO+CH3CO2H : 0.31*ARR2( 6.64D-15, 1059.0_dp, TEMP) ; +{152:057} OH+C5H8=RU14O2 : ARR2( 2.54D-11, -410.0_dp, TEMP) ; +{153:058} NO3+C5H8=NRU14O2 : ARR2( 3.03D-12, 446.0_dp, TEMP) ; +{154:059} O3+C5H8=UCARB10+CO+HO2+OH : 0.27*ARR2( 7.86D-15, 1913.0_dp, TEMP) ; +{155:060} O3+C5H8=UCARB10+HCOOH : 0.73*ARR2( 7.86D-15, 1913.0_dp, TEMP) ; +{156:061} APINENE+OH=RTN28O2 : ARR2( 1.20D-11, -444.0_dp, TEMP) ; +{157:062} APINENE+NO3=NRTN28O2 : ARR2( 1.19D-12, -490.0_dp, TEMP) ; +{158:063} APINENE+O3=OH+CH3COCH3+RN18AO2 : 0.80*ARR2( 1.01D-15, 732.0_dp, TEMP) ; +{159:064} APINENE+O3=TNCARB26+H2O2 : 0.075*ARR2( 1.01D-15, 732.0_dp, TEMP) ; +{160:065} APINENE+O3=RCOOH25 : 0.125*ARR2( 1.01D-15, 732.0_dp, TEMP) ; +{161:066} BPINENE+OH=RTX28O2 : ARR2( 2.38D-11, -357.0_dp, TEMP) ; +{162:067} BPINENE+NO3=NRTX28O2 : 2.51D-12 ; +{163:068} BPINENE+O3= RTX24O2+OH : 1.50D-17*0.35 ; +{164:069} BPINENE+O3= HCHO+TXCARB24+H2O2 : 1.50D-17*0.20 ; +{165:070} BPINENE+O3= HCHO+TXCARB22 : 1.50D-17*0.25 ; +{166:071} BPINENE+O3= TXCARB24+CO : 1.50D-17*0.20 ; +{167:072} C2H2+OH=HCOOH+CO+HO2 : 0.364*KMT_IUPAC(5.0D-30, 1.5_dp, 1.0D-12, 0.0_dp, 0.37_dp, TEMP,C_M) ; +{168:073} C2H2+OH=CARB3+OH : 0.636*KMT_IUPAC(5.0D-30, 1.5_dp, 1.0D-12, 0.0_dp, 0.37_dp, TEMP,C_M) ; +{169:074} BENZENE+OH=RA13O2 : 0.47*ARR2( 2.33D-12, 193.0_dp, TEMP) ; +{170:075} BENZENE+OH=AROH14+HO2 : 0.53*ARR2( 2.33D-12, 193.0_dp, TEMP) ; +{171:076} TOLUENE+OH=RA16O2 : 0.82*ARR2( 1.81D-12, -338.0_dp, TEMP) ; +{172:077} TOLUENE+OH=AROH17+HO2 : 0.18*ARR2( 1.81D-12, -338.0_dp, TEMP) ; +{173:078} OXYL+OH=RA19AO2 : 1.36D-11*0.70 ; +{174:079} OXYL+OH=RA19CO2 : 1.36D-11*0.30 ; +{175:080} OH+HCHO=HO2+CO : 1.20D-14*TEMP*EXP(287/TEMP) ; +{176:081} OH+CH3CHO=CH3CO3 : ARR2( 5.55D-12, -311.0_dp, TEMP) ; +{177:082} OH+C2H5CHO=C2H5CO3 : 1.96D-11 ; +{178:083} NO3+HCHO=HO2+CO+HNO3 : 5.80D-16 ; +{179:084} NO3+CH3CHO=CH3CO3+HNO3 : 1.44d-12*EXP(-1862.0/temp) ; +{180:085} NO3+C2H5CHO=C2H5CO3+HNO3 : 1.44d-12*EXP(-1862.0/temp)*2.4 ; +{181:086} OH+CH3COCH3=RN8O2 : 5.34D-18*TEMP**2*EXP(-230/TEMP) ; +{182:087} MEK+OH=RN11O2 : 3.24D-18*TEMP**2*EXP(414/TEMP) ; +{183:088} OH+CH3OH=HO2+HCHO : 6.01D-18*TEMP**2*EXP(170/TEMP) ; +{184:089} OH+C2H5OH=CH3CHO+HO2 : 6.18D-18*TEMP**2*EXP(532/TEMP)*0.887 ; +{185:090} OH+C2H5OH=HOCH2CH2O2 : 6.18D-18*TEMP**2*EXP(532/TEMP)*0.113 ; +{186:091} NPROPOL+OH=C2H5CHO+HO2 : 5.53D-12*0.49 ; +{187:092} NPROPOL+OH=RN9O2 : 5.53D-12*0.51 ; +{188:093} OH+IPROPOL=CH3COCH3+HO2 : 4.06D-18*TEMP**2*EXP(788/TEMP)*0.86 ; +{189:094} OH+IPROPOL=RN9O2 : 4.06D-18*TEMP**2*EXP(788/TEMP)*0.14 ; +{190:095} HCOOH+OH=HO2 : 4.50D-13 ; +{191:096} CH3CO2H+OH=CH3OO : 8.00D-13 ; +{192:097} CH3OO+NO=HCHO+HO2+NO2 : 0.999*ARR2( 3.00D-12, -280.0_dp, TEMP) ; +{193:098} C2H5O2+NO=CH3CHO+HO2+NO2 : 0.991*ARR2( 2.60D-12, -365.0_dp, TEMP) ; +{194:099} RN10O2+NO=C2H5CHO+HO2+NO2 : 0.980*ARR2( 2.80D-12, -360.0_dp, TEMP) ; +{195:100} IC3H7O2+NO=CH3COCH3+HO2+NO2 : 0.958*ARR2( 2.70D-12, -360.0_dp, TEMP) ; +{196:101} RN13O2+NO=CH3CHO+C2H5O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.917*0.398 ; +{197:102} RN13O2+NO=CARB11A+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.917*0.602 ; +{198:103} RN16O2+NO=RN15AO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.877 ; +{199:104} RN19O2+NO=RN18AO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.788 ; +{200:105} RN13AO2+NO=RN12O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{201:106} RN16AO2+NO=RN15O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{202:107} RA13O2+NO=CARB3+UDCARB8+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.918 ; +{203:108} RA16O2+NO=CARB3+UDCARB11+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.889*0.7 ; +{204:109} RA16O2+NO=CARB6+UDCARB8+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.889*0.3 ; +{205:110} RA19AO2+NO=CARB3+UDCARB14+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.862 ; +{206:111} RA19CO2+NO=CARB9+UDCARB8+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.862 ; +{207:112} HOCH2CH2O2+NO=HCHO+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.995*0.776 ; +{208:113} HOCH2CH2O2+NO=HOCH2CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.995*0.224 ; +{209:114} RN9O2+NO=CH3CHO+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.979 ; +{210:115} RN12O2+NO=CH3CHO+CH3CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.959 ; +{211:116} RN15O2+NO=C2H5CHO+CH3CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.936 ; +{212:117} RN18O2+NO=C2H5CHO+C2H5CHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.903 ; +{213:118} RN15AO2+NO=CARB13+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.975 ; +{214:119} RN18AO2+NO=CARB16+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.946 ; +{215:120} CH3CO3+NO=CH3OO+NO2 : 8.10d-12*EXP(270.0/temp) ; +{216:121} C2H5CO3+NO=C2H5O2+NO2 : 8.10d-12*EXP(270.0/temp) ; +{217:122} HOCH2CO3+NO=HO2+HCHO+NO2 : 8.10d-12*EXP(270.0/temp) ; +{218:123} RN8O2+NO=CH3CO3+HCHO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{219:124} RN11O2+NO=CH3CO3+CH3CHO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{220:125} RN14O2+NO=C2H5CO3+CH3CHO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{221:126} RN17O2+NO=RN16AO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{222:127} RU14O2+NO=UCARB12+HO2+ NO2 : 2.40d-12*EXP(360.0/temp)*0.900*0.252 ; +{223:128} RU14O2+NO=UCARB10+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.900*0.748 ; +{224:129} RU12O2+NO=CH3CO3+HOCH2CHO+NO2 : 2.40d-12*EXP(360.0/temp)*0.7 ; +{225:130} RU12O2+NO=CARB7+CO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.3 ; +{226:131} RU10O2+NO=CH3CO3+HOCH2CHO+NO2 : 2.40d-12*EXP(360.0/temp)*0.5 ; +{227:132} RU10O2+NO=CARB6+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.3 ; +{228:133} RU10O2+NO=CARB7+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.2 ; +{229:134} NRN6O2+NO=HCHO+HCHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{230:135} NRN9O2+NO=CH3CHO+HCHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{231:136} NRN12O2+NO=CH3CHO+CH3CHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{232:137} NRU14O2+NO=NUCARB12+HO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{233:138} NRU12O2+NO=NOA+CO+HO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{234:139} RTN28O2+NO=TNCARB26+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.915 ; +{235:140} RTN28O2+NO=CH3COCH3+RN19O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.085 ; +{236:141} NRTN28O2+NO=TNCARB26+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{237:142} RTN26O2+NO=RTN25O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{238:143} RTN25O2+NO=RTN24O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.840 ; +{239:144} RTN24O2+NO=RTN23O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{240:145} RTN23O2+NO=CH3COCH3+RTN14O2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{241:146} RTN14O2+NO=HCHO+TNCARB10+HO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{242:147} RTN10O2+NO=RN8O2+CO+NO2 : 2.40d-12*EXP(360.0/temp) ; +{243:148} RTX28O2+NO=TXCARB24+HCHO+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.915 ; +{244:149} RTX28O2+NO=CH3COCH3+RN19O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.767*0.085 ; +{245:150} NRTX28O2+NO=TXCARB24+HCHO+NO2+NO2 : 2.40d-12*EXP(360.0/temp) ; +{246:151} RTX24O2+NO=TXCARB22+HO2+NO2 : 2.40d-12*EXP(360.0/temp)*0.843*0.6 ; +{247:152} RTX24O2+NO=CH3COCH3+RN13AO2+HCHO+NO2 : 2.40d-12*EXP(360.0/temp)*0.843*0.4 ; +{248:153} RTX22O2+NO=CH3COCH3+RN13O2+NO2 : 2.40d-12*EXP(360.0/temp)*0.700 ; +{249:154} CH3OO+NO=CH3NO3 : 0.001*ARR2( 3.00D-12, -280.0_dp, TEMP) ; +{250:155} C2H5O2+NO=C2H5NO3 : 0.009*ARR2( 2.60D-12, -365.0_dp, TEMP) ; +{251:156} RN10O2+NO=RN10NO3 : 0.020*ARR2( 2.80D-12, -360.0_dp, TEMP) ; +{252:157} IC3H7O2+NO=IC3H7NO3 : 0.042*ARR2( 2.70D-12, -360.0_dp, TEMP) ; +{253:158} RN13O2+NO=RN13NO3 : 2.40d-12*EXP(360.0/temp)*0.083 ; +{254:159} RN16O2+NO=RN16NO3 : 2.40d-12*EXP(360.0/temp)*0.123 ; +{255:160} RN19O2+NO=RN19NO3 : 2.40d-12*EXP(360.0/temp)*0.212 ; +{256:161} HOCH2CH2O2+NO=HOC2H4NO3 : 2.40d-12*EXP(360.0/temp)*0.005 ; +{257:162} RN9O2+NO=RN9NO3 : 2.40d-12*EXP(360.0/temp)*0.021 ; +{258:163} RN12O2+NO=RN12NO3 : 2.40d-12*EXP(360.0/temp)*0.041 ; +{259:164} RN15O2+NO=RN15NO3 : 2.40d-12*EXP(360.0/temp)*0.064 ; +{260:165} RN18O2+NO=RN18NO3 : 2.40d-12*EXP(360.0/temp)*0.097 ; +{261:166} RN15AO2+NO=RN15NO3 : 2.40d-12*EXP(360.0/temp)*0.025 ; +{262:167} RN18AO2+NO=RN18NO3 : 2.40d-12*EXP(360.0/temp)*0.054 ; +{263:168} RU14O2+NO=RU14NO3 : 2.40d-12*EXP(360.0/temp)*0.100 ; +{264:169} RA13O2+NO=RA13NO3 : 2.40d-12*EXP(360.0/temp)*0.082 ; +{265:170} RA16O2+NO=RA16NO3 : 2.40d-12*EXP(360.0/temp)*0.111 ; +{266:171} RA19AO2+NO=RA19NO3 : 2.40d-12*EXP(360.0/temp)*0.138 ; +{267:172} RA19CO2+NO=RA19NO3 : 2.40d-12*EXP(360.0/temp)*0.138 ; +{268:173} RTN28O2+NO=RTN28NO3 : 2.40d-12*EXP(360.0/temp)*0.233 ; +{269:174} RTN25O2+NO=RTN25NO3 : 2.40d-12*EXP(360.0/temp)*0.160 ; +{270:175} RTX28O2+NO=RTX28NO3 : 2.40d-12*EXP(360.0/temp)*0.233 ; +{271:176} RTX24O2+NO=RTX24NO3 : 2.40d-12*EXP(360.0/temp)*0.157 ; +{272:177} RTX22O2+NO=RTX22NO3 : 2.40d-12*EXP(360.0/temp)*0.300 ; +{273:178} CH3OO+NO3=HCHO+HO2+NO2 : 2.50d-12*0.40 ; +{274:179} C2H5O2+NO3=CH3CHO+HO2+NO2 : 2.50d-12 ; +{275:180} RN10O2+NO3=C2H5CHO+HO2+NO2 : 2.50d-12 ; +{276:181} IC3H7O2+NO3=CH3COCH3+HO2+NO2 : 2.50d-12 ; +{277:182} RN13O2+NO3=CH3CHO+C2H5O2+NO2 : 2.50d-12*0.398 ; +{278:183} RN13O2+NO3=CARB11A+HO2+NO2 : 2.50d-12*0.602 ; +{279:184} RN16O2+NO3=RN15AO2+NO2 : 2.50d-12 ; +{280:185} RN19O2+NO3=RN18AO2+NO2 : 2.50d-12 ; +{281:186} RN13AO2+NO3=RN12O2+NO2 : 2.50d-12 ; +{282:187} RN16AO2+NO3=RN15O2+NO2 : 2.50d-12 ; +{283:188} RA13O2+NO3=CARB3+UDCARB8+HO2+NO2 : 2.50d-12 ; +{284:189} RA16O2+NO3=CARB3+UDCARB11+HO2+NO2 : 2.50d-12*0.7 ; +{285:190} RA16O2+NO3=CARB6+UDCARB8+HO2+NO2 : 2.50d-12*0.3 ; +{286:191} RA19AO2+NO3=CARB3+UDCARB14+HO2+NO2 : 2.50d-12 ; +{287:192} RA19CO2+NO3=CARB9+UDCARB8+HO2+NO2 : 2.50d-12 ; +{288:193} HOCH2CH2O2+NO3=HCHO+HCHO+HO2+NO2 : 2.50d-12*0.776 ; +{289:194} HOCH2CH2O2+NO3=HOCH2CHO+HO2+NO2 : 2.50d-12*0.224 ; +{290:195} RN9O2+NO3=CH3CHO+HCHO+HO2+NO2 : 2.50d-12 ; +{291:196} RN12O2+NO3=CH3CHO+CH3CHO+HO2+NO2 : 2.50d-12 ; +{292:197} RN15O2+NO3=C2H5CHO+CH3CHO+HO2+NO2 : 2.50d-12 ; +{293:198} RN18O2+NO3=C2H5CHO+C2H5CHO+HO2+NO2 : 2.50d-12; +{294:199} RN15AO2+NO3=CARB13+HO2+NO2 : 2.50d-12 ; +{295:200} RN18AO2+NO3=CARB16+HO2+NO2 : 2.50d-12 ; +{296:201} CH3CO3+NO3=CH3OO+NO2 : 2.50d-12*1.60 ; +{297:202} C2H5CO3+NO3=C2H5O2+NO2 : 2.50d-12*1.60 ; +{298:203} HOCH2CO3+NO3=HO2+HCHO+NO2 : 2.50d-12*1.60 ; +{299:204} RN8O2+NO3=CH3CO3+HCHO+NO2 : 2.50d-12 ; +{300:205} RN11O2+NO3=CH3CO3+CH3CHO+NO2 : 2.50d-12 ; +{301:206} RN14O2+NO3=C2H5CO3+CH3CHO+NO2 : 2.50d-12 ; +{302:207} RN17O2+NO3=RN16AO2+NO2 : 2.50d-12 ; +{303:208} RU14O2+NO3=UCARB12+HO2+NO2 : 2.50d-12*0.252 ; +{304:209} RU14O2+NO3=UCARB10+HCHO+HO2+NO2 : 2.50d-12*0.748 ; +{305:210} RU12O2+NO3=CH3CO3+HOCH2CHO+NO2 : 2.50d-12*0.7 ; +{306:211} RU12O2+NO3=CARB7+CO+HO2+NO2 : 2.50d-12*0.3 ; +{307:212} RU10O2+NO3=CH3CO3+HOCH2CHO+NO2 : 2.50d-12*0.5 ; +{308:213} RU10O2+NO3=CARB6+HCHO+HO2+NO2 : 2.50d-12*0.3 ; +{309:214} RU10O2+NO3=CARB7+HCHO+HO2+NO2 : 2.50d-12*0.2 ; +{310:215} NRN6O2+NO3=HCHO+HCHO+NO2+NO2 : 2.50d-12 ; +{311:216} NRN9O2+NO3=CH3CHO+HCHO+NO2+NO2 : 2.50d-12 ; +{312:217} NRN12O2+NO3=CH3CHO+CH3CHO+NO2+NO2 : 2.50d-12 ; +{313:218} NRU14O2+NO3=NUCARB12+HO2+NO2 : 2.50d-12 ; +{314:219} NRU12O2+NO3=NOA+CO+HO2+NO2 : 2.50d-12 ; +{315:220} RTN28O2+NO3=TNCARB26+HO2+NO2 : 2.50d-12 ; +{316:221} NRTN28O2+NO3=TNCARB26+NO2+NO2 : 2.50d-12 ; +{317:222} RTN26O2+NO3=RTN25O2+NO2 : 2.50d-12 ; +{318:223} RTN25O2+NO3=RTN24O2+NO2 : 2.50d-12 ; +{319:224} RTN24O2+NO3=RTN23O2+NO2 : 2.50d-12 ; +{320:225} RTN23O2+NO3=CH3COCH3+RTN14O2+NO2 : 2.50d-12 ; +{321:226} RTN14O2+NO3=HCHO+TNCARB10+HO2+NO2 : 2.50d-12 ; +{322:227} RTN10O2+NO3=RN8O2+CO+NO2 : 2.50d-12 ; +{323:228} RTX28O2+NO3=TXCARB24+HCHO+HO2+NO2 : 2.50d-12 ; +{324:229} RTX24O2+NO3=TXCARB22+HO2+NO2 : 2.50d-12 ; +{325:230} RTX22O2+NO3=CH3COCH3+RN13O2+NO2 : 2.50d-12 ; +{326:231} NRTX28O2+NO3=TXCARB24+HCHO+NO2+NO2 : 2.50d-12 ; +{327:232} CH3OO+HO2=CH3OOH : ARR2( 3.80D-13, -780.0_dp, TEMP) ; +{328:233} C2H5O2+HO2=C2H5OOH : ARR2( 7.50D-13, -700.0_dp, TEMP) ; +{329:234} RN10O2+HO2=RN10OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{330:235} IC3H7O2+HO2=IC3H7OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{331:236} RN13O2+HO2=RN13OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{332:237} RN16O2+HO2=RN16OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{333:238} RN19O2+HO2=RN19OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{334:239} RN13AO2+HO2=RN13OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{335:240} RN16AO2+HO2=RN16OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{336:241} RA13O2+HO2=RA13OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{337:242} RA16O2+HO2=RA16OOH : 0.820*2.91d-13*EXP(1300.0/temp) ; +{338:243} RA19AO2+HO2=RA19OOH : 0.859*2.91d-13*EXP(1300.0/temp) ; +{339:244} RA19CO2+HO2=RA19OOH : 0.859*2.91d-13*EXP(1300.0/temp) ; +{340:245} HOCH2CH2O2+HO2=HOC2H4OOH : ARR2( 2.03D-13, -1250.0_dp, TEMP) ; +{341:246} RN9O2+HO2=RN9OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{342:247} RN12O2+HO2=RN12OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{343:248} RN15O2+HO2=RN15OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{344:249} RN18O2+HO2=RN18OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{345:250} RN15AO2+HO2=RN15OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{346:251} RN18AO2+HO2=RN18OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{347:252} CH3CO3+HO2=CH3CO3H : 4.30d-13*EXP(1040.0/temp) ; +{348:253} C2H5CO3+HO2=C2H5CO3H : 4.30d-13*EXP(1040.0/temp) ; +{349:254} HOCH2CO3+HO2=HOCH2CO3H : 4.30d-13*EXP(1040.0/temp) ; +{350:255} RN8O2+HO2=RN8OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{351:256} RN11O2+HO2=RN11OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{352:257} RN14O2+HO2=RN14OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{353:258} RN17O2+HO2=RN17OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{354:258} RU14O2+HO2=RU14OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{355:260} RU12O2+HO2=RU12OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{356:261} RU10O2+HO2=RU10OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{357:262} NRN6O2+HO2=NRN6OOH : 0.387*2.91d-13*EXP(1300.0/temp) ; +{358:263} NRN9O2+HO2=NRN9OOH : 0.520*2.91d-13*EXP(1300.0/temp) ; +{359:264} NRN12O2+HO2=NRN12OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{360:265} NRU14O2+HO2=NRU14OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{361:266} NRU12O2+HO2=NRU12OOH : 0.625*2.91d-13*EXP(1300.0/temp) ; +{362:267} RTN28O2+HO2=RTN28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{363:268} NRTN28O2+HO2=NRTN28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{364:269} RTN26O2+HO2=RTN26OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{365:270} RTN25O2+HO2=RTN25OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{366:271} RTN24O2+HO2=RTN24OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{367:272} RTN23O2+HO2=RTN23OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{368:273} RTN14O2+HO2=RTN14OOH : 0.770*2.91d-13*EXP(1300.0/temp) ; +{369:274} RTN10O2+HO2=RTN10OOH : 0.706*2.91d-13*EXP(1300.0/temp) ; +{370:275} RTX28O2+HO2=RTX28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{371:276} RTX24O2+HO2=RTX24OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{372:277} RTX22O2+HO2=RTX22OOH : 0.890*2.91d-13*EXP(1300.0/temp) ; +{373:278} NRTX28O2+HO2=NRTX28OOH : 0.914*2.91d-13*EXP(1300.0/temp) ; +{374:279} CH3OO=HCHO+HO2 : 0.33*RO2*ARR2( 1.82D-13, -416.0_dp, TEMP) ; +{375:280} CH3OO=HCHO : 0.335*RO2*ARR2( 1.82D-13, -416.0_dp, TEMP) ; +{376:281} CH3OO=CH3OH : 0.335*RO2*ARR2( 1.82D-13, -416.0_dp, TEMP) ; +{377:282} C2H5O2=CH3CHO+HO2 : 3.10D-13*0.6*RO2 ; +{378:283} C2H5O2=CH3CHO : 3.10D-13*0.2*RO2 ; +{379:284} C2H5O2=C2H5OH : 3.10D-13*0.2*RO2 ; +{380:285} RN10O2=C2H5CHO+HO2 : 6.00D-13*0.6*RO2 ; +{381:286} RN10O2=C2H5CHO : 6.00D-13*0.2*RO2 ; +{382:287} RN10O2=NPROPOL : 6.00D-13*0.2*RO2 ; +{383:288} IC3H7O2=CH3COCH3+HO2 : 4.00D-14*0.6*RO2 ; +{384:289} IC3H7O2=CH3COCH3 : 4.00D-14*0.2*RO2 ; +{385:290} IC3H7O2=IPROPOL : 4.00D-14*0.2*RO2 ; +{386:291} RN13O2=CH3CHO+C2H5O2 : 2.50D-13*RO2*0.398 ; +{387:292} RN13O2=CARB11A+HO2 : 2.50D-13*RO2*0.602 ; +{388:293} RN13AO2=RN12O2 : 8.80D-13*RO2 ; +{389:294} RN16AO2=RN15O2 : 8.80D-13*RO2 ; +{390:295} RA13O2=CARB3+UDCARB8+HO2 : 8.80D-13*RO2 ; +{391:296} RA16O2=CARB3+UDCARB11+HO2 : 8.80D-13*RO2*0.7 ; +{392:297} RA16O2=CARB6+UDCARB8+HO2 : 8.80D-13*RO2*0.3 ; +{393:298} RA19AO2=CARB3+UDCARB14+HO2 : 8.80D-13*RO2 ; +{394:299} RA19CO2=CARB3+UDCARB14+HO2 : 8.80D-13*RO2 ; +{395:300} RN16O2=RN15AO2 : 2.50D-13*RO2 ; +{396:301} RN19O2=RN18AO2 : 2.50D-13*RO2 ; +{397:302} HOCH2CH2O2=HCHO+HCHO+HO2 : 2.00D-12*RO2*0.776 ; +{398:303} HOCH2CH2O2=HOCH2CHO+HO2 : 2.00D-12*RO2*0.224 ; +{399:304} RN9O2=CH3CHO+HCHO+HO2 : 8.80D-13*RO2 ; +{400:305} RN12O2=CH3CHO+CH3CHO+HO2 : 8.80D-13*RO2 ; +{401:306} RN15O2=C2H5CHO+CH3CHO+HO2 : 8.80D-13*RO2 ; +{402:307} RN18O2=C2H5CHO+C2H5CHO+HO2 : 8.80D-13*RO2 ; +{403:308} RN15AO2=CARB13+HO2 : 8.80D-13*RO2 ; +{404:309} RN18AO2=CARB16+HO2 : 8.80D-13*RO2 ; +{405:310} CH3CO3=CH3OO : 1.00D-11*RO2 ; +{406:311} C2H5CO3=C2H5O2 : 1.00D-11*RO2 ; +{407:312} HOCH2CO3=HCHO+HO2 : 1.00D-11*RO2 ; +{408:313} RN8O2=CH3CO3+HCHO : 1.40D-12*RO2 ; +{409:314} RN11O2=CH3CO3+CH3CHO : 1.40D-12*RO2 ; +{410:315} RN14O2=C2H5CO3+CH3CHO : 1.40D-12*RO2 ; +{411:316} RN17O2=RN16AO2 : 1.40D-12*RO2 ; +{412:317} RU14O2=UCARB12+HO2 : 1.71D-12*RO2*0.252 ; +{413:318} RU14O2=UCARB10+HCHO+HO2 : 1.71D-12*RO2*0.748 ; +{414:319} RU12O2=CH3CO3+HOCH2CHO : 2.00D-12*RO2*0.7 ; +{415:320} RU12O2=CARB7+HOCH2CHO+HO2 : 2.00D-12*RO2*0.3 ; +{416:321} RU10O2=CH3CO3+HOCH2CHO : 2.00D-12*RO2*0.5 ; +{417:322} RU10O2=CARB6+HCHO+HO2 : 2.00D-12*RO2*0.3 ; +{418:323} RU10O2=CARB7+HCHO+HO2 : 2.00D-12*RO2*0.2 ; +{419:324} NRN6O2=HCHO+HCHO+NO2 : 6.00D-13*RO2 ; +{420:325} NRN9O2=CH3CHO+HCHO+NO2 : 2.30D-13*RO2 ; +{421:326} NRN12O2=CH3CHO+CH3CHO+NO2 : 2.50D-13*RO2 ; +{422:327} NRU14O2=NUCARB12+HO2 : 1.30D-12*RO2 ; +{423:328} NRU12O2=NOA+CO+HO2 : 9.60D-13*RO2 ; +{424:329} RTN28O2=TNCARB26+HO2 : 2.85D-13*RO2 ; +{425:330} NRTN28O2=TNCARB26+NO2 : 1.00D-13*RO2 ; +{426:331} RTN26O2=RTN25O2 : 2.00D-12*RO2 ; +{427:332} RTN25O2=RTN24O2 : 1.30D-12*RO2 ; +{428:333} RTN24O2=RTN23O2 : 6.70D-15*RO2 ; +{429:334} RTN23O2=CH3COCH3+RTN14O2 : 6.70D-15*RO2 ; +{430:335} RTN14O2=HCHO+TNCARB10+HO2 : 8.80D-13*RO2 ; +{431:336} RTN10O2=RN8O2+CO : 2.00D-12*RO2 ; +{432:337} RTX28O2=TXCARB24+HCHO+HO2 : 2.00D-12*RO2 ; +{433:338} RTX24O2=TXCARB22+HO2 : 2.50D-13*RO2 ; +{434:339} RTX22O2=CH3COCH3+RN13O2 : 2.50D-13*RO2 ; +{435:340} NRTX28O2=TXCARB24+HCHO+NO2 : 9.20D-14*RO2 ; +{436:341} OH+CARB14=RN14O2 : 1.87D-11 ; +{437:342} OH+CARB17=RN17O2 : 4.36D-12 ; +{438:343} OH+CARB11A=RN11O2 : 3.24D-18*TEMP**2*EXP(414/TEMP) ; +{439:344} OH+CARB7=CARB6+HO2 : 3.00D-12 ; +{440:345} OH+CARB10=CARB9+HO2 : 5.86D-12 ; +{441:346} OH+CARB13=RN13O2 : 1.65D-11 ; +{442:347} OH+CARB16=RN16O2 : 1.25D-11 ; +{443:348} OH+UCARB10=RU10O2 : 2.50D-11 ; +{444:349} NO3+UCARB10=RU10O2+HNO3 : 1.44d-12*EXP(-1862.0/temp) ; +{445:350} O3+UCARB10=HCHO+CH3CO3+CO+OH : 2.85D-18*0.59 ; +{446:351} O3+UCARB10=HCHO+CARB6+H2O2 : 2.85D-18*0.41 ; +{447:352} OH+HOCH2CHO=HOCH2CO3 : 1.00D-11 ; +{448:353} NO3+HOCH2CHO=HOCH2CO3+HNO3 : 1.44d-12*EXP(-1862.0/temp) ; +{449:354} OH+CARB3=CO+CO+HO2 : 1.14D-11 ; +{450:355} OH+CARB6=CH3CO3+CO : 1.72D-11 ; +{451:356} OH+CARB9=RN9O2 : 2.40D-13 ; +{452:357} OH+CARB12=RN12O2 : 1.38D-12 ; +{453:358} OH+CARB15=RN15O2 : 4.81D-12 ; +{454:359} OH+CCARB12=RN12O2 : 4.79D-12 ; +{455:360} OH+UCARB12=RU12O2 : 4.52D-11 ; +{456:361} NO3+UCARB12=RU12O2+HNO3 : 1.44d-12*EXP(-1862.0/temp)*4.25 ; +{457:362} O3+UCARB12=HOCH2CHO+CH3CO3+CO+OH : 2.40D-17*0.89 ; +{458:363} O3+UCARB12=HOCH2CHO+CARB6+H2O2 : 2.40D-17*0.11 ; +{459:364} OH+NUCARB12=NRU12O2 : 4.16D-11 ; +{460:365} OH+NOA=CARB6+NO2 : 1.30D-13 ; +{461:366} OH+UDCARB8=C2H5O2 : 5.20D-11*0.5 ; +{462:367} OH+UDCARB11=RN10O2 : 5.58D-11*0.55 ; +{463:368} OH+UDCARB14=RN13O2 : 7.00D-11*0.55 ; +{464:369} OH+TNCARB26=RTN26O2 : 4.20D-11 ; +{465:370} OH+TNCARB15=RN15AO2 : 1.00D-12 ; +{466:371} OH+TNCARB10=RTN10O2 : 1.00D-10 ; +{467:372} NO3+TNCARB26=RTN26O2+HNO3 : 3.80D-14 ; +{468:373} NO3+TNCARB10=RTN10O2+HNO3 : 1.44d-12*EXP(-1862.0/temp)*5.5 ; +{469:374} OH+RCOOH25=RTN25O2 : 6.65D-12 ; +{470:375} OH+TXCARB24=RTX24O2 : 1.55D-11 ; +{471:376} OH+TXCARB22=RTX22O2 : 4.55D-12 ; +{472:377} OH+CH3NO3=HCHO+NO2 : ARR2( 1.00D-14, -1060.0_dp, TEMP) ; +{473:378} OH+C2H5NO3=CH3CHO+NO2 : ARR2( 4.40D-14, -720.0_dp, TEMP) ; +{474:379} OH+RN10NO3=C2H5CHO+NO2 : 7.30D-13 ; +{475:380} OH+IC3H7NO3=CH3COCH3+NO2 : 4.90D-13 ; +{476:381} OH+RN13NO3=CARB11A+NO2 : 9.20D-13 ; +{477:382} OH+RN16NO3=CARB14+NO2 : 1.85D-12 ; +{478:383} OH+RN19NO3=CARB17+NO2 : 3.02D-12 ; +{479:384} OH+HOC2H4NO3=HOCH2CHO+NO2 : 1.09D-12 ; +{480:385} OH+RN9NO3=CARB7+NO2 : 1.31D-12 ; +{481:386} OH+RN12NO3=CARB10+NO2 : 1.79D-12 ; +{482:387} OH+RN15NO3=CARB13+NO2 : 1.03D-11 ; +{483:388} OH+RN18NO3=CARB16+NO2 : 1.34D-11 ; +{484:389} OH+RU14NO3=UCARB12+NO2 : 5.55D-11 ; +{485:390} OH+RA13NO3=CARB3+UDCARB8+NO2 : 7.30D-11 ; +{486:391} OH+RA16NO3=CARB3+UDCARB11+NO2 : 7.16D-11 ; +{487:392} OH+RA19NO3=CARB6+UDCARB11+NO2 : 8.31D-11 ; +{488:393} OH+RTN28NO3=TNCARB26+NO2 : 4.35D-12 ; +{489:394} OH+RTN25NO3=CH3COCH3+TNCARB15+NO2 : 2.88D-12 ; +{490:395} OH+RTX28NO3=TXCARB24+HCHO+NO2 : 3.53D-12 ; +{491:396} OH+RTX24NO3=TXCARB22+NO2 : 6.48D-12 ; +{492:397} OH+RTX22NO3=CH3COCH3+CCARB12+NO2 : 4.74D-12 ; +{493:398} OH+AROH14=RAROH14 : 2.63D-11 ; +{494:399} NO3+AROH14=RAROH14+HNO3 : 3.78D-12 ; +{495:400} RAROH14+NO2=ARNOH14 : 2.08D-12 ; +{496:401} OH+ARNOH14=CARB13+NO2 : 9.00D-13 ; +{497:402} NO3+ARNOH14=CARB13+NO2+HNO3 : 9.00D-14 ; +{498:403} OH+AROH17=RAROH17 : 4.65D-11 ; +{499:404} NO3+AROH17=RAROH17+HNO3 : 1.25D-11 ; +{500:405} RAROH17+NO2=ARNOH17 : 2.08D-12 ; +{501:406} OH+ARNOH17=CARB16+NO2 : 1.53D-12 ; +{502:407} NO3+ARNOH17=CARB16+NO2+HNO3 : 3.13D-13 ; +{503:408} OH+CH3OOH=CH3OO : ARR2( 1.90D-12, -190.0_dp, TEMP) ; +{504:409} OH+CH3OOH=HCHO+OH : ARR2( 1.00D-12, -190.0_dp, TEMP) ; +{505:410} OH+C2H5OOH=CH3CHO+OH : 1.36D-11 ; +{506:411} OH+RN10OOH=C2H5CHO+OH : 1.89D-11 ; +{507:412} OH+IC3H7OOH=CH3COCH3+OH : 2.78D-11 ; +{508:413} OH+RN13OOH=CARB11A+OH : 3.57D-11 ; +{509:414} OH+RN16OOH=CARB14+OH : 4.21D-11 ; +{510:415} OH+RN19OOH=CARB17+OH : 4.71D-11 ; +{511:416} OH+CH3CO3H=CH3CO3 : 3.70D-12 ; +{512:417} OH+C2H5CO3H=C2H5CO3 : 4.42D-12 ; +{513:418} OH+HOCH2CO3H=HOCH2CO3 : 6.19D-12 ; +{514:419} OH+RN8OOH=CARB6+OH : 4.42D-12 ; +{515:420} OH+RN11OOH=CARB9+OH : 2.50D-11 ; +{516:421} OH+RN14OOH=CARB12+OH : 3.20D-11 ; +{517:422} OH+RN17OOH=CARB15+OH : 3.35D-11 ; +{518:423} OH+RU14OOH=UCARB12+OH : 7.51D-11 ; +{519:424} OH+RU12OOH=RU12O2 : 3.00D-11 ; +{520:425} OH+RU10OOH=RU10O2 : 3.00D-11 ; +{521:426} OH+NRU14OOH=NUCARB12+OH : 1.03D-10 ; +{522:427} OH+NRU12OOH=NOA+CO+OH : 2.65D-11 ; +{523:428} OH+HOC2H4OOH=HOCH2CHO+OH : 2.13D-11 ; +{524:429} OH+RN9OOH=CARB7+OH : 2.50D-11 ; +{525:430} OH+RN12OOH=CARB10+OH : 3.25D-11 ; +{526:431} OH+RN15OOH=CARB13+OH : 3.74D-11 ; +{527:432} OH+RN18OOH=CARB16+OH : 3.83D-11 ; +{528:433} OH+NRN6OOH=HCHO+HCHO+NO2+OH : 5.22D-12 ; +{529:434} OH+NRN9OOH=CH3CHO+HCHO+NO2+OH : 6.50D-12 ; +{530:435} OH+NRN12OOH=CH3CHO+CH3CHO+NO2+OH : 7.15D-12 ; +{531:436} OH+RA13OOH=CARB3+UDCARB8+OH : 9.77D-11 ; +{532:437} OH+RA16OOH=CARB3+UDCARB11+OH : 9.64D-11 ; +{533:438} OH+RA19OOH=CARB6+UDCARB11+OH : 1.12D-10 ; +{534:439} OH+RTN28OOH=TNCARB26+OH : 2.38D-11 ; +{535:440} OH+RTN26OOH=RTN26O2 : 1.20D-11 ; +{536:441} OH+NRTN28OOH=TNCARB26+NO2+OH : 9.50D-12 ; +{537:442} OH+RTN25OOH=RTN25O2 : 1.66D-11 ; +{538:443} OH+RTN24OOH=RTN24O2 : 1.05D-11 ; +{539:444} OH+RTN23OOH=RTN23O2 : 2.05D-11 ; +{540:445} OH+RTN14OOH=RTN14O2 : 8.69D-11 ; +{541:446} OH+RTN10OOH=RTN10O2 : 4.23D-12 ; +{542:447} OH+RTX28OOH=RTX28O2 : 2.00D-11 ; +{543:448} OH+RTX24OOH=TXCARB22+OH : 8.59D-11 ; +{544:449} OH+RTX22OOH=CH3COCH3+CCARB12+OH : 7.50D-11 ; +{545:450} OH+NRTX28OOH=NRTX28O2 : 9.58D-12 ; +{546:451} CH3CO3+NO2=PAN : TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp , TEMP, C_M) ; +{547:452} PAN=CH3CO3+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29 ,6.5_dp,1.1d-11,0._dp,TEMP,C_M) ; +{548:453} C2H5CO3+NO2=PPN : TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp , TEMP, C_M) ; +{549:454} PPN=C2H5CO3+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29,6.5_dp , 1.1d-11 , 0._dp,TEMP, C_M) ; +{550:455} HOCH2CO3+NO2=PHAN : TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp , TEMP, C_M) ; +{551:456} PHAN=HOCH2CO3+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29 , 6.5_dp,1.1d-11,0._dp,TEMP, C_M) ; +{552:457} OH+PAN=HCHO+CO+NO2 : ARR2( 9.50D-13, 650.0_dp, TEMP) ; +{553:458} OH+PPN=CH3CHO+CO+NO2 : 1.27D-12 ; +{554:459} OH+PHAN=HCHO+CO+NO2 : 1.12D-12 ; +{555:460} RU12O2+NO2=RU12PAN : 0.061*TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp ,TEMP, C_M) ; +{556:461} RU12PAN=RU12O2+NO2 : TROEE( 1.111d28,14000._dp,8.5d-29,6.5_dp,1.1d-11,0._dp,TEMP, C_M) ; +{557:462} RU10O2+NO2=MPAN : 0.041*TROE( 8.5d-29,6.5_dp,1.1d-11,1._dp,TEMP,C_M) ; +{558:463} MPAN=RU10O2+NO2 : TROEE(1.111d28,14000._dp,8.5d-29,6.5_dp,1.1d-11,0._dp ,TEMP, C_M) ; +{559:464} OH+MPAN=CARB7+CO+NO2 : 3.60D-12 ; +{560:465} OH+RU12PAN=UCARB10+NO2 : 2.52D-11 ; +{561:466} RTN26O2+NO2=RTN26PAN : 0.722*TROE( 8.5d-29 , 6.5_dp , 1.1d-11 , 1._dp,TEMP, C_M) ; +{562:467} RTN26PAN=RTN26O2+NO2 : TROEE(1.111d28,14000._dp,8.5d-29,6.5_dp,1.1d-11,0._dp,TEMP, C_M) ; +{563:468} OH+RTN26PAN=CH3COCH3+CARB16+NO2 : 3.66D-12 ; +{564:469} OH+ANHY=HOCH2CH2O2 : 1.50D-12 ; +{565:470} OH+UDCARB8=ANHY+HO2 : 5.20D-11*0.50 ; +{566:471} OH+UDCARB11=ANHY+CH3OO : 5.58D-11*0.45 ; +{567:472} OH+UDCARB14=ANHY+C2H5O2 : 7.00D-11*0.45 ; +{568:473} OH+CH3CL=CH3OO : 7.33D-18*EXP(-809/TEMP)*TEMP**2 ; +{569:474} OH+CH2CL2=CH3OO : 6.14D-18*EXP(-389/TEMP)*TEMP**2 ; +{570:475} OH+CHCL3=CH3OO : 1.80D-18*EXP(-129/TEMP)*TEMP**2 ; +{571:476} OH+CH3CCL3=C2H5O2 : 2.25D-18*EXP(-910/TEMP)*TEMP**2 ; +{572:477} OH+TCE= HOCH2CH2O2 : ARR2( 9.64D-12, 1209.0_dp, TEMP) ; +{573:478} OH+TRICLETH=HOCH2CH2O2 : ARR2( 5.63D-13, -427.0_dp, TEMP) ; +{574:479} OH+CDICLETH=HOCH2CH2O2 : ARR2( 1.94D-12, -90.0_dp, TEMP) ; +{575:480} OH+TDICLETH=HOCH2CH2O2 : ARR2( 1.01D-12, -250.0_dp, TEMP) ; +{576:481} CH3OO+NO2=CH3O2NO2 : RJPL(1.3D-30,4.0_dp,7.5D-12,2.0_dp,C_M,TEMP) ; +{577:482} TNCARB12+hv = RN9O2 + HOCH2CO3 : 7.047*7.8D-5 * j(Pj_no2) ; +{578:483} TNCARB11+hv = RTN10O2 + CO + HO2 : 32.6088*4.6D-4 * j(Pj_no2) ; +{579:484} RA22NO3+hv = CARB6 + UDCARB14 + HO2 + NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{580:485} RA22OOH+hv = CARB6 + UDCARB14 + HO2 + OH : 0.7 * j(Pj_h2o2) ; +{581:486} RA25NO3+hv = CARB6 + UDCARB17 + HO2 + NO2 : 5.228*7.8D-5 * j(Pj_no2) ; +{582:487} RA25OOH+hv = CARB6 + UDCARB17 + HO2 + OH : 0.7 * j(Pj_h2o2) ; +{583:488} UDCARB17+hv = ANHY + HO2 + RN10O2 : 0.02*0.45*j(Pj_no2) ; +{584:489} UDCARB17+hv = RN16O2 + HO2 : 0.02*0.55*j(Pj_no2) ; +{585:490} RTN23O2 + NO = RTN23NO3 : 2.40d-12*EXP(360.0/temp)*0.118 ; +{586:491} RTN23NO3 + OH = CH3COCH3 + TNCARB12 + NO2 : 5.37D-12 ; +{587:492} TNCARB12 + OH = TNCARB11 + HO2 : 3.22D-12 ; +{588:493} TNCARB11 + OH = RTN10O2 + CO : 1.33D-11 ; +{589:494} TNCARB11 + NO3 = RTN10O2 + CO + HNO3 : 1.44d-12*EXP(-1862.0/temp)*5.5 ; +{590:495} TM123B + OH = RA22AO2 : 3.27D-11*0.50 ; +{591:496} TM123B + OH = RA22BO2 : 3.27D-11*0.50 ; +{592:497} TM124B + OH = RA22AO2 : 3.25D-11*0.50 ; +{593:498} TM124B + OH = RA22BO2 : 3.25D-11*0.50 ; +{594:499} TM135B + OH = RA22AO2 : 5.67D-11 ; +{595:500} OETHTOL + OH = RA22AO2 : 1.19D-11 ; +{596:501} METHTOL + OH = RA22AO2 : 1.86D-11 ; +{597:502} PETHTOL + OH = RA22AO2 : 1.18D-11 ; +{598:503} RA22AO2 + NO = CARB6 + UDCARB14 + HO2 + NO2 : 2.40d-12*EXP(360.0/temp)*0.843 ; +{599:504} RA22BO2 + NO = CARB9 + UDCARB11 + HO2 + NO2 : 2.40d-12*EXP(360.0/temp)*0.843 ; +{600:505} RA22AO2 + NO = RA22NO3 : 2.40d-12*EXP(360.0/temp)*0.157 ; +{601:506} RA22BO2 + NO = RA22NO3 : 2.40d-12*EXP(360.0/temp)*0.157 ; +{602:507} RA22AO2 + NO3 = CARB6 + UDCARB14 + HO2 + NO2 : 2.50d-12 ; +{603:508} RA22BO2 + NO3 = CARB9 + UDCARB11 + HO2 + NO2 : 2.50d-12 ; +{604:509} RA22AO2 + HO2 = RA22OOH : 0.520*2.91d-13*EXP(1300.0/temp)*0.890 ; +{605:510} RA22BO2 + HO2 = RA22OOH : 0.520*2.91d-13*EXP(1300.0/temp)*0.890 ; +{606:511} RA22AO2 = CARB6 + UDCARB14 + HO2 : 8.80D-13*RO2 ; +{607:512} RA22BO2 = CARB9 + UDCARB11 + HO2 : 8.80D-13*RO2 ; +{608:513} OH + RA22NO3 = CARB6 + UDCARB14 + NO2 : 9.45D-11 ; +{609:514} OH + RA22OOH = CARB6 + UDCARB14 + OH : 1.28D-10 ; +{610:515} DIME35EB + OH = RA25O2 : 5.67D-11 ; +{611:516} RA25O2 + NO = CARB6 + UDCARB17 + HO2 + NO2 : 2.40d-12*EXP(360.0/temp)*0.833 ; +{612:517} RA25O2 + NO = RA25NO3 : 2.40d-12*EXP(360.0/temp)*0.167 ; +{613:518} RA25O2 + NO3 = CARB6 + UDCARB17 + HO2 + NO2 : 2.50d-12 ; +{614:519} RA25O2 + HO2 = RA25OOH : 0.520*2.91d-13*EXP(1300.0/temp)*0.914 ; +{615:520} RA25O2 = CARB6 + UDCARB17 + HO2 : 8.80D-13*RO2 ; +{616:521} OH + RA25NO3 = CARB6 + UDCARB17 + NO2 : 9.57D-11 ; +{617:522} OH + RA25OOH = CARB6 + UDCARB17 + OH : 1.28D-10 ; +{618:523} OH + UDCARB17 = RN16O2 : 7.00D-11*0.55 ; +{619:524} OH + UDCARB17 = ANHY + RN10O2 : 7.00D-11*0.45 ; +{620:105} HCl = HCl : 1.0_dp ; {copied from cbmz_bb} +{621:106} NH3 = NH3 : 1.0_dp ; {copied from cbmz_bb} +{622:S04} DMS + OH = CH3SCH2OO + H2O : ARR2(1.12d-11,250._dp,temp) ; {CH3SCH3+OH->CH3SCH2+H2O ; CH3SCH2+O2->CH3SCH2OO - 1st step is slowest, so use that as reaction function (IUPAC preferred value)} +{623:S05} DMS + OH {+O2} = DMSO + HO2 : iupac_ch3sch3(9.5d-39,5270._dp,7.5d-29,5610._dp,C_M*0.2_dp,temp) ; {IUPAC preferred value} +{624:S06} DMS + NO3 {+O2} = CH3SCH2OO + HNO3 : ARR2(1.9d-13,-520._dp,temp) ; +{625:S12} CH3SCH2OO + NO = HCHO + CH3S + NO2 : ARR2(4.9d-12,-263._dp,temp) ; +{626:S13} CH3SCH2OO + CH3SCH2OO {+O2} = 2 HCHO + 2 CH3S : 1.0d-11 ; +{627:S14} CH3S + O3 = CH3SO {+ O2} : ARR2(1.15d-12,-432._dp,temp) ; +{628:S15} CH3S + NO2 = CH3SO + NO : ARR2(3.0d-11,-210._dp,temp) ; +{629:S16} CH3SO + NO2 {+O2} = 0.82 CH3SO2 + 0.18 SO2 + 0.18 CH3OO + NO : 1.2d-11 ; +{630:S17} CH3SO + O3 {+O2} = CH3SO2 : 6.0d-13 ; +{631:S18} CH3SO2 = SO2 + CH3OO : ARR2(5.0d13,9673._dp,temp) {ARR2(1.9d13,8661._dp,temp)} ; +{632:S19} CH3SO2 + NO2 = CH3SO3 + NO : 2.2d-12 ; +{633:S20} CH3SO2 + O3 = CH3SO3 : 3.0d-13 ; +{634:S21} CH3SO3 + HO2 = MSA : 5.0d-11 ; +{635:S22} CH3SO3 {+H2O+O2} = CH3OO + H2SO4 : ARR2(1.36d14,11071._dp,temp) ; +{636:S23} DMSO + OH = 0.95 MSIA + 0.95 CH3OO + 0.05 DMSO2 : 8.7d-11 ; +{637:S24} MSIA + OH = 0.95 CH3SO2 + 0.05 MSA + 0.05 HO2 + H2O : 9.d-11 ; +{638:S25} MSIA + NO3 = CH3SO2 + HNO3 : 1.0d-13 ; + diff --git a/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.kpp b/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.kpp new file mode 100644 index 00000000..2c500e4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.kpp @@ -0,0 +1,9 @@ +#MODEL crimech +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM diff --git a/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.spc b/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.spc new file mode 100644 index 00000000..8c7c1c22 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech.spc @@ -0,0 +1,238 @@ +#DEFVAR + HONO =IGNORE ; + O3 =IGNORE ; + HCHO =IGNORE ; + PAN =IGNORE ; + C2H4 =IGNORE ; + CO =IGNORE ; + HNO3 =IGNORE ; + N2O5 =IGNORE ; + HNO4 =IGNORE ; + NO3 =IGNORE ; + O1D =IGNORE ; + O3P =IGNORE ; + OH =IGNORE ; + HO2 =IGNORE ; + H2O2 =IGNORE ; + C2H6 =IGNORE ; + HCOOH =IGNORE ; + CH3CO3 =IGNORE ; + CH3OO =IGNORE ; + C2H5O2 =IGNORE ; + HSO3 =IGNORE ; + SO3 =IGNORE ; + SO2 =IGNORE ; + NO2 =IGNORE ; + NO =IGNORE ; + C3H8 =IGNORE ; + NC4H10 =IGNORE ; + HOCH2CH2O2 =IGNORE ; + IC3H7O2 =IGNORE ; + C5H8 =IGNORE ; + BENZENE =IGNORE ; + TOLUENE =IGNORE ; + OXYL =IGNORE ; + NPROPOL =IGNORE ; + C2H2 =IGNORE ; + C3H6 =IGNORE ; + TBUT2ENE =IGNORE ; + CH3CHO =IGNORE ; + C2H5CHO =IGNORE ; + CH3CO2H =IGNORE ; + CH3COCH3 =IGNORE ; + MEK =IGNORE ; + CH3OH =IGNORE ; + C2H5OH =IGNORE ; + IC3H7NO3 =IGNORE ; + IPROPOL =IGNORE ; + CH3NO3 =IGNORE ; + C2H5NO3 =IGNORE ; + HOC2H4NO3 =IGNORE ; + CH3OOH =IGNORE ; + C2H5OOH =IGNORE ; + IC3H7OOH =IGNORE ; + CH3CO3H =IGNORE ; + HOC2H4OOH =IGNORE ; + RN10O2 =IGNORE ; + RN13O2 =IGNORE ; + RN16O2 =IGNORE ; + RN19O2 =IGNORE ; + RN9O2 =IGNORE ; + RN12O2 =IGNORE ; + RN15O2 =IGNORE ; + RN18O2 =IGNORE ; + NRN6O2 =IGNORE ; + NRN9O2 =IGNORE ; + NRN12O2 =IGNORE ; + CARB14 =IGNORE ; + RN11O2 =IGNORE ; + RN14O2 =IGNORE ; + CARB17 =IGNORE ; + RN8O2 =IGNORE ; + RN17O2 =IGNORE ; + RN10NO3 =IGNORE ; + RN13NO3 =IGNORE ; + RN19NO3 =IGNORE ; + RN9NO3 =IGNORE ; + RN12NO3 =IGNORE ; + RN15NO3 =IGNORE ; + RN18NO3 =IGNORE ; + RN16NO3 =IGNORE ; + RN10OOH =IGNORE ; + RN13OOH =IGNORE ; + RN16OOH =IGNORE ; + RN19OOH =IGNORE ; + RN8OOH =IGNORE ; + RN11OOH =IGNORE ; + RN14OOH =IGNORE ; + RN17OOH =IGNORE ; + RN9OOH =IGNORE ; + RN12OOH =IGNORE ; + RN15OOH =IGNORE ; + RN18OOH =IGNORE ; + NRN6OOH =IGNORE ; + NRN9OOH =IGNORE ; + NRN12OOH =IGNORE ; + APINENE =IGNORE ; + BPINENE =IGNORE ; + RN13AO2 =IGNORE ; + RN16AO2 =IGNORE ; + RN15AO2 =IGNORE ; + RN18AO2 =IGNORE ; + CARB7 =IGNORE ; + CARB10 =IGNORE ; + CARB13 =IGNORE ; + CARB16 =IGNORE ; + CARB3 =IGNORE ; + CARB6 =IGNORE ; + CARB9 =IGNORE ; + CARB12 =IGNORE ; + CARB15 =IGNORE ; + C2H5CO3H =IGNORE ; + C2H5CO3 =IGNORE ; + PPN =IGNORE ; + HOCH2CHO =IGNORE ; + HOCH2CO3 =IGNORE ; + HOCH2CO3H =IGNORE ; + PHAN =IGNORE ; + CCARB12 =IGNORE ; + RU14O2 =IGNORE ; + RU12O2 =IGNORE ; + CH3CL =IGNORE ; + CH2CL2 =IGNORE ; + CHCL3 =IGNORE ; + CH3CCL3 =IGNORE ; + CDICLETH =IGNORE ; + TDICLETH =IGNORE ; + TRICLETH =IGNORE ; + TCE =IGNORE ; + RU10O2 =IGNORE ; + UCARB12 =IGNORE ; + UCARB10 =IGNORE ; + RU14NO3 =IGNORE ; + RU14OOH =IGNORE ; + RU12OOH =IGNORE ; + RU10OOH =IGNORE ; + MPAN =IGNORE ; + RU12PAN=IGNORE ; + NRU14O2 =IGNORE ; + NUCARB12 =IGNORE ; + NRU14OOH =IGNORE ; + NRU12O2 =IGNORE ; + NRU12OOH =IGNORE ; + NOA =IGNORE ; + RA13O2 =IGNORE ; + RA13NO3 =IGNORE ; + RA13OOH =IGNORE ; + UDCARB8 =IGNORE ; + AROH14 =IGNORE ; + RAROH14 =IGNORE ; + ARNOH14 =IGNORE ; + RA16O2 =IGNORE ; + RA16NO3 =IGNORE ; + RA16OOH =IGNORE ; + UDCARB11 =IGNORE ; + AROH17 =IGNORE ; + RAROH17 =IGNORE ; + ARNOH17 =IGNORE ; + UDCARB14 =IGNORE ; + RA19AO2 =IGNORE ; + RA19CO2 =IGNORE ; + RA19NO3 =IGNORE ; + RA19OOH =IGNORE ; + RTN28O2 =IGNORE ; + RTN28NO3 =IGNORE ; + RTN28OOH =IGNORE ; + TNCARB26 =IGNORE ; + RTN26O2 =IGNORE ; + RTN26OOH =IGNORE ; + NRTN28O2 =IGNORE ; + NRTN28OOH =IGNORE ; + RTN26PAN =IGNORE ; + RTN25O2 =IGNORE ; + RTN24O2 =IGNORE ; + RTN23O2 =IGNORE ; + RTN14O2 =IGNORE ; + RTN10O2 =IGNORE ; + RTN25OOH =IGNORE ; + RTN24OOH =IGNORE ; + RTN23OOH =IGNORE ; + RTN14OOH =IGNORE ; + RTN10OOH =IGNORE ; + TNCARB10 =IGNORE ; + RTN25NO3 =IGNORE ; + TNCARB15 =IGNORE ; + RCOOH25 =IGNORE ; + RTX28O2 =IGNORE ; + RTX28NO3 =IGNORE ; + RTX28OOH =IGNORE ; + TXCARB24 =IGNORE ; + RTX24O2 =IGNORE ; + RTX24NO3 =IGNORE ; + RTX24OOH =IGNORE ; + TXCARB22 =IGNORE ; + RTX22O2 =IGNORE ; + RTX22NO3 =IGNORE ; + RTX22OOH =IGNORE ; + NRTX28O2 =IGNORE ; + NRTX28OOH =IGNORE ; + CARB11A =IGNORE ; + ANHY =IGNORE ; + CH3O2NO2 =IGNORE ; + CH4 =IGNORE ; + H2SO4 =IGNORE ; + HCl =IGNORE ; + NH3 =IGNORE ; + RTN23NO3 =IGNORE ; + TNCARB12 =IGNORE ; + TNCARB11 =IGNORE ; + TM123B =IGNORE ; + TM124B =IGNORE ; + TM135B =IGNORE ; + OETHTOL =IGNORE ; + METHTOL =IGNORE ; + PETHTOL =IGNORE ; + RA22AO2 =IGNORE ; + RA22BO2 =IGNORE ; + RA22NO3 =IGNORE ; + RA22OOH =IGNORE ; + DIME35EB =IGNORE ; + RA25O2 =IGNORE ; + RA25NO3 =IGNORE ; + UDCARB17 =IGNORE ; + RA25OOH =IGNORE ; + DMS = IGNORE ; + CH3SCH2OO = IGNORE ; + DMSO = IGNORE ; + CH3S = IGNORE ; + CH3SO = IGNORE ; + CH3SO2 = IGNORE ; + CH3SO3 = IGNORE ; + MSA = IGNORE ; + MSIA = IGNORE ; + DMSO2 = IGNORE ; +#DEFFIX + H2O =IGNORE ; + M =IGNORE ; +{H2 =IGNORE ;} + diff --git a/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech_wrfkpp.equiv new file mode 100644 index 00000000..4a0df53c --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/crimech/crimech_wrfkpp.equiv @@ -0,0 +1,14 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +HO OH +KET CH3COCH3 +ACO3 CH3CO3 +PAA CH3CO3H +PROOH IC3H7OOH +SULF H2SO4 + diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart/mozart.def b/wrfv2_fire/chem/KPP/mechanisms/mozart/mozart.def index 6aadf7dd..9f8883e7 100644 --- a/wrfv2_fire/chem/KPP/mechanisms/mozart/mozart.def +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart/mozart.def @@ -43,7 +43,7 @@ REAL(KIND=dp) FUNCTION usr5( temp, c_m ) k0 = c_m * 6.5e-34_dp * exp( 1335._dp/temp ) k2 = exp( 2199._dp/temp ) - k0 = k0 /(1.0_dp + k0/(2.7e-11_dp*k2)) + k0 = k0 /(1.0_dp + k0/(2.7e-17_dp*k2)) k2 = exp( 460._dp/temp ) usr5 = k0 + 2.4e-14_dp * k2 @@ -148,3 +148,5 @@ END FUNCTION usr26 #ENDINLINE + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.def b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.def index b5e52da4..b176a176 100644 --- a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.def +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.def @@ -43,7 +43,7 @@ REAL(KIND=dp) FUNCTION usr5( temp, c_m ) k0 = c_m * 6.5e-34_dp * exp( 1335._dp/temp ) k2 = exp( 2199._dp/temp ) - k0 = k0 /(1.0_dp + k0/(2.7e-11_dp*k2)) + k0 = k0 /(1.0_dp + k0/(2.7e-17_dp*k2)) k2 = exp( 460._dp/temp ) usr5 = k0 + 2.4e-14_dp * k2 diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.def b/wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.def index b5e95543..254f3e5e 100644 --- a/wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.def +++ b/wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.def @@ -43,7 +43,7 @@ REAL(KIND=dp) FUNCTION usr5( temp, c_m ) k0 = c_m * 6.5e-34_dp * exp( 1335._dp/temp ) k2 = exp( 2199._dp/temp ) - k0 = k0 /(1.0_dp + k0/(2.7e-11_dp*k2)) + k0 = k0 /(1.0_dp + k0/(2.7e-17_dp*k2)) k2 = exp( 460._dp/temp ) usr5 = k0 + 2.4e-14_dp * k2 diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.def b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.def new file mode 100755 index 00000000..32a92086 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.def @@ -0,0 +1,62 @@ +#include atoms_red +#include ./racm_esrlsorg_aqchem.spc +#include ./racm_esrlsorg_aqchem.eqn + + + + +#INLINE F90_RATES +REAL(KIND=dp) FUNCTION k45( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=2.4E-14_dp * EXP(460._dp/TEMP) + k2=2.7E-17_dp * EXP(2199._dp/TEMP) + k3=6.5E-34_dp * EXP(1335._dp/TEMP) * c_m + + k45=k0+k3/(1+k3/k2) + + +END FUNCTION k45 + + +REAL(kind=dp) FUNCTION k57( TEMP, C_M ) + + INTRINSIC LOG10 + + REAL(KIND=dp), INTENT(IN) :: temp ! temperature [K] + REAL(KIND=dp), INTENT(IN) :: c_m ! air concentration [molecules/cm3] + REAL(KIND=dp) :: k0_300Kn ! low pressure limit at 300 K + REAL(KIND=dp) :: nn ! exponent for low pressure limit + REAL(KIND=dp) :: kinf_300Kn ! high pressure limit at 300 K + REAL(KIND=dp) :: mn ! exponent for high pressure limit + REAL(KIND=dp) :: zt_help, k0_T, kinf_T, k_ratio + REAL(KIND=dp) :: k57troe, k57cact + + k0_300Kn = 5.9e-33_dp + nn = 1.4_dp + kinf_300Kn = 1.1e-12_dp + mn = -1.3_dp + + zt_help = 300._dp/temp + k0_T = k0_300Kn * zt_help**(nn) * c_m ! k_0 at current T + kinf_T = kinf_300Kn * zt_help**(mn) ! k_inf at current T + k_ratio = k0_T/kinf_T + k57troe = k0_T/(1._dp+k_ratio)*0.6_dp**(1._dp/(1._dp+LOG10(k_ratio)**2)) + + k0_300Kn = 1.5e-13_dp + nn = -0.6_dp + kinf_300Kn = 2.9e9_dp + mn = -6.1_dp + + k0_T = k0_300Kn * zt_help**(nn)! k_0 at current T + kinf_T = kinf_300Kn * zt_help**(mn) / c_m ! k_inf at current T + k_ratio = k0_T/kinf_T + k57cact = k0_T/(1._dp+k_ratio)*0.6_dp**(1._dp/(1._dp+LOG10(k_ratio)**2)) + + k57 = k57troe + k57cact + +END FUNCTION k57 + +#ENDINLINE + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.eqn b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.eqn new file mode 100644 index 00000000..18814dbd --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.eqn @@ -0,0 +1,246 @@ +#EQUATIONS {} + {001:J01} NO2+hv=O3P+NO : j(Pj_no2) ; + {002:J02} O3+hv=O1D{+O2} : j(Pj_o31d) ; + {003:J03} O3+hv=O3P{+O2} : j(Pj_o33p) ; + {004:J04} HONO+hv=HO+NO : j(Pj_hno2) ; + {005:J05} HNO3+hv=HO+NO2 : j(Pj_hno3) ; + {006:J06} HNO4+hv=0.65 HO2+0.65 NO2+0.35 HO+0.35 NO3 : j(Pj_hno4) ; + {007:J07} NO3+hv=NO{+O2} : j(Pj_no3o2) ; + {008:J08} NO3+hv=NO2+O3P : j(Pj_no3o) ; + {009:J09} H2O2+hv=HO+HO : j(Pj_h2o2) ; + {010:J10} HCHO+hv=CO{+H2} : j(Pj_ch2om) ; + {011:J11} HCHO+hv=HO2+HO2+CO : j(Pj_ch2or) ; + {012:J12} ALD+hv=MO2+HO2+CO : j(Pj_ch3cho) ; + {013:J13} OP1+hv=HCHO+HO2+HO : j(Pj_ch3o2h) ; + {014:J14} OP2+hv=ALD+HO2+HO : j(Pj_ch3coch3) ; + {015:J15} PAA+hv=MO2+HO : j(Pj_ch3coo2h) ; + {016:J16} KET+hv=ACO3+ETHP : j(Pj_ch3coc2h5) ; + {017:J17} GLY+hv=0.13 HCHO+1.87 CO{+0.87 H2} : j(Pj_hcocho) ; + {018:J18} GLY+hv=0.45 HCHO+1.55 CO+0.80 HO2{+0.15 H2} : j(Pj_hcochob) ; + {019:J19} MGLY+hv=ACO3+HO2+CO : j(Pj_ch3cocho) ; + {020:J20} DCB+hv=HO2+TCO3 : j(Pj_hcochest) ; + {021:J21} ONIT+hv=0.20 ALD+0.80 KET+HO2+NO2 : j(Pj_ch3ono2) ; + {022:J22} MACR+hv=CO+HCHO+HO2+ACO3 : j(Pj_macr) ; + {023:J23} HKET+hv=HCHO+HO2+ACO3 : j(Pj_ch3coc2h5) ; + {024:001} O3P+M{O2}=O3 : (C_M *6.00D-34*(TEMP/300.0)**(-2.4)) ; + {025:002} O3P+O3=M {2O2} : ARR2( 8.00D-12 , 2060.0_dp, TEMP) ; + {026:003} O1D + M = O3P : .78084*ARR2(2.15D-11 , -110.0_dp, TEMP) + .20946*ARR2( 3.30D-11 , -55.0_dp , TEMP ) ; + {027:004} O1D+H2O=HO+HO : ARR2( 1.63D-10 , -60.0_dp, TEMP ) ; + {028:005} O3+HO=HO2{+O2} : ARR2( 1.70D-12 , 940.0_dp, TEMP ) ; + {029:006} O3+HO2=HO{+2.0 O2} : ARR2( 1.0D-14 , 490.0_dp, TEMP ) ; + {030:007} HO+HO2=H2O{+O2} : ARR2( 4.80D-11 , -250.0_dp, TEMP ) ; + {031:008} H2O2+HO=HO2+H2O : 1.8D-12 ; + {032:009} HO2+HO2=H2O2{+O2} : (3.5D-13*EXP(430./TEMP) + 1.7D-33* C_M *EXP(1000./TEMP)) ; + {033:010} HO2+HO2+H2O=H2O2+H2O{+O2} : (4.9D-34* EXP(2630./TEMP)+ 2.38D-54* C_M *EXP(3200./TEMP)) ; + {034:011} O3P+NO=NO2 : TROE( 9.00D-32 , 1.5_dp , 3.00D-11 , 0.0_dp , TEMP, C_M) ; + {035:012} O3P+NO2=NO{+O2} : ARR2( 5.1D-12 , -210.0_dp, TEMP) ; + {036:013} O3P+NO2=NO3 : TROE( 2.5D-31 , 1.8_dp , 2.20D-11 , 0.7_dp , TEMP, C_M) ; + {037:014} NO+HO=HONO : TROE( 7.00D-31 , 2.6_dp , 3.6D-11 , 0.1_dp , TEMP, C_M) ; + {038:015} HO+NO2=HNO3 : TROE( 1.8D-30 , 3.0_dp , 2.8D-11 , 0.0_dp , TEMP, C_M) ; + {039:016} HO+NO3=NO2+HO2 : 2.20D-11 ; + {040:017} HO2+NO=NO2+HO : ARR2( 3.50D-12 , -250.0_dp, TEMP ) ; + {041:018} HO2+NO2=HNO4 : TROE( 2.0D-31 , 3.4_dp , 2.9D-12 , 1.1_dp , TEMP, C_M) ; + {042:019} HNO4=HO2+NO2 : TROEE( 4.76D26,10900.0_dp, 2.0D-31 , 3.4_dp , 2.9D-12 , 1.1_dp, TEMP, C_M ) ; + {043:020} HO2+NO3=0.3 HNO3+0.7 NO2+0.7 HO{+O2} : 3.50D-12 ; + {044:021} HO+HONO=NO2+H2O : ARR2( 1.80D-11 , 390.0_dp, TEMP ) ; + {045:022} HO+HNO3=NO3+H2O : k45(TEMP,C_M) ; + {046:023} HO+HNO4=NO2+H2O{+O2} : ARR2( 1.30D-12 , -380.0_dp, TEMP ) ; + {047:024} O3+NO=NO2{+O2} : ARR2( 3.0D-12 , 1500.0_dp, TEMP ) ; + {048:025} O3+NO2=NO3{+O2} : ARR2( 1.20D-13 , 2450.0_dp, TEMP ) ; + {049:026} NO+NO+M{O2}=NO2+NO2 : (.20946D0*ARR2( 3.30D-39 , -530.0_dp, TEMP )) ; + {050:027} NO3+NO=NO2+NO2 : ARR2( 1.50D-11 , -170.0_dp , TEMP) ; + {051:028} NO3+NO2=NO+NO2{+O2} : ARR2( 4.50D-14, 1260.0_dp, TEMP ) ; + {052:029} NO3+NO2=N2O5 : TROE( 2.0D-30 , 4.4_dp , 1.4D-12 , 0.7_dp , TEMP, C_M) ; + {053:030} N2O5=NO2+NO3 : TROEE(3.70D26,11000.0_dp, 2.0D-30 , 4.4_dp , 1.4D-12 , 0.7_dp, TEMP, C_M ) ; + {054:031} NO3+NO3=NO2+NO2{+O2} : ARR2( 8.50D-13 , 2450.0_dp, TEMP ) ; + {055:032} HO+M{=H2}=H2O+HO2 : (5.31D-7*ARR2( 2.8D-12 , 1800.0_dp, TEMP )) ;{fixed H2 (531ppb) Novelli '99} + {056:033} HO+SO2=SULF+HO2 : TROE( 3.3D-31 , 4.3_dp , 1.6D-12 , 0.0_dp , TEMP, C_M) ; + {057:034} CO+HO=HO2+CO2 : k57(TEMP,C_M) ; + {058:035} NALD+HO=HCHO+CO+NO2 : ARR2( 5.60D-12 , -270.0_dp, TEMP ) ; + {059:036} HACE+HO=MGLY+HO2 : 3.00D-12 ; + {060:037} CH4+HO=MO2+H2O : ARR2( 2.45D-12 , 1775.0_dp, TEMP ) ; + {061:038} ETH+HO=ETHP+H2O : ARR2( 8.7D-12 , 1070.0_dp, TEMP ); + {062:039} HC3+HO=0.583 HC3P+0.381 HO2+0.335 ALD+0.036 ORA1+0.036 CO+0.036 GLY+0.036 HO+0.010 HCHO+H2O : ARR2( 5.26D-12 , 260.0_dp, TEMP ) ; + {063:040} HC5+HO=0.75 HC5P+0.25 KET+0.25 HO2+H2O : ARR2( 8.02D-12 , 155.0_dp, TEMP ) ; + {064:041} HC8+HO=0.9511 HC8P+0.025 ALD+0.024 HKET+0.049 HO2+H2O : ARR2( 1.64D-11 , 125.0_dp, TEMP ) ; + {065:042} ETE+HO=ETEP : TROE( 1.0D-28 , 4.5_dp , 8.8D-12 , 0.85_dp , TEMP, C_M) ; + {066:043} OLT+HO=OLTP : ARR2( 5.72D-12 , -500.0_dp, TEMP ) ; + {067:044} OLI+HO=OLIP : ARR2( 1.33D-11 , -500.0_dp, TEMP ) ; + {068:045} DIEN+HO=ISOP : ARR2( 1.48D-11 , -448.0_dp, TEMP ) ; + {069:046} ISO+HO=ISOP : ARR2( 2.54D-11 , -410.0_dp, TEMP ) ; + {070:047} API+HO=APIP : ARR2( 1.21D-11 , -444.0_dp, TEMP ) ; + {071:048} LIM+HO=LIMP : 1.71D-10 ; + {072:049} TOL+HO=0.90 ADDT+0.10 XO2+0.10 HO2 : ARR2( 1.81D-12 , -338.0_dp, TEMP ) ; + {073:050} XYL+HO=0.90 ADDX+0.10 XO2+0.10 HO2 : ARR2( 7.30D-12 , -355.0_dp, TEMP ) ; + {074:051} CSL+HO=0.85 ADDC+0.10 PHO+0.05 HO2+0.05 XO2 : 6.8D-11 ; + {075:052} HCHO+HO=HO2+CO+H2O : ARR2( 5.5D-12 , -125.0_dp, TEMP ) ; + {076:053} ALD+HO=ACO3+H2O : ARR2( 5.6D-12 , -270.0_dp, TEMP ) ; + {077:054} KET+HO=KETP+H2O : (THERMAL_T2(5.68D-18, -92.0_dp,TEMP )) ; + {078:055} HKET+HO=HO2+MGLY+H2O : 3.00D-12 ; + {079:056} GLY+HO=HO2+2.0 CO+H2O : 1.15D-11 ; + {080:057} MGLY+HO=ACO3+CO+H2O : 1.72D-11 ; + {081:058} MACR+HO=MACP : .5*(4.13D-12*EXP(425./TEMP) + 1.86D-11*EXP(175./TEMP)) ; + {082:059} DCB+HO=0.50 TCO3+0.50 HO2+0.50 XO2+0.35 UDD+0.15 GLY+0.15 MGLY : ARR2( 2.80D-11 , -175.0_dp, TEMP ) ; + {083:060} UDD+HO=0.88 ALD+0.12 KET+HO2 : 2.70D-10 ; + {084:061} OP1+HO=0.65 MO2+0.35 HCHO+0.35 HO : ARR2( 3.8D-12 , -200.0_dp, TEMP ) ; + {085:062} OP2+HO=0.44 HC3P+0.08 ALD+0.41 KET+0.49 HO+0.07 XO2 : ARR2( 3.40D-12 , -190.0_dp, TEMP ) ; + {086:063} PAA+HO=0.35 HCHO+0.65 ACO3+0.35 HO2+0.35 XO2 : ARR2( 3.8D-12 , -200.0_dp, TEMP ) ; + {087:064} PAN+HO=HCHO+XO2+H2O+NO3 : 4.00D-14 ; + {088:065} TPAN+HO=0.60 HKET+0.40 HCHO+0.40 HO2+XO2+0.40 PAN+0.60 NO3 : ARR2( 3.25D-13 , -500.0_dp, TEMP ) ; + {089:066} ONIT+HO=HC3P+NO2+H2O : ARR2( 5.31D-12 , 260.0_dp , TEMP) ; + {090:067} HCHO+NO3=HO2+HNO3+CO : ARR2( 3.40D-13 , 1900.0_dp, TEMP ) ; + {091:068} ALD+NO3=ACO3+HNO3 : ARR2( 1.40D-12 , 1900.0_dp, TEMP ) ; + {092:069} GLY+NO3=HNO3+HO2+2.0 CO : ARR2( 2.90D-12 , 1900.0_dp, TEMP ) ; + {093:070} MGLY+NO3=HNO3+ACO3+CO : ARR2( 1.40D-12 , 1900.0_dp, TEMP ) ; + {094:071} MAHP+HO=MACP : 3.00D-11 ; + {095:072} DCB+NO3=0.5 TCO3+0.5 HO2+0.5 XO2+0.25 GLY+0.25 ALD+0.03 KET+0.25 MGLY+0.5 HNO3+0.5 NO2 : ARR2( 2.87D-13 , 1000.0_dp, TEMP ) ; + {096:073} CSL+NO3=HNO3+PHO : 2.20D-11 ; + {097:074} ETE+NO3=0.80 OLNN+0.20 OLND : (THERMAL_T2( 4.88D-18 , 2282.0_dp,TEMP )) ; + {098:075} OLT+NO3=0.43 OLNN+0.57 OLND : ARR2( 1.79D-13 , 450.0_dp, TEMP ) ; + {099:076} OLI+NO3=0.11 OLNN+0.89 OLND : ARR2( 8.64D-13 , -450.0_dp, TEMP ) ; + {100:077} DIEN+NO3=0.90 OLNN+0.10 OLND+0.90 MACR : 1.00D-13 ; + {101:078} ISO+NO3=ISON : ARR2( 3.03D-12 , 446.0_dp, TEMP ) ; + {102:079} API+NO3=0.10 OLNN+0.90 OLND : ARR2( 1.19D-12 , -490.0_dp, TEMP ) ; + {103:080} LIM+NO3=0.13 OLNN+0.87 OLND : 1.22D-11 ; + {104:081} TPAN+NO3=0.60 ONIT+0.60 NO3+0.40 PAN+0.40 HCHO+0.40 NO2+XO2 : ARR2( 2.20D-14 , 500.0_dp, TEMP ) ; + {105:082} ETE+O3=HCHO+0.43 CO+0.37 ORA1+0.26 HO2+0.12 HO{+0.13 H2} : ARR2( 1.2D-14 , 2630.0_dp, TEMP ) ; + {106:083} OLT+O3=0.64 HCHO+0.44 ALD+0.37 CO+0.14 ORA1+0.10 ORA2+0.25 HO2+0.40 HO+0.03 KET+0.03 KETP+0.06 CH4 +0.006 H2O2+0.03 ETH+0.19 MO2+0.10 ETHP{+0.05 H2} : ARR2( 4.33D-15, 1800.0_dp, TEMP ) ; + {107:084} OLI+O3=0.02 HCHO+0.99 ALD+0.16 KET+0.30 CO+0.011 H2O2+0.14 ORA2+0.07 CH4+0.22 HO2+0.63 HO+0.23 MO2+0.12 KETP+0.06 ETH+0.18 ETHP : ARR2( 4.40D-15 , 845.0_dp, TEMP ) ; + {108:085} DIEN+O3=0.90 HCHO+0.39 MACR+0.36 CO+0.15 ORA1+0.09 O3P+0.30 HO2+0.35 OLT+0.28 HO+0.15 ACO3+0.03 MO2+0.02 KETP+0.13 XO2+0.001 H2O2{+0.05 H2} : ARR2( 1.34D-14 , 2283.0_dp, TEMP ) ; + {109:086} ISO+O3=0.65 MACR+0.58 HCHO+0.1 MACP+0.1 ACO3+0.08 MO2+0.28 ORA1+0.14 CO+0.09 H2O2+0.25 HO2+0.25 HO : ARR2( 7.86D-15 , 1913.0_dp, TEMP ) ; + {110:087} API+O3=0.65 ALD+0.53 KET+0.14 CO+0.20 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2 : ARR2( 1.01D-15 , 732.0_dp, TEMP ) ; + {111:088} LIM+O3=0.04 HCHO+0.46 OLT+0.14 CO+0.16 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2+0.79 MACR+0.01 ORA1+0.07 ORA2 : 2.00D-16 ; + {112:089} MACR+O3=0.9 MGLY+0.45 ORA1+0.32 HO2+0.22 CO+0.19 HO+0.1 ACO3 : .5*(1.36D-15*EXP(-2112./TEMP)+7.51D-16*EXP(-1521./TEMP)) ; + {113:090} DCB+O3=0.21 HO+0.29 HO2+0.66 CO+0.50 GLY+0.28 ACO3+0.16 ALD+0.62 MGLY+0.11 PAA+0.11 ORA1+0.21 ORA2 : 2.00D-18 ; + {114:091} TPAN+O3=0.70 HCHO+0.30 PAN+0.70 NO2+0.13 CO+0.11 ORA1+0.08 HO2+0.036 HO+0.70 ACO3{+0.04 H2} : ARR2( 2.46D-15 , 1700.0_dp, TEMP ) ; + {115:092} PHO+NO2=0.10 CSL+ONIT : 2.00D-11 ; + {116:093} PHO+HO2=CSL : 1.00D-11 ; + {117:094} ADDT+NO2=CSL+HONO : 3.60D-11 ; + {118:095} ADDT+M {O2}=0.98 TOLP+0.02 CSL+0.02 HO2 : (.20946D0*ARR2( 1.66D-17 , -1044.0_dp, TEMP )) ; + {119:096} ADDT+O3=CSL+HO : 5.00D-11 ; + {120:097} ADDX+NO2=CSL+HONO : 3.60D-11 ; + {121:098} ADDX+M{O2}=0.98 XYLP+0.02 CSL+0.02 HO2 : (.20946D0*ARR2( 1.66D-17 , -1044.0_dp, TEMP )) ; + {122:099} ADDX+O3=CSL+HO : 1.00D-11 ; + {123:100} ADDC+NO2=CSL+HONO : 3.60D-11 ; + {124:101} ADDC+M{O2}=0.98 CSLP+0.02 CSL+0.02 HO2 : (.20946D0*ARR2( 1.66D-17 , -1044.0_dp, TEMP )) ; + {125:102} ADDC+O3=CSL+HO : 5.00D-11 ; + {126:103} ACO3+NO2=PAN : TROE( 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M) ; + {127:104} PAN=ACO3+NO2 : TROEE(1.11D28,14000.0_dp, 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M) ; + {128:105} TCO3+NO2=TPAN : TROE( 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M) ; + {129:106} TPAN=TCO3+NO2 : TROEE(1.11D28,14000.0_dp, 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M ) ; + {130:107} MO2+NO=HCHO+HO2+NO2 : ARR2( 2.8D-12 , -300.0_dp, TEMP ) ; + {131:108} ETHP+NO=ALD+HO2+NO2 : ARR2( 2.6D-12 , -365.0_dp, TEMP ); + {132:109} HC3P+NO=0.047 HCHO+0.233 ALD+0.623 KET+0.063 GLY+0.742 HO2+0.15 MO2+0.048 ETHP+0.048 XO2+0.059 ONIT+0.941 NO2 : 4.00D-12 ; + {133:110} HC5P+NO=0.021 HCHO+0.211 ALD+0.722 KET+0.599 HO2+0.031 MO2+0.245 ETHP+0.334 XO2+0.124 ONIT+0.876 NO2 : 4.00D-12 ; + {134:111} HC8P+NO=0.15 ALD+0.642 KET+0.133 ETHP+0.261 ONIT+0.739 NO2+0.606 HO2+0.416 XO2 : 4.00D-12 ; + {135:112} ETEP+NO=1.6 HCHO+HO2+NO2+0.2 ALD : 9.00D-12 ; + {136:113} OLTP+NO=0.94 ALD+HCHO+HO2+NO2+0.06 KET : 4.00D-12 ; + {137:114} OLIP+NO=HO2+1.71 ALD+0.29 KET+NO2 : 4.00D-12 ; + {138:115} ISOP+NO=MACR+NO2+HCHO+HO2+0.046 ISON : ARR2( 2.43D-12 , -360.0_dp, TEMP ) ; + {139:116} APIP+NO=0.80 HO2+0.80 ALD+0.80 KET+0.20 ONIT+0.80 NO2 : 4.00D-12 ; + {140:117} LIMP+NO=0.65 HO2+0.40 MACR+0.25 OLI+0.25 HCHO+0.35 ONIT+0.65 NO2 : 4.00D-12 ; + {141:118} TOLP+NO=0.95 NO2+0.95 HO2+0.65 MGLY+1.20 GLY+0.50 DCB+0.05 ONIT : 4.00D-12 ; + {142:119} XYLP+NO=0.95 NO2+0.95 HO2+0.60 MGLY+0.35 GLY+0.95 DCB+0.05 ONIT : 4.00D-12 ; + {143:120} CSLP+NO=GLY+MGLY+HO2+NO2 : 4.00D-12 ; + {144:121} ACO3+NO=MO2+NO2 : ARR2( 8.1D-12 , -270.0_dp, TEMP ) ; + {145:122} TCO3+NO=ACO3+HCHO+NO2 : ARR2( 8.1D-12 , -270.0_dp, TEMP ) ; + {146:123} KETP+NO=0.54 MGLY+0.46 ALD+0.23 ACO3+0.77 HO2+0.16 XO2+NO2 : 4.00D-12 ; + {147:124} OLNN+NO=HO2+ONIT+NO2 : 4.00D-12 ; + {148:125} OLND+NO=0.287 HCHO+1.24 ALD+0.464 KET+2.0 NO2 : 4.00D-12 ; + {149:126} MO2+HO2=OP1 : ARR2( 4.1D-13 , -750.0_dp, TEMP ) ; + {150:127} ETHP+HO2=OP2 : ARR2( 7.4D-13 , -700.0_dp, TEMP ) ; + {151:128} HC3P+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {152:129} HC5P+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {153:130} HC8P+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {154:131} ETEP+HO2=OP2 : ARR2( 1.90D-13 , -1300.0_dp, TEMP ) ; + {155:132} OLTP+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {156:133} OLIP+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {157:134} ISOP+HO2=ISHP : ARR2( 2.05D-13 , -1300.0_dp, TEMP ) ; + {158:135} APIP+HO2=OP2 : 1.50D-11 ; + {159:136} LIMP+HO2=OP2 : 1.50D-11 ; + {160:137} TOLP+HO2=OP2 : ARR2( 3.75D-13 , -980.0_dp, TEMP ) ; + {161:138} XYLP+HO2=OP2 : ARR2( 3.75D-13 , -980.0_dp, TEMP) ; + {162:139} CSLP+HO2=OP2 : ARR2( 3.75D-13 , -980.0_dp, TEMP ) ; + {163:140} ACO3+HO2=PAA : 4.3D-13*EXP(1040./TEMP)/(1.+0.027*EXP(660./TEMP)) ; + {164:141} ACO3+HO2=ORA2+O3 : 4.3D-13*EXP(1040./TEMP)/(1.+37.*EXP(-660./TEMP)) ; + {165:142} TCO3+HO2=OP2 : 4.3D-13*EXP(1040./TEMP)/(1.+0.027*EXP(660./TEMP)) ; + {166:143} TCO3+HO2=ORA2+O3 : 4.3D-13*EXP(1040./TEMP)/(1.+37.*EXP(-660./TEMP)) ; + {167:144} KETP+HO2=OP2 : ARR2( 1.15D-13 , -1300.0_dp, TEMP ) ; + {168:145} OLNN+HO2=ONIT : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {169:146} OLND+HO2=ONIT : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {170:147} MO2+MO2=1.33 HCHO+0.66 HO2 : ARR2( 9.5D-14 , -390.0_dp, TEMP ) ; + {171:148} ETHP+MO2=0.75 HCHO+HO2+0.75 ALD : ARR2( 1.18D-13 , -158.0_dp, TEMP ) ; + {172:149} HC3P+MO2=0.81 HCHO+0.992 HO2+0.58 ALD+0.018 KET+0.007 MO2+0.005 MGLY+0.085 XO2+0.119 GLY : ARR2( 9.46D-14 , -431.0_dp , TEMP) ; + {173:150} HC5P+MO2=0.829 HCHO+0.946 HO2+0.523 ALD+0.24 KET+0.014 ETHP+0.049 MO2+0.245 XO2 : ARR2( 1.00D-13 , -467.0_dp, TEMP ) ; + {174:151} HC8P+MO2=0.753 HCHO+0.993 HO2+0.411 ALD+0.419 KET+0.322 XO2+0.013 ETHP : ARR2( 4.34D-14 , -633.0_dp, TEMP ) ; + {175:152} ETEP+MO2=1.55 HCHO+HO2+0.35 ALD : ARR2( 1.71D-13 , -708.0_dp, TEMP ) ; + {176:153} OLTP+MO2=1.25 HCHO+HO2+0.669 ALD+0.081 KET : ARR2( 1.46D-13 , -708.0_dp, TEMP ) ; + {177:154} OLIP+MO2=0.755 HCHO+HO2+0.932 ALD+0.313 KET : ARR2( 9.18D-14 , -708.0_dp, TEMP ) ; + {178:155} ISOP+MO2=0.550 MACR+0.370 OLT+HO2+0.08 OLI+1.09 HCHO : ARR2( 1.36D-13 , -708.0_dp, TEMP ) ; + {179:156} APIP+MO2=HCHO+ALD+KET+2.0 HO2 : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {180:157} LIMP+MO2=1.4 HCHO+0.60 MACR+0.40 OLI+2.0 HO2 : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {181:158} TOLP+MO2=HCHO+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {182:159} XYLP+MO2=HCHO+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {183:160} CSLP+MO2=GLY+MGLY+HCHO+2.0 HO2 : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {184:161} ACO3+MO2=HCHO+HO2+MO2 : ARR2( 1.8D-12 , -500.0_dp, TEMP ) ; + {185:162} ACO3+MO2=HCHO+ORA2 : ARR2( 2.0D-13 , -500.0_dp, TEMP ) ; + {186:163} TCO3+MO2=2.0 HCHO+HO2+ACO3 : ARR2( 1.8D-12 , -500.0_dp, TEMP ) ; + {187:164} TCO3+MO2=HCHO+ORA2 : ARR2( 2.0D-13 , -500.0_dp, TEMP ) ; + {188:165} KETP+MO2=0.75 HCHO+0.88 HO2+0.40 MGLY+0.30 ALD+0.30 HKET+0.12 ACO3+0.08 XO2 : ARR2( 6.91D-13 , -508.0_dp, TEMP ) ; + {189:166} OLNN+MO2=0.75 HCHO+HO2+ONIT : ARR2( 1.60D-13 , -708.0_dp, TEMP ) ; + {190:167} OLND+MO2=0.96 HCHO+0.5 HO2+0.64 ALD+0.149 KET+0.5 NO2+0.5 ONIT : ARR2( 9.68D-14 , -708.0_dp, TEMP ) ; + {191:168} ETHP+ACO3=ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 1.03D-12 , -211.0_dp, TEMP ) ; + {192:169} HC3P+ACO3=0.724 ALD+0.127 KET+0.488 HO2+0.508 MO2+0.006 ETHP+0.071 XO2+0.091 HCHO+0.10 GLY+0.499 ORA2+0.004 MGLY : ARR2( 6.90D-13 , -460.0_dp, TEMP ) ; + {193:170} HC5P+ACO3=0.677 ALD+0.33 KET+0.438 HO2+0.554 MO2+0.495 ORA2+0.018 ETHP+0.237 XO2+0.076 HCHO : ARR2( 5.59D-13 , -522.0_dp, TEMP ) ; + {194:171} HC8P+ACO3=0.497 ALD+0.581 KET+0.489 HO2+0.507 MO2+0.495 ORA2+0.015 ETHP+0.318 XO2 : ARR2( 2.47D-13 , -683.0_dp, TEMP ) ; + {195:172} ETEP+ACO3=0.8 HCHO+0.6 ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 9.48D-13 , -765.0_dp, TEMP ) ; + {196:173} OLTP+ACO3=0.859 ALD+0.501 HCHO+0.501 HO2+0.501 MO2+0.499 ORA2+0.141 KET : ARR2( 8.11D-13 , -765.0_dp, TEMP ) ; + {197:174} OLIP+ACO3=0.941 ALD+0.569 KET+0.51 HO2+0.51 MO2+0.49 ORA2 : ARR2( 5.09D-13 , -765.0_dp, TEMP ) ; + {198:175} ISOP+ACO3=0.771 MACR+0.229 OLT+0.506 HO2+0.494 ORA2+0.340 HCHO+0.506 MO2 : ARR2( 7.60D-13 , -765.0_dp, TEMP ) ; + {199:176} APIP+ACO3=ALD+KET+HO2+MO2 : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {200:177} LIMP+ACO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+MO2 : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {201:178} TOLP+ACO3=MO2+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {202:179} XYLP+ACO3=MO2+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {203:180} CSLP+ACO3=GLY+MGLY+MO2+HO2 : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {204:181} ACO3+ACO3=2.0 MO2 : ARR2( 2.5D-12 , -500.0_dp, TEMP ) ; + {205:182} TCO3+ACO3=MO2+ACO3+HCHO : ARR2( 2.5D-12 , -500.0_dp, TEMP ) ; + {206:183} KETP+ACO3=0.54 MGLY+0.35 ALD+0.11 KET+0.12 ACO3+0.38 HO2+0.08 XO2+0.5 MO2+0.5 ORA2 : ARR2( 7.51D-13 , -565.0_dp, TEMP ) ; + {207:184} OLNN+ACO3=ONIT+0.5 ORA2+0.5 MO2+0.5 HO2 : ARR2( 8.85D-13 , -765.0_dp, TEMP ) ; + {208:185} OLND+ACO3=0.207 HCHO+0.65 ALD+0.167 KET+0.484 ORA2+0.484 ONIT+0.516 NO2+0.516 MO2 : ARR2( 5.37D-13 , -765.0_dp, TEMP ) ; + {209:186} OLNN+OLNN=2.0 ONIT+HO2 : ARR2( 7.00D-14 , -1000.0_dp , TEMP) ; + {210:187} OLNN+OLND=0.202 HCHO+0.64 ALD+0.149 KET+0.50 HO2+1.50 ONIT+0.50 NO2 : ARR2( 4.25D-14 , -1000.0_dp, TEMP ) ; + {211:188} OLND+OLND=0.504 HCHO+1.21 ALD+0.285 KET+ONIT+NO2 : ARR2( 2.96D-14 , -1000.0_dp, TEMP ) ; + {212:189} MO2+NO3=HCHO+HO2+NO2 : 1.20D-12 ; + {213:190} ETHP+NO3=ALD+HO2+NO2 : 1.20D-12 ; + {214:191} HC3P+NO3=0.048 HCHO+0.243 ALD+0.67 KET+0.063 GLY+0.792 HO2+0.155 MO2+0.053 ETHP+0.051 XO2+NO2 : 1.20D-12 ; + {215:192} HC5P+NO3=0.021 HCHO+0.239 ALD+0.828 KET+0.699 HO2+0.04 MO2+0.262 ETHP+0.391 XO2+NO2 : 1.20D-12 ; + {216:193} HC8P+NO3=0.187 ALD+0.88 KET+0.845 HO2+0.155 ETHP+0.587 XO2+NO2 : 1.20D-12 ; + {217:194} ETEP+NO3=1.6 HCHO+0.2 ALD+HO2+NO2 : 1.20D-12 ; + {218:195} OLTP+NO3=HCHO+0.94 ALD+0.06 KET+HO2+NO2 : 1.20D-12 ; + {219:196} OLIP+NO3=1.71 ALD+0.29 KET+HO2+NO2 : 1.20D-12 ; + {220:197} MPAN+HO=HACE+NO2 : 3.2D-11 ; + {221:198} APIP+NO3=ALD+KET+HO2+NO2 : 1.20D-12 ; + {222:199} LIMP+NO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+NO2 : 1.20D-12 ; + {223:200} TOLP+NO3=0.70 MGLY+1.30 GLY+0.50 DCB+HO2+NO2 : 1.20D-12 ; + {224:201} XYLP+NO3=1.26 MGLY+0.74 GLY+DCB+HO2+NO2 : 1.20D-12 ; + {225:202} CSLP+NO3=GLY+MGLY+HO2+NO2 : 1.20D-12; + {226:203} ACO3+NO3=MO2+NO2 : 4.00D-12; + {227:204} TCO3+NO3=HCHO+ACO3+NO2 : 4.00D-12; + {228:205} KETP+NO3=0.54 MGLY+0.46 ALD+0.77 HO2+0.23 ACO3+0.16 XO2+NO2 : 1.20D-12 ; + {229:206} OLNN+NO3=ONIT+HO2+NO2 : 1.20D-12 ; + {230:207} OLND+NO3=0.28 HCHO+1.24 ALD+0.469 KET+2.0 NO2 : 1.20D-12 ; + {231:208} XO2+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {232:209} XO2+MO2=HCHO+HO2 : ARR2( 5.99D-15 , -1510.0_dp, TEMP ) ; + {233:210} XO2+ACO3=MO2 : ARR2( 3.40D-14 , -1560.0_dp, TEMP ) ; + {234:211} XO2+XO2=M{O2} : ARR2( 7.13D-17 , -2950.0_dp, TEMP ) ; + {235:212} XO2+NO=NO2 : 4.00D-12 ; + {236:213} XO2+NO3=NO2 : 1.20D-12 ; + {237:214} ISOP+ISOP=2. MACR+HCHO+HO2 : 2.00D-12 ; + {238:215} ISHP+HO=MACR+HO : 1.00D-10 ; + {239:216} ISON+HO=HACE+NALD : 1.30D-11 ; + {240:217} MACP+NO=NO2+0.25 HACE+0.25 CO+0.25 ACO3+0.5 MGLY+0.75 HCHO+0.75 HO2 : ARR2( 2.54D-12 , -360.0_dp, TEMP ) ; + {241:218} MACP+HO2=MAHP : ARR2( 1.82D-13 , -1300.0_dp, TEMP ) ; + {242:219} MACP+MACP=HACE+MGLY+0.5 HCHO+0.5 CO+HO2 : 2.00D-12 ; + {243:220} MACP+NO2=MPAN : TROE( 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M) ; + {244:221} MPAN=MACP+NO2 : TROEE(1.11D28,14000.0_dp,9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M ) ; + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.kpp b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.kpp new file mode 100644 index 00000000..bdf1441a --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.kpp @@ -0,0 +1,10 @@ +#MODEL racm_esrlsorg_aqchem +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.spc b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.spc new file mode 100644 index 00000000..5685a481 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem.spc @@ -0,0 +1,88 @@ +#DEFVAR + O3 =IGNORE ; + H2O2 =IGNORE ; + NO =IGNORE ; + NO2 =IGNORE ; + NO3 =IGNORE ; + N2O5 =IGNORE ; + HONO =IGNORE ; + HNO3 =IGNORE ; + HNO4 =IGNORE ; + SO2 =IGNORE ; + SULF =IGNORE ; + CO =IGNORE ; + CO2 =IGNORE ; + CH4 =IGNORE ; + ETH =IGNORE ; + HC3 =IGNORE ; + HC5 =IGNORE ; + HC8 =IGNORE ; + ETE =IGNORE ; + OLT =IGNORE ; + OLI =IGNORE ; + DIEN =IGNORE ; + ISO =IGNORE ; + API =IGNORE ; + LIM =IGNORE ; + TOL =IGNORE ; + XYL =IGNORE ; + CSL =IGNORE ; + HCHO =IGNORE ; + ALD =IGNORE ; + KET =IGNORE ; + GLY =IGNORE ; + MGLY =IGNORE ; + DCB =IGNORE ; + MACR =IGNORE ; + UDD =IGNORE ; + HKET =IGNORE ; + ONIT =IGNORE ; + PAN =IGNORE ; + TPAN =IGNORE ; + OP1 =IGNORE ; + OP2 =IGNORE ; + PAA =IGNORE ; + ORA1 =IGNORE ; + ORA2 =IGNORE ; + HO =IGNORE ; + HO2 =IGNORE ; + O3P =IGNORE ; + O1D =IGNORE ; + MO2 =IGNORE ; + ETHP =IGNORE ; + HC3P =IGNORE ; + HC5P =IGNORE ; + HC8P =IGNORE ; + ETEP =IGNORE ; + OLTP =IGNORE ; + OLIP =IGNORE ; + ISOP =IGNORE ; + APIP =IGNORE ; + LIMP =IGNORE ; + PHO =IGNORE ; + ADDT =IGNORE ; + ADDX =IGNORE ; + ADDC =IGNORE ; + TOLP =IGNORE ; + XYLP =IGNORE ; + CSLP =IGNORE ; + ACO3 =IGNORE ; + TCO3 =IGNORE ; + KETP =IGNORE ; + OLNN =IGNORE ; + OLND =IGNORE ; + XO2 =IGNORE ; + HACE =IGNORE ; + ISHP =IGNORE ; + ISON =IGNORE ; + MACP =IGNORE ; + MAHP =IGNORE ; + MPAN =IGNORE ; + NALD =IGNORE ; +#DEFFIX + H2O = IGNORE ; {water} + M = IGNORE ; +{ H2O = H+2O ;} +{ N2 = N+N ;} +{ O2 = IGNORE ;} +{ H2 = IGNORE ;} diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem_wrfkpp.equiv new file mode 100644 index 00000000..e4c23b7a --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_esrlsorg_aqchem/racm_esrlsorg_aqchem_wrfkpp.equiv @@ -0,0 +1,9 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +rpho pho + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.def b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.def new file mode 100644 index 00000000..00cd9844 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.def @@ -0,0 +1,21 @@ +#include atoms_red +#include ./racmsorg_aqchem.spc +#include ./racmsorg_aqchem.eqn + + + + +#INLINE F90_RATES +REAL(KIND=dp) FUNCTION k46( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=7.2E-15_dp * EXP(785._dp/TEMP) + k2=4.1E-16_dp * EXP(1440._dp/TEMP) + k3=1.9E-33_dp * EXP(725._dp/TEMP) + + k46=k0+k3/(1+k3/k2) + + +END FUNCTION k46 +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.eqn b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.eqn new file mode 100644 index 00000000..8858c6da --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.eqn @@ -0,0 +1,242 @@ +#EQUATIONS {} + {001:J01} NO2+hv=O3P+NO : j(Pj_no2) ; + {002:J02} O3+hv=O1D{+O2} : j(Pj_o31d) ; + {003:J03} O3+hv=O3P{+O2} : j(Pj_o33p) ; + {004:J04} HONO+hv=HO+NO : j(Pj_hno2) ; + {005:J05} HNO3+hv=HO+NO2 : j(Pj_hno3) ; + {006:J06} HNO4+hv=0.65 HO2+0.65 NO2+0.35 HO+0.35 NO3 : j(Pj_hno4) ; + {007:J07} NO3+hv=NO{+O2} : j(Pj_no3o2) ; + {008:J08} NO3+hv=NO2+O3P : j(Pj_no3o) ; + {009:J09} H2O2+hv=HO+HO : j(Pj_h2o2) ; + {010:J10} HCHO+hv=CO{+H2} : j(Pj_ch2om) ; + {011:J11} HCHO+hv=HO2+HO2+CO : j(Pj_ch2or) ; + {012:J12} ALD+hv=MO2+HO2+CO : j(Pj_ch3cho) ; + {013:J13} OP1+hv=HCHO+HO2+HO : j(Pj_ch3o2h) ; + {014:J14} OP2+hv=ALD+HO2+HO : j(Pj_ch3coch3) ; + {015:J15} PAA+hv=MO2+HO : j(Pj_ch3coo2h) ; + {016:J16} KET+hv=ACO3+ETHP : j(Pj_ch3coc2h5) ; + {017:J17} GLY+hv=0.13 HCHO+1.87 CO{+0.87 H2} : j(Pj_hcocho) ; + {018:J18} GLY+hv=0.45 HCHO+1.55 CO+0.80 HO2{+0.15 H2} : j(Pj_hcochob) ; + {019:J19} MGLY+hv=ACO3+HO2+CO : j(Pj_ch3cocho) ; + {020:J20} DCB+hv=HO2+TCO3 : j(Pj_hcochest) ; + {021:J21} ONIT+hv=0.20 ALD+0.80 KET+HO2+NO2 : j(Pj_ch3ono2) ; + {022:J22} MACR+hv=CO+HCHO+HO2+ACO3 : j(Pj_macr) ; + {023:J23} HKET+hv=HCHO+HO2+ACO3 : j(Pj_ch3coc2h5) ; + {024:001} O3P+M{O2}=O3 : (C_M *6.00D-34*(TEMP/300.0_dp)**(-2.3)) ; + {025:002} O3P+O3=M {2O2} : ARR2( 8.00D-12 , 2060.0_dp, TEMP) ; + {026:003} O1D + M = O3{+O2} : .78084*ARR2(1.8D-11,-110._dp, TEMP); + {027:004} O1D + M = O3P{+O2} : .20946*ARR2( 3.20D-11 , -70.0_dp , TEMP ) ; + {028:005} O1D+H2O=HO+HO : 2.20D-10 ; + {029:006} O3+HO=HO2{+O2} : ARR2( 1.60D-12 , 940.0_dp, TEMP ) ; + {030:007} O3+HO2=HO{+2.0 O2} : ARR2( 1.10D-14 , 500.0_dp, TEMP ) ; + {031:008} HO+HO2=H2O{+O2} : ARR2( 4.80D-11 , -250.0_dp, TEMP ) ; + {032:009} H2O2+HO=HO2+H2O : ARR2( 2.90D-12 , 160.0_dp, TEMP ) ; + {033:010} HO2+HO2=H2O2{+O2} : (2.3D-13*EXP(600./TEMP) + 1.7D-33* C_M *EXP(1000./TEMP)) ; + {034:011} HO2+HO2+H2O=H2O2+H2O{+O2} : (3.22D-34* EXP(2800./TEMP)+ 2.38D-54* C_M *EXP(3200./TEMP)) ; + {035:012} O3P+NO=NO2 : TROE( 9.00D-32 , 1.5_dp , 3.00D-11 , 0.0_dp , TEMP, C_M) ; + {036:013} O3P+NO2=NO{+O2} : ARR2( 6.50D-12 , -120.0_dp, TEMP) ; + {037:014} O3P+NO2=NO3 : TROE( 9.00D-32 , 2.0_dp , 2.20D-11 , 0.0_dp , TEMP, C_M) ; + {038:015} NO+HO=HONO : TROE( 7.00D-31 , 2.6_dp , 1.50D-11 , 0.5_dp , TEMP, C_M) ; + {039:016} HO+NO2=HNO3 : TROE( 2.60D-30 , 3.2_dp , 2.40D-11 , 1.3_dp , TEMP, C_M) ; + {040:017} HO+NO3=NO2+HO2 : 2.20D-11 ; + {041:018} HO2+NO=NO2+HO : ARR2( 3.70D-12 , -250.0_dp, TEMP ) ; + {042:019} HO2+NO2=HNO4 : TROE( 1.80D-31 , 3.2_dp , 4.70D-12 , 1.4_dp , TEMP, C_M) ; + {043:020} HNO4=HO2+NO2 : TROEE( 4.76D26,10900.0_dp, 1.80D-31 , 3.2_dp , 4.70D-12 , 1.4_dp , TEMP, C_M ) ; + {044:021} HO2+NO3=0.3 HNO3+0.7 NO2+0.7 HO{+O2} : 3.50D-12 ; + {045:022} HO+HONO=NO2+H2O : ARR2( 1.80D-11 , 390.0_dp, TEMP ) ; + {046:023} HO+HNO3=NO3+H2O : k46(TEMP,C_M) ; + {047:024} HO+HNO4=NO2+H2O{+O2} : ARR2( 1.30D-12 , -380.0_dp, TEMP ) ; + {048:025} O3+NO=NO2{+O2} : ARR2( 2.00D-12 , 1400.0_dp, TEMP ) ; + {049:026} O3+NO2=NO3{+O2} : ARR2( 1.20D-13 , 2450.0_dp, TEMP ) ; + {050:027} NO+NO+M{O2}=NO2+NO2 : (.20946e0*ARR2( 3.30D-39 , -530.0_dp, TEMP )) ; + {051:028} NO3+NO=NO2+NO2 : ARR2( 1.50D-11 , -170.0_dp , TEMP) ; + {052:029} NO3+NO2=NO+NO2{+O2} : ARR2( 4.50D-14, 1260.0_dp, TEMP ) ; + {053:030} NO3+NO2=N2O5 : TROE( 2.20D-30 , 3.9_dp , 1.50D-12 , 0.7_dp , TEMP, C_M) ; + {054:031} N2O5=NO2+NO3 : TROEE(3.70D26,11000.0_dp, 2.20D-30 , 3.9_dp , 1.50D-12 , 0.7_dp , TEMP, C_M ) ; + {055:032} NO3+NO3=NO2+NO2{+O2} : ARR2( 8.50D-13 , 2450.0_dp, TEMP ) ; + {056:033} HO+M{=H2}=H2O+HO2 : (5.31D-7*ARR2( 5.50D-12 , 2000.0_dp, TEMP )) ;{fixed H2 (531ppb) Novelli '99} + {057:034} HO+SO2=SULF+HO2 : TROE( 3.00D-31 , 3.3_dp , 1.50D-12 , 0.0_dp , TEMP, C_M) ; + {058:035} CO+HO=HO2+CO2 : 1.5D-13 * (1.0_dp + 2.439D-20 * C_M) ; + {059:036} ISO+O3P=0.86 OLT+0.05 HCHO+0.02 HO+0.01 CO+0.13 DCB+0.28 HO2+0.15 XO2 : 6.0D-11 ; + {060:037} MACR+O3P=ALD : ARR2(1.59D-11,-13.0_dp, TEMP) ; + {061:038} CH4+HO=MO2+H2O : (THERMAL_T2(7.44D-18, 1361.0_dp,TEMP )) ; + {062:039} ETH+HO=ETHP+H2O : (THERMAL_T2(1.51D-17, 492.0_dp,TEMP )) ; + {063:040} HC3+HO=0.583 HC3P+0.381 HO2+0.335 ALD+0.036 ORA1+0.036 CO+0.036 GLY+0.036 HO+0.010 HCHO+H2O : ARR2( 5.26D-12 , 260.0_dp, TEMP ) ; + {064:041} HC5+HO=0.75 HC5P+0.25 KET+0.25 HO2+H2O : ARR2( 8.02D-12 , 155.0_dp, TEMP ) ; + {065:042} HC8+HO=0.9511 HC8P+0.025 ALD+0.024 HKET+0.049 HO2+H2O : ARR2( 1.64D-11 , 125.0_dp, TEMP ) ; + {066:043} ETE+HO=ETEP : ARR2( 1.96D-12 , -438.0_dp, TEMP ) ; + {067:044} OLT+HO=OLTP : ARR2( 5.72D-12 , -500.0_dp, TEMP ) ; + {068:045} OLI+HO=OLIP : ARR2( 1.33D-11 , -500.0_dp, TEMP ) ; + {069:046} DIEN+HO=ISOP : ARR2( 1.48D-11 , -448.0_dp, TEMP ) ; + {070:047} ISO+HO=ISOP : ARR2( 2.54D-11 , -410.0_dp, TEMP ) ; + {071:048} API+HO=APIP : ARR2( 1.21D-11 , -444.0_dp, TEMP ) ; + {072:049} LIM+HO=LIMP : 1.71D-10 ; + {073:050} TOL+HO=0.90 ADDT+0.10 XO2+0.10 HO2 : ARR2( 1.81D-12 , -355.0_dp, TEMP ) ; + {074:051} XYL+HO=0.90 ADDX+0.10 XO2+0.10 HO2 : ARR2( 7.30D-12 , -355.0_dp, TEMP ) ; + {075:052} CSL+HO=0.85 ADDC+0.10 PHO+0.05 HO2+0.05 XO2 : 6.00D-11 ; + {076:053} HCHO+HO=HO2+CO+H2O : 1.00D-11 ; + {077:054} ALD+HO=ACO3+H2O : ARR2( 5.55D-12 , -331.0_dp, TEMP ) ; + {078:055} KET+HO=KETP+H2O : (THERMAL_T2(5.68D-18, -92.0_dp,TEMP )) ; + {079:056} HKET+HO=HO2+MGLY+H2O : 3.00D-12 ; + {080:057} GLY+HO=HO2+2.0 CO+H2O : 1.14D-11 ; + {081:058} MGLY+HO=ACO3+CO+H2O : 1.72D-11 ; + {082:059} MACR+HO=0.51 TCO3+0.41 HKET+0.08 MGLY+0.41 CO+0.08 HCHO+0.49 HO2+0.49 XO2 : ARR2(1.86D-11, -175.0_dp, TEMP) ; + {083:060} DCB+HO=0.50 TCO3+0.50 HO2+0.50 XO2+0.35 UDD+0.15 GLY+0.15 MGLY : ARR2( 2.80D-11 , -175.0_dp, TEMP ) ; + {084:061} UDD+HO=0.88 ALD+0.12 KET+HO2 : 2.70D-10 ; + {085:062} OP1+HO=0.65 MO2+0.35 HCHO+0.35 HO : ARR2( 2.93D-12 , -190.0_dp, TEMP ) ; + {086:063} OP2+HO=0.44 HC3P+0.08 ALD+0.41 KET+0.49 HO+0.07 XO2 : ARR2( 3.40D-12 , -190.0_dp, TEMP ) ; + {087:064} PAA+HO=0.35 HCHO+0.65 ACO3+0.35 HO2+0.35 XO2 : ARR2( 2.93D-12 , -190.0_dp, TEMP ) ; + {088:065} PAN+HO=HCHO+XO2+H2O+NO3 : 4.00D-14 ; + {089:066} TPAN+HO=0.60 HKET+0.40 HCHO+0.40 HO2+XO2+0.40 PAN+0.60 NO3 : ARR2( 3.25D-13 , -500.0_dp, TEMP ) ; + {090:067} ONIT+HO=HC3P+NO2+H2O : ARR2( 5.31D-12 , 260.0_dp , TEMP) ; + {091:068} HCHO+NO3=HO2+HNO3+CO : ARR2( 3.40D-13 , 1900.0_dp, TEMP ) ; + {092:069} ALD+NO3=ACO3+HNO3 : ARR2( 1.40D-12 , 1900.0_dp, TEMP ) ; + {093:070} GLY+NO3=HNO3+HO2+2.0 CO : ARR2( 2.90D-12 , 1900.0_dp, TEMP ) ; + {094:071} MGLY+NO3=HNO3+ACO3+CO : ARR2( 1.40D-12 , 1900.0_dp, TEMP ) ; + {095:072} MACR+NO3=0.20 TCO3+0.20 HNO3+0.80 OLNN+0.80 CO : ARR2(8.27D-15, 150.0_dp, TEMP) ; + {096:073} DCB+NO3=0.5 TCO3+0.5 HO2+0.5 XO2+0.25 GLY+0.25 ALD+0.03 KET+0.25 MGLY+0.5 HNO3+0.5 NO2 : ARR2( 2.87D-13 , 1000.0_dp, TEMP ) ; + {097:074} CSL+NO3=HNO3+PHO : 2.20D-11 ; + {098:075} ETE+NO3=0.80 OLNN+0.20 OLND : (THERMAL_T2( 4.88D-18 , 2282.0_dp,TEMP )) ; + {099:076} OLT+NO3=0.43 OLNN+0.57 OLND : ARR2( 1.79D-13 , 450.0_dp, TEMP ) ; + {100:077} OLI+NO3=0.11 OLNN+0.89 OLND : ARR2( 8.64D-13 , -450.0_dp, TEMP ) ; + {101:078} DIEN+NO3=0.90 OLNN+0.10 OLND+0.90 MACR : 1.00D-13 ; + {102:079} ISO+NO3=0.90 OLNN+0.10 OLND+0.90 MACR : ARR2(4.0D-12, 446.0_dp, TEMP) ; + {103:080} API+NO3=0.10 OLNN+0.90 OLND : ARR2( 1.19D-12 , -490.0_dp, TEMP ) ; + {104:081} LIM+NO3=0.13 OLNN+0.87 OLND : 1.22D-11 ; + {105:082} TPAN+NO3=0.60 ONIT+0.60 NO3+0.40 PAN+0.40 HCHO+0.40 NO2+XO2 : ARR2( 2.20D-14 , 500.0_dp, TEMP ) ; + {106:083} ETE+O3=HCHO+0.43 CO+0.37 ORA1+0.26 HO2+0.12 HO{+0.13 H2} : ARR2( 9.14D-15 , 2580.0_dp, TEMP ) ; + {107:084} OLT+O3=0.64 HCHO+0.44 ALD+0.37 CO+0.14 ORA1+0.10 ORA2+0.25 HO2+0.40 HO+0.03 KET+0.03 KETP+0.06 CH4 +0.006 H2O2+0.03 ETH+0.19 MO2+0.10 ETHP{+0.05 H2} : ARR2( 4.33D-15, 1800.0_dp, TEMP ) ; + {108:085} OLI+O3=0.02 HCHO+0.99 ALD+0.16 KET+0.30 CO+0.011 H2O2+0.14 ORA2+0.07 CH4+0.22 HO2+0.63 HO+0.23 MO2+0.12 KETP+0.06 ETH+0.18 ETHP : ARR2( 4.40D-15 , 845.0_dp, TEMP ) ; + {109:086} DIEN+O3=0.90 HCHO+0.39 MACR+0.36 CO+0.15 ORA1+0.09 O3P+0.30 HO2+0.35 OLT+0.28 HO+0.15 ACO3+0.03 MO2+0.02 KETP+0.13 XO2+0.001 H2O2{+0.05 H2} : ARR2( 1.34D-14 , 2283.0_dp, TEMP ) ; + {110:087} ISO+O3=0.9 HCHO+0.39 MACR+0.36 CO +0.15 ORA1+0.09 O3P+0.30 HO2 +0.35 OLT+0.28 HO +0.15 ACO3+0.03 MO2+0.02 KETP+0.13 XO2 +0.001 H2O2{+0.05 H2} : ARR2(7.86D-15, 1913.0_dp, TEMP) ; + {111:088} API+O3=0.65 ALD+0.53 KET+0.14 CO+0.20 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2 : ARR2( 1.01D-15 , 732.0_dp, TEMP ) ; + {112:089} LIM+O3=0.04 HCHO+0.46 OLT+0.14 CO+0.16 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2+0.79 MACR+0.01 ORA1+0.07 ORA2 : 2.00D-16 ; + {113:090} MACR+O3=0.40 HCHO+0.60 MGLY+0.13 ORA2+0.54 CO+0.22 ORA1+0.29 HO2+0.07 HO+0.13 OP2+0.13 ACO3 {+0.08 H2} : ARR2(1.36D-15, 2112.0_dp, TEMP) ; + {114:091} DCB+O3=0.21 HO+0.29 HO2+0.66 CO+0.50 GLY+0.28 ACO3+0.16 ALD+0.62 MGLY+0.11 PAA+0.11 ORA1+0.21 ORA2 : 2.00D-18 ; + {115:092} TPAN+O3=0.70 HCHO+0.30 PAN+0.70 NO2+0.13 CO+0.11 ORA1+0.08 HO2+0.036 HO+0.70 ACO3{+0.04 H2} : ARR2( 2.46D-15 , 1700.0_dp, TEMP ) ; + {116:093} PHO+NO2=0.10 CSL+ONIT : 2.00D-11 ; + {117:094} PHO+HO2=CSL : 1.00D-11 ; + {118:095} ADDT+NO2=CSL+HONO : 3.60D-11 ; + {119:096} ADDT+M {O2}=0.98 TOLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66D-17 , -1044.0_dp, TEMP )) ; + {120:097} ADDT+O3=CSL+HO : 5.00D-11 ; + {121:098} ADDX+NO2=CSL+HONO : 3.60D-11 ; + {122:099} ADDX+M{O2}=0.98 XYLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66D-17 , -1044.0_dp, TEMP )) ; + {123:100} ADDX+O3=CSL+HO : 1.00D-11 ; + {124:101} ADDC+NO2=CSL+HONO : 3.60D-11 ; + {125:102} ADDC+M{O2}=0.98 CSLP+0.02 CSL+0.02 HO2 : (.20946e0*ARR2( 1.66D-17 , -1044.0_dp, TEMP )) ; + {126:103} ADDC+O3=CSL+HO : 5.00D-11 ; + {127:104} ACO3+NO2=PAN : TROE( 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M) ; + {128:105} PAN=ACO3+NO2 : TROEE(1.16D28,13954.0_dp, 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M) ; + {129:106} TCO3+NO2=TPAN : TROE( 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M) ; + {130:107} TPAN=TCO3+NO2 : TROEE(1.16D28,13954.0_dp, 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M ) ; + {131:108} MO2+NO=HCHO+HO2+NO2 : ARR2( 4.20D-12 , -180.0_dp, TEMP ) ; + {132:109} ETHP+NO=ALD+HO2+NO2 : 8.70D-12 ; + {133:110} HC3P+NO=0.047 HCHO+0.233 ALD+0.623 KET+0.063 GLY+0.742 HO2+0.15 MO2+0.048 ETHP+0.048 XO2+0.059 ONIT+0.941 NO2 : 4.00D-12 ; + {134:111} HC5P+NO=0.021 HCHO+0.211 ALD+0.722 KET+0.599 HO2+0.031 MO2+0.245 ETHP+0.334 XO2+0.124 ONIT+0.876 NO2 : 4.00D-12 ; + {135:112} HC8P+NO=0.15 ALD+0.642 KET+0.133 ETHP+0.261 ONIT+0.739 NO2+0.606 HO2+0.416 XO2 : 4.00D-12 ; + {136:113} ETEP+NO=1.6 HCHO+HO2+NO2+0.2 ALD : 9.00D-12 ; + {137:114} OLTP+NO=0.94 ALD+HCHO+HO2+NO2+0.06 KET : 4.00D-12 ; + {138:115} OLIP+NO=HO2+1.71 ALD+0.29 KET+NO2 : 4.00D-12 ; + {139:116} ISOP+NO=0.446 MACR+0.354 OLT +0.847 HO2+0.606 HCHO+0.153 ONIT+0.847 NO2 : 4.0D-12 ; + {140:117} APIP+NO=0.80 HO2+0.80 ALD+0.80 KET+0.20 ONIT+0.80 NO2 : 4.00D-12 ; + {141:118} LIMP+NO=0.65 HO2+0.40 MACR+0.25 OLI+0.25 HCHO+0.35 ONIT+0.65 NO2 : 4.00D-12 ; + {142:119} TOLP+NO=0.95 NO2+0.95 HO2+0.65 MGLY+1.20 GLY+0.50 DCB+0.05 ONIT : 4.00D-12 ; + {143:120} XYLP+NO=0.95 NO2+0.95 HO2+0.60 MGLY+0.35 GLY+0.95 DCB+0.05 ONIT : 4.00D-12 ; + {144:121} CSLP+NO=GLY+MGLY+HO2+NO2 : 4.00D-12 ; + {145:122} ACO3+NO=MO2+NO2 : 2.00D-11 ; + {146:123} TCO3+NO=ACO3+HCHO+NO2 : 2.00D-11 ; + {147:124} KETP+NO=0.54 MGLY+0.46 ALD+0.23 ACO3+0.77 HO2+0.16 XO2+NO2 : 4.00D-12 ; + {148:125} OLNN+NO=HO2+ONIT+NO2 : 4.00D-12 ; + {149:126} OLND+NO=0.287 HCHO+1.24 ALD+0.464 KET+2.0 NO2 : 4.00D-12 ; + {150:127} MO2+HO2=OP1 : ARR2( 3.80D-13 , -800.0_dp, TEMP ) ; + {151:128} ETHP+HO2=OP2 : ARR2( 7.50D-13 , -700.0_dp, TEMP ) ; + {152:129} HC3P+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {153:130} HC5P+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {154:131} HC8P+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {155:132} ETEP+HO2=OP2 : ARR2( 1.90D-13 , -1300.0_dp, TEMP ) ; + {156:133} OLTP+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {157:134} OLIP+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {158:135} ISOP+HO2=OP2 : ARR2( 1.28D-13 , -1300.0_dp, TEMP) ; + {159:136} APIP+HO2=OP2 : 1.50D-11 ; + {160:137} LIMP+HO2=OP2 : 1.50D-11 ; + {161:138} TOLP+HO2=OP2 : ARR2( 3.75D-13 , -980.0_dp, TEMP ) ; + {162:139} XYLP+HO2=OP2 : ARR2( 3.75D-13 , -980.0_dp, TEMP) ; + {163:140} CSLP+HO2=OP2 : ARR2( 3.75D-13 , -980.0_dp, TEMP ) ; + {164:141} ACO3+HO2=PAA : ARR2( 1.15D-12 , -550.0_dp, TEMP ) ; + {165:142} ACO3+HO2=ORA2+O3 : ARR2( 3.86D-16 , -2640.0_dp, TEMP ) ; + {166:143} TCO3+HO2=OP2 : ARR2( 1.15D-12 , -550.0_dp, TEMP ) ; + {167:144} TCO3+HO2=ORA2+O3 : ARR2( 3.86D-16 , -2640.0_dp, TEMP ) ; + {168:145} KETP+HO2=OP2 : ARR2( 1.15D-13 , -1300.0_dp, TEMP ) ; + {169:146} OLNN+HO2=ONIT : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {170:147} OLND+HO2=ONIT : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {171:148} MO2+MO2=1.33 HCHO+0.66 HO2 : ARR2( 9.10D-14 , -416.0_dp, TEMP ) ; + {172:149} ETHP+MO2=0.75 HCHO+HO2+0.75 ALD : ARR2( 1.18D-13 , -158.0_dp, TEMP ) ; + {173:150} HC3P+MO2=0.81 HCHO+0.992 HO2+0.58 ALD+0.018 KET+0.007 MO2+0.005 MGLY+0.085 XO2+0.119 GLY : ARR2( 9.46D-14 , -431.0_dp , TEMP) ; + {174:151} HC5P+MO2=0.829 HCHO+0.946 HO2+0.523 ALD+0.24 KET+0.014 ETHP+0.049 MO2+0.245 XO2 : ARR2( 1.00D-13 , -467.0_dp, TEMP ) ; + {175:152} HC8P+MO2=0.753 HCHO+0.993 HO2+0.411 ALD+0.419 KET+0.322 XO2+0.013 ETHP : ARR2( 4.34D-14 , -633.0_dp, TEMP ) ; + {176:153} ETEP+MO2=1.55 HCHO+HO2+0.35 ALD : ARR2( 1.71D-13 , -708.0_dp, TEMP ) ; + {177:154} OLTP+MO2=1.25 HCHO+HO2+0.669 ALD+0.081 KET : ARR2( 1.46D-13 , -708.0_dp, TEMP ) ; + {178:155} OLIP+MO2=0.755 HCHO+HO2+0.932 ALD+0.313 KET : ARR2( 9.18D-14 , -708.0_dp, TEMP ) ; + {179:156} ISOP+MO2=0.550 MACR+0.370 OLT+HO2+0.08 OLI+1.09 HCHO : ARR2( 1.36D-13 , -708.0_dp, TEMP ) ; + {180:157} APIP+MO2=HCHO+ALD+KET+2.0 HO2 : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {181:158} LIMP+MO2=1.4 HCHO+0.60 MACR+0.40 OLI+2.0 HO2 : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {182:159} TOLP+MO2=HCHO+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {183:160} XYLP+MO2=HCHO+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {184:161} CSLP+MO2=GLY+MGLY+HCHO+2.0 HO2 : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {185:162} ACO3+MO2=HCHO+HO2+MO2 : ARR2( 3.21D-11 , 440.0_dp, TEMP ) ; + {186:163} ACO3+MO2=HCHO+ORA2 : ARR2( 2.68D-16 , -2510.0_dp, TEMP ) ; + {187:164} TCO3+MO2=2.0 HCHO+HO2+ACO3 : ARR2( 3.21D-11 , 440.0_dp, TEMP ) ; + {188:165} TCO3+MO2=HCHO+ORA2 : ARR2( 2.68D-16 , -2510.0_dp, TEMP ) ; + {189:166} KETP+MO2=0.75 HCHO+0.88 HO2+0.40 MGLY+0.30 ALD+0.30 HKET+0.12 ACO3+0.08 XO2 : ARR2( 6.91D-13 , -508.0_dp, TEMP ) ; + {190:167} OLNN+MO2=0.75 HCHO+HO2+ONIT : ARR2( 1.60D-13 , -708.0_dp, TEMP ) ; + {191:168} OLND+MO2=0.96 HCHO+0.5 HO2+0.64 ALD+0.149 KET+0.5 NO2+0.5 ONIT : ARR2( 9.68D-14 , -708.0_dp, TEMP ) ; + {192:169} ETHP+ACO3=ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 1.03D-12 , -211.0_dp, TEMP ) ; + {193:170} HC3P+ACO3=0.724 ALD+0.127 KET+0.488 HO2+0.508 MO2+0.006 ETHP+0.071 XO2+0.091 HCHO+0.10 GLY+0.499 ORA2+0.004 MGLY : ARR2( 6.90D-13 , -460.0_dp, TEMP ) ; + {194:171} HC5P+ACO3=0.677 ALD+0.33 KET+0.438 HO2+0.554 MO2+0.495 ORA2+0.018 ETHP+0.237 XO2+0.076 HCHO : ARR2( 5.59D-13 , -522.0_dp, TEMP ) ; + {195:172} HC8P+ACO3=0.497 ALD+0.581 KET+0.489 HO2+0.507 MO2+0.495 ORA2+0.015 ETHP+0.318 XO2 : ARR2( 2.47D-13 , -683.0_dp, TEMP ) ; + {196:173} ETEP+ACO3=0.8 HCHO+0.6 ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 9.48D-13 , -765.0_dp, TEMP ) ; + {197:174} OLTP+ACO3=0.859 ALD+0.501 HCHO+0.501 HO2+0.501 MO2+0.499 ORA2+0.141 KET : ARR2( 8.11D-13 , -765.0_dp, TEMP ) ; + {198:175} OLIP+ACO3=0.941 ALD+0.569 KET+0.51 HO2+0.51 MO2+0.49 ORA2 : ARR2( 5.09D-13 , -765.0_dp, TEMP ) ; + {199:176} ISOP+ACO3=0.771 MACR+0.229 OLT+0.506 HO2+0.494 ORA2+0.340 HCHO+0.506 MO2 : ARR2( 7.60D-13 , -765.0_dp, TEMP ) ; + {200:177} APIP+ACO3=ALD+KET+HO2+MO2 : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {201:178} LIMP+ACO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+MO2 : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {202:179} TOLP+ACO3=MO2+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {203:180} XYLP+ACO3=MO2+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {204:181} CSLP+ACO3=GLY+MGLY+MO2+HO2 : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {205:182} ACO3+ACO3=2.0 MO2 : ARR2( 2.80D-12 , -530.0_dp, TEMP ) ; + {206:183} TCO3+ACO3=MO2+ACO3+HCHO : ARR2( 2.80D-12 , -530.0_dp, TEMP ) ; + {207:184} KETP+ACO3=0.54 MGLY+0.35 ALD+0.11 KET+0.12 ACO3+0.38 HO2+0.08 XO2+0.5 MO2+0.5 ORA2 : ARR2( 7.51D-13 , -565.0_dp, TEMP ) ; + {208:185} OLNN+ACO3=ONIT+0.5 ORA2+0.5 MO2+0.5 HO2 : ARR2( 8.85D-13 , -765.0_dp, TEMP ) ; + {209:186} OLND+ACO3=0.207 HCHO+0.65 ALD+0.167 KET+0.484 ORA2+0.484 ONIT+0.516 NO2+0.516 MO2 : ARR2( 5.37D-13 , -765.0_dp, TEMP ) ; + {210:187} OLNN+OLNN=2.0 ONIT+HO2 : ARR2( 7.00D-14 , -1000.0_dp , TEMP) ; + {211:188} OLNN+OLND=0.202 HCHO+0.64 ALD+0.149 KET+0.50 HO2+1.50 ONIT+0.50 NO2 : ARR2( 4.25D-14 , -1000.0_dp, TEMP ) ; + {212:189} OLND+OLND=0.504 HCHO+1.21 ALD+0.285 KET+ONIT+NO2 : ARR2( 2.96D-14 , -1000.0_dp, TEMP ) ; + {213:190} MO2+NO3=HCHO+HO2+NO2 : 1.20D-12 ; + {214:191} ETHP+NO3=ALD+HO2+NO2 : 1.20D-12 ; + {215:192} HC3P+NO3=0.048 HCHO+0.243 ALD+0.67 KET+0.063 GLY+0.792 HO2+0.155 MO2+0.053 ETHP+0.051 XO2+NO2 : 1.20D-12 ; + {216:193} HC5P+NO3=0.021 HCHO+0.239 ALD+0.828 KET+0.699 HO2+0.04 MO2+0.262 ETHP+0.391 XO2+NO2 : 1.20D-12 ; + {217:194} HC8P+NO3=0.187 ALD+0.88 KET+0.845 HO2+0.155 ETHP+0.587 XO2+NO2 : 1.20D-12 ; + {218:195} ETEP+NO3=1.6 HCHO+0.2 ALD+HO2+NO2 : 1.20D-12 ; + {219:196} OLTP+NO3=HCHO+0.94 ALD+0.06 KET+HO2+NO2 : 1.20D-12 ; + {220:197} OLIP+NO3=1.71 ALD+0.29 KET+HO2+NO2 : 1.20D-12 ; + {221:198} ISOP+NO3=0.60 MACR+0.40 OLT +0.686 HCHO+HO2+NO2 : 1.20D-12 ; + {222:199} APIP+NO3=ALD+KET+HO2+NO2 : 1.20D-12 ; + {223:200} LIMP+NO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+NO2 : 1.20D-12 ; + {224:201} TOLP+NO3=0.70 MGLY+1.30 GLY+0.50 DCB+HO2+NO2 : 1.20D-12 ; + {225:202} XYLP+NO3=1.26 MGLY+0.74 GLY+DCB+HO2+NO2 : 1.20D-12 ; + {226:203} CSLP+NO3=GLY+MGLY+HO2+NO2 : 1.20D-12; + {227:204} ACO3+NO3=MO2+NO2 : 4.00D-12; + {228:205} TCO3+NO3=HCHO+ACO3+NO2 : 4.00D-12; + {229:206} KETP+NO3=0.54 MGLY+0.46 ALD+0.77 HO2+0.23 ACO3+0.16 XO2+NO2 : 1.20D-12 ; + {230:207} OLNN+NO3=ONIT+HO2+NO2 : 1.20D-12 ; + {231:208} OLND+NO3=0.28 HCHO+1.24 ALD+0.469 KET+2.0 NO2 : 1.20D-12 ; + {232:209} XO2+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {233:210} XO2+MO2=HCHO+HO2 : ARR2( 5.99D-15 , -1510.0_dp, TEMP ) ; + {234:211} XO2+ACO3=MO2 : ARR2( 3.40D-14 , -1560.0_dp, TEMP ) ; + {235:212} XO2+XO2=M{O2} : ARR2( 7.13D-17 , -2950.0_dp, TEMP ) ; + {236:213} XO2+NO=NO2 : 4.00D-12 ; + {237:214} XO2+NO3=NO2 : 1.20D-12 ; + + + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.kpp b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.kpp new file mode 100644 index 00000000..ee5b49b1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.kpp @@ -0,0 +1,10 @@ +#MODEL racmsorg_aqchem +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.spc b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.spc new file mode 100644 index 00000000..bd882298 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem.spc @@ -0,0 +1,81 @@ +#DEFVAR + O3 =IGNORE ; + H2O2 =IGNORE ; + NO =IGNORE ; + NO2 =IGNORE ; + NO3 =IGNORE ; + N2O5 =IGNORE ; + HONO =IGNORE ; + HNO3 =IGNORE ; + HNO4 =IGNORE ; + SO2 =IGNORE ; + SULF =IGNORE ; + CO =IGNORE ; + CO2 =IGNORE ; + CH4 =IGNORE ; + ETH =IGNORE ; + HC3 =IGNORE ; + HC5 =IGNORE ; + HC8 =IGNORE ; + ETE =IGNORE ; + OLT =IGNORE ; + OLI =IGNORE ; + DIEN =IGNORE ; + ISO =IGNORE ; + API =IGNORE ; + LIM =IGNORE ; + TOL =IGNORE ; + XYL =IGNORE ; + CSL =IGNORE ; + HCHO =IGNORE ; + ALD =IGNORE ; + KET =IGNORE ; + GLY =IGNORE ; + MGLY =IGNORE ; + DCB =IGNORE ; + MACR =IGNORE ; + UDD =IGNORE ; + HKET =IGNORE ; + ONIT =IGNORE ; + PAN =IGNORE ; + TPAN =IGNORE ; + OP1 =IGNORE ; + OP2 =IGNORE ; + PAA =IGNORE ; + ORA1 =IGNORE ; + ORA2 =IGNORE ; + HO =IGNORE ; + HO2 =IGNORE ; + O3P =IGNORE ; + O1D =IGNORE ; + MO2 =IGNORE ; + ETHP =IGNORE ; + HC3P =IGNORE ; + HC5P =IGNORE ; + HC8P =IGNORE ; + ETEP =IGNORE ; + OLTP =IGNORE ; + OLIP =IGNORE ; + ISOP =IGNORE ; + APIP =IGNORE ; + LIMP =IGNORE ; + PHO =IGNORE ; + ADDT =IGNORE ; + ADDX =IGNORE ; + ADDC =IGNORE ; + TOLP =IGNORE ; + XYLP =IGNORE ; + CSLP =IGNORE ; + ACO3 =IGNORE ; + TCO3 =IGNORE ; + KETP =IGNORE ; + XO2 =IGNORE ; + OLNN =IGNORE ; + OLND =IGNORE; +#DEFFIX + H2O = IGNORE ; {water} + M = IGNORE ; +{ H2O = H+2O ;} +{ N2 = N+N ;} +{ O2 = IGNORE ;} +{ H2 = IGNORE ;} diff --git a/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem_wrfkpp.equiv new file mode 100644 index 00000000..e4c23b7a --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racmsorg_aqchem/racmsorg_aqchem_wrfkpp.equiv @@ -0,0 +1,9 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +rpho pho + diff --git a/wrfv2_fire/chem/Makefile b/wrfv2_fire/chem/Makefile index c2d9e4fd..152c12cd 100755 --- a/wrfv2_fire/chem/Makefile +++ b/wrfv2_fire/chem/Makefile @@ -53,6 +53,10 @@ MODULES = \ module_gocart_dust.o \ module_gocart_dust_afwa.o \ module_gocart_seasalt.o \ + module_uoc_dust.o \ + module_qf03.o \ + module_soilpsd.o \ + module_dust_load.o \ module_mosaic_addemiss.o \ module_mosaic_initmixrats.o \ module_mosaic_movesect.o \ diff --git a/wrfv2_fire/chem/aerosol_driver.F b/wrfv2_fire/chem/aerosol_driver.F index 17fe495b..9aceda5d 100755 --- a/wrfv2_fire/chem/aerosol_driver.F +++ b/wrfv2_fire/chem/aerosol_driver.F @@ -231,7 +231,7 @@ SUBROUTINE aerosols_driver (id,curr_secs,ktau,dtstep,ktauc, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (RACMSORG_AQ,RACMSORG_AQCHEM,RACMSORG_KPP,RACM_ESRLSORG_KPP) + CASE (RACMSORG_AQ,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACMSORG_KPP,RACM_ESRLSORG_KPP) ! ???? are separate cases needed here for radm2sorg and racmsorg packages ???? CALL wrf_debug(15,'aerosols_driver calling sorgam_driver') do ii=its,ite @@ -255,7 +255,8 @@ SUBROUTINE aerosols_driver (id,curr_secs,ktau,dtstep,ktauc, & CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, & CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP, & - CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ) + CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) CALL wrf_debug(15,'aerosols_driver calling mosaic_aerchem_driver') CALL mosaic_aerchem_driver( & id, curr_secs, ktau, dtstep, ktauc, dtstepc, config_flags, & @@ -388,8 +389,8 @@ SUBROUTINE sum_pm_driver ( config_flags, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RACMSORG_AQ,RACMSORG_AQCHEM,RADM2SORG_KPP,RACMSORG_KPP,RACM_ESRLSORG_KPP, & - CBMZSORG,CBMZSORG_AQ) + CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RACMSORG_AQ,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RADM2SORG_KPP, & + RACMSORG_KPP,RACM_ESRLSORG_KPP,CBMZSORG,CBMZSORG_AQ) CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_sorgam') CALL sum_pm_sorgam ( & alt, chem, h2oaj, h2oai, & @@ -408,7 +409,8 @@ SUBROUTINE sum_pm_driver ( config_flags, & its,ite, jts,jte, kts,kte ) ! CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & - CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ) + CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_mosaic') call sum_pm_mosaic ( & alt, chem, & diff --git a/wrfv2_fire/chem/chem_driver.F b/wrfv2_fire/chem/chem_driver.F index d3fc777f..3c963b05 100755 --- a/wrfv2_fire/chem/chem_driver.F +++ b/wrfv2_fire/chem/chem_driver.F @@ -4,15 +4,6 @@ ! William Gustafson (PNNL), Marc Salzmann (GFDL), and Georg Grell ! 10/12/2011 - Ravan Ahmadov (NOAA) updated to include the RACM_SOA_VBS option ! -#if ( NMM_CORE == 1 ) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!NCEP_MESO:MEDIATION_LAYER:SOLVER -! -!----------------------------------------------------------------------- -#include "../dyn_nmm/nmm_loop_basemacros.h" -#include "../dyn_nmm/nmm_loop_macros.h" -!----------------------------------------------------------------------- -#endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine chem_driver ( grid , config_flags & @@ -22,17 +13,12 @@ subroutine chem_driver ( grid , config_flags & !---------------------------------------------------------------------- USE module_domain , only : domain USE module_configure -#if ( EM_CORE == 1 ) USE module_driver_constants USE module_machine USE module_tiles -#endif USE module_dm USE module_model_constants USE module_state_description -#if ( NMM_CORE == 1 ) - USE MODULE_PHYSICS_CALLS -#endif USE module_data_radm2 USE module_data_sorgam USE module_radm @@ -45,9 +31,8 @@ subroutine chem_driver ( grid , config_flags & USE module_gocart_so2so4 USE module_aer_opt_out,only: aer_opt_out USE module_ctrans_grell -! USE module_aerosols_soa_vbs, only: USE module_data_soa_vbs, only: ldrog_vbs -! + USE module_dust_load USE module_dry_dep_driver USE module_emissions_driver USE module_input_tracer, only: set_tracer @@ -145,14 +130,7 @@ end SUBROUTINE sum_pm_driver ! ! Definitions of dummy arguments to solve # include -#if ( EM_CORE == 1 ) # define NO_I1_OLD -#endif -#if ( NMM_CORE == 1 ) -# ifdef DM_PARALLEL - INCLUDE "mpif.h" -# endif -#endif TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags @@ -164,32 +142,11 @@ end SUBROUTINE sum_pm_driver ! .. Local Scalars .. INTEGER :: stepave,i,j,k,l,numgas,nv,n, nr,ktau,k_start,k_end,idf,jdf,kdf INTEGER :: ijulian +! UoC dust scheme option + INTEGER :: imod ! REAL :: convtrans_avglen_m ! ................................................................ -! .. -! -! necessary for aerosols (module dependent) -! -#if ( NMM_CORE == 1 ) - real, dimension(grid%sm31:grid%em31,grid%sm33:grid%em33,grid%sm32:grid%em32) ::vcsulf_old,vcso2_old - real, dimension(grid%sm31:grid%em31,grid%sm33:grid%em33,grid%sm32:grid%em32,ldrog) ::vdrog3 - - real, dimension(grid%sm31:grid%em31,grid%sm33:grid%em33,grid%sm32:grid%em32,ldrog_vbs) ::vdrog3_vbs - - real, dimension(grid%sm31:grid%em31,grid%sm33:grid%em33,grid%sm32:grid%em32) ::n2o5_het - REAL,DIMENSION(grid%sm31:grid%em31,grid%sm33:grid%em33,grid%sm32:grid%em32) :: & - p_phy,u_phy,v_phy & - ,t_phy,dz8w,t8w,p8w & - ,rho,rri,z_at_w,vvel,zmid - REAL,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32) :: pbl_h - REAL,DIMENSION(grid%sm33:grid%em33-1) :: QL,TL - REAL,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32) :: REXNSFC,FACTRS & - ,TOT,TSFC - REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: moist_trans - REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: scalar_trans -#endif -#if ( EM_CORE == 1 ) real, dimension(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) ::vcsulf_old,vcso2_old,vch2o2_old real, dimension(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,ldrog) ::vdrog3 @@ -210,7 +167,6 @@ end SUBROUTINE sum_pm_driver REAL,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33,num_chem_ct) :: chem_old INTEGER,DIMENSION(num_chem_ct) :: chem_ct_indices -#endif ! Variables for adaptive time steps... TYPE(WRFU_TimeInterval) :: tmpTimeInterval REAL(KIND=8) :: curr_secs @@ -241,9 +197,9 @@ end SUBROUTINE sum_pm_driver REAL, DIMENSION( grid%sm31:grid%em31, grid%sm32:grid%em32, grid%sm33:grid%em33,gas_pcnst_pos) :: dvmrdt_sv13d,dvmrcwdt_sv13d LOGICAL :: haveaer - CHARACTER (LEN=1000) :: msg !BSINGH:01/31/2013: For message string - CHARACTER (LEN=256) :: current_date_char !shc - integer :: current_month !shc + CHARACTER (LEN=1000) :: msg + CHARACTER (LEN=256) :: current_date_char + integer :: current_month ! .. ! .. Intrinsic Functions .. INTRINSIC max, min @@ -292,17 +248,6 @@ end SUBROUTINE sum_pm_driver ! Setup the adaptive timestep for the chem routines. Most of this follows ! what is in solve_em, except for the call to adjust time_step. ! -#if ( NMM_CORE == 1) - !NMM defaults to the old step counting methodology in physics so we - !will do the same here in chemistry. In theory, adapt_step_flag can - !probably be set to TRUE for NMM too using the curr_secs calculated - !with ktau, but I do not have input files to test NMM. (wig, 12-May-2008) - adapt_step_flag = .FALSE. - KTAU=GRID%NTSD - curr_secs = (ktau-1)*real(grid%dt,8) !I think this breaks around 68 yrs w/ i4 - ijulian=ifix(grid%julian) -#endif -#if ( EM_CORE == 1 ) !The necesssary variables exist for the EM core and using the adaptive !techniques will work even with a constant time step. In fact, they !prevent issues with restarts and changed time steps. So, we will @@ -312,7 +257,6 @@ end SUBROUTINE sum_pm_driver tmpTimeInterval = domain_get_time_since_sim_start(grid) curr_secs = real_time_r8(tmpTimeInterval) ijulian=ifix(grid%julian) -#endif do_photstep = .false. IF ( ktau==1 ) then @@ -332,25 +276,15 @@ end SUBROUTINE sum_pm_driver do_photstep = .true. ENDIF -#if (NMM_CORE == 1) - if( ktau==1 ) then - dtstepc=grid%dt - else - dtstepc=grid%dt*float(grid%stepchem) - end if -#endif -#if (EM_CORE == 1) if( ktau==1 ) then dtstepc = grid%dt else tmpTimeInterval = domain_get_current_time(grid) - last_chem_time(grid%id) dtstepc = real(real_time_r8(tmpTimeInterval),4) end if -#endif ! initializing diagnostics and macros -#if (EM_CORE == 1) if( ktau==1 ) then grid%conv_ct(:,:,:,:) = 0. grid%chem_ct(:,:,:,:) = 0. @@ -367,7 +301,6 @@ end SUBROUTINE sum_pm_driver chem_ct_indices(p_chem_ho) = p_ho chem_ct_indices(p_chem_ho2) = p_ho2 endif -#endif do_chemstep = .false. IF ( ktau==1 ) then @@ -417,62 +350,19 @@ end SUBROUTINE sum_pm_driver if(config_flags%cu_diag == 0 ) grid%raincv_b(:,:) = grid%raincv(:,:) -#if ( NMM_CORE == 1 ) -!*** IN NMM SET CONTROLS FOR TILES TO PATCHES -! -!----------------------------------------------------------------------- - IDF=IDE-1 - JDF=JDE-1 - KDF=KDE-2 ! DO NOT do chem at the top level to mimic what used to be done (also prevents a solver failure at kde-1 for MADE/SORGAM) - ITS=IPS - ITE=MIN(IPE,IDF) - JTS=JPS - JTE=MIN(JPE,JDF) - KTS=KPS - KTE=MIN(KPE,KDF) - -#endif - - num_3d_m = num_moist num_3d_c = num_chem num_3d_s = num_scalar numgas = get_last_gas(config_flags%chem_opt) - -#if ( EM_CORE == 1 ) - ! Compute these starting and stopping locations for each tile and number of tiles. CALL set_tiles ( grid , ids , ide , jds , jde , ips , ipe , jps , jpe ) k_start = kps k_end = kpe -#endif ijds = min(ids, jds) ijde = max(ide, jde) -#if ( NMM_CORE ==1) - allocate(moist_trans(ims:ime,kms:kme,jms:jme,num_3d_m)) - allocate(scalar_trans(ims:ime,kms:kme,jms:jme,num_3d_s)) - DO l=1,num_3d_m - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - moist_trans(i,k,j,l)=moist(i,j,k,l) - ENDDO - ENDDO - ENDDO - ENDDO - DO l=1,num_3d_s - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - scalar_trans(i,k,j,l)=scalar(i,j,k,l) - ENDDO - ENDDO - ENDDO - ENDDO -#endif chem_minval = epsilc !chem_minval can be case dependant and set below... chem_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2) @@ -481,6 +371,9 @@ end SUBROUTINE sum_pm_driver CASE (RADM2_KPP) CALL wrf_debug(15,'calling radm2_kpp from chem_driver') haveaer = .false. + CASE (CRIMECH_KPP) + CALL wrf_debug(15,'calling crimech_kpp from chem_driver') + haveaer = .false. CASE (RADM2SORG) CALL wrf_debug(15,'calling radm2sorg aerosols driver from chem_driver') haveaer = .true. @@ -496,8 +389,11 @@ end SUBROUTINE sum_pm_driver CASE (RADM2SORG_AQCHEM) CALL wrf_debug(15,'calling radm2sorg_aqchem aerosols driver from chem_driver') haveaer = .true. - CASE (RACMSORG_AQCHEM) - CALL wrf_debug(15,'calling racmsorg_aqchem aerosols driver from chem_driver') + CASE (RACMSORG_AQCHEM_KPP) + CALL wrf_debug(15,'calling racmsorg_aqchem_kpp aerosols driver from chem_driver') + haveaer = .true. + CASE (RACM_ESRLSORG_AQCHEM_KPP) + CALL wrf_debug(15,'calling racm_esrlsorg_aqchem_kpp aerosols driver from chem_driver') haveaer = .true. CASE (RACM_KPP) CALL wrf_debug(15,'calling racm_kpp from chem_driver') @@ -583,6 +479,12 @@ end SUBROUTINE sum_pm_driver CASE (CBMZ_MOSAIC_DMS_8BIN_AQ) CALL wrf_debug(15,'calling cbmz_mosaic_dms_8bin_aq aerosols driver from chem_driver') haveaer = .true. + CASE (CRI_MOSAIC_8BIN_AQ_KPP) + CALL wrf_debug(15,'calling cri_mosaic_8bin_aq_kpp aerosols driver from chem_driver') + haveaer = .true. + CASE (CRI_MOSAIC_4BIN_AQ_KPP) + CALL wrf_debug(15,'calling cri_mosaic_4bin_aq_kpp aerosols driver from chem_driver') + haveaer = .true. CASE (MOZART_KPP) CALL wrf_debug(15,'calling mozart driver from chem_driver') CASE (MOZCART_KPP) @@ -642,114 +544,6 @@ end SUBROUTINE sum_pm_driver ! ! ! -#if ( NMM_CORE == 1 ) - k_start = kts - k_end = min(kpe,kde-1) -! this should be in seperate routine!!!!!! - GRID%SIGMA=1 - grid%HYDRO=.FALSE. - its=max(its,MYIS1) - jts=max(jts,MYJS2) - ite=min(ite,MYIE1) - jte=min(jte,MYJE2) - DO J=jts,jte - DO I=its,ite - pbl_h(i,j)=grid%pblh(i,j) -! -! PDSL=PD(I,J)*RES(I,J) -!----------------------------------------------------------------------- -!*** LONG AND SHORTWAVE FLUX AT GROUND SURFACE -!----------------------------------------------------------------------- - IF(grid%CZMEAN(I,J)>0.) THEN - FACTRS(I,J)=grid%CZEN(I,J)/grid%CZMEAN(I,J) - ELSE - FACTRS(I,J)=0. - ENDIF - grid%GSW(I,J)=(grid%RSWIN(I,J)-grid%RSWOUT(I,J))*grid%HBM2(I,J)*FACTRS(I,J) - P8W(I,KTE+1,J)=grid%PT - grid%XLAT(I,J)=grid%GLAT(I,J)/DEGRAD - grid%XLONG(I,J)=grid%GLON(I,J)/DEGRAD - grid%XLAND(I,J)=grid%SM(I,J)+1. - grid%PSFC(i,j)=grid%PD(I,J)+grid%PDTOP+grid%PT - grid%UST(I,J)=grid%USTAR(I,J) - REXNSFC(I,J)=(grid%PSFC(i,j)*1.E-5)**CAPA - TSFC(I,J)=grid%THS(I,J)*REXNSFC(I,J) - grid%TSK(I,J)=TSFC(I,J) - - T8W(I,1,J)=TSFC(I,J) - P8W(I,KTS,J)=grid%ETA1(KTS)*grid%PDTOP+grid%ETA2(KTS)*grid%PDSL(i,j)+grid%PT -! -!----------------------------------------------------------------------- -!*** FILL THE SINGLE-COLUMN INPUT -!----------------------------------------------------------------------- -! - z_at_w(i,kts,j)=grid%fis(i,j)/g - DO K=KTS,KTE+1 - vvel(i,k,j)=grid%w(i,j,k) - DPL=grid%DETA1(K)*grid%PDTOP+grid%DETA2(K)*grid%PDSL(i,j) - QL(K)=AMAX1(grid%Q(I,J,K),EPSQ) - PLYR=grid%AETA1(K)*grid%PDTOP+grid%AETA2(K)*grid%PDSL(i,j)+grid%PT - TL(K)=grid%T(I,J,K) -! -! here rri is inverse density! -! - RHO(I,K,J)=PLYR/(R_D*TL(K)*(1.+P608*QL(K))) - RRI(I,K,J)=1./RHO(i,k,j) - T_PHY(I,K,J)=TL(K) - moist_trans(I,K,J,P_QV)=QL(K)/(1.-QL(K)) - P8W(I,K+1,J)=grid%ETA1(K+1)*grid%PDTOP+grid%ETA2(K+1)*grid%PDSL(i,j)+grid%PT - P_PHY(I,K,J)=PLYR - DZ8W(I,K,J)=TL(K)*(P608*QL(K)+1.)*R_D & - & *(P8W(I,K,J)-P8W(I,K+1,J)) & - & /(P_PHY(I,K,J)*G) - if(K.gt.kts)then - Z_AT_W(i,k,j)=Z_AT_W(I,k-1,j)+DZ8W(I,K-1,J) - ZMID(I,K-1,J)=.5*(Z_AT_W(I,K-1,J)+Z_AT_W(I,K,J)) - endif - - ENDDO -! - DO K=KTS+1,KTE+1 - T8W(I,K,J)=0.5*(TL(K-1)+TL(K)) - ENDDO - T8W(I,KTE+2,J)=-1.E20 - ZMID(I,KTE+1,J)=Z_AT_W(I,KTE+1,J) -! - ENDDO - ENDDO -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -!*** COMPUTE VELOCITY COMPONENTS AT MASS POINTS -! -!----------------------------------------------------------------------- -!$omp parallel do & -!$omp& private(i,j,k,rwmsk,wmsk) - DO J=MYJS1_P1,MYJE1_P1 -! - DO K=KTS,KTE - DO I=MYIS_P1,MYIE_P1 - WMSK=grid%VTM(I+grid%IHE(J),J,K)+grid%VTM(I+grid%IHW(J),J,K) & - & +grid%VTM(I,J+1,K)+grid%VTM(I,J-1,K) - IF(WMSK>0.)THEN - RWMSK=1./WMSK - U_PHY(I,K,J)=(grid%U(I+grid%IHE(J),J,K)*grid%VTM(I+grid%IHE(J),J,K) & - & +grid%U(I+grid%IHW(J),J,K)*grid%VTM(I+grid%IHW(J),J,K) & - & +grid%U(I,J+1,K)*grid%VTM(I,J+1,K) & - & +grid%U(I,J-1,K)*grid%VTM(I,J-1,K))*RWMSK - V_PHY(I,K,J)=(grid%V(I+grid%IHE(J),J,K)*grid%VTM(I+grid%IHE(J),J,K) & - & +grid%V(I+grid%IHW(J),J,K)*grid%VTM(I+grid%IHW(J),J,K) & - & +grid%V(I,J+1,K)*grid%VTM(I,J+1,K) & - & +grid%V(I,J-1,K)*grid%VTM(I,J-1,K))*RWMSK - ELSE - U_PHY(I,K,J)=0. - V_PHY(I,K,J)=0. - ENDIF - ENDDO - ENDDO - ENDDO -#endif - do nv=1,num_chem do j=jps,jpe do k=kps,kpe @@ -761,7 +555,7 @@ end SUBROUTINE sum_pm_driver enddo select case (config_flags%chem_opt) case (RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & - RACM_ESRLSORG_KPP,RACMSORG_AQ,RACMSORG_KPP, RACMSORG_AQCHEM, RACM_SOA_VBS_KPP) + RACM_ESRLSORG_KPP,RACMSORG_AQ,RACMSORG_KPP, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RACM_SOA_VBS_KPP) do j=jps,jpe do k=kps,kpe do i=ips,ipe @@ -785,7 +579,6 @@ end SUBROUTINE sum_pm_driver end select vdrog3=0. -#if ( EM_CORE == 1 ) do j=jps,min(jde-1,jpe) do k=kps,kpe do i=ips,min(ide-1,ipe) @@ -833,25 +626,9 @@ end SUBROUTINE sum_pm_driver kts=k_start kte=min(k_end,kde-1) -#endif -! -! no time average available in first half hour -! -! if( config_flags%chem_conv_tr>0)then -! call convtrans_prep(grid%gd_cloud,grid%gd_cloud2,grid%gd_cloud_a,& -! grid%gd_cloud_b,grid%raincv,grid%raincv_a,grid%raincv_b, & -! grid%gd_cloud2_a,grid%gd_cloud2_b,convtrans_avglen_m,stepave,& -! adapt_step_flag,curr_secs,grid%stepave_count, & -! ktau,grid%dt, & -! config_flags%cu_rad_feedback, config_flags%cu_physics, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte,kts,kte ) -! endif ! chem_conv_tr ! ! -#if ( EM_CORE == 1 ) CALL wrf_debug ( 15 , ' call chem_prep' ) CALL chem_prep ( config_flags, & grid%u_2, grid%v_2, grid%p, grid%pb, & @@ -864,7 +641,6 @@ end SUBROUTINE sum_pm_driver ims, ime, jms, jme, kms, kme, & its,ite,jts,jte, & k_start, k_end ) -#endif #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) if( (its <= CHEM_DBG_I .and. ite >= CHEM_DBG_I) .and. & @@ -880,22 +656,6 @@ end SUBROUTINE sum_pm_driver end if #endif -!-- set upper boundary condition -! if( config_flags%have_bcs_upper )then -! call wrf_debug(15,'set upper boundary condition') -! call tropopause_driver( grid%id, grid%dt, current_date_char, & -! t_phy, p_phy, p8w, zmid, z_at_w, & -! grid%tropo_lev, grid%tropo_p, grid%tropo_z, & -! ids, ide, jds, jde, kds, kde, & -! ims, ime, jms, jme, kms, kme, & -! its, ite, jts, jte, kts, kte ) -! call upper_bc_driver ( grid%id, grid%dt, current_date_char, & -! chem, p_phy, p8w, grid%tropo_lev, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte ) -! endif - !--- emissions @@ -907,12 +667,7 @@ end SUBROUTINE sum_pm_driver grid%plumerisefire_frq,grid%stepfirepl, & grid%bioemdt,grid%stepbioe, & config_flags, & -#if (NMM_CORE == 1) - grid%gmt,ijulian,rri,t_phy,moist_trans,p8w,t8w,u_phy,v_phy,vvel, & -#endif -#if (EM_CORE == 1 ) grid%gmt,ijulian,rri,t_phy,moist,p8w,t8w,u_phy,v_phy,vvel, & -#endif grid%e_bio,p_phy,chem,rho,dz8w,grid%ne_area,emis_ant,emis_vol,grid%tsk, & grid%erod,g,emis_seas,emis_dust,tracer, & ebu , ebu_in,grid%mean_fct_agtf,grid%mean_fct_agef,grid%mean_fct_agsv, & @@ -943,12 +698,11 @@ end SUBROUTINE sum_pm_driver grid%ebio_cco_oh, grid%ebio_rco_oh, & grid%clayfrac,grid%sandfrac,grid%dust_alpha,grid%dust_gamma,grid%dust_smtune,& grid%snowh,grid%zs, & -#if (NMM_CORE == 1) - grid%T2,grid%RSWIN, & -#endif -#if (EM_CORE == 1 ) + grid%soilctop, grid%ust_t, grid%rough_cor, grid%smois_cor, & + grid%ebio_c5h8,grid%ebio_apinene,grid%ebio_bpinene,grid%ebio_toluene, & + grid%ebio_ch3cho,grid%ebio_ch3co2h,grid%ebio_tbut2ene, & + grid%ebio_c2h5cho,grid%ebio_nc4h10, & grid%T2,grid%swdown, & -#endif grid%nmegan,grid%EFmegan, & grid%msebio_isop, & grid%mlai, & @@ -1048,15 +802,10 @@ end SUBROUTINE sum_pm_driver call wrf_debug(15,'calling photolysis driver') call photolysis_driver (grid%id,curr_secs,ktau,grid%dt, & config_flags,haveaer, & -#if (NMM_CORE == 1) - grid%gmt,ijulian,t_phy,moist_trans,grid%aerwrf,p8w,t8w,p_phy, & -#endif -#if (EM_CORE == 1) grid%gmt,ijulian,t_phy,moist,grid%aerwrf,p8w,t8w,p_phy, & -#endif chem,rho,dz8w,grid%xlat,grid%xlong, & z_at_w, & - grid%gd_cloud_b,grid%gd_cloud2_b, & + grid%qc_cu,grid%qi_cu, & grid%ph_macr,grid%ph_o31d,grid%ph_o33p,grid%ph_no2,grid%ph_no3o2, & grid%ph_no3o,grid%ph_hno2,grid%ph_hno3,grid%ph_hno4,grid%ph_h2o2, & grid%ph_ch2or,grid%ph_ch2om,grid%ph_ch3cho,grid%ph_ch3coch3, & @@ -1109,22 +858,27 @@ end SUBROUTINE sum_pm_driver ! do vertical mixing with dry deposition ! ! save old concentrations for vertical mixing tendencies -#if (EM_CORE == 1) DO nv=PARAM_FIRST_SCALAR,num_chem_ct chem_old(its:ite,kts:kte,jts:jte,nv) = chem(its:ite,kts:kte,jts:jte,chem_ct_indices(nv)) ENDDO -#endif + +! UoC dust scheme option + scheme_select: SELECT CASE(config_flags%dust_schme) + CASE (SHAO_2001) + imod = 1 + CASE (SHAO_2004) + imod = 2 + CASE (SHAO_2011) + imod = 3 + CASE DEFAULT + imod = 2 + END SELECT scheme_select if (config_flags%vertmix_onoff>0) then if (ktau.gt.2) then call wrf_debug(15,'calling dry_deposition_driver') call dry_dep_driver(grid%id,curr_secs,ktau,grid%dt,config_flags, & -#if (NMM_CORE == 1) - grid%gmt,ijulian,t_phy,moist_trans,scalar_trans,p8w,t8w,vvel, & -#endif -#if (EM_CORE == 1) grid%gmt,ijulian,t_phy,moist,scalar,p8w,t8w,vvel, & -#endif rri,p_phy,chem,tracer,rho,dz8w,rh,grid%exch_h,grid%hfx,grid%dx, & grid%cldfra, grid%cldfra_old,grid%raincv_b,seasin,dustin, & grid%ccn1, grid%ccn2, grid%ccn3, grid%ccn4, grid%ccn5, grid%ccn6, & @@ -1136,7 +890,15 @@ end SUBROUTINE sum_pm_driver grid%cvapi1,grid%cvapi2,grid%cvlim1,grid%cvlim2,grid%dep_vel_o3, & emis_ant,ebu_in, & config_flags%sf_urban_physics,numgas,current_month,dvel,grid%snowh, & - grid%is_CAMMGMP_used, & !BSINGH:01/31/2013: Added is_CAMMGMP_used for MAM drydep + grid%dustdrydep_1,grid%dustdrydep_2,grid%dustdrydep_3, & + grid%dustdrydep_4,grid%dustdrydep_5, & + grid%depvelocity, & + grid%dustgraset_1,grid%dustgraset_2,grid%dustgraset_3, & + grid%dustgraset_4,grid%dustgraset_5, & + grid%setvel_1,grid%setvel_2,grid%setvel_3,grid%setvel_4, & + grid%setvel_5, imod, & + grid%is_CAMMGMP_used, & + grid%dep_vel,grid%num_vert_mix, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite,jts,jte,kts,kte) @@ -1152,13 +914,11 @@ end SUBROUTINE sum_pm_driver end if ! accumulate vertical mixing tendencies -#if (EM_CORE == 1) DO nv=PARAM_FIRST_SCALAR,num_chem_ct grid%vmix_ct(its:ite,kts:kte,jts:jte,nv) = grid%vmix_ct(its:ite,kts:kte,jts:jte,nv) + & (chem(its:ite,kts:kte,jts:jte,chem_ct_indices(nv)) - & chem_old(its:ite,kts:kte,jts:jte,nv)) ENDDO -#endif #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) if( (its <= CHEM_DBG_I .and. ite >= CHEM_DBG_I) .and. & @@ -1193,19 +953,12 @@ end SUBROUTINE sum_pm_driver call wrf_debug(15,'calling conv transport for chemical species') if(config_flags%chem_opt >0 )then ! save old concentrations for convective tendencies -#if (EM_CORE == 1) DO nv=PARAM_FIRST_SCALAR,num_chem_ct chem_old(its:ite,kts:kte,jts:jte,nv) = chem(its:ite,kts:kte,jts:jte,chem_ct_indices(nv)) ENDDO -#endif call grelldrvct(grid%DT,ktau,grid%DX, & rho,grid%RAINCV_B,chem, & -#if (NMM_CORE == 1) - U_phy,V_phy,t_phy,moist_trans,dz8w, & -#endif -#if (EM_CORE == 1) U_phy,V_phy,t_phy,moist,dz8w, & -#endif p_phy,XLV,CP,G,r_v, & z_at_w,grid%cu_co_ten, & grid%wd_no3_cu,grid%wd_so4_cu, & @@ -1223,24 +976,17 @@ end SUBROUTINE sum_pm_driver its, ite, jts, jte, kts ) end if ! accumulate convective tendencies -#if (EM_CORE == 1) DO nv=PARAM_FIRST_SCALAR,num_chem_ct grid%conv_ct(its:ite,kts:kte,jts:jte,nv) = grid%conv_ct(its:ite,kts:kte,jts:jte,nv) + & (chem(its:ite,kts:kte,jts:jte,chem_ct_indices(nv)) - & chem_old(its:ite,kts:kte,jts:jte,nv)) ENDDO -#endif endif if (config_flags%tracer_opt > 0)then call wrf_debug(15,'calling conv transport for tracers') call grelldrvct(grid%DT,ktau,grid%DX, & rho,grid%RAINCV_B,tracer, & -#if (NMM_CORE == 1) - U_phy,V_phy,t_phy,moist_trans,dz8w, & -#endif -#if (EM_CORE == 1) U_phy,V_phy,t_phy,moist,dz8w, & -#endif p_phy,XLV,CP,G,r_v, & z_at_w, grid%cu_co_ten, & grid%wd_no3_cu,grid%wd_so4_cu, & @@ -1283,23 +1029,16 @@ end SUBROUTINE sum_pm_driver ! ! save old concentrations for chemistry tendencies -#if (EM_CORE == 1) DO nv=PARAM_FIRST_SCALAR,num_chem_ct chem_old(its:ite,kts:kte,jts:jte,nv) = chem(its:ite,kts:kte,jts:jte,chem_ct_indices(nv)) ENDDO -#endif if ( cam_mam_aerosols ) & del_h2so4_gasprod(:,:,:) = chem(:,:,:,p_sulf) if(config_flags%gaschem_onoff>0)then call mechanism_driver(grid%id,curr_secs,ktau,grid%dt,grid%ktauc,dtstepc,config_flags, & -#if (NMM_CORE == 1) - grid%gmt,ijulian,t_phy,moist_trans,p8w,t8w, & -#endif -#if (EM_CORE == 1) grid%gmt,ijulian,t_phy,moist,p8w,t8w,grid%gd_cldfr, & -#endif p_phy,chem,rho,dz8w,grid%dx,g, & zmid,z_at_w,grid%xlat,grid%xlong, & vdrog3,vcsulf_old,vcso2_old,vch2o2_old,grid%ttday,grid%tcosz, & @@ -1338,12 +1077,7 @@ end SUBROUTINE sum_pm_driver CALL kpp_mechanism_driver (chem, & grid%id,dtstepc,config_flags, & p_phy,t_phy,rho, & -#if (NMM_CORE == 1) - moist_trans, & -#endif -#if (EM_CORE == 1) moist, & -#endif vdrog3, ldrog, vdrog3_vbs, ldrog_vbs, & ! #include @@ -1369,7 +1103,7 @@ end SUBROUTINE sum_pm_driver CASE (RADM2SORG,RADM2SORG_KPP,RACMSORG_KPP,RACM_SOA_VBS_KPP) CALL wrf_debug(15,'gocart so2-so4 conversion') CALL so2so4(0,chem,p_so2,p_sulf,p_h2o2,p_QC,T_PHY,MOIST, & - grid%gd_cloud_b, grid%gd_cldfr, & + grid%qc_cu, grid%gd_cldfr, & NUM_CHEM,NUM_MOIST, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -1382,7 +1116,7 @@ end SUBROUTINE sum_pm_driver CASE (RADM2SORG,RADM2SORG_KPP,RACMSORG_KPP,RACM_SOA_VBS_KPP) CALL wrf_debug(15,'gocart so2-so4 conversion') CALL so2so4(1,chem,p_so2,p_sulf,p_h2o2,p_QC,T_PHY,MOIST, & - grid%gd_cloud_b, grid%gd_cldfr, & + grid%qc_cu, grid%gd_cldfr, & NUM_CHEM,NUM_MOIST, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -1418,13 +1152,11 @@ end SUBROUTINE sum_pm_driver endif !gaschem_onoff ! accumulate gas phase chemistry tendencies -#if (EM_CORE == 1) DO nv=PARAM_FIRST_SCALAR,num_chem_ct grid%chem_ct(its:ite,kts:kte,jts:jte,nv) = grid%chem_ct(its:ite,kts:kte,jts:jte,nv) + & (chem(its:ite,kts:kte,jts:jte,chem_ct_indices(nv)) - & chem_old(its:ite,kts:kte,jts:jte,nv)) ENDDO -#endif if ( cam_mam_aerosols ) & del_h2so4_gasprod(:,:,:) = chem(:,:,:,p_sulf) - del_h2so4_gasprod(:,:,:) @@ -1451,7 +1183,6 @@ end SUBROUTINE sum_pm_driver (config_flags%chem_opt == CBMZ_CAM_MAM7_NOAQ) .or. & (config_flags%chem_opt == CBMZ_CAM_MAM7_AQ )).and. & (config_flags%cu_physics == CAMZMSCHEME)) then - !BSINGH - Wetdep for gases (MAM only) call cam_mam_gas_wetdep_driver( & !Intent in-outs @@ -1476,15 +1207,10 @@ end SUBROUTINE sum_pm_driver call cloudchem_driver( & grid%id, ktau, grid%ktauc, grid%dt, dtstepc, config_flags, & t_phy, p_phy, rho, rri, dz8w, & - p8w,grid%prain3d,scalar,grid%dvmrdt_sv13d,grid%dvmrcwdt_sv13d, grid%f_ice_phy, & !Balwinder.Singh@pnnl.gov: Variables required for CAM-MAM cloud chemistry - grid%f_rain_phy,grid%cldfrai, grid%cldfral, & -#if (NMM_CORE == 1) - moist_trans, grid%cldfra, grid%ph_no2, & -#endif -#if (EM_CORE == 1) + p8w,grid%prain3d,scalar,grid%dvmrdt_sv13d,grid%dvmrcwdt_sv13d, & + grid%f_ice_phy,grid%f_rain_phy,grid%cldfrai, grid%cldfral, & moist, grid%cldfra, grid%cldfra_mp_all, grid%ph_no2, & -#endif - chem, gas_aqfrac, numgas_mam,grid%is_CAMMGMP_used, &!BSINGH:01/31/2013: Added is_CAMMGMP_used for CAM_MAM_cloudchem + chem, gas_aqfrac, numgas_mam,grid%is_CAMMGMP_used, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -1499,20 +1225,15 @@ end SUBROUTINE sum_pm_driver call aerosols_driver (grid%id,curr_secs,ktau,grid%dt,grid%ktauc, & config_flags,dtstepc,grid%dx, & -#if (NMM_CORE==1) - rri,t_phy,moist_trans,grid%aerwrf,p8w,t8w, & -#endif -#if (EM_CORE == 1) rri,t_phy,moist,grid%aerwrf,p8w,t8w, & -#endif p_phy,chem,rho,dz8w, rh, & - zmid,z_at_w,pbl_h,grid%cldfra,grid%cldfra_mp_all,grid%vbs_nbin, & + zmid,z_at_w,pbl_h,grid%cldfra,grid%cldfra_mp_all,grid%vbs_nbin, & grid%h2oaj,grid%h2oai,grid%nu3,grid%ac3,grid%cor3,grid%asulf, & grid%ahno3,grid%anh3,grid%cvaro1,grid%cvaro2,grid%cvalk1,grid%cvole1, & grid%cvapi1,grid%cvapi2,grid%cvlim1,grid%cvlim2,vcsulf_old, & vdrog3,vdrog3_vbs,grid%br_rto,grid%dgnum4d,grid%dgnumwet4d,wetdens_ap, & del_h2so4_gasprod,grid%dvmrdt_sv13d,grid%dvmrcwdt_sv13d, & - grid%is_CAMMGMP_used, &!BSINGH:01/31/2013: Added is_CAMMGMP_used for cam_mam_aerchem_driver + grid%is_CAMMGMP_used, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite,jts,jte,kts,kte ) @@ -1542,17 +1263,12 @@ end SUBROUTINE sum_pm_driver if (config_flags%wetscav_onoff > 0) then call wetscav_driver (grid%id,ktau,grid%dt,grid%ktauc,config_flags,dtstepc, & -#if (NMM_CORE == 1) - rri,t_phy,moist_trans,p8w,t8w, & -#endif -#if (EM_CORE == 1) rri,t_phy,moist,p8w,t8w, & -#endif grid%dx, grid%dy, & p_phy,chem,rho,grid%cldfra,grid%cldfra2, & grid%rainprod,grid%evapprod,grid%hno3_col_mdel, & grid%qlsink,grid%precr,grid%preci,grid%precs,grid%precg, & - gas_aqfrac, numgas_mam,dz8w, & + gas_aqfrac, numgas_mam,dz8w, & grid%h2oaj,grid%h2oai,grid%nu3,grid%ac3,grid%cor3, & grid%asulf,grid%ahno3,grid%anh3,grid%cvaro1,grid%cvaro2, & grid%cvalk1,grid%cvole1,grid%cvapi1,grid%cvapi2, & @@ -1598,8 +1314,8 @@ end SUBROUTINE sum_pm_driver ! if(config_flags%chem_opt == CHEM_VOLC)then CALL wrf_debug(15,'gocart so2-so4 conversion') - CALL so2so4(0,chem,p_so2,p_sulf,p_h2o2,p_QC,T_PHY,MOIST, & - grid%gd_cloud_b, grid%gd_cldfr, & + CALL so2so4(0,chem,p_so2,p_sulf,p_h2o2,p_QC,T_PHY,MOIST, & + grid%qc_cu, grid%gd_cldfr, & NUM_CHEM,NUM_MOIST, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -1611,10 +1327,10 @@ end SUBROUTINE sum_pm_driver if(config_flags%wetscav_onoff<0)then call wrf_debug(15,'calculate LS wet deposition') call wetdep_ls(grid%dt,chem,grid%rainncv,moist,rho,num_moist, & - num_chem,numgas,dz8w,vvel,grid%chem_opt, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + num_chem,numgas,dz8w,vvel,grid%chem_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) endif ! ! Sum up the aerosol mass for radiation and diagnostic purposes. Unlike @@ -1630,16 +1346,23 @@ end SUBROUTINE sum_pm_driver grid%bbsoa_a01,grid%bbsoa_a02,grid%bbsoa_a03,grid%bbsoa_a04, & grid%hsoa_a01,grid%hsoa_a02,grid%hsoa_a03,grid%hsoa_a04, & grid%biog_a01,grid%biog_a02,grid%biog_a03,grid%biog_a04, & - grid%asmpsoa_a01,grid%asmpsoa_a02,grid%asmpsoa_a03,grid%asmpsoa_a04, & + grid%asmpsoa_a01,grid%asmpsoa_a02,grid%asmpsoa_a03,grid%asmpsoa_a04, & grid%arosoa_a01,grid%arosoa_a02,grid%arosoa_a03,grid%arosoa_a04, & grid%totoa_a01,grid%totoa_a02,grid%totoa_a03,grid%totoa_a04, & grid%hsoa_c,grid%hsoa_o,grid%bbsoa_c,grid%bbsoa_o, & grid%biog_v1,grid%biog_v2,grid%biog_v3,grid%biog_v4, & grid%ant_v1,grid%ant_v2,grid%ant_v3,grid%ant_v4, & - grid%smpa_v1,grid%smpbb_v1, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + grid%smpa_v1,grid%smpbb_v1, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + call dust_load_driver ( config_flags, & + rri, chem, dz8w, grid%dustload_1, grid%dustload_2, grid%dustload_3, & + grid%dustload_4, grid%dustload_5, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts, kte ) ! Fill top level to prevent spurious interpolation results (no extrapolation) @@ -1653,16 +1376,16 @@ end SUBROUTINE sum_pm_driver call wrf_debug(15,'done tileloop in chem_driver') if( grid%OPT_PARS_OUT == 1) then call wrf_debug(15,'calculate optical output stuff') - call aer_opt_out(TAUAER300=grid%tauaer1, TAUAER400=grid%tauaer2 & - & ,TAUAER600=grid%tauaer3, TAUAER999=grid%tauaer4 & - & ,GAER300=grid%gaer1, GAER400=grid%gaer2, GAER600=grid%gaer3, GAER999=grid%gaer4 & - & ,WAER300=grid%waer1, WAER400=grid%waer2, WAER600=grid%waer3, WAER999=grid%waer4 & - ,ext_coeff=grid%ext_coef,bscat_coeff=grid%bscat_coef,asym_par=grid%asym_par & - ,num_ext_coef=num_ext_coef,num_bscat_coef=num_bscat_coef,num_asym_par=num_asym_par & - & ,dz8w=dz8w & - & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - & ,its=its,ite=ite,jts=jts,jte=jte,kts=kts, kte=kte) + call aer_opt_out(TAUAER300=grid%tauaer1, TAUAER400=grid%tauaer2 & + & ,TAUAER600=grid%tauaer3, TAUAER999=grid%tauaer4 & + & ,GAER300=grid%gaer1, GAER400=grid%gaer2, GAER600=grid%gaer3, GAER999=grid%gaer4 & + & ,WAER300=grid%waer1, WAER400=grid%waer2, WAER600=grid%waer3, WAER999=grid%waer4 & + ,ext_coeff=grid%ext_coef,bscat_coeff=grid%bscat_coef,asym_par=grid%asym_par & + ,num_ext_coef=num_ext_coef,num_bscat_coef=num_bscat_coef,num_asym_par=num_asym_par & + & ,dz8w=dz8w & + & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + & ,its=its,ite=ite,jts=jts,jte=jte,kts=kts, kte=kte ) endif @@ -1693,31 +1416,18 @@ end SUBROUTINE sum_pm_driver endif -# if ( EM_CORE == 1 ) END DO chem_tile_loop_1 -#endif -#if (NMM_CORE==1) - DO l=1,num_3d_m - DO k=kts,kte - DO j=jts,jte - DO i=its,ite - moist(i,j,k,l)=moist_trans(i,k,j,l) - ENDDO - ENDDO - ENDDO - ENDDO - DO l=1,num_3d_s - DO k=kts,kte - DO j=jts,jte - DO i=its,ite - scalar(i,j,k,l)=scalar_trans(i,k,j,l) - ENDDO - ENDDO - ENDDO - ENDDO - deallocate(moist_trans) - deallocate(scalar_trans) -#endif + +!-- Work around for dgnum and dgnumwet not being written to restart files. + + grid%dgnum_a1(its:ite, kts:kte, jts:jte) = grid%dgnum4d(its:ite, kts:kte, jts:jte, 1) + grid%dgnum_a2(its:ite, kts:kte, jts:jte) = grid%dgnum4d(its:ite, kts:kte, jts:jte, 2) + grid%dgnum_a3(its:ite, kts:kte, jts:jte) = grid%dgnum4d(its:ite, kts:kte, jts:jte, 3) + + grid%dgnumwet_a1(its:ite, kts:kte, jts:jte) = grid%dgnumwet4d(its:ite, kts:kte, jts:jte, 1) + grid%dgnumwet_a2(its:ite, kts:kte, jts:jte) = grid%dgnumwet4d(its:ite, kts:kte, jts:jte, 2) + grid%dgnumwet_a3(its:ite, kts:kte, jts:jte) = grid%dgnumwet4d(its:ite, kts:kte, jts:jte, 3) + END subroutine chem_driver diff --git a/wrfv2_fire/chem/chemics_init.F b/wrfv2_fire/chem/chemics_init.F index 42b5fc9b..77058bdc 100755 --- a/wrfv2_fire/chem/chemics_init.F +++ b/wrfv2_fire/chem/chemics_init.F @@ -15,11 +15,13 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16, & + dgnum4d, dgnumwet4d, dgnum_a1, dgnum_a2, dgnum_a3, & + dgnumwet_a1, dgnumwet_a2, dgnumwet_a3, & pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & last_chem_time_year, last_chem_time_month, & last_chem_time_day, last_chem_time_hour, & last_chem_time_minute, last_chem_time_second, & - chem_in_opt, kemit, & + chem_in_opt, kemit, num_vert_mix, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -60,6 +62,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, real , intent(in) :: bioemdt,photdt,chemdt,dt,gmt INTEGER, INTENT(IN ) :: plumerisefire_frq INTEGER, INTENT(IN ) :: chem_in_opt + INTEGER, INTENT(INOUT) :: num_vert_mix INTEGER, INTENT(IN ) :: id,julday,kemit, & last_chem_time_year, & last_chem_time_month, & @@ -84,6 +87,15 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16, & gaer1,gaer2,gaer3,gaer4, & waer1,waer2,waer3,waer4 +!-- Arrays needed to output dgnum when restarting + REAL, DIMENSION( ims:ime , kms:kme , jms:jme, 3 ) , & + INTENT(INOUT ) :: & + dgnum4d, dgnumwet4d + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT ) :: & + dgnum_a1, dgnum_a2, dgnum_a3, & + dgnumwet_a1, dgnumwet_a2, dgnumwet_a3 +!-- end dgnum restart arrays REAL, DIMENSION( ims:ime , kms:kme , jms:jme , 1:4 ) , & INTENT(INOUT ) :: & @@ -136,14 +148,6 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, numgas = get_last_gas(config_flags%chem_opt) -#if ( NMM_CORE == 1 ) -call wrf_message("*********************************************************************") -call wrf_message("* WARNING: THE USE OF THE NMM WITH CHEMISTRY IS *") -call wrf_message("* CONSIDERED BETA CODE THAT IS STILL IN DEVELOPMENT. *") -call wrf_message("* PLEASE REPORT ANY BUGS TO wrfchemhelp.gsd@noaa.gov *") -call wrf_message("*********************************************************************") -#endif - chem_select: SELECT CASE(config_flags%chem_opt) CASE (GOCART_SIMPLE) CALL wrf_debug(15,'calling only gocart aerosols driver from chem_driver') @@ -153,6 +157,10 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, CALL wrf_debug(15,'calling gocart and radm driver from chem_driver') CASE (GOCARTRACM_KPP) CALL wrf_debug(15,'calling gocart and racmkpp driver from chem_driver') + CASE (CRIMECH_KPP, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) + CALL wrf_debug(15,'calling crimech driver from chem_driver') + call wrf_message("WARNING: CRIMECH chemistry option is highly experimental and not recommended for use.") +! call wrf_error_fatal("ERROR: experimental option selected, please contact G.MCFIGGANS for assistance") CASE (CBM4_KPP ) CALL wrf_debug(15,'calling CB4 from chem_driver') call wrf_message("WARNING: CB4 chemistry option is highly experimental and not recommended for use.") @@ -185,13 +193,20 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_message("WARNING: RACMSORG_AQ chemistry option is highly experimental and not recommended for use.") call wrf_error_fatal("ERROR: experimental option selected, please contact wrfchemhelp for assistance") CASE (RADM2SORG_AQCHEM ) + numgas_mam = numgas CALL wrf_debug(15,'calling RADM2/MADE/SORGAM with AQCHEM chemistry from chem_driver') call wrf_message("WARNING: RADM2SORG_AQCHEM chemistry option is experimental and not yet fully tested.") call wrf_message(" We recommend contacting wrfchemhelp for assistance.") - CASE (RACMSORG_AQCHEM ) + CASE (RACMSORG_AQCHEM_KPP ) + numgas_mam = numgas CALL wrf_debug(15,'calling RACM/MADE/SORGAM with AQCHEM chemistry from chem_driver') - call wrf_message("WARNING: RACMSORG_AQCHEM chemistry option is highly experimental and not recommended for use.") - call wrf_error_fatal("ERROR: experimental option selected, please contact wrfchemhelp for assistance") + call wrf_message("WARNING: RACMSORG_AQCHEM_KPP chemistry option is highly experimental and not recommended for use.") +! call wrf_error_fatal("ERROR: experimental option selected, please contact wrfchemhelp for assistance") + CASE (RACM_ESRLSORG_AQCHEM_KPP ) + numgas_mam = numgas + CALL wrf_debug(15,'calling RACM/MADE/SORGAM with AQCHEM chemistry from chem_driver') + call wrf_message("WARNING: RACM_ESRLSORG_AQCHEM_KPP chemistry option is highly experimental and not recommended for use.") +! call wrf_error_fatal("ERROR: experimental option selected, please contact wrfchemhelp for assistance") CASE (CO2_TRACER, GHG_TRACER ) call wrf_message("WARNING: Users interested in the GHG options should check the comments/references in header of module_ghg_fluxes") CASE (CBMZ_CAM_MAM3_NOAQ) @@ -204,6 +219,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, numgas_mam = numgas CALL wrf_debug(15,'calling CBMZ_CAM_MAM7_NOAQ chemistry from chem_driver') call wrf_message("WARNING: CBMZ_CAM_MAM7_NOAQ chemistry option is highly experimental and not recommended for use.") + call wrf_message("WARNING: In CBMZ_CAM_MAM7_NOAQ chemistry option, DMS is not implemented yet.") call wrf_error_fatal("ERROR: It is recommended that you contact phil.rasch at pnnl.gov for information regarding this option") CASE (CBMZ_CAM_MAM7_AQ) numgas_mam = numgas @@ -245,11 +261,12 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, config_flags%chem_opt /= MOZART_MOSAIC_4BIN_VBS0_KPP ) then if( ( config_flags%chem_opt >= 8 .AND. config_flags%chem_opt <= 13) .OR. & ( config_flags%chem_opt >= 31 .AND. config_flags%chem_opt <= 36) .OR. & - ( config_flags%chem_opt >= 41 .AND. config_flags%chem_opt <= 42) .OR. & - ( config_flags%chem_opt == 503 .OR. config_flags%chem_opt == 504) ) then + ( config_flags%chem_opt >= 41 .AND. config_flags%chem_opt <= 43) .OR. & + ( config_flags%chem_opt == 503 .OR. config_flags%chem_opt == 504) .OR. & + ( config_flags%chem_opt == 601 .OR. config_flags%chem_opt == 611) ) then call wrf_debug( 15, 'Chemics_init: Wet scavenging turned on' ) else - call wrf_error_fatal("ERROR: wet scavenging option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 42 or 503 or 504 to function.") + call wrf_error_fatal("ERROR: wet scavenging option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 42 or 503 or 504 or 601 or 611 to function.") endif if ( config_flags%mp_physics /= 2 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 11) then call wrf_error_fatal("ERROR: wet scavenging option requires mp_phys = 2 (Lin et al.) or 10 (Morrison) or 11 (CAMMGMP) to function.") @@ -269,10 +286,11 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if( ( config_flags%chem_opt >= 8 .AND. config_flags%chem_opt <= 13) .OR. & ( config_flags%chem_opt >= 31 .AND. config_flags%chem_opt <= 36) .OR. & ( config_flags%chem_opt >= 501 .AND. config_flags%chem_opt <= 504) .OR. & - ( config_flags%chem_opt >= 41 .AND. config_flags%chem_opt <= 42) ) then + ( config_flags%chem_opt >= 41 .AND. config_flags%chem_opt <= 43) .OR. & + ( config_flags%chem_opt >= 601 .AND. config_flags%chem_opt <= 611) ) then call wrf_debug( 15, 'Chemics_init: Cloud chemistry turned on' ) else - call wrf_error_fatal("ERROR: cloud chemistry option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 42 to function.") + call wrf_error_fatal("ERROR: cloud chemistry option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 43 to function.") endif if ( config_flags%mp_physics /= 2 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 11 ) then call wrf_error_fatal("ERROR: cloud chemistry option requires mp_phys = 2 (Lin et al.) or 10 (Morrison) or 11 (CAMMGMP)to function.") @@ -301,6 +319,38 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_error_fatal(" ERROR: CHEM_INIT: FOR CHEM_OPT = 0, AER_RA_FEEDBACK MUST = 0 ") ENDIF + IF ( config_flags%aer_ra_feedback .EQ. 1 .AND. & + ( config_flags%chem_opt == RADM2 .or. & + config_flags%chem_opt == CBMZ .or. & + config_flags%chem_opt == CBMZ_BB .or. & + config_flags%chem_opt == CO2_TRACER .or. & + config_flags%chem_opt == RADM2_KPP .or. & + config_flags%chem_opt == RACM_MIM_KPP .or. & + config_flags%chem_opt == RACM_KPP .or. & + config_flags%chem_opt == CBM4_KPP .or. & + config_flags%chem_opt == SAPRC99_KPP .or. & + config_flags%chem_opt == NMHC9_KPP ) ) then + call wrf_error_fatal(" ERROR: CHEM_INIT: MUST HAVE AEROSOLS TO INCLUDE AEROSOL RADIATION FEEDBACK. SET AER_RA_FEEDBACK = 0 ") + ENDIF + + if ( config_flags%n2o5_hetchem == 1 )then + if( (config_flags%chem_opt >= 7 .AND. config_flags%chem_opt <= 10) .OR. & + (config_flags%chem_opt >= 31 .AND. config_flags%chem_opt <= 34) .OR. & + config_flags%chem_opt == 170 .OR. config_flags%chem_opt == 198 .OR. & + config_flags%chem_opt == 199 .OR. config_flags%chem_opt == 201 .OR. & + config_flags%chem_opt == 601 .OR. config_flags%chem_opt == 611 ) then + call wrf_debug( 15, 'using N2O5 heterogeneous chemistry without Cl- pathway') + else + call wrf_error_fatal("ERROR: N2O5 heterogenous chemistry (without Cl- pathway) must be run with MOSAIC aerosol") + endif + elseif ( config_flags%n2o5_hetchem == 2 ) then + if( config_flags%chem_opt == 601 .OR. config_flags%chem_opt == 611 ) then + call wrf_debug( 15, 'using full N2O5 heterogeneous chemistry') + else + call wrf_error_fatal("ERROR: full N2O5 heterogenous chemistry must be run with MOSAIC aerosol coupled with gas-phase scheme which deals with ClNO2") + endif + endif + ! IF ( config_flags%chem_opt == 2 .AND. config_flags%dust_opt .NE. 2 ) THEN ! call wrf_error_fatal(" ERROR: USE dust_opt = 2 when using MADE/SORGAM aerosol option ") ! ENDIF @@ -312,15 +362,33 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, message_txt = " ERROR: CHEM_INIT: Chemistry routines require USGS or MODIS_NOAH land use maps. Need to change land use option." call wrf_error_fatal( trim(message_txt) ) ELSE - IF (trim(mminlu_loc) == 'USGS' .and. grid%num_land_cat /= 24 ) THEN - message_txt = " ERROR: CHEM_INIT: USGS land use map should have 24 catagories." + IF (trim(mminlu_loc) == 'USGS' .and. grid%num_land_cat <= 23 ) THEN + message_txt = " ERROR: CHEM_INIT: USGS land use map should have 24 or more catagories." call wrf_error_fatal( trim(message_txt) ) - ELSEIF (trim(mminlu_loc) == 'MODIFIED_IGBP_MODIS_NOAH' .and. grid%num_land_cat /= 20 ) THEN - message_txt = " ERROR: CHEM_INIT: MODIS_NOAH land use map should have 20 catagories." + ELSEIF (trim(mminlu_loc) == 'MODIFIED_IGBP_MODIS_NOAH' .and. grid%num_land_cat <= 19 ) THEN + message_txt = " ERROR: CHEM_INIT: MODIS_NOAH land use map should have 20 or more catagories." call wrf_error_fatal( trim(message_txt) ) ENDIF ENDIF !-- + +!-- Load dgnum arrays when restart is active +IF ( config_flags%restart ) THEN + do j=jts,jte + do k=kts,kte + do i=its,ite + dgnum4d(i, k, j, 1) = dgnum_a1(i, k, j) + dgnum4d(i, k, j, 2) = dgnum_a2(i, k, j) + dgnum4d(i, k, j, 3) = dgnum_a3(i, k, j) + + dgnumwet4d(i, k, j, 1) = dgnumwet_a1(i, k, j) + dgnumwet4d(i, k, j, 2) = dgnumwet_a2(i, k, j) + dgnumwet4d(i, k, j, 3) = dgnumwet_a3(i, k, j) + end do + end do + end do +ENDIF +!-- end load dgnum arrays if( .NOT. config_flags%restart ) then do j=jts,jte @@ -426,6 +494,24 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ! RETURN IF CHEMISTRY IS NOT RUNNING IF ( config_flags%chem_opt == 0 ) RETURN +! Set the num_vert_mix variable if using ACM + num_vert_mix = 0 + IF ( config_flags%bl_pbl_physics == ACMPBLSCHEME ) THEN + mix_select: SELECT CASE(config_flags%chem_opt) + CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZSORG_AQ, & + CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) + num_vert_mix = numgas + CASE DEFAULT + num_vert_mix = num_chem + END SELECT mix_select + if(num_vert_mix .gt. config_flags%ndepvel) then + write(message_txt,'(A30,2(I8,2x))') 'chem_init: num_vert_mix and ndepvel ',num_vert_mix,config_flags%ndepvel + call wrf_message( trim(message_txt) ) + call wrf_error_fatal(" ERROR: CHEM_INIT: num_vert_mix > ndepvel ") + endif + ENDIF + stepbioe=nint(bioemdt*60./dt) stepphot=nint(photdt*60./dt) stepchem=nint(chemdt*60./dt) @@ -491,12 +577,13 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if( .NOT. config_flags%restart ) then kpp_select: SELECT CASE(config_flags%chem_opt) - CASE (GOCARTRACM_KPP,RACM_KPP,RACMPM_KPP,RACMSORG_KPP, RACM_MIM_KPP,RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP) + CASE (GOCARTRACM_KPP,RACM_KPP,RACMPM_KPP,RACMSORG_KPP,RACM_MIM_KPP,RACM_ESRLSORG_KPP, & + RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACM_SOA_VBS_KPP) if(config_flags%chem_in_opt == 0 )then do j=jts,jte do k=kts,kte do i=its,ite - chem(i,k,j,p_co2)=370. + chem(i,k,j,p_co2)=380. chem(i,k,j,p_ch4)=1.7 chem(i,k,j,p_ete)=chem(i,k,j,p_olt) chem(i,k,j,p_ete)=epsilc @@ -515,7 +602,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, do j=jts,jte do k=kts,kte do i=its,ite - chem(i,k,j,p_co2)=370. + chem(i,k,j,p_co2)=380. chem(i,k,j,p_ch4)=1.7 enddo enddo @@ -555,12 +642,17 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif CASE (MOZART_MOSAIC_4BIN_VBS0_KPP) +! 20130708 acd_alma_bugfix start + grid%vbs_nbin=0 +! 20130708 acd_alma_bugfix end if(config_flags%chem_in_opt == 0 )then - grid%vbs_nbin=0 +! 20130708 acd_alma_bugfix start +! grid%vbs_nbin=0 +! 20130708 acd_alma_bugfix end do j=jts,jte do k=kts,kte do i=its,ite - ! chem(i,k,j,p_co2)=370. + ! chem(i,k,j,p_co2)=380. ! chem(i,k,j,p_ch4)=1.7 if (p_ant1_c.gt.1) chem(i,k,j,p_ant1_c)=0.0 if (p_ant2_c.gt.1) chem(i,k,j,p_ant2_c)=0.0 @@ -598,7 +690,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, do j=jts,jte do k=kts,kte do i=its,ite - chem(i,k,j,p_co2)=370. + chem(i,k,j,p_co2)=380. chem(i,k,j,p_ch4)=1.7 if (p_pcg1_b_c.gt.1) chem(i,k,j,p_pcg1_b_c)=0.00 if (p_pcg2_b_c.gt.1) chem(i,k,j,p_pcg2_b_c)=0.00 @@ -799,7 +891,6 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, CASE (DUST) if(config_flags%phot_opt .NE. 0 )then call wrf_error_fatal("Dust only simple initialization, phot_opt MUST BE ZERO") -! config_flags%phot_opt = 0 endif CALL wrf_debug(15,'call dust aerosols initialization') ch_dust(:,:)=0.8D-9 @@ -819,7 +910,6 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, CASE (GOCART_SIMPLE) if(config_flags%phot_opt .NE. 0 )then call wrf_error_fatal("GOCART simple initialization, phot_opt MUST BE ZERO") -! config_flags%phot_opt = 0 endif CALL wrf_debug(15,'call GOCART chem/aerosols initialization') ch_dust(:,:)=0.8D-9 @@ -877,7 +967,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, CALL wrf_debug(15,'MOZCART dust initialization') ch_dust(:,:) = 0.8D-9 - CASE (RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM, RADM2SORG_KPP, & + CASE (RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RADM2SORG_KPP, & RACMSORG_KPP, RACM_ESRLSORG_KPP, CBMZSORG, CBMZSORG_AQ) CALL wrf_debug(15,'call MADE/SORGAM aerosols initialization') @@ -946,7 +1036,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) endif - if(config_flags%wetscav_onoff == 1 .and. .NOT. config_flags%restart ) then + if(config_flags%wetscav_onoff == 1 ) then if(config_flags%mp_physics == CAMMGMPSCHEME ) then call wetscav_cam_mam_driver_init(ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -957,9 +1047,9 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP ) + CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP,CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) call wrf_debug(15,'call MOSAIC aerosols initialization') - call init_data_mosaic_asect(is_aerosol) + call init_data_mosaic_asect(config_flags%n2o5_hetchem,is_aerosol) if(config_flags%chem_in_opt == 0 )then if( .NOT. config_flags%restart ) & call mosaic_init_wrf_mixrats( & @@ -973,9 +1063,9 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, END SELECT aer_select progn_sanity_check : SELECT CASE(config_flags%chem_opt) - CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM, & + CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_DMS_4BIN_AQ, & - CBMZ_MOSAIC_DMS_8BIN_AQ, CBMZSORG_AQ) + CBMZ_MOSAIC_DMS_8BIN_AQ,CBMZSORG_AQ,CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) if( config_flags%progn /= 1 ) & call wrf_error_fatal( & "ERROR: When using a ..._AQ chemistry package, progn must be 1") @@ -1231,7 +1321,8 @@ subroutine print_chem_species_index( chem_opt ) print*,p_iso,"iso" print*,p_ho,"ho" print*,p_ho2,"ho2" - case (RACMSORG_AQ, RACMSORG_AQCHEM, RACM_KPP, RACMPM_KPP, RACMSORG_KPP,RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP) + case (RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RACM_KPP, RACMPM_KPP, RACMSORG_KPP, & + RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP) print*,p_so2,"so2" print*,p_sulf,"sulf" print*,p_no2,"no2" @@ -1590,8 +1681,8 @@ subroutine print_chem_species_index( chem_opt ) ! Aerosol species... ! select case (chem_opt) - case (RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM, RACMSORG_KPP, RACM_ESRLSORG_KPP, & - CBMZSORG, CBMZSORG_AQ,RACMSORG) + case (RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & + RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP, RACM_ESRLSORG_KPP, CBMZSORG, CBMZSORG_AQ,RACMSORG) print*,p_so4aj,"so4aj" print*,p_so4ai,"so4ai" print*,p_nh4aj,"nh4aj" diff --git a/wrfv2_fire/chem/cloudchem_driver.F b/wrfv2_fire/chem/cloudchem_driver.F index 2f69d8b9..80342d2c 100644 --- a/wrfv2_fire/chem/cloudchem_driver.F +++ b/wrfv2_fire/chem/cloudchem_driver.F @@ -188,7 +188,7 @@ SUBROUTINE cloudchem_driver( & CASE ( CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, & - CBMZ_MOSAIC_DMS_8BIN_AQ ) + CBMZ_MOSAIC_DMS_8BIN_AQ, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) call wrf_debug(15, & 'cloudchem_driver calling mosaic_cloudchem_driver') @@ -231,7 +231,7 @@ SUBROUTINE cloudchem_driver( & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE ( RADM2SORG_AQCHEM, RACMSORG_AQCHEM ) + CASE ( RADM2SORG_AQCHEM, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP ) call wrf_debug(15, & 'cloudchem_driver calling sorgam_aqchem_driver') diff --git a/wrfv2_fire/chem/convert_emiss.F b/wrfv2_fire/chem/convert_emiss.F index 6280d9a9..189e5632 100644 --- a/wrfv2_fire/chem/convert_emiss.F +++ b/wrfv2_fire/chem/convert_emiss.F @@ -133,6 +133,7 @@ END SUBROUTINE Setup_Timekeeping INTEGER :: iswaterr,itest,beg_day,beg_hour INTEGER :: itime = 0 INTEGER :: inew_nei = 0 + INTEGER :: inew_ch4 = 0 ! set to 1 if using 2011 NEI emissions INTEGER :: nv = 0 INTEGER :: nv_f = 0 INTEGER :: nv_g = 0 @@ -1877,6 +1878,17 @@ END SUBROUTINE Setup_Timekeeping read(91)dumc0(ids:ide-1,kds:grid%kemit,jds:jde-1) #endif grid%emis_ant(ips:ipe ,kps:grid%kemit,jps:jpe ,p_e_iso)=dumc0(ips:ipe ,kps:grid%kemit,jps:jpe ) + IF( inew_ch4 == 1 ) THEN +#ifdef DM_PARALLEL + IF (wrf_dm_on_monitor()) THEN + read(91)dumc0(ids:ide-1,kds:grid%kemit,jds:jde-1) + ENDIF + DM_BCAST_MACRO(dumc0) +#else + read(91)dumc0(ids:ide-1,kds:grid%kemit,jds:jde-1) +#endif +! grid%emis_ant(ips:ipe ,kps:grid%kemit,jps:jpe ,p_e_ch4)=dumc0(ips:ipe ,kps:grid%kemit,jps:jpe ) + ENDIF #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN read(91)dumc0(ids:ide-1,kds:grid%kemit,jds:jde-1) @@ -2375,6 +2387,17 @@ END SUBROUTINE Setup_Timekeeping read(91)dumc0(ids:ide-1,kds:grid%kemit,jds:jde-1) #endif grid%emis_ant(ips:ipe ,kps:grid%kemit,jps:jpe ,p_e_iso)=dumc0(ips:ipe ,kps:grid%kemit,jps:jpe ) + IF( inew_ch4 == 1 ) THEN +#ifdef DM_PARALLEL + IF (wrf_dm_on_monitor()) THEN + read(91)dumc0(ids:ide-1,kds:grid%kemit,jds:jde-1) + ENDIF + DM_BCAST_MACRO(dumc0) +#else + read(91)dumc0(ids:ide-1,kds:grid%kemit,jds:jde-1) +#endif +! grid%emis_ant(ips:ipe ,kps:grid%kemit,jps:jpe ,p_e_ch4)=dumc0(ips:ipe ,kps:grid%kemit,jps:jpe ) + endif #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN read(91)dumc0(ids:ide-1,kds:grid%kemit,jds:jde-1) diff --git a/wrfv2_fire/chem/depend.chem b/wrfv2_fire/chem/depend.chem index e7e331b9..41f9538c 100644 --- a/wrfv2_fire/chem/depend.chem +++ b/wrfv2_fire/chem/depend.chem @@ -14,6 +14,8 @@ module_gocart_dust.o: ../phys/module_data_gocart_dust.o module_gocart_dust_afwa.o: ../phys/module_data_gocart_dust.o +module_uoc_dust.o: module_qf03.o module_soilpsd.o + module_gocart_seasalt.o: module_data_gocart_seas.o module_gocart_chem.o: module_data_gocartchem.o module_phot_mad.o @@ -207,7 +209,7 @@ module_tropopause.o: module_interpolate.o module_upper_bc_driver.o: module_tropopause.o -chem_driver.o: module_radm.o ../dyn_em/module_convtrans_prep.o module_chem_utilities.o module_data_radm2.o module_dep_simple.o module_bioemi_simple.o module_vertmx_wrf.o module_phot_mad.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_data_cbmz.o module_cbmz.o module_wetscav_driver.o dry_dep_driver.o emissions_driver.o module_input_tracer.o module_input_tracer_data.o module_tropopause.o module_upper_bc_driver.o module_ctrans_grell.o module_data_soa_vbs.o module_aer_opt_out.o module_data_sorgam.o module_gocart_so2so4.o ../phys/module_cu_camzm_driver.o module_cam_mam_gas_wetdep_driver.o +chem_driver.o: module_radm.o ../dyn_em/module_convtrans_prep.o module_chem_utilities.o module_data_radm2.o module_dep_simple.o module_bioemi_simple.o module_vertmx_wrf.o module_phot_mad.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_data_cbmz.o module_cbmz.o module_wetscav_driver.o dry_dep_driver.o emissions_driver.o module_input_tracer.o module_input_tracer_data.o module_tropopause.o module_upper_bc_driver.o module_ctrans_grell.o module_data_soa_vbs.o module_aer_opt_out.o module_data_sorgam.o module_gocart_so2so4.o ../phys/module_cu_camzm_driver.o module_cam_mam_gas_wetdep_driver.o module_dust_load.o chemics_init.o: module_cbm4_initmixrats.o module_cbmz_initmixrats.o module_gocart_aerosols.o ../phys/module_data_gocart_dust.o module_data_gocart_seas.o module_data_gocartchem.o module_gocart_chem.o module_dep_simple.o module_ftuv_driver.o module_phot_mad.o module_gocart_chem.o module_aerosols_sorgam.o module_mixactivate_wrappers.o module_mosaic_driver.o module_input_chem_data.o module_tropopause.o module_upper_bc_driver.o module_cam_mam_init.o module_cam_mam_wetscav.o @@ -221,7 +223,7 @@ mechanism_driver.o: module_data_radm2.o module_radm.o module_aerosols_sorgam.o m optical_driver.o: module_optical_averaging.o module_peg_util.o -emissions_driver.o: module_add_emiss_burn.o module_data_radm2.o module_radm.o module_bioemi_simple.o module_bioemi_beis314.o module_bioemi_megan2.o module_emissions_anthropogenics.o module_cbmz_addemiss.o module_mosaic_addemiss.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_plumerise1.o module_gocart_dust.o module_gocart_dust_afwa.o module_gocart_seasalt.o module_ghg_fluxes.o module_lightning_nox_driver.o module_cam_mam_addemiss.o +emissions_driver.o: module_add_emiss_burn.o module_data_radm2.o module_radm.o module_bioemi_simple.o module_bioemi_beis314.o module_bioemi_megan2.o module_emissions_anthropogenics.o module_cbmz_addemiss.o module_mosaic_addemiss.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_plumerise1.o module_gocart_dust.o module_gocart_dust_afwa.o module_uoc_dust.o module_gocart_seasalt.o module_ghg_fluxes.o module_lightning_nox_driver.o module_cam_mam_addemiss.o dry_dep_driver.o: module_data_radm2.o module_aer_drydep.o module_dep_simple.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_mosaic_drydep.o ../phys/module_mixactivate.o module_cam_mam_drydep.o ../phys/module_data_cam_mam_asect.o ../phys/module_data_cam_mam_aero.o ../phys/module_cam_support.o diff --git a/wrfv2_fire/chem/dry_dep_driver.F b/wrfv2_fire/chem/dry_dep_driver.F index a8e3953e..ef2840c3 100755 --- a/wrfv2_fire/chem/dry_dep_driver.F +++ b/wrfv2_fire/chem/dry_dep_driver.F @@ -21,8 +21,15 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & anh3,cvaro1,cvaro2, & cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,dep_vel_o3, & emis_ant,ebu_in, & - sf_urban_physics,numgas,current_month,dvel, & - snowh,is_CAMMGMP_used, & !BSINGH:01/31/2013: Added is_CAMMGMP_used for MAM drydep + sf_urban_physics,numgas,current_month,dvel,snowh, & + dustdrydep_1,dustdrydep_2,dustdrydep_3, & + dustdrydep_4,dustdrydep_5, & + depvelocity, & + dustgraset_1,dustgraset_2,dustgraset_3, & + dustgraset_4,dustgraset_5, & + setvel_1,setvel_2,setvel_3,setvel_4,setvel_5, imod, & + is_CAMMGMP_used, & !BSINGH:01/31/2013: Added is_CAMMGMP_used for MAM drydep + dep_vel,num_vert_mix, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -80,6 +87,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & REAL, DIMENSION( ims:ime, 1, jms:jme, num_ebu_in ), & INTENT(INOUT ) :: ebu_in + REAL, DIMENSION( ims:ime, config_flags%kdepvel, jms:jme, config_flags%ndepvel ), & + INTENT(INOUT ) :: dep_vel + REAL, DIMENSION( ims:ime, config_flags%kdvel, jms:jme, num_dvel ), & INTENT(INOUT ) :: dvel @@ -129,6 +139,17 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & REAL, INTENT(IN ) :: & dtstep,gmt,dx + INTEGER, INTENT(INOUT) :: num_vert_mix + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: & + dustdrydep_1, dustdrydep_2, dustdrydep_3, & + dustdrydep_4, dustdrydep_5, depvelocity + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: & + dustgraset_1,dustgraset_2,dustgraset_3, & + dustgraset_4,dustgraset_5, & + setvel_1,setvel_2,setvel_3,setvel_4,setvel_5 + INTEGER, INTENT(IN) :: imod + !--- deposition and emissions stuff ! .. Parameters .. ! .. @@ -151,8 +172,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & REAL, DIMENSION( kms:kme ) :: dryrho_1d ! turbulent transport - real :: pblst(kts:kte),ekmfull(kts:kte+1),zzfull(kts:kte+1),zz(kts:kte) - integer :: ii,jj,kk,i,j,k,nv + real :: pblst(kts:kte),ekmfull(kts:kte+1),zzfull(kts:kte+1),zz(kts:kte) + integer :: ii,jj,kk,i,j,k,nv + integer :: ll ! ! necessary for aerosols (module dependent) ! @@ -248,6 +270,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & t_phy, moist, p8w, t8w, rmol,aer_res_def, & p_phy, chem, rho_phy, dz8w, ddvel, xland, hfx, & ivgtyp, tsk, vegfra, pbl, ust, znt, xlat, xlong, & + dustdrydep_1,dustdrydep_2,dustdrydep_3, & + dustdrydep_4,dustdrydep_5, & + depvelocity, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -273,6 +298,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & dvel(its:ite,1,j,p_dvel_ch3cooh) = m2cm*ddvel(its:ite,j,p_ch3cooh) dvel(its:ite,1,j,p_dvel_acet) = m2cm*ddvel(its:ite,j,p_acet) dvel(its:ite,1,j,p_dvel_mgly) = m2cm*ddvel(its:ite,j,p_mgly) +! 20120820 acd_ck_bugfix start + dvel(its:ite,1,j,p_dvel_gly) = m2cm*ddvel(its:ite,j,p_gly) +! 20120820 acd_ck_bugfix end dvel(its:ite,1,j,p_dvel_paa) = m2cm*ddvel(its:ite,j,p_paa) dvel(its:ite,1,j,p_dvel_pooh) = m2cm*ddvel(its:ite,j,p_c3h6ooh) dvel(its:ite,1,j,p_dvel_mpan) = m2cm*ddvel(its:ite,j,p_mpan) @@ -316,6 +344,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & t_phy,moist,p8w,t8w,rmol,aer_res_def, & p_phy,chem,rho_phy,dz8w,ddvel,xland,hfx, & ivgtyp,tsk,vegfra,pbl,ust,znt,xlat,xlong, & + dustdrydep_1,dustdrydep_2,dustdrydep_3, & + dustdrydep_4,dustdrydep_5, & + depvelocity, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -328,6 +359,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & t_phy,moist,p8w,t8w,rmol,aer_res_def, & p_phy,chem,rho_phy,dz8w,ddvel,xland,hfx, & ivgtyp,tsk,vegfra,pbl,ust,znt,xlat,xlong, & + dustdrydep_1,dustdrydep_2,dustdrydep_3, & + dustdrydep_4,dustdrydep_5, & + depvelocity, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -351,6 +385,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & t_phy,moist,p8w,t8w,rmol,aer_res_def, & p_phy,chem,rho_phy,dz8w,ddvel,xland,hfx, & ivgtyp,tsk,vegfra,pbl,ust,znt,xlat,xlong, & + dustdrydep_1,dustdrydep_2,dustdrydep_3, & + dustdrydep_4,dustdrydep_5, & + depvelocity, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -376,11 +413,12 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP, & CBMZSORG,CBMZSORG_AQ) aer_mech_id = 1 - CASE (RACMSORG_AQ,RACMSORG_AQCHEM,RACMSORG_KPP) + CASE (RACMSORG_AQ,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACMSORG_KPP) aer_mech_id = 2 CASE ( CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, & CBMZ_MOSAIC_8BIN_AQ,CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP, & - CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ) + CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) aer_mech_id = 3 CASE ( CBMZ_CAM_MAM3_NOAQ, CBMZ_CAM_MAM3_AQ, CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM7_AQ ) aer_mech_id = 4 @@ -413,7 +451,7 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (RACMSORG_AQ,RACMSORG_AQCHEM,RACMSORG_KPP) + CASE (RACMSORG_AQ,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACMSORG_KPP) CALL wrf_debug(15,'DOING DRY DEP VELOCITIES FOR AEROSOLS/RACM') call sorgam_depdriver (id,config_flags,ktau,dtstep, & ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, & @@ -427,7 +465,8 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & its,ite, jts,jte, kts,kte ) CASE ( CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP ) + CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) CALL wrf_debug(15,'DOING DRY DEP VELOCITIES FOR MOSAIC AEROSOLS') call mosaic_drydep_driver( & id, curr_secs, ktau, dtstep, config_flags, & @@ -505,28 +544,24 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & END SELECT drydep_select -! Add dvel here for all aerosol and gas species in the dvel array -! l = max( 1, min( num_chem, numddvel ) ) -! do i=its,ite -! do j=jts,jte -! do k=1,l -! dvel(i,j,k) = ddvel(i,j,k) -! enddo -! enddo -! enddo -! -! do i=its,ite -! do j=jts,jte -! do k=l+1,numddvel -! if (l < numddvel) dvel(i,j,k) = 0.0 -! enddo -! enddo -! enddo +! Add dep_vel here for all aerosol and gas species in the dvel array + ll = max( 1, min( config_flags%ndepvel, num_vert_mix ) ) + dep_vel(:,:,:,:) = 0. + do l=1,ll + do j=jts,jte + do k=1,config_flags%kdepvel + do i=its,ite + dep_vel(i,k,j,l) = ddvel(i,j,l) + enddo + enddo + enddo + enddo ! This will be called later from subgrd_transport_driver.F !!!!!!!! ! ! dep_vel_o3=0. + if (num_vert_mix == 0) then do 100 j=jts,jte do 100 i=its,ite pblst=0. @@ -596,8 +631,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & enddo mix_select: SELECT CASE(config_flags%chem_opt) - CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZSORG_AQ, & - CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ) + CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, CBMZ_MOSAIC_4BIN_AQ, & + CBMZ_MOSAIC_8BIN_AQ, CBMZSORG_AQ, CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, & + CBMZ_MOSAIC_DMS_8BIN_AQ, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) if(.not.is_aerosol(nv))then ! mix gases not aerosol call vertmx(dtstep,pblst,ekmfull,dryrho_1d, & zzfull,zz,ddvel(i,j,nv),kts,kte) @@ -635,10 +671,11 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & enddo enddo CASE DEFAULT - CALL wrf_debug(15,'NOT YET DEFINED') +! CALL wrf_debug(15,'NOT YET DEFINED') END SELECT tracer_select 100 continue + endif ! num_vert_mix = 0 ! ! vertical mixing and activation of aerosol ! @@ -650,7 +687,7 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & mixactivate_select: SELECT CASE(config_flags%chem_opt) - CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM, CBMZSORG_AQ) + CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, CBMZSORG_AQ) CALL wrf_debug(15,'call mixactivate for sorgam aerosol') call sorgam_mixactivate ( & id, ktau, dtstep, config_flags, idrydep_onoff, & @@ -662,7 +699,8 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ) + CASE (CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) CALL wrf_debug(15,'call mixactivate for mosaic aerosol') call mosaic_mixactivate ( & id, ktau, dtstep, config_flags, idrydep_onoff, & @@ -677,11 +715,15 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & CASE DEFAULT END SELECT mixactivate_select settling_select: SELECT CASE(config_flags%chem_opt) - CASE (DUST,GOCART_SIMPLE,GOCARTRACM_KPP,MOZCART_KPP,RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM) + CASE (DUST,GOCART_SIMPLE,GOCARTRACM_KPP,MOZCART_KPP,RADM2SORG,RADM2SORG_AQ, & + RADM2SORG_AQCHEM,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP) CALL wrf_debug(15,'call gocart settling routine') call gocart_settling_driver(dtstep,config_flags,t_phy,moist, & chem,rho_phy,dz8w,p8w,p_phy, & dustin,seasin,dx,g, & + dustgraset_1,dustgraset_2,dustgraset_3, & + dustgraset_4,dustgraset_5, & + setvel_1,setvel_2,setvel_3,setvel_4,setvel_5, imod, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) diff --git a/wrfv2_fire/chem/emissions_driver.F b/wrfv2_fire/chem/emissions_driver.F index 07d5b177..0aaf021e 100755 --- a/wrfv2_fire/chem/emissions_driver.F +++ b/wrfv2_fire/chem/emissions_driver.F @@ -41,6 +41,10 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ebio_cco_oh, ebio_rco_oh, & clayfrac,sandfrac,dust_alpha,dust_gamma,dust_smtune, & snowh,zs, & + soil_top_cat, ust_t, rough_cor, smois_cor, & + ebio_c5h8,ebio_apinene,ebio_bpinene,ebio_toluene, & + ebio_ch3cho,ebio_ch3co2h,ebio_tbut2ene,ebio_c2h5cho, & + ebio_nc4h10, & ! stuff for MEGAN v2.04 T2,swdown, & nmegan,EFmegan, & @@ -82,6 +86,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & USE gocart_dust USE gocart_dust_afwa USE gocart_seasalt + USE uoc_dust USE module_dms_emis USE module_mosaic_addemiss USE module_add_emis_cptec @@ -212,8 +217,18 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ebio_alk3, ebio_alk4, ebio_alk5, ebio_ole1, ebio_ole2, & ebio_aro1, ebio_aro2, ebio_ccho, ebio_meoh, & ebio_ethene, ebio_hcooh, ebio_terp, ebio_bald, & - ebio_cco_oh, ebio_rco_oh - + ebio_cco_oh, ebio_rco_oh, & + ebio_c5h8,ebio_apinene,ebio_bpinene,ebio_toluene, & + ebio_ch3cho,ebio_ch3co2h,ebio_tbut2ene,ebio_c2h5cho, & + ebio_nc4h10 + + REAL, DIMENSION( ims:ime , jms:jme ) , OPTIONAL , & + INTENT(INOUT) :: ust_t, & + rough_cor, & + smois_cor +! dust source area information from WPS + REAL, DIMENSION(ims:ime,1:config_flags%num_soil_cat,jms:jme) , & + INTENT(IN):: soil_top_cat ! stuff for MEGAN v2.04...most of these arrays are optional and package dependent ! as declared in registry.chem @@ -296,6 +311,9 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & CHARACTER (LEN=80) :: message LOGICAL :: do_bioemiss, do_plumerisefire,do_ex_volcanoe + INTEGER :: imod ! dust scheme option from namelist + + ! .. ! .. ! .. Intrinsic Functions .. @@ -306,7 +324,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ! for PNNL modules: >0 = sea salt/dust emissions turned on ! As of NOV 2008 these only are used for MOSAIC and SORGAM ! gocart dust and seasalt will only work for GOCART and SORGAM -! +! DL - 06/02/2013 - added option for MOSAIC-PDFiTE seasalt emissions (with organic fraction) percen_mass_umbrel=.75 base_umbrel=.25 ! fraction @@ -316,6 +334,9 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & seasalt_emiss_active = 0 if(config_flags%dust_opt >= 2 )dust_emiss_active = 1 if(config_flags%seas_opt == 2 )seasalt_emiss_active = 1 + if(config_flags%seas_opt == 3 )seasalt_emiss_active = 3 + if(config_flags%seas_opt == 4 )seasalt_emiss_active = 4 + ! ! Setup the timing flags... ! (methodology is adapated from module_radiation_driver.F) @@ -449,12 +470,12 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ivolcano=0 elseif(julday.eq.begday)then if(beghr.gt.int(gmtp))then - write(message,'("before volcano stuff at gmtp = ",i8)') gmtp + write(message,'("before volcano stuff at gmtp = ",i8)') int(gmtp) call wrf_debug(15,message) ivolcano=0 elseif(beghr.eq.int(gmtp))then if(begmin.gt.gmtm)then - write(message,'("before volcano stuff at gmtp,begmin = ",2i8)') gmtp,begmin + write(message,'("before volcano stuff at gmtp,begmin = ",2i8)') int(gmtp),int(begmin) call wrf_debug(15,message) ivolcano=0 endif @@ -466,12 +487,12 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ivolcano=0 elseif(julday.eq.endday)then if(endhr.lt.int(gmtp))then - write(message,'("after volcano stuff at gmtp = ",i8)') gmtp + write(message,'("after volcano stuff at gmtp = ",i8)') int(gmtp) call wrf_debug(15,message) ivolcano=0 elseif(endhr.eq.int(gmtp))then if(endmin.lt.gmtm)then - write(message,'("after volcano stuff at gmtm,endmin = ",2i8)') gmtm,endmin + write(message,'("after volcano stuff at gmtm,endmin = ",2i8)') int(gmtm),int(endmin) call wrf_debug(15,message) ivolcano=0 endif @@ -495,7 +516,8 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & +emis_vol(i,k,j,p_e_vash9)*conv & +.5*emis_vol(i,k,j,p_e_vash8)*conv enddo - CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_KPP,RACMSORG_KPP,RACMSORG_AQ,RACM_ESRLSORG_KPP) + CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_KPP,RACMSORG_KPP,RACMSORG_AQ,RACM_ESRLSORG_KPP, & + RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP) ! write(0,*)'do later' do k=kts,kte conv = float(ivolcano)*4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) @@ -653,6 +675,10 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & CASE DEFAULT if(seasalt_emiss_active.eq.1) then CALL wrf_debug(15,'MOSAIC or SORGAM sea salt emissions') + elseif(seasalt_emiss_active.eq.3) then + CALL wrf_debug(15,'MOSAIC sea salt emissions (Fuentes et al) - low activity') + elseif(seasalt_emiss_active.eq.4) then + CALL wrf_debug(15,'MOSAIC sea salt emissions (Fuentes et al) - high activity') else CALL wrf_debug(15,'no sea salt emissions') end if @@ -676,6 +702,25 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE (DUSTUOC) + CALL wrf_debug(15,'UoC dust emission schemes') +! kang [2008/12/14] modify for namelist selection + scheme_select: SELECT CASE(config_flags%dust_schme) + CASE (SHAO_2001) + imod = 1 + CASE (SHAO_2004) + imod = 2 + CASE (SHAO_2011) + imod = 3 + CASE DEFAULT + imod = 2 + END SELECT scheme_select + call uoc_dust_driver (ktau,dtstep,config_flags, & + chem,rho_phy,dz8w,smois,ust, isltyp,vegfra,g,emis_dust, & + ust_t, imod, rough_cor, smois_cor, soil_top_cat, erod, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) CASE DEFAULT if(dust_emiss_active.eq.1) then CALL wrf_debug(15,'MOSAIC or SORGAM dust emissions') @@ -745,8 +790,8 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & if( do_bioemiss ) then beis314_check_mechanism_ok: SELECT CASE(config_flags%chem_opt) CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & - RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ,RACMSORG_AQCHEM, & - RACMSORG_KPP,RACM_ESRLSORG_KPP, RACM_SOA_VBS_KPP, & + RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ,RACMSORG_AQCHEM_KPP, & + RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP,RACM_ESRLSORG_KPP, RACM_SOA_VBS_KPP, & CBM4_KPP, NMHC9_KPP, GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP) CASE DEFAULT CALL wrf_error_fatal( & @@ -791,6 +836,9 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ebio_nh3,ebio_no2,ebio_c2h5oh,ebio_ch3cooh,ebio_mek, & ebio_bigene,ebio_c2h6,ebio_c2h4,ebio_c3h6,ebio_c3h8,ebio_so2, & ebio_dms, & + ebio_c5h8,ebio_apinene,ebio_bpinene,ebio_toluene, & + ebio_ch3cho,ebio_ch3co2h,ebio_tbut2ene,ebio_c2h5cho, & + ebio_nc4h10, & ebio_sesq, ebio_mbo, & ebio_alk3, ebio_alk4, ebio_alk5, ebio_ole1, ebio_ole2, & ebio_aro1, ebio_aro2, ebio_ccho, ebio_meoh, & @@ -814,8 +862,9 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ! gas_addemiss_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & - RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM, RACMSORG_KPP, RACM_SOA_VBS_KPP, & - RACM_ESRLSORG_KPP, MOZART_KPP, MOZCART_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP ) + RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP, & + RACM_SOA_VBS_KPP, RACM_ESRLSORG_KPP, MOZART_KPP, MOZCART_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP, CRIMECH_KPP, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) IF(config_flags%emiss_inpt_opt /= 3 ) then IF(config_flags%kemit .GT. kte-ksub) THEN k=config_flags%kemit @@ -857,21 +906,24 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & end if ! emiss_inpt_opt /= 3 - IF(config_flags%emiss_opt == 10 ) then - do j=jts,jte - do i=its,ite - do k=kts,min(config_flags%kemit,kte-ksub) - conv = 4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - - chem(i,k,j,p_voca) = chem(i,k,j,p_voca) & - +emis_ant(i,k,j,p_e_co_a)*conv*0.08*28./250. - chem(i,k,j,p_vocbb) = chem(i,k,j,p_vocbb) & - +emis_ant(i,k,j,p_e_co_bb)*conv*0.08*28./250. - - end do - end do - end do - endif +! 20130725 acd_ck_bugfix start +! > double counting - already added in add_anthropogenics (module_emissions_anthropogenic.F) +! IF(config_flags%emiss_opt == 10 ) then +! do j=jts,jte +! do i=its,ite +! do k=kts,min(config_flags%kemit,kte-ksub) +! conv = 4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) +! +! chem(i,k,j,p_voca) = chem(i,k,j,p_voca) & +! +emis_ant(i,k,j,p_e_co_a)*conv*0.08*28./250. +! chem(i,k,j,p_vocbb) = chem(i,k,j,p_vocbb) & +! +emis_ant(i,k,j,p_e_co_bb)*conv*0.08*28./250. +! +! end do +! end do +! end do +! endif +! 20130725 acd_ck_bugfix end !For SAPRC99 need to define SAPRC99_addemiss_anthro and SAPRC99_addemiss_bio !so did not add saprcnov packages here @@ -1088,7 +1140,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & chem(i,k,j,p_co) = chem(i,k,j,p_co) & +emis_ant(i,k,j,p_e_co)*conv chem(i,k,j,p_no) = chem(i,k,j,p_no) & - +emis_ant(i,k,j,p_e_co)*conv + +emis_ant(i,k,j,p_e_no)*conv chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & +emis_ant(i,k,j,p_e_hcho)*conv end do @@ -1306,7 +1358,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & chem(i,k,j,p_co) = chem(i,k,j,p_co) & +emis_ant(i,k,j,p_e_co)*conv chem(i,k,j,p_no) = chem(i,k,j,p_no) & - +emis_ant(i,k,j,p_e_co)*conv + +emis_ant(i,k,j,p_e_no)*conv chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) & +emis_ant(i,k,j,p_e_hcho)*conv end do @@ -1440,7 +1492,8 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & emiss_select: SELECT CASE(config_flags%emiss_inpt_opt) CASE (EMISS_INPT_CPTEC) call wrf_debug(15,'emissions_driver calling add_emiss_cptec') - call add_emis_cptec(id,dtstep,ktau,dz8w,config_flags,rho_phy,chem,& + call add_emis_cptec(id,dtstep,ktau,dz8w,config_flags,curr_secs, & + rho_phy,chem, & julday,gmt,xlat,xlong,t_phy,p_phy, & emis_ant, & ids,ide, jds,jde, kds,kde, & @@ -1453,7 +1506,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & aer_addemiss_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RADM2SORG_KPP, & - RACMSORG_AQ,RACMSORG_AQCHEM,RACMSORG_KPP,RACM_ESRLSORG_KPP,CBMZSORG,CBMZSORG_AQ) + RACMSORG_AQ,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACMSORG_KPP,RACM_ESRLSORG_KPP,CBMZSORG,CBMZSORG_AQ) call wrf_debug(15,'emissions_driver calling sorgam_addemiss') call sorgam_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, & ebu, & @@ -1491,7 +1544,8 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ,SAPRC99_MOSAIC_4BIN_VBS2_KPP,& - CBMZ_MOSAIC_4BIN_VBS2_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP ) + CBMZ_MOSAIC_4BIN_VBS2_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) call wrf_debug(15,'emissions_driver calling mosaic_addemiss') call mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & config_flags, chem, slai, ust, smois, ivgtyp, isltyp, & diff --git a/wrfv2_fire/chem/mechanism_driver.F b/wrfv2_fire/chem/mechanism_driver.F index bcc8e269..be861f4c 100755 --- a/wrfv2_fire/chem/mechanism_driver.F +++ b/wrfv2_fire/chem/mechanism_driver.F @@ -138,7 +138,7 @@ subroutine mechanism_driver(id,curr_secs,ktau,dtstep,ktauc,dtstepc,& ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (RACMSORG_KPP,RADM2SORG_KPP,RACMSORG_AQ,RACMSORG_AQCHEM,RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP) + CASE (RACMSORG_KPP,RADM2SORG_KPP,RACMSORG_AQ,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP) vcsulf_old(its:ite,kts:kte,jts:jte) = & max(chem(its:ite,kts:kte,jts:jte,p_sulf),epsilc) diff --git a/wrfv2_fire/chem/module_add_emis_cptec.F b/wrfv2_fire/chem/module_add_emis_cptec.F index 49fef778..997ff028 100644 --- a/wrfv2_fire/chem/module_add_emis_cptec.F +++ b/wrfv2_fire/chem/module_add_emis_cptec.F @@ -1,7 +1,8 @@ Module module_add_emis_cptec CONTAINS - subroutine add_emis_cptec(id,dtstep,ktau,dz8w,config_flags,rho_phy,chem, & - julday,gmt,xlat,xlong,t_phy,p_phy,emis_ant, & + subroutine add_emis_cptec(id,dtstep,ktau,dz8w,config_flags, & + curr_secs,rho_phy,chem, & + julday,gmt,xlat,xlong,t_phy,p_phy,emis_ant, & ! ebu_no,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8, & ! ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso, & ! ebu_api,ebu_lim,ebu_tol,ebu_xyl,ebu_csl,ebu_hcho,ebu_ald, & @@ -11,6 +12,8 @@ subroutine add_emis_cptec(id,dtstep,ktau,dz8w,config_flags,rho_phy,chem, & its,ite, jts,jte, kts,kte ) USE module_configure USE module_state_description + USE module_date_time + IMPLICIT NONE @@ -48,12 +51,17 @@ subroutine add_emis_cptec(id,dtstep,ktau,dz8w,config_flags,rho_phy,chem, & REAL, INTENT(IN ) :: & dtstep,gmt + + REAL(KIND=8), INTENT(IN ) :: curr_secs + integer ::imonth1,idate1,iyear1,itime1 integer :: i,j,k real :: time,conv_rho integer :: iweek,idays real :: tign,timeq,r_q,r_antro real, dimension(7) :: week_CYCLE + integer :: century_year,month,day,hour,minute,second,ten_thousandth + ! dia da semana: DOM SEG TER QUA QUI SEX SAB ! iweek= 1 2 3 4 5 6 7 !- dados cetesb/campinas/2005 @@ -69,7 +77,11 @@ subroutine add_emis_cptec(id,dtstep,ktau,dz8w,config_flags,rho_phy,chem, & !-------------biomass burning diurnal cycle -------------------- !number of days of simulation - idays = int(( float(itime1)/100. + time/3600.)/24.+.00001) + call split_date_char(start_date,century_year,month,day,hour,minute, & + second,ten_thousandth) + itime1 = hour + + idays = int(( float(itime1) + time/3600.)/24.+.00001) tign = real(idays)*24.*3600. ! Modulacao da queimada media durante o ciclo diurno(unidade: 1/s) ! com a int( r_q dt) (0 - 24h)= 1. diff --git a/wrfv2_fire/chem/module_add_emiss_burn.F b/wrfv2_fire/chem/module_add_emiss_burn.F index 7334189a..48cc453a 100644 --- a/wrfv2_fire/chem/module_add_emiss_burn.F +++ b/wrfv2_fire/chem/module_add_emiss_burn.F @@ -161,7 +161,7 @@ subroutine add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,chem, & enddo enddo CASE (RADM2SORG,RACMSORG_KPP, RADM2SORG_KPP, RACM_ESRLSORG_KPP, RACM_SOA_VBS_KPP, & - RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM) + RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP) do j=jts,jte do i=its,ite do k=kts,kte @@ -364,6 +364,24 @@ subroutine add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,chem, & enddo enddo enddo +! 20130822 acd_rkumar_bb start +! Adding simple SOA scheme emissions from biomass burning. +! WARNING: do not provide e_co_bb in wrfchemi* files if you use +! the online plume rise - you would be double counting emissions! +! -- Dear Steven, could you please include this note in the user guide +! -- when you adopt these changes? Thanks. Rajesh and Christoph + IF (chem_opt .EQ. MOZART_MOSAIC_4BIN_VBS0_KPP) THEN + do j=jts,jte + do k=kts,kte + do i=its,ite + conv_rho = (r_q*4.828e-4*dtstep)/(rho_phy(i,k,j)*dz8w(i,k,j)*60.) + chem(i,k,j,p_vocbb) = chem(i,k,j,p_vocbb) + ebu(i,k,j,p_ebu_co)*conv_rho*0.04*28./250. + enddo + enddo + enddo + ENDIF +! 20130822 acd_rkumar_bb end + if( biomass_burn_opt == BIOMASSB_MOZC ) then do j=jts,jte do k=kts,kte diff --git a/wrfv2_fire/chem/module_bioemi_megan2.F b/wrfv2_fire/chem/module_bioemi_megan2.F index 9fc60813..0b6a4aa8 100644 --- a/wrfv2_fire/chem/module_bioemi_megan2.F +++ b/wrfv2_fire/chem/module_bioemi_megan2.F @@ -43,6 +43,9 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ebio_nh3,ebio_no2,ebio_c2h5oh,ebio_ch3cooh,ebio_mek, & ebio_bigene,ebio_c2h6,ebio_c2h4,ebio_c3h6,ebio_c3h8,ebio_so2, & ebio_dms, & + ebio_c5h8,ebio_apinene,ebio_bpinene,ebio_toluene, & + ebio_ch3cho,ebio_ch3co2h,ebio_tbut2ene,ebio_c2h5cho, & + ebio_nc4h10, & ebio_sesq, ebio_mbo, & ebio_alk3, ebio_alk4, ebio_alk5, ebio_ole1, ebio_ole2, & ebio_aro1, ebio_aro2, ebio_ccho, ebio_meoh, & @@ -169,6 +172,9 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ebio_nh3,ebio_no2,ebio_c2h5oh,ebio_ch3cooh,ebio_mek, & ebio_bigene,ebio_c2h6,ebio_c2h4,ebio_c3h6,ebio_c3h8,ebio_so2, & ebio_dms, & + ebio_c5h8,ebio_apinene,ebio_bpinene,ebio_toluene, & + ebio_ch3cho,ebio_ch3co2h,ebio_tbut2ene,ebio_c2h5cho, & + ebio_nc4h10, & ebio_sesq,ebio_mbo, & ebio_alk3, ebio_alk4, ebio_alk5, ebio_ole1, ebio_ole2, & ebio_aro1, ebio_aro2, ebio_ccho, ebio_meoh, & @@ -348,6 +354,17 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ebio_c3h8 ( its:ite , jts:jte ) = 0.0 ebio_so2 ( its:ite , jts:jte ) = 0.0 ebio_dms ( its:ite , jts:jte ) = 0.0 + ebio_c5h8 ( its:ite , jts:jte ) = 0.0 + ebio_apinene ( its:ite , jts:jte ) = 0.0 + ebio_bpinene ( its:ite , jts:jte ) = 0.0 + ebio_toluene ( its:ite , jts:jte ) = 0.0 + ebio_hcooh ( its:ite , jts:jte ) = 0.0 + ebio_ch3cho ( its:ite , jts:jte ) = 0.0 + ebio_c2h5oh ( its:ite , jts:jte ) = 0.0 + ebio_ch3co2h ( its:ite , jts:jte ) = 0.0 + ebio_tbut2ene ( its:ite , jts:jte ) = 0.0 + ebio_c2h5cho ( its:ite , jts:jte ) = 0.0 + ebio_nc4h10 ( its:ite , jts:jte ) = 0.0 ebio_sesq ( its:ite , jts:jte ) = 0.0 ebio_mbo ( its:ite , jts:jte ) = 0.0 e_bio ( its:ite , jts:jte , 1:ne_area) = 0.0 @@ -428,8 +445,8 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ! get p_of_radm2cbmz(:), p_of_radm2(:), and radm2_per_megan(:) CALL get_megan2radm2_table - CASE (RACMSORG_AQ, RACMSORG_AQCHEM, RACM_ESRLSORG_KPP, RACM_KPP, GOCARTRACM_KPP, RACMSORG_KPP, RACM_MIM_KPP, & - RACMPM_KPP) + CASE (RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RACM_ESRLSORG_KPP, RACM_KPP, GOCARTRACM_KPP, RACMSORG_KPP, & + RACM_MIM_KPP, RACMPM_KPP) ! get p_of_megan2racm(:), p_of_racm(:), and racm_per_megan(:) CALL get_megan2racm_table @@ -456,6 +473,10 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & CASE (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP) ! FIX FOR SAPRC07A CALL get_megan2saprcnov_table + CASE ( CRIMECH_KPP, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) + ! get p_of_megan2crimech(:), p_of_crimech(:), and crimech_per_megan(:) + CALL get_megan2crimech_table + CASE DEFAULT CALL wrf_error_fatal('Species conversion table for MEGAN v2.04 not available. ') @@ -916,8 +937,8 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & END DO - CASE (RACMSORG_AQ, RACMSORG_AQCHEM, RACM_ESRLSORG_KPP, RACM_KPP, GOCARTRACM_KPP, RACMSORG_KPP, RACM_MIM_KPP, & - RACMPM_KPP) + CASE (RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RACM_ESRLSORG_KPP, RACM_KPP, GOCARTRACM_KPP, & + RACMSORG_KPP, RACM_MIM_KPP, RACMPM_KPP) DO icount = 1, n_megan2racm @@ -1138,6 +1159,25 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & e_bio(i,j,p_ol2-1) = e_bio(i,j,p_ol2-1) + gas_emis*convert2 ELSE IF ( p_in_chem .EQ. p_ora1) THEN e_bio(i,j,p_ora1-1) = e_bio(i,j,p_ora1-1) + gas_emis*convert2 + + ! SAN, 08/11/13 - adding missing CBMZ species to be mapped: + ! missing: p_par, p_ch3oh, p_c2h5oh, p_nh3, p_tol + ELSE IF ( p_in_chem .EQ. p_par) THEN + !ebio_par(i,j) = ebio_par(i,j) + gas_emis + e_bio(i,j,p_par-1) = e_bio(i,j,p_par-1) + gas_emis*convert2 + ELSE IF ( p_in_chem .EQ. p_ch3oh) THEN + ebio_ch3oh(i,j) = ebio_ch3oh(i,j) + gas_emis + e_bio(i,j,p_ch3oh-1) = e_bio(i,j,p_ch3oh-1)+ gas_emis*convert2 + ELSE IF ( p_in_chem .EQ. p_c2h5oh) THEN + ebio_c2h5oh(i,j) = ebio_c2h5oh(i,j) + gas_emis + e_bio(i,j,p_c2h5oh-1)= e_bio(i,j,p_c2h5oh-1) + gas_emis*convert2 + ELSE IF ( p_in_chem .EQ. p_nh3) THEN + ebio_nh3(i,j) = ebio_nh3(i,j) + gas_emis + e_bio(i,j,p_nh3-1) = e_bio(i,j,p_nh3-1) + gas_emis*convert2 + ELSE IF ( p_in_chem .EQ. p_tol) THEN + ebio_tol(i,j) = ebio_tol(i,j) + gas_emis + e_bio(i,j,p_tol-1) = e_bio(i,j,p_tol-1) + gas_emis*convert2 + END IF @@ -1253,6 +1293,107 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & END DO + CASE ( CRIMECH_KPP, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) + + DO icount = 1, n_megan2crimech + IF ( p_of_crimech(icount) .NE. non_react ) THEN + + ! Get index to chem array for the corresponding crimech + ! species. + p_in_chem = p_of_crimech(icount) + + ! Check if the species is actually in the mechanism + IF( p_in_chem > param_first_scalar ) THEN + + ! Emission rate of mechanism species in mol km-2 hr-1 + gas_emis = crimech_per_megan(icount) * E_megan2(p_of_megan2crimech(icount)) + + ! Add emissions to diagnostic output variables. + ! ebio_xxx (mol km-2 hr-1) were originally used by the + ! BEIS3.11 biogenic emissions module. + ! I have also borrowed variable e_bio (ppm m min-1). + + IF ( p_in_chem == p_c5h8 ) THEN + ebio_c5h8(i,j) = ebio_c5h8(i,j) + gas_emis + e_bio(i,j,p_c5h8-1) = e_bio(i,j,p_c5h8-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_no ) THEN + ebio_no(i,j) = ebio_no(i,j) + gas_emis + e_bio(i,j,p_no-1) = e_bio(i,j,p_no-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_no2 ) THEN + ebio_no2(i,j) = ebio_no2(i,j) + gas_emis + e_bio(i,j,p_no2-1) = e_bio(i,j,p_no2-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_co ) THEN + ebio_co(i,j) = ebio_co(i,j) + gas_emis + e_bio(i,j,p_co-1) = e_bio(i,j,p_co-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_hcho ) THEN + ebio_hcho(i,j) = ebio_hcho(i,j) + gas_emis + e_bio(i,j,p_hcho-1) = e_bio(i,j,p_hcho-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_ket ) THEN + ebio_ket(i,j) = ebio_ket(i,j) + gas_emis + e_bio(i,j,p_ket-1) = e_bio(i,j,p_ket-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_toluene ) THEN + ebio_toluene(i,j) = ebio_toluene(i,j) + gas_emis + e_bio(i,j,p_toluene-1) = e_bio(i,j,p_toluene-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_apinene ) THEN + ebio_apinene(i,j) = ebio_apinene(i,j) + gas_emis + e_bio(i,j,p_apinene-1) = e_bio(i,j,p_apinene-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_bpinene ) THEN + ebio_bpinene(i,j) = ebio_bpinene(i,j) + gas_emis + e_bio(i,j,p_bpinene-1) = e_bio(i,j,p_bpinene-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_so2 ) THEN + ebio_so2(i,j) = ebio_so2(i,j) + gas_emis + e_bio(i,j,p_so2-1) = e_bio(i,j,p_so2-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_dms ) THEN + ebio_dms(i,j) = ebio_dms(i,j) + gas_emis + e_bio(i,j,p_dms-1) = e_bio(i,j,p_dms-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_nc4h10 ) THEN + ebio_nc4h10(i,j) = ebio_nc4h10(i,j) + gas_emis + e_bio(i,j,p_nc4h10-1) = e_bio(i,j,p_nc4h10-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_tbut2ene ) THEN + ebio_tbut2ene(i,j) = ebio_tbut2ene(i,j) + gas_emis + e_bio(i,j,p_tbut2ene-1) = e_bio(i,j,p_tbut2ene-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_nh3 ) THEN + ebio_nh3(i,j) = ebio_nh3(i,j) + gas_emis + e_bio(i,j,p_nh3-1) = e_bio(i,j,p_nh3-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_ch3oh ) THEN + ebio_ch3oh(i,j) = ebio_ch3oh(i,j) + gas_emis + e_bio(i,j,p_ch3oh-1) = e_bio(i,j,p_ch3oh-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_c2h5oh ) THEN + ebio_c2h5oh(i,j) = ebio_c2h5oh(i,j) + gas_emis + e_bio(i,j,p_c2h5oh-1) = e_bio(i,j,p_c2h5oh-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_ch3co2h ) THEN + ebio_ch3co2h(i,j) = ebio_ch3co2h(i,j) + gas_emis + e_bio(i,j,p_ch3co2h-1) = e_bio(i,j,p_ch3co2h-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_mek ) THEN + ebio_mek(i,j) = ebio_mek(i,j) + gas_emis + e_bio(i,j,p_mek-1) = e_bio(i,j,p_mek-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_c2h4 ) THEN + ebio_c2h4(i,j) = ebio_c2h4(i,j) + gas_emis + e_bio(i,j,p_c2h4-1) = e_bio(i,j,p_c2h4-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_c2h6 ) THEN + ebio_c2h6(i,j) = ebio_c2h6(i,j) + gas_emis + e_bio(i,j,p_c2h6-1) = e_bio(i,j,p_c2h6-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_c3h6 ) THEN + ebio_c3h6(i,j) = ebio_c3h6(i,j) + gas_emis + e_bio(i,j,p_c3h6-1) = e_bio(i,j,p_c3h6-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_c3h8 ) THEN + ebio_c3h8(i,j) = ebio_c3h8(i,j) + gas_emis + e_bio(i,j,p_c3h8-1) = e_bio(i,j,p_c3h8-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_ch3cho ) THEN + ebio_ch3cho(i,j) = ebio_ch3cho(i,j) + gas_emis + e_bio(i,j,p_ch3cho-1) = e_bio(i,j,p_ch3cho-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_hcooh ) THEN + ebio_hcooh(i,j) = ebio_hcooh(i,j) + gas_emis + e_bio(i,j,p_hcooh-1) = e_bio(i,j,p_hcooh-1) + gas_emis*convert2 + END IF + + END IF !( p_in_chem > param_first_scalar ) + + + END IF !( p_of_crimech(icount) .NE. non_react ) + + END DO + CASE DEFAULT diff --git a/wrfv2_fire/chem/module_cam_mam_init.F b/wrfv2_fire/chem/module_cam_mam_init.F index 31f13b51..fc388020 100644 --- a/wrfv2_fire/chem/module_cam_mam_init.F +++ b/wrfv2_fire/chem/module_cam_mam_init.F @@ -152,9 +152,11 @@ subroutine cam_mam_init( & endif !Balwinder.Singh@pnnl.gov: Sanity check for cam_mam_nspec variable in namelist - if((config_flags%chem_opt == CBMZ_CAM_MAM3_NOAQ .OR. config_flags%chem_opt == CBMZ_CAM_MAM3_AQ) .AND. config_flags%cam_mam_nspec .NE. 74)then - call wrf_error_fatal( 'CAM_MAM_INIT - For MODAL_AERO_3MODE (chem_opt - 503 CAM_MAM3 package), cam_mam_nspec in namelist should be set to 74' ) + !BSINGH (01/23/2014):Please make sure cam_mam_nspec is equal to pcnst in phys/module_physics_init.F and registry.chem + if((config_flags%chem_opt == CBMZ_CAM_MAM3_NOAQ .OR. config_flags%chem_opt == CBMZ_CAM_MAM3_AQ) .AND. config_flags%cam_mam_nspec .NE. 85)then + call wrf_error_fatal( 'CAM_MAM_INIT - For MODAL_AERO_3MODE (chem_opt - 503 CAM_MAM3 package), cam_mam_nspec in namelist should be set to 85' ) elseif((config_flags%chem_opt == CBMZ_CAM_MAM7_NOAQ .OR. config_flags%chem_opt == CBMZ_CAM_MAM7_AQ) .AND. config_flags%cam_mam_nspec .NE. 90)then + !BSINGH (01/23/2014): DMS species are NOT included in MAM7 package. call wrf_error_fatal('CAM_MAM_INIT - For MODAL_AERO_7MODE (chem_opt - 504 CAM_MAM7 package), cam_mam_nspec in namelist should be set to 90') endif diff --git a/wrfv2_fire/chem/module_cbmz_addemiss.F b/wrfv2_fire/chem/module_cbmz_addemiss.F index 853f485c..e2362ff9 100644 --- a/wrfv2_fire/chem/module_cbmz_addemiss.F +++ b/wrfv2_fire/chem/module_cbmz_addemiss.F @@ -194,6 +194,13 @@ subroutine cbmz_addemiss_anthro( id, dtstep, dz8w, config_flags, & + conv*emis_ant(i,k,j,p_e_c2h5oh) end if + !BSINGH(01/24/2013): Added for DMS emissions + !PMA DMS emission [added by BSINGH - 01/20/2014] + if ( (config_flags%emiss_inpt_opt == EMISS_INPT_PNNL_MAM)) then + chem(i,k,j,p_dms) = chem(i,k,j,p_dms) & + + conv*emis_ant(i,k,j,p_e_dms) + end if + END DO 100 continue diff --git a/wrfv2_fire/chem/module_chem_plumerise_scalar.F b/wrfv2_fire/chem/module_chem_plumerise_scalar.F index 0f09d9ef..8500de7b 100644 --- a/wrfv2_fire/chem/module_chem_plumerise_scalar.F +++ b/wrfv2_fire/chem/module_chem_plumerise_scalar.F @@ -42,6 +42,8 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz,firesize,mean_fct & integer, parameter :: grassland = 4 real, dimension(nveg_agreg) :: firesize,mean_fct + INTEGER, PARAMETER :: wind_eff = 1 + !Fator de conversao de unidades !!fcu=1. !=> kg [gas/part] /kg [ar] @@ -86,8 +88,8 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz,firesize,mean_fct & !- plume rise => cycle do k = 1,m1 - !ucon (k)=up(k,i,j) ! u wind - !vcon (k)=vp(k,i,j) ! v wind + ucon (k)=up(k,i,j) ! u wind + vcon (k)=vp(k,i,j) ! v wind !wcon (k)=wp(k,i,j) ! w wind thtcon(k)=theta(k,i,j) ! pot temperature picon (k)=pp(k,i,j) ! exner function @@ -104,7 +106,7 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz,firesize,mean_fct & enddo !- get envinronmental state (temp, water vapor mix ratio, ...) - call get_env_condition(1,m1,kmt) + call get_env_condition(1,m1,kmt,wind_eff) !- loop nos 4 biomas agregados com possivel queimada do iveg_ag=1,nveg_agreg @@ -144,12 +146,12 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz,firesize,mean_fct & cycle endif - call makeplume (kmt,ztopmax(imm),ixx) + call makeplume (kmt,ztopmax(imm),ixx,imm) enddo ! enddo do loop em imm !- define o dominio vertical onde a emissao flaming ira ser colocada - call set_flam_vert(ztopmax,k1,k2) + call set_flam_vert(ztopmax,k1,k2,nkp,zzcon,W_VMD,VMD) !- espessura da camada vertical dz_flam=zzcon(k2)-zzcon(k1-1) @@ -203,7 +205,7 @@ subroutine plumerise(m1,m2,m3,ia,iz,ja,jz,firesize,mean_fct & end subroutine plumerise !------------------------------------------------------------------------- -subroutine get_env_condition(k1,k2,kmt) +subroutine get_env_condition(k1,k2,kmt,wind_eff) !se module_zero_plumegen_coms !use rconstants @@ -211,6 +213,8 @@ subroutine get_env_condition(k1,k2,kmt) integer :: k1,k2,k,kcon,klcl,kmt,nk,nkmid,i real :: znz,themax,tlll,plll,rlll,zlll,dzdd,dzlll,tlcl,plcl,dzlcl,dummy integer :: n_setgrid = 0 +integer :: wind_eff + if( n_setgrid == 0) then n_setgrid = 1 @@ -225,14 +229,15 @@ subroutine get_env_condition(k1,k2,kmt) enddo stop ' envir stop 12' 13 continue -kmt=k +!-srf-mb +kmt=min(k,nkp-1) nk=k2-k1+1 -!call htint(nk, wcon,zzcon(k1),kmt,wpe,zt) -!call htint(nk, ucon,zcon(k1),kmt,upe,zt) -!call htint(nk, vcon,zcon(k1),kmt,vpe,zt) - call htint(nk,thtcon,zcon(k1),kmt,the ,zt) - call htint(nk, rvcon,zcon(k1),kmt,qvenv,zt) +!call htint(nk, wcon,zzcon,kmt,wpe,zt) + call htint(nk, ucon,zcon,kmt,upe,zt) + call htint(nk, vcon,zcon,kmt,vpe,zt) + call htint(nk,thtcon,zcon,kmt,the ,zt) + call htint(nk, rvcon,zcon,kmt,qvenv,zt) do k=1,kmt qvenv(k)=max(qvenv(k),1e-8) enddo @@ -250,8 +255,14 @@ subroutine get_env_condition(k1,k2,kmt) pe(k) = (pke(k)/cp)**cpor*p00 ! pressure (Pa) dne(k)= pe(k)/(rgas*te(k)*(1.+.61*qvenv(k))) ! dry air density (kg/m3) ! print*,'ENV=',qvenv(k)*1000., te(k)-273.15,zt(k) +!-srf-mb + vel_e(k) = sqrt(upe(k)**2+vpe(k)**2) !-env wind (m/s) + !print*,'k,vel_e(k),te(k)=',vel_e(k),te(k) enddo +!-ewe - env wind effect +if(wind_eff < 1) vel_e(1:kmt) = 0. + !-use este para gerar o RAMS.out ! ------- print environment state !print*,'k,zt(k),pe(k),te(k)-273.15,qvenv(k)*1000' @@ -312,33 +323,93 @@ subroutine set_grid() end subroutine set_grid !------------------------------------------------------------------------- -subroutine set_flam_vert(ztopmax,k1,k2) -! use module_zero_plumegen_coms, only : nkp,zzcon - implicit none - integer imm,k,k1,k2 - real, dimension(2) :: ztopmax - integer, dimension(2) :: k_lim - + SUBROUTINE set_flam_vert(ztopmax,k1,k2,nkp,zzcon,W_VMD,VMD) + + REAL , INTENT(IN) :: ztopmax(2) + INTEGER , INTENT(OUT) :: k1 + INTEGER , INTENT(OUT) :: k2 + + ! plumegen_coms + INTEGER , INTENT(IN) :: nkp + REAL , INTENT(IN) :: zzcon(nkp) + + INTEGER imm,k + INTEGER, DIMENSION(2) :: k_lim + + !- version 2 + REAL , INTENT(IN) :: W_VMD(nkp,2) + REAL , INTENT(OUT) :: VMD(nkp,2) + real w_thresold,xxx + integer k_initial,k_final,ko,kk4,kl + + !- version 1 + DO imm=1,2 + ! checar + ! do k=1,m1-1 + DO k=1,nkp-1 + IF(zzcon(k) > ztopmax(imm) ) EXIT + ENDDO + k_lim(imm) = k + ENDDO + k1=MAX(3,k_lim(1)) + k2=MAX(3,k_lim(2)) + + IF(k2 < k1) THEN + !print*,'1: ztopmax k=',ztopmax(1), k1 + !print*,'2: ztopmax k=',ztopmax(2), k2 + k2=k1 + !stop 1234 + ENDIF + + !- version 2 + !- vertical mass distribution + !- + w_thresold = 1. + DO imm=1,2 - do imm=1,2 -! checar -! do k=1,m1-1 - do k=1,nkp-1 - if(zzcon(k) > ztopmax(imm) ) exit - enddo - k_lim(imm) = k - enddo - k1=max(3,k_lim(1)) - k2=max(3,k_lim(2)) - - if(k2 < k1) then - !print*,'1: ztopmax k=',ztopmax(1), k1 - !print*,'2: ztopmax k=',ztopmax(2), k2 - k2=k1 - !stop 1234 - endif -end subroutine set_flam_vert + VMD(1:nkp,imm)= 0. + xxx=0. + k_initial= 0 + k_final = 0 + + !- define range of the upper detrainemnt layer + do ko=nkp-10,2,-1 + + if(w_vmd(ko,imm) < w_thresold) cycle + + if(k_final==0) k_final=ko + + if(w_vmd(ko,imm)-1. > w_vmd(ko-1,imm)) then + k_initial=ko + exit + endif + + enddo + !- if there is a non zero depth layer, make the mass vertical distribution + if(k_final > 0 .and. k_initial > 0) then + + k_initial=int((k_final+k_initial)*0.5) + + !- parabolic vertical distribution between k_initial and k_final + kk4 = k_final-k_initial+2 + do ko=1,kk4-1 + kl=ko+k_initial-1 + VMD(kl,imm) = 6.* float(ko)/float(kk4)**2 * (1. - float(ko)/float(kk4)) + enddo + if(sum(VMD(1:NKP,imm)) .ne. 1.) then + xxx= ( 1.- sum(VMD(1:NKP,imm)) )/float(k_final-k_initial+1) + do ko=k_initial,k_final + VMD(ko,imm) = VMD(ko,imm)+ xxx !- values between 0 and 1. + enddo + ! print*,'new mass=',sum(mass)*100.,xxx + !pause + endif + endif !k_final > 0 .and. k_initial > + + ENDDO + + END SUBROUTINE set_flam_vert !------------------------------------------------------------------------- subroutine get_fire_properties(imm,iveg_ag,burnt_area,STD_burnt_area) @@ -347,6 +418,7 @@ subroutine get_fire_properties(imm,iveg_ag,burnt_area,STD_burnt_area) integer :: moist, i, icount,imm,iveg_ag real:: bfract, effload, heat, hinc ,burnt_area,STD_burnt_area,heat_fluxW real, dimension(2,4) :: heat_flux +INTEGER, parameter :: use_last = 0 data heat_flux/ & @@ -377,7 +449,8 @@ subroutine get_fire_properties(imm,iveg_ag,burnt_area,STD_burnt_area) !heat = 21.e6 !- joules per kg of fuel consumed !heat = 15.5e6 !joules/kg - cerrado heat = 19.3e6 !joules/kg - floresta em alta floresta (mt) -alpha = 0.1 !- entrainment constant +!alpha = 0.1 !- entrainment constant +alpha = 0.05 !- entrainment constant !-------------------- printout ---------------------------------------- @@ -436,19 +509,34 @@ subroutine get_fire_properties(imm,iveg_ag,burnt_area,STD_burnt_area) ICOUNT = ICOUNT + 1 ENDDO ! ramp for 5 minutes - - HINC = HEATING (1) / 4. - HEATING (1) = 0.1 - HEATING (2) = HINC - HEATING (3) = 2. * HINC - HEATING (4) = 3. * HINC -! + IF(use_last /= 1) THEN + + HINC = HEATING (1) / 4. + HEATING (1) = 0.1 + HEATING (2) = HINC + HEATING (3) = 2. * HINC + HEATING (4) = 3. * HINC + ELSE + IF(imm==1) THEN + HINC = HEATING (1) / 4. + HEATING (1) = 0.1 + HEATING (2) = HINC + HEATING (3) = 2. * HINC + HEATING (4) = 3. * HINC + ELSE + HINC = (HEATING (1) - heat_flux(imm-1,iveg_ag) * 1000. *0.55)/ 4. + HEATING (1) = heat_flux(imm-1,iveg_ag) * 1000. *0.55 + 0.1 + HEATING (2) = HEATING (1)+ HINC + HEATING (3) = HEATING (2)+ HINC + HEATING (4) = HEATING (3)+ HINC + ENDIF + ENDIF return end subroutine get_fire_properties !------------------------------------------------------------------------------- ! -SUBROUTINE MAKEPLUME ( kmt,ztopmax,ixx) +SUBROUTINE MAKEPLUME ( kmt,ztopmax,ixx,imm) ! ! ********************************************************************* ! @@ -519,6 +607,9 @@ SUBROUTINE MAKEPLUME ( kmt,ztopmax,ixx) ztopmax, wmax, rmaxtime, es, esat, heat,dt_save !ESAT_PR, character (len=2) :: cixx + REAL :: DELZ_THRESOLD + INTEGER :: imm + ! real, external:: esat_pr! ! ! ******************* SOME CONSTANTS ********************************** @@ -607,6 +698,10 @@ SUBROUTINE MAKEPLUME ( kmt,ztopmax,ixx) !-- scalars entrainment, adiabatic call scl_misc(NM1) + +!-- scalars dinamic entrainment + call scl_dyn_entrain(NM1,nkp,wbar,w,adiabat,alpha,radius,tt,t,te,qvt,qv,qvenv,qct,qc,qht,qh,qit,qi,& + vel_e,vel_p,vel_t,rad_p,rad_t) !-- gravity wave damping using Rayleigh friction layer fot T call damp_grav_wave(1,nm1,deltak,dt,zt,zm,w,t,tt,qv,qh,qi,qc,te,pe,qvenv) @@ -681,26 +776,38 @@ SUBROUTINE MAKEPLUME ( kmt,ztopmax,ixx) ! Gravity wave damping using Rayleigh friction layer for W call damp_grav_wave(2,nm1,deltak,dt,zt,zm,w,t,tt,qv,qh,qi,qc,te,pe,qvenv) !--- + !- update radius + do k=2,nm1 + radius(k) = rad_p(k) + enddo + !-- try to find the plume top (above surface height) + kk = 1 + DO WHILE (w (kk) .GT. 1.) + kk = kk + 1 + ztop = zm(kk) + !print*,'W=',w (kk) + ENDDO + ! + ztop_(mintime) = ztop + ztopmax = MAX (ztop, ztopmax) + kkmax = MAX (kk , kkmax ) + !print * ,'ztopmax=', mintime,'mn ',ztop_(mintime), ztopmax + + ! + ! if the solution is going to a stationary phase, exit + IF(mintime > 10) THEN + ! if(mintime > 20) then + ! if( abs(ztop_(mintime)-ztop_(mintime-10)) < DZ ) exit + IF( ABS(ztop_(mintime)-ztop_(mintime-10)) < DELZ_THRESOLD) then + + !- determine W parameter to determine the VMD + do k=2,nm1 + W_VMD(k,imm) = w(k) + enddo + EXIT ! finish the integration + ENDIF + ENDIF -!-- try to find the plume top (above surface height) - kk = 1 - do while (w (kk) .gt. 1.) - kk = kk + 1 - ztop = zm(kk) - !print*,'W=',w (kk) - enddo -! - ztop_(mintime) = ztop - ztopmax = max (ztop, ztopmax) - kkmax = max (kk , kkmax ) - !print * ,'ztopmax=', mintime,'mn ',ztop_(mintime), ztopmax - -! -!srf-27082005 -! if the solution is going to a stationary phase, exit - if(mintime > 10) then - if( abs(ztop_(mintime)-ztop_(mintime-10)) < DZ ) exit - endif if(ilastprint == mintime) then call printout (izprint,nrectotal) @@ -810,6 +917,8 @@ SUBROUTINE LBOUND () ! WC(1) = W(1) + VEL_P(1) = 0. + rad_p(1) = rsurf !SC(1) = SCE(1)+F/1000.*dt ! gas/particle (g/g) @@ -885,6 +994,8 @@ SUBROUTINE INITIAL ( kmt) EST (k) = ES QSAT (k) = (.622 * ES) / (PE (k) - ES) !saturation lwc g/g RHO (k) = 3483.8 * PE (k) / T (k) !dry air density g/m**3 + VEL_P(k) = 0. + rad_p(k) = 0. enddo ! Initialize the entrainment radius, Turner-style plume @@ -892,11 +1003,19 @@ SUBROUTINE INITIAL ( kmt) do k=2,N radius(k) = radius(k-1)+(6./5.)*alpha*(zt(k)-zt(k-1)) enddo +! Initialize the entrainment radius, Turner-style plume + radius(1) = rsurf + rad_p(1) = rsurf + DO k=2,N + radius(k) = radius(k-1)+(6./5.)*alpha*(zt(k)-zt(k-1)) + rad_p(k) = radius(k) + ENDDO ! Initialize the viscosity VISC (1) = VISCOSITY do k=2,N - VISC (k) = VISCOSITY!max(1.e-3,visc(k-1) - 1.* VISCOSITY/float(nkp)) + !VISC (k) = VISCOSITY!max(1.e-3,visc(k-1) - 1.* VISCOSITY/float(nkp)) + VISC (k) = max(1.e-3,visc(k-1) - 1.* VISCOSITY/float(nkp)) enddo !-- Initialize gas/concentration !DO k =10,20 @@ -939,12 +1058,14 @@ subroutine friction(ifrom,nm1,deltak,dt,zt,zm,var1,vart,var2) !nfpt=50 !kf = nm1 - nfpt -kf = nm1 - int(deltak/2) +!kf = nm1 - int(deltak/2) + kf = nm1 - int(deltak) zmkf = zm(kf) !old: float(kf )*dz ztop = zm(nm1) !distim = min(4.*dt,200.) -distim = 60. +!distim = 60. + distim = min(3.*dt,60.) c1 = 1. / (distim * (ztop - zmkf)) c2 = dt * c1 @@ -1112,7 +1233,7 @@ subroutine ENTRAINMENT(m1,w,wt,radius,ALPHA) implicit none integer :: k,m1 real, dimension(m1) :: w,wt,radius -real DMDTM,ALPHA,WBAR,RADIUS_BAR,umgamai +REAL DMDTM,WBAR,RADIUS_BAR,umgamai,DYN_ENTR,ALPHA real, parameter :: mu = 0.15 ,gama = 0.5 ! mass virtual coeff. !- new - Siesbema et al, 2004 @@ -1130,7 +1251,7 @@ subroutine ENTRAINMENT(m1,w,wt,radius,ALPHA) !-- for W: WBAR is only W(k) ! WBAR=0.5*(W(k)+W(k-1)) WBAR=W(k) - RADIUS_BAR = 0.5*(RADIUS(k) + RADIUS(k+1)) + RADIUS_BAR = 0.5*(RADIUS(k) + RADIUS(k-1)) ! orig !DMDTM = 2. * ALPHA * ABS (WBAR) / RADIUS_BAR != (1/M)DM/DT DMDTM = umgamai * 2. * ALPHA * ABS (WBAR) / RADIUS_BAR != (1/M)DM/DT @@ -1138,6 +1259,16 @@ subroutine ENTRAINMENT(m1,w,wt,radius,ALPHA) !-- DMDTM*W(L) entrainment, wt(k) = wt(k) - DMDTM*ABS (WBAR) !print*,'W-ENTR=',k,w(k),- DMDTM*ABS (WBAR) + + !if(VEL_P (k) - VEL_E (k) > 0.) cycle + + !- dynamic entrainment + DYN_ENTR = (2./3.1416)*0.5*ABS (VEL_P(k)-VEL_E(k)+VEL_P(k-1)-VEL_E(k-1)) /RADIUS_BAR + + wt(k) = wt(k) - DYN_ENTR*ABS (WBAR) + + !- entraiment acceleration for output only + !dwdt_entr(k) = - DMDTM*ABS (WBAR)- DYN_ENTR*ABS (WBAR) enddo end subroutine ENTRAINMENT !------------------------------------------------------------------------------- @@ -1230,9 +1361,30 @@ subroutine scl_advectc_plumerise(varn,mzp) call advtndc_plumerise(mzp,QH,scr1(1),QHT,dt) ! endif + !- horizontal wind advection tendency (VEL_T) + scr1=VEL_P + call fa_zc_plumerise(mzp & + ,VEL_P ,scr1 (1) & + ,vt3dc (1) ,vt3df (1) & + ,vt3dg (1) ,vt3dk (1) & + ,vctr1,vctr2 ) - return + call advtndc_plumerise(mzp,VEL_P,scr1(1),VEL_T,dt) + + !- vertical radius transport + scr1=rad_p + call fa_zc_plumerise(mzp & + ,rad_p ,scr1 (1) & + ,vt3dc (1) ,vt3df (1) & + ,vt3dg (1) ,vt3dk (1) & + ,vctr1,vctr2 ) + + call advtndc_plumerise(mzp,rad_p,scr1(1),rad_t,dt) + + + return +! !- gas/particle advection tendency (SCT) ! if(varn == 'SC')return scr1=SC @@ -1319,6 +1471,8 @@ subroutine tend0_plumerise qct(1:nm1) = 0. qht(1:nm1) = 0. qit(1:nm1) = 0. +vel_t(1:nm1) = 0. +rad_t(1:nm1) = 0. !sct(1:nm1) = 0. end subroutine tend0_plumerise @@ -1349,11 +1503,85 @@ subroutine scl_misc(m1) QHT(K) = QHT(K) - DMDTM * ( QH (k) ) QIT(K) = QIT(K) - DMDTM * ( QI (k) ) + !-- tendency horizontal speed = adv + entrainment + VEL_T(K) = VEL_T(K) - DMDTM * ( VEL_P (k) - VEL_E (k) ) + + !-- tendency horizontal speed = adv + entrainment + rad_t(K) = rad_t(K) + 0.5*DMDTM*(6./5.)*RADIUS (k) !-- tendency gas/particle = adv + entrainment ! SCT(K) = SCT(K) - DMDTM * ( SC (k) - SCE (k) ) enddo end subroutine scl_misc +! **************************************************************** + + SUBROUTINE scl_dyn_entrain(m1,nkp,wbar,w,adiabat,alpha,radius,tt,t,te,qvt,qv,qvenv,qct,qc,qht,qh,qit,qi,& + vel_e,vel_p,vel_t,rad_p,rad_t) + implicit none + + INTEGER , INTENT(IN) :: m1 + + ! plumegen_coms + INTEGER , INTENT(IN) :: nkp + REAL , INTENT(INOUT) :: wbar + REAL , INTENT(IN) :: w(nkp) + REAL , INTENT(INOUT) :: adiabat + REAL , INTENT(IN) :: alpha + REAL , INTENT(IN) :: radius(nkp) + REAL , INTENT(INOUT) :: tt(nkp) + REAL , INTENT(IN) :: t(nkp) + REAL , INTENT(IN) :: te(nkp) + REAL , INTENT(INOUT) :: qvt(nkp) + REAL , INTENT(IN) :: qv(nkp) + REAL , INTENT(IN) :: qvenv(nkp) + REAL , INTENT(INOUT) :: qct(nkp) + REAL , INTENT(IN) :: qc(nkp) + REAL , INTENT(INOUT) :: qht(nkp) + REAL , INTENT(IN) :: qh(nkp) + REAL , INTENT(INOUT) :: qit(nkp) + REAL , INTENT(IN) :: qi(nkp) + + REAL , INTENT(IN) :: vel_e(nkp) + REAL , INTENT(IN) :: vel_p(nkp) + REAL , INTENT(INOUT) :: vel_t(nkp) + REAL , INTENT(INOUT) :: rad_T(nkp) + REAL , INTENT(IN) :: rad_p(nkp) + + real, parameter :: g = 9.81, cp=1004., pi=3.1416 + + integer k + real dmdtm + + DO k=2,m1-1 + ! + !-- tendency horizontal radius from dyn entrainment + !rad_t(K) = rad_t(K) + (vel_e(k)-vel_p(k)) /pi + rad_t(K) = rad_t(K) + ABS((vel_e(k)-vel_p(k)))/pi + + !-- entrainment + !DMDTM = (2./3.1416) * (VEL_E (k) - VEL_P (k)) / RADIUS (k) + DMDTM = (2./3.1416) * ABS(VEL_E (k) - VEL_P (k)) / RADIUS (k) + + !-- tendency horizontal speed from dyn entrainment + VEL_T(K) = VEL_T(K) - DMDTM * ( VEL_P (k) - VEL_E (k) ) + + ! if(VEL_P (k) - VEL_E (k) > 0.) cycle + + !-- tendency temperature from dyn entrainment + TT(k) = TT(K) - DMDTM * ( T (k) - TE (k) ) + + !-- tendency water vapor from dyn entrainment + QVT(K) = QVT(K) - DMDTM * ( QV (k) - QVENV (k) ) + + QCT(K) = QCT(K) - DMDTM * ( QC (k) ) + QHT(K) = QHT(K) - DMDTM * ( QH (k) ) + QIT(K) = QIT(K) - DMDTM * ( QI (k) ) + + !-- tendency gas/particle from dyn entrainment + ! SCT(K) = SCT(K) - DMDTM * ( SC (k) - SCE (k) ) + + ENDDO + END SUBROUTINE scl_dyn_entrain ! **************************************************************** @@ -1361,7 +1589,9 @@ subroutine visc_W(m1,deltak,kmt) !use module_zero_plumegen_coms implicit none integer m1,k,deltak,kmt,m2 -real dz1t,dz1m,dz2t,dz2m,d2wdz,d2tdz ,d2qvdz ,d2qhdz ,d2qcdz ,d2qidz ,d2scdz +real dz1t,dz1m,dz2t,dz2m,d2wdz,d2tdz ,d2qvdz ,d2qhdz ,d2qcdz ,d2qidz ,d2scdz, & + d2vel_pdz,d2rad_dz + !srf--- 17/08/2005 !m2=min(m1+deltak,kmt) @@ -1380,6 +1610,8 @@ subroutine visc_W(m1,deltak,kmt) D2QCDZ = (QC (k + 1) - 2 * QC (k) + QC (k - 1) ) * DZ2T D2QIDZ = (QI (k + 1) - 2 * QI (k) + QI (k - 1) ) * DZ2T !D2SCDZ = (SC (k + 1) - 2 * SC (k) + SC (k - 1) ) * DZ2T + d2vel_pdz=(vel_P (k + 1) - 2 * vel_P (k) + vel_P (k - 1) ) * DZ2T + d2rad_dz =(rad_p (k + 1) - 2 * rad_p (k) + rad_p (k - 1) ) * DZ2T WT(k) = WT(k) + D2WDZ TT(k) = TT(k) + D2TDZ @@ -1387,6 +1619,8 @@ subroutine visc_W(m1,deltak,kmt) QCT(k) = QCT(k) + D2QCDZ QHT(k) = QHT(k) + D2QHDZ QIT(k) = QIT(k) + D2QIDZ + vel_t(k) = vel_t(k) + d2vel_pdz + rad_t(k) = rad_t(k) + d2rad_dz !SCT(k) = SCT(k) + D2SCDZ !print*,'W-VISC=',k,D2WDZ enddo @@ -1423,6 +1657,9 @@ subroutine update_plumerise(m1,varn) QC(k) = max(0., QC(k)) QH(k) = max(0., QH(k)) QI(k) = max(0., QI(k)) + + VEL_P(k) = VEL_P(k) + VEL_T(k) * DT + rad_p(k) = rad_p(k) + rad_t(k) * DT ! SC(k) = max(0., SC(k)) enddo diff --git a/wrfv2_fire/chem/module_ctrans_grell.F b/wrfv2_fire/chem/module_ctrans_grell.F index 6531a3ad..32cf3ab1 100755 --- a/wrfv2_fire/chem/module_ctrans_grell.F +++ b/wrfv2_fire/chem/module_ctrans_grell.F @@ -1181,7 +1181,7 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & ! USE module_configure USE module_state_description, only: RADM2SORG,RADM2SORG_AQ,RACMSORG_AQ,RACMSORG_KPP, & RADM2SORG_KPP,RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP, & - RADM2SORG_AQCHEM,RACMSORG_AQCHEM + RADM2SORG_AQCHEM,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP USE module_ctrans_aqchem USE module_input_chem_data, only: get_last_gas implicit none @@ -1380,8 +1380,10 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & ! Aqueous chemistry ! - if ((chemopt .EQ. RADM2SORG .OR. chemopt .EQ. RADM2SORG_AQ .OR. chemopt .EQ. RACMSORG_AQ .OR. chemopt .EQ. RACMSORG_KPP .OR. chemopt .EQ. RADM2SORG_KPP .OR. & - chemopt .EQ. RACM_ESRLSORG_KPP .OR. chemopt .EQ. RACM_SOA_VBS_KPP .OR. chemopt .EQ. RADM2SORG_AQCHEM .OR. chemopt .EQ. RACMSORG_AQCHEM) & + if ((chemopt .EQ. RADM2SORG .OR. chemopt .EQ. RADM2SORG_AQ .OR. chemopt .EQ. RACMSORG_AQ .OR. & + chemopt .EQ. RACMSORG_KPP .OR. chemopt .EQ. RADM2SORG_KPP .OR. chemopt .EQ. RACM_ESRLSORG_KPP .OR. & + chemopt .EQ. RACM_SOA_VBS_KPP .OR. chemopt .EQ. RADM2SORG_AQCHEM .OR. chemopt .EQ. RACMSORG_AQCHEM_KPP .OR. & + chemopt .EQ. RACM_ESRLSORG_AQCHEM_KPP) & .and. (conv_tr_aqchem == 1)) then ! @@ -1600,7 +1602,7 @@ SUBROUTINE cup_dd_tracer(ierr,z_cup,qrcd,tracer,tre_cup,tr_up,tr_dd, & ! Calculate wet deposition with re-evaporation (based on wet scavenging in cup_up_tracer); ! assume no gas takeup by rain during fall for now - do i=its,ite + do i=its,itf IF(ierr(I).eq.0)then @@ -1639,12 +1641,12 @@ SUBROUTINE cup_dd_tracer(ierr,z_cup,qrcd,tracer,tre_cup,tr_up,tr_dd, & ! In downdraft, do only transport of tracers - do i=its,ite + do i=its,itf IF(ierr(I).eq.0)then do nv=1,num_chem - tr_dd(i,jmin(i),nv)=tre_cup(i,jmin(i),nv) ! Tracer amount in downdraft + tr_dd(i,jmin(i):ktf,nv)=tre_cup(i,jmin(i):ktf,nv) ! Tracer amount in downdraft enddo do ki=jmin(i)-1,1,-1 @@ -1663,7 +1665,7 @@ SUBROUTINE cup_dd_tracer(ierr,z_cup,qrcd,tracer,tre_cup,tr_up,tr_dd, & ! Add evaporation from rain water: - do i=its,ite + do i=its,itf IF(ierr(I).eq.0)then do nv=1,num_chem do k=kts,ktf diff --git a/wrfv2_fire/chem/module_data_mgn2mech.F b/wrfv2_fire/chem/module_data_mgn2mech.F index 9b477cc9..0f683100 100644 --- a/wrfv2_fire/chem/module_data_mgn2mech.F +++ b/wrfv2_fire/chem/module_data_mgn2mech.F @@ -61,6 +61,11 @@ MODULE module_data_mgn2mech REAL, DIMENSION (n_megan2saprcnov) :: saprcnov_per_megan DATA p_of_saprcnov / n_megan2saprcnov*non_react / + INTEGER, PARAMETER :: n_megan2crimech = 188 + INTEGER, DIMENSION (n_megan2crimech) :: p_of_megan2crimech, p_of_crimech + REAL, DIMENSION (n_megan2crimech) :: crimech_per_megan + DATA p_of_crimech / n_megan2crimech*non_react / + !-------------------------------------------------------------------- ! Some naming convention in denoting MEGAN species ! _a = alpha , _b = beta , _c = cis , _al = allo , @@ -1105,4 +1110,209 @@ SUBROUTINE get_megan2saprcnov_table p_of_megan2saprcnov(138) = is_hexenyl_act_c3 ; p_of_saprcnov(138) = p_ole2 ; saprcnov_per_megan(138) = 1.000 END SUBROUTINE get_megan2saprcnov_table +!-------------------------------------------------------------------- + + SUBROUTINE get_megan2crimech_table + + ! For MEGAN v2.04 species conversion to crimech species + ! Based on Tan's MAP_CV2crimech.EXT + + ! + ! Index of Index of Molar ratio + ! MEGAN species crimech Species + ! + + p_of_megan2crimech( 1) = is_isoprene ; p_of_crimech( 1) = p_c5h8 ; crimech_per_megan( 1) = 1.000 + p_of_megan2crimech( 2) = is_myrcene ; p_of_crimech( 2) = p_bpinene ; crimech_per_megan( 2) = 1.000 + p_of_megan2crimech( 3) = is_sabinene ; p_of_crimech( 3) = p_bpinene ; crimech_per_megan( 3) = 1.000 + p_of_megan2crimech( 4) = is_limonene ; p_of_crimech( 4) = p_apinene ; crimech_per_megan( 4) = 0.667 + p_of_megan2crimech( 5) = is_limonene ; p_of_crimech( 5) = p_bpinene ; crimech_per_megan( 5) = 0.333 + p_of_megan2crimech( 6) = is_carene_3 ; p_of_crimech( 6) = p_apinene ; crimech_per_megan( 6) = 1.000 + p_of_megan2crimech( 7) = is_ocimene_t_b ; p_of_crimech( 7) = p_bpinene ; crimech_per_megan( 7) = 1.000 + p_of_megan2crimech( 8) = is_pinene_b ; p_of_crimech( 8) = p_apinene ; crimech_per_megan( 8) = 1.000 + p_of_megan2crimech( 9) = is_pinene_a ; p_of_crimech( 9) = p_bpinene ; crimech_per_megan( 9) = 1.000 + p_of_megan2crimech( 10) = is_2met_styrene ; p_of_crimech( 10) = p_apinene ; crimech_per_megan( 10) = 1.000 + p_of_megan2crimech( 11) = is_2met_styrene ; p_of_crimech( 11) = p_bpinene ; crimech_per_megan( 11) = 1.000 + p_of_megan2crimech( 12) = is_cymene_p ; p_of_crimech( 12) = p_toluene ; crimech_per_megan( 12) = 1.500 + p_of_megan2crimech( 13) = is_cymene_o ; p_of_crimech( 13) = p_toluene ; crimech_per_megan( 13) = 1.500 + p_of_megan2crimech( 14) = is_phellandrene_a ; p_of_crimech( 14) = p_apinene ; crimech_per_megan( 14) = 1.000 + p_of_megan2crimech( 15) = is_thujene_a ; p_of_crimech( 15) = p_apinene ; crimech_per_megan( 15) = 1.000 + p_of_megan2crimech( 16) = is_terpinene_a ; p_of_crimech( 16) = p_apinene ; crimech_per_megan( 16) = 1.000 + p_of_megan2crimech( 17) = is_terpinene_g ; p_of_crimech( 17) = p_apinene ; crimech_per_megan( 17) = 1.000 + p_of_megan2crimech( 18) = is_terpinolene ; p_of_crimech( 18) = p_apinene ; crimech_per_megan( 18) = 0.667 + p_of_megan2crimech( 19) = is_terpinolene ; p_of_crimech( 19) = p_bpinene ; crimech_per_megan( 19) = 0.333 + p_of_megan2crimech( 20) = is_phellandrene_b ; p_of_crimech( 20) = p_bpinene ; crimech_per_megan( 20) = 1.000 + p_of_megan2crimech( 21) = is_camphene ; p_of_crimech( 21) = p_bpinene ; crimech_per_megan( 21) = 1.000 + p_of_megan2crimech( 22) = is_bornene ; p_of_crimech( 22) = p_apinene ; crimech_per_megan( 22) = 1.000 + p_of_megan2crimech( 23) = is_fenchene_a ; p_of_crimech( 23) = p_apinene ; crimech_per_megan( 23) = 1.000 + p_of_megan2crimech( 24) = is_ocimene_al ; p_of_crimech( 24) = p_apinene ; crimech_per_megan( 24) = 1.000 + p_of_megan2crimech( 25) = is_ocimene_c_b ; p_of_crimech( 25) = p_bpinene ; crimech_per_megan( 25) = 1.000 + p_of_megan2crimech( 26) = is_tricyclene ; p_of_crimech( 26) = p_apinene ; crimech_per_megan( 26) = 0.667 + p_of_megan2crimech( 27) = is_tricyclene ; p_of_crimech( 27) = p_bpinene ; crimech_per_megan( 27) = 0.333 + p_of_megan2crimech( 28) = is_estragole ; p_of_crimech( 28) = p_apinene ; crimech_per_megan( 28) = 0.667 + p_of_megan2crimech( 29) = is_estragole ; p_of_crimech( 29) = p_bpinene ; crimech_per_megan( 29) = 0.333 + p_of_megan2crimech( 30) = is_camphor ; p_of_crimech( 30) = p_c5h8 ; crimech_per_megan( 30) = 2.000 + p_of_megan2crimech( 31) = is_fenchone ; p_of_crimech( 31) = p_apinene ; crimech_per_megan( 31) = 0.667 + p_of_megan2crimech( 32) = is_fenchone ; p_of_crimech( 32) = p_bpinene ; crimech_per_megan( 32) = 0.333 + p_of_megan2crimech( 33) = is_piperitone ; p_of_crimech( 33) = p_apinene ; crimech_per_megan( 33) = 1.000 + p_of_megan2crimech( 34) = is_thujone_a ; p_of_crimech( 34) = p_apinene ; crimech_per_megan( 34) = 1.000 + p_of_megan2crimech( 35) = is_thujone_b ; p_of_crimech( 35) = p_bpinene ; crimech_per_megan( 35) = 1.000 + p_of_megan2crimech( 36) = is_cineole_1_8 ; p_of_crimech( 36) = p_c5h8 ; crimech_per_megan( 36) = 2.000 + p_of_megan2crimech( 37) = is_borneol ; p_of_crimech( 37) = p_c5h8 ; crimech_per_megan( 37) = 2.000 + p_of_megan2crimech( 38) = is_linalool ; p_of_crimech( 38) = p_apinene ; crimech_per_megan( 38) = 0.667 + p_of_megan2crimech( 39) = is_linalool ; p_of_crimech( 39) = p_bpinene ; crimech_per_megan( 39) = 0.333 + p_of_megan2crimech( 40) = is_terpineol_4 ; p_of_crimech( 40) = p_apinene ; crimech_per_megan( 40) = 1.000 + p_of_megan2crimech( 41) = is_terpineol_a ; p_of_crimech( 41) = p_apinene ; crimech_per_megan( 41) = 1.000 + p_of_megan2crimech( 42) = is_linalool_oxd_c ; p_of_crimech( 42) = p_apinene ; crimech_per_megan( 42) = 0.833 + p_of_megan2crimech( 43) = is_linalool_oxd_c ; p_of_crimech( 43) = p_bpinene ; crimech_per_megan( 43) = 0.416 + p_of_megan2crimech( 44) = is_linalool_oxd_t ; p_of_crimech( 44) = p_apinene ; crimech_per_megan( 44) = 0.833 + p_of_megan2crimech( 45) = is_linalool_oxd_t ; p_of_crimech( 45) = p_bpinene ; crimech_per_megan( 45) = 0.416 + p_of_megan2crimech( 46) = is_ionone_b ; p_of_crimech( 46) = p_apinene ; crimech_per_megan( 46) = 0.934 + p_of_megan2crimech( 47) = is_ionone_b ; p_of_crimech( 47) = p_bpinene ; crimech_per_megan( 47) = 0.462 + p_of_megan2crimech( 48) = is_bornyl_act ; p_of_crimech( 48) = p_apinene ; crimech_per_megan( 48) = 0.667 + p_of_megan2crimech( 49) = is_bornyl_act ; p_of_crimech( 49) = p_bpinene ; crimech_per_megan( 49) = 0.333 + p_of_megan2crimech( 50) = is_farnescene_a ; p_of_crimech( 50) = p_apinene ; crimech_per_megan( 50) = 1.500 + p_of_megan2crimech( 51) = is_caryophyllene_b ; p_of_crimech( 51) = p_apinene ; crimech_per_megan( 51) = 1.000 + p_of_megan2crimech( 52) = is_caryophyllene_b ; p_of_crimech( 52) = p_bpinene ; crimech_per_megan( 52) = 0.500 + p_of_megan2crimech( 53) = is_acoradiene ; p_of_crimech( 53) = p_apinene ; crimech_per_megan( 53) = 1.000 + p_of_megan2crimech( 54) = is_acoradiene ; p_of_crimech( 54) = p_bpinene ; crimech_per_megan( 54) = 0.500 + p_of_megan2crimech( 55) = is_aromadendrene ; p_of_crimech( 55) = p_apinene ; crimech_per_megan( 55) = 1.000 + p_of_megan2crimech( 56) = is_aromadendrene ; p_of_crimech( 56) = p_bpinene ; crimech_per_megan( 56) = 0.500 + p_of_megan2crimech( 57) = is_bergamotene_a ; p_of_crimech( 57) = p_apinene ; crimech_per_megan( 57) = 1.500 + p_of_megan2crimech( 58) = is_bergamotene_b ; p_of_crimech( 58) = p_bpinene ; crimech_per_megan( 58) = 1.500 + p_of_megan2crimech( 59) = is_bisabolene_a ; p_of_crimech( 59) = p_apinene ; crimech_per_megan( 59) = 1.500 + p_of_megan2crimech( 60) = is_bisabolene_b ; p_of_crimech( 60) = p_bpinene ; crimech_per_megan( 60) = 1.500 + p_of_megan2crimech( 61) = is_bourbonene_b ; p_of_crimech( 61) = p_apinene ; crimech_per_megan( 61) = 1.000 + p_of_megan2crimech( 62) = is_bourbonene_b ; p_of_crimech( 62) = p_bpinene ; crimech_per_megan( 62) = 0.500 + p_of_megan2crimech( 63) = is_cadinene_d ; p_of_crimech( 63) = p_apinene ; crimech_per_megan( 63) = 1.000 + p_of_megan2crimech( 64) = is_cadinene_d ; p_of_crimech( 64) = p_bpinene ; crimech_per_megan( 64) = 0.500 + p_of_megan2crimech( 65) = is_cadinene_g ; p_of_crimech( 65) = p_apinene ; crimech_per_megan( 65) = 1.000 + p_of_megan2crimech( 66) = is_cadinene_g ; p_of_crimech( 66) = p_bpinene ; crimech_per_megan( 66) = 1.500 + p_of_megan2crimech( 67) = is_cedrene_a ; p_of_crimech( 67) = p_apinene ; crimech_per_megan( 67) = 1.000 + p_of_megan2crimech( 68) = is_cedrene_a ; p_of_crimech( 68) = p_bpinene ; crimech_per_megan( 68) = 0.500 + p_of_megan2crimech( 69) = is_copaene_a ; p_of_crimech( 69) = p_apinene ; crimech_per_megan( 69) = 1.000 + p_of_megan2crimech( 70) = is_copaene_a ; p_of_crimech( 70) = p_bpinene ; crimech_per_megan( 70) = 0.500 + p_of_megan2crimech( 71) = is_cubebene_a ; p_of_crimech( 71) = p_apinene ; crimech_per_megan( 71) = 1.000 + p_of_megan2crimech( 72) = is_cubebene_a ; p_of_crimech( 72) = p_bpinene ; crimech_per_megan( 72) = 0.500 + p_of_megan2crimech( 73) = is_cubebene_b ; p_of_crimech( 73) = p_apinene ; crimech_per_megan( 73) = 1.000 + p_of_megan2crimech( 74) = is_cubebene_b ; p_of_crimech( 74) = p_bpinene ; crimech_per_megan( 74) = 0.500 + p_of_megan2crimech( 75) = is_elemene_b ; p_of_crimech( 75) = p_apinene ; crimech_per_megan( 75) = 1.000 + p_of_megan2crimech( 76) = is_elemene_b ; p_of_crimech( 76) = p_bpinene ; crimech_per_megan( 76) = 0.500 + p_of_megan2crimech( 77) = is_farnescene_b ; p_of_crimech( 77) = p_apinene ; crimech_per_megan( 77) = 1.000 + p_of_megan2crimech( 78) = is_farnescene_b ; p_of_crimech( 78) = p_bpinene ; crimech_per_megan( 78) = 0.500 + p_of_megan2crimech( 79) = is_germacrene_b ; p_of_crimech( 79) = p_apinene ; crimech_per_megan( 79) = 1.000 + p_of_megan2crimech( 80) = is_germacrene_b ; p_of_crimech( 80) = p_bpinene ; crimech_per_megan( 80) = 0.500 + p_of_megan2crimech( 81) = is_germacrene_d ; p_of_crimech( 81) = p_apinene ; crimech_per_megan( 81) = 1.000 + p_of_megan2crimech( 82) = is_germacrene_d ; p_of_crimech( 82) = p_bpinene ; crimech_per_megan( 82) = 0.500 + p_of_megan2crimech( 83) = is_gurjunene_b ; p_of_crimech( 83) = p_apinene ; crimech_per_megan( 83) = 1.000 + p_of_megan2crimech( 84) = is_gurjunene_b ; p_of_crimech( 84) = p_bpinene ; crimech_per_megan( 84) = 0.500 + p_of_megan2crimech( 85) = is_humulene_a ; p_of_crimech( 85) = p_apinene ; crimech_per_megan( 85) = 1.000 + p_of_megan2crimech( 86) = is_humulene_a ; p_of_crimech( 86) = p_bpinene ; crimech_per_megan( 86) = 0.500 + p_of_megan2crimech( 87) = is_humulene_g ; p_of_crimech( 87) = p_apinene ; crimech_per_megan( 87) = 1.000 + p_of_megan2crimech( 88) = is_humulene_g ; p_of_crimech( 88) = p_bpinene ; crimech_per_megan( 88) = 0.500 + p_of_megan2crimech( 89) = is_isolongifolene ; p_of_crimech( 89) = p_apinene ; crimech_per_megan( 89) = 1.000 + p_of_megan2crimech( 90) = is_isolongifolene ; p_of_crimech( 90) = p_bpinene ; crimech_per_megan( 90) = 0.500 + p_of_megan2crimech( 91) = is_longifolene ; p_of_crimech( 91) = p_apinene ; crimech_per_megan( 91) = 1.000 + p_of_megan2crimech( 92) = is_longifolene ; p_of_crimech( 92) = p_bpinene ; crimech_per_megan( 92) = 0.500 + p_of_megan2crimech( 93) = is_longipinene ; p_of_crimech( 93) = p_apinene ; crimech_per_megan( 93) = 1.000 + p_of_megan2crimech( 94) = is_longipinene ; p_of_crimech( 94) = p_bpinene ; crimech_per_megan( 94) = 0.500 + p_of_megan2crimech( 95) = is_muurolene_a ; p_of_crimech( 95) = p_apinene ; crimech_per_megan( 95) = 1.000 + p_of_megan2crimech( 96) = is_muurolene_a ; p_of_crimech( 96) = p_bpinene ; crimech_per_megan( 96) = 0.500 + p_of_megan2crimech( 97) = is_muurolene_g ; p_of_crimech( 97) = p_apinene ; crimech_per_megan( 97) = 1.000 + p_of_megan2crimech( 98) = is_muurolene_g ; p_of_crimech( 98) = p_bpinene ; crimech_per_megan( 98) = 0.500 + p_of_megan2crimech( 99) = is_selinene_b ; p_of_crimech( 99) = p_apinene ; crimech_per_megan( 99) = 1.000 + p_of_megan2crimech(100) = is_selinene_b ; p_of_crimech(100) = p_bpinene ; crimech_per_megan(100) = 0.500 + p_of_megan2crimech(101) = is_selinene_d ; p_of_crimech(101) = p_apinene ; crimech_per_megan(101) = 1.000 + p_of_megan2crimech(102) = is_selinene_d ; p_of_crimech(102) = p_bpinene ; crimech_per_megan(102) = 0.500 + p_of_megan2crimech(103) = is_nerolidol_c ; p_of_crimech(103) = p_apinene ; crimech_per_megan(103) = 1.000 + p_of_megan2crimech(104) = is_nerolidol_c ; p_of_crimech(104) = p_bpinene ; crimech_per_megan(104) = 0.500 + p_of_megan2crimech(105) = is_nerolidol_t ; p_of_crimech(105) = p_apinene ; crimech_per_megan(105) = 1.000 + p_of_megan2crimech(106) = is_nerolidol_t ; p_of_crimech(106) = p_bpinene ; crimech_per_megan(106) = 0.500 + p_of_megan2crimech(107) = is_cedrol ; p_of_crimech(107) = p_c5h8 ; crimech_per_megan(107) = 3.000 + p_of_megan2crimech(108) = is_mbo_2m3e2ol ; p_of_crimech(108) = p_c5h8 ; crimech_per_megan(108) = 2.400 + p_of_megan2crimech(109) = is_methanol ; p_of_crimech(109) = p_ch3oh ; crimech_per_megan(109) = 1.000 + p_of_megan2crimech(110) = is_acetone ; p_of_crimech(110) = p_ket ; crimech_per_megan(110) = 1.000 + p_of_megan2crimech(111) = is_methane ; p_of_crimech(111) = p_ch4 ; crimech_per_megan(111) = 1.000 + p_of_megan2crimech(112) = is_ammonia ; p_of_crimech(112) = p_nh3 ; crimech_per_megan(112) = 1.000 + p_of_megan2crimech(113) = is_nitrous_oxd ; p_of_crimech(113) = p_no2 ; crimech_per_megan(113) = 1.000 + p_of_megan2crimech(114) = is_nitric_oxd ; p_of_crimech(114) = p_no ; crimech_per_megan(114) = 1.000 + p_of_megan2crimech(115) = is_acetaldehyde ; p_of_crimech(115) = p_ch3cho ; crimech_per_megan(115) = 1.000 + p_of_megan2crimech(116) = is_ethanol ; p_of_crimech(116) = p_c2h5oh ; crimech_per_megan(116) = 1.000 + p_of_megan2crimech(117) = is_formic_acid ; p_of_crimech(117) = p_hcooh ; crimech_per_megan(117) = 1.000 + p_of_megan2crimech(118) = is_formaldehyde ; p_of_crimech(118) = p_hcho ; crimech_per_megan(118) = 1.000 + p_of_megan2crimech(119) = is_acetic_acid ; p_of_crimech(119) = p_ch3co2h ; crimech_per_megan(119) = 1.000 + p_of_megan2crimech(120) = is_mbo_3m2e1ol ; p_of_crimech(120) = p_c5h8 ; crimech_per_megan(120) = 1.260 + p_of_megan2crimech(121) = is_mbo_3m3e1ol ; p_of_crimech(121) = p_c5h8 ; crimech_per_megan(121) = 1.260 + p_of_megan2crimech(122) = is_benzaldehyde ; p_of_crimech(122) = p_benzene ; crimech_per_megan(122) = 0.883 + p_of_megan2crimech(123) = is_butanone_2 ; p_of_crimech(123) = p_mek ; crimech_per_megan(123) = 1.000 + p_of_megan2crimech(124) = is_decanal ; p_of_crimech(124) = p_c2h5cho ; crimech_per_megan(124) = 2.690 + p_of_megan2crimech(125) = is_dodecene_1 ; p_of_crimech(125) = p_tbut2ene; crimech_per_megan(125) = 3.000 + p_of_megan2crimech(126) = is_geranyl_acetone ; p_of_crimech(126) = p_apinene ; crimech_per_megan(126) = 1.400 + p_of_megan2crimech(127) = is_geranyl_acetone ; p_of_crimech(127) = p_bpinene ; crimech_per_megan(127) = 1.400 + p_of_megan2crimech(128) = is_heptanal ; p_of_crimech(128) = p_c2h5cho ; crimech_per_megan(128) = 1.966 + p_of_megan2crimech(129) = is_heptane ; p_of_crimech(129) = p_nc4h10 ; crimech_per_megan(129) = 1.724 + p_of_megan2crimech(130) = is_hexane ; p_of_crimech(130) = p_nc4h10 ; crimech_per_megan(130) = 1.483 + p_of_megan2crimech(131) = is_met_benzoate ; p_of_crimech(131) = p_toluene ; crimech_per_megan(131) = 1.478 + p_of_megan2crimech(132) = is_met_heptenone ; p_of_crimech(132) = p_tbut2ene; crimech_per_megan(132) = 3.000 + p_of_megan2crimech(133) = is_neryl_acetone ; p_of_crimech(133) = p_ket ; crimech_per_megan(133) = 3.379 + p_of_megan2crimech(134) = is_nonanal ; p_of_crimech(134) = p_c2h5cho ; crimech_per_megan(134) = 2.448 + p_of_megan2crimech(135) = is_nonenal ; p_of_crimech(135) = p_nc4h10 ; crimech_per_megan(135) = 2.413 + p_of_megan2crimech(136) = is_nonenal ; p_of_crimech(136) = p_c2h5cho ; crimech_per_megan(136) = 2.413 + p_of_megan2crimech(137) = is_octanal ; p_of_crimech(137) = p_c2h5cho ; crimech_per_megan(137) = 2.207 + p_of_megan2crimech(138) = is_octanol ; p_of_crimech(138) = p_hc8 ; crimech_per_megan(138) = 2.207 + p_of_megan2crimech(139) = is_octenol_1e3ol ; p_of_crimech(139) = p_tbut2ene; crimech_per_megan(139) = 2.286 + p_of_megan2crimech(140) = is_oxopentanal ; p_of_crimech(140) = p_mek ; crimech_per_megan(140) = 1.400 + p_of_megan2crimech(141) = is_pentane ; p_of_crimech(141) = p_nc4h10 ; crimech_per_megan(141) = 1.241 + p_of_megan2crimech(142) = is_phenyl_cco ; p_of_crimech(142) = p_toluene ; crimech_per_megan(142) = 1.300 + p_of_megan2crimech(143) = is_pyruvic_acid ; p_of_crimech(143) = p_ch3co2h ; crimech_per_megan(143) = 1.158 + p_of_megan2crimech(144) = is_terpinyl_act_a ; p_of_crimech(144) = p_apinene ; crimech_per_megan(144) = 0.934 + p_of_megan2crimech(145) = is_terpinyl_act_a ; p_of_crimech(145) = p_bpinene ; crimech_per_megan(145) = 0.466 + p_of_megan2crimech(146) = is_tetradecene_1 ; p_of_crimech(146) = p_tbut2ene; crimech_per_megan(146) = 3.500 + p_of_megan2crimech(147) = is_toluene ; p_of_crimech(147) = p_toluene ; crimech_per_megan(147) = 1.000 + p_of_megan2crimech(148) = is_carbon_monoxide ; p_of_crimech(148) = p_co ; crimech_per_megan(148) = 1.000 + p_of_megan2crimech(149) = is_butene ; p_of_crimech(149) = p_tbut2ene; crimech_per_megan(149) = 1.000 + p_of_megan2crimech(150) = is_ethane ; p_of_crimech(150) = p_c2h6 ; crimech_per_megan(150) = 1.000 + p_of_megan2crimech(151) = is_ethene ; p_of_crimech(151) = p_c2h4 ; crimech_per_megan(151) = 1.000 + p_of_megan2crimech(152) = is_hydrogen_cyanide ; p_of_crimech(152) = non_react ; crimech_per_megan(152) = 1.000 + p_of_megan2crimech(153) = is_propane ; p_of_crimech(153) = p_c3h8 ; crimech_per_megan(153) = 1.000 + p_of_megan2crimech(154) = is_propene ; p_of_crimech(154) = p_c3h6 ; crimech_per_megan(154) = 1.000 + p_of_megan2crimech(155) = is_carbon_2s ; p_of_crimech(155) = non_react ; crimech_per_megan(155) = 1.000 + p_of_megan2crimech(156) = is_carbonyl_s ; p_of_crimech(156) = non_react ; crimech_per_megan(156) = 1.000 + p_of_megan2crimech(157) = is_diallyl_2s ; p_of_crimech(157) = p_tbut2ene; crimech_per_megan(157) = 0.660 + p_of_megan2crimech(158) = is_diallyl_2s ; p_of_crimech(158) = p_so2 ; crimech_per_megan(158) = 2.000 + p_of_megan2crimech(159) = is_2met_2s ; p_of_crimech(159) = p_c2h6 ; crimech_per_megan(159) = 1.000 + p_of_megan2crimech(160) = is_2met_2s ; p_of_crimech(160) = p_so2 ; crimech_per_megan(160) = 2.000 + p_of_megan2crimech(161) = is_2met_s ; p_of_crimech(161) = p_c2h6 ; crimech_per_megan(161) = 1.000 + p_of_megan2crimech(162) = is_2met_s ; p_of_crimech(162) = p_so2 ; crimech_per_megan(162) = 1.000 + p_of_megan2crimech(163) = is_met_chloride ; p_of_crimech(163) = non_react ; crimech_per_megan(163) = 1.000 + p_of_megan2crimech(164) = is_met_bromide ; p_of_crimech(164) = non_react ; crimech_per_megan(164) = 1.000 + p_of_megan2crimech(165) = is_met_iodide ; p_of_crimech(165) = non_react ; crimech_per_megan(165) = 1.000 + p_of_megan2crimech(166) = is_hydrogen_s ; p_of_crimech(166) = p_so2 ; crimech_per_megan(166) = 1.000 + p_of_megan2crimech(167) = is_met_mercaptan ; p_of_crimech(167) = p_ch4 ; crimech_per_megan(167) = 1.000 + p_of_megan2crimech(168) = is_met_mercaptan ; p_of_crimech(168) = p_so2 ; crimech_per_megan(168) = 1.000 + p_of_megan2crimech(169) = is_met_propenyl_2s ; p_of_crimech(169) = p_c3h6 ; crimech_per_megan(169) = 2.800 + p_of_megan2crimech(170) = is_met_propenyl_2s ; p_of_crimech(170) = p_so2 ; crimech_per_megan(170) = 2.000 + p_of_megan2crimech(171) = is_pppp_2s ; p_of_crimech(171) = p_c3h6 ; crimech_per_megan(171) = 3.500 + p_of_megan2crimech(172) = is_pppp_2s ; p_of_crimech(172) = p_so2 ; crimech_per_megan(172) = 1.800 + p_of_megan2crimech(173) = is_2met_nonatriene ; p_of_crimech(173) = p_apinene ; crimech_per_megan(173) = 0.667 + p_of_megan2crimech(174) = is_2met_nonatriene ; p_of_crimech(174) = p_bpinene ; crimech_per_megan(174) = 0.333 + p_of_megan2crimech(175) = is_met_salicylate ; p_of_crimech(175) = p_toluene ; crimech_per_megan(175) = 1.652 + p_of_megan2crimech(176) = is_indole ; p_of_crimech(176) = p_toluene ; crimech_per_megan(176) = 1.200 + p_of_megan2crimech(177) = is_indole ; p_of_crimech(177) = p_hno3 ; crimech_per_megan(177) = 1.000 + p_of_megan2crimech(178) = is_jasmone ; p_of_crimech(178) = p_apinene ; crimech_per_megan(178) = 0.804 + p_of_megan2crimech(179) = is_jasmone ; p_of_crimech(179) = p_bpinene ; crimech_per_megan(179) = 0.402 + p_of_megan2crimech(180) = is_met_jasmonate ; p_of_crimech(180) = p_apinene ; crimech_per_megan(180) = 1.098 + p_of_megan2crimech(181) = is_met_jasmonate ; p_of_crimech(181) = p_bpinene ; crimech_per_megan(181) = 0.548 + p_of_megan2crimech(182) = is_3met_3dctt ; p_of_crimech(182) = p_tbut2ene; crimech_per_megan(182) = 3.893 + p_of_megan2crimech(183) = is_hexanal ; p_of_crimech(183) = p_c2h5cho ; crimech_per_megan(183) = 1.720 + p_of_megan2crimech(184) = is_hexanol_1 ; p_of_crimech(184) = p_nc4h10 ; crimech_per_megan(184) = 1.759 + p_of_megan2crimech(185) = is_hexenal_c3 ; p_of_crimech(185) = p_tbut2ene; crimech_per_megan(185) = 1.750 + p_of_megan2crimech(186) = is_hexenal_t2 ; p_of_crimech(186) = p_tbut2ene; crimech_per_megan(186) = 1.750 + p_of_megan2crimech(187) = is_hexenol_c3 ; p_of_crimech(187) = p_tbut2ene; crimech_per_megan(187) = 1.786 + p_of_megan2crimech(188) = is_hexenyl_act_c3 ; p_of_crimech(188) = p_tbut2ene; crimech_per_megan(188) = 2.536 + + END SUBROUTINE get_megan2crimech_table + + + END MODULE module_data_mgn2mech diff --git a/wrfv2_fire/chem/module_data_mosaic_other.F b/wrfv2_fire/chem/module_data_mosaic_other.F index 37b8458f..d83889e9 100644 --- a/wrfv2_fire/chem/module_data_mosaic_other.F +++ b/wrfv2_fire/chem/module_data_mosaic_other.F @@ -36,6 +36,8 @@ module module_data_mosaic_other integer, save :: kh2so4 = -999888777 integer, save :: knh3 = -999888777 integer, save :: khcl = -999888777 + integer, save :: kn2o5 = -999888777 + integer, save :: kclno2 = -999888777 integer, save :: ko3 = -999888777 integer, save :: kh2o = -999888777 integer, save :: ktemp = -999888777 diff --git a/wrfv2_fire/chem/module_data_mosaic_therm.F b/wrfv2_fire/chem/module_data_mosaic_therm.F index d7e2f222..4324b53f 100644 --- a/wrfv2_fire/chem/module_data_mosaic_therm.F +++ b/wrfv2_fire/chem/module_data_mosaic_therm.F @@ -40,12 +40,13 @@ module module_data_mosaic_therm ! mosaic-specific parameters ! Alma added 2 smp species - just before the traditional ant1_c ! SOA is treated using a simplified approach for anthropogenic and biomass burning species based on Hodzic and Jimenez, GMD, 2011 - integer ngas_ioa, ngas_soa, ngas_volatile, & + integer ngas_ioa, ngas_soa, ngas_volatile, ngas_het, & naer, naercomp, nelectrolyte, nsalt, & nsoluble, ncation, nanion parameter(ngas_ioa = 5) ! inorganic volatile aerosol species that have a gaseous counterpart parameter(ngas_soa = 68+2+16) ! volatile soa species that have a gaseous counterpart parameter(ngas_volatile = ngas_ioa + ngas_soa) + parameter(ngas_het = 2) ! gas species only involved in heterogeneous reactions ! DL - 9/9/2011 parameter(naer = 11+68+2+16) ! num of chemical species per bin (inorg + oc + bc + oin + soa) parameter(naercomp = 26+68+2+16) ! num of electrolytes + oc, bc, oin, & soa parameter(nelectrolyte = 22) ! num of electrolytes @@ -99,7 +100,7 @@ module module_data_mosaic_therm ! gas integer, save :: & ih2so4_g, ihno3_g, ihcl_g, inh3_g, & - imsa_g + imsa_g, in2o5_g, iclno2_g integer, save :: & ipcg1_b_c_g,ipcg2_b_c_g,ipcg3_b_c_g,ipcg4_b_c_g, & @@ -222,7 +223,8 @@ module module_data_mosaic_therm jhyst_leg(nbin_a_maxd), & ! hysteresis leg: jhyst_up, jhyst_lo iprint_input, & ! flag: mon, moff lunerr_aer, & ! - ncorecnt_aer ! + ncorecnt_aer, & ! + n2o5_flag ! flag to control N2O5 het chem (0=off, 1=no Cl pathway, 2=full) ! NOTE: Some of the following informational output defaults are overridden in ! module_mosaic_driver.F based on the internal MOSAIC debug_level setting. @@ -273,14 +275,14 @@ module module_data_mosaic_therm electrolyte(nelectrolyte,3,nbin_a_maxd), & ! nmol/m^3 electrolyte_sum(nelectrolyte,nbin_a_maxd), & ! nmol/m^3 epercent(nelectrolyte,3,nbin_a_maxd), & ! % - gas(ngas_volatile), & ! nmol/m^3 + gas(ngas_volatile+ngas_het), & ! nmol/m^3 ah2o, & ! - ah2o_a(nbin_a_maxd), & ! - dpmv(nbin_a_maxd), & ! volume_a(nbin_a_maxd), & ! volume_bin(nbin_a_maxd), & ! dry volume of one particle kelvin(nbin_a_maxd), & ! kelvin factor - kel(ngas_volatile,nbin_a_maxd), & ! kelvin factor for condensing species + kel(ngas_volatile+ngas_het,nbin_a_maxd), & ! kelvin factor for condensing species kelvin_nh4no3, & ! - kelvin_nh4cl, & ! - total_species(ngas_volatile) ! @@ -310,7 +312,7 @@ module module_data_mosaic_therm x_soa(naer), & ! soa mole fraction sfc_a(ngas_volatile), & ! nmol/m^3 Heff(ngas_volatile,nbin_a_maxd), & ! - kg(ngas_volatile,nbin_a_maxd), & ! 1/s + kg(ngas_volatile+ngas_het,nbin_a_maxd), & ! 1/s fraceq(ngas_volatile,nbin_a_maxd), & ! 1/s df_gas_s(ngas_volatile,nbin_a_maxd), & ! nmol/m^3 (g-g*) = driving force) df_gas_l(ngas_volatile,nbin_a_maxd), & ! nmol/m^3 (g-g*) = driving force) @@ -323,6 +325,7 @@ module module_data_mosaic_therm sumkg_nh3, & ! 1/s sumkg_hno3, & ! 1/s sumkg_hcl, & ! 1/s + sumkg_n2o5, & ! 1/s delta_nh3_max(nbin_a_maxd), & ! nmol/m^3 delta_hno3_max(nbin_a_maxd), & ! nmol/m^3 delta_hcl_max(nbin_a_maxd), & ! nmol/m^3 @@ -387,7 +390,7 @@ module module_data_mosaic_therm character(len=8), save :: & ename(nelectrolyte), & ! electrolyte names aer_name(naer), & ! generic aerosol species name - gas_name(ngas_volatile) ! gas species name + gas_name(ngas_volatile+ngas_het) ! gas species name character(len=6), save :: & phasestate(4) @@ -411,7 +414,7 @@ module module_data_mosaic_therm dens_electrolyte(nelectrolyte), & ! g/cc dens_aer_mac(naer), & ! g/cc dens_comp_a(naercomp), & ! g/cc (density of compounds) - partial_molar_vol(ngas_volatile), & ! cc/mol + partial_molar_vol(ngas_volatile+ngas_het), & ! cc/mol sigma_water, & ! water surface tension (n/m) sigma_soln(nbin_a_maxd), & ! solution surface tension (n/m) keq_gl(nrxn_aer_gl), & ! gas-liq eqblm const @@ -422,8 +425,8 @@ module module_data_mosaic_therm kp_nh4no3, & ! kp_nh4no3_0, & ! kp_nh4cl, & ! - kp_nh4cl_0 ! - + kp_nh4cl_0, & ! + frac_n2o5_h2o(nbin_a_maxd) ! fraction of N2O5 which reacts with H2O after heterogeneous uptake complex, save :: & ref_index_a(naercomp), & ! refractive index of compounds diff --git a/wrfv2_fire/chem/module_dep_simple.F b/wrfv2_fire/chem/module_dep_simple.F index 4c4e9b53..0af69ffd 100755 --- a/wrfv2_fire/chem/module_dep_simple.F +++ b/wrfv2_fire/chem/module_dep_simple.F @@ -484,6 +484,138 @@ SUBROUTINE wesely_driver( id, ktau, dtstep, config_flags, current_month, & end do end if + +!----------------------------------------------------------- +! For CRI +!----------------------------------------------------------- + if( config_flags%chem_opt == crimech_kpp .or. & + config_flags%chem_opt == cri_mosaic_8bin_aq_kpp .or. & + config_flags%chem_opt == cri_mosaic_4bin_aq_kpp ) then + do j=jts,jte + do i=its,ite +! need to add deposition rates for crimech species here + + ddvel(i,j,p_ch3co2h) = 0. + ddvel(i,j,p_clno2) = 0. + !ddvel(i,j,p_n2o5 ) = 0. + !ddvel(i,j,p_o1d) = 0. + !ddvel(i,j,p_o3p) = 0. + ddvel(i,j,p_c2h6) = 0. + ddvel(i,j,p_aco3) = 0. + !ddvel(i,j,p_ch3oo) = 0. + ddvel(i,j,p_hso3) = 0. + ddvel(i,j,p_so3) = 0. + ddvel(i,j,p_c3h8) = 0. + ddvel(i,j,p_nc4h10) = 0. + ddvel(i,j,p_c5h8) = 0. + ddvel(i,j,p_benzene) = 0. + ddvel(i,j,p_toluene) = 0. + ddvel(i,j,p_oxyl) = 0. + ddvel(i,j,p_npropol) = 0. + ddvel(i,j,p_c2h2) = 0. + ddvel(i,j,p_c3h6) = 0. + ddvel(i,j,p_c2h4) = 0. + ddvel(i,j,p_tbut2ene) = 0. + ddvel(i,j,p_mek) = 0. + ddvel(i,j,p_ipropol) = 0. + ddvel(i,j,p_apinene) = 0. + ddvel(i,j,p_bpinene) = 0. + !ddvel(i,j,p_c2h5co3) = 0. + !ddvel(i,j,p_hoch2co3) = 0. + ddvel(i,j,p_ch3cl) = 0. + ddvel(i,j,p_ch2cl2) = 0. + ddvel(i,j,p_chcl3) = 0. + ddvel(i,j,p_ch3ccl3) = 0. + ddvel(i,j,p_cdicleth) = 0. + ddvel(i,j,p_tdicleth) = 0. + ddvel(i,j,p_tricleth ) = 0. + ddvel(i,j,p_tce) = 0. + ddvel(i,j,p_noa) = 0. + ddvel(i,j,p_aroh14) = 0. + ddvel(i,j,p_raroh14) = 0. + ddvel(i,j,p_arnoh14) = 0. + ddvel(i,j,p_aroh17) = 0. + ddvel(i,j,p_raroh17) = 0. + ddvel(i,j,p_arnoh17) = 0. + ddvel(i,j,p_anhy) = 0. + ddvel(i,j,p_ch4) = 0. + ddvel(i,j,p_sulf) = ddvel(i,j,p_hno3) + ddvel(i,j,p_hcl) = ddvel(i,j,p_hno3) + ddvel(i,j,p_h2) = 0. + ddvel(i,j,p_tm123b) = 0. + ddvel(i,j,p_tm124b) = 0. + ddvel(i,j,p_tm135b) = 0. + ddvel(i,j,p_oethtol) = 0. + ddvel(i,j,p_methtol) = 0. + ddvel(i,j,p_pethtol) = 0. + ddvel(i,j,p_dime35eb) = 0. + ddvel(i,j,p_dms) = 0. + ddvel(i,j,p_ch3sch2oo) = 0. + ddvel(i,j,p_dmso) = 0. + ddvel(i,j,p_ch3s) = 0. + ddvel(i,j,p_ch3so) = 0. + ddvel(i,j,p_ch3so3) = 0. + ddvel(i,j,p_msa) = 0. + ddvel(i,j,p_msia) = 0. + ddvel(i,j,p_ho) = 0. + ddvel(i,j,p_ho2) = 0. + ddvel(i,j,p_ch3oo) = 0. + ddvel(i,j,p_c2h5o2) = 0. + ddvel(i,j,p_hoch2ch2o2) = 0. + ddvel(i,j,p_ic3h7o2) = 0. + ddvel(i,j,p_rn10o2) = 0. + ddvel(i,j,p_rn13o2) = 0. + ddvel(i,j,p_rn16o2) = 0. + ddvel(i,j,p_rn19o2) = 0. + ddvel(i,j,p_rn9o2) = 0. + ddvel(i,j,p_rn12o2) = 0. + ddvel(i,j,p_rn15o2) = 0. + ddvel(i,j,p_rn18o2) = 0. + ddvel(i,j,p_nrn6o2) = 0. + ddvel(i,j,p_nrn9o2) = 0. + ddvel(i,j,p_nrn12o2) = 0. + ddvel(i,j,p_rn11o2) = 0. + ddvel(i,j,p_rn14o2) = 0. + ddvel(i,j,p_rn8o2) = 0. + ddvel(i,j,p_rn17o2) = 0. + ddvel(i,j,p_rn13ao2) = 0. + ddvel(i,j,p_rn16ao2) = 0. + ddvel(i,j,p_rn15ao2) = 0. + ddvel(i,j,p_rn18ao2) = 0. + ddvel(i,j,p_ru14o2) = 0. + ddvel(i,j,p_ru12o2) = 0. + ddvel(i,j,p_ru10o2) = 0. + ddvel(i,j,p_nru14o2) = 0. + ddvel(i,j,p_nru12o2) = 0. + ddvel(i,j,p_ra13o2) = 0. + ddvel(i,j,p_ra16o2) = 0. + ddvel(i,j,p_ra19ao2) = 0. + ddvel(i,j,p_ra19co2) = 0. + ddvel(i,j,p_rtn28o2) = 0. + ddvel(i,j,p_rtn26o2) = 0. + ddvel(i,j,p_nrtn28o2) = 0. + ddvel(i,j,p_rtn25o2) = 0. + ddvel(i,j,p_rtn24o2) = 0. + ddvel(i,j,p_rtn23o2) = 0. + ddvel(i,j,p_rtn14o2) = 0. + ddvel(i,j,p_rtn10o2) = 0. + ddvel(i,j,p_rtx28o2) = 0. + ddvel(i,j,p_rtx24o2) = 0. + ddvel(i,j,p_rtx22o2) = 0. + ddvel(i,j,p_nrtx28o2) = 0. + ddvel(i,j,p_ch3o2no2) = 0. + ddvel(i,j,p_ra22ao2) = 0. + ddvel(i,j,p_ra22bo2) = 0. + ddvel(i,j,p_ra25o2) = 0. + ddvel(i,j,p_ch3so2) = 0. + ddvel(i,j,p_dmso2 ) = 0. + + + end do + end do + end if + + END SUBROUTINE wesely_driver SUBROUTINE rc( rcx, t, rad, rh, iland, & @@ -1553,7 +1685,7 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & if( id == 1 .or. id == 2 ) then ! print*,"modis: num_land ",id,config_flags%num_land_cat - + if( allocated (luse2usgs) ) deallocate (luse2usgs) allocate( luse2usgs(config_flags%num_land_cat),stat=astat ) if( astat /= 0 ) then CALL wrf_message( 'ftuv_init: failed to allocate luse2usgs array' ) @@ -1605,6 +1737,133 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & hstar(p_mekooh) = 311. hstar(p_tolooh) = 311. hstar(p_terpooh) = 311. + + else if( config_flags%chem_opt == crimech_kpp .or. & + config_flags%chem_opt == cri_mosaic_8bin_aq_kpp .or. & + config_flags%chem_opt == cri_mosaic_4bin_aq_kpp ) then + hstar(p_o3) = 1.15E-2 + hstar(p_co) = 1.e-3 + hstar(p_h2o2) = 8.33E+4 + hstar(p_hcho) = 6.3e3 + hstar(p_ch3ooh) = 311. + hstar(p_ch3oh) = 220. + hstar(p_ch3cooh) = 6.3e3 + hstar(p_ket) = 27. + hstar(p_paa) = 837. + hstar(p_c2h5co3h) = 837. + hstar(p_hoch2co3h) = 837. +! hstar(p_c3h6ooh) = 220. + hstar(p_pan) = 5. + hstar(p_mpan) = 1.15e-2 + hstar(p_ru12pan) = 1.15e-2 + hstar(p_rtn26pan) = 1.15e-2 + hstar(p_phan) = 1.15e-2 + hstar(p_ppn) = 1.15e-2 + hstar(p_c2h5oh) = 200. + hstar(p_c2h5ooh) = 336. +! hstar(p_ic3h7ooh) = 336. +! hstar(p_acetp) = 336. +! hstar(p_onit) = 1.e3 +!! hstar(p_onitr) = 7.51e3 +! hstar(p_acetol) = 6.3e3 +! hstar(p_glyald) = 4.14e4 +! hstar(p_hydrald) = 70. + hstar(p_hcooh) = 311. + hstar(p_prooh) = 311. + hstar(p_hoc2h4ooh) = 311. + hstar(p_rn10ooh) = 311. + hstar(p_rn13ooh) = 311. + hstar(p_rn16ooh) = 311. + hstar(p_rn19ooh) = 311. + hstar(p_rn8ooh) = 311. + hstar(p_rn11ooh) = 311. + hstar(p_rn14ooh) = 311. + hstar(p_rn17ooh) = 311. + hstar(p_rn9ooh) = 311. + hstar(p_rn12ooh) = 311. + hstar(p_rn15ooh) = 311. + hstar(p_rn18ooh) = 311. + hstar(p_nrn6ooh) = 311. + hstar(p_nrn9ooh) = 311. + hstar(p_nrn12ooh) = 311. + hstar(p_ru14ooh) = 311. + hstar(p_ru12ooh) = 311. + hstar(p_ru10ooh) = 311. + hstar(p_nru14ooh) = 311. + hstar(p_nru12ooh) = 311. + hstar(p_ra13ooh) = 311. + hstar(p_ra16ooh) = 311. + hstar(p_ra19ooh) = 311. + hstar(p_rtn28ooh) = 311. + hstar(p_rtn26ooh) = 311. + hstar(p_nrtn28ooh) = 311. + hstar(p_rtn25ooh) = 311. + hstar(p_rtn24ooh) = 311. + hstar(p_rtn23ooh) = 311. + hstar(p_rtn14ooh) = 311. + hstar(p_rtn10ooh) = 311. + hstar(p_rcooh25) = 311. + hstar(p_rtx28ooh) = 311. + hstar(p_rtx24ooh) = 311. + hstar(p_rtx22ooh) = 311. + hstar(p_nrtx28ooh) = 311. + hstar(p_ra22ooh) = 311. + hstar(p_ra25ooh) = 311. + hstar(p_ch3no3) = 1.e3 + hstar(p_c2h5no3) = 1.e3 + hstar(p_hoc2h4no3) = 1.e3 + hstar(p_rn10no3) = 1.e3 + hstar(p_rn13no3) = 1.e3 + hstar(p_rn19no3) = 1.e3 + hstar(p_rn9no3) = 1.e3 + hstar(p_rn12no3) = 1.e3 + hstar(p_rn15no3) = 1.e3 + hstar(p_rn18no3) = 1.e3 + hstar(p_rn16no3) = 1.e3 + hstar(p_ru14no3) = 1.e3 + hstar(p_ra13no3) = 1.e3 + hstar(p_ra16no3) = 1.e3 + hstar(p_ra19no3) = 1.e3 + hstar(p_rtn28no3) = 1.e3 + hstar(p_rtn25no3) = 1.e3 + hstar(p_rtx28no3) = 1.e3 + hstar(p_rtx24no3) = 1.e3 + hstar(p_rtx22no3) = 1.e3 + hstar(p_rtn23no3) = 1.e3 + hstar(p_ra22no3) = 1.e3 + hstar(p_ra25no3) = 1.e3 + hstar(p_ic3h7no3) = 1.e3 + hstar(p_ch3cho) = 1.14E+1 + hstar(p_c2h5cho) = 1.14E+1 + hstar(p_hoch2cho) = 1.14E+1 + hstar(p_carb14) = 1.14E+1 + hstar(p_carb17) = 1.14E+1 + hstar(p_carb7) = 1.14E+1 + hstar(p_carb10) = 1.14E+1 + hstar(p_carb13) = 1.14E+1 + hstar(p_carb16) = 1.14E+1 + hstar(p_carb3) = 1.14E+1 + hstar(p_carb6) = 1.14E+1 + hstar(p_carb9) = 1.14E+1 + hstar(p_carb12) = 1.14E+1 + hstar(p_carb15) = 1.14E+1 + hstar(p_ccarb12) = 1.14E+1 + hstar(p_ucarb12) = 1.14E+1 + hstar(p_ucarb10) = 1.14E+1 + hstar(p_nucarb12) = 1.14E+1 + hstar(p_udcarb8) = 1.14E+1 + hstar(p_udcarb11) = 1.14E+1 + hstar(p_udcarb14) = 1.14E+1 + hstar(p_tncarb26) = 1.14E+1 + hstar(p_tncarb10) = 1.14E+1 + hstar(p_tncarb15) = 1.14E+1 + hstar(p_txcarb24) = 1.14E+1 + hstar(p_txcarb22) = 1.14E+1 + hstar(p_carb11a) = 1.14E+1 + hstar(p_tncarb12) = 1.14E+1 + hstar(p_tncarb11) = 1.14E+1 + hstar(p_udcarb17) = 1.14E+1 + else hstar(p_o3) = 1.13E-2 hstar(p_co) = 8.20E-3 @@ -1722,6 +1981,133 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & dhr(p_mekooh) = 5241. dhr(p_tolooh) = 5241. dhr(p_terpooh) = 5241. + + else if( config_flags%chem_opt == crimech_kpp .or. & + config_flags%chem_opt == cri_mosaic_8bin_aq_kpp .or. & + config_flags%chem_opt == cri_mosaic_4bin_aq_kpp ) then + dhr(p_o3) = 2560. + dhr(p_h2o2) = 7379. + dhr(p_hcho) = 6425. + dhr(p_ch3ooh) = 5241. + dhr(p_ch3oh) = 4934. + dhr(p_ch3cooh) = 6425. + dhr(p_ket) = 5300. + dhr(p_paa) = 5308. + dhr(p_c2h5co3h) = 5308. + dhr(p_hoch2co3h) = 5308. +! dhr(p_c3h6ooh) = 5653. + dhr(p_pan) = 0. + dhr(p_mpan) = 2560. + dhr(p_ru12pan) = 2560. + dhr(p_rtn26pan) = 2560. + dhr(p_phan) = 2560. + dhr(p_ppn) = 2560. + dhr(p_c2h5oh) = 6500. +! dhr(p_c3h6ooh) = 220. + dhr(p_c2h5ooh) = 5995. +! dhr(p_ic3h7ooh) = 5995. +! dhr(p_acetp) = 5995. +! dhr(p_onit) = 6000. +! dhr(p_onitr) = 6485. +! dhr(p_acetol) = 6425. +! dhr(p_glyald) = 4630. +! dhr(p_hydrald) = 6000. + + dhr(p_hcooh) = 5241. + dhr(p_prooh) = 5241. + dhr(p_hoc2h4ooh) = 5241. + dhr(p_rn10ooh) = 5241. + dhr(p_rn13ooh) = 5241. + dhr(p_rn16ooh) = 5241. + dhr(p_rn19ooh) = 5241. + dhr(p_rn8ooh) = 5241. + dhr(p_rn11ooh) = 5241. + dhr(p_rn14ooh) = 5241. + dhr(p_rn17ooh) = 5241. + dhr(p_rn9ooh) = 5241. + dhr(p_rn12ooh) = 5241. + dhr(p_rn15ooh) = 5241. + dhr(p_rn18ooh) = 5241. + dhr(p_nrn6ooh) = 5241. + dhr(p_nrn9ooh) = 5241. + dhr(p_nrn12ooh) = 5241. + dhr(p_ru14ooh) = 5241. + dhr(p_ru12ooh) = 5241. + dhr(p_ru10ooh) = 5241. + dhr(p_nru14ooh) = 5241. + dhr(p_nru12ooh) = 5241. + dhr(p_ra13ooh) = 5241. + dhr(p_ra16ooh) = 5241. + dhr(p_ra19ooh) = 5241. + dhr(p_rtn28ooh) = 5241. + dhr(p_rtn26ooh) = 5241. + dhr(p_nrtn28ooh) = 5241. + dhr(p_rtn25ooh) = 5241. + dhr(p_rtn24ooh) = 5241. + dhr(p_rtn23ooh) = 5241. + dhr(p_rtn14ooh) = 5241. + dhr(p_rtn10ooh) = 5241. + dhr(p_rcooh25) = 5241. + dhr(p_rtx28ooh) = 5241. + dhr(p_rtx24ooh) = 5241. + dhr(p_rtx22ooh) = 5241. + dhr(p_nrtx28ooh) = 5241. + dhr(p_ra22ooh) = 5241. + dhr(p_ra25ooh) = 5241. + dhr(p_ch3no3) = 6000. + dhr(p_c2h5no3) = 6000. + dhr(p_hoc2h4no3) = 6000. + dhr(p_rn10no3) = 6000. + dhr(p_rn13no3) = 6000. + dhr(p_rn19no3) = 6000. + dhr(p_rn9no3) = 6000. + dhr(p_rn12no3) = 6000. + dhr(p_rn15no3) = 6000. + dhr(p_rn18no3) = 6000. + dhr(p_rn16no3) = 6000. + dhr(p_ru14no3) = 6000. + dhr(p_ra13no3) = 6000. + dhr(p_ra16no3) = 6000. + dhr(p_ra19no3) = 6000. + dhr(p_rtn28no3) = 6000. + dhr(p_rtn25no3) = 6000. + dhr(p_rtx28no3) = 6000. + dhr(p_rtx24no3) = 6000. + dhr(p_rtx22no3) = 6000. + dhr(p_rtn23no3) = 6000. + dhr(p_ra22no3) = 6000. + dhr(p_ra25no3) = 6000. + dhr(p_ic3h7no3) = 6000. + dhr(p_ch3cho) = 6266. + dhr(p_c2h5cho) = 6266. + dhr(p_hoch2cho) = 6266. + dhr(p_carb14) = 6266. + dhr(p_carb17) = 6266. + dhr(p_carb7) = 6266. + dhr(p_carb10) = 6266. + dhr(p_carb13) = 6266. + dhr(p_carb16) = 6266. + dhr(p_carb3) = 6266. + dhr(p_carb6) = 6266. + dhr(p_carb9) = 6266. + dhr(p_carb12) = 6266. + dhr(p_carb15) = 6266. + dhr(p_ccarb12) = 6266. + dhr(p_ucarb12) = 6266. + dhr(p_ucarb10) = 6266. + dhr(p_nucarb12) = 6266. + dhr(p_udcarb8) = 6266. + dhr(p_udcarb11) = 6266. + dhr(p_udcarb14) = 6266. + dhr(p_tncarb26) = 6266. + dhr(p_tncarb10) = 6266. + dhr(p_tncarb15) = 6266. + dhr(p_txcarb24) = 6266. + dhr(p_txcarb22) = 6266. + dhr(p_carb11a) = 6266. + dhr(p_tncarb12) = 6266. + dhr(p_tncarb11) = 6266. + dhr(p_udcarb17) = 6266. else dhr(p_o3) = 2300. dhr(p_h2o2) = 6615. @@ -1790,6 +2176,132 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & f0(p_mekooh) = .1 f0(p_tolooh) = .1 f0(p_terpooh) = .1 + + else if( config_flags%chem_opt == crimech_kpp .or. & + config_flags%chem_opt == cri_mosaic_8bin_aq_kpp .or. & + config_flags%chem_opt == cri_mosaic_4bin_aq_kpp ) then + + + f0(p_hcho) = small_value + f0(p_ch3ooh) = .1 + f0(p_ch3oh) = small_value + f0(p_ch3cooh) = small_value + f0(p_ket) = small_value + +! f0(p_c3h6ooh) = .1 + + f0(p_mpan) = .1 + f0(p_ru12pan) = .1 + f0(p_rtn26pan) = .1 + f0(p_phan) = .1 + f0(p_ppn) = .1 + f0(p_c2h5oh) = small_value +! f0(p_c3h6ooh) = .1 + f0(p_c2h5ooh) = .1 +! f0(p_ic3h7ooh) = .1 +! f0(p_acetp) = .1 +! f0(p_onit) = .1 +! f0(p_onitr) = .1 +! f0(p_acetol) = .1 +! f0(p_glyald) = .1 +! f0(p_hydrald) = .1 + + f0(p_hcooh) = .1 + f0(p_prooh) = .1 + f0(p_hoc2h4ooh) = .1 + f0(p_rn10ooh) = .1 + f0(p_rn13ooh) = .1 + f0(p_rn16ooh) = .1 + f0(p_rn19ooh) = .1 + f0(p_rn8ooh) = .1 + f0(p_rn11ooh) = .1 + f0(p_rn14ooh) = .1 + f0(p_rn17ooh) = .1 + f0(p_rn9ooh) = .1 + f0(p_rn12ooh) = .1 + f0(p_rn15ooh) = .1 + f0(p_rn18ooh) = .1 + f0(p_nrn6ooh) = .1 + f0(p_nrn9ooh) = .1 + f0(p_nrn12ooh) = .1 + f0(p_ru14ooh) = .1 + f0(p_ru12ooh) = .1 + f0(p_ru10ooh) = .1 + f0(p_nru14ooh) = .1 + f0(p_nru12ooh) = .1 + f0(p_ra13ooh) = .1 + f0(p_ra16ooh) = .1 + f0(p_ra19ooh) = .1 + f0(p_rtn28ooh) = .1 + f0(p_rtn26ooh) = .1 + f0(p_nrtn28ooh) = .1 + f0(p_rtn25ooh) = .1 + f0(p_rtn24ooh) = .1 + f0(p_rtn23ooh) = .1 + f0(p_rtn14ooh) = .1 + f0(p_rtn10ooh) = .1 + f0(p_rcooh25) = .1 + f0(p_rtx28ooh) = .1 + f0(p_rtx24ooh) = .1 + f0(p_rtx22ooh) = .1 + f0(p_nrtx28ooh) = .1 + f0(p_ra22ooh) = .1 + f0(p_ra25ooh) = .1 + f0(p_ch3no3) = .1 + f0(p_c2h5no3) = .1 + f0(p_hoc2h4no3) = .1 + f0(p_rn10no3) = .1 + f0(p_rn13no3) = .1 + f0(p_rn19no3) = .1 + f0(p_rn9no3) = .1 + f0(p_rn12no3) = .1 + f0(p_rn15no3) = .1 + f0(p_rn18no3) = .1 + f0(p_rn16no3) = .1 + f0(p_ru14no3) = .1 + f0(p_ra13no3) = .1 + f0(p_ra16no3) = .1 + f0(p_ra19no3) = .1 + f0(p_rtn28no3) = .1 + f0(p_rtn25no3) = .1 + f0(p_rtx28no3) = .1 + f0(p_rtx24no3) = .1 + f0(p_rtx22no3) = .1 + f0(p_rtn23no3) = .1 + f0(p_ra22no3) = .1 + f0(p_ra25no3) = .1 + f0(p_ic3h7no3) = .1 + f0(p_ch3cho) = 0. + f0(p_c2h5cho) = 0. + f0(p_hoch2cho) = 0. + f0(p_carb14) = 0. + f0(p_carb17) = 0. + f0(p_carb7) = 0. + f0(p_carb10) = 0. + f0(p_carb13) = 0. + f0(p_carb16) = 0. + f0(p_carb3) = 0. + f0(p_carb6) = 0. + f0(p_carb9) = 0. + f0(p_carb12) = 0. + f0(p_carb15) = 0. + f0(p_ccarb12) = 0. + f0(p_ucarb12) = 0. + f0(p_ucarb10) = 0. + f0(p_nucarb12) = 0. + f0(p_udcarb8) = 0. + f0(p_udcarb11) = 0. + f0(p_udcarb14) = 0. + f0(p_tncarb26) = 0. + f0(p_tncarb10) = 0. + f0(p_tncarb15) = 0. + f0(p_txcarb24) = 0. + f0(p_txcarb22) = 0. + f0(p_carb11a) = 0. + f0(p_tncarb12) = 0. + f0(p_tncarb11) = 0. + f0(p_udcarb17) = 0. + else f0(p_hcho) = 0. f0(p_onit) = 0. @@ -1861,6 +2373,134 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & dvj(p_mekooh) = 0.098 dvj(p_tolooh) = 0.084 dvj(p_terpooh) = 0.073 + + else if( config_flags%chem_opt == crimech_kpp .or. & + config_flags%chem_opt == cri_mosaic_8bin_aq_kpp .or. & + config_flags%chem_opt == cri_mosaic_4bin_aq_kpp ) then + dvj(p_o3) = 0.144 + dvj(p_h2o2) = 0.1715 + dvj(p_hcho) = 0.1825 + dvj(p_ch3ooh) = 0.144 + dvj(p_ch3oh) = 0.1767 + dvj(p_ch3cooh) = 0.129 + dvj(p_ket) = 0.1312 + dvj(p_paa) = 0.1147 + dvj(p_c2h5co3h) = 0.1147 + dvj(p_hoch2co3h) = 0.1147 +! dvj(p_c3h6ooh) = 0.1042 + dvj(p_mpan) = 0.0825 + dvj(p_ru12pan) = 0.0825 + dvj(p_rtn26pan) = 0.0825 + dvj(p_phan) = 0.0825 + dvj(p_ppn) = 0.0825 + dvj(p_c2h5oh) = 0.1473 + +! dvj(p_c3h6ooh) = 0.0916 + dvj(p_c2h5ooh) = 0.091627 +! dvj(p_ic3h7ooh) = 0.0916146 +! dvj(p_acetp) = 0.1054 +! dvj(p_onit) = 0.0916 +! dvj(p_onitr) = 0.0824 +! dvj(p_acetol) = 0.116 +! dvj(p_glyald) = 0.129 +! dvj(p_hydrald) = 0.0999 + + dvj(p_hcooh) = 0.098 + dvj(p_prooh) = 0.098 + dvj(p_hoc2h4ooh) = 0.098 + dvj(p_rn10ooh) = 0.098 + dvj(p_rn13ooh) = 0.098 + dvj(p_rn16ooh) = 0.098 + dvj(p_rn19ooh) = 0.098 + dvj(p_rn8ooh) = 0.098 + dvj(p_rn11ooh) = 0.098 + dvj(p_rn14ooh) = 0.098 + dvj(p_rn17ooh) = 0.098 + dvj(p_rn9ooh) = 0.098 + dvj(p_rn12ooh) = 0.098 + dvj(p_rn15ooh) = 0.098 + dvj(p_rn18ooh) = 0.098 + dvj(p_nrn6ooh) = 0.098 + dvj(p_nrn9ooh) = 0.098 + dvj(p_nrn12ooh) = 0.098 + dvj(p_ru14ooh) = 0.098 + dvj(p_ru12ooh) = 0.098 + dvj(p_ru10ooh) = 0.098 + dvj(p_nru14ooh) = 0.098 + dvj(p_nru12ooh) = 0.098 + dvj(p_ra13ooh) = 0.084 + dvj(p_ra16ooh) = 0.084 + dvj(p_ra19ooh) = 0.084 + dvj(p_rtn28ooh) = 0.073 + dvj(p_rtn26ooh) = 0.073 + dvj(p_nrtn28ooh) = 0.073 + dvj(p_rtn25ooh) = 0.073 + dvj(p_rtn24ooh) = 0.073 + dvj(p_rtn23ooh) = 0.073 + dvj(p_rtn14ooh) = 0.073 + dvj(p_rtn10ooh) = 0.073 + dvj(p_rcooh25) = 0.073 + dvj(p_rtx28ooh) = 0.073 + dvj(p_rtx24ooh) = 0.073 + dvj(p_rtx22ooh) = 0.073 + dvj(p_nrtx28ooh) = 0.073 + dvj(p_ra22ooh) = 0.084 + dvj(p_ra25ooh) = 0.084 + dvj(p_ch3no3) = 0.0916 + dvj(p_c2h5no3) = 0.0916 + dvj(p_hoc2h4no3) = 0.0916 + dvj(p_rn10no3) = 0.0916 + dvj(p_rn13no3) = 0.0916 + dvj(p_rn19no3) = 0.0916 + dvj(p_rn9no3) = 0.0916 + dvj(p_rn12no3) = 0.0916 + dvj(p_rn15no3) = 0.0916 + dvj(p_rn18no3) = 0.0916 + dvj(p_rn16no3) = 0.0916 + dvj(p_ru14no3) = 0.0916 + dvj(p_ra13no3) = 0.0916 + dvj(p_ra16no3) = 0.0916 + dvj(p_ra19no3) = 0.0916 + dvj(p_rtn28no3) = 0.0916 + dvj(p_rtn25no3) = 0.0916 + dvj(p_rtx28no3) = 0.0916 + dvj(p_rtx24no3) = 0.0916 + dvj(p_rtx22no3) = 0.0916 + dvj(p_rtn23no3) = 0.0916 + dvj(p_ra22no3) = 0.0916 + dvj(p_ra25no3) = 0.0916 + dvj(p_ic3h7no3) = 0.0916 + dvj(p_ch3cho) = 0.151 + dvj(p_c2h5cho) = 0.151 + dvj(p_hoch2cho) = 0.151 + dvj(p_carb14) = 0.151 + dvj(p_carb17) = 0.151 + dvj(p_carb7) = 0.151 + dvj(p_carb10) = 0.151 + dvj(p_carb13) = 0.151 + dvj(p_carb16) = 0.151 + dvj(p_carb3) = 0.151 + dvj(p_carb6) = 0.151 + dvj(p_carb9) = 0.151 + dvj(p_carb12) = 0.151 + dvj(p_carb15) = 0.151 + dvj(p_ccarb12) = 0.151 + dvj(p_ucarb12) = 0.151 + dvj(p_ucarb10) = 0.151 + dvj(p_nucarb12) = 0.151 + dvj(p_udcarb8) = 0.151 + dvj(p_udcarb11) = 0.151 + dvj(p_udcarb14) = 0.151 + dvj(p_tncarb26) = 0.151 + dvj(p_tncarb10) = 0.151 + dvj(p_tncarb15) = 0.151 + dvj(p_txcarb24) = 0.151 + dvj(p_txcarb22) = 0.151 + dvj(p_carb11a) = 0.151 + dvj(p_tncarb12) = 0.151 + dvj(p_tncarb11) = 0.151 + dvj(p_udcarb17) = 0.151 + else dvj(p_o3) = 0.175 dvj(p_h2o2) = 0.171 diff --git a/wrfv2_fire/chem/module_dust_load.F b/wrfv2_fire/chem/module_dust_load.F new file mode 100644 index 00000000..41fc1499 --- /dev/null +++ b/wrfv2_fire/chem/module_dust_load.F @@ -0,0 +1,59 @@ +MODULE module_dust_load + +! This module for calculation of dust loading + CONTAINS + + SUBROUTINE dust_load_driver ( config_flags, & + alt, chem, dz8w, dustload_1, dustload_2, dustload_3, & + dustload_4, dustload_5, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: alt, dz8w + + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: dustload_1, & + dustload_2, dustload_3, dustload_4, dustload_5 + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER :: i, j, k + +! do j=jts,jte +! do i=its,ite + dustload_1(its:ite,jts:jte) = 0. + dustload_2(its:ite,jts:jte) = 0. + dustload_3(its:ite,jts:jte) = 0. + dustload_4(its:ite,jts:jte) = 0. + dustload_5(its:ite,jts:jte) = 0. +! enddo +! enddo + do j=jts,jte + do i=its,ite + do k=kts,kte +! chem(p_dust) : [ug/kg_dryair], alt : [m3/kg], dz8w : [m] -> dustload : [ug/m2] + dustload_1(i,j)= dustload_1(i,j) + chem(i,k,j,p_dust_1)/alt(i,k,j) * dz8w(i,k,j) + dustload_2(i,j)= dustload_2(i,j) + chem(i,k,j,p_dust_2)/alt(i,k,j) * dz8w(i,k,j) + dustload_3(i,j)= dustload_3(i,j) + chem(i,k,j,p_dust_3)/alt(i,k,j) * dz8w(i,k,j) + dustload_4(i,j)= dustload_4(i,j) + chem(i,k,j,p_dust_4)/alt(i,k,j) * dz8w(i,k,j) + dustload_5(i,j)= dustload_5(i,j) + chem(i,k,j,p_dust_5)/alt(i,k,j) * dz8w(i,k,j) + enddo + enddo + enddo + + END SUBROUTINE dust_load_driver + +END MODULE module_dust_load + diff --git a/wrfv2_fire/chem/module_emissions_anthropogenics.F b/wrfv2_fire/chem/module_emissions_anthropogenics.F index 7b35104f..f17799a9 100755 --- a/wrfv2_fire/chem/module_emissions_anthropogenics.F +++ b/wrfv2_fire/chem/module_emissions_anthropogenics.F @@ -140,10 +140,45 @@ subroutine add_anthropogenics(id,dtstep,dz8w,config_flags,rho_phy,alt, & chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) + conv_rho_aer*emis_ant(i,k,j,p_e_oc) chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) + conv_rho_aer*emis_ant(i,k,j,p_e_bc) elseif( config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then - chem(i,k,j,p_voca) = chem(i,k,j,p_voca) + conv_rho*emis_ant(i,k,j,p_e_voca) - chem(i,k,j,p_vocbb) = chem(i,k,j,p_vocbb) + conv_rho*emis_ant(i,k,j,p_e_vocbb) +! 20130730 acd_ck_bugfix start +! emissions should be CO_A and CO_BB with yields instead of VOC_A and VOC_BB +! chem(i,k,j,p_voca) = chem(i,k,j,p_voca) + conv_rho*emis_ant(i,k,j,p_e_voca) +! chem(i,k,j,p_vocbb) = chem(i,k,j,p_vocbb) + conv_rho*emis_ant(i,k,j,p_e_vocbb) + chem(i,k,j,p_voca) = chem(i,k,j,p_voca) + conv_rho_aer*emis_ant(i,k,j,p_e_co_a)*0.04*28./250. + chem(i,k,j,p_vocbb) = chem(i,k,j,p_vocbb) + conv_rho_aer*emis_ant(i,k,j,p_e_co_bb)*0.04*28./250. +! 20130730 acd_ck_bugfix end endif - else + else if( config_flags%chem_opt == CRIMECH_KPP & + .or. config_flags%chem_opt == CRI_MOSAIC_8BIN_AQ_KPP & + .or. config_flags%chem_opt == CRI_MOSAIC_4BIN_AQ_KPP) then + chem(i,k,j,p_no2) = chem(i,k,j,p_no2) + emis_ant(i,k,j,p_e_no2)*conv_rho + chem(i,k,j,p_c2h6) = chem(i,k,j,p_c2h6) + emis_ant(i,k,j,p_e_c2h6)*conv_rho + chem(i,k,j,p_c2h4) = chem(i,k,j,p_c2h4) + emis_ant(i,k,j,p_e_c2h4)*conv_rho + chem(i,k,j,p_c5h8) = chem(i,k,j,p_c5h8) + emis_ant(i,k,j,p_e_c5h8)*conv_rho + chem(i,k,j,p_tm123b) = chem(i,k,j,p_tm123b) + emis_ant(i,k,j,p_e_tm123b)*conv_rho + chem(i,k,j,p_tm124b) = chem(i,k,j,p_tm124b) + emis_ant(i,k,j,p_e_tm124b)*conv_rho + chem(i,k,j,p_tm135b) = chem(i,k,j,p_tm135b) + emis_ant(i,k,j,p_e_tm135b)*conv_rho + chem(i,k,j,p_oethtol) = chem(i,k,j,p_oethtol) + emis_ant(i,k,j,p_e_oethtol)*conv_rho + chem(i,k,j,p_methtol) = chem(i,k,j,p_methtol) + emis_ant(i,k,j,p_e_methtol)*conv_rho + chem(i,k,j,p_pethtol) = chem(i,k,j,p_pethtol) + emis_ant(i,k,j,p_e_pethtol)*conv_rho + chem(i,k,j,p_dime35eb) = chem(i,k,j,p_dime35eb) + emis_ant(i,k,j,p_e_dime35eb)*conv_rho + chem(i,k,j,p_hcho) = chem(i,k,j,p_hcho) + emis_ant(i,k,j,p_e_hcho)*conv_rho + chem(i,k,j,p_ch3cho) = chem(i,k,j,p_ch3cho) + emis_ant(i,k,j,p_e_ch3cho)*conv_rho + chem(i,k,j,p_c2h5cho) = chem(i,k,j,p_c2h5cho) + emis_ant(i,k,j,p_e_c2h5cho)*conv_rho + chem(i,k,j,p_ket) = chem(i,k,j,p_ket) + emis_ant(i,k,j,p_e_ket)*conv_rho + chem(i,k,j,p_mek) = chem(i,k,j,p_mek) + emis_ant(i,k,j,p_e_mek)*conv_rho + chem(i,k,j,p_ch3oh) = chem(i,k,j,p_ch3oh) + emis_ant(i,k,j,p_e_ch3oh)*conv_rho + chem(i,k,j,p_c2h5oh) = chem(i,k,j,p_c2h5oh) + emis_ant(i,k,j,p_e_c2h5oh)*conv_rho + chem(i,k,j,p_c3h6) = chem(i,k,j,p_c3h6) + emis_ant(i,k,j,p_e_c3h6)*conv_rho + chem(i,k,j,p_c2h2) = chem(i,k,j,p_c2h2) + emis_ant(i,k,j,p_e_c2h2)*conv_rho + chem(i,k,j,p_benzene) = chem(i,k,j,p_benzene) + emis_ant(i,k,j,p_e_benzene)*conv_rho + chem(i,k,j,p_nc4h10) = chem(i,k,j,p_nc4h10) + emis_ant(i,k,j,p_e_nc4h10)*conv_rho + chem(i,k,j,p_toluene) = chem(i,k,j,p_toluene) + emis_ant(i,k,j,p_e_toluene)*conv_rho + chem(i,k,j,p_oxyl) = chem(i,k,j,p_oxyl) + emis_ant(i,k,j,p_e_oxyl)*conv_rho + chem(i,k,j,p_c3h8) = chem(i,k,j,p_c3h8) + emis_ant(i,k,j,p_e_c3h8)*conv_rho + chem(i,k,j,p_tbut2ene) = chem(i,k,j,p_tbut2ene) + emis_ant(i,k,j,p_e_tbut2ene)*conv_rho + chem(i,k,j,p_ch3co2h) = chem(i,k,j,p_ch3co2h) + emis_ant(i,k,j,p_e_ch3co2h)*conv_rho + else chem(i,k,j,p_csl) = chem(i,k,j,p_csl) & +emis_ant(i,k,j,p_e_csl)*conv_rho chem(i,k,j,p_iso) = chem(i,k,j,p_iso) & @@ -176,6 +211,15 @@ subroutine add_anthropogenics(id,dtstep,dz8w,config_flags,rho_phy,alt, & +emis_ant(i,k,j,p_e_xyl)*conv_rho chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & +emis_ant(i,k,j,p_e_ket)*conv_rho + if( config_flags%chem_opt == GOCARTRACM_KPP & + .or. config_flags%chem_opt == GOCARTRADM2 & + .or. config_flags%chem_opt == GOCARTRADM2_KPP) then + conv_rho_aer = alt(i,k,j)*dtstep/dz8w(i,k,j) + chem(i,k,j,p_p10) = chem(i,k,j,p_p10) + conv_rho_aer*emis_ant(i,k,j,p_e_pm_10) + chem(i,k,j,p_p25) = chem(i,k,j,p_p25) + conv_rho_aer*emis_ant(i,k,j,p_e_pm_25) + chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) + conv_rho_aer*emis_ant(i,k,j,p_e_oc) + chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) + conv_rho_aer*emis_ant(i,k,j,p_e_bc) + endif endif END DO 100 continue @@ -276,6 +320,27 @@ subroutine add_biogenics(id,dtstep,dz8w,config_flags,rho_phy,chem, & e_bio(i,j,p_hc3-1)*conv_rho if(p_ol2.gt.1)chem(i,kts,j,p_ol2)=chem(i,kts,j,p_ol2)+ & e_bio(i,j,p_ol2-1)*conv_rho +! CRIMECH only + if(p_c5h8.gt.1)chem(i,kts,j,p_c5h8)=chem(i,kts,j,p_c5h8)+ & + e_bio(i,j,liso)*conv_rho + if(p_oxyl.gt.1)chem(i,kts,j,p_oxyl)=chem(i,kts,j,p_oxyl)+ & + e_bio(i,j,lxyl)*conv_rho + if(p_c3h8.gt.1)chem(i,kts,j,p_c3h8)=chem(i,kts,j,p_c3h8)+ & + e_bio(i,j,lhc3)*conv_rho + if(p_ket.gt.1)chem(i,kts,j,p_ket)=chem(i,kts,j,p_ket)+ & + e_bio(i,j,lket)*conv_rho + if(p_ch3cho.gt.1)chem(i,kts,j,p_ch3cho)=chem(i,kts,j,p_ch3cho)+ & + e_bio(i,j,lald)*conv_rho + if(p_apinene.gt.1)chem(i,kts,j,p_apinene)=chem(i,kts,j,p_apinene)+ & + 0.667*e_bio(i,j,loli)*conv_rho +! if(p_bpinene.gt.1)chem(i,kts,j,p_bpinene)=chem(i,kts,j,p_bpinene)+ & +! 0.333*e_bio(i,j,loli)*conv_rho + if(p_bpinene.gt.1)chem(i,kts,j,p_bpinene)=chem(i,kts,j,p_bpinene)+ & + 0.333*e_bio(i,j,loli)*conv_rho + e_bio(i,j,lolt)*conv_rho + if(p_hcooh.gt.1)chem(i,kts,j,p_hcooh)=chem(i,kts,j,p_hcooh)+ & + e_bio(i,j,lora1)*conv_rho + if(p_ch3co2h.gt.1)chem(i,kts,j,p_ch3co2h)=chem(i,kts,j,p_ch3co2h)+ & + e_bio(i,j,lora2)*conv_rho !BSINGH - Added for CBMZ ! @@ -324,6 +389,26 @@ subroutine add_biogenics(id,dtstep,dz8w,config_flags,rho_phy,chem, & ! if(p_ol2.gt.1)chem(i,kts,j,p_ol2)=chem(i,kts,j,p_ol2)+ & ebio_ete(i,j)*conv_rho +! +! CRIMECH only --- DL 05/08/2013: not used at the moment +! +! if(p_c5h8.gt.1)chem(i,kts,j,p_c5h8)=chem(i,kts,j,p_c5h8)+ & +! e_bio(i,j,p_iso-1)*conv_rho +! if(p_oxyl.gt.1)chem(i,kts,j,p_oxyl)=chem(i,kts,j,p_oxyl)+ & +! e_bio(i,j,p_xyl-1)*conv_rho +! if(p_c3h8.gt.1)chem(i,kts,j,p_c3h8)=chem(i,kts,j,p_c3h8)+ & +! e_bio(i,j,p_hc3-1)*conv_rho +! if(p_ket.gt.1)chem(i,kts,j,p_ket)=chem(i,kts,j,p_ket)+ & +! e_bio(i,j,p_ket-1)*conv_rho +! if(p_ch3cho.gt.1)chem(i,kts,j,p_ch3cho)=chem(i,kts,j,p_ch3cho)+ & +! e_bio(i,j,p_ald-1)*conv_rho +! if(p_c2h6.gt.1)chem(i,kts,j,p_c2h6)=chem(i,kts,j,p_c2h6)+ & +! e_bio(i,j,p_eth-1)*conv_rho +! if(p_apinene.gt.1)chem(i,kts,j,p_apinene)=chem(i,kts,j,p_apinene)+ & +! e_bio(i,j,p_api-1)*conv_rho +! if(p_bpinene.gt.1)chem(i,kts,j,p_bpinene)=chem(i,kts,j,p_bpinene)+ & +! e_bio(i,j,p_api-1)*conv_rho + ! ! RACM only ! diff --git a/wrfv2_fire/chem/module_ftuv_driver.F b/wrfv2_fire/chem/module_ftuv_driver.F index 5e0cf904..2f9440d6 100644 --- a/wrfv2_fire/chem/module_ftuv_driver.F +++ b/wrfv2_fire/chem/module_ftuv_driver.F @@ -138,6 +138,9 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & ph_hyac, ivgtyp, & ph_radfld, ph_adjcoe, ph_prate, & wc_x, zref_x, & + tauaer1, tauaer2, tauaer3, tauaer4, & !rajesh + waer1, waer2, waer3, waer4, & !rajesh + gaer1, gaer2, gaer3, gaer4, & !rajesh ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -184,6 +187,11 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & xlong(ims:ime,jms:jme) real, intent(in ) :: moist(ims:ime,kms:kme,jms:jme,num_moist) real, intent(in ) :: chem(ims:ime,kms:kme,jms:jme,num_chem) +!rajesh: add arrays for aerosol optical properties + real, dimension( ims:ime, kms:kme, jms:jme ), & + intent(in ) :: tauaer1, tauaer2, tauaer3, tauaer4, & + waer1, waer2, waer3, waer4, & + gaer1, gaer2, gaer3, gaer4 !---------------------------------------------------- ! output arguments @@ -242,6 +250,13 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & real(dp) :: acb1(kts:kte+1), acb2(kts:kte+1), aoc1(kts:kte+1), aoc2(kts:kte+1) real(dp) :: aant(kts:kte+1), aso4(kts:kte+1), asal(kts:kte+1) +! rajesh: add arrays + real(dp) :: tauaer300(kts:kte), tauaer400(kts:kte+1), & + tauaer600(kts:kte), tauaer999(kts:kte+1) + real(dp) :: waer300(kts:kte), waer400(kts:kte), & + waer600(kts:kte), waer999(kts:kte) + real(dp) :: gaer300(kts:kte), gaer400(kts:kte), & + gaer600(kts:kte), gaer999(kts:kte) real(dp) :: p_jtop(its:ite,jts:jte) real(dp) :: o2_exo_col(its:ite,jts:jte) @@ -267,9 +282,14 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & isorg=0 aer_select: SELECT CASE(config_flags%chem_opt) - CASE (RADM2SORG,RADM2SORG_KPP,RACMSORG_KPP,RACM_ESRLSORG_KPP,RACMSORG_AQ,RACMSORG_AQCHEM,CBMZSORG,CBMZSORG_AQ) + CASE (RADM2SORG,RADM2SORG_KPP,RACMSORG_KPP,RADM2SORG_AQCHEM,RACM_ESRLSORG_KPP,RACMSORG_AQ,RACMSORG_AQCHEM_KPP, & + RACM_ESRLSORG_AQCHEM_KPP,CBMZSORG,CBMZSORG_AQ) isorg=1 CALL wrf_debug(15,'SORGAM aerosols initialization ') +! 20130128 acd_ck_bugfix start + CASE (MOZART_MOSAIC_4BIN_VBS0_KPP) + CALL wrf_debug(15,'MOZART_MOSAIC_4BIN_VBS0_KPP aerosols initialization ') +! 20130128 acd_ck_bugfix end CASE DEFAULT CALL wrf_debug(15,'no aerosols initialization yet') CALL wrf_message('no aerosols initialization yet') @@ -364,6 +384,20 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & aant(kp1) = 0._dp aso4(kp1) = 0._dp asal(kp1) = 0._dp +! rajesh: initialize aerosol optical properties to zero + tauaer300(k) = 0._dp + tauaer400(k) = 0._dp + tauaer600(k) = 0._dp + tauaer999(k) = 0._dp + waer300(k) = 0._dp + waer400(k) = 0._dp + waer600(k) = 0._dp + waer999(k) = 0._dp + gaer300(k) = 0._dp + gaer400(k) = 0._dp + gaer600(k) = 0._dp + gaer999(k) = 0._dp + if( isorg == 1 ) then acb1(kp1) = chem(i,k,j,p_ecj) ! acb2(kp1) = 0.0_dp @@ -386,6 +420,22 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & asal(kp1) = (chem(i,k,j,p_seas_1) + chem(i,k,j,p_seas_2) & + chem(i,k,j,p_seas_3) + chem(i,k,j,p_seas_4))*atm_mass_den endif + endif +! rajesh: Extract column of aerosol optical properties + if(config_flags%aer_ra_feedback == 1) then + tauaer300(k) = tauaer1(i,k,j) + tauaer400(k) = tauaer2(i,k,j) + tauaer600(k) = tauaer3(i,k,j) + tauaer999(k) = tauaer4(i,k,j) + waer300(k) = waer1(i,k,j) + waer400(k) = waer2(i,k,j) + waer600(k) = waer3(i,k,j) + waer999(k) = waer4(i,k,j) + gaer300(k) = gaer1(i,k,j) + gaer400(k) = gaer2(i,k,j) + gaer600(k) = gaer3(i,k,j) + gaer999(k) = gaer4(i,k,j) + endif ! else ! acb1(kp1) = 0._dp ! acb2(kp1) = 0._dp @@ -394,7 +444,6 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & ! aant(kp1) = 0._dp ! aso4(kp1) = 0._dp ! asal(kp1) = 0._dp - endif enddo level_loop temp(1) = t8w(i,kts,j) @@ -410,6 +459,19 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & aant(1) = aant(2) aso4(1) = aso4(2) asal(1) = asal(2) +! rajesh +! tauaer300(1) = tauaer300(2) +! tauaer400(1) = tauaer400(2) +! tauaer600(1) = tauaer600(2) +! tauaer999(1) = tauaer999(2) +! waer300(1) = waer300(2) +! waer400(1) = waer400(2) +! waer600(1) = waer600(2) +! waer999(1) = waer999(2) +! gaer300(1) = gaer300(2) +! gaer400(1) = gaer400(2) +! gaer600(1) = gaer600(2) +! gaer999(1) = gaer999(2) !---------------------------------------------------- ! smooth air density ... @@ -444,6 +506,14 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & aant, & aso4, & asal, & +! rajesh: Add aerosol optical property columns as arguments + tauaer300, tauaer400, & + tauaer600, tauaer999, & + waer300, waer400, & + waer600, waer999, & + gaer300, gaer400, & + gaer600, gaer999, & + config_flags%aer_ra_feedback, & prate, & radfld, & adjcoe, & @@ -736,7 +806,10 @@ subroutine ftuv_init( id,ips, ipe, jps, jpe, kte, & endif col_dens_allocated !++alma 2012-12-01 modis landuse from sw - if( id == 1 ) then +! if( id == 1 ) then +! 20130807 acd_mbela_bugfix start + if( id == 1 .and. .not. allocated(luse2usgs) ) then +! 20130807 acd_mbela_bugfix end !allocate( luse2usgs(config_flags%num_land_cat),stat=astat ) print*,"num_land_cat: ", num_land_cat allocate( luse2usgs(num_land_cat),stat=astat ) @@ -908,7 +981,10 @@ subroutine photo( chem_opt, nlev, njout, julday, gmtp, alat, & along, o3top, o2top, o3toms, lu, zin, tlevin, & airlevin, rhin, xlwcin, o3in, acb1in, & acb2in, aoc1in, aoc2in, aantin, aso4in, & - asalin, prate, radfld, adjcoe, prate0 ) + asalin, tauaer300in,tauaer400in,tauaer600in,tauaer999in, & + waer300in, waer400in, waer600in, waer999in, & + gaer300in, gaer400in, gaer600in, gaer999in, & + aer_ra_feedback, prate, radfld, adjcoe, prate0 ) use module_ftuv_subs, only : calc_zenith, photoin @@ -941,6 +1017,21 @@ subroutine photo( chem_opt, nlev, njout, julday, gmtp, alat, & real(dp), intent(in) :: aso4in(nlev) real(dp), intent(in) :: asalin(nlev) +! rajesh: declare dust variables + real(dp), intent(in) :: tauaer300in(nlev-1) + real(dp), intent(in) :: tauaer400in(nlev-1) + real(dp), intent(in) :: tauaer600in(nlev-1) + real(dp), intent(in) :: tauaer999in(nlev-1) + real(dp), intent(in) :: waer300in(nlev-1) + real(dp), intent(in) :: waer400in(nlev-1) + real(dp), intent(in) :: waer600in(nlev-1) + real(dp), intent(in) :: waer999in(nlev-1) + real(dp), intent(in) :: gaer300in(nlev-1) + real(dp), intent(in) :: gaer400in(nlev-1) + real(dp), intent(in) :: gaer600in(nlev-1) + real(dp), intent(in) :: gaer999in(nlev-1) + INTEGER, INTENT(IN) :: aer_ra_feedback + !---------------------------------------------------- ! output arguments !---------------------------------------------------- @@ -961,6 +1052,14 @@ subroutine photo( chem_opt, nlev, njout, julday, gmtp, alat, & real(dp), allocatable :: acb1_ph(:), acb2_ph(:) real(dp), allocatable :: aoc1_ph(:), aoc2_ph(:) real(dp), allocatable :: aant_ph(:), aso4_ph(:), asal_ph(:) + +! rajesh: declare allocatable variables for aerosol optical properties + real(dp), allocatable :: tauaer300_ph(:), tauaer400_ph(:), & + tauaer600_ph(:), tauaer999_ph(:), & + waer300_ph(:), waer400_ph(:), & + waer600_ph(:), waer999_ph(:), & + gaer300_ph(:), gaer400_ph(:), & + gaer600_ph(:), gaer999_ph(:) real(dp), allocatable :: ftuv(:,:) !----------------------------------------------------------------------------- @@ -1025,6 +1124,18 @@ subroutine photo( chem_opt, nlev, njout, julday, gmtp, alat, & astat = astat + istat allocate( aant_ph(nz), aso4_ph(nz), asal_ph(nz), stat=istat ) astat = astat + istat + +! rajesh: allocate memory space to aerosol optical property variables + allocate( tauaer300_ph(nz-1), tauaer400_ph(nz-1), tauaer600_ph(nz-1), & + tauaer999_ph(nz-1), stat=istat) + astat = astat + istat + allocate( waer300_ph(nz-1), waer400_ph(nz-1), waer600_ph(nz-1), & + waer999_ph(nz-1), stat=istat) + astat = astat + istat + allocate( gaer300_ph(nz-1), gaer400_ph(nz-1), gaer600_ph(nz-1), & + gaer999_ph(nz-1), stat=istat) + astat = astat + istat + if( astat /= 0 ) then call wrf_message( 'ftuv_driver: failed to allocate _ph arrays' ) call wrf_abort @@ -1040,6 +1151,20 @@ subroutine photo( chem_opt, nlev, njout, julday, gmtp, alat, & aso4_ph(:) = 0.0_dp asal_ph(:) = 0.0_dp +! rajesh: Initialize variables to zero + tauaer300_ph(:) = 0.0_dp + tauaer400_ph(:) = 0.0_dp + tauaer600_ph(:) = 0.0_dp + tauaer999_ph(:) = 0.0_dp + waer300_ph(:) = 0.0_dp + waer400_ph(:) = 0.0_dp + waer600_ph(:) = 0.0_dp + waer999_ph(:) = 0.0_dp + gaer300_ph(:) = 0.0_dp + gaer400_ph(:) = 0.0_dp + gaer600_ph(:) = 0.0_dp + gaer999_ph(:) = 0.0_dp + !---------------------------------------------------- ! assgin vertical profiles ! model levels first @@ -1058,6 +1183,20 @@ subroutine photo( chem_opt, nlev, njout, julday, gmtp, alat, & aso4_ph(1:nlev) = aso4in(1:nlev) asal_ph(1:nlev) = asalin(1:nlev) +! rajesh: + tauaer300_ph(1:nlev-1) = tauaer300in(1:nlev-1) + tauaer400_ph(1:nlev-1) = tauaer400in(1:nlev-1) + tauaer600_ph(1:nlev-1) = tauaer600in(1:nlev-1) + tauaer999_ph(1:nlev-1) = tauaer999in(1:nlev-1) + waer300_ph(1:nlev-1) = waer300in(1:nlev-1) + waer400_ph(1:nlev-1) = waer400in(1:nlev-1) + waer600_ph(1:nlev-1) = waer600in(1:nlev-1) + waer999_ph(1:nlev-1) = waer999in(1:nlev-1) + gaer300_ph(1:nlev-1) = gaer300in(1:nlev-1) + gaer400_ph(1:nlev-1) = gaer400in(1:nlev-1) + gaer600_ph(1:nlev-1) = gaer600in(1:nlev-1) + gaer999_ph(1:nlev-1) = gaer999in(1:nlev-1) + tlay_ph(1:nlev-1) = 0.5_dp*(tlev_ph(1:nlev-1) + tlev_ph(2:nlev)) !---------------------------------------------------- @@ -1082,7 +1221,12 @@ subroutine photo( chem_opt, nlev, njout, julday, gmtp, alat, & o3top, o2top, albedo(:,lu), z_ph, tlev_ph, & tlay_ph, airlev_ph, rh_ph, xlwc_ph, o3_ph, & acb1_ph, acb2_ph, aoc1_ph, aoc2_ph, aant_ph, & - aso4_ph, asal_ph, ftuv, adjcoe, radfld ) + aso4_ph, asal_ph, & + tauaer300_ph, tauaer400_ph, tauaer600_ph, & + tauaer999_ph, waer300_ph, waer400_ph, & + waer600_ph, waer999_ph, gaer300_ph, & + gaer400_ph, gaer600_ph, gaer999_ph, & + aer_ra_feedback, ftuv, adjcoe, radfld ) do n = 1,njout prate(1:nlev-1,n) = ftuv(2:nlev,n) @@ -1091,7 +1235,9 @@ subroutine photo( chem_opt, nlev, njout, julday, gmtp, alat, & deallocate( ftuv, z_ph, tlev_ph, tlay_ph, airlev_ph, rh_ph, xlwc_ph, & o3_ph, acb1_ph, acb2_ph, aoc1_ph, aoc2_ph, aant_ph, aso4_ph, & - asal_ph ) + asal_ph, tauaer300_ph, tauaer400_ph,tauaer600_ph, tauaer999_ph, & + waer300_ph, waer400_ph, waer600_ph, waer999_ph, & + gaer300_ph, gaer400_ph, gaer600_ph, gaer999_ph ) end subroutine photo diff --git a/wrfv2_fire/chem/module_ftuv_subs.F b/wrfv2_fire/chem/module_ftuv_subs.F index dc32526a..ff84b487 100644 --- a/wrfv2_fire/chem/module_ftuv_subs.F +++ b/wrfv2_fire/chem/module_ftuv_subs.F @@ -235,7 +235,10 @@ subroutine photoin( chem_opt, nz, zen, o3toms, esfact, & o3top, o2top, albedo, z, tlev, & tlay, airlev, rh, xlwc, o3, & acb1, acb2, aoc1, aoc2, aant, & - aso4, asal, prate, adjcoe, radfld ) + aso4, asal, tauaer300, tauaer400, tauaer600, & + tauaer999, waer300, waer400, waer600, & + waer999, gaer300, gaer400, gaer600, & + gaer999, aer_ra_feedback, prate, adjcoe, radfld ) use module_wave_data, only : nw, tuv_jmax, deltaw, sflx, & c20, c40, c60, c80, sq @@ -268,6 +271,21 @@ subroutine photoin( chem_opt, nz, zen, o3toms, esfact, & real(dp), intent(in) :: aant(nz) real(dp), intent(in) :: aso4(nz) real(dp), intent(in) :: asal(nz) +! rajesh: declare aerosol optical properties + real(dp), intent(in) :: tauaer300(nz-1) + real(dp), intent(in) :: tauaer400(nz-1) + real(dp), intent(in) :: tauaer600(nz-1) + real(dp), intent(in) :: tauaer999(nz-1) + real(dp), intent(in) :: waer300(nz-1) + real(dp), intent(in) :: waer400(nz-1) + real(dp), intent(in) :: waer600(nz-1) + real(dp), intent(in) :: waer999(nz-1) + real(dp), intent(in) :: gaer300(nz-1) + real(dp), intent(in) :: gaer400(nz-1) + real(dp), intent(in) :: gaer600(nz-1) + real(dp), intent(in) :: gaer999(nz-1) + INTEGER, INTENT(IN) :: aer_ra_feedback + real(dp), intent(out) :: prate(nz,tuv_jmax) real(dp), intent(out) :: adjcoe(nz,tuv_jmax) real(dp), intent(out) :: radfld(nz,nw-1) @@ -316,6 +334,8 @@ subroutine photoin( chem_opt, nz, zen, o3toms, esfact, & real(dp), dimension(nz-1,nw-1) :: dtant, omant, gant real(dp), dimension(nz-1,nw-1) :: dtso4, omso4, gso4 real(dp), dimension(nz-1,nw-1) :: dtsal, omsal, gsal +! rajesh: declare optical property arrays for aerosols + real(dp), dimension(nz-1,nw-1) :: dtaer, omaer, gaer !-------------------------------------------------------------- ! ... spectral irradiance and actinic flux (scalar irradiance): !-------------------------------------------------------------- @@ -349,16 +369,32 @@ subroutine photoin( chem_opt, nz, zen, o3toms, esfact, & !------------------------------------------------------------- ! ... aerosol optical depths ... !------------------------------------------------------------- - call setaer( nz, z, airlev, rh, acb1, & - acb2, aoc1, aoc2, aant, aso4, & - asal, & - dtcb1, omcb1, gcb1, & - dtcb2, omcb2, gcb2, & - dtoc1, omoc1, goc1, & - dtoc2, omoc2, goc2, & - dtant, omant, gant, & - dtso4, omso4, gso4, & - dtsal, omsal, gsal ) +! call setaer( nz, z, airlev, rh, acb1, & +! acb2, aoc1, aoc2, aant, aso4, & +! asal, & +! dtcb1, omcb1, gcb1, & +! dtcb2, omcb2, gcb2, & +! dtoc1, omoc1, goc1, & +! dtoc2, omoc2, goc2, & +! dtant, omant, gant, & +! dtso4, omso4, gso4, & +! dtsal, omsal, gsal ) + +!------------------------------------------------------------ +! rajesh: Conform Aerosol Optical Properties from 4 wavelengths to +! the entire spectra of FTUV +!------------------------------------------------------------ +! Initialize aerosol optical properties to zero + dtaer(:,:) = 0._dp + omaer(:,:) = 0._dp + gaer(:,:) = 0._dp + if(aer_ra_feedback == 1) then + call aer_wrf2ftuv(nz, z, tauaer300, tauaer400, & + tauaer600, tauaer999, waer300, & + waer400, waer600, waer999, & + gaer300, gaer400, gaer600, & + gaer999, dtaer, omaer, gaer ) + endif !------------------------------------------------------------ ! ... photo-chemical and photo-biological weigting functions. @@ -427,13 +463,14 @@ subroutine photoin( chem_opt, nz, zen, o3toms, esfact, & dto3, & ! opt depth of o3 dto2, & ! opt depth of o2 dtcld, omcld, gcld, & ! opt depth of cloud - dtcb1, omcb1, gcb1, & - dtcb2, omcb2, gcb2, & - dtoc1, omoc1, goc1, & - dtoc2, omoc2, goc2, & - dtant, omant, gant, & - dtso4, omso4, gso4, & - dtsal, omsal, gsal, & +! dtcb1, omcb1, gcb1, & +! dtcb2, omcb2, gcb2, & +! dtoc1, omoc1, goc1, & +! dtoc2, omoc2, goc2, & +! dtant, omant, gant, & +! dtso4, omso4, gso4, & +! dtsal, omsal, gsal, & + dtaer, omaer, gaer, & ! pass aerosol optical properties radfld ) ! output of abs. scart flux. !---------------------------------------------------------- ! Interplation the top level @@ -463,6 +500,87 @@ subroutine photoin( chem_opt, nz, zen, o3toms, esfact, & end subroutine photoin +!---------------------------------------------------------------------------- +!rajesh: subroutine to convert aerosol optical properties from 4 +!wavelengths +! to entire spectra of FTUV +!----------------------------------------------------------------------------- + subroutine aer_wrf2ftuv( nzlev, z, tauaer300, tauaer400, & + tauaer600, tauaer999, & + waer300, waer400, waer600, waer999, & + gaer300, gaer400, gaer600, gaer999, & + dtaer, omaer, gaer ) + use module_wave_data, only : nw, wc + +!---------------------------------------------------------------------- +! The routine is based on aerosol treatment in module_ra_rrtmg_sw.F +! INPUT: +! nzlev: number of specified altitude levels in the working grid +! z: specified altitude working grid +! Aerosol optical properties at 300, 400, 600 and 999 nm. +! tauaer300, tauaer400, tauaer600, tauaer999: Layer AODs +! waer300, waer400, waer600, waer999: Layer SSAs +! gaer300, gaer400, gaer600, gaer999: Layer asymmetry parameters + +! OUTPUT: +! dtaer: Layer AOD at FTUV wavelengths +! omaer: Layer SSA at FTUV wavelengths +! gaer : Layer asymmetry parameters at FTUV wavelengths +!------------------------------------------------------------------------ + implicit none + +!----------------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------------- + integer, intent(in) :: nzlev + real(dp), intent(in) :: z(nzlev) + real(dp), intent(in) :: tauaer300(nzlev-1), tauaer400(nzlev-1), & + tauaer600(nzlev-1), tauaer999(nzlev-1) + real(dp), intent(in) :: waer300(nzlev-1), waer400(nzlev-1), & + waer600(nzlev-1), waer999(nzlev-1) + real(dp), intent(in) :: gaer300(nzlev-1), gaer400(nzlev-1), & + gaer600(nzlev-1), gaer999(nzlev-1) +! Output arrays + real(dp), intent(out) :: dtaer(nzlev-1,nw-1), & + omaer(nzlev-1,nw-1), gaer(nzlev-1,nw-1) + +! Local Variables + integer :: k, wn, nloop + real(dp) :: ang, slope + real(dp), parameter :: thresh = 1.e-9_dp + + ang = 0._dp + slope = 0._dp + +! Start Calculation + do wn = 1,nw-1 ! wavelength loop + do k = 1,nzlev-1 ! level loop + +! use angstrom exponent to calculate aerosol optical depth; wc is in nm. + if(tauaer300(k) .gt. thresh .and. tauaer999(k) .gt. thresh) then + ang = log(tauaer300(k)/tauaer999(k))/log(0.999_dp/0.3_dp) + dtaer(k,wn) = tauaer400(k)*(0.4_dp/(wc(wn)*1.e-3_dp))**ang +! print *, ang, dtaer(k,wn), tauaer600(k)*(600./wc(wn))**ang + +! ssa - use linear interpolation/extrapolation + slope = (waer600(k)-waer400(k))/0.2_dp + omaer(k,wn) = slope*((wc(wn)*1.e-3_dp)-0.6_dp)+waer600(k) + if(omaer(k,wn) .lt. 0.4_dp) omaer(k,wn)=0.4_dp + if(omaer(k,wn) .ge. 1.0_dp) omaer(k,wn)=1.0_dp + +! asymmetry parameter - use linear interpolation/extrapolation + slope = (gaer600(k)-gaer400(k))/0.2_dp + gaer(k,wn) = slope*((wc(wn)*1.e-3_dp)-0.6_dp)+gaer600(k) + if(gaer(k,wn) .lt. 0.5_dp) gaer(k,wn) = 0.5_dp + if(gaer(k,wn) .ge. 1.0_dp) gaer(k,wn) = 1.0_dp + endif + enddo ! k + enddo ! wn + + end subroutine aer_wrf2ftuv + +!-------------------------------------------------------------------- + subroutine setaer( nzlev, z, airden, rh, acb1, & acb2, aoc1, aoc2, aant, aso4, & asal, & @@ -1395,9 +1513,10 @@ subroutine setz( nz, cz, tlev, c, ndx, adjcoe ) end do tt = tlev(1)/281._dp do m = 1,tuv_jmax - if( m /= 2 .or. m /= 11 ) then - adjin = 1._dp - else if( m == 2 ) then + adjin = 1._dp +!acd_sw_bugfix 20131205 + if( m == 2 ) then +!acd_sw_bugfix 20131205 !---------------------------------------------------------------------- ! ... temperature modification ! t0.9 (1.05) t0.95(1.025) t1.0(1.0) t1.15(1.02) t1.1(1.04) @@ -1501,9 +1620,12 @@ subroutine setozo( nz, z, tlay, dto3, & ! cz(1:nz-1) = (o3(2:nz)) * 1.e5 * (z(2:nz) - z(1:nz-1)) o3den(1:nz) = o3(1:nz)*airlev(1:nz) - cz(1:nz-1) = 0.5_dp*(o3den(2:nz) + o3den(1:nz-1))*km2cm*(z(2:nz) - z(1:nz-1)) + cz(1:nz-1) = 0.5_dp*(o3den(2:nz) + o3den(1:nz-1))*km2cm*(z(2:nz) - z(1:nz-1)) +!acd_sw_bugfix 20131205 + cz(nz-1) = cz(nz-1) + o3top +!acd_sw_bugfix 20131205 - to3(nz) = o3top + to3(nz) = o3top do k = nz-1,1,-1 to3(k) = to3(k+1) + cz(k) end do @@ -1513,8 +1635,10 @@ subroutine setozo( nz, z, tlay, dto3, & !----------------------------------------------------------------------------- if( o3toms > 0.0_dp ) then scale = o3toms/(to3(1)/2.687e16_dp) - cz(1:nz-1) = cz(1:nz-1)*scale - to3(1:nz) = to3(1:nz)*scale +!acd_sw_bugfix 20131205 + cz(1:nz) = cz(1:nz)*scale +!acd_sw_bugfix 20131205 + to3(1:nz) = to3(1:nz)*scale endif !----------------------------------------------------------------------------- ! ... calculate ozone optical depth for each layer, with temperature @@ -1951,13 +2075,15 @@ subroutine rtlink( nz, & dto3, & dto2, & dtcld, omcld, gcld, & - dtcb1, omcb1, gcb1, & - dtcb2, omcb2, gcb2, & - dtoc1, omoc1, goc1, & - dtoc2, omoc2, goc2, & - dtant, omant, gant, & - dtso4, omso4, gso4, & - dtsal, omsal, gsal, & +! dtcb1, omcb1, gcb1, & +! dtcb2, omcb2, gcb2, & +! dtoc1, omoc1, goc1, & +! dtoc2, omoc2, goc2, & +! dtant, omant, gant, & +! dtso4, omso4, gso4, & +! dtsal, omsal, gsal, & +! rajesh: pass aerosol optical properties + dtaer, omaer, gaer, & radfld ) implicit none @@ -1975,13 +2101,15 @@ subroutine rtlink( nz, & real(dp), intent(in) :: dto3(nz-1,nw-1) real(dp), intent(in) :: dto2(nz-1,nw-1) real(dp), intent(in) :: dtcld(nz-1,nw-1), omcld(nz-1,nw-1), gcld(nz-1,nw-1) - real(dp), intent(in) :: dtcb1(nz-1,nw-1), omcb1(nz-1,nw-1), gcb1(nz-1,nw-1) - real(dp), intent(in) :: dtcb2(nz-1,nw-1), omcb2(nz-1,nw-1), gcb2(nz-1,nw-1) - real(dp), intent(in) :: dtoc1(nz-1,nw-1), omoc1(nz-1,nw-1), goc1(nz-1,nw-1) - real(dp), intent(in) :: dtoc2(nz-1,nw-1), omoc2(nz-1,nw-1), goc2(nz-1,nw-1) - real(dp), intent(in) :: dtant(nz-1,nw-1), omant(nz-1,nw-1), gant(nz-1,nw-1) - real(dp), intent(in) :: dtso4(nz-1,nw-1), omso4(nz-1,nw-1), gso4(nz-1,nw-1) - real(dp), intent(in) :: dtsal(nz-1,nw-1), omsal(nz-1,nw-1), gsal(nz-1,nw-1) +! real(dp), intent(in) :: dtcb1(nz-1,nw-1), omcb1(nz-1,nw-1), gcb1(nz-1,nw-1) +! real(dp), intent(in) :: dtcb2(nz-1,nw-1), omcb2(nz-1,nw-1), gcb2(nz-1,nw-1) +! real(dp), intent(in) :: dtoc1(nz-1,nw-1), omoc1(nz-1,nw-1), goc1(nz-1,nw-1) +! real(dp), intent(in) :: dtoc2(nz-1,nw-1), omoc2(nz-1,nw-1), goc2(nz-1,nw-1) +! real(dp), intent(in) :: dtant(nz-1,nw-1), omant(nz-1,nw-1), gant(nz-1,nw-1) +! real(dp), intent(in) :: dtso4(nz-1,nw-1), omso4(nz-1,nw-1), gso4(nz-1,nw-1) +! real(dp), intent(in) :: dtsal(nz-1,nw-1), omsal(nz-1,nw-1), gsal(nz-1,nw-1) +! rajesh: declare dust optical properties + real(dp), intent(in) :: dtaer(nz-1,nw-1), omaer(nz-1,nw-1), gaer(nz-1,nw-1) real(dp), intent(out) :: radfld(nz,nw-1) !----------------------------------------------------------------------- ! ... local variables @@ -1990,13 +2118,15 @@ subroutine rtlink( nz, & integer :: i, ii, iw real(dp) :: dtsct, dtabs real(dp) :: dscld, dacld - real(dp) :: dscb1, dacb1 - real(dp) :: dscb2, dacb2 - real(dp) :: dsoc1, daoc1 - real(dp) :: dsoc2, daoc2 - real(dp) :: dsant, daant - real(dp) :: dsso4, daso4 - real(dp) :: dssal, dasal +! real(dp) :: dscb1, dacb1 +! real(dp) :: dscb2, dacb2 +! real(dp) :: dsoc1, daoc1 +! real(dp) :: dsoc2, daoc2 +! real(dp) :: dsant, daant +! real(dp) :: dsso4, daso4 +! real(dp) :: dssal, dasal +! rajesh: declare scattering and absorbing optical depths + real(dp) :: dsaer, daaer real(dp), dimension(nz-1,nw-1) :: dt, om, g !----------------------------------------------------------------------- ! ... set any coefficients specific to rt scheme @@ -2007,31 +2137,34 @@ subroutine rtlink( nz, & dscld = dtcld(i,iw)*omcld(i,iw) dacld = dtcld(i,iw)*(1._dp - omcld(i,iw)) - dscb1 = dtcb1(i,iw)*omcb1(i,iw) - dacb1 = dtcb1(i,iw)*(1._dp - omcb1(i,iw)) +! dscb1 = dtcb1(i,iw)*omcb1(i,iw) +! dacb1 = dtcb1(i,iw)*(1._dp - omcb1(i,iw)) - dscb2 = dtcb2(i,iw)*omcb2(i,iw) - dacb2 = dtcb2(i,iw)*(1._dp - omcb2(i,iw)) +! dscb2 = dtcb2(i,iw)*omcb2(i,iw) +! dacb2 = dtcb2(i,iw)*(1._dp - omcb2(i,iw)) - dsoc1 = dtoc1(i,iw)*omoc1(i,iw) - daoc1 = dtoc1(i,iw)*(1._dp - omoc1(i,iw)) +! dsoc1 = dtoc1(i,iw)*omoc1(i,iw) +! daoc1 = dtoc1(i,iw)*(1._dp - omoc1(i,iw)) - dsoc2 = dtoc2(i,iw)*omoc2(i,iw) - daoc2 = dtoc2(i,iw)*(1._dp - omoc2(i,iw)) +! dsoc2 = dtoc2(i,iw)*omoc2(i,iw) +! daoc2 = dtoc2(i,iw)*(1._dp - omoc2(i,iw)) - dsant = dtant(i,iw)*omant(i,iw) - daant = dtant(i,iw)*(1._dp - omant(i,iw)) +! dsant = dtant(i,iw)*omant(i,iw) +! daant = dtant(i,iw)*(1._dp - omant(i,iw)) - dsso4 = dtso4(i,iw)*omso4(i,iw) - daso4 = dtso4(i,iw)*(1._dp - omso4(i,iw)) +! dsso4 = dtso4(i,iw)*omso4(i,iw) +! daso4 = dtso4(i,iw)*(1._dp - omso4(i,iw)) - dssal = dtsal(i,iw)*omsal(i,iw) - dasal = dtsal(i,iw)*(1._dp - omsal(i,iw)) +! dssal = dtsal(i,iw)*omsal(i,iw) +! dasal = dtsal(i,iw)*(1._dp - omsal(i,iw)) - dtsct = dtrl(i,iw) + dscld + & - dscb1 + dscb2 + dsoc1 + dsoc2 + dsant + dsso4 + dssal - dtabs = dto3(i,iw) + dto2(i,iw) + dacld + & - dacb1 + dacb2 + daoc1 + daoc2 + daant + daso4 + dasal +! rajesh: determine scattering and absorption optical depths for dust + dsaer = dtaer(i,iw)*omaer(i,iw) + daaer = dtaer(i,iw)*(1._dp - omaer(i,iw)) + dtsct = dtrl(i,iw) + dscld + dsaer +! dscb1 + dscb2 + dsoc1 + dsoc2 + dsant + dsso4 + dssal + dtabs = dto3(i,iw) + dto2(i,iw) + dacld + daaer +! dacb1 + dacb2 + daoc1 + daoc2 + daant + daso4 + dasal dtabs = max( dtabs,smallest ) dtsct = max( dtsct,smallest ) @@ -2044,19 +2177,21 @@ subroutine rtlink( nz, & if( dtsct /= smallest ) then om(ii,iw) = dtsct/(dtsct + dtabs) g(ii,iw) = ( gcld(i,iw)*dscld + & - gcb1(i,iw)*dscb1 + & - gcb2(i,iw)*dscb2 + & - goc1(i,iw)*dsoc1 + & - goc2(i,iw)*dsoc2 + & - gant(i,iw)*dsant + & - gso4(i,iw)*dsso4 + & - gsal(i,iw)*dssal ) / dtsct +! gcb1(i,iw)*dscb1 + & +! gcb2(i,iw)*dscb2 + & +! goc1(i,iw)*dsoc1 + & +! goc2(i,iw)*dsoc2 + & +! gant(i,iw)*dsant + & +! gso4(i,iw)*dsso4 + & +! rajesh: add aerosol contribution + gaer(i,iw)*dsaer ) / dtsct g(ii,iw) = max( smallest, g(ii,iw) ) g(ii,iw) = min( 1.d0, g(ii,iw) ) else om(ii,iw) = smallest g(ii,iw) = smallest end if +! print *, dt(ii,iw), om(ii,iw), g(ii,iw) end do end do diff --git a/wrfv2_fire/chem/module_gocart_drydep.F b/wrfv2_fire/chem/module_gocart_drydep.F index f17f39a9..2db74d49 100644 --- a/wrfv2_fire/chem/module_gocart_drydep.F +++ b/wrfv2_fire/chem/module_gocart_drydep.F @@ -7,6 +7,9 @@ subroutine gocart_drydep_driver(dtstep, & t_phy,moist,p8w,t8w,rmol,aer_res, & p_phy,chem,rho_phy,dz8w,ddvel,xland,hfx, & ivgtyp,tsk,vegfra,pbl,ust,znt,xlat,xlong, & + dustdrydep_1,dustdrydep_2,dustdrydep_3, & + dustdrydep_4,dustdrydep_5, & + depvelocity, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -48,6 +51,9 @@ subroutine gocart_drydep_driver(dtstep, & rmol,xland,znt,hfx REAL, DIMENSION( its:ite, jts:jte ), & INTENT(IN) :: aer_res + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: & + dustdrydep_1, dustdrydep_2, dustdrydep_3, & + dustdrydep_4, dustdrydep_5, depvelocity !! .. Local Scalars .. INTEGER :: iland, iprt, iseason, jce, jcs, & @@ -109,6 +115,15 @@ subroutine gocart_drydep_driver(dtstep, & enddo ddvel(i,j,p_sulf) = real( dvel(1,1),kind=4 ) ddvel(i,j,p_msa) = real( dvel(1,1),kind=4 ) + + depvelocity(i,j) = ddvel(i,j,p_dust_5) +! drydep [ug/m2/s] = dvel [m/s] * chem [ug/kg] * airden [kg/m3] + dustdrydep_1(i,j)=-dvel(1,1)*chem(i,1,j,p_dust_1)*airden(1,1) + dustdrydep_2(i,j)=-dvel(1,1)*chem(i,1,j,p_dust_2)*airden(1,1) + dustdrydep_3(i,j)=-dvel(1,1)*chem(i,1,j,p_dust_3)*airden(1,1) + dustdrydep_4(i,j)=-dvel(1,1)*chem(i,1,j,p_dust_4)*airden(1,1) + dustdrydep_5(i,j)=-dvel(1,1)*chem(i,1,j,p_dust_5)*airden(1,1) + enddo enddo diff --git a/wrfv2_fire/chem/module_gocart_settling.F b/wrfv2_fire/chem/module_gocart_settling.F index f65ba12f..457d2c73 100644 --- a/wrfv2_fire/chem/module_gocart_settling.F +++ b/wrfv2_fire/chem/module_gocart_settling.F @@ -1,169 +1,211 @@ MODULE MODULE_GOCART_SETTLING +! +! Original GOCART +! KYKang, MKlose, CLWu various changes +! YShao [2011/09/30] complete update +! CONTAINS -SUBROUTINE gocart_settling_driver(dt,config_flags,t_phy,moist, & - chem,rho_phy,dz8w,p8w,p_phy, & - dustin,seasin,dx,g, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) +SUBROUTINE gocart_settling_driver(dt,config_flags,t_phy,moist, & + chem,rho_phy,dz8w,p8w,p_phy, & + dustin,seasin,dx,g, & + dustgraset_1,dustgraset_2,dustgraset_3, & + dustgraset_4,dustgraset_5, & + setvel_1,setvel_2,setvel_3,setvel_4,setvel_5,imod, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) + USE module_configure USE module_state_description USE module_data_gocart_dust USE module_data_gocart_seas USE module_model_constants, ONLY: mwdry IMPLICIT NONE - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - INTEGER, INTENT(IN ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & - INTENT(IN ) :: moist - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: t_phy,p_phy,dz8w,p8w,rho_phy - REAL, DIMENSION( ims:ime , jms:jme, 5 ), & - INTENT(IN ) :: dustin,seasin - - REAL, INTENT(IN ) :: dt,dx,g - integer :: kkk,nmx,i,j,k,kk,lmx,iseas,idust - real*8, DIMENSION (1,1,kte-kts+1) :: tmp,airden,airmas,p_mid,delz,rh - real*8, DIMENSION (1,1,kte-kts+1,5) :: ddust - real*8, DIMENSION (1,1,kte-kts+1,4) :: sea_salt + + TYPE(grid_config_rec_type), INTENT(IN) :: config_flags + + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION(ims:ime,kms:kme,jms:jme,num_moist), INTENT(IN) :: moist + REAL, DIMENSION(ims:ime,kms:kme,jms:jme,num_chem), INTENT(INOUT) :: chem + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: t_phy,p_phy,dz8w,p8w,rho_phy + REAL, DIMENSION( ims:ime , jms:jme, 5 ), & + INTENT(IN ) :: dustin,seasin + + INTEGER, INTENT(IN) :: imod + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT):: & + dustgraset_1,dustgraset_2,dustgraset_3, & + dustgraset_4,dustgraset_5, & + setvel_1,setvel_2,setvel_3,setvel_4,setvel_5 + + REAL*8, DIMENSION (1,1,5) :: graset_dust,grasetvel_dust + REAL*8, DIMENSION (1,1,4) :: graset_ss,grasetvel_ss + + REAL, INTENT(IN) :: dt,dx,g + INTEGER :: kkk,nmx,i,j,k,kk,lmx,iseas,idust + REAL*8, DIMENSION (1,1,kte-kts+1) :: tmp,airden,p_mid,delz,rh + REAL*8, DIMENSION (1,1,kte-kts+1,5) :: ddust + REAL*8, DIMENSION (1,1,kte-kts+1,4) :: sea_salt + + INTEGER :: uoc_flag ! flag for UoC dust schemes ! -! bstl is for budgets +! REAL*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) +! REAL*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) +! REAL*8, DIMENSION (4), PARAMETER :: den_seas(4)=(/2200.,2200.,2200.,2290./) +! REAL*8, DIMENSION (4), PARAMETER :: reff_seas(4)=(/0.30D-6,1.00D-6,3.25D-6,7.50D-6/) +! + REAL*8 conver, converi + conver=1.e-9 + converi=1.e9 + + uoc_flag = 0 + if (config_flags%dust_opt .eq. 4) uoc_flag = 1 + + lmx=kte-kts+1 + + do j=jts,jte + do i=its,ite + + IF(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11) THEN + do kkk=1,5 + ddust(1,1,kts,kkk)=dustin(i,j,kkk)*conver + enddo + kk=0 + do k=kts,kte + kk=kk+1 + + p_mid(1,1,kk) =.01*p_phy(i,kte-k+kts,j) + delz(1,1,kk) =dz8w(i,kte-k+kts,j) + airden(1,1,kk)=rho_phy(i,k,j) + tmp(1,1,kk)= t_phy(i,k,j) + rh(1,1,kk) = .95 + rh(1,1,kk) = MIN( .95, moist(i,k,j,p_qv) / & + (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & + (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) + rh(1,1,kk) = max(1.0D-1,rh(1,1,kk)) + enddo + ELSE + kk=0 + DO k=kts,kte + kk=kk+1 ! -! real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) -! real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) -! real*8, DIMENSION (4), PARAMETER :: den_seas(4)=(/2200.,2200.,2200.,2290./) -! real*8, DIMENSION (4), PARAMETER :: reff_seas(4)=(/0.30D-6,1.00D-6,3.25D-6,7.50D-6/) - real*8, DIMENSION (5) :: bstl_dust - real*8, DIMENSION (4) :: bstl_seas - real*8 conver,converi - conver=1.e-9 - converi=1.e9 - lmx=kte-kts+1 - ddust(:,:,:,:)=0. - sea_salt(:,:,:,:)=0. - do j=jts,jte - do i=its,ite - kk=0 - bstl_dust(:)=0. - bstl_seas(:)=0. - if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11) then - do kkk=1,5 - ddust(1,1,kts,kkk)=dustin(i,j,kkk)*conver - enddo - else - do k=kts,kte - kk=kk+1 - ddust(1,1,kk,1)=chem(i,k,j,p_dust_1)*conver - ddust(1,1,kk,2)=chem(i,k,j,p_dust_2)*conver - ddust(1,1,kk,3)=chem(i,k,j,p_dust_3)*conver - ddust(1,1,kk,4)=chem(i,k,j,p_dust_4)*conver - ddust(1,1,kk,5)=chem(i,k,j,p_dust_5)*conver - enddo - endif - kk=0 - do k=kts,kte - kk=kk+1 - p_mid(1,1,kk)=.01*p_phy(i,kte-k+kts,j) - delz(1,1,kk)=dz8w(i,kte-k+kts,j) - airmas(1,1,kk)=-(p8w(i,k+1,j)-p8w(i,k,j))*dx*dx/g - airden(1,1,kk)=rho_phy(i,k,j) - tmp(1,1,kk)=t_phy(i,k,j) - rh(1,1,kk) = .95 - rh(1,1,kk) = MIN( .95, moist(i,k,j,p_qv) / & - (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & - (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) - rh(1,1,kk)=max(1.0D-1,rh(1,1,kk)) + ddust(1,1,kk,1)=chem(i,k,j,p_dust_1) ! chem and dust in [ug/kg] + ddust(1,1,kk,2)=chem(i,k,j,p_dust_2) + ddust(1,1,kk,3)=chem(i,k,j,p_dust_3) + ddust(1,1,kk,4)=chem(i,k,j,p_dust_4) + ddust(1,1,kk,5)=chem(i,k,j,p_dust_5) + + p_mid(1,1,kk)=.01*p_phy(i,kte-k+kts,j) + delz(1,1,kk)=dz8w(i,kte-k+kts,j) ! delz(1) = dz8w(kte), delz(lmx)=dz8w(kts) + airden(1,1,kk)=rho_phy(i,k,j) + tmp(1,1,kk) =t_phy(i,k,j) + rh(1,1,kk) = .95 + rh(1,1,kk) = MIN( .95, moist(i,k,j,p_qv) / & + (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & + (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j)))) + rh(1,1,kk)=max(1.0D-1,rh(1,1,kk)) + ENDDO + ENDIF + graset_dust(1,1,:)=0. + graset_ss(1,1,:)=0. + + iseas=0 + idust=1 + CALL settling(1,1,lmx,5,g,dyn_visc,ddust,tmp,p_mid,delz, & + imod,graset_dust,grasetvel_dust, uoc_flag, & + den_dust,reff_dust,dt,rh,idust,iseas) + + IF (config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) THEN + kk=1 + do kkk=1,5 + if (kkk .le. 4) sea_salt(1,1,kts,kkk)=seasin(i,j,kkk)*conver + if(ddust(1,1,kk,kkk) .ge. dustin(i,j,kkk)) ddust(1,1,kk,kkk)=dustin(i,j,kkk) enddo -! tmp(1,1,1)=244.3541 -! tmp(1,1,1)=246.72290 -! tmp(1,1,3)=245.79040 -!den= 2650.00000000000 -!reff= 8.000000000000000E-006 - - iseas=0 - idust=1 - - call settling(1, 1, lmx, 5,g,dyn_visc, & - ddust, tmp, p_mid, delz, airmas, & - den_dust, reff_dust, dt, bstl_dust, rh, idust, iseas) - if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then - do kkk=1,4 - sea_salt(1,1,kts,kkk)=seasin(i,j,kkk)*conver - enddo - kk=1 - do kkk=1,5 - if(ddust(1,1,kk,kkk) .ge. dustin(i,j,kkk))ddust(1,1,kk,kkk)=dustin(i,j,kkk) - enddo - chem(i,kts,j,p_p25i)=chem(i,kts,j,p_p25i) & - +.25*(ddust(1,1,kk,1)+.286*ddust(1,1,kk,2))*converi - chem(i,kts,j,p_p25i)=max(chem(i,kts,j,p_p25i),1.e-16) - chem(i,kts,j,p_p25j)=chem(i,kts,j,p_p25j) & - +.75*(ddust(1,1,kk,1)+.286*ddust(1,1,kk,2))*converi - chem(i,kts,j,p_p25j)=max(chem(i,kts,j,p_p25j),1.e-16) - chem(i,kts,j,p_soila)=chem(i,kts,j,p_soila) & - +(.714*ddust(1,1,kk,2)+ddust(1,1,kk,3))*converi - chem(i,kts,j,p_soila)=max(chem(i,kts,j,p_soila),1.e-16) - else - kk=0 - do k=kts,kte - kk=kk+1 - chem(i,k,j,p_dust_1)=ddust(1,1,kk,1)*converi - chem(i,k,j,p_dust_2)=ddust(1,1,kk,2)*converi - chem(i,k,j,p_dust_3)=ddust(1,1,kk,3)*converi - chem(i,k,j,p_dust_4)=ddust(1,1,kk,4)*converi - chem(i,k,j,p_dust_5)=ddust(1,1,kk,5)*converi - sea_salt(1,1,kk,1)=chem(i,k,j,p_seas_1)*conver - sea_salt(1,1,kk,2)=chem(i,k,j,p_seas_2)*conver - sea_salt(1,1,kk,3)=chem(i,k,j,p_seas_3)*conver - sea_salt(1,1,kk,4)=chem(i,k,j,p_seas_4)*conver - enddo - endif -! write(0,*)i,j,bstl_dust(3),bstl_dust(4),chem(i,1,j,p_dust_4) - iseas=1 - idust=0 - call settling(1, 1, lmx, 4, g,dyn_visc,& - sea_salt, tmp, p_mid, delz, airmas, & - den_seas, reff_seas, dt, bstl_seas, rh, idust, iseas) - if(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then - kk=1 - do kkk=1,4 - if(sea_salt(1,1,kk,kkk) .ge. seasin(i,j,kkk))sea_salt(1,1,kk,kkk)=seasin(i,j,kkk) - enddo - chem(i,kts,j,p_naai)=chem(i,kts,j,p_naai) & - +.25*(sea_salt(1,1,kk,1)+.942*sea_salt(1,1,kk,2))*converi - chem(i,kts,j,p_naai)=max(1.e-16,chem(i,kts,j,p_naai)) - chem(i,kts,j,p_naaj)=chem(i,kts,j,p_naaj) & - +.75*(sea_salt(1,1,kk,1)+.942*sea_salt(1,1,kk,2))*converi - chem(i,kts,j,p_naaj)=max(1.e-16,chem(i,kts,j,p_naaj)) - chem(i,kts,j,p_seas)=chem(i,kts,j,p_seas) & - +(.058*sea_salt(1,1,kk,2)+sea_salt(1,1,kk,3))*converi - chem(i,kts,j,p_seas)=max(1.e-16,chem(i,kts,j,p_seas)) - else - kk=0 - do k=kts,kte - kk=kk+1 - chem(i,k,j,p_seas_1)=sea_salt(1,1,kk,1)*converi - chem(i,k,j,p_seas_2)=sea_salt(1,1,kk,2)*converi - chem(i,k,j,p_seas_3)=sea_salt(1,1,kk,3)*converi - chem(i,k,j,p_seas_4)=sea_salt(1,1,kk,4)*converi + chem(i,kts,j,p_p25i)=chem(i,kts,j,p_p25i) & + +.25*(ddust(1,1,kk,1)+.286*ddust(1,1,kk,2))*converi + chem(i,kts,j,p_p25i)=max(chem(i,kts,j,p_p25i),1.e-16) + chem(i,kts,j,p_p25j)=chem(i,kts,j,p_p25j) & + +.75*(ddust(1,1,kk,1)+.286*ddust(1,1,kk,2))*converi + chem(i,kts,j,p_p25j)=max(chem(i,kts,j,p_p25j),1.e-16) + chem(i,kts,j,p_soila)=chem(i,kts,j,p_soila) & + +(.714*ddust(1,1,kk,2)+ddust(1,1,kk,3))*converi + chem(i,kts,j,p_soila)=max(chem(i,kts,j,p_soila),1.e-16) + ELSE + kk = 0 + DO k = kts,kte + kk = kk+1 + chem(i,k,j,p_dust_1)=ddust(1,1,kk,1) ! dust for size bin 1 [ug/kg] + chem(i,k,j,p_dust_2)=ddust(1,1,kk,2) ! ... + chem(i,k,j,p_dust_3)=ddust(1,1,kk,3) ! ... + chem(i,k,j,p_dust_4)=ddust(1,1,kk,4) ! ... + chem(i,k,j,p_dust_5)=ddust(1,1,kk,5) ! dust for size bin 5 (dust_opt 3: for all size bins) [ug/kg] + + sea_salt(1,1,kk,1)=chem(i,k,j,p_seas_1) ! salt [ug/kg] + sea_salt(1,1,kk,2)=chem(i,k,j,p_seas_2) + sea_salt(1,1,kk,3)=chem(i,k,j,p_seas_3) + sea_salt(1,1,kk,4)=chem(i,k,j,p_seas_4) + ENDDO + ENDIF +! +! gravitional settling in [ug/m2/s]; from settling, graset_dust in [ug/kg][m/s] +! + dustgraset_1(i,j)=graset_dust(1,1,1)*airden(1,1,1)*(-1.d0) + dustgraset_2(i,j)=graset_dust(1,1,2)*airden(1,1,1)*(-1.d0) + dustgraset_3(i,j)=graset_dust(1,1,3)*airden(1,1,1)*(-1.d0) + dustgraset_4(i,j)=graset_dust(1,1,4)*airden(1,1,1)*(-1.d0) + dustgraset_5(i,j)=graset_dust(1,1,5)*airden(1,1,1)*(-1.d0) + + setvel_1(i,j)=grasetvel_dust(1,1,1) ! settling velocity [m/s] + setvel_2(i,j)=grasetvel_dust(1,1,2) + setvel_3(i,j)=grasetvel_dust(1,1,3) + setvel_4(i,j)=grasetvel_dust(1,1,4) + setvel_5(i,j)=grasetvel_dust(1,1,5) + + iseas=1 + idust=0 + + CALL settling(1,1,lmx,4,g,dyn_visc,sea_salt,tmp,p_mid,delz, & + imod,graset_ss,grasetvel_ss, uoc_flag, & + den_seas,reff_seas,dt,rh,idust,iseas) + IF (config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) THEN + kk=1 + do kkk=1,4 + if(sea_salt(1,1,kk,kkk) .ge. seasin(i,j,kkk))sea_salt(1,1,kk,kkk)=seasin(i,j,kkk) enddo - endif - enddo - enddo -END SUBROUTINE gocart_settling_driver + chem(i,kts,j,p_naai)=chem(i,kts,j,p_naai) & + +.25*(sea_salt(1,1,kk,1)+.942*sea_salt(1,1,kk,2))*converi + chem(i,kts,j,p_naai)=max(1.e-16,chem(i,kts,j,p_naai)) + chem(i,kts,j,p_naaj)=chem(i,kts,j,p_naaj) & + +.75*(sea_salt(1,1,kk,1)+.942*sea_salt(1,1,kk,2))*converi + chem(i,kts,j,p_naaj)=max(1.e-16,chem(i,kts,j,p_naaj)) + chem(i,kts,j,p_seas)=chem(i,kts,j,p_seas) & + +(.058*sea_salt(1,1,kk,2)+sea_salt(1,1,kk,3))*converi + chem(i,kts,j,p_seas)=max(1.e-16,chem(i,kts,j,p_seas)) + ELSE + kk=0 + DO k=kts,kte + kk=kk+1 + chem(i,k,j,p_seas_1)=sea_salt(1,1,kk,1) + chem(i,k,j,p_seas_2)=sea_salt(1,1,kk,2) + chem(i,k,j,p_seas_3)=sea_salt(1,1,kk,3) + chem(i,k,j,p_seas_4)=sea_salt(1,1,kk,4) + ENDDO + ENDIF + + enddo ! i + enddo ! j + + END SUBROUTINE gocart_settling_driver + + subroutine settling(imx,jmx,lmx,nmx,g0,dyn_visc,tc,tmp,p_mid,delz, & + imod,graset, grasetvel, uoc, & + den,reff,dt,rh,idust,iseas) - subroutine settling(imx,jmx, lmx, nmx,g0,dyn_visc, & - tc, tmp, p_mid, delz, airmas, & - den, reff, dt, bstl, rh, idust, iseas) ! **************************************************************************** ! * * ! * Calculate the loss by settling, using an implicit method * @@ -176,164 +218,166 @@ subroutine settling(imx,jmx, lmx, nmx,g0,dyn_visc, & ! * * ! **************************************************************************** - IMPLICIT NONE INTEGER, INTENT(IN) :: imx, jmx, lmx, nmx,iseas,idust - INTEGER :: ntdt - REAL, INTENT(IN) :: dt,g0,dyn_visc - REAL*8, INTENT(IN) :: tmp(imx,jmx,lmx), delz(imx,jmx,lmx), & - airmas(imx,jmx,lmx), rh(imx,jmx,lmx), & - den(nmx), reff(nmx), p_mid(imx,jmx,lmx) + INTEGER :: ntdt + REAL, INTENT(IN) :: dt,g0,dyn_visc + REAL*8, INTENT(IN) :: tmp(imx,jmx,lmx), delz(imx,jmx,lmx), & + rh(imx,jmx,lmx), p_mid(imx,jmx,lmx) +! + REAL*8 :: den(nmx), reff(nmx) + REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) - REAL*8, INTENT(OUT) :: bstl(imx,jmx,nmx) - REAL*8 :: tc1(imx,jmx,lmx,nmx), dt_settl(nmx), rcm(nmx), rho(nmx) - INTEGER :: ndt_settl(nmx) + INTEGER, INTENT(IN) :: imod, uoc + REAL*8, INTENT(INOUT) :: graset(imx,jmx,nmx) + REAL*8, INTENT(OUT) :: grasetvel(imx,jmx,nmx) + + REAL*8 :: dt_settl(nmx), rcm(nmx), rho(nmx) + INTEGER :: ndt_settl(nmx) REAL*8 :: dzmin, vsettl, dtmax, pres, rhb, rwet(nmx), ratio_r(nmx) - REAL*8 :: c_stokes, free_path, c_cun, viscosity, vd_cor, growth_fac - INTEGER :: k, n, i, j, l, l2 - ! for sea-salt: + REAL*8 :: c_stokes, free_path, c_cun, viscosity, growth_fac + REAL*8 :: vd_cor(lmx), vd_wk1, vd_wk2 + INTEGER :: k, n, i, j, l, l2 + +! for sea-salt: REAL*8, PARAMETER :: c1=0.7674, c2=3.079, c3=2.573E-11, c4=-1.424 - ! for OMP: +! for OMP: REAL*8 :: rwet_priv(nmx), rho_priv(nmx) - ! executable statements - ! IF (type) /= 'dust' .AND. TRIM(aero_type) /= 'sea_salt') RETURN - if(idust.ne.1.and.iseas.ne.1)return - -!!! WHERE (tc(:,:,:,:) < 0.0) tc(:,:,:,:) = 1.0E-32 + IF ( idust.ne.1 .and. iseas.ne.1 ) RETURN + WHERE ( tc(:,:,:,:) < 0.0 ) tc(:,:,:,:) = 1.0D-32 dzmin = MINVAL(delz(:,:,:)) - IF (idust == 1) growth_fac = 1.0 - IF (iseas == 1) growth_fac = 3.0 - - DO k = 1,nmx - - ! Settling velocity (m/s) for each tracer (Stokes Law) - ! DEN density (kg/m3) - ! REFF effective radius (m) - ! dyn_visc dynamic viscosity (kg/m/s) - ! g0 gravity (m/s2) - ! 3.0 corresponds to a growth of a factor 3 of radius with 100% RH - ! 0.5 upper limit with temp correction - - tc1(:,:,:,k) = tc(:,:,:,k) - vsettl = 2.0/9.0 * g0 * den(k) * (growth_fac*reff(k))**2 / & - (0.5*dyn_visc) - - ! Determine the maximum time-step satisying the CFL condition: - ! dt <= (dz)_min / v_settl - ntdt=INT(dt) + IF (idust == 1) growth_fac = 1.0 + IF (iseas == 1) growth_fac = 3.0 +! +! For dust_opt = 4 (UoC dust): +! Change dust radius according to the size cut in module_qf03.F +! Size cut: 2.5, 5, 10, 20 [um] in diameter, so far only 4 size bins +! chem(i,k,j,p_dust_5) is for the sum over the size bins; +! So update chem(i,k,j,p_dust_5) by summation of chem(i,k,j,p_dust_1)...(p_dust_4). +! The fifth component of reff_dust is meaningless. +! + IF (idust == 1 .and. uoc == 1) then + reff(1) = 1.25D-6 + reff(2) = 2.5D-6 + reff(3) = 5.0D-6 + reff(4) = 10.0D-6 + den(1) = 2560. !also, change dust density for the first size bin + ENDIF + + DO k = 1, nmx ! k for different size bins +! +! Settling velocity (m/s) for each tracer (Stokes Law) +! DEN density (kg/m3) +! REFF effective radius (m) +! dyn_visc dynamic viscosity (kg/m/s) +! g0 gravity (m/s2) +! 3.0 corresponds to a growth of a factor 3 of radius with 100% RH +! 0.5 upper limit with temp correction +! + vsettl = 4.0/9.0 * g0 * den(k) * (growth_fac*reff(k))**2 / dyn_visc +! +! Determine the maximum time-step satisying CFL: dt <= (dz)_min / v_settl +! + ntdt = INT(dt) dtmax = dzmin / vsettl - ndt_settl(k) = MAX( 1, INT( ntdt /dtmax) ) - ! limit maximum number of iterations + ndt_settl(k) = MAX( 1,INT(ntdt/dtmax) ) + +! Limit maximum number of iterations IF (ndt_settl(k) > 12) ndt_settl(k) = 12 dt_settl(k) = REAL(ntdt) / REAL(ndt_settl(k)) - ! Particles radius in centimeters +! Particles radius in centimeters IF (iseas.eq.1)rcm(k) = reff(k)*100.0 - IF (idust.eq.1)then - rwet(k) = reff(k) - ratio_r(k) = 1.0 - rho(k) = den(k) - endif - END DO + IF (idust.eq.1) THEN + rwet(k) = reff(k) + ratio_r(k) = 1.0 + rho(k) = den(k) + ENDIF + ENDDO - ! Solve the bidiagonal matrix (l,l) +! Solve the bidiagonal matrix (l,l) !$OMP PARALLEL DO & !$OMP DEFAULT( SHARED ) & !$OMP PRIVATE( i, j, l, l2, n, k, rhb, rwet_priv, ratio_r, c_stokes)& !$OMP PRIVATE( free_path, c_cun, viscosity, rho_priv, vd_cor ) - ! Loop over latitudes - DO j = 1,jmx - - DO k = 1,nmx +! Loop over latitudes + + DO j = 1,jmx ! lat loop + DO i = 1,imx ! lon loop + DO k = 1,nmx ! bin loop + graset(i,j,k)=0. + grasetvel(i,j,k)=0. + IF (idust.eq.1) THEN rwet_priv(k) = rwet(k) rho_priv(k) = rho(k) END IF - DO n = 1,ndt_settl(k) - - ! Solve each vertical layer successively (layer l) - - DO l = lmx,1,-1 - l2 = lmx - l + 1 - -! DO j = 1,jmx - DO i = 1,imx - - IF (iseas.eq.1) THEN - rhb = MIN(9.9D-1, rh(i,j,l)) - ! Aerosol growth with relative humidity (Gerber, 1985) -! td -! changed to LOG10 - rwet_priv(k) = 0.01*(c1*rcm(k)**c2/(c3*rcm(k)**c4 - & - LOG10(rhb)) + rcm(k)**3)**0.33 - ratio_r(k) = (reff(k)/rwet_priv(k))**3.0 - END IF - - ! Dynamic viscosity - c_stokes = 1.458E-6 * tmp(i,j,l)**1.5/(tmp(i,j,l) + 110.4) - - ! Mean free path as a function of pressure (mb) and - ! temperature (K) - ! order of p_mid is top->sfc - free_path = 1.1E-3/p_mid(i,j,l2)/SQRT(tmp(i,j,l)) -!!! free_path = 1.1E-3/p_edge(i,j,l2)/SQRT(tmp(i,j,l)) - - ! Slip Correction Factor - c_cun = 1.0+ free_path/rwet_priv(k)* & - (1.257 + 0.4*EXP(-1.1*rwet_priv(k)/free_path)) - - ! Corrected dynamic viscosity (kg/m/s) - viscosity = c_stokes / c_cun - - ! Settling velocity - IF (iseas.eq.1) THEN - rho_priv(k) = ratio_r(k)*den(k) + (1.0 - ratio_r(k))*1000.0 - END IF - - vd_cor = 2.0/9.0*g0*rho_priv(k)*rwet_priv(k)**2/viscosity - - ! Update mixing ratio - ! Order of delz is top->sfc - IF (l == lmx) THEN - tc(i,j,l,k) = tc(i,j,l,k) / & - (1.0 + dt_settl(k)*vd_cor/delz(i,j,l2)) - ELSE - tc(i,j,l,k) = 1.0/(1.0+dt_settl(k)*vd_cor/delz(i,j,l2))& - *(tc(i,j,l,k) + dt_settl(k)*vd_cor /delz(i,j,l2-1) & - * tc(i,j,l+1,k)) - END IF - END DO !i -! END DO !j - END DO !l - - END DO !n - END DO !k - - END DO !j + DO n = 1,ndt_settl(k) ! time loop + DO l = lmx,1,-1 ! height loop, from top + l2 = lmx - l + 1 + + IF (iseas.eq.1) THEN + rhb = MIN(9.9D-1, rh(i,j,l)) ! Aerosol growth with relative humidity (Gerber, 1985) + rwet_priv(k) = 0.01*(c1*rcm(k)**c2/(c3*rcm(k)**c4 - & + LOG10(rhb)) + rcm(k)**3)**0.33 ! td changed to LOG10 + ratio_r(k) = (reff(k)/rwet_priv(k))**3.0 + END IF + + c_stokes = 1.458E-6*tmp(i,j,l)**1.5/(tmp(i,j,l) + 110.4) ! Dynamic viscosity + free_path = 1.1E-3/p_mid(i,j,l2)/SQRT(tmp(i,j,l)) ! Free path as func of pres(mb) and temp(K); order of p_mid: top->sfc + + c_cun = 1.0+free_path/rwet_priv(k)* & + (1.257 + 0.4*EXP(-1.1*rwet_priv(k)/free_path)) ! Slip correction + viscosity = c_stokes / c_cun ! Corrected dynamic viscosity (kg/m/s) + + IF (iseas.eq.1) THEN + rho_priv(k) = ratio_r(k)*den(k) + (1.-ratio_r(k))*1000. + END IF + + vd_cor(l) = 2./9.*g0*rho_priv(k)*rwet_priv(k)**2/viscosity ! Settling velocity, depends on temp + +! Update mixing ratio; order of delz: top->sfc + IF (l == lmx) THEN + vd_wk1 = dt_settl(k)*vd_cor(l)/delz(i,j,l2) ! Dimensionless + tc(i,j,l,k) = tc(i,j,l,k)/(1.+ vd_wk1) + ELSE + vd_wk1 = dt_settl(k)*vd_cor(l)/delz(i,j,l2) ! Dimensionless + vd_wk2 = dt_settl(k)*vd_cor(l+1)/delz(i,j,l2) ! Dimensionless + tc(i,j,l,k) = (tc(i,j,l,k)+vd_wk2*tc(i,j,l+1,k))/(1.+vd_wk1) + ENDIF + + IF (l==1) THEN + graset(i,j,k)=graset(i,j,k)+vd_cor(l)*tc(i,j,l,k)/ndt_settl(k) ! [ug/kg][m/s] + grasetvel(i,j,k)=vd_cor(l) ! [m/s] + ENDIF + ENDDO !l, height + ENDDO !n, time + ENDDO !k, bin +! +! For UoC dust schemes, there are 4 size bins: chem(i,k,j,p_dust_5) is the sum +! + IF (uoc .eq. 1) THEN + IF ( idust.eq.1 ) THEN + DO l = 1, lmx + tc(i,j,l,5)=tc(i,j,l,1)+tc(i,j,l,2)+tc(i,j,l,3)+tc(i,j,l,4) + ENDDO + graset(i,j,5)=graset(i,j,1)+graset(i,j,2)+graset(i,j,3)+graset(i,j,4) + ENDIF + ENDIF + + ENDDO !i + END DO !j !$OMP END PARALLEL DO - DO n = 1,nmx - DO i = 1,imx - DO j = 1,jmx - bstl(i,j,n) = 0.0 - DO l = 1,lmx - IF (tc(i,j,l,n) < 1.0D-32) tc(i,j,l,n) = 1.0D-32 - bstl(i,j,n) = bstl(i,j,n) + & - (tc(i,j,l,n) - tc1(i,j,l,n)) * airmas(i,j,l) - END DO - END DO - END DO - END DO - END SUBROUTINE settling END MODULE MODULE_GOCART_SETTLING diff --git a/wrfv2_fire/chem/module_input_chem_data.F b/wrfv2_fire/chem/module_input_chem_data.F index bf34cc17..ec775824 100755 --- a/wrfv2_fire/chem/module_input_chem_data.F +++ b/wrfv2_fire/chem/module_input_chem_data.F @@ -58,12 +58,7 @@ MODULE module_input_chem_data REAL, PARAMETER :: mwso4 = 96.0576 ! Variables for adaptive time steps... -#if ( EM_CORE == 1 ) TYPE(WRFU_Time), DIMENSION(max_domains) :: last_chem_time -#endif -#if ( NMM_CORE == 1) - TYPE(WRFU_Time), DIMENSION(1) :: last_chem_time -#endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Initial atmospheric chemistry profile data @@ -73,7 +68,7 @@ MODULE module_input_chem_data INTEGER :: kx ! number of vertical levels in temp profile INTEGER :: kxm1 - PARAMETER( kx=16, kxm1=kx-1, logg=200, lo=34) ! Changed value of logg from 100 to 200 for additional gas species + PARAMETER( kx=16, kxm1=kx-1, logg=350, lo=34) ! DL (6/2/2013) Changed value of logg from 200 to 350 for additional gas species INTEGER, DIMENSION(logg) :: iref @@ -154,7 +149,6 @@ MODULE module_input_chem_data ! DATA ZFA/ 0., 85., 212., 385., 603., 960., 1430., 2010., & ! 2850., 4010., 5340., 6900., 8510.,10200.,12100.,16000., & ! 21000./ -#if ( ! EM_CORE == 0 ) DATA ZFA_BDY/ 0., 85., 212., 385., 603., 960., 1430., 2010., & 2850., 4010., 5340., 6900., 8510.,10200.,12100.,16000., & 21000./ @@ -163,18 +157,6 @@ MODULE module_input_chem_data DATA ZFA/ 0., 85., 212., 385., 603., 960., 1430., 2010., & 2850., 4010., 5340., 6900., 8510.,10200.,12100.,16000., & 21000./ -#endif -#if ( ! NMM_CORE == 0 ) - - DATA ZFA_BDY/ 0., 85., 212., 385., 603., 960., 1430., 2010., & - 2850., 4010., 5340., 6900., 8510.,10200.,12100.,16000., & - 21000./ - -! Profile pressure in hpa - DATA ZFA/ 100000., 98500., 98000., 96000., 94000., 90000., 85000., 75000., & - 71000., 65000., 52000., 48000., 45000., 30000., 25000., 20000., & - 5000./ -#endif !wig: To match the xl profile to the correct species, match WRF's p_ ! flag with iref(p_-1) to get the value of the first index in xl, @@ -338,8 +320,8 @@ SUBROUTINE setup_gasprofile_maps(chem_opt, numgas) select case(chem_opt) case (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & - RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM, & - RACM_ESRLSORG_KPP, RACMSORG_KPP, RACM_SOA_VBS_KPP, & + RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & + RACM_ESRLSORG_AQCHEM_KPP, RACM_ESRLSORG_KPP, RACMSORG_KPP, RACM_SOA_VBS_KPP,& GOCARTRACM_KPP, GOCARTRADM2,GOCARTRADM2_KPP,CHEM_TRACER, CHEM_TRACE2) call setup_gasprofile_map_radm_racm @@ -379,6 +361,9 @@ SUBROUTINE setup_gasprofile_maps(chem_opt, numgas) case (MOZART_KPP) call wrf_debug("setup_profile_maps: nothing done for mozart_kpp") + case (CRIMECH_KPP, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) + call wrf_debug("setup_profile_maps: nothing done for crimech") + case (MOZCART_KPP) call wrf_debug("setup_profile_maps: nothing done for mozcart_kpp") @@ -591,7 +576,6 @@ SUBROUTINE vinterp_chem(nx1, nx2, ny1, ny2, nz1, nz_in, nz_out, nch, z_in, z_out DO i = nx1, nx2 output_loop: DO k = nz1, nz_out -#if ( EM_CORE == 1 ) desired_z = z_out(i,k,j) IF (desired_z .LT. z_in(i,1,j)) THEN @@ -661,75 +645,6 @@ SUBROUTINE vinterp_chem(nx1, nx2, ny1, ny2, nz1, nz_in, nz_out, nch, z_in, z_out ENDDO input_loop ENDIF -#endif -#if ( NMM_CORE == 1 ) - - desired_z = z_out(i,k,j) - IF (desired_z .GT. z_in(i,1,j)) THEN - - IF ((desired_z - z_in(i,1,j)).GT. 0.0001) THEN - data_out(i,k,j,l) = data_in(i,1,j,l) - ELSE - IF (extrapolate) THEN - ! Extrapolate upward because desired pressure level is above - ! the highest level in our input data. Extrapolate using simple - ! 1st derivative of value with respect to height for the bottom 2 - ! input layers. - - ! Add a check to make sure we are not using the gradient of - ! a very thin layer - - IF ( (z_in(i,1,j) - z_in(i,2,j)) .LT. 0.001) THEN - dvaldz = (data_in(i,2,j,l) - data_in(i,1,j,l)) / & - (z_in(i,2,j) - z_in(i,1,j) ) - ELSE - dvaldz = (data_in(i,3,j,l) - data_in(i,1,j,l)) / & - (z_in(i,3,j) - z_in(i,1,j) ) - ENDIF - data_out(i,k,j,l) = MAX( data_in(i,1,j,l) + & - dvaldz * (desired_z-z_in(i,1,j)), 0.) - ELSE - data_out(i,k,j,l) = data_in(i,1,j,l) - ENDIF - ENDIF - ELSE IF (desired_z .LT. z_in(i,nz_in,j)) THEN - IF ( (z_in(i,nz_in,j) - desired_z) .LT. 0.0001) THEN - data_out(i,k,j,l) = data_in(i,nz_in,j,l) - ELSE - IF (extrapolate) THEN - ! Extrapolate upward - IF ( (z_in(i,nz_in-1,j)-z_in(i,nz_in,j)) .LT. 0.0005) THEN - dvaldz = (data_in(i,nz_in,j,l) - data_in(i,nz_in-1,j,l)) / & - (z_in(i,nz_in,j) - z_in(i,nz_in-1,j)) - ELSE - dvaldz = (data_in(i,nz_in,j,l) - data_in(i,nz_in-2,j,l)) / & - (z_in(i,nz_in,j) - z_in(i,nz_in-2,j)) - ENDIF - data_out(i,k,j,l) = MAX( data_in(i,nz_in,j,l) + & - dvaldz * (z_in(i,nz_in,j) - desired_z), 0.) - ELSE - data_out(i,k,j,l) = data_in(i,nz_in,j,l) - ENDIF - ENDIF - ELSE - ! We can trap between two levels and linearly interpolate - - input_loop: DO kk = 1, nz_in-1 - IF (desired_z .EQ. z_in(i,kk,j) )THEN - data_out(i,k,j,l) = data_in(i,kk,j,l) - EXIT input_loop - ELSE IF ( (desired_z .LT. z_in(i,kk,j)) .AND. & - (desired_z .GT. z_in(i,kk+1,j)) ) THEN - wgt0 = (desired_z - z_in(i,kk+1,j)) / & - (z_in(i,kk,j)-z_in(i,kk+1,j)) - data_out(i,k,j,l) = MAX( wgt0*data_in(i,kk,j,l) + & - (1.-wgt0)*data_in(i,kk+1,j,l), 0.) - EXIT input_loop - ENDIF - ENDDO input_loop - - ENDIF -#endif ENDDO output_loop ENDDO ENDDO @@ -753,10 +668,6 @@ SUBROUTINE input_chem_profile (si_grid) REAL, ALLOCATABLE, DIMENSION(:,:,:) :: si_zsigf, si_zsig -#if ( ! NMM_CORE == 0 ) - REAL, ALLOCATABLE, DIMENSION(:,:,:) :: pint - REAL, ALLOCATABLE, DIMENSION(:,:) :: pdsl -#endif CHARACTER (LEN=80) :: inpname, message @@ -778,57 +689,8 @@ SUBROUTINE input_chem_profile (si_grid) ALLOCATE( si_zsigf(ims:ime,kms:kme,jms:jme) ) ALLOCATE( si_zsig(ims:ime,kms:kme,jms:jme) ) -#if ( ! EM_CORE == 0 ) write(message,'(A)') 'WRF_EM_CORE ' si_zsigf = (si_grid%ph_1 + si_grid%phb) / grav -#endif -#if ( ! NMM_CORE == 0 ) - ! Get scalar grid point heights - ALLOCATE( pint(ims:ime,kms:kme,jms:jme) ) - ALLOCATE( pdsl(ims:ime,jms:jme) ) - - write(message,'(A)') 'WRF_NMM_CORE ' - CALL wrf_message ( message ) - - IF(si_grid%sigma.EQ. 1)THEN - do j=jps,jpe - do i=ips,ipe - pdsl(i,j)=si_grid%pd(i,j) - ENDDO - ENDDO - ELSE - do j=jps,jpe - do i=ips,ipe - pdsl(i,j)=si_grid%res(i,j)*si_grid%pd(i,j) - enddo - enddO - ENDIF -!! -!!*** -!! -!! -!!!!! SHOULD PINT,Z,W BE REDEFINED IF RESTRT? -! -! print *,' ips=',ips,' ipe=',ipe -! print *,' jps=',jps,' jpe=',jpe -! print *,' kps=',kps,' kpe=',kpe -! print *,' sigma=',si_grid%sigma -! print *,' pdtop=',si_grid%pdtop,' pt=',si_grid%pt - - do j=jps,jpe - do k=kps,kpe - do i=ips,ipe - pint(i,k,j)=si_grid%eta1(k)*si_grid%pdtop+si_grid%eta2(k)*pdsl(i,j)+si_grid%pt - si_zsigf(i,k,j)=pint(i,k,j) - ENDDO - ENDDO - ENDDO -! do k=kps,kpe -! print *,k,pint(1,k,1),si_grid%eta1(k),si_grid%pdtop,si_grid%eta2(k),pdsl(1,1),si_grid%pt -! enddo -! -! si_zsigf = si_grid%z -#endif ! si_zsigf = (si_grid%ph_1 + si_grid%phb) / grav @@ -886,9 +748,6 @@ SUBROUTINE input_chem_profile (si_grid) CALL wrf_debug ( 100,' input_chem_profile: exit subroutine ') DEALLOCATE( si_zsigf ); DEALLOCATE( si_zsig ) -#if ( ! NMM_CORE == 0 ) - DEALLOCATE( pdsl ); DEALLOCATE( pint ) -#endif RETURN END SUBROUTINE input_chem_profile @@ -1482,7 +1341,6 @@ SUBROUTINE bdy_chem_value_ghg ( chem, nch ) END SUBROUTINE bdy_chem_value_ghg !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#if (EM_CORE == 1 ) SUBROUTINE flow_dep_bdy_chem ( chem, & chem_bxs,chem_btxs, & chem_bxe,chem_btxe, & @@ -1571,7 +1429,9 @@ SUBROUTINE flow_dep_bdy_chem ( chem, & config_flags%chem_opt == RACMSORG_KPP .or. & config_flags%chem_opt == RACM_ESRLSORG_KPP .or. & config_flags%chem_opt == RACM_SOA_VBS_KPP .or. & - config_flags%chem_opt == RACM_MIM_KPP ) then + config_flags%chem_opt == RACM_MIM_KPP .or. & + config_flags%chem_opt == RACMSORG_AQCHEM_KPP .or. & + config_flags%chem_opt == RACM_ESRLSORG_AQCHEM_KPP ) then i_bdy_method = 9 end if if (config_flags%chem_opt == RACMPM_KPP ) then @@ -1863,326 +1723,6 @@ SUBROUTINE flow_dep_bdy_chem ( chem, & ENDIF END SUBROUTINE flow_dep_bdy_chem -#else - SUBROUTINE flow_dep_bdy_chem ( chem, chem_b,chem_bt,dt, & - spec_bdy_width,z, & - ijds, ijde,have_bcs_chem, & - u, v, config_flags, alt, & - t,pb,p,t0,p1000mb,rcp,ph,phb,g, & - spec_zone, ic, & - ids,ide, jds,jde, kds,kde, & ! domain dims - ims,ime, jms,jme, kms,kme, & ! memory dims - ips,ipe, jps,jpe, kps,kpe, & ! patch dims - its,ite, jts,jte, kts,kte ) - -! This subroutine sets zero gradient conditions for outflow and a set profile value -! for inflow in the boundary specified region. Note that field must be unstaggered. -! The velocities, u and v, will only be used to check their sign (coupled vels OK) -! spec_zone is the width of the outer specified b.c.s that are set here. -! (JD August 2000) - - IMPLICIT NONE - - INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde - INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme - INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe - INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: ijds,ijde - INTEGER, INTENT(IN ) :: spec_zone,spec_bdy_width,ic - REAL, INTENT(IN ) :: dt - - - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: chem - REAL, DIMENSION( ijds:ijde , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: chem_b - REAL, DIMENSION( ijds:ijde , kds:kde , spec_bdy_width, 4 ), INTENT(IN ) :: chem_bt - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: z - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: alt - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: u - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: v - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - ph,phb,t,pb,p - real, INTENT (IN) :: g,rcp,t0,p1000mb - TYPE( grid_config_rec_type ) config_flags - - INTEGER :: i, j, k, numgas - INTEGER :: ibs, ibe, jbs, jbe, itf, jtf, ktf - INTEGER :: i_inner, j_inner - INTEGER :: b_dist - integer :: itestbc, i_bdy_method - real tempfac,convfac - real :: chem_bv_def - logical :: have_bcs_chem - - chem_bv_def = conmin - numgas = get_last_gas(config_flags%chem_opt) - itestbc=0 - if(p_nu0.gt.1)itestbc=1 - ibs = ids - ibe = ide-1 - itf = min(ite,ide-1) - jbs = jds - jbe = jde-1 - jtf = min(jte,jde-1) - ktf = kde-1 - -! i_bdy_method determines which "bdy_chem_value" routine to use -! 1=radm2 or racm gas for p_so2 <= ic <= p_ho2 -! 2=sorgam aerosol for p_so4aj <= ic <= p_corn -! 3=cbmz gas for p_hcl <= ic <= p_isopo2 -! OR p_dms <= ic <= p_mtf -! 4=mosaic aerosol for p_so4_a01 <= ic <= p_num_a01 -! OR p_so4_a02 <= ic <= p_num_a02 -! OR ... -! 5=tracer mode -! 0=none for all other ic values -! (note: some cbmz packages use dms,...,mtf while others do not) -! (note: different mosaic packages use different number of sections) - i_bdy_method = 0 - if ((ic .ge. p_so2) .and. (ic .le. p_ho2)) then - i_bdy_method = 1 - - if (config_flags%chem_opt == RACM_KPP .or. & - config_flags%chem_opt == GOCARTRACM_KPP .or. & - config_flags%chem_opt == RACMSORG_KPP .or. & - config_flags%chem_opt == RACM_SOA_VBS_KPP .or. & - config_flags%chem_opt == RACM_ESRLSORG_KPP .or. & - config_flags%chem_opt == RACM_MIM_KPP ) then - i_bdy_method = 9 - end if - if (config_flags%chem_opt == RACMPM_KPP ) then - i_bdy_method = 9 - end if - - else if ((ic .ge. p_so4aj) .and. (ic .le. p_corn)) then - i_bdy_method = 2 - else if ((ic .ge. p_hcl) .and. (ic .le. p_isopo2)) then - i_bdy_method = 3 - else if ((ic .ge. p_dms) .and. (ic .le. p_mtf)) then - i_bdy_method = 3 - else if ((ic .ge. p_so4_a01) .and. (ic .le. p_num_a01)) then - i_bdy_method = 4 - else if ((ic .ge. p_so4_a02) .and. (ic .le. p_num_a02)) then - i_bdy_method = 4 - else if ((ic .ge. p_so4_a03) .and. (ic .le. p_num_a03)) then - i_bdy_method = 4 - else if ((ic .ge. p_so4_a04) .and. (ic .le. p_num_a04)) then - i_bdy_method = 4 - else if ((ic .ge. p_so4_a05) .and. (ic .le. p_num_a05)) then - i_bdy_method = 4 - else if ((ic .ge. p_so4_a06) .and. (ic .le. p_num_a06)) then - i_bdy_method = 4 - else if ((ic .ge. p_so4_a07) .and. (ic .le. p_num_a07)) then - i_bdy_method = 4 - else if ((ic .ge. p_so4_a08) .and. (ic .le. p_num_a08)) then - i_bdy_method = 4 - else if (config_flags%chem_opt == CHEM_TRACER) then - i_bdy_method = 5 - else if (config_flags%chem_opt == CHEM_TRACE2) then - i_bdy_method = 5 - end if - if (have_bcs_chem) i_bdy_method =6 - if (ic .lt. param_first_scalar) i_bdy_method = 0 - -!---------------------------------------------------------------------- -! if (i_bdy_method .eq. 1) then -! print 90010, '_bdy_radm2 for ic=', ic, i_bdy_method -! else if (i_bdy_method .eq. 2) then -! print 90010, '_bdy_sorgam for ic=', ic, i_bdy_method -! else if (i_bdy_method .eq. 3) then -! print 90010, '_bdy_cbmz for ic=', ic, i_bdy_method -! else if (i_bdy_method .eq. 4) then -! print 90010, '_bdy_mosaic for ic=', ic, i_bdy_method -! else if (i_bdy_method .eq. 5) then -! print 90010, '_bdy_tracer for ic=', ic, i_bdy_method -! else -! print 90010, '_bdy_NONE** for ic=', ic, i_bdy_method -! end if -!90010 format( a, 2(1x,i5) ) -!90020 format( a, 1p, 2e12.2 ) -!---------------------------------------------------------------------- - -! if(ic.eq.p_O3)THEN -! write(0,*)'in flow_chem ',jts,jbs,spec_zone -! write(0,*)'in flow_chem ',its,ibs,b_dist,i_bdy_method,ic -! endif - IF (jts - jbs .lt. spec_zone) THEN -! Y-start boundary - DO j = jts, min(jtf,jbs+spec_zone-1) - b_dist = j - jbs - DO k = kts, ktf - DO i = max(its,b_dist+ibs), min(itf,ibe-b_dist) - i_inner = max(i,ibs+spec_zone) - i_inner = min(i_inner,ibe-spec_zone) - IF(v(i,k,j) .lt. 0.)THEN - chem(i,k,j) = chem(i_inner,k,jbs+spec_zone) -! if(j.eq.jts+1.and.k.eq.kts.and.ic.eq.p_o3)then -! write(0,*)'Yflow',i,j,k,i_bdy_method -! write(0,*)chem(i_inner,k,jbs+spec_zone),v(i,k,j) -! endif - ELSE - if (i_bdy_method .eq. 1) then - CALL bdy_chem_value ( & - chem(i,k,j), z(i,k,j), ic, numgas ) - else if (i_bdy_method .eq. 9) then - CALL bdy_chem_value_racm( & - chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) - else if (i_bdy_method .eq. 2) then - tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp - convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac - CALL bdy_chem_value_sorgam ( & - chem(i,k,j), z(i,k,j), ic, config_flags, & - alt(i,k,j),convfac,g) - else if (i_bdy_method .eq. 3) then - CALL bdy_chem_value_cbmz ( & - chem(i,k,j), z(i,k,j), ic, numgas ) - else if (i_bdy_method .eq. 4) then - CALL bdy_chem_value_mosaic ( & - chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) - else if (i_bdy_method .eq. 5) then - CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) - else if (i_bdy_method .eq. 6) then - CALL bdy_chem_value_gcm ( chem(i,k,j),chem_b(i,k,1,P_YSB),chem_bt(i,k,1,P_YSB),dt,ic) -! if(k.eq.kts.and.ic.eq.p_o3)then -! write(0,*)'Ygcm',i,j,k,i_bdy_method -! write(0,*)chem(i,k,j),chem_b(i,k,1,P_YSB),chem_bt(i,k,1,P_YSB),dt -! endif - else - chem(i,k,j) = chem_bv_def - endif - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF - IF (jbe - jtf .lt. spec_zone) THEN -! Y-end boundary - DO j = max(jts,jbe-spec_zone+1), jtf - b_dist = jbe - j - DO k = kts, ktf - DO i = max(its,b_dist+ibs), min(itf,ibe-b_dist) - i_inner = max(i,ibs+spec_zone) - i_inner = min(i_inner,ibe-spec_zone) - IF(v(i,k,j+1) .gt. 0.)THEN - chem(i,k,j) = chem(i_inner,k,jbe-spec_zone) - ELSE - if (i_bdy_method .eq. 1) then - CALL bdy_chem_value ( & - chem(i,k,j), z(i,k,j), ic, numgas ) - else if (i_bdy_method .eq. 9) then - CALL bdy_chem_value_racm ( & - chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) - else if (i_bdy_method .eq. 2) then - tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp - convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac - CALL bdy_chem_value_sorgam ( & - chem(i,k,j), z(i,k,j), ic, config_flags, & - alt(i,k,j),convfac,g) - else if (i_bdy_method .eq. 3) then - CALL bdy_chem_value_cbmz ( & - chem(i,k,j), z(i,k,j), ic, numgas ) - else if (i_bdy_method .eq. 4) then - CALL bdy_chem_value_mosaic ( & - chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) - else if (i_bdy_method .eq. 5) then - CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) - else if (i_bdy_method .eq. 6) then - CALL bdy_chem_value_gcm ( chem(i,k,j),chem_b(i,k,1,P_YEB),chem_bt(i,k,1,P_YEB),dt,ic) - else - chem(i,k,j) = chem_bv_def - endif - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF - - IF (its - ibs .lt. spec_zone) THEN -! X-start boundary - DO i = its, min(itf,ibs+spec_zone-1) - b_dist = i - ibs - DO k = kts, ktf - DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) - j_inner = max(j,jbs+spec_zone) - j_inner = min(j_inner,jbe-spec_zone) - IF(u(i,k,j) .lt. 0.)THEN - chem(i,k,j) = chem(ibs+spec_zone,k,j_inner) - ELSE - if (i_bdy_method .eq. 1) then - CALL bdy_chem_value ( & - chem(i,k,j), z(i,k,j), ic, numgas ) - else if (i_bdy_method .eq. 9) then - CALL bdy_chem_value_racm ( & - chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) - else if (i_bdy_method .eq. 2) then - tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp - convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac - CALL bdy_chem_value_sorgam ( & - chem(i,k,j), z(i,k,j), ic, config_flags, & - alt(i,k,j),convfac,g) - else if (i_bdy_method .eq. 3) then - CALL bdy_chem_value_cbmz ( & - chem(i,k,j), z(i,k,j), ic, numgas ) - else if (i_bdy_method .eq. 4) then - CALL bdy_chem_value_mosaic ( & - chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) - else if (i_bdy_method .eq. 5) then - CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) - else if (i_bdy_method .eq. 6) then - CALL bdy_chem_value_gcm ( chem(i,k,j),chem_b(j,k,1,P_XSB),chem_bt(j,k,1,P_XSB),dt,ic) - else - chem(i,k,j) = chem_bv_def - endif - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF - - IF (ibe - itf .lt. spec_zone) THEN -! X-end boundary - DO i = max(its,ibe-spec_zone+1), itf - b_dist = ibe - i - DO k = kts, ktf - DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) - j_inner = max(j,jbs+spec_zone) - j_inner = min(j_inner,jbe-spec_zone) - IF(u(i+1,k,j) .gt. 0.)THEN - chem(i,k,j) = chem(ibe-spec_zone,k,j_inner) - ELSE - if (i_bdy_method .eq. 1) then - CALL bdy_chem_value ( & - chem(i,k,j), z(i,k,j), ic, numgas ) - else if (i_bdy_method .eq. 9) then - CALL bdy_chem_value_racm ( & - chem(i,k,j), z(i,k,j), ic, numgas,p_co2 ) - else if (i_bdy_method .eq. 2) then - tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp - convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac - CALL bdy_chem_value_sorgam ( & - chem(i,k,j), z(i,k,j), ic, config_flags, & - alt(i,k,j),convfac,g) - else if (i_bdy_method .eq. 3) then - CALL bdy_chem_value_cbmz ( & - chem(i,k,j), z(i,k,j), ic, numgas ) - else if (i_bdy_method .eq. 4) then - CALL bdy_chem_value_mosaic ( & - chem(i,k,j), alt(i,k,j), z(i,k,j), ic, config_flags ) - else if (i_bdy_method .eq. 5) then - CALL bdy_chem_value_tracer ( chem(i,k,j), ic ) - else if (i_bdy_method .eq. 6) then - CALL bdy_chem_value_gcm ( chem(i,k,j),chem_b(j,k,1,P_XEB),chem_bt(j,k,1,P_XEB),dt,ic) - else - chem(i,k,j) = chem_bv_def - endif - ENDIF - ENDDO - ENDDO - ENDDO - ENDIF - - END SUBROUTINE flow_dep_bdy_chem -#endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! this is a kludge routine as of now.... @@ -2557,9 +2097,9 @@ integer FUNCTION get_last_gas(chem_opt) get_last_gas = 0 case (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & - RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM, & - RACM_ESRLSORG_KPP, RACMSORG_KPP, RACM_SOA_VBS_KPP, & - GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP) + RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & + RACM_ESRLSORG_AQCHEM_KPP, RACM_ESRLSORG_KPP, RACMSORG_KPP, RACM_SOA_VBS_KPP,& + GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP) get_last_gas = p_ho2 case (CBMZ_MOSAIC_4BIN_VBS2_KPP, SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP) @@ -2595,6 +2135,9 @@ integer FUNCTION get_last_gas(chem_opt) case (MOZART_KPP) get_last_gas = p_meko2 + case (CRIMECH_KPP, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) + GET_LAST_GAS = p_ic3h7no3 + case (MOZCART_KPP) get_last_gas = p_meko2 diff --git a/wrfv2_fire/chem/module_lightning_nox_decaria.F b/wrfv2_fire/chem/module_lightning_nox_decaria.F index cd4a4393..4b61cff4 100644 --- a/wrfv2_fire/chem/module_lightning_nox_decaria.F +++ b/wrfv2_fire/chem/module_lightning_nox_decaria.F @@ -92,6 +92,7 @@ SUBROUTINE lightning_nox_decaria ( & INTEGER :: i,k,j INTEGER :: ktop,kbtm,kupper,klower REAL :: ic_fr, cg_fr, delta ! reconsolidated flashrates + REAL :: reflmax, cellmax REAL :: term2, B CHARACTER (LEN=250) :: message REAL, DIMENSION( kps:kpe ) :: cellcount @@ -123,6 +124,10 @@ SUBROUTINE lightning_nox_decaria ( & ic_fr = wrf_dm_sum_real(ic_fr) cg_fr = wrf_dm_sum_real(cg_fr) ENDIF + reflmax = maxval(refl(ips:ipe,kps:kpe,jps:jpe)) + cellmax = maxval(cellcount(kps:kpe)) + WRITE(message, * ) ' LNOx tracer: max_refl, max_cellcount, ic_fr = ', reflmax, cellmax, ic_fr + CALL wrf_debug ( 100, message ) !----------------------------------------------------------------- @@ -158,7 +163,7 @@ SUBROUTINE lightning_nox_decaria ( & !* 3) Divide by moles of air gives mixing ratio !* 4) Multiply by 1E6 gives ppmv delta = (ic_fr * N_IC / cellcount(k)) * fd(k) / (molesofair(k)*dz(k)) * 1E6 - WRITE(message, * ) ' lightning_driver: k, delta, cellcount, fd = ', k, delta, cellcount(k), fd(k) + WRITE(message, * ) ' LNOx_driver: k, delta, cellcount, fd = ', k, delta, cellcount(k), fd(k) CALL wrf_debug ( 100, message ) where(refl(ips:ipe,k,jps:jpe) .gt. refl_threshold ) lnox_ic_tend(ips:ipe,k,jps:jpe) = delta @@ -218,6 +223,7 @@ END SUBROUTINE lightning_nox_decaria SUBROUTINE bellcurve ( k_min, k_max, k_mu, z, kps,kpe, f, dz ) !----------------------------------------------------------------- + IMPLICIT NONE INTEGER, INTENT(IN ) :: k_min, k_max, k_mu REAL, DIMENSION( kps:kpe ), INTENT(IN ) :: z ! at phy INTEGER, INTENT(IN ) :: kps,kpe @@ -241,8 +247,11 @@ SUBROUTINE bellcurve ( k_min, k_max, k_mu, z, kps,kpe, f, dz ) ! Truncated Gaussian at 3 sigma f(k_min:k_max) = (1.0/(sqrt(two_pi)*sigma))*exp(-ex(k_min:k_max)*ex(k_min:k_max)/2.0) - dz(kps) = 0. ! safe as long as k_min != kps - dz(kpe) = 0. ! safe as long as k_max != kpe +!++mcb We do need dz at bottom and top of domain +! dz(kps) = 0. ! safe as long as k_min != kps +! dz(kpe) = 0. ! safe as long as k_max != kpe + dz(kps) = (z(kps+1) - z(kps))*.5 + dz(kpe) = (z(kpe) - z(kpe-1))*.5 DO k=kps+1,kpe-1 ! dz(k) = (z(k+1)+z(k))/2. - (z(k)+z(k-1))/2. dz(k) = (z(k+1) - z(k-1))*.5 @@ -282,6 +291,7 @@ SUBROUTINE kfind ( & USE module_dm, only: wrf_dm_max_real, wrf_dm_min_real, wrf_dm_sum_real + IMPLICIT NONE !----------------------------------------------------------------- ! Prognostics @@ -318,11 +328,11 @@ SUBROUTINE kfind ( & ! Look for kbtm k = kps - DO WHILE( cellcount(k) .eq. 0 .and. k .lt. ktop ) + DO WHILE( cellcount(k) .eq. 0 .and. k .le. ktop ) k = k+1 ENDDO kbtm = k - if (kbtm .eq. kps) kbtm = kpe +! if (kbtm .eq. kps) kbtm = kpe ! Look for kupper k = kps @@ -336,7 +346,7 @@ SUBROUTINE kfind ( & ENDDO kupper = k - WRITE(message, * ) ' lightning_driver: kbtm, ktop, klower, kupper = ', kbtm, ktop, klower, kupper + WRITE(message, * ) ' LNOx_driver: kbtm, ktop, klower, kupper = ', kbtm, ktop, klower, kupper CALL wrf_debug ( 100, message ) IF ( cellcount_method .eq. 2 ) THEN @@ -360,6 +370,7 @@ END SUBROUTINE kfind !************************************************************************ SUBROUTINE horizontalAverage( array3D, ips, ipe, kps, kpe, jps, jpe, array1D ) !----------------------------------------------------------------- + IMPLICIT NONE REAL, DIMENSION(ips:ipe,kps:kpe,jps:jpe), INTENT(IN) :: array3D INTEGER, INTENT(IN) :: ips,ipe,kps,kpe,jps,jpe diff --git a/wrfv2_fire/chem/module_lightning_nox_driver.F b/wrfv2_fire/chem/module_lightning_nox_driver.F index 553980c8..cedc1f32 100644 --- a/wrfv2_fire/chem/module_lightning_nox_driver.F +++ b/wrfv2_fire/chem/module_lightning_nox_driver.F @@ -101,7 +101,7 @@ SUBROUTINE lightning_nox_driver ( & IF ( itimestep * dt .lt. lightning_start_seconds ) RETURN - IF ( MOD((itimestep * dt - lightning_start_seconds), lightning_dt ) .ne. 0 ) RETURN +! IF ( MOD((itimestep * dt - lightning_start_seconds), lightning_dt ) .ne. 0 ) RETURN IF ( N_IC .eq. 0. .and. N_CG .eq. 0. ) RETURN !----------------------------------------------------------------- diff --git a/wrfv2_fire/chem/module_mosaic_addemiss.F b/wrfv2_fire/chem/module_mosaic_addemiss.F index 9029902e..38378c76 100644 --- a/wrfv2_fire/chem/module_mosaic_addemiss.F +++ b/wrfv2_fire/chem/module_mosaic_addemiss.F @@ -154,6 +154,39 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & ! (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.933, 0.067 /) ! as of apr-2005 ! (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.16, 0.84 /) ! "old" + +! fraction of TNO black carbon <1um emissions that go into each of +! the mosaic 8 "standard" sections - Doug (4/3/2011) + real, save :: fr8b_tno_bc1(8) = & + (/ 0.0494, 0.3795, 0.4714, 0.0967, 0.003, 0.0, 0.0, 0.0 /) + +! fraction of TNO elemental carbon 1um-2.5um emissions that go into each of +! the mosaic 8 "standard" sections - Doug (4/3/2011) + real, save :: fr8b_tno_ec25(8) = & + (/ 0.0, 0.0, 0.0, 0.0, 0.40, 0.60, 0.0, 0.0 /) + +! fraction of TNO organic carbon <2.5um domestic combustion emissions that go into each of +! the mosaic 8 "standard" sections - Doug (4/3/2011) + real, save :: fr8b_tno_oc_dom(8) = & + (/ 0.0358, 0.1325, 0.2704, 0.3502, 0.1904, 0.0657, 0.0, 0.0 /) + +! fraction of TNO organic carbon <2.5um traffic (and other) emissions that go into each of +! the mosaic 8 "standard" sections - Doug (4/3/2011) + real, save :: fr8b_tno_oc_tra(8) = & + (/ 0.0063, 0.0877, 0.3496, 0.4054, 0.1376, 0.0134, 0.0, 0.0 /) + +! fraction of TNO "OIN" [PM2.5 minus sum(carbon<2.5)] emissions that go into each of +! the mosaic 8 "standard" sections - Doug (4/3/2011) --- based on mosaic fine mode + real, save :: fr8b_tno_mosaic_f(8) = & + (/ 0.060, 0.045, 0.245, 0.400, 0.100, 0.150, 0.0, 0.0/) + +! fraction of TNO 2.5-10um emissions that go into each of +! the mosaic 8 "standard" sections - Doug (4/3/2011) --- based on mosaic coarse mode + real, save :: fr8b_tno_mosaic_c(8) = & + (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.300, 0.700 /) + + + ! following 5 arrays correspond to the above "fr8b_" arrays ! but are set at run time base on input (namelist) parameters: ! only the sorgam or mosaic arrays are non-zero, depending on @@ -165,6 +198,12 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & real :: fr_aem_sorgam_c(8) real :: fr_aem_mosaic_f(8) real :: fr_aem_mosaic_c(8) + real :: fr_tno_bc1(8) + real :: fr_tno_ec25(8) + real :: fr_tno_oc_dom(8) + real :: fr_tno_oc_tra(8) + real :: fr_tno_mosaic_f(8) + real :: fr_tno_mosaic_c(8) double precision :: chem_sum(num_chem) character*80 msg @@ -211,6 +250,12 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & fr_aem_sorgam_c(:) = 0.0 fr_aem_mosaic_f(:) = 0.0 fr_aem_mosaic_c(:) = 0.0 + fr_tno_bc1(:) = 0.0 + fr_tno_ec25(:) = 0.0 + fr_tno_oc_dom(:) = 0.0 + fr_tno_oc_tra(:) = 0.0 + fr_tno_mosaic_f(:) = 0.0 + fr_tno_mosaic_c(:) = 0.0 emiss_inpt_select_1: SELECT CASE( config_flags%emiss_inpt_opt ) @@ -243,6 +288,31 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & end do end if + CASE( emiss_inpt_tno ) ! Doug - added 4/3/2011 + if (nsize_aer(itype) .eq. 8) then + fr_tno_bc1(:) = fr8b_tno_bc1(:) + fr_tno_ec25(:) = fr8b_tno_ec25(:) + fr_tno_oc_dom(:) = fr8b_tno_oc_dom(:) + fr_tno_oc_tra(:) = fr8b_tno_oc_tra(:) + fr_tno_mosaic_c(:) = fr8b_tno_mosaic_c(:) + fr_tno_mosaic_f(:) = fr8b_tno_mosaic_f(:) + else if (nsize_aer(itype) .eq. 4) then + do n = 1, nsize_aer(itype) + fr_tno_bc1(n) = fr8b_tno_bc1(2*n-1) & + + fr8b_tno_bc1(2*n) + fr_tno_ec25(n) = fr8b_tno_ec25(2*n-1) & + + fr8b_tno_ec25(2*n) + fr_tno_oc_dom(n) = fr8b_tno_oc_dom(2*n-1) & + + fr8b_tno_oc_dom(2*n) + fr_tno_oc_tra(n) = fr8b_tno_oc_tra(2*n-1) & + + fr8b_tno_oc_tra(2*n) + fr_tno_mosaic_c(n) = fr8b_tno_mosaic_c(2*n-1) & + + fr8b_tno_mosaic_c(2*n) + fr_tno_mosaic_f(n) = fr8b_tno_mosaic_f(2*n-1) & + + fr8b_tno_mosaic_f(2*n) + end do + end if + CASE DEFAULT return @@ -256,6 +326,12 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & fr_aem_sorgam_c(:) = 0.0 fr_aem_mosaic_f(:) = 0.0 fr_aem_mosaic_c(:) = 0.0 + fr_tno_bc1(:) = 0.0 + fr_tno_ec25(:) = 0.0 + fr_tno_oc_dom(:) = 0.0 + fr_tno_oc_tra(:) = 0.0 + fr_tno_mosaic_f(:) = 0.0 + fr_tno_mosaic_c(:) = 0.0 end if @@ -307,7 +383,10 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & aem_oc = fr_aem_mosaic_f(n)*(emis_ant(i,k,j,p_e_orgj)+ebu(i,k,j,p_ebu_oc)) & + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_orgc) & + fr_aem_sorgam_i(n)*(emis_ant(i,k,j,p_e_orgi)+0.25*ebu(i,k,j,p_ebu_oc)) & - + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_orgj)+0.75*ebu(i,k,j,p_ebu_oc)) + + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_orgj)+0.75*ebu(i,k,j,p_ebu_oc)) & + + fr_tno_oc_dom(n)*emis_ant(i,k,j,p_e_oc_dom) & + + fr_tno_oc_tra(n)*emis_ant(i,k,j,p_e_oc_tra) & + + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_oc_25_10) chem_select_1 : SELECT CASE( config_flags%chem_opt ) CASE(CBMZ_MOSAIC_4BIN_VBS2_KPP, SAPRC99_MOSAIC_4BIN_VBS2_KPP) ! Set the oc to zero for VBS @@ -317,12 +396,18 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & aem_bc = fr_aem_mosaic_f(n)*(emis_ant(i,k,j,p_e_ecj)+ebu(i,k,j,p_ebu_bc)) & + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_ecc) & + fr_aem_sorgam_i(n)*(emis_ant(i,k,j,p_e_eci)+0.25*ebu(i,k,j,p_ebu_bc)) & - + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_ecj)+0.75*ebu(i,k,j,p_ebu_bc)) + + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_ecj)+0.75*ebu(i,k,j,p_ebu_bc)) & + + fr_tno_bc1(n)*emis_ant(i,k,j,p_e_bc_1) & + + fr_tno_ec25(n)*emis_ant(i,k,j,p_e_ec_1_25) & + + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_ec_25_10) aem_oin = fr_aem_mosaic_f(n)*(emis_ant(i,k,j,p_e_pm25j)+ebu(i,k,j,p_ebu_pm25)) & + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_pm_10) & + fr_aem_sorgam_i(n)*(emis_ant(i,k,j,p_e_pm25i)+0.25*ebu(i,k,j,p_ebu_pm25)) & - + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_pm25j)+0.75*ebu(i,k,j,p_ebu_pm25)) + + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_pm25j)+0.75*ebu(i,k,j,p_ebu_pm25)) & + + fr_tno_mosaic_f(n)*emis_ant(i,k,j,p_e_oin_25) & + + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_oin_10) + ! emissions for these species are currently zero aem_nh4 = 0.0 @@ -416,12 +501,12 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & ! do seasalt emissions - if (seasalt_emiss_active == 1) & + if (seasalt_emiss_active > 0) & call mosaic_seasalt_emiss( & id, dtstep, u10, v10, alt, dz8w, xland, config_flags, chem, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, seasalt_emiss_active ) ! if (seasalt_emiss_active == 2) & ! call mosaic_seasalt_emiss( & @@ -461,7 +546,7 @@ subroutine mosaic_seasalt_emiss( & id, dtstep, u10, v10, alt, dz8w, xland, config_flags, chem, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, seasalt_emiss_active ) ! ! adds seasalt emissions for mosaic aerosol species ! (i.e., seasalt emissions tendencies over time dtstep are applied @@ -482,6 +567,7 @@ subroutine mosaic_seasalt_emiss( & its,ite, jts,jte, kts,kte REAL, INTENT(IN ) :: dtstep + INTEGER, INTENT(IN) :: seasalt_emiss_active ! 10-m wind speed components (m/s) REAL, DIMENSION( ims:ime , jms:jme ), & @@ -497,32 +583,78 @@ subroutine mosaic_seasalt_emiss( & INTENT(IN ) :: alt, dz8w ! local variables - integer i, j, k, l, l_na, l_cl, n + integer i, j, k, l, l_na, l_cl, n, l_oc integer iphase, itype integer p1st real dum, dumdlo, dumdhi, dumoceanfrac, dumspd10 - real factaa, factbb, fracna, fraccl + real factaa, factbb, fracna, fraccl, fracorg real :: ssemfact_numb( maxd_asize, maxd_atype ) real :: ssemfact_mass( maxd_asize, maxd_atype ) + + ! Factors for Fuentes et al (ACP, 2011, doi:10.5194/acp-11-2585-2011) + ! seasalt emission scheme. + ! These are for calculating the seawater_OC content dependent factors. + real, save :: alpha_f1(4) = & + (/ 12.328, 38.077, 102.31, 281.65 /) + real, save :: alpha_f2(4) = & + (/ 2.2958, 8.0935, 25.251, 46.80 /) + real, save :: alpha_f3(4) = & + (/ 0.00452, 0.00705, 0.00080, 0.000761 /) + real, save :: beta_f1(4) = & + (/ 0.0311, -0.031633, 0.013154, -0.0017762 /) + real, save :: beta_f2(4) = & + (/ -13.916, 35.73, -9.7651, 1.1665 /) + real, save :: beta_f3(4) = & + (/ 4747.8, 12920.0, 7313.4, 6610.0 /) + real :: nti(4), dp0gi(4) + ! seawater OC<0.2um concentration (in uM) - first is for low activity, the 2nd for high activity + ! High activity conc is from the average for RHaMBLe cruise in high activity regions + real, save :: oc02um(2) = (/ 0.0, 280.0 /) + ! Organic fraction for seasalt emissions (by size bin). + ! These are estimated from Figure 5 of Fuentes et al (ACP, 2011), assuming a value of + ! 2 ug/l for Chl-a for the high activity + real, save :: org_frac_low_activity(8) = & + (/ 0.05, 0.05, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 /) + real, save :: org_frac_high_activity(8) = & + (/ 0.2, 0.2, 0.1, 0.01, 0.01, 0.01, 0.01, 0.01 /) + + p1st = PARAM_FIRST_SCALAR ! for now just do itype=1 itype = 1 iphase = ai_phase + ! if using Feuntes et al (2011) then calculate the seawater OC dependent factors + if(seasalt_emiss_active .eq. 3 .or. seasalt_emiss_active .eq. 4)then + do i=1,4 + nti(i) = beta_f1(i) * oc02um(seasalt_emiss_active-2)**2.0 + beta_f2(i) & + * oc02um(seasalt_emiss_active-2) + beta_f3(i) + dp0gi(i) = alpha_f1(i) + alpha_f2(i) & + * exp(-alpha_f3(i)*oc02um(seasalt_emiss_active-2)) + end do + end if + + ! compute emissions factors for each size bin -! (limit emissions to dp > 0.1 micrometer) do n = 1, nsize_aer(itype) ! changed the lower bound of the emission size limit to match lowest section edge, Qing.Yang@pnl.gov -! dumdlo = max( dlo_sect(n,itype), 0.1e-4 ) -! dumdhi = max( dhi_sect(n,itype), 0.1e-4 ) - dumdlo = max( dlo_sect(n,itype), 0.02e-4 ) - dumdhi = max( dhi_sect(n,itype), 0.02e-4 ) - call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, & - ssemfact_numb(n,itype), dum, ssemfact_mass(n,itype) ) + ! DL - 30/3/2012 - select emission scheme (1=original, 3&4=Feuntes et al, 2011) + if(seasalt_emiss_active == 1)then +! changed the lower bound of the emission size limit to match lowest section edge, Qing.Yang@pnl.gov +! dumdlo = max( dlo_sect(n,itype), 0.1e-4 ) +! dumdhi = max( dhi_sect(n,itype), 0.1e-4 ) + dumdlo = max( dlo_sect(n,itype), 0.02e-4 ) + dumdhi = max( dhi_sect(n,itype), 0.02e-4 ) + call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, & + ssemfact_numb(n,itype), dum, ssemfact_mass(n,itype) ) + elseif(seasalt_emiss_active .eq. 3 .or. seasalt_emiss_active .eq. 4)then + call seasalt_emit_feuntes_1bin( dlo_sect(n,itype), dhi_sect(n,itype), & + ssemfact_numb(n,itype), dum, ssemfact_mass(n,itype), nti, dp0gi, oc02um(seasalt_emiss_active-2) ) + endif ! convert mass emissions factor from (g/m2/s) to (ug/m2/s) ssemfact_mass(n,itype) = ssemfact_mass(n,itype)*1.0e6 @@ -531,52 +663,95 @@ subroutine mosaic_seasalt_emiss( & ! loop over i,j and apply seasalt emissions k = kts - do 1830 j = jts, jte - do 1820 i = its, ite - - !Skip this point if over land. xland=1 for land and 2 for water. - !Also, there is no way to differentiate fresh from salt water. - !Currently, this assumes all water is salty. - if( xland(i,j) < 1.5 ) cycle - - !wig: As far as I can tell, only real.exe knows the fractional breakdown - ! of land use. So, in wrf.exe, dumoceanfrac will always be 1. - dumoceanfrac = 1. !fraction of grid i,j that is salt water - dumspd10 = dumoceanfrac* & - ( (u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5*3.41) ) - -! factaa is (s*m2/kg-air) -! factaa*ssemfact_mass(n) is (s*m2/kg-air)*(ug/m2/s) = ug/kg-air -! factaa*ssemfact_numb(n) is (s*m2/kg-air)*( #/m2/s) = #/kg-air - factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j) - - factbb = factaa * dumspd10 - -! apportion seasalt mass emissions assumming that seasalt is pure nacl - fracna = mw_na_aer / (mw_na_aer + mw_cl_aer) - fraccl = 1.0 - fracna - - do 1810 n = 1, nsize_aer(itype) - -! only apply emissions if bin has both na and cl species - l_na = lptr_na_aer(n,itype,iphase) - l_cl = lptr_cl_aer(n,itype,iphase) - if ((l_na >= p1st) .and. (l_cl >= p1st)) then - - chem(i,k,j,l_na) = chem(i,k,j,l_na) + & - factbb * ssemfact_mass(n,itype) * fracna - - chem(i,k,j,l_cl) = chem(i,k,j,l_cl) + & - factbb * ssemfact_mass(n,itype) * fraccl - - l = numptr_aer(n,itype,iphase) - if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + & - factbb * ssemfact_numb(n,itype) - end if -1810 continue - -1820 continue -1830 continue + do j = jts, jte + do i = its, ite + + ! Skip this point if over land. xland=1 for land and 2 for water. + ! Also, there is no way to differentiate fresh from salt water. + ! Currently, this assumes all water is salty. + if( xland(i,j) < 1.5 ) cycle + + !wig: As far as I can tell, only real.exe knows the fractional breakdown + ! of land use. So, in wrf.exe, dumoceanfrac will always be 1. + dumoceanfrac = 1. !fraction of grid i,j that is salt water + dumspd10 = dumoceanfrac* & + ( (u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5*3.41) ) + + ! factaa is (s*m2/kg-air) + ! factaa*ssemfact_mass(n) is (s*m2/kg-air)*(ug/m2/s) = ug/kg-air + ! factaa*ssemfact_numb(n) is (s*m2/kg-air)*( #/m2/s) = #/kg-air + factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j) + + factbb = factaa * dumspd10 + + if(seasalt_emiss_active == 1)then + ! apportion seasalt mass emissions assumming that seasalt is pure nacl + fracna = mw_na_aer / (mw_na_aer + mw_cl_aer) + fraccl = 1.0 - fracna + + do n = 1, nsize_aer(itype) + + ! only apply emissions if bin has both na and cl species + l_na = lptr_na_aer(n,itype,iphase) + l_cl = lptr_cl_aer(n,itype,iphase) + if ((l_na >= p1st) .and. (l_cl >= p1st)) then + + chem(i,k,j,l_na) = chem(i,k,j,l_na) + & + factbb * ssemfact_mass(n,itype) * fracna + + chem(i,k,j,l_cl) = chem(i,k,j,l_cl) + & + factbb * ssemfact_mass(n,itype) * fraccl + + l = numptr_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + & + factbb * ssemfact_numb(n,itype) + + end if + + end do ! n = 1, nsize_aer(itype) + + + elseif(seasalt_emiss_active.eq.3 .or. seasalt_emiss_active.eq.4)then + do n = 1, nsize_aer(itype) + + ! apportion seasalt mass emissions assumming that seasalt is a + ! simple mix of pure nacl and a single primary organic + if(seasalt_emiss_active.eq.3)then + fracorg = org_frac_low_activity(n) + elseif(seasalt_emiss_active.eq.4)then + fracorg = org_frac_high_activity(n) + endif + fracna = mw_na_aer / (mw_na_aer + mw_cl_aer) + fraccl = 1.0 - fracna + fracna = (1.0-fracorg)*fracna + fraccl = (1.0-fracorg)*fraccl + + ! only apply emissions if bin has both na and cl species + l_na = lptr_na_aer(n,itype,iphase) + l_cl = lptr_cl_aer(n,itype,iphase) + l_oc = lptr_oc_aer(n,itype,iphase) + if ((l_na >= p1st) .and. (l_cl >= p1st) .and. (l_oc >= p1st)) then + + chem(i,k,j,l_na) = chem(i,k,j,l_na) + & + factbb * ssemfact_mass(n,itype) * fracna + + chem(i,k,j,l_cl) = chem(i,k,j,l_cl) + & + factbb * ssemfact_mass(n,itype) * fraccl + + chem(i,k,j,l_oc) = chem(i,k,j,l_oc) + & + factbb * ssemfact_mass(n,itype) * fracorg + + l = numptr_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + & + factbb * ssemfact_numb(n,itype) + + end if + + end do ! n = 1, nsize_aer(itype) + endif + + end do ! i = its, ite + end do ! j = jts, jte return @@ -830,6 +1005,416 @@ subroutine seasalt_emitfactors_1bin( ireduce_smallr_emit, & end subroutine seasalt_emitfactors_1bin +!c---------------------------------------------------------------------- +!c Following is an adaption of the subroutine above. +!c It has been modified to include flux from Fuentes et al, ACP, 2010 +!c for dealing with smaller particle emissions. +!c---------------------------------------------------------------------- + subroutine seasalt_emit_feuntes_1bin( & + dpdrylo_cm, dpdryhi_cm, & + emitfact_numb, emitfact_surf, emitfact_mass, nti, dp0gi, oc02um ) +!c +!c computes seasalt emissions factors for a specifed +!c dry particle size range +!c dpdrylo_cm = lower dry diameter (cm) +!c dpdryhi_cm = upper dry diameter (cm) +!c +!c number and mass emissions are then computed as +!c number emissions (#/m2/s) == emitfact_numb * (spd10*3.41) +!c dry-sfc emissions (cm2/m2/s) == emitfact_surf * (spd10*3.41) +!c dry-mass emissions (g/m2/s) == emitfact_mass * (spd10*3.41) +!c +!c where spd10 = 10 m windspeed in m/s +!c +!c Uses bubble emissions formula (eqn 5a) from +!c Gong et al. [JGR, 1997, p 3805-3818] for particles +!c with dry diameters of 0.45 um or more +!c +!c For smaller particles we use the parameterisation of +!c Fuentes et al, ACP, 2010. +!c + + + implicit none + + ! subr arguments + !integer ireduce_smallr_emit + real dpdrylo_cm, dpdryhi_cm, & + emitfact_numb, emitfact_surf, emitfact_mass + real, intent(in) :: nti(4), dp0gi(4), oc02um + + ! local variables + integer isub_bin, nsub_bin, jd, nsub_lower_bin, nsub_upper_bin + + real alnrdrylo + real drydens, drydens_43pi_em12, x_4pi_em8, drydens_16pi_em12, x_pi_em8 + real dum, dumadjust, dumb, dumexpb + real dumsum_na, dumsum_ma, dumsum_sa + real drwet, dlnrdry, ddwet, ddry, dwet + real df0drwet, df0dlnrdry, df0dlnrdry_star + real relhum + real rdry, rdrylo, rdryhi, rdryaa, rdrybb + real rdrylowermost, rdryuppermost, rdry_star + real rwet, rwetaa, rwetbb + real rdry_cm, rwet_cm + real sigmag_star + real xmdry, xsdry + + real ddrylo, ddryhi, alogddrylo + real ddrybb, ddry_cm, dwet_cm, dwetbb + real ddryaa, dwetaa, dlogddry, df0dlogddry + + real pi + parameter (pi = 3.1415936536) + + ! c1-c4 are constants for seasalt hygroscopic growth parameterization + ! in Eqn 3 and Table 2 of Gong et al. [1997] + real c1, c2, c3, c4, onethird + parameter (c1 = 0.7674) + parameter (c2 = 3.079) + parameter (c3 = 2.573e-11) + parameter (c4 = -1.424) + parameter (onethird = 1.0/3.0) + + + ! constants for seasalt/organic aerosol distribution parameterisation + ! from Fuentes et al, ACP, 2010 + real, save :: width_ssinorg_f(4) = & + (/ 1.55, 1.7, 1.5, 1.7 /) + real, save :: width_ssorg_f(4) = & + (/ 1.55, 1.9, 1.5, 1.7 /) + real :: width_ss_f(4), frac + ! scale_factor is a combination of: + ! 1) (Q) sweep air flow (58.3 cm3/s) + ! 2) (Ab) total surface area covered by bubbles (0.0146 m2) + ! 4) scaling factor of 3.84e-6 from the whitecap coverage formulation of + ! Monahan and O'Muircheartaigh (1980) - as the Gong et al formulation + ! includes a whitecap coverage factor too + ! this is for converting from dNt to dFp for Fuentes et al (ACP, 2010) + real, parameter :: scale_factor = 58.3/(0.0146)*3.84e-6 !0.01533 + + + ! select which distribution width to use for Fuentes et al, + if(oc02um.gt.0e0)then + width_ss_f = width_ssorg_f + else + width_ss_f = width_ssinorg_f + end if + + + ! dry particle density (g/cm3) + drydens = 2.165 + ! factor for radius (micrometers) to mass (g) + drydens_43pi_em12 = drydens*(4.0/3.0)*pi*1.0e-12 + ! factor for diameter (micrometers) to mass (g) + drydens_16pi_em12 = drydens*(1.0/6.0)*pi*1.0e-12 + ! factor for radius (micrometers) to surface (cm2) + x_4pi_em8 = 4.0*pi*1.0e-8 + ! factor for diameter (micrometers) to surface (cm2) + x_pi_em8 = pi*1.0e-8 + ! bubble emissions formula assume 80% RH + relhum = 0.80 + + ! rdry_star = dry radius (micrometers) below which the + ! dF0/dr emission formula from Fuentes et al, ACP, 2010 + ! will be used. + rdry_star = 0.45 / 2.0 + !if (ireduce_smallr_emit .le. 0) rdry_star = -1.0e20 + ! sigmag_star = geometric standard deviation used for + ! rdry < rdry_star + sigmag_star = 1.9 + + ! initialize sums + dumsum_na = 0.0 + dumsum_sa = 0.0 + dumsum_ma = 0.0 + + ! rdrylowermost, rdryuppermost = lower and upper + ! dry radii (micrometers) for overall integration + rdrylowermost = dpdrylo_cm*0.5e4 + rdryuppermost = dpdryhi_cm*0.5e4 + + + ! "section 1" + ! integrate over rdry > rdry_star, where the dF0/dr emissions + ! formula from the original subroutine is applicable + ! (so using Gong et al for all emission profile) + if (rdrylowermost .ge. rdry_star) then + + ! rdrylo, rdryhi = lower and upper dry radii (micrometers) + ! for this part of the integration + rdrylo = rdrylowermost + rdryhi = rdryuppermost + + nsub_bin = 1000 + + alnrdrylo = log( rdrylo ) + dlnrdry = (log( rdryhi ) - alnrdrylo)/nsub_bin + + ! compute rdry, rwet (micrometers) at lowest size + rdrybb = exp( alnrdrylo ) + rdry_cm = rdrybb*1.0e-4 + rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ & + ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird + rwetbb = rwet_cm*1.0e4 + + do isub_bin = 1, nsub_bin + + ! rdry, rwet at sub_bin lower boundary are those + ! at upper boundary of previous sub_bin + rdryaa = rdrybb + rwetaa = rwetbb + + ! compute rdry, rwet (micrometers) at sub_bin upper boundary + dum = alnrdrylo + isub_bin*dlnrdry + rdrybb = exp( dum ) + + rdry_cm = rdrybb*1.0e-4 + rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ & + ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird + rwetbb = rwet_cm*1.0e4 + + ! geometric mean rdry, rwet (micrometers) for sub_bin + rdry = sqrt(rdryaa * rdrybb) + rwet = sqrt(rwetaa * rwetbb) + drwet = rwetbb - rwetaa + + ! xmdry is dry mass in g + xmdry = drydens_43pi_em12 * (rdry**3.0) + + ! xsdry is dry surface in cm2 + xsdry = x_4pi_em8 * (rdry**2.0) + + ! dumb is "B" in Gong's Eqn 5a + ! df0drwet is "dF0/dr" in Gong's Eqn 5a + dumb = ( 0.380 - log10(rwet) ) / 0.650 + dumexpb = exp( -dumb*dumb) + df0drwet = 1.373 * (rwet**(-3.0)) * & + (1.0 + 0.057*(rwet**1.05)) * & + (10.0**(1.19*dumexpb)) + + dumsum_na = dumsum_na + drwet*df0drwet + dumsum_ma = dumsum_ma + drwet*df0drwet*xmdry + dumsum_sa = dumsum_sa + drwet*df0drwet*xsdry + + end do + + + ! "section 2" + ! integrate over rdry < rdry_star for old parameterisation, and use + ! Fuentes et al below that + ! + ! 1. for rdry < rdry_star, use Fuentes et al parameterisation + ! 2. for rdry > rdry_star, use Gong et al parameterisation, as above + elseif (rdryuppermost .gt. rdry_star) then + + ! determine the fraction of size bin below rdry_star + frac = (log(rdry_star)-log(rdrylowermost)) / (log(rdryuppermost)-log(rdrylowermost)) + nsub_lower_bin = floor(frac*1000.0) ! calc number of size bins to use for section below rdry_star + nsub_upper_bin = 1000-nsub_lower_bin ! use remaining size bins for section above rdry_star + + + ! 1................. + ! ddrylo, ddryhi = lower and upper dry diameter (micrometers) + ! for this part of the integration + ddrylo = rdrylowermost*2.0 + ddryhi = rdry_star*2.0 + + nsub_bin = nsub_lower_bin + + alogddrylo = log10( ddrylo ) + dlogddry = (log10( ddryhi ) - alogddrylo)/nsub_bin + + ! compute ddry, dwet (micrometers) at lowest size + ddrybb = 10.0**( alogddrylo ) + ddry_cm = ddrybb*1.0e-4 + dwet_cm = ( ddry_cm**3 + (c1*(ddry_cm**c2))/ & + ( (c3*(ddry_cm**c4)) - log10(relhum) ) )**onethird + dwetbb = dwet_cm*1.0e4 + + do isub_bin = 1, nsub_bin + + ! ddry, dwet at sub_bin lower boundary are those + ! at upper boundary of previous sub_bin + ddryaa = ddrybb + !dwetaa = dwetbb + + ! compute ddry, dwet (micrometers) at sub_bin upper boundary + dum = alogddrylo + isub_bin*dlogddry + ddrybb = 10.0**( dum ) + + ddry_cm = ddrybb*1.0e-4 + !dwet_cm = ( ddry_cm**3 + (c1*(ddry_cm**c2))/ & + ! ( (c3*(ddry_cm**c4)) - log10(relhum) ) )**onethird + !dwetbb = dwet_cm*1.0e4 + + ! geometric mean rdry, rwet (micrometers) for sub_bin + ddry = sqrt(ddryaa * ddrybb) + !dwet = sqrt(dwetaa * dwetbb) + + ! xmdry is dry mass in g + xmdry = drydens_16pi_em12 * (ddry**3.0) + + ! xsdry is dry surface in cm2 + xsdry = x_pi_em8 * (ddry**2.0) + + ! Equation 2 from Fuentes et al (ACP, 2011). Wet diameter is scaled by a factor + ! of 1e3 to convert from um to nm for this calculation + df0dlogddry = 0.0 + do jd = 1, 4 + df0dlogddry = df0dlogddry + nti(jd)/( (2.0*pi)**0.5 * log10(width_ss_f(jd)) ) & + * exp(-1.0/2.0 * (log10(ddry*1e3/dp0gi(jd))/log10(width_ss_f(jd)))**2.0 ) + end do + + dumsum_na = dumsum_na + dlogddry*df0dlogddry*scale_factor + dumsum_ma = dumsum_ma + dlogddry*df0dlogddry*scale_factor*xmdry + dumsum_sa = dumsum_sa + dlogddry*df0dlogddry*scale_factor*xsdry + + end do + + + ! 2................ + ! rdrylo, rdryhi = lower and upper dry radii (micrometers) + ! for this part of the integration + rdrylo = rdry_star + rdryhi = rdryuppermost + + nsub_bin = nsub_upper_bin + + alnrdrylo = log( rdrylo ) + dlnrdry = (log( rdryhi ) - alnrdrylo)/nsub_bin + + ! compute rdry, rwet (micrometers) at lowest size + rdrybb = exp( alnrdrylo ) + rdry_cm = rdrybb*1.0e-4 + rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ & + ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird + rwetbb = rwet_cm*1.0e4 + + do isub_bin = 1, nsub_bin + + ! rdry, rwet at sub_bin lower boundary are those + ! at upper boundary of previous sub_bin + rdryaa = rdrybb + rwetaa = rwetbb + + ! compute rdry, rwet (micrometers) at sub_bin upper boundary + dum = alnrdrylo + isub_bin*dlnrdry + rdrybb = exp( dum ) + + rdry_cm = rdrybb*1.0e-4 + rwet_cm = ( rdry_cm**3 + (c1*(rdry_cm**c2))/ & + ( (c3*(rdry_cm**c4)) - log10(relhum) ) )**onethird + rwetbb = rwet_cm*1.0e4 + + ! geometric mean rdry, rwet (micrometers) for sub_bin + rdry = sqrt(rdryaa * rdrybb) + rwet = sqrt(rwetaa * rwetbb) + drwet = rwetbb - rwetaa + + ! xmdry is dry mass in g + xmdry = drydens_43pi_em12 * (rdry**3.0) + + ! xsdry is dry surface in cm2 + xsdry = x_4pi_em8 * (rdry**2.0) + + ! dumb is "B" in Gong's Eqn 5a + ! df0drwet is "dF0/dr" in Gong's Eqn 5a + dumb = ( 0.380 - log10(rwet) ) / 0.650 + dumexpb = exp( -dumb*dumb) + df0drwet = 1.373 * (rwet**(-3.0)) * & + (1.0 + 0.057*(rwet**1.05)) * & + (10.0**(1.19*dumexpb)) + + dumsum_na = dumsum_na + drwet*df0drwet + dumsum_ma = dumsum_ma + drwet*df0drwet*xmdry + dumsum_sa = dumsum_sa + drwet*df0drwet*xsdry + + end do + + + + ! "section 3" + ! where rdry < rdry_star for the whole bin we use Fuentes et al + ! for all emissions + ! + else + + ! ddrylo, ddryhi = lower and upper dry diameter (micrometers) + ! for this part of the integration + ddrylo = rdrylowermost*2.0 + ddryhi = rdryuppermost*2.0 + + nsub_bin = 1000 + + alogddrylo = log10( ddrylo ) + dlogddry = (log10( ddryhi ) - alogddrylo)/nsub_bin + + ! compute ddry, dwet (micrometers) at lowest size + ddrybb = 10.0**( alogddrylo ) + ddry_cm = ddrybb*1.0e-4 + dwet_cm = ( ddry_cm**3 + (c1*(ddry_cm**c2))/ & + ( (c3*(ddry_cm**c4)) - log10(relhum) ) )**onethird + dwetbb = dwet_cm*1.0e4 + + do isub_bin = 1, nsub_bin + + ! ddry, dwet at sub_bin lower boundary are those + ! at upper boundary of previous sub_bin + ddryaa = ddrybb + !dwetaa = dwetbb + + ! compute ddry, dwet (micrometers) at sub_bin upper boundary + dum = alogddrylo + isub_bin*dlogddry + ddrybb = 10.0**( dum ) + + ddry_cm = ddrybb*1.0e-4 + !dwet_cm = ( ddry_cm**3 + (c1*(ddry_cm**c2))/ & + ! ( (c3*(ddry_cm**c4)) - log10(relhum) ) )**onethird + !dwetbb = dwet_cm*1.0e4 + + ! geometric mean rdry, rwet (micrometers) for sub_bin + ddry = sqrt(ddryaa * ddrybb) + !dwet = sqrt(dwetaa * dwetbb) + + ! xmdry is dry mass in g + xmdry = drydens_16pi_em12 * (ddry**3.0) + + ! xsdry is dry surface in cm2 + xsdry = x_pi_em8 * (ddry**2.0) + + ! Equation 2 from Fuentes et al (ACP, 2011). Wet diameter is scaled by a factor + ! of 1e3 to convert from um to nm for this calculation + df0dlogddry = 0.0 + do jd = 1, 4 + df0dlogddry = df0dlogddry + nti(jd)/( (2.0*pi)**0.5 * log10(width_ss_f(jd)) ) & + * exp(-1.0/2.0 * (log10(ddry*1e3/dp0gi(jd))/log10(width_ss_f(jd)))**2.0 ) + end do + + dumsum_na = dumsum_na + dlogddry*df0dlogddry*scale_factor + dumsum_ma = dumsum_ma + dlogddry*df0dlogddry*scale_factor*xmdry + dumsum_sa = dumsum_sa + dlogddry*df0dlogddry*scale_factor*xsdry + + end do + + + + end if + !c + !c all done + !c + emitfact_numb = dumsum_na + emitfact_mass = dumsum_ma + emitfact_surf = dumsum_sa + + + return + end subroutine seasalt_emit_feuntes_1bin + + + + + END MODULE module_mosaic_addemiss @@ -1284,6 +1869,16 @@ subroutine mosaic_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & itype = 1 iphase = ai_phase +! 20130603 acd_ck_emiss start + ! added option for 4bin WRF + IF (nsize_aer(itype) == 4) THEN + sz(1) = sz(1) + sz(2) + sz(2) = sz(3) + sz(4) + sz(3) = sz(5) + sz(6) + sz(4) = sz(7) + sz(8) + ENDIF +! 20130603 acd_ck_emiss end + conver=1.e-9 converi=1.e9 ! @@ -1351,6 +1946,13 @@ subroutine mosaic_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & ! mass1part is mass of a single particle in ug, density of dust ~2.5 g cm-3 if (n <= 5) densdust=2.5 if (n > 5 ) densdust=2.65 +! 20130603 acd_ck_emiss start + ! added option for 4bin WRF + if (nsize_aer(itype) == 4) then + if (n <= 2) densdust=2.5 + if (n > 2 ) densdust=2.65 + endif +! 20130603 acd_ck_emiss end mass1part=0.523598*(dcen_sect(n,itype)**3)*densdust*1.0e06 l = numptr_aer(n,itype,iphase) if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + & diff --git a/wrfv2_fire/chem/module_mosaic_driver.F b/wrfv2_fire/chem/module_mosaic_driver.F index 0b89c34e..17cca424 100644 --- a/wrfv2_fire/chem/module_mosaic_driver.F +++ b/wrfv2_fire/chem/module_mosaic_driver.F @@ -2687,7 +2687,8 @@ subroutine mapaer_tofrom_host( imap, & p_smpa,p_smpbb, & p_ant1_c,p_ant2_c,p_ant3_c,p_ant4_c,p_ant1_o,p_ant2_o,p_ant3_o,p_ant4_o,& p_biog1_c,p_biog2_c,p_biog3_c,p_biog4_c,p_biog1_o, & - p_biog2_o,p_biog3_o,p_biog4_o + p_biog2_o,p_biog3_o,p_biog4_o, & + p_n2o5, p_clno2 use module_state_description, only: param_first_scalar use module_data_mosaic_asect @@ -3057,6 +3058,10 @@ subroutine mapaer_tofrom_host( imap, & rsub(khcl,k1:k2,1) = chem(it,kt1:kt2,jt,p_hcl)/factgas if (p_nh3 .ge. p1st) & rsub(knh3,k1:k2,1) = chem(it,kt1:kt2,jt,p_nh3)/factgas + if (p_n2o5 .ge. p1st) & + rsub(kn2o5,k1:k2,1) = chem(it,kt1:kt2,jt,p_n2o5)/factgas + if (p_clno2 .ge. p1st) & + rsub(kclno2,k1:k2,1) = chem(it,kt1:kt2,jt,p_clno2)/factgas ! rce 2005-apr-12 - added following species for cldchem, here and below: ! ko3, kso2, kh2o2, khcho, khcooh, koh, kho2, @@ -3654,6 +3659,7 @@ subroutine mapaer_tofrom_host( imap, & if (aboxtest_gases_fixed .eq. 10) then if ((l .eq. kh2so4 ) .or. (l .eq. khno3 ) .or. & (l .eq. khcl ) .or. (l .eq. knh3 ) .or. & + (l .eq. kclno2 ) .or. (l .eq. kn2o5 ) .or. & (l .eq. ko3 ) .or. & (l .eq. kso2 ) .or. (l .eq. kh2o2 ) .or. & (l .eq. khcho ) .or. & @@ -3727,6 +3733,10 @@ subroutine mapaer_tofrom_host( imap, & chem(it,kt1:kt2,jt,p_hcl) = rsub(khcl,k1:k2,1)*factgas if (p_nh3 .ge. p1st) & chem(it,kt1:kt2,jt,p_nh3) = rsub(knh3,k1:k2,1)*factgas + if (p_n2o5 .ge. p1st) & + chem(it,kt1:kt2,jt,p_n2o5) = rsub(kn2o5,k1:k2,1)*factgas + if (p_clno2 .ge. p1st) & + chem(it,kt1:kt2,jt,p_clno2) = rsub(kclno2,k1:k2,1)*factgas if (p_o3 .ge. p1st) & chem(it,kt1:kt2,jt,p_o3) = rsub(ko3,k1:k2,1)*factgas @@ -4243,7 +4253,7 @@ end subroutine mapaer_tofrom_host !----------------------------------------------------------------------- ! *** note - eventually is_aerosol will be a subr argument - subroutine init_data_mosaic_asect( is_aerosol ) + subroutine init_data_mosaic_asect( n2o5_hetchem, is_aerosol ) ! subroutine init_data_mosaic_asect( ) use module_data_mosaic_asect @@ -4252,7 +4262,7 @@ subroutine init_data_mosaic_asect( is_aerosol ) aboxtest_rh_method, aboxtest_map_method, & aboxtest_gases_fixed, aboxtest_min_temp, & aboxtest_min_relhum, aboxtest_max_relhum - use module_data_mosaic_therm, only: nbin_a, nbin_a_maxd + use module_data_mosaic_therm, only: nbin_a, nbin_a_maxd, n2o5_flag use module_mosaic_csuesat, only: init_csuesat use module_mosaic_movesect, only: move_sections, test_move_sections use module_peg_util, only: peg_error_fatal @@ -4287,6 +4297,8 @@ subroutine init_data_mosaic_asect( is_aerosol ) ! *** note - eventually is_aerosol will be a subr argument logical, intent(out) :: is_aerosol(num_chem) +! control flag for N2O5 het chem scheme + integer, intent(in) :: n2o5_hetchem ! local variables integer idum, itype, l, ldum, n, nhi, nsize_aer_dum @@ -4385,6 +4397,8 @@ subroutine init_data_mosaic_asect( is_aerosol ) ! *** end of "box testing" code section *** #endif +! copy over N2O5 control flag (DL 9/6/2013) +n2o5_flag = n2o5_hetchem ! ! set master aerosol chemical types @@ -5143,7 +5157,8 @@ subroutine init_data_mosaic_ptr( is_aerosol ) kant1_c,kant2_c,kant3_c,kant4_c,kant1_o,kant2_o, & kant3_o,kant4_o, & kbiog1_c,kbiog2_c,kbiog3_c,kbiog4_c,kbiog1_o,kbiog2_o, & - kbiog3_o,kbiog4_o + kbiog3_o,kbiog4_o, & + kn2o5, kclno2 use module_peg_util, only: peg_error_fatal, peg_message use module_mosaic_wetscav, only: initwet @@ -7193,7 +7208,11 @@ subroutine init_data_mosaic_ptr( is_aerosol ) do ll = 1, ncomp_plustracer_aer(itype) - write(msg,9350) 'massptr_aer(), ll', & +! 20130116 acd_ck_bugfix start +! added writeout of name_aer to understand which mastercomps are used +! write(msg,9350) 'massptr_aer(), ll', & + write(msg,9350) name_aer(ll,itype), & +! 20130116 acd_ck_bugfix end (massptr_aer(ll,n,itype,iphase), n=1,nsize_aer(itype)), ll call peg_message( lunout, msg ) end do @@ -7303,6 +7322,10 @@ subroutine init_data_mosaic_ptr( is_aerosol ) y_biog2_o=0 y_biog3_o=0 y_biog4_o=0 +! 20130807 acd_alma_bugfix start + y_smpa=0 + y_smpbb=0 +! 20130807 acd_alma_bugfix end @@ -7405,6 +7428,10 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (lptr_biog2_o_aer(n,itype,iphase) .ge. p1st) y_biog2_o = y_biog2_o + 1 if (lptr_biog3_o_aer(n,itype,iphase) .ge. p1st) y_biog3_o = y_biog3_o + 1 if (lptr_biog4_o_aer(n,itype,iphase) .ge. p1st) y_biog4_o = y_biog4_o + 1 +! 20130807 acd_alma_bugfix start + if (lptr_smpa_aer(n,itype,iphase) .ge. p1st) y_smpa = y_smpa + 1 + if (lptr_smpbb_aer(n,itype,iphase) .ge. p1st) y_smpbb = y_smpbb + 1 +! 20130807 acd_alma_bugfix end end do @@ -8320,6 +8347,18 @@ subroutine init_data_mosaic_ptr( is_aerosol ) knh3 = p_nh3 ! else ! msg = '*** subr init_data_mosaic_ptr - ptr error for nh3' +! call peg_error_fatal( lunerr, msg ) + end if + if (p_n2o5 .ge. p1st) then + kn2o5 = p_n2o5 +! else +! msg = '*** subr init_data_mosaic_ptr - ptr error for n2o5' +! call peg_error_fatal( lunerr, msg ) + end if + if (p_clno2 .ge. p1st) then + kclno2 = p_clno2 +! else +! msg = '*** subr init_data_mosaic_ptr - ptr error for clno2' ! call peg_error_fatal( lunerr, msg ) end if if (p_o3 .ge. p1st) then @@ -8352,6 +8391,8 @@ subroutine init_data_mosaic_ptr( is_aerosol ) ltot = max( ltot, khno3 ) ltot = max( ltot, khcl ) ltot = max( ltot, knh3 ) + ltot = max( ltot, kn2o5 ) + ltot = max( ltot, kclno2 ) ltot = max( ltot, ko3 ) ltot = max( ltot, kso2 ) ltot = max( ltot, kh2o2 ) @@ -8576,6 +8617,8 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (p_biog4_o .ge. p1st) name(kbiog4_o ) = 'biog4_o' if (p_hcl .ge. p1st) name(khcl ) = 'hcl' if (p_nh3 .ge. p1st) name(knh3 ) = 'nh3' + if (p_n2o5 .ge. p1st) name(kn2o5 ) = 'n2o5' + if (p_clno2 .ge. p1st) name(kclno2 ) = 'clno2' if (p_o3 .ge. p1st) name(ko3 ) = 'o3' if (p_so2 .ge. p1st) name(kso2 ) = 'so2' if (p_h2o2 .ge. p1st) name(kh2o2 ) = 'h2o2' diff --git a/wrfv2_fire/chem/module_mosaic_newnuc.F b/wrfv2_fire/chem/module_mosaic_newnuc.F index 7170b630..a653cc2d 100644 --- a/wrfv2_fire/chem/module_mosaic_newnuc.F +++ b/wrfv2_fire/chem/module_mosaic_newnuc.F @@ -987,7 +987,7 @@ subroutine wexler_nuc_mosaic_1box( & ! ch2so4 = (ug-h2so4/m3-air) ! ch2so4*1.0e-12/mwh2so4 = (mole-h2so4/cm3-air) qh2so4_crit = (ch2so4_crit*1.0e-12/98.0)/cair - qh2so4_avail = qh2so4_cur - qh2so4_crit + qh2so4_avail = (qh2so4_cur - qh2so4_crit)*dtnuc ! if "available" h2so4 vapor < 4.0e-18 mole/mole-air ~= 1.0e2 molecules/cm3, ! exit with new particle formation = 0 diff --git a/wrfv2_fire/chem/module_mosaic_therm.F b/wrfv2_fire/chem/module_mosaic_therm.F index 1c57a832..e10d5e7e 100644 --- a/wrfv2_fire/chem/module_mosaic_therm.F +++ b/wrfv2_fire/chem/module_mosaic_therm.F @@ -605,6 +605,16 @@ subroutine map_mosaic_species(k, m, imap) else gas(inh3_g) = 0.0 end if + if (kn2o5 .ge. p1st) then + gas(in2o5_g) = rsub(kn2o5,k,m)*conv1a + else + gas(in2o5_g) = 0.0 + end if + if (kclno2 .ge. p1st) then + gas(iclno2_g) = rsub(kclno2,k,m)*conv1a + else + gas(iclno2_g) = 0.0 + end if ! soa gas-phase species -- currently deactivated if (kpcg1_b_c .ge. p1st) then @@ -1721,6 +1731,10 @@ subroutine map_mosaic_species(k, m, imap) rsub(khcl,k,m) = gas(ihcl_g)*conv1b if (knh3 .ge. p1st) & rsub(knh3,k,m) = gas(inh3_g)*conv1b + if (kn2o5 .ge. p1st) & + rsub(kn2o5,k,m) = gas(in2o5_g)*conv1b + if (kclno2 .ge. p1st) & + rsub(kclno2,k,m) = gas(iclno2_g)*conv1b ! soa gas-phase species -- currently deactivated if (kpcg1_b_c .ge. p1st) & @@ -2641,7 +2655,7 @@ subroutine aerosol_phase_state(ibin) ah2o = rh_pc*0.01 ah2o_a(ibin) = ah2o kelvin(ibin) = 1.0 - do iv = 1, ngas_volatile + do iv = 1, ngas_volatile+ngas_het kel(iv,ibin) = 1.0 enddo @@ -2714,7 +2728,7 @@ subroutine aerosol_phase_state(ibin) if(jaerosolstate(ibin) .eq. all_liquid)jhyst_leg(ibin) = jhyst_up ! now compute kelvin effect terms for condensing species (nh3, hno3, and hcl) - do iv = 1, ngas_volatile + do iv = 1, ngas_volatile+ngas_het term = 4.*sigma_soln(ibin)*partial_molar_vol(iv)/ & (8.3144e7*T_K*DpmV(ibin)) kel(iv,ibin) = 1. + term*(1. + 0.5*term*(1. + term/3.)) @@ -4658,7 +4672,9 @@ subroutine ASTEM(dtchem,vbs_nbin) integer ibin real(kind=8) dumdum integer vbs_nbin(1) - +! 20130807 acd_alma_bugfix start + integer start_svoc, Nsoa +! 20130807 acd_alma_bugfix end ! logical first ! save first ! data first/.true./ @@ -4714,18 +4730,42 @@ subroutine ASTEM(dtchem,vbs_nbin) call ASTEM_non_volatiles(dtchem) ! analytical solution if (istat_mosaic_fe1 .lt. 0) return +! DL - 20/11/2012 - recalculate the mass balance to take account of +! NO3- and Cl- changes from N2O5 het reactions + call overall_massbal_in ! save input mass over all bins + + ! condense inorganic semi-volatile gases hno3, hcl, nh3, and co2 call ASTEM_semi_volatiles(dtchem) ! semi-implicit + explicit euler if (istat_mosaic_fe1 .lt. 0) return ! condense secondary organic gases (8 sorgam species) if (istat_mosaic_fe1 .lt. 0) return -!BSINGH (PNNL)- Following 3 lines are commented due to array out of bound error in equilibrium_smp - !if (vbs_nbin.eq.0) then - !call equilibrium_smp - !else - call equilibrium - !Bend if + +! 20130807 acd_alma_bugfix start + start_svoc = 1 + Nsoa = 0 + ! simple version, Hodzic and Jimenez, GMD, 2011 + if (vbs_nbin(1).eq.0) then + start_svoc = ismpa_g + Nsoa = ngas_volatile-start_svoc + ! 9-bin version + else + start_svoc = ipcg1_b_c_g + Nsoa = ngas_volatile-start_svoc + end if + + call equilibrium(start_svoc,Nsoa) + +!!BSINGH (PNNL)- Following 3 lines are commented due to array out of bound error in equilibrium_smp +! !if (vbs_nbin.eq.0) then +! !call equilibrium_smp +! !else +! call equilibrium +! !Bend if +! +! 20130807 acd_alma_bugfix end + ! template for error status checking ! if (iprint_mosaic_fe1 .gt. 0) then ! write(6,*)'error in computing dtmax for soa' @@ -4830,8 +4870,14 @@ end subroutine print_mosaic_stats ! Calculates the equilibrium gas-particle partitioning for SOA species - subroutine equilibrium +! 20130807 acd_alma_bugfix start + subroutine equilibrium(start_ind,N) +! subroutine equilibrium +! 20130807 acd_alma_bugfix end ! This routine was implemented by Manish Shrivastava on 12/24/2009 to do gas-particle partitioning of SOA assuming thermodynamic equilibrium. +! 20130807 acd_alma_bugfix start +! Modified by Alma Hodzic 12/2012 to implement the partitioning for mozart-mosaic species (based on the initial code implemented by Manish Shrivastava and originated from CAMx) +! 20130807 acd_alma_bugfix end ! This would give MOSAIC cpabilities of running both dynamic and equilibrium gas-particle partitioning ! Calls the subroutine soap. Subroutine soap calls subroutine spfcn ! use module_data_mosaic_main @@ -4839,7 +4885,10 @@ subroutine equilibrium implicit none real(kind=8), parameter :: tinys=1.0d-15 - integer, parameter :: N=ngas_soa !Total number of soa species +! 20130807 acd_alma_bugfix start + integer, intent(in) :: start_ind, N +! integer, parameter :: N=ngas_soa !Total number of soa species +! 20130807 acd_alma_bugfix end integer, parameter :: itermax=2000 integer idxfresh(N),idxaged(N) !counter for fresh and aged soa species real(kind=8) :: dq,frqfresh(nbin_a),frqaged(nbin_a) @@ -4884,9 +4933,26 @@ subroutine equilibrium ! Initialize flagsoap do i=1,N flagsoap(i)=1 +! 20130807 acd_alma_bugfix start + Ctot(i) = 0.0 + Ctotaged(i) = 0.0 + Ctotfresh(i) = 0.0 + Caer(i) = 0.0 + Caeraged(i) = 0.0 + Caerfresh(i) = 0.0 + Cgas(i) = 0.0 + Cgasaged(i) = 0.0 + Cgasfresh(i) = 0.0 + Csat(i) = 0.0 + Csataged(i) = 0.0 + Csatfresh(i) = 0.0 +! 20130807 acd_alma_bugfix end enddo +! 20130807 acd_alma_bugfix start ! Calculate Ctot and Paer - do iv = ipcg1_b_c_g, ngas_volatile +! do iv = ipcg1_b_c_g, ngas_volatile + do iv = start_ind, ngas_ioa + ngas_soa +! 20130807 acd_alma_bugfix end total_species(iv) = gas(iv) do ibin = 1, nbin_a total_species(iv) = total_species(iv) + aer(iv,jtotal,ibin) @@ -4897,13 +4963,14 @@ subroutine equilibrium do ibin=1,nbin_a cpxaged= cpxaged+aer(ioc_a,jp,ibin) enddo -!remove ioc_a to check equlibrium calculations by Manish Shrivastava on 02/04/2010 -! Maps arrays starting from ipcg1_b_c_g on to corresponding arrays starting from 1 for just soa species + +! 20130807 acd_alma_bugfix start +! Maps arrays starting from start_ind or ipcg1_b_c_g on to corresponding arrays starting from 1 for just soa species do i=1,N - Ctot(i)=total_species(ipcg1_b_c_g+i-1) - Caer(i)=Paer(ipcg1_b_c_g+i-1) - Csat(i)=sat_soa(ipcg1_b_c_g+i-1) - Cgas(i)=gas(ipcg1_b_c_g+i-1) + Ctot(i)=total_species(start_ind+i-1) + Caer(i)=Paer(start_ind+i-1) + Csat(i)=sat_soa(start_ind+i-1) + Cgas(i)=gas(start_ind+i-1) enddo ! Initialize mapping array indices @@ -4914,35 +4981,40 @@ subroutine equilibrium ! Seperate the fresh and aged species and treat them as 2 different solutions. Note this approach differes from PMCAMx ! In PMCAMx if flagsoap(i) was set to zero those species were not considered solution forming. - - do i=1,9 - flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species - enddo - do i=10,18 - flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species - enddo - do i=19,26 - flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species - enddo - do i=27,34 - flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species - enddo - do i=35,43 - flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species - enddo - do i=44,52 - flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species - enddo - do i=53,60 - flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species - enddo - do i=61,68 +! 20130807 acd_alma_bugfix start + do i=1,N flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species - enddo - do i=69,84 - flagsoap(i)=1 !Oxidized fossil oxygen - enddo + enddo + +! do i=1,9 +! flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species +! enddo +! do i=10,18 +! flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species +! enddo +! do i=19,26 +! flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species +! enddo +! do i=27,34 +! flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species +! enddo +! do i=35,43 +! flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species +! enddo +! do i=44,52 +! flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species +! enddo +! do i=53,60 +! flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species +! enddo +! do i=61,68 +! flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species +! enddo +! do i=69,84 +! flagsoap(i)=1 !Oxidized fossil oxygen +! enddo +! 20130807 acd_alma_bugfix end do i=1,N if (flagsoap(i).eq.2) then ! fresh primary species forming 1 solution @@ -5006,15 +5078,27 @@ subroutine equilibrium xsumfresh(ibin)=0.0 xsumaged(ibin)=0.0 xsumaged(ibin)= xsumaged(ibin)+aer(ioc_a,jp,ibin)!Caluclate pre-existing primary in each bin for aged aerosol - do iv = ipcg1_b_c_g, ngas_volatile - if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then +! 20130807 acd_alma_bugfix start + do iv = start_ind, ngas_ioa + ngas_soa + if (flagsoap(iv-start_ind+1).eq.2) then xsumfresh(ibin)= xsumfresh(ibin)+aer(iv,jtotal,ibin) - elseif (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then + elseif (flagsoap(iv-start_ind+1).eq.1) then xsumaged(ibin)= xsumaged(ibin)+aer(iv,jtotal,ibin) - elseif (flagsoap(iv-ipcg1_b_c_g+1).eq.0) then - print *, 'Error in mapping flagsoap to ipcg1_b_c_g' + elseif (flagsoap(iv-start_ind+1).eq.0) then + print *, 'Error in mapping flagsoap to start_ind' endif enddo +! do iv = ipcg1_b_c_g, ngas_volatile +! if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then +! xsumfresh(ibin)= xsumfresh(ibin)+aer(iv,jtotal,ibin) +! elseif (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then +! xsumaged(ibin)= xsumaged(ibin)+aer(iv,jtotal,ibin) +! elseif (flagsoap(iv-ipcg1_b_c_g+1).eq.0) then +! print *, 'Error in mapping flagsoap to ipcg1_b_c_g' +! endif +! enddo +! 20130807 acd_alma_bugfix end + ! Give a small non-zero value to xsum if it is zero in the section if (xsumfresh(ibin).eq.0.0) xsumfresh(ibin)=tinys if (xsumaged(ibin).eq.0.0) xsumaged(ibin)=tinys @@ -5023,9 +5107,14 @@ subroutine equilibrium ! Calculate dq as (gas concentration) G(t)-G(t+h): ! Caluclate driving force at previous time step (Cgas,i-XiCsati) for both fresh and aged solutions - do iv = ipcg1_b_c_g, ngas_volatile - if (Ctot(iv-ipcg1_b_c_g+1).lt.1d-10) goto 120 ! If a given species concentration is too low skip - dq=gas(iv)-Cgas(iv-ipcg1_b_c_g+1) !Since both fresh and aged species have been remapped to an array going from 1 to N +! 20130807 acd_alma_bugfix start + do iv = start_ind, ngas_ioa + ngas_soa + if (Ctot(iv-start_ind+1).lt.1d-10) goto 120 ! If a given species concentration is too low skip + dq=gas(iv)-Cgas(iv-start_ind+1) !Since both fresh and aged species have been remapped to an array going from 1 to N +! do iv = ipcg1_b_c_g, ngas_volatile +! if (Ctot(iv-ipcg1_b_c_g+1).lt.1d-10) goto 120 ! If a given species concentration is too low skip +! dq=gas(iv)-Cgas(iv-ipcg1_b_c_g+1) !Since both fresh and aged species have been remapped to an array going from 1 to N +! 20130807 acd_alma_bugfix end frqtotfresh=0.0d0 frqtotaged=0.0d0 mnkfresh=0.0d0 @@ -5036,26 +5125,42 @@ subroutine equilibrium ! fraceq(iv,ibin) is calculated as the rate of mass transfer ! The weighting fractions frqfresh(ibin) amd frqaged(ibin) are caluclated assuming mole fractions from previous time step ! This assumtion could be relaxed by iterativetely solving this equation - if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then +! 20130807 acd_alma_bugfix start + if (flagsoap(iv-start_ind+1).eq.2) then frqfresh(ibin)= kg(iv,ibin)*(gas(iv) & ! replaced fraceq(iv,ibin) by kg(iv,ibin) on 01/19/10 -(aer(iv,jtotal,ibin))/xsumfresh(ibin) & - *Csat(iv-ipcg1_b_c_g+1)) + *Csat(iv-start_ind+1)) endif - if (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then + if (flagsoap(iv-start_ind+1).eq.1) then frqaged(ibin)= kg(iv,ibin)*(gas(iv) & ! replaced fraceq(iv,ibin) by kg(iv,ibin) on 01/19/10 -(aer(iv,jtotal,ibin))/xsumaged(ibin) & - *Csat(iv-ipcg1_b_c_g+1)) + *Csat(iv-start_ind+1)) endif +! if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then +! frqfresh(ibin)= kg(iv,ibin)*(gas(iv) & ! replaced fraceq(iv,ibin) by kg(iv,ibin) on 01/19/10 +! -(aer(iv,jtotal,ibin))/xsumfresh(ibin) & +! *Csat(iv-ipcg1_b_c_g+1)) +! endif +! +! if (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then +! frqaged(ibin)= kg(iv,ibin)*(gas(iv) & ! replaced fraceq(iv,ibin) by kg(iv,ibin) on 01/19/10 +! -(aer(iv,jtotal,ibin))/xsumaged(ibin) & +! *Csat(iv-ipcg1_b_c_g+1)) +! endif +! 20130807 acd_alma_bugfix end mnkfresh=min(mnkfresh,frqfresh(ibin)) mnkaged=min(mnkaged,frqaged(ibin)) mxkfresh=max(mxkfresh,frqfresh(ibin)) mxkaged=max(mxkaged,frqaged(ibin)) enddo ! for ibin +! 20130807 acd_alma_bugfix start ! Repeat code from this point on for aged aerosol species - if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then + if (flagsoap(iv-start_ind+1).eq.2) then +! if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then +! 20130807 acd_alma_bugfix end ! Condensation is favored in the next time step in this bin if(dq.gt.0.and.mnkfresh.lt.0.and.mxkfresh.gt.0) then do ibin=1,nbin_a @@ -5077,8 +5182,11 @@ subroutine equilibrium do ibin=1,nbin_a frqfresh(ibin)=frqfresh(ibin)/frqtotfresh enddo - - elseif(flagsoap(iv-ipcg1_b_c_g+1).eq.1) then + +! 20130807 acd_alma_bugfix start + elseif(flagsoap(iv-start_ind+1).eq.1) then +! elseif(flagsoap(iv-ipcg1_b_c_g+1).eq.1) then +! 20130807 acd_alma_bugfix end if(dq.gt.0.and.mnkaged.lt.0.and.mxkaged.gt.0) then do ibin=1,nbin_a frqaged(ibin)=max(frqaged(ibin)-mnkaged,0.0d0) @@ -5100,29 +5208,48 @@ subroutine equilibrium endif ! for flagsoap ! Condense all condensing species if(dq.gt.0.0d0) then - ! Map the species back into the original MOSAIC arrays +! 20130807 acd_alma_bugfix start + ! Map the species back into the original MOSAIC arrays do ibin=1,nbin_a - if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then + if (flagsoap(iv-start_ind+1).eq.2) then aer(iv,jtotal,ibin)= aer(iv,jtotal,ibin)+dq*frqfresh(ibin) endif - if (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then + if (flagsoap(iv-start_ind+1).eq.1) then aer(iv,jtotal,ibin)= aer(iv,jtotal,ibin)+dq*frqaged(ibin) endif enddo ! Set the gas phase species to equilibrium value - gas(iv)=Cgas(iv-ipcg1_b_c_g+1) + gas(iv)=Cgas(iv-start_ind+1) + +! do ibin=1,nbin_a +! if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then +! aer(iv,jtotal,ibin)= aer(iv,jtotal,ibin)+dq*frqfresh(ibin) +! endif +! if (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then +! aer(iv,jtotal,ibin)= aer(iv,jtotal,ibin)+dq*frqaged(ibin) +! endif +! enddo +!! Set the gas phase species to equilibrium value +! gas(iv)=Cgas(iv-ipcg1_b_c_g+1) +! 20130807 acd_alma_bugfix end ! Evaporate all evaporating species elseif(dq.lt.0.0d0) then iter=0 100 frt=1.0d0 do ibin=1,nbin_a - if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then +! 20130807 acd_alma_bugfix start + if (flagsoap(iv-start_ind+1).eq.2) then +! if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then +! 20130807 acd_alma_bugfix end ! Cannot evaporate more than whats in the bin ie ratio (aer(iv,jtotal,ibin)/dq*frqfresh(ibin)) should be less than equal to 1 if(frqfresh(ibin).gt.0.0d0) & frt=MAX(MIN(aer(iv,jtotal,ibin)/abs(-dq*frqfresh(ibin)),frt),0.0d0) - elseif(flagsoap(iv-ipcg1_b_c_g+1).eq.1) then +! 20130807 acd_alma_bugfix start +! elseif(flagsoap(iv-ipcg1_b_c_g+1).eq.1) then + elseif(flagsoap(iv-start_ind+1).eq.1) then +! 20130807 acd_alma_bugfix end if(frqaged(ibin).gt.0.0d0) & frt=MAX(MIN(aer(iv,jtotal,ibin)/abs(-dq*frqaged(ibin)),frt),0.0d0) endif ! for flagsoap @@ -5134,13 +5261,19 @@ subroutine equilibrium frqtotaged=0.0d0 do ibin=1,nbin_a - if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then +! 20130807 acd_alma_bugfix start + if (flagsoap(iv-start_ind+1).eq.2) then +! if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then +! 20130807 acd_alma_bugfix end aer(iv,jtotal,ibin)= & ! Since dq is negative this is evaporating aerosols MAX(aer(iv,jtotal,ibin)+frt*dq*frqfresh(ibin),0.0d0) if(aer(iv,jtotal,ibin).lt.tinys) frqfresh(ibin)=0.0d0 frqtotfresh=frqtotfresh+frqfresh(ibin) - elseif (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then +! 20130807 acd_alma_bugfix start +! elseif (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then + elseif (flagsoap(iv-start_ind+1).eq.1) then +! 20130807 acd_alma_bugfix end aer(iv,jtotal,ibin)= & MAX(aer(iv,jtotal,ibin)+frt*dq*frqaged(ibin),0.0d0) if(aer(iv,jtotal,ibin).lt.tinys) frqaged(ibin)=0.0d0 @@ -5150,7 +5283,10 @@ subroutine equilibrium ! Check if we should evaporate more dq=(1.0d0-frt)*dq - if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then +! 20130807 acd_alma_bugfix start +! if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then + if (flagsoap(iv-start_ind+1).eq.2) then +! 20130807 acd_alma_bugfix end if(dq.lt.-1.d-8) then ! check if d-8 is better if(frqtotfresh.gt.tinys) then ! we have sections which are not empty if(iter.le.itermax) then ! check infinite loop @@ -5162,7 +5298,10 @@ subroutine equilibrium endif ! for iter endif ! frqtotfresh.gt.tinys endif ! dq.lt.-1.d-7 - elseif (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then +! 20130807 acd_alma_bugfix start +! elseif (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then + elseif (flagsoap(iv-start_ind+1).eq.1) then +! 20130807 acd_alma_bugfix end if(dq.lt.-1.d-8) then if(frqtotaged.gt.tinys) then ! we have sections which are not empty if(iter.le.itermax) then ! check infinite loop @@ -5181,14 +5320,17 @@ subroutine equilibrium endif ! for flagsoap ! now set the gas species concentration conservatively - gas(iv)=Ctot(iv-ipcg1_b_c_g+1) +! 20130807 acd_alma_bugfix start +! gas(iv)=Ctot(iv-ipcg1_b_c_g+1) + gas(iv)=Ctot(iv-start_ind+1) +! 20130807 acd_alma_bugfix end do ibin=1,nbin_a gas(iv)=gas(iv)-aer(iv,jtotal,ibin) enddo endif ! if dq.gt.0 120 continue - enddo ! for iv=ipcg1_b_c_g + enddo ! for iv=start_ind end subroutine equilibrium @@ -5197,350 +5339,11 @@ end subroutine equilibrium ! Calculates the equilibrium gas-particle partitioning for SOA species when MOZART_MOSAIC_4BIN_VBS0_KPP is used ! This routine was modified by Alma Hodzic based on the initial code implemented by Manish Shrivastava and originated from CAMx - subroutine equilibrium_smp - - implicit none - real(kind=8), parameter :: tinys=1.0d-15 - integer, parameter :: N=ngas_soa !Total number of soa species - integer, parameter :: itermax=2000 - integer idxfresh(N),idxaged(N) !counter for fresh and aged soa species - real(kind=8) :: dq,frqfresh(nbin_a),frqaged(nbin_a) - real(kind=8) :: frqtotfresh,frqtotaged,frt - real(kind=8) :: xsumfresh(nbin_a),xsumaged(nbin_a) - real(kind=8) :: mnkfresh,mxkfresh,mnkaged,mxkaged - real betak - real(kind=8) :: Csatfresh(N), Ctotfresh(N) - real(kind=8) :: Cgasfresh(N),Caerfresh(N) ! Csat: Saturation conc., Ctot: Total organic mass - real(kind=8) :: Csataged(N), Ctotaged(N) - real(kind=8) :: Cgasaged(N),Caeraged(N) - integer nsolfresh,nsolaged,ntrack,icontfresh,icontaged ! counters corresponding to fresh and aged species for mapping - real(kind=8) :: cpxfresh,cpxaged !Moles of pre-existing fresh and aged particle phase organic mass - integer ibin,iter ! Bin nos. -! local variables - integer iv, jp - real(kind=8) :: dum, sum_dum, sum_soa, small_oc - - real(kind=8) :: cpx !pre-existing OA umol/m3^M - real(kind=8) :: Ctot(N),Caer(N),Cgas(N),Csat(N) - real(kind=8) :: Paer(ngas_volatile) - integer :: i -! LOGICAL check - jp=jtotal - iter=0 - cpxaged=0.0 - cpxfresh=0.0 ! Assume no pres-existing OA forms a solution - nsolfresh=0 - nsolaged=0 - icontfresh=0 - icontaged=0 - dq=0.0 -! Paer holds the organic aerosol values in each volatility bin (sum of all size bins) - do iv=1,ngas_volatile - Paer(iv)=0.0 - enddo -! Initialize flagsoap - do i=1,N - flagsoap(i)=1 - enddo -! Calculate Ctot and Paer - do iv = ismpa_g, ngas_volatile - total_species(iv) = gas(iv) - do ibin = 1, nbin_a - total_species(iv) = total_species(iv) + aer(iv,jtotal,ibin) - Paer(iv)=Paer(iv)+aer(iv,jtotal,ibin) - enddo - enddo -! Calculate pre-existing moles of OA (cpx) as sum of all size bins - do ibin=1,nbin_a - cpxaged= cpxaged+aer(ioc_a,jp,ibin) - enddo - if(cpxaged .eq. 0.0 )then - print*,"No OA mass available for partitioning - " , & - "make sure that OA is included in IC/BC" - stop - endif - -!remove ioc_a to check equlibrium calculations by Manish Shrivastava on 02/04/2010 -! Maps arrays starting from ismpa_g on to corresponding arrays starting from 1 for just soa species - do i=1,N - Ctot(i)=total_species(ismpa_g+i-1) - Caer(i)=Paer(ismpa_g+i-1) - Csat(i)=sat_soa(ismpa_g+i-1) - Cgas(i)=gas(ismpa_g+i-1) - enddo - -! Initialize mapping array indices - do i=1,N - idxfresh(i)=0 - idxaged(i)=0 - enddo -! Seperate the fresh and aged species and treat them as 2 different solutions. Note this approach differes from PMCAMx -! In PMCAMx if flagsoap(i) was set to zero those species were not considered solution forming. - - - do i=1,2 - flagsoap(i)=1 ! alma: for smpa and smpbb - set to 1- contribute to the partitionning mass.. - but double counting with the other SOA. It is ok if the VBS is taken out - enddo - do i=3,18 - flagsoap(i)=1 !Oxidized fossil oxygen - enddo - - do i=1,N - if (flagsoap(i).eq.2) then ! fresh primary species forming 1 solution - icontfresh=icontfresh+1 ! count the number of fresh species - idxfresh(icontfresh) = i !Map the species - Csatfresh(icontfresh)=Csat(i) - Ctotfresh(icontfresh)=Ctot(i) - Caerfresh(icontfresh)=Caer(i) - Cgasfresh(icontfresh)=Cgas(i) - nsolfresh=nsolfresh+1 - elseif (flagsoap(i).eq.1) then ! Aged SOA species forming another solution - icontaged=icontaged+1 - idxaged(icontaged) = i - Csataged(icontaged)=Csat(i) - Ctotaged(icontaged)=Ctot(i) - Caeraged(icontaged)=Caer(i) - Cgasaged(icontaged)=Cgas(i) - nsolaged=nsolaged+1 - endif - enddo - -! Caluclate the initial equilibrium partitioning by the bisection method (CMU PMCAMx approach) -! If all fresh abd aged species form a solution -! call soap(ngas_soa,Ctot,Csat,Caer,Cgas,cpx) - -! if fresh and aged species form seperate solutions - if (nsolfresh.gt.0) call soap(nsolfresh,Ctotfresh, & - Csatfresh,Caerfresh,Cgasfresh,cpxfresh) - if (nsolaged.gt.0) call soap(nsolaged,Ctotaged, & - Csataged,Caeraged,Cgasaged,cpxaged) - - -! Map the fresh and aged species back into original arrays -! Now assign the equilibrium gas-particle partitioning arrays - ntrack=0 - do i=1,N ! Map the fresh and aged species back into array from 1 to N after calculating equilibrium - if (idxfresh(i).gt.0) then - Caer(idxfresh(i))= Caerfresh(i) - Cgas(idxfresh(i))= Cgasfresh(i) - Ctot(idxfresh(i))= Ctotfresh(i) - ntrack=ntrack+1 - endif - if (idxaged(i).gt.0) then - Caer(idxaged(i))= Caeraged(i) - Cgas(idxaged(i))= Cgasaged(i) - Ctot(idxaged(i))= Ctotaged(i) - ntrack=ntrack+1 - endif - enddo -! Check for total number of species - if (ntrack.ne.N) then - print *, 'Error in mapping fresh and primary species arrays' - print *, ntrack,N,ngas_soa - stop - endif -! From here on distribute the organic aerosol in size bins following Koo et al. 2003 " Integrated approaches to modeling -! the organic and inorganic atmospheric aerosol components" -! The original code from PMCAMx was modified to include 2 solutions for fresh and primary species -! by Manish Shrivastava on 01/11/2010 -! Calculate total organic aerosol OA(in nmoles/m3) in each bin for either of fresh and aged aerosols - - do ibin=1,nbin_a - xsumfresh(ibin)=0.0 - xsumaged(ibin)=0.0 - xsumaged(ibin)= xsumaged(ibin)+aer(ioc_a,jp,ibin)!Caluclate pre-existing primary in each bin for aged aerosol - do iv = ismpa_g, ngas_volatile - if (flagsoap(iv-ismpa_g+1).eq.2) then - xsumfresh(ibin)= xsumfresh(ibin)+aer(iv,jtotal,ibin) - elseif (flagsoap(iv-ismpa_g+1).eq.1) then - xsumaged(ibin)= xsumaged(ibin)+aer(iv,jtotal,ibin) - elseif (flagsoap(iv-ismpa_g+1).eq.0) then - print *, 'Error in mapping flagsoap to ismpa_g' - endif - enddo - -! Give a small non-zero value to xsum if it is zero in the section - if (xsumfresh(ibin).eq.0.0) xsumfresh(ibin)=tinys - if (xsumaged(ibin).eq.0.0) xsumaged(ibin)=tinys - enddo - - -! Calculate dq as (gas concentration) G(t)-G(t+h): -! Caluclate driving force at previous time step (Cgas,i-XiCsati) for both fresh and aged solutions - do iv = ismpa_g, ngas_volatile - if (Ctot(iv-ismpa_g+1).lt.1d-10) goto 120 ! If a given species concentration is too low skip - dq=gas(iv)-Cgas(iv-ismpa_g+1) !Since both fresh and aged species have been remapped to an array going from 1 to N - frqtotfresh=0.0d0 - frqtotaged=0.0d0 - mnkfresh=0.0d0 - mnkaged=0.0d0 - mxkfresh=0.0d0 - mxkaged=0.0d0 - do ibin=1,nbin_a -! fraceq(iv,ibin) is calculated as the rate of mass transfer -! The weighting fractions frqfresh(ibin) amd frqaged(ibin) are caluclated assuming mole fractions from previous time step -! This assumtion could be relaxed by iterativetely solving this equation - if (flagsoap(iv-ismpa_g+1).eq.2) then - frqfresh(ibin)= kg(iv,ibin)*(gas(iv) & ! replaced fraceq(iv,ibin) by kg(iv,ibin) on 01/19/10 - -(aer(iv,jtotal,ibin))/xsumfresh(ibin) & - *Csat(iv-ismpa_g+1)) - endif - - if (flagsoap(iv-ismpa_g+1).eq.1) then - frqaged(ibin)= kg(iv,ibin)*(gas(iv) & ! replaced fraceq(iv,ibin) by kg(iv,ibin) on 01/19/10 - -(aer(iv,jtotal,ibin))/xsumaged(ibin) & - *Csat(iv-ismpa_g+1)) - endif - - mnkfresh=min(mnkfresh,frqfresh(ibin)) - mnkaged=min(mnkaged,frqaged(ibin)) - - mxkfresh=max(mxkfresh,frqfresh(ibin)) - mxkaged=max(mxkaged,frqaged(ibin)) - enddo ! for ibin -! Repeat code from this point on for aged aerosol species - if (flagsoap(iv-ismpa_g+1).eq.2) then -! Condensation is favored in the next time step in this bin - if(dq.gt.0.and.mnkfresh.lt.0.and.mxkfresh.gt.0) then - do ibin=1,nbin_a - frqfresh(ibin)=max(frqfresh(ibin)-mnkfresh,0.0d0) - enddo -! evaporation is favored in the next time step in this bin - elseif(dq.lt.0.and.mxkfresh.gt.0.and.mnkfresh.lt.0) then - do ibin=1,nbin_a - frqfresh(ibin)=min(frqfresh(ibin)-mxkfresh,0.0d0) - enddo - endif - do ibin=1,nbin_a - frqtotfresh=frqtotfresh+frqfresh(ibin) - enddo -! Re-normalize frqfresh(ibin) -! Additional code to check for frqtotfresh and frqtotaged -! Added by Manish Shrivastava on 02/19/2010 - - do ibin=1,nbin_a - frqfresh(ibin)=frqfresh(ibin)/frqtotfresh - enddo - - elseif(flagsoap(iv-ismpa_g+1).eq.1) then - if(dq.gt.0.and.mnkaged.lt.0.and.mxkaged.gt.0) then - do ibin=1,nbin_a - frqaged(ibin)=max(frqaged(ibin)-mnkaged,0.0d0) - enddo - elseif(dq.lt.0.and.mxkaged.gt.0.and.mnkaged.lt.0) then - do ibin=1,nbin_a - frqaged(ibin)=min(frqaged(ibin)-mxkaged,0.0d0) - enddo - endif - - do ibin=1,nbin_a - frqtotaged=frqtotaged+frqaged(ibin) - enddo - - do ibin=1,nbin_a - frqaged(ibin)=frqaged(ibin)/frqtotaged - enddo - - endif ! for flagsoap -! Condense all condensing species - if(dq.gt.0.0d0) then - ! Map the species back into the original MOSAIC arrays - - do ibin=1,nbin_a - if (flagsoap(iv-ismpa_g+1).eq.2) then - aer(iv,jtotal,ibin)= aer(iv,jtotal,ibin)+dq*frqfresh(ibin) - endif - if (flagsoap(iv-ismpa_g+1).eq.1) then - aer(iv,jtotal,ibin)= aer(iv,jtotal,ibin)+dq*frqaged(ibin) - endif - enddo -! Set the gas phase species to equilibrium value - gas(iv)=Cgas(iv-ismpa_g+1) - -! Evaporate all evaporating species - elseif(dq.lt.0.0d0) then - iter=0 -100 frt=1.0d0 - do ibin=1,nbin_a - if (flagsoap(iv-ismpa_g+1).eq.2) then -! Cannot evaporate more than whats in the bin ie ratio (aer(iv,jtotal,ibin)/dq*frqfresh(ibin)) should be less than equal to 1 - if(frqfresh(ibin).gt.0.0d0) & - frt=MAX(MIN(aer(iv,jtotal,ibin)/abs(-dq*frqfresh(ibin)),frt),0.0d0) - elseif(flagsoap(iv-ismpa_g+1).eq.1) then - if(frqaged(ibin).gt.0.0d0) & - frt=MAX(MIN(aer(iv,jtotal,ibin)/abs(-dq*frqaged(ibin)),frt),0.0d0) - endif ! for flagsoap - enddo ! for ibin - - - - frqtotfresh=0.0d0 - frqtotaged=0.0d0 - - do ibin=1,nbin_a - if (flagsoap(iv-ismpa_g+1).eq.2) then - aer(iv,jtotal,ibin)= & - -! Since dq is negative this is evaporating aerosols - MAX(aer(iv,jtotal,ibin)+frt*dq*frqfresh(ibin),0.0d0) - if(aer(iv,jtotal,ibin).lt.tinys) frqfresh(ibin)=0.0d0 - frqtotfresh=frqtotfresh+frqfresh(ibin) - elseif (flagsoap(iv-ismpa_g+1).eq.1) then - aer(iv,jtotal,ibin)= & - MAX(aer(iv,jtotal,ibin)+frt*dq*frqaged(ibin),0.0d0) - if(aer(iv,jtotal,ibin).lt.tinys) frqaged(ibin)=0.0d0 - frqtotaged=frqtotaged+frqaged(ibin) - endif ! for flagsoap - enddo ! for ibin - -! Check if we should evaporate more - dq=(1.0d0-frt)*dq - if (flagsoap(iv-ismpa_g+1).eq.2) then - if(dq.lt.-1.d-8) then ! check if d-8 is better - if(frqtotfresh.gt.tinys) then ! we have sections which are not empty - if(iter.le.itermax) then ! check infinite loop - iter = iter + 1 - do ibin = 1,nbin_a - frqfresh(ibin) = frqfresh(ibin) / frqtotfresh - enddo ! for ibin - goto 100 - endif ! for iter - endif ! frqtotfresh.gt.tinys - endif ! dq.lt.-1.d-7 - elseif (flagsoap(iv-ismpa_g+1).eq.1) then - if(dq.lt.-1.d-8) then - if(frqtotaged.gt.tinys) then ! we have sections which are not empty - if(iter.le.itermax) then ! check infinite loop - iter = iter + 1 - do ibin = 1,nbin_a - frqaged(ibin) = frqaged(ibin) / frqtotaged - enddo - goto 100 - endif - endif - endif - - ! we need to evaporate more to achieve equilibrium - ! but we completely evaporated the species in all sections - ! or exceeded itermax - endif ! for flagsoap - - -! now set the gas species concentration conservatively - gas(iv)=Ctot(iv-ismpa_g+1) - do ibin=1,nbin_a - gas(iv)=gas(iv)-aer(iv,jtotal,ibin) - enddo - endif ! if dq.gt.0 - -120 continue - enddo ! for iv=ismpa_g - - end subroutine equilibrium_smp - - - -! ---- +!++ alma - removed the subroutine equilibrium_smp +! subroutine equilibrium_smp +!.. +! end subroutine equilibrium_smp +!-- ! This subroutine spfcn calculates the objective function fval to solve gas-particle partitioning of SOA ! Subroutine spfcn is called from within the subroutine soap @@ -7942,6 +7745,11 @@ subroutine ASTEM_non_volatiles(dtchem) ! TOUCH delta_h2so4, delta_tmsa, delta_nh3, delta_hno3, delta_hcl, & delta_so4(nbin_a), delta_msa(nbin_a), & delta_nh4(nbin_a) + ! DL (10/7/2012) - move N2O5 het uptake into non-volatile subroutine, so that + ! NH3 uptake to balance acid uptake takes place too + real(kind=8) :: decay_n2o5, & + delta_n2o5, delta_clno2, & + delta_no3_rct1(nbin_a), delta_no3_rct2(nbin_a) real(kind=8) XT @@ -7959,6 +7767,11 @@ subroutine ASTEM_non_volatiles(dtchem) ! TOUCH sumkg_hno3 = sumkg_hno3 + kg(ihno3_g,ibin) sumkg_hcl = sumkg_hcl + kg(ihcl_g,ibin) enddo + ! DL (10/7/2012) + sumkg_n2o5 = 0.0 + do ibin = 1, nbin_a + sumkg_n2o5 = sumkg_n2o5 + kg(in2o5_g,ibin) + enddo @@ -8024,6 +7837,71 @@ subroutine ASTEM_non_volatiles(dtchem) ! TOUCH + if(n2o5_flag .gt. 0) then + ! DL (10/7/2012) moved from separate subroutine into involatile subroutine + !-------------------------------------- + ! N2O5 uptake, if there is enough gas, and uptake is non-zero + ! (currently we only calculate uptake for aqueous particles, + ! so in some circumstances we could have aerosol but no reaction) + if(gas(in2o5_g) .gt. 1.e-14 .and. sumkg_n2o5 .gt. 0.0)then + + ! integrate n2o5 condensation analytically + decay_n2o5 = exp(-sumkg_n2o5*dtchem) + delta_n2o5 = gas(in2o5_g)*(1.0 - decay_n2o5) + gas(in2o5_g) = gas(in2o5_g)*decay_n2o5 + + + ! now distribute delta_n2o5 to each bin and conform the particle (may degas by massbal) + do ibin = 1, nbin_a + if(jaerosolstate(ibin) .ne. no_aerosol)then + delta_no3_rct1(ibin) = delta_n2o5*frac_n2o5_h2o(ibin)*kg(in2o5_g,ibin)/sumkg_n2o5 + delta_no3_rct2(ibin) = delta_n2o5*(1.0-frac_n2o5_h2o(ibin))*kg(in2o5_g,ibin)/sumkg_n2o5 + + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jtotal,ibin) + & + (2.0*delta_no3_rct1(ibin)+delta_no3_rct2(ibin)) + ! check to ensure we don't get negative Cl- concentrations + ! - if this will occur then branch the remaining N2O5 to reaction 1 + if(aer(icl_a,jtotal,ibin).ge.delta_no3_rct2(ibin))then + aer(icl_a,jtotal,ibin) = aer(icl_a,jtotal,ibin) - & + delta_no3_rct2(ibin) + gas(iclno2_g) = gas(iclno2_g) + & + delta_no3_rct2(ibin) + else + aer(ino3_a,jtotal,ibin) = aer(ino3_a,jtotal,ibin) + & + (delta_no3_rct2(ibin)-aer(icl_a,jtotal,ibin)) + gas(iclno2_g) = gas(iclno2_g) + & + aer(icl_a,jtotal,ibin) + + ! record the amount of remaining N2O5 which branches to reaction 1 (this is + ! for the purposes of determining NH3 uptake later) + delta_no3_rct1(ibin) = delta_no3_rct1(ibin) + (delta_no3_rct2(ibin)-aer(icl_a,jtotal,ibin)) + delta_no3_rct2(ibin) = aer(icl_a,jtotal,ibin) + + aer(icl_a,jtotal,ibin) = 0.0 + endif + endif + enddo + + else + + delta_n2o5 = 0.0 + do ibin = 1, nbin_a + delta_no3_rct1(ibin) = 0.0 + delta_no3_rct2(ibin) = 0.0 + enddo + + endif + else + delta_n2o5 = 0.0 ! if we're not using the N2O5 het scheme then set these to zero for ion balance calculations below + do ibin = 1, nbin_a + delta_no3_rct1(ibin) = 0.0 + delta_no3_rct2(ibin) = 0.0 + enddo + endif + + + + ! compute max allowable nh3, hno3, and hcl condensation delta_nh3 = gas(inh3_g) *(1.0 - exp(-sumkg_nh3*dtchem)) delta_hno3= gas(ihno3_g)*(1.0 - exp(-sumkg_hno3*dtchem)) @@ -8039,7 +7917,7 @@ subroutine ASTEM_non_volatiles(dtchem) ! TOUCH enddo - if(delta_h2so4 .eq. 0.0 .and. delta_tmsa .eq. 0.0)then + if(delta_h2so4 .eq. 0.0 .and. delta_tmsa .eq. 0.0 .and. delta_n2o5 .eq. 0.0)then iupdate_phase_state = mNO goto 100 endif @@ -8055,7 +7933,7 @@ subroutine ASTEM_non_volatiles(dtchem) ! TOUCH epercent(jcaco3,jtotal,ibin) .eq. 0.0 .and. & jaerosolstate(ibin) .ne. no_aerosol)then - delta_nh4(ibin)=min( (2.*delta_so4(ibin)+delta_msa(ibin)), & + delta_nh4(ibin)=min( (2.*delta_so4(ibin)+delta_msa(ibin)+2.*delta_no3_rct1(ibin)+delta_no3_rct2(ibin)), & delta_nh3_max(ibin) ) aer(inh4_a,jtotal,ibin) = aer(inh4_a,jtotal,ibin) + & ! update aer-phase @@ -8109,6 +7987,9 @@ subroutine aerosolmtc(vbs_nbin) ! include 'mosaic.h' ! local variables integer nghq,vbs_nbin(1) +! 20130618 acd_ck_vbsmoz start + integer start_ind +! 20130618 acd_ck_vbsmoz end parameter (nghq = 2) ! gauss-hermite quadrature order integer ibin, iq, iv real(kind=8) tworootpi, root2, beta @@ -8116,9 +7997,9 @@ subroutine aerosolmtc(vbs_nbin) real(kind=8) cdum, dp, dp_avg, fkn, kn, lnsg, lndpgn, lndp, speed, & sumghq real(kind=8) xghq(nghq), wghq(nghq) ! quadrature abscissae and weights - real(kind=8) mw_vol(ngas_volatile), v_molar(ngas_volatile), & ! mw and molar vols of volatile species - freepath(ngas_volatile), accom(ngas_volatile), & - dg(ngas_volatile) ! keep local + real(kind=8) mw_vol(ngas_volatile+ngas_het), v_molar(ngas_volatile+ngas_het), & ! mw and molar vols of volatile species + freepath(ngas_volatile+ngas_het), accom(ngas_volatile+ngas_het), & + dg(ngas_volatile+ngas_het) ! keep local ! real(kind=8) fuchs_sutugin ! mosaic func ! real(kind=8) gas_diffusivity ! mosaic func ! real(kind=8) mean_molecular_speed ! mosaic func @@ -8132,6 +8013,8 @@ subroutine aerosolmtc(vbs_nbin) mw_vol(ihno3_g) = 63.0 mw_vol(ihcl_g) = 36.5 mw_vol(inh3_g) = 17.0 + mw_vol(in2o5_g) = 108.0 + mw_vol(iclno2_g) = 81.5 mw_vol(imsa_g) = 96.0 mw_vol(ipcg1_b_c_g) =250.0 mw_vol(ipcg2_b_c_g) =250.0 @@ -8229,12 +8112,16 @@ subroutine aerosolmtc(vbs_nbin) v_molar(ihcl_g) = 21.48 v_molar(inh3_g) = 14.90 v_molar(imsa_g) = 58.00 + v_molar(in2o5_g) = 60.40 + v_molar(iclno2_g)= 52.70 ! mass accommodation coefficients accom(ih2so4_g) = 0.1 accom(ihno3_g) = 0.1 accom(ihcl_g) = 0.1 accom(inh3_g) = 0.1 + accom(in2o5_g) = 0.1 ! dummy variable - will recalc later.. + accom(iclno2_g) = 0.1 ! dummy - for convenience of calcs accom(imsa_g) = 0.1 accom(ipcg1_b_c_g) =0.1 accom(ipcg2_b_c_g) =0.1 @@ -8343,19 +8230,27 @@ subroutine aerosolmtc(vbs_nbin) enddo ! soa +! 20130618 acd_ck_vbsmoz start + start_ind = 1 if(vbs_nbin(1) .eq. 0) then - do iv = ismpa_g, ngas_volatile - speed = mean_molecular_speed(t_k,mw_vol(iv)) ! cm/s - dg(iv) = 0.1 ! cm^2/s (increased from 0.2 to 0.035 by Manish Shrivastava) - freepath(iv) = 3.*dg(iv)/speed - enddo + start_ind = ismpa_g else - do iv = ipcg1_b_c_g, ngas_volatile + start_ind = ipcg1_b_c_g + end if + + do iv = start_ind, ngas_ioa + ngas_soa speed = mean_molecular_speed(t_k,mw_vol(iv)) ! cm/s dg(iv) = 0.1 ! cm^2/s (increased from 0.2 to 0.035 by Manish Shrivastava) freepath(iv) = 3.*dg(iv)/speed enddo - end if +! 20130618 acd_ck_vbsmoz end + +! het-rct gases ! DL 9/9/2011 + do iv = (ngas_volatile+1), (ngas_volatile+ngas_het) + speed = mean_molecular_speed(t_k,mw_vol(iv)) ! cm/s + dg(iv) = gas_diffusivity(t_k,p_atm,mw_vol(iv),v_molar(iv)) ! cm^2/s + freepath(iv) = 3.*dg(iv)/speed ! cm + enddo ! calc mass transfer coefficients for gases over various aerosol bins @@ -8375,7 +8270,20 @@ subroutine aerosolmtc(vbs_nbin) cdum = tworootpi*num_a(ibin)* & exp(beta*lndpgn + 0.5*(beta*lnsg)**2) - do 20 iv = 1, ngas_volatile + do 20 iv = 1, ngas_volatile + ngas_het + + if(iv.eq.in2o5_g)then ! recalculate accom coeff for N2O5 + ! for each different aerosol composition + ! (use total aerosol composition for now) + if(n2o5_flag.gt.0)then + accom(iv) = acc_n2o5_bert_thorn(water_a(ibin),& + aer(ino3_a,jtotal,ibin),& + aer(icl_a,jtotal,ibin),& + vol_wet_a(ibin)) + else + accom(iv) = 0.0 + endif + end if sumghq = 0.0 do 30 iq = 1, nghq ! sum over gauss-hermite quadrature points @@ -8388,6 +8296,17 @@ subroutine aerosolmtc(vbs_nbin) kg(iv,ibin) = cdum*dg(iv)*sumghq ! 1/s 20 continue + + if(n2o5_flag.gt.0)then + ! calculate the reaction path splitting for + ! heterogeneous N2O5 reactions + frac_n2o5_h2o(ibin) = split_n2o5_bert_thorn(water_a(ibin),& + aer(icl_a,jtotal,ibin),& + vol_wet_a(ibin)) + else + frac_n2o5_h2o(ibin) = 0.0 + endif + 10 continue elseif(msize_framework .eq. msection)then @@ -8402,13 +8321,34 @@ subroutine aerosolmtc(vbs_nbin) dp_avg = dp_wet_a(ibin) cdum = 6.283185*dp_avg*num_a(ibin) - do 21 iv = 1, ngas_volatile + do 21 iv = 1, ngas_volatile+ngas_het + if(iv.eq.in2o5_g)then ! recalculate accom coeff for N2O5 + ! for each different aerosol composition + ! (use total aerosol composition for now) + if(n2o5_flag.gt.0)then + accom(iv) = acc_n2o5_bert_thorn(water_a(ibin),& + aer(ino3_a,jtotal,ibin),& + aer(icl_a,jtotal,ibin),& + vol_wet_a(ibin)) + else + accom(iv) = 0.0 + end if + end if kn = 2.*freepath(iv)/dp_avg fkn = fuchs_sutugin(kn,accom(iv)) kg(iv,ibin) = cdum*dg(iv)*fkn ! 1/s!Increased by a factor of 10000 by Manish Shrivastava to force to equilibrium ! fraceq(iv,ibin)=num_a(ibin)*dp_wet_a(ibin)/(kn/accom(iv)+1) 21 continue - + if(n2o5_flag.gt.0)then + ! calculate the reaction path splitting for + ! heterogeneous N2O5 reactions + frac_n2o5_h2o(ibin) = split_n2o5_bert_thorn(water_a(ibin),& + aer(icl_a,jtotal,ibin),& + vol_wet_a(ibin)) + else + frac_n2o5_h2o(ibin) = 0.0 + end if + 11 continue else @@ -11710,7 +11650,8 @@ subroutine load_mosaic_parameters ibiog2_o_g =89 ibiog3_o_g =90 ibiog4_o_g =91 - + in2o5_g =92 ! ioa --> NO3- + iclno2_g =93 ! ioa N2O5+Cl- --> ! ico2_g = 14 ! currently not used @@ -12143,6 +12084,8 @@ subroutine load_mosaic_parameters gas_name(ibiog2_o_g)="biog2_o" gas_name(ibiog3_o_g)="biog3_o" gas_name(ibiog4_o_g)="biog4_o" + gas_name(in2o5_g) = "n2o5 " + gas_name(iclno2_g)= "clno2" ! names of electrolytes ename(jnh4so4) = 'amso4' @@ -12762,6 +12705,8 @@ subroutine load_mosaic_parameters partial_molar_vol(ibiog2_o_g)=250.0 partial_molar_vol(ibiog3_o_g)=250.0 partial_molar_vol(ibiog4_o_g)=250.0 + partial_molar_vol(in2o5_g) = 200.0 ! assumed... + partial_molar_vol(iclno2_g) = 200.0 ! assumed... ! refractive index ref_index_a(jnh4so4) = cmplx(1.52,0.) @@ -15246,6 +15191,9 @@ subroutine update_thermodynamic_constants(vbs_nbin) ! include 'mosaic.h' ! local variables integer iv, j_index, ibin, je,vbs_nbin(1) +! 20130816 acd_ck_vbsmoz start + integer start_ind +! 20130816 acd_ck_vbsmoz end real(kind=8) :: tr, rt, term real(kind=8) :: gam_nh4no3_0, gam_nh4cl_0, m_nh4no3_0, m_nh4cl_0 ! raz update 6/25/2008 ! function @@ -15294,15 +15242,18 @@ subroutine update_thermodynamic_constants(vbs_nbin) keq_sl(jcano3) = fn_keq(4.31d5, 7.83d0,42.01d0, t_k)*1.e5 ! ca(no3)2(s) = ca++ + 2no3- keq_sl(jcamsa2) = 1.e15 ! CaMSA2(s)= Ca+ + 2MSA- +! 20130816 acd_ck_vbsmoz start + start_ind = 1 if (vbs_nbin(1).eq.0) then - do iv = ismpa_g, ngas_volatile - sat_soa(iv) = 0.0 ! [nmol/m^3(air)] - enddo + start_ind = ismpa_g else - do iv = ipcg1_b_c_g, ngas_volatile + start_ind = ipcg1_b_c_g + endif + + do iv = start_ind, ngas_ioa + ngas_soa sat_soa(iv) = 0.0 ! [nmol/m^3(air)] enddo - end if +! 20130816 acd_ck_vbsmoz end if (vbs_nbin(1).eq.9) then ! vapor pressures of soa species @@ -15418,15 +15369,19 @@ subroutine update_thermodynamic_constants(vbs_nbin) po_soa(ibiog1_o_g) = fn_po(9.91d-6, 83.0d0, T_K) ! [Pascal] endif +! 20130716 acd_ck_vbsmoz start + start_ind = 1 if (vbs_nbin(1).eq.0) then - do iv = ismpa_g, ngas_volatile - sat_soa(iv) = 1.e9*po_soa(iv)/(8.314*t_k) ! [nmol/m^3(air)] - enddo + start_ind = ismpa_g else - do iv = ipcg1_b_c_g, ngas_volatile + start_ind = ipcg1_b_c_g + end if + + do iv = start_ind, ngas_ioa + ngas_soa sat_soa(iv) = 1.e9*po_soa(iv)/(8.314*t_k) ! [nmol/m^3(air)] enddo - endif +! 20130716 acd_ck_vbsmoz end + ! water surface tension term = (647.15 - t_k)/647.15 sigma_water = 0.2358*term**1.256 * (1. - 0.625*term) ! surface tension of pure water in n/m @@ -15822,6 +15777,139 @@ end function fuchs_sutugin +!---------------------------------------------------------- + real(kind=8) function acc_n2o5_bert_thorn(mass_h2o,mol_no3,mol_cl,vol) + ! Composition dependent mass accommodation coefficient. + ! After Bertram and Thornton, ACP, 2009 + ! + ! acc_N2O5 = A*(b-b*exp(-d*[H2O(l)])) + ! * (1-1/(1+(k3'*[H2O(l)]/[NO3-])+(k4'*[Cl-]/[NO3-]))) + ! where: + ! acc_N2O5 = accommodation coefficient of N2O5 on the aerosol + ! A = factor for experimental conditions = 3.2e-8 s + ! b = 1.15e6 s^-1 + ! d = 1.3e-1 M^-1 + ! [H2O(l)] = H2O Molarity + ! k3' (=k3/k2b) = 6.0e-2 + ! k4' (=k4/k2b) = 29e0 + ! [Cl-] = Cl- Molarity + ! [NO3-] = NO3- Molarity + + ! define set factors for scheme + real(kind=8), parameter :: A_bt = 3.2e-8 + real(kind=8), parameter :: b_bt = 1.15e6 + real(kind=8), parameter :: d_bt = 1.3e-1 + real(kind=8), parameter :: k3_bt = 6.0e-2 + real(kind=8), parameter :: k4_bt = 29e0 + + ! internal conversion factors + real(kind=8), parameter :: nmol_mol = 1e-9 ! convert nmol->mol + real(kind=8), parameter :: m3_litre = 1e3 ! convert m3->litre + real(kind=8), parameter :: mm_h2o = 18e-3 ! molar mass (kg/mol) + + ! input variables + real(kind=8) :: mass_h2o ! kg(water)/m^3(air) + real(kind=8) :: mol_no3 ! nmol/m^3(air?) + real(kind=8) :: mol_cl ! nmol/m^3(air?) + real(kind=8) :: vol ! cc/cc(air) - wet volume + + ! internal variables + real(kind=8) :: part_step + real(kind=8) :: aer_h2o, aer_no3, aer_cl ! molarity - mol/litre(solution) + + + ! extract and convert aerosol data from inputs to Moles/litre(solution) + aer_h2o = mass_h2o / (mm_h2o*vol*m3_litre) + aer_no3 = mol_no3*nmol_mol / (vol*m3_litre) + aer_cl = mol_cl*nmol_mol / (vol*m3_litre) + + if(n2o5_flag.eq.1)then ! switch off Cl pathway + aer_cl = 0.0 + end if + + if(aer_h2o .ne. 0.0)then + part_step = b_bt - b_bt * exp(-d_bt*aer_h2o) + if(aer_no3 .ne. 0.0)then + acc_n2o5_bert_thorn = A_bt * part_step * & + (1.0 - 1.0 / ( & + 1.0 + & + (k3_bt*aer_h2o/aer_no3) + & + (k4_bt*aer_cl/aer_no3) & + )) + else + acc_n2o5_bert_thorn = A_bt * part_step + endif + else ! if no aerosol water then don't take up N2O5 + acc_n2o5_bert_thorn = 0.0 + endif + + return + end function acc_n2o5_bert_thorn +!------------------------------------------------------------- + + +!------------------------------------------------------------- + real(kind=8) function split_n2o5_bert_thorn(mass_h2o,mol_cl,vol) + ! Hetereogeneous reaction of N2O5 with H2O(l) and Cl-(aq) + ! after Bertram and Thornton, ACP, 2009 + ! Subroutine for splitting reaction pathways + ! + ! R3f = 1 / (1+(k4'[Cl-])/(k3'[H2O(l)])) (H2O pathway) + ! R4f = 1 / (1+(k3'[H2O(l)])/(k4'[Cl-])) (Cl- pathway) + ! where: + ! R3f = fraction of N2O5 that reacts with H2O + ! R4f = fraction of N2O5 that reacts with Cl- + ! [H2O(l)] = H2O Molarity + ! [Cl-] = Cl- Molarity + ! k3' (=k3/k2b) = 6.0e-2 + ! k4' (=k4/k2b) = 29e0 + ! + ! This function outputs the fraction of N2O5 which reacts + ! with H2O + + ! define parameters for the scheme + real(kind=8), parameter :: k3_bt = 6.0e-2 + real(kind=8), parameter :: k4_bt = 29e0 + + ! internal conversion factors + real(kind=8), parameter :: nmol_mol = 1e-9 ! convert nmol->mol + real(kind=8), parameter :: m3_litre = 1e3 ! convert m3->litre + real(kind=8), parameter :: mm_h2o = 18e-3 ! molar mass (kg/mol) + + ! input variables + real(kind=8) :: mass_h2o ! kg(water)/m^3(air) + real(kind=8) :: mol_cl ! nmol/m^3(air?) + real(kind=8) :: vol ! cc/cc(air) - wet volume + + ! internal variables + real(kind=8) :: part_step + real(kind=8) :: aer_h2o, aer_cl ! molarity - mol/litre(solution) + + + ! extract and convert aerosol data from inputs to Moles/litre(solution) + aer_h2o = mass_h2o / (mm_h2o*vol*m3_litre) + aer_cl = mol_cl*nmol_mol / (vol*m3_litre) + + if(n2o5_flag.eq.1)then ! switch off Cl pathway + aer_cl = 0.0 + end if + + if(aer_h2o .ne. 0.0)then + split_n2o5_bert_thorn = 1e0 / & + ( 1e0 + (k4_bt*aer_cl)/(k3_bt*aer_h2o) ) + else + split_n2o5_bert_thorn = 0.0 + endif + + + + return + end function split_n2o5_bert_thorn +!------------------------------------------------------------- + + + + !---------------------------------------------------------- diff --git a/wrfv2_fire/chem/module_mosaic_wetscav.F b/wrfv2_fire/chem/module_mosaic_wetscav.F index a91c0651..5d46b150 100644 --- a/wrfv2_fire/chem/module_mosaic_wetscav.F +++ b/wrfv2_fire/chem/module_mosaic_wetscav.F @@ -200,24 +200,21 @@ subroutine wetscav (id,ktau,dtstep,ktauc,config_flags, & do 100 k=kts,kte do 100 i=its,ite - scale=max((1.-dtstepc*qlsink(i,k,j)),0.) - if(scale.gt.1.)then - print *,'qlsink,scale=',qlsink(i,k,j),scale,' i,k,j=',i,k,j - scale=1. - endif + scale=1.0-dtstepc*qlsink(i,k,j) + scale=max(0.0,min(1.0,scale)) ! make sure 0 <= scale <= 1 if (qlsink(i,k,j) > 0.0) then - pdel_fac = pdel(i,k,j)/(g*mwdry) + pdel_fac = pdel(i,k,j)/g do n=1,ntype_aer do m=1,nsize_aer(n) do l=1,ncomp_aer(n) lmasscw=massptr_aer(l,m,n,cw_phase) if (lmasscw < param_first_scalar) cycle - qsrflx(i,j,lmasscw)=qsrflx(i,j,lmasscw)+chem(i,k,j,lmasscw)*(scale-1.)*pdel_fac + qsrflx(i,j,lmasscw)=qsrflx(i,j,lmasscw)+chem(i,k,j,lmasscw)*(scale-1.)*pdel_fac ! aerosol mass (ug/m2) chem(i,k,j,lmasscw)=chem(i,k,j,lmasscw)*scale end do ! comp lnumcw=numptr_aer(m,n,cw_phase) if (lnumcw < param_first_scalar) cycle - qsrflx(i,j,lnumcw)=qsrflx(i,j,lnumcw)+chem(i,k,j,lnumcw)*(scale-1.)*pdel_fac + qsrflx(i,j,lnumcw)=qsrflx(i,j,lnumcw)+chem(i,k,j,lnumcw)*(scale-1.)*pdel_fac ! aerosol number (1/m2) chem(i,k,j,lnumcw)=chem(i,k,j,lnumcw)*scale end do ! size end do ! type @@ -232,11 +229,11 @@ subroutine wetscav (id,ktau,dtstep,ktauc,config_flags, & do 270 k = kts,kte do 270 i = its,ite fracscav = dtstepc*qlsink(i,k,j)*gas_aqfrac(i,k,j,l) - if (fracscav > 0.0) then - fracscav = max( 0.0, min( 1.0, fracscav ) ) + if (fracscav > 0.0) then ! make sure fracscav > 0 + fracscav = min(1.0,fracscav) ! make sure fracscav <= 1 scale = 1.0 - fracscav pdel_fac = pdel(i,k,j)/(g*mwdry) - qsrflx(i,j,l) = qsrflx(i,j,l)+chem(i,k,j,l)*(scale-1.)*pdel_fac + qsrflx(i,j,l) = qsrflx(i,j,l)+chem(i,k,j,l)*(scale-1.)*pdel_fac ! mmol/m2 chem(i,k,j,l) = chem(i,k,j,l)*scale end if 270 continue @@ -461,7 +458,10 @@ subroutine aerimpactscav (ims,ime,kms,kme,jms,jme,its,ite,kts,kte,jts,jte,num_ch real, intent(inout) :: dqdt(ims:ime,kms:kme,jms:jme,num_chem) ! TMR tendency array logical, intent(inout) :: dotend(num_chem) ! flag for doing scav - real, intent(inout) :: qsrflx(ims:ime,jms:jme,num_chem) ! column tracer tendencies + real, intent(inout) :: qsrflx(ims:ime,jms:jme,num_chem) + ! changes to column tracer burdens by wet scavenging over current timestep + ! this routine adds on the contribution from aerosol impaction and brownian + ! diffusion scavenging by precipitation integer, intent(in) :: maxd_atype, maxd_asize, maxd_acomp, maxd_aphase integer, intent(in) :: ai_phase integer, intent(in) :: ntype_aer @@ -500,7 +500,7 @@ subroutine aerimpactscav (ims,ime,kms,kme,jms,jme,its,ite,kts,kte,jts,jte,num_ch real :: dumlogdens, dumlogptot, dumlogtemp real :: dumnumb real :: dumscavratenum, dumscavratevol - real :: pdel_fac + real :: pdel_dt_fac real :: pf_to_prmmh real :: scavimptbl1, scavimptbl2, scavimptbl3, scavimptbl4 real :: xgrow @@ -716,24 +716,25 @@ subroutine aerimpactscav (ims,ime,kms,kme,jms,jme,its,ite,kts,kte,jts,jte,num_ch ! ! compute tendencies ! - pdel_fac = pdel(i,k,j)/(g*mwdry) + pdel_dt_fac = deltat*pdel(i,k,j)/g dumrate = -dumimpactamt3/(deltat*(1.0 + 1.0e-8)) + dumrate = min(0.0,max(-1.0/deltat,dumrate)) ! make sure -1 <= dumrate*deltat <= 0 do ll = 1, ncomp_aer(n) l = massptr_aer(ll,m,n,ai_phase) if (l < param_first_scalar) cycle dqdt(i,k,j,l) = chem(i,k,j,l)*dumrate - qsrflx(i,j,l) = qsrflx(i,j,l) + dqdt(i,k,j,l)*pdel_fac + qsrflx(i,j,l) = qsrflx(i,j,l) + dqdt(i,k,j,l)*pdel_dt_fac ! aerosol mass (ug/m2) end do l = waterptr_aer(m,n) if (l >= param_first_scalar) then dqdt(i,k,j,l) = chem(i,k,j,l)*dumrate - qsrflx(i,j,l) = qsrflx(i,j,l) + dqdt(i,k,j,l)*pdel_fac + qsrflx(i,j,l) = qsrflx(i,j,l) + dqdt(i,k,j,l)*pdel_dt_fac ! aerosol water mass (ug/m2) end if l = numptr_aer(m,n,ai_phase) if (l >= param_first_scalar) then dumrate = -dumimpactamt0/(deltat*(1.0 + 1.0e-8)) dqdt(i,k,j,l) = chem(i,k,j,l)*dumrate - qsrflx(i,j,l) = qsrflx(i,j,l) + dqdt(i,k,j,l)*pdel_fac + qsrflx(i,j,l) = qsrflx(i,j,l) + dqdt(i,k,j,l)*pdel_dt_fac ! aerosol number (1/m2) end if @@ -1206,8 +1207,9 @@ subroutine gasrainscav (ims,ime,kms,kme,jms,jme,its,ite,kts,kte,jts,jte,num_chem real, intent(out) :: dqdt(ims:ime,kms:kme,jms:jme,num_chem) ! TMR tendency array logical, intent(inout) :: dotend(num_chem) ! flag for doing scav real, intent(inout) :: qsrflx(ims:ime,jms:jme,num_chem) - ! process-specific column tracer tendencies - ! (1=all wet removal from this routine) + ! changes to column tracer burdens by wet scavenging over current timestep + ! this routine adds on the contribution from gas scavenging + ! by mass transfer to rain !--------------------------Local Variables------------------------------ @@ -1231,7 +1233,7 @@ subroutine gasrainscav (ims,ime,kms,kme,jms,jme,its,ite,kts,kte,jts,jte,num_chem real :: fracscav(ng), fracscav_sub(ng) real :: deltatinv real :: dum, dumamt, dumprecipmmh, dumpress, dumtemp - real :: pdel_dt_fac + real :: pdel_fac real :: r_gc(ng) real :: scavrate_hno3 real :: scavrate(ng), scavrate_factor(ng) @@ -1363,15 +1365,15 @@ subroutine gasrainscav (ims,ime,kms,kme,jms,jme,its,ite,kts,kte,jts,jte,num_chem ! ! compute tendencies ! - pdel_dt_fac = (pdel(i,k,j)/(g*mwdry))*deltatinv + pdel_fac = (pdel(i,k,j)/(g*mwdry)) do ig = 1, ng - fracscav(ig) = min( fracscav(ig), 1.0 ) + fracscav(ig) = max(0.0,min(1.0,fracscav(ig))) ! make sure 0 <= fracscav <= 1 amtscav(ig) = fracscav(ig)*r_gc(ig) lg = lg_ptr(ig) if (lg .ge. p1st) then dqdt(i,k,j,lg) = -deltatinv*amtscav(ig) - qsrflx(i,j,lg) = qsrflx(i,j,lg) + pdel_dt_fac*amtscav(ig) + qsrflx(i,j,lg) = qsrflx(i,j,lg) - pdel_fac*amtscav(ig) ! mmol/m2 end if end do diff --git a/wrfv2_fire/chem/module_mozcart_wetscav.F b/wrfv2_fire/chem/module_mozcart_wetscav.F index dbbdafc0..b8593f80 100644 --- a/wrfv2_fire/chem/module_mozcart_wetscav.F +++ b/wrfv2_fire/chem/module_mozcart_wetscav.F @@ -12,10 +12,12 @@ MODULE module_mozcart_wetscav save - integer, parameter :: wetscav_tab_cnt = 36 + integer, parameter :: wetscav_tab_cnt = 37 real, parameter :: zero = 0. real, parameter :: one = 1. real, parameter :: four = 4. + real(8), parameter :: oner8 = 1._8 + real(8), parameter :: fourr8 = 4._8 real, parameter :: adj_factor = one + 10.*epsilon( one ) real, parameter :: TICE = 273. real, parameter :: TMIX = 258. @@ -45,7 +47,7 @@ MODULE module_mozcart_wetscav subroutine wetscav_mozcart_init( id, numgas, config_flags ) !---------------------------------------------------------------------- -! Initialize the mozcart, mozcart-xnox wet scavenging module +! Initialize the mozart, mozcart wet scavenging module !---------------------------------------------------------------------- use module_scalar_tables, only : chem_dname_table @@ -76,6 +78,9 @@ subroutine wetscav_mozcart_init( id, numgas, config_flags ) call wrf_error_fatal("mozcart_wetscav_init: failed to allocate wet_scav_tab") endif +!---------------------------------------------------------------------- +! NOTE: this table does NOT include an entry for SO4 +!---------------------------------------------------------------------- wet_scav_tab(1) = wet_scav( 'h2o2', p_h2o2, (/8.33e+04, 7379., 2.2e-12, -3730., 0., 0./), 34.0135994, .false. ) wet_scav_tab(2) = wet_scav( 'hno3', p_hno3, (/0., 0., 2.6e+06, 8700., 0., 0./), 63.0123405, .true. ) wet_scav_tab(3) = wet_scav( 'hcho', p_hcho, (/6.30e+03, 6425., 0., 0., 0., 0./), 30.0251999, .false. ) @@ -112,6 +117,7 @@ subroutine wetscav_mozcart_init( id, numgas, config_flags ) wet_scav_tab(34) = wet_scav( 'xooh', p_xooh, (/90.5, 5607., 0., 0., 0., 0./), 134.126602, .false. ) wet_scav_tab(35) = wet_scav( 'ch3cooh', p_ch3cooh, (/4.1e3, 6300., 0., 0., 0., 0./), 60.0503998, .false. ) wet_scav_tab(36) = wet_scav( 'so2', p_so2, (/8.33e+04, 7379., 2.2e-12, -3730., 0., 0./), 34.0135994, .false. ) + wet_scav_tab(37) = wet_scav( 'h2so4', p_h2so4, (/0., 0., 2.6e+06, 8700., 0., 0./), 98.0784, .false. ) hetcnt = 0 do m = param_first_scalar,numgas @@ -1497,9 +1503,13 @@ subroutine WASHOUT( LPAR, NTRACE, DTSCAV, QTTJFL, QM, & ! Maintain cloud core by reducing NC and AM area going into cloud below !----------------------------------------------------------------------- RCA = (RCXA*FCXA*CLOLDPCT + RCXB*FCXB*CLNEWPCT + RAX*FAX*AMCLPCT)/FCA - DCA = (RCXA*FCXA*CLOLDPCT)/(RCA*FCA)*DCXA + & - (RCXB*FCXB*CLNEWPCT)/(RCA*FCA)*DCXB + & - (RAX*FAX*AMCLPCT)/(RCA*FCA)*DAX + if( RCA > zero ) then + DCA = (RCXA*FCXA*CLOLDPCT)/(RCA*FCA)*DCXA + & + (RCXB*FCXB*CLNEWPCT)/(RCA*FCA)*DCXB + & + (RAX*FAX*AMCLPCT)/(RCA*FCA)*DAX + else + DCA = zero + endif else FCA = zero DCA = zero @@ -1759,30 +1769,45 @@ function DEMPIRICAL( CWATER, RRATE ) !----------------------------------------------------------------------- ! local variables !----------------------------------------------------------------------- - real :: RRATEX, WX, THETA, PHI, ETA, BETA, ALPHA, BEE - real :: GAMTHETA, GAMBETA + real(8), parameter :: big_diameter = 100._8 ! mm + real(8), parameter :: const0 = .638_8 + real(8), parameter :: const1 = oner8 + const0 - real :: DEMPIRICAL + real(8) :: RRATEX, WX, THETA, PHI, ETA, BETA, ALPHA, BEE + real(8) :: GAMTHETA, GAMBETA + real(8) :: numer, denom + real(8) :: diameter ! mm - RRATEX = RRATE*3600. !mm/hr - WX = CWATER*1.0e3 !g/m3 + real :: DEMPIRICAL - if( RRATEX > 0.04 ) then - THETA = exp( -1.43*log10( 7.*RRATEX ) ) + 2.8 + if( cwater > 0._8 ) then + RRATEX = real(RRATE,kind=8)*3600._8 !mm/hr + WX = real(CWATER,kind=8)*1.0e3_8 !g/m3 + + if( RRATEX > 0.04_8 ) then + THETA = exp( -1.43_8*log10( 7._8*RRATEX ) ) + 2.8_8 + else + THETA = 5._8 + endif + + PHI = RRATEX/(3600._8*10._8) !cgs units + ETA = exp( 3.01_8*THETA - 10.5_8 ) + BETA = THETA/const1 + ALPHA = exp( FOURR8*(BETA - 3.5_8) ) + BEE = const0*BETA - ONER8 + GAMTHETA = real( GAMMA( real(THETA,kind=4) ),kind=8 ) + GAMBETA = real( GAMMA( real(BETA + ONER8,kind=4) ),kind=8 ) + + numer = WX*ETA*GAMTHETA + denom = 1.0e6_8*ALPHA*PHI*GAMBETA + diameter = ((numer/denom)**(-oner8/BEE))*10._8 + diameter = min( big_diameter,diameter ) + DEMPIRICAL = real( diameter ) +! DEMPIRICAL = (((WX*ETA*GAMTHETA)/(1.0e6*ALPHA*PHI*GAMBETA))** (-one/BEE))*10. ! in mm (wx/1e6 for cgs) else - THETA = 5. + DEMPIRICAL = 0. endif - PHI = RRATEX/(3600.*10.) !cgs units - ETA = exp( 3.01*THETA - 10.5 ) - BETA = THETA/(one + 0.638) - ALPHA = exp( FOUR*(BETA - 3.5) ) - BEE = (.638*THETA)/(one + .638) - ONE - GAMTHETA = GAMMA( THETA ) - GAMBETA = GAMMA( BETA + ONE ) - - DEMPIRICAL = (((WX*ETA*GAMTHETA)/(1.0e6*ALPHA*PHI*GAMBETA))** (-one/BEE))*10. ! in mm (wx/1e6 for cgs) - end function DEMPIRICAL function GAMMA( X ) diff --git a/wrfv2_fire/chem/module_optical_averaging.F b/wrfv2_fire/chem/module_optical_averaging.F index 81bff9e4..15bb1e58 100644 --- a/wrfv2_fire/chem/module_optical_averaging.F +++ b/wrfv2_fire/chem/module_optical_averaging.F @@ -223,7 +223,8 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & ! CASE (RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & RACM_SOA_VBS_KPP, & - RACM_ESRLSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM, RACMSORG_KPP,& + RACM_ESRLSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & + RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP, & CBMZSORG, CBMZSORG_AQ ) call optical_prep_modal(nbin_o, chem, alt, & ! h2oai, h2oaj, refindx, radius_wet, number_bin, & @@ -249,7 +250,9 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP ) + CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + MOZART_MOSAIC_4BIN_VBS0_KPP,CRI_MOSAIC_8BIN_AQ_KPP, & + CRI_MOSAIC_4BIN_AQ_KPP ) call optical_prep_sectional(nbin_o, chem, alt, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & ! refindx, radius_wet, number_bin, & @@ -387,6 +390,10 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & !!$ endif !!$ 888 format(i3,9e12.5) ! +! Initialize LW vars as not all options compute it + lwtauaer(:,:)=1.e-20 + lwextaer(:,:)=1.e-20 + if (option_mie .eq. 1) then call mieaer(id, iclm, jclm, nbin_o, & ! number_bin_col, radius_wet_col, refindx_col, & @@ -432,11 +439,18 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & ! call peg_message( lunerr, msg ) !jdf !shortwave - tauaersw(iclm,k,jclm,:) = swtauaer(:,k) - extaersw(iclm,k,jclm,:) = swextaer(:,k) - gaersw(iclm,k,jclm,:) = swgaer(:,k) - waersw(iclm,k,jclm,:) = swwaer(:,k) - bscoefsw(iclm,k,jclm,:) = swbscoef(:,k) +! tauaersw(iclm,k,jclm,:) = swtauaer(:,k) +! extaersw(iclm,k,jclm,:) = swextaer(:,k) +! gaersw(iclm,k,jclm,:) = swgaer(:,k) +! waersw(iclm,k,jclm,:) = swwaer(:,k) +! bscoefsw(iclm,k,jclm,:) = swbscoef(:,k) + do ns=1,nspint + tauaersw(iclm,k,jclm,ns) = amax1(swtauaer(ns,k),1.e-20) + extaersw(iclm,k,jclm,ns) = amax1(swextaer(ns,k),1.e-20) + gaersw(iclm,k,jclm,ns) = amax1(amin1(swgaer(ns,k),1.0-1.e-8),1.e-20) + waersw(iclm,k,jclm,ns) = amax1(amin1(swwaer(ns,k),1.0-1.e-8),1.e-20) + bscoefsw(iclm,k,jclm,ns) = amax1(swbscoef(ns,k),1.e-20) + enddo l2aer(iclm,k,jclm,:) = l2(:,k) l3aer(iclm,k,jclm,:) = l3(:,k) l4aer(iclm,k,jclm,:) = l4(:,k) @@ -445,8 +459,13 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & l7aer(iclm,k,jclm,:) = l7(:,k) !longwave - tauaerlw(iclm,k,jclm,1:nlwbands) = lwtauaer(1:nlwbands,k) - extaerlw(iclm,k,jclm,1:nlwbands) = lwextaer(1:nlwbands,k) +! tauaerlw(iclm,k,jclm,1:nlwbands) = lwtauaer(1:nlwbands,k) +! extaerlw(iclm,k,jclm,1:nlwbands) = lwextaer(1:nlwbands,k) + do ns=1,nlwbands + tauaerlw(iclm,k,jclm,ns) = amax1(lwtauaer(ns,k),1.e-20) + extaerlw(iclm,k,jclm,ns) = amax1(lwextaer(ns,k),1.e-20) + enddo + enddo !!$ if(id.eq.1.and.iclm.eq.84.and.jclm.eq.52) then !!$ write(*,889) sizeaer(1,1),sizeaer(2,1),sizeaer(3,1),sizeaer(4,1) @@ -659,6 +678,28 @@ subroutine optical_prep_sectional(nbin_o, chem, alt, & dens_lim1 = 1.0 dens_lim2 = 1.0 dens_h2o = 1.0 + + vol_so4 = 0. + vol_no3 = 0. + vol_cl = 0. + vol_msa = 0. + vol_co3 = 0. + vol_nh4 = 0. + vol_na = 0. + vol_ca = 0. + vol_oin = 0. + vol_oc = 0. + vol_bc = 0. + vol_aro1 = 0. + vol_aro2 = 0. + vol_alk1 = 0. + vol_ole1 = 0. + vol_api1 = 0. + vol_api2 = 0. + vol_lim1 = 0. + vol_lim2 = 0. + vol_h2o = 0. + vol_dust = 0. ! p1st = param_first_scalar ! @@ -1917,7 +1958,7 @@ subroutine optical_prep_mam(nbin_o, chem, alt, & mass_ncl_a3*xmas_sectc(isize) mass_dst = mass_dst_a1*xmas_sectj(isize) + mass_dst_a3*xmas_sectc(isize) mass_soa = mass_soa_a2*xmas_secti(isize) + mass_soa_a1*xmas_sectj(isize) - mass_pom = mass_soa_a1*xmas_sectj(isize) + mass_pom = mass_pom_a1*xmas_sectj(isize) mass_bc = mass_bc_a1*xmas_sectj(isize) vol_so4 = mass_so4 / dens_so4 vol_ncl = mass_ncl / dens_ncl @@ -2462,7 +2503,8 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & mass_bc1j= (1.-FRAC2Aitken)*chem(i,k,j,p_bc1)*conv1a mass_bc2j= (1.-FRAC2Aitken)*chem(i,k,j,p_bc2)*conv1a mass_bcj= mass_bc1j + mass_bc2j - mass_msaj= (1.-FRAC2Aitken)*chem(i,k,j,p_msa)*conv1sulf + if( p_msa .gt. 1) mass_msaj= (1.-FRAC2Aitken)*chem(i,k,j,p_msa)*conv1sulf + ! Aitken mode... ! SAM 7/18/09 - Put fraction of GOCART sulfate, organic, black carbon masses into modal Aitken mode @@ -2474,7 +2516,7 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & mass_bc1i= FRAC2Aitken*chem(i,k,j,p_bc1)*conv1a mass_bc2i= FRAC2Aitken*chem(i,k,j,p_bc2)*conv1a mass_bci= mass_bc1i + mass_bc2i - mass_msai= FRAC2Aitken*chem(i,k,j,p_msa)*conv1sulf + if( p_msa .gt. 1) mass_msai= FRAC2Aitken*chem(i,k,j,p_msa)*conv1sulf ! ! Now divide mass into sections which is done by sect02: @@ -2512,6 +2554,9 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & mass_nh4 = mass_nh4i*xmas_secti(isize) + mass_nh4j*xmas_sectj(isize) mass_oin = mass_oini*xmas_secti(isize) + mass_oinj*xmas_sectj(isize) + & mass_soil*xmas_sectc(isize) + mass_antha*xmas_sectc(isize) + if( p_msa .gt. 1) then + mass_msa = mass_msai*xmas_secti(isize) + mass_msaj*xmas_sectj(isize) + endif ! GOCART OC mass_aero1 is hydrophobic, mass_aero2 is hydrophylic mass_aro1 = mass_aro1j*xmas_sectj(isize) + mass_aro1i*xmas_secti(isize) mass_aro2 = mass_aro2j*xmas_sectj(isize) + mass_aro2i*xmas_secti(isize) @@ -2548,6 +2593,7 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & vol_na = mass_na / dens_na vol_cl = mass_cl / dens_cl vol_soil = mass_soil / dens_dust + vol_msa = mass_msa / dens_msa ! vol_h2o = mass_h2o / dens_h2o ! 7/23/09 SAM calculate vol_h2o from kappas in Petters and Kreidenweis ACP, 2007, vol. 7, 1961-1971. ! Their kappas are the hygroscopicities used in Abdul-Razzak and Ghan, 2004, JGR, V105, p. 6837-6844. diff --git a/wrfv2_fire/chem/module_phot_fastj.F b/wrfv2_fire/chem/module_phot_fastj.F index a1291c93..b089c900 100644 --- a/wrfv2_fire/chem/module_phot_fastj.F +++ b/wrfv2_fire/chem/module_phot_fastj.F @@ -89,11 +89,11 @@ subroutine fastj_driver(id,curr_secs,dtstep,config_flags, & USE module_configure USE module_state_description USE module_data_mosaic_therm, only: nbin_a, nbin_a_maxd - USE module_data_mosaic_asect - USE module_data_mosaic_other +! USE module_data_mosaic_asect + USE module_data_mosaic_other, only: kmaxd, nsubareas USE module_fastj_mie ! USE module_mosaic_therm, only: aerosol_optical_properties - USE module_mosaic_driver, only: mapaer_tofrom_host +! USE module_mosaic_driver, only: mapaer_tofrom_host USE module_fastj_data, only: nb, nc implicit none @@ -237,7 +237,8 @@ subroutine fastj_driver(id,curr_secs,dtstep,config_flags, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - MOZART_MOSAIC_4BIN_VBS0_KPP ) + MOZART_MOSAIC_4BIN_VBS0_KPP, CRI_MOSAIC_8BIN_AQ_KPP, & + CRI_MOSAIC_4BIN_AQ_KPP ) processingAerosols = .true. case default processingAerosols = .false. diff --git a/wrfv2_fire/chem/module_qf03.F b/wrfv2_fire/chem/module_qf03.F new file mode 100644 index 00000000..e4d14c98 --- /dev/null +++ b/wrfv2_fire/chem/module_qf03.F @@ -0,0 +1,573 @@ +MODULE qf03 +! +! Y. Shao, 29 Jan 2004 +! +! JY Kang, 01 Dec 2008 +! Modify the code for WRF_chem +! +! M. Klose, 2010-2013 Modifications +!----------------------------------------------------------------------------------- +! Calculate sediment flux for multi-particle size soils as a weighted average of Q(d) +! dust emission F(d) for covered and moisture soil +! +! Options for dust calculation: +! 1 Shao (2001) +! 2 Shao (2004) +! 3 Shao (2011): simplification of 2; added on 26 Sep 2009 +! +!-------------------------------------------------------------------------------------- +! +! input: +! n: number of particle size ranges. +! dm: median diameter of each particle size. [m] +! m_fract: Weight fraction of each particle range. Sum m_fract = 1 +! ustar: Friciton velocity. [m/s] +! cf: fraction area covered by roughness elements +! w: surface soil moisture contains [m^3/m^3] +! c: Owen's coefficient +! +! output: +! ustart: Mean threshold velocity of each particle range. +! q: Sand flux from each size range. +! ffq: Weighted sand flux from each size range. +! qtotal: Total sand flux (weighted average). +! f: Weighted dust flux ejected by single sand size range for given d_d. +! fff: Weighted dust flux ejected by all sand size range from each dust size range. +! ftotal: Total dust flux (weighted average). +!-------------------------------------------------------------------------------------- +! + + CONTAINS + + subroutine qf03_driver ( nmx, idst, g, rho, dt, & + ustar, w, cf_in, ust_min, imod, dz_lowest, & + soilc, tot_soilc, domsoilc, & + tc, bems, rough_cor_in, smois_cor_in, wr, & + d0, dd, psd_m, dpsd_m, ppsd_m, psd_f, dpsd_f, ppsd_f, imax, stype) + + INTEGER, INTENT(IN ) :: nmx, imod, idst + REAL, INTENT(IN ) :: g, dt, rho, dz_lowest, ustar + REAL(8), INTENT(IN ) :: w, cf_in + REAL(8), INTENT(OUT ) :: ust_min, rough_cor_in, smois_cor_in + REAL , INTENT(INOUT), DIMENSION(nmx) :: tc, bems + REAL , INTENT(IN), DIMENSION(12) :: wr + +!kang [2009/01/07] soil class type + REAL, INTENT(IN ) :: tot_soilc + REAL, DIMENSION(16), INTENT(IN) :: soilc + INTEGER, INTENT(IN ) :: domsoilc + + integer :: imax, stype + real(8), dimension(0:imax), intent(in) :: d0 + real(8), dimension(imax), intent(in) :: dd + real(8), dimension(imax,stype), intent(in) :: psd_m, dpsd_m, ppsd_m + real(8), dimension(imax,stype), intent(in) :: psd_f, dpsd_f, ppsd_f + +!local variables +! particle-size distributions + real(8), dimension(imax) :: psdm, dpsdm, ppsdm ! minimally dispersed + real(8), dimension(imax) :: psdf, dpsdf, ppsdf ! fully dispersed + real(8), dimension(imax) :: psds, dpsds, ppsds ! sediment + character(4) :: s_type + + + real(8) :: smois_correc + integer :: i, j, n, kk, ij, index + real(8) :: total, qtotal, ftotal, cf + real(8) :: ftotalb, ftotalp +! + real(8), parameter :: calpha = 5.d0, cbeta = 1.37d0 +! +! + real(8), dimension(imax) :: beta_d, beta_s ! beta1 and beta2 used by Shao et al. (1996) dust emission + real(8), dimension(imax) :: ustart, q, ffq, fff + real(8), dimension(imax,imax) :: f +! + real(8), dimension(imax,imax) :: fb + real(8), dimension(imax,imax) :: fp + real(8), dimension(imax) :: fffb, fffp +! + real(8), parameter :: c_lambda=0.35 + real(8) :: h, lambda + real(8) :: ghl, fc + real(8) :: phl + real(8) :: cys, u0, al0, sx, ppr, rhos, smass, omega, rys + real(8) :: ddm, a1, a2, a3, a3b, a3p + real(8) :: zeta, sigma_m ! u*sqrt(rhos/p), bombardment coefficient +! + real(8) :: ustart0_out, qwhite_out, f_mb_out, f_hlys_out, pmass_out, vhlys_out + + real :: xx1,xx2,xx3,xx4 + + character*2 mod + character*6 ss_type + character*80 infile + character*80 surf_file + integer :: nmax + + integer, parameter :: nbins=4 + integer, parameter :: nkk=50 + real(8) :: sigma + real, dimension(nbins) :: dbin, fbin, cell_fbin + integer, dimension(nbins) :: ibin + data dbin/2.5,5.,10.,20./ !size cut diameter (um) + real(8) :: rhop + real :: cell_ftotal + integer :: isl, cc +!******************************************************************************************* +! +! initialization + cell_ftotal = 0. + do n = 1, nbins + cell_fbin(n) = 0. + enddo +! + DO cc = 1, 12 ! soil category + if (soilc(cc).eq.0.) then + go to 103 + endif + if (cc.eq.1.or.cc.eq.2) then + s_type = 'sand' + psdm(:)=psd_m(:,1) + psdf(:)=psd_f(:,1) + dpsdm(:)=dpsd_m(:,1) + dpsdf(:)=dpsd_f(:,1) + ppsdm(:)=ppsd_m(:,1) + ppsdf(:)=ppsd_f(:,1) + elseif (cc.eq.3.or.cc.eq.4..or.cc.eq.6.or.cc.eq.8.or.cc.eq.9) then + s_type = 'loam' + psdm(:)=psd_m(:,3) + psdf(:)=psd_f(:,3) + dpsdm(:)=dpsd_m(:,3) + dpsdf(:)=dpsd_f(:,3) + ppsdm(:)=ppsd_m(:,3) + ppsdf(:)=ppsd_f(:,3) + elseif (cc.eq.7) then + s_type = 'sloa' + psdm(:)=psd_m(:,2) + psdf(:)=psd_f(:,2) + dpsdm(:)=dpsd_m(:,2) + dpsdf(:)=dpsd_f(:,2) + ppsdm(:)=ppsd_m(:,2) + ppsdf(:)=ppsd_f(:,2) + elseif (cc.eq.5.or.cc.eq.10.or.cc.eq.11.or.cc.eq.12) then + s_type = 'clay' + psdm(:)=psd_m(:,4) + psdf(:)=psd_f(:,4) + dpsdm(:)=dpsd_m(:,4) + dpsdf(:)=dpsd_f(:,4) + ppsdm(:)=ppsd_m(:,4) + ppsdf(:)=ppsd_f(:,4) + else + go to 103 + endif +! +! + rhop = 2560.d0 ! particle density [kg/m3] + rhos = 1000.d0 ! bulk density of soil [kg/m3] ??? + phl = 30000. ! plastic pressure [N/m2] + cys = 0.00001 ! cys : parameter + + sigma = rhop/rho ! particle-air density ratio + cf = cf_in/100. ! vegetation cover + +! +!------------------- +! frontal area index +!------------------- + lambda = - c_lambda*dlog( 1.d0 - cf ) + call r_c(lambda, rough_cor_in) + +! Matching WRF_soil class with Shao's class for moisture correction of Fecan (cc:WRF_soil class, isl:Shao's class) +! cc +! 1:sand, 2:loamy sand, 3:sandy loam, 4:silt loam, 5:silt, 6:loam, 7:sandy clay loam, +! 8:silty clay loam, 9:clay loam, 10:sandy clay, 11:silty clay, 12:clay +! isl +! 1:sand, 2:loamy sand, 3:sandy loam, 4:loam, 5:silt loam, 6: silt, 7:sandy clay loam, +! 8:clay loam, 9:silty clay loam, 10:sandy clay, 11:silty clay, 12:clay + if (cc.eq.1.or.cc.eq.2.or.cc.eq.3.or.cc.eq.7.or.cc.eq.10.or. & + & cc.eq.11.or.cc.eq.12) then + isl = cc + elseif (cc.eq.4) then + isl = 5 + elseif (cc.eq.5) then + isl = 6 + elseif (cc.eq.6) then + isl = 4 + elseif (cc.eq.8) then + isl = 9 + elseif (cc.eq.9) then + isl = 8 + endif + + call h_c(w, wr(cc), isl, smois_correc) +!---------------------------------------------- +! for each particle size group, estimate ustart +!---------------------------------------------- +! + ust_min = 999.0 + do i = 1, imax + call ustart0(dd(i), sigma, g, rho, ustart0_out) + ustart(i) = ustart0_out + ustart(i) = rough_cor_in*smois_correc*ustart(i) + ust_min = dmin1(ust_min, ustart(i)) + call qwhite(ustart(i), ustar, rho, g, qwhite_out) + q(i) = qwhite_out + q(i) = (1.d0-cf)*q(i) + enddo + if (cc.eq.domsoilc) then + smois_cor_in = smois_correc + endif +! +! + IF ( ustar .le. ust_min ) THEN ! no erosion goto 102 + q = 0.d0 + ffq = 0.d0 + qtotal = 0.d0 + fff = 0.d0 + ftotal = 0.d0 + fbin = 0.d0 + goto 102 + ELSE + ghl = dexp( -(ustar - ust_min)**3.d0 ) + dpsds = ghl*dpsdm + (1.-ghl)*dpsdf + psds = ghl*psdm + (1.-ghl)*psdf + ppsds = ghl*ppsdm + (1.-ghl)*ppsdf +! + ffq = q*dpsds + qtotal = sum(ffq) + +!-------------- +! dust emission +!-------------- +! +! size bin + do n=1,nbins + ibin(n)=0 + do i=imax,1,-1 + if(d0(i).ge.dbin(n)) ibin(n)=i + enddo + if(ibin(n).eq.0) stop 'wrong dust classes' + enddo +! +! +! +!-------------------------------- +! Shao (2001) dust emission model +!-------------------------------- + IF (imod .eq. 1) THEN + do i = idst+1, imax + ddm = dd(i)*1.d-6 + call pmass(rhop, ddm, pmass_out) ! mass of saltating particles + smass = pmass_out + u0 = 10*ustar + al0 = 13.d0*3.14159d0/180.d0 + call vhlys(phl, 2, smass, al0, u0, ddm, vhlys_out) + omega = vhlys_out ![m3] +! + do j = 1, idst + rys = psdm(j)/psdf(j) + a1 = cys*( (1.-ghl) + ghl*rys ) + a2 = ffq(i)*g/ustar**2/smass + + if ( dpsdf(j) .lt. dpsdm(j) ) then + a3 = dpsdf(j)*rhos*omega + else + a3 = dpsdf(j)*rhos*omega + (dpsdf(j)-dpsdm(j))*smass + endif + f(i,j) = a1*a2*a3 ![kg/m2/s] + enddo + enddo +! + ftotal = 0.0 + do j = 1, idst + fff(j) = 0. + do i = idst+1, imax + fff(j) = fff(j) + f(i,j) + enddo + fff(j) = (1-cf)*fff(j) + ftotal = ftotal + fff(j) + enddo +! + do n=1,nbins + j0=1 + if(n.gt.1) j0=ibin(n-1)+1 + fbin(n)=0 + do j=j0,ibin(n) + fbin(n)=fbin(n)+fff(j) + enddo + enddo +! +!-------------------------------- +! Shao (2004) dust emission model +!-------------------------------- + ELSEIF (imod .eq. 2) THEN + zeta = ustar*dsqrt( rhos/phl ) + sigma_m = 12.d0*zeta*zeta*(1.d0+14.d0*zeta) +! + do i = idst+1, imax + do j = 1, idst + rys = psdm(j)/psdf(j) + a1 = cys*dpsdf(j)*( (1.-ghl) + ghl*rys ) + a2 = (1.+sigma_m) + a3 = ffq(i)*g/ustar**2 + f(i,j) = a1*a2*a3 + enddo + enddo +! + ftotal = 0.0 + do j = 1, idst + fff(j) = 0. + do i = idst+1, imax + fff(j) = fff(j) + f(i,j) + enddo + fff(j) = (1-cf)*fff(j) + ftotal = ftotal + fff(j) + enddo +! + do n=1,nbins + j0=1 + if(n.gt.1) j0=ibin(n-1)+1 + fbin(n)=0 + do j=j0,ibin(n) + fbin(n)=fbin(n)+fff(j) + enddo + enddo +! +! +!-------------------------------------------------------------------------- +! Shao (2011) minimal version, ghl = 1, Q independent of sand particle size +! +! See Eq. (34) in +! Shao, Y., M. Ishizuka, M. Mikami, J. Leys (2011): Parameterization of size- +! resolved dust emission and validation with measurements, JGR, 116, D08203, +! doi: 10.1029/2010JD014527 +!-------------------------------------------------------------------------- + ELSEIF (imod .eq. 3) THEN + zeta = ustar*dsqrt( rhos/phl ) + sigma_m = 12.d0*zeta*zeta*(1.d0+14.d0*zeta) +! + ftotal = 0.0 +! + do j = 1, idst + a1 = cys*dpsdm(j) + a2 = (1.+sigma_m) + a3 = qtotal*g/ustar**2 + fff(j) = a1*a2*a3 + fff(j) = (1-cf)*fff(j) + ftotal = ftotal + fff(j) + enddo +! + do n=1,nbins + j0=1 + if(n.gt.1) j0=ibin(n-1)+1 + fbin(n)=0 + do j=j0,ibin(n) + fbin(n)=fbin(n)+fff(j) + enddo + enddo +! + ENDIF ! dust scheme + ENDIF ! ust < ust_t +! +! +! +102 continue + + do n = 1, nbins + cell_fbin(n) = cell_fbin(n) + (soilc(cc)/tot_soilc)*fbin(n) + enddo + cell_ftotal = cell_ftotal + ftotal*soilc(cc)/tot_soilc + +103 continue + + ENDDO ! cc, soil category + + + do n = 1, nbins +! fbin : [kg/m2/s], dz_lowest : [m], rho : [kg/m3], dt : [s] -> tc : [kg/kg-dryair] + tc(n) = tc(n) + cell_fbin(n)/dz_lowest/rho*dt ![kg/kg-dryair] + bems(n) = cell_fbin(n) ![kg/m2/s] + enddo + tc(5) = tc(5) + cell_ftotal/dz_lowest/rho*dt ![kg/kg-dryair] + bems(5) = cell_ftotal ![kg/m2/s] + + END subroutine qf03_driver + + +!***************************************************************************** + subroutine ustart0(dum, sigma, g, rho, ustart0_out) +! +! Y. Shao, 13 June 2000 +! +! Calculate ustar0(d) using Shao and Lu (2000) for uncovered +! dry surface +! +! dum: particle diameter [um] +! ustar0: threshold friction velocity [m/s] +! + real, intent(in) :: g, rho + real(8), intent(in) :: dum, sigma + real(8), intent(out) :: ustart0_out + real(8) :: dm + real(8), parameter :: gamma = 1.65d-4 ! a constant + real(8), parameter :: f = 0.0123 + + dm = dum*1d-6 + + ustart0_out = f*(sigma*g*dm + gamma/(rho*dm) ) + ustart0_out = dsqrt( ustart0_out ) +! end function + end subroutine ustart0 +!***************************************************************************** + subroutine qwhite(ust, ustar, rho, g, qwhite_out) +! +! Yaping Shao 17-07-99! +! +! White (1979) Sand Flux Equation +! Q = c*rho*u_*^3 over g (1 - u_*t over u_*)(1 + u_*t^2/u_*^2) +! qwhite: Streamwise Sand Flux; [kg m-1 s-1] +! c : 2.6 +! ust : threhold friction velocity [m/s] +! ustar : friction velocity [m/s] +! + real(8) :: c + real, intent(in) :: ustar, rho, g + real(8), intent(in) :: ust + real(8), intent(out) :: qwhite_out + real(8) :: a, b + c = 0.5d0 + a = rho/g +! IF (ustar.lt.ust) THEN +! qwhite = 0.d0 +! ELSE +! b = ust/ustar +! qwhite = c*a*ustar**3.*(1.-b)*(1.+b*b) +! ENDIF + IF (ustar.lt.ust) THEN + qwhite_out = 0.d0 + ELSE + b = ust/ustar + qwhite_out = c*a*ustar**3.*(1.-b)*(1.+b*b) + ENDIF + + END subroutine qwhite +!***************************************************************************** + subroutine vhlys(p, k, xm, alpha, u, d, vhlys_out) +! +! Volume removal according to Lu and Shao (1999), Equation (8) +! alpha: impact angle [^o] +! u : impact velocity [m/s] +! p : plastic pressure [N/m^2] +! xm : particle mass [kg] +! d : particle diameter [m] +! +! + REAL(8),intent(in) :: alpha, xm, u, d, p + REAL(8) :: beta + REAL(8), PARAMETER :: pi=3.1415927d0 + REAL(8) :: t1, t2, t3 + INTEGER,intent(in) :: k + real(8),intent(out) :: vhlys_out + + beta = dsqrt( p*k*d/xm ) + t1 = u*u/(beta*beta)*( dsin(2.d0*alpha) - 4.d0*dsin(alpha)*dsin(alpha) ) + t2 = u*dsin(alpha)/beta + t3 = 7.5d0*pi*t2**3.d0/d + vhlys_out = d*( t1 + t3 ) + + END subroutine vhlys +!***************************************************************************** +! A routine for correction of ust for soil moisture content +! +! w : volumetric soil moisture +! isl: soil texture type, ranging from 1 to 12 +! +! Author: Yaping Shao, 5/05/2001 +! Reference: Fecan et al. (1999), Ann. Geophysicae,17,149-157 +! +! Data based on Shao and Jung, 2000, unpublished manuscript +! Data invented for sand, loamy sand, sandy loam, loam, clay loam, and clay +! isl=1, 2, 3, 4, 8, 12 +!---------------------------------------------------------------------- + subroutine h_c (w, wr, isl, h) + + real(8) :: a(12), b(12) + real(8), intent(in) :: w + real(8), intent(out) :: h + real, intent(in) :: wr + integer, intent(in) :: isl + character*100 :: msg ! error message string + +! NOTE: There might be an inconsistency between soil moisture parameters used in this module and +! the ones used in the WRF land-surface model. For Noah, RUC, and Noah MP LSM, the inconsistency has +! been checked and the values provided in SOILPARM.TBL are used for consistency purpose. For all +! other LSM options, the parameters obtained from Shao are used and the inconsistency might still +! occur. This might lead to unrealistic fluxes. + + data a /21.19, 33.03, 44.87, 17.79, 20.81, 23.83, 26.84, 29.86, 27.51, 25.17, 22.82, 20.47/ + data b / 0.68, 0.71, 0.85, 0.61, 0.66, 0.71, 0.75, 0.80, 0.75, 0.70, 0.64, 0.59/ + + if ( w.lt.0. ) then + write(msg, *) 'soil moisture correction (h_c): w = ', w, ' < 0' + call wrf_error_fatal(msg) +! stop + endif + + if ( w.le.wr ) then + h = 1.0 + else + h = sqrt( 1 + a(isl)*( w-wr )**b(isl) ) + endif + + END subroutine h_c + +!***************************************************************************** + subroutine pmass(rhop, d, pmass_out) +! +! Particle Mass +! rhop: particle density [kg m^-3] +! d : particle size [m] +! + REAL(8), PARAMETER :: pi=3.1415927d0 + REAL(8),intent(in) :: rhop, d + real(8),intent(out) :: pmass_out + + pmass_out = (pi*rhop*d**3.d0)/6.d0 + + END subroutine pmass + +!***************************************************************************** + subroutine r_c (x,r) +! +! Y. Shao 17-07-92 +! CORRECTION FUNCTION FOR UST(D) BASED ON Raupach et al. (1992) +! x = frontal area index +! +! R_C = (1 - sig m x)^{1/2} (1 + m beta x)^{1/2} +! Note I deife R_C = u_{*tR}/u_{*tS} +! While Raupach et al. defined +! R_C = u_{*tS}/u_{*tR} and their R function is +! R_C = (1 - sig m x)^{-1/2} (1 + m beta x)^{-1/2} +! +! sig : basal to frontal area; about 1 +! m : parameter less than 1; about 0.5 +! beta : a ratio of drag coef.; about 90. +! + real(8) :: xc + real(8), intent(in) :: x + real(8), intent(out) :: r + real(8), parameter :: sig=1., m=0.5, beta=90. +! + xc = 1./(sig*m) + IF (x.ge.xc) THEN + r = 999. ! Full covered surface + ELSE + r = dsqrt(1.-sig*m*x)*dsqrt(1.+m*beta*x) + ENDIF +! + END subroutine r_c + + + +END MODULE qf03 diff --git a/wrfv2_fire/chem/module_soilpsd.F b/wrfv2_fire/chem/module_soilpsd.F new file mode 100644 index 00000000..d3e1bed5 --- /dev/null +++ b/wrfv2_fire/chem/module_soilpsd.F @@ -0,0 +1,64 @@ +MODULE module_soilpsd + integer, parameter :: mmax=4 + + real(8), dimension(3, mmax) :: csandm ! Coefs for sand minimally dispersed + data csandm /0., 0., 0., & + & 0.0329, 4.3733, 0.8590, & + & 0.9671, 5.7689, 0.2526, & + & 0., 0., 0. / +! + real(8), dimension(3, mmax) :: cloamm ! Coefs for loam minimally dispersed + data cloamm /0.1114, 4.3565, 0.4257, & + & 0.4554, 5.1674, 0.3824, & + & 0.4331, 5.4092, 1.0000, & + & 0., 0., 0. / +! + real(8), dimension(3, mmax) :: csloam ! Coefs for sandy clay loam minimally dispersed, very dusty + data csloam /0.0722, 2.2675, 1.0000, & + & 0.6266, 4.9654, 0.3496, & + & 0.3012, 5.5819, 0.5893, & + & 0., 0., 0. / +! + real(8), dimension(3, mmax) :: cclaym ! Coefs for clay minimally dispersed + data cclaym /0.3902, 3.5542, 1.0000, & + & 0.2813, 4.2239, 0.2507, & + & 0.3286, 5.1638, 0.4632, & + & 0., 0., 0. / +! + real(8), dimension(3, mmax) :: csandf ! Coefs for sand fully dispersed + data csandf /0., 0., 0., & + & 0.0338, 0.6931, 1.0000, & + & 0.9662, 5.6300, 0.2542, & + & 0., 0., 0. / +! + real(8), dimension(3, mmax) :: cloamf ! Coefs for loam fully dispersed + data cloamf /0.5844, 4.6079, 0.6141, & + & 0.3304, 5.2050, 0.2897, & + & 0.0522, 7.0553, 1.0000, & + & 0.0330, 0.6931, 1.0000 / +! + real(8), dimension(3, mmax) :: csloaf ! Coefs for sandy clay loam fully dispersed + data csloaf /0.2344, 1.8079, 0.6141, & + & 0.3634, 4.2050, 0.2897, & + & 0.4022, 5.6553, 1.0000, & + & 0., 0., 0. / +! + real(8), dimension(3, mmax) :: cclayf ! Coefs for clay fully dispersed + data cclayf /0.0872, 0.6931, 1.0000, & + & 0.4464, 3.9323, 0.9181, & + & 0.4665, 5.4486, 0.3916, & + & 0., 0., 0. / +! + real(8), dimension(3, mmax) :: cjadef ! Coefs for fully dispersed, JADE site, loam sand + data cjadef /0.228, 5.42, 0.350, & + & 0.277, 4.86, 0.595, & + & 0.295, 3.08, 1.050, & + & 0.200, 1.30, 1.400 / +! + real(8), dimension(3, mmax) :: cjadem ! Coefs for minimally dispersed, JADE site, loam sand + data cjadem /0.35, 5.40, 0.345, & + & 0.32, 4.63, 0.490, & + & 0.23, 4.10, 0.650, & + & 0.10, 2.75, 0.950 / +! +END MODULE module_soilpsd diff --git a/wrfv2_fire/chem/module_sorgam_aqchem.F b/wrfv2_fire/chem/module_sorgam_aqchem.F index f0bb7ff4..1c9e0d4d 100644 --- a/wrfv2_fire/chem/module_sorgam_aqchem.F +++ b/wrfv2_fire/chem/module_sorgam_aqchem.F @@ -259,7 +259,7 @@ subroutine sorgam_aqchem_driver( & return endif - write(*,'(a,8(1x,i6))') 'entering module_sorgam_aqchem - ktau =', ktau +! write(*,'(a,8(1x,i6))') 'entering module_sorgam_aqchem - ktau =', ktau ! We set the precipitation rate and aerosol scavenging rates to zero, ! in order to prevent wet scavenging in AQCHEM (it is treated elswhere): diff --git a/wrfv2_fire/chem/module_uoc_dust.F b/wrfv2_fire/chem/module_uoc_dust.F new file mode 100644 index 00000000..bfa4ac65 --- /dev/null +++ b/wrfv2_fire/chem/module_uoc_dust.F @@ -0,0 +1,333 @@ +MODULE uoc_dust +!---------------------------------------------------------------------------- +! Dust emission module developed at the University of Cologne, Germany. +! Dust emission schemes and framework developed by Y Shao (yshao@uni-koeln.de) +! Implementation into WRF and modifications by JY Kang (jy.kang@kiaps.org), +! M Klose (mklose@uni-koeln.de), and CL Wu (wuchenglai@mail.iap.ac.cn). +! +! For references and available schemes, see module_qf03.F +! Martina Klose, 29 May 2013 +!---------------------------------------------------------------------------- + USE module_data_gocart_dust + USE qf03 + USE module_soilpsd + USE module_sf_noahlsm, ONLY:DRYSMC + USE module_sf_noahmplsm, ONLY: DRYSMC_nmp => DRYSMC + USE module_sf_ruclsm, ONLY:DRYSMC_ruc => DRYSMC + + CONTAINS + subroutine uoc_dust_driver(ktau,dt,config_flags, & + chem,rho_phy,dz8w,smois,ust, & + isltyp,vegfra,g,emis_dust, & + ust_t_min, imod, rough_cor, smois_cor, & + soil_top_cat, erod, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + USE module_configure + USE module_state_description + USE module_model_constants, ONLY: mwdry + IMPLICIT NONE + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: ktau, imod, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: isltyp + REAL, DIMENSION(ims:ime,1:config_flags%num_soil_cat,jms:jme) , & + INTENT(IN ) :: soil_top_cat + REAL, DIMENSION( ims:ime , jms:jme, 3 ) , & + INTENT(IN ) :: erod + +! ust_t_min is calculated value from qf03 + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: ust_t_min, & + rough_cor, & + smois_cor + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL, & + INTENT(INOUT ) :: emis_dust + REAL, DIMENSION( ims:ime, config_flags%num_soil_layers, jms:jme ) , & + INTENT(INOUT) :: smois + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: ust, & + vegfra + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: dz8w, & + rho_phy + + REAL, INTENT(IN ) :: dt,g +! +! local variables +! + integer, parameter :: imax=100 ! No. of particle size intervals for psd + integer, parameter :: jmax=4 ! No. of log-normal distributions for constructing psd + integer, parameter :: stype=4 ! No. of soil texture classes + real(8), dimension(0:imax) :: d0 + real(8), dimension(imax) :: dd + real(8), dimension(imax) :: psdm, dpsdm, ppsdm + real(8), dimension(imax) :: psdf, dpsdf, ppsdf + real(8), dimension(imax,stype) :: psd_m, dpsd_m, ppsd_m + real(8), dimension(imax,stype) :: psd_f, dpsd_f, ppsd_f + real(8), parameter :: dcut=20.d0 ! dust cutoff particle size + + integer :: nmx,i,j,k,p,idst + real :: ust_grid, airden, dz_lowest + real, DIMENSION (5) :: tc,bems + real*8 :: gwet, cf + real*8 conver,converi + real*8 ust_min, rough_cor_in, smois_cor_in + real, dimension(16) :: soilc + real tot_soilc + integer domsoilc + integer cc + character*1 :: tmp + real, dimension(12) :: thr + data thr/0.001, 0.003, 0.037, 0.061, 0.072, 0.049, 0.084, 0.110, 0.095, 0.126, 0.141, 0.156/ +! Shao's air-dry soil moisture [m3/m3] in WRF order + +!*************************************************************************** +! initialization + + conver=1.e-9 + converi=1.e9 + + nmx=5 !size bin + k=kts !in the bottom layer + +! calculate soil-psd once for all 4 types +! initialize + psd_m(:,:) = 0. + psd_f(:,:) = 0. + dpsd_m(:,:) = 0. + dpsd_f(:,:) = 0. + ppsd_m(:,:) = 0. + ppsd_f(:,:) = 0. + + do p = 1, 4 + if (p.eq.1) then ! sand + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csandm, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csandf, jmax) + psd_m(:,1) = psdm(:) + psd_f(:,1) = psdf(:) + dpsd_m(:,1) = dpsdm(:) + dpsd_f(:,1) = dpsdf(:) + ppsd_m(:,1) = ppsdm(:) + ppsd_f(:,1) = ppsdf(:) + elseif (p.eq.2) then ! sandy clay loam + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csloam, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csloaf, jmax) + psd_m(:,2) = psdm(:) + psd_f(:,2) = psdf(:) + dpsd_m(:,2) = dpsdm(:) + dpsd_f(:,2) = dpsdf(:) + ppsd_m(:,2) = ppsdm(:) + ppsd_f(:,2) = ppsdf(:) + elseif (p.eq.3) then ! loam + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, cloamm, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, cloamf, jmax) + psd_m(:,3) = psdm(:) + psd_f(:,3) = psdf(:) + dpsd_m(:,3) = dpsdm(:) + dpsd_f(:,3) = dpsdf(:) + ppsd_m(:,3) = ppsdm(:) + ppsd_f(:,3) = ppsdf(:) + else ! clay + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, cclaym, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, cclayf, jmax) + psd_m(:,4) = psdm(:) + psd_f(:,4) = psdf(:) + dpsd_m(:,4) = dpsdm(:) + dpsd_f(:,4) = dpsdf(:) + ppsd_m(:,4) = ppsdm(:) + ppsd_f(:,4) = ppsdf(:) + endif + enddo +! +! Before calculating dust emission, some parameters should be set. + j = 0 +1 j = j+1 + if ( dd(j) .le. dcut ) then + idst = j + goto 1 + endif +! + do j=jts,jte + do i=its,ite + +! do dust over dust source area only + if (sum(erod(i,j,:)).gt.0.) then !use fraction of erodible surface area as dust source indicator + tc(1)=chem(i,kts,j,p_dust_1)*conver ![kg/kg-dryair] + tc(2)=chem(i,kts,j,p_dust_2)*conver + tc(3)=chem(i,kts,j,p_dust_3)*conver + tc(4)=chem(i,kts,j,p_dust_4)*conver + tc(5)=chem(i,kts,j,p_dust_5)*conver + + ust_grid=ust(i,j) ! u* for one grid + +! delta z for the lowest layer is needed for unit conversion + dz_lowest = dz8w(i,1,j) + +! for soil moisture using volumetric soil moisture (smois) + gwet=smois(i,1,j) + airden=rho_phy(i,kts,j) ![kg/m3] + cf=vegfra(i,j) ! in [%] + +! initialization + tot_soilc=0. + do cc = 1, 12 + soilc(cc) = 0. + enddo + +! print*, texture(i,j) + do cc = 1, 12 + soilc(cc) = soil_top_cat(i,cc,j) + tot_soilc = tot_soilc + soilc(cc) + enddo + +! domsoilc = texture(i,j) + domsoilc = isltyp(i,j) + if ( config_flags%sf_surface_physics .eq. 3 ) then + DRYSMC = DRYSMC_ruc ! RUC + elseif ( config_flags%sf_surface_physics .eq. 4 ) then + DRYSMC = DRYSMC_nmp ! Noah MP + elseif ( config_flags%sf_surface_physics .eq. 1 .or. & + & config_flags%sf_surface_physics .eq. 5 .or. & + & config_flags%sf_surface_physics .eq. 7 .or. & + & config_flags%sf_surface_physics .eq. 8 .or. & + & config_flags%sf_surface_physics .eq. 0) then + DRYSMC(1:12) = thr + CALL wrf_message('UoC dust: DRYSMC reset for dust emission') + endif +!------------------------------------------------------------------------ + + call qf03_driver( nmx, idst, g, airden, dt, & + ust_grid, gwet, cf, ust_min, imod, dz_lowest, & + soilc, tot_soilc, domsoilc, & + tc, bems, rough_cor_in, smois_cor_in, DRYSMC(1:12), & + d0, dd, psd_m, dpsd_m, ppsd_m, psd_f, dpsd_f, ppsd_f, imax, stype) + + chem(i,kts,j,p_dust_1)=tc(1)*converi ![ug/kg-dryair] + chem(i,kts,j,p_dust_2)=tc(2)*converi + chem(i,kts,j,p_dust_3)=tc(3)*converi + chem(i,kts,j,p_dust_4)=tc(4)*converi + chem(i,kts,j,p_dust_5)=tc(5)*converi +! for output diagnostics + emis_dust(i,1,j,p_edust1)=bems(1)*converi + emis_dust(i,1,j,p_edust2)=bems(2)*converi + emis_dust(i,1,j,p_edust3)=bems(3)*converi + emis_dust(i,1,j,p_edust4)=bems(4)*converi + emis_dust(i,1,j,p_edust5)=bems(5)*converi ![kg/m2/s] -> [ug/m2/s] + else ! no dust source + emis_dust(i,1,j,p_edust1)=0. + emis_dust(i,1,j,p_edust2)=0. + emis_dust(i,1,j,p_edust3)=0. + emis_dust(i,1,j,p_edust4)=0. + emis_dust(i,1,j,p_edust5)=0. + ust_min = -9999.d0 + rough_cor_in = 1.d0 + smois_cor_in = 1.d0 + endif !dsource/erod + + ust_t_min(i,j) = ust_min + rough_cor(i,j) = rough_cor_in + smois_cor(i,j) = smois_cor_in + enddo ! i loop + enddo ! j loop +! + +end subroutine UoC_dust_driver + +!***************************************************************************** + subroutine psd_create(d, dm, psd, dpsd, ppsd, imax, cmtrix, jmax) +! +!---------------------------------------------------------------------------- +! Yaping Shao, 13 June 2000 +! +! - Generate particle size distribution density function +! (both minimally-dispersed and fully-dispersed as the +! sum of four log-normal distributions. +! +! d(0,imax): output, particle size at 0, 1, 2, ..., imax points [um] +! dm(imax): output, particle size at middle of 0-1, 1-2, etc [um] +! psd(imax): output, particle size distribution density at dm [um^-1] +! dpsd(imax): output, Delta P for sections 0-1, 1-2, etc. [ ] +! ppsd(imax): output, P for sections 0-1, 1-2, etc. [ ] +! imax: input, length dm, psd, dpsdm, ppsd, etc. +! cmtrix: jmaxx coefficient matrix +! e.g. +! w1 = cmtrix(1, 1): weight for first log-normal distribution +! dln1 = cmtrix(2, 1): mean log-particle size of first log-normal distribution +! sig1 = cmtrix(3, 1): sigma of log-particle size for first log-normal distribution +! etc. +! careful with the dimension of dln and sig +!---------------------------------------------------------------------------- +! + integer :: i, j, imax, jmax + real(8), dimension(3, jmax) :: cmtrix + real(8) :: d(0:imax), dm(imax) + real(8) :: psd(imax), dpsd(imax), ppsd(imax) ! for p(d), Delta P(d) and P(d) + real(8) :: p, pp, w, dln, sig + real(8) :: cn + real(8), parameter :: eps=1.d-7 + real(8), parameter :: dref=1000.d0 + real(8) :: fu, fd, phi +! + cn = 1.d0/dsqrt(2.d0*3.14159d0) +! +! initialise psd, dpsd, ppsd +! + psd = 0.d0 + dpsd = 0.d0 + ppsd = 0.d0 +! +! Estimate d using phi scale. phi varies between from 9 to -1 +! with increment 0.1. Reference particle size d0 = 1000 um +! + fu = 10.d0 + fd = -1.d0 + do i = 0, imax + phi = fu - i*(fu-fd)/imax + d(i) = dref/2.d0**phi + enddo +! + do i = 1, imax + dm(i) = dexp( (dlog(d(i))+dlog(d(i-1)) )/2.d0 ) + + pp = 0.d0 + do j = 1, jmax + w = cmtrix(1, j) + dln = cmtrix(2, j) + sig = cmtrix(3, j) + if ( (w.gt.eps) .and. (sig.ne.0.) ) then + p = w*cn/sig*dexp( -(dlog(dm(i))-dln)**2/(2*sig**2) ) + else + p=0.d0 + endif + pp = pp + p + enddo +! + dpsd(i) = pp*( dlog(d(i)) - dlog(d(i-1)) ) ! Delta P over i + if (i.eq.1) then + ppsd(i) = 0.d0 + dpsd(i) ! P(d), with P(0) = 0 + else + ppsd(i) = ppsd(i-1) + dpsd(i) + endif + psd(i) = pp/dm(i) ! p(d), particle size distribution density + + enddo +! +! Renormalisation, in case ppsd(imax) is not 1 +! + dpsd = dpsd/ppsd(imax) + psd = psd/ppsd(imax) + ppsd = ppsd/ppsd(imax) + +! + end subroutine +!***************************************************************************** + +END MODULE uoc_dust diff --git a/wrfv2_fire/chem/module_vash_settling.F b/wrfv2_fire/chem/module_vash_settling.F index 1946e73e..67205c68 100755 --- a/wrfv2_fire/chem/module_vash_settling.F +++ b/wrfv2_fire/chem/module_vash_settling.F @@ -94,6 +94,7 @@ SUBROUTINE vash_settling_driver(dt,config_flags,t_phy,moist, & ash(1,1,kk,10)=chem(i,k,j,p_vash_10)*conver enddo if(config_flags%chem_opt == 400 .or. config_flags%chem_opt == 402 ) then + kk=0 do k=kts,kte kk=kk+1 ash(1,1,kk,1)=chem(i,k,j,p_vash_1)*conver @@ -118,6 +119,7 @@ SUBROUTINE vash_settling_driver(dt,config_flags,t_phy,moist, & chem(i,k,j,p_vash_10)=ash(1,1,kk,10)*converi enddo if(config_flags%chem_opt == 400 .or. config_flags%chem_opt == 402 ) then + kk=0 do k=kts,kte kk=kk+1 chem(i,k,j,p_vash_1)=ash(1,1,kk,1)*converi diff --git a/wrfv2_fire/chem/module_wetscav_driver.F b/wrfv2_fire/chem/module_wetscav_driver.F index 013eaf83..aca9b7e2 100644 --- a/wrfv2_fire/chem/module_wetscav_driver.F +++ b/wrfv2_fire/chem/module_wetscav_driver.F @@ -248,6 +248,7 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & integer :: ii,jj,kk REAL, DIMENSION( ims:ime, jms:jme, num_chem ) :: qsrflx ! column change due to scavening REAL :: tmp_minval = 1.0e7 + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) :: rainrate, evaprate ! ! Wet deposition over the current time step @@ -267,7 +268,7 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & ! cps_select: SELECT CASE(config_flags%chem_opt) - CASE ( RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM , CBMZSORG_AQ ) + CASE ( RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, CBMZSORG_AQ ) CALL wrf_debug(15,'wetscav_driver calling sorgam_wetscav_driver' ) call wetscav_sorgam_driver (id,ktau,dtstep,ktauc,config_flags, & dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & @@ -291,7 +292,8 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN) CALL wrf_error_fatal('Wet scavenging is currently not possible with MOSAIC unless aqueous aerosols are turned on.') - CASE (CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ) + CASE (CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) CALL wrf_debug(15,'wetscav_driver calling mosaic_wetscav_driver') call wetscav_cbmz_mosaic (id,ktau,dtstep,ktauc,config_flags, & dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & @@ -302,9 +304,19 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & its,ite, jts,jte, kts,kte ) CASE (MOZART_KPP,MOZCART_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP) CALL wrf_debug(15,'wetscav_driver calling wetscav_mozcart') + if( config_flags%mp_physics == THOMPSON ) then + rainrate(:,:,:) = rainprod(:,:,:) + evaprate(:,:,:) = evapprod(:,:,:) + elseif( config_flags%mp_physics == CAMMGMPSCHEME ) then + rainrate(:,:,:) = prain3d(:,:,:) + evaprate(:,:,:) = nevapr3d(:,:,:) + else + rainrate(:,:,:) = 0. + evaprate(:,:,:) = 0. + endif call wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, & dtstepc, t_phy, p8w, t8w, p_phy, & - chem, rho_phy, cldfra2, rainprod, evapprod, & + chem, rho_phy, cldfra2, rainrate, evaprate, & qv_b4mp, qc_b4mp, qi_b4mp, qs_b4mp, & gas_aqfrac, numgas_aqfrac, dz8w, dx, dy, & moist(ims,kms,jms,p_qv), moist(ims,kms,jms,p_qc), & @@ -340,7 +352,7 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & SELECT CASE(config_flags%chem_opt) - CASE ( RADM2SORG_AQCHEM,RACMSORG_AQCHEM ) + CASE ( RADM2SORG_AQCHEM,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP ) do jj=jts,jte do ii=its,ite diff --git a/wrfv2_fire/chem/module_zero_plumegen_coms.F b/wrfv2_fire/chem/module_zero_plumegen_coms.F index 7399a35e..5826ae93 100644 --- a/wrfv2_fire/chem/module_zero_plumegen_coms.F +++ b/wrfv2_fire/chem/module_zero_plumegen_coms.F @@ -33,6 +33,15 @@ Module module_zero_plumegen_coms real :: DT,TIME,TDUR integer :: MINTIME,MDUR,MAXTIME ! +REAL, DIMENSION(nkp,2) :: W_VMD,VMD +REAL :: upe (nkp) +REAL :: vpe (nkp) +REAL :: vel_e (nkp) + +REAL :: vel_p (nkp) +REAL :: rad_p (nkp) +REAL :: vel_t (nkp) +REAL :: rad_t (nkp) real :: ztop_(ntime) @@ -54,7 +63,15 @@ subroutine zero_plumegen_coms zsurf=0.0;zbase=0.0;ztop=0.0;area=0.0;rsurf=0.0;alpha=0.0;radius=0.0;heating=0.0 fmoist=0.0;bload=0.0;dt=0.0;time=0.0;tdur=0.0 ztop_=0.0 - +upe =0.0 +vpe =0.0 +vel_e =0.0 +vel_p =0.0 +rad_p =0.0 +vel_t =0.0 +rad_t =0.0 + W_VMD=0.0 + VMD=0.0 n=0;nm1=0;l=0;lbase=0;mintime=0;mdur=0;maxtime=0 end subroutine zero_plumegen_coms End Module diff --git a/wrfv2_fire/chem/optical_driver.F b/wrfv2_fire/chem/optical_driver.F index 50706de8..670b3f70 100755 --- a/wrfv2_fire/chem/optical_driver.F +++ b/wrfv2_fire/chem/optical_driver.F @@ -110,8 +110,8 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& ! ENDIF select case (config_flags%chem_opt) case ( RADM2SORG, RADM2SORG_KPP, RADM2SORG_AQ, RADM2SORG_AQCHEM, & - GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM, & - RACM_SOA_VBS_KPP, & + GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & + RACM_ESRLSORG_AQCHEM_KPP, RACM_SOA_VBS_KPP, & GOCARTRACM_KPP, GOCARTRADM2_KPP, GOCARTRADM2, & RACM_ESRLSORG_KPP, MOZCART_KPP, & CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_KPP, & @@ -120,7 +120,7 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP , & CBMZ_CAM_MAM3_NOAQ,CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM3_AQ, & - CBMZ_CAM_MAM7_AQ) + CBMZ_CAM_MAM7_AQ, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) processingAerosols = .true. call wrf_debug(15,'optical driver: process aerosols true') case default @@ -138,8 +138,8 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& select case (config_flags%chem_opt) case ( RADM2SORG, RACM_ESRLSORG_KPP, RADM2SORG_KPP, RADM2SORG_AQ, RADM2SORG_AQCHEM, & GOCARTRACM_KPP, GOCARTRADM2_KPP, GOCARTRADM2, & - GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM, & - RACM_SOA_VBS_KPP, & + GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & + RACM_ESRLSORG_AQCHEM_KPP, RACM_SOA_VBS_KPP, & CBMZSORG, CBMZSORG_AQ, MOZCART_KPP, & CBMZ_CAM_MAM3_NOAQ, CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM3_AQ, CBMZ_CAM_MAM7_AQ) nbin_o = 8 @@ -147,7 +147,8 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP ) + CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + MOZART_MOSAIC_4BIN_VBS0_KPP, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) nbin_o = nbin_a end select ! diff --git a/wrfv2_fire/chem/photolysis_driver.F b/wrfv2_fire/chem/photolysis_driver.F index 133525bc..f44884f6 100755 --- a/wrfv2_fire/chem/photolysis_driver.F +++ b/wrfv2_fire/chem/photolysis_driver.F @@ -190,6 +190,9 @@ SUBROUTINE photolysis_driver (id,curr_secs,ktau,dtstep, & ivgtyp, & ph_radfld, ph_adjcoe, ph_prate, & wc,zref, & + tauaer1, tauaer2, tauaer3, tauaer4, & !rajesh + waer1, waer2, waer3, waer4, & !rajesh + gaer1, gaer2, gaer3, gaer4, & !rajesh ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) diff --git a/wrfv2_fire/clean b/wrfv2_fire/clean index 05e6a143..ada8356f 100755 --- a/wrfv2_fire/clean +++ b/wrfv2_fire/clean @@ -31,31 +31,38 @@ if ( "$arg" == '-a' || "$arg" == '-aa' ) then /bin/cp Registry/Registry Registry/Registry.backup /bin/rm -f Registry/Registry /bin/rm -f Registry/io_boilerplate_temporary.inc + if ( -f Registry/Registry.rconfig ) then + /bin/rm -f Registry/Registry.rconfig + endif endif /bin/rm -fr ./netcdf_links /bin/rm -fr tools/code_dbase ( cd external ; make -i superclean ) ( cd external/io_grib1/WGRIB ; make clean ) ( cd external/atm_ocn ; make clean ) - ( cd tools ; /bin/rm -f registry gen_comms.c fseeko_test fseeko64_test ) + ( cd tools ; /bin/rm -f registry gen_comms.c fseeko_test fseeko64_test nc4_test.log ) ( cd inc; /bin/rm -f dm_comm_cpp_flags wrf_io_flags.h wrf_status_codes.h ) if ( -f configure.wrf ) then /bin/cp configure.wrf configure.wrf.backup /bin/rm -f configure.wrf endif if ( "$arg" != '-aa' ) then - ( cd run ; /bin/rm -f gm* out* fort* ideal* *.exe ; \ + ( cd run ; /bin/rm -f gm* out* fort* ideal* *.exe input_sounding ; \ /bin/cp -f namelist.input namelist.input.backup ; \ /bin/rm -f namelist.input ) >& /dev/null ( cd test/exp_real ; /bin/rm -f gm* out* fort* real* ) ( cd test ; rm -f */*.exe */ETAMPNEW_DATA* */GENPARM.TBL */LANDUSE.TBL */README.namelist \ */RRTM_DATA */SOILPARM.TBL */VEGPARM.TBL */MPTABLE.TBL */URBPARM.TBL */grib2map.tbl \ */CAM_ABS_DATA */CAM_AEROPT_DATA \ + */CCN_ACTIVATE.BIN \ */CAMtr_volume_mixing_ratio.RCP4.5 */CAMtr_volume_mixing_ratio.RCP6 */CAMtr_volume_mixing_ratio.RCP8.5 \ */CAMtr_volume_mixing_ratio.A1B */CAMtr_volume_mixing_ratio.A2 */CAMtr_volume_mixing_ratio \ */CLM_*DATA */RRTMG_LW_DATA */RRTMG_SW_DATA \ */ozone.formatted */ozone_lat.formatted */ozone_plev.formatted \ */aerosol.formatted */aerosol_lat.formatted */aerosol_plev.formatted */aerosol_lon.formatted \ + */kernels.asc_s_0_03_0_9 */bulkradii.asc_s_0_03_0_9 */bulkdens.asc_s_0_03_0_9 \ + */constants.asc \ + */masses.asc */kernels_z.asc */capacity.asc */termvels.asc */coeff_p.asc */coeff_q.asc \ */gribmap.txt */tr??t?? */co2_trans */namelist.output ) >& /dev/null else if ( "$arg" == '-aa' ) then /bin/rm -f configure.wrf.backup diff --git a/wrfv2_fire/compile b/wrfv2_fire/compile index 70d2b7f4..396f60ff 100755 --- a/wrfv2_fire/compile +++ b/wrfv2_fire/compile @@ -241,6 +241,8 @@ else /bin/cat Registry/Registry.CONVERT >> Registry/Registry endif else if ( $WRF_DA_CORE == 1 ) then + setenv BUFR 1 + setenv CRTM 1 if ( ! -f Registry/Registry ) then set overwrite=1 else @@ -268,8 +270,8 @@ else setenv BUFR 1 endif setenv CRTM_CPP "-DCRTM" - setenv CRTM_LIB "-L../external/crtm/libsrc -lCRTM" - setenv CRTM_SRC "-I../external/crtm/libsrc" + setenv CRTM_LIB "-L../external/crtm_2.1.3/libsrc -lCRTM" + setenv CRTM_SRC "-I../external/crtm_2.1.3/libsrc" setenv SFC_CRTM `grep '^SFC' configure.wrf | awk '{print $3}' | sed -e 's/\// /g' | awk '{print $NF}'` setenv ABI_CRTM `grep '^SFC' configure.wrf | sed -n 's/.*\(\-m[0-9]\{2\}\).*/\1/p'` else @@ -285,7 +287,7 @@ else setenv BUFR 1 endif setenv RTTOV_CPP "-DRTTOV" - setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov10.1.0_coef_io -lrttov10.1.0_emis_atlas -lrttov10.1.0_main" + setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov11.1.0_coef_io -lrttov11.1.0_emis_atlas -lrttov11.1.0_main" setenv RTTOV_SRC "-I${RTTOV}/include -I${RTTOV}/mod" else setenv RTTOV_CPP " " @@ -356,6 +358,10 @@ else endif endif + echo " " + echo "============================================================================================== " + echo " " + cat inc/version_decl | cut -c 45-54 echo " " echo -n "Compiling: " if ( $WRF_DA_CORE ) echo -n "WRF_DA_CORE " @@ -363,7 +369,23 @@ else if ( $WRF_NMM_CORE ) echo -n "WRF_NMM_CORE " if ( $WRF_COAMPS_CORE ) echo -n "WRF_COAMPS_CORE " if ( $WRF_EXP_CORE ) echo -n "WRF_EXP_CORE " - echo "." + echo " " + env | grep LARGE + echo " " + uname -a + echo " " + set comp = ( `grep "^SFC" configure.wrf | cut -d"=" -f2-` ) + if ( "$comp[1]" == "gfortran" ) then + gfortran --version + else if ( "$comp[1]" == "pgf90" ) then + pgf90 --version + else if ( "$comp[1]" == "ifort" ) then + ifort -V + else + echo "Not sure how to figure out the version of this compiler: $comp[1]" + endif + echo " " + echo "============================================================================================== " echo " " if ( ! $?WRF_SRC_ROOT_DIR ) setenv WRF_SRC_ROOT_DIR `pwd` diff --git a/wrfv2_fire/configure b/wrfv2_fire/configure index db06036e..369a0496 100755 --- a/wrfv2_fire/configure +++ b/wrfv2_fire/configure @@ -279,7 +279,7 @@ if [ -n "$NETCDF" ] ; then echo "Will use NETCDF in dir: $NETCDF" # for 3.6.2 and greater there might be a second library, libnetcdff.a . Check for this and use # if available - if [ -f "$NETCDF/lib/libnetcdff.a" ] ; then + if [ -f "$NETCDF/lib/libnetcdff.a" -o -f "$NETCDF/lib/libnetcdff.so" ] ; then USENETCDFF="-lnetcdff" fi else @@ -534,6 +534,16 @@ else compileflags="${compileflags} " fi +if [ -n "$WRF_NMM_CORE" -a -n "$WRF_CHEM" ]; then + if [ $WRF_NMM_CORE = 1 -a $WRF_CHEM = 1 ]; then + echo + echo "NMM is no longer compatible with the Chemistry option." + echo + # alphabetically: c=3, o=15, so co2 = 3+15+2 = 20 + exit 20 + fi +fi + if [ `which timex` ] ; then FORTRAN_COMPILER_TIMER=timex fi @@ -648,6 +658,10 @@ if test -n "$NETCDF" ; then echo "Error : Not found $NETCDF/include/netcdf.inc" echo " Please check this installation of NetCDF and re-run this configure script" echo + if test -n "$NETCDF4" ; then + echo "If on the NCAR Supercomputers, cp 'configure.nc4' to 'configure' and re-run script" + echo + fi exit -1 fi grep nf_format_64bit $NETCDF/include/netcdf.inc > /dev/null @@ -884,10 +898,10 @@ EOF fi # testing for Fortran 2003 IEEE signaling features -make fortran_2003_test > tools/fortran_2003_test.log 2>&1 -rm -f tools/fortran_2003_test.log +make fortran_2003_ieee_test > tools/fortran_2003_ieee_test.log 2>&1 +rm -f tools/fortran_2003_ieee_test.log retval=-1 -if [ -f tools/fortran_2003_test.exe ] ; then +if [ -f tools/fortran_2003_ieee_test.exe ] ; then retval=0 fi if [ $retval -ne 0 ] ; then @@ -897,12 +911,33 @@ if [ $retval -ne 0 ] ; then echo " " echo "************************** W A R N I N G ************************************" echo " " - echo "There are some Fortran 20003 features in WRF that your compiler does not recognize" + echo "There are some Fortran 2003 features in WRF that your compiler does not recognize" echo "The IEEE signaling call has been removed. That may not be enough." echo " " echo "*****************************************************************************" fi +# testing for Fortran 2003 ISO_C features +make fortran_2003_iso_c_test > tools/fortran_2003_iso_c_test.log 2>&1 +rm -f tools/fortran_2003_iso_c_test.log +retval=-1 +if [ -f tools/fortran_2003_iso_c_test.exe ] ; then + retval=0 +fi +if [ $retval -ne 0 ] ; then + sed -e '/^ARCH_LOCAL/s/$/ -DNO_ISO_C_SUPPORT/' configure.wrf > configure.wrf.edit + mv configure.wrf.edit configure.wrf + echo " " + echo " " + echo "************************** W A R N I N G ************************************" + echo " " + echo "There are some Fortran 2003 features in WRF that your compiler does not recognize" + echo "The routines that utilize ISO_C support have been stubbed out. " + echo "That may not be enough." + echo " " + echo "*****************************************************************************" +fi + # testing for netcdf4 IO features if [ -n "$NETCDF4" ] ; then if [ $NETCDF4 -eq 1 ] ; then diff --git a/wrfv2_fire/configure.nc4 b/wrfv2_fire/configure.nc4 new file mode 100755 index 00000000..bf874bfd --- /dev/null +++ b/wrfv2_fire/configure.nc4 @@ -0,0 +1,932 @@ +#!/bin/sh + +# parse argument list + +thiscmd=$0 + +FORTRAN_COMPILER_TIMER="" +opt_level="-f" +print_usage="" +chemistry="" +wrf_core="" +while [ $# -ge 1 ]; do + case $1 in + -d) opt_level="-d" ;; + -D) opt_level="-D" ;; + -s) opt_level="-s" ;; + -f) opt_level="-f" ;; + -h) print_usage="yes" ;; + -help) print_usage="yes" ;; + -os) shift ; WRF_OS=$1 ;; + -mach) shift ; WRF_MACH=$1 ;; + -time) shift ; FORTRAN_COMPILER_TIMER=$1 ;; + chem) WRF_CHEM=1 ;; + kpp) WRF_KPP=1 ;; + radardfi) WRF_DFI_RADAR=1 ;; + wrfda) wrf_core=DA_CORE ;; + 4dvar) wrf_core=4D_DA_CORE ;; + arw) wrf_core=EM_CORE ;; + nmm) wrf_core=NMM_CORE ;; + coamps) wrf_core=COAMPS_CORE ;; + exp) wrf_core=EXP_CORE ;; + titan) WRF_TITAN=1 ; break ;; + mars) WRF_MARS=1 ; break ;; + venus) WRF_VENUS=1 ; break ;; + esac + shift +done +if [ -n "$print_usage" ] ; then + echo usage: $thiscmd '[-d|-D|-s|-f|-os os|-mach mach|-time timecommand] [chem] [kpp]' + exit +fi + +if `pwd | grep ' ' > /dev/null ` ; then + echo '************************** W A R N I N G ************************************' + echo The current working directory has spaces in some components of its path name + echo and this may cause problems for your build. This can occur, for example, on + echo Windows systems. It is strongly recommended that you install WRF and other + echo related software such as NetCDF in directories whose path names contain no + echo white space. On Win, for example, create and install in a directory under C:. + echo '*****************************************************************************' +fi + + +# lifted from the configure file for mpich; 00/03/10 jm +# +# Check for perl and perl version +for p in perl5 perl +do + # Extract the first word of "$p", so it can be a program name with args. + set dummy $p; ac_word=$2 + if test -z "$ac_echo_n" ; then + ac_echo_n=yes + if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then + # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. + if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then + ac_n= ac_c=' +' ac_t=' ' + else + ac_n=-n ac_c= ac_t= + fi + else + ac_n= ac_c='\c' ac_t= + fi + ac_echo_test=`echo foo 1>&1` + if test -z "$ac_echo_test" ; then + print_error "Your sh shell does not handle the output redirection" + print_error "1>&1 correctly. Configure will work around this problem," + print_error "but you should report the problem to your vendor." + fi + fi + if test -z "$ac_echo_test" -a 1 = 1 ; then + echo $ac_n "checking for $ac_word""... $ac_c" + else + echo $ac_n "checking for $ac_word""... $ac_c" 1>&1 + fi + ac_prog_where="" + if test -n "$PERL"; then + ac_pg_PERL="$PERL" # Let the user override the test. + else + ac_first_char=`expr "$p" : "\(.\)"` + if test "$ac_first_char" = "/" -a -x "$p" ; then + ac_pg_PERL="$p" + ac_prog_where=$p + else + IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" + for ac_dir in $PATH; do + test -z "$ac_dir" && ac_dir=. + if test -f $ac_dir/$ac_word; then + ac_pg_PERL="$p" + ac_prog_where=$ac_dir/$ac_word + break + fi + done + IFS="$ac_save_ifs" + fi + fi;PERL="$ac_pg_PERL" + if test -n "$ac_prog_where" ; then + if test -z "$ac_echo_test" -a 1 = 1 ; then + echo "$ac_t""found $ac_prog_where ($PERL)" + else + echo "$ac_t""found $ac_prog_where ($PERL)" 1>&1 + fi + PERLFULLPATH=$ac_prog_where + else + if test -z "$ac_echo_test" -a 1 = 1 ; then + echo "$ac_t""no" + else + echo "$ac_t""no" 1>&1 + fi + fi + test -n "$PERL" && break +done + +if test -z "$PERL" ; then + # We have to set this outside of the loop lest the first failure in + # PROGRAM_CHECK set the value (which then terminates the effect of the + # loop, since autoconf macros only set values that are null, they + # don't override them + PERL="" +fi + +if test -n "$PERL" ; then + PERL="$PERL" + + perlversion=`$PERL -v | grep 'This is perl' | \ + sed -e 's/^.*v[a-z ]*\([0-9]\).*$/\1/'` + + # Should do a test first for ch_p4 etc. + if test "$perlversion" -lt 5 ; then + echo "WRF build requires perl version 5, which configure did not find." + echo "You can set the environment variable PERL to contain the " + echo "location of perl version 5." + echo "Configure believes that $PERL is version $perlversion ." + PERL="" + fi + +fi + +# Look for netcdf +if test -z "$NETCDF" ; then + for p in /usr/local/netcdf + do + if test -d $p ; then + NETCDF=$p + break + fi + done +fi +if test -z "$NETCDF" ; then + + if [ `hostname | cut -c 1-2` = "bs" -o \ + `hostname | cut -c 1-2` = "bd" -o \ + `hostname` = "tempest" -o `hostname` = "ute" ] ; then + echo 'Compiling on an NCAR system with weird paths to NetCDF' + echo 'Setting up a local NetCDF directory with symlinks' + if ( test -d ./netcdf_links ) ; then + echo 'A directory ./netcdf_links already exists. Continuing.' + else + mkdir ./netcdf_links + if [ -z "$OBJECT_MODE" ] ; then + OBJECT_MODE=32 + export OBJECT_MODE + fi + if [ $OBJECT_MODE -ne 64 -a \( `hostname | cut -c 1-2` = "bd" -o `hostname | cut -c 1-2` = "bs" \) ] ; then + ( cd ./netcdf_links ; ln -s /usr/local/lib32/r4i4 ./lib ; \ + ln -s /usr/local/include ./include ) + else + ( cd ./netcdf_links ; ln -s /usr/local/lib64/r4i4 ./lib ; \ + ln -s /usr/local/include ./include ) + fi + fi + NETCDF=`pwd`/netcdf_links + export NETCDF + + + else + bedone="" + if [ -d ./netcdf_links ] ; then + echo '** There is an existing ./netcdf_links file. Should I use? [y]' + read resp + if [ "$resp" = "y" ] ; then + NETCDF=`pwd`/netcdf_links + bedone="yes" + else + echo 'Removing existing ./netcdf_links directory' + /bin/rm -fr ./netcdf_links + fi + else + echo '** WARNING: No path to NETCDF and environment variable NETCDF not set.' + echo '** would you like me to try to fix? [y]' + fi + netcdfipath="" + netcdflpath="" + while [ -z "$bedone" ] ; do + read resp + if [ "$resp" = "y" -o -z "$resp" ] ; then + if [ -d ./netcdf_links ] ; then + echo 'There is already a ./netcdf_links directory. Okay to use links' + echo 'in this directory for NetCDF include and lib dirs? [y]' + read resp + if [ "$resp" = "y" ] ; then + NETCDF=`pwd`/netcdf_links + export NETCDF + bedone="yes" + continue + fi + fi + if [ -z "$netcdfipath" ] ; then + echo 'Enter full path to NetCDF include directory on your system' + read resp + if [ ! -d "$resp" ] ; then + echo "invalid path: $resp. Try again? [y]" ; continue + fi + netcdfipath=$resp + fi + if [ -z "$netcdflpath" ] ; then + echo 'Enter full path to NetCDF library directory on your system' + read resp + if [ ! -d "$resp" ] ; then + echo "invalid path: $resp. Try again? [y]" ; continue + fi + netcdflpath=$resp + fi + + if [ -n "$netcdflpath" -a -n "$netcdfipath" ] ; then + if [ -d ./netcdf_links ] ; then + echo 'Existing ./netcdf_links directory. Okay to remove. [y]' + read resp + if [ "$resp" = "y" ] ; then + /bin/rm -fr ./netcdf_links + fi + fi + mkdir ./netcdf_links + cd ./netcdf_links + ln -s "$netcdfipath" include + ln -s "$netcdflpath" lib + cd .. + echo created new ./netcdf_links directory + /bin/ls -lF ./netcdf_links + NETCDF=`pwd`/netcdf_links + export NETCDF + bedone="yes" + fi + else + bedone="yes" + fi + done + fi +fi + +if test -z "$PDHF5" ; then + if [ `hostname | cut -c 1-2` = "bb" -o `hostname | cut -c 1-2` = "bf" -o `hostname | cut -c 1-2` = "bs" -o \ + `hostname` = "dataproc" -o `hostname` = "ute" ] ; then + if [ -d ~michalak/hdf5pbin ] ; then + PHDF5=~michalak/hdf5pbin + export PHDF5 + fi + if [ "$OBJECT_MODE" -eq 64 ] ; then + if [ -d ~michalak/hdf5pbin-64 ] ; then + PHDF5=~michalak/hdf5pbin-64 + export PHDF5 + fi + fi + fi +fi + +USENETCDFF="" # see below +if [ -n "$NETCDF" ] ; then + echo "Will use NETCDF in dir: $NETCDF" +# for 3.6.2 and greater there might be a second library, libnetcdff.a . Check for this and use +# if available + if [ -f "$NETCDF/lib/libnetcdff.a" -o -f "$NETCDF/lib/libnetcdff.so" ] ; then + USENETCDFF="-lnetcdff" + fi +else + echo "Will configure for use without NetCDF" +fi + +if [ -z "$HDF5_PATH" ] ; then HDF5_PATH=''; fi +if [ -z "$ZLIB_PATH" ] ; then ZLIB_PATH=''; fi +if [ -z "$GPFS_PATH" ] ; then GPFS_PATH=''; fi +if [ -z "$CURL_PATH" ] ; then CURL_PATH=''; fi + +if [ -n "$NETCDF4" ] ; then + if [ $NETCDF4 -eq 1 ] ; then + DEP_LIB_PATH='' + if [ -f $NETCDF/bin/nf-config ] ; then + nx_config="$NETCDF/bin/nf-config --flibs" + DEP_LIB_PATH="`$nx_config | awk '{for(i=1;i<=NF;i++){if(match($i, /-L.*/)) {print $i} } }'`" + CURL="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lcurl") {print $i} } }'`" + GPFS="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lgpfs") {print $i} } }'`" + fi + if [ "$DEP_LIB_PATH" = '' ] ; then + if [ -f $NETCDF/bin/nc-config ] ; then + nx_config="$NETCDF/bin/nc-config --libs" + DEP_LIB_PATH="`$nx_config | awk '{for(i=1;i<=NF;i++){if(match($i, /-L.*/)) {print $i} } }'`" + CURL="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lcurl") {print $i} } }'`" + GPFS="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lgpfs") {print $i} } }'`" + if [ "$CURL" != '' -a "$CURL_PATH" = '' ] ; then + CURL_PATH="DEFAULT" + fi + if [ "$GPFS" != '' -a "$GPFS_PATH" = '' ] ; then + GPFS_PATH="DEFAULT" + fi + fi + fi + for P in "$HDF5_PATH" "$ZLIB_PATH" "$GPFS_PATH" "$CURL_PATH" + do + if [ "$P" != '' -a "$P" != "DEFAULT" ] ; then + if [ "${P#${P%?}}" = "/" ] ; then + P=`echo $P | sed 's/\/$//'` + fi + DEP_LIB_PATH="`echo $DEP_LIB_PATH | awk -v VAR=-L$P/lib '{for(i=1;i<=NF;i++){if ($i != VAR ) {print $i} } }'`" + DEP_LIB_PATH="$DEP_LIB_PATH -L$P/lib" + fi + done + if [ "${DEP_LIB_PATH#${DEP_LIB_PATH%?}}" = "/" ] ; then + DEP_LIB_PATH=`echo $DEP_LIB_PATH | sed 's/\/$//'` + fi + DEP_LIB_PATH="`echo $DEP_LIB_PATH | awk -v VAR=-L$NETCDF/lib '{for(i=1;i<=NF;i++){if ($i != VAR ) {print $i} } }'`" + fi +fi + +if [ -n "$PNETCDF" ] ; then + echo "Will use PNETCDF in dir: $PNETCDF" +# experimental, so don't tease the user if it is not there +#else +# echo "Will configure for use without NetCDF" +fi + +if [ -n "$PHDF5" ] ; then + echo "Will use PHDF5 in dir: $PHDF5" +else + echo "PHDF5 not set in environment. Will configure WRF for use without." +fi + +if [ "$wrf_core" = "DA_CORE" ]; then + if [ -n "$WRFPLUS_DIR" ] ; then + unset WRFPLUS_DIR + fi +fi + +if [ "$wrf_core" = "4D_DA_CORE" ]; then + if [ -n "$WRFPLUS_DIR" ] ; then + echo "Will use WRFPLUS in dir: $WRFPLUS_DIR" + else + echo "WRFPLUS_DIR not set in environment. Please compile WRFPLUS and set WRFPLUS_DIR." + exit + fi +fi +# Users who are cross-compiling can set environment variable +# $WRF_OS to override the value normally obtained from `uname`. +# If $WRF_OS is set, then $WRF_MACH can also be set to override +# the value normally obtained from `uname -m`. If $WRF_OS is +# set and $WRF_MACH is not set, then $WRF_MACH defaults to "ARCH". +# If $WRF_OS is not set then $WRF_MACH is ignored. +if [ -n "$WRF_OS" ] ; then + echo "${0}: WRF operating system set to \"${WRF_OS}\" via environment variable \$WRF_OS" + os=$WRF_OS + mach="ARCH" + if [ -n "$WRF_MACH" ] ; then + echo "${0}: WRF machine set to \"${WRF_MACH}\" via environment variable \$WRF_MACH" + mach=$WRF_MACH + fi +else + # if the uname command exists, give it a shot and see if + # we can narrow the choices; otherwise, spam 'em + os="ARCH" + mach="ARCH" + type uname > /dev/null + if [ $? -eq 0 ] ; then + os=`uname` + if [ "$os" = "AIX" -o "$os" = "IRIX" -o "$os" = "IRIX64" -o "$os" = "SunOS" -o "$os" = "HP-UX" -o "$os" = "Darwin" -o "$os" = "Interix" ] ; then + mach="ARCH" + else + xxx=`expr "$os" : '\(.........\).*'` + if [ "$xxx" = "CYGWIN_NT" ] ; then + os=$xxx + fi + if [ "$os" = "OSF1" -o "$os" = "Linux" -o "$os" = "UNICOS/mp" -o "$os" = "UNIX_System_V" -o "$os" = "CYGWIN_NT" ] ; then + mach=`uname -m` + if [ "$mach" = "ia64" -a -f /etc/sgi-release ] ; then + mach="Altix" + fi + else + os="ARCH" + mach="ARCH" + fi + fi + fi +fi + +# an IBM specific hack to adjust the bmaxstack and bmaxdata options if addressing is 32-bit +if [ "$os" = "AIX" ] ; then + if [ -z "$OBJECT_MODE" ] ; then + OBJECT_MODE=32 + export OBJECT_MODE + fi + if [ "$OBJECT_MODE" = "32" ] ; then +# the bang means nothing to sh in this context; use to represent spaces (perl will unbang) + ldflags=-bmaxstack:256000000!-bmaxdata:2048000000 + fi +fi + +# compile options that come from the environment, such as chemistry +# the "!" is removed by Config_new.pl +if [ -n "$WRF_HYDRO" ] ; then + if [ $WRF_HYDRO = 1 ] ; then + echo building WRF-HYDRO + compileflags="${compileflags}!-DWRF_HYDRO" + echo $compileflags + fi +fi + +# compile options that come from the environment, such as chemistry +# the "!" is removed by Config_new.pl +if [ -n "$WRF_MARS" ] ; then + if [ $WRF_MARS = 1 ] ; then + echo building WRF for Mars + compileflags="${compileflags}!-DPLANET!-DMARS" + echo $compileflags + fi +fi + +if [ -n "$WRF_TITAN" ] ; then + if [ $WRF_TITAN = 1 ] ; then + echo building WRF for Titan + compileflags="${compileflags}!-DPLANET!-DTITAN" + fi +fi + +if [ -n "$WRF_VENUS" ] ; then + if [ $WRF_VENUS = 1 ] ; then + echo building WRF for Venus + compileflags="${compileflags}!-DPLANET!-DVENUS" + fi +fi +if [ -n "$WRF_QUIETLY" ]; then + echo WRF_QUIETLY is now a synonym for WRF_LOG_BUFFERING + echo setting WRF_LOG_BUFFERING to 1... + export WRF_LOG_BUFFERING=1 +fi +if [ -n "$WRF_LOG_BUFFERING" ]; then + if [ $WRF_LOG_BUFFERING = 1 ]; then + echo building WRF with support for buffering of log messages + compileflags="${compileflags}!-DWRF_LOG_BUFFERING=1" + fi +fi +if [ -n "$WRF_NMM_CORE" ]; then + if [ $WRF_NMM_CORE = 1 ]; then + if [ -n "$HWRF" ]; then + if [ $HWRF = 1 ]; then + echo building WRF with HWRF option + compileflags="${compileflags}!-DHWRF=1" + if [ -n "$IDEAL_NMM_TC" ]; then + echo building WRF with NMM Idealized Tropical Cyclone option + compileflags="${compileflags}!-DIDEAL_NMM_TC=1" + fi + fi + fi + if [ -n "$IBM_REDUCE_BUG_WORKAROUND" ]; then + if [ $IBM_REDUCE_BUG_WORKAROUND = 1 ]; then + echo adding IBM_REDUCE_BUG_WORKAROUND flag for some IBM systems + compileflags="${compileflags}!-DIBM_REDUCE_BUG_WORKAROUND" + fi + fi + fi +fi +if [ -n "$WRF_DFI_RADAR" ] ; then + if [ $WRF_DFI_RADAR = 1 ] ; then + echo building WRF with radar dfi option + compileflags="${compileflags}!-DWRF_DFI_RADAR=1" + fi +fi +if [ -n "$WRF_CHEM" ] ; then + if [ $WRF_CHEM = 1 ] ; then + echo building WRF with chemistry option + compileflags="${compileflags}!-DWRF_CHEM!-DBUILD_CHEM=1" + if [ -n "$WRF_KPP" ] ; then + if [ $WRF_KPP = 1 ] ; then + echo building WRF with KPP chemistry option + compileflags="${compileflags}!-DWRF_KPP" + fi + fi + else + compileflags="${compileflags} " + fi +else + compileflags="${compileflags} " +fi + +if [ -n "$WRF_NMM_CORE" -a -n "$WRF_CHEM" ]; then + if [ $WRF_NMM_CORE = 1 -a $WRF_CHEM = 1 ]; then + echo + echo "NMM is no longer compatible with the Chemistry option." + echo + # alphabetically: c=3, o=15, so co2 = 3+15+2 = 20 + exit 20 + fi +fi + +if [ `which timex` ] ; then + FORTRAN_COMPILER_TIMER=timex +fi + +# Found perl, so proceed with configuration +if test -n "$PERL" ; then + srch=`grep -i "^#ARCH.*$os" arch/configure_new.defaults | grep -i "$mach"` + if [ -n "$srch" ] ; then + $PERL arch/Config_new.pl -dmparallel=$COMMLIB -ompparallel=$OMP -perl=$PERL \ + -netcdf=$NETCDF -pnetcdf=$PNETCDF -phdf5=$PHDF5 -os=$os -mach=$mach -ldflags=$ldflags \ + -compileflags=$compileflags -opt_level=$opt_level -USENETCDFF=$USENETCDFF -time=$FORTRAN_COMPILER_TIMER \ + -wrf_core=$wrf_core -gpfs=$GPFS_PATH -curl=$CURL_PATH -dep_lib_path="$DEP_LIB_PATH" + if test ! -f configure.wrf ; then + exit 1 + fi + if [ "$opt_level" = "-d" ] ; then + sed -e 's/FCOPTIM[ ]*=/& # /' -e '/FCDEBUG[ ]*=/s/#//' configure.wrf > configure.wrf.edit + /bin/mv configure.wrf.edit configure.wrf + fi + if [ "$opt_level" = "-D" ] ; then + sed -e 's/FCOPTIM[ ]*=/& # /' -e '/FCDEBUG[ ]*=/s/#//g' configure.wrf > configure.wrf.edit + /bin/mv configure.wrf.edit configure.wrf + fi + else + WRF_OS=$os ; export WRF_OS + WRF_MACH=$mach ; export WRF_MACH + echo '*** Configuration not found in configure_new.defaults; checking configure_old.defaults ***' + + # see if we still have an old setting laying around from v2 + if [ "$opt_level" = "-d" ] ; then + arch/config_old $opt_level + else + arch/config_old + fi + + fi +fi + +# new feb 2005. test whether MPI-2 +if test -f configure.wrf ; then + grep 'DMPARALLEL *= *1' configure.wrf > /dev/null + if [ $? = 0 ] ; then + echo testing for MPI_Comm_f2c and MPI_Comm_c2f + /bin/rm -f tools/mpi2_test + ( make mpi2_test 2> /dev/null ) 1> /dev/null + if test -e tools/mpi2_test.o ; then + echo " " MPI_Comm_f2c and MPI_Comm_c2f are supported + sed '/^DM_CC.*=/s/$/ -DMPI2_SUPPORT/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf + if [ `hostname | cut -c 1-2` = "be" ] ; then + sed '/^ARCH_LOCAL.*=/s/$/ -DUSE_MPI_IN_PLACE/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf + fi + else + echo " " MPI_Comm_f2c and MPI_Comm_c2f are not supported + fi + grep 'OMPCPP *= *-D_OPENMP' configure.wrf > /dev/null + if [ $? = 0 ] ; then + echo testing for MPI_Init_thread + /bin/rm -f tools/mpi2_thread_test + ( make mpi2_thread_test 2> /dev/null ) 1> /dev/null + if test -e tools/mpi2_thread_test.o ; then + echo " " MPI_Init_thread is supported + sed '/^DM_CC.*=/s/$/ -DMPI2_THREAD_SUPPORT/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf + else + echo " " MPI_Init_thread is not supported + fi + fi + fi +# new dec 2005. test what fseek is supported (needed for share/landread.c to work correctly) + echo testing for fseeko and fseeko64 + /bin/rm -f tools/fseeko_test tools/fseeko64_test + ( make fseek_test 2> /dev/null ) 1> /dev/null + if [ "$os" = "Darwin" ] ; then + # fseeko64 does not exist under Darwin fseeko does. Remove the 0 length executable + # file that might get generated anyway, even though the compiler complains about missing reference. + /bin/rm -f tools/fseeko64_test + fi + if test -x tools/fseeko64_test ; then + ( tools/fseeko64_test 2> /dev/null ) 1> /dev/null + if [ $? = 0 ] ; then + echo fseeko64 is supported + sed '/^CC .*=/s/$/ -DFSEEKO64_OK /' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf + fi + else + if test -x tools/fseeko_test ; then + ( tools/fseeko_test 2> /dev/null ) 1> /dev/null + if [ $? = 0 ] ; then + echo fseeko is supported and handles 64 bit offsets + sed '/^CC .*=/s/$/ -DFSEEKO_OK /' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf + else + echo neither fseeko64 nor fseeko with 64 bit offsets works, landread will be compiled with fseek + echo but may not work correctly for very high resolution terrain datasets + fi + else + echo neither fseeko64 nor fseeko with 64 bit offsets works, landread will be compiled with fseek + echo but may not work correctly for very high resolution terrain datasets + fi + fi +fi + +echo "------------------------------------------------------------------------" +sed -e '1,/#### Architecture specific settings ####/d' -e '/^externals/,$d' configure.wrf + +echo "------------------------------------------------------------------------" +echo "Settings listed above are written to configure.wrf." +echo "If you wish to change settings, please edit that file." +echo "If you wish to change the default options, edit the file:" +echo " arch/configure_new.defaults" + +if test -n "$NETCDF" ; then + if [ ! -f $NETCDF/include/netcdf.inc ] ; then + echo + echo "Error : Not found $NETCDF/include/netcdf.inc" + echo " Please check this installation of NetCDF and re-run this configure script" + echo + exit -1 + fi + grep nf_format_64bit $NETCDF/include/netcdf.inc > /dev/null + configure_aaaa=$? ; export configure_aaaa + if [ $configure_aaaa -a -z "$WRFIO_NCD_LARGE_FILE_SUPPORT" ] ; then + echo "NetCDF users note:" + echo " This installation of NetCDF supports large file support. To enable large file" + echo " support in NetCDF, set the environment variable WRFIO_NCD_LARGE_FILE_SUPPORT" + echo " to 1 and run configure again. Set to any other value to avoid this message." + fi +fi +echo " " + +if [ "$wrf_core" = "DA_CORE" -o "$wrf_core" = "4D_DA_CORE" ]; then + if [ "`grep '^SFC' configure.wrf | grep -i 'gfortran'`" != "" -o "`grep '^SFC' configure.wrf | grep -i 'frtpx'`" != "" ]; then + echo "WRFDA using gfortran/frtpx needs realsize=8" + sed -e '/^PROMOTION.*=/s/#//' configure.wrf > configure.wrf.edit + /bin/mv configure.wrf.edit configure.wrf + fi +fi + +#Checking cross-compiling capability for some particular environment +#on Linux and Mac box + +if [ $os = "Linux" -o $os = "Darwin" ]; then + + SFC=`grep '^SFC' configure.wrf | awk '{print $3}'` + SCC=`grep '^SCC' configure.wrf | awk '{print $3}'` + CCOMP=`grep '^CCOMP' configure.wrf | awk '{print $3}'` + + SFC="`type $SFC 2>/dev/null | awk '{print $NF}' | sed -e 's/(//g;s/)//g'`" + SCC="`type $SCC 2>/dev/null | awk '{print $NF}' | sed -e 's/(//g;s/)//g'`" + CCOMP="`type $CCOMP 2>/dev/null | awk '{print $NF}' | sed -e 's/(//g;s/)//g'`" + + foo=foo_$$ + +cat > ${foo}.c < ${foo}.f < /dev/null 2>&1 + if [ $? != 0 ]; then + sed 's/-cc=$(SCC)//' configure.wrf > configure.wrf.edit + mv configure.wrf.edit configure.wrf + fi + rm ${foo} ${foo}.o 2> /dev/null + mpif90 -f90=$SFC -o ${foo} ${foo}.f > /dev/null 2>&1 + if [ $? != 0 ]; then + sed 's/-f90=$(SFC)//' configure.wrf > configure.wrf.edit + mv configure.wrf.edit configure.wrf + fi + rm ${foo} ${foo}.o 2> /dev/null + fi + fi + + if [ -e $NETCDF/lib/libnetcdf.a -a "$SFC" != "" -a "$SCC" != "" -a "$CCOMP" != "" ]; then + + SFC_MULTI_ABI=0 + SCC_MULTI_ABI=0 + CCOMP_MULTI_ABI=0 + CROSS_COMPILING=0 + + echo + echo Testing for NetCDF, C and Fortran compiler + echo + + ar p $NETCDF/lib/libnetcdf.a `ar t $NETCDF/lib/libnetcdf.a | grep -E '\.o' | head -n 1 | sed 's/://'` > ${foo}.o + netcdf_arch="`file ${foo}.o | grep -o -E '[0-9]{2}-bit|i386'`" + rm ${foo}.o + + $SFC -o ${foo} ${foo}.f > /dev/null 2>&1 + SFC_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`" + rm ${foo} ${foo}.o 2> /dev/null + + $SCC -o ${foo} ${foo}.c > /dev/null 2>&1 + SCC_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`" + CCOMP_arch=$SCC_arch + rm ${foo} ${foo}.o 2> /dev/null + + if [ "$SCC" != "$CCOMP" ]; then + $CCOMP -o ${foo} ${foo}.c > /dev/null 2>&1 + CCOMP_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`" + rm ${foo} ${foo}.o 2> /dev/null + fi + + if [ "$SFC_arch" = "" -o "$SCC_arch" = "" -o "$CCOMP_arch" = "" ]; then + echo " One of compilers testing failed!" + echo " Please check your compiler" + echo + rm -f ${foo} ${foo}.[cfo] 2> /dev/null + exit + else + cp configure.wrf configure.wrf.edit + fi + + case $netcdf_arch in + + 32-bit|i386 ) + + if [ "$SFC_arch" = "64-bit" ] ; then + CROSS_COMPILING=1 + $SFC -m32 -o ${foo} ${foo}.f > /dev/null 2>&1 + if [ $? = 0 ]; then + SFC_MULTI_ABI=1 + sed '/^SFC.*=/s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp + mv configure.wrf.tmp configure.wrf.edit + fi + fi + if [ "$SCC_arch" = "64-bit" ] ; then + CROSS_COMPILING=1 + $SCC -m32 -o ${foo} ${foo}.c > /dev/null 2>&1 + if [ $? = 0 ]; then + SCC_MULTI_ABI=1 + sed '/^SCC.*=/s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp + mv configure.wrf.tmp configure.wrf.edit + fi + fi + + if [ "$CCOMP_arch" = "64-bit" ] ; then + CROSS_COMPILING=1 + if [ "$CCOMP" != "$SCC" ]; then + $CCOMP -m32 -o ${foo} ${foo}.c > /dev/null 2>&1 + if [ $? = 0 ]; then + CCOMP_MULTI_ABI=1 + sed '/^CCOMP/ s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp + mv configure.wrf.tmp configure.wrf.edit + fi + else + CCOMP_MULTI_ABI=1 + sed '/^CCOMP/ s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp + mv configure.wrf.tmp configure.wrf.edit + fi + fi + + if [ $CROSS_COMPILING -eq 1 ] ; then + echo NOTE: + echo This installation of NetCDF is 32-bit + if [ \( $SFC_MULTI_ABI -ne 1 -a "$SFC_arch" = "64-bit" \) \ + -o \( $SCC_MULTI_ABI -ne 1 -a "$SCC_arch" = "64-bit" \) \ + -o \( $CCOMP_MULTI_ABI -ne 1 -a "$CCOMP_arch" = "64-bit" \) ] ; then + rm configure.wrf.edit + echo One of compilers is 64-bit and doesn\'t support cross-compiling. + echo Please check your NETCDF lib and compiler + else + echo -m32 is appended to configure.wrf + echo It will be forced to build in 32-bit. + echo If you don\'t want 32-bit binaries, please use 64-bit NetCDF, and re-run the configure script. + fi + fi + ;; + + 64-bit ) + + if [ "$SFC_arch" = "32-bit" -o "$SFC_arch" = "i386" ] ; then + CROSS_COMPILING=1 + $SFC -m64 -o ${foo} ${foo}.f > /dev/null 2>&1 + if [ $? = 0 ]; then + SFC_MULTI_ABI=1 + sed '/^SFC.*=/s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp + mv configure.wrf.tmp configure.wrf.edit + fi + fi + if [ "$SCC_arch" = "32-bit" -o "$SCC_arch" = "i386" ] ; then + CROSS_COMPILING=1 + $SCC -m64 -o ${foo} ${foo}.c > /dev/null 2>&1 + if [ $? = 0 ]; then + SCC_MULTI_ABI=1 + sed '/^SCC.*=/s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp + mv configure.wrf.tmp configure.wrf.edit + fi + fi + + if [ "$CCOMP_arch" = "32-bit" -o "$CCOMP_arch" = "i386" ] ; then + CROSS_COMPILING=1 + if [ "$CCOMP" != "$SCC" ]; then + $CCOMP -m64 -o ${foo} ${foo}.c > /dev/null 2>&1 + if [ $? = 0 ]; then + CCOMP_MULTI_ABI=1 + sed '/^CCOMP/ s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp + mv configure.wrf.tmp configure.wrf.edit + fi + else + CCOMP_MULTI_ABI=1 + sed '/^CCOMP/ s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp + mv configure.wrf.tmp configure.wrf.edit + fi + fi + + if [ $CROSS_COMPILING -eq 1 ] ; then + echo NOTE: + echo This installation of NetCDF is 64-bit + if [ \( $SFC_MULTI_ABI -ne 1 -a "$SFC_arch" != "64-bit" \) \ + -o \( $SCC_MULTI_ABI -ne 1 -a "$SCC_arch" != "64-bit" \) \ + -o \( $CCOMP_MULTI_ABI -ne 1 -a "$CCOMP_arch" != "64-bit" \) ]; then + rm configure.wrf.edit + echo One of Compilers is 32-bit and doesn\'t support cross-compiling. + echo Please check your NetCDF lib and compiler + else + echo -m64 is appended to configure.wrf + echo It will be forced to build in 64-bit. + echo If you don\'t want 64-bit binaries, please use 32-bit NetCDF, and re-run the configure script. + fi + fi + ;; + esac + + if [ -e configure.wrf.edit ]; then + mv configure.wrf.edit configure.wrf + fi + + if [ $CROSS_COMPILING -eq 0 ] ; then + echo "This installation of NetCDF is $netcdf_arch" + echo " C compiler is $SCC_arch" + echo " Fortran compiler is $SFC_arch" + echo " It will build in $netcdf_arch" + fi + echo + fi + rm -f ${foo} ${foo}.[cfo] 2> /dev/null +fi + +# testing for Fortran 2003 IEEE signaling features +make fortran_2003_ieee_test > tools/fortran_2003_ieee_test.log 2>&1 +rm -f tools/fortran_2003_ieee_test.log +retval=-1 +if [ -f tools/fortran_2003_ieee_test.exe ] ; then + retval=0 +fi +if [ $retval -ne 0 ] ; then + sed -e '/^ARCH_LOCAL/s/$/ -DNO_IEEE_MODULE/' configure.wrf > configure.wrf.edit + mv configure.wrf.edit configure.wrf + echo " " + echo " " + echo "************************** W A R N I N G ************************************" + echo " " + echo "There are some Fortran 2003 features in WRF that your compiler does not recognize" + echo "The IEEE signaling call has been removed. That may not be enough." + echo " " + echo "*****************************************************************************" +fi + +# testing for Fortran 2003 ISO_C features +make fortran_2003_iso_c_test > tools/fortran_2003_iso_c_test.log 2>&1 +rm -f tools/fortran_2003_iso_c_test.log +retval=-1 +if [ -f tools/fortran_2003_iso_c_test.exe ] ; then + retval=0 +fi +if [ $retval -ne 0 ] ; then + sed -e '/^ARCH_LOCAL/s/$/ -DNO_ISO_C_SUPPORT/' configure.wrf > configure.wrf.edit + mv configure.wrf.edit configure.wrf + echo " " + echo " " + echo "************************** W A R N I N G ************************************" + echo " " + echo "There are some Fortran 2003 features in WRF that your compiler does not recognize" + echo "The routines that utilize ISO_C support have been stubbed out. " + echo "That may not be enough." + echo " " + echo "*****************************************************************************" +fi + +# testing for netcdf4 IO features +if [ -n "$NETCDF4" ] ; then + if [ $NETCDF4 -eq 1 ] ; then + make nc4_test > tools/nc4_test.log 2>&1 + retval=-1 + if [ -f tools/nc4_test.exe ] ; then + retval=0 + rm -f tools/nc4_test.log + fi + if [ $retval -ne 0 ] ; then + echo "************************** W A R N I N G ************************************" + echo "NETCDF4 IO features are enabled, but this installation of NetCDF " + echo " $NETCDF" + echo "sounds like DO NOT support these IO features. " + echo + echo "Please make sure NETCDF version is 4.1.3 or later and was built with " + echo "--enable-netcdf4 " + echo + echo "OR unset NETCDF4 variable " + echo " bash/ksh : unset NETCDF4 " + echo " csh : unsetenv NETCDF4 " + echo + echo "Then re-run this configure script " + echo + echo "!!! configure.wrf WAS REMOVED !!!" + echo + echo "*****************************************************************************" + rm -f configure.wrf + fi + fi +fi diff --git a/wrfv2_fire/dyn_em/Makefile b/wrfv2_fire/dyn_em/Makefile index 222dcbca..9e16b425 100644 --- a/wrfv2_fire/dyn_em/Makefile +++ b/wrfv2_fire/dyn_em/Makefile @@ -24,7 +24,8 @@ MODULES = \ module_sfs_nba.o \ module_convtrans_prep.o \ module_sfs_driver.o \ - module_stoch.o \ + module_stoch.o \ + module_after_all_rk_steps.o \ $(CASE_MODULE) # possible CASE_MODULE settings diff --git a/wrfv2_fire/dyn_em/adapt_timestep_em.F b/wrfv2_fire/dyn_em/adapt_timestep_em.F index d72a5614..ea7c3a85 100644 --- a/wrfv2_fire/dyn_em/adapt_timestep_em.F +++ b/wrfv2_fire/dyn_em/adapt_timestep_em.F @@ -118,14 +118,17 @@ RECURSIVE SUBROUTINE adapt_timestep(grid, config_flags) max_increase_factor = 1. + grid%max_step_increase_pct / 100. ! - ! If this is the first time step of the model run (indicated by current_time - ! eq start_time), then set the time step to the input starting_time_step. + ! If this is the first time step of the model run (indicated by time step #1), + ! then set the time step to the input starting_time_step. ! ! Else, calculate the time step based on cfl. ! - if ( (domain_get_current_time ( grid ) .eq. domain_get_start_time ( grid )) .AND. & - .NOT. config_flags%restart ) then - CALL WRFU_TimeIntervalSet(dtInterval, Sn=grid%starting_time_step, Sd=1) + if ( ( domain_get_advanceCount ( grid ) .EQ. 1 ) .AND. ( .NOT. config_flags%restart ) ) then + if ( grid%starting_time_step_den .EQ. 0 ) then + CALL WRFU_TimeIntervalSet(dtInterval, Sn=grid%starting_time_step, Sd=1) + else + CALL WRFU_TimeIntervalSet(dtInterval, Sn=grid%starting_time_step, Sd=grid%starting_time_step_den) + end if curr_secs = 0 CALL WRFU_TimeIntervalSet(last_dtInterval, Sn=0, Sd=1) @@ -174,14 +177,22 @@ RECURSIVE SUBROUTINE adapt_timestep(grid, config_flags) ! Limit the maximum dtInterval based on user input - CALL WRFU_TimeIntervalSet(tmpTimeInterval, Sn=grid%max_time_step, Sd=1) + if ( grid%max_time_step_den .EQ. 0 ) then + CALL WRFU_TimeIntervalSet(tmpTimeInterval, Sn=grid%max_time_step, Sd=1) + else + CALL WRFU_TimeIntervalSet(tmpTimeInterval, Sn=grid%max_time_step, Sd=grid%max_time_step_den) + end if if (dtInterval .gt. tmpTimeInterval ) then dtInterval = tmpTimeInterval endif ! Limit the minimum dtInterval based on user input. - CALL WRFU_TimeIntervalSet(tmpTimeInterval, Sn=grid%min_time_step, Sd=1) + if ( grid%min_time_step_den .EQ. 0 ) then + CALL WRFU_TimeIntervalSet(tmpTimeInterval, Sn=grid%min_time_step, Sd=1) + else + CALL WRFU_TimeIntervalSet(tmpTimeInterval, Sn=grid%min_time_step, Sd=grid%min_time_step_den) + end if if (dtInterval .lt. tmpTimeInterval ) then dtInterval = tmpTimeInterval endif diff --git a/wrfv2_fire/dyn_em/depend.dyn_em b/wrfv2_fire/dyn_em/depend.dyn_em index 218044e9..7bea8683 100644 --- a/wrfv2_fire/dyn_em/depend.dyn_em +++ b/wrfv2_fire/dyn_em/depend.dyn_em @@ -177,6 +177,7 @@ module_initialize_scm_xy.o : \ module_initialize_real.o : \ nest_init_utils.o \ + module_polarfft.o \ ../share/module_llxy.o \ ../frame/module_domain.o \ ../frame/module_configure.o \ @@ -229,7 +230,7 @@ start_em.o: module_bc_em.o \ ../share/module_bc.o \ ../share/module_date_time.o \ ../phys/module_physics_init.o \ - ../phys/module_diagnostics.o \ + ../phys/module_diag_pld.o \ ../phys/module_fr_fire_driver_wrf.o \ $(CF) @@ -241,7 +242,9 @@ solve_em.o: module_small_step_em.o \ module_big_step_utilities_em.o \ module_first_rk_step_part1.o \ module_first_rk_step_part2.o \ + module_after_all_rk_steps.o \ module_avgflx_em.o \ + module_polarfft.o \ ../frame/module_domain.o \ ../frame/module_configure.o \ ../frame/module_driver_constants.o \ @@ -250,6 +253,7 @@ solve_em.o: module_small_step_em.o \ ../frame/module_tiles.o \ ../frame/module_dm.o \ ../frame/module_comm_dm.o \ + ../frame/module_cpl.o \ ../share/module_llxy.o \ ../share/module_model_constants.o \ ../share/module_bc.o \ @@ -290,6 +294,12 @@ module_first_rk_step_part2.o : \ ../phys/module_fddaobs_driver.o \ ../phys/module_fddaobs_driver.o +module_after_all_rk_steps.o : \ + ../frame/module_state_description.o \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../phys/module_diagnostics_driver.o + adapt_timestep_em.o: \ module_bc_em.o \ ../frame/module_domain.o \ diff --git a/wrfv2_fire/dyn_em/module_advect_em.F b/wrfv2_fire/dyn_em/module_advect_em.F index 096f3934..03c4ee64 100644 --- a/wrfv2_fire/dyn_em/module_advect_em.F +++ b/wrfv2_fire/dyn_em/module_advect_em.F @@ -7572,10 +7572,11 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & DO j=j_start, j_end DO k=kts, ktf -#ifdef INTEL_ALIGN64 -!DEC$ ASSUME_ALIGNED fqx:64, fqy:64, fqz:64, fqxl:64, fqyl:64, fqzl:64 +#ifdef XEON_SIMD +!DIR$ simd +#else +!DIR$ vector always #endif -!DEC$ vector always DO i=i_start, i_end ph_low = (mub(i,j)+mu_old(i,j))*field_old(i,k,j) & diff --git a/wrfv2_fire/dyn_em/module_after_all_rk_steps.F b/wrfv2_fire/dyn_em/module_after_all_rk_steps.F new file mode 100644 index 00000000..88c7ec46 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_after_all_rk_steps.F @@ -0,0 +1,150 @@ +!WRF:MEDIATION_LAYER:SOLVER + +MODULE module_after_all_rk_steps + +CONTAINS + + ! This subroutine is called once per domain per time step. It is outside + ! of and after the end of the Runge-Kutta time steps, after the calls to + ! the explicit moisture driver, and after the polar filtering calls. The + ! variables in here are all up-to-date with the end of this current time + ! step. + + + SUBROUTINE after_all_rk_steps ( grid, config_flags, & + moist, chem, tracer, scalar, & + th_phy, pi_phy, p_phy, rho_phy, & + p8w, t8w, dz8w, & + curr_secs2, & + diag_flag, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex, & + imsy, imey, jmsy, jmey, kmsy, kmey, & + ipsy, ipey, jpsy, jpey, kpsy, kpey ) + + + !============================================================= + ! USE Association for Generic WRF Infrastructure + !============================================================= + + ! Pick up the number of members for each of the 4d arrays - for declaration purposes. + + USE module_state_description, ONLY: num_moist, num_chem, num_tracer, num_scalar + + ! This gives us the type definition for grid (domain) + + USE module_domain, ONLY : domain + + ! All of the information from the namelist is in config_flags. The + ! type declaration for this puppy must be available. + + USE module_configure, ONLY : grid_config_rec_type + + + !============================================================= + ! USE Association for the Diagnostic Packages + !============================================================= + + USE module_diagnostics_driver, ONLY : diagnostics_driver + + + IMPLICIT NONE + + + !============================================================= + ! Subroutine Arguments + !============================================================= + + ! Arguments passed in. All of the diagnostics are part of the grid structure, so + ! even though we are not changing any of the fundamental variables, we are computing + ! the diagnostics. Therefore grid is INOUT. + + TYPE ( domain ), INTENT(INOUT) :: grid + + ! We are not changing any of the namelist settings. + + TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags + + ! The 4d arrays are input only, no mods to them. + + REAL , DIMENSION(ims:ime,kms:kme,jms:jme,num_moist ) , INTENT(IN) :: moist + REAL , DIMENSION(ims:ime,kms:kme,jms:jme,num_chem ) , INTENT(IN) :: chem + REAL , DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer) , INTENT(IN) :: tracer + REAL , DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar) , INTENT(IN) :: scalar + + ! A few handy 3d arrays computed for the physics scheme: pressure (Pa) and + ! temperature (K), on both half (_phy) and full levels. + + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: th_phy , & + p_phy , & + pi_phy , & + rho_phy , & + dz8w , & + p8w , & + t8w + + ! Time (s) since the beginning of the restart. + + REAL :: curr_secs2 + + ! Is this to be a history output time? If so, compute the diagnostics. + + LOGICAL :: diag_flag + + ! The sundry dimensions required to keep a model running smoothly: + ! The first letter: + ! i: refers to the nominally west east direction, the inner-most (fastest) + ! incrementing index + ! j: refers to the nominally south north direction, the outer-most (slowest) + ! incrementing index + ! k: refers to the vertical direction form bottom to top, the second dimension + ! in all 3d arrays + ! The second letter: + ! d: refers to the domain size, the geophysical extent of the entire domain, + ! not used in dimensions or looping, used to determine when we are close to + ! the edge of the boundary + ! m: refers to the memory size size, all 2d and 3d arrays from the Registry + ! (passed into here via the grid structure or the I1 variables [such as + ! p_phy, for example]) use these values for dimensioning + ! p: refers to the patch size, the extent over which computational loops run + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + + ! Hopefully unnecessary, these are the filtered dimensions. + + INTEGER , INTENT(IN) :: imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey + + + !============================================================= + ! Start of executable code + !============================================================= + + CALL wrf_debug ( 100 , '--> TOP OF AFTER ALL RK STEPS' ) + CALL wrf_debug ( 100 , '--> CALLING DIAGNOSTICS DRIVER' ) + + CALL diagnostics_driver ( grid, config_flags, & + moist, chem, tracer, scalar, & + th_phy, pi_phy, p_phy, rho_phy, & + p8w, t8w, dz8w, & + curr_secs2, & + diag_flag, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex, & + imsy, imey, jmsy, jmey, kmsy, kmey, & + ipsy, ipey, jpsy, jpey, kpsy, kpey ) + + + END SUBROUTINE after_all_rk_steps + +END MODULE module_after_all_rk_steps diff --git a/wrfv2_fire/dyn_em/module_big_step_utilities_em.F b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F index 78b2aac5..2e1a3582 100644 --- a/wrfv2_fire/dyn_em/module_big_step_utilities_em.F +++ b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F @@ -4804,11 +4804,11 @@ SUBROUTINE phy_prep ( config_flags, & ! input k_start = kts k_end = min( kte, kde-1 ) !jdf - do j = j_start,j_end - do i = i_start, i_end - if(landmask(i,j).lt.0.5) xland(i,j)=2.0 - enddo - enddo +! do j = j_start,j_end +! do i = i_start, i_end +! if(landmask(i,j).lt.0.5) xland(i,j)=2.0 +! enddo +! enddo !jdf ! compute thermodynamics and velocities at pressure points (or half levels) diff --git a/wrfv2_fire/dyn_em/module_diffusion_em.F b/wrfv2_fire/dyn_em/module_diffusion_em.F index 3113244a..82357b13 100644 --- a/wrfv2_fire/dyn_em/module_diffusion_em.F +++ b/wrfv2_fire/dyn_em/module_diffusion_em.F @@ -1201,6 +1201,7 @@ SUBROUTINE calculate_km_kh( config_flags, dt, & n_moist, cf1, cf2, cf3, warm_rain, & mix_upper_bound, & msftx, msfty, & + zx, zy, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -1247,7 +1248,7 @@ SUBROUTINE calculate_km_kh( config_flags, dt, & REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT( IN ) & :: defor11, defor22, defor33, defor12, defor13, defor23, & - div, rdz, rdzw, p8w, t8w, theta, t, p + div, rdz, rdzw, p8w, t8w, theta, t, p, zx, zy REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: tke @@ -1312,6 +1313,7 @@ SUBROUTINE calculate_km_kh( config_flags, dt, & CALL smag2d_km( config_flags, xkmh, xkmv, & xkhh, xkhv, defor11, defor22, defor12, & rdzw, dx, dy, msftx, msfty, & + zx, zy, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -1916,7 +1918,7 @@ END SUBROUTINE smag_km SUBROUTINE smag2d_km( config_flags,xkmh,xkmv,xkhh,xkhv, & defor11,defor22,defor12, & - rdzw,dx,dy,msftx, msfty, & + rdzw,dx,dy,msftx, msfty,zx,zy, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -1935,7 +1937,7 @@ SUBROUTINE smag2d_km( config_flags,xkmh,xkmv,xkhh,xkhv, & REAL , INTENT(IN ) :: dx, dy - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: rdzw + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: rdzw,zx,zy REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: xkmh, & xkmv, & @@ -1953,6 +1955,7 @@ SUBROUTINE smag2d_km( config_flags,xkmh,xkmv,xkhh,xkhv, & INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k REAL :: deltas, tmp, pr, mlen_h, c_s + REAL :: dxm, dym, tmpzx, tmpzy, alpha REAL, DIMENSION( its:ite , kts:kte , jts:jte ) :: def2 @@ -2002,6 +2005,16 @@ SUBROUTINE smag2d_km( config_flags,xkmh,xkmv,xkhh,xkhv, & xkmv(i,k,j)=0. xkhh(i,k,j)=xkmh(i,k,j)/pr xkhv(i,k,j)=0. + IF(config_flags%diff_opt .EQ. 2)THEN +! jd: slope reduce by slope factor + dxm=dx/msftx(i,j) + dym=dy/msfty(i,j) + tmpzx = abs(0.25*( zx(i,k,j)+ zx(i+1,k,j ) + zx(i,k+1,j)+ zx(i+1,k+1,j ))*rdzw(i,k,j)*dxm) + tmpzy = abs(0.25*( zy(i,k,j)+ zy(i ,k,j+1) + zy(i,k+1,j)+ zy(i ,k+1,j+1))*rdzw(i,k,j)*dym) + alpha = max(sqrt(tmpzx*tmpzx+tmpzy*tmpzy),1.0) + xkmh(i,k,j)=xkmh(i,k,j)/alpha + xkhh(i,k,j)=xkhh(i,k,j)/alpha + ENDIF ENDDO ENDDO ENDDO @@ -3387,7 +3400,8 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & config_flags,defor13,defor23,defor33, & nba_mij, n_nba_mij, & !JDM div, & - moist,chem,scalar,tracer,xkmv,xkhv,km_opt,& + moist,chem,scalar,tracer, & + xkmv,xkhv,xkmh,km_opt, & ! xkmh added fnm, fnp, dn, dnw, rdz, rdzw, & hfx, qfx, ust, rho, & ids, ide, jds, jde, kds, kde, & @@ -3452,6 +3466,7 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & div, & xkmv, & xkhv, & + xkmh, & tke, & rdz, & u_2, & @@ -3521,7 +3536,7 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & CALL vertical_diffusion_w_2( rw_tendf, config_flags, mu, & defor33, tke(ims,kms,jms), & nba_mij, n_nba_mij, & !JDM - div, xkmv, & + div, xkmh, & !Mod from RR Oct2013 was xkmv dn, rdz, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4040,7 +4055,7 @@ END SUBROUTINE vertical_diffusion_v_2 SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & defor33, tke, & nba_mij, n_nba_mij, & !JDM - div, xkmv, & + div, xkmh, & dn, rdz, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4065,7 +4080,7 @@ SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & INTENT(IN ) ::defor33, & tke, & div, & - xkmv, & + xkmh, & rdz INTEGER, INTENT( IN ) :: n_nba_mij !JDM @@ -4111,7 +4126,7 @@ SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & js_ext=0 je_ext=0 CALL cal_titau_11_22_33( config_flags, titau3, & - mu, tke, xkmv, defor33, & + mu, tke, xkmh, defor33, & ! from RR 20131023 was xkmv nba_mij(ims,kms,jms,P_m33), & !JDM is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & @@ -6068,15 +6083,15 @@ SUBROUTINE cal_helicity ( config_flags, u, v, w, uh, up_heli_max,& REAL & :: zl, zu, uh_smth - REAL, DIMENSION( its-2:ite+2, jts-2:jte+2 ) :: mm + REAL, DIMENSION( its-3:ite+2, jts-3:jte+2 ) :: mm - REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) & + REAL, DIMENSION( its-3:ite+2, kts:kte, jts-3:jte+2 ) & :: tmp1, hat, hatavg - REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) & + REAL, DIMENSION( its-3:ite+2, kts:kte, jts-3:jte+2 ) & :: wavg, rvort - LOGICAL, DIMENSION( its-2:ite+2, jts-2:jte+2 ) & + LOGICAL, DIMENSION( its-3:ite+2, jts-3:jte+2 ) & :: use_column ! End declarations. diff --git a/wrfv2_fire/dyn_em/module_em.F b/wrfv2_fire/dyn_em/module_em.F index eaa1dc4d..88083f69 100644 --- a/wrfv2_fire/dyn_em/module_em.F +++ b/wrfv2_fire/dyn_em/module_em.F @@ -8,12 +8,15 @@ MODULE module_em USE module_advect_em, only: advect_u, advect_v, advect_w, advect_scalar, advect_scalar_pd, advect_scalar_mono, & advect_weno_u, advect_weno_v, advect_weno_w, advect_scalar_weno, advect_scalar_wenopd - USE module_big_step_utilities_em, only: grid_config_rec_type, calculate_full, couple_momentum, calc_mu_uv, calc_ww_cp, calc_cq, calc_alt, calc_php, set_tend, rhs_ph, & - horizontal_pressure_gradient, pg_buoy_w, w_damp, perturbation_coriolis, coriolis, curvature, horizontal_diffusion, horizontal_diffusion_3dmp, vertical_diffusion_u, & - vertical_diffusion_v, vertical_diffusion, vertical_diffusion_3dmp, sixth_order_diffusion, rk_rayleigh_damp, theta_relaxation, vertical_diffusion_mp, zero_tend, zero_tend2d + USE module_big_step_utilities_em, only: grid_config_rec_type, calculate_full, couple_momentum, calc_mu_uv, calc_ww_cp, & + calc_cq, calc_alt, calc_php, set_tend, rhs_ph, & + horizontal_pressure_gradient, pg_buoy_w, w_damp, perturbation_coriolis, coriolis, curvature, horizontal_diffusion, & + horizontal_diffusion_3dmp, vertical_diffusion_u, & + vertical_diffusion_v, vertical_diffusion, vertical_diffusion_3dmp, sixth_order_diffusion, rk_rayleigh_damp, & + theta_relaxation, vertical_diffusion_mp, zero_tend, zero_tend2d - USE module_state_description, only: param_first_scalar, p_qr, p_qv, p_qc, p_qg, p_qi, p_qs, tiedtkescheme, heldsuarez, positivedef, & - gdscheme, g3scheme, gfscheme, kfetascheme, monotonic, wenopd_scalar, weno_scalar, weno_mom + USE module_state_description, only: param_first_scalar, p_qr, p_qv, p_qc, p_qg, p_qi, p_qs, tiedtkescheme, heldsuarez, & + positivedef, gdscheme, g3scheme, gfscheme, kfetascheme, monotonic, wenopd_scalar, weno_scalar, weno_mom USE module_damping_em, only: held_suarez_damp @@ -1628,6 +1631,8 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & RQISHTEN,RQSSHTEN,RQGSHTEN, & RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RQVNDGDTEN, & RMUNDGDTEN, & + scalar, scalar_tend, num_scalar, & + tracer, tracer_tend, num_tracer, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -1636,6 +1641,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & TYPE(grid_config_rec_type), INTENT(IN) :: config_flags + INTEGER, INTENT(IN ) :: num_scalar, num_tracer INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte @@ -1696,7 +1702,14 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: RMUNDGDTEN - INTEGER :: i,k,j +! 4d arrays + + REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT) :: tracer + REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer),INTENT(INOUT) :: tracer_tend + REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT) :: scalar + REAL ,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT) :: scalar_tend + + INTEGER :: i,k,j, im INTEGER :: itf,ktf,jtf,itsu,jtsv !----------------------------------------------------------------------- @@ -1952,6 +1965,29 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & ENDIF +! 4d couple scalar tendencies that have only uncoupled physics tendencies at this point + + DO im = PARAM_FIRST_SCALAR,num_scalar + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + scalar_tend(I,K,J,im)=mu(I,J)*scalar_tend(I,K,J,im) + ENDDO + ENDDO + ENDDO + ENDDO + + DO im = PARAM_FIRST_SCALAR,num_tracer + DO J=jts,jtf + DO K=kts,ktf + DO I=its,itf + tracer_tend(I,K,J,im)=mu(I,J)*tracer_tend(I,K,J,im) + ENDDO + ENDDO + ENDDO + ENDDO + + END SUBROUTINE calculate_phy_tend !----------------------------------------------------------------------- @@ -2113,8 +2149,19 @@ subroutine trajectory ( grid,config_flags, & eta_new = 0.0 keta=0 keta_temp=0 - if (traj_lat(tjk) .ne. -9999.0) then - call latlon_to_ij (proj, traj_lat(tjk),traj_long(tjk),traj_i(tjk),traj_j(tjk)) + if (traj_i(tjk) .ne. -9999.0) then + if ( ( proj%code .EQ. PROJ_LC ) .OR. & + ( proj%code .EQ. PROJ_PS ) .OR. & + ( proj%code .EQ. PROJ_PS_WGS84 ) .OR. & + ( proj%code .EQ. PROJ_ALBERS_NAD83 ) .OR. & + ( proj%code .EQ. PROJ_MERC ) .OR. & + ( proj%code .EQ. PROJ_LATLON ) .OR. & + ( proj%code .EQ. PROJ_CYL ) .OR. & + ( proj%code .EQ. PROJ_CASSINI ) .OR. & + ( proj%code .EQ. PROJ_GAUSS ) .OR. & + ( proj%code .EQ. PROJ_ROTLL ) ) THEN + call latlon_to_ij (proj, traj_lat(tjk),traj_long(tjk),traj_i(tjk),traj_j(tjk)) + end if i_traj=floor(traj_i(tjk)) ! find the lower_left_bottom corner for trajectory j_traj=floor(traj_j(tjk)) ! k_traj=floor(traj_k(tjk)) ! @@ -2262,7 +2309,18 @@ subroutine trajectory ( grid,config_flags, & traj_k(tjk) = traj_k(tjk)-0.5 endif !! convert i,j,k into lon, lat - call ij_to_latlon (proj, traj_i(tjk), traj_j(tjk),traj_lat(tjk),traj_long(tjk)) + if ( ( proj%code .EQ. PROJ_LC ) .OR. & + ( proj%code .EQ. PROJ_PS ) .OR. & + ( proj%code .EQ. PROJ_PS_WGS84 ) .OR. & + ( proj%code .EQ. PROJ_ALBERS_NAD83 ) .OR. & + ( proj%code .EQ. PROJ_MERC ) .OR. & + ( proj%code .EQ. PROJ_LATLON ) .OR. & + ( proj%code .EQ. PROJ_CYL ) .OR. & + ( proj%code .EQ. PROJ_CASSINI ) .OR. & + ( proj%code .EQ. PROJ_GAUSS ) .OR. & + ( proj%code .EQ. PROJ_ROTLL ) ) THEN + call ij_to_latlon (proj, traj_i(tjk), traj_j(tjk),traj_lat(tjk),traj_long(tjk)) + end if else traj_i(tjk) = -9999.0 traj_j(tjk) = -9999.0 diff --git a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F index c20d543d..32660ec2 100644 --- a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F +++ b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F @@ -20,9 +20,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & , tke_tend & , adapt_step_flag , curr_secs & , psim , psih , wspd , gz1oz0 , br , chklowq & - , cu_act_flag , hol , th_phy & - , pi_phy , p_phy , t_phy , u_phy , v_phy & - , dz8w , p8w , t8w , rho_phy , rho & + , cu_act_flag , hol , th_phy & + , pi_phy , p_phy , t_phy & + , dz8w , p8w , t8w & , ids, ide, jds, jde, kds, kde & , ims, ime, jms, jme, kms, kme & , ips, ipe, jps, jpe, kps, kpe & @@ -51,7 +51,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & use module_scalar_tables #ifdef DM_PARALLEL USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, wrf_dm_maxval - USE module_comm_dm, ONLY : halo_em_phys_a_sub,halo_em_fdda_sfc_sub,halo_pwp_sub,halo_em_chem_e_3_sub,halo_em_chem_e_5_sub + USE module_comm_dm, ONLY : halo_em_phys_a_sub,halo_em_fdda_sfc_sub,halo_pwp_sub,halo_em_chem_e_3_sub, & + halo_em_chem_e_5_sub, halo_em_hydro_noahmp_sub #endif USE module_utility IMPLICIT NONE @@ -96,13 +97,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: pi_phy REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: p_phy REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t_phy - REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: u_phy - REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: v_phy REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: dz8w REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: p8w REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t8w - REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho_phy - REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: ru_tendf REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rv_tendf @@ -193,7 +190,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & grid%mut, grid%muu, grid%muv, grid%u_2, & grid%v_2, grid%p, grid%pb, grid%alt, & grid%ph_2, grid%phb, grid%t_2, grid%tsk, moist, num_moist, & - rho,th_phy, p_phy, pi_phy, u_phy, v_phy, & + grid%rho,th_phy, p_phy, pi_phy, grid%u_phy, grid%v_phy, & p8w, t_phy, t8w, grid%z, grid%z_at_w, dz8w, & grid%p_hyd, grid%p_hyd_w, grid%dnw, & grid%fnm, grid%fnp, grid%znw, grid%p_top, & @@ -268,10 +265,11 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,JULYR=grid%julyr ,LW_PHYSICS=config_flags%ra_lw_physics & & ,NCFRCV=grid%ncfrcv ,NCFRST=grid%ncfrst ,NPHS=1 & & ,o3input=config_flags%o3input ,O3rad=grid%o3rad & - & ,aer_opt=config_flags%aer_opt ,aerod=aerod(:,:,:,P_ocarbon:P_upperaer) & + & ,aer_opt=config_flags%aer_opt ,aerod=aerod(:,:,:,P_ocarbon:P_upperaer) & + & ,swint_opt=config_flags%swint_opt & & ,P8W=grid%p_hyd_w ,P=grid%p_hyd ,PI=pi_phy & & ,RADT=grid%radt ,RA_CALL_OFFSET=grid%ra_call_offset & - & ,RHO=rho ,RLWTOA=grid%rlwtoa & + & ,RHO=grid%rho ,RLWTOA=grid%rlwtoa & & ,RSWTOA=grid%rswtoa ,RTHRATEN=grid%rthraten & & ,RTHRATENLW=grid%rthratenlw ,RTHRATENSW=grid%rthratensw & & ,SNOW=grid%snow ,STEPRA=grid%stepra ,SWDOWN=grid%swdown & @@ -286,6 +284,18 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,SWVISDIR=grid%swvisdir ,SWVISDIF=grid%swvisdif & !ssib & ,SWNIRDIR=grid%swnirdir ,SWNIRDIF=grid%swnirdif & !ssib & ,SF_SURFACE_PHYSICS=config_flags%sf_surface_physics & !ssib +! WRF-solar and aerosol variables from jararias 2013/8 and 2013/11 + & ,SWDDIR=grid%swddir,SWDDNI=grid%swddni,SWDDIF=grid%swddif & + & ,Gx=grid%Gx,Bx=grid%Bx,gg=grid%gg,bb=grid%bb & + & ,swdown_ref=grid%swdown_ref,swddir_ref=grid%swddir_ref & + & ,coszen_ref=grid%coszen_ref & + & ,aer_type=config_flags%aer_type & + & ,aer_aod550_opt=config_flags%aer_aod550_opt,aer_aod550_val=config_flags%aer_aod550_val & + & ,aer_angexp_opt=config_flags%aer_angexp_opt,aer_angexp_val=config_flags%aer_angexp_val & + & ,aer_ssa_opt=config_flags%aer_ssa_opt,aer_ssa_val=config_flags%aer_ssa_val & + & ,aer_asy_opt=config_flags%aer_asy_opt,aer_asy_val=config_flags%aer_asy_val & + & ,aod5502d=grid%aod5502d,angexp2d=grid%angexp2d,aerssa2d=grid%aerssa2d & + & ,aerasy2d=grid%aerasy2d,aod5503d=grid%aod5503d & !Optional solar variables & ,DECLINX=grid%declin ,SOLCONX=grid%solcon ,COSZEN=grid%coszen ,HRANG=grid%hrang & & , CEN_LAT=grid%cen_lat & @@ -312,8 +322,12 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & , TSWDN=grid%tswdn, TSWUP=grid%tswup & ! goddard schemes & , SSWDN=grid%sswdn, SSWUP=grid%sswup & ! goddard schemes !JJS 20101020 ^^^^^ - & , CLDFRA=grid%cldfra, CLDFRA_MP_ALL=grid%cldfra_mp_all & + & , LRADIUS=grid%LRADIUS,IRADIUS=grid%IRADIUS & !BSINGH(01/22/2014) + & , CLDFRA_DP=grid%cldfra_dp & ! ckay for subgrid cloud + & , CLDFRA_SH=grid%cldfra_sh & + & , re_cloud=grid%re_cloud, re_ice=grid%re_ice, re_snow=grid%re_snow & ! G. Thompson + & , has_reqc=grid%has_reqc, has_reqi=grid%has_reqi, has_reqs=grid%has_reqs & ! G. Thompson & , PB=grid%pb & & , F_ICE_PHY=grid%f_ice_phy,F_RAIN_PHY=grid%f_rain_phy & & , QV=moist(ims,kms,jms,P_QV), F_QV=F_QV & @@ -348,8 +362,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,AEROSOLC_2=grid%aerosolc_2, M_HYBI0=grid%m_hybi & & ,ABSTOT=grid%abstot, ABSNXT=grid%absnxt, EMSTOT=grid%emstot & & ,RADTACTTIME=grid%radtacttime & - & ,CU_RAD_FEEDBACK=config_flags%cu_rad_feedback & - & ,QC_ADJUST=grid%GD_CLOUD_B , QI_ADJUST=grid%GD_CLOUD2_B & + & ,ICLOUD_CU=config_flags%ICLOUD_CU & + & ,QC_CU=grid%QC_CU , QI_CU=grid%QI_CU & #ifdef WRF_CHEM & ,AER_RA_FEEDBACK=config_flags%aer_ra_feedback & & ,PM2_5_DRY=grid%pm2_5_dry, PM2_5_WATER=grid%pm2_5_water & @@ -379,6 +393,15 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & BENCH_START(surf_driver_tim) +!gmm halo of wtd and riverflow for leafhydro +#ifdef DM_PARALLEL + IF ( config_flags%sf_surface_physics.eq.NOAHMPSCHEME ) THEN + IF ( config_flags%opt_run.eq.5.and.mod(grid%itimestep,grid%STEPWTD).eq.0 ) THEN +# include "HALO_EM_HYDRO_NOAHMP.inc" + ENDIF + ENDIF +#endif + !----------------------------------------------------------------- ! urban related variable are added to arguments of surface_driver !----------------------------------------------------------------- @@ -436,7 +459,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,PSIM=psim ,P_PHY=grid%p_hyd ,Q10=grid%q10 & & ,Q2=grid%q2 ,QFX=grid%qfx ,QSFC=grid%qsfc & & ,QSHLTR=grid%qshltr ,QZ0=grid%qz0 ,RAINCV=grid%raincv & - & ,RA_LW_PHYSICS=config_flags%ra_lw_physics ,RHO=rho & + & ,RA_LW_PHYSICS=config_flags%ra_lw_physics ,RHO=grid%rho & & ,RMOL=grid%rmol ,SFCEVP=grid%sfcevp ,SFCEXC=grid%sfcexc & & ,SFCRUNOFF=grid%sfcrunoff & & ,SF_SFCLAY_PHYSICS=config_flags%sf_sfclay_physics & @@ -445,7 +468,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,SMSTAV=grid%smstav ,SMSTOT=grid%smstot ,SNOALB=grid%snoalb & & ,SNOW=grid%snow ,SNOWC=grid%snowc ,SNOWH=grid%snowh & & ,SMCREL=grid%smcrel & - & ,SST=grid%sst ,SST_UPDATE=grid%sst_update & + & ,SST=grid%sst ,SST_INPUT=grid%sst_input,SST_UPDATE=grid%sst_update & & ,SSTSK=grid%sstsk ,DTW=grid%dtw ,SST_SKIN=grid%sst_skin & & ,SCM_FORCE_SKINTEMP=grid%scm_force_skintemp & & ,SCM_FORCE_FLUX=grid%scm_force_flux & @@ -458,10 +481,12 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,TSLB=grid%tslb ,T_PHY=t_phy ,U10=grid%u10 & & ,URATX=grid%uratx ,VRATX=grid%vratx ,TRATX=grid%tratx & & ,UDRUNOFF=grid%udrunoff ,UST=grid%ust ,UZ0=grid%uz0 & - & ,U_FRAME=grid%u_frame ,U_PHY=u_phy ,V10=grid%v10 & + & ,U_FRAME=grid%u_frame ,U_PHY=grid%u_phy ,V10=grid%v10 & + & ,UOCE=grid%uoce ,VOCE=grid%voce & & ,VEGFRA=grid%vegfra ,VZ0=grid%vz0 ,V_FRAME=grid%v_frame & - & ,V_PHY=v_phy ,WARM_RAIN=grid%warm_rain & + & ,V_PHY=grid%v_phy ,WARM_RAIN=grid%warm_rain & & ,WSPD=wspd ,XICE=grid%xice ,XLAND=grid%xland & + & ,MAX_EDOM=grid%num_ext_model_couple_dom ,CPLMASK=grid%cplmask & & ,Z0=grid%z0 ,Z=grid%z ,ZNT=grid%znt & & ,ZS=grid%zs ,ALBSI=grid%albsi , ICEDEPTH=grid%icedepth & & ,SNOWSI=grid%snowsi & @@ -472,6 +497,21 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,SF_OCEAN_PHYSICS=config_flags%sf_ocean_physics ,OML_HML0=config_flags%oml_hml0 ,OML_GAMMA=config_flags%oml_gamma & & ,TML=grid%tml, T0ML=grid%t0ml, HML=grid%hml, H0ML=grid%h0ml, HUML=grid%huml, HVML=grid%hvml, F=grid%f & & ,TMOML=grid%TMOML,ISWATER=iswater & + & ,lakedepth2d=grid%lakedepth2d, savedtke12d=grid%savedtke12d & + & ,snowdp2d=grid%snowdp2d, h2osno2d=grid%h2osno2d & !lake + & ,snl2d=grid%snl2d, t_grnd2d=grid%t_grnd2d & + & ,t_lake3d=grid%t_lake3d, lake_icefrac3d=grid%lake_icefrac3d & !lake + & ,z_lake3d=grid%z_lake3d, dz_lake3d=grid%dz_lake3d & + & ,t_soisno3d=grid%t_soisno3d, h2osoi_ice3d=grid%h2osoi_ice3d & !lake + & ,h2osoi_liq3d=grid%h2osoi_liq3d, h2osoi_vol3d=grid%h2osoi_vol3d & + & ,z3d=grid%z3d, dz3d=grid%dz3d & !lake + & ,zi3d=grid%zi3d, watsat3d=grid%watsat3d & + & ,csol3d=grid%csol3d, tkmg3d=grid%tkmg3d & !lake + & ,tkdry3d=grid%tkdry3d, tksatu3d=grid%tksatu3d & + & ,LakeModel=grid%sf_lake_physics, lake_min_elev=grid%lake_min_elev & !lake +#if ( EM_CORE == 1) + & ,LakeMask=grid%LakeMask & ! lake +#endif ! CLM Varaibles & ,NUMC=grid%numc,NUMP=grid%nump,SABV=grid%sabv,SABG=grid%sabg,LWUP=grid%lwup,SNL=grid%snl, & & HISTORY_INTERVAL=config_flags%history_interval , &!ylu add hist inverval for accumulation T max/min @@ -643,12 +683,19 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & , irbxy=grid%irbxy , trxy=grid%trxy , evcxy=grid%evcxy & & ,chleafxy=grid%chleafxy , chucxy=grid%chucxy & & , chv2xy=grid%chv2xy , chb2xy=grid%chb2xy , chstarxy=grid%chstarxy & + !Optional hydro variables in NOAHMP + & ,smcwtdxy=grid%smcwtdxy ,rechxy=grid%rechxy ,deeprechxy=grid%deeprechxy & + & ,fdepthxy=grid%fdepthxy, areaxy=grid%areaxy, rivercondxy=grid%rivercondxy & + & ,riverbedxy=grid%riverbedxy, eqzwt=grid%eqzwt, pexpxy=grid%pexpxy & + & ,qrfxy=grid%qrfxy, qspringxy=grid%qspringxy, qslatxy=grid%qslatxy, qrfsxy=grid%qrfsxy & + & ,qspringsxy=grid%qspringsxy, smoiseq=grid%smoiseq, wtddt=config_flags%wtddt, stepwtd=grid%stepwtd & ! Noah UA changes & ,ua_phys=config_flags%ua_phys,flx4=grid%flx4,fvb=grid%fvb & & ,fbur=grid%fbur,fgsn=grid%fgsn & ! Indexes & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + & ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe & & , I_START=grid%i_start,I_END=min(grid%i_end, ide-1) & & , J_START=grid%j_start,J_END=min(grid%j_end, jde-1) & & , KTS=k_start, KTE=min(k_end,kde-1) & @@ -684,14 +731,31 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,usemonalb=config_flags%usemonalb & & ,NOAHRES=grid%noahres & & ,TSK_SAVE=grid%tsk_save & -!mynn mp - & ,ch=grid%ch,tsq=grid%tsq,qsq=grid%qsq,cov=grid%cov & + & ,ch=grid%ch,tsq=grid%tsq,qsq=grid%qsq,cov=grid%cov & !MYNN - MP + & ,Sh3d=grid%sh3d,EL_PBL=grid%el_pbl & !JOE- MYNN cloudpdf + & ,bl_mynn_cloudpdf=config_flags%bl_mynn_cloudpdf & !JOE- MYNN cloudpdf + & ,fgdp=grid%fgdp,dfgdp=grid%dfgdp,vdfg=grid%vdfg & !Katata - fogdes + & ,grav_settling=config_flags%grav_settling & !Katata - fogdes & ,OM_TMP=grid%om_tmp, OM_S=grid%om_s, OM_U=grid%om_u, OM_V=grid%om_v & !cyl:3DPWP & ,OM_DEPTH=grid%om_depth, OM_ML=grid%OM_ML, OM_LON=grid%om_lon & !cyl:3DPWP & ,OM_LAT=grid%om_lat & !cy:3DPWP & , okms = 1, okme=config_flags%ocean_levels & ! cyl:3DPWP & ,rdx=grid%rdx, rdy=grid%rdy,msfu=grid%msfu,msfv=grid%msfv,msft=grid%msft &!cyl: 3DPWP & ,XTIME=grid%xtime,OM_TINI=grid%om_tini,OM_SINI=grid%om_sini,id=grid%id,omdt=config_flags%omdt &!cyl: 3DPWP + & ,sf_surface_mosaic=config_flags%sf_surface_mosaic, mosaic_cat=config_flags%mosaic_cat, mosaic_cat_index=grid%mosaic_cat_index & !danli mosaic + & ,landusef2=grid%landusef2,TSK_mosaic=grid%TSK_mosaic,QSFC_mosaic=grid%QSFC_mosaic, TSLB_mosaic=grid%TSLB_mosaic,SMOIS_mosaic=grid%SMOIS_mosaic,SH2O_mosaic=grid%SH2O_mosaic & !danli mosaic + & ,CANWAT_mosaic=grid%CANWAT_mosaic,SNOW_mosaic=grid%SNOW_mosaic,SNOWH_mosaic=grid%SNOWH_mosaic,SNOWC_mosaic=grid%SNOWC_mosaic & !danli mosaic + & ,ALBEDO_mosaic=grid%ALBEDO_mosaic,ALBBCK_mosaic=grid%ALBBCK_mosaic, EMISS_mosaic=grid%EMISS_mosaic, EMBCK_mosaic=grid%EMBCK_mosaic, ZNT_mosaic=grid%ZNT_mosaic, Z0_mosaic=grid%Z0_mosaic & !danli mosaic + & ,HFX_mosaic=grid%HFX_mosaic,QFX_mosaic=grid%QFX_mosaic, LH_mosaic=grid%LH_mosaic, GRDFLX_mosaic=grid%GRDFLX_mosaic,SNOTIME_mosaic=grid%SNOTIME_mosaic & !danli mosaic + & ,TR_URB2D_mosaic=grid%TR_URB2D_mosaic,TB_URB2D_mosaic=grid%TB_URB2D_mosaic & !danli mosaic + & ,TG_URB2D_mosaic=grid%TG_URB2D_mosaic,TC_URB2D_mosaic=grid%TC_URB2D_mosaic & !danli mosaic + & ,QC_URB2D_mosaic=grid%QC_URB2D_mosaic,UC_URB2D_mosaic=grid%UC_URB2D_mosaic & !danli mosaic + & ,TRL_URB3D_mosaic=grid%TRL_URB3D_mosaic,TBL_URB3D_mosaic=grid%TBL_URB3D_mosaic & !danli mosaic + & ,TGL_URB3D_mosaic=grid%TGL_URB3D_mosaic & !danli mosaic + & ,SH_URB2D_mosaic=grid%SH_URB2D_mosaic,LH_URB2D_mosaic=grid%LH_URB2D_mosaic & !danli mosaic + & ,G_URB2D_mosaic=grid%G_URB2D_mosaic,RN_URB2D_mosaic=grid%RN_URB2D_mosaic & !danli mosaic + & ,TS_URB2D_mosaic=grid%TS_URB2D_mosaic & !danli mosaic + & ,TS_RUL2D_mosaic=grid%TS_RUL2D_mosaic & !danli mosaic & ) #ifdef WRF_HYDRO @@ -710,6 +774,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & CALL pbl_driver( & & AKHS=grid%akhs ,AKMS=grid%akms & & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics & + & ,WINDFARM_OPT=config_flags%windfarm_opt,power=grid%power & & ,BLDT=grid%bldt, CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag & & ,BLDTACTTIME=grid%bldtacttime & & ,BR=br ,CHKLOWQ=chklowq ,CT=grid%ct & @@ -724,13 +789,14 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,PSIM=psim ,P_PHY=grid%p_hyd ,QFX=grid%qfx & & ,QSFC=grid%qsfc ,QZ0=grid%qz0 ,MIXHT=mixht & & ,RA_LW_PHYSICS=config_flags%ra_lw_physics & - & ,RHO=rho ,RQCBLTEN=grid%rqcblten ,RQIBLTEN=grid%rqiblten & + & ,RHO=grid%rho ,RQCBLTEN=grid%rqcblten ,RQIBLTEN=grid%rqiblten & & ,RQVBLTEN=grid%rqvblten ,RTHBLTEN=grid%rthblten ,RUBLTEN=grid%rublten & & ,RVBLTEN=grid%rvblten ,SNOW=grid%snow ,STEPBL=grid%stepbl & & ,THZ0=grid%thz0 ,TH_PHY=th_phy & & ,TSK=grid%tsk ,T_PHY=grid%t_phy ,UST=grid%ust & - & ,U10=grid%u10 ,UZ0=grid%uz0 ,U_FRAME=grid%u_frame ,U_PHY=u_phy & - & ,V10=grid%v10 ,VZ0=grid%vz0 ,V_FRAME=grid%v_frame ,V_PHY=v_phy & + & ,U10=grid%u10 ,UZ0=grid%uz0 ,U_FRAME=grid%u_frame ,U_PHY=grid%u_phy & + & ,V10=grid%v10 ,VZ0=grid%vz0 ,V_FRAME=grid%v_frame ,V_PHY=grid%v_phy & + & ,UOCE=grid%uoce ,VOCE=grid%voce & ,T2=grid%t2 & & ,WARM_RAIN=grid%warm_rain ,WSPD=wspd & & ,XICE=grid%xice ,XLAND=grid%xland ,Z=grid%z & @@ -784,19 +850,18 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG & & ,HOL=HOL, MOL=grid%mol, REGIME=grid%REGIME & !mynn mp@ - & ,QKE=grid%qke & -!ACF-QKE advection - & ,QKE_ADV=scalar(ims,kms,jms,P_qke_adv) & - & ,bl_mynn_tkeadvect=config_flags%bl_mynn_tkeadvect & -!ACF-end + & ,QKE=grid%qke, Sh3d=grid%sh3d & + & ,QKE_ADV=scalar(ims,kms,jms,P_qke_adv) & !ACF-QKE advection + & ,bl_mynn_tkeadvect=config_flags%bl_mynn_tkeadvect & !ACF-QKE advection & ,tsq=grid%tsq, qsq=grid%qsq, cov=grid%cov & - & ,EL_MYNN=grid%el_mynn & & ,DQKE=grid%dqke,QWT=grid%qWT & & ,QSHEAR=grid%qSHEAR,QBUOY=grid%qBUOY,QDISS=grid%qDISS & & ,bl_mynn_tkebudget=config_flags%bl_mynn_tkebudget & + & ,bl_mynn_cloudpdf=config_flags%bl_mynn_cloudpdf & & ,rmol=grid%rmol, ch=grid%ch & & ,qcg=grid%qcg, grav_settling=config_flags%grav_settling & ! & ,K_m=grid%K_m, K_h=grid%K_h, K_q=grid%K_q & + & ,vdfg=grid%vdfg & ! Katata - fogdep !GWD for ARW & ,GWD_OPT=config_flags%gwd_opt & & ,DTAUX3D=grid%dtaux3d,DTAUY3D=grid%dtauy3d & @@ -828,7 +893,18 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,XLAT_V=grid%xlat_v,XLONG_V=grid%xlong_v,FNM=grid%fnm & & ,FNP=grid%fnp, IS_CAMMGMP_USED = grid%is_CAMMGMP_used & ! for grims shallow convection with ysupbl - & ,WSTAR=grid%wstar_ysu,DELTA=grid%delta_ysu & + & ,WSTAR=grid%wstar_ysu,DELTA=grid%delta_ysu & +! for pbl mixing of scalars and tracers + & ,SCALAR=scalar,SCALAR_TEND=scalar_tend,NUM_SCALAR=num_scalar& + & ,TRACER=tracer,TRACER_TEND=tracer_tend,NUM_TRACER=num_tracer& + & ,SCALAR_PBLMIX=config_flags%scalar_pblmix & + & ,TRACER_PBLMIX=config_flags%tracer_pblmix & +#if (WRF_CHEM == 1) + & ,CHEM=chem,VD=grid%dep_vel & + & ,NCHEM=num_chem,kdvel=config_flags%kdepvel & + & ,ndvel=config_flags%ndepvel & + & ,NUM_VERT_MIX=grid%num_vert_mix & +#endif & ) @@ -854,7 +930,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & ,ids,ide, kds,kde, jds,jde & ,ims,ime, kms,kme, jms,jme & ,ips,ipe, kps,kpe, jps,jpe & - ,rho,grid%z_at_w,dz8w) + ,grid%rho,grid%z_at_w,dz8w) endif BENCH_END(fire_driver_tim) @@ -874,14 +950,16 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & BENCH_START(cu_driver_tim) CALL cumulus_driver(grid & ! Prognostic variables - & ,U=u_phy ,V=v_phy ,TH=th_phy ,T=grid%t_phy & - & ,W=grid%w_2 ,P=grid%p_hyd ,PI=pi_phy ,RHO=rho & + & ,U=grid%u_phy ,V=grid%v_phy ,TH=th_phy ,T=grid%t_phy & + & ,W=grid%w_2 ,P=grid%p_hyd ,PI=pi_phy ,RHO=grid%rho & ! Other arguments & ,ITIMESTEP=grid%itimestep ,DT=grid%dt ,DX=grid%dx & & ,CUDT=grid%cudt,CURR_SECS=curr_secs,ADAPT_STEP_FLAG=adapt_step_flag & & ,CUDTACTTIME=grid%cudtacttime & & ,RAINC=grid%rainc ,RAINCV=grid%raincv ,PRATEC=grid%pratec & & ,NCA=grid%nca & + & ,CLDFRA_DP=grid%cldfra_dp ,CLDFRA_SH=grid%cldfra_sh & ! ckay for subgrid cloud + & ,QC_CU=grid%QC_CU ,QI_CU=grid%QI_CU & & ,HTOP=grid%cutop ,HBOT=grid%cubot ,KPBL=grid%kpbl & & ,Z=grid%z ,Z_AT_W=grid%z_at_w ,MAVAIL=grid%mavail ,PBLH=grid%pblh & & ,DZ8W=dz8w ,P8W=grid%p_hyd_w, PSFC=grid%psfc, TSK=grid%tsk & @@ -940,6 +1018,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics & & ,SF_SFCLAY_PHYSICS=config_flags%sf_sfclay_physics & & ,KFETA_TRIGGER=config_flags%kfeta_trigger & + & ,NSAS_DX_FACTOR=config_flags%nsas_dx_factor & ! Dimension arguments & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & @@ -982,9 +1061,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & !$OMP PRIVATE ( ij ) DO ij = 1 , grid%num_tiles call convtrans_prep(grid%gd_cloud,grid%gd_cloud2,grid%gd_cloud_a,& - & grid%gd_cloud_b,grid%raincv,grid%raincv_a,grid%raincv_b, & + & grid%QC_CU,grid%raincv,grid%raincv_a,grid%raincv_b, & & grid%gd_cldfr,moist,p_QV,p_QC,p_qi,T_PHY,P_PHY,num_moist, & - & grid%gd_cloud2_a,grid%gd_cloud2_b,grid%convtrans_avglen_m,& + & grid%gd_cloud2_a,grid%QI_CU,grid%convtrans_avglen_m,& & adapt_step_flag,curr_secs, & & grid%itimestep,grid%dt, & & config_flags%cu_physics, & @@ -1009,8 +1088,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,J_START=grid%j_start, J_END=min(grid%j_end, jde-1) & & ,KTS=k_start, KTE=min(k_end, kde-1) & & ,NUM_TILES=grid%num_tiles & - & ,U=u_phy, V=v_phy, TH=th_phy, T=t_phy & - & ,P=grid%p_hyd, PI=pi_phy, RHO=rho, MOIST=moist & + & ,U=grid%u_phy, V=grid%v_phy, TH=th_phy, T=t_phy & + & ,P=grid%p_hyd, PI=pi_phy, RHO=grid%rho, MOIST=moist & & ,NUM_MOIST=num_moist & & ,ITIMESTEP=grid%itimestep, DT=grid%dt, DX=grid%dx & & ,CUDT=grid%cudt & @@ -1153,7 +1232,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,z=grid%z,z_at_w=grid%z_at_w & & ,th=th_phy, qv=moist(ims,kms,jms,P_QV) & & ,ql=moist(ims,kms,jms,P_QC) & - & ,u=u_phy, v=v_phy & + & ,u=grid%u_phy, v=grid%v_phy & & ,thten=grid%rthblten, qvten=grid%rqvblten & & ,qlten=grid%rqcblten & & ,uten=grid%rublten, vten=grid%rvblten & @@ -1187,7 +1266,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & q_ndg_new=fdda3d(ims,kms,jms,P_q_ndg_new), & mu_ndg_new=fdda2d(ims,1,jms,P_mu_ndg_new), & u3d=grid%u_2,v3d=grid%v_2,th_phy=th_phy, & - ph=grid%ph_2,rho=rho,moist=moist, & + ph=grid%ph_2,rho=grid%rho,moist=moist, & p_phy=p_phy,pi_phy=pi_phy,p8w=p8w,t_phy=grid%t_phy, & dz8w=dz8w,z=grid%z,z_at_w=grid%z_at_w, & grid=grid,config_flags=config_flags,dx=grid%DX,n_moist=num_moist, & diff --git a/wrfv2_fire/dyn_em/module_first_rk_step_part2.F b/wrfv2_fire/dyn_em/module_first_rk_step_part2.F index 7873d698..162e9857 100644 --- a/wrfv2_fire/dyn_em/module_first_rk_step_part2.F +++ b/wrfv2_fire/dyn_em/module_first_rk_step_part2.F @@ -20,8 +20,8 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & , adapt_step_flag , curr_secs & , psim , psih , wspd , gz1oz0 , br , chklowq & , cu_act_flag , hol , th_phy & - , pi_phy , p_phy , t_phy , u_phy , v_phy & - , dz8w , p8w , t8w , rho_phy , rho & + , pi_phy , p_phy , t_phy & + , dz8w , p8w , t8w & , nba_mij, n_nba_mij & !JDM , nba_rij, n_nba_rij & !JDM , ids, ide, jds, jde, kds, kde & @@ -58,7 +58,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & USE module_sfs_driver !JDM USE module_stoch, ONLY : update_stoch_ten, update_stoch , calculate_stoch_ten, & - do_fftback_along_x,do_fftback_along_y,sp2gp_prep + do_fftback_along_x,do_fftback_along_y,sp2gp_prep,perturb_physics_tend IMPLICIT NONE @@ -102,13 +102,9 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: pi_phy REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: p_phy REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t_phy - REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: u_phy - REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: v_phy REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: dz8w REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: p8w REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: t8w - REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho_phy - REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rho REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: ru_tendf REAL ,DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: rv_tendf @@ -162,7 +158,6 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & CALL UPDATE_STOCH(grid%SPSTREAMFORCS,grid%SPSTREAMFORCC, & grid%SPTFORCS,grid%SPTFORCC, & grid%SPT_AMP,grid%SPSTREAM_AMP, & - grid%itimestep,ij, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & grid%i_start(ij), grid%i_end(ij), grid%j_start(ij), & @@ -172,6 +167,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%SPSTREAMFORCS,grid%SPSTREAMFORCC, & grid%SPTFORCS,grid%SPTFORCC, & grid%VERTSTRUCC,grid%VERTSTRUCS, & + grid%VERTAMPT,grid%VERTAMPUV, & grid%RU_REAL,grid%RV_REAL,grid%RT_REAL, & grid%RU_IMAG,grid%RV_IMAG,grid%RT_IMAG, & grid%DX,grid%DY,grid%stoch_vertstruc_opt, & @@ -342,6 +338,8 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%rqishten,grid%rqsshten,grid%rqgshten, & grid%RUNDGDTEN,grid%RVNDGDTEN,grid%RTHNDGDTEN,grid%RQVNDGDTEN, & grid%RMUNDGDTEN, & + scalar, scalar_tend, num_scalar, & + tracer, tracer_tend, num_tracer, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & grid%i_start(ij), min(grid%i_end(ij),ide-1), & @@ -462,7 +460,8 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & # include "HALO_EM_HELICITY.inc" #endif - IF (config_flags%nwp_diagnostics .eq. 1) THEN + IF ( ( config_flags%nwp_diagnostics .eq. 1 ) .OR. & + ( ( config_flags%afwa_diag_opt .eq. 1 ) .AND. ( config_flags%afwa_severe_opt .EQ. 1 ) ) ) THEN BENCH_START(helicity_tim) !$OMP PARALLEL DO & @@ -515,6 +514,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%cf1, grid%cf2, grid%cf3, grid%warm_rain, & grid%mix_upper_bound, & grid%msftx, grid%msfty, & + grid%zx, grid%zy, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & grid%i_start(ij), grid%i_end(ij), & @@ -628,6 +628,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & IF ( config_flags%cu_physics == SASSCHEME .or. & config_flags%cu_physics == TIEDTKESCHEME .or. & config_flags%cu_physics == CAMZMSCHEME .or. & + config_flags%cu_physics == MESO_SAS .or. & config_flags%cu_physics == NSASSCHEME ) THEN # include "HALO_EM_PHYS_CU.inc" ENDIF @@ -706,6 +707,28 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & !$OMP END PARALLEL DO BENCH_END(update_phy_ten_tim) + IF (grid%stoch_force_opt== 2) then + !CASE (PERTURB_TENDF) + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + +! JB comment: P_QV is in moist_tend(ims,kms,jms,2) + DO ij = 1 , grid%num_tiles + call perturb_physics_tend(grid%gridpointvariance,& + grid%sppt_thresh_fact, grid%rt_tendf_stoch, & + ru_tendf,rv_tendf,t_tendf,moist_tend(ims,kms,jms,2), & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end ) + END DO + !$OMP END PARALLEL DO + ENDIF +BENCH_END(update_phy_ten_stoch) + + + #ifdef PLANET ! do rayleigh (and zonal-average newtonian) damping during ! first iteration of RK loop only @@ -750,7 +773,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%rdz,grid%rdzw,grid%dn, & grid%dnw,config_flags%mix_isotropic, & grid%hfx, grid%qfx, moist(ims,kms,jms,P_QV), & - grid%ustm, rho, & + grid%ustm, grid%rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & grid%i_start(ij), grid%i_end(ij), & @@ -788,9 +811,9 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%defor13,grid%defor23,grid%defor33, & nba_mij, num_nba_mij, & !JDM grid%div, moist, chem, scalar,tracer, & - grid%xkmv, grid%xkhv, config_flags%km_opt, & + grid%xkmv, grid%xkhv, grid%xkmh, config_flags%km_opt, & ! xkmh added Oct2013 grid%fnm, grid%fnp, grid%dn, grid%dnw, grid%rdz, grid%rdzw, & - grid%hfx, grid%qfx, grid%ustm, rho, & + grid%hfx, grid%qfx, grid%ustm, grid%rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & grid%i_start(ij), grid%i_end(ij), & diff --git a/wrfv2_fire/dyn_em/module_force_scm.F b/wrfv2_fire/dyn_em/module_force_scm.F index cf31eccd..9d28e0a2 100644 --- a/wrfv2_fire/dyn_em/module_force_scm.F +++ b/wrfv2_fire/dyn_em/module_force_scm.F @@ -324,7 +324,8 @@ SUBROUTINE force_scm(itimestep, dt, scm_force, dx, num_force_layers & qv_y = interp_0(qv_upstream_y,z_force,z(ids,k,jds),num_force_layers) qv_adv_tend(k) = (qv_x-qv(ids,k,jds))/adv_timescale_x(k) + (qv_y-qv(ids,k,jds))/adv_timescale_y(k) - WRITE( message, * ) 'qv_adv_tend branch 1',k,adv_timescale_x(k), qv_upstream_x(k), adv_timescale_y(k), qv_x, qv_y, qv(ids,k,jds), qv_adv_tend(k) + WRITE( message, * ) 'qv_adv_tend branch 1',k,adv_timescale_x(k), qv_upstream_x(k), adv_timescale_y(k), & + qv_x, qv_y, qv(ids,k,jds), qv_adv_tend(k) CALL wrf_debug ( 100, message ) enddo else ! WA if upstream is empty, use tendency only not value+tend @@ -333,7 +334,8 @@ SUBROUTINE force_scm(itimestep, dt, scm_force, dx, num_force_layers & qv_y = interp_0(dt*qv_upstream_y_tend,z_force,z(ids,k,jds),num_force_layers) qv_adv_tend(k) = qv_x/adv_timescale_x(k) + qv_y/adv_timescale_y(k) - WRITE( message, * ) 'qv_adv_tend branch 2',k,adv_timescale_x(k), adv_timescale_y(k), qv_upstream_x(k), qv_x, qv_y, qv(ids,k,jds), qv_adv_tend(k) + WRITE( message, * ) 'qv_adv_tend branch 2',k,adv_timescale_x(k), adv_timescale_y(k), qv_upstream_x(k), & + qv_x, qv_y, qv(ids,k,jds), qv_adv_tend(k) CALL wrf_debug ( 100, message ) enddo endif diff --git a/wrfv2_fire/dyn_em/module_initialize_b_wave.F b/wrfv2_fire/dyn_em/module_initialize_b_wave.F index 44465a22..a141ba63 100644 --- a/wrfv2_fire/dyn_em/module_initialize_b_wave.F +++ b/wrfv2_fire/dyn_em/module_initialize_b_wave.F @@ -18,6 +18,7 @@ MODULE module_initialize_ideal #ifdef DM_PARALLEL USE module_dm #endif + CHARACTER (LEN=256) , PRIVATE :: a_message CONTAINS @@ -77,7 +78,7 @@ SUBROUTINE init_domain_rk ( grid & ! Local data INTEGER, PARAMETER :: nl_max = 1000 - REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho, u, v, qv, pd_in + REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho_local, u, v, qv, pd_in INTEGER :: nl_in INTEGER :: icm,jcm, ii, im1, jj, jm1, loop, error, fid, nxc, nyc @@ -155,7 +156,8 @@ SUBROUTINE init_domain_rk ( grid & delt = 0. z_scale = .50 pi = 2.*asin(1.0) - write(6,*) ' pi is ',pi + write(a_message,*) ' pi is ',pi + call wrf_message(a_message) nxc = (ide-ids)/4 nyc = (jde-jds)/2 @@ -267,7 +269,7 @@ SUBROUTINE init_domain_rk ( grid & dry_sounding = .true. debug = .true. ! this will produce print of the sounding - CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, & + CALL get_sounding( zk, p_in, pd_in, theta, rho_local, u, v, qv, dry_sounding, & nl_max, nl_in, u_jet, rho_jet, th_jet, z_jet, & nz_jet, ny_jet, ny_jet/2, debug ) @@ -333,7 +335,7 @@ SUBROUTINE init_domain_rk ( grid & ! get sounding for this point debug = .false. ! this will turn off print of the sounding - CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, & + CALL get_sounding( zk, p_in, pd_in, theta, rho_local, u, v, qv, dry_sounding, & nl_max, nl_in, u_jet, rho_jet, th_jet, z_jet, & nz_jet, ny_jet, j, debug ) @@ -592,7 +594,7 @@ END SUBROUTINE init_module_initialize real, dimension(nz_jet,ny_jet) :: u_jet, rho_jet, & th_jet, z_jet - real, dimension(nz_jet,ny_jet) :: zk,p,p_dry,theta,rho,u,v,qv + real, dimension(nz_jet,ny_jet) :: zk,p,p_dry,theta,rho_local,u,v,qv logical :: dry, debug integer :: j, nl @@ -611,7 +613,7 @@ END SUBROUTINE init_module_initialize do j=1,ny_jet call get_sounding( zk(:,j),p(:,j),p_dry(:,j),theta(:,j), & - rho(:,j),u(:,j), v(:,j), qv(:,j), & + rho_local(:,j),u(:,j), v(:,j), qv(:,j), & dry, nz_jet, nl, u_jet, rho_jet, th_jet, & z_jet, nz_jet, ny_jet, j, debug ) debug = .false. @@ -621,8 +623,7 @@ END SUBROUTINE init_module_initialize write(6,*) ' lowest level p, th, and rho, highest level p ' do j=1,ny_jet - write(6,*) j, p(1,j),theta(1,j),rho(1,j), p(nz_jet,j) -! write(6,*) j, p(1,j),theta(1,j)-th_jet(1,j),rho(1,j)-rho_jet(1,j) + write(6,*) j, p(1,j),theta(1,j),rho_local(1,j), p(nz_jet,j) enddo call parray( p, nz_jet, ny_jet) @@ -905,9 +906,12 @@ SUBROUTINE read_input_jet( u, r, t, zk, nz, ny ) REWIND(10) read(10) ny_in,nz_in if((ny_in /= ny ) .or. (nz_in /= nz)) then - write(0,*) ' error in input jet dimensions ' - write(0,*) ' ny, ny_input, nz, nz_input ', ny, ny_in, nz,nz_in - write(0,*) ' error exit ' + write(a_message,*) ' error in input jet dimensions ' + CALL wrf_message (a_message) + write(a_message,*) ' ny, ny_input, nz, nz_input ', ny, ny_in, nz,nz_in + CALL wrf_message (a_message) + write(a_message,*) ' error exit ' + CALL wrf_message (a_message) call wrf_error_fatal ( ' error in input jet dimensions ' ) end if read(10) field_in diff --git a/wrfv2_fire/dyn_em/module_initialize_les.F b/wrfv2_fire/dyn_em/module_initialize_les.F index 61693660..7876c4cd 100644 --- a/wrfv2_fire/dyn_em/module_initialize_les.F +++ b/wrfv2_fire/dyn_em/module_initialize_les.F @@ -627,9 +627,10 @@ SUBROUTINE init_domain_rk ( grid & temp(3) = thtmp * (ptmp/p1000mb)**rcp ! For LES-CBL, add 5 degrees to the surface temperature! +! - Removed in 3.6 ! -! grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3) - grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3)+5. + grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3) +! grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3)+5. grid%tmn(I,J)=grid%tsk(I,J)-0.5 ENDDO ENDDO diff --git a/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F b/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F index bce3bac8..50e1d04d 100644 --- a/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F +++ b/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F @@ -86,7 +86,7 @@ SUBROUTINE init_domain_rk ( grid & INTEGER, PARAMETER :: nl_max = 1000 REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho, u, v, qv, pd_in - INTEGER :: nl_in + INTEGER :: nl_in , icount INTEGER :: icm,jcm, ii, im1, jj, jm1, loop, error, fid, nxc, nyc @@ -611,6 +611,46 @@ SUBROUTINE init_domain_rk ( grid & ENDDO ENDDO + ! Template for initializing trajectories. The i, j, and k starting locations + ! are specified. Right now, a small plane in the middle of the domain is + ! selected. + + grid%traj_i = -9999 + grid%traj_j = -9999 + grid%traj_k = -9999 + grid%traj_lat = -9999 + grid%traj_long = -9999 + + IF (config_flags%num_traj .gt. 0 .and. config_flags%traj_opt .gt. 0) THEN + icount = 1 + DO j = (jde + jds)/2 - 2, (jde + jds)/2 + 2, 1 + DO i = (ide + ids)/2 - 2, (ide + ids)/2 + 2, 1 + IF ( its .LE. i .and. ite .GE. i .and. jts .LE. j .and. jte .GE. j ) THEN + grid%traj_i (icount) = i + grid%traj_j (icount) = j + grid%traj_k (icount) = 10 + grid%traj_lat (icount) = grid%xlat(i,j) + grid%traj_long(icount) = grid%xlong(i,j) + END IF + +#ifdef DM_PARALLEL + grid%traj_i (icount) = wrf_dm_max_real ( grid%traj_i (icount) ) + grid%traj_j (icount) = wrf_dm_max_real ( grid%traj_j (icount) ) + grid%traj_k (icount) = wrf_dm_max_real ( grid%traj_k (icount) ) + grid%traj_lat (icount) = wrf_dm_max_real ( grid%traj_lat (icount) ) + grid%traj_long(icount) = wrf_dm_max_real ( grid%traj_long(icount) ) +#endif + + icount = icount + 1 + IF (icount .GT. config_flags%num_traj) THEN + EXIT + END IF + END DO + END DO + END IF + + + END SUBROUTINE init_domain_rk SUBROUTINE init_module_initialize diff --git a/wrfv2_fire/dyn_em/module_initialize_real.F b/wrfv2_fire/dyn_em/module_initialize_real.F index 681a130d..90ec96f1 100644 --- a/wrfv2_fire/dyn_em/module_initialize_real.F +++ b/wrfv2_fire/dyn_em/module_initialize_real.F @@ -18,6 +18,7 @@ MODULE module_initialize_real USE module_soil_pre USE module_date_time USE module_llxy + USE module_polarfft #ifdef DM_PARALLEL USE module_dm USE module_comm_dm, ONLY : & @@ -117,6 +118,8 @@ SUBROUTINE init_domain_rk ( grid & REAL , DIMENSION(max_eta) :: eta_levels REAL :: max_dz + REAL :: dclat + ! INTEGER , PARAMETER :: nl_max = 1000 ! REAL , DIMENSION(nl_max) :: grid%dn @@ -151,6 +154,7 @@ SUBROUTINE init_domain_rk ( grid & REAL , DIMENSION(100) :: lqmi REAL :: t_start , t_end + REAL , ALLOCATABLE , DIMENSION(:,:) :: clat_glob ! Dimension information stored in grid data structure. @@ -168,6 +172,41 @@ SUBROUTINE init_domain_rk ( grid & CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + ! Lake Mask and depth assignment + + CALL nl_get_iswater ( grid%id , grid%iswater ) + CALL nl_get_islake ( grid%id , grid%islake ) + + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( grid%lu_index(i,j) .NE. grid%islake ) THEN + grid%lakemask(i,j) = 0 + ELSE + grid%lakemask(i,j) = 1 + END IF + END DO + END DO + + IF ( grid%sf_lake_physics .EQ. 1 ) THEN + grid%lake_depth_flag = flag_lake_depth + IF ( flag_lake_depth .EQ. 0 ) THEN + CALL wrf_message ( " Warning: Please rerun WPS to get lake_depth information for lake model" ) + + ! Set lake depth over the ocean to be -2 m, and set the lake depth over land to be -1 m. + + ELSE + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + IF ( ( grid%lu_index(i,j) .NE. grid%islake ) .AND. ( grid%lu_index(i,j) .NE. grid%iswater ) ) THEN + grid%lake_depth(i,j) = -1 + ELSE IF ( grid%lu_index(i,j) .NE. grid%islake ) THEN + grid%lake_depth(i,j) = -2 + END IF + END DO + END DO + END IF + END IF + ! Send out a quick message about the time steps based on the map scale factors. IF ( ( internal_time_loop .EQ. 1 ) .AND. ( grid%id .EQ. 1 ) .AND. & @@ -232,7 +271,6 @@ SUBROUTINE init_domain_rk ( grid & ( config_flags%grid_fdda .NE. 0 ) .OR. & ( config_flags%sst_update .EQ. 1 ) .OR. & ( config_flags%all_ic_times ) .OR. & - ( config_flags%smooth_cg_topo ) .OR. & ( config_flags%map_proj .EQ. PROJ_CASSINI ) ! There are a few checks that we need to do when the input data comes in with the middle @@ -522,13 +560,29 @@ SUBROUTINE init_domain_rk ( grid & ! in the model betwixt the CG and FG domains. IF ( ( config_flags%smooth_cg_topo ) .AND. & + ( internal_time_loop .EQ. 1 ) .AND. & ( grid%id .EQ. 1 ) .AND. & ( flag_soilhgt .EQ. 1) ) THEN CALL blend_terrain ( grid%toposoil , grid%ht , & ids , ide , jds , jde , 1 , 1 , & ims , ime , jms , jme , 1 , 1 , & ips , ipe , jps , jpe , 1 , 1 ) + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%ht_smooth(i,j) = grid%ht(i,j) + END DO + END DO + ELSE IF ( ( config_flags%smooth_cg_topo ) .AND. & + ( internal_time_loop .NE. 1 ) .AND. & + ( grid%id .EQ. 1 ) .AND. & + ( flag_soilhgt .EQ. 1) ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%ht(i,j) = grid%ht_smooth(i,j) + END DO + END DO + END IF ! Filter the input topography if this is a polar projection. @@ -538,6 +592,65 @@ SUBROUTINE init_domain_rk ( grid & END IF IF ( config_flags%map_proj .EQ. PROJ_CASSINI ) THEN +#if 1 + dclat = 90./REAL(jde-jds) !(0.5 * 180/ny) + DO j = jts, MIN(jte,jde-1) + DO k = kts, kte + DO i = its, MIN(ite,ide-1) + grid%t_2(i,k,j) = 1. + END DO + END DO + DO i = its, MIN(ite,ide-1) + grid%t_2(i,1,j) = grid%ht(i,j) + grid%sr(i,j) = grid%ht(i,j) + END DO + END DO +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) +! WARNING: this might present scaling issues on very large numbers of processors + ALLOCATE( clat_glob(ids:ide,jds:jde) ) + + CALL wrf_patch_to_global_real ( grid%clat, clat_glob, grid%domdesc, 'xy', 'xy', & + ids, ide, jds, jde, 1, 1, & + ims, ime, jms, jme, 1, 1, & + its, ite, jts, jte, 1, 1 ) + + CALL wrf_dm_bcast_real ( clat_glob , (ide-ids+1)*(jde-jds+1) ) + + grid%clat_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex) + + DEALLOCATE( clat_glob ) +#endif + + CALL pxft ( grid=grid & + ,lineno=__LINE__ & + ,flag_uv = 0 & + ,flag_rurv = 0 & + ,flag_wph = 0 & + ,flag_ww = 0 & + ,flag_t = 1 & + ,flag_mu = 0 & + ,flag_mut = 0 & + ,flag_moist = 0 & + ,flag_chem = 0 & + ,flag_tracer = 0 & + ,flag_scalar = 0 & + ,positive_definite = .FALSE. & + ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & + ,fft_filter_lat = config_flags%fft_filter_lat & + ,dclat = dclat & + ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & + ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & + ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe & + ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & + ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%ht(i,j) = grid%t_2(i,1,j) + grid%sr(i,j) = grid%sr(i,j) - grid%ht(i,j) + END DO + END DO + +#else #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) ! We stick the topo and map fac in an unused 3d array. The map scale @@ -606,6 +719,7 @@ SUBROUTINE init_domain_rk ( grid & ids, ide, jds, jde, 1,1, & ims, ime, jms, jme, 1,1, & its, ite, jts, jte, 1,1 ) +#endif #endif END IF @@ -929,6 +1043,13 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) + IF ( config_flags%rdlai2d ) THEN + CALL monthly_interp_to_date ( grid%lai12m , current_date , grid%lai , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + ENDIF + ! Get the min/max of each i,j for the monthly green-ness fraction. CALL monthly_min_max ( grid%greenfrac , grid%shdmin , grid%shdmax , & @@ -961,6 +1082,81 @@ SUBROUTINE init_domain_rk ( grid & END DO END DO + ! Added by G. Thompson 2013Sep10 + ! Interpolate monthly aerosol climatology data to specific date/time. + ! Since data are 3D, do over a loop of vertical levels using temporary array space. + + IF (config_flags%mp_physics.eq.THOMPSONAERO .and. P_QNWFA.gt.1 .and. config_flags%use_aero_icbc) then + CALL wrf_debug ( 0 , 'Using Thompson_aerosol_aware so using QNWFA monthly climo arrays to create QNWFA_now') + DO k = 1, num_metgrid_levels + WRITE(a_message,*) ' transferring each K-level ', k, ' to qntemp, sample Jan data, ', grid%QNWFA_jan(10,k,10) + CALL wrf_debug ( 0 , a_message) + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%qntemp(i, 1, j) = grid%QNWFA_jan(i,k,j) + grid%qntemp(i, 2, j) = grid%QNWFA_feb(i,k,j) + grid%qntemp(i, 3, j) = grid%QNWFA_mar(i,k,j) + grid%qntemp(i, 4, j) = grid%QNWFA_apr(i,k,j) + grid%qntemp(i, 5, j) = grid%QNWFA_may(i,k,j) + grid%qntemp(i, 6, j) = grid%QNWFA_jun(i,k,j) + grid%qntemp(i, 7, j) = grid%QNWFA_jul(i,k,j) + grid%qntemp(i, 8, j) = grid%QNWFA_aug(i,k,j) + grid%qntemp(i, 9, j) = grid%QNWFA_sep(i,k,j) + grid%qntemp(i,10, j) = grid%QNWFA_oct(i,k,j) + grid%qntemp(i,11, j) = grid%QNWFA_nov(i,k,j) + grid%qntemp(i,12, j) = grid%QNWFA_dec(i,k,j) + ENDDO + ENDDO + if (k.eq.1) then + write(a_message,*) ' DEBUG-GT qntemp(10,jan-feb,10) ', grid%qntemp(10, 1, 10),grid%qntemp(10, 2, 10) + CALL wrf_debug ( 0 , a_message) + endif + CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + if (k.eq.1) then + write(a_message,*) ' DEBUG-GT qntemp2(10,10) ', grid%qntemp2(10,10) + CALL wrf_debug ( 0 , a_message) + endif + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%QNWFA_now(i,k,j) = grid%qntemp2(i,j) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (config_flags%mp_physics.eq.THOMPSONAERO .and. P_QNIFA.gt.1 .and. config_flags%use_aero_icbc) then + DO k = 1, num_metgrid_levels + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%qntemp(i, 1, j) = grid%QNIFA_jan(i,k,j) + grid%qntemp(i, 2, j) = grid%QNIFA_feb(i,k,j) + grid%qntemp(i, 3, j) = grid%QNIFA_mar(i,k,j) + grid%qntemp(i, 4, j) = grid%QNIFA_apr(i,k,j) + grid%qntemp(i, 5, j) = grid%QNIFA_may(i,k,j) + grid%qntemp(i, 6, j) = grid%QNIFA_jun(i,k,j) + grid%qntemp(i, 7, j) = grid%QNIFA_jul(i,k,j) + grid%qntemp(i, 8, j) = grid%QNIFA_aug(i,k,j) + grid%qntemp(i, 9, j) = grid%QNIFA_sep(i,k,j) + grid%qntemp(i,10, j) = grid%QNIFA_oct(i,k,j) + grid%qntemp(i,11, j) = grid%QNIFA_nov(i,k,j) + grid%qntemp(i,12, j) = grid%QNIFA_dec(i,k,j) + ENDDO + ENDDO + CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%QNIFA_now(i,k,j) = grid%qntemp2(i,j) + ENDDO + ENDDO + ENDDO + ENDIF + ! Two ways to get the surface pressure. 1) If we have the low-res input surface ! pressure and the low-res topography, then we can do a simple hydrostatic ! relation. 2) Otherwise we compute the surface pressure from the sea-level @@ -1367,6 +1563,65 @@ SUBROUTINE init_domain_rk ( grid & END DO END IF +!..If we have number of water-friendly aerosols from monthly climo data, interpolate to WRF model levels. + WRITE(a_message,*) ' flag value of flag_qnwfa is ', flag_qnwfa + CALL wrf_debug ( 0 , a_message) + IF ( flag_qnwfa .EQ. 1 .and. config_flags%use_aero_icbc) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_s + IF ( im .EQ. P_QNWFA ) THEN + CALL wrf_debug ( 0 , 'Using Thompson_aerosol_aware so vertically-interpolating QNWFA monthly climo arrays to fill scalar') + CALL vert_interp ( grid%QNWFA_now , grid%pd_gc , scalar(:,:,:,P_QNWFA) , grid%pb , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , & + lowest_lev_from_sfc , use_levels_below_ground , use_surface , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + END DO + ELSEIF ( flag_qnwfa .EQ. 1 .and. (.NOT. config_flags%use_aero_icbc)) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_s + IF ( im .EQ. P_QNWFA ) THEN + DO j = jts, MIN(jte,jde-1) + DO k = kts, kte + DO i = its, MIN(ite,ide-1) + scalar(i,k,j,P_QNWFA) = 0. + END DO + END DO + END DO + END IF + END DO + END IF + +!..If we have number of ice-friendly aerosols from monthly climo data, interpolate to WRF model levels. + IF ( flag_qnifa .EQ. 1 .and. config_flags%use_aero_icbc) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_s + IF ( im .EQ. P_QNIFA ) THEN + CALL vert_interp ( grid%QNIFA_now , grid%pd_gc , scalar(:,:,:,P_QNIFA) , grid%pb , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , & + lowest_lev_from_sfc , use_levels_below_ground , use_surface , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF + END DO + ELSEIF ( flag_qnifa .EQ. 1 .and. (.NOT. config_flags%use_aero_icbc)) THEN + DO im = PARAM_FIRST_SCALAR, num_3d_s + IF ( im .EQ. P_QNIFA ) THEN + DO j = jts, MIN(jte,jde-1) + DO k = kts, kte + DO i = its, MIN(ite,ide-1) + scalar(i,k,j,P_QNIFA) = 0. + END DO + END DO + END DO + END IF + END DO + END IF + ! If this is UM data, put the dry rho-based pressure back into the dry pressure array. ! Since the dry pressure is no longer needed, no biggy. @@ -1420,7 +1675,9 @@ SUBROUTINE init_domain_rk ( grid & CALL nl_get_iswater ( grid%id , grid%iswater ) CALL nl_get_islake ( grid%id , grid%islake ) + IF ( grid%islake < 0 ) THEN + grid%lakeflag=0 CALL wrf_debug ( 0 , 'Old data, no inland lake information') DO j=jts,MIN(jde-1,jte) @@ -1441,6 +1698,7 @@ SUBROUTINE init_domain_rk ( grid & END DO END DO ELSE + grid%lakeflag=1 IF ( we_have_tavgsfc ) THEN CALL wrf_debug ( 0 , 'Using inland lakes with average surface temperature') @@ -1729,6 +1987,7 @@ SUBROUTINE init_domain_rk ( grid & ! Make all the veg/soil parms the same so as not to confuse the developer. + DO j = jts , MIN(jde-1,jte) DO i = its , MIN(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE @@ -1795,6 +2054,7 @@ SUBROUTINE init_domain_rk ( grid & ! Adjustments for the seaice field PRIOR to the grid%tslb computations. This is ! is for the 5-layer scheme. + num_veg_cat = SIZE ( grid%landusef , DIM=2 ) num_soil_top_cat = SIZE ( grid%soilctop , DIM=2 ) num_soil_bot_cat = SIZE ( grid%soilcbot , DIM=2 ) @@ -1935,7 +2195,21 @@ SUBROUTINE init_domain_rk ( grid & ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then print *,'Noah -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j) iicount = iicount + 1 + grid%smois(i,:,j) = 0.005 +!+---+-----------------------------------------------------------------+ +! Some bad values of soil moisture are possible (huge negative and positive), but they +! appear to occur only along coastlines, so instead of overwriting with small moisture +! values, use relatively large moisture val. Orig code checked for large negative but +! not positive values, mods here reset either. G. Thompson (28 Feb 2008). + +! grid%smois(i,:,j) = 0.499 +! ELSEIF ( (grid%landmask(i,j).gt.0.5) .and. (grid%tslb(i,1,j) .gt. 170 ) .and. & +! ( grid%tslb(i,1,j) .lt. 400 ) .and. (grid%smois(i,1,j) .gt. 1.005 ) ) then +! print *,'Noah -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j) +! iicount = iicount + 1 +! grid%smois(i,:,j) = 0.499 +!+---+-----------------------------------------------------------------+ END IF END DO END DO @@ -1957,7 +2231,16 @@ SUBROUTINE init_domain_rk ( grid & ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then print *,'RUC -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j) iicount = iicount + 1 - grid%smois(i,:,j) = 0.005 +! grid%smois(i,:,j) = 0.005 +!+---+-----------------------------------------------------------------+ +! Same comment as above. + grid%smois(i,:,j) = 0.499 + ELSEIF ( (grid%landmask(i,j).gt.0.5) .and. (grid%tslb(i,1,j) .gt. 170 ) .and. & + ( grid%tslb(i,1,j) .lt. 400 ) .and. (grid%smois(i,1,j) .gt. 1.005 ) ) then + print *,'Noah -> Noah: bad soil moisture at i,j =',i,j,grid%smois(i,:,j) + iicount = iicount + 1 + grid%smois(i,:,j) = 0.499 +!+---+-----------------------------------------------------------------+ END IF END DO END DO @@ -1966,6 +2249,25 @@ SUBROUTINE init_domain_rk ( grid & END IF END IF +!+---+-----------------------------------------------------------------+ + ! Fudge soil moisture higher where canopy water is non-zero. + ! G. Thompson (12 Jun 2008) + +! DO j = jts, MIN(jte,jde-1) +! DO i = its, MIN(ite,ide-1) +! IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE +! if (grid%canwat(i,j) .GT. 1.01 .AND. grid%landmask(i,j) .GT. 0.5 ) THEN +! print *,' CANWAT: moisten soil a bit more at i,j =',i,j,grid%canwat(i,j) +! grid%smois(i,1,j) = grid%smois(i,1,j) + (grid%canwat(i,j)**0.33333)*0.04 +! grid%smois(i,1,j) = MIN(0.499, grid%smois(i,1,j)) +! grid%smois(i,2,j) = grid%smois(i,2,j) + (grid%canwat(i,j)**0.33333)*0.01 +! grid%smois(i,2,j) = MIN(0.499, grid%smois(i,2,j)) +! end if +! END DO +! END DO +!+---+-----------------------------------------------------------------+ + + CASE ( RUCLSMSCHEME ) iicount = 0 IF ( flag_soil_layers == 1 ) THEN @@ -2348,6 +2650,15 @@ SUBROUTINE init_domain_rk ( grid & END DO END DO +!+---+-----------------------------------------------------------------+ + ! New addition by Greg Thompson to dry out the stratosphere. +! CALL wrf_debug ( 0 , ' calling routine to dry stratosphere') +! CALL dry_stratos ( grid%t_2, moist(:,:,:,P_QV), grid%phb, & +! ids , ide , jds , jde , kds , kde , & +! ims , ime , jms , jme , kms , kme , & +! its , ite , jts , jte , kts , kte ) +!+---+-----------------------------------------------------------------+ + ! Fill in the outer rows and columns to allow us to be sloppy. IF ( ite .EQ. ide ) THEN @@ -2667,6 +2978,29 @@ SUBROUTINE init_domain_rk ( grid & ! Set flag to denote that we are saving original values of HT, MUB, and ! PHB for 2-way nesting and cycling. + grid%save_topo_from_real=1 + + ! Template for initializing tracer arrays. + ! Right now, a small plane in the middle of the domain at lowest model level is + ! defined. + + IF (config_flags%tracer_opt .eq. 2) THEN + DO j = (jde + jds)/2 - 4, (jde + jds)/2 + 4, 1 + DO i = (ide + ids)/2 - 4, (ide + ids)/2 + 4, 1 + tracer(i, 1, j, im) = 1. + IF ( its .LE. i .and. ite .GE. i .and. jts .LE. j .and. jte .GE. j ) THEN + tracer(i, 1, j, P_tr17_1) = 1. + tracer(i, 1, j, P_tr17_2) = 1. + tracer(i, 1, j, P_tr17_3) = 1. + tracer(i, 1, j, P_tr17_4) = 1. +! tracer(i, 1, j, P_tr17_5) = 1. +! tracer(i, 1, j, P_tr17_6) = 1. +! tracer(i, 1, j, P_tr17_7) = 1. +! tracer(i, 1, j, P_tr17_8) = 1. + END IF + END DO + END DO + END IF ! Template for initializing trajectories. The i, j, and k starting locations ! are specified. Right now, a small plane in the middle of the domain is @@ -2758,11 +3092,24 @@ SUBROUTINE init_domain_rk ( grid & END IF END IF - - - grid%save_topo_from_real=1 ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte + +!+---+-----------------------------------------------------------------+ + ! Added by Greg Thompson. Pre-set snow depth by latitude, elevation, and day-of-year. + +! CALL wrf_debug ( 0 , ' calling routine to add snow in high mountain peaks') +! DO j = jts, min(jde-1,jte) +! DO i = its, min(ide-1,ite) +! IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE +! grid%snowh(i,j) = snowHires (grid%snowh(i,j), grid%xlat(i,j), grid%ht(i,j), current_date, i,j) +! grid%snow(i,j) = grid%snowh(i,j) * 1000. / 5. +! END DO +! END DO +! CALL wrf_debug ( 0 , ' DONE routine to add snow in high mountain peaks') +!+---+-----------------------------------------------------------------+ + + #ifdef DM_PARALLEL # include "HALO_EM_INIT_1.inc" # include "HALO_EM_INIT_2.inc" @@ -3965,7 +4312,7 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & ! the isobaric original field has the surface from 2-m T and RH, and 10-m U and V). IF ( lowest_lev_from_sfc ) THEN - fnew(i,1,j) = forig(i,ko_above_sfc(i)-1,j) + fnew(i,1,j) = forig(i,1,j) END IF END DO @@ -4391,6 +4738,12 @@ SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n REAL , DIMENSION(target_dim) , INTENT(IN) :: target_x REAL , DIMENSION(target_dim) , INTENT(OUT) :: target_y +! cubic spline defs + INTEGER :: K + REAL :: DX, ALPHA, BETA, GAMMA, ETA + REAL , DIMENSION(all_dim) :: P2 +! cubic spline defs + ! Brought in for debug purposes, all of the computations are in a single column. INTEGER , INTENT(IN) :: i,j @@ -4523,7 +4876,28 @@ SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n ! an odd order interpolator. For the even guys, we'll do it twice ! and shift the range one index, then get an average. - IF ( MOD(n,2) .NE. 0 ) THEN +! cubic spline + IF ( n .EQ. 9 ) THEN + CALL cubic_spline (all_dim-1, all_x, all_y, P2) +! +! Find the value of function f(x) +! + DX = all_x(loc_center_right) - all_x(loc_center_left) + ALPHA = P2(loc_center_right)/(6*DX) + BETA = -P2(loc_center_left)/(6*DX) + GAMMA = all_y(loc_center_right)/DX - DX*P2(loc_center_right)/6 + ETA = DX*P2(loc_center_left)/6 - all_y(loc_center_left)/DX + target_y(target_loop) = ALPHA*(target_x(target_loop)-all_x(loc_center_left))*(target_x(target_loop)-all_x(loc_center_left)) & + *(target_x(target_loop)-all_x(loc_center_left)) & + +BETA*(target_x(target_loop)-all_x(loc_center_right))*(target_x(target_loop)-all_x(loc_center_right)) & + *(target_x(target_loop)-all_x(loc_center_right)) & + +GAMMA*(target_x(target_loop)-all_x(loc_center_left)) & + +ETA*(target_x(target_loop)-all_x(loc_center_right)) + +! IF ( MOD(n,2) .NE. 0 ) THEN +! end cubic spline block + + ELSE IF ( MOD(n,2) .NE. 0 ) THEN IF ( ( loc_center_left -(((n+1)/2)-1) .GE. 1 ) .AND. & ( loc_center_right+(((n+1)/2)-1) .LE. all_dim ) ) THEN ist = loc_center_left -(((n+1)/2)-1) @@ -4574,6 +4948,89 @@ SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n END SUBROUTINE lagrange_setup +!--------------------------------------------------------------------- + +! cubic spline routines + + SUBROUTINE cubic_spline (N, XI, FI, P2) + ! + ! Function to carry out the cubic-spline approximation + ! with the second-order derivatives returned. + ! + INTEGER :: I + INTEGER, INTENT (IN) :: N + REAL, INTENT (IN), DIMENSION (N):: XI, FI + REAL, INTENT (OUT), DIMENSION (N):: P2 + REAL, DIMENSION (N):: G, H + REAL, DIMENSION (N-1):: D, B, C +! +! Assign the intervals and function differences +! + DO I = 1, N + H(I) = XI(I+1) - XI(I) + G(I) = FI(I+1) - FI(I) + END DO +! +! Evaluate the coefficient matrix elements + DO I = 1, N-1 + D(I) = 2*(H(I+1)+H(I)) + B(I) = 6*(G(I+1)/H(I+1)-G(I)/H(I)) + C(I) = H(I+1) + END DO +! +! Obtain the second-order derivatives +! + CALL TRIDIAGONAL_LINEAR_EQ (N-1, D, C, C, B, G) + P2(1) = 0 + P2(N+1) = 0 + DO I = 2, N + P2(I) = G(I-1) + END DO + +END SUBROUTINE cubic_spline + +!--------------------------------------------------------------------- + + SUBROUTINE TRIDIAGONAL_LINEAR_EQ (L, D, E, C, B, Z) +! +! Function to solve the tridiagonal linear equation set. +! + INTEGER, INTENT (IN) :: L + INTEGER :: I + REAL, INTENT (IN), DIMENSION (L):: D, E, C, B + REAL, INTENT (OUT), DIMENSION (L):: Z + REAL, DIMENSION (L):: Y, W + REAL, DIMENSION (L-1):: V, T +! +! Evaluate the elements in the LU decomposition +! + W(1) = D(1) + V(1) = C(1) + T(1) = E(1)/W(1) + DO I = 2, L - 1 + W(I) = D(I)-V(I-1)*T(I-1) + V(I) = C(I) + T(I) = E(I)/W(I) + END DO + W(L) = D(L)-V(L-1)*T(L-1) +! +! Forward substitution to obtain y +! + Y(1) = B(1)/W(1) + DO I = 2, L + Y(I) = (B(I)-V(I-1)*Y(I-1))/W(I) + END DO +! +! Backward substitution to obtain z + Z(L) = Y(L) + DO I = L-1, 1, -1 + Z(I) = Y(I) - T(I)*Z(I+1) + END DO + +END SUBROUTINE TRIDIAGONAL_LINEAR_EQ + +! end cubic spline routines + !--------------------------------------------------------------------- SUBROUTINE lagrange_interp ( x , y , n , target_x , target_y ) @@ -6419,6 +6876,123 @@ END SUBROUTINE filter_topo !--------------------------------------------------------------------- + +!+---+-----------------------------------------------------------------+ +! Begin addition by Greg Thompson to dry out the stratosphere. +! Starting 3 levels below model top, go downward and search for where +! Theta gradient over three K-levels is less steep than +10 K per 1500 m. +! This threshold approximates a vertical line on a skew-T chart from +! approximately 300 to 240 mb, anything more unstable than this reference +! is probably in the troposphere so pick the K plus 1 point as the +! tropopause and set mixing ratio to a really small values above. +!..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 +!..Last modified: 30 Dec 2004 +!+---+-----------------------------------------------------------------+ + + subroutine dry_stratos ( theta, qv, phb, & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: theta, phb + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: qv + + ! Local vars + + INTEGER :: i, j, k, kk, istart, iend, jstart, jend, kstart, kend + REAL :: ht1, ht2, theta1, theta2, htz, sat85, p_std_atmos + CHARACTER*256:: str_debug + ! Saturation vapor pressure at T = -85C. + DATA sat85 /0.0235755574/ + + do i = 1, 256 + str_debug(i:i) = char(0) + enddo + + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = MIN(jde-1,jte) + kstart = kts + kend = kte-1 + DO j = jstart, jend + DO i = istart, iend + DO k = kend-3, kstart, -1 + ht1 = phb(i,k,j)/9.8 + ht2 = phb(i,k+2,j)/9.8 + theta1 = theta(i,k,j) + theta2 = theta(i,k+2,j) + if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. (ht1.gt.4000.) ) then + DO kk = k+3, kend + htz = phb(i,kk,j)/9.8 + p_std_atmos = exp(log(1.0-htz/44307.692)/0.19)*101325.0 + qv(i,kk,j) = 0.622*sat85/(p_std_atmos-sat85) + END DO + goto 79 + end if + END DO + 79 continue + END DO + END DO + + END SUBROUTINE dry_stratos + +!+---+-----------------------------------------------------------------+ +!..Hardwire snow cover above a pre-specified altitude. +!.. Starting altitude for snow (snow_startz) depends on latitude +!.. and is 3900 m at 35-deg lowering to 250km (linearly) by 65-deg lat. +!.. Alter WEASD linear function from 0 at snow_startz to 999 mm at 4 km. +!.. Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 +!.. Last modified: 27 Dec 2008 +!+---+-----------------------------------------------------------------+ + + real function snowHires (snow_in, latitude, elev, date_str, i,j) + IMPLICIT NONE + + REAL, INTENT(IN):: latitude, elev, snow_in + INTEGER, INTENT(IN):: i, j + CHARACTER (LEN=24), INTENT(IN) :: date_str + + REAL :: snow_startz, del_lat, season_factor, snow_out + REAL :: gmt + INTEGER :: day_peak, day_of_year, julyr + CHARACTER (LEN=256) :: dbg_msg + + CALL get_julgmt ( date_str , julyr , day_of_year , gmt ) + + if (latitude .gt. 0.0) then + del_lat = (65.-latitude)/(65.-35.) + day_peak = 80 + else + del_lat = (-65.-latitude)/(-65.+35.) + day_peak = 264 + endif + + snow_startz = (3900.-250.)*del_lat + 250. + snow_startz = max(250., min(3900., snow_startz)) + + season_factor = 1. + snow_out = 0. + IF (elev .GT. snow_startz) THEN + season_factor = ABS(COS((day_of_year - day_peak)*0.5*0.0174533)) + snow_out = 0.999*(elev-snow_startz)/(4000.-snow_startz) + write(dbg_msg,*) 'DEBUG_GT_SNOW ', day_of_year, latitude, elev, snow_in, snow_startz, season_factor, snow_out,i, j + CALL wrf_debug (150, dbg_msg) + ENDIF + + snowHires = MAX(snow_in, season_factor * snow_out) + + END FUNCTION snowHires + +!+---+-----------------------------------------------------------------+ + + SUBROUTINE init_module_initialize END SUBROUTINE init_module_initialize diff --git a/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F b/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F index 50ac890a..561bca3f 100644 --- a/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F +++ b/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F @@ -288,8 +288,10 @@ SUBROUTINE init_domain_rk ( grid & IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz) DO k=1, kde - grid%znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & - (1.-exp(-1./z_scale)) +! grid%znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & +! (1.-exp(-1./z_scale)) +! read eta_levels from namelist (replace with commented code above if not) + grid%znw(k) = model_config_rec%eta_levels(k) ENDDO ELSE DO k=1, kde @@ -594,6 +596,14 @@ SUBROUTINE init_domain_rk ( grid & DO K = kts, kte-1 DO I = its, min(ide-1,ite) grid%h_diabatic(i,k,j) = 0. + if(k.eq.kts)tracer(i,k,j,p_tr17_1)=1. + if(k.eq.kts.and.grid%xland(i,j).lt.1.5)tracer(i,k,j,p_tr17_2)=1. + if(k.eq.kts.and.grid%xland(i,j).gt.1.5)tracer(i,k,j,p_tr17_3)=1. + if(k.le.5)tracer(i,k,j,p_tr17_4)=1. + if(k.le.5.and.grid%xland(i,j).lt.1.5)tracer(i,k,j,p_tr17_5)=1. + if(k.le.5.and.grid%xland(i,j).gt.1.5)tracer(i,k,j,p_tr17_6)=1. + if(k.le.10)tracer(i,k,j,p_tr17_7)=1. + if(k.le.10.and.k.gt.5)tracer(i,k,j,p_tr17_8)=1. ENDDO ENDDO ENDDO diff --git a/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F b/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F index df42dd92..0b8f8d1b 100644 --- a/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F +++ b/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F @@ -101,6 +101,7 @@ SUBROUTINE init_domain_rk ( grid & real*8 :: rmax,vmax,frac,angle real, dimension(:), allocatable :: rref,zref,th0,qv0,thv0,prs0,pi0,rh0 real, dimension(:,:), allocatable :: vref,piref,pref,thref,thvref,qvref + real :: pi_in,dz ! stuff from original initialization that has been dropped from the Registry REAL :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd, zt @@ -549,9 +550,13 @@ SUBROUTINE init_domain_rk ( grid & rref(i) = config_flags%dx*(float(i-1)+0.5) enddo - print *,' zref:' + print *,' zref,dz:' do k=0,kref+1 - print *,k,zref(k) + if( k.ge.2 .and. k.le.kref )then + print *,k,zref(k),zref(k)-zref(k-1) + else + print *,k,zref(k) + endif enddo print *,' vref:' @@ -667,12 +672,20 @@ SUBROUTINE init_domain_rk ( grid & i1 = i2-1 frac = ( rr-rref(i1)) & /(rref(i2)-rref(i1)) - do k=1,kte - px = p0*( ( pi0(k)+piref(i1,k)+(piref(i2,k)-piref(i1,k))*frac )**(cp/r_d) ) - qx = qvref(i1,k)+(qvref(i2,k)-qvref(i1,k))*frac - qv(k) = qx + do k=1,nl_in + pi_in = pi0(k)+piref(i1,k)+(piref(i2,k)-piref(i1,k))*frac + qv(k) = qvref(i1,k)+(qvref(i2,k)-qvref(i1,k))*frac theta(k) = th0(k)+thref(i1,k)+(thref(i2,k)-thref(i1,k))*frac - pd_in(k) = px/(1.0+((r_v/r_d)*qx)) + p_in(k) = p1000mb*(pi_in**(cp/r_d)) + qvf = 1. + rvovrd*qv(k) + rho(k) = 1./((r_d/p1000mb)*theta(k)*qvf*((p_in(k)/p1000mb)**cvpm)) + enddo + + pd_in(nl_in) = p_in(nl_in) + + do k=nl_in-1,1,-1 + dz = zk(k+1)-zk(k) + pd_in(k) = pd_in(k+1) + 0.5*dz*(rho(k)+rho(k+1))*g enddo ! At this point grid%p_top is already set. find the DRY mass in the column diff --git a/wrfv2_fire/dyn_em/module_polarfft.F b/wrfv2_fire/dyn_em/module_polarfft.F index 5ca3bf1d..21c645f6 100644 --- a/wrfv2_fire/dyn_em/module_polarfft.F +++ b/wrfv2_fire/dyn_em/module_polarfft.F @@ -2,6 +2,7 @@ MODULE module_polarfft USE module_model_constants USE module_wrf_error + CHARACTER (LEN=256) , PRIVATE :: a_message CONTAINS @@ -135,6 +136,7 @@ SUBROUTINE pxft ( grid & ! Local LOGICAL piggyback_mu, piggyback_mut INTEGER ij, k_end + #ifdef DM_PARALLEL #else INTEGER itrace @@ -190,34 +192,42 @@ SUBROUTINE pxft ( grid & ENDIF #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) # include "XPOSE_POLAR_FILTER_V_z2x.inc" + CALL polar_filter_3d( grid%v_xxx, grid%clat_xxx, .false., & fft_filter_lat, dclat, & ids, ide, jds, jde, kds, kde-1, & imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, MIN(kde-1,kpex ) ) + # include "XPOSE_POLAR_FILTER_V_x2z.inc" # include "XPOSE_POLAR_FILTER_U_z2x.inc" k_end = MIN(kde-1,kpex) IF ( piggyback_mu ) k_end = MIN(kde,kpex) + CALL polar_filter_3d( grid%u_xxx, grid%clat_xxx, piggyback_mu, & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, k_end ) + # include "XPOSE_POLAR_FILTER_U_x2z.inc" #else + CALL polar_filter_3d( grid%v_2, grid%clat, .false., & fft_filter_lat, dclat, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, MIN(kde-1,kpe) ) + k_end = MIN(kde-1,kpe) IF ( piggyback_mu ) k_end = MIN(kde,kpe) + CALL polar_filter_3d( grid%u_2, grid%clat, piggyback_mu, & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde-1, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, k_end ) + #endif IF ( piggyback_mu ) THEN @@ -236,20 +246,24 @@ SUBROUTINE pxft ( grid & # include "XPOSE_POLAR_FILTER_T_z2x.inc" k_end = MIN(kde-1,kpex) IF ( piggyback_mu ) k_end = MIN(kde,kpex) + CALL polar_filter_3d( grid%t_xxx, grid%clat_xxx,piggyback_mu, & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde-1, & imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, k_end ) + # include "XPOSE_POLAR_FILTER_T_x2z.inc" #else k_end = MIN(kde-1,kpe) IF ( piggyback_mu ) k_end = MIN(kde,kpe) + CALL polar_filter_3d( grid%t_2, grid%clat, piggyback_mu, & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde-1, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, k_end ) + #endif IF ( piggyback_mu ) THEN grid%mu_2(ips:ipe,jps:jpe) = grid%t_2(ips:ipe,kde,jps:jpe) @@ -268,20 +282,25 @@ SUBROUTINE pxft ( grid & ids, ide, jds, jde, kds, kde, & imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, kpex ) + # include "XPOSE_POLAR_FILTER_W_x2z.inc" # include "XPOSE_POLAR_FILTER_PH_z2x.inc" + CALL polar_filter_3d( grid%ph_xxx, grid%clat_xxx, .false., & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, kpex ) + # include "XPOSE_POLAR_FILTER_PH_x2z.inc" #else + CALL polar_filter_3d( grid%w_2, grid%clat, .false., & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) + CALL polar_filter_3d( grid%ph_2, grid%clat, .false., & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & @@ -301,6 +320,7 @@ SUBROUTINE pxft ( grid & ids, ide, jds, jde, kds, kde, & imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, kpex ) + # include "XPOSE_POLAR_FILTER_WW_x2z.inc" #else CALL polar_filter_3d( grid%ww_m, grid%clat, .false., & @@ -324,10 +344,12 @@ SUBROUTINE pxft ( grid & ids, ide, jds, jde, kds, kde, & imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1) ) + # include "XPOSE_POLAR_FILTER_RV_x2z.inc" # include "XPOSE_POLAR_FILTER_RU_z2x.inc" k_end = MIN(kde-1,kpex) IF ( piggyback_mut ) k_end = MIN(kde,kpex) + CALL polar_filter_3d( grid%ru_xxx, grid%clat_xxx, piggyback_mut, & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & @@ -335,13 +357,16 @@ SUBROUTINE pxft ( grid & ipsx, ipex, jpsx, jpex, kpsx, k_end ) #include "XPOSE_POLAR_FILTER_RU_x2z.inc" #else + CALL polar_filter_3d( grid%rv_m, grid%clat, .false., & fft_filter_lat, dclat, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, MIN(kde-1,kpe) ) + k_end = MIN(kde-1,kpe) IF ( piggyback_mut ) k_end = MIN(kde,kpe) + CALL polar_filter_3d( grid%ru_m, grid%clat, piggyback_mut, & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde-1, & @@ -400,17 +425,20 @@ SUBROUTINE pxft ( grid & #endif ENDIF -! tracer +!!!!!!!!!!!!!!!!!!!!!!! +! TRACER IF ( flag_tracer .GE. PARAM_FIRST_SCALAR ) THEN itrace = flag_tracer #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) # include "XPOSE_POLAR_FILTER_TRACER_z2x.inc" + CALL polar_filter_3d( grid%fourd_xxx, grid%clat_xxx, .false. , & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1), & positive_definite = positive_definite ) + # include "XPOSE_POLAR_FILTER_TRACER_x2z.inc" #else CALL polar_filter_3d( tracer(ims,kms,jms,itrace), grid%clat, .false. , & @@ -482,6 +510,8 @@ SUBROUTINE polar_filter_3d( f, xlat, piggyback, fft_filter_lat, dvlat, & INTEGER :: k, nboxw, nbox2, istart, iend, overlap INTEGER, DIMENSION(6) :: wavenumber = (/ 1, 3, 7, 10, 13, 16 /) + INTEGER :: fftflag + ! Variables will stay in domain form since this routine is meaningless ! unless tile extent is the same as domain extent in E/W direction, i.e., ! the processor has access to all grid points in E/W direction. @@ -493,6 +523,8 @@ SUBROUTINE polar_filter_3d( f, xlat, piggyback, fft_filter_lat, dvlat, & CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) END IF + fftflag= 1 ! call double-precision fft +! fftflag= 0 ! call single-precision fft nx = ide-ids ! "U" stagger variables will be repeated by periodic BCs ny = kte-kts+1 ! we can filter extra level for variables that are non-Z-staggered @@ -505,15 +537,21 @@ SUBROUTINE polar_filter_3d( f, xlat, piggyback, fft_filter_lat, dvlat, & ! determine whether or not to filter the data - lat = xlat(ids,j)-dvlat + if(xlat(ids,j).gt.0.) then + lat = xlat(ids,j)-dvlat + else + lat = xlat(ids,j)+dvlat + endif + IF (abs(lat) >= fft_filter_lat) THEN + DO k=kts,kte DO i=ids,ide-1 sheet(i-ids+1,k-kts+1) = f(i,k,j) END DO END DO - CALL polar_filter_fft_2d_ncar(nx,ny,sheet,lat,fft_filter_lat,piggyback) + call polar_filter_fft_2d_ncar(nx,ny,sheet,lat,fft_filter_lat,piggyback,fftflag) DO k=kts,kte DO i=ids,ide-1 @@ -521,6 +559,7 @@ SUBROUTINE polar_filter_3d( f, xlat, piggyback, fft_filter_lat, dvlat, & END DO ! setting up ims-ime with x periodicity: ! enforce periodicity as in set_physical_bc3d + DO i=1,ids-ims f(ids-i,k,j)=f(ide-i,k,j) END DO @@ -528,6 +567,7 @@ SUBROUTINE polar_filter_3d( f, xlat, piggyback, fft_filter_lat, dvlat, & f(ide+i-1,k,j)=f(ids+i-1,k,j) END DO END DO + END IF END DO ! outer j (latitude) loop @@ -535,7 +575,7 @@ END SUBROUTINE polar_filter_3d !------------------------------------------------------------------------------ -SUBROUTINE polar_filter_fft_2d_ncar(nx,ny,fin,lat,filter_latitude,piggyback) +SUBROUTINE polar_filter_fft_2d_ncar(nx,ny,fin,lat,filter_latitude,piggyback,fftflag) IMPLICIT NONE INTEGER , INTENT(IN) :: nx, ny REAL , DIMENSION(nx,ny), INTENT(INOUT) :: fin @@ -543,13 +583,19 @@ SUBROUTINE polar_filter_fft_2d_ncar(nx,ny,fin,lat,filter_latitude,piggyback) LOGICAL, INTENT(IN) :: piggyback REAL :: pi, rcosref, freq, c, cf + + INTEGER :: k, fftflag + REAL, DIMENSION(NX,NY) :: work + REAL, DIMENSION(NX+15) :: wsave + REAL(KIND=8), DIMENSION(NX,NY) :: fin8, work8 + REAL(KIND=8), DIMENSION(NX+15) :: wsave8 + INTEGER :: i, j REAL, dimension(nx,ny) :: fp INTEGER :: lensave, ier, nh, n1 INTEGER :: lot, jump, n, inc, lenr, lensav, lenwrk - REAL, DIMENSION(nx+15) :: wsave - REAL, DIMENSION(nx,ny) :: work + REAL, PARAMETER :: alpha = 0.0 REAL :: factor_k @@ -574,16 +620,31 @@ SUBROUTINE polar_filter_fft_2d_ncar(nx,ny,fin,lat,filter_latitude,piggyback) ! initialize coefficients, place in wsave ! (should place this in init and save wsave at program start) - call rfftmi(n,wsave,lensav,ier) + if(fftflag.eq.0) then + call rfftmi(n,wsave,lensav,ier) + else + call dfft1i(n,wsave8,lensav,ier) + endif + IF(ier /= 0) THEN - write(0,*) ' error in rfftmi ',ier + write(a_message,*) ' error in rfftmi ',ier + CALL wrf_message ( a_message ) END IF ! do the forward transform - call rfftmf( lot, jump, n, inc, fin, lenr, wsave, lensav, work, lenwrk, ier ) + if(fftflag.eq.0) then + call rfftmf(lot, jump, n, inc, fin, lenr, wsave, lensav, work, lenwrk, ier) + else + fin8 = fin + do k=1,ny + call dfft1f(n, inc, fin8(1,k), lenr, wsave8, lensav, work8, lenwrk, ier) + enddo + endif + IF(ier /= 0) THEN - write(0,*) ' error in rfftmf ',ier + write(a_message,*) ' error in rfftmf ',ier + CALL wrf_message ( a_message ) END IF if(MOD(n,2) == 0) then @@ -599,6 +660,7 @@ SUBROUTINE polar_filter_fft_2d_ncar(nx,ny,fin,lat,filter_latitude,piggyback) DO i=2,nh+1 freq=REAL(i-1)/REAL(n) c = (rcosref*COS(lat*pi/180.)/SIN(freq*pi))**2 + ! c = MAX(0.,MIN(1.,c)) do j=1,ntop factor_k = (1.-alpha)+alpha*min(1.,float(ntop - j)/10.) @@ -629,17 +691,34 @@ SUBROUTINE polar_filter_fft_2d_ncar(nx,ny,fin,lat,filter_latitude,piggyback) endif END IF - DO j=1,ny - DO i=1,nx - fin(i,j) = fp(i,j)*fin(i,j) - ENDDO - ENDDO + if(fftflag.eq.0) then + do j=1,ny + do i=1,nx + fin(i,j) = fp(i,j)*fin(i,j) + enddo + enddo + else + do j=1,ny + do i=1,nx + fin8(i,j) = fp(i,j)*fin8(i,j) + enddo + enddo + endif ! do the backward transform - call rfftmb( lot, jump, n, inc, fin, lenr, wsave, lensav, work, lenwrk, ier ) + if(fftflag.eq.0) then + call rfftmb(lot, jump, n, inc, fin, lenr, wsave, lensav, work, lenwrk, ier) + else + do k=1,ny + call dfft1b(n, inc, fin8(1,k), lenr, wsave8, lensav, work8, lenwrk, ier) + enddo + fin= fin8 + endif + IF(ier /= 0) THEN - write(0,*) ' error in rfftmb ',ier + write(a_message,*) ' error in rfftmb ',ier + CALL wrf_message ( a_message ) END IF END SUBROUTINE polar_filter_fft_2d_ncar diff --git a/wrfv2_fire/dyn_em/module_stoch.F b/wrfv2_fire/dyn_em/module_stoch.F index 95c4d2f6..b0f4bb4b 100644 --- a/wrfv2_fire/dyn_em/module_stoch.F +++ b/wrfv2_fire/dyn_em/module_stoch.F @@ -1,10 +1,9 @@ module module_stoch !*********************************************************************** ! -! Purpose: Stochastic kinetic-energy backscatter scheme (SKEB) +! Purpose: Stochastic Perturbation Schemes ! Author : Judith Berner, NCAR (berner@ucar.edu) -! Date : Dec 2010 -! Version: 1.0 +! Date : Apr 2014 ! !*********************************************************************** ! @@ -15,38 +14,63 @@ module module_stoch ! Details of the scheme and its performance in a meso-scale WRF-ensemble ! system are available in: ! -! Berner, J., S.-Y. Ha, J. P. Hacker, A. Fournier and C. Snyder 2010: -! Model uncertainty in a mesoscale ensemble prediction system: Stochastic -! versus multi-physics representations, MWR, accepted -! (available through the AMS early online release) +! Berner, J., S.-Y. Ha, J. P. Hacker, A. Fournier and C. Snyder 2011: +! "Model uncertainty in a mesoscale ensemble prediction system: Stochastic +! versus multi-physics representations", 2011, Mon. Wea. Rev., 139, 1972—1995 +! http://journals.ametsoc.org/doi/abs/10.1175/2010MWR3595.1 ! ! Features: -! Version 1.0: ! Dissipation: Dissipation rates are assumed constant in space and time ! Vertical structure: Supports two options for vertical structure: ! 0) constant ! 1) random phase ! ! Optional namelist parameters: -! stoch_opt - 0) No stochastic parameterization -! - 1) Stochastic kinetic-energy backscatter scheme (SKEB) -! stoch_vertstruc_opt - 0) Constant vertical structure -! - 1) Random phase vertical structure -! tot_backscat_psi - Strength of streamfunction perturbations -! tot_backscat-t - Strength of potential temperature perturbations -! -!*********************************************************************** +! stoch_force_opt = 0, 0, 0: No stochastic parameterization +! = 1, 1, 1: Use SKEB scheme +! stoch_vertstruc_opt = 0, 0, 0: Constant vertical structure of random pattern generator +! = 1, 1, 1: Random phase vertical structure random pattern generator +! tot_backscat_psi : Total backscattered dissipation rate for streamfunction; Controls +! amplitude of rotational wind perturbations Default value is 1.0E-5 m2/s3. +! tot_backscat_t : Total backscattered dissipation rate for potential temperature; +! Controls amplitude of potential temperature perturbations. Default value is 1.0E-6 m2/s3. +! nens : Random seed for random number stream. This parameter needs to be different +! for each member in ensemble forecasts. Is a function of initial start time +! to ensure different random number streams for different forecasts. +! ztau_psi : Decorrelation time (in s) for streamfunction perturbations. +! Default is 10800s. Recommended value is 216000s. +! ztau_t : Decorrelation time (in s) for potential temperature perturbations. +! Default 10800s. Recommended value is 216000s. +! rexponent_psi : Spectral slope for streamfunction perturbations. Default is -1.83 +! for a kinetic-energy forcing spectrum with slope -5/3. +! rexponent_t : Spectral slope of potential temperature perturbations. Default is -1.83 +! for a potential energy forcing spectrum with slope -1.832. +! kminforc : Minimal forcing wavenumber in longitude for streamfunction perturbations. Default is 1. +! lminforc : Minimal forcing wavenumber in latitude for streamfunction perturbations. Default is 1. +! kminforc : Minimal forcing wavenumber in longitude for potential temperature perturbations. Default is 1. +! lminforct : Minimal forcing wavenumber in latitude for potential temperature perturbations. Default is 1. +! kmaxforc : Maximal forcing wavenumber in longitude for streamfunction perturbations. +! Default is maximal possible wavenumbers determined by number of gridpoints. +! lmaxforc : Maximal forcing wavenumber in latitude for streamfunction perturbations. +! Default is maximal possible wavenumbers determined by number of gridpoints. +! kmaxforct : Maximal forcing wavenumber in longitude for potential temperature perturbations. +! Default is maximal possible wavenumbers determined by number of gridpoints. +! lmaxforct : Maximal forcing wavenumber in latitude for potential temperature perturbations. +! Default is maximal possible wavenumbers determined by number of gridpoints. +! zsigma2_eps : Noise variance in autoregressive process defining streamfunction perturbations. +! zsigma2_eta : Noise variance in autoregressive process defining in potential temperature perturbations. +!*********************************************************************** ! ------------------------------------------------------------------ !************** DECLARE FIELDS AND VARIABLES FOR STOCHASTIC BACKSCATTER ! ------------------------------------------------------------------ implicit none - public :: SETUP_STOCH, UPDATE_STOCH,do_fftback_along_x,do_fftback_along_y,& - SP2GP_prep + public :: SETUP_STOCH_SKEBS, SETUP_STOCH_SPPT, UPDATE_STOCH,& + do_fftback_along_x,do_fftback_along_y, SP2GP_prep INTEGER :: LMINFORC, LMAXFORC, KMINFORC, KMAXFORC, & & LMINFORCT, LMAXFORCT, KMINFORCT, KMAXFORCT - REAL :: ALPH, TOT_BACKSCAT_PSI, TOT_BACKSCAT_T, REXPONENT + REAL :: ALPH, ALPH_PSI, ALPH_T, TOT_BACKSCAT_PSI, TOT_BACKSCAT_T, REXPONENT_PSI,REXPONENT_T ! ----------Fields for spectral transform ----------- @@ -56,7 +80,8 @@ module module_stoch ! --------- Others ------------------------------------------------- REAL, PARAMETER:: RPI= 3.141592653589793 !4.0*atan(1.0) - REAL, PARAMETER:: CP= 1006 ! specific heat of dry air in J/(Kg*K)= m^2/(K* s^2) + REAL, PARAMETER:: CP= 1006.0 ! specific heat of dry air in J/(Kg*K)= m^2/(K* s^2) + REAL, PARAMETER:: T0= 300.0 ! Reference temperature in K save @@ -69,32 +94,44 @@ module module_stoch !!******** INITIALIZE STOCHASTIC KINETIC ENERGY BACKSCATTER (SKEB) ***** ! ------------------------------------------------------------------ - subroutine SETUP_STOCH( & + subroutine SETUP_STOCH_SKEBS( & VERTSTRUCC,VERTSTRUCS, & SPT_AMP,SPSTREAM_AMP, & + VERTAMPT,VERTAMPUV, & stoch_vertstruc_opt, & - itime_step,DX,DY,NENS, & + ISEED1,ISEED2,itime_step,DX,DY, & TOT_BACKSCAT_PSI,TOT_BACKSCAT_T, & + ZTAU_PSI,ZTAU_T,REXPONENT_PSI,REXPONENT_T, & + KMINFORC,KMAXFORCH,LMINFORC,LMAXFORCH, & + KMINFORCT,KMAXFORCTH,LMINFORCT,LMAXFORCTH, & + KMAXFORC,LMAXFORC,KMAXFORCT,LMAXFORCT, & + ZSIGMA2_EPSH,ZSIGMA2_ETAH, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - USE module_configure IMPLICIT NONE - TYPE (grid_config_rec_type) :: config_flags - INTEGER :: IER,IK,IL,I,J + INTEGER :: IER,IK,IL,iseed1,iseed2,I,J INTEGER :: itime_step,stoch_vertstruc_opt INTEGER :: KMAX,LMAX,LENSAV,ILEV INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte + INTEGER :: KMINFORC,LMINFORC,KMINFORCT,LMINFORCT + INTEGER :: KMAXFORC,LMAXFORC,KMAXFORCT,LMAXFORCT + INTEGER :: KMAXFORCH,LMAXFORCH,KMAXFORCTH,LMAXFORCTH + REAL :: ZSIGMA2_EPSH,ZSIGMA2_ETAH REAL :: DX,DY,RY,RX,RATIO_BACKSCAT,TOT_BACKSCAT_PSI,TOT_BACKSCAT_T - REAL :: ZGAMMAN,ZTAU,ZCONSTF0,ZCONSTF0T,ZSIGMA2_EPS, RHOKLMAX,ZREF,RHOKL,EPS + REAL :: ZGAMMAN,ZGAMMAT,ZTAU_PSI,ZTAU_T,ZCONSTF0,ZCONSTF0T,ZSIGMA2_EPS,ZSIGMA2_ETA,RHOKLMAX,ZREF,RHOKL,EPS + REAL :: REXPONENT_PSI,REXPONENT_T + REAL :: ZNORM1,ZNORM2 REAL, DIMENSION (ims:ime,kms:kme,jms:jme) :: VERTSTRUCC,VERTSTRUCS REAL, DIMENSION (ims:ime,jms:jme) :: SPSTREAM_AMP,SPT_AMP REAL, DIMENSION (ids:ide,jds:jde) :: ZCHI,ZCHIT - INTEGER :: how_many, nens + REAL, DIMENSION (kms:kme ) :: VERTAMPT,VERTAMPUV LOGICAL :: is_print = .true. + INTEGER , ALLOCATABLE , DIMENSION(:) :: iseed + INTEGER :: how_many LOGICAL , EXTERNAL :: wrf_dm_on_monitor @@ -103,7 +140,7 @@ subroutine SETUP_STOCH( & KMAX=(jde-jds)+1 !NLAT LMAX=(ide-ids)+1 !NLON RY= KMAX*DY - RX= LMAX*DY + RX= LMAX*DX LENSAV= 4*(KMAX+LMAX)+INT(LOG(REAL(KMAX))) + INT(LOG(REAL(LMAX))) + 8 ! --------- ALLOCATE FIELDS FOR FFTPACK---------------------------- @@ -129,44 +166,30 @@ subroutine SETUP_STOCH( & its, ite, jts, jte, kts, kte ) ! ---------- INITIAIZE STOCHASTIC KINETIC ENERGY BACKSCATTER PARAMETERS----------- - REXPONENT=-1.83 !produces 2(p+1) kinetic energy spectra % p=-11/6=1.83 => k=-5/3 -! TOT_BACKSCAT_PSI = 2.0 -! TOT_BACKSCAT_T = 4.8E-04 ! 2.E-06/240 - KMINFORC=0 - KMAXFORC=min0(40,KMAX/2) - LMINFORC=KMINFORC - LMAXFORC=KMAXFORC - KMINFORCT=0 - KMAXFORCT=KMAXFORC - LMINFORCT=KMINFORCT - LMAXFORCT=KMAXFORCT - ZTAU = 2.E04/12. - ALPH = float(itime_step)/ZTAU ! approximation of 1.-exp(-itime_step/ZTAU) - ZSIGMA2_EPS=1./(12.0*ALPH) - -! Sanity checks for forcing wavenumber range - IF (LMAXFORC>LMAX/2) then - LMAXFORC=min0(40,LMAX/2)-1 - KMAXFORC=LMAXFORC - ENDIF - IF (LMAXFORCT>LMAX/2) then - LMAXFORCT=min0(40,LMAX/2)-1 - KMAXFORCT=LMAXFORCT - ENDIF - IF ((LMINFORC>LMAXFORC).or.(KMINFORC>KMAXFORC)) then - WRITE(*,'('' LMINFORC>LMAXFORC IN SETUP_STOCH.F90'')') - STOP - ENDIF - IF ((KMAXFORC>KMAX/2).or.(LMAXFORC>LMAX/2)) then - WRITE(*,'('' KMAXFORC>KMAX/2 IN SETUP_STOCH.F90'')') - print*,KMAXFORC,KMAX/2 - STOP - ENDIF - IF ((KMINFORC.ne.LMINFORC).or.(KMAXFORC.ne.LMAXFORC)) then - WRITE(*,'('' Forcing is non-homogenious in latitude and longitude'')') - WRITE(*,'('' If this is what you want, comment *stop* IN SETUP_STOCH.F90'')') - STOP - ENDIF +! REXPONENT_PSI=-1.83 !produces 2(p+1) kinetic energy spectra % p=-11/6=1.83 => k=-5/3 +! REXPONENT_T=-1.83 ! + KMAXFORC =min0(((ide-ids)+1)/2,((jde-jds)+1 )/2)-5 + LMAXFORC =KMAXFORC + KMAXFORCT=min0(((ide-ids)+1)/2,((jde-jds)+1 )/2)-5 + LMAXFORCT=KMAXFORCT + if (KMAXFORC > KMAXFORCH) then + KMAXFORC=KMAXFORCH + endif + if (LMAXFORC > LMAXFORCH) then + LMAXFORC=LMAXFORCH + endif + if (KMAXFORCT > KMAXFORCTH) then + KMAXFORCT=KMAXFORCTH + endif + if (LMAXFORCT > LMAXFORCTH) then + LMAXFORCT=LMAXFORCTH + endif + + + ALPH_PSI = float(itime_step)/ZTAU_PSI ! approximation of 1.-exp(-itime_step/ZTAU_PSI) + ALPH_T = float(itime_step)/ZTAU_PSI ! approximation of 1.-exp(-itime_step/ZTAU_T) + ZSIGMA2_EPS=1./(12.0*ALPH_PSI) + ZSIGMA2_ETA=1./(12.0*ALPH_T) ! Output of stochastic settings if (is_print) then @@ -175,18 +198,24 @@ subroutine SETUP_STOCH( & WRITE(*,'('' >> Initializing stochastic kinetic-energy backscatter scheme << '')') WRITE(*,'('' Total backscattered energy, TOT_BACKSCAT_PSI '',E12.5)') TOT_BACKSCAT_PSI WRITE(*,'('' Total backscattered temperature, TOT_BACKSCAT_T '',E12.5)') TOT_BACKSCAT_T - WRITE(*,'('' Exponent for energy spectra, REXPONENT ='',E12.5)') REXPONENT + WRITE(*,'('' Exponent for energy spectra, REXPONENT_PSI ='',E12.5)') REXPONENT_PSI + WRITE(*,'('' Exponent for temperature spectra, REXPONENT_T ='',E12.5)') REXPONENT_T WRITE(*,'('' Minimal wavenumber of streamfunction forcing, LMINFORC ='',I10)') LMINFORC WRITE(*,'('' Maximal wavenumber of streamfunction forcing, LMAXFORC ='',I10)') LMAXFORC WRITE(*,'('' Minimal wavenumber of streamfunction forcing, KMINFORC ='',I10)') KMINFORC WRITE(*,'('' Maximal wavenumber of streamfunction forcing, KMAXFORC ='',I10)') KMAXFORC WRITE(*,'('' Minimal wavenumber of temperature forcing, LMINFORCT ='',I10)') LMINFORCT WRITE(*,'('' Maximal wavenumber of temperature forcing, LMAXFORCT ='',I10)') LMAXFORCT + WRITE(*,'('' Minimal wavenumber of temperature forcing, KMINFORCT ='',I10)') KMINFORCT + WRITE(*,'('' Maximal wavenumber of temperature forcing, KMAXFORCT ='',I10)') KMAXFORCT WRITE(*,'('' stoch_vertstruc_opt '',I10)') stoch_vertstruc_opt WRITE(*,'('' Time step: itime_step='',I10)') itime_step - WRITE(*,'('' Decorrelation time of noise, ZTAU ='',E12.5)') ZTAU + WRITE(*,'('' Decorrelation time of noise, ZTAU_PSI ='',E12.5)') ZTAU_PSI + WRITE(*,'('' Decorrelation time of noise, ZTAU_T ='',E12.5)') ZTAU_T WRITE(*,'('' Variance of noise, ZSIGMA2_EPS ='',E12.5)') ZSIGMA2_EPS - WRITE(*,'('' Autoregressive parameter 1-ALPH ='',E12.5)') 1.-ALPH + WRITE(*,'('' Variance of noise, ZSIGMA2_ETA ='',E12.5)') ZSIGMA2_ETA + WRITE(*,'('' Autoregressive parameter 1-ALPH_PSI ='',E12.5)') 1.-ALPH_PSI + WRITE(*,'('' Autoregressive parameter 1-ALPH_T ='',E12.5)') 1.-ALPH_T WRITE(*,'('' =============================================='')') endif @@ -196,72 +225,58 @@ subroutine SETUP_STOCH( & ! First the constants: ZCHI = 0.0 - ! Fill lower left quadrant of ZCHI. For this range the indeces IK,IL - do IK=KMINFORC,KMAXFORC - do IL=LMINFORC,LMAXFORC - if ((sqrt(float(IK*IK+IL*IL))).le.(KMAXFORC)) then - if ((IK>0).or.(IL>0)) then - ZCHI(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT/2.) - endif - endif - enddo - enddo ZGAMMAN = 0.0 - DO IK=KMINFORC,KMAXFORC - DO IL=LMINFORC,LMAXFORC - if (sqrt(float(IK*IK+IL*IL)).le.KMAXFORC) then - if ((IK>0).or.(IL>0)) then - ZGAMMAN= ZGAMMAN + ((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT+1) - endif - endif - ENDDO - ENDDO - ZGAMMAN=4.0*ZGAMMAN !account for all quadrants, although only one is Filled - -! A value TOT_BACKSCAT_PSI=xx m^2/S^3 means that in each gridbox and on average, -! a dissipation rate of D=TOT_BACKSCAT_PSI m^2/s^3 is backscattered onto the resolved streamfunction -! The resulting units for ZCONSTF0 are sqrt(m^2/(s^3*s)) = m^2/s^2, which is the unit of dpsi/dt -! Note, that the unit of IK has the unit m here. - ZCONSTF0=SQRT(ALPH*TOT_BACKSCAT_PSI/(float(itime_step)*ZSIGMA2_EPS*ZGAMMAN))/(2*RPI) + ! Fill lower left quadrant of ZCHI. For this range the indeces IK,IL + DO IK=jds-1,jde ! These are now wavenumbers + DO IL=ids-1,ide + if (((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((KMAXFORC+0.5)/RX)).and.& + (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((KMINFORC-0.5)/RX))) .or. & + ((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((LMAXFORC+0.5)/RX)).and.& + (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((LMINFORC-0.5)/RX))))then + if ((IK>0).or.(IL>0)) then + ZCHI(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT_PSI/2.) + ZGAMMAN= ZGAMMAN + ((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT_PSI+1) + endif + endif + enddo + enddo + ZGAMMAN=4.0*ZGAMMAN !account for all quadrants, although only one is Filled + ZCONSTF0=SQRT(ALPH_PSI*TOT_BACKSCAT_PSI/(float(itime_step)*ZSIGMA2_EPS*ZGAMMAN))/(2*RPI) ZCHIT = 0.0 + ZGAMMAT = 0.0 ! Fill lower left quadrant of ZCHI. For this range the indeces IK,IL - do IK=KMINFORCT,KMAXFORCT - do IL=LMINFORCT,LMAXFORCT - if ((sqrt(float(IK*IK+IL*IL))).le.(KMAXFORCT)) then - if ((IK>0).or.(IL>0)) then - ZCHIT(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT/2.) - endif - endif - enddo - enddo - ZGAMMAN = 0.0 - DO IK=KMINFORCT,KMAXFORCT - DO IL=LMINFORCT,LMAXFORCT - if (sqrt(float(IK*IK+IL*IL)).le.KMAXFORC) then - if ((IK>0).or.(IL>0)) then - ZGAMMAN= ZGAMMAN + ((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT+1) - endif - endif - ENDDO - ENDDO - ZGAMMAN=4.0*ZGAMMAN !account for all quadrants, although only one is Filled + DO IK=jds-1,jde ! These are now wavenumbers + DO IL=ids-1,ide + if (((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((KMAXFORCT+0.5)/RX)).and.& + (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((KMINFORCT-0.5)/RX))) .or. & + ((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((LMAXFORCT+0.5)/RX)).and.& + (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((LMINFORCT-0.5)/RX))))then + if ((IK>0).or.(IL>0)) then + ZCHIT(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT_T/2.) + ZGAMMAT= ZGAMMAT + ((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT_T) + endif + endif + enddo + enddo + ZGAMMAT=4.0*ZGAMMAT !account for all quadrants, although only one is Filled + ! A value TOT_BACKSCAT_T= xx m^2/S^3 means that in each gridbox and on average, ! a dissipation rate of D=TOT_BACKSCAT_T m^2/s^3 is backscattered onto the resolved temperture pattern ! The resulting units for ZCONSTF0T are m^2/s^3* (K* s^2)/m^2 = K/s , which is the unit of dT/dt - ZCONSTF0T=TOT_BACKSCAT_T /cp* SQRT(ALPH/(ZSIGMA2_EPS*ZGAMMAN))/(2*RPI) + ZCONSTF0T=SQRT(T0*ALPH_T*TOT_BACKSCAT_T/(float(itime_step)*cp*ZSIGMA2_ETA*ZGAMMAT)) + ! Now the wavenumber-dependent amplitudes ! Note: There are symmetries and anti-symmetries to ensure real-valued back transforms ! Fill lower left quadrant of matrix of noise amplitudes for wavenumbers K=0,KMAX/2 SPSTREAM_AMP=0.0 SPT_AMP=0.0 - SPT_AMP=0.0 DO IK=jts,jte DO IL=its,ite if ((IL .le. (LMAX/2+1)) .and. (IK .le. (KMAX/2+1)) ) then - SPSTREAM_AMP(IL,IK) = ZCONSTF0 *ZCHI(IL,IK) + SPSTREAM_AMP(IL,IK) = ZCONSTF0 *ZCHI(IL,IK) SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(IL,IK) endif ENDDO @@ -281,7 +296,8 @@ subroutine SETUP_STOCH( & ! Lower right quadrant DO IK=jts,jte DO IL=its,ite - if ((IK .gt. (KMAX/2+1)) .and. (IL.le.LMAX/2) ) then + !if ((IK .gt. (KMAX/2+1)) .and. (IL.le.(LMAX/2)) ) then + if ((IK .gt. (KMAX/2+1)) .and. (IL.le.(LMAX/2+1)) ) then SPSTREAM_AMP(IL,IK) = ZCONSTF0 *ZCHI(IL,KMAX-IK+2) SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(IL,KMAX-IK+2) endif @@ -291,7 +307,8 @@ subroutine SETUP_STOCH( & ! Upper right quadrant DO IK=jts,jte DO IL=its,ite - if ((IK .gt. (KMAX/2+1)) .and. (IL.gt.LMAX/2) ) then + !if ((IK .gt. (KMAX/2+1)) .and. (IL.gt.(LMAX/2)) ) then + if ((IK .gt. (KMAX/2+1)) .and. (IL.gt.(LMAX/2+1)) ) then SPSTREAM_AMP(IL,IK) = ZCONSTF0 *ZCHI(LMAX-IL+2,KMAX-IK+2) SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(LMAX-IL+2,KMAX-IK+2) endif @@ -301,7 +318,7 @@ subroutine SETUP_STOCH( & ! Array for vertical structure if desired - IF (stoch_vertstruc_opt>0) then + IF (stoch_vertstruc_opt==1) then VERTSTRUCC=0.0 VERTSTRUCS=0.0 RHOKLMAX= sqrt(KMAX**2/DY**2 + LMAX**2/DX**2) @@ -323,24 +340,273 @@ subroutine SETUP_STOCH( & ENDDO ENDDO ENDDO - END IF + ELSEIF (stoch_vertstruc_opt==2) then + VERTAMPT=1.0 ! Define vertical amplitude here. + VERTAMPUV=1.0 ! Define vertical amplitude here. + ENDIF -! Allocate field for seed and set seed for random number generator +! Set seed for random number generator + + CALL random_seed(size=how_many) + IF ( ALLOCATED(iseed)) DEALLOCATE(iseed) + ALLOCATE(iseed(how_many)) + IF ( wrf_dm_on_monitor() ) THEN + iseed=0 + iseed(1) = iseed1 + iseed(2) = iseed2 + call random_seed(put=iseed(1:how_many)) ! set random seed on monitor. + call random_seed(get=iseed(1:how_many)) + END IF +#ifdef DM_PARALLEL + CALL wrf_dm_bcast_integer ( iseed , how_many ) + CALL random_seed(put=iseed(1:how_many)) ! set random seed on each proc +#endif + + END subroutine SETUP_STOCH_SKEBS + +! ------------------------------------------------------------------ +!!******** INITIALIZE STOCHASTICALLY PERTURBED PHYSICAL TENDENCY (SPPT) scheme ***** +! ------------------------------------------------------------------ + + subroutine SETUP_STOCH_SPPT( & + VERTSTRUCC,VERTSTRUCS, & + SPT_AMP, & + SPTFORCC,SPTFORCS, & + VERTAMPT,VERTAMPUV, & + stoch_vertstruc_opt, & + ISEED1,ISEED2,itime_step,DX,DY, & + gridpointvariance, l_sppt, tau_sppt, & + KMINFORCT,KMAXFORCTH,LMINFORCT,LMAXFORCTH, & + KMAXFORCT,LMAXFORCT, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + + IMPLICIT NONE + INTEGER :: IER,IK,IL,iseed1,iseed2,I,J + INTEGER :: itime_step,stoch_vertstruc_opt + INTEGER :: KMAX,LMAX,LENSAV,ILEV + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + REAL :: DX,DY,RY,RX,RATIO_BACKSCAT,TOT_BACKSCAT_PSI,TOT_BACKSCAT_T + REAL :: ZGAMMAN,ZCONSTF0,ZCONSTF0T,ZSIGMA2_EPS, RHOKLMAX,ZREF,RHOKL,EPS + REAL :: z,phi,gridpointvariance,kappat,tau_sppt,l_sppt,sum + INTEGER :: KMINFORCT,LMINFORCT,KMAXFORCT,LMAXFORCT,KMAXFORCTH,LMAXFORCTH + REAL, DIMENSION (kms:kme ) :: VERTAMPT,VERTAMPUV + REAL, DIMENSION (ims:ime,kms:kme,jms:jme) :: VERTSTRUCC,VERTSTRUCS + REAL, DIMENSION (ims:ime,jms:jme) :: SPSTREAM_AMP,SPT_AMP + REAL, DIMENSION (ids:ide,jds:jde) :: ZCHI,ZCHIT + REAL, DIMENSION (ims:ime,jms:jme) :: SPTFORCS,SPTFORCC + REAL, DIMENSION (ims:ime,jms:jme) :: var_sigma1 + LOGICAL :: is_print = .true. + INTEGER , ALLOCATABLE , DIMENSION(:) :: iseed + INTEGER :: how_many + + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + + +! --------- SETUP PARAMETERS --------------------------------------- + KMAX=(jde-jds)+1 !NLAT + LMAX=(ide-ids)+1 !NLON + RY= KMAX*DY + RX= LMAX*DY + LENSAV= 4*(KMAX+LMAX)+INT(LOG(REAL(KMAX))) + INT(LOG(REAL(LMAX))) + 8 + +! --------- ALLOCATE FIELDS FOR FFTPACK---------------------------- +! --------- ALLOCATE FIELDS FOR FFTPACK---------------------------- + IF ( ALLOCATED(WSAVE1) ) DEALLOCATE(WSAVE1) + IF ( ALLOCATED(WSAVE2) ) DEALLOCATE(WSAVE2) + ALLOCATE(WSAVE1(LENSAV),WSAVE2(LENSAV)) + + IF ( ALLOCATED(WAVENUMBER_K)) DEALLOCATE(WAVENUMBER_K) + IF ( ALLOCATED(WAVENUMBER_L)) DEALLOCATE(WAVENUMBER_L) + ALLOCATE (wavenumber_k(jds:jde),wavenumber_l(ids:ide)) + +! -------- INITIALIZE FFTPACK ROUTINES ----------------------------- + call CFFT1I (LMAX, WSAVE1, LENSAV, IER) + if(ier.ne. 0) write(*,95) ier + + call CFFT1I (KMAX, WSAVE2, LENSAV, IER) + if(ier.ne. 0) write(*,95) ier + + 95 format('error in cFFT2I= 'i5) + + call findindex( wavenumber_k, wavenumber_l, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! ---------- INITIALIZE STOCHASTICALLY PERTURBED PHYSICAL TENDENCY PARAMETERS----------- + + kappat= L_sppt**2 ! L^2= kappa*T, where L is a length scale in m; set to for L=100km + phi = exp (-float(itime_step)/tau_sppt) + alph = 1.-phi + + KMAXFORCT=min0(((ide-ids)+1)/2,((jde-jds)+1 )/2)-5 + LMAXFORCT=KMAXFORCT + if (KMAXFORCT > KMAXFORCTH) then + KMAXFORCT=KMAXFORCTH + endif + if (LMAXFORCT > LMAXFORCTH) then + LMAXFORCT=LMAXFORCTH + endif + +! Output of stochastic settings + if (is_print) then + WRITE(*,'('' '')') + WRITE(*,'('' =============================================='')') + WRITE(*,'('' >> Initializing stochastically perturbed physical tendencies (SPPT) scheme << '')') + WRITE(*,'('' Minimal wavenumber of temperature forcing, KMINFORCT ='',I10)') KMINFORCT + WRITE(*,'('' Maximal wavenumber of temperature forcing, KMAXFORCT ='',I10)') KMAXFORCT + WRITE(*,'('' stoch_vertstruc_opt '',I10)') stoch_vertstruc_opt + WRITE(*,'('' Time step: itime_step='',I10)') itime_step + WRITE(*,'('' Decorrelation time of noise, tau_sppt ='',E12.5)') TAU_sppt + WRITE(*,'('' Autoregressive parameter phi ='',E12.5)') phi + WRITE(*,'('' Length Scale l_sppt'',E12.5)') l_sppt + WRITE(*,'('' Variance in gridpoint space'',E12.5)') gridpointvariance + WRITE(*,'('' =============================================='')') + endif + +! Modify ZGAMMAN,ZCONSTF0,ZCHIT for SPPT: +! Constants for spherical harmonics (Palmer et al. 2009) +! ZCONSTF0T= F_0= (var(r)*(1-phi^2)/( 2* sum_n=1^N (2n+1) exp(−κTn(n+1)))^(1./2.) +! ZCHIT(IL,IK) = sigma_n/F_0= exp(−κTn(n+1)/2) + +! Constants for double period boundary domain +! gridpointvariance=1.0 +! ZCONSTF0T=F0= sqrt((gridpointvariance*(1 − phi**2))/ZGAMMAN) +! ZCHIT(IL,IK) =ZCONSTF0T * exp( -2*RPI**2*kappat*((IK/RY*IK/RY)+(IL/RX*IL/RX)) ) + +! Use existing code and inteprete in the following manner: +! SPT_AMP(IL,IK) (set in line 287) is sigma_kl in eq. 14 of Palmer et al 2009 +! (1-alph) is phi in eq. 14 of Palmer et al 2009 +! for propagator see line 416 : +! SPTFORCC(IL,IK) = (1.-ALPH)*SPTFORCC(IL,IK) + SPT_AMP(IL,IK) *(ZRANDNOSC2(IL,IK)) + + ZCHIT = 0.0 + ZGAMMAN = 0.0 + ! Fill lower left quadrant of ZCHI. For this range the indeces IK,IL + DO IK=jds-1,jde ! These are now wavenumbers + DO IL=ids-1,ide + if (((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((KMAXFORCT+0.5)/RX)).and.& + (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((KMINFORCT-0.5)/RX))) .or. & + ((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((LMAXFORCT+0.5)/RX)).and.& + (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((LMINFORCT-0.5)/RX))))then + if ((IK>0).or.(IL>0)) then + ZCHIT(IL+1,IK+1)=exp( -2*RPI**2*kappat*((IK/RY*IK/RY)+(IL/RX*IL/RX)) ) !SPPT + ZGAMMAN= ZGAMMAN + exp( -4*RPI**2*kappat*((IK/RY*IK/RY)+(IL/RX*IL/RX)) ) !SPPT + endif + endif + enddo + enddo + ZGAMMAN=4.0*ZGAMMAN !account for all quadrants, although only one is Filled + ZCONSTF0T= sqrt(gridpointvariance*(1.-phi**2)/(2.*ZGAMMAN)) + + +! Now the wavenumber-dependent amplitudes +! Note: There are symmetries and anti-symmetries to ensure real-valued back transforms +! Fill lower left quadrant of matrix of noise amplitudes for wavenumbers K=0,KMAX/2 + SPT_AMP=0.0 + DO IK=jts,jte + DO IL=its,ite + if ((IL .le. (LMAX/2+1)) .and. (IK .le. (KMAX/2+1)) ) then + SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(IL,IK) + endif + ENDDO + ENDDO + + ! Fill other quadrants: + ! Upper left quadrant + DO IK=jts,jte + DO IL=its,ite + if ( (IL .gt. (LMAX/2+1)) .and. (IK .le. (KMAX/2+1)) ) then + SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(LMAX-IL+2,IK) + endif + ENDDO + ENDDO + +! Lower right quadrant + DO IK=jts,jte + DO IL=its,ite + if ((IK .gt. (KMAX/2+1)) .and. (IL.le.LMAX/2) ) then + SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(IL,KMAX-IK+2) + endif + ENDDO + ENDDO + +! Upper right quadrant + DO IK=jts,jte + DO IL=its,ite + if ((IK .gt. (KMAX/2+1)) .and. (IL.gt.LMAX/2) ) then + SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(LMAX-IL+2,KMAX-IK+2) + endif + ENDDO + ENDDO + + IF (stoch_vertstruc_opt>0) then + VERTSTRUCC=0.0 + VERTSTRUCS=0.0 + RHOKLMAX= sqrt(KMAX**2/DY**2 + LMAX**2/DX**2) + ZREF=32.0 + DO ILEV=kds,kde + DO IK=jts,jte + DO IL=its,ite + if (IL.le.(LMAX/2)) then + RHOKL = sqrt((IK+1)**2/DY**2 + (IL+1)**2/DX**2) + EPS = ((RHOKLMAX - RHOKL)/ RHOKLMAX) * (ILEV/ZREF) * RPI + VERTSTRUCC(IL,ILEV,IK) = cos ( eps* (IL+1) ) + VERTSTRUCS(IL,ILEV,IK) = sin ( eps* (IL+1) ) + VERTSTRUCC (LMAX-IL+1,ILEV,IK) = cos ( eps* (IL+1) ) + VERTSTRUCS (LMAX-IL+1,ILEV,IK) = - sin ( eps* (IL+1) ) + endif + ENDDO + ENDDO + ENDDO + ENDIF + + IF (stoch_vertstruc_opt>1) then + ! Taper off below 1300m, 1300m is at about 900hPa (correct?), for 40 levels this pressure is close to level 12 + ! => taper off for levels lower than level 14: tanh(ilev/xnorm) + ! Also taper off top: tanh(kde-ilev) + ! CAREFUL: HARDWIRED TO 40 LEVELS!!! + VERTAMPT=0.0 + VERTAMPUV=0.0 + DO ILEV=1,kde-3 + VERTAMPT(ILEV+3)=tanh(float(kde-ilev-3))+tanh(float(ilev)/2.5)-1.0 + ENDDO + ENDIF + +! Set seed for random number generator CALL random_seed(size=how_many) - IF ( ALLOCATED(ISEED) ) DEALLOCATE(ISEED) - ALLOCATE (ISEED(how_many)) - iseed=0 + IF ( ALLOCATED(iseed)) DEALLOCATE(iseed) + ALLOCATE(iseed(how_many)) IF ( wrf_dm_on_monitor() ) THEN - iseed(1) = 7654321 - iseed(2) = 2*(nens*811)+1 - call random_seed(put=iseed) ! set random seed on monitor. + iseed=0 + iseed(1) = iseed1 + iseed(2) = iseed2 + call random_seed(put=iseed(1:how_many)) ! set random seed on monitor. + call random_seed(get=iseed(1:how_many)) END IF #ifdef DM_PARALLEL - CALL wrf_dm_bcast_integer ( iseed , how_many ) + CALL wrf_dm_bcast_integer ( iseed , how_many ) + CALL random_seed(put=iseed(1:how_many)) ! set random seed on each proc #endif - END subroutine SETUP_STOCH +! Initialization of SPTFORCC + DO IK=jts,jte + DO IL=its,ite + call gauss_noise(z) + SPTFORCC(IL,IK) = (1.-phi**2)**(0.5)*SPT_AMP(IL,IK)*z + call gauss_noise(z) + SPTFORCS(IL,IK) = (1.-phi**2)**(0.5)*SPT_AMP(IL,IK)*z + ENDDO + ENDDO + + + END subroutine SETUP_STOCH_SPPT ! ------------------------------------------------------------------ !!************** UPDATE STOCHASTIC PATTERN IN WAVENUMBER SPACE********** @@ -349,7 +615,6 @@ END subroutine SETUP_STOCH subroutine UPDATE_STOCH( & SPSTREAMFORCS,SPSTREAMFORCC,SPTFORCS,SPTFORCC, & SPT_AMP,SPSTREAM_AMP, & - itime,ij, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -362,50 +627,45 @@ subroutine UPDATE_STOCH( & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte - REAL :: Z, thresh - INTEGER ::IL, IK,LMAX,KMAX,i,itime,ij,llmax,kkmax,how_many + REAL :: Z + REAL, PARAMETER :: thresh = 3.0 + INTEGER ::IL, IK,LMAX,KMAX LOGICAL :: LGAUSS KMAX=(jde-jds)+1 !NLAT LMAX=(ide-ids)+1 !NATX - ! Pick the distribution of the noise ! Random noise uses global indexes to ensure necessary symmetries and anti-symmetries ! of random forcing when run on multiple processors - - CALL random_seed(size=how_many) - call random_seed(put=iseed) - - LGAUSS=.false. - thresh=3.0 ! Set threshold to ensure stability + LGAUSS=.true. IF (LGAUSS) then - DO IK=jds,int(jde/2.0)+2 + DO IK=jds,jde DO IL=ids,ide - do - call gauss_noise(z) - if (abs(z).le.thresh) exit - enddo - ZRANDNOSS1(IL,IK)=z - do - call gauss_noise(z) - if (abs(z).le.thresh) exit - enddo - ZRANDNOSC1(IL,IK)=z - do - call gauss_noise(z) - if (abs(z).le.thresh) exit - enddo - ZRANDNOSS2(IL,IK)=z - do - call gauss_noise(z) - if (abs(z).le.thresh) exit - enddo - ZRANDNOSC2(IL,IK)=z + do + call gauss_noise(z) + if (abs(z)1)) then ! Upper half DO IL=its,ite - SPSTREAMFORCC(IL,IK) = (1.-ALPH)*SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK)*(ZRANDNOSC1(IL,IK)) - SPSTREAMFORCS(IL,IK) = (1.-ALPH)*SPSTREAMFORCS(IL,IK) + SPSTREAM_AMP(IL,IK)*(ZRANDNOSS1(IL,IK)) - SPTFORCC(IL,IK) = (1.-ALPH)*SPTFORCC(IL,IK) + SPT_AMP(IL,IK) *(ZRANDNOSC2(IL,IK)) - SPTFORCS(IL,IK) = (1.-ALPH)*SPTFORCS(IL,IK) + SPT_AMP(IL,IK) *(ZRANDNOSS2(IL,IK)) + SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK)* ZRANDNOSC1(IL,IK) + SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCS(IL,IK) + SPSTREAM_AMP(IL,IK)* ZRANDNOSS1(IL,IK) + SPTFORCC(IL,IK) = (1.-ALPH_T)*SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2(IL,IK) + SPTFORCS(IL,IK) = (1.-ALPH_T)*SPTFORCS(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSS2(IL,IK) ENDDO - endif + ELSEIF (IK==1) then + DO IL=its,ite + if ((IL.le.(LMAX/2+1))) then + SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK)* ZRANDNOSC1(IL,IK) + SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCS(IL,IK) + SPSTREAM_AMP(IL,IK)* ZRANDNOSS1(IL,IK) + SPTFORCC(IL,IK) = (1.-ALPH_T)*SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2(IL,IK) + SPTFORCS(IL,IK) = (1.-ALPH_T)*SPTFORCS(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSS2(IL,IK) + elseif ((IL.gt.(LMAX/2+1))) then + SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK)* ZRANDNOSC1(LMAX-IL+2,IK) + SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCS(IL,IK) - SPSTREAM_AMP(IL,IK)* ZRANDNOSS1(LMAX-IL+2,IK) + SPTFORCC(IL,IK) = (1.-ALPH_T)*SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2(LMAX-IL+2,IK) + SPTFORCS(IL,IK) = (1.-ALPH_T)*SPTFORCS(IL,IK) - SPT_AMP(IL,IK) * ZRANDNOSS2(LMAX-IL+2,IK) + endif + ENDDO + ENDIF ENDDO - DO IK=jts,jte - if (IK.ge.(KMAX/2+1))then + if (IK.gt.(KMAX/2+1)) then ! Lower half DO IL=its,ite - if (IL>1) then - SPSTREAMFORCC(IL,IK)= (1.-ALPH)* SPSTREAMFORCC(IL,IK) + & - SPSTREAM_AMP(IL,IK) * ZRANDNOSC1(LMAX-IL+2,KMAX-IK+2) - SPSTREAMFORCS(IL,IK)= -((1.-ALPH)*(-1.0*SPSTREAMFORCS(IL,IK))+ & - SPSTREAM_AMP(IL,IK) * ZRANDNOSS1(LMAX-IL+2,KMAX-IK+2)) - SPTFORCC(IL,IK)= (1.-ALPH)* SPTFORCC(IL,IK) + & - SPT_AMP(IL,IK) * ZRANDNOSC2(LMAX-IL+2,KMAX-IK+2) - SPTFORCS(IL,IK)= -((1.-ALPH)*(-1.0*SPTFORCS(IL,IK))+ & - SPT_AMP(IL,IK) * ZRANDNOSS2(LMAX-IL+2,KMAX-IK+2)) - else - SPSTREAMFORCC(1,IK) = (1.-ALPH) * SPSTREAMFORCC(1,IK) + & - SPSTREAM_AMP(1,IK) * ZRANDNOSC1(1,KMAX-IK+2) - SPSTREAMFORCS(1,IK) = -((1.-ALPH)*(-1.0*SPSTREAMFORCS(1,IK))+ & - SPSTREAM_AMP(1,IK) * ZRANDNOSS1(1,KMAX-IK+2)) - SPTFORCC(1,IK) = (1.-ALPH) * SPTFORCC(1,IK) + & - SPT_AMP(1,IK) * ZRANDNOSC2(1,KMAX-IK+2) - SPTFORCS(1,IK) = -((1.-ALPH)*(-1.0*SPTFORCS(1,IK))+ & - SPT_AMP(1,IK) * ZRANDNOSS2(1,KMAX-IK+2)) - endif - ENDDO - endif - ENDDO - + if (IL.le.(LMAX/2+1).and.(IL.gt.1)) then !lower left + SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK) * ZRANDNOSC1(LMAX-IL+2,KMAX-IK+2) + SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCS(IL,IK) - SPSTREAM_AMP(IL,IK) * ZRANDNOSS1(LMAX-IL+2,KMAX-IK+2) + SPTFORCC(IL,IK) = (1.-ALPH_T)* SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2(LMAX-IL+2,KMAX-IK+2) + SPTFORCS(IL,IK) = (1.-ALPH_T)* SPTFORCS(IL,IK) - SPT_AMP(IL,IK) * ZRANDNOSS2(LMAX-IL+2,KMAX-IK+2) + elseif (IL.eq.1) then !don't exceed index + SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK) * ZRANDNOSC1( 1,KMAX-IK+2) + SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCS(IL,IK) - SPSTREAM_AMP(IL,IK) * ZRANDNOSS1( 1,KMAX-IK+2) + SPTFORCC(IL,IK) = (1.-ALPH_T)* SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2( 1,KMAX-IK+2) + SPTFORCS(IL,IK) = (1.-ALPH_T)* SPTFORCS(IL,IK) - SPT_AMP(IL,IK) * ZRANDNOSS2( 1,KMAX-IK+2) + elseif (IL.gt.(LMAX/2+1)) then !lower right + SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK) * ZRANDNOSC1(LMAX-IL+2,KMAX-IK+2) + SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCS(IL,IK) - SPSTREAM_AMP(IL,IK) * ZRANDNOSS1(LMAX-IL+2,KMAX-IK+2) + SPTFORCC(IL,IK) = (1.-ALPH_T)* SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2(LMAX-IL+2,KMAX-IK+2) + SPTFORCS(IL,IK) = (1.-ALPH_T)* SPTFORCS(IL,IK) - SPT_AMP(IL,IK) * ZRANDNOSS2(LMAX-IL+2,KMAX-IK+2) + endif + ENDDO + endif + ENDDO + END subroutine UPDATE_STOCH ! ------------------------------------------------------------------ @@ -570,11 +841,87 @@ SUBROUTINE UPDATE_STOCH_TEN(ru_tendf,rv_tendf,t_tendf, & END SUBROUTINE UPDATE_STOCH_TEN ! ------------------------------------------------------------------ +!!************** PERTURB PHYSICS TENDENCIES (except T) FOR SPPT ******************* +! ------------------------------------------------------------------ + subroutine perturb_physics_tend(gridpointvariance, & + sppt_thresh_fact,rstoch, & + ru_tendf,rv_tendf,t_tendf,moist_tend, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + +! This subroutine add stochastic perturbations of the form +! +! rx_tendf(i,k,j) = rx_tendf(i,k,j)*(1.0 + rstoch(i,k,j)) +! +! to the tendencies of U, V, and Q. +! Since the temperature perturbations do not include the micro-physics +! tendencies at this point, the stochastic tendency perturbations to +! temperature are added in subroutine rk_addtend_dry of module module_em.F + + IMPLICIT NONE + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION(ims:ime , kms:kme, jms:jme),INTENT(INOUT) :: & + ru_tendf, rv_tendf, t_tendf,moist_tend, & + rstoch + REAL :: gridpointvariance ,thresh,sppt_thresh_fact + + INTEGER :: I,J,K + +! Here the random process at each gridpoint is capped if it exceeds a value thresh + + thresh=sppt_thresh_fact*sqrt(gridpointvariance) + DO j = jts,jte + DO k = kts,kte-1 + DO i = its,ite + if (rstoch(i,k,j).lt.-thresh) then + rstoch(i,k,j)=-thresh + endif + if (rstoch(i,k,j).gt.thresh) then + rstoch(i,k,j)=thresh + endif + ENDDO + ENDDO + ENDDO + +! Perturb the tendencies of u,v,q,t. + DO j = jts,MIN(jde-1,jte) + DO k = kts,kte-1 + DO i = its,ite + ru_tendf(i,k,j) = ru_tendf(i,k,j)*(1.0 + rstoch(i,k,j)) + ENDDO + ENDDO + ENDDO + + DO j = jts,jte + DO k = kts,kte-1 + DO i = its,MIN(ide-1,ite) + rv_tendf(i,k,j) = rv_tendf(i,k,j)*(1.0 + rstoch(i,k,j)) + ENDDO + ENDDO + ENDDO + + DO j = jts,MIN(jde-1,jte) + DO k = kts,kte-1 + DO i = its,MIN(ide-1,ite) + moist_tend(i,k,j) = moist_tend(i,k,j)*(1.0 + rstoch(i,k,j)) + t_tendf (i,k,j) = t_tendf(i,k,j)*(1.0 + rstoch(i,k,j)) + ENDDO + ENDDO + ENDDO + + end subroutine perturb_physics_tend + +! ------------------------------------------------------------------ !!************** TRANSFORM FROM SPHERICAL HARMONICS TO GRIDPOILT SPACE** ! ------------------------------------------------------------------ subroutine SP2GP_prep( & SPSTREAMFORCS,SPSTREAMFORCC,SPTFORCS,SPTFORCC, & VERTSTRUCC,VERTSTRUCS, & + VERTAMPT,VERTAMPUV, & RU_REAL,RV_REAL,RT_REAL, & RU_IMAG,RV_IMAG,RT_IMAG, & dx,dy,stoch_vertstruc_opt, & @@ -589,6 +936,7 @@ subroutine SP2GP_prep( & REAL, DIMENSION (ims:ime , jms:jme) :: SPSTREAMFORCS,SPSTREAMFORCC,SPTFORCS,SPTFORCC REAL, DIMENSION (ims:ime , kms:kme, jms:jme) :: RU_REAL,RV_REAL,RT_REAL,RU_IMAG,RV_IMAG,RT_IMAG, & VERTSTRUCC,VERTSTRUCS + REAL, DIMENSION (kms:kme ) :: VERTAMPT,VERTAMPUV INTEGER :: IK,IL,ILEV,NLAT,NLON,stoch_vertstruc_opt REAL :: dx,dy,RY,RX @@ -630,6 +978,30 @@ subroutine SP2GP_prep( & ENDDO ENDDO + + elseif (stoch_vertstruc_opt==3) then + + DO IL=its,ite + DO IK=jts,jte + rt_real(IL,ILEV,IK) = SPTFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK) - SPTFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK) + rt_real(IL,ILEV,IK) = rt_real(IL,ILEV,IK) * VERTAMPT(ILEV) + rt_imag(IL,ILEV,IK) = SPTFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK) + SPTFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK) + rt_imag(IL,ILEV,IK) = rt_imag(IL,ILEV,IK) * VERTAMPT(ILEV) + ru_real(IL,ILEV,IK) = 2*RPI/RY* wavenumber_k(IK) *& + (+SPSTREAMFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK) + SPSTREAMFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK)) + ru_real(IL,ILEV,IK) = ru_real(IL,ILEV,IK) * VERTAMPUV(ILEV) + ru_imag(IL,ILEV,IK) = 2*RPI/RY* wavenumber_k(IK) *& + (-SPSTREAMFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK) + SPSTREAMFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK)) + ru_imag(IL,ILEV,IK) = ru_imag(IL,ILEV,IK) * VERTAMPUV(ILEV) + rv_real(IL,ILEV,IK) = 2*RPI/RX* wavenumber_l(IL) *& + (-SPSTREAMFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK) - SPSTREAMFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK)) + rv_real(IL,ILEV,IK) = rv_real(IL,ILEV,IK) * VERTAMPUV(ILEV) + rv_imag(IL,ILEV,IK) = 2*RPI/RX* wavenumber_l(IL) *& + (+SPSTREAMFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK) - SPSTREAMFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK)) + rv_imag(IL,ILEV,IK) = rv_imag(IL,ILEV,IK) * VERTAMPUV(ILEV) + ENDDO + ENDDO + endif ENDDO !ILEV @@ -893,4 +1265,32 @@ subroutine gauss_noise(z) end subroutine gauss_noise ! ------------------------------------------------------------------ - end module module_stoch + SUBROUTINE rand_seed (config_flags, seed1, seed2,nens ) + USE module_configure + IMPLICIT NONE +! +! Structure that contains run-time configuration (namelist) data for domain + TYPE (grid_config_rec_type) :: config_flags +! +! Arguments + INTEGER, INTENT(OUT) :: seed1, seed2 + INTEGER, INTENT(IN ) :: nens + +! Local + integer :: date_time(8) + integer*8 :: yyyy,mmdd,newtime + integer*8 :: ihr,isc,idiv + character (len=10) :: real_clock(3), time +! + LOGICAL :: is_print = .false. +! + newtime = config_flags%start_year * ( config_flags%start_month*100+config_flags%start_day) + config_flags%start_hour + + idiv=2; + seed1 = newtime+nens*1000000 + seed2 = mod(newtime+nens*1000000,idiv) + if(is_print) print *,'Rand_seed (newtime/idiv):',newtime,idiv,nens + + end SUBROUTINE rand_seed + + end module module_stoch diff --git a/wrfv2_fire/dyn_em/module_wps_io_arw.F b/wrfv2_fire/dyn_em/module_wps_io_arw.F index 370d9b62..a52d4048 100755 --- a/wrfv2_fire/dyn_em/module_wps_io_arw.F +++ b/wrfv2_fire/dyn_em/module_wps_io_arw.F @@ -113,6 +113,8 @@ MODULE module_wps_io_arw ! Some constants to allow simple dimensions in the defined types ! given below. + CHARACTER (LEN=256) , PRIVATE :: a_message + CONTAINS @@ -341,7 +343,8 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) call mpi_file_read_at(iunit,file_offset(index)+5*4, & igarb,1,mpi_integer4, & mpi_status_ignore, ierr) - write(0,*) 'setting iswater to be: ', igarb + write(a_message,*) 'setting iswater to be: ', igarb + CALL wrf_message ( a_message ) CALL nl_set_iswater (grid%id, igarb ) VarName='ISICE' @@ -349,7 +352,8 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) call mpi_file_read_at(iunit,file_offset(index)+5*4, & igarb2,1,mpi_integer4, & mpi_status_ignore, ierr) - write(0,*) 'setting isice to be: ', igarb2 + write(a_message,*) 'setting isice to be: ', igarb2 + CALL wrf_message ( a_message ) CALL nl_set_isice (grid%id, igarb2 ) IF ( igarb .eq. 16 .and. igarb2 .eq. 24 ) THEN @@ -748,7 +752,8 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) DO I=ITS,min(ITE,IDE-1) grid%v_gc(I,K,J)=dumdata_v(I,J,K) if (grid%v_gc(I,K,J) .ne. grid%v_gc(I,K,J) .or. abs(grid%v_gc(I,K,J)) .gt. 100.) then - write(0,*) 'bad v_gc defined: ', I,K,J,grid%v_gc(I,K,J) + write(a_message,*) 'bad v_gc defined: ', I,K,J,grid%v_gc(I,K,J) + CALL wrf_message ( a_message ) call wrf_error_fatal(" bad v_gc") endif ENDDO @@ -765,7 +770,8 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) DO I=ITS,min(ITE,IDE) grid%u_gc(I,K,J)=dumdata_u(I,J,K) if (grid%u_gc(I,K,J) .ne. grid%u_gc(I,K,J) .or. abs(grid%u_gc(I,K,J)) .gt. 100.) then - write(0,*) 'bad u_gc defined: ', I,K,J,grid%u_gc(I,K,J) + write(a_message,*) 'bad u_gc defined: ', I,K,J,grid%u_gc(I,K,J) + CALL wrf_message ( a_message ) call wrf_error_fatal(" bad u_gc") endif ENDDO @@ -782,7 +788,8 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) DO I=ITS,min(ITE,IDE-1) grid%t_gc(I,K,J)=dumdata(I,J,K) if (grid%t_gc(I,K,J) .ne. grid%t_gc(I,K,J) .or. abs(grid%t_gc(I,K,J)) .gt. 350.) then - write(0,*) 'bad t_gc defined: ', I,K,J,grid%t_gc(I,K,J) + write(a_message,*) 'bad t_gc defined: ', I,K,J,grid%t_gc(I,K,J) + CALL wrf_message ( a_message ) call wrf_error_fatal(" bad t_gc") endif ENDDO @@ -948,7 +955,8 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) ENDDO ENDDO - write(0,*) 'veg_cat and soil_cat sizes:::: ', num_veg_cat , num_soil_top_cat + write(a_message,*) 'veg_cat and soil_cat sizes:::: ', num_veg_cat , num_soil_top_cat + CALL wrf_message ( a_message ) varName='SOILCTOP' CALL retrieve_index(index,VarName,varname_all,nrecs,iret) @@ -1092,11 +1100,13 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) !! bandaid for newly created WPS geogrid static files if (grid%msfu(I,J) .lt. 0.7) then - write(0,*) 'weird msfu at I,J: ', I,J,grid%msfu(I,J) + write(a_message,*) 'weird msfu at I,J: ', I,J,grid%msfu(I,J) + CALL wrf_message ( a_message ) if(J .eq. min(JTE,JDE-1)) then grid%msfu(I,J)=dumdata_u(I,J-1,1) - write(0,*) 'changing msfu to: ',I,J, grid%msfu(I,J) + write(a_message,*) 'changing msfu to: ',I,J, grid%msfu(I,J) + CALL wrf_message ( a_message ) endif endif @@ -1115,10 +1125,12 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) grid%msfv(I,J)=dumdata_v(I,J,1) if (grid%msfv(I,J) .lt. 0.7 ) then - write(0,*) 'weird msfv at I,J: ', I,J,grid%msfv(I,J) + write(a_message,*) 'weird msfv at I,J: ', I,J,grid%msfv(I,J) + CALL wrf_message ( a_message ) grid%msfv(I,J)=dumdata_v(I,J-1,1) if( J .eq. min(JTE,JDE)) then - write(0,*) 'changing msfv to: ',I,J, grid%msfv(I,J) + write(a_message,*) 'changing msfv to: ',I,J, grid%msfv(I,J) + CALL wrf_message ( a_message ) endif endif @@ -1204,7 +1216,8 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) ENDDO ENDDO - write(0,*) 'reading XLAT_M' + write(a_message,*) 'reading XLAT_M' + CALL wrf_message ( a_message ) varName='XLAT_M' CALL retrieve_index(index,VarName,varname_all,nrecs,iret) CALL mpi_file_read_at(iunit,file_offset(index+1), & @@ -1216,11 +1229,13 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) grid%xlat_gc(I,J)=dumdata(I,J,1) ENDDO ENDDO - write(0,*) 'xlat_gc defined' + write(a_message,*) 'xlat_gc defined' + CALL wrf_message ( a_message ) call mpi_file_close(mpi_comm_world, ierr) - write(0,*) 'to ST000010 def' + write(a_message,*) 'to ST000010 def' + CALL wrf_message ( a_message ) varName='ST000010' flag_st000010 = 1 num_st_levels_input = num_st_levels_input + 1 @@ -1230,7 +1245,8 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) st_input(I,num_st_levels_input + 1,J) = grid%st000010(i,j) ENDDO ENDDO - write(0,*) 'past ST000010 def' + write(a_message,*) 'past ST000010 def' + CALL wrf_message ( a_message ) varName='ST010040' flag_st010040 = 1 @@ -1304,10 +1320,14 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels ) ! flag_sst = 1 - write(0,*) 'maxval st_input(1): ', maxval(st_input(:,1,:)) - write(0,*) 'maxval st_input(2): ', maxval(st_input(:,2,:)) - write(0,*) 'maxval st_input(3): ', maxval(st_input(:,3,:)) - write(0,*) 'maxval st_input(4): ', maxval(st_input(:,4,:)) + write(a_message,*) 'maxval st_input(1): ', maxval(st_input(:,1,:)) + CALL wrf_message ( a_message ) + write(a_message,*) 'maxval st_input(2): ', maxval(st_input(:,2,:)) + CALL wrf_message ( a_message ) + write(a_message,*) 'maxval st_input(3): ', maxval(st_input(:,3,:)) + CALL wrf_message ( a_message ) + write(a_message,*) 'maxval st_input(4): ', maxval(st_input(:,4,:)) + CALL wrf_message ( a_message ) DEALLOCATE(pmsl) DEALLOCATE(psfc_in) @@ -1538,9 +1558,11 @@ subroutine inventory_wrf_binary_file(in_unit,wrf_ges_filename,nrecs, & blanks=trim(' ') - write(0,*) 'inventory subroutine' + write(a_message,*) 'inventory subroutine' + CALL wrf_message ( a_message ) - write(0,*) 'opening file : ', trim(wrf_ges_filename) + write(a_message,*) 'opening file : ', trim(wrf_ges_filename) + CALL wrf_message ( a_message ) open(in_unit,file=trim(wrf_ges_filename),access='direct',recl=lrecl) irecs=0 @@ -1579,7 +1601,8 @@ subroutine inventory_wrf_binary_file(in_unit,wrf_ges_filename,nrecs, & domainend_all(1:3,irecs)=0 loc_count=1 -! write(0,*) '1, hdrbuf4(1): 1', hdrbuf4(1) +! write(a_message,*) '1, hdrbuf4(1): 1', hdrbuf4(1) +! CALL wrf_message ( a_message ) do i=2,8 if(loc_count.ge.lenrec) exit loc_count=loc_count+1 @@ -1591,7 +1614,7 @@ subroutine inventory_wrf_binary_file(in_unit,wrf_ges_filename,nrecs, & ! write(0,*) 'I, hdrbuf4(I): ', I, hdrbuf4(I) end do -! if(lenrec==2048) write(0,*)' irecs,hdrbuf(2),int_dom_ti_char,int_field=', & +! if(lenrec==2048) then write(0,*)' irecs,hdrbuf(2),int_dom_ti_char,int_field=', & ! irecs,hdrbuf(2),int_dom_ti_char,int_field, int_dom_ti_real, int_dom_ti_integer if(lenrec==2048.and.(hdrbuf(2) == int_dom_ti_char .or. hdrbuf(2) == int_field & @@ -1616,7 +1639,8 @@ subroutine inventory_wrf_binary_file(in_unit,wrf_ges_filename,nrecs, & datahandle,element,dumstr,strdata,loccode) varname_all(irecs)=trim(element) datestr_all(irecs)=trim(strdata) - write(0,*)'(1) irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),trim(datestr_all(irecs)) + write(a_message,*)'(1) irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),trim(datestr_all(irecs)) + CALL wrf_message ( a_message ) else if(hdrbuf(2) == int_dom_ti_real) then @@ -1637,7 +1661,8 @@ subroutine inventory_wrf_binary_file(in_unit,wrf_ges_filename,nrecs, & ! datestr_all(irecs)=trim(strdata) - write(0,*)'(2) irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),rdata(1) + write(a_message,*)'(2) irecs,varname,datestr = ',irecs,trim(varname_all(irecs)),rdata(1) + CALL wrf_message ( a_message ) ! write(0,*) ' --------------------------- ' else if(hdrbuf(2) == int_dom_ti_integer) then @@ -1688,26 +1713,37 @@ subroutine inventory_wrf_binary_file(in_unit,wrf_ges_filename,nrecs, & return 885 continue - write(0,*)' problem in inventory_wrf_binary_file, lenrec has bad value before end of file' - write(0,*)' lenrec =',lenrec + write(a_message,*)' problem in inventory_wrf_binary_file, lenrec has bad value before end of file' + CALL wrf_message ( a_message ) + write(a_message,*)' lenrec =',lenrec + CALL wrf_message ( a_message ) close(in_unit) return 890 continue - write(0,*)' problem in inventory_wrf_binary_file, beginning and ending rec len words unequal' - write(0,*)' begining reclen =',lensave - write(0,*)' ending reclen =',lenrec - write(0,*)' irecs =',irecs - write(0,*)' nrecs =',nrecs + write(a_message,*)' problem in inventory_wrf_binary_file, beginning and ending rec len words unequal' + CALL wrf_message ( a_message ) + write(a_message,*)' begining reclen =',lensave + CALL wrf_message ( a_message ) + write(a_message,*)' ending reclen =',lenrec + CALL wrf_message ( a_message ) + write(a_message,*)' irecs =',irecs + CALL wrf_message ( a_message ) + write(a_message,*)' nrecs =',nrecs + CALL wrf_message ( a_message ) call wrf_error_fatal("curious reclen discrepancy") close(in_unit) return 900 continue - write(0,*)' normal end of file reached in inventory_wrf_binary_file' - write(0,*)' nblocks=',thisblock - write(0,*)' irecs,nrecs=',irecs,nrecs - write(0,*)' nreads=',nreads + write(a_message,*)' normal end of file reached in inventory_wrf_binary_file' + CALL wrf_message ( a_message ) + write(a_message,*)' nblocks=',thisblock + CALL wrf_message ( a_message ) + write(a_message,*)' irecs,nrecs=',irecs,nrecs + CALL wrf_message ( a_message ) + write(a_message,*)' nreads=',nreads + CALL wrf_message ( a_message ) close(in_unit) end subroutine inventory_wrf_binary_file diff --git a/wrfv2_fire/dyn_em/solve_em.F b/wrfv2_fire/dyn_em/solve_em.F index 8d0e2c23..30ba499d 100644 --- a/wrfv2_fire/dyn_em/solve_em.F +++ b/wrfv2_fire/dyn_em/solve_em.F @@ -11,7 +11,7 @@ SUBROUTINE solve_em ( grid , config_flags & domain, get_ijk_from_grid, get_ijk_from_subgrid & ,domain_get_current_time, domain_get_start_time & ,domain_get_sim_start_time, domain_clock_get,is_alarm_tstep - USE module_domain_type, ONLY : history_alarm, restart_alarm + USE module_domain_type, ONLY : history_alarm, restart_alarm, auxinput4_alarm USE module_configure, ONLY : grid_config_rec_type USE module_driver_constants USE module_machine @@ -34,7 +34,7 @@ SUBROUTINE solve_em ( grid , config_flags & ,halo_em_tke_advect_5_sub,halo_em_tke_old_e_5_sub & ,halo_em_tke_old_e_7_sub,halo_em_tracer_e_3_sub,halo_em_tracer_e_5_sub & ,halo_em_tracer_e_7_sub,halo_em_tracer_old_e_5_sub & - ,halo_em_tracer_old_e_7_sub,period_bdy_em_a_sub & + ,halo_em_tracer_old_e_7_sub,halo_em_sbm_sub,period_bdy_em_a_sub & ,period_bdy_em_b3_sub,period_bdy_em_b_sub,period_bdy_em_chem2_sub & ,period_bdy_em_chem_old_sub,period_bdy_em_chem_sub,period_bdy_em_d3_sub & ,period_bdy_em_d_sub,period_bdy_em_e_sub,period_bdy_em_moist2_sub & @@ -60,9 +60,9 @@ SUBROUTINE solve_em ( grid , config_flags & USE module_polarfft USE module_microphysics_driver USE module_microphysics_zero_out - USE module_lightning_driver, ONLY : lightning_driver +! USE module_lightning_driver, ONLY : lightning_driver USE module_fddaobs_driver - USE module_diagnostics +! USE module_diagnostics #ifdef WRF_CHEM USE module_input_chem_data USE module_input_tracer @@ -70,8 +70,10 @@ SUBROUTINE solve_em ( grid , config_flags & #endif USE module_first_rk_step_part1 USE module_first_rk_step_part2 + USE module_after_all_rk_steps USE module_llxy, ONLY : proj_cassini USE module_avgflx_em, ONLY : zero_avgflx, upd_avgflx + USE module_cpl, ONLY : coupler_on, cpl_settime, cpl_store_input IMPLICIT NONE @@ -147,7 +149,7 @@ SUBROUTINE solve_em ( grid , config_flags & LOGICAL :: leapfrog INTEGER :: l,kte,kk LOGICAL :: f_flux ! flag for computing averaged fluxes in cu_gd - REAL :: curr_secs + REAL :: curr_secs, curr_secs2 INTEGER :: num_sound_steps INTEGER :: idex, jdex REAL :: max_msft @@ -160,7 +162,7 @@ SUBROUTINE solve_em ( grid , config_flags & ! urban related variables INTEGER :: NUM_ROOF_LAYERS, NUM_WALL_LAYERS, NUM_ROAD_LAYERS ! urban - TYPE(WRFU_TimeInterval) :: tmpTimeInterval + TYPE(WRFU_TimeInterval) :: tmpTimeInterval, tmpTimeInterval2 REAL :: real_time LOGICAL :: adapt_step_flag LOGICAL :: fill_w_flag @@ -258,8 +260,10 @@ SUBROUTINE solve_em ( grid , config_flags & ! floating point seconds based on a TimeInterval. So, we will ! calculate it here--but, this is not clean!! ! - tmpTimeInterval = domain_get_current_time ( grid ) - domain_get_sim_start_time ( grid ) - curr_secs = real_time(tmpTimeInterval) + tmpTimeInterval = domain_get_current_time ( grid ) - domain_get_sim_start_time ( grid ) + tmpTimeInterval2 = domain_get_current_time ( grid ) - domain_get_start_time ( grid ) + curr_secs = real_time(tmpTimeInterval) + curr_secs2 = real_time(tmpTimeInterval2) old_dt = grid%dt ! store old time step for flux averaging code at end of RK loop !----------------------------------------------------------------------------- @@ -281,13 +285,15 @@ SUBROUTINE solve_em ( grid , config_flags & ! Set diagnostic flag value history output time !----------------------------------------------------------------------------- ! if ( Is_alarm_tstep(grid_clock, grid_alarms(HISTORY_ALARM)) ) then - diag_flag = .false. + diag_flag = .false. if ( Is_alarm_tstep(grid%domain_clock, grid%alarms(HISTORY_ALARM)) ) then diag_flag = .true. endif grid%itimestep = grid%itimestep + 1 + IF( coupler_on ) CALL cpl_store_input( grid, config_flags ) + IF (config_flags%polar) dclat = 90./REAL(jde-jds) !(0.5 * 180/ny) #ifdef WRF_CHEM @@ -671,6 +677,8 @@ SUBROUTINE solve_em ( grid , config_flags & !
 !
 
+       IF (coupler_on) CALL cpl_settime( curr_secs2 )
+
        CALL first_rk_step_part1 (    grid, config_flags         &
                              , moist , moist_tend               &
                              , chem  , chem_tend                &
@@ -688,8 +696,7 @@ SUBROUTINE solve_em ( grid , config_flags  &
                              , br , chklowq                     &
                              , cu_act_flag , hol , th_phy       &
                              , pi_phy , p_phy , grid%t_phy      &
-                             , u_phy , v_phy                    &
-                             , dz8w , p8w , t8w , rho_phy , rho &
+                             , dz8w , p8w , t8w                 &
                              , ids, ide, jds, jde, kds, kde     &
                              , ims, ime, jms, jme, kms, kme     &
                              , ips, ipe, jps, jpe, kps, kpe     &
@@ -723,8 +730,7 @@ SUBROUTINE solve_em ( grid , config_flags  &
                              , br , chklowq                     &
                              , cu_act_flag , hol , th_phy       &
                              , pi_phy , p_phy , grid%t_phy      &
-                             , u_phy , v_phy                    &
-                             , dz8w , p8w , t8w , rho_phy , rho &
+                             , dz8w , p8w , t8w                 &
                              , nba_mij, num_nba_mij             & !JDM 
                              , nba_rij, num_nba_rij             & !JDM  
                              , ids, ide, jds, jde, kds, kde     &
@@ -1680,7 +1686,8 @@ SUBROUTINE solve_em ( grid , config_flags  &
 !-----------------------------------------------------------------------
 ! first moisture
 
-     IF ((config_flags%moist_adv_opt /= ORIGINAL .and. config_flags%moist_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order)) THEN
+     IF ((config_flags%moist_adv_opt /= ORIGINAL .and. config_flags%moist_adv_opt /= WENO_SCALAR) .and. &
+         (rk_step == rk_order)) THEN
 
        !$OMP PARALLEL DO   &
        !$OMP PRIVATE ( ij )
@@ -1741,7 +1748,8 @@ SUBROUTINE solve_em ( grid , config_flags  &
 
 ! scalars
 
-     IF ((config_flags%scalar_adv_opt /= ORIGINAL .and. config_flags%scalar_adv_opt /= WENO_SCALAR) .and. (rk_step == rk_order)) THEN
+     IF ((config_flags%scalar_adv_opt /= ORIGINAL .and. config_flags%scalar_adv_opt /= WENO_SCALAR) .and. &
+         (rk_step == rk_order)) THEN
 
        !$OMP PARALLEL DO   &
        !$OMP PRIVATE ( ij )
@@ -2064,7 +2072,8 @@ SUBROUTINE solve_em ( grid , config_flags  &
 
 BENCH_START(rlx_bdy_scalar_tim)
                IF( ( config_flags%specified .or. config_flags%nested ) .and. rk_step == 1 ) THEN 
-                 IF ( im .EQ. P_QV .OR. config_flags%nested ) THEN
+                 IF ( im .EQ. P_QV .OR. config_flags%nested .OR. &
+                    ( config_flags%specified .AND. config_flags%have_bcs_moist ) ) THEN
                    CALL relax_bdy_scalar ( moist_tend(ims,kms,jms,im),            & 
                                      moist(ims,kms,jms,im),  grid%mut,         &
                                      moist_bxs(jms,kms,1,im),moist_bxe(jms,kms,1,im), &
@@ -2127,7 +2136,7 @@ SUBROUTINE solve_em ( grid , config_flags  &
 BENCH_END(update_scal_tim)
 
 BENCH_START(flow_depbdy_tim)
-               IF( config_flags%specified ) THEN
+               IF( config_flags%specified .AND. ( .NOT. config_flags%have_bcs_moist ) ) THEN
                  IF(im .ne. P_QV)THEN
                    CALL flow_dep_bdy  (  moist(ims,kms,jms,im),                 &
                                 grid%ru_m, grid%rv_m, config_flags,             &
@@ -2539,7 +2548,10 @@ SUBROUTINE solve_em ( grid , config_flags  &
                                  grid%j_start(ij), grid%j_end(ij), &
                                  k_start    , k_end               )
 
-           IF( config_flags%nested .and. (rk_step == 1) ) THEN
+           IF( rk_step == 1 ) THEN
+             IF ( config_flags%nested .OR. &
+                ( config_flags%specified .AND. config_flags%have_bcs_scalar ) .OR. &
+                ( ( is .EQ. P_QNWFA .OR. is .EQ. P_QNIFA) .AND. config_flags%use_aero_icbc ) ) THEN
 
                CALL relax_bdy_scalar ( scalar_tend(ims,kms,jms,is),                            &
                                        scalar(ims,kms,jms,is),  grid%mut,                      &
@@ -2571,7 +2583,8 @@ SUBROUTINE solve_em ( grid , config_flags  &
                                        grid%j_start(ij), grid%j_end(ij),                       &
                                        k_start, k_end                                          )
 
-           ENDIF ! b.c test for chem nested boundary condition
+             ENDIF
+           ENDIF ! b.c test for scalars
 
          ENDDO scalar_tile_loop_1
          !$OMP END PARALLEL DO
@@ -2600,10 +2613,10 @@ SUBROUTINE solve_em ( grid , config_flags  &
                                   jts=grid%j_start(ij), jte=grid%j_end(ij),               &
                                   kts=k_start    , kte=k_end                              )
 
-           IF( config_flags%specified ) THEN
+           IF ( config_flags%specified ) THEN
 
-             IF(is .ne. P_QNN)THEN
-               CALL flow_dep_bdy  ( scalar(ims,kms,jms,is),     &
+             IF ( is .EQ. P_QNN ) THEN
+               CALL flow_dep_bdy_qnn  ( scalar(ims,kms,jms,is),     &
                                   grid%ru_m, grid%rv_m, config_flags,   &
                                   grid%spec_zone,                  &
                                   ids,ide, jds,jde, kds,kde,  & ! domain dims
@@ -2612,8 +2625,35 @@ SUBROUTINE solve_em ( grid , config_flags  &
                                   grid%i_start(ij), grid%i_end(ij),  &
                                   grid%j_start(ij), grid%j_end(ij),  &
                                   k_start, k_end                    )
-             ELSE
-               CALL flow_dep_bdy_qnn  ( scalar(ims,kms,jms,is),     &
+             ELSE IF ( ( ( ( is .EQ. P_QNWFA ) .OR. ( is .EQ. P_QNIFA ) ) .AND. &
+                         ( .NOT. config_flags%use_aero_icbc ) ) &
+                         .OR. &
+                       ( ( .NOT. ( ( is .EQ. P_QNWFA ) .OR. ( is .EQ. P_QNIFA ) ) ) .AND. &
+                         ( .NOT. config_flags%have_bcs_scalar ) ) ) THEN
+
+!     A = ( is .EQ. P_QNWFA ) .OR. ( is .EQ. P_QNIFA )
+!     B = config_flags%use_aero_icbc
+!     C = config_glags%have_bcs_scalar
+
+! Test| A  | B  | C | ( A AND NOT B ) OR ( NOT A AND NOT C ) 
+! ----+----+----+---+-----------------------------------------------
+!  1  | T  | T  | T |                 F = DO NOT CALL flow_dep_bdy
+!  2  | T  | T  | F |                 F = DO NOT CALL flow_dep_bdy
+!  3  | T  | F  | T |                 T =        CALL flow_dep_bdy
+!  4  | T  | F  | F |                 T =        CALL flow_dep_bdy
+!  5  | F  | T  | T |                 F = DO NOT CALL flow_dep_bdy
+!  6  | F  | T  | F |                 T =        CALL flow_dep_bdy
+!  7  | F  | F  | T |                 F = DO NOT CALL flow_dep_bdy
+!  8  | F  | F  | F |                 T =        CALL flow_dep_bdy
+! ----+----+----+---+-----------------------------------------------
+
+!  If this is     the special friendly fields AND are to use the aero icbc, then NO calls to flow dep: tests 1 and 2
+!  If this is     the special friendly fields AND do not use the aero icbc, then    call     flow dep: tests 3 and 4
+!  If this is not the special friendly fields AND: 
+!           If we        have bcs for scalars, do not call flow dep: tests 5 and 7
+!           If we do not have bcs for scalars,        call flow dep: tests 6 and 8
+
+               CALL flow_dep_bdy  ( scalar(ims,kms,jms,is),     &
                                   grid%ru_m, grid%rv_m, config_flags,   &
                                   grid%spec_zone,                  &
                                   ids,ide, jds,jde, kds,kde,  & ! domain dims
@@ -3248,10 +3288,10 @@ SUBROUTINE solve_em ( grid , config_flags  &
 
        CALL wrf_debug ( 200 , ' call moist_physics_prep' )
 BENCH_START(moist_physics_prep_tim)
-       CALL moist_physics_prep_em( grid%t_2, grid%t_1, t0, rho,                &
+       CALL moist_physics_prep_em( grid%t_2, grid%t_1, t0, grid%rho,           &
                                    grid%al, grid%alb, grid%p, p8w, p0, grid%pb,          &
-                                   grid%ph_2, grid%phb, th_phy, pi_phy, p_phy, &
-                                   grid%z, grid%z_at_w, dz8w,                  &
+                                   grid%ph_2, grid%phb, th_phy, pi_phy , p_phy, &
+                                   grid%z, grid%z_at_w, dz8w,        &
                                    dtm, grid%h_diabatic,                  &
                                    config_flags,grid%fnm, grid%fnp,            &
                                    ids, ide, jds, jde, kds, kde,     &
@@ -3288,13 +3328,17 @@ SUBROUTINE solve_em ( grid , config_flags  &
 !     ENDIF
 !     WRITE(wrf_err_message,*)'diag_flag=',diag_flag
 !     CALL wrf_debug ( 0 , wrf_err_message )
+#ifdef DM_PARALLEL
+#      include "HALO_EM_SBM.inc"
+#endif
+
 
      CALL microphysics_driver(                                            &
       &         DT=dtm             ,DX=grid%dx              ,DY=grid%dy   &
       &        ,DZ8W=dz8w          ,F_ICE_PHY=grid%f_ice_phy              &
       &        ,ITIMESTEP=grid%itimestep                    ,LOWLYR=grid%lowlyr  &
       &        ,P8W=p8w            ,P=p_phy            ,PI_PHY=pi_phy     &
-      &        ,RHO=rho            ,SPEC_ZONE=grid%spec_zone              &
+      &        ,RHO=grid%rho       ,SPEC_ZONE=grid%spec_zone              &
       &        ,SR=grid%sr              ,TH=th_phy                        &
       &        ,refl_10cm=grid%refl_10cm                                  & ! hm, 9/22/09 for refl
       &        ,WARM_RAIN=grid%warm_rain                                  &
@@ -3336,7 +3380,8 @@ SUBROUTINE solve_em ( grid , config_flags  &
       &        ,TURBTYPE3D=grid%turbtype3d,SMAW3D=grid%smaw3d             &
       &        ,WSEDL3D=grid%wsedl3d,CLDFRA_OLD_MP=grid%cldfra_old_mp     &
       &        ,CLDFRA_MP=grid%cldfra_mp,CLDFRA_MP_ALL=grid%cldfra_mp_ALL &
-      &        ,CLDFRAI=grid%cldfrai             &
+      &        ,LRADIUS=grid%LRADIUS, IRADIUS=grid%IRADIUS                & !BSINGH(01/20/2014): Added for RRTMG<->CAMMGMP
+      &        ,CLDFRAI=grid%cldfrai                                      &
       &        ,CLDFRAL=grid%cldfral,CLDFRA_CONV=grid%CLDFRA_CONV         &
       &        ,ALT=grid%alt                                              &
       &        ,ACCUM_MODE=config_flags%accum_mode                        &
@@ -3364,6 +3409,9 @@ SUBROUTINE solve_em ( grid , config_flags  &
       &        , QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS               &
       &        , QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG               &
       &        , QH_CURR=moist(ims,kms,jms,P_QH), F_QH=F_QH               & ! for milbrandt2mom
+      &        , QIC_CURR=moist(ims,kms,jms,P_QIC), F_QIC=F_QIC               &
+      &        , QIP_CURR=moist(ims,kms,jms,P_QIP), F_QIP=F_QIP               &
+      &        , QID_CURR=moist(ims,kms,jms,P_QID), F_QID=F_QID               &
       &        , QNDROP_CURR=scalar(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP &
 #ifdef WRF_CHEM
       &        , RAINPROD=grid%rainprod, EVAPPROD=grid%evapprod           &
@@ -3377,7 +3425,13 @@ SUBROUTINE solve_em ( grid , config_flags  &
       &        , QNR_CURR=scalar(ims,kms,jms,P_QNR), F_QNR=F_QNR          &
       &        , QNS_CURR=scalar(ims,kms,jms,P_QNS), F_QNS=F_QNS          &
       &        , QNG_CURR=scalar(ims,kms,jms,P_QNG), F_QNG=F_QNG          &
+      &        , QNWFA_CURR=scalar(ims,kms,jms,P_QNWFA), F_QNWFA=F_QNWFA  & ! for Thompson water-friendly aerosol
+      &        , QNIFA_CURR=scalar(ims,kms,jms,P_QNIFA), F_QNIFA=F_QNIFA  & ! for Thompson ice-friendly aerosol
       &        , QNH_CURR=scalar(ims,kms,jms,P_QNH), F_QNH=F_QNH          & ! for milbrandt2mom and nssl_2mom
+      &        , QNIC_CURR=scalar(ims,kms,jms,P_QNIC), F_QNIC=F_QNIC          &
+      &        , QNIP_CURR=scalar(ims,kms,jms,P_QNIP), F_QNIP=F_QNIP          &
+      &        , QNID_CURR=scalar(ims,kms,jms,P_QNID), F_QNID=F_QNID          &
+
 !       &        , QZR_CURR=scalar(ims,kms,jms,P_QZR), F_QZR=F_QZR          & ! for milbrandt3mom
 !       &        , QZI_CURR=scalar(ims,kms,jms,P_QZI), F_QZI=F_QZI          & ! "
 !       &        , QZS_CURR=scalar(ims,kms,jms,P_QZS), F_QZS=F_QZS          & ! "
@@ -3392,7 +3446,37 @@ SUBROUTINE solve_em ( grid , config_flags  &
 ! YLIN
 ! RI_CURR INPUT
       &        , RI_CURR=grid%rimi                                          &
+      &        , re_cloud=grid%re_cloud, re_ice=grid%re_ice, re_snow=grid%re_snow & ! G. Thompson
+      &        , has_reqc=grid%has_reqc, has_reqi=grid%has_reqi, has_reqs=grid%has_reqs & ! G. Thompson
+      &        , qnwfa2d=grid%qnwfa2d                                                   & ! G. Thompson
       &        , diagflag=diag_flag, do_radar_ref=config_flags%do_radar_ref &
+      &        ,u=grid%u_phy,v=grid%v_phy &
+      &        ,scalar=scalar,num_scalar=num_scalar                             &
+      &        ,TH_OLD=grid%th_old                                        &
+      &        ,QV_OLD=grid%qv_old                                        &
+      &        ,xlat=grid%xlat,xlong=grid%xlong,IVGTYP=grid%ivgtyp  &
+      &        , EFFR_CURR=scalar(ims,kms,jms,P_EFFR), F_EFFR=F_EFFR          & ! for SBM
+      &        , ICE_EFFR_CURR=scalar(ims,kms,jms,P_ICE_EFFR), F_ICE_EFFR=F_ICE_EFFR          & ! for SBM
+      &        , TOT_EFFR_CURR=scalar(ims,kms,jms,P_TOT_EFFR), F_TOT_EFFR=F_TOT_EFFR          & ! for SBM
+      &        , QIC_EFFR_CURR=scalar(ims,kms,jms,P_QIC_EFFR), F_QIC_EFFR=F_QIC_EFFR          & ! for SBM
+      &        , QIP_EFFR_CURR=scalar(ims,kms,jms,P_QIP_EFFR), F_QIP_EFFR=F_QIP_EFFR          & ! for SBM
+      &        , QID_EFFR_CURR=scalar(ims,kms,jms,P_QID_EFFR), F_QID_EFFR=F_QID_EFFR          & ! for SBM
+      &        ,kext_ql=grid%kext_ql                                       &
+      &        ,kext_qs=grid%kext_qs                                       &
+      &        ,kext_qg=grid%kext_qg                                       &
+      &        ,kext_qh=grid%kext_qh                                       &
+      &        ,kext_qa=grid%kext_qa                                       &
+      &        ,kext_qic=grid%kext_qic                                       &
+      &        ,kext_qip=grid%kext_qip                                       &
+      &        ,kext_qid=grid%kext_qid                                       &
+      &        ,kext_ft_qic=grid%kext_ft_qic                                       &
+      &        ,kext_ft_qip=grid%kext_ft_qip                                       &
+      &        ,kext_ft_qid=grid%kext_ft_qid                                       &
+      &        ,kext_ft_qs=grid%kext_ft_qs                                       &
+      &        ,kext_ft_qg=grid%kext_ft_qg         &
+      &        ,height=grid%height                                         &
+      &        ,tempc=grid%tempc                                         &
+
                                                                           )
 BENCH_END(micro_driver_tim)
 
@@ -3554,42 +3638,6 @@ SUBROUTINE solve_em ( grid , config_flags  &
 !  end filter for moist variables post-microphysics and end of timestep
 !-----------------------------------------------------------
 
-!-----------------------------------------------------------
-!  Lightning flash rate diagnostic production
-!-----------------------------------------------------------
-  IF ( config_flags%lightning_option /= 0 ) THEN
-    CALL lightning_driver ( &
-          ! Frequently used prognostics
-            grid%itimestep, grid%dt, grid%dx, grid%dy,         &
-            grid%xlat, grid%xlong, grid%xland, grid%ht,        &
-            grid%t_phy, p_phy, rho, u_phy, v_phy, grid%w_2,    &
-            grid%z, moist,                                     &
-          ! Scheme specific prognostics
-            grid%ktop_deep, grid%refl_10cm,                    &
-            domain_get_current_time( grid ),                   &
-          ! Flashrate namelist inputs
-            config_flags%lightning_option,                     &
-            config_flags%lightning_dt,                         &
-            config_flags%lightning_start_seconds,              &
-            config_flags%flashrate_factor,                     &
-          ! IC:CG namelist settings
-            config_flags%iccg_method,                          &
-            config_flags%iccg_prescribed_num,                  &
-            config_flags%iccg_prescribed_den,                  &
-          ! IC:CG inputs
-            grid%iccg_in_num, grid%iccg_in_den,                &
-          ! Scheme specific namelist inputs
-            config_flags%cellcount_method,                     &
-            config_flags%cldtop_adjustment,                    &
-          ! Order dependent args for domain, mem, and tile dims
-            ids, ide, jds, jde, kds, kde,         &
-            ims, ime, jms, jme, kms, kme,         &
-            ips, ipe, jps, jpe, kps, kpe,         &
-          ! Mandatory outputs for all quantitative schemes
-            grid%ic_flashcount, grid%ic_flashrate,          &
-            grid%cg_flashcount, grid%cg_flashrate           &
-      )
-   ENDIF
 
    !$OMP PARALLEL DO   &
    !$OMP PRIVATE ( ij, its, ite, jts, jte, im, ii, jj, kk )
@@ -3966,190 +4014,26 @@ SUBROUTINE solve_em ( grid , config_flags  &
    END DO
    !$OMP END PARALLEL DO
 
-! calculate some model diagnostics.
+!-----------------------------------------------------------
+!  After all of the RK steps, after the microphysics, after p-rho-phi,
+!  after w, after filtering, we have data ready to use.
+!-----------------------------------------------------------
+
+  CALL after_all_rk_steps ( grid, config_flags,                  &
+                            moist, chem, tracer, scalar,         &
+                            th_phy, pi_phy, p_phy, rho_phy,      &   
+                            p8w, t8w, dz8w,                      &
+                            curr_secs2,                          &
+                            diag_flag,                           &
+                            ids,  ide,  jds,  jde,  kds,  kde,   &
+                            ims,  ime,  jms,  jme,  kms,  kme,   &
+                            ips,  ipe,  jps,  jpe,  kps,  kpe,   &
+                            imsx, imex, jmsx, jmex, kmsx, kmex,  &
+                            ipsx, ipex, jpsx, jpex, kpsx, kpex,  &
+                            imsy, imey, jmsy, jmey, kmsy, kmey,  &
+                            ipsy, ipey, jpsy, jpey, kpsy, kpey   )
 
-   CALL wrf_debug ( 200 , ' call diagnostic_driver' )
-   
-   CALL diagnostic_output_calc(                                            &
-      &              DPSDT=grid%dpsdt   ,DMUDT=grid%dmudt                  &
-      &             ,P8W=p8w   ,PK1M=grid%pk1m                             &
-      &             ,MU_2=grid%mu_2  ,MU_2M=grid%mu_2m                     &
-      &             ,U=grid%u_2    ,V=grid%v_2                             &
-      &             ,RAINCV=grid%raincv    ,RAINNCV=grid%rainncv           &
-      &             ,RAINC=grid%rainc    ,RAINNC=grid%rainnc               &
-      &             ,I_RAINC=grid%i_rainc    ,I_RAINNC=grid%i_rainnc       &
-      &             ,HFX=grid%hfx   ,SFCEVP=grid%sfcevp    ,LH=grid%lh     &
-      &             ,DT=grid%dt      ,SBW=config_flags%spec_bdy_width      &
-      &             ,XTIME=grid%xtime   ,T2=grid%t2                        &
-      &        ,ACSWUPT=grid%acswupt    ,ACSWUPTC=grid%acswuptc            &
-      &        ,ACSWDNT=grid%acswdnt    ,ACSWDNTC=grid%acswdntc            &
-      &        ,ACSWUPB=grid%acswupb    ,ACSWUPBC=grid%acswupbc            &
-      &        ,ACSWDNB=grid%acswdnb    ,ACSWDNBC=grid%acswdnbc            &
-      &        ,ACLWUPT=grid%aclwupt    ,ACLWUPTC=grid%aclwuptc            &
-      &        ,ACLWDNT=grid%aclwdnt    ,ACLWDNTC=grid%aclwdntc            &
-      &        ,ACLWUPB=grid%aclwupb    ,ACLWUPBC=grid%aclwupbc            &
-      &        ,ACLWDNB=grid%aclwdnb    ,ACLWDNBC=grid%aclwdnbc            &
-      &      ,I_ACSWUPT=grid%i_acswupt  ,I_ACSWUPTC=grid%i_acswuptc        &
-      &      ,I_ACSWDNT=grid%i_acswdnt  ,I_ACSWDNTC=grid%i_acswdntc        &
-      &      ,I_ACSWUPB=grid%i_acswupb  ,I_ACSWUPBC=grid%i_acswupbc        &
-      &      ,I_ACSWDNB=grid%i_acswdnb  ,I_ACSWDNBC=grid%i_acswdnbc        &
-      &      ,I_ACLWUPT=grid%i_aclwupt  ,I_ACLWUPTC=grid%i_aclwuptc        &
-      &      ,I_ACLWDNT=grid%i_aclwdnt  ,I_ACLWDNTC=grid%i_aclwdntc        &
-      &      ,I_ACLWUPB=grid%i_aclwupb  ,I_ACLWUPBC=grid%i_aclwupbc        &
-      &      ,I_ACLWDNB=grid%i_aclwdnb  ,I_ACLWDNBC=grid%i_aclwdnbc        &
-                  ! Selection flag
-      &             ,DIAG_PRINT=config_flags%diag_print                    &
-      &             ,BUCKET_MM=config_flags%bucket_mm                      &
-      &             ,BUCKET_J =config_flags%bucket_J                       &
-      &             ,SNOWNCV=grid%snowncv, SNOW_ACC_NC=grid%snow_acc_nc    &
-      &             ,PREC_ACC_C=grid%prec_acc_c                            &
-      &             ,PREC_ACC_NC=grid%prec_acc_nc                          &
-      &             ,PREC_ACC_DT=config_flags%prec_acc_dt                  &
-      &             ,CURR_SECS=curr_secs                                   &
-      &             ,NWP_DIAGNOSTICS=config_flags%nwp_diagnostics          &
-      &             ,DIAGFLAG=diag_flag                                    &
-      &             ,HISTORY_INTERVAL=grid%history_interval                &
-      &             ,ITIMESTEP=grid%itimestep                              &
-      &             ,U10=grid%u10,V10=grid%v10,W=grid%w_2                  &
-      &             ,WSPD10MAX=grid%wspd10max                              &
-      &             ,UP_HELI_MAX=grid%up_heli_max                          &
-      &             ,W_UP_MAX=grid%w_up_max,W_DN_MAX=grid%w_dn_max         &
-      &             ,ZNW=grid%znw,W_COLMEAN=w_colmean                      &
-      &             ,NUMCOLPTS=numcolpts,W_MEAN=grid%w_mean                &
-      &             ,GRPL_MAX=grid%grpl_max,GRPL_COLINT=grpl_colint        &
-      &             ,REFD_MAX=grid%refd_max                                &
-      &             ,refl_10cm=grid%refl_10cm                              &
-      &             ,QG_CURR=moist(ims,kms,jms,P_QG)                       &
-      &             ,RHO=rho,PH=grid%ph_2,PHB=grid%phb,G=g                 &
-                  ! Dimension arguments
-      &             ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde     &
-      &             ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme     &
-      &             ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe     &
-      &             ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1)     &
-      &             ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1)     &
-      &             ,KTS=k_start, KTE=min(k_end,kde-1)                     &
-      &             ,NUM_TILES=grid%num_tiles                              &
-      &                                                          )
-
-   IF (config_flags%output_diagnostics == 1) THEN
-     IF ((config_flags%auxhist3_interval == 0 ) ) THEN
-        WRITE (wrf_err_message , * )"CLWRF: ERROR -- error -- ERROR -- error : NO 'auxhist3_interval' has been defined in 'namelist.input'"
-        CALL wrf_error_fatal ( TRIM(wrf_err_message) )
-     END IF
-     CALL wrf_debug ( 200 , ' CLWRF: call diagnostic_calc' )
-     CALL clwrf_output_calc(                                               &
-        &            DPSDT=grid%dpsdt   ,DMUDT=grid%dmudt                  &
-        &           ,P8W=p8w   ,PK1M=grid%pk1m                             &
-        &           ,MU_2=grid%mu_2  ,MU_2M=grid%mu_2m                     &
-        &           ,U=grid%u_2    ,V=grid%v_2                             &
-        &           ,is_restart=config_flags%restart                       &
-        &           ,clwrfH=config_flags%auxhist3_interval                 &
-        &           ,T2=grid%t2, Q2=grid%q2, U10=grid%u10, V10=grid%v10    &
-        &           ,SKINTEMP=grid%tsk                                     &
-        &           ,T2CLMIN=grid%t2min, T2CLMAX=grid%t2max                &
-        &           ,TT2CLMIN=grid%tt2min, TT2CLMAX=grid%tt2max            &
-        &           ,T2CLMEAN=grid%t2mean, T2CLSTD=grid%t2std              &
-        &           ,Q2CLMIN=grid%q2min, Q2CLMAX=grid%q2max                &
-        &           ,TQ2CLMIN=grid%tq2min, TQ2CLMAX=grid%tq2max            &
-        &           ,Q2CLMEAN=grid%q2mean, Q2CLSTD=grid%q2std              &
-        &           ,U10CLMAX=grid%u10max, V10CLMAX=grid%v10max            &
-        &           ,SPDUV10CLMAX=grid%spduv10max                          &
-        &           ,TSPDUV10CLMAX=grid%tspduv10max                        &
-        &           ,U10CLMEAN=grid%u10mean, V10CLMEAN=grid%v10mean        &
-        &           ,SPDUV10CLMEAN=grid%spduv10mean                        &
-        &           ,U10CLSTD=grid%u10std, V10CLSTD=grid%v10std            &
-        &           ,SPDUV10CLSTD=grid%spduv10std                          &
-        &           ,RAINCCLMAX=grid%raincvmax                             &
-        &           ,RAINNCCLMAX=grid%rainncvmax                           &
-        &           ,TRAINCCLMAX=grid%traincvmax                           &
-        &           ,TRAINNCCLMAX=grid%trainncvmax                         &
-        &           ,RAINCCLMEAN=grid%raincvmean                           &
-        &           ,RAINNCCLMEAN=grid%rainncvmean                         &
-        &           ,RAINCCLSTD=grid%raincvstd                             &
-        &           ,RAINNCCLSTD=grid%rainncvstd                           &
-        &           ,SKINTEMPCLMIN=grid%skintempmin                        &
-        &           ,SKINTEMPCLMAX=grid%skintempmax                        &
-        &           ,TSKINTEMPCLMIN=grid%tskintempmin                      &
-        &           ,TSKINTEMPCLMAX=grid%tskintempmax                      &
-        &           ,SKINTEMPCLMEAN=grid%skintempmean                      &
-        &           ,SKINTEMPCLSTD=grid%skintempstd                        &
-        &           ,RAINCV=grid%raincv    ,RAINNCV=grid%rainncv           &
-        &           ,RAINC=grid%rainc    ,RAINNC=grid%rainnc               &
-        &           ,I_RAINC=grid%i_rainc    ,I_RAINNC=grid%i_rainnc       &
-        &           ,HFX=grid%hfx   ,SFCEVP=grid%sfcevp    ,LH=grid%lh     &
-        &           ,DT=grid%dt      ,SBW=config_flags%spec_bdy_width      &
-        &           ,XTIME=grid%xtime                                      &
-                    ! Selection flag
-        &           ,DIAG_PRINT=config_flags%diag_print                    &
-        &           ,BUCKET_MM=config_flags%bucket_mm                      &
-        &           ,BUCKET_J =config_flags%bucket_J                       &
-                    ! Dimension arguments
-        &           ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde     &
-        &           ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme     &
-        &           ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe     &
-        &           ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1)     &
-        &           ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1)     &
-        &           ,KTS=k_start, KTE=min(k_end,kde-1)                     &
-        &           ,NUM_TILES=grid%num_tiles                              &
-        &                                                          )
-   ENDIF
 
-   IF ( config_flags%p_lev_diags .NE. SKIP_PRESS_DIAGS ) THEN
-     !  Process the diags if this is the correct time step OR
-     !  if this is an adaptive timestep forecast.
-     IF ( ( ( MOD(NINT(curr_secs+grid%dt),NINT(config_flags%p_lev_interval)) .EQ. 0 ) ) .OR. &
-            ( config_flags%use_adaptive_time_step ) ) THEN
-       !$OMP PARALLEL DO   &
-       !$OMP PRIVATE ( ij )
-       DO ij = 1 , grid%num_tiles
-         CALL wrf_debug ( 200 , ' PLD: pressure level diags' )
-         CALL pld (                                  &
-                      !  Input data for computing
-                       U=grid%u_2                    &
-                      ,V=grid%v_2                    &
-                      ,W=grid%w_2                    &
-                      ,t=grid%t_2                    &
-                      ,qv=moist(:,:,:,P_QV)          &
-                      ,zp=grid%ph_2                  &
-                      ,zb=grid%phb                   &
-                      ,pp=grid%p                     &
-                      ,pb=grid%pb                    &
-                      ,p=grid%p_hyd                  &
-                      ,pw=grid%p_hyd_w               &
-                      !  Map factors, coriolis for diags
-                      ,msfux=grid%msfux              &
-                      ,msfuy=grid%msfuy              &
-                      ,msfvx=grid%msfvx              &
-                      ,msfvy=grid%msfvy              &
-                      ,msftx=grid%msftx              &
-                      ,msfty=grid%msfty              &
-                      ,f=grid%f                      &
-                      ,e=grid%e                      &
-                      !  Namelist info
-                      ,use_tot_or_hyd_p=config_flags%use_tot_or_hyd_p &
-                      ,missing=config_flags%p_lev_missing &
-                      !  The diagnostics, mostly output variables
-                      ,num_press_levels=config_flags%num_press_levels &
-                      ,max_press_levels=max_plevs    &
-                      ,press_levels=model_config_rec%press_levels &
-                      ,p_pl  = grid%p_pl             &
-                      ,u_pl  = grid%u_pl             &
-                      ,v_pl  = grid%v_pl             &
-                      ,t_pl  = grid%t_pl             &
-                      ,rh_pl = grid%rh_pl            &
-                      ,ght_pl= grid%ght_pl           &
-                      ,s_pl  = grid%s_pl             &
-                      ,td_pl = grid%td_pl            &
-                      !  Dimension arguments
-                      ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde    &
-                      ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme    &
-                      ,ITS=grid%i_start(ij),ITE=grid%i_end(ij)              &
-                      ,JTS=grid%j_start(ij),JTE=grid%j_end(ij)              &
-                      ,KTS=kps,KTE=kpe                                      )
-       END DO
-       !$OMP END PARALLEL DO
-     ENDIF
-   ENDIF
 
 #ifdef DM_PARALLEL
 !-----------------------------------------------------------------------
@@ -4232,6 +4116,10 @@ SUBROUTINE solve_em ( grid , config_flags  &
 
    CALL wrf_debug ( 200 , ' call end of solve_em' )
 
+!  Are we about to read SST input from the wrflowinput file?  That data is saved
+!  for use in fractional merging of external/coupled SST and input SST. 
+   IF ( coupler_on )   grid%just_read_auxinput4 = Is_alarm_tstep(grid%domain_clock, grid%alarms(AUXINPUT4_ALARM))
+
 ! Finish timers if compiled with -DBENCH.
 #include 
 
diff --git a/wrfv2_fire/dyn_em/start_em.F b/wrfv2_fire/dyn_em/start_em.F
index e3aae68a..9b9e183c 100644
--- a/wrfv2_fire/dyn_em/start_em.F
+++ b/wrfv2_fire/dyn_em/start_em.F
@@ -26,7 +26,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
    USE module_physics_init
    USE module_lightning_driver, ONLY : lightning_init
    USE module_fr_fire_driver_wrf, ONLY : fire_driver_em_init
-   USE module_stoch, ONLY : SETUP_STOCH, update_stoch
+   USE module_stoch, ONLY : SETUP_STOCH_SPPT,SETUP_STOCH_SKEBS,rand_seed, update_stoch
 #ifdef WRF_CHEM
    USE module_aerosols_sorgam, ONLY: sum_pm_sorgam
    USE module_gocart_aerosols, ONLY: sum_pm_gocart
@@ -34,7 +34,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
    USE module_input_tracer, ONLY: initialize_tracer
    USE module_aerosols_soa_vbs, only: sum_pm_soa_vbs
 #endif
-   USE module_diagnostics, ONLY : pld
+   USE module_diag_pld, ONLY : pld
 
 !!debug
 !USE module_compute_geop
@@ -107,6 +107,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 ! Define variables local (topo_wind local vars)
    REAL    :: alpha, vfac
 
+!..Need to fill special height var for setting up initial condition.  G. Thompson
+   REAL, ALLOCATABLE, DIMENSION(:,:,:) :: z_at_q
+
    CALL get_ijk_from_grid ( grid ,                              &
                            ids, ide, jds, jde, kds, kde,        &
                            ims, ime, jms, jme, kms, kme,        &
@@ -122,6 +125,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 #ifndef WRF_CHEM
          ALLOCATE(CLDFRA_OLD(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; CLDFRA_OLD = 0.
 #endif
+   ALLOCATE(z_at_q(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; z_at_q = 0.
    CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
 
    IF ( ( MOD (ide-ids,config_flags%parent_grid_ratio) .NE. 0 ) .OR. &
@@ -178,29 +182,74 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
        first_trip_for_this_domain = .TRUE.
    ENDIF
 
-!   --- SETUP AND INITIALIZE STOCHASTIC KINETIC ENERGY BACKSCATTER SCHEME ---
+!   --- SETUP AND INITIALIZE STOCHASTIC PERTURBATION SCHEMES ---
 
    IF ( first_trip_for_this_domain ) THEN
      grid%did_stoch = .FALSE.
    END IF
 
    IF ( ( grid%id == 1 ) .AND. &
-        ( NINT(grid%stoch_force_global_opt) == 1 ) .AND. &
+        ( grid%stoch_force_global_opt == 1 ) .AND. &
         ( .NOT. grid%did_stoch ) ) THEN
 
      grid%did_stoch = .TRUE.
+     IF ( wrf_dm_on_monitor () ) THEN
+       CALL rand_seed ( config_flags, grid%SEED1, grid%SEED2, grid%NENS )
+     ENDIF
+#ifdef DM_PARALLEL
+     CALL wrf_dm_bcast_bytes ( grid%SEED1, IWORDSIZE )
+     CALL wrf_dm_bcast_bytes ( grid%SEED2, IWORDSIZE )
+#endif
 
-     call SETUP_STOCH(grid%VERTSTRUCC,grid%VERTSTRUCS,                   &
+     IF (grid%stoch_force_opt==1) then
+     grid%SPTFORCC=0.0
+     grid%SPTFORCS=0.0
+     call SETUP_STOCH_SKEBS(grid%VERTSTRUCC,grid%VERTSTRUCS,                   &
                       grid%SPT_AMP,grid%SPSTREAM_AMP,                    &
-                      grid%stoch_vertstruc_opt,                          & 
-                      grid%time_step,grid%DX,grid%DY,grid%NENS,          &
+                      grid%VERTAMPT,grid%VERTAMPUV,                      &
+                      grid%stoch_vertstruc_opt,                          &
+                      grid%SEED1,grid%SEED2,grid%time_step,              &
+                      grid%DX,grid%DY,                                   &
                       grid%TOT_BACKSCAT_PSI,grid%TOT_BACKSCAT_T,         &
+                      grid%ZTAU_PSI,grid%ZTAU_T,grid%REXPONENT_PSI,grid%REXPONENT_T,               &
+                      grid%KMINFORC,grid%KMAXFORC,grid%LMINFORC,grid%LMAXFORC,     &
+                      grid%KMINFORCT,grid%KMAXFORCT,grid%LMINFORCT,grid%LMAXFORCT, &
+                      grid%KMAXFORCH,grid%LMAXFORCH,grid%KMAXFORCTH,grid%LMAXFORCTH, &
+                      grid%ZSIGMA2_EPS,grid%ZSIGMA2_ETA,                          &
                       ids, ide, jds, jde, kds, kde,                      &
                       ims, ime, jms, jme, kms, kme,                      &
                       its, ite, jts, jte, kts, kte                       )
-    
+     END IF
+     IF (grid%stoch_force_opt==2) then
+
+        call SETUP_STOCH_SPPT(grid%VERTSTRUCC,grid%VERTSTRUCS,            &
+                       grid%SPT_AMP,                                      &
+                       grid%SPTFORCC,grid%SPTFORCS,                       &
+                       grid%VERTAMPT,grid%VERTAMPUV,                      &
+                       grid%stoch_vertstruc_opt,                          &
+                       grid%SEED1,grid%SEED2,grid%time_step,              &
+                       grid%DX,grid%DY,                                   &
+                       grid%gridpointvariance,grid%l_sppt,grid%tau_sppt,  &
+                       grid%KMINFORCT,grid%KMAXFORCT,grid%LMINFORCT,grid%LMAXFORCT, &
+                       grid%KMAXFORCTH,grid%LMAXFORCTH, &
+                       ids, ide, jds, jde, kds, kde,                      &
+                       ims, ime, jms, jme, kms, kme,                      &
+                       its, ite, jts, jte, kts, kte                       )
+     ENDIF 
+     do i=1,600
+     CALL UPDATE_STOCH(grid%SPSTREAMFORCS,grid%SPSTREAMFORCC,           &
+                      grid%SPTFORCS,grid%SPTFORCC,                        &
+                      grid%SPT_AMP,grid%SPSTREAM_AMP,                     &
+                      ids, ide, jds, jde, kds, kde,                       &
+                      ims, ime, jms, jme, kms, kme,                       &
+                      its, ite, jts, jte, kts, kte                       )
+     enddo
+
+
     END IF
-!   --- END SETUP STOCHASTIC KINETIC ENERGY BACKSCATTER SCHEME ----------
+!   --- END SETUP STOCHASTIC PERTURBATION SCHEMES ----------
+
+
 
 ! wig: Add a combined exponential+linear weight on the mother boundaries
 !      following code changes by Ruby Leung. For the nested grid, there
@@ -593,6 +642,14 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 
    ENDIF
 
+   DO j=jts,min(jte,jde-1)
+      DO k = kts,kte
+         DO i = its, min(ite,ide-1)
+            z_at_q(i,k,j)=(grid%ph_2(i,k,j)+grid%phb(i,k,j))/g
+         ENDDO
+      ENDDO
+   ENDDO
+
    IF ( grid%press_adj .and. ( grid%id .NE. 1 ) .AND. .NOT. ( config_flags%restart ) .AND. &
        ( ( config_flags%input_from_hires ) .OR. ( config_flags%input_from_file ) ) ) THEN
       DO j = jts, MIN(jte,jde-1)
@@ -609,6 +666,10 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 
    END IF
 
+! set GMT outside of phy_init because phy_init may not be called on this
+! process if, for example, it is a moving nest and if this part of the domain is not
+! being initialized (not the leading edge).
+   CALL domain_setgmtetc( grid, start_of_simulation )
    IF ( first_trip_for_this_domain ) THEN
 
    CALL wrf_debug ( 100 , 'start_domain_em: Before call to phy_init' )
@@ -617,10 +678,6 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 ! MPDT is the call frequency for microphysics in minutes (0 means every step)
    MPDT = 0.
 
-! set GMT outside of phy_init because phy_init may not be called on this
-! process if, for example, it is a moving nest and if this part of the domain is not
-! being initialized (not the leading edge).
-   CALL domain_setgmtetc( grid, start_of_simulation )
 !tgs
    IF(config_flags%cycling) start_of_simulation = .true.
 !  print *,'cycling, start_of_simulation -->',config_flags%cycling, start_of_simulation
@@ -695,6 +752,13 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 ! Phy_init is not necessarily thread-safe; do not multi-thread this loop.
 ! The tiling is to handle the fact that we may be masking off part of the computation.
 !
+
+#ifdef DM_PARALLEL
+if(config_flags%sf_surface_physics.eq.NOAHMPSCHEME.and.config_flags%opt_run.eq.5)then
+#  include "HALO_EM_HYDRO_NOAHMP_INIT.inc"
+endif
+#endif
+
    DO ij = 1, grid%num_tiles
 
 !tgs do not need physics initialization for backward DFI integration
@@ -706,7 +770,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
                       grid%p_top, grid%tsk, grid%RADT,grid%BLDT,grid%CUDT, MPDT, &
                       grid%rucuten, grid%rvcuten, grid%rthcuten,             &
                       grid%rqvcuten, grid%rqrcuten, grid%rqccuten,           &
-                      grid%rqscuten, grid%rqicuten,  &
+                      grid%rqscuten, grid%rqicuten,                          &
                       grid%rushten, grid%rvshten, grid%rthshten,             &
                       grid%rqvshten, grid%rqrshten, grid%rqcshten,           &
                       grid%rqsshten, grid%rqishten, grid%rqgshten,           &
@@ -716,6 +780,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
                       grid%stepbl,grid%stepra,grid%stepcu,                   &
                       grid%w0avg, grid%rainnc, grid%rainc, grid%raincv, grid%rainncv,  &
                       grid%snownc, grid%snowncv, grid%graupelnc, grid%graupelncv,  &
+                      z_at_q, grid%qnwfa2d, scalar(ims,kms,jms,1), num_scalar,         & ! G. Thompson
+                      grid%re_cloud, grid%re_ice, grid%re_snow,         & ! G. Thompson
+                      grid%has_reqc, grid%has_reqi, grid%has_reqs,      & ! G. Thompson
                       grid%nca,grid%swrad_scat,                    &
                       grid%cldefi,grid%lowlyr,                          &
                       grid%mass_flux,                              &
@@ -732,7 +799,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
                       grid%landuse_ISICE, grid%landuse_LUCATS,            &
                       grid%landuse_LUSEAS, grid%landuse_ISN,              &
                       grid%lu_state,                                      &
-                      grid%xlat,grid%xlong,grid%albedo,grid%albbck,grid%GMT,grid%JULYR,grid%JULDAY,     &
+                      grid%xlat,grid%xlong,grid%xlong_u,grid%xlat_v,grid%albedo,grid%albbck,grid%GMT,grid%JULYR,grid%JULDAY,     &
                       grid%levsiz, num_ozmixm, num_aerosolc, grid%paerlev,  &
                       grid%alevsiz, grid%no_src_types,                      &
                       grid%tmn,grid%xland,grid%znt,grid%z0,grid%ust,grid%mol,grid%pblh,grid%tke_pbl,    &
@@ -758,7 +825,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
                       grid%raincv_a,grid%raincv_b,                                    &
                       grid%gd_cloud, grid%gd_cloud2,                                  & ! Optional
                       grid%gd_cloud_a, grid%gd_cloud2_a,                              & ! Optional
-                      grid%gd_cloud_b, grid%gd_cloud2_b,                              & ! Optional
+                      grid%QC_CU, grid%QI_CU,                                         & ! Optional
                       ozmixm,grid%pin,                             &     ! Optional
                       grid%aerodm,grid%pina,                       &     ! Optional
                       grid%m_ps_1,grid%m_ps_2,grid%m_hybi,aerosolc_1,aerosolc_2,&  ! Optional
@@ -775,6 +842,10 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
                       grid%STMASSXY, grid%WOODXY, grid%STBLCPXY, grid%FASTCPXY,                 &   ! Optional Noah-MP
                       grid%XSAIXY,                                                              &   ! Optional Noah-MP
                       grid%T2MVXY, grid%T2MBXY, grid%CHSTARXY,                                  &   ! Optional Noah-MP
+                      grid%SMOISEQ  ,grid%SMCWTDXY ,grid%RECHXY, grid%DEEPRECHXY, grid%AREAXY,  & ! Optional Noah-MP
+                      config_flags%wtddt ,grid%stepwtd ,grid%QRFSXY ,grid%QSPRINGSXY ,grid%QSLATXY, & ! Optional Noah-MP
+                      grid%FDEPTHXY, grid%RIVERBEDXY, grid%EQZWT, grid%RIVERCONDXY, grid%PEXPXY, & ! Optional Noah-MP
+                      grid%msftx, grid%msfty,                              &
                       grid%DZR, grid%DZB, grid%DZG,                          & !Optional urban
                       grid%TR_URB2D,grid%TB_URB2D,grid%TG_URB2D,grid%TC_URB2D,    & !Optional urban
                       grid%QC_URB2D, grid%XXXR_URB2D,grid%XXXB_URB2D,        & !Optional urban
@@ -795,8 +866,17 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
                       grid%B_Q_BEP,grid%B_E_BEP,grid%DLG_BEP,                          & !multi-layer urban
                       grid%DL_U_BEP,grid%SF_BEP,grid%VL_BEP,                           & !multi-layer urban
                       grid%TML,grid%T0ML,grid%HML,grid%H0ML,grid%HUML,grid%HVML,grid%TMOML,     & !Optional oml
-                      grid%TSK_SAVE,                                                   & !Optional fractional seaice
-              grid%numc,grid%nump,grid%snl,grid%snowdp,&   ! start of CLM variables
+                      grid%lakedepth2d,  grid%savedtke12d,  grid%snowdp2d,   grid%h2osno2d,       & !lake
+                      grid%snl2d,        grid%t_grnd2d,     grid%t_lake3d,   grid%lake_icefrac3d, & !lake
+                      grid%z_lake3d,     grid%dz_lake3d,    grid%t_soisno3d, grid%h2osoi_ice3d,   & !lake
+                      grid%h2osoi_liq3d, grid%h2osoi_vol3d, grid%z3d,        grid%dz3d,           & !lake
+                      grid%zi3d,         grid%watsat3d,     grid%csol3d,     grid%tkmg3d,         & !lake
+                      grid%tkdry3d,      grid%tksatu3d,     grid%lake2d,                            & !lake
+                      config_flags%lakedepth_default,        config_flags%lake_min_elev, grid%lake_depth,     & !lake
+                      grid%lakemask,        grid%lakeflag,  grid%LAKE_DEPTH_FLAG, grid%use_lakedepth,     & !lake
+                      config_flags%sf_surface_mosaic, config_flags%mosaic_cat, config_flags%num_land_cat, & ! Noah tiling
+                      config_flags%maxpatch,           &   ! start of CLM variables
+              grid%numc,grid%nump,grid%snl,grid%snowdp,&   !
               grid%wtc,grid%wtp,&
               grid%h2osno,grid%t_grnd,grid%t_veg,grid%h2ocan, &
               grid%h2ocan_col,grid%t2m_max,grid%t2m_min,&
@@ -842,13 +922,14 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
               grid%h2osoi_vol6,&
               grid%h2osoi_vol7,grid%h2osoi_vol8,&
               grid%h2osoi_vol9,grid%h2osoi_vol10,&
-              grid%ht,config_flags%maxpatch,    &
+              grid%ht,                          &
               grid%ALBEDOsubgrid,grid%LHsubgrid,&
               grid%HFXsubgrid,grid%LWUPsubgrid,&
               grid%Q2subgrid,grid%SABVsubgrid,  &
               grid%SABGsubgrid,grid%NRAsubgrid,&
               grid%SWUPsubgrid,grid%lhsoi, &
               grid%lhveg, grid%lhtran, & !end of CLM variables
+                      grid%TSK_SAVE,                        & !Optional fractional seaice
                       grid%itimestep, grid%fdob,            &
                       t00, p00, a,                      & ! for obs_nudge base state
                       grid%TYR, grid%TYRA, grid%TDLY, grid%TLAG, grid%NYEAR, grid%NDAY,grid%tmn_update, &
@@ -860,10 +941,26 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
                       config_flags%nssl_rho_qh, config_flags%nssl_rho_qhl,    &
                       config_flags%nssl_rho_qs                                &
                       ,grid%RQCNCUTEN, grid%RQINCUTEN,grid%rliq             &      !mchen add for cammpmg
+                      ,grid%cldfra_dp,grid%cldfra_sh                        & ! ckay for subgrid cloud
                       ,grid%te_temf,grid%cf3d_temf,grid%wm_temf        & ! WA
                       ,grid%massflux_EDKF, grid%entr_EDKF, grid%detr_EDKF                & 
                       ,grid%thl_up,grid%thv_up,grid%rt_up                                &
                       ,grid%rv_up,grid%rc_up,grid%u_up,grid%v_up,grid%frac_up            &
+                      ,grid%QKE                                               &!JOE-for mynn
+                      ,grid%landusef,grid%landusef2,grid%mosaic_cat_index                            & ! danli mosaic 
+                      ,grid%TSK_mosaic,grid%TSLB_mosaic,grid%SMOIS_mosaic,grid%SH2O_mosaic           & ! danli mosaic
+                      ,grid%CANWAT_mosaic,grid%SNOW_mosaic,grid%SNOWH_mosaic,grid%SNOWC_mosaic       & ! danli mosaic
+                      ,grid%ALBEDO_mosaic,grid%ALBBCK_mosaic, grid%EMISS_mosaic                      & ! danli mosaic
+                      ,grid%EMBCK_mosaic, grid%ZNT_mosaic, grid%Z0_mosaic                            & ! danli mosaic
+                      ,grid%TR_URB2D_mosaic,grid%TB_URB2D_mosaic                                     & ! danli mosaic 
+                      ,grid%TG_URB2D_mosaic,grid%TC_URB2D_mosaic                                     & ! danli mosaic 
+                      ,grid%QC_URB2D_mosaic                                                          & ! danli mosaic
+                      ,grid%TRL_URB3D_mosaic,grid%TBL_URB3D_mosaic                                   & ! danli mosaic 
+                      ,grid%TGL_URB3D_mosaic                                                         & ! danli mosaic 
+                      ,grid%SH_URB2D_mosaic,grid%LH_URB2D_mosaic                                     & ! danli mosaic 
+                      ,grid%G_URB2D_mosaic,grid%RN_URB2D_mosaic                                      & ! danli mosaic 
+                      ,grid%TS_URB2D_mosaic                                                          & ! danli mosaic 
+                      ,grid%TS_RUL2D_mosaic                                                          & ! danli mosaic
                       )
        ENDIF   !tgs
 
@@ -1009,6 +1106,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 #  include "PERIOD_BDY_EM_TKE.inc"
 #  include "PERIOD_BDY_EM_SCALAR.inc"
 #  include "PERIOD_BDY_EM_CHEM.inc"
+if(config_flags%sf_surface_physics.eq.NOAHMPSCHEME.and.config_flags%opt_run.eq.5)then
+#  include "HALO_EM_HYDRO_NOAHMP_INIT.inc"
+endif
 #endif
 
 
@@ -1361,11 +1461,13 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
                          grid%tauaerlw5,grid%tauaerlw6,grid%tauaerlw7,grid%tauaerlw8,           &
                          grid%tauaerlw9,grid%tauaerlw10,grid%tauaerlw11,grid%tauaerlw12,        &
                          grid%tauaerlw13,grid%tauaerlw14,grid%tauaerlw15,grid%tauaerlw16,       &
+                         grid%dgnum4d, grid%dgnumwet4d, grid%dgnum_a1, grid%dgnum_a2,           & 
+                         grid%dgnum_a3, grid%dgnumwet_a1, grid%dgnumwet_a2, grid%dgnumwet_a3,   &
                          grid%pm2_5_dry,grid%pm2_5_water,grid%pm2_5_dry_ec,                &
                          grid%last_chem_time_year,grid%last_chem_time_month,               &
                          grid%last_chem_time_day,grid%last_chem_time_hour,                 &
                          grid%last_chem_time_minute,grid%last_chem_time_second,            &
-                         grid%chem_in_opt,grid%kemit,                       &
+                         grid%chem_in_opt,grid%kemit,grid%num_vert_mix,                       &
                          ids , ide , jds , jde , kds , kde ,                &
                          ims , ime , jms , jme , kms , kme ,                &
                          its , ite , jts , jte , kts , kte                  )
@@ -1381,7 +1483,8 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
                 ids,ide, jds,jde, kds,kde,                                  &
                 ims,ime, jms,jme, kms,kme,                                  &
                 its,ite, jts,jte, kts,kte-1                                 )
-        case (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RADM2SORG_KPP,RACMSORG_AQ,RACMSORG_AQCHEM,RACMSORG_KPP)
+        case (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RADM2SORG_KPP,RACMSORG_AQ,RACMSORG_AQCHEM_KPP, &
+              RACM_ESRLSORG_AQCHEM_KPP,RACMSORG_KPP)
            call sum_pm_sorgam (                                             &
                 grid%alt, chem, grid%h2oaj, grid%h2oai,                                    &
                 grid%pm2_5_dry, grid%pm2_5_water, grid%pm2_5_dry_ec, grid%pm10,                 &
@@ -1398,7 +1501,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 
         case (CBMZ_MOSAIC_4BIN,CBMZ_MOSAIC_8BIN,CBMZ_MOSAIC_4BIN_AQ,CBMZ_MOSAIC_8BIN_AQ, &
               CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ,       &
-              CBMZ_MOSAIC_DMS_8BIN_AQ)
+              CBMZ_MOSAIC_DMS_8BIN_AQ, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP)
            call sum_pm_mosaic (                                             &
                 grid%alt, chem,                                                  &
                 grid%pm2_5_dry, grid%pm2_5_water, grid%pm2_5_dry_ec, grid%pm10,                 &
@@ -1512,6 +1615,8 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 #  include "PERIOD_BDY_EM_CHEM.inc"
 #endif
 
+DEALLOCATE(z_at_q)
+
    IF (config_flags%p_lev_diags == PRESS_DIAGS ) THEN
     CALL wrf_debug ( 200 , ' PLD: pressure level diags' )
     CALL pld (                                  &
diff --git a/wrfv2_fire/dyn_nmm/Makefile b/wrfv2_fire/dyn_nmm/Makefile
index 223c2bc7..69f2142e 100644
--- a/wrfv2_fire/dyn_nmm/Makefile
+++ b/wrfv2_fire/dyn_nmm/Makefile
@@ -25,6 +25,9 @@ MODULES =                 		\
 	module_SMOOTH_TERRAIN.o         \
         module_PHYSICS_CALLS.o          \
         module_IGWAVE_ADJUST.o          \
+	module_membrane_mslp.o		\
+	module_tracker.o		\
+	module_relax.o			\
 	$(CASE_MODULE)
 
 # moved into share/Makefile
diff --git a/wrfv2_fire/dyn_nmm/depend.dyn_nmm b/wrfv2_fire/dyn_nmm/depend.dyn_nmm
index 81edf9b5..2d8aa707 100644
--- a/wrfv2_fire/dyn_nmm/depend.dyn_nmm
+++ b/wrfv2_fire/dyn_nmm/depend.dyn_nmm
@@ -5,14 +5,18 @@ solve_nmm.o:   module_BC_NMM.o module_STATS_FOR_MOVE.o \
                module_NONHY_DYNAM.o module_DIFFUSION_NMM.o    \
                module_BNDRY_COND.o module_PHYSICS_CALLS.o \
                module_CTLBLK.o module_HIFREQ.o \
+               ../phys/module_diag_refl.o \
                ../share/module_random.o ../frame/hires_timer.o
 
+module_membrane_mslp.o: module_relax.o ../frame/module_dm.o ../frame/module_domain.o
+module_tracker.o: module_relax.o ../frame/module_dm.o ../frame/module_domain.o
+
 NMM_NEST_UTILS1.o: module_TERRAIN.o module_SMOOTH_TERRAIN.o \
 	../frame/module_dm.o ../frame/module_domain.o \
 	../frame/module_configure.o ../frame/module_timing.o
 
 module_STATS_FOR_MOVE.o: ../frame/module_dm.o ../frame/module_domain.o \
-	../frame/module_configure.o
+	../frame/module_configure.o module_membrane_mslp.o module_tracker.o
 
 start_domain_nmm.o: module_HIFREQ.o ../share/module_random.o module_STATS_FOR_MOVE.o
 
diff --git a/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F b/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F
index f935f4d3..dbe8d73a 100644
--- a/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F
+++ b/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F
@@ -182,7 +182,7 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
 !
       REAL :: BCHR,CONVFAC,CWK,DT,PLYR,RRI
 !
-      LOGICAL :: E_BDY,W_BDY,N_BDY,S_BDY
+      LOGICAL :: E_BDY,W_BDY,N_BDY,S_BDY, activate
 !
       CHARACTER(LEN=255) :: message
 !-----------------------------------------------------------------------
@@ -232,14 +232,15 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
 !
 !***  USE IBDY=1 FOR SOUTH; 2 FOR NORTH
 !
-      DO IBDY=1,2 
+      ns_do: DO IBDY=1,2 
 !
 !***  MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
 !
-        IF(S_BDY.AND.IBDY==1) THEN 
+        activate=.false.
+        ns_if: IF(S_BDY.AND.IBDY==1) THEN 
             JB=1         ! Which cell in from boundary
             JJ=1         ! Which cell in the domain
-
+            activate=.true.
           DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
             PD_BYS(I,1,JB)=PD_BYS(I,1,JB)+PD_BTYS(I,1,JB)*DT
             PD(I,JJ)=PD_BYS(I,1,JB)
@@ -264,7 +265,7 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
           ELSEIF(N_BDY.AND.IBDY==2) THEN
             JB=1         ! Which cell in from boundary
             JJ=JJM       ! Which cell in the domain
-
+            activate=.true.
 !
           DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE)
             PD_BYE(I,1,JB)=PD_BYE(I,1,JB)+PD_BTYE(I,1,JB)*DT
@@ -286,10 +287,9 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
      &                    +ETA2(K)*PD(I,JJ)*RES(I,JJ)+PT
             ENDDO
           ENDDO
+        ENDIF ns_if
 
-!         ENDIF   ! for N/S boundaries
-
-!
+        ns_activate: IF(activate) THEN
 #ifdef WRF_CHEM
 !$omp parallel do                                                       &
 !$omp& private(i,k,nv)
@@ -315,8 +315,8 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
           ENDDO
           ENDDO
 #endif
-        ENDIF
-      ENDDO
+        ENDIF ns_activate
+      ENDDO ns_do
 !
 !-----------------------------------------------------------------------
 !***  WEST AND EAST BOUNDARIES
@@ -324,14 +324,15 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
 !
 !***  USE IBDY=1 FOR WEST; 2 FOR EAST. 
 !
-      DO IBDY=1,2 
+      ew_do: DO IBDY=1,2 
 !
 !***  MAKE SURE THE PROCESSOR HAS THIS BOUNDARY.
 !
-        IF(W_BDY.AND.IBDY==1) THEN  
+        activate=.false.
+        ew_if: IF(W_BDY.AND.IBDY==1) THEN  
             IB=1         ! Which cell in from boundary 
             II=1         ! Which cell in the domain
-!
+            activate=.true.
           DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
             IF(MOD(J,2)==1)THEN
               PD_BXS(J,1,IB)=PD_BXS(J,1,IB)+PD_BTXS(J,1,IB)*DT
@@ -362,7 +363,7 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
           ELSEIF(E_BDY.AND.IBDY==2) THEN
             IB=1         ! Which cell in from boundary
             II=IIM       ! Which cell in the domain
-
+            activate=.true.
           DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2)
             IF(MOD(J,2)==1)THEN
               PD_BXE(J,1,IB)=PD_BXE(J,1,IB)+PD_BTXE(J,1,IB)*DT
@@ -389,9 +390,10 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
 !
             ENDDO
           ENDDO
-!
-!          ENDIF  ! for W/E boundaries
-!
+
+       ENDIF ew_if
+
+       ew_activate: IF(activate) THEN
 !
 #ifdef WRF_CHEM
 !$omp parallel do                                                       &
@@ -417,8 +419,8 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
           ENDDO
 
 #endif
-        ENDIF
-      ENDDO
+        ENDIF ew_activate
+      ENDDO ew_do
 !
 !-----------------------------------------------------------------------
 !***  SPACE INTERPOLATION OF PD THEN REMAINING MASS VARIABLES
diff --git a/wrfv2_fire/dyn_nmm/module_GWD.F b/wrfv2_fire/dyn_nmm/module_GWD.F
index 3da5f33e..387d3755 100644
--- a/wrfv2_fire/dyn_nmm/module_GWD.F
+++ b/wrfv2_fire/dyn_nmm/module_GWD.F
@@ -182,7 +182,7 @@ SUBROUTINE GWD_driver(U,V,T,Q,Z,DP,PINT,PMID,EXNR, KPBL, ITIME    &
      &                     ,HSTDV,HCNVX,HASYW,HASYS,HASYSW,HASYNW       &
      &                     ,HLENW,HLENS,HLENSW,HLENNW                   &
      &                     ,HANGL,HANIS,HSLOP,HZMAX,CROT,SROT           &
-     &                     ,DUDT,DVDT,UGWDsfc,VGWDsfc                   &
+     &                     ,DUDT,DVDT,UGWDsfc,VGWDsfc,XLAND             &      !ADDED XLAND FOR SKIPPING OCEAN POINTS(KWON)
      &                     ,IDS,IDE,JDS,JDE,KDS,KDE                     &
      &                     ,IMS,IME,JMS,JME,KMS,KME                     &
      &                     ,ITS,ITE,JTS,JTE,KTS,KTE )
@@ -247,7 +247,7 @@ SUBROUTINE GWD_driver(U,V,T,Q,Z,DP,PINT,PMID,EXNR, KPBL, ITIME    &
      &                                   U,V,T,Q,Z,DP,PINT,PMID,EXNR
       REAL, INTENT(IN), DIMENSION (ims:ime, jms:jme) :: HSTDV,HCNVX     &
      &      ,HASYW,HASYS,HASYSW,HASYNW,HLENW,HLENS,HLENSW,HLENNW,HANGL  &
-     &      ,HANIS,HSLOP,HZMAX,CROT,SROT
+     &      ,HANIS,HSLOP,HZMAX,CROT,SROT, XLAND                           !ADDED XLAND BY KWON
       INTEGER, INTENT(IN), DIMENSION (ims:ime, jms:jme) :: KPBL
       INTEGER, INTENT(IN) :: ids,ide,jds,jde,kds,kde                    &
      &,                      ims,ime,jms,jme,kms,kme                    &
@@ -273,7 +273,7 @@ SUBROUTINE GWD_driver(U,V,T,Q,Z,DP,PINT,PMID,EXNR, KPBL, ITIME    &
       REAL(KIND=KIND_PHYS), DIMENSION (IM,KTS:KTE) :: DUDTcol,DVDTcol   &
      &,                    Ucol,Vcol,Tcol,Qcol,DPcol,Pcol,EXNcol,PHIcol
       REAL(KIND=KIND_PHYS), DIMENSION (IM,KTS:KTE+1) :: PINTcol,PHILIcol
-      INTEGER :: I,J,IJ,K,Imid,Jmid
+      INTEGER :: I,J,IJ,K,Imid,Jmid                             
       REAL :: Ugeo,Vgeo,Umod,Vmod, TERRtest,TERRmin
       REAL(KIND=KIND_PHYS) :: TEST
       CHARACTER(LEN=255) :: message
@@ -294,6 +294,7 @@ SUBROUTINE GWD_driver(U,V,T,Q,Z,DP,PINT,PMID,EXNR, KPBL, ITIME    &
 !--------------------------  Executable below  -------------------------
 !
 
+
 lprnt=.false.
 !dbg
 if (itime <= 1) then
@@ -424,6 +425,9 @@ SUBROUTINE GWD_driver(U,V,T,Q,Z,DP,PINT,PMID,EXNR, KPBL, ITIME    &
       DO I=IMS,IME
         UGWDsfc(I,J)=0.
         VGWDsfc(I,J)=0.
+!        IF(ITIMIE.LE.2.OR.ITIME.GE.900) THEN
+!        PRINT *,'KWON: I J HSTDV  IN GWD_DRIVER ',ITIME,I,J,HSTDV(I,J)
+!        ENDIF
       ENDDO
       ENDDO
 !
@@ -432,6 +436,15 @@ SUBROUTINE GWD_driver(U,V,T,Q,Z,DP,PINT,PMID,EXNR, KPBL, ITIME    &
 !dbg       Imid=.5*(ITS+ITE)
 !dbg       Jmid=.5*(JTS+JTE)
 !
+!INITIALIZE THE OUPUT OF GWD_COL  KWON
+          DO K=KTS,KTE
+            DUDTcol(IM,K)=0.
+            DVDTcol(IM,K)=0.
+          ENDDO
+          DUsfc(IM)=0.             !-- U wind stress
+          DVsfc(IM)=0.             !-- V wind stress
+
+
       DO J=JTS,JTE
         DO I=ITS,ITE
           if (kpbl(i,j)kte) go to 100
@@ -441,6 +454,8 @@ SUBROUTINE GWD_driver(U,V,T,Q,Z,DP,PINT,PMID,EXNR, KPBL, ITIME    &
           TERRtest=HZMAX(I,J)+SIGFAC*HSTDV(I,J)
           TERRmin=Z(I,2,J)-Z(I,1,J)
           IF (TERRtest < TERRmin) GO TO 100
+!  ADDED BY KWON TO SKIP OCEAN POINTS
+          IF (XLAND(I,J).GE.1.5)  GO TO 100
 !
 !-- For debugging:
 !
diff --git a/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F b/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F
index a7cd1f3d..7c14f65c 100644
--- a/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F
+++ b/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F
@@ -49,6 +49,18 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN            &
      &                    ,Z,SICE,NUM_AEROSOLC,NUM_OZMIXM               &
      &                    ,GRID,CONFIG_FLAGS                            &
      &                    ,RTHRATEN                                     &
+     &                    ,re_cloud,re_ice,re_snow                      & ! G. Thompson
+     &                    ,has_reqc,has_reqi,has_reqs                   & ! G. Thompson
+     &                    ,SWUPT,SWUPTC,SWDNT,SWDNTC                    &
+     &                    ,SWUPB,SWUPBC,SWDNB,SWDNBC                    &
+     &                    ,LWUPT,LWUPTC,LWDNT,LWDNTC                    &
+     &                    ,LWUPB,LWUPBC,LWDNB,LWDNBC                    &
+     &                    ,ACSWUPT,ACSWUPTC,ACSWDNT,ACSWDNTC            &
+     &                    ,ACSWUPB,ACSWUPBC,ACSWDNB,ACSWDNBC            &
+     &                    ,ACLWUPT,ACLWUPTC,ACLWDNT,ACLWDNTC            &
+     &                    ,ACLWUPB,ACLWUPBC,ACLWDNB,ACLWDNBC            &
+     &                    ,SWVISDIR ,SWVISDIF                           &  !ssib
+     &                    ,SWNIRDIR, SWNIRDIF &                            !ssib
 #ifdef WRF_CHEM
      &                    ,PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC         &
      &                    ,TAUAER1, TAUAER2, TAUAER3, TAUAER4           &
@@ -150,6 +162,30 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN            &
 #endif
 !
       REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: CLDFRA
+
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) ::          &
+                      ACSWUPT,ACSWUPTC,ACSWDNT,ACSWDNTC,          &
+                      ACSWUPB,ACSWUPBC,ACSWDNB,ACSWDNBC,          &
+                      ACLWUPT,ACLWUPTC,ACLWDNT,ACLWDNTC,          &
+                      ACLWUPB,ACLWUPBC,ACLWDNB,ACLWDNBC
+
+! TOA and surface, upward and downward, total and clear fluxes
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) ::          &
+                        SWUPT,  SWUPTC,  SWDNT,  SWDNTC,          &
+                        SWUPB,  SWUPBC,  SWDNB,  SWDNBC,          &
+                        LWUPT,  LWUPTC,  LWDNT,  LWDNTC,          &
+                        LWUPB,  LWUPBC,  LWDNB,  LWDNBC
+
+   REAL, DIMENSION( ims:ime, jms:jme ),                           &
+         INTENT(OUT  )  ::                              SWVISDIR, &
+                                                        SWVISDIF, &
+                                                        SWNIRDIR, &
+                                                        SWNIRDIF
+
+!
+!..Additions for coupling cloud physics effective radii and radiation.  G. Thompson
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN):: re_cloud, re_ice, re_snow
+      INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
 !
       LOGICAL,INTENT(IN) :: RESTRT
 !
@@ -162,7 +198,7 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN            &
 !***  LOCAL VARIABLES
 !***
 !-----------------------------------------------------------------------
-      INTEGER :: I,ICLOUD,IENDX,II,ISTAT,J,JDAY,JMONTH,K,KMNTH,N,NRAD
+      INTEGER :: I,IENDX,II,ISTAT,J,JDAY,JMONTH,K,KMNTH,N,NRAD
 !
       INTEGER,DIMENSION(3) :: IDAT
       INTEGER,DIMENSION(12) :: MONTH=(/31,28,31,30,31,30,31,31          &
@@ -177,7 +213,7 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN            &
      &                                  ,SWCF, LWCF                     &
      &                                  ,PDSL,REXNSFC,SWNETDN           &
      &                                  ,TOT,TOTLWDN,TOTSWDN,TOTSWDNC   &
-     &                                  ,TSFC,XLAND,XLAT,XLON
+     &                                  ,TSFC,XLAND,XLAT,XLON, HT
 !
 !
       REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: CLFR,DZ                &   !<--- Used only with physics (IKJ)
@@ -230,6 +266,7 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN            &
         T8W(I,KTS,J)=TSFC(I,J)
         P8W(I,KTS,J)=ETA1(KTS)*PDTOP+ETA2(KTS)*PDSL(I,J)+PT
         Z_PHY(I,KTS,J)=Z(I,J,KTS)
+        HT(I,J)=Z(I,J,KTS)
       ENDDO
       ENDDO
 !
@@ -274,8 +311,6 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN            &
 !
       ENDDO
       ENDDO
-!
-      ICLOUD=999
 !
       GMT=REAL(IHRST)
 !
@@ -351,8 +386,22 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN            &
      &                 ,J_START=GRID%J_START,J_END=GRID%J_END           &
      &                 ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES        &
      &                 ,ITIMESTEP=NTSD,DT=DT                            &
-     &                 ,CU_RAD_FEEDBACK=config_flags%cu_rad_feedback    &
-     &                 ,QC_ADJUST=GD_CLOUD,QI_ADJUST=GD_CLOUD2          &
+     &                 ,ICLOUD_CU=config_flags%ICLOUD_CU                &
+     &                 ,QC_CU=GRID%QC_CU,QI_CU=GRID%QI_CU               &
+! WRF-Solar variables
+                       ,swint_opt=config_flags%swint_opt                &   
+     &       ,SWDDIR=grid%swddir,SWDDNI=grid%swddni,SWDDIF=grid%swddif     & ! jararias
+     &       ,Gx=grid%Gx,Bx=grid%Bx,gg=grid%gg,bb=grid%bb                  & ! for sza-interpolation
+     &       ,swdown_ref=grid%swdown_ref,swddir_ref=grid%swddir_ref        & !
+     &       ,coszen_ref=grid%coszen_ref                                   & 
+     &       ,coszen=grid%coszen                                   & 
+     &       ,hrang=grid%hrang                                   & 
+     &       ,ht=ht                                   & 
+     &       ,aer_type=config_flags%aer_type                                                        &
+     &       ,aer_aod550_opt=config_flags%aer_aod550_opt,aer_aod550_val=config_flags%aer_aod550_val &
+     &       ,aer_angexp_opt=config_flags%aer_angexp_opt,aer_angexp_val=config_flags%aer_angexp_val &
+     &       ,aer_ssa_opt=config_flags%aer_ssa_opt,aer_ssa_val=config_flags%aer_ssa_val             &
+     &       ,aer_asy_opt=config_flags%aer_asy_opt,aer_asy_val=config_flags%aer_asy_val             &
 #ifdef WRF_CHEM
      &                 ,AER_RA_FEEDBACK=config_flags%aer_ra_feedback    &
      &                 ,PM2_5_DRY=pm2_5_dry,PM2_5_WATER=pm2_5_water     &
@@ -385,9 +434,49 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN            &
      &                 ,LW_PHYSICS=CONFIG_FLAGS%RA_LW_PHYSICS           &
      &                 ,SW_PHYSICS=CONFIG_FLAGS%RA_SW_PHYSICS           &
      &                 ,RADT=RADT,RA_CALL_OFFSET=GRID%RA_CALL_OFFSET    &
-     &                 ,STEPRA=NRAD,ICLOUD=ICLOUD                       &
+     &                 ,STEPRA=NRAD,ICLOUD=config_flags%ICLOUD          &
      &                 ,WARM_RAIN=WARM_RAIN                             &
      &                 ,SWDOWNC=TOTSWDNC,CLDFRA=CLFR                    &
+     &                 ,SWUPT=SWUPT                                     &
+     &                 ,SWUPTC=SWUPTC                                   &
+     &                 ,SWDNT=SWDNT                                     &
+     &                 ,SWDNTC=SWDNTC                                   &
+     &                 ,SWUPB=SWUPB                                     &
+     &                 ,SWUPBC=SWUPBC                                   &
+     &                 ,SWDNB=SWDNB                                     &
+     &                 ,SWDNBC=SWDNBC                                   &
+     &                 ,LWUPT=LWUPT                                     &
+     &                 ,LWUPTC=LWUPTC                                   &
+     &                 ,LWDNT=LWDNT                                     &
+     &                 ,LWDNTC=LWDNTC                                   &
+     &                 ,LWUPB=LWUPB                                     &
+     &                 ,LWUPBC=LWUPBC                                   &
+     &                 ,LWDNB=LWDNB                                     &
+     &                 ,LWDNBC=LWDNBC                                   &
+     &                 ,ACSWUPT=ACSWUPT                                 &
+     &                 ,ACSWUPTC=ACSWUPTC                               &
+     &                 ,ACSWDNT=ACSWDNT                                 &
+     &                 ,ACSWDNTC=ACSWDNTC                               &
+     &                 ,ACSWUPB=ACSWUPB                                 &
+     &                 ,ACSWUPBC=ACSWUPBC                               &
+     &                 ,ACSWDNB=ACSWDNB                                 &
+     &                 ,ACSWDNBC=ACSWDNBC                               &
+     &                 ,ACLWUPT=ACLWUPT                                 &
+     &                 ,ACLWUPTC=ACLWUPTC                               &
+     &                 ,ACLWDNT=ACLWDNT                                 &
+     &                 ,ACLWDNTC=ACLWDNTC                               &
+     &                 ,ACLWUPB=ACLWUPB                                 &
+     &                 ,ACLWUPBC=ACLWUPBC                               &
+     &                 ,ACLWDNB=ACLWDNB                                 &
+     &                 ,ACLWDNBC=ACLWDNBC                               &
+     &        ,SWVISDIR=swvisdir ,SWVISDIF=swvisdif                     &  !ssib
+     &        ,SWNIRDIR=swnirdir ,SWNIRDIF=swnirdif                     &  !ssib
+     &                 ,re_cloud=grid%re_cloud                          & ! G. Thompson
+     &                 ,re_ice=grid%re_ice                              & ! G. Thompson
+     &                 ,re_snow=grid%re_snow                            & ! G. Thompson
+     &                 ,has_reqc=has_reqc                               & ! G. Thompson
+     &                 ,has_reqi=has_reqi                               & ! G. Thompson
+     &                 ,has_reqs=has_reqs                               & ! G. Thompson
      &                 ,RSWTOA=RSWTOA,RLWTOA=RLWTOA                     &
      &                 ,CZMEAN=CZMEAN,CFRACL=CFRACL                     &
      &                 ,CFRACM=CFRACM,CFRACH=CFRACH                     &
@@ -650,7 +739,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
 !- RLWIN/RSWIN - downward longwave/shortwave at the surface (also TOTLWDN/TOTSWDN in RADIATION)
      &                ,PD,RES,PINT,T,Q,CWM,F_ICE,F_RAIN,SR              &
      &                ,Q2,U,V,THS,TSFC,SST,PREC,SNO                     &
-     &                ,FIS,Z0,Z0BASE,USTAR,MIXHT,PBLH,LPBL,EL_MYJ       &
+     &                ,FIS,Z0,MZ0,Z0BASE,USTAR,MIXHT,PBLH,LPBL,EL_MYJ   &   !MZ0: MOMENTUM Z0 (KWON)
      &                ,MOIST,RMOL,MOL                                   &
      &                ,EXCH_H,EXCH_M,F,AKHS,AKMS,AKHS_OUT,AKMS_OUT      &
      &                ,THZ0,QZ0,UZ0,VZ0,QS,MAVAIL                       &
@@ -660,7 +749,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &                ,SFCEXC,ACSNOW,ACSNOM,SNOPCX,SICE,TG,SOILTB       &
      &                ,ALBSI,ICEDEPTH,SNOWSI                            &
      &                ,ALBASE,MXSNAL,ALBEDO,SH2O,SI,EPSR,EMBCK          &
-     &                ,U10,V10,TH10,Q10,TSHLTR,QSHLTR,PSHLTR            &
+     &                ,U10,V10,UOCE,VOCE,TH10,Q10,TSHLTR,QSHLTR,PSHLTR            &
      &                ,T2,QSG,QVG,QCG,SOILT1,TSNAV,SMFR3D,KEEPFR3DFLAG  &
      &                ,TWBS,QWBS,TAUX,TAUY,SFCSHX,SFCLHX,SFCEVP,RTHRATEN&
      &                ,POTEVP,POTFLX,SUBSHX                             &
@@ -677,11 +766,12 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &                ,RC_MF                                            & ! QNSE
      &                ,GRID,CONFIG_FLAGS                                &
      &                ,IHE,IHW,IVE,IVW                                  &
-     &                ,DISHEAT                                          &
-     &                ,HPBL2D, EVAP2D, HEAT2D                           &  !Kwon S&P
+     &                ,DISHEAT,DKU3D,DKT3D                              &
+     &                ,HPBL2D, EVAP2D, HEAT2D,RC2D                      &  !Kwon S&P
      &                ,SFCHEADRT,INFXSRT,SOLDRAIN                       &  !Hydrology, no-op right now
      &                ,IDS,IDE,JDS,JDE,KDS,KDE                          &
      &                ,IMS,IME,JMS,JME,KMS,KME                          &
+     &                ,IPS,IPE,JPS,JPE,KPS,KPE                          &
      &                ,ITS,ITE,JTS,JTE,KTS,KTE)
 !***********************************************************************
 !$$$  SUBPROGRAM DOCUMENTATION BLOCK
@@ -726,6 +816,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
 #endif
       INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
      &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,IPS,IPE,JPS,JPE,KPS,KPE                     &
      &                     ,ITS,ITE,JTS,JTE,KTS,KTE                     &
      &                     ,N_MOIST,NPHS,NSOIL,NTSD
 !
@@ -733,7 +824,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
 !
       INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: ISLTYP,IVGTYP
 !
-      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) ::  HPBL2D, EVAP2D, HEAT2D   !Kwon S&P
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) ::  HPBL2D, EVAP2D, HEAT2D , RC2D   !Kwon S&P
 !
       INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: LPBL
 !
@@ -796,7 +887,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &                                                ,USTAR,UZ0,UZ0H   &
      &                                                ,VZ0,VZ0H         &
      &                                                ,DEW              & !RUC LSM
-     &                                                ,Z0,Z0BASE
+     &                                                ,Z0,MZ0,Z0BASE      !MZ0 (KWON)
 !
       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: AKHS_OUT,AKMS_OUT  &
      &                                              ,ALWIN,ALWOUT       &
@@ -805,6 +896,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &                                              ,PSHLTR,Q10,QSHLTR  &
      &                                              ,TH10,TSHLTR        &
      &                                              ,U10,V10            & ! GWD
+     &                                              ,UOCE,VOCE          &
      &                                              ,UGWDsfc,VGWDsfc      ! GWD
 !
       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: GRNFLX,QWBS,RADOT  &
@@ -830,6 +922,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &                                                      ,EXCH_H     &
      &                                                      ,EXCH_M
 !
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(OUT) :: DKU3D,DKT3D   ! KWON
       REAL,DIMENSION(IMS:IME,NSOIL,JMS:JME),INTENT(INOUT) :: KEEPFR3DFLAG & !<--- Used only in physics (IKJ)
      &                                                      ,SH2O,SMC     &
      &                                                      ,SMFR3D,STC
@@ -920,7 +1013,9 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
       LOGICAL :: FQ_I, ETAMP_PHYSICS,ETAMP_Regional            !BSF
 
       CHARACTER(len=255) :: message
+#if HWRF==1
 !dbg integer :: kpblmin,kpblmax,lpblmin,lpblmax    !dbg
+#endif
 !
 !
     TYPE(WRFU_Time)                :: currentTime
@@ -929,6 +1024,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
 
     INTEGER  :: isurban
     CHARACTER(len=256) :: MMINLU
+    REAL :: VAR_RIC,coef_ric_s,coef_ric_l                             !KWON for variable Ric (=1)
 !-----------------------------------------------------------------------
 !***********************************************************************
 !-----------------------------------------------------------------------
@@ -1295,16 +1391,21 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &          ,SMOIS=SMC,SMSTAV=SMSTAV,SMSTOT=SMSTOT,SNOALB=MXSNAL    &
      &          ,SNOW=SNOW,SNOWC=SNOWC,SNOWH=SNOWH,STEPBL=NPHS          &
      &          ,SMCREL=SMCREL                                          &
-     &          ,SST=SST,SST_UPDATE=SST_UPDATE                          &
+     &          ,SST=SST,SST_UPDATE=SST_UPDATE,MAX_EDOM=-1              &
      &          ,TH10=TH10,TH2=TH2X,T2=T2,THZ0=THZ0,TH_PHY=TH_PHY       &
      &          ,TMN=TG,TSHLTR=TSHLTR,TSK=TSFC,TSLB=STC,T_PHY=T_PHY     &
      &          ,U10=U10,UDRUNOFF=BGROFF,UST=USTAR,UZ0=UZ0H             &
      &          ,U_FRAME=U_FRAME,U_PHY=U_PHY,V10=V10,VEGFRA=VGFRCK      &
+     &          ,UOCE=UOCE,VOCE=VOCE                                    &
      &          ,VZ0=VZ0H,V_FRAME=V_FRAME,V_PHY=V_PHY                   &
      &          ,WARM_RAIN=WARM_RAIN,WSPD=WSPD,XICE=SICE,XICEM=SICE     &
      &          ,ALBSI=albsi,ICEDEPTH=icedepth,SNOWSI=snowsi            &
      &          ,ISICE=GRID%LANDUSE_ISICE,ISWATER=GRID%ISWATER          &
-     &          ,XLAND=XLAND,Z=Z,ZNT=Z0,ZS=SLDPTH,CT=CT,TKE_PBL=TKE,SFENTH=SFENTH     &
+     &          ,XLAND=XLAND,Z=Z,ZNT=Z0                                 &
+#ifdef HWRF
+     &          ,MZNT=MZ0                                               &
+#endif
+     &          ,ZS=SLDPTH,CT=CT,TKE_PBL=TKE,SFENTH=SFENTH              &   !KWON
      &          ,ALBBCK=ALBASE,LH=ELFLX,SH2O=SH2O,SHDMAX=SHDMAX         &
      &          ,SHDMIN=SHDMIN,Z0=Z0BASE,FLQC=FLQC,FLHC=FLHC            &
      &          ,FM=FM,FHH=FH                                           &
@@ -1320,6 +1421,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &          ,NUM_URBAN_HI=config_flags%num_urban_hi                 & !multi-layer urban
      &          ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE        &
      &          ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME        &
+     &          ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe      & 
      &          ,I_START=GRID%I_START,I_END=GRID%I_END                  &
      &          ,J_START=GRID%J_START,J_END=GRID%J_END                  &
      &          ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES               &
@@ -1393,7 +1495,19 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &        ,   irbxy=grid%irbxy    ,    trxy=grid%trxy    ,   evcxy=grid%evcxy    &
      &        ,chleafxy=grid%chleafxy ,  chucxy=grid%chucxy                          &                       
      &        ,  chv2xy=grid%chv2xy   ,  chb2xy=grid%chb2xy , chstarxy=grid%chstarxy &                       
+     &        ,  smoiseq=grid%smoiseq, smcwtdxy=grid%smcwtdxy, rechxy=grid%rechxy    &                       
+     &        ,  deeprechxy=grid%deeprechxy                                          &                       
      &        ,coszen=grid%czen,xlat_urb2d=grid%xlat                                 &
+! mosaic tiling for Noah
+     &        ,sf_surface_mosaic=config_flags%sf_surface_mosaic,  mosaic_cat=config_flags%mosaic_cat      &
+! lake module
+     &        ,lakedepth2d=grid%lakedepth2d, savedtke12d=grid%savedtke12d, snowdp2d=grid%snowdp2d, h2osno2d=grid%h2osno2d    &
+     &        ,snl2d=grid%snl2d, t_grnd2d=grid%t_grnd2d, t_lake3d=grid%t_lake3d,   lake_icefrac3d=grid%lake_icefrac3d        &
+     &        ,z_lake3d=grid%z_lake3d, dz_lake3d=grid%dz_lake3d, t_soisno3d=grid%t_soisno3d, h2osoi_ice3d=grid%h2osoi_ice3d  &
+     &        ,h2osoi_liq3d=grid%h2osoi_liq3d, h2osoi_vol3d=grid%h2osoi_vol3d, z3d=grid%z3d, dz3d=grid%dz3d                  &
+     &        ,zi3d=grid%zi3d, watsat3d=grid%watsat3d, csol3d=grid%csol3d, tkmg3d=grid%tkmg3d                                &
+     &        ,tkdry3d=grid%tkdry3d,tksatu3d=grid%tksatu3d, LakeModel=grid%sf_lake_physics,  lake_min_elev=grid%lake_min_elev  &
+! end lake module
      &        ,maxpatch=1,inest=1,history_interval=config_flags%history_interval  & !clm
 
      &                                                          )
@@ -1445,6 +1559,12 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
          FQ_I=F_QI
          PQ_I=P_QI
       ENDIF
+#if HWRF==1
+      CALL nl_get_var_ric(1, var_ric)
+      CALL nl_get_coef_ric_s(1, coef_ric_s)
+      CALL nl_get_coef_ric_l(1, coef_ric_l)
+!      write(0,*) 'var_ric & coef_ric_s l from namelist Kwon  ',var_ric,coef_ric_s,coef_ric_l
+#endif
 !
       CALL PBL_DRIVER(                                                &
      &                ITIMESTEP=NTSD,DT=DT                            &
@@ -1454,7 +1574,11 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &               ,RQCBLTEN=RQCBLTEN,RQIBLTEN=RQIBLTEN             & !BSF
 !BSF &               ,RQRBLTEN=RQRBLTEN,RQSBLTEN=RQSBLTEN             & !BSF
 !BSF &               ,RQGBLTEN=RQGBLTEN                               & !BSF
-     &               ,TSK=TSFC,XLAND=XLAND,ZNT=Z0,HT=SFCZ             &
+     &               ,TSK=TSFC,XLAND=XLAND,ZNT=Z0                     &
+#ifdef HWRF
+     &               ,MZNT=MZ0                                        &
+#endif
+     &               ,HT=SFCZ                                         &   !KWON
      &               ,UST=USTAR,MIXHT=MIXHT,PBLH=PBLH                 &
      &               ,HFX=TWBS,QFX=QWBS,GRDFLX=GRNFLX                 &
      &               ,U_PHY=U_PHY,V_PHY=V_PHY,TH_PHY=TH_PHY,RHO=RR    &
@@ -1465,7 +1589,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &               ,THZ0=THZ0,QZ0=QZ0,UZ0=UZ0H,VZ0=VZ0H             &
      &               ,QSFC=QS,LOWLYR=LOWLYR                           &
      &               ,PSIM=PSIM,PSIH=PSIH,GZ1OZ0=GZ1OZ0               &
-     &               ,U10=U10,V10=V10,T2=T2,WSPD=WSPD,BR=BR,CHKLOWQ=CHKLOWQ &   
+     &               ,U10=U10,V10=V10,UOCE=UOCE,VOCE=VOCE,T2=T2,WSPD=WSPD,BR=BR,CHKLOWQ=CHKLOWQ &   
      &               ,DX=DX,STEPBL=NPHS,WARM_RAIN=WARM_RAIN           &
      &               ,KPBL=KPBL,CT=CT,LH=ELFLX,SNOW=SNOW,XICE=SICE    &
      &               ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics      &
@@ -1478,6 +1602,9 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &               ,J_START=GRID%J_START,J_END=GRID%J_END           &
      &               ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES        &
      &               ,CTOPO=grid%ctopo,CTOPO2=grid%ctopo2             &
+     &               ,WINDFARM_OPT=config_flags%windfarm_opt          &
+     &               ,POWER=grid%POWER                                &
+     &               ,NUM_SCALAR=1, NUM_TRACER=1                      &  ! parameters not used by NMM
 #if (NMM_CORE==1)
      &               ,DISHEAT=DISHEAT                                 &
 #endif
@@ -1487,6 +1614,14 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &               ,GFS_ALPHA=GRID%GFS_ALPHA                        &
 #endif
      &               ,HPBL2D=HPBL2D, EVAP2D=EVAP2D, HEAT2D=HEAT2D     &    !Kwon S&P
+     &               ,RC2D=RC2D                                       &    !KWON
+#if HWRF==1
+     &               ,VAR_RIC=VAR_RIC                                 &    !Kwon Ric
+#endif
+     &               ,DKU3D=DKU3D,DKT3D=DKT3D 
+#if HWRF==1
+     &               ,coef_ric_l=coef_ric_l,coef_ric_s=coef_ric_s     &    !Kwon for Ric
+#endif
      &               ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV &
      &               ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC &
      &               ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,PQ_I),F_QI=FQ_I &
@@ -1687,7 +1822,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT                              &
      &               ,HANGL=HANGL,HANIS=HANIS,HSLOP=HSLOP,HZMAX=HZMAX   &
      &               ,CROT=CROT,SROT=SROT                               &
      &               ,DUDT=DUDT_GWD,DVDT=DVDT_GWD                       &
-     &               ,UGWDsfc=UGWDsfc,VGWDsfc=VGWDsfc                   &
+     &               ,UGWDsfc=UGWDsfc,VGWDsfc=VGWDsfc,XLAND=XLAND       &    !ADDED BY KWON FOR OCEAN
      &               ,IDS=IDS,IDE=IDE,JDS=JDS,JDE=JDE,KDS=KDS,KDE=KDE   &
      &               ,IMS=IMS,IME=IME,JMS=JMS,JME=JME,KMS=KMS,KME=KME   &
      &               ,ITS=IGS,ITE=IGE,JTS=JGS,JTE=JGE,KTS=KTS,KTE=KTE )
@@ -2199,6 +2334,9 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL                       &
       REAL,DIMENSION(IMS:IME,JMS:JME,ENSDIM) :: ZERO_GD
 !
       REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
+!
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: CLDFRA_DP, CLDFRA_SH
+      REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: QC_CU, QI_CU
 !
       LOGICAL :: RESTART,WARM_RAIN,ETAMP_Regional
       LOGICAL,DIMENSION(IMS:IME,JMS:JME) :: CU_ACT_FLAG
@@ -2257,10 +2395,12 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL                       &
      &   CONFIG_FLAGS%CU_PHYSICS==NSASSCHEME)RETURN
       IF(MOD(NTSD,NCNVC)/=0.AND.                                      &
      &   CONFIG_FLAGS%CU_PHYSICS==TIEDTKESCHEME)RETURN
-      IF(MOD(NTSD,NCNVC)/=0.AND. &
+      IF(MOD(NTSD,NCNVC)/=0.AND.                                      &
      &   CONFIG_FLAGS%CU_PHYSICS==OSASSCHEME)RETURN
       IF(MOD(NTSD,NCNVC)/=0.AND.                                      &
      &   CONFIG_FLAGS%CU_PHYSICS==SASSCHEME)RETURN
+      IF(MOD(NTSD,NCNVC)/=0.AND.                                      &
+     &   CONFIG_FLAGS%CU_PHYSICS==MESO_SAS)RETURN             !Kwon
       
 !-----------------------------------------------------------------------
       NSTEP_CNV=NCNVC
@@ -2515,6 +2655,8 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL                       &
                   ! Others
      &                 ,ITIMESTEP=NTSD,DT=DT,DX=GPS                     &
      &                 ,RAINC=RAINC,RAINCV=RAINCV,NCA=NCA               &
+     &                 ,CLDFRA_DP=CLDFRA_DP,CLDFRA_SH=CLDFRA_SH         &
+     &                 ,QC_CU=QC_CU, QI_CU=QI_CU                        &
      &                 ,DZ8W=DZ,P8W=P8W,FORCET=TTEN,FORCEQ=QTEN         &
      &                 ,CLDEFI=CLDEFI,LOWLYR=LOWLYR,XLAND=XLAND         &
      &                 ,CU_ACT_FLAG=CU_ACT_FLAG,WARM_RAIN=WARM_RAIN     &
@@ -2679,7 +2821,7 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL                       &
 !
           cps_select: SELECT CASE(config_flags%cu_physics)
 !
-          CASE (KFSCHEME,KFETASCHEME,GDSCHEME,SASSCHEME,OSASSCHEME,NSASSCHEME,TIEDTKESCHEME)
+          CASE (KFSCHEME,KFETASCHEME,GDSCHEME,SASSCHEME,MESO_SAS,OSASSCHEME,NSASSCHEME,TIEDTKESCHEME)
             IF (ETAMP_Regional) THEN
               MOIST_TRANS(I,K,J,P_QS)=MAX(0.,MOIST_TRANS(I,K,J,P_QS)+RQICUTEN(I,K,J)*DTCNVC+RQSCUTEN(I,K,J)*DTCNVC)
             ELSE
@@ -2737,6 +2879,9 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST                          &
      &                   ,TBPVS_STATE                                   &
      &                   ,TBPVS0_STATE                                  &
      &                   ,GRID,CONFIG_FLAGS                             &
+     &                   ,re_cloud,re_ice,re_snow                       & ! G. Thompson
+     &                   ,has_reqc,has_reqi,has_reqs                    & ! G. Thompson
+     &                   ,diag_flag                                     & 
      &                   ,IDS,IDE,JDS,JDE,KDS,KDE                       &
      &                   ,IMS,IME,JMS,JME,KMS,KME                       &
      &                   ,ITS,ITE,JTS,JTE,KTS,KTE)
@@ -2802,6 +2947,10 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST                          &
      &                                  ,TBPVS_STATE,TBPVS0_STATE
 !
       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: SR
+!
+!..Additions for coupling cloud physics effective radii and radiation.  G. Thompson
+      REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT):: re_cloud, re_ice, re_snow
+      INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
 !
       TYPE(DOMAIN),TARGET :: GRID
 !
@@ -2829,6 +2978,7 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST                          &
       REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS
       REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: SCALAR_TRANS
 !
+      LOGICAL                        :: diag_flag
       LOGICAL :: E_BDY,F_QT,QT_PRESENT,WARM_RAIN
 !
 !-----------------------------------------------------------------------
@@ -2950,6 +3100,7 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST                          &
      &                  TH=TH_PHY,RHO=RR,PI_PHY=PI_PHY,P=P_PHY          &
      &                 ,RAINNC=RAINNC,RAINNCV=RAINNCV                   &
      &                 ,DZ8W=DZ,P8W=P8W,DT=DTPHS,DX=DX,DY=DY            &
+     &                 ,W=grid%W                                        &
      &                 ,MP_PHYSICS=CONFIG_FLAGS%MP_PHYSICS              &
 #ifdef WRF_CHEM
      &                 ,CHEM_OPT=CONFIG_FLAGS%CHEM_OPT                  &
@@ -2979,7 +3130,17 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST                          &
      &                 ,I_START=GRID%I_START,I_END=GRID%I_END           &
      &                 ,J_START=GRID%J_START,J_END=GRID%J_END           &
      &                 ,KTS=KTS,KTE=KTE,NUM_TILES=GRID%NUM_TILES        &
+     &                 ,DO_RADAR_REF=config_flags%do_radar_ref          &
+     &                 ,DIAGFLAG=diag_flag                              &
      &                 ,ID=grid%id                                      &
+     &                 ,num_scalar=1                                      &  !mchen temporary
+     &                 ,refl_10cm=grid%refl_10cm & ! to calc. radar reflectivity
+     &                 ,re_cloud=grid%re_cloud                          & ! G. Thompson
+     &                 ,re_ice=grid%re_ice                              & ! G. Thompson
+     &                 ,re_snow=grid%re_snow                            & ! G. Thompson
+     &                 ,has_reqc=has_reqc                               & ! G. Thompson
+     &                 ,has_reqi=has_reqi                               & ! G. Thompson
+     &                 ,has_reqs=has_reqs                               & ! G. Thompson
                                                                         )
 
 !$omp parallel do                                                       &
diff --git a/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F b/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F
index c720ada4..bae15ca9 100644
--- a/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F
+++ b/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F
@@ -1,15 +1,32 @@
 module module_stats_for_move
   implicit none
   private
+#if ( NMM_NEST == 1 )
   public :: stats_for_move, vorttrak_init
+
+  ! Tuning parameters for the PDYN-following algorithm:
+
+  ! Maximum, minimum and initial search radii:
+  real, parameter :: vt5_max_radius=250000.0
+  real, parameter :: vt5_min_radius=100000.0
+  real, parameter :: vt5_start_radius=vt5_max_radius
+
+  ! How much to increase or decrease search radius after a move or
+  ! non-move (but it will never exceed the prescribed min/max):
+  real, parameter :: vt5_move_factor=1.1
+  real, parameter :: vt5_nomove_factor=0.8
+
 contains
 
-  SUBROUTINE VORTTRAK_INIT(grid,config_flags,       &
+  SUBROUTINE VORTTRAK_INIT(grid,config_flags,init,  &
                            IDS,IDE,JDS,JDE,KDS,KDE, &
                            IMS,IME,JMS,JME,KMS,KME, &
                            ITS,ITE,JTS,JTE,KTS,KTE)
     USE MODULE_CONFIGURE, ONLY : grid_config_rec_type
     USE MODULE_DOMAIN, ONLY : domain
+#ifdef HWRF
+    USE module_tracker, only: ncep_tracker_init
+#endif
     IMPLICIT NONE
     integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE
     integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME
@@ -18,6 +35,7 @@ SUBROUTINE VORTTRAK_INIT(grid,config_flags,       &
     type(grid_config_rec_type), intent(in) :: config_flags
     integer :: vortex_tracker
     character*255 :: message
+    logical, intent(in) :: init ! True if this is the simulation start
 
     ! For vortex_tracker==4 option:
     integer :: cx,cy ! center x,y
@@ -27,20 +45,47 @@ SUBROUTINE VORTTRAK_INIT(grid,config_flags,       &
     
 #ifdef HWRF
     vortex_tracker=grid%vortex_tracker
-    if(vortex_tracker<1 .or. vortex_tracker>4) then
-       write(message,*)' domain ',grid%id,' has an invalid value ',vortex_tracker,' for vortex_tracker.  It must be 1, 2, 3 or 4.'
+    if(vortex_tracker<1 .or. vortex_tracker>6) then
+       write(message,*)' domain ',grid%id,' has an invalid value ',vortex_tracker,' for vortex_tracker.  It must be 1, 2, 3, 4 or 5.'
        call wrf_error_fatal(message)
     endif
-    
-    is_vt4: if(vortex_tracker==4) then
-       call wrf_message('in VORTTRAK_INIT for vortex tracker 4')
-       if(.not.(grid%vt4_pmax<0.0)) then
-          if(grid%vt4_pmax<100000.0 .or. grid%vt4_pmax>107000) then
-             write(message,'("vt4_pmax bad: vt4_pmax must be either <0 or within [1e5,1.07e5], but it is ",F15.5,".  We recommend -1.")') grid%vt4_pmax
-             call wrf_error_fatal(message)
+
+    ! Signify that the pdyn smooth and parent smooth are invalid in
+    ! this domain:
+    grid%pdyn_parent_age=0
+    grid%pdyn_smooth_age=0
+
+    if(size(grid%pdyn_smooth)>1) then
+       !write(0,*) 'in start domain, call update_pdyn_mslp for grid ',grid%id
+       CALL UPDATE_PDYN_MSLP(grid,config_flags, &
+                            IDS,IDE,JDS,JDE,KDS,KDE, &
+                            IMS,IME,JMS,JME,KMS,KME, &
+                            ITS,ITE,JTS,JTE,KTS,KTE )
+       
+    end if
+
+    is_vt45: if(vortex_tracker==4 .or. vortex_tracker==5) then
+       call wrf_message('in VORTTRAK_INIT for vortex tracker 4 or 5')
+       if(vortex_tracker==4) then
+          if(.not.(grid%vt4_pmax<0.0)) then
+             if(grid%vt4_pmax<100000.0 .or. grid%vt4_pmax>107000) then
+                write(message,'("vt4_pmax bad: vt4_pmax must be either <0 or within [1e5,1.07e5], but it is ",F15.5,".  We recommend -1.")') grid%vt4_pmax
+                call wrf_error_fatal(message)
+             endif
+          endif
+       endif
+
+       if(vortex_tracker==5) then
+          if(init) then 
+             grid%vt5searchrad=vt5_start_radius
+13011        format("Search radius now ",F0.3,"km for domain ",I0)
+             !write(message,13011) grid%vt5searchrad/1000.0,grid%id
+             !call wrf_debug(1,message)
           endif
        endif
+    endif is_vt45
 
+    distsq: if(size(grid%distsq)>1) then
        cx=ide/2
        cy=jde/2
        ! Calculate distance of various points from the domain center:
@@ -60,11 +105,85 @@ SUBROUTINE VORTTRAK_INIT(grid,config_flags,       &
              GRID%distsq(i,j)=far
           enddo
        enddo jdo
-    endif is_vt4
+    endif distsq
+#endif
+
+#ifdef HWRF
+    if(init .and. vortex_tracker==6) then
+       call ncep_tracker_init(grid)
+    endif
 #endif
 
   END SUBROUTINE VORTTRAK_INIT
 
+#ifdef HWRF
+  !----------------------------------------------------------------------
+  !
+  SUBROUTINE UPDATE_PDYN_MSLP(grid,config_flags, &
+                            IDS,IDE,JDS,JDE,KDS,KDE, &
+                            IMS,IME,JMS,JME,KMS,KME, &
+                            IPS,IPE,JPS,JPE,KPS,KPE )
+    USE MODULE_CONFIGURE, ONLY : grid_config_rec_type
+    USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid
+#ifdef DM_PARALLEL
+    USE MODULE_COMM_DM, ONLY : HALO_NMM_TRACK_sub
+    USE MODULE_DM, ONLY: ntasks_x, ntasks_y, mytask, ntasks, local_communicator
+#endif
+    use module_membrane_mslp
+    implicit none
+    type(domain), intent(inout) :: grid
+    type(grid_config_rec_type), intent(in) :: config_flags
+    integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE
+    integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME
+    integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE
+    integer :: i,j
+    logical bad
+
+    ! Update pdyn, mslp and sqws:
+    CALL STATS_MAKE_MSLP (grid%PDYN,grid%membrane_MSLP,grid%MSLP,grid%SQWS,         &
+                          grid%PINT,grid%T,grid%Q,grid%U,grid%V, &
+                          grid%FIS,grid%PD,grid%SM,              &
+                          grid%PDTOP,grid%PT,                    &
+                          grid%DETA1,grid%DETA2,grid%ETA2,       &
+                          IDS,IDE,JDS,JDE,KDS,KDE,               &
+                          IMS,IME,JMS,JME,KMS,KME,               &
+                          IPS,IPE,JPS,JPE,KPS,KPE)
+
+    ! Store average of parent pdyn_smooth and my pdyn in pdyn_smooth
+    ! to send to child for its tracking for vortex tracker 5
+    if(size(grid%pdyn_smooth)>1) then
+       if(grid%id==1) then
+          ! No parent, so pdyn_smooth==pdyn and pdyn_parent is ignored
+          !write(0,*) 'no parent (gid=1) so storing pdyn in pdyn_smooth'
+          do j=max(jds,jps),min(jpe,jde-1)
+             do i=max(ids,ips),min(ipe,ide-1)
+                grid%pdyn_smooth(i,j)=grid%pdyn(i,j)
+             enddo
+          enddo
+       else
+          !write(0,*) 'grid ',grid%id,' storing average of pdyn and pdyn_parent in pdyn_smooth'
+          do j=max(jds,jps),min(jpe,jde-1)
+             do i=max(ids,ips),min(ipe,ide-1)
+                grid%pdyn_smooth(i,j) = &
+                     0.5*grid%pdyn(i,j) + &
+                     0.5*grid%pdyn_parent(i,j)
+             enddo
+          enddo
+       endif
+
+       grid%pdyn_smooth_age=max(1,grid%pdyn_smooth_age+1)
+    else
+       call wrf_error_fatal('pdyn_smooth not allocated')
+    endif
+
+#ifdef DM_PARALLEL
+#   include "HALO_NMM_TRACK.inc"
+#endif
+
+  END SUBROUTINE UPDATE_PDYN_MSLP
+
+#endif
+
   !----------------------------------------------------------------------
   !
   SUBROUTINE STATS_FOR_MOVE(grid,config_flags, &
@@ -95,6 +214,7 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, &
     !       option 3, but uses the dynamic pressure PDYN and includes PDYN
     !       noise removal.  Plus, it only searches within X km of the nest
     !       center to avoid other nearby systems.
+    !   vortex_tracker=5 -- track average of parent and grandparent PDYN
     !
     ! HISTORY:
     !   2004?       - initial implementation by gopal
@@ -103,8 +223,12 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, &
     !   late  2010  - sam added a new child tracker (vortex_tracker=2)
     !   Nov 08 2011 - sam split implementation into several functions and
     !                 added the vortex_tracker=4 option
+#ifdef HWRF
+    USE module_tracker, only: ncep_tracker_center
+#endif
     USE MODULE_CONFIGURE, ONLY : grid_config_rec_type
     USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid
+    use module_membrane_mslp
 #ifdef DM_PARALLEL
 # ifdef HWRF
     USE MODULE_COMM_DM, ONLY : HALO_NMM_VT4_NOISE_sub, HALO_NMM_VT4_MSLP_sub
@@ -119,9 +243,12 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, &
     integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME
     integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE
     integer, intent(in) :: ITS,ITE,JTS,JTE,KTS,KTE
-    integer :: vortex_tracker
+    integer :: vortex_tracker,j
+    character*255 :: message
+    logical :: skip_nest_motion
 
     !     KEEP NEST MOTION IN SINK WITH PHYSICS TIME STEPS
+
 #if ( NMM_NEST == 1 )
 #ifdef HWRF
     MOVEFREQ=grid%movemin*grid%nphs
@@ -130,25 +257,48 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, &
     MOVEFREQ=grid%nphs
     vortex_tracker=-1
 #endif
-    IF(MOD(grid%NTSD+1,MOVEFREQ)/=0)THEN
+    skip_nest_motion=.false.
+    IF(MOD(grid%NTSD+1,MOVEFREQ)/=0 .or. grid%id==1)THEN
 #ifdef HWRF
-       IF(grid%MOVED) grid%NTIME0=grid%NTSD             !FOR UPDATING NTIM0
+       IF(grid%MOVED .and. grid%id/=1) then
+          grid%NTIME0=grid%NTSD             !FOR UPDATING NTIM0
+       ENDIF
 #endif
        grid%MVNEST=.FALSE.
-       RETURN
+       skip_nest_motion=.true.
     ENDIF
 
-    CALL STATS_MAKE_MSLP (grid%PDYN,grid%MSLP,grid%SQWS,         &
-                          grid%PINT,grid%T,grid%Q,grid%U,grid%V, &
-                          grid%FIS,grid%PD,grid%SM,              &
-                          grid%PDTOP,grid%PT,                    &
-                          grid%DETA1,grid%DETA2,                 &
-                          IDS,IDE,JDS,JDE,KDS,KDE,               &
-                          IMS,IME,JMS,JME,KMS,KME,               &
-                          ITS,ITE,JTS,JTE,KTS,KTE)
+#ifdef HWRF
+    if(skip_nest_motion .and. ( grid%pdyn_smooth_age/=0 .or. size(grid%pdyn_smooth)<=1)) then
+       ! Pdyn_smooth is up to date and it is not yet time to move the
+       ! nest, so we can return now.
+       !write(0,*) 'skipping pdyn_smooth in grid ',grid%id
+       return
+    else
+       ! Either we need to move the nest, or the pdyn values are
+       ! invalid due to nest initialization or recent nest motion, so
+       ! we cannot return yet.
+    endif
+
+    ! Update membrane_mslp:
+    call make_membrane_mslp(grid)
+
+
+    ! Update regular mslp:
+    CALL UPDATE_PDYN_MSLP(grid,config_flags, &
+                          IDS,IDE,JDS,JDE,KDS,KDE, &
+                          IMS,IME,JMS,JME,KMS,KME, &
+                          IPS,IPE,JPS,JPE,KPS,KPE)
+
+    if(skip_nest_motion) then
+       ! We get here if we had to update pdyn_smooth, but it is not
+       ! yet time to move the nest.
+       return
+    endif
+#endif
 
     !     HAND OFF CONTROL TO STATS_FOR_MOVE_123 FOR TRACKERS 1, 2 and 3
-    oldmove: if(vortex_tracker /= 4) then
+    oldmove: if(vortex_tracker<4) then
        ! PDYN causes noise in the presence of strong vorticity variations,
        ! so it is not used by HWRF for nest tracking.
        CALL STATS_FOR_MOVE_123 (grid%XLOC_2,grid%YLOC_2                   &
@@ -169,8 +319,39 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, &
             ,IMS,IME,JMS,JME,KMS,KME                                      &
             ,ITS,ITE,JTS,JTE,KTS,KTE)
        RETURN
-    else
 #ifdef HWRF
+    elseif(vortex_tracker==6) then
+       ! Tracker #6: do whatever the inline NCEP Tracker says
+       call ncep_tracker_center(grid)
+       call vt6_move(grid%tracker_ifix,grid%tracker_jfix,  &
+                     grid%tracker_gave_up,grid%tracker_havefix, &
+                     grid%xloc_2,grid%yloc_2, grid%id,     &
+                     grid%xloc_1,grid%yloc_1, grid%mvnest, &
+                     IDS,IDE,JDS,JDE,KDS,KDE,              &
+                     IMS,IME,JMS,JME,KMS,KME,              &
+                     ITS,ITE,JTS,JTE,KTS,KTE)
+    elseif(vortex_tracker==5) then
+       ! Tracker #5: follow average of grandparent and parent PDYN
+       call vt5_move(grid%pdyn_parent,grid%distsq,grid%vt5searchrad, &
+                     grid%xloc_2,grid%yloc_2, grid%id,     &
+                     grid%xloc_1,grid%yloc_1, grid%mvnest, &
+                     IDS,IDE,JDS,JDE,KDS,KDE,              &
+                     IMS,IME,JMS,JME,KMS,KME,              &
+                     ITS,ITE,JTS,JTE,KTS,KTE)
+
+       ! Adjust nest movement search radius for the next timestep
+       ! based on whether we moved this timestep or not.
+       if(grid%mvnest) then
+          grid%vt5searchrad=max(vt5_min_radius,min(vt5_max_radius, &
+               grid%vt5searchrad*vt5_move_factor))
+       else
+          grid%vt5searchrad=max(vt5_min_radius,min(vt5_max_radius, &
+               grid%vt5searchrad*vt5_nomove_factor))
+       endif
+13011  format("Search radius now ",F0.3,"km for domain ",I0)
+       write(message,13011) grid%vt5searchrad/1000.0,grid%id
+       call wrf_debug(1,message)
+    else
     !     HANDLE VORTEX TRACKER 4 HERE
 
        ! (we only get here in HWRF mode)
@@ -361,6 +542,139 @@ SUBROUTINE vt4_noise_detect(MSLP,NOISY,PMAX,PMIN,DPDR, &
   END SUBROUTINE vt4_noise_detect
 
 #ifdef HWRF
+  SUBROUTINE vt5_move(PDYN,distsq,searchrad,xloc,yloc,gridid,cx,cy,mvnest, &
+                      IDS,IDE,JDS,JDE,KDS,KDE,                   &
+                      IMS,IME,JMS,JME,KMS,KME,                   &
+                      ITS,ITE,JTS,JTE,KTS,KTE)
+    use module_dm, only: wrf_dm_minval_real
+    implicit none
+    real, intent(in) :: PDYN(ims:ime,jms:jme)
+    real, intent(in) :: distsq(ims:ime,jms:jme)
+    real, intent(in) :: searchrad
+    integer, intent(inout) :: xloc,yloc
+    integer, intent(in) :: cx,cy,gridid
+    logical, intent(out) :: mvnest 
+    integer :: &
+                      IDS,IDE,JDS,JDE,KDS,KDE,                   &
+                      IMS,IME,JMS,JME,KMS,KME,                   &
+                      ITS,ITE,JTS,JTE,KTS,KTE
+   
+    real, parameter :: big_pdyn=999999.9
+    integer i,j,iloc,jloc
+    real pdynloc,xdiff,ydiff,radsq
+    character*255 message
+
+    if(gridid==1) then ! Do nothing for MOAD
+       !write(0,*) 'Grid 1 (MOAD): skipping vt5_move'
+       mvnest=.false.
+       xloc=cx
+       yloc=cy
+       return
+    endif
+
+201 format("Search for minimum PDYN (<",F10.2,") within searchrad=",F0.3,"km of domain center cx=",I0," cy=",I0)
+    !write(message,201) big_pdyn,searchrad/1000.0,cx,cy
+
+    radsq=searchrad*searchrad
+    iloc=-1
+    jloc=-1
+    pdynloc=big_pdyn
+    do j=jts,min(jde-1,jte)
+       do i=its,min(ide-1,ite)
+          if(distsq(i,j)
 
@@ -426,6 +426,10 @@ SUBROUTINE init_domain_nmm ( grid &
 !JWB # include "HALO_NMM_IDEAL_1.inc"
 #endif
 !
+ WRITE(message,*)'--------------- ght_gc before calling vortex --------------------------'
+! call wrf_debug(1,message)
+! WRITE(message,*)grid%ght_gc(100,100,:)
+
   CALL vortex ( grid%ght_gc,grid%rh_gc,grid%t_gc,grid%u_gc,grid%v_gc,grid%p_gc &
      &,         ght_out,rh_out,t_out,u_out,v_out      &
      &,         grid%ht_gc,grid%tsk_gc,grid%xice_gc                          &
@@ -4696,7 +4700,7 @@ SUBROUTINE vortex ( ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc              &
 !         This is gopal's doing
 !----------------------------------------------------------------------------
 
- WRITE(0,*)'---------------- message CASE -------------------------'
+ WRITE(0,*)'---------------- IDEAL CASE -------------------------'
  call wrf_debug(1,message)
  WRITE(message,*)'number of pressure levels',end_z
  call wrf_debug(1,message)
@@ -4707,25 +4711,25 @@ SUBROUTINE vortex ( ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc              &
  WRITE(message,*)'number of soilbot  levels',num_soil_bot_cat
  call wrf_debug(1,message)
  WRITE(message,*)'--------------- ght_gc --------------------------'
- call wrf_debug(1,message)
- WRITE(message,*)ght_gc(100,100,:)
- call wrf_debug(1,message)
+! call wrf_debug(1,message)
+! WRITE(message,*)ght_gc(100,100,:)
+! call wrf_debug(1,message)
  WRITE(message,*)'--------------- p_gc --------------------------'
- call wrf_debug(1,message)
- WRITE(message,*)p_gc(100,100,:)
- call wrf_debug(1,message)
+! call wrf_debug(1,message)
+! WRITE(message,*)p_gc(100,100,:)
+! call wrf_debug(1,message)
  WRITE(message,*)'--------------- rh_gc ---------------------------'
- call wrf_debug(1,message)
- WRITE(message,*)rh_gc(100,100,:)
- call wrf_debug(1,message)
+! call wrf_debug(1,message)
+! WRITE(message,*)rh_gc(100,100,:)
+! call wrf_debug(1,message)
  WRITE(message,*)'--------------- t_gc --------------------------'
- call wrf_debug(1,message)
- WRITE(message,*)t_gc(100,100,:)
- call wrf_debug(1,message)
- WRITE(message,*)'------------------------------------------------'
- call wrf_debug(1,message)
+! call wrf_debug(1,message)
+! WRITE(message,*)t_gc(100,100,:)
+! call wrf_debug(1,message)
  WRITE(message,*)'------------------------------------------------'
- call wrf_debug(1,message)
+! call wrf_debug(1,message)
+! WRITE(message,*)'------------------------------------------------'
+! call wrf_debug(1,message)
 
 !
 !   SET UP IDEAL CONDITIONS
@@ -4796,7 +4800,7 @@ SUBROUTINE vortex ( ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc              &
   IF (WRF_DM_ON_MONITOR()) THEN
 !orig   OPEN(21,file='../MESSAGES/storm.center',status='old')
 !repository messages
-   OPEN(21,file='../messages/storm.center',status='old')
+   OPEN(21,file='storm.center',status='old')
    read(21,*)glat0
    read(21,*)glon0
    close(21)
@@ -4847,6 +4851,11 @@ SUBROUTINE vortex ( ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc              &
       endif
     enddo
   enddo
+! jbao-put storm in center
+        id1=ide/2
+        jd1=jde/2
+! end jbao-put storm in center
+
 
   IF(abs(ID0-ID1) .GE. 5 .OR. abs(JD0-JD1) .GE. 5)THEN
 !   call wrf_error_fatal("LAT LON INFO IN STROM MESSAGE FILE IN INCORRECT")
@@ -5051,24 +5060,25 @@ SUBROUTINE vortex ( ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc              &
      enddo
 
       WRITE(message,*)'--------------- new ght_gc --------------------------'
-      call wrf_debug(1,message)
-      WRITE(message,*)ght_gc(100,100,:)
-      call wrf_debug(1,message)
+!      call wrf_debug(1,message)
+!      WRITE(message,*)ght_gc(100,100,:)
+!      call wrf_debug(1,message)
       WRITE(message,*)'--------------- new p_gc --------------------------'
-      call wrf_debug(1,message)
-      WRITE(message,*)p_gc(100,100,:)
-      call wrf_debug(1,message)
+!      call wrf_debug(1,message)
+!      WRITE(message,*)p_gc(100,100,:)
+!      call wrf_debug(1,message)
       WRITE(message,*)'--------------- new rh_gc ---------------------------'
-      call wrf_debug(1,message)
-      WRITE(message,*)rh_gc(100,100,:)
-      call wrf_debug(1,message)
+!      call wrf_debug(1,message)
+!      WRITE(message,*)rh_gc(100,100,:)
+!      call wrf_debug(1,message)
       WRITE(message,*)'--------------- new t_gc --------------------------'
-      call wrf_debug(1,message)
-      WRITE(message,*)t_gc(100,100,:)
-      call wrf_debug(1,message)
-      WRITE(message,*)'---------------------------------------------------'
-      call wrf_debug(1,message)
+!      call wrf_debug(1,message)
+!      WRITE(message,*)t_gc(100,100,:)
+!      call wrf_debug(1,message)
+!      WRITE(message,*)'---------------------------------------------------'
+!      call wrf_debug(1,message)
 
+      WRITE(0,*)'tcbogus completed'
       WRITE(message,*)'tcbogus completed'
       call wrf_debug(1,message)
 
diff --git a/wrfv2_fire/dyn_nmm/module_membrane_mslp.F b/wrfv2_fire/dyn_nmm/module_membrane_mslp.F
new file mode 100644
index 00000000..226a33f1
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_membrane_mslp.F
@@ -0,0 +1,726 @@
+module module_membrane_mslp
+  implicit none
+  private
+
+#ifdef HWRF
+
+  public :: make_membrane_mslp
+
+  integer, parameter :: npres = 33
+  real, parameter :: badheight=-9e9
+
+  ! NCEP Unified Post standard pressure levels (SLPDEF) used for this
+  ! membrane MSLP calculation.  These are ALL of the post pressure
+  ! levels up to 200mbar:
+  real, parameter :: post_stdpres(npres) = (/ 20000.,          &
+       22500., 25000., 27500., 30000., 32500., 35000., 37500., 40000., &
+       42500., 45000., 47500., 50000., 52500., 55000., 57500., 60000., &
+       62500., 65000., 67500., 70000., 72500., 75000., 77500., 80000., &
+       82500., 85000., 87500., 90000., 92500., 95000., 97500.,100000./)
+
+  ! index within post_stdpres of the 850mbar and 700mbar levels, respectively:
+  integer, parameter :: k850 = 27, k700=21
+
+  ! Pressure "interface" levels, used only for interpolation.  These
+  ! are half-way between pressure levels (post_stdpres) in pressure
+  ! space (instead of z, Z or density), to match assumptions made in
+  ! the post's Memberane MSLP calculation:
+  real, parameter :: post_istdpres(npres+1) = (/ 18750., &
+       21250., 23750., 26250., 28750., 31250., 33750., 36250., 38750., &
+       41250., 43750., 46250., 48750., 51250., 53750., 56250., 58750., &
+       61250., 63750., 66250., 68750., 71250., 73750., 76250., 78750., &
+       81250., 83750., 86250., 88750., 91250., 93750., 96250., 98750., &
+       101250./)
+
+  ! Constants from the NCEP Unified Post used for interpolation and
+  ! extrapolation:
+  real, parameter :: post_H1=1.0
+  real, parameter :: post_PQ0=379.90516
+  real, parameter :: post_A2=17.2693882
+  real, parameter :: post_A3=273.16
+  real, parameter :: post_A4=35.86
+  real, parameter :: post_D608=0.608
+  real, parameter :: post_RD=287.04
+  real, parameter :: post_G=9.81
+  real, parameter :: post_GAMMA=6.5E-3
+  real, parameter :: post_RGAMOG=post_RD*post_GAMMA/post_G
+  real, parameter :: post_RHmin=1.0E-6     ! minimal RH bound
+  real, parameter :: post_smallQ=1.E-12
+
+  real, parameter :: post_slope=-6.6e-4 ! K/km
+
+  REAL, PARAMETER :: old_COEF3=post_RD*post_SLOPE
+  REAL, PARAMETER :: old_COEF2=-1./old_COEF3
+
+contains
+
+  subroutine make_membrane_mslp(grid)
+    USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid
+    implicit none
+    type(domain), intent(inout) :: grid
+    character*255 :: message
+
+    integer :: IDS,IDE,JDS,JDE,KDS,KDE
+    integer :: IMS,IME,JMS,JME,KMS,KME
+    integer :: IPS,IPE,JPS,JPE,KPS,KPE
+
+    ! Make sure the two constant pressure level values are right:
+100 format('In module_membrane_mslp, post_stdpres(',A,')=',F0.3,' but should be ',F0.3)
+    if(abs(post_stdpres(k850)-85000.)>1) then
+       write(message,100) 'k850',post_stdpres(k850),85000.
+       call wrf_error_fatal(message)
+    endif
+    if(abs(post_stdpres(k700)-70000.)>1) then
+       write(message,100) 'k850',post_stdpres(k700),70000.
+       call wrf_error_fatal(message)
+    endif
+
+    CALL get_ijk_from_grid (  grid ,      &
+         ids, ide, jds, jde, kds, kde,    &
+         ims, ime, jms, jme, kms, kme,    &
+         ips, ipe, jps, jpe, kps, kpe    )
+
+    call membrane_mslp_impl(grid,         &
+         ids, ide, jds, jde, kds, kde,    &
+         ims, ime, jms, jme, kms, kme,    &
+         ips, ipe, jps, jpe, kps, kpe    )
+
+  end subroutine make_membrane_mslp
+
+  ! ------------------------------------------------------------
+  ! BEGIN IMPLEMENTATION
+  ! ------------------------------------------------------------
+
+
+  ! ------------------------------------------------------------
+  ! membrane_mslp_impl - top-level implementation function
+  subroutine membrane_mslp_impl(grid, &
+       IDS,IDE,JDS,JDE,KDS,KDE, &
+       IMS,IME,JMS,JME,KMS,KME, &
+       IPS,IPE,JPS,JPE,KPS,KPE)
+    USE MODULE_DOMAIN, ONLY : domain
+    USE MODULE_RELAX
+#ifdef DM_PARALLEL
+    USE MODULE_COMM_DM, ONLY : HALO_NMM_MEMBRANE_INTERP_sub
+    USE MODULE_DM, ONLY: ntasks_x, ntasks_y, mytask, ntasks, local_communicator
+    use module_dm, only: wrf_dm_minval_real
+#endif
+
+    implicit none
+
+    type(domain), intent(inout) :: grid
+
+    integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE
+    integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME
+    integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE
+
+    real :: presTv(ips:ipe,jps:jpe,npres), Pmsl(ips:ipe,jps:jpe)
+    real :: presZ(ips:ipe,jps:jpe,npres)
+
+    real :: interP(ips:ipe,jps:jpe,npres+1), interZ(ips:ipe,jps:jpe,npres+1)
+
+    logical :: ground_mask(ips:ipe,jps:jpe,npres)
+    integer :: ground_level(ips:ipe,jps:jpe)
+    integer :: ipres,i,j,mpres,imin,jmin,k
+    real :: pmin
+    character*255 :: message
+
+    if(size(grid%p700rv)>1) then
+       ! Need a halo for winds in order to get vorticity and H point wind magnetudes:
+#ifdef DM_PARALLEL
+#      include "HALO_NMM_MEMBRANE_INTERP.inc"
+#endif
+    endif
+
+    ! UPPER BOUND: MPRES
+
+    ! Find mpres: the lowest pressure that we need to handle.  This is
+    ! mostly for efficiency: we don't need to interpolate or relax
+    ! anything higher in the atmosphere than the next pressure level
+    ! above the domain-wide lowest surface pressure:
+    pmin=9e9
+    imin=-99
+    jmin=-99
+    do j=max(jps,jds),min(jpe,jde-1)
+       do i=max(ips,ids),min(ipe,ide-1)
+          pmin=min(pmin,grid%pint(i,j,1))
+          imin=i
+          jmin=j
+       enddo
+    enddo
+#ifdef DM_PARALLEL
+    call wrf_dm_minval_real(pmin,imin,jmin)
+#endif
+
+    ! FIXME: DON'T HANDLE ANYTHING ABOVE PMIN
+    ! NOTE: MUST HANDLE TWO LEVELS ABOVE
+
+    ! Step 1: calculate Tv, Q and Z on pressure levels using the same
+    ! method as the NCEP Unified Post:
+    call calculate_3D(grid,presTv,presZ,ground_mask,ground_level, &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE)
+
+    ! Step 2: smooth Tv through an overrelaxation method:
+
+    ! Modify the relax mask so that the outermost three rows and
+    ! columns are always relaxed.  This is needed to overcome bad
+    ! values fed in from the parent every timestep.  Setting the mask
+    ! to true on the boundaries of the domain prevent them from being
+    ! used as boundaries of the overrelaxation.  
+
+    ! (Some of the reasons for boundary issues: The parent and nest
+    ! terrain will never match because the nest terrain is smoothed on
+    ! the boundary, and the parent is not.  Also, the user may have
+    ! set a different terrain for different domains in their
+    ! namelist.wps, in which case you'll get an even worse mismatch.
+    ! Every time the nest moves, ips terrain changes on the leading
+    ! and trailing edges of the nest.  That causes huge shocks when
+    ! there are high mountains near the boundaries.  If you do a plot
+    ! of 500mbar geopotential height, it looks like a piece of jello
+    ! shaking every time the nest moves.  Also, there is some
+    ! weirdness on the lateral boundaries of the MOAD due to the
+    ! mismatch between GFS terrain (which has its higher spectral
+    ! components discarded) and the smoothed HWRF terrain.)
+
+    grid%relaxmask=.true.
+
+    ! Now loop over all vertical levels and relax them:
+    do ipres=1,npres
+       ! Store Tv in relaxwork:
+       do j=jps,min(jde-1,jpe)
+          do i=ips,min(ide-1,ipe)
+             grid%relaxwork(i,j)=presTv(i,j,ipres)
+          enddo
+       enddo
+
+       ! In the inner regions (all but outermost row & col) set the
+       ! relaxmask to the ground_mask:
+       do j=max(jps,jds+1),min(jde-2,jpe)
+          do i=max(ips,ids+1),min(ide-2,ipe)
+             grid%relaxmask(i,j)=ground_mask(i,j,ipres)
+          enddo
+       enddo
+
+       ! Overrelax:
+       call relax4e(grid,0.7,100,2, &
+            IDS,IDE,JDS,JDE,KDS,KDE, &
+            IMS,IME,JMS,JME,KMS,KME, &
+            IPS,IPE,JPS,JPE,KPS,KPE)
+
+       ! Copy back the modified relaxation mask
+       do j=jps,min(jde-1,jpe)
+          do i=ips,min(ide-1,ipe)
+             ground_mask(i,j,ipres)=grid%relaxmask(i,j)
+          enddo
+       enddo
+
+       ! Copy the relaxed values back to Tv:
+       do j=jps,min(jde-1,jpe)
+          do i=ips,min(ide-1,ipe)
+             presTv(i,j,ipres)=grid%relaxwork(i,j)
+          enddo
+       enddo
+    end do
+
+    ! Step 3: Solve for Z on interface levels (pressure space
+    ! interface levels) using the hydrostatic equation.  Once Z=0 is
+    ! reached, solve for Pmsl.
+    call calculate_interP(presTv,presZ,grid%Z,Pmsl,grid%PINT, &
+         grid%T(:,:,1), grid%Q(:,:,1), &
+         ground_level, ground_mask,grid%fis, &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE)
+
+    ! Copy the MSLP values back to the grid:
+    do j=jps,min(jde-1,jpe)
+       do i=ips,min(ide-1,ipe)
+          grid%membrane_MSLP(i,j)=Pmsl(i,j)
+       enddo
+    enddo
+
+    ! Smooth the membrane_mslp values:
+    call smoothMSLP(grid,1, &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE)
+
+    if(size(grid%p850z)>1) then
+       ! Copy 700 and 850 mbar heights to their arrays:
+       do j=max(jds,jps),min(jde-1,jpe)
+          do i=max(ids,ips),min(ide-1,ipe)
+             grid%p850z(i,j)=presZ(i,j,k850)
+             grid%p700z(i,j)=presZ(i,j,k700)
+          enddo
+       enddo
+    endif
+
+  end subroutine membrane_mslp_impl
+
+  subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, &
+       IDS,IDE,JDS,JDE,KDS,KDE, &
+       IMS,IME,JMS,JME,KMS,KME, &
+       IPS,IPE,JPS,JPE,KPS,KPE)
+    USE MODULE_DOMAIN, ONLY : domain
+
+    implicit none
+
+    type(domain), intent(inout) :: grid
+
+    integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE
+    integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME
+    integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE
+
+    real, intent(inout) :: presTv(ips:ipe,jps:jpe,npres)
+    real, intent(inout) :: presZ(ips:ipe,jps:jpe,npres)
+
+    logical, intent(inout) :: ground_mask(ips:ipe,jps:jpe,npres)
+    integer, intent(inout) :: ground_level(ips:ipe,jps:jpe)
+
+    integer :: Tkdest(ips:ipe,jps:jpe), Zkdest(ips:ipe,jps:jpe), Zbottom(ips:ipe,jps:jpe)
+    integer :: i,j,ks,a,kd,k
+    real :: weight, TL,QL,PL, tempT, RHL, TVRL, TVRBLO, TBLO,QBLO
+
+    integer,target, dimension(ips:ipe,jps:jpe) :: ks850,ks700
+    integer, pointer, dimension(:,:) :: ksX
+
+    real, pointer, dimension(:,:) :: preswind,presrv
+
+    real :: Pmass(ips:ipe,jps:jpe,kds:kde)
+    real :: numsum,densum,modelP1,modelP2,pdiff,presQ,presT,ZL,QSAT, U1, V1, U2, V2, dudy1,dvdx1, dudy2,dvdx2
+
+    ! ks: k in source (model level) array
+    ! kd: k in destination (pressure level) array
+    ground_level=0
+    ground_mask=.false.
+    Zkdest=1
+    Tkdest=1
+    Zbottom=0
+
+    ks850=0
+    ks700=0
+
+    ! Interpolate geopotential height to post_stdpres pressure levels
+    ! and create a temporary array with non-hydrostatic pressure
+    ! (PINT) on model mass points:
+    do ks=kde-1,kds,-1
+       do j=jps,min(jde-1,jpe)
+          iZ: do i=ips,min(ide-1,ipe)
+             Pmass(i,j,ks)=sqrt(grid%PINT(i,j,ks)*grid%PINT(i,j,ks+1))
+          enddo iZ
+       enddo
+    enddo
+
+    ! Interpolate temperature and specific humidity to post_stdpres
+    ! pressure levels:
+    do ks=kde-1,kds+1,-1
+       do j=jps,min(jde-1,jpe)
+          iTQ: do i=ips,min(ide-1,ipe)
+             kd=Tkdest(i,j)
+             if(kd<=npres) then
+                innerTQ: do while(kd<=npres)
+                   if(.not.(post_stdpres(kd)<=Pmass(i,j,ks-1) &
+                        .and. post_stdpres(kd)>=Pmass(i,j,ks))) then
+                      cycle iTQ
+                   endif
+                   weight=log(post_stdpres(kd)/Pmass(i,j,ks))/log(Pmass(i,j,ks-1)/Pmass(i,j,ks))
+
+                   presZ(i,j,kd)=weight*grid%Z(i,j,ks-1) + (1.-weight)*grid%Z(i,j,ks)
+
+                   presT=weight*grid%T(i,j,ks-1) + (1.-weight)*grid%T(i,j,ks)
+                   presQ=weight*grid%Q(i,j,ks-1) + (1.-weight)*grid%Q(i,j,ks)
+                   presTv(i,j,kd)=presT*(1.+post_D608*presQ)
+
+                   if(kd==k850) then
+                      ks850(i,j)=ks
+                   elseif(kd==k700) then
+                      ks700(i,j)=ks
+                   endif
+
+103                format('interp ks=',I0,' kd=',I0,' presT(i=',I0,',j=',I0,',kd)=',F0.3, &
+                        ' between T(i,j,ks-1)=',F0.3,' and T(i,j,ks)=', &
+                        F0.3,' using weight=',F0.3)
+                   !write(0,103) ks,kd,i,j,presT,grid%T(i,j,ks-1),grid%T(i,j,ks),weight
+104                format(' Pmass(i,j,ks)=',F0.3,' Pmass(i,j,ks-1)=',F0.3,' post_stdpres(kd)=',F0.3)
+                   !write(0,104) Pmass(i,j,ks),Pmass(i,j,ks-1),post_stdpres(kd)
+                   if(weight<0 .or. weight>1) then
+                      write(0,*) 'Bad weight: ',weight
+                      call wrf_error_fatal('bad weight')
+                   endif
+                   kd=kd+1
+                   Tkdest(i,j)=kd
+                   Zkdest(i,j)=kd
+                   Zbottom(i,j)=ks
+                end do innerTQ
+             end if
+          end do iTQ
+       end do
+    end do
+
+   ! Interpolate to regions between the middle of the lowest mass
+   ! level and the bottom of the atmosphere:
+   do j=jps,min(jde-1,jpe)
+      iTQ2: do i=ips,min(ide-1,ipe)
+         kd=Zkdest(i,j)
+         if(kd<=npres) then
+            do while(kd<=npres)
+               if(.not.(post_stdpres(kd)<=grid%PINT(i,j,kds) &
+                    .and. post_stdpres(kd)>=Pmass(i,j,kds))) then
+                  cycle iTQ2
+               endif
+
+               presT=grid%T(i,j,1)
+               presQ=grid%Q(i,j,1)
+               presTv(i,j,kd)=presT*(1.+post_D608*presQ)
+
+               weight=log(post_stdpres(kd)/Pmass(i,j,kds))/log(grid%PINT(i,j,kds)/Pmass(i,j,kds))
+               presZ(i,j,kd)=(1.-weight)*grid%Z(i,j,1)+weight*grid%fis(i,j)/post_g
+
+               kd=kd+1
+               Tkdest(i,j)=kd
+               Zkdest(i,j)=kd
+               Zbottom(i,j)=ks
+            end do
+         end if
+      end do iTQ2
+   end do
+
+   ifwind: if(size(grid%p700rv)>1) then
+    ! Interpolate wind to H points on pressure levels, calculating
+    ! horizontal wind vector magnitude and vertical component of
+    ! vorticity.  Interpolate only to 700 and 850 mbar.
+    windloop: do k=1,2
+       if(k==1) then
+          ksX=>ks700
+          preswind=>grid%p700wind
+          presrv=>grid%p700rv
+          kd=k700
+       elseif(k==2) then
+          ksX=>ks850
+          kd=k850
+          preswind=>grid%p850wind
+          presrv=>grid%p850rv 
+      endif
+
+      ! No wind on boundaries:
+      if(jps<=jds) then
+         do i=ips,min(ide-1,ipe)
+            preswind(i,jds)=0
+            presrv(i,jds)=0
+         enddo
+      endif
+      if(jpe>=jde-1) then
+         do i=ips,min(ide-1,ipe)
+            preswind(i,jde-1)=0
+            presrv(i,jde-1)=0
+         enddo
+      endif
+      if(ips<=ids) then
+         do j=jps,min(jde-1,jpe)
+            preswind(ids,j)=0
+            presrv(ids,j)=0
+         enddo
+      endif
+      if(ipe>=ide-1) then
+         do j=jps,min(jde-1,jpe)
+            preswind(ide-1,j)=0
+            presrv(ide-1,j)=0
+         enddo
+      endif
+
+      ! Interpolate winds:
+      do j=max(jps,jds+2),min(jde-2,jpe)
+         a=mod(j,2)
+         do i=max(ips,ids+2),min(ide-2,ipe)
+            ks=ksX(i,j)
+            if(ks>1) then
+               ! Interpolate between mass levels:
+               weight=log(post_stdpres(kd)/Pmass(i,j,ks))/log(Pmass(i,j,ks-1)/Pmass(i,j,ks))
+
+               U1=0.25*(grid%u(i,j-1,ks) + grid%u(i,j+1,ks) + grid%u(i-a,j,ks) + grid%u(i+1-a,j,ks))
+               V1=0.25*(grid%v(i,j-1,ks) + grid%v(i,j+1,ks) + grid%v(i-a,j,ks) + grid%v(i+1-a,j,ks))
+               U2=0.25*(grid%u(i,j-1,ks-1) + grid%u(i,j+1,ks-1) + grid%u(i-a,j,ks-1) + grid%u(i+1-a,j,ks-1))
+               V2=0.25*(grid%v(i,j-1,ks-1) + grid%v(i,j+1,ks-1) + grid%v(i-a,j,ks-1) + grid%v(i+1-a,j,ks-1))
+               
+               dvdx1 = (grid%v(i+1-a,j,ks)-grid%v(i-a,j,ks))/(2.*grid%dx_nmm(i,j))
+               dudy1 = (grid%u(i,j+1,ks)-grid%u(i,j-1,ks))/(2.*grid%dy_nmm)
+               dvdx2 = (grid%v(i+1-a,j,ks-1)-grid%v(i-a,j,ks-1))/(2.*grid%dx_nmm(i,j))
+               dudy2 = (grid%u(i,j+1,ks-1)-grid%u(i,j-1,ks-1))/(2.*grid%dy_nmm)
+               
+               preswind(i,j)=weight*sqrt(u2*u2+v2*v2) + (1.-weight)*sqrt(u1*u1+v1*v1)
+               presrv(i,j)=(dvdx2-dudy2)*weight + (dvdx1-dudy1)*(1.-weight)
+            elseif(post_stdpres(kd)>=Pmass(i,j,kds)) then
+               ! At and below lowest mass level, use lowest model level winds
+               ks=1
+               U1=0.25*(grid%u(i,j-1,ks) + grid%u(i,j+1,ks) + grid%u(i-a,j,ks) + grid%u(i+1-a,j,ks))
+               V1=0.25*(grid%v(i,j-1,ks) + grid%v(i,j+1,ks) + grid%v(i-a,j,ks) + grid%v(i+1-a,j,ks))
+               
+               dvdx1 = (grid%v(i+1-a,j,ks)-grid%v(i-a,j,ks))/(2.*grid%dx_nmm(i,j))
+               dudy1 = (grid%u(i,j+1,ks)-grid%u(i,j-1,ks))/(2.*grid%dy_nmm)
+
+               preswind(i,j)=sqrt(u1*u1 + v1*v1)
+               presrv(i,j)=dvdx1-dudy1
+            endif
+         end do
+      end do
+   enddo windloop
+
+   ! Calculate 10m wind magnitude and vorticity
+   ! NOTE: u10 and v10 are already on H points
+   do j=max(jps,jds+1),min(jpe,jde-2)
+      a=mod(j,2)
+      do i=max(ips,ids+1),min(ipe,ide-2)
+         grid%m10wind(i,j)=sqrt(grid%u10(i,j)*grid%u10(i,j) + grid%v10(i,j)*grid%v10(i,j))
+         dvdx1 = 0.5*(grid%v10(i-a+1,j+1)-grid%v10(i-a,j+1) + &
+                     grid%v10(i-a+1,j-1)-grid%v10(i-a,j-1)) / (2*grid%dx_nmm(i,j))
+         dudy1 = 0.5*(grid%u10(i-a,j+1)-grid%u10(i-a,j-1) + &
+                     grid%u10(i-a+1,j+1)-grid%u10(i-a+1,j-1)) / (2*grid%dy_nmm)
+         grid%m10rv(i,j) = dvdx1 - dudy1
+      enddo
+   enddo
+  endif ifwind
+
+    do j=jps,min(jde-1,jpe)
+       do i=ips,min(ide-1,ipe)
+          ground_level(i,j)=min(Zkdest(i,j),Tkdest(i,j))
+       enddo
+    enddo
+
+    do kd=1,npres
+       do j=jps,min(jde-1,jpe)
+          do i=ips,min(ide-1,ipe)
+             ground_mask(i,j,kd) = (kd>=ground_level(i,j))
+          enddo
+       enddo
+    enddo
+
+    ! Extrapolate below-ground temperature but not height.  Fill in
+    ! badheight for height below ground.  
+    jloop2: do j=jps,min(jde-1,jpe)
+       iloop2: do i=ips,min(ide-1,ipe)
+          if(ground_level(i,j)>npres) then
+301          format('Extrap: i=',I0,' j=',I0,' NO EXTRAP: ground at ',I0)
+             !write(0,301) i,j,ground_level(i,j)
+             cycle iloop2
+          else
+302          format('Extrap: i=',I0,' j=',I0,' extrap from ',F0.3,' ground at ',I0)
+             !write(0,302) i,j,post_stdpres(ground_level(i,j)),ground_level(i,j)
+          endif
+          kloop2: do kd=ground_level(i,j),npres
+             ! Extrapolate first guess below-ground values using the
+             ! exact same method used in the post.  Even the constants
+             ! are copied from the post:
+             PL=grid%PINT(I,J,2)
+             ZL=0.5*(grid%Z(I,J,2)+grid%Z(I,J,1))
+             TL=0.5*(grid%T(I,J,2)+grid%T(I,J,1))
+             QL=0.5*(grid%Q(I,J,2)+grid%Q(I,J,1))
+             QSAT=post_PQ0/PL*EXP(post_A2*(TL-post_A3)/(TL-post_A4))
+             !
+             RHL=QL/QSAT
+             !
+             IF(RHL.GT.1.)THEN
+                RHL=1.
+                QL =RHL*QSAT
+             ENDIF
+             !
+             IF(RHL.LT.post_RHmin)THEN
+                RHL=post_RHmin
+                QL =RHL*QSAT
+             ENDIF
+             !
+             TVRL  =TL*(1.+post_D608*QL)
+             TVRBLO=TVRL*(post_stdpres(kd)/PL)**post_RGAMOG
+             TBLO  =TVRBLO/(1.+post_D608*QL)
+
+             !QSAT=post_PQ0/post_stdpres(kd)*EXP(post_A2*(TBLO-post_A3)/(TBLO-post_A4))
+
+             !QBLO =RHL*QSAT
+             !presQ(i,j,kd)=AMAX1(post_smallQ,QBLO)
+
+             presTv(i,j,kd)=TBLO
+
+             ! Extrapolated virtual temperature:
+             !presTv(i,j,kd)=TBLO*(1.+post_D608*QBLO)
+
+             ! extrapolated temperature, with virtual part removed using extrapolated specific humidity:
+             !presTv(i,j,kd)=TVRBLO/(1.+post_D608*QBLO)
+
+             ! Below-ground Z is recalcluated after smoothing Tv.  We
+             ! only fill in badval here:
+             presZ(i,j,kd)=badheight
+
+303          format('Extrap i=',I0,' j=',I0,' kd=',I0,' presTv=',F0.3,' presZ=',F0.3)
+304          format('   TL=',F0.3,' QL=',F0.3,' ZL=',F0.3,' QSAT=',F0.3)
+305          format('   TVRL=',F0.3,' TVRBLO=',F0.3,' TBLO=',F0.3,' RHL=',F0.3)
+             !write(0,303) i,j,kd,presTv(i,j,kd),presZ(i,j,kd)
+             !write(0,304) TL,QL,ZL,QSAT
+             !write(0,305) TVRL,TVRBLO,TBLO,RHL
+          enddo kloop2
+       enddo iloop2
+    enddo jloop2
+  end subroutine calculate_3D
+
+  subroutine calculate_interP( &
+       presTv,presZ,modelZ,Pmsl,PINT,T1,Q1, &
+       ground_level,ground_mask,fis, &
+       IDS,IDE,JDS,JDE,KDS,KDE, &
+       IMS,IME,JMS,JME,KMS,KME, &
+       IPS,IPE,JPS,JPE,KPS,KPE)
+    USE MODULE_DOMAIN, ONLY : domain
+
+    implicit none
+
+    integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE
+    integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME
+    integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE
+
+    real, intent(in) :: PINT(ims:ime,jms:jme,kms:kme), modelZ(ims:ime,jms:jme,kms:kme)
+    real, intent(in) :: T1(ims:ime,jms:jme,1)
+    real, intent(in) :: Q1(ims:ime,jms:jme,1)
+
+    real, intent(in) :: fis(ims:ime,jms:jme)
+    real, intent(out) :: Pmsl(ips:ipe,jps:jpe)
+    real, intent(inout) :: presTv(ips:ipe,jps:jpe,npres)
+    real, intent(inout) :: presZ(ips:ipe,jps:jpe,npres)
+
+    logical, intent(inout) :: ground_mask(ips:ipe,jps:jpe,npres)
+    integer, intent(inout) :: ground_level(ips:ipe,jps:jpe)
+
+    real :: Z,midTv,dZ,newZ,P,newP,TVRT,TLYR,DIS,oa,slope
+    integer :: kp,ip,i,j
+
+    ! What this code does:
+
+    ! For every point where the surface is above Z=0, we start from
+    ! the lowest above-ground pressure and integrate the hydrostatic
+    ! equation downward to find P at Z=0.
+
+    ! For points where the surface Z<=0 (surface is at or below sea
+    ! level), we interpolate to get P at Z=0.
+
+
+    ! STEP 1: extrapolate below-ground values
+    do j=jps,min(jde-1,jpe)
+       iloop: do i=ips,min(ide-1,ipe)
+          !          nearground: if(modelZ(i,j,1)<50.0) then
+          !             Pmsl(i,j)=pint1(i,j,1)
+          !                method(i,j)=-30
+          !          else
+          if(ground_level(i,j)post_stdpres(npres) .and. modelZ(i,j,1)>0.)then
+          !                  ! Model surface pressure is a higher pressure than the
+          !                  ! highest standard pressure level.  Use the model
+          !                  ! fields to extrapolate.
+          !                  TVRT=T1(I,J,1)*(post_H1+post_D608*Q1(I,J,1))
+          !                  !DIS=modelZ(I,J,2)-modelZ(I,J,1)+0.5*modelZ(I,J,2) ???
+          !                  DIS=0.5*(modelZ(I,J,2)+modelZ(I,J,1))
+          !                  TLYR=TVRT-DIS*post_SLOPE*post_G*0.5
+          !                  Pmsl(I,J)=PINT(I,J,1)*EXP((modelZ(I,J,1))*post_G/(post_RD*TLYR))
+          ! ! 1023            format('  use model: TVRT=',F0.3,' DIS=',F0.3,' TLYR=',F0.3,' Pmsl=',F0.3)
+          ! ! 1024            format('     result: ',F0.3,'*EXP(',F0.3,'/(',F0.3,'*',F0.3'))')
+          ! !                 write(0,1023) TVRT,DIS,TLYR,Pmsl(i,j)
+          ! !                 write(0,1024) PINT(I,J,1),modelZ(I,J,2),post_RD,TLYR
+          !                method(i,j)=-20
+          !               ELSE
+          ! Highest pressure level (post_stdpres(1)) has a
+          ! higher pressure than the model surface pressure, so
+          ! extrapolate using the pressure level values.
+1025      format('  use npres: TLYR=',F0.3,' Pmsl=',F0.3)
+1026      format('     result: ',F0.3,'/EXP(-',F0.3,'*',F0.3,'/(',F0.3,'*',F0.3,'))')
+          TLYR=presTv(I,J,npres)-presZ(I,J,npres)*post_SLOPE*post_G*0.5
+          Pmsl(I,J)=post_stdpres(npres)/EXP(-presZ(I,J,npres)*post_G/(post_RD*TLYR))
+          !oa=0.5*post_SLOPE*post_g*presZ(i,j,npres)/TLYR
+          !Pmsl(i,j)=post_stdpres(npres)*(1.-oa)**old_coef2
+          !write(0,1025) TLYR,Pmsl(I,J)
+          !write(0,1026) post_stdpres(npres),presZ(I,J,npres),post_G,post_RD,TLYR
+!          method(i,j)=-10
+          !             END IF
+          !          endif nearground
+       enddo iloop
+    enddo
+  end subroutine calculate_interP
+
+  subroutine smoothMSLP(grid,iterations,  &
+       IDS,IDE,JDS,JDE,KDS,KDE, &
+       IMS,IME,JMS,JME,KMS,KME, &
+       IPS,IPE,JPS,JPE,KPS,KPE)
+    use module_relax
+    USE MODULE_DOMAIN, ONLY : domain
+    implicit none
+    type(domain), intent(inout) :: grid
+    integer, intent(in) :: iterations
+
+    integer :: IDS,IDE,JDS,JDE,KDS,KDE
+    integer :: IMS,IME,JMS,JME,KMS,KME
+    integer :: IPS,IPE,JPS,JPE,KPS,KPE
+    integer :: i,j
+
+    do j=jps,min(jde-1,jpe)
+       do i=ips,min(ide-1,ipe)
+          grid%relaxmask(i,j)=.true.
+          grid%relaxwork(i,j)=grid%membrane_mslp(i,j)
+       enddo
+    enddo
+
+    call relax4e(grid,0.5,iterations,0, &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE)
+
+    do j=jps,min(jde-1,jpe)
+       do i=ips,min(ide-1,ipe)
+          grid%membrane_mslp(i,j)=grid%relaxwork(i,j)
+       enddo
+    enddo
+
+  end subroutine smoothMSLP
+
+#endif
+end module module_membrane_mslp
diff --git a/wrfv2_fire/dyn_nmm/module_relax.F b/wrfv2_fire/dyn_nmm/module_relax.F
new file mode 100644
index 00000000..9b3a33e0
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_relax.F
@@ -0,0 +1,221 @@
+module module_relax
+  implicit none
+contains
+  subroutine relax4e(grid,relax_coeff,nrelax,expand,  &
+       IDS,IDE,JDS,JDE,KDS,KDE, &
+       IMS,IME,JMS,JME,KMS,KME, &
+       IPS,IPE,JPS,JPE,KPS,KPE)
+    USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid
+#ifdef DM_PARALLEL
+    USE MODULE_COMM_DM, ONLY : HALO_NMM_MEMBRANE_RELAX_sub, HALO_NMM_MEMBRANE_MASK_sub
+    USE MODULE_DM, ONLY: ntasks_x, ntasks_y, mytask, ntasks, local_communicator
+#endif
+    implicit none
+    type(domain), intent(inout) :: grid
+    real, intent(in) :: relax_coeff
+    integer, intent(in) :: nrelax
+    integer, intent(in) :: expand
+
+    integer :: IDS,IDE,JDS,JDE,KDS,KDE
+    integer :: IMS,IME,JMS,JME,KMS,KME
+    integer :: IPS,IPE,JPS,JPE,KPS,KPE
+    real :: nextvalue(ims:ime,jms:jme)
+    real :: r,r1
+    integer :: i,j,irelax,a,iter
+
+    ! Aliases to simplify the expressions below, we'll use "r" instead
+    ! of relax_coeff, and r1 instead of 1-r:
+    r=relax_coeff
+    r1=1.0-r
+
+    ! Relax all points within "expand" gridpoints of a point that
+    ! wants to be relaxed:
+    expand_relax: if(expand>0) then
+       do j=jps,min(jpe,jde-1)
+          do i=ips,min(ipe,ide-1)
+             if(grid%relaxmask(i,j)) then
+                grid%relaximask(i,j)=1
+             else
+                grid%relaximask(i,j)=0
+             endif
+          enddo
+       enddo
+       if(.false.) then
+          do iter=1,expand
+#ifdef DM_PARALLEL
+#      include "HALO_NMM_MEMBRANE_MASK.inc"
+#endif
+             do j=max(jps,jds+1),min(jpe,jde-2)
+                a=mod(j,2)
+                do i=max(ips,ids+1),min(ipe,ide-2)
+                   grid%relaximask(i,j) = grid%relaximask(i,j) + &
+                        grid%relaximask(i-a, j-1) + &
+                        grid%relaximask(i-a, j+1) + &
+                        grid%relaximask(i+1-a, j+1) + &
+                        grid%relaximask(i+1-a, j-1)
+                enddo
+             enddo
+          enddo
+       endif
+       do j=jps,min(jpe,jde-1)
+          do i=ips,min(ipe,ide-1)
+             if(grid%relaximask(i,j)>0) then
+                grid%relaxmask(i,j)=.true.
+             endif
+          enddo
+       enddo
+    endif expand_relax
+    relaxloop: do irelax=1,nrelax
+#ifdef DM_PARALLEL
+#      include "HALO_NMM_MEMBRANE_RELAX.inc"
+#endif
+
+       !$omp parallel do      &
+       !$omp private(i,j,a)
+       bigj: do j=max(jps,jds+1),min(jpe,jde-2)
+          a=mod(j,2)
+          bigi: do i=max(ips,ids+1),min(ipe,ide-2)
+             if(grid%relaxmask(i,j)) then
+                nextvalue(i,j) = &
+                     r1 * grid%relaxwork(i,j) + &
+                     r * ( &
+                     grid%relaxwork(i-a,  j-1) + &
+                     grid%relaxwork(i-a,  j+1) + &
+                     grid%relaxwork(i+1-a,j+1) + &
+                     grid%relaxwork(i+1-a,j-1) )/4.
+             else
+                nextvalue(i,j) = grid%relaxwork(i,j)
+             endif
+          enddo bigi
+       enddo bigj
+       ! Handle boundary points next.
+       ! SOUTH:
+       if(jps<=jds) then
+          j=1
+          a=mod(j,2)
+          !$omp parallel do      &
+          !$omp private(i,j,a)
+          do i=max(ips,ids+1),min(ipe,ide-2)
+             if(grid%relaxmask(i,j)) then
+                nextvalue(i,j) = &
+                     r1 * grid%relaxwork(i,j) + r * &
+                     (grid%relaxwork(i-a,  j+1) + grid%relaxwork(i+1-a,j+1) )/2.
+             else
+                nextvalue(i,j)=grid%relaxwork(i,j)
+             endif
+          enddo
+       endif
+       ! NORTH:
+       if(jpe>=jde-1) then
+          j=jde-1
+          a=mod(j,2)
+          !$omp parallel do      &
+          !$omp private(i,j,a)
+          do i=max(ips,ids+1),min(ipe,ide-2)
+             if(grid%relaxmask(i,j)) then
+                nextvalue(i,j) = &
+                     r1 * grid%relaxwork(i,j) + r * &
+                     (grid%relaxwork(i-a,  j-1) + grid%relaxwork(i+1-a,j-1) )/2.
+             else
+                nextvalue(i,j)=grid%relaxwork(i,j)
+             endif
+          enddo
+       endif
+       ! WEST:
+       if(ips<=ids) then
+          i=1
+          !$omp parallel do      &
+          !$omp private(i,j,a)
+          do j=max(jps,jds+1),min(jpe,jde-2)
+             a=mod(j,2)
+             if(grid%relaxmask(i,j)) then
+                nextvalue(i,j) = &
+                     r1 * grid%relaxwork(i,j) + r * &
+                     (grid%relaxwork(i+1-a,j+1) + grid%relaxwork(i+1-a,j-1) )/2.
+             else
+                nextvalue(i,j)=grid%relaxwork(i,j)
+             endif
+          enddo
+       endif
+       ! EAST:
+       if(ipe>=ide-1) then
+          i=ide-1
+          !$omp parallel do      &
+          !$omp private(i,j,a)
+          do j=max(jps,jds+1),min(jpe,jde-2)
+             a=mod(j,2)
+             if(grid%relaxmask(i,j)) then
+                nextvalue(i,j) = &
+                     r1 * grid%relaxwork(i,j) + r * &
+                     (grid%relaxwork(i-a,j+1) + grid%relaxwork(i-a,j-1) )/2.
+             else
+                nextvalue(i,j)=grid%relaxwork(i,j)
+             endif
+          enddo
+       endif
+
+       ! Finally, handle corner points:
+       ! SOUTHWEST:
+       if(ips<=ids .and. jps<=jds) then
+          if(grid%relaxmask(ids,jds)) then
+             nextvalue(ids,jds) = &
+                  r1 * grid%relaxwork(ids,jds) + r * &
+                  grid%relaxwork(ids,  jds+1)
+          else
+             nextvalue(ids,jds)=grid%relaxwork(ids,jds)
+          end if
+       endif
+       ! SOUTHEAST:
+       if(ipe>=ide-1 .and. jps<=jds) then
+          if(grid%relaxmask(ide-1,jds)) then
+             nextvalue(ide-1,jds) = &
+                  r1 * grid%relaxwork(ide-1,jds) + r * &
+                  (grid%relaxwork(ide-1,jds+1) + grid%relaxwork(ide-2,jds))/2.
+          else
+             nextvalue(ide-1,jds)=grid%relaxwork(ide-1,jds)
+          endif
+       endif
+       ! NORTHWEST:
+       if(ips<=ids .and. jpe>=jde-1) then
+          if(grid%relaxmask(ids,jde-1)) then
+             a=mod(jde-1,2)
+             if(a==1) then
+                nextvalue(ids,jde-1) = &
+                     r1 * grid%relaxwork(ids,jde-1) + r * &
+                     grid%relaxwork(ids,jde-2)
+             else
+                nextvalue(ids,jde-1) = &
+                     r1 * grid%relaxwork(ids,jde-1) + r * &
+                     (grid%relaxwork(ids,jde-2) + grid%relaxwork(ids+1,jde-2))/2.
+             endif
+          else
+             nextvalue(ids,jde-1)=grid%relaxwork(ids,jde-1)
+          endif
+       endif
+       ! NORTHEAST:
+       if(ipe>=ide-1 .and. jpe>=jde-1) then
+          if(grid%relaxmask(ide-1,jde-1)) then
+             a=mod(jde-1,2)
+             if(a==0) then
+                nextvalue(ide-1,jde-1) = &
+                     r1 * grid%relaxwork(ide-1,jde-1) + r * &
+                     grid%relaxwork(ide-1,jde-2)
+             else
+                nextvalue(ide-1,jde-1) = &
+                     r1 * grid%relaxwork(ide-1,jde-1) + r * &
+                     (grid%relaxwork(ide-1,jde-2) + grid%relaxwork(ide-2,jde-2))/2.
+             endif
+          else
+             nextvalue(ide-1,jde-1)=grid%relaxwork(ide-1,jde-1)
+          endif
+       endif
+
+       do j=max(jps,jds),min(jpe,jde-1)
+          a=mod(j,2)
+          do i=max(ips,ids),min(ipe,ide-1)
+             grid%relaxwork(i,j)=nextvalue(i,j)
+          enddo
+       enddo
+    enddo relaxloop
+  end subroutine relax4e
+end module module_relax
diff --git a/wrfv2_fire/dyn_nmm/module_si_io_nmm.F b/wrfv2_fire/dyn_nmm/module_si_io_nmm.F
index 497f9d0d..88bf3d4d 100644
--- a/wrfv2_fire/dyn_nmm/module_si_io_nmm.F
+++ b/wrfv2_fire/dyn_nmm/module_si_io_nmm.F
@@ -1394,6 +1394,24 @@ END SUBROUTINE read_si
 ! ------------------------------------------------------------
 ! ------------------------------------------------------------
 
+#if defined ( NO_IEEE_MODULE )
+   SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels )
+
+      USE module_domain
+
+      IMPLICIT NONE
+
+#if defined(DM_PARALLEL) && !defined(STUBMPI)
+      INCLUDE "mpif.h"
+#endif
+
+      TYPE(domain) ,       INTENT(INOUT)  :: grid
+      CHARACTER (*) ,      INTENT(IN)     :: filename
+      CHARACTER (LEN=19) , INTENT(IN)     :: file_date_string !not used
+      INTEGER ,            INTENT(IN)     :: num_metgrid_levels
+      
+   END SUBROUTINE read_wps
+#else
    SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels )
 
       USE module_soil_pre
@@ -1866,5 +1884,6 @@ SUBROUTINE read_wps ( grid, filename, file_date_string, num_metgrid_levels )
         enddo
 
      end subroutine read_wps
+#endif
 
 END MODULE module_si_io_nmm
diff --git a/wrfv2_fire/dyn_nmm/module_tracker.F b/wrfv2_fire/dyn_nmm/module_tracker.F
new file mode 100644
index 00000000..7c37dc1c
--- /dev/null
+++ b/wrfv2_fire/dyn_nmm/module_tracker.F
@@ -0,0 +1,990 @@
+module module_tracker
+  implicit none
+  private
+#ifdef HWRF
+  public :: ncep_tracker_center, ncep_tracker_init
+
+  real, parameter :: invE=0.36787944117 ! 1/e
+
+  ! Copied from tracker:
+  real,parameter :: searchrad=250.0 ! km - ignore data more than this far from domain center
+  integer, parameter :: maxtp=11 ! number of tracker parameters
+  real, parameter :: uverrmax = 225.0  ! For use in get_uv_guess
+  real, parameter :: ecircum = 40030.2  ! Earth's circumference
+  ! (km) using erad=6371.e3
+  real, parameter :: rads_vmag=120.0 ! max search radius for wind minimum
+  real, parameter :: err_reg_init=300.0 ! max err at initial time (km)
+  real, parameter :: err_reg_max=225.0 ! max err at other times (km)
+
+  real, parameter :: errpmax=485.0 ! max stddev of track parameters
+  real, parameter :: errpgro=1.25 ! stddev multiplier
+
+contains
+
+  subroutine ncep_tracker_init(grid)
+    ! Initialize tracker variables in the grid structure.
+    use module_domain, only: domain
+    implicit none
+    type(domain), intent(inout) :: grid
+    call wrf_message('ncep_tracker_init')
+    grid%track_stderr_m1=-99.9
+    grid%track_stderr_m2=-99.9
+    grid%track_stderr_m3=-99.9
+    grid%tracker_fixlon=-999.0
+    grid%tracker_fixlat=-999.0
+    grid%tracker_ifix=-99
+    grid%tracker_jfix=-99
+    grid%tracker_havefix=.false.
+    grid%tracker_gave_up=.false.
+  end subroutine ncep_tracker_init
+
+  subroutine ncep_tracker_center(grid)
+    ! Top-level entry to the inline ncep tracker.  Finds the center of
+    ! the storm in the specified grid and updates the grid variables.
+    ! Will do nothing and return immediately if
+    ! grid%tracker_gave_up=.true.
+
+    USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid
+    implicit none
+    type(domain), intent(inout) :: grid
+    character*255 :: message
+
+    integer :: IDS,IDE,JDS,JDE,KDS,KDE
+    integer :: IMS,IME,JMS,JME,KMS,KME
+    integer :: IPS,IPE,JPS,JPE,KPS,KPE
+
+    CALL get_ijk_from_grid (  grid ,      &
+         ids, ide, jds, jde, kds, kde,    &
+         ims, ime, jms, jme, kms, kme,    &
+         ips, ipe, jps, jpe, kps, kpe    )
+
+    call ntc_impl(grid,                &
+         ids, ide, jds, jde, kds, kde,    &
+         ims, ime, jms, jme, kms, kme,    &
+         ips, ipe, jps, jpe, kps, kpe    )
+  end subroutine ncep_tracker_center
+
+  subroutine ntc_impl(grid, &
+       IDS,IDE,JDS,JDE,KDS,KDE, &
+       IMS,IME,JMS,JME,KMS,KME, &
+       IPS,IPE,JPS,JPE,KPS,KPE)
+    USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid
+#ifdef DM_PARALLEL
+    use module_dm, only: wrf_dm_sum_real
+#endif
+    implicit none
+    type(domain), intent(inout) :: grid
+    integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE
+    integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME
+    integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE
+
+    real :: dxdymean, sum
+    integer :: i,j, iweights,ip
+
+
+    integer :: iguess, jguess ! first guess location
+    real :: latguess, longuess ! same, but in lat & lon
+
+    integer :: iuvguess, juvguess ! "second guess" location using everything except wind maxima
+    real :: srsq
+    integer :: ifinal,jfinal
+    real :: latfinal,lonfinal
+    integer :: ierr
+    integer :: icen(maxtp), jcen(maxtp) ! center locations for each parameter
+    real :: loncen(maxtp), latcen(maxtp) ! lat, lon locations in degrees
+    logical :: calcparm(maxtp) ! do we have a valid center location for this parameter?
+    real :: rcen(maxtp) ! center value (max wind, min mslp, etc.)
+
+    logical :: north_hemi ! true = northern hemisphere
+
+    ! icen,jcen: Same meaning as clon, clat in tracker, but uses i and
+    ! j indexes of the center instead of lat/lon.  Tracker comment:
+    !            Holds the coordinates for the center positions for
+    !            all storms at all times for all parameters.
+    !            (max_#_storms, max_fcst_times, max_#_parms).
+    !            For the third position (max_#_parms), here they are:
+    !             1: Relative vorticity at 850 mb
+    !             2: Relative vorticity at 700 mb
+    !             3: Vector wind magnitude at 850 mb
+    !             4: NOT CURRENTLY USED
+    !             5: Vector wind magnitude at 700 mb
+    !             6: NOT CURRENTLY USED
+    !             7: Geopotential height at 850 mb
+    !             8: Geopotential height at 700 mb
+    !             9: Mean Sea Level Pressure
+    !            10: Vector wind magnitude at 10 m
+    !            11: Relative vorticity at 10 m
+
+    call wrf_message('ncep_tracker_center')
+
+    ! Initialize center information to invalid values for all centers:
+    icen=-99
+    jcen=-99
+    latcen=9e9
+    loncen=9e9
+    rcen=9e9
+    calcparm=.false.
+    srsq=searchrad*searchrad*1e6
+
+    ! Hard coded first-guess center is domain center:
+    iguess=ide/2
+    jguess=jde/2
+    call get_lonlat(grid,iguess,jguess,longuess,latguess,ierr, &
+         ids,ide, jds,jde, kds,kde, &
+         ims,ime, jms,jme, kms,kme, &
+         ips,ipe, jps,jpe, kps,kpe)
+    if(ierr/=0) then
+       call wrf_error_fatal("ERROR: center of domain is not inside the domain")
+    endif
+    north_hemi = latguess>0.0
+
+    ! Get the mean V-to-H point-to-point distance:
+    sum=0
+    do j=jps,min(jde-1,jpe)
+       do i=ips,min(ide-1,ipe)
+          sum=sum+grid%dx_nmm(i,j)
+       enddo
+    enddo
+#ifdef DM_PARALLEL
+    sum=wrf_dm_sum_real(sum)
+#endif
+    dxdymean=0.5*(grid%dy_nmm + sum/( (ide-ids) * (jde-jds) ))/1000.0
+33  format ('dxdymean=',F0.3,' dx=',F0.3,' dy=',F0.3,' sum=',F0.3,' count=',I0)
+    !write(0,33) dxdymean,grid%dx_nmm((ips+ipe)/2,(jps+jpe)/2),grid%dy_nmm, &
+    !     sum,(ide-ids) * (jde-jds)
+
+    ! Find the centers of all fields except the wind minima:
+    call find_center(grid,grid%p850rv,grid%sp850rv,srsq, &
+         icen(1),jcen(1),rcen(1),calcparm(1),loncen(1),latcen(1),dxdymean,'zeta', &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE, north_hemi=north_hemi)
+    call find_center(grid,grid%p700rv,grid%sp700rv,srsq, &
+         icen(2),jcen(2),rcen(2),calcparm(2),loncen(2),latcen(2),dxdymean,'zeta', &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE, north_hemi=north_hemi)
+    call find_center(grid,grid%p850z,grid%sp850z,srsq, &
+         icen(7),jcen(7),rcen(7),calcparm(7),loncen(7),latcen(7),dxdymean,'hgt', &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE)
+    call find_center(grid,grid%p700z,grid%sp700z,srsq, &
+         icen(8),jcen(8),rcen(8),calcparm(8),loncen(8),latcen(8),dxdymean,'hgt', &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE)
+    call find_center(grid,grid%membrane_mslp,grid%smslp,srsq, &
+         icen(9),jcen(9),rcen(9),calcparm(9),loncen(9),latcen(9),dxdymean,'slp', &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE)
+    call find_center(grid,grid%m10rv,grid%sm10rv,srsq, &
+         icen(11),jcen(11),rcen(11),calcparm(11),loncen(11),latcen(11),dxdymean,'zeta', &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE, north_hemi=north_hemi)
+
+    ! Get a guess center location for the wind minimum searches:
+    call get_uv_guess(grid,icen,jcen,loncen,latcen,calcparm, &
+         iguess,jguess,longuess,latguess,iuvguess,juvguess, &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE)
+
+    ! Find wind minima.  Requires a first guess center:
+    call find_center(grid,grid%p850wind,grid%sp850wind,srsq, &
+         icen(3),jcen(3),rcen(3),calcparm(3),loncen(3),latcen(3),dxdymean,'wind', &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE, &
+         iuvguess=iuvguess, juvguess=juvguess)
+    call find_center(grid,grid%p700wind,grid%sp700wind,srsq, &
+         icen(5),jcen(5),rcen(5),calcparm(5),loncen(5),latcen(5),dxdymean,'wind', &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE, &
+         iuvguess=iuvguess, juvguess=juvguess)
+    call find_center(grid,grid%m10wind,grid%sm10wind,srsq, &
+         icen(10),jcen(10),rcen(10),calcparm(10),loncen(10),latcen(10),dxdymean,'wind', &
+         IDS,IDE,JDS,JDE,KDS,KDE, &
+         IMS,IME,JMS,JME,KMS,KME, &
+         IPS,IPE,JPS,JPE,KPS,KPE, &
+         iuvguess=iuvguess, juvguess=juvguess)
+
+    ! Get a final guess center location:
+    call fixcenter(grid,icen,jcen,calcparm,loncen,latcen, &
+         iguess,jguess,longuess,latguess, &
+         ifinal,jfinal,lonfinal,latfinal, &
+         north_hemi, &
+         ids,ide, jds,jde, kds,kde, &
+         ims,ime, jms,jme, kms,kme, &
+         ips,ipe, jps,jpe, kps,kpe)
+
+    grid%tracker_fixes=0
+    do ip=1,maxtp
+       if(calcparm(ip)) then
+300       format('Parameter ',I0,': i=',I0,' j=',I0,' lon=',F0.2,' lat=',F0.2)
+          !write(0,300) ip,icen(ip),jcen(ip),loncen(ip),latcen(ip)
+          if(icen(ip)>=ips .and. icen(ip)<=ipe &
+               .and. jcen(ip)>=jps .and. jcen(ip)<=jpe) then
+             grid%tracker_fixes(icen(ip),jcen(ip))=ip
+          endif
+       else
+301       format('Parameter ',I0,' invalid')
+          !write(0,301) ip
+       endif
+    enddo
+
+    if(iguess>=ips .and. iguess<=ipe .and. jguess>=jps .and. jguess<=jpe) then
+       grid%tracker_fixes(iguess,jguess)=-1
+201    format('First guess: i=',I0,' j=',I0,' lon=',F0.2,' lat=',F0.2)
+       !write(0,201) iguess,jguess,longuess,latguess
+    endif
+
+    if(iuvguess>=ips .and. iuvguess<=ipe .and. juvguess>=jps .and. juvguess<=jpe) then
+       grid%tracker_fixes(iuvguess,juvguess)=-2
+202    format('UV guess: i=',I0,' j=',I0)
+       !write(0,202) iguess,jguess
+    endif
+
+1000 format('Back with final lat/lon at i=',I0,' j=',I0,' lon=',F0.3,' lat=',F0.3)
+    !write(0,1000) ifinal,jfinal,lonfinal,latfinal
+
+    if(ifinal>=ips .and. ifinal<=ipe .and. jfinal>=jps .and. jfinal<=jpe) then
+       grid%tracker_fixes(ifinal,jfinal)=-3
+203    format('Final fix: i=',I0,' j=',I0,' lon=',F0.2,' lat=',F0.2)
+       !write(0,201) ifinal,jfinal,lonfinal,latfinal
+    endif
+
+    ! Get the MSLP minimum location and determine if what we found is
+    ! still a storm:
+
+    !FIXME: INSERT CODE HERE
+
+    ! Get the wind maximum location:
+
+    !FIXME: INSERT CODE HERE
+
+    ! Get the guess location for the next time:
+
+  end subroutine ntc_impl
+
+  subroutine fixcenter(grid,icen,jcen,calcparm,loncen,latcen, &
+       iguess,jguess,longuess,latguess, &
+       ifinal,jfinal,lonfinal,latfinal, &
+       north_hemi, &
+       ids,ide, jds,jde, kds,kde, &
+       ims,ime, jms,jme, kms,kme, &
+       ips,ipe, jps,jpe, kps,kpe)
+    ! This is the same as "fixcenter" in gettrk_main
+    ! ABSTRACT: This subroutine loops through the different parameters
+    !           for the input storm number (ist) and calculates the 
+    !           center position of the storm by taking an average of
+    !           the center positions obtained for those parameters.
+    !           First we check to see which parameters are within a 
+    !           max error range (errmax), and we discard those that are
+    !           not within that range.  Of the remaining parms, we get 
+    !           a mean position, and then we re-calculate the position
+    !           by giving more weight to those estimates that are closer
+    !           to this mean first-guess position estimate.
+
+    ! Arguments: Input:
+    ! grid - the grid being processed
+    ! icen,jcen - arrays of center gridpoint locations
+    ! calcperm - array of center validity flags (true = center is valid)
+    ! loncen,latcen - center geographic locations
+    ! iguess,jguess - first guess gridpoint location
+    ! longuess,latguess - first guess geographic location
+
+    ! Arguments: Output:
+    ! ifinal,jfinal - final center gridpoint location
+    ! lonfinal,latfinal - final center geographic location
+
+    ! Arguments: Optional input:
+    ! north_hemi - true = northern hemisphere, false=south
+
+    use module_wrf_error
+    USE MODULE_DOMAIN, ONLY : domain, domain_clock_get
+    implicit none
+    integer, intent(in) :: &
+         ids,ide, jds,jde, kds,kde, &
+         ims,ime, jms,jme, kms,kme, &
+         ips,ipe, jps,jpe, kps,kpe
+    type(domain), intent(inout) :: grid
+    integer, intent(in) :: icen(maxtp), jcen(maxtp)
+    real, intent(in) :: loncen(maxtp), latcen(maxtp)
+    logical, intent(inout) :: calcparm(maxtp)
+
+    integer, intent(in) :: iguess,jguess
+    real, intent(in) :: latguess,longuess
+
+    integer, intent(inout) :: ifinal,jfinal
+    real, intent(inout) :: lonfinal,latfinal
+
+    logical, intent(in), optional :: north_hemi
+
+    character*255 :: message
+    real :: errdist(maxtp),avgerr,errmax,errinit,xavg_stderr
+    real :: dist,degrees, total
+    real :: minutes,hours,trkerr_avg, dist_from_mean(maxtp),wsum
+    integer :: ip,itot4next,iclose,count,ifound,ierr
+    integer(kind=8) :: isum,jsum
+    real :: irsum,jrsum,errtmp,devia,wtpos
+    real :: xmn_dist_from_mean, stderr_close
+    logical use4next(maxtp)
+
+    ! Determine forecast hour:
+    call domain_clock_get(grid,minutesSinceSimulationStart=minutes)
+    hours=minutes/60.
+
+    ! Decide maximum values for distance and std. dev.:
+    if(hours<0.5) then
+       errmax=err_reg_init
+       errinit=err_reg_init
+    else
+       errmax=err_reg_max
+       errinit=err_reg_max
+    endif
+
+    if(hours>4.) then
+       xavg_stderr = ( grid%track_stderr_m1 + &
+            grid%track_stderr_m2 + grid%track_stderr_m3 ) / 3.0
+    elseif(hours>3.) then
+       xavg_stderr = ( grid%track_stderr_m1 + grid%track_stderr_m2 ) / 2.0
+    elseif(hours>2.) then
+       xavg_stderr = grid%track_stderr_m1
+    endif
+
+    if(hours>2.) then
+       errtmp = 3.0*xavg_stderr*errpgro
+       errmax = max(errtmp,errinit)
+       errtmp = errpmax
+       errmax = min(errmax,errtmp)
+    endif
+
+    ! Initialize loop variables:
+    errdist=0.0
+    use4next=.false.
+    trkerr_avg=0
+    itot4next=0
+    iclose=0
+    isum=0
+    jsum=0
+    ifound=0
+
+    !write(0,*) 'errpmax=',errpmax
+    !write(0,*) 'errmax=',errmax
+
+500 format('Parm ip=',I0,' dist=',F0.3)
+501 format('  too far, but discard')
+    do ip=1,maxtp
+       if(ip==4 .or. ip==6) then
+          calcparm(ip)=.false.
+          cycle
+       elseif(calcparm(ip)) then
+          ifound=ifound+1
+          call calcdist(longuess,latguess,loncen(ip),latcen(ip),dist,degrees)
+          errdist(ip)=dist
+          !write(0,500) ip,dist
+          if(dist<=errpmax) then
+             if(ip==3 .or. ip==5 .or. ip==10) then
+                use4next(ip)=.false.
+                !write(0,'(A)') '  within range but discard: errpmax'
+             else
+                !write(0,'(A)') '  within range and keep: errpmax'
+                use4next(ip)=.true.
+                trkerr_avg=trkerr_avg+dist
+                itot4next=itot4next+1
+             endif
+          endif
+          if(dist<=errmax) then
+502          format('  apply i=',I0,' j=',I0)
+             !write(0,502) icen(ip),jcen(ip)
+             iclose=iclose+1
+             isum=isum+icen(ip)
+             jsum=jsum+jcen(ip)
+503          format(' added things isum=',I0,' jsum=',I0,' iclose=',I0)
+             !write(0,503) isum,jsum,iclose
+          else
+             !write(0,*) '  discard; too far: errmax'
+             calcparm(ip)=.false.
+          endif
+       endif
+    enddo
+
+    if(ifound<=0) then
+       call wrf_message('The tracker could not find the centers for any parameters.  Thus,')
+       call wrf_message('a center position could not be obtained for this storm.')
+       goto 999
+    endif
+
+    if(iclose<=0) then
+200    format('No storms are within errmax=',F0.1,'km of the parameters')
+       !write(message,200) errmax
+       call wrf_message(message)
+       goto 999
+    endif
+
+    ifinal=real(isum)/real(iclose)
+    jfinal=real(jsum)/real(iclose)
+
+504 format(' calculated ifinal, jfinal: ifinal=',I0,' jfinal=',I0,' isum=',I0,' jsum=',I0,' iclose=',I0)
+    !write(0,504) ifinal,jfinal,isum,jsum,iclose
+
+    call get_lonlat(grid,ifinal,jfinal,lonfinal,latfinal,ierr, &
+         ids,ide, jds,jde, kds,kde, &
+         ims,ime, jms,jme, kms,kme, &
+         ips,ipe, jps,jpe, kps,kpe)
+    if(ierr/=0) then
+       write(0,*) 'bad bad naughty final (1)'
+       goto 999
+    endif
+
+    count=0
+    dist_from_mean=0.0
+    total=0.0
+    do ip=1,maxtp
+       if(calcparm(ip)) then
+          call calcdist(lonfinal,latfinal,loncen(ip),latcen(ip),dist,degrees)
+          dist_from_mean(ip)=dist
+          total=total+dist
+          count=count+1
+       endif
+    enddo
+    xmn_dist_from_mean=total/real(count)
+
+    do ip=1,maxtp
+       if(calcparm(ip)) then
+          total=total+(xmn_dist_from_mean-dist_from_mean(ip))**2
+       endif
+    enddo
+    if(count<2) then
+       stderr_close=0.0
+    else
+       stderr_close=max(1.0,sqrt(1./(count-1) * total))
+    endif
+
+    if(calcparm(1) .or. calcparm(2) .or. calcparm(7) .or. &
+         calcparm(8) .or. calcparm(9) .or. calcparm(11)) then
+       continue
+    else
+       call wrf_message('In fixcenter, STOPPING PROCESSING for this storm.  The reason is that')
+       call wrf_message('none of the fix locations for parms z850, z700, zeta 850, zeta 700')
+       call wrf_message('MSLP or sfc zeta were within a reasonable distance of the guess location.')
+       goto 999
+    endif
+
+    ! Recalculate the final center location using weights
+    if(stderr_close<5.0) then
+       ! Old code forced a minimum of 5.0 stddev
+       stderr_close=5.0
+    endif
+    irsum=0
+    jrsum=0
+    wsum=0
+    do ip=1,maxtp
+       if(calcparm(ip)) then
+          devia=max(1.0,dist_from_mean(ip)/stderr_close)
+          wtpos=exp(-devia/3.)
+          irsum=icen(ip)*wtpos+irsum
+          jrsum=jcen(ip)*wtpos+jrsum
+          wsum=wtpos+wsum
+1100      format(' Adding parm: devia=',F0.3,' wtpos=',F0.3,' irsum=',F0.3,' jrsum=',F0.3,' wsum=',F0.3)
+          !write(0,1100) devia,wtpos,irsum,jrsum,wsum
+       endif
+    enddo
+    ifinal=nint(real(irsum)/real(wsum))
+    jfinal=nint(real(jrsum)/real(wsum))
+    call get_lonlat(grid,ifinal,jfinal,lonfinal,latfinal,ierr, &
+         ids,ide, jds,jde, kds,kde, &
+         ims,ime, jms,jme, kms,kme, &
+         ips,ipe, jps,jpe, kps,kpe)
+    if(ierr/=0) then
+       write(0,*) 'bad bad naughty final (2)'
+       goto 999
+    endif
+
+    ! Store the lat/lon location:
+    grid%tracker_fixlon=lonfinal
+    grid%tracker_fixlat=latfinal
+    grid%tracker_ifix=ifinal
+    grid%tracker_jfix=jfinal
+    grid%tracker_havefix=.true.
+
+1000 format('Stored lat/lon at i=',I0,' j=',I0,' lon=',F0.3,' lat=',F0.3)
+    !write(0,1000) ifinal,jfinal,lonfinal,latfinal
+    
+
+    if(nint(hours) > grid%track_last_hour ) then
+       ! It is time to recalculate the std. dev. of the track:
+       count=0
+       dist_from_mean=0.0
+       total=0.0
+       do ip=1,maxtp
+          if(calcparm(ip)) then
+             call calcdist(lonfinal,latfinal,loncen(ip),loncen(ip),dist,degrees)
+             dist_from_mean(ip)=dist
+             total=total+dist
+             count=count+1
+          endif
+       enddo
+       xmn_dist_from_mean=total/real(count)
+
+       do ip=1,maxtp
+          if(calcparm(ip)) then
+             total=total+(xmn_dist_from_mean-dist_from_mean(ip))**2
+          endif
+       enddo
+       if(count<2) then
+          stderr_close=0.0
+       else
+          stderr_close=max(1.0,sqrt(1./(count-1) * total))
+       endif
+
+       grid%track_stderr_m3=grid%track_stderr_m2
+       grid%track_stderr_m2=grid%track_stderr_m1
+       grid%track_stderr_m1=stderr_close
+       grid%track_last_hour=nint(hours)
+    endif
+
+    !write(0,*) 'got to return'
+    return
+
+    ! We jump here if we're giving up on finding the center
+999 continue
+    grid%tracker_fixlon=-999.0
+    grid%tracker_fixlat=-999.0
+    grid%tracker_ifix=-99
+    grid%tracker_jfix=-99
+    grid%tracker_havefix=.false.
+    grid%tracker_gave_up=.true.
+  end subroutine fixcenter
+
+  subroutine get_uv_guess(grid,icen,jcen,loncen,latcen,calcparm, &
+       iguess,jguess,longuess,latguess,iout,jout, &
+       IDS,IDE,JDS,JDE,KDS,KDE, &
+       IMS,IME,JMS,JME,KMS,KME, &
+       IPS,IPE,JPS,JPE,KPS,KPE)
+    ! This is a rewrite of the gettrk_main.f get_uv_guess.  Original comment:
+    ! ABSTRACT: The purpose of this subroutine is to get a modified 
+    !           first guess lat/lon position before searching for the 
+    !           minimum in the wind field.  The reason for doing this is
+    !           to better refine the guess and avoid picking up a wind
+    !           wind minimum far away from the center.  So, use the 
+    !           first guess position (and give it strong weighting), and
+    !           then also use the  fix positions for the current time
+    !           (give the vorticity centers stronger weighting as well),
+    !           and then take the average of these positions.
+
+    ! Arguments: Input:
+    !  grid - grid being searched
+    !  icen,jcen - tracker parameter center gridpoints
+    !  loncen,latcen - tracker parameter centers' geographic locations
+    !  calcparm - is each center valid?
+    !  iguess, jguess - first guess gridpoint location
+    !  longuess,latguess - first guess geographic location
+
+    ! Arguments: Output:
+    !  iout,jout - uv guess center location
+
+    USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid
+#ifdef DM_PARALLEL
+    use module_dm, only: wrf_dm_sum_real
+#endif
+    implicit none
+    type(domain), intent(inout) :: grid
+    integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE
+    integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME
+    integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE
+
+    integer, intent(in) :: icen(maxtp), jcen(maxtp)
+    real, intent(in) :: loncen(maxtp), latcen(maxtp)
+    logical, intent(in) :: calcparm(maxtp)
+
+    integer, intent(in) :: iguess,jguess
+    real, intent(in) :: latguess,longuess
+
+    integer, intent(inout) :: iout,jout
+    real :: degrees,dist
+    integer :: ip,ict
+    integer(kind=8) :: isum,jsum
+
+    ict=2
+    isum=2*iguess
+    jsum=2*jguess
+
+    ! Get a guess storm center location for searching for the wind centers:
+    do ip=1,maxtp
+       if ((ip > 2 .and. ip < 7) .or. ip == 10) then
+          cycle   ! because 3-6 are for 850 & 700 u & v and 10 is 
+          ! for surface wind magnitude.
+       elseif(calcparm(ip)) then
+          call calcdist (longuess,latguess,loncen(ip),latcen(ip),dist,degrees)
+          if(dist 1.0) then
+       cosanga = 1.0
+    endif
+
+    degrees    = acos(cosanga) / dtr
+    circ_fract = degrees / 360.
+    xdist      = circ_fract * ecircum
+    !
+    !     NOTE: whether this subroutine returns the value of the distance
+    !           in km or m depends on the scale of the parameter ecircum. 
+    !           At the original writing of this subroutine (7/97), ecircum
+    !           was given in km.
+    !
+    return
+  end subroutine calcdist
+
+  ! subroutine get_lonlat(grid,iguess,jguess,longuess,latguess, &
+  !       ids,ide, jds,jde, kds,kde, &
+  !       ims,ime, jms,jme, kms,kme, &
+  !       ips,ipe, jps,jpe, kps,kpe)
+  !   ! Returns the latitude (latguess) and longitude (longuess) of the
+  !   ! specified location (iguess,jguess) in the specified grid.
+  !   USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid
+  !   USE MODULE_DM, ONLY: wrf_dm_at_ij_real
+  !   implicit none
+  !   integer, intent(in) :: &
+  !       ids,ide, jds,jde, kds,kde, &
+  !       ims,ime, jms,jme, kms,kme, &
+  !       ips,ipe, jps,jpe, kps,kpe
+  !   type(domain), intent(inout) :: grid
+  !   integer, intent(in) :: iguess,jguess
+  !   real, intent(inout) :: longuess,latguess
+
+  !   call wrf_dm_at_ij_real(grid,iguess,jguess,ims,ime, jms,jme, &
+  !        longuess,grid%hlon, &
+  !       val2=latguess,field2=grid%hlat)
+  ! end subroutine get_lonlat
+
+
+  subroutine get_lonlat(grid,iguess,jguess,longuess,latguess,ierr, &
+       ids,ide, jds,jde, kds,kde, &
+       ims,ime, jms,jme, kms,kme, &
+       ips,ipe, jps,jpe, kps,kpe)
+    ! Returns the latitude (latguess) and longitude (longuess) of the
+    ! specified location (iguess,jguess) in the specified grid.
+    USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid
+    USE MODULE_DM, ONLY: wrf_dm_maxloc_real
+    implicit none
+    integer, intent(in) :: &
+         ids,ide, jds,jde, kds,kde, &
+         ims,ime, jms,jme, kms,kme, &
+         ips,ipe, jps,jpe, kps,kpe
+    integer, intent(out) :: ierr
+    type(domain), intent(inout) :: grid
+    integer, intent(in) :: iguess,jguess
+    real, intent(inout) :: longuess,latguess
+    real :: weight,zjunk
+    integer :: itemp,jtemp
+
+    ierr=0
+    zjunk=1
+    if(iguess>=ips .and. iguess<=ipe .and. jguess>=jps .and. jguess<=jpe) then
+       weight=1
+       longuess=grid%hlon(iguess,jguess)
+       latguess=grid%hlat(iguess,jguess)
+       itemp=iguess
+       jtemp=jguess
+    else
+       weight=0
+       longuess=-999.9
+       latguess=-999.9
+       itemp=-99
+       jtemp=-99
+    endif
+
+#ifdef DM_PARALLEL
+    call wrf_dm_maxloc_real(weight,latguess,longuess,zjunk,itemp,jtemp)
+#endif
+
+    if(itemp==-99 .and. jtemp==-99) then
+       ierr=95
+    endif
+  end subroutine get_lonlat
+#endif
+end module module_tracker
diff --git a/wrfv2_fire/dyn_nmm/solve_nmm.F b/wrfv2_fire/dyn_nmm/solve_nmm.F
index 15187120..eb7009d5 100644
--- a/wrfv2_fire/dyn_nmm/solve_nmm.F
+++ b/wrfv2_fire/dyn_nmm/solve_nmm.F
@@ -14,7 +14,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &           )
 !-----------------------------------------------------------------------
         use module_timing
-      USE MODULE_DOMAIN,                ONLY : DOMAIN, GET_IJK_FROM_GRID
+      USE MODULE_DOMAIN,                ONLY : DOMAIN, GET_IJK_FROM_GRID &
+                                              ,domain_clock_get,is_alarm_tstep_nphs
+
       USE MODULE_CONFIGURE,             ONLY : GRID_CONFIG_REC_TYPE
       USE MODULE_MODEL_CONSTANTS
       USE MODULE_STATE_DESCRIPTION
@@ -41,10 +43,15 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
       USE MODULE_EXT_INTERNAL
       USE MODULE_PRECIP_ADJUST
       USE MODULE_NEST_UTIL     ! USEs module_MPP (contains MYPE,NPES,MPI_COMM_COMP)
+#ifdef MOVE_NESTS
       USE MODULE_STATS_FOR_MOVE,        ONLY: STATS_FOR_MOVE
+#endif
 #ifdef WRF_CHEM
       USE MODULE_INPUT_CHEM_DATA,       ONLY: GET_LAST_GAS
 #endif
+      USE MODULE_DIAG_REFL
+
+
 !-----------------------------------------------------------------------
 !
       IMPLICIT NONE
@@ -91,8 +98,15 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
       INTEGER :: I,ICLTEND,IDF,IRTN,J,JC,JDF,K,KDF,LB,N_MOIST &
      &          ,NTSD_current,L
 #ifdef HWRF
+#ifdef HRD_MULTIPLE_STORMS
+!XUEJIN's doing
+      INTEGER, PARAMETER                    :: max_simulation_domains=11 !The max number of domains in the HWRF simulation. Currently hard-coded to 5 storms. This should eventually be replaced with CONFIG_FLAGS%MAX_DOM.
+      INTEGER                               :: kid1
+      INTEGER,SAVE,DIMENSION(max_simulation_domains)       :: NTSD_restart1
+#else
 !zhang's doing
       INTEGER,SAVE :: NTSD_restart1,NTSD_restart2,NTSD_restart3
+#endif
 #endif
       integer :: ierr,nrand,idt
       INTEGER,SAVE :: NTSD_restart
@@ -137,6 +151,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 #else
      &,            adjppt_tim
 #endif
+
+! Flag for producing diagnostic fields (e.g., radar reflectivity) 
+      LOGICAL                        :: diag_flag
+
 #ifdef NMM_FIND_LOAD_IMBALANCE
       real,save :: loadimbal_tim,previmbal_tim
 #endif
@@ -229,10 +247,17 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
       IF(NTSD_current==0)THEN
         IF(GRID%RESTART.AND.GRID%TSTART>0.)THEN
 #ifdef HWRF
+#ifdef HRD_MULTIPLE_STORMS
+!XUEJIN's doing
+          do kid1=1,max_simulation_domains
+          if( grid%id .eq. kid1 ) NTSD_restart1(kid1)=INT(grid%TSTART*3600./GRID%DT+0.5)
+          end do
+#else
 !zhang's doing: temporarily hardwired for two domains
           if( grid%id .eq. 1 ) NTSD_restart1=INT(grid%TSTART*3600./GRID%DT+0.5)
           if( grid%id .eq. 2 ) NTSD_restart2=INT(grid%TSTART*3600./GRID%DT+0.5)
           if( grid%id .eq. 3 ) NTSD_restart3=INT(grid%TSTART*3600./GRID%DT+0.5)
+#endif
 #endif
           IHRST=grid%nstart_hour
           NTSD_restart=grid%ntsd
@@ -240,24 +265,45 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
           IHRST=GRID%GMT
           grid%nstart_hour=IHRST
 #ifdef HWRF
+#ifdef HRD_MULTIPLE_STORMS
+!XUEJIN's doing
+          NTSD_restart1=0
+#else
 !zhang's doing
           NTSD_restart1=0
           NTSD_restart2=0
           NTSD_restart3=0
+#endif
 #else
           NTSD_restart=0
 #endif
         ENDIF
       ENDIF
 #ifdef HWRF
+#ifdef HRD_MULTIPLE_STORMS
+!XUEJIN's doing
+      do kid1=1,max_simulation_domains
+      if( grid%id .eq. kid1 ) grid%ntsd=NTSD_restart1(kid1)+NTSD_current
+      end do
+#else
 !zhang's doing
       if( grid%id .eq. 1 ) grid%ntsd=NTSD_restart1+NTSD_current
       if( grid%id .eq. 2 ) grid%ntsd=NTSD_restart2+NTSD_current
       if( grid%id .eq. 3 ) grid%ntsd=NTSD_restart3+NTSD_current
+#endif
 #else
       grid%ntsd=NTSD_restart+NTSD_current
 #endif
       LAST_TIME=domain_last_time_step(GRID)
+!-----------------------------------------------------------------------------
+!
+! Set diagnostic flag value at history output time
+!-----------------------------------------------------------------------------
+    diag_flag = .false.
+    if ( Is_alarm_tstep_nphs(grid%domain_clock, grid%alarms(HISTORY_ALARM), grid%nphs) ) then
+       diag_flag = .true.
+    endif
+
 !
 !-----------------------------------------------------------------------
 !
@@ -308,6 +354,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
          ETAMP_PHYSICS=.TRUE.
 !
       ENDIF
+
+
+
 !
 !-----------------------------------------------------------------------
 !***  SET FLAG FOR THE OPERATIONAL PHYSICS SUITE.
@@ -587,12 +636,12 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &            ,ITS,ITE,JTS,JTE,KTS,KTE)
 !-----------------------------------------------------------------------
 !
-#ifdef HWRF
-!zhang
-      IF(NTSD_current==0)THEN
-#else
+!!#ifdef HWRF
+!!!zhang
+!!      IF(NTSD_current==0)THEN
+!!#else
       IF(grid%ntsd==0)THEN
-#endif
+!!#endif
         FIRST=.TRUE.
 !       call hpm_init()
 #ifdef NMM_FIND_LOAD_IMBALANCE
@@ -756,6 +805,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 !-----------------------------------------------------------------------
 !-----------------------------------------------------------------------
 #ifdef HWRF
+#ifdef HRD_MULTIPLE_STORMS
+      write(message,*)' No Ocean Coupling Run'
+      call wrf_message(trim(message))
+#else
 ! Coupling insertion:->
       call ATM_TSTEP_INIT(NTSD_current,grid%NPHS,GRID%ID,grid%NPHS*grid%dt, &
       ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme,           &
@@ -766,6 +819,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 !<-:coupling insertion
 !
 #endif
+#endif
 !-----------------------------------------------------------------------
 !***  PRESSURE TENDENCY, SIGMA DOT, VERTICAL PART OF OMEGA-ALPHA
 !-----------------------------------------------------------------------
@@ -1545,6 +1599,18 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &                ,grid%z,grid%sice,NUM_AEROSOLC,NUM_OZMIXM                  &
      &                ,GRID,CONFIG_FLAGS                               &
      &                ,RTHRATEN                                        &  
+     &                ,grid%re_cloud,grid%re_ice,grid%re_snow          &  ! G. Thompson
+     &                ,grid%has_reqc,grid%has_reqi,grid%has_reqs       &  ! G. Thompson
+     &                ,grid%SWUPT,grid%SWUPTC,grid%SWDNT,grid%SWDNTC   &
+     &                ,grid%SWUPB,grid%SWUPBC,grid%SWDNB,grid%SWDNBC   &
+     &                ,grid%LWUPT,grid%LWUPTC,grid%LWDNT,grid%LWDNTC   &
+     &                ,grid%LWUPB,grid%LWUPBC,grid%LWDNB,grid%LWDNBC   &
+     &                ,grid%ACSWUPT,grid%ACSWUPTC,grid%ACSWDNT,grid%ACSWDNTC   &
+     &                ,grid%ACSWUPB,grid%ACSWUPBC,grid%ACSWDNB,grid%ACSWDNBC   &
+     &                ,grid%ACLWUPT,grid%ACLWUPTC,grid%ACLWDNT,grid%ACLWDNTC   &
+     &                ,grid%ACLWUPB,grid%ACLWUPBC,grid%ACLWDNB,grid%ACLWDNBC   &
+     &                 ,grid%swvisdir ,grid%swvisdif &  !ssib
+     &                 ,grid%swnirdir ,grid%swnirdif &  !ssib
 #ifdef WRF_CHEM
      &                ,PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC            &
      &                ,TAUAER1, TAUAER2, TAUAER3, TAUAER4              & 
@@ -1594,6 +1660,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 !-------------------------------------------------------------------------------------
 !*** GET SSTs FROM DMITRY's COUPLER ON TO THE PARENT AND NESTED GRID
 !-------------------------------------------------------------------------------------
+#ifdef HRD_MULTIPLE_STORMS
+      write(message,*)' No Ocean Coupling Run'
+      call wrf_message(trim(message))
+#else
 ! Coupling insertion:->
         CALL ATM_GETSST(grid%sst,grid%sm)
 !<-:Coupling insertion
@@ -1602,6 +1672,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
         sst_tim=sst_tim+timef()-btimx
       ENDIF
 
+#endif
 #endif
 !----------------------------------------------------------------------
 !***  TURBULENT PROCESSES 
@@ -1627,7 +1698,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &            ,grid%czen,grid%czmean,grid%sigt4,grid%rlwin,grid%rswin,grid%radot                 &
      &            ,grid%pd,grid%res,grid%pint,grid%t,grid%q,grid%cwm,grid%f_ice,grid%f_rain,grid%sr                 &
      &            ,grid%q2,grid%u,grid%v,grid%ths,grid%nmm_tsk,grid%sst,grid%prec,grid%sno                     &
-     &            ,grid%fis,grid%z0,grid%z0base,grid%ustar,grid%mixht,grid%pblh,grid%lpbl,grid%el_pbl          &   !PLee (3/07)
+     &            ,grid%fis,grid%z0,grid%mz0,grid%z0base,grid%ustar,grid%mixht,grid%pblh,grid%lpbl,grid%el_pbl    &   !KWON MZ0
      &            ,MOIST,grid%rmol,grid%mol                                      &
      &            ,grid%exch_h,grid%exch_m,grid%f,grid%akhs,grid%akms,grid%akhs_out,grid%akms_out         &
      &            ,grid%thz0,grid%qz0,grid%uz0,grid%vz0,grid%qsh,grid%mavail                         &
@@ -1637,7 +1708,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &            ,grid%sfcexc,grid%acsnow,grid%acsnom,grid%snopcx,grid%sice,grid%tg,grid%soiltb          &
      &            ,grid%albsi,grid%icedepth,grid%snowsi                                                   &
      &            ,grid%albase,grid%mxsnal,grid%albedo,grid%sh2o,grid%si,grid%epsr,grid%embck             &
-     &            ,grid%u10,grid%v10,grid%th10,grid%q10,grid%tshltr,grid%qshltr,grid%pshltr               &
+     &            ,grid%u10,grid%v10,grid%uoce,grid%voce,grid%th10,grid%q10,grid%tshltr,grid%qshltr,grid%pshltr               &
      &            ,grid%t2,grid%qsg,grid%qvg,grid%qcg,grid%soilt1,grid%tsnav,grid%smfr3d,grid%keepfr3dflag     &
 #if (NMM_CORE==1)
      &            ,grid%twbs,grid%qwbs,grid%taux,grid%tauy,grid%sfcshx,grid%sfclhx,grid%sfcevp,RTHRATEN                      &
@@ -1661,11 +1732,12 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &            ,grid%rc_mf                                          & ! QNSE
      &            ,GRID,CONFIG_FLAGS                                   &
      &            ,grid%ihe,grid%ihw,grid%ive,grid%ivw                 &
-     &            ,GRID%DISHEAT                                        &
-     &            ,GRID%HPBL2D, GRID%EVAP2D, GRID%HEAT2D               &  !S&P Kwon
+     &            ,GRID%DISHEAT,GRID%DKU3D,GRID%DKT3D                          &
+     &            ,GRID%HPBL2D, GRID%EVAP2D, GRID%HEAT2D,GRID%RC2D               &  !S&P Kwon
      &            ,GRID%SFCHEADRT,GRID%INFXSRT,GRID%SOLDRAIN           &  !Hydrology, no-op right now
      &            ,IDS,IDF,JDS,JDF,KDS,KDE                             &
      &            ,IMS,IME,JMS,JME,KMS,KME                             &
+     &            ,IPS,IPE,JPS,JPE,KPS,KPE                             &
      &            ,ITS,ITE,JTS,JTE,KTS,KTE)
 !
 !                     ***  NOTE  ***
@@ -1694,6 +1766,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 !
 !
 
+#ifdef HRD_MULTIPLE_STORMS
+      write(message,*)' No Ocean Coupling Run'
+      call wrf_message(trim(message))
+#else
 ! Coupling insertion:->
       call ATM_DOFLUXES(grid%twbs,grid%qwbs,grid%rlwin,grid%rswin,grid%radot,grid%rswout, &
       grid%taux,grid%tauy,grid%pint(:,:,1),grid%prec,grid%u10,grid%v10)
@@ -1705,6 +1781,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
         flux_tim=flux_tim+timef()-btimx
       ENDIF
 
+#endif
 #endif
 !
 #ifdef NMM_FIND_LOAD_IMBALANCE
@@ -1786,6 +1863,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &   (CONFIG_FLAGS%CU_PHYSICS.eq.KFETASCHEME .or.                     &
      &   CONFIG_FLAGS%CU_PHYSICS.eq.OSASSCHEME .or.                       &
      &   CONFIG_FLAGS%CU_PHYSICS.eq.NSASSCHEME .or.                       &
+     &   CONFIG_FLAGS%CU_PHYSICS.eq.MESO_SAS .or.                         &   !Kwon
      &   CONFIG_FLAGS%CU_PHYSICS.eq.SASSCHEME))THEN                       ! 
 !
 #ifdef NMM_FIND_LOAD_IMBALANCE
@@ -1889,6 +1967,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
         IF(MOD(grid%ntsd, GRID%NCNVC).eq.0.and.                 &
      &    (CONFIG_FLAGS%CU_PHYSICS.eq.OSASSCHEME.or.            &
      &     CONFIG_FLAGS%CU_PHYSICS.eq.NSASSCHEME.or.            &
+     &     CONFIG_FLAGS%CU_PHYSICS.eq.MESO_SAS.or.              & !Kwon
      &     CONFIG_FLAGS%CU_PHYSICS.eq.SASSCHEME))THEN 
 !emc_2010_bugfix_h50
 !
@@ -1946,6 +2025,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &               ,grid%tbpvs_state                                      &
      &               ,grid%tbpvs0_state                                     &
      &               ,GRID,CONFIG_FLAGS                                &
+     &               ,grid%re_cloud,grid%re_ice,grid%re_snow           &  ! G. Thompson
+     &               ,grid%has_reqc,grid%has_reqi,grid%has_reqs        &  ! G. Thompson
+     &               ,diag_flag                                        &  
      &               ,IDS,IDF,JDS,JDF,KDS,KDE                          &
      &               ,IMS,IME,JMS,JME,KMS,KME                          &
      &               ,ITS,ITE,JTS,JTE,KTS,KTE)
@@ -2291,6 +2373,19 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
       ENDDO
       ENDDO
       ENDDO
+! calculate some model diagnostics.
+
+   CALL wrf_debug ( 200 , ' call diagnostic_driver' )
+
+   CALL diagnostic_output_calc_refl(                                   &
+      &              DIAGFLAG=diag_flag                                &
+      &             ,REFD_MAX=grid%refd_max                            &
+      &             ,refl_10cm=grid%refl_10cm                          &
+      &             ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
+      &             ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
+      &             ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
+      &                                                          )
+
 !
 !----------------------------------------------------------------------
 !
@@ -2396,13 +2491,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 !-----------------------------------------------------------------------------
 !
 #ifdef MOVE_NESTS
-   IF(grid%id .NE. 1 .AND. MOD(grid%ntsd,1)==0 .AND. grid%num_moves.EQ.-99)THEN
-!-----------------
-#ifdef DM_PARALLEL
-#    include "HALO_NMM_TRACK.inc"
-#endif
-!-----------------
-
+   IF ( grid%num_moves.EQ.-99 ) THEN
       call start_timing()
       call stats_for_move(grid,config_flags &
                          ,IDS,IDE,JDS,JDE,KDS,KDE &
@@ -2444,6 +2533,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 !
 !
 !
+#ifdef HRD_MULTIPLE_STORMS
+      write(message,*)' No Ocean Coupling Run'
+      call wrf_message(trim(message))
+#else
 ! Coupling insertion:->
       call ATM_SENDFLUXES
 !<-:Coupling insertion
@@ -2453,6 +2546,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 !  IF(grid%id==2)WRITE(0,*)'AFTER ATM_SENDFLUX grid%qwbs grid%twbs AT 10 10 ',grid%ntsd,grid%qwbs(10,10),grid%twbs(10,10)
 !
 #endif
+#endif
 
 !--------------------------------------------------------------------------------------------------------------
 !
diff --git a/wrfv2_fire/dyn_nmm/start_domain_nmm.F b/wrfv2_fire/dyn_nmm/start_domain_nmm.F
index 782741d2..391a9565 100644
--- a/wrfv2_fire/dyn_nmm/start_domain_nmm.F
+++ b/wrfv2_fire/dyn_nmm/start_domain_nmm.F
@@ -62,12 +62,15 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
      &           )
 !----------------------------------------------------------------------
 !
+#ifdef HWRF
       USE MODULE_STATS_FOR_MOVE, only: vorttrak_init
+#endif
       USE MODULE_TIMING
 #ifdef HWRF
       USE MODULE_HIFREQ, only : hifreq_open
 #endif
       USE MODULE_DOMAIN
+      USE MODULE_STATE_DESCRIPTION
       USE MODULE_RANDOM, only : srand_grid, rand_grid_r4
       USE MODULE_DRIVER_CONSTANTS
       USE module_model_constants
@@ -99,6 +102,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
    USE MODULE_GOCART_AEROSOLS, ONLY: SUM_PM_GOCART
    USE MODULE_MOSAIC_DRIVER, ONLY: SUM_PM_MOSAIC
 #endif
+
 !
 !----------------------------------------------------------------------
 !
@@ -149,7 +153,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
      &          ,K,K400,KBI,KBI2,KCCO2,KNT,KNTI                         &
      &          ,LB,LRECBC,L                                            &
      &          ,N,NMAP,NRADLH,NRADSH,NREC,NS,RECL,STAT                 &
-     &          ,STEPBL,STEPCU,STEPRA
+     &          ,STEPBL,STEPCU,STEPRA, KFE,KFS
 !
       INTEGER :: MY_E,MY_N,MY_S,MY_W                                    &
      &          ,MY_NE,MY_NW,MY_SE,MY_SW,MYI,MYJ,NPE
@@ -168,6 +172,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
 !!!   REAL :: BLDT,CWML,EXNSFC,G_INV,PLYR,PSFC,ROG,SFCZ,THSIJ,TL
       REAL :: CWML,EXNSFC,G_INV,PLYR,PSURF,ROG,SFCZ,THSIJ,TL,ZOQING
       REAL :: TEND
+      REAL :: TEMPDX, TEMPDY
 #ifdef HWRF
 !zhang's doing 
       REAL :: TSTART
@@ -212,9 +217,13 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
       REAL,ALLOCATABLE,DIMENSION(:,:,:) :: ZINT,RRI,CONVFAC,ZMID
       REAL,ALLOCATABLE,DIMENSION(:,:,:) :: T_TRANS,PINT_TRANS
       REAL,ALLOCATABLE,DIMENSION(:,:,:) :: CLDFRA_TRANS
+      REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: SCALAR_TRANS
 #ifndef WRF_CHEM
       REAL,ALLOCATABLE,DIMENSION(:,:,:) :: CLDFRA_OLD
 #endif
+!..Need to fill special height var for setting up initial condition.  G. Thompson
+      REAL,ALLOCATABLE,DIMENSION(:,:,:) :: z_at_q
+
 #if 0
       REAL,ALLOCATABLE,DIMENSION(:,:,:) :: w0avg
 #endif
@@ -266,6 +275,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
 !**********************************************************************
 !----------------------------------------------------------------------
 !
+
       call start_timing
 
 #ifdef HWRF
@@ -308,6 +318,53 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
         grid%nomove_freq_hr=config_flags%nomove_freq
 #endif
 
+      ! Recalculate grid bounds, regardless of reason for
+      ! start_domain_nmm call, or version of NMM:
+      has_parent: if(grid%id /= 1) then ! NOTE REQUIREMENT: MOAD IS GRID 1!!
+         ! Nest gets dx & dy from parent and grid ratio.
+3302     format('Grid ',I0,' calculating west/south bounds relative to parent grid ',I0)
+         write(message,3302) grid%id, grid%parents(1)%ptr%id
+         call wrf_debug(2,message)
+         tempdx=grid%parents(1)%ptr%dx/grid%parent_grid_ratio
+         tempdy=grid%parents(1)%ptr%dy/grid%parent_grid_ratio
+         grid%wbd0var = grid%parents(1)%ptr%wbd0var + (grid%i_parent_start-1)*2.*grid%parents(1)%ptr%dx + mod(grid%j_parent_start+1,2)*grid%parents(1)%ptr%dx
+         grid%sbd0var = grid%parents(1)%ptr%sbd0var + (grid%j_parent_start-1)*grid%parents(1)%ptr%dy
+3303     format('Parent wbd0=',F0.3,' sbd0=',F0.3,' i_parent_start=',I0,' j_parent_start=',I0)
+         write(message,3303) grid%parents(1)%ptr%wbd0var, &
+              grid%parents(1)%ptr%sbd0var, grid%i_parent_start,grid%j_parent_start
+         call wrf_debug(2,message)
+      else
+         ! MOAD gets dx & dy from namelist.
+3305     format('Grid ',I0,' calculating west/south bounds as MOAD')
+         write(message,3305) grid%id
+         call wrf_debug(2,message)
+         call nl_get_dx(grid%id,tempdx)
+         call nl_get_dy(grid%id,tempdy)
+         grid%wbd0var = -(IDE-2)*tempdx
+         grid%sbd0var = -((JDE-1)/2)*tempdy
+#if ! ( NMM_NEST == 1 )
+         ! When NMM is compiled without nesting support, we need to
+         ! update the bound metadata here:
+         grid%wbd0 = grid%wbd0var
+         grid%sbd0 = grid%sbd0var
+#endif
+      endif has_parent
+      if(tempdx<1e-5 .or. tempdy<1e-5) then
+         ! Should never reach here unless someone adds a bug to NMM.
+         ! The meaning of grid%dx varies during nest initialization
+         ! (sometimes it is MOAD dx, sometimes nest dx), so this check
+         ! is here just in case someone screws up the code later on.
+         write(message,1045) tempdx,tempdy
+         call wrf_message('WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ')
+         call wrf_message('Warning: dx or dy are invalid after parent calculation or namelist check.')
+         call wrf_message(message)
+         call wrf_message('WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ')
+1045     format('Must be >1e-5.  dx=',F0.7,' dy=',F0.7,'.  Grid bounds will be wrong.')
+      endif
+      write(message,3011) grid%id,tempdx,tempdy,grid%wbd0var,grid%sbd0var
+      call wrf_debug(2,message)
+3011  format('Grid ',I0,': dx=',F0.3,' dy=',F0.3,' wbd0=',F0.3,' sbd0=',F0.3)
+
 #if 1
       IF(IME>NMM_MAX_DIM )THEN
         WRITE(wrf_err_message,*)                                       &
@@ -354,18 +411,6 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
          CALL WRF_ERROR_FATAL(wrf_err_message)
       END IF
 
-#if (HWRF==1)
-      if(grid%vortex_tracker<1 .or. grid%vortex_tracker>3) then
-         write(wrf_err_message,*)' domain ',grid%id,' has an invalid value ',grid%vortex_tracker,' for grid%vortex_tracker.  It must be 1, 2 or 3.'
-      endif
-#endif
-      
-#if (HWRF==1)
-      if(grid%vortex_tracker<1 .or. grid%vortex_tracker>3) then
-         write(wrf_err_message,*)' domain ',grid%id,' has an invalid value ',grid%vortex_tracker,' for grid%vortex_tracker.  It must be 1, 2 or 3.'
-      endif
-#endif
-      
 !!!!!!tlb
 !!!! For now, set NPES to 1
       NPES=1
@@ -568,8 +613,10 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
 !
       IFS=IPS
       JFS=JPS
+      KFS=KPS
       JFE=MIN(JPE,JDE-1)
       IFE=MIN(IPE,IDE-1)
+      KFE=MIN(KPE,KDE-1)
 
       if((allowed_to_read.and..not.(restrt)) .or. .not.allowed_to_read) then
          randif: IF(in_use_for_config(grid%id,'random'))THEN
@@ -623,17 +670,20 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
            write(message,'("Domain ",I0," does not have hifreq out.")') grid%id
         endif
       else
-        write(message,'("Domain ",I0," is not being initialized.")') grid%id
+          write(message,'("Domain ",I0," is not being initialized.")') grid%id
       endif
 ! end of high-freq output
 #endif
 #ifdef HWRF
-! Begin Sam Trahan's doing for vortex_tracker=4 option
+! Begin Sam Trahan's doing for vortex tracker initialization
+    IF ( program_name(1:8) .NE. "REAL_NMM" ) THEN
          call VORTTRAK_INIT(grid,config_flags,       &
+                            (allowed_to_read .and. .not. restrt), &
                             IDS,IDE,JDS,JDE,KDS,KDE, &
                             IMS,IME,JMS,JME,KMS,KME, &
                             ITS,ITE,JTS,JTE,KTS,KTE)
-! End Sam Trahan's doing for vortex_tracker=4 option
+      ENDIF
+! End Sam Trahan's doing for vortex tracker initialization
 #endif
 #ifdef HWRF
 !zhang's doing
@@ -1617,20 +1667,14 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
 
 #ifdef HWRF
       hwrfx_mslp: if(grid%vortex_tracker /= 1) then
-! XUEJIN's doing
-! add to output MSLP at the initial time
-!
-!    COMPUTATION OF MSLP         ! This is gopal's doing
-!
-
-
      DO J=JFS,JFE
       DO I=IFS,IFE
-         grid%Z(I,J,1)=grid%FIS(I,J)*GI
+         grid%Z(I,J,KFS)=grid%FIS(I,J)*GI
       ENDDO
      ENDDO
 
-     DO K=KPS,2
+     ! Z now correctly calculated after nest move.  Needed by membrane MSLP.
+     DO K=KFS,KFE
       DO J=JFS,JFE
        DO I=IFS,IFE
           APELP      = (grid%PINT(I,J,K+1)+grid%PINT(I,J,K))
@@ -1641,25 +1685,23 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
       ENDDO
      ENDDO
 
+     DO K=KFS,KFE
+      DO J=JFS,JFE
+       DO I=IFS,IFE
+          grid%Z(i,j,k)=(grid%Z(i,j,k)+grid%Z(i,j,k+1))*0.5
+       ENDDO
+      ENDDO
+     ENDDO
+
      grid%MSLP=-9999.99
      DO J=JFS,JFE
       DO I=IFS,IFE
-         SFCT      = grid%T(I,J,1)*(1.+D608*grid%Q(I,J,1)) + LAPSR*(grid%Z(I,J,1)+grid%Z(I,J,2))*0.5
-         A         = LAPSR*grid%Z(I,J,1)/SFCT
+         SFCT      = grid%T(I,J,1)*(1.+D608*grid%Q(I,J,1)) + LAPSR*grid%Z(I,J,1)
+         A         = LAPSR*grid%FIS(i,j)*gi/SFCT
          grid%MSLP(I,J) = grid%PINT(I,J,1)*(1-A)**COEF2
       ENDDO
      ENDDO
 
-! SET BACK Z AS IN ORIGINAL CODE
-
-     DO K=KPS,KPE
-      DO J=JFS,JFE
-       DO I=IFS,IFE
-         grid%Z(I,J,K)=grid%PINT(I,J,K)
-       ENDDO
-      ENDDO
-     ENDDO
-
   endif hwrfx_mslp
 #endif
 
@@ -1798,15 +1840,17 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
       ALLOCATE(RTHRATEN(IMS:IME,KMS:KME,JMS:JME),STAT=I)    ; RTHRATEN  = 0.
       ALLOCATE(RTHRATENLW(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; RTHRATENLW = 0.
       ALLOCATE(RTHRATENSW(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; RTHRATENSW = 0.
-      ALLOCATE(ZINT(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; ZINT = 0.
-      ALLOCATE(CONVFAC(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; CONVFAC = 0.
+      ALLOCATE(ZINT(IMS:IME,KMS:KME,JMS:JME),STAT=I)        ; ZINT = 0.
+      ALLOCATE(CONVFAC(IMS:IME,KMS:KME,JMS:JME),STAT=I)     ; CONVFAC = 0.
       ALLOCATE(PINT_TRANS(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; PINT_TRANS = 0.
-      ALLOCATE(T_TRANS(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ;  T_TRANS = 0.
-      ALLOCATE(RRI(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ;  RRI = 0.
-      ALLOCATE(CLDFRA_TRANS(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; CLDFRA_TRANS = 0.
+      ALLOCATE(T_TRANS(IMS:IME,KMS:KME,JMS:JME),STAT=I)     ;  T_TRANS = 0.
+      ALLOCATE(RRI(IMS:IME,KMS:KME,JMS:JME),STAT=I)         ;  RRI = 0.
+      ALLOCATE(CLDFRA_TRANS(IMS:IME,KMS:KME,JMS:JME),STAT=I); CLDFRA_TRANS = 0.
+      ALLOCATE(SCALAR_TRANS(IMS:IME,KMS:KME,JMS:JME,NUM_SCALAR),STAT=I)
 #ifndef WRF_CHEM      
       ALLOCATE(CLDFRA_OLD(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; CLDFRA_OLD = 0.
 #endif
+      ALLOCATE(Z_AT_Q(IMS:IME,KMS:KME,JMS:JME),STAT=I)      ; z_at_q = 0.
 #if 0
       ALLOCATE(w0avg(IMS:IME,KMS:KME,JMS:JME),STAT=I)       ; w0avg = 0.
 #endif
@@ -1818,6 +1862,19 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
       GRID%BLDT=GRID%NPHS*GRID%DT/60.
       GRID%CUDT=GRID%NCNVC*GRID%DT/60.
       GRID%GSMDT=GRID%NPHS*GRID%DT/60.
+!
+! translate scalar(i,j,k,n) to scalar_trans(i,k,j,n)
+        DO N=1,NUM_SCALAR
+!$omp parallel do                                                       &
+!$omp& private(i,j,k)
+          DO K=KMS,KME
+          DO J=JMS,JME
+          DO I=IMS,IME
+            SCALAR_TRANS(I,K,J,N)=SCALAR(I,J,K,N)
+          ENDDO
+          ENDDO
+          ENDDO
+        ENDDO
 !
       DO J=MYJS,MYJE
       DO I=MYIS,MYIE
@@ -1945,6 +2002,9 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
 ! includes these as dummy arguments or declares them.  Access them from 
 ! GRID.  JM 20050819
 #ifndef WRF_NMM_NEST
+    ! NOTE: we always get here for all NMM configurations because the
+    !       #if condition is wrong.  Leaving this as is, just in case
+    !       there was a good reason for it.
       grid%moved = .FALSE.
 #endif
 
@@ -1972,6 +2032,10 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
      &             ,STEPBL,STEPRA,STEPCU                                &
      &             ,grid%w0avg, RAINNC, RAINC, grid%raincv, RAINNCV               &
      &             ,SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV              &
+     &             ,z_at_q, grid%qnwfa2d                                &
+     &             ,scalar_trans(ims,kms,jms,1),num_scalar              &
+     &             ,grid%re_cloud, grid%re_ice, grid%re_snow            & ! G. Thompson
+     &             ,grid%has_reqc,grid%has_reqi,grid%has_reqs           & ! G. Thompson
      &             ,NCA,GRID%SWRAD_SCAT                                 &
      &             ,grid%cldefi,LOWLYR                                       &
      &             ,grid%mass_flux                                           &
@@ -1980,7 +2044,8 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
      &             ,GRID%LANDUSE_ISICE, GRID%LANDUSE_LUCATS             &
      &             ,GRID%LANDUSE_LUSEAS, GRID%LANDUSE_ISN               &
      &             ,GRID%LU_STATE                                       &
-     &             ,grid%xlat,grid%xlong,grid%albedo,grid%albbck                            &
+     &             ,grid%xlat,grid%xlong,grid%glat,grid%glon&
+     &             ,grid%albedo,grid%albbck                             &
      &             ,GRID%GMT,GRID%JULYR,GRID%JULDAY                     &
      &             ,GRID%LEVSIZ, NUM_OZMIXM, NUM_AEROSOLC, GRID%PAERLEV &
      &             ,grid%alevsiz, grid%no_src_types                     &
@@ -2016,8 +2081,19 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
      &                STMASSXY=grid%STMASSXY, WOODXY=grid%WOODXY,                        & ! Optional Noah-MP
      &                STBLCPXY=grid%STBLCPXY, FASTCPXY=grid%FASTCPXY,                    & ! Optional Noah-MP
      &                XSAIXY=grid%XSAIXY,                                                & ! Optional Noah-MP
-     &                T2MVXY=grid%T2MVXY, T2MBXY=grid%T2MBXY, CHSTARXY=grid%CHSTARXY     & ! Optional Noah-MP
-     &                ,MAXPATCH=1 & ! CLM
+     &                T2MVXY=grid%T2MVXY, T2MBXY=grid%T2MBXY, CHSTARXY=grid%CHSTARXY,    & ! Optional Noah-MP
+     &                smoiseq=grid%smoiseq, smcwtdxy=grid%smcwtdxy, rechxy=grid%rechxy,   &
+     &                deeprechxy=grid%deeprechxy,                                         &
+     &                lakedepth2d=grid%lakedepth2d,  savedtke12d=grid%savedtke12d,  snowdp2d=grid%snowdp2d,   h2osno2d=grid%h2osno2d,               & !lake
+     &                snl2d= grid%snl2d, t_grnd2d=grid%t_grnd2d, t_lake3d=grid%t_lake3d, lake_icefrac3d=grid%lake_icefrac3d,                        & !lake
+     &                z_lake3d=grid%z_lake3d, dz_lake3d=grid%dz_lake3d, t_soisno3d=grid%t_soisno3d, h2osoi_ice3d=grid%h2osoi_ice3d,                 & !lake
+     &                h2osoi_liq3d=grid%h2osoi_liq3d, h2osoi_vol3d=grid%h2osoi_vol3d, z3d=grid%z3d, dz3d=grid%dz3d,                                 & !lake
+     &                zi3d=grid%zi3d, watsat3d=grid%watsat3d, csol3d=grid%csol3d, tkmg3d=grid%tkmg3d,                                               & !lake
+     &                tkdry3d=grid%tkdry3d, tksatu3d=grid%tksatu3d, lake2d=grid%lake2d,                                                             & !lake
+     &                lakedepth_default=config_flags%lakedepth_default, lake_min_elev=config_flags%lake_min_elev, lake_depth=grid%lake_depth,               & !lake
+     &                lake_depth_flag=grid%LAKE_DEPTH_FLAG, use_lakedepth=grid%use_lakedepth,                                                      & !lake
+     &                sf_surface_mosaic=config_flags%sf_surface_mosaic, mosaic_cat=config_flags%mosaic_cat, nlcat=1,     & ! Noah tiling
+     &                MAXPATCH=1 & ! CLM
      &                )
 
 #ifdef HWRF
@@ -2039,14 +2115,20 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
 !-----------------------------------------------------------------------
 !---- Initialization for gravity wave drag (GWD) & mountain blocking (MB)
 !
-      CALL nl_get_cen_lat(GRID%ID, CEN_LAT)    !-- CEN_LAT in deg
-      CALL nl_get_cen_lon(GRID%ID, CEN_LON)    !-- CEN_LON in deg
-      DTPHS=grid%dt*grid%nphs
-      CALL GWD_init(DTPHS,GRID%DX,GRID%DY,CEN_LAT,CEN_LON,RESTRT        &
+#if (HWRF == 1)
+   IF(grid%gwd_opt .eq. 2 .AND. grid%id .eq. 1 .AND. allowed_to_read) THEN
+#else
+   IF(grid%gwd_opt .eq. 2 ) THEN
+#endif
+        CALL nl_get_cen_lat(GRID%ID, CEN_LAT)    !-- CEN_LAT in deg
+        CALL nl_get_cen_lon(GRID%ID, CEN_LON)    !-- CEN_LON in deg
+        DTPHS=grid%dt*grid%nphs
+        CALL GWD_init(DTPHS,GRID%DX,GRID%DY,CEN_LAT,CEN_LON,RESTRT        &
      &              ,grid%glat,grid%glon,grid%crot,grid%srot,grid%hangl                          &
      &              ,IDS,IDE,JDS,JDE,KDS,KDE                            &
      &              ,IMS,IME,JMS,JME,KMS,KME                            &
      &              ,ITS,ITE,JTS,JTE,KTS,KTE )
+      ENDIF
       IF(.NOT.RESTRT)THEN
         DO J=MYJS,MYJE
         DO I=MYIS,MYIE
@@ -2281,7 +2363,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
                grid%ttday,grid%tcosz,grid%julday,grid%gmt,                         &
                GD_CLOUD,GD_CLOUD2,raincv_a,raincv_b,           &
                GD_CLOUD_a,GD_CLOUD2_a,            &
-               GD_CLOUD_B,GD_CLOUD2_B,            &
+               QC_CU,QI_CU,                       &
                TAUAER1,TAUAER2,TAUAER3,TAUAER4,                      &
                GAER1,GAER2,GAER3,GAER4,                              &
                WAER1,WAER2,WAER3,WAER4,                              &
@@ -2306,7 +2388,8 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
                 IDS,IDE, JDS,JDE, KDS,KDE,                                  &
                 IMS,IME, JMS,JME, KMS,KME,                                  &
                 ITS,ITE, JTS,JTE, KTS,KTE-1                                 )
-        CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RADM2SORG_KPP,RACMSORG_AQ,RACMSORG_AQCHEM,RACMSORG_KPP)
+        CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RADM2SORG_KPP,RACMSORG_AQ,RACMSORG_AQCHEM_KPP, &
+              RACM_ESRLSORG_AQCHEM_KPP,RACMSORG_KPP)
 !!!       write(0,*)'sum pm '
            CALL SUM_PM_SORGAM (                                             &
                 RRI, CHEM, H2OAJ, H2OAI,                              &
@@ -2316,7 +2399,8 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
                 ITS,ITE, JTS,JTE, KTS,KTE-1                                 )
              
         CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, &
-             CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ)
+             CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, &
+        	 CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP)
            CALL SUM_PM_MOSAIC (                                             &
                 RRI, CHEM,                                            &
                 PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC, PM10,                 &
@@ -2390,6 +2474,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
 #ifndef WRF_CHEM
       DEALLOCATE(CLDFRA_OLD)
 #endif
+      DEALLOCATE(Z_AT_Q)
 #if 0
       DEALLOCATE(w0avg)
 #endif
diff --git a/wrfv2_fire/external/Makefile b/wrfv2_fire/external/Makefile
index ab8efc44..2bfe007a 100644
--- a/wrfv2_fire/external/Makefile
+++ b/wrfv2_fire/external/Makefile
@@ -2,9 +2,9 @@
 
 superclean :
 	( cd esmf_time_f90 ;  make superclean )
-	( cd io_netcdf ;  make superclean )
 	( cd io_pnetcdf ;  make superclean )
 	( cd io_int ; make superclean )
+	( cd io_netcdf ;  make superclean )
 	( cd io_mcel ;  make superclean )
 	( cd io_phdf5 ; make superclean )
 	( cd io_grib1 ; make superclean )
diff --git a/wrfv2_fire/external/RSL_LITE/c_code.c b/wrfv2_fire/external/RSL_LITE/c_code.c
index 1653466a..bdd93f49 100755
--- a/wrfv2_fire/external/RSL_LITE/c_code.c
+++ b/wrfv2_fire/external/RSL_LITE/c_code.c
@@ -40,7 +40,18 @@ RSL_LITE_ERROR_DUP1 ( int *me )
     gethostname( hostname, 256 ) ;
 
 /* redirect standard out*/
+# ifndef RSL0_ONLY
     sprintf(filename,"rsl.out.%04d",*me) ;
+# else
+    if (*me == 0)
+     {
+     sprintf(filename,"rsl.out.%04d",*me) ;
+     }
+    else
+     {
+     sprintf(filename,"/dev/null") ;
+     }
+# endif
     if ((newfd = open( filename, O_CREAT | O_WRONLY | O_TRUNC, 0666 )) < 0 )
     {
         perror("error_dup: cannot open rsl.out.nnnn") ;
@@ -59,7 +70,18 @@ RSL_LITE_ERROR_DUP1 ( int *me )
 # if defined( _WIN32 ) 
     if ( *me != 0 ) {   /* stderr from task 0 should come to screen on windows because it is buffered if redirected */
 #endif
+# ifndef RSL0_ONLY
     sprintf(filename,"rsl.error.%04d",*me) ;
+# else
+    if (*me == 0)
+     {
+     sprintf(filename,"rsl.error.%04d",*me) ;
+     }
+    else
+     {
+     sprintf(filename,"/dev/null") ;
+     }
+# endif
     if ((newfd = open( filename, O_CREAT | O_WRONLY | O_TRUNC, 0666 )) < 0 )
     {
         perror("error_dup: cannot open rsl.error.log") ;
diff --git a/wrfv2_fire/external/RSL_LITE/module_dm.F b/wrfv2_fire/external/RSL_LITE/module_dm.F
index 94f18069..f7367ac1 100644
--- a/wrfv2_fire/external/RSL_LITE/module_dm.F
+++ b/wrfv2_fire/external/RSL_LITE/module_dm.F
@@ -4,6 +4,10 @@ MODULE module_dm
    USE module_wrf_error
    USE module_driver_constants
 !   USE module_comm_dm
+#if ( DA_CORE != 1 )
+   USE module_cpl, ONLY : coupler_on, cpl_init
+#endif
+
    IMPLICIT NONE
 
 #if ( NMM_CORE == 1 ) || defined( WRF_CHEM ) 
@@ -20,6 +24,12 @@ MODULE module_dm
    INTEGER local_communicator_x, local_communicator_y ! subcommunicators for rows and cols of mesh
    LOGICAL :: dm_debug_flag = .FALSE.
 
+#if (DA_CORE == 1)
+   integer :: c_ipsy, c_ipey, c_kpsy, c_kpey, c_kpsx, c_kpex, c_ipex, c_ipsx, c_jpex, c_jpsx, c_jpey, c_jpsy 
+   integer :: c_imsy, c_imey, c_kmsy, c_kmey, c_kmsx, c_kmex, c_imex, c_imsx, c_jmex, c_jmsx, c_jmey, c_jmsy 
+   integer :: k 
+#endif
+
    INTERFACE wrf_dm_maxval
 #if ( defined(PROMOTE_FLOAT) || ( RWORDSIZE == DWORDSIZE ) )
      MODULE PROCEDURE wrf_dm_maxval_real , wrf_dm_maxval_integer
@@ -61,7 +71,6 @@ SUBROUTINE MPASPECT( P, MINM, MINN, PROCMIN_M, PROCMIN_N )
       IF ( MINM .LT. PROCMIN_M .OR. MINN .LT. PROCMIN_N ) THEN
         WRITE( wrf_err_message , * )'MPASPECT: UNABLE TO GENERATE PROCESSOR MESH.  STOPPING.'
         CALL wrf_message ( TRIM ( wrf_err_message ) )
-        WRITE(0,*)' PROCMIN_M ', PROCMIN_M
         WRITE( wrf_err_message , * )' PROCMIN_M ', PROCMIN_M
         CALL wrf_message ( TRIM ( wrf_err_message ) )
         WRITE( wrf_err_message , * )' PROCMIN_N ', PROCMIN_N
@@ -271,6 +280,10 @@ SUBROUTINE patch_domain_rsl_lite( id  , parent, parent_id, &
       INTEGER               :: idim_cd, jdim_cd, ierr
       INTEGER               :: max_dom
 
+#if (DA_CORE == 1)
+      INTEGER               :: e_we, e_sn 
+#endif
+
       TYPE(domain), POINTER :: intermediate_grid
       TYPE(domain), POINTER  :: nest_grid
       CHARACTER*256   :: mess
@@ -464,6 +477,15 @@ SUBROUTINE patch_domain_rsl_lite( id  , parent, parent_id, &
          c_ids = i_parent_start-shw ; c_ide = c_ids + idim_cd - 1
          c_jds = j_parent_start-shw ; c_jde = c_jds + jdim_cd - 1
 
+#if (DA_CORE == 1)
+          call nl_get_e_we( id -1, e_we )
+          call nl_get_e_sn( id -1, e_sn )
+
+         if ( c_ids .le. 0   ) c_ids = 1
+         if ( c_ide .gt. e_we) c_ide = e_we
+         if ( c_jds .le. 0   ) c_jds = 1
+         if ( c_jde .gt. e_sn) c_jde = e_sn
+#endif
          ! we want the intermediate domain to be decomposed the
          ! the same as the underlying nest. So try this:
 
@@ -511,13 +533,99 @@ SUBROUTINE patch_domain_rsl_lite( id  , parent, parent_id, &
             c_jps = 0
          ENDIF
 
+#if (DA_CORE == 1)
+         IF (c_ipe .EQ. -1 .or. c_jpe .EQ. -1) THEN
+            c_ipe = -1
+            c_ips = 0
+            c_jpe = -1
+            c_jps = 0
+         ENDIF
+
+
+          c_kpsx = -1
+          nj = ( c_jds - j_parent_start ) * parent_grid_ratio + 1 + 1 ;
+          ierr = 0
+          DO k = c_kds, c_kde
+             CALL task_for_point ( k, nj, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
+                                   1, 1, ierr )
+             IF ( Px .EQ. mytask_x ) THEN
+                c_kpex = k
+                IF ( c_kpsx .EQ. -1 ) c_kpsx = k
+             ENDIF
+          ENDDO
+          IF ( ierr .NE. 0 ) THEN
+             CALL tfp_message(__FILE__,__LINE__)
+          ENDIF
+          IF (c_kpsx .EQ. -1 ) THEN
+             c_kpex = -1
+             c_kpsx = 0
+          ENDIF
+
+          c_jpsx = -1
+          k = c_kds ;
+          ierr = 0
+          DO j = c_jds, c_jde
+             nj = ( j - j_parent_start ) * parent_grid_ratio + 1 + 1 ;
+             CALL task_for_point ( k, nj, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, &
+                                   1, 1, ierr )
+             IF ( Py .EQ. mytask_y ) THEN
+                c_jpex = j
+                IF ( c_jpsx .EQ. -1 ) c_jpsx = j
+             ENDIF
+          ENDDO
+          IF ( ierr .NE. 0 ) THEN
+             CALL tfp_message(__FILE__,__LINE__)
+          ENDIF
+          IF (c_jpsx .EQ. -1 ) THEN
+             c_jpex = -1
+             c_jpsx = 0
+          ENDIF
+
+          IF (c_ipex .EQ. -1 .or. c_jpex .EQ. -1) THEN
+             c_ipex = -1
+             c_ipsx = 0
+             c_jpex = -1
+             c_jpsx = 0
+          ENDIF
+
+          c_kpsy = c_kpsx   ! same as above
+          c_kpey = c_kpex   ! same as above
+
+          c_ipsy = -1
+          k = c_kds ;
+          ierr = 0
+          DO i = c_ids, c_ide
+             ni = ( i - i_parent_start ) * parent_grid_ratio + 1 + 1 ;
+             CALL task_for_point ( ni, k, ids, ide, kds, kde, ntasks_y, ntasks_x, Py, Px, &
+                                   1, 1, ierr ) ! x and y for proc mesh reversed
+             IF ( Py .EQ. mytask_y ) THEN
+                c_ipey = i
+                IF ( c_ipsy .EQ. -1 ) c_ipsy = i
+             ENDIF
+          ENDDO
+          IF ( ierr .NE. 0 ) THEN
+             CALL tfp_message(__FILE__,__LINE__)
+          ENDIF
+          IF (c_ipsy .EQ. -1 ) THEN
+             c_ipey = -1
+             c_ipsy = 0
+          ENDIF
+#endif
+
+
          IF ( c_ips <= c_ipe ) THEN
 ! extend the patch dimensions out shw along edges of domain
            IF ( mytask_x .EQ. 0 ) THEN
              c_ips = c_ips - shw
+#if (DA_CORE == 1)
+             c_ipsy = c_ipsy - shw  
+#endif
            ENDIF
            IF ( mytask_x .EQ. ntasks_x-1 ) THEN
              c_ipe = c_ipe + shw
+#if (DA_CORE == 1)
+             c_ipey = c_ipey + shw  
+#endif
            ENDIF
            c_ims = max( c_ips - max(shw,thisdomain_max_halo_width), c_ids - bdx ) - 1
            c_ime = min( c_ipe + max(shw,thisdomain_max_halo_width), c_ide + bdx ) + 1
@@ -532,9 +640,15 @@ SUBROUTINE patch_domain_rsl_lite( id  , parent, parent_id, &
 ! extend the patch dimensions out shw along edges of domain
            IF ( mytask_y .EQ. 0 ) THEN
               c_jps = c_jps - shw
+#if (DA_CORE == 1)
+              c_jpsx = c_jpsx - shw  
+#endif
            ENDIF
            IF ( mytask_y .EQ. ntasks_y-1 ) THEN
               c_jpe = c_jpe + shw
+#if (DA_CORE == 1)
+              c_jpex = c_jpex + shw  
+#endif
            ENDIF
            c_jms = max( c_jps - max(shw,thisdomain_max_halo_width), c_jds - bdx ) - 1
            c_jme = min( c_jpe + max(shw,thisdomain_max_halo_width), c_jde + bdx ) + 1
@@ -548,6 +662,79 @@ SUBROUTINE patch_domain_rsl_lite( id  , parent, parent_id, &
          c_kms = 1
          c_kme = c_kde
 
+! Default initializations
+         c_sm1x = 1 ; c_em1x = 1 ; c_sm2x = 1 ; c_em2x = 1 ; c_sm3x = 1 ; c_em3x = 1
+         c_sm1y = 1 ; c_em1y = 1 ; c_sm2y = 1 ; c_em2y = 1 ; c_sm3y = 1 ; c_em3y = 1
+
+#if (DA_CORE == 1)
+         c_kmsx = c_kpsx 
+         c_kmex = c_kpex 
+         c_kmsy = c_kpsy 
+         c_kmey = c_kpey 
+
+         IF ( c_kpsx .EQ. 0 .AND. c_kpex .EQ. -1 ) THEN  
+            c_kmsx = 0
+            c_kmex = 0
+         ENDIF
+         IF ( c_kpsy .EQ. 0 .AND. c_kpey .EQ. -1 ) THEN
+            c_kmsy = 0
+            c_kmey = 0
+         ENDIF
+         c_imsx = c_ids
+         c_imex = c_ide
+         c_ipsx = c_imsx
+         c_ipex = c_imex
+
+         IF ( c_ipsy .EQ. 0 .AND. c_ipey .EQ. -1 ) THEN
+            c_imsy = 0
+            c_imey = 0
+         ELSE
+            c_imsy = c_ipsy
+            c_imey = c_ipey
+         ENDIF
+
+         c_jmsx = c_jpsx
+         c_jmex = c_jpex
+         c_jmsy = c_jds
+         c_jmey = c_jde
+
+         IF ( c_jpsx .EQ. 0 .AND. c_jpex .EQ. -1 ) THEN
+            c_jmsx = 0
+            c_jmex = 0
+         ELSE
+            c_jpsy = c_jmsy
+            c_jpey = c_jmey
+         ENDIF
+
+         c_sm1x = c_imsx
+         c_em1x = c_imex
+         c_sm2x = c_jmsx
+         c_em2x = c_jmex
+         c_sm3x = c_kmsx
+         c_em3x = c_kmex
+
+         c_sm1y = c_imsy
+         c_em1y = c_imey
+         c_sm2y = c_jmsy
+         c_em2y = c_jmey
+         c_sm3y = c_kmsy
+         c_em3y = c_kmey
+
+         c_sp1x = c_ipsx
+         c_ep1x = c_ipex
+         c_sp2x = c_jpsx
+         c_ep2x = c_jpex
+         c_sp3x = c_kpsx
+         c_ep3x = c_kpex
+
+         c_sp1y = c_ipsy
+         c_ep1y = c_ipey
+         c_sp2y = c_jpsy
+         c_ep2y = c_jpey
+         c_sp3y = c_kpsy
+         c_ep3y = c_kpey
+#endif
+
          WRITE(wrf_err_message,*)'*************************************'
          CALL wrf_message( TRIM(wrf_err_message) )
          WRITE(wrf_err_message,*)'Nesting domain'
@@ -648,9 +835,6 @@ SUBROUTINE patch_domain_rsl_lite( id  , parent, parent_id, &
          intermediate_grid%njds = jds
          intermediate_grid%njde = jde
 
-         c_sm1x = 1 ; c_em1x = 1 ; c_sm2x = 1 ; c_em2x = 1 ; c_sm3x = 1 ; c_em3x = 1
-         c_sm1y = 1 ; c_em1y = 1 ; c_sm2y = 1 ; c_em2y = 1 ; c_sm3y = 1 ; c_em3y = 1
-
          intermediate_grid%sm31x                           = c_sm1x
          intermediate_grid%em31x                           = c_em1x
          intermediate_grid%sm32x                           = c_sm2x
@@ -664,6 +848,21 @@ SUBROUTINE patch_domain_rsl_lite( id  , parent, parent_id, &
          intermediate_grid%sm33y                           = c_sm3y
          intermediate_grid%em33y                           = c_em3y
 
+#if (DA_CORE == 1)
+         intermediate_grid%sp31x                           = c_sp1x
+         intermediate_grid%ep31x                           = c_ep1x
+         intermediate_grid%sp32x                           = c_sp2x
+         intermediate_grid%ep32x                           = c_ep2x
+         intermediate_grid%sp33x                           = c_sp3x
+         intermediate_grid%ep33x                           = c_ep3x
+         intermediate_grid%sp31y                           = c_sp1y
+         intermediate_grid%ep31y                           = c_ep1y
+         intermediate_grid%sp32y                           = c_sp2y
+         intermediate_grid%ep32y                           = c_ep2y
+         intermediate_grid%sp33y                           = c_sp3y
+         intermediate_grid%ep33y                           = c_ep3y
+#endif
+
 #if ( defined(SGIALTIX) && (! defined(MOVE_NESTS) ) ) || ( defined(FUJITSU_FX10) && (! defined(MOVE_NESTS) ) )
          ! allocate space for the intermediate domain
          CALL alloc_space_field ( intermediate_grid, intermediate_grid%id , 1, 2 , .TRUE., &   ! use same id as nest
@@ -1134,6 +1333,19 @@ INTEGER FUNCTION wrf_dm_sum_integer ( inval )
 #endif
    END FUNCTION wrf_dm_sum_integer
 
+   SUBROUTINE wrf_dm_sum_integers (inval, retval)
+      IMPLICIT NONE
+      INTEGER, INTENT(IN)  :: inval(:)
+      INTEGER, INTENT(OUT) :: retval(:)
+#ifndef STUBMPI
+      INCLUDE 'mpif.h'
+      INTEGER ierr
+      CALL mpi_allreduce ( inval, retval, SIZE(inval), MPI_INTEGER, MPI_SUM, local_communicator, ierr )
+#else
+      retval = inval
+#endif
+   END SUBROUTINE wrf_dm_sum_integers
+
 #ifdef HWRF
    SUBROUTINE wrf_dm_minloc_real ( val, lat, lon, z, idex, jdex )
       IMPLICIT NONE
@@ -1426,10 +1638,19 @@ SUBROUTINE split_communicator
         IF ( thread_support_provided .lt. thread_support_requested ) THEN
            CALL WRF_ERROR_FATAL( "failed to initialize MPI thread support")
         ENDIF
+        mpi_comm_here = MPI_COMM_WORLD
 #  else
-        CALL mpi_init ( ierr )
+#if ( DA_CORE != 1 )
+        IF ( coupler_on ) THEN
+           CALL cpl_init( mpi_comm_here )
+        ELSE
+#endif
+           CALL mpi_init ( ierr )
+           mpi_comm_here = MPI_COMM_WORLD
+#if ( DA_CORE != 1 )
+        ENDIF
+#endif
 #  endif
-        mpi_comm_here = MPI_COMM_WORLD
 #ifdef HWRF
         CALL atm_cmp_start( mpi_comm_here )   ! atmospheric side of HWRF coupler will split MPI_COMM_WORLD and return communicator as argument
 #endif
@@ -1534,6 +1755,7 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf,          &
     REAL QRK_BUFFER(NIOBF)    ! Buffer for holding Q or RKO
     REAL SFP_BUFFER(NIOBF)    ! Buffer for holding Surface pressure
     REAL PBL_BUFFER(NIOBF)    ! Buffer for holding (real) KPBL index
+    REAL QATOB_BUFFER(NIOBF)  ! Buffer for holding QV at the ob location
     INTEGER N_BUFFER(NIOBF)
     REAL FULL_BUFFER(NIOBF)
     INTEGER IFULL_BUFFER(NIOBF)
@@ -1641,6 +1863,7 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf,          &
        QRK_BUFFER(NLOCAL_CRS) = ERRF(4,N)     ! MOISTURE
        PBL_BUFFER(NLOCAL_CRS) = ERRF(5,N)     ! KPBL
        SFP_BUFFER(NLOCAL_CRS) = ERRF(6,N)     ! SURFACE PRESSURE
+       QATOB_BUFFER(NLOCAL_CRS) = ERRF(10,N)     ! Model Mixing ratio itself (NOT ERROR)
        N_BUFFER(NLOCAL_CRS) = N
      ENDIF
    ENDDO
@@ -1683,6 +1906,15 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf,          &
    DO N = 1, NSTA
      ERRF(6,IFULL_BUFFER(N)) = FULL_BUFFER(N)
    ENDDO
+
+! Water vapor mixing ratio at the mass points (NOT THE ERROR)
+   CALL MPI_ALLGATHERV( QATOB_BUFFER, NLOCAL_CRS, MPI_REAL,     &
+                        FULL_BUFFER, ICOUNT, IDISPLACEMENT,   &
+                        MPI_REAL, MPI_COMM_COMP, IERR)
+   DO N = 1, NSTA
+     ERRF(10,IFULL_BUFFER(N)) = FULL_BUFFER(N)
+   ENDDO
+
 #endif
    END SUBROUTINE get_full_obs_vector
 
@@ -2055,11 +2287,24 @@ SUBROUTINE write_68( grid, v , s , &
 END
 
    SUBROUTINE wrf_abort
+
+#if ( DA_CORE != 1 )
+      USE module_cpl, ONLY : coupler_on, cpl_abort
+#endif
+
       IMPLICIT NONE
 #ifndef STUBMPI
       INCLUDE 'mpif.h'
       INTEGER ierr
-      CALL mpi_abort(MPI_COMM_WORLD,1,ierr)
+#if ( DA_CORE != 1 )
+      IF ( coupler_on ) THEN
+         CALL cpl_abort( 'wrf_abort', 'look for abort message in rsl* files' )
+      ELSE
+#endif
+         CALL mpi_abort(MPI_COMM_WORLD,1,ierr)
+#if ( DA_CORE != 1 )
+      END IF
+#endif
 #else
       STOP
 #endif
diff --git a/wrfv2_fire/external/atm_ocn/Makefile b/wrfv2_fire/external/atm_ocn/Makefile
index 4f5537ee..07794010 100644
--- a/wrfv2_fire/external/atm_ocn/Makefile
+++ b/wrfv2_fire/external/atm_ocn/Makefile
@@ -16,7 +16,7 @@ library: $(OBJ)
 	$(RANLIB) $(TARGET)
 
 .F.o:
-	$(CPP) $(CPPFLAGS) -DDM_PARALLEL  $*.F  > $*.f90
+	$(CPP) -traditional $(CPPFLAGS) -DDM_PARALLEL  $*.F  > $*.f90
 	$(FC) -o $@ -c $(FFLAGS)  $*.f90 
 
 clean:
diff --git a/wrfv2_fire/external/esmf_time_f90/Makefile b/wrfv2_fire/external/esmf_time_f90/Makefile
index 67074b4f..4ef918fb 100644
--- a/wrfv2_fire/external/esmf_time_f90/Makefile
+++ b/wrfv2_fire/external/esmf_time_f90/Makefile
@@ -39,7 +39,7 @@ libesmf_time.a : $(OBJS)
 Test1_ESMF.f : Test1.F90
 	$(RM) Test1_ESMF.b Test1_ESMF.f
 	cp Test1.F90 Test1_ESMF.b
-	$(CPP) -C -P -I. Test1_ESMF.b > Test1_ESMF.f
+	$(CPP) -P -traditional -I. Test1_ESMF.b > Test1_ESMF.f
 
 Test1_ESMF.exe : libesmf_time.a Test1_ESMF.o
 	$(FC) -o Test1_ESMF.exe Test1_ESMF.o libesmf_time.a
@@ -47,7 +47,7 @@ Test1_ESMF.exe : libesmf_time.a Test1_ESMF.o
 Test1_WRFU.f : Test1.F90
 	$(RM) Test1_WRFU.b Test1_WRFU.f
 	sed -e "s/ESMF_Mod/module_utility/g" -e "s/ESMF_/WRFU_/g" Test1.F90 > Test1_WRFU.b
-	$(CPP) -C -P -I. Test1_WRFU.b > Test1_WRFU.f
+	$(CPP) -P -traditional -I. Test1_WRFU.b > Test1_WRFU.f
 
 Test1_WRFU.exe : libesmf_time.a Test1_WRFU.o
 	$(FC) -o Test1_WRFU.exe Test1_WRFU.o libesmf_time.a
@@ -55,7 +55,7 @@ Test1_WRFU.exe : libesmf_time.a Test1_WRFU.o
 .F90.o :
 	$(RM) $@
 	$(SED_FTN) $*.F90 > $*.b
-	$(CPP) -C -P -I. $*.b > $*.f
+	$(CPP) -P -traditional -I. $*.b > $*.f
 	$(RM) $*.b
 	@ if echo $(CPP) | $(FGREP) 'DVAR4D'; then \
           echo COMPILING $*.F90 for 4DVAR ; \
@@ -67,7 +67,7 @@ Test1_WRFU.exe : libesmf_time.a Test1_WRFU.o
 .F90.f :
 	$(RM) $@
 	$(SED_FTN) $*.F90 > $*.b
-	$(CPP) -C -P -I. $*.b > $*.f
+	$(CPP) -P -traditional -I. $*.b > $*.f
 	$(RM) $*.b
 	@ if echo $(CPP) | $(FGREP) 'DVAR4D'; then \
           echo COMPILING $*.F90 for 4DVAR ; \
diff --git a/wrfv2_fire/external/fftpack/77to90.csh b/wrfv2_fire/external/fftpack/77to90.csh
index 10782f56..d88ba8c3 100755
--- a/wrfv2_fire/external/fftpack/77to90.csh
+++ b/wrfv2_fire/external/fftpack/77to90.csh
@@ -1,38 +1,22 @@
 #!/bin/csh
 
-#	The NCAR CISL fftpack (version 5)
-#	convert files to f90
+#	The NCAR CISL fftpack (version 5) rename *.f90 to *.F
 
 
-cd fftpack5
+cd temp
 
-foreach f ( *.f )
+foreach f ( *.f90 )
 
 	set root = $f:r
 	
 	#	Get rid of those pesky tab characters
 
-	expand $f >! ${root}.F
+	expand $f >! ../${root}.F
 
-	#	The f77 to f90 converter wants files to
-	#	end with the .f extension.  
-
-	mv ${root}.F ${root}.f
-
-	echo "${root} /" >! input
-	../a.out < input
-
-	#	The converter makes a .f90 file, WRF expects
-	#	things to actually be .F extensioned.
-
-	mv ${root}.f90 ${root}.F
-
-	#	Zap the original f77 file.
-
-	rm ${root}.f
+	rm ${root}.f90
 	
 end
 
-rm input
-
 cd ..
+
+rm -rf temp
diff --git a/wrfv2_fire/external/fftpack/README b/wrfv2_fire/external/fftpack/README
index e35606e6..2a951692 100644
--- a/wrfv2_fire/external/fftpack/README
+++ b/wrfv2_fire/external/fftpack/README
@@ -1,45 +1,24 @@
-Web site for convert.f90:
-ftp://ftp.numerical.rl.ac.uk/pub/MandR/convert.f90
+The FFTPACK5 is an open source library of Fast Fourier
+Transforms.  The download and reference pages are
+available at:
+http://www2.cisl.ucar.edu/docs/fftpack5
 
-!     Copyright CERN, Geneva 1991, 1997 - Copyright and any other
-!     appropriate legal protection of these computer programs
-!     and associated documentation reserved in all countries
-!     of the world.
-!     Author: Michael Metcalf  (MichaelMetcalf@compuserve.com)
 
-======================================================
+1) What does WRF use from the package
 
-Web site for fftpack5:
-http://www.cisl.ucar.edu/css/software/fftpack5/
+The WRF code makes use of only of a few of the routines:
 
-FFTPACK is a Fortran subroutine library of Fast Fourier Transforms (FFT's) 
-developed at the National Center for Atmospheric Research. Version 5 of the 
-library was written by Paul Swarztrauber and Richard Valent in the mid 
-1990's. This release of FFTPACK includes single and multiple instance 
-complex-to-complex and real-to-real transforms, two-dimensional complex-
-to-complex and real-to-complex transforms, and a collection of sine and 
-cosine transforms.  
+The Stochastic Backscatter scheme:
+CFFT1I
+CFFT1B
 
-References
+The Spectral Nudging option:
+RFFTMI
+RFFTMF
+RFFTMB
 
-(1) Vectorizing the Fast Fourier Transforms, by Paul Swarztrauber, 
-    Parallel Computations, G. Rodrigue, ed., Academic Press, New York 1982.
+The polar filtering capabaility for a global domain:
+DFFT1I
+DFFT1F
+DFFT1B
 
-(2) Fast Fourier Transforms Algorithms for Vector Computers, by Paul 
-    Swarztrauber, Parallel Computing, (1984) pp.45-63.
-
-(3) Symmetric FFTs, by P. N. Swarztrauber, Mathematics of Computation 47(1986), 
-    pp. 323-346.
-
-==========
-
-The WRF usage of the fftpack5 package is for filtering high-latitude
-data for usage in the global implementation.  The files have been 
-moved from little .f files to big .F files (to adopt the WRF convention).
-Additionally, the Makefile has been modified to accomodate this small
-naming change for the default suffix.  
-
-The fftpack source has been changed by the convert.f90 program, turning
-the code into free-format.  The only other modification is that the
-imbedded tabs in the source have been turned into spaces (otherwise
-convert.f90 coughs up a spleen).
diff --git a/wrfv2_fire/external/fftpack/convert.f90 b/wrfv2_fire/external/fftpack/convert.f90
deleted file mode 100644
index 7ce6aa0c..00000000
--- a/wrfv2_fire/external/fftpack/convert.f90
+++ /dev/null
@@ -1,1710 +0,0 @@
-!     ftp://ftp.numerical.rl.ac.uk/pub/MandR/convert.f90
-!
-!     Copyright CERN, Geneva 1991, 1997 - Copyright and any other
-!     appropriate legal protection of these computer programs
-!     and associated documentation reserved in all countries
-!     of the world.
-!     Author: Michael Metcalf  (MichaelMetcalf@compuserve.com)
-!
-!     Requires the option -qcharlen=14400 with IBM's xlf.
-!
-!     Version 1.5. Differs from previous versions in that:
-!      (19/12/96)
-!                  Code modified to be Fortran 95 and ELF
-!                  compatible (no functional changes).
-!
-!***********************************************************************
-!                                                                      *
-!                                                                      *
-!    A program to convert FORTRAN 77 source form to Fortran 90 source  *
-!  form. It also formats the code by indenting the bodies of DO-loops  *
-!  and IF-blocks by ISHIFT columns. Statement keywords are             *
-!  followed if necessary by a blank, and blanks within tokens are      *
-!  are suppressed; this handling of blanks is optional.                *
-!    If a CONTINUE statement terminates a single DO loop, it is        *
-!  replaced by END DO.                                                 *
-!    Procedure END statements have the procedure name added, if        *
-!  blanks are handled.                                                 *
-!    Statements like INTEGER*2 are converted to INTEGER(2), if blanks  *
-!  are handled. Depending on the target processor, a further global    *
-!  edit might be required (e.g. where 2 bytes correspond to KIND=1).   *
-!  Typed functions and assumed-length character specifications are     *
-!  treated similarly. The length specification *4 is removed for all   *
-!  data types except CHARACTER, as is *8 for COMPLEX. This             *
-!  treatment of non-standard type declarations includes any            *
-!  non-standard IMPLICIT statements.                                   *
-!    Optionally, interface blocks only may be produced; this requires  *
-!  blanks processing to be requested. The interface blocks are         *
-!  compatible with both the old and new source forms.                  *
-!                                                                      *
-!    Usage: the program reads one data record in free format from the  *
-!          default input unit. This contains:                          *
-!                                                                      *
-!                        name of file                                  *
-!                        indentation depth                             *
-!                        maximum indentation level                     *
-!                        whether significant blanks should be handled  *
-!                        whether interface blocks only are required    *
-!                                                                      *
-!   The default values in the absence of this record are:              *
-!                               name 3 10 T F                          *
-!   To do nothing but change the source form of a file prog.f type     *
-!                               prog 0  0 F F                          *
-!       or simply                                                      *
-!                               prog /                                 *
-!   For more extensive processing type, say,                           *
-!                               prog 3 10 t f                          *
-!   and for interface blocks only type                                 *
-!                               prog 0 0 t t                           *
-!   The input is read from prog.f, the output is written to prog.f90;  *
-!   there should be no tabs in the input.                              *
-!                                                                      *
-!   Restrictions:  The program does not indent FORMAT statements or    *
-!                any statement containing a character string with an   *
-!                embedded multiple blank.                              *
-!                  The order of comment lines and Fortran statements   *
-!                is slightly modified if there are sequences of        *
-!                more than KKLIM (=200) comment lines.                 *
-!                  If there are syntax errors, continued lines do not  *
-!                have a trailing &.                                    *
-!                  When producing interface blocks, a check is required*
-!                that any dummy argument that is a procedure has a     *
-!                corresponding EXTERNAL statement. Also, since no      *
-!                COMMON blocks or PARAMETER statements are copied,     *
-!                part of an assumed-size array declaration may be      *
-!                missing. Similarly, parts of an assumed-length        *
-!                character symbolic constant might be copied and have  *
-!                to be deleted. BLOCK DATA statements are copied and   *
-!                must be deleted. These problems would normally be     *
-!                detected by a compiler and are trivially corrected.   *
-!                  Within a given keyword, the case must be all upper  *
-!                or all lower, and lower case programs require         *
-!                blank handling for correct indenting.                 *
-!                                                                      *
-!***********************************************************************
-!
-   MODULE STRUCTURE
-!
-!***********************************************************************
-!   Define maximum level of DO-loop nesting, and maximum length of     *
-!   a Fortran statement. LEN may be reduced for                        *
-!   compilers accepting a maximum character                            *
-!   length below 2640 and this will cause any excess                   *
-!   continuation lines and all following lines to be copied unchanged. *
-!   KKLIM defines the length of the comment line buffer. If this       *
-!   length is exceeded, the statement preceding the comments will      *
-!   appear after them.                                                 *
-!***********************************************************************
-      implicit none
-      public
-      INTEGER, PARAMETER :: NEST = 32 , LEN = 2640 , KKLIM = 200,      &
-      KLEN = 72*KKLIM
-!
-      INTEGER :: KNTDO , KNTIF , KNTCOM , LABEL , LENST , LABLNO, NOARG
-      INTEGER, DIMENSION(NEST) :: LABLDO
-!
-      LOGICAL :: SYNERR, BLNKFL, INTFL
-!
-      CHARACTER(LEN=LEN) :: STAMNT
-      CHARACTER(LEN=KLEN):: CBUF
-      CHARACTER(LEN=42)  :: NAME
-!
-   END MODULE STRUCTURE
-   MODULE DATA
-   implicit none
-   public
-!
-      INTEGER, SAVE :: ISHIFT , MXDPTH , NIN , NOUT, TIME0
-      LOGICAL, SAVE :: BLANKS, INTBFL
-!
-   END MODULE DATA
-   MODULE STATISTICS
-   implicit none
-   public
-!
-      INTEGER, SAVE :: MXDO , MXIF , KARD , KNTPU
-!
-      LOGICAL, SAVE :: SYNTAX, OVFLW, NONSTD
-!
-   END MODULE STATISTICS
-   MODULE ALL_PROCEDURES
-   private
-   public :: start, program_units, terminate
-   CONTAINS
-!***********************************************************************
-   SUBROUTINE ARGUMENT(ARGNAM, LENARG, STAMNT, LENST, NOARG)
-   implicit none
-!
-!   To store the argument names and function name, if any, for later
-!   use in checking whether a specification statement is relevant to an
-!   interface block.
-      CHARACTER(LEN=*), INTENT(IN OUT), dimension(:) :: ARGNAM
-      CHARACTER(LEN=*), INTENT(IN)         :: STAMNT
-      INTEGER, INTENT(OUT), dimension(:)   :: LENARG
-      INTEGER, INTENT(IN OUT) :: NOARG
-      INTEGER, INTENT(IN)    :: LENST
-!
-      integer :: ind1, ind2, newind
-!
-!   Correct length of function name
-      IF (NOARG == 1) LENARG(1) = LEN_TRIM(ARGNAM(1))
-!
-!   Get any other arguments
-      IND1 = index(STAMNT(:LENST), '(') + 1
-      IF (IND1  /=  1 .AND. STAMNT(IND1:IND1)  /=  ')') THEN
-         NEWIND = index(STAMNT(IND1+1:LENST), '(')
-         IF (NEWIND /= 0) IND1 = NEWIND + 1 + IND1
-    3    IND2 = index(STAMNT(IND1:LENST), ',') - 1
-         IF (IND2  ==  -1) IND2 = index(STAMNT(IND1:LENST), ')') - 1
-         IND2 = IND2 + IND1 - 1
-         IF (STAMNT(IND1+1:IND1+1)  /=  '*' ) THEN
-            NOARG = NOARG +1
-            ARGNAM(NOARG) = STAMNT(IND1:IND2)
-            LENARG(NOARG) = IND2 - IND1 +1
-         END IF
-            IF (STAMNT(IND2+1:IND2+1)  ==  ')') GO TO 4
-         IND1 = IND2 + 3
-         GO TO 3
-      END IF
-    4 LENARG(:NOARG) = MIN(LENARG(:NOARG), 6)
-!
-   RETURN
-   END SUBROUTINE ARGUMENT
-   SUBROUTINE BLANK( )
-!
-!   To suppress all blanks in the statement, and then to place
-!   a blank on each side of =,  +, -, * and / (but not ** or //), a
-!   blank after each ) and , and a blank before each (.
-!   No changes are made within character strings or FORMAT statememts.
-!
-      USE DATA
-!
-      USE STATISTICS
-!
-      USE STRUCTURE
-   implicit none
-!
-      CHARACTER(LEN=LEN) :: BUFFER
-      integer :: l1, l2, lchar, napost, lenold
-!
-!   Reduce length to that of significant characters
-      BLNKFL = .FALSE.
-      LENST = LEN_TRIM(STAMNT(1:LENST))
-      IF (.NOT.BLANKS) THEN
-         IF (LEN-LENST >= 2) STAMNT(LENST+1:LENST+2) = '  '
-         LENST = MIN(LENST+2, LEN)
-         GO TO 99
-      END IF
-      BLNKFL = .TRUE.
-!
-!   Suppress blanks (add 2 to catch
-!   odd number of apostrophes on a line in REFORM).
-      LCHAR = 0
-      NAPOST = 0
-      DO L1 = 1, LENST
-         IF (STAMNT(L1:L1)  ==  "'") NAPOST = 1-NAPOST
-         IF (NAPOST == 0 .AND. STAMNT(L1:L1)  ==  ' ') CYCLE
-         LCHAR = LCHAR+1
-         BUFFER(LCHAR:LCHAR) = STAMNT(L1:L1)
-      END DO
-      IF (LEN-LCHAR >= 2) BUFFER(LCHAR+1:LCHAR+2) = '  '
-      LCHAR = MIN(LCHAR+2, LEN)
-!
-!   Eliminate FORMATS
-       IF( LABEL  /=  0 .AND.                                          &
-     & LCHAR  >=  11 .AND.(BUFFER(:7)  ==  'FORMAT(' .OR.              &
-     &                     BUFFER(:7)  ==  'format(') .AND.            &
-     & BUFFER(LCHAR-2:LCHAR-2)  ==  ')') THEN
-         IF (LEN-LENST >= 2) STAMNT(LENST+1:LENST+2) = '  '
-         LENST = MIN(LENST+2, LEN)
-         GO TO 99
-       END IF
-!
-!   Insert blanks
-      LENOLD = LENST
-      LENST = 0
-      NAPOST = 0
-      DO L2 = 1, LCHAR
-!
-!   Check size of statement
-         IF(LENST+3 > LEN) THEN
-            LENST = LCHAR
-            STAMNT(:LENST) = BUFFER(:LENST)
-            OVFLW = .TRUE.
-            GO TO 99
-         END IF
-!
-!   Whether inside character string
-         IF (BUFFER(L2:L2)  ==  "'") NAPOST = 1-NAPOST
-         IF (NAPOST == 1) GO TO 3
-!
-!   Add blank padding according to character
-         SELECT CASE (BUFFER(L2:L2))
-         CASE ( ')' )
-            STAMNT(LENST+1:LENST+2) = ') '
-            LENST = LENST+2
-         CASE ( '(' )
-            STAMNT(LENST+1:LENST+2) = ' ('
-            LENST = LENST + 2
-         CASE ( ',' )
-            STAMNT(LENST+1:LENST+2) = ', '
-            LENST = LENST + 2
-         CASE ( '=' )
-            STAMNT(LENST+1:LENST+3) = ' = '
-            LENST = LENST + 3
-         CASE ( '*' )
-            IF (BUFFER(L2-1:L2-1)  /=  '*' .AND. BUFFER(L2+1:L2+1)     &
-             /=  '*') THEN
-               STAMNT(LENST+1:LENST+3) = ' * '
-               LENST = LENST + 3
-            ELSE
-               GO TO 3
-            END IF
-         CASE ( '/' )
-            IF (BUFFER(L2-1:L2-1)  /=  '/' .AND. BUFFER(L2+1:L2+1)     &
-             /=  '/') THEN
-               STAMNT(LENST+1:LENST+3) = ' / '
-               LENST = LENST + 3
-            ELSE
-               GO TO 3
-            END IF
-         CASE ('+')
-            IF (BUFFER(L2-1:L2-1)  /=  'E' .AND.                       &
-                BUFFER(L2-1:L2-1)  /=  'e' .AND.                       &
-                BUFFER(L2-1:L2-1)  /=  'D' .AND.                       &
-                BUFFER(L2-1:L2-1)  /=  'd' .OR.                        &
-          LLT(BUFFER(L2+1:L2+1), '0') .AND. LGT(BUFFER(L2+1:L2+1), '9')&
-               ) THEN
-               STAMNT(LENST+1:LENST+3) = ' + '
-               LENST = LENST + 3
-            ELSE
-               GO TO 3
-            END IF
-         CASE ('-')
-            IF (BUFFER(L2-1:L2-1)  /=  'E' .AND.                       &
-                BUFFER(L2-1:L2-1)  /=  'e' .AND.                       &
-                BUFFER(L2-1:L2-1)  /=  'D' .AND.                       &
-                BUFFER(L2-1:L2-1)  /=  'd' .OR.                        &
-          LLT(BUFFER(L2+1:L2+1), '0') .AND. LGT(BUFFER(L2+1:L2+1), '9')&
-               ) THEN
-               STAMNT(LENST+1:LENST+3) = ' - '
-               LENST = LENST + 3
-            ELSE
-               GO TO 3
-            END IF
-         CASE DEFAULT
-            GO TO 3
-         END SELECT
-         CYCLE
-    3    STAMNT(LENST+1:LENST+1) = BUFFER(L2:L2)
-         LENST = LENST +1
-      END DO
-!
-!   Blank out end of statement
-      IF (LENOLD > LENST) STAMNT(LENST+1:LENOLD) = ' '
-      IF (LENST < LEN .AND. MOD(LENST, 66) /= 0)                       &
-          STAMNT(LENST+1: LENST+66-MOD(LENST, 66)) = ' '
-!
-99 RETURN
-   END SUBROUTINE BLANK
-   SUBROUTINE IDENTIFY (IRET)
-!
-!***********************************************************************
-!   To identify statement as beginning or end of DO-loop or            *
-!   IF-block, or as probable FORMAT.                                   *
-!   Attempt to scan as few of the input characters as possible.        *
-!***********************************************************************
-!
-      USE STRUCTURE
-      USE DATA
-   implicit none
-!
-      CHARACTER(LEN=5), PARAMETER :: ENDIF='ENDIF' , THEN='NEHT)',     &
-                                     THENLC='neht)'
-      CHARACTER(LEN=3), PARAMETER :: BIF='IF('
-      CHARACTER(LEN=2), PARAMETER :: DO='DO'
-      CHARACTER(LEN=7), PARAMETER :: FORMAT='FORMAT('
-      CHARACTER(LEN=4), PARAMETER :: ELSE='ELSE'
-      CHARACTER(LEN=5)            :: INTFIL
-      INTEGER, INTENT(OUT)        :: IRET
-!
-      integer :: l1, l2, l3, l4, l5, l6, l7, l8, l9, l10, l11, l12,    &
-                 k1, k2, k3, k5, k6, k7, k8, lparen, kntch, napos
-!
-      IRET = 0
-!
-!   Check whether end of DO-loop
-      IF (KNTDO /= 0) THEN
-         IF (LABEL == LABLDO(KNTDO)) THEN
-            IRET = 2
-            GO TO 99
-         END IF
-      END IF
-!
-!   Check whether any of remaining possibilities
-      DO L7 = 1 , LENST
-         IF (STAMNT(L7:L7) == ' ') CYCLE
-         IF (STAMNT(L7:L7) == 'E') THEN
-            DO L11 = L7+1 , LENST
-               IF (STAMNT(L11:L11) == ' ') CYCLE
-               IF (STAMNT(L11:L11) == ENDIF(2:2)) GO TO 6
-               IF (STAMNT(L11:L11) == ELSE(2:2)) GO TO 3
-               GO TO 99
-            END DO
-         END IF
-         IF (STAMNT(L7:L7) == BIF(:1)) GO TO 9
-         IF (STAMNT(L7:L7) == DO(:1)) GO TO 15
-         IF (STAMNT(L7:L7) == FORMAT(:1)) GO TO 31
-         GO TO 99
-      END DO
-      GO TO  99
-!
-!   Check whether ELSE or ELSEIF
-    3 K8 = 3
-      DO L12 = L11+1 , LENST
-         IF (STAMNT(L12:L12) == ' ') CYCLE
-         IF (STAMNT(L12:L12) /= ELSE(K8:K8)) GO TO 99
-         IF (K8 == 4) GO TO 5
-         K8 = K8+1
-      END DO
-      GO TO  99
-    5 IF (L12 >= LENST) THEN
-         IRET = 6
-         GO TO 99
-      END IF
-      IF (STAMNT(L12+1:LENST) == ' ') THEN
-         IRET = 6
-         GO TO 99
-      END IF
-      K2 = 1
-      IRET = 6
-      L7 = L12
-      GO TO  10
-!
-!   Check whether end of IF-block
-    6 K1 = 3
-      DO L1 = L11+1 , LENST
-         IF (STAMNT(L1:L1) == ' ') CYCLE
-         IF (STAMNT(L1:L1) /= ENDIF(K1:K1)) GO TO 99
-         IF (K1 == 5) EXIT
-         K1 = K1+1
-      END DO
-      IF (L1 >= LENST) THEN
-         IRET = 4
-         GO TO 99
-      END IF
-      IF (STAMNT(L1+1:LENST) == ' ') IRET = 4
-      GO TO  99
-!
-!   Check whether beginning of IF-block
-    9 K2 = 2
-      IRET = 3
-   10 DO L2 = L7+1 , LENST
-         IF (STAMNT(L2:L2) == ' ') CYCLE
-         IF (STAMNT(L2:L2) /= BIF(K2:K2)) THEN
-            IRET = 0
-            GO TO 99
-         END IF
-         IF (K2 == 3) GO TO 12
-         K2 = K2+1
-      END DO
-      IRET = 0
-      GO TO  99
-!
-!   Backward search for )THEN at end of IF statement (to save
-!   scanning the condition).
-   12 K3 = 1
-      DO L3 = LENST , L2+1 , -1
-         IF (STAMNT(L3:L3) == ' ') CYCLE
-         IF (STAMNT(L3:L3) /= THEN(K3:K3) .AND.                        &
-             STAMNT(L3:L3) /= THENLC(K3:K3)) THEN
-            IRET = 0
-            GO TO 99
-         END IF
-         IF (K3 == 5) GO TO 99
-         K3 = K3+1
-      END DO
-      IRET = 0
-      GO TO  99
-!
-!   Check whether beginning of DO-loop
-   15 DO L4 = L7+1 , LENST
-         IF (STAMNT(L4:L4) == ' ') CYCLE
-         IF (STAMNT(L4:L4) == DO(2:2)) GO TO 17
-         GO TO 99
-      END DO
-      GO TO  99
-!
-!   Have DO - check label
-   17 K5 = 0
-      INTFIL = ' '
-      DO L5 = L4+1 , LENST
-         IF (STAMNT(L5:L5) == ' ') CYCLE
-         IF (LLT(STAMNT(L5:L5) , '0') .OR. LGT(STAMNT(L5:L5) , '9'))   &
-         EXIT
-         K5 = K5+1
-         IF (K5 > 5) GO TO 20
-         INTFIL(K5:K5) = STAMNT(L5:L5)
-      END DO
-      IF (K5 == 0) GO TO 99
-   20 READ (INTFIL , '(BN , I5)') LABLNO
-      IF (LABLNO == 0) GO TO 99
-!
-!   Have label - check comma
-      DO L8 = L5, LENST
-         IF (STAMNT(L8:L8) == ' ') CYCLE
-         IF (STAMNT(L8:L8) == ',') EXIT
-         GO TO 23
-      END DO
-      IRET = 1
-      GO TO  99
-!
-!   Have a DO and label with no comma.
-!   Check for variable whose first of maximum of six
-!   characters is alphabetic, followed by an equals sign,
-!   followed by a character string containing a comma which is
-!   not enclosed in parentheses.
-   23 K6 = 0
-      DO L9 = L8 , LENST
-         IF (STAMNT(L9:L9) == ' ') CYCLE
-         IF (K6 == 0) THEN
-            IF ((LLT(STAMNT(L9:L9), 'A') .OR. LGT(STAMNT(L9:L9), 'Z')) &
-           .AND.(LLT(STAMNT(L9:L9), 'a') .OR. LGT(STAMNT(L9:L9), 'z')))&
-            GO TO 99
-            K6 = 1
-         ELSE IF (LGE(STAMNT(L9:L9) , 'A') .AND. LLE(STAMNT(L9:L9),'Z')&
-            .OR. LGE(STAMNT(L9:L9) , 'a') .AND. LLE(STAMNT(L9:L9) ,'z')&
-         .OR. LGE(STAMNT(L9:L9) , '0') .AND. LLE(STAMNT(L9:L9) , '9')) &
-         THEN
-            K6 = K6+1
-            IF (K6 == 6) GO TO 26
-         ELSE
-            IF (K6 == 0) GO TO 99
-            GO TO 25
-         END IF
-      END DO
-      GO TO  99
-!
-!   Expect an equals sign
-   25 L9=L9-1
-   26 DO L10 = L9+1 , LENST
-         IF (STAMNT(L10:L10) == ' ') CYCLE
-         IF (STAMNT(L10:L10) == '=') GO TO 28
-         GO TO 99
-      END DO
-      GO TO  99
-!
-!   Search for bare comma
-   28 LPAREN = 0
-      KNTCH = 0
-      NAPOS = 0
-      DO L6 = L10+1 , LENST
-         IF (STAMNT(L6:L6) == ' ') CYCLE
-         IF (STAMNT(L6:L6) == "'") NAPOS = 1 - NAPOS
-         IF (NAPOS == 1) CYCLE
-         IF (STAMNT(L6:L6) == ',') THEN
-            IF (KNTCH /= 0) THEN
-               IF (LPAREN == 0) GO TO 30
-               CYCLE
-            ELSE
-               GO TO 99
-            END IF
-         ELSE IF (STAMNT(L6:L6) == '(') THEN
-            LPAREN = LPAREN+1
-         ELSE IF (STAMNT(L6:L6) == ')') THEN
-            LPAREN = LPAREN-1
-         END IF
-         KNTCH = 1
-      END DO
-      GO TO  99
-   30 IRET = 1
-!
-!   Insert blank after label
-      IF (.NOT.BLANKS .OR. LENST >= LEN) GO TO 99
-      DO L10 = LENST, L5, -1
-         STAMNT(L10+1:L10+1) = STAMNT(L10:L10)
-      END DO
-      STAMNT(L5:L5) = ' '
-      LENST = LENST  + 1
-      GO TO  99
-!
-!   Identify FORMAT statement
-   31 IF (LABEL == 0) GO TO 99
-      K7 = 2
-      DO L11 = L7+1 , LENST
-         IF (STAMNT(L11:L11) == ' ') CYCLE
-         IF (STAMNT(L11:L11) /= FORMAT(K7:K7)) GO TO 99
-         IF (K7 == 7) GO TO 33
-         K7 = K7+1
-      END DO
-      GO TO  99
-   33 IRET = 5
-!
-99 RETURN
-   END SUBROUTINE IDENTIFY
-   SUBROUTINE KEYWORD(ASSIGN, SKIP)
-!
-!   To check whether those initial keywords of the statement which
-!   require it are followed by a blank, to add one if necessary, and
-!   to suppress any embedded blanks.
-!
-      USE STATISTICS
-!
-      USE STRUCTURE
-   implicit none
-!
-      LOGICAL, INTENT(OUT) :: ASSIGN, SKIP
-!
-      INTEGER, PARAMETER    :: NKEY = 42, MAXLEN = 15
-      CHARACTER(LEN=MAXLEN) :: BEGIN
-      CHARACTER(LEN=LEN)    :: BUFFER
-      CHARACTER(LEN=3)      :: THREE
-      CHARACTER(LEN=32)     :: NAMEOF
-      CHARACTER(LEN=6), SAVE :: ARGNAM(445)
-      LOGICAL               :: IFASS
-      INTEGER, SAVE         :: LENARG(445)
-!
-      CHARACTER(LEN=MAXLEN), PARAMETER, dimension(nkey) :: KEYS = (/   &
-      'ASSIGN         ', 'BACKSPACE      ', 'BLOCKDATA      ',         &
-      'CALL           ', 'CHARACTER      ', 'CLOSE          ',         &
-      'COMMON         ', 'COMPLEX        ', 'CONTINUE       ',         &
-      'DATA           ', 'DIMENSION      ', 'DOUBLEPRECISION',         &
-      'DO             ', 'ELSEIF         ', 'ELSE           ',         &
-      'ENDFILE        ', 'ENDIF          ', 'ENTRY          ',         &
-      'EXTERNAL       ', 'EQUIVALENCE    ', 'FORMAT         ',         &
-      'FUNCTION       ', 'GOTO           ', 'IF             ',         &
-      'IMPLICIT       ', 'INQUIRE        ', 'INTEGER        ',         &
-      'INTRINSIC      ', 'LOGICAL        ', 'OPEN           ',         &
-      'PARAMETER      ', 'PAUSE          ', 'PRINT          ',         &
-      'PROGRAM        ', 'READ           ', 'REAL           ',         &
-      'RETURN         ', 'REWIND         ', 'SAVE           ',         &
-      'STOP           ', 'SUBROUTINE     ', 'WRITE          '/)
-      INTEGER, PARAMETER, dimension(nkey) :: LK =                      &
-            (/6, 9, 9, 4,                                              &
-              9, 5, 6, 7, 8, 4,                                        &
-              9,15, 2, 6, 4,                                           &
-              7, 5, 5, 8,11,                                           &
-              6, 8, 4, 2, 8, 7,                                        &
-              7, 9, 7, 4, 9,                                           &
-              5, 5, 7, 4, 4, 6,                                        &
-              6, 4, 4,10, 5    /)
-      LOGICAL, PARAMETER, dimension(nkey) :: BLANK =                   &
-               (/.TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,                    &
-                 .TRUE.,  .FALSE., .TRUE.,  .TRUE.,  .FALSE., .TRUE.,  &
-                 .TRUE.,  .TRUE.,  .TRUE.,  .FALSE., .FALSE.,          &
-                 .TRUE.,  .FALSE., .TRUE.,  .TRUE.,  .FALSE.,          &
-                 .FALSE., .TRUE.,  .TRUE.,  .FALSE., .TRUE.,  .FALSE., &
-                 .TRUE.,  .TRUE.,  .TRUE.,  .FALSE., .TRUE.,           &
-                 .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  &
-                 .TRUE.,  .TRUE.,  .TRUE.,  .TRUE.,  .FALSE./)
-      LOGICAL, PARAMETER, dimension(nkey) :: FOLLOW =                  &
-               (/.TRUE.,  .TRUE.,  .FALSE., .TRUE.,                    &
-                 .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., .FALSE., &
-                 .FALSE., .FALSE., .FALSE., .FALSE., .FALSE.,          &
-                 .TRUE.,  .FALSE., .FALSE., .FALSE., .FALSE.,          &
-                 .FALSE., .FALSE., .TRUE.,  .FALSE., .FALSE., .FALSE., &
-                 .FALSE., .FALSE., .FALSE., .FALSE., .FALSE.,          &
-                 .TRUE.,  .TRUE.,  .FALSE., .TRUE.,  .FALSE., .TRUE.,  &
-                 .TRUE.,  .FALSE., .TRUE.,  .FALSE., .FALSE./)
-!
-      CHARACTER(LEN=MAXLEN), PARAMETER, dimension(nkey) :: KEYSLC = (/ &
-      'assign         ', 'backspace      ', 'blockdata      ',         &
-      'call           ', 'character      ', 'close          ',         &
-      'common         ', 'complex        ', 'continue       ',         &
-      'data           ', 'dimension      ', 'doubleprecision',         &
-      'do             ', 'elseif         ', 'else           ',         &
-      'endfile        ', 'endif          ', 'entry          ',         &
-      'external       ', 'equivalence    ', 'format         ',         &
-      'function       ', 'goto           ', 'if             ',         &
-      'implicit       ', 'inquire        ', 'integer        ',         &
-      'intrinsic      ', 'logical        ', 'open           ',         &
-      'parameter      ', 'pause          ', 'print          ',         &
-      'program        ', 'read           ', 'real           ',         &
-      'return         ', 'rewind         ', 'save           ',         &
-      'stop           ', 'subroutine     ', 'write          '/)
-!
-      integer :: l1, l2, l3, l4, l5, l6, l7, l20, lparen, kntap, kntch,&
-                 lc, lcc, l33, next, l8, napos, lsave, name_length
-!
-!   Test for statement function statement or assignment statement
-      SKIP = INTFL
-      ASSIGN = .FALSE.
-      IFASS = .FALSE.
-      THREE = ' '
-      LPAREN = 0
-      KNTAP = 0
-      KNTCH = 0
-      DO L1 = 1, LENST
-         IF (STAMNT(L1:L1)==' ') CYCLE
-         IF (STAMNT(L1:L1)=='=') THEN
-            IF (KNTCH==0) SYNERR = .TRUE.
-            IF (LPAREN==0 .AND. KNTAP==0) THEN
-               ASSIGN = .TRUE.
-               GO TO 9
-            ELSE
-               EXIT
-            END IF
-         ELSE IF (STAMNT(L1:L1)=='(') THEN
-            LPAREN = LPAREN+1
-         ELSE IF (STAMNT(L1:L1)==')') THEN
-            LPAREN = LPAREN-1
-         ELSE IF (STAMNT(L1:L1)=="'") THEN
-            KNTAP = 1-KNTAP
-         END IF
-         KNTCH = KNTCH+1
-         IF (KNTCH<=3) THREE(KNTCH:KNTCH) = STAMNT(L1:L1)
-      END DO
-!
-!   Suppress blanks in first 15 non-blank characters
-   10 BEGIN = ' '
-      LC = 0
-      DO L2 = 1, LENST
-         IF (STAMNT(L2:L2)==' ') CYCLE
-         LC = LC+1
-         BEGIN(LC:LC) = STAMNT(L2:L2)
-         IF (LC==MAXLEN) GO TO 3
-      END DO
-      L2 = L2-1
-!
-!   Is this a keyword? Failure of this test is not fatal, in order to
-!   allow for non-standard syntax extensions.
-    3 DO L3 = 1, NKEY
-         IF     (BEGIN(:LK(L3)) == KEYS(L3)(:LK(L3))) THEN
-            GO TO 5
-         ELSE IF (BEGIN(:LK(L3)) == KEYSLC(L3)(:LK(L3))) THEN
-            LCC = 0
-            DO  L33 = 1, L2
-               IF (STAMNT(L33:L33) == ' ') CYCLE
-               LCC = LCC + 1
-               IF (LCC == LK(L3)) EXIT
-            END DO
-            STAMNT(:L33) = KEYS(L3)(:LK(L3))
-            GO TO 5
-         END IF
-      END DO
-      NONSTD = .TRUE.
-      GO TO  98
-!
-!   Test for embedded blanks in keyword
-    5 IF (L2 /= LC) THEN
-         LC = 0
-         DO L4 =1, LENST
-            IF (STAMNT(L4:L4)==' ') CYCLE
-            LC = LC+1
-            IF (LC==LK(L3)) GO TO 7
-         END DO
-         GO TO 8
-    7    IF (L4==LC) GO TO 8
-         STAMNT(:L4) = KEYS(L3)(:LC)
-         GO TO 99
-      END IF
-!
-!   Keyword has no blanks - is it followed by a blank if it needs one?
-    8 IF (.NOT.BLANK(L3)) GO TO 99
-      NEXT = 0
-      DO L8 = 1, LK(L3)
-   17    NEXT = NEXT+1
-         IF (STAMNT(NEXT:NEXT)==' ') GO TO 17
-      END DO
-      NEXT = NEXT+1
-      IF (STAMNT(NEXT:NEXT)==' ') GO TO 99
-!
-!   Sometimes a delimiter may be present
-      IF (L3==2.OR.L3==16.OR.L3==23.OR.L3==35.OR.L3==38) THEN
-         IF (STAMNT(NEXT:NEXT)=='(') GO TO 99
-      ELSE IF (L3==5) THEN
-         IF (STAMNT(NEXT:NEXT)=='*') GO TO 99
-      ELSE IF (L3==7.OR.L3==39) THEN
-         IF (STAMNT(NEXT:NEXT)=='/') GO TO 99
-      END IF
-      IF (LENST==LEN) THEN
-         OVFLW = .TRUE.
-         GO TO 99
-      END IF
-!
-!   Insert the blank
-      BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
-      LENST = LENST+1
-      STAMNT(NEXT:NEXT) = ' '
-      STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
-      BLNKFL = .TRUE.
-      GO TO  99
-!
-!   Check whether, in fact, a DO-loop
-    9 IF (THREE(:2) /= 'DO' .AND. THREE(:2) /= 'do') GO TO 12
-      LPAREN = 0
-      NAPOS = 0
-      DO L5 = L1+2, LENST
-         IF (STAMNT(L5:L5)==' ') CYCLE
-         IF (STAMNT(L5:L5) == "'") NAPOS = 1 - NAPOS
-         IF (NAPOS == 1) CYCLE
-         IF (STAMNT(L5:L5)==',') THEN
-            IF (LPAREN==0) THEN
-               ASSIGN = .FALSE.
-               GO TO 10
-            END IF
-         ELSE IF (STAMNT(L5:L5)=='(') THEN
-            LPAREN = LPAREN+1
-         ELSE IF (STAMNT(L5:L5)==')') THEN
-            LPAREN = LPAREN-1
-         END IF
-      END DO
-      GO TO  99
-!
-!   Check whether, in fact, a logical IF followed by an assignment
-   12 IF (THREE /= 'IF(' .AND. THREE /= 'if(') GO TO 99
-      IFASS = .TRUE.
-      DO L6 = L1-1, 1, -1
-         IF (STAMNT(L6:L6)==' ') CYCLE
-         IF (STAMNT(L6:L6)==')') THEN
-!
-!   Is there a second pair of first-level parentheses
-            IF (index(STAMNT(:L6), ')')==0) GO TO 99
-            LPAREN = 1
-            DO L7 = L6-1, 4, -1
-               IF (STAMNT(L7:L7)==' ') CYCLE
-               IF (STAMNT(L7:L7)==')') THEN
-                  IF (LPAREN==0) THEN
-                     GO TO 14
-                  ELSE
-                     LPAREN = LPAREN+1
-                  END IF
-               ELSE IF (STAMNT(L7:L7)=='(') THEN
-                  LPAREN = LPAREN-1
-               END IF
-            END DO
-            GO TO 99
-   14       ASSIGN = .FALSE.
-            GO TO 10
-         ELSE
-            ASSIGN = .FALSE.
-            GO TO 10
-         END IF
-      END DO
-!
-!   Test for non-executable statement keyword
-   99 IF (ASSIGN) GO TO 98
-      IF (.NOT.INTFL) GO TO 97
-      SKIP = L3 ==  3.OR.L3 ==  5.OR.L3 ==  8                          &
-         .OR.L3 == 11.OR.L3 == 12.OR.L3 == 19.OR.L3 == 22              &
-         .OR.L3 == 25.OR.L3 == 27.OR.L3 == 29                          &
-         .OR.L3 == 34.OR.L3 == 36.OR.L3 == 41
-      SKIP = .NOT.SKIP
-      IF (SKIP) GO TO 98
-!
-!   Check whether this statement refers to an argument or a function
-!   name
-      IF (L3 == 3 .OR. L3 == 22 .OR. L3 == 25 .OR.                     &
-                       L3 == 34 .OR. L3 == 41) GO TO 97
-      IF(index(STAMNT(LK(L3)+1:LENST), 'FUNCTION')/= .0 .OR.           &
-         index(STAMNT(LK(L3)+1:LENST), 'function') /= 0) GO TO 97
-      DO L20 = 1, NOARG
-         IF(index(STAMNT(LK(L3)+1:LENST), ARGNAM(L20)(:LENARG(L20)))   &
-          /=  0) GO TO 97
-      END DO
-      SKIP = .TRUE.
-      GO TO 98
-!
-!   Keep procedure name for END statement
-   97 call name_of(nameof, stamnt(lk(l3)+2:lenst), name_length)
-      IF(L3 == 3.OR.L3 == 22.OR.L3 == 34.OR.                           &
-      L3 == 41) NAME = KEYS(L3)(:LK(L3))//NAMEOF(:name_length)
-!
-!   Get argument names for later use in skipping unnecessary
-!   specifications
-   21 IF (INTFL) THEN
-         IF (L3 == 22) THEN
-            ARGNAM(1) = NAME(10:15)
-            NOARG = 1
-         END IF
-         IF (L3 == 22 .OR. L3 == 41)                                   &
-         CALL ARGUMENT(ARGNAM, LENARG, STAMNT, LENST, NOARG)
-      END IF
-!
-!   Deal with awkward cases
-      LSAVE = L3
-      IF(L3 == 1.OR.L3 == 5.OR.L3 == 8.OR.L3 == 12 .OR. L3 == 13       &
-      .OR. L3 == 25                                                    &
-      .OR.L3 == 24.AND..NOT.IFASS.OR.L3 == 27.OR.L3 == 29.OR.L3 == 36) &
-        CALL SPECIAL(L3, NEXT, BUFFER, NKEY, KEYS, KEYSLC, LK, FOLLOW)
-!
-!   Was, in fact, a function
-      IF (INTFL.AND.L3 == 22.AND.LSAVE /= 22) THEN
-         SKIP = .FALSE.
-         GO TO 21
-      END IF
-!
-!   Print procedure name
-   98 IF(.NOT.ASSIGN.AND.(L3 == 3.OR.L3 == 22.OR.L3 == 34.OR.L3 == 41))&
-      WRITE (*, '('' Starting '', A)') NAME
-      RETURN
-   END SUBROUTINE KEYWORD
-   subroutine NAME_OF(nameof, HEADER, name_length)
-!
-   implicit none
-!   Pick out name of procedure
-      CHARACTER(LEN=*), INTENT(IN) :: HEADER
-      CHARACTER(LEN=*), INTENT(out):: nameof
-      integer, intent(out)         :: name_length
-      integer :: ind, indast
-!
-      NAMEOF = ' '
-!
-!   Is there a left parenthesis or an asterisk?
-      IND = index(HEADER, '(' )
-      INDAST = index(HEADER, '*')
-      IF (IND /= 0 .AND. INDAST /= 0) IND = MIN(IND, INDAST)
-      IF (IND <= LEN(NAMEOF)) THEN
-         IF (IND  ==  0) THEN
-            NAMEOF(2:) = HEADER(:LEN(HEADER))
-            name_length = min(len(header)+1, len(nameof))
-         ELSE
-            NAMEOF(2:IND) = HEADER(:IND-1)
-            name_length = ind
-         END IF
-      END IF
-      RETURN
-   END subroutine NAME_OF
-   SUBROUTINE PROGRAM_UNITS( )
-!
-!***********************************************************************
-!   The principal subroutine of CONVERT processes the                  *
-!   input stream, which is assumed to contain syntactically correct    *
-!   Fortran program units. To protect itself from bad data, failure    *
-!   to pass a primitive syntax check will cause the program to copy    *
-!   the input stream to the output unit unchanged, until an END line is*
-!   encountered.                                                       *
-!***********************************************************************
-!
-      USE DATA
-!
-      USE STATISTICS
-!
-      USE STRUCTURE
-   implicit none
-!
-!***********************************************************************
-!   USER is a character which may be defined to identify lines         *
-!   in the input stream which are to be treated as                     *
-!   comment lines ( + in this example).                                *
-!***********************************************************************
-!
-      CHARACTER(LEN=1) :: CONTIN
-      CHARACTER(LEN=3), PARAMETER :: FIN='END', FINLC='end'
-      CHARACTER(LEN=66) :: FIELD
-      CHARACTER(LEN=72) :: LINE
-      CHARACTER(LEN=72), PARAMETER :: BLANKV=' '
-!
-      LOGICAL :: NEWDO , NEWIF , FORM ,  ELSEBL , ASSIGN
-!
-      CHARACTER(LEN=*), PARAMETER :: USER = '+'
-      LOGICAL :: STAT = .FALSE. , SKIP = .FALSE.
-!
-      integer :: l1,             l5, l22, kntcon, napo, lab, l9, k1,   &
-                 irtcod, nend
-!
-!   Start processing program units
-      MXDO = 0
-      MXIF = 0
-      KARD = 0
-      KNTPU = 0
-      SYNTAX = .FALSE.
-      SYNERR = .FALSE.
-      OVFLW = .FALSE.
-      NONSTD = .FALSE.
-      KNTDO = 0
-      KNTIF = 0
-      KNTCOM = 0
-      NAME = ' '
-      NOARG = 0
-      INTFL = INTBFL
-!
-!   Set continuation line counter
-    1 KNTCON = 0
-!
-!   Set statement length counter
-      LENST = 0
-!
-!   Read one line into an internal file,
-!   columns 73-80 of all lines are ignored.
-    2 READ (NIN , '(A)' , END = 100 , ERR = 100) LINE
-      KARD = KARD+1
-!
-!   Check whether a comment line and if so copy to buffer.
-      IF (LINE(:1) == 'C' .OR. LINE(:1) == '*' .OR. LINE(:1) ==        &
-      USER .OR. LINE == ' ' .OR. LINE(:1) == 'c'                       &
-                            .OR. LINE(:1) == '!') THEN
-         IF (INTFL) GO TO 2
-         IF (LINE(:1) == 'C' .OR. LINE(:1) == '*'                      &
-         .OR. LINE(:1) == 'c') LINE(:1) = '!'
-         IF (KNTCOM == KKLIM) THEN
-            WRITE (NOUT , '(A72)') (CBUF(72*L5-71:72*L5) , L5 = 1 ,    &
-            KNTCOM) , LINE
-            KNTCOM = 0
-         ELSE IF (SYNERR .OR. .NOT.STAT) THEN
-            WRITE (NOUT , '(A72)') LINE
-         ELSE
-            KNTCOM = KNTCOM+1
-            CBUF(72*KNTCOM-71:72*KNTCOM) = LINE
-         END IF
-         GO TO 2
-      END IF
-!
-!   Some form of embedded comment?
-      NAPO = 0
-      DO L22 = 2, 72
-         IF (LINE(L22:L22)  ==  '''') NAPO = 1 - NAPO
-         IF (L22 == 6) CYCLE
-         IF (LINE(L22:L22)  /=  '!') CYCLE
-         IF (NAPO  /=  0) CYCLE
-         IF (.NOT. INTFL) THEN
-            IF (KNTCOM  <  KKLIM) THEN
-               KNTCOM = KNTCOM +1
-               CBUF(72*KNTCOM-71:72*KNTCOM) =                          &
-                                BLANKV(:L22-1)//LINE(L22:72)
-            ELSE
-               WRITE (NOUT, '(A)') BLANKV(:L22-1)//LINE(L22:72)
-            END IF
-         END IF
-         LINE(L22:72) = ' '
-         IF (LINE  ==  ' ') GO TO 2
-         EXIT
-      END DO
-!
-!   Line is some form of statement; re-read.
-      READ (LINE , '(BN , I5 , A1 , A66)') LAB , CONTIN , FIELD
-      STAT = .TRUE.
-!
-!   Check on syntax and copy to statement buffer
-    3 IF (CONTIN == '0') CONTIN = ' '
-      IF (CONTIN /= ' ') THEN
-         CONTIN = '&'
-         IF (SYNERR) THEN
-            GO TO 6
-         ELSE IF (LENST == 0 .OR. LENST+66 > LEN .OR. LAB /= 0) THEN
-            SYNERR = .TRUE.
-            IF (LENST > 0) THEN
-               IF (LABEL /= 0) THEN
-                  WRITE (NOUT , '(I5, 1X, A66:"&"/(5X, "&", A66:       &
-     &            "&"))') LABEL ,                                      &
-                  (STAMNT(66*L9-65:66*L9) , L9 = 1 , (LENST+65)/66)
-               ELSE
-                  WRITE (NOUT , '(6X, A66:"&"/(5X, "&", A66:"&"        &
-     &            ))') (STAMNT(66*L9-65:66*L9) , L9 = 1 , (LENST+65)/66)
-               END IF
-            END IF
-            IF (LAB /= 0) THEN
-               WRITE (NOUT , 1000) LAB , CONTIN , FIELD
-            ELSE
-               WRITE (NOUT , 1006) CONTIN , FIELD
-            END IF
-            GO TO 1
-         ELSE
-            KNTCON = KNTCON+1
-            STAMNT(LENST+1:LENST+66) = FIELD
-            LENST = LENST+66
-            GO TO 2
-         END IF
-      ELSE IF (KNTCON == 0) THEN
-         IF (LENST /= 0) GO TO 4
-         STAMNT(1:66) = FIELD
-         LENST = 66
-         LABEL = LAB
-         IF (SYNERR) GO TO 4
-         GO TO 2
-      END IF
-      IF (KNTCON > 0) GO TO 6
-!
-!   Have a complete statement ready for processing (the last line
-!   read is still waiting in LINE). The statement now needs to be
-!   identified.
-!   The END statement is a special case - if found it will be copied
-!   and the next program unit processed.
-    4 K1 = 1
-      DO  L1 = 1 , LENST
-         IF (STAMNT(L1:L1) == ' ') CYCLE
-         IF (STAMNT(L1:L1) /= FIN(K1:K1) .AND.                         &
-             STAMNT(L1:L1) /= FINLC(K1:K1)) THEN
-            EXIT
-         ELSE
-            K1 = K1+1
-            IF (K1 > 3 .AND. (L1 >= LENST .OR. STAMNT(L1+1:LENST)      &
-            == ' ')) THEN
-               IF (.NOT.SYNERR) THEN
-                  KNTPU=KNTPU+1
-                  IF (LABEL == 0) THEN
-                     WRITE (NOUT , 1001) FIN, NAME
-                  ELSE
-                     WRITE (NOUT , 1002) LABEL , FIN, NAME
-                  END IF
-               END IF
-!
-!   Set counters for new program unit
-               SYNTAX = SYNTAX .OR. SYNERR
-               KNTDO = 0
-               KNTIF = 0
-               SYNERR = .FALSE.
-               KNTCON = 0
-               LENST = 0
-               IF (KNTCOM /= 0) WRITE (NOUT , '(A72)') (CBUF(72*L5-71: &
-               72*L5) , L5 = 1 , KNTCOM)
-               KNTCOM = 0
-               NAME = ' '
-               NOARG = 0
-               GO TO 3
-            ELSE
-               IF (K1 > 3) EXIT
-            END IF
-         END IF
-      END DO
-!
-!   If syntax error flag set, copy and take next statement
-    6 IF (SYNERR) THEN
-         IF (LAB /= 0) THEN
-            WRITE (NOUT , 1000) LAB , CONTIN , FIELD
-         ELSE
-            WRITE (NOUT , 1006) CONTIN , FIELD
-         END IF
-         LENST = 0
-         GO TO 2
-      END IF
-!
-!   Compress blanks and insert blanks around special characters
-      CALL BLANK( )
-!
-!   Handle Fortran keywords
-      NEWDO = .FALSE.
-      NEWIF = .FALSE.
-      FORM  = .FALSE.
-      ELSEBL = .FALSE.
-      ASSIGN = .FALSE.
-      IF (BLANKS) CALL KEYWORD(ASSIGN, SKIP)
-      IF (SKIP) GO TO 16
-      IF (SYNERR) GO TO 6
-      IF (BLANKS .AND. ASSIGN .AND. LABEL == 0) GO TO 14
-!
-!   Have a valid statement which is not an END line or assignment
-!   Identify statement as    DO
-!                            IF ( ) THEN
-!                            DO terminator
-!                            END IF
-!                            FORMAT
-!                            ELSE or ELSEIF
-!                            none of these.
-      CALL IDENTIFY(IRTCOD)
-      SELECT CASE (IRTCOD)
-         CASE (0)
-            GO TO  14
-!
-!   New DO-loop
-         CASE (1)
-            IF (KNTDO == NEST) GO TO 14
-            NEWDO = .TRUE.
-            LABLDO(KNTDO+1) = LABLNO
-!
-!   End of DO-loop(s)
-         CASE (2)
-            NEND = 0
-            DO  L5 = KNTDO , 1 , -1
-               IF (LABLDO(L5) /= LABEL) EXIT
-               NEND = NEND + 1
-            END DO
-!
-!   Replace CONTINUE by END DO
-      KNTDO = KNTDO - NEND
-      IF (NEND == 1 .AND. LENST == 10 .AND. STAMNT(:LENST) ==          &
-      'CONTINUE  ') THEN
-         STAMNT(:8) = 'END DO  '
-         LENST = 6
-      END IF
-!
-!   Beginning of IF-block
-         CASE (3)
-            NEWIF = .TRUE.
-!
-!   End of IF-block
-         CASE (4)
-            KNTIF = KNTIF-1
-            IF (KNTIF < 0) THEN
-               SYNERR = .TRUE.
-               KNTIF = 0
-            END IF
-!
-!   FORMAT statement
-         CASE (5)
-            FORM =.TRUE.
-!
-!   Beginning of ELSE-block
-         CASE (6)
-            IF (KNTIF  >  0) THEN
-               ELSEBL = .TRUE.
-            ELSE
-              SYNERR = .TRUE.
-            END IF
-      END SELECT
-!
-!   Reformat statements and write
-   14 CALL REFORM (FORM , ELSEBL)
-!
-!   Set variables for next statement
-      IF (NEWDO) KNTDO = KNTDO+1
-      IF (NEWIF) KNTIF = KNTIF+1
-      MXDO = MAX(MXDO , KNTDO)
-      MXIF = MAX(MXIF , KNTIF)
-   16 KNTCON = 0
-      LENST = 0
-      GO TO   3
-!
-!   End of data. Last line must be an END.
-  100 IF (LABEL == 0) WRITE (NOUT , 1001) FIN, NAME
-      IF (LABEL /= 0) WRITE (NOUT , 1002) LABEL , FIN, NAME
-      KNTPU=KNTPU+1
-      IF (INTFL) WRITE (NOUT, '(6X, ''END INTERFACE'')')
-!
-!   Note: if there is a syntax error, continued
-!         statements do not have a trailing &
- 1000 FORMAT(I5 , A1 , A)
- 1001 FORMAT(TR6 , A3 ,TR1, A)
- 1002 FORMAT(I5 , TR1 , A3 ,TR1, A)
- 1006 FORMAT(TR5 , A1 , A66)
-!
-   RETURN
-   END SUBROUTINE PROGRAM_UNITS
-   SUBROUTINE REFORM (FORM , ELSEBL)
-!
-!   Performs reformatting and output of accepted statements
-!
-      USE DATA
-!
-      USE STRUCTURE
-   implicit none
-!
-      INTEGER, PARAMETER :: LLIMIT = LEN-(LEN/66-1)*6
-      CHARACTER(LEN=LEN) :: OUT
-      CHARACTER(LEN = 1) :: AMP
-!
-      LOGICAL, INTENT(IN) :: FORM , ELSEBL
-!
-      integer :: ind, ipnt, l6, l2, l3, l4, lout, idepth, kntap, kadd, &
-                 l5, jpnt
-!
-!   If FORMAT statement, do not indent
-      IF (FORM) GO TO 9
-!
-!   Remove the blanks before commas if no character string
-      IF (BLNKFL .AND. INDEX(STAMNT(:LENST), "'") == 0) THEN
-         IPNT = 1
-         DO
-            IND = INDEX(STAMNT(IPNT:LENST), ' , ')
-            IF (IND == 0) EXIT
-            IND = IPNT + IND - 1
-            STAMNT(IND:IND+2) = ',  '
-            IPNT = IND + 3
-         END DO
-      END IF
-!
-!   Reformat indented statement and write. If reformatting causes it
-!   to exceed LEN characters, it will be copied unchanged.
-      IDEPTH = MIN(KNTDO+KNTIF , MXDPTH)
-      IF (IDEPTH == 0 .AND. .NOT.BLNKFL) GO TO  9
-      IF (ELSEBL) IDEPTH = IDEPTH-1
-      IPNT = 1
-      JPNT = 1
-    1 IF (MOD(IPNT , 66) == 1) THEN
-         IF (IPNT+65 > LEN) GO TO 9
-         OUT(IPNT:IPNT+65) = ' '
-         IPNT = IPNT+IDEPTH*ISHIFT
-      END IF
-!
-!   Find first non-blank character
-      DO  L2 = JPNT , LENST
-         IF (STAMNT(L2:L2) /= ' ') GO TO 3
-      END DO
-      IF (JPNT == 1) THEN
-         SYNERR = .TRUE.
-         GO TO 9
-      ELSE
-         GO TO 10
-      END IF
-!
-!   Find first multiple blank (but not in a character string)
-    3 KNTAP = 0
-      DO  L3 = L2, LENST-1
-         IF (STAMNT(L3:L3) == "'") KNTAP = 1-KNTAP
-         IF (STAMNT(L3:L3+1) == '  ') THEN
-            IF (KNTAP == 0) GO TO 5
-            GO TO 9
-         END IF
-      END DO
-      L3 = LENST
-!
-!   Have section with no multiple blanks. This can be copied to OUT
-!   if there is room on the current line. Otherwise cut the
-!   section after the non-alphanumeric character nearest to the end of
-!   the line, if one exists.
-!   An apostrophe and period are considered to be alphanumeric
-!   characters, in order to hold character strings,
-!   and real and logical constants together;
-!   underscores and dollars are so treated to handle common extensions,
-!   and the ** and // operators and real literal constants are treated.
-    5 KADD = 0
-      IF (L3-L2  <=  66-MOD(IPNT , 66)) GO TO  8
-      DO L4 = 66+L2-MOD(IPNT , 66) , L2 , -1
-         IF (STAMNT(L4:L4) == ' ') GO TO 7
-         IF (LGE(STAMNT(L4:L4) , 'A') .AND. LLE(STAMNT(L4:L4) , 'Z'))  &
-         CYCLE
-         IF(LGE(STAMNT(L4:L4), '0') .AND.                              &
-                  LLE(STAMNT(L4:L4), '9')) CYCLE
-         IF (STAMNT(L4:L4)  ==  "'" .OR.                               &
-         STAMNT(L4:L4)  ==  '_' .OR. STAMNT(L4:L4)  ==  '$' .OR.       &
-         STAMNT(L4:L4)  ==  '.') CYCLE
-         IF (L4 /= LENST) THEN
-            IF (STAMNT(L4:L4+1)  ==  '**' .OR.                         &
-                STAMNT(L4:L4+1)  ==  '//' ) CYCLE
-            IF (L4 /= L2) THEN
-               IF(LGE(STAMNT(L4+1:L4+1), '0') .AND.                    &
-                  LLE(STAMNT(L4+1:L4+1), '9')) THEN
-                  IF (STAMNT(L4-1:L4)  ==  'E+' .OR.                   &
-                      STAMNT(L4-1:L4)  ==  'e+' .OR.                   &
-                      STAMNT(L4-1:L4)  ==  'E-' .OR.                   &
-                      STAMNT(L4-1:L4)  ==  'e-' .OR.                   &
-                      STAMNT(L4-1:L4)  ==  'D+' .OR.                   &
-                      STAMNT(L4-1:L4)  ==  'd+' .OR.                   &
-                      STAMNT(L4-1:L4)  ==  'D-' .OR.                   &
-                      STAMNT(L4-1:L4)  ==  'd-' ) CYCLE
-               END IF
-            END IF
-         END IF
-         IF (LGE(STAMNT(L4:L4) , 'a') .AND. LLE(STAMNT(L4:L4) , 'z'))  &
-         CYCLE
-         GO TO 7
-      END DO
-!
-!   No break character found
-      IF (BLNKFL) GO TO 9
-      L4 = 66-MOD(IPNT , 66)+L2
-!
-!   Cut here
-    7 L3 = L4
-      KADD = 1
-    8 LOUT = IPNT+L3-L2
-      IF (LOUT > LEN) GO TO  9
-      OUT(IPNT:LOUT) = STAMNT(L2:L3)
-      IF (L3 == LENST) GO TO 10
-!
-!   Set pointers for next section of statement
-      IPNT = LOUT+1
-      IF (KADD == 1 .AND. MOD(IPNT , 66) /= 1 .OR. MOD(IPNT , 66)      &
-       >= 60) IPNT = ((IPNT+65)/66)*66+1
-      IF (MOD(IPNT , 66) == 0) IPNT = IPNT+1
-      JPNT = L3+1
-      IF (KADD == 0) JPNT = JPNT+1
-      GO TO   1
-!
-!   Copied statement (if adding 6 cols. to initial line would cause
-!   total length to exceed 2640, must start it in col.1)
-    9 LENST = LEN_TRIM(STAMNT(:LENST))
-      IF (LENST > 66) THEN
-         AMP = '&'
-      ELSE
-         AMP = ' '
-      END IF
-      IF (LABEL /= 0) THEN
-         WRITE (NOUT , 1003) LABEL , STAMNT(:MIN(LENST, 66)), AMP
-      ELSE
-         IF (LENST < LEN-6) THEN
-            WRITE (NOUT , 1004) STAMNT(:MIN(LENST,66)), AMP
-         ELSE
-            WRITE (NOUT , '(A,A1)') STAMNT(:MIN(LENST, 66)), AMP
-         END IF
-      END IF
-      IF (LENST > 66) WRITE (NOUT , 1005)                              &
-     &('&', STAMNT(66*L6-65:66*L6) , L6 = 2 , (LENST+65)/66)
-      GO TO  11
-!
-!   Write OUT to output unit
-   10 LOUT = LEN_TRIM(OUT(:LOUT))
-      IF (LOUT > 66) THEN
-         AMP = '&'
-      ELSE
-         AMP =' '
-      END IF
-      IF (LABEL /= 0) THEN
-         WRITE (NOUT , 1003) LABEL , OUT(:MIN(LOUT, 66)), AMP
-      ELSE
-         WRITE (NOUT , 1004) OUT(:MIN(LOUT, 66)), AMP
-      END IF
-!
-!   An & is required in col. 6 if statement has more than 2412
-!   characters, otherwise total length including cols. 1-6 will
-!   exceed 2640. Also if making interface blocks, in order to be
-!   compatible with both old and new source forms.
-      IF (LOUT > 66) THEN
-         IF (LOUT > LLIMIT .OR. INTFL) THEN
-            AMP = '&'
-         ELSE
-            AMP = ' '
-         END IF
-         WRITE (NOUT , 1005) (AMP , OUT(66*L5-65:66*L5) , L5 = 2 , (   &
-         LOUT+65)/66)
-      END IF
-!
-!   Write any comments following statement
-   11 IF (KNTCOM /= 0) THEN
-         WRITE (NOUT ,'(A72)') (CBUF(72*L5-71:72*L5) , L5 = 1 , KNTCOM)
-         KNTCOM = 0
-      END IF
-!
- 1003 FORMAT(I5 , TR1, A, A)
- 1004 FORMAT(TR6, A, A)
- 1005 FORMAT(TR5 , A , A:'&' )
-!
-   RETURN
-   END SUBROUTINE REFORM
-   SUBROUTINE SPECIAL(L3, NEXT, BUFFER, NKEY, KEYS, KEYSLC,            &
-      LK, FOLLOW)
-!
-!   Special treatment for peculiar Fortran syntax
-!
-      USE STRUCTURE
-!
-      USE STATISTICS
-   implicit none
-!
-      INTEGER, PARAMETER :: NUMLEN = 5
-!
-      CHARACTER(LEN=*), INTENT(OUT) :: BUFFER
-      INTEGER, INTENT(IN) :: NKEY
-      INTEGER, INTENT(IN), dimension(:) :: LK
-      CHARACTER(LEN=*), INTENT(IN), dimension(:) :: KEYS, KEYSLC
-      CHARACTER(LEN=32)     :: NAMEOF
-      CHARACTER(LEN=NUMLEN) :: NUMBER
-!
-      INTEGER, INTENT(IN OUT) :: L3, NEXT
-      LOGICAL, INTENT(IN), dimension(:) :: FOLLOW
-      LOGICAL :: IFASSIGN
-      integer ::         ind,        l20, istar, lparen, napos, ndigit,&
-                 nparen, l10, ilp, isss, limit, name_length
-!
-      IFASSIGN = .FALSE.
-!
-!  Deal with labelled DO WHILE
-      IF (L3 == 13) THEN
-         IND = index(STAMNT(:LENST), 'WHILE')
-         IF (IND == 0) IND = index(STAMNT(:LENST), 'while')
-         IF (IND /= 0) THEN
-            IF(LGE(STAMNT(IND-1:IND-1), '0') .AND.                     &
-               LLE(STAMNT(IND-1:IND-1), '9'))                          &
-               STAMNT(IND:IND+5) = ' WHILE'
-         END IF
-         GO TO 99
-      END IF
-!
-!   Deal with IMPLICIT with non-standard length specifiers
-      IF (L3  ==  25) THEN
-         IF (index(STAMNT(:LENST), '*')  /=  0) THEN
-!
-!   first, CHARACTER*(len)
-   11       IND = index(STAMNT(:LENST), 'CHARACTER *  (')
-            IF (IND  ==  0) IND = index(STAMNT(:LENST),'character *  (')
-            IF (IND /=  0) THEN
-               STAMNT(IND+10:IND+10) = ' '
-               GO TO 11
-            END IF
-!
-!   then, type*nn
-            NPAREN = 0
-            NAPOS = 0
-            DO L10 = 15, LENST
-               IF (STAMNT(L10:L10)  ==  "'") THEN
-                  NAPOS = 1 - NAPOS
-               ELSE IF (STAMNT(L10:L10)  ==  '(') THEN
-                  IF (NAPOS  ==  0) NPAREN = NPAREN + 1
-               ELSE IF (STAMNT(L10:L10)  ==  ')') THEN
-                  IF (NAPOS  ==  0) NPAREN = NPAREN - 1
-               ELSE IF (STAMNT(L10:L10)  ==  '*') THEN
-                  IF (NPAREN  ==  0) THEN
-                     STAMNT(L10:L10+1) = ' ('
-                     ILP = index(STAMNT(L10+2:LENST), '(')
-                     IF (ILP  ==  0) THEN
-                        SYNERR = .TRUE.
-                        GO TO 99
-                     ELSE
-                        STAMNT(L10+ILP:L10+ILP) = ')'
-                     END IF
-                     IF (STAMNT(L10+1:L10+3)  ==  '(4)') THEN
-                        IF (STAMNT(L10-5:L10-5)  /=  'C' .AND.         &
-                            STAMNT(L10-5:L10-5)  /=  'c')              &
-                            STAMNT(L10+1:L10+3) = '   '
-                     ELSE IF (STAMNT(L10-2:L10+3)  ==  'X  (8)' .OR.   &
-                             STAMNT(L10-2:L10+3)  ==  'x  (8)')THEN
-                        STAMNT(L10+1:L10+3) = '   '
-                     END IF
-
-                  END IF
-               END IF
-            END DO
-         END IF
-         GO TO 99
-      END IF
-!
-!   An ASSIGN label must be followed by a blank and a * specifier
-!   converted to (...)
-      IF(L3 == 1 .AND. STAMNT(:7 )  ==  'ASSIGN '     .OR.             &
-         L3 == 5 .AND. STAMNT(:11)  ==  'CHARACTER *' .OR.             &
-         L3 == 8 .AND. STAMNT(:9 )  ==  'COMPLEX *'   .OR.             &
-         L3 == 27.AND. STAMNT(:9 )  ==  'INTEGER *'   .OR.             &
-         L3 == 29.AND. STAMNT(:9 )  ==  'LOGICAL *'   .OR.             &
-         L3 == 36.AND. STAMNT(:6 )  ==  'REAL *'          ) THEN
-         IF (L3 < 8) THEN
-            ISSS = L3+7
-         ELSE IF (L3 < 30) THEN
-            ISSS = 10
-         ELSE
-            ISSS = 7
-         END IF
-!
-!   Extract the length parameter
-         NDIGIT = 1
-         NUMBER = '  '
-         DO L20 = ISSS, LENST
-            IF(STAMNT(L20:L20)  ==  ' ') CYCLE
-            NUMBER(:1) = STAMNT(L20:L20)
-            IF(LGE(STAMNT(L20:L20),'0') .AND. LLE(STAMNT(L20:L20),'9') &
-            ) GO TO 21
-            GO TO 1
-         END DO
-         SYNERR = .TRUE.
-         GO TO 99
-   21    DO NEXT = L20+1, LENST
-            IF(STAMNT(NEXT:NEXT)  ==  ' ') CYCLE
-            IF(LLT(STAMNT(NEXT:NEXT), '0') .OR. LGT(STAMNT(NEXT:NEXT), &
-            '9')) GO TO 19
-            NDIGIT = NDIGIT + 1
-            IF (NDIGIT  >  NUMLEN) THEN
-               SYNERR = .TRUE.
-               GO TO 99
-            END IF
-            NUMBER(NDIGIT:NDIGIT) = STAMNT(NEXT:NEXT)
-         END DO
-         SYNERR = .TRUE.
-         GO TO 99
-      END IF
-      GO TO 1
-!
-!   Insert the blank or parentheses
-   19 IF (LENST >= LEN-1) THEN
-         OVFLW = .TRUE.
-         GO TO 99
-      END IF
-      BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
-      IF (L3 == 1) THEN
-         LENST = LENST+2
-         STAMNT(NEXT:NEXT+3) = ' TO '
-         STAMNT(NEXT+4:LENST) = BUFFER(NEXT+2:LENST-2)
-      ELSE
-         LENST = LENST+1
-         STAMNT(NEXT:NEXT) = ' '
-         STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
-         IF (L3 /= 5.AND. NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '4') THEN
-            STAMNT(NEXT-4:NEXT-1) = '    '
-         ELSE IF (L3 == 8.AND.NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '8') &
-         THEN
-            STAMNT(NEXT-4:NEXT-1) = '    '
-         ELSE
-            STAMNT(NEXT-3-NDIGIT:NEXT-1) = '('//NUMBER(:NDIGIT)//')'
-         END IF
-      END IF
-      GO TO 2
-!
-!   Handle (*) case
-    1 IF(L3 == 5 .AND. STAMNT(:18)  ==  'CHARACTER *  ( * )') THEN
-         NEXT = 19
-         STAMNT(11:11) = ' '
-      END IF
-!
-!   IF statement may be followed by a keyword
-    2 IF (L3  ==  24 ) THEN
-         LPAREN = 1
-         NAPOS = 0
-         DO NEXT = 5, LENST
-            IF (STAMNT(NEXT:NEXT)  ==  "'") NAPOS = 1 - NAPOS
-            IF (NAPOS  ==  1) CYCLE
-            IF (STAMNT(NEXT:NEXT)  ==  '(' ) LPAREN = LPAREN+1
-            IF (STAMNT(NEXT:NEXT)  ==  ')' ) LPAREN = LPAREN-1
-            IF (LPAREN  ==  0) GO TO 5
-         END DO
-         GO TO 99
-    5    NEXT = NEXT+1
-         DO L3 = 1, NKEY
-            IF (FOLLOW(L3) .AND.(STAMNT(NEXT+1:NEXT+LK(L3)) == KEYS(L3)&
-                          .OR. STAMNT(NEXT+1:NEXT+LK(L3)) == KEYSLC(L3)&
-             )) THEN
-               NEXT = NEXT+LK(L3)+1
-               IF(L3 == 1) IFASSIGN = .TRUE.
-               GO TO 9
-            END IF
-         END DO
-      ELSE
-!
-! Typed function
-         IF(STAMNT(NEXT+1:NEXT+8)  ==  'FUNCTION'  .OR.                &
-            STAMNT(NEXT+1:NEXT+8)  ==  'function') THEN
-            NEXT = NEXT+9
-            call name_of(nameof, stamnt(next:lenst), name_length)
-            NAME = 'FUNCTION'//NAMEOF(:name_length)
-            L3 = 22
-!
-!   Deal with any *
-            LIMIT = index(STAMNT(:LENST), '(')
-            IF (LIMIT /= 0) THEN
-               ISTAR = index(STAMNT(:LIMIT), '*')
-               IF (ISTAR  /=  0) THEN
-                  NDIGIT = LIMIT - ISTAR -3
-                  IF (NDIGIT  >  NUMLEN) THEN
-                     SYNERR = .TRUE.
-                     GO TO 99
-                  END IF
-                  NUMBER(:NDIGIT) = STAMNT(ISTAR+2:LIMIT-2)
-                  STAMNT(NEXT-5+NDIGIT:LIMIT-2) =                      &
-                                      'FUNCTION'//NAME(10:ISTAR-NEXT+8)
-                  STAMNT(NEXT-8:NEXT-6+NDIGIT)  =                      &
-                                      '('//NUMBER(:NDIGIT)//') '
-                  IF (NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '4') THEN
-                     STAMNT(NEXT-8:NEXT-5) = '    '
-                  ELSE IF (NDIGIT  ==  1 .AND. NUMBER(:1)  ==  '8'.AND.&
-                     (STAMNT(7:7) == 'X'.OR.STAMNT(7:7) == 'x')) THEN
-                     STAMNT(NEXT-8:NEXT-5) = '    '
-                  END IF
-                  NEXT = NEXT + 3 + NDIGIT
-               END IF
-            ELSE
-               SYNERR = .TRUE.
-               GO TO 99
-            END IF
-            GO TO 9
-         END IF
-      END IF
-      GO TO 99
-!
-!   Insert the blank
-    9 IF (LENST >= LEN-2) THEN
-         OVFLW = .TRUE.
-         GO TO 99
-      END IF
-      BUFFER(NEXT:LENST) = STAMNT(NEXT:LENST)
-      LENST = LENST+1
-      STAMNT(NEXT:NEXT) = ' '
-      STAMNT(NEXT+1:LENST) = BUFFER(NEXT:LENST-1)
-!
-!   ASSIGN may follow IF
-      IF(.NOT.IFASSIGN) GO TO 99
-      NEXT = index(STAMNT(:LENST), 'TO')
-      IF (NEXT == 0) NEXT = index(STAMNT(:LENST), 'to')
-      IF(NEXT == 0) THEN
-         SYNERR = .TRUE.
-         GO TO 99
-      ELSE
-         LENST = LENST+2
-         STAMNT(NEXT:NEXT+3) = ' TO '
-         STAMNT(NEXT+4:LENST) = BUFFER(NEXT+1:LENST-3)
-      END IF
-99 RETURN
-   END SUBROUTINE SPECIAL
-   SUBROUTINE START( )
-!
-!   To prepare for PROGRAM_UNITS
-!
-      USE DATA
-   implicit none
-      CHARACTER(LEN=16) :: NAME
-!
-!   Prompt for interactive use
-      WRITE (*,'(" Type name of file, shift, max. indent level, T or F &
-        &for blank treatment,",/ " T or F for interface blocks only.")')
-      WRITE (*,'(" For simple use type only the name of the file ",    &
-            &"followed by a slash (/) and RETURN.",/                   &
-            &" Note that the name should be given WITHOUT extension!")')
-!
-!   Does standard input unit contain an input record
-      NIN = 11
-      NOUT = 12
-      ISHIFT = 0
-      MXDPTH = 0
-      BLANKS = .FALSE.
-      INTBFL = .FALSE.
-      READ (* , * , END = 1 , ERR = 1) NAME, ISHIFT , MXDPTH ,         &
-      BLANKS, INTBFL
-!
-!   If record present, check input values are reasonable
-      ISHIFT = MIN(MAX(ISHIFT , 0) , 10)
-      MXDPTH = MIN(MAX(MXDPTH , 0) , 36/MAX(ISHIFT,1))
-      IF (INTBFL.AND..NOT.BLANKS) WRITE (*, '('' Interface block proces&
-     &sing cancelled as blank processing not requested'')')
-      INTBFL = BLANKS.AND.INTBFL
-      GO TO  2
-!
-!   Set default values
-    1 ISHIFT = 3
-      MXDPTH = 10
-      BLANKS = .TRUE.
-      INTBFL = .FALSE.
-      NAME = 'name'
-    2 OPEN (UNIT=NIN, FILE=TRIM(NAME)//'.f', ACTION='READ')
-      OPEN (UNIT=NOUT, FILE=TRIM(NAME)//'.f90', ACTION='WRITE')
-!
-!   Print values to be used
-      Write (*,'(" Loop bodies will be indented by",I3/                &
-     &           " Maximum indenting level is     ",I3)')              &
-              ISHIFT , MXDPTH
-      IF (BLANKS) WRITE (*,                                            &
-      '(" Significant blank proccessing requested")')
-      IF (INTBFL) WRITE (*,                                            &
-      '('' Only interface blocks will be produced'')')
-      IF (INTBFL) WRITE (NOUT, '(6X, ''INTERFACE'')')
-!
-      CALL SYSTEM_CLOCK(TIME0)
-      RETURN
-   END SUBROUTINE START
-   SUBROUTINE TERMINATE( )
-!
-!   To print the final summary
-!
-      USE STATISTICS
-      USE DATA
-   implicit none
-!
-      integer :: itick, itime
-!
-      CALL SYSTEM_CLOCK(ITIME, ITICK)
-      IF (ITICK /= 0)                                                  &
-      WRITE (*,'(" Processing complete in ", F7.3, " seconds")')       &
-            REAL(ITIME-TIME0)/REAL(ITICK)
-      WRITE (*,'(" Maximum depth of DO-loop nesting ",I3/              &
-     &           " Maximum depth of IF-block nesting",I3/              &
-     &" No. of lines read  ",I17/" No. of program units read   ",I8/   &
-     &           " Global syntax error flag",L12)')                    &
-                MXDO , MXIF , KARD , KNTPU , SYNTAX
-!
-      IF (OVFLW) WRITE(*,  '(" At least one statement was too long to h&
-     &ave a necessary blank added")')
-      IF (NONSTD) WRITE (*,  '(" At least one statement began with a no&
-     &n-standard keyword")')
-!
-    RETURN
-    END SUBROUTINE TERMINATE
-   END MODULE ALL_PROCEDURES
-   PROGRAM CONVERT
-   USE ALL_PROCEDURES
-   implicit none
-!
-!   Initialize
-      CALL START( )
-!
-!   Process the lines of program units
-      CALL PROGRAM_UNITS( )
-!
-!   Print some statistics
-      CALL TERMINATE( )
-      STOP
-   END PROGRAM CONVERT
diff --git a/wrfv2_fire/external/fftpack/f90split.f90 b/wrfv2_fire/external/fftpack/f90split.f90
new file mode 100644
index 00000000..4d3a5dda
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/f90split.f90
@@ -0,0 +1,1666 @@
+program main
+
+!*****************************************************************************80
+!
+!! MAIN is the main program for F90SPLIT.
+!
+!  Discussion:
+!
+!    F90SPLIT splits the modules of a FORTRAN file into separate files.
+!
+!    A "module" is a blockdata, function, module, program, subroutine,
+!    recursive function or recursive subroutine program subunit.
+!
+!    The command
+!
+!      f90split extract.f90
+!
+!    processes the file EXTRACT.F90 line by line.  Each program subunit
+!    that is found is written to a separate file whose name is derived
+!    from the name of the program subunit.  If the program subunit does
+!    not have a name, a default name is assigned.
+!
+!    The program should be able to split multiple files with a
+!    single command, as in:
+!
+!      f90split *.f90
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    23 August 2011
+!
+!  Author:
+!
+!    John Burkardt
+!
+  implicit none
+
+  integer ( kind = 4 ) iarg
+  integer ( kind = 4 ) iargc
+  character ( len = 255 ) input_file
+  integer ( kind = 4 ) numarg
+
+  call timestamp ( )
+
+  write ( *, '(a)' ) ' '
+  write ( *, '(a)' ) 'F90SPLIT:'
+  write ( *, '(a)' ) '  FORTRAN90 version'
+  write ( *, '(a)' ) '  Split a FORTRAN90 program, so that each'
+  write ( *, '(a)' ) '  unit is in its own file.'
+!
+!  Count the number of command line arguments.
+!
+  numarg = iargc ( )
+
+  if ( numarg < 1 ) then
+
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'F90SPLIT:'
+    write ( *, '(a)' ) '  What is the name of the input file?'
+    read ( *, '(a)' ) input_file
+
+    if ( input_file == ' ' ) then
+      stop
+    end if
+
+    numarg = 1
+    call handle ( input_file )
+
+  else
+
+    do iarg = 1, numarg
+
+      call getarg ( iarg, input_file )
+
+      call handle ( input_file )
+
+    end do
+
+  end if
+
+  write ( *, '(a)' ) ' '
+  write ( *, '(a,i4)' ) '  Number of files handled = ', numarg
+!
+!  Terminate.
+!
+  write ( *, '(a)' ) ' '
+  write ( *, '(a)' ) 'F90SPLIT:'
+  write ( *, '(a)' ) '  Normal end of execution.'
+
+  write ( *, '(a)' ) ' '
+  call timestamp ( )
+
+  stop
+end
+subroutine handle ( input_file )
+
+!*****************************************************************************80
+!
+!! HANDLE handles one file.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    23 August 2011
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) INPUT_FILE, the name of the file to
+!    be split up.
+!
+  implicit none
+
+  integer ( kind = 4 ) duplicate_num
+  character ( len = 255 ) extension
+  logical f90_line_is_end
+  integer ( kind = 4 ) i
+  character ( len = 255 ) input_file
+  integer ( kind = 4 ) input_unit
+  integer ( kind = 4 ) ios
+  integer ( kind = 4 ) j
+  character ( len = 255 ) line
+  integer ( kind = 4 ) line_length
+  integer ( kind = 4 ) line_length_loc
+  integer ( kind = 4 ) line_length_max
+  integer ( kind = 4 ) line_num
+  integer ( kind = 4 ) module_num
+  logical no_name
+  character ( len = 255 ) no_name_file
+  integer ( kind = 4 ) no_name_line_last
+  integer ( kind = 4 ) no_name_line_num
+  logical no_name_open
+  integer ( kind = 4 ) no_name_unit
+  logical output_exists
+  character ( len = 255 ) output_file
+  logical output_open
+  integer ( kind = 4 ) output_unit
+
+  duplicate_num = 0
+!
+!  Pick off the extension of the input file.
+!
+  call file_ext ( input_file, i, j )
+
+  if ( i == 0 ) then
+    extension = '.f'
+  else if ( 1 < i ) then
+    extension = input_file(i-1:j)
+  else
+    extension = ' '
+  end if
+!
+!  Open the file.
+!
+  call get_unit ( input_unit )
+
+  open ( unit = input_unit, file = input_file, status = 'old', &
+    iostat = ios )
+
+  if ( ios /= 0 ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'F90SPLIT - Fatal error!'
+    write ( *, '(a)' ) &
+      '  Could not open the input file "' // trim ( input_file ) // '".'
+    stop
+  end if
+
+  line_num = 0
+  no_name_line_last = -1
+  no_name_line_num = 0
+  module_num = 0
+
+  output_open = .false.
+
+  no_name_open = .false.
+  no_name = .true.
+  no_name_file = 'no_name.f90'
+
+  line_length_max = -1;
+  line_length_loc = -1;
+
+  do
+
+    read ( input_unit, '(a)', iostat = ios ) line
+
+    if ( ios /= 0 ) then
+      exit
+    end if
+
+    line_num = line_num + 1
+
+    line_length = len_trim ( line )
+    if ( line_length_max < line_length ) then
+      line_length_max = line_length
+      line_length_loc = line_num
+    end if
+!
+!  If we don't have a module name, then it's not clear what to do.
+!  My vote is to discard the information for now.
+!
+!  It's important to check whether the next line marks the beginning of
+!  a named module.
+!
+    if ( no_name ) then
+
+      call f90_line_is_begin ( line, output_file )
+
+      if ( output_file /= ' ' ) then
+
+        no_name = .false.
+
+        module_num = module_num + 1
+
+        call s_cat ( output_file, extension, output_file )
+
+        write ( *, '(a)' ) trim ( output_file )
+
+        call get_unit ( output_unit )
+
+        open ( unit = output_unit, file = output_file, &
+          status = 'replace', iostat = ios )
+
+        output_open = .true.
+
+      end if
+
+    end if
+!
+!  If an output file is not currently open...
+!
+    if ( .not. output_open ) then
+
+      call f90_line_is_begin ( line, output_file )
+
+      if ( output_file == ' ' ) then
+
+        no_name = .true.
+
+        if ( .not. no_name_open ) then
+          write ( *, '(a)' ) trim ( no_name_file )
+          call get_unit ( no_name_unit )
+          open ( unit = no_name_unit, file = no_name_file, status = 'replace', &
+            iostat = ios )
+          no_name_open = .true.
+        end if
+
+      else
+
+        module_num = module_num + 1
+
+        no_name = .false.
+        call s_cat ( output_file, extension, output_file )
+        call s_low ( output_file )
+        write ( *, '(a)' ) trim ( output_file )
+!
+!  Check for duplicates
+!
+        inquire ( file = output_file, exist = output_exists )
+
+        if ( output_exists ) then
+          duplicate_num = duplicate_num + 1
+          write ( *, '(a)' ) '  Duplicate module = "' &
+            // trim ( output_file ) // '".'
+        end if
+
+        call get_unit ( output_unit )
+
+        open ( unit = output_unit, file = output_file, status = 'replace', &
+          iostat = ios )
+
+        output_open = .true.
+
+      end if
+
+    end if
+!
+!  Write the line.
+!
+    if ( output_open ) then
+      write ( output_unit, '(a)' ) trim ( line )
+    else
+      write ( no_name_unit, '(a)' ) trim ( line )
+      no_name_line_last = line_num
+      no_name_line_num = no_name_line_num + 1
+    end if
+
+    if ( f90_line_is_end ( line ) ) then
+      close ( unit = output_unit )
+      output_open = .false.
+      no_name = .false.
+    end if
+
+  end do
+!
+!  Close the NO_NAME file, and delete it.
+!  Rationale:
+!
+!    1) I don't write main programs without a PROGRAM statement.
+!    2) I don't stick blank or comment lines between routines.
+!    3) The stupid ALPHA fortran compiler will FAIL if given
+!       a file to compile that contains only blanks and comments!
+!
+  if ( no_name_open ) then
+    close ( unit = no_name_unit, status = 'delete' )
+    no_name_open = .false.
+  end if
+
+  close ( unit = input_unit )
+
+  write ( *, '(a)' ) ' '
+  write ( *, '(a)' ) 'F90SPLIT:'
+  write ( *, '(a)' ) '  Reached end of ' // trim ( input_file )
+  write ( *, '(a,i8)' ) '  Lines read:              ', line_num
+  write ( *, '(a,i8)' ) '  Longest line length:     ', line_length_max
+  write ( *, '(a,i8)' ) '  Longest line location:   ', line_length_loc
+  write ( *, '(a,i8)' ) '  Named modules created:   ', module_num
+  write ( *, '(a,i8)' ) '  Lines sent to NO_NAME:   ', no_name_line_num
+  if ( 0 < no_name_line_num ) then
+    write ( *, '(a,i8)' ) '  Last NO_NAME line:       ', no_name_line_last
+  end if
+  write ( *, '(a,i8)' ) '  Duplicate modules found: ', duplicate_num
+
+  return
+end
+subroutine ch_cap ( c )
+
+!*****************************************************************************80
+!
+!! CH_CAP capitalizes a single character.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    19 July 1998
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input/output, character C, the character to capitalize.
+!
+  implicit none
+
+  character c
+  integer ( kind = 4 ) itemp
+
+  itemp = ichar ( c )
+
+  if ( 97 <= itemp .and. itemp <= 122 ) then
+    c = char ( itemp - 32 )
+  end if
+
+  return
+end
+subroutine ch_low ( ch )
+
+!*****************************************************************************80
+!
+!! CH_LOW lowercases a single character.
+!
+!  Discussion:
+!
+!    Instead of CHAR and ICHAR, we now use the ACHAR and IACHAR functions,
+!    which guarantee the ASCII collating sequence.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    19 July 1998
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input/output, character CH, the character to be lowercased.
+!
+  implicit none
+
+  character              ch
+  integer   ( kind = 4 ) i
+
+  i = iachar ( ch )
+
+  if ( 65 <= i .and. i <= 90 ) then
+    ch = achar ( i + 32 )
+  end if
+
+  return
+end
+subroutine digit_to_ch ( digit, c )
+
+!*****************************************************************************80
+!
+!! DIGIT_TO_CH returns the character representation of a decimal digit.
+!
+!  Example:
+!
+!    DIGIT   C
+!    -----  ---
+!      0    '0'
+!      1    '1'
+!    ...    ...
+!      9    '9'
+!     17    '*'
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    04 August 1999
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) DIGIT, the digit value between 0 and 9.
+!
+!    Output, character C, the corresponding character, or '*' if DIGIT
+!    was illegal.
+!
+  implicit none
+
+  character              c
+  integer   ( kind = 4 ) digit
+
+  if ( 0 <= digit .and. digit <= 9 ) then
+
+    c = char ( digit + 48 )
+
+  else
+
+    c = '*'
+
+  end if
+
+  return
+end
+subroutine f90_line_is_begin ( line, name )
+
+!*****************************************************************************80
+!
+!! F90_LINE_IS_BEGIN determines if a line begins a FORTRAN90 routine.
+!
+!  Discussion:
+!
+!    This routine will NOT properly handle complicated function
+!    statements such as:
+!
+!      integer ( kind = 4 )*2 function fred ( a, b )
+!      recursive real function bob ( c )
+!
+!    For that matter, if you are so bold as to have a variable whose
+!    name is "PROGRAM", "FUNCTION" or a similar "keyword", then this
+!    routine will incorrectly treat lines such as:
+!
+!      function = function + 1
+!
+!    The routine will also fail if the initial line of the module
+!    extends over more than one line:
+!
+!      recursive double precision fun&
+!      ction naomi ( x )
+!
+!    or if you use some nonstandard keyword such as
+!
+!      parallel function magoo ( y )
+!
+!    14 December 2002: This routine was, for convenience and style,
+!    lowercasing the line and hence the output name.  I now find that
+!    I want to preserve case, so I modified the routine.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    12 January 2011
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) LINE, a line of text.
+!
+!    Output, character ( len = * ) NAME, the name of the module, if this
+!    line begins a module, and ' ' otherwise.
+!
+  implicit none
+
+  integer ( kind = 4 ) i
+  character ( len = * ) line
+  character ( len = 255 ) line2
+  character ( len = * ) name
+  logical s_eqi
+
+  name = ' '
+
+  line2 = line
+  call s_blank_delete ( line2 )
+
+  if ( s_eqi ( line2(1:9), 'blockdata' ) ) then
+    if ( line2(10:) == ' ' ) then
+      name = 'blockdata'
+    else
+      call s_before_ss_copy ( line2(10:), '(', name )
+    end if
+  else if ( s_eqi ( line2(1:17), 'characterfunction' ) ) then
+    call s_before_ss_copy ( line2(18:), '(', name )
+  else if ( s_eqi ( line2(1:15), 'complexfunction' ) ) then
+    call s_before_ss_copy ( line2(16:), '(', name )
+  else if ( s_eqi ( line2(1:23), 'doubleprecisionfunction' ) ) then
+    call s_before_ss_copy ( line2(24:), '(', name )
+  else if ( s_eqi ( line2(1:8), 'function' ) ) then
+    call s_before_ss_copy ( line2(9:), '(', name )
+  else if ( s_eqi ( line2(1:15), 'integerfunction' ) ) then
+    call s_before_ss_copy ( line2(16:), '(', name )
+  else if ( s_eqi ( line2(1:15), 'logicalfunction' ) ) then
+    call s_before_ss_copy ( line2(16:), '(', name )
+  else if ( s_eqi ( line2(1:6), 'module' ) ) then
+    call s_before_ss_copy ( line2(7:), '(', name )
+  else if ( s_eqi ( line2(1:7), 'program' ) ) then
+    call s_before_ss_copy ( line2(8:), '(', name )
+  else if ( s_eqi ( line2(1:12), 'realfunction' ) ) then
+    call s_before_ss_copy ( line2(13:), '(', name )
+  else if ( s_eqi ( line2(1:17), 'recursivefunction' ) ) then
+    call s_before_ss_copy ( line2(18:), '(', name )
+  else if ( s_eqi ( line2(1:10), 'subroutine' ) ) then
+    call s_before_ss_copy ( line2(11:), '(', name )
+  else if ( s_eqi ( line2(1:19), 'recursivesubroutine' ) ) then
+    call s_before_ss_copy ( line2(20:), '(', name )
+  end if
+!
+!  In some "clever" cases, people write the name of the routine
+!  on one line, continue with an ampersand, and the rest of the
+!  routine follows.
+!
+!  I really should be reading the logical line, not the literal
+!  line, but for now, let me just chop off trailing ampersands.
+!
+  i = index ( name, '&' )
+
+  if ( i /= 0 ) then
+    name(i:i) = ' '
+  end if
+
+  return
+end
+function f90_line_is_end ( line )
+
+!*****************************************************************************80
+!
+!! F90_LINE_IS_END determines if a line ends a FORTRAN90 module.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    12 July 2000
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) LINE, a line of text.
+!
+!    Output, logical F90_LINE_IS_END, TRUE if the line ends a module.
+!
+  implicit none
+
+  logical f90_line_is_end
+  character ( len = * ) line
+  character ( len = 255 ) line2
+
+  f90_line_is_end = .false.
+
+  line2 = line
+
+  call s_low ( line2 )
+
+  call s_blank_delete ( line2 )
+
+  if ( &
+    line2       == 'end' .or. &
+    line2(1:12) == 'endblockdata' .or. &
+    line2(1:11) == 'endfunction' .or. &
+    line2(1:9)  == 'endmodule' .or. &
+    line2(1:10) == 'endprogram' .or. &
+    line2(1:13) == 'endsubroutine' .or. &
+    line2(1:4)  == 'end!' ) then
+
+    f90_line_is_end = .true.
+
+  end if
+
+  return
+end
+subroutine file_ext ( file_name, i, j )
+
+!*****************************************************************************80
+!
+!! FILE_EXT determines the "extension" of a file name.
+!
+!  Discussion:
+!
+!    The "extension" of a filename is the string of characters
+!    that appears after the LAST period in the name.  A file
+!    with no period, or with a period as the last character
+!    in the name, has a "null" extension.
+!
+!    Blanks are unusual in filenames.  This routine ignores all
+!    trailing blanks, but will treat initial or internal blanks
+!    as regular characters acceptable in a file name.
+!
+!  Example:
+!
+!    FILE_NAME  I  J
+!
+!    bob.for    5  7
+!    N.B.C.D    7  7
+!    Naomi.     0  0
+!    Arthur     0  0
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    07 February 2000
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) FILE_NAME, a file name to be examined.
+!
+!    Output, integer ( kind = 4 ) I, J, the indices of the first and last 
+!    characters in the file extension.
+!
+!    If at least one period occurs in the filename, and at least one
+!    nonblank character follows that period, then I will be the index
+!    of the first character after the period, and J the index of the
+!    last nonblank character after the period.  The extension is
+!    therefore equal to FILE_NAME(I:J).
+!
+!    Otherwise, I and J will be returned as 0, indicating that the file
+!    has no extension.
+!
+  implicit none
+
+  character ( len = * ) file_name
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) s_index_last
+
+  i = s_index_last ( file_name, '.' )
+
+  if ( i /= 0 ) then
+
+    j = len_trim ( file_name )
+
+    if ( i == j ) then
+      i = 0
+      j = 0
+    else
+      i = i + 1
+    end if
+
+  else
+
+    j = 0
+
+  end if
+
+  return
+end
+subroutine get_unit ( iunit )
+
+!*****************************************************************************80
+!
+!! GET_UNIT returns a free FORTRAN unit number.
+!
+!  Discussion:
+!
+!    A "free" FORTRAN unit number is a value between 1 and 99 which
+!    is not currently associated with an I/O device.  A free FORTRAN unit
+!    number is needed in order to open a file with the OPEN command.
+!
+!    If IUNIT = 0, then no free FORTRAN unit could be found, although
+!    all 99 units were checked (except for units 5, 6 and 9, which
+!    are commonly reserved for console I/O).
+!
+!    Otherwise, IUNIT is a value between 1 and 99, representing a
+!    free FORTRAN unit.  Note that GET_UNIT assumes that units 5 and 6
+!    are special, and will never return those values.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    18 September 2005
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Output, integer ( kind = 4 ) IUNIT, the free unit number.
+!
+  implicit none
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ios
+  integer ( kind = 4 ) iunit
+  logical lopen
+
+  iunit = 0
+
+  do i = 1, 99
+
+    if ( i /= 5 .and. i /= 6 .and. i /= 9 ) then
+
+      inquire ( unit = i, opened = lopen, iostat = ios )
+
+      if ( ios == 0 ) then
+        if ( .not. lopen ) then
+          iunit = i
+          return
+        end if
+      end if
+
+    end if
+
+  end do
+
+  return
+end
+subroutine s_before_ss_copy ( s, ss, s2 )
+
+!*****************************************************************************80
+!
+!! S_BEFORE_SS_COPY copies a string up to a given substring.
+!
+!  Discussion:
+!
+!    S and S2 can be the same object, in which case the string is
+!    overwritten by a copy of itself up to the substring, followed
+!    by blanks.
+!
+!  Example:
+!
+!    Input:
+!
+!      S = 'ABCDEFGH'
+!      SS = 'EF'
+!
+!    Output:
+!
+!      S2 = 'ABCD'.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    21 November 1999
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) S, the string to be copied.
+!
+!    Input, character ( len = * ) SS, the substring before which the copy stops.
+!
+!    Output, character ( len = * ) S2, the copied portion of S.
+!
+  implicit none
+
+  integer ( kind = 4 ) last
+  integer ( kind = 4 ) last_s2
+  character ( len = * ) s
+  character ( len = * ) s2
+  character ( len = * ) ss
+!
+!  Find the first occurrence of the substring.
+!
+  last = index ( s, ss )
+!
+!  If the substring doesn't occur at all, behave as though it begins
+!  just after the string terminates.
+!
+!  Now redefine LAST to point to the last character to copy before
+!  the substring begins.
+!
+  if ( last == 0 ) then
+    last = len ( s )
+  else
+    last = last - 1
+  end if
+!
+!  Now adjust again in case the copy holder is "short".
+!
+  last_s2 = len ( s2 )
+
+  last = min ( last, last_s2 )
+!
+!  Copy the beginning of the string.
+!  Presumably, compilers now understand that if LAST is 0, we don't
+!  copy anything.
+!  Clear out the rest of the copy.
+!
+  s2(1:last) = s(1:last)
+  s2(last+1:last_s2) = ' '
+
+  return
+end
+subroutine s_blank_delete ( s )
+
+!*****************************************************************************80
+!
+!! S_BLANK_DELETE removes blanks from a string, left justifying the remainder.
+!
+!  Discussion:
+!
+!    All TAB characters are also removed.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    26 July 1998
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input/output, character ( len = * ) S, the string to be transformed.
+!
+  implicit none
+
+  character c
+  integer ( kind = 4 ) iget
+  integer ( kind = 4 ) iput
+  character ( len = * ) s
+  character TAB
+
+  TAB = char ( 9 )
+  iput = 0
+
+  do iget = 1, len ( s )
+
+    c = s(iget:iget)
+
+    if ( c /= ' ' .and. c /= TAB ) then
+      iput = iput + 1
+      s(iput:iput) = c
+    end if
+
+  end do
+
+  s(iput+1:) = ' '
+
+  return
+end
+subroutine s_blanks_delete ( s )
+
+!*****************************************************************************80
+!
+!! S_BLANKS_DELETE replaces consecutive blanks by one blank.
+!
+!  Discussion:
+!
+!    The remaining characters are left justified and right padded with blanks.
+!    TAB characters are converted to spaces.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    26 July 1998
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input/output, character ( len = * ) S, the string to be transformed.
+!
+  implicit none
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) nchar
+  character newchr
+  character oldchr
+  character ( len = * ) s
+  character TAB
+
+  nchar = len ( s )
+  TAB = char ( 9 )
+  j = 0
+  newchr = ' '
+
+  do i = 1, nchar
+
+    oldchr = newchr
+    newchr = s(i:i)
+
+    if ( newchr == TAB ) then
+      newchr = ' '
+    end if
+
+    s(i:i) = ' '
+
+    if ( oldchr /= ' ' .or. newchr /= ' ' ) then
+      j = j + 1
+      s(j:j) = newchr
+    end if
+
+  end do
+
+  return
+end
+subroutine s_cap ( s )
+
+!*****************************************************************************80
+!
+!! S_CAP replaces any lowercase letters by uppercase ones in a string.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    16 May 1999
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input/output, character ( len = * ) S, the string to be transformed.
+!
+  implicit none
+
+  character c
+  integer ( kind = 4 ) i
+  character ( len = * ) s
+
+  do i = 1, len ( s )
+
+    c = s(i:i)
+    call ch_cap ( c )
+    s(i:i) = c
+
+  end do
+
+  return
+end
+subroutine s_cat ( s1, s2, s3 )
+
+!*****************************************************************************80
+!
+!! S_CAT concatenates two strings to make a third string.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    11 May 2000
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) S1, the "prefix" string.
+!
+!    Input, character ( len = * ) S2, the "postfix" string.
+!
+!    Output, character ( len = * ) S3, the string made by
+!    concatenating S1 and S2, ignoring any trailing blanks.
+!
+  implicit none
+
+  character ( len = * ) s1
+  character ( len = * ) s2
+  character ( len = * ) s3
+
+  s3 = trim ( s1 ) // trim ( s2 )
+
+  return
+end
+function s_eqi ( s1, s2 )
+
+!*****************************************************************************80
+!
+!! S_EQI is a case insensitive comparison of two strings for equality.
+!
+!  Example:
+!
+!    S_EQI ( 'Anjana', 'ANJANA' ) is .TRUE.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    14 April 1999
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) S1, S2, the strings to compare.
+!
+!    Output, logical S_EQI, the result of the comparison.
+!
+  implicit none
+
+  character c1
+  character c2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) len1
+  integer ( kind = 4 ) len2
+  integer ( kind = 4 ) lenc
+  logical s_eqi
+  character ( len = * ) s1
+  character ( len = * ) s2
+
+  len1 = len ( s1 )
+  len2 = len ( s2 )
+  lenc = min ( len1, len2 )
+
+  s_eqi = .false.
+
+  do i = 1, lenc
+
+    c1 = s1(i:i)
+    c2 = s2(i:i)
+    call ch_cap ( c1 )
+    call ch_cap ( c2 )
+
+    if ( c1 /= c2 ) then
+      return
+    end if
+
+  end do
+
+  do i = lenc + 1, len1
+    if ( s1(i:i) /= ' ' ) then
+      return
+    end if
+  end do
+
+  do i = lenc + 1, len2
+    if ( s2(i:i) /= ' ' ) then
+      return
+    end if
+  end do
+
+  s_eqi = .true.
+
+  return
+end
+function s_index_last ( string, sub )
+
+!*****************************************************************************80
+!
+!! S_INDEX_LAST finds the LAST occurrence of a given substring.
+!
+!  Discussion:
+!
+!    It returns the location in STRING at which the substring SUB is
+!    first found, or 0 if the substring does not occur at all.
+!
+!    The routine is also trailing blank insensitive.  This is very
+!    important for those cases where you have stored information in
+!    larger variables.  If STRING is of length 80, and SUB is of
+!    length 80, then if STRING = 'FRED' and SUB = 'RED', a match would
+!    not be reported by the standard FORTRAN INDEX, because it treats
+!    both variables as being 80 characters long!  This routine assumes that
+!    trailing blanks represent garbage!
+!
+!    This means that this routine cannot be used to find, say, the last
+!    occurrence of a substring 'A ', since it assumes the blank space
+!    was not specified by the user, but is, rather, padding by the
+!    system.  However, as a special case, this routine can properly handle
+!    the case where either STRING or SUB is all blanks.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    14 April 1999
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) STRING, the string to be searched.
+!
+!    Input, character ( len = * ) SUB, the substring to search for.
+!
+!    Output, integer ( kind = 4 ) S_INDEX_LAST.  0 if SUB does not occur in
+!    STRING.  Otherwise S_INDEX_LAST = I, where STRING(I:I+LENS-1) = SUB,
+!    where LENS is the length of SUB, and is the last place
+!    this happens.
+!
+  implicit none
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) llen1
+  integer ( kind = 4 ) llen2
+  integer ( kind = 4 ) s_index_last
+  character ( len = * ) string
+  character ( len = * ) sub
+
+  s_index_last = 0
+
+  llen1 = len_trim ( string )
+  llen2 = len_trim ( sub )
+!
+!  In case STRING or SUB is blanks, use LEN
+!
+  if ( llen1 == 0 ) then
+    llen1 = len ( string )
+  end if
+
+  if ( llen2 == 0 ) then
+    llen2 = len ( sub )
+  end if
+
+  if ( llen1 < llen2 ) then
+    return
+  end if
+
+  do j = 1, llen1+1-llen2
+
+    i = llen1 + 2 - llen2 - j
+
+    if ( string(i:i+llen2-1) == sub ) then
+      s_index_last = i
+      return
+    end if
+
+  end do
+
+  return
+end
+function s_indexi ( s, sub )
+
+!*****************************************************************************80
+!
+!! S_INDEXI is a case-insensitive INDEX function.
+!
+!  Discussion:
+!
+!    The function returns the location in the string at which the
+!    substring SUB is first found, or 0 if the substring does not
+!    occur at all.
+!
+!    The routine is also trailing blank insensitive.  This is very
+!    important for those cases where you have stored information in
+!    larger variables.  If S is of length 80, and SUB is of
+!    length 80, then if S = 'FRED' and SUB = 'RED', a match would
+!    not be reported by the standard FORTRAN INDEX, because it treats
+!    both variables as being 80 characters long!  This routine assumes that
+!    trailing blanks represent garbage!
+!
+!    Because of the suppression of trailing blanks, this routine cannot be
+!    used to find, say, the first occurrence of the two-character
+!    string 'A '.  However, this routine treats as a special case the
+!    occurrence where S or SUB is entirely blank.  Thus you can
+!    use this routine to search for occurrences of double or triple blanks
+!    in a string, for example, although INDEX itself would be just as
+!    suitable for that problem.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    14 April 1999
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) S, the string to be searched.
+!
+!    Input, character ( len = * ) SUB, the substring to search for.
+!
+!    Output, integer ( kind = 4 ) S_INDEXI.  0 if SUB does not occur in
+!    the string.  Otherwise S(S_INDEXI:S_INDEXI+LENS-1) = SUB,
+!    where LENS is the length of SUB, and is the first place
+!    this happens.  However, note that this routine ignores case,
+!    unlike the standard FORTRAN INDEX function.
+!
+  implicit none
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) llen1
+  integer ( kind = 4 ) llen2
+  character ( len = * ) s
+  logical s_eqi
+  integer ( kind = 4 ) s_indexi
+  character ( len = * ) sub
+
+  s_indexi = 0
+
+  llen1 = len_trim ( s )
+  llen2 = len_trim ( sub )
+!
+!  In case S or SUB is blanks, use LEN.
+!
+  if ( llen1 == 0 ) then
+    llen1 = len ( s )
+  end if
+
+  if ( llen2 == 0 ) then
+    llen2 = len ( sub )
+  end if
+
+  if ( llen1 < llen2 ) then
+    return
+  end if
+
+  do i = 1, llen1 + 1 - llen2
+
+    if ( s_eqi ( s(i:i+llen2-1), sub ) ) then
+      s_indexi = i
+      return
+    end if
+
+  end do
+
+  return
+end
+subroutine s_low ( s )
+
+!*****************************************************************************80
+!
+!! S_LOW replaces all uppercase letters by lowercase ones.
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    19 July 1998
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input/output, character ( len = * ) S, the string to be
+!    transformed.  On output, the string is all lowercase.
+!
+  implicit none
+
+  integer ( kind = 4 ) i
+  character ( len = * ) s
+  integer ( kind = 4 ) s_length
+
+  s_length = len_trim ( s )
+
+  do i = 1, s_length
+    call ch_low ( s(i:i) )
+  end do
+
+  return
+end
+subroutine s_split ( s, sub, s1, s2, s3 )
+
+!*****************************************************************************80
+!
+!! S_SPLIT divides a string into three parts, given the middle.
+!
+!  Discussion:
+!
+!    This version of the routine is case-insensitive.
+!
+!  Example:
+!
+!    Input:
+!
+!      S = 'aBCdEfgh'
+!      S2 = 'eF'
+!
+!    Output:
+!
+!      S1 = 'aBCd'
+!      S2 =  'gh'
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    01 March 2000
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) S, the string to be analyzed.
+!
+!    Input, character ( len = * ) SUB, the substring used to "split" S.
+!    Trailing blanks in SUB are ignored.
+!
+!    Output, character ( len = * ) S1, the entries in the string, up
+!    to, but not including, the first occurrence, if any,
+!    of SUB.  If SUB occurs immediately, then S1 = ' '.
+!    If SUB is not long enough, trailing entries will be lost.
+!
+!    Output, character ( len = * ) S2, the part of the string that matched SUB.
+!    If S2 is ' ', then there wasn't a match.
+!
+!    Output, character ( len = * ) S3, the part of the string after the match.
+!    If there was no match, then S3 is blank.
+!
+  implicit none
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) lenm
+  integer ( kind = 4 ) lens
+  character ( len = * ) s
+  integer ( kind = 4 ) s_indexi
+  character ( len = * ) s1
+  character ( len = * ) s2
+  character ( len = * ) s3
+  character ( len = * ) sub
+
+  lens = len_trim ( s )
+
+  lenm = len_trim ( sub )
+  if ( lenm == 0 ) then
+    lenm = 1
+  end if
+
+  i = s_indexi ( s, sub )
+!
+!  The substring did not occur.
+!
+  if ( i == 0 ) then
+    s1 = s
+    s2 = ' '
+    s3 = ' '
+!
+!  The substring begins immediately.
+!
+  else if ( i == 1 ) then
+    s1 = ' '
+    s2 = s(1:lenm)
+    s3 = s(lenm+1:)
+!
+!  What am I checking here?
+!
+  else if ( lens < i + lenm ) then
+    s1 = s
+    s2 = ' '
+    s3 = ' '
+!
+!  The substring occurs in the middle.
+!
+  else
+    s1 = s(1:i-1)
+    s2 = s(i:i+lenm-1)
+    s3 = s(i+lenm: )
+  end if
+!
+!  Drop leading blanks.
+!
+  s1 = adjustl ( s1 )
+  s2 = adjustl ( s2 )
+  s3 = adjustl ( s3 )
+
+  return
+end
+subroutine timestamp ( )
+
+!*****************************************************************************80
+!
+!! TIMESTAMP prints the current YMDHMS date as a time stamp.
+!
+!  Example:
+!
+!    31 May 2001   9:45:54.872 AM
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    18 May 2013
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    None
+!
+  implicit none
+
+  character ( len = 8 ) ampm
+  integer ( kind = 4 ) d
+  integer ( kind = 4 ) h
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) mm
+  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
+    'January  ', 'February ', 'March    ', 'April    ', &
+    'May      ', 'June     ', 'July     ', 'August   ', &
+    'September', 'October  ', 'November ', 'December ' /)
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) s
+  integer ( kind = 4 ) values(8)
+  integer ( kind = 4 ) y
+
+  call date_and_time ( values = values )
+
+  y = values(1)
+  m = values(2)
+  d = values(3)
+  h = values(5)
+  n = values(6)
+  s = values(7)
+  mm = values(8)
+
+  if ( h < 12 ) then
+    ampm = 'AM'
+  else if ( h == 12 ) then
+    if ( n == 0 .and. s == 0 ) then
+      ampm = 'Noon'
+    else
+      ampm = 'PM'
+    end if
+  else
+    h = h - 12
+    if ( h < 12 ) then
+      ampm = 'PM'
+    else if ( h == 12 ) then
+      if ( n == 0 .and. s == 0 ) then
+        ampm = 'Midnight'
+      else
+        ampm = 'AM'
+      end if
+    end if
+  end if
+
+  write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
+    d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )
+
+  return
+end
+subroutine word_next_read ( line, word, done )
+
+!*****************************************************************************80
+!
+!! WORD_NEXT_READ "reads" words from a string, one at a time.
+!
+!  Discussion:
+!
+!    The following characters are considered to be a single word,
+!    whether surrounded by spaces or not:
+!
+!      " ( ) { } [ ]
+!
+!  Licensing:
+!
+!    This code is distributed under the GNU LGPL license.
+!
+!  Modified:
+!
+!    16 February 1999
+!
+!  Author:
+!
+!    John Burkardt
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) LINE, a string, presumably containing words
+!    separated by spaces.
+!
+!    Output, character ( len = * ) WORD.
+!    If DONE is FALSE, then WORD contains the "next" word read from LINE.
+!    If DONE is TRUE, then WORD is blank, because there was no more to read.
+!
+!    Input/output, logical DONE.
+!    On input with a fresh value of LINE, set DONE to TRUE.
+!    On output, the routine sets DONE:
+!      FALSE if another word was read from LINE,
+!      TRUE if no more words could be read (LINE is exhausted).
+!
+  implicit none
+
+  logical done
+  integer ( kind = 4 ) ilo
+  integer ( kind = 4 ), save :: lenc = 0
+  character ( len = * ) line
+  integer ( kind = 4 ), save :: next = 1
+  character TAB
+  character ( len = * ) word
+
+  TAB = char ( 9 )
+!
+!  An input value of DONE = TRUE signals a new line of text to examine.
+!
+  if ( done ) then
+
+    next = 1
+    done = .false.
+    lenc = len_trim ( line )
+
+    if ( lenc <= 0 ) then
+      done = .true.
+      word = ' '
+      return
+    end if
+
+  end if
+!
+!  Beginning at index NEXT, search LINE for the next nonblank,
+!  which signals the beginning of a word.
+!
+  ilo = next
+
+  do
+!
+!  ...LINE(NEXT:) is blank.  Return with WORD = ' ' and DONE = TRUE.
+!
+    if ( lenc < ilo ) then
+      word = ' '
+      done = .true.
+      next = lenc + 1
+      return
+    end if
+!
+!  If the current character is blank, skip to the next one.
+!
+    if ( line(ilo:ilo) /= ' ' .and. line(ilo:ilo) /= TAB ) then
+      exit
+    end if
+
+    ilo = ilo + 1
+
+  end do
+!
+!  ILO is the index of the next nonblank character in the string.
+!
+!  If this initial nonblank is a special character,
+!  then that's the whole word as far as we're concerned,
+!  so return immediately.
+!
+  if ( line(ilo:ilo) == '"' .or. line(ilo:ilo) == '(' .or. &
+       line(ilo:ilo) == ')' .or. line(ilo:ilo) == '{' .or. &
+       line(ilo:ilo) == '}' .or. line(ilo:ilo) == '[' .or. &
+       line(ilo:ilo) == ']' ) then
+
+    word = line(ilo:ilo)
+    next = ilo + 1
+    return
+
+  end if
+!
+!  Now search for the last contiguous character that is not a
+!  blank, TAB, or special character.
+!
+  next = ilo + 1
+
+  do
+
+    if ( lenc < next ) then
+      word = line(ilo:next-1)
+      return
+    end if
+
+    if ( line(next:next) == ' ' .or. &
+         line(next:next) == TAB .or. &
+         line(next:next) == '"' .or. &
+         line(next:next) == '(' .or. &
+         line(next:next) == ')' .or. &
+         line(next:next) == '{' .or. &
+         line(next:next) == '}' .or. &
+         line(next:next) == '[' .or. &
+         line(next:next) == ']' ) then
+      exit
+    end if
+
+    next = next + 1
+
+  end do
+
+  word = line(ilo:next-1)
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/f90split.sh b/wrfv2_fire/external/fftpack/f90split.sh
new file mode 100755
index 00000000..9f33001b
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/f90split.sh
@@ -0,0 +1,22 @@
+#!/bin/bash
+#
+gfortran -c -g f90split.f90 >& compiler.txt
+if [ $? -ne 0 ]; then
+  echo "Errors compiling f90split.f90"
+  exit
+fi
+rm compiler.txt
+#
+gfortran f90split.o
+if [ $? -ne 0 ]; then
+  echo "Errors linking and loading f90split.o"
+  exit
+fi
+rm f90split.o
+#
+chmod ugo+x a.out
+# mv a.out ~/bin/$ARCH/f90split
+mv a.out f90split.exe
+
+#
+echo "Program installed as f90split.exe"
diff --git a/wrfv2_fire/external/fftpack/fftpack5/Makefile b/wrfv2_fire/external/fftpack/fftpack5/Makefile
index 41a549b9..dac7b7a4 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/Makefile
+++ b/wrfv2_fire/external/fftpack/fftpack5/Makefile
@@ -1,15 +1,19 @@
 .SUFFIXES: .F .o
 
-OBJ  =   c1f2kb.o c1f2kf.o c1f3kb.o c1f3kf.o c1f4kb.o c1f4kf.o c1f5kb.o c1f5kf.o c1fgkb.o c1fgkf.o c1fm1b.o c1fm1f.o cfft1b.o \
-         cfft1f.o cfft1i.o cfft2b.o cfft2f.o cfft2i.o cfftmb.o cfftmf.o cfftmi.o cmf2kb.o \
-         cmf2kf.o cmf3kb.o cmf3kf.o cmf4kb.o cmf4kf.o cmf5kb.o cmf5kf.o cmfgkb.o cmfgkf.o cmfm1b.o cmfm1f.o cosq1b.o \
-         cosq1f.o cosq1i.o cosqb1.o cosqf1.o cosqmb.o cosqmf.o cosqmi.o cost1b.o cost1f.o cost1i.o costb1.o costf1.o \
-         costmb.o costmf.o costmi.o factor.o mcfti1.o mcsqb1.o mcsqf1.o mcstb1.o mcstf1.o mradb2.o mradb3.o \
-         mradb4.o mradb5.o mradbg.o mradf2.o mradf3.o mradf4.o mradf5.o mradfg.o mrftb1.o mrftf1.o mrfti1.o msntb1.o \
-         msntf1.o r1f2kb.o r1f2kf.o r1f3kb.o r1f3kf.o r1f4kb.o r1f4kf.o r1f5kb.o r1f5kf.o r1fgkb.o r1fgkf.o rfft1b.o \
-         rfft1f.o rfft1i.o rfft2b.o rfft2f.o rfft2i.o rfftb1.o rfftf1.o rffti1.o rfftmb.o \
-         rfftmf.o rfftmi.o sinq1b.o sinq1f.o sinq1i.o sinqmb.o sinqmf.o sinqmi.o sint1b.o sint1f.o sint1i.o sintb1.o \
-         sintf1.o sintmb.o sintmf.o sintmi.o tables.o xercon.o xerfft.o
+OBJ	= \
+c1f2kb.o  cfft1b.o  cmf3kf.o  cosqb1.o  costmi.o   dcosq1f.o  dfftb1.o   mradb2.o  mrfti1.o  r1fgkf.o     rfft2i.o  sinqmi.o  z1f2kf.o  zfft1f.o  zmf4kb.o \
+c1f2kf.o  cfft1f.o  cmf4kb.o  cosqf1.o  d1f2kb.o   dcosq1i.o  dfftf1.o   mradb3.o  msntb1.o  r4_factor.o  rfftb1.o  sint1b.o  z1f3kb.o  zfft1i.o  zmf4kf.o \
+c1f3kb.o  cfft1i.o  cmf4kf.o  cosqmb.o  d1f2kf.o   dcosqb1.o  dffti1.o   mradb4.o  msntf1.o  r4_mcfti1.o  rfftf1.o  sint1f.o  z1f3kf.o  zfft2b.o  zmf5kb.o \
+c1f3kf.o  cfft2b.o  cmf5kb.o  cosqmf.o  d1f3kb.o   dcosqf1.o  dsint1b.o  mradb5.o  r1f2kb.o  r4_tables.o  rffti1.o  sint1i.o  z1f4kb.o  zfft2f.o  zmf5kf.o \
+c1f4kb.o  cfft2f.o  cmf5kf.o  cosqmi.o  d1f3kf.o   dcost1b.o  dsint1f.o  mradbg.o  r1f2kf.o  r8_factor.o  rfftmb.o  sintb1.o  z1f4kf.o  zfft2i.o  zmfgkb.o \
+c1f4kf.o  cfft2i.o  cmfgkb.o  cost1b.o  d1f4kb.o   dcost1f.o  dsint1i.o  mradf2.o  r1f3kb.o  r8_mcfti1.o  rfftmf.o  sintf1.o  z1f5kb.o  zfftmb.o  zmfgkf.o \
+c1f5kb.o  cfftmb.o  cmfgkf.o  cost1f.o  d1f4kf.o   dcost1i.o  dsintb1.o  mradf3.o  r1f3kf.o  r8_tables.o  rfftmi.o  sintmb.o  z1f5kf.o  zfftmf.o  zmfm1b.o \
+c1f5kf.o  cfftmf.o  cmfm1b.o  cost1i.o  d1f5kb.o   dcostb1.o  dsintf1.o  mradf4.o  r1f4kb.o  rfft1b.o     sinq1b.o  sintmf.o  z1fgkb.o  zfftmi.o  zmfm1f.o \
+c1fgkb.o  cfftmi.o  cmfm1f.o  costb1.o  d1f5kf.o   dcostf1.o  mcsqb1.o   mradf5.o  r1f4kf.o  rfft1f.o     sinq1f.o  sintmi.o  z1fgkf.o  zmf2kb.o           \
+c1fgkf.o  cmf2kb.o  cosq1b.o  costf1.o  d1fgkb.o   dfft1b.o   mcsqf1.o   mradfg.o  r1f5kb.o  rfft1i.o     sinq1i.o  xercon.o  z1fm1b.o  zmf2kf.o           \
+c1fm1b.o  cmf2kf.o  cosq1f.o  costmb.o  d1fgkf.o   dfft1f.o   mcstb1.o   mrftb1.o  r1f5kf.o  rfft2b.o     sinqmb.o  xerfft.o  z1fm1f.o  zmf3kb.o           \
+c1fm1f.o  cmf3kb.o  cosq1i.o  costmf.o  dcosq1b.o  dfft1i.o   mcstf1.o   mrftf1.o  r1fgkb.o  rfft2f.o     sinqmf.o  z1f2kb.o  zfft1b.o  zmf3kf.o 
+
 
 AR = ar
 ARFLAGS = cr
@@ -20,7 +24,9 @@ library: $(OBJ)
 	$(RANLIB) $(TARGET)
 
 .F.o:
-	$(FC) -c $(FFLAGS) $< 
+	$(CPP) $(CPPFLAGS) $*.F  > $*.f90
+	$(FC) -c $(FFLAGS) $*.f90
+	$(RM) -f $*.f90
 
 clean:
 	rm -f $(OBJ) $(TARGET) *.obj
diff --git a/wrfv2_fire/external/fftpack/fftpack5/Makefile-orig b/wrfv2_fire/external/fftpack/fftpack5/Makefile-orig
deleted file mode 100644
index 4dfa58d0..00000000
--- a/wrfv2_fire/external/fftpack/fftpack5/Makefile-orig
+++ /dev/null
@@ -1,49 +0,0 @@
-.SUFFIXES:
-.SUFFIXES: .f .o
-
-OBJ  =   c1f2kb.o c1f2kf.o c1f3kb.o c1f3kf.o c1f4kb.o c1f4kf.o c1f5kb.o c1f5kf.o c1fgkb.o c1fgkf.o c1fm1b.o c1fm1f.o cfft1b.o\
-         cfft1f.o cfft1i.o cfft2b.o cfft2f.o cfft2i.o cfftmb.o cfftmf.o cfftmi.o cmf2kb.o\
-         cmf2kf.o cmf3kb.o cmf3kf.o cmf4kb.o cmf4kf.o cmf5kb.o cmf5kf.o cmfgkb.o cmfgkf.o cmfm1b.o cmfm1f.o cosq1b.o\
-         cosq1f.o cosq1i.o cosqb1.o cosqf1.o cosqmb.o cosqmf.o cosqmi.o cost1b.o cost1f.o cost1i.o costb1.o costf1.o\
-         costmb.o costmf.o costmi.o factor.o mcfti1.o mcsqb1.o mcsqf1.o mcstb1.o mcstf1.o mradb2.o mradb3.o\
-         mradb4.o mradb5.o mradbg.o mradf2.o mradf3.o mradf4.o mradf5.o mradfg.o mrftb1.o mrftf1.o mrfti1.o msntb1.o\
-         msntf1.o r1f2kb.o r1f2kf.o r1f3kb.o r1f3kf.o r1f4kb.o r1f4kf.o r1f5kb.o r1f5kf.o r1fgkb.o r1fgkf.o rfft1b.o\
-         rfft1f.o rfft1i.o rfft2b.o rfft2f.o rfft2i.o rfftb1.o rfftf1.o rffti1.o rfftmb.o\
-         rfftmf.o rfftmi.o sinq1b.o sinq1f.o sinq1i.o sinqmb.o sinqmf.o sinqmi.o sint1b.o sint1f.o sint1i.o sintb1.o\
-         sintf1.o sintmb.o sintmf.o sintmi.o tables.o xercon.o xerfft.o
-
-default:
-	@echo "Usage: $(MAKE) [ sun | hp | ibm | gnu | intel | absoft | pgi]"
-
-sun:
-	@$(MAKE) FC=f90 LD=ar FFLAGS="-xO5" LDFLAGS="cr" TARGET=libfftpack.a all
-
-hp:
-	@$(MAKE) FC=f90 LD=ar FFLAGS="-fast" LDFLAGS="cr" TARGET=libfftpack.a all
-
-ibm:
-	@$(MAKE) FC=xlf LD=ar FFLAGS="-O3" LDFLAGS="cr" TARGET=libfftpack.a all
-
-gnu:
-	@$(MAKE) FC=g77 LD=ar FFLAGS="-O3" LDFLAGS="cr" TARGET=libfftpack.a all
-
-intel:
-	@$(MAKE) FC=ifort LD=ar FFLAGS="-O3" LDFLAGS="cr" TARGET=libfftpack.a all
-
-absoft:
-	@$(MAKE) FC=f77 LD=ar FFLAGS="-O3" LDFLAGS="cr" TARGET=libfftpack.a all
-
-pgi:
-	@$(MAKE) FC=pgf77 LD=ar FFLAGS="-fast" LDFLAGS="cr" TARGET=libfftpack.a all
-
-all: library
-
-library: $(OBJ)
-	$(LD) $(LDFLAGS) $(TARGET) $(OBJ)
-
-.f.o:
-	$(FC) -c $(FFLAGS) $< 
-
-clean:
-	rm -f $(OBJ) libfftpack*
-
diff --git a/wrfv2_fire/external/fftpack/fftpack5/README b/wrfv2_fire/external/fftpack/fftpack5/README
deleted file mode 100644
index d372ac07..00000000
--- a/wrfv2_fire/external/fftpack/fftpack5/README
+++ /dev/null
@@ -1,174 +0,0 @@
-
-FFTPACK5 - a FORTRAN library of fast Fourier transforms
-
-Authors:  Paul N. Swarztrauber and Richard A. Valent
-
-$Id: README,v 1.2 2004/06/17 21:59:51 rodney Exp $
-
-Website
--------
-
-http://www.scd.ucar.edu/css/software/fftpack5
-
-
-Documentation
--------------
-
-Documentation is provided in PDF format in the file fftpack5.pdf.
-This information is also available in HTML format at the above
-website.  Information about building the library follows below,
-as well as a synopsis of the library.
-
-
-Compiling Library
------------------   
-
-[Editor's note - this refers to the original build, 
-not the WRF modified build.]
-
-The included Makefile if configured to build a static
-library on most currently availble unix and unix-like
-operating systems.  The given make targets (type "make"
-without any arguments for a list of targets) correspond
-to compiler names; e.g. intel = Intel F95 compiler, 
-gnu = GNU g77 compiler, sun = Sun Solaris compiler, etc.
-
-The source code is by default configured for single precision
-real numbers.  If double precision is desired, the Makefile must
-be modified with the appropriate compiler options for promoting
-real to double precision as well as promoting constants to double
-precision (this is often "-r8" on some, but not all, compilers).
-
-
-Complex Transform Routines
-__________________________
-
-CFFT1I    1D complex initialization
-CFFT1B    1D complex backward
-CFFT1F    1D complex forward
-
-CFFT2I    2D complex initialization
-CFFT2B    2D complex backward
-CFFT2F    2D complex forward
-
-CFFTMI    multiple complex initialization
-CFFTMB    multiple complex backward
-CFFTMF    multiple complex forward
-
-
-Real Transform Routines
-_______________________
-
-RFFT1I    1D real initialization
-RFFT1B    1D real backward
-RFFT1F    1D real forward
-
-RFFT2I    2D real initialization
-RFFT2B    2D real backward
-RFFT2F    2D real forward
-
-RFFTMI    multiple real initialization
-RFFTMB    multiple real backward
-RFFTMF    multiple real forward
-
-
-Real Cosine Transform Routines
-______________________________
-
-COST1I    1D real cosine initialization
-COST1B    1D real cosine backward
-COST1F    1D real cosine forward
-
-COSTMI    multiple real cosine initialization
-COSTMB    multiple real cosine backward
-COSTMF    multiple real cosine forward
-
-
-Real Sine Transform Routines
-____________________________
-
-SINT1I    1D real sine initialization
-SINT1B    1D real sine backward
-SINT1F    1D real sine forward
-
-SINTMI    multiple real sine initialization
-SINTMB    multiple real sine backward
-SINTMF    multiple real sine forward
-
-
-Real Quarter-Cosine Transform Routines
-______________________________________
-
-COSQ1I    1D real quarter-cosine initialization
-COSQ1B    1D real quarter-cosine backward
-COSQ1F    1D real quarter-cosine forward
-
-COSQMI    multiple real quarter-cosine initialization
-COSQMB    multiple real quarter-cosine backward
-COSQMF    multiple real quarter-cosine forward
-
-
-Real Quarter-Sine Transform Routines
-____________________________________
-
-SINQ1I    1D real quarter-sine initialization
-SINQ1B    1D real quarter-sine backward
-SINQ1F    1D real quarter-sine forward
-
-SINQMI    multiple real quarter-sine initialization
-SINQMB    multiple real quarter-sine backward
-SINQMF    multiple real quarter-sine forward
-
-
-Library FFTPACK5 contains 1D, 2D, and multiple fast Fourier
-subroutines, written in Fortran 77, for transforming real and complex
-data, real even and odd wave data, and real even and odd quarter-wave
-data.
-
-All of the FFTPACK5 routines listed above are grouped in triplets
-e.g. {CFFT1I, CFFT1F, CFFT1B}.  The suffix "I" denotes "initialize",
-"F" denotes "forward" (as in "forward transform") and "B" denotes
-"backward".  In an application program, before calling "B" or "F"
-routines for the first time, or before calling them with a different
-length, users must initialize an array by calling the "I" routine of
-the appropriate pair or triplet.  Note that "I" routines need not be
-called each time before a "B" or "F" routine is called.
-
-All of the transform routines in FFTPACK5 are normalized.
-
-Error messages are written to unit 6 by routine XERFFT.  The
-standard version of XERFFT issues an error message and halts execution,
-so that no FFTPACK routine will return to the calling program with
-error return IER different than zero.  Users may consider modifying the
-STOP statement in order to call system-specific exception-handling
-facilities.
-
-FFTPACK5 is written in standard Fortran 77 except for several
-instances where arrays of type REAL or COMPLEX are passed to a
-subroutine and used as a different type.
-
- (1) "Vectorizing the Fast Fourier Transforms", by Paul Swarztrauber,
-     Parallel Computations, G. Rodrigue, ed., Academic Press,
-     New York 1982.
-
- (2) "Fast Fourier Transforms Algorithms for Vector Computers", by
-     Paul Swarztrauber, Parallel Computing, (1984) pp.45-63.
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1f2kb.F b/wrfv2_fire/external/fftpack/fftpack5/c1f2kb.F
index 34f9a78a..6b26ee54 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1f2kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1f2kb.F
@@ -1,42 +1,94 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1f2kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1F2KB (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
-      REAL  CC(IN1,L1,IDO,2),CH(IN2,L1,2,IDO),WA(IDO,1,2) 
-!                                                                       
-      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
-      DO 101 K=1,L1 
-         CHOLD1 = CC(1,K,1,1)+CC(1,K,1,2) 
-         CC(1,K,1,2) = CC(1,K,1,1)-CC(1,K,1,2) 
-         CC(1,K,1,1) = CHOLD1 
-         CHOLD2 = CC(2,K,1,1)+CC(2,K,1,2) 
-         CC(2,K,1,2) = CC(2,K,1,1)-CC(2,K,1,2) 
-         CC(2,K,1,1) = CHOLD2 
-  101 END DO 
-      RETURN 
-  102 DO 103 K=1,L1 
-         CH(1,K,1,1) = CC(1,K,1,1)+CC(1,K,1,2) 
-         CH(1,K,2,1) = CC(1,K,1,1)-CC(1,K,1,2) 
-         CH(2,K,1,1) = CC(2,K,1,1)+CC(2,K,1,2) 
-         CH(2,K,2,1) = CC(2,K,1,1)-CC(2,K,1,2) 
-  103 END DO 
-      IF(IDO .EQ. 1) RETURN 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-            CH(1,K,1,I) = CC(1,K,I,1)+CC(1,K,I,2) 
-            TR2 = CC(1,K,I,1)-CC(1,K,I,2) 
-            CH(2,K,1,I) = CC(2,K,I,1)+CC(2,K,I,2) 
-            TI2 = CC(2,K,I,1)-CC(2,K,I,2) 
-            CH(2,K,2,I) = WA(I,1,1)*TI2+WA(I,1,2)*TR2 
-            CH(1,K,2,I) = WA(I,1,1)*TR2-WA(I,1,2)*TI2 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine c1f2kb ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! C1F2KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,l1,ido,2)
+  real ( kind = 4 ) ch(in2,l1,2,ido)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) wa(ido,1,2)
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      ch(1,k,1,1) = cc(1,k,1,1) + cc(1,k,1,2)
+      ch(1,k,2,1) = cc(1,k,1,1) - cc(1,k,1,2)
+      ch(2,k,1,1) = cc(2,k,1,1) + cc(2,k,1,2)
+      ch(2,k,2,1) = cc(2,k,1,1) - cc(2,k,1,2)
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+
+        ch(1,k,1,i) = cc(1,k,i,1) + cc(1,k,i,2)
+        tr2         = cc(1,k,i,1) - cc(1,k,i,2)
+        ch(2,k,1,i) = cc(2,k,i,1) + cc(2,k,i,2)
+        ti2         = cc(2,k,i,1) - cc(2,k,i,2)
+
+        ch(2,k,2,i) = wa(i,1,1) * ti2 + wa(i,1,2) * tr2
+        ch(1,k,2,i) = wa(i,1,1) * tr2 - wa(i,1,2) * ti2
+
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+
+      chold1      = cc(1,k,1,1) + cc(1,k,1,2)
+      cc(1,k,1,2) = cc(1,k,1,1) - cc(1,k,1,2)
+      cc(1,k,1,1) = chold1
+
+      chold2      = cc(2,k,1,1) + cc(2,k,1,2)
+      cc(2,k,1,2) = cc(2,k,1,1) - cc(2,k,1,2)
+      cc(2,k,1,1) = chold2
+
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1f2kf.F b/wrfv2_fire/external/fftpack/fftpack5/c1f2kf.F
index 7d447db6..63c2714f 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1f2kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1f2kf.F
@@ -1,50 +1,105 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1f2kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1F2KF (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
-      REAL  CC(IN1,L1,IDO,2),CH(IN2,L1,2,IDO),WA(IDO,1,2) 
-!                                                                       
-      IF (IDO .GT. 1) GO TO 102 
-      SN = 1./REAL(2*L1) 
-      IF (NA .EQ. 1) GO TO 106 
-      DO 101 K=1,L1 
-         CHOLD1 = SN*(CC(1,K,1,1)+CC(1,K,1,2)) 
-         CC(1,K,1,2) = SN*(CC(1,K,1,1)-CC(1,K,1,2)) 
-         CC(1,K,1,1) = CHOLD1 
-         CHOLD2 = SN*(CC(2,K,1,1)+CC(2,K,1,2)) 
-         CC(2,K,1,2) = SN*(CC(2,K,1,1)-CC(2,K,1,2)) 
-         CC(2,K,1,1) = CHOLD2 
-  101 END DO 
-      RETURN 
-  106 DO 107 K=1,L1 
-         CH(1,K,1,1) = SN*(CC(1,K,1,1)+CC(1,K,1,2)) 
-         CH(1,K,2,1) = SN*(CC(1,K,1,1)-CC(1,K,1,2)) 
-         CH(2,K,1,1) = SN*(CC(2,K,1,1)+CC(2,K,1,2)) 
-         CH(2,K,2,1) = SN*(CC(2,K,1,1)-CC(2,K,1,2)) 
-  107 END DO 
-      RETURN 
-  102 DO 103 K=1,L1 
-         CH(1,K,1,1) = CC(1,K,1,1)+CC(1,K,1,2) 
-         CH(1,K,2,1) = CC(1,K,1,1)-CC(1,K,1,2) 
-         CH(2,K,1,1) = CC(2,K,1,1)+CC(2,K,1,2) 
-         CH(2,K,2,1) = CC(2,K,1,1)-CC(2,K,1,2) 
-  103 END DO 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-            CH(1,K,1,I) = CC(1,K,I,1)+CC(1,K,I,2) 
-            TR2 = CC(1,K,I,1)-CC(1,K,I,2) 
-            CH(2,K,1,I) = CC(2,K,I,1)+CC(2,K,I,2) 
-            TI2 = CC(2,K,I,1)-CC(2,K,I,2) 
-            CH(2,K,2,I) = WA(I,1,1)*TI2-WA(I,1,2)*TR2 
-            CH(1,K,2,I) = WA(I,1,1)*TR2+WA(I,1,2)*TI2 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine c1f2kf ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! C1F2KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,l1,ido,2)
+  real ( kind = 4 ) ch(in2,l1,2,ido)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) sn
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) wa(ido,1,2)
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+      ch(1,k,1,1) = cc(1,k,1,1) + cc(1,k,1,2)
+      ch(1,k,2,1) = cc(1,k,1,1) - cc(1,k,1,2)
+      ch(2,k,1,1) = cc(2,k,1,1) + cc(2,k,1,2)
+      ch(2,k,2,1) = cc(2,k,1,1) - cc(2,k,1,2)
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        ch(1,k,1,i) = cc(1,k,i,1) + cc(1,k,i,2)
+        tr2         = cc(1,k,i,1) - cc(1,k,i,2)
+        ch(2,k,1,i) = cc(2,k,i,1) + cc(2,k,i,2)
+        ti2         = cc(2,k,i,1) - cc(2,k,i,2)
+        ch(2,k,2,i) = wa(i,1,1) * ti2 - wa(i,1,2) * tr2
+        ch(1,k,2,i) = wa(i,1,1) * tr2 + wa(i,1,2) * ti2
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0E+00 / real ( 2 * l1, kind = 4 )
+
+    do k = 1, l1
+      ch(1,k,1,1) = sn * ( cc(1,k,1,1) + cc(1,k,1,2) )
+      ch(1,k,2,1) = sn * ( cc(1,k,1,1) - cc(1,k,1,2) )
+      ch(2,k,1,1) = sn * ( cc(2,k,1,1) + cc(2,k,1,2) )
+      ch(2,k,2,1) = sn * ( cc(2,k,1,1) - cc(2,k,1,2) )
+    end do
+
+  else
+
+    sn = 1.0E+00 / real ( 2 * l1, kind = 4 )
+
+    do k = 1, l1
+
+      chold1      = sn * ( cc(1,k,1,1) + cc(1,k,1,2) )
+      cc(1,k,1,2) = sn * ( cc(1,k,1,1) - cc(1,k,1,2) )
+      cc(1,k,1,1) = chold1
+
+      chold2      = sn * ( cc(2,k,1,1) + cc(2,k,1,2) )
+      cc(2,k,1,2) = sn * ( cc(2,k,1,1) - cc(2,k,1,2) )
+      cc(2,k,1,1) = chold2
+
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1f3kb.F b/wrfv2_fire/external/fftpack/fftpack5/c1f3kb.F
index 1cd8a42f..aa7d77fc 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1f3kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1f3kb.F
@@ -1,67 +1,129 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1f3kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1F3KB (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
-      REAL  CC(IN1,L1,IDO,3),CH(IN2,L1,3,IDO),WA(IDO,2,2) 
-      DATA TAUR,TAUI /-.5,.866025403784439/ 
-!                                                                       
-      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
-      DO 101 K=1,L1 
-         TR2 = CC(1,K,1,2)+CC(1,K,1,3) 
-         CR2 = CC(1,K,1,1)+TAUR*TR2 
-         CC(1,K,1,1) = CC(1,K,1,1)+TR2 
-         TI2 = CC(2,K,1,2)+CC(2,K,1,3) 
-         CI2 = CC(2,K,1,1)+TAUR*TI2 
-         CC(2,K,1,1) = CC(2,K,1,1)+TI2 
-         CR3 = TAUI*(CC(1,K,1,2)-CC(1,K,1,3)) 
-         CI3 = TAUI*(CC(2,K,1,2)-CC(2,K,1,3)) 
-         CC(1,K,1,2) = CR2-CI3 
-         CC(1,K,1,3) = CR2+CI3 
-         CC(2,K,1,2) = CI2+CR3 
-         CC(2,K,1,3) = CI2-CR3 
-  101 END DO 
-      RETURN 
-  102 DO 103 K=1,L1 
-         TR2 = CC(1,K,1,2)+CC(1,K,1,3) 
-         CR2 = CC(1,K,1,1)+TAUR*TR2 
-         CH(1,K,1,1) = CC(1,K,1,1)+TR2 
-         TI2 = CC(2,K,1,2)+CC(2,K,1,3) 
-         CI2 = CC(2,K,1,1)+TAUR*TI2 
-         CH(2,K,1,1) = CC(2,K,1,1)+TI2 
-         CR3 = TAUI*(CC(1,K,1,2)-CC(1,K,1,3)) 
-         CI3 = TAUI*(CC(2,K,1,2)-CC(2,K,1,3)) 
-         CH(1,K,2,1) = CR2-CI3 
-         CH(1,K,3,1) = CR2+CI3 
-         CH(2,K,2,1) = CI2+CR3 
-         CH(2,K,3,1) = CI2-CR3 
-  103 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      DO 105 I=2,IDO 
-        DO 104 K=1,L1 
-            TR2 = CC(1,K,I,2)+CC(1,K,I,3) 
-            CR2 = CC(1,K,I,1)+TAUR*TR2 
-            CH(1,K,1,I) = CC(1,K,I,1)+TR2 
-            TI2 = CC(2,K,I,2)+CC(2,K,I,3) 
-            CI2 = CC(2,K,I,1)+TAUR*TI2 
-            CH(2,K,1,I) = CC(2,K,I,1)+TI2 
-            CR3 = TAUI*(CC(1,K,I,2)-CC(1,K,I,3)) 
-            CI3 = TAUI*(CC(2,K,I,2)-CC(2,K,I,3)) 
-            DR2 = CR2-CI3 
-            DR3 = CR2+CI3 
-            DI2 = CI2+CR3 
-            DI3 = CI2-CR3 
-            CH(2,K,2,I) = WA(I,1,1)*DI2+WA(I,1,2)*DR2 
-            CH(1,K,2,I) = WA(I,1,1)*DR2-WA(I,1,2)*DI2 
-            CH(2,K,3,I) = WA(I,2,1)*DI3+WA(I,2,2)*DR3 
-            CH(1,K,3,I) = WA(I,2,1)*DR3-WA(I,2,2)*DI3 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine c1f3kb ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! C1F3KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,l1,ido,3)
+  real ( kind = 4 ) ch(in2,l1,3,ido)
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) di2
+  real ( kind = 4 ) di3
+  real ( kind = 4 ) dr2
+  real ( kind = 4 ) dr3
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 4 ), parameter :: taui =  0.866025403784439E+00
+  real ( kind = 4 ), parameter :: taur = -0.5E+00
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) wa(ido,2,2)
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+
+      tr2 = cc(1,k,1,2)+cc(1,k,1,3)
+      cr2 = cc(1,k,1,1)+taur*tr2
+      ch(1,k,1,1) = cc(1,k,1,1)+tr2
+      ti2 = cc(2,k,1,2)+cc(2,k,1,3)
+      ci2 = cc(2,k,1,1)+taur*ti2
+      ch(2,k,1,1) = cc(2,k,1,1)+ti2
+      cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3))
+      ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3))
+
+      ch(1,k,2,1) = cr2 - ci3
+      ch(1,k,3,1) = cr2 + ci3
+      ch(2,k,2,1) = ci2 + cr3
+      ch(2,k,3,1) = ci2 - cr3
+
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        tr2 = cc(1,k,i,2)+cc(1,k,i,3)
+        cr2 = cc(1,k,i,1)+taur*tr2
+        ch(1,k,1,i) = cc(1,k,i,1)+tr2
+        ti2 = cc(2,k,i,2)+cc(2,k,i,3)
+        ci2 = cc(2,k,i,1)+taur*ti2
+        ch(2,k,1,i) = cc(2,k,i,1)+ti2
+        cr3 = taui*(cc(1,k,i,2)-cc(1,k,i,3))
+        ci3 = taui*(cc(2,k,i,2)-cc(2,k,i,3))
+
+        dr2 = cr2 - ci3
+        dr3 = cr2 + ci3
+        di2 = ci2 + cr3
+        di3 = ci2 - cr3
+
+        ch(2,k,2,i) = wa(i,1,1) * di2 + wa(i,1,2) * dr2
+        ch(1,k,2,i) = wa(i,1,1) * dr2 - wa(i,1,2) * di2
+        ch(2,k,3,i) = wa(i,2,1) * di3 + wa(i,2,2) * dr3
+        ch(1,k,3,i) = wa(i,2,1) * dr3 - wa(i,2,2) * di3
+
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+
+      tr2 = cc(1,k,1,2)+cc(1,k,1,3)
+      cr2 = cc(1,k,1,1)+taur*tr2
+      cc(1,k,1,1) = cc(1,k,1,1)+tr2
+      ti2 = cc(2,k,1,2)+cc(2,k,1,3)
+      ci2 = cc(2,k,1,1)+taur*ti2
+      cc(2,k,1,1) = cc(2,k,1,1)+ti2
+      cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3))
+      ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3))
+
+      cc(1,k,1,2) = cr2 - ci3
+      cc(1,k,1,3) = cr2 + ci3
+      cc(2,k,1,2) = ci2 + cr3
+      cc(2,k,1,3) = ci2 - cr3
+
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1f3kf.F b/wrfv2_fire/external/fftpack/fftpack5/c1f3kf.F
index 064f07d1..6c2e42bf 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1f3kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1f3kf.F
@@ -1,83 +1,154 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1f3kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1F3KF (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
-      REAL  CC(IN1,L1,IDO,3),CH(IN2,L1,3,IDO),WA(IDO,2,2) 
-      DATA TAUR,TAUI /-.5,-.866025403784439/ 
-!                                                                       
-      IF (IDO .GT. 1) GO TO 102 
-      SN = 1./REAL(3*L1) 
-      IF (NA .EQ. 1) GO TO 106 
-      DO 101 K=1,L1 
-         TR2 = CC(1,K,1,2)+CC(1,K,1,3) 
-         CR2 = CC(1,K,1,1)+TAUR*TR2 
-         CC(1,K,1,1) = SN*(CC(1,K,1,1)+TR2) 
-         TI2 = CC(2,K,1,2)+CC(2,K,1,3) 
-         CI2 = CC(2,K,1,1)+TAUR*TI2 
-         CC(2,K,1,1) = SN*(CC(2,K,1,1)+TI2) 
-         CR3 = TAUI*(CC(1,K,1,2)-CC(1,K,1,3)) 
-         CI3 = TAUI*(CC(2,K,1,2)-CC(2,K,1,3)) 
-         CC(1,K,1,2) = SN*(CR2-CI3) 
-         CC(1,K,1,3) = SN*(CR2+CI3) 
-         CC(2,K,1,2) = SN*(CI2+CR3) 
-         CC(2,K,1,3) = SN*(CI2-CR3) 
-  101 END DO 
-      RETURN 
-  106 DO 107 K=1,L1 
-         TR2 = CC(1,K,1,2)+CC(1,K,1,3) 
-         CR2 = CC(1,K,1,1)+TAUR*TR2 
-         CH(1,K,1,1) = SN*(CC(1,K,1,1)+TR2) 
-         TI2 = CC(2,K,1,2)+CC(2,K,1,3) 
-         CI2 = CC(2,K,1,1)+TAUR*TI2 
-         CH(2,K,1,1) = SN*(CC(2,K,1,1)+TI2) 
-         CR3 = TAUI*(CC(1,K,1,2)-CC(1,K,1,3)) 
-         CI3 = TAUI*(CC(2,K,1,2)-CC(2,K,1,3)) 
-         CH(1,K,2,1) = SN*(CR2-CI3) 
-         CH(1,K,3,1) = SN*(CR2+CI3) 
-         CH(2,K,2,1) = SN*(CI2+CR3) 
-         CH(2,K,3,1) = SN*(CI2-CR3) 
-  107 END DO 
-      RETURN 
-  102 DO 103 K=1,L1 
-         TR2 = CC(1,K,1,2)+CC(1,K,1,3) 
-         CR2 = CC(1,K,1,1)+TAUR*TR2 
-         CH(1,K,1,1) = CC(1,K,1,1)+TR2 
-         TI2 = CC(2,K,1,2)+CC(2,K,1,3) 
-         CI2 = CC(2,K,1,1)+TAUR*TI2 
-         CH(2,K,1,1) = CC(2,K,1,1)+TI2 
-         CR3 = TAUI*(CC(1,K,1,2)-CC(1,K,1,3)) 
-         CI3 = TAUI*(CC(2,K,1,2)-CC(2,K,1,3)) 
-         CH(1,K,2,1) = CR2-CI3 
-         CH(1,K,3,1) = CR2+CI3 
-         CH(2,K,2,1) = CI2+CR3 
-         CH(2,K,3,1) = CI2-CR3 
-  103 END DO 
-      DO 105 I=2,IDO 
-        DO 104 K=1,L1 
-            TR2 = CC(1,K,I,2)+CC(1,K,I,3) 
-            CR2 = CC(1,K,I,1)+TAUR*TR2 
-            CH(1,K,1,I) = CC(1,K,I,1)+TR2 
-            TI2 = CC(2,K,I,2)+CC(2,K,I,3) 
-            CI2 = CC(2,K,I,1)+TAUR*TI2 
-            CH(2,K,1,I) = CC(2,K,I,1)+TI2 
-            CR3 = TAUI*(CC(1,K,I,2)-CC(1,K,I,3)) 
-            CI3 = TAUI*(CC(2,K,I,2)-CC(2,K,I,3)) 
-            DR2 = CR2-CI3 
-            DR3 = CR2+CI3 
-            DI2 = CI2+CR3 
-            DI3 = CI2-CR3 
-            CH(2,K,2,I) = WA(I,1,1)*DI2-WA(I,1,2)*DR2 
-            CH(1,K,2,I) = WA(I,1,1)*DR2+WA(I,1,2)*DI2 
-            CH(2,K,3,I) = WA(I,2,1)*DI3-WA(I,2,2)*DR3 
-            CH(1,K,3,I) = WA(I,2,1)*DR3+WA(I,2,2)*DI3 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine c1f3kf ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! C1F3KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,l1,ido,3)
+  real ( kind = 4 ) ch(in2,l1,3,ido)
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) di2
+  real ( kind = 4 ) di3
+  real ( kind = 4 ) dr2
+  real ( kind = 4 ) dr3
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) sn
+  real ( kind = 4 ), parameter :: taui = -0.866025403784439E+00
+  real ( kind = 4 ), parameter :: taur = -0.5E+00
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) wa(ido,2,2)
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+
+      tr2 = cc(1,k,1,2)+cc(1,k,1,3)
+      cr2 = cc(1,k,1,1)+taur*tr2
+      ch(1,k,1,1) = cc(1,k,1,1)+tr2
+      ti2 = cc(2,k,1,2)+cc(2,k,1,3)
+      ci2 = cc(2,k,1,1)+taur*ti2
+      ch(2,k,1,1) = cc(2,k,1,1)+ti2
+      cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3))
+      ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3))
+
+      ch(1,k,2,1) = cr2 - ci3
+      ch(1,k,3,1) = cr2 + ci3
+      ch(2,k,2,1) = ci2 + cr3
+      ch(2,k,3,1) = ci2 - cr3
+
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+
+        tr2 = cc(1,k,i,2)+cc(1,k,i,3)
+        cr2 = cc(1,k,i,1)+taur*tr2
+        ch(1,k,1,i) = cc(1,k,i,1)+tr2
+        ti2 = cc(2,k,i,2)+cc(2,k,i,3)
+        ci2 = cc(2,k,i,1)+taur*ti2
+        ch(2,k,1,i) = cc(2,k,i,1)+ti2
+        cr3 = taui*(cc(1,k,i,2)-cc(1,k,i,3))
+        ci3 = taui*(cc(2,k,i,2)-cc(2,k,i,3))
+
+        dr2 = cr2 - ci3
+        dr3 = cr2 + ci3
+        di2 = ci2 + cr3
+        di3 = ci2 - cr3
+
+        ch(2,k,2,i) = wa(i,1,1) * di2 - wa(i,1,2) * dr2
+        ch(1,k,2,i) = wa(i,1,1) * dr2 + wa(i,1,2) * di2
+        ch(2,k,3,i) = wa(i,2,1) * di3 - wa(i,2,2) * dr3
+        ch(1,k,3,i) = wa(i,2,1) * dr3 + wa(i,2,2) * di3
+
+       end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0E+00 / real ( 3 * l1, kind = 4 )
+
+    do k = 1, l1
+      tr2 = cc(1,k,1,2)+cc(1,k,1,3)
+      cr2 = cc(1,k,1,1)+taur*tr2
+      ch(1,k,1,1) = sn*(cc(1,k,1,1)+tr2)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,3)
+      ci2 = cc(2,k,1,1)+taur*ti2
+      ch(2,k,1,1) = sn*(cc(2,k,1,1)+ti2)
+      cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3))
+      ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3))
+
+      ch(1,k,2,1) = sn*(cr2-ci3)
+      ch(1,k,3,1) = sn*(cr2+ci3)
+      ch(2,k,2,1) = sn*(ci2+cr3)
+      ch(2,k,3,1) = sn*(ci2-cr3)
+
+    end do
+
+  else
+
+    sn = 1.0E+00 / real ( 3 * l1, kind = 4 )
+
+    do k = 1, l1
+
+      tr2 = cc(1,k,1,2)+cc(1,k,1,3)
+      cr2 = cc(1,k,1,1)+taur*tr2
+      cc(1,k,1,1) = sn*(cc(1,k,1,1)+tr2)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,3)
+      ci2 = cc(2,k,1,1)+taur*ti2
+      cc(2,k,1,1) = sn*(cc(2,k,1,1)+ti2)
+      cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3))
+      ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3))
+
+      cc(1,k,1,2) = sn*(cr2-ci3)
+      cc(1,k,1,3) = sn*(cr2+ci3)
+      cc(2,k,1,2) = sn*(ci2+cr3)
+      cc(2,k,1,3) = sn*(ci2-cr3)
+
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1f4kb.F b/wrfv2_fire/external/fftpack/fftpack5/c1f4kb.F
index c7d6c62e..540fa1ee 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1f4kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1f4kb.F
@@ -1,82 +1,139 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1f4kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1F4KB (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
-      REAL CC(IN1,L1,IDO,4),CH(IN2,L1,4,IDO),WA(IDO,3,2) 
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
-      DO 101 K=1,L1 
-         TI1 = CC(2,K,1,1)-CC(2,K,1,3) 
-         TI2 = CC(2,K,1,1)+CC(2,K,1,3) 
-         TR4 = CC(2,K,1,4)-CC(2,K,1,2) 
-         TI3 = CC(2,K,1,2)+CC(2,K,1,4) 
-         TR1 = CC(1,K,1,1)-CC(1,K,1,3) 
-         TR2 = CC(1,K,1,1)+CC(1,K,1,3) 
-         TI4 = CC(1,K,1,2)-CC(1,K,1,4) 
-         TR3 = CC(1,K,1,2)+CC(1,K,1,4) 
-         CC(1,K,1,1) = TR2+TR3 
-         CC(1,K,1,3) = TR2-TR3 
-         CC(2,K,1,1) = TI2+TI3 
-         CC(2,K,1,3) = TI2-TI3 
-         CC(1,K,1,2) = TR1+TR4 
-         CC(1,K,1,4) = TR1-TR4 
-         CC(2,K,1,2) = TI1+TI4 
-         CC(2,K,1,4) = TI1-TI4 
-  101 END DO 
-      RETURN 
-  102 DO 103 K=1,L1 
-         TI1 = CC(2,K,1,1)-CC(2,K,1,3) 
-         TI2 = CC(2,K,1,1)+CC(2,K,1,3) 
-         TR4 = CC(2,K,1,4)-CC(2,K,1,2) 
-         TI3 = CC(2,K,1,2)+CC(2,K,1,4) 
-         TR1 = CC(1,K,1,1)-CC(1,K,1,3) 
-         TR2 = CC(1,K,1,1)+CC(1,K,1,3) 
-         TI4 = CC(1,K,1,2)-CC(1,K,1,4) 
-         TR3 = CC(1,K,1,2)+CC(1,K,1,4) 
-         CH(1,K,1,1) = TR2+TR3 
-         CH(1,K,3,1) = TR2-TR3 
-         CH(2,K,1,1) = TI2+TI3 
-         CH(2,K,3,1) = TI2-TI3 
-         CH(1,K,2,1) = TR1+TR4 
-         CH(1,K,4,1) = TR1-TR4 
-         CH(2,K,2,1) = TI1+TI4 
-         CH(2,K,4,1) = TI1-TI4 
-  103 END DO 
-      IF(IDO .EQ. 1) RETURN 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-            TI1 = CC(2,K,I,1)-CC(2,K,I,3) 
-            TI2 = CC(2,K,I,1)+CC(2,K,I,3) 
-            TI3 = CC(2,K,I,2)+CC(2,K,I,4) 
-            TR4 = CC(2,K,I,4)-CC(2,K,I,2) 
-            TR1 = CC(1,K,I,1)-CC(1,K,I,3) 
-            TR2 = CC(1,K,I,1)+CC(1,K,I,3) 
-            TI4 = CC(1,K,I,2)-CC(1,K,I,4) 
-            TR3 = CC(1,K,I,2)+CC(1,K,I,4) 
-            CH(1,K,1,I) = TR2+TR3 
-            CR3 = TR2-TR3 
-            CH(2,K,1,I) = TI2+TI3 
-            CI3 = TI2-TI3 
-            CR2 = TR1+TR4 
-            CR4 = TR1-TR4 
-            CI2 = TI1+TI4 
-            CI4 = TI1-TI4 
-            CH(1,K,2,I) = WA(I,1,1)*CR2-WA(I,1,2)*CI2 
-            CH(2,K,2,I) = WA(I,1,1)*CI2+WA(I,1,2)*CR2 
-            CH(1,K,3,I) = WA(I,2,1)*CR3-WA(I,2,2)*CI3 
-            CH(2,K,3,I) = WA(I,2,1)*CI3+WA(I,2,2)*CR3 
-            CH(1,K,4,I) = WA(I,3,1)*CR4-WA(I,3,2)*CI4 
-            CH(2,K,4,I) = WA(I,3,1)*CI4+WA(I,3,2)*CR4 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine c1f4kb ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! C1F4KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,l1,ido,4)
+  real ( kind = 4 ) ch(in2,l1,4,ido)
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) ci4
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) cr4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) ti1
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) ti3
+  real ( kind = 4 ) ti4
+  real ( kind = 4 ) tr1
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) tr3
+  real ( kind = 4 ) tr4
+  real ( kind = 4 ) wa(ido,3,2)
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      ti1 = cc(2,k,1,1)-cc(2,k,1,3)
+      ti2 = cc(2,k,1,1)+cc(2,k,1,3)
+      tr4 = cc(2,k,1,4)-cc(2,k,1,2)
+      ti3 = cc(2,k,1,2)+cc(2,k,1,4)
+      tr1 = cc(1,k,1,1)-cc(1,k,1,3)
+      tr2 = cc(1,k,1,1)+cc(1,k,1,3)
+      ti4 = cc(1,k,1,2)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,2)+cc(1,k,1,4)
+      ch(1,k,1,1) = tr2+tr3
+      ch(1,k,3,1) = tr2-tr3
+      ch(2,k,1,1) = ti2+ti3
+      ch(2,k,3,1) = ti2-ti3
+      ch(1,k,2,1) = tr1+tr4
+      ch(1,k,4,1) = tr1-tr4
+      ch(2,k,2,1) = ti1+ti4
+      ch(2,k,4,1) = ti1-ti4
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+
+        ti1 = cc(2,k,i,1)-cc(2,k,i,3)
+        ti2 = cc(2,k,i,1)+cc(2,k,i,3)
+        ti3 = cc(2,k,i,2)+cc(2,k,i,4)
+        tr4 = cc(2,k,i,4)-cc(2,k,i,2)
+        tr1 = cc(1,k,i,1)-cc(1,k,i,3)
+        tr2 = cc(1,k,i,1)+cc(1,k,i,3)
+        ti4 = cc(1,k,i,2)-cc(1,k,i,4)
+        tr3 = cc(1,k,i,2)+cc(1,k,i,4)
+        ch(1,k,1,i) = tr2+tr3
+        cr3 = tr2-tr3
+        ch(2,k,1,i) = ti2+ti3
+        ci3 = ti2-ti3
+        cr2 = tr1+tr4
+        cr4 = tr1-tr4
+        ci2 = ti1+ti4
+        ci4 = ti1-ti4
+
+        ch(1,k,2,i) = wa(i,1,1)*cr2-wa(i,1,2)*ci2
+        ch(2,k,2,i) = wa(i,1,1)*ci2+wa(i,1,2)*cr2
+        ch(1,k,3,i) = wa(i,2,1)*cr3-wa(i,2,2)*ci3
+        ch(2,k,3,i) = wa(i,2,1)*ci3+wa(i,2,2)*cr3
+        ch(1,k,4,i) = wa(i,3,1)*cr4-wa(i,3,2)*ci4
+        ch(2,k,4,i) = wa(i,3,1)*ci4+wa(i,3,2)*cr4
+
+       end do
+    end do
+
+  else
+
+    do k = 1, l1
+       ti1 = cc(2,k,1,1)-cc(2,k,1,3)
+       ti2 = cc(2,k,1,1)+cc(2,k,1,3)
+       tr4 = cc(2,k,1,4)-cc(2,k,1,2)
+       ti3 = cc(2,k,1,2)+cc(2,k,1,4)
+       tr1 = cc(1,k,1,1)-cc(1,k,1,3)
+       tr2 = cc(1,k,1,1)+cc(1,k,1,3)
+       ti4 = cc(1,k,1,2)-cc(1,k,1,4)
+       tr3 = cc(1,k,1,2)+cc(1,k,1,4)
+       cc(1,k,1,1) = tr2+tr3
+       cc(1,k,1,3) = tr2-tr3
+       cc(2,k,1,1) = ti2+ti3
+       cc(2,k,1,3) = ti2-ti3
+       cc(1,k,1,2) = tr1+tr4
+       cc(1,k,1,4) = tr1-tr4
+       cc(2,k,1,2) = ti1+ti4
+       cc(2,k,1,4) = ti1-ti4
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1f4kf.F b/wrfv2_fire/external/fftpack/fftpack5/c1f4kf.F
index 5e043b13..e557cbbd 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1f4kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1f4kf.F
@@ -1,102 +1,165 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1f4kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1F4KF (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
-      REAL CC(IN1,L1,IDO,4),CH(IN2,L1,4,IDO),WA(IDO,3,2) 
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      IF (IDO .GT. 1) GO TO 102 
-      SN = 1./REAL(4*L1) 
-      IF (NA .EQ. 1) GO TO 106 
-      DO 101 K=1,L1 
-         TI1 = CC(2,K,1,1)-CC(2,K,1,3) 
-         TI2 = CC(2,K,1,1)+CC(2,K,1,3) 
-         TR4 = CC(2,K,1,2)-CC(2,K,1,4) 
-         TI3 = CC(2,K,1,2)+CC(2,K,1,4) 
-         TR1 = CC(1,K,1,1)-CC(1,K,1,3) 
-         TR2 = CC(1,K,1,1)+CC(1,K,1,3) 
-         TI4 = CC(1,K,1,4)-CC(1,K,1,2) 
-         TR3 = CC(1,K,1,2)+CC(1,K,1,4) 
-         CC(1,K,1,1) = SN*(TR2+TR3) 
-         CC(1,K,1,3) = SN*(TR2-TR3) 
-         CC(2,K,1,1) = SN*(TI2+TI3) 
-         CC(2,K,1,3) = SN*(TI2-TI3) 
-         CC(1,K,1,2) = SN*(TR1+TR4) 
-         CC(1,K,1,4) = SN*(TR1-TR4) 
-         CC(2,K,1,2) = SN*(TI1+TI4) 
-         CC(2,K,1,4) = SN*(TI1-TI4) 
-  101 END DO 
-      RETURN 
-  106 DO 107 K=1,L1 
-         TI1 = CC(2,K,1,1)-CC(2,K,1,3) 
-         TI2 = CC(2,K,1,1)+CC(2,K,1,3) 
-         TR4 = CC(2,K,1,2)-CC(2,K,1,4) 
-         TI3 = CC(2,K,1,2)+CC(2,K,1,4) 
-         TR1 = CC(1,K,1,1)-CC(1,K,1,3) 
-         TR2 = CC(1,K,1,1)+CC(1,K,1,3) 
-         TI4 = CC(1,K,1,4)-CC(1,K,1,2) 
-         TR3 = CC(1,K,1,2)+CC(1,K,1,4) 
-         CH(1,K,1,1) = SN*(TR2+TR3) 
-         CH(1,K,3,1) = SN*(TR2-TR3) 
-         CH(2,K,1,1) = SN*(TI2+TI3) 
-         CH(2,K,3,1) = SN*(TI2-TI3) 
-         CH(1,K,2,1) = SN*(TR1+TR4) 
-         CH(1,K,4,1) = SN*(TR1-TR4) 
-         CH(2,K,2,1) = SN*(TI1+TI4) 
-         CH(2,K,4,1) = SN*(TI1-TI4) 
-  107 END DO 
-      RETURN 
-  102 DO 103 K=1,L1 
-         TI1 = CC(2,K,1,1)-CC(2,K,1,3) 
-         TI2 = CC(2,K,1,1)+CC(2,K,1,3) 
-         TR4 = CC(2,K,1,2)-CC(2,K,1,4) 
-         TI3 = CC(2,K,1,2)+CC(2,K,1,4) 
-         TR1 = CC(1,K,1,1)-CC(1,K,1,3) 
-         TR2 = CC(1,K,1,1)+CC(1,K,1,3) 
-         TI4 = CC(1,K,1,4)-CC(1,K,1,2) 
-         TR3 = CC(1,K,1,2)+CC(1,K,1,4) 
-         CH(1,K,1,1) = TR2+TR3 
-         CH(1,K,3,1) = TR2-TR3 
-         CH(2,K,1,1) = TI2+TI3 
-         CH(2,K,3,1) = TI2-TI3 
-         CH(1,K,2,1) = TR1+TR4 
-         CH(1,K,4,1) = TR1-TR4 
-         CH(2,K,2,1) = TI1+TI4 
-         CH(2,K,4,1) = TI1-TI4 
-  103 END DO 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-            TI1 = CC(2,K,I,1)-CC(2,K,I,3) 
-            TI2 = CC(2,K,I,1)+CC(2,K,I,3) 
-            TI3 = CC(2,K,I,2)+CC(2,K,I,4) 
-            TR4 = CC(2,K,I,2)-CC(2,K,I,4) 
-            TR1 = CC(1,K,I,1)-CC(1,K,I,3) 
-            TR2 = CC(1,K,I,1)+CC(1,K,I,3) 
-            TI4 = CC(1,K,I,4)-CC(1,K,I,2) 
-            TR3 = CC(1,K,I,2)+CC(1,K,I,4) 
-            CH(1,K,1,I) = TR2+TR3 
-            CR3 = TR2-TR3 
-            CH(2,K,1,I) = TI2+TI3 
-            CI3 = TI2-TI3 
-            CR2 = TR1+TR4 
-            CR4 = TR1-TR4 
-            CI2 = TI1+TI4 
-            CI4 = TI1-TI4 
-            CH(1,K,2,I) = WA(I,1,1)*CR2+WA(I,1,2)*CI2 
-            CH(2,K,2,I) = WA(I,1,1)*CI2-WA(I,1,2)*CR2 
-            CH(1,K,3,I) = WA(I,2,1)*CR3+WA(I,2,2)*CI3 
-            CH(2,K,3,I) = WA(I,2,1)*CI3-WA(I,2,2)*CR3 
-            CH(1,K,4,I) = WA(I,3,1)*CR4+WA(I,3,2)*CI4 
-            CH(2,K,4,I) = WA(I,3,1)*CI4-WA(I,3,2)*CR4 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine c1f4kf ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! C1F4KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,l1,ido,4)
+  real ( kind = 4 ) ch(in2,l1,4,ido)
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) ci4
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) cr4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) sn
+  real ( kind = 4 ) ti1
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) ti3
+  real ( kind = 4 ) ti4
+  real ( kind = 4 ) tr1
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) tr3
+  real ( kind = 4 ) tr4
+  real ( kind = 4 ) wa(ido,3,2)
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+
+      ti1 = cc(2,k,1,1)-cc(2,k,1,3)
+      ti2 = cc(2,k,1,1)+cc(2,k,1,3)
+      tr4 = cc(2,k,1,2)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,2)+cc(2,k,1,4)
+      tr1 = cc(1,k,1,1)-cc(1,k,1,3)
+      tr2 = cc(1,k,1,1)+cc(1,k,1,3)
+      ti4 = cc(1,k,1,4)-cc(1,k,1,2)
+      tr3 = cc(1,k,1,2)+cc(1,k,1,4)
+
+      ch(1,k,1,1) = tr2 + tr3
+      ch(1,k,3,1) = tr2 - tr3
+      ch(2,k,1,1) = ti2 + ti3
+      ch(2,k,3,1) = ti2 - ti3
+      ch(1,k,2,1) = tr1 + tr4
+      ch(1,k,4,1) = tr1 - tr4
+      ch(2,k,2,1) = ti1 + ti4
+      ch(2,k,4,1) = ti1 - ti4
+
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        ti1 = cc(2,k,i,1)-cc(2,k,i,3)
+        ti2 = cc(2,k,i,1)+cc(2,k,i,3)
+        ti3 = cc(2,k,i,2)+cc(2,k,i,4)
+        tr4 = cc(2,k,i,2)-cc(2,k,i,4)
+        tr1 = cc(1,k,i,1)-cc(1,k,i,3)
+        tr2 = cc(1,k,i,1)+cc(1,k,i,3)
+        ti4 = cc(1,k,i,4)-cc(1,k,i,2)
+        tr3 = cc(1,k,i,2)+cc(1,k,i,4)
+        ch(1,k,1,i) = tr2+tr3
+        cr3 = tr2-tr3
+        ch(2,k,1,i) = ti2+ti3
+        ci3 = ti2-ti3
+        cr2 = tr1+tr4
+        cr4 = tr1-tr4
+        ci2 = ti1+ti4
+        ci4 = ti1-ti4
+        ch(1,k,2,i) = wa(i,1,1)*cr2+wa(i,1,2)*ci2
+        ch(2,k,2,i) = wa(i,1,1)*ci2-wa(i,1,2)*cr2
+        ch(1,k,3,i) = wa(i,2,1)*cr3+wa(i,2,2)*ci3
+        ch(2,k,3,i) = wa(i,2,1)*ci3-wa(i,2,2)*cr3
+        ch(1,k,4,i) = wa(i,3,1)*cr4+wa(i,3,2)*ci4
+        ch(2,k,4,i) = wa(i,3,1)*ci4-wa(i,3,2)*cr4
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0E+00 / real ( 4 * l1, kind = 4 )
+
+    do k = 1, l1
+      ti1 = cc(2,k,1,1)-cc(2,k,1,3)
+      ti2 = cc(2,k,1,1)+cc(2,k,1,3)
+      tr4 = cc(2,k,1,2)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,2)+cc(2,k,1,4)
+      tr1 = cc(1,k,1,1)-cc(1,k,1,3)
+      tr2 = cc(1,k,1,1)+cc(1,k,1,3)
+      ti4 = cc(1,k,1,4)-cc(1,k,1,2)
+      tr3 = cc(1,k,1,2)+cc(1,k,1,4)
+      ch(1,k,1,1) = sn*(tr2+tr3)
+      ch(1,k,3,1) = sn*(tr2-tr3)
+      ch(2,k,1,1) = sn*(ti2+ti3)
+      ch(2,k,3,1) = sn*(ti2-ti3)
+      ch(1,k,2,1) = sn*(tr1+tr4)
+      ch(1,k,4,1) = sn*(tr1-tr4)
+      ch(2,k,2,1) = sn*(ti1+ti4)
+      ch(2,k,4,1) = sn*(ti1-ti4)
+    end do
+
+  else
+
+    sn = 1.0E+00 / real ( 4 * l1, kind = 4 )
+
+    do k = 1, l1
+      ti1 = cc(2,k,1,1)-cc(2,k,1,3)
+      ti2 = cc(2,k,1,1)+cc(2,k,1,3)
+      tr4 = cc(2,k,1,2)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,2)+cc(2,k,1,4)
+      tr1 = cc(1,k,1,1)-cc(1,k,1,3)
+      tr2 = cc(1,k,1,1)+cc(1,k,1,3)
+      ti4 = cc(1,k,1,4)-cc(1,k,1,2)
+      tr3 = cc(1,k,1,2)+cc(1,k,1,4)
+      cc(1,k,1,1) = sn*(tr2+tr3)
+      cc(1,k,1,3) = sn*(tr2-tr3)
+      cc(2,k,1,1) = sn*(ti2+ti3)
+      cc(2,k,1,3) = sn*(ti2-ti3)
+      cc(1,k,1,2) = sn*(tr1+tr4)
+      cc(1,k,1,4) = sn*(tr1-tr4)
+      cc(2,k,1,2) = sn*(ti1+ti4)
+      cc(2,k,1,4) = sn*(ti1-ti4)
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1f5kb.F b/wrfv2_fire/external/fftpack/fftpack5/c1f5kb.F
index a75fc563..70f8ad9a 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1f5kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1f5kb.F
@@ -1,118 +1,186 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1f5kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1F5KB (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
-      REAL  CC(IN1,L1,IDO,5),CH(IN2,L1,5,IDO),WA(IDO,4,2) 
-      DATA TR11,TI11,TR12,TI12 /.3090169943749474,.9510565162951536,    &
-     &-.8090169943749474,.5877852522924731/                             
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
-      DO 101 K=1,L1 
-         TI5 = CC(2,K,1,2)-CC(2,K,1,5) 
-         TI2 = CC(2,K,1,2)+CC(2,K,1,5) 
-         TI4 = CC(2,K,1,3)-CC(2,K,1,4) 
-         TI3 = CC(2,K,1,3)+CC(2,K,1,4) 
-         TR5 = CC(1,K,1,2)-CC(1,K,1,5) 
-         TR2 = CC(1,K,1,2)+CC(1,K,1,5) 
-         TR4 = CC(1,K,1,3)-CC(1,K,1,4) 
-         TR3 = CC(1,K,1,3)+CC(1,K,1,4) 
-         CHOLD1 = CC(1,K,1,1)+TR2+TR3 
-         CHOLD2 = CC(2,K,1,1)+TI2+TI3 
-         CR2 = CC(1,K,1,1)+TR11*TR2+TR12*TR3 
-         CI2 = CC(2,K,1,1)+TR11*TI2+TR12*TI3 
-         CR3 = CC(1,K,1,1)+TR12*TR2+TR11*TR3 
-         CI3 = CC(2,K,1,1)+TR12*TI2+TR11*TI3 
-         CC(1,K,1,1) = CHOLD1 
-         CC(2,K,1,1) = CHOLD2 
-         CR5 = TI11*TR5+TI12*TR4 
-         CI5 = TI11*TI5+TI12*TI4 
-         CR4 = TI12*TR5-TI11*TR4 
-         CI4 = TI12*TI5-TI11*TI4 
-         CC(1,K,1,2) = CR2-CI5 
-         CC(1,K,1,5) = CR2+CI5 
-         CC(2,K,1,2) = CI2+CR5 
-         CC(2,K,1,3) = CI3+CR4 
-         CC(1,K,1,3) = CR3-CI4 
-         CC(1,K,1,4) = CR3+CI4 
-         CC(2,K,1,4) = CI3-CR4 
-         CC(2,K,1,5) = CI2-CR5 
-  101 END DO 
-      RETURN 
-  102 DO 103 K=1,L1 
-         TI5 = CC(2,K,1,2)-CC(2,K,1,5) 
-         TI2 = CC(2,K,1,2)+CC(2,K,1,5) 
-         TI4 = CC(2,K,1,3)-CC(2,K,1,4) 
-         TI3 = CC(2,K,1,3)+CC(2,K,1,4) 
-         TR5 = CC(1,K,1,2)-CC(1,K,1,5) 
-         TR2 = CC(1,K,1,2)+CC(1,K,1,5) 
-         TR4 = CC(1,K,1,3)-CC(1,K,1,4) 
-         TR3 = CC(1,K,1,3)+CC(1,K,1,4) 
-         CH(1,K,1,1) = CC(1,K,1,1)+TR2+TR3 
-         CH(2,K,1,1) = CC(2,K,1,1)+TI2+TI3 
-         CR2 = CC(1,K,1,1)+TR11*TR2+TR12*TR3 
-         CI2 = CC(2,K,1,1)+TR11*TI2+TR12*TI3 
-         CR3 = CC(1,K,1,1)+TR12*TR2+TR11*TR3 
-         CI3 = CC(2,K,1,1)+TR12*TI2+TR11*TI3 
-         CR5 = TI11*TR5+TI12*TR4 
-         CI5 = TI11*TI5+TI12*TI4 
-         CR4 = TI12*TR5-TI11*TR4 
-         CI4 = TI12*TI5-TI11*TI4 
-         CH(1,K,2,1) = CR2-CI5 
-         CH(1,K,5,1) = CR2+CI5 
-         CH(2,K,2,1) = CI2+CR5 
-         CH(2,K,3,1) = CI3+CR4 
-         CH(1,K,3,1) = CR3-CI4 
-         CH(1,K,4,1) = CR3+CI4 
-         CH(2,K,4,1) = CI3-CR4 
-         CH(2,K,5,1) = CI2-CR5 
-  103 END DO 
-      IF(IDO .EQ. 1) RETURN 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-            TI5 = CC(2,K,I,2)-CC(2,K,I,5) 
-            TI2 = CC(2,K,I,2)+CC(2,K,I,5) 
-            TI4 = CC(2,K,I,3)-CC(2,K,I,4) 
-            TI3 = CC(2,K,I,3)+CC(2,K,I,4) 
-            TR5 = CC(1,K,I,2)-CC(1,K,I,5) 
-            TR2 = CC(1,K,I,2)+CC(1,K,I,5) 
-            TR4 = CC(1,K,I,3)-CC(1,K,I,4) 
-            TR3 = CC(1,K,I,3)+CC(1,K,I,4) 
-            CH(1,K,1,I) = CC(1,K,I,1)+TR2+TR3 
-            CH(2,K,1,I) = CC(2,K,I,1)+TI2+TI3 
-            CR2 = CC(1,K,I,1)+TR11*TR2+TR12*TR3 
-            CI2 = CC(2,K,I,1)+TR11*TI2+TR12*TI3 
-            CR3 = CC(1,K,I,1)+TR12*TR2+TR11*TR3 
-            CI3 = CC(2,K,I,1)+TR12*TI2+TR11*TI3 
-            CR5 = TI11*TR5+TI12*TR4 
-            CI5 = TI11*TI5+TI12*TI4 
-            CR4 = TI12*TR5-TI11*TR4 
-            CI4 = TI12*TI5-TI11*TI4 
-            DR3 = CR3-CI4 
-            DR4 = CR3+CI4 
-            DI3 = CI3+CR4 
-            DI4 = CI3-CR4 
-            DR5 = CR2+CI5 
-            DR2 = CR2-CI5 
-            DI5 = CI2-CR5 
-            DI2 = CI2+CR5 
-            CH(1,K,2,I) = WA(I,1,1)*DR2-WA(I,1,2)*DI2 
-            CH(2,K,2,I) = WA(I,1,1)*DI2+WA(I,1,2)*DR2 
-            CH(1,K,3,I) = WA(I,2,1)*DR3-WA(I,2,2)*DI3 
-            CH(2,K,3,I) = WA(I,2,1)*DI3+WA(I,2,2)*DR3 
-            CH(1,K,4,I) = WA(I,3,1)*DR4-WA(I,3,2)*DI4 
-            CH(2,K,4,I) = WA(I,3,1)*DI4+WA(I,3,2)*DR4 
-            CH(1,K,5,I) = WA(I,4,1)*DR5-WA(I,4,2)*DI5 
-            CH(2,K,5,I) = WA(I,4,1)*DI5+WA(I,4,2)*DR5 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine c1f5kb ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! C1F5KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,l1,ido,5)
+  real ( kind = 4 ) ch(in2,l1,5,ido)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) ci4
+  real ( kind = 4 ) ci5
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) cr4
+  real ( kind = 4 ) cr5
+  real ( kind = 4 ) di2
+  real ( kind = 4 ) di3
+  real ( kind = 4 ) di4
+  real ( kind = 4 ) di5
+  real ( kind = 4 ) dr2
+  real ( kind = 4 ) dr3
+  real ( kind = 4 ) dr4
+  real ( kind = 4 ) dr5
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) ti3
+  real ( kind = 4 ) ti4
+  real ( kind = 4 ) ti5
+  real ( kind = 4 ), parameter :: ti11 =  0.9510565162951536E+00
+  real ( kind = 4 ), parameter :: ti12 =  0.5877852522924731E+00
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) tr3
+  real ( kind = 4 ) tr4
+  real ( kind = 4 ) tr5
+  real ( kind = 4 ), parameter :: tr11 =  0.3090169943749474E+00
+  real ( kind = 4 ), parameter :: tr12 = -0.8090169943749474E+00
+  real ( kind = 4 ) wa(ido,4,2)
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      ti5 = cc(2,k,1,2)-cc(2,k,1,5)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,5)
+      ti4 = cc(2,k,1,3)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,3)+cc(2,k,1,4)
+      tr5 = cc(1,k,1,2)-cc(1,k,1,5)
+      tr2 = cc(1,k,1,2)+cc(1,k,1,5)
+      tr4 = cc(1,k,1,3)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,3)+cc(1,k,1,4)
+      ch(1,k,1,1) = cc(1,k,1,1)+tr2+tr3
+      ch(2,k,1,1) = cc(2,k,1,1)+ti2+ti3
+      cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3
+      ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3
+      cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3
+      ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3
+      cr5 = ti11*tr5+ti12*tr4
+      ci5 = ti11*ti5+ti12*ti4
+      cr4 = ti12*tr5-ti11*tr4
+      ci4 = ti12*ti5-ti11*ti4
+      ch(1,k,2,1) = cr2-ci5
+      ch(1,k,5,1) = cr2+ci5
+      ch(2,k,2,1) = ci2+cr5
+      ch(2,k,3,1) = ci3+cr4
+      ch(1,k,3,1) = cr3-ci4
+      ch(1,k,4,1) = cr3+ci4
+      ch(2,k,4,1) = ci3-cr4
+      ch(2,k,5,1) = ci2-cr5
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        ti5 = cc(2,k,i,2)-cc(2,k,i,5)
+        ti2 = cc(2,k,i,2)+cc(2,k,i,5)
+        ti4 = cc(2,k,i,3)-cc(2,k,i,4)
+        ti3 = cc(2,k,i,3)+cc(2,k,i,4)
+        tr5 = cc(1,k,i,2)-cc(1,k,i,5)
+        tr2 = cc(1,k,i,2)+cc(1,k,i,5)
+        tr4 = cc(1,k,i,3)-cc(1,k,i,4)
+        tr3 = cc(1,k,i,3)+cc(1,k,i,4)
+        ch(1,k,1,i) = cc(1,k,i,1)+tr2+tr3
+        ch(2,k,1,i) = cc(2,k,i,1)+ti2+ti3
+        cr2 = cc(1,k,i,1)+tr11*tr2+tr12*tr3
+        ci2 = cc(2,k,i,1)+tr11*ti2+tr12*ti3
+        cr3 = cc(1,k,i,1)+tr12*tr2+tr11*tr3
+        ci3 = cc(2,k,i,1)+tr12*ti2+tr11*ti3
+        cr5 = ti11*tr5+ti12*tr4
+        ci5 = ti11*ti5+ti12*ti4
+        cr4 = ti12*tr5-ti11*tr4
+        ci4 = ti12*ti5-ti11*ti4
+        dr3 = cr3-ci4
+        dr4 = cr3+ci4
+        di3 = ci3+cr4
+        di4 = ci3-cr4
+        dr5 = cr2+ci5
+        dr2 = cr2-ci5
+        di5 = ci2-cr5
+        di2 = ci2+cr5
+        ch(1,k,2,i) = wa(i,1,1)*dr2-wa(i,1,2)*di2
+        ch(2,k,2,i) = wa(i,1,1)*di2+wa(i,1,2)*dr2
+        ch(1,k,3,i) = wa(i,2,1)*dr3-wa(i,2,2)*di3
+        ch(2,k,3,i) = wa(i,2,1)*di3+wa(i,2,2)*dr3
+        ch(1,k,4,i) = wa(i,3,1)*dr4-wa(i,3,2)*di4
+        ch(2,k,4,i) = wa(i,3,1)*di4+wa(i,3,2)*dr4
+        ch(1,k,5,i) = wa(i,4,1)*dr5-wa(i,4,2)*di5
+        ch(2,k,5,i) = wa(i,4,1)*di5+wa(i,4,2)*dr5
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      ti5 = cc(2,k,1,2)-cc(2,k,1,5)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,5)
+      ti4 = cc(2,k,1,3)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,3)+cc(2,k,1,4)
+      tr5 = cc(1,k,1,2)-cc(1,k,1,5)
+      tr2 = cc(1,k,1,2)+cc(1,k,1,5)
+      tr4 = cc(1,k,1,3)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,3)+cc(1,k,1,4)
+      chold1 = cc(1,k,1,1)+tr2+tr3
+      chold2 = cc(2,k,1,1)+ti2+ti3
+      cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3
+      ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3
+      cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3
+      ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3
+      cc(1,k,1,1) = chold1
+      cc(2,k,1,1) = chold2
+      cr5 = ti11*tr5+ti12*tr4
+      ci5 = ti11*ti5+ti12*ti4
+      cr4 = ti12*tr5-ti11*tr4
+      ci4 = ti12*ti5-ti11*ti4
+      cc(1,k,1,2) = cr2-ci5
+      cc(1,k,1,5) = cr2+ci5
+      cc(2,k,1,2) = ci2+cr5
+      cc(2,k,1,3) = ci3+cr4
+      cc(1,k,1,3) = cr3-ci4
+      cc(1,k,1,4) = cr3+ci4
+      cc(2,k,1,4) = ci3-cr4
+      cc(2,k,1,5) = ci2-cr5
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1f5kf.F b/wrfv2_fire/external/fftpack/fftpack5/c1f5kf.F
index ec72e3c6..45673b90 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1f5kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1f5kf.F
@@ -1,149 +1,238 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1f5kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1F5KF (IDO,L1,NA,CC,IN1,CH,IN2,WA) 
-      REAL  CC(IN1,L1,IDO,5),CH(IN2,L1,5,IDO),WA(IDO,4,2) 
-      DATA TR11,TI11,TR12,TI12 /.3090169943749474,-.9510565162951536,   &
-     &-.8090169943749474,-.5877852522924731/                            
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      IF (IDO .GT. 1) GO TO 102 
-      SN = 1./REAL(5*L1) 
-      IF (NA .EQ. 1) GO TO 106 
-      DO 101 K=1,L1 
-! rav    DO 101 M1=1,M1D,IM1                                            
-         TI5 = CC(2,K,1,2)-CC(2,K,1,5) 
-         TI2 = CC(2,K,1,2)+CC(2,K,1,5) 
-         TI4 = CC(2,K,1,3)-CC(2,K,1,4) 
-         TI3 = CC(2,K,1,3)+CC(2,K,1,4) 
-         TR5 = CC(1,K,1,2)-CC(1,K,1,5) 
-         TR2 = CC(1,K,1,2)+CC(1,K,1,5) 
-         TR4 = CC(1,K,1,3)-CC(1,K,1,4) 
-         TR3 = CC(1,K,1,3)+CC(1,K,1,4) 
-         CHOLD1 = SN*(CC(1,K,1,1)+TR2+TR3) 
-         CHOLD2 = SN*(CC(2,K,1,1)+TI2+TI3) 
-         CR2 = CC(1,K,1,1)+TR11*TR2+TR12*TR3 
-         CI2 = CC(2,K,1,1)+TR11*TI2+TR12*TI3 
-         CR3 = CC(1,K,1,1)+TR12*TR2+TR11*TR3 
-         CI3 = CC(2,K,1,1)+TR12*TI2+TR11*TI3 
-         CC(1,K,1,1) = CHOLD1 
-         CC(2,K,1,1) = CHOLD2 
-         CR5 = TI11*TR5+TI12*TR4 
-         CI5 = TI11*TI5+TI12*TI4 
-         CR4 = TI12*TR5-TI11*TR4 
-         CI4 = TI12*TI5-TI11*TI4 
-         CC(1,K,1,2) = SN*(CR2-CI5) 
-         CC(1,K,1,5) = SN*(CR2+CI5) 
-         CC(2,K,1,2) = SN*(CI2+CR5) 
-         CC(2,K,1,3) = SN*(CI3+CR4) 
-         CC(1,K,1,3) = SN*(CR3-CI4) 
-         CC(1,K,1,4) = SN*(CR3+CI4) 
-         CC(2,K,1,4) = SN*(CI3-CR4) 
-         CC(2,K,1,5) = SN*(CI2-CR5) 
-  101 END DO 
-      RETURN 
-  106 DO 107 K=1,L1 
-         TI5 = CC(2,K,1,2)-CC(2,K,1,5) 
-         TI2 = CC(2,K,1,2)+CC(2,K,1,5) 
-         TI4 = CC(2,K,1,3)-CC(2,K,1,4) 
-         TI3 = CC(2,K,1,3)+CC(2,K,1,4) 
-         TR5 = CC(1,K,1,2)-CC(1,K,1,5) 
-         TR2 = CC(1,K,1,2)+CC(1,K,1,5) 
-         TR4 = CC(1,K,1,3)-CC(1,K,1,4) 
-         TR3 = CC(1,K,1,3)+CC(1,K,1,4) 
-         CH(1,K,1,1) = SN*(CC(1,K,1,1)+TR2+TR3) 
-         CH(2,K,1,1) = SN*(CC(2,K,1,1)+TI2+TI3) 
-         CR2 = CC(1,K,1,1)+TR11*TR2+TR12*TR3 
-         CI2 = CC(2,K,1,1)+TR11*TI2+TR12*TI3 
-         CR3 = CC(1,K,1,1)+TR12*TR2+TR11*TR3 
-         CI3 = CC(2,K,1,1)+TR12*TI2+TR11*TI3 
-         CR5 = TI11*TR5+TI12*TR4 
-         CI5 = TI11*TI5+TI12*TI4 
-         CR4 = TI12*TR5-TI11*TR4 
-         CI4 = TI12*TI5-TI11*TI4 
-         CH(1,K,2,1) = SN*(CR2-CI5) 
-         CH(1,K,5,1) = SN*(CR2+CI5) 
-         CH(2,K,2,1) = SN*(CI2+CR5) 
-         CH(2,K,3,1) = SN*(CI3+CR4) 
-         CH(1,K,3,1) = SN*(CR3-CI4) 
-         CH(1,K,4,1) = SN*(CR3+CI4) 
-         CH(2,K,4,1) = SN*(CI3-CR4) 
-         CH(2,K,5,1) = SN*(CI2-CR5) 
-  107 END DO 
-      RETURN 
-  102 DO 103 K=1,L1 
-         TI5 = CC(2,K,1,2)-CC(2,K,1,5) 
-         TI2 = CC(2,K,1,2)+CC(2,K,1,5) 
-         TI4 = CC(2,K,1,3)-CC(2,K,1,4) 
-         TI3 = CC(2,K,1,3)+CC(2,K,1,4) 
-         TR5 = CC(1,K,1,2)-CC(1,K,1,5) 
-         TR2 = CC(1,K,1,2)+CC(1,K,1,5) 
-         TR4 = CC(1,K,1,3)-CC(1,K,1,4) 
-         TR3 = CC(1,K,1,3)+CC(1,K,1,4) 
-         CH(1,K,1,1) = CC(1,K,1,1)+TR2+TR3 
-         CH(2,K,1,1) = CC(2,K,1,1)+TI2+TI3 
-         CR2 = CC(1,K,1,1)+TR11*TR2+TR12*TR3 
-         CI2 = CC(2,K,1,1)+TR11*TI2+TR12*TI3 
-         CR3 = CC(1,K,1,1)+TR12*TR2+TR11*TR3 
-         CI3 = CC(2,K,1,1)+TR12*TI2+TR11*TI3 
-         CR5 = TI11*TR5+TI12*TR4 
-         CI5 = TI11*TI5+TI12*TI4 
-         CR4 = TI12*TR5-TI11*TR4 
-         CI4 = TI12*TI5-TI11*TI4 
-         CH(1,K,2,1) = CR2-CI5 
-         CH(1,K,5,1) = CR2+CI5 
-         CH(2,K,2,1) = CI2+CR5 
-         CH(2,K,3,1) = CI3+CR4 
-         CH(1,K,3,1) = CR3-CI4 
-         CH(1,K,4,1) = CR3+CI4 
-         CH(2,K,4,1) = CI3-CR4 
-         CH(2,K,5,1) = CI2-CR5 
-  103 END DO 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-            TI5 = CC(2,K,I,2)-CC(2,K,I,5) 
-            TI2 = CC(2,K,I,2)+CC(2,K,I,5) 
-            TI4 = CC(2,K,I,3)-CC(2,K,I,4) 
-            TI3 = CC(2,K,I,3)+CC(2,K,I,4) 
-            TR5 = CC(1,K,I,2)-CC(1,K,I,5) 
-            TR2 = CC(1,K,I,2)+CC(1,K,I,5) 
-            TR4 = CC(1,K,I,3)-CC(1,K,I,4) 
-            TR3 = CC(1,K,I,3)+CC(1,K,I,4) 
-            CH(1,K,1,I) = CC(1,K,I,1)+TR2+TR3 
-            CH(2,K,1,I) = CC(2,K,I,1)+TI2+TI3 
-            CR2 = CC(1,K,I,1)+TR11*TR2+TR12*TR3 
-            CI2 = CC(2,K,I,1)+TR11*TI2+TR12*TI3 
-            CR3 = CC(1,K,I,1)+TR12*TR2+TR11*TR3 
-            CI3 = CC(2,K,I,1)+TR12*TI2+TR11*TI3 
-            CR5 = TI11*TR5+TI12*TR4 
-            CI5 = TI11*TI5+TI12*TI4 
-            CR4 = TI12*TR5-TI11*TR4 
-            CI4 = TI12*TI5-TI11*TI4 
-            DR3 = CR3-CI4 
-            DR4 = CR3+CI4 
-            DI3 = CI3+CR4 
-            DI4 = CI3-CR4 
-            DR5 = CR2+CI5 
-            DR2 = CR2-CI5 
-            DI5 = CI2-CR5 
-            DI2 = CI2+CR5 
-            CH(1,K,2,I) = WA(I,1,1)*DR2+WA(I,1,2)*DI2 
-            CH(2,K,2,I) = WA(I,1,1)*DI2-WA(I,1,2)*DR2 
-            CH(1,K,3,I) = WA(I,2,1)*DR3+WA(I,2,2)*DI3 
-            CH(2,K,3,I) = WA(I,2,1)*DI3-WA(I,2,2)*DR3 
-            CH(1,K,4,I) = WA(I,3,1)*DR4+WA(I,3,2)*DI4 
-            CH(2,K,4,I) = WA(I,3,1)*DI4-WA(I,3,2)*DR4 
-            CH(1,K,5,I) = WA(I,4,1)*DR5+WA(I,4,2)*DI5 
-            CH(2,K,5,I) = WA(I,4,1)*DI5-WA(I,4,2)*DR5 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine c1f5kf ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! C1F5KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,l1,ido,5)
+  real ( kind = 4 ) ch(in2,l1,5,ido)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) ci4
+  real ( kind = 4 ) ci5
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) cr4
+  real ( kind = 4 ) cr5
+  real ( kind = 4 ) di2
+  real ( kind = 4 ) di3
+  real ( kind = 4 ) di4
+  real ( kind = 4 ) di5
+  real ( kind = 4 ) dr2
+  real ( kind = 4 ) dr3
+  real ( kind = 4 ) dr4
+  real ( kind = 4 ) dr5
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) sn
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) ti3
+  real ( kind = 4 ) ti4
+  real ( kind = 4 ) ti5
+  real ( kind = 4 ), parameter :: ti11 = -0.9510565162951536E+00
+  real ( kind = 4 ), parameter :: ti12 = -0.5877852522924731E+00
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) tr3
+  real ( kind = 4 ) tr4
+  real ( kind = 4 ) tr5
+  real ( kind = 4 ), parameter :: tr11 =  0.3090169943749474E+00
+  real ( kind = 4 ), parameter :: tr12 = -0.8090169943749474E+00
+  real ( kind = 4 ) wa(ido,4,2)
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+
+      ti5 = cc(2,k,1,2)-cc(2,k,1,5)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,5)
+      ti4 = cc(2,k,1,3)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,3)+cc(2,k,1,4)
+      tr5 = cc(1,k,1,2)-cc(1,k,1,5)
+      tr2 = cc(1,k,1,2)+cc(1,k,1,5)
+      tr4 = cc(1,k,1,3)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,3)+cc(1,k,1,4)
+
+      ch(1,k,1,1) = cc(1,k,1,1)+tr2+tr3
+      ch(2,k,1,1) = cc(2,k,1,1)+ti2+ti3
+      cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3
+      ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3
+      cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3
+      ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3
+      cr5 = ti11*tr5+ti12*tr4
+      ci5 = ti11*ti5+ti12*ti4
+      cr4 = ti12*tr5-ti11*tr4
+      ci4 = ti12*ti5-ti11*ti4
+      ch(1,k,2,1) = cr2-ci5
+      ch(1,k,5,1) = cr2+ci5
+      ch(2,k,2,1) = ci2+cr5
+      ch(2,k,3,1) = ci3+cr4
+      ch(1,k,3,1) = cr3-ci4
+      ch(1,k,4,1) = cr3+ci4
+      ch(2,k,4,1) = ci3-cr4
+      ch(2,k,5,1) = ci2-cr5
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+
+        ti5 = cc(2,k,i,2)-cc(2,k,i,5)
+        ti2 = cc(2,k,i,2)+cc(2,k,i,5)
+        ti4 = cc(2,k,i,3)-cc(2,k,i,4)
+        ti3 = cc(2,k,i,3)+cc(2,k,i,4)
+        tr5 = cc(1,k,i,2)-cc(1,k,i,5)
+        tr2 = cc(1,k,i,2)+cc(1,k,i,5)
+        tr4 = cc(1,k,i,3)-cc(1,k,i,4)
+        tr3 = cc(1,k,i,3)+cc(1,k,i,4)
+
+        ch(1,k,1,i) = cc(1,k,i,1)+tr2+tr3
+        ch(2,k,1,i) = cc(2,k,i,1)+ti2+ti3
+        cr2 = cc(1,k,i,1)+tr11*tr2+tr12*tr3
+        ci2 = cc(2,k,i,1)+tr11*ti2+tr12*ti3
+        cr3 = cc(1,k,i,1)+tr12*tr2+tr11*tr3
+        ci3 = cc(2,k,i,1)+tr12*ti2+tr11*ti3
+        cr5 = ti11*tr5+ti12*tr4
+        ci5 = ti11*ti5+ti12*ti4
+        cr4 = ti12*tr5-ti11*tr4
+        ci4 = ti12*ti5-ti11*ti4
+        dr3 = cr3-ci4
+        dr4 = cr3+ci4
+        di3 = ci3+cr4
+        di4 = ci3-cr4
+        dr5 = cr2+ci5
+        dr2 = cr2-ci5
+        di5 = ci2-cr5
+        di2 = ci2+cr5
+        ch(1,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2
+        ch(2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2
+        ch(1,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3
+        ch(2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3
+        ch(1,k,4,i) = wa(i,3,1)*dr4+wa(i,3,2)*di4
+        ch(2,k,4,i) = wa(i,3,1)*di4-wa(i,3,2)*dr4
+        ch(1,k,5,i) = wa(i,4,1)*dr5+wa(i,4,2)*di5
+        ch(2,k,5,i) = wa(i,4,1)*di5-wa(i,4,2)*dr5
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0E+00 / real ( 5 * l1, kind = 4 )
+
+    do k = 1, l1
+
+      ti5 = cc(2,k,1,2)-cc(2,k,1,5)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,5)
+      ti4 = cc(2,k,1,3)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,3)+cc(2,k,1,4)
+      tr5 = cc(1,k,1,2)-cc(1,k,1,5)
+      tr2 = cc(1,k,1,2)+cc(1,k,1,5)
+      tr4 = cc(1,k,1,3)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,3)+cc(1,k,1,4)
+
+      ch(1,k,1,1) = sn*(cc(1,k,1,1)+tr2+tr3)
+      ch(2,k,1,1) = sn*(cc(2,k,1,1)+ti2+ti3)
+
+      cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3
+      ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3
+      cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3
+      ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3
+      cr5 = ti11*tr5+ti12*tr4
+      ci5 = ti11*ti5+ti12*ti4
+      cr4 = ti12*tr5-ti11*tr4
+      ci4 = ti12*ti5-ti11*ti4
+
+      ch(1,k,2,1) = sn*(cr2-ci5)
+      ch(1,k,5,1) = sn*(cr2+ci5)
+      ch(2,k,2,1) = sn*(ci2+cr5)
+      ch(2,k,3,1) = sn*(ci3+cr4)
+      ch(1,k,3,1) = sn*(cr3-ci4)
+      ch(1,k,4,1) = sn*(cr3+ci4)
+      ch(2,k,4,1) = sn*(ci3-cr4)
+      ch(2,k,5,1) = sn*(ci2-cr5)
+
+    end do
+
+  else
+
+    sn = 1.0E+00 / real ( 5 * l1, kind = 4 )
+
+    do k = 1, l1
+
+      ti5 = cc(2,k,1,2)-cc(2,k,1,5)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,5)
+      ti4 = cc(2,k,1,3)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,3)+cc(2,k,1,4)
+      tr5 = cc(1,k,1,2)-cc(1,k,1,5)
+      tr2 = cc(1,k,1,2)+cc(1,k,1,5)
+      tr4 = cc(1,k,1,3)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,3)+cc(1,k,1,4)
+
+      chold1 = sn*(cc(1,k,1,1)+tr2+tr3)
+      chold2 = sn*(cc(2,k,1,1)+ti2+ti3)
+
+      cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3
+      ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3
+      cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3
+      ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3
+
+      cc(1,k,1,1) = chold1
+      cc(2,k,1,1) = chold2
+
+      cr5 = ti11*tr5+ti12*tr4
+      ci5 = ti11*ti5+ti12*ti4
+      cr4 = ti12*tr5-ti11*tr4
+      ci4 = ti12*ti5-ti11*ti4
+
+      cc(1,k,1,2) = sn*(cr2-ci5)
+      cc(1,k,1,5) = sn*(cr2+ci5)
+      cc(2,k,1,2) = sn*(ci2+cr5)
+      cc(2,k,1,3) = sn*(ci3+cr4)
+      cc(1,k,1,3) = sn*(cr3-ci4)
+      cc(1,k,1,4) = sn*(cr3+ci4)
+      cc(2,k,1,4) = sn*(ci3-cr4)
+      cc(2,k,1,5) = sn*(ci2-cr5)
+
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1fgkb.F b/wrfv2_fire/external/fftpack/fftpack5/c1fgkb.F
index e8a0b517..5e52430b 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1fgkb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1fgkb.F
@@ -1,111 +1,178 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1fgkb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1FGKB (IDO,IP,L1,LID,NA,CC,CC1,IN1,                   &
-     &                                      CH,CH1,IN2,WA)              
-      REAL       CH(IN2,L1,IDO,IP) ,CC(IN1,L1,IP,IDO),                  &
-     &                CC1(IN1,LID,IP)    ,CH1(IN2,LID,IP)  ,            &
-     &                WA(IDO,IP-1,2)                                    
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      IPP2 = IP+2 
-      IPPH = (IP+1)/2 
-      DO 110 KI=1,LID 
-         CH1(1,KI,1) = CC1(1,KI,1) 
-         CH1(2,KI,1) = CC1(2,KI,1) 
-  110 END DO 
-      DO 111 J=2,IPPH 
-         JC = IPP2-J 
-         DO 112 KI=1,LID 
-            CH1(1,KI,J) =  CC1(1,KI,J)+CC1(1,KI,JC) 
-            CH1(1,KI,JC) = CC1(1,KI,J)-CC1(1,KI,JC) 
-            CH1(2,KI,J) =  CC1(2,KI,J)+CC1(2,KI,JC) 
-            CH1(2,KI,JC) = CC1(2,KI,J)-CC1(2,KI,JC) 
-  112    CONTINUE 
-  111 END DO 
-      DO 118 J=2,IPPH 
-         DO 117 KI=1,LID 
-            CC1(1,KI,1) = CC1(1,KI,1)+CH1(1,KI,J) 
-            CC1(2,KI,1) = CC1(2,KI,1)+CH1(2,KI,J) 
-  117    CONTINUE 
-  118 END DO 
-      DO 116 L=2,IPPH 
-         LC = IPP2-L 
-         DO 113 KI=1,LID 
-            CC1(1,KI,L) = CH1(1,KI,1)+WA(1,L-1,1)*CH1(1,KI,2) 
-            CC1(1,KI,LC) = WA(1,L-1,2)*CH1(1,KI,IP) 
-            CC1(2,KI,L) = CH1(2,KI,1)+WA(1,L-1,1)*CH1(2,KI,2) 
-            CC1(2,KI,LC) = WA(1,L-1,2)*CH1(2,KI,IP) 
-  113    CONTINUE 
-         DO 115 J=3,IPPH 
-            JC = IPP2-J 
-            IDLJ = MOD((L-1)*(J-1),IP) 
-            WAR = WA(1,IDLJ,1) 
-            WAI = WA(1,IDLJ,2) 
-            DO 114 KI=1,LID 
-               CC1(1,KI,L) = CC1(1,KI,L)+WAR*CH1(1,KI,J) 
-               CC1(1,KI,LC) = CC1(1,KI,LC)+WAI*CH1(1,KI,JC) 
-               CC1(2,KI,L) = CC1(2,KI,L)+WAR*CH1(2,KI,J) 
-               CC1(2,KI,LC) = CC1(2,KI,LC)+WAI*CH1(2,KI,JC) 
-  114       CONTINUE 
-  115    CONTINUE 
-  116 END DO 
-      IF(IDO.GT.1 .OR. NA.EQ.1) GO TO 136 
-      DO 120 J=2,IPPH 
-         JC = IPP2-J 
-         DO 119 KI=1,LID 
-            CHOLD1 = CC1(1,KI,J)-CC1(2,KI,JC) 
-            CHOLD2 = CC1(1,KI,J)+CC1(2,KI,JC) 
-            CC1(1,KI,J) = CHOLD1 
-            CC1(2,KI,JC) = CC1(2,KI,J)-CC1(1,KI,JC) 
-            CC1(2,KI,J) = CC1(2,KI,J)+CC1(1,KI,JC) 
-            CC1(1,KI,JC) = CHOLD2 
-  119    CONTINUE 
-  120 END DO 
-      RETURN 
-  136 DO 137 KI=1,LID 
-         CH1(1,KI,1) = CC1(1,KI,1) 
-         CH1(2,KI,1) = CC1(2,KI,1) 
-  137 END DO 
-      DO 135 J=2,IPPH 
-         JC = IPP2-J 
-         DO 134 KI=1,LID 
-            CH1(1,KI,J) = CC1(1,KI,J)-CC1(2,KI,JC) 
-            CH1(1,KI,JC) = CC1(1,KI,J)+CC1(2,KI,JC) 
-            CH1(2,KI,JC) = CC1(2,KI,J)-CC1(1,KI,JC) 
-            CH1(2,KI,J) = CC1(2,KI,J)+CC1(1,KI,JC) 
-  134    CONTINUE 
-  135 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      DO 131 I=1,IDO 
-         DO 130 K=1,L1 
-            CC(1,K,1,I) = CH(1,K,I,1) 
-            CC(2,K,1,I) = CH(2,K,I,1) 
-  130    CONTINUE 
-  131 END DO 
-      DO 123 J=2,IP 
-         DO 122 K=1,L1 
-            CC(1,K,J,1) = CH(1,K,1,J) 
-            CC(2,K,J,1) = CH(2,K,1,J) 
-  122    CONTINUE 
-  123 END DO 
-      DO 126 J=2,IP 
-         DO 125 I=2,IDO 
-            DO 124 K=1,L1 
-               CC(1,K,J,I) = WA(I,J-1,1)*CH(1,K,I,J)                    &
-     &                      -WA(I,J-1,2)*CH(2,K,I,J)                    
-               CC(2,K,J,I) = WA(I,J-1,1)*CH(2,K,I,J)                    &
-     &                      +WA(I,J-1,2)*CH(1,K,I,J)                    
-  124       CONTINUE 
-  125    CONTINUE 
-  126 END DO 
-      RETURN 
-      END                                           
+subroutine c1fgkb ( ido, ip, l1, lid, na, cc, cc1, in1, ch, ch1, in2, wa )
+
+!*****************************************************************************80
+!
+!! C1FGKB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) lid
+
+  real ( kind = 4 ) cc(in1,l1,ip,ido)
+  real ( kind = 4 ) cc1(in1,lid,ip)
+  real ( kind = 4 ) ch(in2,l1,ido,ip)
+  real ( kind = 4 ) ch1(in2,lid,ip)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) idlj
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) ki
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) wa(ido,ip-1,2)
+  real ( kind = 4 ) wai
+  real ( kind = 4 ) war
+
+  ipp2 = ip + 2
+  ipph = ( ip + 1 ) / 2
+  do ki = 1, lid
+    ch1(1,ki,1) = cc1(1,ki,1)
+    ch1(2,ki,1) = cc1(2,ki,1)
+  end do
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do ki = 1, lid
+      ch1(1,ki,j) =  cc1(1,ki,j) + cc1(1,ki,jc)
+      ch1(1,ki,jc) = cc1(1,ki,j) - cc1(1,ki,jc)
+      ch1(2,ki,j) =  cc1(2,ki,j) + cc1(2,ki,jc)
+      ch1(2,ki,jc) = cc1(2,ki,j) - cc1(2,ki,jc)
+    end do
+  end do
+
+  do j = 2, ipph
+    do ki = 1, lid
+      cc1(1,ki,1) = cc1(1,ki,1)+ch1(1,ki,j)
+      cc1(2,ki,1) = cc1(2,ki,1)+ch1(2,ki,j)
+    end do
+  end do
+
+  do l = 2, ipph
+
+     lc = ipp2 - l
+     do ki = 1, lid
+       cc1(1,ki,l) = ch1(1,ki,1)+wa(1,l-1,1)*ch1(1,ki,2)
+       cc1(1,ki,lc) = wa(1,l-1,2)*ch1(1,ki,ip)
+       cc1(2,ki,l) = ch1(2,ki,1)+wa(1,l-1,1)*ch1(2,ki,2)
+       cc1(2,ki,lc) = wa(1,l-1,2)*ch1(2,ki,ip)
+     end do
+
+     do j = 3, ipph
+       jc = ipp2 - j
+       idlj = mod ( ( l - 1 ) * ( j - 1 ), ip )
+       war = wa(1,idlj,1)
+       wai = wa(1,idlj,2)
+       do ki = 1, lid
+         cc1(1,ki,l) = cc1(1,ki,l)+war*ch1(1,ki,j)
+         cc1(1,ki,lc) = cc1(1,ki,lc)+wai*ch1(1,ki,jc)
+         cc1(2,ki,l) = cc1(2,ki,l)+war*ch1(2,ki,j)
+         cc1(2,ki,lc) = cc1(2,ki,lc)+wai*ch1(2,ki,jc)
+       end do
+     end do
+
+  end do
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do ki = 1, lid
+      ch1(1,ki,1) = cc1(1,ki,1)
+      ch1(2,ki,1) = cc1(2,ki,1)
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        ch1(1,ki,j) = cc1(1,ki,j)-cc1(2,ki,jc)
+        ch1(1,ki,jc) = cc1(1,ki,j)+cc1(2,ki,jc)
+        ch1(2,ki,jc) = cc1(2,ki,j)-cc1(1,ki,jc)
+        ch1(2,ki,j) = cc1(2,ki,j)+cc1(1,ki,jc)
+      end do
+    end do
+
+    if ( ido == 1 ) then
+      return
+    end if
+
+    do i = 1, ido
+      do k = 1, l1
+        cc(1,k,1,i) = ch(1,k,i,1)
+        cc(2,k,1,i) = ch(2,k,i,1)
+      end do
+    end do
+
+    do j = 2, ip
+      do k = 1, l1
+        cc(1,k,j,1) = ch(1,k,1,j)
+        cc(2,k,j,1) = ch(2,k,1,j)
+      end do
+    end do
+
+    do j = 2, ip
+      do i = 2, ido
+        do k = 1, l1
+          cc(1,k,j,i) = wa(i,j-1,1)*ch(1,k,i,j) &
+                       -wa(i,j-1,2)*ch(2,k,i,j)
+          cc(2,k,j,i) = wa(i,j-1,1)*ch(2,k,i,j) &
+                       +wa(i,j-1,2)*ch(1,k,i,j)
+        end do
+      end do
+    end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        chold1 = cc1(1,ki,j)-cc1(2,ki,jc)
+        chold2 = cc1(1,ki,j)+cc1(2,ki,jc)
+        cc1(1,ki,j) = chold1
+        cc1(2,ki,jc) = cc1(2,ki,j)-cc1(1,ki,jc)
+        cc1(2,ki,j) = cc1(2,ki,j)+cc1(1,ki,jc)
+        cc1(1,ki,jc) = chold2
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1fgkf.F b/wrfv2_fire/external/fftpack/fftpack5/c1fgkf.F
index 9115da45..0611954f 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1fgkf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1fgkf.F
@@ -1,130 +1,204 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1fgkf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1FGKF (IDO,IP,L1,LID,NA,CC,CC1,IN1,                   &
-     &                                      CH,CH1,IN2,WA)              
-      REAL       CH(IN2,L1,IDO,IP) ,CC(IN1,L1,IP,IDO),                  &
-     &                CC1(IN1,LID,IP)    ,CH1(IN2,LID,IP)  ,            &
-     &                WA(IDO,IP-1,2)                                    
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      IPP2 = IP+2 
-      IPPH = (IP+1)/2 
-      DO 110 KI=1,LID 
-         CH1(1,KI,1) = CC1(1,KI,1) 
-         CH1(2,KI,1) = CC1(2,KI,1) 
-  110 END DO 
-      DO 111 J=2,IPPH 
-         JC = IPP2-J 
-         DO 112 KI=1,LID 
-            CH1(1,KI,J) =  CC1(1,KI,J)+CC1(1,KI,JC) 
-            CH1(1,KI,JC) = CC1(1,KI,J)-CC1(1,KI,JC) 
-            CH1(2,KI,J) =  CC1(2,KI,J)+CC1(2,KI,JC) 
-            CH1(2,KI,JC) = CC1(2,KI,J)-CC1(2,KI,JC) 
-  112    CONTINUE 
-  111 END DO 
-      DO 118 J=2,IPPH 
-         DO 117 KI=1,LID 
-            CC1(1,KI,1) = CC1(1,KI,1)+CH1(1,KI,J) 
-            CC1(2,KI,1) = CC1(2,KI,1)+CH1(2,KI,J) 
-  117    CONTINUE 
-  118 END DO 
-      DO 116 L=2,IPPH 
-         LC = IPP2-L 
-         DO 113 KI=1,LID 
-            CC1(1,KI,L) = CH1(1,KI,1)+WA(1,L-1,1)*CH1(1,KI,2) 
-            CC1(1,KI,LC) = -WA(1,L-1,2)*CH1(1,KI,IP) 
-            CC1(2,KI,L) = CH1(2,KI,1)+WA(1,L-1,1)*CH1(2,KI,2) 
-            CC1(2,KI,LC) = -WA(1,L-1,2)*CH1(2,KI,IP) 
-  113    CONTINUE 
-         DO 115 J=3,IPPH 
-            JC = IPP2-J 
-            IDLJ = MOD((L-1)*(J-1),IP) 
-            WAR = WA(1,IDLJ,1) 
-            WAI = -WA(1,IDLJ,2) 
-            DO 114 KI=1,LID 
-               CC1(1,KI,L) = CC1(1,KI,L)+WAR*CH1(1,KI,J) 
-               CC1(1,KI,LC) = CC1(1,KI,LC)+WAI*CH1(1,KI,JC) 
-               CC1(2,KI,L) = CC1(2,KI,L)+WAR*CH1(2,KI,J) 
-               CC1(2,KI,LC) = CC1(2,KI,LC)+WAI*CH1(2,KI,JC) 
-  114       CONTINUE 
-  115    CONTINUE 
-  116 END DO 
-      IF (IDO .GT. 1) GO TO 136 
-      SN = 1./REAL(IP*L1) 
-      IF (NA .EQ. 1) GO TO 146 
-      DO 149 KI=1,LID 
-         CC1(1,KI,1) = SN*CC1(1,KI,1) 
-         CC1(2,KI,1) = SN*CC1(2,KI,1) 
-  149 END DO 
-      DO 120 J=2,IPPH 
-         JC = IPP2-J 
-         DO 119 KI=1,LID 
-            CHOLD1 = SN*(CC1(1,KI,J)-CC1(2,KI,JC)) 
-            CHOLD2 = SN*(CC1(1,KI,J)+CC1(2,KI,JC)) 
-            CC1(1,KI,J) = CHOLD1 
-            CC1(2,KI,JC) = SN*(CC1(2,KI,J)-CC1(1,KI,JC)) 
-            CC1(2,KI,J) = SN*(CC1(2,KI,J)+CC1(1,KI,JC)) 
-            CC1(1,KI,JC) = CHOLD2 
-  119    CONTINUE 
-  120 END DO 
-      RETURN 
-  146 DO 147 KI=1,LID 
-         CH1(1,KI,1) = SN*CC1(1,KI,1) 
-         CH1(2,KI,1) = SN*CC1(2,KI,1) 
-  147 END DO 
-      DO 145 J=2,IPPH 
-         JC = IPP2-J 
-         DO 144 KI=1,LID 
-            CH1(1,KI,J) = SN*(CC1(1,KI,J)-CC1(2,KI,JC)) 
-            CH1(2,KI,J) = SN*(CC1(2,KI,J)+CC1(1,KI,JC)) 
-            CH1(1,KI,JC) = SN*(CC1(1,KI,J)+CC1(2,KI,JC)) 
-            CH1(2,KI,JC) = SN*(CC1(2,KI,J)-CC1(1,KI,JC)) 
-  144    CONTINUE 
-  145 END DO 
-      RETURN 
-  136 DO 137 KI=1,LID 
-         CH1(1,KI,1) = CC1(1,KI,1) 
-         CH1(2,KI,1) = CC1(2,KI,1) 
-  137 END DO 
-      DO 135 J=2,IPPH 
-         JC = IPP2-J 
-         DO 134 KI=1,LID 
-            CH1(1,KI,J) = CC1(1,KI,J)-CC1(2,KI,JC) 
-            CH1(2,KI,J) = CC1(2,KI,J)+CC1(1,KI,JC) 
-            CH1(1,KI,JC) = CC1(1,KI,J)+CC1(2,KI,JC) 
-            CH1(2,KI,JC) = CC1(2,KI,J)-CC1(1,KI,JC) 
-  134    CONTINUE 
-  135 END DO 
-      DO 131 I=1,IDO 
-         DO 130 K=1,L1 
-            CC(1,K,1,I) = CH(1,K,I,1) 
-            CC(2,K,1,I) = CH(2,K,I,1) 
-  130    CONTINUE 
-  131 END DO 
-      DO 123 J=2,IP 
-         DO 122 K=1,L1 
-            CC(1,K,J,1) = CH(1,K,1,J) 
-            CC(2,K,J,1) = CH(2,K,1,J) 
-  122    CONTINUE 
-  123 END DO 
-      DO 126 J=2,IP 
-         DO 125 I=2,IDO 
-            DO 124 K=1,L1 
-               CC(1,K,J,I) = WA(I,J-1,1)*CH(1,K,I,J)                    &
-     &                      +WA(I,J-1,2)*CH(2,K,I,J)                    
-               CC(2,K,J,I) = WA(I,J-1,1)*CH(2,K,I,J)                    &
-     &                      -WA(I,J-1,2)*CH(1,K,I,J)                    
-  124       CONTINUE 
-  125    CONTINUE 
-  126 END DO 
-      RETURN 
-      END                                           
+subroutine c1fgkf ( ido, ip, l1, lid, na, cc, cc1, in1, ch, ch1, in2, wa )
+
+!*****************************************************************************80
+!
+!! C1FGKF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) lid
+
+  real ( kind = 4 ) cc(in1,l1,ip,ido)
+  real ( kind = 4 ) cc1(in1,lid,ip)
+  real ( kind = 4 ) ch(in2,l1,ido,ip)
+  real ( kind = 4 ) ch1(in2,lid,ip)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) idlj
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) ki
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) sn
+  real ( kind = 4 ) wa(ido,ip-1,2)
+  real ( kind = 4 ) wai
+  real ( kind = 4 ) war
+
+  ipp2 = ip+2
+  ipph = (ip+1)/2
+
+  do ki = 1, lid
+    ch1(1,ki,1) = cc1(1,ki,1)
+    ch1(2,ki,1) = cc1(2,ki,1)
+  end do
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do ki = 1, lid
+      ch1(1,ki,j) =  cc1(1,ki,j)+cc1(1,ki,jc)
+      ch1(1,ki,jc) = cc1(1,ki,j)-cc1(1,ki,jc)
+      ch1(2,ki,j) =  cc1(2,ki,j)+cc1(2,ki,jc)
+      ch1(2,ki,jc) = cc1(2,ki,j)-cc1(2,ki,jc)
+    end do
+  end do
+
+  do j = 2, ipph
+    do ki = 1, lid
+      cc1(1,ki,1) = cc1(1,ki,1) + ch1(1,ki,j)
+      cc1(2,ki,1) = cc1(2,ki,1) + ch1(2,ki,j)
+    end do
+  end do
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+
+    do ki = 1, lid
+      cc1(1,ki,l)  = ch1(1,ki,1) + wa(1,l-1,1) * ch1(1,ki,2)
+      cc1(1,ki,lc) =             - wa(1,l-1,2) * ch1(1,ki,ip)
+      cc1(2,ki,l)  = ch1(2,ki,1) + wa(1,l-1,1) * ch1(2,ki,2)
+      cc1(2,ki,lc) =             - wa(1,l-1,2) * ch1(2,ki,ip)
+    end do
+
+    do j = 3, ipph
+
+      jc = ipp2 - j
+      idlj = mod ( ( l - 1 ) * ( j - 1 ), ip )
+      war = wa(1,idlj,1)
+      wai = -wa(1,idlj,2)
+
+      do ki = 1, lid
+        cc1(1,ki,l) = cc1(1,ki,l)+war*ch1(1,ki,j)
+        cc1(1,ki,lc) = cc1(1,ki,lc)+wai*ch1(1,ki,jc)
+        cc1(2,ki,l) = cc1(2,ki,l)+war*ch1(2,ki,j)
+        cc1(2,ki,lc) = cc1(2,ki,lc)+wai*ch1(2,ki,jc)
+      end do
+
+    end do
+
+  end do
+
+  if ( 1 < ido ) then
+
+    do ki = 1, lid
+      ch1(1,ki,1) = cc1(1,ki,1)
+      ch1(2,ki,1) = cc1(2,ki,1)
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        ch1(1,ki,j) = cc1(1,ki,j)-cc1(2,ki,jc)
+        ch1(2,ki,j) = cc1(2,ki,j)+cc1(1,ki,jc)
+        ch1(1,ki,jc) = cc1(1,ki,j)+cc1(2,ki,jc)
+        ch1(2,ki,jc) = cc1(2,ki,j)-cc1(1,ki,jc)
+      end do
+    end do
+
+    do i = 1, ido
+      do k = 1, l1
+        cc(1,k,1,i) = ch(1,k,i,1)
+        cc(2,k,1,i) = ch(2,k,i,1)
+      end do
+    end do
+
+    do j = 2, ip
+      do k = 1, l1
+        cc(1,k,j,1) = ch(1,k,1,j)
+        cc(2,k,j,1) = ch(2,k,1,j)
+      end do
+    end do
+
+    do j = 2, ip
+      do i = 2, ido
+        do k = 1, l1
+          cc(1,k,j,i) = wa(i,j-1,1)*ch(1,k,i,j) + wa(i,j-1,2)*ch(2,k,i,j)
+          cc(2,k,j,i) = wa(i,j-1,1)*ch(2,k,i,j) - wa(i,j-1,2)*ch(1,k,i,j)
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0E+00 / real ( ip * l1, kind = 4 )
+
+    do ki = 1, lid
+      ch1(1,ki,1) = sn * cc1(1,ki,1)
+      ch1(2,ki,1) = sn * cc1(2,ki,1)
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        ch1(1,ki,j) =  sn * ( cc1(1,ki,j) - cc1(2,ki,jc) )
+        ch1(2,ki,j) =  sn * ( cc1(2,ki,j) + cc1(1,ki,jc) )
+        ch1(1,ki,jc) = sn * ( cc1(1,ki,j) + cc1(2,ki,jc) )
+        ch1(2,ki,jc) = sn * ( cc1(2,ki,j) - cc1(1,ki,jc) )
+      end do
+    end do
+
+  else
+
+    sn = 1.0E+00 / real ( ip * l1, kind = 4 )
+
+    do ki = 1, lid
+      cc1(1,ki,1) = sn * cc1(1,ki,1)
+      cc1(2,ki,1) = sn * cc1(2,ki,1)
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        chold1 = sn*(cc1(1,ki,j)-cc1(2,ki,jc))
+        chold2 = sn*(cc1(1,ki,j)+cc1(2,ki,jc))
+        cc1(1,ki,j) = chold1
+        cc1(2,ki,jc) = sn*(cc1(2,ki,j)-cc1(1,ki,jc))
+        cc1(2,ki,j) = sn*(cc1(2,ki,j)+cc1(1,ki,jc))
+        cc1(1,ki,jc) = chold2
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1fm1b.F b/wrfv2_fire/external/fftpack/fftpack5/c1fm1b.F
index fe3072ca..53ac04b6 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1fm1b.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1fm1b.F
@@ -1,55 +1,104 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1fm1b.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1FM1B (N,INC,C,CH,WA,FNF,FAC) 
-      COMPLEX       C(*) 
-      REAL       CH(*),     WA(*),     FAC(*) 
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      INC2 = INC+INC 
-      NF = FNF 
-      NA = 0 
-      L1 = 1 
-      IW = 1 
-      DO 125 K1=1,NF 
-         IP = FAC(K1) 
-         L2 = IP*L1 
-         IDO = N/L2 
-         LID = L1*IDO 
-         NBR = 1+NA+2*MIN(IP-2,4) 
-         GO TO (52,62,53,63,54,64,55,65,56,66),NBR 
-   52    CALL C1F2KB (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
-         GO TO 120 
-   62    CALL C1F2KB (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
-         GO TO 120 
-   53    CALL C1F3KB (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
-         GO TO 120 
-   63    CALL C1F3KB (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
-         GO TO 120 
-   54    CALL C1F4KB (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
-         GO TO 120 
-   64    CALL C1F4KB (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
-         GO TO 120 
-   55    CALL C1F5KB (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
-         GO TO 120 
-   65    CALL C1F5KB (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
-         GO TO 120 
-   56    CALL C1FGKB (IDO,IP,L1,LID,NA,C,C,INC2,CH,CH,2,                &
-     &     WA(IW))                                                      
-         GO TO 120 
-   66    CALL C1FGKB (IDO,IP,L1,LID,NA,CH,CH,2,C,C,                     &
-     &     INC2,WA(IW))                                                 
-  120    L1 = L2 
-         IW = IW+(IP-1)*(IDO+IDO) 
-         IF(IP .LE. 5) NA = 1-NA 
-  125 END DO 
-      RETURN 
-      END                                           
+subroutine c1fm1b ( n, inc, c, ch, wa, fnf, fac )
+
+!*****************************************************************************80
+!
+!! C1FM1B is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  complex ( kind = 4 ) c(*)
+  real ( kind = 4 ) ch(*)
+  real ( kind = 4 ) fac(*)
+  real ( kind = 4 ) fnf
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) inc2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) lid
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nbr
+  integer ( kind = 4 ) nf
+  real ( kind = 4 ) wa(*)
+
+  inc2 = inc + inc
+  nf = int ( fnf )
+  na = 0
+  l1 = 1
+  iw = 1
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1) )
+    l2 = ip * l1
+    ido = n / l2
+    lid = l1 * ido
+    nbr = 1 + na + 2 * min ( ip - 2, 4 )
+
+    if ( nbr == 1 ) then
+      call c1f2kb ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+    else if ( nbr == 2 ) then
+      call c1f2kb ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+    else if ( nbr == 3 ) then
+      call c1f3kb ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+    else if ( nbr == 4 ) then
+      call c1f3kb ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+    else if ( nbr == 5 ) then
+      call c1f4kb ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+    else if ( nbr == 6 ) then
+      call c1f4kb ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+    else if ( nbr == 7 ) then
+      call c1f5kb ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+    else if ( nbr == 8 ) then
+      call c1f5kb ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+    else if ( nbr == 9 ) then
+      call c1fgkb ( ido, ip, l1, lid, na, c, c, inc2, ch, ch, 2, wa(iw) )
+    else if ( nbr == 10 ) then
+      call c1fgkb ( ido, ip, l1, lid, na, ch, ch, 2, c, c, inc2, wa(iw) )
+    end if
+
+    l1 = l2
+    iw = iw + ( ip - 1 ) * ( ido + ido )
+
+    if ( ip <= 5 ) then
+      na = 1 - na
+    end if
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/c1fm1f.F b/wrfv2_fire/external/fftpack/fftpack5/c1fm1f.F
index d0a95ef3..6601ea32 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/c1fm1f.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/c1fm1f.F
@@ -1,56 +1,103 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: c1fm1f.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE C1FM1F (N,INC,C,CH,WA,FNF,FAC) 
-      COMPLEX       C(*) 
-      REAL       CH(*),     WA(*),      FAC(*) 
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      INC2 = INC+INC 
-      NF = FNF 
-      NA = 0 
-      L1 = 1 
-      IW = 1 
-      DO 125 K1=1,NF 
-         IP = FAC(K1) 
-         L2 = IP*L1 
-         IDO = N/L2 
-         LID = L1*IDO 
-         NBR = 1+NA+2*MIN(IP-2,4) 
-         write(*,*) wa(iw),wa(iw+1) 
-         GO TO (52,62,53,63,54,64,55,65,56,66),NBR 
-   52    CALL C1F2KF (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
-         GO TO 120 
-   62    CALL C1F2KF (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
-         GO TO 120 
-   53    CALL C1F3KF (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
-         GO TO 120 
-   63    CALL C1F3KF (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
-         GO TO 120 
-   54    CALL C1F4KF (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
-         GO TO 120 
-   64    CALL C1F4KF (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
-         GO TO 120 
-   55    CALL C1F5KF (IDO,L1,NA,C,INC2,CH,2,WA(IW)) 
-         GO TO 120 
-   65    CALL C1F5KF (IDO,L1,NA,CH,2,C,INC2,WA(IW)) 
-         GO TO 120 
-   56    CALL C1FGKF (IDO,IP,L1,LID,NA,C,C,INC2,CH,CH,                  &
-     &     1,WA(IW))                                                    
-         GO TO 120 
-   66    CALL C1FGKF (IDO,IP,L1,LID,NA,CH,CH,2,C,C,                     &
-     &     INC2,WA(IW))                                                 
-  120    L1 = L2 
-         IW = IW+(IP-1)*(IDO+IDO) 
-         IF(IP .LE. 5) NA = 1-NA 
-  125 END DO 
-      RETURN 
-      END                                           
+subroutine c1fm1f ( n, inc, c, ch, wa, fnf, fac )
+
+!*****************************************************************************80
+!
+!! C1FM1F is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  complex ( kind = 4 ) c(*)
+  real ( kind = 4 ) ch(*)
+  real ( kind = 4 ) fac(*)
+  real ( kind = 4 ) fnf
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) inc2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) lid
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nbr
+  integer ( kind = 4 ) nf
+  real ( kind = 4 ) wa(*)
+
+  inc2 = inc + inc
+  nf = int ( fnf )
+  na = 0
+  l1 = 1
+  iw = 1
+
+  do k1 = 1, nf
+
+     ip = int ( fac(k1) )
+     l2 = ip * l1
+     ido = n / l2
+     lid = l1 * ido
+     nbr = 1 + na + 2 * min ( ip - 2, 4 )
+
+     if ( nbr == 1 ) then
+       call c1f2kf ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+     else if ( nbr == 2 ) then
+       call c1f2kf ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+     else if ( nbr == 3 ) then
+       call c1f3kf ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+     else if ( nbr == 4 ) then
+       call c1f3kf ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+     else if ( nbr == 5 ) then
+       call c1f4kf ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+     else if ( nbr == 6 ) then
+       call c1f4kf ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+     else if ( nbr == 7 ) then
+       call c1f5kf ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+     else if ( nbr == 8 ) then
+       call c1f5kf ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+     else if ( nbr == 9 ) then
+       call c1fgkf ( ido, ip, l1, lid, na, c, c, inc2, ch, ch, 1, wa(iw) )
+     else if ( nbr == 10 ) then
+       call c1fgkf ( ido, ip, l1, lid, na, ch, ch, 2, c, c, inc2, wa(iw) )
+     end if
+
+     l1 = l2
+     iw = iw + ( ip - 1 ) * ( ido + ido )
+
+     if ( ip <= 5 ) then
+       na = 1 - na
+     end if
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cfft1b.F b/wrfv2_fire/external/fftpack/fftpack5/cfft1b.F
index 1cef69b9..b95056e7 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cfft1b.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cfft1b.F
@@ -1,36 +1,123 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cfft1b.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CFFT1B (N, INC, C, LENC, WSAVE, LENSAV,                &
-     &                  WORK, LENWRK, IER)                              
-      INTEGER  N, INC, LENC, LENSAV, LENWRK, IER 
-      COMPLEX       C(LENC) 
-      REAL     WSAVE(LENSAV)     ,WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENC .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('CFFT1B ', 6) 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
-        IER = 2 
-        CALL XERFFT ('CFFT1B ', 8) 
-      ELSEIF (LENWRK .LT. 2*N) THEN 
-        IER = 3 
-        CALL XERFFT ('CFFT1B ', 10) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      IW1 = N+N+1 
-      CALL C1FM1B (N,INC,C,WORK,WSAVE,WSAVE(IW1),                       &
-     &                           WSAVE(IW1+1))                          
-      RETURN 
-      END                                           
+subroutine cfft1b ( n, inc, c, lenc, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! CFFT1B: complex single precision backward fast Fourier transform, 1D.
+!
+!  Discussion:
+!
+!    CFFT1B computes the one-dimensional Fourier transform of a single
+!    periodic sequence within a complex array.  This transform is referred
+!    to as the backward transform or Fourier synthesis, transforming the
+!    sequence from spectral to physical space.
+!
+!    This transform is normalized since a call to CFFT1B followed
+!    by a call to CFFT1F (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    22 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array C, of two consecutive elements within the sequence to be transformed.
+!
+!    Input/output, complex ( kind = 4 ) C(LENC) containing the sequence to be
+!    transformed.
+!
+!    Input, integer ( kind = 4 ) LENC, the dimension of the C array.
+!    LENC must be at least INC*(N-1) + 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to CFFT1I before the first call to routine CFFT1F
+!    or CFFT1B for a given transform length N.  WSAVE's contents may be
+!    re-used for subsequent calls to CFFT1F and CFFT1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENC not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 4 ) c(lenc)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lenc < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'CFFT1B', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'CFFT1B', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * n ) then
+    ier = 3
+    call xerfft ( 'CFFT1B', 10 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+
+  call c1fm1b ( n, inc, c, work, wsave, wsave(iw1), wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cfft1f.F b/wrfv2_fire/external/fftpack/fftpack5/cfft1f.F
index 6bad5a68..67e5a645 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cfft1f.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cfft1f.F
@@ -1,36 +1,123 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cfft1f.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CFFT1F (N, INC, C, LENC, WSAVE, LENSAV,                &
-     &                  WORK, LENWRK, IER)                              
-      INTEGER  N, INC, LENC, LENSAV, LENWRK, IER 
-      COMPLEX  C(LENC) 
-      REAL     WSAVE(LENSAV)     ,WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENC .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('CFFT1F ', 6) 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
-        IER = 2 
-        CALL XERFFT ('CFFT1F ', 8) 
-      ELSEIF (LENWRK .LT. 2*N) THEN 
-        IER = 3 
-        CALL XERFFT ('CFFTMF ', 10) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      IW1 = N+N+1 
-      CALL C1FM1F (N,INC,C,WORK,WSAVE,WSAVE(IW1),                       &
-     &                           WSAVE(IW1+1))                          
-      RETURN 
-      END                                           
+subroutine cfft1f ( n, inc, c, lenc, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! CFFT1F: complex single precision forward fast Fourier transform, 1D.
+!
+!  Discussion:
+!
+!    CFFT1F computes the one-dimensional Fourier transform of a single
+!    periodic sequence within a complex array.  This transform is referred
+!    to as the forward transform or Fourier analysis, transforming the
+!    sequence from physical to spectral space.
+!
+!    This transform is normalized since a call to CFFT1F followed
+!    by a call to CFFT1B (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    22 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array C, of two consecutive elements within the sequence to be transformed.
+!
+!    Input/output, complex ( kind = 4 ) C(LENC) containing the sequence to
+!    be transformed.
+!
+!    Input, integer ( kind = 4 ) LENC, the dimension of the C array.
+!    LENC must be at least INC*(N-1) + 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to CFFT1I before the first call to routine CFFT1F
+!    or CFFT1B for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to CFFT1F and CFFT1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENC   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 4 ) c(lenc)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lenc < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'CFFT1F', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'CFFT1F', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * n ) then
+    ier = 3
+    call xerfft ( 'CFFT1F', 10 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+
+  call c1fm1f ( n, inc, c, work, wsave, wsave(iw1), wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cfft1i.F b/wrfv2_fire/external/fftpack/fftpack5/cfft1i.F
index cd9d6fd1..164c68f7 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cfft1i.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cfft1i.F
@@ -1,27 +1,84 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cfft1i.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CFFT1I (N, WSAVE, LENSAV, IER) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
-        IER = 2 
-        CALL XERFFT ('CFFTMI ', 3) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      IW1 = N+N+1 
-      CALL MCFTI1 (N,WSAVE,WSAVE(IW1),WSAVE(IW1+1)) 
-      RETURN 
-      END                                           
+subroutine cfft1i ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! CFFT1I: initialization for CFFT1B and CFFT1F.
+!
+!  Discussion:
+!
+!    CFFT1I initializes array WSAVE for use in its companion routines
+!    CFFT1B and CFFT1F.  Routine CFFT1I must be called before the first
+!    call to CFFT1B or CFFT1F, and after whenever the value of integer
+!    N changes.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    22 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product
+!    of small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors
+!    of N and  also containing certain trigonometric values which will be used
+!    in routines CFFT1B or CFFT1F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough.
+
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'CFFT1I', 3 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+
+  call r4_mcfti1 ( n, wsave, wsave(iw1), wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cfft2b.F b/wrfv2_fire/external/fftpack/fftpack5/cfft2b.F
index f573fc55..886a329d 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cfft2b.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cfft2b.F
@@ -1,59 +1,149 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cfft2b.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CFFT2B (LDIM, L, M, C, WSAVE, LENSAV,                  &
-     &                     WORK, LENWRK, IER)                           
-      INTEGER L, M, LDIM, LENSAV, LENWRK, IER 
-      COMPLEX C(LDIM,M) 
-      REAL WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-! Initialize error return                                               
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (L .GT. LDIM) THEN 
-        IER = 5 
-        CALL XERFFT ('CFFT2B', -2) 
-        GO TO 100 
-      ELSEIF (LENSAV .LT. 2*L + INT(LOG(REAL(L))) +                     &
-     &                    2*M + INT(LOG(REAL(M))) +8) THEN              
-        IER = 2 
-        CALL XERFFT ('CFFT2B', 6) 
-        GO TO 100 
-      ELSEIF (LENWRK .LT. 2*L*M) THEN 
-        IER = 3 
-        CALL XERFFT ('CFFT2B', 8) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-! Transform X lines of C array                                          
-      IW = 2*L+INT(LOG(REAL(L))*LOG(2.)) + 3 
-      CALL CFFTMB(L, 1, M, LDIM, C, (L-1) + LDIM*(M-1) +1,              &
-     &     WSAVE(IW), 2*M + INT(LOG(REAL(M))) + 4,                      &
-     &     WORK, 2*L*M, IER1)                                           
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('CFFT2B',-5) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-! Transform Y lines of C array                                          
-      IW = 1 
-      CALL CFFTMB (M, LDIM, L, 1, C, (M-1)*LDIM + L,                    &
-     &     WSAVE(IW), 2*L + INT(LOG(REAL(L))) + 4,                      &
-     &     WORK, 2*M*L, IER1)                                           
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('CFFT2B',-5) 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine cfft2b ( ldim, l, m, c, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! CFFT2B: complex single precision backward fast Fourier transform, 2D.
+!
+!  Discussion:
+!
+!    CFFT2B computes the two-dimensional discrete Fourier transform of a
+!    complex periodic array.  This transform is known as the backward
+!    transform or Fourier synthesis, transforming from spectral to
+!    physical space.  Routine CFFT2B is normalized, in that a call to
+!    CFFT2B followed by a call to CFFT2F (or vice-versa) reproduces the
+!    original array within roundoff error.
+!
+!    On 10 May 2010, this code was modified by changing the value
+!    of an index into the WSAVE array.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    10 May 2010
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LDIM, the first dimension of C.
+!
+!    Input, integer ( kind = 4 ) L, the number of elements to be transformed
+!    in the first dimension of the two-dimensional complex array C.  The value
+!    of L must be less than or equal to that of LDIM.  The transform is
+!    most efficient when L is a product of small primes.
+!
+!    Input, integer ( kind = 4 ) M, the number of elements to be transformed in
+!    the second dimension of the two-dimensional complex array C.  The transform
+!    is most efficient when M is a product of small primes.
+!
+!    Input/output, complex ( kind = 4 ) C(LDIM,M), on intput, the array of
+!    two dimensions containing the (L,M) subarray to be transformed.  On
+!    output, the transformed data.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV). WSAVE's contents must be
+!    initialized with a call to CFFT2I before the first call to routine CFFT2F
+!    or CFFT2B with transform lengths L and M.  WSAVE's contents may be
+!    re-used for subsequent calls to CFFT2F and CFFT2B with the same
+!    transform lengths L and M.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*(L+M) + INT(LOG(REAL(L)))
+!    + INT(LOG(REAL(M))) + 8.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*L*M.
+!
+!    Output, integer ( kind = 4 ) IER, the error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    5, input parameter LDIM < L;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) ldim
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 4 ) c(ldim,m)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) l
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( ldim < l ) then
+    ier = 5
+    call xerfft ( 'CFFT2B', -2 )
+    return
+  end if
+
+  if ( lensav < 2 * l + int ( log ( real ( l, kind = 4 ) ) ) + &
+                2 * m + int ( log ( real ( m, kind = 4 ) ) ) + 8 ) then
+    ier = 2
+    call xerfft ( 'CFFT2B', 6 )
+    return
+  end if
+
+  if ( lenwrk < 2 * l * m ) then
+    ier = 3
+    call xerfft ( 'CFFT2B', 8 )
+    return
+  end if
+!
+!  Transform the X lines of the C array.
+!
+!  The value of IW was modified on 10 May 2010.
+!
+  iw = 2 * l + int ( log ( real ( l, kind = 4 ) ) ) + 5
+
+  call cfftmb ( l, 1, m, ldim, c, (l-1)+ldim*(m-1) +1, &
+    wsave(iw), 2*m + int(log( real ( m, kind = 4 ))) + 4, work, 2*l*m, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'CFFT2B', -5 )
+    return
+  end if
+!
+!  Transform the Y lines of the C array.
+!
+  iw = 1
+  call cfftmb ( m, ldim, l, 1, c, (m-1)*ldim + l, wsave(iw), &
+    2*l + int(log( real ( l, kind = 4 ))) + 4, work, 2*m*l, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'CFFT2B', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cfft2f.F b/wrfv2_fire/external/fftpack/fftpack5/cfft2f.F
index f115e461..3520bf66 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cfft2f.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cfft2f.F
@@ -1,59 +1,150 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cfft2f.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CFFT2F (LDIM, L, M, C, WSAVE, LENSAV,                  &
-     &                     WORK, LENWRK, IER)                           
-      INTEGER L, M, LDIM, LENSAV, LENWRK, IER 
-      COMPLEX C(LDIM,M) 
-      REAL WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-! Initialize error return                                               
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (L .GT. LDIM) THEN 
-        IER = 5 
-        CALL XERFFT ('CFFT2F', -2) 
-        GO TO 100 
-      ELSEIF (LENSAV .LT. 2*L + INT(LOG(REAL(L))) +                     &
-     &                    2*M + INT(LOG(REAL(M))) +8) THEN              
-        IER = 2 
-        CALL XERFFT ('CFFT2F', 6) 
-        GO TO 100 
-      ELSEIF (LENWRK .LT. 2*L*M) THEN 
-        IER = 3 
-        CALL XERFFT ('CFFT2F', 8) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-! Transform X lines of C array                                          
-      IW = 2*L+INT(LOG(REAL(L))*LOG(2.)) + 3 
-      CALL CFFTMF(L, 1, M, LDIM, C, (L-1) + LDIM*(M-1) +1,              &
-     &     WSAVE(IW), 2*M + INT(LOG(REAL(M))) + 4,                      &
-     &     WORK, 2*L*M, IER1)                                           
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('CFFT2F',-5) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-! Transform Y lines of C array                                          
-      IW = 1 
-      CALL CFFTMF (M, LDIM, L, 1, C, (M-1)*LDIM + L,                    &
-     &     WSAVE(IW), 2*L + INT(LOG(REAL(L))) + 4,                      &
-     &     WORK, 2*M*L, IER1)                                           
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('CFFT2F',-5) 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine cfft2f ( ldim, l, m, c, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! CFFT2F: complex single precision forward fast Fourier transform, 2D.
+!
+!  Discussion:
+!
+!    CFFT2F computes the two-dimensional discrete Fourier transform of
+!    a complex periodic array. This transform is known as the forward
+!    transform or Fourier analysis, transforming from physical to
+!    spectral space. Routine CFFT2F is normalized, in that a call to
+!    CFFT2F followed by a call to CFFT2B (or vice-versa) reproduces the
+!    original array within roundoff error.
+!
+!    On 10 May 2010, this code was modified by changing the value
+!    of an index into the WSAVE array.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    10 May 2010
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LDIM, the first dimension of the array C.
+!
+!    Input, integer ( kind = 4 ) L, the number of elements to be transformed
+!    in the first dimension of the two-dimensional complex array C.  The value
+!    of L must be less than or equal to that of LDIM.  The transform is most
+!    efficient when L is a product of small primes.
+!
+!    Input, integer ( kind = 4 ) M, the number of elements to be transformed
+!    in the second dimension of the two-dimensional complex array C.  The
+!    transform is most efficient when M is a product of small primes.
+!
+!    Input/output, complex ( kind = 4 ) C(LDIM,M), on input, the array of two
+!    dimensions containing the (L,M) subarray to be transformed.  On output, the
+!    transformed data.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV). WSAVE's contents must be
+!    initialized with a call to CFFT2I before the first call to routine CFFT2F
+!    or CFFT2B with transform lengths L and M.  WSAVE's contents may be re-used
+!    for subsequent calls to CFFT2F and CFFT2B having those same
+!    transform lengths.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*(L+M) + INT(LOG(REAL(L)))
+!    + INT(LOG(REAL(M))) + 8.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*L*M.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    5, input parameter LDIM < L;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) ldim
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 4 ) c(ldim,m)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) l
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( ldim < l ) then
+    ier = 5
+    call xerfft ( 'CFFT2F', -2 )
+    return
+  end if
+
+  if ( lensav < 2 * l + int ( log ( real ( l, kind = 4 ) ) ) + &
+                2 * m + int ( log ( real ( m, kind = 4 ) ) ) + 8 ) then
+    ier = 2
+    call xerfft ( 'CFFT2F', 6 )
+    return
+  end if
+
+  if ( lenwrk < 2 * l * m ) then
+    ier = 3
+    call xerfft ( 'CFFT2F', 8 )
+    return
+  end if
+!
+!  Transform the X lines of the C array.
+!
+!  The value of IW was modified on 10 May 2010.
+!
+  iw = 2 * l + int ( log ( real ( l, kind = 4 ) ) ) + 5
+
+  call cfftmf ( l, 1, m, ldim, c, (l-1) + ldim*(m-1) +1, wsave(iw), &
+    2*m + int(log( real ( m, kind = 4 ))) + 4, work, 2*l*m, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'CFFT2F', -5 )
+    return
+  end if
+!
+!  Transform the Y lines of the C array.
+!
+  iw = 1
+
+  call cfftmf ( m, ldim, l, 1, c, (m-1)*ldim + l, wsave(iw), &
+    2*l + int(log( real ( l, kind = 4 ))) + 4, work, 2*m*l, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'CFFT2F', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cfft2i.F b/wrfv2_fire/external/fftpack/fftpack5/cfft2i.F
index be3633f1..f1349731 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cfft2i.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cfft2i.F
@@ -1,41 +1,109 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cfft2i.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CFFT2I (L, M, WSAVE, LENSAV, IER) 
-      INTEGER L, M, IER 
-      REAL WSAVE(LENSAV) 
-!                                                                       
-! Initialize error return                                               
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. 2*L + INT(LOG(REAL(L))) +                         &
-     &                    2*M + INT(LOG(REAL(M))) +8) THEN              
-        IER = 2 
-        CALL XERFFT ('CFFT2I', 4) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-      CALL CFFTMI (L, WSAVE(1), 2*L + INT(LOG(REAL(L))) + 4, IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('CFFT2I',-5) 
-        GO TO 100 
-      ENDIF 
-      CALL CFFTMI (M, WSAVE(2*L+INT(LOG(REAL(L))*LOG(2.)) + 3),         &
-     &            2*M + INT(LOG(REAL(M))) + 4, IER1)                    
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('CFFT2I',-5) 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine cfft2i ( l, m, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! CFFT2I: initialization for CFFT2B and CFFT2F.
+!
+!  Discussion:
+!
+!    CFFT2I initializes real array WSAVE for use in its companion
+!    routines CFFT2F and CFFT2B for computing two-dimensional fast
+!    Fourier transforms of complex data.  Prime factorizations of L and M,
+!    together with tabulations of the trigonometric functions, are
+!    computed and stored in array WSAVE.
+!
+!    On 10 May 2010, this code was modified by changing the value
+!    of an index into the WSAVE array.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    10 May 2010
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) L, the number of elements to be transformed
+!    in the first dimension.  The transform is most efficient when L is a
+!    product of small primes.
+!
+!    Input, integer ( kind = 4 ) M, the number of elements to be transformed
+!    in the second dimension.  The transform is most efficient when M is a
+!    product of small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*(L+M) + INT(LOG(REAL(L)))
+!    + INT(LOG(REAL(M))) + 8.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), contains the prime factors of L
+!    and M, and also certain trigonometric values which will be used in
+!    routines CFFT2B or CFFT2F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) m
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * l + int ( log ( real ( l, kind = 4 ) ) ) + &
+                2 * m + int ( log ( real ( m, kind = 4 ) ) ) + 8 ) then
+    ier = 2
+    call xerfft ( 'CFFT2I', 4 )
+    return
+  end if
+
+  call cfftmi ( l, wsave(1), 2*l + int(log( real ( l, kind = 4 ))) + 4, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'CFFT2I', -5 )
+    return
+  end if
+!
+!  On 10 May 2010, the value of IW was modified.
+!
+  iw = 2 * l + int ( log ( real ( l, kind = 4 ) ) ) + 5
+
+  call cfftmi ( m, wsave(iw), 2*m + int(log( real ( m, kind = 4 ))) + 4, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'CFFT2I', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cfftmb.F b/wrfv2_fire/external/fftpack/fftpack5/cfftmb.F
index 104abb9f..45167fa2 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cfftmb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cfftmb.F
@@ -1,40 +1,147 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cfftmb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CFFTMB (LOT, JUMP, N, INC, C, LENC, WSAVE, LENSAV,     &
-     &                  WORK, LENWRK, IER)                              
-      INTEGER  LOT, JUMP, N, INC, LENC, LENSAV, LENWRK, IER 
-      COMPLEX       C(LENC) 
-      REAL     WSAVE(LENSAV)     ,WORK(LENWRK) 
-      LOGICAL XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENC .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('CFFTMB ', 6) 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
-        IER = 2 
-        CALL XERFFT ('CFFTMB ', 8) 
-      ELSEIF (LENWRK .LT. 2*LOT*N) THEN 
-        IER = 3 
-        CALL XERFFT ('CFFTMB ', 10) 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('CFFTMB ', -1) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      IW1 = N+N+1 
-      CALL CMFM1B (LOT,JUMP,N,INC,C,WORK,WSAVE,WSAVE(IW1),              &
-     &                           WSAVE(IW1+1))                          
-      RETURN 
-      END                                           
+subroutine cfftmb ( lot, jump, n, inc, c, lenc, wsave, lensav, work, &
+  lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! CFFTMB: complex single precision backward FFT, 1D, multiple vectors.
+!
+!  Discussion:
+!
+!    CFFTMB computes the one-dimensional Fourier transform of multiple
+!    periodic sequences within a complex array.  This transform is referred
+!    to as the backward transform or Fourier synthesis, transforming the
+!    sequences from spectral to physical space.  This transform is
+!    normalized since a call to CFFTMF followed by a call to CFFTMB (or
+!    vice-versa) reproduces the original array within roundoff error.
+!
+!    The parameters INC, JUMP, N and LOT are consistent if equality
+!    I1*INC + J1*JUMP = I2*INC + J2*JUMP for I1,I2 < N and J1,J2 < LOT
+!    implies I1=I2 and J1=J2.  For multiple FFTs to execute correctly,
+!    input variables INC, JUMP, N and LOT must be consistent, otherwise
+!    at least one array element mistakenly is transformed more than once.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    24 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed
+!    within array C.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations, in
+!    array C, of the first elements of two consecutive sequences to be
+!    transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array C, of two consecutive elements within the same sequence to be
+!    transformed.
+!
+!    Input/output, complex ( kind = 4 ) C(LENC), an array containing LOT
+!    sequences, each having length N, to be transformed.  C can have any
+!    number of dimensions, but the total number of locations must be at least
+!    LENC.  On output, C contains the transformed sequences.
+!
+!    Input, integer ( kind = 4 ) LENC, the dimension of the C array.
+!    LENC must be at least (LOT-1)*JUMP + INC*(N-1) + 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to CFFTMI before the first call to routine CFFTMF
+!    or CFFTMB for a given transform length N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*LOT*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit
+!    1, input parameter LENC not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC, JUMP, N, LOT are not consistent.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 4 ) c(lenc)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  logical              xercon
+
+  ier = 0
+
+  if ( lenc < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'CFFTMB', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'CFFTMB', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * lot * n ) then
+    ier = 3
+    call xerfft ( 'CFFTMB', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'CFFTMB', -1 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+
+  call cmfm1b ( lot, jump, n, inc, c, work, wsave, wsave(iw1), &
+    wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cfftmf.F b/wrfv2_fire/external/fftpack/fftpack5/cfftmf.F
index 54cd24e8..b7d1f9e2 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cfftmf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cfftmf.F
@@ -1,40 +1,146 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cfftmf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CFFTMF (LOT, JUMP, N, INC, C, LENC, WSAVE, LENSAV,     &
-     &                  WORK, LENWRK, IER)                              
-      INTEGER  LOT, JUMP, N, INC, LENC, LENSAV, LENWRK, IER 
-      COMPLEX  C(LENC) 
-      REAL     WSAVE(LENSAV)     ,WORK(LENWRK) 
-      LOGICAL  XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENC .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('CFFTMF ', 6) 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
-        IER = 2 
-        CALL XERFFT ('CFFTMF ', 8) 
-      ELSEIF (LENWRK .LT. 2*LOT*N) THEN 
-        IER = 3 
-        CALL XERFFT ('CFFTMF ', 10) 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('CFFTMF ', -1) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      IW1 = N+N+1 
-      CALL CMFM1F (LOT,JUMP,N,INC,C,WORK,WSAVE,WSAVE(IW1),              &
-     &                           WSAVE(IW1+1))                          
-      RETURN 
-      END                                           
+subroutine cfftmf ( lot, jump, n, inc, c, lenc, wsave, lensav, work, &
+  lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! CFFTMF: complex single precision forward FFT, 1D, multiple vectors.
+!
+!  Discussion:
+!
+!    CFFTMF computes the one-dimensional Fourier transform of multiple
+!    periodic sequences within a complex array. This transform is referred
+!    to as the forward transform or Fourier analysis, transforming the
+!    sequences from physical to spectral space. This transform is
+!    normalized since a call to CFFTMF followed by a call to CFFTMB
+!    (or vice-versa) reproduces the original array within roundoff error.
+!
+!    The parameters integers INC, JUMP, N and LOT are consistent if equality
+!    I1*INC + J1*JUMP = I2*INC + J2*JUMP for I1,I2 < N and J1,J2 < LOT
+!    implies I1=I2 and J1=J2. For multiple FFTs to execute correctly,
+!    input variables INC, JUMP, N and LOT must be consistent, otherwise
+!    at least one array element mistakenly is transformed more than once.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    24 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be
+!    transformed within array C.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations,
+!    in array C, of the first elements of two consecutive sequences to be
+!    transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array C, of two consecutive elements within the same sequence to be
+!    transformed.
+!
+!    Input/output, complex ( kind = 4 ) C(LENC), array containing LOT sequences,
+!    each having length N, to be transformed.  C can have any number of
+!    dimensions, but the total number of locations must be at least LENC.
+!
+!    Input, integer ( kind = 4 ) LENC, the dimension of the C array.
+!    LENC must be at least (LOT-1)*JUMP + INC*(N-1) + 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to CFFTMI before the first call to routine CFFTMF
+!    or CFFTMB for a given transform length N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*LOT*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0 successful exit;
+!    1 input parameter LENC not big enough;
+!    2 input parameter LENSAV not big enough;
+!    3 input parameter LENWRK not big enough;
+!    4 input parameters INC, JUMP, N, LOT are not consistent.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 4 ) c(lenc)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  logical              xercon
+
+  ier = 0
+
+  if ( lenc < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'CFFTMF', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'CFFTMF', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * lot * n ) then
+    ier = 3
+    call xerfft ( 'CFFTMF', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'CFFTMF', -1 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+
+  call cmfm1f ( lot, jump, n, inc, c, work, wsave, wsave(iw1), &
+    wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cfftmi.F b/wrfv2_fire/external/fftpack/fftpack5/cfftmi.F
index 892aaaea..c45398d1 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cfftmi.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cfftmi.F
@@ -1,27 +1,82 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cfftmi.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CFFTMI (N, WSAVE, LENSAV, IER) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) + 4) THEN 
-        IER = 2 
-        CALL XERFFT ('CFFTMI ', 3) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      IW1 = N+N+1 
-      CALL MCFTI1 (N,WSAVE,WSAVE(IW1),WSAVE(IW1+1)) 
-      RETURN 
-      END                                           
+subroutine cfftmi ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! CFFTMI: initialization for CFFTMB and CFFTMF.
+!
+!  Discussion:
+!
+!    CFFTMI initializes array WSAVE for use in its companion routines
+!    CFFTMB and CFFTMF.  CFFTMI must be called before the first call
+!    to CFFTMB or CFFTMF, and after whenever the value of integer N changes.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    24 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors
+!    of N and also containing certain trigonometric values which will be used in
+!    routines CFFTMB or CFFTMF.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'cfftmi ', 3 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+  call r4_mcfti1 ( n, wsave, wsave(iw1), wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmf2kb.F b/wrfv2_fire/external/fftpack/fftpack5/cmf2kb.F
index 2e3a5063..21c89fe5 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmf2kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmf2kb.F
@@ -1,51 +1,113 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cmf2kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CMF2KB (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
-      REAL  CC(2,IN1,L1,IDO,2),CH(2,IN2,L1,2,IDO),WA(IDO,1,2) 
-!                                                                       
-      M1D = (LOT-1)*IM1+1 
-      M2S = 1-IM2 
-      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
-      DO 101 K=1,L1 
-         DO 101 M1=1,M1D,IM1 
-         CHOLD1 = CC(1,M1,K,1,1)+CC(1,M1,K,1,2) 
-         CC(1,M1,K,1,2) = CC(1,M1,K,1,1)-CC(1,M1,K,1,2) 
-         CC(1,M1,K,1,1) = CHOLD1 
-         CHOLD2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,2) 
-         CC(2,M1,K,1,2) = CC(2,M1,K,1,1)-CC(2,M1,K,1,2) 
-         CC(2,M1,K,1,1) = CHOLD2 
-  101 CONTINUE 
-      RETURN 
-  102 DO 103 K=1,L1 
-         M2 = M2S 
-         DO 103 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+CC(1,M1,K,1,2) 
-         CH(1,M2,K,2,1) = CC(1,M1,K,1,1)-CC(1,M1,K,1,2) 
-         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+CC(2,M1,K,1,2) 
-         CH(2,M2,K,2,1) = CC(2,M1,K,1,1)-CC(2,M1,K,1,2) 
-  103 CONTINUE 
-      IF(IDO .EQ. 1) RETURN 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-         M2 = M2S 
-         DO 104 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+CC(1,M1,K,I,2) 
-            TR2 = CC(1,M1,K,I,1)-CC(1,M1,K,I,2) 
-            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+CC(2,M1,K,I,2) 
-            TI2 = CC(2,M1,K,I,1)-CC(2,M1,K,I,2) 
-            CH(2,M2,K,2,I) = WA(I,1,1)*TI2+WA(I,1,2)*TR2 
-            CH(1,M2,K,2,I) = WA(I,1,1)*TR2-WA(I,1,2)*TI2 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine cmf2kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! CMF2KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(2,in1,l1,ido,2)
+  real ( kind = 4 ) ch(2,in2,l1,2,ido)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) wa(ido,1,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1) + cc(1,m1,k,1,2)
+        ch(1,m2,k,2,1) = cc(1,m1,k,1,1) - cc(1,m1,k,1,2)
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1) + cc(2,m1,k,1,2)
+        ch(2,m2,k,2,1) = cc(2,m1,k,1,1) - cc(2,m1,k,1,2)
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+cc(1,m1,k,i,2)
+          tr2 = cc(1,m1,k,i,1)-cc(1,m1,k,i,2)
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+cc(2,m1,k,i,2)
+          ti2 = cc(2,m1,k,i,1)-cc(2,m1,k,i,2)
+
+          ch(2,m2,k,2,i) = wa(i,1,1) * ti2 + wa(i,1,2) * tr2
+          ch(1,m2,k,2,i) = wa(i,1,1) * tr2 - wa(i,1,2) * ti2
+
+        end do
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+
+        chold1         = cc(1,m1,k,1,1) + cc(1,m1,k,1,2)
+        cc(1,m1,k,1,2) = cc(1,m1,k,1,1) - cc(1,m1,k,1,2)
+        cc(1,m1,k,1,1) = chold1
+
+        chold2         = cc(2,m1,k,1,1) + cc(2,m1,k,1,2)
+        cc(2,m1,k,1,2) = cc(2,m1,k,1,1) - cc(2,m1,k,1,2)
+        cc(2,m1,k,1,1) = chold2
+
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmf2kf.F b/wrfv2_fire/external/fftpack/fftpack5/cmf2kf.F
index 1db54e98..ead6d6da 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmf2kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmf2kf.F
@@ -1,62 +1,131 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cmf2kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CMF2KF (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
-      REAL  CC(2,IN1,L1,IDO,2),CH(2,IN2,L1,2,IDO),WA(IDO,1,2) 
-!                                                                       
-      M1D = (LOT-1)*IM1+1 
-      M2S = 1-IM2 
-      IF (IDO .GT. 1) GO TO 102 
-      SN = 1./REAL(2*L1) 
-      IF (NA .EQ. 1) GO TO 106 
-      DO 101 K=1,L1 
-         DO 101 M1=1,M1D,IM1 
-         CHOLD1 = SN*(CC(1,M1,K,1,1)+CC(1,M1,K,1,2)) 
-         CC(1,M1,K,1,2) = SN*(CC(1,M1,K,1,1)-CC(1,M1,K,1,2)) 
-         CC(1,M1,K,1,1) = CHOLD1 
-         CHOLD2 = SN*(CC(2,M1,K,1,1)+CC(2,M1,K,1,2)) 
-         CC(2,M1,K,1,2) = SN*(CC(2,M1,K,1,1)-CC(2,M1,K,1,2)) 
-         CC(2,M1,K,1,1) = CHOLD2 
-  101 CONTINUE 
-      RETURN 
-  106 DO 107 K=1,L1 
-         M2 = M2S 
-         DO 107 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH(1,M2,K,1,1) = SN*(CC(1,M1,K,1,1)+CC(1,M1,K,1,2)) 
-         CH(1,M2,K,2,1) = SN*(CC(1,M1,K,1,1)-CC(1,M1,K,1,2)) 
-         CH(2,M2,K,1,1) = SN*(CC(2,M1,K,1,1)+CC(2,M1,K,1,2)) 
-         CH(2,M2,K,2,1) = SN*(CC(2,M1,K,1,1)-CC(2,M1,K,1,2)) 
-  107 CONTINUE 
-      RETURN 
-  102 DO 103 K=1,L1 
-         M2 = M2S 
-         DO 103 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+CC(1,M1,K,1,2) 
-         CH(1,M2,K,2,1) = CC(1,M1,K,1,1)-CC(1,M1,K,1,2) 
-         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+CC(2,M1,K,1,2) 
-         CH(2,M2,K,2,1) = CC(2,M1,K,1,1)-CC(2,M1,K,1,2) 
-  103 CONTINUE 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-         M2 = M2S 
-         DO 104 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+CC(1,M1,K,I,2) 
-            TR2 = CC(1,M1,K,I,1)-CC(1,M1,K,I,2) 
-            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+CC(2,M1,K,I,2) 
-            TI2 = CC(2,M1,K,I,1)-CC(2,M1,K,I,2) 
-            CH(2,M2,K,2,I) = WA(I,1,1)*TI2-WA(I,1,2)*TR2 
-            CH(1,M2,K,2,I) = WA(I,1,1)*TR2+WA(I,1,2)*TI2 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine cmf2kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! CMF2KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(2,in1,l1,ido,2)
+  real ( kind = 4 ) ch(2,in2,l1,2,ido)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lid
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) sn
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) wa(ido,1,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+cc(1,m1,k,1,2)
+        ch(1,m2,k,2,1) = cc(1,m1,k,1,1)-cc(1,m1,k,1,2)
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+cc(2,m1,k,1,2)
+        ch(2,m2,k,2,1) = cc(2,m1,k,1,1)-cc(2,m1,k,1,2)
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+cc(1,m1,k,i,2)
+          tr2 = cc(1,m1,k,i,1)-cc(1,m1,k,i,2)
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+cc(2,m1,k,i,2)
+          ti2 = cc(2,m1,k,i,1)-cc(2,m1,k,i,2)
+          ch(2,m2,k,2,i) = wa(i,1,1)*ti2-wa(i,1,2)*tr2
+          ch(1,m2,k,2,i) = wa(i,1,1)*tr2+wa(i,1,2)*ti2
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0E+00 / real ( 2 * l1, kind = 4 )
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch(1,m2,k,1,1) = sn * ( cc(1,m1,k,1,1) + cc(1,m1,k,1,2) )
+        ch(1,m2,k,2,1) = sn * ( cc(1,m1,k,1,1) - cc(1,m1,k,1,2) )
+        ch(2,m2,k,1,1) = sn * ( cc(2,m1,k,1,1) + cc(2,m1,k,1,2) )
+        ch(2,m2,k,2,1) = sn * ( cc(2,m1,k,1,1) - cc(2,m1,k,1,2) )
+      end do
+    end do
+
+  else
+
+    sn = 1.0E+00 / real ( 2 * l1, kind = 4 )
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+
+        chold1         = sn * ( cc(1,m1,k,1,1) + cc(1,m1,k,1,2) )
+        cc(1,m1,k,1,2) = sn * ( cc(1,m1,k,1,1) - cc(1,m1,k,1,2) )
+        cc(1,m1,k,1,1) = chold1
+
+        chold2         = sn * ( cc(2,m1,k,1,1) + cc(2,m1,k,1,2) )
+        cc(2,m1,k,1,2) = sn * ( cc(2,m1,k,1,1) - cc(2,m1,k,1,2) )
+        cc(2,m1,k,1,1) = chold2
+
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmf3kb.F b/wrfv2_fire/external/fftpack/fftpack5/cmf3kb.F
index 5f0010d0..1091517a 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmf3kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmf3kb.F
@@ -1,76 +1,145 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cmf3kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CMF3KB (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
-      REAL  CC(2,IN1,L1,IDO,3),CH(2,IN2,L1,3,IDO),WA(IDO,2,2) 
-      DATA TAUR,TAUI /-.5,.866025403784439/ 
-!                                                                       
-      M1D = (LOT-1)*IM1+1 
-      M2S = 1-IM2 
-      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
-      DO 101 K=1,L1 
-         DO 101 M1=1,M1D,IM1 
-         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,3) 
-         CR2 = CC(1,M1,K,1,1)+TAUR*TR2 
-         CC(1,M1,K,1,1) = CC(1,M1,K,1,1)+TR2 
-         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,3) 
-         CI2 = CC(2,M1,K,1,1)+TAUR*TI2 
-         CC(2,M1,K,1,1) = CC(2,M1,K,1,1)+TI2 
-         CR3 = TAUI*(CC(1,M1,K,1,2)-CC(1,M1,K,1,3)) 
-         CI3 = TAUI*(CC(2,M1,K,1,2)-CC(2,M1,K,1,3)) 
-         CC(1,M1,K,1,2) = CR2-CI3 
-         CC(1,M1,K,1,3) = CR2+CI3 
-         CC(2,M1,K,1,2) = CI2+CR3 
-         CC(2,M1,K,1,3) = CI2-CR3 
-  101 CONTINUE 
-      RETURN 
-  102 DO 103 K=1,L1 
-         M2 = M2S 
-         DO 103 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,3) 
-         CR2 = CC(1,M1,K,1,1)+TAUR*TR2 
-         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+TR2 
-         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,3) 
-         CI2 = CC(2,M1,K,1,1)+TAUR*TI2 
-         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+TI2 
-         CR3 = TAUI*(CC(1,M1,K,1,2)-CC(1,M1,K,1,3)) 
-         CI3 = TAUI*(CC(2,M1,K,1,2)-CC(2,M1,K,1,3)) 
-         CH(1,M2,K,2,1) = CR2-CI3 
-         CH(1,M2,K,3,1) = CR2+CI3 
-         CH(2,M2,K,2,1) = CI2+CR3 
-         CH(2,M2,K,3,1) = CI2-CR3 
-  103 CONTINUE 
-      IF (IDO .EQ. 1) RETURN 
-      DO 105 I=2,IDO 
-        DO 104 K=1,L1 
-         M2 = M2S 
-         DO 104 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            TR2 = CC(1,M1,K,I,2)+CC(1,M1,K,I,3) 
-            CR2 = CC(1,M1,K,I,1)+TAUR*TR2 
-            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+TR2 
-            TI2 = CC(2,M1,K,I,2)+CC(2,M1,K,I,3) 
-            CI2 = CC(2,M1,K,I,1)+TAUR*TI2 
-            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+TI2 
-            CR3 = TAUI*(CC(1,M1,K,I,2)-CC(1,M1,K,I,3)) 
-            CI3 = TAUI*(CC(2,M1,K,I,2)-CC(2,M1,K,I,3)) 
-            DR2 = CR2-CI3 
-            DR3 = CR2+CI3 
-            DI2 = CI2+CR3 
-            DI3 = CI2-CR3 
-            CH(2,M2,K,2,I) = WA(I,1,1)*DI2+WA(I,1,2)*DR2 
-            CH(1,M2,K,2,I) = WA(I,1,1)*DR2-WA(I,1,2)*DI2 
-            CH(2,M2,K,3,I) = WA(I,2,1)*DI3+WA(I,2,2)*DR3 
-            CH(1,M2,K,3,I) = WA(I,2,1)*DR3-WA(I,2,2)*DI3 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine cmf3kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! CMF3KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(2,in1,l1,ido,3)
+  real ( kind = 4 ) ch(2,in2,l1,3,ido)
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) di2
+  real ( kind = 4 ) di3
+  real ( kind = 4 ) dr2
+  real ( kind = 4 ) dr3
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 4 ), parameter :: taui =  0.866025403784439E+00
+  real ( kind = 4 ), parameter :: taur = -0.5E+00
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) wa(ido,2,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido .or. na == 1 ) then
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+
+        m2 = m2 + im2
+
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
+        cr2 = cc(1,m1,k,1,1)+taur*tr2
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2
+
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
+        ci2 = cc(2,m1,k,1,1)+taur*ti2
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2
+
+        cr3 = taui * (cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
+        ci3 = taui * (cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
+
+        ch(1,m2,k,2,1) = cr2-ci3
+        ch(1,m2,k,3,1) = cr2+ci3
+        ch(2,m2,k,2,1) = ci2+cr3
+        ch(2,m2,k,3,1) = ci2-cr3
+
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,3)
+          cr2 = cc(1,m1,k,i,1)+taur*tr2
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2
+          ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,3)
+          ci2 = cc(2,m1,k,i,1)+taur*ti2
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2
+          cr3 = taui*(cc(1,m1,k,i,2)-cc(1,m1,k,i,3))
+          ci3 = taui*(cc(2,m1,k,i,2)-cc(2,m1,k,i,3))
+          dr2 = cr2-ci3
+          dr3 = cr2+ci3
+          di2 = ci2+cr3
+          di3 = ci2-cr3
+          ch(2,m2,k,2,i) = wa(i,1,1)*di2+wa(i,1,2)*dr2
+          ch(1,m2,k,2,i) = wa(i,1,1)*dr2-wa(i,1,2)*di2
+          ch(2,m2,k,3,i) = wa(i,2,1)*di3+wa(i,2,2)*dr3
+          ch(1,m2,k,3,i) = wa(i,2,1)*dr3-wa(i,2,2)*di3
+        end do
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
+        cr2 = cc(1,m1,k,1,1)+taur*tr2
+        cc(1,m1,k,1,1) = cc(1,m1,k,1,1)+tr2
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
+        ci2 = cc(2,m1,k,1,1)+taur*ti2
+        cc(2,m1,k,1,1) = cc(2,m1,k,1,1)+ti2
+        cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
+        ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
+        cc(1,m1,k,1,2) = cr2-ci3
+        cc(1,m1,k,1,3) = cr2+ci3
+        cc(2,m1,k,1,2) = ci2+cr3
+        cc(2,m1,k,1,3) = ci2-cr3
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmf3kf.F b/wrfv2_fire/external/fftpack/fftpack5/cmf3kf.F
index e894e808..b7c0c607 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmf3kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmf3kf.F
@@ -1,95 +1,166 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cmf3kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CMF3KF (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
-      REAL  CC(2,IN1,L1,IDO,3),CH(2,IN2,L1,3,IDO),WA(IDO,2,2) 
-      DATA TAUR,TAUI /-.5,-.866025403784439/ 
-!                                                                       
-      M1D = (LOT-1)*IM1+1 
-      M2S = 1-IM2 
-      IF (IDO .GT. 1) GO TO 102 
-      SN = 1./REAL(3*L1) 
-      IF (NA .EQ. 1) GO TO 106 
-      DO 101 K=1,L1 
-         DO 101 M1=1,M1D,IM1 
-         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,3) 
-         CR2 = CC(1,M1,K,1,1)+TAUR*TR2 
-         CC(1,M1,K,1,1) = SN*(CC(1,M1,K,1,1)+TR2) 
-         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,3) 
-         CI2 = CC(2,M1,K,1,1)+TAUR*TI2 
-         CC(2,M1,K,1,1) = SN*(CC(2,M1,K,1,1)+TI2) 
-         CR3 = TAUI*(CC(1,M1,K,1,2)-CC(1,M1,K,1,3)) 
-         CI3 = TAUI*(CC(2,M1,K,1,2)-CC(2,M1,K,1,3)) 
-         CC(1,M1,K,1,2) = SN*(CR2-CI3) 
-         CC(1,M1,K,1,3) = SN*(CR2+CI3) 
-         CC(2,M1,K,1,2) = SN*(CI2+CR3) 
-         CC(2,M1,K,1,3) = SN*(CI2-CR3) 
-  101 CONTINUE 
-      RETURN 
-  106 DO 107 K=1,L1 
-         M2 = M2S 
-         DO 107 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,3) 
-         CR2 = CC(1,M1,K,1,1)+TAUR*TR2 
-         CH(1,M2,K,1,1) = SN*(CC(1,M1,K,1,1)+TR2) 
-         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,3) 
-         CI2 = CC(2,M1,K,1,1)+TAUR*TI2 
-         CH(2,M2,K,1,1) = SN*(CC(2,M1,K,1,1)+TI2) 
-         CR3 = TAUI*(CC(1,M1,K,1,2)-CC(1,M1,K,1,3)) 
-         CI3 = TAUI*(CC(2,M1,K,1,2)-CC(2,M1,K,1,3)) 
-         CH(1,M2,K,2,1) = SN*(CR2-CI3) 
-         CH(1,M2,K,3,1) = SN*(CR2+CI3) 
-         CH(2,M2,K,2,1) = SN*(CI2+CR3) 
-         CH(2,M2,K,3,1) = SN*(CI2-CR3) 
-  107 CONTINUE 
-      RETURN 
-  102 DO 103 K=1,L1 
-         M2 = M2S 
-         DO 103 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,3) 
-         CR2 = CC(1,M1,K,1,1)+TAUR*TR2 
-         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+TR2 
-         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,3) 
-         CI2 = CC(2,M1,K,1,1)+TAUR*TI2 
-         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+TI2 
-         CR3 = TAUI*(CC(1,M1,K,1,2)-CC(1,M1,K,1,3)) 
-         CI3 = TAUI*(CC(2,M1,K,1,2)-CC(2,M1,K,1,3)) 
-         CH(1,M2,K,2,1) = CR2-CI3 
-         CH(1,M2,K,3,1) = CR2+CI3 
-         CH(2,M2,K,2,1) = CI2+CR3 
-         CH(2,M2,K,3,1) = CI2-CR3 
-  103 CONTINUE 
-      DO 105 I=2,IDO 
-        DO 104 K=1,L1 
-         M2 = M2S 
-         DO 104 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            TR2 = CC(1,M1,K,I,2)+CC(1,M1,K,I,3) 
-            CR2 = CC(1,M1,K,I,1)+TAUR*TR2 
-            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+TR2 
-            TI2 = CC(2,M1,K,I,2)+CC(2,M1,K,I,3) 
-            CI2 = CC(2,M1,K,I,1)+TAUR*TI2 
-            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+TI2 
-            CR3 = TAUI*(CC(1,M1,K,I,2)-CC(1,M1,K,I,3)) 
-            CI3 = TAUI*(CC(2,M1,K,I,2)-CC(2,M1,K,I,3)) 
-            DR2 = CR2-CI3 
-            DR3 = CR2+CI3 
-            DI2 = CI2+CR3 
-            DI3 = CI2-CR3 
-            CH(2,M2,K,2,I) = WA(I,1,1)*DI2-WA(I,1,2)*DR2 
-            CH(1,M2,K,2,I) = WA(I,1,1)*DR2+WA(I,1,2)*DI2 
-            CH(2,M2,K,3,I) = WA(I,2,1)*DI3-WA(I,2,2)*DR3 
-            CH(1,M2,K,3,I) = WA(I,2,1)*DR3+WA(I,2,2)*DI3 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine cmf3kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! CMF3KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(2,in1,l1,ido,3)
+  real ( kind = 4 ) ch(2,in2,l1,3,ido)
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) di2
+  real ( kind = 4 ) di3
+  real ( kind = 4 ) dr2
+  real ( kind = 4 ) dr3
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) sn
+  real ( kind = 4 ), parameter :: taui = -0.866025403784439E+00
+  real ( kind = 4 ), parameter :: taur = -0.5E+00
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) wa(ido,2,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
+        cr2 = cc(1,m1,k,1,1)+taur*tr2
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
+        ci2 = cc(2,m1,k,1,1)+taur*ti2
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2
+        cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
+        ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
+        ch(1,m2,k,2,1) = cr2-ci3
+        ch(1,m2,k,3,1) = cr2+ci3
+        ch(2,m2,k,2,1) = ci2+cr3
+        ch(2,m2,k,3,1) = ci2-cr3
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,3)
+          cr2 = cc(1,m1,k,i,1)+taur*tr2
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2
+          ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,3)
+          ci2 = cc(2,m1,k,i,1)+taur*ti2
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2
+          cr3 = taui*(cc(1,m1,k,i,2)-cc(1,m1,k,i,3))
+          ci3 = taui*(cc(2,m1,k,i,2)-cc(2,m1,k,i,3))
+          dr2 = cr2-ci3
+          dr3 = cr2+ci3
+          di2 = ci2+cr3
+          di3 = ci2-cr3
+          ch(2,m2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2
+          ch(1,m2,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2
+          ch(2,m2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3
+          ch(1,m2,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0E+00 / real ( 3 * l1, kind = 4 )
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
+        cr2 = cc(1,m1,k,1,1)+taur*tr2
+        ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
+        ci2 = cc(2,m1,k,1,1)+taur*ti2
+        ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2)
+        cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
+        ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
+        ch(1,m2,k,2,1) = sn*(cr2-ci3)
+        ch(1,m2,k,3,1) = sn*(cr2+ci3)
+        ch(2,m2,k,2,1) = sn*(ci2+cr3)
+        ch(2,m2,k,3,1) = sn*(ci2-cr3)
+      end do
+    end do
+
+  else
+
+    sn = 1.0E+00 / real ( 3 * l1, kind = 4 )
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
+        cr2 = cc(1,m1,k,1,1)+taur*tr2
+        cc(1,m1,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
+        ci2 = cc(2,m1,k,1,1)+taur*ti2
+        cc(2,m1,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2)
+        cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
+        ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
+        cc(1,m1,k,1,2) = sn*(cr2-ci3)
+        cc(1,m1,k,1,3) = sn*(cr2+ci3)
+        cc(2,m1,k,1,2) = sn*(ci2+cr3)
+        cc(2,m1,k,1,3) = sn*(ci2-cr3)
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmf4kb.F b/wrfv2_fire/external/fftpack/fftpack5/cmf4kb.F
index eb6c754d..417c7fda 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmf4kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmf4kb.F
@@ -1,91 +1,156 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cmf4kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CMF4KB (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
-      REAL CC(2,IN1,L1,IDO,4),CH(2,IN2,L1,4,IDO),WA(IDO,3,2) 
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      M1D = (LOT-1)*IM1+1 
-      M2S = 1-IM2 
-      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
-      DO 101 K=1,L1 
-         DO 101 M1=1,M1D,IM1 
-         TI1 = CC(2,M1,K,1,1)-CC(2,M1,K,1,3) 
-         TI2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,3) 
-         TR4 = CC(2,M1,K,1,4)-CC(2,M1,K,1,2) 
-         TI3 = CC(2,M1,K,1,2)+CC(2,M1,K,1,4) 
-         TR1 = CC(1,M1,K,1,1)-CC(1,M1,K,1,3) 
-         TR2 = CC(1,M1,K,1,1)+CC(1,M1,K,1,3) 
-         TI4 = CC(1,M1,K,1,2)-CC(1,M1,K,1,4) 
-         TR3 = CC(1,M1,K,1,2)+CC(1,M1,K,1,4) 
-         CC(1,M1,K,1,1) = TR2+TR3 
-         CC(1,M1,K,1,3) = TR2-TR3 
-         CC(2,M1,K,1,1) = TI2+TI3 
-         CC(2,M1,K,1,3) = TI2-TI3 
-         CC(1,M1,K,1,2) = TR1+TR4 
-         CC(1,M1,K,1,4) = TR1-TR4 
-         CC(2,M1,K,1,2) = TI1+TI4 
-         CC(2,M1,K,1,4) = TI1-TI4 
-  101 CONTINUE 
-      RETURN 
-  102 DO 103 K=1,L1 
-         M2 = M2S 
-         DO 103 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         TI1 = CC(2,M1,K,1,1)-CC(2,M1,K,1,3) 
-         TI2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,3) 
-         TR4 = CC(2,M1,K,1,4)-CC(2,M1,K,1,2) 
-         TI3 = CC(2,M1,K,1,2)+CC(2,M1,K,1,4) 
-         TR1 = CC(1,M1,K,1,1)-CC(1,M1,K,1,3) 
-         TR2 = CC(1,M1,K,1,1)+CC(1,M1,K,1,3) 
-         TI4 = CC(1,M1,K,1,2)-CC(1,M1,K,1,4) 
-         TR3 = CC(1,M1,K,1,2)+CC(1,M1,K,1,4) 
-         CH(1,M2,K,1,1) = TR2+TR3 
-         CH(1,M2,K,3,1) = TR2-TR3 
-         CH(2,M2,K,1,1) = TI2+TI3 
-         CH(2,M2,K,3,1) = TI2-TI3 
-         CH(1,M2,K,2,1) = TR1+TR4 
-         CH(1,M2,K,4,1) = TR1-TR4 
-         CH(2,M2,K,2,1) = TI1+TI4 
-         CH(2,M2,K,4,1) = TI1-TI4 
-  103 CONTINUE 
-      IF(IDO .EQ. 1) RETURN 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-         M2 = M2S 
-         DO 104 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            TI1 = CC(2,M1,K,I,1)-CC(2,M1,K,I,3) 
-            TI2 = CC(2,M1,K,I,1)+CC(2,M1,K,I,3) 
-            TI3 = CC(2,M1,K,I,2)+CC(2,M1,K,I,4) 
-            TR4 = CC(2,M1,K,I,4)-CC(2,M1,K,I,2) 
-            TR1 = CC(1,M1,K,I,1)-CC(1,M1,K,I,3) 
-            TR2 = CC(1,M1,K,I,1)+CC(1,M1,K,I,3) 
-            TI4 = CC(1,M1,K,I,2)-CC(1,M1,K,I,4) 
-            TR3 = CC(1,M1,K,I,2)+CC(1,M1,K,I,4) 
-            CH(1,M2,K,1,I) = TR2+TR3 
-            CR3 = TR2-TR3 
-            CH(2,M2,K,1,I) = TI2+TI3 
-            CI3 = TI2-TI3 
-            CR2 = TR1+TR4 
-            CR4 = TR1-TR4 
-            CI2 = TI1+TI4 
-            CI4 = TI1-TI4 
-            CH(1,M2,K,2,I) = WA(I,1,1)*CR2-WA(I,1,2)*CI2 
-            CH(2,M2,K,2,I) = WA(I,1,1)*CI2+WA(I,1,2)*CR2 
-            CH(1,M2,K,3,I) = WA(I,2,1)*CR3-WA(I,2,2)*CI3 
-            CH(2,M2,K,3,I) = WA(I,2,1)*CI3+WA(I,2,2)*CR3 
-            CH(1,M2,K,4,I) = WA(I,3,1)*CR4-WA(I,3,2)*CI4 
-            CH(2,M2,K,4,I) = WA(I,3,1)*CI4+WA(I,3,2)*CR4 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine cmf4kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! CMF4KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(2,in1,l1,ido,4)
+  real ( kind = 4 ) ch(2,in2,l1,4,ido)
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) ci4
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) cr4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) ti1
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) ti3
+  real ( kind = 4 ) ti4
+  real ( kind = 4 ) tr1
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) tr3
+  real ( kind = 4 ) tr4
+  real ( kind = 4 ) wa(ido,3,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
+        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
+        tr4 = cc(2,m1,k,1,4)-cc(2,m1,k,1,2)
+        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
+        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
+        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
+        ti4 = cc(1,m1,k,1,2)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = tr2+tr3
+        ch(1,m2,k,3,1) = tr2-tr3
+        ch(2,m2,k,1,1) = ti2+ti3
+        ch(2,m2,k,3,1) = ti2-ti3
+        ch(1,m2,k,2,1) = tr1+tr4
+        ch(1,m2,k,4,1) = tr1-tr4
+        ch(2,m2,k,2,1) = ti1+ti4
+        ch(2,m2,k,4,1) = ti1-ti4
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ti1 = cc(2,m1,k,i,1)-cc(2,m1,k,i,3)
+          ti2 = cc(2,m1,k,i,1)+cc(2,m1,k,i,3)
+          ti3 = cc(2,m1,k,i,2)+cc(2,m1,k,i,4)
+          tr4 = cc(2,m1,k,i,4)-cc(2,m1,k,i,2)
+          tr1 = cc(1,m1,k,i,1)-cc(1,m1,k,i,3)
+          tr2 = cc(1,m1,k,i,1)+cc(1,m1,k,i,3)
+          ti4 = cc(1,m1,k,i,2)-cc(1,m1,k,i,4)
+          tr3 = cc(1,m1,k,i,2)+cc(1,m1,k,i,4)
+          ch(1,m2,k,1,i) = tr2+tr3
+          cr3 = tr2-tr3
+          ch(2,m2,k,1,i) = ti2+ti3
+          ci3 = ti2-ti3
+          cr2 = tr1+tr4
+          cr4 = tr1-tr4
+          ci2 = ti1+ti4
+          ci4 = ti1-ti4
+          ch(1,m2,k,2,i) = wa(i,1,1)*cr2-wa(i,1,2)*ci2
+          ch(2,m2,k,2,i) = wa(i,1,1)*ci2+wa(i,1,2)*cr2
+          ch(1,m2,k,3,i) = wa(i,2,1)*cr3-wa(i,2,2)*ci3
+          ch(2,m2,k,3,i) = wa(i,2,1)*ci3+wa(i,2,2)*cr3
+          ch(1,m2,k,4,i) = wa(i,3,1)*cr4-wa(i,3,2)*ci4
+          ch(2,m2,k,4,i) = wa(i,3,1)*ci4+wa(i,3,2)*cr4
+        end do
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
+        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
+        tr4 = cc(2,m1,k,1,4)-cc(2,m1,k,1,2)
+        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
+        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
+        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
+        ti4 = cc(1,m1,k,1,2)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
+        cc(1,m1,k,1,1) = tr2+tr3
+        cc(1,m1,k,1,3) = tr2-tr3
+        cc(2,m1,k,1,1) = ti2+ti3
+        cc(2,m1,k,1,3) = ti2-ti3
+        cc(1,m1,k,1,2) = tr1+tr4
+        cc(1,m1,k,1,4) = tr1-tr4
+        cc(2,m1,k,1,2) = ti1+ti4
+        cc(2,m1,k,1,4) = ti1-ti4
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmf4kf.F b/wrfv2_fire/external/fftpack/fftpack5/cmf4kf.F
index 5435ccea..5916fb0c 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmf4kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmf4kf.F
@@ -1,114 +1,186 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cmf4kf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CMF4KF (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
-      REAL CC(2,IN1,L1,IDO,4),CH(2,IN2,L1,4,IDO),WA(IDO,3,2) 
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      M1D = (LOT-1)*IM1+1 
-      M2S = 1-IM2 
-      IF (IDO .GT. 1) GO TO 102 
-      SN = 1./REAL(4*L1) 
-      IF (NA .EQ. 1) GO TO 106 
-      DO 101 K=1,L1 
-         DO 101 M1=1,M1D,IM1 
-         TI1 = CC(2,M1,K,1,1)-CC(2,M1,K,1,3) 
-         TI2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,3) 
-         TR4 = CC(2,M1,K,1,2)-CC(2,M1,K,1,4) 
-         TI3 = CC(2,M1,K,1,2)+CC(2,M1,K,1,4) 
-         TR1 = CC(1,M1,K,1,1)-CC(1,M1,K,1,3) 
-         TR2 = CC(1,M1,K,1,1)+CC(1,M1,K,1,3) 
-         TI4 = CC(1,M1,K,1,4)-CC(1,M1,K,1,2) 
-         TR3 = CC(1,M1,K,1,2)+CC(1,M1,K,1,4) 
-         CC(1,M1,K,1,1) = SN*(TR2+TR3) 
-         CC(1,M1,K,1,3) = SN*(TR2-TR3) 
-         CC(2,M1,K,1,1) = SN*(TI2+TI3) 
-         CC(2,M1,K,1,3) = SN*(TI2-TI3) 
-         CC(1,M1,K,1,2) = SN*(TR1+TR4) 
-         CC(1,M1,K,1,4) = SN*(TR1-TR4) 
-         CC(2,M1,K,1,2) = SN*(TI1+TI4) 
-         CC(2,M1,K,1,4) = SN*(TI1-TI4) 
-  101 CONTINUE 
-      RETURN 
-  106 DO 107 K=1,L1 
-         M2 = M2S 
-         DO 107 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         TI1 = CC(2,M1,K,1,1)-CC(2,M1,K,1,3) 
-         TI2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,3) 
-         TR4 = CC(2,M1,K,1,2)-CC(2,M1,K,1,4) 
-         TI3 = CC(2,M1,K,1,2)+CC(2,M1,K,1,4) 
-         TR1 = CC(1,M1,K,1,1)-CC(1,M1,K,1,3) 
-         TR2 = CC(1,M1,K,1,1)+CC(1,M1,K,1,3) 
-         TI4 = CC(1,M1,K,1,4)-CC(1,M1,K,1,2) 
-         TR3 = CC(1,M1,K,1,2)+CC(1,M1,K,1,4) 
-         CH(1,M2,K,1,1) = SN*(TR2+TR3) 
-         CH(1,M2,K,3,1) = SN*(TR2-TR3) 
-         CH(2,M2,K,1,1) = SN*(TI2+TI3) 
-         CH(2,M2,K,3,1) = SN*(TI2-TI3) 
-         CH(1,M2,K,2,1) = SN*(TR1+TR4) 
-         CH(1,M2,K,4,1) = SN*(TR1-TR4) 
-         CH(2,M2,K,2,1) = SN*(TI1+TI4) 
-         CH(2,M2,K,4,1) = SN*(TI1-TI4) 
-  107 CONTINUE 
-      RETURN 
-  102 DO 103 K=1,L1 
-         M2 = M2S 
-         DO 103 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         TI1 = CC(2,M1,K,1,1)-CC(2,M1,K,1,3) 
-         TI2 = CC(2,M1,K,1,1)+CC(2,M1,K,1,3) 
-         TR4 = CC(2,M1,K,1,2)-CC(2,M1,K,1,4) 
-         TI3 = CC(2,M1,K,1,2)+CC(2,M1,K,1,4) 
-         TR1 = CC(1,M1,K,1,1)-CC(1,M1,K,1,3) 
-         TR2 = CC(1,M1,K,1,1)+CC(1,M1,K,1,3) 
-         TI4 = CC(1,M1,K,1,4)-CC(1,M1,K,1,2) 
-         TR3 = CC(1,M1,K,1,2)+CC(1,M1,K,1,4) 
-         CH(1,M2,K,1,1) = TR2+TR3 
-         CH(1,M2,K,3,1) = TR2-TR3 
-         CH(2,M2,K,1,1) = TI2+TI3 
-         CH(2,M2,K,3,1) = TI2-TI3 
-         CH(1,M2,K,2,1) = TR1+TR4 
-         CH(1,M2,K,4,1) = TR1-TR4 
-         CH(2,M2,K,2,1) = TI1+TI4 
-         CH(2,M2,K,4,1) = TI1-TI4 
-  103 CONTINUE 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-         M2 = M2S 
-         DO 104 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            TI1 = CC(2,M1,K,I,1)-CC(2,M1,K,I,3) 
-            TI2 = CC(2,M1,K,I,1)+CC(2,M1,K,I,3) 
-            TI3 = CC(2,M1,K,I,2)+CC(2,M1,K,I,4) 
-            TR4 = CC(2,M1,K,I,2)-CC(2,M1,K,I,4) 
-            TR1 = CC(1,M1,K,I,1)-CC(1,M1,K,I,3) 
-            TR2 = CC(1,M1,K,I,1)+CC(1,M1,K,I,3) 
-            TI4 = CC(1,M1,K,I,4)-CC(1,M1,K,I,2) 
-            TR3 = CC(1,M1,K,I,2)+CC(1,M1,K,I,4) 
-            CH(1,M2,K,1,I) = TR2+TR3 
-            CR3 = TR2-TR3 
-            CH(2,M2,K,1,I) = TI2+TI3 
-            CI3 = TI2-TI3 
-            CR2 = TR1+TR4 
-            CR4 = TR1-TR4 
-            CI2 = TI1+TI4 
-            CI4 = TI1-TI4 
-            CH(1,M2,K,2,I) = WA(I,1,1)*CR2+WA(I,1,2)*CI2 
-            CH(2,M2,K,2,I) = WA(I,1,1)*CI2-WA(I,1,2)*CR2 
-            CH(1,M2,K,3,I) = WA(I,2,1)*CR3+WA(I,2,2)*CI3 
-            CH(2,M2,K,3,I) = WA(I,2,1)*CI3-WA(I,2,2)*CR3 
-            CH(1,M2,K,4,I) = WA(I,3,1)*CR4+WA(I,3,2)*CI4 
-            CH(2,M2,K,4,I) = WA(I,3,1)*CI4-WA(I,3,2)*CR4 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine cmf4kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! CMF4KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(2,in1,l1,ido,4)
+  real ( kind = 4 ) ch(2,in2,l1,4,ido)
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) ci4
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) cr4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) sn
+  real ( kind = 4 ) ti1
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) ti3
+  real ( kind = 4 ) ti4
+  real ( kind = 4 ) tr1
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) tr3
+  real ( kind = 4 ) tr4
+  real ( kind = 4 ) wa(ido,3,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
+        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
+        tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
+        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
+        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
+        ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
+        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = tr2+tr3
+        ch(1,m2,k,3,1) = tr2-tr3
+        ch(2,m2,k,1,1) = ti2+ti3
+        ch(2,m2,k,3,1) = ti2-ti3
+        ch(1,m2,k,2,1) = tr1+tr4
+        ch(1,m2,k,4,1) = tr1-tr4
+        ch(2,m2,k,2,1) = ti1+ti4
+        ch(2,m2,k,4,1) = ti1-ti4
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ti1 = cc(2,m1,k,i,1)-cc(2,m1,k,i,3)
+          ti2 = cc(2,m1,k,i,1)+cc(2,m1,k,i,3)
+          ti3 = cc(2,m1,k,i,2)+cc(2,m1,k,i,4)
+          tr4 = cc(2,m1,k,i,2)-cc(2,m1,k,i,4)
+          tr1 = cc(1,m1,k,i,1)-cc(1,m1,k,i,3)
+          tr2 = cc(1,m1,k,i,1)+cc(1,m1,k,i,3)
+          ti4 = cc(1,m1,k,i,4)-cc(1,m1,k,i,2)
+          tr3 = cc(1,m1,k,i,2)+cc(1,m1,k,i,4)
+          ch(1,m2,k,1,i) = tr2+tr3
+          cr3 = tr2-tr3
+          ch(2,m2,k,1,i) = ti2+ti3
+          ci3 = ti2-ti3
+          cr2 = tr1+tr4
+          cr4 = tr1-tr4
+          ci2 = ti1+ti4
+          ci4 = ti1-ti4
+          ch(1,m2,k,2,i) = wa(i,1,1)*cr2+wa(i,1,2)*ci2
+          ch(2,m2,k,2,i) = wa(i,1,1)*ci2-wa(i,1,2)*cr2
+          ch(1,m2,k,3,i) = wa(i,2,1)*cr3+wa(i,2,2)*ci3
+          ch(2,m2,k,3,i) = wa(i,2,1)*ci3-wa(i,2,2)*cr3
+          ch(1,m2,k,4,i) = wa(i,3,1)*cr4+wa(i,3,2)*ci4
+          ch(2,m2,k,4,i) = wa(i,3,1)*ci4-wa(i,3,2)*cr4
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0E+00 / real ( 4 * l1, kind = 4 )
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
+        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
+        tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
+        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
+        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
+        ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
+        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = sn*(tr2+tr3)
+        ch(1,m2,k,3,1) = sn*(tr2-tr3)
+        ch(2,m2,k,1,1) = sn*(ti2+ti3)
+        ch(2,m2,k,3,1) = sn*(ti2-ti3)
+        ch(1,m2,k,2,1) = sn*(tr1+tr4)
+        ch(1,m2,k,4,1) = sn*(tr1-tr4)
+        ch(2,m2,k,2,1) = sn*(ti1+ti4)
+        ch(2,m2,k,4,1) = sn*(ti1-ti4)
+      end do
+    end do
+
+  else
+
+    sn = 1.0E+00 / real ( 4 * l1, kind = 4 )
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
+        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
+        tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
+        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
+        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
+        ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
+        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
+        cc(1,m1,k,1,1) = sn*(tr2+tr3)
+        cc(1,m1,k,1,3) = sn*(tr2-tr3)
+        cc(2,m1,k,1,1) = sn*(ti2+ti3)
+        cc(2,m1,k,1,3) = sn*(ti2-ti3)
+        cc(1,m1,k,1,2) = sn*(tr1+tr4)
+        cc(1,m1,k,1,4) = sn*(tr1-tr4)
+        cc(2,m1,k,1,2) = sn*(ti1+ti4)
+        cc(2,m1,k,1,4) = sn*(ti1-ti4)
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmf5kb.F b/wrfv2_fire/external/fftpack/fftpack5/cmf5kb.F
index fae0dfdf..b4a63eb3 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmf5kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmf5kb.F
@@ -1,127 +1,210 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cmf5kb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CMF5KB (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
-      REAL  CC(2,IN1,L1,IDO,5),CH(2,IN2,L1,5,IDO),WA(IDO,4,2) 
-      DATA TR11,TI11,TR12,TI12 /.3090169943749474,.9510565162951536,    &
-     &-.8090169943749474,.5877852522924731/                             
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      M1D = (LOT-1)*IM1+1 
-      M2S = 1-IM2 
-      IF (IDO.GT.1 .OR. NA.EQ.1) GO TO 102 
-      DO 101 K=1,L1 
-         DO 101 M1=1,M1D,IM1 
-         TI5 = CC(2,M1,K,1,2)-CC(2,M1,K,1,5) 
-         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,5) 
-         TI4 = CC(2,M1,K,1,3)-CC(2,M1,K,1,4) 
-         TI3 = CC(2,M1,K,1,3)+CC(2,M1,K,1,4) 
-         TR5 = CC(1,M1,K,1,2)-CC(1,M1,K,1,5) 
-         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,5) 
-         TR4 = CC(1,M1,K,1,3)-CC(1,M1,K,1,4) 
-         TR3 = CC(1,M1,K,1,3)+CC(1,M1,K,1,4) 
-         CHOLD1 = CC(1,M1,K,1,1)+TR2+TR3 
-         CHOLD2 = CC(2,M1,K,1,1)+TI2+TI3 
-         CR2 = CC(1,M1,K,1,1)+TR11*TR2+TR12*TR3 
-         CI2 = CC(2,M1,K,1,1)+TR11*TI2+TR12*TI3 
-         CR3 = CC(1,M1,K,1,1)+TR12*TR2+TR11*TR3 
-         CI3 = CC(2,M1,K,1,1)+TR12*TI2+TR11*TI3 
-         CC(1,M1,K,1,1) = CHOLD1 
-         CC(2,M1,K,1,1) = CHOLD2 
-         CR5 = TI11*TR5+TI12*TR4 
-         CI5 = TI11*TI5+TI12*TI4 
-         CR4 = TI12*TR5-TI11*TR4 
-         CI4 = TI12*TI5-TI11*TI4 
-         CC(1,M1,K,1,2) = CR2-CI5 
-         CC(1,M1,K,1,5) = CR2+CI5 
-         CC(2,M1,K,1,2) = CI2+CR5 
-         CC(2,M1,K,1,3) = CI3+CR4 
-         CC(1,M1,K,1,3) = CR3-CI4 
-         CC(1,M1,K,1,4) = CR3+CI4 
-         CC(2,M1,K,1,4) = CI3-CR4 
-         CC(2,M1,K,1,5) = CI2-CR5 
-  101 CONTINUE 
-      RETURN 
-  102 DO 103 K=1,L1 
-         M2 = M2S 
-         DO 103 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         TI5 = CC(2,M1,K,1,2)-CC(2,M1,K,1,5) 
-         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,5) 
-         TI4 = CC(2,M1,K,1,3)-CC(2,M1,K,1,4) 
-         TI3 = CC(2,M1,K,1,3)+CC(2,M1,K,1,4) 
-         TR5 = CC(1,M1,K,1,2)-CC(1,M1,K,1,5) 
-         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,5) 
-         TR4 = CC(1,M1,K,1,3)-CC(1,M1,K,1,4) 
-         TR3 = CC(1,M1,K,1,3)+CC(1,M1,K,1,4) 
-         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+TR2+TR3 
-         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+TI2+TI3 
-         CR2 = CC(1,M1,K,1,1)+TR11*TR2+TR12*TR3 
-         CI2 = CC(2,M1,K,1,1)+TR11*TI2+TR12*TI3 
-         CR3 = CC(1,M1,K,1,1)+TR12*TR2+TR11*TR3 
-         CI3 = CC(2,M1,K,1,1)+TR12*TI2+TR11*TI3 
-         CR5 = TI11*TR5+TI12*TR4 
-         CI5 = TI11*TI5+TI12*TI4 
-         CR4 = TI12*TR5-TI11*TR4 
-         CI4 = TI12*TI5-TI11*TI4 
-         CH(1,M2,K,2,1) = CR2-CI5 
-         CH(1,M2,K,5,1) = CR2+CI5 
-         CH(2,M2,K,2,1) = CI2+CR5 
-         CH(2,M2,K,3,1) = CI3+CR4 
-         CH(1,M2,K,3,1) = CR3-CI4 
-         CH(1,M2,K,4,1) = CR3+CI4 
-         CH(2,M2,K,4,1) = CI3-CR4 
-         CH(2,M2,K,5,1) = CI2-CR5 
-  103 CONTINUE 
-      IF(IDO .EQ. 1) RETURN 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-         M2 = M2S 
-         DO 104 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            TI5 = CC(2,M1,K,I,2)-CC(2,M1,K,I,5) 
-            TI2 = CC(2,M1,K,I,2)+CC(2,M1,K,I,5) 
-            TI4 = CC(2,M1,K,I,3)-CC(2,M1,K,I,4) 
-            TI3 = CC(2,M1,K,I,3)+CC(2,M1,K,I,4) 
-            TR5 = CC(1,M1,K,I,2)-CC(1,M1,K,I,5) 
-            TR2 = CC(1,M1,K,I,2)+CC(1,M1,K,I,5) 
-            TR4 = CC(1,M1,K,I,3)-CC(1,M1,K,I,4) 
-            TR3 = CC(1,M1,K,I,3)+CC(1,M1,K,I,4) 
-            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+TR2+TR3 
-            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+TI2+TI3 
-            CR2 = CC(1,M1,K,I,1)+TR11*TR2+TR12*TR3 
-            CI2 = CC(2,M1,K,I,1)+TR11*TI2+TR12*TI3 
-            CR3 = CC(1,M1,K,I,1)+TR12*TR2+TR11*TR3 
-            CI3 = CC(2,M1,K,I,1)+TR12*TI2+TR11*TI3 
-            CR5 = TI11*TR5+TI12*TR4 
-            CI5 = TI11*TI5+TI12*TI4 
-            CR4 = TI12*TR5-TI11*TR4 
-            CI4 = TI12*TI5-TI11*TI4 
-            DR3 = CR3-CI4 
-            DR4 = CR3+CI4 
-            DI3 = CI3+CR4 
-            DI4 = CI3-CR4 
-            DR5 = CR2+CI5 
-            DR2 = CR2-CI5 
-            DI5 = CI2-CR5 
-            DI2 = CI2+CR5 
-            CH(1,M2,K,2,I) = WA(I,1,1)*DR2-WA(I,1,2)*DI2 
-            CH(2,M2,K,2,I) = WA(I,1,1)*DI2+WA(I,1,2)*DR2 
-            CH(1,M2,K,3,I) = WA(I,2,1)*DR3-WA(I,2,2)*DI3 
-            CH(2,M2,K,3,I) = WA(I,2,1)*DI3+WA(I,2,2)*DR3 
-            CH(1,M2,K,4,I) = WA(I,3,1)*DR4-WA(I,3,2)*DI4 
-            CH(2,M2,K,4,I) = WA(I,3,1)*DI4+WA(I,3,2)*DR4 
-            CH(1,M2,K,5,I) = WA(I,4,1)*DR5-WA(I,4,2)*DI5 
-            CH(2,M2,K,5,I) = WA(I,4,1)*DI5+WA(I,4,2)*DR5 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine cmf5kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! CMF5KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(2,in1,l1,ido,5)
+  real ( kind = 4 ) ch(2,in2,l1,5,ido)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) ci4
+  real ( kind = 4 ) ci5
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) cr4
+  real ( kind = 4 ) cr5
+  real ( kind = 4 ) di2
+  real ( kind = 4 ) di3
+  real ( kind = 4 ) di4
+  real ( kind = 4 ) di5
+  real ( kind = 4 ) dr2
+  real ( kind = 4 ) dr3
+  real ( kind = 4 ) dr4
+  real ( kind = 4 ) dr5
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) ti3
+  real ( kind = 4 ) ti4
+  real ( kind = 4 ) ti5
+  real ( kind = 4 ), parameter :: ti11 =  0.9510565162951536E+00
+  real ( kind = 4 ), parameter :: ti12 =  0.5877852522924731E+00
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) tr3
+  real ( kind = 4 ) tr4
+  real ( kind = 4 ) tr5
+  real ( kind = 4 ), parameter :: tr11 =  0.3090169943749474E+00
+  real ( kind = 4 ), parameter :: tr12 = -0.8090169943749474E+00
+  real ( kind = 4 ) wa(ido,4,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
+        ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
+        tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
+        tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2+tr3
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2+ti3
+        cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
+        ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
+        cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
+        ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
+        cr5 = ti11*tr5+ti12*tr4
+        ci5 = ti11*ti5+ti12*ti4
+        cr4 = ti12*tr5-ti11*tr4
+        ci4 = ti12*ti5-ti11*ti4
+        ch(1,m2,k,2,1) = cr2-ci5
+        ch(1,m2,k,5,1) = cr2+ci5
+        ch(2,m2,k,2,1) = ci2+cr5
+        ch(2,m2,k,3,1) = ci3+cr4
+        ch(1,m2,k,3,1) = cr3-ci4
+        ch(1,m2,k,4,1) = cr3+ci4
+        ch(2,m2,k,4,1) = ci3-cr4
+        ch(2,m2,k,5,1) = ci2-cr5
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ti5 = cc(2,m1,k,i,2)-cc(2,m1,k,i,5)
+          ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,5)
+          ti4 = cc(2,m1,k,i,3)-cc(2,m1,k,i,4)
+          ti3 = cc(2,m1,k,i,3)+cc(2,m1,k,i,4)
+          tr5 = cc(1,m1,k,i,2)-cc(1,m1,k,i,5)
+          tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,5)
+          tr4 = cc(1,m1,k,i,3)-cc(1,m1,k,i,4)
+          tr3 = cc(1,m1,k,i,3)+cc(1,m1,k,i,4)
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2+tr3
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2+ti3
+          cr2 = cc(1,m1,k,i,1)+tr11*tr2+tr12*tr3
+          ci2 = cc(2,m1,k,i,1)+tr11*ti2+tr12*ti3
+          cr3 = cc(1,m1,k,i,1)+tr12*tr2+tr11*tr3
+          ci3 = cc(2,m1,k,i,1)+tr12*ti2+tr11*ti3
+          cr5 = ti11*tr5+ti12*tr4
+          ci5 = ti11*ti5+ti12*ti4
+          cr4 = ti12*tr5-ti11*tr4
+          ci4 = ti12*ti5-ti11*ti4
+          dr3 = cr3-ci4
+          dr4 = cr3+ci4
+          di3 = ci3+cr4
+          di4 = ci3-cr4
+          dr5 = cr2+ci5
+          dr2 = cr2-ci5
+          di5 = ci2-cr5
+          di2 = ci2+cr5
+          ch(1,m2,k,2,i) = wa(i,1,1) * dr2 - wa(i,1,2) * di2
+          ch(2,m2,k,2,i) = wa(i,1,1) * di2 + wa(i,1,2) * dr2
+          ch(1,m2,k,3,i) = wa(i,2,1) * dr3 - wa(i,2,2) * di3
+          ch(2,m2,k,3,i) = wa(i,2,1) * di3 + wa(i,2,2) * dr3
+          ch(1,m2,k,4,i) = wa(i,3,1) * dr4 - wa(i,3,2) * di4
+          ch(2,m2,k,4,i) = wa(i,3,1) * di4 + wa(i,3,2) * dr4
+          ch(1,m2,k,5,i) = wa(i,4,1) * dr5 - wa(i,4,2) * di5
+          ch(2,m2,k,5,i) = wa(i,4,1) * di5 + wa(i,4,2) * dr5
+        end do
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+        ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
+        ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
+        tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
+        tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
+
+        chold1 = cc(1,m1,k,1,1) + tr2 + tr3
+        chold2 = cc(2,m1,k,1,1) + ti2 + ti3
+
+        cr2 = cc(1,m1,k,1,1) + tr11 * tr2 + tr12 * tr3
+        ci2 = cc(2,m1,k,1,1) + tr11 * ti2 + tr12 * ti3
+        cr3 = cc(1,m1,k,1,1) + tr12 * tr2 + tr11 * tr3
+        ci3 = cc(2,m1,k,1,1) + tr12 * ti2 + tr11 * ti3
+
+        cc(1,m1,k,1,1) = chold1
+        cc(2,m1,k,1,1) = chold2
+
+        cr5 = ti11*tr5 + ti12*tr4
+        ci5 = ti11*ti5 + ti12*ti4
+        cr4 = ti12*tr5 - ti11*tr4
+        ci4 = ti12*ti5 - ti11*ti4
+        cc(1,m1,k,1,2) = cr2-ci5
+        cc(1,m1,k,1,5) = cr2+ci5
+        cc(2,m1,k,1,2) = ci2+cr5
+        cc(2,m1,k,1,3) = ci3+cr4
+        cc(1,m1,k,1,3) = cr3-ci4
+        cc(1,m1,k,1,4) = cr3+ci4
+        cc(2,m1,k,1,4) = ci3-cr4
+        cc(2,m1,k,1,5) = ci2-cr5
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmf5kf.F b/wrfv2_fire/external/fftpack/fftpack5/cmf5kf.F
index a90e676a..7ac01962 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmf5kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmf5kf.F
@@ -1,166 +1,253 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                      C
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!      File:           cmf5kf.f                                         
-!                                                                       
-!      Library:        FFTPACK 5.0                                      
-!                                                                       
-!      Authors:        Paul N. Swarztrauber and Richard A. Valent       
-!                      National Center for Atmospheric Research         
-!                      PO 3000, Boulder, Colorado                       
-!                                                                       
-!      Date:           Wed Mar 29 18:31:13 MST 1995                     
-!                                                                       
-!      Description:    Lower-level auxiliary routine                    
-!                                                                       
-      SUBROUTINE CMF5KF (LOT,IDO,L1,NA,CC,IM1,IN1,CH,IM2,IN2,WA) 
-      REAL  CC(2,IN1,L1,IDO,5),CH(2,IN2,L1,5,IDO),WA(IDO,4,2) 
-      DATA TR11,TI11,TR12,TI12 /.3090169943749474,-.9510565162951536,   &
-     &-.8090169943749474,-.5877852522924731/                            
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      M1D = (LOT-1)*IM1+1 
-      M2S = 1-IM2 
-      IF (IDO .GT. 1) GO TO 102 
-      SN = 1./REAL(5*L1) 
-      IF (NA .EQ. 1) GO TO 106 
-      DO 101 K=1,L1 
-         DO 101 M1=1,M1D,IM1 
-         TI5 = CC(2,M1,K,1,2)-CC(2,M1,K,1,5) 
-         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,5) 
-         TI4 = CC(2,M1,K,1,3)-CC(2,M1,K,1,4) 
-         TI3 = CC(2,M1,K,1,3)+CC(2,M1,K,1,4) 
-         TR5 = CC(1,M1,K,1,2)-CC(1,M1,K,1,5) 
-         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,5) 
-         TR4 = CC(1,M1,K,1,3)-CC(1,M1,K,1,4) 
-         TR3 = CC(1,M1,K,1,3)+CC(1,M1,K,1,4) 
-         CHOLD1 = SN*(CC(1,M1,K,1,1)+TR2+TR3) 
-         CHOLD2 = SN*(CC(2,M1,K,1,1)+TI2+TI3) 
-         CR2 = CC(1,M1,K,1,1)+TR11*TR2+TR12*TR3 
-         CI2 = CC(2,M1,K,1,1)+TR11*TI2+TR12*TI3 
-         CR3 = CC(1,M1,K,1,1)+TR12*TR2+TR11*TR3 
-         CI3 = CC(2,M1,K,1,1)+TR12*TI2+TR11*TI3 
-         CC(1,M1,K,1,1) = CHOLD1 
-         CC(2,M1,K,1,1) = CHOLD2 
-         CR5 = TI11*TR5+TI12*TR4 
-         CI5 = TI11*TI5+TI12*TI4 
-         CR4 = TI12*TR5-TI11*TR4 
-         CI4 = TI12*TI5-TI11*TI4 
-         CC(1,M1,K,1,2) = SN*(CR2-CI5) 
-         CC(1,M1,K,1,5) = SN*(CR2+CI5) 
-         CC(2,M1,K,1,2) = SN*(CI2+CR5) 
-         CC(2,M1,K,1,3) = SN*(CI3+CR4) 
-         CC(1,M1,K,1,3) = SN*(CR3-CI4) 
-         CC(1,M1,K,1,4) = SN*(CR3+CI4) 
-         CC(2,M1,K,1,4) = SN*(CI3-CR4) 
-         CC(2,M1,K,1,5) = SN*(CI2-CR5) 
-  101 CONTINUE 
-      RETURN 
-  106 DO 107 K=1,L1 
-         M2 = M2S 
-         DO 107 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         TI5 = CC(2,M1,K,1,2)-CC(2,M1,K,1,5) 
-         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,5) 
-         TI4 = CC(2,M1,K,1,3)-CC(2,M1,K,1,4) 
-         TI3 = CC(2,M1,K,1,3)+CC(2,M1,K,1,4) 
-         TR5 = CC(1,M1,K,1,2)-CC(1,M1,K,1,5) 
-         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,5) 
-         TR4 = CC(1,M1,K,1,3)-CC(1,M1,K,1,4) 
-         TR3 = CC(1,M1,K,1,3)+CC(1,M1,K,1,4) 
-         CH(1,M2,K,1,1) = SN*(CC(1,M1,K,1,1)+TR2+TR3) 
-         CH(2,M2,K,1,1) = SN*(CC(2,M1,K,1,1)+TI2+TI3) 
-         CR2 = CC(1,M1,K,1,1)+TR11*TR2+TR12*TR3 
-         CI2 = CC(2,M1,K,1,1)+TR11*TI2+TR12*TI3 
-         CR3 = CC(1,M1,K,1,1)+TR12*TR2+TR11*TR3 
-         CI3 = CC(2,M1,K,1,1)+TR12*TI2+TR11*TI3 
-         CR5 = TI11*TR5+TI12*TR4 
-         CI5 = TI11*TI5+TI12*TI4 
-         CR4 = TI12*TR5-TI11*TR4 
-         CI4 = TI12*TI5-TI11*TI4 
-         CH(1,M2,K,2,1) = SN*(CR2-CI5) 
-         CH(1,M2,K,5,1) = SN*(CR2+CI5) 
-         CH(2,M2,K,2,1) = SN*(CI2+CR5) 
-         CH(2,M2,K,3,1) = SN*(CI3+CR4) 
-         CH(1,M2,K,3,1) = SN*(CR3-CI4) 
-         CH(1,M2,K,4,1) = SN*(CR3+CI4) 
-         CH(2,M2,K,4,1) = SN*(CI3-CR4) 
-         CH(2,M2,K,5,1) = SN*(CI2-CR5) 
-  107 CONTINUE 
-      RETURN 
-  102 DO 103 K=1,L1 
-         M2 = M2S 
-         DO 103 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         TI5 = CC(2,M1,K,1,2)-CC(2,M1,K,1,5) 
-         TI2 = CC(2,M1,K,1,2)+CC(2,M1,K,1,5) 
-         TI4 = CC(2,M1,K,1,3)-CC(2,M1,K,1,4) 
-         TI3 = CC(2,M1,K,1,3)+CC(2,M1,K,1,4) 
-         TR5 = CC(1,M1,K,1,2)-CC(1,M1,K,1,5) 
-         TR2 = CC(1,M1,K,1,2)+CC(1,M1,K,1,5) 
-         TR4 = CC(1,M1,K,1,3)-CC(1,M1,K,1,4) 
-         TR3 = CC(1,M1,K,1,3)+CC(1,M1,K,1,4) 
-         CH(1,M2,K,1,1) = CC(1,M1,K,1,1)+TR2+TR3 
-         CH(2,M2,K,1,1) = CC(2,M1,K,1,1)+TI2+TI3 
-         CR2 = CC(1,M1,K,1,1)+TR11*TR2+TR12*TR3 
-         CI2 = CC(2,M1,K,1,1)+TR11*TI2+TR12*TI3 
-         CR3 = CC(1,M1,K,1,1)+TR12*TR2+TR11*TR3 
-         CI3 = CC(2,M1,K,1,1)+TR12*TI2+TR11*TI3 
-         CR5 = TI11*TR5+TI12*TR4 
-         CI5 = TI11*TI5+TI12*TI4 
-         CR4 = TI12*TR5-TI11*TR4 
-         CI4 = TI12*TI5-TI11*TI4 
-         CH(1,M2,K,2,1) = CR2-CI5 
-         CH(1,M2,K,5,1) = CR2+CI5 
-         CH(2,M2,K,2,1) = CI2+CR5 
-         CH(2,M2,K,3,1) = CI3+CR4 
-         CH(1,M2,K,3,1) = CR3-CI4 
-         CH(1,M2,K,4,1) = CR3+CI4 
-         CH(2,M2,K,4,1) = CI3-CR4 
-         CH(2,M2,K,5,1) = CI2-CR5 
-  103 CONTINUE 
-      DO 105 I=2,IDO 
-         DO 104 K=1,L1 
-         M2 = M2S 
-         DO 104 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            TI5 = CC(2,M1,K,I,2)-CC(2,M1,K,I,5) 
-            TI2 = CC(2,M1,K,I,2)+CC(2,M1,K,I,5) 
-            TI4 = CC(2,M1,K,I,3)-CC(2,M1,K,I,4) 
-            TI3 = CC(2,M1,K,I,3)+CC(2,M1,K,I,4) 
-            TR5 = CC(1,M1,K,I,2)-CC(1,M1,K,I,5) 
-            TR2 = CC(1,M1,K,I,2)+CC(1,M1,K,I,5) 
-            TR4 = CC(1,M1,K,I,3)-CC(1,M1,K,I,4) 
-            TR3 = CC(1,M1,K,I,3)+CC(1,M1,K,I,4) 
-            CH(1,M2,K,1,I) = CC(1,M1,K,I,1)+TR2+TR3 
-            CH(2,M2,K,1,I) = CC(2,M1,K,I,1)+TI2+TI3 
-            CR2 = CC(1,M1,K,I,1)+TR11*TR2+TR12*TR3 
-            CI2 = CC(2,M1,K,I,1)+TR11*TI2+TR12*TI3 
-            CR3 = CC(1,M1,K,I,1)+TR12*TR2+TR11*TR3 
-            CI3 = CC(2,M1,K,I,1)+TR12*TI2+TR11*TI3 
-            CR5 = TI11*TR5+TI12*TR4 
-            CI5 = TI11*TI5+TI12*TI4 
-            CR4 = TI12*TR5-TI11*TR4 
-            CI4 = TI12*TI5-TI11*TI4 
-            DR3 = CR3-CI4 
-            DR4 = CR3+CI4 
-            DI3 = CI3+CR4 
-            DI4 = CI3-CR4 
-            DR5 = CR2+CI5 
-            DR2 = CR2-CI5 
-            DI5 = CI2-CR5 
-            DI2 = CI2+CR5 
-            CH(1,M2,K,2,I) = WA(I,1,1)*DR2+WA(I,1,2)*DI2 
-            CH(2,M2,K,2,I) = WA(I,1,1)*DI2-WA(I,1,2)*DR2 
-            CH(1,M2,K,3,I) = WA(I,2,1)*DR3+WA(I,2,2)*DI3 
-            CH(2,M2,K,3,I) = WA(I,2,1)*DI3-WA(I,2,2)*DR3 
-            CH(1,M2,K,4,I) = WA(I,3,1)*DR4+WA(I,3,2)*DI4 
-            CH(2,M2,K,4,I) = WA(I,3,1)*DI4-WA(I,3,2)*DR4 
-            CH(1,M2,K,5,I) = WA(I,4,1)*DR5+WA(I,4,2)*DI5 
-            CH(2,M2,K,5,I) = WA(I,4,1)*DI5-WA(I,4,2)*DR5 
-  104    CONTINUE 
-  105 END DO 
-      RETURN 
-      END                                           
+subroutine cmf5kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! CMF5KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(2,in1,l1,ido,5)
+  real ( kind = 4 ) ch(2,in2,l1,5,ido)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  real ( kind = 4 ) ci2
+  real ( kind = 4 ) ci3
+  real ( kind = 4 ) ci4
+  real ( kind = 4 ) ci5
+  real ( kind = 4 ) cr2
+  real ( kind = 4 ) cr3
+  real ( kind = 4 ) cr4
+  real ( kind = 4 ) cr5
+  real ( kind = 4 ) di2
+  real ( kind = 4 ) di3
+  real ( kind = 4 ) di4
+  real ( kind = 4 ) di5
+  real ( kind = 4 ) dr2
+  real ( kind = 4 ) dr3
+  real ( kind = 4 ) dr4
+  real ( kind = 4 ) dr5
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) sn
+  real ( kind = 4 ) ti2
+  real ( kind = 4 ) ti3
+  real ( kind = 4 ) ti4
+  real ( kind = 4 ) ti5
+  real ( kind = 4 ), parameter :: ti11 = -0.9510565162951536E+00
+  real ( kind = 4 ), parameter :: ti12 = -0.5877852522924731E+00
+  real ( kind = 4 ) tr2
+  real ( kind = 4 ) tr3
+  real ( kind = 4 ) tr4
+  real ( kind = 4 ) tr5
+  real ( kind = 4 ), parameter :: tr11 =  0.3090169943749474E+00
+  real ( kind = 4 ), parameter :: tr12 = -0.8090169943749474E+00
+  real ( kind = 4 ) wa(ido,4,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
+        ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
+        tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
+        tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2+tr3
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2+ti3
+        cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
+        ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
+        cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
+        ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
+        cr5 = ti11*tr5+ti12*tr4
+        ci5 = ti11*ti5+ti12*ti4
+        cr4 = ti12*tr5-ti11*tr4
+        ci4 = ti12*ti5-ti11*ti4
+        ch(1,m2,k,2,1) = cr2-ci5
+        ch(1,m2,k,5,1) = cr2+ci5
+        ch(2,m2,k,2,1) = ci2+cr5
+        ch(2,m2,k,3,1) = ci3+cr4
+        ch(1,m2,k,3,1) = cr3-ci4
+        ch(1,m2,k,4,1) = cr3+ci4
+        ch(2,m2,k,4,1) = ci3-cr4
+        ch(2,m2,k,5,1) = ci2-cr5
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ti5 = cc(2,m1,k,i,2)-cc(2,m1,k,i,5)
+          ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,5)
+          ti4 = cc(2,m1,k,i,3)-cc(2,m1,k,i,4)
+          ti3 = cc(2,m1,k,i,3)+cc(2,m1,k,i,4)
+          tr5 = cc(1,m1,k,i,2)-cc(1,m1,k,i,5)
+          tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,5)
+          tr4 = cc(1,m1,k,i,3)-cc(1,m1,k,i,4)
+          tr3 = cc(1,m1,k,i,3)+cc(1,m1,k,i,4)
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2+tr3
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2+ti3
+          cr2 = cc(1,m1,k,i,1)+tr11*tr2+tr12*tr3
+          ci2 = cc(2,m1,k,i,1)+tr11*ti2+tr12*ti3
+          cr3 = cc(1,m1,k,i,1)+tr12*tr2+tr11*tr3
+          ci3 = cc(2,m1,k,i,1)+tr12*ti2+tr11*ti3
+          cr5 = ti11*tr5+ti12*tr4
+          ci5 = ti11*ti5+ti12*ti4
+          cr4 = ti12*tr5-ti11*tr4
+          ci4 = ti12*ti5-ti11*ti4
+          dr3 = cr3-ci4
+          dr4 = cr3+ci4
+          di3 = ci3+cr4
+          di4 = ci3-cr4
+          dr5 = cr2+ci5
+          dr2 = cr2-ci5
+          di5 = ci2-cr5
+          di2 = ci2+cr5
+          ch(1,m2,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2
+          ch(2,m2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2
+          ch(1,m2,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3
+          ch(2,m2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3
+          ch(1,m2,k,4,i) = wa(i,3,1)*dr4+wa(i,3,2)*di4
+          ch(2,m2,k,4,i) = wa(i,3,1)*di4-wa(i,3,2)*dr4
+          ch(1,m2,k,5,i) = wa(i,4,1)*dr5+wa(i,4,2)*di5
+          ch(2,m2,k,5,i) = wa(i,4,1)*di5-wa(i,4,2)*dr5
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0E+00 / real ( 5 * l1, kind = 4 )
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
+        ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
+        tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
+        tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2+tr3)
+        ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2+ti3)
+        cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
+        ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
+        cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
+        ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
+        cr5 = ti11*tr5+ti12*tr4
+        ci5 = ti11*ti5+ti12*ti4
+        cr4 = ti12*tr5-ti11*tr4
+        ci4 = ti12*ti5-ti11*ti4
+        ch(1,m2,k,2,1) = sn*(cr2-ci5)
+        ch(1,m2,k,5,1) = sn*(cr2+ci5)
+        ch(2,m2,k,2,1) = sn*(ci2+cr5)
+        ch(2,m2,k,3,1) = sn*(ci3+cr4)
+        ch(1,m2,k,3,1) = sn*(cr3-ci4)
+        ch(1,m2,k,4,1) = sn*(cr3+ci4)
+        ch(2,m2,k,4,1) = sn*(ci3-cr4)
+        ch(2,m2,k,5,1) = sn*(ci2-cr5)
+      end do
+    end do
+
+  else
+
+    sn = 1.0E+00 / real ( 5 * l1, kind = 4 )
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+
+        ti5 = cc(2,m1,k,1,2) - cc(2,m1,k,1,5)
+        ti2 = cc(2,m1,k,1,2) + cc(2,m1,k,1,5)
+        ti4 = cc(2,m1,k,1,3) - cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,3) + cc(2,m1,k,1,4)
+        tr5 = cc(1,m1,k,1,2) - cc(1,m1,k,1,5)
+        tr2 = cc(1,m1,k,1,2) + cc(1,m1,k,1,5)
+        tr4 = cc(1,m1,k,1,3) - cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,3) + cc(1,m1,k,1,4)
+
+        chold1 = sn * ( cc(1,m1,k,1,1) + tr2 + tr3 )
+        chold2 = sn * ( cc(2,m1,k,1,1) + ti2 + ti3 )
+
+        cr2 = cc(1,m1,k,1,1) + tr11 * tr2 + tr12 * tr3
+        ci2 = cc(2,m1,k,1,1) + tr11 * ti2 + tr12 * ti3
+        cr3 = cc(1,m1,k,1,1) + tr12 * tr2 + tr11 * tr3
+        ci3 = cc(2,m1,k,1,1) + tr12 * ti2 + tr11 * ti3
+
+        cc(1,m1,k,1,1) = chold1
+        cc(2,m1,k,1,1) = chold2
+
+        cr5 = ti11 * tr5 + ti12 * tr4
+        ci5 = ti11 * ti5 + ti12 * ti4
+        cr4 = ti12 * tr5 - ti11 * tr4
+        ci4 = ti12 * ti5 - ti11 * ti4
+
+        cc(1,m1,k,1,2) = sn * ( cr2 - ci5 )
+        cc(1,m1,k,1,5) = sn * ( cr2 + ci5 )
+        cc(2,m1,k,1,2) = sn * ( ci2 + cr5 )
+        cc(2,m1,k,1,3) = sn * ( ci3 + cr4 )
+        cc(1,m1,k,1,3) = sn * ( cr3 - ci4 )
+        cc(1,m1,k,1,4) = sn * ( cr3 + ci4 )
+        cc(2,m1,k,1,4) = sn * ( ci3 - cr4 )
+        cc(2,m1,k,1,5) = sn * ( ci2 - cr5 )
+
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmfgkb.F b/wrfv2_fire/external/fftpack/fftpack5/cmfgkb.F
index b87ebe17..1fa75593 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmfgkb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmfgkb.F
@@ -1,144 +1,236 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cmfgkb.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CMFGKB (LOT,IDO,IP,L1,LID,NA,CC,CC1,IM1,IN1,           &
-     &                                      CH,CH1,IM2,IN2,WA)          
-      REAL       CH(2,IN2,L1,IDO,IP) ,CC(2,IN1,L1,IP,IDO),              &
-     &                CC1(2,IN1,LID,IP)    ,CH1(2,IN2,LID,IP)  ,        &
-     &                WA(IDO,IP-1,2)                                    
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      M1D = (LOT-1)*IM1+1 
-      M2S = 1-IM2 
-      IPP2 = IP+2 
-      IPPH = (IP+1)/2 
-      DO 110 KI=1,LID 
-         M2 = M2S 
-         DO 110 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH1(1,M2,KI,1) = CC1(1,M1,KI,1) 
-         CH1(2,M2,KI,1) = CC1(2,M1,KI,1) 
-  110 CONTINUE 
-      DO 111 J=2,IPPH 
-         JC = IPP2-J 
-         DO 112 KI=1,LID 
-         M2 = M2S 
-         DO 112 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CH1(1,M2,KI,J) =  CC1(1,M1,KI,J)+CC1(1,M1,KI,JC) 
-            CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)-CC1(1,M1,KI,JC) 
-            CH1(2,M2,KI,J) =  CC1(2,M1,KI,J)+CC1(2,M1,KI,JC) 
-            CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(2,M1,KI,JC) 
-  112    CONTINUE 
-  111 END DO 
-      DO 118 J=2,IPPH 
-         DO 117 KI=1,LID 
-         M2 = M2S 
-         DO 117 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CC1(1,M1,KI,1) = CC1(1,M1,KI,1)+CH1(1,M2,KI,J) 
-            CC1(2,M1,KI,1) = CC1(2,M1,KI,1)+CH1(2,M2,KI,J) 
-  117    CONTINUE 
-  118 END DO 
-      DO 116 L=2,IPPH 
-         LC = IPP2-L 
-         DO 113 KI=1,LID 
-         M2 = M2S 
-         DO 113 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CC1(1,M1,KI,L) = CH1(1,M2,KI,1)+WA(1,L-1,1)*CH1(1,M2,KI,2) 
-            CC1(1,M1,KI,LC) = WA(1,L-1,2)*CH1(1,M2,KI,IP) 
-            CC1(2,M1,KI,L) = CH1(2,M2,KI,1)+WA(1,L-1,1)*CH1(2,M2,KI,2) 
-            CC1(2,M1,KI,LC) = WA(1,L-1,2)*CH1(2,M2,KI,IP) 
-  113    CONTINUE 
-         DO 115 J=3,IPPH 
-            JC = IPP2-J 
-            IDLJ = MOD((L-1)*(J-1),IP) 
-            WAR = WA(1,IDLJ,1) 
-            WAI = WA(1,IDLJ,2) 
-            DO 114 KI=1,LID 
-               M2 = M2S 
-               DO 114 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CC1(1,M1,KI,L) = CC1(1,M1,KI,L)+WAR*CH1(1,M2,KI,J) 
-               CC1(1,M1,KI,LC) = CC1(1,M1,KI,LC)+WAI*CH1(1,M2,KI,JC) 
-               CC1(2,M1,KI,L) = CC1(2,M1,KI,L)+WAR*CH1(2,M2,KI,J) 
-               CC1(2,M1,KI,LC) = CC1(2,M1,KI,LC)+WAI*CH1(2,M2,KI,JC) 
-  114       CONTINUE 
-  115    CONTINUE 
-  116 END DO 
-      IF(IDO.GT.1 .OR. NA.EQ.1) GO TO 136 
-      DO 120 J=2,IPPH 
-         JC = IPP2-J 
-         DO 119 KI=1,LID 
-         DO 119 M1=1,M1D,IM1 
-            CHOLD1 = CC1(1,M1,KI,J)-CC1(2,M1,KI,JC) 
-            CHOLD2 = CC1(1,M1,KI,J)+CC1(2,M1,KI,JC) 
-            CC1(1,M1,KI,J) = CHOLD1 
-            CC1(2,M1,KI,JC) = CC1(2,M1,KI,J)-CC1(1,M1,KI,JC) 
-            CC1(2,M1,KI,J) = CC1(2,M1,KI,J)+CC1(1,M1,KI,JC) 
-            CC1(1,M1,KI,JC) = CHOLD2 
-  119    CONTINUE 
-  120 END DO 
-      RETURN 
-  136 DO 137 KI=1,LID 
-         M2 = M2S 
-         DO 137 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH1(1,M2,KI,1) = CC1(1,M1,KI,1) 
-         CH1(2,M2,KI,1) = CC1(2,M1,KI,1) 
-  137 CONTINUE 
-      DO 135 J=2,IPPH 
-         JC = IPP2-J 
-         DO 134 KI=1,LID 
-         M2 = M2S 
-         DO 134 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CH1(1,M2,KI,J) = CC1(1,M1,KI,J)-CC1(2,M1,KI,JC) 
-            CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)+CC1(2,M1,KI,JC) 
-            CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(1,M1,KI,JC) 
-            CH1(2,M2,KI,J) = CC1(2,M1,KI,J)+CC1(1,M1,KI,JC) 
-  134    CONTINUE 
-  135 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      DO 131 I=1,IDO 
-         DO 130 K=1,L1 
-         M2 = M2S 
-         DO 130 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CC(1,M1,K,1,I) = CH(1,M2,K,I,1) 
-            CC(2,M1,K,1,I) = CH(2,M2,K,I,1) 
-  130    CONTINUE 
-  131 END DO 
-      DO 123 J=2,IP 
-         DO 122 K=1,L1 
-         M2 = M2S 
-         DO 122 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CC(1,M1,K,J,1) = CH(1,M2,K,1,J) 
-            CC(2,M1,K,J,1) = CH(2,M2,K,1,J) 
-  122    CONTINUE 
-  123 END DO 
-      DO 126 J=2,IP 
-         DO 125 I=2,IDO 
-            DO 124 K=1,L1 
-               M2 = M2S 
-               DO 124 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CC(1,M1,K,J,I) = WA(I,J-1,1)*CH(1,M2,K,I,J)              &
-     &                      -WA(I,J-1,2)*CH(2,M2,K,I,J)                 
-               CC(2,M1,K,J,I) = WA(I,J-1,1)*CH(2,M2,K,I,J)              &
-     &                      +WA(I,J-1,2)*CH(1,M2,K,I,J)                 
-  124       CONTINUE 
-  125    CONTINUE 
-  126 END DO 
-      RETURN 
-      END                                           
+subroutine cmfgkb ( lot, ido, ip, l1, lid, na, cc, cc1, im1, in1, &
+  ch, ch1, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! CMFGKB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) lid
+
+  real ( kind = 4 ) cc(2,in1,l1,ip,ido)
+  real ( kind = 4 ) cc1(2,in1,lid,ip)
+  real ( kind = 4 ) ch(2,in2,l1,ido,ip)
+  real ( kind = 4 ) ch1(2,in2,lid,ip)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) idlj
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) ki
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) wa(ido,ip-1,2)
+  real ( kind = 4 ) wai
+  real ( kind = 4 ) war
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+  ipp2 = ip + 2
+  ipph = ( ip + 1 ) / 2
+
+  do ki = 1, lid
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
+      ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
+    end do
+  end do
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch1(1,m2,ki,j) =  cc1(1,m1,ki,j) + cc1(1,m1,ki,jc)
+        ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) - cc1(1,m1,ki,jc)
+        ch1(2,m2,ki,j) =  cc1(2,m1,ki,j) + cc1(2,m1,ki,jc)
+        ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(2,m1,ki,jc)
+      end do
+    end do
+  end do
+
+  do j = 2, ipph
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        cc1(1,m1,ki,1) = cc1(1,m1,ki,1) + ch1(1,m2,ki,j)
+        cc1(2,m1,ki,1) = cc1(2,m1,ki,1) + ch1(2,m2,ki,j)
+      end do
+    end do
+  end do
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+
+        cc1(1,m1,ki,l)  = ch1(1,m2,ki,1) + wa(1,l-1,1) * ch1(1,m2,ki,2)
+        cc1(1,m1,ki,lc) =                  wa(1,l-1,2) * ch1(1,m2,ki,ip)
+        cc1(2,m1,ki,l)  = ch1(2,m2,ki,1) + wa(1,l-1,1) * ch1(2,m2,ki,2)
+        cc1(2,m1,ki,lc) =                  wa(1,l-1,2) * ch1(2,m2,ki,ip)
+
+      end do
+    end do
+
+    do j = 3, ipph
+      jc = ipp2 - j
+      idlj = mod ( ( l - 1 ) * ( j - 1 ), ip )
+      war = wa(1,idlj,1)
+      wai = wa(1,idlj,2)
+      do ki = 1, lid
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc1(1,m1,ki,l)  = cc1(1,m1,ki,l)  + war * ch1(1,m2,ki,j)
+          cc1(1,m1,ki,lc) = cc1(1,m1,ki,lc) + wai * ch1(1,m2,ki,jc)
+          cc1(2,m1,ki,l)  = cc1(2,m1,ki,l)  + war * ch1(2,m2,ki,j)
+          cc1(2,m1,ki,lc) = cc1(2,m1,ki,lc) + wai * ch1(2,m2,ki,jc)
+        end do
+      end do
+    end do
+
+  end do
+
+  if( 1 < ido .or. na == 1 ) then
+
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
+        ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
+      end do
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch1(1,m2,ki,j)  = cc1(1,m1,ki,j) - cc1(2,m1,ki,jc)
+          ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) + cc1(2,m1,ki,jc)
+          ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(1,m1,ki,jc)
+          ch1(2,m2,ki,j)  = cc1(2,m1,ki,j) + cc1(1,m1,ki,jc)
+        end do
+      end do
+    end do
+
+    if ( ido == 1 ) then
+      return
+    end if
+
+    do i = 1, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc(1,m1,k,1,i) = ch(1,m2,k,i,1)
+          cc(2,m1,k,1,i) = ch(2,m2,k,i,1)
+        end do
+      end do
+    end do
+
+    do j = 2, ip
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc(1,m1,k,j,1) = ch(1,m2,k,1,j)
+          cc(2,m1,k,j,1) = ch(2,m2,k,1,j)
+        end do
+      end do
+    end do
+
+    do j = 2, ip
+      do i = 2, ido
+        do k = 1, l1
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            cc(1,m1,k,j,i) = wa(i,j-1,1) * ch(1,m2,k,i,j) &
+                           - wa(i,j-1,2) * ch(2,m2,k,i,j)
+            cc(2,m1,k,j,i) = wa(i,j-1,1) * ch(2,m2,k,i,j) &
+                           + wa(i,j-1,2) * ch(1,m2,k,i,j)
+          end do
+        end do
+      end do
+    end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        do m1 = 1, m1d, im1
+
+          chold1         = cc1(1,m1,ki,j) - cc1(2,m1,ki,jc)
+          chold2         = cc1(1,m1,ki,j) + cc1(2,m1,ki,jc)
+          cc1(1,m1,ki,j) = chold1
+
+          cc1(2,m1,ki,jc) = cc1(2,m1,ki,j) - cc1(1,m1,ki,jc)
+          cc1(2,m1,ki,j)  = cc1(2,m1,ki,j) + cc1(1,m1,ki,jc)
+          cc1(1,m1,ki,jc) = chold2
+
+        end do
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmfgkf.F b/wrfv2_fire/external/fftpack/fftpack5/cmfgkf.F
index bc7cfe75..a2ebaf64 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmfgkf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmfgkf.F
@@ -1,172 +1,267 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cmfgkf.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CMFGKF (LOT,IDO,IP,L1,LID,NA,CC,CC1,IM1,IN1,           &
-     &                                      CH,CH1,IM2,IN2,WA)          
-      REAL       CH(2,IN2,L1,IDO,IP) ,CC(2,IN1,L1,IP,IDO),              &
-     &                CC1(2,IN1,LID,IP)    ,CH1(2,IN2,LID,IP)  ,        &
-     &                WA(IDO,IP-1,2)                                    
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      M1D = (LOT-1)*IM1+1 
-      M2S = 1-IM2 
-      IPP2 = IP+2 
-      IPPH = (IP+1)/2 
-      DO 110 KI=1,LID 
-         M2 = M2S 
-         DO 110 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH1(1,M2,KI,1) = CC1(1,M1,KI,1) 
-         CH1(2,M2,KI,1) = CC1(2,M1,KI,1) 
-  110 CONTINUE 
-      DO 111 J=2,IPPH 
-         JC = IPP2-J 
-         DO 112 KI=1,LID 
-         M2 = M2S 
-         DO 112 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CH1(1,M2,KI,J) =  CC1(1,M1,KI,J)+CC1(1,M1,KI,JC) 
-            CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)-CC1(1,M1,KI,JC) 
-            CH1(2,M2,KI,J) =  CC1(2,M1,KI,J)+CC1(2,M1,KI,JC) 
-            CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(2,M1,KI,JC) 
-  112    CONTINUE 
-  111 END DO 
-      DO 118 J=2,IPPH 
-         DO 117 KI=1,LID 
-         M2 = M2S 
-         DO 117 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CC1(1,M1,KI,1) = CC1(1,M1,KI,1)+CH1(1,M2,KI,J) 
-            CC1(2,M1,KI,1) = CC1(2,M1,KI,1)+CH1(2,M2,KI,J) 
-  117    CONTINUE 
-  118 END DO 
-      DO 116 L=2,IPPH 
-         LC = IPP2-L 
-         DO 113 KI=1,LID 
-         M2 = M2S 
-         DO 113 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CC1(1,M1,KI,L) = CH1(1,M2,KI,1)+WA(1,L-1,1)*CH1(1,M2,KI,2) 
-            CC1(1,M1,KI,LC) = -WA(1,L-1,2)*CH1(1,M2,KI,IP) 
-            CC1(2,M1,KI,L) = CH1(2,M2,KI,1)+WA(1,L-1,1)*CH1(2,M2,KI,2) 
-            CC1(2,M1,KI,LC) = -WA(1,L-1,2)*CH1(2,M2,KI,IP) 
-  113    CONTINUE 
-         DO 115 J=3,IPPH 
-            JC = IPP2-J 
-            IDLJ = MOD((L-1)*(J-1),IP) 
-            WAR = WA(1,IDLJ,1) 
-            WAI = -WA(1,IDLJ,2) 
-            DO 114 KI=1,LID 
-               M2 = M2S 
-               DO 114 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CC1(1,M1,KI,L) = CC1(1,M1,KI,L)+WAR*CH1(1,M2,KI,J) 
-               CC1(1,M1,KI,LC) = CC1(1,M1,KI,LC)+WAI*CH1(1,M2,KI,JC) 
-               CC1(2,M1,KI,L) = CC1(2,M1,KI,L)+WAR*CH1(2,M2,KI,J) 
-               CC1(2,M1,KI,LC) = CC1(2,M1,KI,LC)+WAI*CH1(2,M2,KI,JC) 
-  114       CONTINUE 
-  115    CONTINUE 
-  116 END DO 
-      IF (IDO .GT. 1) GO TO 136 
-      SN = 1./REAL(IP*L1) 
-      IF (NA .EQ. 1) GO TO 146 
-      DO 149 KI=1,LID 
-         M2 = M2S 
-         DO 149 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CC1(1,M1,KI,1) = SN*CC1(1,M1,KI,1) 
-         CC1(2,M1,KI,1) = SN*CC1(2,M1,KI,1) 
-  149 CONTINUE 
-      DO 120 J=2,IPPH 
-         JC = IPP2-J 
-         DO 119 KI=1,LID 
-         DO 119 M1=1,M1D,IM1 
-            CHOLD1 = SN*(CC1(1,M1,KI,J)-CC1(2,M1,KI,JC)) 
-            CHOLD2 = SN*(CC1(1,M1,KI,J)+CC1(2,M1,KI,JC)) 
-            CC1(1,M1,KI,J) = CHOLD1 
-            CC1(2,M1,KI,JC) = SN*(CC1(2,M1,KI,J)-CC1(1,M1,KI,JC)) 
-            CC1(2,M1,KI,J) = SN*(CC1(2,M1,KI,J)+CC1(1,M1,KI,JC)) 
-            CC1(1,M1,KI,JC) = CHOLD2 
-  119    CONTINUE 
-  120 END DO 
-      RETURN 
-  146 DO 147 KI=1,LID 
-         M2 = M2S 
-         DO 147 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH1(1,M2,KI,1) = SN*CC1(1,M1,KI,1) 
-         CH1(2,M2,KI,1) = SN*CC1(2,M1,KI,1) 
-  147 CONTINUE 
-      DO 145 J=2,IPPH 
-         JC = IPP2-J 
-         DO 144 KI=1,LID 
-         M2 = M2S 
-         DO 144 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CH1(1,M2,KI,J) = SN*(CC1(1,M1,KI,J)-CC1(2,M1,KI,JC)) 
-            CH1(2,M2,KI,J) = SN*(CC1(2,M1,KI,J)+CC1(1,M1,KI,JC)) 
-            CH1(1,M2,KI,JC) = SN*(CC1(1,M1,KI,J)+CC1(2,M1,KI,JC)) 
-            CH1(2,M2,KI,JC) = SN*(CC1(2,M1,KI,J)-CC1(1,M1,KI,JC)) 
-  144    CONTINUE 
-  145 END DO 
-      RETURN 
-  136 DO 137 KI=1,LID 
-         M2 = M2S 
-         DO 137 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH1(1,M2,KI,1) = CC1(1,M1,KI,1) 
-         CH1(2,M2,KI,1) = CC1(2,M1,KI,1) 
-  137 CONTINUE 
-      DO 135 J=2,IPPH 
-         JC = IPP2-J 
-         DO 134 KI=1,LID 
-         M2 = M2S 
-         DO 134 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CH1(1,M2,KI,J) = CC1(1,M1,KI,J)-CC1(2,M1,KI,JC) 
-            CH1(2,M2,KI,J) = CC1(2,M1,KI,J)+CC1(1,M1,KI,JC) 
-            CH1(1,M2,KI,JC) = CC1(1,M1,KI,J)+CC1(2,M1,KI,JC) 
-            CH1(2,M2,KI,JC) = CC1(2,M1,KI,J)-CC1(1,M1,KI,JC) 
-  134    CONTINUE 
-  135 END DO 
-      DO 131 I=1,IDO 
-         DO 130 K=1,L1 
-         M2 = M2S 
-         DO 130 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CC(1,M1,K,1,I) = CH(1,M2,K,I,1) 
-            CC(2,M1,K,1,I) = CH(2,M2,K,I,1) 
-  130    CONTINUE 
-  131 END DO 
-      DO 123 J=2,IP 
-         DO 122 K=1,L1 
-         M2 = M2S 
-         DO 122 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-            CC(1,M1,K,J,1) = CH(1,M2,K,1,J) 
-            CC(2,M1,K,J,1) = CH(2,M2,K,1,J) 
-  122    CONTINUE 
-  123 END DO 
-      DO 126 J=2,IP 
-         DO 125 I=2,IDO 
-            DO 124 K=1,L1 
-               M2 = M2S 
-               DO 124 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CC(1,M1,K,J,I) = WA(I,J-1,1)*CH(1,M2,K,I,J)              &
-     &                      +WA(I,J-1,2)*CH(2,M2,K,I,J)                 
-               CC(2,M1,K,J,I) = WA(I,J-1,1)*CH(2,M2,K,I,J)              &
-     &                      -WA(I,J-1,2)*CH(1,M2,K,I,J)                 
-  124       CONTINUE 
-  125    CONTINUE 
-  126 END DO 
-      RETURN 
-      END                                           
+subroutine cmfgkf ( lot, ido, ip, l1, lid, na, cc, cc1, im1, in1, &
+  ch, ch1, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! CMFGKF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) lid
+
+  real ( kind = 4 ) cc(2,in1,l1,ip,ido)
+  real ( kind = 4 ) cc1(2,in1,lid,ip)
+  real ( kind = 4 ) ch(2,in2,l1,ido,ip)
+  real ( kind = 4 ) ch1(2,in2,lid,ip)
+  real ( kind = 4 ) chold1
+  real ( kind = 4 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) idlj
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) ki
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 4 ) sn
+  real ( kind = 4 ) wa(ido,ip-1,2)
+  real ( kind = 4 ) wai
+  real ( kind = 4 ) war
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+  ipp2 = ip + 2
+  ipph = ( ip + 1 ) / 2
+
+  do ki = 1, lid
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
+      ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
+    end do
+  end do
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch1(1,m2,ki,j) =  cc1(1,m1,ki,j) + cc1(1,m1,ki,jc)
+        ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) - cc1(1,m1,ki,jc)
+        ch1(2,m2,ki,j) =  cc1(2,m1,ki,j) + cc1(2,m1,ki,jc)
+        ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(2,m1,ki,jc)
+      end do
+    end do
+  end do
+
+  do j = 2, ipph
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        cc1(1,m1,ki,1) = cc1(1,m1,ki,1) + ch1(1,m2,ki,j)
+        cc1(2,m1,ki,1) = cc1(2,m1,ki,1) + ch1(2,m2,ki,j)
+      end do
+    end do
+  end do
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        cc1(1,m1,ki,l)  = ch1(1,m2,ki,1) + wa(1,l-1,1) * ch1(1,m2,ki,2)
+        cc1(1,m1,ki,lc) =                - wa(1,l-1,2) * ch1(1,m2,ki,ip)
+        cc1(2,m1,ki,l)  = ch1(2,m2,ki,1) + wa(1,l-1,1) * ch1(2,m2,ki,2)
+        cc1(2,m1,ki,lc) =                - wa(1,l-1,2) * ch1(2,m2,ki,ip)
+      end do
+    end do
+
+    do j = 3, ipph
+      jc = ipp2 - j
+      idlj = mod ( ( l - 1 ) * ( j - 1 ), ip )
+      war = wa(1,idlj,1)
+      wai = -wa(1,idlj,2)
+      do ki = 1, lid
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc1(1,m1,ki,l)  = cc1(1,m1,ki,l)  + war * ch1(1,m2,ki,j)
+          cc1(1,m1,ki,lc) = cc1(1,m1,ki,lc) + wai * ch1(1,m2,ki,jc)
+          cc1(2,m1,ki,l)  = cc1(2,m1,ki,l)  + war * ch1(2,m2,ki,j)
+          cc1(2,m1,ki,lc) = cc1(2,m1,ki,lc) + wai * ch1(2,m2,ki,jc)
+        end do
+      end do
+    end do
+
+  end do
+
+  if ( 1 < ido ) then
+
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
+        ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
+      end do
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch1(1,m2,ki,j)  = cc1(1,m1,ki,j) - cc1(2,m1,ki,jc)
+          ch1(2,m2,ki,j)  = cc1(2,m1,ki,j) + cc1(1,m1,ki,jc)
+          ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) + cc1(2,m1,ki,jc)
+          ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(1,m1,ki,jc)
+        end do
+      end do
+    end do
+
+    do i = 1, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc(1,m1,k,1,i) = ch(1,m2,k,i,1)
+          cc(2,m1,k,1,i) = ch(2,m2,k,i,1)
+        end do
+      end do
+    end do
+
+    do j = 2, ip
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc(1,m1,k,j,1) = ch(1,m2,k,1,j)
+          cc(2,m1,k,j,1) = ch(2,m2,k,1,j)
+        end do
+      end do
+    end do
+
+    do j = 2, ip
+      do i = 2, ido
+        do k = 1, l1
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            cc(1,m1,k,j,i) = wa(i,j-1,1) * ch(1,m2,k,i,j) &
+                           + wa(i,j-1,2) * ch(2,m2,k,i,j)
+            cc(2,m1,k,j,i) = wa(i,j-1,1) * ch(2,m2,k,i,j) &
+                           - wa(i,j-1,2) * ch(1,m2,k,i,j)
+          end do
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0E+00 / real ( ip * l1, kind = 4 )
+
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch1(1,m2,ki,1) = sn * cc1(1,m1,ki,1)
+        ch1(2,m2,ki,1) = sn * cc1(2,m1,ki,1)
+      end do
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch1(1,m2,ki,j)  = sn * ( cc1(1,m1,ki,j) - cc1(2,m1,ki,jc) )
+          ch1(2,m2,ki,j)  = sn * ( cc1(2,m1,ki,j) + cc1(1,m1,ki,jc) )
+          ch1(1,m2,ki,jc) = sn * ( cc1(1,m1,ki,j) + cc1(2,m1,ki,jc) )
+          ch1(2,m2,ki,jc) = sn * ( cc1(2,m1,ki,j) - cc1(1,m1,ki,jc) )
+        end do
+      end do
+    end do
+
+  else
+
+    sn = 1.0E+00 / real ( ip * l1, kind = 4 )
+
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        cc1(1,m1,ki,1) = sn * cc1(1,m1,ki,1)
+        cc1(2,m1,ki,1) = sn * cc1(2,m1,ki,1)
+      end do
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        do m1 = 1, m1d, im1
+          chold1 = sn * ( cc1(1,m1,ki,j) - cc1(2,m1,ki,jc) )
+          chold2 = sn * ( cc1(1,m1,ki,j) + cc1(2,m1,ki,jc) )
+          cc1(1,m1,ki,j) = chold1
+          cc1(2,m1,ki,jc) = sn * ( cc1(2,m1,ki,j) - cc1(1,m1,ki,jc) )
+          cc1(2,m1,ki,j)  = sn * ( cc1(2,m1,ki,j) + cc1(1,m1,ki,jc) )
+          cc1(1,m1,ki,jc) = chold2
+        end do
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmfm1b.F b/wrfv2_fire/external/fftpack/fftpack5/cmfm1b.F
index 2d8c17b1..584f0fd8 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmfm1b.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmfm1b.F
@@ -1,54 +1,105 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cmfm1b.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CMFM1B (LOT,JUMP,N,INC,C,CH,WA,FNF,FAC) 
-      COMPLEX       C(*) 
-      REAL       CH(*),     WA(*),     FAC(*) 
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      NF = FNF 
-      NA = 0 
-      L1 = 1 
-      IW = 1 
-      DO 125 K1=1,NF 
-         IP = FAC(K1) 
-         L2 = IP*L1 
-         IDO = N/L2 
-         LID = L1*IDO 
-         NBR = 1+NA+2*MIN(IP-2,4) 
-         GO TO (52,62,53,63,54,64,55,65,56,66),NBR 
-   52    CALL CMF2KB (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
-         GO TO 120 
-   62    CALL CMF2KB (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
-         GO TO 120 
-   53    CALL CMF3KB (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
-         GO TO 120 
-   63    CALL CMF3KB (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
-         GO TO 120 
-   54    CALL CMF4KB (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
-         GO TO 120 
-   64    CALL CMF4KB (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
-         GO TO 120 
-   55    CALL CMF5KB (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
-         GO TO 120 
-   65    CALL CMF5KB (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
-         GO TO 120 
-   56    CALL CMFGKB (LOT,IDO,IP,L1,LID,NA,C,C,JUMP,INC,CH,CH,1,        &
-     &     LOT,WA(IW))                                                  
-         GO TO 120 
-   66    CALL CMFGKB (LOT,IDO,IP,L1,LID,NA,CH,CH,1,LOT,C,C,             &
-     &     JUMP,INC,WA(IW))                                             
-  120    L1 = L2 
-         IW = IW+(IP-1)*(IDO+IDO) 
-         IF(IP .LE. 5) NA = 1-NA 
-  125 END DO 
-      RETURN 
-      END                                           
+subroutine cmfm1b ( lot, jump, n, inc, c, ch, wa, fnf, fac )
+
+!*****************************************************************************80
+!
+!! CMFM1B is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  complex ( kind = 4 ) c(*)
+  real ( kind = 4 ) ch(*)
+  real ( kind = 4 ) fac(*)
+  real ( kind = 4 ) fnf
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) lid
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nbr
+  integer ( kind = 4 ) nf
+  real ( kind = 4 ) wa(*)
+
+  nf = int ( fnf )
+  na = 0
+  l1 = 1
+  iw = 1
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1) )
+    l2 = ip * l1
+    ido = n / l2
+    lid = l1 * ido
+    nbr = 1 + na + 2 * min ( ip - 2, 4 )
+
+    if ( nbr == 1 ) then
+      call cmf2kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 2 ) then
+      call cmf2kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 3 ) then
+      call cmf3kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 4 ) then
+      call cmf3kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 5 ) then
+      call cmf4kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 6 ) then
+      call cmf4kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 7 ) then
+      call cmf5kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 8 ) then
+      call cmf5kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 9 ) then
+      call cmfgkb ( lot, ido, ip, l1, lid, na, c, c, jump, inc, ch, ch, &
+        1, lot, wa(iw) )
+    else if ( nbr == 10 ) then
+      call cmfgkb ( lot, ido, ip, l1, lid, na, ch, ch, 1, lot, c, c, &
+        jump, inc, wa(iw) )
+    end if
+
+    l1 = l2
+    iw = iw + ( ip - 1 ) * ( ido + ido )
+
+    if ( ip <= 5 ) then
+      na = 1 - na
+    end if
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cmfm1f.F b/wrfv2_fire/external/fftpack/fftpack5/cmfm1f.F
index ead3b153..cd0ea3de 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cmfm1f.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cmfm1f.F
@@ -1,54 +1,105 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cmfm1f.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE CMFM1F (LOT,JUMP,N,INC,C,CH,WA,FNF,FAC) 
-      COMPLEX       C(*) 
-      REAL       CH(*),     WA(*),      FAC(*) 
-!                                                                       
-! FFTPACK 5.0 auxiliary routine                                         
-!                                                                       
-      NF = FNF 
-      NA = 0 
-      L1 = 1 
-      IW = 1 
-      DO 125 K1=1,NF 
-         IP = FAC(K1) 
-         L2 = IP*L1 
-         IDO = N/L2 
-         LID = L1*IDO 
-         NBR = 1+NA+2*MIN(IP-2,4) 
-         GO TO (52,62,53,63,54,64,55,65,56,66),NBR 
-   52    CALL CMF2KF (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
-         GO TO 120 
-   62    CALL CMF2KF (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
-         GO TO 120 
-   53    CALL CMF3KF (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
-         GO TO 120 
-   63    CALL CMF3KF (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
-         GO TO 120 
-   54    CALL CMF4KF (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
-         GO TO 120 
-   64    CALL CMF4KF (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
-         GO TO 120 
-   55    CALL CMF5KF (LOT,IDO,L1,NA,C,JUMP,INC,CH,1,LOT,WA(IW)) 
-         GO TO 120 
-   65    CALL CMF5KF (LOT,IDO,L1,NA,CH,1,LOT,C,JUMP,INC,WA(IW)) 
-         GO TO 120 
-   56    CALL CMFGKF (LOT,IDO,IP,L1,LID,NA,C,C,JUMP,INC,CH,CH,          &
-     &     1,LOT,WA(IW))                                                
-         GO TO 120 
-   66    CALL CMFGKF (LOT,IDO,IP,L1,LID,NA,CH,CH,1,LOT,C,C,             &
-     &     JUMP,INC,WA(IW))                                             
-  120    L1 = L2 
-         IW = IW+(IP-1)*(IDO+IDO) 
-         IF(IP .LE. 5) NA = 1-NA 
-  125 END DO 
-      RETURN 
-      END                                           
+subroutine cmfm1f ( lot, jump, n, inc, c, ch, wa, fnf, fac )
+
+!*****************************************************************************80
+!
+!! CMFM1F is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  complex ( kind = 4 ) c(*)
+  real ( kind = 4 ) ch(*)
+  real ( kind = 4 ) fac(*)
+  real ( kind = 4 ) fnf
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) lid
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nbr
+  integer ( kind = 4 ) nf
+  real ( kind = 4 ) wa(*)
+
+  nf = int ( fnf )
+  na = 0
+  l1 = 1
+  iw = 1
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1) )
+    l2 = ip * l1
+    ido = n / l2
+    lid = l1 * ido
+    nbr = 1 + na + 2 * min ( ip - 2, 4 )
+
+    if ( nbr == 1 ) then
+      call cmf2kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 2 ) then
+      call cmf2kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 3 ) then
+      call cmf3kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 4 ) then
+      call cmf3kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 5 ) then
+      call cmf4kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 6 ) then
+      call cmf4kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 7 ) then
+      call cmf5kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 8 ) then
+      call cmf5kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 9 ) then
+      call cmfgkf ( lot, ido, ip, l1, lid, na, c, c, jump, inc, ch, ch, &
+        1, lot, wa(iw) )
+    else if ( nbr == 10 ) then
+      call cmfgkf ( lot, ido, ip, l1, lid, na, ch, ch, 1, lot, c, c, &
+        jump, inc, wa(iw) )
+    end if
+
+    l1 = l2
+    iw = iw + ( ip - 1 ) * ( ido + ido )
+
+    if ( ip <= 5 ) then
+      na = 1 - na
+    end if
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cosq1b.F b/wrfv2_fire/external/fftpack/fftpack5/cosq1b.F
index 29287644..f32b2bac 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cosq1b.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cosq1b.F
@@ -1,45 +1,137 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cosq1b.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSQ1B (N, INC, X, LENX, WSAVE, LENSAV,                &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('COSQ1B', 6) 
-        GO TO 300 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COSQ1B', 8) 
-        GO TO 300 
-      ELSEIF (LENWRK .LT. N) THEN 
-        IER = 3 
-        CALL XERFFT ('COSQ1B', 10) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      IF (N-2) 300,102,103 
-  102 SSQRT2 = 1./SQRT(2.) 
-      X1 = X(1,1)+X(1,2) 
-      X(1,2) = SSQRT2*(X(1,1)-X(1,2)) 
-      X(1,1) = X1 
-      RETURN 
-  103 CALL COSQB1 (N,INC,X,WSAVE,WORK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSQ1B',-5) 
-      ENDIF 
-!                                                                       
-  300 RETURN 
-      END                                           
+subroutine cosq1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! COSQ1B: real single precision backward cosine quarter wave transform, 1D.
+!
+!  Discussion:
+!
+!    COSQ1B computes the one-dimensional Fourier transform of a sequence
+!    which is a cosine series with odd wave numbers.  This transform is
+!    referred to as the backward transform or Fourier synthesis, transforming
+!    the sequence from spectral to physical space.
+!
+!    This transform is normalized since a call to COSQ1B followed
+!    by a call to COSQ1F (or vice-versa) reproduces the original
+!    array  within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    31 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the number of elements to be transformed
+!    in the sequence.  The transform is most efficient when N is a
+!    product of small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR); on input, containing the sequence
+!    to be transformed, and on output, containing the transformed sequence.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to COSQ1I before the first call to routine COSQ1F
+!    or COSQ1B for a given transform length N.  WSAVE's contents may be
+!    re-used for subsequent calls to COSQ1F and COSQ1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) ssqrt2
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) x1
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'COSQ1B', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'COSQ1B', 8 )
+    return
+  end if
+
+  if ( lenwrk < n ) then
+    ier = 3
+    call xerfft ( 'COSQ1B', 10 )
+    return
+  end if
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    ssqrt2 = 1.0E+00 / sqrt ( 2.0E+00 )
+    x1 = x(1,1) + x(1,2)
+    x(1,2) = ssqrt2 * ( x(1,1) - x(1,2) )
+    x(1,1) = x1
+    return
+  end if
+
+  call cosqb1 ( n, inc, x, wsave, work, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'COSQ1B', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cosq1f.F b/wrfv2_fire/external/fftpack/fftpack5/cosq1f.F
index f12a6f15..6f74abfa 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cosq1f.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cosq1f.F
@@ -1,46 +1,137 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cosq1f.f,v 1.3 2004/06/15 21:14:57 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSQ1F (N, INC, X, LENX, WSAVE, LENSAV,                &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('COSQ1F', 6) 
-        GO TO 300 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COSQ1F', 8) 
-        GO TO 300 
-      ELSEIF (LENWRK .LT. N) THEN 
-        IER = 3 
-        CALL XERFFT ('COSQ1F', 10) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      IF (N-2) 102,101,103 
-  101 SSQRT2 = 1./SQRT(2.) 
-      TSQX = SSQRT2*X(1,2) 
-      X(1,2) = .5*X(1,1)-TSQX 
-      X(1,1) = .5*X(1,1)+TSQX 
-  102 RETURN 
-  103 CALL COSQF1 (N,INC,X,WSAVE,WORK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSQ1F',-5) 
-      ENDIF 
-!                                                                       
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine cosq1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! COSQ1F: real single precision forward cosine quarter wave transform, 1D.
+!
+!  Discussion:
+!
+!    COSQ1F computes the one-dimensional Fourier transform of a sequence
+!    which is a cosine series with odd wave numbers.  This transform is
+!    referred to as the forward transform or Fourier analysis, transforming
+!    the sequence from physical to spectral space.
+!
+!    This transform is normalized since a call to COSQ1F followed
+!    by a call to COSQ1B (or vice-versa) reproduces the original
+!    array  within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    31 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the number of elements to be transformed
+!    in the sequence.  The transform is most efficient when N is a
+!    product of small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR); on input, containing the sequence
+!    to be transformed, and on output, containing the transformed sequence.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to COSQ1I before the first call to routine COSQ1F
+!    or COSQ1B for a given transform length N.  WSAVE's contents may be
+!    re-used for subsequent calls to COSQ1F and COSQ1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) lenx
+  real ( kind = 4 ) ssqrt2
+  real ( kind = 4 ) tsqx
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'cosq1f', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'cosq1f', 8 )
+    return
+  end if
+
+  if ( lenwrk < n ) then
+    ier = 3
+    call xerfft ( 'cosq1f', 10 )
+    return
+  end if
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    ssqrt2 = 1.0E+00 / sqrt ( 2.0E+00 )
+    tsqx = ssqrt2 * x(1,2)
+    x(1,2) = 0.5E+00 * x(1,1) - tsqx
+    x(1,1) = 0.5E+00 * x(1,1) + tsqx
+    return
+  end if
+
+  call cosqf1 ( n, inc, x, wsave, work, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'cosq1f', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cosq1i.F b/wrfv2_fire/external/fftpack/fftpack5/cosq1i.F
index 4996f2a3..124ad944 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cosq1i.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cosq1i.F
@@ -1,37 +1,102 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cosq1i.f,v 1.2 2004/06/15 21:08:32 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSQ1I (N, WSAVE, LENSAV, IER) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COSQ1I', 3) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      PIH = 2.*ATAN(1.) 
-      DT = PIH/FLOAT(N) 
-      FK = 0. 
-      DO 101 K=1,N 
-         FK = FK+1. 
-         WSAVE(K) = COS(FK*DT) 
-  101 END DO 
-      LNSV = N + INT(LOG(REAL(N))) +4 
-      CALL RFFT1I (N, WSAVE(N+1), LNSV, IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSQ1I',-5) 
-      ENDIF 
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine cosq1i ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! COSQ1I: initialization for COSQ1B and COSQ1F.
+!
+!  Discussion:
+!
+!    COSQ1I initializes array WSAVE for use in its companion routines
+!    COSQ1F and COSQ1B.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    31 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product
+!    of small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors of N
+!    and also containing certain trigonometric values which will be used
+!    in routines COSQ1B or COSQ1F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  real ( kind = 4 ) dt
+  real ( kind = 4 ) fk
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) pih
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'cosq1i', 3 )
+    return
+  end if
+
+  pih = 2.0E+00 * atan ( 1.0E+00 )
+  dt = pih / real ( n, kind = 4 )
+  fk = 0.0E+00
+
+  do k = 1, n
+    fk = fk + 1.0E+00
+    wsave(k) = cos ( fk * dt )
+  end do
+
+  lnsv = n + int ( log ( real ( n, kind = 4 ) ) ) + 4
+
+  call rfft1i ( n, wsave(n+1), lnsv, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'cosq1i', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cosqb1.F b/wrfv2_fire/external/fftpack/fftpack5/cosqb1.F
index 5467101b..afd11ff5 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cosqb1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cosqb1.F
@@ -1,50 +1,105 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cosqb1.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSQB1 (N,INC,X,WSAVE,WORK,IER) 
-      DIMENSION       X(INC,*)     ,WSAVE(*)     ,WORK(*) 
-      IER = 0 
-      NS2 = (N+1)/2 
-      NP2 = N+2 
-      DO 101 I=3,N,2 
-         XIM1 = X(1,I-1)+X(1,I) 
-         X(1,I) = .5*(X(1,I-1)-X(1,I)) 
-         X(1,I-1) = .5*XIM1 
-  101 END DO 
-      X(1,1) = .5*X(1,1) 
-      MODN = MOD(N,2) 
-      IF (MODN .NE. 0) GO TO 302 
-      X(1,N) = .5*X(1,N) 
-  302 LENX = INC*(N-1)  + 1 
-      LNSV = N + INT(LOG(REAL(N))) + 4 
-      LNWK = N 
-!                                                                       
-      CALL RFFT1B(N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSQB1',-5) 
-        GO TO 400 
-      ENDIF 
-!                                                                       
-      DO 102 K=2,NS2 
-         KC = NP2-K 
-         WORK(K) = WSAVE(K-1)*X(1,KC)+WSAVE(KC-1)*X(1,K) 
-         WORK(KC) = WSAVE(K-1)*X(1,K)-WSAVE(KC-1)*X(1,KC) 
-  102 END DO 
-      IF (MODN .NE. 0) GO TO 305 
-      X(1,NS2+1) = WSAVE(NS2)*(X(1,NS2+1)+X(1,NS2+1)) 
-  305 DO 103 K=2,NS2 
-         KC = NP2-K 
-         X(1,K) = WORK(K)+WORK(KC) 
-         X(1,KC) = WORK(K)-WORK(KC) 
-  103 END DO 
-      X(1,1) = X(1,1)+X(1,1) 
-  400 RETURN 
-      END                                           
+subroutine cosqb1 ( n, inc, x, wsave, work, ier )
+
+!*****************************************************************************80
+!
+!! COSQB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np2
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) work(*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) xim1
+
+  ier = 0
+  ns2 = ( n + 1 ) / 2
+  np2 = n + 2
+
+  do i = 3, n, 2
+    xim1 = x(1,i-1) + x(1,i)
+    x(1,i) = 0.5E+00 * ( x(1,i-1) - x(1,i) )
+    x(1,i-1) = 0.5E+00 * xim1
+  end do
+
+  x(1,1) = 0.5E+00 * x(1,1)
+  modn = mod ( n, 2 )
+
+  if ( modn == 0 ) then
+    x(1,n) = 0.5E+00 * x(1,n)
+  end if
+
+  lenx = inc * ( n - 1 )  + 1
+  lnsv = n + int ( log ( real ( n, kind = 4 ) ) ) + 4
+  lnwk = n
+
+  call rfft1b ( n, inc, x, lenx, wsave(n+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'cosqb1', -5 )
+    return
+  end if
+
+  do k = 2, ns2
+    kc = np2 - k
+    work(k)  = wsave(k-1) * x(1,kc) + wsave(kc-1) * x(1,k)
+    work(kc) = wsave(k-1) * x(1,k)  - wsave(kc-1) * x(1,kc)
+  end do
+
+  if ( modn == 0 ) then
+    x(1,ns2+1) = wsave(ns2) * ( x(1,ns2+1) + x(1,ns2+1) )
+  end if
+
+  do k = 2, ns2
+    kc = np2 - k
+    x(1,k)  = work(k) + work(kc)
+    x(1,kc) = work(k) - work(kc)
+  end do
+
+  x(1,1) = x(1,1) + x(1,1)
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cosqf1.F b/wrfv2_fire/external/fftpack/fftpack5/cosqf1.F
index 010f4b88..edff12b5 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cosqf1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cosqf1.F
@@ -1,48 +1,102 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cosqf1.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSQF1 (N,INC,X,WSAVE,WORK,IER) 
-      DIMENSION       X(INC,*)      ,WSAVE(*)      ,WORK(*) 
-      IER = 0 
-      NS2 = (N+1)/2 
-      NP2 = N+2 
-      DO 101 K=2,NS2 
-         KC = NP2-K 
-         WORK(K)  = X(1,K)+X(1,KC) 
-         WORK(KC) = X(1,K)-X(1,KC) 
-  101 END DO 
-      MODN = MOD(N,2) 
-      IF (MODN .NE. 0) GO TO 301 
-      WORK(NS2+1) = X(1,NS2+1)+X(1,NS2+1) 
-  301 DO 102 K=2,NS2 
-         KC = NP2-K 
-         X(1,K)  = WSAVE(K-1)*WORK(KC)+WSAVE(KC-1)*WORK(K) 
-         X(1,KC) = WSAVE(K-1)*WORK(K) -WSAVE(KC-1)*WORK(KC) 
-  102 END DO 
-      IF (MODN .NE. 0) GO TO 303 
-      X(1,NS2+1) = WSAVE(NS2)*WORK(NS2+1) 
-  303 LENX = INC*(N-1)  + 1 
-      LNSV = N + INT(LOG(REAL(N))) + 4 
-      LNWK = N 
-!                                                                       
-      CALL RFFT1F(N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSQF1',-5) 
-        GO TO 400 
-      ENDIF 
-!                                                                       
-      DO 103 I=3,N,2 
-         XIM1 = .5*(X(1,I-1)+X(1,I)) 
-         X(1,I) = .5*(X(1,I-1)-X(1,I)) 
-         X(1,I-1) = XIM1 
-  103 END DO 
-  400 RETURN 
-      END                                           
+subroutine cosqf1 ( n, inc, x, wsave, work, ier )
+
+!*****************************************************************************80
+!
+!! COSQF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np2
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) work(*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) xim1
+
+  ier = 0
+  ns2 = ( n + 1 ) / 2
+  np2 = n + 2
+
+  do k = 2, ns2
+    kc = np2 - k
+    work(k)  = x(1,k) + x(1,kc)
+    work(kc) = x(1,k) - x(1,kc)
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn == 0 ) then
+    work(ns2+1) = x(1,ns2+1) + x(1,ns2+1)
+  end if
+
+  do k = 2, ns2
+    kc = np2 - k
+    x(1,k)  = wsave(k-1) * work(kc) + wsave(kc-1) * work(k)
+    x(1,kc) = wsave(k-1) * work(k)  - wsave(kc-1) * work(kc)
+  end do
+
+  if ( modn == 0 ) then
+    x(1,ns2+1) = wsave(ns2) * work(ns2+1)
+  end if
+
+  lenx = inc * ( n - 1 ) + 1
+  lnsv = n + int ( log ( real ( n, kind = 4 ) ) ) + 4
+  lnwk = n
+
+  call rfft1f ( n, inc, x, lenx, wsave(n+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'cosqf1', -5 )
+    return
+  end if
+
+  do i = 3, n, 2
+    xim1   = 0.5E+00 * ( x(1,i-1) + x(1,i) )
+    x(1,i) = 0.5E+00 * ( x(1,i-1) - x(1,i) )
+    x(1,i-1) = xim1
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cosqmb.F b/wrfv2_fire/external/fftpack/fftpack5/cosqmb.F
index 3560fab8..72f40ec6 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cosqmb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cosqmb.F
@@ -1,58 +1,166 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cosqmb.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSQMB (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-      LOGICAL    XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('COSQMB', 6) 
-        GO TO 300 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COSQMB', 8) 
-        GO TO 300 
-      ELSEIF (LENWRK .LT. LOT*N) THEN 
-        IER = 3 
-        CALL XERFFT ('COSQMB', 10) 
-        GO TO 300 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('COSQMB', -1) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      LJ = (LOT-1)*JUMP+1 
-      IF (N-2) 101,102,103 
-  101 DO 201 M=1,LJ,JUMP 
-      X(M,1) = X(M,1) 
-  201 END DO 
-      RETURN 
-  102 SSQRT2 = 1./SQRT(2.) 
-      DO 202 M=1,LJ,JUMP 
-      X1 = X(M,1)+X(M,2) 
-      X(M,2) = SSQRT2*(X(M,1)-X(M,2)) 
-      X(M,1) = X1 
-  202 END DO 
-      RETURN 
-  103 CALL MCSQB1 (LOT,JUMP,N,INC,X,WSAVE,WORK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSQMB',-5) 
-      ENDIF 
-!                                                                       
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine cosqmb ( lot, jump, n, inc, x, lenx, wsave, lensav, work, &
+  lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! COSQMB: real single precision backward cosine quarter wave, multiple vectors.
+!
+!  Discussion:
+!
+!    COSQMB computes the one-dimensional Fourier transform of multiple
+!    sequences, each of which is a cosine series with odd wave numbers.
+!    This transform is referred to as the backward transform or Fourier
+!    synthesis, transforming the sequences from spectral to physical space.
+!
+!    This transform is normalized since a call to COSQMB followed
+!    by a call to COSQMF (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    01 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed
+!    within array R.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations,
+!    in array R, of the first elements of two consecutive sequences to be
+!    transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the same sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), array containing LOT sequences,
+!    each having length N.  R can have any number of dimensions, but the total
+!    number of locations must be at least LENR.  On input, R contains the data
+!    to be transformed, and on output, the transformed data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to COSQMI before the first call to routine COSQMF
+!    or COSQMB for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to COSQMF and COSQMB with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least LOT*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC,JUMP,N,LOT are not consistent;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lj
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) ssqrt2
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) x1
+  logical              xercon
+
+  ier = 0
+
+  if ( lenx < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'cosqmb', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'cosqmb', 8 )
+    return
+  end if
+
+  if ( lenwrk < lot * n ) then
+    ier = 3
+    call xerfft ( 'cosqmb', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'cosqmb', -1 )
+    return
+  end if
+
+  lj = ( lot - 1 ) * jump + 1
+
+  if ( n < 2 ) then
+    do m = 1, lj, jump
+      x(m,1) = x(m,1)
+    end do
+    return
+  end if
+
+  if ( n  ==  2 ) then
+    ssqrt2 = 1.0E+00 / sqrt ( 2.0E+00 )
+    do m = 1, lj, jump
+      x1 = x(m,1) + x(m,2)
+      x(m,2) = ssqrt2 * ( x(m,1) - x(m,2) )
+      x(m,1) = x1
+    end do
+    return
+  end if
+
+  call mcsqb1 ( lot, jump, n, inc, x, wsave, work, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'cosqmb', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cosqmf.F b/wrfv2_fire/external/fftpack/fftpack5/cosqmf.F
index bae5da25..c1c57e9f 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cosqmf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cosqmf.F
@@ -1,54 +1,167 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cosqmf.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSQMF (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-      LOGICAL    XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('COSQMF', 6) 
-        GO TO 300 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COSQMF', 8) 
-        GO TO 300 
-      ELSEIF (LENWRK .LT. LOT*N) THEN 
-        IER = 3 
-        CALL XERFFT ('COSQMF', 10) 
-        GO TO 300 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('COSQMF', -1) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      LJ = (LOT-1)*JUMP+1 
-      IF (N-2) 102,101,103 
-  101 SSQRT2 = 1./SQRT(2.) 
-      DO 201 M=1,LJ,JUMP 
-      TSQX = SSQRT2*X(M,2) 
-      X(M,2) = .5*X(M,1)-TSQX 
-      X(M,1) = .5*X(M,1)+TSQX 
-  201 END DO 
-  102 RETURN 
-  103 CALL MCSQF1 (LOT,JUMP,N,INC,X,WSAVE,WORK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSQMF',-5) 
-      ENDIF 
-!                                                                       
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine cosqmf ( lot, jump, n, inc, x, lenx, wsave, lensav, work, &
+  lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! COSQMF: real single precision forward cosine quarter wave, multiple vectors.
+!
+!  Discussion:
+!
+!    COSQMF computes the one-dimensional Fourier transform of multiple
+!    sequences within a real array, where each of the sequences is a
+!    cosine series with odd wave numbers.  This transform is referred to
+!    as the forward transform or Fourier synthesis, transforming the
+!    sequences from spectral to physical space.
+!
+!    This transform is normalized since a call to COSQMF followed
+!    by a call to COSQMB (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    01 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed
+!    within array R.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations, in
+!    array R, of the first elements of two consecutive sequences to be
+!    transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the same sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), array containing LOT sequences,
+!    each having length N.  R can have any number of dimensions, but the total
+!    number of locations must be at least LENR.  On input, R contains the data
+!    to be transformed, and on output, the transformed data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to COSQMI before the first call to routine COSQMF
+!    or COSQMB for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to COSQMF and COSQMB with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least LOT*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC,JUMP,N,LOT are not consistent;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lj
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) ssqrt2
+  real ( kind = 4 ) tsqx
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+  logical              xercon
+
+  ier = 0
+
+  if ( lenx < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'cosqmf', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'cosqmf', 8 )
+    return
+  end if
+
+  if ( lenwrk < lot * n ) then
+    ier = 3
+    call xerfft ( 'cosqmf', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'cosqmf', -1 )
+    return
+  end if
+
+  lj = ( lot - 1 ) * jump + 1
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+
+    ssqrt2 = 1.0E+00 / sqrt ( 2.0E+00 )
+
+    do m = 1, lj, jump
+      tsqx = ssqrt2 * x(m,2)
+      x(m,2) = 0.5E+00 * x(m,1) - tsqx
+      x(m,1) = 0.5E+00 * x(m,1) + tsqx
+    end do
+
+    return
+  end if
+
+  call mcsqf1 ( lot, jump, n, inc, x, wsave, work, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'cosqmf', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cosqmi.F b/wrfv2_fire/external/fftpack/fftpack5/cosqmi.F
index 24c8185e..f3c87b98 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cosqmi.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cosqmi.F
@@ -1,38 +1,103 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cosqmi.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSQMI (N, WSAVE, LENSAV, IER) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COSQMI', 3) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      PIH = 2.*ATAN(1.) 
-      DT = PIH/FLOAT(N) 
-      FK = 0. 
-      DO 101 K=1,N 
-         FK = FK+1. 
-         WSAVE(K) = COS(FK*DT) 
-  101 END DO 
-      LNSV = N + INT(LOG(REAL(N))) +4 
-      CALL RFFTMI (N, WSAVE(N+1), LNSV, IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSQMI',-5) 
-      ENDIF 
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine cosqmi ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! COSQMI: initialization for COSQMB and COSQMF.
+!
+!  Discussion:
+!
+!    COSQMI initializes array WSAVE for use in its companion routines
+!    COSQMF and COSQMB.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    01 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors of
+!    N and also containing certain trigonometric values which will be used
+!    in routines COSQMB or COSQMF.
+!
+!    Input, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  real ( kind = 4 ) dt
+  real ( kind = 4 ) fk
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) pih
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'cosqmi', 3 )
+    return
+  end if
+
+  pih = 2.0E+00 * atan ( 1.0E+00 )
+
+  dt = pih / real ( n, kind = 4 )
+
+  fk = 0.0E+00
+  do k = 1, n
+    fk = fk + 1.0E+00
+    wsave(k) = cos ( fk * dt )
+  end do
+
+  lnsv = n + int ( log ( real ( n, kind = 4 ) ) ) + 4
+
+  call rfftmi ( n, wsave(n+1), lnsv, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'cosqmi', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cost1b.F b/wrfv2_fire/external/fftpack/fftpack5/cost1b.F
index 609b204f..80518ead 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cost1b.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cost1b.F
@@ -1,39 +1,123 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cost1b.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COST1B ( N, INC, X, LENX, WSAVE, LENSAV,               &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-      IF (LENX .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('COST1B', 6) 
-        GO TO 100 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COST1B', 8) 
-        GO TO 100 
-      ELSEIF (LENWRK .LT. N-1) THEN 
-        IER = 3 
-        CALL XERFFT ('COST1B', 10) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-      CALL COSTB1 (N,INC,X,WSAVE,WORK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COST1B',-5) 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine cost1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! COST1B: real single precision backward cosine transform, 1D.
+!
+!  Discussion:
+!
+!    COST1B computes the one-dimensional Fourier transform of an even
+!    sequence within a real array.  This transform is referred to as
+!    the backward transform or Fourier synthesis, transforming the sequence
+!    from spectral to physical space.
+!
+!    This transform is normalized since a call to COST1B followed
+!    by a call to COST1F (or vice-versa) reproduces the original array
+!    within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    28 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N-1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), containing the sequence to
+!     be transformed.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to COST1I before the first call to routine COST1F
+!    or COST1B for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to COST1F and COST1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N-1.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'cost1b', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'cost1b', 8 )
+    return
+  end if
+
+  if ( lenwrk < n - 1 ) then
+    ier = 3
+    call xerfft ( 'cost1b', 10 )
+    return
+  end if
+
+  call costb1 ( n, inc, x, wsave, work, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'cost1b', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cost1f.F b/wrfv2_fire/external/fftpack/fftpack5/cost1f.F
index fb291bb7..33d65edf 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cost1f.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cost1f.F
@@ -1,39 +1,123 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cost1f.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COST1F ( N, INC, X, LENX, WSAVE, LENSAV,               &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-      IF (LENX .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('COST1F', 6) 
-        GO TO 100 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COST1F', 8) 
-        GO TO 100 
-      ELSEIF (LENWRK .LT. N-1) THEN 
-        IER = 3 
-        CALL XERFFT ('COST1F', 10) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-      CALL COSTF1(N,INC,X,WSAVE,WORK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COST1F',-5) 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine cost1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! COST1F: real single precision forward cosine transform, 1D.
+!
+!  Discussion:
+!
+!    COST1F computes the one-dimensional Fourier transform of an even
+!    sequence within a real array.  This transform is referred to as the
+!    forward transform or Fourier analysis, transforming the sequence
+!    from  physical to spectral space.
+!
+!    This transform is normalized since a call to COST1F followed by a call
+!    to COST1B (or vice-versa) reproduces the original array within
+!    roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    28 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N-1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), containing the sequence to
+!    be transformed.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to COST1I before the first call to routine COST1F
+!    or COST1B for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to COST1F and COST1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N-1.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'COST1F', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'COST1F', 8 )
+    return
+  end if
+
+  if ( lenwrk < n - 1 ) then
+    ier = 3
+    call xerfft ( 'COST1F', 10 )
+    return
+  end if
+
+  call costf1 ( n, inc, x, wsave, work, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'COST1F', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/cost1i.F b/wrfv2_fire/external/fftpack/fftpack5/cost1i.F
index 0bc0971e..c580a576 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/cost1i.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/cost1i.F
@@ -1,44 +1,114 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: cost1i.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COST1I (N, WSAVE, LENSAV, IER) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COST1I', 3) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      IF (N .LE. 3) RETURN 
-      NM1 = N-1 
-      NP1 = N+1 
-      NS2 = N/2 
-      PI = 4.*ATAN(1.) 
-      DT = PI/FLOAT(NM1) 
-      FK = 0. 
-      DO 101 K=2,NS2 
-         KC = NP1-K 
-         FK = FK+1. 
-         WSAVE(K) = 2.*SIN(FK*DT) 
-         WSAVE(KC) = 2.*COS(FK*DT) 
-  101 END DO 
-      LNSV = NM1 + INT(LOG(REAL(NM1))) +4 
-      CALL RFFT1I (NM1, WSAVE(N+1), LNSV, IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COST1I',-5) 
-      ENDIF 
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine cost1i ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! COST1I: initialization for COST1B and COST1F.
+!
+!  Discussion:
+!
+!    COST1I initializes array WSAVE for use in its companion routines
+!    COST1F and COST1B.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    28 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N-1 is a product
+!    of small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, dimension of WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors of
+!    N and also containing certain trigonometric values which will be used in
+!    routines COST1B or COST1F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  real ( kind = 4 ) dt
+  real ( kind = 4 ) fk
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nm1
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) pi
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'COST1I', 3 )
+    return
+  end if
+
+  if ( n <= 3 ) then
+    return
+  end if
+
+  nm1 = n - 1
+  np1 = n + 1
+  ns2 = n / 2
+  pi = 4.0E+00 * atan ( 1.0E+00 )
+  dt = pi / real ( nm1, kind = 4 )
+  fk = 0.0E+00
+  do k = 2, ns2
+    kc = np1 - k
+    fk = fk + 1.0E+00
+    wsave(k) = 2.0E+00 * sin ( fk * dt )
+    wsave(kc) = 2.0E+00 * cos ( fk * dt )
+  end do
+
+  lnsv = nm1 + int ( log ( real ( nm1, kind = 4 ) ) ) + 4
+
+  call rfft1i ( nm1, wsave(n+1), lnsv, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'COST1I', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/costb1.F b/wrfv2_fire/external/fftpack/fftpack5/costb1.F
index 68171c98..a8ccdb5f 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/costb1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/costb1.F
@@ -1,73 +1,146 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: costb1.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSTB1(N,INC,X,WSAVE,WORK,IER) 
-      REAL       X(INC,*)       ,WSAVE(*) 
-      DOUBLE PRECISION           DSUM 
-      IER = 0 
-      NM1 = N-1 
-      NP1 = N+1 
-      NS2 = N/2 
-      IF (N-2) 106,101,102 
-  101 X1H = X(1,1)+X(1,2) 
-      X(1,2) = X(1,1)-X(1,2) 
-      X(1,1) = X1H 
-      RETURN 
-  102 IF (N .GT. 3) GO TO 103 
-      X1P3 = X(1,1)+X(1,3) 
-      X2 = X(1,2) 
-      X(1,2) = X(1,1)-X(1,3) 
-      X(1,1) = X1P3+X2 
-      X(1,3) = X1P3-X2 
-      RETURN 
-  103 X(1,1) = X(1,1)+X(1,1) 
-      X(1,N) = X(1,N)+X(1,N) 
-      DSUM = X(1,1)-X(1,N) 
-      X(1,1) = X(1,1)+X(1,N) 
-      DO 104 K=2,NS2 
-         KC = NP1-K 
-         T1 = X(1,K)+X(1,KC) 
-         T2 = X(1,K)-X(1,KC) 
-         DSUM = DSUM+WSAVE(KC)*T2 
-         T2 = WSAVE(K)*T2 
-         X(1,K) = T1-T2 
-         X(1,KC) = T1+T2 
-  104 END DO 
-      MODN = MOD(N,2) 
-      IF (MODN .EQ. 0) GO TO 124 
-      X(1,NS2+1) = X(1,NS2+1)+X(1,NS2+1) 
-  124 LENX = INC*(NM1-1)  + 1 
-      LNSV = NM1 + INT(LOG(REAL(NM1))) + 4 
-      LNWK = NM1 
-!                                                                       
-      CALL RFFT1F(NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,                  &
-     &            LNWK,IER1)                                            
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSTB1',-5) 
-        RETURN 
-      ENDIF 
-!                                                                       
-      FNM1S2 = FLOAT(NM1)/2. 
-      DSUM = .5*DSUM 
-      X(1,1) = FNM1S2*X(1,1) 
-      IF(MOD(NM1,2) .NE. 0) GO TO 30 
-      X(1,NM1) = X(1,NM1)+X(1,NM1) 
-   30 FNM1S4 = FLOAT(NM1)/4. 
-      DO 105 I=3,N,2 
-         XI = FNM1S4*X(1,I) 
-         X(1,I) = FNM1S4*X(1,I-1) 
-         X(1,I-1) = DSUM 
-         DSUM = DSUM+XI 
-  105 END DO 
-      IF (MODN .NE. 0) RETURN 
-         X(1,N) = DSUM 
-  106 RETURN 
-      END                                           
+subroutine costb1 ( n, inc, x, wsave, work, ier )
+
+!*****************************************************************************80
+!
+!! COSTB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  real ( kind = 8 ) dsum
+  real ( kind = 4 ) fnm1s2
+  real ( kind = 4 ) fnm1s4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nm1
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) t1
+  real ( kind = 4 ) t2
+  real ( kind = 4 ) work(*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) x1h
+  real ( kind = 4 ) x1p3
+  real ( kind = 4 ) x2
+  real ( kind = 4 ) xi
+
+  ier = 0
+  nm1 = n - 1
+  np1 = n + 1
+  ns2 = n / 2
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    x1h    = x(1,1) + x(1,2)
+    x(1,2) = x(1,1) - x(1,2)
+    x(1,1) = x1h
+    return
+  end if
+
+  if ( n == 3 ) then
+    x1p3 = x(1,1) + x(1,3)
+    x2 = x(1,2)
+    x(1,2) = x(1,1) - x(1,3)
+    x(1,1) = x1p3 + x2
+    x(1,3) = x1p3 - x2
+    return
+  end if
+
+  x(1,1) = x(1,1) + x(1,1)
+  x(1,n) = x(1,n) + x(1,n)
+  dsum = x(1,1) - x(1,n)
+  x(1,1) = x(1,1) + x(1,n)
+
+  do k = 2, ns2
+    kc = np1 - k
+    t1 = x(1,k) + x(1,kc)
+    t2 = x(1,k) - x(1,kc)
+    dsum = dsum + wsave(kc) * t2
+    t2 = wsave(k) * t2
+    x(1,k) = t1 - t2
+    x(1,kc) = t1 + t2
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    x(1,ns2+1) = x(1,ns2+1) + x(1,ns2+1)
+  end if
+
+  lenx = inc * ( nm1 - 1 )  + 1
+  lnsv = nm1 + int ( log ( real ( nm1, kind = 4 ) ) ) + 4
+  lnwk = nm1
+
+  call rfft1f ( nm1, inc, x, lenx, wsave(n+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'COSTB1', -5 )
+    return
+  end if
+
+  fnm1s2 = real ( nm1, kind = 4 ) / 2.0E+00
+  dsum = 0.5E+00 * dsum
+  x(1,1) = fnm1s2 * x(1,1)
+
+  if ( mod ( nm1, 2 ) == 0 ) then
+    x(1,nm1) = x(1,nm1) + x(1,nm1)
+  end if
+
+  fnm1s4 = real ( nm1, kind = 4 ) / 4.0E+00
+
+  do i = 3, n, 2
+    xi = fnm1s4 * x(1,i)
+    x(1,i) = fnm1s4 * x(1,i-1)
+    x(1,i-1) = dsum
+    dsum = dsum + xi
+  end do
+
+  if ( modn == 0 ) then
+    x(1,n) = dsum
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/costf1.F b/wrfv2_fire/external/fftpack/fftpack5/costf1.F
index c952db9e..3f5bee20 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/costf1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/costf1.F
@@ -1,71 +1,142 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: costf1.f,v 1.2 2004/06/15 21:14:57 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSTF1(N,INC,X,WSAVE,WORK,IER) 
-      REAL       X(INC,*)       ,WSAVE(*) 
-      DOUBLE PRECISION           DSUM 
-      IER = 0 
-      NM1 = N-1 
-      NP1 = N+1 
-      NS2 = N/2 
-      IF (N-2) 200,101,102 
-  101 X1H = X(1,1)+X(1,2) 
-      X(1,2) = .5*(X(1,1)-X(1,2)) 
-      X(1,1) = .5*X1H 
-      GO TO 200 
-  102 IF (N .GT. 3) GO TO 103 
-      X1P3 = X(1,1)+X(1,3) 
-      TX2 = X(1,2)+X(1,2) 
-      X(1,2) = .5*(X(1,1)-X(1,3)) 
-      X(1,1) = .25*(X1P3+TX2) 
-      X(1,3) = .25*(X1P3-TX2) 
-      GO TO 200 
-  103 DSUM = X(1,1)-X(1,N) 
-      X(1,1) = X(1,1)+X(1,N) 
-      DO 104 K=2,NS2 
-         KC = NP1-K 
-         T1 = X(1,K)+X(1,KC) 
-         T2 = X(1,K)-X(1,KC) 
-         DSUM = DSUM+WSAVE(KC)*T2 
-         T2 = WSAVE(K)*T2 
-         X(1,K) = T1-T2 
-         X(1,KC) = T1+T2 
-  104 END DO 
-      MODN = MOD(N,2) 
-      IF (MODN .EQ. 0) GO TO 124 
-      X(1,NS2+1) = X(1,NS2+1)+X(1,NS2+1) 
-  124 LENX = INC*(NM1-1)  + 1 
-      LNSV = NM1 + INT(LOG(REAL(NM1))) + 4 
-      LNWK = NM1 
-!                                                                       
-      CALL RFFT1F(NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,                  &
-     &            LNWK,IER1)                                            
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSTF1',-5) 
-        GO TO 200 
-      ENDIF 
-!                                                                       
-      SNM1 = 1./FLOAT(NM1) 
-      DSUM = SNM1*DSUM 
-      IF(MOD(NM1,2) .NE. 0) GO TO 30 
-      X(1,NM1) = X(1,NM1)+X(1,NM1) 
-   30 DO 105 I=3,N,2 
-         XI = .5*X(1,I) 
-         X(1,I) = .5*X(1,I-1) 
-         X(1,I-1) = DSUM 
-         DSUM = DSUM+XI 
-  105 END DO 
-      IF (MODN .NE. 0) GO TO 117 
-      X(1,N) = DSUM 
-  117 X(1,1) = .5*X(1,1) 
-      X(1,N) = .5*X(1,N) 
-  200 RETURN 
-      END                                           
+subroutine costf1 ( n, inc, x, wsave, work, ier )
+
+!*****************************************************************************80
+!
+!! COSTF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  real ( kind = 8 ) dsum
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nm1
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) snm1
+  real ( kind = 4 ) t1
+  real ( kind = 4 ) t2
+  real ( kind = 4 ) tx2
+  real ( kind = 4 ) work(*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) x1h
+  real ( kind = 4 ) x1p3
+  real ( kind = 4 ) xi
+
+  ier = 0
+  nm1 = n - 1
+  np1 = n + 1
+  ns2 = n / 2
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    x1h = x(1,1) + x(1,2)
+    x(1,2) = 0.5E+00 * ( x(1,1) - x(1,2) )
+    x(1,1) = 0.5E+00 * x1h
+    return
+  end if
+
+  if ( n == 3 ) then
+    x1p3 = x(1,1) + x(1,3)
+    tx2 = x(1,2) + x(1,2)
+    x(1,2) = 0.5E+00 * ( x(1,1) - x(1,3) )
+    x(1,1) = 0.25E+00 * ( x1p3 + tx2 )
+    x(1,3) = 0.25E+00 * ( x1p3 - tx2 )
+    return
+  end if
+
+  dsum = x(1,1) - x(1,n)
+  x(1,1) = x(1,1) + x(1,n)
+  do k = 2, ns2
+    kc = np1 - k
+    t1 = x(1,k) + x(1,kc)
+    t2 = x(1,k) - x(1,kc)
+    dsum = dsum + wsave(kc) * t2
+    t2 = wsave(k) * t2
+    x(1,k) = t1 - t2
+    x(1,kc) = t1 + t2
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    x(1,ns2+1) = x(1,ns2+1) + x(1,ns2+1)
+  end if
+
+  lenx = inc * ( nm1 - 1 )  + 1
+  lnsv = nm1 + int ( log ( real ( nm1, kind = 4 ) ) ) + 4
+  lnwk = nm1
+
+  call rfft1f ( nm1, inc, x, lenx, wsave(n+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'costf1', -5 )
+    return
+  end if
+
+  snm1 = 1.0E+00 / real ( nm1, kind = 4 )
+  dsum = snm1 * dsum
+
+  if ( mod ( nm1, 2 ) == 0 ) then
+    x(1,nm1) = x(1,nm1) + x(1,nm1)
+  end if
+
+  do i = 3, n, 2
+    xi = 0.5E+00 * x(1,i)
+    x(1,i) = 0.5E+00 * x(1,i-1)
+    x(1,i-1) = dsum
+    dsum = dsum + xi
+  end do
+
+  if ( modn == 0 ) then
+    x(1,n) = dsum
+  end if
+
+  x(1,1) = 0.5E+00 * x(1,1)
+  x(1,n) = 0.5E+00 * x(1,n)
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/costmb.F b/wrfv2_fire/external/fftpack/fftpack5/costmb.F
index 1a389ed2..85113e30 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/costmb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/costmb.F
@@ -1,46 +1,145 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: costmb.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSTMB (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-      LOGICAL    XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('COSTMB', 6) 
-        GO TO 100 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COSTMB', 8) 
-        GO TO 100 
-      ELSEIF (LENWRK .LT. LOT*(N+1)) THEN 
-        IER = 3 
-        CALL XERFFT ('COSTMB', 10) 
-        GO TO 100 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('COSTMB', -1) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-      IW1 = LOT+LOT+1 
-      CALL MCSTB1(LOT,JUMP,N,INC,X,WSAVE,WORK,WORK(IW1),IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSTMB',-5) 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine costmb ( lot, jump, n, inc, x, lenx, wsave, lensav, work, &
+  lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! COSTMB: real single precision backward cosine transform, multiple vectors.
+!
+!  Discussion:
+!
+!    COSTMB computes the one-dimensional Fourier transform of multiple
+!    even sequences within a real array.  This transform is referred to
+!    as the backward transform or Fourier synthesis, transforming the
+!    sequences from spectral to physical space.
+!
+!    This transform is normalized since a call to COSTMB followed
+!    by a call to COSTMF (or vice-versa) reproduces the original
+!    array  within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    29 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed
+!    within array R.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations, in
+!    array R, of the first elements of two consecutive sequences to be
+!    transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N-1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array R, of two consecutive elements within the same sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), array containing LOT sequences,
+!    each having length N.  On input, the data to be transformed; on output,
+!    the transormed data.  R can have any number of dimensions, but the total
+!    number of locations must be at least LENR.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to COSTMI before the first call to routine COSTMF
+!    or COSTMB for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to COSTMF and COSTMB with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least LOT*(N+1).
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC,JUMP,N,LOT are not consistent;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+  logical              xercon
+
+  ier = 0
+
+  if ( lenx < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'costmb', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'costmb', 8 )
+    return
+  end if
+
+  if ( lenwrk < lot * ( n + 1 ) ) then
+    ier = 3
+    call xerfft ( 'costmb', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'costmb', -1 )
+    return
+  end if
+
+  iw1 = lot + lot + 1
+
+  call mcstb1 ( lot, jump, n, inc, x, wsave, work, work(iw1), ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'costmb', -5 )
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/costmf.F b/wrfv2_fire/external/fftpack/fftpack5/costmf.F
index a77e9ae1..c3496317 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/costmf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/costmf.F
@@ -1,46 +1,146 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: costmf.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSTMF (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-      LOGICAL    XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('COSTMF', 6) 
-        GO TO 100 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COSTMF', 8) 
-        GO TO 100 
-      ELSEIF (LENWRK .LT. LOT*(N+1)) THEN 
-        IER = 3 
-        CALL XERFFT ('COSTMF', 10) 
-        GO TO 100 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('COSTMF', -1) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-      IW1 = LOT+LOT+1 
-      CALL MCSTF1(LOT,JUMP,N,INC,X,WSAVE,WORK,WORK(IW1),IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSTMF',-5) 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine costmf ( lot, jump, n, inc, x, lenx, wsave, lensav, work, &
+  lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! COSTMF: real single precision forward cosine transform, multiple vectors.
+!
+!  Discussion:
+!
+!    COSTMF computes the one-dimensional Fourier transform of multiple
+!    even sequences within a real array.  This transform is referred to
+!    as the forward transform or Fourier analysis, transforming the
+!    sequences from physical to spectral space.
+!
+!    This transform is normalized since a call to COSTMF followed
+!    by a call to COSTMB (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    29 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed
+!    within array R.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations,
+!    in array R, of the first elements of two consecutive sequences to
+!    be transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N-1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the same sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), array containing LOT sequences,
+!    each having length N.  On input, the data to be transformed; on output,
+!    the transormed data.  R can have any number of dimensions, but the total
+!    number of locations must be at least LENR.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the  R array.
+!    LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to COSTMI before the first call to routine COSTMF
+!    or COSTMB for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to COSTMF and COSTMB with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least LOT*(N+1).
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC,JUMP,N,LOT are not consistent;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+  logical              xercon
+
+  ier = 0
+
+  if ( lenx < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'COSTMF', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'COSTMF', 8 )
+    return
+  end if
+
+  if ( lenwrk < lot * ( n + 1 ) ) then
+    ier = 3
+    call xerfft ( 'COSTMF', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'COSTMF', -1 )
+    return
+  end if
+
+  iw1 = lot + lot + 1
+
+  call mcstf1 ( lot, jump, n, inc, x, wsave, work, work(iw1), ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'COSTMF', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/costmi.F b/wrfv2_fire/external/fftpack/fftpack5/costmi.F
index 4077e4dd..8d7db4c5 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/costmi.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/costmi.F
@@ -1,44 +1,115 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: costmi.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE COSTMI (N, WSAVE, LENSAV, IER) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('COSTMI', 3) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      IF (N .LE. 3) RETURN 
-      NM1 = N-1 
-      NP1 = N+1 
-      NS2 = N/2 
-      PI = 4.*ATAN(1.) 
-      DT = PI/FLOAT(NM1) 
-      FK = 0. 
-      DO 101 K=2,NS2 
-         KC = NP1-K 
-         FK = FK+1. 
-         WSAVE(K) = 2.*SIN(FK*DT) 
-         WSAVE(KC) = 2.*COS(FK*DT) 
-  101 END DO 
-      LNSV = NM1 + INT(LOG(REAL(NM1))) +4 
-      CALL RFFTMI (NM1, WSAVE(N+1), LNSV, IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('COSTMI',-5) 
-      ENDIF 
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine costmi ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! COSTMI: initialization for COSTMB and COSTMF.
+!
+!  Discussion:
+!
+!    COSTMI initializes array WSAVE for use in its companion routines
+!    COSTMF and COSTMB.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    29 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors of N
+!    and also containing certain trigonometric values which will be used
+!    in routines COSTMB or COSTMF.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  real ( kind = 4 ) dt
+  real ( kind = 4 ) fk
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nm1
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) pi
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'costmi', 3 )
+    return
+  end if
+
+  if ( n <= 3 ) then
+    return
+  end if
+
+  nm1 = n - 1
+  np1 = n + 1
+  ns2 = n / 2
+  pi = 4.0E+00 * atan ( 1.0E+00 )
+  dt = pi / real ( nm1, kind = 4 )
+
+  fk = 0.0E+00
+  do k = 2, ns2
+    kc = np1 - k
+    fk = fk + 1.0E+00
+    wsave(k) = 2.0E+00 * sin ( fk * dt )
+    wsave(kc) = 2.0E+00 * cos ( fk * dt )
+  end do
+
+  lnsv = nm1 + int ( log ( real ( nm1, kind = 4 ) ) ) + 4
+
+  call rfftmi ( nm1, wsave(n+1), lnsv, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'costmi', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/d1f2kb.F b/wrfv2_fire/external/fftpack/fftpack5/d1f2kb.F
new file mode 100644
index 00000000..e96fa429
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/d1f2kb.F
@@ -0,0 +1,88 @@
+subroutine d1f2kb ( ido, l1, cc, in1, ch, in2, wa1 )
+
+!*****************************************************************************80
+!
+!! D1F2KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(in1,ido,2,l1)
+  real ( kind = 8 ) ch(in2,ido,l1,2)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 8 ) wa1(ido)
+
+  do k = 1, l1
+    ch(1,1,k,1) = cc(1,1,1,k) + cc(1,ido,2,k)
+    ch(1,1,k,2) = cc(1,1,1,k) - cc(1,ido,2,k)
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+
+        ch(1,i-1,k,1) = cc(1,i-1,1,k) + cc(1,ic-1,2,k)
+        ch(1,i,k,1)   = cc(1,i,1,k)   - cc(1,ic,2,k)
+
+        ch(1,i-1,k,2) = wa1(i-2) * ( cc(1,i-1,1,k) - cc(1,ic-1,2,k) ) &
+                      - wa1(i-1) * ( cc(1,i,1,k)   + cc(1,ic,2,k) )
+        ch(1,i,k,2)   = wa1(i-2) * ( cc(1,i,1,k)   + cc(1,ic,2,k) ) &
+                      + wa1(i-1) * ( cc(1,i-1,1,k) - cc(1,ic-1,2,k) )
+
+      end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    ch(1,ido,k,1) =     cc(1,ido,1,k) + cc(1,ido,1,k)
+    ch(1,ido,k,2) = - ( cc(1,1,2,k)   + cc(1,1,2,k) )
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/d1f2kf.F b/wrfv2_fire/external/fftpack/fftpack5/d1f2kf.F
new file mode 100644
index 00000000..f414dcde
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/d1f2kf.F
@@ -0,0 +1,88 @@
+subroutine d1f2kf ( ido, l1, cc, in1, ch, in2, wa1 )
+
+!*****************************************************************************80
+!
+!! D1F2KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) ch(in2,ido,2,l1)
+  real ( kind = 8 ) cc(in1,ido,l1,2)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 8 ) wa1(ido)
+
+  do k = 1, l1
+    ch(1,1,1,k)   = cc(1,1,k,1) + cc(1,1,k,2)
+    ch(1,ido,2,k) = cc(1,1,k,1) - cc(1,1,k,2)
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+        ch(1,i,1,k) = cc(1,i,k,1)   + ( wa1(i-2) * cc(1,i,k,2) &
+                                      - wa1(i-1) * cc(1,i-1,k,2) )
+        ch(1,ic,2,k) = -cc(1,i,k,1) + ( wa1(i-2) * cc(1,i,k,2) &
+                                      - wa1(i-1) * cc(1,i-1,k,2) )
+        ch(1,i-1,1,k) = cc(1,i-1,k,1)  + ( wa1(i-2) * cc(1,i-1,k,2) &
+                                         + wa1(i-1) * cc(1,i,k,2))
+        ch(1,ic-1,2,k) = cc(1,i-1,k,1) - ( wa1(i-2) * cc(1,i-1,k,2) &
+                                         + wa1(i-1) * cc(1,i,k,2))
+      end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    ch(1,1,2,k) = -cc(1,ido,k,2)
+    ch(1,ido,1,k) = cc(1,ido,k,1)
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/d1f3kb.F b/wrfv2_fire/external/fftpack/fftpack5/d1f3kb.F
new file mode 100644
index 00000000..906b51a1
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/d1f3kb.F
@@ -0,0 +1,100 @@
+subroutine d1f3kb ( ido, l1, cc, in1, ch, in2, wa1, wa2 )
+
+!*****************************************************************************80
+!
+!! D1F3KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) arg
+  real ( kind = 8 ) cc(in1,ido,3,l1)
+  real ( kind = 8 ) ch(in2,ido,l1,3)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 8 ) taui
+  real ( kind = 8 ) taur
+  real ( kind = 8 ) wa1(ido)
+  real ( kind = 8 ) wa2(ido)
+
+  arg = 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) / 3.0D+00
+  taur = cos ( arg )
+  taui = sin ( arg )
+
+  do k = 1, l1
+    ch(1,1,k,1) = cc(1,1,1,k) + 2.0D+00 * cc(1,ido,2,k)
+    ch(1,1,k,2) = cc(1,1,1,k) + 2.0D+00 * taur * cc(1,ido,2,k) &
+                              - 2.0D+00 * taui * cc(1,1,3,k)
+    ch(1,1,k,3) = cc(1,1,1,k) + 2.0D+00 * taur * cc(1,ido,2,k) &
+                              + 2.0D+00 * taui * cc(1,1,3,k)
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      ch(1,i-1,k,1) = cc(1,i-1,1,k)+(cc(1,i-1,3,k)+cc(1,ic-1,2,k))
+      ch(1,i,k,1) = cc(1,i,1,k)+(cc(1,i,3,k)-cc(1,ic,2,k))
+      ch(1,i-1,k,2) = wa1(i-2)* &
+        ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))- &
+        (taui*(cc(1,i,3,k)+cc(1,ic,2,k)))) -wa1(i-1)* &
+        ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))+ &
+        (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))))
+      ch(1,i,k,2) = wa1(i-2)* &
+        ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))+ &
+        (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))) +wa1(i-1)* &
+        ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))- &
+        (taui*(cc(1,i,3,k)+cc(1,ic,2,k))))
+      ch(1,i-1,k,3) = wa2(i-2)* &
+        ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))+ &
+        (taui*(cc(1,i,3,k)+cc(1,ic,2,k)))) -wa2(i-1)* &
+        ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))- &
+        (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))))
+      ch(1,i,k,3) = wa2(i-2)* &
+        ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))- &
+        (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))) +wa2(i-1)* &
+        ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))+ &
+        (taui*(cc(1,i,3,k)+cc(1,ic,2,k))))
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/d1f3kf.F b/wrfv2_fire/external/fftpack/fftpack5/d1f3kf.F
new file mode 100644
index 00000000..a03f061c
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/d1f3kf.F
@@ -0,0 +1,102 @@
+subroutine d1f3kf ( ido, l1, cc, in1, ch, in2, wa1, wa2 )
+
+!*****************************************************************************80
+!
+!! D1F3KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) arg
+  real ( kind = 8 ) cc(in1,ido,l1,3)
+  real ( kind = 8 ) ch(in2,ido,3,l1)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 8 ) taui
+  real ( kind = 8 ) taur
+  real ( kind = 8 ) wa1(ido)
+  real ( kind = 8 ) wa2(ido)
+
+  arg = 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) / 3.0D+00
+  taur = cos ( arg )
+  taui = sin ( arg )
+
+  do k = 1, l1
+    ch(1,1,1,k) = cc(1,1,k,1)          + ( cc(1,1,k,2) + cc(1,1,k,3) )
+    ch(1,1,3,k) =                 taui * ( cc(1,1,k,3) - cc(1,1,k,2) )
+    ch(1,ido,2,k) = cc(1,1,k,1) + taur * ( cc(1,1,k,2) + cc(1,1,k,3) )
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      ch(1,i-1,1,k) = cc(1,i-1,k,1)+((wa1(i-2)*cc(1,i-1,k,2)+ &
+        wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3)))
+      ch(1,i,1,k) = cc(1,i,k,1)+((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3)))
+      ch(1,i-1,3,k) = (cc(1,i-1,k,1)+taur*((wa1(i-2)* &
+        cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)* &
+        cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))))+(taui*((wa1(i-2)* &
+        cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa2(i-2)* &
+        cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))))
+      ch(1,ic-1,2,k) = (cc(1,i-1,k,1)+taur*((wa1(i-2)* &
+        cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)* &
+        cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))))-(taui*((wa1(i-2)* &
+        cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa2(i-2)* &
+        cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))))
+      ch(1,i,3,k) = (cc(1,i,k,1)+taur*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))))+(taui*((wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2))))
+      ch(1,ic,2,k) = (taui*((wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2))))-(cc(1,i,k,1)+taur*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))))
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/d1f4kb.F b/wrfv2_fire/external/fftpack/fftpack5/d1f4kb.F
new file mode 100644
index 00000000..230bce57
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/d1f4kb.F
@@ -0,0 +1,120 @@
+subroutine d1f4kb ( ido, l1, cc, in1, ch, in2, wa1, wa2, wa3 )
+
+!*****************************************************************************80
+!
+!! D1F4KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(in1,ido,4,l1)
+  real ( kind = 8 ) ch(in2,ido,l1,4)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 8 ) sqrt2
+  real ( kind = 8 ) wa1(ido)
+  real ( kind = 8 ) wa2(ido)
+  real ( kind = 8 ) wa3(ido)
+
+  sqrt2 = sqrt ( 2.0D+00 )
+
+  do k = 1, l1
+    ch(1,1,k,3) = ( cc(1,1,1,k)   + cc(1,ido,4,k) ) &
+                - ( cc(1,ido,2,k) + cc(1,ido,2,k) )
+    ch(1,1,k,1) = ( cc(1,1,1,k)   + cc(1,ido,4,k) ) &
+                + ( cc(1,ido,2,k) + cc(1,ido,2,k) )
+    ch(1,1,k,4) = ( cc(1,1,1,k)   - cc(1,ido,4,k) ) &
+                + ( cc(1,1,3,k)   + cc(1,1,3,k) )
+    ch(1,1,k,2) = ( cc(1,1,1,k)   - cc(1,ido,4,k) ) &
+                - ( cc(1,1,3,k)   + cc(1,1,3,k) )
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+        ch(1,i-1,k,1) = (cc(1,i-1,1,k)+cc(1,ic-1,4,k)) &
+          +(cc(1,i-1,3,k)+cc(1,ic-1,2,k))
+        ch(1,i,k,1) = (cc(1,i,1,k)-cc(1,ic,4,k)) &
+          +(cc(1,i,3,k)-cc(1,ic,2,k))
+        ch(1,i-1,k,2) = wa1(i-2)*((cc(1,i-1,1,k)-cc(1,ic-1,4,k)) &
+          -(cc(1,i,3,k)+cc(1,ic,2,k)))-wa1(i-1) &
+          *((cc(1,i,1,k)+cc(1,ic,4,k))+(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))
+        ch(1,i,k,2) = wa1(i-2)*((cc(1,i,1,k)+cc(1,ic,4,k)) &
+          +(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))+wa1(i-1) &
+          *((cc(1,i-1,1,k)-cc(1,ic-1,4,k))-(cc(1,i,3,k)+cc(1,ic,2,k)))
+        ch(1,i-1,k,3) = wa2(i-2)*((cc(1,i-1,1,k)+cc(1,ic-1,4,k)) &
+          -(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))-wa2(i-1) &
+          *((cc(1,i,1,k)-cc(1,ic,4,k))-(cc(1,i,3,k)-cc(1,ic,2,k)))
+        ch(1,i,k,3) = wa2(i-2)*((cc(1,i,1,k)-cc(1,ic,4,k)) &
+          -(cc(1,i,3,k)-cc(1,ic,2,k)))+wa2(i-1) &
+          *((cc(1,i-1,1,k)+cc(1,ic-1,4,k))-(cc(1,i-1,3,k) &
+          +cc(1,ic-1,2,k)))
+        ch(1,i-1,k,4) = wa3(i-2)*((cc(1,i-1,1,k)-cc(1,ic-1,4,k)) &
+          +(cc(1,i,3,k)+cc(1,ic,2,k)))-wa3(i-1) &
+          *((cc(1,i,1,k)+cc(1,ic,4,k))-(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))
+        ch(1,i,k,4) = wa3(i-2)*((cc(1,i,1,k)+cc(1,ic,4,k)) &
+          -(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))+wa3(i-1) &
+          *((cc(1,i-1,1,k)-cc(1,ic-1,4,k))+(cc(1,i,3,k)+cc(1,ic,2,k)))
+      end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    ch(1,ido,k,1) = ( cc(1,ido,1,k) + cc(1,ido,3,k) ) &
+                  + ( cc(1,ido,1,k) + cc(1,ido,3,k))
+    ch(1,ido,k,2) = sqrt2 * ( ( cc(1,ido,1,k) - cc(1,ido,3,k) ) &
+                            - ( cc(1,1,2,k)   + cc(1,1,4,k) ) )
+    ch(1,ido,k,3) = ( cc(1,1,4,k) - cc(1,1,2,k) ) &
+                  + ( cc(1,1,4,k) - cc(1,1,2,k) )
+    ch(1,ido,k,4) = -sqrt2 * ( ( cc(1,ido,1,k) - cc(1,ido,3,k) ) &
+                             + ( cc(1,1,2,k) + cc(1,1,4,k) ) )
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/d1f4kf.F b/wrfv2_fire/external/fftpack/fftpack5/d1f4kf.F
new file mode 100644
index 00000000..f2e8f127
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/d1f4kf.F
@@ -0,0 +1,123 @@
+subroutine d1f4kf ( ido, l1, cc, in1, ch, in2, wa1, wa2, wa3 )
+
+!*****************************************************************************80
+!
+!! D1F4KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(in1,ido,l1,4)
+  real ( kind = 8 ) ch(in2,ido,4,l1)
+  real ( kind = 8 ) hsqt2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 8 ) wa1(ido)
+  real ( kind = 8 ) wa2(ido)
+  real ( kind = 8 ) wa3(ido)
+
+  hsqt2 = sqrt ( 2.0D+00 ) / 2.0D+00
+
+  do k = 1, l1
+    ch(1,1,1,k)   = ( cc(1,1,k,2) + cc(1,1,k,4) ) &
+                  + ( cc(1,1,k,1) + cc(1,1,k,3) )
+    ch(1,ido,4,k) = ( cc(1,1,k,1) + cc(1,1,k,3) ) &
+                  - ( cc(1,1,k,2) + cc(1,1,k,4) )
+    ch(1,ido,2,k) = cc(1,1,k,1) - cc(1,1,k,3)
+    ch(1,1,3,k)   = cc(1,1,k,4) - cc(1,1,k,2)
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+        ch(1,i-1,1,k) = ((wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+          cc(1,i,k,2))+(wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+          cc(1,i,k,4)))+(cc(1,i-1,k,1)+(wa2(i-2)*cc(1,i-1,k,3)+ &
+          wa2(i-1)*cc(1,i,k,3)))
+        ch(1,ic-1,4,k) = (cc(1,i-1,k,1)+(wa2(i-2)*cc(1,i-1,k,3)+ &
+          wa2(i-1)*cc(1,i,k,3)))-((wa1(i-2)*cc(1,i-1,k,2)+ &
+          wa1(i-1)*cc(1,i,k,2))+(wa3(i-2)*cc(1,i-1,k,4)+ &
+          wa3(i-1)*cc(1,i,k,4)))
+        ch(1,i,1,k) = ((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* &
+          cc(1,i-1,k,2))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+          cc(1,i-1,k,4)))+(cc(1,i,k,1)+(wa2(i-2)*cc(1,i,k,3)- &
+          wa2(i-1)*cc(1,i-1,k,3)))
+        ch(1,ic,4,k) = ((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* &
+          cc(1,i-1,k,2))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+          cc(1,i-1,k,4)))-(cc(1,i,k,1)+(wa2(i-2)*cc(1,i,k,3)- &
+          wa2(i-1)*cc(1,i-1,k,3)))
+        ch(1,i-1,3,k) = ((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* &
+          cc(1,i-1,k,2))-(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+          cc(1,i-1,k,4)))+(cc(1,i-1,k,1)-(wa2(i-2)*cc(1,i-1,k,3)+ &
+          wa2(i-1)*cc(1,i,k,3)))
+        ch(1,ic-1,2,k) = (cc(1,i-1,k,1)-(wa2(i-2)*cc(1,i-1,k,3)+ &
+          wa2(i-1)*cc(1,i,k,3)))-((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* &
+          cc(1,i-1,k,2))-(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+          cc(1,i-1,k,4)))
+        ch(1,i,3,k) = ((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+          cc(1,i,k,4))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+          cc(1,i,k,2)))+(cc(1,i,k,1)-(wa2(i-2)*cc(1,i,k,3)- &
+          wa2(i-1)*cc(1,i-1,k,3)))
+        ch(1,ic,2,k) = ((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+          cc(1,i,k,4))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+          cc(1,i,k,2)))-(cc(1,i,k,1)-(wa2(i-2)*cc(1,i,k,3)- &
+          wa2(i-1)*cc(1,i-1,k,3)))
+       end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    ch(1,ido,1,k) = (hsqt2*(cc(1,ido,k,2)-cc(1,ido,k,4)))+ cc(1,ido,k,1)
+    ch(1,ido,3,k) = cc(1,ido,k,1)-(hsqt2*(cc(1,ido,k,2)- cc(1,ido,k,4)))
+    ch(1,1,2,k) = (-hsqt2*(cc(1,ido,k,2)+cc(1,ido,k,4)))- cc(1,ido,k,3)
+    ch(1,1,4,k) = (-hsqt2*(cc(1,ido,k,2)+cc(1,ido,k,4)))+ cc(1,ido,k,3)
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/d1f5kb.F b/wrfv2_fire/external/fftpack/fftpack5/d1f5kb.F
new file mode 100644
index 00000000..89f638df
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/d1f5kb.F
@@ -0,0 +1,170 @@
+subroutine d1f5kb ( ido, l1, cc, in1, ch, in2, wa1, wa2, wa3, wa4 )
+
+!*****************************************************************************80
+!
+!! D1F5KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) arg
+  real ( kind = 8 ) cc(in1,ido,5,l1)
+  real ( kind = 8 ) ch(in2,ido,l1,5)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 8 ) ti11
+  real ( kind = 8 ) ti12
+  real ( kind = 8 ) tr11
+  real ( kind = 8 ) tr12
+  real ( kind = 8 ) wa1(ido)
+  real ( kind = 8 ) wa2(ido)
+  real ( kind = 8 ) wa3(ido)
+  real ( kind = 8 ) wa4(ido)
+
+  arg = 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) / 5.0D+00
+  tr11 = cos ( arg )
+  ti11 = sin ( arg )
+  tr12 = cos ( 2.0D+00 * arg )
+  ti12 = sin ( 2.0D+00 * arg )
+
+  do k = 1, l1
+
+    ch(1,1,k,1) = cc(1,1,1,k) + 2.0D+00 * cc(1,ido,2,k) &
+                              + 2.0D+00 * cc(1,ido,4,k)
+
+    ch(1,1,k,2) = ( cc(1,1,1,k) &
+      +   tr11 * 2.0D+00 * cc(1,ido,2,k) + tr12 * 2.0D+00 * cc(1,ido,4,k) ) &
+      - ( ti11 * 2.0D+00 * cc(1,1,3,k)   + ti12 * 2.0D+00 * cc(1,1,5,k))
+
+    ch(1,1,k,3) = ( cc(1,1,1,k) &
+      +   tr12 * 2.0D+00 * cc(1,ido,2,k) + tr11 * 2.0D+00 * cc(1,ido,4,k) ) &
+      - ( ti12 * 2.0D+00 * cc(1,1,3,k)   - ti11 * 2.0D+00 * cc(1,1,5,k))
+
+    ch(1,1,k,4) = ( cc(1,1,1,k) &
+      +   tr12 * 2.0D+00 * cc(1,ido,2,k) + tr11 * 2.0D+00 * cc(1,ido,4,k) ) &
+      + ( ti12 * 2.0D+00 * cc(1,1,3,k)   - ti11 * 2.0D+00 * cc(1,1,5,k))
+
+    ch(1,1,k,5) = ( cc(1,1,1,k) &
+      +   tr11 * 2.0D+00 * cc(1,ido,2,k) + tr12 * 2.0D+00 * cc(1,ido,4,k) ) &
+      + ( ti11 * 2.0D+00 * cc(1,1,3,k)   + ti12 * 2.0D+00 * cc(1,1,5,k) )
+
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      ch(1,i-1,k,1) = cc(1,i-1,1,k)+(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +(cc(1,i-1,5,k)+cc(1,ic-1,4,k))
+      ch(1,i,k,1) = cc(1,i,1,k)+(cc(1,i,3,k)-cc(1,ic,2,k)) &
+        +(cc(1,i,5,k)-cc(1,ic,4,k))
+      ch(1,i-1,k,2) = wa1(i-2)*((cc(1,i-1,1,k)+tr11* &
+        (cc(1,i-1,3,k)+cc(1,ic-1,2,k))+tr12 &
+        *(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))-(ti11*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))+ti12*(cc(1,i,5,k)+cc(1,ic,4,k)))) &
+        -wa1(i-1)*((cc(1,i,1,k)+tr11*(cc(1,i,3,k)-cc(1,ic,2,k)) &
+        +tr12*(cc(1,i,5,k)-cc(1,ic,4,k)))+(ti11*(cc(1,i-1,3,k) &
+        -cc(1,ic-1,2,k))+ti12*(cc(1,i-1,5,k)-cc(1,ic-1,4,k))))
+      ch(1,i,k,2) = wa1(i-2)*((cc(1,i,1,k)+tr11*(cc(1,i,3,k) &
+        -cc(1,ic,2,k))+tr12*(cc(1,i,5,k)-cc(1,ic,4,k))) &
+        +(ti11*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))+ti12 &
+        *(cc(1,i-1,5,k)-cc(1,ic-1,4,k))))+wa1(i-1) &
+        *((cc(1,i-1,1,k)+tr11*(cc(1,i-1,3,k) &
+        +cc(1,ic-1,2,k))+tr12*(cc(1,i-1,5,k)+cc(1,ic-1,4,k))) &
+        -(ti11*(cc(1,i,3,k)+cc(1,ic,2,k))+ti12 &
+        *(cc(1,i,5,k)+cc(1,ic,4,k))))
+      ch(1,i-1,k,3) = wa2(i-2) &
+        *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))-(ti12*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k)))) &
+        -wa2(i-1) &
+        *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- &
+      cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) &
+        +(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 &
+        *(cc(1,i-1,5,k)-cc(1,ic-1,4,k))))
+      ch(1,i,k,3) = wa2(i-2) &
+        *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- &
+        cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) &
+        +(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 &
+        *(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) &
+        +wa2(i-1) &
+        *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))-(ti12*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k))))
+      ch(1,i-1,k,4) = wa3(i-2) &
+        *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti12*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k)))) &
+        -wa3(i-1) &
+        *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- &
+      cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) &
+        -(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 &
+        *(cc(1,i-1,5,k)-cc(1,ic-1,4,k))))
+      ch(1,i,k,4) = wa3(i-2) &
+        *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- &
+        cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) &
+        -(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 &
+        *(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) &
+        +wa3(i-1) &
+        *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti12*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k))))
+      ch(1,i-1,k,5) = wa4(i-2) &
+        *((cc(1,i-1,1,k)+tr11*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr12*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti11*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))+ti12*(cc(1,i,5,k)+cc(1,ic,4,k)))) &
+        -wa4(i-1) &
+        *((cc(1,i,1,k)+tr11*(cc(1,i,3,k)-cc(1,ic,2,k)) &
+        +tr12*(cc(1,i,5,k)-cc(1,ic,4,k)))-(ti11*(cc(1,i-1,3,k) &
+        -cc(1,ic-1,2,k))+ti12*(cc(1,i-1,5,k)-cc(1,ic-1,4,k))))
+      ch(1,i,k,5) = wa4(i-2) &
+        *((cc(1,i,1,k)+tr11*(cc(1,i,3,k)-cc(1,ic,2,k)) &
+        +tr12*(cc(1,i,5,k)-cc(1,ic,4,k)))-(ti11*(cc(1,i-1,3,k) &
+        -cc(1,ic-1,2,k))+ti12*(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) &
+        +wa4(i-1) &
+        *((cc(1,i-1,1,k)+tr11*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr12*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti11*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))+ti12*(cc(1,i,5,k)+cc(1,ic,4,k))))
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/d1f5kf.F b/wrfv2_fire/external/fftpack/fftpack5/d1f5kf.F
new file mode 100644
index 00000000..ab6793f7
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/d1f5kf.F
@@ -0,0 +1,176 @@
+subroutine d1f5kf ( ido, l1, cc, in1, ch, in2, wa1, wa2, wa3, wa4 )
+
+!*****************************************************************************80
+!
+!! D1F5KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) arg
+  real ( kind = 8 ) cc(in1,ido,l1,5)
+  real ( kind = 8 ) ch(in2,ido,5,l1)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 8 ) ti11
+  real ( kind = 8 ) ti12
+  real ( kind = 8 ) tr11
+  real ( kind = 8 ) tr12
+  real ( kind = 8 ) wa1(ido)
+  real ( kind = 8 ) wa2(ido)
+  real ( kind = 8 ) wa3(ido)
+  real ( kind = 8 ) wa4(ido)
+
+  arg = 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 ) / 5.0D+00
+  tr11 = cos ( arg )
+  ti11 = sin ( arg )
+  tr12 = cos ( 2.0D+00 * arg )
+  ti12 = sin ( 2.0D+00 * arg )
+
+  do k = 1, l1
+
+    ch(1,1,1,k) = cc(1,1,k,1) + ( cc(1,1,k,5) + cc(1,1,k,2) ) &
+                              + ( cc(1,1,k,4) + cc(1,1,k,3) )
+
+    ch(1,ido,2,k) = cc(1,1,k,1) + tr11 * ( cc(1,1,k,5) + cc(1,1,k,2) ) &
+                                + tr12 * ( cc(1,1,k,4) + cc(1,1,k,3) )
+
+    ch(1,1,3,k) =                 ti11 * ( cc(1,1,k,5) - cc(1,1,k,2) ) &
+                                + ti12 * ( cc(1,1,k,4) - cc(1,1,k,3) )
+
+    ch(1,ido,4,k) = cc(1,1,k,1) + tr12 * ( cc(1,1,k,5) + cc(1,1,k,2) ) &
+                                + tr11 * ( cc(1,1,k,4) + cc(1,1,k,3) )
+
+    ch(1,1,5,k) =                 ti12 * ( cc(1,1,k,5) - cc(1,1,k,2) ) &
+                                - ti11 * ( cc(1,1,k,4) - cc(1,1,k,3) )
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      ch(1,i-1,1,k) = cc(1,i-1,k,1)+((wa1(i-2)*cc(1,i-1,k,2)+ &
+        wa1(i-1)*cc(1,i,k,2))+(wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)* &
+        cc(1,i,k,5)))+((wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))+(wa3(i-2)*cc(1,i-1,k,4)+ &
+        wa3(i-1)*cc(1,i,k,4)))
+      ch(1,i,1,k) = cc(1,i,k,1)+((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* &
+        cc(1,i-1,k,5)))+((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+        cc(1,i-1,k,4)))
+      ch(1,i-1,3,k) = cc(1,i-1,k,1)+tr11* &
+        ( wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2) &
+        +wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5))+tr12* &
+        ( wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3) &
+        +wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))+ti11* &
+        ( wa1(i-2)*cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2) &
+        -(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))+ti12* &
+        ( wa2(i-2)*cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3) &
+        -(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4)))
+      ch(1,ic-1,2,k) = cc(1,i-1,k,1)+tr11* &
+        ( wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2) &
+        +wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5))+tr12* &
+        ( wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3) &
+        +wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))-(ti11* &
+        ( wa1(i-2)*cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2) &
+        -(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))+ti12* &
+        ( wa2(i-2)*cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3) &
+        -(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4))))
+      ch(1,i,3,k) = (cc(1,i,k,1)+tr11*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* &
+        cc(1,i-1,k,5)))+tr12*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+        cc(1,i-1,k,4))))+(ti11*((wa4(i-2)*cc(1,i-1,k,5)+ &
+        wa4(i-1)*cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2)))+ti12*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+        cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))))
+      ch(1,ic,2,k) = (ti11*((wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)* &
+        cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2)))+ti12*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+        cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))))-(cc(1,i,k,1)+tr11*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* &
+        cc(1,i-1,k,5)))+tr12*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+        cc(1,i-1,k,4))))
+      ch(1,i-1,5,k) = (cc(1,i-1,k,1)+tr12*((wa1(i-2)* &
+        cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa4(i-2)* &
+        cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5)))+tr11*((wa2(i-2)* &
+        cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))+(wa3(i-2)* &
+        cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))))+(ti12*((wa1(i-2)* &
+        cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa4(i-2)* &
+        cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))-ti11*((wa2(i-2)* &
+        cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))-(wa3(i-2)* &
+        cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4))))
+      ch(1,ic-1,4,k) = (cc(1,i-1,k,1)+tr12*((wa1(i-2)* &
+        cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa4(i-2)* &
+        cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5)))+tr11*((wa2(i-2)* &
+        cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))+(wa3(i-2)* &
+        cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))))-(ti12*((wa1(i-2)* &
+        cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa4(i-2)* &
+        cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))-ti11*((wa2(i-2)* &
+        cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))-(wa3(i-2)* &
+        cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4))))
+      ch(1,i,5,k) = (cc(1,i,k,1)+tr12*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* &
+        cc(1,i-1,k,5)))+tr11*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+        cc(1,i-1,k,4))))+(ti12*((wa4(i-2)*cc(1,i-1,k,5)+ &
+        wa4(i-1)*cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2)))-ti11*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+        cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))))
+      ch(1,ic,4,k) = (ti12*((wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)* &
+        cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2)))-ti11*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+        cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))))-(cc(1,i,k,1)+tr12*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* &
+        cc(1,i-1,k,5)))+tr11*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+        cc(1,i-1,k,4))))
+     end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/d1fgkb.F b/wrfv2_fire/external/fftpack/fftpack5/d1fgkb.F
new file mode 100644
index 00000000..96486761
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/d1fgkb.F
@@ -0,0 +1,273 @@
+subroutine d1fgkb ( ido, ip, l1, idl1, cc, c1, c2, in1, ch, ch2, in2, wa )
+
+!*****************************************************************************80
+!
+!! D1FGKB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) ai1
+  real ( kind = 8 ) ai2
+  real ( kind = 8 ) ar1
+  real ( kind = 8 ) ar1h
+  real ( kind = 8 ) ar2
+  real ( kind = 8 ) ar2h
+  real ( kind = 8 ) arg
+  real ( kind = 8 ) c1(in1,ido,l1,ip)
+  real ( kind = 8 ) c2(in1,idl1,ip)
+  real ( kind = 8 ) cc(in1,ido,ip,l1)
+  real ( kind = 8 ) ch(in2,ido,l1,ip)
+  real ( kind = 8 ) ch2(in2,idl1,ip)
+  real ( kind = 8 ) dc2
+  real ( kind = 8 ) dcp
+  real ( kind = 8 ) ds2
+  real ( kind = 8 ) dsp
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idij
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) ik
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) is
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) j2
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) nbd
+  real ( kind = 8 ) tpi
+  real ( kind = 8 ) wa(ido)
+
+  tpi = 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 )
+  arg = tpi / real ( ip, kind = 8 )
+  dcp = cos ( arg )
+  dsp = sin ( arg )
+  idp2 = ido + 2
+  nbd = ( ido - 1 ) / 2
+  ipp2 = ip + 2
+  ipph = ( ip + 1 ) / 2
+
+  if ( ido < l1 ) then
+    do i = 1, ido
+      do k = 1, l1
+        ch(1,i,k,1) = cc(1,i,1,k)
+      end do
+    end do
+  else
+    do k = 1, l1
+      do i = 1, ido
+        ch(1,i,k,1) = cc(1,i,1,k)
+      end do
+    end do
+  end if
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    j2 = j + j
+    do k = 1, l1
+      ch(1,1,k,j) = cc(1,ido,j2-2,k)+cc(1,ido,j2-2,k)
+      ch(1,1,k,jc) = cc(1,1,j2-1,k)+cc(1,1,j2-1,k)
+    end do
+  end do
+
+  if ( ido == 1 ) then
+
+  else if ( nbd < l1 ) then
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do i = 3, ido, 2
+        ic = idp2 - i
+        do k = 1, l1
+          ch(1,i-1,k,j) = cc(1,i-1,2*j-1,k)+cc(1,ic-1,2*j-2,k)
+          ch(1,i-1,k,jc) = cc(1,i-1,2*j-1,k)-cc(1,ic-1,2*j-2,k)
+          ch(1,i,k,j) = cc(1,i,2*j-1,k)-cc(1,ic,2*j-2,k)
+          ch(1,i,k,jc) = cc(1,i,2*j-1,k)+cc(1,ic,2*j-2,k)
+        end do
+      end do
+    end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do k = 1, l1
+        do i = 3, ido, 2
+          ic = idp2 - i
+          ch(1,i-1,k,j) = cc(1,i-1,2*j-1,k)+cc(1,ic-1,2*j-2,k)
+          ch(1,i-1,k,jc) = cc(1,i-1,2*j-1,k)-cc(1,ic-1,2*j-2,k)
+          ch(1,i,k,j) = cc(1,i,2*j-1,k)-cc(1,ic,2*j-2,k)
+          ch(1,i,k,jc) = cc(1,i,2*j-1,k)+cc(1,ic,2*j-2,k)
+        end do
+      end do
+    end do
+
+  end if
+
+  ar1 = 1.0D+00
+  ai1 = 0.0D+00
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+    ar1h = dcp * ar1 - dsp * ai1
+    ai1 = dcp * ai1 + dsp * ar1
+    ar1 = ar1h
+
+    do ik = 1, idl1
+      c2(1,ik,l) = ch2(1,ik,1)+ar1*ch2(1,ik,2)
+      c2(1,ik,lc) = ai1*ch2(1,ik,ip)
+    end do
+
+    dc2 = ar1
+    ds2 = ai1
+    ar2 = ar1
+    ai2 = ai1
+
+    do j = 3, ipph
+
+      jc = ipp2 - j
+      ar2h = dc2*ar2-ds2*ai2
+      ai2 = dc2*ai2+ds2*ar2
+      ar2 = ar2h
+
+      do ik = 1, idl1
+        c2(1,ik,l) = c2(1,ik,l)+ar2*ch2(1,ik,j)
+        c2(1,ik,lc) = c2(1,ik,lc)+ai2*ch2(1,ik,jc)
+      end do
+
+    end do
+
+  end do
+
+  do j = 2, ipph
+    do ik = 1, idl1
+      ch2(1,ik,1) = ch2(1,ik,1)+ch2(1,ik,j)
+    end do
+  end do
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do k = 1, l1
+      ch(1,1,k,j) = c1(1,1,k,j)-c1(1,1,k,jc)
+      ch(1,1,k,jc) = c1(1,1,k,j)+c1(1,1,k,jc)
+    end do
+  end do
+
+  if ( ido == 1 ) then
+
+  else if ( nbd < l1 ) then
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do i = 3, ido, 2
+        do k = 1, l1
+          ch(1,i-1,k,j)  = c1(1,i-1,k,j) - c1(1,i,k,jc)
+          ch(1,i-1,k,jc) = c1(1,i-1,k,j) + c1(1,i,k,jc)
+          ch(1,i,k,j)    = c1(1,i,k,j)   + c1(1,i-1,k,jc)
+          ch(1,i,k,jc)   = c1(1,i,k,j)   - c1(1,i-1,k,jc)
+        end do
+      end do
+    end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do k = 1, l1
+        do i = 3, ido, 2
+          ch(1,i-1,k,j) = c1(1,i-1,k,j)-c1(1,i,k,jc)
+          ch(1,i-1,k,jc) = c1(1,i-1,k,j)+c1(1,i,k,jc)
+          ch(1,i,k,j) = c1(1,i,k,j)+c1(1,i-1,k,jc)
+          ch(1,i,k,jc) = c1(1,i,k,j)-c1(1,i-1,k,jc)
+        end do
+      end do
+    end do
+
+  end if
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  do ik = 1, idl1
+    c2(1,ik,1) = ch2(1,ik,1)
+  end do
+
+  do j = 2, ip
+    do k = 1, l1
+      c1(1,1,k,j) = ch(1,1,k,j)
+    end do
+  end do
+
+  if ( l1 < nbd ) then
+
+    is = -ido
+    do j = 2, ip
+       is = is + ido
+       do k = 1, l1
+         idij = is
+         do i = 3, ido, 2
+           idij = idij + 2
+           c1(1,i-1,k,j) = wa(idij-1)*ch(1,i-1,k,j)-wa(idij)* ch(1,i,k,j)
+           c1(1,i,k,j) = wa(idij-1)*ch(1,i,k,j)+wa(idij)* ch(1,i-1,k,j)
+         end do
+       end do
+    end do
+
+  else
+
+    is = -ido
+
+    do j = 2, ip
+      is = is + ido
+      idij = is
+      do i = 3, ido, 2
+        idij = idij + 2
+        do k = 1, l1
+           c1(1,i-1,k,j) = wa(idij-1) * ch(1,i-1,k,j) - wa(idij) * ch(1,i,k,j)
+           c1(1,i,k,j)   = wa(idij-1) * ch(1,i,k,j)   + wa(idij) * ch(1,i-1,k,j)
+        end do
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/d1fgkf.F b/wrfv2_fire/external/fftpack/fftpack5/d1fgkf.F
new file mode 100644
index 00000000..b5d7d703
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/d1fgkf.F
@@ -0,0 +1,283 @@
+subroutine d1fgkf ( ido, ip, l1, idl1, cc, c1, c2, in1, ch, ch2, in2, wa )
+
+!*****************************************************************************80
+!
+!! D1FGKF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) ai1
+  real ( kind = 8 ) ai2
+  real ( kind = 8 ) ar1
+  real ( kind = 8 ) ar1h
+  real ( kind = 8 ) ar2
+  real ( kind = 8 ) ar2h
+  real ( kind = 8 ) arg
+  real ( kind = 8 ) c1(in1,ido,l1,ip)
+  real ( kind = 8 ) c2(in1,idl1,ip)
+  real ( kind = 8 ) cc(in1,ido,ip,l1)
+  real ( kind = 8 ) ch(in2,ido,l1,ip)
+  real ( kind = 8 ) ch2(in2,idl1,ip)
+  real ( kind = 8 ) dc2
+  real ( kind = 8 ) dcp
+  real ( kind = 8 ) ds2
+  real ( kind = 8 ) dsp
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idij
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) ik
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) is
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) j2
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) nbd
+  real ( kind = 8 ) tpi
+  real ( kind = 8 ) wa(ido)
+
+  tpi = 2.0D+00 * 4.0D+00 * atan ( 1.0D+00 )
+  arg = tpi / real ( ip, kind = 8 )
+  dcp = cos ( arg )
+  dsp = sin ( arg )
+  ipph = ( ip + 1 ) / 2
+  ipp2 = ip + 2
+  idp2 = ido + 2
+  nbd = ( ido - 1 ) / 2
+
+  if ( ido == 1 ) then
+
+    do ik = 1, idl1
+      c2(1,ik,1) = ch2(1,ik,1)
+    end do
+
+  else
+
+    do ik = 1, idl1
+      ch2(1,ik,1) = c2(1,ik,1)
+    end do
+
+    do j = 2, ip
+      do k = 1, l1
+        ch(1,1,k,j) = c1(1,1,k,j)
+      end do
+    end do
+
+    if ( l1 < nbd ) then
+
+      is = -ido
+
+      do j = 2, ip
+        is = is + ido
+        do k = 1, l1
+          idij = is
+          do i = 3, ido, 2
+            idij = idij + 2
+            ch(1,i-1,k,j) = wa(idij-1)*c1(1,i-1,k,j)+wa(idij) *c1(1,i,k,j)
+            ch(1,i,k,j) = wa(idij-1)*c1(1,i,k,j)-wa(idij) *c1(1,i-1,k,j)
+          end do
+        end do
+      end do
+
+    else
+
+      is = -ido
+
+      do j = 2, ip
+        is = is + ido
+        idij = is
+        do i = 3, ido, 2
+          idij = idij + 2
+          do k = 1, l1
+            ch(1,i-1,k,j) = wa(idij-1)*c1(1,i-1,k,j)+wa(idij) *c1(1,i,k,j)
+            ch(1,i,k,j) = wa(idij-1)*c1(1,i,k,j)-wa(idij) *c1(1,i-1,k,j)
+          end do
+        end do
+      end do
+
+    end if
+
+    if ( nbd < l1 ) then
+
+      do j = 2, ipph
+        jc = ipp2 - j
+        do i = 3, ido, 2
+          do k = 1, l1
+            c1(1,i-1,k,j) = ch(1,i-1,k,j)+ch(1,i-1,k,jc)
+            c1(1,i-1,k,jc) = ch(1,i,k,j)-ch(1,i,k,jc)
+            c1(1,i,k,j) = ch(1,i,k,j)+ch(1,i,k,jc)
+            c1(1,i,k,jc) = ch(1,i-1,k,jc)-ch(1,i-1,k,j)
+          end do
+        end do
+      end do
+
+    else
+
+      do j = 2, ipph
+        jc = ipp2 - j
+        do k = 1, l1
+          do i = 3, ido, 2
+            c1(1,i-1,k,j) = ch(1,i-1,k,j)+ch(1,i-1,k,jc)
+            c1(1,i-1,k,jc) = ch(1,i,k,j)-ch(1,i,k,jc)
+            c1(1,i,k,j) = ch(1,i,k,j)+ch(1,i,k,jc)
+            c1(1,i,k,jc) = ch(1,i-1,k,jc)-ch(1,i-1,k,j)
+          end do
+        end do
+      end do
+
+    end if
+
+  end if
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do k = 1, l1
+      c1(1,1,k,j) = ch(1,1,k,j)+ch(1,1,k,jc)
+      c1(1,1,k,jc) = ch(1,1,k,jc)-ch(1,1,k,j)
+    end do
+  end do
+
+  ar1 = 1.0D+00
+  ai1 = 0.0D+00
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+    ar1h = dcp * ar1 - dsp * ai1
+    ai1 = dcp * ai1 + dsp * ar1
+    ar1 = ar1h
+
+    do ik = 1, idl1
+      ch2(1,ik,l) = c2(1,ik,1)+ar1*c2(1,ik,2)
+      ch2(1,ik,lc) = ai1*c2(1,ik,ip)
+    end do
+
+    dc2 = ar1
+    ds2 = ai1
+    ar2 = ar1
+    ai2 = ai1
+
+    do j = 3, ipph
+      jc = ipp2 - j
+      ar2h = dc2 * ar2 - ds2 * ai2
+      ai2 = dc2 * ai2 + ds2 * ar2
+      ar2 = ar2h
+      do ik = 1, idl1
+        ch2(1,ik,l) = ch2(1,ik,l)+ar2*c2(1,ik,j)
+        ch2(1,ik,lc) = ch2(1,ik,lc)+ai2*c2(1,ik,jc)
+      end do
+    end do
+
+  end do
+
+  do j = 2, ipph
+    do ik = 1, idl1
+      ch2(1,ik,1) = ch2(1,ik,1)+c2(1,ik,j)
+    end do
+  end do
+
+  if ( ido < l1 ) then
+
+    do i = 1, ido
+      do k = 1, l1
+        cc(1,i,1,k) = ch(1,i,k,1)
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do i = 1, ido
+        cc(1,i,1,k) = ch(1,i,k,1)
+      end do
+    end do
+
+  end if
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    j2 = j+j
+    do k = 1, l1
+      cc(1,ido,j2-2,k) = ch(1,1,k,j)
+      cc(1,1,j2-1,k) = ch(1,1,k,jc)
+    end do
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  if ( nbd < l1 ) then
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      j2 = j + j
+      do i = 3, ido, 2
+        ic = idp2 - i
+        do k = 1, l1
+          cc(1,i-1,j2-1,k) = ch(1,i-1,k,j)+ch(1,i-1,k,jc)
+          cc(1,ic-1,j2-2,k) = ch(1,i-1,k,j)-ch(1,i-1,k,jc)
+          cc(1,i,j2-1,k) = ch(1,i,k,j)+ch(1,i,k,jc)
+          cc(1,ic,j2-2,k) = ch(1,i,k,jc)-ch(1,i,k,j)
+        end do
+      end do
+   end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      j2 = j + j
+      do k = 1, l1
+        do i = 3, ido, 2
+          ic = idp2 - i
+          cc(1,i-1,j2-1,k)  = ch(1,i-1,k,j) + ch(1,i-1,k,jc)
+          cc(1,ic-1,j2-2,k) = ch(1,i-1,k,j) - ch(1,i-1,k,jc)
+          cc(1,i,j2-1,k)    = ch(1,i,k,j)   + ch(1,i,k,jc)
+          cc(1,ic,j2-2,k)   = ch(1,i,k,jc)  - ch(1,i,k,j)
+        end do
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dcosq1b.F b/wrfv2_fire/external/fftpack/fftpack5/dcosq1b.F
new file mode 100644
index 00000000..b9665f33
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dcosq1b.F
@@ -0,0 +1,135 @@
+subroutine dcosq1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! DCOSQ1B: real double precision backward cosine quarter wave transform, 1D.
+!
+!  Discussion:
+!
+!    DCOSQ1B computes the one-dimensional Fourier transform of a sequence
+!    which is a cosine series with odd wave numbers.  This transform is
+!    referred to as the backward transform or Fourier synthesis, transforming
+!    the sequence from spectral to physical space.
+!
+!    This transform is normalized since a call to DCOSQ1B followed
+!    by a call to DCOSQ1F (or vice-versa) reproduces the original
+!    array  within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    17 November 2007
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the number of elements to be transformed
+!    in the sequence.  The transform is most efficient when N is a
+!    product of small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 8 ) R(LENR); on input, containing the sequence
+!    to be transformed, and on output, containing the transformed sequence.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to DCOSQ1I before the first call to routine
+!    DCOSQ1F or DCOSQ1B for a given transform length N.  WSAVE's contents may
+!    be re-used for subsequent calls to DCOSQ1F and DCOSQ1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) ssqrt2
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+  real ( kind = 8 ) x(inc,*)
+  real ( kind = 8 ) x1
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'DCOSQ1B', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'DCOSQ1B', 8 )
+    return
+  end if
+
+  if ( lenwrk < n ) then
+    ier = 3
+    call xerfft ( 'DCOSQ1B', 10 )
+    return
+  end if
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    ssqrt2 = 1.0D+00 / sqrt ( 2.0D+00 )
+    x1 = x(1,1) + x(1,2)
+    x(1,2) = ssqrt2 * ( x(1,1) - x(1,2) )
+    x(1,1) = x1
+    return
+  end if
+
+  call dcosqb1 ( n, inc, x, wsave, work, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'DCOSQ1B', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dcosq1f.F b/wrfv2_fire/external/fftpack/fftpack5/dcosq1f.F
new file mode 100644
index 00000000..c4f4ef7f
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dcosq1f.F
@@ -0,0 +1,135 @@
+subroutine dcosq1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! DCOSQ1F: real double precision forward cosine quarter wave transform, 1D.
+!
+!  Discussion:
+!
+!    DCOSQ1F computes the one-dimensional Fourier transform of a sequence
+!    which is a cosine series with odd wave numbers.  This transform is
+!    referred to as the forward transform or Fourier analysis, transforming
+!    the sequence from physical to spectral space.
+!
+!    This transform is normalized since a call to DCOSQ1F followed
+!    by a call to DCOSQ1B (or vice-versa) reproduces the original
+!    array  within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!     17 November 2007
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the number of elements to be transformed in
+!    the sequence.  The transform is most efficient when N is a
+!    product of small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 8 ) R(LENR); on input, containing the sequence
+!    to be transformed, and on output, containing the transformed sequence.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to DCOSQ1I before the first call to routine
+!    DCOSQ1F or DCOSQ1B for a given transform length N.  WSAVE's contents may
+!    be re-used for subsequent calls to DCOSQ1F and DCOSQ1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) lenx
+  real ( kind = 8 ) ssqrt2
+  real ( kind = 8 ) tsqx
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+  real ( kind = 8 ) x(inc,*)
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'dcosq1f', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'dcosq1f', 8 )
+    return
+  end if
+
+  if ( lenwrk < n ) then
+    ier = 3
+    call xerfft ( 'dcosq1f', 10 )
+    return
+  end if
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    ssqrt2 = 1.0D+00 / sqrt ( 2.0D+00 )
+    tsqx = ssqrt2 * x(1,2)
+    x(1,2) = 0.5D+00 * x(1,1) - tsqx
+    x(1,1) = 0.5D+00 * x(1,1) + tsqx
+    return
+  end if
+
+  call dcosqf1 ( n, inc, x, wsave, work, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'dcosq1f', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dcosq1i.F b/wrfv2_fire/external/fftpack/fftpack5/dcosq1i.F
new file mode 100644
index 00000000..230ba9bd
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dcosq1i.F
@@ -0,0 +1,100 @@
+subroutine dcosq1i ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! DCOSQ1I: initialization for DCOSQ1B and DCOSQ1F.
+!
+!  Discussion:
+!
+!    DCOSQ1I initializes array WSAVE for use in its companion routines
+!    DCOSQ1F and DCOSQ1B.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    17 November 2007
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of small
+!    primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors of
+!    N and also containing certain trigonometric values which will be used
+!    in routines DCOSQ1B or DCOSQ1F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  real ( kind = 8 ) dt
+  real ( kind = 8 ) fk
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) pih
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'dcosq1i', 3 )
+    return
+  end if
+
+  pih = 2.0D+00 * atan ( 1.0D+00 )
+  dt = pih / real ( n, kind = 8 )
+  fk = 0.0D+00
+
+  do k = 1, n
+    fk = fk + 1.0D+00
+    wsave(k) = cos ( fk * dt )
+  end do
+
+  lnsv = n + int ( log ( real ( n, kind = 8 ) ) ) + 4
+
+  call dfft1i ( n, wsave(n+1), lnsv, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'dcosq1i', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dcosqb1.F b/wrfv2_fire/external/fftpack/fftpack5/dcosqb1.F
new file mode 100644
index 00000000..bbf64b10
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dcosqb1.F
@@ -0,0 +1,103 @@
+subroutine dcosqb1 ( n, inc, x, wsave, work, ier )
+
+!*****************************************************************************80
+!
+!! DCOSQB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!     17 November 2007
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np2
+  integer ( kind = 4 ) ns2
+  real ( kind = 8 ) work(*)
+  real ( kind = 8 ) wsave(*)
+  real ( kind = 8 ) x(inc,*)
+  real ( kind = 8 ) xim1
+
+  ier = 0
+  ns2 = ( n + 1 ) / 2
+  np2 = n + 2
+
+  do i = 3, n, 2
+    xim1 = x(1,i-1) + x(1,i)
+    x(1,i) = 0.5D+00 * ( x(1,i-1) - x(1,i) )
+    x(1,i-1) = 0.5D+00 * xim1
+  end do
+
+  x(1,1) = 0.5D+00 * x(1,1)
+  modn = mod ( n, 2 )
+
+  if ( modn == 0 ) then
+    x(1,n) = 0.5D+00 * x(1,n)
+  end if
+
+  lenx = inc * ( n - 1 )  + 1
+  lnsv = n + int ( log ( real ( n, kind = 8 ) ) ) + 4
+  lnwk = n
+
+  call dfft1b ( n, inc, x, lenx, wsave(n+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'dcosqb1', -5 )
+    return
+  end if
+
+  do k = 2, ns2
+    kc = np2 - k
+    work(k)  = wsave(k-1) * x(1,kc) + wsave(kc-1) * x(1,k)
+    work(kc) = wsave(k-1) * x(1,k)  - wsave(kc-1) * x(1,kc)
+  end do
+
+  if ( modn == 0 ) then
+    x(1,ns2+1) = wsave(ns2) * ( x(1,ns2+1) + x(1,ns2+1) )
+  end if
+
+  do k = 2, ns2
+    kc = np2 - k
+    x(1,k)  = work(k) + work(kc)
+    x(1,kc) = work(k) - work(kc)
+  end do
+
+  x(1,1) = x(1,1) + x(1,1)
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dcosqf1.F b/wrfv2_fire/external/fftpack/fftpack5/dcosqf1.F
new file mode 100644
index 00000000..84f22f5d
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dcosqf1.F
@@ -0,0 +1,100 @@
+subroutine dcosqf1 ( n, inc, x, wsave, work, ier )
+
+!*****************************************************************************80
+!
+!! DCOSQF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    17 November 2007
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np2
+  integer ( kind = 4 ) ns2
+  real ( kind = 8 ) work(*)
+  real ( kind = 8 ) wsave(*)
+  real ( kind = 8 ) x(inc,*)
+  real ( kind = 8 ) xim1
+
+  ier = 0
+  ns2 = ( n + 1 ) / 2
+  np2 = n + 2
+
+  do k = 2, ns2
+    kc = np2 - k
+    work(k)  = x(1,k) + x(1,kc)
+    work(kc) = x(1,k) - x(1,kc)
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn == 0 ) then
+    work(ns2+1) = x(1,ns2+1) + x(1,ns2+1)
+  end if
+
+  do k = 2, ns2
+    kc = np2 - k
+    x(1,k)  = wsave(k-1) * work(kc) + wsave(kc-1) * work(k)
+    x(1,kc) = wsave(k-1) * work(k)  - wsave(kc-1) * work(kc)
+  end do
+
+  if ( modn == 0 ) then
+    x(1,ns2+1) = wsave(ns2) * work(ns2+1)
+  end if
+
+  lenx = inc * ( n - 1 ) + 1
+  lnsv = n + int ( log ( real ( n, kind = 8 ) ) ) + 4
+  lnwk = n
+
+  call dfft1f ( n, inc, x, lenx, wsave(n+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'dcosqf1', -5 )
+    return
+  end if
+
+  do i = 3, n, 2
+    xim1   = 0.5D+00 * ( x(1,i-1) + x(1,i) )
+    x(1,i) = 0.5D+00 * ( x(1,i-1) - x(1,i) )
+    x(1,i-1) = xim1
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dcost1b.F b/wrfv2_fire/external/fftpack/fftpack5/dcost1b.F
new file mode 100644
index 00000000..b797e903
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dcost1b.F
@@ -0,0 +1,121 @@
+subroutine dcost1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! DCOST1B: real double precision backward cosine transform, 1D.
+!
+!  Discussion:
+!
+!    DCOST1B computes the one-dimensional Fourier transform of an even
+!    sequence within a real array.  This transform is referred to as
+!    the backward transform or Fourier synthesis, transforming the sequence
+!    from spectral to physical space.
+!
+!    This transform is normalized since a call to DCOST1B followed
+!    by a call to COST1F (or vice-versa) reproduces the original array
+!    within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N-1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 8 ) R(LENR), containing the sequence
+!    to be transformed.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to DCOST1I before the first call to routine
+!    DCOST1F or DCOST1B for a given transform length N.  WSAVE's contents
+!    may be re-used for subsequent calls to DCOST1F and DCOST1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N-1.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+  real ( kind = 8 ) x(inc,*)
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'DCOST1B', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'DCOST1B', 8 )
+    return
+  end if
+
+  if ( lenwrk < n - 1 ) then
+    ier = 3
+    call xerfft ( 'DCOST1B', 10 )
+    return
+  end if
+
+  call dcostb1 ( n, inc, x, wsave, work, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'DCOST1B', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dcost1f.F b/wrfv2_fire/external/fftpack/fftpack5/dcost1f.F
new file mode 100644
index 00000000..1e1467b8
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dcost1f.F
@@ -0,0 +1,121 @@
+subroutine dcost1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! DCOST1F: real double precision forward cosine transform, 1D.
+!
+!  Discussion:
+!
+!    DCOST1F computes the one-dimensional Fourier transform of an even
+!    sequence within a real array.  This transform is referred to as the
+!    forward transform or Fourier analysis, transforming the sequence
+!    from  physical to spectral space.
+!
+!    This transform is normalized since a call to DCOST1F followed by a call
+!    to DCOST1B (or vice-versa) reproduces the original array within
+!    roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N-1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 8 ) R(LENR), containing the sequence
+!    to be transformed.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to DCOST1I before the first call to routine
+!    DCOST1F or DCOST1B for a given transform length N.  WSAVE's contents
+!    may be re-used for subsequent calls to DCOST1F and DCOST1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N-1.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+  real ( kind = 8 ) x(inc,*)
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'DCOST1F', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'DCOST1F', 8 )
+    return
+  end if
+
+  if ( lenwrk < n - 1 ) then
+    ier = 3
+    call xerfft ( 'DCOST1F', 10 )
+    return
+  end if
+
+  call dcostf1 ( n, inc, x, wsave, work, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'DCOST1F', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dcost1i.F b/wrfv2_fire/external/fftpack/fftpack5/dcost1i.F
new file mode 100644
index 00000000..f4891788
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dcost1i.F
@@ -0,0 +1,112 @@
+subroutine dcost1i ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! DCOST1I: initialization for DCOST1B and DCOST1F.
+!
+!  Discussion:
+!
+!    DCOST1I initializes array WSAVE for use in its companion routines
+!    DCOST1F and DCOST1B.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N-1 is a product
+!    of small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, dimension of WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors
+!    of N and also containing certain trigonometric values which will be used
+!    in routines DCOST1B or DCOST1F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  real ( kind = 8 ) dt
+  real ( kind = 8 ) fk
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nm1
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 8 ) pi
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'DCOST1I', 3 )
+    return
+  end if
+
+  if ( n <= 3 ) then
+    return
+  end if
+
+  nm1 = n - 1
+  np1 = n + 1
+  ns2 = n / 2
+  pi = 4.0E+00 * atan ( 1.0D+00 )
+  dt = pi / real ( nm1, kind = 8 )
+  fk = 0.0E+00
+  do k = 2, ns2
+    kc = np1 - k
+    fk = fk + 1.0D+00
+    wsave(k) = 2.0D+00 * sin ( fk * dt )
+    wsave(kc) = 2.0D+00 * cos ( fk * dt )
+  end do
+
+  lnsv = nm1 + int ( log ( real ( nm1, kind = 8 ) ) ) + 4
+
+  call dfft1i ( nm1, wsave(n+1), lnsv, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'DCOST1I', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dcostb1.F b/wrfv2_fire/external/fftpack/fftpack5/dcostb1.F
new file mode 100644
index 00000000..63f0f65e
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dcostb1.F
@@ -0,0 +1,144 @@
+subroutine dcostb1 ( n, inc, x, wsave, work, ier )
+
+!*****************************************************************************80
+!
+!! DCOSTB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  real ( kind = 8 ) dsum
+  real ( kind = 8 ) fnm1s2
+  real ( kind = 8 ) fnm1s4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nm1
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 8 ) t1
+  real ( kind = 8 ) t2
+  real ( kind = 8 ) work(*)
+  real ( kind = 8 ) wsave(*)
+  real ( kind = 8 ) x(inc,*)
+  real ( kind = 8 ) x1h
+  real ( kind = 8 ) x1p3
+  real ( kind = 8 ) x2
+  real ( kind = 8 ) xi
+
+  ier = 0
+  nm1 = n - 1
+  np1 = n + 1
+  ns2 = n / 2
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    x1h    = x(1,1) + x(1,2)
+    x(1,2) = x(1,1) - x(1,2)
+    x(1,1) = x1h
+    return
+  end if
+
+  if ( n == 3 ) then
+    x1p3 = x(1,1) + x(1,3)
+    x2 = x(1,2)
+    x(1,2) = x(1,1) - x(1,3)
+    x(1,1) = x1p3 + x2
+    x(1,3) = x1p3 - x2
+    return
+  end if
+
+  x(1,1) = x(1,1) + x(1,1)
+  x(1,n) = x(1,n) + x(1,n)
+  dsum = x(1,1) - x(1,n)
+  x(1,1) = x(1,1) + x(1,n)
+
+  do k = 2, ns2
+    kc = np1 - k
+    t1 = x(1,k) + x(1,kc)
+    t2 = x(1,k) - x(1,kc)
+    dsum = dsum + wsave(kc) * t2
+    t2 = wsave(k) * t2
+    x(1,k) = t1 - t2
+    x(1,kc) = t1 + t2
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    x(1,ns2+1) = x(1,ns2+1) + x(1,ns2+1)
+  end if
+
+  lenx = inc * ( nm1 - 1 )  + 1
+  lnsv = nm1 + int ( log ( real ( nm1, kind = 8 ) ) ) + 4
+  lnwk = nm1
+
+  call dfft1f ( nm1, inc, x, lenx, wsave(n+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'DCOSTB1', -5 )
+    return
+  end if
+
+  fnm1s2 = real ( nm1, kind = 8 ) / 2.0D+00
+  dsum = 0.5D+00 * dsum
+  x(1,1) = fnm1s2 * x(1,1)
+
+  if ( mod ( nm1, 2 ) == 0 ) then
+    x(1,nm1) = x(1,nm1) + x(1,nm1)
+  end if
+
+  fnm1s4 = real ( nm1, kind = 8 ) / 4.0D+00
+
+  do i = 3, n, 2
+    xi = fnm1s4 * x(1,i)
+    x(1,i) = fnm1s4 * x(1,i-1)
+    x(1,i-1) = dsum
+    dsum = dsum + xi
+  end do
+
+  if ( modn == 0 ) then
+    x(1,n) = dsum
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dcostf1.F b/wrfv2_fire/external/fftpack/fftpack5/dcostf1.F
new file mode 100644
index 00000000..7dc98398
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dcostf1.F
@@ -0,0 +1,140 @@
+subroutine dcostf1 ( n, inc, x, wsave, work, ier )
+
+!*****************************************************************************80
+!
+!! DCOSTF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  real ( kind = 8 ) dsum
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nm1
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 8 ) snm1
+  real ( kind = 8 ) t1
+  real ( kind = 8 ) t2
+  real ( kind = 8 ) tx2
+  real ( kind = 8 ) work(*)
+  real ( kind = 8 ) wsave(*)
+  real ( kind = 8 ) x(inc,*)
+  real ( kind = 8 ) x1h
+  real ( kind = 8 ) x1p3
+  real ( kind = 8 ) xi
+
+  ier = 0
+  nm1 = n - 1
+  np1 = n + 1
+  ns2 = n / 2
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    x1h = x(1,1) + x(1,2)
+    x(1,2) = 0.5D+00 * ( x(1,1) - x(1,2) )
+    x(1,1) = 0.5D+00 * x1h
+    return
+  end if
+
+  if ( n == 3 ) then
+    x1p3 = x(1,1) + x(1,3)
+    tx2 = x(1,2) + x(1,2)
+    x(1,2) = 0.5D+00 * ( x(1,1) - x(1,3) )
+    x(1,1) = 0.25D+00 * ( x1p3 + tx2 )
+    x(1,3) = 0.25D+00 * ( x1p3 - tx2 )
+    return
+  end if
+
+  dsum = x(1,1) - x(1,n)
+  x(1,1) = x(1,1) + x(1,n)
+  do k = 2, ns2
+    kc = np1 - k
+    t1 = x(1,k) + x(1,kc)
+    t2 = x(1,k) - x(1,kc)
+    dsum = dsum + wsave(kc) * t2
+    t2 = wsave(k) * t2
+    x(1,k) = t1 - t2
+    x(1,kc) = t1 + t2
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    x(1,ns2+1) = x(1,ns2+1) + x(1,ns2+1)
+  end if
+
+  lenx = inc * ( nm1 - 1 )  + 1
+  lnsv = nm1 + int ( log ( real ( nm1, kind = 8 ) ) ) + 4
+  lnwk = nm1
+
+  call dfft1f ( nm1, inc, x, lenx, wsave(n+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'DCOSTF1', -5 )
+    return
+  end if
+
+  snm1 = 1.0D+00 / real ( nm1, kind = 8 )
+  dsum = snm1 * dsum
+
+  if ( mod ( nm1, 2 ) == 0 ) then
+    x(1,nm1) = x(1,nm1) + x(1,nm1)
+  end if
+
+  do i = 3, n, 2
+    xi = 0.5D+00 * x(1,i)
+    x(1,i) = 0.5D+00 * x(1,i-1)
+    x(1,i-1) = dsum
+    dsum = dsum + xi
+  end do
+
+  if ( modn == 0 ) then
+    x(1,n) = dsum
+  end if
+
+  x(1,1) = 0.5D+00 * x(1,1)
+  x(1,n) = 0.5D+00 * x(1,n)
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dfft1b.F b/wrfv2_fire/external/fftpack/fftpack5/dfft1b.F
new file mode 100644
index 00000000..ec88b1ab
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dfft1b.F
@@ -0,0 +1,119 @@
+subroutine dfft1b ( n, inc, r, lenr, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! DFFT1B: real double precision backward fast Fourier transform, 1D.
+!
+!  Discussion:
+!
+!    DFFT1B computes the one-dimensional Fourier transform of a periodic
+!    sequence within a real array.  This is referred to as the backward
+!    transform or Fourier synthesis, transforming the sequence from
+!    spectral to physical space.  This transform is normalized since a
+!    call to DFFT1B followed by a call to DFFT1F (or vice-versa) reproduces
+!    the original array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    16 November 2007
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 8 ) R(LENR), on input, the data to be
+!    transformed, and on output, the transformed data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1) + 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to DFFT1I before the first call to routine
+!    DFFT1F or DFFT1B for a given transform length N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenr
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) r(lenr)
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lenr < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'rfft1b ', 6 )
+    return
+  end if
+
+  if ( lensav < n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'DFFT1B ', 8 )
+    return
+  end if
+
+  if ( lenwrk < n ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'DFFT1B - Fatal error!'
+    write ( *, '(a)' ) '  LENWRK < N:'
+    write ( *, '(a,i6)' ) '  LENWRK = ', lenwrk
+    write ( *, '(a,i6)' ) '  N = ', n
+    ier = 3
+    call xerfft ( 'DFFT1B ', 10 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  call dfftb1 ( n, inc, r, work, wsave, wsave(n+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dfft1f.F b/wrfv2_fire/external/fftpack/fftpack5/dfft1f.F
new file mode 100644
index 00000000..30541b05
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dfft1f.F
@@ -0,0 +1,114 @@
+subroutine dfft1f ( n, inc, r, lenr, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! DFFT1F: real double precision forward fast Fourier transform, 1D.
+!
+!  Discussion:
+!
+!    DFFT1F computes the one-dimensional Fourier transform of a periodic
+!    sequence within a real array.  This is referred to as the forward
+!    transform or Fourier analysis, transforming the sequence from physical
+!    to spectral space.  This transform is normalized since a call to
+!    DFFT1F followed by a call to DFFT1B (or vice-versa) reproduces the
+!    original array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 8 ) R(LENR), on input, contains the sequence
+!    to be transformed, and on output, the transformed data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1) + 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to DFFT1I before the first call to routine DFFT1F
+!    or DFFT1B for a given transform length N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR not big enough:
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenr
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+  real ( kind = 8 ) r(lenr)
+
+  ier = 0
+
+  if ( lenr < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'DFFT1F', 6 )
+    return
+  end if
+
+  if ( lensav < n + int ( log ( real ( n, kind = 8  ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'DFFT1F', 8 )
+    return
+  end if
+
+  if ( lenwrk < n ) then
+    ier = 3
+    call xerfft ( 'DFFT1F', 10 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  call dfftf1 ( n, inc, r, work, wsave, wsave(n+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dfft1i.F b/wrfv2_fire/external/fftpack/fftpack5/dfft1i.F
new file mode 100644
index 00000000..f9ad8b47
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dfft1i.F
@@ -0,0 +1,80 @@
+subroutine dfft1i ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! DFFT1I: initialization for DFFT1B and DFFT1F.
+!
+!  Discussion:
+!
+!    DFFT1I initializes array WSAVE for use in its companion routines
+!    DFFT1B and DFFT1F.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors
+!    of N and also containing certain trigonometric values which will be used
+!    in routines DFFT1B or DFFT1F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'DFFT1I ', 3 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  call dffti1 ( n, wsave(1), wsave(n+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dfftb1.F b/wrfv2_fire/external/fftpack/fftpack5/dfftb1.F
new file mode 100644
index 00000000..1aedd6e6
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dfftb1.F
@@ -0,0 +1,183 @@
+subroutine dfftb1 ( n, in, c, ch, wa, fac )
+
+!*****************************************************************************80
+!
+!! DFFTB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) in
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) c(in,*)
+  real ( kind = 8 ) ch(*)
+  real ( kind = 8 ) fac(15)
+  real ( kind = 8 ) half
+  real ( kind = 8 ) halfm
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) ix2
+  integer ( kind = 4 ) ix3
+  integer ( kind = 4 ) ix4
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nf
+  integer ( kind = 4 ) nl
+  real ( kind = 8 ) wa(n)
+
+  nf = int ( fac(2) )
+  na = 0
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1+2) )
+    na = 1 - na
+
+    if ( 5 < ip ) then
+      if ( k1 /= nf ) then
+        na = 1 - na
+      end if
+    end if
+
+  end do
+
+  half = 0.5D+00
+  halfm = -0.5D+00
+  modn = mod ( n, 2 )
+  nl = n - 2
+  if ( modn /= 0 ) then
+    nl = n - 1
+  end if
+
+  if ( na == 0 ) then
+
+    do j = 2, nl, 2
+      c(1,j) = half * c(1,j)
+      c(1,j+1) = halfm * c(1,j+1)
+    end do
+
+  else
+
+    ch(1) = c(1,1)
+    ch(n) = c(1,n)
+
+    do j = 2, nl, 2
+      ch(j) = half * c(1,j)
+      ch(j+1) = halfm * c(1,j+1)
+    end do
+
+  end if
+
+  l1 = 1
+  iw = 1
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1+2) )
+    l2 = ip * l1
+    ido = n / l2
+    idl1 = ido * l1
+
+    if ( ip == 4 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+
+      if ( na == 0 ) then
+        call d1f4kb ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2), wa(ix3) )
+      else
+        call d1f4kb ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2), wa(ix3) )
+      end if
+
+      na = 1 - na
+
+    else if ( ip == 2 ) then
+
+      if ( na == 0 ) then
+        call d1f2kb ( ido, l1, c, in, ch, 1, wa(iw) )
+      else
+        call d1f2kb ( ido, l1, ch, 1, c, in, wa(iw) )
+      end if
+
+      na = 1 - na
+
+    else if ( ip == 3 ) then
+
+      ix2 = iw + ido
+
+      if ( na == 0 ) then
+        call d1f3kb ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2) )
+      else
+        call d1f3kb ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2) )
+      end if
+
+      na = 1 - na
+
+    else if ( ip == 5 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+      ix4 = ix3 + ido
+
+      if ( na == 0 ) then
+        call d1f5kb ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
+      else
+        call d1f5kb ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
+      end if
+
+      na = 1 - na
+
+    else
+
+      if ( na == 0 ) then
+        call d1fgkb ( ido, ip, l1, idl1, c, c, c, in, ch, ch, 1, wa(iw) )
+      else
+        call d1fgkb ( ido, ip, l1, idl1, ch, ch, ch, 1, c, c, in, wa(iw) )
+      end if
+
+      if ( ido == 1 ) then
+        na = 1 - na
+      end if
+
+    end if
+
+    l1 = l2
+    iw = iw + ( ip - 1 ) * ido
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dfftf1.F b/wrfv2_fire/external/fftpack/fftpack5/dfftf1.F
new file mode 100644
index 00000000..41c51e50
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dfftf1.F
@@ -0,0 +1,177 @@
+subroutine dfftf1 ( n, in, c, ch, wa, fac )
+
+!*****************************************************************************80
+!
+!! DFFTF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) in
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) c(in,*)
+  real ( kind = 8 ) ch(*)
+  real ( kind = 8 ) fac(15)
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) ix2
+  integer ( kind = 4 ) ix3
+  integer ( kind = 4 ) ix4
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) kh
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nf
+  integer ( kind = 4 ) nl
+  real ( kind = 8 ) sn
+  real ( kind = 8 ) tsn
+  real ( kind = 8 ) tsnm
+  real ( kind = 8 ) wa(n)
+
+  nf = int ( fac(2) )
+  na = 1
+  l2 = n
+  iw = n
+
+  do k1 = 1, nf
+
+    kh = nf - k1
+    ip = int ( fac(kh+3) )
+    l1 = l2 / ip
+    ido = n / l2
+    idl1 = ido * l1
+    iw = iw - ( ip - 1 ) * ido
+    na = 1 - na
+
+    if ( ip == 4 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+
+      if ( na == 0 ) then
+        call d1f4kf ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2), wa(ix3) )
+      else
+        call d1f4kf ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2), wa(ix3) )
+      end if
+
+    else if ( ip == 2 ) then
+
+      if ( na == 0 ) then
+        call d1f2kf ( ido, l1, c, in, ch, 1, wa(iw) )
+      else
+        call d1f2kf ( ido, l1, ch, 1, c, in, wa(iw) )
+      end if
+
+    else if ( ip == 3 ) then
+
+      ix2 = iw + ido
+
+      if ( na == 0 ) then
+        call d1f3kf ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2) )
+      else
+        call d1f3kf ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2) )
+      end if
+
+    else if ( ip == 5 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+      ix4 = ix3 + ido
+
+      if ( na == 0 ) then
+        call d1f5kf ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
+      else
+        call d1f5kf ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
+      end if
+
+    else
+
+      if ( ido == 1 ) then
+        na = 1 - na
+      end if
+
+      if ( na == 0 ) then
+        call d1fgkf ( ido, ip, l1, idl1, c, c, c, in, ch, ch, 1, wa(iw) )
+        na = 1
+      else
+        call d1fgkf ( ido, ip, l1, idl1, ch, ch, ch, 1, c, c, in, wa(iw) )
+        na = 0
+      end if
+
+    end if
+
+    l2 = l1
+
+  end do
+
+  sn = 1.0D+00 / real ( n, kind = 8 )
+  tsn = 2.0D+00 / real ( n, kind = 8 )
+  tsnm = - tsn
+  modn = mod ( n, 2 )
+  nl = n - 2
+
+  if ( modn /= 0 ) then
+    nl = n - 1
+  end if
+
+  if ( na == 0 ) then
+
+    c(1,1) = sn * ch(1)
+    do j = 2, nl, 2
+      c(1,j) = tsn * ch(j)
+      c(1,j+1) = tsnm * ch(j+1)
+    end do
+
+    if ( modn == 0 ) then
+      c(1,n) = sn * ch(n)
+    end if
+
+  else
+
+    c(1,1) = sn * c(1,1)
+
+    do j = 2, nl, 2
+      c(1,j) = tsn * c(1,j)
+      c(1,j+1) = tsnm * c(1,j+1)
+    end do
+
+    if ( modn == 0 ) then
+      c(1,n) = sn * c(1,n)
+    end if
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dffti1.F b/wrfv2_fire/external/fftpack/fftpack5/dffti1.F
new file mode 100644
index 00000000..744b92cc
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dffti1.F
@@ -0,0 +1,154 @@
+subroutine dffti1 ( n, wa, fac )
+
+!*****************************************************************************80
+!
+!! DFFTI1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the number for which factorization and
+!    other information is needed.
+!
+!    Output, real ( kind = 8 ) WA(N), trigonometric information.
+!
+!    Output, real ( kind = 8 ) FAC(15), factorization information.
+!    FAC(1) is N, FAC(2) is NF, the number of factors, and FAC(3:NF+2) are the
+!    factors.
+!
+  implicit none
+
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) arg
+  real ( kind = 8 ) argh
+  real ( kind = 8 ) argld
+  real ( kind = 8 ) fac(15)
+  real ( kind = 8 ) fi
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ib
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) ii
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) ipm
+  integer ( kind = 4 ) is
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) ld
+  integer ( kind = 4 ) nf
+  integer ( kind = 4 ) nfm1
+  integer ( kind = 4 ) nl
+  integer ( kind = 4 ) nq
+  integer ( kind = 4 ) nr
+  integer ( kind = 4 ) ntry
+  real ( kind = 8 ) tpi
+  real ( kind = 8 ) wa(n)
+
+  nl = n
+  nf = 0
+  j = 0
+
+  do while ( 1 < nl )
+
+    j = j + 1
+
+    if ( j == 1 ) then
+      ntry = 4
+    else if ( j == 2 ) then
+      ntry = 2
+    else if ( j == 3 ) then
+      ntry = 3
+    else if ( j == 4 ) then
+      ntry = 5
+    else
+      ntry = ntry + 2
+    end if
+
+    do
+
+      nq = nl / ntry
+      nr = nl - ntry * nq
+
+      if ( nr /= 0 ) then
+        exit
+      end if
+
+      nf = nf + 1
+      fac(nf+2) = real ( ntry, kind = 8 )
+      nl = nq
+!
+!  If 2 is a factor, make sure it appears first in the list of factors.
+!
+      if ( ntry == 2 ) then
+        if ( nf /= 1 ) then
+          do i = 2, nf
+            ib = nf - i + 2
+            fac(ib+2) = fac(ib+1)
+          end do
+          fac(3) = 2.0D+00
+        end if
+      end if
+
+    end do
+
+  end do
+
+  fac(1) = real ( n, kind = 8 )
+  fac(2) = real ( nf, kind = 8 )
+  tpi = 8.0D+00 * atan ( 1.0D+00 )
+  argh = tpi / real ( n, kind = 8 )
+  is = 0
+  nfm1 = nf - 1
+  l1 = 1
+
+  do k1 = 1, nfm1
+    ip = int ( fac(k1+2) )
+    ld = 0
+    l2 = l1 * ip
+    ido = n / l2
+    ipm = ip - 1
+    do j = 1, ipm
+      ld = ld + l1
+      i = is
+      argld = real ( ld, kind = 8 ) * argh
+      fi = 0.0D+00
+      do ii = 3, ido, 2
+        i = i + 2
+        fi = fi + 1.0D+00
+        arg = fi * argld
+        wa(i-1) = real ( cos ( arg ), kind = 8 )
+        wa(i) = real ( sin ( arg ), kind = 8 )
+      end do
+      is = is + ido
+    end do
+    l1 = l2
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dsint1b.F b/wrfv2_fire/external/fftpack/fftpack5/dsint1b.F
new file mode 100644
index 00000000..262f1fa3
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dsint1b.F
@@ -0,0 +1,121 @@
+subroutine dsint1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! DSINT1B: real double precision backward sine transform, 1D.
+!
+!  Discussion:
+!
+!    DSINT1B computes the one-dimensional Fourier transform of an odd
+!    sequence within a real array.  This transform is referred to as
+!    the backward transform or Fourier synthesis, transforming the
+!    sequence from spectral to physical space.
+!
+!    This transform is normalized since a call to DSINT1B followed
+!    by a call to DSINT1F (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N+1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 8 ) R(LENR), on input, contains the
+!    sequence to be transformed, and on output, the transformed sequence.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to DSINT1I before the first call to routine
+!    SINT1F or SINT1B for a given transform length N.  WSAVE's contents
+!    may be re-used for subsequent calls to DSINT1F and DSINT1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*N+2.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+  real ( kind = 8 ) x(inc,*)
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'DSINT1B', 6 )
+    return
+  end if
+
+  if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'DSINT1B', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * n + 2 ) then
+    ier = 3
+    call xerfft ( 'DSINT1B', 10 )
+    return
+  end if
+
+  call dsintb1 ( n, inc, x, wsave, work, work(n+2), ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'DSINT1B', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dsint1f.F b/wrfv2_fire/external/fftpack/fftpack5/dsint1f.F
new file mode 100644
index 00000000..a9ea011a
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dsint1f.F
@@ -0,0 +1,121 @@
+subroutine dsint1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! DSINT1F: real double precision forward sine transform, 1D.
+!
+!  Discussion:
+!
+!    DSINT1F computes the one-dimensional Fourier transform of an odd
+!    sequence within a real array.  This transform is referred to as the
+!    forward transform or Fourier analysis, transforming the sequence
+!    from physical to spectral space.
+!
+!    This transform is normalized since a call to DSINT1F followed
+!    by a call to DSINT1B (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N+1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 8 ) R(LENR), on input, contains the sequence
+!    to be transformed, and on output, the transformed sequence.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to DSINT1I before the first call to routine
+!    DSINT1F or DSINT1B for a given transform length N.  WSAVE's contents
+!    may be re-used for subsequent calls to DSINT1F and DSINT1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*N+2.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+  real ( kind = 8 ) x(inc,*)
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'DSINT1F', 6 )
+    return
+  end if
+
+  if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'DSINT1F', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * n + 2 ) then
+    ier = 3
+    call xerfft ( 'DSINT1F', 10 )
+    return
+  end if
+
+  call dsintf1 ( n, inc, x, wsave, work, work(n+2), ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'DSINT1F', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dsint1i.F b/wrfv2_fire/external/fftpack/fftpack5/dsint1i.F
new file mode 100644
index 00000000..f6010758
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dsint1i.F
@@ -0,0 +1,106 @@
+subroutine dsint1i ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! DSINT1I: initialization for DSINT1B and DSINT1F.
+!
+!  Discussion:
+!
+!    DSINT1I initializes array WSAVE for use in its companion routines
+!    DSINT1F and DSINT1B.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    07 February 2006
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N+1 is a product
+!    of small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors
+!    of N and also containing certain trigonometric values which will be used
+!    in routines DSINT1B or DSINT1F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  real ( kind = 8 ) dt
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 8 ) pi
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'DSINT1I', 3 )
+    return
+  end if
+
+  pi = 4.0D+00 * atan ( 1.0D+00 )
+
+  if ( n <= 1 ) then
+    return
+  end if
+
+  ns2 = n / 2
+  np1 = n + 1
+  dt = pi / real ( np1, kind = 8 )
+
+  do k = 1, ns2
+    wsave(k) = 2.0D+00 * sin ( real ( k, kind = 8 ) * dt )
+  end do
+
+  lnsv = np1 + int ( log ( real ( np1, kind = 8  ) ) ) + 4
+
+  call dfft1i ( np1, wsave(ns2+1), lnsv, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'DSINT1I', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dsintb1.F b/wrfv2_fire/external/fftpack/fftpack5/dsintb1.F
new file mode 100644
index 00000000..a2b1c9b1
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dsintb1.F
@@ -0,0 +1,124 @@
+subroutine dsintb1 ( n, inc, x, wsave, xh, work, ier )
+
+!*****************************************************************************80
+!
+!! DSINTB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  real ( kind = 8 ) dsum
+  real ( kind = 8 ) fnp1s4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) lnxh
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 8 ) srt3s2
+  real ( kind = 8 ) t1
+  real ( kind = 8 ) t2
+  real ( kind = 8 ) work(*)
+  real ( kind = 8 ) wsave(*)
+  real ( kind = 8 ) x(inc,*)
+  real ( kind = 8 ) xh(*)
+  real ( kind = 8 ) xhold
+
+  ier = 0
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    srt3s2 = sqrt ( 3.0D+00 ) / 2.0D+00
+    xhold = srt3s2 * ( x(1,1) + x(1,2) )
+    x(1,2) = srt3s2 * ( x(1,1) - x(1,2) )
+    x(1,1) = xhold
+    return
+  end if
+
+  np1 = n + 1
+  ns2 = n / 2
+
+  do k = 1, ns2
+    kc = np1 - k
+    t1 = x(1,k) - x(1,kc)
+    t2 = wsave(k) * ( x(1,k) + x(1,kc) )
+    xh(k+1) = t1 + t2
+    xh(kc+1) = t2 - t1
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    xh(ns2+2) = 4.0D+00 * x(1,ns2+1)
+  end if
+
+  xh(1) = 0.0D+00
+  lnxh = np1
+  lnsv = np1 + int ( log ( real ( np1, kind = 8 ) ) ) + 4
+  lnwk = np1
+
+  call dfft1f ( np1, 1, xh, lnxh, wsave(ns2+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'DSINTB1', -5 )
+    return
+  end if
+
+  if ( mod ( np1, 2 ) == 0 ) then
+    xh(np1) = xh(np1) + xh(np1)
+  end if
+
+  fnp1s4 = real ( np1, kind = 8 ) / 4.0D+00
+  x(1,1) = fnp1s4 * xh(1)
+  dsum = x(1,1)
+
+  do i = 3, n, 2
+    x(1,i-1) = fnp1s4 * xh(i)
+    dsum = dsum + fnp1s4 * xh(i-1)
+    x(1,i) = dsum
+  end do
+
+  if ( modn == 0 ) then
+    x(1,n) = fnp1s4 * xh(n+1)
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/dsintf1.F b/wrfv2_fire/external/fftpack/fftpack5/dsintf1.F
new file mode 100644
index 00000000..921e561f
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/dsintf1.F
@@ -0,0 +1,124 @@
+subroutine dsintf1 ( n, inc, x, wsave, xh, work, ier )
+
+!*****************************************************************************80
+!
+!! DSINTF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Original real single precision by Paul Swarztrauber, Richard Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  real ( kind = 8 ) dsum
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) lnxh
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 8 ) sfnp1
+  real ( kind = 8 ) ssqrt3
+  real ( kind = 8 ) t1
+  real ( kind = 8 ) t2
+  real ( kind = 8 ) work(*)
+  real ( kind = 8 ) wsave(*)
+  real ( kind = 8 ) x(inc,*)
+  real ( kind = 8 ) xh(*)
+  real ( kind = 8 ) xhold
+
+  ier = 0
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    ssqrt3 = 1.0D+00 / sqrt ( 3.0D+00 )
+    xhold = ssqrt3 * ( x(1,1) + x(1,2) )
+    x(1,2) = ssqrt3 * ( x(1,1) - x(1,2) )
+    x(1,1) = xhold
+    return
+  end if
+
+  np1 = n + 1
+  ns2 = n / 2
+
+  do k = 1, ns2
+    kc = np1 - k
+    t1 = x(1,k) - x(1,kc)
+    t2 = wsave(k) * ( x(1,k) + x(1,kc) )
+    xh(k+1) = t1 + t2
+    xh(kc+1) = t2 - t1
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    xh(ns2+2) = 4.0D+00 * x(1,ns2+1)
+  end if
+
+  xh(1) = 0.0D+00
+  lnxh = np1
+  lnsv = np1 + int ( log ( real ( np1, kind = 8 ) ) ) + 4
+  lnwk = np1
+
+  call dfft1f ( np1, 1, xh, lnxh, wsave(ns2+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'DSINTF1', -5 )
+    return
+  end if
+
+  if ( mod ( np1, 2 ) == 0 ) then
+    xh(np1) = xh(np1) + xh(np1)
+  end if
+
+  sfnp1 = 1.0D+00 / real ( np1, kind = 8 )
+  x(1,1) = 0.5D+00 * xh(1)
+  dsum = x(1,1)
+
+  do i = 3, n, 2
+    x(1,i-1) = 0.5D+00 * xh(i)
+    dsum = dsum + 0.5D+00 * xh(i-1)
+    x(1,i) = dsum
+  end do
+
+  if ( modn == 0 ) then
+    x(1,n) = 0.5D+00 * xh(n+1)
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mcsqb1.F b/wrfv2_fire/external/fftpack/fftpack5/mcsqb1.F
index e2c808fa..bf045a87 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mcsqb1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mcsqb1.F
@@ -1,71 +1,130 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mcsqb1.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MCSQB1 (LOT,JUMP,N,INC,X,WSAVE,WORK,IER) 
-      DIMENSION       X(INC,*)     ,WSAVE(*)     ,WORK(LOT,*) 
-      IER = 0 
-      LJ = (LOT-1)*JUMP+1 
-      NS2 = (N+1)/2 
-      NP2 = N+2 
-      DO 101 I=3,N,2 
-         DO 201 M=1,LJ,JUMP 
-         XIM1 = X(M,I-1)+X(M,I) 
-         X(M,I) = .5*(X(M,I-1)-X(M,I)) 
-         X(M,I-1) = .5*XIM1 
-  201    CONTINUE 
-  101 END DO 
-      DO 301 M=1,LJ,JUMP 
-      X(M,1) = .5*X(M,1) 
-  301 END DO 
-      MODN = MOD(N,2) 
-      IF (MODN .NE. 0) GO TO 302 
-      DO 303 M=1,LJ,JUMP 
-      X(M,N) = .5*X(M,N) 
-  303 END DO 
-  302 CONTINUE 
-      LENX = (LOT-1)*JUMP + INC*(N-1)  + 1 
-      LNSV = N + INT(LOG(REAL(N))) + 4 
-      LNWK = LOT*N 
-!                                                                       
-      CALL RFFTMB(LOT,JUMP,N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('MCSQB1',-5) 
-        GO TO 400 
-      ENDIF 
-!                                                                       
-      DO 102 K=2,NS2 
-         KC = NP2-K 
-         M1 = 0 
-         DO 202 M=1,LJ,JUMP 
-         M1 = M1 + 1 
-         WORK(M1,K) = WSAVE(K-1)*X(M,KC)+WSAVE(KC-1)*X(M,K) 
-         WORK(M1,KC) = WSAVE(K-1)*X(M,K)-WSAVE(KC-1)*X(M,KC) 
-  202    CONTINUE 
-  102 END DO 
-      IF (MODN .NE. 0) GO TO 305 
-      DO 304 M=1,LJ,JUMP 
-         X(M,NS2+1) = WSAVE(NS2)*(X(M,NS2+1)+X(M,NS2+1)) 
-  304    CONTINUE 
-  305 DO 103 K=2,NS2 
-         KC = NP2-K 
-         M1 = 0 
-         DO 203 M=1,LJ,JUMP 
-            M1 = M1 + 1 
-            X(M,K) = WORK(M1,K)+WORK(M1,KC) 
-            X(M,KC) = WORK(M1,K)-WORK(M1,KC) 
-  203    CONTINUE 
-  103 END DO 
-      DO 104 M=1,LJ,JUMP 
-      X(M,1) = X(M,1)+X(M,1) 
-  104 END DO 
-  400 CONTINUE 
-      RETURN 
-      END                                           
+subroutine mcsqb1 ( lot, jump, n, inc, x, wsave, work, ier )
+
+!*****************************************************************************80
+!
+!! MCSQB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lot
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lj
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np2
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) work(lot,*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) xim1
+
+  ier = 0
+  lj = ( lot - 1 ) * jump + 1
+  ns2 = ( n + 1 ) / 2
+  np2 = n + 2
+
+  do i = 3, n, 2
+    do m = 1, lj, jump
+      xim1 = x(m,i-1) + x(m,i)
+      x(m,i) = 0.5E+00 * ( x(m,i-1) - x(m,i) )
+      x(m,i-1) = 0.5E+00 * xim1
+    end do
+  end do
+
+  do m = 1, lj, jump
+    x(m,1) = 0.5E+00 * x(m,1)
+  end do
+
+  modn = mod ( n, 2 )
+  if ( modn == 0 ) then
+    do m = 1, lj, jump
+      x(m,n) = 0.5E+00 * x(m,n)
+    end do
+  end if
+
+  lenx = ( lot - 1 ) * jump + inc * ( n - 1 )  + 1
+  lnsv = n + int ( log ( real ( n, kind = 4 ) ) ) + 4
+  lnwk = lot * n
+
+  call rfftmb ( lot, jump, n, inc, x, lenx, wsave(n+1), lnsv, &
+    work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'mcsqb1', -5 )
+    return
+  end if
+
+  do k = 2, ns2
+    kc = np2 - k
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      work(m1,k) = wsave(k-1) * x(m,kc) + wsave(kc-1) * x(m,k)
+      work(m1,kc) = wsave(k-1) * x(m,k) - wsave(kc-1) * x(m,kc)
+    end do
+  end do
+
+  if ( modn == 0 ) then
+    do m = 1, lj, jump
+      x(m,ns2+1) = wsave(ns2) * ( x(m,ns2+1) + x(m,ns2+1) )
+    end do
+  end if
+
+  do k = 2, ns2
+    kc = np2 - k
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      x(m,k) = work(m1,k) + work(m1,kc)
+      x(m,kc) = work(m1,k) - work(m1,kc)
+    end do
+  end do
+
+  do m = 1, lj, jump
+    x(m,1) = x(m,1) + x(m,1)
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mcsqf1.F b/wrfv2_fire/external/fftpack/fftpack5/mcsqf1.F
index 6cbf402a..929690fa 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mcsqf1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mcsqf1.F
@@ -1,69 +1,126 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mcsqf1.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MCSQF1 (LOT,JUMP,N,INC,X,WSAVE,WORK,IER) 
-      DIMENSION       X(INC,*)      ,WSAVE(*)      ,WORK(LOT,*) 
-      IER = 0 
-      LJ = (LOT-1)*JUMP+1 
-      NS2 = (N+1)/2 
-      NP2 = N+2 
-      DO 101 K=2,NS2 
-         KC = NP2-K 
-         M1 = 0 
-         DO 201 M=1,LJ,JUMP 
-         M1 = M1 + 1 
-         WORK(M1,K)  = X(M,K)+X(M,KC) 
-         WORK(M1,KC) = X(M,K)-X(M,KC) 
-  201    CONTINUE 
-  101 END DO 
-      MODN = MOD(N,2) 
-      IF (MODN .NE. 0) GO TO 301 
-         M1 = 0 
-         DO 202 M=1,LJ,JUMP 
-         M1 = M1 + 1 
-         WORK(M1,NS2+1) = X(M,NS2+1)+X(M,NS2+1) 
-  202    CONTINUE 
-  301    DO 102 K=2,NS2 
-         KC = NP2-K 
-         M1 = 0 
-         DO 302 M=1,LJ,JUMP 
-         M1 = M1 + 1 
-         X(M,K)  = WSAVE(K-1)*WORK(M1,KC)+WSAVE(KC-1)*WORK(M1,K) 
-         X(M,KC) = WSAVE(K-1)*WORK(M1,K) -WSAVE(KC-1)*WORK(M1,KC) 
-  302    CONTINUE 
-  102 END DO 
-      IF (MODN .NE. 0) GO TO 303 
-      M1 = 0 
-      DO 304 M=1,LJ,JUMP 
-         M1 = M1 + 1 
-         X(M,NS2+1) = WSAVE(NS2)*WORK(M1,NS2+1) 
-  304 END DO 
-  303 CONTINUE 
-      LENX = (LOT-1)*JUMP + INC*(N-1)  + 1 
-      LNSV = N + INT(LOG(REAL(N))) + 4 
-      LNWK = LOT*N 
-!                                                                       
-      CALL RFFTMF(LOT,JUMP,N,INC,X,LENX,WSAVE(N+1),LNSV,WORK,LNWK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('MCSQF1',-5) 
-        GO TO 400 
-      ENDIF 
-!                                                                       
-      DO 103 I=3,N,2 
-         DO 203 M=1,LJ,JUMP 
-            XIM1 = .5*(X(M,I-1)+X(M,I)) 
-            X(M,I) = .5*(X(M,I-1)-X(M,I)) 
-            X(M,I-1) = XIM1 
-  203    CONTINUE 
-  103 END DO 
-  400 CONTINUE 
-      RETURN 
-      END                                           
+subroutine mcsqf1 ( lot, jump, n, inc, x, wsave, work, ier )
+
+!*****************************************************************************80
+!
+!! MCSQF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lot
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) lj
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np2
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) work(lot,*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) xim1
+
+  ier = 0
+  lj = ( lot - 1 ) * jump + 1
+  ns2 = ( n + 1 ) / 2
+  np2 = n + 2
+
+  do k = 2, ns2
+    kc = np2 - k
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      work(m1,k)  = x(m,k) + x(m,kc)
+      work(m1,kc) = x(m,k) - x(m,kc)
+    end do
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn == 0 ) then
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      work(m1,ns2+1) = x(m,ns2+1) + x(m,ns2+1)
+    end do
+  end if
+
+  do k = 2, ns2
+    kc = np2 - k
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      x(m,k)  = wsave(k-1) * work(m1,kc) + wsave(kc-1) * work(m1,k)
+      x(m,kc) = wsave(k-1) * work(m1,k)  - wsave(kc-1) * work(m1,kc)
+    end do
+  end do
+
+  if ( modn == 0 ) then
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      x(m,ns2+1) = wsave(ns2) * work(m1,ns2+1)
+    end do
+  end if
+
+  lenx = ( lot - 1 ) * jump + inc * ( n - 1 ) + 1
+  lnsv = n + int ( log ( real ( n, kind = 4 ) ) ) + 4
+  lnwk = lot * n
+
+  call rfftmf ( lot, jump, n, inc, x, lenx, wsave(n+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'mcsqf1', -5 )
+    return
+  end if
+
+  do i = 3, n, 2
+    do m = 1, lj, jump
+      xim1 = 0.5E+00 * ( x(m,i-1) + x(m,i) )
+      x(m,i) = 0.5E+00 * ( x(m,i-1) - x(m,i) )
+      x(m,i-1) = xim1
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mcstb1.F b/wrfv2_fire/external/fftpack/fftpack5/mcstb1.F
index 82edd497..0fffddf5 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mcstb1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mcstb1.F
@@ -1,106 +1,188 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mcstb1.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MCSTB1(LOT,JUMP,N,INC,X,WSAVE,DSUM,WORK,IER) 
-      REAL       X(INC,*)       ,WSAVE(*) 
-      DOUBLE PRECISION           DSUM(*) 
-      IER = 0 
-      NM1 = N-1 
-      NP1 = N+1 
-      NS2 = N/2 
-      LJ = (LOT-1)*JUMP+1 
-      IF (N-2) 106,101,102 
-  101 DO 111 M=1,LJ,JUMP 
-         X1H = X(M,1)+X(M,2) 
-         X(M,2) = X(M,1)-X(M,2) 
-         X(M,1) = X1H 
-  111 END DO 
-      RETURN 
-  102 IF (N .GT. 3) GO TO 103 
-      DO 112 M=1,LJ,JUMP 
-         X1P3 = X(M,1)+X(M,3) 
-         X2 = X(M,2) 
-         X(M,2) = X(M,1)-X(M,3) 
-         X(M,1) = X1P3+X2 
-         X(M,3) = X1P3-X2 
-  112 END DO 
-      RETURN 
-  103 DO 118 M=1,LJ,JUMP 
-      X(M,1) = X(M,1)+X(M,1) 
-      X(M,N) = X(M,N)+X(M,N) 
-  118 END DO 
-      M1 = 0 
-      DO 113 M=1,LJ,JUMP 
-         M1 = M1+1 
-         DSUM(M1) = X(M,1)-X(M,N) 
-         X(M,1) = X(M,1)+X(M,N) 
-  113 END DO 
-      DO 104 K=2,NS2 
-         M1 = 0 
-         DO 114 M=1,LJ,JUMP 
-         M1 = M1+1 
-         KC = NP1-K 
-         T1 = X(M,K)+X(M,KC) 
-         T2 = X(M,K)-X(M,KC) 
-         DSUM(M1) = DSUM(M1)+WSAVE(KC)*T2 
-         T2 = WSAVE(K)*T2 
-         X(M,K) = T1-T2 
-         X(M,KC) = T1+T2 
-  114    CONTINUE 
-  104 END DO 
-      MODN = MOD(N,2) 
-      IF (MODN .EQ. 0) GO TO 124 
-         DO 123 M=1,LJ,JUMP 
-         X(M,NS2+1) = X(M,NS2+1)+X(M,NS2+1) 
-  123    CONTINUE 
-  124 CONTINUE 
-      LENX = (LOT-1)*JUMP + INC*(NM1-1)  + 1 
-      LNSV = NM1 + INT(LOG(REAL(NM1))) + 4 
-      LNWK = LOT*NM1 
-!                                                                       
-      CALL RFFTMF(LOT,JUMP,NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,         &
-     &            LNWK,IER1)                                            
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('MCSTB1',-5) 
-        GO TO 106 
-      ENDIF 
-!                                                                       
-      FNM1S2 = FLOAT(NM1)/2. 
-      M1 = 0 
-      DO 10 M=1,LJ,JUMP 
-      M1 = M1+1 
-      DSUM(M1) = .5*DSUM(M1) 
-      X(M,1) = FNM1S2*X(M,1) 
-   10 END DO 
-      IF(MOD(NM1,2) .NE. 0) GO TO 30 
-      DO 20 M=1,LJ,JUMP 
-      X(M,NM1) = X(M,NM1)+X(M,NM1) 
-   20 END DO 
-   30 FNM1S4 = FLOAT(NM1)/4. 
-      DO 105 I=3,N,2 
-         M1 = 0 
-         DO 115 M=1,LJ,JUMP 
-            M1 = M1+1 
-            XI = FNM1S4*X(M,I) 
-            X(M,I) = FNM1S4*X(M,I-1) 
-            X(M,I-1) = DSUM(M1) 
-            DSUM(M1) = DSUM(M1)+XI 
-  115 END DO 
-  105 END DO 
-      IF (MODN .NE. 0) RETURN 
-      M1 = 0 
-      DO 116 M=1,LJ,JUMP 
-         M1 = M1+1 
-         X(M,N) = DSUM(M1) 
-  116 END DO 
-  106 CONTINUE 
-      RETURN 
-      END                                           
+subroutine mcstb1 ( lot, jump, n, inc, x, wsave, dsum, work, ier )
+
+!*****************************************************************************80
+!
+!! MCSTB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  real ( kind = 8 ) dsum(*)
+  real ( kind = 4 ) fnm1s2
+  real ( kind = 4 ) fnm1s4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lj
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nm1
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) t1
+  real ( kind = 4 ) t2
+  real ( kind = 4 ) work(*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) x1h
+  real ( kind = 4 ) x1p3
+  real ( kind = 4 ) x2
+  real ( kind = 4 ) xi
+
+  ier = 0
+  nm1 = n - 1
+  np1 = n + 1
+  ns2 = n / 2
+  lj = ( lot - 1 ) * jump + 1
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    do m = 1, lj, jump
+      x1h = x(m,1) + x(m,2)
+      x(m,2) = x(m,1) - x(m,2)
+      x(m,1) = x1h
+    end do
+    return
+  end if
+
+  if ( n == 3 ) then
+
+    do m = 1, lj, jump
+      x1p3 = x(m,1) + x(m,3)
+      x2 = x(m,2)
+      x(m,2) = x(m,1) - x(m,3)
+      x(m,1) = x1p3 + x2
+      x(m,3) = x1p3 - x2
+    end do
+
+    return
+  end if
+
+  do m = 1, lj, jump
+    x(m,1) = x(m,1) + x(m,1)
+    x(m,n) = x(m,n) + x(m,n)
+  end do
+
+  m1 = 0
+  do m = 1, lj, jump
+    m1 = m1 + 1
+    dsum(m1) = x(m,1) - x(m,n)
+    x(m,1) = x(m,1) + x(m,n)
+  end do
+
+  do k = 2, ns2
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      kc = np1 - k
+      t1 = x(m,k) + x(m,kc)
+      t2 = x(m,k) - x(m,kc)
+      dsum(m1) = dsum(m1) + wsave(kc) * t2
+      t2 = wsave(k) * t2
+      x(m,k) = t1 - t2
+      x(m,kc) = t1 + t2
+    end do
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    do m = 1, lj, jump
+      x(m,ns2+1) = x(m,ns2+1) + x(m,ns2+1)
+    end do
+  end if
+
+  lenx = ( lot - 1 ) * jump + inc * ( nm1 - 1 )  + 1
+  lnsv = nm1 + int ( log ( real ( nm1, kind = 4 ) ) ) + 4
+  lnwk = lot * nm1
+
+  call rfftmf ( lot, jump, nm1, inc, x, lenx, wsave(n+1), lnsv, work, &
+    lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'mcstb1', -5 )
+    return
+  end if
+
+  fnm1s2 = real ( nm1, kind = 4 ) / 2.0E+00
+  m1 = 0
+  do m = 1, lj, jump
+    m1 = m1 + 1
+    dsum(m1) = 0.5E+00 * dsum(m1)
+    x(m,1) = fnm1s2 * x(m,1)
+  end do
+
+  if ( mod ( nm1, 2 ) == 0 ) then
+    do m = 1, lj, jump
+      x(m,nm1) = x(m,nm1) + x(m,nm1)
+    end do
+  end if
+
+  fnm1s4 = real ( nm1, kind = 4 ) / 4.0E+00
+
+  do i = 3, n, 2
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      xi = fnm1s4 * x(m,i)
+      x(m,i) = fnm1s4 * x(m,i-1)
+      x(m,i-1) = dsum(m1)
+      dsum(m1) = dsum(m1) + xi
+    end do
+  end do
+
+  if ( modn /= 0 ) then
+    return
+  end if
+
+  m1 = 0
+  do m = 1, lj, jump
+    m1 = m1 + 1
+    x(m,n) = dsum(m1)
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mcstf1.F b/wrfv2_fire/external/fftpack/fftpack5/mcstf1.F
index 65ceecef..0ae88b6d 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mcstf1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mcstf1.F
@@ -1,103 +1,185 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mcstf1.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MCSTF1(LOT,JUMP,N,INC,X,WSAVE,DSUM,WORK,IER) 
-      REAL       X(INC,*)       ,WSAVE(*) 
-      DOUBLE PRECISION           DSUM(*) 
-      IER = 0 
-      NM1 = N-1 
-      NP1 = N+1 
-      NS2 = N/2 
-      LJ = (LOT-1)*JUMP+1 
-      IF (N-2) 200,101,102 
-  101 DO 111 M=1,LJ,JUMP 
-         X1H = X(M,1)+X(M,2) 
-         X(M,2) = .5*(X(M,1)-X(M,2)) 
-         X(M,1) = .5*X1H 
-  111 END DO 
-      GO TO 200 
-  102 IF (N .GT. 3) GO TO 103 
-      DO 112 M=1,LJ,JUMP 
-         X1P3 = X(M,1)+X(M,3) 
-         TX2 = X(M,2)+X(M,2) 
-         X(M,2) = .5*(X(M,1)-X(M,3)) 
-         X(M,1) = .25*(X1P3+TX2) 
-         X(M,3) = .25*(X1P3-TX2) 
-  112 END DO 
-      GO TO 200 
-  103 M1 = 0 
-      DO 113 M=1,LJ,JUMP 
-         M1 = M1+1 
-         DSUM(M1) = X(M,1)-X(M,N) 
-         X(M,1) = X(M,1)+X(M,N) 
-  113 END DO 
-      DO 104 K=2,NS2 
-         M1 = 0 
-         DO 114 M=1,LJ,JUMP 
-         M1 = M1+1 
-         KC = NP1-K 
-         T1 = X(M,K)+X(M,KC) 
-         T2 = X(M,K)-X(M,KC) 
-         DSUM(M1) = DSUM(M1)+WSAVE(KC)*T2 
-         T2 = WSAVE(K)*T2 
-         X(M,K) = T1-T2 
-         X(M,KC) = T1+T2 
-  114    CONTINUE 
-  104 END DO 
-      MODN = MOD(N,2) 
-      IF (MODN .EQ. 0) GO TO 124 
-         DO 123 M=1,LJ,JUMP 
-         X(M,NS2+1) = X(M,NS2+1)+X(M,NS2+1) 
-  123    CONTINUE 
-  124 CONTINUE 
-      LENX = (LOT-1)*JUMP + INC*(NM1-1)  + 1 
-      LNSV = NM1 + INT(LOG(REAL(NM1))) + 4 
-      LNWK = LOT*NM1 
-!                                                                       
-      CALL RFFTMF(LOT,JUMP,NM1,INC,X,LENX,WSAVE(N+1),LNSV,WORK,         &
-     &            LNWK,IER1)                                            
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('MCSTF1',-5) 
-        GO TO 200 
-      ENDIF 
-!                                                                       
-      SNM1 = 1./FLOAT(NM1) 
-      DO 10 M=1,LOT 
-      DSUM(M) = SNM1*DSUM(M) 
-   10 END DO 
-      IF(MOD(NM1,2) .NE. 0) GO TO 30 
-      DO 20 M=1,LJ,JUMP 
-      X(M,NM1) = X(M,NM1)+X(M,NM1) 
-   20 END DO 
-   30 DO 105 I=3,N,2 
-         M1 = 0 
-         DO 115 M=1,LJ,JUMP 
-            M1 = M1+1 
-            XI = .5*X(M,I) 
-            X(M,I) = .5*X(M,I-1) 
-            X(M,I-1) = DSUM(M1) 
-            DSUM(M1) = DSUM(M1)+XI 
-  115 END DO 
-  105 END DO 
-      IF (MODN .NE. 0) GO TO 117 
-      M1 = 0 
-      DO 116 M=1,LJ,JUMP 
-         M1 = M1+1 
-         X(M,N) = DSUM(M1) 
-  116 END DO 
-  117 DO 118 M=1,LJ,JUMP 
-      X(M,1) = .5*X(M,1) 
-      X(M,N) = .5*X(M,N) 
-  118 END DO 
-!                                                                       
-  200 CONTINUE 
-      RETURN 
-      END                                           
+subroutine mcstf1 ( lot, jump, n, inc, x, wsave, dsum, work, ier )
+
+!*****************************************************************************80
+!
+!! MCSTF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  real ( kind = 8 ) dsum(*)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lj
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nm1
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) snm1
+  real ( kind = 4 ) t1
+  real ( kind = 4 ) t2
+  real ( kind = 4 ) tx2
+  real ( kind = 4 ) work(*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) x1h
+  real ( kind = 4 ) x1p3
+  real ( kind = 4 ) xi
+
+  ier = 0
+  nm1 = n - 1
+  np1 = n + 1
+  ns2 = n / 2
+  lj = ( lot - 1 ) * jump + 1
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+
+    do m = 1, lj, jump
+      x1h = x(m,1) + x(m,2)
+      x(m,2) = 0.5E+00 * ( x(m,1) - x(m,2) )
+      x(m,1) = 0.5E+00 * x1h
+    end do
+
+    return
+
+  end if
+
+  if ( n == 3 ) then
+
+    do m = 1, lj, jump
+      x1p3 = x(m,1) + x(m,3)
+      tx2 = x(m,2) + x(m,2)
+      x(m,2) = 0.5E+00 * ( x(m,1) - x(m,3) )
+      x(m,1) = 0.25E+00 * ( x1p3 + tx2 )
+      x(m,3) = 0.25E+00 * ( x1p3 - tx2 )
+    end do
+
+    return
+  end if
+
+  m1 = 0
+  do m = 1, lj, jump
+    m1 = m1 + 1
+    dsum(m1) = x(m,1) - x(m,n)
+    x(m,1) = x(m,1) + x(m,n)
+  end do
+
+  do k = 2, ns2
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      kc = np1 - k
+      t1 = x(m,k) + x(m,kc)
+      t2 = x(m,k) - x(m,kc)
+      dsum(m1) = dsum(m1) + wsave(kc) * t2
+      t2 = wsave(k) * t2
+      x(m,k) = t1 - t2
+      x(m,kc) = t1 + t2
+    end do
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    do m = 1, lj, jump
+      x(m,ns2+1) = x(m,ns2+1) + x(m,ns2+1)
+    end do
+  end if
+
+  lenx = ( lot - 1 ) * jump + inc * ( nm1 - 1 )  + 1
+  lnsv = nm1 + int ( log ( real ( nm1, kind = 4 ) ) ) + 4
+  lnwk = lot * nm1
+
+  call rfftmf ( lot, jump, nm1, inc, x, lenx, wsave(n+1), lnsv, work, &
+    lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'mcstf1', -5 )
+    return
+  end if
+
+  snm1 = 1.0E+00 / real ( nm1, kind = 4 )
+  do m = 1, lot
+    dsum(m) = snm1 * dsum(m)
+  end do
+
+  if ( mod ( nm1, 2 ) == 0 ) then
+    do m = 1, lj, jump
+      x(m,nm1) = x(m,nm1) + x(m,nm1)
+    end do
+  end if
+
+  do i = 3, n, 2
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      xi = 0.5E+00 * x(m,i)
+      x(m,i) = 0.5E+00 * x(m,i-1)
+      x(m,i-1) = dsum(m1)
+      dsum(m1) = dsum(m1) + xi
+    end do
+  end do
+
+  if ( modn == 0 ) then
+
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      x(m,n) = dsum(m1)
+    end do
+
+  end if
+
+  do m = 1, lj, jump
+    x(m,1) = 0.5E+00 * x(m,1)
+    x(m,n) = 0.5E+00 * x(m,n)
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mradb2.F b/wrfv2_fire/external/fftpack/fftpack5/mradb2.F
index 0362b952..ffa8ad16 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mradb2.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mradb2.F
@@ -1,51 +1,110 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mradb2.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRADB2 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1) 
-      REAL       CC(IN1,IDO,2,L1), CH(IN2,IDO,L1,2), WA1(IDO) 
-!                                                                       
-      M1D = (M-1)*IM1+1 
-      M2S = 1-IM2 
-      DO 101 K=1,L1 
-          M2 = M2S 
-          DO 1001 M1=1,M1D,IM1 
-          M2 = M2+IM2 
-         CH(M2,1,K,1) = CC(M1,1,1,K)+CC(M1,IDO,2,K) 
-         CH(M2,1,K,2) = CC(M1,1,1,K)-CC(M1,IDO,2,K) 
- 1001     CONTINUE 
-  101 END DO 
-      IF (IDO-2) 107,105,102 
-  102 IDP2 = IDO+2 
-      DO 104 K=1,L1 
-         DO 103 I=3,IDO,2 
-            IC = IDP2-I 
-               M2 = M2S 
-               DO 1002 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-        CH(M2,I-1,K,1) = CC(M1,I-1,1,K)+CC(M1,IC-1,2,K) 
-        CH(M2,I,K,1) = CC(M1,I,1,K)-CC(M1,IC,2,K) 
-        CH(M2,I-1,K,2) = WA1(I-2)*(CC(M1,I-1,1,K)-CC(M1,IC-1,2,K))      &
-     &  -WA1(I-1)*(CC(M1,I,1,K)+CC(M1,IC,2,K))                          
-        CH(M2,I,K,2) = WA1(I-2)*(CC(M1,I,1,K)+CC(M1,IC,2,K))+WA1(I-1)   &
-     &  *(CC(M1,I-1,1,K)-CC(M1,IC-1,2,K))                               
- 1002          CONTINUE 
-  103    CONTINUE 
-  104 END DO 
-      IF (MOD(IDO,2) .EQ. 1) RETURN 
-  105 DO 106 K=1,L1 
-          M2 = M2S 
-          DO 1003 M1=1,M1D,IM1 
-          M2 = M2+IM2 
-         CH(M2,IDO,K,1) = CC(M1,IDO,1,K)+CC(M1,IDO,1,K) 
-         CH(M2,IDO,K,2) = -(CC(M1,1,2,K)+CC(M1,1,2,K)) 
- 1003     CONTINUE 
-  106 END DO 
-  107 RETURN 
-      END                                           
+subroutine mradb2 ( m, ido, l1, cc, im1, in1, ch, im2, in2, wa1 )
+
+!*****************************************************************************80
+!
+!! MRADB2 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,ido,2,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,2)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  real ( kind = 4 ) wa1(ido)
+
+  m1d = ( m - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,1,k,1) = cc(m1,1,1,k) + cc(m1,ido,2,k)
+      ch(m2,1,k,2) = cc(m1,1,1,k) - cc(m1,ido,2,k)
+    end do
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch(m2,i-1,k,1) = cc(m1,i-1,1,k) + cc(m1,ic-1,2,k)
+          ch(m2,i,k,1)   = cc(m1,i,1,k) - cc(m1,ic,2,k)
+          ch(m2,i-1,k,2) = wa1(i-2) * ( cc(m1,i-1,1,k) - cc(m1,ic-1,2,k) ) &
+                         - wa1(i-1) * ( cc(m1,i,1,k)   + cc(m1,ic,2,k) )
+          ch(m2,i,k,2)   = wa1(i-2) * ( cc(m1,i,1,k)   + cc(m1,ic,2,k) ) &
+                         + wa1(i-1) * ( cc(m1,i-1,1,k) - cc(m1,ic-1,2,k) )
+        end do
+      end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,ido,k,1) = cc(m1,ido,1,k) + cc(m1,ido,1,k)
+      ch(m2,ido,k,2) = -( cc(m1,1,2,k) + cc(m1,1,2,k) )
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mradb3.F b/wrfv2_fire/external/fftpack/fftpack5/mradb3.F
index 5b6a9b79..e8eece50 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mradb3.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mradb3.F
@@ -1,69 +1,127 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mradb3.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRADB3 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1,WA2) 
-      REAL       CC(IN1,IDO,3,L1)    ,CH(IN2,IDO,L1,3),                 &
-     &           WA1(IDO)   ,WA2(IDO)                                   
-!                                                                       
-      M1D = (M-1)*IM1+1 
-      M2S = 1-IM2 
-      ARG=2.*4.*ATAN(1.0)/3. 
-      TAUR=COS(ARG) 
-      TAUI=SIN(ARG) 
-      DO 101 K=1,L1 
-          M2 = M2S 
-          DO 1001 M1=1,M1D,IM1 
-          M2 = M2+IM2 
-         CH(M2,1,K,1) = CC(M1,1,1,K)+2.*CC(M1,IDO,2,K) 
-         CH(M2,1,K,2) = CC(M1,1,1,K)+(2.*TAUR)*CC(M1,IDO,2,K)           &
-     &   -(2.*TAUI)*CC(M1,1,3,K)                                        
-         CH(M2,1,K,3) = CC(M1,1,1,K)+(2.*TAUR)*CC(M1,IDO,2,K)           &
-     &   +2.*TAUI*CC(M1,1,3,K)                                          
- 1001     CONTINUE 
-  101 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      IDP2 = IDO+2 
-      DO 103 K=1,L1 
-         DO 102 I=3,IDO,2 
-            IC = IDP2-I 
-               M2 = M2S 
-               DO 1002 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-        CH(M2,I-1,K,1) = CC(M1,I-1,1,K)+(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)) 
-        CH(M2,I,K,1) = CC(M1,I,1,K)+(CC(M1,I,3,K)-CC(M1,IC,2,K)) 
-        CH(M2,I-1,K,2) = WA1(I-2)*                                      &
-     & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))-         &
-     & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))                             &
-     &                   -WA1(I-1)*                                     &
-     & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))+               &
-     & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))                         
-            CH(M2,I,K,2) = WA1(I-2)*                                    &
-     & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))+               &
-     & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))                         &
-     &                  +WA1(I-1)*                                      &
-     & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))-         &
-     & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))                             
-              CH(M2,I-1,K,3) = WA2(I-2)*                                &
-     & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))+         &
-     & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))                             &
-     &   -WA2(I-1)*                                                     &
-     & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))-               &
-     & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))                         
-            CH(M2,I,K,3) = WA2(I-2)*                                    &
-     & ((CC(M1,I,1,K)+TAUR*(CC(M1,I,3,K)-CC(M1,IC,2,K)))-               &
-     & (TAUI*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))))                         &
-     &                 +WA2(I-1)*                                       &
-     & ((CC(M1,I-1,1,K)+TAUR*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))+         &
-     & (TAUI*(CC(M1,I,3,K)+CC(M1,IC,2,K))))                             
- 1002          CONTINUE 
-  102    CONTINUE 
-  103 END DO 
-      RETURN 
-      END                                           
+subroutine mradb3 ( m, ido, l1, cc, im1, in1, ch, im2, in2, wa1, wa2 )
+
+!*****************************************************************************80
+!
+!! MRADB3 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) cc(in1,ido,3,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,3)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  real ( kind = 4 ) taui
+  real ( kind = 4 ) taur
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+
+  m1d = ( m - 1 ) * im1 + 1
+  m2s = 1 - im2
+  arg = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 ) / 3.0E+00
+  taur = cos ( arg )
+  taui = sin ( arg )
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,1,k,1) = cc(m1,1,1,k) + 2.0E+00 * cc(m1,ido,2,k)
+      ch(m2,1,k,2) = cc(m1,1,1,k) + ( 2.0E+00 * taur ) * cc(m1,ido,2,k) &
+        - ( 2.0E+00 * taui ) * cc(m1,1,3,k)
+      ch(m2,1,k,3) = cc(m1,1,1,k) + ( 2.0E+00 * taur ) * cc(m1,ido,2,k) &
+        + 2.0E+00 * taui * cc(m1,1,3,k)
+    end do
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      m2 = m2s
+      do m1 = 1, m1d, im1
+
+        m2 = m2 + im2
+
+        ch(m2,i-1,k,1) = cc(m1,i-1,1,k)+(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k))
+
+        ch(m2,i,k,1) = cc(m1,i,1,k)+(cc(m1,i,3,k)-cc(m1,ic,2,k))
+
+        ch(m2,i-1,k,2) = wa1(i-2)* &
+          ((cc(m1,i-1,1,k)+taur*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)))- &
+          (taui*(cc(m1,i,3,k)+cc(m1,ic,2,k)))) - wa1(i-1)* &
+          ((cc(m1,i,1,k)+taur*(cc(m1,i,3,k)-cc(m1,ic,2,k)))+ &
+          (taui*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))))
+
+        ch(m2,i,k,2) = wa1(i-2)* &
+          ((cc(m1,i,1,k)+taur*(cc(m1,i,3,k)-cc(m1,ic,2,k)))+ &
+          (taui*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k)))) + wa1(i-1)* &
+          ((cc(m1,i-1,1,k)+taur*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)))- &
+          (taui*(cc(m1,i,3,k)+cc(m1,ic,2,k))))
+
+        ch(m2,i-1,k,3) = wa2(i-2)* &
+          ((cc(m1,i-1,1,k)+taur*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)))+ &
+          (taui*(cc(m1,i,3,k)+cc(m1,ic,2,k)))) - wa2(i-1)* &
+          ((cc(m1,i,1,k)+taur*(cc(m1,i,3,k)-cc(m1,ic,2,k)))- &
+          (taui*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))))
+
+        ch(m2,i,k,3) = wa2(i-2)* &
+          ((cc(m1,i,1,k)+taur*(cc(m1,i,3,k)-cc(m1,ic,2,k)))- &
+          (taui*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k)))) + wa2(i-1)* &
+          ((cc(m1,i-1,1,k)+taur*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)))+ &
+          (taui*(cc(m1,i,3,k)+cc(m1,ic,2,k))))
+
+      end do
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mradb4.F b/wrfv2_fire/external/fftpack/fftpack5/mradb4.F
index 035d4ca6..92023f43 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mradb4.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mradb4.F
@@ -1,83 +1,143 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mradb4.f,v 1.2 2004/06/15 21:29:19 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRADB4 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1,WA2,WA3) 
-      REAL       CC(IN1,IDO,4,L1)  ,CH(IN2,IDO,L1,4)    ,               &
-     &           WA1(IDO)  ,        WA2(IDO)  ,       WA3(IDO)          
-!                                                                       
-      M1D = (M-1)*IM1+1 
-      M2S = 1-IM2 
-      SQRT2=SQRT(2.) 
-      DO 101 K=1,L1 
-          M2 = M2S 
-          DO 1001 M1=1,M1D,IM1 
-          M2 = M2+IM2 
-         CH(M2,1,K,3) = (CC(M1,1,1,K)+CC(M1,IDO,4,K))                   &
-     &   -(CC(M1,IDO,2,K)+CC(M1,IDO,2,K))                               
-         CH(M2,1,K,1) = (CC(M1,1,1,K)+CC(M1,IDO,4,K))                   &
-     &   +(CC(M1,IDO,2,K)+CC(M1,IDO,2,K))                               
-         CH(M2,1,K,4) = (CC(M1,1,1,K)-CC(M1,IDO,4,K))                   &
-     &   +(CC(M1,1,3,K)+CC(M1,1,3,K))                                   
-         CH(M2,1,K,2) = (CC(M1,1,1,K)-CC(M1,IDO,4,K))                   &
-     &   -(CC(M1,1,3,K)+CC(M1,1,3,K))                                   
- 1001     CONTINUE 
-  101 END DO 
-      IF (IDO-2) 107,105,102 
-  102 IDP2 = IDO+2 
-      DO 104 K=1,L1 
-         DO 103 I=3,IDO,2 
-            IC = IDP2-I 
-               M2 = M2S 
-               DO 1002 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-        CH(M2,I-1,K,1) = (CC(M1,I-1,1,K)+CC(M1,IC-1,4,K))               &
-     &  +(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))                               
-        CH(M2,I,K,1) = (CC(M1,I,1,K)-CC(M1,IC,4,K))                     &
-     &  +(CC(M1,I,3,K)-CC(M1,IC,2,K))                                   
-        CH(M2,I-1,K,2)=WA1(I-2)*((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))       &
-     &  -(CC(M1,I,3,K)+CC(M1,IC,2,K)))-WA1(I-1)                         &
-     &  *((CC(M1,I,1,K)+CC(M1,IC,4,K))+(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K)))
-        CH(M2,I,K,2)=WA1(I-2)*((CC(M1,I,1,K)+CC(M1,IC,4,K))             &
-     &  +(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K)))+WA1(I-1)                     &
-     &  *((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))-(CC(M1,I,3,K)+CC(M1,IC,2,K)))
-        CH(M2,I-1,K,3)=WA2(I-2)*((CC(M1,I-1,1,K)+CC(M1,IC-1,4,K))       &
-     &  -(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K)))-WA2(I-1)                     &
-     &  *((CC(M1,I,1,K)-CC(M1,IC,4,K))-(CC(M1,I,3,K)-CC(M1,IC,2,K)))    
-        CH(M2,I,K,3)=WA2(I-2)*((CC(M1,I,1,K)-CC(M1,IC,4,K))             &
-     &  -(CC(M1,I,3,K)-CC(M1,IC,2,K)))+WA2(I-1)                         &
-     &  *((CC(M1,I-1,1,K)+CC(M1,IC-1,4,K))-(CC(M1,I-1,3,K)              &
-     &  +CC(M1,IC-1,2,K)))                                              
-        CH(M2,I-1,K,4)=WA3(I-2)*((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))       &
-     &  +(CC(M1,I,3,K)+CC(M1,IC,2,K)))-WA3(I-1)                         &
-     & *((CC(M1,I,1,K)+CC(M1,IC,4,K))-(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))) 
-        CH(M2,I,K,4)=WA3(I-2)*((CC(M1,I,1,K)+CC(M1,IC,4,K))             &
-     &  -(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K)))+WA3(I-1)                     &
-     &  *((CC(M1,I-1,1,K)-CC(M1,IC-1,4,K))+(CC(M1,I,3,K)+CC(M1,IC,2,K)))
- 1002          CONTINUE 
-  103    CONTINUE 
-  104 END DO 
-      IF (MOD(IDO,2) .EQ. 1) RETURN 
-  105 CONTINUE 
-      DO 106 K=1,L1 
-               M2 = M2S 
-               DO 1003 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-         CH(M2,IDO,K,1) = (CC(M1,IDO,1,K)+CC(M1,IDO,3,K))               &
-     &   +(CC(M1,IDO,1,K)+CC(M1,IDO,3,K))                               
-         CH(M2,IDO,K,2) = SQRT2*((CC(M1,IDO,1,K)-CC(M1,IDO,3,K))        &
-     &   -(CC(M1,1,2,K)+CC(M1,1,4,K)))                                  
-         CH(M2,IDO,K,3) = (CC(M1,1,4,K)-CC(M1,1,2,K))                   &
-     &   +(CC(M1,1,4,K)-CC(M1,1,2,K))                                   
-         CH(M2,IDO,K,4) = -SQRT2*((CC(M1,IDO,1,K)-CC(M1,IDO,3,K))       &
-     &   +(CC(M1,1,2,K)+CC(M1,1,4,K)))                                  
- 1003          CONTINUE 
-  106 END DO 
-  107 RETURN 
-      END                                           
+subroutine mradb4 ( m, ido, l1, cc, im1, in1, ch, im2, in2, wa1, wa2, wa3 )
+
+!*****************************************************************************80
+!
+!! MRADB4 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,ido,4,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,4)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  real ( kind = 4 ) sqrt2
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+  real ( kind = 4 ) wa3(ido)
+
+  m1d = ( m - 1 ) * im1 + 1
+  m2s = 1 - im2
+  sqrt2 = sqrt ( 2.0E+00 )
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,1,k,3) = (cc(m1,1,1,k)+cc(m1,ido,4,k)) &
+        -(cc(m1,ido,2,k)+cc(m1,ido,2,k))
+      ch(m2,1,k,1) = (cc(m1,1,1,k)+cc(m1,ido,4,k)) &
+        +(cc(m1,ido,2,k)+cc(m1,ido,2,k))
+      ch(m2,1,k,4) = (cc(m1,1,1,k)-cc(m1,ido,4,k)) &
+        +(cc(m1,1,3,k)+cc(m1,1,3,k))
+      ch(m2,1,k,2) = (cc(m1,1,1,k)-cc(m1,ido,4,k)) &
+        -(cc(m1,1,3,k)+cc(m1,1,3,k))
+    end do
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch(m2,i-1,k,1) = (cc(m1,i-1,1,k)+cc(m1,ic-1,4,k)) &
+            +(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k))
+          ch(m2,i,k,1) = (cc(m1,i,1,k)-cc(m1,ic,4,k)) &
+            +(cc(m1,i,3,k)-cc(m1,ic,2,k))
+          ch(m2,i-1,k,2) = wa1(i-2)*((cc(m1,i-1,1,k)-cc(m1,ic-1,4,k)) &
+            -(cc(m1,i,3,k)+cc(m1,ic,2,k)))-wa1(i-1) &
+            *((cc(m1,i,1,k)+cc(m1,ic,4,k))+(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k)))
+          ch(m2,i,k,2) = wa1(i-2)*((cc(m1,i,1,k)+cc(m1,ic,4,k)) &
+            +(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))) + wa1(i-1) &
+            *((cc(m1,i-1,1,k)-cc(m1,ic-1,4,k))-(cc(m1,i,3,k)+cc(m1,ic,2,k)))
+          ch(m2,i-1,k,3) = wa2(i-2)*((cc(m1,i-1,1,k)+cc(m1,ic-1,4,k)) &
+            -(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k))) - wa2(i-1) &
+            *((cc(m1,i,1,k)-cc(m1,ic,4,k))-(cc(m1,i,3,k)-cc(m1,ic,2,k)))
+          ch(m2,i,k,3) = wa2(i-2)*((cc(m1,i,1,k)-cc(m1,ic,4,k)) &
+            -(cc(m1,i,3,k)-cc(m1,ic,2,k))) + wa2(i-1) &
+            *((cc(m1,i-1,1,k)+cc(m1,ic-1,4,k))-(cc(m1,i-1,3,k) &
+            +cc(m1,ic-1,2,k)))
+          ch(m2,i-1,k,4) = wa3(i-2)*((cc(m1,i-1,1,k)-cc(m1,ic-1,4,k)) &
+            +(cc(m1,i,3,k)+cc(m1,ic,2,k))) - wa3(i-1) &
+            *((cc(m1,i,1,k)+cc(m1,ic,4,k))-(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k)))
+          ch(m2,i,k,4) = wa3(i-2)*((cc(m1,i,1,k)+cc(m1,ic,4,k)) &
+            -(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))) + wa3(i-1) &
+            *((cc(m1,i-1,1,k)-cc(m1,ic-1,4,k))+(cc(m1,i,3,k)+cc(m1,ic,2,k)))
+        end do
+      end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,ido,k,1) = (cc(m1,ido,1,k)+cc(m1,ido,3,k)) &
+        +(cc(m1,ido,1,k)+cc(m1,ido,3,k))
+      ch(m2,ido,k,2) = sqrt2*((cc(m1,ido,1,k)-cc(m1,ido,3,k)) &
+        -(cc(m1,1,2,k)+cc(m1,1,4,k)))
+      ch(m2,ido,k,3) = (cc(m1,1,4,k)-cc(m1,1,2,k)) &
+        +(cc(m1,1,4,k)-cc(m1,1,2,k))
+      ch(m2,ido,k,4) = -sqrt2*((cc(m1,ido,1,k)-cc(m1,ido,3,k)) &
+        +(cc(m1,1,2,k)+cc(m1,1,4,k)))
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mradb5.F b/wrfv2_fire/external/fftpack/fftpack5/mradb5.F
index 2af774b6..a2df3ec8 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mradb5.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mradb5.F
@@ -1,125 +1,183 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mradb5.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRADB5 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,                &
-     &       WA1,WA2,WA3,WA4)                                           
-      REAL   CC(IN1,IDO,5,L1)    ,CH(IN2,IDO,L1,5),                     &
-     &       WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)         
-!                                                                       
-      M1D = (M-1)*IM1+1 
-      M2S = 1-IM2 
-      ARG=2.*4.*ATAN(1.0)/5. 
-      TR11=COS(ARG) 
-      TI11=SIN(ARG) 
-      TR12=COS(2.*ARG) 
-      TI12=SIN(2.*ARG) 
-      DO 101 K=1,L1 
-      M2 = M2S 
-      DO 1001 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH(M2,1,K,1) = CC(M1,1,1,K)+2.*CC(M1,IDO,2,K)+2.*CC(M1,IDO,4,K) 
-         CH(M2,1,K,2) = (CC(M1,1,1,K)+TR11*2.*CC(M1,IDO,2,K)            &
-     &   +TR12*2.*CC(M1,IDO,4,K))-(TI11*2.*CC(M1,1,3,K)                 &
-     &   +TI12*2.*CC(M1,1,5,K))                                         
-         CH(M2,1,K,3) = (CC(M1,1,1,K)+TR12*2.*CC(M1,IDO,2,K)            &
-     &   +TR11*2.*CC(M1,IDO,4,K))-(TI12*2.*CC(M1,1,3,K)                 &
-     &   -TI11*2.*CC(M1,1,5,K))                                         
-         CH(M2,1,K,4) = (CC(M1,1,1,K)+TR12*2.*CC(M1,IDO,2,K)            &
-     &   +TR11*2.*CC(M1,IDO,4,K))+(TI12*2.*CC(M1,1,3,K)                 &
-     &   -TI11*2.*CC(M1,1,5,K))                                         
-         CH(M2,1,K,5) = (CC(M1,1,1,K)+TR11*2.*CC(M1,IDO,2,K)            &
-     &   +TR12*2.*CC(M1,IDO,4,K))+(TI11*2.*CC(M1,1,3,K)                 &
-     &   +TI12*2.*CC(M1,1,5,K))                                         
- 1001          CONTINUE 
-  101 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      IDP2 = IDO+2 
-      DO 103 K=1,L1 
-         DO 102 I=3,IDO,2 
-            IC = IDP2-I 
-            M2 = M2S 
-      DO 1002 M1=1,M1D,IM1 
-        M2 = M2+IM2 
-        CH(M2,I-1,K,1) = CC(M1,I-1,1,K)+(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))&
-     &  +(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K))                               
-        CH(M2,I,K,1) = CC(M1,I,1,K)+(CC(M1,I,3,K)-CC(M1,IC,2,K))        &
-     &  +(CC(M1,I,5,K)-CC(M1,IC,4,K))                                   
-        CH(M2,I-1,K,2) = WA1(I-2)*((CC(M1,I-1,1,K)+TR11*                &
-     &  (CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))+TR12                           &
-     &  *(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))-(TI11*(CC(M1,I,3,K)          &
-     &  +CC(M1,IC,2,K))+TI12*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             &
-     &  -WA1(I-1)*((CC(M1,I,1,K)+TR11*(CC(M1,I,3,K)-CC(M1,IC,2,K))      &
-     &  +TR12*(CC(M1,I,5,K)-CC(M1,IC,4,K)))+(TI11*(CC(M1,I-1,3,K)       &
-     &  -CC(M1,IC-1,2,K))+TI12*(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))       
-        CH(M2,I,K,2) = WA1(I-2)*((CC(M1,I,1,K)+TR11*(CC(M1,I,3,K)       &
-     &  -CC(M1,IC,2,K))+TR12*(CC(M1,I,5,K)-CC(M1,IC,4,K)))              &
-     &  +(TI11*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))+TI12                    &
-     &  *(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))+WA1(I-1)                    &
-     &  *((CC(M1,I-1,1,K)+TR11*(CC(M1,I-1,3,K)                          &
-     &  +CC(M1,IC-1,2,K))+TR12*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))        &
-     &  -(TI11*(CC(M1,I,3,K)+CC(M1,IC,2,K))+TI12                        &
-     &  *(CC(M1,I,5,K)+CC(M1,IC,4,K))))                                 
-        CH(M2,I-1,K,3) = WA2(I-2)                                       &
-     &  *((CC(M1,I-1,1,K)+TR12*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
-     &  +TR11*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))-(TI12*(CC(M1,I,3,K)     &
-     &  +CC(M1,IC,2,K))-TI11*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             &
-     & -WA2(I-1)                                                        &
-     & *((CC(M1,I,1,K)+TR12*(CC(M1,I,3,K)-                              &
-     &  CC(M1,IC,2,K))+TR11*(CC(M1,I,5,K)-CC(M1,IC,4,K)))               &
-     &  +(TI12*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))-TI11                    &
-     &  *(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))                             
-        CH(M2,I,K,3) = WA2(I-2)                                         &
-     & *((CC(M1,I,1,K)+TR12*(CC(M1,I,3,K)-                              &
-     &  CC(M1,IC,2,K))+TR11*(CC(M1,I,5,K)-CC(M1,IC,4,K)))               &
-     &  +(TI12*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))-TI11                    &
-     &  *(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))                             &
-     &  +WA2(I-1)                                                       &
-     &  *((CC(M1,I-1,1,K)+TR12*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
-     &  +TR11*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))-(TI12*(CC(M1,I,3,K)     &
-     &  +CC(M1,IC,2,K))-TI11*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             
-        CH(M2,I-1,K,4) = WA3(I-2)                                       &
-     &  *((CC(M1,I-1,1,K)+TR12*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
-     &  +TR11*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))+(TI12*(CC(M1,I,3,K)     &
-     &  +CC(M1,IC,2,K))-TI11*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             &
-     &  -WA3(I-1)                                                       &
-     & *((CC(M1,I,1,K)+TR12*(CC(M1,I,3,K)-                              &
-     &  CC(M1,IC,2,K))+TR11*(CC(M1,I,5,K)-CC(M1,IC,4,K)))               &
-     &  -(TI12*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))-TI11                    &
-     &  *(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))                             
-        CH(M2,I,K,4) = WA3(I-2)                                         &
-     & *((CC(M1,I,1,K)+TR12*(CC(M1,I,3,K)-                              &
-     &  CC(M1,IC,2,K))+TR11*(CC(M1,I,5,K)-CC(M1,IC,4,K)))               &
-     &  -(TI12*(CC(M1,I-1,3,K)-CC(M1,IC-1,2,K))-TI11                    &
-     &  *(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))                             &
-     &  +WA3(I-1)                                                       &
-     &  *((CC(M1,I-1,1,K)+TR12*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
-     &  +TR11*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))+(TI12*(CC(M1,I,3,K)     &
-     &  +CC(M1,IC,2,K))-TI11*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             
-        CH(M2,I-1,K,5) = WA4(I-2)                                       &
-     &  *((CC(M1,I-1,1,K)+TR11*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
-     &  +TR12*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))+(TI11*(CC(M1,I,3,K)     &
-     &  +CC(M1,IC,2,K))+TI12*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             &
-     &  -WA4(I-1)                                                       &
-     &  *((CC(M1,I,1,K)+TR11*(CC(M1,I,3,K)-CC(M1,IC,2,K))               &
-     &  +TR12*(CC(M1,I,5,K)-CC(M1,IC,4,K)))-(TI11*(CC(M1,I-1,3,K)       &
-     &  -CC(M1,IC-1,2,K))+TI12*(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))       
-        CH(M2,I,K,5) = WA4(I-2)                                         &
-     &  *((CC(M1,I,1,K)+TR11*(CC(M1,I,3,K)-CC(M1,IC,2,K))               &
-     &  +TR12*(CC(M1,I,5,K)-CC(M1,IC,4,K)))-(TI11*(CC(M1,I-1,3,K)       &
-     &  -CC(M1,IC-1,2,K))+TI12*(CC(M1,I-1,5,K)-CC(M1,IC-1,4,K))))       &
-     &  +WA4(I-1)                                                       &
-     &  *((CC(M1,I-1,1,K)+TR11*(CC(M1,I-1,3,K)+CC(M1,IC-1,2,K))         &
-     &  +TR12*(CC(M1,I-1,5,K)+CC(M1,IC-1,4,K)))+(TI11*(CC(M1,I,3,K)     &
-     &  +CC(M1,IC,2,K))+TI12*(CC(M1,I,5,K)+CC(M1,IC,4,K))))             
- 1002      CONTINUE 
-  102    CONTINUE 
-  103 END DO 
-      RETURN 
-      END                                           
+subroutine mradb5 ( m, ido, l1, cc, im1, in1, ch, im2, in2, &
+  wa1, wa2, wa3, wa4 )
+
+!*****************************************************************************80
+!
+!! MRADB5 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) cc(in1,ido,5,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,5)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  real ( kind = 4 ) ti11
+  real ( kind = 4 ) ti12
+  real ( kind = 4 ) tr11
+  real ( kind = 4 ) tr12
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+  real ( kind = 4 ) wa3(ido)
+  real ( kind = 4 ) wa4(ido)
+
+  m1d = ( m - 1 ) * im1 + 1
+  m2s = 1 - im2
+  arg = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 ) / 5.E+00
+  tr11 = cos ( arg )
+  ti11 = sin ( arg )
+  tr12 = cos ( 2.0E+00 * arg )
+  ti12 = sin ( 2.0E+00 * arg )
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,1,k,1) = cc(m1,1,1,k) + 2.0E+00 * cc(m1,ido,2,k) &
+        + 2.0E+00 * cc(m1,ido,4,k)
+      ch(m2,1,k,2) = ( cc(m1,1,1,k) + tr11 * 2.0E+00 * cc(m1,ido,2,k) &
+        + tr12 * 2.0E+00 * cc(m1,ido,4,k) ) - ( ti11 * 2.0E+00 * cc(m1,1,3,k) &
+        + ti12 * 2.0E+00 * cc(m1,1,5,k) )
+      ch(m2,1,k,3) = ( cc(m1,1,1,k) + tr12 * 2.0E+00 * cc(m1,ido,2,k) &
+        + tr11 * 2.0E+00 * cc(m1,ido,4,k) ) - ( ti12 * 2.0E+00 * cc(m1,1,3,k) &
+        - ti11 * 2.0E+00 * cc(m1,1,5,k) )
+      ch(m2,1,k,4) = ( cc(m1,1,1,k) + tr12 * 2.0E+00 * cc(m1,ido,2,k) &
+        + tr11 * 2.0E+00 * cc(m1,ido,4,k) ) + ( ti12 * 2.0E+00 * cc(m1,1,3,k) &
+        - ti11 * 2.0E+00 * cc(m1,1,5,k) )
+      ch(m2,1,k,5) = ( cc(m1,1,1,k) + tr11 * 2.0E+00 * cc(m1,ido,2,k) &
+        + tr12 * 2.0E+00 * cc(m1,ido,4,k) ) + ( ti11 * 2.0E+00 * cc(m1,1,3,k) &
+        + ti12 * 2.0E+00 * cc(m1,1,5,k) )
+    end do
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch(m2,i-1,k,1) = cc(m1,i-1,1,k)+(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) &
+          +(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k))
+        ch(m2,i,k,1) = cc(m1,i,1,k)+(cc(m1,i,3,k)-cc(m1,ic,2,k)) &
+          +(cc(m1,i,5,k)-cc(m1,ic,4,k))
+        ch(m2,i-1,k,2) = wa1(i-2)*((cc(m1,i-1,1,k)+tr11* &
+          (cc(m1,i-1,3,k)+cc(m1,ic-1,2,k))+tr12 &
+          *(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))-(ti11*(cc(m1,i,3,k) &
+          +cc(m1,ic,2,k))+ti12*(cc(m1,i,5,k)+cc(m1,ic,4,k)))) &
+          -wa1(i-1)*((cc(m1,i,1,k)+tr11*(cc(m1,i,3,k)-cc(m1,ic,2,k)) &
+          +tr12*(cc(m1,i,5,k)-cc(m1,ic,4,k)))+(ti11*(cc(m1,i-1,3,k) &
+          -cc(m1,ic-1,2,k))+ti12*(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k))))
+        ch(m2,i,k,2) = wa1(i-2)*((cc(m1,i,1,k)+tr11*(cc(m1,i,3,k) &
+          -cc(m1,ic,2,k))+tr12*(cc(m1,i,5,k)-cc(m1,ic,4,k))) &
+          +(ti11*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))+ti12 &
+          *(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k)))) + wa1(i-1) &
+          *((cc(m1,i-1,1,k)+tr11*(cc(m1,i-1,3,k) &
+          +cc(m1,ic-1,2,k))+tr12*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k))) &
+          -(ti11*(cc(m1,i,3,k)+cc(m1,ic,2,k))+ti12 &
+          *(cc(m1,i,5,k)+cc(m1,ic,4,k))))
+        ch(m2,i-1,k,3) = wa2(i-2) &
+          *((cc(m1,i-1,1,k)+tr12*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) &
+          +tr11*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))-(ti12*(cc(m1,i,3,k) &
+          +cc(m1,ic,2,k))-ti11*(cc(m1,i,5,k)+cc(m1,ic,4,k)))) &
+          -wa2(i-1) &
+          *((cc(m1,i,1,k)+tr12*(cc(m1,i,3,k)- &
+        cc(m1,ic,2,k))+tr11*(cc(m1,i,5,k)-cc(m1,ic,4,k))) &
+          +(ti12*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))-ti11 &
+          *(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k))))
+        ch(m2,i,k,3) = wa2(i-2) &
+          *((cc(m1,i,1,k)+tr12*(cc(m1,i,3,k)- &
+          cc(m1,ic,2,k))+tr11*(cc(m1,i,5,k)-cc(m1,ic,4,k))) &
+          +(ti12*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))-ti11 &
+          *(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k)))) &
+          + wa2(i-1) &
+          *((cc(m1,i-1,1,k)+tr12*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) &
+          +tr11*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))-(ti12*(cc(m1,i,3,k) &
+          +cc(m1,ic,2,k))-ti11*(cc(m1,i,5,k)+cc(m1,ic,4,k))))
+        ch(m2,i-1,k,4) = wa3(i-2) &
+          *((cc(m1,i-1,1,k)+tr12*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) &
+          +tr11*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))+(ti12*(cc(m1,i,3,k) &
+          +cc(m1,ic,2,k))-ti11*(cc(m1,i,5,k)+cc(m1,ic,4,k)))) &
+          -wa3(i-1) &
+          *((cc(m1,i,1,k)+tr12*(cc(m1,i,3,k)- &
+          cc(m1,ic,2,k))+tr11*(cc(m1,i,5,k)-cc(m1,ic,4,k))) &
+          -(ti12*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))-ti11 &
+          *(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k))))
+        ch(m2,i,k,4) = wa3(i-2) &
+          *((cc(m1,i,1,k)+tr12*(cc(m1,i,3,k)- &
+          cc(m1,ic,2,k))+tr11*(cc(m1,i,5,k)-cc(m1,ic,4,k))) &
+          -(ti12*(cc(m1,i-1,3,k)-cc(m1,ic-1,2,k))-ti11 &
+          *(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k)))) &
+          + wa3(i-1) &
+          *((cc(m1,i-1,1,k)+tr12*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) &
+          +tr11*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))+(ti12*(cc(m1,i,3,k) &
+          +cc(m1,ic,2,k))-ti11*(cc(m1,i,5,k)+cc(m1,ic,4,k))))
+        ch(m2,i-1,k,5) = wa4(i-2) &
+          *((cc(m1,i-1,1,k)+tr11*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) &
+          +tr12*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))+(ti11*(cc(m1,i,3,k) &
+          +cc(m1,ic,2,k))+ti12*(cc(m1,i,5,k)+cc(m1,ic,4,k)))) &
+          -wa4(i-1) &
+          *((cc(m1,i,1,k)+tr11*(cc(m1,i,3,k)-cc(m1,ic,2,k)) &
+          +tr12*(cc(m1,i,5,k)-cc(m1,ic,4,k)))-(ti11*(cc(m1,i-1,3,k) &
+          -cc(m1,ic-1,2,k))+ti12*(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k))))
+        ch(m2,i,k,5) = wa4(i-2) &
+          *((cc(m1,i,1,k)+tr11*(cc(m1,i,3,k)-cc(m1,ic,2,k)) &
+          +tr12*(cc(m1,i,5,k)-cc(m1,ic,4,k)))-(ti11*(cc(m1,i-1,3,k) &
+          -cc(m1,ic-1,2,k))+ti12*(cc(m1,i-1,5,k)-cc(m1,ic-1,4,k)))) &
+          + wa4(i-1) &
+          *((cc(m1,i-1,1,k)+tr11*(cc(m1,i-1,3,k)+cc(m1,ic-1,2,k)) &
+          +tr12*(cc(m1,i-1,5,k)+cc(m1,ic-1,4,k)))+(ti11*(cc(m1,i,3,k) &
+          +cc(m1,ic,2,k))+ti12*(cc(m1,i,5,k)+cc(m1,ic,4,k))))
+      end do
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mradbg.F b/wrfv2_fire/external/fftpack/fftpack5/mradbg.F
index 2e050246..d49057b6 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mradbg.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mradbg.F
@@ -1,238 +1,351 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mradbg.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRADBG (M,IDO,IP,L1,IDL1,CC,C1,C2,IM1,IN1,             &
-     &          CH,CH2,IM2,IN2,WA)                                      
-      REAL      CH(IN2,IDO,L1,IP)    ,CC(IN1,IDO,IP,L1) ,               &
-     &          C1(IN1,IDO,L1,IP)    ,C2(IN1,IDL1,IP),                  &
-     &          CH2(IN2,IDL1,IP)     ,WA(IDO)                           
-!                                                                       
-      M1D = (M-1)*IM1+1 
-      M2S = 1-IM2 
-      TPI=2.*4.*ATAN(1.0) 
-      ARG = TPI/FLOAT(IP) 
-      DCP = COS(ARG) 
-      DSP = SIN(ARG) 
-      IDP2 = IDO+2 
-      NBD = (IDO-1)/2 
-      IPP2 = IP+2 
-      IPPH = (IP+1)/2 
-      IF (IDO .LT. L1) GO TO 103 
-      DO 102 K=1,L1 
-         DO 101 I=1,IDO 
-            M2 = M2S 
-            DO 1001 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH(M2,I,K,1) = CC(M1,I,1,K) 
- 1001       CONTINUE 
-  101    CONTINUE 
-  102 END DO 
-      GO TO 106 
-  103 DO 105 I=1,IDO 
-         DO 104 K=1,L1 
-            M2 = M2S 
-            DO 1004 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH(M2,I,K,1) = CC(M1,I,1,K) 
- 1004       CONTINUE 
-  104    CONTINUE 
-  105 END DO 
-  106 DO 108 J=2,IPPH 
-         JC = IPP2-J 
-         J2 = J+J 
-         DO 107 K=1,L1 
-            M2 = M2S 
-            DO 1007 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH(M2,1,K,J) = CC(M1,IDO,J2-2,K)+CC(M1,IDO,J2-2,K) 
-            CH(M2,1,K,JC) = CC(M1,1,J2-1,K)+CC(M1,1,J2-1,K) 
- 1007       CONTINUE 
-  107    CONTINUE 
-  108 END DO 
-      IF (IDO .EQ. 1) GO TO 116 
-      IF (NBD .LT. L1) GO TO 112 
-      DO 111 J=2,IPPH 
-         JC = IPP2-J 
-         DO 110 K=1,L1 
-            DO 109 I=3,IDO,2 
-               IC = IDP2-I 
-               M2 = M2S 
-               DO 1009 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CH(M2,I-1,K,J) = CC(M1,I-1,2*J-1,K)+CC(M1,IC-1,2*J-2,K) 
-               CH(M2,I-1,K,JC) = CC(M1,I-1,2*J-1,K)-CC(M1,IC-1,2*J-2,K) 
-               CH(M2,I,K,J) = CC(M1,I,2*J-1,K)-CC(M1,IC,2*J-2,K) 
-               CH(M2,I,K,JC) = CC(M1,I,2*J-1,K)+CC(M1,IC,2*J-2,K) 
- 1009          CONTINUE 
-  109       CONTINUE 
-  110    CONTINUE 
-  111 END DO 
-      GO TO 116 
-  112 DO 115 J=2,IPPH 
-         JC = IPP2-J 
-         DO 114 I=3,IDO,2 
-            IC = IDP2-I 
-            DO 113 K=1,L1 
-               M2 = M2S 
-               DO 1013 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CH(M2,I-1,K,J) = CC(M1,I-1,2*J-1,K)+CC(M1,IC-1,2*J-2,K) 
-               CH(M2,I-1,K,JC) = CC(M1,I-1,2*J-1,K)-CC(M1,IC-1,2*J-2,K) 
-               CH(M2,I,K,J) = CC(M1,I,2*J-1,K)-CC(M1,IC,2*J-2,K) 
-               CH(M2,I,K,JC) = CC(M1,I,2*J-1,K)+CC(M1,IC,2*J-2,K) 
- 1013          CONTINUE 
-  113       CONTINUE 
-  114    CONTINUE 
-  115 END DO 
-  116 AR1 = 1. 
-      AI1 = 0. 
-      DO 120 L=2,IPPH 
-         LC = IPP2-L 
-         AR1H = DCP*AR1-DSP*AI1 
-         AI1 = DCP*AI1+DSP*AR1 
-         AR1 = AR1H 
-         DO 117 IK=1,IDL1 
-            M2 = M2S 
-            DO 1017 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            C2(M1,IK,L) = CH2(M2,IK,1)+AR1*CH2(M2,IK,2) 
-            C2(M1,IK,LC) = AI1*CH2(M2,IK,IP) 
- 1017       CONTINUE 
-  117    CONTINUE 
-         DC2 = AR1 
-         DS2 = AI1 
-         AR2 = AR1 
-         AI2 = AI1 
-         DO 119 J=3,IPPH 
-            JC = IPP2-J 
-            AR2H = DC2*AR2-DS2*AI2 
-            AI2 = DC2*AI2+DS2*AR2 
-            AR2 = AR2H 
-            DO 118 IK=1,IDL1 
-               M2 = M2S 
-               DO 1018 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               C2(M1,IK,L) = C2(M1,IK,L)+AR2*CH2(M2,IK,J) 
-               C2(M1,IK,LC) = C2(M1,IK,LC)+AI2*CH2(M2,IK,JC) 
- 1018          CONTINUE 
-  118       CONTINUE 
-  119    CONTINUE 
-  120 END DO 
-      DO 122 J=2,IPPH 
-         DO 121 IK=1,IDL1 
-            M2 = M2S 
-            DO 1021 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH2(M2,IK,1) = CH2(M2,IK,1)+CH2(M2,IK,J) 
- 1021       CONTINUE 
-  121    CONTINUE 
-  122 END DO 
-      DO 124 J=2,IPPH 
-         JC = IPP2-J 
-         DO 123 K=1,L1 
-            M2 = M2S 
-            DO 1023 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH(M2,1,K,J) = C1(M1,1,K,J)-C1(M1,1,K,JC) 
-            CH(M2,1,K,JC) = C1(M1,1,K,J)+C1(M1,1,K,JC) 
- 1023       CONTINUE 
-  123    CONTINUE 
-  124 END DO 
-      IF (IDO .EQ. 1) GO TO 132 
-      IF (NBD .LT. L1) GO TO 128 
-      DO 127 J=2,IPPH 
-         JC = IPP2-J 
-         DO 126 K=1,L1 
-            DO 125 I=3,IDO,2 
-               M2 = M2S 
-               DO 1025 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CH(M2,I-1,K,J) = C1(M1,I-1,K,J)-C1(M1,I,K,JC) 
-               CH(M2,I-1,K,JC) = C1(M1,I-1,K,J)+C1(M1,I,K,JC) 
-               CH(M2,I,K,J) = C1(M1,I,K,J)+C1(M1,I-1,K,JC) 
-               CH(M2,I,K,JC) = C1(M1,I,K,J)-C1(M1,I-1,K,JC) 
- 1025          CONTINUE 
-  125       CONTINUE 
-  126    CONTINUE 
-  127 END DO 
-      GO TO 132 
-  128 DO 131 J=2,IPPH 
-         JC = IPP2-J 
-         DO 130 I=3,IDO,2 
-            DO 129 K=1,L1 
-               M2 = M2S 
-               DO 1029 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CH(M2,I-1,K,J) = C1(M1,I-1,K,J)-C1(M1,I,K,JC) 
-               CH(M2,I-1,K,JC) = C1(M1,I-1,K,J)+C1(M1,I,K,JC) 
-               CH(M2,I,K,J) = C1(M1,I,K,J)+C1(M1,I-1,K,JC) 
-               CH(M2,I,K,JC) = C1(M1,I,K,J)-C1(M1,I-1,K,JC) 
- 1029          CONTINUE 
-  129       CONTINUE 
-  130    CONTINUE 
-  131 END DO 
-  132 CONTINUE 
-      IF (IDO .EQ. 1) RETURN 
-      DO 133 IK=1,IDL1 
-         M2 = M2S 
-         DO 1033 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         C2(M1,IK,1) = CH2(M2,IK,1) 
- 1033    CONTINUE 
-  133 END DO 
-      DO 135 J=2,IP 
-         DO 134 K=1,L1 
-            M2 = M2S 
-            DO 1034 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            C1(M1,1,K,J) = CH(M2,1,K,J) 
- 1034       CONTINUE 
-  134    CONTINUE 
-  135 END DO 
-      IF (NBD .GT. L1) GO TO 139 
-      IS = -IDO 
-      DO 138 J=2,IP 
-         IS = IS+IDO 
-         IDIJ = IS 
-         DO 137 I=3,IDO,2 
-            IDIJ = IDIJ+2 
-            DO 136 K=1,L1 
-               M2 = M2S 
-               DO 1036 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               C1(M1,I-1,K,J) = WA(IDIJ-1)*CH(M2,I-1,K,J)-WA(IDIJ)*     &
-     &          CH(M2,I,K,J)                                            
-               C1(M1,I,K,J) = WA(IDIJ-1)*CH(M2,I,K,J)+WA(IDIJ)*         &
-     &          CH(M2,I-1,K,J)                                          
- 1036          CONTINUE 
-  136       CONTINUE 
-  137    CONTINUE 
-  138 END DO 
-      GO TO 143 
-  139 IS = -IDO 
-      DO 142 J=2,IP 
-         IS = IS+IDO 
-         DO 141 K=1,L1 
-            IDIJ = IS 
-            DO 140 I=3,IDO,2 
-               IDIJ = IDIJ+2 
-               M2 = M2S 
-               DO 1040 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               C1(M1,I-1,K,J) = WA(IDIJ-1)*CH(M2,I-1,K,J)-WA(IDIJ)*     &
-     &          CH(M2,I,K,J)                                            
-               C1(M1,I,K,J) = WA(IDIJ-1)*CH(M2,I,K,J)+WA(IDIJ)*         &
-     &          CH(M2,I-1,K,J)                                          
- 1040          CONTINUE 
-  140       CONTINUE 
-  141    CONTINUE 
-  142 END DO 
-  143 RETURN 
-      END                                           
+subroutine mradbg ( m, ido, ip, l1, idl1, cc, c1, c2, im1, in1, &
+  ch, ch2, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! MRADBG is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) ai1
+  real ( kind = 4 ) ai2
+  real ( kind = 4 ) ar1
+  real ( kind = 4 ) ar1h
+  real ( kind = 4 ) ar2
+  real ( kind = 4 ) ar2h
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) c1(in1,ido,l1,ip)
+  real ( kind = 4 ) c2(in1,idl1,ip)
+  real ( kind = 4 ) cc(in1,ido,ip,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,ip)
+  real ( kind = 4 ) ch2(in2,idl1,ip)
+  real ( kind = 4 ) dc2
+  real ( kind = 4 ) dcp
+  real ( kind = 4 ) ds2
+  real ( kind = 4 ) dsp
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idij
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) ik
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) is
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) j2
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) nbd
+  real ( kind = 4 ) tpi
+  real ( kind = 4 ) wa(ido)
+
+  m1d = ( m - 1 ) * im1 + 1
+  m2s = 1 - im2
+  tpi = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 )
+  arg = tpi / real ( ip, kind = 4 )
+  dcp = cos ( arg )
+  dsp = sin ( arg )
+  idp2 = ido + 2
+  nbd = ( ido - 1 ) / 2
+  ipp2 = ip + 2
+  ipph = ( ip + 1 ) / 2
+
+  if ( ido < l1 ) then
+
+    do i = 1, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch(m2,i,k,1) = cc(m1,i,1,k)
+        end do
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do i = 1, ido
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch(m2,i,k,1) = cc(m1,i,1,k)
+        end do
+      end do
+    end do
+
+  end if
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    j2 = j + j
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch(m2,1,k,j) = cc(m1,ido,j2-2,k) + cc(m1,ido,j2-2,k)
+        ch(m2,1,k,jc) = cc(m1,1,j2-1,k) + cc(m1,1,j2-1,k)
+      end do
+    end do
+  end do
+
+  if ( ido == 1 ) then
+
+  else if ( nbd < l1 ) then
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do i = 3, ido, 2
+        ic = idp2 - i
+        do k = 1, l1
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            ch(m2,i-1,k,j)  = cc(m1,i-1,2*j-1,k) + cc(m1,ic-1,2*j-2,k)
+            ch(m2,i-1,k,jc) = cc(m1,i-1,2*j-1,k) - cc(m1,ic-1,2*j-2,k)
+            ch(m2,i,k,j)    = cc(m1,i,2*j-1,k)   - cc(m1,ic,2*j-2,k)
+            ch(m2,i,k,jc)   = cc(m1,i,2*j-1,k)   + cc(m1,ic,2*j-2,k)
+          end do
+        end do
+      end do
+    end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do k = 1, l1
+        do i = 3, ido, 2
+          ic = idp2 - i
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            ch(m2,i-1,k,j)  = cc(m1,i-1,2*j-1,k) + cc(m1,ic-1,2*j-2,k)
+            ch(m2,i-1,k,jc) = cc(m1,i-1,2*j-1,k) - cc(m1,ic-1,2*j-2,k)
+            ch(m2,i,k,j)    = cc(m1,i,2*j-1,k)   - cc(m1,ic,2*j-2,k)
+            ch(m2,i,k,jc)   = cc(m1,i,2*j-1,k)   + cc(m1,ic,2*j-2,k)
+          end do
+        end do
+      end do
+    end do
+
+  end if
+
+  ar1 = 1.0E+00
+  ai1 = 0.0E+00
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+    ar1h = dcp * ar1 - dsp * ai1
+    ai1 =  dcp * ai1 + dsp * ar1
+    ar1 = ar1h
+
+    do ik = 1, idl1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        c2(m1,ik,l)  = ch2(m2,ik,1) + ar1 * ch2(m2,ik,2)
+        c2(m1,ik,lc) =                ai1 * ch2(m2,ik,ip)
+      end do
+    end do
+
+    dc2 = ar1
+    ds2 = ai1
+    ar2 = ar1
+    ai2 = ai1
+
+    do j = 3, ipph
+      jc = ipp2 - j
+      ar2h = dc2 * ar2 - ds2 * ai2
+      ai2  = dc2 * ai2 + ds2 * ar2
+      ar2 = ar2h
+      do ik = 1, idl1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          c2(m1,ik,l)  = c2(m1,ik,l)  + ar2 * ch2(m2,ik,j)
+          c2(m1,ik,lc) = c2(m1,ik,lc) + ai2 * ch2(m2,ik,jc)
+        end do
+      end do
+    end do
+
+  end do
+
+  do j = 2, ipph
+    do ik = 1, idl1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch2(m2,ik,1) = ch2(m2,ik,1) + ch2(m2,ik,j)
+      end do
+    end do
+  end do
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch(m2,1,k,j)  = c1(m1,1,k,j) - c1(m1,1,k,jc)
+        ch(m2,1,k,jc) = c1(m1,1,k,j) + c1(m1,1,k,jc)
+      end do
+    end do
+  end do
+
+  if ( ido == 1 ) then
+
+  else if ( nbd < l1 ) then
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do i = 3, ido, 2
+        do k = 1, l1
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            ch(m2,i-1,k,j)  = c1(m1,i-1,k,j) - c1(m1,i,k,jc)
+            ch(m2,i-1,k,jc) = c1(m1,i-1,k,j) + c1(m1,i,k,jc)
+            ch(m2,i,k,j)    = c1(m1,i,k,j)   + c1(m1,i-1,k,jc)
+            ch(m2,i,k,jc)   = c1(m1,i,k,j)   - c1(m1,i-1,k,jc)
+          end do
+        end do
+      end do
+    end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do k = 1, l1
+        do i = 3, ido, 2
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            ch(m2,i-1,k,j)  = c1(m1,i-1,k,j) - c1(m1,i,k,jc)
+            ch(m2,i-1,k,jc) = c1(m1,i-1,k,j) + c1(m1,i,k,jc)
+            ch(m2,i,k,j)    = c1(m1,i,k,j)   + c1(m1,i-1,k,jc)
+            ch(m2,i,k,jc)   = c1(m1,i,k,j)   - c1(m1,i-1,k,jc)
+          end do
+        end do
+      end do
+    end do
+
+  end if
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  do ik = 1, idl1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      c2(m1,ik,1) = ch2(m2,ik,1)
+    end do
+  end do
+
+  do j = 2, ip
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        c1(m1,1,k,j) = ch(m2,1,k,j)
+      end do
+    end do
+  end do
+
+  if ( l1 < nbd ) then
+
+    is = -ido
+
+    do j = 2, ip
+      is = is + ido
+      do k = 1, l1
+        idij = is
+        do i = 3, ido, 2
+          idij = idij + 2
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            c1(m1,i-1,k,j) = wa(idij-1) * ch(m2,i-1,k,j) &
+                           - wa(idij)   * ch(m2,i,k,j)
+            c1(m1,i,k,j) =   wa(idij-1) * ch(m2,i,k,j) &
+                           + wa(idij)   * ch(m2,i-1,k,j)
+          end do
+        end do
+      end do
+    end do
+
+  else
+
+    is = -ido
+
+    do j = 2, ip
+      is = is + ido
+      idij = is
+      do i = 3, ido, 2
+        idij = idij + 2
+        do k = 1, l1
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            c1(m1,i-1,k,j) = wa(idij-1) * ch(m2,i-1,k,j) &
+                           - wa(idij)   * ch(m2,i,k,j)
+            c1(m1,i,k,j) =   wa(idij-1) * ch(m2,i,k,j) &
+                           + wa(idij)   * ch(m2,i-1,k,j)
+          end do
+        end do
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mradf2.F b/wrfv2_fire/external/fftpack/fftpack5/mradf2.F
index ebc3e11f..e06457ce 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mradf2.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mradf2.F
@@ -1,53 +1,112 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mradf2.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRADF2 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1) 
-      REAL       CH(IN2,IDO,2,L1) ,CC(IN1,IDO,L1,2) , WA1(IDO) 
-!                                                                       
-      M1D = (M-1)*IM1+1 
-      M2S = 1-IM2 
-      DO 101 K=1,L1 
-         M2 = M2S 
-         DO 1001 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH(M2,1,1,K) = CC(M1,1,K,1)+CC(M1,1,K,2) 
-         CH(M2,IDO,2,K) = CC(M1,1,K,1)-CC(M1,1,K,2) 
- 1001    CONTINUE 
-  101 END DO 
-      IF (IDO-2) 107,105,102 
-  102 IDP2 = IDO+2 
-      DO 104 K=1,L1 
-         DO 103 I=3,IDO,2 
-            IC = IDP2-I 
-            M2 = M2S 
-            DO 1003 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH(M2,I,1,K) = CC(M1,I,K,1)+(WA1(I-2)*CC(M1,I,K,2)-         &
-     &       WA1(I-1)*CC(M1,I-1,K,2))                                   
-            CH(M2,IC,2,K) = (WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*            &
-     &       CC(M1,I-1,K,2))-CC(M1,I,K,1)                               
-            CH(M2,I-1,1,K) = CC(M1,I-1,K,1)+(WA1(I-2)*CC(M1,I-1,K,2)+   &
-     &       WA1(I-1)*CC(M1,I,K,2))                                     
-            CH(M2,IC-1,2,K) = CC(M1,I-1,K,1)-(WA1(I-2)*CC(M1,I-1,K,2)+  &
-     &       WA1(I-1)*CC(M1,I,K,2))                                     
- 1003       CONTINUE 
-  103    CONTINUE 
-  104 END DO 
-      IF (MOD(IDO,2) .EQ. 1) RETURN 
-  105 DO 106 K=1,L1 
-         M2 = M2S 
-         DO 1006 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH(M2,1,2,K) = -CC(M1,IDO,K,2) 
-         CH(M2,IDO,1,K) = CC(M1,IDO,K,1) 
- 1006    CONTINUE 
-  106 END DO 
-  107 RETURN 
-      END                                           
+subroutine mradf2 ( m, ido, l1, cc, im1, in1, ch, im2, in2, wa1 )
+
+!*****************************************************************************80
+!
+!! MRADF2 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,ido,l1,2)
+  real ( kind = 4 ) ch(in2,ido,2,l1)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  real ( kind = 4 ) wa1(ido)
+
+  m1d = ( m - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,1,1,k)   = cc(m1,1,k,1) + cc(m1,1,k,2)
+      ch(m2,ido,2,k) = cc(m1,1,k,1) - cc(m1,1,k,2)
+    end do
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch(m2,i,1,k) =    cc(m1,i,k,1)   + ( wa1(i-2) * cc(m1,i,k,2) &
+                                             - wa1(i-1) * cc(m1,i-1,k,2) )
+          ch(m2,ic,2,k)  = -cc(m1,i,k,1)   + ( wa1(i-2) * cc(m1,i,k,2) &
+                                             - wa1(i-1) * cc(m1,i-1,k,2) )
+          ch(m2,i-1,1,k)  = cc(m1,i-1,k,1) + ( wa1(i-2) * cc(m1,i-1,k,2) &
+                                             + wa1(i-1) * cc(m1,i,k,2))
+          ch(m2,ic-1,2,k) = cc(m1,i-1,k,1) - ( wa1(i-2) * cc(m1,i-1,k,2) &
+                                             + wa1(i-1) * cc(m1,i,k,2) )
+        end do
+      end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,1,2,k) = -cc(m1,ido,k,2)
+      ch(m2,ido,1,k) = cc(m1,ido,k,1)
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mradf3.F b/wrfv2_fire/external/fftpack/fftpack5/mradf3.F
index e364f95d..68c13849 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mradf3.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mradf3.F
@@ -1,68 +1,121 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mradf3.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRADF3 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1,WA2) 
-      REAL       CH(IN2,IDO,3,L1)  ,CC(IN1,IDO,L1,3)     ,              &
-     &                WA1(IDO)     ,WA2(IDO)                            
-!                                                                       
-      M1D = (M-1)*IM1+1 
-      M2S = 1-IM2 
-      ARG=2.*4.*ATAN(1.0)/3. 
-      TAUR=COS(ARG) 
-      TAUI=SIN(ARG) 
-      DO 101 K=1,L1 
-         M2 = M2S 
-         DO 1001 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH(M2,1,1,K) = CC(M1,1,K,1)+(CC(M1,1,K,2)+CC(M1,1,K,3)) 
-         CH(M2,1,3,K) = TAUI*(CC(M1,1,K,3)-CC(M1,1,K,2)) 
-         CH(M2,IDO,2,K) = CC(M1,1,K,1)+TAUR*                            &
-     &      (CC(M1,1,K,2)+CC(M1,1,K,3))                                 
- 1001    CONTINUE 
-  101 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      IDP2 = IDO+2 
-      DO 103 K=1,L1 
-         DO 102 I=3,IDO,2 
-            IC = IDP2-I 
-            M2 = M2S 
-            DO 1002 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH(M2,I-1,1,K) = CC(M1,I-1,K,1)+((WA1(I-2)*CC(M1,I-1,K,2)+  &
-     &       WA1(I-1)*CC(M1,I,K,2))+(WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*  &
-     &       CC(M1,I,K,3)))                                             
-            CH(M2,I,1,K) = CC(M1,I,K,1)+((WA1(I-2)*CC(M1,I,K,2)-        &
-     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*  &
-     &       CC(M1,I-1,K,3)))                                           
-            CH(M2,I-1,3,K) = (CC(M1,I-1,K,1)+TAUR*((WA1(I-2)*           &
-     &       CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2))+(WA2(I-2)*           &
-     &       CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3))))+(TAUI*((WA1(I-2)*  &
-     &       CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2))-(WA2(I-2)*           &
-     &       CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3))))                    
-            CH(M2,IC-1,2,K) = (CC(M1,I-1,K,1)+TAUR*((WA1(I-2)*          &
-     &       CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2))+(WA2(I-2)*           &
-     &       CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3))))-(TAUI*((WA1(I-2)*  &
-     &       CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2))-(WA2(I-2)*           &
-     &       CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3))))                    
-            CH(M2,I,3,K) = (CC(M1,I,K,1)+TAUR*((WA1(I-2)*CC(M1,I,K,2)-  &
-     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*  &
-     &       CC(M1,I-1,K,3))))+(TAUI*((WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*&
-     &       CC(M1,I,K,3))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
-     &       CC(M1,I,K,2))))                                            
-            CH(M2,IC,2,K) = (TAUI*((WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*   &
-     &       CC(M1,I,K,3))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
-     &       CC(M1,I,K,2))))-(CC(M1,I,K,1)+TAUR*((WA1(I-2)*CC(M1,I,K,2)-&
-     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*  &
-     &       CC(M1,I-1,K,3))))                                          
- 1002       CONTINUE 
-  102    CONTINUE 
-  103 END DO 
-      RETURN 
-      END                                           
+subroutine mradf3 ( m, ido, l1, cc, im1, in1, ch, im2, in2, wa1, wa2 )
+
+!*****************************************************************************80
+!
+!! MRADF3 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) cc(in1,ido,l1,3)
+  real ( kind = 4 ) ch(in2,ido,3,l1)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  real ( kind = 4 ) taui
+  real ( kind = 4 ) taur
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+
+  m1d = ( m - 1 ) * im1 + 1
+  m2s = 1 - im2
+  arg = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 ) / 3.0E+00
+  taur = cos ( arg )
+  taui = sin ( arg )
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,1,1,k)   = cc(m1,1,k,1)        + ( cc(m1,1,k,2) + cc(m1,1,k,3) )
+      ch(m2,1,3,k)   =                taui * ( cc(m1,1,k,3) - cc(m1,1,k,2) )
+      ch(m2,ido,2,k) = cc(m1,1,k,1) + taur * ( cc(m1,1,k,2) + cc(m1,1,k,3) )
+     end do
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch(m2,i-1,1,k) = cc(m1,i-1,k,1)+((wa1(i-2)*cc(m1,i-1,k,2)+ &
+          wa1(i-1)*cc(m1,i,k,2))+(wa2(i-2)*cc(m1,i-1,k,3) + wa2(i-1)* &
+          cc(m1,i,k,3)))
+        ch(m2,i,1,k) = cc(m1,i,k,1)+((wa1(i-2)*cc(m1,i,k,2)- &
+          wa1(i-1)*cc(m1,i-1,k,2))+(wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
+          cc(m1,i-1,k,3)))
+        ch(m2,i-1,3,k) = (cc(m1,i-1,k,1)+taur*((wa1(i-2)* &
+          cc(m1,i-1,k,2) + wa1(i-1)*cc(m1,i,k,2))+(wa2(i-2)* &
+          cc(m1,i-1,k,3) + wa2(i-1)*cc(m1,i,k,3))))+(taui*((wa1(i-2)* &
+          cc(m1,i,k,2) - wa1(i-1)*cc(m1,i-1,k,2))-(wa2(i-2)* &
+          cc(m1,i,k,3) - wa2(i-1)*cc(m1,i-1,k,3))))
+        ch(m2,ic-1,2,k) = (cc(m1,i-1,k,1)+taur*((wa1(i-2)* &
+          cc(m1,i-1,k,2) + wa1(i-1)*cc(m1,i,k,2))+(wa2(i-2)* &
+          cc(m1,i-1,k,3) + wa2(i-1)*cc(m1,i,k,3))))-(taui*((wa1(i-2)* &
+          cc(m1,i,k,2) - wa1(i-1)*cc(m1,i-1,k,2)) - ( wa2(i-2)* &
+          cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3))))
+        ch(m2,i,3,k) = (cc(m1,i,k,1)+taur*((wa1(i-2)*cc(m1,i,k,2)- &
+          wa1(i-1)*cc(m1,i-1,k,2))+(wa2(i-2)*cc(m1,i,k,3) - wa2(i-1)* &
+          cc(m1,i-1,k,3))))+(taui*((wa2(i-2)*cc(m1,i-1,k,3) + wa2(i-1)* &
+          cc(m1,i,k,3))-(wa1(i-2)*cc(m1,i-1,k,2) + wa1(i-1)* &
+          cc(m1,i,k,2))))
+        ch(m2,ic,2,k) = (taui*((wa2(i-2)*cc(m1,i-1,k,3) + wa2(i-1)* &
+          cc(m1,i,k,3))-(wa1(i-2)*cc(m1,i-1,k,2) + wa1(i-1)* &
+          cc(m1,i,k,2))))-(cc(m1,i,k,1)+taur*((wa1(i-2)*cc(m1,i,k,2)- &
+          wa1(i-1)*cc(m1,i-1,k,2))+(wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
+          cc(m1,i-1,k,3))))
+      end do
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mradf4.F b/wrfv2_fire/external/fftpack/fftpack5/mradf4.F
index 8b2ab585..0cbd517d 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mradf4.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mradf4.F
@@ -1,90 +1,150 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mradf4.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRADF4 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,WA1,WA2,WA3) 
-      REAL       CC(IN1,IDO,L1,4)   ,CH(IN2,IDO,4,L1)     ,             &
-     &           WA1(IDO)           ,WA2(IDO)     ,WA3(IDO)             
-!                                                                       
-      HSQT2=SQRT(2.)/2. 
-      M1D = (M-1)*IM1+1 
-      M2S = 1-IM2 
-      DO 101 K=1,L1 
-         M2 = M2S 
-         DO 1001 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH(M2,1,1,K) = (CC(M1,1,K,2)+CC(M1,1,K,4))                     &
-     &      +(CC(M1,1,K,1)+CC(M1,1,K,3))                                
-         CH(M2,IDO,4,K) = (CC(M1,1,K,1)+CC(M1,1,K,3))                   &
-     &      -(CC(M1,1,K,2)+CC(M1,1,K,4))                                
-         CH(M2,IDO,2,K) = CC(M1,1,K,1)-CC(M1,1,K,3) 
-         CH(M2,1,3,K) = CC(M1,1,K,4)-CC(M1,1,K,2) 
- 1001    CONTINUE 
-  101 END DO 
-      IF (IDO-2) 107,105,102 
-  102 IDP2 = IDO+2 
-      DO 104 K=1,L1 
-         DO 103 I=3,IDO,2 
-            IC = IDP2-I 
-            M2 = M2S 
-            DO 1003 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH(M2,I-1,1,K) = ((WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*        &
-     &       CC(M1,I,K,2))+(WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*           &
-     &       CC(M1,I,K,4)))+(CC(M1,I-1,K,1)+(WA2(I-2)*CC(M1,I-1,K,3)+   &
-     &       WA2(I-1)*CC(M1,I,K,3)))                                    
-            CH(M2,IC-1,4,K) = (CC(M1,I-1,K,1)+(WA2(I-2)*CC(M1,I-1,K,3)+ &
-     &       WA2(I-1)*CC(M1,I,K,3)))-((WA1(I-2)*CC(M1,I-1,K,2)+         &
-     &       WA1(I-1)*CC(M1,I,K,2))+(WA3(I-2)*CC(M1,I-1,K,4)+           &
-     &       WA3(I-1)*CC(M1,I,K,4)))                                    
-            CH(M2,I,1,K) = ((WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*            &
-     &       CC(M1,I-1,K,2))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
-     &       CC(M1,I-1,K,4)))+(CC(M1,I,K,1)+(WA2(I-2)*CC(M1,I,K,3)-     &
-     &       WA2(I-1)*CC(M1,I-1,K,3)))                                  
-            CH(M2,IC,4,K) = ((WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*           &
-     &       CC(M1,I-1,K,2))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
-     &       CC(M1,I-1,K,4)))-(CC(M1,I,K,1)+(WA2(I-2)*CC(M1,I,K,3)-     &
-     &       WA2(I-1)*CC(M1,I-1,K,3)))                                  
-            CH(M2,I-1,3,K) = ((WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*          &
-     &       CC(M1,I-1,K,2))-(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
-     &       CC(M1,I-1,K,4)))+(CC(M1,I-1,K,1)-(WA2(I-2)*CC(M1,I-1,K,3)+ &
-     &       WA2(I-1)*CC(M1,I,K,3)))                                    
-            CH(M2,IC-1,2,K) = (CC(M1,I-1,K,1)-(WA2(I-2)*CC(M1,I-1,K,3)+ &
-     &       WA2(I-1)*CC(M1,I,K,3)))-((WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*  &
-     &       CC(M1,I-1,K,2))-(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
-     &       CC(M1,I-1,K,4)))                                           
-            CH(M2,I,3,K) = ((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*          &
-     &       CC(M1,I,K,4))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
-     &       CC(M1,I,K,2)))+(CC(M1,I,K,1)-(WA2(I-2)*CC(M1,I,K,3)-       &
-     &       WA2(I-1)*CC(M1,I-1,K,3)))                                  
-            CH(M2,IC,2,K) = ((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*         &
-     &       CC(M1,I,K,4))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
-     &       CC(M1,I,K,2)))-(CC(M1,I,K,1)-(WA2(I-2)*CC(M1,I,K,3)-       &
-     &       WA2(I-1)*CC(M1,I-1,K,3)))                                  
- 1003       CONTINUE 
-  103    CONTINUE 
-  104 END DO 
-      IF (MOD(IDO,2) .EQ. 1) RETURN 
-  105 CONTINUE 
-      DO 106 K=1,L1 
-         M2 = M2S 
-         DO 1006 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH(M2,IDO,1,K) = (HSQT2*(CC(M1,IDO,K,2)-CC(M1,IDO,K,4)))+   &
-     &       CC(M1,IDO,K,1)                                             
-            CH(M2,IDO,3,K) = CC(M1,IDO,K,1)-(HSQT2*(CC(M1,IDO,K,2)-     &
-     &       CC(M1,IDO,K,4)))                                           
-            CH(M2,1,2,K) = (-HSQT2*(CC(M1,IDO,K,2)+CC(M1,IDO,K,4)))-    &
-     &       CC(M1,IDO,K,3)                                             
-            CH(M2,1,4,K) = (-HSQT2*(CC(M1,IDO,K,2)+CC(M1,IDO,K,4)))+    &
-     &       CC(M1,IDO,K,3)                                             
- 1006    CONTINUE 
-  106 END DO 
-  107 RETURN 
-      END                                           
+subroutine mradf4 ( m, ido, l1, cc, im1, in1, ch, im2, in2, wa1, wa2, wa3 )
+
+!*****************************************************************************80
+!
+!! MRADF4 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,ido,l1,4)
+  real ( kind = 4 ) ch(in2,ido,4,l1)
+  real ( kind = 4 ) hsqt2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+  real ( kind = 4 ) wa3(ido)
+
+  hsqt2 = sqrt ( 2.0E+00 ) / 2.0E+00
+  m1d = ( m - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,1,1,k) =   ( cc(m1,1,k,2) + cc(m1,1,k,4) ) &
+                     + ( cc(m1,1,k,1) + cc(m1,1,k,3) )
+      ch(m2,ido,4,k) = ( cc(m1,1,k,1) + cc(m1,1,k,3) ) &
+                      -( cc(m1,1,k,2) + cc(m1,1,k,4) )
+      ch(m2,ido,2,k) =   cc(m1,1,k,1) - cc(m1,1,k,3)
+      ch(m2,1,3,k) =     cc(m1,1,k,4) - cc(m1,1,k,2)
+    end do
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch(m2,i-1,1,k) = ((wa1(i-2)*cc(m1,i-1,k,2) + wa1(i-1)* &
+            cc(m1,i,k,2))+(wa3(i-2)*cc(m1,i-1,k,4) + wa3(i-1)* &
+            cc(m1,i,k,4)))+(cc(m1,i-1,k,1)+(wa2(i-2)*cc(m1,i-1,k,3)+ &
+            wa2(i-1)*cc(m1,i,k,3)))
+          ch(m2,ic-1,4,k) = (cc(m1,i-1,k,1)+(wa2(i-2)*cc(m1,i-1,k,3)+ &
+            wa2(i-1)*cc(m1,i,k,3)))-((wa1(i-2)*cc(m1,i-1,k,2)+ &
+            wa1(i-1)*cc(m1,i,k,2))+(wa3(i-2)*cc(m1,i-1,k,4)+ &
+            wa3(i-1)*cc(m1,i,k,4)))
+          ch(m2,i,1,k) = ((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* &
+            cc(m1,i-1,k,2))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
+            cc(m1,i-1,k,4)))+(cc(m1,i,k,1)+(wa2(i-2)*cc(m1,i,k,3)- &
+            wa2(i-1)*cc(m1,i-1,k,3)))
+          ch(m2,ic,4,k) = ((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* &
+            cc(m1,i-1,k,2))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
+            cc(m1,i-1,k,4)))-(cc(m1,i,k,1)+(wa2(i-2)*cc(m1,i,k,3)- &
+            wa2(i-1)*cc(m1,i-1,k,3)))
+          ch(m2,i-1,3,k) = ((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* &
+            cc(m1,i-1,k,2))-(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
+            cc(m1,i-1,k,4)))+(cc(m1,i-1,k,1)-(wa2(i-2)*cc(m1,i-1,k,3)+ &
+            wa2(i-1)*cc(m1,i,k,3)))
+          ch(m2,ic-1,2,k) = (cc(m1,i-1,k,1)-(wa2(i-2)*cc(m1,i-1,k,3)+ &
+            wa2(i-1)*cc(m1,i,k,3)))-((wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)* &
+            cc(m1,i-1,k,2))-(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
+            cc(m1,i-1,k,4)))
+          ch(m2,i,3,k) = ((wa3(i-2)*cc(m1,i-1,k,4) + wa3(i-1)* &
+            cc(m1,i,k,4))-(wa1(i-2)*cc(m1,i-1,k,2) + wa1(i-1)* &
+            cc(m1,i,k,2)))+(cc(m1,i,k,1)-(wa2(i-2)*cc(m1,i,k,3)- &
+            wa2(i-1)*cc(m1,i-1,k,3)))
+          ch(m2,ic,2,k) = ((wa3(i-2)*cc(m1,i-1,k,4) + wa3(i-1)* &
+            cc(m1,i,k,4))-(wa1(i-2)*cc(m1,i-1,k,2) + wa1(i-1)* &
+            cc(m1,i,k,2)))-(cc(m1,i,k,1)-(wa2(i-2)*cc(m1,i,k,3)- &
+            wa2(i-1)*cc(m1,i-1,k,3)))
+        end do
+      end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,ido,1,k) = cc(m1,ido,k,1) &
+        + (  hsqt2 * ( cc(m1,ido,k,2) - cc(m1,ido,k,4) ) )
+      ch(m2,ido,3,k) = cc(m1,ido,k,1) &
+        - (  hsqt2 * ( cc(m1,ido,k,2) - cc(m1,ido,k,4) ) )
+      ch(m2,1,2,k) =  -cc(m1,ido,k,3) &
+        + ( -hsqt2 * ( cc(m1,ido,k,2) + cc(m1,ido,k,4) ) )
+      ch(m2,1,4,k) =   cc(m1,ido,k,3) &
+        + ( -hsqt2 * ( cc(m1,ido,k,2) + cc(m1,ido,k,4) ) )
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mradf5.F b/wrfv2_fire/external/fftpack/fftpack5/mradf5.F
index 18b5a94a..49bc67ff 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mradf5.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mradf5.F
@@ -1,133 +1,190 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mradf5.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRADF5 (M,IDO,L1,CC,IM1,IN1,CH,IM2,IN2,                &
-     &                   WA1,WA2,WA3,WA4)                               
-      REAL       CC(IN1,IDO,L1,5)    ,CH(IN2,IDO,5,L1)     ,            &
-     &           WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)     
-!                                                                       
-      M1D = (M-1)*IM1+1 
-      M2S = 1-IM2 
-      ARG=2.*4.*ATAN(1.0)/5. 
-      TR11=COS(ARG) 
-      TI11=SIN(ARG) 
-      TR12=COS(2.*ARG) 
-      TI12=SIN(2.*ARG) 
-      DO 101 K=1,L1 
-         M2 = M2S 
-         DO 1001 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH(M2,1,1,K) = CC(M1,1,K,1)+(CC(M1,1,K,5)+CC(M1,1,K,2))+       &
-     &    (CC(M1,1,K,4)+CC(M1,1,K,3))                                   
-         CH(M2,IDO,2,K) = CC(M1,1,K,1)+TR11*(CC(M1,1,K,5)+CC(M1,1,K,2))+&
-     &    TR12*(CC(M1,1,K,4)+CC(M1,1,K,3))                              
-         CH(M2,1,3,K) = TI11*(CC(M1,1,K,5)-CC(M1,1,K,2))+TI12*          &
-     &    (CC(M1,1,K,4)-CC(M1,1,K,3))                                   
-         CH(M2,IDO,4,K) = CC(M1,1,K,1)+TR12*(CC(M1,1,K,5)+CC(M1,1,K,2))+&
-     &    TR11*(CC(M1,1,K,4)+CC(M1,1,K,3))                              
-         CH(M2,1,5,K) = TI12*(CC(M1,1,K,5)-CC(M1,1,K,2))-TI11*          &
-     &    (CC(M1,1,K,4)-CC(M1,1,K,3))                                   
- 1001    CONTINUE 
-  101 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      IDP2 = IDO+2 
-      DO 103 K=1,L1 
-         DO 102 I=3,IDO,2 
-            IC = IDP2-I 
-            M2 = M2S 
-            DO 1002 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH(M2,I-1,1,K) = CC(M1,I-1,K,1)+((WA1(I-2)*CC(M1,I-1,K,2)+  &
-     &       WA1(I-1)*CC(M1,I,K,2))+(WA4(I-2)*CC(M1,I-1,K,5)+WA4(I-1)*  &
-     &       CC(M1,I,K,5)))+((WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*         &
-     &       CC(M1,I,K,3))+(WA3(I-2)*CC(M1,I-1,K,4)+                    &
-     &       WA3(I-1)*CC(M1,I,K,4)))                                    
-            CH(M2,I,1,K) = CC(M1,I,K,1)+((WA1(I-2)*CC(M1,I,K,2)-        &
-     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*  &
-     &       CC(M1,I-1,K,5)))+((WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*         &
-     &       CC(M1,I-1,K,3))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
-     &       CC(M1,I-1,K,4)))                                           
-            CH(M2,I-1,3,K) = CC(M1,I-1,K,1)+TR11*                       &
-     &      ( WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2)             &
-     &       +WA4(I-2)*CC(M1,I-1,K,5)+WA4(I-1)*CC(M1,I,K,5))+TR12*      &
-     &      ( WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3)             &
-     &       +WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*CC(M1,I,K,4))+TI11*      &
-     &      ( WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2)             &
-     &       -(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*CC(M1,I-1,K,5)))+TI12*    &
-     &      ( WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3)             &
-     &       -(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*CC(M1,I-1,K,4)))          
-            CH(M2,IC-1,2,K) = CC(M1,I-1,K,1)+TR11*                      &
-     &      ( WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2)             &
-     &       +WA4(I-2)*CC(M1,I-1,K,5)+WA4(I-1)*CC(M1,I,K,5))+TR12*      &
-     &     ( WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3)              &
-     &      +WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*CC(M1,I,K,4))-(TI11*      &
-     &      ( WA1(I-2)*CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2)             &
-     &       -(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*CC(M1,I-1,K,5)))+TI12*    &
-     &      ( WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3)             &
-     &       -(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*CC(M1,I-1,K,4))))         
-            CH(M2,I,3,K) = (CC(M1,I,K,1)+TR11*((WA1(I-2)*CC(M1,I,K,2)-  &
-     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*  &
-     &       CC(M1,I-1,K,5)))+TR12*((WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*    &
-     &       CC(M1,I-1,K,3))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
-     &       CC(M1,I-1,K,4))))+(TI11*((WA4(I-2)*CC(M1,I-1,K,5)+         &
-     &       WA4(I-1)*CC(M1,I,K,5))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*  &
-     &       CC(M1,I,K,2)))+TI12*((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*    &
-     &       CC(M1,I,K,4))-(WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*           &
-     &       CC(M1,I,K,3))))                                            
-            CH(M2,IC,2,K) = (TI11*((WA4(I-2)*CC(M1,I-1,K,5)+WA4(I-1)*   &
-     &       CC(M1,I,K,5))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
-     &       CC(M1,I,K,2)))+TI12*((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*    &
-     &       CC(M1,I,K,4))-(WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*           &
-     &       CC(M1,I,K,3))))-(CC(M1,I,K,1)+TR11*((WA1(I-2)*CC(M1,I,K,2)-&
-     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*  &
-     &       CC(M1,I-1,K,5)))+TR12*((WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*    &
-     &       CC(M1,I-1,K,3))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
-     &       CC(M1,I-1,K,4))))                                          
-            CH(M2,I-1,5,K) = (CC(M1,I-1,K,1)+TR12*((WA1(I-2)*           &
-     &       CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2))+(WA4(I-2)*           &
-     &       CC(M1,I-1,K,5)+WA4(I-1)*CC(M1,I,K,5)))+TR11*((WA2(I-2)*    &
-     &       CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3))+(WA3(I-2)*           &
-     &       CC(M1,I-1,K,4)+WA3(I-1)*CC(M1,I,K,4))))+(TI12*((WA1(I-2)*  &
-     &       CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2))-(WA4(I-2)*           &
-     &       CC(M1,I,K,5)-WA4(I-1)*CC(M1,I-1,K,5)))-TI11*((WA2(I-2)*    &
-     &       CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3))-(WA3(I-2)*           &
-     &       CC(M1,I,K,4)-WA3(I-1)*CC(M1,I-1,K,4))))                    
-            CH(M2,IC-1,4,K) = (CC(M1,I-1,K,1)+TR12*((WA1(I-2)*          &
-     &       CC(M1,I-1,K,2)+WA1(I-1)*CC(M1,I,K,2))+(WA4(I-2)*           &
-     &       CC(M1,I-1,K,5)+WA4(I-1)*CC(M1,I,K,5)))+TR11*((WA2(I-2)*    &
-     &       CC(M1,I-1,K,3)+WA2(I-1)*CC(M1,I,K,3))+(WA3(I-2)*           &
-     &       CC(M1,I-1,K,4)+WA3(I-1)*CC(M1,I,K,4))))-(TI12*((WA1(I-2)*  &
-     &       CC(M1,I,K,2)-WA1(I-1)*CC(M1,I-1,K,2))-(WA4(I-2)*           &
-     &       CC(M1,I,K,5)-WA4(I-1)*CC(M1,I-1,K,5)))-TI11*((WA2(I-2)*    &
-     &       CC(M1,I,K,3)-WA2(I-1)*CC(M1,I-1,K,3))-(WA3(I-2)*           &
-     &       CC(M1,I,K,4)-WA3(I-1)*CC(M1,I-1,K,4))))                    
-            CH(M2,I,5,K) = (CC(M1,I,K,1)+TR12*((WA1(I-2)*CC(M1,I,K,2)-  &
-     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*  &
-     &       CC(M1,I-1,K,5)))+TR11*((WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*    &
-     &       CC(M1,I-1,K,3))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
-     &       CC(M1,I-1,K,4))))+(TI12*((WA4(I-2)*CC(M1,I-1,K,5)+         &
-     &       WA4(I-1)*CC(M1,I,K,5))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*  &
-     &       CC(M1,I,K,2)))-TI11*((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*    &
-     &       CC(M1,I,K,4))-(WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*           &
-     &       CC(M1,I,K,3))))                                            
-            CH(M2,IC,4,K) = (TI12*((WA4(I-2)*CC(M1,I-1,K,5)+WA4(I-1)*   &
-     &       CC(M1,I,K,5))-(WA1(I-2)*CC(M1,I-1,K,2)+WA1(I-1)*           &
-     &       CC(M1,I,K,2)))-TI11*((WA3(I-2)*CC(M1,I-1,K,4)+WA3(I-1)*    &
-     &       CC(M1,I,K,4))-(WA2(I-2)*CC(M1,I-1,K,3)+WA2(I-1)*           &
-     &       CC(M1,I,K,3))))-(CC(M1,I,K,1)+TR12*((WA1(I-2)*CC(M1,I,K,2)-&
-     &       WA1(I-1)*CC(M1,I-1,K,2))+(WA4(I-2)*CC(M1,I,K,5)-WA4(I-1)*  &
-     &       CC(M1,I-1,K,5)))+TR11*((WA2(I-2)*CC(M1,I,K,3)-WA2(I-1)*    &
-     &       CC(M1,I-1,K,3))+(WA3(I-2)*CC(M1,I,K,4)-WA3(I-1)*           &
-     &       CC(M1,I-1,K,4))))                                          
- 1002       CONTINUE 
-  102    CONTINUE 
-  103 END DO 
-      RETURN 
-      END                                           
+subroutine mradf5 ( m, ido, l1, cc, im1, in1, ch, im2, in2, wa1, wa2, wa3, wa4 )
+
+!*****************************************************************************80
+!
+!! MRADF5 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) cc(in1,ido,l1,5)
+  real ( kind = 4 ) ch(in2,ido,5,l1)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  real ( kind = 4 ) ti11
+  real ( kind = 4 ) ti12
+  real ( kind = 4 ) tr11
+  real ( kind = 4 ) tr12
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+  real ( kind = 4 ) wa3(ido)
+  real ( kind = 4 ) wa4(ido)
+
+  m1d = ( m - 1 ) * im1 + 1
+  m2s = 1 - im2
+  arg = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 ) / 5.0E+00
+  tr11 = cos ( arg )
+  ti11 = sin ( arg )
+  tr12 = cos ( 2.0E+00 * arg )
+  ti12 = sin ( 2.0E+00 * arg )
+
+  do k = 1, l1
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch(m2,1,1,k) = cc(m1,1,k,1) + ( cc(m1,1,k,5) + cc(m1,1,k,2) ) &
+                                  + ( cc(m1,1,k,4) + cc(m1,1,k,3) )
+      ch(m2,ido,2,k) = cc(m1,1,k,1) + tr11 * ( cc(m1,1,k,5) + cc(m1,1,k,2) ) &
+                                    + tr12 * ( cc(m1,1,k,4) + cc(m1,1,k,3) )
+      ch(m2,1,3,k) = ti11 * ( cc(m1,1,k,5) - cc(m1,1,k,2) ) &
+                   + ti12 * ( cc(m1,1,k,4) - cc(m1,1,k,3) )
+      ch(m2,ido,4,k) = cc(m1,1,k,1) + tr12 * ( cc(m1,1,k,5) + cc(m1,1,k,2) ) &
+                                    + tr11 * ( cc(m1,1,k,4) + cc(m1,1,k,3) )
+      ch(m2,1,5,k) = ti12 * ( cc(m1,1,k,5) - cc(m1,1,k,2) ) &
+                   - ti11 * ( cc(m1,1,k,4) - cc(m1,1,k,3) )
+    end do
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch(m2,i-1,1,k) = cc(m1,i-1,k,1)+((wa1(i-2)*cc(m1,i-1,k,2)+ &
+          wa1(i-1)*cc(m1,i,k,2))+(wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)* &
+          cc(m1,i,k,5)))+((wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
+          cc(m1,i,k,3))+(wa3(i-2)*cc(m1,i-1,k,4)+ &
+          wa3(i-1)*cc(m1,i,k,4)))
+        ch(m2,i,1,k) = cc(m1,i,k,1)+((wa1(i-2)*cc(m1,i,k,2)- &
+          wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* &
+          cc(m1,i-1,k,5)))+((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
+          cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
+          cc(m1,i-1,k,4)))
+        ch(m2,i-1,3,k) = cc(m1,i-1,k,1)+tr11* &
+          ( wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2) &
+          +wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5))+tr12* &
+          ( wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3) &
+          +wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))+ti11* &
+          ( wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2) &
+          -(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))+ti12* &
+          ( wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3) &
+          -(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4)))
+        ch(m2,ic-1,2,k) = cc(m1,i-1,k,1)+tr11* &
+          ( wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2) &
+          +wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5))+tr12* &
+          ( wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3) &
+          +wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))-(ti11* &
+          ( wa1(i-2)*cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2) &
+          -(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))+ti12* &
+          ( wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3) &
+          -(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4))))
+        ch(m2,i,3,k) = (cc(m1,i,k,1)+tr11*((wa1(i-2)*cc(m1,i,k,2)- &
+          wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* &
+          cc(m1,i-1,k,5)))+tr12*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
+          cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
+          cc(m1,i-1,k,4))))+(ti11*((wa4(i-2)*cc(m1,i-1,k,5)+ &
+          wa4(i-1)*cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
+          cc(m1,i,k,2)))+ti12*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* &
+          cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
+          cc(m1,i,k,3))))
+        ch(m2,ic,2,k) = (ti11*((wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)* &
+          cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
+          cc(m1,i,k,2)))+ti12*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* &
+          cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
+          cc(m1,i,k,3))))-(cc(m1,i,k,1)+tr11*((wa1(i-2)*cc(m1,i,k,2)- &
+          wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* &
+          cc(m1,i-1,k,5)))+tr12*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
+          cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
+          cc(m1,i-1,k,4))))
+        ch(m2,i-1,5,k) = (cc(m1,i-1,k,1)+tr12*((wa1(i-2)* &
+          cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2))+(wa4(i-2)* &
+          cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5)))+tr11*((wa2(i-2)* &
+          cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3))+(wa3(i-2)* &
+          cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))))+(ti12*((wa1(i-2)* &
+          cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2))-(wa4(i-2)* &
+          cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))-ti11*((wa2(i-2)* &
+          cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3))-(wa3(i-2)* &
+          cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4))))
+        ch(m2,ic-1,4,k) = (cc(m1,i-1,k,1)+tr12*((wa1(i-2)* &
+          cc(m1,i-1,k,2)+wa1(i-1)*cc(m1,i,k,2))+(wa4(i-2)* &
+          cc(m1,i-1,k,5)+wa4(i-1)*cc(m1,i,k,5)))+tr11*((wa2(i-2)* &
+          cc(m1,i-1,k,3)+wa2(i-1)*cc(m1,i,k,3))+(wa3(i-2)* &
+          cc(m1,i-1,k,4)+wa3(i-1)*cc(m1,i,k,4))))-(ti12*((wa1(i-2)* &
+          cc(m1,i,k,2)-wa1(i-1)*cc(m1,i-1,k,2))-(wa4(i-2)* &
+          cc(m1,i,k,5)-wa4(i-1)*cc(m1,i-1,k,5)))-ti11*((wa2(i-2)* &
+          cc(m1,i,k,3)-wa2(i-1)*cc(m1,i-1,k,3))-(wa3(i-2)* &
+          cc(m1,i,k,4)-wa3(i-1)*cc(m1,i-1,k,4))))
+        ch(m2,i,5,k) = (cc(m1,i,k,1)+tr12*((wa1(i-2)*cc(m1,i,k,2)- &
+          wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* &
+          cc(m1,i-1,k,5)))+tr11*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
+          cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
+          cc(m1,i-1,k,4))))+(ti12*((wa4(i-2)*cc(m1,i-1,k,5)+ &
+          wa4(i-1)*cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
+          cc(m1,i,k,2)))-ti11*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* &
+          cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
+          cc(m1,i,k,3))))
+        ch(m2,ic,4,k) = (ti12*((wa4(i-2)*cc(m1,i-1,k,5)+wa4(i-1)* &
+          cc(m1,i,k,5))-(wa1(i-2)*cc(m1,i-1,k,2)+wa1(i-1)* &
+          cc(m1,i,k,2)))-ti11*((wa3(i-2)*cc(m1,i-1,k,4)+wa3(i-1)* &
+          cc(m1,i,k,4))-(wa2(i-2)*cc(m1,i-1,k,3)+wa2(i-1)* &
+          cc(m1,i,k,3))))-(cc(m1,i,k,1)+tr12*((wa1(i-2)*cc(m1,i,k,2)- &
+          wa1(i-1)*cc(m1,i-1,k,2))+(wa4(i-2)*cc(m1,i,k,5)-wa4(i-1)* &
+          cc(m1,i-1,k,5)))+tr11*((wa2(i-2)*cc(m1,i,k,3)-wa2(i-1)* &
+          cc(m1,i-1,k,3))+(wa3(i-2)*cc(m1,i,k,4)-wa3(i-1)* &
+          cc(m1,i-1,k,4))))
+      end do
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mradfg.F b/wrfv2_fire/external/fftpack/fftpack5/mradfg.F
index 9ae16419..f988b441 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mradfg.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mradfg.F
@@ -1,248 +1,361 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mradfg.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRADFG (M,IDO,IP,L1,IDL1,CC,C1,C2,IM1,IN1,             &
-     &              CH,CH2,IM2,IN2,WA)                                  
-      REAL          CH(IN2,IDO,L1,IP)   ,CC(IN1,IDO,IP,L1),             &
-     &              C1(IN1,IDO,L1,IP)   ,C2(IN1,IDL1,IP),               &
-     &              CH2(IN2,IDL1,IP)    ,WA(IDO)                        
-!                                                                       
-      M1D = (M-1)*IM1+1 
-      M2S = 1-IM2 
-      TPI=2.*4.*ATAN(1.0) 
-      ARG = TPI/FLOAT(IP) 
-      DCP = COS(ARG) 
-      DSP = SIN(ARG) 
-      IPPH = (IP+1)/2 
-      IPP2 = IP+2 
-      IDP2 = IDO+2 
-      NBD = (IDO-1)/2 
-      IF (IDO .EQ. 1) GO TO 119 
-      DO 101 IK=1,IDL1 
-         M2 = M2S 
-         DO 1001 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         CH2(M2,IK,1) = C2(M1,IK,1) 
- 1001    CONTINUE 
-  101 END DO 
-      DO 103 J=2,IP 
-         DO 102 K=1,L1 
-            M2 = M2S 
-            DO 1002 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH(M2,1,K,J) = C1(M1,1,K,J) 
- 1002       CONTINUE 
-  102    CONTINUE 
-  103 END DO 
-      IF (NBD .GT. L1) GO TO 107 
-      IS = -IDO 
-      DO 106 J=2,IP 
-         IS = IS+IDO 
-         IDIJ = IS 
-         DO 105 I=3,IDO,2 
-            IDIJ = IDIJ+2 
-            DO 104 K=1,L1 
-               M2 = M2S 
-               DO 1004 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CH(M2,I-1,K,J) = WA(IDIJ-1)*C1(M1,I-1,K,J)+WA(IDIJ)      &
-     &           *C1(M1,I,K,J)                                          
-               CH(M2,I,K,J) = WA(IDIJ-1)*C1(M1,I,K,J)-WA(IDIJ)          &
-     &           *C1(M1,I-1,K,J)                                        
- 1004          CONTINUE 
-  104       CONTINUE 
-  105    CONTINUE 
-  106 END DO 
-      GO TO 111 
-  107 IS = -IDO 
-      DO 110 J=2,IP 
-         IS = IS+IDO 
-         DO 109 K=1,L1 
-            IDIJ = IS 
-            DO 108 I=3,IDO,2 
-               IDIJ = IDIJ+2 
-               M2 = M2S 
-               DO 1008 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CH(M2,I-1,K,J) = WA(IDIJ-1)*C1(M1,I-1,K,J)+WA(IDIJ)      &
-     &           *C1(M1,I,K,J)                                          
-               CH(M2,I,K,J) = WA(IDIJ-1)*C1(M1,I,K,J)-WA(IDIJ)          &
-     &           *C1(M1,I-1,K,J)                                        
- 1008          CONTINUE 
-  108       CONTINUE 
-  109    CONTINUE 
-  110 END DO 
-  111 IF (NBD .LT. L1) GO TO 115 
-      DO 114 J=2,IPPH 
-         JC = IPP2-J 
-         DO 113 K=1,L1 
-            DO 112 I=3,IDO,2 
-               M2 = M2S 
-               DO 1012 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               C1(M1,I-1,K,J) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC) 
-               C1(M1,I-1,K,JC) = CH(M2,I,K,J)-CH(M2,I,K,JC) 
-               C1(M1,I,K,J) = CH(M2,I,K,J)+CH(M2,I,K,JC) 
-               C1(M1,I,K,JC) = CH(M2,I-1,K,JC)-CH(M2,I-1,K,J) 
- 1012          CONTINUE 
-  112       CONTINUE 
-  113    CONTINUE 
-  114 END DO 
-      GO TO 121 
-  115 DO 118 J=2,IPPH 
-         JC = IPP2-J 
-         DO 117 I=3,IDO,2 
-            DO 116 K=1,L1 
-               M2 = M2S 
-               DO 1016 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               C1(M1,I-1,K,J) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC) 
-               C1(M1,I-1,K,JC) = CH(M2,I,K,J)-CH(M2,I,K,JC) 
-               C1(M1,I,K,J) = CH(M2,I,K,J)+CH(M2,I,K,JC) 
-               C1(M1,I,K,JC) = CH(M2,I-1,K,JC)-CH(M2,I-1,K,J) 
- 1016          CONTINUE 
-  116       CONTINUE 
-  117    CONTINUE 
-  118 END DO 
-      GO TO 121 
-  119 DO 120 IK=1,IDL1 
-         M2 = M2S 
-         DO 1020 M1=1,M1D,IM1 
-         M2 = M2+IM2 
-         C2(M1,IK,1) = CH2(M2,IK,1) 
- 1020    CONTINUE 
-  120 END DO 
-  121 DO 123 J=2,IPPH 
-         JC = IPP2-J 
-         DO 122 K=1,L1 
-            M2 = M2S 
-            DO 1022 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            C1(M1,1,K,J) = CH(M2,1,K,J)+CH(M2,1,K,JC) 
-            C1(M1,1,K,JC) = CH(M2,1,K,JC)-CH(M2,1,K,J) 
- 1022       CONTINUE 
-  122    CONTINUE 
-  123 END DO 
-!                                                                       
-      AR1 = 1. 
-      AI1 = 0. 
-      DO 127 L=2,IPPH 
-         LC = IPP2-L 
-         AR1H = DCP*AR1-DSP*AI1 
-         AI1 = DCP*AI1+DSP*AR1 
-         AR1 = AR1H 
-         DO 124 IK=1,IDL1 
-            M2 = M2S 
-            DO 1024 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH2(M2,IK,L) = C2(M1,IK,1)+AR1*C2(M1,IK,2) 
-            CH2(M2,IK,LC) = AI1*C2(M1,IK,IP) 
- 1024       CONTINUE 
-  124    CONTINUE 
-         DC2 = AR1 
-         DS2 = AI1 
-         AR2 = AR1 
-         AI2 = AI1 
-         DO 126 J=3,IPPH 
-            JC = IPP2-J 
-            AR2H = DC2*AR2-DS2*AI2 
-            AI2 = DC2*AI2+DS2*AR2 
-            AR2 = AR2H 
-            DO 125 IK=1,IDL1 
-               M2 = M2S 
-               DO 1025 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CH2(M2,IK,L) = CH2(M2,IK,L)+AR2*C2(M1,IK,J) 
-               CH2(M2,IK,LC) = CH2(M2,IK,LC)+AI2*C2(M1,IK,JC) 
- 1025          CONTINUE 
-  125       CONTINUE 
-  126    CONTINUE 
-  127 END DO 
-      DO 129 J=2,IPPH 
-         DO 128 IK=1,IDL1 
-            M2 = M2S 
-            DO 1028 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CH2(M2,IK,1) = CH2(M2,IK,1)+C2(M1,IK,J) 
- 1028       CONTINUE 
-  128    CONTINUE 
-  129 END DO 
-!                                                                       
-      IF (IDO .LT. L1) GO TO 132 
-      DO 131 K=1,L1 
-         DO 130 I=1,IDO 
-            M2 = M2S 
-            DO 1030 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CC(M1,I,1,K) = CH(M2,I,K,1) 
- 1030       CONTINUE 
-  130    CONTINUE 
-  131 END DO 
-      GO TO 135 
-  132 DO 134 I=1,IDO 
-         DO 133 K=1,L1 
-            M2 = M2S 
-            DO 1033 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CC(M1,I,1,K) = CH(M2,I,K,1) 
- 1033       CONTINUE 
-  133    CONTINUE 
-  134 END DO 
-  135 DO 137 J=2,IPPH 
-         JC = IPP2-J 
-         J2 = J+J 
-         DO 136 K=1,L1 
-            M2 = M2S 
-            DO 1036 M1=1,M1D,IM1 
-            M2 = M2+IM2 
-            CC(M1,IDO,J2-2,K) = CH(M2,1,K,J) 
-            CC(M1,1,J2-1,K) = CH(M2,1,K,JC) 
- 1036       CONTINUE 
-  136    CONTINUE 
-  137 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      IF (NBD .LT. L1) GO TO 141 
-      DO 140 J=2,IPPH 
-         JC = IPP2-J 
-         J2 = J+J 
-         DO 139 K=1,L1 
-            DO 138 I=3,IDO,2 
-               IC = IDP2-I 
-               M2 = M2S 
-               DO 1038 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CC(M1,I-1,J2-1,K) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC) 
-               CC(M1,IC-1,J2-2,K) = CH(M2,I-1,K,J)-CH(M2,I-1,K,JC) 
-               CC(M1,I,J2-1,K) = CH(M2,I,K,J)+CH(M2,I,K,JC) 
-               CC(M1,IC,J2-2,K) = CH(M2,I,K,JC)-CH(M2,I,K,J) 
- 1038          CONTINUE 
-  138       CONTINUE 
-  139    CONTINUE 
-  140 END DO 
-      RETURN 
-  141 DO 144 J=2,IPPH 
-         JC = IPP2-J 
-         J2 = J+J 
-         DO 143 I=3,IDO,2 
-            IC = IDP2-I 
-            DO 142 K=1,L1 
-               M2 = M2S 
-               DO 1042 M1=1,M1D,IM1 
-               M2 = M2+IM2 
-               CC(M1,I-1,J2-1,K) = CH(M2,I-1,K,J)+CH(M2,I-1,K,JC) 
-               CC(M1,IC-1,J2-2,K) = CH(M2,I-1,K,J)-CH(M2,I-1,K,JC) 
-               CC(M1,I,J2-1,K) = CH(M2,I,K,J)+CH(M2,I,K,JC) 
-               CC(M1,IC,J2-2,K) = CH(M2,I,K,JC)-CH(M2,I,K,J) 
- 1042          CONTINUE 
-  142       CONTINUE 
-  143    CONTINUE 
-  144 END DO 
-      RETURN 
-      END                                           
+subroutine mradfg ( m, ido, ip, l1, idl1, cc, c1, c2, im1, in1, &
+  ch, ch2, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! MRADFG is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) ai1
+  real ( kind = 4 ) ai2
+  real ( kind = 4 ) ar1
+  real ( kind = 4 ) ar1h
+  real ( kind = 4 ) ar2
+  real ( kind = 4 ) ar2h
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) c1(in1,ido,l1,ip)
+  real ( kind = 4 ) c2(in1,idl1,ip)
+  real ( kind = 4 ) cc(in1,ido,ip,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,ip)
+  real ( kind = 4 ) ch2(in2,idl1,ip)
+  real ( kind = 4 ) dc2
+  real ( kind = 4 ) dcp
+  real ( kind = 4 ) ds2
+  real ( kind = 4 ) dsp
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idij
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) ik
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) is
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) j2
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) nbd
+  real ( kind = 4 ) tpi
+  real ( kind = 4 ) wa(ido)
+
+  m1d = ( m - 1 ) * im1 + 1
+  m2s = 1 - im2
+  tpi = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 )
+  arg = tpi / real ( ip, kind = 4 )
+  dcp = cos ( arg )
+  dsp = sin ( arg )
+  ipph = ( ip + 1 ) / 2
+  ipp2 = ip + 2
+  idp2 = ido + 2
+  nbd = ( ido - 1 ) / 2
+
+  if ( ido == 1 ) then
+    do ik = 1, idl1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        c2(m1,ik,1) = ch2(m2,ik,1)
+      end do
+    end do
+
+  else
+
+    do ik = 1, idl1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch2(m2,ik,1) = c2(m1,ik,1)
+      end do
+    end do
+
+    do j = 2, ip
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch(m2,1,k,j) = c1(m1,1,k,j)
+        end do
+      end do
+    end do
+
+    if ( l1 < nbd ) then
+
+      is = -ido
+
+      do j = 2, ip
+        is = is + ido
+        do k = 1, l1
+          idij = is
+          do i = 3, ido, 2
+            idij = idij + 2
+            m2 = m2s
+            do m1 = 1, m1d, im1
+              m2 = m2 + im2
+              ch(m2,i-1,k,j) = wa(idij-1) * c1(m1,i-1,k,j) &
+                             + wa(idij)   * c1(m1,i,k,j)
+              ch(m2,i,k,j) =   wa(idij-1) * c1(m1,i,k,j)   &
+                             - wa(idij)   * c1(m1,i-1,k,j)
+            end do
+          end do
+        end do
+      end do
+
+    else
+
+      is = -ido
+      do j = 2, ip
+        is = is + ido
+        idij = is
+        do i = 3, ido, 2
+          idij = idij + 2
+          do k = 1, l1
+            m2 = m2s
+            do m1 = 1, m1d, im1
+              m2 = m2 + im2
+              ch(m2,i-1,k,j) = wa(idij-1) * c1(m1,i-1,k,j) &
+                             + wa(idij)   * c1(m1,i,k,j)
+              ch(m2,i,k,j) =   wa(idij-1) * c1(m1,i,k,j)   &
+                             - wa(idij)   * c1(m1,i-1,k,j)
+            end do
+          end do
+        end do
+      end do
+
+    end if
+
+    if ( nbd < l1 ) then
+
+      do j = 2, ipph
+        jc = ipp2 - j
+        do i = 3, ido, 2
+          do k = 1, l1
+            m2 = m2s
+            do m1 = 1, m1d, im1
+              m2 = m2 + im2
+              c1(m1,i-1,k,j)  = ch(m2,i-1,k,j)  + ch(m2,i-1,k,jc)
+              c1(m1,i-1,k,jc) = ch(m2,i,k,j)    - ch(m2,i,k,jc)
+              c1(m1,i,k,j)    = ch(m2,i,k,j)    + ch(m2,i,k,jc)
+              c1(m1,i,k,jc)   = ch(m2,i-1,k,jc) - ch(m2,i-1,k,j)
+            end do
+          end do
+        end do
+      end do
+
+    else
+
+      do j = 2, ipph
+        jc = ipp2 - j
+        do k = 1, l1
+          do i = 3, ido, 2
+            m2 = m2s
+            do m1 = 1, m1d, im1
+              m2 = m2 + im2
+              c1(m1,i-1,k,j)  = ch(m2,i-1,k,j)  + ch(m2,i-1,k,jc)
+              c1(m1,i-1,k,jc) = ch(m2,i,k,j)    - ch(m2,i,k,jc)
+              c1(m1,i,k,j)    = ch(m2,i,k,j)    + ch(m2,i,k,jc)
+              c1(m1,i,k,jc)   = ch(m2,i-1,k,jc) - ch(m2,i-1,k,j)
+            end do
+          end do
+        end do
+      end do
+
+    end if
+
+  end if
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        c1(m1,1,k,j)  = ch(m2,1,k,j)  + ch(m2,1,k,jc)
+        c1(m1,1,k,jc) = ch(m2,1,k,jc) - ch(m2,1,k,j)
+      end do
+    end do
+  end do
+
+  ar1 = 1.0E+00
+  ai1 = 0.0E+00
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+    ar1h = dcp * ar1 - dsp * ai1
+    ai1 =  dcp * ai1 + dsp * ar1
+    ar1 = ar1h
+
+    do ik = 1, idl1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch2(m2,ik,l)  = c2(m1,ik,1) + ar1 * c2(m1,ik,2)
+        ch2(m2,ik,lc) =               ai1 * c2(m1,ik,ip)
+      end do
+    end do
+
+    dc2 = ar1
+    ds2 = ai1
+    ar2 = ar1
+    ai2 = ai1
+
+    do j = 3, ipph
+      jc = ipp2 - j
+      ar2h = dc2 * ar2 - ds2 * ai2
+      ai2  = dc2 * ai2 + ds2 * ar2
+      ar2 = ar2h
+      do ik = 1, idl1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch2(m2,ik,l)  = ch2(m2,ik,l)  + ar2 * c2(m1,ik,j)
+          ch2(m2,ik,lc) = ch2(m2,ik,lc) + ai2 * c2(m1,ik,jc)
+        end do
+      end do
+    end do
+
+  end do
+
+  do j = 2, ipph
+    do ik = 1, idl1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch2(m2,ik,1) = ch2(m2,ik,1) + c2(m1,ik,j)
+      end do
+    end do
+  end do
+
+  if ( ido < l1 ) then
+
+    do i = 1, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc(m1,i,1,k) = ch(m2,i,k,1)
+        end do
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do i = 1, ido
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc(m1,i,1,k) = ch(m2,i,k,1)
+        end do
+      end do
+    end do
+
+  end if
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    j2 = j + j
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        cc(m1,ido,j2-2,k) = ch(m2,1,k,j)
+        cc(m1,1,j2-1,k) = ch(m2,1,k,jc)
+      end do
+    end do
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  if ( nbd < l1 ) then
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      j2 = j + j
+      do i = 3, ido, 2
+        ic = idp2 - i
+        do k = 1, l1
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            cc(m1,i-1,j2-1,k)  = ch(m2,i-1,k,j) + ch(m2,i-1,k,jc)
+            cc(m1,ic-1,j2-2,k) = ch(m2,i-1,k,j) - ch(m2,i-1,k,jc)
+            cc(m1,i,j2-1,k)    = ch(m2,i,k,j)   + ch(m2,i,k,jc)
+            cc(m1,ic,j2-2,k)   = ch(m2,i,k,jc)  - ch(m2,i,k,j)
+          end do
+        end do
+      end do
+    end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      j2 = j + j
+      do k = 1, l1
+        do i = 3, ido, 2
+          ic = idp2 - i
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            cc(m1,i-1,j2-1,k)  = ch(m2,i-1,k,j) + ch(m2,i-1,k,jc)
+            cc(m1,ic-1,j2-2,k) = ch(m2,i-1,k,j) - ch(m2,i-1,k,jc)
+            cc(m1,i,j2-1,k)    = ch(m2,i,k,j)   + ch(m2,i,k,jc)
+            cc(m1,ic,j2-2,k)   = ch(m2,i,k,jc)  - ch(m2,i,k,j)
+          end do
+        end do
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mrftb1.F b/wrfv2_fire/external/fftpack/fftpack5/mrftb1.F
index 46b4849e..9945a71b 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mrftb1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mrftb1.F
@@ -1,105 +1,208 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mrftb1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRFTB1 (M,IM,N,IN,C,CH,WA,FAC) 
-      REAL       CH(M,*), C(IN,*), WA(N) ,FAC(15) 
-!                                                                       
-      NF = FAC(2) 
-      NA = 0 
-      DO 10 K1=1,NF 
-      IP = FAC(K1+2) 
-      NA = 1-NA 
-      IF(IP .LE. 5) GO TO 10 
-      IF(K1 .EQ. NF) GO TO 10 
-      NA = 1-NA 
-   10 END DO 
-      HALF = .5 
-      HALFM = -.5 
-      MODN = MOD(N,2) 
-      NL = N-2 
-      IF(MODN .NE. 0) NL = N-1 
-      IF (NA .EQ. 0) GO TO 120 
-      M2 = 1-IM 
-      DO 117 I=1,M 
-      M2 = M2+IM 
-      CH(I,1) = C(M2,1) 
-      CH(I,N) = C(M2,N) 
-  117 END DO 
-      DO 118 J=2,NL,2 
-      M2 = 1-IM 
-      DO 118 I=1,M 
-         M2 = M2+IM 
-         CH(I,J) = HALF*C(M2,J) 
-         CH(I,J+1) = HALFM*C(M2,J+1) 
-  118 CONTINUE 
-      GO TO 124 
-  120 continue 
-      DO 122 J=2,NL,2 
-      M2 = 1-IM 
-      DO 122 I=1,M 
-         M2 = M2+IM 
-         C(M2,J) = HALF*C(M2,J) 
-         C(M2,J+1) = HALFM*C(M2,J+1) 
-  122 CONTINUE 
-  124 L1 = 1 
-      IW = 1 
-      DO 116 K1=1,NF 
-         IP = FAC(K1+2) 
-         L2 = IP*L1 
-         IDO = N/L2 
-         IDL1 = IDO*L1 
-         IF (IP .NE. 4) GO TO 103 
-         IX2 = IW+IDO 
-         IX3 = IX2+IDO 
-         IF (NA .NE. 0) GO TO 101 
-         CALL MRADB4 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),WA(IX3)) 
-         GO TO 102 
-  101    CALL MRADB4 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),WA(IX3)) 
-  102    NA = 1-NA 
-         GO TO 115 
-  103    IF (IP .NE. 2) GO TO 106 
-         IF (NA .NE. 0) GO TO 104 
-         CALL MRADB2 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW)) 
-         GO TO 105 
-  104    CALL MRADB2 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW)) 
-  105    NA = 1-NA 
-         GO TO 115 
-  106    IF (IP .NE. 3) GO TO 109 
-         IX2 = IW+IDO 
-         IF (NA .NE. 0) GO TO 107 
-         CALL MRADB3 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2)) 
-         GO TO 108 
-  107    CALL MRADB3 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2)) 
-  108    NA = 1-NA 
-         GO TO 115 
-  109    IF (IP .NE. 5) GO TO 112 
-         IX2 = IW+IDO 
-         IX3 = IX2+IDO 
-         IX4 = IX3+IDO 
-         IF (NA .NE. 0) GO TO 110 
-         CALL MRADB5 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),           &
-     &                  WA(IX3),WA(IX4))                                
-         GO TO 111 
-  110    CALL MRADB5 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),           &
-     &                  WA(IX3),WA(IX4))                                
-  111    NA = 1-NA 
-         GO TO 115 
-  112    IF (NA .NE. 0) GO TO 113 
-         CALL MRADBG (M,IDO,IP,L1,IDL1,C,C,C,IM,IN,CH,CH,1,             &
-     &                            M,WA(IW))                             
-         GO TO 114 
-  113    CALL MRADBG (M,IDO,IP,L1,IDL1,CH,CH,CH,1,M,C,C,IM,             &
-     &                           IN,WA(IW))                             
-  114    IF (IDO .EQ. 1) NA = 1-NA 
-  115    L1 = L2 
-         IW = IW+(IP-1)*IDO 
-  116 END DO 
-      RETURN 
-      END                                           
+subroutine mrftb1 ( m, im, n, in, c, ch, wa, fac )
+
+!*****************************************************************************80
+!
+!! MRFTB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) in
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 4 ) c(in,*)
+  real ( kind = 4 ) ch(m,*)
+  real ( kind = 4 ) fac(15)
+  real ( kind = 4 ) half
+  real ( kind = 4 ) halfm
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) im
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) ix2
+  integer ( kind = 4 ) ix3
+  integer ( kind = 4 ) ix4
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nf
+  integer ( kind = 4 ) nl
+  real ( kind = 4 ) wa(n)
+
+  nf = int ( fac(2) )
+  na = 0
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1+2) )
+    na = 1 - na
+
+    if ( 5 < ip ) then
+      if ( k1 /= nf ) then
+        na = 1 - na
+      end if
+    end if
+
+  end do
+
+  half = 0.5E+00
+  halfm = -0.5E+00
+  modn = mod ( n, 2 )
+  nl = n - 2
+  if ( modn /= 0 ) then
+    nl = n - 1
+  end if
+
+  if ( na == 0 ) then
+
+    do j = 2, nl, 2
+      m2 = 1 - im
+      do i = 1, m
+        m2 = m2 + im
+        c(m2,j) = half * c(m2,j)
+        c(m2,j+1) = halfm * c(m2,j+1)
+      end do
+    end do
+
+  else
+
+    m2 = 1 - im
+
+    do i = 1, m
+      m2 = m2 + im
+      ch(i,1) = c(m2,1)
+      ch(i,n) = c(m2,n)
+    end do
+
+    do j = 2, nl, 2
+      m2 = 1 - im
+      do i = 1, m
+        m2 = m2 + im
+        ch(i,j) = half * c(m2,j)
+        ch(i,j+1) = halfm * c(m2,j+1)
+      end do
+    end do
+
+  end if
+
+  l1 = 1
+  iw = 1
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1+2) )
+    l2 = ip * l1
+    ido = n / l2
+    idl1 = ido * l1
+
+    if ( ip == 4 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+
+      if ( na == 0 ) then
+        call mradb4 ( m, ido, l1, c, im, in, ch, 1, m, wa(iw), wa(ix2), &
+          wa(ix3) )
+      else
+        call mradb4 ( m, ido, l1, ch, 1, m, c, im, in, wa(iw), wa(ix2), &
+          wa(ix3) )
+      end if
+
+      na = 1 - na
+
+    else if ( ip == 2 ) then
+
+      if ( na == 0 ) then
+        call mradb2 ( m, ido, l1, c, im, in, ch, 1, m, wa(iw) )
+      else
+        call mradb2 ( m, ido, l1, ch, 1, m, c, im, in, wa(iw) )
+      end if
+
+      na = 1 - na
+
+    else if ( ip == 3 ) then
+
+      ix2 = iw + ido
+
+      if ( na == 0 ) then
+        call mradb3 ( m, ido, l1, c, im, in, ch, 1, m, wa(iw), wa(ix2) )
+      else
+        call mradb3 ( m, ido, l1, ch, 1, m, c, im, in, wa(iw), wa(ix2) )
+      end if
+
+      na = 1 - na
+
+    else if ( ip == 5 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+      ix4 = ix3 + ido
+
+      if ( na == 0 ) then
+        call mradb5 ( m, ido, l1, c, im, in, ch, 1, m, wa(iw), wa(ix2), &
+          wa(ix3), wa(ix4) )
+      else
+        call mradb5 ( m, ido, l1, ch, 1, m, c, im, in, wa(iw), wa(ix2), &
+          wa(ix3), wa(ix4) )
+      end if
+
+      na = 1 - na
+
+    else
+
+      if ( na == 0 ) then
+        call mradbg ( m, ido, ip, l1, idl1, c, c, c, im, in, ch, ch, 1, &
+          m, wa(iw) )
+      else
+        call mradbg ( m, ido, ip, l1, idl1, ch, ch, ch, 1, m, c, c, im, &
+          in, wa(iw) )
+      end if
+
+      if ( ido == 1 ) then
+        na = 1 - na
+      end if
+
+    end if
+
+    l1 = l2
+    iw = iw + ( ip - 1 ) * ido
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mrftf1.F b/wrfv2_fire/external/fftpack/fftpack5/mrftf1.F
index dcc2659f..c1cd71d8 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mrftf1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mrftf1.F
@@ -1,112 +1,218 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mrftf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRFTF1 (M,IM,N,IN,C,CH,WA,FAC) 
-      REAL       CH(M,*) ,C(IN,*)  ,WA(N)   ,FAC(15) 
-!                                                                       
-      NF = FAC(2) 
-      NA = 1 
-      L2 = N 
-      IW = N 
-      DO 111 K1=1,NF 
-         KH = NF-K1 
-         IP = FAC(KH+3) 
-         L1 = L2/IP 
-         IDO = N/L2 
-         IDL1 = IDO*L1 
-         IW = IW-(IP-1)*IDO 
-         NA = 1-NA 
-         IF (IP .NE. 4) GO TO 102 
-         IX2 = IW+IDO 
-         IX3 = IX2+IDO 
-         IF (NA .NE. 0) GO TO 101 
-         CALL MRADF4 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),WA(IX3)) 
-         GO TO 110 
-  101    CALL MRADF4 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),WA(IX3)) 
-         GO TO 110 
-  102    IF (IP .NE. 2) GO TO 104 
-         IF (NA .NE. 0) GO TO 103 
-         CALL MRADF2 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW)) 
-         GO TO 110 
-  103    CALL MRADF2 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW)) 
-         GO TO 110 
-  104    IF (IP .NE. 3) GO TO 106 
-         IX2 = IW+IDO 
-         IF (NA .NE. 0) GO TO 105 
-         CALL MRADF3 (M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2)) 
-         GO TO 110 
-  105    CALL MRADF3 (M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2)) 
-         GO TO 110 
-  106    IF (IP .NE. 5) GO TO 108 
-         IX2 = IW+IDO 
-         IX3 = IX2+IDO 
-         IX4 = IX3+IDO 
-         IF (NA .NE. 0) GO TO 107 
-         CALL MRADF5(M,IDO,L1,C,IM,IN,CH,1,M,WA(IW),WA(IX2),            &
-     &                      WA(IX3),WA(IX4))                            
-         GO TO 110 
-  107    CALL MRADF5(M,IDO,L1,CH,1,M,C,IM,IN,WA(IW),WA(IX2),            &
-     &                      WA(IX3),WA(IX4))                            
-         GO TO 110 
-  108    IF (IDO .EQ. 1) NA = 1-NA 
-         IF (NA .NE. 0) GO TO 109 
-         CALL MRADFG (M,IDO,IP,L1,IDL1,C,C,C,IM,IN,CH,CH,1,M,WA(IW)) 
-         NA = 1 
-         GO TO 110 
-  109    CALL MRADFG (M,IDO,IP,L1,IDL1,CH,CH,CH,1,M,C,C,IM,IN,WA(IW)) 
-         NA = 0 
-  110    L2 = L1 
-  111 END DO 
-      SN = 1./N 
-      TSN = 2./N 
-      TSNM = -TSN 
-      MODN = MOD(N,2) 
-      NL = N-2 
-      IF(MODN .NE. 0) NL = N-1 
-      IF (NA .NE. 0) GO TO 120 
-      M2 = 1-IM 
-      DO 117 I=1,M 
-         M2 = M2+IM 
-         C(M2,1) = SN*CH(I,1) 
-  117 END DO 
-      DO 118 J=2,NL,2 
-      M2 = 1-IM 
-      DO 118 I=1,M 
-         M2 = M2+IM 
-         C(M2,J) = TSN*CH(I,J) 
-         C(M2,J+1) = TSNM*CH(I,J+1) 
-  118 CONTINUE 
-      IF(MODN .NE. 0) RETURN 
-      M2 = 1-IM 
-      DO 119 I=1,M 
-         M2 = M2+IM 
-         C(M2,N) = SN*CH(I,N) 
-  119 END DO 
-      RETURN 
-  120 M2 = 1-IM 
-      DO 121 I=1,M 
-         M2 = M2+IM 
-         C(M2,1) = SN*C(M2,1) 
-  121 END DO 
-      DO 122 J=2,NL,2 
-      M2 = 1-IM 
-      DO 122 I=1,M 
-         M2 = M2+IM 
-         C(M2,J) = TSN*C(M2,J) 
-         C(M2,J+1) = TSNM*C(M2,J+1) 
-  122 CONTINUE 
-      IF(MODN .NE. 0) RETURN 
-      M2 = 1-IM 
-      DO 123 I=1,M 
-         M2 = M2+IM 
-         C(M2,N) = SN*C(M2,N) 
-  123 END DO 
-      RETURN 
-      END                                           
+subroutine mrftf1 ( m, im, n, in, c, ch, wa, fac )
+
+!*****************************************************************************80
+!
+!! MRFTF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) in
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+
+  real ( kind = 4 ) c(in,*)
+  real ( kind = 4 ) ch(m,*)
+  real ( kind = 4 ) fac(15)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) im
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) ix2
+  integer ( kind = 4 ) ix3
+  integer ( kind = 4 ) ix4
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) kh
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nf
+  integer ( kind = 4 ) nl
+  real ( kind = 4 ) sn
+  real ( kind = 4 ) tsn
+  real ( kind = 4 ) tsnm
+  real ( kind = 4 ) wa(n)
+
+  nf = int ( fac(2) )
+  na = 1
+  l2 = n
+  iw = n
+
+  do k1 = 1, nf
+
+    kh = nf - k1
+    ip = int ( fac(kh+3) )
+    l1 = l2 / ip
+    ido = n / l2
+    idl1 = ido * l1
+    iw = iw - ( ip - 1 ) * ido
+    na = 1 - na
+
+    if ( ip == 4 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+
+      if ( na == 0 ) then
+        call mradf4 ( m, ido, l1, c, im, in, ch, 1,m, wa(iw), wa(ix2), &
+          wa(ix3) )
+      else
+        call mradf4 ( m, ido, l1, ch, 1, m, c, im, in, wa(iw), wa(ix2), &
+          wa(ix3) )
+      end if
+
+    else if ( ip == 2 ) then
+
+      if ( na == 0 ) then
+        call mradf2 ( m, ido, l1, c, im, in, ch, 1, m, wa(iw) )
+      else
+        call mradf2 ( m, ido, l1, ch, 1, m, c, im, in, wa(iw) )
+      end if
+
+    else if ( ip == 3 ) then
+
+      ix2 = iw + ido
+
+      if ( na == 0 ) then
+        call mradf3 ( m, ido, l1, c, im, in, ch, 1, m, wa(iw), wa(ix2) )
+      else
+        call mradf3 ( m, ido, l1, ch, 1, m, c, im, in, wa(iw), wa(ix2) )
+      end if
+
+    else if ( ip == 5 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+      ix4 = ix3 + ido
+
+      if ( na == 0 ) then
+        call mradf5 ( m, ido, l1, c, im, in, ch, 1, m, wa(iw), wa(ix2), &
+          wa(ix3), wa(ix4) )
+      else
+        call mradf5 ( m, ido, l1, ch, 1, m, c, im, in, wa(iw), wa(ix2), &
+          wa(ix3), wa(ix4) )
+      end if
+
+    else
+
+      if ( ido == 1 ) then
+        na = 1 - na
+      end if
+
+      if ( na == 0 ) then
+        call mradfg ( m, ido, ip, l1, idl1, c, c, c, im, in, ch, ch, 1, &
+          m, wa(iw) )
+        na = 1
+      else
+        call mradfg ( m, ido, ip, l1, idl1, ch, ch, ch, 1, m, c, c, im, &
+          in, wa(iw) )
+        na = 0
+      end if
+
+    end if
+
+    l2 = l1
+
+  end do
+
+  sn = 1.0E+00 / real ( n, kind = 4 )
+  tsn = 2.0E+00 / real ( n, kind = 4 )
+  tsnm = -tsn
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    nl = n - 1
+  else
+    nl = n - 2
+  end if
+
+  if ( na == 0 ) then
+
+    m2 = 1-im
+    do i = 1, m
+      m2 = m2 + im
+      c(m2,1) = sn * ch(i,1)
+    end do
+
+    do j = 2, nl, 2
+      m2 = 1 - im
+      do i = 1, m
+        m2 = m2 + im
+        c(m2,j) = tsn * ch(i,j)
+        c(m2,j+1) = tsnm * ch(i,j+1)
+      end do
+    end do
+
+    if ( modn == 0 ) then
+      m2 = 1 - im
+      do i = 1, m
+        m2 = m2 + im
+        c(m2,n) = sn * ch(i,n)
+      end do
+    end if
+
+  else
+
+    m2 = 1-im
+    do i = 1, m
+      m2 = m2 + im
+      c(m2,1) = sn * c(m2,1)
+    end do
+
+    do j = 2, nl, 2
+      m2 = 1 - im
+      do i = 1, m
+        m2 = m2 + im
+        c(m2,j) = tsn * c(m2,j)
+        c(m2,j+1) = tsnm * c(m2,j+1)
+      end do
+    end do
+
+    if ( modn == 0 ) then
+
+      m2 = 1 - im
+
+      do i = 1, m
+        m2 = m2 + im
+        c(m2,n) = sn * c(m2,n)
+      end do
+
+    end if
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/mrfti1.F b/wrfv2_fire/external/fftpack/fftpack5/mrfti1.F
index f3221329..2bd680cf 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/mrfti1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/mrfti1.F
@@ -1,70 +1,155 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: mrfti1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MRFTI1 (N,WA,FAC) 
-      REAL       WA(N)      ,FAC(15) 
-      INTEGER    NTRYH(4) 
-      DOUBLE PRECISION TPI,ARGH,ARGLD,ARG 
-      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ 
-!                                                                       
-      NL = N 
-      NF = 0 
-      J = 0 
-  101 J = J+1 
-      IF (J-4) 102,102,103 
-  102 NTRY = NTRYH(J) 
-      GO TO 104 
-  103 NTRY = NTRY+2 
-  104 NQ = NL/NTRY 
-      NR = NL-NTRY*NQ 
-      IF (NR) 101,105,101 
-  105 NF = NF+1 
-      FAC(NF+2) = NTRY 
-      NL = NQ 
-      IF (NTRY .NE. 2) GO TO 107 
-      IF (NF .EQ. 1) GO TO 107 
-      DO 106 I=2,NF 
-         IB = NF-I+2 
-         FAC(IB+2) = FAC(IB+1) 
-  106 END DO 
-      FAC(3) = 2 
-  107 IF (NL .NE. 1) GO TO 104 
-      FAC(1) = N 
-      FAC(2) = NF 
-      TPI = 8.D0*DATAN(1.D0) 
-      ARGH = TPI/FLOAT(N) 
-      IS = 0 
-      NFM1 = NF-1 
-      L1 = 1 
-      IF (NFM1 .EQ. 0) RETURN 
-      DO 110 K1=1,NFM1 
-         IP = FAC(K1+2) 
-         LD = 0 
-         L2 = L1*IP 
-         IDO = N/L2 
-         IPM = IP-1 
-         DO 109 J=1,IPM 
-            LD = LD+L1 
-            I = IS 
-            ARGLD = FLOAT(LD)*ARGH 
-            FI = 0. 
-            DO 108 II=3,IDO,2 
-               I = I+2 
-               FI = FI+1. 
-               ARG = FI*ARGLD 
-               WA(I-1) = DCOS(ARG) 
-               WA(I) = DSIN(ARG) 
-  108       CONTINUE 
-            IS = IS+IDO 
-  109    CONTINUE 
-         L1 = L2 
-  110 END DO 
-      RETURN 
-      END                                           
+subroutine mrfti1 ( n, wa, fac )
+
+!*****************************************************************************80
+!
+!! MRFTI1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the number for which factorization and
+!    other information is needed.
+!
+!    Output, real ( kind = 4 ) WA(N), trigonometric information.
+!
+!    Output, real ( kind = 4 ) FAC(15), factorization information.  FAC(1) is
+!    N, FAC(2) is NF, the number of factors, and FAC(3:NF+2) are the factors.
+!
+  implicit none
+
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) arg
+  real ( kind = 8 ) argh
+  real ( kind = 8 ) argld
+  real ( kind = 4 ) fac(15)
+  real ( kind = 4 ) fi
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ib
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) ii
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) ipm
+  integer ( kind = 4 ) is
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) ld
+  integer ( kind = 4 ) nf
+  integer ( kind = 4 ) nfm1
+  integer ( kind = 4 ) nl
+  integer ( kind = 4 ) nq
+  integer ( kind = 4 ) nr
+  integer ( kind = 4 ) ntry
+  real ( kind = 8 ) tpi
+  real ( kind = 4 ) wa(n)
+
+  nl = n
+  nf = 0
+  j = 0
+
+  do while ( 1 < nl )
+
+    j = j + 1
+
+    if ( j == 1 ) then
+      ntry = 4
+    else if ( j == 2 ) then
+      ntry = 2
+    else if ( j == 3 ) then
+      ntry = 3
+    else if ( j == 4 ) then
+      ntry = 5
+    else
+      ntry = ntry + 2
+    end if
+
+    do
+
+      nq = nl / ntry
+      nr = nl - ntry * nq
+
+      if ( nr /= 0 ) then
+        exit
+      end if
+
+      nf = nf + 1
+      fac(nf+2) = real ( ntry, kind = 4 )
+      nl = nq
+!
+!  If 2 is a factor, make sure it appears first in the list of factors.
+!
+      if ( ntry == 2 ) then
+        if ( nf /= 1 ) then
+          do i = 2, nf
+            ib = nf - i + 2
+            fac(ib+2) = fac(ib+1)
+          end do
+          fac(3) = 2.0E+00
+        end if
+      end if
+
+    end do
+
+  end do
+
+  fac(1) = real ( n, kind = 4 )
+  fac(2) = real ( nf, kind = 4 )
+  tpi = 8.0D+00 * atan ( 1.0D+00 )
+  argh = tpi / real ( n, kind = 4 )
+  is = 0
+  nfm1 = nf - 1
+  l1 = 1
+
+  do k1 = 1, nfm1
+    ip = int ( fac(k1+2) )
+    ld = 0
+    l2 = l1 * ip
+    ido = n / l2
+    ipm = ip - 1
+    do j = 1, ipm
+      ld = ld + l1
+      i = is
+      argld = real ( ld, kind = 4 ) * argh
+      fi = 0.0E+00
+      do ii = 3, ido, 2
+        i = i + 2
+        fi = fi + 1.0E+00
+        arg = fi * argld
+        wa(i-1) = cos ( arg )
+        wa(i) = sin ( arg )
+      end do
+      is = is + ido
+    end do
+    l1 = l2
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/msntb1.F b/wrfv2_fire/external/fftpack/fftpack5/msntb1.F
index 71991d0e..dfcc2c60 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/msntb1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/msntb1.F
@@ -1,88 +1,166 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: msntb1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MSNTB1(LOT,JUMP,N,INC,X,WSAVE,DSUM,XH,WORK,IER) 
-      REAL       X(INC,*)       ,WSAVE(*)   ,XH(LOT,*) 
-      DOUBLE PRECISION           DSUM(*) 
-      IER = 0 
-      LJ = (LOT-1)*JUMP+1 
-      IF (N-2) 200,102,103 
-  102 SRT3S2 = SQRT(3.)/2. 
-      DO 112 M=1,LJ,JUMP 
-         XHOLD = SRT3S2*(X(M,1)+X(M,2)) 
-         X(M,2) = SRT3S2*(X(M,1)-X(M,2)) 
-         X(M,1) = XHOLD 
-  112 END DO 
-      GO TO 200 
-  103 NP1 = N+1 
-      NS2 = N/2 
-      DO 104 K=1,NS2 
-         KC = NP1-K 
-         M1 = 0 
-         DO 114 M=1,LJ,JUMP 
-         M1 = M1+1 
-         T1 = X(M,K)-X(M,KC) 
-         T2 = WSAVE(K)*(X(M,K)+X(M,KC)) 
-         XH(M1,K+1) = T1+T2 
-         XH(M1,KC+1) = T2-T1 
-  114    CONTINUE 
-  104 END DO 
-      MODN = MOD(N,2) 
-      IF (MODN .EQ. 0) GO TO 124 
-      M1 = 0 
-      DO 123 M=1,LJ,JUMP 
-         M1 = M1+1 
-         XH(M1,NS2+2) = 4.*X(M,NS2+1) 
-  123 END DO 
-  124 DO 127 M=1,LOT 
-         XH(M,1) = 0. 
-  127 END DO 
-      LNXH = LOT-1 + LOT*(NP1-1) + 1 
-      LNSV = NP1 + INT(LOG(REAL(NP1))) + 4 
-      LNWK = LOT*NP1 
-!                                                                       
-      CALL RFFTMF(LOT,1,NP1,LOT,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,         &
-     &            LNWK,IER1)                                            
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('MSNTB1',-5) 
-        GO TO 200 
-      ENDIF 
-!                                                                       
-      IF(MOD(NP1,2) .NE. 0) GO TO 30 
-      DO 20 M=1,LOT 
-      XH(M,NP1) = XH(M,NP1)+XH(M,NP1) 
-   20 END DO 
-   30 FNP1S4 = FLOAT(NP1)/4. 
-      M1 = 0 
-      DO 125 M=1,LJ,JUMP 
-         M1 = M1+1 
-         X(M,1) = FNP1S4*XH(M1,1) 
-         DSUM(M1) = X(M,1) 
-  125 END DO 
-      DO 105 I=3,N,2 
-         M1 = 0 
-         DO 115 M=1,LJ,JUMP 
-            M1 = M1+1 
-            X(M,I-1) = FNP1S4*XH(M1,I) 
-            DSUM(M1) = DSUM(M1)+FNP1S4*XH(M1,I-1) 
-            X(M,I) = DSUM(M1) 
-  115    CONTINUE 
-  105 END DO 
-      IF (MODN .NE. 0) GO TO 200 
-      M1 = 0 
-      DO 116 M=1,LJ,JUMP 
-         M1 = M1+1 
-         X(M,N) = FNP1S4*XH(M1,N+1) 
-  116 END DO 
-!                                                                       
-  200 CONTINUE 
-      RETURN 
-      END                                           
+subroutine msntb1 ( lot, jump, n, inc, x, wsave, dsum, xh, work, ier )
+
+!*****************************************************************************80
+!
+!! MSNTB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lot
+
+  real ( kind = 8 ) dsum(*)
+  real ( kind = 4 ) fnp1s4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lj
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) lnxh
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) srt3s2
+  real ( kind = 4 ) t1
+  real ( kind = 4 ) t2
+  real ( kind = 4 ) work(*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) xh(lot,*)
+  real ( kind = 4 ) xhold
+
+  ier = 0
+  lj = ( lot - 1 ) * jump + 1
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+
+    srt3s2 = sqrt ( 3.0E+00 ) / 2.0E+00
+
+    do m = 1, lj, jump
+      xhold =  srt3s2 * ( x(m,1) + x(m,2) )
+      x(m,2) = srt3s2 * ( x(m,1) - x(m,2) )
+      x(m,1) = xhold
+    end do
+
+    return
+  end if
+
+  np1 = n + 1
+  ns2 = n / 2
+
+  do k = 1, ns2
+    kc = np1 - k
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      t1 = x(m,k) - x(m,kc)
+      t2 = wsave(k) * ( x(m,k) + x(m,kc) )
+      xh(m1,k+1) = t1 + t2
+      xh(m1,kc+1) = t2 - t1
+    end do
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      xh(m1,ns2+2) = 4.0E+00 * x(m,ns2+1)
+    end do
+
+  end if
+
+  do m = 1, lot
+    xh(m,1) = 0.0E+00
+  end do
+
+  lnxh = lot - 1 + lot * ( np1 - 1 ) + 1
+  lnsv = np1 + int ( log ( real ( np1, kind = 4 ) ) ) + 4
+  lnwk = lot * np1
+
+  call rfftmf ( lot, 1, np1, lot, xh, lnxh, wsave(ns2+1), lnsv, work, &
+    lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'msntb1', -5 )
+    return
+  end if
+
+  if ( mod ( np1, 2 ) == 0 ) then
+    do m = 1, lot
+      xh(m,np1) = xh(m,np1) + xh(m,np1)
+    end do
+  end if
+
+  fnp1s4 = real ( np1, kind = 4 ) / 4.0E+00
+
+  m1 = 0
+  do m = 1, lj, jump
+    m1 = m1 + 1
+    x(m,1) = fnp1s4 * xh(m1,1)
+    dsum(m1) = x(m,1)
+  end do
+
+  do i = 3, n, 2
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1+1
+      x(m,i-1) = fnp1s4 * xh(m1,i)
+      dsum(m1) = dsum(m1) + fnp1s4 * xh(m1,i-1)
+      x(m,i) = dsum(m1)
+    end do
+  end do
+
+  if ( modn == 0 ) then
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      x(m,n) = fnp1s4 * xh(m1,n+1)
+    end do
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/msntf1.F b/wrfv2_fire/external/fftpack/fftpack5/msntf1.F
index 91f3d8bc..e4ddad4d 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/msntf1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/msntf1.F
@@ -1,87 +1,161 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: msntf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE MSNTF1(LOT,JUMP,N,INC,X,WSAVE,DSUM,XH,WORK,IER) 
-      REAL       X(INC,*)       ,WSAVE(*)   ,XH(LOT,*) 
-      DOUBLE PRECISION           DSUM(*) 
-      IER = 0 
-      LJ = (LOT-1)*JUMP+1 
-      IF (N-2) 101,102,103 
-  102 SSQRT3 = 1./SQRT(3.) 
-      DO 112 M=1,LJ,JUMP 
-         XHOLD = SSQRT3*(X(M,1)+X(M,2)) 
-         X(M,2) = SSQRT3*(X(M,1)-X(M,2)) 
-         X(M,1) = XHOLD 
-  112 END DO 
-  101  GO TO 200 
-  103 NP1 = N+1 
-      NS2 = N/2 
-      DO 104 K=1,NS2 
-         KC = NP1-K 
-         M1 = 0 
-         DO 114 M=1,LJ,JUMP 
-         M1 = M1 + 1 
-         T1 = X(M,K)-X(M,KC) 
-         T2 = WSAVE(K)*(X(M,K)+X(M,KC)) 
-         XH(M1,K+1) = T1+T2 
-         XH(M1,KC+1) = T2-T1 
-  114    CONTINUE 
-  104 END DO 
-      MODN = MOD(N,2) 
-      IF (MODN .EQ. 0) GO TO 124 
-      M1 = 0 
-      DO 123 M=1,LJ,JUMP 
-         M1 = M1 + 1 
-         XH(M1,NS2+2) = 4.*X(M,NS2+1) 
-  123 END DO 
-  124 DO 127 M=1,LOT 
-         XH(M,1) = 0. 
-  127 END DO 
-      LNXH = LOT-1 + LOT*(NP1-1) + 1 
-      LNSV = NP1 + INT(LOG(REAL(NP1))) + 4 
-      LNWK = LOT*NP1 
-!                                                                       
-      CALL RFFTMF(LOT,1,NP1,LOT,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,         &
-     &            LNWK,IER1)                                            
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('MSNTF1',-5) 
-        GO TO 200 
-      ENDIF 
-!                                                                       
-      IF(MOD(NP1,2) .NE. 0) GO TO 30 
-      DO 20 M=1,LOT 
-      XH(M,NP1) = XH(M,NP1)+XH(M,NP1) 
-   20 END DO 
-   30 SFNP1 = 1./FLOAT(NP1) 
-      M1 = 0 
-      DO 125 M=1,LJ,JUMP 
-         M1 = M1+1 
-         X(M,1) = .5*XH(M1,1) 
-         DSUM(M1) = X(M,1) 
-  125 END DO 
-      DO 105 I=3,N,2 
-         M1 = 0 
-         DO 115 M=1,LJ,JUMP 
-            M1 = M1+1 
-            X(M,I-1) = .5*XH(M1,I) 
-            DSUM(M1) = DSUM(M1)+.5*XH(M1,I-1) 
-            X(M,I) = DSUM(M1) 
-  115    CONTINUE 
-  105 END DO 
-      IF (MODN .NE. 0) GO TO 200 
-      M1 = 0 
-      DO 116 M=1,LJ,JUMP 
-         M1 = M1+1 
-         X(M,N) = .5*XH(M1,N+1) 
-  116 END DO 
-  200 CONTINUE 
-      RETURN 
-      END                                           
+subroutine msntf1 ( lot, jump, n, inc, x, wsave, dsum, xh, work, ier )
+
+!*****************************************************************************80
+!
+!! MSNTF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lot
+
+  real ( kind = 8 ) dsum(*)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lj
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) lnxh
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) sfnp1
+  real ( kind = 4 ) ssqrt3
+  real ( kind = 4 ) t1
+  real ( kind = 4 ) t2
+  real ( kind = 4 ) work(*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) xh(lot,*)
+  real ( kind = 4 ) xhold
+
+  ier = 0
+  lj = ( lot - 1 ) * jump + 1
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    ssqrt3 = 1.0E+00 / sqrt ( 3.0E+00 )
+    do m = 1, lj, jump
+      xhold =  ssqrt3 * ( x(m,1) + x(m,2) )
+      x(m,2) = ssqrt3 * ( x(m,1) - x(m,2) )
+      x(m,1) = xhold
+    end do
+  end if
+
+  np1 = n + 1
+  ns2 = n / 2
+
+  do k = 1, ns2
+    kc = np1 - k
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      t1 = x(m,k) - x(m,kc)
+      t2 = wsave(k) * ( x(m,k) + x(m,kc) )
+      xh(m1,k+1) = t1 + t2
+      xh(m1,kc+1) = t2 - t1
+    end do
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      xh(m1,ns2+2) = 4.0E+00 * x(m,ns2+1)
+    end do
+  end if
+
+  do m = 1, lot
+    xh(m,1) = 0.0E+00
+  end do
+
+  lnxh = lot - 1 + lot * ( np1 - 1 ) + 1
+  lnsv = np1 + int ( log ( real ( np1, kind = 4 ) ) ) + 4
+  lnwk = lot * np1
+
+  call rfftmf ( lot, 1, np1, lot, xh, lnxh, wsave(ns2+1), lnsv, work, &
+    lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'msntf1', -5 )
+    return
+  end if
+
+  if ( mod ( np1, 2 ) == 0 ) then
+    do m = 1, lot
+      xh(m,np1) = xh(m,np1) + xh(m,np1)
+    end do
+  end if
+
+  sfnp1 = 1.0E+00 / real ( np1, kind = 4 )
+  m1 = 0
+  do m = 1, lj, jump
+    m1 = m1 + 1
+    x(m,1) = 0.5E+00 * xh(m1,1)
+    dsum(m1) = x(m,1)
+  end do
+
+  do i = 3, n, 2
+    m1 = 0
+    do m = 1, lj, jump
+      m1 = m1 + 1
+      x(m,i-1) = 0.5E+00 * xh(m1,i)
+      dsum(m1) = dsum(m1) + 0.5E+00 * xh(m1,i-1)
+      x(m,i) = dsum(m1)
+    end do
+  end do
+
+  if ( modn /= 0 ) then
+    return
+  end if
+
+  m1 = 0
+  do m = 1, lj, jump
+    m1 = m1 + 1
+    x(m,n) = 0.5E+00 * xh(m1,n+1)
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r1f2kb.F b/wrfv2_fire/external/fftpack/fftpack5/r1f2kb.F
index 318de6ca..221dec21 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/r1f2kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/r1f2kb.F
@@ -1,40 +1,90 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: r1f2kb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE R1F2KB (IDO,L1,CC,IN1,CH,IN2,WA1) 
-      REAL       CC(IN1,IDO,2,L1), CH(IN2,IDO,L1,2), WA1(IDO) 
-!                                                                       
-      DO 101 K=1,L1 
-         CH(1,1,K,1) = CC(1,1,1,K)+CC(1,IDO,2,K) 
-         CH(1,1,K,2) = CC(1,1,1,K)-CC(1,IDO,2,K) 
-  101 END DO 
-      IF (IDO-2) 107,105,102 
-  102 IDP2 = IDO+2 
-      DO 104 K=1,L1 
-         DO 103 I=3,IDO,2 
-            IC = IDP2-I 
-                                                                        
-            CH(1,I-1,K,1) = CC(1,I-1,1,K)+CC(1,IC-1,2,K) 
-            CH(1,I,K,1) = CC(1,I,1,K)-CC(1,IC,2,K) 
-                                                                        
-            CH(1,I-1,K,2) = WA1(I-2)*(CC(1,I-1,1,K)-CC(1,IC-1,2,K))     &
-     &           -WA1(I-1)*(CC(1,I,1,K)+CC(1,IC,2,K))                   
-            CH(1,I,K,2) = WA1(I-2)*(CC(1,I,1,K)+CC(1,IC,2,K))+WA1(I-1)  &
-     &           *(CC(1,I-1,1,K)-CC(1,IC-1,2,K))                        
-                                                                        
-  103    CONTINUE 
-  104 END DO 
-      IF (MOD(IDO,2) .EQ. 1) RETURN 
-  105 DO 106 K=1,L1 
-         CH(1,IDO,K,1) = CC(1,IDO,1,K)+CC(1,IDO,1,K) 
-         CH(1,IDO,K,2) = -(CC(1,1,2,K)+CC(1,1,2,K)) 
-  106 END DO 
-  107 RETURN 
-      END                                           
+subroutine r1f2kb ( ido, l1, cc, in1, ch, in2, wa1 )
+
+!*****************************************************************************80
+!
+!! R1F2KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,ido,2,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,2)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 4 ) wa1(ido)
+
+  do k = 1, l1
+    ch(1,1,k,1) = cc(1,1,1,k) + cc(1,ido,2,k)
+    ch(1,1,k,2) = cc(1,1,1,k) - cc(1,ido,2,k)
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+
+        ch(1,i-1,k,1) = cc(1,i-1,1,k) + cc(1,ic-1,2,k)
+        ch(1,i,k,1)   = cc(1,i,1,k)   - cc(1,ic,2,k)
+
+        ch(1,i-1,k,2) = wa1(i-2) * ( cc(1,i-1,1,k) - cc(1,ic-1,2,k) ) &
+                      - wa1(i-1) * ( cc(1,i,1,k)   + cc(1,ic,2,k) )
+        ch(1,i,k,2)   = wa1(i-2) * ( cc(1,i,1,k)   + cc(1,ic,2,k) ) &
+                      + wa1(i-1) * ( cc(1,i-1,1,k) - cc(1,ic-1,2,k) )
+
+      end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    ch(1,ido,k,1) =     cc(1,ido,1,k) + cc(1,ido,1,k)
+    ch(1,ido,k,2) = - ( cc(1,1,2,k)   + cc(1,1,2,k) )
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r1f2kf.F b/wrfv2_fire/external/fftpack/fftpack5/r1f2kf.F
index 0c547c79..57e464b3 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/r1f2kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/r1f2kf.F
@@ -1,39 +1,90 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: r1f2kf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE R1F2KF (IDO,L1,CC,IN1,CH,IN2,WA1) 
-      REAL       CH(IN2,IDO,2,L1) ,CC(IN1,IDO,L1,2) , WA1(IDO) 
-!                                                                       
-      DO 101 K=1,L1 
-         CH(1,1,1,K) = CC(1,1,K,1)+CC(1,1,K,2) 
-         CH(1,IDO,2,K) = CC(1,1,K,1)-CC(1,1,K,2) 
-  101 END DO 
-      IF (IDO-2) 107,105,102 
-  102 IDP2 = IDO+2 
-      DO 104 K=1,L1 
-         DO 103 I=3,IDO,2 
-            IC = IDP2-I 
-            CH(1,I,1,K) = CC(1,I,K,1)+(WA1(I-2)*CC(1,I,K,2)-            &
-     &       WA1(I-1)*CC(1,I-1,K,2))                                    
-            CH(1,IC,2,K) = (WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*              &
-     &       CC(1,I-1,K,2))-CC(1,I,K,1)                                 
-            CH(1,I-1,1,K) = CC(1,I-1,K,1)+(WA1(I-2)*CC(1,I-1,K,2)+      &
-     &       WA1(I-1)*CC(1,I,K,2))                                      
-            CH(1,IC-1,2,K) = CC(1,I-1,K,1)-(WA1(I-2)*CC(1,I-1,K,2)+     &
-     &       WA1(I-1)*CC(1,I,K,2))                                      
-  103    CONTINUE 
-  104 END DO 
-      IF (MOD(IDO,2) .EQ. 1) RETURN 
-  105 DO 106 K=1,L1 
-         CH(1,1,2,K) = -CC(1,IDO,K,2) 
-         CH(1,IDO,1,K) = CC(1,IDO,K,1) 
-  106 END DO 
-  107 RETURN 
-      END                                           
+subroutine r1f2kf ( ido, l1, cc, in1, ch, in2, wa1 )
+
+!*****************************************************************************80
+!
+!! R1F2KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) ch(in2,ido,2,l1)
+  real ( kind = 4 ) cc(in1,ido,l1,2)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 4 ) wa1(ido)
+
+  do k = 1, l1
+    ch(1,1,1,k)   = cc(1,1,k,1) + cc(1,1,k,2)
+    ch(1,ido,2,k) = cc(1,1,k,1) - cc(1,1,k,2)
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+        ch(1,i,1,k) = cc(1,i,k,1)   + ( wa1(i-2) * cc(1,i,k,2) &
+                                      - wa1(i-1) * cc(1,i-1,k,2) )
+        ch(1,ic,2,k) = -cc(1,i,k,1) + ( wa1(i-2) * cc(1,i,k,2) &
+                                      - wa1(i-1) * cc(1,i-1,k,2) )
+        ch(1,i-1,1,k) = cc(1,i-1,k,1)  + ( wa1(i-2) * cc(1,i-1,k,2) &
+                                         + wa1(i-1) * cc(1,i,k,2))
+        ch(1,ic-1,2,k) = cc(1,i-1,k,1) - ( wa1(i-2) * cc(1,i-1,k,2) &
+                                         + wa1(i-1) * cc(1,i,k,2))
+      end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    ch(1,1,2,k) = -cc(1,ido,k,2)
+    ch(1,ido,1,k) = cc(1,ido,k,1)
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r1f3kb.F b/wrfv2_fire/external/fftpack/fftpack5/r1f3kb.F
index e8f144d1..86d73731 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/r1f3kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/r1f3kb.F
@@ -1,59 +1,102 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: r1f3kb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE R1F3KB (IDO,L1,CC,IN1,CH,IN2,WA1,WA2) 
-      REAL       CC(IN1,IDO,3,L1)    ,CH(IN2,IDO,L1,3),                 &
-     &           WA1(IDO)   ,WA2(IDO)                                   
-!                                                                       
-      ARG=2.*4.*ATAN(1.0)/3. 
-      TAUR=COS(ARG) 
-      TAUI=SIN(ARG) 
-      DO 101 K=1,L1 
-         CH(1,1,K,1) = CC(1,1,1,K)+2.*CC(1,IDO,2,K) 
-         CH(1,1,K,2) = CC(1,1,1,K)+(2.*TAUR)*CC(1,IDO,2,K)              &
-     &   -(2.*TAUI)*CC(1,1,3,K)                                         
-         CH(1,1,K,3) = CC(1,1,1,K)+(2.*TAUR)*CC(1,IDO,2,K)              &
-     &   +2.*TAUI*CC(1,1,3,K)                                           
-  101 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      IDP2 = IDO+2 
-      DO 103 K=1,L1 
-         DO 102 I=3,IDO,2 
-            IC = IDP2-I 
-        CH(1,I-1,K,1) = CC(1,I-1,1,K)+(CC(1,I-1,3,K)+CC(1,IC-1,2,K)) 
-        CH(1,I,K,1) = CC(1,I,1,K)+(CC(1,I,3,K)-CC(1,IC,2,K)) 
-        CH(1,I-1,K,2) = WA1(I-2)*                                       &
-     & ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))-            &
-     & (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))                               &
-     &                   -WA1(I-1)*                                     &
-     & ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))+                  &
-     & (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))                           
-            CH(1,I,K,2) = WA1(I-2)*                                     &
-     & ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))+                  &
-     & (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))                           &
-     &                  +WA1(I-1)*                                      &
-     & ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))-            &
-     & (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))                               
-              CH(1,I-1,K,3) = WA2(I-2)*                                 &
-     & ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))+            &
-     & (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))                               &
-     &   -WA2(I-1)*                                                     &
-     & ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))-                  &
-     & (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))                           
-            CH(1,I,K,3) = WA2(I-2)*                                     &
-     & ((CC(1,I,1,K)+TAUR*(CC(1,I,3,K)-CC(1,IC,2,K)))-                  &
-     & (TAUI*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))))                           &
-     &                 +WA2(I-1)*                                       &
-     & ((CC(1,I-1,1,K)+TAUR*(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))+            &
-     & (TAUI*(CC(1,I,3,K)+CC(1,IC,2,K))))                               
-  102    CONTINUE 
-  103 END DO 
-      RETURN 
-      END                                           
+subroutine r1f3kb ( ido, l1, cc, in1, ch, in2, wa1, wa2 )
+
+!*****************************************************************************80
+!
+!! R1F3KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) cc(in1,ido,3,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,3)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 4 ) taui
+  real ( kind = 4 ) taur
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+
+  arg = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 ) / 3.0E+00
+  taur = cos ( arg )
+  taui = sin ( arg )
+
+  do k = 1, l1
+    ch(1,1,k,1) = cc(1,1,1,k) + 2.0E+00 * cc(1,ido,2,k)
+    ch(1,1,k,2) = cc(1,1,1,k) + 2.0E+00 * taur * cc(1,ido,2,k) &
+                              - 2.0E+00 * taui * cc(1,1,3,k)
+    ch(1,1,k,3) = cc(1,1,1,k) + 2.0E+00 * taur * cc(1,ido,2,k) &
+                              + 2.0E+00 * taui * cc(1,1,3,k)
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      ch(1,i-1,k,1) = cc(1,i-1,1,k)+(cc(1,i-1,3,k)+cc(1,ic-1,2,k))
+      ch(1,i,k,1) = cc(1,i,1,k)+(cc(1,i,3,k)-cc(1,ic,2,k))
+      ch(1,i-1,k,2) = wa1(i-2)* &
+        ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))- &
+        (taui*(cc(1,i,3,k)+cc(1,ic,2,k)))) -wa1(i-1)* &
+        ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))+ &
+        (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))))
+      ch(1,i,k,2) = wa1(i-2)* &
+        ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))+ &
+        (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))) +wa1(i-1)* &
+        ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))- &
+        (taui*(cc(1,i,3,k)+cc(1,ic,2,k))))
+      ch(1,i-1,k,3) = wa2(i-2)* &
+        ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))+ &
+        (taui*(cc(1,i,3,k)+cc(1,ic,2,k)))) -wa2(i-1)* &
+        ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))- &
+        (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))))
+      ch(1,i,k,3) = wa2(i-2)* &
+        ((cc(1,i,1,k)+taur*(cc(1,i,3,k)-cc(1,ic,2,k)))- &
+        (taui*(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))) +wa2(i-1)* &
+        ((cc(1,i-1,1,k)+taur*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))+ &
+        (taui*(cc(1,i,3,k)+cc(1,ic,2,k))))
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r1f3kf.F b/wrfv2_fire/external/fftpack/fftpack5/r1f3kf.F
index 12e4b4a0..7ea6df5e 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/r1f3kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/r1f3kf.F
@@ -1,58 +1,104 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: r1f3kf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE R1F3KF (IDO,L1,CC,IN1,CH,IN2,WA1,WA2) 
-      REAL       CH(IN2,IDO,3,L1)  ,CC(IN1,IDO,L1,3)     ,              &
-     &                WA1(IDO)     ,WA2(IDO)                            
-!                                                                       
-      ARG=2.*4.*ATAN(1.0)/3. 
-      TAUR=COS(ARG) 
-      TAUI=SIN(ARG) 
-      DO 101 K=1,L1 
-         CH(1,1,1,K) = CC(1,1,K,1)+(CC(1,1,K,2)+CC(1,1,K,3)) 
-         CH(1,1,3,K) = TAUI*(CC(1,1,K,3)-CC(1,1,K,2)) 
-         CH(1,IDO,2,K) = CC(1,1,K,1)+TAUR*                              &
-     &      (CC(1,1,K,2)+CC(1,1,K,3))                                   
-  101 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      IDP2 = IDO+2 
-      DO 103 K=1,L1 
-         DO 102 I=3,IDO,2 
-            IC = IDP2-I 
-            CH(1,I-1,1,K) = CC(1,I-1,K,1)+((WA1(I-2)*CC(1,I-1,K,2)+     &
-     &       WA1(I-1)*CC(1,I,K,2))+(WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*    &
-     &       CC(1,I,K,3)))                                              
-            CH(1,I,1,K) = CC(1,I,K,1)+((WA1(I-2)*CC(1,I,K,2)-           &
-     &       WA1(I-1)*CC(1,I-1,K,2))+(WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*    &
-     &       CC(1,I-1,K,3)))                                            
-            CH(1,I-1,3,K) = (CC(1,I-1,K,1)+TAUR*((WA1(I-2)*             &
-     &       CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2))+(WA2(I-2)*             &
-     &       CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3))))+(TAUI*((WA1(I-2)*    &
-     &       CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2))-(WA2(I-2)*             &
-     &       CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3))))                      
-            CH(1,IC-1,2,K) = (CC(1,I-1,K,1)+TAUR*((WA1(I-2)*            &
-     &       CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2))+(WA2(I-2)*             &
-     &       CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3))))-(TAUI*((WA1(I-2)*    &
-     &       CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2))-(WA2(I-2)*             &
-     &       CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3))))                      
-            CH(1,I,3,K) = (CC(1,I,K,1)+TAUR*((WA1(I-2)*CC(1,I,K,2)-     &
-     &       WA1(I-1)*CC(1,I-1,K,2))+(WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*    &
-     &       CC(1,I-1,K,3))))+(TAUI*((WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*  &
-     &       CC(1,I,K,3))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
-     &       CC(1,I,K,2))))                                             
-            CH(1,IC,2,K) = (TAUI*((WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*     &
-     &       CC(1,I,K,3))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
-     &       CC(1,I,K,2))))-(CC(1,I,K,1)+TAUR*((WA1(I-2)*CC(1,I,K,2)-   &
-     &       WA1(I-1)*CC(1,I-1,K,2))+(WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*    &
-     &       CC(1,I-1,K,3))))                                           
-  102    CONTINUE 
-  103 END DO 
-      RETURN 
-      END                                           
+subroutine r1f3kf ( ido, l1, cc, in1, ch, in2, wa1, wa2 )
+
+!*****************************************************************************80
+!
+!! R1F3KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) cc(in1,ido,l1,3)
+  real ( kind = 4 ) ch(in2,ido,3,l1)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 4 ) taui
+  real ( kind = 4 ) taur
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+
+  arg = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 ) / 3.0E+00
+  taur = cos ( arg )
+  taui = sin ( arg )
+
+  do k = 1, l1
+    ch(1,1,1,k) = cc(1,1,k,1)          + ( cc(1,1,k,2) + cc(1,1,k,3) )
+    ch(1,1,3,k) =                 taui * ( cc(1,1,k,3) - cc(1,1,k,2) )
+    ch(1,ido,2,k) = cc(1,1,k,1) + taur * ( cc(1,1,k,2) + cc(1,1,k,3) )
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      ch(1,i-1,1,k) = cc(1,i-1,k,1)+((wa1(i-2)*cc(1,i-1,k,2)+ &
+        wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3)))
+      ch(1,i,1,k) = cc(1,i,k,1)+((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3)))
+      ch(1,i-1,3,k) = (cc(1,i-1,k,1)+taur*((wa1(i-2)* &
+        cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)* &
+        cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))))+(taui*((wa1(i-2)* &
+        cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa2(i-2)* &
+        cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))))
+      ch(1,ic-1,2,k) = (cc(1,i-1,k,1)+taur*((wa1(i-2)* &
+        cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa2(i-2)* &
+        cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))))-(taui*((wa1(i-2)* &
+        cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa2(i-2)* &
+        cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))))
+      ch(1,i,3,k) = (cc(1,i,k,1)+taur*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))))+(taui*((wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2))))
+      ch(1,ic,2,k) = (taui*((wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2))))-(cc(1,i,k,1)+taur*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))))
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r1f4kb.F b/wrfv2_fire/external/fftpack/fftpack5/r1f4kb.F
index 70a83845..0157873d 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/r1f4kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/r1f4kb.F
@@ -1,69 +1,122 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: r1f4kb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE R1F4KB (IDO,L1,CC,IN1,CH,IN2,WA1,WA2,WA3) 
-      REAL       CC(IN1,IDO,4,L1)  ,CH(IN2,IDO,L1,4)    ,               &
-     &           WA1(IDO)  ,        WA2(IDO)  ,       WA3(IDO)          
-!                                                                       
-      SQRT2=SQRT(2.) 
-      DO 101 K=1,L1 
-         CH(1,1,K,3) = (CC(1,1,1,K)+CC(1,IDO,4,K))                      &
-     &   -(CC(1,IDO,2,K)+CC(1,IDO,2,K))                                 
-         CH(1,1,K,1) = (CC(1,1,1,K)+CC(1,IDO,4,K))                      &
-     &   +(CC(1,IDO,2,K)+CC(1,IDO,2,K))                                 
-         CH(1,1,K,4) = (CC(1,1,1,K)-CC(1,IDO,4,K))                      &
-     &   +(CC(1,1,3,K)+CC(1,1,3,K))                                     
-         CH(1,1,K,2) = (CC(1,1,1,K)-CC(1,IDO,4,K))                      &
-     &   -(CC(1,1,3,K)+CC(1,1,3,K))                                     
-  101 END DO 
-      IF (IDO-2) 107,105,102 
-  102 IDP2 = IDO+2 
-      DO 104 K=1,L1 
-         DO 103 I=3,IDO,2 
-            IC = IDP2-I 
-        CH(1,I-1,K,1) = (CC(1,I-1,1,K)+CC(1,IC-1,4,K))                  &
-     &  +(CC(1,I-1,3,K)+CC(1,IC-1,2,K))                                 
-        CH(1,I,K,1) = (CC(1,I,1,K)-CC(1,IC,4,K))                        &
-     &  +(CC(1,I,3,K)-CC(1,IC,2,K))                                     
-        CH(1,I-1,K,2)=WA1(I-2)*((CC(1,I-1,1,K)-CC(1,IC-1,4,K))          &
-     &  -(CC(1,I,3,K)+CC(1,IC,2,K)))-WA1(I-1)                           &
-     &  *((CC(1,I,1,K)+CC(1,IC,4,K))+(CC(1,I-1,3,K)-CC(1,IC-1,2,K)))    
-        CH(1,I,K,2)=WA1(I-2)*((CC(1,I,1,K)+CC(1,IC,4,K))                &
-     &  +(CC(1,I-1,3,K)-CC(1,IC-1,2,K)))+WA1(I-1)                       &
-     &  *((CC(1,I-1,1,K)-CC(1,IC-1,4,K))-(CC(1,I,3,K)+CC(1,IC,2,K)))    
-        CH(1,I-1,K,3)=WA2(I-2)*((CC(1,I-1,1,K)+CC(1,IC-1,4,K))          &
-     &  -(CC(1,I-1,3,K)+CC(1,IC-1,2,K)))-WA2(I-1)                       &
-     &  *((CC(1,I,1,K)-CC(1,IC,4,K))-(CC(1,I,3,K)-CC(1,IC,2,K)))        
-        CH(1,I,K,3)=WA2(I-2)*((CC(1,I,1,K)-CC(1,IC,4,K))                &
-     &  -(CC(1,I,3,K)-CC(1,IC,2,K)))+WA2(I-1)                           &
-     &  *((CC(1,I-1,1,K)+CC(1,IC-1,4,K))-(CC(1,I-1,3,K)                 &
-     &  +CC(1,IC-1,2,K)))                                               
-        CH(1,I-1,K,4)=WA3(I-2)*((CC(1,I-1,1,K)-CC(1,IC-1,4,K))          &
-     &  +(CC(1,I,3,K)+CC(1,IC,2,K)))-WA3(I-1)                           &
-     & *((CC(1,I,1,K)+CC(1,IC,4,K))-(CC(1,I-1,3,K)-CC(1,IC-1,2,K)))     
-        CH(1,I,K,4)=WA3(I-2)*((CC(1,I,1,K)+CC(1,IC,4,K))                &
-     &  -(CC(1,I-1,3,K)-CC(1,IC-1,2,K)))+WA3(I-1)                       &
-     &  *((CC(1,I-1,1,K)-CC(1,IC-1,4,K))+(CC(1,I,3,K)+CC(1,IC,2,K)))    
-  103    CONTINUE 
-  104 END DO 
-      IF (MOD(IDO,2) .EQ. 1) RETURN 
-  105 CONTINUE 
-      DO 106 K=1,L1 
-         CH(1,IDO,K,1) = (CC(1,IDO,1,K)+CC(1,IDO,3,K))                  &
-     &   +(CC(1,IDO,1,K)+CC(1,IDO,3,K))                                 
-         CH(1,IDO,K,2) = SQRT2*((CC(1,IDO,1,K)-CC(1,IDO,3,K))           &
-     &   -(CC(1,1,2,K)+CC(1,1,4,K)))                                    
-         CH(1,IDO,K,3) = (CC(1,1,4,K)-CC(1,1,2,K))                      &
-     &   +(CC(1,1,4,K)-CC(1,1,2,K))                                     
-         CH(1,IDO,K,4) = -SQRT2*((CC(1,IDO,1,K)-CC(1,IDO,3,K))          &
-     &   +(CC(1,1,2,K)+CC(1,1,4,K)))                                    
-  106 END DO 
-  107 RETURN 
-      END                                           
+subroutine r1f4kb ( ido, l1, cc, in1, ch, in2, wa1, wa2, wa3 )
+
+!*****************************************************************************80
+!
+!! R1F4KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,ido,4,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,4)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 4 ) sqrt2
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+  real ( kind = 4 ) wa3(ido)
+
+  sqrt2 = sqrt ( 2.0E+00 )
+
+  do k = 1, l1
+    ch(1,1,k,3) = ( cc(1,1,1,k)   + cc(1,ido,4,k) ) &
+                - ( cc(1,ido,2,k) + cc(1,ido,2,k) )
+    ch(1,1,k,1) = ( cc(1,1,1,k)   + cc(1,ido,4,k) ) &
+                + ( cc(1,ido,2,k) + cc(1,ido,2,k) )
+    ch(1,1,k,4) = ( cc(1,1,1,k)   - cc(1,ido,4,k) ) &
+                + ( cc(1,1,3,k)   + cc(1,1,3,k) )
+    ch(1,1,k,2) = ( cc(1,1,1,k)   - cc(1,ido,4,k) ) &
+                - ( cc(1,1,3,k)   + cc(1,1,3,k) )
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+        ch(1,i-1,k,1) = (cc(1,i-1,1,k)+cc(1,ic-1,4,k)) &
+          +(cc(1,i-1,3,k)+cc(1,ic-1,2,k))
+        ch(1,i,k,1) = (cc(1,i,1,k)-cc(1,ic,4,k)) &
+          +(cc(1,i,3,k)-cc(1,ic,2,k))
+        ch(1,i-1,k,2) = wa1(i-2)*((cc(1,i-1,1,k)-cc(1,ic-1,4,k)) &
+          -(cc(1,i,3,k)+cc(1,ic,2,k)))-wa1(i-1) &
+          *((cc(1,i,1,k)+cc(1,ic,4,k))+(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))
+        ch(1,i,k,2) = wa1(i-2)*((cc(1,i,1,k)+cc(1,ic,4,k)) &
+          +(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))+wa1(i-1) &
+          *((cc(1,i-1,1,k)-cc(1,ic-1,4,k))-(cc(1,i,3,k)+cc(1,ic,2,k)))
+        ch(1,i-1,k,3) = wa2(i-2)*((cc(1,i-1,1,k)+cc(1,ic-1,4,k)) &
+          -(cc(1,i-1,3,k)+cc(1,ic-1,2,k)))-wa2(i-1) &
+          *((cc(1,i,1,k)-cc(1,ic,4,k))-(cc(1,i,3,k)-cc(1,ic,2,k)))
+        ch(1,i,k,3) = wa2(i-2)*((cc(1,i,1,k)-cc(1,ic,4,k)) &
+          -(cc(1,i,3,k)-cc(1,ic,2,k)))+wa2(i-1) &
+          *((cc(1,i-1,1,k)+cc(1,ic-1,4,k))-(cc(1,i-1,3,k) &
+          +cc(1,ic-1,2,k)))
+        ch(1,i-1,k,4) = wa3(i-2)*((cc(1,i-1,1,k)-cc(1,ic-1,4,k)) &
+          +(cc(1,i,3,k)+cc(1,ic,2,k)))-wa3(i-1) &
+          *((cc(1,i,1,k)+cc(1,ic,4,k))-(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))
+        ch(1,i,k,4) = wa3(i-2)*((cc(1,i,1,k)+cc(1,ic,4,k)) &
+          -(cc(1,i-1,3,k)-cc(1,ic-1,2,k)))+wa3(i-1) &
+          *((cc(1,i-1,1,k)-cc(1,ic-1,4,k))+(cc(1,i,3,k)+cc(1,ic,2,k)))
+      end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    ch(1,ido,k,1) = ( cc(1,ido,1,k) + cc(1,ido,3,k) ) &
+                  + ( cc(1,ido,1,k) + cc(1,ido,3,k))
+    ch(1,ido,k,2) = sqrt2 * ( ( cc(1,ido,1,k) - cc(1,ido,3,k) ) &
+                            - ( cc(1,1,2,k)   + cc(1,1,4,k) ) )
+    ch(1,ido,k,3) = ( cc(1,1,4,k) - cc(1,1,2,k) ) &
+                  + ( cc(1,1,4,k) - cc(1,1,2,k) )
+    ch(1,ido,k,4) = -sqrt2 * ( ( cc(1,ido,1,k) - cc(1,ido,3,k) ) &
+                             + ( cc(1,1,2,k) + cc(1,1,4,k) ) )
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r1f4kf.F b/wrfv2_fire/external/fftpack/fftpack5/r1f4kf.F
index 95e406f6..6c84b1c9 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/r1f4kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/r1f4kf.F
@@ -1,76 +1,125 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: r1f4kf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE R1F4KF (IDO,L1,CC,IN1,CH,IN2,WA1,WA2,WA3) 
-      REAL       CC(IN1,IDO,L1,4)   ,CH(IN2,IDO,4,L1)     ,             &
-     &           WA1(IDO)           ,WA2(IDO)     ,WA3(IDO)             
-!                                                                       
-      HSQT2=SQRT(2.)/2. 
-      DO 101 K=1,L1 
-         CH(1,1,1,K) = (CC(1,1,K,2)+CC(1,1,K,4))                        &
-     &      +(CC(1,1,K,1)+CC(1,1,K,3))                                  
-         CH(1,IDO,4,K) = (CC(1,1,K,1)+CC(1,1,K,3))                      &
-     &      -(CC(1,1,K,2)+CC(1,1,K,4))                                  
-         CH(1,IDO,2,K) = CC(1,1,K,1)-CC(1,1,K,3) 
-         CH(1,1,3,K) = CC(1,1,K,4)-CC(1,1,K,2) 
-  101 END DO 
-      IF (IDO-2) 107,105,102 
-  102 IDP2 = IDO+2 
-      DO 104 K=1,L1 
-         DO 103 I=3,IDO,2 
-            IC = IDP2-I 
-            CH(1,I-1,1,K) = ((WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*          &
-     &       CC(1,I,K,2))+(WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*             &
-     &       CC(1,I,K,4)))+(CC(1,I-1,K,1)+(WA2(I-2)*CC(1,I-1,K,3)+      &
-     &       WA2(I-1)*CC(1,I,K,3)))                                     
-            CH(1,IC-1,4,K) = (CC(1,I-1,K,1)+(WA2(I-2)*CC(1,I-1,K,3)+    &
-     &       WA2(I-1)*CC(1,I,K,3)))-((WA1(I-2)*CC(1,I-1,K,2)+           &
-     &       WA1(I-1)*CC(1,I,K,2))+(WA3(I-2)*CC(1,I-1,K,4)+             &
-     &       WA3(I-1)*CC(1,I,K,4)))                                     
-            CH(1,I,1,K) = ((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*              &
-     &       CC(1,I-1,K,2))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
-     &       CC(1,I-1,K,4)))+(CC(1,I,K,1)+(WA2(I-2)*CC(1,I,K,3)-        &
-     &       WA2(I-1)*CC(1,I-1,K,3)))                                   
-            CH(1,IC,4,K) = ((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*             &
-     &       CC(1,I-1,K,2))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
-     &       CC(1,I-1,K,4)))-(CC(1,I,K,1)+(WA2(I-2)*CC(1,I,K,3)-        &
-     &       WA2(I-1)*CC(1,I-1,K,3)))                                   
-            CH(1,I-1,3,K) = ((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*            &
-     &       CC(1,I-1,K,2))-(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
-     &       CC(1,I-1,K,4)))+(CC(1,I-1,K,1)-(WA2(I-2)*CC(1,I-1,K,3)+    &
-     &       WA2(I-1)*CC(1,I,K,3)))                                     
-            CH(1,IC-1,2,K) = (CC(1,I-1,K,1)-(WA2(I-2)*CC(1,I-1,K,3)+    &
-     &       WA2(I-1)*CC(1,I,K,3)))-((WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*    &
-     &       CC(1,I-1,K,2))-(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
-     &       CC(1,I-1,K,4)))                                            
-            CH(1,I,3,K) = ((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*            &
-     &       CC(1,I,K,4))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
-     &       CC(1,I,K,2)))+(CC(1,I,K,1)-(WA2(I-2)*CC(1,I,K,3)-          &
-     &       WA2(I-1)*CC(1,I-1,K,3)))                                   
-            CH(1,IC,2,K) = ((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*           &
-     &       CC(1,I,K,4))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
-     &       CC(1,I,K,2)))-(CC(1,I,K,1)-(WA2(I-2)*CC(1,I,K,3)-          &
-     &       WA2(I-1)*CC(1,I-1,K,3)))                                   
-  103    CONTINUE 
-  104 END DO 
-      IF (MOD(IDO,2) .EQ. 1) RETURN 
-  105 CONTINUE 
-      DO 106 K=1,L1 
-            CH(1,IDO,1,K) = (HSQT2*(CC(1,IDO,K,2)-CC(1,IDO,K,4)))+      &
-     &       CC(1,IDO,K,1)                                              
-            CH(1,IDO,3,K) = CC(1,IDO,K,1)-(HSQT2*(CC(1,IDO,K,2)-        &
-     &       CC(1,IDO,K,4)))                                            
-            CH(1,1,2,K) = (-HSQT2*(CC(1,IDO,K,2)+CC(1,IDO,K,4)))-       &
-     &       CC(1,IDO,K,3)                                              
-            CH(1,1,4,K) = (-HSQT2*(CC(1,IDO,K,2)+CC(1,IDO,K,4)))+       &
-     &       CC(1,IDO,K,3)                                              
-  106 END DO 
-  107 RETURN 
-      END                                           
+subroutine r1f4kf ( ido, l1, cc, in1, ch, in2, wa1, wa2, wa3 )
+
+!*****************************************************************************80
+!
+!! R1F4KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) cc(in1,ido,l1,4)
+  real ( kind = 4 ) ch(in2,ido,4,l1)
+  real ( kind = 4 ) hsqt2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+  real ( kind = 4 ) wa3(ido)
+
+  hsqt2 = sqrt ( 2.0E+00 ) / 2.0E+00
+
+  do k = 1, l1
+    ch(1,1,1,k)   = ( cc(1,1,k,2) + cc(1,1,k,4) ) &
+                  + ( cc(1,1,k,1) + cc(1,1,k,3) )
+    ch(1,ido,4,k) = ( cc(1,1,k,1) + cc(1,1,k,3) ) &
+                  - ( cc(1,1,k,2) + cc(1,1,k,4) )
+    ch(1,ido,2,k) = cc(1,1,k,1) - cc(1,1,k,3)
+    ch(1,1,3,k)   = cc(1,1,k,4) - cc(1,1,k,2)
+  end do
+
+  if ( ido < 2 ) then
+    return
+  end if
+
+  if ( 2 < ido ) then
+
+    idp2 = ido + 2
+
+    do k = 1, l1
+      do i = 3, ido, 2
+        ic = idp2 - i
+        ch(1,i-1,1,k) = ((wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+          cc(1,i,k,2))+(wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+          cc(1,i,k,4)))+(cc(1,i-1,k,1)+(wa2(i-2)*cc(1,i-1,k,3)+ &
+          wa2(i-1)*cc(1,i,k,3)))
+        ch(1,ic-1,4,k) = (cc(1,i-1,k,1)+(wa2(i-2)*cc(1,i-1,k,3)+ &
+          wa2(i-1)*cc(1,i,k,3)))-((wa1(i-2)*cc(1,i-1,k,2)+ &
+          wa1(i-1)*cc(1,i,k,2))+(wa3(i-2)*cc(1,i-1,k,4)+ &
+          wa3(i-1)*cc(1,i,k,4)))
+        ch(1,i,1,k) = ((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* &
+          cc(1,i-1,k,2))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+          cc(1,i-1,k,4)))+(cc(1,i,k,1)+(wa2(i-2)*cc(1,i,k,3)- &
+          wa2(i-1)*cc(1,i-1,k,3)))
+        ch(1,ic,4,k) = ((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* &
+          cc(1,i-1,k,2))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+          cc(1,i-1,k,4)))-(cc(1,i,k,1)+(wa2(i-2)*cc(1,i,k,3)- &
+          wa2(i-1)*cc(1,i-1,k,3)))
+        ch(1,i-1,3,k) = ((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* &
+          cc(1,i-1,k,2))-(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+          cc(1,i-1,k,4)))+(cc(1,i-1,k,1)-(wa2(i-2)*cc(1,i-1,k,3)+ &
+          wa2(i-1)*cc(1,i,k,3)))
+        ch(1,ic-1,2,k) = (cc(1,i-1,k,1)-(wa2(i-2)*cc(1,i-1,k,3)+ &
+          wa2(i-1)*cc(1,i,k,3)))-((wa1(i-2)*cc(1,i,k,2)-wa1(i-1)* &
+          cc(1,i-1,k,2))-(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+          cc(1,i-1,k,4)))
+        ch(1,i,3,k) = ((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+          cc(1,i,k,4))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+          cc(1,i,k,2)))+(cc(1,i,k,1)-(wa2(i-2)*cc(1,i,k,3)- &
+          wa2(i-1)*cc(1,i-1,k,3)))
+        ch(1,ic,2,k) = ((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+          cc(1,i,k,4))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+          cc(1,i,k,2)))-(cc(1,i,k,1)-(wa2(i-2)*cc(1,i,k,3)- &
+          wa2(i-1)*cc(1,i-1,k,3)))
+       end do
+    end do
+
+    if ( mod ( ido, 2 ) == 1 ) then
+      return
+    end if
+
+  end if
+
+  do k = 1, l1
+    ch(1,ido,1,k) = (hsqt2*(cc(1,ido,k,2)-cc(1,ido,k,4)))+ cc(1,ido,k,1)
+    ch(1,ido,3,k) = cc(1,ido,k,1)-(hsqt2*(cc(1,ido,k,2)- cc(1,ido,k,4)))
+    ch(1,1,2,k) = (-hsqt2*(cc(1,ido,k,2)+cc(1,ido,k,4)))- cc(1,ido,k,3)
+    ch(1,1,4,k) = (-hsqt2*(cc(1,ido,k,2)+cc(1,ido,k,4)))+ cc(1,ido,k,3)
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r1f5kb.F b/wrfv2_fire/external/fftpack/fftpack5/r1f5kb.F
index 1b902e6f..71f746df 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/r1f5kb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/r1f5kb.F
@@ -1,115 +1,172 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: r1f5kb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE R1F5KB (IDO,L1,CC,IN1,CH,IN2,                          &
-     &       WA1,WA2,WA3,WA4)                                           
-      REAL   CC(IN1,IDO,5,L1)    ,CH(IN2,IDO,L1,5),                     &
-     &       WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)         
-!                                                                       
-      ARG=2.*4.*ATAN(1.0)/5. 
-      TR11=COS(ARG) 
-      TI11=SIN(ARG) 
-      TR12=COS(2.*ARG) 
-      TI12=SIN(2.*ARG) 
-      DO 101 K=1,L1 
-         CH(1,1,K,1) = CC(1,1,1,K)+2.*CC(1,IDO,2,K)+2.*CC(1,IDO,4,K) 
-         CH(1,1,K,2) = (CC(1,1,1,K)+TR11*2.*CC(1,IDO,2,K)               &
-     &   +TR12*2.*CC(1,IDO,4,K))-(TI11*2.*CC(1,1,3,K)                   &
-     &   +TI12*2.*CC(1,1,5,K))                                          
-         CH(1,1,K,3) = (CC(1,1,1,K)+TR12*2.*CC(1,IDO,2,K)               &
-     &   +TR11*2.*CC(1,IDO,4,K))-(TI12*2.*CC(1,1,3,K)                   &
-     &   -TI11*2.*CC(1,1,5,K))                                          
-         CH(1,1,K,4) = (CC(1,1,1,K)+TR12*2.*CC(1,IDO,2,K)               &
-     &   +TR11*2.*CC(1,IDO,4,K))+(TI12*2.*CC(1,1,3,K)                   &
-     &   -TI11*2.*CC(1,1,5,K))                                          
-         CH(1,1,K,5) = (CC(1,1,1,K)+TR11*2.*CC(1,IDO,2,K)               &
-     &   +TR12*2.*CC(1,IDO,4,K))+(TI11*2.*CC(1,1,3,K)                   &
-     &   +TI12*2.*CC(1,1,5,K))                                          
-  101 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      IDP2 = IDO+2 
-      DO 103 K=1,L1 
-         DO 102 I=3,IDO,2 
-            IC = IDP2-I 
-        CH(1,I-1,K,1) = CC(1,I-1,1,K)+(CC(1,I-1,3,K)+CC(1,IC-1,2,K))    &
-     &  +(CC(1,I-1,5,K)+CC(1,IC-1,4,K))                                 
-        CH(1,I,K,1) = CC(1,I,1,K)+(CC(1,I,3,K)-CC(1,IC,2,K))            &
-     &  +(CC(1,I,5,K)-CC(1,IC,4,K))                                     
-        CH(1,I-1,K,2) = WA1(I-2)*((CC(1,I-1,1,K)+TR11*                  &
-     &  (CC(1,I-1,3,K)+CC(1,IC-1,2,K))+TR12                             &
-     &  *(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))-(TI11*(CC(1,I,3,K)             &
-     &  +CC(1,IC,2,K))+TI12*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
-     &  -WA1(I-1)*((CC(1,I,1,K)+TR11*(CC(1,I,3,K)-CC(1,IC,2,K))         &
-     &  +TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))+(TI11*(CC(1,I-1,3,K)          &
-     &  -CC(1,IC-1,2,K))+TI12*(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))          
-        CH(1,I,K,2) = WA1(I-2)*((CC(1,I,1,K)+TR11*(CC(1,I,3,K)          &
-     &  -CC(1,IC,2,K))+TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))                 &
-     &  +(TI11*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))+TI12                      &
-     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))+WA1(I-1)                      &
-     &  *((CC(1,I-1,1,K)+TR11*(CC(1,I-1,3,K)                            &
-     &  +CC(1,IC-1,2,K))+TR12*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))           &
-     &  -(TI11*(CC(1,I,3,K)+CC(1,IC,2,K))+TI12                          &
-     &  *(CC(1,I,5,K)+CC(1,IC,4,K))))                                   
-        CH(1,I-1,K,3) = WA2(I-2)                                        &
-     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
-     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))-(TI12*(CC(1,I,3,K)        &
-     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
-     & -WA2(I-1)                                                        &
-     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
-     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
-     &  +(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
-     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               
-        CH(1,I,K,3) = WA2(I-2)                                          &
-     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
-     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
-     &  +(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
-     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               &
-     &  +WA2(I-1)                                                       &
-     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
-     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))-(TI12*(CC(1,I,3,K)        &
-     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))                
-        CH(1,I-1,K,4) = WA3(I-2)                                        &
-     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
-     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI12*(CC(1,I,3,K)        &
-     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
-     &  -WA3(I-1)                                                       &
-     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
-     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
-     &  -(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
-     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               
-        CH(1,I,K,4) = WA3(I-2)                                          &
-     & *((CC(1,I,1,K)+TR12*(CC(1,I,3,K)-                                &
-     &  CC(1,IC,2,K))+TR11*(CC(1,I,5,K)-CC(1,IC,4,K)))                  &
-     &  -(TI12*(CC(1,I-1,3,K)-CC(1,IC-1,2,K))-TI11                      &
-     &  *(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))                               &
-     &  +WA3(I-1)                                                       &
-     &  *((CC(1,I-1,1,K)+TR12*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
-     &  +TR11*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI12*(CC(1,I,3,K)        &
-     &  +CC(1,IC,2,K))-TI11*(CC(1,I,5,K)+CC(1,IC,4,K))))                
-        CH(1,I-1,K,5) = WA4(I-2)                                        &
-     &  *((CC(1,I-1,1,K)+TR11*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
-     &  +TR12*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI11*(CC(1,I,3,K)        &
-     &  +CC(1,IC,2,K))+TI12*(CC(1,I,5,K)+CC(1,IC,4,K))))                &
-     &  -WA4(I-1)                                                       &
-     &  *((CC(1,I,1,K)+TR11*(CC(1,I,3,K)-CC(1,IC,2,K))                  &
-     &  +TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))-(TI11*(CC(1,I-1,3,K)          &
-     &  -CC(1,IC-1,2,K))+TI12*(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))          
-        CH(1,I,K,5) = WA4(I-2)                                          &
-     &  *((CC(1,I,1,K)+TR11*(CC(1,I,3,K)-CC(1,IC,2,K))                  &
-     &  +TR12*(CC(1,I,5,K)-CC(1,IC,4,K)))-(TI11*(CC(1,I-1,3,K)          &
-     &  -CC(1,IC-1,2,K))+TI12*(CC(1,I-1,5,K)-CC(1,IC-1,4,K))))          &
-     &  +WA4(I-1)                                                       &
-     &  *((CC(1,I-1,1,K)+TR11*(CC(1,I-1,3,K)+CC(1,IC-1,2,K))            &
-     &  +TR12*(CC(1,I-1,5,K)+CC(1,IC-1,4,K)))+(TI11*(CC(1,I,3,K)        &
-     &  +CC(1,IC,2,K))+TI12*(CC(1,I,5,K)+CC(1,IC,4,K))))                
-  102    CONTINUE 
-  103 END DO 
-      RETURN 
-      END                                           
+subroutine r1f5kb ( ido, l1, cc, in1, ch, in2, wa1, wa2, wa3, wa4 )
+
+!*****************************************************************************80
+!
+!! R1F5KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) cc(in1,ido,5,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,5)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 4 ) ti11
+  real ( kind = 4 ) ti12
+  real ( kind = 4 ) tr11
+  real ( kind = 4 ) tr12
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+  real ( kind = 4 ) wa3(ido)
+  real ( kind = 4 ) wa4(ido)
+
+  arg = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 ) / 5.0E+00
+  tr11 = cos ( arg )
+  ti11 = sin ( arg )
+  tr12 = cos ( 2.0E+00 * arg )
+  ti12 = sin ( 2.0E+00 * arg )
+
+  do k = 1, l1
+
+    ch(1,1,k,1) = cc(1,1,1,k) + 2.0E+00 * cc(1,ido,2,k) &
+                              + 2.0E+00 * cc(1,ido,4,k)
+
+    ch(1,1,k,2) = ( cc(1,1,1,k) &
+      +   tr11 * 2.0E+00 * cc(1,ido,2,k) + tr12 * 2.0E+00 * cc(1,ido,4,k) ) &
+      - ( ti11 * 2.0E+00 * cc(1,1,3,k)   + ti12 * 2.0E+00 * cc(1,1,5,k))
+
+    ch(1,1,k,3) = ( cc(1,1,1,k) &
+      +   tr12 * 2.0E+00 * cc(1,ido,2,k) + tr11 * 2.0E+00 * cc(1,ido,4,k) ) &
+      - ( ti12 * 2.0E+00 * cc(1,1,3,k)   - ti11 * 2.0E+00 * cc(1,1,5,k))
+
+    ch(1,1,k,4) = ( cc(1,1,1,k) &
+      +   tr12 * 2.0E+00 * cc(1,ido,2,k) + tr11 * 2.0E+00 * cc(1,ido,4,k) ) &
+      + ( ti12 * 2.0E+00 * cc(1,1,3,k)   - ti11 * 2.0E+00 * cc(1,1,5,k))
+
+    ch(1,1,k,5) = ( cc(1,1,1,k) &
+      +   tr11 * 2.0E+00 * cc(1,ido,2,k) + tr12 * 2.0E+00 * cc(1,ido,4,k) ) &
+      + ( ti11 * 2.0E+00 * cc(1,1,3,k)   + ti12 * 2.0E+00 * cc(1,1,5,k) )
+
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      ch(1,i-1,k,1) = cc(1,i-1,1,k)+(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +(cc(1,i-1,5,k)+cc(1,ic-1,4,k))
+      ch(1,i,k,1) = cc(1,i,1,k)+(cc(1,i,3,k)-cc(1,ic,2,k)) &
+        +(cc(1,i,5,k)-cc(1,ic,4,k))
+      ch(1,i-1,k,2) = wa1(i-2)*((cc(1,i-1,1,k)+tr11* &
+        (cc(1,i-1,3,k)+cc(1,ic-1,2,k))+tr12 &
+        *(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))-(ti11*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))+ti12*(cc(1,i,5,k)+cc(1,ic,4,k)))) &
+        -wa1(i-1)*((cc(1,i,1,k)+tr11*(cc(1,i,3,k)-cc(1,ic,2,k)) &
+        +tr12*(cc(1,i,5,k)-cc(1,ic,4,k)))+(ti11*(cc(1,i-1,3,k) &
+        -cc(1,ic-1,2,k))+ti12*(cc(1,i-1,5,k)-cc(1,ic-1,4,k))))
+      ch(1,i,k,2) = wa1(i-2)*((cc(1,i,1,k)+tr11*(cc(1,i,3,k) &
+        -cc(1,ic,2,k))+tr12*(cc(1,i,5,k)-cc(1,ic,4,k))) &
+        +(ti11*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))+ti12 &
+        *(cc(1,i-1,5,k)-cc(1,ic-1,4,k))))+wa1(i-1) &
+        *((cc(1,i-1,1,k)+tr11*(cc(1,i-1,3,k) &
+        +cc(1,ic-1,2,k))+tr12*(cc(1,i-1,5,k)+cc(1,ic-1,4,k))) &
+        -(ti11*(cc(1,i,3,k)+cc(1,ic,2,k))+ti12 &
+        *(cc(1,i,5,k)+cc(1,ic,4,k))))
+      ch(1,i-1,k,3) = wa2(i-2) &
+        *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))-(ti12*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k)))) &
+        -wa2(i-1) &
+        *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- &
+      cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) &
+        +(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 &
+        *(cc(1,i-1,5,k)-cc(1,ic-1,4,k))))
+      ch(1,i,k,3) = wa2(i-2) &
+        *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- &
+        cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) &
+        +(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 &
+        *(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) &
+        +wa2(i-1) &
+        *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))-(ti12*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k))))
+      ch(1,i-1,k,4) = wa3(i-2) &
+        *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti12*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k)))) &
+        -wa3(i-1) &
+        *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- &
+      cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) &
+        -(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 &
+        *(cc(1,i-1,5,k)-cc(1,ic-1,4,k))))
+      ch(1,i,k,4) = wa3(i-2) &
+        *((cc(1,i,1,k)+tr12*(cc(1,i,3,k)- &
+        cc(1,ic,2,k))+tr11*(cc(1,i,5,k)-cc(1,ic,4,k))) &
+        -(ti12*(cc(1,i-1,3,k)-cc(1,ic-1,2,k))-ti11 &
+        *(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) &
+        +wa3(i-1) &
+        *((cc(1,i-1,1,k)+tr12*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr11*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti12*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))-ti11*(cc(1,i,5,k)+cc(1,ic,4,k))))
+      ch(1,i-1,k,5) = wa4(i-2) &
+        *((cc(1,i-1,1,k)+tr11*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr12*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti11*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))+ti12*(cc(1,i,5,k)+cc(1,ic,4,k)))) &
+        -wa4(i-1) &
+        *((cc(1,i,1,k)+tr11*(cc(1,i,3,k)-cc(1,ic,2,k)) &
+        +tr12*(cc(1,i,5,k)-cc(1,ic,4,k)))-(ti11*(cc(1,i-1,3,k) &
+        -cc(1,ic-1,2,k))+ti12*(cc(1,i-1,5,k)-cc(1,ic-1,4,k))))
+      ch(1,i,k,5) = wa4(i-2) &
+        *((cc(1,i,1,k)+tr11*(cc(1,i,3,k)-cc(1,ic,2,k)) &
+        +tr12*(cc(1,i,5,k)-cc(1,ic,4,k)))-(ti11*(cc(1,i-1,3,k) &
+        -cc(1,ic-1,2,k))+ti12*(cc(1,i-1,5,k)-cc(1,ic-1,4,k)))) &
+        +wa4(i-1) &
+        *((cc(1,i-1,1,k)+tr11*(cc(1,i-1,3,k)+cc(1,ic-1,2,k)) &
+        +tr12*(cc(1,i-1,5,k)+cc(1,ic-1,4,k)))+(ti11*(cc(1,i,3,k) &
+        +cc(1,ic,2,k))+ti12*(cc(1,i,5,k)+cc(1,ic,4,k))))
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r1f5kf.F b/wrfv2_fire/external/fftpack/fftpack5/r1f5kf.F
index b4f35338..c68c263b 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/r1f5kf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/r1f5kf.F
@@ -1,123 +1,178 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: r1f5kf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE R1F5KF (IDO,L1,CC,IN1,CH,IN2,                          &
-     &                   WA1,WA2,WA3,WA4)                               
-      REAL       CC(IN1,IDO,L1,5)    ,CH(IN2,IDO,5,L1)     ,            &
-     &           WA1(IDO)     ,WA2(IDO)     ,WA3(IDO)     ,WA4(IDO)     
-!                                                                       
-      ARG=2.*4.*ATAN(1.0)/5. 
-      TR11=COS(ARG) 
-      TI11=SIN(ARG) 
-      TR12=COS(2.*ARG) 
-      TI12=SIN(2.*ARG) 
-      DO 101 K=1,L1 
-         CH(1,1,1,K) = CC(1,1,K,1)+(CC(1,1,K,5)+CC(1,1,K,2))+           &
-     &    (CC(1,1,K,4)+CC(1,1,K,3))                                     
-         CH(1,IDO,2,K) = CC(1,1,K,1)+TR11*(CC(1,1,K,5)+CC(1,1,K,2))+    &
-     &    TR12*(CC(1,1,K,4)+CC(1,1,K,3))                                
-         CH(1,1,3,K) = TI11*(CC(1,1,K,5)-CC(1,1,K,2))+TI12*             &
-     &    (CC(1,1,K,4)-CC(1,1,K,3))                                     
-         CH(1,IDO,4,K) = CC(1,1,K,1)+TR12*(CC(1,1,K,5)+CC(1,1,K,2))+    &
-     &    TR11*(CC(1,1,K,4)+CC(1,1,K,3))                                
-         CH(1,1,5,K) = TI12*(CC(1,1,K,5)-CC(1,1,K,2))-TI11*             &
-     &    (CC(1,1,K,4)-CC(1,1,K,3))                                     
-  101 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      IDP2 = IDO+2 
-      DO 103 K=1,L1 
-         DO 102 I=3,IDO,2 
-            IC = IDP2-I 
-            CH(1,I-1,1,K) = CC(1,I-1,K,1)+((WA1(I-2)*CC(1,I-1,K,2)+     &
-     &       WA1(I-1)*CC(1,I,K,2))+(WA4(I-2)*CC(1,I-1,K,5)+WA4(I-1)*    &
-     &       CC(1,I,K,5)))+((WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*           &
-     &       CC(1,I,K,3))+(WA3(I-2)*CC(1,I-1,K,4)+                      &
-     &       WA3(I-1)*CC(1,I,K,4)))                                     
-            CH(1,I,1,K) = CC(1,I,K,1)+((WA1(I-2)*CC(1,I,K,2)-           &
-     &       WA1(I-1)*CC(1,I-1,K,2))+(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*    &
-     &       CC(1,I-1,K,5)))+((WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*           &
-     &       CC(1,I-1,K,3))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
-     &       CC(1,I-1,K,4)))                                            
-            CH(1,I-1,3,K) = CC(1,I-1,K,1)+TR11*                         &
-     &      ( WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2)               &
-     &       +WA4(I-2)*CC(1,I-1,K,5)+WA4(I-1)*CC(1,I,K,5))+TR12*        &
-     &      ( WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3)               &
-     &       +WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*CC(1,I,K,4))+TI11*        &
-     &      ( WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2)               &
-     &       -(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*CC(1,I-1,K,5)))+TI12*      &
-     &      ( WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3)               &
-     &       -(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*CC(1,I-1,K,4)))            
-            CH(1,IC-1,2,K) = CC(1,I-1,K,1)+TR11*                        &
-     &      ( WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2)               &
-     &       +WA4(I-2)*CC(1,I-1,K,5)+WA4(I-1)*CC(1,I,K,5))+TR12*        &
-     &     ( WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3)                &
-     &      +WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*CC(1,I,K,4))-(TI11*        &
-     &      ( WA1(I-2)*CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2)               &
-     &       -(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*CC(1,I-1,K,5)))+TI12*      &
-     &      ( WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3)               &
-     &       -(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*CC(1,I-1,K,4))))           
-            CH(1,I,3,K) = (CC(1,I,K,1)+TR11*((WA1(I-2)*CC(1,I,K,2)-     &
-     &       WA1(I-1)*CC(1,I-1,K,2))+(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*    &
-     &       CC(1,I-1,K,5)))+TR12*((WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*      &
-     &       CC(1,I-1,K,3))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
-     &       CC(1,I-1,K,4))))+(TI11*((WA4(I-2)*CC(1,I-1,K,5)+           &
-     &       WA4(I-1)*CC(1,I,K,5))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*    &
-     &       CC(1,I,K,2)))+TI12*((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*      &
-     &       CC(1,I,K,4))-(WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*             &
-     &       CC(1,I,K,3))))                                             
-            CH(1,IC,2,K) = (TI11*((WA4(I-2)*CC(1,I-1,K,5)+WA4(I-1)*     &
-     &       CC(1,I,K,5))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
-     &       CC(1,I,K,2)))+TI12*((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*      &
-     &       CC(1,I,K,4))-(WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*             &
-     &       CC(1,I,K,3))))-(CC(1,I,K,1)+TR11*((WA1(I-2)*CC(1,I,K,2)-   &
-     &       WA1(I-1)*CC(1,I-1,K,2))+(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*    &
-     &       CC(1,I-1,K,5)))+TR12*((WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*      &
-     &       CC(1,I-1,K,3))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
-     &       CC(1,I-1,K,4))))                                           
-            CH(1,I-1,5,K) = (CC(1,I-1,K,1)+TR12*((WA1(I-2)*             &
-     &       CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2))+(WA4(I-2)*             &
-     &       CC(1,I-1,K,5)+WA4(I-1)*CC(1,I,K,5)))+TR11*((WA2(I-2)*      &
-     &       CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3))+(WA3(I-2)*             &
-     &       CC(1,I-1,K,4)+WA3(I-1)*CC(1,I,K,4))))+(TI12*((WA1(I-2)*    &
-     &       CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2))-(WA4(I-2)*             &
-     &       CC(1,I,K,5)-WA4(I-1)*CC(1,I-1,K,5)))-TI11*((WA2(I-2)*      &
-     &       CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3))-(WA3(I-2)*             &
-     &       CC(1,I,K,4)-WA3(I-1)*CC(1,I-1,K,4))))                      
-            CH(1,IC-1,4,K) = (CC(1,I-1,K,1)+TR12*((WA1(I-2)*            &
-     &       CC(1,I-1,K,2)+WA1(I-1)*CC(1,I,K,2))+(WA4(I-2)*             &
-     &       CC(1,I-1,K,5)+WA4(I-1)*CC(1,I,K,5)))+TR11*((WA2(I-2)*      &
-     &       CC(1,I-1,K,3)+WA2(I-1)*CC(1,I,K,3))+(WA3(I-2)*             &
-     &       CC(1,I-1,K,4)+WA3(I-1)*CC(1,I,K,4))))-(TI12*((WA1(I-2)*    &
-     &       CC(1,I,K,2)-WA1(I-1)*CC(1,I-1,K,2))-(WA4(I-2)*             &
-     &       CC(1,I,K,5)-WA4(I-1)*CC(1,I-1,K,5)))-TI11*((WA2(I-2)*      &
-     &       CC(1,I,K,3)-WA2(I-1)*CC(1,I-1,K,3))-(WA3(I-2)*             &
-     &       CC(1,I,K,4)-WA3(I-1)*CC(1,I-1,K,4))))                      
-            CH(1,I,5,K) = (CC(1,I,K,1)+TR12*((WA1(I-2)*CC(1,I,K,2)-     &
-     &       WA1(I-1)*CC(1,I-1,K,2))+(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*    &
-     &       CC(1,I-1,K,5)))+TR11*((WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*      &
-     &       CC(1,I-1,K,3))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
-     &       CC(1,I-1,K,4))))+(TI12*((WA4(I-2)*CC(1,I-1,K,5)+           &
-     &       WA4(I-1)*CC(1,I,K,5))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*    &
-     &       CC(1,I,K,2)))-TI11*((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*      &
-     &       CC(1,I,K,4))-(WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*             &
-     &       CC(1,I,K,3))))                                             
-            CH(1,IC,4,K) = (TI12*((WA4(I-2)*CC(1,I-1,K,5)+WA4(I-1)*     &
-     &       CC(1,I,K,5))-(WA1(I-2)*CC(1,I-1,K,2)+WA1(I-1)*             &
-     &       CC(1,I,K,2)))-TI11*((WA3(I-2)*CC(1,I-1,K,4)+WA3(I-1)*      &
-     &       CC(1,I,K,4))-(WA2(I-2)*CC(1,I-1,K,3)+WA2(I-1)*             &
-     &       CC(1,I,K,3))))-(CC(1,I,K,1)+TR12*((WA1(I-2)*CC(1,I,K,2)-   &
-     &       WA1(I-1)*CC(1,I-1,K,2))+(WA4(I-2)*CC(1,I,K,5)-WA4(I-1)*    &
-     &       CC(1,I-1,K,5)))+TR11*((WA2(I-2)*CC(1,I,K,3)-WA2(I-1)*      &
-     &       CC(1,I-1,K,3))+(WA3(I-2)*CC(1,I,K,4)-WA3(I-1)*             &
-     &       CC(1,I-1,K,4))))                                           
-  102    CONTINUE 
-  103 END DO 
-      RETURN 
-      END                                           
+subroutine r1f5kf ( ido, l1, cc, in1, ch, in2, wa1, wa2, wa3, wa4 )
+
+!*****************************************************************************80
+!
+!! R1F5KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) cc(in1,ido,l1,5)
+  real ( kind = 4 ) ch(in2,ido,5,l1)
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) k
+  real ( kind = 4 ) ti11
+  real ( kind = 4 ) ti12
+  real ( kind = 4 ) tr11
+  real ( kind = 4 ) tr12
+  real ( kind = 4 ) wa1(ido)
+  real ( kind = 4 ) wa2(ido)
+  real ( kind = 4 ) wa3(ido)
+  real ( kind = 4 ) wa4(ido)
+
+  arg = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 ) / 5.0E+00
+  tr11 = cos ( arg )
+  ti11 = sin ( arg )
+  tr12 = cos ( 2.0E+00 * arg )
+  ti12 = sin ( 2.0E+00 * arg )
+
+  do k = 1, l1
+
+    ch(1,1,1,k) = cc(1,1,k,1) + ( cc(1,1,k,5) + cc(1,1,k,2) ) &
+                              + ( cc(1,1,k,4) + cc(1,1,k,3) )
+
+    ch(1,ido,2,k) = cc(1,1,k,1) + tr11 * ( cc(1,1,k,5) + cc(1,1,k,2) ) &
+                                + tr12 * ( cc(1,1,k,4) + cc(1,1,k,3) )
+
+    ch(1,1,3,k) =                 ti11 * ( cc(1,1,k,5) - cc(1,1,k,2) ) &
+                                + ti12 * ( cc(1,1,k,4) - cc(1,1,k,3) )
+
+    ch(1,ido,4,k) = cc(1,1,k,1) + tr12 * ( cc(1,1,k,5) + cc(1,1,k,2) ) &
+                                + tr11 * ( cc(1,1,k,4) + cc(1,1,k,3) )
+
+    ch(1,1,5,k) =                 ti12 * ( cc(1,1,k,5) - cc(1,1,k,2) ) &
+                                - ti11 * ( cc(1,1,k,4) - cc(1,1,k,3) )
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  idp2 = ido + 2
+
+  do k = 1, l1
+    do i = 3, ido, 2
+      ic = idp2 - i
+      ch(1,i-1,1,k) = cc(1,i-1,k,1)+((wa1(i-2)*cc(1,i-1,k,2)+ &
+        wa1(i-1)*cc(1,i,k,2))+(wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)* &
+        cc(1,i,k,5)))+((wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))+(wa3(i-2)*cc(1,i-1,k,4)+ &
+        wa3(i-1)*cc(1,i,k,4)))
+      ch(1,i,1,k) = cc(1,i,k,1)+((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* &
+        cc(1,i-1,k,5)))+((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+        cc(1,i-1,k,4)))
+      ch(1,i-1,3,k) = cc(1,i-1,k,1)+tr11* &
+        ( wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2) &
+        +wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5))+tr12* &
+        ( wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3) &
+        +wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))+ti11* &
+        ( wa1(i-2)*cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2) &
+        -(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))+ti12* &
+        ( wa2(i-2)*cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3) &
+        -(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4)))
+      ch(1,ic-1,2,k) = cc(1,i-1,k,1)+tr11* &
+        ( wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2) &
+        +wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5))+tr12* &
+        ( wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3) &
+        +wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))-(ti11* &
+        ( wa1(i-2)*cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2) &
+        -(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))+ti12* &
+        ( wa2(i-2)*cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3) &
+        -(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4))))
+      ch(1,i,3,k) = (cc(1,i,k,1)+tr11*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* &
+        cc(1,i-1,k,5)))+tr12*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+        cc(1,i-1,k,4))))+(ti11*((wa4(i-2)*cc(1,i-1,k,5)+ &
+        wa4(i-1)*cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2)))+ti12*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+        cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))))
+      ch(1,ic,2,k) = (ti11*((wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)* &
+        cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2)))+ti12*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+        cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))))-(cc(1,i,k,1)+tr11*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* &
+        cc(1,i-1,k,5)))+tr12*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+        cc(1,i-1,k,4))))
+      ch(1,i-1,5,k) = (cc(1,i-1,k,1)+tr12*((wa1(i-2)* &
+        cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa4(i-2)* &
+        cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5)))+tr11*((wa2(i-2)* &
+        cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))+(wa3(i-2)* &
+        cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))))+(ti12*((wa1(i-2)* &
+        cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa4(i-2)* &
+        cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))-ti11*((wa2(i-2)* &
+        cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))-(wa3(i-2)* &
+        cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4))))
+      ch(1,ic-1,4,k) = (cc(1,i-1,k,1)+tr12*((wa1(i-2)* &
+        cc(1,i-1,k,2)+wa1(i-1)*cc(1,i,k,2))+(wa4(i-2)* &
+        cc(1,i-1,k,5)+wa4(i-1)*cc(1,i,k,5)))+tr11*((wa2(i-2)* &
+        cc(1,i-1,k,3)+wa2(i-1)*cc(1,i,k,3))+(wa3(i-2)* &
+        cc(1,i-1,k,4)+wa3(i-1)*cc(1,i,k,4))))-(ti12*((wa1(i-2)* &
+        cc(1,i,k,2)-wa1(i-1)*cc(1,i-1,k,2))-(wa4(i-2)* &
+        cc(1,i,k,5)-wa4(i-1)*cc(1,i-1,k,5)))-ti11*((wa2(i-2)* &
+        cc(1,i,k,3)-wa2(i-1)*cc(1,i-1,k,3))-(wa3(i-2)* &
+        cc(1,i,k,4)-wa3(i-1)*cc(1,i-1,k,4))))
+      ch(1,i,5,k) = (cc(1,i,k,1)+tr12*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* &
+        cc(1,i-1,k,5)))+tr11*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+        cc(1,i-1,k,4))))+(ti12*((wa4(i-2)*cc(1,i-1,k,5)+ &
+        wa4(i-1)*cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2)))-ti11*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+        cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))))
+      ch(1,ic,4,k) = (ti12*((wa4(i-2)*cc(1,i-1,k,5)+wa4(i-1)* &
+        cc(1,i,k,5))-(wa1(i-2)*cc(1,i-1,k,2)+wa1(i-1)* &
+        cc(1,i,k,2)))-ti11*((wa3(i-2)*cc(1,i-1,k,4)+wa3(i-1)* &
+        cc(1,i,k,4))-(wa2(i-2)*cc(1,i-1,k,3)+wa2(i-1)* &
+        cc(1,i,k,3))))-(cc(1,i,k,1)+tr12*((wa1(i-2)*cc(1,i,k,2)- &
+        wa1(i-1)*cc(1,i-1,k,2))+(wa4(i-2)*cc(1,i,k,5)-wa4(i-1)* &
+        cc(1,i-1,k,5)))+tr11*((wa2(i-2)*cc(1,i,k,3)-wa2(i-1)* &
+        cc(1,i-1,k,3))+(wa3(i-2)*cc(1,i,k,4)-wa3(i-1)* &
+        cc(1,i-1,k,4))))
+     end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r1fgkb.F b/wrfv2_fire/external/fftpack/fftpack5/r1fgkb.F
index 82c8b915..483029ec 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/r1fgkb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/r1fgkb.F
@@ -1,177 +1,275 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: r1fgkb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE R1FGKB (IDO,IP,L1,IDL1,CC,C1,C2,IN1,                   &
-     &          CH,CH2,IN2,WA)                                          
-      REAL      CH(IN2,IDO,L1,IP)    ,CC(IN1,IDO,IP,L1) ,               &
-     &          C1(IN1,IDO,L1,IP)    ,C2(IN1,IDL1,IP),                  &
-     &          CH2(IN2,IDL1,IP)     ,WA(IDO)                           
-!                                                                       
-      TPI=2.*4.*ATAN(1.0) 
-      ARG = TPI/FLOAT(IP) 
-      DCP = COS(ARG) 
-      DSP = SIN(ARG) 
-      IDP2 = IDO+2 
-      NBD = (IDO-1)/2 
-      IPP2 = IP+2 
-      IPPH = (IP+1)/2 
-      IF (IDO .LT. L1) GO TO 103 
-      DO 102 K=1,L1 
-         DO 101 I=1,IDO 
-            CH(1,I,K,1) = CC(1,I,1,K) 
-  101    CONTINUE 
-  102 END DO 
-      GO TO 106 
-  103 DO 105 I=1,IDO 
-         DO 104 K=1,L1 
-            CH(1,I,K,1) = CC(1,I,1,K) 
-  104    CONTINUE 
-  105 END DO 
-  106 DO 108 J=2,IPPH 
-         JC = IPP2-J 
-         J2 = J+J 
-         DO 107 K=1,L1 
-            CH(1,1,K,J) = CC(1,IDO,J2-2,K)+CC(1,IDO,J2-2,K) 
-            CH(1,1,K,JC) = CC(1,1,J2-1,K)+CC(1,1,J2-1,K) 
- 1007       CONTINUE 
-  107    CONTINUE 
-  108 END DO 
-      IF (IDO .EQ. 1) GO TO 116 
-      IF (NBD .LT. L1) GO TO 112 
-      DO 111 J=2,IPPH 
-         JC = IPP2-J 
-         DO 110 K=1,L1 
-            DO 109 I=3,IDO,2 
-               IC = IDP2-I 
-               CH(1,I-1,K,J) = CC(1,I-1,2*J-1,K)+CC(1,IC-1,2*J-2,K) 
-               CH(1,I-1,K,JC) = CC(1,I-1,2*J-1,K)-CC(1,IC-1,2*J-2,K) 
-               CH(1,I,K,J) = CC(1,I,2*J-1,K)-CC(1,IC,2*J-2,K) 
-               CH(1,I,K,JC) = CC(1,I,2*J-1,K)+CC(1,IC,2*J-2,K) 
-  109       CONTINUE 
-  110    CONTINUE 
-  111 END DO 
-      GO TO 116 
-  112 DO 115 J=2,IPPH 
-         JC = IPP2-J 
-         DO 114 I=3,IDO,2 
-            IC = IDP2-I 
-            DO 113 K=1,L1 
-               CH(1,I-1,K,J) = CC(1,I-1,2*J-1,K)+CC(1,IC-1,2*J-2,K) 
-               CH(1,I-1,K,JC) = CC(1,I-1,2*J-1,K)-CC(1,IC-1,2*J-2,K) 
-               CH(1,I,K,J) = CC(1,I,2*J-1,K)-CC(1,IC,2*J-2,K) 
-               CH(1,I,K,JC) = CC(1,I,2*J-1,K)+CC(1,IC,2*J-2,K) 
-  113       CONTINUE 
-  114    CONTINUE 
-  115 END DO 
-  116 AR1 = 1. 
-      AI1 = 0. 
-      DO 120 L=2,IPPH 
-         LC = IPP2-L 
-         AR1H = DCP*AR1-DSP*AI1 
-         AI1 = DCP*AI1+DSP*AR1 
-         AR1 = AR1H 
-         DO 117 IK=1,IDL1 
-            C2(1,IK,L) = CH2(1,IK,1)+AR1*CH2(1,IK,2) 
-            C2(1,IK,LC) = AI1*CH2(1,IK,IP) 
-  117    CONTINUE 
-         DC2 = AR1 
-         DS2 = AI1 
-         AR2 = AR1 
-         AI2 = AI1 
-         DO 119 J=3,IPPH 
-            JC = IPP2-J 
-            AR2H = DC2*AR2-DS2*AI2 
-            AI2 = DC2*AI2+DS2*AR2 
-            AR2 = AR2H 
-            DO 118 IK=1,IDL1 
-               C2(1,IK,L) = C2(1,IK,L)+AR2*CH2(1,IK,J) 
-               C2(1,IK,LC) = C2(1,IK,LC)+AI2*CH2(1,IK,JC) 
-  118       CONTINUE 
-  119    CONTINUE 
-  120 END DO 
-      DO 122 J=2,IPPH 
-         DO 121 IK=1,IDL1 
-            CH2(1,IK,1) = CH2(1,IK,1)+CH2(1,IK,J) 
-  121    CONTINUE 
-  122 END DO 
-      DO 124 J=2,IPPH 
-         JC = IPP2-J 
-         DO 123 K=1,L1 
-            CH(1,1,K,J) = C1(1,1,K,J)-C1(1,1,K,JC) 
-            CH(1,1,K,JC) = C1(1,1,K,J)+C1(1,1,K,JC) 
-  123    CONTINUE 
-  124 END DO 
-      IF (IDO .EQ. 1) GO TO 132 
-      IF (NBD .LT. L1) GO TO 128 
-      DO 127 J=2,IPPH 
-         JC = IPP2-J 
-         DO 126 K=1,L1 
-            DO 125 I=3,IDO,2 
-               CH(1,I-1,K,J) = C1(1,I-1,K,J)-C1(1,I,K,JC) 
-               CH(1,I-1,K,JC) = C1(1,I-1,K,J)+C1(1,I,K,JC) 
-               CH(1,I,K,J) = C1(1,I,K,J)+C1(1,I-1,K,JC) 
-               CH(1,I,K,JC) = C1(1,I,K,J)-C1(1,I-1,K,JC) 
-  125       CONTINUE 
-  126    CONTINUE 
-  127 END DO 
-      GO TO 132 
-  128 DO 131 J=2,IPPH 
-         JC = IPP2-J 
-         DO 130 I=3,IDO,2 
-            DO 129 K=1,L1 
-               CH(1,I-1,K,J) = C1(1,I-1,K,J)-C1(1,I,K,JC) 
-               CH(1,I-1,K,JC) = C1(1,I-1,K,J)+C1(1,I,K,JC) 
-               CH(1,I,K,J) = C1(1,I,K,J)+C1(1,I-1,K,JC) 
-               CH(1,I,K,JC) = C1(1,I,K,J)-C1(1,I-1,K,JC) 
-  129       CONTINUE 
-  130    CONTINUE 
-  131 END DO 
-  132 CONTINUE 
-      IF (IDO .EQ. 1) RETURN 
-      DO 133 IK=1,IDL1 
-         C2(1,IK,1) = CH2(1,IK,1) 
-  133 END DO 
-      DO 135 J=2,IP 
-         DO 134 K=1,L1 
-            C1(1,1,K,J) = CH(1,1,K,J) 
-  134    CONTINUE 
-  135 END DO 
-      IF (NBD .GT. L1) GO TO 139 
-      IS = -IDO 
-      DO 138 J=2,IP 
-         IS = IS+IDO 
-         IDIJ = IS 
-         DO 137 I=3,IDO,2 
-            IDIJ = IDIJ+2 
-            DO 136 K=1,L1 
-               C1(1,I-1,K,J) = WA(IDIJ-1)*CH(1,I-1,K,J)-WA(IDIJ)*       &
-     &          CH(1,I,K,J)                                             
-               C1(1,I,K,J) = WA(IDIJ-1)*CH(1,I,K,J)+WA(IDIJ)*           &
-     &          CH(1,I-1,K,J)                                           
-  136       CONTINUE 
-  137    CONTINUE 
-  138 END DO 
-      GO TO 143 
-  139 IS = -IDO 
-      DO 142 J=2,IP 
-         IS = IS+IDO 
-         DO 141 K=1,L1 
-            IDIJ = IS 
-            DO 140 I=3,IDO,2 
-               IDIJ = IDIJ+2 
-               C1(1,I-1,K,J) = WA(IDIJ-1)*CH(1,I-1,K,J)-WA(IDIJ)*       &
-     &          CH(1,I,K,J)                                             
-               C1(1,I,K,J) = WA(IDIJ-1)*CH(1,I,K,J)+WA(IDIJ)*           &
-     &          CH(1,I-1,K,J)                                           
-  140       CONTINUE 
-  141    CONTINUE 
-  142 END DO 
-  143 RETURN 
-      END                                           
+subroutine r1fgkb ( ido, ip, l1, idl1, cc, c1, c2, in1, ch, ch2, in2, wa )
+
+!*****************************************************************************80
+!
+!! R1FGKB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) ai1
+  real ( kind = 4 ) ai2
+  real ( kind = 4 ) ar1
+  real ( kind = 4 ) ar1h
+  real ( kind = 4 ) ar2
+  real ( kind = 4 ) ar2h
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) c1(in1,ido,l1,ip)
+  real ( kind = 4 ) c2(in1,idl1,ip)
+  real ( kind = 4 ) cc(in1,ido,ip,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,ip)
+  real ( kind = 4 ) ch2(in2,idl1,ip)
+  real ( kind = 4 ) dc2
+  real ( kind = 4 ) dcp
+  real ( kind = 4 ) ds2
+  real ( kind = 4 ) dsp
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idij
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) ik
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) is
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) j2
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) nbd
+  real ( kind = 4 ) tpi
+  real ( kind = 4 ) wa(ido)
+
+  tpi = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 )
+  arg = tpi / real ( ip, kind = 4 )
+  dcp = cos ( arg )
+  dsp = sin ( arg )
+  idp2 = ido + 2
+  nbd = ( ido - 1 ) / 2
+  ipp2 = ip + 2
+  ipph = ( ip + 1 ) / 2
+
+  if ( ido < l1 ) then
+    do i = 1, ido
+      do k = 1, l1
+        ch(1,i,k,1) = cc(1,i,1,k)
+      end do
+    end do
+  else
+    do k = 1, l1
+      do i = 1, ido
+        ch(1,i,k,1) = cc(1,i,1,k)
+      end do
+    end do
+  end if
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    j2 = j + j
+    do k = 1, l1
+      ch(1,1,k,j) = cc(1,ido,j2-2,k)+cc(1,ido,j2-2,k)
+      ch(1,1,k,jc) = cc(1,1,j2-1,k)+cc(1,1,j2-1,k)
+    end do
+  end do
+
+  if ( ido == 1 ) then
+
+  else if ( nbd < l1 ) then
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do i = 3, ido, 2
+        ic = idp2 - i
+        do k = 1, l1
+          ch(1,i-1,k,j) = cc(1,i-1,2*j-1,k)+cc(1,ic-1,2*j-2,k)
+          ch(1,i-1,k,jc) = cc(1,i-1,2*j-1,k)-cc(1,ic-1,2*j-2,k)
+          ch(1,i,k,j) = cc(1,i,2*j-1,k)-cc(1,ic,2*j-2,k)
+          ch(1,i,k,jc) = cc(1,i,2*j-1,k)+cc(1,ic,2*j-2,k)
+        end do
+      end do
+    end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do k = 1, l1
+        do i = 3, ido, 2
+          ic = idp2 - i
+          ch(1,i-1,k,j) = cc(1,i-1,2*j-1,k)+cc(1,ic-1,2*j-2,k)
+          ch(1,i-1,k,jc) = cc(1,i-1,2*j-1,k)-cc(1,ic-1,2*j-2,k)
+          ch(1,i,k,j) = cc(1,i,2*j-1,k)-cc(1,ic,2*j-2,k)
+          ch(1,i,k,jc) = cc(1,i,2*j-1,k)+cc(1,ic,2*j-2,k)
+        end do
+      end do
+    end do
+
+  end if
+
+  ar1 = 1.0E+00
+  ai1 = 0.0E+00
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+    ar1h = dcp * ar1 - dsp * ai1
+    ai1 = dcp * ai1 + dsp * ar1
+    ar1 = ar1h
+
+    do ik = 1, idl1
+      c2(1,ik,l) = ch2(1,ik,1)+ar1*ch2(1,ik,2)
+      c2(1,ik,lc) = ai1*ch2(1,ik,ip)
+    end do
+
+    dc2 = ar1
+    ds2 = ai1
+    ar2 = ar1
+    ai2 = ai1
+
+    do j = 3, ipph
+
+      jc = ipp2 - j
+      ar2h = dc2*ar2-ds2*ai2
+      ai2 = dc2*ai2+ds2*ar2
+      ar2 = ar2h
+
+      do ik = 1, idl1
+        c2(1,ik,l) = c2(1,ik,l)+ar2*ch2(1,ik,j)
+        c2(1,ik,lc) = c2(1,ik,lc)+ai2*ch2(1,ik,jc)
+      end do
+
+    end do
+
+  end do
+
+  do j = 2, ipph
+    do ik = 1, idl1
+      ch2(1,ik,1) = ch2(1,ik,1)+ch2(1,ik,j)
+    end do
+  end do
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do k = 1, l1
+      ch(1,1,k,j) = c1(1,1,k,j)-c1(1,1,k,jc)
+      ch(1,1,k,jc) = c1(1,1,k,j)+c1(1,1,k,jc)
+    end do
+  end do
+
+  if ( ido == 1 ) then
+
+  else if ( nbd < l1 ) then
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do i = 3, ido, 2
+        do k = 1, l1
+          ch(1,i-1,k,j)  = c1(1,i-1,k,j) - c1(1,i,k,jc)
+          ch(1,i-1,k,jc) = c1(1,i-1,k,j) + c1(1,i,k,jc)
+          ch(1,i,k,j)    = c1(1,i,k,j)   + c1(1,i-1,k,jc)
+          ch(1,i,k,jc)   = c1(1,i,k,j)   - c1(1,i-1,k,jc)
+        end do
+      end do
+    end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do k = 1, l1
+        do i = 3, ido, 2
+          ch(1,i-1,k,j) = c1(1,i-1,k,j)-c1(1,i,k,jc)
+          ch(1,i-1,k,jc) = c1(1,i-1,k,j)+c1(1,i,k,jc)
+          ch(1,i,k,j) = c1(1,i,k,j)+c1(1,i-1,k,jc)
+          ch(1,i,k,jc) = c1(1,i,k,j)-c1(1,i-1,k,jc)
+        end do
+      end do
+    end do
+
+  end if
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  do ik = 1, idl1
+    c2(1,ik,1) = ch2(1,ik,1)
+  end do
+
+  do j = 2, ip
+    do k = 1, l1
+      c1(1,1,k,j) = ch(1,1,k,j)
+    end do
+  end do
+
+  if ( l1 < nbd ) then
+
+    is = -ido
+    do j = 2, ip
+       is = is + ido
+       do k = 1, l1
+         idij = is
+         do i = 3, ido, 2
+           idij = idij + 2
+           c1(1,i-1,k,j) = wa(idij-1)*ch(1,i-1,k,j)-wa(idij)* ch(1,i,k,j)
+           c1(1,i,k,j) = wa(idij-1)*ch(1,i,k,j)+wa(idij)* ch(1,i-1,k,j)
+         end do
+       end do
+    end do
+
+  else
+
+    is = -ido
+
+    do j = 2, ip
+      is = is + ido
+      idij = is
+      do i = 3, ido, 2
+        idij = idij + 2
+        do k = 1, l1
+           c1(1,i-1,k,j) = wa(idij-1) * ch(1,i-1,k,j) - wa(idij) * ch(1,i,k,j)
+           c1(1,i,k,j)   = wa(idij-1) * ch(1,i,k,j)   + wa(idij) * ch(1,i-1,k,j)
+        end do
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r1fgkf.F b/wrfv2_fire/external/fftpack/fftpack5/r1fgkf.F
index d2a0a33b..ae5c6868 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/r1fgkf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/r1fgkf.F
@@ -1,182 +1,285 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: r1fgkf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE R1FGKF (IDO,IP,L1,IDL1,CC,C1,C2,IN1,                   &
-     &              CH,CH2,IN2,WA)                                      
-      REAL          CH(IN2,IDO,L1,IP)   ,CC(IN1,IDO,IP,L1),             &
-     &              C1(IN1,IDO,L1,IP)   ,C2(IN1,IDL1,IP),               &
-     &              CH2(IN2,IDL1,IP)    ,WA(IDO)                        
-!                                                                       
-      TPI=2.*4.*ATAN(1.0) 
-      ARG = TPI/FLOAT(IP) 
-      DCP = COS(ARG) 
-      DSP = SIN(ARG) 
-      IPPH = (IP+1)/2 
-      IPP2 = IP+2 
-      IDP2 = IDO+2 
-      NBD = (IDO-1)/2 
-      IF (IDO .EQ. 1) GO TO 119 
-      DO 101 IK=1,IDL1 
-         CH2(1,IK,1) = C2(1,IK,1) 
-  101 END DO 
-      DO 103 J=2,IP 
-         DO 102 K=1,L1 
-            CH(1,1,K,J) = C1(1,1,K,J) 
-  102    CONTINUE 
-  103 END DO 
-      IF (NBD .GT. L1) GO TO 107 
-      IS = -IDO 
-      DO 106 J=2,IP 
-         IS = IS+IDO 
-         IDIJ = IS 
-         DO 105 I=3,IDO,2 
-            IDIJ = IDIJ+2 
-            DO 104 K=1,L1 
-               CH(1,I-1,K,J) = WA(IDIJ-1)*C1(1,I-1,K,J)+WA(IDIJ)        &
-     &           *C1(1,I,K,J)                                           
-               CH(1,I,K,J) = WA(IDIJ-1)*C1(1,I,K,J)-WA(IDIJ)            &
-     &           *C1(1,I-1,K,J)                                         
-  104       CONTINUE 
-  105    CONTINUE 
-  106 END DO 
-      GO TO 111 
-  107 IS = -IDO 
-      DO 110 J=2,IP 
-         IS = IS+IDO 
-         DO 109 K=1,L1 
-            IDIJ = IS 
-            DO 108 I=3,IDO,2 
-               IDIJ = IDIJ+2 
-               CH(1,I-1,K,J) = WA(IDIJ-1)*C1(1,I-1,K,J)+WA(IDIJ)        &
-     &           *C1(1,I,K,J)                                           
-               CH(1,I,K,J) = WA(IDIJ-1)*C1(1,I,K,J)-WA(IDIJ)            &
-     &           *C1(1,I-1,K,J)                                         
-  108       CONTINUE 
-  109    CONTINUE 
-  110 END DO 
-  111 IF (NBD .LT. L1) GO TO 115 
-      DO 114 J=2,IPPH 
-         JC = IPP2-J 
-         DO 113 K=1,L1 
-            DO 112 I=3,IDO,2 
-               C1(1,I-1,K,J) = CH(1,I-1,K,J)+CH(1,I-1,K,JC) 
-               C1(1,I-1,K,JC) = CH(1,I,K,J)-CH(1,I,K,JC) 
-               C1(1,I,K,J) = CH(1,I,K,J)+CH(1,I,K,JC) 
-               C1(1,I,K,JC) = CH(1,I-1,K,JC)-CH(1,I-1,K,J) 
-  112       CONTINUE 
-  113    CONTINUE 
-  114 END DO 
-      GO TO 121 
-  115 DO 118 J=2,IPPH 
-         JC = IPP2-J 
-         DO 117 I=3,IDO,2 
-            DO 116 K=1,L1 
-               C1(1,I-1,K,J) = CH(1,I-1,K,J)+CH(1,I-1,K,JC) 
-               C1(1,I-1,K,JC) = CH(1,I,K,J)-CH(1,I,K,JC) 
-               C1(1,I,K,J) = CH(1,I,K,J)+CH(1,I,K,JC) 
-               C1(1,I,K,JC) = CH(1,I-1,K,JC)-CH(1,I-1,K,J) 
-  116       CONTINUE 
-  117    CONTINUE 
-  118 END DO 
-      GO TO 121 
-  119 DO 120 IK=1,IDL1 
-         C2(1,IK,1) = CH2(1,IK,1) 
-  120 END DO 
-  121 DO 123 J=2,IPPH 
-         JC = IPP2-J 
-         DO 122 K=1,L1 
-            C1(1,1,K,J) = CH(1,1,K,J)+CH(1,1,K,JC) 
-            C1(1,1,K,JC) = CH(1,1,K,JC)-CH(1,1,K,J) 
-  122    CONTINUE 
-  123 END DO 
-!                                                                       
-      AR1 = 1. 
-      AI1 = 0. 
-      DO 127 L=2,IPPH 
-         LC = IPP2-L 
-         AR1H = DCP*AR1-DSP*AI1 
-         AI1 = DCP*AI1+DSP*AR1 
-         AR1 = AR1H 
-         DO 124 IK=1,IDL1 
-            CH2(1,IK,L) = C2(1,IK,1)+AR1*C2(1,IK,2) 
-            CH2(1,IK,LC) = AI1*C2(1,IK,IP) 
-  124    CONTINUE 
-         DC2 = AR1 
-         DS2 = AI1 
-         AR2 = AR1 
-         AI2 = AI1 
-         DO 126 J=3,IPPH 
-            JC = IPP2-J 
-            AR2H = DC2*AR2-DS2*AI2 
-            AI2 = DC2*AI2+DS2*AR2 
-            AR2 = AR2H 
-            DO 125 IK=1,IDL1 
-               CH2(1,IK,L) = CH2(1,IK,L)+AR2*C2(1,IK,J) 
-               CH2(1,IK,LC) = CH2(1,IK,LC)+AI2*C2(1,IK,JC) 
-  125       CONTINUE 
-  126    CONTINUE 
-  127 END DO 
-      DO 129 J=2,IPPH 
-         DO 128 IK=1,IDL1 
-            CH2(1,IK,1) = CH2(1,IK,1)+C2(1,IK,J) 
-  128    CONTINUE 
-  129 END DO 
-!                                                                       
-      IF (IDO .LT. L1) GO TO 132 
-      DO 131 K=1,L1 
-         DO 130 I=1,IDO 
-            CC(1,I,1,K) = CH(1,I,K,1) 
-  130    CONTINUE 
-  131 END DO 
-      GO TO 135 
-  132 DO 134 I=1,IDO 
-         DO 133 K=1,L1 
-            CC(1,I,1,K) = CH(1,I,K,1) 
-  133    CONTINUE 
-  134 END DO 
-  135 DO 137 J=2,IPPH 
-         JC = IPP2-J 
-         J2 = J+J 
-         DO 136 K=1,L1 
-            CC(1,IDO,J2-2,K) = CH(1,1,K,J) 
-            CC(1,1,J2-1,K) = CH(1,1,K,JC) 
-  136    CONTINUE 
-  137 END DO 
-      IF (IDO .EQ. 1) RETURN 
-      IF (NBD .LT. L1) GO TO 141 
-      DO 140 J=2,IPPH 
-         JC = IPP2-J 
-         J2 = J+J 
-         DO 139 K=1,L1 
-            DO 138 I=3,IDO,2 
-               IC = IDP2-I 
-               CC(1,I-1,J2-1,K) = CH(1,I-1,K,J)+CH(1,I-1,K,JC) 
-               CC(1,IC-1,J2-2,K) = CH(1,I-1,K,J)-CH(1,I-1,K,JC) 
-               CC(1,I,J2-1,K) = CH(1,I,K,J)+CH(1,I,K,JC) 
-               CC(1,IC,J2-2,K) = CH(1,I,K,JC)-CH(1,I,K,J) 
-  138       CONTINUE 
-  139    CONTINUE 
-  140 END DO 
-      RETURN 
-  141 DO 144 J=2,IPPH 
-         JC = IPP2-J 
-         J2 = J+J 
-         DO 143 I=3,IDO,2 
-            IC = IDP2-I 
-            DO 142 K=1,L1 
-               CC(1,I-1,J2-1,K) = CH(1,I-1,K,J)+CH(1,I-1,K,JC) 
-               CC(1,IC-1,J2-2,K) = CH(1,I-1,K,J)-CH(1,I-1,K,JC) 
-               CC(1,I,J2-1,K) = CH(1,I,K,J)+CH(1,I,K,JC) 
-               CC(1,IC,J2-2,K) = CH(1,I,K,JC)-CH(1,I,K,J) 
-  142       CONTINUE 
-  143    CONTINUE 
-  144 END DO 
-      RETURN 
-      END                                           
+subroutine r1fgkf ( ido, ip, l1, idl1, cc, c1, c2, in1, ch, ch2, in2, wa )
+
+!*****************************************************************************80
+!
+!! R1FGKF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+
+  real ( kind = 4 ) ai1
+  real ( kind = 4 ) ai2
+  real ( kind = 4 ) ar1
+  real ( kind = 4 ) ar1h
+  real ( kind = 4 ) ar2
+  real ( kind = 4 ) ar2h
+  real ( kind = 4 ) arg
+  real ( kind = 4 ) c1(in1,ido,l1,ip)
+  real ( kind = 4 ) c2(in1,idl1,ip)
+  real ( kind = 4 ) cc(in1,ido,ip,l1)
+  real ( kind = 4 ) ch(in2,ido,l1,ip)
+  real ( kind = 4 ) ch2(in2,idl1,ip)
+  real ( kind = 4 ) dc2
+  real ( kind = 4 ) dcp
+  real ( kind = 4 ) ds2
+  real ( kind = 4 ) dsp
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ic
+  integer ( kind = 4 ) idij
+  integer ( kind = 4 ) idp2
+  integer ( kind = 4 ) ik
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) is
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) j2
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) nbd
+  real ( kind = 4 ) tpi
+  real ( kind = 4 ) wa(ido)
+
+  tpi = 2.0E+00 * 4.0E+00 * atan ( 1.0E+00 )
+  arg = tpi / real ( ip, kind = 4 )
+  dcp = cos ( arg )
+  dsp = sin ( arg )
+  ipph = ( ip + 1 ) / 2
+  ipp2 = ip + 2
+  idp2 = ido + 2
+  nbd = ( ido - 1 ) / 2
+
+  if ( ido == 1 ) then
+
+    do ik = 1, idl1
+      c2(1,ik,1) = ch2(1,ik,1)
+    end do
+
+  else
+
+    do ik = 1, idl1
+      ch2(1,ik,1) = c2(1,ik,1)
+    end do
+
+    do j = 2, ip
+      do k = 1, l1
+        ch(1,1,k,j) = c1(1,1,k,j)
+      end do
+    end do
+
+    if ( l1 < nbd ) then
+
+      is = -ido
+
+      do j = 2, ip
+        is = is + ido
+        do k = 1, l1
+          idij = is
+          do i = 3, ido, 2
+            idij = idij + 2
+            ch(1,i-1,k,j) = wa(idij-1)*c1(1,i-1,k,j)+wa(idij) *c1(1,i,k,j)
+            ch(1,i,k,j) = wa(idij-1)*c1(1,i,k,j)-wa(idij) *c1(1,i-1,k,j)
+          end do
+        end do
+      end do
+
+    else
+
+      is = -ido
+
+      do j = 2, ip
+        is = is + ido
+        idij = is
+        do i = 3, ido, 2
+          idij = idij + 2
+          do k = 1, l1
+            ch(1,i-1,k,j) = wa(idij-1)*c1(1,i-1,k,j)+wa(idij) *c1(1,i,k,j)
+            ch(1,i,k,j) = wa(idij-1)*c1(1,i,k,j)-wa(idij) *c1(1,i-1,k,j)
+          end do
+        end do
+      end do
+
+    end if
+
+    if ( nbd < l1 ) then
+
+      do j = 2, ipph
+        jc = ipp2 - j
+        do i = 3, ido, 2
+          do k = 1, l1
+            c1(1,i-1,k,j) = ch(1,i-1,k,j)+ch(1,i-1,k,jc)
+            c1(1,i-1,k,jc) = ch(1,i,k,j)-ch(1,i,k,jc)
+            c1(1,i,k,j) = ch(1,i,k,j)+ch(1,i,k,jc)
+            c1(1,i,k,jc) = ch(1,i-1,k,jc)-ch(1,i-1,k,j)
+          end do
+        end do
+      end do
+
+    else
+
+      do j = 2, ipph
+        jc = ipp2 - j
+        do k = 1, l1
+          do i = 3, ido, 2
+            c1(1,i-1,k,j) = ch(1,i-1,k,j)+ch(1,i-1,k,jc)
+            c1(1,i-1,k,jc) = ch(1,i,k,j)-ch(1,i,k,jc)
+            c1(1,i,k,j) = ch(1,i,k,j)+ch(1,i,k,jc)
+            c1(1,i,k,jc) = ch(1,i-1,k,jc)-ch(1,i-1,k,j)
+          end do
+        end do
+      end do
+
+    end if
+
+  end if
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do k = 1, l1
+      c1(1,1,k,j) = ch(1,1,k,j)+ch(1,1,k,jc)
+      c1(1,1,k,jc) = ch(1,1,k,jc)-ch(1,1,k,j)
+    end do
+  end do
+
+  ar1 = 1.0E+00
+  ai1 = 0.0E+00
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+    ar1h = dcp * ar1 - dsp * ai1
+    ai1 = dcp * ai1 + dsp * ar1
+    ar1 = ar1h
+
+    do ik = 1, idl1
+      ch2(1,ik,l) = c2(1,ik,1)+ar1*c2(1,ik,2)
+      ch2(1,ik,lc) = ai1*c2(1,ik,ip)
+    end do
+
+    dc2 = ar1
+    ds2 = ai1
+    ar2 = ar1
+    ai2 = ai1
+
+    do j = 3, ipph
+      jc = ipp2 - j
+      ar2h = dc2 * ar2 - ds2 * ai2
+      ai2 = dc2 * ai2 + ds2 * ar2
+      ar2 = ar2h
+      do ik = 1, idl1
+        ch2(1,ik,l) = ch2(1,ik,l)+ar2*c2(1,ik,j)
+        ch2(1,ik,lc) = ch2(1,ik,lc)+ai2*c2(1,ik,jc)
+      end do
+    end do
+
+  end do
+
+  do j = 2, ipph
+    do ik = 1, idl1
+      ch2(1,ik,1) = ch2(1,ik,1)+c2(1,ik,j)
+    end do
+  end do
+
+  if ( ido < l1 ) then
+
+    do i = 1, ido
+      do k = 1, l1
+        cc(1,i,1,k) = ch(1,i,k,1)
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do i = 1, ido
+        cc(1,i,1,k) = ch(1,i,k,1)
+      end do
+    end do
+
+  end if
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    j2 = j+j
+    do k = 1, l1
+      cc(1,ido,j2-2,k) = ch(1,1,k,j)
+      cc(1,1,j2-1,k) = ch(1,1,k,jc)
+    end do
+  end do
+
+  if ( ido == 1 ) then
+    return
+  end if
+
+  if ( nbd < l1 ) then
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      j2 = j + j
+      do i = 3, ido, 2
+        ic = idp2 - i
+        do k = 1, l1
+          cc(1,i-1,j2-1,k) = ch(1,i-1,k,j)+ch(1,i-1,k,jc)
+          cc(1,ic-1,j2-2,k) = ch(1,i-1,k,j)-ch(1,i-1,k,jc)
+          cc(1,i,j2-1,k) = ch(1,i,k,j)+ch(1,i,k,jc)
+          cc(1,ic,j2-2,k) = ch(1,i,k,jc)-ch(1,i,k,j)
+        end do
+      end do
+   end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      j2 = j + j
+      do k = 1, l1
+        do i = 3, ido, 2
+          ic = idp2 - i
+          cc(1,i-1,j2-1,k)  = ch(1,i-1,k,j) + ch(1,i-1,k,jc)
+          cc(1,ic-1,j2-2,k) = ch(1,i-1,k,j) - ch(1,i-1,k,jc)
+          cc(1,i,j2-1,k)    = ch(1,i,k,j)   + ch(1,i,k,jc)
+          cc(1,ic,j2-2,k)   = ch(1,i,k,jc)  - ch(1,i,k,j)
+        end do
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r4_factor.F b/wrfv2_fire/external/fftpack/fftpack5/r4_factor.F
new file mode 100644
index 00000000..d1d0ea65
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/r4_factor.F
@@ -0,0 +1,92 @@
+subroutine r4_factor ( n, nf, fac )
+
+!*****************************************************************************80
+!
+!! R4_FACTOR factors of an integer for real single precision computations.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 August 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the number for which factorization and
+!    other information is needed.
+!
+!    Output, integer ( kind = 4 ) NF, the number of factors.
+!
+!    Output, real ( kind = 4 ) FAC(*), a list of factors of N.
+!
+  implicit none
+
+  real ( kind = 4 ) fac(*)
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nf
+  integer ( kind = 4 ) nl
+  integer ( kind = 4 ) nq
+  integer ( kind = 4 ) nr
+  integer ( kind = 4 ) ntry
+
+  nl = n
+  nf = 0
+  j = 0
+
+  do while ( 1 < nl )
+
+    j = j + 1
+
+    if ( j == 1 ) then
+      ntry = 4
+    else if ( j == 2 ) then
+      ntry = 2
+    else if ( j == 3 ) then
+      ntry = 3
+    else if ( j == 4 ) then
+      ntry = 5
+    else
+      ntry = ntry + 2
+    end if
+
+    do
+
+      nq = nl / ntry
+      nr = nl - ntry * nq
+
+      if ( nr /= 0 ) then
+        exit
+      end if
+
+      nf = nf + 1
+      fac(nf) = real ( ntry, kind = 4 )
+      nl = nq
+
+    end do
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r4_mcfti1.F b/wrfv2_fire/external/fftpack/fftpack5/r4_mcfti1.F
new file mode 100644
index 00000000..7f70b0e1
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/r4_mcfti1.F
@@ -0,0 +1,69 @@
+subroutine r4_mcfti1 ( n, wa, fnf, fac )
+
+!*****************************************************************************80
+!
+!! R4_MCFTI1 sets up factors and tables, real single precision arithmetic.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  real ( kind = 4 ) fac(*)
+  real ( kind = 4 ) fnf
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nf
+  real ( kind = 4 ) wa(*)
+!
+!  Get the factorization of N.
+!
+  call r4_factor ( n, nf, fac )
+  fnf = real ( nf, kind = 4 )
+  iw = 1
+  l1 = 1
+!
+!  Set up the trigonometric tables.
+!
+  do k1 = 1, nf
+    ip = int ( fac(k1) )
+    l2 = l1 * ip
+    ido = n / l2
+    call r4_tables ( ido, ip, wa(iw) )
+    iw = iw + ( ip - 1 ) * ( ido + ido )
+    l1 = l2
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r4_tables.F b/wrfv2_fire/external/fftpack/fftpack5/r4_tables.F
new file mode 100644
index 00000000..1a60af64
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/r4_tables.F
@@ -0,0 +1,74 @@
+subroutine r4_tables ( ido, ip, wa )
+
+!*****************************************************************************80
+!
+!! R4_TABLES computes trigonometric tables, real single precision arithmetic.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 August 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) ip
+
+  real ( kind = 4 ) arg1
+  real ( kind = 4 ) arg2
+  real ( kind = 4 ) arg3
+  real ( kind = 4 ) arg4
+  real ( kind = 4 ) argz
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) j
+  real ( kind = 4 ) tpi
+  real ( kind = 4 ) wa(ido,ip-1,2)
+
+  tpi = 8.0E+00 * atan ( 1.0E+00 )
+  argz = tpi / real ( ip, kind = 4 )
+  arg1 = tpi / real ( ido * ip, kind = 4 )
+
+  do j = 2, ip
+
+    arg2 = real ( j - 1, kind = 4 ) * arg1
+
+    do i = 1, ido
+      arg3 = real ( i - 1, kind = 4 ) * arg2
+      wa(i,j-1,1) = cos ( arg3 )
+      wa(i,j-1,2) = sin ( arg3 )
+    end do
+
+    if ( 5 < ip ) then
+      arg4 = real ( j - 1, kind = 4 ) * argz
+      wa(1,j-1,1) = cos ( arg4 )
+      wa(1,j-1,2) = sin ( arg4 )
+    end if
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r8_factor.F b/wrfv2_fire/external/fftpack/fftpack5/r8_factor.F
new file mode 100644
index 00000000..936ca8f7
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/r8_factor.F
@@ -0,0 +1,90 @@
+subroutine r8_factor ( n, nf, fac )
+
+!*****************************************************************************80
+!
+!! R8_FACTOR factors of an integer for real double precision computations.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    27 August 2009
+!
+!  Author:
+!
+!    Original real single precision version by Paul Swarztrauber, Dick Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the number for which factorization and
+!    other information is needed.
+!
+!    Output, integer ( kind = 4 ) NF, the number of factors.
+!
+!    Output, real ( kind = 8 ) FAC(*), a list of factors of N.
+!
+  implicit none
+
+  real ( kind = 8 ) fac(*)
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nf
+  integer ( kind = 4 ) nl
+  integer ( kind = 4 ) nq
+  integer ( kind = 4 ) nr
+  integer ( kind = 4 ) ntry
+
+  nl = n
+  nf = 0
+  j = 0
+
+  do while ( 1 < nl )
+
+    j = j + 1
+
+    if ( j == 1 ) then
+      ntry = 4
+    else if ( j == 2 ) then
+      ntry = 2
+    else if ( j == 3 ) then
+      ntry = 3
+    else if ( j == 4 ) then
+      ntry = 5
+    else
+      ntry = ntry + 2
+    end if
+
+    do
+
+      nq = nl / ntry
+      nr = nl - ntry * nq
+
+      if ( nr /= 0 ) then
+        exit
+      end if
+
+      nf = nf + 1
+      fac(nf) = real ( ntry, kind = 8 )
+      nl = nq
+
+    end do
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r8_mcfti1.F b/wrfv2_fire/external/fftpack/fftpack5/r8_mcfti1.F
new file mode 100644
index 00000000..2faad5b5
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/r8_mcfti1.F
@@ -0,0 +1,67 @@
+subroutine r8_mcfti1 ( n, wa, fnf, fac )
+
+!*****************************************************************************80
+!
+!! R8_MCFTI1 sets up factors and tables, real double precision arithmetic.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    27 August 2009
+!
+!  Author:
+!
+!    Original real single precision version by Paul Swarztrauber, Dick Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  real ( kind = 8 ) fac(*)
+  real ( kind = 8 ) fnf
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) nf
+  real ( kind = 8 ) wa(*)
+!
+!  Get the factorization of N.
+!
+  call r8_factor ( n, nf, fac )
+  fnf = real ( nf, kind = 8 )
+  iw = 1
+  l1 = 1
+!
+!  Set up the trigonometric tables.
+!
+  do k1 = 1, nf
+    ip = int ( fac(k1) )
+    l2 = l1 * ip
+    ido = n / l2
+    call r8_tables ( ido, ip, wa(iw) )
+    iw = iw + ( ip - 1 ) * ( ido + ido )
+    l1 = l2
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/r8_tables.F b/wrfv2_fire/external/fftpack/fftpack5/r8_tables.F
new file mode 100644
index 00000000..7d32fc1e
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/r8_tables.F
@@ -0,0 +1,72 @@
+subroutine r8_tables ( ido, ip, wa )
+
+!*****************************************************************************80
+!
+!! R8_TABLES computes trigonometric tables, real double precision arithmetic.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    27 August 2009
+!
+!  Author:
+!
+!    Original real single precision version by Paul Swarztrauber, Dick Valent.
+!    Real double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) ip
+
+  real ( kind = 8 ) arg1
+  real ( kind = 8 ) arg2
+  real ( kind = 8 ) arg3
+  real ( kind = 8 ) arg4
+  real ( kind = 8 ) argz
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) j
+  real ( kind = 8 ) tpi
+  real ( kind = 8 ) wa(ido,ip-1,2)
+
+  tpi = 8.0D+00 * atan ( 1.0D+00 )
+  argz = tpi / real ( ip, kind = 8 )
+  arg1 = tpi / real ( ido * ip, kind = 8 )
+
+  do j = 2, ip
+
+    arg2 = real ( j - 1, kind = 8 ) * arg1
+
+    do i = 1, ido
+      arg3 = real ( i - 1, kind = 8 ) * arg2
+      wa(i,j-1,1) = cos ( arg3 )
+      wa(i,j-1,2) = sin ( arg3 )
+    end do
+
+    if ( 5 < ip ) then
+      arg4 = real ( j - 1, kind = 8 ) * argz
+      wa(1,j-1,1) = cos ( arg4 )
+      wa(1,j-1,2) = sin ( arg4 )
+    end if
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rfft1b.F b/wrfv2_fire/external/fftpack/fftpack5/rfft1b.F
index 55563113..9a9df9e2 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rfft1b.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rfft1b.F
@@ -1,33 +1,121 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rfft1b.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFT1B ( N, INC, R, LENR, WSAVE, LENSAV,               &
-     &                  WORK, LENWRK, IER)                              
-      INTEGER  N, INC, LENR, LENSAV, LENWRK, IER 
-      REAL     R(LENR), WSAVE(LENSAV)     ,WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENR .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('RFFT1B ', 6) 
-      ELSEIF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('RFFT1B ', 8) 
-      ELSEIF (LENWRK .LT. N) THEN 
-        IER = 3 
-        CALL XERFFT ('RFFT1B ', 10) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      CALL RFFTB1 (N,INC,R,WORK,WSAVE,WSAVE(N+1)) 
-      RETURN 
-      END                                           
+subroutine rfft1b ( n, inc, r, lenr, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! RFFT1B: real single precision backward fast Fourier transform, 1D.
+!
+!  Discussion:
+!
+!    RFFT1B computes the one-dimensional Fourier transform of a periodic
+!    sequence within a real array.  This is referred to as the backward
+!    transform or Fourier synthesis, transforming the sequence from
+!    spectral to physical space.  This transform is normalized since a
+!    call to RFFT1B followed by a call to RFFT1F (or vice-versa) reproduces
+!    the original array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    25 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), on input, the data to be
+!    transformed, and on output, the transformed data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1) + 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to RFFT1I before the first call to routine
+!    RFFT1F or RFFT1B for a given transform length N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenr
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) r(lenr)
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lenr < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'rfft1b ', 6 )
+    return
+  end if
+
+  if ( lensav < n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'rfft1b ', 8 )
+    return
+  end if
+
+  if ( lenwrk < n ) then
+    write ( *, '(a)' ) ' '
+    write ( *, '(a)' ) 'RFFT1B - Fatal error!'
+    write ( *, '(a)' ) '  LENWRK < N:'
+    write ( *, '(a,i6)' ) '  LENWRK = ', lenwrk
+    write ( *, '(a,i6)' ) '  N = ', n
+    ier = 3
+    call xerfft ( 'rfft1b ', 10 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  call rfftb1 ( n, inc, r, work, wsave, wsave(n+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rfft1f.F b/wrfv2_fire/external/fftpack/fftpack5/rfft1f.F
index 246ec4bc..59a35ce5 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rfft1f.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rfft1f.F
@@ -1,33 +1,116 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rfft1f.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFT1F ( N, INC, R, LENR, WSAVE, LENSAV,               &
-     &                  WORK, LENWRK, IER)                              
-      INTEGER  N, INC, LENR, LENSAV, LENWRK, IER 
-      REAL     R(LENR), WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENR .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('RFFT1F ', 6) 
-      ELSEIF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('RFFT1F ', 8) 
-      ELSEIF (LENWRK .LT. N) THEN 
-        IER = 3 
-        CALL XERFFT ('RFFT1F ', 10) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      CALL RFFTF1 (N,INC,R,WORK,WSAVE,WSAVE(N+1)) 
-      RETURN 
-      END                                           
+subroutine rfft1f ( n, inc, r, lenr, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! RFFT1F: real single precision forward fast Fourier transform, 1D.
+!
+!  Discussion:
+!
+!    RFFT1F computes the one-dimensional Fourier transform of a periodic
+!    sequence within a real array.  This is referred to as the forward
+!    transform or Fourier analysis, transforming the sequence from physical
+!    to spectral space.  This transform is normalized since a call to
+!    RFFT1F followed by a call to RFFT1B (or vice-versa) reproduces the
+!    original array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    25 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), on input, contains the sequence
+!    to be transformed, and on output, the transformed data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1) + 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to RFFT1I before the first call to routine RFFT1F
+!    or RFFT1B for a given transform length N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR not big enough:
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenr
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) r(lenr)
+
+  ier = 0
+
+  if ( lenr < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'rfft1f ', 6 )
+    return
+  end if
+
+  if ( lensav < n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'rfft1f ', 8 )
+    return
+  end if
+
+  if ( lenwrk < n ) then
+    ier = 3
+    call xerfft ( 'rfft1f ', 10 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  call rfftf1 ( n, inc, r, work, wsave, wsave(n+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rfft1i.F b/wrfv2_fire/external/fftpack/fftpack5/rfft1i.F
index 3c89028d..06b53669 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rfft1i.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rfft1i.F
@@ -1,26 +1,82 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rfft1i.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFT1I ( N, WSAVE, LENSAV, IER ) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('RFFT1I ', 3) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      CALL RFFTI1 (N,WSAVE(1),WSAVE(N+1)) 
-      RETURN 
-      END                                           
+subroutine rfft1i ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! RFFT1I: initialization for RFFT1B and RFFT1F.
+!
+!  Discussion:
+!
+!    RFFT1I initializes array WSAVE for use in its companion routines
+!    RFFT1B and RFFT1F.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    25 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors of
+!    N and also containing certain trigonometric values which will be used in
+!    routines RFFT1B or RFFT1F.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'rfft1i ', 3 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  call rffti1 ( n, wsave(1), wsave(n+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rfft2b.F b/wrfv2_fire/external/fftpack/fftpack5/rfft2b.F
index 40e8a3bd..24ef9178 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rfft2b.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rfft2b.F
@@ -1,79 +1,164 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rfft2b.f,v 1.5 2004/07/06 00:58:41 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFT2B (LDIM, L, M, R, WSAVE, LENSAV, WORK,            &
-     &  LENWRK, IER)                                                    
-      INTEGER LDIM, L, M, LENSAV, LENWRK, IER 
-      REAL    R(LDIM,M), WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-!                                                                       
-! Initialize IER                                                        
-!                                                                       
-      IER = 0 
-!                                                                       
-! Verify LENSAV                                                         
-!                                                                       
-      LWSAV =   L + INT(LOG (REAL(L))) +4 
-      MWSAV =   2*M + INT(LOG (REAL(M))) +4 
-      IF (LENSAV .LT. LWSAV+MWSAV) THEN 
-        IER = 2 
-        CALL XERFFT ('RFFT2B', 6) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-! Verify LENWRK                                                         
-!                                                                       
-      IF (LENWRK .LT. 2*(L/2+1)*M) THEN 
-        IER = 3 
-        CALL XERFFT ('RFFT2B', 8) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-! Verify LDIM is as big as L                                            
-!                                                                       
-      IF (LDIM .LT. 2*(L/2+1)) THEN 
-        IER = 5 
-        CALL XERFFT ('RFFT2B', -6) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-! transform second dimension of array                                   
-!                                                                       
-      CALL CFFTMB(L/2+1,1,M,LDIM/2,R,M*LDIM/2,                          &
-     &     WSAVE(L+INT(LOG(REAL(L)))+5),                                &
-     &     2*M+INT(LOG(REAL(M)))+4,WORK,2*(L/2+1)*M,IER1)               
-      IF(IER1.NE.0) THEN 
-         IER=20 
-         CALL XERFFT('RFFT2B',-5) 
-         GO TO 100 
-      ENDIF 
-!                                                                       
-! reshuffle                                                             
-!                                                                       
-      DO J=1,M 
-         DO I=2,L 
-            R(I,J)=R(I+1,J) 
-         ENDDO 
-      ENDDO 
-!                                                                       
-! Transform first dimension of array                                    
-!                                                                       
-      CALL RFFTMB(M,LDIM,L,1,R,M*LDIM,WSAVE(1),                         &
-     &     L+INT(LOG(REAL(L)))+4,WORK,2*(L/2+1)*M,IER1)                 
-      IF(IER1.NE.0) THEN 
-         IER=20 
-         CALL XERFFT('RFFT2F',-5) 
-         GO TO 100 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-!                                                                       
-      RETURN 
-      END                                           
+subroutine rfft2b ( ldim, l, m, r, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! RFFT2B: real single precision backward fast Fourier transform, 2D.
+!
+!  Discussion:
+!
+!    RFFT2B computes the two-dimensional discrete Fourier transform of the
+!    complex Fourier coefficients a real periodic array.  This transform is
+!    known as the backward transform or Fourier synthesis, transforming from
+!    spectral to physical space.  Routine RFFT2B is normalized: a call to
+!    RFFT2B followed by a call to RFFT2F (or vice-versa) reproduces the
+!    original array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    26 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LDIM, the first dimension of the 2D real
+!    array R, which must be at least 2*(L/2+1).
+!
+!    Input, integer ( kind = 4 ) L, the number of elements to be transformed
+!    in the first dimension of the two-dimensional real array R.  The value of
+!    L must be less than or equal to that of LDIM.  The transform is most
+!    efficient when L is a product of small primes.
+!
+!    Input, integer ( kind = 4 ) M, the number of elements to be transformed
+!    in the second dimension of the two-dimensional real array R.  The transform
+!    is most efficient when M is a product of small primes.
+!
+!    Input/output, real ( kind = 4 ) R(LDIM,M), the real array of two
+!    dimensions.  On input, R contains the L/2+1-by-M complex subarray of
+!    spectral coefficients, on output, the physical coefficients.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to RFFT2I before the first call to routine RFFT2F
+!    or RFFT2B with lengths L and M.  WSAVE's contents may be re-used for
+!    subsequent calls to RFFT2F and RFFT2B with the same transform lengths
+!    L and M.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the number of elements in the WSAVE
+!    array.  LENSAV must be at least L + M + INT(LOG(REAL(L)))
+!    + INT(LOG(REAL(M))) + 8.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).  WORK provides workspace, and
+!    its contents need not be saved between calls to routines RFFT2B and RFFT2F.
+!
+!    Input, integer ( kind = 4 )  LENWRK, the number of elements in the WORK
+!    array.  LENWRK must be at least LDIM*M.
+!
+!    Output, integer ( kind = 4 ) IER, the error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    6, input parameter LDIM < 2*(L/2+1);
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldim
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+  integer ( kind = 4 ) m
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lwsav
+  integer ( kind = 4 ) mwsav
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) r(ldim,m)
+
+  ier = 0
+!
+!  Verify LENSAV.
+!
+  lwsav = l + int ( log ( real ( l, kind = 4 ) ) ) + 4
+  mwsav = 2 * m + int ( log ( real ( m, kind = 4 ) ) ) + 4
+
+  if ( lensav < lwsav + mwsav ) then
+    ier = 2
+    call xerfft ( 'rfft2b', 6 )
+    return
+  end if
+!
+!  Verify LENWRK.
+!
+  if ( lenwrk < 2 * ( l / 2 + 1 ) * m ) then
+    ier = 3
+    call xerfft ( 'rfft2b', 8 )
+    return
+  end if
+!
+!  Verify LDIM is as big as L.
+!
+  if ( ldim < 2 * ( l / 2 + 1 ) ) then
+    ier = 5
+    call xerfft ( 'rfft2b', -6 )
+    return
+  end if
+!
+!  Transform second dimension of array.
+!
+  call cfftmb ( l/2+1, 1, m, ldim/2, r, m*ldim/2, &
+    wsave(l+int(log( real ( l, kind = 4 )))+5), &
+    2*m+int(log( real ( m, kind = 4 )))+4, work, &
+    2*(l/2+1)*m, ier1 )
+
+  if ( ier1 /= 0 ) then
+     ier = 20
+     call xerfft ( 'rfft2b', -5 )
+     return
+  end if
+!
+!  Reshuffle.
+!
+  do j = 1, m
+    do i = 2, l
+      r(i,j) = r(i+1,j)
+    end do
+  end do
+!
+!  Transform first dimension of array.
+!
+  call rfftmb ( m, ldim, l, 1, r, m*ldim, wsave(1), &
+    l+int(log( real ( l, kind = 4 )))+4, work, 2*(l/2+1)*m, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'rfft2f', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rfft2f.F b/wrfv2_fire/external/fftpack/fftpack5/rfft2f.F
index 07291c9d..2764810d 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rfft2f.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rfft2f.F
@@ -1,81 +1,166 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rfft2f.f,v 1.5 2004/07/06 00:58:41 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFT2F (LDIM, L, M, R, WSAVE, LENSAV, WORK,            &
-     &  LENWRK, IER)                                                    
-      INTEGER LDIM, L, M, LENSAV, LENWRK, IER 
-      REAL    R(LDIM,M), WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-!                                                                       
-! Initialize IER                                                        
-!                                                                       
-      IER = 0 
-!                                                                       
-! Verify LENSAV                                                         
-!                                                                       
-      LWSAV =   L + INT(LOG (REAL(L))) +4 
-      MWSAV =   2*M + INT(LOG (REAL(M))) +4 
-      IF (LENSAV .LT. LWSAV+MWSAV) THEN 
-        IER = 2 
-        CALL XERFFT ('RFFT2F', 6) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-! Verify LENWRK                                                         
-!                                                                       
-      IF (LENWRK .LT. 2*(L/2+1)*M) THEN 
-        IER = 3 
-        CALL XERFFT ('RFFT2F', 8) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-! Verify LDIM is as big as L                                            
-!                                                                       
-      IF (LDIM .LT. 2*(L/2+1)) THEN 
-        IER = 5 
-        CALL XERFFT ('RFFT2F', -6) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-! Transform first dimension of array                                    
-!                                                                       
-      CALL RFFTMF(M,LDIM,L,1,R,M*LDIM,WSAVE(1),                         &
-     &     L+INT(LOG(REAL(L)))+4,WORK,2*(L/2+1)*M,IER1)                 
-      IF(IER1.NE.0) THEN 
-         IER=20 
-         CALL XERFFT('RFFT2F',-5) 
-         GO TO 100 
-      ENDIF 
-!                                                                       
-! reshuffle to add in nyquist imaginary components                      
-!                                                                       
-      DO J=1,M 
-         IF(MOD(L,2).EQ.0) R(L+2,J)=0.0 
-         DO I=L,2,-1 
-            R(I+1,J)=R(I,J) 
-         ENDDO 
-         R(2,J)=0.0 
-      ENDDO 
-!                                                                       
-! transform second dimension of array                                   
-!                                                                       
-      CALL CFFTMF(L/2+1,1,M,LDIM/2,R,M*LDIM/2,                          &
-     &     WSAVE(L+INT(LOG(REAL(L)))+5),                                &
-     &     2*M+INT(LOG(REAL(M)))+4,WORK,2*(L/2+1)*M,IER1)               
-      IF(IER1.NE.0) THEN 
-         IER=20 
-         CALL XERFFT('RFFT2F',-5) 
-         GO TO 100 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-!                                                                       
-      RETURN 
-      END                                           
+subroutine rfft2f ( ldim, l, m, r, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+! RFFT2F: real single precision forward fast Fourier transform, 2D.
+!
+!  Discussion:
+!
+!    RFFT2F computes the two-dimensional discrete Fourier transform of a
+!    real periodic array.  This transform is known as the forward transform
+!    or Fourier analysis, transforming from physical to spectral space.
+!    Routine RFFT2F is normalized: a call to RFFT2F followed by a call to
+!    RFFT2B (or vice-versa) reproduces the original array within roundoff
+!    error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    26 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LDIM, the first dimension of the 2D real
+!    array R, which must be at least 2*(L/2+1).
+!
+!    Input, integer ( kind = 4 ) L, the number of elements to be transformed
+!    in the first dimension of the two-dimensional real array R.  The value
+!    of L must be less than or equal to that of LDIM.  The transform is most
+!    efficient when L is a product of small primes.
+!
+!    Input, integer ( kind = 4 ) M, the number of elements to be transformed
+!    in the second dimension of the two-dimensional real array R.  The
+!    transform is most efficient when M is a product of small primes.
+!
+!    Input/output, real ( kind = 4 ) R(LDIM,M), the real array of two
+!    dimensions.  On input, containing the L-by-M physical data to be
+!    transformed.  On output, the spectral coefficients.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to RFFT2I before the first call to routine RFFT2F
+!    or RFFT2B with lengths L and M.  WSAVE's contents may be re-used for
+!    subsequent calls to RFFT2F and RFFT2B with the same transform lengths.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the number of elements in the WSAVE
+!    array.  LENSAV must be at least L + M + INT(LOG(REAL(L)))
+!    + INT(LOG(REAL(M))) + 8.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK), provides workspace, and its
+!    contents need not be saved between calls to routines RFFT2F and RFFT2B.
+!
+!    Input, integer ( kind = 4 ) LENWRK, the number of elements in the WORK
+!    array.  LENWRK must be at least LDIM*M.
+!
+!    Output, integer ( kind = 4 ) IER, the error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    6, input parameter LDIM < 2*(L+1);
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) ldim
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+  integer ( kind = 4 ) m
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lwsav
+  integer ( kind = 4 ) mwsav
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) r(ldim,m)
+
+  ier = 0
+!
+!  Verify LENSAV.
+!
+  lwsav = l + int ( log ( real ( l, kind = 4 ) ) ) + 4
+  mwsav = 2 * m + int ( log ( real ( m, kind = 4 ) ) ) + 4
+
+  if ( lensav < lwsav + mwsav ) then
+    ier = 2
+    call xerfft ( 'rfft2f', 6 )
+    return
+  end if
+!
+!  Verify LENWRK.
+!
+  if ( lenwrk < 2 * ( l / 2 + 1 ) * m ) then
+    ier = 3
+    call xerfft ( 'rfft2f', 8 )
+    return
+  end if
+!
+!  Verify LDIM is as big as L.
+!
+  if ( ldim < 2 * ( l / 2 + 1 ) ) then
+    ier = 5
+    call xerfft ( 'rfft2f', -6 )
+    return
+  end if
+!
+!  Transform first dimension of array.
+!
+  call rfftmf ( m, ldim, l, 1, r, m*ldim, wsave(1), &
+    l+int(log( real ( l, kind = 4 )))+4, work,2*(l/2+1)*m, ier1 )
+
+  if ( ier1 /= 0 ) then
+     ier = 20
+     call xerfft ( 'rfft2f', -5 )
+     return
+  end if
+!
+!  Reshuffle to add in Nyquist imaginary components.
+!
+  do j = 1, m
+    if ( mod ( l, 2 ) == 0 ) then
+      r(l+2,j) = 0.0E+00
+    end if
+    do i = l, 2, -1
+      r(i+1,j) = r(i,j)
+    end do
+    r(2,j) = 0.0E+00
+  end do
+!
+!  Transform second dimension of array.
+!
+  call cfftmf ( l/2+1, 1, m, ldim/2, r, m*ldim/2, &
+    wsave(l+int(log( real ( l, kind = 4 )))+5), &
+    2*m+int(log( real ( m, kind = 4 )))+4, work, 2*(l/2+1)*m, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'rfft2f', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rfft2i.F b/wrfv2_fire/external/fftpack/fftpack5/rfft2i.F
index 63118e98..5dadff7e 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rfft2i.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rfft2i.F
@@ -1,45 +1,110 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rfft2i.f,v 1.3 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFT2I (L, M, WSAVE, LENSAV, IER) 
-      INTEGER L, M, LENSAV, IER 
-      INTEGER LWSAV,MWSAV 
-      REAL WSAVE(LENSAV) 
-!                                                                       
-! Initialize IER                                                        
-!                                                                       
-      IER = 0 
-!                                                                       
-! Verify LENSAV                                                         
-!                                                                       
-      LWSAV =   L+INT(LOG(REAL(L)))+4 
-      MWSAV =   2*M+INT(LOG(REAL(M)))+4 
-      IF (LENSAV .LT. LWSAV+MWSAV) THEN 
-        IER = 2 
-        CALL XERFFT ('RFFT2I', 4) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-      CALL RFFTMI (L, WSAVE(1), L + INT(LOG(REAL(L))) + 4, IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('RFFT2I',-5) 
-        GO TO 100 
-      ENDIF 
-      CALL CFFTMI (M, WSAVE(L+INT(LOG(REAL(L)))+5),                     &
-     &            2*M+INT(LOG(REAL(M)))+4,IER1)                         
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('RFFT2I',-5) 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine rfft2i ( l, m, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! RFFT2I: initialization for RFFT2B and RFFT2F.
+!
+!  Discussion:
+!
+!    RFFT2I initializes real array WSAVE for use in its companion routines
+!    RFFT2F and RFFT2B for computing the two-dimensional fast Fourier
+!    transform of real data.  Prime factorizations of L and M, together with
+!    tabulations of the trigonometric functions, are computed and stored in
+!    array WSAVE.  RFFT2I must be called prior to the first call to RFFT2F
+!    or RFFT2B.  Separate WSAVE arrays are required for different values of
+!    L or M.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    26 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) L, the number of elements to be transformed
+!    in the first dimension.  The transform is most efficient when L is a
+!    product of small primes.
+!
+!    Input, integer ( kind = 4 ) M, the number of elements to be transformed
+!    in the second dimension.  The transform is most efficient when M is a
+!    product of small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the number of elements in the WSAVE
+!    array.  LENSAV must be at least L + M + INT(LOG(REAL(L)))
+!    + INT(LOG(REAL(M))) + 8.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors
+!    of L and M, and also containing certain trigonometric values which
+!    will be used in routines RFFT2B or RFFT2F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lwsav
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) mwsav
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+!
+!  Verify LENSAV.
+!
+  lwsav = l + int ( log ( real ( l, kind = 4 ) ) ) + 4
+  mwsav = 2 * m + int ( log ( real ( m, kind = 4 ) ) ) + 4
+
+  if ( lensav < lwsav + mwsav ) then
+    ier = 2
+    call xerfft ( 'rfft2i', 4 )
+    return
+  end if
+
+  call rfftmi ( l, wsave(1), l + int(log( real ( l, kind = 4 ))) + 4, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'rfft2i', -5 )
+    return
+  end if
+
+  call cfftmi ( m, wsave(l+int(log( real ( l, kind = 4 )))+5), &
+    2*m+int(log( real ( m, kind = 4 )))+4, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'rfft2i', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rfftb1.F b/wrfv2_fire/external/fftpack/fftpack5/rfftb1.F
index 41e63851..62848b5e 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rfftb1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rfftb1.F
@@ -1,95 +1,185 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rfftb1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFTB1 (N,IN,C,CH,WA,FAC) 
-      REAL       CH(*), C(IN,*), WA(N) ,FAC(15) 
-!                                                                       
-      NF = FAC(2) 
-      NA = 0 
-      DO 10 K1=1,NF 
-      IP = FAC(K1+2) 
-      NA = 1-NA 
-      IF(IP .LE. 5) GO TO 10 
-      IF(K1 .EQ. NF) GO TO 10 
-      NA = 1-NA 
-   10 END DO 
-      HALF = .5 
-      HALFM = -.5 
-      MODN = MOD(N,2) 
-      NL = N-2 
-      IF(MODN .NE. 0) NL = N-1 
-      IF (NA .EQ. 0) GO TO 120 
-      CH(1) = C(1,1) 
-      CH(N) = C(1,N) 
-      DO 118 J=2,NL,2 
-         CH(J) = HALF*C(1,J) 
-         CH(J+1) = HALFM*C(1,J+1) 
-  118 END DO 
-      GO TO 124 
-  120 DO 122 J=2,NL,2 
-         C(1,J) = HALF*C(1,J) 
-         C(1,J+1) = HALFM*C(1,J+1) 
-  122 END DO 
-  124 L1 = 1 
-      IW = 1 
-      DO 116 K1=1,NF 
-         IP = FAC(K1+2) 
-         L2 = IP*L1 
-         IDO = N/L2 
-         IDL1 = IDO*L1 
-         IF (IP .NE. 4) GO TO 103 
-         IX2 = IW+IDO 
-         IX3 = IX2+IDO 
-         IF (NA .NE. 0) GO TO 101 
-         CALL R1F4KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),WA(IX3)) 
-         GO TO 102 
-  101    CALL R1F4KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),WA(IX3)) 
-  102    NA = 1-NA 
-         GO TO 115 
-  103    IF (IP .NE. 2) GO TO 106 
-         IF (NA .NE. 0) GO TO 104 
-         CALL R1F2KB (IDO,L1,C,IN,CH,1,WA(IW)) 
-         GO TO 105 
-  104    CALL R1F2KB (IDO,L1,CH,1,C,IN,WA(IW)) 
-  105    NA = 1-NA 
-         GO TO 115 
-  106    IF (IP .NE. 3) GO TO 109 
-         IX2 = IW+IDO 
-         IF (NA .NE. 0) GO TO 107 
-! rav    CALL RIF3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2))                  
-         CALL R1F3KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2)) 
-         GO TO 108 
-  107    CALL R1F3KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2)) 
-  108    NA = 1-NA 
-         GO TO 115 
-  109    IF (IP .NE. 5) GO TO 112 
-         IX2 = IW+IDO 
-         IX3 = IX2+IDO 
-         IX4 = IX3+IDO 
-         IF (NA .NE. 0) GO TO 110 
-         CALL R1F5KB (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),                  &
-     &                  WA(IX3),WA(IX4))                                
-         GO TO 111 
-  110    CALL R1F5KB (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),                  &
-     &                  WA(IX3),WA(IX4))                                
-  111    NA = 1-NA 
-         GO TO 115 
-  112    IF (NA .NE. 0) GO TO 113 
-! rav    CALL RIFGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW))           
-         CALL R1FGKB (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW)) 
-         GO TO 114 
-! rav 113    CALL RIFGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW))      
-  113    CALL R1FGKB (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW)) 
-  114    IF (IDO .EQ. 1) NA = 1-NA 
-  115    L1 = L2 
-         IW = IW+(IP-1)*IDO 
-  116 END DO 
-      RETURN 
-      END                                           
+subroutine rfftb1 ( n, in, c, ch, wa, fac )
+
+!*****************************************************************************80
+!
+!! RFFTB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) in
+  integer ( kind = 4 ) n
+
+  real ( kind = 4 ) c(in,*)
+  real ( kind = 4 ) ch(*)
+  real ( kind = 4 ) fac(15)
+  real ( kind = 4 ) half
+  real ( kind = 4 ) halfm
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) ix2
+  integer ( kind = 4 ) ix3
+  integer ( kind = 4 ) ix4
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nf
+  integer ( kind = 4 ) nl
+  real ( kind = 4 ) wa(n)
+
+  nf = int ( fac(2) )
+  na = 0
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1+2) )
+    na = 1 - na
+
+    if ( 5 < ip ) then
+      if ( k1 /= nf ) then
+        na = 1 - na
+      end if
+    end if
+
+  end do
+
+  half = 0.5E+00
+  halfm = -0.5E+00
+  modn = mod ( n, 2 )
+  nl = n - 2
+  if ( modn /= 0 ) then
+    nl = n - 1
+  end if
+
+  if ( na == 0 ) then
+
+    do j = 2, nl, 2
+      c(1,j) = half * c(1,j)
+      c(1,j+1) = halfm * c(1,j+1)
+    end do
+
+  else
+
+    ch(1) = c(1,1)
+    ch(n) = c(1,n)
+
+    do j = 2, nl, 2
+      ch(j) = half*c(1,j)
+      ch(j+1) = halfm*c(1,j+1)
+    end do
+
+  end if
+
+  l1 = 1
+  iw = 1
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1+2) )
+    l2 = ip * l1
+    ido = n / l2
+    idl1 = ido * l1
+
+    if ( ip == 4 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+
+      if ( na == 0 ) then
+        call r1f4kb ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2), wa(ix3) )
+      else
+        call r1f4kb ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2), wa(ix3) )
+      end if
+
+      na = 1 - na
+
+    else if ( ip == 2 ) then
+
+      if ( na == 0 ) then
+        call r1f2kb ( ido, l1, c, in, ch, 1, wa(iw) )
+      else
+        call r1f2kb ( ido, l1, ch, 1, c, in, wa(iw) )
+      end if
+
+      na = 1 - na
+
+    else if ( ip == 3 ) then
+
+      ix2 = iw + ido
+
+      if ( na == 0 ) then
+        call r1f3kb ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2) )
+      else
+        call r1f3kb ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2) )
+      end if
+
+      na = 1 - na
+
+    else if ( ip == 5 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+      ix4 = ix3 + ido
+
+      if ( na == 0 ) then
+        call r1f5kb ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
+      else
+        call r1f5kb ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
+      end if
+
+      na = 1 - na
+
+    else
+
+      if ( na == 0 ) then
+        call r1fgkb ( ido, ip, l1, idl1, c, c, c, in, ch, ch, 1, wa(iw) )
+      else
+        call r1fgkb ( ido, ip, l1, idl1, ch, ch, ch, 1, c, c, in, wa(iw) )
+      end if
+
+      if ( ido == 1 ) then
+        na = 1 - na
+      end if
+
+    end if
+
+    l1 = l2
+    iw = iw + ( ip - 1 ) * ido
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rfftf1.F b/wrfv2_fire/external/fftpack/fftpack5/rfftf1.F
index 6c1f3520..6877caec 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rfftf1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rfftf1.F
@@ -1,90 +1,179 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rfftf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFTF1 (N,IN,C,CH,WA,FAC) 
-      REAL       CH(*) ,C(IN,*)  ,WA(N)   ,FAC(15) 
-!                                                                       
-      NF = FAC(2) 
-      NA = 1 
-      L2 = N 
-      IW = N 
-      DO 111 K1=1,NF 
-         KH = NF-K1 
-         IP = FAC(KH+3) 
-         L1 = L2/IP 
-         IDO = N/L2 
-         IDL1 = IDO*L1 
-         IW = IW-(IP-1)*IDO 
-         NA = 1-NA 
-         IF (IP .NE. 4) GO TO 102 
-         IX2 = IW+IDO 
-         IX3 = IX2+IDO 
-         IF (NA .NE. 0) GO TO 101 
-         CALL R1F4KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),WA(IX3)) 
-         GO TO 110 
-  101    CALL R1F4KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),WA(IX3)) 
-         GO TO 110 
-  102    IF (IP .NE. 2) GO TO 104 
-         IF (NA .NE. 0) GO TO 103 
-         CALL R1F2KF (IDO,L1,C,IN,CH,1,WA(IW)) 
-         GO TO 110 
-  103    CALL R1F2KF (IDO,L1,CH,1,C,IN,WA(IW)) 
-         GO TO 110 
-  104    IF (IP .NE. 3) GO TO 106 
-         IX2 = IW+IDO 
-         IF (NA .NE. 0) GO TO 105 
-         CALL R1F3KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2)) 
-         GO TO 110 
-  105    CALL R1F3KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2)) 
-         GO TO 110 
-  106    IF (IP .NE. 5) GO TO 108 
-         IX2 = IW+IDO 
-         IX3 = IX2+IDO 
-         IX4 = IX3+IDO 
-         IF (NA .NE. 0) GO TO 107 
-         CALL R1F5KF (IDO,L1,C,IN,CH,1,WA(IW),WA(IX2),                  &
-     &                      WA(IX3),WA(IX4))                            
-         GO TO 110 
-  107    CALL R1F5KF (IDO,L1,CH,1,C,IN,WA(IW),WA(IX2),                  &
-     &                      WA(IX3),WA(IX4))                            
-         GO TO 110 
-  108    IF (IDO .EQ. 1) NA = 1-NA 
-         IF (NA .NE. 0) GO TO 109 
-         CALL R1FGKF (IDO,IP,L1,IDL1,C,C,C,IN,CH,CH,1,WA(IW)) 
-         NA = 1 
-         GO TO 110 
-  109    CALL R1FGKF (IDO,IP,L1,IDL1,CH,CH,CH,1,C,C,IN,WA(IW)) 
-         NA = 0 
-  110    L2 = L1 
-  111 END DO 
-      SN = 1./N 
-      TSN = 2./N 
-      TSNM = -TSN 
-      MODN = MOD(N,2) 
-      NL = N-2 
-      IF(MODN .NE. 0) NL = N-1 
-      IF (NA .NE. 0) GO TO 120 
-      C(1,1) = SN*CH(1) 
-      DO 118 J=2,NL,2 
-         C(1,J) = TSN*CH(J) 
-         C(1,J+1) = TSNM*CH(J+1) 
-  118 END DO 
-      IF(MODN .NE. 0) RETURN 
-      C(1,N) = SN*CH(N) 
-      RETURN 
-  120 C(1,1) = SN*C(1,1) 
-      DO 122 J=2,NL,2 
-         C(1,J) = TSN*C(1,J) 
-         C(1,J+1) = TSNM*C(1,J+1) 
-  122 END DO 
-      IF(MODN .NE. 0) RETURN 
-      C(1,N) = SN*C(1,N) 
-      RETURN 
-      END                                           
+subroutine rfftf1 ( n, in, c, ch, wa, fac )
+
+!*****************************************************************************80
+!
+!! RFFTF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) in
+  integer ( kind = 4 ) n
+
+  real ( kind = 4 ) c(in,*)
+  real ( kind = 4 ) ch(*)
+  real ( kind = 4 ) fac(15)
+  integer ( kind = 4 ) idl1
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) ix2
+  integer ( kind = 4 ) ix3
+  integer ( kind = 4 ) ix4
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) kh
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nf
+  integer ( kind = 4 ) nl
+  real ( kind = 4 ) sn
+  real ( kind = 4 ) tsn
+  real ( kind = 4 ) tsnm
+  real ( kind = 4 ) wa(n)
+
+  nf = int ( fac(2) )
+  na = 1
+  l2 = n
+  iw = n
+
+  do k1 = 1, nf
+
+    kh = nf - k1
+    ip = int ( fac(kh+3) )
+    l1 = l2 / ip
+    ido = n / l2
+    idl1 = ido * l1
+    iw = iw - ( ip - 1 ) * ido
+    na = 1 - na
+
+    if ( ip == 4 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+
+      if ( na == 0 ) then
+        call r1f4kf ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2), wa(ix3) )
+      else
+        call r1f4kf ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2), wa(ix3) )
+      end if
+
+    else if ( ip == 2 ) then
+
+      if ( na == 0 ) then
+        call r1f2kf ( ido, l1, c, in, ch, 1, wa(iw) )
+      else
+        call r1f2kf ( ido, l1, ch, 1, c, in, wa(iw) )
+      end if
+
+    else if ( ip == 3 ) then
+
+      ix2 = iw + ido
+
+      if ( na == 0 ) then
+        call r1f3kf ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2) )
+      else
+        call r1f3kf ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2) )
+      end if
+
+    else if ( ip == 5 ) then
+
+      ix2 = iw + ido
+      ix3 = ix2 + ido
+      ix4 = ix3 + ido
+
+      if ( na == 0 ) then
+        call r1f5kf ( ido, l1, c, in, ch, 1, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
+      else
+        call r1f5kf ( ido, l1, ch, 1, c, in, wa(iw), wa(ix2), wa(ix3), wa(ix4) )
+      end if
+
+    else
+
+      if ( ido == 1 ) then
+        na = 1 - na
+      end if
+
+      if ( na == 0 ) then
+        call r1fgkf ( ido, ip, l1, idl1, c, c, c, in, ch, ch, 1, wa(iw) )
+        na = 1
+      else
+        call r1fgkf ( ido, ip, l1, idl1, ch, ch, ch, 1, c, c, in, wa(iw) )
+        na = 0
+      end if
+
+    end if
+
+    l2 = l1
+
+  end do
+
+  sn = 1.0E+00 / real ( n, kind = 4 )
+  tsn = 2.0E+00 / real ( n, kind = 4 )
+  tsnm = -tsn
+  modn = mod ( n, 2 )
+  nl = n - 2
+
+  if ( modn /= 0 ) then
+    nl = n - 1
+  end if
+
+  if ( na == 0 ) then
+
+    c(1,1) = sn * ch(1)
+    do j = 2, nl, 2
+      c(1,j) = tsn * ch(j)
+      c(1,j+1) = tsnm * ch(j+1)
+    end do
+
+    if ( modn == 0 ) then
+      c(1,n) = sn * ch(n)
+    end if
+
+  else
+
+    c(1,1) = sn * c(1,1)
+
+    do j = 2, nl, 2
+      c(1,j) = tsn * c(1,j)
+      c(1,j+1) = tsnm * c(1,j+1)
+    end do
+
+    if ( modn == 0 ) then
+      c(1,n) = sn * c(1,n)
+    end if
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rffti1.F b/wrfv2_fire/external/fftpack/fftpack5/rffti1.F
index fbd9895a..f3c8f5bf 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rffti1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rffti1.F
@@ -1,70 +1,156 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rffti1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFTI1 (N,WA,FAC) 
-      REAL       WA(N)      ,FAC(15) 
-      INTEGER    NTRYH(4) 
-      DOUBLE PRECISION TPI,ARGH,ARGLD,ARG 
-      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/ 
-!                                                                       
-      NL = N 
-      NF = 0 
-      J = 0 
-  101 J = J+1 
-      IF (J-4) 102,102,103 
-  102 NTRY = NTRYH(J) 
-      GO TO 104 
-  103 NTRY = NTRY+2 
-  104 NQ = NL/NTRY 
-      NR = NL-NTRY*NQ 
-      IF (NR) 101,105,101 
-  105 NF = NF+1 
-      FAC(NF+2) = NTRY 
-      NL = NQ 
-      IF (NTRY .NE. 2) GO TO 107 
-      IF (NF .EQ. 1) GO TO 107 
-      DO 106 I=2,NF 
-         IB = NF-I+2 
-         FAC(IB+2) = FAC(IB+1) 
-  106 END DO 
-      FAC(3) = 2 
-  107 IF (NL .NE. 1) GO TO 104 
-      FAC(1) = N 
-      FAC(2) = NF 
-      TPI = 8.D0*DATAN(1.D0) 
-      ARGH = TPI/FLOAT(N) 
-      IS = 0 
-      NFM1 = NF-1 
-      L1 = 1 
-      IF (NFM1 .EQ. 0) RETURN 
-      DO 110 K1=1,NFM1 
-         IP = FAC(K1+2) 
-         LD = 0 
-         L2 = L1*IP 
-         IDO = N/L2 
-         IPM = IP-1 
-         DO 109 J=1,IPM 
-            LD = LD+L1 
-            I = IS 
-            ARGLD = FLOAT(LD)*ARGH 
-            FI = 0. 
-            DO 108 II=3,IDO,2 
-               I = I+2 
-               FI = FI+1. 
-               ARG = FI*ARGLD 
-               WA(I-1) = DCOS(ARG) 
-               WA(I) = DSIN(ARG) 
-  108       CONTINUE 
-            IS = IS+IDO 
-  109    CONTINUE 
-         L1 = L2 
-  110 END DO 
-      RETURN 
-      END                                           
+subroutine rffti1 ( n, wa, fac )
+
+!*****************************************************************************80
+!
+!! RFFTI1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the number for which factorization
+!    and other information is needed.
+!
+!    Output, real ( kind = 4 ) WA(N), trigonometric information.
+!
+!    Output, real ( kind = 4 ) FAC(15), factorization information.
+!    FAC(1) is N, FAC(2) is NF, the number of factors, and FAC(3:NF+2) are the
+!    factors.
+!
+  implicit none
+
+  integer ( kind = 4 ) n
+
+  real ( kind = 8 ) arg
+  real ( kind = 8 ) argh
+  real ( kind = 8 ) argld
+  real ( kind = 4 ) fac(15)
+  real ( kind = 4 ) fi
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ib
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) ii
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) ipm
+  integer ( kind = 4 ) is
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) ld
+  integer ( kind = 4 ) nf
+  integer ( kind = 4 ) nfm1
+  integer ( kind = 4 ) nl
+  integer ( kind = 4 ) nq
+  integer ( kind = 4 ) nr
+  integer ( kind = 4 ) ntry
+  real ( kind = 8 ) tpi
+  real ( kind = 4 ) wa(n)
+
+  nl = n
+  nf = 0
+  j = 0
+
+  do while ( 1 < nl )
+
+    j = j + 1
+
+    if ( j == 1 ) then
+      ntry = 4
+    else if ( j == 2 ) then
+      ntry = 2
+    else if ( j == 3 ) then
+      ntry = 3
+    else if ( j == 4 ) then
+      ntry = 5
+    else
+      ntry = ntry + 2
+    end if
+
+    do
+
+      nq = nl / ntry
+      nr = nl - ntry * nq
+
+      if ( nr /= 0 ) then
+        exit
+      end if
+
+      nf = nf + 1
+      fac(nf+2) = real ( ntry, kind = 4 )
+      nl = nq
+!
+!  If 2 is a factor, make sure it appears first in the list of factors.
+!
+      if ( ntry == 2 ) then
+        if ( nf /= 1 ) then
+          do i = 2, nf
+            ib = nf - i + 2
+            fac(ib+2) = fac(ib+1)
+          end do
+          fac(3) = 2.0E+00
+        end if
+      end if
+
+    end do
+
+  end do
+
+  fac(1) = real ( n, kind = 4 )
+  fac(2) = real ( nf, kind = 4 )
+  tpi = 8.0D+00 * atan ( 1.0D+00 )
+  argh = tpi / real ( n, kind = 4 )
+  is = 0
+  nfm1 = nf-1
+  l1 = 1
+
+  do k1 = 1, nfm1
+    ip = int ( fac(k1+2) )
+    ld = 0
+    l2 = l1 * ip
+    ido = n / l2
+    ipm = ip - 1
+    do j = 1, ipm
+      ld = ld + l1
+      i = is
+      argld = real ( ld, kind = 4 ) * argh
+      fi = 0.0E+00
+      do ii = 3, ido, 2
+        i = i + 2
+        fi = fi + 1.0E+00
+        arg = fi * argld
+        wa(i-1) = real ( cos ( arg ), kind = 4 )
+        wa(i) = real ( sin ( arg ), kind = 4 )
+      end do
+      is = is + ido
+    end do
+    l1 = l2
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rfftmb.F b/wrfv2_fire/external/fftpack/fftpack5/rfftmb.F
index 04086e2b..f3c83d30 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rfftmb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rfftmb.F
@@ -1,37 +1,138 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rfftmb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFTMB (LOT, JUMP, N, INC, R, LENR, WSAVE, LENSAV,     &
-     &                  WORK, LENWRK, IER)                              
-      INTEGER  LOT, JUMP, N, INC, LENR, LENSAV, LENWRK, IER 
-      REAL     R(LENR), WSAVE(LENSAV)     ,WORK(LENWRK) 
-      LOGICAL  XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENR .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('RFFTMB ', 6) 
-      ELSEIF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('RFFTMB ', 8) 
-      ELSEIF (LENWRK .LT. LOT*N) THEN 
-        IER = 3 
-        CALL XERFFT ('RFFTMB ', 10) 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('RFFTMB ', -1) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      CALL MRFTB1 (LOT,JUMP,N,INC,R,WORK,WSAVE,WSAVE(N+1)) 
-      RETURN 
-      END                                           
+subroutine rfftmb ( lot, jump, n, inc, r, lenr, wsave, lensav, &
+  work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! RFFTMB: real single precision backward FFT, 1D, multiple vectors.
+!
+!  Discussion:
+!
+!    RFFTMB computes the one-dimensional Fourier transform of multiple
+!    periodic sequences within a real array.  This transform is referred
+!    to as the backward transform or Fourier synthesis, transforming the
+!    sequences from spectral to physical space.
+!
+!    This transform is normalized since a call to RFFTMB followed
+!    by a call to RFFTMF (or vice-versa) reproduces the original
+!    array  within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed
+!    within array R.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations, in
+!    array R, of the first elements of two consecutive sequences to be
+!    transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array R, of two consecutive elements within the same sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), real array containing LOT
+!    sequences, each having length N.  R can have any number of dimensions,
+!    but the total number of locations must be at least LENR.  On input, the
+!    spectral data to be transformed, on output the physical data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least (LOT-1)*JUMP + INC*(N-1) + 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to RFFTMI before the first call to routine RFFTMF
+!    or RFFTMB for a given transform length N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must  be at least N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least LOT*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC, JUMP, N, LOT are not consistent.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenr
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) r(lenr)
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  logical              xercon
+
+  ier = 0
+
+  if ( lenr < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'rfftmb ', 6 )
+    return
+  end if
+
+  if ( lensav < n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'rfftmb ', 8 )
+    return
+  end if
+
+  if ( lenwrk < lot * n ) then
+    ier = 3
+    call xerfft ( 'rfftmb ', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'rfftmb ', -1 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  call mrftb1 ( lot, jump, n, inc, r, work, wsave, wsave(n+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rfftmf.F b/wrfv2_fire/external/fftpack/fftpack5/rfftmf.F
index 4699e61a..daf67b95 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rfftmf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rfftmf.F
@@ -1,37 +1,138 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rfftmf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFTMF (LOT, JUMP, N, INC, R, LENR, WSAVE, LENSAV,     &
-     &                  WORK, LENWRK, IER)                              
-      INTEGER  LOT, JUMP, N, INC, LENR, LENSAV, LENWRK, IER 
-      REAL     R(LENR), WSAVE(LENSAV), WORK(LENWRK) 
-      LOGICAL  XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENR .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('RFFTMF ', 6) 
-      ELSEIF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('RFFTMF ', 8) 
-      ELSEIF (LENWRK .LT. LOT*N) THEN 
-        IER = 3 
-        CALL XERFFT ('RFFTMF ', 10) 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('RFFTMF ', -1) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      CALL MRFTF1 (LOT,JUMP,N,INC,R,WORK,WSAVE,WSAVE(N+1)) 
-      RETURN 
-      END                                           
+subroutine rfftmf ( lot, jump, n, inc, r, lenr, wsave, lensav, &
+  work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! RFFTMF: real single precision forward FFT, 1D, multiple vectors.
+!
+!  Discussion:
+!
+!    RFFTMF computes the one-dimensional Fourier transform of multiple
+!    periodic sequences within a real array.  This transform is referred
+!    to as the forward transform or Fourier analysis, transforming the
+!    sequences from physical to spectral space.
+!
+!    This transform is normalized since a call to RFFTMF followed
+!    by a call to RFFTMB (or vice-versa) reproduces the original array
+!    within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed
+!    within array R.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations, in
+!    array R, of the first elements of two consecutive sequences to be
+!    transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the same sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), real array containing LOT
+!    sequences, each having length N.  R can have any number of dimensions, but
+!    the total number of locations must be at least LENR.  On input, the
+!    physical data to be transformed, on output the spectral data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least (LOT-1)*JUMP + INC*(N-1) + 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to RFFTMI before the first call to routine RFFTMF
+!    or RFFTMB for a given transform length N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least LOT*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC, JUMP, N, LOT are not consistent.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenr
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) r(lenr)
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  logical              xercon
+
+  ier = 0
+
+  if ( lenr < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'rfftmf ', 6 )
+    return
+  end if
+
+  if ( lensav < n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'rfftmf ', 8 )
+    return
+  end if
+
+  if ( lenwrk < lot * n ) then
+    ier = 3
+    call xerfft ( 'rfftmf ', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'rfftmf ', -1 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  call mrftf1 ( lot, jump, n, inc, r, work, wsave, wsave(n+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/rfftmi.F b/wrfv2_fire/external/fftpack/fftpack5/rfftmi.F
index 0b541b8f..649b7f3f 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/rfftmi.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/rfftmi.F
@@ -1,26 +1,82 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: rfftmi.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE RFFTMI (N, WSAVE, LENSAV, IER) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('RFFTMI ', 3) 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-!                                                                       
-      CALL MRFTI1 (N,WSAVE(1),WSAVE(N+1)) 
-      RETURN 
-      END                                           
+subroutine rfftmi ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! RFFTMI: initialization for RFFTMB and RFFTMF.
+!
+!  Discussion:
+!
+!    RFFTMI initializes array WSAVE for use in its companion routines
+!    RFFTMB and RFFTMF.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), work array containing the prime
+!    factors of N and also containing certain trigonometric
+!    values which will be used in routines RFFTMB or RFFTMF.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'rfftmi ', 3 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  call mrfti1 ( n, wsave(1), wsave(n+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sinq1b.F b/wrfv2_fire/external/fftpack/fftpack5/sinq1b.F
index 6b0273cc..2da5f02e 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sinq1b.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sinq1b.F
@@ -1,49 +1,145 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sinq1b.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINQ1B ( N, INC, X, LENX, WSAVE, LENSAV,               &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('SINQ1B', 6) 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINQ1B', 8) 
-      ELSEIF (LENWRK .LT. N) THEN 
-        IER = 3 
-        CALL XERFFT ('SINQ1B', 10) 
-      ENDIF 
-!                                                                       
-      IF (N .GT. 1) GO TO 101 
-      X(1,1) = 4.*X(1,1) 
-      RETURN 
-  101 NS2 = N/2 
-      DO 102 K=2,N,2 
-         X(1,K) = -X(1,K) 
-  102 END DO 
-      CALL COSQ1B (N,INC,X,LENX,WSAVE,LENSAV,WORK,LENWRK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINQ1B',-5) 
-        GO TO 300 
-      ENDIF 
-      DO 103 K=1,NS2 
-         KC = N-K 
-         XHOLD = X(1,K) 
-         X(1,K) = X(1,KC+1) 
-         X(1,KC+1) = XHOLD 
-  103 END DO 
-  300 RETURN 
-      END                                           
+subroutine sinq1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! SINQ1B: real single precision backward sine quarter wave transform, 1D.
+!
+!  Discussion:
+!
+!    SINQ1B computes the one-dimensional Fourier transform of a sequence
+!    which is a sine series with odd wave numbers.  This transform is
+!    referred to as the backward transform or Fourier synthesis,
+!    transforming the sequence from spectral to physical space.
+!
+!    This transform is normalized since a call to SINQ1B followed
+!    by a call to SINQ1F (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    01 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), on input, the sequence to be
+!    transformed.  On output, the transformed sequence.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to SINQ1I before the first call to routine SINQ1F
+!    or SINQ1B for a given transform length N.  WSAVE's contents may be
+!    re-used for subsequent calls to SINQ1F and SINQ1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N.
+!
+!    Output, integer ( kind = 4 ) IER, the error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) xhold
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'sinq1b', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'sinq1b', 8 )
+    return
+  end if
+
+  if ( lenwrk < n ) then
+    ier = 3
+    call xerfft ( 'sinq1b', 10 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    x(1,1) = 4.0E+00 * x(1,1)
+    return
+  end if
+
+  ns2 = n / 2
+
+  do k = 2, n, 2
+    x(1,k) = -x(1,k)
+  end do
+
+  call cosq1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'sinq1b', -5 )
+    return
+  end if
+
+  do k = 1, ns2
+    kc = n - k
+    xhold = x(1,k)
+    x(1,k) = x(1,kc+1)
+    x(1,kc+1) = xhold
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sinq1f.F b/wrfv2_fire/external/fftpack/fftpack5/sinq1f.F
index 10780d4c..12635ad6 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sinq1f.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sinq1f.F
@@ -1,50 +1,144 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sinq1f.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINQ1F ( N, INC, X, LENX, WSAVE, LENSAV,               &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('SINQ1F', 6) 
-        GO TO 300 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINQ1F', 8) 
-        GO TO 300 
-      ELSEIF (LENWRK .LT. N) THEN 
-        IER = 3 
-        CALL XERFFT ('SINQ1F', 10) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-      NS2 = N/2 
-      DO 101 K=1,NS2 
-         KC = N-K 
-         XHOLD = X(1,K) 
-         X(1,K) = X(1,KC+1) 
-         X(1,KC+1) = XHOLD 
-  101 END DO 
-      CALL COSQ1F (N,INC,X,LENX,WSAVE,LENSAV,WORK,LENWRK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINQ1F',-5) 
-        GO TO 300 
-      ENDIF 
-      DO 102 K=2,N,2 
-         X(1,K) = -X(1,K) 
-  102 END DO 
-  300 RETURN 
-      END                                           
+subroutine sinq1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! SINQ1F: real single precision forward sine quarter wave transform, 1D.
+!
+!  Discussion:
+!
+!    SINQ1F computes the one-dimensional Fourier transform of a sequence
+!    which is a sine series of odd wave numbers.  This transform is
+!    referred to as the forward transform or Fourier analysis, transforming
+!    the sequence from physical to spectral space.
+!
+!    This transform is normalized since a call to SINQ1F followed
+!    by a call to SINQ1B (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    01 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), on input, the sequence to be
+!    transformed.  On output, the transformed sequence.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to SINQ1I before the first call to routine SINQ1F
+!    or SINQ1B for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to SINQ1F and SINQ1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least N.
+!
+!    Output, integer ( kind = 4 ) IER, the error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) xhold
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'sinq1f', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'sinq1f', 8 )
+    return
+  end if
+
+  if ( lenwrk < n ) then
+    ier = 3
+    call xerfft ( 'sinq1f', 10 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  ns2 = n / 2
+
+  do k = 1, ns2
+    kc = n - k
+    xhold = x(1,k)
+    x(1,k) = x(1,kc+1)
+    x(1,kc+1) = xhold
+  end do
+
+  call cosq1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'sinq1f', -5 )
+    return
+  end if
+
+  do k = 2, n, 2
+    x(1,k) = -x(1,k)
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sinq1i.F b/wrfv2_fire/external/fftpack/fftpack5/sinq1i.F
index 09b06841..382f4af7 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sinq1i.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sinq1i.F
@@ -1,29 +1,86 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sinq1i.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINQ1I (N, WSAVE, LENSAV, IER) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINQ1I', 3) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      CALL COSQ1I (N, WSAVE, LENSAV, IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINQ1I',-5) 
-      ENDIF 
-  300 RETURN 
-      END                                           
+subroutine sinq1i ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! SINQ1I: initialization for SINQ1B and SINQ1F.
+!
+!  Discussion:
+!
+!    SINQ1I initializes array WSAVE for use in its companion routines
+!    SINQ1F and SINQ1B.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    01 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors
+!    of N and also containing certain trigonometric values which will be used
+!   in routines SINQ1B or SINQ1F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'sinq1i', 3 )
+    return
+  end if
+
+  call cosq1i ( n, wsave, lensav, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'sinq1i', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sinqmb.F b/wrfv2_fire/external/fftpack/fftpack5/sinqmb.F
index ce84e3aa..edbd7081 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sinqmb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sinqmb.F
@@ -1,61 +1,176 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sinqmb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINQMB (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-      LOGICAL    XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('SINQMB', 6) 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINQMB', 8) 
-      ELSEIF (LENWRK .LT. LOT*N) THEN 
-        IER = 3 
-        CALL XERFFT ('SINQMB', 10) 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('SINQMB', -1) 
-      ENDIF 
-!                                                                       
-      LJ = (LOT-1)*JUMP+1 
-      IF (N .GT. 1) GO TO 101 
-      DO 201 M=1,LJ,JUMP 
-         X(M,1) = 4.*X(M,1) 
-  201 END DO 
-      RETURN 
-  101 NS2 = N/2 
-      DO 102 K=2,N,2 
-         DO 202 M=1,LJ,JUMP 
-         X(M,K) = -X(M,K) 
-  202    CONTINUE 
-  102 END DO 
-      CALL COSQMB (LOT,JUMP,N,INC,X,LENX,WSAVE,LENSAV,WORK,LENWRK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINQMB',-5) 
-        GO TO 300 
-      ENDIF 
-      DO 103 K=1,NS2 
-         KC = N-K 
-         DO 203 M=1,LJ,JUMP 
-         XHOLD = X(M,K) 
-         X(M,K) = X(M,KC+1) 
-         X(M,KC+1) = XHOLD 
-  203    CONTINUE 
-  103 END DO 
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine sinqmb ( lot, jump, n, inc, x, lenx, wsave, lensav, &
+  work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! SINQMB: real single precision backward sine quarter wave, multiple vectors.
+!
+!  Discussion:
+!
+!    SINQMB computes the one-dimensional Fourier transform of multiple
+!    sequences within a real array, where each of the sequences is a
+!    sine series with odd wave numbers.  This transform is referred to as
+!    the backward transform or Fourier synthesis, transforming the
+!    sequences from spectral to physical space.
+!
+!    This transform is normalized since a call to SINQMB followed
+!    by a call to SINQMF (or vice-versa) reproduces the original
+!    array  within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    03 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed
+!    within array R.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations, in
+!    array R, of the first elements of two consecutive sequences to be
+!    transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array R, of two consecutive elements within the same sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), containing LOT sequences, each
+!    having length N.  R can have any number of dimensions, but the total
+!    number of locations must be at least LENR.  On input, R contains the data
+!    to be transformed, and on output the transformed data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to SINQMI before the first call to routine SINQMF
+!    or SINQMB for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to SINQMF and SINQMB with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least LOT*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC,JUMP,N,LOT are not consistent;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lj
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+  logical              xercon
+  real ( kind = 4 ) xhold
+
+  ier = 0
+
+  if ( lenx < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'sinqmb', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'sinqmb', 8 )
+    return
+  end if
+
+  if ( lenwrk < lot * n ) then
+    ier = 3
+    call xerfft ( 'sinqmb', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'sinqmb', -1 )
+    return
+  end if
+
+  lj = ( lot - 1 ) * jump + 1
+
+  if ( n <= 1 ) then
+    do m = 1, lj, jump
+      x(m,1) = 4.0E+00 * x(m,1)
+    end do
+    return
+  end if
+
+  ns2 = n / 2
+
+  do k = 2, n, 2
+    do m = 1, lj, jump
+      x(m,k) = -x(m,k)
+    end do
+  end do
+
+  call cosqmb ( lot, jump, n, inc, x, lenx, wsave, lensav, work, lenwrk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'sinqmb', -5 )
+    return
+  end if
+
+  do k = 1, ns2
+    kc = n - k
+    do m = 1, lj, jump
+      xhold = x(m,k)
+      x(m,k) = x(m,kc+1)
+      x(m,kc+1) = xhold
+    end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sinqmf.F b/wrfv2_fire/external/fftpack/fftpack5/sinqmf.F
index e87c5ec6..7d3da14c 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sinqmf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sinqmf.F
@@ -1,61 +1,173 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sinqmf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINQMF (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-      LOGICAL    XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('SINQMF', 6) 
-        GO TO 300 
-      ELSEIF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINQMF', 8) 
-        GO TO 300 
-      ELSEIF (LENWRK .LT. LOT*N) THEN 
-        IER = 3 
-        CALL XERFFT ('SINQMF', 10) 
-        GO TO 300 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('SINQMF', -1) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      IF (N .EQ. 1) RETURN 
-      NS2 = N/2 
-      LJ = (LOT-1)*JUMP+1 
-      DO 101 K=1,NS2 
-         KC = N-K 
-         DO 201 M=1,LJ,JUMP 
-         XHOLD = X(M,K) 
-         X(M,K) = X(M,KC+1) 
-         X(M,KC+1) = XHOLD 
-  201    CONTINUE 
-  101 END DO 
-      CALL COSQMF (LOT,JUMP,N,INC,X,LENX,WSAVE,LENSAV,WORK,LENWRK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINQMF',-5) 
-        GO TO 300 
-      ENDIF 
-      DO 102 K=2,N,2 
-         DO 202 M=1,LJ,JUMP 
-         X(M,K) = -X(M,K) 
-  202    CONTINUE 
-  102 END DO 
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine sinqmf ( lot, jump, n, inc, x, lenx, wsave, lensav, &
+  work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! SINQMF: real single precision forward sine quarter wave, multiple vectors.
+!
+!  Discussion:
+!
+!    SINQMF computes the one-dimensional Fourier transform of multiple
+!    sequences within a real array, where each sequence is a sine series
+!    with odd wave numbers.  This transform is referred to as the forward
+!    transform or Fourier synthesis, transforming the sequences from
+!    spectral to physical space.
+!
+!    This transform is normalized since a call to SINQMF followed
+!    by a call to SINQMB (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    03 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed
+!    within array R.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations,
+!    in array R, of the first elements of two consecutive sequences to
+!    be transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the same sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), containing LOT sequences, each
+!    having length N.  R can have any number of dimensions, but the total
+!    number of locations must be at least LENR.  On input, R contains the data
+!    to be transformed, and on output the transformed data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to SINQMI before the first call to routine SINQMF
+!    or SINQMB for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to SINQMF and SINQMB with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least LOT*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC,JUMP,N,LOT are not consistent;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lj
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+  logical              xercon
+  real ( kind = 4 ) xhold
+
+  ier = 0
+
+  if ( lenx < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'sinqmf', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'sinqmf', 8 )
+    return
+  end if
+
+  if ( lenwrk < lot * n ) then
+    ier = 3
+    call xerfft ( 'sinqmf', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'sinqmf', -1 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  ns2 = n / 2
+  lj = ( lot - 1 ) * jump + 1
+
+  do k = 1, ns2
+     kc = n - k
+     do m = 1, lj, jump
+       xhold = x(m,k)
+       x(m,k) = x(m,kc+1)
+       x(m,kc+1) = xhold
+     end do
+  end do
+
+  call cosqmf ( lot, jump, n, inc, x, lenx, wsave, lensav, work, &
+    lenwrk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'sinqmf', -5 )
+    return
+  end if
+
+  do k = 2, n, 2
+     do m = 1, lj, jump
+       x(m,k) = -x(m,k)
+     end do
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sinqmi.F b/wrfv2_fire/external/fftpack/fftpack5/sinqmi.F
index f5a976ba..e62e65a5 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sinqmi.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sinqmi.F
@@ -1,30 +1,86 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sinqmi.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINQMI (N, WSAVE, LENSAV, IER) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. 2*N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINQMI', 3) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      CALL COSQMI (N, WSAVE, LENSAV, IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINQMI',-5) 
-      ENDIF 
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine sinqmi ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! SINQMI: initialization for SINQMB and SINQMF.
+!
+!  Discussion:
+!
+!    SINQMI initializes array WSAVE for use in its companion routines
+!    SINQMF and SINQMB.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    03 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors
+!    of N and also containing certain trigonometric values which will be used
+!    in routines SINQMB or SINQMF.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'sinqmi', 3 )
+    return
+  end if
+
+  call cosqmi ( n, wsave, lensav, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'sinqmi', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sint1b.F b/wrfv2_fire/external/fftpack/fftpack5/sint1b.F
index 55f3876c..cf827e64 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sint1b.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sint1b.F
@@ -1,40 +1,123 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sint1b.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINT1B ( N, INC, X, LENX, WSAVE, LENSAV,               &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('SINT1B', 6) 
-        GO TO 100 
-      ELSEIF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINT1B', 8) 
-        GO TO 100 
-      ELSEIF (LENWRK .LT. (2*N+2)) THEN 
-        IER = 3 
-        CALL XERFFT ('SINT1B', 10) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-      CALL SINTB1(N,INC,X,WSAVE,WORK,WORK(N+2),IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINT1B',-5) 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine sint1b ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! SINT1B: real single precision backward sine transform, 1D.
+!
+!  Discussion:
+!
+!    SINT1B computes the one-dimensional Fourier transform of an odd
+!    sequence within a real array.  This transform is referred to as
+!    the backward transform or Fourier synthesis, transforming the
+!    sequence from spectral to physical space.
+!
+!    This transform is normalized since a call to SINT1B followed
+!    by a call to SINT1F (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    30 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N+1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), on input, contains the sequence
+!    to be transformed, and on output, the transformed sequence.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to SINT1I before the first call to routine SINT1F
+!    or SINT1B for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to SINT1F and SINT1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*N+2.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'sint1b', 6 )
+    return
+  end if
+
+  if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'sint1b', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * n + 2 ) then
+    ier = 3
+    call xerfft ( 'sint1b', 10 )
+    return
+  end if
+
+  call sintb1 ( n, inc, x, wsave, work, work(n+2), ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'sint1b', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sint1f.F b/wrfv2_fire/external/fftpack/fftpack5/sint1f.F
index 3967b8d6..3ab80322 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sint1f.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sint1f.F
@@ -1,38 +1,123 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sint1f.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINT1F ( N, INC, X, LENX, WSAVE, LENSAV,               &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-!                                                                       
-      IER = 0 
-      IF (LENX .LT. INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('SINT1F', 6) 
-        GO TO 100 
-      ELSEIF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINT1F', 8) 
-        GO TO 100 
-      ELSEIF (LENWRK .LT. (2*N+2)) THEN 
-        IER = 3 
-        CALL XERFFT ('SINT1F', 10) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-      CALL SINTF1(N,INC,X,WSAVE,WORK,WORK(N+2),IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINT1F',-5) 
-      ENDIF 
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine sint1f ( n, inc, x, lenx, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! SINT1F: real single precision forward sine transform, 1D.
+!
+!  Discussion:
+!
+!    SINT1F computes the one-dimensional Fourier transform of an odd
+!    sequence within a real array.  This transform is referred to as the
+!    forward transform or Fourier analysis, transforming the sequence
+!    from physical to spectral space.
+!
+!    This transform is normalized since a call to SINT1F followed
+!    by a call to SINT1B (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    30 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N+1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations,
+!    in array R, of two consecutive elements within the sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), on input, contains the sequence
+!    to be transformed, and on output, the transformed sequence.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to SINT1I before the first call to routine SINT1F
+!    or SINT1B for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to SINT1F and SINT1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*N+2.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+
+  ier = 0
+
+  if ( lenx < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'SINT1F', 6 )
+    return
+  end if
+
+  if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'SINT1F', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * n + 2 ) then
+    ier = 3
+    call xerfft ( 'SINT1F', 10 )
+    return
+  end if
+
+  call sintf1 ( n, inc, x, wsave, work, work(n+2), ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'SINT1F', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sint1i.F b/wrfv2_fire/external/fftpack/fftpack5/sint1i.F
index 5ed67a58..cc151453 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sint1i.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sint1i.F
@@ -1,40 +1,108 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sint1i.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINT1I (N, WSAVE, LENSAV, IER) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINT1I', 3) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      PI = 4.*ATAN(1.) 
-      IF (N .LE. 1) RETURN 
-      NS2 = N/2 
-      NP1 = N+1 
-      DT = PI/FLOAT(NP1) 
-      DO 101 K=1,NS2 
-         WSAVE(K) = 2.*SIN(K*DT) 
-  101 END DO 
-      LNSV = NP1 + INT(LOG(REAL(NP1))) +4 
-      CALL RFFT1I (NP1, WSAVE(NS2+1), LNSV, IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINT1I',-5) 
-      ENDIF 
-!                                                                       
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine sint1i ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! SINT1I: initialization for SINT1B and SINT1F.
+!
+!  Discussion:
+!
+!    SINT1I initializes array WSAVE for use in its companion routines
+!    SINT1F and SINT1B.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    30 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N+1 is a product
+!    of small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors
+!    of N and also containing certain trigonometric values which will be used
+!    in routines SINT1B or SINT1F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  real ( kind = 4 ) dt
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) pi
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'SINT1I', 3 )
+    return
+  end if
+
+  pi = 4.0E+00 * atan ( 1.0E+00 )
+
+  if ( n <= 1 ) then
+    return
+  end if
+
+  ns2 = n / 2
+  np1 = n + 1
+  dt = pi / real ( np1, kind = 4 )
+
+  do k = 1, ns2
+    wsave(k) = 2.0E+00 * sin ( real ( k, kind = 4 ) * dt )
+  end do
+
+  lnsv = np1 + int ( log ( real ( np1, kind = 4 ) ) ) + 4
+
+  call rfft1i ( np1, wsave(ns2+1), lnsv, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'SINT1I', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sintb1.F b/wrfv2_fire/external/fftpack/fftpack5/sintb1.F
index 75828886..b9b6f795 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sintb1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sintb1.F
@@ -1,60 +1,126 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sintb1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINTB1(N,INC,X,WSAVE,XH,WORK,IER) 
-      REAL       X(INC,*)       ,WSAVE(*)   ,XH(*) 
-      DOUBLE PRECISION           DSUM 
-      IER = 0 
-      IF (N-2) 200,102,103 
-  102 SRT3S2 = SQRT(3.)/2. 
-      XHOLD = SRT3S2*(X(1,1)+X(1,2)) 
-      X(1,2) = SRT3S2*(X(1,1)-X(1,2)) 
-      X(1,1) = XHOLD 
-      GO TO 200 
-  103 NP1 = N+1 
-      NS2 = N/2 
-      DO 104 K=1,NS2 
-         KC = NP1-K 
-         T1 = X(1,K)-X(1,KC) 
-         T2 = WSAVE(K)*(X(1,K)+X(1,KC)) 
-         XH(K+1) = T1+T2 
-         XH(KC+1) = T2-T1 
-  104 END DO 
-      MODN = MOD(N,2) 
-      IF (MODN .EQ. 0) GO TO 124 
-      XH(NS2+2) = 4.*X(1,NS2+1) 
-  124 XH(1) = 0. 
-      LNXH = NP1 
-      LNSV = NP1 + INT(LOG(REAL(NP1))) + 4 
-      LNWK = NP1 
-!                                                                       
-      CALL RFFT1F(NP1,1,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,LNWK,IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINTB1',-5) 
-        GO TO 200 
-      ENDIF 
-!                                                                       
-      IF(MOD(NP1,2) .NE. 0) GO TO 30 
-      XH(NP1) = XH(NP1)+XH(NP1) 
-   30 FNP1S4 = FLOAT(NP1)/4. 
-         X(1,1) = FNP1S4*XH(1) 
-         DSUM = X(1,1) 
-      DO 105 I=3,N,2 
-            X(1,I-1) = FNP1S4*XH(I) 
-            DSUM = DSUM+FNP1S4*XH(I-1) 
-            X(1,I) = DSUM 
-  105 END DO 
-      IF (MODN .NE. 0) GO TO 200 
-         X(1,N) = FNP1S4*XH(N+1) 
-!                                                                       
-  200 CONTINUE 
-      RETURN 
-      END                                           
+subroutine sintb1 ( n, inc, x, wsave, xh, work, ier )
+
+!*****************************************************************************80
+!
+!! SINTB1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  real ( kind = 8 ) dsum
+  real ( kind = 4 ) fnp1s4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) lnxh
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) srt3s2
+  real ( kind = 4 ) t1
+  real ( kind = 4 ) t2
+  real ( kind = 4 ) work(*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) xh(*)
+  real ( kind = 4 ) xhold
+
+  ier = 0
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    srt3s2 = sqrt ( 3.0E+00 ) / 2.0E+00
+    xhold = srt3s2 * ( x(1,1) + x(1,2) )
+    x(1,2) = srt3s2 * ( x(1,1) - x(1,2) )
+    x(1,1) = xhold
+    return
+  end if
+
+  np1 = n + 1
+  ns2 = n / 2
+
+  do k = 1, ns2
+    kc = np1 - k
+    t1 = x(1,k) - x(1,kc)
+    t2 = wsave(k) * ( x(1,k) + x(1,kc) )
+    xh(k+1) = t1 + t2
+    xh(kc+1) = t2 - t1
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    xh(ns2+2) = 4.0E+00 * x(1,ns2+1)
+  end if
+
+  xh(1) = 0.0E+00
+  lnxh = np1
+  lnsv = np1 + int ( log ( real ( np1, kind = 4 ) ) ) + 4
+  lnwk = np1
+
+  call rfft1f ( np1, 1, xh, lnxh, wsave(ns2+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'sintb1', -5 )
+    return
+  end if
+
+  if ( mod ( np1, 2 ) == 0 ) then
+    xh(np1) = xh(np1) + xh(np1)
+  end if
+
+  fnp1s4 = real ( np1, kind = 4 ) / 4.0E+00
+  x(1,1) = fnp1s4 * xh(1)
+  dsum = x(1,1)
+
+  do i = 3, n, 2
+    x(1,i-1) = fnp1s4 * xh(i)
+    dsum = dsum + fnp1s4 * xh(i-1)
+    x(1,i) = dsum
+  end do
+
+  if ( modn == 0 ) then
+    x(1,n) = fnp1s4 * xh(n+1)
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sintf1.F b/wrfv2_fire/external/fftpack/fftpack5/sintf1.F
index c590993b..2e8a53bd 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sintf1.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sintf1.F
@@ -1,59 +1,126 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sintf1.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINTF1(N,INC,X,WSAVE,XH,WORK,IER) 
-      REAL       X(INC,*)       ,WSAVE(*)   ,XH(*) 
-      DOUBLE PRECISION           DSUM 
-      IER = 0 
-      IF (N-2) 200,102,103 
-  102 SSQRT3 = 1./SQRT(3.) 
-      XHOLD = SSQRT3*(X(1,1)+X(1,2)) 
-      X(1,2) = SSQRT3*(X(1,1)-X(1,2)) 
-      X(1,1) = XHOLD 
-      GO TO 200 
-  103 NP1 = N+1 
-      NS2 = N/2 
-      DO 104 K=1,NS2 
-         KC = NP1-K 
-         T1 = X(1,K)-X(1,KC) 
-         T2 = WSAVE(K)*(X(1,K)+X(1,KC)) 
-         XH(K+1) = T1+T2 
-         XH(KC+1) = T2-T1 
-  104 END DO 
-      MODN = MOD(N,2) 
-      IF (MODN .EQ. 0) GO TO 124 
-      XH(NS2+2) = 4.*X(1,NS2+1) 
-  124 XH(1) = 0. 
-      LNXH = NP1 
-      LNSV = NP1 + INT(LOG(REAL(NP1))) + 4 
-      LNWK = NP1 
-!                                                                       
-      CALL RFFT1F(NP1,1,XH,LNXH,WSAVE(NS2+1),LNSV,WORK,                 &
-     &            LNWK,IER1)                                            
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINTF1',-5) 
-        GO TO 200 
-      ENDIF 
-!                                                                       
-      IF(MOD(NP1,2) .NE. 0) GO TO 30 
-      XH(NP1) = XH(NP1)+XH(NP1) 
-   30 SFNP1 = 1./FLOAT(NP1) 
-         X(1,1) = .5*XH(1) 
-         DSUM = X(1,1) 
-      DO 105 I=3,N,2 
-            X(1,I-1) = .5*XH(I) 
-            DSUM = DSUM+.5*XH(I-1) 
-            X(1,I) = DSUM 
-  105 END DO 
-      IF (MODN .NE. 0) GO TO 200 
-      X(1,N) = .5*XH(N+1) 
-  200 RETURN 
-      END                                           
+subroutine sintf1 ( n, inc, x, wsave, xh, work, ier )
+
+!*****************************************************************************80
+!
+!! SINTF1 is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+
+  real ( kind = 8 ) dsum
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) kc
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) lnwk
+  integer ( kind = 4 ) lnxh
+  integer ( kind = 4 ) modn
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) sfnp1
+  real ( kind = 4 ) ssqrt3
+  real ( kind = 4 ) t1
+  real ( kind = 4 ) t2
+  real ( kind = 4 ) work(*)
+  real ( kind = 4 ) wsave(*)
+  real ( kind = 4 ) x(inc,*)
+  real ( kind = 4 ) xh(*)
+  real ( kind = 4 ) xhold
+
+  ier = 0
+
+  if ( n < 2 ) then
+    return
+  end if
+
+  if ( n == 2 ) then
+    ssqrt3 = 1.0E+00 / sqrt ( 3.0E+00 )
+    xhold = ssqrt3 * ( x(1,1) + x(1,2) )
+    x(1,2) = ssqrt3 * ( x(1,1) - x(1,2) )
+    x(1,1) = xhold
+    return
+  end if
+
+  np1 = n + 1
+  ns2 = n / 2
+
+  do k = 1, ns2
+    kc = np1 - k
+    t1 = x(1,k) - x(1,kc)
+    t2 = wsave(k) * ( x(1,k) + x(1,kc) )
+    xh(k+1) = t1 + t2
+    xh(kc+1) = t2 - t1
+  end do
+
+  modn = mod ( n, 2 )
+
+  if ( modn /= 0 ) then
+    xh(ns2+2) = 4.0E+00 * x(1,ns2+1)
+  end if
+
+  xh(1) = 0.0E+00
+  lnxh = np1
+  lnsv = np1 + int ( log ( real ( np1, kind = 4 ) ) ) + 4
+  lnwk = np1
+
+  call rfft1f ( np1, 1, xh, lnxh, wsave(ns2+1), lnsv, work, lnwk, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'sintf1', -5 )
+    return
+  end if
+
+  if ( mod ( np1, 2 ) == 0 ) then
+    xh(np1) = xh(np1) + xh(np1)
+  end if
+
+  sfnp1 = 1.0E+00 / real ( np1, kind = 4 )
+  x(1,1) = 0.5E+00 * xh(1)
+  dsum = x(1,1)
+
+  do i = 3, n, 2
+    x(1,i-1) = 0.5E+00 * xh(i)
+    dsum = dsum + 0.5E+00 * xh(i-1)
+    x(1,i) = dsum
+  end do
+
+  if ( modn == 0 ) then
+    x(1,n) = 0.5E+00 * xh(n+1)
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sintmb.F b/wrfv2_fire/external/fftpack/fftpack5/sintmb.F
index d73b78e4..aa0b061d 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sintmb.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sintmb.F
@@ -1,47 +1,147 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sintmb.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINTMB (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-      LOGICAL    XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('SINTMB', 6) 
-        GO TO 100 
-      ELSEIF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINTMB', 8) 
-        GO TO 100 
-      ELSEIF (LENWRK .LT. LOT*(2*N+4)) THEN 
-        IER = 3 
-        CALL XERFFT ('SINTMB', 10) 
-        GO TO 100 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('SINTMB', -1) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-      IW1 = LOT+LOT+1 
-      IW2 = IW1+LOT*(N+1) 
-      CALL MSNTB1(LOT,JUMP,N,INC,X,WSAVE,WORK,WORK(IW1),WORK(IW2),IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINTMB',-5) 
-      ENDIF 
-!                                                                       
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine sintmb ( lot, jump, n, inc, x, lenx, wsave, lensav, &
+  work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! SINTMB: real single precision backward sine transform, multiple vectors.
+!
+!  Discussion:
+!
+!    SINTMB computes the one-dimensional Fourier transform of multiple
+!    odd sequences within a real array.  This transform is referred to as
+!    the backward transform or Fourier synthesis, transforming the
+!    sequences from spectral to physical space.
+!
+!    This transform is normalized since a call to SINTMB followed
+!    by a call to SINTMF (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    02 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed
+!    within the array R.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations, in
+!    array R, of the first elements of two consecutive sequences.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N+1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array R, of two consecutive elements within the same sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), containing LOT sequences, each
+!    having length N.  R can have any number of dimensions, but the total
+!    number of locations must be at least LENR.  On input, R contains the data
+!    to be transformed, and on output, the transformed data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to SINTMI before the first call to routine SINTMF
+!    or SINTMB for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to SINTMF and SINTMB with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least LOT*(2*N+4).
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC,JUMP,N,LOT are not consistent;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) iw2
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+  logical              xercon
+
+  ier = 0
+
+  if ( lenx < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'SINMTB', 6 )
+    return
+  end if
+
+  if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'SINMTB', 8 )
+    return
+  end if
+
+  if ( lenwrk < lot * ( 2 * n + 4 ) ) then
+    ier = 3
+    call xerfft ( 'SINMTB', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'SINMTB', -1 )
+    return
+  end if
+
+  iw1 = lot + lot + 1
+  iw2 = iw1 + lot * ( n + 1 )
+
+  call msntb1 ( lot, jump, n, inc, x, wsave, work, work(iw1), work(iw2), ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'SINMTB', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sintmf.F b/wrfv2_fire/external/fftpack/fftpack5/sintmf.F
index 64e820f0..740ee2fc 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sintmf.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sintmf.F
@@ -1,46 +1,147 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sintmf.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINTMF (LOT, JUMP, N, INC, X, LENX, WSAVE, LENSAV,     &
-     &                   WORK, LENWRK, IER)                             
-      INTEGER    LOT, JUMP, N, INC, LENX, LENSAV, LENWRK, IER 
-      REAL       X(INC,*), WSAVE(LENSAV), WORK(LENWRK) 
-      LOGICAL    XERCON 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENX .LT. (LOT-1)*JUMP + INC*(N-1) + 1) THEN 
-        IER = 1 
-        CALL XERFFT ('SINTMF', 6) 
-        GO TO 100 
-      ELSEIF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINTMF', 8) 
-        GO TO 100 
-      ELSEIF (LENWRK .LT. LOT*(2*N+4)) THEN 
-        IER = 3 
-        CALL XERFFT ('SINTMF', 10) 
-        GO TO 100 
-      ELSEIF (.NOT. XERCON(INC,JUMP,N,LOT)) THEN 
-        IER = 4 
-        CALL XERFFT ('SINTMF', -1) 
-        GO TO 100 
-      ENDIF 
-!                                                                       
-      IW1 = LOT+LOT+1 
-      IW2 = IW1+LOT*(N+1) 
-      CALL MSNTF1(LOT,JUMP,N,INC,X,WSAVE,WORK,WORK(IW1),WORK(IW2),IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINTMF',-5) 
-      ENDIF 
-  100 CONTINUE 
-      RETURN 
-      END                                           
+subroutine sintmf ( lot, jump, n, inc, x, lenx, wsave, lensav, &
+  work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! SINTMF: real single precision forward sine transform, multiple vectors.
+!
+!  Discussion:
+!
+!    SINTMF computes the one-dimensional Fourier transform of multiple
+!    odd sequences within a real array.  This transform is referred to as
+!    the forward transform or Fourier analysis, transforming the sequences
+!    from physical to spectral space.
+!
+!    This transform is normalized since a call to SINTMF followed
+!    by a call to SINTMB (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    02 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be
+!    transformed within.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations,
+!    in array R, of the first elements of two consecutive sequences.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N+1 is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array R, of two consecutive elements within the same sequence.
+!
+!    Input/output, real ( kind = 4 ) R(LENR), containing LOT sequences, each
+!    having length N.  R can have any number of dimensions, but the total
+!    number of locations must be at least LENR.  On input, R contains the data
+!    to be transformed, and on output, the transformed data.
+!
+!    Input, integer ( kind = 4 ) LENR, the dimension of the R array.
+!    LENR must be at least (LOT-1)*JUMP + INC*(N-1)+ 1.
+!
+!    Input, real ( kind = 4 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to SINTMI before the first call to routine SINTMF
+!    or SINTMB for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to SINTMF and SINTMB with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 4 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least LOT*(2*N+4).
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENR   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC,JUMP,N,LOT are not consistent;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) iw2
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lenx
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  real ( kind = 4 ) work(lenwrk)
+  real ( kind = 4 ) wsave(lensav)
+  real ( kind = 4 ) x(inc,*)
+  logical              xercon
+
+  ier = 0
+
+  if ( lenx < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'sintmf', 6 )
+    return
+  end if
+
+  if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'sintmf', 8 )
+    return
+  end if
+
+  if ( lenwrk < lot * ( 2 * n + 4 ) ) then
+    ier = 3
+    call xerfft ( 'sintmf', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'sintmf', -1 )
+    return
+  end if
+
+  iw1 = lot + lot + 1
+  iw2 = iw1 + lot * ( n + 1 )
+
+  call msntf1 ( lot, jump, n, inc, x, wsave, work,work(iw1), work(iw2), ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'sintmf', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/sintmi.F b/wrfv2_fire/external/fftpack/fftpack5/sintmi.F
index 6f2d67dd..0e0f45f1 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/sintmi.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/sintmi.F
@@ -1,40 +1,108 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: sintmi.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE SINTMI (N, WSAVE, LENSAV, IER) 
-      INTEGER    N, LENSAV, IER 
-      REAL       WSAVE(LENSAV) 
-!                                                                       
-      IER = 0 
-!                                                                       
-      IF (LENSAV .LT. N/2 + N + INT(LOG(REAL(N))) +4) THEN 
-        IER = 2 
-        CALL XERFFT ('SINTMI', 3) 
-        GO TO 300 
-      ENDIF 
-!                                                                       
-      PI = 4.*ATAN(1.) 
-      IF (N .LE. 1) RETURN 
-      NS2 = N/2 
-      NP1 = N+1 
-      DT = PI/FLOAT(NP1) 
-      DO 101 K=1,NS2 
-         WSAVE(K) = 2.*SIN(K*DT) 
-  101 END DO 
-      LNSV = NP1 + INT(LOG(REAL(NP1))) +4 
-      CALL RFFTMI (NP1, WSAVE(NS2+1), LNSV, IER1) 
-      IF (IER1 .NE. 0) THEN 
-        IER = 20 
-        CALL XERFFT ('SINTMI',-5) 
-      ENDIF 
-!                                                                       
-  300 CONTINUE 
-      RETURN 
-      END                                           
+subroutine sintmi ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! SINTMI: initialization for SINTMB and SINTMF.
+!
+!  Discussion:
+!
+!    SINTMI initializes array WSAVE for use in its companion routines
+!    SINTMF and SINTMB.  The prime factorization of N together with a
+!    tabulation of the trigonometric functions are computed and stored
+!    in array WSAVE.  Separate WSAVE arrays are required for different
+!    values of N.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    02 April 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least N/2 + N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 4 ) WSAVE(LENSAV), containing the prime factors
+!    of N and also containing certain trigonometric values which will be used
+!    in routines SINTMB or SINTMF.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  real ( kind = 4 ) dt
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lnsv
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) np1
+  integer ( kind = 4 ) ns2
+  real ( kind = 4 ) pi
+  real ( kind = 4 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < n / 2 + n + int ( log ( real ( n, kind = 4 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'sintmi', 3 )
+    return
+  end if
+
+  pi = 4.0E+00 * atan ( 1.0E+00 )
+
+  if ( n <= 1 ) then
+    return
+  end if
+
+  ns2 = n / 2
+  np1 = n + 1
+  dt = pi / real ( np1, kind = 4 )
+
+  do k = 1, ns2
+    wsave(k) = 2.0E+00 * sin ( real ( k, kind = 4 ) * dt )
+  end do
+
+  lnsv = np1 + int ( log ( real ( np1, kind = 4 ) ) ) + 4
+
+  call rfftmi ( np1, wsave(ns2+1), lnsv, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'sintmi', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/xercon.F b/wrfv2_fire/external/fftpack/fftpack5/xercon.F
index 619ecd1a..60a5992c 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/xercon.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/xercon.F
@@ -1,54 +1,85 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: xercon.f,v 1.2 2004/06/15 21:29:20 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      LOGICAL FUNCTION XERCON (INC,JUMP,N,LOT) 
-      INTEGER INC, JUMP, N, LOT 
-      INTEGER I, J, JNEW, LCM 
-!                                                                       
-!     Definition: positive integers INC, JUMP, N and LOT are consistent 
-!                                                            ---------- 
-!     if I1*INC + J1*JUMP = I2*INC + J2*JUMP for I1,I2 < N and J1,J2    
-!     < LOT implies I1=I2 and J1=J2.                                    
-!                                                                       
-!     For multiple FFTs to execute correctly, input parameters INC,     
-!     JUMP, N and LOT must be consistent ... otherwise at least one     
-!     array element mistakenly is transformed more than once.           
-!                                                                       
-!     XERCON = .TRUE. if and only if INC, JUMP, N and LOT are           
-!     consistent.                                                       
-!                                                                       
-!     ------------------------------------------------------------------
-!                                                                       
-!     Compute I = greatest common divisor (INC, JUMP)                   
-!                                                                       
-      I = INC 
-      J = JUMP 
-   10 CONTINUE 
-      IF (J .NE. 0) THEN 
-        JNEW = MOD(I,J) 
-        I    = J 
-        J    = JNEW 
-        GO TO 10 
-      ENDIF 
-!                                                                       
-! Compute LCM = least common multiple (INC, JUMP)                       
-!                                                                       
-      LCM = (INC*JUMP)/I 
-!                                                                       
-! Check consistency of INC, JUMP, N, LOT                                
-!                                                                       
-      IF (LCM .LE. (N-1)*INC .AND. LCM .LE. (LOT-1)*JUMP) THEN 
-        XERCON = .FALSE. 
-      ELSE 
-        XERCON = .TRUE. 
-      ENDIF 
-!                                                                       
-      RETURN 
-      END                                           
+function xercon ( inc, jump, n, lot )
+
+!*****************************************************************************80
+!
+!! XERCON checks INC, JUMP, N and LOT for consistency.
+!
+!  Discussion:
+!
+!    Positive integers INC, JUMP, N and LOT are "consistent" if,
+!    for any values I1 and I2 < N, and J1 and J2 < LOT,
+!
+!      I1 * INC + J1 * JUMP = I2 * INC + J2 * JUMP
+!
+!    can only occur if I1 = I2 and J1 = J2.
+!
+!    For multiple FFT's to execute correctly, INC, JUMP, N and LOT must
+!    be consistent, or else at least one array element will be
+!    transformed more than once.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    25 March 2005
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) INC, JUMP, N, LOT, the parameters to check.
+!
+!    Output, logical XERCON, is TRUE if the parameters are consistent.
+!
+  implicit none
+
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) jnew
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lcm
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  logical              xercon
+
+  i = inc
+  j = jump
+
+  do while ( j /= 0 )
+    jnew = mod ( i, j )
+    i = j
+    j = jnew
+  end do
+!
+!  LCM = least common multiple of INC and JUMP.
+!
+  lcm = ( inc * jump ) / i
+
+  if ( lcm <= ( n - 1 ) * inc .and. lcm <= ( lot - 1 ) * jump ) then
+    xercon = .false.
+  else
+    xercon = .true.
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/xerfft.F b/wrfv2_fire/external/fftpack/fftpack5/xerfft.F
index 5c958774..9e804aa6 100644
--- a/wrfv2_fire/external/fftpack/fftpack5/xerfft.F
+++ b/wrfv2_fire/external/fftpack/fftpack5/xerfft.F
@@ -1,70 +1,91 @@
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!                                                                       
-!   FFTPACK 5.0                                                         
-!                                                                       
-!   Authors:  Paul N. Swarztrauber and Richard A. Valent                
-!                                                                       
-!   $Id: xerfft.f,v 1.3 2004/07/06 00:58:41 rodney Exp $                
-!                                                                       
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-                                                                        
-      SUBROUTINE XERFFT( SRNAME, INFO) 
-!                                                                       
-!     .. Scalar Arguments ..                                            
-      CHARACTER*6        SRNAME 
-      INTEGER            INFO 
-!                                                                       
-!     ..                                                                
-!                                                                       
-!  Purpose                                                              
-!  =======                                                              
-!                                                                       
-!  XERFFT  is an error handler for library FFTPACK version 5.0 routines.
-!  It is called by an FFTPACK 5.0 routine if an input parameter has an  
-!  invalid value.  A message is printed and execution stops.            
-!                                                                       
-!  Installers may consider modifying the STOP statement in order to     
-!  call system-specific exception-handling facilities.                  
-!                                                                       
-!  Arguments                                                            
-!  =========                                                            
-!                                                                       
-!  SRNAME  (input) CHARACTER*6                                          
-!          The name of the routine which called XERFFT.                 
-!                                                                       
-!  INFO    (input) INTEGER                                              
-!          When a single  invalid parameter in the parameter list of    
-!          the calling routine has been detected, INFO is the position  
-!          of that parameter.  In the case when an illegal combination  
-!          of LOT, JUMP, N, and INC has been detected, the calling      
-!          subprogram calls XERFFT with INFO = -1.                      
-!                                                                       
-! ===================================================================== 
-!                                                                       
-!     .. Executable Statements ..                                       
-!                                                                       
-      IF (INFO .GE. 1) THEN 
-        WRITE( *, '(A,A,A,I3,A)') ' ** On entry to ', SRNAME,           &
-     &    ' parameter number ', INFO, ' had an illegal value'           
-      ELSEIF (INFO .EQ. -1) THEN 
-        WRITE( *, '(A,A,A,A)') ' ** On entry to ', SRNAME,              &
-     &    ' parameters LOT, JUMP, N and INC are inconsistent'           
-      ELSEIF (INFO .EQ. -2) THEN 
-        WRITE( *, '(A,A,A,A)') ' ** On entry to ', SRNAME,              &
-     &    ' parameter L is greater than LDIM'                           
-      ELSEIF (INFO .EQ. -3) THEN 
-        WRITE( *, '(A,A,A,A)') ' ** On entry to ', SRNAME,              &
-     &    ' parameter M is greater than MDIM'                           
-      ELSEIF (INFO .EQ. -5) THEN 
-        WRITE( *, '(A,A,A,A)') ' ** Within ', SRNAME,                   &
-     &    ' input error returned by lower level routine'                
-      ELSEIF (INFO .EQ. -6) THEN 
-        WRITE( *, '(A,A,A,A)') ' ** On entry to ', SRNAME,              &
-     &    ' parameter LDIM is less than 2*(L/2+1)'                      
-      ENDIF 
-!                                                                       
-      STOP 
-!                                                                       
-!     End of XERFFT                                                     
-!                                                                       
-      END                                           
+subroutine xerfft ( srname, info )
+
+!*****************************************************************************80
+!
+!! XERFFT is an error handler for the FFTPACK routines.
+!
+!  Discussion:
+!
+!    XERFFT is an error handler for FFTPACK version 5.0 routines.
+!    It is called by an FFTPACK 5.0 routine if an input parameter has an
+!    invalid value.  A message is printed and execution stops.
+!
+!    Installers may consider modifying the stop statement in order to
+!    call system-specific exception-handling facilities.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!    Copyright (C) 1995-2004, Scientific Computing Division,
+!    University Corporation for Atmospheric Research
+!
+!  Modified:
+!
+!    27 March 2009
+!
+!  Author:
+!
+!    Paul Swarztrauber
+!    Richard Valent
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, character ( len = * ) SRNAME, the name of the calling routine.
+!
+!    Input, integer ( kind = 4 ) INFO, an error code.  When a single invalid
+!    parameter in the parameter list of the calling routine has been detected,
+!    INFO is the position of that parameter.  In the case when an illegal
+!    combination of LOT, JUMP, N, and INC has been detected, the calling
+!    subprogram calls XERFFT with INFO = -1.
+!
+  implicit none
+
+  integer ( kind = 4 ) info
+  character ( len = * ) srname
+  character ( len = 256 ) err_mesg
+
+#if ( VAR4D != 1)
+  call wrf_message ( 'XERFFT - Fatal error!' )
+#else
+  call da_wrf_message ( 'XERFFT - Fatal error!' )
+#endif
+
+  if ( 1 <= info ) then
+    write ( err_mesg , '(a,a,a,i3,a)') '  On entry to ', trim ( srname ), &
+      ' parameter number ', info, ' had an illegal value.'
+  else if ( info == -1 ) then
+    write( err_mesg , '(a,a,a,a)') '  On entry to ', trim ( srname ), &
+      ' parameters LOT, JUMP, N and INC are inconsistent.'
+  else if ( info == -2 ) then
+    write( err_mesg , '(a,a,a,a)') '  On entry to ', trim ( srname ), &
+      ' parameter L is greater than LDIM.'
+  else if ( info == -3 ) then
+    write( err_mesg , '(a,a,a,a)') '  On entry to ', trim ( srname ), &
+      ' parameter M is greater than MDIM.'
+  else if ( info == -5 ) then
+    write( err_mesg , '(a,a,a,a)') '  Within ', trim ( srname ), &
+      ' input error returned by lower level routine.'
+  else if ( info == -6 ) then
+    write( err_mesg , '(a,a,a,a)') '  On entry to ', trim ( srname ), &
+      ' parameter LDIM is less than 2*(L/2+1).'
+  end if
+
+#if ( VAR4D != 1)
+  call wrf_error_fatal ( err_mesg )
+#else
+  call da_wrf_error_fatal ( err_mesg )
+#endif
+
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1f2kb.F b/wrfv2_fire/external/fftpack/fftpack5/z1f2kb.F
new file mode 100644
index 00000000..138b365f
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1f2kb.F
@@ -0,0 +1,92 @@
+subroutine z1f2kb ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! Z1F2KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(in1,l1,ido,2)
+  real ( kind = 8 ) ch(in2,l1,2,ido)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) wa(ido,1,2)
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      ch(1,k,1,1) = cc(1,k,1,1) + cc(1,k,1,2)
+      ch(1,k,2,1) = cc(1,k,1,1) - cc(1,k,1,2)
+      ch(2,k,1,1) = cc(2,k,1,1) + cc(2,k,1,2)
+      ch(2,k,2,1) = cc(2,k,1,1) - cc(2,k,1,2)
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+
+        ch(1,k,1,i) = cc(1,k,i,1) + cc(1,k,i,2)
+        tr2         = cc(1,k,i,1) - cc(1,k,i,2)
+        ch(2,k,1,i) = cc(2,k,i,1) + cc(2,k,i,2)
+        ti2         = cc(2,k,i,1) - cc(2,k,i,2)
+
+        ch(2,k,2,i) = wa(i,1,1) * ti2 + wa(i,1,2) * tr2
+        ch(1,k,2,i) = wa(i,1,1) * tr2 - wa(i,1,2) * ti2
+
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+
+      chold1      = cc(1,k,1,1) + cc(1,k,1,2)
+      cc(1,k,1,2) = cc(1,k,1,1) - cc(1,k,1,2)
+      cc(1,k,1,1) = chold1
+
+      chold2      = cc(2,k,1,1) + cc(2,k,1,2)
+      cc(2,k,1,2) = cc(2,k,1,1) - cc(2,k,1,2)
+      cc(2,k,1,1) = chold2
+
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1f2kf.F b/wrfv2_fire/external/fftpack/fftpack5/z1f2kf.F
new file mode 100644
index 00000000..1e405376
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1f2kf.F
@@ -0,0 +1,103 @@
+subroutine z1f2kf ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! Z1F2KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(in1,l1,ido,2)
+  real ( kind = 8 ) ch(in2,l1,2,ido)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) sn
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) wa(ido,1,2)
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+      ch(1,k,1,1) = cc(1,k,1,1) + cc(1,k,1,2)
+      ch(1,k,2,1) = cc(1,k,1,1) - cc(1,k,1,2)
+      ch(2,k,1,1) = cc(2,k,1,1) + cc(2,k,1,2)
+      ch(2,k,2,1) = cc(2,k,1,1) - cc(2,k,1,2)
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        ch(1,k,1,i) = cc(1,k,i,1) + cc(1,k,i,2)
+        tr2         = cc(1,k,i,1) - cc(1,k,i,2)
+        ch(2,k,1,i) = cc(2,k,i,1) + cc(2,k,i,2)
+        ti2         = cc(2,k,i,1) - cc(2,k,i,2)
+        ch(2,k,2,i) = wa(i,1,1) * ti2 - wa(i,1,2) * tr2
+        ch(1,k,2,i) = wa(i,1,1) * tr2 + wa(i,1,2) * ti2
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0D+00 / real ( 2 * l1, kind = 8 )
+
+    do k = 1, l1
+      ch(1,k,1,1) = sn * ( cc(1,k,1,1) + cc(1,k,1,2) )
+      ch(1,k,2,1) = sn * ( cc(1,k,1,1) - cc(1,k,1,2) )
+      ch(2,k,1,1) = sn * ( cc(2,k,1,1) + cc(2,k,1,2) )
+      ch(2,k,2,1) = sn * ( cc(2,k,1,1) - cc(2,k,1,2) )
+    end do
+
+  else
+
+    sn = 1.0D+00 / real ( 2 * l1, kind = 8 )
+
+    do k = 1, l1
+
+      chold1      = sn * ( cc(1,k,1,1) + cc(1,k,1,2) )
+      cc(1,k,1,2) = sn * ( cc(1,k,1,1) - cc(1,k,1,2) )
+      cc(1,k,1,1) = chold1
+
+      chold2      = sn * ( cc(2,k,1,1) + cc(2,k,1,2) )
+      cc(2,k,1,2) = sn * ( cc(2,k,1,1) - cc(2,k,1,2) )
+      cc(2,k,1,1) = chold2
+
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1f3kb.F b/wrfv2_fire/external/fftpack/fftpack5/z1f3kb.F
new file mode 100644
index 00000000..bcdb5ffa
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1f3kb.F
@@ -0,0 +1,127 @@
+subroutine z1f3kb ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! Z1F3KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(in1,l1,ido,3)
+  real ( kind = 8 ) ch(in2,l1,3,ido)
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) di2
+  real ( kind = 8 ) di3
+  real ( kind = 8 ) dr2
+  real ( kind = 8 ) dr3
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 8 ), parameter :: taui =  0.866025403784439D+00
+  real ( kind = 8 ), parameter :: taur = -0.5D+00
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) wa(ido,2,2)
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+
+      tr2 = cc(1,k,1,2)+cc(1,k,1,3)
+      cr2 = cc(1,k,1,1)+taur*tr2
+      ch(1,k,1,1) = cc(1,k,1,1)+tr2
+      ti2 = cc(2,k,1,2)+cc(2,k,1,3)
+      ci2 = cc(2,k,1,1)+taur*ti2
+      ch(2,k,1,1) = cc(2,k,1,1)+ti2
+      cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3))
+      ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3))
+
+      ch(1,k,2,1) = cr2 - ci3
+      ch(1,k,3,1) = cr2 + ci3
+      ch(2,k,2,1) = ci2 + cr3
+      ch(2,k,3,1) = ci2 - cr3
+
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        tr2 = cc(1,k,i,2)+cc(1,k,i,3)
+        cr2 = cc(1,k,i,1)+taur*tr2
+        ch(1,k,1,i) = cc(1,k,i,1)+tr2
+        ti2 = cc(2,k,i,2)+cc(2,k,i,3)
+        ci2 = cc(2,k,i,1)+taur*ti2
+        ch(2,k,1,i) = cc(2,k,i,1)+ti2
+        cr3 = taui*(cc(1,k,i,2)-cc(1,k,i,3))
+        ci3 = taui*(cc(2,k,i,2)-cc(2,k,i,3))
+
+        dr2 = cr2 - ci3
+        dr3 = cr2 + ci3
+        di2 = ci2 + cr3
+        di3 = ci2 - cr3
+
+        ch(2,k,2,i) = wa(i,1,1) * di2 + wa(i,1,2) * dr2
+        ch(1,k,2,i) = wa(i,1,1) * dr2 - wa(i,1,2) * di2
+        ch(2,k,3,i) = wa(i,2,1) * di3 + wa(i,2,2) * dr3
+        ch(1,k,3,i) = wa(i,2,1) * dr3 - wa(i,2,2) * di3
+
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+
+      tr2 = cc(1,k,1,2)+cc(1,k,1,3)
+      cr2 = cc(1,k,1,1)+taur*tr2
+      cc(1,k,1,1) = cc(1,k,1,1)+tr2
+      ti2 = cc(2,k,1,2)+cc(2,k,1,3)
+      ci2 = cc(2,k,1,1)+taur*ti2
+      cc(2,k,1,1) = cc(2,k,1,1)+ti2
+      cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3))
+      ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3))
+
+      cc(1,k,1,2) = cr2 - ci3
+      cc(1,k,1,3) = cr2 + ci3
+      cc(2,k,1,2) = ci2 + cr3
+      cc(2,k,1,3) = ci2 - cr3
+
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1f3kf.F b/wrfv2_fire/external/fftpack/fftpack5/z1f3kf.F
new file mode 100644
index 00000000..bc1386a1
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1f3kf.F
@@ -0,0 +1,150 @@
+subroutine z1f3kf ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! Z1F3KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(in1,l1,ido,3)
+  real ( kind = 8 ) ch(in2,l1,3,ido)
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) di2
+  real ( kind = 8 ) di3
+  real ( kind = 8 ) dr2
+  real ( kind = 8 ) dr3
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) sn
+  real ( kind = 8 ), parameter :: taui = -0.866025403784439D+00
+  real ( kind = 8 ), parameter :: taur = -0.5D+00
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) wa(ido,2,2)
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+      tr2 = cc(1,k,1,2)+cc(1,k,1,3)
+      cr2 = cc(1,k,1,1)+taur*tr2
+      ch(1,k,1,1) = cc(1,k,1,1)+tr2
+      ti2 = cc(2,k,1,2)+cc(2,k,1,3)
+      ci2 = cc(2,k,1,1)+taur*ti2
+      ch(2,k,1,1) = cc(2,k,1,1)+ti2
+      cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3))
+      ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3))
+
+      ch(1,k,2,1) = cr2 - ci3
+      ch(1,k,3,1) = cr2 + ci3
+      ch(2,k,2,1) = ci2 + cr3
+      ch(2,k,3,1) = ci2 - cr3
+
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+
+        tr2 = cc(1,k,i,2)+cc(1,k,i,3)
+        cr2 = cc(1,k,i,1)+taur*tr2
+        ch(1,k,1,i) = cc(1,k,i,1)+tr2
+        ti2 = cc(2,k,i,2)+cc(2,k,i,3)
+        ci2 = cc(2,k,i,1)+taur*ti2
+        ch(2,k,1,i) = cc(2,k,i,1)+ti2
+        cr3 = taui*(cc(1,k,i,2)-cc(1,k,i,3))
+        ci3 = taui*(cc(2,k,i,2)-cc(2,k,i,3))
+
+        dr2 = cr2 - ci3
+        dr3 = cr2 + ci3
+        di2 = ci2 + cr3
+        di3 = ci2 - cr3
+
+        ch(2,k,2,i) = wa(i,1,1) * di2 - wa(i,1,2) * dr2
+        ch(1,k,2,i) = wa(i,1,1) * dr2 + wa(i,1,2) * di2
+        ch(2,k,3,i) = wa(i,2,1) * di3 - wa(i,2,2) * dr3
+        ch(1,k,3,i) = wa(i,2,1) * dr3 + wa(i,2,2) * di3
+
+       end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0D+00 / real ( 3 * l1, kind = 8 )
+
+    do k = 1, l1
+      tr2 = cc(1,k,1,2)+cc(1,k,1,3)
+      cr2 = cc(1,k,1,1)+taur*tr2
+      ch(1,k,1,1) = sn*(cc(1,k,1,1)+tr2)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,3)
+      ci2 = cc(2,k,1,1)+taur*ti2
+      ch(2,k,1,1) = sn*(cc(2,k,1,1)+ti2)
+      cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3))
+      ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3))
+
+      ch(1,k,2,1) = sn*(cr2-ci3)
+      ch(1,k,3,1) = sn*(cr2+ci3)
+      ch(2,k,2,1) = sn*(ci2+cr3)
+      ch(2,k,3,1) = sn*(ci2-cr3)
+
+    end do
+
+  else
+
+    sn = 1.0D+00 / real ( 3 * l1, kind = 8 )
+
+    do k = 1, l1
+      tr2 = cc(1,k,1,2)+cc(1,k,1,3)
+      cr2 = cc(1,k,1,1)+taur*tr2
+      cc(1,k,1,1) = sn*(cc(1,k,1,1)+tr2)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,3)
+      ci2 = cc(2,k,1,1)+taur*ti2
+      cc(2,k,1,1) = sn*(cc(2,k,1,1)+ti2)
+      cr3 = taui*(cc(1,k,1,2)-cc(1,k,1,3))
+      ci3 = taui*(cc(2,k,1,2)-cc(2,k,1,3))
+
+      cc(1,k,1,2) = sn*(cr2-ci3)
+      cc(1,k,1,3) = sn*(cr2+ci3)
+      cc(2,k,1,2) = sn*(ci2+cr3)
+      cc(2,k,1,3) = sn*(ci2-cr3)
+
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1f4kb.F b/wrfv2_fire/external/fftpack/fftpack5/z1f4kb.F
new file mode 100644
index 00000000..b77a183a
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1f4kb.F
@@ -0,0 +1,136 @@
+subroutine z1f4kb ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! Z1F4KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(in1,l1,ido,4)
+  real ( kind = 8 ) ch(in2,l1,4,ido)
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) ci4
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) cr4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) ti1
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) ti3
+  real ( kind = 8 ) ti4
+  real ( kind = 8 ) tr1
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) tr3
+  real ( kind = 8 ) tr4
+  real ( kind = 8 ) wa(ido,3,2)
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      ti1 = cc(2,k,1,1)-cc(2,k,1,3)
+      ti2 = cc(2,k,1,1)+cc(2,k,1,3)
+      tr4 = cc(2,k,1,4)-cc(2,k,1,2)
+      ti3 = cc(2,k,1,2)+cc(2,k,1,4)
+      tr1 = cc(1,k,1,1)-cc(1,k,1,3)
+      tr2 = cc(1,k,1,1)+cc(1,k,1,3)
+      ti4 = cc(1,k,1,2)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,2)+cc(1,k,1,4)
+      ch(1,k,1,1) = tr2+tr3
+      ch(1,k,3,1) = tr2-tr3
+      ch(2,k,1,1) = ti2+ti3
+      ch(2,k,3,1) = ti2-ti3
+      ch(1,k,2,1) = tr1+tr4
+      ch(1,k,4,1) = tr1-tr4
+      ch(2,k,2,1) = ti1+ti4
+      ch(2,k,4,1) = ti1-ti4
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        ti1 = cc(2,k,i,1)-cc(2,k,i,3)
+        ti2 = cc(2,k,i,1)+cc(2,k,i,3)
+        ti3 = cc(2,k,i,2)+cc(2,k,i,4)
+        tr4 = cc(2,k,i,4)-cc(2,k,i,2)
+        tr1 = cc(1,k,i,1)-cc(1,k,i,3)
+        tr2 = cc(1,k,i,1)+cc(1,k,i,3)
+        ti4 = cc(1,k,i,2)-cc(1,k,i,4)
+        tr3 = cc(1,k,i,2)+cc(1,k,i,4)
+        ch(1,k,1,i) = tr2+tr3
+        cr3 = tr2-tr3
+        ch(2,k,1,i) = ti2+ti3
+        ci3 = ti2-ti3
+        cr2 = tr1+tr4
+        cr4 = tr1-tr4
+        ci2 = ti1+ti4
+        ci4 = ti1-ti4
+
+        ch(1,k,2,i) = wa(i,1,1)*cr2-wa(i,1,2)*ci2
+        ch(2,k,2,i) = wa(i,1,1)*ci2+wa(i,1,2)*cr2
+        ch(1,k,3,i) = wa(i,2,1)*cr3-wa(i,2,2)*ci3
+        ch(2,k,3,i) = wa(i,2,1)*ci3+wa(i,2,2)*cr3
+        ch(1,k,4,i) = wa(i,3,1)*cr4-wa(i,3,2)*ci4
+        ch(2,k,4,i) = wa(i,3,1)*ci4+wa(i,3,2)*cr4
+
+       end do
+    end do
+
+  else
+
+    do k = 1, l1
+       ti1 = cc(2,k,1,1)-cc(2,k,1,3)
+       ti2 = cc(2,k,1,1)+cc(2,k,1,3)
+       tr4 = cc(2,k,1,4)-cc(2,k,1,2)
+       ti3 = cc(2,k,1,2)+cc(2,k,1,4)
+       tr1 = cc(1,k,1,1)-cc(1,k,1,3)
+       tr2 = cc(1,k,1,1)+cc(1,k,1,3)
+       ti4 = cc(1,k,1,2)-cc(1,k,1,4)
+       tr3 = cc(1,k,1,2)+cc(1,k,1,4)
+       cc(1,k,1,1) = tr2+tr3
+       cc(1,k,1,3) = tr2-tr3
+       cc(2,k,1,1) = ti2+ti3
+       cc(2,k,1,3) = ti2-ti3
+       cc(1,k,1,2) = tr1+tr4
+       cc(1,k,1,4) = tr1-tr4
+       cc(2,k,1,2) = ti1+ti4
+       cc(2,k,1,4) = ti1-ti4
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1f4kf.F b/wrfv2_fire/external/fftpack/fftpack5/z1f4kf.F
new file mode 100644
index 00000000..a437dfa3
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1f4kf.F
@@ -0,0 +1,163 @@
+subroutine z1f4kf ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! Z1F4KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(in1,l1,ido,4)
+  real ( kind = 8 ) ch(in2,l1,4,ido)
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) ci4
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) cr4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) sn
+  real ( kind = 8 ) ti1
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) ti3
+  real ( kind = 8 ) ti4
+  real ( kind = 8 ) tr1
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) tr3
+  real ( kind = 8 ) tr4
+  real ( kind = 8 ) wa(ido,3,2)
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+
+      ti1 = cc(2,k,1,1)-cc(2,k,1,3)
+      ti2 = cc(2,k,1,1)+cc(2,k,1,3)
+      tr4 = cc(2,k,1,2)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,2)+cc(2,k,1,4)
+      tr1 = cc(1,k,1,1)-cc(1,k,1,3)
+      tr2 = cc(1,k,1,1)+cc(1,k,1,3)
+      ti4 = cc(1,k,1,4)-cc(1,k,1,2)
+      tr3 = cc(1,k,1,2)+cc(1,k,1,4)
+
+      ch(1,k,1,1) = tr2 + tr3
+      ch(1,k,3,1) = tr2 - tr3
+      ch(2,k,1,1) = ti2 + ti3
+      ch(2,k,3,1) = ti2 - ti3
+      ch(1,k,2,1) = tr1 + tr4
+      ch(1,k,4,1) = tr1 - tr4
+      ch(2,k,2,1) = ti1 + ti4
+      ch(2,k,4,1) = ti1 - ti4
+
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        ti1 = cc(2,k,i,1)-cc(2,k,i,3)
+        ti2 = cc(2,k,i,1)+cc(2,k,i,3)
+        ti3 = cc(2,k,i,2)+cc(2,k,i,4)
+        tr4 = cc(2,k,i,2)-cc(2,k,i,4)
+        tr1 = cc(1,k,i,1)-cc(1,k,i,3)
+        tr2 = cc(1,k,i,1)+cc(1,k,i,3)
+        ti4 = cc(1,k,i,4)-cc(1,k,i,2)
+        tr3 = cc(1,k,i,2)+cc(1,k,i,4)
+        ch(1,k,1,i) = tr2+tr3
+        cr3 = tr2-tr3
+        ch(2,k,1,i) = ti2+ti3
+        ci3 = ti2-ti3
+        cr2 = tr1+tr4
+        cr4 = tr1-tr4
+        ci2 = ti1+ti4
+        ci4 = ti1-ti4
+        ch(1,k,2,i) = wa(i,1,1)*cr2+wa(i,1,2)*ci2
+        ch(2,k,2,i) = wa(i,1,1)*ci2-wa(i,1,2)*cr2
+        ch(1,k,3,i) = wa(i,2,1)*cr3+wa(i,2,2)*ci3
+        ch(2,k,3,i) = wa(i,2,1)*ci3-wa(i,2,2)*cr3
+        ch(1,k,4,i) = wa(i,3,1)*cr4+wa(i,3,2)*ci4
+        ch(2,k,4,i) = wa(i,3,1)*ci4-wa(i,3,2)*cr4
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0D+00 / real ( 4 * l1, kind = 8 )
+
+    do k = 1, l1
+      ti1 = cc(2,k,1,1)-cc(2,k,1,3)
+      ti2 = cc(2,k,1,1)+cc(2,k,1,3)
+      tr4 = cc(2,k,1,2)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,2)+cc(2,k,1,4)
+      tr1 = cc(1,k,1,1)-cc(1,k,1,3)
+      tr2 = cc(1,k,1,1)+cc(1,k,1,3)
+      ti4 = cc(1,k,1,4)-cc(1,k,1,2)
+      tr3 = cc(1,k,1,2)+cc(1,k,1,4)
+      ch(1,k,1,1) = sn*(tr2+tr3)
+      ch(1,k,3,1) = sn*(tr2-tr3)
+      ch(2,k,1,1) = sn*(ti2+ti3)
+      ch(2,k,3,1) = sn*(ti2-ti3)
+      ch(1,k,2,1) = sn*(tr1+tr4)
+      ch(1,k,4,1) = sn*(tr1-tr4)
+      ch(2,k,2,1) = sn*(ti1+ti4)
+      ch(2,k,4,1) = sn*(ti1-ti4)
+    end do
+
+  else
+
+    sn = 1.0D+00 / real ( 4 * l1, kind = 8 )
+
+    do k = 1, l1
+      ti1 = cc(2,k,1,1)-cc(2,k,1,3)
+      ti2 = cc(2,k,1,1)+cc(2,k,1,3)
+      tr4 = cc(2,k,1,2)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,2)+cc(2,k,1,4)
+      tr1 = cc(1,k,1,1)-cc(1,k,1,3)
+      tr2 = cc(1,k,1,1)+cc(1,k,1,3)
+      ti4 = cc(1,k,1,4)-cc(1,k,1,2)
+      tr3 = cc(1,k,1,2)+cc(1,k,1,4)
+      cc(1,k,1,1) = sn*(tr2+tr3)
+      cc(1,k,1,3) = sn*(tr2-tr3)
+      cc(2,k,1,1) = sn*(ti2+ti3)
+      cc(2,k,1,3) = sn*(ti2-ti3)
+      cc(1,k,1,2) = sn*(tr1+tr4)
+      cc(1,k,1,4) = sn*(tr1-tr4)
+      cc(2,k,1,2) = sn*(ti1+ti4)
+      cc(2,k,1,4) = sn*(ti1-ti4)
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1f5kb.F b/wrfv2_fire/external/fftpack/fftpack5/z1f5kb.F
new file mode 100644
index 00000000..a200d363
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1f5kb.F
@@ -0,0 +1,184 @@
+subroutine z1f5kb ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! Z1F5KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(in1,l1,ido,5)
+  real ( kind = 8 ) ch(in2,l1,5,ido)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) ci4
+  real ( kind = 8 ) ci5
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) cr4
+  real ( kind = 8 ) cr5
+  real ( kind = 8 ) di2
+  real ( kind = 8 ) di3
+  real ( kind = 8 ) di4
+  real ( kind = 8 ) di5
+  real ( kind = 8 ) dr2
+  real ( kind = 8 ) dr3
+  real ( kind = 8 ) dr4
+  real ( kind = 8 ) dr5
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) ti3
+  real ( kind = 8 ) ti4
+  real ( kind = 8 ) ti5
+  real ( kind = 8 ), parameter :: ti11 =  0.9510565162951536D+00
+  real ( kind = 8 ), parameter :: ti12 =  0.5877852522924731D+00
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) tr3
+  real ( kind = 8 ) tr4
+  real ( kind = 8 ) tr5
+  real ( kind = 8 ), parameter :: tr11 =  0.3090169943749474D+00
+  real ( kind = 8 ), parameter :: tr12 = -0.8090169943749474D+00
+  real ( kind = 8 ) wa(ido,4,2)
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      ti5 = cc(2,k,1,2)-cc(2,k,1,5)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,5)
+      ti4 = cc(2,k,1,3)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,3)+cc(2,k,1,4)
+      tr5 = cc(1,k,1,2)-cc(1,k,1,5)
+      tr2 = cc(1,k,1,2)+cc(1,k,1,5)
+      tr4 = cc(1,k,1,3)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,3)+cc(1,k,1,4)
+      ch(1,k,1,1) = cc(1,k,1,1)+tr2+tr3
+      ch(2,k,1,1) = cc(2,k,1,1)+ti2+ti3
+      cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3
+      ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3
+      cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3
+      ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3
+      cr5 = ti11*tr5+ti12*tr4
+      ci5 = ti11*ti5+ti12*ti4
+      cr4 = ti12*tr5-ti11*tr4
+      ci4 = ti12*ti5-ti11*ti4
+      ch(1,k,2,1) = cr2-ci5
+      ch(1,k,5,1) = cr2+ci5
+      ch(2,k,2,1) = ci2+cr5
+      ch(2,k,3,1) = ci3+cr4
+      ch(1,k,3,1) = cr3-ci4
+      ch(1,k,4,1) = cr3+ci4
+      ch(2,k,4,1) = ci3-cr4
+      ch(2,k,5,1) = ci2-cr5
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        ti5 = cc(2,k,i,2)-cc(2,k,i,5)
+        ti2 = cc(2,k,i,2)+cc(2,k,i,5)
+        ti4 = cc(2,k,i,3)-cc(2,k,i,4)
+        ti3 = cc(2,k,i,3)+cc(2,k,i,4)
+        tr5 = cc(1,k,i,2)-cc(1,k,i,5)
+        tr2 = cc(1,k,i,2)+cc(1,k,i,5)
+        tr4 = cc(1,k,i,3)-cc(1,k,i,4)
+        tr3 = cc(1,k,i,3)+cc(1,k,i,4)
+        ch(1,k,1,i) = cc(1,k,i,1)+tr2+tr3
+        ch(2,k,1,i) = cc(2,k,i,1)+ti2+ti3
+        cr2 = cc(1,k,i,1)+tr11*tr2+tr12*tr3
+        ci2 = cc(2,k,i,1)+tr11*ti2+tr12*ti3
+        cr3 = cc(1,k,i,1)+tr12*tr2+tr11*tr3
+        ci3 = cc(2,k,i,1)+tr12*ti2+tr11*ti3
+        cr5 = ti11*tr5+ti12*tr4
+        ci5 = ti11*ti5+ti12*ti4
+        cr4 = ti12*tr5-ti11*tr4
+        ci4 = ti12*ti5-ti11*ti4
+        dr3 = cr3-ci4
+        dr4 = cr3+ci4
+        di3 = ci3+cr4
+        di4 = ci3-cr4
+        dr5 = cr2+ci5
+        dr2 = cr2-ci5
+        di5 = ci2-cr5
+        di2 = ci2+cr5
+        ch(1,k,2,i) = wa(i,1,1)*dr2-wa(i,1,2)*di2
+        ch(2,k,2,i) = wa(i,1,1)*di2+wa(i,1,2)*dr2
+        ch(1,k,3,i) = wa(i,2,1)*dr3-wa(i,2,2)*di3
+        ch(2,k,3,i) = wa(i,2,1)*di3+wa(i,2,2)*dr3
+        ch(1,k,4,i) = wa(i,3,1)*dr4-wa(i,3,2)*di4
+        ch(2,k,4,i) = wa(i,3,1)*di4+wa(i,3,2)*dr4
+        ch(1,k,5,i) = wa(i,4,1)*dr5-wa(i,4,2)*di5
+        ch(2,k,5,i) = wa(i,4,1)*di5+wa(i,4,2)*dr5
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      ti5 = cc(2,k,1,2)-cc(2,k,1,5)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,5)
+      ti4 = cc(2,k,1,3)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,3)+cc(2,k,1,4)
+      tr5 = cc(1,k,1,2)-cc(1,k,1,5)
+      tr2 = cc(1,k,1,2)+cc(1,k,1,5)
+      tr4 = cc(1,k,1,3)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,3)+cc(1,k,1,4)
+      chold1 = cc(1,k,1,1)+tr2+tr3
+      chold2 = cc(2,k,1,1)+ti2+ti3
+      cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3
+      ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3
+      cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3
+      ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3
+      cc(1,k,1,1) = chold1
+      cc(2,k,1,1) = chold2
+      cr5 = ti11*tr5+ti12*tr4
+      ci5 = ti11*ti5+ti12*ti4
+      cr4 = ti12*tr5-ti11*tr4
+      ci4 = ti12*ti5-ti11*ti4
+      cc(1,k,1,2) = cr2-ci5
+      cc(1,k,1,5) = cr2+ci5
+      cc(2,k,1,2) = ci2+cr5
+      cc(2,k,1,3) = ci3+cr4
+      cc(1,k,1,3) = cr3-ci4
+      cc(1,k,1,4) = cr3+ci4
+      cc(2,k,1,4) = ci3-cr4
+      cc(2,k,1,5) = ci2-cr5
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1f5kf.F b/wrfv2_fire/external/fftpack/fftpack5/z1f5kf.F
new file mode 100644
index 00000000..f0424638
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1f5kf.F
@@ -0,0 +1,236 @@
+subroutine z1f5kf ( ido, l1, na, cc, in1, ch, in2, wa )
+
+!*****************************************************************************80
+!
+!! Z1F5KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(in1,l1,ido,5)
+  real ( kind = 8 ) ch(in2,l1,5,ido)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) ci4
+  real ( kind = 8 ) ci5
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) cr4
+  real ( kind = 8 ) cr5
+  real ( kind = 8 ) di2
+  real ( kind = 8 ) di3
+  real ( kind = 8 ) di4
+  real ( kind = 8 ) di5
+  real ( kind = 8 ) dr2
+  real ( kind = 8 ) dr3
+  real ( kind = 8 ) dr4
+  real ( kind = 8 ) dr5
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) sn
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) ti3
+  real ( kind = 8 ) ti4
+  real ( kind = 8 ) ti5
+  real ( kind = 8 ), parameter :: ti11 = -0.9510565162951536D+00
+  real ( kind = 8 ), parameter :: ti12 = -0.5877852522924731D+00
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) tr3
+  real ( kind = 8 ) tr4
+  real ( kind = 8 ) tr5
+  real ( kind = 8 ), parameter :: tr11 =  0.3090169943749474D+00
+  real ( kind = 8 ), parameter :: tr12 = -0.8090169943749474D+00
+  real ( kind = 8 ) wa(ido,4,2)
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+
+      ti5 = cc(2,k,1,2)-cc(2,k,1,5)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,5)
+      ti4 = cc(2,k,1,3)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,3)+cc(2,k,1,4)
+      tr5 = cc(1,k,1,2)-cc(1,k,1,5)
+      tr2 = cc(1,k,1,2)+cc(1,k,1,5)
+      tr4 = cc(1,k,1,3)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,3)+cc(1,k,1,4)
+
+      ch(1,k,1,1) = cc(1,k,1,1)+tr2+tr3
+      ch(2,k,1,1) = cc(2,k,1,1)+ti2+ti3
+      cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3
+      ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3
+      cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3
+      ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3
+      cr5 = ti11*tr5+ti12*tr4
+      ci5 = ti11*ti5+ti12*ti4
+      cr4 = ti12*tr5-ti11*tr4
+      ci4 = ti12*ti5-ti11*ti4
+      ch(1,k,2,1) = cr2-ci5
+      ch(1,k,5,1) = cr2+ci5
+      ch(2,k,2,1) = ci2+cr5
+      ch(2,k,3,1) = ci3+cr4
+      ch(1,k,3,1) = cr3-ci4
+      ch(1,k,4,1) = cr3+ci4
+      ch(2,k,4,1) = ci3-cr4
+      ch(2,k,5,1) = ci2-cr5
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+
+        ti5 = cc(2,k,i,2)-cc(2,k,i,5)
+        ti2 = cc(2,k,i,2)+cc(2,k,i,5)
+        ti4 = cc(2,k,i,3)-cc(2,k,i,4)
+        ti3 = cc(2,k,i,3)+cc(2,k,i,4)
+        tr5 = cc(1,k,i,2)-cc(1,k,i,5)
+        tr2 = cc(1,k,i,2)+cc(1,k,i,5)
+        tr4 = cc(1,k,i,3)-cc(1,k,i,4)
+        tr3 = cc(1,k,i,3)+cc(1,k,i,4)
+
+        ch(1,k,1,i) = cc(1,k,i,1)+tr2+tr3
+        ch(2,k,1,i) = cc(2,k,i,1)+ti2+ti3
+        cr2 = cc(1,k,i,1)+tr11*tr2+tr12*tr3
+        ci2 = cc(2,k,i,1)+tr11*ti2+tr12*ti3
+        cr3 = cc(1,k,i,1)+tr12*tr2+tr11*tr3
+        ci3 = cc(2,k,i,1)+tr12*ti2+tr11*ti3
+        cr5 = ti11*tr5+ti12*tr4
+        ci5 = ti11*ti5+ti12*ti4
+        cr4 = ti12*tr5-ti11*tr4
+        ci4 = ti12*ti5-ti11*ti4
+        dr3 = cr3-ci4
+        dr4 = cr3+ci4
+        di3 = ci3+cr4
+        di4 = ci3-cr4
+        dr5 = cr2+ci5
+        dr2 = cr2-ci5
+        di5 = ci2-cr5
+        di2 = ci2+cr5
+        ch(1,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2
+        ch(2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2
+        ch(1,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3
+        ch(2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3
+        ch(1,k,4,i) = wa(i,3,1)*dr4+wa(i,3,2)*di4
+        ch(2,k,4,i) = wa(i,3,1)*di4-wa(i,3,2)*dr4
+        ch(1,k,5,i) = wa(i,4,1)*dr5+wa(i,4,2)*di5
+        ch(2,k,5,i) = wa(i,4,1)*di5-wa(i,4,2)*dr5
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0D+00 / real ( 5 * l1, kind = 8 )
+
+    do k = 1, l1
+
+      ti5 = cc(2,k,1,2)-cc(2,k,1,5)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,5)
+      ti4 = cc(2,k,1,3)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,3)+cc(2,k,1,4)
+      tr5 = cc(1,k,1,2)-cc(1,k,1,5)
+      tr2 = cc(1,k,1,2)+cc(1,k,1,5)
+      tr4 = cc(1,k,1,3)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,3)+cc(1,k,1,4)
+
+      ch(1,k,1,1) = sn*(cc(1,k,1,1)+tr2+tr3)
+      ch(2,k,1,1) = sn*(cc(2,k,1,1)+ti2+ti3)
+
+      cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3
+      ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3
+      cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3
+      ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3
+      cr5 = ti11*tr5+ti12*tr4
+      ci5 = ti11*ti5+ti12*ti4
+      cr4 = ti12*tr5-ti11*tr4
+      ci4 = ti12*ti5-ti11*ti4
+
+      ch(1,k,2,1) = sn*(cr2-ci5)
+      ch(1,k,5,1) = sn*(cr2+ci5)
+      ch(2,k,2,1) = sn*(ci2+cr5)
+      ch(2,k,3,1) = sn*(ci3+cr4)
+      ch(1,k,3,1) = sn*(cr3-ci4)
+      ch(1,k,4,1) = sn*(cr3+ci4)
+      ch(2,k,4,1) = sn*(ci3-cr4)
+      ch(2,k,5,1) = sn*(ci2-cr5)
+
+    end do
+
+  else
+
+    sn = 1.0D+00 / real ( 5 * l1, kind = 8 )
+
+    do k = 1, l1
+
+      ti5 = cc(2,k,1,2)-cc(2,k,1,5)
+      ti2 = cc(2,k,1,2)+cc(2,k,1,5)
+      ti4 = cc(2,k,1,3)-cc(2,k,1,4)
+      ti3 = cc(2,k,1,3)+cc(2,k,1,4)
+      tr5 = cc(1,k,1,2)-cc(1,k,1,5)
+      tr2 = cc(1,k,1,2)+cc(1,k,1,5)
+      tr4 = cc(1,k,1,3)-cc(1,k,1,4)
+      tr3 = cc(1,k,1,3)+cc(1,k,1,4)
+
+      chold1 = sn*(cc(1,k,1,1)+tr2+tr3)
+      chold2 = sn*(cc(2,k,1,1)+ti2+ti3)
+
+      cr2 = cc(1,k,1,1)+tr11*tr2+tr12*tr3
+      ci2 = cc(2,k,1,1)+tr11*ti2+tr12*ti3
+      cr3 = cc(1,k,1,1)+tr12*tr2+tr11*tr3
+      ci3 = cc(2,k,1,1)+tr12*ti2+tr11*ti3
+
+      cc(1,k,1,1) = chold1
+      cc(2,k,1,1) = chold2
+
+      cr5 = ti11*tr5+ti12*tr4
+      ci5 = ti11*ti5+ti12*ti4
+      cr4 = ti12*tr5-ti11*tr4
+      ci4 = ti12*ti5-ti11*ti4
+
+      cc(1,k,1,2) = sn*(cr2-ci5)
+      cc(1,k,1,5) = sn*(cr2+ci5)
+      cc(2,k,1,2) = sn*(ci2+cr5)
+      cc(2,k,1,3) = sn*(ci3+cr4)
+      cc(1,k,1,3) = sn*(cr3-ci4)
+      cc(1,k,1,4) = sn*(cr3+ci4)
+      cc(2,k,1,4) = sn*(ci3-cr4)
+      cc(2,k,1,5) = sn*(ci2-cr5)
+
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1fgkb.F b/wrfv2_fire/external/fftpack/fftpack5/z1fgkb.F
new file mode 100644
index 00000000..ef085033
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1fgkb.F
@@ -0,0 +1,176 @@
+subroutine z1fgkb ( ido, ip, l1, lid, na, cc, cc1, in1, ch, ch1, in2, wa )
+
+!*****************************************************************************80
+!
+!! Z1FGKB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) lid
+
+  real ( kind = 8 ) cc(in1,l1,ip,ido)
+  real ( kind = 8 ) cc1(in1,lid,ip)
+  real ( kind = 8 ) ch(in2,l1,ido,ip)
+  real ( kind = 8 ) ch1(in2,lid,ip)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) idlj
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) ki
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) wa(ido,ip-1,2)
+  real ( kind = 8 ) wai
+  real ( kind = 8 ) war
+
+  ipp2 = ip + 2
+  ipph = ( ip + 1 ) / 2
+  do ki = 1, lid
+    ch1(1,ki,1) = cc1(1,ki,1)
+    ch1(2,ki,1) = cc1(2,ki,1)
+  end do
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do ki = 1, lid
+      ch1(1,ki,j) =  cc1(1,ki,j) + cc1(1,ki,jc)
+      ch1(1,ki,jc) = cc1(1,ki,j) - cc1(1,ki,jc)
+      ch1(2,ki,j) =  cc1(2,ki,j) + cc1(2,ki,jc)
+      ch1(2,ki,jc) = cc1(2,ki,j) - cc1(2,ki,jc)
+    end do
+  end do
+
+  do j = 2, ipph
+    do ki = 1, lid
+      cc1(1,ki,1) = cc1(1,ki,1)+ch1(1,ki,j)
+      cc1(2,ki,1) = cc1(2,ki,1)+ch1(2,ki,j)
+    end do
+  end do
+
+  do l = 2, ipph
+
+     lc = ipp2 - l
+     do ki = 1, lid
+       cc1(1,ki,l) = ch1(1,ki,1)+wa(1,l-1,1)*ch1(1,ki,2)
+       cc1(1,ki,lc) = wa(1,l-1,2)*ch1(1,ki,ip)
+       cc1(2,ki,l) = ch1(2,ki,1)+wa(1,l-1,1)*ch1(2,ki,2)
+       cc1(2,ki,lc) = wa(1,l-1,2)*ch1(2,ki,ip)
+     end do
+
+     do j = 3, ipph
+       jc = ipp2 - j
+       idlj = mod ( ( l - 1 ) * ( j - 1 ), ip )
+       war = wa(1,idlj,1)
+       wai = wa(1,idlj,2)
+       do ki = 1, lid
+         cc1(1,ki,l) = cc1(1,ki,l)+war*ch1(1,ki,j)
+         cc1(1,ki,lc) = cc1(1,ki,lc)+wai*ch1(1,ki,jc)
+         cc1(2,ki,l) = cc1(2,ki,l)+war*ch1(2,ki,j)
+         cc1(2,ki,lc) = cc1(2,ki,lc)+wai*ch1(2,ki,jc)
+       end do
+     end do
+
+  end do
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do ki = 1, lid
+      ch1(1,ki,1) = cc1(1,ki,1)
+      ch1(2,ki,1) = cc1(2,ki,1)
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        ch1(1,ki,j) = cc1(1,ki,j)-cc1(2,ki,jc)
+        ch1(1,ki,jc) = cc1(1,ki,j)+cc1(2,ki,jc)
+        ch1(2,ki,jc) = cc1(2,ki,j)-cc1(1,ki,jc)
+        ch1(2,ki,j) = cc1(2,ki,j)+cc1(1,ki,jc)
+      end do
+    end do
+
+    if ( ido == 1 ) then
+      return
+    end if
+
+    do i = 1, ido
+      do k = 1, l1
+        cc(1,k,1,i) = ch(1,k,i,1)
+        cc(2,k,1,i) = ch(2,k,i,1)
+      end do
+    end do
+
+    do j = 2, ip
+      do k = 1, l1
+        cc(1,k,j,1) = ch(1,k,1,j)
+        cc(2,k,j,1) = ch(2,k,1,j)
+      end do
+    end do
+
+    do j = 2, ip
+      do i = 2, ido
+        do k = 1, l1
+          cc(1,k,j,i) = wa(i,j-1,1)*ch(1,k,i,j) &
+                       -wa(i,j-1,2)*ch(2,k,i,j)
+          cc(2,k,j,i) = wa(i,j-1,1)*ch(2,k,i,j) &
+                       +wa(i,j-1,2)*ch(1,k,i,j)
+        end do
+      end do
+    end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        chold1 = cc1(1,ki,j)-cc1(2,ki,jc)
+        chold2 = cc1(1,ki,j)+cc1(2,ki,jc)
+        cc1(1,ki,j) = chold1
+        cc1(2,ki,jc) = cc1(2,ki,j)-cc1(1,ki,jc)
+        cc1(2,ki,j) = cc1(2,ki,j)+cc1(1,ki,jc)
+        cc1(1,ki,jc) = chold2
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1fgkf.F b/wrfv2_fire/external/fftpack/fftpack5/z1fgkf.F
new file mode 100644
index 00000000..da391526
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1fgkf.F
@@ -0,0 +1,202 @@
+subroutine z1fgkf ( ido, ip, l1, lid, na, cc, cc1, in1, ch, ch1, in2, wa )
+
+!*****************************************************************************80
+!
+!! Z1FGKF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) lid
+
+  real ( kind = 8 ) cc(in1,l1,ip,ido)
+  real ( kind = 8 ) cc1(in1,lid,ip)
+  real ( kind = 8 ) ch(in2,l1,ido,ip)
+  real ( kind = 8 ) ch1(in2,lid,ip)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) idlj
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) ki
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) sn
+  real ( kind = 8 ) wa(ido,ip-1,2)
+  real ( kind = 8 ) wai
+  real ( kind = 8 ) war
+
+  ipp2 = ip+2
+  ipph = (ip+1)/2
+
+  do ki = 1, lid
+    ch1(1,ki,1) = cc1(1,ki,1)
+    ch1(2,ki,1) = cc1(2,ki,1)
+  end do
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do ki = 1, lid
+      ch1(1,ki,j) =  cc1(1,ki,j)+cc1(1,ki,jc)
+      ch1(1,ki,jc) = cc1(1,ki,j)-cc1(1,ki,jc)
+      ch1(2,ki,j) =  cc1(2,ki,j)+cc1(2,ki,jc)
+      ch1(2,ki,jc) = cc1(2,ki,j)-cc1(2,ki,jc)
+    end do
+  end do
+
+  do j = 2, ipph
+    do ki = 1, lid
+      cc1(1,ki,1) = cc1(1,ki,1) + ch1(1,ki,j)
+      cc1(2,ki,1) = cc1(2,ki,1) + ch1(2,ki,j)
+    end do
+  end do
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+
+    do ki = 1, lid
+      cc1(1,ki,l)  = ch1(1,ki,1) + wa(1,l-1,1) * ch1(1,ki,2)
+      cc1(1,ki,lc) =             - wa(1,l-1,2) * ch1(1,ki,ip)
+      cc1(2,ki,l)  = ch1(2,ki,1) + wa(1,l-1,1) * ch1(2,ki,2)
+      cc1(2,ki,lc) =             - wa(1,l-1,2) * ch1(2,ki,ip)
+    end do
+
+    do j = 3, ipph
+
+      jc = ipp2 - j
+      idlj = mod ( ( l - 1 ) * ( j - 1 ), ip )
+      war = wa(1,idlj,1)
+      wai = -wa(1,idlj,2)
+
+      do ki = 1, lid
+        cc1(1,ki,l) = cc1(1,ki,l)+war*ch1(1,ki,j)
+        cc1(1,ki,lc) = cc1(1,ki,lc)+wai*ch1(1,ki,jc)
+        cc1(2,ki,l) = cc1(2,ki,l)+war*ch1(2,ki,j)
+        cc1(2,ki,lc) = cc1(2,ki,lc)+wai*ch1(2,ki,jc)
+      end do
+
+    end do
+
+  end do
+
+  if ( 1 < ido ) then
+
+    do ki = 1, lid
+      ch1(1,ki,1) = cc1(1,ki,1)
+      ch1(2,ki,1) = cc1(2,ki,1)
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        ch1(1,ki,j) = cc1(1,ki,j)-cc1(2,ki,jc)
+        ch1(2,ki,j) = cc1(2,ki,j)+cc1(1,ki,jc)
+        ch1(1,ki,jc) = cc1(1,ki,j)+cc1(2,ki,jc)
+        ch1(2,ki,jc) = cc1(2,ki,j)-cc1(1,ki,jc)
+      end do
+    end do
+
+    do i = 1, ido
+      do k = 1, l1
+        cc(1,k,1,i) = ch(1,k,i,1)
+        cc(2,k,1,i) = ch(2,k,i,1)
+      end do
+    end do
+
+    do j = 2, ip
+      do k = 1, l1
+        cc(1,k,j,1) = ch(1,k,1,j)
+        cc(2,k,j,1) = ch(2,k,1,j)
+      end do
+    end do
+
+    do j = 2, ip
+      do i = 2, ido
+        do k = 1, l1
+          cc(1,k,j,i) = wa(i,j-1,1)*ch(1,k,i,j) + wa(i,j-1,2)*ch(2,k,i,j)
+          cc(2,k,j,i) = wa(i,j-1,1)*ch(2,k,i,j) - wa(i,j-1,2)*ch(1,k,i,j)
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0D+00 / real ( ip * l1, kind = 8 )
+
+    do ki = 1, lid
+      ch1(1,ki,1) = sn * cc1(1,ki,1)
+      ch1(2,ki,1) = sn * cc1(2,ki,1)
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        ch1(1,ki,j) = sn*(cc1(1,ki,j)-cc1(2,ki,jc))
+        ch1(2,ki,j) = sn*(cc1(2,ki,j)+cc1(1,ki,jc))
+        ch1(1,ki,jc) = sn*(cc1(1,ki,j)+cc1(2,ki,jc))
+        ch1(2,ki,jc) = sn*(cc1(2,ki,j)-cc1(1,ki,jc))
+      end do
+    end do
+
+  else
+
+    sn = 1.0D+00 / real ( ip * l1, kind = 8 )
+
+    do ki = 1, lid
+      cc1(1,ki,1) = sn * cc1(1,ki,1)
+      cc1(2,ki,1) = sn * cc1(2,ki,1)
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        chold1 = sn*(cc1(1,ki,j)-cc1(2,ki,jc))
+        chold2 = sn*(cc1(1,ki,j)+cc1(2,ki,jc))
+        cc1(1,ki,j) = chold1
+        cc1(2,ki,jc) = sn*(cc1(2,ki,j)-cc1(1,ki,jc))
+        cc1(2,ki,j) = sn*(cc1(2,ki,j)+cc1(1,ki,jc))
+        cc1(1,ki,jc) = chold2
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1fm1b.F b/wrfv2_fire/external/fftpack/fftpack5/z1fm1b.F
new file mode 100644
index 00000000..d0b5fc1d
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1fm1b.F
@@ -0,0 +1,102 @@
+subroutine z1fm1b ( n, inc, c, ch, wa, fnf, fac )
+
+!*****************************************************************************80
+!
+!! Z1FM1B is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  complex ( kind = 8 ) c(*)
+  real ( kind = 8 ) ch(*)
+  real ( kind = 8 ) fac(*)
+  real ( kind = 8 ) fnf
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) inc2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) lid
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nbr
+  integer ( kind = 4 ) nf
+  real ( kind = 8 ) wa(*)
+
+  inc2 = inc + inc
+  nf = int ( fnf )
+  na = 0
+  l1 = 1
+  iw = 1
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1) )
+    l2 = ip * l1
+    ido = n / l2
+    lid = l1 * ido
+    nbr = 1 + na + 2 * min ( ip - 2, 4 )
+
+    if ( nbr == 1 ) then
+      call z1f2kb ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+    else if ( nbr == 2 ) then
+      call z1f2kb ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+    else if ( nbr == 3 ) then
+      call z1f3kb ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+    else if ( nbr == 4 ) then
+      call z1f3kb ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+    else if ( nbr == 5 ) then
+      call z1f4kb ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+    else if ( nbr == 6 ) then
+      call z1f4kb ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+    else if ( nbr == 7 ) then
+      call z1f5kb ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+    else if ( nbr == 8 ) then
+      call z1f5kb ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+    else if ( nbr == 9 ) then
+      call z1fgkb ( ido, ip, l1, lid, na, c, c, inc2, ch, ch, 2, wa(iw) )
+    else if ( nbr == 10 ) then
+      call z1fgkb ( ido, ip, l1, lid, na, ch, ch, 2, c, c, inc2, wa(iw) )
+    end if
+
+    l1 = l2
+    iw = iw + ( ip - 1 ) * ( ido + ido )
+
+    if ( ip <= 5 ) then
+      na = 1 - na
+    end if
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/z1fm1f.F b/wrfv2_fire/external/fftpack/fftpack5/z1fm1f.F
new file mode 100644
index 00000000..1fb4fd38
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/z1fm1f.F
@@ -0,0 +1,101 @@
+subroutine z1fm1f ( n, inc, c, ch, wa, fnf, fac )
+
+!*****************************************************************************80
+!
+!! Z1FM1F is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  complex ( kind = 8 ) c(*)
+  real ( kind = 8 ) ch(*)
+  real ( kind = 8 ) fac(*)
+  real ( kind = 8 ) fnf
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) inc2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) lid
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nbr
+  integer ( kind = 4 ) nf
+  real ( kind = 8 ) wa(*)
+
+  inc2 = inc + inc
+  nf = int ( fnf )
+  na = 0
+  l1 = 1
+  iw = 1
+
+  do k1 = 1, nf
+
+     ip = int ( fac(k1) )
+     l2 = ip * l1
+     ido = n / l2
+     lid = l1 * ido
+     nbr = 1 + na + 2 * min ( ip - 2, 4 )
+
+     if ( nbr == 1 ) then
+       call z1f2kf ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+     else if ( nbr == 2 ) then
+       call z1f2kf ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+     else if ( nbr == 3 ) then
+       call z1f3kf ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+     else if ( nbr == 4 ) then
+       call z1f3kf ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+     else if ( nbr == 5 ) then
+       call z1f4kf ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+     else if ( nbr == 6 ) then
+       call z1f4kf ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+     else if ( nbr == 7 ) then
+       call z1f5kf ( ido, l1, na, c, inc2, ch, 2, wa(iw) )
+     else if ( nbr == 8 ) then
+       call z1f5kf ( ido, l1, na, ch, 2, c, inc2, wa(iw) )
+     else if ( nbr == 9 ) then
+       call z1fgkf ( ido, ip, l1, lid, na, c, c, inc2, ch, ch, 1, wa(iw) )
+     else if ( nbr == 10 ) then
+       call z1fgkf ( ido, ip, l1, lid, na, ch, ch, 2, c, c, inc2, wa(iw) )
+     end if
+
+     l1 = l2
+     iw = iw + ( ip - 1 ) * ( ido + ido )
+
+     if ( ip <= 5 ) then
+       na = 1 - na
+     end if
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zfft1b.F b/wrfv2_fire/external/fftpack/fftpack5/zfft1b.F
new file mode 100644
index 00000000..fda539d6
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zfft1b.F
@@ -0,0 +1,121 @@
+subroutine zfft1b ( n, inc, c, lenc, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! ZFFT1B: complex double precision backward fast Fourier transform, 1D.
+!
+!  Discussion:
+!
+!    ZFFT1B computes the one-dimensional Fourier transform of a single
+!    periodic sequence within a complex array.  This transform is referred
+!    to as the backward transform or Fourier synthesis, transforming the
+!    sequence from spectral to physical space.
+!
+!    This transform is normalized since a call to ZFFT1B followed
+!    by a call to ZFFT1F (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array C, of two consecutive elements within the sequence to be transformed.
+!
+!    Input/output, complex ( kind = 8 ) C(LENC) containing the sequence to
+!    be transformed.
+!
+!    Input, integer ( kind = 4 ) LENC, the dimension of the C array.
+!    LENC must be at least INC*(N-1) + 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to ZFFT1I before the first call to routine ZFFT1F
+!    or ZFFT1B for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to ZFFT1F and ZFFT1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENC not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 8 ) c(lenc)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lenc < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'ZFFT1B', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'ZFFT1B', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * n ) then
+    ier = 3
+    call xerfft ( 'ZFFT1B', 10 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+
+  call z1fm1b ( n, inc, c, work, wsave, wsave(iw1), wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zfft1f.F b/wrfv2_fire/external/fftpack/fftpack5/zfft1f.F
new file mode 100644
index 00000000..d038bf36
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zfft1f.F
@@ -0,0 +1,121 @@
+subroutine zfft1f ( n, inc, c, lenc, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! ZFFT1F: complex double precision forward fast Fourier transform, 1D.
+!
+!  Discussion:
+!
+!    ZFFT1F computes the one-dimensional Fourier transform of a single
+!    periodic sequence within a complex array.  This transform is referred
+!    to as the forward transform or Fourier analysis, transforming the
+!    sequence from physical to spectral space.
+!
+!    This transform is normalized since a call to ZFFT1F followed
+!    by a call to ZFFT1B (or vice-versa) reproduces the original
+!    array within roundoff error.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array C, of two consecutive elements within the sequence to be transformed.
+!
+!    Input/output, complex ( kind = 8 ) C(LENC) containing the sequence to
+!    be transformed.
+!
+!    Input, integer ( kind = 4 ) LENC, the dimension of the C array.
+!    LENC must be at least INC*(N-1) + 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to ZFFT1I before the first call to routine ZFFT1F
+!    or ZFFT1B for a given transform length N.  WSAVE's contents may be re-used
+!    for subsequent calls to ZFFT1F and ZFFT1B with the same N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    1, input parameter LENC   not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 8 ) c(lenc)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lenc < inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'ZFFT1F', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'ZFFT1F', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * n ) then
+    ier = 3
+    call xerfft ( 'ZFFT1F', 10 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+
+  call z1fm1f ( n, inc, c, work, wsave, wsave(iw1), wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zfft1i.F b/wrfv2_fire/external/fftpack/fftpack5/zfft1i.F
new file mode 100644
index 00000000..f47813fd
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zfft1i.F
@@ -0,0 +1,82 @@
+subroutine zfft1i ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! ZFFT1I: initialization for ZFFT1B and ZFFT1F.
+!
+!  Discussion:
+!
+!    ZFFT1I initializes array WSAVE for use in its companion routines
+!    ZFFT1B and ZFFT1F.  Routine ZFFT1I must be called before the first
+!    call to ZFFT1B or ZFFT1F, and after whenever the value of integer
+!    N changes.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of the sequence to be
+!    transformed.  The transform is most efficient when N is a product
+!    of small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors
+!    of N and  also containing certain trigonometric values which will be used
+!    in routines ZFFT1B or ZFFT1F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough.
+
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'ZFFT1I', 3 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+
+  call r8_mcfti1 ( n, wsave, wsave(iw1), wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zfft2b.F b/wrfv2_fire/external/fftpack/fftpack5/zfft2b.F
new file mode 100644
index 00000000..b9073087
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zfft2b.F
@@ -0,0 +1,147 @@
+subroutine zfft2b ( ldim, l, m, c, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! ZFFT2B: complex double precision backward fast Fourier transform, 2D.
+!
+!  Discussion:
+!
+!    ZFFT2B computes the two-dimensional discrete Fourier transform of a
+!    complex periodic array.  This transform is known as the backward
+!    transform or Fourier synthesis, transforming from spectral to
+!    physical space.  Routine ZFFT2B is normalized, in that a call to
+!    ZFFT2B followed by a call to ZFFT2F (or vice-versa) reproduces the
+!    original array within roundoff error.
+!
+!    On 10 May 2010, this code was modified by changing the value
+!    of an index into the WSAVE array.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    10 May 2010
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LDIM, the first dimension of C.
+!
+!    Input, integer ( kind = 4 ) L, the number of elements to be transformed
+!    in the first dimension of the two-dimensional complex array C.  The value
+!    of L must be less than or equal to that of LDIM.  The transform is
+!    most efficient when L is a product of small primes.
+!
+!    Input, integer ( kind = 4 ) M, the number of elements to be transformed
+!    in the second dimension of the two-dimensional complex array C.  The
+!    transform is most efficient when M is a product of small primes.
+!
+!    Input/output, complex ( kind = 8 ) C(LDIM,M), on intput, the array of two
+!    dimensions containing the (L,M) subarray to be transformed.  On output,
+!    the transformed data.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be
+!    initialized with a call to ZFFT2I before the first call to routine ZFFT2F
+!    or ZFFT2B with transform lengths L and M.  WSAVE's contents may be
+!    re-used for subsequent calls to ZFFT2F and ZFFT2B with the same
+!    transform lengths L and M.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*(L+M) + INT(LOG(REAL(L)))
+!    + INT(LOG(REAL(M))) + 8.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*L*M.
+!
+!    Output, integer ( kind = 4 ) IER, the error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    5, input parameter LDIM < L;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) ldim
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 8 ) c(ldim,m)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) l
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( ldim < l ) then
+    ier = 5
+    call xerfft ( 'ZFFT2B', -2 )
+    return
+  end if
+
+  if ( lensav < 2 * l + int ( log ( real ( l, kind = 8 ) ) ) + &
+                2 * m + int ( log ( real ( m, kind = 8 ) ) ) + 8 ) then
+    ier = 2
+    call xerfft ( 'ZFFT2B', 6 )
+    return
+  end if
+
+  if ( lenwrk < 2 * l * m ) then
+    ier = 3
+    call xerfft ( 'ZFFT2B', 8 )
+    return
+  end if
+!
+!  Transform the X lines of the C array.
+!
+!  On 10 May 2010, the value of IW was modified.
+!
+  iw = 2 * l + int ( log ( real ( l, kind = 8 ) ) ) + 5
+
+  call zfftmb ( l, 1, m, ldim, c, (l-1)+ldim*(m-1) +1, &
+    wsave(iw), 2*m + int(log(real ( m, kind = 8 ))) + 4, work, 2*l*m, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'ZFFT2B', -5 )
+    return
+  end if
+!
+!  Transform the Y lines of the C array.
+!
+  iw = 1
+  call zfftmb ( m, ldim, l, 1, c, (m-1)*ldim + l, wsave(iw), &
+    2*l + int(log(real ( l, kind = 8 ))) + 4, work, 2*m*l, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'ZFFT2B', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zfft2f.F b/wrfv2_fire/external/fftpack/fftpack5/zfft2f.F
new file mode 100644
index 00000000..f93302f9
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zfft2f.F
@@ -0,0 +1,148 @@
+subroutine zfft2f ( ldim, l, m, c, wsave, lensav, work, lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! ZFFT2F: complex double precision forward fast Fourier transform, 2D.
+!
+!  Discussion:
+!
+!    ZFFT2F computes the two-dimensional discrete Fourier transform of
+!    a complex periodic array. This transform is known as the forward
+!    transform or Fourier analysis, transforming from physical to
+!    spectral space. Routine ZFFT2F is normalized, in that a call to
+!    ZFFT2F followed by a call to ZFFT2B (or vice-versa) reproduces the
+!    original array within roundoff error.
+!
+!    On 10 May 2010, this code was modified by changing the value
+!    of an index into the WSAVE array.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    10 May 2010
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LDIM, the first dimension of the array C.
+!
+!    Input, integer ( kind = 4 ) L, the number of elements to be transformed
+!    in the first dimension of the two-dimensional complex array C.  The value
+!    of L must be less than or equal to that of LDIM.  The transform is most
+!    efficient when L is a product of small primes.
+!
+!    Input, integer ( kind = 4 ) M, the number of elements to be transformed
+!    in the second dimension of the two-dimensional complex array C.  The
+!    transform is most efficient when M is a product of small primes.
+!
+!    Input/output, complex ( kind = 8 ) C(LDIM,M), on input, the array of two
+!    dimensions containing the (L,M) subarray to be transformed.  On output,
+!    the transformed data.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV). WSAVE's contents must be
+!    initialized with a call to ZFFT2I before the first call to routine ZFFT2F
+!    or ZFFT2B with transform lengths L and M.  WSAVE's contents may be re-used
+!    for subsequent calls to ZFFT2F and ZFFT2B having those same
+!    transform lengths.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*(L+M) + INT(LOG(REAL(L)))
+!    + INT(LOG(REAL(M))) + 8.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*L*M.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    5, input parameter LDIM < L;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) m
+  integer ( kind = 4 ) ldim
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 8 ) c(ldim,m)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) l
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( ldim < l ) then
+    ier = 5
+    call xerfft ( 'ZFFT2F', -2 )
+    return
+  end if
+
+  if ( lensav < 2 * l + int ( log ( real ( l, kind = 8 ) ) ) + &
+                2 * m + int ( log ( real ( m, kind = 8 ) ) ) + 8 ) then
+    ier = 2
+    call xerfft ( 'ZFFT2F', 6 )
+    return
+  end if
+
+  if ( lenwrk < 2 * l * m ) then
+    ier = 3
+    call xerfft ( 'ZFFT2F', 8 )
+    return
+  end if
+!
+!  Transform the X lines of the C array.
+!
+!  On 10 May 2010, the value of IW was modified.
+!
+  iw = 2 * l + int ( log ( real ( l, kind = 8 ) ) ) + 5
+
+  call zfftmf ( l, 1, m, ldim, c, (l-1) + ldim*(m-1) +1, wsave(iw), &
+    2*m + int(log(real ( m, kind = 8 ))) + 4, work, 2*l*m, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'ZFFT2F', -5 )
+    return
+  end if
+!
+!  Transform the Y lines of the C array.
+!
+  iw = 1
+
+  call zfftmf ( m, ldim, l, 1, c, (m-1)*ldim + l, wsave(iw), &
+    2*l + int(log(real ( l, kind = 8 ))) + 4, work, 2*m*l, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'ZFFT2F', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zfft2i.F b/wrfv2_fire/external/fftpack/fftpack5/zfft2i.F
new file mode 100644
index 00000000..6621d96d
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zfft2i.F
@@ -0,0 +1,107 @@
+subroutine zfft2i ( l, m, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! ZFFT2I: initialization for ZFFT2B and ZFFT2F.
+!
+!  Discussion:
+!
+!    ZFFT2I initializes real array WSAVE for use in its companion
+!    routines ZFFT2F and ZFFT2B for computing two-dimensional fast
+!    Fourier transforms of complex data.  Prime factorizations of L and M,
+!    together with tabulations of the trigonometric functions, are
+!    computed and stored in array WSAVE.
+!
+!    On 10 May 2010, this code was modified by changing the value
+!    of an index into the WSAVE array.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) L, the number of elements to be transformed
+!    in the first dimension.  The transform is most efficient when L is a
+!    product of small primes.
+!
+!    Input, integer ( kind = 4 ) M, the number of elements to be transformed
+!    in the second dimension.  The transform is most efficient when M is a
+!    product of small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*(L+M) + INT(LOG(REAL(L)))
+!    + INT(LOG(REAL(M))) + 8.
+!
+!    Output, real ( kind = 8 ) WSAVE(LENSAV), contains the prime factors of L
+!    and M, and also certain trigonometric values which will be used in
+!    routines ZFFT2B or ZFFT2F.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough;
+!    20, input error returned by lower level routine.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) ier1
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) m
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * l + int ( log ( real ( l, kind = 8 ) ) ) + &
+                2 * m + int ( log ( real ( m, kind = 8 ) ) ) + 8 ) then
+    ier = 2
+    call xerfft ( 'ZFFT2I', 4 )
+    return
+  end if
+
+  call zfftmi ( l, wsave(1), 2*l + int(log(real ( l, kind = 8 ))) + 4, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'ZFFT2I', -5 )
+    return
+  end if
+!
+!  On 10 May 2010, the value of IW was modified.
+!
+  iw = 2 * l + int ( log ( real ( l, kind = 8 ) ) ) + 5
+
+  call zfftmi ( m, wsave(iw), 2*m + int(log(real ( m, kind = 8 ))) + 4, ier1 )
+
+  if ( ier1 /= 0 ) then
+    ier = 20
+    call xerfft ( 'ZFFT2I', -5 )
+    return
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zfftmb.F b/wrfv2_fire/external/fftpack/fftpack5/zfftmb.F
new file mode 100644
index 00000000..47109945
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zfftmb.F
@@ -0,0 +1,145 @@
+subroutine zfftmb ( lot, jump, n, inc, c, lenc, wsave, lensav, work, &
+  lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! ZFFTMB: complex double precision backward FFT, 1D, multiple vectors.
+!
+!  Discussion:
+!
+!    ZFFTMB computes the one-dimensional Fourier transform of multiple
+!    periodic sequences within a complex array.  This transform is referred
+!    to as the backward transform or Fourier synthesis, transforming the
+!    sequences from spectral to physical space.  This transform is
+!    normalized since a call to ZFFTMF followed by a call to ZFFTMB (or
+!    vice-versa) reproduces the original array within roundoff error.
+!
+!    The parameters INC, JUMP, N and LOT are consistent if equality
+!    I1*INC + J1*JUMP = I2*INC + J2*JUMP for I1,I2 < N and J1,J2 < LOT
+!    implies I1=I2 and J1=J2.  For multiple FFTs to execute correctly,
+!    input variables INC, JUMP, N and LOT must be consistent, otherwise
+!    at least one array element mistakenly is transformed more than once.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be transformed
+!    within array C.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations, in
+!    array C, of the first elements of two consecutive sequences to
+!    be transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array C, of two consecutive elements within the same sequence to be
+!    transformed.
+!
+!    Input/output, complex ( kind = 8 ) C(LENC), an array containing LOT
+!    sequences, each having length N, to be transformed.  C can have any
+!    number of dimensions, but the total number of locations must be at least
+!    LENC.  On output, C contains the transformed sequences.
+!
+!    Input, integer ( kind = 4 ) LENC, the dimension of the C array.
+!    LENC must be at least (LOT-1)*JUMP + INC*(N-1) + 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to ZFFTMI before the first call to routine ZFFTMF
+!    or ZFFTMB for a given transform length N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*LOT*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit
+!    1, input parameter LENC not big enough;
+!    2, input parameter LENSAV not big enough;
+!    3, input parameter LENWRK not big enough;
+!    4, input parameters INC, JUMP, N, LOT are not consistent.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 8 ) c(lenc)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+  logical              xercon
+
+  ier = 0
+
+  if ( lenc < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'ZFFTMB', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'ZFFTMB', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * lot * n ) then
+    ier = 3
+    call xerfft ( 'ZFFTMB', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'ZFFTMB', -1 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+
+  call zmfm1b ( lot, jump, n, inc, c, work, wsave, wsave(iw1), &
+    wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zfftmf.F b/wrfv2_fire/external/fftpack/fftpack5/zfftmf.F
new file mode 100644
index 00000000..c2c0a023
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zfftmf.F
@@ -0,0 +1,144 @@
+subroutine zfftmf ( lot, jump, n, inc, c, lenc, wsave, lensav, work, &
+  lenwrk, ier )
+
+!*****************************************************************************80
+!
+!! ZFFTMF: complex double precision forward FFT, 1D, multiple vectors.
+!
+!  Discussion:
+!
+!    ZFFTMF computes the one-dimensional Fourier transform of multiple
+!    periodic sequences within a complex array. This transform is referred
+!    to as the forward transform or Fourier analysis, transforming the
+!    sequences from physical to spectral space. This transform is
+!    normalized since a call to ZFFTMF followed by a call to ZFFTMB
+!    (or vice-versa) reproduces the original array within roundoff error.
+!
+!    The parameters integers INC, JUMP, N and LOT are consistent if equality
+!    I1*INC + J1*JUMP = I2*INC + J2*JUMP for I1,I2 < N and J1,J2 < LOT
+!    implies I1=I2 and J1=J2. For multiple FFTs to execute correctly,
+!    input variables INC, JUMP, N and LOT must be consistent, otherwise
+!    at least one array element mistakenly is transformed more than once.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) LOT, the number of sequences to be
+!    transformed within array C.
+!
+!    Input, integer ( kind = 4 ) JUMP, the increment between the locations,
+!    in array C, of the first elements of two consecutive sequences to be
+!    transformed.
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) INC, the increment between the locations, in
+!    array C, of two consecutive elements within the same sequence to be
+!    transformed.
+!
+!    Input/output, complex ( kind = 8 ) C(LENC), array containing LOT sequences,
+!    each having length N, to be transformed.  C can have any number of
+!    dimensions, but the total number of locations must be at least LENC.
+!
+!    Input, integer ( kind = 4 ) LENC, the dimension of the C array.
+!    LENC must be at least (LOT-1)*JUMP + INC*(N-1) + 1.
+!
+!    Input, real ( kind = 8 ) WSAVE(LENSAV).  WSAVE's contents must be
+!    initialized with a call to ZFFTMI before the first call to routine ZFFTMF
+!    or ZFFTMB for a given transform length N.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Workspace, real ( kind = 8 ) WORK(LENWRK).
+!
+!    Input, integer ( kind = 4 ) LENWRK, the dimension of the WORK array.
+!    LENWRK must be at least 2*LOT*N.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0 successful exit;
+!    1 input parameter LENC not big enough;
+!    2 input parameter LENSAV not big enough;
+!    3 input parameter LENWRK not big enough;
+!    4 input parameters INC, JUMP, N, LOT are not consistent.
+!
+  implicit none
+
+  integer ( kind = 4 ) lenc
+  integer ( kind = 4 ) lensav
+  integer ( kind = 4 ) lenwrk
+
+  complex ( kind = 8 ) c(lenc)
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) work(lenwrk)
+  real ( kind = 8 ) wsave(lensav)
+  logical              xercon
+
+  ier = 0
+
+  if ( lenc < ( lot - 1 ) * jump + inc * ( n - 1 ) + 1 ) then
+    ier = 1
+    call xerfft ( 'ZFFTMF', 6 )
+    return
+  end if
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'ZFFTMF', 8 )
+    return
+  end if
+
+  if ( lenwrk < 2 * lot * n ) then
+    ier = 3
+    call xerfft ( 'ZFFTMF', 10 )
+    return
+  end if
+
+  if ( .not. xercon ( inc, jump, n, lot ) ) then
+    ier = 4
+    call xerfft ( 'ZFFTMF', -1 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+
+  call zmfm1f ( lot, jump, n, inc, c, work, wsave, wsave(iw1), &
+    wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zfftmi.F b/wrfv2_fire/external/fftpack/fftpack5/zfftmi.F
new file mode 100644
index 00000000..8ee9c016
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zfftmi.F
@@ -0,0 +1,80 @@
+subroutine zfftmi ( n, wsave, lensav, ier )
+
+!*****************************************************************************80
+!
+!! ZFFTMI: initialization for ZFFTMB and ZFFTMF.
+!
+!  Discussion:
+!
+!    ZFFTMI initializes array WSAVE for use in its companion routines
+!    ZFFTMB and ZFFTMF.  ZFFTMI must be called before the first call
+!    to ZFFTMB or ZFFTMF, and after whenever the value of integer N changes.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+!    Input, integer ( kind = 4 ) N, the length of each sequence to be
+!    transformed.  The transform is most efficient when N is a product of
+!    small primes.
+!
+!    Input, integer ( kind = 4 ) LENSAV, the dimension of the WSAVE array.
+!    LENSAV must be at least 2*N + INT(LOG(REAL(N))) + 4.
+!
+!    Output, real ( kind = 8 ) WSAVE(LENSAV), containing the prime factors
+!    of N and also containing certain trigonometric values which will be used in
+!    routines ZFFTMB or ZFFTMF.
+!
+!    Output, integer ( kind = 4 ) IER, error flag.
+!    0, successful exit;
+!    2, input parameter LENSAV not big enough.
+!
+  implicit none
+
+  integer ( kind = 4 ) lensav
+
+  integer ( kind = 4 ) ier
+  integer ( kind = 4 ) iw1
+  integer ( kind = 4 ) n
+  real ( kind = 8 ) wsave(lensav)
+
+  ier = 0
+
+  if ( lensav < 2 * n + int ( log ( real ( n, kind = 8 ) ) ) + 4 ) then
+    ier = 2
+    call xerfft ( 'cfftmi ', 3 )
+    return
+  end if
+
+  if ( n == 1 ) then
+    return
+  end if
+
+  iw1 = n + n + 1
+  call r8_mcfti1 ( n, wsave, wsave(iw1), wsave(iw1+1) )
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmf2kb.F b/wrfv2_fire/external/fftpack/fftpack5/zmf2kb.F
new file mode 100644
index 00000000..b0c0149b
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmf2kb.F
@@ -0,0 +1,111 @@
+subroutine zmf2kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! ZMF2KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(2,in1,l1,ido,2)
+  real ( kind = 8 ) ch(2,in2,l1,2,ido)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) wa(ido,1,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1) + cc(1,m1,k,1,2)
+        ch(1,m2,k,2,1) = cc(1,m1,k,1,1) - cc(1,m1,k,1,2)
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1) + cc(2,m1,k,1,2)
+        ch(2,m2,k,2,1) = cc(2,m1,k,1,1) - cc(2,m1,k,1,2)
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+cc(1,m1,k,i,2)
+          tr2 = cc(1,m1,k,i,1)-cc(1,m1,k,i,2)
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+cc(2,m1,k,i,2)
+          ti2 = cc(2,m1,k,i,1)-cc(2,m1,k,i,2)
+
+          ch(2,m2,k,2,i) = wa(i,1,1) * ti2 + wa(i,1,2) * tr2
+          ch(1,m2,k,2,i) = wa(i,1,1) * tr2 - wa(i,1,2) * ti2
+
+        end do
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+
+        chold1         = cc(1,m1,k,1,1) + cc(1,m1,k,1,2)
+        cc(1,m1,k,1,2) = cc(1,m1,k,1,1) - cc(1,m1,k,1,2)
+        cc(1,m1,k,1,1) = chold1
+
+        chold2         = cc(2,m1,k,1,1) + cc(2,m1,k,1,2)
+        cc(2,m1,k,1,2) = cc(2,m1,k,1,1) - cc(2,m1,k,1,2)
+        cc(2,m1,k,1,1) = chold2
+
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmf2kf.F b/wrfv2_fire/external/fftpack/fftpack5/zmf2kf.F
new file mode 100644
index 00000000..af463c75
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmf2kf.F
@@ -0,0 +1,129 @@
+subroutine zmf2kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! ZMF2KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(2,in1,l1,ido,2)
+  real ( kind = 8 ) ch(2,in2,l1,2,ido)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lid
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) sn
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) wa(ido,1,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+cc(1,m1,k,1,2)
+        ch(1,m2,k,2,1) = cc(1,m1,k,1,1)-cc(1,m1,k,1,2)
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+cc(2,m1,k,1,2)
+        ch(2,m2,k,2,1) = cc(2,m1,k,1,1)-cc(2,m1,k,1,2)
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+cc(1,m1,k,i,2)
+          tr2 = cc(1,m1,k,i,1)-cc(1,m1,k,i,2)
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+cc(2,m1,k,i,2)
+          ti2 = cc(2,m1,k,i,1)-cc(2,m1,k,i,2)
+          ch(2,m2,k,2,i) = wa(i,1,1)*ti2-wa(i,1,2)*tr2
+          ch(1,m2,k,2,i) = wa(i,1,1)*tr2+wa(i,1,2)*ti2
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0D+00 / real ( 2 * l1, kind = 8 )
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch(1,m2,k,1,1) = sn * ( cc(1,m1,k,1,1) + cc(1,m1,k,1,2) )
+        ch(1,m2,k,2,1) = sn * ( cc(1,m1,k,1,1) - cc(1,m1,k,1,2) )
+        ch(2,m2,k,1,1) = sn * ( cc(2,m1,k,1,1) + cc(2,m1,k,1,2) )
+        ch(2,m2,k,2,1) = sn * ( cc(2,m1,k,1,1) - cc(2,m1,k,1,2) )
+      end do
+    end do
+
+  else
+
+    sn = 1.0D+00 / real ( 2 * l1, kind = 8 )
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+
+        chold1         = sn * ( cc(1,m1,k,1,1) + cc(1,m1,k,1,2) )
+        cc(1,m1,k,1,2) = sn * ( cc(1,m1,k,1,1) - cc(1,m1,k,1,2) )
+        cc(1,m1,k,1,1) = chold1
+
+        chold2         = sn * ( cc(2,m1,k,1,1) + cc(2,m1,k,1,2) )
+        cc(2,m1,k,1,2) = sn * ( cc(2,m1,k,1,1) - cc(2,m1,k,1,2) )
+        cc(2,m1,k,1,1) = chold2
+
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmf3kb.F b/wrfv2_fire/external/fftpack/fftpack5/zmf3kb.F
new file mode 100644
index 00000000..843d94a1
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmf3kb.F
@@ -0,0 +1,143 @@
+subroutine zmf3kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! ZMF3KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(2,in1,l1,ido,3)
+  real ( kind = 8 ) ch(2,in2,l1,3,ido)
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) di2
+  real ( kind = 8 ) di3
+  real ( kind = 8 ) dr2
+  real ( kind = 8 ) dr3
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 8 ), parameter :: taui =  0.866025403784439D+00
+  real ( kind = 8 ), parameter :: taur = -0.5D+00
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) wa(ido,2,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido .or. na == 1 ) then
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+
+        m2 = m2 + im2
+
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
+        cr2 = cc(1,m1,k,1,1)+taur*tr2
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2
+
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
+        ci2 = cc(2,m1,k,1,1)+taur*ti2
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2
+
+        cr3 = taui * (cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
+        ci3 = taui * (cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
+
+        ch(1,m2,k,2,1) = cr2-ci3
+        ch(1,m2,k,3,1) = cr2+ci3
+        ch(2,m2,k,2,1) = ci2+cr3
+        ch(2,m2,k,3,1) = ci2-cr3
+
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,3)
+          cr2 = cc(1,m1,k,i,1)+taur*tr2
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2
+          ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,3)
+          ci2 = cc(2,m1,k,i,1)+taur*ti2
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2
+          cr3 = taui*(cc(1,m1,k,i,2)-cc(1,m1,k,i,3))
+          ci3 = taui*(cc(2,m1,k,i,2)-cc(2,m1,k,i,3))
+          dr2 = cr2-ci3
+          dr3 = cr2+ci3
+          di2 = ci2+cr3
+          di3 = ci2-cr3
+          ch(2,m2,k,2,i) = wa(i,1,1)*di2+wa(i,1,2)*dr2
+          ch(1,m2,k,2,i) = wa(i,1,1)*dr2-wa(i,1,2)*di2
+          ch(2,m2,k,3,i) = wa(i,2,1)*di3+wa(i,2,2)*dr3
+          ch(1,m2,k,3,i) = wa(i,2,1)*dr3-wa(i,2,2)*di3
+        end do
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
+        cr2 = cc(1,m1,k,1,1)+taur*tr2
+        cc(1,m1,k,1,1) = cc(1,m1,k,1,1)+tr2
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
+        ci2 = cc(2,m1,k,1,1)+taur*ti2
+        cc(2,m1,k,1,1) = cc(2,m1,k,1,1)+ti2
+        cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
+        ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
+        cc(1,m1,k,1,2) = cr2-ci3
+        cc(1,m1,k,1,3) = cr2+ci3
+        cc(2,m1,k,1,2) = ci2+cr3
+        cc(2,m1,k,1,3) = ci2-cr3
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmf3kf.F b/wrfv2_fire/external/fftpack/fftpack5/zmf3kf.F
new file mode 100644
index 00000000..efeb66ab
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmf3kf.F
@@ -0,0 +1,164 @@
+subroutine zmf3kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! ZMF3KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(2,in1,l1,ido,3)
+  real ( kind = 8 ) ch(2,in2,l1,3,ido)
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) di2
+  real ( kind = 8 ) di3
+  real ( kind = 8 ) dr2
+  real ( kind = 8 ) dr3
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) sn
+  real ( kind = 8 ), parameter :: taui = -0.866025403784439D+00
+  real ( kind = 8 ), parameter :: taur = -0.5D+00
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) wa(ido,2,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
+        cr2 = cc(1,m1,k,1,1)+taur*tr2
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
+        ci2 = cc(2,m1,k,1,1)+taur*ti2
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2
+        cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
+        ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
+        ch(1,m2,k,2,1) = cr2-ci3
+        ch(1,m2,k,3,1) = cr2+ci3
+        ch(2,m2,k,2,1) = ci2+cr3
+        ch(2,m2,k,3,1) = ci2-cr3
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,3)
+          cr2 = cc(1,m1,k,i,1)+taur*tr2
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2
+          ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,3)
+          ci2 = cc(2,m1,k,i,1)+taur*ti2
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2
+          cr3 = taui*(cc(1,m1,k,i,2)-cc(1,m1,k,i,3))
+          ci3 = taui*(cc(2,m1,k,i,2)-cc(2,m1,k,i,3))
+          dr2 = cr2-ci3
+          dr3 = cr2+ci3
+          di2 = ci2+cr3
+          di3 = ci2-cr3
+          ch(2,m2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2
+          ch(1,m2,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2
+          ch(2,m2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3
+          ch(1,m2,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0D+00 / real ( 3 * l1, kind = 8 )
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
+        cr2 = cc(1,m1,k,1,1)+taur*tr2
+        ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
+        ci2 = cc(2,m1,k,1,1)+taur*ti2
+        ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2)
+        cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
+        ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
+        ch(1,m2,k,2,1) = sn*(cr2-ci3)
+        ch(1,m2,k,3,1) = sn*(cr2+ci3)
+        ch(2,m2,k,2,1) = sn*(ci2+cr3)
+        ch(2,m2,k,3,1) = sn*(ci2-cr3)
+      end do
+    end do
+
+  else
+
+    sn = 1.0D+00 / real ( 3 * l1, kind = 8 )
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,3)
+        cr2 = cc(1,m1,k,1,1)+taur*tr2
+        cc(1,m1,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,3)
+        ci2 = cc(2,m1,k,1,1)+taur*ti2
+        cc(2,m1,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2)
+        cr3 = taui*(cc(1,m1,k,1,2)-cc(1,m1,k,1,3))
+        ci3 = taui*(cc(2,m1,k,1,2)-cc(2,m1,k,1,3))
+        cc(1,m1,k,1,2) = sn*(cr2-ci3)
+        cc(1,m1,k,1,3) = sn*(cr2+ci3)
+        cc(2,m1,k,1,2) = sn*(ci2+cr3)
+        cc(2,m1,k,1,3) = sn*(ci2-cr3)
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmf4kb.F b/wrfv2_fire/external/fftpack/fftpack5/zmf4kb.F
new file mode 100644
index 00000000..b449302e
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmf4kb.F
@@ -0,0 +1,154 @@
+subroutine zmf4kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! ZMF4KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(2,in1,l1,ido,4)
+  real ( kind = 8 ) ch(2,in2,l1,4,ido)
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) ci4
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) cr4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) ti1
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) ti3
+  real ( kind = 8 ) ti4
+  real ( kind = 8 ) tr1
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) tr3
+  real ( kind = 8 ) tr4
+  real ( kind = 8 ) wa(ido,3,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
+        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
+        tr4 = cc(2,m1,k,1,4)-cc(2,m1,k,1,2)
+        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
+        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
+        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
+        ti4 = cc(1,m1,k,1,2)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = tr2+tr3
+        ch(1,m2,k,3,1) = tr2-tr3
+        ch(2,m2,k,1,1) = ti2+ti3
+        ch(2,m2,k,3,1) = ti2-ti3
+        ch(1,m2,k,2,1) = tr1+tr4
+        ch(1,m2,k,4,1) = tr1-tr4
+        ch(2,m2,k,2,1) = ti1+ti4
+        ch(2,m2,k,4,1) = ti1-ti4
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ti1 = cc(2,m1,k,i,1)-cc(2,m1,k,i,3)
+          ti2 = cc(2,m1,k,i,1)+cc(2,m1,k,i,3)
+          ti3 = cc(2,m1,k,i,2)+cc(2,m1,k,i,4)
+          tr4 = cc(2,m1,k,i,4)-cc(2,m1,k,i,2)
+          tr1 = cc(1,m1,k,i,1)-cc(1,m1,k,i,3)
+          tr2 = cc(1,m1,k,i,1)+cc(1,m1,k,i,3)
+          ti4 = cc(1,m1,k,i,2)-cc(1,m1,k,i,4)
+          tr3 = cc(1,m1,k,i,2)+cc(1,m1,k,i,4)
+          ch(1,m2,k,1,i) = tr2+tr3
+          cr3 = tr2-tr3
+          ch(2,m2,k,1,i) = ti2+ti3
+          ci3 = ti2-ti3
+          cr2 = tr1+tr4
+          cr4 = tr1-tr4
+          ci2 = ti1+ti4
+          ci4 = ti1-ti4
+          ch(1,m2,k,2,i) = wa(i,1,1)*cr2-wa(i,1,2)*ci2
+          ch(2,m2,k,2,i) = wa(i,1,1)*ci2+wa(i,1,2)*cr2
+          ch(1,m2,k,3,i) = wa(i,2,1)*cr3-wa(i,2,2)*ci3
+          ch(2,m2,k,3,i) = wa(i,2,1)*ci3+wa(i,2,2)*cr3
+          ch(1,m2,k,4,i) = wa(i,3,1)*cr4-wa(i,3,2)*ci4
+          ch(2,m2,k,4,i) = wa(i,3,1)*ci4+wa(i,3,2)*cr4
+        end do
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
+        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
+        tr4 = cc(2,m1,k,1,4)-cc(2,m1,k,1,2)
+        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
+        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
+        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
+        ti4 = cc(1,m1,k,1,2)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
+        cc(1,m1,k,1,1) = tr2+tr3
+        cc(1,m1,k,1,3) = tr2-tr3
+        cc(2,m1,k,1,1) = ti2+ti3
+        cc(2,m1,k,1,3) = ti2-ti3
+        cc(1,m1,k,1,2) = tr1+tr4
+        cc(1,m1,k,1,4) = tr1-tr4
+        cc(2,m1,k,1,2) = ti1+ti4
+        cc(2,m1,k,1,4) = ti1-ti4
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmf4kf.F b/wrfv2_fire/external/fftpack/fftpack5/zmf4kf.F
new file mode 100644
index 00000000..a623bc29
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmf4kf.F
@@ -0,0 +1,184 @@
+subroutine zmf4kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! ZMF4KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(2,in1,l1,ido,4)
+  real ( kind = 8 ) ch(2,in2,l1,4,ido)
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) ci4
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) cr4
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) sn
+  real ( kind = 8 ) ti1
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) ti3
+  real ( kind = 8 ) ti4
+  real ( kind = 8 ) tr1
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) tr3
+  real ( kind = 8 ) tr4
+  real ( kind = 8 ) wa(ido,3,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
+        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
+        tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
+        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
+        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
+        ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
+        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = tr2+tr3
+        ch(1,m2,k,3,1) = tr2-tr3
+        ch(2,m2,k,1,1) = ti2+ti3
+        ch(2,m2,k,3,1) = ti2-ti3
+        ch(1,m2,k,2,1) = tr1+tr4
+        ch(1,m2,k,4,1) = tr1-tr4
+        ch(2,m2,k,2,1) = ti1+ti4
+        ch(2,m2,k,4,1) = ti1-ti4
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ti1 = cc(2,m1,k,i,1)-cc(2,m1,k,i,3)
+          ti2 = cc(2,m1,k,i,1)+cc(2,m1,k,i,3)
+          ti3 = cc(2,m1,k,i,2)+cc(2,m1,k,i,4)
+          tr4 = cc(2,m1,k,i,2)-cc(2,m1,k,i,4)
+          tr1 = cc(1,m1,k,i,1)-cc(1,m1,k,i,3)
+          tr2 = cc(1,m1,k,i,1)+cc(1,m1,k,i,3)
+          ti4 = cc(1,m1,k,i,4)-cc(1,m1,k,i,2)
+          tr3 = cc(1,m1,k,i,2)+cc(1,m1,k,i,4)
+          ch(1,m2,k,1,i) = tr2+tr3
+          cr3 = tr2-tr3
+          ch(2,m2,k,1,i) = ti2+ti3
+          ci3 = ti2-ti3
+          cr2 = tr1+tr4
+          cr4 = tr1-tr4
+          ci2 = ti1+ti4
+          ci4 = ti1-ti4
+          ch(1,m2,k,2,i) = wa(i,1,1)*cr2+wa(i,1,2)*ci2
+          ch(2,m2,k,2,i) = wa(i,1,1)*ci2-wa(i,1,2)*cr2
+          ch(1,m2,k,3,i) = wa(i,2,1)*cr3+wa(i,2,2)*ci3
+          ch(2,m2,k,3,i) = wa(i,2,1)*ci3-wa(i,2,2)*cr3
+          ch(1,m2,k,4,i) = wa(i,3,1)*cr4+wa(i,3,2)*ci4
+          ch(2,m2,k,4,i) = wa(i,3,1)*ci4-wa(i,3,2)*cr4
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0D+00 / real ( 4 * l1, kind = 8 )
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
+        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
+        tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
+        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
+        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
+        ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
+        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = sn*(tr2+tr3)
+        ch(1,m2,k,3,1) = sn*(tr2-tr3)
+        ch(2,m2,k,1,1) = sn*(ti2+ti3)
+        ch(2,m2,k,3,1) = sn*(ti2-ti3)
+        ch(1,m2,k,2,1) = sn*(tr1+tr4)
+        ch(1,m2,k,4,1) = sn*(tr1-tr4)
+        ch(2,m2,k,2,1) = sn*(ti1+ti4)
+        ch(2,m2,k,4,1) = sn*(ti1-ti4)
+      end do
+    end do
+
+  else
+
+    sn = 1.0D+00 / real ( 4 * l1, kind = 8 )
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+        ti1 = cc(2,m1,k,1,1)-cc(2,m1,k,1,3)
+        ti2 = cc(2,m1,k,1,1)+cc(2,m1,k,1,3)
+        tr4 = cc(2,m1,k,1,2)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,2)+cc(2,m1,k,1,4)
+        tr1 = cc(1,m1,k,1,1)-cc(1,m1,k,1,3)
+        tr2 = cc(1,m1,k,1,1)+cc(1,m1,k,1,3)
+        ti4 = cc(1,m1,k,1,4)-cc(1,m1,k,1,2)
+        tr3 = cc(1,m1,k,1,2)+cc(1,m1,k,1,4)
+        cc(1,m1,k,1,1) = sn*(tr2+tr3)
+        cc(1,m1,k,1,3) = sn*(tr2-tr3)
+        cc(2,m1,k,1,1) = sn*(ti2+ti3)
+        cc(2,m1,k,1,3) = sn*(ti2-ti3)
+        cc(1,m1,k,1,2) = sn*(tr1+tr4)
+        cc(1,m1,k,1,4) = sn*(tr1-tr4)
+        cc(2,m1,k,1,2) = sn*(ti1+ti4)
+        cc(2,m1,k,1,4) = sn*(ti1-ti4)
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmf5kb.F b/wrfv2_fire/external/fftpack/fftpack5/zmf5kb.F
new file mode 100644
index 00000000..75b7dd1e
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmf5kb.F
@@ -0,0 +1,208 @@
+subroutine zmf5kb ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! ZMF5KB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(2,in1,l1,ido,5)
+  real ( kind = 8 ) ch(2,in2,l1,5,ido)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) ci4
+  real ( kind = 8 ) ci5
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) cr4
+  real ( kind = 8 ) cr5
+  real ( kind = 8 ) di2
+  real ( kind = 8 ) di3
+  real ( kind = 8 ) di4
+  real ( kind = 8 ) di5
+  real ( kind = 8 ) dr2
+  real ( kind = 8 ) dr3
+  real ( kind = 8 ) dr4
+  real ( kind = 8 ) dr5
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) ti3
+  real ( kind = 8 ) ti4
+  real ( kind = 8 ) ti5
+  real ( kind = 8 ), parameter :: ti11 =  0.9510565162951536D+00
+  real ( kind = 8 ), parameter :: ti12 =  0.5877852522924731D+00
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) tr3
+  real ( kind = 8 ) tr4
+  real ( kind = 8 ) tr5
+  real ( kind = 8 ), parameter :: tr11 =  0.3090169943749474D+00
+  real ( kind = 8 ), parameter :: tr12 = -0.8090169943749474D+00
+  real ( kind = 8 ) wa(ido,4,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido .or. na == 1 ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
+        ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
+        tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
+        tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2+tr3
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2+ti3
+        cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
+        ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
+        cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
+        ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
+        cr5 = ti11*tr5+ti12*tr4
+        ci5 = ti11*ti5+ti12*ti4
+        cr4 = ti12*tr5-ti11*tr4
+        ci4 = ti12*ti5-ti11*ti4
+        ch(1,m2,k,2,1) = cr2-ci5
+        ch(1,m2,k,5,1) = cr2+ci5
+        ch(2,m2,k,2,1) = ci2+cr5
+        ch(2,m2,k,3,1) = ci3+cr4
+        ch(1,m2,k,3,1) = cr3-ci4
+        ch(1,m2,k,4,1) = cr3+ci4
+        ch(2,m2,k,4,1) = ci3-cr4
+        ch(2,m2,k,5,1) = ci2-cr5
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ti5 = cc(2,m1,k,i,2)-cc(2,m1,k,i,5)
+          ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,5)
+          ti4 = cc(2,m1,k,i,3)-cc(2,m1,k,i,4)
+          ti3 = cc(2,m1,k,i,3)+cc(2,m1,k,i,4)
+          tr5 = cc(1,m1,k,i,2)-cc(1,m1,k,i,5)
+          tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,5)
+          tr4 = cc(1,m1,k,i,3)-cc(1,m1,k,i,4)
+          tr3 = cc(1,m1,k,i,3)+cc(1,m1,k,i,4)
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2+tr3
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2+ti3
+          cr2 = cc(1,m1,k,i,1)+tr11*tr2+tr12*tr3
+          ci2 = cc(2,m1,k,i,1)+tr11*ti2+tr12*ti3
+          cr3 = cc(1,m1,k,i,1)+tr12*tr2+tr11*tr3
+          ci3 = cc(2,m1,k,i,1)+tr12*ti2+tr11*ti3
+          cr5 = ti11*tr5+ti12*tr4
+          ci5 = ti11*ti5+ti12*ti4
+          cr4 = ti12*tr5-ti11*tr4
+          ci4 = ti12*ti5-ti11*ti4
+          dr3 = cr3-ci4
+          dr4 = cr3+ci4
+          di3 = ci3+cr4
+          di4 = ci3-cr4
+          dr5 = cr2+ci5
+          dr2 = cr2-ci5
+          di5 = ci2-cr5
+          di2 = ci2+cr5
+          ch(1,m2,k,2,i) = wa(i,1,1) * dr2 - wa(i,1,2) * di2
+          ch(2,m2,k,2,i) = wa(i,1,1) * di2 + wa(i,1,2) * dr2
+          ch(1,m2,k,3,i) = wa(i,2,1) * dr3 - wa(i,2,2) * di3
+          ch(2,m2,k,3,i) = wa(i,2,1) * di3 + wa(i,2,2) * dr3
+          ch(1,m2,k,4,i) = wa(i,3,1) * dr4 - wa(i,3,2) * di4
+          ch(2,m2,k,4,i) = wa(i,3,1) * di4 + wa(i,3,2) * dr4
+          ch(1,m2,k,5,i) = wa(i,4,1) * dr5 - wa(i,4,2) * di5
+          ch(2,m2,k,5,i) = wa(i,4,1) * di5 + wa(i,4,2) * dr5
+        end do
+      end do
+    end do
+
+  else
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+        ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
+        ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
+        tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
+        tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
+
+        chold1 = cc(1,m1,k,1,1) + tr2 + tr3
+        chold2 = cc(2,m1,k,1,1) + ti2 + ti3
+
+        cr2 = cc(1,m1,k,1,1) + tr11 * tr2 + tr12 * tr3
+        ci2 = cc(2,m1,k,1,1) + tr11 * ti2 + tr12 * ti3
+        cr3 = cc(1,m1,k,1,1) + tr12 * tr2 + tr11 * tr3
+        ci3 = cc(2,m1,k,1,1) + tr12 * ti2 + tr11 * ti3
+
+        cc(1,m1,k,1,1) = chold1
+        cc(2,m1,k,1,1) = chold2
+
+        cr5 = ti11*tr5 + ti12*tr4
+        ci5 = ti11*ti5 + ti12*ti4
+        cr4 = ti12*tr5 - ti11*tr4
+        ci4 = ti12*ti5 - ti11*ti4
+        cc(1,m1,k,1,2) = cr2-ci5
+        cc(1,m1,k,1,5) = cr2+ci5
+        cc(2,m1,k,1,2) = ci2+cr5
+        cc(2,m1,k,1,3) = ci3+cr4
+        cc(1,m1,k,1,3) = cr3-ci4
+        cc(1,m1,k,1,4) = cr3+ci4
+        cc(2,m1,k,1,4) = ci3-cr4
+        cc(2,m1,k,1,5) = ci2-cr5
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmf5kf.F b/wrfv2_fire/external/fftpack/fftpack5/zmf5kf.F
new file mode 100644
index 00000000..53d95e29
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmf5kf.F
@@ -0,0 +1,251 @@
+subroutine zmf5kf ( lot, ido, l1, na, cc, im1, in1, ch, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! ZMF5KF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) l1
+
+  real ( kind = 8 ) cc(2,in1,l1,ido,5)
+  real ( kind = 8 ) ch(2,in2,l1,5,ido)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  real ( kind = 8 ) ci2
+  real ( kind = 8 ) ci3
+  real ( kind = 8 ) ci4
+  real ( kind = 8 ) ci5
+  real ( kind = 8 ) cr2
+  real ( kind = 8 ) cr3
+  real ( kind = 8 ) cr4
+  real ( kind = 8 ) cr5
+  real ( kind = 8 ) di2
+  real ( kind = 8 ) di3
+  real ( kind = 8 ) di4
+  real ( kind = 8 ) di5
+  real ( kind = 8 ) dr2
+  real ( kind = 8 ) dr3
+  real ( kind = 8 ) dr4
+  real ( kind = 8 ) dr5
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) sn
+  real ( kind = 8 ) ti2
+  real ( kind = 8 ) ti3
+  real ( kind = 8 ) ti4
+  real ( kind = 8 ) ti5
+  real ( kind = 8 ), parameter :: ti11 = -0.9510565162951536D+00
+  real ( kind = 8 ), parameter :: ti12 = -0.5877852522924731D+00
+  real ( kind = 8 ) tr2
+  real ( kind = 8 ) tr3
+  real ( kind = 8 ) tr4
+  real ( kind = 8 ) tr5
+  real ( kind = 8 ), parameter :: tr11 =  0.3090169943749474D+00
+  real ( kind = 8 ), parameter :: tr12 = -0.8090169943749474D+00
+  real ( kind = 8 ) wa(ido,4,2)
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+
+  if ( 1 < ido ) then
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
+        ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
+        tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
+        tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = cc(1,m1,k,1,1)+tr2+tr3
+        ch(2,m2,k,1,1) = cc(2,m1,k,1,1)+ti2+ti3
+        cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
+        ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
+        cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
+        ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
+        cr5 = ti11*tr5+ti12*tr4
+        ci5 = ti11*ti5+ti12*ti4
+        cr4 = ti12*tr5-ti11*tr4
+        ci4 = ti12*ti5-ti11*ti4
+        ch(1,m2,k,2,1) = cr2-ci5
+        ch(1,m2,k,5,1) = cr2+ci5
+        ch(2,m2,k,2,1) = ci2+cr5
+        ch(2,m2,k,3,1) = ci3+cr4
+        ch(1,m2,k,3,1) = cr3-ci4
+        ch(1,m2,k,4,1) = cr3+ci4
+        ch(2,m2,k,4,1) = ci3-cr4
+        ch(2,m2,k,5,1) = ci2-cr5
+      end do
+    end do
+
+    do i = 2, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ti5 = cc(2,m1,k,i,2)-cc(2,m1,k,i,5)
+          ti2 = cc(2,m1,k,i,2)+cc(2,m1,k,i,5)
+          ti4 = cc(2,m1,k,i,3)-cc(2,m1,k,i,4)
+          ti3 = cc(2,m1,k,i,3)+cc(2,m1,k,i,4)
+          tr5 = cc(1,m1,k,i,2)-cc(1,m1,k,i,5)
+          tr2 = cc(1,m1,k,i,2)+cc(1,m1,k,i,5)
+          tr4 = cc(1,m1,k,i,3)-cc(1,m1,k,i,4)
+          tr3 = cc(1,m1,k,i,3)+cc(1,m1,k,i,4)
+          ch(1,m2,k,1,i) = cc(1,m1,k,i,1)+tr2+tr3
+          ch(2,m2,k,1,i) = cc(2,m1,k,i,1)+ti2+ti3
+          cr2 = cc(1,m1,k,i,1)+tr11*tr2+tr12*tr3
+          ci2 = cc(2,m1,k,i,1)+tr11*ti2+tr12*ti3
+          cr3 = cc(1,m1,k,i,1)+tr12*tr2+tr11*tr3
+          ci3 = cc(2,m1,k,i,1)+tr12*ti2+tr11*ti3
+          cr5 = ti11*tr5+ti12*tr4
+          ci5 = ti11*ti5+ti12*ti4
+          cr4 = ti12*tr5-ti11*tr4
+          ci4 = ti12*ti5-ti11*ti4
+          dr3 = cr3-ci4
+          dr4 = cr3+ci4
+          di3 = ci3+cr4
+          di4 = ci3-cr4
+          dr5 = cr2+ci5
+          dr2 = cr2-ci5
+          di5 = ci2-cr5
+          di2 = ci2+cr5
+          ch(1,m2,k,2,i) = wa(i,1,1)*dr2+wa(i,1,2)*di2
+          ch(2,m2,k,2,i) = wa(i,1,1)*di2-wa(i,1,2)*dr2
+          ch(1,m2,k,3,i) = wa(i,2,1)*dr3+wa(i,2,2)*di3
+          ch(2,m2,k,3,i) = wa(i,2,1)*di3-wa(i,2,2)*dr3
+          ch(1,m2,k,4,i) = wa(i,3,1)*dr4+wa(i,3,2)*di4
+          ch(2,m2,k,4,i) = wa(i,3,1)*di4-wa(i,3,2)*dr4
+          ch(1,m2,k,5,i) = wa(i,4,1)*dr5+wa(i,4,2)*di5
+          ch(2,m2,k,5,i) = wa(i,4,1)*di5-wa(i,4,2)*dr5
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0D+00 / real ( 5 * l1, kind = 8 )
+
+    do k = 1, l1
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ti5 = cc(2,m1,k,1,2)-cc(2,m1,k,1,5)
+        ti2 = cc(2,m1,k,1,2)+cc(2,m1,k,1,5)
+        ti4 = cc(2,m1,k,1,3)-cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,3)+cc(2,m1,k,1,4)
+        tr5 = cc(1,m1,k,1,2)-cc(1,m1,k,1,5)
+        tr2 = cc(1,m1,k,1,2)+cc(1,m1,k,1,5)
+        tr4 = cc(1,m1,k,1,3)-cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,3)+cc(1,m1,k,1,4)
+        ch(1,m2,k,1,1) = sn*(cc(1,m1,k,1,1)+tr2+tr3)
+        ch(2,m2,k,1,1) = sn*(cc(2,m1,k,1,1)+ti2+ti3)
+        cr2 = cc(1,m1,k,1,1)+tr11*tr2+tr12*tr3
+        ci2 = cc(2,m1,k,1,1)+tr11*ti2+tr12*ti3
+        cr3 = cc(1,m1,k,1,1)+tr12*tr2+tr11*tr3
+        ci3 = cc(2,m1,k,1,1)+tr12*ti2+tr11*ti3
+        cr5 = ti11*tr5+ti12*tr4
+        ci5 = ti11*ti5+ti12*ti4
+        cr4 = ti12*tr5-ti11*tr4
+        ci4 = ti12*ti5-ti11*ti4
+        ch(1,m2,k,2,1) = sn*(cr2-ci5)
+        ch(1,m2,k,5,1) = sn*(cr2+ci5)
+        ch(2,m2,k,2,1) = sn*(ci2+cr5)
+        ch(2,m2,k,3,1) = sn*(ci3+cr4)
+        ch(1,m2,k,3,1) = sn*(cr3-ci4)
+        ch(1,m2,k,4,1) = sn*(cr3+ci4)
+        ch(2,m2,k,4,1) = sn*(ci3-cr4)
+        ch(2,m2,k,5,1) = sn*(ci2-cr5)
+      end do
+    end do
+
+  else
+
+    sn = 1.0D+00 / real ( 5 * l1, kind = 8 )
+
+    do k = 1, l1
+      do m1 = 1, m1d, im1
+
+        ti5 = cc(2,m1,k,1,2) - cc(2,m1,k,1,5)
+        ti2 = cc(2,m1,k,1,2) + cc(2,m1,k,1,5)
+        ti4 = cc(2,m1,k,1,3) - cc(2,m1,k,1,4)
+        ti3 = cc(2,m1,k,1,3) + cc(2,m1,k,1,4)
+        tr5 = cc(1,m1,k,1,2) - cc(1,m1,k,1,5)
+        tr2 = cc(1,m1,k,1,2) + cc(1,m1,k,1,5)
+        tr4 = cc(1,m1,k,1,3) - cc(1,m1,k,1,4)
+        tr3 = cc(1,m1,k,1,3) + cc(1,m1,k,1,4)
+
+        chold1 = sn * ( cc(1,m1,k,1,1) + tr2 + tr3 )
+        chold2 = sn * ( cc(2,m1,k,1,1) + ti2 + ti3 )
+
+        cr2 = cc(1,m1,k,1,1) + tr11 * tr2 + tr12 * tr3
+        ci2 = cc(2,m1,k,1,1) + tr11 * ti2 + tr12 * ti3
+        cr3 = cc(1,m1,k,1,1) + tr12 * tr2 + tr11 * tr3
+        ci3 = cc(2,m1,k,1,1) + tr12 * ti2 + tr11 * ti3
+
+        cc(1,m1,k,1,1) = chold1
+        cc(2,m1,k,1,1) = chold2
+
+        cr5 = ti11 * tr5 + ti12 * tr4
+        ci5 = ti11 * ti5 + ti12 * ti4
+        cr4 = ti12 * tr5 - ti11 * tr4
+        ci4 = ti12 * ti5 - ti11 * ti4
+
+        cc(1,m1,k,1,2) = sn * ( cr2 - ci5 )
+        cc(1,m1,k,1,5) = sn * ( cr2 + ci5 )
+        cc(2,m1,k,1,2) = sn * ( ci2 + cr5 )
+        cc(2,m1,k,1,3) = sn * ( ci3 + cr4 )
+        cc(1,m1,k,1,3) = sn * ( cr3 - ci4 )
+        cc(1,m1,k,1,4) = sn * ( cr3 + ci4 )
+        cc(2,m1,k,1,4) = sn * ( ci3 - cr4 )
+        cc(2,m1,k,1,5) = sn * ( ci2 - cr5 )
+
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmfgkb.F b/wrfv2_fire/external/fftpack/fftpack5/zmfgkb.F
new file mode 100644
index 00000000..8e56d6a8
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmfgkb.F
@@ -0,0 +1,234 @@
+subroutine zmfgkb ( lot, ido, ip, l1, lid, na, cc, cc1, im1, in1, &
+  ch, ch1, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! ZMFGKB is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) lid
+
+  real ( kind = 8 ) cc(2,in1,l1,ip,ido)
+  real ( kind = 8 ) cc1(2,in1,lid,ip)
+  real ( kind = 8 ) ch(2,in2,l1,ido,ip)
+  real ( kind = 8 ) ch1(2,in2,lid,ip)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) idlj
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) ki
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) wa(ido,ip-1,2)
+  real ( kind = 8 ) wai
+  real ( kind = 8 ) war
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+  ipp2 = ip + 2
+  ipph = ( ip + 1 ) / 2
+
+  do ki = 1, lid
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
+      ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
+    end do
+  end do
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch1(1,m2,ki,j) =  cc1(1,m1,ki,j) + cc1(1,m1,ki,jc)
+        ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) - cc1(1,m1,ki,jc)
+        ch1(2,m2,ki,j) =  cc1(2,m1,ki,j) + cc1(2,m1,ki,jc)
+        ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(2,m1,ki,jc)
+      end do
+    end do
+  end do
+
+  do j = 2, ipph
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        cc1(1,m1,ki,1) = cc1(1,m1,ki,1) + ch1(1,m2,ki,j)
+        cc1(2,m1,ki,1) = cc1(2,m1,ki,1) + ch1(2,m2,ki,j)
+      end do
+    end do
+  end do
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+
+        cc1(1,m1,ki,l)  = ch1(1,m2,ki,1) + wa(1,l-1,1) * ch1(1,m2,ki,2)
+        cc1(1,m1,ki,lc) =                  wa(1,l-1,2) * ch1(1,m2,ki,ip)
+        cc1(2,m1,ki,l)  = ch1(2,m2,ki,1) + wa(1,l-1,1) * ch1(2,m2,ki,2)
+        cc1(2,m1,ki,lc) =                  wa(1,l-1,2) * ch1(2,m2,ki,ip)
+
+      end do
+    end do
+
+    do j = 3, ipph
+      jc = ipp2 - j
+      idlj = mod ( ( l - 1 ) * ( j - 1 ), ip )
+      war = wa(1,idlj,1)
+      wai = wa(1,idlj,2)
+      do ki = 1, lid
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc1(1,m1,ki,l)  = cc1(1,m1,ki,l)  + war * ch1(1,m2,ki,j)
+          cc1(1,m1,ki,lc) = cc1(1,m1,ki,lc) + wai * ch1(1,m2,ki,jc)
+          cc1(2,m1,ki,l)  = cc1(2,m1,ki,l)  + war * ch1(2,m2,ki,j)
+          cc1(2,m1,ki,lc) = cc1(2,m1,ki,lc) + wai * ch1(2,m2,ki,jc)
+        end do
+      end do
+    end do
+
+  end do
+
+  if( 1 < ido .or. na == 1 ) then
+
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
+        ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
+      end do
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch1(1,m2,ki,j)  = cc1(1,m1,ki,j) - cc1(2,m1,ki,jc)
+          ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) + cc1(2,m1,ki,jc)
+          ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(1,m1,ki,jc)
+          ch1(2,m2,ki,j)  = cc1(2,m1,ki,j) + cc1(1,m1,ki,jc)
+        end do
+      end do
+    end do
+
+    if ( ido == 1 ) then
+      return
+    end if
+
+    do i = 1, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc(1,m1,k,1,i) = ch(1,m2,k,i,1)
+          cc(2,m1,k,1,i) = ch(2,m2,k,i,1)
+        end do
+      end do
+    end do
+
+    do j = 2, ip
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc(1,m1,k,j,1) = ch(1,m2,k,1,j)
+          cc(2,m1,k,j,1) = ch(2,m2,k,1,j)
+        end do
+      end do
+    end do
+
+    do j = 2, ip
+      do i = 2, ido
+        do k = 1, l1
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            cc(1,m1,k,j,i) = wa(i,j-1,1) * ch(1,m2,k,i,j) &
+                           - wa(i,j-1,2) * ch(2,m2,k,i,j)
+            cc(2,m1,k,j,i) = wa(i,j-1,1) * ch(2,m2,k,i,j) &
+                           + wa(i,j-1,2) * ch(1,m2,k,i,j)
+          end do
+        end do
+      end do
+    end do
+
+  else
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        do m1 = 1, m1d, im1
+
+          chold1         = cc1(1,m1,ki,j) - cc1(2,m1,ki,jc)
+          chold2         = cc1(1,m1,ki,j) + cc1(2,m1,ki,jc)
+          cc1(1,m1,ki,j) = chold1
+
+          cc1(2,m1,ki,jc) = cc1(2,m1,ki,j) - cc1(1,m1,ki,jc)
+          cc1(2,m1,ki,j)  = cc1(2,m1,ki,j) + cc1(1,m1,ki,jc)
+          cc1(1,m1,ki,jc) = chold2
+
+        end do
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmfgkf.F b/wrfv2_fire/external/fftpack/fftpack5/zmfgkf.F
new file mode 100644
index 00000000..a4495ba2
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmfgkf.F
@@ -0,0 +1,265 @@
+subroutine zmfgkf ( lot, ido, ip, l1, lid, na, cc, cc1, im1, in1, &
+  ch, ch1, im2, in2, wa )
+
+!*****************************************************************************80
+!
+!! ZMFGKF is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) in1
+  integer ( kind = 4 ) in2
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) lid
+
+  real ( kind = 8 ) cc(2,in1,l1,ip,ido)
+  real ( kind = 8 ) cc1(2,in1,lid,ip)
+  real ( kind = 8 ) ch(2,in2,l1,ido,ip)
+  real ( kind = 8 ) ch1(2,in2,lid,ip)
+  real ( kind = 8 ) chold1
+  real ( kind = 8 ) chold2
+  integer ( kind = 4 ) i
+  integer ( kind = 4 ) idlj
+  integer ( kind = 4 ) im1
+  integer ( kind = 4 ) im2
+  integer ( kind = 4 ) ipp2
+  integer ( kind = 4 ) ipph
+  integer ( kind = 4 ) j
+  integer ( kind = 4 ) jc
+  integer ( kind = 4 ) k
+  integer ( kind = 4 ) ki
+  integer ( kind = 4 ) l
+  integer ( kind = 4 ) lc
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) m1
+  integer ( kind = 4 ) m1d
+  integer ( kind = 4 ) m2
+  integer ( kind = 4 ) m2s
+  integer ( kind = 4 ) na
+  real ( kind = 8 ) sn
+  real ( kind = 8 ) wa(ido,ip-1,2)
+  real ( kind = 8 ) wai
+  real ( kind = 8 ) war
+
+  m1d = ( lot - 1 ) * im1 + 1
+  m2s = 1 - im2
+  ipp2 = ip + 2
+  ipph = ( ip + 1 ) / 2
+
+  do ki = 1, lid
+    m2 = m2s
+    do m1 = 1, m1d, im1
+      m2 = m2 + im2
+      ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
+      ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
+    end do
+  end do
+
+  do j = 2, ipph
+    jc = ipp2 - j
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch1(1,m2,ki,j) =  cc1(1,m1,ki,j) + cc1(1,m1,ki,jc)
+        ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) - cc1(1,m1,ki,jc)
+        ch1(2,m2,ki,j) =  cc1(2,m1,ki,j) + cc1(2,m1,ki,jc)
+        ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(2,m1,ki,jc)
+      end do
+    end do
+  end do
+
+  do j = 2, ipph
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        cc1(1,m1,ki,1) = cc1(1,m1,ki,1) + ch1(1,m2,ki,j)
+        cc1(2,m1,ki,1) = cc1(2,m1,ki,1) + ch1(2,m2,ki,j)
+      end do
+    end do
+  end do
+
+  do l = 2, ipph
+
+    lc = ipp2 - l
+
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        cc1(1,m1,ki,l)  = ch1(1,m2,ki,1) + wa(1,l-1,1) * ch1(1,m2,ki,2)
+        cc1(1,m1,ki,lc) =                - wa(1,l-1,2) * ch1(1,m2,ki,ip)
+        cc1(2,m1,ki,l)  = ch1(2,m2,ki,1) + wa(1,l-1,1) * ch1(2,m2,ki,2)
+        cc1(2,m1,ki,lc) =                - wa(1,l-1,2) * ch1(2,m2,ki,ip)
+      end do
+    end do
+
+    do j = 3, ipph
+      jc = ipp2 - j
+      idlj = mod ( ( l - 1 ) * ( j - 1 ), ip )
+      war = wa(1,idlj,1)
+      wai = -wa(1,idlj,2)
+      do ki = 1, lid
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc1(1,m1,ki,l)  = cc1(1,m1,ki,l)  + war * ch1(1,m2,ki,j)
+          cc1(1,m1,ki,lc) = cc1(1,m1,ki,lc) + wai * ch1(1,m2,ki,jc)
+          cc1(2,m1,ki,l)  = cc1(2,m1,ki,l)  + war * ch1(2,m2,ki,j)
+          cc1(2,m1,ki,lc) = cc1(2,m1,ki,lc) + wai * ch1(2,m2,ki,jc)
+        end do
+      end do
+    end do
+
+  end do
+
+  if ( 1 < ido ) then
+
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch1(1,m2,ki,1) = cc1(1,m1,ki,1)
+        ch1(2,m2,ki,1) = cc1(2,m1,ki,1)
+      end do
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch1(1,m2,ki,j)  = cc1(1,m1,ki,j) - cc1(2,m1,ki,jc)
+          ch1(2,m2,ki,j)  = cc1(2,m1,ki,j) + cc1(1,m1,ki,jc)
+          ch1(1,m2,ki,jc) = cc1(1,m1,ki,j) + cc1(2,m1,ki,jc)
+          ch1(2,m2,ki,jc) = cc1(2,m1,ki,j) - cc1(1,m1,ki,jc)
+        end do
+      end do
+    end do
+
+    do i = 1, ido
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc(1,m1,k,1,i) = ch(1,m2,k,i,1)
+          cc(2,m1,k,1,i) = ch(2,m2,k,i,1)
+        end do
+      end do
+    end do
+
+    do j = 2, ip
+      do k = 1, l1
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          cc(1,m1,k,j,1) = ch(1,m2,k,1,j)
+          cc(2,m1,k,j,1) = ch(2,m2,k,1,j)
+        end do
+      end do
+    end do
+
+    do j = 2, ip
+      do i = 2, ido
+        do k = 1, l1
+          m2 = m2s
+          do m1 = 1, m1d, im1
+            m2 = m2 + im2
+            cc(1,m1,k,j,i) = wa(i,j-1,1) * ch(1,m2,k,i,j) &
+                           + wa(i,j-1,2) * ch(2,m2,k,i,j)
+            cc(2,m1,k,j,i) = wa(i,j-1,1) * ch(2,m2,k,i,j) &
+                           - wa(i,j-1,2) * ch(1,m2,k,i,j)
+          end do
+        end do
+      end do
+    end do
+
+  else if ( na == 1 ) then
+
+    sn = 1.0D+00 / real ( ip * l1, kind = 8 )
+
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        ch1(1,m2,ki,1) = sn * cc1(1,m1,ki,1)
+        ch1(2,m2,ki,1) = sn * cc1(2,m1,ki,1)
+      end do
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        m2 = m2s
+        do m1 = 1, m1d, im1
+          m2 = m2 + im2
+          ch1(1,m2,ki,j)  = sn * ( cc1(1,m1,ki,j) - cc1(2,m1,ki,jc) )
+          ch1(2,m2,ki,j)  = sn * ( cc1(2,m1,ki,j) + cc1(1,m1,ki,jc) )
+          ch1(1,m2,ki,jc) = sn * ( cc1(1,m1,ki,j) + cc1(2,m1,ki,jc) )
+          ch1(2,m2,ki,jc) = sn * ( cc1(2,m1,ki,j) - cc1(1,m1,ki,jc) )
+        end do
+      end do
+    end do
+
+  else
+
+    sn = 1.0D+00 / real ( ip * l1, kind = 8 )
+
+    do ki = 1, lid
+      m2 = m2s
+      do m1 = 1, m1d, im1
+        m2 = m2 + im2
+        cc1(1,m1,ki,1) = sn * cc1(1,m1,ki,1)
+        cc1(2,m1,ki,1) = sn * cc1(2,m1,ki,1)
+      end do
+    end do
+
+    do j = 2, ipph
+      jc = ipp2 - j
+      do ki = 1, lid
+        do m1 = 1, m1d, im1
+          chold1 = sn * ( cc1(1,m1,ki,j) - cc1(2,m1,ki,jc) )
+          chold2 = sn * ( cc1(1,m1,ki,j) + cc1(2,m1,ki,jc) )
+          cc1(1,m1,ki,j) = chold1
+          cc1(2,m1,ki,jc) = sn * ( cc1(2,m1,ki,j) - cc1(1,m1,ki,jc) )
+          cc1(2,m1,ki,j)  = sn * ( cc1(2,m1,ki,j) + cc1(1,m1,ki,jc) )
+          cc1(1,m1,ki,jc) = chold2
+        end do
+      end do
+    end do
+
+  end if
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmfm1b.F b/wrfv2_fire/external/fftpack/fftpack5/zmfm1b.F
new file mode 100644
index 00000000..05873ff6
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmfm1b.F
@@ -0,0 +1,103 @@
+subroutine zmfm1b ( lot, jump, n, inc, c, ch, wa, fnf, fac )
+
+!*****************************************************************************80
+!
+!! ZMFM1B is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  complex ( kind = 8 ) c(*)
+  real ( kind = 8 ) ch(*)
+  real ( kind = 8 ) fac(*)
+  real ( kind = 8 ) fnf
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) lid
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nbr
+  integer ( kind = 4 ) nf
+  real ( kind = 8 ) wa(*)
+
+  nf = int ( fnf )
+  na = 0
+  l1 = 1
+  iw = 1
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1) )
+    l2 = ip * l1
+    ido = n / l2
+    lid = l1 * ido
+    nbr = 1 + na + 2 * min ( ip - 2, 4 )
+
+    if ( nbr == 1 ) then
+      call zmf2kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 2 ) then
+      call zmf2kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 3 ) then
+      call zmf3kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 4 ) then
+      call zmf3kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 5 ) then
+      call zmf4kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 6 ) then
+      call zmf4kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 7 ) then
+      call zmf5kb ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 8 ) then
+      call zmf5kb ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 9 ) then
+      call zmfgkb ( lot, ido, ip, l1, lid, na, c, c, jump, inc, ch, ch, &
+        1, lot, wa(iw) )
+    else if ( nbr == 10 ) then
+      call zmfgkb ( lot, ido, ip, l1, lid, na, ch, ch, 1, lot, c, c, &
+        jump, inc, wa(iw) )
+    end if
+
+    l1 = l2
+    iw = iw + ( ip - 1 ) * ( ido + ido )
+
+    if ( ip <= 5 ) then
+      na = 1 - na
+    end if
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/fftpack/fftpack5/zmfm1f.F b/wrfv2_fire/external/fftpack/fftpack5/zmfm1f.F
new file mode 100644
index 00000000..75f84fcc
--- /dev/null
+++ b/wrfv2_fire/external/fftpack/fftpack5/zmfm1f.F
@@ -0,0 +1,103 @@
+subroutine zmfm1f ( lot, jump, n, inc, c, ch, wa, fnf, fac )
+
+!*****************************************************************************80
+!
+!! ZMFM1F is an FFTPACK5 auxiliary routine.
+!
+!  License:
+!
+!    Licensed under the GNU General Public License (GPL).
+!
+!  Modified:
+!
+!    26 Ausust 2009
+!
+!  Author:
+!
+!    Original complex single precision by Paul Swarztrauber, Richard Valent.
+!    Complex double precision version by John Burkardt.
+!
+!  Reference:
+!
+!    Paul Swarztrauber,
+!    Vectorizing the Fast Fourier Transforms,
+!    in Parallel Computations,
+!    edited by G. Rodrigue,
+!    Academic Press, 1982.
+!
+!    Paul Swarztrauber,
+!    Fast Fourier Transform Algorithms for Vector Computers,
+!    Parallel Computing, pages 45-63, 1984.
+!
+!  Parameters:
+!
+  implicit none
+
+  complex ( kind = 8 ) c(*)
+  real ( kind = 8 ) ch(*)
+  real ( kind = 8 ) fac(*)
+  real ( kind = 8 ) fnf
+  integer ( kind = 4 ) ido
+  integer ( kind = 4 ) inc
+  integer ( kind = 4 ) ip
+  integer ( kind = 4 ) iw
+  integer ( kind = 4 ) jump
+  integer ( kind = 4 ) k1
+  integer ( kind = 4 ) l1
+  integer ( kind = 4 ) l2
+  integer ( kind = 4 ) lid
+  integer ( kind = 4 ) lot
+  integer ( kind = 4 ) n
+  integer ( kind = 4 ) na
+  integer ( kind = 4 ) nbr
+  integer ( kind = 4 ) nf
+  real ( kind = 8 ) wa(*)
+
+  nf = int ( fnf )
+  na = 0
+  l1 = 1
+  iw = 1
+
+  do k1 = 1, nf
+
+    ip = int ( fac(k1) )
+    l2 = ip * l1
+    ido = n / l2
+    lid = l1 * ido
+    nbr = 1 + na + 2 * min ( ip - 2, 4 )
+
+    if ( nbr == 1 ) then
+      call zmf2kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 2 ) then
+      call zmf2kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 3 ) then
+      call zmf3kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 4 ) then
+      call zmf3kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 5 ) then
+      call zmf4kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 6 ) then
+      call zmf4kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 7 ) then
+      call zmf5kf ( lot, ido, l1, na, c, jump, inc, ch, 1, lot, wa(iw) )
+    else if ( nbr == 8 ) then
+      call zmf5kf ( lot, ido, l1, na, ch, 1, lot, c, jump, inc, wa(iw) )
+    else if ( nbr == 9 ) then
+      call zmfgkf ( lot, ido, ip, l1, lid, na, c, c, jump, inc, ch, ch, &
+        1, lot, wa(iw) )
+    else if ( nbr == 10 ) then
+      call zmfgkf ( lot, ido, ip, l1, lid, na, ch, ch, 1, lot, c, c, &
+        jump, inc, wa(iw) )
+    end if
+
+    l1 = l2
+    iw = iw + ( ip - 1 ) * ( ido + ido )
+
+    if ( ip <= 5 ) then
+      na = 1 - na
+    end if
+
+  end do
+
+  return
+end
diff --git a/wrfv2_fire/external/io_esmf/makefile b/wrfv2_fire/external/io_esmf/makefile
index d919ad7e..c17499f1 100644
--- a/wrfv2_fire/external/io_esmf/makefile
+++ b/wrfv2_fire/external/io_esmf/makefile
@@ -24,7 +24,7 @@ $(TARGET) : $(OBJS)
 	$(RANLIB) $(TARGET)
 
 .F90.o :
-	$(CPP) -I../ioapi_share -C -P -DESMF_COUPLING $*.F90 > $*.f
+	$(CPP) -I../ioapi_share -P -traditional -DESMF_COUPLING $*.F90 > $*.f
 	$(FC) -c -g -I../ioapi_share $*.f
 
 superclean: 
diff --git a/wrfv2_fire/external/io_grib2/g2lib/utest/Makefile b/wrfv2_fire/external/io_grib2/g2lib/utest/Makefile
index 22e20169..59902567 100644
--- a/wrfv2_fire/external/io_grib2/g2lib/utest/Makefile
+++ b/wrfv2_fire/external/io_grib2/g2lib/utest/Makefile
@@ -53,7 +53,7 @@ CPPFLAGS =
 DEP_LIBS = -lio_grib2 -L../.. -lio_grib_share -L../../../io_grib_share -lpng -ljasper
 
 FC = ifort -FR
-CPP = /lib/cpp -traditional -C -P
+CPP = /lib/cpp -traditional -P
 LDD = ifort
 MAIN_OBJS =  \
 	test_g2lib.o
diff --git a/wrfv2_fire/external/io_int/makefile b/wrfv2_fire/external/io_int/makefile
index 23ca56d4..41cae782 100644
--- a/wrfv2_fire/external/io_int/makefile
+++ b/wrfv2_fire/external/io_int/makefile
@@ -9,7 +9,7 @@ WRF_MOD = ../../frame/pack_utils.o \
 	  ../../frame/module_wrf_error.o \
 	  ../../frame/wrf_debug.o
 
-CPP1    = $(CPP) $(TRADFLAG)
+CPP1    = $(CPP) $(TRADFLAG) $(ARCHFLAGS)
 M4      = m4 -Uinclude -Uindex -Ulen
 
 .SUFFIXES: .F90 .F .f .f90 .c .h .o .code
@@ -38,8 +38,11 @@ io_int_idx_tags.h: ../../inc/intio_tags.h
 io_int_idx.o: io_int_idx.c io_int_idx.h io_int_idx_tags.h
 	$(CC) -o $@ -c $*.c
 
-module_io_int_idx.o: module_io_int_idx.f90
-	$(FC) $(FCFLAGS) -o $@ -c $*.f90
+module_io_int_idx.o: module_io_int_idx.f
+	$(FC) $(FCFLAGS) -o $@ -c $*.f
+
+module_io_int_idx.f: module_io_int_idx.F90
+	$(CPP1) $*.F90 > $@
 
 module_io_int_read.o: module_io_int_read.f module_io_int_idx.o
 	$(FC) $(FCFLAGS) -I../../frame -o $@ -c $*.f
@@ -78,8 +81,11 @@ diffwrf: diffwrf.f $(WRF_MOD) $(ESMF_MOD_DEPENDENCE) $(LIB)
 $(WRF_MOD) $(ESMF_MOD_DEPENDENCE):
 	@echo "Diffwrf io_int will be built later on in this compile. No need to rerun compile. "
 
-test_io_idx: test_io_idx.f90 $(LIB)
-	$(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $@.f90 -L. -lwrfio_int
+test_io_idx: test_io_idx.f $(LIB)
+	$(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $@.f -L. -lwrfio_int
+
+test_io_idx.f: test_io_idx.F90
+	$(CPP1) $*.F90 > $@
 
 test_io_mpi: test_io_mpi.f90 $(LIB)
 	$(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $@.f90 -L. -lwrfio_int
diff --git a/wrfv2_fire/external/io_int/module_io_int_idx.f90 b/wrfv2_fire/external/io_int/module_io_int_idx.F90
similarity index 97%
rename from wrfv2_fire/external/io_int/module_io_int_idx.f90
rename to wrfv2_fire/external/io_int/module_io_int_idx.F90
index 44d7c749..1ebdec54 100644
--- a/wrfv2_fire/external/io_int/module_io_int_idx.f90
+++ b/wrfv2_fire/external/io_int/module_io_int_idx.F90
@@ -1,3 +1,12 @@
+#if defined ( NO_ISO_C_SUPPORT ) 
+module module_io_int_idx
+   private
+   contains
+      subroutine dummy
+      end subroutine dummy
+end module module_io_int_idx
+
+#else
 !
 ! Public domain.
 !
@@ -185,3 +194,4 @@ function io_int_string(arr) result(str)
     end function io_int_string
 
 end module module_io_int_idx
+#endif
diff --git a/wrfv2_fire/external/io_int/module_io_int_read.F90 b/wrfv2_fire/external/io_int/module_io_int_read.F90
index 6893bfa3..5e2a8f6e 100644
--- a/wrfv2_fire/external/io_int/module_io_int_read.F90
+++ b/wrfv2_fire/external/io_int/module_io_int_read.F90
@@ -1,3 +1,12 @@
+#if defined ( NO_IEEE_MODULE )         /* stub out entire module */
+module module_io_int_read
+   private
+   contains
+      subroutine dummy
+      end subroutine dummy
+end module module_io_int_read
+
+#else
 !
 ! Public domain.
 !
@@ -1070,3 +1079,4 @@ end subroutine read_c1
 #endif         /* __PATHSCALE__ */
 #endif         /* defined(DM_PARALLEL) && !defined(STUBMPI) */
 end module module_io_int_read
+#endif         /* stub out entire module */
diff --git a/wrfv2_fire/external/io_int/test_io_idx.f90 b/wrfv2_fire/external/io_int/test_io_idx.F90
similarity index 85%
rename from wrfv2_fire/external/io_int/test_io_idx.f90
rename to wrfv2_fire/external/io_int/test_io_idx.F90
index d4db4dcc..8f523f6c 100644
--- a/wrfv2_fire/external/io_int/test_io_idx.f90
+++ b/wrfv2_fire/external/io_int/test_io_idx.F90
@@ -1,3 +1,12 @@
+#if defined ( NO_IEEE_MODULE )      /* stub out entire program */
+program test_io_idx
+   print *,'NO TEST PROGRAM MADE for test_io_idx'
+   print *,'NO TEST PROGRAM MADE for test_io_idx'
+   print *,'NO TEST PROGRAM MADE for test_io_idx'
+   print *,'NO TEST PROGRAM MADE for test_io_idx'
+end program test_io_idx
+
+#else
 !
 ! Public domain.
 !
@@ -76,3 +85,4 @@ subroutine wrf_message(message)
 
     write(0,*) trim(message)
 end subroutine wrf_message
+#endif      /* stub out entire program */
diff --git a/wrfv2_fire/external/io_mcel/makefile b/wrfv2_fire/external/io_mcel/makefile
index 8aa95a5d..15e3fa57 100644
--- a/wrfv2_fire/external/io_mcel/makefile
+++ b/wrfv2_fire/external/io_mcel/makefile
@@ -5,7 +5,7 @@ OBJS    = $(OBJSL)
 OPTS    =
 FFLAGS  =  $(OPTS) -w -g
 LIBS    = 
-CPP     = /lib/cpp -C -P $(TRADFLAG)
+CPP     = /lib/cpp -P $(TRADFLAG)
 M4      = m4 -Uinclude -Uindex -Ulen
 AR      = ar
 RANLIB  = echo
diff --git a/wrfv2_fire/external/io_netcdf/ext_ncd_put_dom_ti.code b/wrfv2_fire/external/io_netcdf/ext_ncd_put_dom_ti.code
index 6b98425c..2d5b1a3e 100644
--- a/wrfv2_fire/external/io_netcdf/ext_ncd_put_dom_ti.code
+++ b/wrfv2_fire/external/io_netcdf/ext_ncd_put_dom_ti.code
@@ -102,7 +102,7 @@ IF ( ncd_ok_to_put_dom_ti( DataHandle ) ) THEN
       call wrf_debug ( WARN , msg)
       return
     endif
-  elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
+  elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
     stat = NF_REDEF(DH%NCID)
     call netcdf_err(stat,Status)
     if(Status /= WRF_NO_ERR) then
diff --git a/wrfv2_fire/external/io_netcdf/makefile b/wrfv2_fire/external/io_netcdf/makefile
index 473a8ff3..af7f162a 100644
--- a/wrfv2_fire/external/io_netcdf/makefile
+++ b/wrfv2_fire/external/io_netcdf/makefile
@@ -5,7 +5,8 @@ OBJS    = $(OBJSL)
 CODE    = ext_ncd_get_dom_ti.code ext_ncd_get_var_td.code ext_ncd_get_var_ti.code ext_ncd_put_dom_ti.code ext_ncd_put_var_td.code ext_ncd_put_var_ti.code transpose.code 
 FFLAGS  =  $(FCFLAGS) -I$(NETCDFPATH)/include -I../ioapi_share
 LIBS    = $(LIB_LOCAL) -L$(NETCDFPATH)/lib -lnetcdf
-CPP1    = $(CPP) -C -P $(TRADFLAG)
+LIBFFS  = $(LIB_LOCAL) -L$(NETCDFPATH)/lib -lnetcdff -lnetcdf
+CPP1    = $(CPP) -P $(TRADFLAG)
 M4      = m4 -Uinclude -Uindex -Ulen
 AR      = ar
 
@@ -49,8 +50,8 @@ diffwrf:                diffwrf.F90
 	$(FC) -c $(FFLAGS) diffwrf.f
 	@if [ \( -f ../../frame/wrf_debug.o \) -a \( -f ../../frame/module_wrf_error.o \) -a \( -f $(ESMF_MOD_DEPENDENCE) \) -a \( -f ../../frame/clog.o \) ] ; then \
 	  echo "diffwrf io_netcdf is being built now. " ; \
-          if [ \( -f $(NETCDFPATH)/lib/libnetcdff.a \) ] ; then \
-            $(FC) $(FFLAGS) $(LDFLAGS) -o diffwrf diffwrf.o $(OBJSL) ../../frame/wrf_debug.o ../../frame/module_wrf_error.o ../../frame/clog.o $(ESMF_IO_LIB_EXT) $(LIBS) -L$(NETCDFPATH)/lib -lnetcdff ;\
+          if [ \( -f $(NETCDFPATH)/lib/libnetcdff.a -o -f $(NETCDFPATH)/lib/libnetcdff.so \) ] ; then \
+            $(FC) $(FFLAGS) $(LDFLAGS) -o diffwrf diffwrf.o $(OBJSL) ../../frame/wrf_debug.o ../../frame/module_wrf_error.o ../../frame/clog.o $(ESMF_IO_LIB_EXT) $(LIBFFS) ;\
           else \
             $(FC) $(FFLAGS) $(LDFLAGS) -o diffwrf diffwrf.o $(OBJSL) ../../frame/wrf_debug.o ../../frame/module_wrf_error.o ../../frame/clog.o $(ESMF_IO_LIB_EXT) $(LIBS) ;\
           fi ; \
diff --git a/wrfv2_fire/external/io_netcdf/wrf_io.F90 b/wrfv2_fire/external/io_netcdf/wrf_io.F90
index 432a3c7a..8f5e1e3c 100644
--- a/wrfv2_fire/external/io_netcdf/wrf_io.F90
+++ b/wrfv2_fire/external/io_netcdf/wrf_io.F90
@@ -92,6 +92,7 @@ module wrf_data
 ! to .FALSE. when the first field is read or written.  
     logical                               :: first_operation
     logical                               :: R4OnOutput
+    logical                               :: nofill
     logical                               :: use_netcdf_classic
   end type wrf_data_handle
   type(wrf_data_handle),target            :: WrfDataHandles(WrfDataHandleMax)
@@ -203,6 +204,7 @@ subroutine allocHandle(DataHandle,DH,Comm,Status)
   DH%Write     =.false.
   DH%first_operation  = .TRUE.
   DH%R4OnOutput = .false.
+  DH%nofill = .false.
   Status = WRF_NO_ERR
 end subroutine allocHandle
 
@@ -1388,6 +1390,10 @@ SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHand
   if (index(SysDepInfo,'REAL_OUTPUT_SIZE=4') /= 0) then
      DH%R4OnOutput = .true.
   end if
+!toggle on nofill mode
+  if (index(SysDepInfo,'NOFILL=.TRUE.') /= 0) then
+     DH%nofill = .true.
+  end if
 
   return
 end subroutine ext_ncd_open_for_write_begin
@@ -1423,6 +1429,7 @@ SUBROUTINE ext_ncd_open_for_write_commit(DataHandle, Status)
   type(wrf_data_handle),pointer     :: DH
   integer                           :: i
   integer                           :: stat
+  integer                           :: oldmode  ! for nf_set_fill, not used
 
   if(WrfIOnotInitialized) then
     Status = WRF_IO_NOT_INITIALIZED 
@@ -1436,6 +1443,16 @@ SUBROUTINE ext_ncd_open_for_write_commit(DataHandle, Status)
     call wrf_debug ( WARN , TRIM(msg)) 
     return
   endif
+  if ( DH%nofill ) then
+    Status = NF_SET_FILL(DH%NCID,NF_NOFILL, oldmode )
+    if(Status /= WRF_NO_ERR) then
+      write(msg,*) 'Warning Status = ',Status,' from NF_SET_FILL ',__FILE__,', line', __LINE__
+      call wrf_debug ( WARN , TRIM(msg)) 
+      return
+    endif
+    write(msg,*) 'Information: NOFILL being set for writing to ',TRIM(DH%FileName)
+    call wrf_debug ( WARN , TRIM(msg)) 
+  endif
   stat = NF_ENDDEF(DH%NCID)
   call netcdf_err(stat,Status)
   if(Status /= WRF_NO_ERR) then
@@ -1572,6 +1589,8 @@ subroutine ext_ncd_redef( DataHandle, Status)
     call wrf_debug ( WARN , TRIM(msg))
   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then
     continue
+  elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then
+    continue
   elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then
     Status = WRF_WARN_FILE_OPEN_FOR_READ
     write(msg,*) 'Warning FILE OPEN FOR READ in ',__FILE__,', line', __LINE__
diff --git a/wrfv2_fire/external/io_phdf5/Makefile b/wrfv2_fire/external/io_phdf5/Makefile
index 7fc3b5dc..c92cd88b 100644
--- a/wrfv2_fire/external/io_phdf5/Makefile
+++ b/wrfv2_fire/external/io_phdf5/Makefile
@@ -7,7 +7,7 @@ FFLAGS  =  $(OPTS) -I$(PHDF5PATH)/lib -I../ioapi_share
 FORTRANLIB=-I$(PHDF5PATH)/lib $(PHDF5PATH)/lib/libhdf5_fortran.a
 LIBSHDF = $(FORTRANLIB) $(PHDF5PATH)/lib/libhdf5.a
 LIB     =-lm -lz
-CPP     = /lib/cpp -C -P $(TRADFLAG)
+CPP     = /lib/cpp -P $(TRADFLAG)
 M4      = m4 -Uinclude -Uindex -Ulen
 AR      = ar
 
diff --git a/wrfv2_fire/external/io_pnetcdf/makefile b/wrfv2_fire/external/io_pnetcdf/makefile
index 4c281d75..b29510bc 100644
--- a/wrfv2_fire/external/io_pnetcdf/makefile
+++ b/wrfv2_fire/external/io_pnetcdf/makefile
@@ -5,7 +5,7 @@ OBJS    = $(OBJSL)
 CODE    = ext_pnc_get_dom_ti.code ext_pnc_get_var_td.code ext_pnc_get_var_ti.code ext_pnc_put_dom_ti.code ext_pnc_put_var_td.code ext_pnc_put_var_ti.code transpose.code 
 FFLAGS  =  $(FCFLAGS) -I$(NETCDFPATH)/include -I../ioapi_share
 LIBS    = -L$(NETCDFPATH)/lib -lnetcdf
-CPP1    = $(CPP) -C -P $(TRADFLAG)
+CPP1    = $(CPP) -P $(TRADFLAG)
 M4      = m4 -Uinclude -Uindex -Ulen
 AR      = ar
 
diff --git a/wrfv2_fire/frame/Makefile b/wrfv2_fire/frame/Makefile
index 1389b9dc..a4168fac 100644
--- a/wrfv2_fire/frame/Makefile
+++ b/wrfv2_fire/frame/Makefile
@@ -30,7 +30,9 @@ MODULES =       module_driver_constants.o  \
                 module_dm.o                \
                 module_quilt_outbuf_ops.o  \
                 module_io_quilt.o          \
-		module_intermediate_nmm.o
+		module_intermediate_nmm.o  \
+		module_cpl.o               \
+		module_cpl_oasis3.o
 ALOBJS =\
                 module_alloc_space_0.o       \
                 module_alloc_space_1.o       \
diff --git a/wrfv2_fire/frame/module_bdywrite.F b/wrfv2_fire/frame/module_bdywrite.F
index 2bcfee6f..9a9052ca 100644
--- a/wrfv2_fire/frame/module_bdywrite.F
+++ b/wrfv2_fire/frame/module_bdywrite.F
@@ -4,6 +4,7 @@ module module_bdywrite
 #ifdef EXTRA_HWRF_DEBUG_STUFF
   private
   public :: bdywrite
+  CHACARCTER (LEN=256) , PRIVATE :: a_message
 contains
   subroutine bdywrite(grid,filename)
     use module_domain_type, only: domain
@@ -128,7 +129,7 @@ subroutine bdywrite(grid,filename)
                           ,IMS,IME,JMS,JME,KMS,KME                    &
                           ,IPS,IPE,JPS,JPE,KPS,KPE )
 
-    write(0,*) "Sam's special boundary output (TM) for domain ",grid%id
+    write(a_message,*) "Sam's special boundary output (TM) for domain ",grid%id ; CALL wrf_message ( a_message )
     ! call CHECK_MOIST('MOIST',grid%moist,PARAM_FIRST_SCALAR, num_moist, &
     !        grid%moist_bxs,grid%moist_bxe, &
     !        grid%moist_bys,grid%moist_bye, &
@@ -192,14 +193,30 @@ subroutine bdywrite(grid,filename)
     if(f_qnr) write_vars3d_part(qnr,scalar,real,p_qnr)
     if(f_qni) write_vars3d_part(qni,scalar,real,p_qni)
 
-    if(f_qv) write(0,*) f_qv,p_qv
-    if(f_qc) write(0,*) f_qc,p_qc
-    if(f_qr) write(0,*) f_qr,p_qr
-    if(f_qi) write(0,*) f_qi,p_qi
-    if(f_qg) write(0,*) f_qg,p_qg
-    if(f_qs) write(0,*) f_qs,p_qs
-    if(f_qnr) write(0,*) f_qnr,p_qnr
-    if(f_qni) write(0,*) f_qni,p_qni
+    if(f_qv) then
+       write(a_message,*) f_qv,p_qv ; CALL wrf_message ( a_message )
+    endif
+    if(f_qc) then
+       write(a_message,*) f_qc,p_qc ; CALL wrf_message ( a_message )
+    endif
+    if(f_qr) then
+       write(a_message,*) f_qr,p_qr ; CALL wrf_message ( a_message )
+    endif
+    if(f_qi) then
+       write(a_message,*) f_qi,p_qi ; CALL wrf_message ( a_message )
+    endif
+    if(f_qg) then
+       write(a_message,*) f_qg,p_qg ; CALL wrf_message ( a_message )
+    endif
+    if(f_qs) then
+       write(a_message,*) f_qs,p_qs ; CALL wrf_message ( a_message )
+    endif
+    if(f_qnr) then
+       write(a_message,*) f_qnr,p_qnr ; CALL wrf_message ( a_message )
+    endif
+    if(f_qni) then
+       write(a_message,*) f_qni,p_qni ; CALL wrf_message ( a_message )
+    endif
 !    write_vars2d(utemp,real)
 !    write_vars2d(vtemp,real)
 !    write_vars2d(ttemp,real)
@@ -208,7 +225,7 @@ subroutine bdywrite(grid,filename)
 !    write_vars2d(cwmtemp,real)
 
     assert(nf_close(fid))
-    write(0,*) "Finished Sam's special boundary output (TM) for domain ",grid%id
+    write(a_message,*) "Finished Sam's special boundary output (TM) for domain ",grid%id ; CALL wrf_message ( a_message )
 
   end subroutine bdywrite
 
diff --git a/wrfv2_fire/frame/module_cpl.F b/wrfv2_fire/frame/module_cpl.F
new file mode 100644
index 00000000..f55193f6
--- /dev/null
+++ b/wrfv2_fire/frame/module_cpl.F
@@ -0,0 +1,521 @@
+MODULE module_cpl
+
+   USE module_domain          , ONLY : domain, get_ijk_from_grid
+   USE module_configure       , ONLY : grid_config_rec_type
+   USE module_model_constants , ONLY : stbolt
+   USE module_driver_constants, ONLY : max_domains, max_cplfld, max_extdomains
+   USE module_cpl_oasis3 
+
+   IMPLICIT NONE
+   PRIVATE
+
+   PUBLIC cpl_init
+   PUBLIC cpl_set_dm_communicator
+   PUBLIC cpl_defdomain
+   PUBLIC cpl_settime
+   PUBLIC cpl_snd
+   PUBLIC cpl_rcv
+   PUBLIC cpl_store_input
+   PUBLIC cpl_finalize
+   PUBLIC cpl_abort
+
+#ifdef key_cpp_oasis3
+   LOGICAL     , PARAMETER, PUBLIC :: coupler_on = .TRUE.
+   CHARACTER(5), PARAMETER         :: coupler_name = 'oasis'
+#else
+   LOGICAL     , PARAMETER, PUBLIC :: coupler_on = .FALSE.
+   CHARACTER(4), PARAMETER         :: coupler_name = 'none'
+#endif
+   INTEGER :: nsecrun             ! current time in seconds since simulation restart
+   INTEGER, PARAMETER :: charlen = 64
+   CHARACTER(charlen), DIMENSION(max_domains,max_extdomains,max_cplfld) :: rcvname, sndname   ! coupling fields names for each nest
+
+   CHARACTER(256) :: cltxt        ! messages or debug string
+   INTEGER :: nlevdbg  = 1        ! verbosity level
+   INTEGER :: nlevdbg2 = 10       ! verbosity level
+
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+   INCLUDE 'mpif.h'               ! only for MPI_COMM_NULL
+#else
+   INTEGER :: MPI_COMM_NULL = -1  ! define a fake (and not used) MPI_COMM_NULL, so it is compiling
+#endif
+
+CONTAINS
+
+   SUBROUTINE cpl_init( kl_comm ) 
+      !!-------------------------------------------------------------------
+      !!             ***  ROUTINE cpl_init  ***
+      !!
+      !! ** Purpose :   initialise coupling field names and WRF-coupler MPI communications
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(OUT) :: kl_comm       ! local MPI communicator of the model
+      !
+      INTEGER       :: jwrf,jext,jfld       ! local loop indicees
+      CHARACTER( 3) :: clwrfdom, clextdom   ! d
+      CHARACTER(16) :: clprefix             ! 'WRF_d??_EXT_d??_'
+      !!--------------------------------------------------------------------
+
+      ! coupling field name default definition
+      rcvname(:,:,:) = 'not defined'
+      sndname(:,:,:) = 'not defined'
+      
+      ! we could imagine to define rcvname and sndname through the namelist...
+      ! define all possible coupling names with _d of WRF and the external model(s)
+      DO jext = 1, max_extdomains
+         
+         WRITE(clextdom, fmt="('d',i2.2)") jext
+         
+         DO jwrf = 1, max_domains
+            
+            WRITE(clwrfdom, fmt="('d',i2.2)") jwrf          
+            ! do not change following syntaxe as it is used in routines bellow 
+            clprefix = 'WRF_'//clwrfdom//'_EXT_'//clextdom//'_' 
+            
+            ! Variables that can be received by WRF
+            rcvname(jwrf,jext,1) = clprefix//'SST'                  ! receive Sea surface temperature
+            rcvname(jwrf,jext,2) = clprefix//'UOCE'                 ! receive ocean zonal surface current 
+            rcvname(jwrf,jext,3) = clprefix//'VOCE'                 ! receive ocean meridional surface current 
+            
+            ! Variables that can be sent by WRF
+            sndname(jwrf,jext,1) = clprefix//'EVAP-PRECIP'          ! send net fresh water budget: evaporation - total précipitation
+            sndname(jwrf,jext,2) = clprefix//'SURF_NET_SOLAR'       ! send net short wave flux at ground surface
+            sndname(jwrf,jext,3) = clprefix//'SURF_NET_NON-SOLAR'   ! send net non-solar heat flux at ground surface
+            sndname(jwrf,jext,4) = clprefix//'TAUX'                 ! send zonal wind tress at atmosphere-ocean interface
+            sndname(jwrf,jext,5) = clprefix//'TAUY'                 ! send meridional wind tress at atmosphere-ocean interface
+            sndname(jwrf,jext,6) = clprefix//'TAUMOD'               ! send the wind tress module at atmosphere-ocean interface
+            
+         END DO
+      END DO
+      
+      IF ( coupler_name == 'oasis' ) CALL cpl_oasis_init( kl_comm ) 
+      
+   END SUBROUTINE cpl_init
+   
+
+   SUBROUTINE cpl_set_dm_communicator( kdm_comm )
+      !!-------------------------------------------------------------------
+      !!             ***  SUBROUTINE cpl_initquilt  ***
+      !!
+      !! ** Purpose : provide the computing nodes communicator to the coupler
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(IN) :: kdm_comm       ! MPI communicator between the computing nodes
+      !!--------------------------------------------------------------------
+
+      IF ( coupler_name == 'oasis' ) THEN 
+         IF ( kdm_comm == MPI_COMM_NULL ) THEN
+            CALL cpl_oasis_define( sndname, rcvname )   ! define io_quilting to OASIS
+         ELSE
+            CALL cpl_oasis_def_dmcomm( kdm_comm )       ! send the computing nodes communicator to OASIS
+         END IF
+      END IF
+
+   END SUBROUTINE cpl_set_dm_communicator
+
+
+   SUBROUTINE cpl_defdomain( grid )
+      !!-------------------------------------------------------------------
+      !!             ***  SUBROUTINE cpl_defdomain  ***
+      !!
+      !! ** Purpose : define each variable involved in the coupling and the grid partitioning
+      !!--------------------------------------------------------------------
+      TYPE(domain), INTENT(IN), POINTER ::   grid
+      !
+      INTEGER :: jwrf,jext,jfld          ! local loop indicees
+      REAL    :: zmin,zmax               ! min/max of grid*cplmask
+      INTEGER :: ips,ipe,jps,jpe,kps,kpe ! domain dimension on 1 processor
+      INTEGER :: ims,ime,jms,jme,kms,kme ! memory domain dimension on 1 processor 
+      INTEGER :: ids,ide,jds,jde,kds,kde ! domain dimension
+      !!--------------------------------------------------------------------
+#if (EM_CORE == 1)
+
+      CALL get_ijk_from_grid( grid, ids, ide, jds, jde, kds, kde, &
+         &                          ims, ime, jms, jme, kms, kme, &
+         &                          ips, ipe, jps, jpe, kps, kpe  )
+
+      ! first do some checks and prints. note that this could not be done in cpl_init
+      ! which is called too early in the code
+
+      ! some control prints on potential sent/received fields...
+      CALL wrf_debug(nlevdbg, 'cpl_init: defined variables to be potentially received' )
+      DO jfld = 1, max_cplfld
+         DO jext = 1, grid%num_ext_model_couple_dom
+            DO jwrf = 1, grid%max_dom
+               IF( TRIM(sndname(jwrf,jext,jfld)) /= 'not defined' ) THEN
+                  WRITE(cltxt,*) '   jwrf, jext, jfld: ', jwrf, jext, jfld ,' name: ', TRIM(sndname(jwrf,jext,jfld))
+                  CALL wrf_debug(nlevdbg2, cltxt)
+               END IF
+            END DO
+         END DO
+      END DO
+      CALL wrf_debug(nlevdbg, 'cpl_init: defined variables to be potentially sent' )
+      DO jfld = 1, max_cplfld
+         DO jext = 1, grid%num_ext_model_couple_dom
+            DO jwrf = 1, grid%max_dom
+               IF( TRIM(rcvname(jwrf,jext,jfld)) /= 'not defined' ) THEN
+                  WRITE(cltxt,*) '   jwrf, jext, jfld: ', jwrf, jext, jfld ,' name: ', TRIM(rcvname(jwrf,jext,jfld))
+                  CALL wrf_debug(nlevdbg2, cltxt)
+               END IF
+            END DO
+         END DO
+      END DO
+      
+      ! some checks on grid%cplmask...
+      DO jext = 1, grid%num_ext_model_couple_dom
+
+         WRITE(cltxt,*) 'checks on cplmask of external model domain: ', jext               ;   CALL wrf_debug(nlevdbg, cltxt)
+
+         zmin = MINVAL(grid%cplmask(ips:ipe,jext,jps:jpe))
+         IF( zmin < 0. ) THEN
+            WRITE(cltxt,*) 'min of external model domain cplmask: ',jext,' < 0. : ',zmin   ;   CALL cpl_abort('cpl_defdomain',cltxt)
+         END IF
+         WRITE(cltxt,*) '   minval(grid%cplmask(ips:ipe,jext,jps:jpe)): ', zmin            ;   CALL wrf_debug(nlevdbg, cltxt)
+
+         zmax = MAXVAL(grid%cplmask(ips:ipe,jext,jps:jpe))
+         IF( zmax > 1. ) THEN
+            WRITE(cltxt,*) 'max of external model domain cplmask: ',jext,' > 1. : ',zmax   ;   CALL cpl_abort('cpl_defdomain',cltxt)
+         END IF
+         IF( zmax == 0. ) THEN
+            WRITE(cltxt,*) 'max of external model domain cplmask: ',jext,' = 0 '           ;   CALL wrf_message(cltxt)
+            WRITE(cltxt,*) '  => no coupling between this external model domain and this WRF patch'   ;   CALL wrf_message(cltxt)
+         END IF
+         WRITE(cltxt,*) '   maxval(grid%cplmask(ips:ipe,jext,jps:jpe)): ', zmax            ;   CALL wrf_debug(nlevdbg, cltxt)
+
+      END DO
+#endif       
+      
+      IF ( coupler_name == 'oasis' ) CALL cpl_oasis_define( sndname, rcvname, grid )
+
+   END SUBROUTINE cpl_defdomain
+
+
+   SUBROUTINE cpl_settime( psec )
+      !!-------------------------------------------------------------------
+      !!             ***  SUBROUTINE cpl_settime  ***
+      !!
+      !! ** Purpose :   update and store the number of second since the beginning of the job.  
+      !!--------------------------------------------------------------------
+      REAL, INTENT(in) :: psec
+      !!--------------------------------------------------------------------
+
+      nsecrun = NINT( psec )
+      WRITE(cltxt,*) 'store number of second since the beginning of the job: ', nsecrun   ;   CALL wrf_debug(nlevdbg2, cltxt)
+
+   END SUBROUTINE cpl_settime
+
+
+   FUNCTION cpl_toreceive( kdomwrf, kdomext, kfldid )
+      !!-------------------------------------------------------------------
+      !!             ***  FUNCTION cpl_toreceive  ***
+      !!
+      !! ** Purpose :   send back a logical to tell if a variable must be received or not
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(IN) :: kdomwrf   ! wrf domain index
+      INTEGER, INTENT(IN) :: kdomext   ! external model domain index
+      INTEGER, INTENT(IN) :: kfldid    ! field index
+      !
+      LOGICAL :: cpl_toreceive
+      !!--------------------------------------------------------------------
+
+      IF ( coupler_name == 'oasis' ) cpl_toreceive = cpl_oasis_toreceive( kdomwrf, kdomext, kfldid ) 
+
+   END FUNCTION cpl_toreceive
+
+
+   FUNCTION cpl_tosend( kdomwrf, kfldid, max_edom )
+      !!-------------------------------------------------------------------
+      !!             ***  FUNCTION cpl_tosend  ***
+      !!
+      !! ** Purpose :   send back a logical array to tell if a variable must be
+      !!                sent or not to each of the external model domains
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(IN) :: kdomwrf   ! wrf domain index
+      INTEGER, INTENT(IN) :: kfldid    ! variable index
+      INTEGER, INTENT(IN) :: max_edom  ! max number of external model domains
+      !
+      LOGICAL,DIMENSION(max_edom) :: cpl_tosend
+      INTEGER                     :: jext          ! local loop indicees
+      !!--------------------------------------------------------------------
+
+      DO jext = 1, max_edom
+         IF ( coupler_name == 'oasis' )   cpl_tosend(jext) = cpl_oasis_tosend( kdomwrf, jext, kfldid ) 
+      END DO
+      
+   END FUNCTION cpl_tosend
+
+
+   FUNCTION cpl_get_fldid( cdsuffix )
+      !!-------------------------------------------------------------------
+      !!             ***  SUBROUTINE cpl_get_fldid  ***
+      !!
+      !! ** Purpose : send back the field id corresponding to the suffix of a coupling variable name
+      !!--------------------------------------------------------------------
+      CHARACTER(*), INTENT(IN) :: cdsuffix   ! field name suffix
+      !
+      INTEGER       :: cpl_get_fldid     ! field index
+      INTEGER       :: jfld              ! local loop indicees
+      CHARACTER(16) :: clprefix          ! 'WRF_d01_EXT_d01_'
+      !!--------------------------------------------------------------------
+      cpl_get_fldid = -1   ! default value
+         
+      clprefix = 'WRF_d01_EXT_d01_' 
+      DO jfld = 1, max_cplfld
+         IF( clprefix//TRIM(cdsuffix) == TRIM(sndname(1,1,jfld)) )   cpl_get_fldid = jfld
+         IF( clprefix//TRIM(cdsuffix) == TRIM(rcvname(1,1,jfld)) )   cpl_get_fldid = jfld
+      END DO
+          
+      IF( cpl_get_fldid == -1 )   CALL cpl_abort( 'cpl_get_fldid', 'variable suffix not found '//TRIM(cdsuffix) )
+      WRITE(cltxt,*) 'The id of variable'//TRIM(cdsuffix)//' is: ', cpl_get_fldid   ;   CALL wrf_debug(nlevdbg2, cltxt)
+
+   END FUNCTION cpl_get_fldid
+
+   
+   SUBROUTINE cpl_snd( grid )
+         !!-------------------------------------------------------------------
+      !!             ***  SUBROUTINE cpl_snd  ***
+      !!
+      !! ** Purpose : compute coupling data to be sent and call cpl_sndfield
+      !!--------------------------------------------------------------------
+      TYPE(domain), INTENT(IN), POINTER :: grid
+      !
+      INTEGER :: ips,ipe,jps,jpe,kps,kpe ! domain dimension on 1 processor
+      INTEGER :: ims,ime,jms,jme,kms,kme ! memory domain dimension on 1 processor 
+      INTEGER :: ids,ide,jds,jde,kds,kde ! domain dimension
+      !!--------------------------------------------------------------------
+      CALL get_ijk_from_grid( grid, ids, ide, jds, jde, kds, kde, &
+         &                          ims, ime, jms, jme, kms, kme, &
+         &                          ips, ipe, jps, jpe, kps, kpe  )
+
+#if (EM_CORE == 1)
+      CALL cpl_snd2( grid, grid%num_ext_model_couple_dom,   &
+         &                 ids, ide, jds, jde, kds, kde,    &
+         &                 ims, ime, jms, jme, kms, kme,    &
+         &                 ips, ipe, jps, jpe, kps, kpe )
+#endif
+
+   END SUBROUTINE cpl_snd
+
+
+   SUBROUTINE cpl_snd2( grid, max_edom                &
+      &                     , ids,ide,jds,jde,kds,kde &
+      &                     , ims,ime,jms,jme,kms,kme &
+      &                     , ips,ipe,jps,jpe,kps,kpe )
+      !!-------------------------------------------------------------------
+      !!             ***  SUBROUTINE cpl_snd2  ***
+      !!
+      !! ** Purpose : compute coupling data to be sent and call cpl_sndfield
+      !!--------------------------------------------------------------------
+      TYPE(domain), INTENT(IN), POINTER :: grid
+      INTEGER,      INTENT(IN)          :: max_edom    ! max number of external model domains
+      INTEGER,      INTENT(IN)          :: ids,ide,jds,jde,kds,kde
+      INTEGER,      INTENT(IN)          :: ims,ime,jms,jme,kms,kme
+      INTEGER,      INTENT(IN)          :: ips,ipe,jps,jpe,kps,kpe
+      !
+      REAL, DIMENSION( ips:ipe, jps:jpe ) :: cplsnd
+      REAL, DIMENSION( ips:ipe, jps:jpe ) :: u_uo
+      REAL, DIMENSION( ips:ipe, jps:jpe ) :: v_vo
+      REAL, DIMENSION( ips:ipe, jps:jpe ) :: wspd
+      REAL, DIMENSION( ips:ipe, jps:jpe ) :: taut
+      INTEGER :: icnt
+      INTEGER :: ifldid
+      LOGICAL,DIMENSION(max_edom) :: lltosend
+      !!--------------------------------------------------------------------
+
+#if (EM_CORE == 1)
+
+      ! we use ipe and not min(ipe, ide-1) the variable we are using are coming from grid and are therefore initialized to 0  
+      
+      ifldid      = cpl_get_fldid( 'EVAP-PRECIP' )
+      lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
+      IF ( COUNT(lltosend) > 0 ) THEN 
+         cplsnd(ips:ipe,jps:jpe) = grid%QFX(ips:ipe,jps:jpe) &
+            &                  - ( grid%RAINCV(ips:ipe,jps:jpe)+grid%RAINNCV(ips:ipe,jps:jpe) ) / grid%DT
+         CALL cpl_sndfield( grid%id, lltosend, ifldid, cplsnd )
+      END IF
+      
+      ifldid      = cpl_get_fldid( 'SURF_NET_SOLAR' )
+      lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
+      IF ( COUNT(lltosend) > 0 ) THEN 
+         CALL cpl_sndfield( grid%id, lltosend, ifldid, grid%GSW(ips:ipe,jps:jpe) )
+      END IF
+      
+      ifldid      = cpl_get_fldid( 'SURF_NET_NON-SOLAR' )
+      lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
+      IF ( COUNT(lltosend) > 0 ) THEN 
+         cplsnd(ips:ipe,jps:jpe) = grid%GLW(ips:ipe,jps:jpe) &
+            &                      - STBOLT * grid%EMISS(ips:ipe,jps:jpe) * grid%SST(ips:ipe,jps:jpe)**4 &
+            &                      - grid%LH(ips:ipe,jps:jpe) - grid%HFX(ips:ipe,jps:jpe) 
+         CALL cpl_sndfield( grid%id, lltosend, ifldid, cplsnd )
+      END IF
+      
+      ! test if we need to compute the module of the wind speed and stres
+      icnt   =        COUNT( cpl_tosend( grid%id, cpl_get_fldid( 'TAUMOD' ), max_edom ) )
+      icnt   = icnt + COUNT( cpl_tosend( grid%id, cpl_get_fldid( 'TAUX'   ), max_edom ) )
+      icnt   = icnt + count( cpl_tosend( grid%id, cpl_get_fldid( 'TAUY'   ), max_edom ) )
+      IF ( icnt > 0 ) THEN 
+         u_uo(ips:ipe,jps:jpe) = grid%u_phy(ips:ipe,kps,jps:jpe) - grid%uoce(ips:ipe,jps:jpe)
+         v_vo(ips:ipe,jps:jpe) = grid%v_phy(ips:ipe,kps,jps:jpe) - grid%voce(ips:ipe,jps:jpe)
+         wspd(ips:ipe,jps:jpe) = MAX( SQRT( u_uo(ips:ipe,jps:jpe)**2 + v_vo(ips:ipe,jps:jpe)**2 ), 1.e-7 )
+         taut(ips:ipe,jps:jpe) = grid%rho(ips:ipe,kps,jps:jpe) * grid%ust(ips:ipe,jps:jpe)**2
+      END IF
+      
+      ifldid      = cpl_get_fldid( 'TAUX' )
+      lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
+      IF ( COUNT(lltosend) > 0 ) THEN 
+         cplsnd(ips:ipe,jps:jpe) = taut(ips:ipe,jps:jpe) * u_uo(ips:ipe,jps:jpe) / wspd(ips:ipe,jps:jpe)
+         CALL cpl_sndfield( grid%id, lltosend, ifldid, cplsnd )
+      END IF
+      
+      ifldid      = cpl_get_fldid( 'TAUY' )
+      lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
+      IF ( COUNT(lltosend) > 0 ) THEN 
+         cplsnd(ips:ipe,jps:jpe) = taut(ips:ipe,jps:jpe) * v_vo(ips:ipe,jps:jpe) / wspd(ips:ipe,jps:jpe)
+         CALL cpl_sndfield( grid%id, lltosend, ifldid, cplsnd )
+      END IF
+      
+      ifldid      = cpl_get_fldid( 'TAUMOD' )
+      lltosend(:) = cpl_tosend( grid%id, ifldid, max_edom )
+      IF ( COUNT(lltosend) > 0 ) THEN 
+         CALL cpl_sndfield( grid%id, lltosend, ifldid, taut )
+      END IF
+      
+#endif       
+   END SUBROUTINE cpl_snd2
+
+
+   SUBROUTINE cpl_sndfield( kdomwrf, ldtosend, kfldid, pdata )
+      !!-------------------------------------------------------------------
+      !!             ***  SUBROUTINE cpl_rcv  ***
+      !!
+      !! ** Purpose :   send coupling data
+      !!--------------------------------------------------------------------
+      INTEGER,              INTENT(IN) :: kdomwrf   ! wrf domain index
+      LOGICAL,DIMENSION(:), INTENT(IN) :: ldtosend
+      INTEGER,              INTENT(IN) :: kfldid    ! field index
+      REAL, DIMENSION(:,:), INTENT(IN) :: pdata     ! data to be sent
+      !
+      INTEGER :: jext          ! local loop indicees
+      !!--------------------------------------------------------------------
+
+      DO jext = 1, SIZE(ldtosend)
+         IF( ldtosend(jext) ) THEN
+            IF ( coupler_name == 'oasis' ) CALL cpl_oasis_snd( kdomwrf, jext, kfldid, nsecrun, pdata )
+         END IF
+      END DO
+
+   END SUBROUTINE cpl_sndfield
+
+
+   SUBROUTINE cpl_rcv( kdomwrf, cdsuffix,            &
+      &                ids, ide, jds, jde, kds, kde, &
+      &                ims, ime, jms, jme, kms, kme, &
+      &                ips, ipe, jps, jpe, kps, kpe, &
+      &                max_edom, pcplmask, pdatacpl, pdataobs )
+      !!-------------------------------------------------------------------
+      !!             ***  SUBROUTINE cpl_rcv  ***
+      !!
+      !! ** Purpose :   receive coupling data
+      !!--------------------------------------------------------------------
+      INTEGER,                                                   INTENT(IN   ) :: kdomwrf     ! wrf domain index
+      CHARACTER(*),                                              INTENT(IN   ) :: cdsuffix    ! field name suffix
+      INTEGER,                                                   INTENT(IN   ) :: ids,ide,jds,jde,kds,kde
+      INTEGER,                                                   INTENT(IN   ) :: ims,ime,jms,jme,kms,kme
+      INTEGER,                                                   INTENT(IN   ) :: ips,ipe,jps,jpe,kps,kpe
+      INTEGER,                                                   INTENT(IN   ) :: max_edom    ! max number of external model domains
+      REAL, DIMENSION( ims:ime, 1:max_edom, jms:jme ),           INTENT(IN   ) :: pcplmask    ! coupling mask
+      REAL, DIMENSION( ims:ime,             jms:jme ),           INTENT(  OUT) :: pdatacpl    ! coupling data
+      REAL, DIMENSION( ims:ime,             jms:jme ), OPTIONAL, INTENT(IN   ) :: pdataobs    ! observed data to be merged
+      !
+      INTEGER :: jext                                ! external domain index
+      INTEGER :: ifldid                              ! field index
+      REAL, DIMENSION( ips:ipe, jps:jpe ) :: zdata   ! data received from the coupler
+      !!--------------------------------------------------------------------
+
+      ifldid = cpl_get_fldid( cdsuffix )
+         
+      IF( PRESENT(pdataobs) ) THEN
+         pdatacpl(ips:ipe,jps:jpe) = pdataobs(ips:ipe,jps:jpe) * ( 1.0 - SUM( pcplmask(ips:ipe,1:max_edom,jps:jpe), dim = 2 ) )
+      ELSE 
+         pdatacpl(ips:ipe,jps:jpe) = 0.0
+      END IF
+
+      DO jext = 1, max_edom
+         IF( cpl_toreceive( kdomwrf, jext, ifldid ) ) THEN
+            IF( coupler_name == 'oasis' )   CALL cpl_oasis_rcv( kdomwrf, jext, ifldid, nsecrun, zdata )
+            pdatacpl(ips:ipe,jps:jpe) = pdatacpl(ips:ipe,jps:jpe) + zdata(ips:ipe,jps:jpe) * pcplmask(ips:ipe,jext,jps:jpe)
+         END IF
+      END DO
+
+   END SUBROUTINE cpl_rcv
+
+
+   SUBROUTINE cpl_store_input( grid, config_flags )
+      !!-------------------------------------------------------------------
+      !!             ***  SUBROUTINE cpl_store_input  ***
+      !!
+      !! ** Purpose : Store input data that will be merged later with data received from the coupler
+      !!--------------------------------------------------------------------
+      TYPE(domain)                , INTENT(INOUT) :: grid
+      TYPE (grid_config_rec_type) , INTENT(IN   ) :: config_flags
+      !
+      INTEGER :: ips,ipe,jps,jpe,kps,kpe ! domain dimension on 1 processor
+      INTEGER :: ims,ime,jms,jme,kms,kme ! memory domain dimension on 1 processor 
+      INTEGER :: ids,ide,jds,jde,kds,kde ! domain dimension
+      LOGICAL :: llmust_store
+      INTEGER :: jext          ! local loop indicees     
+      !!--------------------------------------------------------------------
+
+#if (EM_CORE == 1)
+      CALL get_ijk_from_grid( grid, ids, ide, jds, jde, kds, kde, &
+         &                          ims, ime, jms, jme, kms, kme, &
+         &                          ips, ipe, jps, jpe, kps, kpe  )
+      
+      ! take care of variables read in AUXINPUT4... 
+      ! AUXINPUT4 was just read if:
+      ! 1) We asked (legally) for an AUXINPUT4 input AND this is the first time step AFTER an auxinput4_alarm was ringing
+      ! OR
+      ! 2) This is the first time step
+      IF( ( config_flags%auxinput4_interval .NE. 0 .AND. config_flags%io_form_auxinput4 .NE. 0 .AND. grid%just_read_auxinput4 ) &
+         .OR. grid%itimestep .EQ. 1 ) THEN
+         
+         ! if we receive the SST, we need to store it in SST_INPUT
+         llmust_store = .FALSE.
+         DO jext = 1, grid%num_ext_model_couple_dom
+            llmust_store = llmust_store .OR. cpl_toreceive( grid%id, jext, cpl_get_fldid( 'SST' ) )
+         END DO
+         IF( llmust_store )   grid%sst_input(ips:ipe,jps:jpe) = grid%sst(ips:ipe,jps:jpe)   ! store SST into SST_INPUT 
+         
+         grid%just_read_auxinput4 = .FALSE.  ! the work as been done and not me done again until we reread data from AUXINPUT4
+      
+      END IF
+#endif      
+ 
+   END SUBROUTINE cpl_store_input
+
+
+   SUBROUTINE cpl_finalize()
+      !!-------------------------------------------------------------------
+      !!             ***  SUBROUTINE cpl_finalize  ***
+      !!
+      !! ** Purpose :   cpl_finalize MPI communications with the coupler
+      !!--------------------------------------------------------------------
+      IF ( coupler_name == 'oasis' ) CALL cpl_oasis_finalize()
+
+   END SUBROUTINE cpl_finalize
+
+
+   SUBROUTINE cpl_abort( cdroutine, cdtxt )
+      !!-------------------------------------------------------------------
+      !!             ***  SUBROUTINE cpl_abort  ***
+      !!
+      !! ** Purpose :   abort coupling simulation
+      !!--------------------------------------------------------------------
+      CHARACTER(*), INTENT(IN) :: cdroutine   ! name of the subroutine calling cpl_oasis_abort
+      CHARACTER(*), INTENT(IN) :: cdtxt       ! aborting text
+      !!--------------------------------------------------------------------
+
+      IF ( coupler_name == 'oasis' ) CALL cpl_oasis_abort( cdroutine, cdtxt )
+
+   END SUBROUTINE cpl_abort
+
+
+END MODULE module_cpl
diff --git a/wrfv2_fire/frame/module_cpl_oasis3.F b/wrfv2_fire/frame/module_cpl_oasis3.F
new file mode 100644
index 00000000..f7d96cec
--- /dev/null
+++ b/wrfv2_fire/frame/module_cpl_oasis3.F
@@ -0,0 +1,531 @@
+ MODULE module_cpl_oasis3
+#ifdef key_cpp_oasis3
+   !!======================================================================
+   !!                    ***  MODULE cpl_oasis  ***
+   !! Coupled O/A : coupled ocean-atmosphere case using OASIS3-MCT
+   !!=====================================================================
+   !!----------------------------------------------------------------------
+   !!   cpl_oasis_init     : initialization of coupled mode communication
+   !!   cpl_oasis_define   : definition of grid and fields
+   !!   cpl_oasis_snd      : send out fields in coupled mode
+   !!   cpl_oasis_rcv      : receive fields in coupled mode
+   !!   cpl_oasis_finaliz : finalize the coupled mode communication
+   !!----------------------------------------------------------------------
+
+   USE module_domain          , ONLY : domain, get_ijk_from_grid
+   USE module_driver_constants, ONLY : max_domains, max_cplfld, max_extdomains
+   USE mod_oasis              ! OASIS3-MCT module
+
+   IMPLICIT NONE
+   PRIVATE
+
+   TYPE ::   FLD_CPL                                  ! Coupling field information
+      CHARACTER(len = 64) ::   clname                    ! Name of the coupling field, jpeighty defined in oasis
+      INTEGER             ::   nid                       ! Id of the field
+#if ( RWORDSIZE == 8 )
+      REAL        , POINTER, DIMENSION(:,:) ::   dbl2d   ! 2d array to store received field 
+#else
+      REAL(kind=8), POINTER, DIMENSION(:,:) ::   dbl2d   ! 2d array to store received field 
+#endif
+   END TYPE FLD_CPL
+   TYPE(FLD_CPL), DIMENSION(max_domains,max_extdomains,max_cplfld) :: srcv, ssnd   ! Coupling fields informations
+   INTEGER :: ndm_comm                                                         ! MPI communicator between the computing nodes
+   INTEGER :: ncomp_id                                                         ! id returned by oasis_init_comp
+   INTEGER :: nlevdbg  = 1                                                     ! verbosity level
+   INTEGER :: nlevdbg2 = 10                                                    ! verbosity level
+   CHARACTER(len = 256) :: cltxt                                               ! messages or debug string
+
+   !! Routine accessibility
+   PUBLIC cpl_oasis_init
+   PUBLIC cpl_oasis_def_dmcomm
+   PUBLIC cpl_oasis_define
+   PUBLIC cpl_oasis_toreceive
+   PUBLIC cpl_oasis_tosend
+   PUBLIC cpl_oasis_snd
+   PUBLIC cpl_oasis_rcv
+   PUBLIC cpl_oasis_finalize
+   PUBLIC cpl_oasis_abort
+
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+   INCLUDE 'mpif.h'               ! only for MPI_COMM_NULL
+#else
+   INTEGER :: MPI_COMM_NULL = -1  ! define a fake (and not used) MPI_COMM_NULL, so it is compiling 
+#endif
+
+CONTAINS
+
+   SUBROUTINE cpl_oasis_init( kl_comm ) 
+      !!-------------------------------------------------------------------
+      !!             ***  ROUTINE cpl_oasis_init  ***
+      !!
+      !! ** Purpose :   Initialize coupled mode communication for WRF
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(OUT) :: kl_comm       ! local communicator of the model
+      !
+      INTEGER :: ierror   ! return error code
+      !!--------------------------------------------------------------------
+
+      ! Initialize OASIS for the application
+      CALL oasis_init_comp( ncomp_id, 'wrfexe', ierror )
+      IF( ierror /= OASIS_Ok )   CALL cpl_oasis_abort( 'cpl_oasis_init', 'Failure in oasis_init_comp' )
+
+      ! Get an MPI communicator for WRF local communication
+      CALL oasis_get_localcomm( kl_comm, ierror )
+      IF( ierror /= OASIS_Ok )   CALL cpl_oasis_abort( 'cpl_oasis_init','Failure in oasis_get_localcomm' )
+
+      srcv(:,:,:)%nid = -1            ! default definition
+      ssnd(:,:,:)%nid = -1            ! default definition
+      ndm_comm        = MPI_COMM_NULL ! default definition, will be redefined by cpl_oasis_def_dmcomm if computing node
+
+   END SUBROUTINE cpl_oasis_init
+
+
+   SUBROUTINE cpl_oasis_def_dmcomm( kdm_comm ) 
+      !!-------------------------------------------------------------------
+      !!             ***  ROUTINE cpl_oasis_def_dmcomm  ***
+      !!
+      !! ** Purpose :   define ndm_comm: the MPI communicator between the computing nodes
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(IN) :: kdm_comm       ! computing nodes communicator
+      !!--------------------------------------------------------------------
+      ndm_comm = kdm_comm   ! store it to used it in cpl_oasis_define
+
+      WRITE(cltxt,*) 'cpl_oasis_def_dmcomm : ', kdm_comm
+      CALL wrf_debug(nlevdbg, cltxt)
+      CALL wrf_debug(nlevdbg, '~~~~~~~~~~~~~~~~~~~~~~~')
+
+   END SUBROUTINE cpl_oasis_def_dmcomm
+
+
+   SUBROUTINE cpl_oasis_define( cdsndname, cdrcvname, pgrid )
+      !!-------------------------------------------------------------------
+      !!             ***  ROUTINE cpl_oasis_define  ***
+      !!
+      !! ** Purpose :   Define grid and coupling field information for WRF
+      !!--------------------------------------------------------------------
+      CHARACTER(*), INTENT(IN), DIMENSION(:,:,:)  :: cdsndname, cdrcvname   ! coupling field names
+      TYPE(domain), INTENT(IN), OPTIONAL, POINTER :: pgrid                  ! grid structure
+      !
+      INTEGER :: ierror                  ! return error code
+      INTEGER :: idwrf1,idwrf2           ! loop index over wrf domain number (start and end)
+      INTEGER :: idext1,idext2           ! loop index over external model domain number (start and end)
+      INTEGER :: id_part                 ! partition id in oasis
+      INTEGER :: iparal(5)               ! OASIS box partition
+      INTEGER :: ishape(2,2)             ! shape of arrays passed to PSMILe
+      INTEGER :: jw,je,jf                ! local loop indicees
+      INTEGER :: ips,ipe,jps,jpe,kps,kpe ! domain dimension on 1 processor
+      INTEGER :: ims,ime,jms,jme,kms,kme ! memory domain dimension on 1 processor 
+      INTEGER :: ids,ide,jds,jde,kds,kde ! domain dimension
+      LOGICAL :: llcompute_core          ! is it a compiting core?
+      !!--------------------------------------------------------------------
+
+      CALL wrf_message('cpl_oasis_define : initialization in coupled ocean/atmosphere case')
+      CALL wrf_debug(nlevdbg, '~~~~~~~~~~~~~~~~~~~~~~~')
+
+      llcompute_core = PRESENT(pgrid)
+
+      ! -----------------------------------------------------------------
+      ! ... Define communicator used between computing cores      
+      CALL oasis_set_couplcomm( ndm_comm, ierror )               ! provide this communicator to OASIS3-MCT
+      IF ( ierror /= OASIS_Ok ) CALL cpl_oasis_abort( 'cpl_oasis_define', 'Failure in oasis_set_couplcomm')
+      
+      ! -----------------------------------------------------------------
+      ! ... Define the partition 
+      ! -----------------------------------------------------------------
+      IF( llcompute_core ) THEN
+         
+         ! ... get mpi domain position
+         CALL get_ijk_from_grid( pgrid, ids, ide, jds, jde, kds, kde, &
+            &                           ims, ime, jms, jme, kms, kme, &
+            &                           ips, ipe, jps, jpe, kps, kpe  )
+
+         ishape(:,1) = (/1, ipe-ips+1 /)
+         ishape(:,2) = (/1, jpe-jps+1 /)
+         
+         ! ... Define the partition parameteres
+         iparal(1) = 2                                      ! box partitioning
+         iparal(2) = ide * ( jps - 1 ) + (ips -1)
+         iparal(3) = ipe - ips + 1                          ! local extent in i 
+         iparal(4) = jpe - jps + 1                          ! local extent in j
+         iparal(5) = ide                                    ! global extent in x
+      
+         WRITE(cltxt,*) 'Define the partition for computing cores'   ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) ' multiexchg: iparal (1:5)', iparal          ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) ' multiexchg: ips, ipe =', ips, ipe          ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) ' multiexchg: jps, jpe =', jps, jpe          ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) ' multiexchg: ids, jds =', ids, jds          ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) ' multiexchg: ide, jde =', ide, jde          ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) ' multiexchg: ishape(:,1) =', ishape(:,1)    ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) ' multiexchg: ishape(:,2) =', ishape(:,2)    ;   CALL wrf_debug(nlevdbg, cltxt)
+
+      ELSE
+         CALL wrf_debug(nlevdbg, 'no partition for IO cores')
+         iparal(:) = 0   ! "fake" partition for IO cores
+      ENDIF
+      
+      CALL oasis_def_partition( id_part, iparal, ierror )
+      IF( ierror /= OASIS_Ok ) CALL cpl_oasis_abort( 'cpl_oasis_define', 'Failure in oasis_def_partition')
+
+      ! -----------------------------------------------------------------
+      ! ... Define the variables that can be send/received by WRF
+      ! -----------------------------------------------------------------
+      IF( llcompute_core ) THEN   ;   idwrf1 = pgrid%id   ;   idwrf2 = pgrid%id      ! coupling field related to this nest
+      ELSE                        ;   idwrf1 = 1          ;   idwrf2 = max_domains   ! define all (dummy) coupling fields
+      ENDIF
+
+      ! -----------------------------------------------------------------
+      ! ... Define sent variables. 
+      ! -----------------------------------------------------------------
+      DO jf = 1, max_cplfld
+         DO je = 1, max_extdomains
+            DO jw = idwrf1, idwrf2
+               ssnd(jw,je,jf)%clname = TRIM(cdsndname(jw,je,jf))
+               CALL oasis_def_var(ssnd(jw,je,jf)%nid, ssnd(jw,je,jf)%clname, id_part, (/2,1/), OASIS_Out, ishape, OASIS_Real,ierror)
+               IF( ierror /= OASIS_Ok ) THEN
+                  WRITE(cltxt,*) 'wrf domain ',jw,' external model domain ',je,   &
+                     ' field ',jf,' (',TRIM(ssnd(jw,je,jf)%clname),'): oasis_def_var failed'
+                  CALL wrf_message( cltxt )
+                  CALL cpl_oasis_abort( 'cpl_oasis_define', 'Failure in oasis_def_var')
+               ENDIF
+               WRITE(cltxt,*) 'cpl_oasis_define ok for :', TRIM(ssnd(jw,je,jf)%clname), ssnd(jw,je,jf)%nid 
+               CALL wrf_debug(nlevdbg2, cltxt)
+               IF( ssnd(jw,je,jf)%nid /= -1 ) THEN 
+                  WRITE(cltxt,*) ' var snd: ', ssnd(jw,je,jf)%nid, ' ', TRIM(ssnd(jw,je,jf)%clname), id_part 
+                  CALL wrf_debug(nlevdbg, cltxt)
+               ENDIF
+            END DO
+         END DO
+      END DO
+         
+      ! -----------------------------------------------------------------
+      ! ... Define received variables. 
+      ! -----------------------------------------------------------------
+      DO jf = 1, max_cplfld
+         DO je = 1, max_extdomains
+            DO jw = idwrf1, idwrf2
+               srcv(jw,je,jf)%clname = TRIM(cdrcvname(jw,je,jf))
+               CALL oasis_def_var(srcv(jw,je,jf)%nid, srcv(jw,je,jf)%clname, id_part, (/2,1/), OASIS_In , ishape, OASIS_Real,ierror)
+               IF( ierror /= OASIS_Ok ) THEN
+                  WRITE(cltxt,*) 'wrf domain ',jw,' external model domain ',je,   &
+                     ' field ',jf,' (',TRIM(srcv(jw,je,jf)%clname),'): oasis_def_var failed'
+                  CALL wrf_message( cltxt )
+                  CALL cpl_oasis_abort( 'cpl_oasis_define', 'Failure in oasis_def_var')
+               ENDIF
+               WRITE(cltxt,*) 'cpl_oasis_define ok for :', TRIM(srcv(jw,je,jf)%clname), srcv(jw,je,jf)%nid
+               CALL wrf_debug(nlevdbg2, cltxt)
+               IF( srcv(jw,je,jf)%nid /= -1 ) THEN
+                  WRITE(cltxt,*) ' var rcv: ', srcv(jw,je,jf)%nid, ' ', TRIM(srcv(jw,je,jf)%clname), id_part
+                  CALL wrf_debug(nlevdbg, cltxt)
+               END IF
+               IF( srcv(jw,je,jf)%nid /= -1 .AND. llcompute_core ) THEN   ! allocate received array
+                  ALLOCATE( srcv(jw,je,jf)%dbl2d( iparal(3), iparal(4) ), stat = ierror)
+                  IF (ierror > 0)   CALL cpl_oasis_abort( 'cpl_oasis_define', 'Failure in allocating srcv')
+               END IF
+            END DO
+         END DO
+      END DO
+
+      ! -----------------------------------------------------------------
+      ! ... End definition
+      ! -----------------------------------------------------------------
+      IF (llcompute_core) THEN 
+         IF ( pgrid%id == pgrid%max_dom ) CALL cpl_oasis_enddef()
+         CALL wrf_message('cpl_oasis_define (compute_core) : cpl_oasis_enddef done')
+      ELSE
+         CALL cpl_oasis_enddef()
+         CALL wrf_message('cpl_oasis_define (io_core) : cpl_oasis_enddef done')
+      ENDIF
+      
+   END SUBROUTINE cpl_oasis_define
+   
+   
+   SUBROUTINE cpl_oasis_enddef()
+      !!-------------------------------------------------------------------
+      !!             ***  ROUTINE cpl_oasis_enddef  ***
+      !!
+      !! ** Purpose :   tells to OASIS that exchanged field definition is finished
+      !!--------------------------------------------------------------------
+      INTEGER :: ierror         ! return error code
+      CALL oasis_enddef(ierror)
+      IF( ierror /= OASIS_Ok )   CALL cpl_oasis_abort( 'cpl_oasis_define', 'Failure in oasis_enddef')
+      
+   END SUBROUTINE cpl_oasis_enddef
+   
+   
+   FUNCTION cpl_oasis_toreceive( kdomwrf, kdomext, kfldid )
+      !!-------------------------------------------------------------------
+      !!             ***  FUNCTION cpl_oasis_toreceive  ***
+      !!
+      !! ** Purpose :   send back a logical to tell if a variable is received or not
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(IN) :: kdomwrf   ! wrf domain index
+      INTEGER, INTENT(IN) :: kdomext   ! external model domain index
+      INTEGER, INTENT(IN) :: kfldid    ! field index
+      !
+      LOGICAL :: cpl_oasis_toreceive
+      !!--------------------------------------------------------------------
+      
+      cpl_oasis_toreceive = srcv(kdomwrf,kdomext,kfldid)%nid /= -1
+
+   END FUNCTION cpl_oasis_toreceive
+
+
+   FUNCTION cpl_oasis_tosend( kdomwrf, kdomext, kfldid )
+      !!-------------------------------------------------------------------
+      !!             ***  FUNCTION cpl_oasis_tosend  ***
+      !!
+      !! ** Purpose :   send back a logical to tell if a variable is tosend or not
+      !!--------------------------------------------------------------------
+      INTEGER, INTENT(IN) :: kdomwrf   ! wrf domain index
+      INTEGER, INTENT(IN) :: kdomext   ! external model domain index
+      INTEGER, INTENT(IN) :: kfldid    ! field index
+      !
+      LOGICAL :: cpl_oasis_tosend
+      !!--------------------------------------------------------------------
+      
+      cpl_oasis_tosend = ssnd(kdomwrf,kdomext,kfldid)%nid /= -1
+
+   END FUNCTION cpl_oasis_tosend
+
+
+   SUBROUTINE cpl_oasis_snd( kdomwrf, kdomext, kfldid, ksec, pdata )
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE cpl_oasis_snd  ***
+      !!
+      !! ** Purpose : - At each coupling time-step,this routine sends fields to the coupler
+      !!----------------------------------------------------------------------
+      INTEGER,              INTENT(IN) :: kdomwrf   ! wrf domain index
+      INTEGER,              INTENT(IN) :: kdomext   ! external model domain index
+      INTEGER,              INTENT(IN) :: kfldid    ! field index
+      INTEGER,              INTENT(IN) :: ksec      ! time-step in seconds
+      REAL, DIMENSION(:,:), INTENT(IN) :: pdata     ! data to be sent
+      !!
+      INTEGER :: info              ! OASIS3 info argument
+      LOGICAL :: llaction          ! true if we sent data to the coupler
+      !!--------------------------------------------------------------------
+      !
+      WRITE(cltxt,*) 'OASIS_PUT in: kdomwrf, kdomext, kfldid, name, ksec', &
+         kdomwrf, kdomext, kfldid, ' ', TRIM(ssnd(kdomwrf,kdomext,kfldid)%clname), ksec
+      CALL wrf_debug(nlevdbg, cltxt)
+
+#if ( RWORDSIZE == 8 )
+      CALL oasis_put(ssnd(kdomwrf,kdomext,kfldid)%nid, ksec,      pdata(:,:) , info)
+#else
+      CALL oasis_put(ssnd(kdomwrf,kdomext,kfldid)%nid, ksec, DBLE(pdata(:,:)), info)
+#endif
+      
+      WRITE(cltxt,*) 'OASIS_PUT out: info', info   ;   CALL wrf_debug(nlevdbg, cltxt)
+
+      llaction = info == OASIS_Sent     .OR. info == OASIS_ToRest .OR.   &
+         &       info == OASIS_SentOut  .OR. info == OASIS_ToRestOut 
+
+      WRITE(cltxt,*) "llaction : ", llaction       ;   CALL wrf_debug(nlevdbg, cltxt)
+
+      IF( llaction ) THEN
+         WRITE(cltxt,*) '****************'                                                  ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) 'oasis_put: Incoming ', TRIM(ssnd(kdomwrf,kdomext,kfldid)%clname)   ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) 'oasis_put:    varid ', ssnd(kdomwrf,kdomext,kfldid)%nid            ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) 'oasis_put:     ksec ', ksec                                        ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) 'oasis_put:     info ', info                                        ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) '    - shape         ', SHAPE(pdata)                                ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) '    - minimum       ', MINVAL(pdata)                               ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) '    - maximum       ', MAXVAL(pdata)                               ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) '    - sum           ', SUM(pdata)                                  ;   CALL wrf_debug(nlevdbg, cltxt)
+         WRITE(cltxt,*) '****************'                                                  ;   CALL wrf_debug(nlevdbg, cltxt)
+      ELSE
+         WRITE(cltxt,*) 'field not sent as info=', info                                     ;   CALL wrf_debug(nlevdbg, cltxt)
+      ENDIF
+      
+    END SUBROUTINE cpl_oasis_snd
+
+
+   SUBROUTINE cpl_oasis_rcv( kdomwrf, kdomext, kfldid, ksec, pcplrcv )
+
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE cpl_oasis_rcv  ***
+      !!
+      !! ** Purpose : - At each coupling time-step, this routine check if it is the good time
+      !!                to receive field from the coupler
+      !!----------------------------------------------------------------------
+      INTEGER,              INTENT(IN   ) :: kdomwrf   ! wrf domain index
+      INTEGER,              INTENT(IN   ) :: kdomext   ! external model domain index
+      INTEGER,              INTENT(IN   ) :: kfldid    ! variable index
+      INTEGER,              INTENT(IN   ) :: ksec      ! number of seconds since the last restart
+      REAL, DIMENSION(:,:), INTENT(  OUT) :: pcplrcv   ! output data
+      !!
+      INTEGER :: info              ! OASIS3 info argument
+      LOGICAL :: llaction          ! true if we received data from the coupler
+      !!--------------------------------------------------------------------
+      !
+      WRITE(cltxt,*) 'OASIS_GET in: kdomwrf, kdomext, kfldid, name, ksec', &
+         kdomwrf, kdomext, kfldid, ' ', TRIM(srcv(kdomwrf,kdomext,kfldid)%clname), ksec
+      CALL wrf_debug(nlevdbg, cltxt)
+
+      CALL oasis_get( srcv(kdomwrf,kdomext,kfldid)%nid, ksec, srcv(kdomwrf,kdomext,kfldid)%dbl2d, info )
+#if ( RWORDSIZE == 8 )
+      pcplrcv(:,:) =      srcv(kdomwrf,kdomext,kfldid)%dbl2d
+#else
+      pcplrcv(:,:) = REAL(srcv(kdomwrf,kdomext,kfldid)%dbl2d, kind=4)
+#endif
+
+      WRITE(cltxt,*) 'OASIS_GET out: info', info   ;   CALL wrf_debug(nlevdbg, cltxt)
+
+      llaction = info == OASIS_Recvd   .OR. info == OASIS_FromRest .OR.   &
+         &       info == OASIS_RecvOut .OR. info == OASIS_FromRestOut 
+
+      WRITE(cltxt,*) "llaction : ", llaction       ;   CALL wrf_debug(nlevdbg, cltxt)
+
+      IF( llaction ) THEN
+            WRITE(cltxt,*) '****************'                                                   ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) 'oasis_get: Incoming ', TRIM(srcv(kdomwrf,kdomext,kfldid)%clname)    ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) 'oasis_get:    varid ', srcv(kdomwrf,kdomext,kfldid)%nid             ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) 'oasis_get:     ksec ', ksec                                         ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) 'oasis_get:     info ', info                                         ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) '    - shape         ', SHAPE(pcplrcv)                               ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) '    - local shape   ', SHAPE(srcv(kdomwrf, kdomext,kfldid)%dbl2d)   ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) '    - local minimum ', MINVAL(pcplrcv)                              ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) '    - local maximum ', MAXVAL(pcplrcv)                              ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) '    - local sum     ', SUM(pcplrcv)                                 ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) '****************'                                                   ;   CALL wrf_debug(nlevdbg, cltxt)
+      ELSE
+            WRITE(cltxt,*) '****************'                                                   ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) 'oasis_get: field not received as info = ', info                     ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) '    - local minimum ', MINVAL(pcplrcv)                              ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) '    - local maximum ', MAXVAL(pcplrcv)                              ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) '    - local sum     ', SUM(pcplrcv)                                 ;   CALL wrf_debug(nlevdbg, cltxt)
+            WRITE(cltxt,*) '****************'                                                   ;   CALL wrf_debug(nlevdbg, cltxt)
+      ENDIF
+
+   END SUBROUTINE cpl_oasis_rcv
+
+
+   SUBROUTINE cpl_oasis_finalize()
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE cpl_oasis_finalize  ***
+      !!
+      !! ** Purpose : - Finalizes the coupling. If MPI_init has not been
+      !!      called explicitly before cpl_oasis_init it will also close
+      !!      MPI communication.
+      !!----------------------------------------------------------------------
+      INTEGER :: ierror         ! return error code
+      INTEGER :: jw,je,jf       ! local loop indicees
+      !!--------------------------------------------------------------------
+      DO jf = 1, max_cplfld
+         DO je = 1, max_extdomains
+            DO jw = 1, max_domains
+               ierror = 0
+               IF ( ASSOCIATED(srcv(jw,je,jf)%dbl2d) ) DEALLOCATE( srcv(jw,je,jf)%dbl2d, stat = ierror )
+               IF (ierror > 0) THEN
+                  CALL cpl_oasis_abort( 'cpl_oasis_finalize', 'Failure in deallocating ')
+                  RETURN
+               ENDIF
+            END DO
+         END DO
+      END DO
+      CALL oasis_terminate ( ierror )         
+
+   END SUBROUTINE cpl_oasis_finalize
+
+
+   SUBROUTINE cpl_oasis_abort( cdroutine, cdtxt )
+      !!---------------------------------------------------------------------
+      !!              ***  ROUTINE cpl_oasis_abort  ***
+      !!
+      !! ** Purpose :   abort coupling simulation
+      !!----------------------------------------------------------------------
+      CHARACTER(*), INTENT(IN) :: cdroutine   ! name of the subroutine calling cpl_oasis_abort
+      CHARACTER(*), INTENT(IN) :: cdtxt       ! aborting text
+      !!--------------------------------------------------------------------
+
+      CALL wrf_message( '     ==== ABORTING ====' )
+      CALL wrf_message( 'cpl_abort called by '//TRIM(cdroutine) )
+      CALL wrf_message( '   ==> '//TRIM(cdtxt) )
+      CALL oasis_abort( ncomp_id, cdroutine, cdtxt )
+      
+   END SUBROUTINE cpl_oasis_abort
+   
+#else
+   !!----------------------------------------------------------------------
+   !!   Dummy modules just for compilation...
+   !!----------------------------------------------------------------------
+   USE module_domain, ONLY : domain
+   IMPLICIT NONE
+   PRIVATE
+   PUBLIC cpl_oasis_init
+   PUBLIC cpl_oasis_def_dmcomm
+   PUBLIC cpl_oasis_define
+   PUBLIC cpl_oasis_toreceive
+   PUBLIC cpl_oasis_tosend
+   PUBLIC cpl_oasis_snd
+   PUBLIC cpl_oasis_rcv
+   PUBLIC cpl_oasis_finalize
+   PUBLIC cpl_oasis_abort
+
+CONTAINS
+
+   SUBROUTINE cpl_oasis_init( kl_comm ) 
+      INTEGER, INTENT(OUT) :: kl_comm       ! local communicator of the model
+      IF (.FALSE.) kl_comm = -1 ! to avoid compilation warning
+   END SUBROUTINE cpl_oasis_init
+
+   SUBROUTINE cpl_oasis_def_dmcomm( kdm_comm ) 
+      INTEGER, INTENT(IN) :: kdm_comm       ! computing nodes communicator
+      IF (.FALSE.) WRITE(*,*) kdm_comm ! to avoid compilation warning
+   END SUBROUTINE cpl_oasis_def_dmcomm
+
+   SUBROUTINE cpl_oasis_define( cdsndname, cdrcvname, pgrid )
+      CHARACTER(*), INTENT(IN), DIMENSION(:,:,:)  :: cdsndname, cdrcvname   ! coupling field names
+      TYPE(domain), INTENT(IN), OPTIONAL, POINTER :: pgrid                  ! grid structure
+      IF (.FALSE.) WRITE(*,*) cdsndname, cdrcvname, pgrid%id  ! to avoid compilation warning
+   END SUBROUTINE cpl_oasis_define
+
+   FUNCTION cpl_oasis_toreceive( kdomwrf, kdomext, kfldid )
+      INTEGER, INTENT(IN) :: kdomwrf   ! wrf domain index
+      INTEGER, INTENT(IN) :: kdomext   ! external model domain index
+      INTEGER, INTENT(IN) :: kfldid    ! field index
+      LOGICAL :: cpl_oasis_toreceive
+      IF (.FALSE.) WRITE(*,*) kdomwrf, kdomext, kfldid  ! to avoid compilation warning
+      IF (.FALSE.) cpl_oasis_toreceive = .false.  ! to avoid compilation warning
+   END FUNCTION cpl_oasis_toreceive
+
+   FUNCTION cpl_oasis_tosend( kdomwrf, kdomext, kfldid )
+      INTEGER, INTENT(IN) :: kdomwrf   ! wrf domain index
+      INTEGER, INTENT(IN) :: kdomext   ! external model domain index
+      INTEGER, INTENT(IN) :: kfldid    ! field index
+      LOGICAL :: cpl_oasis_tosend
+      IF (.FALSE.) WRITE(*,*) kdomwrf, kdomext, kfldid  ! to avoid compilation warning
+      IF (.FALSE.) cpl_oasis_tosend = .false.  ! to avoid compilation warning
+   END FUNCTION cpl_oasis_tosend
+
+   SUBROUTINE cpl_oasis_snd( kdomwrf, kdomext, kfldid, ksec, pdata )
+      !!----------------------------------------------------------------------
+      INTEGER,              INTENT(IN) :: kdomwrf   ! wrf domain index
+      INTEGER,              INTENT(IN) :: kdomext   ! external model domain index
+      INTEGER,              INTENT(IN) :: kfldid    ! field index
+      INTEGER,              INTENT(IN) :: ksec      ! time-step in seconds
+      REAL, DIMENSION(:,:), INTENT(IN) :: pdata     ! data to be sent
+      IF (.FALSE.) WRITE(*,*) kdomwrf, kdomext, kfldid, ksec, pdata ! to avoid compilation warning
+   END SUBROUTINE cpl_oasis_snd
+
+   SUBROUTINE cpl_oasis_rcv( kdomwrf, kdomext, kfldid, ksec, pcplrcv )
+      INTEGER,              INTENT(IN   ) :: kdomwrf   ! wrf domain index
+      INTEGER,              INTENT(IN   ) :: kdomext   ! external model domain index
+      INTEGER,              INTENT(IN   ) :: kfldid    ! variable index
+      INTEGER,              INTENT(IN   ) :: ksec      ! number of seconds since the last restart
+      REAL, DIMENSION(:,:), INTENT(  OUT) :: pcplrcv   ! output data
+      IF (.FALSE.) WRITE(*,*) kdomwrf, kdomext, kfldid, ksec ! to avoid compilation warning
+      IF (.FALSE.) pcplrcv(:,:) = -1. ! to avoid compilation warning
+   END SUBROUTINE cpl_oasis_rcv
+
+   SUBROUTINE cpl_oasis_finalize()
+      IF (.FALSE.) WRITE(*,*) 'You should not be there...'
+   END SUBROUTINE cpl_oasis_finalize
+
+   SUBROUTINE cpl_oasis_abort( cdroutine, cdtxt )
+      CHARACTER(*), INTENT(IN) :: cdroutine   ! name of the subroutine calling cpl_oasis_abort
+      CHARACTER(*), INTENT(IN) :: cdtxt       ! aborting text
+      IF (.FALSE.) WRITE(*,*) cdroutine, cdtxt   ! to avoid compilation warning
+   END SUBROUTINE cpl_oasis_abort
+#endif
+
+END MODULE module_cpl_oasis3
diff --git a/wrfv2_fire/frame/module_dm_stubs.F b/wrfv2_fire/frame/module_dm_stubs.F
index 4a98eb4c..7ea51c2d 100644
--- a/wrfv2_fire/frame/module_dm_stubs.F
+++ b/wrfv2_fire/frame/module_dm_stubs.F
@@ -45,6 +45,13 @@ INTEGER FUNCTION wrf_dm_sum_integer ( inval )
       wrf_dm_sum_integer = inval
    END FUNCTION wrf_dm_sum_integer
 
+   SUBROUTINE wrf_dm_sum_integers ( inval, retval )
+      IMPLICIT NONE
+      INTEGER, INTENT(IN) :: inval(:)
+      INTEGER, INTENT(OUT) :: retval(:)
+      retval(:) = inval(:)
+   END SUBROUTINE wrf_dm_sum_integers
+
    INTEGER FUNCTION wrf_dm_bxor_integer ( inval )
       IMPLICIT NONE
       INTEGER inval
diff --git a/wrfv2_fire/frame/module_domain.F b/wrfv2_fire/frame/module_domain.F
index 9cc605ee..fb3786c2 100644
--- a/wrfv2_fire/frame/module_domain.F
+++ b/wrfv2_fire/frame/module_domain.F
@@ -682,6 +682,7 @@ SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid )
 
       ALLOCATE ( new_grid )
       ALLOCATE( new_grid%head_statevars )
+      new_grid%head_statevars%Ndim = 0
       NULLIFY( new_grid%head_statevars%next)
       new_grid%tail_statevars => new_grid%head_statevars 
 
@@ -1093,7 +1094,7 @@ SUBROUTINE modify_io_masks1 ( grid , id )
                     CALL get_fieldstr(fieldno,',',fieldlst,t1,256,noerr)
                     CALL change_to_lower_case(t1,lookee)
                     DO WHILE ( noerr )    ! linear search, blargh...
-                      p => grid%head_statevars
+                      p => grid%head_statevars%next
                       found = .FALSE.
                       count_em = count_em + 1
                       DO WHILE ( ASSOCIATED( p ) )
@@ -1170,7 +1171,7 @@ SUBROUTINE modify_io_masks1 ( grid , id )
 
 #ifdef DM_PARALLEL
 ! broadcast the new masks to the other tasks
-      p => grid%head_statevars
+      p => grid%head_statevars%next
       DO WHILE ( ASSOCIATED( p ) )
         IF ( p%Ndim .EQ. 4 .AND. p%scalar_array ) THEN
 
@@ -1680,7 +1681,6 @@ RECURSIVE SUBROUTINE show_nest_subtree ( grid )
       INTEGER kid
       IF ( .NOT. ASSOCIATED( grid ) ) RETURN
       myid = grid%id
-      write(0,*)'show_nest_subtree ',myid
       DO kid = 1, max_nests
         IF ( ASSOCIATED( grid%nests(kid)%ptr ) ) THEN
           IF ( grid%nests(kid)%ptr%id .EQ. myid ) THEN
@@ -2592,6 +2592,62 @@ LOGICAL FUNCTION Is_alarm_tstep( grid_clock, alarm )
       END FUNCTION Is_alarm_tstep
 
 
+#if (NMM_CORE==1)
+!******************************************************************************
+! Function to determine if the next NPHS time step is an alarm-timestep for
+! a certain grid:
+! NMM-only -- modify to check whether the next alarm coincides with the next
+! NPHS time step!
+!******************************************************************************
+
+      LOGICAL FUNCTION Is_alarm_tstep_nphs( grid_clock, alarm, nphs )
+
+        IMPLICIT NONE
+
+        TYPE (WRFU_Clock), INTENT(in)  :: grid_clock
+        TYPE (WRFU_Alarm), INTENT(in)  :: alarm
+
+        LOGICAL :: pred1, pred2, pred3
+        INTEGER :: nphs
+
+        Is_alarm_tstep_nphs = .FALSE.
+
+        IF ( ASSOCIATED( alarm%alarmint ) ) THEN
+          IF ( alarm%alarmint%Enabled ) THEN
+            IF ( alarm%alarmint%RingIntervalSet ) THEN
+              pred1 = .FALSE. ; pred2 = .FALSE. ; pred3 = .FALSE.
+              IF ( alarm%alarmint%StopTimeSet ) THEN
+                 PRED1 = ( grid_clock%clockint%CurrTime + grid_clock%clockint%TimeStep*nphs > &
+                      alarm%alarmint%StopTime )
+              ENDIF
+              IF ( alarm%alarmint%RingTimeSet ) THEN
+                 PRED2 = ( ( alarm%alarmint%RingTime - &
+                      grid_clock%clockint%TimeStep <= &
+                      grid_clock%clockint%CurrTime )     &
+                      .AND. ( grid_clock%clockint%CurrTime < alarm%alarmint%RingTime ) )
+              ENDIF
+              IF ( alarm%alarmint%RingIntervalSet ) THEN
+                 PRED3 = ( alarm%alarmint%PrevRingTime + &
+                      alarm%alarmint%RingInterval <= &
+                      grid_clock%clockint%CurrTime + grid_clock%clockint%TimeStep*nphs )
+              ENDIF
+              IF ( ( .NOT. ( pred1 ) ) .AND. &
+                   ( ( pred2 ) .OR. ( pred3 ) ) ) THEN
+                 Is_alarm_tstep_nphs = .TRUE.
+              ENDIF
+            ELSE IF ( alarm%alarmint%RingTimeSet ) THEN
+              IF ( alarm%alarmint%RingTime -&
+                   grid_clock%clockint%TimeStep*nphs <= &
+                   grid_clock%clockint%CurrTime ) THEN
+                 Is_alarm_tstep_nphs = .TRUE.
+              ENDIF
+            ENDIF
+          ENDIF
+        ENDIF
+
+      END FUNCTION Is_alarm_tstep_nphs
+#endif
+
 
 !******************************************************************************
 ! BEGIN TEST SECTION
@@ -3045,9 +3101,7 @@ SUBROUTINE modify_io_masks ( id )
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: id
      TYPE(domain), POINTER :: grid
-!write(0,*)'modify_io_masks head_grid ',id,ASSOCIATED(head_grid)
      CALL find_grid_by_id( id, head_grid, grid )
-!write(0,*)'modify_io_masks grid ',id,ASSOCIATED(grid)
      IF ( ASSOCIATED( grid ) ) CALL modify_io_masks1( grid, id ) 
      RETURN 
    END SUBROUTINE modify_io_masks
diff --git a/wrfv2_fire/frame/module_driver_constants.F b/wrfv2_fire/frame/module_driver_constants.F
index 760c8811..7a117e37 100644
--- a/wrfv2_fire/frame/module_driver_constants.F
+++ b/wrfv2_fire/frame/module_driver_constants.F
@@ -1,7 +1,7 @@
 !WRF:DRIVER_LAYER:CONSTANTS
 !
 !  This MODULE contains all of the constants used in the model.  These
-!  are separated by uage within the code.
+!  are separated by usage within the code.
 
 MODULE module_driver_constants
 
@@ -69,11 +69,24 @@ MODULE module_driver_constants
 
    INTEGER , PARAMETER :: max_instruments =   30
 
+   !  The maximum number of obs indexes (for conventional DA obs) 
+
+   INTEGER , PARAMETER :: num_ob_indexes  =   28
+
+
    !  The maximum number of bogus storms
 
    INTEGER , PARAMETER :: max_bogus =  5
 
-   !  2. Following related to driver leve data structures for DM_PARALLEL communications
+   !  The maximum number of fields that can be sent or received in coupled mode
+
+   INTEGER , PARAMETER :: max_cplfld = 20
+
+   !  The maximum number of domains used by the external model with which wrf is communicating in coupled mode
+
+   INTEGER , PARAMETER :: max_extdomains = 5
+
+   !  2. Following related to driver level data structures for DM_PARALLEL communications
 
 #ifdef DM_PARALLEL
    INTEGER , PARAMETER :: max_comms       =   1024
@@ -84,7 +97,7 @@ MODULE module_driver_constants
    !  3. Following is information related to the file I/O.
 
    !  These are the bounds of the available FORTRAN logical unit numbers for the file I/O.
-   !  Only logical unti numbers within these bounds will be chosen for I/O unit numbers.
+   !  Only logical unit numbers within these bounds will be chosen for I/O unit numbers.
 
    INTEGER , PARAMETER :: min_file_unit = 10
    INTEGER , PARAMETER :: max_file_unit = 99
diff --git a/wrfv2_fire/frame/module_integrate.F b/wrfv2_fire/frame/module_integrate.F
index bfbd9d89..4d2a5466 100644
--- a/wrfv2_fire/frame/module_integrate.F
+++ b/wrfv2_fire/frame/module_integrate.F
@@ -15,6 +15,7 @@ RECURSIVE SUBROUTINE integrate ( grid )
    USE module_configure
    USE module_timing
    USE module_utility
+   USE module_cpl, ONLY : coupler_on, cpl_snd, cpl_defdomain
 
    IMPLICIT NONE
 
@@ -295,6 +296,7 @@ SUBROUTINE dfi_accumulate( grid )
                IF ( grid%dfi_stage == DFI_STARTFWD ) THEN
                   CALL wrf_dfi_startfwd_init(new_nest)
                ENDIF
+               IF (coupler_on) CALL cpl_defdomain( new_nest ) 
             END DO
             IF ( a_nest_was_opened ) THEN
                CALL set_overlaps ( grid )   ! find overlapping and set pointers
@@ -348,6 +350,7 @@ SUBROUTINE dfi_accumulate( grid )
 #endif
                  END IF
                END DO
+               IF (coupler_on) CALL cpl_snd( grid_ptr ) 
                grid_ptr => grid_ptr%sibling
             END DO
             CALL set_current_grid_ptr( grid )
diff --git a/wrfv2_fire/frame/module_io.F b/wrfv2_fire/frame/module_io.F
index bbfcabea..edc6e489 100644
--- a/wrfv2_fire/frame/module_io.F
+++ b/wrfv2_fire/frame/module_io.F
@@ -230,12 +230,15 @@ SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInf
   CHARACTER*128     :: mess
   CHARACTER*1028    :: tstr, t1
   INTEGER i,j
+  LOGICAL ncd_nofill
 
   WRITE(mess,*) 'module_io.F: in wrf_open_for_write_begin, FileName = ',TRIM(FileName)
   CALL wrf_debug( DEBUG_LVL, mess )
 
   CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet )
 
+  CALL nl_get_ncd_nofill( 1 , ncd_nofill )
+
   io_form = io_form_for_dataset( DataSet )
 
   Status = 0
@@ -251,8 +254,13 @@ SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInf
           ELSE
             LocFilename = FileName
           ENDIF
-          CALL ext_ncd_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
-                                              Hndl , Status )
+          IF ( ncd_nofill ) THEN
+            CALL ext_ncd_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo // ",NOFILL=.TRUE.", &
+                                                Hndl , Status )
+          ELSE
+            CALL ext_ncd_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
+                                                Hndl , Status )
+          ENDIF
         ENDIF
         IF ( .NOT. multi_files(io_form) ) THEN
           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
@@ -381,8 +389,13 @@ SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInf
     END SELECT
   ELSE IF ( use_output_servers() ) THEN
     IF ( io_form .GT. 0 ) THEN
-      CALL wrf_quilt_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
-                                            Hndl , io_form, Status )
+      IF ( ncd_nofill ) THEN
+        CALL wrf_quilt_open_for_write_begin ( FileName , Comm_compute, Comm_io, TRIM(SysDepInfo) // ",NOFILL=.TRUE.", &
+                                              Hndl , io_form, Status )
+      ELSE
+        CALL wrf_quilt_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
+                                              Hndl , io_form, Status )
+      ENDIF
     ENDIF
   ELSE
     Status = 0
diff --git a/wrfv2_fire/frame/module_io_quilt.F b/wrfv2_fire/frame/module_io_quilt.F
index 775bdb1e..6f300f5c 100644
--- a/wrfv2_fire/frame/module_io_quilt.F
+++ b/wrfv2_fire/frame/module_io_quilt.F
@@ -66,6 +66,9 @@ MODULE module_wrf_quilt
 !
   USE module_internal_header_util
   USE module_timing
+#if ( DA_CORE != 1 )
+  USE module_cpl, ONLY : coupler_on, cpl_set_dm_communicator, cpl_finalize
+#endif
 
   INTEGER, PARAMETER :: int_num_handles = 99
   INTEGER, PARAMETER :: max_servers = int_num_handles+1  ! why +1?
@@ -681,7 +684,15 @@ SUBROUTINE quilt
             CALL ext_gr2_ioexit( Status )
 #endif
             CALL wrf_message ( 'I/O QUILT SERVERS DONE' )
-            CALL mpi_finalize(ierr)
+#if ( DA_CORE != 1 )
+            IF (coupler_on) THEN 
+               CALL cpl_finalize() 
+            ELSE
+#endif
+               CALL mpi_finalize(ierr)
+#if ( DA_CORE != 1 )
+            END IF
+#endif
             STOP
           ELSE
             WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.'
@@ -2647,12 +2658,18 @@ SUBROUTINE init_module_wrf_quilt
        ! provide the communicator for the integration tasks to RSL
        IF ( compute_node ) THEN
           CALL wrf_set_dm_communicator( mpi_comm_local )
+#if ( DA_CORE != 1 )
+          IF (coupler_on) CALL cpl_set_dm_communicator( mpi_comm_local )
+#endif
 #ifdef HWRF
           call ATM_SET_COMM(mpi_comm_local)
 #endif
        ELSE
 #ifdef HWRF
           call ATM_LEAVE_COUPLING()
+#endif
+#if ( DA_CORE != 1 )
+          IF (coupler_on) CALL cpl_set_dm_communicator( MPI_COMM_NULL )
 #endif
           CALL quilt    ! will not return on io server tasks
        ENDIF
diff --git a/wrfv2_fire/frame/module_quilt_outbuf_ops.F b/wrfv2_fire/frame/module_quilt_outbuf_ops.F
index b7686c80..d056908e 100644
--- a/wrfv2_fire/frame/module_quilt_outbuf_ops.F
+++ b/wrfv2_fire/frame/module_quilt_outbuf_ops.F
@@ -1263,7 +1263,8 @@ SUBROUTINE store_patch_in_outbuf_pnc( inbuf_r, inbuf_i, DateStr, VarName , &
     IF ( .NOT. found ) THEN
       num_entries = num_entries + 1
       IF(num_entries > tabsize)THEN
-         WRITE(mess,*) 'Number of entries in outpatch_table has exceeded tabsize (',tabsize,') in module_quilt_outbuf_ops::store_patch_in_outbuf_pnc'
+         WRITE(mess,*) 'Number of entries in outpatch_table has exceeded tabsize (',&
+         tabsize,') in module_quilt_outbuf_ops::store_patch_in_outbuf_pnc'
          CALL wrf_error_fatal(mess)
       END IF
       outpatch_table(num_entries)%npatch = 0
diff --git a/wrfv2_fire/frame/module_wrf_error.F b/wrfv2_fire/frame/module_wrf_error.F
index 2c528904..dcf1bb13 100644
--- a/wrfv2_fire/frame/module_wrf_error.F
+++ b/wrfv2_fire/frame/module_wrf_error.F
@@ -109,8 +109,13 @@ SUBROUTINE init_module_wrf_error(on_io_server)
     OPEN(unit=27, file="namelist.input", form="formatted", status="old")
     READ(27,nml=logging,iostat=iostat)
     if(iostat /= 0) then
+#if (DA_CORE!=1)
+       CALL wrf_debug ( 1 , 'Namelist logging not found in namelist.input. ' )
+       CALL wrf_debug ( 1 , ' --> Using registry defaults for variables in logging.' )
+#else
        write(0,*) 'Namelist logging not found in namelist.input. Using registry defaults for variables in logging.'
        write(6,*) 'Namelist logging not found in namelist.input. Using registry defaults for variables in logging.'
+#endif
 #      ifdef _WIN32
           FLUSH(0)
 #      endif
diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile
new file mode 100644
index 00000000..a37fbe0d
--- /dev/null
+++ b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile
@@ -0,0 +1,34 @@
+# Makefile 
+#
+.SUFFIXES:
+.SUFFIXES: .o .F
+
+
+
+include ../../macros
+
+MODFLAG =       -I./ -I ../../MPP -I ../../mod 
+
+WRF_ROOT = ../../..
+OBJS = \
+	module_wrf_HYDRO.o \
+	wrf_drv_HYDRO.o    
+all:	$(OBJS) 
+
+.F.o:
+	@echo ""
+	$(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f
+	$(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I$(WRF_ROOT)/frame -I$(WRF_ROOT)/main -I$(WRF_ROOT)/external/esmf_time_f90 $(*).f
+	$(RMD) $(*).f
+	@echo ""
+	ar -r ../../lib/libHYDRO.a $(@)
+
+#
+# Dependencies:
+#
+module_wrf_HYDRO.o: ../../Data_Rec/module_RT_data.o ../../Data_Rec/module_namelist.o ../../HYDRO_drv/module_HYDRO_drv.o
+
+wrf_drv_HYDRO.o: module_wrf_HYDRO.o
+
+clean:
+	rm -f *.o *.mod *.stb *~ *.f
diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl
new file mode 100644
index 00000000..64550bdb
--- /dev/null
+++ b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl
@@ -0,0 +1,9 @@
+# Makefile 
+
+all:
+	(cd ../../; make -f Makefile.comm BASIC)
+	(make)
+
+clean:
+	(make clean)
+	(cd ../../; make -f Makefile.comm clean)
diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F
new file mode 100644
index 00000000..d238acaa
--- /dev/null
+++ b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F
@@ -0,0 +1,321 @@
+module module_WRF_HYDRO
+
+#ifdef MPP_LAND
+    use module_mpp_land, only: global_nx, global_ny, decompose_data_real, &
+                 write_io_real, my_id, mpp_land_bcast_real1, IO_id, &
+                mpp_land_bcast_real, mpp_land_bcast_int1
+#endif
+    use module_HYDRO_drv, only: HYDRO_ini, HYDRO_exe
+
+    use module_rt_data, only:  rt_domain
+    use module_CPL_LAND, only: CPL_LAND_INIT, cpl_outdate
+    use module_namelist, only: nlst_rt
+    USE module_domain, ONLY : domain, domain_clock_get
+    !yw USE module_configure, only : config_flags
+    USE module_configure, only: model_config_rec
+ 
+
+    implicit none
+     
+    !yw   added for check soil moisture and soiltype
+    integer ::  checkSOIL_flag
+
+
+
+
+CONTAINS
+
+!wrf_cpl_HYDRO will not call the off-line lsm 
+    subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte)
+
+       implicit none
+       TYPE ( domain ), INTENT(INOUT) :: grid
+       integer its, ite, jts, jte, ij
+       real :: HYDRO_dt
+
+
+        integer k, ix,jx, mm, nn
+
+        integer ::  did
+
+        integer ntime
+
+        integer :: i,j
+        
+
+!output flux and state variable
+
+        did = 1
+        ix = ite - its + 1
+        jx = jte - jts + 1
+
+        if(HYDRO_dt .le. 0) then
+             write(6,*) "Warning: HYDRO_dt <= 0 from land input. set it to be 1 seconds."
+             HYDRO_dt = 1
+        endif
+
+        ntime = 1
+
+    
+            nlst_rt(did)%dt = HYDRO_dt
+
+  
+        if(.not. RT_DOMAIN(did)%initialized) then
+
+
+           !yw nlst_rt(did)%nsoil = config_flags%num_soil_layers
+           !nlst_rt(did)%nsoil = model_config_rec%num_metgrid_soil_levels
+           nlst_rt(did)%nsoil = grid%num_soil_layers
+
+         
+#ifdef MPP_LAND
+           call mpp_land_bcast_int1 (nlst_rt(did)%nsoil)
+#endif
+           allocate(nlst_rt(did)%zsoil8(nlst_rt(did)%nsoil))
+           if(grid%zs(1) <  0) then
+              nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = grid%zs(1:nlst_rt(did)%nsoil)
+           else
+              nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = -1*grid%zs(1:nlst_rt(did)%nsoil)
+           endif
+
+            CALL domain_clock_get( grid, current_timestr=cpl_outdate)
+            nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19)
+            nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19)
+
+
+            call CPL_LAND_INIT(its,ite,jts,jte)
+
+#ifdef HYDRO_D
+               write(6,*) "sf_surface_physics is ", grid%sf_surface_physics
+#endif
+
+           if(grid%sf_surface_physics .eq. 5) then    
+                ! clm4 
+               call HYDRO_ini(ntime,did=did,ix0=1,jx0=1)
+           else
+               call HYDRO_ini(ntime,did,ix0=ix,jx0=jx,vegtyp=grid%IVGTYP(its:ite,jts:jte),soltyp=grid%isltyp(its:ite,jts:jte))
+           endif
+
+
+
+            if(nlst_rt(did)%sys_cpl .ne. 2) then
+               write(6,*) "Error: sys_cpl should be 2."
+               call hydro_stop()
+            endif
+
+
+            nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19)
+            nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19)
+
+        endif
+
+            nlst_rt(did)%dt = HYDRO_dt
+
+
+
+            mm = HYDRO_dt/nlst_rt(did)%dtrt
+            if(mm*nlst_rt(did)%dtrt .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm
+
+#ifdef HYDRO_D 
+        write(6,*) "mm, nlst_rt(did)%dt = ",mm, nlst_rt(did)%dt
+#endif
+
+        if(nlst_rt(did)%SUBRTSWCRT .eq.0  &
+               .and. nlst_rt(did)%OVRTSWCRT .eq. 0 .and. nlst_rt(did)%GWBASESWCRT .eq. 0) return
+
+        nn = nlst_rt(did)%nsoil
+
+        ! get the data from WRF 
+
+
+       if((.not. RT_DOMAIN(did)%initialized) .and. (nlst_rt(did)%rst_typ .eq. 1) ) then
+#ifdef HYDRO_D
+           write(6,*) "restart initial data from offline file"
+#endif
+       else
+            do k = 1, nlst_rt(did)%nsoil
+                RT_DOMAIN(did)%STC(:,:,k) = grid%TSLB(its:ite,k,jts:jte) 
+                RT_DOMAIN(did)%smc(:,:,k) = grid%smois(its:ite,k,jts:jte) 
+                RT_DOMAIN(did)%sh2ox(:,:,k) = grid%sh2o(its:ite,k,jts:jte) 
+            end do 
+            rt_domain(did)%infxsrt = grid%infxsrt(its:ite,jts:jte)
+            rt_domain(did)%soldrain = grid%soldrain(its:ite,jts:jte)
+       endif  
+
+
+!yw       if(checkSOIL_flag .ne. 99) then
+!yw           call checkSoil(did) 
+!yw           checkSOIL_flag = 99
+!yw       endif
+
+            call HYDRO_exe(did)
+
+
+! add for update the WRF state variable.
+            do k = 1, nlst_rt(did)%nsoil
+                ! grid%TSLB(its:ite,k,jts:jte) = RT_DOMAIN(did)%STC(:,:,k)
+                grid%smois(its:ite,k,jts:jte) = RT_DOMAIN(did)%smc(:,:,k)
+                grid%sh2o(its:ite,k,jts:jte) = RT_DOMAIN(did)%sh2ox(:,:,k)
+            end do 
+
+! update WRF variable after running routing model.
+            grid%sfcheadrt(its:ite,jts:jte) = rt_domain(did)%sfcheadrt
+
+!yw not sure for the following
+!           grid%xice(its:ite,jts:jte) = rt_domain(did)%sice
+
+            RT_DOMAIN(did)%initialized = .true.
+     end subroutine wrf_cpl_HYDRO
+
+
+
+
+
+!program drive rtland
+! This subroutine will be used if the 4-layer Noah lsm is not used.
+      subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp)
+!  input: z1,v1,kk1,z,ix,jx,kk
+!  output: vout
+!  interpolate based on soil layer: z1 and z 
+!  z :  soil layer of output variable.
+!  z1: array of soil layers of input variable.
+         implicit none
+         integer:: i,j,k
+         integer:: kk1, ix,jx,kk, vegtyp(ix,jx)
+         real :: z1(kk1), z(kk), v1(ix,kk1,jx),vout(ix,jx,kk)
+
+       
+         do j = 1, jx
+            do i = 1, ix
+                do k = 1, kk
+                  call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) 
+                end do
+            end do
+         end do
+      end subroutine wrf2lsm
+
+! This subroutine will be used if the 4-layer Noah lsm is not used.
+      subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp)
+!  input: z1,v1,kk1,z,ix,jx,kk
+!  output: vout
+!  interpolate based on soil layer: z1 and z 
+!  z :  soil layer of output variable.
+!  z1: array of soil layers of input variable.
+         implicit none
+         integer:: i,j,k
+         integer:: kk1, ix,jx,kk, vegtyp(ix,jx)
+         real :: z1(kk1), z(kk), v1(ix,jx,kk1),vout(ix,kk,jx)
+
+       
+         do j = 1, jx
+            do i = 1, ix
+                 do k = 1, kk
+                    call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) 
+                 end do
+            end do
+         end do
+      end subroutine lsm2wrf
+
+      subroutine interpLayer(inZ,inV,inK,outZ,outV)
+         implicit none
+         integer:: k, k1, k2
+         integer :: inK
+         real:: inV(inK),inZ(inK)
+         real:: outV, outZ, w1, w2
+
+         if(outZ .le. inZ(1)) then
+             w1 = (inZ(2)-outZ)/(inZ(2)-inZ(1))
+             w2 = (inZ(1)-outZ)/(inZ(2)-inZ(1))
+             outV = inV(1)*w1-inV(2)*w2
+             return
+         elseif(outZ .ge. inZ(inK)) then
+             w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) 
+             w2 = (outZ-inZ(inK))  /(inZ(inK)-inZ(inK-1))
+             outV = inV(inK)*w1 -inV(inK-1)* w2
+             return
+         else  
+            do k = 2, inK
+             if((inZ(k) .ge. outZ).and.(inZ(k-1) .le. outZ) ) then
+                k1  = k-1
+                k2 = k
+                w1 = (outZ-inZ(k1))/(inZ(k2)-inZ(k1))
+                w2 = (inZ(k2)-outZ)/(inZ(k2)-inZ(k1))
+                outV = inV(k2)*w1 + inV(k1)*w2
+                return 
+             end if 
+            end do
+         endif
+      end subroutine interpLayer
+
+      subroutine lsm_wrf_input(did,vegtyp,soltyp,ix,jx)
+         implicit none
+         integer did, leng
+         parameter(leng=100)
+         integer :: i,j, nn, ix,jx
+         integer, dimension(ix,jx) :: soltyp, vegtyp
+         real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc
+
+
+         where(soltyp == 14) VEGTYP = 16
+         where(VEGTYP == 16 ) soltyp = 14
+
+         RT_DOMAIN(did)%VEGTYP = vegtyp
+
+!      input OV_ROUGH from OVROUGH.TBL
+#ifdef MPP_LAND
+       if(my_id .eq. IO_id) then
+#endif
+
+       open(71,file="HYDRO.TBL", form="formatted")
+!read OV_ROUGH first
+          read(71,*) nn
+          read(71,*)
+          do i = 1, nn
+             read(71,*) RT_DOMAIN(did)%OV_ROUGH(i)
+          end do
+!read parameter for LKSAT
+          read(71,*) nn
+          read(71,*)
+          do i = 1, nn
+             read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i)
+          end do
+       close(71)
+
+#ifdef MPP_LAND
+       endif
+       call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH)
+       call mpp_land_bcast_real(leng,xdum1)
+       call mpp_land_bcast_real(leng,MAXSMC)
+       call mpp_land_bcast_real(leng,refsmc)
+       call mpp_land_bcast_real(leng,wltsmc)
+#endif
+
+       rt_domain(did)%lksat = 0.0
+       do j = 1, RT_DOMAIN(did)%jx
+             do i = 1, RT_DOMAIN(did)%ix
+                rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0
+                IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN   ! urban
+                    rt_domain(did)%SMCMAX1(i,j) = 0.45
+                    rt_domain(did)%SMCREF1(i,j) = 0.42
+                    rt_domain(did)%SMCWLT1(i,j) = 0.40
+                else
+                    rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J))
+                    rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J))
+                    rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J))
+                ENDIF
+             end do
+       end do
+
+
+      end subroutine lsm_wrf_input
+
+      subroutine  checkSoil(did) 
+          implicit none
+          integer :: did
+          where(rt_domain(did)%smc(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16
+          where(rt_domain(did)%sh2ox(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16
+          where(rt_domain(did)%smc(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16
+          where(rt_domain(did)%sh2ox(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16
+      end subroutine checkSoil
+
+end module module_wrf_HYDRO
diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F b/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F
new file mode 100644
index 00000000..70939c26
--- /dev/null
+++ b/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F
@@ -0,0 +1,31 @@
+!2345678
+       subroutine wrf_drv_HYDRO(HYDRO_dt,grid,its,ite,jts,jte)
+          use module_wrf_HYDRO, only: wrf_cpl_HYDRO
+          USE module_domain, ONLY : domain 
+          implicit none
+           integer:: its,ite,jts,jte
+          real :: HYDRO_dt
+          TYPE ( domain ), INTENT(INOUT) :: grid
+!         return
+
+          if(grid%num_nests .lt. 1) then
+
+             call wrf_cpl_HYDRO(HYDRO_dt, grid,its,ite,jts,jte)  
+
+          endif
+       end subroutine wrf_drv_HYDRO
+
+
+       subroutine wrf_drv_HYDRO_ini(grid,its,ite,jts,jte)
+          use module_wrf_HYDRO, only: wrf_cpl_HYDRO
+          USE module_domain, ONLY : domain
+          implicit none
+           integer:: its,ite,jts,jte
+          TYPE ( domain ), INTENT(INOUT) :: grid
+
+          if(grid%num_nests .lt. 1) then
+!            call wrf_cpl_HYDRO_ini(grid,its,ite,jts,jte)  
+          endif
+
+       end subroutine wrf_drv_HYDRO_ini
+
diff --git a/wrfv2_fire/hydro/Data_Rec/Makefile b/wrfv2_fire/hydro/Data_Rec/Makefile
new file mode 100644
index 00000000..398ba2fe
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/Makefile
@@ -0,0 +1,28 @@
+# Makefile 
+#
+.SUFFIXES:
+.SUFFIXES: .o .F
+
+include ../macros
+
+OBJS = \
+	module_namelist.o \
+	module_RT_data.o \
+	module_GW_baseflow_data.o
+
+all:	$(OBJS) 
+
+.F.o:
+	@echo ""
+	$(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f
+	$(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I../mod $(*).f
+	$(RMD) $(*).f
+	@echo ""
+	ar -r ../lib/libHYDRO.a $(@)
+	cp *.mod ../mod
+
+# Dependencies:
+#
+
+clean:
+	rm -f *.o *.mod *.stb *~ *.f
diff --git a/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc b/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc
new file mode 100644
index 00000000..99c79886
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc
@@ -0,0 +1,26 @@
+
+ type gw_field
+      integer :: ix, jx
+      integer :: allo_status = -99
+
+      real :: dx, dt
+
+      integer, allocatable, dimension(:,:) ::  ltype     ! land-sfc type
+      real,    allocatable, dimension(:,:) ::  &
+        elev,           &  ! elev/bathymetry of sfc rel to sl (m)
+        bot,            &  ! elev. aquifer bottom rel to sl (m)
+        hycond,         &  ! hydraulic conductivity (m/s per m/m)
+        poros,          &  ! porosity (m3/m3)
+        compres,        &  ! compressibility (1/Pa)
+        ho                 ! head at start of timestep (m)
+
+      real,    allocatable, dimension(:,:) ::  &
+        h,              &  ! head, after ghmcompute (m)
+        convgw             ! convergence due to gw flow (m/s)
+
+      real  :: ebot, eocn
+      integer ::istep = 0
+
+
+  end type gw_field
+
diff --git a/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F b/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F
new file mode 100644
index 00000000..4b171683
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F
@@ -0,0 +1,9 @@
+Module module_GW_baseflow_data
+   IMPLICIT NONE
+   INTEGER, PARAMETER :: max_domain=5
+
+#include "gw_field_include.inc"
+      type (gw_field) :: gw2d(max_domain)
+      save gw2d
+
+end module module_GW_baseflow_data
diff --git a/wrfv2_fire/hydro/Data_Rec/module_RT_data.F b/wrfv2_fire/hydro/Data_Rec/module_RT_data.F
new file mode 100644
index 00000000..951e33de
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/module_RT_data.F
@@ -0,0 +1,10 @@
+Module module_RT_data
+   IMPLICIT NONE
+   INTEGER, PARAMETER :: max_domain=5
+
+! define Routing data
+#include "rt_include.inc"
+   TYPE ( RT_FIELD ), DIMENSION (max_domain) :: RT_DOMAIN
+   save RT_DOMAIN
+
+end module module_RT_data
diff --git a/wrfv2_fire/hydro/Data_Rec/module_namelist.F b/wrfv2_fire/hydro/Data_Rec/module_namelist.F
new file mode 100644
index 00000000..806b2831
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/module_namelist.F
@@ -0,0 +1,202 @@
+Module module_namelist
+
+#ifdef MPP_LAND
+          USE module_mpp_land
+#endif
+
+    IMPLICIT NONE
+    INTEGER, PARAMETER :: max_domain=5
+
+#include "namelist.inc"
+    TYPE(namelist_rt_field) , dimension(max_domain) :: nlst_rt
+    save nlst_rt 
+
+CONTAINS 
+
+    subroutine read_rt_nlst(nlst)     
+          implicit none
+
+          TYPE(namelist_rt_field) nlst
+
+          integer ierr
+          integer:: RT_OPTION, CHANRTSWCRT, channel_option, &
+                    SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, &
+                    GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, &
+                    sys_cpl, rst_typ
+          real:: DTRT,dxrt
+          character(len=256) :: route_topo_f=""
+          character(len=256) :: route_chan_f=""
+          character(len=256) :: route_link_f=""
+          character(len=256) :: route_lake_f=""
+          character(len=256) :: route_direction_f=""
+          character(len=256) :: route_order_f=""
+          character(len=256) :: gwbasmskfil =""
+          character(len=256) :: gwstrmfil =""
+          character(len=256) :: geo_finegrid_flnm =""
+       integer :: SOLVEG_INITSWC
+       real out_dt, rst_dt
+       character(len=256)  :: RESTART_FILE = ""
+       logical            :: history_output
+       integer            :: split_output_count, order_to_write
+       integer :: igrid
+       character(len=256) :: geo_static_flnm = ""
+       integer  :: DEEPGWSPIN
+
+       integer :: HIRES_OUT
+       integer :: i
+
+!!! add the following two dummy variables 
+       integer  :: NSOIL
+       real :: ZSOIL8(8)
+
+       namelist /HYDRO_nlist/ NSOIL, ZSOIL8,&
+            RESTART_FILE,HISTORY_OUTPUT,SPLIT_OUTPUT_COUNT,IGRID,&
+            geo_static_flnm, &
+            out_dt, rst_dt, &
+            HIRES_OUT, &
+            DEEPGWSPIN, SOLVEG_INITSWC, &
+            RT_OPTION, CHANRTSWCRT, channel_option, &
+                    SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, dtrt,dxrt,&
+                    GWBASESWCRT,route_topo_f,route_chan_f,route_link_f,route_lake_f, &
+                    route_direction_f,route_order_f,gwbasmskfil, geo_finegrid_flnm,&
+                    gwstrmfil,GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, sys_cpl, &
+                    order_to_write , rst_typ
+#ifdef MPP_LAND
+       if(IO_id .eq. my_id) then
+#endif
+          open(30, file="hydro.namelist", form="FORMATTED")
+          read(30, HYDRO_nlist, iostat=ierr)
+          close(30)
+#ifdef MPP_LAND
+       endif
+#endif
+
+
+#ifdef MPP_LAND
+!  call mpp_land_bcast_real1(DT)
+  call mpp_land_bcast_int1(SPLIT_OUTPUT_COUNT)
+  call mpp_land_bcast_int1(IGRID)
+  call mpp_land_bcast_real1(out_dt)
+  call mpp_land_bcast_real1(rst_dt)
+  call mpp_land_bcast_int1(HIRES_OUT)
+  call mpp_land_bcast_int1(DEEPGWSPIN)
+  call mpp_land_bcast_int1(SOLVEG_INITSWC)
+#endif
+
+
+#ifdef MPP_LAND
+      call mpp_land_bcast_int1(nlst%NSOIL)
+      do i = 1, nlst%NSOIL
+        call mpp_land_bcast_real1(nlst%ZSOIL8(i))
+      end do
+#ifdef HYDRO_D
+      write(6,*) "nlst%NSOIL = ", nlst%NSOIL
+      write(6,*) "nlst%ZSOIL8 = ",nlst%ZSOIL8
+#endif
+#endif
+
+!  nlst%DT = DT
+  nlst%RESTART_FILE = RESTART_FILE
+  nlst%HISTORY_OUTPUT = HISTORY_OUTPUT
+  nlst%SPLIT_OUTPUT_COUNT = SPLIT_OUTPUT_COUNT
+  nlst%IGRID = IGRID
+  nlst%geo_static_flnm = geo_static_flnm
+  nlst%out_dt = out_dt
+  nlst%rst_dt = rst_dt
+  nlst%HIRES_OUT = HIRES_OUT
+  nlst%DEEPGWSPIN = DEEPGWSPIN
+  nlst%SOLVEG_INITSWC = SOLVEG_INITSWC
+
+  write(nlst%hgrid,'(I1)') igrid
+
+
+
+
+#ifdef MPP_LAND
+  !bcast namelist variable.
+  call mpp_land_bcast_int1(rt_option)
+  call mpp_land_bcast_int1(CHANRTSWCRT)
+  call mpp_land_bcast_int1(channel_option)
+  call mpp_land_bcast_int1(SUBRTSWCRT)
+  call mpp_land_bcast_int1(OVRTSWCRT)
+  call mpp_land_bcast_int1(AGGFACTRT)
+  call mpp_land_bcast_real1(DTRT)
+  call mpp_land_bcast_real1(DXRT)
+  call mpp_land_bcast_int1(GWBASESWCRT)
+  call mpp_land_bcast_int1(GW_RESTART)
+  call mpp_land_bcast_int1(RSTRT_SWC  )
+  call mpp_land_bcast_int1(TERADJ_SOLAR)
+  call mpp_land_bcast_int1(sys_cpl)
+  call mpp_land_bcast_int1(rst_typ)
+  call mpp_land_bcast_int1(order_to_write)
+#endif
+    nlst%RT_OPTION = RT_OPTION
+    nlst%CHANRTSWCRT = CHANRTSWCRT
+    nlst%GW_RESTART  = GW_RESTART 
+    nlst%RSTRT_SWC   = RSTRT_SWC  
+    nlst%channel_option = channel_option
+    nlst%DTRT   = DTRT
+    nlst%SUBRTSWCRT = SUBRTSWCRT
+    nlst%OVRTSWCRT = OVRTSWCRT
+    nlst%dxrt0 = dxrt
+    nlst%AGGFACTRT = AGGFACTRT
+    nlst%GWBASESWCRT = GWBASESWCRT
+    nlst%TERADJ_SOLAR = TERADJ_SOLAR
+    nlst%sys_cpl = sys_cpl
+    nlst%rst_typ = rst_typ
+    nlst%order_to_write = order_to_write
+! files
+    nlst%route_topo_f   =  route_topo_f
+    nlst%route_chan_f = route_chan_f 
+    nlst%route_link_f = route_link_f
+    nlst%route_lake_f =route_lake_f
+    nlst%route_direction_f =  route_direction_f
+    nlst%route_order_f =  route_order_f
+    nlst%gwbasmskfil =  gwbasmskfil
+    nlst%gwstrmfil =  gwstrmfil
+    nlst%geo_finegrid_flnm =  geo_finegrid_flnm
+
+#ifdef MPP_LAND
+  if(my_id .eq. IO_id) then
+#endif
+#ifdef HYDRO_D
+     write(6,*) "output of the namelist file "
+
+    write(6,*) " nlst%RT_OPTION ", RT_OPTION
+    write(6,*) " nlst%CHANRTSWCRT ", CHANRTSWCRT
+    write(6,*) " nlst%GW_RESTART  ", GW_RESTART 
+    write(6,*) " nlst%RSTRT_SWC   ", RSTRT_SWC  
+    write(6,*) " nlst%channel_option ", channel_option
+    write(6,*) " nlst%DTRT   ", DTRT
+    write(6,*) " nlst%SUBRTSWCRT ", SUBRTSWCRT
+    write(6,*) " nlst%OVRTSWCRT ", OVRTSWCRT
+    write(6,*) " nlst%dxrt0 ", dxrt
+    write(6,*) " nlst%AGGFACTRT ", AGGFACTRT
+    write(6,*) " nlst%GWBASESWCRT ", GWBASESWCRT
+    write(6,*) " nlst%TERADJ_SOLAR ", TERADJ_SOLAR
+    write(6,*) " nlst%sys_cpl ", sys_cpl
+    write(6,*) " nlst%rst_typ ", rst_typ
+    write(6,*) " nlst%order_to_write ", order_to_write
+    write(6,*) " nlst%route_topo_f   ",  route_topo_f
+    write(6,*) " nlst%route_chan_f ", route_chan_f 
+    write(6,*) " nlst%route_link_f ", route_link_f
+    write(6,*) " nlst%route_lake_f ",route_lake_f
+    write(6,*) " nlst%route_direction_f ",  route_direction_f
+    write(6,*) " nlst%route_order_f ",  route_order_f
+    write(6,*) " nlst%gwbasmskfil ",  gwbasmskfil
+    write(6,*) " nlst%gwstrmfil ",  gwstrmfil
+    write(6,*) " nlst%geo_finegrid_flnm ",  geo_finegrid_flnm
+#endif
+#ifdef MPP_LAND
+  endif
+#endif
+
+#ifdef MPP_LAND
+  !bcast other  variable.
+      call mpp_land_bcast_real1(nlst%dt)
+#endif
+      return
+    end subroutine read_rt_nlst
+
+
+end module module_namelist
diff --git a/wrfv2_fire/hydro/Data_Rec/namelist.inc b/wrfv2_fire/hydro/Data_Rec/namelist.inc
new file mode 100644
index 00000000..6f81617c
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/namelist.inc
@@ -0,0 +1,38 @@
+   TYPE namelist_rt_field  
+      
+       integer :: nsoil, SOLVEG_INITSWC
+       real,allocatable,dimension(:) :: ZSOIL8
+       real out_dt, rst_dt, dt
+       integer :: START_YEAR, START_MONTH, START_DAY, START_HOUR, START_MIN
+       character(len=256)  :: restart_file = ""
+       logical            :: history_output
+       integer            :: split_output_count
+       integer :: igrid
+       character(len=256) :: geo_static_flnm = ""
+       integer  :: DEEPGWSPIN
+       integer :: HIRES_OUT, order_to_write, rst_typ
+       
+!      additional character
+       character :: hgrid
+       character(len=19) :: olddate="123456"
+       character(len=19) :: startdate="123456"
+
+
+
+          integer:: RT_OPTION, CHANRTSWCRT, channel_option, &
+                  SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, &
+                  GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, &
+                  sys_cpl
+          real:: DTRT,dxrt0
+          character(len=256) :: route_topo_f=""
+          character(len=256) :: route_chan_f=""
+          character(len=256) :: route_link_f=""
+          character(len=256) :: route_lake_f=""
+          character(len=256) :: route_direction_f=""
+          character(len=256) :: route_order_f=""
+          character(len=256) :: gwbasmskfil =""
+          character(len=256) :: gwstrmfil =""
+          character(len=256) :: geo_finegrid_flnm =""
+
+   END TYPE namelist_rt_field 
+
diff --git a/wrfv2_fire/hydro/Data_Rec/rt_include.inc b/wrfv2_fire/hydro/Data_Rec/rt_include.inc
new file mode 100644
index 00000000..0441a485
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/rt_include.inc
@@ -0,0 +1,169 @@
+   TYPE RT_FIELD  
+   INTEGER :: IX, JX
+   logical initialized
+  REAL    :: DX,GRDAREART,SUBFLORT,WATAVAILRT,QSUBDRYRT,QSUBBDRYTRT
+  REAL    :: SFHEAD1RT,INFXS1RT,QSTRMVOLTRT,QBDRYTRT,SFHEADRT,ETPND1,INFXSRTOT
+  REAL    :: LAKE_INFLOTRT,accsuminfxs,diffsuminfxs,RETDEPFRAC
+  REAL    :: VERTKSAT,l3temp,l4temp,l3moist,l4moist,RNOF1TOT,RNOF2TOT,RNOF3TOT
+  INTEGER :: IXRT,JXRT,vegct
+  INTEGER :: AGGFACYRT, AGGFACXRT, KRTel_option, FORC_TYP
+  INTEGER :: SATLYRCHKRT,DT_FRACRT
+  INTEGER ::  LAKE_CT, STRM_CT
+  REAL                                 :: RETDEP_CHAN  ! Channel retention depth
+  INTEGER :: NLINKS  !maximum number of unique links in channel
+  INTEGER :: NLAKES  !number of lakes
+  INTEGER :: MAXORDER !maximum stream order
+  integer :: timestep_flag    ! 1 cold start run else continue run
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!DJG   VARIABLES FOR ROUTING
+  INTEGER, allocatable, DIMENSION(:,:)      :: CH_NETRT !-- keeps track of the 0-1 channel network
+  INTEGER, allocatable, DIMENSION(:,:)      :: CH_NETLNK !-- assigns a unique value to each channel gridpoint, called links
+  REAL,    allocatable, DIMENSION(:,:)      :: LATVAL,LONVAL !-- lat lon
+  REAL,    allocatable, DIMENSION(:,:)      :: TERRAIN
+  REAL, allocatable,    DIMENSION(:)        :: CHLAT,CHLON   !  channel lat and lon
+  ! INTEGER, allocatable, DIMENSION(:,:)      :: LAKE_MSKRT, BASIN_MSK,LAK_1K
+  INTEGER, allocatable, DIMENSION(:,:)      :: LAKE_MSKRT, LAK_1K
+  INTEGER, allocatable, DIMENSION(:,:)      :: g_LAK_1K
+  REAL,    allocatable, DIMENSION(:,:)      :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT
+  REAL,    allocatable, DIMENSION(:,:,:)    :: SO8RT
+  INTEGER,    allocatable, DIMENSION(:,:,:) :: SO8RT_D, SO8LD_D
+  REAL,    allocatable, DIMENSION(:,:)      :: SO8LD_Vmax
+  REAL   Vmax
+  REAL,    allocatable, DIMENSION(:,:)      :: SFCHEADRT,INFXSRT,LKSAT,LKSATRT
+  REAL,    allocatable, DIMENSION(:,:)      :: SFCHEADSUBRT,INFXSUBRT,LKSATFAC
+  REAL,    allocatable, DIMENSION(:,:)      :: QSUBRT,ZWATTABLRT,QSUBBDRYRT,SOLDEPRT
+  REAL,    allocatable, DIMENSION(:,:)      :: SUB_RESID
+  REAL,    allocatable, DIMENSION(:,:)      :: q_sfcflx_x,q_sfcflx_y
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!DJG   VARIABLES FOR GW/Baseflow
+  INTEGER :: numbasns
+  INTEGER, allocatable, DIMENSION(:,:)   :: GWSUBBASMSK  !GW basin mask grid
+  REAL,    allocatable, DIMENSION(:,:)   :: qinflowbase  !strm inflow/baseflow from GW
+  REAL,    allocatable, DIMENSION(:,:)   :: SOLDRAIN     !time-step drainage
+  INTEGER, allocatable, DIMENSION(:,:)   :: gw_strm_msk  !GW basin mask grid
+  REAL,    allocatable, DIMENSION(:)     :: z_gwsubbas   !depth in GW bucket
+  REAL,    allocatable, DIMENSION(:)     :: qin_gwsubbas !flow to GW bucket
+  REAL,    allocatable, DIMENSION(:)     :: qout_gwsubbas!flow from GW bucket
+  REAL,    allocatable, DIMENSION(:)     :: gwbas_pix_ct !ct of strm pixels in
+  REAL,    allocatable, DIMENSION(:)     :: basns_area   !basin area
+  REAL,    allocatable, DIMENSION(:)     :: node_area   !nodes area
+
+  REAL,    allocatable, DIMENSION(:)     :: z_q_bas_parm !GW bucket disch params
+  INTEGER, allocatable, DIMENSION(:)     :: ct2_bas       !ct of lnd pixels in basn
+  REAL,    allocatable, DIMENSION(:)     :: bas_pcp      !sub-basin avg'd pcp
+  INTEGER                                :: bas,bas_id
+  CHARACTER(len=19)                      :: header
+  CHARACTER(len=1)                       :: jnk
+  REAL, allocatable, DIMENSION(:)        :: gw_buck_coeff,gw_buck_exp,z_max  !GW bucket parameters
+!DJG Switch for Deep Sat GW Init:
+  INTEGER                                :: DEEPGWSPIN  !Switch to setup deep GW spinp
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!DJG,DNY   VARIABLES FOR CHANNEL ROUTING
+!-- channel params
+  INTEGER, allocatable, DIMENSION(:)   :: LINK       !channel link
+  INTEGER, allocatable, DIMENSION(:)   :: TO_NODE    !link's to node
+  INTEGER, allocatable, DIMENSION(:)   :: FROM_NODE  !link's from node
+  INTEGER, allocatable, DIMENSION(:)   :: ORDER      !link's order
+  INTEGER, allocatable, DIMENSION(:)   :: STRMFRXSTPTS      !frxst point flag
+  INTEGER, allocatable, DIMENSION(:)   :: TYPEL       !type of link Muskingum: 0 strm 1 lake
+                                                      !-- Diffusion: 0 edge or pour; 1 interior; 2 lake
+  INTEGER, allocatable, DIMENSION(:)   :: TYPEN      !type of link 0 strm 1 lake
+  REAL, allocatable, DIMENSION(:)      :: QLAKEI      !lake inflow in difussion scheme
+  REAL, allocatable, DIMENSION(:)      :: QLAKEO      !lake outflow in difussion scheme
+  INTEGER, allocatable, DIMENSION(:)   :: LAKENODE   !which nodes flow into which lakes
+  REAL, allocatable, DIMENSION(:)      :: CVOL       ! channel volume
+
+
+  REAL, allocatable, DIMENSION(:)      :: MUSK, MUSX !muskingum params
+  REAL, allocatable, DIMENSION(:)      :: CHANLEN    !link length
+  REAL, allocatable, DIMENSION(:)      :: MannN      !mannings N
+  REAL, allocatable, DIMENSION(:)      :: So         !link slope
+  REAL, allocatable, DIMENSION(:)      :: ChSSlp, Bw !trapezoid link params
+  REAL, allocatable, DIMENSION(:,:)    :: QLINK      !flow in link
+  REAL, allocatable, DIMENSION(:)      :: HLINK      !head in link
+  REAL, allocatable, DIMENSION(:)      :: ZELEV      !elevation of nodes for channel
+  INTEGER, allocatable, DIMENSION(:)   :: CHANXI,CHANYJ !map chan to fine grid
+  REAL,  DIMENSION(50)     :: BOTWID,HLINK_INIT,CHAN_SS,CHMann !Channel parms from table
+
+  REAL, allocatable, DIMENSION(:)      :: RESHT  !reservoir height
+!-- lake params
+  REAL, allocatable, DIMENSION(:)    :: HRZAREA    !horizontal extent of lake, km^2
+  REAL, allocatable, DIMENSION(:)    :: WEIRL      !overtop weir length (m)
+  REAL, allocatable, DIMENSION(:)    :: ORIFICEC   !coefficient of orifice
+  REAL, allocatable, DIMENSION(:)    :: ORIFICEA   !orifice opening area (m^2)
+  REAL, allocatable, DIMENSION(:)    :: ORIFICEE   !orifice elevation (m)
+  REAL, allocatable, DIMENSION(:)    :: LATLAKE, LONLAKE,ELEVLAKE ! lake info
+#ifdef MPP_LAND
+  INTEGER, allocatable, DIMENSION(:)    :: lake_index,nlinks_index
+  INTEGER, allocatable, DIMENSION(:,:)  :: Link_location
+  integer mpp_nlinks, yw_mpp_nlinks
+#endif
+
+  REAL,    allocatable, DIMENSION(:,:)      :: OVROUGHRTFAC,RETDEPRTFAC
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!DJG   VARIABLES FOR AGGREGATION/DISAGGREGATION
+  REAL,    allocatable, DIMENSION(:,:,:)   :: SMCRT,SMCMAXRT,SMCWLTRT,SH2OWGT
+  REAL,    allocatable, DIMENSION(:,:)     :: INFXSAGGRT
+  REAL,    allocatable, DIMENSION(:,:)     :: DHRT,QSTRMVOLRT,QBDRYRT,LAKE_INFLORT
+  !yw REAL,    allocatable, DIMENSION(:,:)     :: QSTRMVOLRT_TS,LAKE_INFLORT_TS
+!  REAL,    allocatable, DIMENSION(:,:)     :: QSTRMVOLRT_DUM,LAKE_INFLORT_DUM
+  REAL,    allocatable, DIMENSION(:,:)       :: INFXSWGT, ywtmp
+  REAL,    allocatable, DIMENSION(:)       :: SMCAGGRT,STCAGGRT,SH2OAGGRT
+  REAL    :: INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT
+  REAL,    allocatable, DIMENSION(:,:,:)       :: dist  ! 8 direction of distance
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!DJG   VARIABLES FOR ONLINE MASS BALANCE CALCULATION
+  REAL(KIND=8)    :: DCMC,DSWE,DACRAIN,DSFCEVP,DCANEVP,DEDIR,DETT,DEPND,DESNO,DSFCRNFF
+  REAL(KIND=8)    :: DSMCTOT,RESID,SUMEVP,DUG1RNFF,DUG2RNFF,SMCTOT1,SMCTOT2,DETP
+  REAL(KIND=8)    :: suminfxsrt,suminfxs1,suminfxs2,dprcp_ts
+  REAL(KIND=8)    :: CHAN_IN1,CHAN_IN2,LAKE_IN1,LAKE_IN2,zzz, CHAN_STOR,CHAN_OUT
+  REAL(KIND=8)    :: CHAN_INV,LAKE_INV  !-channel and lake inflow in volume
+  REAL(KIND=8)    :: DQBDRY
+  REAL    :: QSTRMVOLTRT1,LAKE_INFLOTRT1,QBDRYTOT1,LSMVOL
+  REAL(KIND=8),    allocatable, DIMENSION(:)   :: DSMC,SMCRTCHK
+  REAL(KIND=8),    allocatable, DIMENSION(:,:)  :: CMC_INIT,SWE_INIT
+!  REAL(KIND=8),    allocatable, DIMENSION(:,:,:) :: SMC_INIT
+  REAL(KIND=8)            :: SMC_INIT,SMC_FINAL,resid2,resid1
+  REAL(KIND=8)            :: chcksm1,chcksm2,CMC1,CMC2,prcp_in,ETATOT,dsmctot_av
+
+  integer :: g_ixrt,g_jxrt,flag
+  integer :: allo_status = -99
+  integer iywtmp
+
+
+!-- lake params
+  REAL, allocatable, DIMENSION(:)    :: LAKEMAXH   !maximum depth (m)
+  REAL, allocatable, DIMENSION(:)    :: WEIRC      !coeff of overtop weir
+
+
+
+
+!DJG Modified namelist for routing and agg. variables
+  real Z_tmp
+
+  !!! define land surface grid variables
+      REAL,    allocatable, DIMENSION(:,:,:) :: SMC,STC,SH2OX
+      REAL,    allocatable, DIMENSION(:,:)   :: SMCMAX1,SMCWLT1,SMCREF1
+      INTEGER, allocatable, DIMENSION(:,:)   :: VEGTYP 
+      REAL,    allocatable, DIMENSION(:)   :: SLDPTH
+
+!!! define constant/parameter
+    real ::   ov_rough(50), ZSOIL(100)
+!  out_counts: couput counts for current run.
+!  his_out_counts: used for channel routing output and  special for restart. 
+!  his_out_counts = previous run + out_counts
+    integer :: out_counts, rst_counts, his_out_counts
+    
+    REAL,    allocatable, DIMENSION(:,:)   :: lat_lsm, lon_lsm
+    REAL,    allocatable, DIMENSION(:,:,:) :: dist_lsm
+
+   END TYPE RT_FIELD
diff --git a/wrfv2_fire/hydro/HYDRO_drv/Makefile b/wrfv2_fire/hydro/HYDRO_drv/Makefile
new file mode 100644
index 00000000..9a04d9e6
--- /dev/null
+++ b/wrfv2_fire/hydro/HYDRO_drv/Makefile
@@ -0,0 +1,28 @@
+# Makefile 
+#
+.SUFFIXES:
+.SUFFIXES: .o .F
+
+include ../macros
+
+OBJS = \
+	module_HYDRO_drv.o
+all:	$(OBJS) 
+
+.F.o:
+	@echo ""
+	$(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f
+	$(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I../mod $(*).f
+	$(RMD) $(*).f
+	@echo ""
+	ar -r ../lib/libHYDRO.a $(@)
+	cp *.mod ../mod
+
+#
+# Dependencies:
+#
+module_HYDRO_drv.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o ../Data_Rec/module_GW_baseflow_data.o \
+        ../Routing/module_GW_baseflow.o ../Routing/module_HYDRO_utils.o ../Routing/module_HYDRO_io.o ../Routing/module_RT.o
+
+clean:
+	rm -f *.o *.mod *.stb *~ *.f
diff --git a/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F b/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F
new file mode 100644
index 00000000..2157f293
--- /dev/null
+++ b/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F
@@ -0,0 +1,1152 @@
+module module_HYDRO_drv
+#ifdef MPP_LAND 
+   use module_HYDRO_io, only:  mpp_output_rt, mpp_output_chrt, mpp_output_lakes, mpp_output_chrtgrd
+   USE module_mpp_land
+#else
+   use module_HYDRO_io, only:  output_rt, output_chrt, output_lakes
+#endif
+   use module_HYDRO_io, only: output_gw, restart_out_nc, restart_in_nc,  &
+        get_file_dimension ,get2d_lsm_real, get2d_lsm_vegtyp, get2d_lsm_soltyp, &
+        output_lsm
+   use module_rt_data, only: rt_domain
+   use module_GW_baseflow_data, only: gw2d
+   use module_GW_baseflow, only: gw2d_allocate, gw2d_ini
+   use module_namelist, only: nlst_rt
+   use module_routing, only: getChanDim, landrt_ini
+   use module_HYDRO_utils
+   use module_namelist
+   
+   implicit none
+
+   contains
+   subroutine HYDRO_rst_out(did)
+      implicit none
+      integer:: rst_out  
+      integer did, outflag
+      character(len=19) out_date
+      rst_out = -99
+#ifdef MPP_LAND
+   if(IO_id .eq. my_id) then
+#endif
+     if(nlst_rt(did)%dt .gt. nlst_rt(did)%rst_dt*60) then
+        call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%rst_counts))
+     else
+        call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%rst_dt*60*rt_domain(did)%rst_counts))
+     endif
+     if ( out_date(1:19) == nlst_rt(did)%olddate(1:19) ) then
+           rst_out = 99
+           rt_domain(did)%rst_counts = rt_domain(did)%rst_counts + 1
+     endif
+! restart every month automatically.
+     if ((nlst_rt(did)%olddate(9:10) == "01") .and. (nlst_rt(did)%olddate(12:13) == "00") .and. &
+          (nlst_rt(did)%olddate(15:16) == "00").and. (nlst_rt(did)%olddate(18:19) == "00")) rst_out = 99
+#ifdef MPP_LAND
+   endif
+     call mpp_land_bcast_int1(rst_out)
+#endif
+    if(rst_out .gt. 0) &
+             call   RESTART_OUT_nc(trim("HYDRO_RST."//nlst_rt(did)%olddate(1:16)   &
+                 //"_DOMAIN"//trim(nlst_rt(did)%hgrid)),  did)
+
+#ifdef MPP_LAND
+   if(IO_id .eq. my_id) then
+#endif
+#ifdef HYDRO_D
+      write(6,*) "restartFile  =",  "RESTART."//nlst_rt(did)%olddate(1:16)   &
+                 //"_DOMAIN"//trim(nlst_rt(did)%hgrid)
+#endif
+#ifdef MPP_LAND
+   endif
+#endif
+
+
+   end subroutine HYDRO_rst_out
+
+   subroutine HYDRO_out(did)
+      implicit none
+      integer did, outflag
+      character(len=19) out_date, rt_out_date
+      integer :: Kt, ounit
+
+!    real, dimension(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx):: soilmx_tmp, &
+!           runoff1x_tmp, runoff2x_tmp, runoff3x_tmp,etax_tmp, &
+!           EDIRX_tmp,ECX_tmp,ETTX_tmp,RCX_tmp,HX_tmp,acrain_tmp, &
+!           ACSNOM_tmp, esnow2d_tmp, drip2d_tmp,dewfall_tmp, fpar_tmp, &
+!           qfx_tmp, prcp_out_tmp, etpndx_tmp
+
+   outflag = -99
+
+#ifdef MPP_LAND
+   if(IO_id .eq. my_id) then
+#endif
+      if(nlst_rt(did)%olddate(1:19) .eq. nlst_rt(did)%startdate(1:19) .and. rt_domain(did)%his_out_counts .eq. 0) then
+#ifdef HYDRO_D
+         write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19), rt_domain(did)%his_out_counts
+#endif
+         call geth_newdate(rt_out_date, nlst_rt(did)%olddate, -1*nint(rt_domain(did)%his_out_counts*nlst_rt(did)%out_dt*60))
+         outflag = 99
+      else
+         if(nlst_rt(did)%dt .gt. nlst_rt(did)%out_dt*60) then
+             call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%out_counts))
+         else
+             call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%out_dt*60*rt_domain(did)%out_counts))
+         endif
+         if ( out_date(1:19) == nlst_rt(did)%olddate(1:19) ) then
+#ifdef HYDRO_D
+             write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19)
+#endif
+             outflag = 99
+             call geth_newdate(rt_out_date, nlst_rt(did)%olddate, -1*nint(rt_domain(did)%his_out_counts*nlst_rt(did)%out_dt*60))
+         endif
+      endif
+#ifdef MPP_LAND
+   endif
+     call mpp_land_bcast_int1(outflag)
+#endif
+
+     call HYDRO_rst_out(did) 
+
+     if (outflag .lt. 0) return
+
+     rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1
+     rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1
+
+     if(nlst_rt(did)%out_dt*60 .gt. nlst_rt(did)%DT) then
+        kt = rt_domain(did)%his_out_counts*nlst_rt(did)%out_dt*60/nlst_rt(did)%DT
+     else
+        kt = rt_domain(did)%his_out_counts
+     endif
+
+
+
+
+     call output_lsm(trim(nlst_rt(did)%olddate(1:4)//nlst_rt(did)%olddate(6:7)//nlst_rt(did)%olddate(9:10)  &
+                 //nlst_rt(did)%olddate(12:13)//nlst_rt(did)%olddate(15:16)//  &
+                 ".LSMOUT_DOMAIN"//trim(nlst_rt(did)%hgrid)),     &
+                 did)
+
+    
+
+        if(nlst_rt(did)%SUBRTSWCRT .gt. 0 &
+             .or. nlst_rt(did)%OVRTSWCRT .gt. 0 &
+             .or. nlst_rt(did)%GWBASESWCRT .gt. 0 ) then
+           if (nlst_rt(did)%HIRES_OUT.ge.1) then
+
+
+#ifdef MPP_LAND
+              call mpp_output_rt(rt_domain(did)%g_ixrt, rt_domain(did)%g_jxrt,    &
+#else
+              call output_rt(    &
+#endif
+                nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+                RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, &
+                nlst_rt(did)%nsoil, &
+!               nlst_rt(did)%startdate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,&
+                rt_out_date, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,&
+                RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SMCRT,&
+                RT_DOMAIN(did)%SUB_RESID,       &
+                   RT_DOMAIN(did)%q_sfcflx_x,RT_DOMAIN(did)%q_sfcflx_y,&
+                RT_DOMAIN(did)%soxrt,RT_DOMAIN(did)%soyrt,&
+                RT_DOMAIN(did)%QSTRMVOLRT,RT_DOMAIN(did)%SFCHEADSUBRT, &
+                nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT,&
+                RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL,&
+                RT_DOMAIN(did)%LONVAL,RT_DOMAIN(did)%dist,nlst_rt(did)%HIRES_OUT,&
+                RT_DOMAIN(did)%QBDRYRT )
+
+           if(nlst_rt(did)%GWBASESWCRT .eq. 3) then
+	     
+              call output_gw(    &
+                nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+                RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt,          &
+                nlst_rt(did)%nsoil,                               &
+!               nlst_rt(did)%startdate, nlst_rt(did)%olddate,    &
+                rt_out_date, nlst_rt(did)%olddate,    &
+                gw2d(did)%h, RT_DOMAIN(did)%SMCRT,                 &
+                gw2d(did)%convgw, RT_DOMAIN(did)%SFCHEADSUBRT,     &
+                nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT, &
+                RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL,       &
+                RT_DOMAIN(did)%LONVAL,rt_domain(did)%dist,           &
+                nlst_rt(did)%HIRES_OUT)
+
+	  endif
+! BF end gw2d output section
+
+           end if
+#ifdef HYDRO_D
+          write(6,*) "before call output_chrt"
+#endif
+     
+           if (nlst_rt(did)%CHANRTSWCRT.eq.1.or.nlst_rt(did)%CHANRTSWCRT.eq.2) then 
+
+#ifdef MPP_LAND
+             call mpp_output_chrt(rt_domain(did)%mpp_nlinks,rt_domain(did)%nlinks_index, &
+#else
+             call output_chrt(  &
+#endif
+               nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+               RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, &
+!              nlst_rt(did)%startdate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,&
+               rt_out_date,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,&
+               RT_DOMAIN(did)%CHLAT, &
+               RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, &
+               RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, &
+               RT_DOMAIN(did)%STRMFRXSTPTS,nlst_rt(did)%order_to_write)
+
+#ifdef MPP_LAND
+              call mpp_output_chrtgrd(nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+                  RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt, RT_DOMAIN(did)%NLINKS,   &
+                  RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%ORDER, &
+                  nlst_rt(did)%startdate, nlst_rt(did)%olddate, &
+                  RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm,   &
+                  RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index,                   &
+                  RT_DOMAIN(did)%g_ixrt,RT_DOMAIN(did)%g_jxrt )
+#endif
+
+               if (RT_DOMAIN(did)%NLAKES.gt.0)  &
+#ifdef MPP_LAND
+                call mpp_output_lakes( RT_DOMAIN(did)%lake_index, &
+#else
+                call output_lakes(  &
+#endif
+                   nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+                   RT_DOMAIN(did)%NLAKES, &
+!                  trim(nlst_rt(did)%startdate), trim(nlst_rt(did)%olddate), &
+                   trim(rt_out_date), trim(nlst_rt(did)%olddate), &
+                   RT_DOMAIN(did)%LATLAKE,RT_DOMAIN(did)%LONLAKE, &
+                   RT_DOMAIN(did)%ELEVLAKE,RT_DOMAIN(did)%QLAKEI, &
+                   RT_DOMAIN(did)%QLAKEO, &
+                   RT_DOMAIN(did)%RESHT,nlst_rt(did)%DT,Kt)
+           endif
+#ifdef HYDRO_D
+           write(6,*) "end calling output functions"
+#endif
+
+        endif  ! end of routing switch
+
+
+      end subroutine HYDRO_out
+
+
+      subroutine HYDRO_rst_in(did)
+        integer :: did
+        integer:: flag 
+
+
+
+   flag = -1
+#ifdef MPP_LAND
+   if(my_id.eq.IO_id) then
+#endif
+      if (trim(nlst_rt(did)%restart_file) /= "") then
+          flag = 99
+          rt_domain(did)%timestep_flag = 99   ! continue run
+      endif 
+#ifdef MPP_LAND
+   endif 
+   call mpp_land_bcast_int1(flag)
+#endif
+
+      
+   if (flag.eq.99) then
+
+#ifdef MPP_LAND
+     if(my_id.eq.IO_id) then
+#endif
+#ifdef HYDRO_D
+        write(6,*) "*** read restart data: ",trim(nlst_rt(did)%restart_file)
+#endif
+#ifdef MPP_LAND
+     endif 
+#endif
+      call   RESTART_IN_nc(trim(nlst_rt(did)%restart_file), did)
+
+  if (trim(nlst_rt(did)%restart_file) /= "") then 
+          nlst_rt(did)%restart_file = ""
+  endif
+  endif
+ end subroutine HYDRO_rst_in
+
+     subroutine HYDRO_time_adv(did)
+        implicit none
+        character(len = 19) :: newdate 
+        integer did
+ 
+#ifdef MPP_LAND
+   if(IO_id.eq.my_id) then
+#endif
+         call geth_newdate(newdate, nlst_rt(did)%olddate, nint( nlst_rt(did)%dt))
+         nlst_rt(did)%olddate = newdate
+#ifdef HYDRO_D
+         write(6,*) "current time is ",newdate
+#endif
+#ifdef MPP_LAND
+   endif
+#endif
+     end subroutine HYDRO_time_adv
+
+  integer function nfeb_yw(year)
+    !
+    ! Compute the number of days in February for the given year.
+    !
+    implicit none
+    integer, intent(in) :: year ! Four-digit year
+
+    nfeb_yw = 28 ! By default, February has 28 days ...
+    if (mod(year,4).eq.0) then
+       nfeb_yw = 29  ! But every four years, it has 29 days ...
+       if (mod(year,100).eq.0) then
+          nfeb_yw = 28  ! Except every 100 years, when it has 28 days ...
+          if (mod(year,400).eq.0) then
+             nfeb_yw = 29  ! Except every 400 years, when it has 29 days ...
+             if (mod(year,3600).eq.0) then
+                nfeb_yw = 28  ! Except every 3600 years, when it has 28 days.
+             endif
+          endif
+       endif
+    endif
+  end function nfeb_yw
+
+  subroutine geth_newdate (ndate, odate, idt)
+    implicit none
+
+    !  From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and 
+    !  delta-time, compute the new date.
+
+    !  on entry     -  odate  -  the old hdate.
+    !                  idt    -  the change in time
+
+    !  on exit      -  ndate  -  the new hdate.
+
+    integer, intent(in)           :: idt
+    character (len=*), intent(out) :: ndate
+    character (len=*), intent(in)  :: odate
+
+    !  Local Variables
+
+    !  yrold    -  indicates the year associated with "odate"
+    !  moold    -  indicates the month associated with "odate"
+    !  dyold    -  indicates the day associated with "odate"
+    !  hrold    -  indicates the hour associated with "odate"
+    !  miold    -  indicates the minute associated with "odate"
+    !  scold    -  indicates the second associated with "odate"
+
+    !  yrnew    -  indicates the year associated with "ndate"
+    !  monew    -  indicates the month associated with "ndate"
+    !  dynew    -  indicates the day associated with "ndate"
+    !  hrnew    -  indicates the hour associated with "ndate"
+    !  minew    -  indicates the minute associated with "ndate"
+    !  scnew    -  indicates the second associated with "ndate"
+
+    !  mday     -  a list assigning the number of days in each month
+
+    !  i        -  loop counter
+    !  nday     -  the integer number of days represented by "idt"
+    !  nhour    -  the integer number of hours in "idt" after taking out
+    !              all the whole days
+    !  nmin     -  the integer number of minutes in "idt" after taking out
+    !              all the whole days and whole hours.
+    !  nsec     -  the integer number of minutes in "idt" after taking out
+    !              all the whole days, whole hours, and whole minutes.
+
+    integer :: newlen, oldlen
+    integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew
+    integer :: yrold, moold, dyold, hrold, miold, scold, frold
+    integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc
+    logical :: opass
+    character (len=10) :: hfrc
+    character (len=1) :: sp
+    logical :: punct
+    integer :: yrstart, yrend, mostart, moend, dystart, dyend
+    integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart
+    integer :: units
+    integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/)
+!yw    integer nfeb_yw   
+
+    ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...."
+    if (odate(5:5) == "-") then
+       punct = .TRUE.
+    else
+       punct = .FALSE.
+    endif
+
+    !  Break down old hdate into parts
+
+    hrold = 0
+    miold = 0
+    scold = 0
+    frold = 0
+    oldlen = LEN(odate)
+    if (punct) then
+       yrstart = 1
+       yrend = 4
+       mostart = 6
+       moend = 7
+       dystart = 9
+       dyend = 10
+       hrstart = 12
+       hrend = 13
+       mistart = 15
+       miend = 16
+       scstart = 18
+       scend = 19
+       frstart = 21
+       select case (oldlen)
+       case (10)
+          ! Days
+          units = 1
+       case (13)
+          ! Hours
+          units = 2
+       case (16)
+          ! Minutes
+          units = 3
+       case (19)
+          ! Seconds
+          units = 4
+       case (21)
+          ! Tenths
+          units = 5
+       case (22)
+          ! Hundredths
+          units = 6
+       case (23)
+          ! Thousandths
+          units = 7
+       case (24)
+          ! Ten thousandths
+          units = 8
+       case default
+#ifdef HYDRO_D
+          write(*,*) 'ERROR: geth_newdate:  odd length: #'//trim(odate)//'#'
+          stop
+#endif
+       end select
+
+       if (oldlen.ge.11) then
+          sp = odate(11:11)
+       else
+          sp = ' '
+       end if
+
+    else
+
+       yrstart = 1
+       yrend = 4
+       mostart = 5
+       moend = 6
+       dystart = 7
+       dyend = 8
+       hrstart = 9
+       hrend = 10
+       mistart = 11
+       miend = 12
+       scstart = 13
+       scend = 14
+       frstart = 15
+
+       select case (oldlen)
+       case (8)
+          ! Days
+          units = 1
+       case (10)
+          ! Hours
+          units = 2
+       case (12)
+          ! Minutes
+          units = 3
+       case (14)
+          ! Seconds
+          units = 4
+       case (15)
+          ! Tenths
+          units = 5
+       case (16)
+          ! Hundredths
+          units = 6
+       case (17)
+          ! Thousandths
+          units = 7
+       case (18)
+          ! Ten thousandths
+          units = 8
+       case default
+#ifdef HYDRO_D
+          write(*,*) 'ERROR: geth_newdate:  odd length: #'//trim(odate)//'#'
+          stop
+#endif
+       end select
+    endif
+
+    !  Use internal READ statements to convert the CHARACTER string
+    !  date into INTEGER components.
+
+    read(odate(yrstart:yrend),  '(i4)') yrold
+    read(odate(mostart:moend),  '(i2)') moold
+    read(odate(dystart:dyend), '(i2)') dyold
+    if (units.ge.2) then
+       read(odate(hrstart:hrend),'(i2)') hrold
+       if (units.ge.3) then
+          read(odate(mistart:miend),'(i2)') miold
+          if (units.ge.4) then
+             read(odate(scstart:scend),'(i2)') scold
+             if (units.ge.5) then
+                read(odate(frstart:oldlen),*) frold
+             end if
+          end if
+       end if
+    end if
+
+    !  Set the number of days in February for that year.
+
+    mday(2) = nfeb_yw(yrold)
+
+    !  Check that ODATE makes sense.
+
+    opass = .TRUE.
+
+    !  Check that the month of ODATE makes sense.
+
+    if ((moold.gt.12).or.(moold.lt.1)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Month of ODATE = ', moold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the day of ODATE makes sense.
+
+    if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Day of ODATE = ', dyold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the hour of ODATE makes sense.
+
+    if ((hrold.gt.23).or.(hrold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Hour of ODATE = ', hrold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the minute of ODATE makes sense.
+
+    if ((miold.gt.59).or.(miold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Minute of ODATE = ', miold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the second of ODATE makes sense.
+
+    if ((scold.gt.59).or.(scold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Second of ODATE = ', scold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the fractional part  of ODATE makes sense.
+    if (.not.opass) then
+#ifdef HYDRO_D
+       write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen
+       stop
+#endif
+    end if
+
+    !  Date Checks are completed.  Continue.
+
+
+    !  Compute the number of days, hours, minutes, and seconds in idt
+
+    if (units.ge.5) then !idt should be in fractions of seconds
+       ifrc = oldlen-(frstart)+1
+       ifrc = 10**ifrc
+       nday   = abs(idt)/(86400*ifrc)
+       nhour  = mod(abs(idt),86400*ifrc)/(3600*ifrc)
+       nmin   = mod(abs(idt),3600*ifrc)/(60*ifrc)
+       nsec   = mod(abs(idt),60*ifrc)/(ifrc)
+       nfrac = mod(abs(idt), ifrc)
+    else if (units.eq.4) then  !idt should be in seconds
+       ifrc = 1
+       nday   = abs(idt)/86400 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),86400)/3600
+       nmin   = mod(abs(idt),3600)/60
+       nsec   = mod(abs(idt),60)
+       nfrac  = 0
+    else if (units.eq.3) then !idt should be in minutes
+       ifrc = 1
+       nday   = abs(idt)/1440 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),1440)/60
+       nmin   = mod(abs(idt),60)
+       nsec   = 0
+       nfrac  = 0
+    else if (units.eq.2) then !idt should be in hours
+       ifrc = 1
+       nday   = abs(idt)/24 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),24)
+       nmin   = 0
+       nsec   = 0
+       nfrac  = 0
+    else if (units.eq.1) then !idt should be in days
+       ifrc = 1
+       nday   = abs(idt)    ! integer number of days in delta-time
+       nhour  = 0
+       nmin   = 0
+       nsec   = 0
+       nfrac  = 0
+    else
+#ifdef HYDRO_D
+       write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') &
+            oldlen
+       write(*,*) '#'//odate(1:oldlen)//'#'
+       stop
+#endif
+    end if
+
+    if (idt.ge.0) then
+
+       frnew = frold + nfrac
+       if (frnew.ge.ifrc) then
+          frnew = frnew - ifrc
+          nsec = nsec + 1
+       end if
+
+       scnew = scold + nsec
+       if (scnew .ge. 60) then
+          scnew = scnew - 60
+          nmin  = nmin + 1
+       end if
+
+       minew = miold + nmin
+       if (minew .ge. 60) then
+          minew = minew - 60
+          nhour  = nhour + 1
+       end if
+
+       hrnew = hrold + nhour
+       if (hrnew .ge. 24) then
+          hrnew = hrnew - 24
+          nday  = nday + 1
+       end if
+
+       dynew = dyold
+       monew = moold
+       yrnew = yrold
+       do i = 1, nday
+          dynew = dynew + 1
+          if (dynew.gt.mday(monew)) then
+             dynew = dynew - mday(monew)
+             monew = monew + 1
+             if (monew .gt. 12) then
+                monew = 1
+                yrnew = yrnew + 1
+                ! If the year changes, recompute the number of days in February
+                mday(2) = nfeb_yw(yrnew)
+             end if
+          end if
+       end do
+
+    else if (idt.lt.0) then
+
+       frnew = frold - nfrac
+       if (frnew .lt. 0) then
+          frnew = frnew + ifrc
+          nsec = nsec + 1
+       end if
+
+       scnew = scold - nsec
+       if (scnew .lt. 00) then
+          scnew = scnew + 60
+          nmin  = nmin + 1
+       end if
+
+       minew = miold - nmin
+       if (minew .lt. 00) then
+          minew = minew + 60
+          nhour  = nhour + 1
+       end if
+
+       hrnew = hrold - nhour
+       if (hrnew .lt. 00) then
+          hrnew = hrnew + 24
+          nday  = nday + 1
+       end if
+
+       dynew = dyold
+       monew = moold
+       yrnew = yrold
+       do i = 1, nday
+          dynew = dynew - 1
+          if (dynew.eq.0) then
+             monew = monew - 1
+             if (monew.eq.0) then
+                monew = 12
+                yrnew = yrnew - 1
+                ! If the year changes, recompute the number of days in February
+                mday(2) = nfeb_yw(yrnew)
+             end if
+             dynew = mday(monew)
+          end if
+       end do
+    end if
+
+    !  Now construct the new mdate
+
+    newlen = LEN(ndate)
+
+    if (punct) then
+
+       if (newlen.gt.frstart) then
+          write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew
+          write(hfrc,'(i10)') frnew+1000000000
+          ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10)
+
+       else if (newlen.eq.scend) then
+          write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew
+19        format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2)
+
+       else if (newlen.eq.miend) then
+          write(ndate,16) yrnew, monew, dynew, hrnew, minew
+16        format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2)
+
+       else if (newlen.eq.hrend) then
+          write(ndate,13) yrnew, monew, dynew, hrnew
+13        format(i4,'-',i2.2,'-',i2.2,'_',i2.2)
+
+       else if (newlen.eq.dyend) then
+          write(ndate,10) yrnew, monew, dynew
+10        format(i4,'-',i2.2,'-',i2.2)
+
+       end if
+
+    else
+
+       if (newlen.gt.frstart) then
+          write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew
+          write(hfrc,'(i10)') frnew+1000000000
+          ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10)
+
+       else if (newlen.eq.scend) then
+          write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew
+119       format(i4,i2.2,i2.2,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.miend) then
+          write(ndate,116) yrnew, monew, dynew, hrnew, minew
+116       format(i4,i2.2,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.hrend) then
+          write(ndate,113) yrnew, monew, dynew, hrnew
+113       format(i4,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.dyend) then
+          write(ndate,110) yrnew, monew, dynew
+110       format(i4,i2.2,i2.2)
+
+       end if
+
+    endif
+
+    if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp
+
+  end subroutine geth_newdate
+  
+     subroutine HYDRO_exe(did)
+
+
+        implicit none
+        integer:: did
+        integer:: rst_out
+
+
+        call HYDRO_out(did)
+
+
+! running land surface model
+! cpl: 0--offline run; 
+!      1-- coupling with WRF but running offline lsm; 
+!      2-- coupling with WRF but do not run offline lsm  
+!      3-- coupling with LIS and do not run offline lsm  
+!      4:  coupling with CLM
+!          if(nlst_rt(did)%SYS_CPL .eq. 0 .or. nlst_rt(did)%SYS_CPL .eq. 1 )then
+!                  call drive_noahLSF(did,kt)
+!          else
+!              ! does not run the NOAH LASF model, only read the parameter
+!              call read_land_par(did,lsm(did)%ix,lsm(did)%jx)
+!          endif
+
+
+
+
+
+           IF (nlst_rt(did)%GWBASESWCRT .ne. 0     &
+               .or. nlst_rt(did)%SUBRTSWCRT .NE.0  &
+               .or. nlst_rt(did)%OVRTSWCRT .NE. 0 ) THEN
+
+
+! running routing model
+                call exeRouting(did)
+
+    END IF    ! End if for channel routing option
+
+
+! advance to next time step
+!      if(
+           call HYDRO_time_adv(did)
+
+      ! output for history 
+           call HYDRO_out(did)
+
+
+            
+           RT_DOMAIN(did)%SOLDRAIN = 0
+           RT_DOMAIN(did)%QSUBRT = 0
+
+
+
+      end subroutine HYDRO_exe
+
+
+      subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp)
+        implicit none
+        integer ntime, did
+        integer rst_out, ix,jx
+!        integer, OPTIONAL:: ix0,jx0
+        integer:: ix0,jx0
+        integer, dimension(ix0,jx0),OPTIONAL :: vegtyp, soltyp
+
+
+
+#ifdef MPP_LAND
+    call  MPP_LAND_INIT()
+#endif
+
+
+! read the namelist
+! the lsm namelist will be read by rtland sequentially again.
+     call read_rt_nlst(nlst_rt(did) )
+
+
+             IF (nlst_rt(did)%GWBASESWCRT .eq. 0 &
+               .and. nlst_rt(did)%SUBRTSWCRT .eq.0  &
+               .and. nlst_rt(did)%OVRTSWCRT .eq. 0 ) return
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! get the dimension 
+     call get_file_dimension(trim(nlst_rt(did)%geo_static_flnm), ix,jx)
+   
+       
+#ifdef MPP_LAND
+
+  if (nlst_rt(did)%sys_cpl .eq. 1 .or. nlst_rt(did)%sys_cpl .eq. 4) then
+!sys_cpl: 1-- coupling with HRLDAS but running offline lsm; 
+!         2-- coupling with WRF but do not run offline lsm  
+!         3-- coupling with LIS and do not run offline lsm  
+!         4:  coupling with CLM
+
+! create 2 dimensiaon logical mapping of the CPUs for coupling with CLM or HRLDAS.
+         call log_map2d()
+
+         global_nx = ix  ! get from land model
+         global_ny = jx  ! get from land model
+
+         call mpp_land_bcast_int1(global_nx)
+         call mpp_land_bcast_int1(global_ny)
+
+!!! temp set global_nx to ix 
+         rt_domain(did)%ix = global_nx
+         rt_domain(did)%jx = global_ny
+
+! over write the ix and jx
+         call MPP_LAND_PAR_INI(1,rt_domain(did)%ix,rt_domain(did)%jx,&
+              nlst_rt(did)%AGGFACTRT)
+   else  
+!  coupled with WRF, LIS
+         numprocs = node_info(1,1)
+
+         call wrf_LAND_set_INIT(node_info,numprocs,nlst_rt(did)%AGGFACTRT)
+
+
+         rt_domain(did)%ix = local_nx
+         rt_domain(did)%jx = local_ny
+   endif
+
+     
+
+      rt_domain(did)%g_IXRT=global_rt_nx
+      rt_domain(did)%g_JXRT=global_rt_ny
+      rt_domain(did)%ixrt = local_rt_nx
+      rt_domain(did)%jxrt = local_rt_ny
+
+#ifdef HYDRO_D
+      write(6,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt"
+      write(6,*)  rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt
+      write(6,*) "rt_domain(did)%ix, rt_domain(did)%jx "
+      write(6,*) rt_domain(did)%ix, rt_domain(did)%jx 
+      write(6,*) "global_nx, global_ny, local_nx, local_ny"
+      write(6,*) global_nx, global_ny, local_nx, local_ny
+#endif
+#else
+! sequential
+      rt_domain(did)%ix = ix
+      rt_domain(did)%jx = jx
+      rt_domain(did)%ixrt = ix*nlst_rt(did)%AGGFACTRT 
+      rt_domain(did)%jxrt = jx*nlst_rt(did)%AGGFACTRT
+#endif
+
+      
+!      allocate rt arrays
+
+
+       call getChanDim(did)
+
+
+#ifdef HYDRO_D
+       write(6,*) "finish getChanDim "
+#endif
+
+      if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then
+          call gw2d_allocate(did,&
+                             rt_domain(did)%ixrt,&
+                             rt_domain(did)%jxrt,&
+                             nlst_rt(did)%nsoil)
+#ifdef HYDRO_D
+       write(6,*) "finish gw2d_allocate"
+#endif
+      endif
+
+! calculate the distance between grids for routing.
+! decompose the land parameter/data 
+
+
+!      ix0= rt_domain(did)%ix
+!      jx0= rt_domain(did)%jx
+      if(present(vegtyp)) then
+           call lsm_input(did,ix0=ix0,jx0=jx0,vegtyp0=vegtyp,soltyp0=soltyp)
+      else
+           call lsm_input(did,ix0=ix0,jx0=jx0)
+      endif
+
+
+#ifdef HYDRO_D
+       write(6,*) "finish decomposion"
+#endif
+
+
+     call get_dist_lsm(did) 
+     call get_dist_lrt(did)
+
+
+! rt model initilization
+      call LandRT_ini(did)
+
+#ifdef HYDRO_D
+      write(6,*) "finish LandRT_ini"    
+#endif
+
+       
+      if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then
+	
+          call gw2d_ini(did,&
+                        nlst_rt(did)%dt,&
+                        nlst_rt(did)%dxrt0)
+#ifdef HYDRO_D                        
+          write(6,*) "finish gw2d_ini"      
+#endif
+      endif
+#ifdef HYDRO_D
+       write(6,*) "finish LandRT_ini"
+#endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+     IF (nlst_rt(did)%TERADJ_SOLAR.EQ.1 .and. nlst_rt(did)%CHANRTSWCRT.NE.2) THEN   ! Perform ter rain adjustment of incoming solar
+#ifdef MPP_LAND
+          call MPP_seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,&
+             rt_domain(did)%TERRAIN, rt_domain(did)%dist_lsm,&
+             rt_domain(did)%ix,rt_domain(did)%jx,global_nx,global_ny)
+#else
+          call seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,&
+                   rt_domain(did)%TERRAIN,rt_domain(did)%dist_lsm,&
+                   rt_domain(did)%ix,rt_domain(did)%jx)
+#endif
+    endif
+
+
+     IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2 .or. nlst_rt(did)%GWBASESWCRT .gt. 0) then
+       call get_basn_area(did)
+     endif
+
+     IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2 ) then
+!       call get_basn_area(did)
+        call get_node_area(did)
+     endif
+     
+
+
+!      if(rt_domain(did)%rst_flag .eq. -99 ) return
+! restart the file
+       call HYDRO_rst_in(did)
+
+! output at the initial time
+       call HYDRO_out(did)
+
+
+      end subroutine HYDRO_ini
+
+      subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0)
+         implicit none
+         integer did, leng
+         parameter(leng=100)
+         integer :: i,j, nn
+         integer, allocatable, dimension(:,:) :: soltyp
+         real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc
+
+        integer :: ix0,jx0
+        integer, dimension(ix0,jx0),OPTIONAL :: vegtyp0, soltyp0
+
+#ifdef HYDRO_D
+         write(6,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx
+#endif
+
+         allocate(soltyp(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) )
+
+         soltyp = 0
+         call get2d_lsm_soltyp(soltyp,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm))
+
+
+         call get2d_lsm_real("HGT",RT_DOMAIN(did)%TERRAIN,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm))
+
+         call get2d_lsm_real("XLAT",RT_DOMAIN(did)%lat_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm))
+         call get2d_lsm_real("XLONG",RT_DOMAIN(did)%lon_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm))
+         call get2d_lsm_vegtyp(RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm))
+
+
+
+            if(nlst_rt(did)%sys_cpl .eq. 2 ) then
+              ! coupling with WRF
+                if(present(soltyp0) ) then
+                   where(soltyp0 == 14) VEGTYP0 = 16
+                   where(VEGTYP0 == 16 ) soltyp0 = 14
+                   soltyp = soltyp0
+                   RT_DOMAIN(did)%VEGTYP = VEGTYP0
+                endif
+            endif
+
+         where(soltyp == 14) RT_DOMAIN(did)%VEGTYP = 16
+         where(RT_DOMAIN(did)%VEGTYP == 16 ) soltyp = 14
+
+! LKSAT, 
+! temporary set
+       RT_DOMAIN(did)%SMCRTCHK = 0
+       RT_DOMAIN(did)%SMCAGGRT = 0
+       RT_DOMAIN(did)%STCAGGRT = 0
+       RT_DOMAIN(did)%SH2OAGGRT = 0
+     
+
+       RT_DOMAIN(did)%zsoil(1:nlst_rt(did)%nsoil) = nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil)
+
+       RT_DOMAIN(did)%sldpth(1) = abs( RT_DOMAIN(did)%zsoil(1) )
+       do i = 2, nlst_rt(did)%nsoil
+          RT_DOMAIN(did)%sldpth(i) = RT_DOMAIN(did)%zsoil(i-1)-RT_DOMAIN(did)%zsoil(i)
+       enddo
+       RT_DOMAIN(did)%SOLDEPRT = -1.0*RT_DOMAIN(did)%ZSOIL(nlst_rt(did)%NSOIL)
+
+!      input OV_ROUGH from OVROUGH.TBL
+#ifdef MPP_LAND
+       if(my_id .eq. IO_id) then
+#endif
+
+       open(71,file="HYDRO.TBL", form="formatted") 
+!read OV_ROUGH first
+          read(71,*) nn
+          read(71,*)    
+          do i = 1, nn
+             read(71,*) RT_DOMAIN(did)%OV_ROUGH(i)
+          end do 
+!read parameter for LKSAT
+          read(71,*) nn
+          read(71,*)    
+          do i = 1, nn
+             read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i)
+          end do 
+       close(71)
+
+#ifdef MPP_LAND
+       endif
+       call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH)
+       call mpp_land_bcast_real(leng,xdum1)
+       call mpp_land_bcast_real(leng,MAXSMC)
+       call mpp_land_bcast_real(leng,refsmc)
+       call mpp_land_bcast_real(leng,wltsmc)
+#endif
+
+       rt_domain(did)%lksat = 0.0
+       do j = 1, RT_DOMAIN(did)%jx
+             do i = 1, RT_DOMAIN(did)%ix
+                rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0
+                IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN   ! urban
+                    rt_domain(did)%SMCMAX1(i,j) = 0.45
+                    rt_domain(did)%SMCREF1(i,j) = 0.42
+                    rt_domain(did)%SMCWLT1(i,j) = 0.40
+                else
+                    rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J))
+                    rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J))
+                    rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J))
+                ENDIF
+             end do
+       end do
+
+       deallocate(soltyp)
+
+
+      end subroutine lsm_input
+
+
+end module module_HYDRO_drv
+
+! stop the job due to the fatal error.
+      subroutine HYDRO_stop()
+        integer :: ierr
+#ifdef HYDRO_D
+      write(6,*) "The job is stoped due to the fatal error."
+#endif
+#ifdef MPP_LAND
+#ifndef HYDRO_D
+      print*, "---"
+      print*, "ERROR! Program stopped. Recompile with environment variable HYDRO_D set to 1 for enhanced debug information."
+      print*, ""
+#endif
+         call mpp_land_abort()
+         call MPI_finalize(ierr)
+#else
+         stop "Fatal Error"
+#endif
+
+     return
+     end  subroutine HYDRO_stop  
+
+! stop the job due to the fatal error.
+      subroutine HYDRO_finish()
+#ifdef MPP_LAND
+        USE module_mpp_land
+#endif
+        integer :: ierr
+
+        print*, "The model finished successfully......."
+#ifdef MPP_LAND
+!         call mpp_land_abort()
+         call mpp_land_sync()
+         call MPI_finalize(ierr)
+         stop 
+#else
+         stop 
+#endif
+
+     return
+     end  subroutine HYDRO_finish
+
diff --git a/wrfv2_fire/hydro/MPP/CPL_WRF.F b/wrfv2_fire/hydro/MPP/CPL_WRF.F
new file mode 100644
index 00000000..45876b9b
--- /dev/null
+++ b/wrfv2_fire/hydro/MPP/CPL_WRF.F
@@ -0,0 +1,159 @@
+!   This is used as a coupler with the WRF model.
+MODULE MODULE_CPL_LAND
+
+
+  IMPLICIT NONE
+
+  integer my_global_id
+ 
+  integer total_pe_num
+  integer global_ix,global_jx
+
+  integer,allocatable,dimension(:,:) :: node_info
+
+  logical initialized, cpl_land, time_step_read_rstart, &
+           time_step_write_rstart, time_step_output
+  character(len=19) cpl_outdate, cpl_rstdate
+
+
+
+  contains
+
+  subroutine CPL_LAND_INIT(istart,iend,jstart,jend)
+      implicit none
+   include "mpif.h"
+      integer  ierr
+      logical mpi_inited
+      integer istart,iend,jstart,jend 
+
+      CALL mpi_initialized( mpi_inited, ierr )
+      if ( .NOT. mpi_inited ) then
+          call mpi_init(ierr)
+      endif
+
+      call MPI_COMM_RANK( MPI_COMM_WORLD, my_global_id, ierr )
+      call MPI_COMM_SIZE( MPI_COMM_WORLD, total_pe_num, ierr )
+
+      allocate(node_info(9,total_pe_num))
+
+      node_info = -99
+
+! send node info to node 0
+      node_info(1,my_global_id+1) = total_pe_num
+      node_info(6,my_global_id+1) = istart
+      node_info(7,my_global_id+1) = iend
+      node_info(8,my_global_id+1) = jstart
+      node_info(9,my_global_id+1) = jend
+
+
+      call send_info()
+      call find_left()
+      call find_right()
+      call find_up()
+      call find_down()
+
+      call send_info()
+
+      initialized = .false.  ! land model need to be initialized. 
+      return
+  END subroutine CPL_LAND_INIT
+
+     subroutine send_info()
+        implicit none
+   include "mpif.h"
+        integer,allocatable,dimension(:,:) :: tmp_info
+        integer  ierr, i,size, tag
+        integer mpp_status(MPI_STATUS_SIZE)
+        tag  = 9 
+        size =  9
+
+        if(my_global_id .eq. 0) then
+           do i = 1, total_pe_num-1 
+             call mpi_recv(node_info(:,i+1),size,MPI_INTEGER,  &
+                i,tag,MPI_COMM_WORLD,mpp_status,ierr) 
+           enddo
+        else
+           call mpi_send(node_info(:,my_global_id+1),size,   &
+               MPI_INTEGER,0,tag,MPI_COMM_WORLD,ierr) 
+        endif 
+
+        call MPI_barrier( MPI_COMM_WORLD ,ierr)
+
+        size = 9 * total_pe_num
+        call mpi_bcast(node_info,size,MPI_INTEGER,   &
+            0,MPI_COMM_WORLD,ierr)
+
+        call MPI_barrier( MPI_COMM_WORLD ,ierr)
+
+     return
+     end  subroutine send_info
+
+     subroutine find_left()
+          implicit none
+          integer i
+          
+          node_info(2,my_global_id+1) = -1
+
+          do i = 1, total_pe_num 
+               if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. &
+                   (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. &
+                   ((node_info(7,i)+1).eq.node_info(6,my_global_id+1)) ) then
+                   node_info(2,my_global_id+1) = i - 1
+                   return
+               endif 
+          end do
+     return
+     end subroutine find_left
+
+     subroutine find_right()
+          implicit none
+          integer i
+          
+          node_info(3,my_global_id+1) = -1
+
+          do i = 1, total_pe_num 
+               if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. &
+                   (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. &
+                   ((node_info(6,i)-1).eq.node_info(7,my_global_id+1)) ) then
+                   node_info(3,my_global_id+1) = i - 1
+                   return
+               endif 
+          end do
+     return
+     end subroutine find_right
+
+     subroutine find_up()
+          implicit none
+          integer i
+          
+          node_info(4,my_global_id+1) = -1
+
+          do i = 1, total_pe_num 
+               if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. &
+                   (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. &
+                   ((node_info(8,i)-1).eq.node_info(9,my_global_id+1)) ) then
+                   node_info(4,my_global_id+1) = i - 1
+                   return
+               endif 
+          end do
+     return
+     end subroutine find_up
+
+     subroutine find_down()
+          implicit none
+          integer i
+          
+          node_info(5,my_global_id+1) = -1
+
+          do i = 1, total_pe_num 
+               if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. &
+                   (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. &
+                   ((node_info(9,i)+1).eq.node_info(8,my_global_id+1)) ) then
+                   node_info(5,my_global_id+1) = i - 1
+                   return
+               endif 
+          end do
+     return
+     end subroutine find_down
+
+END MODULE MODULE_CPL_LAND
diff --git a/wrfv2_fire/hydro/MPP/Makefile b/wrfv2_fire/hydro/MPP/Makefile
new file mode 100644
index 00000000..abc0b055
--- /dev/null
+++ b/wrfv2_fire/hydro/MPP/Makefile
@@ -0,0 +1,26 @@
+# Makefile 
+#
+.SUFFIXES:
+.SUFFIXES: .o .F
+
+include ../macros
+
+OBJS =  CPL_WRF.o mpp_land.o 
+
+all:	$(OBJS)
+mpp_land.o: mpp_land.F
+	@echo ""
+	$(RMD) $(*).o $(*).mod $(*).stb *~
+	$(COMPILER90) $(F90FLAGS) -c $(*).F
+	ar -r ../lib/libHYDRO.a $(@)
+
+CPL_WRF.o: CPL_WRF.F
+	@echo ""
+	$(RMD) $(*).o $(*).mod $(*).stb *~ *.f
+	$(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f
+	$(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f
+        
+	$(COMPILER90) $(F90FLAGS)  -c $(*).F
+	ar -r ../lib/libHYDRO.a $(@)
+clean:
+	$(RMD) *.o *.mod *.stb *~
diff --git a/wrfv2_fire/hydro/MPP/mpp_land.F b/wrfv2_fire/hydro/MPP/mpp_land.F
new file mode 100644
index 00000000..78f6cecd
--- /dev/null
+++ b/wrfv2_fire/hydro/MPP/mpp_land.F
@@ -0,0 +1,1559 @@
+!#### This is a module for parallel Land model.
+MODULE MODULE_MPP_LAND
+
+  use MODULE_CPL_LAND 
+
+  IMPLICIT NONE
+  include "mpif.h"
+  integer, public :: left_id,right_id,up_id,down_id,my_id
+  integer, public :: left_right_np,up_down_np ! define total process in two dimensions.
+  integer, public :: left_right_p ,up_down_p ! the position of the current process in the logical topography.
+  integer, public :: IO_id   ! the number for IO. (Last processor for IO)
+  integer, public :: global_nx, global_ny, local_nx,local_ny
+  integer, public :: global_rt_nx, global_rt_ny
+  integer, public :: local_rt_nx,local_rt_ny,rt_AGGFACTRT
+  integer, public :: numprocs   ! total process, get by mpi initialization.
+
+  integer mpp_status(MPI_STATUS_SIZE)
+
+  integer  overlap_n
+  integer, allocatable, DIMENSION(:), public :: local_nx_size,local_ny_size
+  integer, allocatable, DIMENSION(:), public :: local_rt_nx_size,local_rt_ny_size
+  integer, allocatable, DIMENSION(:), public :: startx,starty
+ 
+  contains
+
+  subroutine LOG_MAP2d()
+    implicit none
+    integer :: ierr
+      call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) 
+      call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) 
+
+      call getNX_NY(numprocs, left_right_np,up_down_np)
+      if(my_id.eq.IO_id) then 
+#ifdef HYDRO_D
+            write(6,*) ""
+            write(6,*) "total process:",numprocs
+            write(6,*) "left_right_np =", left_right_np,&
+                 "up_down_np=",up_down_np
+#endif
+      end if
+
+!   ### get the row and column of the current process in the logical topography.
+!   ### left --> right, 0 -->left_right_np -1
+!   ### up --> down, 0 --> up_down_np -1
+        left_right_p = mod(my_id , left_right_np)
+        up_down_p = my_id / left_right_np
+
+!   ### get the neighbors.  -1 means no neighbor.
+        down_id = my_id - left_right_np
+        up_id =   my_id + left_right_np 
+        if( up_down_p .eq. 0) down_id = -1
+        if( up_down_p .eq. (up_down_np-1) ) up_id = -1
+
+        left_id = my_id - 1 
+        right_id = my_id + 1 
+        if( left_right_p .eq. 0) left_id = -1
+        if( left_right_p .eq. (left_right_np-1) ) right_id =-1
+    
+!    ### the IO node is the last processor.
+!yw        IO_id = numprocs - 1
+         IO_id = 0
+
+! print the information for debug.
+
+        call mpp_land_sync()
+
+  return 
+  end  subroutine log_map2d
+!old subroutine MPP_LAND_INIT(flag, ew_numprocs, sn_numprocs)
+  subroutine MPP_LAND_INIT()
+!    ### initialize the land model logically based on the two D method. 
+!    ### Call this function directly if it is nested with WRF.
+    implicit none
+    integer :: ierr
+    integer :: ew_numprocs, sn_numprocs  ! input the processors in x and y direction.
+    logical mpi_inited
+     
+!     left_right_np = ew_numprocs
+!     up_down_np  = sn_numprocs
+
+      CALL mpi_initialized( mpi_inited, ierr )
+      if ( .NOT. mpi_inited ) then
+           call MPI_INIT( ierr )  ! stand alone land model.
+      else 
+           call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) 
+           call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) 
+           return
+      endif
+!     create 2d logical mapping of the CPU.
+      call log_map2d()
+
+      return
+  end   subroutine MPP_LAND_INIT
+
+
+     subroutine MPP_LAND_PAR_INI(over_lap,in_global_nx,in_global_ny,AGGFACTRT)
+        integer in_global_nx,in_global_ny, AGGFACTRT
+        integer :: over_lap   ! the overlaped grid number. (default is 1)
+        global_nx = in_global_nx
+        global_ny = in_global_ny 
+        rt_AGGFACTRT = AGGFACTRT
+        global_rt_nx = in_global_nx*AGGFACTRT
+        global_rt_ny = in_global_ny *AGGFACTRT
+        !overlap_n = 1
+        local_nx = global_nx / left_right_np 
+        if(left_right_p .eq. (left_right_np-1) ) then
+              local_nx = global_nx   &
+                    -int(global_nx/left_right_np)*(left_right_np-1)
+        end if
+        local_ny = global_ny / up_down_np 
+        if(  up_down_p .eq. (up_down_np-1) ) then
+           local_ny = global_ny  &
+                 -int(global_ny/up_down_np)*(up_down_np -1)
+        end if
+
+        local_rt_nx=local_nx*AGGFACTRT+2
+        local_rt_ny=local_ny*AGGFACTRT+2
+        if(left_id.lt.0) local_rt_nx = local_rt_nx -1
+        if(right_id.lt.0) local_rt_nx = local_rt_nx -1
+        if(up_id.lt.0) local_rt_ny = local_rt_ny -1
+        if(down_id.lt.0) local_rt_ny = local_rt_ny -1
+
+        call get_local_size(local_nx, local_ny,local_rt_nx,local_rt_ny)
+        call calculate_start_p()
+        
+        in_global_nx = local_nx
+        in_global_ny = local_ny
+#ifdef HYDRO_D
+        write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_nx
+        write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_ny
+        write(6,*) "my_id=",my_id,"global_nx=",global_nx
+        write(6,*) "my_id=",my_id,"global_nx=",global_ny
+#endif
+        return 
+        end  subroutine MPP_LAND_PAR_INI
+
+  subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag)
+!   ### Communicate message on left right direction.
+    integer NX,NY
+    real in_out_data(nx,ny),data_r(2,ny)
+    integer count,size,tag,  ierr
+    integer flag   ! 99 replace the boundary, else get the sum.
+
+    if(flag .eq. 99) then ! replace the data  
+       if(right_id .ge. 0) then  !   ### send to right first.
+           tag = 11 
+           size = ny
+           call mpi_send(in_out_data(nx-1,:),size,MPI_REAL,   &
+             right_id,tag,MPI_COMM_WORLD,ierr)
+       end if
+       if(left_id .ge. 0) then !   receive from left
+           tag = 11
+           size = ny
+           call mpi_recv(in_out_data(1,:),size,MPI_REAL,  &
+              left_id,tag,MPI_COMM_WORLD,mpp_status,ierr)
+       endif 
+
+      if(left_id .ge. 0 ) then !   ### send to left second.
+          size = ny 
+          tag = 21
+          call mpi_send(in_out_data(2,:),size,MPI_REAL,   &
+             left_id,tag,MPI_COMM_WORLD,ierr)
+      endif
+      if(right_id .ge. 0) then !   receive from  right
+          tag = 21
+          size = ny 
+          call mpi_recv(in_out_data(nx,:),size,MPI_REAL,&
+             right_id,tag,MPI_COMM_WORLD, mpp_status,ierr)
+      endif
+
+    else   ! get the sum
+
+       if(right_id .ge. 0) then !   ### send to right first.
+         tag = 11
+         size = 2*ny 
+         call mpi_send(in_out_data(nx-1:nx,:),size,MPI_REAL,   &
+             right_id,tag,MPI_COMM_WORLD,ierr)
+       end if
+       if(left_id .ge. 0) then !   receive from left
+          tag = 11
+          size = 2*ny
+          call mpi_recv(data_r,size,MPI_REAL,left_id,tag, &
+               MPI_COMM_WORLD,mpp_status,ierr)
+          in_out_data(1,:) = in_out_data(1,:) + data_r(1,:)
+          in_out_data(2,:) = in_out_data(2,:) + data_r(2,:)
+       endif 
+
+      if(left_id .ge. 0 ) then !   ### send to left second.
+          size = 2*ny
+          tag = 21
+          call mpi_send(in_out_data(1:2,:),size,MPI_REAL,   &
+             left_id,tag,MPI_COMM_WORLD,ierr)
+      endif
+      if(right_id .ge. 0) then !   receive from  right
+          tag = 21
+          size = 2*ny
+          call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_REAL,&
+             right_id,tag,MPI_COMM_WORLD, mpp_status,ierr)
+      endif
+    endif   ! end if black for flag.
+
+    return
+  end subroutine MPP_LAND_LR_COM
+
+  subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag)
+!   ### Communicate message on left right direction.
+    integer NX,NY
+    real*8 in_out_data(nx,ny),data_r(2,ny)
+    integer count,size,tag,  ierr
+    integer flag   ! 99 replace the boundary, else get the sum.
+
+    if(flag .eq. 99) then ! replace the data  
+       if(right_id .ge. 0) then  !   ### send to right first.
+           tag = 11 
+           size = ny
+           call mpi_send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION,   &
+             right_id,tag,MPI_COMM_WORLD,ierr)
+       end if
+       if(left_id .ge. 0) then !   receive from left
+           tag = 11
+           size = ny
+           call mpi_recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION,  &
+              left_id,tag,MPI_COMM_WORLD,mpp_status,ierr)
+       endif 
+
+      if(left_id .ge. 0 ) then !   ### send to left second.
+          size = ny 
+          tag = 21
+          call mpi_send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION,   &
+             left_id,tag,MPI_COMM_WORLD,ierr)
+      endif
+      if(right_id .ge. 0) then !   receive from  right
+          tag = 21
+          size = ny 
+          call mpi_recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,&
+             right_id,tag,MPI_COMM_WORLD, mpp_status,ierr)
+      endif
+
+    else   ! get the sum
+
+       if(right_id .ge. 0) then !   ### send to right first.
+         tag = 11
+         size = 2*ny 
+         call mpi_send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,   &
+             right_id,tag,MPI_COMM_WORLD,ierr)
+       end if
+       if(left_id .ge. 0) then !   receive from left
+          tag = 11
+          size = 2*ny
+          call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, &
+               MPI_COMM_WORLD,mpp_status,ierr)
+          in_out_data(1,:) = in_out_data(1,:) + data_r(1,:)
+          in_out_data(2,:) = in_out_data(2,:) + data_r(2,:)
+       endif 
+
+      if(left_id .ge. 0 ) then !   ### send to left second.
+          size = 2*ny
+          tag = 21
+          call mpi_send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION,   &
+             left_id,tag,MPI_COMM_WORLD,ierr)
+      endif
+      if(right_id .ge. 0) then !   receive from  right
+          tag = 21
+          size = 2*ny
+          call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,&
+             right_id,tag,MPI_COMM_WORLD, mpp_status,ierr)
+      endif
+    endif   ! end if black for flag.
+
+    return
+  end subroutine MPP_LAND_LR_COM8
+  
+  
+  subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny)
+    integer local_nx, local_ny, rt_nx,rt_ny
+    integer i,status,ierr, tag
+    integer tmp_nx,tmp_ny
+!   ### if it is IO node, get the local_size of the x and y direction 
+!   ### for all other tasks.
+    integer s_r(2)
+
+!   if(my_id .eq. IO_id) then 
+       allocate(local_nx_size(numprocs),stat = status) 
+       allocate(local_ny_size(numprocs),stat = status) 
+       allocate(local_rt_nx_size(numprocs),stat = status) 
+       allocate(local_rt_ny_size(numprocs),stat = status) 
+!   end if
+
+       call mpp_land_sync()
+
+       if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1 
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 1
+                 call mpi_recv(s_r,2,MPI_INTEGER,i, & 
+                      tag,MPI_COMM_WORLD,mpp_status,ierr)
+                 local_nx_size(i+1) = s_r(1)
+                 local_ny_size(i+1) = s_r(2)
+               else
+                   local_nx_size(i+1) = local_nx
+                   local_ny_size(i+1) = local_ny
+               end if
+           end do
+       else 
+           tag =  1  
+           s_r(1) = local_nx
+           s_r(2) = local_ny
+           call mpi_send(s_r,2,MPI_INTEGER, IO_id,     &
+               tag,MPI_COMM_WORLD,ierr)
+       end if
+
+ 
+       if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1 
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 2
+                 call mpi_recv(s_r,2,MPI_INTEGER,i, & 
+                      tag,MPI_COMM_WORLD,mpp_status,ierr)
+                 local_rt_nx_size(i+1) = s_r(1)
+                 local_rt_ny_size(i+1) = s_r(2)
+               else
+                   local_rt_nx_size(i+1) = rt_nx
+                   local_rt_ny_size(i+1) = rt_ny
+               end if
+           end do
+       else 
+           tag =  2  
+           s_r(1) = rt_nx
+           s_r(2) = rt_ny
+           call mpi_send(s_r,2,MPI_INTEGER, IO_id,     &
+               tag,MPI_COMM_WORLD,ierr)
+       end if
+       call mpp_land_sync()
+       return 
+  end  subroutine get_local_size
+
+
+  subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag)
+!   ### Communicate message on up down direction.
+    integer NX,NY
+    real in_out_data(nx,ny),data_r(nx,2)
+    integer count,size,tag, status, ierr
+    integer flag  ! 99 replace the boundary , else get the sum of the boundary
+
+
+    if(flag .eq. 99) then  ! replace the boundary data.
+
+       if(up_id .ge. 0 ) then !   ### send to up first.
+           tag = 31
+           size = nx
+           call mpi_send(in_out_data(:,ny-1),size,MPI_REAL,   &
+               up_id,tag,MPI_COMM_WORLD,ierr)
+       endif
+       if(down_id .ge. 0 ) then !   receive from down 
+           tag = 31 
+           size = nx
+           call mpi_recv(in_out_data(:,1),size,MPI_REAL, &
+              down_id,tag,MPI_COMM_WORLD, mpp_status,ierr)
+       endif
+   
+       if(down_id .ge. 0 ) then !   send down.
+           tag = 41
+           size = nx
+           call mpi_send(in_out_data(:,2),size,MPI_REAL,      &
+                down_id,tag,MPI_COMM_WORLD,ierr)
+       endif
+       if(up_id .ge. 0 ) then !   receive from upper 
+           tag = 41 
+           size = nx
+           call mpi_recv(in_out_data(:,ny),size,MPI_REAL, &
+               up_id,tag,MPI_COMM_WORLD,mpp_status,ierr)
+       endif
+     
+    else  ! flag = 1 
+
+       if(up_id .ge. 0 ) then !   ### send to up first.
+           tag = 31
+           size = nx*2
+           call mpi_send(in_out_data(:,ny-1:ny),size,MPI_REAL,   &
+               up_id,tag,MPI_COMM_WORLD,ierr)
+       endif
+       if(down_id .ge. 0 ) then !   receive from down
+           tag = 31
+           size = nx*2
+           call mpi_recv(data_r,size,MPI_REAL, &
+              down_id,tag,MPI_COMM_WORLD, mpp_status,ierr)
+           in_out_data(:,1) = in_out_data(:,1) + data_r(:,1)
+           in_out_data(:,2) = in_out_data(:,2) + data_r(:,2)
+       endif
+
+       if(down_id .ge. 0 ) then !   send down.
+           tag = 41
+           size = nx*2
+           call mpi_send(in_out_data(:,1:2),size,MPI_REAL,      &
+                down_id,tag,MPI_COMM_WORLD,ierr)
+       endif
+       if(up_id .ge. 0 ) then !   receive from upper
+           tag = 41
+           size = nx * 2
+           call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_REAL, &
+               up_id,tag,MPI_COMM_WORLD,mpp_status,ierr)
+       endif
+    endif  ! end of block  flag
+    return
+  end  subroutine MPP_LAND_UB_COM
+
+  subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag)
+!   ### Communicate message on up down direction.
+    integer NX,NY
+    real*8 in_out_data(nx,ny),data_r(nx,2)
+    integer count,size,tag, status, ierr
+    integer flag  ! 99 replace the boundary , else get the sum of the boundary
+
+
+    if(flag .eq. 99) then  ! replace the boundary data.
+
+       if(up_id .ge. 0 ) then !   ### send to up first.
+           tag = 31
+           size = nx
+           call mpi_send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION,   &
+               up_id,tag,MPI_COMM_WORLD,ierr)
+       endif
+       if(down_id .ge. 0 ) then !   receive from down 
+           tag = 31 
+           size = nx
+           call mpi_recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, &
+              down_id,tag,MPI_COMM_WORLD, mpp_status,ierr)
+       endif
+   
+       if(down_id .ge. 0 ) then !   send down.
+           tag = 41
+           size = nx
+           call mpi_send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION,      &
+                down_id,tag,MPI_COMM_WORLD,ierr)
+       endif
+       if(up_id .ge. 0 ) then !   receive from upper 
+           tag = 41 
+           size = nx
+           call mpi_recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, &
+               up_id,tag,MPI_COMM_WORLD,mpp_status,ierr)
+       endif
+     
+    else  ! flag = 1 
+
+       if(up_id .ge. 0 ) then !   ### send to up first.
+           tag = 31
+           size = nx*2
+           call mpi_send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION,   &
+               up_id,tag,MPI_COMM_WORLD,ierr)
+       endif
+       if(down_id .ge. 0 ) then !   receive from down
+           tag = 31
+           size = nx*2
+           call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION, &
+              down_id,tag,MPI_COMM_WORLD, mpp_status,ierr)
+           in_out_data(:,1) = in_out_data(:,1) + data_r(:,1)
+           in_out_data(:,2) = in_out_data(:,2) + data_r(:,2)
+       endif
+
+       if(down_id .ge. 0 ) then !   send down.
+           tag = 41
+           size = nx*2
+           call mpi_send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION,      &
+                down_id,tag,MPI_COMM_WORLD,ierr)
+       endif
+       if(up_id .ge. 0 ) then !   receive from upper
+           tag = 41
+           size = nx * 2
+           call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, &
+               up_id,tag,MPI_COMM_WORLD,mpp_status,ierr)
+       endif
+    endif  ! end of block  flag
+    return
+  end  subroutine MPP_LAND_UB_COM8
+  
+  subroutine calculate_start_p()
+! calculate startx and starty
+    integer :: local_startx, local_starty
+    integer :: i,status, ierr, tag
+    integer :: r_s(2)
+
+    allocate(starty(numprocs),stat = ierr) 
+    allocate(startx(numprocs),stat = ierr)
+
+    local_startx = int(global_nx/left_right_np) * left_right_p+1 
+    local_starty = int(global_ny/up_down_np) * up_down_p+1 
+    if(left_id .lt. 0) local_startx = 1
+    if(down_id .lt. 0) local_starty = 1
+
+    if(my_id .eq. IO_id) then
+         startx(my_id+1) = local_startx
+         starty(my_id+1) = local_starty
+    end if
+
+    r_s(1) = local_startx
+    r_s(2) = local_starty
+    call mpp_land_sync()
+
+    if(my_id .eq. IO_id) then
+        do i = 0, numprocs - 1
+           ! block receive  from other node.
+           if(i.ne.my_id) then
+              tag = 1
+              call mpi_recv(r_s,2,MPI_INTEGER,i, &
+                   tag,MPI_COMM_WORLD,mpp_status,ierr)
+              startx(i+1) = r_s(1)
+              starty(i+1) = r_s(2)
+           end if
+        end do
+     else
+           tag =  1
+           call mpi_send(r_s,2,MPI_INTEGER, IO_id,     &
+               tag,MPI_COMM_WORLD,ierr)
+     end if
+
+     call mpp_land_sync()
+
+     return
+  end subroutine calculate_start_p
+
+  subroutine decompose_data_real (in_buff,out_buff)
+! usage: all of the cpu call this subroutine.
+! the IO node will distribute the data to rest of the node.
+      real in_buff(global_nx,global_ny),out_buff(local_nx,local_ny) 
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+
+      tag = 2
+      if(my_id .eq. IO_id) then
+         do i = 0, numprocs - 1
+            ibegin = startx(i+1)
+            iend   = startx(i+1)+local_nx_size(i+1) -1
+            jbegin = starty(i+1)
+            jend   = starty(i+1)+local_ny_size(i+1) -1
+          
+            if(my_id .eq. i) then
+               out_buff=in_buff(ibegin:iend,jbegin:jend)
+            else
+               ! send data to the rest process.
+               size = local_nx_size(i+1)*local_ny_size(i+1)
+               call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,&
+                  MPI_REAL, i,tag,MPI_COMM_WORLD,ierr)
+            end if
+         end do
+      else 
+         size = local_nx*local_ny
+         call mpi_recv(out_buff,size,MPI_REAL,IO_id, &
+                tag,MPI_COMM_WORLD,mpp_status,ierr) 
+      end if
+      return
+  end subroutine decompose_data_real
+
+  subroutine decompose_data_int (in_buff,out_buff)
+! usage: all of the cpu call this subroutine.
+! the IO node will distribute the data to rest of the node.
+      integer in_buff(global_nx,global_ny),out_buff(local_nx,local_ny) 
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+ 
+      tag = 2
+      if(my_id .eq. IO_id) then
+         do i = 0, numprocs - 1
+            ibegin = startx(i+1)
+            iend   = startx(i+1)+local_nx_size(i+1) -1
+            jbegin = starty(i+1)
+            jend   = starty(i+1)+local_ny_size(i+1) -1
+            if(my_id .eq. i) then
+               out_buff=in_buff(ibegin:iend,jbegin:jend)
+            else
+               ! send data to the rest process.
+               size = local_nx_size(i+1)*local_ny_size(i+1)
+               call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,&
+                  MPI_INTEGER, i,tag,MPI_COMM_WORLD,ierr)
+            end if
+         end do
+      else 
+         size = local_nx*local_ny
+         call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, &
+                tag,MPI_COMM_WORLD,mpp_status,ierr) 
+      end if
+      return
+  end subroutine decompose_data_int
+
+  subroutine write_IO_int(in_buff,out_buff)
+! the IO node will receive the data from the rest process.
+      integer in_buff(1:local_nx,1:local_ny),    &
+          out_buff(global_nx,global_ny)
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+      if(my_id .ne. IO_id) then
+          size = local_nx*local_ny
+          tag = 2
+          call mpi_send(in_buff,size,MPI_INTEGER, IO_id,     &
+                tag,MPI_COMM_WORLD,ierr)
+      else
+          do i = 0, numprocs - 1
+            ibegin = startx(i+1)
+            iend   = startx(i+1)+local_nx_size(i+1) -1
+            jbegin = starty(i+1)
+            jend   = starty(i+1)+local_ny_size(i+1) -1
+            if(i .eq. IO_id) then
+               out_buff(ibegin:iend,jbegin:jend) = in_buff 
+            else 
+               size = local_nx_size(i+1)*local_ny_size(i+1)
+               tag = 2
+               call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,&
+                   MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr)
+            end if
+          end do
+      end if
+      return
+  end subroutine write_IO_int
+
+  subroutine write_IO_real(in_buff,out_buff)
+! the IO node will receive the data from the rest process.
+      real in_buff(1:local_nx,1:local_ny),    &
+          out_buff(global_nx,global_ny)
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+      if(my_id .ne. IO_id) then
+          size = local_nx*local_ny
+          tag = 2
+          call mpi_send(in_buff,size,MPI_REAL, IO_id,     &
+                tag,MPI_COMM_WORLD,ierr)
+      else
+          do i = 0, numprocs - 1
+            ibegin = startx(i+1)
+            iend   = startx(i+1)+local_nx_size(i+1) -1
+            jbegin = starty(i+1)
+            jend   = starty(i+1)+local_ny_size(i+1) -1
+            if(i .eq. IO_id) then
+               out_buff(ibegin:iend,jbegin:jend) = in_buff 
+            else 
+               size = local_nx_size(i+1)*local_ny_size(i+1)
+               tag = 2
+               call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,&
+                   MPI_REAL,i,tag,MPI_COMM_WORLD,mpp_status,ierr)
+            end if
+          end do
+      end if
+      return
+  end subroutine write_IO_real
+
+  subroutine write_IO_RT_real(in_buff,out_buff)
+! the IO node will receive the data from the rest process.
+      real in_buff(1:local_rt_nx,1:local_rt_ny),    &
+          out_buff(global_rt_nx,global_rt_ny)
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+      if(my_id .ne. IO_id) then
+          size = local_rt_nx*local_rt_ny
+          tag = 2
+          call mpi_send(in_buff,size,MPI_REAL, IO_id,     &
+                tag,MPI_COMM_WORLD,ierr)
+      else
+          do i = 0, numprocs - 1
+            ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) 
+            if(ibegin.gt.1) ibegin=ibegin - 1
+            iend   = ibegin + local_rt_nx_size(i+1) -1
+            jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+            if(jbegin.gt.1) jbegin=jbegin - 1
+            jend   = jbegin + local_rt_ny_size(i+1) -1
+            if(i .eq. IO_id) then
+               out_buff(ibegin:iend,jbegin:jend) = in_buff 
+            else 
+               size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1)
+               tag = 2
+               call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,&
+                   MPI_REAL,i,tag,MPI_COMM_WORLD,mpp_status,ierr)
+            end if
+          end do
+      end if
+      return
+  end subroutine write_IO_RT_real
+
+
+  subroutine write_IO_RT_int (in_buff,out_buff)
+! the IO node will receive the data from the rest process.
+      integer :: in_buff(1:local_rt_nx,1:local_rt_ny),    &
+          out_buff(global_rt_nx,global_rt_ny)
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+      if(my_id .ne. IO_id) then
+          size = local_rt_nx*local_rt_ny
+          tag = 2
+          call mpi_send(in_buff,size,MPI_INTEGER, IO_id,     &
+                tag,MPI_COMM_WORLD,ierr)
+      else
+          do i = 0, numprocs - 1
+            ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) 
+            if(ibegin.gt.1) ibegin=ibegin - 1
+            iend   = ibegin + local_rt_nx_size(i+1) -1
+            jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+            if(jbegin.gt.1) jbegin=jbegin - 1
+            jend   = jbegin + local_rt_ny_size(i+1) -1
+            if(i .eq. IO_id) then
+               out_buff(ibegin:iend,jbegin:jend) = in_buff 
+            else 
+               size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1)
+               tag = 2
+               call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,&
+                   MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr)
+            end if
+          end do
+      end if
+      return
+  end subroutine write_IO_RT_int
+
+  subroutine mpp_land_sync()
+      integer ierr
+       call MPI_barrier( MPI_COMM_WORLD ,ierr)
+      return
+  end subroutine mpp_land_sync
+
+! subroutine mpp_land_sync()
+!    integer tag, i, status, ierr,size
+!    integer buff(2)
+!    
+!     size =2 
+!     buff = 3 
+!     if(my_id .ne. IO_id) then
+!         tag = 2
+!         call mpi_send(buff,size,MPI_INTEGER, IO_id,     &
+!               tag,MPI_COMM_WORLD,ierr)
+!     else
+!         do i = 0, numprocs - 1
+!              tag = 2
+!            if(i .ne. IO_id) then
+!              call mpi_recv(buff,size,&
+!                  MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr)
+!           end if
+!         end do
+!     end if
+
+!     return
+! end subroutine mpp_land_sync
+
+  subroutine mpp_land_bcast_int(size,inout)
+      integer size
+      integer inout(size)
+      integer ierr
+        call mpi_bcast(inout,size,MPI_INTEGER,   &
+            IO_id,MPI_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_int
+
+  subroutine mpp_land_bcast_int1(inout)
+      integer inout
+      integer ierr
+        call mpi_bcast(inout,1,MPI_INTEGER,   &
+            IO_id,MPI_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_int1
+
+  subroutine mpp_land_bcast_real1(inout)
+      real inout
+      integer ierr
+        call mpi_bcast(inout,1,MPI_REAL,   &
+            IO_id,MPI_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_real1
+
+  subroutine mpp_land_bcast_real(size,inout)
+      integer size
+      real inout(size)
+      integer ierr
+        call mpi_bcast(inout,size,MPI_real,   &
+            IO_id,MPI_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_real
+
+  subroutine mpp_land_bcast_rd(size,inout)
+      integer size
+      real*8 inout(size)
+      integer ierr
+        call mpi_bcast(inout,size,MPI_REAL8,   &
+            IO_id,MPI_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_rd
+
+  subroutine mpp_land_bcast_char(size,inout)
+      integer size
+      character inout(*)
+      integer ierr
+        call mpi_bcast(inout,size,MPI_CHARACTER,   &
+            IO_id,MPI_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_char
+
+ 
+  subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag)
+!   ### Communicate message on left right and up bottom directions.
+    integer NX,NY
+    integer flag != 99  test only for land model. (replace the boundary).
+                 != 1   get the sum of the boundary value.
+    real in_out_data(nx,ny)
+
+    call MPP_LAND_LR_COM(in_out_data,NX,NY,flag)
+    call MPP_LAND_UB_COM(in_out_data,NX,NY,flag)
+
+    return
+  end subroutine MPP_LAND_COM_REAL
+
+  subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag)
+!   ### Communicate message on left right and up bottom directions.
+    integer NX,NY
+    integer flag != 99  test only for land model. (replace the boundary).
+                 != 1   get the sum of the boundary value.
+    real*8 in_out_data(nx,ny)
+
+    call MPP_LAND_LR_COM8(in_out_data,NX,NY,flag)
+    call MPP_LAND_UB_COM8(in_out_data,NX,NY,flag)
+
+    return
+  end subroutine MPP_LAND_COM_REAL8
+
+  subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag)
+!   ### Communicate message on left right and up bottom directions.
+    integer NX,NY
+    integer flag != 99  test only for land model. (replace the boundary).
+                 != 1   get the sum of the boundary value.
+    integer data(nx,ny)
+    real in_out_data(nx,ny)
+
+    in_out_data = data + 0.0
+    call MPP_LAND_LR_COM(in_out_data,NX,NY,flag)
+    call MPP_LAND_UB_COM(in_out_data,NX,NY,flag)
+    data = in_out_data + 0
+
+    return
+  end subroutine MPP_LAND_COM_INTEGER
+ 
+     subroutine read_restart_3(unit,nz,out)
+        integer unit,nz,i
+        real buf3(global_nx,global_ny,nz),&
+          out(local_nx,local_ny,3)
+        if(my_id.eq.IO_id) read(unit) buf3
+        do i = 1,nz
+          call decompose_data_real (buf3(:,:,i),out(:,:,i))
+        end do
+     return
+     end subroutine read_restart_3
+
+     subroutine read_restart_2(unit,out)
+        integer unit,ierr2
+        real  buf2(global_nx,global_ny),&
+          out(local_nx,local_ny)
+
+       if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2
+        call mpp_land_bcast_int1(ierr2)
+        if(ierr2 .ne. 0) return
+
+        call decompose_data_real (buf2,out)
+     return
+     end subroutine read_restart_2
+
+     subroutine read_restart_rt_2(unit,out)
+        integer unit,ierr2
+        real  buf2(global_rt_nx,global_rt_ny),&
+          out(local_rt_nx,local_rt_ny)
+
+       if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2
+        call mpp_land_bcast_int1(ierr2)
+        if(ierr2.ne.0) return
+
+        call decompose_RT_real(buf2,out, &
+          global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny)
+     return
+     end subroutine read_restart_rt_2
+
+     subroutine read_restart_rt_3(unit,nz,out)
+        integer unit,nz,i,ierr2
+        real buf3(global_rt_nx,global_rt_ny,nz),&
+          out(local_rt_nx,local_rt_ny,3)
+
+        if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf3
+        call mpp_land_bcast_int1(ierr2)
+        if(ierr2.ne.0) return
+
+        do i = 1,nz
+          call decompose_RT_real (buf3(:,:,i),out(:,:,i),&
+          global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny)
+        end do
+     return
+     end subroutine read_restart_rt_3
+
+     subroutine write_restart_3(unit,nz,in)
+        integer unit,nz,i
+        real buf3(global_nx,global_ny,nz),&
+          in(local_nx,local_ny,nz)
+        do i = 1,nz
+          call write_IO_real(in(:,:,i),buf3(:,:,i))
+        end do
+        if(my_id.eq.IO_id) write(unit) buf3
+     return
+     end subroutine write_restart_3
+
+     subroutine write_restart_2(unit,in)
+        integer unit
+        real  buf2(global_nx,global_ny),&
+           in(local_nx,local_ny)
+        call write_IO_real(in,buf2)
+        if(my_id.eq.IO_id) write(unit) buf2
+     return
+     end subroutine write_restart_2
+
+     subroutine write_restart_rt_2(unit,in)
+        integer unit
+        real  buf2(global_rt_nx,global_rt_ny), &
+           in(local_rt_nx,local_rt_ny)
+        call write_IO_RT_real(in,buf2)
+        if(my_id.eq.IO_id) write(unit) buf2
+     return
+     end subroutine write_restart_rt_2
+
+     subroutine write_restart_rt_3(unit,nz,in)
+        integer unit,nz,i
+        real buf3(global_rt_nx,global_rt_ny,nz),&
+          in(local_rt_nx,local_rt_ny,nz)
+        do i = 1,nz
+          call write_IO_RT_real(in(:,:,i),buf3(:,:,i))
+        end do
+        if(my_id.eq.IO_id) write(unit) buf3
+     return
+     end subroutine write_restart_rt_3
+
+   subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny)
+! usage: all of the cpu call this subroutine.
+! the IO node will distribute the data to rest of the node.
+      integer g_nx,g_ny,nx,ny
+      real in_buff(g_nx,g_ny),out_buff(nx,ny)
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+
+      tag = 2
+      if(my_id .eq. IO_id) then
+         do i = 0, numprocs - 1
+            ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) 
+            if(ibegin.gt.1) ibegin=ibegin - 1
+            iend   = ibegin + local_rt_nx_size(i+1) -1
+            jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+            if(jbegin.gt.1) jbegin=jbegin - 1
+            jend   = jbegin + local_rt_ny_size(i+1) -1
+
+            if(my_id .eq. i) then
+               out_buff=in_buff(ibegin:iend,jbegin:jend)
+            else
+               ! send data to the rest process.
+               size = (iend-ibegin+1)*(jend-jbegin+1)
+               call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,&
+                  MPI_REAL, i,tag,MPI_COMM_WORLD,ierr)
+            end if
+         end do
+      else
+         size = nx*ny
+         call mpi_recv(out_buff,size,MPI_REAL,IO_id, &
+                tag,MPI_COMM_WORLD,mpp_status,ierr)
+      end if
+      return
+  end subroutine decompose_RT_real
+
+   subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny)
+! usage: all of the cpu call this subroutine.
+! the IO node will distribute the data to rest of the node.
+      integer g_nx,g_ny,nx,ny
+      integer in_buff(g_nx,g_ny),out_buff(nx,ny)
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+
+      tag = 2
+        call mpp_land_sync()
+      if(my_id .eq. IO_id) then
+         do i = 0, numprocs - 1
+            ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+            if(ibegin.gt.1) ibegin=ibegin - 1
+            iend   = ibegin + local_rt_nx_size(i+1) -1
+            jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+            if(jbegin.gt.1) jbegin=jbegin - 1
+            jend   = jbegin + local_rt_ny_size(i+1) -1
+
+            if(my_id .eq. i) then
+               out_buff=in_buff(ibegin:iend,jbegin:jend)
+            else
+               ! send data to the rest process.
+               size = (iend-ibegin+1)*(jend-jbegin+1)
+               call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,&
+                  MPI_INTEGER, i,tag,MPI_COMM_WORLD,ierr)
+            end if
+         end do
+      else
+         size = nx*ny
+         call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, &
+                tag,MPI_COMM_WORLD,mpp_status,ierr)
+      end if
+      return
+  end subroutine decompose_RT_int
+
+  subroutine getNX_NY(nprocs, nx,ny)
+  ! calculate the nx and ny based on the total nprocs.
+    integer nprocs, nx, ny
+    integer i,j, max
+    max = nprocs
+    do j = 1, nprocs
+       if( mod(nprocs,j) .eq. 0 ) then
+           i = nprocs/j
+           if( abs(i-j) .lt. max) then
+               max = abs(i-j)
+               nx = i 
+               ny = j 
+           end if
+       end if
+    end do
+  return 
+  end subroutine getNX_NY
+
+     subroutine pack_global_22(in,   &
+        out,k)
+        integer ix,jx,k,i
+        real out(global_nx,global_ny,k)
+        real  in(local_nx,local_ny,k)
+        do i = 1, k
+          call write_IO_real(in(:,:,i),out(:,:,i))
+        enddo
+     return 
+     end subroutine pack_global_22
+
+
+  subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT)
+    implicit none
+    integer total_pe
+    integer info(9,total_pe),AGGFACTRT
+    integer :: ierr, status
+    integer i
+
+      call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) 
+      call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) 
+
+      if(numprocs .ne. total_pe) then
+         write(6,*) "Error: numprocs .ne. total_pe ",numprocs, total_pe 
+         call hydro_stop()
+      endif
+
+
+!   ### get the neighbors.  -1 means no neighbor.
+      left_id = info(2,my_id+1)
+      right_id = info(3,my_id+1)
+      up_id =   info(4,my_id+1)
+      down_id = info(5,my_id+1)
+      IO_id = 0
+
+       allocate(local_nx_size(numprocs),stat = status) 
+       allocate(local_ny_size(numprocs),stat = status) 
+       allocate(local_rt_nx_size(numprocs),stat = status) 
+       allocate(local_rt_ny_size(numprocs),stat = status) 
+       allocate(starty(numprocs),stat = ierr) 
+       allocate(startx(numprocs),stat = ierr)
+
+       i = my_id + 1
+       local_nx = info(7,i) - info(6,i) + 1
+       local_ny = info(9,i) - info(8,i) + 1
+ 
+       global_nx = 0
+       global_ny = 0
+       do i = 1, numprocs
+          global_nx = max(global_nx,info(7,i))
+          global_ny = max(global_ny,info(9,i))
+       enddo
+
+       local_rt_nx = local_nx*AGGFACTRT+2
+       local_rt_ny = local_ny*AGGFACTRT+2
+       if(left_id.lt.0) local_rt_nx = local_rt_nx -1
+       if(right_id.lt.0) local_rt_nx = local_rt_nx -1
+       if(up_id.lt.0) local_rt_ny = local_rt_ny -1
+       if(down_id.lt.0) local_rt_ny = local_rt_ny -1
+
+       global_rt_nx = global_nx*AGGFACTRT
+       global_rt_ny = global_ny*AGGFACTRT
+       rt_AGGFACTRT = AGGFACTRT
+
+       do i =1,numprocs 
+          local_nx_size(i) = info(7,i) - info(6,i) + 1
+          local_ny_size(i) = info(9,i) - info(8,i) + 1
+          startx(i)        = info(6,i) 
+          starty(i)        = info(8,i) 
+
+          local_rt_nx_size(i) = (info(7,i) - info(6,i) + 1)*AGGFACTRT+2
+          local_rt_ny_size(i) = (info(9,i) - info(8,i) + 1 )*AGGFACTRT+2
+          if(info(2,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1
+          if(info(3,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1
+          if(info(4,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1
+          if(info(5,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1
+       enddo
+      return 
+      end   subroutine wrf_LAND_set_INIT
+
+      subroutine getMy_global_id()
+          integer ierr
+          call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) 
+      return
+      end subroutine getMy_global_id
+
+  subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag)
+  ! communicate the data for channel routine.
+      implicit none
+      integer ix,jy,size
+      integer Link_location(ix,jy)
+      integer i,j, flag
+      real Link_V(size), tmp_inout(ix,jy)
+
+       if(size .eq. 0) return
+
+!     map the Link_V data to tmp_inout(ix,jy)
+      do i = 1,ix 
+            if(Link_location(i,1) .gt. 0) &
+               tmp_inout(i,1) = Link_V(Link_location(i,1))
+            if(Link_location(i,2) .gt. 0) &
+               tmp_inout(i,2) = Link_V(Link_location(i,2))
+            if(Link_location(i,jy-1) .gt. 0) &
+               tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1))
+            if(Link_location(i,jy) .gt. 0) &
+               tmp_inout(i,jy) = Link_V(Link_location(i,jy))
+        enddo
+      do j = 1,jy 
+            if(Link_location(1,j) .gt. 0) &
+               tmp_inout(1,j) = Link_V(Link_location(1,j))
+            if(Link_location(2,j) .gt. 0) &
+               tmp_inout(2,j) = Link_V(Link_location(2,j))
+            if(Link_location(ix-1,j) .gt. 0) &
+               tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j))
+            if(Link_location(ix,j) .gt. 0) &
+               tmp_inout(ix,j) = Link_V(Link_location(ix,j))
+      enddo
+
+!   commu nicate tmp_inout
+    call MPP_LAND_COM_REAL(tmp_inout, ix,jy,flag)
+
+!map the data back to Link_V
+      do j = 1,jy 
+            if(Link_location(1,j) .gt. 0) &
+               Link_V(Link_location(1,j)) = tmp_inout(1,j)
+            if(Link_location(2,j) .gt. 0) &
+               Link_V(Link_location(2,j)) = tmp_inout(2,j)
+            if(Link_location(ix-1,j) .gt. 0) &
+               Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j)
+            if(Link_location(ix,j) .gt. 0) &
+               Link_V(Link_location(ix,j)) = tmp_inout(ix,j)
+      enddo
+      do i = 1,ix 
+            if(Link_location(i,1) .gt. 0) &
+               Link_V(Link_location(i,1)) = tmp_inout(i,1)
+            if(Link_location(i,2) .gt. 0) &
+               Link_V(Link_location(i,2)) = tmp_inout(i,2)
+            if(Link_location(i,jy-1) .gt. 0) &
+               Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1)
+            if(Link_location(i,jy) .gt. 0) &
+               Link_V(Link_location(i,jy)) = tmp_inout(i,jy)
+      enddo
+  end subroutine MPP_CHANNEL_COM_REAL
+
+     subroutine print_2(unit,in,fm)
+        integer unit
+        character(len=*) fm
+        real  buf2(global_nx,global_ny),&
+           in(local_nx,local_ny)
+        call write_IO_real(in,buf2)
+        if(my_id.eq.IO_id) write(unit,*) buf2
+     return
+     end subroutine print_2
+
+     subroutine print_rt_2(unit,in)
+        integer unit
+        real  buf2(global_nx,global_ny),&
+           in(local_nx,local_ny)
+        call write_IO_real(in,buf2)
+        if(my_id.eq.IO_id) write(unit,*) buf2
+     return
+     end subroutine print_rt_2
+
+     subroutine mpp_land_max_int1(v)
+        implicit none
+        integer v, r1, max
+        integer i, ierr, tag
+        if(my_id .eq. IO_id) then
+           max = v
+           do i = 0, numprocs - 1
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 101
+                 call mpi_recv(r1,1,MPI_INTEGER,i, &
+                      tag,MPI_COMM_WORLD,mpp_status,ierr)
+                 if(max <= r1) max = r1 
+              end if
+           end do
+       else
+           tag =  101
+           call mpi_send(v,1,MPI_INTEGER, IO_id,     &
+               tag,MPI_COMM_WORLD,ierr)
+       end if
+       call mpp_land_bcast_int1(max)
+       v = max
+       return
+     end subroutine mpp_land_max_int1
+     
+     subroutine mpp_land_max_real1(v)
+        implicit none
+        real v, r1, max
+        integer i, ierr, tag
+        if(my_id .eq. IO_id) then
+           max = v
+           do i = 0, numprocs - 1
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 101
+                 call mpi_recv(r1,1,MPI_REAL,i, &
+                      tag,MPI_COMM_WORLD,mpp_status,ierr)
+                 if(max <= r1) max = r1 
+              end if
+           end do
+       else
+           tag =  101
+           call mpi_send(v,1,MPI_REAL, IO_id,     &
+               tag,MPI_COMM_WORLD,ierr)
+       end if
+       call mpp_land_bcast_real1(max)
+       v = max
+       return
+     end subroutine mpp_land_max_real1
+
+     subroutine mpp_same_int1(v)   
+        implicit none
+        integer v,r1
+        integer i, ierr, tag
+        if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 109
+                 call mpi_recv(r1,1,MPI_INTEGER,i, &
+                      tag,MPI_COMM_WORLD,mpp_status,ierr)
+                 if(v .ne. r1) v = -99  
+              end if
+           end do
+       else
+           tag =  109
+           call mpi_send(v,1,MPI_INTEGER, IO_id,     &
+               tag,MPI_COMM_WORLD,ierr)
+       end if
+       call mpp_land_bcast_int1(v)
+     end subroutine mpp_same_int1
+
+     subroutine write_chanel_real8(v,nodelist_in,mpp_nlinks,nlinks)   
+        implicit none
+        real*8 recv(nlinks), v(nlinks)
+        integer nodelist(nlinks), mpp_nlinks,nlinks, nodelist_in(nlinks)
+        integer i, ierr, tag, k
+        integer length, node
+
+        nodelist = nodelist_in
+        if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 109
+                 call mpi_recv(nodelist,nlinks,MPI_INTEGER,i, &
+                      tag,MPI_COMM_WORLD,mpp_status,ierr)
+                   tag = 119
+                 call mpi_recv(recv(:),nlinks,MPI_DOUBLE_PRECISION,i,  &
+                   tag,MPI_COMM_WORLD,mpp_status,ierr)
+
+                 do k = 1,nodelist(nlinks)
+                    if(nodelist(k) .gt. -99) then
+                      node = nodelist(k) 
+                      v(node) = recv(node)
+                    endif
+                 enddo
+              end if
+            
+           end do
+        else
+           tag =  109
+           nodelist(nlinks) = mpp_nlinks 
+           call mpi_send(nodelist,nlinks,MPI_INTEGER, IO_id,     &
+               tag,MPI_COMM_WORLD,ierr)
+           tag = 119
+           call mpi_send(v,nlinks,MPI_DOUBLE_PRECISION,IO_id,   &
+               tag,MPI_COMM_WORLD,ierr)
+        end if
+     end subroutine write_chanel_real8
+
+
+     subroutine write_chanel_real(v,nodelist_in,mpp_nlinks,nlinks)   
+        implicit none
+        real recv(nlinks), v(nlinks)
+        integer nodelist(nlinks), mpp_nlinks,nlinks, nodelist_in(nlinks)
+        integer i, ierr, tag, k
+        integer length, node
+
+        nodelist = nodelist_in
+        if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 109
+                 call mpi_recv(nodelist,nlinks,MPI_INTEGER,i, &
+                      tag,MPI_COMM_WORLD,mpp_status,ierr)
+                   tag = 119
+                 call mpi_recv(recv(:),nlinks,MPI_REAL,i,  &
+                   tag,MPI_COMM_WORLD,mpp_status,ierr)
+
+                 do k = 1,nodelist(nlinks)
+                    if(nodelist(k) .gt. -99) then
+                      node = nodelist(k) 
+                      v(node) = recv(node)
+                    endif
+                 enddo
+              end if
+            
+           end do
+        else
+           tag =  109
+           nodelist(nlinks) = mpp_nlinks 
+           call mpi_send(nodelist,nlinks,MPI_INTEGER, IO_id,     &
+               tag,MPI_COMM_WORLD,ierr)
+           tag = 119
+           call mpi_send(v,nlinks,MPI_REAL,IO_id,   &
+               tag,MPI_COMM_WORLD,ierr)
+        end if
+     end subroutine write_chanel_real
+
+     subroutine write_chanel_int(v,nodelist_in,mpp_nlinks,nlinks)   
+        implicit none
+        integer :: recv(nlinks), v(nlinks)
+        integer nodelist(nlinks), mpp_nlinks,nlinks, nodelist_in(nlinks)
+        integer i, ierr, tag, k
+        integer length, node
+
+        nodelist = nodelist_in
+        if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 109
+                 call mpi_recv(nodelist,nlinks,MPI_INTEGER,i, &
+                      tag,MPI_COMM_WORLD,mpp_status,ierr)
+                   tag = 119
+                 call mpi_recv(recv(:),nlinks,MPI_INTEGER,i,  &
+                   tag,MPI_COMM_WORLD,mpp_status,ierr)
+
+                 do k = 1,nodelist(nlinks)
+                    if(nodelist(k) .gt. -99) then
+                      node = nodelist(k) 
+                      v(node) = recv(node)
+                    endif
+                 enddo
+              end if
+            
+           end do
+        else
+           tag =  109
+           nodelist(nlinks) = mpp_nlinks 
+           call mpi_send(nodelist,nlinks,MPI_INTEGER, IO_id,     &
+               tag,MPI_COMM_WORLD,ierr)
+           tag = 119
+           call mpi_send(v,nlinks,MPI_INTEGER,IO_id,   &
+               tag,MPI_COMM_WORLD,ierr)
+        end if
+     end subroutine write_chanel_int
+
+
+     subroutine write_lake_real(v,nodelist_in,nlakes)   
+        implicit none
+        real recv(nlakes), v(nlakes)
+        integer nodelist(nlakes), nlakes, nodelist_in(nlakes)
+        integer i, ierr, tag, k
+        integer length, node
+
+        nodelist = nodelist_in
+        if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 129
+                 call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, &
+                      tag,MPI_COMM_WORLD,mpp_status,ierr)
+                   tag = 139
+                 call mpi_recv(recv(:),nlakes,MPI_REAL,i,  &
+                   tag,MPI_COMM_WORLD,mpp_status,ierr)
+
+                 do k = 1,nlakes
+                    if(nodelist(k) .gt. -99) then
+                       node = nodelist(k) 
+                       v(node) = recv(node)
+                    endif
+                 enddo
+              end if
+            
+           end do
+        else
+           tag =  129
+           call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id,     &
+               tag,MPI_COMM_WORLD,ierr)
+           tag = 139
+           call mpi_send(v,nlakes,MPI_REAL,IO_id,   &
+               tag,MPI_COMM_WORLD,ierr)
+        end if
+     end subroutine write_lake_real
+
+     subroutine read_rst_crt_r(unit,out,size)
+         implicit none
+        integer unit, size, ierr,ierr2
+        real  out(size),out1(size)
+        if(my_id.eq.IO_id) then
+          read(unit,IOSTAT=ierr2,end=99) out1
+          if(ierr2.eq.0) out=out1
+        endif
+99      continue
+        call mpp_land_bcast_int1(ierr2)
+        if(ierr2 .ne. 0) return
+        call mpi_bcast(out,size,MPI_REAL,   &
+            IO_id,MPI_COMM_WORLD,ierr)
+     return
+     end subroutine read_rst_crt_r  
+
+         subroutine write_rst_crt_r(unit,cd,nlinks_index,mpp_nlinks,nlinks)
+         integer :: unit,mpp_nlinks,nlinks,nlinks_index(nlinks)
+         real cd(nlinks)
+         call write_chanel_real(cd,nlinks_index,mpp_nlinks,nlinks)
+         write(unit) cd
+         return
+         end subroutine write_rst_crt_r
+
+    subroutine sum_real8(vin,nsize)
+       implicit none
+       integer nsize,i,j,tag,ierr
+       real*8, dimension(nsize):: vin,recv
+       real, dimension(nsize):: v 
+       tag = 319
+       if(my_id .eq. IO_id) then
+          do i = 0, numprocs - 1
+             if(i .ne. my_id) then
+               call mpi_recv(recv,nsize,MPI_DOUBLE_PRECISION,i,  &
+                    tag,MPI_COMM_WORLD,mpp_status,ierr)
+               vin(:) = vin(:) + recv(:)
+             endif
+          end do
+          v = vin
+       else
+             call mpi_send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id,   &
+                  tag,MPI_COMM_WORLD,ierr)
+       endif
+       call mpp_land_bcast_real(nsize,v) 
+       vin = v
+       return
+    end subroutine sum_real8
+
+!  subroutine get_globalDim(ix,g_ix)
+!     implicit none
+!     integer ix,g_ix, ierr
+!     include "mpif.h"
+!
+!     if ( my_id .eq. IO_id ) then
+!           g_ix = ix
+!        call mpi_reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, &
+!             MPI_SUM, 0, MPI_COMM_WORLD, ierr )
+!     else
+!        call mpi_reduce( ix,       0,      4, MPI_INTEGER, &
+!             MPI_SUM,  0, MPI_COMM_WORLD, ierr )
+!     endif
+!      call mpp_land_bcast_int1(g_ix)
+!
+!     return
+!
+!  end subroutine get_globalDim
+
+  subroutine gather_1d_real_tmp(vl,s_in,e_in,vg,sg)
+    integer sg, s,e, size, s_in, e_in
+    integer index_s(2)
+    integer tag, ierr,i
+!   s: start index, e: end index
+    real  vl(e_in-s_in+1), vg(sg)
+    s = s_in
+    e = e_in
+
+    if(my_id .eq. IO_id) then 
+        vg(s:e) = vl
+    end if
+
+     index_s(1) = s
+     index_s(2) = e
+     size = e - s + 1 
+
+    if(my_id .eq. IO_id) then
+         do i = 0, numprocs - 1 
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 202
+                 call mpi_recv(index_s,2,MPI_INTEGER,i, & 
+                      tag,MPI_COMM_WORLD,mpp_status,ierr)
+
+                 tag = 203
+                 e = index_s(2)
+                 s = index_s(1)
+                 size = e - s + 1 
+                 call mpi_recv(vg(s:e),size,MPI_REAL,  &
+                    i,tag,MPI_COMM_WORLD,mpp_status,ierr)
+              endif
+         end do
+     else 
+           tag =  202
+           call mpi_send(index_s,2,MPI_INTEGER, IO_id,     &
+               tag,MPI_COMM_WORLD,ierr)
+
+           tag =  203  
+           call mpi_send(vl,size,MPI_REAL,IO_id,   &
+               tag,MPI_COMM_WORLD,ierr)
+     end if
+
+     return 
+  end  subroutine gather_1d_real_tmp
+
+  subroutine sum_double(inout)
+      implicit none
+      real*8:: inout, send
+      integer :: ierr
+      send = inout
+      !yw CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,ierr)
+      CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
+  end subroutine sum_double
+
+
+END MODULE MODULE_MPP_LAND
+
+        subroutine mpp_land_abort()
+            implicit none
+  include "mpif.h"
+            integer ierr
+            CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR)
+        end ! mpp_land_abort
+
+  subroutine mpp_land_sync()
+      implicit none
+      include "mpif.h"
+      integer ierr
+      call MPI_barrier( MPI_COMM_WORLD ,ierr)
+      if(ierr .ne. 0) call mpp_land_abort()
+      return
+  end ! mpp_land_sync
+
+
+
+
diff --git a/wrfv2_fire/hydro/Routing/Makefile b/wrfv2_fire/hydro/Routing/Makefile
new file mode 100644
index 00000000..516344db
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/Makefile
@@ -0,0 +1,54 @@
+# Makefile 
+#
+.SUFFIXES:
+.SUFFIXES: .o .F
+
+include ../macros
+
+OBJS = \
+	module_HYDRO_utils.o \
+	module_noah_chan_param_init_rt.o \
+	module_GW_baseflow.o \
+	module_HYDRO_io.o \
+ 	module_RT.o Noah_distr_routing.o \
+	module_channel_routing.o \
+	rtFunction.o module_lsm_forcing.o
+
+all:	$(OBJS)
+
+#module_RT.o: module_RT.F
+#	@echo ""
+#	$(CPP) $(CPPFLAGS) $(*).F > $(*).f
+#	$(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG)  $(*).f
+#	$(RMD) $(*).f
+#	@echo ""
+#	cp *.mod ../mod
+
+.F.o:
+	@echo ""
+	$(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f
+	$(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f
+	$(RMD) $(*).f
+	@echo ""
+	ar -r ../lib/libHYDRO.a $(@)
+	cp *.mod ../mod
+
+#
+# Dependencies:
+#
+module_GW_baseflow.o: ../Data_Rec/module_GW_baseflow_data.o 
+
+module_HYDRO_io.o:  module_HYDRO_utils.o ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o 
+
+module_HYDRO_utils.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o
+
+module_lsm_forcing.o: module_HYDRO_io.o 
+
+module_RT.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o ../Data_Rec/module_GW_baseflow_data.o \
+	module_GW_baseflow.o module_HYDRO_utils.o module_HYDRO_io.o\
+	module_noah_chan_param_init_rt.o ../Data_Rec/module_GW_baseflow_data.o 
+
+rtFunction.o: ../Data_Rec/module_RT_data.o ../Data_Rec/module_GW_baseflow_data.o ../Data_Rec/module_namelist.o module_channel_routing.o
+
+clean:
+	rm -f *.o *.mod *.stb *~ *.f
diff --git a/wrfv2_fire/hydro/Routing/Noah_distr_routing.F b/wrfv2_fire/hydro/Routing/Noah_distr_routing.F
new file mode 100644
index 00000000..1542ff07
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/Noah_distr_routing.F
@@ -0,0 +1,2778 @@
+!DJG ------------------------------------------------
+!DJG   SUBROUTINE RT_PARM
+!DJG ------------------------------------------------
+
+	SUBROUTINE RT_PARM(IX,JY,IXRT,JXRT,VEGTYP,RETDP,OVRGH,  &
+                      AGGFACTR)
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id,&
+               up_id,mpp_land_com_real,MPP_LAND_UB_COM, &
+               MPP_LAND_LR_COM,mpp_land_com_integer 
+#endif
+
+	IMPLICIT NONE
+
+!DJG -------- DECLARATIONS -----------------------
+ 
+	INTEGER, INTENT(IN) :: IX,JY,IXRT,JXRT,AGGFACTR
+
+	INTEGER, INTENT(IN), DIMENSION(IX,JY)	:: VEGTYP
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)	:: RETDP
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)	:: OVRGH
+
+
+!DJG Local Variables
+
+	INTEGER	:: I,J,IXXRT,JYYRT
+        INTEGER :: AGGFACYRT,AGGFACXRT
+
+
+!DJG Assign RETDP and OVRGH based on VEGTYP...
+
+	do J=1,JY
+          do I=1,IX
+
+             do AGGFACYRT=AGGFACTR-1,0,-1
+              do AGGFACXRT=AGGFACTR-1,0,-1
+
+               IXXRT=I*AGGFACTR-AGGFACXRT
+               JYYRT=J*AGGFACTR-AGGFACYRT
+#ifdef MPP_LAND
+       if(left_id.ge.0) IXXRT=IXXRT+1
+       if(down_id.ge.0) JYYRT=JYYRT+1
+#else
+!yw ????
+!       IXXRT=IXXRT+1
+!       JYYRT=JYYRT+1
+#endif
+
+
+!DJG Urban, rock, playa, snow/ice...
+	       IF (VEGTYP(I,J).EQ.1.OR.VEGTYP(I,J).EQ.26.OR.   &
+                      VEGTYP(I,J).EQ.26.OR.VEGTYP(I,J).EQ.24) THEN
+                 RETDP(IXXRT,JYYRT)=1.3
+                 OVRGH(IXXRT,JYYRT)=0.1
+!DJG Wetlands and water bodies...
+	       ELSE IF (VEGTYP(I,J).EQ.17.OR.VEGTYP(I,J).EQ.18.OR.  &
+                      VEGTYP(I,J).EQ.19.OR.VEGTYP(I,J).EQ.16) THEN
+                 RETDP(IXXRT,JYYRT)=10.0
+                 OVRGH(IXXRT,JYYRT)=0.2
+!DJG All other natural covers...
+               ELSE 
+                 RETDP(IXXRT,JYYRT)=5.0
+                 OVRGH(IXXRT,JYYRT)=0.2
+               END IF
+
+              end do
+             end do
+
+          end do
+        end do
+#ifdef MPP_LAND
+        call MPP_LAND_COM_REAL(RETDP,IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(OVRGH,IXRT,JXRT,99)
+#endif
+
+!DJG ----------------------------------------------------------------
+  END SUBROUTINE RT_PARM
+!DJG ----------------------------------------------------------------
+
+
+
+
+
+!DJG ------------------------------------------------
+!DJG   SUBROUTINE SUBSFC_RTNG
+!DJG ------------------------------------------------
+
+	SUBROUTINE SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT,    &
+          SOYRT,LATKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT,      &    
+          NSOIL,SMCRT,INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT,    &
+          SMCWLTRT,SO8RT,SO8RT_D, rt_option,SLDPTH,junk4,CWATAVAIL, &
+          SATLYRCHK)
+
+!       use module_mpp_land, only: write_restart_rt_3, write_restart_rt_2, &
+!            my_id
+#ifdef MPP_LAND
+        use module_mpp_land, only: MPP_LAND_COM_REAL
+#endif
+	IMPLICIT NONE
+
+!DJG -------- DECLARATIONS ------------------------
+
+	INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL
+
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: SOXRT,junk4
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: SOYRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: LATKSATRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: SOLDEPRT
+
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)   :: ZWATTABLRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)   :: CWATAVAIL
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: SATLYRCHK
+
+
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)   :: QSUBRT
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)   :: QSUBBDRYRT
+
+	REAL, INTENT(IN)                          :: dist(ixrt,jxrt,9)
+	REAL, INTENT(IN)                          :: DT
+	REAL, INTENT(IN), DIMENSION(NSOIL)        :: ZSOIL
+	REAL, INTENT(IN), DIMENSION(NSOIL) 	  :: SLDPTH
+	REAL, INTENT(INOUT)                       :: QSUBBDRYTRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: INFXSUBRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT
+
+	REAL, DIMENSION(IXRT,JXRT)	:: ywtmp
+!DJG Local Variables
+
+	INTEGER	:: I,J,KK
+!djg        INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK
+
+	REAL 	:: GRDAREA
+	REAL	:: SUBFLO
+	REAL	:: WATAVAIL
+
+        INTEGER :: SO8RT_D(IXRT,JXRT,3)
+        REAL :: SO8RT(IXRT,JXRT,8)
+        integer ::  rt_option, index
+
+        INTEGER :: DT_STEPS             !-- number of timestep in routing
+        REAL :: SUBDT                !-- subsurface routing timestep
+        INTEGER :: KRT                  !-- routing counter
+        REAL, DIMENSION(IXRT,JXRT,NSOIL) :: SMCTMP  !--temp store of SMC
+        REAL, DIMENSION(IXRT,JXRT) :: ZWATTABLRTTMP ! temp store of ZWAT
+        REAL, DIMENSION(IXRT,JXRT) :: INFXSUBRTTMP ! temp store of infilx
+!djg        REAL, DIMENSION(IXRT,JXRT) :: CWATAVAIL ! temp specif. of wat avial
+        
+        
+
+!DJG Debug Variables...
+        REAL :: qsubchk,qsubbdrytmp
+        REAL :: junk1,junk2,junk3,junk5,junk6,junk7
+        INTEGER, PARAMETER :: double=8
+        REAL (KIND=double) :: smctot1a,smctot2a
+	INTEGER :: kx,count
+
+        
+!DJG -----------------------------------------------------------------
+!DJG  SUBSURFACE ROUTING LOOP
+!DJG    - SUBSURFACE ROUTING RUN ON NOAH TIMESTEP
+!DJG    - SUBSURFACE ROUITNG ONLY PERFORMED ON SATURATED LAYERS
+!DJG -----------------------------------------------------------------
+
+        !yw GRDAREA=DXRT*DXRT
+        ! GRDAREA=dist(i,j,9)
+
+
+!DJG debug subsfc...
+         subflo = 0.0
+
+!DJG Set up mass balance checks...
+!         CWATAVAIL = 0.            !-- initialize subsurface watavail
+         SUBDT = DT                !-- initialize the routing timestep to DT
+
+
+!!!! Find saturated layer depth...
+! Loop through domain to determine sat. layers and assign wat tbl depth...
+!    and water available for subsfc routing (CWATAVAIL)...
+!
+!         CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, &
+!                             SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, &
+!                             CWATAVAIL,SLDPTH)
+         
+
+
+!DJG debug variable...
+
+
+!DJG Courant check temp variable setup...
+         ZWATTABLRTTMP = ZWATTABLRT !-- temporary storage of water table level
+
+
+
+
+!!!! Call subsurface routing subroutine...
+#ifdef HYDRO_D
+     print *, "calling subsurface routing subroutine...Opt. ",rt_option
+#endif
+
+
+     if(rt_option .eq. 1) then
+        CALL ROUTE_SUBSURFACE1(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT,  &   
+               LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT, &   
+               SO8RT,SO8RT_D,CWATAVAIL,SUBDT)
+     else 
+        CALL ROUTE_SUBSURFACE2(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT,      &
+               LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT,     &
+               CWATAVAIL,SUBDT)
+     end if
+
+#ifdef HYDRO_D
+     write(6,*) "finish calling ROUTE_SUBSURFACE ", rt_option
+#endif
+
+
+!!!! Update soil moisture fields with subsurface flow...
+
+!!!! Loop through subsurface routing domain...
+	DO I=1,IXRT
+          DO J=1,JXRT
+
+!!DJG Check for courant condition violation...put limit on qsub
+!!DJG QSUB HAS units of m^3/s SUBFLO has units of m
+          
+
+           IF (CWATAVAIL(i,j).le.ABS(qsubrt(i,j))/dist(i,j,9)*SUBDT) THEN
+             QSUBRT(i,j) = -1.0*CWATAVAIL(i,j)
+             SUBFLO = QSUBRT(i,j)  !Units of qsubrt converted via CWATAVAIL
+           ELSE
+             SUBFLO=QSUBRT(I,J)/dist(i,j,9)*SUBDT !Convert qsubrt from m^3/s to m
+           END IF
+
+           WATAVAIL=0.  !Initialize to 0. for every cell...
+
+
+!!DJG Begin loop through soil profile to adjust soil water content
+!!DJG based on subsfc flow (SUBFLO)...
+
+            IF (SUBFLO.GT.0) THEN ! Increase soil moist for +SUBFLO (Inflow)
+
+! Loop through soil layers from bottom to top
+              DO KK=NSOIL,1,-1
+
+
+! Check for saturated layers
+                IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK)) THEN
+                  IF (SMCRT(I,J,KK).GT.SMCMAXRT(I,J,KK)) THEN
+#ifdef HYDRO_D
+                   print *, "Subsfc acct. SMCMAX exceeded...", &
+                       SMCRT(I,J,KK), SMCMAXRT(I,J,KK),KK,i,j
+                   call hydro_stop()
+#endif
+                  ELSE
+                  END IF
+                ELSE
+                  WATAVAIL = (SMCMAXRT(I,J,KK)-SMCRT(I,J,KK))*SLDPTH(KK)
+                  IF (WATAVAIL.GE.SUBFLO) THEN
+                    SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK)
+                    SUBFLO = 0.
+                  ELSE
+                    SUBFLO = SUBFLO - WATAVAIL
+                    SMCRT(I,J,KK) = SMCMAXRT(I,J,KK)
+                  END IF
+                END IF
+
+                 IF (SUBFLO.EQ.0.) EXIT
+!                IF (SUBFLO.EQ.0.) goto 669
+
+              END DO      ! END DO FOR SOIL LAYERS
+
+669           continue
+
+! If all layers sat. add remaining subflo to infilt. excess...                  
+              IF (KK.eq.0.AND.SUBFLO.gt.0.) then
+                 INFXSUBRT(I,J) = INFXSUBRT(I,J) + SUBFLO/1000.    !Units = mm
+                 SUBFLO=0.
+              END IF
+
+!DJG Error trap...
+	       if (subflo.ne.0.) then
+#ifdef HYDRO_D
+                  print *, "Subflo (+) not expired...:",subflo,i,j,kk,SMCRT(i,j,1), &
+                           SMCRT(i,j,2),SMCRT(i,j,3),SMCRT(i,j,4),SMCRT(i,j,5),  &
+                           SMCRT(i,j,6),SMCRT(i,j,7),SMCRT(i,j,8),"SMCMAX",SMCMAXRT(i,j,1)
+#endif
+               end if
+
+ 
+            ELSE IF (SUBFLO.LT.0) THEN    ! Decrease soil moist for -SUBFLO (Drainage)
+
+
+!DJG loop from satlyr back down and subtract out subflo as necess...
+!    now set to SMCREF, 8/24/07
+!DJG and then using unsat cond as opposed to Ksat...
+
+	      DO KK=SATLYRCHK(I,J),NSOIL
+                 WATAVAIL = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK)
+                 IF (WATAVAIL.GE.ABS(SUBFLO)) THEN
+                   SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK)
+                   SUBFLO=0.
+                 ELSE     ! Since subflo is small on a time-step following is unlikely...
+                   SMCRT(I,J,KK)=SMCREFRT(I,J,KK)
+                   SUBFLO=SUBFLO+WATAVAIL
+                 END IF
+                 IF (SUBFLO.EQ.0.) EXIT
+!                IF (SUBFLO.EQ.0.) goto 668
+
+              END DO  ! END DO FOR SOIL LAYERS
+668        continue
+
+
+!DJG Error trap...
+              if(abs(subflo) .le. 1.E-7 )  subflo = 0.0  !truncate residual to 1E-7 prec.
+
+	       if (subflo.ne.0.) then
+#ifdef HYDRO_D
+                  print *, "Subflo (-) not expired:",i,j,subflo,CWATAVAIL(i,j)
+                  print *, "zwatabl = ", ZWATTABLRT(I,J)
+                  print *, "QSUBRT(I,J)=",QSUBRT(I,J)
+                  print *, "WATAVAIL = ",WATAVAIL, "kk=",kk
+                  print *
+#endif
+               end if
+
+
+
+            END IF  ! end if for +/- SUBFLO soil moisture accounting...
+
+
+
+
+          END DO        ! END DO X dim
+        END DO          ! END DO Y dim
+!!!! End loop through subsurface routing domain...
+
+#ifdef MPP_LAND
+     do i = 1, NSOIL
+        call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99)
+     end DO
+#endif
+
+
+
+!DJG ----------------------------------------------------------------
+  END SUBROUTINE SUBSFC_RTNG 
+!DJG ----------------------------------------------------------------
+
+
+!DJG ------------------------------------------------------------------------
+!DJG  SUBSURFACE FINDZWAT
+!DJG ------------------------------------------------------------------------
+         SUBROUTINE FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, &
+                             SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT,CWATAVAIL,&
+                             SLDPTH)
+
+	IMPLICIT NONE
+
+!DJG -------- DECLARATIONS ------------------------
+
+	INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT
+	REAL, INTENT(IN), DIMENSION(NSOIL)        :: ZSOIL
+	REAL, INTENT(IN), DIMENSION(NSOIL)        :: SLDPTH
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)   :: ZWATTABLRT
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)   :: CWATAVAIL
+        INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SATLYRCHK
+       
+!DJG Local Variables
+        INTEGER :: KK,i,j
+
+
+!!!! Find saturated layer depth...
+! Loop through domain to determine sat. layers and assign wat tbl depth...
+
+
+        SATLYRCHK = 0  !set flag for sat. layers
+        CWATAVAIL = 0.  !set wat avail for subsfc rtng = 0.
+
+        DO J=1,JXRT
+          DO I=1,IXRT
+
+! Loop through soil layers from bottom to top
+              DO KK=NSOIL,1,-1
+
+! Check for saturated layers
+! Add additional logical check to ensure water is 'available' for routing,
+!  (i.e. not 'frozen' or otherwise immobile)
+!                IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK).AND.SMCMAXRT(I,J,KK) &
+!                  .GT.SMCWLTRT(I,J,KK)) THEN
+                IF (SMCRT(I,J,KK).GE.SMCREFRT(I,J,KK).AND.SMCREFRT(I,J,KK) &
+                  .GT.SMCWLTRT(I,J,KK)) THEN
+! Add additional check to ensure saturation from bottom up only...8/8/05
+                  IF(SATLYRCHK(I,J).EQ.KK+1.OR.KK.EQ.NSOIL) SATLYRCHK(I,J) = KK
+                END IF
+
+              END DO
+
+
+! Designate ZWATTABLRT based on highest sat. layer and
+! Define amount of water avail for subsfc routing on each gridcell (CWATAVAIL)
+!  note: using a 'field capacity' value of SMCREF as lower limit...
+
+              IF (SATLYRCHK(I,J).ne.0) then
+                IF (SATLYRCHK(I,J).ne.1) then  ! soil column is partially sat.
+                  ZWATTABLRT(I,J) = -ZSOIL(SATLYRCHK(I,J)-1)
+                  DO KK=SATLYRCHK(I,J),NSOIL
+!old                   CWATAVAIL(I,J) = (SMCRT(I,J,SATLYRCHK(I,J))-&
+!old                                    SMCREFRT(I,J,SATLYRCHK(I,J))) * &
+!old                                    (ZSOIL(SATLYRCHK(I,J)-1)-ZSOIL(NSOIL))
+                    CWATAVAIL(I,J) = CWATAVAIL(I,J)+(SMCRT(I,J,KK)- &
+                                     SMCREFRT(I,J,KK))*SLDPTH(KK)
+                  END DO
+
+
+                ELSE  ! soil column is fully saturated to sfc.
+                  ZWATTABLRT(I,J) = 0.
+                  DO KK=SATLYRCHK(I,J),NSOIL
+                    CWATAVAIL(I,J) = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK)
+                  END DO
+                END IF
+              ELSE  ! no saturated layers...
+                ZWATTABLRT(I,J) = -ZSOIL(NSOIL)
+                SATLYRCHK(I,J) = NSOIL + 1
+              END IF
+
+
+	   END DO
+         END DO
+
+
+!DJG ----------------------------------------------------------------
+  END SUBROUTINE FINDZWAT 
+!DJG ----------------------------------------------------------------
+
+
+!DJG ----------------------------------------------------------------
+!DJG ----------------------------------------------------------------
+!DJG     SUBROUTINE ROUTE_SUBSURFACE2
+!DJG ----------------------------------------------------------------
+
+          SUBROUTINE ROUTE_SUBSURFACE2(                                 &
+                dist,z,qsub,sox,soy,                                   &
+                latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,CWATAVAIL,   &
+                SUBDT)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!  Subroutine to route subsurface flow through the watershed
+!DJG ----------------------------------------------------------------
+!
+!  Called from: main.f (Noah_router_driver)
+!
+!  Returns: qsub=DQSUB   which in turn becomes SUBFLO in head calc.
+!
+!  Created:    D. Gochis                           3/27/03
+!              Adaptded from Wigmosta, 1994
+!
+!  Modified:   D. Gochis                           1/05/04
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id,&
+               up_id,mpp_land_com_real,MPP_LAND_UB_COM, &
+               MPP_LAND_LR_COM,mpp_land_com_integer
+#endif
+
+        IMPLICIT NONE
+
+
+!! Declare Passed variables
+
+        INTEGER, INTENT(IN) :: XX,YY
+
+!! Declare passed arrays
+
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: z
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: sox
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soy
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep
+        REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY
+        REAL, INTENT(INOUT) :: QSUBDRYT
+        REAL, INTENT(IN) :: SUBDT
+        real, intent(in), dimension(xx,yy,9) :: dist 
+
+!!! Declare Local Variables
+
+        REAL :: dzdx,dzdy,beta,gamma
+        REAL :: qqsub,hh,ksat, gsize
+
+        INTEGER :: i,j
+!!! Initialize variables
+        REAL, PARAMETER :: nexp=1.0      ! local power law exponent
+
+!yw        soldep = 2.
+        
+
+! Begin Subsurface routing
+
+!!! Loop to route water in x-direction
+        do j=1,YY
+          do i=1,XX
+! check for boundary grid point?
+          if (i.eq.XX) GOTO 998
+          gsize = dist(i,j,3)
+
+          dzdx= (z(i,j) - z(i+1,j))/gsize
+          beta=sox(i,j) + dzdx + 1E-30
+          if (abs(beta) .lt. 1E-20) beta=1E-20
+          if (beta.lt.0) then
+!yw            hh=(1-(z(i+1,j)/soldep(i,j)))**nexp
+            hh=(1-(z(i+1,j)/soldep(i+1,j)))**nexp
+! Change later to use mean Ksat of two cells
+            ksat=latksat(i+1,j)
+          else
+            hh=(1-(z(i,j)/soldep(i,j)))**nexp
+            ksat=latksat(i,j)
+          end if
+
+          if (hh .lt. 0.) then
+#ifdef HYDRO_D
+            print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), &
+                      soldep(i,j),nexp
+            call hydro_stop()
+#endif
+          end if
+
+!Err. tan slope          gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta)
+          gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta
+
+          qqsub = gamma * hh
+          qsub(i,j) = qsub(i,j) + qqsub
+          qsub(i+1,j) = qsub(i+1,j) - qqsub
+
+! Boundary adjustments
+#ifdef MPP_LAND
+          if ((i.eq.1).AND.(beta.lt.0.).and.(left_id.lt.0)) then
+#else
+          if ((i.eq.1).AND.(beta.lt.0.)) then
+#endif
+            qsub(i,j) = qsub(i,j) - qqsub
+            QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub
+            QSUBDRYT = QSUBDRYT - qqsub
+#ifdef MPP_LAND
+          else if ((i.eq.(xx-1)).AND.(beta.gt.0.) &
+              .and.(right_id.lt.0) ) then
+#else
+          else if ((i.eq.(xx-1)).AND.(beta.gt.0.)) then
+#endif
+            qsub(i+1,j) = qsub(i+1,j) + qqsub
+            QSUBDRY(i+1,j) = QSUBDRY(i+1,j) + qqsub
+            QSUBDRYT = QSUBDRYT + qqsub
+          end if
+
+998       continue
+
+!! End loop to route sfc water in x-direction
+          end do
+        end do
+
+#ifdef MPP_LAND
+       call MPP_LAND_LR_COM(qsub,XX,YY,99)
+       call MPP_LAND_LR_COM(QSUBDRY,XX,YY,99)
+#endif
+
+
+!!! Loop to route water in y-direction
+        do j=1,YY
+          do i=1,XX
+! check for boundary grid point?
+          if (j.eq.YY) GOTO 999
+          gsize = dist(i,j,1)
+
+          dzdy= (z(i,j) - z(i,j+1))/gsize
+          beta=soy(i,j) + dzdy + 1E-30
+          if (abs(beta) .lt. 1E-20) beta=1E-20
+          if (beta.lt.0) then
+!yw            hh=(1-(z(i,j+1)/soldep(i,j)))**nexp
+            hh=(1-(z(i,j+1)/soldep(i,j+1)))**nexp
+            ksat=latksat(i,j+1)
+          else
+            hh=(1-(z(i,j)/soldep(i,j)))**nexp
+            ksat=latksat(i,j)
+          end if
+
+          if (hh .lt. 0.) GOTO 999
+
+!Err. tan slope          gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta)
+          gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta
+
+          qqsub = gamma * hh
+          qsub(i,j) = qsub(i,j) + qqsub
+          qsub(i,j+1) = qsub(i,j+1) - qqsub
+
+! Boundary adjustments
+
+#ifdef MPP_LAND
+          if ((j.eq.1).AND.(beta.lt.0.).and.(down_id.lt.0)) then
+#else
+          if ((j.eq.1).AND.(beta.lt.0.)) then
+#endif
+            qsub(i,j) = qsub(i,j) - qqsub
+            QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub
+            QSUBDRYT = QSUBDRYT - qqsub
+#ifdef MPP_LAND
+          else if ((j.eq.(yy-1)).AND.(beta.gt.0.)  &
+                .and. (up_id.lt.0) ) then
+#else
+          else if ((j.eq.(yy-1)).AND.(beta.gt.0.)) then
+#endif
+            qsub(i,j+1) = qsub(i,j+1) + qqsub
+            QSUBDRY(i,j+1) = QSUBDRY(i,j+1) + qqsub
+            QSUBDRYT = QSUBDRYT + qqsub
+          end if
+
+999       continue
+
+!! End loop to route sfc water in y-direction
+          end do
+        end do
+
+#ifdef MPP_LAND
+       call MPP_LAND_UB_COM(qsub,XX,YY,99)
+       call MPP_LAND_UB_COM(QSUBDRY,XX,YY,99)
+#endif
+
+        return
+!DJG------------------------------------------------------------
+        end subroutine ROUTE_SUBSURFACE2
+!DJG------------------------------------------------------------
+
+
+
+!DJG ------------------------------------------------
+!DJG   SUBROUTINE OV_RTNG
+!DJG ------------------------------------------------
+
+	SUBROUTINE OV_RTNG(DT,DTRT,IXRT,JXRT,INFXSUBRT,      &
+          SFCHEADSUBRT,DHRT,CH_NETRT,RETDEPRT,OVROUGHRT,      &
+          QSTRMVOLRT,QBDRYRT,QSTRMVOLTRT,QBDRYTRT,SOXRT,     &
+          SOYRT,dist,LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT,  &
+          SO8RT,SO8RT_D,rt_option,q_sfcflx_x,q_sfcflx_y)
+
+!yyww 
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id, &
+              up_id,mpp_land_com_real, my_id, &
+             mpp_land_sync
+#endif
+
+	IMPLICIT NONE
+
+!DJG --------DECLARATIONS----------------------------
+
+	INTEGER, INTENT(IN)			:: IXRT,JXRT
+	REAL, INTENT(IN)			:: DT,DTRT
+
+	INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT
+	INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)	:: INFXSUBRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)	:: SOXRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)	:: SOYRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist 
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)	:: RETDEPRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)	:: OVROUGHRT
+
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)	:: SFCHEADSUBRT
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)	:: DHRT
+
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_INFLORT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QBDRYRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: q_sfcflx_x,q_sfcflx_y
+	REAL, INTENT(INOUT)     :: QSTRMVOLTRT,QBDRYTRT,LAKE_INFLOTRT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8)  :: SO8RT
+
+!DJG Local Variables
+
+	INTEGER :: KRT,I,J,ct
+
+	REAL, DIMENSION(IXRT,JXRT)	:: INFXS_FRAC
+	REAL	:: DT_FRAC,SUM_INFXS,sum_head
+        INTEGER SO8RT_D(IXRT,JXRT,3), rt_option
+	
+	
+
+
+!DJG ----------------------------------------------------------------------
+! DJG BEGIN 1-D or 2-D OVERLAND FLOW ROUTING LOOP
+!DJG ---------------------------------------------------------------------
+!DJG  Loop over 'routing time step'
+!DJG  Compute the number of time steps based on NOAH DT and routing DTRT
+
+       DT_FRAC=INT(DT/DTRT)
+
+#ifdef HYDRO_D
+       write(6,*) "OV_RTNG  DT_FRAC, DT, DTRT",DT_FRAC, DT, DTRT
+       write(6,*) "IXRT, JXRT = ",ixrt,jxrt
+#endif
+
+!DJG NOTE: Applying all infiltration excess water at once then routing
+!DJG       Pre-existing SFHEAD gets combined with Precip. in the
+!DJG       calculation of INFXS1 during subroutine SRT.f.
+!DJG debug
+
+
+!DJG Assign all infiltration excess to surface head...
+            SFCHEADSUBRT=INFXSUBRT
+
+!DJG Divide infiltration excess over all routing time-steps
+!	     INFXS_FRAC=INFXSUBRT/(DT/DTRT)
+
+!DJG Set flux accumulation fields to 0. before each loop...
+      q_sfcflx_x = 0.
+      q_sfcflx_y = 0.
+      ct =0
+
+
+!DJG Execute routing time-step loop...
+
+
+      DO KRT=1,DT_FRAC
+
+        DO J=1,JXRT
+          DO I=1,IXRT
+
+!DJG Removed 4_29_05, sfhead now updated in route_overland subroutine...
+!           SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J)
+!!           SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J)+INFXS_FRAC(I,J)
+!           DHRT(I,J)=0.
+
+!DJG ERROR Check...
+
+	   IF (SFCHEADSUBRT(I,J).lt.0.) THEN 
+#ifdef HYDRO_D
+		print *, "ywcheck 2 ERROR!!!: Neg. Surface Head Value at (i,j):",    &
+                    i,j,SFCHEADSUBRT(I,J)
+                print *, "RETDEPRT(I,J) = ",RETDEPRT(I,J), "KRT=",KRT
+                print *, "INFXSUBRT(i,j)=",INFXSUBRT(i,j)
+                print *, "jxrt=",jxrt," ixrt=",ixrt
+#endif
+           END IF
+
+!DJG Remove surface water from channel cells
+!DJG Channel inflo cells specified as nonzeros from CH_NET
+!DJG 9/16/04  Channel Extractions Removed until stream model implemented...
+
+
+
+           IF (CH_NETRT(I,J).ne.-9999) THEN
+             ct = ct +1
+
+!DJG Temporary test to up the retention depth of channel grid cells to 'soak' 
+!more water into valleys....set retdep = retdep*100 (=5 mm)
+
+!	     RETDEPRT(I,J) = RETDEPRT(I,J) * 100.0    !DJG TEMP HARDWIRE!!!!
+!	     RETDEPRT(I,J) = 10.0    !DJG TEMP HARDWIRE!!!!
+
+             IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN
+!!               QINFLO(CH_NET(I,J)=QINFLO(CH_NET(I,J)+SFCHEAD(I,J) - RETDEPRT(I,J)
+               QSTRMVOLTRT = QSTRMVOLTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J))
+               QSTRMVOLRT(I,J) = QSTRMVOLRT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J)
+               SFCHEADSUBRT(I,J) = RETDEPRT(I,J)
+             END IF
+           END IF
+
+!DJG Lake inflow withdrawl from surface head...(4/29/05)
+           
+
+           IF (LAKE_MSKRT(I,J).gt.0) THEN
+             IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN
+               LAKE_INFLOTRT = LAKE_INFLOTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J))
+               LAKE_INFLORT(I,J) = LAKE_INFLORT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J)
+               SFCHEADSUBRT(I,J) = RETDEPRT(I,J)
+              
+             END IF
+           END IF
+
+
+
+         END DO
+        END DO
+
+!DJG----------------------------------------------------------------------
+!DJG CALL OVERLAND FLOW ROUTING SUBROUTINE
+!DJG----------------------------------------------------------------------
+
+!DJG Debug...
+
+
+           if(rt_option .eq. 1) then
+              CALL ROUTE_OVERLAND1(DTRT,dist,SFCHEADSUBRT,DHRT,SOXRT,   &
+		SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT,    & 
+                SO8RT,SO8RT_D,q_sfcflx_x,q_sfcflx_y)
+            else
+              CALL ROUTE_OVERLAND2(DTRT,dist,SFCHEADSUBRT,DHRT,SOXRT,   &
+                  SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT,  &
+                  q_sfcflx_x,q_sfcflx_y)    
+            end if
+             
+        END DO          ! END routing time steps
+
+#ifdef HYDRO_D
+ 	print *, "End of OV_routing call..."
+#endif
+
+!----------------------------------------------------------------------
+! END OVERLAND FLOW ROUTING LOOP
+!     CHANNEL ROUTING TO FOLLOW 
+!----------------------------------------------------------------------
+
+!DJG ----------------------------------------------------------------
+  END SUBROUTINE OV_RTNG 
+!DJG ----------------------------------------------------------------
+
+!DJG     SUBROUTINE ROUTE_OVERLAND1
+!DJG ----------------------------------------------------------------
+
+          SUBROUTINE ROUTE_OVERLAND1(dt,                                &
+     &          gsize,h,qsfc,sox,soy,                                   &
+     &     retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT,SO8RT,SO8RT_D,      &
+     &     q_sfcflx_x,q_sfcflx_y)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!  Subroutine to route excess rainfall over the watershed
+!     using a 2d diffusion routing scheme.
+!
+!  Called from: main.f
+!
+!      Will try to formulate this to be called from NOAH
+!
+!  Returns: qsfc=DQOV   which in turn becomes DH in head calc.
+!
+!  Created:  Adaptded from CASC2D source code
+!  NOTE: dh from original code has been replaced by qsfc
+!        dhh replaced by qqsfc
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id, &
+              up_id,mpp_land_com_real, my_id, mpp_land_com_real8,&
+             mpp_land_sync
+#endif
+
+        IMPLICIT NONE
+
+
+!! Declare Passed variables
+
+        INTEGER, INTENT(IN) :: XX,YY
+        REAL, INTENT(IN) :: dt, gsize(xx,yy,9)
+
+!! Declare passed arrays
+
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: qsfc
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: sox
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soy
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x, q_sfcflx_y
+        REAL, INTENT(INOUT) :: QBDRYT
+        REAL, INTENT(IN), DIMENSION(XX,YY,8) :: SO8RT
+        REAL*8, DIMENSION(XX,YY) :: QBDRY_tmp, DH
+        REAL*8, DIMENSION(XX,YY) :: DH_tmp
+
+!!! Declare Local Variables
+
+        REAL :: dhdx,dhdy,alfax,alfay
+        REAL :: hh53,qqsfc,hh,dt_new,hmax
+        REAL :: sfx,sfy
+        REAL :: tmp_adjust
+
+        INTEGER :: i,j
+        REAL IXX8,IYY8
+        INTEGER  IXX0,JYY0,index, SO8RT_D(XX,YY,3)
+        REAL  tmp_gsize,hsum
+
+!!! Initialize variables
+
+
+
+!!! Begin Routing of Excess Rainfall over the Watershed
+
+        DH=0.
+        DH_tmp=0.
+        QBDRY_tmp =0.
+
+!!! Loop to route water
+        do j=2,YY-1
+          do i=2,XX-1
+          if (h(I,J).GT.retent_dep(I,J)) then 
+             IXX0 = SO8RT_D(i,j,1)
+             JYY0 = SO8RT_D(i,j,2)
+             index = SO8RT_D(i,j,3)
+             tmp_gsize = 1.0/gsize(i,j,index)
+             sfx = so8RT(i,j,index)-(h(IXX0,JYY0)-h(i,j))*0.001*tmp_gsize
+             hmax = h(i,j)*0.001  !Specify max head for mass flux limit...
+             if(sfx .lt. 1E-20) then
+               call GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,so8rt,gsize(i,j,:),sfx,XX,YY)
+             end if
+             if(IXX0 > 0) then  ! do the rest if the lowest grid can be found.
+                 if(sfx .lt. 1E-20) then
+#ifdef HYDRO_D
+                      print*, "Message: sfx reset to 1E-20. sfx =",sfx
+                      print*, "i,j,index,IXX0,JYY0",i,j,index,IXX0,JYY0
+                      print*, "so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index) ", &
+                         so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index)
+#endif
+                      sfx = 1E-20
+                 end if
+                 alfax = sqrt(sfx) / dist_rough(i,j) 
+                 hh=(h(i,j)-retent_dep(i,j)) * 0.001
+                 hh53=hh**(5./3.)
+
+! Calculate q-flux...
+                 qqsfc = alfax*hh53*dt * tmp_gsize
+
+!Courant check (simple mass limit on overland flow)...
+                 if (qqsfc.ge.(hmax*dt*tmp_gsize)) qqsfc = hmax*dt*tmp_gsize
+
+! Accumulate directional fluxes on routing subgrid...
+                 if (IXX0.gt.i) then
+                   q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc * &
+                         (1.0 - 0.5 * (ABS(j-JYY0)))
+                 else if (IXX0.lt.i) then
+                   q_sfcflx_x(I,J) = q_sfcflx_x(I,J) - 1.0 * &
+                         qqsfc * (1.0 - 0.5 * (ABS(j-JYY0)))
+                 else
+                   q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + 0.
+                 end if
+                 if (JYY0.gt.j) then
+                   q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc * &
+                          (1.0 - 0.5 * (ABS(i-IXX0)))
+                 elseif (JYY0.lt.j) then
+                   q_sfcflx_y(I,J) = q_sfcflx_y(I,J) - 1.0 * &
+                          qqsfc * (1.0 - 0.5 * (ABS(i-IXX0)))
+                 else
+                   q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + 0.
+                 end if
+
+
+!DJG put adjustment in for (h) due to qqsfc
+
+!yw changed as following:
+                 tmp_adjust=qqsfc*1000
+                 if((h(i,j) - tmp_adjust) <0 )  then
+#ifdef HYDRO_D
+                   print*, "Error Warning: surface head is negative:  ",i,j,ixx0,jyy0, &
+                       h(i,j) - tmp_adjust
+#endif
+                     tmp_adjust = h(i,j)
+                 end if
+ 	         DH(i,j) = DH(i,j)-tmp_adjust
+                 DH_tmp(ixx0,jyy0) = DH_tmp(ixx0,jyy0) + tmp_adjust
+      !yw end change
+                  
+      !DG Boundary adjustments here
+            !DG Constant Flux Condition
+#ifdef MPP_LAND
+      if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. &
+          ((ixx0.eq.1) .and.(left_id  .lt. 0)) .or. &
+          ((jyy0.eq.1) .and.(down_id  .lt. 0)) .or. &
+          ((JYY0.eq.YY).and.(up_id    .lt. 0)) ) then 
+              QBDRY_tmp(IXX0,JYY0)=QBDRY_tmp(IXX0,JYY0) - qqsfc*1000.
+#else
+                if ((ixx0.eq.XX).or.(ixx0.eq.1).or.(jyy0.eq.1)   &
+                     .or.(JYY0.eq.YY )) then
+                     QBDRY(IXX0,JYY0)=QBDRY(IXX0,JYY0) - qqsfc*1000.
+#endif
+                     QBDRYT=QBDRYT - qqsfc
+                     DH_tmp(IXX0,JYY0)= DH_tmp(IXX0,JYY0)-tmp_adjust
+                end if
+             end if
+!! End loop to route sfc water 
+          end if
+          end do
+        end do
+
+#ifdef MPP_LAND
+! use double precision to solve the underflow problem.
+       call MPP_LAND_COM_REAL8(DH_tmp,XX,YY,1)
+       call MPP_LAND_COM_REAL8(QBDRY_tmp,XX,YY,1)
+#endif
+       QBDRY = QBDRY + QBDRY_tmp
+       DH = DH+DH_tmp 
+
+#ifdef MPP_LAND
+       call MPP_LAND_COM_REAL8(DH,XX,YY,99)
+       call MPP_LAND_COM_REAL(QBDRY,XX,YY,99)
+#endif
+
+        H = H + DH
+
+        return
+
+!DJG ----------------------------------------------------------------------
+        end subroutine ROUTE_OVERLAND1
+
+
+!DJG ----------------------------------------------------------------
+        SUBROUTINE GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,sox,tmp_gsize,max,XX,YY)
+          implicit none
+          INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY
+          INTEGER, INTENT(IN) :: I,J
+
+          REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY,8),tmp_gsize(9)
+          REAL  max
+          IXX0 = -1
+          max = 0
+          if (h(I,J).LE.retent_dep(I,J)) return
+
+          IXX8 = I
+          JYY8 = J+1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J+1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J-1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY)
+
+          IXX8 = I
+          JYY8 = J-1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J-1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J+1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY)
+        RETURN
+        END SUBROUTINE GETMAX8DIR
+
+        SUBROUTINE GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox   &
+            ,IXX0,JYY0,max,tmp_gsize,XX,YY)
+        implicit none
+        integer,INTENT(INOUT) ::IXX0,JYY0
+        INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY
+        REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY)
+        REAL, INTENT(INOUT) ::max
+        real, INTENT(IN) :: tmp_gsize
+        real :: sfx
+
+             sfx = sox(i,j)-(h(IXX8,JYY8)-h(i,j))*0.001/tmp_gsize
+             if(sfx .le. 0 ) return
+             if(max < sfx ) then
+                   IXX0 = IXX8
+                   JYY0 = JYY8
+                   max = sfx
+             end if
+
+        END SUBROUTINE GET8DIR
+!DJG ----------------------------------------------------------------
+!DJG     SUBROUTINE ROUTE_SUBSURFACE1
+!DJG ----------------------------------------------------------------
+
+          SUBROUTINE ROUTE_SUBSURFACE1(                                 &
+                dist,z,qsub,sox,soy,                                   &
+                latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,SO8RT,SO8RT_D,    &
+                CWATAVAIL,SUBDT)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!  Subroutine to route subsurface flow through the watershed
+!
+!  Called from: main.f (Noah_router_driver)
+!
+!  Returns: qsub=DQSUB   which in turn becomes SUBFLO in head calc.
+!
+!  Created:    D. Gochis                           3/27/03
+!              Adaptded from Wigmosta, 1994
+!
+!  Modified:   D. Gochis                           1/05/04
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id,&
+           up_id,mpp_land_com_real8,my_id,mpp_land_com_real
+#endif
+
+        IMPLICIT NONE
+
+
+!! Declare Passed variables
+
+        INTEGER, INTENT(IN) :: XX,YY
+
+!! Declare passed arrays
+
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: z
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: sox
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soy
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep
+        REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY
+        REAL, INTENT(INOUT) :: QSUBDRYT
+        REAL*8, DIMENSION(XX,YY) :: qsub_tmp,QSUBDRY_tmp
+!yw        INTEGER, INTENT(OUT) :: flag
+        REAL, INTENT(IN) :: dist(xx,yy,9),SUBDT
+
+!!! Declare Local Variables
+
+        REAL :: dzdx,dzdy,beta,gamma
+        REAL :: qqsub,hh,ksat
+
+        REAL :: SO8RT(XX,YY,8)
+        INTEGER :: SO8RT_D(XX,YY,3), rt_option
+        
+
+!!! Initialize variables
+
+        REAL, PARAMETER :: nexp=1.0      ! local power law exponent
+        integer IXX0,JYY0,index,i,j
+        real tmp_gsize
+
+!     temporary set it to be 2. Should be passed in.
+!yw        soldep = 2.
+! Begin Subsurface routing
+
+
+
+!!! Loop to route water in x-direction
+        qsub_tmp = 0.
+        QSUBDRY_tmp = 0.
+
+#ifdef HYDRO_D
+        write(6,*) "call subsurface routing xx= , yy =", yy, xx
+#endif
+
+        do j=2,YY-1
+          do i=2,XX-1
+
+
+        if(i.ge.2.AND.i.le.XX-1.AND.j.ge.2.AND.j.le.YY-1) then !if grdcl chk
+! check for boundary grid point?
+          IXX0 = SO8RT_D(i,j,1)
+          JYY0 = SO8RT_D(i,j,2)
+
+          index = SO8RT_D(i,j,3)
+
+            if(dist(i,j,index) .le. 0) then
+#ifdef HYDRO_D
+               write(6,*) "Error: dist(i,j,index) is <= zero "   
+               call hydro_stop()
+#endif
+            endif
+            if(soldep(i,j) .eq. 0) then
+#ifdef HYDRO_D
+               write(6,*) "Error: soldep          is = zero "   
+               call hydro_stop()
+#endif
+            endif
+
+          tmp_gsize = 1.0/dist(i,j,index)
+
+       
+          dzdx= (z(i,j) - z(IXX0,JYY0) )* tmp_gsize
+          beta=so8RT(i,j,index) + dzdx 
+
+          if(beta .lt. 1E-20 ) then   !if-then for direction...
+            call GETSUB8(IXX0,JYY0,I,J,Z,so8rt,dist(i,j,:),beta,XX,YY)
+          end if
+          if(beta .gt. 0) then            !if-then for flux calc 
+              if(beta .lt. 1E-20 ) then
+#ifdef HYDRO_D
+                   print*, "Message: beta need to be reset to 1E-20. beta = ",beta
+#endif
+                   beta = 1E-20
+              end if
+
+! do the rest if the lowest grid can be found.
+              hh=(1-(z(i,j)/soldep(i,j)))**nexp
+              ksat=latksat(i,j)
+
+              if (hh .lt. 0.) then
+#ifdef HYDRO_D
+                 print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), &
+                      soldep(i,j)
+                 call hydro_stop() 
+#endif
+              end if
+
+!err. tan slope     gamma=-1.0*((gsize*ksat*soldep(i,j))/nexp)*tan(beta)
+              gamma=-1.0*((dist(i,j,index)*ksat*soldep(i,j))/nexp)*beta
+              qqsub = gamma * hh
+
+              qsub(i,j) = qsub(i,j) + qqsub
+              qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) - qqsub
+
+!!DJG Error Checks...
+              if(qqsub .gt. 0) then
+#ifdef HYDRO_D
+                    print*, "Error: qqsub should be negative, qqsub =",qqsub,&
+                       "gamma=",gamma,"hh=",hh,"beta=",beta,"dzdx=",dzdx,&
+                       "so8RT=",so8RT(i,j,index),"latksat=",ksat, &
+                       "tan(beta)=",tan(beta),i,j,z(i,j),z(IXX0,JYY0)
+                    print*, "ixx0=",ixx0, "jyy0=",jyy0
+                    print*, "soldep =", soldep(i,j), "nexp=",nexp
+                 call hydro_stop() 
+#endif
+              end if
+
+
+
+
+! Boundary adjustments
+#ifdef MPP_LAND
+      if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. &
+          ((ixx0.eq.1) .and.(left_id  .lt. 0)) .or. &
+          ((jyy0.eq.1) .and.(down_id  .lt. 0)) .or. &
+          ((JYY0.eq.YY).and.(up_id    .lt. 0)) ) then 
+#else
+              if ((ixx0.eq.1).or.(ixx0.eq.xx).or.(jyy0.eq.1).or.(jyy0.eq.yy)) then
+#endif
+                qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) + qqsub
+                QSUBDRY_tmp(ixx0,jyy0) = QSUBDRY_tmp(ixx0,jyy0) + qqsub
+
+                QSUBDRYT = QSUBDRYT + qqsub
+              end if
+
+998           continue
+
+!! End loop to route sfc water in x-direction
+      end if  !endif for flux calc
+
+          endif   !! Endif for gridcell check...
+
+
+          end do  !endif for i-dim
+!CRNT debug          if(flag.eq.-99) exit !exit loop for courant violation...
+        end do   !endif for j-dim
+
+#ifdef MPP_LAND
+
+       call MPP_LAND_COM_REAL8(qsub_tmp,XX,YY,1)
+       call MPP_LAND_COM_REAL8(QSUBDRY_tmp,XX,YY,1)
+#endif
+       qsub = qsub + qsub_tmp
+       QSUBDRY= QSUBDRY + QSUBDRY_tmp 
+
+
+        do j=2,YY-1
+          do i=2,XX-1
+            if(dist(i,j,9) .le. 0) then
+#ifdef HYDRO_D
+               write(6,*) "Error: dist(i,j,9) is <= zero "   
+               call hydro_stop()
+#endif
+            endif
+            if(CWATAVAIL(i,j).lt.ABS(qsub(i,j))/dist(i,j,9)*SUBDT) THEN
+              qsub(i,j) = -1.0*CWATAVAIL(i,j)
+            end if
+          end do
+        end do
+#ifdef MPP_LAND
+       call MPP_LAND_COM_REAL(qsub,XX,YY,99)
+       call MPP_LAND_COM_REAL(QSUBDRY,XX,YY,99)
+#endif
+
+
+        return
+!DJG------------------------------------------------------------
+        end subroutine ROUTE_SUBSURFACE1
+!DJG------------------------------------------------------------
+
+!DJG------------------------------------------------------------
+
+
+      SUBROUTINE GETSUB8(IXX0,JYY0,I,J,Z,sox,tmp_gsize,max,XX,YY)
+          implicit none
+          INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY
+          INTEGER, INTENT(IN) :: I,J
+
+          REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY,8),tmp_gsize(9)
+          REAL  max
+          max = -1
+
+          IXX8 = I
+          JYY8 = J+1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J+1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J-1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY)
+
+          IXX8 = I
+          JYY8 = J-1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J-1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J+1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY)
+        RETURN
+        END SUBROUTINE GETSUB8
+
+        SUBROUTINE GETSUB8DIR(IXX8,JYY8,I,J,Z,sox,IXX0,JYY0,max,tmp_gsize,XX,YY)
+        implicit none
+        integer,INTENT(INOUT) ::IXX0,JYY0
+        INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY
+        REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY)
+        REAL, INTENT(INOUT) ::max
+        real, INTENT(IN) :: tmp_gsize
+        real :: beta , dzdx
+
+          dzdx= (z(i,j) - z(IXX0,JYY0) )/tmp_gsize
+          beta=sox(i,j) + dzdx 
+          if(max < beta ) then
+                   IXX0 = IXX8
+                   JYY0 = JYY8
+                   max = beta 
+          end if
+
+        END SUBROUTINE GETSUB8DIR
+!DJG ----------------------------------------------------------------------
+
+!DJG     SUBROUTINE ROUTE_OVERLAND2
+!DJG ----------------------------------------------------------------
+
+          SUBROUTINE ROUTE_OVERLAND2 (dt,                               &
+     &          dist,h,qsfc,sox,soy,                                   &
+     &          retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT,               &
+     &          q_sfcflx_x,q_sfcflx_y)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!  Subroutine to route excess rainfall over the watershed
+!     using a 2d diffusion routing scheme.
+!
+!  Called from: main.f
+!
+!      Will try to formulate this to be called from NOAH
+!
+!  Returns: qsfc=DQOV   which in turn becomes DH in head calc.
+!
+!  Created:  Adaptded from CASC2D source code
+!  NOTE: dh from original code has been replaced by qsfc
+!        dhh replaced by qqsfc
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id,&
+               up_id,mpp_land_com_real,MPP_LAND_UB_COM, &
+               MPP_LAND_LR_COM,mpp_land_com_integer
+#endif
+
+        IMPLICIT NONE
+
+
+!! Declare Passed variables
+
+        real :: gsize
+        INTEGER, INTENT(IN) :: XX,YY
+        REAL, INTENT(IN) :: dt , dist(XX,YY,9)
+
+!! Declare passed arrays
+
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: qsfc
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: sox
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soy
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x,q_sfcflx_y
+        REAL, INTENT(INOUT) :: QBDRYT
+        REAL  :: DH(XX,YY)
+
+!!! Declare Local Variables
+
+        REAL :: dhdx,dhdy,alfax,alfay
+        REAL :: hh53,qqsfc,hh,dt_new
+        REAL :: sfx,sfy
+        REAL :: tmp_adjust
+
+        INTEGER :: i,j
+
+!!! Initialize variables
+
+
+
+
+!!! Begin Routing of Excess Rainfall over the Watershed
+
+
+        DH = 0
+!!! Loop to route water in x-direction
+        do j=1,YY
+          do i=1,XX
+
+
+! check for boundary gridpoint?
+          if (i.eq.XX) GOTO 998
+           gsize = dist(i,j,3)
+
+
+! check for detention storage?
+          if (h(i,j).lt.retent_dep(i,j).AND.     &
+              h(i+1,j).lt.retent_dep(i+1,j)) GOTO 998
+
+          dhdx = (h(i+1,j)/1000. - h(i,j)/1000.) / gsize  ! gisze-(m),h-(mm)
+
+          sfx = (sox(i,j)-dhdx+1E-30)
+          if (abs(sfx).lt.1E-20) sfx=1E-20
+          alfax = ((abs(sfx))**0.5)/dist_rough(i,j)
+          if (sfx.lt.0.) then
+              hh=(h(i+1,j)-retent_dep(i+1,j))/1000.
+          else
+              hh=(h(i,j)-retent_dep(i,j))/1000.
+          end if
+
+          if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 998
+          if (hh.lt.0.) then
+          GOTO 998
+          end if
+
+          hh53=hh**(5./3.)
+
+
+! Calculate q-flux... (units (m))
+          qqsfc = (sfx/abs(sfx))*alfax*hh53*dt/gsize
+          q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc
+
+!DJG put adjustment in for (h) due to qqsfc
+
+!yw changed as following:
+           tmp_adjust=qqsfc*1000
+          if(tmp_adjust .le. 0 ) GOTO 998
+           if((h(i,j) - tmp_adjust) <0 )  then
+#ifdef HYDRO_D
+               print*, "Error Warning: surface head is negative:  ",i,j
+#endif
+               tmp_adjust = h(i,j)
+           end if
+           if((h(i+1,j) + tmp_adjust) <0) then 
+#ifdef HYDRO_D
+               print*, "Error Warning: surface head is negative: ",i+1,j
+#endif
+               tmp_adjust = -1*h(i+1,j)
+           end if
+ 	   Dh(i,j) = Dh(i,j)-tmp_adjust
+           Dh(i+1,j) = Dh(i+1,j) + tmp_adjust
+!yw end change
+
+
+
+!DG Boundary adjustments here
+!DG Constant Flux Condition
+#ifdef MPP_LAND
+          if ((i.eq.1).AND.(sfx.lt.0).and. & 
+                (left_id .lt. 0) ) then
+#else
+          if ((i.eq.1).AND.(sfx.lt.0)) then
+#endif
+             Dh(i,j) = Dh(i,j) + qqsfc*1000.
+            QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000.
+            QBDRYT=QBDRYT + qqsfc*1000.
+#ifdef MPP_LAND
+          else if ( (i.eq.(XX-1)).AND.(sfx.gt.0) &
+             .and. (right_id .lt. 0) ) then
+#else
+          else if ((i.eq.(XX-1)).AND.(sfx.gt.0)) then
+#endif
+             tmp_adjust = qqsfc*1000.
+             if(h(i+1,j).lt.tmp_adjust) tmp_adjust = h(i+1,j)
+             Dh(i+1,j) = Dh(i+1,j) - tmp_adjust
+!DJG Re-assign h(i+1) = 0.0 when <0.0 (from rounding/truncation error)
+            QBDRY(I+1,J)=QBDRY(I+1,J) - tmp_adjust
+            QBDRYT=QBDRYT - tmp_adjust
+          end if
+
+
+998     continue
+
+!! End loop to route sfc water in x-direction
+          end do
+        end do
+
+        H = H + DH
+#ifdef MPP_LAND
+       call MPP_LAND_LR_COM(H,XX,YY,99)
+       call MPP_LAND_LR_COM(QBDRY,XX,YY,99)
+#endif
+
+
+        DH = 0
+!!!! Loop to route water in y-direction
+        do j=1,YY
+          do i=1,XX
+
+!! check for boundary grid point?
+          if (j.eq.YY) GOTO 999
+           gsize = dist(i,j,1)
+
+
+!! check for detention storage?
+          if (h(i,j).lt.retent_dep(i,j).AND.     & 
+              h(i,j+1).lt.retent_dep(i,j+1)) GOTO 999
+
+          dhdy = (h(i,j+1)/1000. - h(i,j)/1000.) / gsize
+
+          sfy = (soy(i,j)-dhdy+1E-30)
+          if (abs(sfy).lt.1E-20) sfy=1E-20
+          alfay = ((abs(sfy))**0.5)/dist_rough(i,j)
+          if (sfy.lt.0.) then
+              hh=(h(i,j+1)-retent_dep(i,j+1))/1000.
+          else
+              hh=(h(i,j)-retent_dep(i,j))/1000.
+          end if
+
+          if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 999
+          if (hh.lt.0.) then
+            GOTO 999
+          end if
+
+         hh53=hh**(5./3.)
+
+! Calculate q-flux...
+          qqsfc = (sfy/abs(sfy))*alfay*hh53*dt / gsize
+          q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc
+
+
+!DJG put adjustment in for (h) due to qqsfc
+!yw	  h(i,j) = h(i,j)-qqsfc*1000.
+!yw          h(i,j+1) = h(i,j+1) + qqsfc*1000.
+!yw changed as following:
+           tmp_adjust=qqsfc*1000
+          if(tmp_adjust .le. 0 ) GOTO 999
+
+           if((h(i,j) - tmp_adjust) <0 )  then
+#ifdef HYDRO_D
+               print*, "Error Warning: surface head is negative:  ",i,j
+#endif
+               tmp_adjust = h(i,j)
+           end if
+           if((h(i,j+1) + tmp_adjust) <0) then
+#ifdef HYDRO_D
+               print*, "Error Warning: surface head is negative: ",i,j+1
+#endif
+               tmp_adjust = -1*h(i,j+1)
+           end if
+	  Dh(i,j) = Dh(i,j)-tmp_adjust
+          Dh(i,j+1) = Dh(i,j+1) + tmp_adjust
+!yw end change
+
+!          qsfc(i,j) = qsfc(i,j)-qqsfc
+!          qsfc(i,j+1) = qsfc(i,j+1) + qqsfc
+!!DG Boundary adjustments here
+!!DG Constant Flux Condition
+#ifdef MPP_LAND
+          if ((j.eq.1).AND.(sfy.lt.0)   &
+             .and. (down_id .lt. 0) ) then
+#else
+          if ((j.eq.1).AND.(sfy.lt.0)) then
+#endif
+            Dh(i,j) = Dh(i,j) + qqsfc*1000.
+            QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000.
+            QBDRYT=QBDRYT + qqsfc*1000.
+#ifdef MPP_LAND
+          else if ((j.eq.(YY-1)).AND.(sfy.gt.0) &
+             .and. (up_id .lt. 0) ) then
+#else
+          else if ((j.eq.(YY-1)).AND.(sfy.gt.0)) then
+#endif
+             tmp_adjust = qqsfc*1000.
+             if(h(i,j+1).lt.tmp_adjust) tmp_adjust = h(i,j+1)
+             Dh(i,j+1) = Dh(i,j+1) - tmp_adjust
+!DJG Re-assign h(j+1) = 0.0 when <0.0 (from rounding/truncation error)
+            QBDRY(I,J+1)=QBDRY(I,J+1) - tmp_adjust
+            QBDRYT=QBDRYT - tmp_adjust
+          end if
+
+999     continue
+
+!!!! End loop to route sfc water in y-direction
+          end do
+        end do
+
+        H = H +DH
+#ifdef MPP_LAND
+       call MPP_LAND_UB_COM(H,XX,YY,99)
+       call MPP_LAND_UB_COM(QBDRY,XX,YY,99)
+#endif
+        return
+
+!DJG ----------------------------------------------------------------------
+        end subroutine ROUTE_OVERLAND2
+
+
+     Subroutine drive_RT( IX,JX,NSOIL,IXRT,JXRT,  &
+       SMC,STC,SH2OX,INFXSRT,SFCHEADRT,SMCMAX1,SMCREF1,LKSAT,  &
+       SMCWLT1, SMCRTCHK,DSMC,ZSOIL, SMCAGGRT,STCAGGRT,SH2OAGGRT, &
+       SLDPTH,VEGTYP,SOLDEPRT,INFXSAGGRT,DHRT,QSTRMVOLRT, &
+       QBDRYRT,LAKE_INFLORT,SFCHEADSUBRT,INFXSWGT,LKSATRT, &
+       INFXSUBRT,OVROUGHRT,QSUBRT,ZWATTABLRT,QSUBBDRYRT,   &
+       RETDEPRT,SOXRT,SOYRT,SUB_RESID,SMCRT,SMCMAXRT,SMCWLTRT, &
+       SH2OWGT,LAKE_MSKRT,CH_NETRT,dist,LSMVOL,DSMCTOT,SMCTOT1,&
+       SMCTOT2,suminfxs1,suminfxsrt,SO8RT,SO8RT_D,AGGFACTRT,  &
+       SUBRTSWCRT,OVRTSWCRT, LAKE_CT, STRM_CT,    &
+       RT_OPTION,OV_ROUGH,INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT,&
+       DTRT, DT,LAKE_INFLOTRT,QBDRYTRT,QSUBBDRYTRT,&
+       QSTRMVOLTRT,q_sfcflx_x,q_sfcflx_y,LKSATFAC,&
+       OVROUGHRTFAC,area_lsm)
+
+
+
+!DX,SICE,INFXSWGT,SH2OWGT,i,j,AGGFACYRT,AGGFACXRT,IXXRT,JYYRT,INFXSUBRT
+! LKSATRT,SMCRT,SMCMAXRT,WATHOLDCAP,SMCWLTRT,OVROUGHRT,LAKE_MSKRT
+
+!yyww 
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id, &
+              up_id,mpp_land_com_real, my_id, &
+             mpp_land_sync,mpp_land_com_integer,mpp_land_max_int1, &
+            sum_double
+#endif
+     implicit none
+
+! Define the variables
+       integer IX,JX,NSOIL,IXRT,JXRT
+       real,DIMENSION(IX,JX,NSOIL)::SMC,STC,SH2OX,SICE
+       real,DIMENSION(IX,JX)      ::INFXSRT,SFCHEADRT,SMCMAX1,SMCREF1,LKSAT,  &
+                    SMCWLT1, area_lsm
+       real,DIMENSION(NSOIL)      :: ZSOIL,     &
+                     SMCAGGRT,STCAGGRT,SH2OAGGRT,SLDPTH
+       integer,DIMENSION(IX,JX)      ::VEGTYP
+
+       real,DIMENSION(IXRT,JXRT)  ::SOLDEPRT,INFXSAGGRT,DHRT,QSTRMVOLRT, &
+                    QBDRYRT,LAKE_INFLORT,SFCHEADSUBRT,INFXSWGT,LKSATRT, &
+                    INFXSUBRT,OVROUGHRT,QSUBRT,ZWATTABLRT,QSUBBDRYRT,   &
+                    RETDEPRT,SOXRT,SOYRT,SUB_RESID,q_sfcflx_x,q_sfcflx_y, &
+                    LKSATFAC,CWATAVAIL,OVROUGHRTFAC
+       integer,DIMENSION(IXRT,JXRT)      ::SATLYRCHK
+
+       real,DIMENSION(IXRT,JXRT,NSOIL)::SMCRT,SMCMAXRT,SMCREFRT,SMCWLTRT,SH2OWGT
+       integer,INTENT(IN), DIMENSION(IXRT,JXRT)     ::CH_NETRT
+       integer,INTENT(INOUT), DIMENSION(IXRT,JXRT)  ::LAKE_MSKRT
+
+       REAL    :: INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT, WATHOLDCAP,DTRT,&
+                  DT,LAKE_INFLOTRT,QBDRYTRT,QSUBBDRYTRT,QSTRMVOLTRT
+       REAL    OV_ROUGH(*)
+ 
+       REAL  ::  dx,LSMVOL,SMCEXCS
+       real, DIMENSION(IXRT,JXRT,9)  :: dist
+       
+       real, DIMENSION(IXRT,JXRT,8)  ::SO8RT
+       INTEGER, DIMENSION(IXRT,JXRT,3)  ::SO8RT_D
+                  
+       integer :: AGGFACTRT,SUBRTSWCRT,OVRTSWCRT
+       integer :: sfcrt_flag
+!end define variable.s
+       integer i,j,AGGFACYRT, AGGFACXRT, KRT, kx, KF,&
+            IXXRT, JYYRT, LAKE_CT, STRM_CT,RT_OPTION
+      
+!DJG Debug variables...
+       INTEGER, PARAMETER :: double1=8
+       real (KIND=double1), DIMENSION(NSOIL)   :: SMCRTCHK,DSMC
+       real (KIND=double1)                     :: smctot2,smctot1,dsmctot
+       real (KIND=double1)                     :: suminfxsrt,suminfxs1
+       real (KIND=double1)                     :: chan_in1,chan_in2
+       real (KIND=double1)                     :: lake_in1,lake_in2
+       real (KIND=double1)                     :: qbdry1,qbdry2
+
+
+
+
+!DJG Use New Var SICE to track diff between SMC and SH2O through routing...
+	SICE=SMC-SH2OX
+        SMCREFRT = 0
+
+!DJG First, Disaggregate a few key fields for routing...
+!DJG Debug...
+#ifdef HYDRO_D
+	print *, "Beginning Disaggregation..."
+#endif
+	
+!DJG Mass balance check for disagg...
+
+
+!DJG Weighting alg. alteration...(prescribe wghts if time = 1)
+
+
+        do J=1,JX
+          do I=1,IX
+
+!DJG Weighting alg. alteration...
+              LSMVOL=INFXSRT(I,J)*area_lsm(I,J)
+
+
+             do AGGFACYRT=AGGFACTRT-1,0,-1
+              do AGGFACXRT=AGGFACTRT-1,0,-1
+
+               IXXRT=I*AGGFACTRT-AGGFACXRT
+               JYYRT=J*AGGFACTRT-AGGFACYRT
+#ifdef MPP_LAND
+       if(left_id.ge.0) IXXRT=IXXRT+1
+       if(down_id.ge.0) JYYRT=JYYRT+1
+#else
+!yw ????
+!       IXXRT=IXXRT+1
+!       JYYRT=JYYRT+1
+#endif
+
+
+!DJG Implement subgrid weighting routine...
+               INFXSUBRT(IXXRT,JYYRT)=LSMVOL*     &
+                   INFXSWGT(IXXRT,JYYRT)/dist(IXXRT,JYYRT,9)
+  
+
+            do KRT=1,NSOIL  !Do for soil profile loop
+               IF(SICE(I,J,KRT).gt.0) then  !...adjust for soil ice
+!DJG Adjust SMCMAX for SICE when subsfc routing...make 3d variable
+                 SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J)-SICE(I,J,KRT)
+                 SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J)-SICE(I,J,KRT)
+                 WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J)
+                 IF (SICE(I,J,KRT).le.WATHOLDCAP)    then
+                        SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J)      
+                 else
+                    if(SICE(I,J,KRT).lt.SMCMAX1(I,J)) &
+                          SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - &
+                          (SICE(I,J,KRT)-WATHOLDCAP)
+                    if(SICE(I,J,KRT).ge.SMCMAX1(I,J)) SMCWLTRT(IXXRT,JYYRT,KRT) = 0.
+                 end if
+               ELSE
+                 SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J)
+                 SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J)
+                 WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J)
+                 SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) 
+               END IF   !endif adjust for soil ice...
+
+
+!Now Adjust soil moisture
+!DJG Use SH2O instead of SMC for 'liquid' water...
+                 IF(SMCMAXRT(IXXRT,JYYRT,KRT).GT.0) THEN !Check for smcmax data (=0 over water)
+                   SMCRT(IXXRT,JYYRT,KRT)=SH2OX(I,J,KRT)*SH2OWGT(IXXRT,JYYRT,KRT)
+!old                   SMCRT(IXXRT,JYYRT,KRT)=SMC(I,J,KRT)
+                 ELSE
+                   SMCRT(IXXRT,JYYRT,KRT) = 0.001  !will be skipped w/ landmask
+                   SMCMAXRT(IXXRT,JYYRT,KRT) = 0.001
+                 END IF
+!DJG Check/Adjust so that subgrid cells do not exceed saturation...
+                 IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN
+                   SMCEXCS = (SMCRT(IXXRT,JYYRT,KRT) - SMCMAXRT(IXXRT,JYYRT,KRT)) &
+                             * SLDPTH(KRT)*1000.  !Excess soil water in units of (mm)
+                   SMCRT(IXXRT,JYYRT,KRT) = SMCMAXRT(IXXRT,JYYRT,KRT)
+                   DO KF = KRT-1,1, -1  !loop back upward to redistribute excess water from disagg.
+                     SMCRT(IXXRT,JYYRT,KF) = SMCRT(IXXRT,JYYRT,KF) + SMCEXCS/(SLDPTH(KF)*1000.) 
+                     IF (SMCRT(IXXRT,JYYRT,KF).GT.SMCMAXRT(IXXRT,JYYRT,KF)) THEN  !Recheck new lyr sat.
+                       SMCEXCS = (SMCRT(IXXRT,JYYRT,KF) - SMCMAXRT(IXXRT,JYYRT,KF)) &
+                           * SLDPTH(KF)  !Excess soil water in units of (mm)
+                       SMCRT(IXXRT,JYYRT,KF) = SMCMAXRT(IXXRT,JYYRT,KF)
+                     ELSE  ! Excess soil water expired
+                       SMCEXCS = 0.
+                       EXIT
+                     END IF
+                   END DO
+                   IF (SMCEXCS.GT.0) THEN  !If not expired by sfc then add to Infil. Excess
+                     INFXSUBRT(IXXRT,JYYRT) = INFXSUBRT(IXXRT,JYYRT) + SMCEXCS
+                     SMCEXCS = 0.
+                   END IF
+                 END IF  !End if for soil moisture saturation excess
+
+
+             end do !End do for soil profile loop
+
+
+
+               do KRT=1,NSOIL  !debug loop
+                  IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN
+#ifdef HYDRO_D
+                      print *, "Err. SMCMAX exceeded upon disaggregation3...", ixxrt,jyyrt,krt,&
+                              SMCRT(IXXRT,JYYRT,KRT),SMCMAXRT(IXXRT,JYYRT,KRT)
+                      call hydro_stop()
+#endif
+                  ELSE IF (SMCRT(IXXRT,JYYRT,KRT).LE.0.) THEN
+#ifdef HYDRO_D
+                      print *, "Err. SMCRT fully depleted upon disaggregation...", ixxrt,jyyrt,krt,&
+                              SMCRT(IXXRT,JYYRT,KRT),SH2OWGT(IXXRT,JYYRT,KRT),SH2OX(I,J,KRT)
+                      print *, "VEGTYP = ", VEGTYP(I,J)
+                      print *, "i,j,krt, nsoil",i,j,krt,nsoil
+                      call hydro_stop()
+#endif
+                  END IF
+               end do !debug loop
+
+
+
+!DJG map ov roughness as function of land use provided in VEGPARM.TBL...
+! --- added extra check for VEGTYP for 'masked-out' locations...
+! --- out of basin locations (VEGTYP=0) have OVROUGH hardwired to 0.1
+            IF (VEGTYP(I,J).LE.0) then
+              OVROUGHRT(IXXRT,JYYRT) = 0.1     !COWS mask test
+            ELSE
+               OVROUGHRT(IXXRT,JYYRT)=OV_ROUGH(VEGTYP(I,J))*OVROUGHRTFAC(IXXRT,JYYRT)  ! Distributed calibration...1/17/2012
+            END IF
+
+
+
+!DJG 6.12.08 Map lateral hydraulic conductivity and apply distributed scaling
+! ---        factor that will be read in from hires terrain file
+!              LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) 
+              LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) * LKSATFAC(IXXRT,JYYRT) * &  !Apply scaling factor...
+! ...and scale from max to 0 when SMC decreases from SMCMAX to SMCREF...
+                                    ((SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL)) / &
+                                    (SMCMAXRT(IXXRT,JYYRT,NSOIL)-SMCREFRT(IXXRT,JYYRT,NSOIL)) )
+
+
+
+!DJG set up lake mask...
+!--- modify to make lake mask large here, but not one of the routed lakes!!!
+!--            IF (VEGTYP(I,J).eq.16) then
+               IF (VEGTYP(I,J).eq.16 .and. &
+                        CH_NETRT(IXXRT,JYYRT).le.0) then
+                 !--LAKE_MSKRT(IXXRT,JYYRT) = 1
+                 LAKE_MSKRT(IXXRT,JYYRT) = 9999
+!yw                 LAKE_MSKRT(IXXRT,JYYRT) = -9999
+               end if
+
+              end do
+             end do
+
+          end do
+        end do
+
+
+!!!! Find saturated layer depth...
+! Loop through domain to determine sat. layers and assign wat tbl depth...
+!    and water available for subsfc routing (CWATAVAIL)...
+! This subroutine returns: ZWATTABLRT, CWATAVAIL and SATLYRCHK
+
+         CWATAVAIL = 0.
+
+         CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, &
+                             SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, &
+                             CWATAVAIL,SLDPTH)
+
+
+
+#ifdef HYDRO_D
+	print *, "After Disaggregation..."
+#endif
+
+
+#ifdef MPP_LAND
+        call MPP_LAND_COM_REAL(ZWATTABLRT,IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(CWATAVAIL,IXRT,JXRT,99)
+        call MPP_LAND_COM_INTEGER(SATLYRCHK,IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(INFXSUBRT,IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(LKSATRT,IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(OVROUGHRT,IXRT,JXRT,99)
+        call MPP_LAND_COM_INTEGER(LAKE_MSKRT,IXRT,JXRT,99)
+     do i = 1, NSOIL
+        call MPP_LAND_COM_REAL(SMCMAXRT(:,:,i),IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(SMCWLTRT(:,:,i),IXRT,JXRT,99)
+     end DO
+#endif
+
+
+!DJG Second, Call subsurface routing routine...
+  IF (SUBRTSWCRT.EQ.1) THEN
+#ifdef HYDRO_D
+	print *, "Beginning SUB_routing..."
+        print *, "Routing method is ",rt_option, " direction."
+#endif
+
+    CALL SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT,  &
+          LKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT,NSOIL,SMCRT,     &
+          INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT,SMCWLTRT,SO8RT,    &
+          SO8RT_D, rt_option,SLDPTH,SUB_RESID,CWATAVAIL,SATLYRCHK)
+
+#ifdef HYDRO_D
+    print *, "SUBROUTE routing called and returned..."
+#endif
+
+
+
+  ENDIF    ! ENDIF SUBRTSWCRT
+
+
+!DJG Third, Call Overland Flow Routing Routine...
+  IF (OVRTSWCRT.EQ.1) THEN
+#ifdef HYDRO_D
+	print *, "Beginning OV_routing..."
+        print *, "Routing method is ",rt_option, " direction."
+        print *, "ixrt, jxrt =", ixrt, jxrt
+#endif
+
+!DJG debug...OV Routing...
+	suminfxs1=0.
+        chan_in1=0.
+        lake_in1=0.
+        qbdry1=0.
+        do i=1,IXRT
+         do j=1,JXRT
+            suminfxs1=suminfxs1+INFXSUBRT(I,J)/float(IXRT*JXRT)
+            chan_in1=chan_in1+QSTRMVOLRT(I,J)/float(IXRT*JXRT)
+            lake_in1=lake_in1+LAKE_INFLORT(I,J)/float(IXRT*JXRT)
+            qbdry1=qbdry1+QBDRYRT(I,J)/float(IXRT*JXRT)
+         end do
+        end do
+
+#ifdef MPP_LAND
+! not tested
+        CALL sum_double(suminfxs1)
+        CALL sum_double(chan_in1)
+        CALL sum_double(lake_in1)
+        CALL sum_double(qbdry1)
+#endif
+
+
+!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(set sfcrt_flag)
+!DJG.7.20.2007 - this check will skip ov rtng when no flow is present...
+        
+        sfcrt_flag = 0
+        
+        do j=1,jxrt
+          do i=1,ixrt
+            if(INFXSUBRT(i,j).gt.RETDEPRT(i,j)) then
+              sfcrt_flag = 1
+              exit
+            end if
+          end do
+          if(sfcrt_flag.eq.1) exit
+        end do   
+
+#ifdef MPP_LAND
+       call mpp_land_max_int1(sfcrt_flag)            
+#endif
+!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(IF)
+
+    if (sfcrt_flag.eq.1) then  !If/then for sfc_rt check...
+#ifdef HYDRO_D
+      write(6,*) "calling OV_RTNG "
+#endif
+      CALL OV_RTNG(DT,DTRT,IXRT,JXRT,INFXSUBRT,SFCHEADSUBRT,DHRT,      &
+        CH_NETRT,RETDEPRT,OVROUGHRT,QSTRMVOLRT,QBDRYRT,              &
+        QSTRMVOLTRT,QBDRYTRT,SOXRT,SOYRT,dist,                       &
+        LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT,SO8RT,SO8RT_D,rt_option,&
+        q_sfcflx_x,q_sfcflx_y) 
+    else
+#ifdef HYDRO_D
+      print *, "No water to route overland..."
+#endif
+    end if  !Endif for sfc_rt check...
+
+!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(ENDIF)
+
+#ifdef HYDRO_D
+    print *, "OV routing called and returned..."
+#endif
+
+!DJG Debug...OV Routing...
+	suminfxsrt=0.
+        chan_in2=0.
+        lake_in2=0.
+        qbdry2=0.
+        do i=1,IXRT
+         do j=1,JXRT
+            suminfxsrt=suminfxsrt+SFCHEADSUBRT(I,J)/float(IXRT*JXRT)
+            chan_in2=chan_in2+QSTRMVOLRT(I,J)/float(IXRT*JXRT)
+            lake_in2=lake_in2+LAKE_INFLORT(I,J)/float(IXRT*JXRT)
+            qbdry2=qbdry2+QBDRYRT(I,J)/float(IXRT*JXRT)
+         end do
+        end do
+#ifdef MPP_LAND
+! not tested
+        CALL sum_double(suminfxsrt)
+        CALL sum_double(chan_in2)
+        CALL sum_double(lake_in2)
+        CALL sum_double(qbdry2)
+#endif
+
+#ifdef HYDRO_D
+	print *, "OV Routing Mass Bal: "
+        print *, "Infil. Excess/Sfc Head: ", suminfxsrt-suminfxs1,      &
+                   suminfxsrt,suminfxs1
+        print *, "chan_in = ",chan_in2-chan_in1
+        print *, "lake_in = ",lake_in2-lake_in1
+        print *, "Qbdry = ",qbdry2-qbdry1
+	print *, "Residual : ", suminfxs1-suminfxsrt-(chan_in2-chan_in1) &
+                     -(lake_in2-lake_in1)-(qbdry2-qbdry1)
+#endif
+
+  ENDIF      ! ENDIF for OVRTSWCRT
+
+
+
+
+!DJG Fourth(last), Aggregate a few fields from routing.
+#ifdef HYDRO_D
+ 	print *, "Beginning Aggregation..."
+#endif
+
+
+        do J=1,JX
+          do I=1,IX
+
+             SFCHEADAGGRT= 0.
+!DJG Subgrid weighting edit...
+             LSMVOL=0.
+             do KRT=1,NSOIL
+               SMCAGGRT(KRT) = 0.
+               SH2OAGGRT(KRT) = 0.
+             end do
+
+
+             do AGGFACYRT=AGGFACTRT-1,0,-1
+              do AGGFACXRT=AGGFACTRT-1,0,-1
+
+
+                IXXRT=I*AGGFACTRT-AGGFACXRT
+                JYYRT=J*AGGFACTRT-AGGFACYRT
+#ifdef MPP_LAND
+       if(left_id.ge.0) IXXRT=IXXRT+1
+       if(down_id.ge.0) JYYRT=JYYRT+1
+#else
+!yw ????
+!       IXXRT=IXXRT+1
+!       JYYRT=JYYRT+1
+#endif
+
+!State Variables
+                SFCHEADAGGRT=SFCHEADAGGRT+SFCHEADSUBRT(IXXRT,JYYRT)
+!DJG Subgrid weighting edit...
+                LSMVOL=LSMVOL+SFCHEADSUBRT(IXXRT,JYYRT)*dist(IXXRT,JYYRT,9)
+
+                do KRT=1,NSOIL
+!DJG               SMCAGGRT(KRT)=SMCAGGRT(KRT)+SMCRT(IXXRT,JYYRT,KRT)
+                   SH2OAGGRT(KRT)=SH2OAGGRT(KRT)+           &
+                         SMCRT(IXXRT,JYYRT,KRT)
+                end do
+
+              end do
+             end do
+
+
+
+            SFCHEADRT(I,J) = SFCHEADAGGRT/(AGGFACTRT**2)
+
+            do KRT=1,NSOIL
+!DJG              SMC(I,J,KRT)=SMCAGGRT(KRT)/(AGGFACTRT**2)
+               SH2OX(I,J,KRT)=SH2OAGGRT(KRT)/(AGGFACTRT**2)
+            end do
+
+
+
+!DJG Calculate subgrid weighting array...
+
+              do AGGFACYRT=AGGFACTRT-1,0,-1
+                do AGGFACXRT=AGGFACTRT-1,0,-1
+                  IXXRT=I*AGGFACTRT-AGGFACXRT
+                  JYYRT=J*AGGFACTRT-AGGFACYRT
+#ifdef MPP_LAND
+       if(left_id.ge.0) IXXRT=IXXRT+1
+       if(down_id.ge.0) JYYRT=JYYRT+1
+#else
+!yw ???
+!       IXXRT=IXXRT+1
+!       JYYRT=JYYRT+1
+#endif
+                  if (lsmvol.gt.0.) then
+                    INFXSWGT(IXXRT,JYYRT)=SFCHEADSUBRT(IXXRT,JYYRT)*  &
+                      dist(IXXRT,JYYRT,9)/LSMVOL
+                  else
+                    INFXSWGT(IXXRT,JYYRT)=1./FLOAT(AGGFACTRT*AGGFACTRT)
+                  end if
+
+                  do KRT=1,NSOIL
+                    IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN
+#ifdef HYDRO_D
+                      print *, "SMCMAX exceeded upon aggregation...", &
+                           SMCRT(IXXRT,JYYRT,KRT), SMCMAXRT(IXXRT,JYYRT,KRT)
+                      call hydro_stop()
+#endif
+                    END IF
+                    IF(SH2OX(I,J,KRT).LE.0.) THEN
+#ifdef HYDRO_D
+                      print *, "Erroneous value of SH2O...",SH2OX(I,J,KRT),I,J,KRT
+                      call hydro_stop()
+#endif
+                    END IF
+                    SH2OWGT(IXXRT,JYYRT,KRT)=SMCRT(IXXRT,JYYRT,KRT)/SH2OX(I,J,KRT)
+                  end do
+
+                end do
+              end do
+
+         end do
+        end do
+
+#ifdef MPP_LAND
+        call MPP_LAND_COM_REAL(INFXSWGT,IXRT,JXRT,99)
+        do i = 1, NSOIL
+           call MPP_LAND_COM_REAL(SH2OWGT(:,:,i),IXRT,JXRT,99)
+        end do
+#endif
+
+
+
+
+
+!DJG Update SMC with SICE (unchanged) and new value of SH2O from routing...
+	SMC=SH2OX+SICE
+#ifdef HYDRO_D
+ 	print *, "Finished Aggregation..."
+#endif
+        return
+      end Subroutine drive_RT ! drive_RT
+
+!DJG ----------------------------------------------------------------------
+
+
+!DJG-----------------------------------------------------------------------
+!DJG SUBROUTINE TER_ADJ_SOL    - Terrain adjustment of incoming solar radiation
+!DJG-----------------------------------------------------------------------
+	SUBROUTINE TER_ADJ_SOL(IX,JX,SO8LD_D,TSLP,SHORT,XLAT,XLONG,olddate,DT)
+
+#ifdef MPP_LAND
+        use module_mpp_land, only:  my_id, io_id, &
+             mpp_land_bcast_int1 
+#endif
+          implicit none
+          integer,INTENT(IN)     :: IX,JX
+          INTEGER,INTENT(in), DIMENSION(IX,JX,3)   :: SO8LD_D
+          real,INTENT(IN), DIMENSION(IX,JX)  :: XLAT,XLONG
+ 	  real,INTENT(IN) :: DT
+          real,INTENT(INOUT), DIMENSION(IX,JX)  :: SHORT
+          character(len=19) :: olddate
+
+! Local Variables...
+          real, dimension(IX,JX) ::TSLP,TAZI
+          real, dimension(IX,JX) ::SOLDN
+	  real :: SOLDEC,DGRD,ITIME2,HRANGLE
+	  real :: BINSH,SOLZANG,SOLAZI,INCADJ
+	  real :: TAZIR,TSLPR,LATR,LONR,SOLDNADJ
+          integer :: JULDAY0,HHTIME0,MMTIME0,YYYY0,MM0,DD0
+          integer :: JULDAY,HHTIME,MMTIME,YYYY,MM,DD
+	  integer :: I,J
+          
+
+!----------------------------------------------------------------------
+!  SPECIFY PARAMETERS and VARIABLES
+!----------------------------------------------------------------------
+
+       JULDAY = 0	
+       SOLDN = SHORT
+       DGRD = 3.14159/180.
+       
+! Set up time variables...
+#ifdef MPP_LAND   
+       if(my_id .eq. IO_id) then
+#endif
+          read(olddate(1:4),"(I4)") YYYY0 ! real-time year (GMT)
+          read(olddate(6:7),"(I2.2)") MM0 ! real-time month (GMT)
+          read(olddate(9:10),"(I2.2)") DD0 ! real-time day (GMT)
+          read(olddate(12:13),"(I2.2)") HHTIME0 ! real-time hour (GMT)
+          read(olddate(15:16),"(I2.2)") MMTIME0 ! real-time minutes (GMT)
+#ifdef MPP_LAND   
+       endif
+       call mpp_land_bcast_int1(YYYY0) 
+       call mpp_land_bcast_int1(MM0) 
+       call mpp_land_bcast_int1(DD0) 
+       call mpp_land_bcast_int1(HHTIME0) 
+       call mpp_land_bcast_int1(MMTIME0) 
+#endif
+
+
+! Set up terrain variables...(returns TSLP&TAZI in radians) 
+	call SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI)
+
+!----------------------------------------------------------------------
+!  BEGIN LOOP THROUGH GRID
+!----------------------------------------------------------------------
+        DO J=1,JX
+          DO I=1,IX
+             YYYY = YYYY0
+             MM  = MM0
+             DD  = DD0
+             HHTIME = HHTIME0
+             MMTIME = MMTIME0
+      	     call GMT2LOCAL(1,1,XLONG(i,j),YYYY,MM,DD,HHTIME,MMTIME,DT)
+             call JULDAY_CALC(YYYY,MM,DD,JULDAY)
+
+! Convert to radians...
+           LATR = XLAT(I,J)   !send solsub local lat in deg
+           LONR = XLONG(I,J)   !send solsub local lon in deg
+           TSLPR = TSLP(I,J)/DGRD !send solsub local slp in deg
+           TAZIR = TAZI(I,J)/DGRD !send solsub local azim in deg
+
+!Call SOLSUB to return terrain adjusted incoming solar radiation...
+! SOLSUB taken from Whiteman and Allwine, 1986, Environ. Software.
+
+          call SOLSUB(LONR,LATR,TAZIR,TSLPR,SOLDN(I,J),YYYY,MM,         &
+               DD,HHTIME,MMTIME,SOLDNADJ,SOLZANG,SOLAZI,INCADJ)
+
+         SOLDN(I,J)=SOLDNADJ
+
+          ENDDO
+        ENDDO
+
+	SHORT = SOLDN
+
+        return
+	end SUBROUTINE TER_ADJ_SOL  
+!DJG-----------------------------------------------------------------------
+!DJG END SUBROUTINE TER_ADJ_SOL
+!DJG-----------------------------------------------------------------------
+
+
+!DJG-----------------------------------------------------------------------
+!DJG SUBROUTINE GMT2LOCAL
+!DJG-----------------------------------------------------------------------
+	subroutine GMT2LOCAL(IX,JX,XLONG,YY,MM,DD,HH,MIN,DT)
+
+       implicit none
+
+!!! Declare Passed Args.
+
+        INTEGER, INTENT(INOUT) :: yy,mm,dd,hh,min
+        INTEGER, INTENT(IN) :: IX,JX
+        REAL,INTENT(IN), DIMENSION(IX,JX)  :: XLONG
+        REAL,INTENT(IN) :: DT
+
+!!! Declare local variables
+
+        integer :: i,j,minflag,hhflag,ddflag,mmflag,yyflag
+        integer :: adj_min,lst_adj_min,lst_adj_hh,adj_hh
+        real, dimension(IX,JX) :: TDIFF
+        real :: tmp
+        integer :: yyinit,mminit,ddinit,hhinit,mininit
+
+!!! Initialize flags
+        hhflag=0
+        ddflag=0
+        mmflag=0
+        yyflag=0
+
+!!! Set up constants...
+        yyinit = yy
+   	mminit = mm
+        ddinit = dd
+        hhinit = hh
+        mininit = min
+
+
+! Loop through data...
+     do j=1,JX
+      do i=1,IX
+
+! Reset yy,mm,dd...
+        yy = yyinit
+	mm = mminit
+        dd = ddinit
+        hh = hhinit
+	min = mininit
+
+!!! Set up adjustments...
+!   - assumes +E , -W  longitude and 0.06667 hr/deg (=24/360)
+       TDIFF(I,J) = XLONG(I,J)*0.06667   ! time offset in hr
+       tmp = TDIFF(I,J)
+       lst_adj_hh = INT(tmp)
+       lst_adj_min = NINT(MOD(int(tmp),1)*60.) + int(DT/2./60.)  ! w/ 1/2 timestep adjustment...
+
+!!! Process Minutes...
+        adj_min = min+lst_adj_min
+        if (adj_min.lt.0) then
+          min=60+adj_min
+          lst_adj_hh = lst_adj_hh - 1
+        else if (adj_min.ge.0.AND.adj_min.lt.60) then
+          min=adj_min
+        else if (adj_min.ge.60) then
+          min=adj_min-60
+          lst_adj_hh = lst_adj_hh + 1
+        end if
+
+!!! Process Hours
+        adj_hh = hh+lst_adj_hh
+	if (adj_hh.lt.0) then
+          hh = 24+adj_hh
+          ddflag=1
+        else if (adj_hh.ge.0.AND.adj_hh.lt.24) then
+          hh=adj_hh
+        else if (adj_hh.ge.24) then
+          hh=adj_hh-24
+          ddflag = 2
+        end if
+
+
+
+!!! Process Days, Months, Years
+! Subtract a day
+        if (ddflag.eq.1) then
+          if (dd.gt.1) then
+            dd=dd-1
+          else
+            if (mm.eq.1) then
+              mm=12
+              yy=yy-1
+            else
+              mm=mm-1
+            end if
+            if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. &
+                (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. &
+                 (mm.eq.12)) then
+              dd=31
+            else
+
+!!! Adjustment for leap years!!!
+                if(mm.eq.2) then
+                  if(MOD(yy,4).eq.0) then
+                    dd=29
+                  else
+                    dd=28
+                  end if
+                end if
+                if(mm.ne.2) dd=30
+            end if
+          end if
+        end if
+
+! Add a day
+        if (ddflag.eq.2) then
+          if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. &
+                (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. &
+                 (mm.eq.12)) then
+            if (dd.eq.31) then
+              dd=1
+              if (mm.eq.12) then
+                mm=1
+                yy=yy+1
+              else
+                mm=mm+1
+              end if
+            else
+              dd=dd+1
+            end if
+
+!!! Adjustment for leap years!!!
+          else if (mm.eq.2) then
+            if(MOD(yy,4).eq.0) then
+              if (dd.eq.29) then
+                dd=1
+                mm=3
+              else
+                dd=dd+1
+              end if
+            else
+              if (dd.eq.28) then
+                dd=1
+                mm=3
+              else
+                dd=dd+1
+              end if
+            end if
+          else
+            if (dd.eq.30) then
+              dd=1
+              mm=mm+1
+            else
+              dd=dd+1
+            end if
+          end if
+
+        end if
+
+       end do   !i-loop
+      end do   !j-loop
+
+        return
+        end subroutine
+
+!DJG-----------------------------------------------------------------------
+!DJG END SUBROUTINE GMT2LOCAL
+!DJG-----------------------------------------------------------------------
+
+
+
+!DJG-----------------------------------------------------------------------
+!DJG SUBROUTINE JULDAY_CALC
+!DJG-----------------------------------------------------------------------
+      subroutine JULDAY_CALC(YYYY,MM,DD,JULDAY)
+
+	implicit none
+	integer,intent(in) :: YYYY,MM,DD
+        integer,intent(out) :: JULDAY
+
+        integer :: resid
+        integer julm(13)
+        DATA JULM/0, 31, 59, 90, 120, 151, 181, 212, 243, 273, &
+           304, 334, 365 /
+
+        integer LPjulm(13)
+        DATA LPJULM/0, 31, 60, 91, 121, 152, 182, 213, 244, 274, &
+           305, 335, 366 /
+
+      resid = MOD(YYYY,4) !Set up leap year check...
+
+      if (resid.ne.0) then    !If not a leap year....
+        JULDAY = JULM(MM) + DD
+      else                    !If a leap year...
+        JULDAY = LPJULM(MM) + DD
+      end if
+
+      RETURN
+      END subroutine JULDAY_CALC
+!DJG-----------------------------------------------------------------------
+!DJG END SUBROUTINE JULDAY
+!DJG-----------------------------------------------------------------------
+
+!DJG-----------------------------------------------------------------------
+!DJG SUBROUTINE SLOPE_ASPECT
+!DJG-----------------------------------------------------------------------
+	subroutine SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI)
+
+	implicit none
+        integer, INTENT(IN)		   :: IX,JX
+!	real,INTENT(in),DIMENSION(IX,JX)   :: TSLP  !terrain slope (m/m)
+	real,INTENT(OUT),DIMENSION(IX,JX)   :: TAZI  !terrain aspect (deg)
+
+        INTEGER, DIMENSION(IX,JX,3)   :: SO8LD_D
+	real :: DGRD
+	integer :: i,j
+
+!	TSLP = 0.  !Initialize as flat
+	TAZI = 0.  !Initialize as north facing
+
+! Find steepest descent slope and direction...
+        do j=1,JX
+          do i=1,IX
+!	TSLP(I,J) = TANH(Vmax(i,j)) ! calculate slope in radians...
+
+! Convert steepest slope and aspect to radians...
+        IF (SO8LD_D(i,j,3).eq.1) then
+          TAZI(I,J) = 0.0
+        ELSEIF (SO8LD_D(i,j,3).eq.2) then
+          TAZI(I,J) = 45.0
+        ELSEIF (SO8LD_D(i,j,3).eq.3) then
+          TAZI(I,J) = 90.0
+        ELSEIF (SO8LD_D(i,j,3).eq.4) then
+          TAZI(I,J) = 135.0
+        ELSEIF (SO8LD_D(i,j,3).eq.5) then
+          TAZI(I,J) = 180.0
+        ELSEIF (SO8LD_D(i,j,3).eq.6) then
+          TAZI(I,J) = 225.0
+        ELSEIF (SO8LD_D(i,j,3).eq.7) then
+          TAZI(I,J) = 270.0
+        ELSEIF (SO8LD_D(i,j,3).eq.8) then
+          TAZI(I,J) = 315.0
+	END IF
+
+        DGRD = 3.141593/180.
+	TAZI(I,J) = TAZI(I,J)*DGRD ! convert azimuth to radians...
+
+        END DO
+      END DO
+
+      RETURN
+      END  subroutine SLOPE_ASPECT
+!DJG-----------------------------------------------------------------------
+!DJG END SUBROUTINE SLOPE_ASPECT
+!DJG-----------------------------------------------------------------------
+
+!DJG----------------------------------------------------------------
+!DJG    SUBROUTINE SOLSUB
+!DJG----------------------------------------------------------------
+        SUBROUTINE SOLSUB(LONG,LAT,AZ,IN,SC,YY,MO,IDA,IHR,MM,OUT1, &
+                          OUT2,OUT3,INCADJ)
+
+
+! Notes....
+
+        implicit none
+          logical               :: daily, first
+          integer               :: yy,mo,ida,ihr,mm,d
+          integer,dimension(12) :: nday
+          real                  :: lat,long,longcor,longsun,in,inslo
+          real :: az,sc,out1,out2,out3,cosbeta,dzero,eccent,pi,calint
+          real :: rtod,decmax,omega,onehr,omd,omdzero,rdvecsq,sdec
+          real :: declin,cdec,arg,declon,sr,stdmrdn,b,em,timnoon,azslo
+          real :: slat,clat,caz,saz,sinc,cinc,hinc,h,cosz,extra,extslo
+          real :: t1,z,cosa,a,cosbeta_flat,INCADJ
+          integer :: HHTIME,MMTIME,i,ik
+          real, dimension(4) :: ACOF,BCOF
+
+! Constants
+       daily=.FALSE.
+       ACOF(1) = 0.00839
+       ACOF(2) = -0.05391
+       ACOF(3) = -0.00154
+       ACOF(4) = -0.0022
+       BCOF(1) = -0.12193
+       BCOF(2) = -0.15699
+       BCOF(3) = -0.00657
+       BCOF(4) = -0.00370
+       DZERO = 80.
+       ECCENT = 0.0167
+       PI = 3.14159
+       CALINT = 1.
+       RTOD = PI / 180.
+       DECMAX=(23.+26./60.)*RTOD
+       OMEGA=2*PI/365.
+       ONEHR=15.*RTOD
+
+! Calculate Julian Day...
+       D = 0
+       call JULDAY_CALC(YY,MO,IDA,D)
+
+! Ratio of radius vectors squared...
+       OMD=OMEGA*D
+       OMDZERO=OMEGA*DZERO
+!       RDVECSQ=1./(1.-ECCENT*COS(OMD))**2
+       RDVECSQ = 1.    ! no adjustment for orbital changes when coupled to HRLDAS...
+
+! Declination of sun...
+       LONGSUN=OMEGA*(D-Dzero)+2.*ECCENT*(SIN(OMD)-SIN(OMDZERO))
+       DECLIN=ASIN(SIN(DECMAX)*SIN(LONGSUN))
+       SDEC=SIN(DECLIN)
+       CDEC=COS(DECLIN)
+
+! Check for Polar Day/night...
+       ARG=((PI/2.)-ABS(DECLIN))/RTOD
+       IF(ABS(LAT).GT.ARG) THEN
+         IF((LAT.GT.0..AND.DECLIN.LT.0) .OR.       &
+             (LAT.LT.0..AND.DECLON.GT.0.)) THEN
+               OUT1 = 0.
+               OUT2 = 0.
+               OUT3 = 0.
+               RETURN
+         ENDIF
+         SR=-1.*PI
+       ELSE
+
+! Calculate sunrise hour angle...
+         SR=-1.*ABS(ACOS(-1.*TAN(LAT*RTOD)*TAN(DECLIN)))
+       END IF
+
+! Find standard meridian for site
+       STDMRDN=NINT(LONG/15.)*15.
+       LONGCOR=(LONG-STDMRDN)/15.
+
+! Compute time correction from equation of time...
+       B=2.*PI*(D-.4)/365
+       EM=0.
+       DO I=1,4
+         EM=EM+(BCOF(I)*SIN(I*B)+ACOF(I)*COS(I*B))
+       END DO
+
+! Compute time of solar noon...
+       TIMNOON=12.-EM-LONGCOR
+
+! Set up a few more terms...
+       AZSLO=AZ*RTOD
+       INSLO=IN*RTOD
+       SLAT=SIN(LAT*RTOD)
+       CLAT=COS(LAT*RTOD)
+       CAZ=COS(AZSLO)
+       SAZ=SIN(AZSLO)
+       SINC=SIN(INSLO)
+       CINC=COS(INSLO)
+
+! Begin solar radiation calculations...daily first, else instantaneous...
+       IF (DAILY) THEN   ! compute daily integrated values...(Not used in HRLDAS!)
+         IHR=0
+         MM=0
+         HINC=CALINT*ONEHR/60.
+         IK=(2.*ABS(SR)/HINC)+2.
+         FIRST=.TRUE.
+         OUT1=0.
+         DO I=1,IK
+           H=SR+HINC*FLOAT(I-1)
+           COSZ=SLAT*SDEC+CLAT*CDEC*COS(H)
+           COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- &
+                SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ &
+                SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC)
+           EXTRA=SC*RDVECSQ*COSZ
+           IF(EXTRA.LE.0.) EXTRA=0.
+           EXTSLO=SC*RDVECSQ*COSBETA
+           IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0.
+           IF(FIRST .AND. EXTSLO.GT.0.) THEN
+             OUT2=(H-HINC)/ONEHR+TIMNOON
+             FIRST = .FALSE.
+           END IF
+           IF(.NOT.FIRST .AND. EXTSLO.LE.0.) OUT3=H/ONEHR+TIMNOON
+           OUT1=EXTSLO+OUT1
+         END DO
+         OUT1=OUT1*CALINT*60./1000000.
+
+       ELSE   ! Compute instantaneous values...(Is used in HRLDAS!)
+
+         T1=FLOAT(IHR)+FLOAT(MM)/60.
+         H=ONEHR*(T1-TIMNOON)
+         COSZ=SLAT*SDEC+CLAT*CDEC*COS(H)
+
+! Assuming HRLDAS forcing already accounts for season, time of day etc,
+! subtract out the component of adjustment that would occur for
+! a flat surface, this should leave only the sloped component remaining
+
+         COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)-  &
+              SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ &
+              SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC)
+
+         COSBETA_FLAT=CDEC*CLAT*COS(H)+SDEC*SLAT
+
+         INCADJ = COSBETA+(1-COSBETA_FLAT)
+
+         EXTRA=SC*RDVECSQ*COSZ
+         IF(EXTRA.LE.0.) EXTRA=0.
+         EXTSLO=SC*RDVECSQ*INCADJ
+!         IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0.  !remove check for HRLDAS.
+         OUT1=EXTSLO
+         Z=ACOS(COSZ)
+         COSA=(SLAT*COSZ-SDEC)/(CLAT*SIN(Z))
+         IF(COSA.LT.-1.) COSA=-1.
+         IF(COSA.GT.1.) COSA=1.
+         A=ABS(ACOS(COSA))
+         IF(H.LT.0.) A=-A
+         OUT2=Z/RTOD
+         OUT3=A/RTOD+180
+
+       END IF    ! End if for daily vs instantaneous values...
+
+!DJG-----------------------------------------------------------------------
+       RETURN
+       END SUBROUTINE SOLSUB
+!DJG-----------------------------------------------------------------------
+       
+       subroutine seq_land_SO8(SO8LD_D,Vmax,TERR,dx,ix,jx)
+         implicit none
+         integer :: ix,jx,i,j
+         REAL, DIMENSION(IX,JX,8)      :: SO8LD
+         INTEGER, DIMENSION(IX,JX,3)   :: SO8LD_D
+         real,DIMENSION(IX,JX)      :: TERR
+         real                       :: dx(ix,jx,9),Vmax(ix,jx)
+         SO8LD_D = -1
+         do j = 2, jx -1
+            do i = 2, ix -1
+               SO8LD(i,j,1) = (TERR(i,j)-TERR(i,j+1))/dx(i,j,1)
+               SO8LD_D(i,j,1) = i
+               SO8LD_D(i,j,2) = j + 1
+               SO8LD_D(i,j,3) = 1
+               Vmax(i,j) = SO8LD(i,j,1)
+
+               SO8LD(i,j,2) = (TERR(i,j)-TERR(i+1,j+1))/DX(i,j,2)
+               if(SO8LD(i,j,2) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i + 1
+                 SO8LD_D(i,j,2) = j + 1
+                 SO8LD_D(i,j,3) = 2
+                 Vmax(i,j) = SO8LD(i,j,2)
+               end if
+               SO8LD(i,j,3) = (TERR(i,j)-TERR(i+1,j))/DX(i,j,3)
+               if(SO8LD(i,j,3) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i + 1
+                 SO8LD_D(i,j,2) = j
+                 SO8LD_D(i,j,3) = 3
+                 Vmax(i,j) = SO8LD(i,j,3)
+               end if
+               SO8LD(i,j,4) = (TERR(i,j)-TERR(i+1,j-1))/DX(i,j,4)
+               if(SO8LD(i,j,4) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i + 1
+                 SO8LD_D(i,j,2) = j - 1
+                 SO8LD_D(i,j,3) = 4
+                 Vmax(i,j) = SO8LD(i,j,4)
+               end if
+               SO8LD(i,j,5) = (TERR(i,j)-TERR(i,j-1))/DX(i,j,5)
+               if(SO8LD(i,j,5) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i
+                 SO8LD_D(i,j,2) = j - 1
+                 SO8LD_D(i,j,3) = 5
+                 Vmax(i,j) = SO8LD(i,j,5)
+               end if
+               SO8LD(i,j,6) = (TERR(i,j)-TERR(i-1,j-1))/DX(i,j,6)
+               if(SO8LD(i,j,6) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i - 1
+                 SO8LD_D(i,j,2) = j - 1
+                 SO8LD_D(i,j,3) = 6
+                 Vmax(i,j) = SO8LD(i,j,6)
+               end if
+               SO8LD(i,j,7) = (TERR(i,j)-TERR(i-1,j))/DX(i,j,7)
+               if(SO8LD(i,j,7) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i - 1
+                 SO8LD_D(i,j,2) = j
+                 SO8LD_D(i,j,3) = 7
+                 Vmax(i,j) = SO8LD(i,j,7)
+               end if
+               SO8LD(i,j,8) = (TERR(i,j)-TERR(i-1,j+1))/DX(i,j,8)
+               if(SO8LD(i,j,8) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i - 1
+                 SO8LD_D(i,j,2) = j + 1
+                 SO8LD_D(i,j,3) = 8
+                 Vmax(i,j) = SO8LD(i,j,8)
+               end if
+             enddo
+          enddo
+          Vmax = TANH(Vmax)    
+          return
+          end  subroutine seq_land_SO8
+
+#ifdef MPP_LAND
+       subroutine MPP_seq_land_SO8(SO8LD_D,Vmax,TERRAIN,dx,ix,jx,&
+         global_nx,global_ny)
+
+         use module_mpp_land, only:  my_id, io_id, &
+              write_io_real,decompose_data_int,decompose_data_real
+
+         implicit none
+         integer,intent(in) :: ix,jx,global_nx,global_ny
+         INTEGER, intent(inout),DIMENSION(IX,JX,3)   :: SO8LD_D
+!         real,intent(in), DIMENSION(IX,JX)   :: TERRAIN
+         real,DIMENSION(IX,JX)   :: TERRAIN
+         real,intent(out),dimension(ix,jx) ::  Vmax
+         real,intent(in)                     :: dx(ix,jx,9)
+         real                     :: g_dx(ix,jx,9)
+
+         real,DIMENSION(global_nx,global_ny)      :: g_TERRAIN
+         real,DIMENSION(global_nx,global_ny)      :: g_Vmax
+         integer,DIMENSION(global_nx,global_ny,3)      :: g_SO8LD_D
+         integer :: k
+
+         g_SO8LD_D = 0
+         g_Vmax    = 0
+       
+         do k = 1, 9 
+            call write_IO_real(dx(:,:,k),g_dx(:,:,k)) 
+         end do
+
+         call write_IO_real(TERRAIN,g_TERRAIN)
+         if(my_id .eq. IO_id) then
+            call seq_land_SO8(g_SO8LD_D,g_Vmax,g_TERRAIN,g_dx,global_nx,global_ny)
+         endif
+          call decompose_data_int(g_SO8LD_D(:,:,3),SO8LD_D(:,:,3))
+          call decompose_data_real(g_Vmax,Vmax)
+         return
+         end subroutine MPP_seq_land_SO8
+
+#endif
+
diff --git a/wrfv2_fire/hydro/Routing/module_GW_baseflow.F b/wrfv2_fire/hydro/Routing/module_GW_baseflow.F
new file mode 100644
index 00000000..c58c2e37
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_GW_baseflow.F
@@ -0,0 +1,809 @@
+module module_GW_baseflow
+
+#ifdef MPP_LAND
+   use module_mpp_land
+#endif
+   implicit none
+
+#include "gw_field_include.inc"
+#include "rt_include.inc"
+#include "namelist.inc"
+contains
+
+!------------------------------------------------------------------------------
+!DJG   Simple GW Bucket Model
+!------------------------------------------------------------------------------
+
+   subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,basns_area,&
+                            gwsubbasmsk, runoff1x, runoff2x, z_gwsubbas, qin_gwsubbas,&
+                            qout_gwsubbas,qinflowbase,gw_strm_msk,gwbas_pix_ct,dist,DT,&
+                            C,ex,z_mx,GWBASESWCRT,OVRTSWCRT)
+   implicit none
+   
+!!!Declarations...
+   integer, intent(in)                               :: ix,jx,ixrt,jxrt
+   integer, intent(in)                               :: numbasns
+   integer, intent(in), dimension(ix,jx)             :: gwsubbasmsk
+   real, intent(in), dimension(ix,jx)                :: runoff2x 
+   real, intent(in), dimension(ix,jx)                :: runoff1x 
+   real, intent(in)                                  :: basns_area(numbasns),dist(ixrt,jxrt,9),DT
+   real, intent(in),dimension(numbasns)              :: C,ex,z_mx
+   real, intent(out),dimension(numbasns)             :: qout_gwsubbas
+   real, intent(out),dimension(numbasns)             :: qin_gwsubbas
+   real, intent(out),dimension(numbasns)             :: z_gwsubbas
+   real, intent(out),dimension(ixrt,jxrt)            :: qinflowbase
+   integer, intent(in),dimension(ixrt,jxrt)          :: gw_strm_msk
+   integer, intent(in)                               :: GWBASESWCRT
+   integer, intent(in)                               :: OVRTSWCRT
+
+   real*8, dimension(numbasns)                      :: sum_perc8,ct_bas8
+   real, dimension(numbasns)                        :: sum_perc
+   real, dimension(numbasns)                        :: net_perc
+
+   real, dimension(numbasns)                        :: ct_bas
+   real, dimension(numbasns)                        :: gwbas_pix_ct
+   integer                                          :: i,j,bas
+   real                                             :: zbastmp
+   character(len=19)				    :: header
+   character(len=1)				    :: jnk
+
+
+!!!Initialize variables...
+   ct_bas8 = 0
+   sum_perc8 = 0.
+   net_perc = 0.
+   qout_gwsubbas = 0.
+   qin_gwsubbas = 0.
+
+
+
+!!!Calculate aggregated percolation from deep runoff into GW basins...
+   do i=1,ix
+     do j=1,jx
+       do bas=1,numbasns
+         if(gwsubbasmsk(i,j).eq.bas) then
+           if(OVRTSWCRT.ne.0) then
+             sum_perc8(bas) = sum_perc8(bas)+runoff2x(i,j)  !Add only drainage to bucket...runoff2x in (mm)
+           else
+             sum_perc8(bas) = sum_perc8(bas)+runoff1x(i,j)+runoff2x(i,j)  !Add sfc water & drainage to bucket...runoff1x and runoff2x in (mm)
+           end if
+           ct_bas8(bas) = ct_bas8(bas) + 1
+         end if
+       end do
+     end do
+   end do
+
+#ifdef MPP_LAND
+   call sum_real8(sum_perc8,numbasns)
+   call sum_real8(ct_bas8,numbasns)
+#endif
+   sum_perc = sum_perc8
+   ct_bas = ct_bas8
+   
+
+
+
+!!!Loop through GW basins to adjust for inflow/outflow
+
+   DO bas=1,numbasns     ! Loop for GW bucket calcs...
+#ifdef MPP_LAND
+     if(ct_bas(bas) .gt. 0) then
+#endif
+
+     net_perc(bas) = sum_perc(bas) / ct_bas(bas)   !units (mm)
+     qin_gwsubbas(bas) = net_perc(bas)/1000. * ct_bas(bas) * basns_area(bas) !units (m^3)
+
+!Adjust level of GW depth...(conceptual GW bucket units (m))
+     z_gwsubbas(bas) = z_gwsubbas(bas) + net_perc(bas) / 1000.0   ! (m)
+     zbastmp = z_gwsubbas(bas)
+
+!Calculate baseflow as a function of GW depth...
+
+     if(GWBASESWCRT.eq.1) then  !active exponential bucket...
+! Assuming and exponential relation between z and Q...
+       qout_gwsubbas(bas) = C(bas)*EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas)) !Exp.model. q_out (m^3/s)
+
+!Adjust level of GW depth...
+       z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT &
+                       / (ct_bas(bas)*basns_area(bas))   !units(m)
+
+
+
+     elseif (GWBASESWCRT.eq.2) then  !Pass through/steady-state bucket
+
+! Assuming a steady-state (inflow=outflow) model...
+       qout_gwsubbas(bas) = qin_gwsubbas(bas)  !steady-state model...(m^3)
+
+
+
+     end if
+
+
+
+#ifdef MPP_LAND
+     endif
+#endif
+   END DO                 ! End loop for GW bucket calcs...
+
+
+
+!!!Distribute basin integrated baseflow to stream pixels as stream 'inflow'...
+
+      qinflowbase = 0.
+
+
+      do i=1,ixrt
+        do j=1,jxrt
+!!!    -simple uniform disaggregation (8.31.06)
+           if (gw_strm_msk(i,j).gt.0) then
+
+            if(GWBASESWCRT.eq.1) then  !calc stream inflow from exponential bucket... (m^3/s to mm)
+             qinflowbase(i,j) = qout_gwsubbas(gw_strm_msk(i,j))*1000.*DT/ &
+                gwbas_pix_ct(gw_strm_msk(i,j))/dist(i,j,9) !(mm)
+
+            elseif (GWBASESWCRT.eq.2) then  !calc stream inflow from passthrough/steady-state bucket (m^3 to mm)
+             qinflowbase(i,j) = qout_gwsubbas(gw_strm_msk(i,j))*1000./ &
+                gwbas_pix_ct(gw_strm_msk(i,j))/dist(i,j,9) !(mm)
+
+            end if
+
+           end if
+        end do
+      end do
+
+
+!!!    - weighted redistribution...(need to pass accum weights (slope) in...)
+!        NOT FINISHED just BASIC framework...
+!         do bas=1,numbasns
+!           do k=1,gwbas_pix_ct(bas)
+!             qinflowbase(i,j) = k*slope
+!           end do
+!         end do
+
+   return
+
+!------------------------------------------------------------------------------
+   End subroutine simp_gw_buck
+!------------------------------------------------------------------------------
+
+
+!------------------------------------------------------------------------------
+!DJG   Wedge-Aquifer Scheme (TBA)
+!------------------------------------------------------------------------------
+
+!------------------------------------------------------------------------------
+!DJG   TOPMODEL Scheme (TBA)
+!------------------------------------------------------------------------------
+#ifdef MPP_LAND
+   subroutine pix_ct_1(in_gw_strm_msk,ixrt,jxrt,gwbas_pix_ct,numbasns)
+      USE module_mpp_land
+      implicit none
+      integer ::    i,j,ixrt,jxrt,numbasns, bas
+      integer,dimension(ixrt,jxrt) :: in_gw_strm_msk
+      integer,dimension(global_rt_nx,global_rt_ny) :: gw_strm_msk
+      real,dimension(numbasns) :: gwbas_pix_ct 
+
+      gw_strm_msk = 0
+      call write_IO_rt_int(in_gw_strm_msk, gw_strm_msk)    
+
+      if(my_id .eq. IO_id) then
+         gwbas_pix_ct = 0.
+         do bas = 1,numbasns  
+         do i=1,global_rt_nx
+           do j=1,global_rt_ny
+             if(gw_strm_msk(i,j) .eq. bas) then
+                gwbas_pix_ct(gw_strm_msk(i,j)) = gwbas_pix_ct(gw_strm_msk(i,j)) &
+                     + 1.0
+             endif
+           end do
+         end do
+         end do
+      end if
+      call mpp_land_bcast_real(numbasns,gwbas_pix_ct)
+
+      return
+   end subroutine pix_ct_1
+#endif
+
+
+!------------------------------------------------------------------------------
+! Benjamin Fersch  2d groundwater model
+!------------------------------------------------------------------------------
+   subroutine gw2d_ini(did,dt,dx)
+     use module_GW_baseflow_data, only: gw2d
+     implicit none
+     integer did
+     real dt,dx
+
+	   gw2d(did)%dx=dx
+           gw2d(did)%dt=dt
+           ! bftodo: develop proper landtype mask
+           
+           gw2d(did)%compres=0. ! currently not implemented
+
+   return
+   end subroutine gw2d_ini
+
+   subroutine gw2d_allocate(did, ix, jx, nsoil)
+      use module_GW_baseflow_data, only: gw2d
+      implicit none
+      integer ix, jx, nsoil
+      integer istatus, did
+      
+      if(gw2d(did)%allo_status .eq. 1) return
+      gw2d(did)%allo_status = 1
+      
+      gw2d(did)%ix = ix
+      gw2d(did)%jx = jx
+
+
+      allocate(gw2d(did)%ltype  (ix,jx))
+      allocate(gw2d(did)%elev   (ix,jx))
+      allocate(gw2d(did)%bot    (ix,jx))
+      allocate(gw2d(did)%hycond (ix,jx))
+      allocate(gw2d(did)%poros  (ix,jx))
+      allocate(gw2d(did)%compres(ix,jx))
+      allocate(gw2d(did)%ho     (ix,jx))
+      allocate(gw2d(did)%h      (ix,jx))
+      allocate(gw2d(did)%convgw (ix,jx))
+!       allocate(gw2d(did)% (ix,jx))
+
+    end subroutine gw2d_allocate
+
+
+    subroutine gwstep(ix, jx, dx,              &
+		      ltype, elev, bot,        &
+		      hycond, poros, compres,  &
+                      ho, h, convgw,           &
+                      ebot, eocn,              &
+		      dt, istep)
+! #else
+!           dx, istep, dt,                          &        !supplied
+!           ims,ime,jms,jme,its,ite,jts,jte,           &        !supplied
+!           ids,ide,jds,jde,ifs,ife,jfs,jfe)                    !supplied
+! #endif
+
+! New (volug): calling routines use change in head, convgw = d(h-ho)/dt.
+
+! Steps ground-water hydrology (head) through one timestep.
+! Modified from Prickett and Lonnquist (1971), basic one-layer aquifer 
+! simulation program, with mods by Zhongbo Yu(1997).
+! Solves S.dh/dt = d/dx(T.dh/dx) + d/dy(T.dh/dy) + "external sources"
+! for a single layer, where h is head, S is storage coeff and T is 
+! transmissivity. 3-D arrays in main program (hycond,poros,h,bot)
+! are 2-D here, since only a single (uppermost) layer is solved.
+! Uses an iterative time-implicit ADI method.
+
+! use module_hms_constants
+
+
+
+      integer, intent(in) :: ix, jx
+
+      integer, intent(in), dimension(ix,jx) ::  ltype     ! land-sfc type  (supp)
+      real,    intent(in), dimension(ix,jx) ::  &
+        elev,           &  ! elev/bathymetry of sfc rel to sl (m) (supp)
+        bot,            &  ! elev. aquifer bottom rel to sl (m)   (supp)
+        hycond,         &  ! hydraulic conductivity (m/s per m/m) (supp)
+        poros,          &  ! porosity (m3/m3)                     (supp)
+        compres,        &  ! compressibility (1/Pa)               (supp)
+        ho                 ! head at start of timestep (m)        (supp)
+
+      real,    intent(inout), dimension(ix,jx) ::  &
+        h,              &  ! head, after ghmcompute (m)           (ret)
+        convgw             ! convergence due to gw flow (m/s)     (ret)
+
+      real, intent(inout) :: ebot, eocn
+     
+
+
+      integer ::  istep !, dt
+      real, intent(in) :: dt, dx
+
+! #endif      
+!       eocn  = mean spurious sink for h_ocn = sealev fix (m/s)(ret)
+!               This equals the total ground-water flow across 
+!               land->ocean boundaries.
+!       ebot  = mean spurious source for "bot" fix (m/s) (returned)
+!       time  = elapsed time from start of run (sec)
+!       dt = timestep length (sec)
+!       istep = timestep counter
+
+! Local arrays:
+
+      real, dimension(ix,jx)   :: sf2    ! storage coefficient (m3 of h2o / bulk m3)
+      real, dimension(ix,jx,2) ::   t    ! transmissivity (m2/s)..1 for N-S,..2 for E-W
+      real, dimension(0:ix+jx) :: b,g    ! work arrays
+
+
+      real, parameter    :: botinc = 0.01  ! re-wetting increment to fix h < bot
+!     parameter (botinc = 0.  )  ! re-wetting increment to fix h < bot
+                                 ! (m); else no flow into dry cells
+      real, parameter    :: delskip = 0.005 ! av.|dhead| value for iter.skip out(m)
+      integer, parameter :: itermax = 10    ! maximum number of iterations
+      integer, parameter :: itermin = 3     ! minimum number of iterations
+      real, parameter    :: sealev = -1.     ! sea-level elevation (m)
+
+
+! die müssen noch sortiert, geprüft und aufgeräumt werden
+      integer ::                &
+        iter,                   &
+        j,                      &
+        i,                      &
+        jp,                     &
+        ip,                     &
+        ii,                     &
+        n,                      &
+        jj,                     &
+        ierr,                   &
+        ier
+        
+!       real :: su, sc, shp, bb, aa, cc, w, zz, tareal, dtoa, dtot
+      real ::                   &
+        dy,                     &
+        e,                      &
+        su,                     &
+        sc,                     &
+        shp,                    &
+        bb,                     &
+        dd,                     &
+        aa,                     &
+        cc,                     &
+        w,                      &
+        ha,                     &
+        delcur,                 &
+        dtot,                   &
+        dtoa,                   &
+        darea,                  &
+        tareal,                 &
+        zz
+
+#ifdef MPP_LAND
+      real mpiDelcur
+      integer mpiSize
+#endif
+
+      dy = dx
+      darea = dx*dy
+      
+      
+      call scopy (ix*jx, ho, 1, h, 1)
+
+!       Top of iterative loop for ADI solution
+
+      iter = 0
+!~~~~~~~~~~~~~
+   80 continue
+!~~~~~~~~~~~~~
+      iter = iter+1
+      
+#ifdef MPP_LAND
+       call MPP_LAND_COM_REAL(h, ix, jx, 99)
+#endif
+
+      e    = 0.       ! absolute changes in head (for iteration control)
+!      eocn = 0.       ! accumulated fixes for h = 0 over ocean (diag)
+!      ebot = 0.       ! accumulated fixes for h < bot (diagnostic)
+
+!       Set storage coefficient (sf2)
+      
+! #ifdef HMSWRF
+! 
+       tareal = 0.
+! 
+!       do j=jfs,jfe
+!         do i=ifs,ife
+! 
+! 
+! #else
+      do j=1,jx
+        do i=1,ix
+         if(ltype(i,j) .ge. 1) tareal = tareal + darea
+
+! #endif
+!         unconfined water table (h < e): V = poros*(h-b)
+!                                         dV/dh = poros
+!         saturated to surface (h >= e) : V = poros*(e-b) + (h-e)
+!                                         dV/dh = 1
+!         (compressibility is ignored)
+!
+!         su = poros(i,j)*(1.-theta(i,j))    ! old (pre-volug)
+          su = poros(i,j)                    ! new (volug)
+          sc = 1.
+ 
+          if      (ho(i,j).le.elev(i,j) .and. h(i,j).le.elev(i,j)) then
+            sf2(i,j) = su
+          else if (ho(i,j).ge.elev(i,j) .and. h(i,j).ge.elev(i,j)) then
+            sf2(i,j) = sc
+          else if (ho(i,j).le.elev(i,j) .and. h(i,j).ge.elev(i,j)) then
+            shp = sf2(i,j) * (h(i,j) - ho(i,j))
+            sf2(i,j) = shp * sc / (shp - (su-sc)*(elev(i,j)-ho(i,j)))
+          else if (ho(i,j).ge.elev(i,j) .and. h(i,j).le.elev(i,j)) then
+            shp = sf2(i,j) * (ho(i,j) - h(i,j))
+            sf2(i,j) = shp * su / (shp + (su-sc)*(ho(i,j)-elev(i,j)))
+          endif
+
+        enddo
+      enddo
+      
+#ifdef MPP_LAND
+       ! communicate storage coefficient
+       call MPP_LAND_COM_REAL(sf2, ix, jx, 99)
+
+#endif
+
+
+!==========================
+!       Column calculations
+!==========================
+
+!       Set transmissivities. Use min(h,elev)-bot instead of h-bot,
+!       since if h > elev, thickness of groundwater flow is just
+!       elev-bot.
+
+! #ifdef HMSWRF
+! 
+!       do j=jfs,jfe
+!         jp = min (j+1,jfe)
+!         do i=ifs,ife
+!           ip = min (i+1,ife)
+! 
+! #else
+
+      do j=1,jx
+        jp = min (j+1,jx)
+        do i=1,ix
+          ip = min (i+1,ix)
+
+! #endif
+          t(i,j,2) = sqrt( abs(                                           &
+                        hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j))  &
+                       *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j))  &
+                         )    )                                           &
+! #ifdef HMSWRF
+                   * (0.5*(dy+dy)) & ! in WRF the dx and dy are usually equal
+                   / (0.5*(dx+dx))
+! #else
+!                    * (0.5*(dy(i,j)+dy(ip,j)))  &
+!                    / (0.5*(dx(i,j)+dx(ip,j)))
+! #endif
+
+          t(i,j,1) = sqrt( abs(                                           &
+                        hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j ))  &
+                       *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp))  &
+                         )    )                                           &
+! #ifdef HMSWRF
+                   * (0.5*(dx+dx))  &
+                   / (0.5*(dy+dy))
+! #else
+!                    * (0.5*(dx(i,j)+dx(i,jp))) &
+!                    / (0.5*(dy(i,j)+dy(i,jp)))
+! #endif
+        enddo
+      enddo
+
+#ifdef MPP_LAND
+      ! communicate transmissivities in x and y direction
+       call MPP_LAND_COM_REAL(t(:,:,1), ix, jx, 99)
+       call MPP_LAND_COM_REAL(t(:,:,2), ix, jx, 99)
+#endif
+      b = 0.
+      g = 0.
+
+!-------------------
+      do 190 ii=1,ix
+!-------------------
+        i=ii
+        if (mod(istep+iter,2).eq.1) i=ix-i+1
+
+!          calculate b and g arrays
+
+!>>>>>>>>>>>>>>>>>>>>
+        do 170 j=1,jx
+!>>>>>>>>>>>>>>>>>>>>
+!           bb = (sf2(i,j)/dt) * darea(i,j)
+!           dd = ( ho(i,j)*sf2(i,j)/dt ) * darea(i,j)
+          bb = (sf2(i,j)/dt) * darea
+          dd = ( ho(i,j)*sf2(i,j)/dt ) * darea
+          aa = 0.0
+          cc = 0.0
+
+          if (j-1) 90,100,90 
+   90     aa = -t(i,j-1,1)
+          bb = bb + t(i,j-1,1)
+
+  100     if (j-jx) 110,120,110
+  110     cc = -t(i,j,1)
+          bb = bb + t(i,j,1)
+
+  120     if (i-1) 130,140,130
+  130     bb = bb + t(i-1,j,2)
+          dd = dd + h(i-1,j)*t(i-1,j,2)
+
+  140     if (i-ix) 150,160,150
+  150     bb = bb + t(i,j,2)
+          dd = dd + h(i+1,j)*t(i,j,2)
+
+  160     w = bb - aa*b(j-1)
+          b(j) = cc/w
+          g(j) = (dd-aa*g(j-1))/w
+!>>>>>>>>>>>>>>>
+  170   continue
+!>>>>>>>>>>>>>>>
+
+!          re-estimate heads
+
+        e = e + abs(h(i,jx)-g(jx))
+        h(i,jx) = g(jx)
+        n = jx-1
+  180   if (n.eq.0) goto 185
+        ha = g(n) - b(n)*h(i,n+1)
+        e = e + abs(ha-h(i,n))
+        h(i,n) = ha
+        n = n-1
+        goto 180
+  185   continue
+
+!-------------
+  190 continue
+!-------------
+
+#ifdef MPP_LAND
+       call MPP_LAND_COM_REAL(h, ix, jx, 99)
+#endif
+
+
+!=======================
+!       Row calculations
+!=======================
+
+!       set transmissivities (same as above)
+
+      do j=1,jx
+        jp = min (j+1,jx)
+        do i=1,ix
+          ip = min (i+1,ix)
+          t(i,j,2) = sqrt( abs(                                             &
+                        hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j))    &
+                       *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j))    &
+                         )    )                                             &
+!                    * (0.5*(dy(i,j)+dy(ip,j)))                               &
+!                    / (0.5*(dx(i,j)+dx(ip,j)))
+                   * (0.5*(dy+dy))                               &
+                   / (0.5*(dx+dx))
+
+          t(i,j,1) = sqrt( abs(                                             &
+                        hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j ))    &
+                       *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp))    &
+                         )    )                                             &
+                   * (0.5*(dx+dx))                               &
+                   / (0.5*(dy+dy))
+        enddo
+      enddo
+      
+#ifdef MPP_LAND
+      ! communicate transmissivities in x and y direction
+       call MPP_LAND_COM_REAL(t(:,:,1), ix, jx, 99)
+       call MPP_LAND_COM_REAL(t(:,:,2), ix, jx, 99)
+#endif
+      b = 0.
+      g = 0.
+
+!-------------------
+      do 300 jj=1,jx
+!-------------------
+        j=jj
+        if (mod(istep+iter,2).eq.1) j = jx-j+1
+
+!         calculate b and g arrays
+
+!>>>>>>>>>>>>>>>>>>>>
+        do 280 i=1,ix
+!>>>>>>>>>>>>>>>>>>>>
+!           bb = (sf2(i,j)/dt) * darea(i,j)
+!           dd = ( ho(i,j)*sf2(i,j)/dt ) * darea(i,j)
+          bb = (sf2(i,j)/dt) * darea
+          dd = ( ho(i,j)*sf2(i,j)/dt ) * darea
+          aa = 0.0
+          cc = 0.0
+
+          if (j-1) 200,210,200
+  200     bb = bb + t(i,j-1,1)
+          dd = dd + h(i,j-1)*t(i,j-1,1)
+
+  210     if (j-jx) 220,230,220
+  220     dd = dd + h(i,j+1)*t(i,j,1)
+          bb = bb + t(i,j,1)
+
+  230     if (i-1) 240,250,240
+  240     bb = bb + t(i-1,j,2)
+          aa = -t(i-1,j,2)
+
+  250     if (i-ix) 260,270,260
+  260     bb = bb + t(i,j,2)
+          cc = -t(i,j,2)
+
+  270     w = bb - aa*b(i-1)
+          b(i) = cc/w
+          g(i) = (dd-aa*g(i-1))/w
+!>>>>>>>>>>>>>>>
+  280   continue
+!>>>>>>>>>>>>>>>
+
+!          re-estimate heads
+
+        e = e + abs(h(ix,j)-g(ix))
+        h(ix,j) = g(ix)
+        n = ix-1
+  290   if (n.eq.0) goto 295
+        ha = g(n)-b(n)*h(n+1,j)
+        e = e + abs(h(n,j)-ha)
+        h(n,j) = ha
+        n = n-1
+        goto 290
+  295   continue
+
+!-------------
+  300 continue
+!-------------
+
+!         fix head < bottom of aquifer
+! #endif
+! 
+! #ifdef HMSWRF
+! 
+!       do j=jfs,jfe
+!         do i=ifs,ife
+! 
+! #else
+      do j=1,jx
+        do i=1,ix
+! #endif
+          if (ltype(i,j).eq.1 .and. h(i,j).le.bot(i,j)+botinc) then
+
+! #ifndef HMSWRF
+            e = e +  bot(i,j) + botinc - h(i,j)
+!             ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea(i,j)
+            ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea
+! #endif
+
+            h(i,j) = bot(i,j) + botinc
+          endif
+        enddo
+      enddo
+!        maintain head = sea level for ocean (only for adjacent ocean,
+!        rest has hycond=0)
+
+! #ifdef HMSWRF
+! 
+!       do j=jfs,jfe
+!         do i=its,ife
+! 
+! #else
+      do j=1,jx
+        do i=1,ix
+! #endif
+          if (ltype(i,j).eq.2) then
+! #ifndef HMSWRF
+            eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea
+!             eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea(i,j)
+! #endif
+            h(i,j) = sealev
+          endif
+        enddo
+      enddo
+
+!        Loop back for next ADI iteration
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+! #ifdef HMSWRF
+!       delcur = e/(xdim*ydim)
+! #else
+      delcur = e/(ix*jx)
+! #endif
+
+#ifdef MPP_LAND
+
+call mpi_reduce(delcur, mpiDelcur, 1, MPI_REAL, MPI_SUM, 0, MPI_COMM_WORLD, ierr)
+call MPI_COMM_SIZE( MPI_COMM_WORLD, mpiSize, ierr ) 
+
+mpiDelcur = mpiDelcur/mpiSize
+
+call mpi_bcast(delcur, 1, mpi_real, 0, MPI_COMM_WORLD, ierr)
+
+#endif
+
+      if ( (delcur.gt.delskip*dt/86400. .and. iter.lt.itermax)      &
+           .or. iter.lt.itermin ) then
+        goto 80
+      else
+      endif
+
+      
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+!        Compute convergence rate due to ground water flow (returned)
+
+! #ifdef HMSWRF
+! 
+!       do j=jfs,jfe
+!         do i=ifs,ife
+! 
+! #else
+      do j=1,jx
+        do i=1,ix
+! #endif
+          if (ltype(i,j).eq.1) then
+            convgw(i,j) = sf2(i,j) * (h(i,j)-ho(i,j)) / dt
+          else
+            convgw(i,j) = 0.
+          endif
+        enddo
+      enddo
+
+!        Diagnostic water conservation check for this timestep
+
+      dtot = 0.     ! total change in water storage (m3)
+      dtoa = 0.
+
+! #ifdef HMSWRF
+! 
+!       do j=jts,jte
+!         do i=its,ite
+! 
+! #else
+      do j=1,jx
+        do i=1,ix
+! #endif
+          if (ltype(i,j).eq.1) then
+! #ifdef HMSWRF
+            dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea
+            dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea
+! #else
+!             dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea(i,j)
+!             dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea(i,j)
+! #endif
+          endif
+        enddo
+      enddo
+
+      dtot = (dtot/tareal)/dt   ! convert to m/s, rel to land area
+      dtoa = (dtoa/tareal)/dt
+      eocn = (eocn/tareal)/dt
+      ebot = (ebot/tareal)/dt
+
+      zz = 1.e3 * 86400.                    ! convert printout to mm/day
+#ifdef HYDRO_D
+        write (*,900)                         &
+          dtot*zz, dtoa*zz, -eocn*zz, ebot*zz,     &
+          (dtot-(-eocn+ebot))*zz
+#endif
+  900 format                                       &
+        (3x,'    dh/dt       |dh/dt|        ocnflx        botfix',&
+            '                  ','      ghmerror'  &
+!         /3x,4f9.4,2(9x),e14.4)
+        /3x,5(e14.4))
+      
+      return
+      end subroutine gwstep
+      
+      
+      SUBROUTINE SCOPY (NT, ARR, INCA, BRR, INCB)
+!
+!        Copies array ARR to BRR, incrementing by INCA and INCB
+!        respectively, up to a total length of NT words of ARR.
+!        (Same as Cray SCOPY.)
+!
+      real, DIMENSION(*) :: ARR, BRR
+      integer :: ia, nt, inca, incb, ib
+!
+      IB = 1
+      DO 10 IA=1,NT,INCA
+         BRR(IB) = ARR(IA)
+         IB = IB + INCB
+   10 CONTINUE
+!
+      RETURN
+      END SUBROUTINE SCOPY
+
+end module module_GW_baseflow   
diff --git a/wrfv2_fire/hydro/Routing/module_HYDRO_io.F b/wrfv2_fire/hydro/Routing/module_HYDRO_io.F
new file mode 100644
index 00000000..6b68dce6
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_HYDRO_io.F
@@ -0,0 +1,5114 @@
+module module_HYDRO_io
+#ifdef MPP_LAND
+     use module_mpp_land
+#endif
+   use module_HYDRO_utils, only: get_dist_ll
+   use module_namelist, only: nlst_rt
+   use module_RT_data, only: rt_domain
+
+   implicit none
+#include 
+
+     contains
+        integer function get2d_real(var_name,out_buff,ix,jx,fileName)
+          implicit none
+          integer :: ivar, iret,varid,ncid,ix,jx
+          real out_buff(ix,jx)
+          character(len=*), intent(in) :: var_name
+          character(len=*), intent(in) :: fileName
+          get2d_real = -1
+
+          iret = nf_open(trim(fileName), NF_NOWRITE, ncid)
+          if (iret .ne. 0) then
+#ifdef HYDRO_D 
+            print*,"failed to open the netcdf file: ",trim(fileName)
+#endif
+            out_buff = -9999.
+            return 
+          endif
+          ivar = nf_inq_varid(ncid,trim(var_name),  varid)
+          if(ivar .ne. 0) then
+            ivar = nf_inq_varid(ncid,trim(var_name//"_M"),  varid)
+            if(ivar .ne. 0) then
+#ifdef HYDRO_D
+               write(6,*) "Read Variable Error file: ",trim(fileName)
+               write(6,*) "Read Error: could not find ",trim(var_name)
+#endif
+                 return 
+            endif
+          end if
+          iret = nf_get_var_real(ncid, varid, out_buff)
+          iret = nf_close(ncid)
+          get2d_real =  ivar
+      end function get2d_real
+     
+     subroutine get2d_lsm_real(var_name,out_buff,ix,jx,fileName)
+         implicit none
+         integer ix,jx, status
+         character (len=*),intent(in) :: var_name, fileName
+         real,dimension(ix,jx):: out_buff
+#ifdef MPP_LAND
+         real,allocatable, dimension(:,:) :: buff_g
+
+#ifdef HYDRO_D
+         write(6,*) "start to read variable ", var_name
+#endif
+         allocate(buff_g (global_nx,global_ny) )
+
+         if(my_id .eq. IO_id) then
+            status = get2d_real(var_name,buff_g,global_nx,global_ny,fileName)
+         end if
+         call decompose_data_real(buff_g,out_buff)     
+         deallocate(buff_g)
+#else         
+         status = get2d_real(var_name,out_buff,ix,jx,fileName)
+#endif
+#ifdef HYDRO_D
+         write(6,*) "finish reading variable ", var_name
+#endif
+     end subroutine get2d_lsm_real
+
+     subroutine get2d_lsm_vegtyp(out_buff,ix,jx,fileName)
+         implicit none
+         integer ix,jx, status,land_cat, iret, dimid,ncid
+         character (len=*),intent(in) :: fileName
+         character (len=256) units 
+         integer,dimension(ix,jx):: out_buff
+         real, dimension(ix,jx) :: xdum
+#ifdef MPP_LAND
+         real,allocatable, dimension(:,:) :: buff_g
+
+         allocate(buff_g (global_nx,global_ny) )
+
+         if(my_id .eq. IO_id) then
+#endif
+                ! Open the NetCDF file.
+              iret = nf_open(fileName, NF_NOWRITE, ncid)
+              if (iret /= 0) then
+#ifdef HYDRO_D
+                 write(*,'("Problem opening geo_static file: ''", A, "''")') &
+                      trim(fileName)
+                 call hydro_stop()
+#endif
+              endif
+
+            iret = nf_inq_dimid(ncid, "land_cat", dimid)
+            if (iret /= 0) then
+#ifdef HYDRO_D
+              print*, "nf_inq_dimid:  land_cat"
+              call hydro_stop()
+#endif
+             endif
+
+            iret = nf_inq_dimlen(ncid, dimid, land_cat)
+            if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, "nf_inq_dimlen:  land_cat"
+               call hydro_stop()
+#endif
+            endif
+
+#ifdef MPP_LAND
+            call get_landuse_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat)
+            iret = nf_close(ncid)
+         end if
+
+         call decompose_data_real(buff_g,xdum)     
+         deallocate(buff_g)
+#else         
+          call get_landuse_netcdf(ncid, xdum,   units, ix, jx, land_cat)
+          iret = nf_close(ncid)
+#endif
+         out_buff = nint(xdum)
+     end subroutine get2d_lsm_vegtyp
+
+     subroutine get_file_dimension(fileName, ix,jx)
+            implicit none
+            character(len=*) fileName
+            integer ncid , iret, ix,jx, dimid
+#ifdef MPP_LAND
+            if(my_id .eq. IO_id) then
+#endif
+            iret = nf_open(fileName, NF_NOWRITE, ncid)
+            if (iret /= 0) then
+#ifdef HYDRO_D
+               write(*,'("Problem opening geo_static file: ''", A, "''")') &
+                    trim(fileName)
+               call hydro_stop()
+#endif
+            endif
+        
+            iret = nf_inq_dimid(ncid, "west_east", dimid)
+        
+            if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, "nf_inq_dimid:  west_east"
+               call hydro_stop()
+#endif
+            endif
+        
+            iret = nf_inq_dimlen(ncid, dimid, ix)
+            if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, "nf_inq_dimlen:  west_east"
+               call hydro_stop()
+#endif
+            endif
+        
+            iret = nf_inq_dimid(ncid, "south_north", dimid)
+            if (iret /= 0) then
+#ifdef HYDRO_D
+                       print*, "nf_inq_dimid:  south_north"
+                       call hydro_stop()
+#endif
+            endif
+        
+            iret = nf_inq_dimlen(ncid, dimid, jx)
+            if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, "nf_inq_dimlen:  south_north"
+               call hydro_stop()
+#endif
+            endif
+            iret = nf_close(ncid)
+#ifdef MPP_LAND
+            endif
+            call mpp_land_bcast_int1(ix)
+            call mpp_land_bcast_int1(jx)
+#endif
+
+     end subroutine get_file_dimension
+
+     subroutine get2d_lsm_soltyp(out_buff,ix,jx,fileName)
+         implicit none
+         integer ix,jx, status,land_cat, iret, dimid,ncid
+         character (len=*),intent(in) :: fileName
+         character (len=256) units 
+         integer,dimension(ix,jx):: out_buff
+         real, dimension(ix,jx) :: xdum
+#ifdef MPP_LAND
+         real,allocatable, dimension(:,:) :: buff_g
+
+         allocate(buff_g (global_nx,global_ny) )
+
+         if(my_id .eq. IO_id) then
+#endif
+                ! Open the NetCDF file.
+              iret = nf_open(fileName, NF_NOWRITE, ncid)
+              if (iret /= 0) then
+#ifdef HYDRO_D
+                 write(*,'("Problem opening geo_static file: ''", A, "''")') &
+                      trim(fileName)
+                 call hydro_stop()
+#endif
+              endif
+
+            iret = nf_inq_dimid(ncid, "soil_cat", dimid)
+            if (iret /= 0) then
+#ifdef HYDRO_D
+              print*, "nf_inq_dimid:  soil_cat"
+              call hydro_stop()
+#endif
+             endif
+
+            iret = nf_inq_dimlen(ncid, dimid, land_cat)
+            if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, "nf_inq_dimlen:  soil_cat"
+               call hydro_stop()
+#endif
+            endif
+
+#ifdef MPP_LAND
+            call get_soilcat_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat)
+            iret = nf_close(ncid)
+         end if
+
+         call decompose_data_real(buff_g,xdum)     
+         deallocate(buff_g)
+#else         
+          call get_soilcat_netcdf(ncid, xdum,   units, ix, jx, land_cat)
+          iret = nf_close(ncid)
+#endif
+          out_buff = nint(xdum)
+     end subroutine get2d_lsm_soltyp
+
+
+   
+
+
+
+  subroutine get_landuse_netcdf(ncid, array, units, idim, jdim, ldim)
+    implicit none
+#include 
+    integer, intent(in) :: ncid
+    integer, intent(in) :: idim, jdim, ldim
+    real, dimension(idim,jdim), intent(out) :: array
+    character(len=256), intent(out) :: units
+    integer :: iret, varid
+    real, dimension(idim,jdim,ldim) :: xtmp
+    integer, dimension(1) :: mp
+    integer :: i, j, l
+    character(len=24), parameter :: name = "LANDUSEF"
+
+    units = ""
+
+    iret = nf_inq_varid(ncid,  trim(name),  varid)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, 'name = "', trim(name)//'"'
+       print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  get_landuse_netcdf:  nf_inq_varid"
+       call hydro_stop()
+#endif
+    endif
+
+    iret = nf_get_var_real(ncid, varid, xtmp)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, 'name = "', trim(name)//'"'
+       print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  get_landuse_netcdf:  nf_get_var_real"
+       call hydro_stop()
+#endif
+    endif
+
+    do i = 1, idim
+       do j = 1, jdim
+          mp = maxloc(xtmp(i,j,:))
+          array(i,j) = mp(1)
+          do l = 1,ldim
+            if(xtmp(i,j,l).lt.0) array(i,j) = -9999.0
+          enddo
+       enddo
+    enddo
+
+  end subroutine get_landuse_netcdf
+
+
+  subroutine get_soilcat_netcdf(ncid, array, units, idim, jdim, ldim)
+    implicit none
+#include 
+
+    integer, intent(in) :: ncid
+    integer, intent(in) :: idim, jdim, ldim
+    real, dimension(idim,jdim), intent(out) :: array
+    character(len=256), intent(out) :: units
+    integer :: iret, varid
+    real, dimension(idim,jdim,ldim) :: xtmp
+    integer, dimension(1) :: mp
+    integer :: i, j
+    character(len=24), parameter :: name = "SOILCTOP"
+
+    units = ""
+
+    iret = nf_inq_varid(ncid,  trim(name),  varid)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, 'name = "', trim(name)//'"'
+       print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  get_soilcat_netcdf:  nf_inq_varid"
+       call hydro_stop()
+#endif
+    endif
+
+    iret = nf_get_var_real(ncid, varid, xtmp)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, 'name = "', trim(name)//'"'
+       print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  get_soilcat_netcdf:  nf_get_var_real"
+       call hydro_stop()
+#endif
+    endif
+
+    do i = 1, idim
+       do j = 1, jdim
+          mp = maxloc(xtmp(i,j,:))
+          array(i,j) = mp(1)
+       enddo
+    enddo
+
+    where (array == 14) array = 1   ! DJG remove all 'water' soils...
+
+  end subroutine get_soilcat_netcdf
+
+
+subroutine get_greenfrac_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd)
+    implicit none
+#include 
+    integer, intent(in) :: ncid,mm,dd
+    integer, intent(in) :: idim, jdim, ldim
+    real, dimension(idim,jdim) :: array
+    real, dimension(idim,jdim) :: array2
+    real, dimension(idim,jdim) :: diff
+    real, dimension(idim,jdim), intent(out) :: array3
+    character(len=256), intent(out) :: units
+    integer :: iret, varid
+    real, dimension(idim,jdim,ldim) :: xtmp
+    integer, dimension(1) :: mp
+    integer :: i, j, mm2,daytot
+    real :: ddfrac
+    character(len=24), parameter :: name = "GREENFRAC"
+
+    units = "fraction"
+
+    iret = nf_inq_varid(ncid,  trim(name),  varid)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, 'name = "', trim(name)//'"'
+       print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  get_greenfrac_netcdf:  nf_inq_varid"
+       call hydro_stop()
+#endif
+    endif
+
+    iret = nf_get_var_real(ncid, varid, xtmp)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, 'name = "', trim(name)//'"'
+       print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  get_greenfrac_netcdf:  nf_get_var_real"
+       call hydro_stop()
+#endif
+    endif
+
+
+    if (mm.lt.12) then 
+      mm2 = mm+1
+    else
+      mm2 = 1
+    end if
+
+!DJG_DES Set up dates for daily interpolation...
+          if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then
+             daytot = 31
+          else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then 
+             daytot = 30
+          else if (mm.eq.2) then
+             daytot = 28
+          end if
+          ddfrac = float(dd)/float(daytot)
+          if (ddfrac.gt.1.0) ddfrac = 1.0   ! Assumes Feb. 29th change is same as Feb 28th
+
+#ifdef HYDRO_D
+    print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac
+#endif
+
+    do i = 1, idim
+       do j = 1, jdim
+          array(i,j) = xtmp(i,j,mm)   !GREENFRAC in geogrid in units of fraction from month 1
+          array2(i,j) = xtmp(i,j,mm2)   !GREENFRAC in geogrid in units of fraction from month 1
+          diff(i,j) = array2(i,j) - array(i,j)
+          array3(i,j) = array(i,j) + ddfrac * diff(i,j) 
+       enddo
+    enddo
+
+end subroutine get_greenfrac_netcdf
+
+
+
+subroutine get_albedo12m_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd)
+    implicit none
+#include 
+    integer, intent(in) :: ncid,mm,dd
+    integer, intent(in) :: idim, jdim, ldim
+    real, dimension(idim,jdim) :: array
+    real, dimension(idim,jdim) :: array2
+    real, dimension(idim,jdim) :: diff
+    real, dimension(idim,jdim), intent(out) :: array3
+    character(len=256), intent(out) :: units
+    integer :: iret, varid
+    real, dimension(idim,jdim,ldim) :: xtmp
+    integer, dimension(1) :: mp
+    integer :: i, j, mm2,daytot
+    real :: ddfrac
+    character(len=24), parameter :: name = "ALBEDO12M"
+
+
+    units = "fraction"
+
+    iret = nf_inq_varid(ncid,  trim(name),  varid)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, 'name = "', trim(name)//'"'
+       print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  get_albedo12m_netcdf:  nf_inq_varid"
+       call hydro_stop()
+#endif
+    endif
+
+    iret = nf_get_var_real(ncid, varid, xtmp)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, 'name = "', trim(name)//'"'
+       print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  get_albedo12m_netcdf:  nf_get_var_real"
+       call hydro_stop()
+#endif
+    endif
+
+    if (mm.lt.12) then 
+      mm2 = mm+1
+    else
+      mm2 = 1
+    end if
+
+!DJG_DES Set up dates for daily interpolation...
+          if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then
+             daytot = 31
+          else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then 
+             daytot = 30
+          else if (mm.eq.2) then
+             daytot = 28
+          end if
+          ddfrac = float(dd)/float(daytot)
+          if (ddfrac.gt.1.0) ddfrac = 1.0   ! Assumes Feb. 29th change is same as Feb 28th
+
+#ifdef HYDRO_D
+    print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac
+#endif
+
+    do i = 1, idim
+       do j = 1, jdim
+          array(i,j) = xtmp(i,j,mm) / 100.0   !Convert ALBEDO12M from % to fraction...month 1
+          array2(i,j) = xtmp(i,j,mm2) / 100.0   !Convert ALBEDO12M from % to fraction... month 2
+          diff(i,j) = array2(i,j) - array(i,j)
+          array3(i,j) = array(i,j) + ddfrac * diff(i,j) 
+       enddo
+    enddo
+
+end subroutine get_albedo12m_netcdf
+
+
+
+  subroutine get_2d_netcdf(name, ncid, array, units, idim, jdim, &
+       fatal_if_error, ierr)
+    implicit none
+#include 
+    character(len=*), intent(in) :: name
+    integer, intent(in) :: ncid
+    integer, intent(in) :: idim, jdim
+    real, dimension(idim,jdim), intent(out) :: array
+    character(len=256), intent(out) :: units
+    integer :: iret, varid
+    ! .TRUE._IF_ERROR:  an input code value:
+    !      .TRUE. if an error in reading the data should stop the program.
+    !      Otherwise the, IERR error flag is set, but the program continues.
+    logical, intent(in) :: fatal_if_error 
+    integer, intent(out) :: ierr
+
+    units = ""
+
+    iret = nf_inq_varid(ncid,  name,  varid)
+
+    if (iret /= 0) then
+       if (fatal_IF_ERROR) then
+#ifdef HYDRO_D
+          print*, 'name = "', trim(name)//'"'
+          print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  get_2d_netcdf:  nf_inq_varid"
+          call hydro_stop()
+#endif
+       else
+          ierr = iret
+          return
+       endif
+    endif
+
+
+    iret = nf_get_var_real(ncid, varid, array)
+    if (iret /= 0) then
+       if (fatal_IF_ERROR) then
+#ifdef HYDRO_D
+          print*, 'name = "', trim(name)//'"'
+          print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  get_2d_netcdf:  nf_get_var_real"
+          call hydro_stop()
+#endif
+       else
+          ierr = iret
+          return
+       endif
+    endif
+
+    ierr = 0;
+  end subroutine get_2d_netcdf
+
+      subroutine get_2d_netcdf_cows(var_name,ncid,var, &
+            ix,jx,tlevel,fatal_if_error,ierr)
+#include 
+          character(len=*), intent(in) :: var_name
+          integer,intent(in) ::  ncid,ix,jx,tlevel
+          real, intent(out):: var(ix,jx)
+          logical, intent(in) :: fatal_if_error
+          integer ierr, iret
+          integer varid
+          integer start(4),count(4)
+          data count /1,1,1,1/
+          data start /1,1,1,1/
+          count(1) = ix
+          count(2) = jx
+          start(4) = tlevel
+      iret = nf_inq_varid(ncid,  var_name,  varid)
+
+      if (iret /= 0) then
+        if (fatal_IF_ERROR) then
+#ifdef HYDRO_D
+           print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid"
+           call hydro_stop()
+#endif
+        else
+          ierr = iret
+          return
+        endif
+      endif
+      iret = nf_get_vara_real(ncid, varid, start,count,var)
+
+      return
+      end subroutine get_2d_netcdf_cows
+
+!---------------------------------------------------------
+!DJG Subroutinesfor inputting routing fields...
+!DNY   first reads the files to get the size of the 
+!DNY   LINKS arrays
+!DJG   - Currently only hi-res topo is read 
+!DJG   - At a future time, use this routine to input
+!DJG     subgrid land-use classification or routing
+!DJG     parameters 'overland roughness' and 'retention
+!DJG     depth'
+!
+!DJG,DNY - Update this subroutine to read in channel and lake
+!           parameters if activated       11.20.2005
+!---------------------------------------------------------
+       SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, &
+            route_direction_f, route_lake_f, NLINKS, NLAKES, &
+            CH_NETLNK, channel_option, geo_finegrid_flnm)
+
+         implicit none
+#include 
+        INTEGER                                      :: I,J,channel_option,iret,jj
+        INTEGER, INTENT(INOUT)                       :: NLINKS, NLAKES
+        INTEGER, INTENT(IN)                          :: IXRT,JXRT
+        INTEGER                                      :: CHNID,cnt
+        INTEGER, DIMENSION(IXRT,JXRT)                :: CH_NETRT   !- binary channel mask
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK  !- each node gets unique id
+        INTEGER, DIMENSION(IXRT,JXRT)                :: DIRECTION  !- flow direction
+        INTEGER, DIMENSION(IXRT,JXRT)                :: LAKE_MSKRT
+        REAL, DIMENSION(IXRT,JXRT)                   :: LAT, LON
+
+!!Dummy read in grids for inverted y-axis
+        INTEGER, DIMENSION(IXRT,JXRT)                :: CH_NETRT_inv   !- binary channel mask
+        INTEGER, DIMENSION(IXRT,JXRT)                :: DIRECTION_inv  !- flow direction
+        INTEGER, DIMENSION(IXRT,JXRT)                :: LAKE_MSKRT_inv
+        REAL, DIMENSION(IXRT,JXRT)                   :: LAT_inv, LON_inv
+
+
+        CHARACTER(len=*)       :: route_chan_f, route_link_f,route_direction_f,route_lake_f
+        CHARACTER(len=256)       :: InputLine
+        CHARACTER(len=256)       :: geo_finegrid_flnm
+        CHARACTER(len=256)       :: var_name
+!        external get2d_real
+!       integer ::  get2d_real
+     
+        NLINKS = 0
+        NLAKES = 0
+        CH_NETRT = -9999
+        CH_NETLNK = -9999
+
+
+        cnt = 0 
+#ifdef HYDRO_D
+       print *, "Channel Option in Routedim is ", channel_option
+#endif
+
+       IF(channel_option.eq.3) then  !get maxnodes and links from grid
+
+         var_name = "CHANNELGRID"
+         call get2d_int(var_name,CH_NETRT_inv,ixrt,jxrt,&
+                   trim(geo_finegrid_flnm))
+         
+         var_name = "FLOWDIRECTION"
+         call get2d_int(var_name,DIRECTION_inv,ixrt,jxrt,&
+                   trim(geo_finegrid_flnm))
+
+         var_name = "LAKEGRID"
+         call get2d_int(var_name,LAKE_MSKRT_inv,ixrt,jxrt,&
+                   trim(geo_finegrid_flnm))
+
+
+        var_name = "LATITUDE"
+        iret =  get2d_real(var_name,LAT_inv,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+        var_name = "LONGITUDE"
+        iret = get2d_real(var_name,LON_inv,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+
+!!!Flip y-dimension of highres grids from exported Arc files...
+
+
+        do i=1,ixrt
+        jj=jxrt
+         do j=1,jxrt
+           CH_NETRT(i,j)=CH_NETRT_inv(i,jj)
+           DIRECTION(i,j)=DIRECTION_inv(i,jj)
+           LAKE_MSKRT(i,j)=LAKE_MSKRT_inv(i,jj)
+           LAT(i,j)=LAT_inv(i,jj)
+           LON(i,j)=LON_inv(i,jj)
+           jj=jxrt-j
+         end do
+        end do
+          
+! temp fix for buggy Arc export...
+        do j=1,jxrt
+          do i=1,ixrt
+            if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128
+          end do
+        end do
+
+
+!DJG inv         do j=jxrt,1,-1
+         do j=1,jxrt
+             do i = 1, ixrt
+               if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then 
+                 NLINKS = NLINKS + 1
+               endif
+            end do 
+         end do 
+#ifdef HYDRO_D
+         print *, "NLINKS IS ", NLINKS 
+#endif
+
+
+!DJG inv         DO j = JXRT,1,-1  !rows
+         DO j = 1,JXRT  !rows
+          DO i = 1 ,IXRT   !colsumns
+           If (CH_NETRT(i, j) .ge. 0) then !get its direction
+            If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT).AND.(CH_NETRT(i,j+1) .ge.0) ) then !North
+             cnt = cnt + 1
+             CH_NETLNK(i,j) = cnt
+            else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) &
+               .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1) .ge.0)) then !North East
+             cnt = cnt + 1
+             CH_NETLNK(i,j) = cnt
+            else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT).AND.(CH_NETRT(i+1,j) .ge. 0)) then !East
+             cnt = cnt + 1
+             CH_NETLNK(i,j) = cnt 
+            else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) &
+                    .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i+1,j-1).ge.0)) then !south east
+             cnt = cnt + 1
+             CH_NETLNK(i,j) = cnt
+            else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0)) then !due south
+             cnt = cnt + 1
+             CH_NETLNK(i,j) = cnt
+            else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) &
+                    .AND. (j - 1 .NE. 0).AND. (CH_NETRT(i-1,j-1).ge.0) ) then !south west
+             cnt = cnt + 1
+             CH_NETLNK(i,j) = cnt
+            else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0)) then !West
+             cnt = cnt + 1
+             CH_NETLNK(i,j) = cnt
+            else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) &
+                    .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0)) then !North West
+             cnt = cnt + 1
+             CH_NETLNK(i,j) = cnt 
+           else 
+#ifdef HYDRO_D
+             write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j 
+135             FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4)
+#endif
+             if (DIRECTION(i,j) .eq. 0) then
+#ifdef HYDRO_D
+               print *, "Direction i,j ",i,j," of point ", cnt, "is invalid"
+#endif
+             endif
+
+           End If
+         End If !CH_NETRT check for this node
+        END DO
+       END DO 
+#ifdef HYDRO_D
+       print *, "found type 0 nodes", cnt
+#endif
+      
+!Find out if the boundaries are on an edge or flow into a lake
+!DJG inv       DO j = JXRT,1,-1
+       DO j = 1,JXRT
+         DO i = 1 ,IXRT
+          If (CH_NETRT(i, j) .ge. 0) then !get its direction
+
+           If ( ((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT))         & !-- 64's can only flow north
+               .OR. ((DIRECTION(i, j) .EQ. 64).and. (j1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east
+              cnt = cnt + 1
+              CH_NETLNK(i,j) = cnt
+#ifdef HYDRO_D
+              print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j
+#endif
+           else if ( ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0))       &      !-- 4's can only flow due south
+                .OR. ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south
+              cnt = cnt + 1
+              CH_NETLNK(i,j) = cnt
+#ifdef HYDRO_D
+              print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j
+#endif
+           else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0))      &      !-- 8's can flow south or west
+               .OR.  ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0))      &      !-- this is the south edge
+               .OR.  ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west
+              cnt = cnt + 1
+              CH_NETLNK(i,j) = cnt
+#ifdef HYDRO_D
+              print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j
+#endif
+           else if ( ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE. 0))       &      !-- 16's can only flow due west 
+               .OR.  ((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West
+              cnt = cnt + 1
+              CH_NETLNK(i,j) = cnt              
+#ifdef HYDRO_D
+              print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j
+#endif
+           else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0))      &      !-- 32's can flow either west or north
+               .OR.  ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT))   &      !-- this is the north edge
+               .OR.  ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j
+        INTEGER, INTENT(IN)                          :: IXRT,JXRT
+        INTEGER                                      :: CHANRTSWCRT, NLINKS, NLAKES
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)       :: ELRT
+        INTEGER, DIMENSION(IXRT,JXRT)                :: DIRECTION
+        INTEGER, DIMENSION(IXRT,JXRT)                :: GSTRMFRXSTPTS
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT
+        INTEGER,                DIMENSION(IXRT,JXRT) :: GORDER  !-- gridded stream orderk
+        INTEGER,                DIMENSION(IXRT,JXRT) :: Link_Location !-- gridded stream orderk
+        INTEGER                                      :: I,J,channel_option
+        REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)      :: LATVAL, LONVAL
+        CHARACTER(len=28)                            :: dir
+!Dummy inverted grids from arc
+	INTEGER, DIMENSION(IXRT,JXRT)                :: DIRECTION_inv
+        INTEGER, DIMENSION(IXRT,JXRT)                :: GSTRMFRXSTPTS_inv
+        INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT_inv
+        INTEGER,                DIMENSION(IXRT,JXRT) :: GORDER_inv  !-- gridded stream orderk
+        REAL, DIMENSION(IXRT,JXRT)      :: LATVAL_inv, LONVAL_inv
+
+
+!----DJG,DNY New variables for channel and lake routing
+        CHARACTER(len=155)	 :: header
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: FROM_NODE
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: ZELEV
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: CHLAT,CHLON
+
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: TYPEL
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: TO_NODE,ORDER
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: STRMFRXSTPTS
+
+        INTEGER, INTENT(INOUT)                       :: MAXORDER
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: MUSK, MUSX !muskingum
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS,2)    :: QLINK  !channel flow
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: CHANLEN   !channel length
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: MannN, So !mannings N
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: LAKENODE  ! identifies which nodes pour into which lakes
+        REAL, INTENT(IN)                             :: dist(ixrt,jxrt,9)
+
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT)    :: CH_NETLNK
+        REAL,  DIMENSION(IXRT,JXRT)                  ::  ChSSlpG,BwG,MannNG  !channel properties on Grid
+
+
+!-- store the location x,y location of the channel element
+         INTEGER, INTENT(INOUT), DIMENSION(NLINKS)   :: CHANXI, CHANYJ
+
+!--reservoir/lake attributes
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: HRZAREA
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: LAKEMAXH
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: WEIRC
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: WEIRL
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: ORIFICEC
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: ORIFICEA
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: ORIFICEE
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: LATLAKE,LONLAKE,ELEVLAKE
+        REAL, INTENT(INOUT), DIMENSION(NLINKS)       :: ChSSlp, Bw
+
+        CHARACTER(len=256)                           :: route_link_f
+        CHARACTER(len=256)                           :: route_lake_f
+        CHARACTER(len=256)                           :: route_direction_f
+        CHARACTER(len=256)                           :: route_order_f
+        CHARACTER(len=256)                           :: geo_finegrid_flnm
+        CHARACTER(len=256)                           :: var_name
+
+        INTEGER                                      :: tmp, cnt, ncid, iret, jj,ct
+        real                                         :: gc,n
+
+!---------------------------------------------------------
+! End Declarations
+!---------------------------------------------------------
+        MAXORDER = -9999
+!initialize GSTRM
+        GSTRMFRXSTPTS = -9999
+
+!yw initialize the array.
+        to_node =   MAXORDER
+        from_node = MAXORDER
+
+#ifdef HYDRO_D
+        print *, "reading routing initialization files..."
+        print *, "route direction", route_direction_f
+        print *, "route order", route_order_f
+        print *, "route linke",route_link_f
+        print *, "route lake",route_lake_f
+#endif
+
+!DJG Edited code here to retrieve data from hires netcdf file....
+
+   IF((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then
+
+        var_name = "LATITUDE"
+        iret = get2d_real(var_name,LATVAL_inv,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+        var_name = "LONGITUDE"
+        iret = get2d_real(var_name,LONVAL_inv,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+
+    END IF
+
+
+       IF(CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2) then
+!DJG change filename to LAKEPARM.TBL        open(unit=79,file=trim(route_link_f),          &
+        open(unit=79,file='LAKEPARM.TBL',          &
+                  form='formatted',status='old')
+       END IF
+
+
+       var_name = "LAKEGRID"
+       call get2d_int(var_name,LAKE_MSKRT_inv,ixrt,jxrt,&
+               trim(geo_finegrid_flnm))
+       var_name = "FLOWDIRECTION"
+       call get2d_int(var_name,DIRECTION_inv,ixrt,jxrt,&
+               trim(geo_finegrid_flnm))
+       var_name = "STREAMORDER"
+       call get2d_int(var_name,GORDER_inv,ixrt,jxrt,&
+               trim(geo_finegrid_flnm))
+       var_name = "frxst_pts"
+       call get2d_int(var_name,GSTRMFRXSTPTS_inv,ixrt,jxrt,&
+               trim(geo_finegrid_flnm))
+
+!--1/13/2011 real hi res sfc calibrtion parameters (...)
+!       var_name = "LAKEGRID"
+!       call get2d_int(var_name,LAKE_MSKRT_inv,ixrt,jxrt,&
+!               trim(geo_finegrid_flnm))
+!       var_name = "LAKEGRID"
+!       call get2d_int(var_name,LAKE_MSKRT_inv,ixrt,jxrt,&
+!               trim(geo_finegrid_flnm))
+
+
+!-- real hi res channel properties (not yet implemented...)
+!        var_name = "MANNINGS"
+!        iret = get2d_real(var_name,MannNG,ixrt,jxrt,&
+!                     trim(geo_finegrid_flnm))
+!        var_name = "SIDE_SLOPE"
+!        iret = get2d_real(var_name,ChSSlpG,ixrt,jxrt,&
+!                     trim(geo_finegrid_flnm))
+!        var_name = "BOTTOM_WIDTH"
+!        iret = get2d_real(var_name,BwG,ixrt,jxrt,&
+!                     trim(geo_finegrid_flnm))
+
+
+!!!Flip y-dimension of highres grids from exported Arc files...
+
+
+        ct = 0
+        do i=1,ixrt
+        jj=jxrt
+         do j=1,jxrt
+           LAKE_MSKRT(i,j)=LAKE_MSKRT_inv(i,jj)
+           DIRECTION(i,j)=DIRECTION_inv(i,jj)
+           GORDER(i,j)=GORDER_inv(i,jj)
+           GSTRMFRXSTPTS(i,j)=GSTRMFRXSTPTS_inv(i,jj)
+           if(GSTRMFRXSTPTS(i,j).ne.-9999) ct = ct+1
+           LATVAL(i,j)=LATVAL_inv(i,jj)
+           LONVAL(i,j)=LONVAL_inv(i,jj)
+           jj=jxrt-j
+         end do
+        end do
+       
+!        if(dist(1,1,1) .eq. -999) then 
+!           call get_dist_ll(dist,latval,lonval,ixrt,jxrt)
+!        end if
+
+        
+#ifdef HYDRO_D
+	print *, "Number of frxst pts: ",ct
+#endif
+          
+     
+! temp fix for buggy Arc export...
+        do j=1,jxrt
+          do i=1,ixrt
+            if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128
+          end do
+        end do
+
+      cnt =0
+      if ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option .ne. 3) then ! not routing on grid, read from file
+       read(79,*)  header
+       do i=1,NLINKS
+          read (79,*) tmp, FROM_NODE(i), TO_NODE(i), TYPEL(i),&
+                   ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), &
+                   MannN(i), So(i), ChSSlp(i), Bw(i), HRZAREA(i),&
+                   LAKEMAXH(i), WEIRC(i), WEIRL(i), ORIFICEC(i), &
+                   ORIFICEA(i),ORIFICEE(i)
+
+           !-- hardwire QLINK
+          QLINK(i,1) = 1.0
+          QLINK(i,2) = QLINK(i,1)
+
+          if (So(i).lt.0.005) So(i) = 0.005  !-- impose a minimum slope requireement
+ 
+          if (ORDER(i) .gt. MAXORDER) then
+            MAXORDER = ORDER(i)
+          endif
+
+        end do
+
+      elseif ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then  !-- handle setting up topology on the grid for diffusion scheme
+
+       read(79,*)  header  !-- read the lake file
+#ifdef HYDRO_D
+       write(*,*) "reading lake file ", header
+       write(6,*) "error check read file ",route_link_f
+#endif
+
+
+      if (NLAKES.gt.0) then !read in only if there are lakes
+       do i=1, NLAKES
+        read (79,*) tmp, HRZAREA(i),LAKEMAXH(i), &
+          WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),&
+           LATLAKE(i), LONLAKE(i),ELEVLAKE(i)
+#ifdef HYDRO_D
+        write (*,*) tmp, HRZAREA(i),LAKEMAXH(i), LATLAKE(i), LONLAKE(i),ELEVLAKE(i),NLAKES
+#endif
+       enddo
+      end if   !end if for NLAKES >0 check
+
+       cnt = 0 
+
+!yw  add temperary to initialize the following two variables.
+     BwG = 0.0
+     ChSSlpG = 0.0
+
+!DJG inv       DO j = JXRT,1,-1  !rows
+       DO j = 1,JXRT  !rows
+        DO i = 1 ,IXRT   !colsumns
+         If (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order
+          If ((DIRECTION(i, j) .EQ. 64) .AND. (j + 1 .LE. JXRT) .AND. &
+               (CH_NETRT(i,j+1).ge.0) ) then !North
+             cnt = cnt + 1
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i, j + 1)
+             CHANLEN(cnt) = dist(i,j,1)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+             Link_Location(i,j) = cnt
+          else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) &
+                    .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1).ge.0) ) then !North East
+             cnt = cnt + 1
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1)
+             CHANLEN(cnt) = dist(i,j,2)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+             Link_Location(i,j) = cnt
+          else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT) &
+                    .AND. (CH_NETRT(i+1,j).ge.0) ) then !East
+             cnt = cnt + 1
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i + 1, j)
+             CHANLEN(cnt) = dist(i,j,3)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+             Link_Location(i,j) = cnt
+          else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) &
+                    .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i+1,j-1).ge.0) ) then !south east
+             cnt = cnt + 1
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1)
+             CHANLEN(cnt) = dist(i,j,4)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+             Link_Location(i,j) = cnt
+          else if ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0) ) then !due south
+             cnt = cnt + 1
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i, j - 1)
+             CHANLEN(cnt) = dist(i,j,5)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+             Link_Location(i,j) = cnt
+          else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) &
+               .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i-1,j-1).ge.0)) then !south west
+             cnt = cnt + 1
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i,j)
+             TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1)
+             CHANLEN(cnt) = dist(i,j,6)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+             Link_Location(i,j) = cnt
+          else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0) ) then !West
+             cnt = cnt + 1
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             TO_NODE(cnt) = CH_NETLNK(i - 1, j)
+             CHANLEN(cnt) = dist(i,j,7)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+             Link_Location(i,j) = cnt
+          else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) &
+                    .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0) ) then !North West
+             cnt = cnt + 1
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1)
+             CHANLEN(cnt) = dist(i,j,8)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+             Link_Location(i,j) = cnt
+          else 
+#ifdef HYDRO_D
+             print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east
+#endif
+          End If
+
+         End If !CH_NETRT check for this node
+
+        END DO
+       END DO 
+
+#ifdef HYDRO_D
+       print *, "after exiting the channel, this many nodes", cnt
+       write(*,*) " " 
+#endif
+
+!Find out if the boundaries are on an edge
+!DJG inv       DO j = JXRT,1,-1
+       DO j = 1,JXRT
+         DO i = 1 ,IXRT
+          If (CH_NETRT(i, j) .ge. 0) then !get its direction
+           If (((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) .OR. &        !-- 64's can only flow north
+              ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North
+              cnt = cnt + 1
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if(j+1 .GT. JXRT) then !-- an edge
+               TYPEL(cnt) = 1
+              elseif(LAKE_MSKRT(i,j+1).gt.0) then 
+               TYPEL(cnt) = 2
+               LAKENODE(cnt) = LAKE_MSKRT(i,j+1)
+              else
+               TYPEL(cnt) = 1 
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,1)
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+              Link_Location(i,j) = cnt
+#ifdef HYDRO_D
+              print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+           else if ( ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .GT. IXRT))  & !-- 128's can flow out of the North or East edge
+               .OR.  ((DIRECTION(i, j) .EQ. 128) .AND. (j + 1 .GT. JXRT))  & !   this is due north edge
+               .OR.  ((DIRECTION(i, j) .EQ. 128) .AND. (i1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east
+              cnt = cnt + 1
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if((i+1 .GT. IXRT) .OR. (j-1 .EQ. 0)) then !an edge 
+                TYPEL(cnt) = 1
+              elseif(LAKE_MSKRT(i+1,j-1).gt.0) then 
+                TYPEL(cnt) = 2
+                LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1)
+              else
+                TYPEL(cnt) = 1
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,4)
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+              Link_Location(i,j) = cnt
+#ifdef HYDRO_D
+              print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+           else if (((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) .OR. &       !-- 4's can only flow due south
+               ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south
+              cnt = cnt + 1
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if(j-1 .EQ. 0) then !- an edge
+                TYPEL(cnt) =1
+              elseif(LAKE_MSKRT(i,j-1).gt.0) then 
+                TYPEL(cnt) = 2
+                LAKENODE(cnt) = LAKE_MSKRT(i,j-1)
+              else
+                TYPEL(cnt) = 1
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,5)
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+              Link_Location(i,j) = cnt
+#ifdef HYDRO_D
+              print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+          else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0))      &      !-- 8's can flow south or west
+               .OR.  ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0))      &      !-- this is the south edge
+               .OR.  ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west
+              cnt = cnt + 1
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if( (i-1 .EQ. 0) .OR. (j-1 .EQ. 0) ) then !- an edge
+               TYPEL(cnt) = 1
+              elseif(LAKE_MSKRT(i-1,j-1).gt.0) then 
+                TYPEL(cnt) = 2
+                LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1)
+              else
+                TYPEL(cnt) = 1
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,6) 
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+              Link_Location(i,j) = cnt
+#ifdef HYDRO_D
+              print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+           else if (((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE.0) ) &                  !16's can only flow due west
+               .OR.((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West
+              cnt = cnt + 1
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if(i-1 .EQ. 0) then !-- an edge
+                TYPEL(cnt) = 1
+              elseif(LAKE_MSKRT(i-1,j).gt.0) then 
+                TYPEL(cnt) = 2
+                LAKENODE(cnt) = LAKE_MSKRT(i-1,j)
+              else
+                TYPEL(cnt) = 1
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,7)
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+              Link_Location(i,j) = cnt
+#ifdef HYDRO_D
+              print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+           else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0))      &      !-- 32's can flow either west or north
+               .OR.  ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT))   &      !-- this is the north edge
+               .OR.  ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j
+   integer :: i,j,ixrt,g_ixrt,jxrt,g_jxrt, nlakes, nlinks
+   integer, dimension(ixrt,jxrt)  :: LAKE_MSKRT, lakenode
+   integer, INTENT(OUT) ,dimension(ixrt,jxrt):: link_location
+   integer, INTENT(OUT) :: mpp_nlinks, yw_mpp_nlinks
+   integer, INTENT(OUT),dimension(nlinks) :: nlinks_index, lake_index
+   
+   INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: FROM_NODE,TO_NODE, &
+            TYPEL,CHANXI,CHANYJ,ORDER
+   REAL, INTENT(INOUT),  DIMENSION(NLINKS)   ::CHANLEN,  ZELEV
+   REAL, INTENT(INOUT),  DIMENSION(NLINKS)   ::CHLAT, CHLON
+   !yw REAL,  DIMENSION(NLINKS)   ::CHLAT4, CHLON4
+   integer,  DIMENSION(NLINKS)   :: node_table 
+   integer , dimension(g_ixrt,g_jxrt):: g_tmp
+   real ywtest(nlinks)
+   integer  maxorder
+  
+! Lake information 
+   REAL, INTENT(INOUT),  DIMENSION(*) :: HRZAREA,LAKEMAXH,WEIRC,WEIRL,&
+             ORIFICEC,ORIFICEA,ORIFICEE,LATLAKE,LONLAKE,ELEVLAKE
+
+      call mpp_land_bcast_int(NLINKS,FROM_NODE)
+      call mpp_land_bcast_int(NLINKS,TO_NODE)
+      call mpp_land_bcast_int(NLINKS,TYPEL)
+      call mpp_land_bcast_int(NLINKS,ORDER)
+      call mpp_land_bcast_int(NLINKS,LAKENODE)
+
+      call mpp_land_bcast_real(NLINKS,CHANLEN)
+      call mpp_land_bcast_real(NLINKS,ZELEV)
+      
+      call mpp_land_bcast_real(NLINKS,CHLAT)
+      call mpp_land_bcast_real(NLINKS,CHLON)
+
+      call mpp_land_max_int1(MAXORDER)
+      if(MAXORDER .eq. 0)  MAXORDER = -9999
+
+       lake_index = -99
+       do j = 1, jxrt
+          do i = 1, ixrt
+            if (LAKE_MSKRT(i,j) .gt. 0) then
+               lake_index(LAKE_MSKRT(i,j)) = LAKE_MSKRT(i,j)
+            endif
+          enddo
+       enddo
+
+       link_location = 0
+       if(my_id .eq. IO_id) then
+          g_tmp = -1
+          do i = 1, nlinks
+             g_tmp( CHANXI(i),CHANYJ(i) )  = i 
+          enddo
+       endif
+       call decompose_RT_int(g_tmp,link_location,g_ixrt, g_jxrt, ixrt, jxrt)
+
+      CHANXI = 0
+      CHANYj = 0
+      do j = 1, jxrt
+          do i = 1, ixrt
+             if(link_location(i,j) .gt. 0) then
+               CHANXI(link_location(i,j)) = i
+               CHANYJ(link_location(i,j)) = j
+             endif
+          end do
+      end do
+
+      node_table = 0
+      do j = 1, jxrt
+          do i = 1, ixrt
+            if(link_location(i,j) .gt. 0) then 
+               if( i.eq.1 .and. left_id > 0) then
+                    continue 
+               elseif ( i.eq. ixrt .and. right_id >0) then
+                    continue
+               elseif ( j.eq. 1 .and. down_id >0 ) then
+                    continue
+               elseif ( j.eq. jxrt .and. up_id >0) then
+                    continue
+               else
+                  node_table(link_location(i,j)) = link_location(i,j) 
+               endif
+            endif 
+          end do
+      end do
+      mpp_nlinks = 0
+      do i = 1, nlinks
+          if(node_table(i) > 0 ) then
+                mpp_nlinks = mpp_nlinks + 1
+                nlinks_index(mpp_nlinks) = i
+          endif
+      enddo
+
+!     mpp_nlinks = 0
+!     do j = 1, jxrt
+!         do i = 1, ixrt
+!           if(link_location(i,j) .gt. 0) then 
+!               mpp_nlinks = mpp_nlinks + 1
+!               nlinks_index(mpp_nlinks) = link_location(i,j)
+!           endif
+!         enddo
+!     enddo
+ 
+! add the boundary links
+      yw_mpp_nlinks = mpp_nlinks  
+      do j = 1, jxrt
+          do i = 1, ixrt
+            if(link_location(i,j) .gt. 0) then 
+               if( i.eq.1 .and. left_id > 0) then
+                    yw_mpp_nlinks = yw_mpp_nlinks + 1
+                    nlinks_index(yw_mpp_nlinks) = link_location(i,j)
+               elseif ( i.eq. ixrt .and. right_id >0) then
+                    yw_mpp_nlinks = yw_mpp_nlinks + 1
+                    nlinks_index(yw_mpp_nlinks) = link_location(i,j)
+               elseif ( j.eq. 1 .and. down_id >0 ) then
+                    yw_mpp_nlinks = yw_mpp_nlinks + 1
+                    nlinks_index(yw_mpp_nlinks) = link_location(i,j)
+               elseif ( j.eq. jxrt .and. up_id >0) then
+                    yw_mpp_nlinks = yw_mpp_nlinks + 1
+                    nlinks_index(yw_mpp_nlinks) = link_location(i,j)
+               else
+                  continue
+               endif
+            endif 
+          end do
+      end do
+
+
+      call mpp_land_bcast_real(NLAKES,HRZAREA)
+      call mpp_land_bcast_real(NLAKES,LAKEMAXH)
+      call mpp_land_bcast_real(NLAKES,WEIRC)
+      call mpp_land_bcast_real(NLAKES,WEIRL)
+      call mpp_land_bcast_real(NLAKES,ORIFICEC)
+      call mpp_land_bcast_real(NLAKES,ORIFICEA)
+      call mpp_land_bcast_real(NLAKES,ORIFICEE)
+      call mpp_land_bcast_real(NLAKES,LATLAKE)
+      call mpp_land_bcast_real(NLAKES,LONLAKE)
+      call mpp_land_bcast_real(NLAKES,ELEVLAKE)
+
+   end subroutine MPP_CHROUTING_CONF
+#endif
+
+#ifdef MPP_LAND
+  subroutine MPP_READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,&
+          gw_strm_msk,numbasns,ch_netrt,AGGFACTRT)
+
+   USE module_mpp_land
+    
+    integer, intent(in)                     :: IX,JX,IXRT,JXRT,AGGFACTRT
+    integer, intent(out)                    :: numbasns
+    integer, intent(out), dimension(IX,JX)  :: GWSUBBASMSK
+    integer, intent(out), dimension(IXRT,JXRT)  :: gw_strm_msk
+    integer, intent(in), dimension(IXRT,JXRT)  :: ch_netrt
+    character(len=256)                      :: gwbasmskfil
+    integer,dimension(global_nX,global_ny) ::  g_GWSUBBASMSK
+    integer,dimension(global_rt_nx, global_rt_ny) ::  g_gw_strm_msk,g_ch_netrt
+
+
+     call write_IO_rt_int(ch_netrt,g_ch_netrt)
+
+     if(my_id .eq. IO_id) then
+       call READ_SIMP_GW(global_nX,global_ny,global_rt_nx,global_rt_ny,&
+             g_GWSUBBASMSK,gwbasmskfil,g_gw_strm_msk,numbasns,&
+             g_ch_netrt,AGGFACTRT) 
+     endif
+     call decompose_data_int(g_GWSUBBASMSK,GWSUBBASMSK)
+     call decompose_RT_int(g_gw_strm_msk,gw_strm_msk,  &
+          global_rt_nx, global_rt_ny,ixrt,jxrt)
+     call mpp_land_bcast_int1(numbasns)
+  return
+  end subroutine MPP_READ_SIMP_GW
+#endif
+
+!DJG -----------------------------------------------------
+!   SUBROUTINE READ_SIMP_GW
+!DJG -----------------------------------------------------
+
+  subroutine READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,&
+          gw_strm_msk,numbasns,ch_netrt,AGGFACTRT)
+    implicit none
+#include 
+
+    integer, intent(in)                     :: IX,JX,IXRT,JXRT,AGGFACTRT
+    integer, intent(in), dimension(IXRT,JXRT)  :: ch_netrt
+    integer, intent(out)                    :: numbasns
+    integer, intent(out), dimension(IX,JX)  :: GWSUBBASMSK
+    integer, intent(out), dimension(IXRT,JXRT)  :: gw_strm_msk
+    character(len=256)                      :: gwbasmskfil
+    integer                                 :: i,j,aggfacxrt,aggfacyrt,ixxrt,jyyrt
+
+    numbasns = 0
+    gw_strm_msk = -9999
+
+!Open files...
+    open(unit=91,file=trim(gwbasmskfil),          &
+            form='formatted',status='old')
+
+!Read in sub-basin mask...
+    do j=jx,1,-1
+          read (91,*) (GWSUBBASMSK(i,j),i=1,ix)
+    end do
+    close(91)
+
+
+!Loop through to count number of basins and assign basin indices to chan grid
+     do J=1,JX
+       do I=1,IX
+
+!Determine max number of basins...(assumes basins are numbered
+!   sequentially from 1 to max number of basins...)
+        if (GWSUBBASMSK(i,j).gt.numbasns) then
+          numbasns = GWSUBBASMSK(i,j)   ! get count of basins...
+        end if
+
+!Assign gw basin index values to channel grid...
+        do AGGFACYRT=AGGFACTRT-1,0,-1
+          do AGGFACXRT=AGGFACTRT-1,0,-1
+
+             IXXRT=I*AGGFACTRT-AGGFACXRT
+             JYYRT=J*AGGFACTRT-AGGFACYRT
+             IF(ch_netrt(IXXRT,JYYRT).ge.0) then  !If channel grid cell
+               gw_strm_msk(IXXRT,JYYRT) = GWSUBBASMSK(i,j)  ! assign coarse grid basn indx to chan grid
+             END IF
+
+           end do !AGGFACXRT
+         end do !AGGFACYRT
+
+      end do   !I-ix
+    end do    !J-jx
+
+    return
+
+!DJG -----------------------------------------------------
+   END SUBROUTINE READ_SIMP_GW
+!DJG -----------------------------------------------------
+
+  ! BF read the static input fields needed for the 2D GW scheme
+  subroutine readGW2d(ix, jx, hc, ihead, botelv, por, ltype)
+  implicit none
+#include 
+  integer, intent(in) :: ix, jx
+  integer, dimension(ix,jx), intent(inout)::   ltype
+  real, dimension(ix,jx), intent(inout)   ::   hc, ihead, botelv, por
+
+#ifdef MPP_LAND
+  integer, dimension(:,:), allocatable ::  gLtype
+  real, dimension(:,:), allocatable    ::  gHC, gIHEAD, gBOTELV, gPOR
+#endif
+  integer :: i
+!, get2d_real
+  
+#ifdef MPP_LAND
+  allocate(gHC(global_rt_nx, global_rt_ny))
+  allocate(gIHEAD(global_rt_nx, global_rt_ny))
+  allocate(gBOTELV(global_rt_nx, global_rt_ny))
+  allocate(gPOR(global_rt_nx, global_rt_ny))
+  allocate(gLtype(global_rt_nx, global_rt_ny))
+  
+  if(my_id .eq. IO_id) then
+#ifdef HYDRO_D
+  print*, "2D GW-Scheme selected, retrieving files from gwhires.nc ..."
+#endif
+#endif
+
+
+        ! hydraulic conductivity
+        i = get2d_real("HC", &
+#ifdef MPP_LAND
+                       gHC, global_nx, global_ny,  &
+#else
+                       hc, ix, jx,  &
+#endif
+                       trim("./gwhires.nc"))
+
+        ! initial head
+        i = get2d_real("IHEAD", &
+#ifdef MPP_LAND
+                       gIHEAD, global_nx, global_ny, &
+#else
+                       ihead,  ix, jx, &
+#endif
+                       trim("./gwhires.nc"))
+                       
+        ! aquifer bottom elevation                
+        i = get2d_real("BOTELV", &
+#ifdef MPP_LAND
+                       gBOTELV, global_nx, global_ny, &
+#else
+                       botelv, ix, jx,  &
+#endif
+                       trim("./gwhires.nc"))
+                       
+	! aquifer porosity
+        i = get2d_real("POR", &
+#ifdef MPP_LAND
+                       gPOR, global_nx, global_ny, &
+#else
+                       por, ix, jx,  &
+#endif
+                       trim("./gwhires.nc"))
+
+! bftodo: develop proper landtype mask
+ 
+#ifdef MPP_LAND
+       gLtype=1
+       gLtype(1,:) = 2
+       gLtype(:,1) = 2
+       gLtype(global_rt_nx,:) = 2
+       gLtype(:,global_rt_ny) = 2 
+#else
+       ltype=1
+       ltype(1,:) =2
+       ltype(:,1) =2
+       ltype(ix,:)=2
+       ltype(:,jx)=2
+#endif
+
+#ifdef MPP_LAND  
+  endif
+     call decompose_rt_int (gLtype, ltype, global_rt_nx, global_rt_ny, ix, jx)
+     call decompose_rt_real(gHC,hc,global_rt_nx, global_rt_ny, ix, jx)
+     call decompose_rt_real(gIHEAD,ihead,global_rt_nx, global_rt_ny, ix, jx)
+     call decompose_rt_real(gBOTELV,botelv,global_rt_nx, global_rt_ny, ix, jx)
+     call decompose_rt_real(gPOR,por,global_rt_nx, global_rt_ny, ix, jx)
+     deallocate(gHC, gIHEAD, gBOTELV, gPOR)
+#endif
+  !bftodo: make filename accessible in namelist
+  return
+  end subroutine readGW2d
+  !BF
+ 
+
+
+
+  subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, &
+       startdate, date, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID,       &
+       q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, &
+       geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,HIRES_OUT,  &
+       QBDRYRT)
+
+!output the routing variables over routing grid.
+    implicit none
+#include 
+
+    integer,                                  intent(in) :: igrid
+    integer,                                  intent(in) :: split_output_count
+    integer,                                  intent(in) :: ixrt,jxrt
+    real,                                     intent(in) :: dt
+    real,                                     intent(in) :: dist(ixrt,jxrt,9)
+    integer,                                  intent(in) :: nsoil
+    integer,                                  intent(in) :: HIRES_OUT 
+    character(len=*),                         intent(in) :: startdate
+    character(len=*),                         intent(in) :: date
+    character(len=*),          intent(in)                :: geo_finegrid_flnm
+    real,             dimension(nsoil),       intent(in) :: sldpth
+    real, allocatable, DIMENSION(:,:)                   :: xdumd  !-- decimated variable
+    real*8, allocatable, DIMENSION(:)                   :: xcoord_d, xcoord
+    real*8, allocatable, DIMENSION(:)                   :: ycoord_d, ycoord
+
+    integer, save :: ncid,ncstatic
+    integer, save :: output_count
+    real,    dimension(nsoil) :: asldpth
+
+    integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n
+    integer :: iret, dimid_soil, i,j,ii,jj
+    character(len=256) :: output_flnm
+    character(len=19)  :: date19
+    character(len=32)  :: convention
+    character(len=34)  :: sec_since_date
+
+    character(len=30)  :: soilm
+
+    real                                :: long_cm,lat_po,fe,fn, chan_in
+    real, dimension(2)                  :: sp
+
+    real, dimension(ixrt,jxrt) :: xdum,QSUBRT,ZWATTABLRT,SUB_RESID
+    real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y
+    real, dimension(ixrt,jxrt) :: QSTRMVOLRT
+    real, dimension(ixrt,jxrt) :: SFCHEADSUBRT
+    real, dimension(ixrt,jxrt) :: soxrt,soyrt
+    real, dimension(ixrt,jxrt) :: LATVAL,LONVAL, QBDRYRT
+    real, dimension(ixrt,jxrt,nsoil) :: SMCRT
+
+    integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag
+    sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
+    seconds_since = int(dt)*output_count
+
+    decimation = 1 !-- decimation factor
+    ixrtd = int(ixrt/decimation)
+    jxrtd = int(jxrt/decimation)
+    allocate(xdumd(ixrtd,jxrtd))
+    allocate(xcoord_d(ixrtd))
+    allocate(ycoord_d(jxrtd))
+    allocate(xcoord(ixrtd))
+    allocate(ycoord(jxrtd))
+    ii = 0
+    jj = 0
+
+!DJG Dump timeseries for channel inflow accum. for calibration...(8/28/09)
+    chan_in = 0.0
+    do j=1,jxrt
+      do i=1,ixrt
+        chan_in=chan_in+QSTRMVOLRT(I,J)/1000.0*(dist(i,j,9))  !(units m^3)
+      enddo
+    enddo
+    open (unit=46,file='qstrmvolrt_accum.txt',form='formatted',&
+             status='unknown',position='append')
+    write (46,713) chan_in
+713 FORMAT (F20.7)
+    close (46)
+!    return
+!DJG end dump of channel inflow for calibration....
+
+    if (hires_out.eq.1) return  ! return if hires flag eq 1, if =2 output full grid
+
+    if (output_count == 0) then
+
+   !-- Open the  finemesh static files to obtain projection information
+#ifdef HYDRO_D
+      write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm)
+#endif
+      iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic)
+
+      if (iret /= 0) then
+#ifdef HYDRO_D
+         write(*,'("Problem opening geo_finegrid file: ''", A, "''")') &
+         trim(geo_finegrid_flnm)
+         write(*,*) "HIRES_OUTPUT will not be georeferenced..."
+#endif
+         
+        hires_flag = 0
+      else
+        hires_flag = 1
+      endif
+
+     if(hires_flag.eq.1) then !if/then hires_georef
+      ! Get Latitude (X)
+      iret = NF_INQ_VARID(ncstatic,'x',varid)
+      if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord)
+      ! Get Longitude (Y)
+      iret = NF_INQ_VARID(ncstatic,'y',varid)
+      if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord)
+     else
+      xcoord_d = 0.
+      ycoord_d = 0.
+     end if  !endif hires_georef 
+
+     do j=jxrt,1,-1*decimation
+        jj = jj+1
+        if (jj<= jxrtd) then
+         ycoord_d(jj) = ycoord(j)
+        endif
+     enddo
+
+!yw     do i = 1,ixrt,decimation
+!yw        ii = ii + 1
+!yw        if (ii <= ixrtd) then 
+!yw         xcoord_d(ii) = xcoord(i)
+         xcoord_d = xcoord
+!yw        endif
+!yw     enddo
+       
+
+     if(hires_flag.eq.1) then !if/then hires_georef
+      ! Get projection information from finegrid netcdf file
+      iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid)
+      if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp)  !-- read it from the static file
+     end if  !endif hires_georef 
+      iret = nf_close(ncstatic)
+
+!-- create the fine grid routing file
+       write(output_flnm, '(A12,".RTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+#ifdef HYDRO_D
+       print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#else
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#endif
+#ifdef HYDRO_D
+       if (iret /= 0) then
+         print*, "Problem nf_create"
+         call hydro_stop()
+       endif
+#endif
+
+       iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times)
+       iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix)  !-- make a decimated grid
+       iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx)
+       iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil)  !-- 3-d soils
+
+!--- define variables
+!     !- time definition, timeObs
+         iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid)
+         iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date)
+
+       !- x-coordinate in cartesian system
+        iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection')
+        iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate')
+        iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- y-coordinate in cartesian ssystem
+          iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid)
+          iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection')
+          iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate')
+          iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- LATITUDE
+        iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE')
+        iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE')
+        iret = nf_put_att_text(ncid,varid,'units',5,'deg North')
+
+       !- LONGITUDE
+          iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid)
+          iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE')
+          iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE')
+          iret = nf_put_att_text(ncid,varid,'units',5,'deg east')
+
+       !-- z-level is soil
+        iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid)
+        iret = nf_put_att_text(ncid,varid,'units',2,'cm')
+        iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer')
+
+         iret = nf_def_var(ncid,  "SOIL_M",  NF_FLOAT, 4, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid)
+            iret = nf_put_att_text(ncid,varid,'units',7,'m^3/m^3')
+            iret = nf_put_att_text(ncid,varid,'description',16,'moisture content')
+            iret = nf_put_att_text(ncid,varid,'long_name',26,soilm)
+            iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z')
+            iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+            iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!      iret = nf_def_var(ncid,"ESNOW2D",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+
+!       iret = nf_def_var(ncid,"QSUBRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+!       iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1')
+!       iret = nf_put_att_text(ncid,varid,'long_name',15,'subsurface flow')
+!       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+!       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+!       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+          iret = nf_def_var(ncid,"ZWATTABLRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+          iret = nf_put_att_text(ncid,varid,'units',1,'m')
+          iret = nf_put_att_text(ncid,varid,'long_name',17,'water table depth')
+          iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+          iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+          iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!       iret = nf_def_var(ncid,"Q_SFCFLX_X",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+!       iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1')
+!       iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux x')
+!       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+!       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+!       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!       iret = nf_def_var(ncid,"Q_SFCFLX_Y",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+!       iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1')
+!       iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux y')
+!       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+!       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+!       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+       iret = nf_def_var(ncid,"QSTRMVOLRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',14,'channel inflow')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+       iret = nf_def_var(ncid,"SFCHEADSUBRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!      iret = nf_def_var(ncid,"SOXRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+!      iret = nf_put_att_text(ncid,varid,'units',1,'1')
+!      iret = nf_put_att_text(ncid,varid,'long_name',7,'slope x')
+!      iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+!      iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+!      iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!      iret = nf_def_var(ncid,"SOYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+!      iret = nf_put_att_text(ncid,varid,'units',1,'1')
+!      iret = nf_put_att_text(ncid,varid,'long_name',7,'slope 7')
+!      iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+!      iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+!      iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!       iret = nf_def_var(ncid,"SUB_RESID",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+
+       iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',70, &
+          'accumulated value of the boundary flux, + into domain, - out of domain')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!-- place projection information
+     if(hires_flag.eq.1) then !if/then hires_georef
+      iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid)
+      iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic')
+      iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm)
+      iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po)
+      iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe)
+      iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn)
+      iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp)
+     end if   !endif hires_georef
+
+!      iret = nf_def_var(ncid,"Date",   NF_CHAR,  2, (/dimid_datelen,dimid_times/),     varid)
+
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(startdate)) = startdate
+      convention(1:32) = "CF-1.0"
+      iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19)
+      iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation)
+
+      iret = nf_enddef(ncid)
+
+!!-- write latitude and longitude locations
+!       xdumd = LATVAL
+        iret = nf_inq_varid(ncid,"x", varid)
+!       iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+         iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array
+
+!       xdumd = LONVAL
+        iret = nf_inq_varid(ncid,"y", varid)
+!       iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+        iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array
+
+        xdumd = LATVAL
+        iret = nf_inq_varid(ncid,"LATITUDE", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+
+        xdumd = LONVAL
+        iret = nf_inq_varid(ncid,"LONGITUDE", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+
+
+#ifdef HYDRO_D 
+        write (*,*) "TEST....",LONVAL (1,1),(1,2)
+        write (*,*) "TEST....",LATVAL (1,1),(1,2)
+#endif
+
+
+
+
+       do n = 1,nsoil
+        if(n == 1) then
+         asldpth(n) = -sldpth(n)
+        else
+         asldpth(n) = asldpth(n-1) - sldpth(n)
+        endif
+       enddo
+
+       iret = nf_inq_varid(ncid,"depth", varid)
+       iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth)
+!yw       iret = nf_close(ncstatic)
+
+    endif
+
+    output_count = output_count + 1
+
+!!-- time
+        iret = nf_inq_varid(ncid,"time", varid)
+        iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since)
+
+!-- 3-d soils
+     do n = 1, nsoil
+!DJG inv      jj = int(jxrt/decimation)
+      jj = 1
+      ii = 0
+!DJG inv      do j = jxrt,1,-decimation
+       do j = 1,jxrt,decimation
+       do i = 1,ixrt,decimation
+        ii = ii + 1  
+        if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
+         xdumd(ii,jj) = smcrt(i,j,n)
+        endif
+      enddo 
+       ii = 0
+!DJG inv       jj = jj -1
+       jj = jj + 1
+     enddo
+!       where (vegtyp(:,:) == 16) xdum = -1.E33
+          iret = nf_inq_varid(ncid,  "SOIL_M", varid)
+          iret = nf_put_vara_real(ncid, varid, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/), xdumd)
+    enddo !-n soils
+
+
+!!   where (vegtyp(:,:) == 16) xdum = -1.E33
+!       jj = int(jxrt/decimation)
+!       ii = 0
+!!       do j = jxrt,1,-decimation
+!      do j = 1,jxrt,decimation
+!        do i = 1,ixrt,decimation
+!         ii = ii + 1  
+!         if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
+!          xdumd(ii,jj) = QSUBRT(i,j)
+!         endif
+!       enddo 
+!       ii = 0
+!       jj = jj - 1 
+!      enddo
+!     iret = nf_inq_varid(ncid,  "QSUBRT", varid)
+!     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+
+!    xdum = ZWATTABLRT
+!   where (vegtyp(:,:) == 16) xdum = -1.E33
+!DJG inv       jj = int(jxrt/decimation)
+       jj = 1
+       ii = 0
+!DJG inv       do j = jxrt,1,-decimation
+       do j = 1,jxrt,decimation
+        do i = 1,ixrt,decimation
+         ii = ii + 1  
+         if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
+          xdumd(ii,jj) = ZWATTABLRT(i,j)
+         endif
+       enddo 
+       ii = 0
+!DJG inv       jj = jj - 1 
+       jj = jj + 1 
+      enddo
+        iret = nf_inq_varid(ncid,  "ZWATTABLRT", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+
+
+!!    xdum = Q_SFCFLX_X
+!!!   where (vegtyp(:,:) == 16) xdum = -1.E33
+!       jj = int(jxrt/decimation)
+!       ii = 0
+!!       do j = jxrt,1,-decimation
+!      do j = 1,jxrt,decimation
+!        do i = 1,ixrt,decimation
+!         ii = ii + 1  
+!         if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
+!          xdumd(ii,jj) = Q_SFCFLX_X(i,j)
+!         endif
+!       enddo 
+!       ii = 0
+!       jj = jj - 1 
+!      enddo
+!     iret = nf_inq_varid(ncid,  "Q_SFCFLX_X", varid)
+!     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+!!
+!!    xdum = Q_SFCFLX_Y
+!!!   where (vegtyp(:,:) == 16) xdum = -1.E33
+!       jj = int(jxrt/decimation)
+!       ii = 0
+!!       do j = jxrt,1,-decimation
+!      do j = 1,jxrt,decimation
+!        do i = 1,ixrt,decimation
+!         ii = ii + 1  
+!         if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
+!          xdumd(ii,jj) = Q_SFCFLX_Y(i,j)
+!         endif
+!       enddo 
+!       ii = 0
+!       jj = jj - 1 
+!      enddo
+!     iret = nf_inq_varid(ncid,  "Q_SFCFLX_Y", varid)
+!     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+
+       jj = 1
+       ii = 0
+       do j = 1,jxrt,decimation
+        do i = 1,ixrt,decimation
+         ii = ii + 1  
+         if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
+          xdumd(ii,jj) = QBDRYRT(i,j)
+         endif
+       enddo 
+       ii = 0
+       jj = jj + 1 
+      enddo
+     iret = nf_inq_varid(ncid,  "QBDRYRT", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+
+
+!    xdum = QSTRMVOLRT
+!!   where (vegtyp(:,:) == 16) xdum = -1.E33
+!DJG inv       jj = int(jxrt/decimation)
+       jj = 1
+       ii = 0
+!DJG inv       do j = jxrt,1,-decimation
+       do j = 1,jxrt,decimation
+        do i = 1,ixrt,decimation
+         ii = ii + 1  
+         if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
+          xdumd(ii,jj) = QSTRMVOLRT(i,j)
+         endif
+       enddo 
+       ii = 0
+!DJG inv      jj = jj - 1 
+       jj = jj + 1 
+      enddo
+     iret = nf_inq_varid(ncid,  "QSTRMVOLRT", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+ 
+!    xdum = SFCHEADSUBRT 
+!!   where (vegtyp(:,:) == 16) xdum = -1.E33
+!DJG inv       jj = int(jxrt/decimation)
+       jj = 1
+       ii = 0
+!DJG inv       do j = jxrt,1,-decimation
+      do j = 1,jxrt,decimation
+        do i = 1,ixrt,decimation
+         ii = ii + 1  
+         if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
+          xdumd(ii,jj) = SFCHEADSUBRT(i,j)
+         endif
+       enddo 
+       ii = 0
+!DJG inv       jj = jj - 1 
+       jj = jj + 1 
+      enddo
+     iret = nf_inq_varid(ncid,  "SFCHEADSUBRT", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+ 
+
+!   iret = nf_inq_varid(ncid,  "SOXRT", varid)
+!   iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+
+!!!   where (vegtyp(:,:) == 16) xdum = -1.E33
+!    iret = nf_inq_varid(ncid,  "SOYRT", varid)
+!    iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+!
+!!    xdum = SUB_RESID
+!!!   where (vegtyp(:,:) == 16) xdum = -1.E33
+!!    iret = nf_inq_varid(ncid,  "SUB_RESID", varid)
+!!    iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+!
+!!time in seconds since startdate
+
+       iret = nf_redef(ncid)
+       date19(1:len_trim(date)) = date
+       iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19)
+ 
+       iret = nf_enddef(ncid)
+      iret = nf_sync(ncid)
+      if (output_count == split_output_count) then
+        output_count = 0
+        iret = nf_close(ncid)
+      endif
+
+     deallocate(xdumd)
+     deallocate(xcoord_d)
+     deallocate(xcoord)
+     deallocate(ycoord_d)
+     deallocate(ycoord)
+    
+#ifdef HYDRO_D 
+     write(6,*) "end of output_rt" 
+#endif
+
+  end subroutine output_rt
+
+!BF output section for gw2d model
+!bftodo: clean up an customize for GW usage
+  subroutine output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, &
+       startdate, date, HEAD, SMCRT, convgw, SFCHEADSUBRT, &
+       geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,HIRES_OUT)
+
+#ifdef MPP_LAND
+       USE module_mpp_land
+#endif
+!output the routing variables over routing grid.
+    implicit none
+#include 
+
+    integer,                                  intent(in) :: igrid
+    integer,                                  intent(in) :: split_output_count
+    integer,                                  intent(in) :: ixrt,jxrt
+    real,                                     intent(in) :: dt
+    real,                                     intent(in) :: dist(ixrt,jxrt,9)
+    integer,                                  intent(in) :: nsoil
+    integer,                                  intent(in) :: HIRES_OUT 
+    character(len=*),                         intent(in) :: startdate
+    character(len=*),                         intent(in) :: date
+    character(len=*),          intent(in)                :: geo_finegrid_flnm
+    real,             dimension(nsoil),       intent(in) :: sldpth
+    real, allocatable, DIMENSION(:,:)                   :: xdumd  !-- decimated variable
+    real*8, allocatable, DIMENSION(:)                   :: xcoord_d, xcoord
+    real*8, allocatable, DIMENSION(:)                   :: ycoord_d, ycoord
+
+    integer, save :: ncid,ncstatic
+    integer, save :: output_count
+    real,    dimension(nsoil) :: asldpth
+
+    integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n
+    integer :: iret, dimid_soil, i,j,ii,jj
+    character(len=256) :: output_flnm
+    character(len=19)  :: date19
+    character(len=32)  :: convention
+    character(len=34)  :: sec_since_date
+
+    character(len=30)  :: soilm
+
+    real                                :: long_cm,lat_po,fe,fn, chan_in
+    real, dimension(2)                  :: sp
+
+    real, dimension(ixrt,jxrt) :: head, convgw
+    real, dimension(ixrt,jxrt) :: SFCHEADSUBRT
+    real, dimension(ixrt,jxrt) :: latval,lonval
+    real, dimension(ixrt,jxrt,nsoil) :: SMCRT
+
+    integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag
+    
+#ifdef MPP_LAND
+    real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gSFCHEADSUBRT
+    real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval
+    real, dimension(global_rt_nx,global_rt_ny,nsoil) :: gSMCRT
+#endif
+    
+#ifdef MPP_LAND
+    call write_IO_rt_real(latval,gLatval)
+    call write_IO_rt_real(lonval,gLonval)
+    call write_IO_rt_real(SFCHEADSUBRT,gSFCHEADSUBRT)
+    call write_IO_rt_real(head,gHead)
+    call write_IO_rt_real(convgw,gConvgw)
+    
+    do i = 1, NSOIL
+     call write_IO_rt_real(SMCRT(:,:,i),gSMCRT(:,:,i))
+    end do
+
+   if(my_id.eq.IO_id) then
+     
+
+#endif
+    sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
+    seconds_since = int(dt)*output_count
+
+    decimation = 1 !-- decimation factor
+#ifdef MPP_LAND
+    ixrtd = int(global_rt_nx/decimation)
+    jxrtd = int(global_rt_ny/decimation)
+#else
+    ixrtd = int(ixrt/decimation)
+    jxrtd = int(jxrt/decimation)
+#endif
+    allocate(xdumd(ixrtd,jxrtd))
+    allocate(xcoord_d(ixrtd))
+    allocate(ycoord_d(jxrtd))
+    allocate(xcoord(ixrtd))
+    allocate(ycoord(jxrtd))
+    ii = 0
+    jj = 0
+
+    if (hires_out.eq.1) return  ! return if hires flag eq 1, if =2 output full grid
+
+    if (output_count == 0) then
+
+   !-- Open the  finemesh static files to obtain projection information
+#ifdef HYDRO_D
+      write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm)
+
+#endif
+      iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic)
+
+      if (iret /= 0) then
+#ifdef HYDRO_D
+         write(*,'("Problem opening geo_finegrid file: ''", A, "''")') &
+         trim(geo_finegrid_flnm)
+         write(*,*) "HIRES_OUTPUT will not be georeferenced..."
+#endif
+        hires_flag = 0
+      else
+        hires_flag = 1
+      endif
+
+     if(hires_flag.eq.1) then !if/then hires_georef
+      ! Get Latitude (X)
+      iret = NF_INQ_VARID(ncstatic,'x',varid)
+      if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord)
+      ! Get Longitude (Y)
+      iret = NF_INQ_VARID(ncstatic,'y',varid)
+      if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord)
+     else
+      xcoord_d = 0.
+      ycoord_d = 0.
+     end if  !endif hires_georef 
+
+     do j=jxrt,1,-1*decimation
+        jj = jj+1
+        if (jj<= jxrtd) then
+         ycoord_d(jj) = ycoord(j)
+        endif
+     enddo
+
+!yw     do i = 1,ixrt,decimation
+!yw        ii = ii + 1
+!yw        if (ii <= ixrtd) then 
+!yw         xcoord_d(ii) = xcoord(i)
+         xcoord_d = xcoord
+!yw        endif
+!yw     enddo
+       
+
+     if(hires_flag.eq.1) then !if/then hires_georef
+      ! Get projection information from finegrid netcdf file
+      iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid)
+      if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp)  !-- read it from the static file
+     end if  !endif hires_georef 
+      iret = nf_close(ncstatic)
+
+!-- create the fine grid routing file
+       write(output_flnm, '(A12,".GW_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+#ifdef HYDRO_D
+       print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+
+
+#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#else
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#endif
+
+#ifdef HYDRO_D
+       if (iret /= 0) then
+         print*, "Problem nf_create"
+         call hydro_stop()
+       endif
+#endif
+
+       iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times)
+       iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix)  !-- make a decimated grid
+       iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx)
+       iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil)  !-- 3-d soils
+
+!--- define variables
+       !- time definition, timeObs
+       iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date)
+
+       !- x-coordinate in cartesian system
+       iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection')
+       iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate')
+       iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- y-coordinate in cartesian ssystem
+       iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection')
+       iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate')
+       iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- LATITUDE
+       iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE')
+       iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE')
+       iret = nf_put_att_text(ncid,varid,'units',5,'deg North')
+
+       !- LONGITUDE
+       iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE')
+       iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE')
+       iret = nf_put_att_text(ncid,varid,'units',5,'deg east')
+
+       !-- z-level is soil
+       iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'cm')
+       iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer')
+
+       iret = nf_def_var(ncid,  "SOIL_M",  NF_FLOAT, 4, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',6,'kg m-2')
+       iret = nf_put_att_text(ncid,varid,'description',16,'moisture content')
+       iret = nf_put_att_text(ncid,varid,'long_name',26,soilm)
+       iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+       iret = nf_def_var(ncid,"HEAD",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',1,'m')
+       iret = nf_put_att_text(ncid,varid,'long_name',17,'groundwater head')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+       iret = nf_def_var(ncid,"CONVGW",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',12,'channel flux')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+       iret = nf_def_var(ncid,"Platzhalter",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!-- place projection information
+     if(hires_flag.eq.1) then !if/then hires_georef
+      iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid)
+      iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic')
+      iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm)
+      iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po)
+      iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe)
+      iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn)
+      iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp)
+     end if   !endif hires_georef
+
+!      iret = nf_def_var(ncid,"Date",   NF_CHAR,  2, (/dimid_datelen,dimid_times/),     varid)
+
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(startdate)) = startdate
+      convention(1:32) = "CF-1.0"
+      iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19)
+      iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation)
+
+      iret = nf_enddef(ncid)
+
+!!-- write latitude and longitude locations
+!       xdumd = LATVAL
+        iret = nf_inq_varid(ncid,"x", varid)
+!       iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+	iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array
+
+!       xdumd = LONVAL
+        iret = nf_inq_varid(ncid,"y", varid)
+!       iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+        iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array
+
+#ifdef MPP_LAND
+        xdumd = gLATVAL
+#else  
+        xdumd = LATVAL
+#endif
+        iret = nf_inq_varid(ncid,"LATITUDE", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+
+#ifdef MPP_LAND
+        xdumd = gLONVAL
+#else  
+        xdumd = LONVAL
+#endif
+        iret = nf_inq_varid(ncid,"LONGITUDE", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+
+       do n = 1,nsoil
+        if(n == 1) then
+         asldpth(n) = -sldpth(n)
+        else
+         asldpth(n) = asldpth(n-1) - sldpth(n)
+        endif
+       enddo
+
+       iret = nf_inq_varid(ncid,"depth", varid)
+       iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth)
+!yw       iret = nf_close(ncstatic)
+
+    endif
+
+    output_count = output_count + 1
+
+!!-- time
+        iret = nf_inq_varid(ncid,"time", varid)
+        iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since)
+
+!-- 3-d soils
+     do n = 1, nsoil
+#ifdef MPP_LAND
+        xdumd = gSMCRT(:,:,n)
+#else  
+        xdumd = SMCRT(:,:,n)
+#endif
+! !DJG inv      jj = int(jxrt/decimation)
+!       jj = 1
+!       ii = 0
+! !DJG inv      do j = jxrt,1,-decimation
+!        do j = 1,jxrt,decimation
+!        do i = 1,ixrt,decimation
+!         ii = ii + 1  
+!         if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
+!          xdumd(ii,jj) = smcrt(i,j,n)
+!         endif
+!       enddo 
+!        ii = 0
+! !DJG inv       jj = jj -1
+!        jj = jj + 1
+!      enddo
+!       where (vegtyp(:,:) == 16) xdum = -1.E33
+          iret = nf_inq_varid(ncid,  "SOIL_M", varid)
+          iret = nf_put_vara_real(ncid, varid, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/), xdumd)
+    enddo !-n soils
+
+#ifdef MPP_LAND
+        xdumd = gHead
+#else  
+        xdumd = head
+#endif
+
+     iret = nf_inq_varid(ncid,  "HEAD", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+
+#ifdef MPP_LAND
+        xdumd = gConvgw
+#else  
+        xdumd = convgw
+#endif
+     iret = nf_inq_varid(ncid,  "CONVGW", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+ 
+!!time in seconds since startdate
+
+       iret = nf_redef(ncid)
+       date19(1:len_trim(date)) = date
+       iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19)
+ 
+       iret = nf_enddef(ncid)
+      iret = nf_sync(ncid)
+      if (output_count == split_output_count) then
+        output_count = 0
+        iret = nf_close(ncid)
+      endif
+
+     deallocate(xdumd)
+     deallocate(xcoord_d)
+     deallocate(xcoord)
+     deallocate(ycoord_d)
+     deallocate(ycoord)
+    
+#ifdef HYDRO_D 
+     write(6,*) "end of output_ge" 
+#endif
+#ifdef MPP_LAND
+    endif
+#endif
+
+  end subroutine output_gw
+
+!-- output the channel route in an IDV 'station' compatible format
+   subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER, &
+        startdate,date,chlon, chlat, hlink,zelev,qlink,dtrt,K,   &
+        STRMFRXSTPTS,order_to_write)
+     
+     implicit none
+#include 
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid,K
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLINKS
+     real, dimension(NLINKS),                  intent(in) :: chlon,chlat
+     real, dimension(NLINKS),                  intent(in) :: hlink,zelev
+     integer, dimension(NLINKS),               intent(in) :: ORDER
+     integer, dimension(NLINKS),               intent(inout) :: STRMFRXSTPTS
+
+     real,                                     intent(in) :: dtrt
+     real, dimension(NLINKS,2),                intent(in) :: qlink
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+
+     real, allocatable, DIMENSION(:)            :: chanlat,chanlon
+     real, allocatable, DIMENSION(:)            :: chanlatO,chanlonO
+
+     real, allocatable, DIMENSION(:)            :: elevation
+     real, allocatable, DIMENSION(:)            :: elevationO
+
+     integer, allocatable, DIMENSION(:)         :: station_id
+     integer, allocatable, DIMENSION(:)         :: station_idO
+
+     integer, allocatable, DIMENSION(:)         :: rec_num_of_station
+     integer, allocatable, DIMENSION(:)         :: rec_num_of_stationO
+
+     integer, allocatable, DIMENSION(:)         :: lOrder !- local stream order
+     integer, allocatable, DIMENSION(:)         :: lOrderO !- local stream order
+
+     integer, save  :: output_count
+     integer, save  :: ncid,ncid2
+
+     integer :: stationdim, dimdata, varid, charid, n
+     integer :: obsdim, dimdataO, charidO
+
+     integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output
+     integer :: start_posO, prev_posO
+
+     integer :: previous_pos  !-- used for the station model
+     character(len=256) :: output_flnm,output_flnm2
+     character(len=19)  :: date19,date19start
+     character(len=34)  :: sec_since_date
+     integer :: seconds_since,nstations,cnt,ObsStation,nobs
+     character(len=32)  :: convention
+     character(len=11),allocatable, DIMENSION(:)  :: stname
+     character(len=11),allocatable, DIMENSION(:)  :: stnameO
+
+    !--- all this for writing the station id string
+     INTEGER   TDIMS, TXLEN
+     PARAMETER (TDIMS=2)    ! number of TX dimensions
+     PARAMETER (TXLEN = 11) ! length of example string
+     INTEGER  TIMEID        ! record dimension id
+     INTEGER  TXID          ! variable ID
+     INTEGER  TXDIMS(TDIMS) ! variable shape
+     INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
+
+     !--  observation point  ids
+     INTEGER   OTDIMS, OTXLEN
+     PARAMETER (OTDIMS=2)    ! number of TX dimensions
+     PARAMETER (OTXLEN = 11) ! length of example string
+     INTEGER  OTIMEID        ! record dimension id
+     INTEGER  OTXID          ! variable ID
+     INTEGER  OTXDIMS(OTDIMS) ! variable shape
+     INTEGER  OTSTART(OTDIMS), OTCOUNT(OTDIMS)
+
+#ifdef HYDRO_D
+     write(6,*) "yyww dtrt =", dtrt , "k =", k
+#endif
+   
+     seconds_since = int(dtrt)*K
+
+!    order_to_write = 2  !-- 1 all; 6 feweest
+
+      nstations = 0  ! total number of channel points to display
+      nobs      = 0  ! number of observation points
+
+!-- output only the higher oder streamflows  and only observation points
+       do i=1,NLINKS
+        if(ORDER(i) .ge. order_to_write) then 
+         nstations = nstations + 1
+        endif
+        if(STRMFRXSTPTS(i) .ne. -9999) then 
+         nobs = nobs + 1
+        endif
+       enddo 
+
+       if (nobs .eq. 0) then ! let's at least make one obs point
+         nobs = 1
+         STRMFRXSTPTS(1) = 1
+       endif
+
+       allocate(chanlat(nstations))
+       allocate(chanlon(nstations))
+       allocate(elevation(nstations))
+       allocate(station_id(nstations))
+       allocate(lOrder(nstations))
+       allocate(rec_num_of_station(nstations))
+       allocate(stname(nstations))
+
+       allocate(chanlatO(nobs))
+       allocate(chanlonO(nobs))
+       allocate(elevationO(nobs))
+       allocate(station_idO(nobs))
+       allocate(lOrderO(nobs))
+       allocate(rec_num_of_stationO(nobs))
+       allocate(stnameO(nobs))
+
+       if(output_count == 0) then 
+!-- have moved sec_since_date from above here..
+        sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
+                  //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
+
+        date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
+                  //startdate(12:13)//':'//startdate(15:16)//':00'
+
+        nstations = 0
+        nobs = 0
+
+        write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+        write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+
+#ifdef HYDRO_D
+        print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+
+#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#else
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#endif
+#ifdef HYDRO_D
+        if (iret /= 0) then
+           print*,  "Problem nf_create points"
+           call hydro_stop()
+        endif
+#endif
+
+#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm2), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid2)
+#else
+       iret = nf_create(trim(output_flnm2), NF_CLOBBER, ncid2)
+#endif
+#ifdef HYDRO_D
+        if (iret /= 0) then
+            print*, "Problem nf_create observation"
+            call hydro_stop()
+        endif
+#endif
+
+       do i=1,NLINKS
+        if(ORDER(i) .ge. order_to_write) then 
+         nstations = nstations + 1
+         chanlat(nstations) = chlat(i)
+         chanlon(nstations) = chlon(i)
+         elevation(nstations) = zelev(i)
+         lOrder(nstations) = ORDER(i)
+         station_id(nstations) = i
+         if(STRMFRXSTPTS(nstations) .eq. -9999) then 
+           ObsStation = 0
+         else 
+           ObsStation = 1
+         endif
+         write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation
+        endif
+       enddo 
+
+
+       do i=1,NLINKS
+        if(STRMFRXSTPTS(i) .ne. -9999) then 
+         nobs = nobs + 1
+         chanlatO(nobs) = chlat(i)
+         chanlonO(nobs) = chlon(i)
+         elevationO(nobs) = zelev(i)
+         lOrderO(nobs) = ORDER(i)
+         station_idO(nobs) = i
+         write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs)
+#ifdef HYDRO_D
+         print *,"stationobservation name",  stnameO(nobs)
+#endif
+        endif
+       enddo 
+
+       iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata)  !--for linked list approach
+
+
+       iret = nf_def_dim(ncid, "station", nstations, stationdim)
+
+
+
+       iret = nf_def_dim(ncid2, "recNum", NF_UNLIMITED, dimdataO)  !--for linked list approach
+       iret = nf_def_dim(ncid2, "station", nobs, obsdim)
+
+
+      !- station location definition all,  lat
+        iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid)
+#ifdef HYDRO_D
+       write(6,*) "iret 2.1,  ", iret, stationdim
+#endif
+        iret = nf_put_att_text(ncid,varid,'long_name',16,'Station latitude')
+#ifdef HYDRO_D
+       write(6,*) "iret 2.2", iret
+#endif
+        iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north')
+#ifdef HYDRO_D
+       write(6,*) "iret 2.3", iret
+#endif
+
+
+      !- station location definition obs,  lat
+        iret = nf_def_var(ncid2,"latitude",NF_FLOAT, 1, (/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation latitude')
+        iret = nf_put_att_text(ncid2,varid,'units',13,'degrees_north')
+
+
+      !- station location definition,  long
+        iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',17,'Station longitude')
+        iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east')
+
+
+      !- station location definition, obs long
+        iret = nf_def_var(ncid2,"longitude",NF_FLOAT, 1, (/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',21,'Observation longitude')
+        iret = nf_put_att_text(ncid2,varid,'units',12,'degrees_east')
+
+
+!     !-- elevation is ZELEV
+        iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',16,'Station altitude')
+        iret = nf_put_att_text(ncid,varid,'units',6,'meters')
+
+
+!     !-- elevation is obs ZELEV
+        iret = nf_def_var(ncid2,"altitude",NF_FLOAT, 1, (/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation altitude')
+        iret = nf_put_att_text(ncid2,varid,'units',6,'meters')
+
+
+!     !--  gage observation
+!       iret = nf_def_var(ncid,"gages",NF_FLOAT, 1, (/stationdim/), varid)
+!       iret = nf_put_att_text(ncid,varid,'long_name',20,'Stream Gage Location')
+!       iret = nf_put_att_text(ncid,varid,'units',4,'none')
+
+!-- parent index
+        iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',36,'index of the station for this record')
+
+        iret = nf_def_var(ncid2,"parent_index",NF_INT,1,(/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',36,'index of the station for this record')
+
+     !-- prevChild
+        iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',57,'record number of the previous record for the same station')
+!ywtmp        iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+        iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+        iret = nf_def_var(ncid2,"prevChild",NF_INT,1,(/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',57,'record number of the previous record for the same station')
+!ywtmp        iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1)
+        iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1)
+
+     !-- lastChild
+        iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',30,'latest report for this station')
+!ywtmp        iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+        iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+        iret = nf_def_var(ncid2,"lastChild",NF_INT,1,(/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',30,'latest report for this station')
+!ywtmp        iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1)
+        iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1)
+
+!     !- flow definition, var
+        iret = nf_def_var(ncid, "streamflow", NF_FLOAT, 1, (/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid,varid,'long_name',10,'River Flow')
+
+        iret = nf_def_var(ncid2, "streamflow", NF_FLOAT, 1, (/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid2,varid,'long_name',10,'River Flow')
+
+!     !- flow definition, var
+!       iret = nf_def_var(ncid, "pos_streamflow", NF_FLOAT, 1, (/dimdata/), varid)
+!       iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+!       iret = nf_put_att_text(ncid,varid,'long_name',14,'abs streamflow')
+
+!     !- head definition, var
+        iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',5,'meter')
+        iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage')
+
+        iret = nf_def_var(ncid2, "head", NF_FLOAT, 1, (/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'units',5,'meter')
+        iret = nf_put_att_text(ncid2,varid,'long_name',11,'River Stage')
+
+
+!     !- order definition, var
+        iret = nf_def_var(ncid, "order", NF_INT, 1, (/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',21,'Strahler Stream Order')
+        iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+        iret = nf_def_var(ncid2, "order", NF_INT, 1, (/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',21,'Strahler Stream Order')
+        iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+
+     !-- station  id
+     ! define character-position dimension for strings of max length 11
+         iret = NF_DEF_DIM(ncid, "id_len", 11, charid)
+         TXDIMS(1) = charid   ! define char-string variable and position dimension first
+         TXDIMS(2) = stationdim
+         iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid)
+         iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id')
+
+         iret = NF_DEF_DIM(ncid2, "id_len", 11, charidO)
+         OTXDIMS(1) = charidO   ! define char-string variable and position dimension first
+         OTXDIMS(2) = obsdim
+         iret = nf_def_var(ncid2,"station_id",NF_CHAR, OTDIMS, OTXDIMS, varid)
+         iret = nf_put_att_text(ncid2,varid,'long_name',14,'Observation id')
+
+
+!     !- time definition, timeObs
+         iret = nf_def_var(ncid,"time_observation",NF_INT, 1, (/dimdata/), varid)
+         iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date)
+         iret = nf_put_att_text(ncid,varid,'long_name',19,'time of observation')
+
+         iret = nf_def_var(ncid2,"time_observation",NF_INT, 1, (/dimdataO/), varid)
+         iret = nf_put_att_text(ncid2,varid,'units',34,sec_since_date)
+         iret = nf_put_att_text(ncid2,varid,'long_name',19,'time of observation')
+
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention)
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention)
+
+         convention(1:32) = "Unidata Observation Dataset v1.0"
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention)
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19start)
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "stationDimension",7, "station")
+         iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+         iret = nf_put_att_int(ncid, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write)
+
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention)
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "cdm_datatype",7, "Station")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_max",4, "90.0")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_min",5, "-90.0")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_max",5, "180.0")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_min",6, "-180.0")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_start",19, date19start)
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "stationDimension",7, "station")
+         iret = nf_put_att_real(ncid2, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+         iret = nf_put_att_int(ncid2, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write)
+
+         iret = nf_enddef(ncid)
+         iret = nf_enddef(ncid2)
+        
+        !-- write latitudes
+         iret = nf_inq_varid(ncid,"latitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlat)
+
+         iret = nf_inq_varid(ncid2,"latitude", varid)
+         iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlatO)
+
+        !-- write longitudes
+         iret = nf_inq_varid(ncid,"longitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlon)
+
+         iret = nf_inq_varid(ncid2,"longitude", varid)
+         iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlonO)
+
+        !-- write elevations
+         iret = nf_inq_varid(ncid,"altitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), elevation)
+
+         iret = nf_inq_varid(ncid2,"altitude", varid)
+         iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), elevationO)
+
+      !-- write gage location
+!      iret = nf_inq_varid(ncid,"gages", varid)
+!      iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), STRMFRXSTPTS)
+
+        !-- write number_of_stations, OPTIONAL
+      !!  iret = nf_inq_varid(ncid,"number_stations", varid)
+      !!  iret = nf_put_var_int(ncid, varid, nstations)
+
+        !-- write station id's 
+         do i=1,nstations
+          TSTART(1) = 1
+          TSTART(2) = i
+          TCOUNT(1) = TXLEN
+          TCOUNT(2) = 1
+          iret = nf_inq_varid(ncid,"station_id", varid)
+          iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i))
+         enddo
+
+        !-- write observation id's 
+         do i=1, nobs
+          OTSTART(1) = 1
+          OTSTART(2) = i
+          OTCOUNT(1) = OTXLEN
+          OTCOUNT(2) = 1
+          iret = nf_inq_varid(ncid2,"station_id", varid)
+          iret = nf_put_vara_text(ncid2, varid, OTSTART, OTCOUNT, stnameO(i))
+         enddo
+
+     endif
+
+     output_count = output_count + 1
+
+     open (unit=999,file='frxst_pts_out.txt',status='unknown',position='append')
+
+     cnt=0
+     do i=1,NLINKS
+
+       if(ORDER(i) .ge. order_to_write) then 
+         start_pos = (cnt+1)+(nstations*(output_count-1))
+
+         !!--time in seconds since startdate
+          iret = nf_inq_varid(ncid,"time_observation", varid)
+          iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since)
+
+         iret = nf_inq_varid(ncid,"streamflow", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlink(i,1))
+
+!        iret = nf_inq_varid(ncid,"pos_streamflow", varid)
+!        iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), abs(qlink(i,1)))
+
+         iret = nf_inq_varid(ncid,"head", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), hlink(i))
+
+         iret = nf_inq_varid(ncid,"order", varid)
+         iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), ORDER(i))
+
+         !-- station index.. will repeat for every timesstep
+         iret = nf_inq_varid(ncid,"parent_index", varid)
+         iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt)
+
+          !--record number of previous record for same station
+!obsolete format         prev_pos = cnt+(nstations*(output_count-1))
+         prev_pos = cnt+(nobs*(output_count-2))
+         if(output_count.ne.1) then !-- only write next set of records
+           iret = nf_inq_varid(ncid,"prevChild", varid)
+           iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos)
+         endif
+
+         cnt=cnt+1  !--indices are 0 based
+         rec_num_of_station(cnt) = start_pos-1  !-- save position for last child, 0-based!!
+
+
+       endif
+    enddo
+!    close(999) 
+
+    !-- output  only observation points
+    cnt=0
+    do i=1,NLINKS
+
+      if(STRMFRXSTPTS(i) .ne. -9999) then 
+#ifdef HYDRO_D
+         print *, "Outputting frxst pt. :",STRMFRXSTPTS(i)
+         call flush(6)
+#endif
+         start_posO = (cnt+1)+(nobs * (output_count-1))
+
+!Write frxst_pts to text file...
+!yw          write(999,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
+           write(999,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), &
+                    abs(qlink(i,1)), abs(qlink(i,1))*35.315,hlink(i)
+!yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3)
+!yw 117 FORMAT(I8,1X,A10,1X,A8,1x,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3)
+  117 FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
+
+         !!--time in seconds since startdate
+         iret = nf_inq_varid(ncid2,"time_observation", varid)
+         iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), seconds_since)
+
+         iret = nf_inq_varid(ncid2,"streamflow", varid)
+         iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1))
+
+         iret = nf_inq_varid(ncid2,"head", varid)
+         iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i))
+
+         iret = nf_inq_varid(ncid,"order", varid)
+         iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i))
+
+         !-- station index.. will repeat for every timesstep
+         iret = nf_inq_varid(ncid2,"parent_index", varid)
+         iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt)
+
+          !--record number of previous record for same station
+!obsolete format          prev_posO = cnt+(nobs*(output_count-1))
+         prev_posO = cnt+(nobs*(output_count-2))
+         if(output_count.ne.1) then !-- only write next set of records
+           iret = nf_inq_varid(ncid2,"prevChild", varid)
+           iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO)
+
+!IF block to add -1 to last element of prevChild array to designate end of list...
+!           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
+!             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
+!           else
+!             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO)
+!           endif 
+
+
+         endif
+
+         cnt=cnt+1  !--indices are 0 based
+         rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
+
+
+      endif
+
+    enddo
+    close(999) 
+
+
+      !-- lastChild variable gives the record number of the most recent report for the station
+      iret = nf_inq_varid(ncid,"lastChild", varid)
+      iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), rec_num_of_station)
+
+      !-- lastChild variable gives the record number of the most recent report for the station
+      iret = nf_inq_varid(ncid2,"lastChild", varid)
+      iret = nf_put_vara_int(ncid2, varid, (/1/), (/nobs/), rec_num_of_stationO)
+
+      iret = nf_redef(ncid)
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(date)) = date
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19)
+
+      iret = nf_redef(ncid2)
+      iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_end", 19, date19)
+
+      iret = nf_enddef(ncid)
+      iret = nf_sync(ncid)
+
+      iret = nf_enddef(ncid2)
+      iret = nf_sync(ncid2)
+
+      if (output_count == split_output_count) then
+        output_count = 0
+        iret = nf_close(ncid)
+        iret = nf_close(ncid2)
+     endif
+
+     deallocate(chanlat)
+     deallocate(chanlon)
+     deallocate(elevation)
+     deallocate(station_id)
+     deallocate(lOrder)
+     deallocate(rec_num_of_station)
+     deallocate(stname)
+
+     deallocate(chanlatO)
+     deallocate(chanlonO)
+     deallocate(elevationO)
+     deallocate(station_idO)
+     deallocate(lOrderO)
+     deallocate(rec_num_of_stationO)
+     deallocate(stnameO)
+#ifdef HYDRO_D
+     print *, "Exited Subroutine output_chrt"
+#endif
+     close(16)
+
+20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3)
+
+end subroutine output_chrt
+
+#ifdef MPP_LAND
+!-- output the channel route in an IDV 'station' compatible format
+   subroutine mpp_output_chrt(mpp_nlinks,nlinks_index,igrid, &
+        split_output_count, NLINKS, ORDER, &
+        startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt, &
+        K,STRMFRXSTPTS,order_to_write)
+
+       USE module_mpp_land
+
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid,K
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLINKS
+     real, dimension(NLINKS),               intent(in) :: chlon,chlat
+     real, dimension(NLINKS),                  intent(in) :: hlink,zelev
+
+     integer, dimension(NLINKS),               intent(in) :: ORDER
+     integer, dimension(NLINKS),               intent(inout) :: STRMFRXSTPTS
+
+     real,                                     intent(in) :: dtrt
+     real, dimension(NLINKS,2),                intent(in) :: qlink
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+     integer  :: mpp_nlinks, nlinks_index(nlinks), order_to_write
+
+
+     call write_chanel_int(order,nlinks_index,mpp_nlinks,nlinks)
+     call write_chanel_real(chlon,nlinks_index,mpp_nlinks,nlinks)
+     call write_chanel_real(chlat,nlinks_index,mpp_nlinks,nlinks)
+     call write_chanel_real(hlink,nlinks_index,mpp_nlinks,nlinks)
+     call write_chanel_real(zelev,nlinks_index,mpp_nlinks,nlinks)
+     call write_chanel_real(qlink(:,1),nlinks_index,mpp_nlinks,nlinks)
+     call write_chanel_real(qlink(:,2),nlinks_index,mpp_nlinks,nlinks)
+
+     if(my_id .eq. IO_id) then
+       call output_chrt(igrid, split_output_count, NLINKS, ORDER, &
+          startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt,K,&
+          STRMFRXSTPTS,order_to_write)
+    end if
+
+end subroutine mpp_output_chrt
+
+!---------  lake netcdf output -----------------------------------------
+!-- output the ilake info an IDV 'station' compatible format -----------
+   subroutine mpp_output_lakes(lake_index,igrid, split_output_count, NLAKES, &
+        startdate, date, latlake, lonlake, elevlake, &
+        qlakei,qlakeo, resht,dtrt,K)
+
+   USE module_mpp_land
+
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid, K
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLAKES
+     real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
+     real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
+     real,                                     intent(in) :: dtrt
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+     integer lake_index(nlakes)
+
+     call write_lake_real(latlake,lake_index,nlakes)
+     call write_lake_real(lonlake,lake_index,nlakes)
+     call write_lake_real(elevlake,lake_index,nlakes)
+     call write_lake_real(resht,lake_index,nlakes)
+     call write_lake_real(qlakei,lake_index,nlakes)
+     call write_lake_real(qlakeo,lake_index,nlakes)
+     if(my_id.eq. IO_id) then
+        call output_lakes(igrid, split_output_count, NLAKES, &
+           startdate, date, latlake, lonlake, elevlake, &
+           qlakei,qlakeo, resht,dtrt,K)
+     end if
+     return
+     end subroutine mpp_output_lakes
+
+#endif
+
+!----------------------------------- lake netcdf output
+!-- output the ilake info an IDV 'station' compatible format
+   subroutine output_lakes(igrid, split_output_count, NLAKES, &
+        startdate, date, latlake, lonlake, elevlake, &
+        qlakei,qlakeo, resht,dtrt,K)
+
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid, K
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLAKES
+     real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
+     real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
+     real,                                     intent(in) :: dtrt
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+
+     integer, allocatable, DIMENSION(:)                   :: station_id
+     integer, allocatable, DIMENSION(:)                   :: rec_num_of_lake
+
+     integer, save  :: output_count
+     integer, save :: ncid
+
+     integer :: stationdim, dimdata, varid, charid, n
+     integer :: iret,i, start_pos, prev_pos  !-- 
+     integer :: previous_pos        !-- used for the station model
+     character(len=256) :: output_flnm
+     character(len=19)  :: date19, date19start
+     character(len=34)  :: sec_since_date
+     integer :: seconds_since,cnt
+     character(len=32)  :: convention
+     character(len=6),allocatable, DIMENSION(:)  :: stname
+
+    !--- all this for writing the station id string
+     INTEGER   TDIMS, TXLEN
+     PARAMETER (TDIMS=2)    ! number of TX dimensions
+     PARAMETER (TXLEN = 6) ! length of example string
+     INTEGER  TIMEID        ! record dimension id
+     INTEGER  TXID          ! variable ID
+     INTEGER  TXDIMS(TDIMS) ! variable shape
+     INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
+
+!    sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
+!    seconds_since = int(dtrt)*output_count
+     seconds_since = int(dtrt)*K
+
+     allocate(station_id(NLAKES))
+     allocate(rec_num_of_lake(NLAKES))
+     allocate(stname(NLAKES))
+
+     if (output_count == 0) then
+
+!-- have moved sec_since_date from above here..
+      sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
+                  //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
+
+      date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
+                  //startdate(12:13)//':'//startdate(15:16)//':00'
+
+      write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+#ifdef HYDRO_D
+      print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+
+#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#else
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#endif
+
+#ifdef HYDRO_D
+      if (iret /= 0) then
+          print*, "Problem nf_create"
+          call hydro_stop()
+      endif
+#endif
+
+      do i=1,NLAKES
+         station_id(i) = i
+         write(stname(i),'(I6)') i
+      enddo 
+
+      iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata)  !--for linked list approach
+      iret = nf_def_dim(ncid, "station", nlakes, stationdim)
+
+      !- station location definition,  lat
+      iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake latitude')
+      iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north')
+
+      !- station location definition,  long
+      iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake longitude')
+      iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east')
+
+!     !-- lake's phyical elevation
+      iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake altitude')
+      iret = nf_put_att_text(ncid,varid,'units',6,'meters')
+
+     !-- parent index
+      iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',33,'index of the lake for this record')
+
+     !-- prevChild
+      iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',54,'record number of the previous record for the same lake')
+!ywtmp      iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+      iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+     !-- lastChild
+      iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',27,'latest report for this lake')
+!ywtmp      iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+      iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+!     !- water surface elevation
+      iret = nf_def_var(ncid, "elevation", NF_FLOAT, 1, (/dimdata/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',6,'meters')
+      iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake Elevation')
+
+!     !- inflow to lake
+      iret = nf_def_var(ncid, "inflow", NF_FLOAT, 1, (/dimdata/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+
+!     !- outflow to lake
+      iret = nf_def_var(ncid, "outflow", NF_FLOAT, 1, (/dimdata/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+
+     !-- station  id
+     ! define character-position dimension for strings of max length 6
+         iret = NF_DEF_DIM(ncid, "id_len", 6, charid)
+         TXDIMS(1) = charid   ! define char-string variable and position dimension first
+         TXDIMS(2) = stationdim
+         iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid)
+         iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id')
+
+!     !- time definition, timeObs
+         iret = nf_def_var(ncid,"time_observation",NF_INT, 1, (/dimdata/), varid)
+         iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date)
+         iret = nf_put_att_text(ncid,varid,'long_name',19,'time of observation')
+
+!       date19(1:19) = "0000-00-00_00:00:00"
+!       date19(1:len_trim(startdate)) = startdate
+!       iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention)
+!
+        date19(1:19) = "0000-00-00_00:00:00"
+        date19(1:len_trim(startdate)) = startdate
+        convention(1:32) = "Unidata Observation Dataset v1.0"
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention)
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station")
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0")
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0")
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0")
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0")
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19start)
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "stationDimension",7, "station")
+!!       iret = nf_put_att_text(ncid, NF_GLOBAL, "observationDimension",6, "recNum")
+!!        iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coordinate",16,"time_observation")
+        iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+        iret = nf_enddef(ncid)
+
+        !-- write latitudes
+        iret = nf_inq_varid(ncid,"latitude", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LATLAKE)
+
+        !-- write longitudes
+        iret = nf_inq_varid(ncid,"longitude", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LONLAKE)
+
+        !-- write physical height of lake
+        iret = nf_inq_varid(ncid,"altitude", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), elevlake)
+
+        !-- write station id's 
+         do i=1,nlakes
+          TSTART(1) = 1
+          TSTART(2) = i
+          TCOUNT(1) = TXLEN
+          TCOUNT(2) = 1
+          iret = nf_inq_varid(ncid,"station_id", varid)
+          iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i))
+         enddo
+
+     endif
+
+     output_count = output_count + 1
+
+     cnt=0
+     do i=1,NLAKES
+
+         start_pos = (cnt+1)+(nlakes*(output_count-1))
+
+         !!--time in seconds since startdate
+         iret = nf_inq_varid(ncid,"time_observation", varid)
+         iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since)
+
+         iret = nf_inq_varid(ncid,"elevation", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), resht(i))
+
+         iret = nf_inq_varid(ncid,"inflow", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakei(i))
+
+         iret = nf_inq_varid(ncid,"outflow", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakeo(i))
+
+         !-- station index.. will repeat for every timesstep
+         iret = nf_inq_varid(ncid,"parent_index", varid)
+         iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt)
+
+          !--record number of previous record for same station
+         prev_pos = cnt+(nlakes*(output_count-1))
+         if(output_count.ne.1) then !-- only write next set of records
+           iret = nf_inq_varid(ncid,"prevChild", varid)
+           iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos)
+         endif
+
+         cnt=cnt+1  !--indices are 0 based
+         rec_num_of_lake(cnt) = start_pos-1  !-- save position for last child, 0-based!!
+
+    enddo
+
+      !-- lastChild variable gives the record number of the most recent report for the station
+      iret = nf_inq_varid(ncid,"lastChild", varid)
+      iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake)
+
+     !-- number of children reported for this station, OPTIONAL
+     !--  iret = nf_inq_varid(ncid,"numChildren", varid)
+     !--  iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake)
+
+    iret = nf_redef(ncid)
+    date19(1:19) = "0000-00-00_00:00:00"
+    date19(1:len_trim(date)) = date
+    iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19)
+    iret = nf_enddef(ncid)
+
+    iret = nf_sync(ncid)
+     if (output_count == split_output_count) then
+        output_count = 0
+        iret = nf_close(ncid)
+     endif
+
+     deallocate(station_id)
+     deallocate(rec_num_of_lake)
+     deallocate(stname)
+#ifdef HYDRO_D
+     print *, "Exited Subroutine output_lakes"
+#endif
+     close(16)
+
+ end subroutine output_lakes
+!----------------------------------- lake netcdf output
+
+#ifdef MPP_LAND
+
+!-- output the channel route in an IDV 'grid' compatible format
+   subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, &
+        NLINKS,CH_NETRT_in, CH_NETLNK_in, ORDER, startdate, date, &
+        qlink, dt, geo_finegrid_flnm, mpp_nlinks,nlinks_index,g_ixrt,g_jxrt )
+
+   USE module_mpp_land
+
+     implicit none
+#include 
+     integer g_ixrt,g_jxrt
+     integer,                                  intent(in) :: igrid
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLINKS,ixrt,jxrt
+     real,                                     intent(in) :: dt
+     real, dimension(NLINKS,2),                intent(in) :: qlink
+     integer, dimension(g_IXRT,g_JXRT)         :: CH_NETRT,CH_NETLNK
+     integer, dimension(IXRT,JXRT),            intent(in) :: CH_NETRT_in,CH_NETLNK_in
+     integer, dimension(NLINKS),               intent(in) :: ORDER !--currently not used here, see finegrid.f
+     character(len=*),          intent(in)     :: geo_finegrid_flnm
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+    
+     integer::  mpp_nlinks , nlinks_index(nlinks)
+     call write_chanel_real(qlink(:,1),nlinks_index,mpp_nlinks,nlinks)
+     call write_chanel_real(qlink(:,2),nlinks_index,mpp_nlinks,nlinks)
+     call write_chanel_int(order,nlinks_index,mpp_nlinks,nlinks)
+     call write_IO_rt_int(CH_NETRT_in, CH_NETRT)
+     call write_IO_rt_int(CH_NETLNK_in, CH_NETLNK)
+
+    if(my_id.eq.IO_id) then
+        call  output_chrtgrd(igrid, split_output_count, g_ixrt,g_jxrt, &
+           NLINKS,CH_NETRT, CH_NETLNK, ORDER, startdate, date, &
+           qlink, dt, geo_finegrid_flnm)
+    endif
+  
+     return
+     end subroutine mpp_output_chrtgrd
+#endif
+
+!-- output the channel route in an IDV 'grid' compatible format
+   subroutine output_chrtgrd(igrid, split_output_count, ixrt,jxrt, &
+        NLINKS,CH_NETRT, CH_NETLNK, ORDER, startdate, date, &
+        qlink, dt, geo_finegrid_flnm)
+
+     integer,                                  intent(in) :: igrid
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLINKS,ixrt,jxrt
+     real,                                     intent(in) :: dt
+     real, dimension(NLINKS,2),                intent(in) :: qlink
+     integer, dimension(IXRT,JXRT),            intent(in) :: CH_NETRT,CH_NETLNK
+     integer, dimension(NLINKS),               intent(in) :: ORDER !--currently not used here, see finegrid.f
+     character(len=*),          intent(in)     :: geo_finegrid_flnm
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+     character(len=32)  :: convention
+     integer,save  :: output_count
+     integer, save :: ncid,ncstatic
+     real, dimension(IXRT,JXRT)          :: tmpflow
+     real, dimension(IXRT)            :: xcoord
+     real, dimension(JXRT)            :: ycoord
+     real                                :: long_cm,lat_po,fe,fn
+     real, dimension(2)                  :: sp
+
+    integer :: varid, n
+    integer :: jxlatdim,ixlondim,timedim !-- dimension ids
+
+    integer :: iret,i,j
+    character(len=256) :: output_flnm
+    character(len=19)  :: date19
+    character(len=34)  :: sec_since_date
+ 
+
+    integer :: seconds_since
+
+
+
+
+      tmpflow = -9E15
+
+ 
+        write(output_flnm, '(A12,".CHRTOUT_GRID",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+#ifdef HYDRO_D
+        print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+ 
+
+!--- define dimension
+#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#else
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#endif
+
+#ifdef HYDRO_D
+        if (iret /= 0) then
+            print*, "Problem nf_create"
+            call hydro_stop()
+        endif
+#endif
+
+
+        iret = nf_def_dim(ncid, "time", NF_UNLIMITED, timedim)
+        iret = nf_def_dim(ncid, "x", ixrt, ixlondim)
+        iret = nf_def_dim(ncid, "y", jxrt, jxlatdim)
+
+!--- define variables
+!     !- time definition, timeObs
+         iret = nf_def_var(ncid,"time",NF_INT, 1, (/timedim/), varid)
+
+       !- x-coordinate in cartesian system
+!yw         iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/ixlondim/), varid)
+!yw         iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection')
+!yw         iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate')
+!yw         iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- y-coordinate in cartesian ssystem
+!yw         iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/jxlatdim/), varid)
+!yw         iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection')
+!yw         iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate')
+!yw         iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+!     !- flow definition, var
+        iret = nf_def_var(ncid,"flow",NF_REAL, 3, (/ixlondim,jxlatdim,timedim/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1')
+        iret = nf_put_att_text(ncid,varid,'long_name',15,'water flow rate')
+        iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+        iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+        iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+
+!-- place prjection information
+
+
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(startdate)) = startdate
+      convention(1:32) = "CF-1.0"
+      iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19)
+
+      iret = nf_enddef(ncid)
+
+!!-- write latitude and longitude locations
+
+!DJG inv    do j=jxrt,1,-1
+    do j=1,jxrt
+     do i=1,ixrt
+       if(CH_NETRT(i,j).GE.0) then
+         tmpflow(i,j) = qlink(CH_NETLNK(i,j),1) 
+       else
+         tmpflow(i,j) = -9E15
+       endif
+     enddo
+    enddo
+
+!!time in seconds since startdate
+
+    iret = nf_inq_varid(ncid,"flow", varid)
+    iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ixrt,jxrt,1/),tmpflow)
+
+        iret = nf_close(ncid)
+
+
+
+ end subroutine output_chrtgrd
+
+
+
+#ifdef MPP_LAND
+  subroutine mpp_output_rt(ixrt, jxrt,igrid, split_output_count, &
+       ixrt_in, jxrt_in,nsoil, startdate, olddate, &
+       QSUBRT_in,ZWATTABLRT_in,SMCRT_in,SUB_RESID_in,       &
+       q_sfcflx_x_in,q_sfcflx_y_in,soxrt_in,soyrt_in,       &
+       QSTRMVOLRT_in,SFCHEADSUBRT_in, &
+       geo_finegrid_flnm,dt,sldpth,LATVAL_in,LONVAL_in,dist,HIRES_OUT, &
+       QBDRYRT_in)
+
+!output the routing variables over routing grid.
+   USE module_mpp_land
+
+    implicit none
+#include 
+
+    integer,                                  intent(in) :: igrid
+    integer,                                  intent(in) :: split_output_count
+
+! ixrt and jxrt are global. ixrt_in and jxrt_in are local array index.
+    integer,                                  intent(in) :: ixrt,jxrt,ixrt_in,jxrt_in
+    real,                                     intent(in) :: dt
+    real,                                     intent(in) :: dist(ixrt_in,jxrt_in,9)
+    integer,                                  intent(in) :: nsoil
+    integer,                                  intent(in) :: HIRES_OUT
+    character(len=*),                         intent(in) :: startdate
+    character(len=*),                         intent(in) :: olddate
+    character(len=*),          intent(in)                :: geo_finegrid_flnm
+    real,             dimension(nsoil),       intent(in) :: sldpth
+
+    real, dimension(ixrt_in,jxrt_in) :: QSUBRT_in,ZWATTABLRT_in,SUB_RESID_in
+    real, dimension(ixrt_in,jxrt_in) :: q_sfcflx_x_in,q_sfcflx_y_in
+    real, dimension(ixrt_in,jxrt_in) :: QSTRMVOLRT_in
+    real, dimension(ixrt_in,jxrt_in) :: SFCHEADSUBRT_in, QBDRYRT_in
+    real, dimension(ixrt_in,jxrt_in) :: soxrt_in,soyrt_in
+    real, dimension(ixrt_in,jxrt_in,nsoil) :: SMCRT_in
+    real, dimension(ixrt_in,jxrt_in) :: LATVAL_in,LONVAL_in
+
+    real, dimension(ixrt,jxrt) :: QSUBRT,ZWATTABLRT,SUB_RESID
+    real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y
+    real, dimension(ixrt,jxrt) :: QSTRMVOLRT, QBDRYRT
+    real, dimension(ixrt,jxrt) :: SFCHEADSUBRT
+    real, dimension(ixrt,jxrt) :: soxrt,soyrt
+    real, dimension(ixrt,jxrt,nsoil) :: SMCRT
+    real, dimension(ixrt,jxrt,9) :: dist_g
+    real, dimension(ixrt,jxrt) :: LATVAL,LONVAL
+    integer i
+
+
+#ifdef HYDRO_D
+    write(6,*) "mpp_output_RT output file: ",trim(geo_finegrid_flnm)
+#endif
+
+    call write_IO_rt_real(LATVAL_in,LATVAL)
+    call write_IO_rt_real(LONVAL_in,LONVAL)
+    call write_IO_rt_real(QSUBRT_in,QSUBRT)
+   
+
+    call write_IO_rt_real(ZWATTABLRT_in,ZWATTABLRT)
+
+
+    call write_IO_rt_real(SUB_RESID_in,SUB_RESID)
+
+
+    call write_IO_rt_real(QSTRMVOLRT_in,QSTRMVOLRT)
+
+
+
+    call write_IO_rt_real(SFCHEADSUBRT_in,SFCHEADSUBRT)
+    call write_IO_rt_real(soxrt_in,soxrt)
+
+    call write_IO_rt_real(QBDRYRT_in,QBDRYRT)
+
+
+
+    call write_IO_rt_real(soyrt_in,soyrt)
+    call write_IO_rt_real(q_sfcflx_x_in,q_sfcflx_x)
+    call write_IO_rt_real(q_sfcflx_y_in,q_sfcflx_y)
+
+
+
+
+    do i = 1, NSOIL
+         call write_IO_rt_real(SMCRT_in(:,:,i),SMCRT(:,:,i))
+    end do
+    do i = 1, 9    
+         call write_IO_rt_real(dist(:,:,i),dist_g(:,:,i))
+    end do
+
+!   yyywwww  ! temp test
+!   if(my_id.eq. IO_id  ) write(14,*) dist(:,:,9)
+!   if(my_id.eq. IO_id  ) write(12,*) dist_g(:,:,9)
+
+
+
+
+    if(my_id.eq.IO_id) then
+       call output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, &
+          startdate, olddate, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID,       &
+          q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, &
+          geo_finegrid_flnm,DT,SLDPTH,latval,lonval,dist_g,HIRES_OUT, &
+          QBDRYRT)
+    end if
+
+#ifdef HYDRO_D
+    write(6,*) "return from mpp_output_RT"
+#endif
+  end subroutine mpp_output_rt
+
+#endif
+
+ subroutine read_chan_forcing( &
+       indir,olddate,startdate,hgrid,&
+       ixrt,jxrt,QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT)
+! This subrouting is going to read channel forcing for
+!  channel only simulations (ie when CHANRTSWCRT = 2)
+
+   implicit none
+#include 
+   ! in variable
+   character(len=*) :: olddate,hgrid,indir,startdate
+   character(len=256) :: filename
+   integer :: ixrt,jxrt
+   real,dimension(ixrt,jxrt):: QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT
+   ! tmp variable
+   character(len=256) :: inflnm, product
+   integer  :: i,j,mmflag
+   character(len=256) :: units
+   integer :: ierr
+   integer :: ncid
+
+
+!DJG Create filename...
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             olddate(15:16)//".RTOUT_DOMAIN"//hgrid
+#ifdef HYDRO_D
+        print *, "Channel forcing file...",inflnm
+#endif
+
+
+!DJG Open NetCDF file...
+    ierr = nf_open(inflnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+#ifdef HYDRO_D
+       write(*,'("READFORC_chan Problem opening netcdf file: ''", A, "''")') trim(inflnm)
+       call hydro_stop()
+#endif
+    endif
+
+!DJG read data...
+    call get_2d_netcdf("QSTRMVOLRT",  ncid, QSTRMVOLRT_ACC, units, ixrt, jxrt, .TRUE., ierr)
+!DJG TBC    call get_2d_netcdf("T2D", ncid, t,     units, ixrt, jxrt, .TRUE., ierr)
+!DJG TBC    call get_2d_netcdf("T2D", ncid, t,     units, ixrt, jxrt, .TRUE., ierr)
+
+    ierr = nf_close(ncid)
+
+ end subroutine read_chan_forcing
+
+
+
+
+      subroutine get2d_int(var_name,out_buff,ix,jx,fileName)
+          implicit none
+#include 
+          integer :: iret,varid,ncid,ix,jx
+          integer out_buff(ix,jx)
+          character(len=*), intent(in) :: var_name
+          character(len=*), intent(in) :: fileName
+          iret = nf_open(trim(fileName), NF_NOWRITE, ncid)
+          if (iret .ne. 0) then
+#ifdef HYDRO_D
+            print*,"aaa failed to open the netcdf file: ",trim(fileName)
+            call hydro_stop()
+#endif
+          endif
+          iret = nf_inq_varid(ncid,trim(var_name),  varid)
+          if(iret .ne. 0) then
+#ifdef HYDRO_D
+            print*,"failed to read the variabe: ",trim(var_name)
+            print*,"failed to read the netcdf file: ",trim(fileName)
+#endif
+          endif
+          iret = nf_get_var_int(ncid, varid, out_buff)
+          iret = nf_close(ncid)
+         return
+      end subroutine get2d_int
+
+#ifdef MPP_LAND
+       SUBROUTINE MPP_READ_ROUTEDIM(g_IXRT,g_JXRT, IXRT,JXRT, &
+            route_chan_f,route_link_f, &
+            route_direction_f, route_lake_f, NLINKS, NLAKES, &
+            CH_NETLNK, channel_option, geo_finegrid_flnm)
+
+
+         USE module_mpp_land
+
+         implicit none
+#include 
+        INTEGER                                      :: channel_option
+        INTEGER                                      :: g_IXRT,g_JXRT
+        INTEGER, INTENT(INOUT)                       :: NLINKS, NLAKES
+        INTEGER, INTENT(IN)                          :: IXRT,JXRT
+        INTEGER                                      :: CHNID,cnt
+        INTEGER, DIMENSION(IXRT,JXRT)                :: CH_NETRT   !- binary channel mask
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK  !- each node gets unique id
+        INTEGER, DIMENSION(g_IXRT,g_JXRT) :: g_CH_NETLNK  ! temp array
+        INTEGER, DIMENSION(IXRT,JXRT)                :: DIRECTION  !- flow direction
+        INTEGER, DIMENSION(IXRT,JXRT)                :: LAKE_MSKRT
+        REAL, DIMENSION(IXRT,JXRT)                   :: LAT, LON
+
+
+        CHARACTER(len=256)       :: route_chan_f, route_link_f,route_direction_f,route_lake_f
+        CHARACTER(len=256)       :: geo_finegrid_flnm
+!       CHARACTER(len=*)       :: geo_finegrid_flnm
+
+        if(my_id .eq. IO_id) then
+          CALL READ_ROUTEDIM(g_IXRT, g_JXRT, route_chan_f, route_link_f, &
+              route_direction_f, route_lake_f, NLINKS, NLAKES, &
+              g_CH_NETLNK, channel_option,geo_finegrid_flnm)
+        endif
+        
+
+        call mpp_land_bcast_int1(NLAKES)
+        call mpp_land_bcast_int1(NLINKS)
+
+
+        call decompose_RT_int(g_CH_NETLNK,CH_NETLNK,g_IXRT,g_JXRT,ixrt,jxrt)
+       
+
+        return 
+        end SUBROUTINE MPP_READ_ROUTEDIM
+
+      SUBROUTINE MPP_READ_ROUTING(IXRT,JXRT,ELRT,  &
+              CH_NETRT,LKSATFAC,route_topo_f,    &
+            route_chan_f, geo_finegrid_flnm,g_IXRT,g_JXRT, &
+            OVROUGHRTFAC,RETDEPRTFAC)
+
+        implicit none
+#include 
+        INTEGER, INTENT(IN)                          :: IXRT,JXRT,g_IXRT,g_JXRT
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT)    :: ELRT,LKSATFAC
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT)    :: OVROUGHRTFAC,RETDEPRTFAC
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT
+
+        REAL, DIMENSION(g_IXRT,g_JXRT)               :: g1_ELRT
+        INTEGER,DIMENSION(g_IXRT,g_JXRT)             :: g1_CH_NETRT
+        REAL, DIMENSION(g_IXRT,g_JXRT)               :: g1_LKSATFAC
+        REAL, DIMENSION(g_IXRT,g_JXRT)               :: g1_OVROUGHRTFAC
+        REAL, DIMENSION(g_IXRT,g_JXRT)               :: g1_RETDEPRTFAC
+
+        CHARACTER(len=256)                           :: route_topo_f,route_chan_f,geo_finegrid_flnm
+
+        if(my_id .eq. IO_id)  then
+          CALL READ_ROUTING_seq(g_IXRT,g_JXRT,g1_ELRT,g1_CH_NETRT,g1_LKSATFAC,&
+              route_topo_f, route_chan_f,geo_finegrid_flnm,g1_OVROUGHRTFAC,&
+               g1_RETDEPRTFAC)
+        endif
+
+        call decompose_RT_real(g1_ELRT,ELRT,g_IXRT,g_JXRT,IXRT,JXRT)
+        call decompose_RT_int(g1_CH_NETRT,CH_NETRT,g_IXRT,g_JXRT,IXRT,JXRT)
+        call decompose_RT_real(g1_LKSATFAC,LKSATFAC,g_IXRT,g_JXRT,IXRT,JXRT)
+        call decompose_RT_real(g1_RETDEPRTFAC,RETDEPRTFAC,g_IXRT,g_JXRT,IXRT,JXRT)
+        call decompose_RT_real(g1_OVROUGHRTFAC,OVROUGHRTFAC,g_IXRT,g_JXRT,IXRT,JXRT)
+
+       return
+       end SUBROUTINE MPP_READ_ROUTING
+
+
+      subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,&
+                 global_nX, global_ny,nsoil,out_SMC,out_SH2OX)
+        implicit none
+#include 
+
+        integer,  intent(in)  :: ix,global_nx,global_ny
+        integer,  intent(in)  :: jx,nsoil
+        real,             dimension(ix,jx), intent(in) :: in_smcmax
+        real,             dimension(ix,jx,nsoil), intent(out) :: out_smc,out_sh2ox
+
+        real,dimension(global_nX, global_ny,nsoil):: g_smc, g_sh2ox
+        real,dimension(global_nX, global_ny):: g_smcmax
+        integer   :: i,j,k
+       
+
+          call write_IO_real(in_smcmax,g_smcmax)  ! get global grid of smcmax
+
+          write (*,*) "In deep GW...", nsoil
+
+!loop to overwrite soils to saturation...
+        do i=1,global_nx
+         do j=1,global_ny
+            g_smc(i,j,1:NSOIL) = g_smcmax(i,j)
+            g_sh2ox(i,j,1:NSOIL) = g_smcmax(i,j)
+         end do 
+        end do 
+
+!decompose global grid to parallel tiles...
+       do k=1,nsoil
+        call decompose_data_real(g_smc(:,:,k),out_smc(:,:,k))
+        call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k))
+       end do
+
+        return 
+        end  subroutine MPP_DEEPGW_HRLDAS
+
+
+       SUBROUTINE MPP_READ_CHROUTING(IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, &
+            FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, &
+            NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, &
+            HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, &
+            ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, &
+            route_link_f, &
+            route_lake_f, route_direction_f, route_order_f, &
+            CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, &
+            CHANXI, CHANYJ, CHLAT, CHLON,  &
+            channel_option,LATVAL,&
+            LONVAL,STRMFRXSTPTS,geo_finegrid_flnm,g_ixrt,g_jxrt)
+        implicit none
+#include 
+        INTEGER, INTENT(IN)                          :: IXRT,JXRT,g_IXRT,g_JXRT
+!yw        INTEGER, INTENT(IN)                       :: CHANRTSWCRT, NLINKS, NLAKES
+        INTEGER                                      :: CHANRTSWCRT, NLINKS, NLAKES
+        INTEGER                                      :: I,J,channel_option
+        REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_LATVAL, g1_LONVAL
+        CHARACTER(len=28)                            :: dir
+
+!----DJG,DNY New variables for channel and lake routing
+        CHARACTER(len=155)	 :: header
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: FROM_NODE
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: ZELEV
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: CHLAT,CHLON
+
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: TYPEL
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: TO_NODE,ORDER
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: STRMFRXSTPTS
+
+        INTEGER, INTENT(INOUT)                       :: MAXORDER
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: MUSK, MUSX !muskingum
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS,2)    :: QLINK  !channel flow
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: CHANLEN   !channel length
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: MannN, So !mannings N
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: LAKENODE  ! identifies which nodes pour into which lakes
+        REAL, INTENT(IN)                             :: dist(ixrt,jxrt,9)
+
+
+!-- store the location x,y location of the channel element
+         INTEGER, INTENT(INOUT), DIMENSION(NLINKS)   :: CHANXI, CHANYJ
+
+!--reservoir/lake attributes
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: HRZAREA
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: LAKEMAXH
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: WEIRC
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: WEIRL
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: ORIFICEC
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: ORIFICEA
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: ORIFICEE
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: LATLAKE,LONLAKE,ELEVLAKE
+        REAL, INTENT(INOUT), DIMENSION(NLINKS)       :: ChSSlp, Bw
+
+        CHARACTER(len=256)                           :: route_link_f
+        CHARACTER(len=256)                           :: route_lake_f
+        CHARACTER(len=256)                           :: route_direction_f
+        CHARACTER(len=256)                           :: route_order_f
+        CHARACTER(len=256)                           :: geo_finegrid_flnm
+        CHARACTER(len=256)                           :: var_name
+
+        INTEGER                                      :: tmp, cnt, ncid
+        real                                         :: gc,n
+
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT)    :: CH_NETLNK
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)       :: ELRT
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT)    :: latval,lonval
+        real      g1_elrt(g_ixrt,g_jxrt), g_dist(g_ixrt,g_jxrt,9)
+        integer   g1_ch_netrt(g_ixrt,g_jxrt)
+        INTEGER, DIMENSION(g_IXRT,g_JXRT)            :: g1_LAKE_MSKRT, g1_ch_netlnk
+        integer :: k
+
+
+        call write_IO_rt_real(elrt,g1_elrt)
+        call write_IO_rt_int(ch_netrt,g1_ch_netrt)
+        call write_IO_rt_int(CH_NETLNK,g1_CH_NETLNK)
+!       if(dist(1,1,1) .ne. -999) then
+            do k = 1, 9
+                call write_IO_rt_real(dist(:,:,k),g_dist(:,:,k))
+            end do
+!       endif
+
+        if(my_id .eq. IO_id) then
+          CALL READ_CHROUTING(g_IXRT,g_JXRT,g1_ELRT,g1_CH_NETRT, g1_LAKE_MSKRT, &
+               FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, &
+               NLAKES, MUSK, MUSX, QLINK,CHANLEN, MannN, So, ChSSlp, Bw, &
+               HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, &
+              ORIFICEA, ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, &
+               route_link_f,route_lake_f, &
+               route_direction_f, route_order_f, &
+               CHANRTSWCRT,g_dist, ZELEV, LAKENODE, g1_CH_NETLNK, CHANXI, CHANYJ, &
+               CHLAT, CHLON, channel_option, g1_latval,g1_lonval,&
+               STRMFRXSTPTS,geo_finegrid_flnm)
+        endif
+
+        call decompose_RT_int(g1_LAKE_MSKRT,LAKE_MSKRT,g_IXRT,G_JXRT,ixrt,jxrt)
+        call decompose_RT_real(g1_latval,latval,g_IXRT,G_JXRT,ixrt,jxrt)
+        call decompose_RT_real(g1_lonval,lonval,g_IXRT,G_JXRT,ixrt,jxrt)
+
+!        do k = 1, 9
+!           call decompose_RT_real(g_dist(:,:,k),dist(:,:,k),g_IXRT,G_JXRT,ixrt,jxrt)
+!        end do
+
+        return 
+        end SUBROUTINE MPP_READ_CHROUTING
+#endif
+        
+      SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f,    &
+            route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC)
+
+
+#include 
+        INTEGER, INTENT(IN) :: IXRT,JXRT
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT
+!Dummy inverted grids
+        REAL, DIMENSION(IXRT,JXRT) :: ELRT_inv,LKSATFAC_inv
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC
+        REAL, DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC_inv
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC
+        REAL, DIMENSION(IXRT,JXRT) :: RETDEPRTFAC_inv
+        INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT_inv
+
+        INTEGER         :: I,J, iret, jj
+        CHARACTER(len=256)        :: var_name
+        CHARACTER(len=256)       :: route_topo_f
+        CHARACTER(len=256)       :: route_chan_f
+        CHARACTER(len=256)       :: geo_finegrid_flnm
+
+        var_name = "TOPOGRAPHY"
+
+        iret = get2d_real(var_name,ELRT_inv,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+#ifdef HYDRO_D
+        if(iret .ne. 0) then
+            write(6,*) "Error reading TOPOGRAPHY failed" 
+            call hydro_stop()
+        endif
+        write(6,*) "read ",var_name
+#endif
+
+!!!DY to be fixed ... 6/27/08
+!        var_name = "BED_ELEVATION"
+!        iret = get2d_real(var_name,ELRT,ixrt,jxrt,&
+!                     trim(geo_finegrid_flnm))
+
+        var_name = "CHANNELGRID"
+        call get2d_int(var_name,CH_NETRT_inv,ixrt,jxrt,&
+               trim(geo_finegrid_flnm))
+
+#ifdef HYDRO_D
+        write(6,*) "read ",var_name
+#endif
+
+        var_name = "LKSATFAC"
+        LKSATFAC_inv = -9999.9
+        iret = get2d_real(var_name,LKSATFAC_inv,ixrt,jxrt,&
+               trim(geo_finegrid_flnm))
+
+#ifdef HYDRO_D
+        write(6,*) "read ",var_name
+#endif
+
+           where (LKSATFAC_inv == -9999.9) LKSATFAC_inv = 1000.0  !specify LKSAFAC if no term avail...
+
+
+!1.12.2012...Read in routing calibration factors...
+        var_name = "RETDEPRTFAC"
+        iret = get2d_real(var_name,RETDEPRTFAC_inv,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+        where (RETDEPRTFAC_inv < 0.) RETDEPRTFAC_inv = 1.0  ! reset grid to = 1.0 if non-valid value exists
+
+        var_name = "OVROUGHRTFAC"
+        iret = get2d_real(var_name,OVROUGHRTFAC_inv,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+        where (OVROUGHRTFAC_inv <= 0.) OVROUGHRTFAC_inv = 1.0 ! reset grid to = 1.0 if non-valid value exists
+
+
+
+!!!Flip y-dimension of highres grids from exported Arc files...
+
+        do i=1,ixrt
+        jj=jxrt
+         do j=1,jxrt
+           ELRT(i,j)=ELRT_inv(i,jj)
+           CH_NETRT(i,j)=CH_NETRT_inv(i,jj)
+           LKSATFAC(i,j)=LKSATFAC_inv(i,jj)
+           RETDEPRTFAC(i,j)=RETDEPRTFAC_inv(i,jj)
+           OVROUGHRTFAC(i,j)=OVROUGHRTFAC_inv(i,jj)
+           jj=jxrt-j
+         end do
+        end do
+
+#ifdef HYDRO_D
+        write(6,*) "finish READ_ROUTING_seq"
+#endif
+
+        return
+
+!DJG -----------------------------------------------------
+   END SUBROUTINE READ_ROUTING_seq
+!DJG _____________________________
+   subroutine output_lsm(outFile,did)
+
+
+   implicit none
+
+   integer did
+
+   character(len=*) outFile
+
+    integer :: ncid,irt, dimid_ix, dimid_jx,  &
+             dimid_ixrt, dimid_jxrt, varid, &
+             dimid_links, dimid_basns, dimid_soil
+    integer :: iret
+
+
+
+#ifdef MPP_LAND
+     if(IO_id.eq.my_id) &
+#endif
+
+#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#else
+       iret = nf_create(trim(outFile), NF_CLOBBER, ncid)
+#endif
+
+#ifdef MPP_LAND
+       call mpp_land_bcast_int1(iret)
+#endif
+
+#ifdef HYDRO_D
+       if (iret /= 0) then
+          print*, "Problem nf_create"
+          call hydro_stop()
+       endif
+#endif
+
+
+#ifdef MPP_LAND
+     if(IO_id.eq.my_id) then
+#endif
+#ifdef HYDRO_D
+         write(6,*) "output file ", outFile
+#endif
+! define dimension for variables 
+          iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil)  !-- 3-d soils
+   
+#ifdef MPP_LAND
+          iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx)
+#else
+          iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx)
+#endif
+    
+!define variables
+          iret = nf_def_var(ncid,"stc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid)
+          iret = nf_def_var(ncid,"smc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid)
+          iret = nf_def_var(ncid,"sh2ox",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid)
+          iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+
+          iret = nf_enddef(ncid)
+
+#ifdef MPP_LAND
+    endif
+#endif
+        call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc")
+        call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc")
+        call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
+        call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") 
+        call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" )
+        call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1"  ) 
+        call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt"  ) 
+        call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SFCHEADRT,"sfcheadrt" )
+
+#ifdef MPP_LAND
+     if(IO_id.eq.my_id) then
+#endif
+
+        iret = nf_close(ncid)
+#ifdef HYDRO_D
+        write(6,*) "finish writing outFile : ", outFile
+#endif
+
+#ifdef MPP_LAND
+    endif
+#endif
+
+        return
+        end subroutine output_lsm
+
+
+   subroutine RESTART_OUT_nc(outFile,did)
+
+
+   implicit none
+
+   integer did
+
+   character(len=*) outFile
+
+    integer :: ncid,irt, dimid_ix, dimid_jx,  &
+             dimid_ixrt, dimid_jxrt, varid, &
+             dimid_links, dimid_basns, dimid_soil
+    integer :: iret
+
+
+#ifdef MPP_LAND
+     if(IO_id.eq.my_id) &
+#endif
+
+#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#else
+       iret = nf_create(trim(outFile), NF_CLOBBER, ncid)
+#endif
+
+
+#ifdef MPP_LAND
+       call mpp_land_bcast_int1(iret)
+#endif
+
+#ifdef HYDRO_D
+       if (iret /= 0) then
+          print*, "Problem nf_create"
+          call hydro_stop()
+       endif
+#endif
+
+#ifdef MPP_LAND
+     if(IO_id.eq.my_id) then
+#endif
+! define dimension for variables 
+          iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil)  !-- 3-d soils
+   
+#ifdef MPP_LAND
+          iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx)
+          iret = nf_def_dim(ncid, "ixrt", global_rt_nx , dimid_ixrt)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iyrt", global_rt_ny, dimid_jxrt)
+#else
+          iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx)
+          iret = nf_def_dim(ncid, "ixrt", rt_domain(did)%ixrt , dimid_ixrt)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iyrt", rt_domain(did)%jxrt, dimid_jxrt)
+#endif
+
+          iret = nf_def_dim(ncid, "links", rt_domain(did)%nlinks, dimid_links)
+          iret = nf_def_dim(ncid, "basns", rt_domain(did)%numbasns, dimid_basns)
+
+!define variables
+          iret = nf_def_var(ncid,"stc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid)
+          iret = nf_def_var(ncid,"smc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid)
+          iret = nf_def_var(ncid,"sh2ox",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid)
+    
+          iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+!         iret = nf_def_var(ncid,"soldrain",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+
+          if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then
+            iret = nf_def_var(ncid,"infxswgt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+            iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+            iret = nf_def_var(ncid,"sh2owgt",NF_FLOAT,3,(/dimid_ixrt,dimid_jxrt,dimid_soil/),varid)
+            if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then
+              iret = nf_def_var(ncid,"hlink",NF_FLOAT,1,(/dimid_links/),varid)
+              iret = nf_def_var(ncid,"qlink1",NF_FLOAT,1,(/dimid_links/),varid)
+              iret = nf_def_var(ncid,"qlink2",NF_FLOAT,1,(/dimid_links/),varid)
+              iret = nf_def_var(ncid,"cvol",NF_FLOAT,1,(/dimid_links/),varid)
+              iret = nf_def_var(ncid,"resht",NF_FLOAT,1,(/dimid_links/),varid)
+              iret = nf_def_var(ncid,"qlakeo",NF_FLOAT,1,(/dimid_links/),varid)
+              iret = nf_def_var(ncid,"lake_inflort",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+              iret = nf_def_var(ncid,"qstrmvolrt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+            end if
+            if(nlst_rt(did)%GWBASESWCRT.EQ.1) then
+              iret = nf_def_var(ncid,"z_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid)
+            end if
+          end if  
+
+!         put global attribute
+          iret = nf_put_att_int(ncid,NF_GLOBAL,"his_out_counts",NF_INT, 1,rt_domain(did)%his_out_counts)
+
+          iret = nf_enddef(ncid)
+
+#ifdef MPP_LAND
+    endif
+#endif
+       call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc")
+        call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc")
+        call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
+
+
+       call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") 
+       call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" )
+       call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1"  ) 
+       call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt"  ) 
+!      call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain"  ) 
+       call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt"  ) 
+
+
+        if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then
+            call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT, "infxswgt" )
+            call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT, "QBDRYRT" )
+            call w_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT, "sh2owgt" )
+            if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then
+              call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%HLINK,"hlink" &
+#ifdef MPP_LAND
+                 ,rt_domain(did)%nlinks_index, rt_domain(did)%mpp_nlinks  &
+#endif
+                  )
+
+              call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,1),"qlink1" &
+#ifdef MPP_LAND
+                 ,rt_domain(did)%nlinks_index, rt_domain(did)%mpp_nlinks  &
+#endif
+                  )
+
+
+              call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,2),"qlink2" &
+#ifdef MPP_LAND
+                 ,rt_domain(did)%nlinks_index, rt_domain(did)%mpp_nlinks  &
+#endif
+                  )
+
+
+              call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%cvol,"cvol" &
+#ifdef MPP_LAND
+                 ,rt_domain(did)%nlinks_index, rt_domain(did)%mpp_nlinks  &
+#endif
+                  )
+
+              call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%resht,"resht" &
+#ifdef MPP_LAND
+                 ,rt_domain(did)%lake_index, rt_domain(did)%mpp_nlinks  &
+#endif
+                  )
+
+              call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%qlakeo,"qlakeo" &
+#ifdef MPP_LAND
+                 ,rt_domain(did)%lake_index, rt_domain(did)%mpp_nlinks  &
+#endif
+                  )
+
+
+              call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort")
+              call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT, "qstrmvolrt" )
+
+            end if
+
+            if(nlst_rt(did)%GWBASESWCRT.EQ.1) then
+              call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,"z_gwsubbas" )
+            end if
+        end if  
+
+#ifdef MPP_LAND
+        if(IO_id.eq.my_id) &
+#endif
+        iret = nf_close(ncid)
+
+        return
+        end subroutine RESTART_OUT_nc
+
+        subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName)
+           implicit none
+           integer:: ncid,ix,jx,varid , iret
+           character(len=*) varName
+           real, dimension(ix,jx):: inVar
+#ifdef MPP_LAND
+           real, dimension(global_rt_nx, global_rt_ny):: varTmp
+           call write_IO_rt_real(inVar,varTmp) 
+           if(my_id .eq. IO_id) then
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_rt_nx,global_rt_ny/),varTmp)
+           endif
+#else
+           iret = nf_inq_varid(ncid,varName, varid)
+           iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),inVar)
+#endif
+           
+           return
+        end subroutine w_rst_rt_nc2
+
+        subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName)
+           implicit none
+           integer:: ncid,ix,jx,varid , iret, nsoil
+           character(len=*) varName
+           real,dimension(ix,jx,nsoil):: inVar
+#ifdef MPP_LAND
+           integer k
+           real varTmp(global_rt_nx,global_rt_ny,nsoil)
+           do k = 1, nsoil
+              call write_IO_rt_real(inVar(:,:,k),varTmp(:,:,k)) 
+           end do
+           if(my_id .eq. IO_id) then
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/global_rt_nx,global_rt_ny,nsoil/),varTmp)
+           endif
+#else
+           iret = nf_inq_varid(ncid,varName, varid)
+           iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ix,jx,nsoil/),inVar)
+#endif
+           return
+        end subroutine w_rst_rt_nc3
+
+        subroutine w_rst_nc2(ncid,ix,jx,inVar,varName)
+           implicit none
+           integer:: ncid,ix,jx,varid , iret
+           character(len=*) varName
+           real inVar(ix,jx)
+
+#ifdef MPP_LAND
+           real varTmp(global_nx,global_ny)
+           call write_IO_real(inVar,varTmp) 
+           if(my_id .eq. IO_id) then
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_nx,global_ny/),varTmp)
+           endif
+#else
+           iret = nf_inq_varid(ncid,varName, varid)
+           iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),invar)
+#endif
+           
+           return
+        end subroutine w_rst_nc2
+
+        subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName)
+           implicit none
+           integer:: ncid,ix,jx,varid , iret, nsoil
+           character(len=*) varName
+           real inVar(ix,jx,nsoil)
+           integer k
+#ifdef MPP_LAND
+           real varTmp(global_nx,global_ny,nsoil)
+           do k = 1, nsoil
+              call write_IO_real(inVar(:,:,k),varTmp(:,:,k)) 
+           end do
+           if(my_id .eq. IO_id) then
+             iret = nf_inq_varid(ncid,varName, varid)
+             iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/global_nx,global_ny,nsoil/),varTmp)
+           endif
+#else
+           iret = nf_inq_varid(ncid,varName, varid)
+           iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ix,jx,nsoil/),inVar)
+#endif
+           return
+        end subroutine w_rst_nc3
+
+        subroutine w_rst_crt_nc1(ncid,n,inVar,varName &
+#ifdef MPP_LAND
+                 ,index, mpp_n&
+#endif
+                  )
+           implicit none
+           integer:: ncid,n,varid , iret
+           character(len=*) varName
+           real inVar(n)
+#ifdef MPP_LAND
+           integer:: index(n),mpp_n
+           call write_chanel_real(inVar,index,mpp_n,n)          
+           if(my_id .eq. IO_id) then
+#endif
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar)
+#ifdef MPP_LAND
+           endif
+#endif
+           return
+        end subroutine w_rst_crt_nc1
+
+        subroutine w_rst_crt_nc1g(ncid,n,inVar,varName)
+           implicit none
+           integer:: ncid,n,varid , iret
+           character(len=*) varName
+           real inVar(n)
+#ifdef MPP_LAND
+           if(my_id .eq. IO_id) then
+#endif
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar)
+#ifdef MPP_LAND
+           endif
+#endif
+           return
+        end subroutine w_rst_crt_nc1g
+
+   subroutine RESTART_IN_NC(inFile,did)
+
+
+   implicit none
+   character(len=*) inFile
+   integer  :: ierr, iret,ncid, did
+
+    integer :: i, j
+
+
+#ifdef MPP_LAND
+     if(IO_id .eq. my_id) then
+#endif
+!open a netcdf file 
+    iret = nf_open(trim(inFile), NF_NOWRITE, ncid)
+#ifdef MPP_LAND
+    endif
+    call mpp_land_bcast_int1(iret)
+#endif
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       write(*,'("Problem opening file: ''", A, "''")') &
+            trim(inFile)
+       call hydro_stop() 
+#endif
+    endif
+
+#ifdef MPP_LAND
+     if(IO_id .eq. my_id) then
+#endif
+        iret = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'his_out_counts', rt_domain(did)%his_out_counts) 
+#ifdef MPP_LAND
+    endif
+    call mpp_land_bcast_int1(rt_domain(did)%out_counts)
+#endif
+
+#ifdef HYDRO_D
+     write(6,*) "nlst_rt(did)%nsoil=",nlst_rt(did)%nsoil
+#endif
+     if(nlst_rt(did)%rst_typ .eq. 1 ) then 
+        call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc")
+        call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc")
+        call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
+        call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt")
+!       call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain")
+        call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt")
+     endif
+ 
+        call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1")
+        call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1")
+        call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1")
+
+
+        if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then
+            call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT,"infxswgt")
+            call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT,"QBDRYRT")
+            call read_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT,"sh2owgt")
+            if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then
+              call read_rst_crt_nc(ncid,rt_domain(did)%HLINK,rt_domain(did)%NLINKS,"hlink")
+              call read_rst_crt_nc(ncid,rt_domain(did)%QLINK(:,1),rt_domain(did)%NLINKS,"qlink1")
+              call read_rst_crt_nc(ncid,rt_domain(did)%QLINK(:,2),rt_domain(did)%NLINKS,"qlink2")
+              call read_rst_crt_nc(ncid,rt_domain(did)%CVOL,rt_domain(did)%NLINKS,"cvol")
+              call read_rst_crt_nc(ncid,rt_domain(did)%RESHT,rt_domain(did)%nlinks,"resht")
+              call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEO,rt_domain(did)%nlinks,"qlakeo")
+              call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort")
+              call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT,"qstrmvolrt")
+            end if
+            if(nlst_rt(did)%GWBASESWCRT.EQ.1.AND.nlst_rt(did)%GW_RESTART.NE.0) then
+                 call read_rst_crt_nc(ncid,rt_domain(did)%z_gwsubbas,rt_domain(did)%numbasns,"z_gwsubbas")
+            end if
+        end if
+
+          if(nlst_rt(did)%rstrt_swc.eq.1) then  !Switch for rest of restart accum vars...
+#ifdef HYDRO_D
+            print *, "1 Resetting RESTART Accumulation Variables to 0...",nlst_rt(did)%rstrt_swc
+#endif
+            rt_domain(did)%INFXSRT=0.
+            rt_domain(did)%LAKE_INFLORT=0.
+            rt_domain(did)%QSTRMVOLRT=0.
+          end if
+
+      
+#ifdef MPP_LAND
+        if(my_id .eq. IO_id) &
+#endif
+        iret =  nf_close(ncid) 
+#ifdef HYDRO_D
+        write(6,*) "end of RESTART_IN"
+#endif
+ 
+        return
+        end subroutine RESTART_IN_nc
+
+      subroutine read_rst_nc3(ncid,ix,jx,NSOIL,var,varStr)
+         implicit none 
+         integer ::  ix,jx,nsoil, ireg, ncid, varid, iret
+         real,dimension(ix,jx,nsoil) ::  var
+         character(len=*) :: varStr
+#ifdef MPP_LAND
+         real,dimension(global_nx,global_ny,nsoil) :: xtmp
+         integer i
+
+         if(my_id .eq. IO_id) & 
+#endif
+           iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+
+         if (iret /= 0) then
+#ifdef HYDRO_D
+            print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+            return
+         endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) & 
+            iret = nf_get_var_real(ncid, varid, xtmp)
+
+         do i = 1, nsoil
+            call decompose_data_real(xtmp(:,:,i), var(:,:,i))
+         end do
+#else
+            iret = nf_get_var_real(ncid, varid, var)
+#endif
+
+         return
+      end subroutine read_rst_nc3
+
+      subroutine read_rst_nc2(ncid,ix,jx,var,varStr)
+         implicit none
+         integer ::  ix,jx,ireg, ncid, varid, iret
+         real,dimension(ix,jx) ::  var
+         character(len=*) :: varStr
+#ifdef MPP_LAND
+         real,dimension(global_nx,global_ny) :: xtmp 
+         if(my_id .eq. IO_id) & 
+#endif
+           iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+
+         if (iret /= 0) then
+#ifdef HYDRO_D
+            print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+            return
+         endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) & 
+            iret = nf_get_var_real(ncid, varid, xtmp)
+
+         call decompose_data_real(xtmp, var)
+#else
+            iret = nf_get_var_real(ncid, varid, var)
+#endif
+         return
+      end subroutine read_rst_nc2
+
+      subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr)
+         implicit none
+         integer ::  ix,jx,nsoil, ireg, ncid, varid, iret
+         real,dimension(ix,jx,nsoil) ::  var
+         character(len=*) :: varStr
+#ifdef MPP_LAND
+         real,dimension(global_rt_nx,global_rt_ny,nsoil) :: xtmp
+         integer i
+         if(my_id .eq. IO_id) & 
+#endif
+            iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+         if (iret /= 0) then
+#ifdef HYDRO_D
+            print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+            return
+         endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif
+#ifdef MPP_LAND
+         iret = nf_get_var_real(ncid, varid, xtmp)
+         do i = 1, nsoil
+            call decompose_RT_real(xtmp(:,:,i),var(:,:,i),global_rt_nx,global_rt_ny,ix,jx)
+         end do
+#else
+         iret = nf_get_var_real(ncid, varid, var)
+#endif
+         return
+      end subroutine read_rst_rt_nc3
+
+      subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr)
+         implicit none
+         integer ::  ix,jx,ireg, ncid, varid, iret
+         real,dimension(ix,jx) ::  var
+         character(len=*) :: varStr
+#ifdef MPP_LAND
+         real,dimension(global_rt_nx,global_rt_ny) :: xtmp 
+#endif
+         iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+         if (iret /= 0) then
+#ifdef HYDRO_D
+            print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+            return
+         endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) &   
+             iret = nf_get_var_real(ncid, varid, xtmp)
+         call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx)
+#else
+            iret = nf_get_var_real(ncid, varid, var)
+#endif
+         return
+      end subroutine read_rst_rt_nc2
+
+      subroutine read_rt_nc2(ncid,ix,jx,var,varStr)
+         implicit none
+         integer ::  ix,jx, ncid, varid, iret
+         real,dimension(ix,jx) ::  var
+         character(len=*) :: varStr
+
+#ifdef MPP_LAND
+         real,dimension(global_rt_nx,global_rt_ny) :: xtmp
+#endif
+            iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+            if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+               return
+            endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) then
+            iret = nf_get_var_real(ncid, varid, xtmp)
+         endif
+         call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx)
+#else
+            iret = nf_get_var_real(ncid, varid, var)
+#endif
+         return
+      end subroutine read_rt_nc2
+
+      subroutine read_rst_crt_nc(ncid,var,n,varStr)
+         implicit none
+         integer ::  ireg, ncid, varid, n, iret
+         real,dimension(n) ::  var
+         character(len=*) :: varStr
+
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) & 
+#endif
+            iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+            if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+               return
+            endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) then
+#endif
+            iret = nf_get_var_real(ncid, varid, var)
+#ifdef MPP_LAND
+         endif
+         call mpp_land_bcast_real(n,var)
+#endif
+         return
+      end subroutine read_rst_crt_nc 
+
+      subroutine hrldas_out()
+      end subroutine hrldas_out
+
+      SUBROUTINE READ_ROUTING_old(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f,    &
+            route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC)
+
+
+#include 
+        INTEGER, INTENT(IN) :: IXRT,JXRT
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT
+!Dummy inverted grids
+        REAL, DIMENSION(IXRT,JXRT) :: ELRT_inv,LKSATFAC_inv
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC
+        REAL, DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC_inv
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC
+        REAL, DIMENSION(IXRT,JXRT) :: RETDEPRTFAC_inv
+        INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT_inv
+
+        INTEGER         :: I,J, iret, jj
+        CHARACTER(len=256)        :: var_name
+        CHARACTER(len=256)       :: route_topo_f
+        CHARACTER(len=256)       :: route_chan_f
+        CHARACTER(len=256)       :: geo_finegrid_flnm
+
+        var_name = "TOPOGRAPHY"
+        iret = get2d_real(var_name,ELRT_inv,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+#ifdef HYDRO_D
+        write(6,*) "read ",var_name
+#endif
+
+!!!DY to be fixed ... 6/27/08
+!        var_name = "BED_ELEVATION"
+!        iret = get2d_real(var_name,ELRT,ixrt,jxrt,&
+!                     trim(geo_finegrid_flnm))
+
+        var_name = "CHANNELGRID"
+        call get2d_int(var_name,CH_NETRT_inv,ixrt,jxrt,&
+               trim(geo_finegrid_flnm))
+
+#ifdef HYDRO_D
+        write(6,*) "read ",var_name
+#endif
+
+        var_name = "LKSATFAC"
+        LKSATFAC_inv = -9999.9
+        iret = get2d_real(var_name,LKSATFAC_inv,ixrt,jxrt,&
+               trim(geo_finegrid_flnm))
+#ifdef HYDRO_D
+        write(6,*) "read ",var_name
+#endif
+
+           where (LKSATFAC_inv == -9999.9) LKSATFAC_inv = 1000.0  !specify LKSAFAC if no term avail...
+
+
+!1.12.2012...Read in routing calibration factors...
+        var_name = "RETDEPRTFAC"
+        iret = get2d_real(var_name,RETDEPRTFAC_inv,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+        where (RETDEPRTFAC_inv < 0.) RETDEPRTFAC_inv = 1.0  ! reset grid to = 1.0 if non-valid value exists
+
+        var_name = "OVROUGHRTFAC"
+        iret = get2d_real(var_name,OVROUGHRTFAC_inv,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+        where (OVROUGHRTFAC_inv <= 0.) OVROUGHRTFAC_inv = 1.0 ! reset grid to = 1.0 if non-valid value exists
+
+
+
+!!!Flip y-dimension of highres grids from exported Arc files...
+
+        do i=1,ixrt
+        jj=jxrt
+         do j=1,jxrt
+           ELRT(i,j)=ELRT_inv(i,jj)
+           CH_NETRT(i,j)=CH_NETRT_inv(i,jj)
+           LKSATFAC(i,j)=LKSATFAC_inv(i,jj)
+           RETDEPRTFAC(i,j)=RETDEPRTFAC_inv(i,jj)
+           OVROUGHRTFAC(i,j)=OVROUGHRTFAC_inv(i,jj)
+           jj=jxrt-j
+         end do
+        end do
+
+#ifdef HYDRO_D  
+        write(6,*) "finish READ_ROUTING_old"
+#endif
+
+        return
+
+!DJG -----------------------------------------------------
+   END SUBROUTINE READ_ROUTING_old
+!DJG _____________________________
+
+end module module_HYDRO_io
diff --git a/wrfv2_fire/hydro/Routing/module_HYDRO_utils.F b/wrfv2_fire/hydro/Routing/module_HYDRO_utils.F
new file mode 100644
index 00000000..0737dbd3
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_HYDRO_utils.F
@@ -0,0 +1,414 @@
+module module_HYDRO_utils
+  use module_RT_data, only: rt_domain
+  use module_namelist, only: nlst_rt
+#ifdef MPP_LAND
+     use module_mpp_land, only: global_nx, global_ny, my_id, IO_id, &
+           decompose_data_real, write_io_real, MPP_LAND_COM_REAL, &
+           write_io_int, mpp_land_bcast_real, global_rt_nx, global_rt_ny, &
+           decompose_rt_real, write_io_rt_real
+#endif
+
+
+  implicit none
+  logical lr_dist_flag    !land routing distance calculated or not. 
+  
+contains
+
+        integer function get2d_real(var_name,out_buff,ix,jx,fileName)
+          implicit none
+#         include "netcdf.inc"
+          integer :: ivar, iret,varid,ncid,ix,jx
+          real out_buff(ix,jx)
+          character(len=*), intent(in) :: var_name
+          character(len=*), intent(in) :: fileName
+          get2d_real = -1
+
+          iret = nf_open(trim(fileName), NF_NOWRITE, ncid)
+          if (iret .ne. 0) then
+#ifdef HYDRO_D
+            print*,"failed to open the netcdf file: ",trim(fileName)
+#endif
+            out_buff = -9999.
+            return
+          endif
+          ivar = nf_inq_varid(ncid,trim(var_name),  varid)
+          if(ivar .ne. 0) then
+            ivar = nf_inq_varid(ncid,trim(var_name//"_M"),  varid)
+            if(ivar .ne. 0) then
+#ifdef HYDRO_D
+               write(6,*) "Read Error: could not find ",var_name
+#endif
+                 return
+            endif
+          end if
+          iret = nf_get_var_real(ncid, varid, out_buff)
+          iret = nf_close(ncid)
+          get2d_real =  ivar
+      end function get2d_real
+
+ 
+! this module create the distance dx, dy and diagnoal for routing
+! 8 direction as the slop:
+! 1: i,j+1  
+! 2: i+1, j+1
+! 3: i+1, j
+! 4: i+1, j-1
+! 5: i, j-1
+! 6: i-1, j-1
+! 7: i-1, j
+! 8: i-1, j+1
+   real function get_dy(i,j,v,ix,jx)  
+      ! south north
+       integer :: i,j,ix,jx
+       real,dimension(ix,jx,9) :: v 
+       if( v(i,j,1) .le. 0) then
+          get_dy = v(i,j,5)
+       else if( v(i,j,5) .le. 0) then
+          get_dy = v(i,j,1)
+       else
+          get_dy = (v(i,j,1) + v(i,j,5) ) / 2
+       endif
+       return
+   end function get_dy
+
+   real function get_dx(i,j,v,ix,jx)   
+      ! east-west
+       integer :: i,j, ix,jx
+       real,dimension(ix,jx,9) :: v 
+       if( v(i,j,3) .le. 0) then
+          get_dx = v(i,j,7)
+       else if( v(i,j,7) .le. 0) then
+          get_dx = v(i,j,3)
+       else
+          get_dx = (v(i,j,3) + v(i,j,7) ) / 2
+       endif
+       return
+   end function get_dx
+
+   real function get_ll_d(lat1_in, lat2_in, lon1_in, lon2_in)
+     implicit none
+     real:: lat1, lat2, lon1, lon2
+     real:: lat1_in, lat2_in, lon1_in, lon2_in
+     real::  r, pai, a,c, dlat, dlon, b1,b2
+     pai = 3.14159
+     lat1 = lat1_in * pai/180
+     lat2 = lat2_in * pai/180
+     lon1 = lon1_in * pai/180
+     lon2 = lon2_in * pai/180
+     r = 6378.1*1000
+     dlat = lat2 -lat1
+     dlon = lon2 -lon1
+     a = sin(dlat/2)*sin(dlat/2) + cos(lat1)*cos(lat2)*sin(dlon/2)*sin(dlon/2)
+     b1 = sqrt(a) 
+     b2 = sqrt(1-a)  
+     c = 2.0*atan2(b1,b2)
+     get_ll_d = R*c
+     return 
+
+   end function get_ll_d
+
+   real function get_ll_d_tmp(lat1_in, lat2_in, lon1_in, lon2_in)
+     implicit none
+     real:: lat1, lat2, lon1, lon2
+     real:: lat1_in, lat2_in, lon1_in, lon2_in
+     real::  r, pai
+     pai = 3.14159
+     lat1 = lat1_in * pai/180
+     lat2 = lat2_in * pai/180
+     lon1 = lon1_in * pai/180
+     lon2 = lon2_in * pai/180
+     r = 6371*1000
+     get_ll_d_tmp = acos(sin(lat1)*sin(lat2)+cos(lat1)*cos(lat2)*cos(lon2-lon1))*r
+     return 
+
+   end function get_ll_d_tmp
+
+   subroutine get_rt_dxdy_ll(did)
+!   use the land lat and lon to derive the routing distrt
+      implicit none
+      integer:: did, k
+      integer iret
+!     external get2d_real
+!     real get2d_real
+#ifdef MPP_LAND
+      real, dimension(global_rt_nx,global_rt_ny):: latrt, lonrt
+      real, dimension(global_rt_nx,global_rt_ny,9):: dist
+      if(my_id .eq. IO_id) then
+ ! read the lat and lon. 
+         iret =  get2d_real("LONGITUDE",lonrt,global_rt_nx,global_rt_ny,&
+                     trim(nlst_rt(did)%GEO_FINEGRID_FLNM ))
+         iret =  get2d_real("LATITUDE",latrt,global_rt_nx,global_rt_ny,&
+                     trim(nlst_rt(did)%GEO_FINEGRID_FLNM ))
+         call get_dist_ll(dist,latrt,lonrt,global_rt_nx,global_rt_ny)
+      end if
+     do k = 1 , 9
+        call decompose_RT_real(dist(:,:,k),rt_domain(did)%dist(:,:,k), &
+                global_rt_nx,global_rt_ny,rt_domain(did)%ixrt,rt_domain(did)%jxrt)
+     end do
+#else
+      real, dimension(rt_domain(did)%ixrt,rt_domain(did)%jxrt):: latrt, lonrt
+ ! read the lat and lon. 
+         iret =  get2d_real("LONGITUDE",lonrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt,&
+                     trim(nlst_rt(did)%GEO_FINEGRID_FLNM ))
+         iret =  get2d_real("LATITUDE",latrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt,&
+                     trim(nlst_rt(did)%GEO_FINEGRID_FLNM ))
+         call get_dist_ll(rt_domain(did)%dist,latrt,lonrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt)
+#endif
+
+   end subroutine get_rt_dxdy_ll
+
+!  get dx and dy of lat and lon   
+   subroutine get_dist_ll(dist,lat,lon,ix,jx)
+      implicit none
+      integer:: ix,jx 
+      real, dimension(ix,jx,9):: dist
+      real, dimension(ix,jx):: lat, lon
+      integer:: i,j 
+      real x,y 
+      dist = -1
+      do j = 1, jx
+        do i = 1, ix
+          if(j .lt. jx) dist(i,j,1) = &
+             get_ll_d(lat(i,j), lat(i,j+1), lon(i,j), lon(i,j+1))
+          if(j .lt. jx .and. i .lt. ix) dist(i,j,2) =  &
+             get_ll_d(lat(i,j), lat(i+1,j+1), lon(i,j), lon(i+1,j+1))
+          if(i .lt. ix) dist(i,j,3) = &    
+             get_ll_d(lat(i,j), lat(i+1,j), lon(i,j), lon(i+1,j))
+          if(j .gt. 1 .and. i .lt. ix) dist(i,j,4) = &    
+             get_ll_d(lat(i,j), lat(i+1,j-1), lon(i,j), lon(i+1,j-1))
+          if(j .gt. 1 ) dist(i,j,5) = &   
+             get_ll_d(lat(i,j), lat(i,j-1), lon(i,j), lon(i,j-1))
+          if(j .gt. 1 .and. i .gt. 1) dist(i,j,6) = &   
+             get_ll_d(lat(i,j), lat(i-1,j-1), lon(i,j), lon(i-1,j-1))
+          if(i .gt. 1) dist(i,j,7) = &   
+             get_ll_d(lat(i,j), lat(i-1,j), lon(i,j), lon(i-1,j))
+          if(j .lt. jx .and. i .gt. 1) dist(i,j,8) = &   
+             get_ll_d(lat(i,j), lat(i-1,j+1), lon(i,j), lon(i-1,j+1))
+        end do
+      end do
+      do j = 1, jx 
+        do i = 1, ix
+            if(j.eq.1) then
+               y =  get_ll_d(lat(i,j), lat(i,j+1), lon(i,j), lon(i,j+1))
+            else if(j.eq.jx) then 
+               y =  get_ll_d(lat(i,j-1), lat(i,j), lon(i,j-1), lon(i,j))
+            else
+               y =  get_ll_d(lat(i,j-1), lat(i,j+1), lon(i,j-1), lon(i,j+1))/2.0
+            endif
+
+            if(i.eq.ix) then
+                x =  get_ll_d(lat(i,j), lat(i-1,j), lon(i,j), lon(i-1,j))
+            else if(i.eq.1) then
+                x =  get_ll_d(lat(i,j), lat(i+1,j), lon(i,j), lon(i+1,j))
+            else
+                x =  get_ll_d(lat(i-1,j), lat(i+1,j), lon(i-1,j), lon(i+1,j))/2.0
+            endif
+            dist(i,j,9) = x * y 
+        end do
+      end do
+#ifdef HYDRO_D
+      write(6,*) "finished get_dist_ll"
+#endif
+   end subroutine get_dist_ll
+
+!  get dx and dy of map projected
+   subroutine get_dxdy_mp(dist,ix,jx,dx,dy)
+      implicit none
+      integer:: ix,jx 
+      real :: dx,dy
+      integer:: i,j 
+      real :: v1
+      ! out variable
+      real, dimension(ix,jx,9)::dist
+      dist = -1
+      v1 = sqrt(dx*dx + dy*dy)
+      do j = 1, jx
+        do i = 1, ix
+          if(j .lt. jx) dist(i,j,1) = dy 
+          if(j .lt. jx .and. i .lt. ix) dist(i,j,2) = v1 
+          if(i .lt. ix) dist(i,j,3) = dx 
+          if(j .gt. 1 .and. i .lt. ix) dist(i,j,4) = v1 
+          if(j .gt. 1 ) dist(i,j,5) = dy 
+          if(j .gt. 1 .and. i .gt. 1) dist(i,j,6) = v1 
+          if(i .gt. 1) dist(i,j,7) = dx 
+          if(j .lt. jx .and. i .gt. 1) dist(i,j,8) = v1 
+          dist(i,j,9) = dx * dy
+        end do
+      end do
+#ifdef HYDRO_D
+      write(6,*) "finished get_dxdy_mp "
+#endif
+   end subroutine get_dxdy_mp
+
+   subroutine get_dist_lsm(did)
+     integer did
+#ifdef MPP_LAND
+     integer ix,jx,ixrt,jxrt, k
+     real , dimension(global_nx,global_ny):: latitude,longitude
+     real, dimension(global_nx,global_ny,9):: dist 
+     if(nlst_rt(did)%dxrt0 .lt. 0) then
+           ! lat and lon grid
+          call write_io_real(rt_domain(did)%lat_lsm,latitude) 
+          call write_io_real(rt_domain(did)%lon_lsm,longitude) 
+          if(my_id.eq.IO_id) then
+               call get_dist_ll(dist,latitude,longitude,  &
+                         global_nx,global_ny)
+          endif
+       
+     else
+           ! mapp projected grid.
+          if(my_id.eq.IO_id) then
+              call get_dxdy_mp(dist,global_nx,global_ny, &
+                 nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT,nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT)
+          endif
+     endif
+     do k = 1 , 9
+        call decompose_data_real(dist(:,:,k),rt_domain(did)%dist_lsm(:,:,k))
+     end do
+#else
+     if(nlst_rt(did)%dxrt0 .lt. 0) then
+        ! lat and lon grid
+        call get_dist_ll(rt_domain(did)%dist_lsm,rt_domain(did)%lat_lsm,rt_domain(did)%lon_lsm,  &
+                      rt_domain(did)%ix,rt_domain(did)%jx)
+     else
+        ! mapp projected grid.
+        call get_dxdy_mp(rt_domain(did)%dist_lsm,rt_domain(did)%ix,rt_domain(did)%jx, &
+              nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT,nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT)
+     endif
+#endif
+
+
+   end subroutine get_dist_lsm
+
+   subroutine get_dist_lrt(did)
+     integer did, k
+
+!     real :: tmp_dist(global_rt_nx, global_rt_ny,9)
+
+! calculate the distance for land routing from the lat /lon of land surface model
+     if(nlst_rt(did)%dxrt0 .lt. 0) then
+        ! using lat and lon grid when channel routing is off
+        call get_rt_dxdy_ll(did)
+     else
+        ! mapp projected grid.
+         call get_dxdy_mp(rt_domain(did)%dist,rt_domain(did)%ixrt,rt_domain(did)%jxrt, &
+              nlst_rt(did)%dxrt0,nlst_rt(did)%dxrt0)
+#ifdef MPP_LAND
+        do k = 1, 9
+           call MPP_LAND_COM_REAL(rt_domain(did)%dist(:,:,k),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+        end do
+#endif
+     endif
+
+
+   end subroutine get_dist_lrt
+
+!   subroutine get_dist_crt(did)
+!      integer did, k
+! calculate the distance from channel routing
+!     if(nlst_rt(did)%dxrt0 .lt. 0) then
+!        ! lat and lon grid
+!        if(rt_domain(did)%dist(1,1,9) .eq. -999)   &
+!           call get_dist_ll(rt_domain(did)%dist,rt_domain(did)%latval,rt_domain(did)%lonval,  &
+!                      rt_domain(did)%ixrt,rt_domain(did)%jxrt)
+!     else
+!        ! mapp projected grid.
+!        if(rt_domain(did)%dist(1,1,9) .eq. -999)   &
+!           call get_dxdy_mp(rt_domain(did)%dist,rt_domain(did)%ixrt,rt_domain(did)%jxrt, &
+!              nlst_rt(did)%dxrt0,nlst_rt(did)%dxrt0)
+!     endif
+!#ifdef MPP_LAND
+!     do k = 1, 9
+!       call MPP_LAND_COM_REAL(rt_domain(did)%dist(:,:,k),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+!     end do
+!#endif
+!   end subroutine get_dist_crt
+   
+   subroutine get_basn_area(did)
+      implicit none
+      integer :: did, ix,jx, k
+      real :: basns_area(rt_domain(did)%numbasns)
+#ifdef MPP_LAND
+      integer :: mask(global_nx, global_ny) 
+      real :: dist_lsm(global_nx, global_ny,9) 
+#else
+      integer :: mask(rt_domain(did)%ix, rt_domain(did)%jx)
+      real :: dist_lsm(rt_domain(did)%ix, rt_domain(did)%jx,9) 
+#endif
+#ifdef MPP_LAND
+      ix = global_nx
+      jx = global_ny
+      call write_IO_int(rt_domain(did)%GWSUBBASMSK,mask) 
+      do k = 1,  9
+         call write_IO_real(rt_domain(did)%dist_lsm(:,:,k),dist_lsm(:,:,k)) 
+      end do
+#else
+      ix = rt_domain(did)%ix
+      jx = rt_domain(did)%jx
+      mask = rt_domain(did)%GWSUBBASMSK
+      dist_lsm = rt_domain(did)%dist_lsm
+#endif
+
+#ifdef MPP_LAND
+      if(my_id .eq. IO_id) then
+#endif
+         call get_area_g(rt_domain(did)%basns_area,mask, rt_domain(did)%numbasns,ix,jx,dist_lsm)
+#ifdef MPP_LAND
+      end if
+      call mpp_land_bcast_real(rt_domain(did)%numbasns,rt_domain(did)%basns_area)
+#endif
+   end subroutine get_basn_area
+
+   subroutine get_area_g(basns_area,GWSUBBASMSK, numbasns,ix,jx,dist)
+      integer :: i,j, n, ix,jx, numbasns
+      integer :: count(numbasns)
+      real :: basns_area(numbasns) , dist(ix,jx,9)
+      integer :: GWSUBBASMSK(ix,jx)
+      basns_area = 0
+      count = 0
+      do  j = 1, jx
+        do  i = 1, ix
+           n = GWSUBBASMSK(i,j)
+           if(n .gt. 0) then
+              basns_area(n) = basns_area(n)+dist(i,j,9)
+              count(n) = count(n) + 1
+           endif
+        end do
+      end do
+      do i = 1, numbasns
+         if(count(i) .gt. 0) then
+             basns_area(i) = basns_area(i) / count(i) 
+         end if
+      end do
+   end subroutine get_area_g
+
+   subroutine get_basn_area_tmp(did)
+      integer :: did
+      integer :: i,j, n
+      integer :: count(rt_domain(did)%numbasns)
+      rt_domain(did)%basns_area = 0
+      count = 0
+      do  j = 1, rt_domain(did)%jx
+        do  i = 1, rt_domain(did)%ix
+           n = rt_domain(did)%GWSUBBASMSK(i,j)
+           if(n .gt. 0) then
+              rt_domain(did)%basns_area(n) = rt_domain(did)%basns_area(n)+rt_domain(did)%dist_lsm(i,j,9)
+              count(n) = count(n) + 1
+           endif
+        end do
+      end do
+      do i = 1, rt_domain(did)%numbasns
+         if(count(i) .gt. 0) then
+             rt_domain(did)%basns_area(i) = rt_domain(did)%basns_area(i) / count(i) 
+         end if
+      end do
+   end subroutine get_basn_area_tmp
+
+   subroutine get_node_area(did)
+       integer :: did
+       call get_area_g(rt_domain(did)%node_area,rt_domain(did)%CH_NETLNK, &
+         rt_domain(did)%NLINKS,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%dist)
+   end subroutine get_node_area
+    
+
+end module module_HYDRO_utils
diff --git a/wrfv2_fire/hydro/Routing/module_RT.F b/wrfv2_fire/hydro/Routing/module_RT.F
new file mode 100644
index 00000000..acac25b6
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_RT.F
@@ -0,0 +1,854 @@
+MODULE module_Routing
+#ifdef MPP_LAND
+   use module_gw_baseflow, only: pix_ct_1
+   use module_HYDRO_io, only: mpp_read_routedim, mpp_read_routing, mpp_read_chrouting, &
+                              mpp_chrouting_conf, mpp_read_simp_gw
+#else
+   !yw use module_HYDRO_io, only: read_routedim, read_routing_old, read_chrouting,read_simp_gw
+   use module_HYDRO_io, only: read_routedim, read_routing_seq, read_chrouting,read_simp_gw
+#endif
+   use module_HYDRO_io, only: readgw2d
+   use module_HYDRO_utils 
+   IMPLICIT NONE
+
+
+CONTAINS
+
+
+   subroutine rt_allocate(did,ix,jx,ixrt,jxrt,nsoil,CHANRTSWCRT)   
+      use module_RT_data, only: rt_domain
+      implicit none
+      integer ixrt,jxrt, ix,jx,nsoil,NLINKS, CHANRTSWCRT
+      integer istatus, did
+      if(rt_domain(did)%allo_status .eq. 1) return
+      rt_domain(did)%allo_status = 1
+
+      rt_domain(did)%ix = ix
+      rt_domain(did)%jx = jx
+      rt_domain(did)%ixrt = ixrt
+      rt_domain(did)%jxrt = jxrt
+!     ixrt = rt_domain(did)%ixrt
+!     jxrt = rt_domain(did)%jxrt
+      
+      NLINKS = rt_domain(did)%NLINKS
+!DJG Allocate routing and disaggregation arrays
+
+#ifdef HYDRO_D
+  write(6,*) "  rt_allocate ***** ixrt,jxrt, nsoil", ixrt,jxrt, nsoil
+#endif
+
+
+  allocate( rt_domain(did)%DSMC   	(NSOIL) )
+  rt_domain(did)%dsmc = 0 
+
+
+  allocate( rt_domain(did)%SMCRTCHK    	(NSOIL) )
+    rt_domain(did)%SMCRTCHK = 0
+
+  allocate( rt_domain(did)%SH2OAGGRT   	(NSOIL) )
+    rt_domain(did)%SH2OAGGRT = 0
+  allocate( rt_domain(did)%STCAGGRT   	(NSOIL) )
+  allocate( rt_domain(did)%SMCAGGRT   	(NSOIL) )
+    rt_domain(did)%STCAGGRT = 0
+  rt_domain(did)%SMCAGGRT = 0
+
+
+  allocate( rt_domain(did)%SMCRT   	(IXRT,JXRT,NSOIL) )
+  allocate( rt_domain(did)%ELRT   	(IXRT,JXRT) )
+  allocate( rt_domain(did)%SOXRT  	(IXRT,JXRT) )
+  allocate( rt_domain(did)%SOYRT   	(IXRT,JXRT) )
+  allocate( rt_domain(did)%SO8RT   	(IXRT,JXRT,8) )
+  allocate( rt_domain(did)%SO8RT_D   	(IXRT,JXRT,3) )
+  allocate( rt_domain(did)%OVROUGHRT   (IXRT,JXRT) )
+  allocate( rt_domain(did)%OVROUGHRTFAC   (IXRT,JXRT) )
+  allocate( rt_domain(did)%RETDEPRT    (IXRT,JXRT) )
+  allocate( rt_domain(did)%RETDEPRTFAC    (IXRT,JXRT) )
+  allocate( rt_domain(did)%SFCHEADSUBRT(IXRT,JXRT) )
+  allocate( rt_domain(did)%INFXSUBRT   (IXRT,JXRT) )
+  allocate( rt_domain(did)%INFXSWGT    (IXRT,JXRT) )
+  allocate( rt_domain(did)%LKSATRT     (IXRT,JXRT) )
+  allocate( rt_domain(did)%LKSATFAC    (IXRT,JXRT) )
+  allocate( rt_domain(did)%QSUBRT      (IXRT,JXRT) )
+  allocate( rt_domain(did)%ZWATTABLRT  (IXRT,JXRT) )
+  allocate( rt_domain(did)%QSUBBDRYRT  (IXRT,JXRT) )
+  allocate( rt_domain(did)%SOLDEPRT    (IXRT,JXRT) )
+  allocate( rt_domain(did)%q_sfcflx_x  (IXRT,JXRT) )
+  allocate( rt_domain(did)%q_sfcflx_y  (IXRT,JXRT) )
+  allocate( rt_domain(did)%SMCMAXRT   	(IXRT,JXRT,NSOIL) )
+  allocate( rt_domain(did)%SMCWLTRT   	(IXRT,JXRT,NSOIL) )
+  allocate( rt_domain(did)%SH2OWGT   	(IXRT,JXRT,NSOIL) )
+  allocate( rt_domain(did)%INFXSAGGRT 	(IXRT,JXRT) )
+  allocate( rt_domain(did)%DHRT   	(IXRT,JXRT) )
+  allocate( rt_domain(did)%QSTRMVOLRT  (IXRT,JXRT) )
+
+
+  ! allocate( rt_domain(did)%QSTRMVOLRT_TS  (IXRT,JXRT) )
+!  allocate( rt_domain(did)%QSTRMVOLRT_DUM  (IXRT,JXRT) )
+  allocate( rt_domain(did)%QBDRYRT   	(IXRT,JXRT) )
+  allocate( rt_domain(did)%CH_NETRT   	(IXRT,JXRT) )
+  allocate( rt_domain(did)%LAKE_MSKRT 	(IXRT,JXRT) )
+  allocate( rt_domain(did)%LAKE_INFLORT(IXRT,JXRT) )
+!  allocate( rt_domain(did)%LAKE_INFLORT_TS(IXRT,JXRT) )
+!  allocate( rt_domain(did)%LAKE_INFLORT_DUM(IXRT,JXRT) )
+
+  allocate( rt_domain(did)%SUB_RESID (ixrt,jxrt) )
+  allocate( rt_domain(did)%LATVAL (ixrt,jxrt) )
+  allocate( rt_domain(did)%LONVAL (ixrt,jxrt) )
+  allocate( rt_domain(did)%dist (ixrt,jxrt,9) )
+!!!! tmp
+
+    rt_domain(did)%dist = -999  
+    rt_domain(did)%SMCRT   	= 0.0                
+    rt_domain(did)%ELRT   	= 0.0                
+    rt_domain(did)%SOXRT  	= 0.0                
+    rt_domain(did)%SOYRT   	= 0.0                
+    rt_domain(did)%SO8RT   	= -999               
+    rt_domain(did)%SO8RT_D   	= 0.0                
+    rt_domain(did)%OVROUGHRT   = 0.0                
+    rt_domain(did)%SFCHEADSUBRT= 0.0                
+    rt_domain(did)%INFXSUBRT   = 0.0                
+    rt_domain(did)%INFXSWGT    = 0.0                
+    rt_domain(did)%LKSATRT     = 0.0                
+    rt_domain(did)%LKSATFAC    = 0.0                
+    rt_domain(did)%QSUBRT      = 0.0                
+    rt_domain(did)%ZWATTABLRT  = 0.0                
+    rt_domain(did)%QSUBBDRYRT  = 0.0                
+    rt_domain(did)%SOLDEPRT    = 0.0                
+    rt_domain(did)%q_sfcflx_x  = 0.0                
+    rt_domain(did)%q_sfcflx_y  = 0.0                
+    rt_domain(did)%SMCMAXRT   	= 0.0                
+    rt_domain(did)%SMCWLTRT   	= 0.0                
+    rt_domain(did)%SH2OWGT           = 0.0
+    rt_domain(did)%INFXSAGGRT 	= 0.0                
+    rt_domain(did)%DHRT   	= 0.0                
+    rt_domain(did)%QSTRMVOLRT  = 0.0
+!    rt_domain(did)%QSTRMVOLRT_DUM  = 0.0                
+    rt_domain(did)%QBDRYRT   	= 0.0                
+    rt_domain(did)%CH_NETRT   	= 0.0                
+    rt_domain(did)%LAKE_MSKRT 	= -9999              
+    rt_domain(did)%LAKE_INFLORT= 0.0                
+!    rt_domain(did)%LAKE_INFLORT_DUM= 0.0                
+
+    rt_domain(did)%SUB_RESID = 0.0                
+    rt_domain(did)%LATVAL = 0.0                
+    rt_domain(did)%LONVAL = 0.0
+
+
+    rt_domain(did)%timestep_flag = 1    ! default is cold start
+
+   IF (CHANRTSWCRT.EQ.1 .or. CHANRTSWCRT .eq. 2) THEN  !IF/then for channel routing
+  allocate( rt_domain(did)%CH_NETLNK (IXRT,JXRT) )
+            rt_domain(did)%CH_NETLNK = 0.0           
+
+!DJG,DNY Allocate channel routing and lake routing arrays
+
+#ifdef MPP_LAND
+     allocate( rt_domain(did)%LAKE_INDEX(NLINKS) )
+     allocate( rt_domain(did)%nlinks_INDEX(NLINKS) )
+     allocate( rt_domain(did)%Link_location(ixrt,jxrt))
+#endif
+     
+
+     allocate( rt_domain(did)%LINK(NLINKS) )
+     allocate( rt_domain(did)%TO_NODE(NLINKS) )
+     allocate( rt_domain(did)%FROM_NODE(NLINKS) )
+     allocate( rt_domain(did)%TYPEL(NLINKS) )
+     allocate( rt_domain(did)%ORDER(NLINKS) )
+     allocate( rt_domain(did)%STRMFRXSTPTS(NLINKS) )
+     allocate( rt_domain(did)%MUSK(NLINKS) )
+     allocate( rt_domain(did)%MUSX(NLINKS) )
+     allocate( rt_domain(did)%CHANXI(NLINKS) )
+     allocate( rt_domain(did)%CHANYJ(NLINKS) )
+     allocate( rt_domain(did)%CHLAT(NLINKS) )   !-latitutde of channel grid point
+     allocate( rt_domain(did)%CHLON(NLINKS) )   !-longitude of channel grid point
+     allocate( rt_domain(did)%CHANLEN(NLINKS) )
+     allocate( rt_domain(did)%So(NLINKS) )
+     allocate( rt_domain(did)%ChSSlp(NLINKS) )
+     allocate( rt_domain(did)%Bw(NLINKS) )
+     allocate( rt_domain(did)%ZELEV(NLINKS) )
+     allocate( rt_domain(did)%CVOL(NLINKS) )
+     allocate( rt_domain(did)%HRZAREA(NLINKS) )
+     allocate( rt_domain(did)%LAKEMAXH(NLINKS) )
+     allocate( rt_domain(did)%WEIRC(NLINKS) )
+     allocate( rt_domain(did)%WEIRL(NLINKS) )
+     allocate( rt_domain(did)%ORIFICEC(NLINKS) )
+     allocate( rt_domain(did)%ORIFICEA(NLINKS) )
+     allocate( rt_domain(did)%ORIFICEE(NLINKS) )
+     allocate( rt_domain(did)%LATLAKE(NLINKS) )
+     allocate( rt_domain(did)%LONLAKE(NLINKS) )
+     allocate( rt_domain(did)%ELEVLAKE(NLINKS) )
+     allocate( rt_domain(did)%LAKENODE(NLINKS) )
+     allocate( rt_domain(did)%RESHT(NLINKS),STAT=istatus )
+     allocate( rt_domain(did)%QLAKEI(NLINKS),STAT=istatus )
+     allocate( rt_domain(did)%QLAKEO(NLINKS),STAT=istatus )
+     allocate( rt_domain(did)%QLINK(NLINKS,2) )
+
+     allocate( rt_domain(did)%HLINK(NLINKS) )  !--used for diffusion only
+     allocate( rt_domain(did)%MannN(NLINKS))
+
+     allocate( rt_domain(did)%node_area(NLINKS) )
+
+!!!! tmp
+      rt_domain(did)%LINK = 0.0        
+      rt_domain(did)%TO_NODE = 0.0        
+      rt_domain(did)%FROM_NODE = 0        
+      rt_domain(did)%TYPEL = 0.0        
+      rt_domain(did)%ORDER = 0.0        
+      rt_domain(did)%STRMFRXSTPTS = 0.0        
+      rt_domain(did)%MUSK = 0.0        
+      rt_domain(did)%MUSX = 0.0        
+      rt_domain(did)%CHANXI = 0.0        
+      rt_domain(did)%CHANYJ = 0.0        
+      rt_domain(did)%CHLAT = 0.0         !-latitutde of channel grid point
+      rt_domain(did)%CHLON = 0.0         !-longitude of channel grid point
+      rt_domain(did)%CHANLEN = 0.0        
+      rt_domain(did)%ChSSlp = 0.0        
+      rt_domain(did)%Bw = 0.0        
+      rt_domain(did)%ZELEV = 0.0        
+      rt_domain(did)%CVOL = 0.0        
+      rt_domain(did)%HRZAREA = 0.0        
+      rt_domain(did)%LAKEMAXH = 0.0        
+      rt_domain(did)%WEIRC = 0.0        
+      rt_domain(did)%WEIRL = 0.0        
+      rt_domain(did)%ORIFICEC = 0.0        
+      rt_domain(did)%ORIFICEA = 0.0        
+      rt_domain(did)%ORIFICEE = 0.0        
+      rt_domain(did)%LATLAKE = 0.0        
+      rt_domain(did)%LONLAKE = 0.0        
+      rt_domain(did)%ELEVLAKE = 0.0        
+      rt_domain(did)%LAKENODE = 0.0        
+      rt_domain(did)%RESHT = 0.0                    
+      rt_domain(did)%QLAKEI = 0.0                     
+      rt_domain(did)%QLAKEO = 0.0                     
+      rt_domain(did)%QLINK = 0        
+
+      rt_domain(did)%HLINK = 0.0        !--used for diffusion only
+      rt_domain(did)%MannN = 0.0        
+
+     rt_domain(did)%So = 0.01
+  END IF   !IF/then for channel routing
+
+
+  !DJG Allocate routing and disaggregation arrays
+  allocate(rt_domain(did)%qinflowbase  (IXRT,JXRT) )
+  allocate(rt_domain(did)%gw_strm_msk  (IXRT,JXRT) )
+
+!!! allocate land surface grid variables
+ allocate( rt_domain(did)%SMC  (IX,JX,NSOIL) )
+! allocate( rt_domain(did)%dist_lsm (ixrt,jxrt,9) )
+! allocate( rt_domain(did)%lat_lsm (ixrt,jxrt) )
+! allocate( rt_domain(did)%lon_lsm (ixrt,jxrt) )
+ allocate( rt_domain(did)%dist_lsm (ix,jx,9) )
+ allocate( rt_domain(did)%lat_lsm (ix,jx) )
+ allocate( rt_domain(did)%lon_lsm (ix,jx) )
+
+! allocate( rt_domain(did)%SICE  (IX,JX,NSOIL) )
+ allocate( rt_domain(did)%SMCMAX1  (IX,JX) )
+  allocate( rt_domain(did)%STC  (IX,JX,NSOIL) )
+  allocate( rt_domain(did)%SH2OX(IX,JX,NSOIL) )
+  allocate( rt_domain(did)%SMCWLT1  (IX,JX) )
+  allocate( rt_domain(did)%SMCREF1  (IX,JX) )
+  allocate( rt_domain(did)%VEGTYP   (IX,JX) )
+  allocate( rt_domain(did)%GWSUBBASMSK   (IX,JX) )
+  allocate( rt_domain(did)%SLDPTH(NSOIL) )
+  allocate( rt_domain(did)%SO8LD_D   (IX,JX,3) )
+  allocate( rt_domain(did)%SO8LD_Vmax   (IX,JX) )
+  allocate( rt_domain(did)%SFCHEADRT   (IX,JX) )
+  allocate( rt_domain(did)%INFXSRT   (IX,JX) )
+  allocate( rt_domain(did)%TERRAIN   (IX,JX) )
+  allocate( rt_domain(did)%LKSAT   (IX,JX) )
+  allocate( rt_domain(did)%SOLDRAIN   (IX,JX) )
+
+
+  rt_domain(did)%dist_lsm = 0.0 
+
+  rt_domain(did)%qinflowbase = 0.0           
+  rt_domain(did)%gw_strm_msk   = 0         
+  rt_domain(did)%SMC   = 0.25           
+! rt_domain(did)%SMCMAX1   = 0.434          
+  rt_domain(did)%SMCMAX1   = 0.0
+   rt_domain(did)%STC   = 282.0          
+   rt_domain(did)%SH2OX = rt_domain(did)%SMC   
+   rt_domain(did)%SMCWLT1   = 0.0            
+   rt_domain(did)%SMCREF1   = 0.0            
+   rt_domain(did)%VEGTYP    = 0            
+   rt_domain(did)%GWSUBBASMSK    = 0              
+   rt_domain(did)%SLDPTH = 0.0           
+   rt_domain(did)%SO8LD_D    = 0.0           
+   rt_domain(did)%SO8LD_Vmax    = 0.0            
+   rt_domain(did)%SFCHEADRT    = 0.0            
+   rt_domain(did)%INFXSRT    = 0.0            
+   rt_domain(did)%TERRAIN    = 0.0            
+   rt_domain(did)%LKSAT    = 0.0            
+   rt_domain(did)%SOLDRAIN    = 0.0            
+
+   rt_domain(did)%out_counts = 0
+   rt_domain(did)%his_out_counts = 0
+   rt_domain(did)%rst_counts = 1
+
+#ifdef HYDRO_D
+  write(6,*) "***** finish rt_allocate "
+#endif
+
+   end subroutine rt_allocate
+
+   subroutine getChanDim(did)
+
+  
+      use module_namelist, only:  nlst_rt 
+      use module_RT_data, only: rt_domain
+      implicit none
+      
+      integer ixrt,jxrt, ix,jx, did
+      INTEGER, allocatable,dimension(:,:) :: CH_NETLNK
+
+      real :: Vmax
+     
+      ix = rt_domain(did)%ix 
+      jx = rt_domain(did)%jx 
+      ixrt = rt_domain(did)%ixrt 
+      jxrt = rt_domain(did)%jxrt 
+
+   
+      allocate(CH_NETLNK(ixrt,jxrt)) 
+
+      IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) THEN  !IF/then for channel routing
+#ifdef MPP_LAND
+        CALL MPP_READ_ROUTEDIM( rt_domain(did)%g_IXRT,rt_domain(did)%g_JXRT, &
+#else
+        CALL READ_ROUTEDIM( &
+#endif
+              IXRT, JXRT, nlst_rt(did)%route_chan_f, nlst_rt(did)%route_link_f, &
+              nlst_rt(did)%route_direction_f, nlst_rt(did)%route_lake_f, rt_domain(did)%NLINKS, rt_domain(did)%NLAKES, &
+              CH_NETLNK, nlst_rt(did)%channel_option, nlst_rt(did)%geo_finegrid_flnm)
+
+#ifdef HYDRO_D
+        write(6,*) "before rt_allocate after READ_ROUTEDIM"
+#endif
+
+
+      end if
+
+        call rt_allocate(did,rt_domain(did)%ix,rt_domain(did)%jx,&
+                   rt_domain(did)%ixrt,rt_domain(did)%jxrt, nlst_rt(did)%nsoil,nlst_rt(did)%CHANRTSWCRT)
+
+      IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) THEN  !IF/then for channel routing
+        rt_domain(did)%CH_NETLNK = CH_NETLNK
+      endif
+
+      deallocate(CH_NETLNK)
+
+   end subroutine getChanDim
+   
+   subroutine LandRT_ini(did)
+
+      use module_noah_chan_param_init_rt
+      use module_namelist, only:  nlst_rt
+      use module_RT_data, only: rt_domain
+      use module_gw_baseflow_data, only: gw2d
+
+#ifdef MPP_LAND
+      USE module_mpp_land
+#endif
+      implicit none 
+      integer did
+      real Vmax
+
+     integer :: bas , bas_id
+     CHARACTER(len=19)                      :: header
+     CHARACTER(len=1)                       :: jnk
+
+     REAL,  DIMENSION(50)     :: BOTWID,HLINK_INIT,CHAN_SS,CHMann !Channel parms from table
+     integer :: i,j
+     
+     
+!------------------------------------------------------------------------
+!DJG Routing Processing
+!------------------------------------------------------------------------
+!DJG IF/then to get routing terrain fields if either routing module is 
+!DJG   activated
+
+
+  IF (nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) THEN
+#ifdef HYDRO_D
+  print *, "Terrain routing initialization..."
+#endif
+
+#ifdef MPP_LAND
+    CALL MPP_READ_ROUTING( &
+#else
+     CALL READ_ROUTING_seq  (  &
+#endif
+          rt_domain(did)%IXRT,rt_domain(did)%JXRT,rt_domain(did)%ELRT,rt_domain(did)%CH_NETRT, &
+          rt_domain(did)%LKSATFAC,trim(nlst_rt(did)%route_topo_f),&
+          nlst_rt(did)%route_chan_f,nlst_rt(did)%geo_finegrid_flnm  ,  &
+#ifdef MPP_LAND
+           rt_domain(did)%g_IXRT,rt_domain(did)%g_JXRT, &
+#endif
+          rt_domain(did)%OVROUGHRTFAC,rt_domain(did)%RETDEPRTFAC)
+
+    !yw CALL READ_ROUTING_old(rt_domain(did)%IXRT,rt_domain(did)%JXRT,rt_domain(did)%ELRT,rt_domain(did)%CH_NETRT, &
+
+
+
+    IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) THEN  !IF/then for channel routing
+#ifdef MPP_LAND
+          CALL MPP_READ_CHROUTING(    &
+#else
+          CALL READ_CHROUTING(    &
+#endif
+               rt_domain(did)%IXRT,rt_domain(did)%JXRT,rt_domain(did)%ELRT,rt_domain(did)%CH_NETRT, & 
+               rt_domain(did)%LAKE_MSKRT, &
+               rt_domain(did)%FROM_NODE, rt_domain(did)%TO_NODE, rt_domain(did)%TYPEL, rt_domain(did)%ORDER, &
+               rt_domain(did)%MAXORDER,rt_domain(did)%NLINKS, &
+               rt_domain(did)%NLAKES, rt_domain(did)%MUSK, rt_domain(did)%MUSX, rt_domain(did)%QLINK,&
+               rt_domain(did)%CHANLEN, rt_domain(did)%MannN, rt_domain(did)%So, rt_domain(did)%ChSSlp, rt_domain(did)%Bw, &
+               rt_domain(did)%HRZAREA, rt_domain(did)%LAKEMAXH, rt_domain(did)%WEIRC, rt_domain(did)%WEIRL, rt_domain(did)%ORIFICEC, &
+               rt_domain(did)%ORIFICEA,  rt_domain(did)%ORIFICEE, rt_domain(did)%LATLAKE, rt_domain(did)%LONLAKE, rt_domain(did)%ELEVLAKE, &
+               nlst_rt(did)%route_link_f,nlst_rt(did)%route_lake_f, &
+               nlst_rt(did)%route_direction_f, nlst_rt(did)%route_order_f, &
+               nlst_rt(did)%CHANRTSWCRT,rt_domain(did)%dist, rt_domain(did)%ZELEV, rt_domain(did)%LAKENODE, rt_domain(did)%CH_NETLNK, &
+               rt_domain(did)%CHANXI, rt_domain(did)%CHANYJ, &
+               rt_domain(did)%CHLAT, rt_domain(did)%CHLON, nlst_rt(did)%channel_option,&
+               rt_domain(did)%latval, rt_domain(did)%lonval,&
+               rt_domain(did)%STRMFRXSTPTS,nlst_rt(did)%geo_finegrid_flnm        &
+#ifdef MPP_LAND
+               ,rt_domain(did)%g_IXRT,rt_domain(did)%g_JXRT   &
+#endif
+               )
+
+#ifdef MPP_LAND
+          call MPP_CHROUTING_CONF(rt_domain(did)%g_ixrt,rt_domain(did)%g_jxrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt, rt_domain(did)%NLAKES,rt_domain(did)%NLINKS,&
+               rt_domain(did)%lake_mskrt, rt_domain(did)%lake_index,rt_domain(did)%link_location,rt_domain(did)%HRZAREA,rt_domain(did)%LAKEMAXH,&
+               rt_domain(did)%WEIRC,rt_domain(did)%WEIRL,&
+               rt_domain(did)%ORIFICEC,rt_domain(did)%ORIFICEA,rt_domain(did)%ORIFICEE,rt_domain(did)%LATLAKE,rt_domain(did)%LONLAKE,rt_domain(did)%ELEVLAKE, &
+               rt_domain(did)%FROM_NODE,rt_domain(did)%TO_NODE,rt_domain(did)%ZELEV,rt_domain(did)%CHLAT,rt_domain(did)%CHLON,rt_domain(did)%TYPEL, &
+               rt_domain(did)%ORDER,rt_domain(did)%CHANLEN, &
+               rt_domain(did)%CHANXI,rt_domain(did)%CHANYJ, rt_domain(did)%lakenode,rt_domain(did)%mpp_nlinks, rt_domain(did)%nlinks_index, rt_domain(did)%maxorder, &
+               rt_domain(did)%yw_mpp_nlinks)
+!!!!!   lake_index,Link_Location)
+#endif
+    endif
+  END IF
+   
+
+!DJG Temporary hardwire of RETDEPRT,RETDEP_CHAN
+!DJG    will later make this a function of SOLTYP and VEGTYP
+!            OVROUGHRT(i,j) = 0.01
+
+              rt_domain(did)%RETDEPRT = 0.001   ! units (mm)
+              rt_domain(did)%RETDEP_CHAN = 0.001
+
+
+!DJG Need to insert call for acquiring routing fields here...
+!DJG     include as a subroutine in module module_Noahlsm_wrfcode_input.F
+!DJG  Calculate terrain slopes 'SOXRT,SOYRT' from subgrid elevation 'ELRT'
+
+
+        rt_domain(did)%so8rt = -999
+        Vmax = 0.0
+        do j=2,rt_domain(did)%JXRT-1
+          do i=2,rt_domain(did)%IXRT-1
+              rt_domain(did)%SOXRT(i,j)=(rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j))/rt_domain(did)%dist(i,j,3)
+              rt_domain(did)%SOYRT(i,j)=(rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i,j+1))/rt_domain(did)%dist(i,j,1)
+!DJG Introduce reduction in retention depth as a linear function of terrain slope
+              IF (nlst_rt(did)%RT_OPTION.eq.2) then
+                IF (rt_domain(did)%SOXRT(i,j).gt.rt_domain(did)%SOYRT(i,j)) then
+                  Vmax=rt_domain(did)%SOXRT(i,j)
+                ELSE
+                  Vmax=rt_domain(did)%SOYRT(i,j)
+                END IF
+
+                IF (Vmax.gt.0.1) then
+                  rt_domain(did)%RETDEPRT(i,j)=0.
+                ELSE
+                  rt_domain(did)%RETDEPFRAC=Vmax/0.1
+                  rt_domain(did)%RETDEPRT(i,j)=rt_domain(did)%RETDEPRT(i,j)*(1.-rt_domain(did)%RETDEPFRAC)
+                  IF (rt_domain(did)%RETDEPRT(i,j).lt.0.) rt_domain(did)%RETDEPRT(i,j)=0.
+                END IF
+              END IF
+
+               rt_domain(did)%SO8RT(i,j,1) = (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i,j+1))/rt_domain(did)%dist(i,j,1)
+               rt_domain(did)%SO8RT_D(i,j,1) = i
+               rt_domain(did)%SO8RT_D(i,j,2) = j + 1 
+               rt_domain(did)%SO8RT_D(i,j,3) = 1 
+               Vmax = rt_domain(did)%SO8RT(i,j,1)
+               
+               rt_domain(did)%SO8RT(i,j,2) = (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j+1))/rt_domain(did)%dist(i,j,2)  
+               if(rt_domain(did)%SO8RT(i,j,2) .gt. Vmax ) then
+                 rt_domain(did)%SO8RT_D(i,j,1) = i + 1
+                 rt_domain(did)%SO8RT_D(i,j,2) = j + 1 
+                 rt_domain(did)%SO8RT_D(i,j,3) = 2
+                 Vmax = rt_domain(did)%SO8RT(i,j,2)
+               end if
+
+               rt_domain(did)%SO8RT(i,j,3) = (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j))/rt_domain(did)%dist(i,j,3)
+               if(rt_domain(did)%SO8RT(i,j,3) .gt. Vmax ) then
+                 rt_domain(did)%SO8RT_D(i,j,1) = i + 1
+                 rt_domain(did)%SO8RT_D(i,j,2) = j  
+                 rt_domain(did)%SO8RT_D(i,j,3) = 3
+                 Vmax = rt_domain(did)%SO8RT(i,j,3)
+               end if
+
+               rt_domain(did)%SO8RT(i,j,4) = (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j-1))/rt_domain(did)%dist(i,j,4)  
+               if(rt_domain(did)%SO8RT(i,j,4) .gt. Vmax ) then
+                 rt_domain(did)%SO8RT_D(i,j,1) = i + 1
+                 rt_domain(did)%SO8RT_D(i,j,2) = j - 1 
+                 rt_domain(did)%SO8RT_D(i,j,3) = 4
+                 Vmax = rt_domain(did)%SO8RT(i,j,4)
+               end if
+
+               rt_domain(did)%SO8RT(i,j,5) = (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i,j-1))/rt_domain(did)%dist(i,j,5)
+               if(rt_domain(did)%SO8RT(i,j,5) .gt. Vmax ) then
+                 rt_domain(did)%SO8RT_D(i,j,1) = i 
+                 rt_domain(did)%SO8RT_D(i,j,2) = j - 1 
+                 rt_domain(did)%SO8RT_D(i,j,3) = 5
+                 Vmax = rt_domain(did)%SO8RT(i,j,5)
+               end if
+
+               rt_domain(did)%SO8RT(i,j,6) = (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i-1,j-1))/rt_domain(did)%dist(i,j,6)  
+               if(rt_domain(did)%SO8RT(i,j,6) .gt. Vmax ) then
+                 rt_domain(did)%SO8RT_D(i,j,1) = i - 1 
+                 rt_domain(did)%SO8RT_D(i,j,2) = j - 1 
+                 rt_domain(did)%SO8RT_D(i,j,3) = 6
+                 Vmax = rt_domain(did)%SO8RT(i,j,6)
+               end if
+
+               rt_domain(did)%SO8RT(i,j,7) = (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i-1,j))/rt_domain(did)%dist(i,j,7)
+               if(rt_domain(did)%SO8RT(i,j,7) .gt. Vmax ) then
+                 rt_domain(did)%SO8RT_D(i,j,1) = i - 1 
+                 rt_domain(did)%SO8RT_D(i,j,2) = j  
+                 rt_domain(did)%SO8RT_D(i,j,3) = 7
+                 Vmax = rt_domain(did)%SO8RT(i,j,7)
+               end if
+
+               rt_domain(did)%SO8RT(i,j,8) = (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i-1,j+1))/rt_domain(did)%dist(i,j,8)  
+               if(rt_domain(did)%SO8RT(i,j,8) .gt. Vmax ) then
+                 rt_domain(did)%SO8RT_D(i,j,1) = i - 1 
+                 rt_domain(did)%SO8RT_D(i,j,2) = j + 1 
+                 rt_domain(did)%SO8RT_D(i,j,3) = 8
+                 Vmax = rt_domain(did)%SO8RT(i,j,8)
+               end if
+
+!DJG Introduce reduction in retention depth as a linear function of terrain slope
+              IF (nlst_rt(did)%RT_OPTION.eq.1) then
+                IF (Vmax.gt.0.75) then
+                  rt_domain(did)%RETDEPRT(i,j)=0.
+                ELSE
+                  rt_domain(did)%RETDEPFRAC=Vmax/0.75
+                  rt_domain(did)%RETDEPRT(i,j)=rt_domain(did)%RETDEPRT(i,j)*(1.-rt_domain(did)%RETDEPFRAC)
+                  IF (rt_domain(did)%RETDEPRT(i,j).lt.0.) rt_domain(did)%RETDEPRT(i,j)=0.
+                END IF
+              END IF
+
+
+          end do
+        end do
+
+
+!Apply calibration scaling factors to sfc roughness and retention depth here...
+                rt_domain(did)%RETDEPRT = rt_domain(did)%RETDEPRT * rt_domain(did)%RETDEPRTFAC
+		rt_domain(did)%OVROUGHRT = rt_domain(did)%OVROUGHRT * rt_domain(did)%OVROUGHRTFAC
+
+
+
+! calculate the slope for boundary        
+#ifdef MPP_LAND
+       if(right_id .lt. 0) rt_domain(did)%SOXRT(rt_domain(did)%IXRT,:)=rt_domain(did)%SOXRT(rt_domain(did)%IXRT-1,:)
+       if(left_id  .lt. 0) rt_domain(did)%SOXRT(1,:)=rt_domain(did)%SOXRT(2,:)
+       if(up_id    .lt. 0) rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT)=rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT-1)
+       if(down_id  .lt. 0) rt_domain(did)%SOYRT(:,1)=rt_domain(did)%SOYRT(:,2)
+#else
+              rt_domain(did)%SOXRT(rt_domain(did)%IXRT,:)=rt_domain(did)%SOXRT(rt_domain(did)%IXRT-1,:)
+              rt_domain(did)%SOXRT(1,:)=rt_domain(did)%SOXRT(2,:)
+              rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT)=rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT-1)
+              rt_domain(did)%SOYRT(:,1)=rt_domain(did)%SOYRT(:,2)
+#endif
+
+#ifdef MPP_LAND
+! communicate the value to 
+       call MPP_LAND_COM_REAL(rt_domain(did)%RETDEPRT,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+       call MPP_LAND_COM_REAL(rt_domain(did)%SOXRT,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+       call MPP_LAND_COM_REAL(rt_domain(did)%SOYRT,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+       do i = 1, 8
+          call MPP_LAND_COM_REAL(rt_domain(did)%SO8RT(:,:,i),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+       end do
+       do i = 1, 3
+          call MPP_LAND_COM_INTEGER(rt_domain(did)%SO8RT_D(:,:,i),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+       end do
+#endif
+
+
+!---------------------------------------------------------------------
+!DJG  If GW/Baseflow activated...Read in req'd fields...
+!----------------------------------------------------------------------
+  IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN
+      If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) THEN
+#ifdef HYDRO_D
+           print *, "new Simple GW-Bucket Scheme selected, retrieving files..."
+#endif
+#ifdef MPP_LAND
+           CALL MPP_READ_SIMP_GW(              &
+#else
+           CALL READ_SIMP_GW(                  &
+#endif
+              rt_domain(did)%IX,rt_domain(did)%JX,rt_domain(did)%IXRT,&
+              rt_domain(did)%JXRT,rt_domain(did)%GWSUBBASMSK,nlst_rt(did)%gwbasmskfil,&
+              rt_domain(did)%gw_strm_msk,rt_domain(did)%numbasns,rt_domain(did)%ch_netrt,nlst_rt(did)%AGGFACTRT)
+            allocate (rt_domain(did)%qout_gwsubbas (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%qin_gwsubbas (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%z_gwsubbas (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%gwbas_pix_ct (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%ct2_bas (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%bas_pcp (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%gw_buck_coeff (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%gw_buck_exp(rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%z_max (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%basns_area (rt_domain(did)%numbasns))
+
+#ifdef HYDRO_D
+            write(6,*)  "end Simple GW-Bucket ..."
+            print *, "Simple GW-Bucket Scheme selected, retrieving files..."
+#endif
+
+!Temporary hardwire...
+      rt_domain(did)%z_gwsubbas = 1.     ! This gets updated with spun-up GW level in GWBUCKPARM.TBL
+
+#ifdef MPP_LAND
+   if(my_id .eq. IO_id) then
+#endif
+!Read in GW bucket params and Zinit from input file in Run directory...
+     OPEN(81, FILE='GWBUCKPARM.TBL',FORM='FORMATTED',STATUS='OLD')
+     read(81,811) header
+811   FORMAT(A19)
+
+
+     do bas = 1,rt_domain(did)%numbasns
+       read(81,812) bas_id,jnk,rt_domain(did)%gw_buck_coeff(bas),jnk,rt_domain(did)%gw_buck_exp(bas),jnk,rt_domain(did)%z_max(bas),&
+             jnk,rt_domain(did)%z_gwsubbas(bas)
+812   FORMAT(I3,A1,F6.4,A1,F6.3,A1,F6.3,A1,F7.4)
+     end do
+     close(81)
+#ifdef MPP_LAND
+   endif
+   call mpp_land_bcast_real(rt_domain(did)%numbasns,rt_domain(did)%gw_buck_coeff)
+   call mpp_land_bcast_real(rt_domain(did)%numbasns,rt_domain(did)%gw_buck_exp  )
+   call mpp_land_bcast_real(rt_domain(did)%numbasns,rt_domain(did)%z_max   )
+   call mpp_land_bcast_real(rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas   )
+#endif
+
+!!! Determine number of stream pixels per GW basin for distribution...
+
+#ifdef MPP_LAND
+         call pix_ct_1(rt_domain(did)%gw_strm_msk,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%gwbas_pix_ct,rt_domain(did)%numbasns)
+#else
+         rt_domain(did)%gwbas_pix_ct = 0.
+         do bas = 1, rt_domain(did)%numbasns
+         do i=1,rt_domain(did)%ixrt
+           do j=1,rt_domain(did)%jxrt
+             if (rt_domain(did)%gw_strm_msk(i,j).eq.bas) then
+                 rt_domain(did)%gwbas_pix_ct(rt_domain(did)%gw_strm_msk(i,j)) = & 
+                 rt_domain(did)%gwbas_pix_ct(rt_domain(did)%gw_strm_msk(i,j))  + 1.0
+             endif
+           end do
+         end do
+         end do
+#endif
+
+#ifdef HYDRO_D
+    print *, "Starting GW basin levels...",rt_domain(did)%z_gwsubbas
+#endif
+           
+
+  ! BF gw2d model
+      elseif (nlst_rt(did)%GWBASESWCRT.GE.3) THEN
+
+        call readGW2d(gw2d(did)%ix, gw2d(did)%jx,     &
+                      gw2d(did)%hycond, gw2d(did)%ho, &
+		      gw2d(did)%bot, gw2d(did)%poros, &
+		      gw2d(did)%ltype)
+
+        gw2d(did)%elev = rt_domain(did)%elrt
+
+    End if
+    
+  END IF
+!---------------------------------------------------------------------
+!DJG  End if GW/Baseflow activated...
+!----------------------------------------------------------------------
+
+
+
+!---------------------------------------------------------------------
+!DJG,DNY  If channel routing activated...
+!----------------------------------------------------------------------
+
+  IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) THEN
+
+!---------------------------------------------------------------------
+!DJG,DNY  Initalize lake and channel heights, this may be overwritten by RESTART
+!--------------------------------------------------------------------
+
+       if (nlst_rt(did)%channel_option .eq. 3) then
+#ifdef MPP_LAND
+        CALL mpp_CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann)  !Read chan parms from table...
+#else
+        CALL CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann)  !Read chan parms from table...
+#endif
+       end if
+
+        do j=1,rt_domain(did)%NLINKS
+           if (nlst_rt(did)%channel_option .ne. 3) then
+            if (rt_domain(did)%TYPEL(j) .eq. 1) then !- for sparse network method this is a lake  (type 0 is river)
+              rt_domain(did)%RESHT(j) = rt_domain(did)%LAKEMAXH(j) * 0.935  !-- assumes lake is ~90%
+            endif
+           else !-- parameterize according to order of diffusion scheme, or if read from hi res file, use its value
+                !--  put condition within the if/then structure, which will assign a value if something is missing in hi res
+
+             if (rt_domain(did)%ORDER(j) .eq. 1) then    !-- smallest stream reach
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .eq. 2) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .eq. 3) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .eq. 4) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .eq. 5) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .eq. 6) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .ge. 7) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             else   !-- the outlets won't have orders since there's no nodes, so
+                    !-- assign the order 5 values
+
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(5)
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(5)
+               endif
+              if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+               rt_domain(did)%MannN(j) = CHMann(5)
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(5)
+             endif
+                
+            rt_domain(did)%CVOL(j) = (rt_domain(did)%Bw(j)+ 1/rt_domain(did)%ChSSLP(j)*rt_domain(did)%HLINK(j))*rt_domain(did)%HLINK(j)*rt_domain(did)%CHANLEN(j) !-- initalize channel volume
+           endif  !Endif channel option eq 3
+        end do
+
+        if (nlst_rt(did)%channel_option .eq. 3) then
+           do j=1,rt_domain(did)%NLAKES
+             rt_domain(did)%RESHT(j) = rt_domain(did)%LAKEMAXH(j) * 0.99   !-- lake is 99% full at start
+           end do
+        endif
+
+!--------------------------------------------------------------------
+  END IF     ! Endif for channel routing setup
+!-----------------------------------------------------------------------
+
+       rt_domain(did)%INFXSWGT = 1./FLOAT(nlst_rt(did)%AGGFACTRT*nlst_rt(did)%AGGFACTRT)
+       rt_domain(did)%SH2OWGT = 1.
+  rt_domain(did)%SOLDEPRT = -1.0 * nlst_rt(did)%ZSOIL8(nlst_rt(did)%NSOIL)
+  rt_domain(did)%QSUBRT = 0.0
+  rt_domain(did)%ZWATTABLRT = 0.0
+  rt_domain(did)%QSUBBDRYRT = 0.0
+  rt_domain(did)%QSTRMVOLRT = 0.0
+  rt_domain(did)%QSTRMVOLRT = 0.0
+  rt_domain(did)%QBDRYRT = 0.0
+  rt_domain(did)%SFCHEADSUBRT = 0.0
+  rt_domain(did)%INFXSUBRT = 0.0
+  rt_domain(did)%DHRT = 0.0
+  rt_domain(did)%LAKE_INFLORT = 0.0
+!  rt_domain(did)%LAKE_INFLORT_DUM = 0.0
+  rt_domain(did)%LAKE_CT = 0
+  rt_domain(did)%STRM_CT = 0
+!  rt_domain(did)%QSTRMVOLRT_DUM = 0.0
+  rt_domain(did)%SOLDRAIN = 0.0
+  rt_domain(did)%qinflowbase = 0.0
+
+!  rt_domain(did)%BASIN_MSK = 1
+! !DJG Initialize mass balance check variables...
+  rt_domain(did)%SMC_INIT=0.
+  rt_domain(did)%DSMC=0.
+  rt_domain(did)%DACRAIN=0.
+  rt_domain(did)%DSFCEVP=0.
+  rt_domain(did)%DCANEVP=0.
+  rt_domain(did)%DEDIR=0.
+  rt_domain(did)%DETT=0.
+  rt_domain(did)%DEPND=0.
+  rt_domain(did)%DESNO=0.
+  rt_domain(did)%DSFCRNFF=0.
+  rt_domain(did)%DQBDRY=0.
+  rt_domain(did)%SUMINFXS1=0.
+ 
+
+
+   end subroutine LandRT_ini
+
+
+END MODULE module_Routing
diff --git a/wrfv2_fire/hydro/Routing/module_channel_routing.F b/wrfv2_fire/hydro/Routing/module_channel_routing.F
new file mode 100644
index 00000000..e09f217c
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_channel_routing.F
@@ -0,0 +1,1210 @@
+MODULE module_channel_routing
+#ifdef MPP_LAND
+  USE module_mpp_land
+#endif
+  IMPLICIT NONE
+
+  contains
+
+! ------------------------------------------------
+!   FUNCTION MUSKING
+! ------------------------------------------------
+	REAL FUNCTION MUSKING(qup,quc,qdp,dt,Km,X)
+
+	IMPLICIT NONE
+
+!--local variables
+        REAL    :: C1, C2, C3
+        REAL    :: Km          !K travel time in hrs in reach
+        REAL    :: X          !weighting factors 0<=X<=0.5 
+        REAL    :: dt         !routing period in hrs
+        REAL    :: avgbf      !average base flow for initial condition
+        REAL    :: qup        !inflow from previous timestep
+        REAL    :: quc        !inflow  of current timestep
+        REAL    :: qdp        !outflow of previous timestep
+        REAL    :: dth        !timestep in hours
+
+        dth = dt/3600    !hours in timestep
+        C1 = (dth - 2*Km*X)/(2*Km*(1-X)+dth)
+        C2 = (dth+2*Km*X)/(2*Km*(1-X)+dth)
+        C3 = (2*Km*(1-X)-dth)/(2*Km*(1-X)+dth)
+        MUSKING = (C1*qup)+(C2*quc)+(C3*qdp)
+
+! ----------------------------------------------------------------
+  END FUNCTION MUSKING
+! ----------------------------------------------------------------
+
+! ------------------------------------------------
+!   SUBROUTINE LEVELPOOL
+! ------------------------------------------------
+
+SUBROUTINE LEVELPOOL(ln,qi0,qi1,qo1,ql,dt,H,ar,we,wc,wl,oe,oc,oa)
+
+    !! ----------------------------  argument variables
+    !! All elevations should be relative to a common base (often belev(k))
+
+    real, intent(INOUT) :: H       ! water elevation height (m)
+    real, intent(IN)    :: dt      ! routing period [s]
+    real, intent(IN)    :: qi0     ! inflow at previous timestep (cms)
+    real, intent(IN)    :: qi1     ! inflow at current timestep (cms)
+    real, intent(OUT)   :: qo1     ! outflow at current timestep
+    real, intent(IN)    :: ql      ! lateral inflow
+    real, intent(IN)    :: ar      ! area of reservoir (km^2)
+    real, intent(IN)    :: we      ! weir elevation, max depth of reservoir before overtop (m)
+    real, intent(IN)    :: wc      ! weir coeff.
+    real, intent(IN)    :: wl      ! weir length (m)
+    real, intent(IN)    :: oe      ! orifice elevation
+    real, intent(IN)    :: oc      ! orifice coeff.
+    real, intent(IN)    :: oa      ! orifice area (m^2)
+    integer, intent(IN) :: ln      ! lake number
+
+    !! ----------------------------  local variables
+    real :: sap                    ! local surface area values
+    real :: discharge              ! storage discharge m^3/s
+    real :: tmp1, tmp2
+    real :: dh, dh1, dh2, dh3      ! height function and 3 order RK
+    real :: It, Itdt_3, Itdt_2_3
+
+    !! ----------------------------  subroutine body: from chow, mad mays. pg. 252
+    !! -- determine from inflow hydrograph
+
+    It = qi0
+    Itdt_3   = (qi0 + (qi1 + ql))/3
+    Itdt_2_3 = (qi0 + (qi1 + ql))/3 + Itdt_3
+
+    !-- determine Q(dh) from elevation-discharge relationship
+    !-- and dh1
+    dh = H - we
+    if (dh .gt. 0.0 ) then              !! orifice and overtop discharge
+        tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        tmp2 = wc * wl * dh * sqrt(dh)
+        discharge = tmp1 + tmp2
+        sap = (ar * 1000.0**2) * (1 + (H - we) / H)
+    else if ( H .gt. oe ) then     !! only orifice flow,not full
+        discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        sap = ar * 1000.0**2
+    else
+        discharge = 0.0
+        sap = ar * 1000.0**2
+    endif
+    dh1 = ((It - discharge)/sap)*dt
+
+    !-- determine Q(H + dh1/3) from elevation-discharge relationship
+    !-- dh2
+    dh = (H+dh1/3) - we
+    if (dh .gt. 0.0 ) then              !! orifice and overtop discharge
+        tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        tmp2 = wc * wl * dh * sqrt(dh)
+        discharge = tmp1 + tmp2
+        sap = (ar * 1000.0**2) * (1 + (H - we) / H)
+    else if ( H .gt. oe ) then     !! only orifice flow,not full
+        discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        sap = ar * 1000.0**2
+    else
+        discharge = 0.0
+        sap = ar * 1000.0**2
+    endif
+    dh2 = ((Itdt_3 - discharge)/sap)*dt
+
+    !-- determine Q(H + 2/3 dh2) from elevation-discharge relationship
+    !-- dh3
+    dh = (H + (0.667*dh2)) - we
+    if (dh .gt. 0.0 ) then              !! orifice and overtop discharge
+        tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        tmp2 = wc * wl * dh * sqrt(dh)
+        discharge = tmp1 + tmp2
+        sap = (ar * 1000.0**2) * (1 + (H - we) / H)
+    else if ( H .gt. oe ) then     !! only orifice flow,not full
+        discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        sap = ar * 1000.0**2
+    else
+        discharge = 0.0
+        sap = ar * 1000.0**2
+    endif
+    dh3 = ((Itdt_2_3 - discharge)/sap)*dt
+
+    !-- determine dh and H
+    dh = (dh1/4.) + (0.75*dh3)
+    H = H + dh
+
+    !-- compute final discharge
+    dh = H - we
+
+    if (dh .gt. 0.0 ) then              !! orifice and overtop discharge
+        tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        tmp2 = wc * wl * dh * sqrt(dh)
+        discharge = tmp1 + tmp2
+        sap = (ar * 1000.0**2) * (1 + (H - we) / H)
+    else if ( H .gt. oe ) then     !! only orifice flow,not full
+        discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        sap = ar * 1000.0**2
+    else
+        discharge = 0.0
+        sap = ar * 1000.0**2
+    endif
+
+    qo1  = discharge  ! return the flow rate from reservoir
+
+23 format('botof H dh orf wr Q',f8.4,2x,f8.4,2x,f8.3,2x,f8.3,2x,f8.2)
+24 format('ofonl H dh sap Q ',f8.4,2x,f8.4,2x,f8.0,2x,f8.2)
+
+  RETURN
+
+! ----------------------------------------------------------------
+  END SUBROUTINE LEVELPOOL
+! ----------------------------------------------------------------
+
+
+! ------------------------------------------------
+!   FUNCTION Diffusive wave
+! ------------------------------------------------
+        REAL FUNCTION DIFFUSION(nod,z1,z2,h1,h2,dx,n, &
+                                Bw, Cs)
+        IMPLICIT NONE
+!-- channel geometry and characteristics
+        REAL    :: Bw         !-bottom width (meters)
+        REAL    :: Cs         !-Channel side slope slope
+        REAL    :: dx         !-channel lngth (m)
+        REAL    :: n          !-mannings coefficient
+        REAL    :: R          !-Hydraulic radius
+        REAL    :: AREA       !- wetted area
+        REAL    :: h1,h2      !-tmp height variables
+        REAL    :: z1,z2      !-z1 is 'from', z2 is 'to' elevations
+        REAL    :: z          !-channel side distance
+        REAL    :: w          !-upstream weight
+        REAL    :: Ku,Kd      !-upstream and downstream conveyance
+        REAL    :: Kf         !-final face conveyance
+        REAL    :: Sf         !-friction slope
+        REAL    :: sgn        !-0 or 1 
+        INTEGER :: nod         !- node
+
+        if (n.le.0.0.or.Cs.le.0.or.Bw.le.0) then
+#ifdef HYDRO_D
+         print *, "error in Diffusion function ->channel coefficients"
+         print *, "nod, n, Cs, Bw", nod, n, Cs, Bw 
+         call hydro_stop()
+#endif
+        endif
+
+!        Sf = ((z1+h1)-(z2+h2))/dx  !-- compute the friction slope
+       !if(z1 .eq. z2) then
+       ! Sf = ((z1-(z2-0.01))+(h1-h2))/dx  !-- compute the friction slope
+       !else
+!         Sf = ((z1-z2)+(h1-h2))/dx  !-- compute the friction slope
+       !endif
+
+!modifieed by Wei Yu for false geography data
+         if(abs(z1-z2) .gt. 1.0E4) then
+#ifdef HYDRO_D
+             print*, "Warning: huge slope rest to 0 for channel grid.", z1,z2
+#endif
+             Sf = ((h1-h2))/dx  !-- compute the friction slope
+         else
+             Sf = ((z1-z2)+(h1-h2))/dx  !-- compute the friction slope
+         endif
+!end  modfication
+
+        sgn = SGNf(Sf)             !-- establish sign
+
+        w = 0.5*(sgn + 1.)         !-- compute upstream or downstream weighting
+        
+        z = 1/Cs                   !--channel side distance (m)
+        R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z**2)) !-- Hyd Radius
+        AREA = (Bw+z*h1)*h1        !-- Flow area
+        Ku = (1/n)*(R**(2./3.))*AREA     !-- convenyance
+
+        R = ((Bw+z*h2)*h2)/(Bw+2*h2*sqrt(1+z**2)) !-- Hyd Radius
+        AREA = (Bw+z*h2)*h2        !-- Flow area
+        Kd = (1/n)*(R**(2./3.))*AREA     !-- convenyance
+
+        Kf =  (1-w)*Kd + w*Ku      !-- conveyance 
+        DIFFUSION = Kf * sqrt(abs(Sf))*sgn
+
+
+100     format('z1,z2,h1,h2,kf,Dif, Sf, sgn  ',f8.3,2x,f8.3,2x,f8.4,2x,f8.4,2x,f8.3,2x,f8.3,2x,f8.3,2x,f8.0)
+
+  END FUNCTION DIFFUSION
+! ----------------------------------------------------------------
+
+! ------------------------------------------------
+!   FUNCTION MUSKINGUM CUNGE
+! ------------------------------------------------
+        REAL FUNCTION MUSKINGCUNGE(index,qup, quc, qdp, ql,&
+                                   dt,So,dx,n,Cs,Bw)
+        IMPLICIT NONE
+
+!--local variables
+        REAL    :: C1, C2, C3, C4
+        REAL    :: Km         !K travel time in hrs in reach
+        REAL    :: X          !weighting factors 0<=X<=0.5
+        REAL    :: dt         !routing period in  seconds
+        REAL    :: qup        !flow upstream previous timestep
+        REAL    :: quc        !flow upstream current timestep
+        REAL    :: qdp        !flow downstream previous timestep
+        REAL    :: ql         !lateral inflow through reach (m^3/sec)
+        REAL    :: Ck         ! wave celerity (m/s)
+        REAL    :: qp         ! peak flow
+
+!-- channel geometry and characteristics
+        REAL    :: Bw         ! bottom width (meters)
+        REAL    :: Cs         ! Channel side slope slope
+        REAL    :: So         ! Channel bottom slope
+        REAL    :: dx         ! channel lngth (m)
+        REAL    :: n          ! mannings coefficient
+        REAL    :: Tw         ! top width at peak flow
+        REAL    :: AREA       ! Cross sectional area m^2
+        REAL    :: Z          ! trapezoid distance (m)
+        REAL    :: R          ! Hydraulic radius
+        REAL    :: WP         ! wetted perimmeter
+        REAL    :: h          ! depth of flow
+        REAL    :: Qj         ! intermediate flow estimate
+        REAL    :: D,D1       ! diffusion coeff
+        REAL    :: dtr        ! required timestep, minutes
+        REAL    :: error,shapefn, sh1, sh2, sh3
+        REAL    :: hp         !courant, previous height
+        INTEGER :: maxiter    !maximum number of iterations
+
+!-- local variables.. needed if channel is sub-divded
+        REAL    :: c,b
+        REAL    :: dxlocal
+        INTEGER :: i,index     !-- channel segment counter
+        INTEGER :: ChnSegments !-- number of channel sub-sections
+
+        c = 0.2407  !-- coefficnets for finding dx/Ckdt
+        b = 1.16065
+
+        z = 1/Cs              !channel side distance (m)
+        h = sqrt(quc+ql)*0.1   !-- assume a initial depth (m)
+        qp = quc + ql
+
+        if (n.le.0.or.So.le.0.or.z.le.0.or.Bw.le.0) then
+#ifdef HYDRO_D
+          print*, "error in channel coefficients -> Muskingum cunge"
+          call hydro_stop()
+#endif
+        end if
+
+        error = 1.0
+        maxiter = 0
+
+        if (quc .gt.0) then  !--top of link must have some water in it
+         do while (error .gt. 0.01 .and. maxiter < 100)  !-- first estimate depth at top of channel
+          maxiter = maxiter + 1
+          !---trapezoidal channel shape function
+          shapefn = SHAPE(Bw,z,h)
+          Qj = FLOW(n,So,Bw,h,z)
+          h = h - (1-quc/Qj)/(shapefn)
+          error = abs((Qj - quc)/quc)
+         end do
+        endif
+
+        maxiter = 0
+!------- approximate flow and depth at the bottom of the channel
+        if (ql .eq.0 .and. quc .eq. 0) then  !-- no water to route
+          Qj=0.0
+        else
+          error = 1.0                        !--reset the error
+          Tw = Bw + 2*z*h                    !--top width of the channel inflow
+          Ck = (sqrt(So)/n)*(5/3)*h**0.667  !-- pg 287 Chow, Mdt, Mays
+          X = 0.5-(qp/(2*Tw*So*Ck*dx))
+          if (X.le.0) then 
+#ifdef HYDRO_D
+           print *, "Muskingum weighting factor is less than 0"
+#endif
+          endif
+
+        if ( dx/(Ck*dt) .le. c*LOG(X)+b) then  !-- Bedient and Huber pg. 296
+            ChnSegments = 1
+            dxlocal = dx
+         else
+           dxlocal = fnDX(qp,Tw,So, Ck,dx,dt) !-- find appropriate channel length
+           X = 0.5-(qp/(2*Tw*So*Ck*dxlocal))
+           if(FRACTION(dx/dxlocal) .le. 0.5) then  !-- round up 
+            ChnSegments = NINT(dx/dxlocal) + 1
+           else
+            ChnSegments = NINT(dx/dxlocal)
+           endif
+          dxlocal = dx/ChnSegments !-- compute segment length, which will
+        endif
+
+        do i = 1, ChnSegments
+         error = 1.0                        !--reset the error
+
+         do while (error .gt. 0.01 .and. maxiter < 500)
+
+           if (qp.gt.2*(2*Tw*So*Ck*dxlocal)) then
+#ifdef HYDRO_D
+            print *, "ERROR IN Musking Cunge,X <0 ", X
+            print *, "X,Qp,Tw,So,Ck,Dxlocal",X,Qp,Tw,So,Ck,Dxlocal
+#endif
+           endif
+
+           Km = dxlocal/Ck                      !-- minutes,Muskingum Param
+           D = (Km*(1 - X) + dt/2)              !-- minutes
+           C1 = (Km*X + dt/2)/D
+           C2 = (dt/2 - Km*X)/D
+           C3 = (Km*(1-X)-dt/2)/D
+           C4 = (ql/ChnSegments*dt)/D           !-- lateral inflow is along each channel sub-section
+
+           MUSKINGCUNGE = (C1*qup)+(C2*quc)+(C3*qdp)+C4 !-- pg 295 Bedient huber assume flows from previous
+                                                        !--previous values same in each segment,a good assumption?
+           if (MUSKINGCUNGE .lt. 0) then !-- only outflow
+#ifdef HYDRO_D
+            print *, "ERROR: musking cunge is negative"
+            print *, "D, C1+C2+C3,C4, MsCng",D,C1+C2+C3,C4,Muskingcunge
+            print *, "qup, quc, qdp, ql",qup,quc,qdp,ql,i,ChnSegments
+#endif
+            Qj = 0.0
+            error = 0.001
+           else 
+!---trapezoidal channel shape function
+            shapefn = SHAPE(Bw,z,h)
+            Qj = FLOW(n,So,Bw,h,z)
+            h = h - (1-MUSKINGCUNGE/Qj)/(shapefn)
+            error = abs((Qj - MUSKINGCUNGE)/MUSKINGCUNGE)
+            if (h<0.00001) error=0.001  !--very small flow depths to route
+            Tw = Bw+2*z*h
+            hp=h
+            maxiter = maxiter + 1
+           endif 
+          enddo !-- while error condtion number of 
+            if (ChnSegments .gt.1) then
+             quc =  MUSKINGCUNGE !-- update condition for next channel length upstream
+            endif
+        enddo !-- number of channel segment loops
+       endif
+
+       MUSKINGCUNGE = Qj
+
+         if(index .eq. 1 .or. index .eq. 2 .or. index .eq. 6) then
+#ifdef HYDRO_D
+           write(*,13) index, ql,quc,qup,Qj,qdp
+#endif
+         endif
+
+10      format('Tw,h,Z, latflow,usf',f3.1,2x,f8.4,2x,f4.1,2x,f5.4,2x,f5.4)
+11      format('h, Qj, Musking, error',f8.4,2x,f8.4,2x,f8.4,2x,f8.4)
+12      format('X, Km, Ck, dtcrv',f8.2,2x,f8.1,2x,f8.1,2x,f6.4)
+13      format('ql,quc,qup,qdc,qdp',i2,2x,f8.2,2x,f8.2,2x,f8.2,2x,f8.2,2x,f8.2)
+
+! ----------------------------------------------------------------
+  END FUNCTION MUSKINGCUNGE
+! ----------------------------------------------------------------
+
+! ------------------------------------------------
+!   FUNCTION KINEMATIC
+! ------------------------------------------------
+	REAL FUNCTION KINEMATIC()
+
+	IMPLICIT NONE
+
+! -------- DECLARATIONS -----------------------
+ 
+!	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)	:: OVRGH
+
+        KINEMATIC = 1       
+!----------------------------------------------------------------
+  END FUNCTION KINEMATIC
+!----------------------------------------------------------------
+
+
+! ------------------------------------------------
+!   SUBROUTINE drive_CHANNEL
+! ------------------------------------------------
+     Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, &
+       QSUBRT, LAKEINFLORT, QSTRMVOLRT, TO_NODE, FROM_NODE, &
+       TYPEL, ORDER, MAXORDER, NLINKS, CH_NETLNK, CH_NETRT, &
+       LAKE_MSKRT, DT, DTRT, MUSK, MUSX, QLINK, &
+       HLINK, ELRT, CHANLEN, MannN, So, ChSSlp, Bw, &
+       RESHT, HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, &
+       ORIFICEE, ZELEV, CVOL, NLAKES, QLAKEI, QLAKEO, LAKENODE, &
+       dist, QINFLOWBASE, CHANXI, CHANYJ, channel_option, RETDEP_CHAN &
+       ,node_area &
+#ifdef MPP_LAND 
+       ,lake_index,link_location,mpp_nlinks,nlinks_index,yw_mpp_nlinks &
+#endif
+       )
+
+       IMPLICIT NONE
+
+! -------- DECLARATIONS ------------------------
+
+        INTEGER, INTENT(IN) :: IXRT,JXRT,channel_option
+        INTEGER, INTENT(IN) :: NLINKS,NLAKES  
+        integer, INTENT(INOUT) :: KT   ! flag of cold start (1) or continue run.
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: QSUBRT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: QSTRMVOLRT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: LAKEINFLORT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: ELRT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: QINFLOWBASE
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT
+
+
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT
+        INTEGER, INTENT(IN), DIMENSION(NLINKS)    :: ORDER, TYPEL !--link
+        INTEGER, INTENT(IN), DIMENSION(NLINKS)    :: TO_NODE, FROM_NODE
+        INTEGER, INTENT(IN), DIMENSION(NLINKS)    :: CHANXI, CHANYJ
+        REAL,    INTENT(IN), DIMENSION(NLINKS)    :: ZELEV  !--elevation of nodes
+        REAL, INTENT(INOUT), DIMENSION(NLINKS)    :: CVOL
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: MUSK, MUSX
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: CHANLEN
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: So, MannN
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: ChSSlp,Bw  !--properties of nodes or links
+        REAL                                      :: Km, X
+        REAL , INTENT(INOUT), DIMENSION(NLINKS,2) :: QLINK
+        REAL , INTENT(INOUT), DIMENSION(NLINKS)   :: HLINK
+        REAL, INTENT(IN)                          :: DT    !-- model timestep
+        REAL, INTENT(IN)                          :: DTRT  !-- routing timestep
+        REAL                                      :: DTCT, dist(ixrt,jxrt,9)
+        REAL                                      :: RETDEP_CHAN
+        INTEGER, INTENT(IN)                       :: MAXORDER, SUBRTSWCRT
+        REAL , INTENT(IN), DIMENSION(NLINKS)   :: node_area
+
+        !-- lake params
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: HRZAREA  !-- horizontal area (km^2)
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: LAKEMAXH !-- maximum lake depth  (m^2)
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: WEIRC    !-- weir coefficient
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: WEIRL    !-- weir length (m)
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: ORIFICEC !-- orrifice coefficient
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: ORIFICEA !-- orrifice area (m^2)
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: ORIFICEE !-- orrifce elevation (m)
+
+        REAL, INTENT(INOUT), DIMENSION(NLINKS)    :: RESHT    !-- reservoir height (m)
+        REAL, INTENT(INOUT), DIMENSION(NLINKS)    :: QLAKEI   !-- lake inflow (cms)
+        REAL,                DIMENSION(NLINKS)    :: QLAKEIP  !-- lake inflow previous timestep (cms)
+        REAL, INTENT(INOUT), DIMENSION(NLINKS)    :: QLAKEO   !-- outflow from lake used in diffusion scheme
+        INTEGER, INTENT(IN), DIMENSION(NLINKS)    :: LAKENODE !-- outflow from lake used in diffusion scheme
+        REAL, DIMENSION(NLINKS)                   :: QLateral !--lateral flux
+        REAL, DIMENSION(NLINKS)                   :: QSUM     !--mass bal of node
+        REAL, DIMENSION(NLINKS)                   :: QLLAKE   !-- lateral inflow to lake in diffusion scheme
+
+!-- Local Variables
+        INTEGER                     :: i,j,k,m,kk,KRT,node
+        INTEGER                     :: DT_STEPS            !-- number of timestep in routing
+        REAL                        :: qu,qd               !--upstream, downstream flow
+        REAL                        :: bo               !--critical depth, bnd outflow just for testing
+
+        REAL, DIMENSION(NLINKS,2)   :: QLINKPREV         !-- temporarily store qlink value
+        REAL ,DIMENSION(NLINKS)     :: HLINKTMP,CVOLTMP  !-- temporarily store head values and volume values
+        REAL ,DIMENSION(NLINKS)     :: CD                !-- critical depth
+        real, DIMENSION(IXRT,JXRT) :: tmp
+        real, dimension(nlinks) :: tmp2
+
+#ifdef MPP_LAND
+        integer lake_index(nlakes)
+        integer nlinks_index(nlinks)
+        integer mpp_nlinks, iyw, yw_mpp_nlinks
+        integer link_location(ixrt,jxrt)
+        real     ywtmp(ixrt,jxrt)
+#endif
+        integer flag
+
+        QLAKEIP = 0
+        QLINKPREV = 0
+        HLINKTMP = 0
+        CVOLTMP = 0
+        CD = 0  
+
+!yw        node = 3924
+        node = 1
+
+
+        QLateral = 0
+        QSUM     = 0
+        QLLAKE   = 0
+        
+
+        IF(channel_option .ne. 3) then   !--muskingum methods ROUTE ON DT timestep, not DTRT!!
+#ifdef MPP_LAND
+#ifdef HYDRO_D
+   write(6,*) "Error: not parallelized"
+   call hydro_stop() 
+#endif
+#endif
+         DT_STEPS = 1
+
+         DO KRT=1,DT_STEPS                 !-- route over routing timestep
+          do k = 1, NLINKS
+             QLateral(k)=0                        !--initial lateral flux to 0 for this reach
+             do i = 1, IXRT
+               do j = 1, JXRT
+                !--------river grid points
+                !!!!  IS THIS CORREECT BECAUSE CH_NETRT IS JUST A 0,1?????
+                 if ( (CH_NETRT(i,j) .eq. k) .and. (LAKE_MSKRT(i,j) .eq. -9999)) then
+                   !--------river grid points
+                   !-- convert total volume into flow rate across reach (m3/sec)
+                   !-- QSUBRT and QSTRMVOLRT are mm for the DT interval, so
+                   !-- you need to divided by the timestep fraction and
+                   !-- multiply by DXRT^2 1m/1000mmm/DT 
+                   QLateral(k) = QLateral(k) + ((QSUBRT(i,j)+QSTRMVOLRT(i,j))/DT_STEPS &
+                      *dist(i,j,9)/1000/DT) + QINFLOWBASE(i,j)
+                 elseif ( (LAKE_MSKRT(i,j) .eq. k)) then !-lake grid
+                   !-- convert total volume into flow rate across reach (m3/sec)
+                   QLateral(k) = QLateral(k) + (LAKEINFLORT(i,j)/DT_STEPS &
+                      *dist(i,j,9)/1000/DT) + QINFLOWBASE(i,j)
+                 endif
+               end do
+             end do
+          end do
+          
+!----------  route order 1 reaches which have no upstream inflow
+          do k=1, NLINKS
+            if (ORDER(k) .eq. 1) then  !-- first order stream has no headflow
+
+               if (KT .eq. 1) then  !-- initial slug of water in unpstream cells
+                 qd = QLINK(k,1)
+                 KT = KT + 1
+               else
+                 qd = QLINK(k,2)        !-- downstream outflow, previous timestep
+                 QLINK(k,1) = 0
+               endif
+
+                if(TYPEL(k) .eq. 1) then    !-- level pool route of reservoir
+                 !CALL LEVELPOOL(1,0.0, 0.0, qd, QLINK(k,2), QLateral(k), &
+                 ! DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), &
+                 ! WEIRC(k), WEIRL(k), ORIFICEE(i), ORIFICEC(k), ORIFICEA(k) )
+                elseif (channel_option .eq. 1) then
+                  Km = MUSK(k)
+                  X = MUSX(k)
+                  QLINK(k,2) = MUSKING(QLINK(k,1), QLateral(k), qd, DT, Km, X) !--current outflow
+                elseif (channel_option .eq. 2) then !-- upstream is assumed constant initial condition
+                  QLINK(k,2) = MUSKINGCUNGE(k,QLINK(k,1),QLINK(k,1), qd, &
+                                  QLateral(k), DT, So(k), CHANLEN(k), &
+                                  MannN(k), ChSSLP(k), Bw(k))
+
+                else
+#ifdef HYDRO_D
+                 print *, "No channel option selected"
+                 call hydro_stop() 
+#endif
+                endif
+            endif
+          end do
+
+      !---------- route other reaches, with upstream inflow
+          do kk = 2, MAXORDER
+             do k = 1, NLINKS
+                qu  = 0
+                if (ORDER(k) .eq. kk) then    !--do the orders sequentially
+                   qd = QLINK(k,2)            !--downstream flow previous timestep
+
+                   do m = 1, NLINKS
+                      if (TO_NODE(m) .eq. FROM_NODE(k)) then
+                        qu = qu + QLINK(m,2)  !--upstream previous timestep
+                      endif
+                   end do ! do m
+
+
+                   if(TYPEL(k) .eq. 1) then   !--link is a reservoir
+                   ! CALL LEVELPOOL(1,QLINK(k,1), qu, qd, QLINK(k,2), &
+                   !  QLateral(k), DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), &
+                   !  WEIRC(k), WEIRL(k),ORIFICEE(k),  ORIFICEC(k), ORIFICEA(k))
+                   elseif (channel_option .eq. 1) then  !muskingum routing
+                       Km = MUSK(k)
+                       X = MUSX(k)
+                       QLINK(k,2) = MUSKING(QLINK(k,1),qu,qd,DT,Km,X)
+                   elseif (channel_option .eq. 2) then ! muskingum cunge
+                       QLINK(k,2) = MUSKINGCUNGE(k,QLINK(k,1), qu, qd, &
+                                    QLateral(k), DT, So(k),  CHANLEN(k), &
+                                    MannN(k), ChSSlp(k), Bw(k) )
+                   else
+#ifdef HYDRO_D
+                    print *, " no channel option selected"
+                    call hydro_stop() 
+#endif
+                   endif
+                   QLINK(k,1) = qu    !save inflow to reach at current timestep
+                                      !to be used as inflow from previous timestep
+                                      !on next iteration
+                endif     !--order == kk
+             end do       !--k links
+          end do          !--kk order
+
+#ifdef HYDRO_D
+          print *, "END OF ALL REACHES...",KRT,DT_STEPS
+#endif
+
+         END DO !-- krt timestep for muksingumcunge routing
+
+!yw begin
+         elseif(channel_option .eq. 3) then   !--- route using the diffusion scheme on nodes not links
+#ifdef MPP_LAND
+         call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINK,NLINKS,99)
+         call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOL,NLINKS,99)
+#endif
+ 
+         KRT = 0                  !-- initialize the time counter
+         DTCT = DTRT              !-- initialize the routing timestep to the timestep in namelist (s)
+         HLINKTMP = HLINK         !-- temporary storage of the water elevations (m)
+         CVOLTMP = CVOL           !-- temporary storage of the volume of water in channel (m^3)
+         QLAKEIP = QLAKEI         !-- temporary lake inflow from previous timestep  (cms)
+
+
+!        call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,ZELEV,NLINKS,99)
+crnt:    DO                      !-- loop on the courant condition
+         QSUM   = 0              !-- initialize the total flow out of each cell to zero
+         QLAKEI = 0              !-- set the lake inflow as zero
+         QLLAKE = 0              !-- initialize each lake's lateral inflow to zero  
+         DT_STEPS=INT(DT/DTCT)   !-- fix the timestep
+         QLateral = 0. 
+
+
+!-- vectorize
+!--------------------- 
+#ifdef MPP_LAND
+         DO iyw = 1,yw_MPP_NLINKS
+         i = nlinks_index(iyw)
+#else
+         DO i = 1,NLINKS
+#endif
+           if(node_area(i) .eq. 0) then
+#ifdef HYDRO_D
+               write(6,*) "Error: node_area(i) is zero. i=", i
+               call hydro_stop() 
+#endif
+           endif
+
+           if((CH_NETRT(CHANXI(i), CHANYJ(i) ) .eq. 0) .and. &
+              (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .lt.0) ) then !--a reg. node
+              QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) =  &
+! await subsfc exchg   ((QSUBRT(CHANXI(i),CHANYJ(i))+QSTRMVOLRT(CHANXI(i),CHANYJ(i))+&
+                ((QSTRMVOLRT(CHANXI(i),CHANYJ(i))+&
+                 QINFLOWBASE(CHANXI(i),CHANYJ(i))) &
+                   /DT_STEPS*node_area(i)/1000/DTCT)
+	if(Qlateral(CH_NETLNK(CHANXI(i),CHANYJ(i))).lt.0.) then
+#ifdef HYDRO_D
+               print*, "i, CHANXI(i),CHANYJ(i) = ", i, CHANXI(i),CHANYJ(i)
+               print *, "NEGATIVE Lat inflow...",QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))), &
+                         QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)), &
+                         QINFLOWBASE(CHANXI(i),CHANYJ(i))
+               call hydro_stop() 
+#endif
+        end if
+            elseif(LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .gt. 0 .and. &
+               (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .ne. 9999)) then !--a lake node
+              QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) = &
+                 QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) + &
+                 (LAKEINFLORT(CHANXI(i),CHANYJ(i))+ &
+                 QINFLOWBASE(CHANXI(i),CHANYJ(i)) &
+                 /DT_STEPS*node_area(i)/1000/DTCT)
+            elseif(CH_NETRT(CHANXI(i),CHANYJ(i)) .gt. 0) then  !pour out of lake
+                 QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) =  &
+                   QLAKEO(CH_NETRT(CHANXI(i),CHANYJ(i)))  !-- previous timestep
+          endif
+        ENDDO
+
+
+#ifdef MPP_LAND
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLateral,NLINKS,99)
+    call MPP_CHANNEL_COM_REAL(LAKE_MSKRT   ,ixrt,jxrt,QLLAKE,NLINKS,99)
+#endif
+
+
+          !-- compute conveyances, with known depths (just assign to QLINK(,1)
+          !--QLINK(,2) will not be used), QLINK is the flow across the node face
+          !-- units should be m3/second.. consistent with QL (lateral flow)
+
+#ifdef MPP_LAND
+         DO iyw = 1,yw_MPP_NLINKS
+         i = nlinks_index(iyw)
+#else
+           DO i = 1,NLINKS
+#endif
+           if (TYPEL(i) .eq. 0 .AND. HLINKTMP(FROM_NODE(i)) .gt. RETDEP_CHAN) then 
+            
+           if(from_node(i) .ne. to_node(i) ) &  ! added by Wei Yu
+              QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), &
+                HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), &
+                CHANLEN(i), MannN(i), Bw(i), ChSSlp(i))
+
+#ifdef HYDRO_D
+            if(qlink(i,1)  .ge. 1.0E6) then
+               print*, "Warning: big Qlink",QLINK(i,1),i,TO_NODE(i),from_node(i)
+            endif
+#endif
+
+            else !--  we are just computing critical depth for outflow points
+               QLINK(i,1) =0.
+            endif
+          ENDDO
+
+#ifdef MPP_LAND
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99)
+#endif
+ 
+          !-- compute total flow across face, into node
+#ifdef MPP_LAND
+         DO iyw = 1,yw_mpp_nlinks
+         i = nlinks_index(iyw)
+#else
+          DO i = 1,NLINKS                                                 !-- inflow to node across each face
+#endif
+           if(TYPEL(i) .eq. 0) then                                       !-- only regular nodes have to attribute
+            QSUM(TO_NODE(i)) = QSUM(TO_NODE(i)) + QLINK(i,1)
+           endif
+          END DO
+
+#ifdef MPP_LAND
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,99)
+#endif
+
+#ifdef MPP_LAND
+         DO iyw = 1,yw_mpp_nlinks
+         i = nlinks_index(iyw)
+#else
+          DO i = 1,NLINKS                                                 !-- outflow from node across each face
+#endif
+            QSUM(FROM_NODE(i)) = QSUM(FROM_NODE(i)) - QLINK(i,1)
+          END DO
+#ifdef MPP_LAND
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,99)
+#endif
+
+         flag = 99
+#ifdef MPP_LAND
+         DO iyw = 1,yw_MPP_NLINKS
+             i = nlinks_index(iyw)
+#else
+          DO i = 1, NLINKS                                                !--- compute volume and depth at each node
+#endif
+ 
+           if( TYPEL(i).eq.0 .and. CVOLTMP(i) .ge. 0.001 .and.(CVOLTMP(i)-QSUM(i)*DTCT)/CVOLTMP(i) .le. -0.01 ) then  
+            flag = -99
+#ifdef HYDRO_D
+            write(6,*) "Unstatble at node ",i
+            write(6,*) "TYPEL, CVOLTMP, QSUM, QSUM*DTCT",TYPEL(i), CVOLTMP(i), QSUM(i), QSUM(i)*DTCT
+            write(6,*) "qsubrt, qstrmvolrt,qlink",QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)),qlink(i,1),qlink(i,2)
+#endif
+            
+            goto 999  
+            endif 
+          enddo 
+
+999 continue
+#ifdef MPP_LAND
+        call mpp_same_int1(flag)
+#endif
+
+
+        if(flag < 0 )   then   
+             if(DTCT .gt. 0.001) then                  !-- timestep in seconds
+              DTCT = DTCT/2                            !-- 1/2 timestep
+              KRT = 0                                  !-- restart counter
+              HLINKTMP = HLINK                         !-- set head and vol to start value of timestep
+              CVOLTMP = CVOL
+              CYCLE crnt                               !-- start cycle over with smaller timestep
+             else
+#ifdef HYDRO_D
+              write(6,*) "Error ..... with small DTCT",DTCT
+              call hydro_stop()
+#endif
+              DTCT = 0.1
+              HLINKTMP = HLINK                          !-- set head and volume to start values of timestep
+              CVOLTMP  = CVOL
+              goto 998  
+             end if
+        endif 
+
+998 continue
+
+
+#ifdef MPP_LAND
+         DO iyw = 1,yw_MPP_NLINKS
+            i = nlinks_index(iyw)
+#else
+         DO i = 1, NLINKS                                                !--- compute volume and depth at each node
+#endif
+ 
+            if(TYPEL(i) .eq. 0) then                   !--  regular channel grid point, compute volume
+              CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) )* DTCT
+              if(CVOLTMP(i) .lt. 0) then 
+#ifdef HYDRO_D
+                print *, "warning! channel volume less than 0:i,CVOL,QSUM,QLat", &
+                               i, CVOLTMP(i),QSUM(i),QLateral(i),HLINK(i)
+#endif
+                CVOLTMP(i) =0 
+              endif
+
+            elseif(TYPEL(i) .eq. 1) then               !-- pour point, critical depth downstream 
+
+              if (QSUM(i)+QLateral(i) .lt. 0) then
+              else
+
+               CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i))
+
+              endif
+               ! change in volume is inflow, lateral flow, and outflow 
+               CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - &
+               !yw DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*DXRT),HLINKTMP(i), &
+               DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), &
+               CD(i),CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT
+
+            elseif (TYPEL(i) .eq. 2) then              !--- into a reservoir, assume critical depth
+              if (QSUM(i)+QLateral(i) .lt. 0) then
+#ifdef HYDRO_D
+               print *, i, 'CrtDpth Qsum+QLat into lake< 0',QSUM(i), QLateral(i)
+#endif
+              else
+               CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i))
+              endif
+ 
+              !-- compute volume in reach (m^3)
+              CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - &
+              DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), &
+              CD(i) ,CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT
+ 
+              !-- compute flow rate into lake from all contributing nodes (cms)
+              QLAKEI(LAKENODE(i)) = QLAKEI(LAKENODE(i)) + QLINK(FROM_NODE(i),1)
+
+            else
+#ifdef HYDRO_D
+              print *, "this node does not have a type.. error"
+              call hydro_stop() 
+#endif
+            endif
+           
+           if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow
+            HLINKTMP(i) = HEAD(i, CVOLTMP(i)/CHANLEN(i),Bw(i),1/ChSSlp(i))  !--updated depth 
+           else
+            HLINKTMP(i) = CD(i)  !!!   CRITICALDEPTH(i,QSUM(i)+QLateral(i), Bw(i), 1./ChSSlp(i)) !--critical depth is head
+           endif 
+
+           END DO  !--- done processing all the links
+
+#ifdef MPP_LAND
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOLTMP,NLINKS,99)
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CD,NLINKS,99)
+    call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99)
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINKTMP,NLINKS,99)
+#endif 
+
+!         call check_channel(92,CVOLTMP,nlinks_index,mpp_nlinks,nlinks)
+!         call check_channel(91,CD,nlinks_index,mpp_nlinks,nlinks)
+!         call check_channel(55,QLAKEI,nlinks_index,mpp_nlinks,nlinks)
+!         call check_channel(56,HLINKTMP,nlinks_index,mpp_nlinks,nlinks)
+
+
+           do i = 1, NLAKES !-- mass balances of lakes
+#ifdef MPP_LAND
+            if(lake_index(i) .gt. 0)  then
+#endif
+              CALL LEVELPOOL(i,QLAKEIP(i), QLAKEI(i), QLAKEO(i), QLLAKE(i), &
+                DTCT, RESHT(i), HRZAREA(i), LAKEMAXH(i), WEIRC(i), &
+                WEIRL(i), ORIFICEE(i), ORIFICEC(i), ORIFICEA(i))
+                QLAKEIP(i) = QLAKEI(i)  !-- store total lake inflow for this timestep
+#ifdef MPP_LAND
+            endif
+#endif
+           enddo
+#ifdef MPP_LAND
+    call MPP_CHANNEL_COM_REAL(LAKE_MSKRT   ,ixrt,jxrt,QLLAKE,NLINKS,99)
+    call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,RESHT,NLAKES,99)
+    call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEO,NLAKES,99)
+    call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99)
+    call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEIP,NLAKES,99)
+#endif
+
+
+#ifdef MPP_LAND
+         DO iyw = 1,yw_MPP_NLINKS
+            i = nlinks_index(iyw)
+#else
+         DO i = 1, NLINKS                                                !--- compute volume and depth at each node
+#endif
+            if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow
+               QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), &
+                  HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), &
+                  CHANLEN(i), MannN(i), Bw(i), ChSSlp(i))
+            endif
+         enddo
+
+#ifdef MPP_LAND
+          call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99)
+#endif
+
+           KRT = KRT + 1                     !-- iterate on the timestep
+           IF(KRT .eq. DT_STEPS) EXIT crnt   !-- up to the maximum time in interval
+
+          END DO crnt  !--- DTCT timestep of DT_STEPS
+ 
+           HLINK = HLINKTMP                 !-- update head based on final solution in timestep
+           CVOL  = CVOLTMP                  !-- update volume
+        else                                            !-- no channel option apparently selected
+#ifdef HYDRO_D
+         print *, "no channel option selected"
+         call hydro_stop() 
+#endif
+        endif
+
+#ifdef HYDRO_D
+         write(6,*) "finished call drive_CHANNEL"
+#endif
+
+        if (KT .eq. 1) KT = KT + 1
+         
+
+ END SUBROUTINE drive_CHANNEL
+! ----------------------------------------------------------------
+
+!--================== utility functions
+     REAL FUNCTION SHAPE(Bw,z,h)
+     REAL :: Bw, z, h
+     REAL :: sh1, sh2, sh3
+          !---trapezoidal channel shape function
+          sh1 = (Bw+2*z*h)*(5*Bw + 6*h*sqrt(1+z**2))
+          sh2 = 4*z*h**2*sqrt(1+z**2)
+          sh3 = (3*h*(Bw+z*h)*(Bw+2*h*sqrt(1+z**2)))
+          if (sh3 .eq. 0) then
+           SHAPE = 0
+           else
+           SHAPE  = (sh1+sh2)/sh3
+          endif
+     END FUNCTION SHAPE
+
+     REAL FUNCTION FLOW(n,So,Bw,h,z)
+     REAL :: n,So, Bw, z, h
+     REAL :: WP, AREA
+          WP = Bw + 2*h*sqrt(1+h**2)             !-- wetted perimeter
+          AREA = (Bw+z*h)*h                      !-- Flow area
+          if (WP .le.0) then
+#ifdef HYDRO_D
+           print *, "Wetter perimeter is zero, will get divide by zero error"
+           call hydro_stop() 
+#endif
+          else
+           FLOW = (1/n)*sqrt(So)*(AREA**(5./3.)/(WP**(2./3.)))
+          endif
+     END FUNCTION FLOW
+
+!-=======================================
+     REAL FUNCTION AREAf(AREA,Bw,h,z)
+     REAL :: AREA, Bw, z, h
+       AREAf = (Bw+z*h)*h-AREA       !-- Flow area
+     END FUNCTION AREAf
+
+!-====critical depth function  ==========
+     REAL FUNCTION CDf(Q,Bw,h,z)
+     REAL :: Q, Bw, z, h
+       if(h .le. 0) then
+#ifdef HYDRO_D
+         print *, "head is zero, will get division by zero error"
+         call hydro_stop() 
+#endif
+       else
+       CDf = (Q/((Bw+z*h)*h))/(sqrt(9.81*(((Bw+z*h)*h)/(Bw+2*z*h))))-1  !--critical depth function
+       endif
+     END FUNCTION CDf
+
+!=======find flow depth in channel with bisection Chapra pg. 131
+    REAL FUNCTION HEAD(index,AREA,Bw,z)  !-- find the water elevation given wetted area, 
+                                         !--bottom widith and side channel.. index was for debuggin
+     REAL :: Bw,z,AREA,test           
+     REAL :: hl, hu, hr, hrold
+     REAL :: fl, fr,error                !-- function evaluation
+     INTEGER :: maxiter,index
+
+     error = 1.0
+     maxiter = 0
+     hl = 0.00001   !-- minimum depth is small
+     hu = 30.  !-- assume maximum depth is 30 meters
+
+    if (AREA .lt. 0.00001) then 
+     hr = 0.
+    else
+      do while ((AREAf(AREA,BW,hl,z)*AREAf(AREA,BW,hu,z)).gt.0 .and. maxiter .lt. 100) 
+       !-- allows for larger , smaller heads 
+       if(AREA .lt. 1.) then
+        hl=hl/2
+       else
+        hu = hu * 2
+       endif
+       maxiter = maxiter + 1
+        
+      end do
+
+      maxiter =0
+      hr = 0
+      fl = AREAf(AREA,Bw,hl,z)
+      do while (error .gt. 0.0001 .and. maxiter < 1000)
+        hrold = hr
+        hr = (hl+hu)/2
+        fr =  AREAf(AREA,Bw,hr,z)
+        maxiter = maxiter + 1
+         if (hr .ne. 0) then
+          error = abs((hr - hrold)/hr)
+         endif
+        test = fl * fr
+         if (test.lt.0) then
+           hu = hr
+         elseif (test.gt.0) then
+           hl=hr
+           fl = fr
+         else
+           error = 0.0
+         endif
+      end do
+     endif
+     HEAD = hr
+
+22   format("i,hl,hu,Area",i5,2x,f12.8,2x,f6.3,2x,f6.3,2x,f6.3,2x,f9.1,2x,i5)
+
+    END FUNCTION HEAD
+!=================================
+     REAL FUNCTION MANNING(h1,n,Bw,Cs)
+
+     REAL :: Bw,h1,Cs,n
+     REAL :: z, AREA,R,Kd
+
+     z=1/Cs
+     R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z**2)) !-- Hyd Radius
+     AREA = (Bw+z*h1)*h1        !-- Flow area
+     Kd = (1/n)*(R**(2./3.))*AREA     !-- convenyance
+#ifdef HYDRO_D
+     print *,"head, kd",  h1,Kd
+#endif
+     MANNING = Kd
+     
+     END FUNCTION MANNING
+
+!=======find flow depth in channel with bisection Chapra pg. 131
+     REAL FUNCTION CRITICALDEPTH(lnk,Q,Bw,z)  !-- find the critical depth
+     REAL :: Bw,z,Q,test
+     REAL :: hl, hu, hr, hrold
+     REAL :: fl, fr,error   !-- function evaluation
+     INTEGER :: maxiter
+     INTEGER :: lnk
+
+     error = 1.0
+     maxiter = 0
+     hl = 1e-5   !-- minimum depth is 0.00001 meters
+!    hu = 35.       !-- assume maximum  critical depth 25 m
+     hu = 100.       !-- assume maximum  critical depth 25 m
+
+     if(CDf(Q,BW,hl,z)*CDf(Q,BW,hu,z) .gt. 0) then
+      if(Q .gt. 0.001) then
+#ifdef HYDRO_D
+        print *, "interval won't work to find CD of lnk ", lnk
+        print *, "Q, hl, hu", Q, hl, hu
+        print *, "cd lwr, upr", CDf(Q,BW,hl,z), CDf(Q,BW,hu,z)
+        call hydro_stop() 
+#endif
+      else
+        Q = 0.0
+      endif
+     endif
+
+     hr = 0.
+     fl = CDf(Q,Bw,hl,z)
+
+     if (Q .eq. 0.) then
+       hr = 0.
+     else
+      do while (error .gt. 0.0001 .and. maxiter < 1000)
+        hrold = hr
+        hr = (hl+hu)/2
+        fr =  CDf(Q,Bw,hr,z)
+        maxiter = maxiter + 1
+         if (hr .ne. 0) then
+          error = abs((hr - hrold)/hr)
+         endif
+        test = fl * fr
+         if (test.lt.0) then
+           hu = hr
+         elseif (test.gt.0) then
+           hl=hr
+           fl = fr
+         else
+           error = 0.0
+         endif
+
+       end do
+      endif
+
+     CRITICALDEPTH = hr
+
+     END FUNCTION CRITICALDEPTH
+!================================================
+     REAL FUNCTION SGNf(val)  !-- function to return the sign of a number
+     REAL:: val
+
+     if (val .lt. 0) then
+       SGNf= -1.
+     elseif (val.gt.0) then
+       SGNf= 1.
+     else
+       SGNf= 0.
+     endif
+
+     END FUNCTION SGNf
+!================================================
+
+     REAL FUNCTION fnDX(qp,Tw,So,Ck,dx,dt) !-- find channel sub-length for MK method
+     REAL    :: qp,Tw,So,Ck,dx, dt,test
+     REAL    :: dxl, dxu, dxr, dxrold
+     REAL    :: fl, fr, error
+     REAL    :: X
+     INTEGER :: maxiter
+
+     error = 1.0
+     maxiter =0
+     dxl = dx*0.9  !-- how to choose dxl???
+     dxu = dx
+     dxr=0
+
+     do while (fnDXCDT(qp,Tw,So,Ck,dxl,dt)*fnDXCDT(qp,Tw,So,Ck,dxu,dt) .gt. 0 &
+               .and. dxl .gt. 10)  !-- don't let dxl get too small
+      dxl = dxl/1.1
+     end do
+     
+      
+     fl = fnDXCDT(qp,Tw,So,Ck,dxl,dt)
+     do while (error .gt. 0.0001 .and. maxiter < 1000)
+        dxrold = dxr
+        dxr = (dxl+dxu)/2
+        fr =  fnDXCDT(qp,Tw,So,Ck,dxr,dt)
+        maxiter = maxiter + 1
+         if (dxr .ne. 0) then
+          error = abs((dxr - dxrold)/dxr)
+         endif
+        test = fl * fr
+         if (test.lt.0) then
+           dxu = dxr
+         elseif (test.gt.0) then
+           dxl=dxr
+           fl = fr
+         else
+           error = 0.0
+         endif
+      end do
+     FnDX = dxr
+
+    END FUNCTION fnDX
+!================================================
+     REAL FUNCTION fnDXCDT(qp,Tw,So,Ck,dx,dt) !-- function to help find sub-length for MK method
+     REAL    :: qp,Tw,So,Ck,dx,dt,X
+     REAL    :: c,b  !-- coefficients on dx/cdt log approximation function
+     
+     c = 0.2407
+     b = 1.16065
+     X = 0.5-(qp/(2*Tw*So*Ck*dx))
+     if (X .le.0) then 
+      fnDXCDT = -1 !0.115
+     else
+      fnDXCDT = (dx/(Ck*dt)) - (c*LOG(X)+b)  !-- this function needs to converge to 0
+     endif
+     END FUNCTION fnDXCDT
+! ----------------------------------------------------------------------
+
+    subroutine check_channel(unit,cd,nlinks_index,mpp_nlinks,nlinks)
+         integer :: unit,mpp_nlinks,nlinks,nlinks_index(nlinks),i
+         real cd(nlinks)
+#ifdef MPP_LAND
+         call write_chanel_real(cd,nlinks_index,mpp_nlinks,nlinks)
+         if(my_id .eq. IO_id) then
+           write(unit,*) cd
+         endif
+#endif
+         return
+    end subroutine check_channel
+END MODULE module_channel_routing
diff --git a/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F b/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F
new file mode 100644
index 00000000..85f654a0
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F
@@ -0,0 +1,1040 @@
+module Module_Date_utilities_rt
+contains
+  subroutine geth_newdate (ndate, odate, idt)
+    implicit none
+
+    !  From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and 
+    !  delta-time, compute the new date.
+
+    !  on entry     -  odate  -  the old hdate.
+    !                  idt    -  the change in time
+
+    !  on exit      -  ndate  -  the new hdate.
+
+    integer, intent(in)           :: idt
+    character (len=*), intent(out) :: ndate
+    character (len=*), intent(in)  :: odate
+
+    !  Local Variables
+
+    !  yrold    -  indicates the year associated with "odate"
+    !  moold    -  indicates the month associated with "odate"
+    !  dyold    -  indicates the day associated with "odate"
+    !  hrold    -  indicates the hour associated with "odate"
+    !  miold    -  indicates the minute associated with "odate"
+    !  scold    -  indicates the second associated with "odate"
+
+    !  yrnew    -  indicates the year associated with "ndate"
+    !  monew    -  indicates the month associated with "ndate"
+    !  dynew    -  indicates the day associated with "ndate"
+    !  hrnew    -  indicates the hour associated with "ndate"
+    !  minew    -  indicates the minute associated with "ndate"
+    !  scnew    -  indicates the second associated with "ndate"
+
+    !  mday     -  a list assigning the number of days in each month
+
+    !  i        -  loop counter
+    !  nday     -  the integer number of days represented by "idt"
+    !  nhour    -  the integer number of hours in "idt" after taking out
+    !              all the whole days
+    !  nmin     -  the integer number of minutes in "idt" after taking out
+    !              all the whole days and whole hours.
+    !  nsec     -  the integer number of minutes in "idt" after taking out
+    !              all the whole days, whole hours, and whole minutes.
+
+    integer :: newlen, oldlen
+    integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew
+    integer :: yrold, moold, dyold, hrold, miold, scold, frold
+    integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc
+    logical :: opass
+    character (len=10) :: hfrc
+    character (len=1) :: sp
+    logical :: punct
+    integer :: yrstart, yrend, mostart, moend, dystart, dyend
+    integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart
+    integer :: units
+    integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/)
+
+    ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...."
+    if (odate(5:5) == "-") then
+       punct = .TRUE.
+    else
+       punct = .FALSE.
+    endif
+
+    !  Break down old hdate into parts
+
+    hrold = 0
+    miold = 0
+    scold = 0
+    frold = 0
+    oldlen = LEN(odate)
+    if (punct) then
+       yrstart = 1
+       yrend = 4
+       mostart = 6
+       moend = 7
+       dystart = 9
+       dyend = 10
+       hrstart = 12
+       hrend = 13
+       mistart = 15
+       miend = 16
+       scstart = 18
+       scend = 19
+       frstart = 21
+       select case (oldlen)
+       case (10)
+          ! Days
+          units = 1
+       case (13)
+          ! Hours
+          units = 2
+       case (16)
+          ! Minutes
+          units = 3
+       case (19)
+          ! Seconds
+          units = 4
+       case (21)
+          ! Tenths
+          units = 5
+       case (22)
+          ! Hundredths
+          units = 6
+       case (23)
+          ! Thousandths
+          units = 7
+       case (24)
+          ! Ten thousandths
+          units = 8
+       case default
+#ifdef HYDRO_D
+          write(*,*) 'ERROR: geth_newdate:  odd length: #'//trim(odate)//'#'
+          call hydro_stop()
+#endif
+       end select
+
+       if (oldlen.ge.11) then
+          sp = odate(11:11)
+       else
+          sp = ' '
+       end if
+
+    else
+
+       yrstart = 1
+       yrend = 4
+       mostart = 5
+       moend = 6
+       dystart = 7
+       dyend = 8
+       hrstart = 9
+       hrend = 10
+       mistart = 11
+       miend = 12
+       scstart = 13
+       scend = 14
+       frstart = 15
+
+       select case (oldlen)
+       case (8)
+          ! Days
+          units = 1
+       case (10)
+          ! Hours
+          units = 2
+       case (12)
+          ! Minutes
+          units = 3
+       case (14)
+          ! Seconds
+          units = 4
+       case (15)
+          ! Tenths
+          units = 5
+       case (16)
+          ! Hundredths
+          units = 6
+       case (17)
+          ! Thousandths
+          units = 7
+       case (18)
+          ! Ten thousandths
+          units = 8
+       case default
+#ifdef HYDRO_D
+          write(*,*) 'ERROR: geth_newdate:  odd length: #'//trim(odate)//'#'
+          call hydro_stop()
+#endif
+       end select
+    endif
+
+    !  Use internal READ statements to convert the CHARACTER string
+    !  date into INTEGER components.
+
+    read(odate(yrstart:yrend),  '(i4)') yrold
+    read(odate(mostart:moend),  '(i2)') moold
+    read(odate(dystart:dyend), '(i2)') dyold
+    if (units.ge.2) then
+       read(odate(hrstart:hrend),'(i2)') hrold
+       if (units.ge.3) then
+          read(odate(mistart:miend),'(i2)') miold
+          if (units.ge.4) then
+             read(odate(scstart:scend),'(i2)') scold
+             if (units.ge.5) then
+                read(odate(frstart:oldlen),*) frold
+             end if
+          end if
+       end if
+    end if
+
+    !  Set the number of days in February for that year.
+
+    mday(2) = nfeb(yrold)
+
+    !  Check that ODATE makes sense.
+
+    opass = .TRUE.
+
+    !  Check that the month of ODATE makes sense.
+
+    if ((moold.gt.12).or.(moold.lt.1)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Month of ODATE = ', moold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the day of ODATE makes sense.
+
+    if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Day of ODATE = ', dyold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the hour of ODATE makes sense.
+
+    if ((hrold.gt.23).or.(hrold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Hour of ODATE = ', hrold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the minute of ODATE makes sense.
+
+    if ((miold.gt.59).or.(miold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Minute of ODATE = ', miold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the second of ODATE makes sense.
+
+    if ((scold.gt.59).or.(scold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Second of ODATE = ', scold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the fractional part  of ODATE makes sense.
+
+
+    if (.not.opass) then
+#ifdef HYDRO_D
+       write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen
+       stop
+#endif
+    end if
+
+    !  Date Checks are completed.  Continue.
+
+
+    !  Compute the number of days, hours, minutes, and seconds in idt
+
+    if (units.ge.5) then !idt should be in fractions of seconds
+       ifrc = oldlen-(frstart)+1
+       ifrc = 10**ifrc
+       nday   = abs(idt)/(86400*ifrc)
+       nhour  = mod(abs(idt),86400*ifrc)/(3600*ifrc)
+       nmin   = mod(abs(idt),3600*ifrc)/(60*ifrc)
+       nsec   = mod(abs(idt),60*ifrc)/(ifrc)
+       nfrac = mod(abs(idt), ifrc)
+    else if (units.eq.4) then  !idt should be in seconds
+       ifrc = 1
+       nday   = abs(idt)/86400 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),86400)/3600
+       nmin   = mod(abs(idt),3600)/60
+       nsec   = mod(abs(idt),60)
+       nfrac  = 0
+    else if (units.eq.3) then !idt should be in minutes
+       ifrc = 1
+       nday   = abs(idt)/1440 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),1440)/60
+       nmin   = mod(abs(idt),60)
+       nsec   = 0
+       nfrac  = 0
+    else if (units.eq.2) then !idt should be in hours
+       ifrc = 1
+       nday   = abs(idt)/24 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),24)
+       nmin   = 0
+       nsec   = 0
+       nfrac  = 0
+    else if (units.eq.1) then !idt should be in days
+       ifrc = 1
+       nday   = abs(idt)    ! integer number of days in delta-time
+       nhour  = 0
+       nmin   = 0
+       nsec   = 0
+       nfrac  = 0
+    else
+#ifdef HYDRO_D
+       write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') &
+            oldlen
+       write(*,*) '#'//odate(1:oldlen)//'#'
+       call hydro_stop()
+#endif
+    end if
+
+    if (idt.ge.0) then
+
+       frnew = frold + nfrac
+       if (frnew.ge.ifrc) then
+          frnew = frnew - ifrc
+          nsec = nsec + 1
+       end if
+
+       scnew = scold + nsec
+       if (scnew .ge. 60) then
+          scnew = scnew - 60
+          nmin  = nmin + 1
+       end if
+
+       minew = miold + nmin
+       if (minew .ge. 60) then
+          minew = minew - 60
+          nhour  = nhour + 1
+       end if
+
+       hrnew = hrold + nhour
+       if (hrnew .ge. 24) then
+          hrnew = hrnew - 24
+          nday  = nday + 1
+       end if
+
+       dynew = dyold
+       monew = moold
+       yrnew = yrold
+       do i = 1, nday
+          dynew = dynew + 1
+          if (dynew.gt.mday(monew)) then
+             dynew = dynew - mday(monew)
+             monew = monew + 1
+             if (monew .gt. 12) then
+                monew = 1
+                yrnew = yrnew + 1
+                ! If the year changes, recompute the number of days in February
+                mday(2) = nfeb(yrnew)
+             end if
+          end if
+       end do
+
+    else if (idt.lt.0) then
+
+       frnew = frold - nfrac
+       if (frnew .lt. 0) then
+          frnew = frnew + ifrc
+          nsec = nsec + 1
+       end if
+
+       scnew = scold - nsec
+       if (scnew .lt. 00) then
+          scnew = scnew + 60
+          nmin  = nmin + 1
+       end if
+
+       minew = miold - nmin
+       if (minew .lt. 00) then
+          minew = minew + 60
+          nhour  = nhour + 1
+       end if
+
+       hrnew = hrold - nhour
+       if (hrnew .lt. 00) then
+          hrnew = hrnew + 24
+          nday  = nday + 1
+       end if
+
+       dynew = dyold
+       monew = moold
+       yrnew = yrold
+       do i = 1, nday
+          dynew = dynew - 1
+          if (dynew.eq.0) then
+             monew = monew - 1
+             if (monew.eq.0) then
+                monew = 12
+                yrnew = yrnew - 1
+                ! If the year changes, recompute the number of days in February
+                mday(2) = nfeb(yrnew)
+             end if
+             dynew = mday(monew)
+          end if
+       end do
+    end if
+
+    !  Now construct the new mdate
+
+    newlen = LEN(ndate)
+
+    if (punct) then
+
+       if (newlen.gt.frstart) then
+          write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew
+          write(hfrc,'(i10)') frnew+1000000000
+          ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10)
+
+       else if (newlen.eq.scend) then
+          write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew
+19        format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2)
+
+       else if (newlen.eq.miend) then
+          write(ndate,16) yrnew, monew, dynew, hrnew, minew
+16        format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2)
+
+       else if (newlen.eq.hrend) then
+          write(ndate,13) yrnew, monew, dynew, hrnew
+13        format(i4,'-',i2.2,'-',i2.2,'_',i2.2)
+
+       else if (newlen.eq.dyend) then
+          write(ndate,10) yrnew, monew, dynew
+10        format(i4,'-',i2.2,'-',i2.2)
+
+       end if
+
+    else
+
+       if (newlen.gt.frstart) then
+          write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew
+          write(hfrc,'(i10)') frnew+1000000000
+          ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10)
+
+       else if (newlen.eq.scend) then
+          write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew
+119       format(i4,i2.2,i2.2,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.miend) then
+          write(ndate,116) yrnew, monew, dynew, hrnew, minew
+116       format(i4,i2.2,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.hrend) then
+          write(ndate,113) yrnew, monew, dynew, hrnew
+113       format(i4,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.dyend) then
+          write(ndate,110) yrnew, monew, dynew
+110       format(i4,i2.2,i2.2)
+
+       end if
+
+    endif
+
+    if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp
+
+  end subroutine geth_newdate
+
+  subroutine geth_idts (newdate, olddate, idt)
+
+    implicit none
+
+    !  From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'), 
+    !  compute the time difference.
+
+    !  on entry     -  newdate  -  the new hdate.
+    !                  olddate  -  the old hdate.
+
+    !  on exit      -  idt    -  the change in time.
+    !                            Units depend on length of date strings.
+
+    character (len=*) , intent(in) :: newdate, olddate
+    integer           , intent(out)   :: idt
+
+
+    !  Local Variables
+
+    !  yrnew    -  indicates the year associated with "ndate"
+    !  yrold    -  indicates the year associated with "odate"
+    !  monew    -  indicates the month associated with "ndate"
+    !  moold    -  indicates the month associated with "odate"
+    !  dynew    -  indicates the day associated with "ndate"
+    !  dyold    -  indicates the day associated with "odate"
+    !  hrnew    -  indicates the hour associated with "ndate"
+    !  hrold    -  indicates the hour associated with "odate"
+    !  minew    -  indicates the minute associated with "ndate"
+    !  miold    -  indicates the minute associated with "odate"
+    !  scnew    -  indicates the second associated with "ndate"
+    !  scold    -  indicates the second associated with "odate"
+    !  i        -  loop counter
+    !  mday     -  a list assigning the number of days in each month
+
+    ! ndate, odate: local values of newdate and olddate
+    character(len=24) :: ndate, odate
+
+    integer :: oldlen, newlen
+    integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew
+    integer :: yrold, moold, dyold, hrold, miold, scold, frold
+    integer :: i, newdys, olddys
+    logical :: npass, opass
+    integer :: timesign
+    integer :: ifrc
+    integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/)
+    logical :: punct
+    integer :: yrstart, yrend, mostart, moend, dystart, dyend
+    integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart
+    integer :: units
+
+    oldlen = len(olddate)
+    newlen = len(newdate)
+    if (newlen.ne.oldlen) then
+#ifdef HYDRO_D
+       write(*,'("GETH_IDTS: NEWLEN /= OLDLEN: ", A, 3x, A)') newdate(1:newlen), olddate(1:oldlen)
+       call hydro_stop()
+#endif
+    endif
+
+    if (olddate.gt.newdate) then
+       timesign = -1
+
+       ifrc = oldlen
+       oldlen = newlen
+       newlen = ifrc
+
+       ndate = olddate
+       odate = newdate
+    else
+       timesign = 1
+       ndate = newdate
+       odate = olddate
+    end if
+
+    ! Break down old hdate into parts
+
+    ! Determine if olddate is punctuated or not
+    if (odate(5:5) == "-") then
+       punct = .TRUE.
+       if (ndate(5:5) /= "-") then
+#ifdef HYDRO_D
+          write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') &
+               ndate(1:newlen), odate(1:oldlen)
+          call hydro_stop()
+#endif
+       endif
+    else
+       punct = .FALSE.
+       if (ndate(5:5) == "-") then
+#ifdef HYDRO_D
+          write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') &
+               ndate(1:newlen), odate(1:oldlen)
+          call hydro_stop()
+#endif
+       endif
+    endif
+
+    if (punct) then
+       yrstart = 1
+       yrend = 4
+       mostart = 6
+       moend = 7
+       dystart = 9
+       dyend = 10
+       hrstart = 12
+       hrend = 13
+       mistart = 15
+       miend = 16
+       scstart = 18
+       scend = 19
+       frstart = 21
+       select case (oldlen)
+       case (10)
+          ! Days
+          units = 1
+       case (13)
+          ! Hours
+          units = 2
+       case (16)
+          ! Minutes
+          units = 3
+       case (19)
+          ! Seconds
+          units = 4
+       case (21)
+          ! Tenths
+          units = 5
+       case (22)
+          ! Hundredths
+          units = 6
+       case (23)
+          ! Thousandths
+          units = 7
+       case (24)
+          ! Ten thousandths
+          units = 8
+       case default
+#ifdef HYDRO_D
+          write(*,*) 'ERROR: geth_idts:  odd length: #'//trim(odate)//'#'
+          call hydro_stop()
+#endif
+       end select
+    else
+
+       yrstart = 1
+       yrend = 4
+       mostart = 5
+       moend = 6
+       dystart = 7
+       dyend = 8
+       hrstart = 9
+       hrend = 10
+       mistart = 11
+       miend = 12
+       scstart = 13
+       scend = 14
+       frstart = 15
+
+       select case (oldlen)
+       case (8)
+          ! Days
+          units = 1
+       case (10)
+          ! Hours
+          units = 2
+       case (12)
+          ! Minutes
+          units = 3
+       case (14)
+          ! Seconds
+          units = 4
+       case (15)
+          ! Tenths
+          units = 5
+       case (16)
+          ! Hundredths
+          units = 6
+       case (17)
+          ! Thousandths
+          units = 7
+       case (18)
+          ! Ten thousandths
+          units = 8
+       case default
+#ifdef HYDRO_D
+          write(*,*) 'ERROR: geth_idts:  odd length: #'//trim(odate)//'#'
+          call hydro_stop()
+#endif
+       end select
+    endif
+
+
+    hrold = 0
+    miold = 0
+    scold = 0
+    frold = 0
+
+    read(odate(yrstart:yrend), '(i4)') yrold
+    read(odate(mostart:moend), '(i2)') moold
+    read(odate(dystart:dyend), '(i2)') dyold
+    if (units.ge.2) then
+       read(odate(hrstart:hrend),'(i2)') hrold
+       if (units.ge.3) then
+          read(odate(mistart:miend),'(i2)') miold
+          if (units.ge.4) then
+             read(odate(scstart:scend),'(i2)') scold
+             if (units.ge.5) then
+                read(odate(frstart:oldlen),*) frold
+             end if
+          end if
+       end if
+    end if
+
+    !  Break down new hdate into parts
+
+    hrnew = 0
+    minew = 0
+    scnew = 0
+    frnew = 0
+
+    read(ndate(yrstart:yrend), '(i4)') yrnew
+    read(ndate(mostart:moend), '(i2)') monew
+    read(ndate(dystart:dyend), '(i2)') dynew
+    if (units.ge.2) then
+       read(ndate(hrstart:hrend),'(i2)') hrnew
+       if (units.ge.3) then
+          read(ndate(mistart:miend),'(i2)') minew
+          if (units.ge.4) then
+             read(ndate(scstart:scend),'(i2)') scnew
+             if (units.ge.5) then
+                read(ndate(frstart:newlen),*) frnew
+             end if
+          end if
+       end if
+    end if
+
+    !  Check that the dates make sense.
+
+    npass = .true.
+    opass = .true.
+
+    !  Check that the month of NDATE makes sense.
+    
+    if ((monew.gt.12).or.(monew.lt.1)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_IDTS:  Month of NDATE = ', monew
+#endif
+       npass = .false.
+    end if
+
+    !  Check that the month of ODATE makes sense.
+
+    if ((moold.gt.12).or.(moold.lt.1)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Month of ODATE = ', moold
+#endif
+       opass = .false.
+    end if
+
+    !  Check that the day of NDATE makes sense.
+
+    if (monew.ne.2) then
+       ! ...... For all months but February
+       if ((dynew.gt.mday(monew)).or.(dynew.lt.1)) then
+#ifdef HYDRO_D
+          print*, 'GETH_IDTS:  Day of NDATE = ', dynew
+#endif
+          npass = .false.
+       end if
+    else if (monew.eq.2) then
+       ! ...... For February
+       if ((dynew > nfeb(yrnew)).or.(dynew < 1)) then
+#ifdef HYDRO_D
+          print*, 'GETH_IDTS:  Day of NDATE = ', dynew
+#endif
+          npass = .false.
+       end if
+    endif
+
+    !  Check that the day of ODATE makes sense.
+
+    if (moold.ne.2) then
+       ! ...... For all months but February
+       if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then
+#ifdef HYDRO_D
+          print*, 'GETH_IDTS:  Day of ODATE = ', dyold
+#endif
+          opass = .false.
+       end if
+    else if (moold.eq.2) then
+       ! ....... For February
+       if ((dyold > nfeb(yrold)).or.(dyold < 1)) then
+#ifdef HYDRO_D
+          print*, 'GETH_IDTS:  Day of ODATE = ', dyold
+#endif
+          opass = .false.
+       end if
+    end if
+
+    !  Check that the hour of NDATE makes sense.
+
+    if ((hrnew.gt.23).or.(hrnew.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Hour of NDATE = ', hrnew
+#endif
+       npass = .false.
+    end if
+
+    !  Check that the hour of ODATE makes sense.
+
+    if ((hrold.gt.23).or.(hrold.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Hour of ODATE = ', hrold
+#endif
+       opass = .false.
+    end if
+
+    !  Check that the minute of NDATE makes sense.
+
+    if ((minew.gt.59).or.(minew.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Minute of NDATE = ', minew
+#endif
+       npass = .false.
+    end if
+
+    !  Check that the minute of ODATE makes sense.
+
+    if ((miold.gt.59).or.(miold.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Minute of ODATE = ', miold
+#endif
+       opass = .false.
+    end if
+
+    !  Check that the second of NDATE makes sense.
+
+    if ((scnew.gt.59).or.(scnew.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  SECOND of NDATE = ', scnew
+#endif
+       npass = .false.
+    end if
+
+    !  Check that the second of ODATE makes sense.
+
+    if ((scold.gt.59).or.(scold.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Second of ODATE = ', scold
+#endif
+       opass = .false.
+    end if
+
+    if (.not. npass) then
+#ifdef HYDRO_D
+       print*, 'Screwy NDATE: ', ndate(1:newlen)
+       call hydro_stop()
+#endif
+    end if
+
+    if (.not. opass) then
+#ifdef HYDRO_D
+       print*, 'Screwy ODATE: ', odate(1:oldlen)
+       call hydro_stop()
+#endif
+    end if
+
+    !  Date Checks are completed.  Continue.
+
+    !  Compute number of days from 1 January ODATE, 00:00:00 until ndate
+    !  Compute number of hours from 1 January ODATE, 00:00:00 until ndate
+    !  Compute number of minutes from 1 January ODATE, 00:00:00 until ndate
+
+    newdys = 0
+    do i = yrold, yrnew - 1
+       newdys = newdys + 337 + nfeb(i)
+    end do
+
+    if (monew .gt. 1) then
+       mday(2) = nfeb(yrnew)
+       do i = 1, monew - 1
+          newdys = newdys + mday(i)
+       end do
+       mday(2) = 28
+    end if
+
+    newdys = newdys + dynew - 1
+
+    !  Compute number of hours from 1 January ODATE, 00:00:00 until odate
+    !  Compute number of minutes from 1 January ODATE, 00:00:00 until odate
+
+    olddys = 0
+
+    if (moold .gt. 1) then
+       mday(2) = nfeb(yrold)
+       do i = 1, moold - 1
+          olddys = olddys + mday(i)
+       end do
+       mday(2) = 28
+    end if
+
+    olddys = olddys + dyold -1
+
+    !  Determine the time difference
+
+    idt = (newdys - olddys)
+    if (units.ge.2) then
+       idt = idt*24 + (hrnew - hrold)
+       if (units.ge.3) then
+          idt = idt*60 + (minew - miold)
+          if (units.ge.4) then
+             idt = idt*60 + (scnew - scold)
+             if (units.ge.5) then
+                ifrc = oldlen-(frstart-1)
+                ifrc = 10**ifrc
+                idt = idt * ifrc + (frnew-frold)
+             endif
+          endif
+       endif
+    endif
+
+    if (timesign .eq. -1) then
+       idt = idt * timesign
+    end if
+
+  end subroutine geth_idts
+
+
+  integer function nfeb(year)
+    !
+    ! Compute the number of days in February for the given year.
+    !
+    implicit none
+    integer, intent(in) :: year ! Four-digit year
+
+    nfeb = 28 ! By default, February has 28 days ...
+    if (mod(year,4).eq.0) then  
+       nfeb = 29  ! But every four years, it has 29 days ...
+       if (mod(year,100).eq.0) then
+          nfeb = 28  ! Except every 100 years, when it has 28 days ...
+          if (mod(year,400).eq.0) then
+             nfeb = 29  ! Except every 400 years, when it has 29 days ...
+             if (mod(year,3600).eq.0) then
+                nfeb = 28  ! Except every 3600 years, when it has 28 days.
+             endif
+          endif
+       endif
+    endif
+  end function nfeb
+
+  integer function nmdays(hdate)
+    !
+    ! Compute the number of days in the month of given date hdate.
+    !
+    implicit none
+    character(len=*), intent(in) :: hdate
+
+    integer :: year, month
+    integer, dimension(12), parameter :: ndays = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /)
+
+    read(hdate(1:7), '(I4,1x,I2)') year, month
+
+    if (month == 2) then
+       nmdays = nfeb(year)
+    else
+       nmdays = ndays(month)
+    endif
+  end function nmdays
+
+  function monthabbr_to_mm(mon) result(mm)
+    implicit none
+
+    character(len=3), intent(in) :: mon
+
+    integer :: mm
+
+    if (mon == "Jan") then
+       mm = 1
+    elseif (mon == "Feb") then
+       mm = 2
+    elseif (mon == "Mar") then
+       mm = 3
+    elseif (mon == "Apr") then
+       mm = 4
+    elseif (mon == "May") then
+       mm = 5
+    elseif (mon == "Jun") then
+       mm = 6
+    elseif (mon == "Jul") then
+       mm = 7
+    elseif (mon == "Aug") then
+       mm = 8
+    elseif (mon == "Sep") then
+       mm = 9
+    elseif (mon == "Oct") then
+       mm = 10
+    elseif (mon == "Nov") then
+       mm = 11
+    elseif (mon == "Dec") then
+       mm = 12
+    else
+#ifdef HYDRO_D
+       write(*, '("Function monthabbr_to_mm:  mon = <",A,">")') mon
+       print*,  "Function monthabbr_to_mm:  Unrecognized mon"
+       call hydro_stop()
+#endif
+    endif
+  end function monthabbr_to_mm
+
+  subroutine swap_date_format(indate, outdate)
+    implicit none
+    character(len=*), intent(in)  :: indate
+    character(len=*), intent(out) :: outdate
+    integer :: inlen
+
+    inlen = len(indate)
+    if (indate(5:5) == "-") then
+       select case (inlen)
+       case (10)
+          ! YYYY-MM-DD
+          outdate = indate(1:4)//indate(6:7)//indate(9:10)
+       case (13)
+          ! YYYY-MM-DD_HH
+          outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)
+       case (16)
+          ! YYYY-MM-DD_HH:mm
+          outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)
+       case (19)
+          ! YYYY-MM-DD_HH:mm:ss
+          outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//&
+               indate(18:19)
+       case (21,22,23,24)
+          ! YYYY-MM-DD_HH:mm:ss.f[f[f[f]]]
+          outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//&
+               indate(18:19)//indate(21:inlen)
+       case default
+#ifdef HYDRO_D
+          write(*,'("Unrecognized length: <", A,">")') indate
+         call hydro_stop()
+#endif
+       end select
+    else
+       select case (inlen)
+       case (8)
+          ! YYYYMMDD
+          outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)
+       case (10)
+          ! YYYYMMDDHH
+          outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//&
+               indate(9:10)
+       case (12)
+          ! YYYYMMDDHHmm
+          outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//&
+               indate(9:10)//":"//indate(11:12)
+       case (14)
+          ! YYYYMMDDHHmmss
+          outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//&
+               indate(9:10)//":"//indate(11:12)//":"//indate(13:14)
+       case (15,16,17,18)
+          ! YYYYMMDDHHmmssf[f[f[f]]]
+          outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//&
+               indate(9:10)//":"//indate(11:12)//":"//indate(13:14)//"."//indate(15:inlen)
+       case default
+#ifdef HYDRO_D
+          write(*,'("Unrecognized length: <", A,">")') indate
+          call hydro_stop()
+#endif
+       end select
+    endif
+
+  end subroutine swap_date_format
+
+  character(len=3) function mm_to_monthabbr(ii) result(mon)
+    implicit none
+    integer, intent(in) :: ii
+    character(len=3), parameter, dimension(12) :: month = (/ &
+         "Jan", "Feb", "Mar", "Apr", "May", "Jun", &
+         "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" /)
+    if (ii > 0 .and. ii < 13 ) then
+       mon = month(ii)
+    else
+#ifdef HYDRO_D
+       print*, "mm_to_monthabbr"
+       call hydro_stop()
+#endif
+    endif
+  end function mm_to_monthabbr
+
+end module Module_Date_utilities_rt
diff --git a/wrfv2_fire/hydro/Routing/module_lsm_forcing.F b/wrfv2_fire/hydro/Routing/module_lsm_forcing.F
new file mode 100644
index 00000000..944b3255
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_lsm_forcing.F
@@ -0,0 +1,1721 @@
+module module_lsm_forcing
+
+#ifdef MPP_LAND
+    use module_mpp_land
+#endif
+    use module_HYDRO_io, only: get_2d_netcdf, get_soilcat_netcdf, get2d_int
+
+implicit none
+#include 
+
+Contains
+
+  subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp)
+    
+    implicit none
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    character(len=*),                   intent(in)  :: target_date
+    real,             dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc
+    integer   tlevel
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid
+
+    tlevel = 1
+
+    ! Open the NetCDF file.
+    ierr = nf_open(flnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+#ifdef HYDRO_D
+       write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm)
+#endif
+       call hydro_stop()
+    endif
+
+    call get_2d_netcdf_ruc("T2",     ncid, t,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("Q2",     ncid, q,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("U10",    ncid, u,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("V10",    ncid, v,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("PSFC",   ncid, p,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("GLW",    ncid, lw,    ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("SWDOWN", ncid, sw,    ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("RAINC",  ncid, pcpc,  ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("RAINNC", ncid, pcp,   ix, jx,tlevel, .true., ierr)
+
+    ierr = nf_close(ncid)
+    
+
+!DJG  Add the convective and non-convective rain components (note: conv. comp=0
+!for cloud resolving runs...) 
+!DJG  Note that for WRF these are accumulated values to be adjusted to rates in
+!driver...
+
+    pcp=pcp+pcpc   ! assumes pcpc=0 for resolved convection...
+
+  end subroutine READFORC_WRF
+
+  subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat)
+    ! Simply return the dimensions of the grid.
+    implicit none
+    character(len=*),          intent(in)  :: geo_static_flnm
+    integer, intent(out) :: ix, jx, land_cat, soil_cat ! dimensions
+
+    integer :: iret, ncid, dimid
+
+    ! Open the NetCDF file.
+    iret = nf_open(geo_static_flnm, NF_NOWRITE, ncid)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       write(*,'("Problem opening geo_static file: ''", A, "''")') &
+            trim(geo_static_flnm)
+#endif
+       call hydro_stop()
+    endif
+
+    iret = nf_inq_dimid(ncid, "west_east", dimid)
+
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, "nf_inq_dimid:  west_east"
+#endif
+       call hydro_stop()
+    endif
+
+    iret = nf_inq_dimlen(ncid, dimid, ix)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, "nf_inq_dimlen:  west_east"
+#endif
+       call hydro_stop()
+    endif
+
+    iret = nf_inq_dimid(ncid, "south_north", dimid)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, "nf_inq_dimid:  south_north"
+#endif
+       call hydro_stop()
+    endif
+
+    iret = nf_inq_dimlen(ncid, dimid, jx)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, "nf_inq_dimlen:  south_north"
+#endif
+       call hydro_stop()
+    endif
+
+    iret = nf_inq_dimid(ncid, "land_cat", dimid)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, "nf_inq_dimid:  land_cat"
+#endif
+       call hydro_stop()
+    endif
+
+    iret = nf_inq_dimlen(ncid, dimid, land_cat)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, "nf_inq_dimlen:  land_cat"
+#endif
+       call hydro_stop()
+    endif
+
+    iret = nf_inq_dimid(ncid, "soil_cat", dimid)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, "nf_inq_dimid:  soil_cat"
+#endif
+       call hydro_stop()
+    endif
+
+    iret = nf_inq_dimlen(ncid, dimid, soil_cat)
+    if (iret /= 0) then
+#ifdef HYDRO_D
+       print*, "nf_inq_dimlen:  soil_cat"
+#endif
+       call hydro_stop()
+    endif
+
+    iret = nf_close(ncid)
+
+  end subroutine read_hrldas_hdrinfo
+
+
+
+  subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp, &
+                  terrain,latitude,longitude,SOLVEG_INITSWC)
+    implicit none
+    character(len=*),          intent(in)  :: geo_static_flnm
+    integer,                   intent(in)  :: ix, jx, land_cat, soil_cat,SOLVEG_INITSWC
+    integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp
+    real,    dimension(ix,jx), intent(out) :: terrain, latitude, longitude
+
+    character(len=256) :: units
+    integer :: ierr,i,j,jj
+    integer :: ncid,varid
+    real, dimension(ix,jx) :: xdum
+    integer, dimension(ix,jx) :: vegtyp_inv, soiltyp_inv,xdum_int
+    integer flag ! flag = 1 from wrfsi, flag =2 from WPS.
+    CHARACTER(len=256)       :: var_name
+
+
+    ! Open the NetCDF file.
+    ierr = nf_open(geo_static_flnm, NF_NOWRITE, ncid)
+
+    if (ierr /= 0) then
+#ifdef HYDRO_D
+       write(*,'("Problem opening geo_static file: ''", A, "''")') trim(geo_static_flnm)
+#endif
+       call hydro_stop() 
+    endif
+
+    flag = -99 
+    ierr = nf_inq_varid(ncid,"XLAT", varid)
+    flag = 1
+    if(ierr .ne. 0) then
+        ierr = nf_inq_varid(ncid,"XLAT_M", varid)
+        if(ierr .ne. 0) then
+#ifdef HYDRO_D
+            write(6,*) "XLAT not found from wrfstatic file. "
+#endif
+            call hydro_stop() 
+        endif
+        flag = 2
+    endif
+
+    ! Get Latitude (lat)
+    if(flag .eq. 1) then
+       call get_2d_netcdf("XLAT", ncid, latitude,  units, ix, jx, .TRUE., ierr)
+    else
+      call get_2d_netcdf("XLAT_M", ncid, latitude,  units, ix, jx, .TRUE., ierr)
+    endif
+
+    ! Get Longitude (lon)
+    if(flag .eq. 1) then 
+        call get_2d_netcdf("XLONG", ncid, longitude, units, ix, jx, .TRUE., ierr)
+    else
+        call get_2d_netcdf("XLONG_M", ncid, longitude, units, ix, jx, .TRUE., ierr)
+    endif
+
+    ! Get Terrain (avg)
+    if(flag .eq. 1) then
+       call get_2d_netcdf("HGT", ncid, terrain,   units, ix, jx, .TRUE., ierr)
+    else
+        call get_2d_netcdf("HGT_M", ncid, terrain,   units, ix, jx, .TRUE., ierr)
+    endif
+
+
+    if (SOLVEG_INITSWC.eq.0) then
+!      ! Get Dominant Land Use categories (use)
+!      call get_landuse_netcdf(ncid, xdum ,   units, ix, jx, land_cat)
+!      vegtyp = nint(xdum)
+
+     var_name = "LU_INDEX"
+         call get2d_int(var_name,xdum_int,ix,jx,&
+               trim(geo_static_flnm))
+         vegtyp = xdum_int
+
+      ! Get Dominant Soil Type categories in the top layer (stl)
+      call get_soilcat_netcdf(ncid, xdum ,   units, ix, jx, soil_cat)
+      soltyp = nint(xdum)
+
+    else if (SOLVEG_INITSWC.eq.1) then
+       var_name = "VEGTYP"
+       call get2d_int(var_name,VEGTYP_inv,ix,jx,&
+              trim(geo_static_flnm))
+
+       var_name = "SOILTYP"
+       call get2d_int(var_name,SOILTYP_inv,ix,jx,&
+              trim(geo_static_flnm))
+       do i=1,ix
+         jj=jx
+         do j=1,jx
+           VEGTYP(i,j)=VEGTYP_inv(i,jj)
+           SOLTYP(i,j)=SOILTYP_inv(i,jj)
+           jj=jx-j
+         end do
+       end do
+
+    endif
+
+
+
+    ! Close the NetCDF file
+    ierr = nf_close(ncid)
+    if (ierr /= 0) then
+#ifdef HYDRO_D
+       print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  READLAND_HRLDAS:  NF_CLOSE"
+#endif
+       call hydro_stop()
+    endif
+
+    ! Make sure vegtyp and soltyp are consistent when it comes to water points,
+    ! by setting soil category to water when vegetation category is water, and
+    ! vice-versa.
+    where (vegtyp == 16) soltyp = 14
+    where (soltyp == 14) vegtyp = 16
+
+!DJG test for deep gw function...
+!    where (soltyp <> 14) soltyp = 1
+
+  end subroutine readland_hrldas
+
+
+      subroutine get_2d_netcdf_ruc(var_name,ncid,var, &
+            ix,jx,tlevel,fatal_if_error,ierr)
+          character(len=*), intent(in) :: var_name
+          integer,intent(in) ::  ncid,ix,jx,tlevel
+          real, intent(out):: var(ix,jx)
+          logical, intent(in) :: fatal_if_error
+          integer dims(4), dim_len(4)
+          integer ierr,iret
+          integer varid
+           integer start(4),count(4)
+           data count /1,1,1,1/
+           data start /1,1,1,1/
+          count(1) = ix
+          count(2) = jx
+          start(4) = tlevel
+      iret = nf_inq_varid(ncid,  var_name,  varid)
+
+      if (iret /= 0) then
+        if (fatal_IF_ERROR) then
+#ifdef HYDRO_D
+           print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf_inq_varid"
+#endif
+           call hydro_stop()
+        else
+          ierr = iret
+          return
+        endif
+      endif
+
+      iret = nf_get_vara_real(ncid, varid, start,count,var)
+
+      return
+      end subroutine get_2d_netcdf_ruc
+
+
+      subroutine get_2d_netcdf_cows(var_name,ncid,var, &
+            ix,jx,tlevel,fatal_if_error,ierr)
+          character(len=*), intent(in) :: var_name
+          integer,intent(in) ::  ncid,ix,jx,tlevel
+          real, intent(out):: var(ix,jx)
+          logical, intent(in) :: fatal_if_error
+          integer ierr, iret
+          integer varid
+          integer start(4),count(4)
+          data count /1,1,1,1/
+          data start /1,1,1,1/
+          count(1) = ix
+          count(2) = jx
+          start(4) = tlevel
+      iret = nf_inq_varid(ncid,  var_name,  varid)
+
+      if (iret /= 0) then
+        if (fatal_IF_ERROR) then
+#ifdef HYDRO_D
+           print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid"
+#endif
+           call hydro_stop()
+        else
+          ierr = iret
+          return
+        endif
+      endif
+      iret = nf_get_vara_real(ncid, varid, start,count,var)
+
+      return
+      end subroutine get_2d_netcdf_cows
+
+
+
+
+
+  subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, &
+       smc, stc, sh2o, cmc, t1, weasd, snodep)
+    implicit none
+    character(len=*),                intent(in)  :: netcdf_flnm
+    integer,                         intent(in)  :: ix
+    integer,                         intent(in)  :: jx
+    integer,                         intent(in)  :: nsoil
+    character(len=*),                intent(in)  :: target_date
+    real,    dimension(ix,jx,nsoil), intent(out) :: smc
+    real,    dimension(ix,jx,nsoil), intent(out) :: stc
+    real,    dimension(ix,jx,nsoil), intent(out) :: sh2o
+    real,    dimension(ix,jx),       intent(out) :: cmc
+    real,    dimension(ix,jx),       intent(out) :: t1
+    real,    dimension(ix,jx),       intent(out) :: weasd
+    real,    dimension(ix,jx),       intent(out) :: snodep
+
+    character(len=256) :: units
+    character(len=8) :: name
+    integer :: ix_read, jx_read,i,j
+
+    integer :: ierr, ncid, ierr_snodep
+    integer :: idx
+
+    logical :: found_canwat, found_skintemp, found_weasd, found_stemp, found_smois
+
+    ! Open the NetCDF file.
+    ierr = nf_open(netcdf_flnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+#ifdef HYDRO_D
+       write(*,'("READINIT Problem opening netcdf file: ''", A, "''")') &
+            trim(netcdf_flnm)
+#endif
+       call hydro_stop()
+    endif
+
+    call get_2d_netcdf("CANWAT",     ncid, cmc,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SKINTEMP",   ncid, t1,      units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("WEASD",      ncid, weasd,   units, ix, jx, .TRUE., ierr)
+
+    if (trim(units) == "m") then
+       ! No conversion necessary
+    else if (trim(units) == "mm") then
+       ! convert WEASD from mm to m
+       weasd = weasd * 1.E-3
+    else
+#ifdef HYDRO_D
+       print*, 'units = "'//trim(units)//'"'
+       print*, "Unrecognized units on WEASD"
+#endif
+       call hydro_stop()
+    endif
+
+    call get_2d_netcdf("SNODEP",     ncid, snodep,   units, ix, jx, .FALSE., ierr_snodep)
+    call get_2d_netcdf("STEMP_1",    ncid, stc(:,:,1), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("STEMP_2",    ncid, stc(:,:,2), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("STEMP_3",    ncid, stc(:,:,3), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("STEMP_4",    ncid, stc(:,:,4), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SMOIS_1",    ncid, smc(:,:,1), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SMOIS_2",    ncid, smc(:,:,2), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SMOIS_3",    ncid, smc(:,:,3), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SMOIS_4",    ncid, smc(:,:,4), units,  ix, jx, .TRUE., ierr)
+
+
+    if (ierr_snodep /= 0) then
+       ! Quick assumption regarding snow depth.
+       snodep = weasd * 10.
+    endif
+
+
+!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation...
+       do i=1,ix
+         do j=1,jx
+           if (WEASD(i,j).lt.0.) WEASD(i,j)=0.0  !set lower bound to correct bi-lin interp err...
+           if (snodep(i,j).lt.0.) snodep(i,j)=0.0  !set lower bound to correct bi-lin interp err...
+         end do
+       end do
+
+
+    sh2o = smc
+
+    ierr = nf_close(ncid)
+  end subroutine readinit_hrldas
+
+
+
+
+  subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    character(len=*),                   intent(in)  :: target_date
+    real,             dimension(ix,jx), intent(out) :: t
+    real,             dimension(ix,jx), intent(out) :: q
+    real,             dimension(ix,jx), intent(out) :: u
+    real,             dimension(ix,jx), intent(out) :: v
+    real,             dimension(ix,jx), intent(out) :: p
+    real,             dimension(ix,jx), intent(out) :: lw
+    real,             dimension(ix,jx), intent(out) :: sw
+    real,             dimension(ix,jx), intent(out) :: pcp
+    real,             dimension(ix,jx), intent(out) :: lai
+    real,             dimension(ix,jx), intent(out) :: fpar
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid
+
+    ! Open the NetCDF file.
+    ierr = nf_open(trim(flnm), NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+#ifdef HYDRO_D
+       write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm)
+#endif
+       call hydro_stop()
+    endif
+
+    call get_2d_netcdf("T2D",     ncid, t,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("Q2D",     ncid, q,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("U2D",     ncid, u,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("V2D",     ncid, v,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("PSFC",    ncid, p,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("LWDOWN",  ncid, lw,    units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SWDOWN",  ncid, sw,    units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("RAINRATE",ncid, pcp,   units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("VEGFRA",  ncid, fpar,  units, ix, jx, .FALSE., ierr)
+    if (ierr == 0) then
+       fpar = fpar * 1.E-2
+    endif
+    call get_2d_netcdf("LAI",     ncid, lai,   units, ix, jx, .FALSE., ierr)
+
+    ierr = nf_close(ncid)
+
+  end subroutine READFORC_HRLDAS
+
+
+
+  subroutine READFORC_DMIP(flnm,ix,jx,var)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    real,       dimension(ix,jx), intent(out)       :: var
+    character(len=13)                               :: head
+    integer                          :: ncols, nrows, cellsize
+    real                             :: xllc, yllc, no_data
+    integer                          :: i,j
+    character(len=256)                              ::junk
+
+    open (77,file=trim(flnm),form="formatted",status="old")
+
+!    read(77,732) head,ncols
+!    read(77,732) head,nrows
+!732        FORMAT(A13,I4)
+!    read(77,733) head,xllc
+!    read(77,733) head,yllc
+!733        FORMAT(A13,F16.9)
+!    read(77,732) head,cellsize
+!    read(77,732) head,no_data
+
+    read(77,*) junk
+    read(77,*) junk
+    read(77,*) junk
+    read(77,*) junk
+    read(77,*) junk
+    read(77,*) junk
+
+    do j=jx,1,-1
+      read(77,*) (var(I,J),I=1,ix)
+    end do
+    close(77)
+
+  end subroutine READFORC_DMIP
+
+
+
+  subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    integer,                            intent(out)  :: ierr_flg
+    integer :: it,jew,zsn
+    real,             dimension(ix,jx), intent(out) :: pcp
+
+    character(len=256) :: units
+    integer :: ierr,i,j,i2,j2,varid
+    integer :: ncid,mmflag
+    real, dimension(ix,jx) :: temp
+
+    mmflag = 0   ! flag for units spec. (0=mm, 1=mm/s)
+
+
+!open NetCDF file...
+        ierr_flg = nf_open(flnm, NF_NOWRITE, ncid)
+        if (ierr_flg /= 0) then
+#ifdef HYDRO_D
+          write(*,'("READFORC_MDV Problem opening netcdf file: ''",A,"''")') &
+                trim(flnm)
+#endif
+           return
+        end if
+
+        ierr = nf_inq_varid(ncid,  "precip",  varid)
+        if(ierr /= 0) ierr_flg = ierr
+        if (ierr /= 0) then
+          ierr = nf_inq_varid(ncid,  "precip_rate",  varid)   !recheck variable name...
+          if (ierr /= 0) then
+#ifdef HYDRO_D
+            write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') &
+                 trim(flnm)
+#endif
+          end if
+          ierr_flg = ierr
+          mmflag = 1
+        end if
+        ierr = nf_get_var_real(ncid, varid, pcp)
+        ierr = nf_close(ncid)
+
+        if (ierr /= 0) then
+#ifdef HYDRO_D
+          write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm)
+#endif
+        end if
+
+  end subroutine READFORC_MDV
+
+
+
+  subroutine READFORC_NAMPCP(flnm,ix,jx,pcp,k,product)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    integer,                            intent(in)  :: k
+    character(len=*),                   intent(in)  :: product
+    integer :: it,jew,zsn
+    parameter(it =  496,jew = 449, zsn = 499)   ! domain 1
+!    parameter(it =  496,jew = 74, zsn = 109)   ! domain 2
+    real,             dimension(it,jew,zsn) :: buf
+    real,             dimension(ix,jx), intent(out) :: pcp
+
+    character(len=256) :: units
+    integer :: ierr,i,j,i2,j2,varid
+    integer :: ncid
+    real, dimension(ix,jx) :: temp
+
+!      varname = trim(product)
+
+!open NetCDF file...
+      if (k.eq.1.) then
+        ierr = nf_open(flnm, NF_NOWRITE, ncid)
+        if (ierr /= 0) then
+#ifdef HYDRO_D
+          write(*,'("READFORC_NAMPCP1 Problem opening netcdf file: ''",A, "''")') &
+              trim(flnm)
+#endif
+          call hydro_stop()
+        end if
+
+        ierr = nf_inq_varid(ncid,  trim(product),  varid)
+        ierr = nf_get_var_real(ncid, varid, buf)
+        ierr = nf_close(ncid)
+
+        if (ierr /= 0) then
+#ifdef HYDRO_D
+          write(*,'("READFORC_NAMPCP2 Problem reading netcdf file: ''", A,"''")') &
+             trim(flnm)
+#endif
+          call hydro_stop()
+        end if
+      endif
+#ifdef HYDRO_D
+      print *, "Data read in...",it,ix,jx,k
+#endif
+
+! Extract single time slice from dataset...
+
+      do i=1,ix
+        do j=1,jx
+          pcp(i,j) = buf(k,i,j)
+        end do
+      end do
+
+!      call get_2d_netcdf_ruc("trmm",ncid, pcp, jx, ix,k, .true., ierr)
+
+  end subroutine READFORC_NAMPCP
+
+
+
+
+  subroutine READFORC_COWS(flnm,ix,jx,target_date, t,q,u,p,lw,sw,pcp,tlevel)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    character(len=*),                   intent(in)  :: target_date
+    real,             dimension(ix,jx), intent(out) :: t
+    real,             dimension(ix,jx), intent(out) :: q
+    real,             dimension(ix,jx), intent(out) :: u
+    real,             dimension(ix,jx) :: v
+    real,             dimension(ix,jx), intent(out) :: p
+    real,             dimension(ix,jx), intent(out) :: lw
+    real,             dimension(ix,jx), intent(out) :: sw
+    real,             dimension(ix,jx), intent(out) :: pcp
+    integer   tlevel
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid
+
+    ! Open the NetCDF file.
+    ierr = nf_open(flnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+#ifdef HYDRO_D
+       write(*,'("READFORC_COWS Problem opening netcdf file: ''", A, "''")') trim(flnm)
+#endif
+       call hydro_stop()
+    endif
+
+    call get_2d_netcdf_cows("TA2",     ncid, t,     ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("QV2",     ncid, q,     ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("WSPD10",  ncid, u,     ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("PRES",    ncid, p,     ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("GLW",     ncid, lw,    ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("RSD",     ncid, sw,    ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("RAIN",    ncid, pcp,   ix, jx,tlevel, .TRUE., ierr)
+!yw   call get_2d_netcdf_cows("V2D",     ncid, v,     ix, jx,tlevel, .TRUE., ierr)
+
+    ierr = nf_close(ncid)
+
+  end subroutine READFORC_COWS
+
+
+
+
+  subroutine READFORC_RUC(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp)
+    
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    character(len=*),                   intent(in)  :: target_date
+    real,             dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc
+    integer   tlevel
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid
+
+    tlevel = 1
+
+    ! Open the NetCDF file.
+    ierr = nf_open(flnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+#ifdef HYDRO_D
+       write(*,'("READFORC_RUC Problem opening netcdf file: ''", A, "''")') trim(flnm)
+#endif
+       call hydro_stop()
+    endif
+
+    call get_2d_netcdf_ruc("T2",     ncid, t,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("Q2",     ncid, q,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("U10",    ncid, u,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("V10",    ncid, v,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("PSFC",   ncid, p,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("GLW",    ncid, lw,    ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("SWDOWN", ncid, sw,    ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("RAINC",  ncid, pcpc,  ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("RAINNC", ncid, pcp,   ix, jx,tlevel, .true., ierr)
+
+    ierr = nf_close(ncid)
+    
+
+!DJG  Add the convective and non-convective rain components (note: conv. comp=0
+!for cloud resolving runs...) 
+!DJG  Note that for RUC these are accumulated values to be adjusted to rates in
+!driver...
+
+    pcp=pcp+pcpc   ! assumes pcpc=0 for resolved convection...
+
+  end subroutine READFORC_RUC
+
+
+
+
+  subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    real,             dimension(ix,jx), intent(out) :: weasd
+    real,             dimension(ix,jx), intent(out) :: snodep
+    real, dimension(ix,jx) :: tmp
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid,i,j
+
+    ! Open the NetCDF file.
+
+    ierr = nf_open(flnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+#ifdef HYDRO_D
+       write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm)
+#endif
+       call hydro_stop()
+    endif
+
+    call get_2d_netcdf("WEASD",  ncid, tmp,   units, ix, jx, .FALSE., ierr)
+    if (ierr /= 0) then
+         call get_2d_netcdf("SNOW",  ncid, tmp,   units, ix, jx, .FALSE., ierr)
+         if (ierr == 0) then
+            units = "mm"
+            print *, "read WEASD from wrfoutput ...... "
+            weasd = tmp * 1.E-3
+         endif
+    else
+         weasd = tmp
+         if (trim(units) == "m") then
+            ! No conversion necessary
+         else if (trim(units) == "mm") then
+            ! convert WEASD from mm to m
+            weasd = weasd * 1.E-3
+         endif
+    endif
+
+    if (ierr /= 0) then
+#ifdef HYDRO_D
+       print *, "!!!!! NO WEASD present in input file...initialize to 0."
+#endif
+    endif
+
+
+    call get_2d_netcdf("SNODEP",     ncid, tmp,   units, ix, jx, .FALSE., ierr)
+    if (ierr /= 0) then
+       ! Quick assumption regarding snow depth.
+       call get_2d_netcdf("SNOWH",     ncid, tmp,   units, ix, jx, .FALSE., ierr)
+       if(ierr .eq. 0) then
+            print *, "read snow depth from wrfoutput ... " 
+            snodep = tmp
+       endif
+    else
+       snodep = tmp
+    endif
+
+    if (ierr /= 0) then
+       ! Quick assumption regarding snow depth.
+!yw       snodep = weasd * 10.
+       where(snodep .lt. weasd) snodep = weasd*10  !set lower bound to correct bi-lin interp err...
+    endif
+
+!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation...
+       where(snodep .lt. 0) snodep = 0
+       where(weasd .lt. 0) weasd = 0
+
+!yw      do i=1,ix
+!yw        do j=1,jx
+!yw           if (WEASD(i,j).lt.0.) WEASD(i,j)=0.0  !set lower bound to correct bi-lin interp err...
+!yw           if (snodep(i,j).lt.0.) snodep(i,j)=0.0  !set lower bound to correct bi-lin interp err...
+!yw         end do
+!yw       end do
+
+    ierr = nf_close(ncid)
+
+  end subroutine READSNOW_FORC
+
+    subroutine get2d_hrldas(inflnm,ix,jx,nsoil,smc,stc,sh2ox,cmc,t1,weasd,snodep)
+          implicit none
+          integer :: iret,varid,ncid,ix,jx,nsoil,ierr
+          real,dimension(ix,jx):: weasd,snodep,cmc,t1
+          real,dimension(ix,jx,nsoil):: smc,stc,sh2ox
+          character(len=*), intent(in) :: inflnm
+          character(len=256)::   units
+          iret = nf_open(trim(inflnm), NF_NOWRITE, ncid)
+          if(iret .ne. 0 )then
+#ifdef HYDRO_D
+              write(6,*) "Error: failed to open file :",trim(inflnm)
+#endif
+             call hydro_stop()
+          endif
+
+          call get2d_hrldas_real("CMC",     ncid, cmc,     ix, jx)
+          call get2d_hrldas_real("TSKIN",   ncid, t1,      ix, jx)
+          call get2d_hrldas_real("SWE",      ncid, weasd,   ix, jx)
+          call get2d_hrldas_real("SNODEP",     ncid, snodep,   ix, jx)
+
+    call get2d_hrldas_real("SOIL_T_1",    ncid, stc(:,:,1),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_2",    ncid, stc(:,:,2),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_3",    ncid, stc(:,:,3),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_4",    ncid, stc(:,:,4),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_5",    ncid, stc(:,:,5),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_6",    ncid, stc(:,:,6),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_7",    ncid, stc(:,:,7),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_8",    ncid, stc(:,:,8),  ix, jx)
+
+    call get2d_hrldas_real("SOIL_M_1",    ncid, SMC(:,:,1),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_2",    ncid, SMC(:,:,2),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_3",    ncid, SMC(:,:,3),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_4",    ncid, SMC(:,:,4),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_5",    ncid, SMC(:,:,5),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_6",    ncid, SMC(:,:,6),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_7",    ncid, SMC(:,:,7),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_8",    ncid, SMC(:,:,8),  ix, jx)
+
+    call get2d_hrldas_real("SOIL_W_1",    ncid, SH2OX(:,:,1),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_2",    ncid, SH2OX(:,:,2),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_3",    ncid, SH2OX(:,:,3),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_4",    ncid, SH2OX(:,:,4),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_5",    ncid, SH2OX(:,:,5),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_6",    ncid, SH2OX(:,:,6),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_7",    ncid, SH2OX(:,:,7),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_8",    ncid, SH2OX(:,:,8),  ix, jx)
+
+          iret = nf_close(ncid)
+         return
+      end subroutine get2d_hrldas
+
+      subroutine get2d_hrldas_real(var_name,ncid,out_buff,ix,jx)
+          implicit none
+          integer ::iret,varid,ncid,ix,jx
+          real out_buff(ix,jx)
+          character(len=*), intent(in) :: var_name
+          iret = nf_inq_varid(ncid,trim(var_name),  varid)
+          iret = nf_get_var_real(ncid, varid, out_buff)
+         return
+      end subroutine get2d_hrldas_real
+
+    subroutine read_stage4(flnm,IX,JX,pcp)
+        integer IX,JX,ierr,ncid,i,j
+        real pcp(IX,JX),buf(ix,jx)
+        character(len=*),  intent(in)  :: flnm
+        character(len=256) :: units
+
+        ierr = nf_open(flnm, NF_NOWRITE, ncid)
+
+        if(ierr .ne. 0) then
+            call hydro_stop()
+        endif
+
+        call get_2d_netcdf("RAINRATE",ncid, buf,   units, ix, jx, .TRUE., ierr)
+        ierr = nf_close(ncid)
+        do j = 1, jx
+        do i = 1, ix
+            if(buf(i,j) .lt. 0) then
+                 buf(i,j) = pcp(i,j)
+            end if
+        end do
+        end do
+        pcp = buf
+        return
+    END subroutine read_stage4
+
+
+
+
+ subroutine read_seq_forcing( &
+       indir,olddate,hgrid, &
+       ix,jx,forc_typ,snow_assim,  & 
+       T2,q2x,u,v,pres,xlong,short,prcp1,&
+       weasd,snodep,dt,k,prcp0 )
+! This subrouting is going to read different forcing.
+   implicit none
+   ! in variable
+   character(len=*) :: olddate,hgrid,indir
+   character(len=256) :: filename
+   integer :: ix,jx,forc_typ,k,snow_assim  ! k is time loop
+   real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,&
+          prcpnew,weasd,snodep,prcp0,prcp2,prcp_old
+   real ::  dt
+   ! tmp variable
+   character(len=256) :: inflnm, inflnm2, product
+   integer  :: i,j,mmflag,igrid,ierr_flg
+   real,dimension(ix,jx):: lai,fpar
+   character(len=4) nwxst_t
+   logical :: fexist
+
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             ".LDASIN_DOMAIN"//hgrid
+
+!!!DJG... Call READFORC_(variable) Subroutine for forcing data...
+!!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!)
+   if(FORC_TYP.eq.1) then
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             ".LDASIN_DOMAIN"//hgrid
+
+        inquire (file=trim(inflnm), exist=fexist)
+        if ( .not. fexist ) then
+#ifdef HYDRO_D
+           print*, "no forcing data found", inflnm
+#endif
+           call hydro_stop()
+        endif
+
+      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+   end if
+
+
+
+
+!!!DJG HRLDAS Forcing with minute format filename (NOTE: precip must be in mm/s!!!)
+   if(FORC_TYP.eq.2) then
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             olddate(15:16)//".LDASIN_DOMAIN"//hgrid
+        inquire (file=trim(inflnm), exist=fexist)
+        if ( .not. fexist ) then
+#ifdef HYDRO_D
+           print*, "no forcing data found", inflnm
+#endif
+           call hydro_stop()
+        endif
+      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+   end if
+
+
+
+
+
+!!!DJG WRF Output File Direct Ingest Forcing...
+     if(FORC_TYP.eq.3) then
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+             "wrfout_d0"//hgrid//"_"//&
+             olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//&
+             "_"//olddate(12:13)//":00:00"
+
+        inquire (file=trim(inflnm), exist=fexist)
+        if ( .not. fexist ) then
+#ifdef HYDRO_D
+           print*, "no forcing data found", inflnm
+#endif
+           call hydro_stop()
+        endif
+
+       CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+          PRES,XLONG,SHORT,PRCPnew)
+        PRCP1=(PRCPnew-prcp0)/dt   !Adjustment to convert accum to rate...(mm/s)
+
+!added by Wei Yu
+        if(k.eq. 1) then 
+           PRCP1 = 0
+        endif
+        prcp0 = PRCPnew
+!end added
+
+     end if
+
+
+
+
+
+!!!DJG CONSTant, idealized forcing...
+     if(FORC_TYP.eq.4) then
+! Impose a fixed diurnal cycle...
+! assumes model timestep is 1 hr
+! assumes K=1 is 12z (Ks or ~ sunrise)
+! First Precip...
+!       IF (K.GE.1 .and. K.LE.2) THEN
+       IF (K.EQ.1) THEN
+        PRCP1 =25.4/3600.0      !units mm/s  (Simulates 1"/hr for first time step...)
+!        PRCP1 =0./3600.0      !units mm/s  (Simulates 1"/hr for first time step...)
+       ELSEIF (K.GT.1) THEN
+!        PRCP1 =0./3600.0      !units mm/s
+!       ELSE
+         PRCP1 = 0.
+       END IF
+!       PRCP1 = 0.
+!       PRCP1 =10./3600.0      !units mm/s
+! Other Met. Vars...
+       T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       Q2X = 0.01
+       U = 1.0
+       V = 1.0
+       PRES = 100000.0
+       XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+    end if
+
+
+
+
+
+!!!DJG  Idealized Met. w/ Specified Precip. Forcing Data...(Note: input precip units here are in 'mm/hr')
+!   This option uses hard-wired met forcing EXCEPT precipitation which is read in
+!   from a single, separate input file called 'YYYYMMDDHHMM.LDASIN_PRECIP_DOMAIN'
+!
+    if(FORC_TYP.eq.5) then
+! Standard Met. Vars...
+       T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       Q2X = 0.01
+       U = 1.0
+       V = 1.0
+       PRES = 100000.0
+       XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+
+!Get specified precip....
+!!!VIP, dimensions of grid are currently hardwired in input subroutine!!!
+!       product = "trmm"
+!       inflnm = trim(indir)//"/"//"sat_domain1.nc"
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             olddate(15:16)//".LDASIN_PRECIP_DOMAIN"//hgrid
+        inquire (file=trim(inflnm), exist=fexist)
+        if ( .not. fexist ) then
+           inflnm = trim(indir)//"/"//&
+                olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+                olddate(15:16)//".PRECIP_FORCING.nc"
+           inquire (file=trim(inflnm), exist=fexist)
+        endif
+        if ( .not. fexist ) then
+           inflnm = trim(indir)//"/"//&
+                olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+                olddate(15:16)//"00.PRECIP_FORCING.nc"
+           inquire (file=trim(inflnm), exist=fexist)
+        endif
+        if ( .not. fexist ) then
+           inflnm = trim(indir)//"/"//&
+                olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+                ".PRECIP_FORCING.nc"
+           inquire (file=trim(inflnm), exist=fexist)
+        endif
+        if ( .not. fexist ) then
+#ifdef HYDRO_D
+           print*, "no forcing data found", inflnm
+#endif
+           call hydro_stop()
+        endif
+
+       PRCP1 = 0.
+       PRCP_old = PRCP1
+
+#ifdef HYDRO_D
+      print *, "Opening supplemental precipitation forcing file...",inflnm
+#endif
+       CALL READFORC_MDV(inflnm,IX,JX,   &
+          PRCP2,mmflag,ierr_flg)
+
+!If radar or spec. data is ok use if not, skip to original NARR data...
+      IF (ierr_flg.eq.0) then   ! use spec. precip
+!Convert units if necessary
+        IF (mmflag.eq.0) then    !Convert pcp grid to units of mm/s...
+           PRCP1=PRCP2/DT     !convert from mm to mm/s
+#ifdef HYDRO_D
+           print*, "Supplemental pcp is accumulated pcp/dt. "  
+#endif
+        else
+           PRCP1=PRCP2   !assumes PRCP2 is in mm/s 
+#ifdef HYDRO_D
+           print*, "Supplemental pcp is rate. "  
+#endif
+        END IF  ! Endif mmflag
+      ELSE   ! either stop or default to original forcing data...
+#ifdef HYDRO_D
+        print *,"Current RADAR precip data not found !!! Using previous available file..."
+#endif
+        PRCP1 = PRCP_old
+      END IF  ! Endif ierr_flg
+
+! Loop through data to screen for plausible values
+       do i=1,ix
+         do j=1,jx
+           if (PRCP1(i,j).lt.0.) PRCP1(i,j)= PRCP_old(i,j)
+           if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889  !set max pcp intens = 500 mm/h
+         end do
+       end do
+
+    end if
+
+
+
+
+
+!!!DJG HRLDAS Forcing with hourly format filename with specified precipitation forcing...
+!   This option uses HRLDAS-formatted met forcing EXCEPT precipitation which is read in
+!   from a single, separate input file called 'YYYYMMDDHHMM.LDASIN_PRECIP_DOMAIN'
+
+   if(FORC_TYP.eq.6) then
+
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             ".LDASIN_DOMAIN"//hgrid
+
+        inquire (file=trim(inflnm), exist=fexist)
+
+        if ( .not. fexist ) then
+           inflnm = trim(indir)//"/"//&
+              olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+              olddate(15:16)//".LDASIN_DOMAIN"//hgrid
+           inquire (file=trim(inflnm), exist=fexist)
+        endif
+
+
+        if ( .not. fexist ) then
+#ifdef HYDRO_D
+           print*, "no ATM forcing data found at this time", inflnm
+#endif
+        else
+           CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+                PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+           PRCP_old = PRCP1  ! This assigns new precip to last precip as a fallback for missing data...
+        endif
+
+
+!Get specified precip....
+!!!VIP, dimensions of grid are currently hardwired in input subroutine!!!
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             olddate(15:16)//"00.PRECIP_FORCING.nc"
+        inquire (file=trim(inflnm), exist=fexist)
+#ifdef HYDRO_D
+       if(fexist) print*, "using pcp forcing: ",trim(inflnm)
+#endif
+        if ( .not. fexist ) then
+            inflnm = trim(indir)//"/"//&
+                 olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+                 olddate(15:16)//".PRECIP_FORCING.nc"
+            inquire (file=trim(inflnm), exist=fexist)
+#ifdef HYDRO_D
+            if(fexist) print*, "using pcp forcing: ",trim(inflnm)
+#endif
+        endif
+        if ( .not. fexist ) then
+           inflnm = trim(indir)//"/"//&
+                olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+                olddate(15:16)//".LDASIN_PRECIP_DOMAIN"//hgrid
+           inquire (file=trim(inflnm), exist=fexist)
+#ifdef HYDRO_D
+           if(fexist) print*, "using pcp forcing: ",trim(inflnm)
+#endif
+        endif
+        if ( .not. fexist ) then
+#ifdef HYDRO_D
+           print*, "no supplemental forcing data found ", trim(inflnm)
+#endif
+           prcp1 = PRCP_old ! for missing pcp data use analysis/model input 
+        else
+           CALL READFORC_MDV(inflnm,IX,JX,   &
+              PRCP2,mmflag,ierr_flg)
+!If radar or spec. data is ok use if not, skip to original NARR data...
+           if(ierr_flg .ne. 0) then
+#ifdef HYDRO_D
+               print*, "Warning: pcp reading problem: ", trim(inflnm)
+#endif
+               PRCP1=PRCP_old
+           else
+               PRCP1=PRCP2   !assumes PRCP2 is in mm/s
+               IF (mmflag.eq.0) then    !Convert pcp grid to units of mm/s...
+                PRCP1=PRCP2/DT     !convert from mm to mm/s
+               END IF  ! Endif mmflag
+               print*, "replace pcp successfully! ",trim(inflnm)
+           endif
+        endif
+
+
+! Loop through data to screen for plausible values
+       where(PRCP1 .lt. 0) PRCP1=PRCP_old
+       do i=1,ix
+         do j=1,jx
+           if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0
+           if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889  !set max pcp intens = 500 mm/h
+         end do
+       end do
+
+   end if
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!The other forcing data types below here are obsolete and left for reference...
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!DJG HRLDAS Single Input with Multiple Input Times File Forcing...
+!     if(FORC_TYP.eq.6) then
+!!Create forcing data filename...
+!     if (len_trim(range) == 0) then
+!      inflnm = trim(indir)//"/"//&
+!             startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//&
+!             olddate(15:16)//".LDASIN_DOMAIN"//hgrid//"_multiple"
+!!        "MET_LIS_CRO_2D_SANTEE_LU_1KM."//&
+!!        ".156hrfcst.radar"
+!     else
+!     endif
+!     CALL READFORC_HRLDAS_mult(inflnm,IX,JX,OLDDATE,T2,Q2X,U,   &
+!          PRES,XLONG,SHORT,PRCP1,K)
+!
+!!       IF (K.GT.0.AND.K.LT.10) THEN
+!!         PRCP1 = 10.0/3600.0            ! units mm/s
+!!          PRCP1 = 0.254/3600.0
+!!       ELSE
+!!         PRCP1 = 0.
+!!       END IF
+!      endif
+
+
+
+!!!!!DJG  NARR Met. w/ NARR Precip. Forcing Data...
+!! Assumes standard 3-hrly NARR data has been resampled to NDHMS grid...
+!! Assumes one 3hrly time-step per forcing data file 
+!! Input precip units here are in 'mm' accumulated over 3 hrs...
+!    if(FORC_TYP.eq.7) then  !NARR Met. w/ NARR Precip.
+!!!Create forcing data filename...
+!      if (len_trim(range) == 0) then
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid
+!      else
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid//"."//trim(range)
+!      endif
+!      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+!          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+!      PRCP1=PRCP1/(3.0*3600.0)  ! convert from 3hr accum to mm/s which is what NDHMS expects    
+!    end if  !NARR Met. w/ NARR Precip.
+
+
+
+
+
+
+!!!!DJG  NARR Met. w/ Specified Precip. Forcing Data...
+!    if(FORC_TYP.eq.8) then !NARR Met. w/ Specified Precip.
+!
+!!Check to make sure if Noah time step is 3 hrs as is NARR...
+!
+!        PRCP_old = PRCP1
+!
+!     if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then   !if/then 3 hr check
+!!!Create forcing data filename...
+!      if (len_trim(range) == 0) then
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid
+!!        startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//&
+!!        ".48hrfcst.ncf"
+!      else
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid//"."//trim(range)
+!      endif
+!      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+!          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+!!       PRCP1=PRCP1/(3.0*3600.0)     !NARR 3hrly precip product in mm
+!       PRCP1=PRCP1     !NAM model data in mm/s
+!    end if    !3 hr check
+!
+!
+!!Get spec. precip....
+!! NAM Remote sensing...
+!!!!VIP, dimensions of grid are currently hardwired in input subroutine!!!
+!!       product = "trmm"
+!!       inflnm = trim(indir)//"/"//"sat_domain1.nc"
+!!!       inflnm = trim(indir)//"/"//"sat_domain2.nc"
+!!       PRCP1 = 0.
+!!       CALL READFORC_NAMPCP(inflnm,IX,JX,   &
+!!          PRCP2,K,product)
+!!       ierr_flg = 0
+!!       mmflag = 0
+!!!Convert pcp grid to units of mm/s...
+!!       PRCP1=PRCP1/(3.0*3600.0)     !3hrly precip product
+!
+!!Read from filelist (NAME HE...,others)...
+!!        if (K.eq.1) then
+!!          open(unit=93,file="filelist.txt",form="formatted",status="old")
+!!        end if
+!!        read (93,*) filename
+!!        inflnm = trim(indir)//"/"//trim(filename)
+!!
+!!
+!!Front Range MDV Radar...
+!
+!!         inflnm = "/ptmp/weiyu/rt_2008/radar_obs/"//&
+!!             inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//&
+!!              olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!!              olddate(15:16)//"_radar.nc"
+!!              olddate(15:16)//"_chill.nc"
+!
+!!        inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/Big_Thomp_04/"//&
+!!       inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//&
+!!             inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//&
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//&
+!!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!!             olddate(15:16)//"00_Pcp60min.nc"
+!!             olddate(15:16)//"00_Pcp30min.nc"
+!!             olddate(15:16)//"00_30min.nc"
+!             olddate(15:16)//"00_Pcp5min.nc"
+!!              olddate(15:16)//"_chill.nc"
+!
+!!         inflnm = "/d2/hydrolab/HRLDAS/forcing/COWS/"//&
+!!             olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//&
+!!             olddate(15:16)//"00_Pcp5min.nc"
+!!              olddate(15:16)//"00_5.nc"
+!
+!!         inflnm = ""     ! use this for NAM frxst runs with 30 min time-step
+!!
+!
+!
+!!        if (K.le.6) then   ! use for 30min nowcast...
+!!          if (K.eq.1) then
+!!             open(unit=94,file="start_file.txt",form="formatted",status="replace")
+!!!             inflnm2 = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//&
+!!             inflnm2 = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/"//&
+!!             olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//&
+!!             olddate(15:16)//"00_"
+!!             close(94)
+!!             nwxst_t = "5"! calc minutes from timestep and convert to char...
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!          if (K.eq.2) then
+!!             nwxst_t = "10" ! calc minutes from timestep and convert to char...
+!!             open(unit=94,file="start_file.txt",form="formatted",status="old")
+!!             read (94,*) inflnm2
+!!             close(94)
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!          if (K.eq.3) then
+!!             nwxst_t = "15" ! calc minutes from timestep and convert to char...
+!!             open(unit=94,file="start_file.txt",form="formatted",status="old")
+!!             read (94,*) inflnm
+!!             close(94)
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!          if (K.eq.4) then
+!!             nwxst_t = "20" ! calc minutes from timestep and convert to char...
+!!             open(unit=94,file="start_file.txt",form="formatted",status="old")
+!!             read (94,*) inflnm
+!!             close(94)
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!          if (K.eq.5) then
+!!             nwxst_t = "25" ! calc minutes from timestep and convert to char...
+!!             open(unit=94,file="start_file.txt",form="formatted",status="old")
+!!             read (94,*) inflnm
+!!             close(94)
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!          if (K.eq.6) then
+!!             nwxst_t = "30" ! calc minutes from timestep and convert to char...
+!!             open(unit=94,file="start_file.txt",form="formatted",status="old")
+!!             read (94,*) inflnm
+!!             close(94)
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!        else
+!!          inflnm = ""     ! use this for NAM frxst runs with 30 min time-step
+!!        end if
+!
+!!             olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//&
+!!             olddate(15:16)//"00_Pcp30minMerge.nc"
+!        
+!       CALL READFORC_MDV(inflnm,IX,JX,   &
+!          PRCP2,mmflag,ierr_flg)
+!
+!!If radar or spec. data is ok use if not, skip to original NARR data...
+!      IF (ierr_flg.eq.0) then   ! use spec. precip
+!         PRCP1=PRCP2   !assumes PRCP2 is in mm/s
+!!Convert units if necessary
+!        IF (mmflag.eq.0) then    !Convert pcp grid to units of mm/s...
+!          PRCP1=PRCP2/DT     !convert from mm to mm/s 
+!        END IF  ! Endif mmflag
+!      ELSE   ! either stop or default to original forcing data...
+!        PRCP1 = PRCP_old
+!      END IF  ! Endif ierr_flg
+!
+!! Loop through data to screen for plausible values
+!       do i=1,ix
+!         do j=1,jx
+!           if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0
+!           if (PRCP1(i,j).gt.0.0555) PRCP1(i,j)=0.0555  !set max pcp intens = 200 mm/h
+!!          PRCP1(i,j) = 0.
+!!          PRCP1(i,j) = 0.02   !override w/ const. precip for gw testing only...
+!         end do
+!       end do
+!
+!!        if (K.eq.1) then  ! quick dump for site specific precip...
+!          open(unit=94,file="Christman_accumpcp.txt",form="formatted",status="new")
+!        end if
+!
+!        
+!    end if  !NARR Met. w/ Specified Precip.
+
+
+
+
+
+!!!!DJG  NLDAS Met. w/ NLDAS Precip. Forcing Data...
+!! Assumes standard hrly NLDAS data has been resampled to NDHMS grid...
+!! Assumes one 1-hrly time-step per forcing data file
+!! Input precip units here are in 'mm' accumulated over 1 hr...
+!    if(FORC_TYP.eq.9) then  !NLDAS Met. w/ NLDAS Precip.
+!!!Create forcing data filename...
+!      if (len_trim(range) == 0) then
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!!Use this for minute forcing...             olddate(15:16)//".LDASIN_DOMAIN"//hgrid
+!             ".LDASIN_DOMAIN"//hgrid
+!      else
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid//"."//trim(range)
+!      endif
+!      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+!          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+!      PRCP1=PRCP1/(1.0*3600.0)  ! convert hourly NLDAS hourly accum pcp to mm/s which is what NDHMS expects
+!    end if  !NLDAS Met. w/ NLDAS Precip.
+
+
+
+
+
+!!!!DJG  NARR Met. w/ DMIP Precip. & Temp. Forcing Data...
+!    if(FORC_TYP.eq.10) then  ! If/Then for DMIP forcing data...
+!!Check to make sure if Noah time step is 3 hrs as is NARR...
+!
+!     if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then   !if/then 3 hr check
+!!!Create forcing data filename...
+!      if (len_trim(range) == 0) then
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid
+!!        startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//&
+!!        ".48hrfcst.ncf"
+!      else
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid//"."//trim(range)
+!      endif
+!      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+!          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+!          PRCP1=PRCP1/(3.0*3600.0)  ! convert to mm/s which is what HRLDAS expects    
+!    end if    !3 hr check
+!
+!!Get DMIP Precip...
+!!       inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/PRECIP_HRAP/precip_finished"//"/"//&
+!       inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/PRECIP_HRAP"//"/"//&
+!           "proj.xmrg"//&
+!           olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//&
+!           "z.asc"
+!        PRCP1 = 0.
+!        CALL READFORC_DMIP(inflnm,IX,JX,PRCP1)
+!          PRCP1 = PRCP1 / 100.0    ! Convert from native hundreths of mm to mm
+!!       IF (K.LT.34) THEN
+!!        PRCP1 = 5.0/3600.0            ! units mm/s
+!!!       ELSE
+!!!         PRCP1 = 0.
+!!       END IF
+!
+!!Get DMIP Temp...
+!!       inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/TEMP_HRAP/tair_finished"//"/"//&
+!       inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/TEMP_HRAP"//"/"//&
+!           "proj.tair"//&
+!           olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//&
+!           "z.asc"
+!        CALL READFORC_DMIP(inflnm,IX,JX,T2)
+!          T2 = (5./9.)*(T2-32.0) + 273.15         !Convert from deg F to deg K
+!
+!    end if  !End if for DMIP forcing data...
+!
+!
+!
+!! : add reading forcing precipitation data
+!!       ywinflnm = "/ptmp/weiyu/hrldas/v2/st4"//"/"//&
+!!            olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!!            ".LDASIN_DOMAIN2"
+!!       call read_stage4(ywinflnm,IX,JX,PRCP1)
+!!end yw
+!
+!
+!!!!DJG Check for snow data assimilation...
+
+   if (SNOW_ASSIM .eq. 1) then
+
+! Every 24 hours, update the snow field from analyses.
+     if(forc_typ .ne. 3 .or. forc_typ .ne. 6) then
+         if ( OLDDATE(12:13) == "00") then
+            CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP)
+         endif
+     else
+        CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP)
+     endif
+
+   end if
+
+
+ end subroutine read_seq_forcing
+
+
+#ifdef MPP_LAND
+    subroutine mpp_readland_hrldas(geo_static_flnm,&
+          ix,jx,land_cat,soil_cat,& 
+          vegtyp,soltyp,terrain,latitude,longitude,&
+          global_nx,global_ny,SOLVEG_INITSWC)
+    implicit none
+    character(len=*),          intent(in)  :: geo_static_flnm
+    integer,                   intent(in)  :: ix, jx, land_cat, soil_cat, &
+              global_nx,global_ny,SOLVEG_INITSWC
+    integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp
+    real,    dimension(ix,jx), intent(out) :: terrain, latitude, longitude
+    real, dimension(global_nx,global_ny) ::g_terrain, g_latitude, g_longitude
+    integer, dimension(global_nx,global_ny) :: g_vegtyp, g_soltyp
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid,varid
+    real, dimension(ix,jx) :: xdum
+    integer flag ! flag = 1 from wrfsi, flag =2 from WPS.
+     if(my_id.eq.IO_id) then
+        CALL READLAND_HRLDAS(geo_static_flnm,global_nx,  &
+               global_ny,LAND_CAT,SOIL_CAT,      &
+               g_VEGTYP,g_SOLTYP,g_TERRAIN,g_LATITUDE,g_LONGITUDE, SOLVEG_INITSWC)
+     end if
+  ! distribute the data to computation node.
+     call mpp_land_bcast_int1(LAND_CAT)
+     call mpp_land_bcast_int1(SOIL_CAT)
+     call decompose_data_int(g_VEGTYP,VEGTYP)
+     call decompose_data_int(g_SOLTYP,SOLTYP)
+     call decompose_data_real(g_TERRAIN,TERRAIN)
+     call decompose_data_real(g_LATITUDE,LATITUDE)
+     call decompose_data_real(g_LONGITUDE,LONGITUDE)
+      return 
+      end subroutine mpp_readland_hrldas
+
+
+      subroutine MPP_READSNOW_FORC(flnm,ix,jx,OLDDATE,weasd,snodep,&
+                 global_nX, global_ny)
+        implicit none
+
+        character(len=*),                   intent(in)  :: flnm,OLDDATE
+        integer,  intent(in)  :: ix, global_nx,global_ny
+        integer,                            intent(in)  :: jx
+        real,             dimension(ix,jx), intent(out) :: weasd
+        real,             dimension(ix,jx), intent(out) :: snodep
+
+        real,dimension(global_nX, global_ny):: g_weasd, g_snodep
+    
+        character(len=256) :: units
+        integer :: ierr
+        integer :: ncid,i,j
+
+        if(my_id .eq. IO_id) then
+          CALL READSNOW_FORC(trim(flnm),global_nX, global_ny,g_WEASD,g_SNODEP)
+       endif
+       call decompose_data_real(g_WEASD,WEASD)
+       call decompose_data_real(g_SNODEP,SNODEP)
+
+        return 
+        end  subroutine MPP_READSNOW_FORC
+
+      subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,&
+                 global_nX, global_ny,nsoil,out_SMC,out_SH2OX)
+        implicit none
+
+        integer,  intent(in)  :: ix,global_nx,global_ny
+        integer,  intent(in)  :: jx,nsoil
+        real,             dimension(ix,jx), intent(in) :: in_smcmax
+        real,             dimension(ix,jx,nsoil), intent(out) :: out_smc,out_sh2ox
+
+        real,dimension(global_nX, global_ny,nsoil):: g_smc, g_sh2ox
+        real,dimension(global_nX, global_ny):: g_smcmax
+        integer   :: i,j,k
+       
+
+          call write_IO_real(in_smcmax,g_smcmax)  ! get global grid of smcmax
+
+#ifdef HYDRO_D
+          write (*,*) "In deep GW...", nsoil
+#endif
+
+!loop to overwrite soils to saturation...
+        do i=1,global_nx
+         do j=1,global_ny
+            g_smc(i,j,1:NSOIL) = g_smcmax(i,j)
+            g_sh2ox(i,j,1:NSOIL) = g_smcmax(i,j)
+         end do 
+        end do 
+
+!decompose global grid to parallel tiles...
+       do k=1,nsoil
+        call decompose_data_real(g_smc(:,:,k),out_smc(:,:,k))
+        call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k))
+       end do
+
+        return 
+        end  subroutine MPP_DEEPGW_HRLDAS
+
+
+ subroutine mpp_read_forcing( &
+       indir,olddate,startdate,hgrid, &
+       ix,jx,forc_typ,snow_assim,  & 
+       T2,q2x,u,v,pres,xlong,short,prcp1,&
+       weasd,snodep,dt,k,g_ix,g_jx,igrid,prcp0)
+! This subrouting is going to read different forcing.
+
+
+   implicit none
+   ! in variable
+   character(len=*) :: olddate,hgrid,indir,startdate
+   character(len=256) :: filename
+   integer :: ix,jx,forc_typ,k,snow_assim,igrid  ! k is time loop
+   real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,&
+          prcpnew,weasd,snodep,prcp0 
+   real ::  dt
+   ! tmp variable
+   character(len=256) :: inflnm, product
+   integer  :: i,j,mmflag, g_ix,g_jx
+   real,dimension(ix,jx):: lai,fpar
+   real,dimension(g_ix,g_jx):: g_T2,g_Q2X,g_U,g_V,g_XLONG, &
+             g_SHORT,g_PRCP1,g_PRES,g_weasd,g_snodep,g_prcp0 
+   integer flag 
+   
+   if(forc_typ .eq. 2) then
+     call write_io_real(prcp0,g_prcp0)
+   endif
+
+   if(forc_typ .eq. 6 .OR. forc_typ .eq. 11) then  ! DJG (6-Spec. precip., 11-DESWAT)
+
+     call write_io_real(T2,g_T2)
+     call write_io_real(Q2X,g_Q2X)
+     call write_io_real(U,g_U)
+     call write_io_real(V,g_V)
+     call write_io_real(XLONG,g_XLONG)
+     call write_io_real(SHORT,g_SHORT)
+     call write_io_real(PRCP1,g_PRCP1)
+     call write_io_real(PRES,g_PRES)
+
+
+   end if
+
+   if(my_id .eq. IO_id) then
+      call read_seq_forcing( &
+        indir,olddate,hgrid,&
+        global_nx,global_ny,forc_typ,snow_assim,  &
+        g_T2,g_q2x,g_u,g_v,g_pres,g_xlong,g_short,g_prcp1,&
+        g_weasd,g_snodep,dt,k,g_prcp0 )
+#ifdef HYDRO_D
+     write(6,*) "finish read forcing,startdate,olddate ",startdate,olddate
+#endif
+   end if
+     call decompose_data_real(g_T2,T2)
+     call decompose_data_real(g_Q2X,Q2X)
+     call decompose_data_real(g_U,U)
+     call decompose_data_real(g_V,V)
+     call decompose_data_real(g_XLONG,XLONG)
+     call decompose_data_real(g_SHORT,SHORT)
+     call decompose_data_real(g_PRCP1,PRCP1)
+     call decompose_data_real(g_PRES,PRES)
+
+     if(forc_typ .eq. 3 .or. forc_typ .eq. 6 .and. snow_assim .eq. 1) then
+         call decompose_data_real(g_weasd,weasd)
+         call decompose_data_real(g_snodep,snodep)
+     else
+        flag = -1
+        if( my_id.eq.IO_id) then
+          if(OLDDATE(12:16) == "00:00") flag = 99
+        end if
+        call mpp_land_bcast_int1(flag)
+        if(flag .eq. 99 .and. snow_assim .eq. 1) then
+           call decompose_data_real(g_weasd,weasd)
+           call decompose_data_real(g_snodep,snodep)
+        endif
+     endif
+   return
+   end subroutine mpp_read_forcing
+#endif
+
+end module module_lsm_forcing
diff --git a/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F b/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F
new file mode 100644
index 00000000..ba40b76b
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F
@@ -0,0 +1,87 @@
+MODULE module_noah_chan_param_init_rt
+
+
+CONTAINS
+!
+!-----------------------------------------------------------------
+  SUBROUTINE CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann)
+!-----------------------------------------------------------------
+
+    IMPLICIT NONE
+
+    integer :: IINDEX, CHANCATS
+    integer :: ORDER
+    integer, PARAMETER :: NCHANTYPES=50 
+    real,dimension(NCHANTYPES)    :: BOTWID,HLINK_INIT,CHAN_SS,CHMann
+    character(LEN=11) :: DATATYPE
+
+!-----SPECIFY CHANNEL RELATED CHARACTERISTICS :
+!             ORDER: Strahler Stream Order
+!            BOTWID: Channel Bottom Width (meters)
+!        HLINK_INIT: Initial depth of flow in channel (meters)
+!           CHAN_SS: Channel side slope (assuming trapezoidal channel geom)
+!            CHMann: Channel Manning's N roughness coefficient 
+
+
+!-----READ IN CHANNEL PROPERTIES FROM CHANPARM.TBL :
+    OPEN(19, FILE='CHANPARM.TBL',FORM='FORMATTED',STATUS='OLD')
+    READ (19,*)
+    READ (19,2000,END=2002) DATATYPE
+#ifdef HYDRO_D
+    PRINT *, DATATYPE
+#endif
+    READ (19,*)CHANCATS,IINDEX
+2000 FORMAT (A11)
+
+!-----Read in Channel Parameters as functions of stream order...
+
+    IF(DATATYPE.EQ.'StreamOrder')THEN
+#ifdef HYDRO_D
+       PRINT *, 'CHANNEL DATA SOURCE TYPE = ',DATATYPE,' FOUND',           &
+            CHANCATS,' CATEGORIES'
+#endif
+       DO ORDER=1,CHANCATS
+          READ (19,*)IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER),   &
+               &     CHMann(ORDER)
+          PRINT *, IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER),   &
+               &     CHMann(ORDER)
+       ENDDO
+    ENDIF
+
+
+!-----Read in Channel Parameters as functions of ???other method??? (TBC)...
+
+
+2002 CONTINUE
+
+    CLOSE (19)
+  END SUBROUTINE CHAN_PARM_INIT
+
+
+
+#ifdef MPP_LAND
+  SUBROUTINE mpp_CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann)
+    use module_mpp_land, only:  my_id, IO_id,mpp_land_bcast_int1, &
+       mpp_land_bcast_real,mpp_land_bcast_int,mpp_land_bcast_real1
+    implicit none
+    integer :: IINDEX, CHANCATS
+    integer :: ORDER
+    integer, PARAMETER :: NCHANTYPES=50 
+    real,dimension(NCHANTYPES)    :: BOTWID,HLINK_INIT,CHAN_SS,CHMann
+    character(LEN=11) :: DATATYPE
+
+    if(my_id.eq.io_id) then
+       call CHAN_PARM_INIT(BOTWID,HLINK_INIT,CHAN_SS,CHMann)
+    end if
+       call mpp_land_bcast_real(NCHANTYPES,BOTWID)
+       call mpp_land_bcast_real(NCHANTYPES,HLINK_INIT)
+       call mpp_land_bcast_real(NCHANTYPES,CHAN_SS)
+       call mpp_land_bcast_real(NCHANTYPES,CHMann)
+    return 
+    END SUBROUTINE mpp_CHAN_PARM_INIT
+#endif
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+
+
+END MODULE module_Noah_chan_param_init_rt
diff --git a/wrfv2_fire/hydro/Routing/rtFunction.F b/wrfv2_fire/hydro/Routing/rtFunction.F
new file mode 100644
index 00000000..9334307f
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/rtFunction.F
@@ -0,0 +1,222 @@
+      subroutine exeRouting (did)
+         use module_RT_data, only: rt_domain
+         use module_GW_baseflow_data, only: gw2d
+         use module_GW_baseflow, only: simp_gw_buck, gwstep
+         use module_channel_routing, only: drive_channel
+         use module_namelist, only: nlst_rt
+
+#ifdef MPP_LAND  
+         use module_mpp_land 
+#endif
+
+       
+         implicit none
+         integer did, i
+         real, dimension(RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT):: &
+                   QSTRMVOLRT_DUM,LAKE_INFLORT_DUM, &
+                   QSTRMVOLRT_TS, LAKE_INFLORT_TS
+
+         real :: dx
+         integer ii,jj,kk
+
+
+           IF (nlst_rt(did)%SUBRTSWCRT.EQ.1 .or. nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) THEN
+
+              QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT
+              LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT
+
+#ifdef HYDRO_D
+               write(6,*) "*****yw******start drive_RT "
+#endif
+
+
+
+!          write(6,*) "yyww RT_DOMAIN(did)%SH2OX(15,1,7)= ", RT_DOMAIN(did)%SH2OX(15,1,7)
+
+         call drive_RT( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,&
+             RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT,  &
+             RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%STC,RT_DOMAIN(did)%SH2OX, &
+             RT_DOMAIN(did)%INFXSRT,RT_DOMAIN(did)%SFCHEADRT,RT_DOMAIN(did)%SMCMAX1,&
+             RT_DOMAIN(did)%SMCREF1,RT_DOMAIN(did)%LKSAT,  &
+             RT_DOMAIN(did)%SMCWLT1, RT_DOMAIN(did)%SMCRTCHK,RT_DOMAIN(did)%DSMC,&
+             RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SMCAGGRT,&
+             RT_DOMAIN(did)%STCAGGRT,RT_DOMAIN(did)%SH2OAGGRT, &
+             RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%SOLDEPRT,&
+             RT_DOMAIN(did)%INFXSAGGRT,RT_DOMAIN(did)%DHRT,RT_DOMAIN(did)%QSTRMVOLRT, &
+             RT_DOMAIN(did)%QBDRYRT,RT_DOMAIN(did)%LAKE_INFLORT,&
+             RT_DOMAIN(did)%SFCHEADSUBRT,RT_DOMAIN(did)%INFXSWGT,&
+             RT_DOMAIN(did)%LKSATRT, &
+             RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%OVROUGHRT,&
+             RT_DOMAIN(did)%QSUBRT,RT_DOMAIN(did)%ZWATTABLRT, &
+             RT_DOMAIN(did)%QSUBBDRYRT,   &
+             RT_DOMAIN(did)%RETDEPRT,RT_DOMAIN(did)%SOXRT,RT_DOMAIN(did)%SOYRT,&
+             RT_DOMAIN(did)%SUB_RESID,RT_DOMAIN(did)%SMCRT,&
+             RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCWLTRT, &
+             RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%LAKE_MSKRT,&
+             RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%dist, &
+             RT_DOMAIN(did)%LSMVOL,RT_DOMAIN(did)%DSMCTOT, &
+             RT_DOMAIN(did)%SMCTOT1,&
+             RT_DOMAIN(did)%SMCTOT2,RT_DOMAIN(did)%suminfxs1, &
+             RT_DOMAIN(did)%suminfxsrt,RT_DOMAIN(did)%SO8RT, &
+             RT_DOMAIN(did)%SO8RT_D,nlst_rt(did)%AGGFACTRT,  &
+             nlst_rt(did)%SUBRTSWCRT,nlst_rt(did)%OVRTSWCRT, &
+             RT_DOMAIN(did)%LAKE_CT, RT_DOMAIN(did)%STRM_CT,    &
+             nlst_rt(did)%RT_OPTION,RT_DOMAIN(did)%OV_ROUGH, &
+             RT_DOMAIN(did)%INFXSAGG1RT,RT_DOMAIN(did)%SFCHEADAGG1RT,&
+             RT_DOMAIN(did)%SFCHEADAGGRT,&
+             nlst_rt(did)%DTRT, &
+             nlst_rt(did)%DT,RT_DOMAIN(did)%LAKE_INFLOTRT,&
+             RT_DOMAIN(did)%QBDRYTRT,RT_DOMAIN(did)%QSUBBDRYTRT,&
+             RT_DOMAIN(did)%QSTRMVOLTRT,RT_DOMAIN(did)%q_sfcflx_x,&
+             RT_DOMAIN(did)%q_sfcflx_y,RT_DOMAIN(did)%LKSATFAC,&
+             RT_DOMAIN(did)%OVROUGHRTFAC,rt_domain(did)%dist_lsm(:,:,9) )
+
+            QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-QSTRMVOLRT_DUM
+            LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-LAKE_INFLORT_DUM
+
+#ifdef HYDRO_D
+           write(6,*) "*****yw******end drive_RT "
+#endif
+        end if
+
+
+
+!------------------------------------------------------------------
+!DJG Begin GW/Baseflow Routines
+!-------------------------------------------------------------------
+
+  IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN     ! Switch to activate/specify GW/Baseflow
+
+!  IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN     ! Switch to activate/specify GW/Baseflow
+
+    If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then   ! Call simple bucket baseflow scheme
+
+#ifdef HYDRO_D
+           write(6,*) "*****yw******start simp_gw_buck "
+#endif
+
+       call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,&
+             RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%basns_area,&
+             RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, &
+             RT_DOMAIN(did)%SOLDRAIN, &
+             RT_DOMAIN(did)%z_gwsubbas,&
+             RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,&
+             RT_DOMAIN(did)%qinflowbase,&
+             RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, &
+             RT_DOMAIN(did)%dist,nlst_rt(did)%DT,&
+             RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, &
+             RT_DOMAIN(did)%z_max,&
+             nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT)
+
+
+#ifdef MPP_LAND
+      if(my_id .eq. IO_id) then
+#endif
+
+       open (unit=51,file='GW_inflow.txt',form='formatted',&
+             status='unknown',position='append')
+       open (unit=52,file='GW_outflow.txt',form='formatted',&
+             status='unknown',position='append')
+       open (unit=53,file='GW_zlev.txt',form='formatted',&
+             status='unknown',position='append')
+       do i=1,RT_DOMAIN(did)%numbasns
+          write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i)
+951        FORMAT(I3,1X,A19,1X,F11.3)
+          write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i)
+          write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i)
+       end do
+       close(51)
+       close(52)
+       close(53)
+#ifdef MPP_LAND
+     endif
+#endif
+
+#ifdef HYDRO_D 
+           write(6,*) "*****yw******end simp_gw_buck "
+#endif
+
+!!!For parameter setup runs output the percolation for each basin,
+!!!otherwise comment out this output...
+    else if (nlst_rt(did)%GWBASESWCRT .eq. 3) then
+
+#ifdef HYDRO_D
+           write(6,*) "*****bf******start 2d_gw_model "
+#endif
+
+           DX = abs(nlst_rt(did)%DXRT0 * nlst_rt(did)%AGGFACTRT)
+           
+           call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, &
+			gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, &
+			gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, &
+			gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, &
+			gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, &
+			gw2d(did)%istep)
+           
+           
+! bftodo head postprocessing block 
+! GW-SOIL-CHANNEL interaction section
+	  gw2d(did)%ho = gw2d(did)%h
+
+#ifdef HYDRO_D
+           write(6,*) "*****bf******end 2d_gw_model "
+#endif
+      
+    End if
+
+  END IF    !DJG (End if for RTE SWC activation)
+!------------------------------------------------------------------
+!DJG End GW/Baseflow Routines
+!-------------------------------------------------------------------
+
+!-------------------------------------------------------------------
+!-------------------------------------------------------------------
+!DJG,DNY  Begin Channel and Lake Routing Routines
+!-------------------------------------------------------------------
+  IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN
+ 
+    call drive_CHANNEL(RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, &
+       nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, &
+       LAKE_INFLORT_TS, QSTRMVOLRT_TS,&
+       RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,&
+       RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,&
+       RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT, &
+       RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTRT, &
+       RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX,  RT_DOMAIN(did)%QLINK, &
+       RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,&
+       RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, &
+       RT_DOMAIN(did)%Bw,&
+       RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,&
+       RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, &
+       RT_DOMAIN(did)%ORIFICEA, &
+       RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, &
+       RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,&
+       RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, &
+       RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, &
+       RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, &
+       RT_DOMAIN(did)%RETDEP_CHAN &
+       , RT_DOMAIN(did)%node_area &
+#ifdef MPP_LAND
+       ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,&
+       RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, &
+       RT_DOMAIN(did)%yw_mpp_nlinks  &
+#endif
+       )
+  endif
+
+#ifdef HYDRO_D
+           write(6,*) "*****yw******end drive_CHANNEL "
+#endif
+
+      end subroutine  exeRouting
+
+      subroutine time_seconds(i3)
+          integer time_array(8)
+          real*8 i3
+          call date_and_time(values=time_array)
+          i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + &
+                time_array(7) + 0.001 * time_array(8)
+          return
+      end subroutine time_seconds
+
+
diff --git a/wrfv2_fire/hydro/Run/HYDRO.TBL b/wrfv2_fire/hydro/Run/HYDRO.TBL
new file mode 100644
index 00000000..1de05f57
--- /dev/null
+++ b/wrfv2_fire/hydro/Run/HYDRO.TBL
@@ -0,0 +1,50 @@
+     27 USGS for OV_ROUGH
+   SFC_ROUGH'
+     0.025,    'Urban and Built-Up Land'  
+     0.035,    'Dryland Cropland and Pasture' 
+     0.035,    'Irrigated Cropland and Pasture' 
+     0.055,    'Mixed Dryland/Irrigated Cropland and Pasture' 
+     0.035,    'Cropland/Grassland Mosaic'
+     0.068,    'Cropland/Woodland Mosaic' 
+     0.055,    'Grassland' 
+     0.055,    'Shrubland' 
+     0.055,    'Mixed Shrubland/Grassland' 
+     0.055,    'Savanna' 
+     0.200,    'Deciduous Broadleaf Forest' 
+     0.200,    'Deciduous Needleleaf Forest' 
+     0.200,    'Evergreen Broadleaf Forest'
+     0.200,    'Evergreen Needleleaf Forest'  
+     0.200,    'Mixed Forest' 
+     0.005,    'Water Bodies' 
+     0.070,    'Herbaceous Wetland' 
+     0.070,    'Wooded Wetland' 
+     0.035,    'Barren or Sparsely Vegetated' 
+     0.055,    'Herbaceous Tundra' 
+     0.055,    'Wooded Tundra' 
+     0.055,    'Mixed Tundra' 
+     0.055,    'Bare Ground Tundra' 
+     0.010,    'Snow or Ice' 
+     0.010,    'Playa' 
+     0.100,    'Lava'   
+     0.010,    'White Sand' 
+19, for SATDK
+SATDK     MAXSMC    REFSMC   WLTSMC  QTZ    '
+1.07E-6,  0.339,    0.236,   0.010,  0.92, 'SAND'
+1.41E-5,  0.421,    0.383,   0.028,  0.82, 'LOAMY SAND'
+5.23E-6,  0.434,    0.383,   0.047,  0.60, 'SANDY LOAM'
+2.81E-6,  0.476,    0.360,   0.084,  0.25, 'SILT LOAM'
+2.81E-6,  0.476,    0.383,   0.084,  0.10, 'SILT'
+3.38E-6,  0.439,    0.329,   0.066,  0.40, 'LOAM'
+4.45E-6,  0.404,    0.314,   0.067,  0.60, 'SANDY CLAY LOAM'
+2.04E-6,  0.464,    0.387,   0.120,  0.10, 'SILTY CLAY LOAM'
+2.45E-6,  0.465,    0.382,   0.103,  0.35, 'CLAY LOAM'
+7.22E-6,  0.406,    0.338,   0.100,  0.52, 'SANDY CLAY'
+1.34E-6,  0.468,    0.404,   0.126,  0.10, 'SILTY CLAY'
+9.74E-7,  0.468,    0.412,   0.138,  0.25, 'CLAY'
+3.38E-6,  0.439,    0.329,   0.066,  0.05, 'ORGANIC MATERIAL'
+    0.0,  1.0,      0.0,     0.0,    0.60, 'WATER'
+1.41E-4,  0.20,     0.170,   0.006,  0.07, 'BEDROCK'
+1.41E-5,  0.421,    0.283,   0.028,  0.25, 'OTHER(land-ice)'
+9.74E-7,  0.468,    0.454,   0.030,  0.60, 'PLAYA'
+1.41E-4,  0.200,    0.170,   0.006,  0.52, 'LAVA'
+1.07E-6,  0.339,    0.236,    0.01,  0.92, 'WHITE SAND'
diff --git a/wrfv2_fire/hydro/Run/hydro.namelist b/wrfv2_fire/hydro/Run/hydro.namelist
new file mode 100644
index 00000000..df5e19dc
--- /dev/null
+++ b/wrfv2_fire/hydro/Run/hydro.namelist
@@ -0,0 +1,104 @@
+&HYDRO_nlist
+
+!!!! SYSTEM COUPLING !!!!
+!Specify what is being coupled:  1=HRLDAS (offline Noah-LSM), 2=WRF, 3=NASA/LIS, 4=CLM
+ sys_cpl = 2
+
+
+
+!!!! MODEL INPUT DATA FILES !!!
+!Specify land surface model gridded input data file...(e.g.: "geo_em.d03.nc")
+ GEO_STATIC_FLNM = "RT/geo_em.d03.nc"
+
+!Specify the high-resolution routing terrain input data file...(e.g.: "Fulldom_hires_hydrofile.nc"
+ GEO_FINEGRID_FLNM = "/d1/gochis/NDHMS/terrain/FRNG/Fulldom_hires_hydrofile_ohd_new_basns_w_cal_params_full_domain.nc"
+
+!Specify the name of the restart file if starting from restart...comment out with '!' if not...
+  RESTART_FILE  = 'HYDRO_RST.2010-10-01_06:00_DOMAIN2'
+
+
+
+!!!! MODEL SETUP AND I/O CONTROL !!!!
+!Specify the domain or nest number identifier...(integer)
+ IGRID = 2
+
+!Specify the restart file write frequency...(minutes)
+ rst_dt = 60   
+
+!Specify the output file write frequency...(minutes)
+ out_dt = 60 ! minutes
+
+!Specify if output history files are to be written...(.TRUE. or .FALSE.)
+ HISTORY_OUTPUT = .TRUE.
+
+!Specify the number of output times to be contained within each output history file...(integer)
+!   SET = 1 WHEN RUNNING CHANNEL ROUTING ONLY/CALIBRATION SIMS!!!
+!   SET = 1 WHEN RUNNING COUPLED TO WRF!!!
+ SPLIT_OUTPUT_COUNT = 1
+
+! rst_typ = 1 : overwrite the soil variables from routing restart file.
+ rst_typ = 1
+
+!Restart switch to set restart accumulation variables = 0 (0-no reset, 1-yes reset to 0.0)
+ RSTRT_SWC = 0
+
+!Output high-resolution routing files...0=none, 1=total chan_inflow ASCII time-series, 2=hires grid and chan_inflow...
+ HIRES_OUT = 2
+
+!Specify the minimum stream order to output to netcdf point file...(integer)
+!Note: lower value of stream order produces more output.
+ order_to_write = 2
+
+
+
+!!!! PHYSICS OPTIONS AND RELATED SETTINGS !!!!
+!Switch for terrain adjustment of incoming solar radiation: 0=no, 1=yes
+!Note: This option is not yet active in Verion 1.0...
+!      WRF has this capability so be careful not to double apply the correction!!!
+ TERADJ_SOLAR = 0
+
+!Specify the number of soil layers (integer) and the depth of the bottom of each layer (meters)...
+! Notes: In Version 1 of WRF-Hydro these must be the same as in the namelist.input file
+!       Future versions will permit this to be different.
+ NSOIL=4
+ ZSOIL8(1) = -0.05
+ ZSOIL8(2) = -0.25
+ ZSOIL8(3) = -0.70 
+ ZSOIL8(4) = -1.5 
+
+!Specify the grid spacing of the terrain routing grid...(meters)
+ DXRT = 100
+
+!Specify the integer multiple between the land model grid and the terrain routing grid...(integer)
+ AGGFACTRT = 10
+
+!Specify the routing model timestep...(seconds)
+ DTRT = 10
+
+!Switch activate subsurface routing...(0=no, 1=yes)
+ SUBRTSWCRT = 1
+
+!Switch activate surface overland flow routing...(0=no, 1=yes)
+ OVRTSWCRT = 1
+
+!Switch to activate channel routing Routing Option: 1=Seepest Descent (D8) 2=CASC2D
+ rt_option    = 1
+ CHANRTSWCRT = 1
+
+!Specify channel routing option: 1=Muskingam-reach, 2=Musk.-Cunge-reach, 3=Diff.Wave-gridded
+ channel_option =3
+
+!Specify the reach file for reach-based routing options...
+ route_link_f = ""
+
+!Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through)
+ GWBASESWCRT = 1
+
+!Specify baseflow/bucket model initialization...(0=cold start from table, 1=restart file)
+ GW_RESTART = 1
+
+!Groundwater/baseflow mask specified on land surface model grid...
+!Note: Only required if baseflow bucket model is active
+ gwbasmskfil = "RT/basn_msk1k_frng_ohd.txt"
+
+/
diff --git a/wrfv2_fire/hydro/arc/Makefile.mpp b/wrfv2_fire/hydro/arc/Makefile.mpp
new file mode 100644
index 00000000..a494e8df
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/Makefile.mpp
@@ -0,0 +1,17 @@
+# Makefile 
+
+all:
+	(make -f Makefile.comm BASIC)
+
+BASIC:
+	(cd MPP     ; make -f Makefile)
+	(cd Data_Rec     ; make -f Makefile)
+	(cd Routing; make -f Makefile)
+	(cd HYDRO_drv;   make -f Makefile)
+
+clean:
+	(cd Data_Rec; make -f Makefile clean)
+	(cd HYDRO_drv; make -f Makefile clean)
+	(cd MPP; make -f Makefile clean)
+	(cd Routing;    make -f Makefile clean)
+	(rm -f lib/*.a */*.mod */*.o CPL/*/*.o CPL/*/*.mod)
diff --git a/wrfv2_fire/hydro/arc/Makefile.seq b/wrfv2_fire/hydro/arc/Makefile.seq
new file mode 100644
index 00000000..14d8a260
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/Makefile.seq
@@ -0,0 +1,30 @@
+# Makefile 
+
+all:
+	(make -f Makefile BASIC)
+
+BASIC:
+	(cd Data_Rec     ; make -f Makefile)
+	(cd Routing; make -f Makefile)
+	(cd HYDRO_drv;   make -f Makefile)
+
+LIS:
+	(make -f Makefile BASIC)
+	(cd LIS_cpl  ;   make -f Makefile)
+
+CLM:
+	(make -f Makefile BASIC)
+	(cd CLM_cpl  ;   make -f Makefile)
+
+WRF:
+	(make -f Makefile BASIC)
+	(cd WRF_cpl  ;   make -f Makefile)
+
+HYDRO:
+	(make -f Makefile BASIC)
+
+clean:
+	(cd Data_Rec; make -f Makefile clean)
+	(cd HYDRO_drv; make -f Makefile clean)
+	(cd Routing;    make -f Makefile clean)
+	(rm -f lib/*.a */*.mod CPL/*/*.o CPL/*/*.mod)
diff --git a/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r b/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r
new file mode 100644
index 00000000..d59c0b15
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r
@@ -0,0 +1,33 @@
+.IGNORE:
+
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+RM		=	rm -f 
+RMD		=	rm -f 
+COMPILER90=	mpxlf90_r
+F90FLAGS  =     -O2 -qfree=f90 -c -w -qspill=20000 -qmaxmem=64000
+LDFLAGS  =     -O2 -qfree=f90  -w -qspill=20000 -qmaxmem=64000
+MODFLAG	=	-I./ -I ../MPP -I../../MPP -I ../mod
+LDFLAGS	=	
+CPP	=       cpp
+LIBS 	=	
+CPPFLAGS	=	-C -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+NETCDFINC	=	$(NETCDF_INC) 
+NETCDFLIB	=	-L$(NETCDF_LIB) -lnetcdff -lnetcdf
+
diff --git a/wrfv2_fire/hydro/arc/macros.mpp.gfort b/wrfv2_fire/hydro/arc/macros.mpp.gfort
new file mode 100644
index 00000000..fd2da440
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.mpp.gfort
@@ -0,0 +1,29 @@
+.IGNORE:
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT =
+endif
+
+RMD		=	rm -f
+COMPILER90=	mpif90  
+F90FLAGS  =       -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 
+MODFLAG	=	-I./ -I ../../MPP -I ../MPP -I ../mod
+LDFLAGS	=	
+CPP	=       /lib/cpp
+CPPFLAGS	=       -C -P -traditional -DMPP_LAND -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+LIBS 	=	
+NETCDFINC       =       $(NETCDF_INC)
+NETCDFLIB       =       -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.mpp.ifort b/wrfv2_fire/hydro/arc/macros.mpp.ifort
new file mode 100644
index 00000000..d3fd9a7c
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.mpp.ifort
@@ -0,0 +1,32 @@
+.IGNORE:
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+
+RMD		=	rm -f
+COMPILER90=	mpif90
+FORMAT_FREE = -FR
+BYTESWAPIO = -convert big_endian
+F90FLAGS  =      -w -c -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO)
+MODFLAG	=	-I./ -I ../../MPP -I ../MPP -I ../mod
+LDFLAGS	=	
+CPP	=       cpp
+CPPFLAGS	=       -C -P -traditional -DMPP_LAND -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+LIBS 	=	
+NETCDFINC       =       $(NETCDF_INC)
+NETCDFLIB       =       -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.mpp.linux b/wrfv2_fire/hydro/arc/macros.mpp.linux
new file mode 100644
index 00000000..9c355ed2
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.mpp.linux
@@ -0,0 +1,31 @@
+.IGNORE:
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+RM		=	rm -f  
+RMD		=	rm -f    
+COMPILER90=	mpif90
+F90FLAGS  =     -Mfree -c -byteswapio -O2 
+LDFLAGS  =      $(F90FLAGS)
+MODFLAG	=	-I./ -I ../../MPP -I ../MPP -I ../mod 
+LDFLAGS	=	
+CPP	=       cpp
+CPPFLAGS	=       -C -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+LIBS 	=	
+NETCDFINC	=	$(NETCDF_INC) 
+NETCDFLIB	=	-L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r b/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r
new file mode 100644
index 00000000..d64595fe
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r
@@ -0,0 +1,32 @@
+.IGNORE:
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+
+
+RM		=	rm -f
+RMD		=	rm -f
+COMPILER90=	xlf90_r
+F90FLAGS  =       -c -O2 -qfree=f90 -qmaxmem=819200
+MODFLAG	=	-I./ -I ../../MPP -I ../MPP -I ../mod
+LDFLAGS	=	
+CPP	=       cpp -C -P
+CPPFLAGS	=       -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+LIBS 	=	
+NETCDFINC       =       $(NETCDF_INC)
+NETCDFLIB       =       -L$(NETCDF_LIB) -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.seq.gfort b/wrfv2_fire/hydro/arc/macros.seq.gfort
new file mode 100644
index 00000000..6a978310
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.seq.gfort
@@ -0,0 +1,30 @@
+.IGNORE:
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+
+RMD		=	rm -f
+COMPILER90=	gfortran
+F90FLAGS  =       -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 
+MODFLAG	=	-I./ -I../mod
+LDFLAGS	=	
+CPP	=       /lib/cpp
+CPPFLAGS	=       -C -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+LIBS 	=	
+NETCDFINC       =       $(NETCDF_INC)
+NETCDFLIB       =       -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.seq.ifort b/wrfv2_fire/hydro/arc/macros.seq.ifort
new file mode 100644
index 00000000..8a6249da
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.seq.ifort
@@ -0,0 +1,32 @@
+.IGNORE:
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO
+else
+WRF_HYDRO = 
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO) 
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+
+RMD		=	rm -f
+COMPILER90=	ifort 
+##F90FLAGS  =       -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 
+F90FLAGS  =       -w -c -ftz -align all -fno-alias -fp-model precise -FR -convert big_endian
+
+MODFLAG	=	-I./  -I ../mod
+LDFLAGS	=	
+CPP	=       cpp
+CPPFLAGS	=       -C -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+LIBS 	=	
+NETCDFINC       =       $(NETCDF_INC)
+NETCDFLIB       =       -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.seq.linux b/wrfv2_fire/hydro/arc/macros.seq.linux
new file mode 100644
index 00000000..50a77465
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.seq.linux
@@ -0,0 +1,32 @@
+.IGNORE:
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT 
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+
+RMD		=	ls 
+RM		=	rm -f
+COMPILER90=	pgf90 
+F90FLAGS  =     -Mfree -Mfptrap -c -byteswapio -Ktrap=fp -O2
+LDFLAGS  =      $(F90FLAGS)
+MODFLAG	=	-I./ -I ../mod
+LDFLAGS	=	
+CPP	=       cpp
+CPPFLAGS	=       -C -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRF_HYDRO) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+LIBS 	=	
+NETCDFINC       =       $(NETCDF_INC)
+NETCDFLIB       =       -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/configure b/wrfv2_fire/hydro/configure
new file mode 100755
index 00000000..151c2d0d
--- /dev/null
+++ b/wrfv2_fire/hydro/configure
@@ -0,0 +1,101 @@
+#!/usr/bin/perl
+
+  if(! defined($ENV{NETCDF_INC})){
+     if(defined($ENV{NETCDF})) {
+       $tt = `echo "NETCDF_INC = \${NETCDF}/include" > macros.tmp` ; 
+     } else {
+        print"Error: environment variable NETCDF_INC not defined. \n";
+        exit(0);
+     }
+   }
+
+  if(! defined($ENV{NETCDF_LIB})){
+     if(defined($ENV{NETCDF})) {
+       $tt = `echo "NETCDF_LIB = \${NETCDF}/lib" >> macros.tmp` ; 
+     } else {
+       print"Error: environment variable NETCDF_LIB not defined. \n";
+       exit(0);
+     }
+  }
+
+  if(-e macros) {system (rm -f macros);}
+#  if(-e Makefile) {system "rm -f Makefile" ;}
+
+#  system("cp arc/Makefile ."); 
+
+  if($#ARGV == 0) {
+     $response = shift(@ARGV) ;
+     print("Configure hydro: $response \n");
+  }else {
+     print "Please select from following supported options. \n\n";
+
+     print "   1. Linux PGI compiler sequential \n";
+     print "   2. Linux PGI compiler dmpar \n";
+     print "   3. IBM AIX compiler sequential, xlf90_r\n";
+     print "   4. IBM AIX compiler dmpar \n";
+     print "   5. Linux gfort compiler sequential \n";
+     print "   6. Linux gfort compiler dmpar      \n";
+     print "   7. Linux ifort compiler sequential \n";
+     print "   8. Linux ifort compiler dmpar      \n";
+     print "   0. exit only \n";
+
+     printf "\nEnter selection [%d-%d] : ",1,5 ;
+
+     $response =  ;
+     chop($response);
+  }
+
+  use Switch;
+  switch ($response) {
+     case 1 { 
+              # sequential linux 
+              system "cp arc/macros.seq.linux macros"; 
+              system "cp arc/Makefile.seq Makefile.comm"; 
+            }
+
+     case 2 {
+              # mpp linux 
+              system "cp arc/macros.mpp.linux macros"; 
+              system "cp arc/Makefile.mpp Makefile.comm"; 
+            }
+
+     case 3 {
+              # sequential IBM AIX
+              system "cp arc/macros.seq.IBM.xlf90_r macros"; 
+              system "cp arc/Makefile.seq Makefile.comm"; 
+            }
+
+     case 4 {
+              # mpp IBM AIX
+              system "cp arc/macros.mpp.IBM.xlf90_r macros"; 
+              system "cp arc/Makefile.mpp Makefile.comm"; 
+            }
+
+     case 5 {
+              # GFORTRAN only                         
+              system "cp arc/macros.seq.gfort macros"; 
+              system "cp arc/Makefile.seq Makefile.comm"; 
+            }
+
+      case 6 {
+               # GFORTRAN dmpar only                         
+               system "cp arc/macros.mpp.gfort macros"; 
+               system "cp arc/Makefile.mpp Makefile.comm"; 
+             }
+      case 7 {
+               # ifort sequential                            
+               system "cp arc/macros.seq.ifort macros"; 
+               system "cp arc/Makefile.seq Makefile.comm"; 
+             }
+      case 8 {
+               # ifort    dmpar only                         
+               system "cp arc/macros.mpp.ifort macros"; 
+               system "cp arc/Makefile.mpp Makefile.comm"; 
+             }
+
+     else   {print "no selection $response\n"; last} 
+  }
+  if(! (-e lib)) {mkdir lib;}
+  if(! (-e mod)) {mkdir mod;}
+  if(-e "macros.tmp")  { system("cat macros.tmp macros > macros.a; rm -f macros.tmp; mv macros.a macros");}
+  if((-d "LandModel") ) {system "cat macros LandModel/user_build_options.bak  > LandModel/user_build_options";}
diff --git a/wrfv2_fire/hydro/wrf_hydro_config b/wrfv2_fire/hydro/wrf_hydro_config
new file mode 100755
index 00000000..47548324
--- /dev/null
+++ b/wrfv2_fire/hydro/wrf_hydro_config
@@ -0,0 +1,28 @@
+#!/usr/bin/perl
+#input argument: Compiler/System sequential/parallel
+#This is called by WRF configuration only.
+if($#ARGV ne 1) {
+  print("Error: No such configuration for Hydro \n");
+  exit(1);
+}
+         $x = lc(shift(@ARGV));
+         $paropt = lc(shift(@ARGV));
+
+         print("Configure option for Hydro : $x  $paropt \n");  
+          if($x =~ "pgi") {
+              if($paropt eq 'serial') { system("./configure 1");}
+              else {system("./configure 2");}
+          }
+          if($x =~ "aix") {
+              if($paropt eq 'serial') { system("./configure 3");}
+              else {system("./configure 4");}
+          }
+          if($x =~ "gfortran") {
+              if($paropt eq 'serial') { system("./configure 5");}
+              else {system("./configure 6");}
+          }
+          if($x =~ "ifort") {
+              if($paropt eq 'serial') { system("./configure 7");}
+              else {system("./configure 8");}
+          }
+
diff --git a/wrfv2_fire/inc/version_decl b/wrfv2_fire/inc/version_decl
index c4770582..1b5abede 100644
--- a/wrfv2_fire/inc/version_decl
+++ b/wrfv2_fire/inc/version_decl
@@ -1 +1 @@
-   CHARACTER (LEN=10) :: release_version = 'V3.5      '
+   CHARACTER (LEN=10) :: release_version = 'V3.6      '
diff --git a/wrfv2_fire/main/depend.common b/wrfv2_fire/main/depend.common
index 6f713ae3..1bb2347d 100644
--- a/wrfv2_fire/main/depend.common
+++ b/wrfv2_fire/main/depend.common
@@ -13,7 +13,8 @@ module_dm.o: module_machine.o module_state_description.o module_wrf_error.o \
 		module_driver_constants.o \
 		module_timing.o \
 		module_comm_nesting_dm.o \
-		module_configure.o module_comm_dm.o
+		module_configure.o module_comm_dm.o \
+                module_cpl.o
 
 module_timing.o: hires_timer.o clog.o
 
@@ -62,18 +63,21 @@ module_alloc_space_7.o : module_domain_type.o module_configure.o
 module_alloc_space_8.o : module_domain_type.o module_configure.o
 module_alloc_space_9.o : module_domain_type.o module_configure.o
 
-module_streams.o : module_state_description.o 
+module_streams.o : \
+		module_state_description.o 
 
 module_driver_constants.o: \
 		module_state_description.o \
                 module_wrf_error.o
 
-module_integrate.o: module_domain.o \
+module_integrate.o: \
+		module_domain.o \
 		module_timing.o \
 		module_driver_constants.o \
 		module_state_description.o \
 		module_nesting.o \
 		module_configure.o \
+		module_cpl.o \
 		$(ESMF_MOD_DEPENDENCE)
 
 module_intermediate_nmm.o: \
@@ -84,29 +88,34 @@ module_intermediate_nmm.o: \
 		module_comm_dm.o \
                 module_timing.o
 
-module_io.o : md_calls.inc \
+module_io.o :	md_calls.inc \
                 module_dm.o \
 		module_state_description.o \
 		module_configure.o  \
                 module_streams.o \
 		module_driver_constants.o 
 
-module_io_quilt.o: module_state_description.o \
+module_io_quilt.o: \
+		module_state_description.o \
                 module_dm.o \
                 module_configure.o \
 		module_internal_header_util.o \
 		module_quilt_outbuf_ops.o \
-		module_wrf_error.o
+		module_wrf_error.o  \
+                module_cpl.o 
 
-module_machine.o: module_driver_constants.o
+module_machine.o: \
+		module_driver_constants.o
 
-module_nesting.o: module_machine.o \
+module_nesting.o: \
+		module_machine.o \
 		module_driver_constants.o \
 		module_configure.o \
 		$(ESMF_MOD_DEPENDENCE) \
 		module_domain.o 
 
-module_quilt_outbuf_ops.o: module_state_description.o module_timing.o
+module_quilt_outbuf_ops.o: \
+		module_state_description.o module_timing.o
 
 module_tiles.o: module_domain.o \
 		module_driver_constants.o \
@@ -126,6 +135,18 @@ module_wrf_error.o: \
 wrf_debug.o: \
 		module_wrf_error.o
 
+module_sm.o:	module_wrf_error.o
+
+module_cpl.o: \
+		../share/module_model_constants.o \
+		module_driver_constants.o \
+		module_domain.o \
+		module_configure.o \
+		module_cpl_oasis3.o
+
+module_cpl_oasis3.o: module_driver_constants.o \
+                     module_domain.o
+
 # End of DEPENDENCIES for frame
 
 # DEPENDENCIES for phys
@@ -193,7 +214,14 @@ module_bl_camuwpbl_driver.o: module_cam_shr_kind_mod.o \
 		module_cam_esinti.o 
 
 module_sf_mynn.o: module_sf_sfclay.o module_bl_mynn.o \
-                ../share/module_model_constants.o
+                ../share/module_model_constants.o \
+                ../frame/module_wrf_error.o
+
+module_sf_fogdes.o: ../share/module_model_constants.o \
+                module_bl_mynn.o
+
+module_bl_fogdes.o: ../share/module_model_constants.o \
+                module_bl_mynn.o
 
 module_sf_gfdl.o : \
 		module_gfs_machine.o \
@@ -275,6 +303,10 @@ module_cu_sas.o: module_gfs_machine.o \
 		 module_gfs_funcphys.o \
 		 module_gfs_physcons.o
 
+module_cu_mesosas.o: module_gfs_machine.o \
+		 module_gfs_funcphys.o \
+		 module_gfs_physcons.o
+
 module_cu_osas.o: module_gfs_machine.o \
 		 module_gfs_funcphys.o \
 		 module_gfs_physcons.o
@@ -409,6 +441,7 @@ module_sf_noahmpdrv.o: module_sf_noahmplsm.o \
 			module_sf_noahlsm_glacial_only.o \
 			module_sf_noahmp_glacier.o \
 			module_sf_myjsfc.o \
+			module_sf_noahmp_groundwater.o \
 			../share/module_model_constants.o
 
 module_sf_noahlsm_glacial_only.o: module_sf_noahlsm.o module_sf_noahmplsm.o
@@ -416,6 +449,8 @@ module_sf_noahlsm_glacial_only.o: module_sf_noahlsm.o module_sf_noahmplsm.o
 module_sf_noahmplsm.o:	../share/module_model_constants.o \
 			module_sf_myjsfc.o
 
+module_sf_noahmp_groundwater.o:
+
 module_sf_bep.o: ../share/module_model_constants.o module_sf_urban.o
 
 module_sf_bep_bem.o: ../share/module_model_constants.o module_sf_bem.o module_sf_urban.o
@@ -455,7 +490,8 @@ module_physics_init.o : \
 		module_sf_slab.o		\
 		module_sf_myjsfc.o		\
 		module_sf_mynn.o                \
-		module_sf_urban.o                \
+		module_sf_fogdes.o              \
+		module_sf_urban.o               \
 		module_sf_qnsesfc.o		\
 		module_sf_pxsfclay.o		\
 		module_sf_noahlsm.o		\
@@ -468,6 +504,7 @@ module_physics_init.o : \
                 module_sf_bep_bem.o             \
 		module_sf_ruclsm.o		\
 		module_sf_pxlsm.o		\
+		module_sf_lake.o		\
 		module_bl_ysu.o		        \
 		module_bl_mrf.o			\
 		module_bl_gfs.o			\
@@ -517,7 +554,7 @@ module_physics_init.o : \
 		module_cam_constituents.o       \
 		module_cam_mp_modal_aero_initialize_data_phys.o \
 		module_cam_support.o \
-		module_wind_fitch.o		\
+		module_wind_fitch.o \
 		../frame/module_state_description.o \
 		../frame/module_configure.o \
 		../frame/module_wrf_error.o \
@@ -581,10 +618,11 @@ module_pbl_driver.o:  \
 		module_bl_gfs.o \
 		module_bl_gfs2011.o \
 		module_bl_mynn.o \
+		module_bl_fogdes.o \
 		module_bl_gwdo.o \
-		module_wind_fitch.o \
 		module_bl_temf.o \
 		module_bl_mfshconvpbl.o \
+		module_wind_fitch.o \
 		../frame/module_state_description.o \
 		../frame/module_configure.o \
 		../share/module_model_constants.o 
@@ -606,6 +644,7 @@ module_radiation_driver.o: \
 		module_ra_hs.o \
 		module_ra_goddard.o \
                 module_ra_flg.o \
+                module_ra_aerosol.o \
 		../frame/module_driver_constants.o \
 		../frame/module_state_description.o \
 		../frame/module_dm.o \
@@ -625,6 +664,7 @@ module_surface_driver.o: \
 		module_sf_pxsfclay.o		\
 		module_sf_gfs.o  		\
 		module_sf_noah_seaice_drv.o	\
+                module_sf_noahmp_groundwater.o  \
 		module_sf_noahdrv.o		\
 		module_sf_clm.o			\
                 module_sf_ssib.o                \
@@ -632,9 +672,11 @@ module_surface_driver.o: \
 		module_sf_ruclsm.o		\
 		module_sf_pxlsm.o		\
 		module_sf_mynn.o                \
+		module_sf_fogdes.o              \
 		module_sf_sfcdiags.o		\
 		module_sf_sfcdiags_ruclsm.o     \
 		module_sf_sstskin.o		\
+                module_sf_lake.o                \
 		module_sf_tmnupdate.o		\
 		module_sf_temfsfclay.o		\
 		module_sf_idealscmsfclay.o	\
@@ -643,6 +685,7 @@ module_surface_driver.o: \
 		module_sf_ocean_driver.o	\
 		../frame/module_state_description.o \
 		../frame/module_configure.o \
+		../frame/module_cpl.o \
 		../share/module_model_constants.o  
 
 module_sf_ocean_driver.o : \
@@ -650,9 +693,38 @@ module_sf_ocean_driver.o : \
 		module_sf_3dpwp.o \
 		../frame/module_state_description.o 
 
-module_diagnostics.o: ../frame/module_dm.o \
+module_diagnostics_driver.o: \
+		module_lightning_driver.o 		\
+		module_diag_misc.o 			\
+		module_diag_cl.o			\
+		module_diag_pld.o 			\
+		module_diag_afwa.o 			\
+		../frame/module_state_description.o 	\
+		../frame/module_domain.o 		\
+		../frame/module_configure.o 		\
+		../frame/module_driver_constants.o 	\
+		../share/module_model_constants.o
+
+module_diag_misc.o: \
+		../frame/module_dm.o
+
+module_diag_cl.o: \
+		../frame/module_dm.o 			\
+		../frame/module_configure.o
+
+module_diag_pld.o: \
+		../share/module_model_constants.o
+
+module_diag_afwa.o: \
+		../frame/module_domain.o 		\
+		../frame/module_dm.o 			\
+		../frame/module_state_description.o 	\
+		../frame/module_configure.o 		\
 		../share/module_model_constants.o
 
+module_diag_refl.o: \
+		../frame/module_dm.o			\
+		../share/module_model_constants.o
 
 module_mixactivate.o: \
 		module_radiation_driver.o
@@ -670,6 +742,10 @@ module_fddaobs_driver.o: \
 		../share/module_model_constants.o  \
 		module_fddaobs_rtfdda.o
 
+module_sf_lake.o : \
+             ../share/module_model_constants.o
+ 
+
 module_fr_fire_driver.o: \
 		../share/module_model_constants.o  \
                 ../frame/module_comm_dm.o \
@@ -715,9 +791,6 @@ module_fdda_spnudging.o :\
 module_sf_bep.o :\
 		module_sf_urban.o
 
-module_wind_fitch.o :\
-		module_wind_generic.o
-
 module_mp_wsm5.o :\
 		module_mp_wsm5_accel.F \
 		module_mp_radar.o
@@ -748,6 +821,9 @@ module_ltng_crmpr92.o :
 
 module_ltng_iccg.o :
 
+module_ra_aerosol.o :\
+	../frame/module_wrf_error.o
+
 # End of DEPENDENCIES for phys
 
 
@@ -1118,6 +1194,7 @@ module_wrf_top.o: ../frame/module_machine.o \
                   ../frame/module_timing.o \
                   ../frame/module_wrf_error.o \
                   ../frame/module_state_description.o \
+                  ../frame/module_cpl.o \
                   $(ESMF_MOD_DEPENDENCE)
 
 # End of DEPENDENCIES for main
diff --git a/wrfv2_fire/main/module_wrf_top.F b/wrfv2_fire/main/module_wrf_top.F
index f6fd7643..71b236c2 100644
--- a/wrfv2_fire/main/module_wrf_top.F
+++ b/wrfv2_fire/main/module_wrf_top.F
@@ -24,6 +24,8 @@ MODULE module_wrf_top
    USE module_dm, ONLY : wrf_dm_initialize
 #endif
 
+   USE module_cpl, ONLY : coupler_on, cpl_finalize, cpl_defdomain
+
    IMPLICIT NONE
 
    REAL    :: time
@@ -52,6 +54,7 @@ MODULE module_wrf_top
 
    CHARACTER (LEN=80)      :: rstname
    CHARACTER (LEN=80)      :: message
+   CHARACTER (LEN=256) , PRIVATE :: a_message
 
    INTERFACE 
      SUBROUTINE Setup_Timekeeping( grid )
@@ -236,7 +239,10 @@ SUBROUTINE wrf_init( no_init1 )
    ALLOCATE( hostids(nproc) )
    ALLOCATE( budds(nproc) )
    CALL mpi_allgather( hostid, 1, MPI_INTEGER, hostids, 1, MPI_INTEGER, loccomm, ierr )
-   if ( ierr .NE. 0 ) write(0,*)__FILE__,__LINE__,'error in mpi_allgather ',ierr
+   IF ( ierr .NE. 0 ) THEN
+      write(a_message,*)__FILE__,__LINE__,'error in mpi_allgather ',ierr
+      CALL wrf_message ( a_message ) 
+   END IF
    budds = -1
    buddcounter = 0 
    ! mark the ones i am on the same node with
@@ -388,6 +394,7 @@ SUBROUTINE wrf_init( no_init1 )
    END IF
 #endif
 
+   IF (coupler_on) CALL cpl_defdomain( head_grid ) 
 
    END SUBROUTINE wrf_init
 
@@ -447,8 +454,12 @@ SUBROUTINE wrf_finalize( no_shutdown )
    ! for DM parallel runs).  
    IF ( .NOT. PRESENT( no_shutdown ) ) THEN
      ! Finalize time manager
-     CALL WRFU_Finalize
-     CALL wrf_shutdown
+      IF (coupler_on) THEN 
+         CALL cpl_finalize() 
+      ELSE
+         CALL WRFU_Finalize
+         CALL wrf_shutdown
+      ENDIF
    ENDIF
 
    END SUBROUTINE wrf_finalize
diff --git a/wrfv2_fire/main/nup_em.F b/wrfv2_fire/main/nup_em.F
index 3a8530db..3689a7fa 100644
--- a/wrfv2_fire/main/nup_em.F
+++ b/wrfv2_fire/main/nup_em.F
@@ -302,7 +302,7 @@ END SUBROUTINE Setup_Timekeeping
    CALL       nl_set_e_we( 1, e_we-2 )
    CALL       nl_set_e_sn( 1, e_sn-2 )
 
-write(0,*)'after alloc_and_configure_domain ',associated(nested_grid%intermediate_grid)
+!write(0,*)'after alloc_and_configure_domain ',associated(nested_grid%intermediate_grid)
 
    CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
    CALL set_scalar_indices_from_config ( nested_grid%id , idum1, idum2 )
diff --git a/wrfv2_fire/main/real_em.F b/wrfv2_fire/main/real_em.F
index eeb21cd6..c837ec65 100644
--- a/wrfv2_fire/main/real_em.F
+++ b/wrfv2_fire/main/real_em.F
@@ -15,7 +15,7 @@ PROGRAM real_data
    USE module_configure, ONLY : grid_config_rec_type, model_config_rec, &
         initial_config, get_config_as_buffer, set_config_as_buffer
    USE module_timing
-   USE module_state_description, ONLY : realonly
+   USE module_state_description, ONLY : realonly, THOMPSONAERO
 #ifdef NO_LEAP_CALENDAR
    USE module_symbols_util, ONLY: wrfu_cal_noleap
 #else
@@ -691,6 +691,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
    REAL , DIMENSION(:,:,:) , ALLOCATABLE , SAVE :: mbdy2dtemp1
    REAL , DIMENSION(:,:,:) , ALLOCATABLE , SAVE :: ubdy3dtemp2 , vbdy3dtemp2 , tbdy3dtemp2 , pbdy3dtemp2 , qbdy3dtemp2
    REAL , DIMENSION(:,:,:) , ALLOCATABLE , SAVE :: mbdy2dtemp2
+   REAL , DIMENSION(:,:,:) , ALLOCATABLE , SAVE :: qn1bdy3dtemp1, qn1bdy3dtemp2, qn2bdy3dtemp1, qn2bdy3dtemp2
 real::t1,t2
 
    !  Various sizes that we need to be concerned about.
@@ -751,7 +752,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
          IF ( ALLOCATED ( pbdy3dtemp2 ) ) DEALLOCATE ( pbdy3dtemp2 )
          IF ( ALLOCATED ( qbdy3dtemp2 ) ) DEALLOCATE ( qbdy3dtemp2 )
          IF ( ALLOCATED ( mbdy2dtemp2 ) ) DEALLOCATE ( mbdy2dtemp2 )
-   
+
          ALLOCATE ( ubdy3dtemp1(ims:ime,kms:kme,jms:jme) )
          ALLOCATE ( vbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
          ALLOCATE ( tbdy3dtemp1(ims:ime,kms:kme,jms:jme) )
@@ -765,6 +766,17 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
          ALLOCATE ( qbdy3dtemp2(ims:ime,kms:kme,jms:jme) )
          ALLOCATE ( mbdy2dtemp2(ims:ime,1:1,    jms:jme) )
 
+         IF (config_flags%mp_physics.eq.THOMPSONAERO .AND.  config_flags%use_aero_icbc) THEN
+            IF ( ALLOCATED ( qn1bdy3dtemp1 ) ) DEALLOCATE ( qn1bdy3dtemp1 )
+            IF ( ALLOCATED ( qn2bdy3dtemp1 ) ) DEALLOCATE ( qn2bdy3dtemp1 )
+            IF ( ALLOCATED ( qn1bdy3dtemp2 ) ) DEALLOCATE ( qn1bdy3dtemp2 )
+            IF ( ALLOCATED ( qn2bdy3dtemp2 ) ) DEALLOCATE ( qn2bdy3dtemp2 )
+            ALLOCATE ( qn1bdy3dtemp1(ims:ime,kms:kme,jms:jme) )
+            ALLOCATE ( qn2bdy3dtemp1(ims:ime,kms:kme,jms:jme) )
+            ALLOCATE ( qn1bdy3dtemp2(ims:ime,kms:kme,jms:jme) )
+            ALLOCATE ( qn2bdy3dtemp2(ims:ime,kms:kme,jms:jme) )
+         END IF
+
       END IF
 
       !  Open the wrfinput file.  From this program, this is an *output* file.
@@ -815,6 +827,13 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
             END DO
          END DO
 
+         IF (config_flags%mp_physics.eq.THOMPSONAERO .AND.  config_flags%use_aero_icbc) THEN
+            CALL couple ( grid%mu_2 , grid%mub , qn1bdy3dtemp1 , grid%scalar(:,:,:,P_QNWFA)      , 't' , grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+            CALL couple ( grid%mu_2 , grid%mub , qn2bdy3dtemp1 , grid%scalar(:,:,:,P_QNIFA)      , 't' , grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         END IF
+
       END IF
 
       IF(grid_fdda .GE. 1)THEN
@@ -880,6 +899,21 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
                                                                     ids , ide , jds , jde , 1 , 1 , &
                                                                     ims , ime , jms , jme , 1 , 1 , &
                                                                     ips , ipe , jps , jpe , 1 , 1 )
+
+         IF (config_flags%mp_physics.eq.THOMPSONAERO .AND.  config_flags%use_aero_icbc) THEN
+            CALL stuff_bdy     ( qn1bdy3dtemp1 , grid%scalar_bxs(:,:,:,P_QNWFA), grid%scalar_bxe(:,:,:,P_QNWFA),     &
+                                            grid%scalar_bys(:,:,:,P_QNWFA), grid%scalar_bye(:,:,:,P_QNWFA),     &
+                                                              'T' , spec_bdy_width      ,               &
+                                                                    ids , ide , jds , jde , kds , kde , &
+                                                                    ims , ime , jms , jme , kms , kme , &
+                                                                    ips , ipe , jps , jpe , kps , kpe )
+            CALL stuff_bdy     ( qn2bdy3dtemp1 , grid%scalar_bxs(:,:,:,P_QNIFA), grid%scalar_bxe(:,:,:,P_QNIFA),     &
+                                            grid%scalar_bys(:,:,:,P_QNIFA), grid%scalar_bye(:,:,:,P_QNIFA),     &
+                                                              'T' , spec_bdy_width      ,               &
+                                                                    ids , ide , jds , jde , kds , kde , &
+                                                                    ims , ime , jms , jme , kms , kme , &
+                                                                    ips , ipe , jps , jpe , kps , kpe )
+         END IF
       END IF
 
 
@@ -940,6 +974,13 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
             END DO
          END DO
 
+         IF (config_flags%mp_physics.eq.THOMPSONAERO .AND.  config_flags%use_aero_icbc) THEN
+            CALL couple ( grid%mu_2 , grid%mub , qn1bdy3dtemp2 , grid%scalar(:,:,:,P_QNWFA)      , 't' , grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+            CALL couple ( grid%mu_2 , grid%mub , qn2bdy3dtemp2 , grid%scalar(:,:,:,P_QNIFA)      , 't' , grid%msfty , &
+                       ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
+         END IF
+
       END IF
 
       IF(grid_fdda .GE. 1)THEN
@@ -1023,6 +1064,24 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
                                                                ids , ide , jds , jde , 1 , 1 , &
                                                                ims , ime , jms , jme , 1 , 1 , &
                                                                ips , ipe , jps , jpe , 1 , 1 )
+         IF (config_flags%mp_physics.eq.THOMPSONAERO .AND.  config_flags%use_aero_icbc) THEN
+            CALL stuff_bdytend ( qn1bdy3dtemp2 , qn1bdy3dtemp1 , REAL(interval_seconds) ,                 &
+                                                               grid%scalar_btxs(:,:,:,P_QNWFA), grid%scalar_btxe(:,:,:,P_QNWFA), &
+                                                               grid%scalar_btys(:,:,:,P_QNWFA), grid%scalar_btye(:,:,:,P_QNWFA), &
+                                                               'T' , &
+                                                               spec_bdy_width      , &
+                                                               ids , ide , jds , jde , kds , kde , &
+                                                               ims , ime , jms , jme , kms , kme , &
+                                                               ips , ipe , jps , jpe , kps , kpe )
+            CALL stuff_bdytend ( qn2bdy3dtemp2 , qn2bdy3dtemp1 , REAL(interval_seconds) ,                 &
+                                                               grid%scalar_btxs(:,:,:,P_QNIFA), grid%scalar_btxe(:,:,:,P_QNIFA), &
+                                                               grid%scalar_btys(:,:,:,P_QNIFA), grid%scalar_btye(:,:,:,P_QNIFA), &
+                                                               'T' , &
+                                                               spec_bdy_width      , &
+                                                               ids , ide , jds , jde , kds , kde , &
+                                                               ims , ime , jms , jme , kms , kme , &
+                                                               ips , ipe , jps , jpe , kps , kpe )
+         END IF
       END IF
 
       !  Both pieces of the boundary data are now available to be written (initial time and tendency).
@@ -1133,6 +1192,17 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
                END DO
             END DO
 
+            IF (config_flags%mp_physics.eq.THOMPSONAERO .AND.  config_flags%use_aero_icbc) THEN
+               DO j = jps , jpe
+                  DO k = kps , kpe
+                     DO i = ips , ipe
+                        qn1bdy3dtemp1(i,k,j) = qn1bdy3dtemp2(i,k,j)
+                        qn2bdy3dtemp1(i,k,j) = qn2bdy3dtemp2(i,k,j)
+                     END DO
+                  END DO
+               END DO
+            END IF
+
          END IF
 
          IF(grid_fdda .GE. 1)THEN
@@ -1198,6 +1268,21 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
                                                                        ids , ide , jds , jde , 1 , 1 , &
                                                                        ims , ime , jms , jme , 1 , 1 , &
                                                                        ips , ipe , jps , jpe , 1 , 1 )
+
+            IF (config_flags%mp_physics.eq.THOMPSONAERO .AND.  config_flags%use_aero_icbc) THEN
+               CALL stuff_bdy     ( qn1bdy3dtemp1 , grid%scalar_bxs(:,:,:,P_QNWFA), grid%scalar_bxe(:,:,:,P_QNWFA),     &
+                                                    grid%scalar_bys(:,:,:,P_QNWFA), grid%scalar_bye(:,:,:,P_QNWFA),     &
+                                                                 'T' , spec_bdy_width      ,               &
+                                                                       ids , ide , jds , jde , kds , kde , &
+                                                                       ims , ime , jms , jme , kms , kme , &
+                                                                       ips , ipe , jps , jpe , kps , kpe )
+               CALL stuff_bdy     ( qn2bdy3dtemp1 , grid%scalar_bxs(:,:,:,P_QNIFA), grid%scalar_bxe(:,:,:,P_QNIFA),     &
+                                                    grid%scalar_bys(:,:,:,P_QNIFA), grid%scalar_bye(:,:,:,P_QNIFA),     &
+                                                                 'T' , spec_bdy_width      ,               &
+                                                                       ids , ide , jds , jde , kds , kde , &
+                                                                       ims , ime , jms , jme , kms , kme , &
+                                                                       ips , ipe , jps , jpe , kps , kpe )
+            END IF
    
          END IF
 
diff --git a/wrfv2_fire/main/real_nmm.F b/wrfv2_fire/main/real_nmm.F
index 6f786a71..4fe42fe4 100644
--- a/wrfv2_fire/main/real_nmm.F
+++ b/wrfv2_fire/main/real_nmm.F
@@ -269,7 +269,6 @@ END SUBROUTINE start_domain
 
 #include "deref_kludge.h"
 
-
    grid%input_from_file = .true.
    grid%input_from_file = .false.
 
@@ -380,8 +379,6 @@ END SUBROUTINE start_domain
       CALL wrf_debug ( 100 , 'med_sidata_input: calling optional_input' )
 !
       CALL optional_input ( grid , idsi , config_flags )
-	write(mess,*) 'maxval st_input(1) within real_nmm: ', maxval(st_input(:,1,:))
-        call wrf_message(mess)
       END IF
 !
       CALL close_dataset ( idsi , config_flags , "DATASET=AUXINPUT1" )
diff --git a/wrfv2_fire/phys/Makefile b/wrfv2_fire/phys/Makefile
index f8ce9442..c5ffe640 100644
--- a/wrfv2_fire/phys/Makefile
+++ b/wrfv2_fire/phys/Makefile
@@ -40,6 +40,7 @@ MODULES = \
 	module_bl_qnsepbl09.o \
 	module_bl_acm.o \
 	module_bl_mynn.o \
+	module_bl_fogdes.o \
 	module_bl_gwdo.o \
 	module_bl_myjurb.o \
 	module_bl_boulac.o \
@@ -61,6 +62,7 @@ MODULES = \
 	module_cu_gf.o \
 	module_cu_nsas.o \
 	module_cu_sas.o \
+	module_cu_mesosas.o \
 	module_cu_osas.o \
 	module_mp_radar.o \
 	module_mp_kessler.o \
@@ -73,6 +75,8 @@ MODULES = \
         module_mp_etaold.o \
 	module_mp_HWRF.o \
 	module_mp_thompson.o \
+	module_mp_full_sbm.o \
+	module_mp_fast_sbm.o \
 	module_mp_gsfcgce.o \
 	module_mp_morr_two_moment.o \
 	module_mp_milbrandt2mom.o \
@@ -93,6 +97,7 @@ MODULES = \
         module_ra_flg.o \
 	module_ra_HWRF.o \
 	module_ra_hs.o  \
+	module_ra_aerosol.o  \
 	module_sf_sfclay.o \
 	module_sf_sfclayrev.o \
 	module_sf_gfs.o \
@@ -105,6 +110,7 @@ MODULES = \
 	module_sf_noah_seaice.o \
 	module_sf_noah_seaice_drv.o \
 	module_sf_noahlsm_glacial_only.o \
+        module_sf_noahmp_groundwater.o \
 	module_sf_noahmpdrv.o \
 	module_sf_noahmplsm.o \
 	module_sf_noahmp_glacier.o \
@@ -125,6 +131,7 @@ MODULES = \
 	module_sf_myjsfc.o \
 	module_sf_qnsesfc.o \
 	module_sf_mynn.o \
+	module_sf_fogdes.o \
 	module_sf_pxsfclay.o \
 	module_sf_temfsfclay.o \
 	module_sf_idealscmsfclay.o \
@@ -145,7 +152,6 @@ MODULES = \
 	module_mixactivate.o \
 	module_radiation_driver.o \
 	module_surface_driver.o \
-	module_diagnostics.o \
 	module_lightning_driver.o \
 	module_ltng_cpmpr92z.o \
 	module_ltng_crmpr92.o \
@@ -155,8 +161,9 @@ MODULES = \
 	module_fddagd_driver.o  \
         module_fddaobs_rtfdda.o \
 	module_fddaobs_driver.o \
-	module_wind_generic.o \
-	module_wind_fitch.o
+	module_wind_fitch.o \
+        module_sf_lake.o \
+	module_diagnostics_driver.o
 
 FIRE_MODULES = \
         module_fr_fire_driver.o \
@@ -167,6 +174,15 @@ FIRE_MODULES = \
         module_fr_fire_phys.o \
         module_fr_fire_util.o
   
+DIAGNOSTIC_MODULES_EM = \
+	module_diag_afwa.o \
+	module_diag_cl.o \
+	module_diag_misc.o \
+	module_diag_pld.o
+  
+DIAGNOSTIC_MODULES_NMM = \
+	module_diag_refl.o
+
 OBJS    =
 
 NMM_MODULES =  
@@ -176,18 +192,22 @@ TARGETDIR    =  ./
 
 $(LIBTARGET) :
 		if [ $(WRF_NMM_CORE) -eq 1 ] ; then \
-                  $(MAKE) $(J) nmm_contrib                                      ; \
-                  $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) $(NMM_OBJS) $(NMM_MODULES) ; \
+                  $(MAKE) $(J) nmm_contrib  ; \
+                  $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) \
+                                   $(NMM_OBJS) $(NMM_MODULES) \
+                                   $(DIAGNOSTIC_MODULES_NMM) ; \
                 else                                                         \
-                  $(MAKE) $(J) non_nmm                                          ; \
-                  $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(FIRE_MODULES) $(OBJS)             ; \
+                  $(MAKE) $(J) non_nmm      ; \
+                  $(AR) $(ARFLAGS) ../main/$(LIBWRFLIB) $(MODULES) $(OBJS) \
+                                   $(FIRE_MODULES) \
+                                   $(DIAGNOSTIC_MODULES_EM)  ; \
                 fi
 
 include ../configure.wrf
 
-nmm_contrib : $(NMM_OBJS) $(NMM_MODULES) $(MODULES) $(OBJS)
+nmm_contrib : $(NMM_OBJS) $(NMM_MODULES) $(MODULES) $(OBJS) $(DIAGNOSTIC_MODULES_NMM)
 
-non_nmm : $(MODULES) $(FIRE_MODULES) $(WIND_MODULES) $(OBJS)
+non_nmm : $(MODULES) $(FIRE_MODULES) $(WIND_MODULES) $(OBJS) $(DIAGNOSTIC_MODULES_EM)
 
 clean:
 	@ echo 'use the clean script'
diff --git a/wrfv2_fire/phys/module_bl_acm.F b/wrfv2_fire/phys/module_bl_acm.F
index 5ecc255a..ed0a2ffc 100755
--- a/wrfv2_fire/phys/module_bl_acm.F
+++ b/wrfv2_fire/phys/module_bl_acm.F
@@ -14,10 +14,14 @@ MODULE module_bl_acm
    SUBROUTINE ACMPBL(XTIME,    DTPBL,    ZNW,   SIGMAH,               &
                      U3D,      V3D,      PP3D,  DZ8W, TH3D, T3D,      &
                      QV3D,     QC3D,     QI3D,  RR3D,                 &
+#if (WRF_CHEM == 1)
+                     CHEM3D,   VD3D,     NCHEM,                       &  ! For WRF-Chem
+                     KDVEL, NDVEL, NUM_VERT_MIX,                      &  ! For WRF-Chem
+#endif
                      UST,      HFX,      QFX,   TSK,                  &
                      PSFC,     EP1,      G,                           &
                      ROVCP,    RD,       CPD,                         &
-                     PBLH,     KPBL2D,   REGIME,                      &
+                     PBLH,     KPBL2D,   EXCH_H, REGIME,              &
                      GZ1OZ0,   WSPD,     PSIM, MUT,                   &
                      RUBLTEN,  RVBLTEN,  RTHBLTEN,                    &
                      RQVBLTEN, RQCBLTEN, RQIBLTEN,                    &
@@ -43,6 +47,7 @@ SUBROUTINE ACMPBL(XTIME,    DTPBL,    ZNW,   SIGMAH,               &
 !     AX        3/2005   - developed WRF version based on the MM5 PX LSM
 !     RG and JP 7/2006   - Finished WRF adaptation
 !     JP 12/2011 12/2011 - ACM2 modified so it's not dependent on first layer thickness. 
+!     JP        3/2013   - WRFChem version. Mixing of chemical species are added
 !
 !**********************************************************************
 !   ARGUMENT LIST:
@@ -62,6 +67,9 @@ SUBROUTINE ACMPBL(XTIME,    DTPBL,    ZNW,   SIGMAH,               &
 !-- QC3D            3D cloud mixing ratio (Kg/Kg)
 !-- QI3D            3D ice mixing ratio (Kg/Kg)
 !-- RR3D            3D dry air density (kg/m^3)
+!-- CHEM3D          Chemical species mixing ratios (ppm)  Optional for WRFChem   
+!-- VD3D            Dry deposition velocity (m/s)         Optional for WRFChem
+!-- NCHEM           Number of chemical species            Optional for WRFChem
 !-- UST             Friction Velocity (m/s)
 !-- HFX		    Upward heat flux at the surface (w/m^2)
 !-- QFX		    Upward moisture flux at the surface (Kg/m^2/s)
@@ -137,17 +145,33 @@ SUBROUTINE ACMPBL(XTIME,    DTPBL,    ZNW,   SIGMAH,               &
                                                         RTHBLTEN, RQVBLTEN,  &
                                                         RQCBLTEN, RQIBLTEN
 
+   real,     dimension( ims:ime, kms:kme, jms:jme ),                         &
+             intent(inout)   ::                         exch_h
+
     INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(OUT  ) ::  KPBL2D
 
+ 
+#if (WRF_CHEM == 1)
+!... Chem
+    INTEGER, INTENT(IN   )   ::   nchem, kdvel, ndvel, num_vert_mix
+    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme, nchem ), INTENT(INOUT) :: CHEM3D
+    REAL,    DIMENSION( ims:ime, kdvel, jms:jme, ndvel ), INTENT(IN) :: VD3D
+#endif
 !... Local Variables
 
 !... Integer
-      INTEGER :: J, K
+      INTEGER :: I, J, K, L
 !... Real
       REAL, DIMENSION( kts:kte ) :: DSIGH, DSIGHI, DSIGFI
       REAL, DIMENSION( 0:kte )   :: SIGMAF
       REAL  RDT
       REAL, PARAMETER :: KARMAN = 0.4
+
+#if (WRF_CHEM == 1)
+!... Chem
+    REAL,    DIMENSION( ims:ime, kms:kme, nchem ) :: CHEM2D
+    REAL,    DIMENSION( ims:ime, kdvel, ndvel ) :: VD2D
+#endif
 !...
 
    RDT = 1.0 / DTPBL
@@ -168,13 +192,37 @@ SUBROUTINE ACMPBL(XTIME,    DTPBL,    ZNW,   SIGMAH,               &
 
    DSIGFI(kte) = DSIGFI(kte-1)
    
-   DO j = jts,jte
+   DO j = jts,jte   
+#if (WRF_CHEM == 1)
+      DO L = 1, nchem
+      DO K = kms,kme
+      DO I = ims, ime
+        CHEM2D(i,k,l) = chem3d(i,k,j,l)
+      ENDDO
+      ENDDO
+      ENDDO
+
+      DO L = 1, ndvel
+      DO K = 1, kdvel
+      DO I = ims, ime
+        VD2D(i,k,l) = VD3D(i,k,j,l)
+      ENDDO
+      ENDDO
+      ENDDO
+#endif
       CALL ACM2D(j=J,xtime=XTIME, dtpbl=DTPBL, sigmaf=SIGMAF, sigmah=SIGMAH    &
               ,dsigfi=DSIGFI,dsighi=DSIGHI,dsigh=DSIGH             &
               ,us=u3d(ims,kms,j),vs=v3d(ims,kms,j)                 &
               ,theta=th3d(ims,kms,j),tt=t3d(ims,kms,j)             &
               ,qvs=qv3d(ims,kms,j),qcs=qc3d(ims,kms,j)             &
-              ,qis=qi3d(ims,kms,j),dzf=DZ8W(ims,kms,j)             &
+              ,qis=qi3d(ims,kms,j)                                 &
+#if (WRF_CHEM == 1)
+              ,chem=chem2d                                         &
+              ,vd=vd2d                                             &
+              ,nchem=nchem,kdvel=kdvel,ndvel=ndvel                 &
+              ,num_vert_mix=num_vert_mix                           &
+#endif
+              ,dzf=DZ8W(ims,kms,j)                                 &
               ,densx=RR3D(ims,kms,j)                               &
               ,utnp=rublten(ims,kms,j),vtnp=rvblten(ims,kms,j)     &
               ,ttnp=rthblten(ims,kms,j),qvtnp=rqvblten(ims,kms,j)  &
@@ -182,6 +230,7 @@ SUBROUTINE ACMPBL(XTIME,    DTPBL,    ZNW,   SIGMAH,               &
               ,cpd=cpd,g=g,rovcp=rovcp,rd=rd,rdt=rdt               &
               ,psfcpa=psfc(ims,j),ust=ust(ims,j)                   &
               ,pbl=pblh(ims,j)                                     &
+              ,exch_hx=exch_h(ims,kms,j)                           &
               ,regime=regime(ims,j),psim=psim(ims,j)               &
               ,hfx=hfx(ims,j),qfx=qfx(ims,j)                       &
               ,tg=tsk(ims,j),gz1oz0=gz1oz0(ims,j)                  &
@@ -191,6 +240,13 @@ SUBROUTINE ACMPBL(XTIME,    DTPBL,    ZNW,   SIGMAH,               &
               ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde   &
               ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme   &
               ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte   )
+#if (WRF_CHEM == 1)
+      DO L = 1, nchem
+      DO I = ims, ime
+        chem3d(i,kms:kme,j,l) = CHEM2D(i,kms:kme,l)
+      ENDDO
+      ENDDO
+#endif
    ENDDO
 
    END SUBROUTINE ACMPBL
@@ -203,9 +259,13 @@ END SUBROUTINE ACMPBL
    SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah          &
               ,dsigfi,dsighi,dsigh                          &
               ,us,vs,theta,tt,qvs,qcs,qis                   &
+#if (WRF_CHEM == 1)
+              ,chem,  vd, nchem, kdvel, ndvel               &
+              ,num_vert_mix                                 &
+#endif
               ,dzf,densx,utnp,vtnp,ttnp,qvtnp,qctnp,qitnp   &
               ,cpd,g,rovcp,rd,rdt,psfcpa,ust                &
-              ,pbl,regime,psim                              &
+              ,pbl,exch_hx,regime,psim                      &
               ,hfx,qfx,tg,gz1oz0,wspd ,klpbl                &
               ,mut                                          &
               ,ep1,karman                                   &
@@ -241,13 +301,20 @@ SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah          &
       real,     dimension( ims:ime ), intent(in)      ::   wspd, psim, gz1oz0
       real,     dimension( ims:ime ), intent(in)      ::   hfx, qfx
       real,     dimension( ims:ime ), intent(in)      ::   mut
-
+      real,     dimension( ims:ime, kms:kme ),                    &
+                intent(inout)                         ::   exch_hx
 !... Integer
       INTEGER, DIMENSION( ims:ime ),       INTENT(OUT):: KLPBL
       INTEGER,  INTENT(IN)      ::      XTIME
       integer,  intent(in   )   ::      ids,ide, jds,jde, kds,kde, &
                                         ims,ime, jms,jme, kms,kme, &
                                         its,ite, jts,jte, kts,kte, j
+#if (WRF_CHEM == 1)
+!....Chem
+      INTEGER,  INTENT(IN)      ::      NCHEM, KDVEL,NDVEL,NUM_VERT_MIX
+      REAL , DIMENSION( ims:ime, kms:kme, NCHEM ), INTENT(INOUT)  :: CHEM
+      REAL , DIMENSION( ims:ime, KDVEL, NDVEL ), INTENT(IN)  :: VD
+#endif
 !--------------------------------------------------------------------
 !--Local 
       INTEGER I, K     
@@ -266,13 +333,13 @@ SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah          &
       REAL,    DIMENSION( its:ite )          :: PBLSIG, MOL
       REAL    ::  FINTT, ZMIX, UMIX, VMIX
       REAL    ::  TMPFX, TMPVTCON, TMPP, TMPTHS, TMPTH1, TMPVCONV, WS1, DTH
-	REAL    ::  A,TST12,RL,ZFUNC
+	REAL    ::  A,TST12,RL,ZFUNC,DENSF
 !    REAL, PARAMETER :: KARMAN = 0.4
 
 !... Integer
       INTEGER :: KL, jtf, ktf, itf, KMIX, KSRC
 !...
-        character*256 :: message
+        character*512 :: message
 !-----initialize vertical tendencies and
 
       DO i = its,ite
@@ -444,10 +511,23 @@ SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah          &
                  TST, QST,  USTM,   EDDYZ,  DENSX,                  &
                  US,    VS,     THETA,  QVS,    QCS,    QIS,        &
                  UX,    VX,     THETAX, QVX,    QCX,    QIX,        &
+#if (WRF_CHEM == 1)
+                 CHEM,  VD,  NCHEM, KDVEL, NDVEL,NUM_VERT_MIX,      &
+#endif
                  ids,ide, jds,jde, kds,kde,                         &
                  ims,ime, jms,jme, kms,kme,                         &
                  its,ite, jts,jte, kts,kte)
 
+!.. Load exch_h for use in CCN activation
+
+     DO K = kts, kte-1
+       DO I = its, ite
+         DENSF     = 0.5 * (DENSX(I,K+1) + DENSX(I,K))
+         exch_hx(I,K) = EDDYZ(I,K) /( (DENSF * G / PSTAR(I)) ** 2 *  &
+                       DTPBL * DSIGFI(K)*1E-6 )
+       ENDDO
+     ENDDO
+
 !... Calculate tendency due to PBL parameterization
 
      DO K = kts, kte
@@ -718,6 +798,10 @@ SUBROUTINE ACM (DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, JX, &
                    TST, QST,  USTM,   EDDYZ,  DENSX,               &
                    US,    VS,     THETA,  QVS,    QCS,    QIS,     &
                    UX,    VX,     THETAX, QVX,    QCX,    QIX,     &
+#if (WRF_CHEM == 1)
+                   CHEM,  VD, NCHEM, KDVEL, NDVEL,                 &
+                   NUM_VERT_MIX,                                   &
+#endif
                    ids,ide, jds,jde, kds,kde,                      &
                    ims,ime, jms,jme, kms,kme,                      &
                    its,ite, jts,jte, kts,kte)
@@ -728,6 +812,7 @@ SUBROUTINE ACM (DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, JX, &
 !---- REVISION HISTORY:
 !   AX     3/2005 - developed WRF version based on ACM2 in the MM5 PX LSM
 !   JP and RG 8/2006 - updates
+!   JP     3/2013 - Chem additions
 !
 !**********************************************************************
 !  ARGUMENTS:
@@ -760,6 +845,9 @@ SUBROUTINE ACM (DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, JX, &
 !-- QVX             new water vapor mixing ratio (Kg/Kg)
 !-- QCX             new cloud mixing ratio (Kg/Kg)
 !-- QIX             new ice mixing ratio (Kg/Kg)
+!-- CHEM            Chemical species mixing ratios (ppm)  WRFChem   
+!-- VD              Dry deposition velocity (m/s)         WRFChem
+!-- NCHEM           Number of chemical species            WRFChem
 !-----------------------------------------------------------------------
 !-----------------------------------------------------------------------
 
@@ -787,10 +875,16 @@ SUBROUTINE ACM (DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, JX, &
                                                            QVS, QCS, QIS, DENSX
       REAL , DIMENSION( its:ite, kts:kte ), INTENT(OUT) :: UX, VX, THETAX,      &
                                                            QVX, QCX, QIX
+#if (WRF_CHEM == 1)
+!......Chem
+      INTEGER,  INTENT(IN)      ::   NCHEM, KDVEL, NDVEL, NUM_VERT_MIX
+      REAL , DIMENSION( ims:ime, kms:kme, nchem ), INTENT(INOUT)  :: CHEM   
+      REAL , DIMENSION( ims:ime, KDVEL, NDVEL ), INTENT(IN)  :: VD
+#endif
 !.......Local variables
 
 !... Parameters
-      INTEGER, PARAMETER :: NSP   = 6
+      INTEGER, PARAMETER :: NSP   = 6 
 !
 !......ACM2 Parameters
 !     INTEGER, PARAMETER :: IFACM = 0
@@ -800,7 +894,7 @@ SUBROUTINE ACM (DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, JX, &
       REAL,    PARAMETER :: KARMAN = 0.4
 
 !... Integer
-      INTEGER :: ILX, KL, KLM, I, K, NSPX, NLP, NL, JJ, L
+      INTEGER :: ILX, KL, KLM, I, K, NSPX, NLP, NL, JJ, L,LL
       INTEGER :: KCBLMX
       INTEGER, DIMENSION( its:ite ) :: KCBL
 
@@ -809,23 +903,35 @@ SUBROUTINE ACM (DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, JX, &
       REAL                               :: EKZ, RZ, FM, WSPD, DTS, DTRAT, F1
       REAL, DIMENSION( its:ite )         :: PSTARI, FSACM, DTLIM
       REAL, DIMENSION( kts:kte, its:ite) :: MBARKS, MDWN
-      REAL, DIMENSION( 1:NSP, its:ite )  :: FS, BCBOTN
       REAL, DIMENSION( kts:kte )         :: XPLUS, XMINUS
       REAL  DELC
-      REAL, DIMENSION( 1:NSP,its:ite,kts:kte  ) :: VCI
+      REAL, DIMENSION( kts:kte )                :: AI, BI, CI, EI !, Y
+      REAL, ALLOCATABLE, DIMENSION( : , : )     :: DI, UI    
+      REAL, ALLOCATABLE, DIMENSION( : , : )     :: FS, BCBOTN
+      REAL, ALLOCATABLE, DIMENSION( : , : , : ) :: VCI
+
+      CHARACTER*80 :: message
 
-      REAL, DIMENSION( kts:kte )               :: AI, BI, CI, EI !, Y
-      REAL, DIMENSION( 1:NSP,kts:kte )         :: DI, UI    
 !
 !--Start Exicutable ----
 
       ILX = ite
       KL  = kte
       KLM = kte - 1
+      NSPX = NSP
+#if (WRF_CHEM == 1)
+      NSPX = NSPX + NUM_VERT_MIX 
+#endif
 
       G1000I = 1.0 / G1000
       KCBLMX = 0
       MBMAX  = 0.0
+!...Allocate species variables
+      ALLOCATE (DI( 1:NSPX,kts:kte ))       
+      ALLOCATE (UI( 1:NSPX,kts:kte ))  
+      ALLOCATE (FS( 1:NSPX, its:ite ))
+      ALLOCATE (BCBOTN( 1:NSPX, its:ite ))  
+      ALLOCATE (VCI( 1:NSPX,its:ite,kts:kte  ))
 
 !---COMPUTE ACM MIXING RATE
       DO I = its, ILX
@@ -883,11 +989,14 @@ SUBROUTINE ACM (DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, JX, &
           ! IF (IMOISTX.NE.1.AND.IMOISTX.NE.3) THEN  !!! Check other PBL models
           VCI(5,I,K) = QCS(I,K)
           VCI(6,I,K) = QIS(I,K)
+#if (WRF_CHEM == 1)
+          DO L= 7, NSPX
+             VCI(L,I,K) = CHEM(I,K,L-NSP)
+          ENDDO
+#endif
         ENDDO
       ENDDO
 
-      NSPX=6
-
       DO I = its,ILX
         FS(1,I) = -UST(I) * TST(I) * DENSX(I,1) * PSTARI(I)
         FS(2,I) = -UST(I) * QST(I) * DENSX(I,1) * PSTARI(I)
@@ -897,6 +1006,11 @@ SUBROUTINE ACM (DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, JX, &
         FS(4,I) = FM * VS(I,1) / WSPD
         FS(5,I) = 0.0
         FS(6,I) = 0.0                      ! SURFACE FLUXES OF CLOUD WATER AND ICE = 0
+#if (WRF_CHEM == 1)
+        DO L= 7, NSPX
+          FS(L,I) = -VD(I,1,L-NSP) * CHEM(I,1,L-NSP) * DENSX(I,1) * PSTARI(I)
+        ENDDO
+#endif
       ENDDO
 !
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -909,7 +1023,7 @@ SUBROUTINE ACM (DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, JX, &
 
 !-- COMPUTE ARRAY ELEMENTS THAT ARE INDEPENDANT OF SPECIES
 
-          DO K = kts,KL
+          DO K = kts,kte
             AI(K) = 0.0
             BI(K) = 0.0
             CI(K) = 0.0
@@ -1025,16 +1139,22 @@ SUBROUTINE ACM (DTPBL, PSTAR,  NOCONV, SIGMAF, DSIGH, DSIGHI, JX, &
           QVX(I,K)    = VCI(2,I,K)
           UX(I,K)     = VCI(3,I,K)
           VX(I,K)     = VCI(4,I,K)
-        ENDDO
+          QCX(I,K)    = VCI(5,I,K)
+          QIX(I,K)    = VCI(6,I,K)
+#if (WRF_CHEM == 1)
+          DO LL= 7, NSPX
+             CHEM(I,K,LL-NSP) = VCI(LL,I,K) 
+          ENDDO
+#endif
       ENDDO
-
-      DO K = kts,KL
-        DO I = its,ILX
-          QCX(I,K) = VCI(5,I,K)
-          QIX(I,K) = VCI(6,I,K)
-        ENDDO
       ENDDO
 
+      DEALLOCATE (DI)       
+      DEALLOCATE (UI)  
+      DEALLOCATE (FS)
+      DEALLOCATE (BCBOTN)  
+      DEALLOCATE (VCI)
+
    END SUBROUTINE ACM
 !-----------------------------------------------------------------------
 !-----------------------------------------------------------------------
diff --git a/wrfv2_fire/phys/module_bl_camuwpbl_driver.F b/wrfv2_fire/phys/module_bl_camuwpbl_driver.F
index 48830d40..5709184f 100755
--- a/wrfv2_fire/phys/module_bl_camuwpbl_driver.F
+++ b/wrfv2_fire/phys/module_bl_camuwpbl_driver.F
@@ -953,7 +953,9 @@ subroutine camuwpblinit(rublten,rvblten,rthblten,rqvblten, &
     
     select case ( eddy_scheme )
     case ( 'diag_TKE' ) 
-       if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme: UW Moist Turbulence Scheme by Bretherton and Park'
+       if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme'
+       call wrf_debug(1,iulog)
+       if( masterproc ) write(iulog,*) 'UW Moist Turbulence Scheme by Bretherton and Park'
        call wrf_debug(1,iulog)
        !! Check compatibility of eddy and shallow scheme
        if( shallow_scheme .ne. 'UW' ) then
diff --git a/wrfv2_fire/phys/module_bl_fogdes.F b/wrfv2_fire/phys/module_bl_fogdes.F
new file mode 100644
index 00000000..2a193e3e
--- /dev/null
+++ b/wrfv2_fire/phys/module_bl_fogdes.F
@@ -0,0 +1,164 @@
+MODULE module_bl_fogdes
+
+  USE module_model_constants
+  USE module_bl_mynn, only: qcgmin, gno, gpw
+
+!-------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------
+
+CONTAINS
+
+  SUBROUTINE bl_fogdes(&
+               vdfg,qc_curr,dtbl,rho,dz8w,grav_settling,dqc,       &
+               ids,ide, jds,jde, kds,kde,                          &
+               ims,ime, jms,jme, kms,kme,                          &
+               its,ite, jts,jte, kts,kte                           &
+                                                                   )
+
+!  This module was written by Joseph Olson (CIRES-NOAA/GSD/AMB) to allow
+!  gravitational settling of cloud droplets in the atmosphere for all 
+!  PBL schemes (when grav_settling > 0). Previously, this option was only 
+!  available for the MYNN PBL scheme.
+!
+!  This module is a companion to module_sf_fogdes, which calulcates the 
+!  (fog) deposition onto the surface, so it uses a consistent formulation
+!  at k=1. Currently, it uses a simple form taken from Dyunkerke (1991)
+!  and Dyunkerke and Driedonks (1988), but uses a lower settling 
+!  velocity coefficient (gno = 1.0 instead of 4.6).
+!
+!    settling velocity:            Vd = gno*(qc)**(2/3)
+!    cloud water flux:  gflux = Vd*qc = gno*(qc)**(5/3)
+!
+!  This form assumes a constant number concentration: 10**8 /m**3 for
+!  gno = 4.6 and approx .2*10**8 /m**3 for gno = 1.0.
+!
+! References:
+!
+! Dyunkerke, P.G. (1991), Radiation fog: a comparison of model simulations
+!     with detailed observations, Mon. Wea. Rev., 119, 324-341.
+! Nakanishi, Mikio (2000), Large-eddy simulation of radiation fog,
+!     Boundary Layer Meteorology, 94, 461-493. 
+!
+!======================================================================
+! Definitions
+!-----------
+!-- vdfg          deposition velocity of fog (m/s)
+!-- qc_curr       cloud water mixing ratio (kg/kg)
+!-- dqc           cloud water mixing ratio tendency
+!-- dtbl          timestep (s)
+!-- rho           density of the air (kg/m^3)
+!-- dp_fog        mean fog droplet diameter (m)
+!-- dz8w          dz between full levels (m)
+!-- grav_settling flag for fog deposition at the lowest atmos layer
+!           = 2   FogDES scheme
+!           = 1   use Duynkerke (1991) - same as in atmos (above k = 1)
+!           = 0   No gravitational settling
+!-- lwc           cloud liquid water content (kg/m^3)
+!-- ims           start index for i in memory
+!-- ime           end index for i in memory
+!-- jms           start index for j in memory
+!-- jme           end index for j in memory
+!-- kms           start index for k in memory
+!-- kme           end index for k in memory
+!-- its           start index for i in tile
+!-- ite           end index for i in tile
+!-- jts           start index for j in tile
+!-- jte           end index for j in tile
+!-- kts           start index for k in tile
+!-- kte           end index for k in tile
+!******************************************************************
+!------------------------------------------------------------------
+
+   INTEGER, INTENT(IN)                       :: ims,ime,jms,jme,kms,kme &
+                                               ,its,ite,jts,jte,kts,kte &
+                                               ,ids,ide,jds,jde,kds,kde
+
+   INTEGER, INTENT(IN)                       :: grav_settling
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                        &
+                                       INTENT(IN),OPTIONAL    :: qc_curr
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                        &
+                                       INTENT(IN)             :: rho
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                        &
+                                       INTENT(IN   )          :: dz8w
+
+   REAL, DIMENSION( ims:ime, jms:jme ),INTENT(IN),OPTIONAL    :: vdfg
+
+   REAL, INTENT(INOUT),OPTIONAL                               :: dtbl
+
+!JOE-added for Dyunkerke(1991) & Dyunkerke and Driedonks (1988)
+!    gravitational settling above the surface (creates qc tendency).
+   REAL,parameter :: gpw2=0.66666666666667
+   REAL :: gfluxp,gfluxm
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                        &
+                                       INTENT(INOUT),OPTIONAL :: dqc
+!JOE-end
+
+! Local variables
+   INTEGER :: i,j,k,grav_settling2
+!------------------------------------------------------------------
+
+  grav_settling2 = MIN(REAL(grav_settling), 1.)
+
+   DO j=jts,jte
+     DO i=its,ite
+
+       !!====================================================
+       !! Calculate gravitational settling in the atmosphere.
+       !! This uses Dyunkerke (referenced above). Note that 
+       !! only the cloud mixing ratio is settled, not the
+       !! number concentration. 
+       !!====================================================
+
+       k=kts
+
+       IF (qc_curr(i,k,j) > qcgmin) THEN
+          gfluxm=grav_settling2*qc_curr(i,k,j)*vdfg(i,j)
+       ELSE
+          gfluxm=0.
+       ENDIF
+
+       IF (.5*(qc_curr(i,k+1,j)+qc_curr(i,k,j)) > qcgmin) THEN
+          gfluxp=grav_settling2*gno* &
+                & (.5*(qc_curr(i,k+1,j)+qc_curr(i,k,j)))**gpw
+       ELSE
+          gfluxp=0.
+       ENDIF
+
+       dqc(i,k,j)=dqc(i,k,j) + (gfluxp - gfluxm)/dz8w(i,kts,j)    !*dtbl
+
+       !print*,"in bl_fogdes: i,j=",i,j
+       !print*,"vdfg=",vdfg(i,j)," qc=",qc_curr(i,k,j)," dtbl=",dtbl
+       !print*,"dqc=",dqc(i,k,j)," gfluxm=",gfluxm," gfluxp=",gfluxp
+
+       DO k=kts+1,kte-1
+
+          IF (.5*(qc_curr(i,k+1,j)+qc_curr(i,k,j)) > qcgmin) THEN
+             gfluxp=grav_settling2*gno* &
+                   & (.5*(qc_curr(i,k+1,j)+qc_curr(i,k,j)))**gpw
+          ELSE
+             gfluxp=0.
+          ENDIF
+
+          IF (.5*(qc_curr(i,k-1,j)+qc_curr(i,k,j)) > qcgmin) THEN
+             gfluxm=grav_settling2*gno* &
+                   & (.5*(qc_curr(i,k-1,j)+qc_curr(i,k,j)))**gpw
+          ELSE
+             gfluxm=0.
+          ENDIF
+
+          dqc(i,k,j)= dqc(i,k,j) + (gfluxp - gfluxm)/dz8w(i,k,j)  !*dtbl
+
+       ENDDO
+
+      ! dqc(i,kte,j)=0.
+
+     ENDDO
+   ENDDO
+
+  END SUBROUTINE bl_fogdes
+
+! ==================================================================
+
+END MODULE module_bl_fogdes
diff --git a/wrfv2_fire/phys/module_bl_gbmpbl.F b/wrfv2_fire/phys/module_bl_gbmpbl.F
index dea1c600..49affc86 100644
--- a/wrfv2_fire/phys/module_bl_gbmpbl.F
+++ b/wrfv2_fire/phys/module_bl_gbmpbl.F
@@ -896,7 +896,7 @@ subroutine pblhgt( &
     iconv = 0
     istabl = 1
     do k=2,kte+1   !nt nscquar is defined at kte+1 after the call to n2
-       if(nsquar(k).lt.0)then   
+       if(nsquar(k).le.0)then   
           if(istabl.eq.1)then
              iconv = iconv + 1
              ktop(iconv)=k
@@ -947,20 +947,22 @@ subroutine pblhgt( &
                                            ! then average rnnll is very small and a very weak 
                                            ! pos n2 is enough to be 'inversion' top. This makes
                                            ! sure that we go up at least one more.
-          if(ilay.gt.1.and.ktop(ilay).eq.kbot(ilay-1))then ! did we merge with layer above?
-             ibeg = ilay - 1
-!NT orig     ktop(ibeg)=ktop(ibeg)+1 !NT not correct if one up was not inversion, the new thicker
-                                     !NT layer might have different average properties, should
-                                     !NT reset to original ktop
-             ktop(ibeg)=ktop_save(ibeg) !NT new
-             kbot(ibeg)=kbot(ibeg+1)
-             iconv = iconv - 1
-             do itemp = ibeg+1,iconv !NT if there's a layer below decrease layer index
-                ktop(itemp)=ktop(itemp+1)
-                kbot(itemp)=kbot(itemp+1)
-                ktop_save(itemp)=ktop_save(itemp+1) !NT new
-             enddo
-             goto 2745        ! recompute for the new, deeper layer
+          if(ilay.gt.1) then
+             if(ktop(ilay).eq.kbot(ilay-1))then ! did we merge with layer above?
+                ibeg = ilay - 1
+   !NT orig     ktop(ibeg)=ktop(ibeg)+1 !NT not correct if one up was not inversion, the new thicker
+                                        !NT layer might have different average properties, should
+                                        !NT reset to original ktop
+                ktop(ibeg)=ktop_save(ibeg) !NT new
+                kbot(ibeg)=kbot(ibeg+1)
+                iconv = iconv - 1
+                do itemp = ibeg+1,iconv !NT if there's a layer below decrease layer index
+                   ktop(itemp)=ktop(itemp+1)
+                   kbot(itemp)=kbot(itemp+1)
+                   ktop_save(itemp)=ktop_save(itemp+1) !NT new
+                enddo
+                goto 2745        ! recompute for the new, deeper layer
+             endif
           endif
           rnnll = rnnll + trnnll
           nlev = nlev + 1 !NT moved up
diff --git a/wrfv2_fire/phys/module_bl_gfs.F b/wrfv2_fire/phys/module_bl_gfs.F
index ae6fb61d..14407726 100755
--- a/wrfv2_fire/phys/module_bl_gfs.F
+++ b/wrfv2_fire/phys/module_bl_gfs.F
@@ -19,6 +19,9 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
 #if (HWRF==1)
                   ALPHA,                                           &
                   HPBL2D, EVAP2D, HEAT2D,                          &    !Kwon add FOR SHAL. CON.
+                  VAR_RIC,                                         &    !Kwon for variable Ric
+                  U10,V10,ZNT,MZNT,rc2d,                           &    !Kwon for variable Ric
+                  DKU3D,DKT3D,coef_ric_l,coef_ric_s,xland,         &    !Kwon for variable Ric
 #endif
                   ids,ide, jds,jde, kds,kde,                       &
                   ims,ime, jms,jme, kms,kme,                       &
@@ -74,6 +77,8 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
 !-- EP1         constant for virtual temperature (R_v/R_d - 1) (dimensionless)
 !-- KARMAN      Von Karman constant
 !-- ALPHA       boundary depth scaling factor
+!-- VAR_RIC     Flag for using variable Ric or not (=1: variable Ric, =0: constant Ric)
+!-- RO          Surface Rossby number
 !-- ids         start index for i in domain
 !-- ide         end index for i in domain
 !-- jds         start index for j in domain
@@ -102,10 +107,17 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
       REAL,  DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::              &
                                         HPBL2D,                         &    !ADDED BY KWON FOR SHALLOW CONV.
                                         EVAP2D,                         &    !ADDED BY KWON FOR SHALLOW CONV.
-                                        HEAT2D                               !ADDED BY KWON FOR SHALLOW CONV.
+                                        HEAT2D,RC2D,MZNT                     !ADDED BY KWON FOR SHALLOW CONV.
+      REAL,  DIMENSION(ims:ime, jms:jme), INTENT(IN) ::              &
+                                        U10,                         &    !ADDED BY KWON FOR VARIABLE Ric
+                                        V10,XLAND,                   &    !ADDED BY KWON FOR VARIABLE Ric
+                                        ZNT                               !ADDED BY KWON FOR VARIABLE Ric
+      REAL,  DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(OUT) :: DKU3D,DKT3D  
+      REAL,    INTENT(IN) :: VAR_RIC,coef_ric_l,coef_ric_s                   !ADDED BY KWON
 #endif
 
 
+
       INTEGER, INTENT(IN) ::            ids,ide, jds,jde, kds,kde,      &
                                         ims,ime, jms,jme, kms,kme,      &
                                         its,ite, jts,jte, kts,kte,      &
@@ -175,6 +187,9 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
                                         T1,                             &
                                         TAU,                            &
                                         dishx,                          &
+#if (HWRF==1)
+                                        dku,dkt,   &       !Kwon for diffusivity
+#endif
                                         U1,                             &
                                         V1
 
@@ -202,8 +217,10 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
                                         QSS,                            &
                                         RBSOIL,                         &
                                         RCL,                            &
+                                        XLAND1,                         &
                                         SPD1,                           &
                                         STRESS,                         &
+                                        RO,rbcr,                        &  !Kwon for variablr Ric(surface Rossby number)
                                         TSEA
 
       REAL     (kind=kind_phys) ::                                      &
@@ -256,10 +273,12 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
         QSS(i)=QV3D(i,kts,j)               ! not used in moninp so set to qv3d for now
         HEAT(i)=HFX(i,j)/CPM*RRHOX
         EVAP(i)=QFX(i,j)*RRHOX
+        XLAND1(i) = 0.0        
 #if (HWRF==1)
 ! Kwon FOR NEW SHALLOW CONVECTION 
         HEAT2D(i,j)=HFX(i,j)/CPM*RRHOX
         EVAP2D(i,j)=QFX(i,j)*RRHOX
+        XLAND1(i) = XLAND(I,J)
 #endif
 !
         STRESS(i)=KARMAN*KARMAN*WSPD(i,j)*WSPD(i,j)/(FMTMP*FMTMP)
@@ -268,6 +287,10 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
         PHII(I,kts)=0.
         RCL(i)=1.
         RBSOIL(I)=BR(i,j)
+#if (HWRF==1)
+! Kwon for variable Ric   : Ro=W10/(f*zo): surface Rossby number
+       Ro(I)=SQRT(U10(I,J)**2 + V10(I,J)**2) / (1.E-4 * MZNT(I,J))
+#endif
       ENDDO
 
       DO k=kts,kte
@@ -323,12 +346,15 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
           ENDDO
         ENDDO
       ENDDO
-
+!
       CALL MONINP(IM,IM,KX,NTRAC,DV,DU,TAU,RTG,U1,V1,T1,Q1,             &
                   PSK,RBSOIL,FM,FH,TSEA,QSS,HEAT,EVAP,STRESS,           &
                   SPD1,KPBL,PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCL,          &
-                  DELTIM,DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,HGAMQ,      &
-                  ALPHA)
+                  DELTIM,DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,            &
+#if (HWRF==1)
+               VAR_RIC,Ro,DKU,DKT,coef_ric_l,coef_ric_s,xland1,  &
+#endif
+                RBCR,HGAMQ,ALPHA)
 
 !============================================================================
 !    ADD  IN  DISSIPATIVE HEATING .... v*dv. This is Bob's doing
@@ -378,10 +404,29 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
 #if (HWRF==1)
 !Kwon For new shallow convection
         HPBL2D(i,j)=HPBL(i)
+        rc2D(i,j)=rbcr(i)
 #endif
 !
         KPBL2D(i,j)=kpbl(i)
       ENDDO
+! INITIALIZE DKU3D and DKT3D  (3D momentum and thermal diffusivity for
+! diagnostics)
+!
+#if (HWRF==1)
+     DO i=its,ite
+     DO k=kts,kte
+      DKU3D(I,J,K) = 0.
+      DKT3D(I,J,K) = 0.
+     ENDDO
+     ENDDO
+
+     DO i=its,ite
+     DO k=kts,kte-1
+      DKU3D(I,J,K) = DKU(I,K)
+      DKT3D(I,J,K) = DKT(I,K)
+     ENDDO
+     ENDDO
+#endif
 
     ENDDO
 
@@ -460,9 +505,12 @@ END SUBROUTINE gfsinit
       SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG,                   &
      &     U1,V1,T1,Q1,                                                 &
      &     PSK,RBSOIL,FM,FH,TSEA,QSS,HEAT,EVAP,STRESS,SPD1,KPBL,        &
-!    &     PSK,RBSOIL,CD,CH,FM,FH,TSEA,QSS,DPHI,SPD1,KPBL,              &
      &     PRSI,DEL,PRSL,PRSLK,PHII,PHIL,RCL,DELTIM,                    &
-     &     DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,HGAMQ,ALPHA)
+     &     DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT,                     &
+#if (HWRF==1)
+           VAR_RIC,Ro,DKU,DKT,coef_ric_l,coef_ric_s,xland1,   &
+#endif
+           RBCR,HGAMQ,ALPHA)
 !
       USE MODULE_GFS_MACHINE, ONLY : kind_phys
       USE MODULE_GFS_PHYSCONS, grav => con_g, RD => con_RD, CP => con_CP &
@@ -479,6 +527,10 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG,                   &
 !
       real(kind=kind_phys) DELTIM
       real :: ALPHA
+
+#if (HWRF==1)
+      real :: VAR_RIC,coef_ric_l,coef_ric_s
+#endif
       real(kind=kind_phys) DV(IM,KM),     DU(IM,KM),                    &
      &                     TAU(IM,KM),    RTG(IM,KM,ntrac),             &
      &                     U1(IX,KM),     V1(IX,KM),                    &
@@ -495,7 +547,10 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG,                   &
      &                     RCL(IM),       DUSFC(IM),                    &
      &                     dvsfc(IM),     dtsfc(IM),                    & 
      &                     DQSFC(IM),     HPBL(IM),                     &
-     &                     HGAMT(IM),     hgamq(IM)
+     &                     HGAMT(IM),     hgamq(IM), RBCR(IM)
+#if (HWRF==1)
+real(kind=kind_phys) RO(IM),xland1(IM)
+#endif
 !
 !    Locals
 !
@@ -510,11 +565,11 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG,                   &
 !
       real(kind=kind_phys) RDZT(IM,KM-1),                               &
      &                     ZI(IM,KM+1),     ZL(IM,KM),                  &
-     &                     DKU(IM,KM-1),    DKT(IM,KM-1), DKO(IM,KM-1), &
+     &                     DKO(IM,KM-1),                                &
      &                     AL(IM,KM-1),     AD(IM,KM),                  &
      &                     AU(IM,KM-1),     A1(IM,KM),                  &
      &                     A2(IM,KM),       THETA(IM,KM),               &
-     &                     AT(IM,KM*(ntrac-1))
+     &                     AT(IM,KM*(ntrac-1)),DKU(IM,KM-1),DKT(IM,KM-1)
       logical              pblflg(IM),   sfcflg(IM), stable(IM)
 !
       real(kind=kind_phys) aphi16,  aphi5,  bet1,   bvf2,               &
@@ -525,7 +580,7 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG,                   &
      &                     dtodsu,  dw2,    dw2min, g,                  &
      &                     gamcrq,  gamcrt, gocp,   gor, gravi,         &
      &                     hol,     pfac,   prmax,  prmin, prinv,       &
-     &                     prnum,   qmin,   qtend,  rbcr,               & 
+     &                     prnum,   qmin,   qtend,                      & 
      &                     rbint,   rdt,    rdz,    rdzt1,              &
      &                     ri,      rimin,  rl2,    rlam,               &
      &                     rone,   rzero,  sfcfrac,                     &
@@ -540,7 +595,7 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG,                   &
       PARAMETER(CONT=1000.*CP/G,CONQ=1000.*HVAP/G,CONW=1000./G)
       PARAMETER(RLAM=150.,VK=0.4,VK2=VK*VK,PRMIN=1.0,PRMAX=4.)
       PARAMETER(DW2MIN=0.0001,DKMIN=1.0,DKMAX=1000.,RIMIN=-100.)
-      PARAMETER(RBCR=0.25,CFAC=7.8,PFAC=2.0,SFCFRAC=0.1)
+      PARAMETER(CFAC=7.8,PFAC=2.0,SFCFRAC=0.1)
       PARAMETER(QMIN=1.E-8,XKZO=1.0,ZFMIN=1.E-8,APHI5=5.,APHI16=16.)
 !     PARAMETER(GAMCRT=3.,GAMCRQ=2.E-3)
       PARAMETER(GAMCRT=3.,GAMCRQ=0.)
@@ -579,6 +634,23 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG,                   &
 !!!   LATD = 0
       LOND = 0
       ENDIF
+!
+! define critical Richardson number    by KWON: Vickers and Mahart(2004) J. Appl. Meteo.
+!  coef_ric=0.16 originally but it may too small: controled by namelist=0.25
+!  Land and Ocean points are treated differently
+!  by Kwon
+!
+     do i=1,im
+     RBCR(I) = 0.25
+#if (HWRF==1)
+     IF(var_ric.eq.1.) THEN             
+      IF(xland1(i).eq.1)  RBCR(I) = coef_ric_l*(1.E-7*Ro(I))**(-0.18)
+      IF(xland1(i).eq.2)  RBCR(I) = coef_ric_s*(1.E-7*Ro(I))**(-0.18)
+!      write(0,*) 'xland1 coef_ric_l coef_ric_s ',xland1(i),coef_ric_l,coef_ric_s
+     ENDIF
+     IF(RBCR(I).GT.0.5) RBCR(I)=0.5    !set upper limit Suggsted by Han
+#endif
+     enddo
 !
       gravi = 1.0 / grav
       DT    = 2. * DELTIM
@@ -663,19 +735,19 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG,                   &
              SPDK2 = MAX(RCL(i)*(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)),RONE)
              RBUP(I)   = (THEKV(I)-THE1V(I))*(G*ZL(I,k)/THE1V(I))/SPDK2
              KPBL(I)   = K
-             STABLE(I) = RBUP(I).GT.RBCR
+             STABLE(I) = RBUP(I).GT.RBCR(I)
           ENDIF
         ENDDO
       ENDDO
 !
       DO I = 1,IM
          K = KPBL(I)
-         IF(RBDN(I).GE.RBCR) THEN
+         IF(RBDN(I).GE.RBCR(I)) THEN
             RBINT = 0.
-         ELSEIF(RBUP(I).LE.RBCR) THEN
+         ELSEIF(RBUP(I).LE.RBCR(I)) THEN
             RBINT = 1.
          ELSE
-            RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I))
+            RBINT = (RBCR(I)-RBDN(I))/(RBUP(I)-RBDN(I))
          ENDIF
          HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,K)-ZL(I,K-1))
          IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1
@@ -749,7 +821,7 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG,                   &
             SPDK2   = MAX(RCL(i)*(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)),RONE)
             RBUP(I)   = (THEKV(I)-THERMAL(I))*(G*ZL(I,k)/THE1V(I))/SPDK2
             KPBL(I)   = K
-            STABLE(I) = RBUP(I).GT.RBCR
+            STABLE(I) = RBUP(I).GT.RBCR(I)
           ENDIF
         ENDDO
       ENDDO
@@ -757,12 +829,12 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG,                   &
       DO I = 1,IM
          IF(PBLFLG(I)) THEN
             K = KPBL(I)
-            IF(RBDN(I).GE.RBCR) THEN
+            IF(RBDN(I).GE.RBCR(I)) THEN
                RBINT = 0.
-            ELSEIF(RBUP(I).LE.RBCR) THEN
+            ELSEIF(RBUP(I).LE.RBCR(I)) THEN
                RBINT = 1.
             ELSE
-               RBINT = (RBCR-RBDN(I))/(RBUP(I)-RBDN(I))
+               RBINT = (RBCR(I)-RBDN(I))/(RBUP(I)-RBDN(I))
             ENDIF
             HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,k)-ZL(I,K-1))
             IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1
@@ -855,6 +927,7 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG,                   &
             ENDIF
          ENDDO
       ENDDO
+
 !
 !     COMPUTE TRIDIAGONAL MATRIX ELEMENTS FOR HEAT AND MOISTURE
 !
diff --git a/wrfv2_fire/phys/module_bl_mynn.F b/wrfv2_fire/phys/module_bl_mynn.F
index 09440986..03f6e85c 100644
--- a/wrfv2_fire/phys/module_bl_mynn.F
+++ b/wrfv2_fire/phys/module_bl_mynn.F
@@ -10,15 +10,19 @@
 !            intent etc)
 !-------------------------------------------------------------------
 !Modifications implemented by Joseph Olson NOAA/GSD/AMB - CU/CIRES
-!(approved by Mikio Nakanishi):
+!(approved by Mikio Nakanishi or under consideration):
 ! 1. Addition of BouLac mixing length in the free atmosphere.
 ! 2. Changed the turbulent mixing length to be integrated from the
 !    surface to the top of the BL + a transition layer depth.
-! 3. Option to use Kitamura/Canuto modification which removes the
-!    critical Richardson number and negative TKE (default).
-! 4. Hybrid PBL height diagnostic, which blends a theta-v-based
+! 3. v3.4.1: Option to use Kitamura/Canuto modification which removes 
+!    the critical Richardson number and negative TKE (default).
+! 4. v3.4.1: Hybrid PBL height diagnostic, which blends a theta-v-based
 !    definition in neutral/convective BL and a TKE-based definition
 !    in stable conditions.
+! 5. v3.4.1: TKE budget output option (bl_mynn_tkebudget)
+! 6. v3.5.0: TKE advection option (bl_mynn_tkeadvect)
+! 7. v3.5.1: Fog deposition related changes.
+!
 ! For changes 1 and 3, see "JOE's mods" below:
 !-------------------------------------------------------------------
 
@@ -26,9 +30,11 @@ MODULE module_bl_mynn
 
   USE module_model_constants, only: &
        &karman, g, p1000mb, &
-       &cp, r_d, rcp, xlv, &
+       &cp, r_d, rcp, xlv, xlf,&
        &svp1, svp2, svp3, svpt0, ep_1, ep_2
 
+  USE module_state_description, only: param_first_scalar, &
+       &p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni
 !-------------------------------------------------------------------
   IMPLICIT NONE
 !-------------------------------------------------------------------
@@ -37,8 +43,8 @@ MODULE module_bl_mynn
   REAL, PARAMETER :: cphm_st=5.0, cphm_unst=16.0, &
                      cphh_st=5.0, cphh_unst=16.0
 
-  REAL, PARAMETER :: xlvcp=xlv/cp, ev=xlv, rd=r_d, rk=cp/rd, &
-       &svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2
+  REAL, PARAMETER :: xlvcp=xlv/cp, xlscp=(xlv+xlf)/cp, ev=xlv, rd=r_d, &
+       &rk=cp/rd, svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2
 
   REAL, PARAMETER :: tref=300.0    ! reference temperature (K)
   REAL, PARAMETER :: tv0=p608*tref, tv1=(1.+p608)*tref, gtr=g/tref
@@ -47,7 +53,7 @@ MODULE module_bl_mynn
   REAL, PARAMETER :: &
        &vk  = karman, &
        &pr  =  0.74, &
-       &g1  =  0.235, &
+       &g1  =  0.229, &  ! NN2009 = 0.235
        &b1  = 24.0, &
        &b2  = 15.0, &    ! CKmod     NN2009
        &c2  =  0.729, &  ! 0.729, & !0.75, &
@@ -69,17 +75,23 @@ MODULE module_bl_mynn
        &e4c = 12.0*a1*a2*cc2, &
        &e5c =  6.0*a1*a1
 
-! Constants for length scale
+! Constants for length scale (alps & cns) and TKE diffusion (Sqfac)
+! Original (Nakanishi and Niino 2009) (for CKmod=0.):
+!  REAL, PARAMETER :: qmin=0.0, zmax=1.0, cns=2.7, & 
+!           &alp1=0.23, alp2=1.0, alp3=5.0, alp4=100.0, &
+!           &alp5=0.40, Sqfac=3.0
+! Modified for Rapid Refresh/HRRR (and for CKmod=1.):
   REAL, PARAMETER :: qmin=0.0, zmax=1.0, cns=2.1, &
-       !NN2009: &alp1=0.23, alp2=1.0, alp3=5.0, alp4=100.0, Sqfac=3.0
-                &alp1=0.23, alp2=0.60, alp3=3.0, alp4=20.0, Sqfac=2.0
+            &alp1=0.23, alp2=0.65, alp3=3.0, alp4=20.0, &
+            &alp5=1.0, Sqfac=2.0
 
 ! Constants for gravitational settling
 !  REAL, PARAMETER :: gno=1.e6/(1.e8)**(2./3.), gpw=5./3., qcgmin=1.e-8
-  REAL, PARAMETER :: gno=4.64158883361278196
-  REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8,qkemin=1.e-12
+  REAL, PARAMETER :: gno=1.0  !original value seems too agressive: 4.64158883361278196
+  REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12
 !  REAL, PARAMETER :: pblh_ref=1500.
 
+! Constants for cloud PDF (mym_condensation)
   REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423
 
 !JOE's mods
@@ -96,10 +108,15 @@ MODULE module_bl_mynn
   !Use BouLac mixing length in free atmosphere (1:yes, 0:no)
   !This helps remove excessively large mixing in unstable layers aloft.
   REAL, PARAMETER :: BLmod=1.
+
+  !Mix couds (water & ice): (0: no, 1: yes)                                                                
+  REAL, PARAMETER :: Cloudmix=0.
 !JOE-end
 
   INTEGER :: mynn_level
 
+  INTEGER, PARAMETER :: kdebug=27
+
 CONTAINS
 
 ! **********************************************************************
@@ -237,8 +254,9 @@ SUBROUTINE  mym_initialize ( kts,kte,&
 !       &            ust, rmo, pmz, phh, flt, flq,&
 !JOE-BouLac/PBLH mod
        &        zi,theta,&
+       &        sh,&
 !JOE-end
-       &            ust, rmo, &
+       &            ust, rmo, el,&
        &            Qke, Tsq, Qsq, Cov)
 !
 !-------------------------------------------------------------------
@@ -250,11 +268,11 @@ SUBROUTINE  mym_initialize ( kts,kte,&
     REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw
     REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw
 
-    REAL, DIMENSION(kts:kte), INTENT(out) :: qke,tsq,qsq,cov
-
+    REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov
+    REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke
 
     REAL, DIMENSION(kts:kte) :: &
-         &ql,el,pdk,pdt,pdq,pdc,dtl,dqw,dtv,&
+         &ql,pdk,pdt,pdq,pdc,dtl,dqw,dtv,&
          &gm,gh,sm,sh,qkw,vt,vq
     INTEGER :: k,l,lmax
     REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq
@@ -299,7 +317,7 @@ SUBROUTINE  mym_initialize ( kts,kte,&
 !
 !   **  Initialization with an iterative manner          **
 !   **  lmax is the iteration count. This is arbitrary.  **
-    lmax = 5  !!kte +3
+    lmax = 5 
 !
     DO l = 1,lmax
 !
@@ -501,6 +519,9 @@ END SUBROUTINE mym_level2
 !       elt(mx,ny)      : Length scale depending on the PBL depth    (m)
 !       vsc(mx,ny)      : Velocity scale q_c                       (m/s)
 !                         at first, used for computing elt
+!
+!     NOTE: the mixing lengths are meant to be calculated at the full-
+!           sigmal levels (or interfaces beween the model layers).
 !
   SUBROUTINE  mym_length ( kts,kte,&
     &            dz, zw, &
@@ -509,27 +530,25 @@ SUBROUTINE  mym_length ( kts,kte,&
     &            qke, &
     &            dtv, &
     &            el, &
-!JOE-added for BouLac ML (PBLH)
-    &            zi,theta,&
-!JOE-end
+    &            zi,theta,&       !JOE-BouLac mod
     &            qkw)
     
 !-------------------------------------------------------------------
 
     INTEGER, INTENT(IN)   :: kts,kte
-    REAL, DIMENSION(kts:kte), INTENT(in) :: dz
+    REAL, DIMENSION(kts:kte), INTENT(in)   :: dz
     REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw
     REAL, INTENT(in) :: rmo,flt,flq
-    REAL, DIMENSION(kts:kte), INTENT(IN) :: qke,vt,vq
+    REAL, DIMENSION(kts:kte), INTENT(IN)   :: qke,vt,vq
 
-    REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el
-    REAL, DIMENSION(kts:kte), INTENT(in) :: dtv
+    REAL, DIMENSION(kts:kte), INTENT(out)  :: qkw, el
+    REAL, DIMENSION(kts:kte), INTENT(in)   :: dtv
 
     REAL :: elt,vsc
 !JOE-added for BouLac ML
     REAL, DIMENSION(kts:kte), INTENT(IN) :: theta
-    REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg
-    REAL :: wt,zi,zi2,elt0,h1,h2
+    REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw
+    REAL :: wt,zi,zi2,h1,h2
 
     !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH.
     !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH 
@@ -540,6 +559,12 @@ SUBROUTINE  mym_length ( kts,kte,&
                                      !=0.3*2500 m PBLH, so the transition
                                      !layer stops growing for PBLHs > 2.5 km.
     REAL, PARAMETER :: mindz = 300.  !min (half) transition layer depth
+
+    !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER
+    REAL, PARAMETER :: ZSLH = 100. ! Max height correlated to surface conditions (m)
+    REAL, PARAMETER :: CSL = 2.    ! CSL = constant of proportionality to L O(1)
+    REAL :: z_m
+
 !Joe-end
 
     INTEGER :: i,j,k
@@ -550,23 +575,28 @@ SUBROUTINE  mym_length ( kts,kte,&
 !
 !JOE-added to impose limits on the height integration for elt as well 
 !    as the transition layer depth
-    zi2=MAX(zi,minzi)
+    IF ( BLmod .EQ. 0. ) THEN
+       zi2=5000.  !originally integrated to model top, not just 5000 m.
+    ELSE
+       zi2=MAX(zi,minzi)
+    ENDIF
     h1=MAX(0.3*zi2,mindz)
     h1=MIN(h1,maxdz)         ! 1/2 transition layer depth
     h2=h1/2.0                ! 1/4 transition layer depth
-!Joe-end
-!JOE-added for BouLac ML
-    qtke(kts)=MAX(qke(kts)/2.,0.01)
+
+    qtke(kts)=MAX(qke(kts)/2.,0.01) !tke at full sigma levels
+    thetaw(kts)=theta(kts)          !theta at full-sigma levels
 !JOE-end
+    qkw(kts) = SQRT(MAX(qke(kts),1.0e-10))
 
     DO k = kts+1,kte
        afk = dz(k)/( dz(k)+dz(k-1) )
        abk = 1.0 -afk
-       qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*&
-            &afk,1.0e-10))
+       qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3))
 
 !JOE- BouLac Start 
-       qtke(k) = MAX(qke(k)/2.,0.001)
+       qtke(k) = (qkw(k)**2.)/2.    ! q -> TKE
+       thetaw(k)= theta(k)*abk + theta(k-1)*afk
 !JOE- BouLac End
 
     END DO
@@ -581,9 +611,9 @@ SUBROUTINE  mym_length ( kts,kte,&
 !
      k = kts+1
      zwk = zw(k)
-     DO WHILE (zwk .LE. (zi2+h1)) 
+     DO WHILE (zwk .LE. MIN((zi2+h1), 4000.)) !JOE: 20130523 reduce too high diffusivity over mts 
        dzk = 0.5*( dz(k)+dz(k-1) )
-       qdz = MAX( qkw(k)-qmin, 0.02 )*dzk
+       qdz = MAX( qkw(k)-qmin, 0.03 )*dzk
              elt = elt +qdz*zwk
              vsc = vsc +qdz
        k   = k+1
@@ -600,23 +630,12 @@ SUBROUTINE  mym_length ( kts,kte,&
 !JOE- BouLac Start
     IF ( BLmod .GT. 0. ) THEN
        ! COMPUTE BouLac mixing length
-       CALL boulac_length(kts,kte,zw,dz,qtke,theta,elBLmin,elBLavg)
+       CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg)
     ENDIF
 !JOE- BouLac END
 
     DO k = kts+1,kte
-       zwk = zw(k)
-
-!JOE- BouLac Start - add blending to only use elt in the boundary
-!     layer and use the BouLac mixing length in free atmos 
-!     [defined relative to the PBLH (zi) + transition layer (h1)].
-      IF ( BLmod .GT. 0. ) THEN
-         wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
-         elt0=elt*(1.-wt) + elBLavg(k)*wt
-      ELSE
-         elt0=elt
-      ENDIF
-!JOE- BouLac END
+       zwk = zw(k)              !full-sigma levels
 
 !   **  Length scale limited by the buoyancy effect  **
        IF ( dtv(k) .GT. 0.0 ) THEN
@@ -631,31 +650,39 @@ SUBROUTINE  mym_length ( kts,kte,&
           elf = elb
        END IF
 !
-!JOE- BouLac Start - only use BL ML in free atmos.
-      IF ( BLmod .GT. 0. ) THEN
-         wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
-         elb=elb*(1.-wt) + elBLmin(k)*wt
-         !TEST: turn off mixing aloft  
-         !elb=elb*(1.-wt) + 0.01*wt
-      ENDIF
-!!JOE- BouLac END
+       z_m = MAX(ZSLH,CSL*zwk*rmo)
 
 !   **  Length scale in the surface layer  **
        IF ( rmo .GT. 0.0 ) THEN
-          els =  vk*zwk &
-               &        /( 1.0 + cns*MIN( zwk*rmo, zmax ) )
+       !   IF ( zwk <= z_m ) THEN  ! use original cns
+             els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax ))
+             !els = vk*zwk/(1.0+cns*MIN( 0.5*zw(kts+1)*rmo, zmax ))
+       !   ELSE
+       !      !blend to neutral values (kz) above z_m
+       !      els = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + vk*(zwk - z_m)
+       !   ENDIF
        ELSE
-          els =  vk*zwk &
-               &  *( 1.0 - alp4*    zwk*rmo         )**0.2
+          els =  vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2
        END IF
 !
-
-!JOE- BouLac Start 
+!   ** HARMONC AVERGING OF MIXING LENGTH SCALES: 
 !       el(k) =      MIN(elb/( elb/elt+elb/els+1.0 ),elf)
-       el(k) =      MIN(elb/( elb/elt0+elb/els+1.0 ),elf)
 !       el(k) =      elb/( elb/elt+elb/els+1.0 )
+!JOE- BouLac Start
+       IF ( BLmod .EQ. 0. ) THEN
+          el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf)
+       ELSE
+          !add blending to use BouLac mixing length in free atmos;
+          !defined relative to the PBLH (zi) + transition layer (h1)
+          el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf)
+          wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
+          el(k) = el(k)*(1.-wt) + alp5*elBLmin(k)*wt
+       ENDIF
 !JOE- BouLac End
 
+       !IF (el(k) > 1000.) THEN
+       !   print*,"SUSPICIOUSLY LARGE Lm:",el(k),k
+       !ENDIF
     END DO
 !
     RETURN
@@ -690,7 +717,7 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2)
      !LOCAL VARS
      INTEGER :: iz, izz, found
      REAL, DIMENSION(kts:kte) :: dlu,dld
-     !REAL, PARAMETER :: g=9.81
+     REAL, PARAMETER :: Lmax=2000.  !soft limit
      REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz
 
      !print*,"IN MYNN-BouLac",kts, kte
@@ -706,22 +733,25 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2)
         zup_inf=0.
         beta=g/theta(iz)           !Buoyancy coefficient
 
+        !print*,"FINDING Dup, k=",iz," zw=",zw(iz)
+
         if (iz .lt. kte) then      !cant integrate upwards from highest level
 
-          !do izz=iz,kte-1         !integrate upwards to find dlu
           found = 0
           izz=iz       
           DO WHILE (found .EQ. 0) 
 
             if (izz .lt. kte) then
-              dzt=(dz(izz+1)+dz(izz))/2.    ! avg layer depth of above and below layer 
-              zup=zup-beta*theta(iz)*dzt    ! initial PE the parcel has at iz
-              !print*,"  ",iz,izz,theta(izz)
+              dzt=dz(izz)                    ! layer depth above 
+              zup=zup-beta*theta(iz)*dzt     ! initial PE the parcel has at iz
+              !print*,"  ",iz,izz,theta(izz),dz(izz)
               zup=zup+beta*(theta(izz+1)+theta(izz))*dzt/2. ! PE gained by lifting a parcel to izz+1
               zzz=zzz+dzt                   ! depth of layer iz to izz+1
+              !print*,"  PE=",zup," TKE=",qtke(iz)," z=",zw(izz)
               if (qtke(iz).lt.zup .and. qtke(iz).ge.zup_inf) then
                  bbb=(theta(izz+1)-theta(izz))/dzt
                  if (bbb .ne. 0.) then
+                    !fractional distance up into the layer where TKE becomes < PE
                     tl=(-beta*(theta(izz)-theta(iz)) + &
                       & sqrt( max(0.,(beta*(theta(izz)-theta(iz)))**2. + &
                       &       2.*bbb*beta*(qtke(iz)-zup_inf))))/bbb/beta
@@ -733,7 +763,8 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2)
                     endif
                  endif            
                  dlu(iz)=zzz-dzt+tl
-                 found = 1
+                 !print*,"  FOUND Dup:",dlu(iz)," z=",zw(izz)," tl=",tl
+                 found =1
               endif
               zup_inf=zup
               izz=izz+1
@@ -750,21 +781,23 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2)
         !----------------------------------
         zdo=0.
         zdo_sup=0.
-        dld(iz)=zw(iz)+dz(iz)/2.
+        dld(iz)=zw(iz)
         zzz=0.
 
+        !print*,"FINDING Ddown, k=",iz," zwk=",zw(iz)
         if (iz .gt. kts) then  !cant integrate downwards from lowest level
 
-          !do izz=iz,kts+1,-1  !integrate downwards to find dld
           found = 0
           izz=iz       
           DO WHILE (found .EQ. 0) 
- 
+
             if (izz .gt. kts) then
-              dzt=(dz(izz-1)+dz(izz))/2.
+              dzt=dz(izz-1)
               zdo=zdo+beta*theta(iz)*dzt
+              !print*,"  ",iz,izz,theta(izz),dz(izz-1)
               zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt/2.
               zzz=zzz+dzt
+              !print*,"  PE=",zdo," TKE=",qtke(iz)," z=",zw(izz)
               if (qtke(iz).lt.zdo .and. qtke(iz).ge.zdo_sup) then
                  bbb=(theta(izz)-theta(izz-1))/dzt
                  if (bbb .ne. 0.) then
@@ -779,6 +812,7 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2)
                     endif
                  endif            
                  dld(iz)=zzz-dzt+tl
+                 !print*,"  FOUND Ddown:",dld(iz)," z=",zw(izz)," tl=",tl
                  found = 1
               endif
               zdo_sup=zdo
@@ -795,11 +829,15 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2)
         !----------------------------------
         !The surface layer length scale can exceed z for large z/L,
         !so keep maximum distance down > z.
-        dld(iz) = min(dld(iz),zw(iz+1))
+        dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos
         lb1(iz) = min(dlu(iz),dld(iz))     !minimum
         lb2(iz) = sqrt(dlu(iz)*dld(iz))    !average - biased towards smallest
         !lb2(iz) = 0.5*(dlu(iz)+dld(iz))   !average
 
+        !Apply soft limit (only impacts very large lb; lb=100 by 5%, lb=500 by 20%).
+        lb1(iz) = lb1(iz)/(1. + (lb1(iz)/Lmax))
+        lb2(iz) = lb2(iz)/(1. + (lb2(iz)/Lmax))
+ 
         if (iz .eq. kte) then
            lb1(kte) = lb1(kte-1)
            lb2(kte) = lb2(kte-1)
@@ -854,12 +892,13 @@ SUBROUTINE  mym_turbulence ( kts,kte,&
     &            rmo, flt, flq, &
 !JOE-BouLac/PBLH test
     &            zi,theta,&
+    &            sh,&
 !JOE-end
     &            El,&
     &            Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc &
 !JOE-TKE BUDGET
-    &		 ,qWT1D,qSHEAR1D,qBUOY1D,qDISS1D, &
-    &            bl_mynn_tkebudget &
+    &		 ,qWT1D,qSHEAR1D,qBUOY1D,qDISS1D &
+    &            ,bl_mynn_tkebudget &
 !JOE-end
     &)
 
@@ -896,9 +935,8 @@ SUBROUTINE  mym_turbulence ( kts,kte,&
     REAL :: zi
     REAL, DIMENSION(kts:kte), INTENT(in) :: theta
 !JOE-end
-!JOE-Canuto/Kitamura mod
-    REAL ::  a2den, duz, ri
-!JOE-end
+
+    REAL ::  a2den, duz, ri, HLmod  !JOE-Canuto/Kitamura mod
 
     DOUBLE PRECISION  q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel
     DOUBLE PRECISION  q3sq, t3sq, r3sq, c3sq, dlsq, qdiv
@@ -929,9 +967,7 @@ SUBROUTINE  mym_turbulence ( kts,kte,&
     &            qke, &
     &            dtv, &
     &            el, &
-!JOE BouLac/PBLH test
-    &            zi,theta,&
-!JOE-end
+    &            zi,theta,&  !JOE-hybrid PBLH
     &            qkw)
 !
 
@@ -960,9 +996,26 @@ SUBROUTINE  mym_turbulence ( kts,kte,&
        ghel = gh (k)*elsq
 !  Modified: Dec/22/2005, up to here
 !
+!JOE-add prints
+       IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN
+          PRINT*,"MYM_TURBULENCE2.0: k=",k," sh=",sh(k)
+          PRINT*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k)
+          PRINT*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq
+          PRINT*," qke=",qke(k)," el=",el(k)," ri=",ri
+          PRINT*," PBLH=",zi," u=",u(k)," v=",v(k)
+       ENDIF
+!JOE-Apply Helfand & Labraga stability check for all Ric
+!    when CKmod == 1. Suggested by Kitamura. Not applied below.
+       IF (CKmod .eq. 1) THEN
+          HLmod = q2sq -1.
+       ELSE
+          HLmod = q3sq
+       ENDIF
 !     **  Since qkw is set to more than 0.0, q3sq > 0.0.  **
        IF ( q3sq .LT. q2sq ) THEN
-          qdiv = SQRT( q3sq/q2sq )
+!       IF ( HLmod .LT. q2sq ) THEN
+!JOE-END
+          qdiv = SQRT( q3sq/q2sq )   !HL89: (1-alfa)
           sm(k) = sm(k) * qdiv
           sh(k) = sh(k) * qdiv
 !
@@ -1000,6 +1053,16 @@ SUBROUTINE  mym_turbulence ( kts,kte,&
 !JOE-end
        END IF
 !
+!      HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20
+       IF (sh(k)<0.0 .OR. sm(k)<0.0 .OR. &
+           sh(k) > 0.76*b2 .or. (sm(k)**2*gm(k) .gt. .44**2)) THEN
+          PRINT*,"MYM_TURBULENCE2.5: k=",k," sh=",sh(k)
+          PRINT*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k)
+          PRINT*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq
+          PRINT*," qke=",qke(k)," el=",el(k)," ri=",ri
+          PRINT*," PBLH=",zi," u=",u(k)," v=",v(k)
+       ENDIF
+
 !   **  Level 3 : start  **
        IF ( levflag .EQ. 3 ) THEN
           t2sq = qdiv*b2*elsq*sh(k)*dtl(k)**2
@@ -1091,17 +1154,25 @@ SUBROUTINE  mym_turbulence ( kts,kte,&
 
 !JOE-Canuto/Kitamura mod
 !          smd  = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2
-          smd  = dlsq*enum*gtr/eden * qdiv**2 * (e3c/(a2den**2) + e4c/a2den)*a1/(a2/a2den)
+          smd  = dlsq*enum*gtr/eden * qdiv**2 * (e3c/(a2den**2) + &
+               & e4c/a2den)*a1/(a2/a2den)
 !JOE-end
           gamv = e1  *enum*gtr/eden
 !
-
           sm(k) = sm(k) +smd
 !
 !     **  For elh (see below), qdiv at Level 3 is reset to 1.0.  **
           qdiv = 1.0
 !   **  Level 3 : end  **
 !
+          IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN
+            PRINT*,"MYM_TURBULENCE3.0: k=",k," sh=",sh(k)
+            PRINT*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k)
+            PRINT*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq
+            PRINT*," qke=",qke(k)," el=",el(k)," ri=",ri
+            PRINT*," PBLH=",zi," u=",u(k)," v=",v(k)
+          ENDIF
+
        ELSE
 !     **  At Level 2.5, qdiv is not reset.  **
           gamt = 0.0
@@ -1112,8 +1183,8 @@ SUBROUTINE  mym_turbulence ( kts,kte,&
        elq = el(k)*qkw(k)
        elh = elq*qdiv
 !
-       pdk(k) = elq*( sm(k)*gm (k) &
-            &                    +sh(k)*gh (k)+gamv )
+       pdk(k) = elq*( sm(k)*gm(k) &
+            &                    +sh(k)*gh(k)+gamv )
        pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k)
        pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k)
        pdc(k) = elh*( sh(k)*dtl(k)+gamt )&
@@ -1505,7 +1576,7 @@ END SUBROUTINE mym_predict
 !     SUBROUTINE  mym_condensation:
 !
 !     Input variables:    see subroutine mym_initialize and turbulence
-!       pi (mx,my,nz) : Perturbation of the Exner function    (J/kg K)
+!       exner(nz)    : Perturbation of the Exner function    (J/kg K)
 !                         defined on the walls of the grid boxes
 !                         This is usually computed by integrating
 !                         d(pi)/dz = h*g*tv/tref**2
@@ -1535,10 +1606,11 @@ SUBROUTINE  mym_condensation (kts,kte, &
     &            thl, qw, &
     &            p,exner, &
     &            tsq, qsq, cov, &
+    &            Sh, el, bl_mynn_cloudpdf,&  !JOE - cloud PDF testing
     &            Vt, Vq)
 
 !-------------------------------------------------------------------
-    INTEGER, INTENT(IN)   :: kts,kte
+    INTEGER, INTENT(IN)   :: kts,kte, bl_mynn_cloudpdf
 
     REAL, DIMENSION(kts:kte), INTENT(IN) :: dz
     REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, &
@@ -1557,6 +1629,10 @@ SUBROUTINE  mym_condensation (kts,kte, &
 
     REAL :: erf
 
+    !JOE: NEW VARIABLES FOR ALTERNATE SIGMA
+    REAL::dth,dqw,dzk
+    REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el
+
 ! Note: kte needs to be larger than kts, i.e., kte >= kts+1.
 
     DO k = kts,kte-1
@@ -1572,11 +1648,13 @@ SUBROUTINE  mym_condensation (kts,kte, &
 !x      end if
 !
 !   **  3.8 = 0.622*6.11 (hPa)  **
+       !SATURATED VAPOR PRESSURE
        esl=svp11*EXP(svp2*(t-svpt0)/(t-svp3))
+       !SATURATED SPECIFIC HUMIDITY
        qsl=ep_2*esl/(p(k)-ep_3*esl)
-!       qsl  = 3.8*EXP( a*ct/( b+ct ) ) / ( 1000.0*p2a**rk )
+       !dqw/dT: Clausius-Clapeyron
        dqsl = qsl*ep_2*ev/( rd*t**2 )
-!
+       !DEFICIT/EXCESS WATER CONTENT
        qmq(k) = qw(k) -qsl
 
        alp(k) = 1.0/( 1.0+dqsl*xlvcp )
@@ -1588,26 +1666,54 @@ SUBROUTINE  mym_condensation (kts,kte, &
        c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq )
 !
        r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq
-       sgm(k) = SQRT( MAX( r3sq, 1.0d-10 ) )
+       IF (bl_mynn_cloudpdf == 0) THEN
+          !ORIGINAL STANDARD DEVIATION: limit e-6 produces ~10% more BL clouds than e-10
+          sgm(k) = SQRT( MAX( r3sq, 1.0d-10 ))
+       ELSE
+          !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and 
+          ! Kuwano-Yoshida et al. 2010 QJRMS, eq. 7):
+          if (k .eq. kts) then 
+             dzk = 0.5*dz(k)
+          else
+             dzk = 0.5*( dz(k) + dz(k-1) )
+          end if
+          dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts)))
+          dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts)))
+          sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,1.) * &
+                             b2 * MAX(Sh(k),0.03))/4. * &
+                      (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) )
+       ENDIF
     END DO
 !
     DO k = kts,kte-1
+       !NORMALIZED DEPARTURE FROM SATURATION
        q1   = qmq(k) / sgm(k)
-       cld0 = 0.5*( 1.0+erf( q1*rr2 ) )
+       !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707
+       cld(k) = 0.5*( 1.0+erf( q1*rr2 ) )
+!       IF (cld(k) < 0. .OR. cld(k) > 1.) THEN
+!          PRINT*,"MYM_CONDENSATION, k=",k," cld=",cld(k)
+!          PRINT*," r3sq=",r3sq," t3sq=",t3sq," c3sq=",c3sq
+!       ENDIF
 !       q1=0.
-!       cld0=0.
+!       cld(k)=0.
 
+       !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and
+       !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989
        eq1  = rrp*EXP( -0.5*q1*q1 )
-       qll  = MAX( cld0*q1 + eq1, 0.0 )
-
-       cld(k) = cld0
+       qll  = MAX( cld(k)*q1 + eq1, 0.0 )
+       !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED)
        ql (k) = alp(k)*sgm(k)*qll
 !
-       q2p  = xlvcp/exner( k )
+       q2p  = xlvcp/exner(k) 
+       !POTENTIAL TEMPERATURE
        pt   = thl(k) +q2p*ql(k)
+       !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA)
        qt   = 1.0 +p608*qw(k) -(1.+p608)*ql(k)
-       rac  = alp(k)*( cld0-qll*eq1 )*( q2p*qt-(1.+p608)*pt )
-!
+       rac  = alp(k)*( cld(k)-qll*eq1 )*( q2p*qt-(1.+p608)*pt )
+
+       !BUOYANCY FACTORS: wherever vt and vq are used, there is a
+       !"+1" and "+tv0", respectively, so these are subtracted out here.
+       !vt is unitless and vq has units of K.
        vt (k) =      qt-1.0 -rac*bet(k)
        vq (k) = p608*pt-tv0 +rac
     END DO
@@ -1627,19 +1733,25 @@ SUBROUTINE mynn_tendencies(kts,kte,&
        &levflag,grav_settling,&
        &delt,&
        &dz,&
-       &u,v,th,qv,qc,p,exner,&
-       &thl,sqv,sqc,sqw,&
-       &ust,flt,flq,wspd,qcg,&
+       &u,v,th,qv,qc,qi,qni,& !qnc,&
+       &p,exner,&
+       &thl,sqv,sqc,sqi,sqw,&
+       &ust,flt,flq,flqv,flqc,wspd,qcg,&
+       &uoce,voce,&
        &tsq,qsq,cov,&
        &tcd,qcd,&
        &dfm,dfh,dfq,&
-       &Du,Dv,Dth,Dqv,Dqc)
+       &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqni&!,Dqnc&
+       &,vdfg1&               !Katata/JOE-fogdes
+       &,FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC &
+       &)
 
 !-------------------------------------------------------------------
     INTEGER, INTENT(in) :: kts,kte
     INTEGER, INTENT(in) :: grav_settling,levflag
+    LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC
 
-!! grav_settling = 1 for gravitational settling of droplets
+!! grav_settling = 1 or 2 for gravitational settling of droplets
 !! grav_settling = 0 otherwise
 ! thl - liquid water potential temperature
 ! qw - total water
@@ -1647,22 +1759,26 @@ SUBROUTINE mynn_tendencies(kts,kte,&
 ! flt - surface flux of thl
 ! flq - surface flux of qw
 
-    REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,qv,qc,p,exner,&
-         &dfm,dfh,dfq,dz,tsq,qsq,cov,tcd,qcd
-    REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc
-    REAL, DIMENSION(kts:kte), INTENT(out) :: du,dv,dth,dqv,dqc
-    REAL, INTENT(IN) :: delt,ust,flt,flq,wspd,qcg
+    REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,qv,qc,qi,qni,&!qnc,&
+         &p,exner,dfm,dfh,dfq,dz,tsq,qsq,cov,tcd,qcd
+    REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi
+    REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,&
+         &dqni!,dqnc
+    REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg
 
 !    REAL, INTENT(IN) :: delt,ust,flt,flq,qcg,&
 !         &gradu_top,gradv_top,gradth_top,gradqv_top
 
 !local vars
 
-    REAL, DIMENSION(kts:kte) :: dtz,vt,vq
+    REAL, DIMENSION(kts:kte) :: dtz,vt,vq,qni2!,qnc2
 
     REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d
 
     REAL :: rhs,gfluxm,gfluxp,dztop
+
+    REAL :: grav_settling2,vdfg1    !Katata-fogdes
+
     INTEGER :: k,kk,nz
 
     nz=kte-kts+1
@@ -1673,14 +1789,17 @@ SUBROUTINE mynn_tendencies(kts,kte,&
        dtz(k)=delt/dz(k)
     ENDDO
 
+!!============================================
 !! u
+!!============================================
    
     k=kts
 
     a(1)=0.
     b(1)=1.+dtz(k)*(dfm(k+1)+ust**2/wspd)
     c(1)=-dtz(k)*dfm(k+1)
-    d(1)=u(k)
+!    d(1)=u(k)
+    d(1)=u(k)+dtz(k)*uoce*ust**2/wspd
 
 !!    a(1)=0.
 !!    b(1)=1.+dtz(k)*dfm(k+1)
@@ -1722,14 +1841,17 @@ SUBROUTINE mynn_tendencies(kts,kte,&
        du(k)=(d(k-kts+1)-u(k))/delt
     ENDDO
 
+!!============================================
 !! v
+!!============================================
 
     k=kts
 
     a(1)=0.
     b(1)=1.+dtz(k)*(dfm(k+1)+ust**2/wspd)
     c(1)=-dtz(k)*dfm(k+1)
-    d(1)=v(k)
+!    d(1)=v(k)
+    d(1)=v(k)+dtz(k)*voce*ust**2/wspd
 
 !!    a(1)=0.
 !!    b(1)=1.+dtz(k)*dfm(k+1)
@@ -1772,38 +1894,50 @@ SUBROUTINE mynn_tendencies(kts,kte,&
        dv(k)=(d(k-kts+1)-v(k))/delt
     ENDDO
 
+!!============================================
 !! thl 
-
+!! NOTE: currently, gravitational settling is removed
+!!============================================
     k=kts
 
     a(1)=0.
     b(1)=1.+dtz(k)*dfh(k+1)
     c(1)=-dtz(k)*dfh(k+1)
     
+!Katata - added
+!    grav_settling2 = MIN(REAL(grav_settling),1.)
+!Katata - end
+!
 ! if qcg not used then assume constant flux in the surface layer
+!JOE-remove original code
+!    IF (qcg < qcgmin) THEN
+!       IF (sqc(k) > qcgmin) THEN
+!          gfluxm=grav_settling2*gno*sqc(k)**gpw
+!       ELSE
+!          gfluxm=0.
+!       ENDIF
+!    ELSE
+!       gfluxm=grav_settling2*gno*(qcg/(1.+qcg))**gpw
+!    ENDIF
+!and replace with vdfg1 is computed in module_sf_fogdes.F.
+!    IF (sqc(k) > qcgmin) THEN
+!       !gfluxm=grav_settling2*gno*sqc(k)**gpw
+!       gfluxm=grav_settling2*sqc(k)*vdfg1
+!    ELSE
+!       gfluxm=0.
+!    ENDIF
+!JOE-end
+!
+!    IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
+!       gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
+!    ELSE
+!       gfluxp=0.
+!    ENDIF
 
-    IF (qcg < qcgmin) THEN
-       IF (sqc(k) > qcgmin) THEN
-          gfluxm=grav_settling*gno*sqc(k)**gpw
-       ELSE
-          gfluxm=0.
-       ENDIF
-    ELSE
-       gfluxm=grav_settling*gno*(qcg/(1.+qcg))**gpw
-    ENDIF
-
-    IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
-       gfluxp=grav_settling*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
-    ELSE
-       gfluxp=0.
-    ENDIF
-
-    rhs=-xlvcp/exner(k)&
-         &*( &
-         &(gfluxp - gfluxm)/dz(k)&
-         & ) + tcd(k)
+    rhs= tcd(k) !-xlvcp/exner(k)*&
+!         ((gfluxp - gfluxm)/dz(k))
 
-    d(1)=thl(k)+dtz(k)*flt+rhs*delt
+    d(1)=thl(k) + dtz(k)*flt + rhs*delt
     
     DO k=kts+1,kte-1
        kk=k-kts+1
@@ -1811,23 +1945,22 @@ SUBROUTINE mynn_tendencies(kts,kte,&
        b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) 
        c(kk)=-dtz(k)*dfh(k+1)
 
-       IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
-          gfluxp=grav_settling*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
-       ELSE
-          gfluxp=0.
-       ENDIF
-       
-       IF (.5*(sqc(k-1)+sqc(k)) > qcgmin) THEN
-          gfluxm=grav_settling*gno*(.5*(sqc(k-1)+sqc(k)))**gpw
-       ELSE
-          gfluxm=0.
-       ENDIF
-
-       rhs=-xlvcp/exner(k)&
-            &*( &
-            &(gfluxp - gfluxm)/dz(k)&
-            & ) + tcd(k)
-       d(kk)=thl(k)+rhs*delt
+!       IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
+!          gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
+!       ELSE
+!          gfluxp=0.
+!       ENDIF
+!       
+!       IF (.5*(sqc(k-1)+sqc(k)) > qcgmin) THEN
+!          gfluxm=grav_settling2*gno*(.5*(sqc(k-1)+sqc(k)))**gpw
+!       ELSE
+!          gfluxm=0.
+!       ENDIF
+
+       rhs= tcd(k) !-xlvcp/exner(k)*&
+!            &((gfluxp - gfluxm)/dz(k))
+
+       d(kk)=thl(k) + rhs*delt
     ENDDO
 
 !! no flux at the top
@@ -1859,96 +1992,326 @@ SUBROUTINE mynn_tendencies(kts,kte,&
        thl(k)=d(k-kts+1)
     ENDDO
 
-!! total water
+!!============================================
+!! NO LONGER MIX total water (sqw = sqc + sqv)
+!! NOTE: no total water tendency is output
+!!============================================
+!
+!    k=kts
+!  
+!    a(1)=0.
+!    b(1)=1.+dtz(k)*dfh(k+1)
+!    c(1)=-dtz(k)*dfh(k+1)
+!    
+!JOE: replace orig code with fogdep
+!    IF (qcg < qcgmin) THEN
+!       IF (sqc(k) > qcgmin) THEN
+!          gfluxm=grav_settling2*gno*sqc(k)**gpw
+!       ELSE
+!          gfluxm=0.
+!       ENDIF
+!    ELSE
+!       gfluxm=grav_settling2*gno*(qcg/(1.+qcg))**gpw
+!    ENDIF
+!and replace with fogdes code + remove use of qcg:
+!    IF (sqc(k) > qcgmin) THEN
+!       !gfluxm=grav_settling2*gno*(.5*(sqc(k)+sqc(k)))**gpw
+!       gfluxm=grav_settling2*sqc(k)*vdfg1
+!    ELSE
+!       gfluxm=0.
+!    ENDIF
+!JOE-end
+!    
+!    IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
+!       gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
+!    ELSE
+!       gfluxp=0.
+!    ENDIF
+!
+!    rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& 
+!
+!    d(1)=sqw(k) + dtz(k)*flq + rhs*delt
+!    
+!    DO k=kts+1,kte-1
+!       kk=k-kts+1
+!       a(kk)=-dtz(k)*dfh(k)
+!       b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) 
+!       c(kk)=-dtz(k)*dfh(k+1)
+!
+!       IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
+!          gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
+!       ELSE
+!          gfluxp=0.
+!       ENDIF
+!
+!       IF (.5*(sqc(k-1)+sqc(k)) > qcgmin) THEN
+!          gfluxm=grav_settling2*gno*(.5*(sqc(k-1)+sqc(k)))**gpw
+!       ELSE
+!          gfluxm=0.
+!       ENDIF
+!
+!       rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)&
+!
+!       d(kk)=sqw(k) + rhs*delt
+!    ENDDO
+
+
+!! no flux at the top
+
+!    a(nz)=-1.
+!    b(nz)=1.
+!    c(nz)=0.
+!    d(nz)=0.
+ 
+!! specified gradient at the top
+!assume gradqw_top=gradqv_top
+
+!    a(nz)=-1.
+!    b(nz)=1.
+!    c(nz)=0.
+!    d(nz)=gradqv_top*dztop
+
+!! prescribed value
+
+!    a(nz)=0.
+!    b(nz)=1.
+!    c(nz)=0.
+!    d(nz)=sqw(kte)
+!
+!    CALL tridiag(nz,a,b,c,d)
+!
+!    DO k=kts,kte
+!       sqw(k)=d(k-kts+1)
+!    ENDDO
+
+!!============================================
+!! cloud water ( sqc )
+!!============================================
+IF (Cloudmix > 0.5 .AND. FLAG_QC) THEN
 
     k=kts
-  
+
     a(1)=0.
     b(1)=1.+dtz(k)*dfh(k+1)
     c(1)=-dtz(k)*dfh(k+1)
-    
-    IF (qcg < qcgmin) THEN
-       IF (sqc(k) > qcgmin) THEN
-          gfluxm=grav_settling*gno*sqc(k)**gpw
-       ELSE
-          gfluxm=0.
-       ENDIF
-    ELSE
-       gfluxm=grav_settling*gno*(qcg/(1.+qcg))**gpw
-    ENDIF
-    
-    IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
-       gfluxp=grav_settling*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
-    ELSE
-       gfluxp=0.
-    ENDIF
 
-    rhs=&
-         &( &
-         &(gfluxp - gfluxm)/dz(k)& 
-        & ) + qcd(k)
-    
-    d(1)=sqw(k)+dtz(k)*flq+rhs*delt
-    
+    rhs   =  qcd(k)
+    d(1)=sqc(k) + dtz(k)*flqc + rhs*delt
+
     DO k=kts+1,kte-1
        kk=k-kts+1
        a(kk)=-dtz(k)*dfh(k)
-       b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) 
+       b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1))
        c(kk)=-dtz(k)*dfh(k+1)
 
-       IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN
-          gfluxp=grav_settling*gno*(.5*(sqc(k+1)+sqc(k)))**gpw
-       ELSE
-          gfluxp=0.
-       ENDIF
+       rhs = qcd(k)
+       d(kk)=sqc(k) + rhs*delt
+    ENDDO
 
-       IF (.5*(sqc(k-1)+sqc(k)) > qcgmin) THEN
-          gfluxm=grav_settling*gno*(.5*(sqc(k-1)+sqc(k)))**gpw
-       ELSE
-          gfluxm=0.
-       ENDIF
+!! prescribed value                                                                                     
+    a(nz)=0.
+    b(nz)=1.
+    c(nz)=0.
+    d(nz)=sqc(kte)
 
-       rhs=&
-            &( &
-            &(gfluxp - gfluxm)/dz(k)&
-            & ) + qcd(k)
-       d(kk)=sqw(k) + rhs*delt
-    ENDDO
+    CALL tridiag(nz,a,b,c,d)
 
+    DO k=kts,kte
+       sqc(k)=d(k-kts+1)
+    ENDDO
 
-!! no flux at the top
+ENDIF
 
-!    a(nz)=-1.
+!!============================================
+!! cloud water number concentration ( qnc )
+!!============================================
+!IF (Cloudmix > 0.5 .AND. FLAG_QNC) THEN
+!
+!    k=kts
+!
+!    a(1)=0.
+!    b(1)=1.+dtz(k)*dfh(k+1)
+!    c(1)=-dtz(k)*dfh(k+1)
+!
+!    rhs =qcd(k)
+!    d(1)=qnc(k) !+ dtz(k)*flqc + rhs*delt
+!
+!    DO k=kts+1,kte-1
+!       kk=k-kts+1
+!       a(kk)=-dtz(k)*dfh(k)
+!       b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1))
+!       c(kk)=-dtz(k)*dfh(k+1)
+!
+!       rhs = qcd(k)
+!       d(kk)=qnc(k) + rhs*delt
+!    ENDDO
+!
+!! prescribed value
+!    a(nz)=0.
 !    b(nz)=1.
 !    c(nz)=0.
-!    d(nz)=0.
- 
+!    d(nz)=qnc(kte)
+!
+!    CALL tridiag(nz,a,b,c,d)
+!
+!    DO k=kts,kte
+!       qnc2(k)=d(k-kts+1)
+!    ENDDO
+!
+!ELSE
+!    qnc2=qnc
+!ENDIF
+
+!!============================================
+!! MIX WATER VAPOR ONLY ( sqv )                                                                         
+!!============================================                                                          
+
+    k=kts
+
+    a(1)=0.
+    b(1)=1.+dtz(k)*dfh(k+1)
+    c(1)=-dtz(k)*dfh(k+1)
+    d(1)=sqv(k) + dtz(k)*flqv + qcd(k)*delt
+
+    DO k=kts+1,kte-1
+       kk=k-kts+1
+       a(kk)=-dtz(k)*dfh(k)
+       b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1))
+       c(kk)=-dtz(k)*dfh(k+1)
+       d(kk)=sqv(k) + qcd(k)*delt
+    ENDDO
+
+!! no flux at the top                                                                                   
+!    a(nz)=-1.                                                                                          
+!    b(nz)=1.                                                                                           
+!    c(nz)=0.                                                                                           
+!    d(nz)=0.                                                                                           
+
+!! specified gradient at the top                                                                        
+!assume gradqw_top=gradqv_top                                                                           
+!    a(nz)=-1.                                                                                          
+!    b(nz)=1.                                                                                           
+!    c(nz)=0.                                                                                           
+!    d(nz)=gradqv_top*dztop                                                                             
+
+!! prescribed value                                                                                     
+    a(nz)=0.
+    b(nz)=1.
+    c(nz)=0.
+    d(nz)=sqv(kte)
+
+    CALL tridiag(nz,a,b,c,d)
+
+    DO k=kts,kte
+       sqv(k)=d(k-kts+1)
+    ENDDO
+
+!!============================================
+!! MIX CLOUD ICE ( sqi )                      
+!!============================================
+IF (Cloudmix > 0.5 .AND. FLAG_QI) THEN
+
+    k=kts
+
+    a(1)=0.
+    b(1)=1.+dtz(k)*dfh(k+1)
+    c(1)=-dtz(k)*dfh(k+1)
+    d(1)=sqi(k) + qcd(k)*delt !should we have qcd for ice???
+
+    DO k=kts+1,kte-1
+       kk=k-kts+1
+       a(kk)=-dtz(k)*dfh(k)
+       b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1))
+       c(kk)=-dtz(k)*dfh(k+1)
+       d(kk)=sqi(k) + qcd(k)*delt
+    ENDDO
+
+!! no flux at the top
+!    a(nz)=-1.       
+!    b(nz)=1.        
+!    c(nz)=0.        
+!    d(nz)=0.        
+
 !! specified gradient at the top
 !assume gradqw_top=gradqv_top
+!    a(nz)=-1.                                                                                          
+!    b(nz)=1.                                                                                           
+!    c(nz)=0.                                                                                           
+!    d(nz)=gradqv_top*dztop                                                                             
 
-!    a(nz)=-1.
-!    b(nz)=1.
-!    c(nz)=0.
-!    d(nz)=gradqv_top*dztop
+!! prescribed value                                                                                     
+    a(nz)=0.
+    b(nz)=1.
+    c(nz)=0.
+    d(nz)=sqi(kte)
 
-!! prescribed value
+    CALL tridiag(nz,a,b,c,d)
+
+    DO k=kts,kte
+       sqi(k)=d(k-kts+1)
+    ENDDO
+
+ENDIF
+
+!!============================================
+!! ice water number concentration (qni)       
+!!============================================
+IF (Cloudmix > 0.5 .AND. FLAG_QNI) THEN
+
+    k=kts
+
+    a(1)=0.
+    b(1)=1.+dtz(k)*dfh(k+1)
+    c(1)=-dtz(k)*dfh(k+1)
+
+    rhs = qcd(k)               
 
+    d(1)=qni(k) !+ dtz(k)*flqc + rhs*delt
+
+    DO k=kts+1,kte-1
+       kk=k-kts+1
+       a(kk)=-dtz(k)*dfh(k)
+       b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1))
+       c(kk)=-dtz(k)*dfh(k+1)
+
+       rhs = qcd(k)
+       d(kk)=qni(k) + rhs*delt
+
+    ENDDO
+
+!! prescribed value
     a(nz)=0.
     b(nz)=1.
     c(nz)=0.
-    d(nz)=sqw(kte)
+    d(nz)=qni(kte)
 
     CALL tridiag(nz,a,b,c,d)
 
-!convert to mixing ratios for wrf
-    
     DO k=kts,kte
-       sqw(k)=d(k-kts+1)
-       sqv(k)=sqw(k)-sqc(k)
+       qni2(k)=d(k-kts+1)
+    ENDDO
+ELSE
+    qni2=qni
+ENDIF
+
+!!============================================
+!! convert to mixing ratios for wrf
+!!============================================
+!!NOTE: added number conc tendencies for double moment schemes
+
+    DO k=kts,kte
+       !sqw(k)=d(k-kts+1)
        Dqv(k)=(sqv(k)/(1.-sqv(k))-qv(k))/delt
-!       Dqc(k)=(sqc(k)/(1.-sqc(k))-qc(k))/delt
-       Dqc(k)=0.
-       Dth(k)=(thl(k)+xlvcp/exner(k)*sqc(k)-th(k))/delt
+       !qc settling tendency is now computed in module_bl_fogdes.F, so
+       !sqc should only be changed by turbulent mixing.
+       Dqc(k)=(sqc(k)/(1.-sqc(k))-qc(k))/delt
+       Dqi(k)=(sqi(k)/(1.-sqi(k))-qi(k))/delt
+ !      Dqnc(k)=(qnc2(k)-qnc(k))/delt
+       Dqni(k)=(qni2(k)-qni(k))/delt
+       Dth(k)=(thl(k) + xlvcp/exner(k)*sqc(k) &
+         &            + xlscp/exner(k)*sqi(k) &
+         &            - th(k))/delt
+       !Dth(k)=(thl(k)+xlvcp/exner(k)*sqc(k)-th(k))/delt
     ENDDO
 
   END SUBROUTINE mynn_tendencies
@@ -2025,39 +2388,41 @@ SUBROUTINE mynn_bl_driver(&
        &grav_settling,&
        &delt,&
        &dz,&
-       &u,v,th,qv,qc,&
+       &u,v,th,qv,qc,qi,qni,&! qnc&       !JOE: ice & num conc mixing
        &p,exner,rho,&
        &xland,ts,qsfc,qcg,ps,&
        &ust,ch,hfx,qfx,rmol,wspd,&
-       &Qke,&
-!ACF for QKE advection
-       &qke_adv,bl_mynn_tkeadvect,&
-!ACF-end
+       &uoce,voce,&                     !ocean current
+       &vdfg,&                          !Katata-added for fog dep
+       &Qke,tke_pbl,&                   !JOE: add TKE for coupling
+       &qke_adv,bl_mynn_tkeadvect,&     !ACF for QKE advection
        &Tsq,Qsq,Cov,&
        &Du,Dv,Dth,&
-       &Dqv,Dqc,&
+       &Dqv,Dqc,Dqi,Dqni,& !Dqnc,&         !JOE: ice & nim conc mixing
 !       &K_m,K_h,K_q&
        &K_h,k_m,&
-       &Pblh&
-!JOE-added for extra ouput
-       &,el_mynn&
-!JOE-end
-!JOE-TKE BUDGET
-       &,dqke,qWT,qSHEAR,qBUOY,qDISS                &
-       &,bl_mynn_tkebudget                          &
-!JOE-end
-       &,IDS,IDE,JDS,JDE,KDS,KDE                    &
-       &,IMS,IME,JMS,JME,KMS,KME                    &
+       &Pblh,kpbl&                      !JOE-added kpbl for coupling
+       &,el_pbl&
+       &,dqke,qWT,qSHEAR,qBUOY,qDISS    & !JOE-TKE BUDGET
+       &,wstar,delta                    & !JOE-added for grims
+       &,bl_mynn_tkebudget              & !JOE-TKE BUDGET
+       &,bl_mynn_cloudpdf,Sh3D          & !JOE-cloudPDF testing
+       ! optional arguments
+       &,FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC &
+       &,IDS,IDE,JDS,JDE,KDS,KDE        &
+       &,IMS,IME,JMS,JME,KMS,KME        &
        &,ITS,ITE,JTS,JTE,KTS,KTE)
     
 !-------------------------------------------------------------------
 
     INTEGER, INTENT(in) :: initflag
+    !INPUT NAMELIST OPTIONS:
     INTEGER, INTENT(in) :: grav_settling
     INTEGER, INTENT(in) :: bl_mynn_tkebudget
-!ACF for QKE advection
+    INTEGER, INTENT(in) :: bl_mynn_cloudpdf
     LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect
-!ACF-end
+
+    LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC
     
     INTEGER,INTENT(IN) :: &
          & IDS,IDE,JDS,JDE,KDS,KDE &
@@ -2074,64 +2439,103 @@ SUBROUTINE mynn_bl_driver(&
     
     REAL, INTENT(in) :: delt
     REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: dz,&
-         &u,v,th,qv,qc,p,exner,rho 
+         &u,v,th,qv,qc,p,exner,rho
+    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), OPTIONAL, INTENT(in)::&
+         &qi,qni! ,qnc
     REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: xland,ust,&
-         &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd
+!         &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd,uoce,voce
+!Katata-added for extra in-output
+         &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd,uoce,voce, vdfg
+!Katata-end
 
     REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: &
          &Qke,Tsq,Qsq,Cov, &
-!ACF for QKE advection
-         &qke_adv
-!ACF-end
+         &tke_pbl, & !JOE-added for coupling (TKE_PBL = QKE/2)
+         &qke_adv    !ACF for QKE advection
 
-    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: &
-         &Du,Dv,Dth,Dqv,Dqc
+    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: &
+         &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqni!,Dqnc
 
     REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: &
          &K_h,K_m
 
     REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(inout) :: &
-         &Pblh
+         &Pblh,wstar,delta  !JOE-added for GRIMS
+    INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: & 
+         &KPBL
     
     REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: &
-         &el_mynn
+         &el_pbl
 
 !JOE-TKE BUDGET
-    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME),        &
-         INTENT(inout) ::                            &
-         qWT,qSHEAR,qBUOY,qDISS,dqke
+    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: &
+         &qWT,qSHEAR,qBUOY,qDISS,dqke
+    ! 3D budget arrays are not allocated when bl_mynn_tkebudget == 0.
+    ! 1D (local) budget arrays are used for passing between subroutines.
+    REAL, DIMENSION(KTS:KTE) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1
 !JOE-end
+    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: K_q,Sh3D
 
 !local vars
-    INTEGER :: ITF,JTF,KTF
+    INTEGER :: ITF,JTF,KTF, IMD,JMD
     INTEGER :: i,j,k
-    REAL, DIMENSION(KMS:KME) :: thl,sqv,sqc,sqw,&
+    REAL, DIMENSION(KTS:KTE) :: thl,sqv,sqc,sqi,sqw,&
          &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, Vt, Vq
 
-    REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: K_q
+    REAL, DIMENSION(KTS:KTE) :: thetav,sh,u1,v1,p1,ex1,dz1,th1,qke1, &
+           & tsq1,qsq1,cov1,qv1,qi1,qc1,du1,dv1,dth1,dqv1,dqc1,dqi1, &
+           & k_m1,k_h1,k_q1,qni1,dqni1!,qnc1,dqnc1
 
-    REAL, DIMENSION(KMS:KME+1) :: zw
-    
-    REAL :: cpm,sqcg,flt,flq,pmz,phh,exnerg,zet
+    REAL, DIMENSION(KTS:KTE+1) :: zw
     
-    REAL, DIMENSION(KMS:KME) :: thetav
-
+      REAL :: cpm,sqcg,flt,flq,flqv,flqc,pmz,phh,exnerg,zet,& 
+              &afk,abk
+!JOE-add GRIMS parameters & variables
+   real,parameter    ::  d1 = 0.02, d2 = 0.05, d3 = 0.001
+   real,parameter    ::  h1 = 0.33333335, h2 = 0.6666667
+   REAL :: govrth, sflux, bfx0, wstar3, wm2, wm3, delb
+!JOE-end GRIMS
     INTEGER, SAVE :: levflag
-    
+
+!***  Begin debugging
+    IMD=(IMS+IME)/2
+    JMD=(JMS+JME)/2
+!***  End debugging 
+
     JTF=MIN0(JTE,JDE-1)
     ITF=MIN0(ITE,IDE-1)
     KTF=MIN0(KTE,KDE-1)
-    
+
     levflag=mynn_level
 
     IF (initflag > 0) THEN
+ 
+       Sh3D(its:ite,kts:kte,jts:jte)=0.
+       el_pbl(its:ite,kts:kte,jts:jte)=0.
+       tsq(its:ite,kts:kte,jts:jte)=0.
+       qsq(its:ite,kts:kte,jts:jte)=0.
+       cov(its:ite,kts:kte,jts:jte)=0.
 
        DO j=JTS,JTF
           DO i=ITS,ITF
              DO k=KTS,KTF
+                dz1(k)=dz(i,k,j)
+                u1(k) = u(i,k,j)
+                v1(k) = v(i,k,j)
+                th1(k)=th(i,k,j)
+                sqc(k)=qc(i,k,j)/(1.+qc(i,k,j))
                 sqv(k)=qv(i,k,j)/(1.+qv(i,k,j))
-                thl(k)=th(i,k,j)
                 thetav(k)=th(i,k,j)*(1.+0.61*sqv(k))
+                IF (PRESENT(qi) .AND. FLAG_QI ) THEN
+                   sqi(k)=qi(i,k,j)/(1.+qi(i,k,j))
+                   sqw(k)=sqv(k)+sqc(k)+sqi(k)
+                   thl(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc(k) &
+                       &           - xlscp/exner(i,k,j)*sqi(k)
+                ELSE
+                   sqi(k)=0.0
+                   sqw(k)=sqv(k)+sqc(k)
+                   thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k)
+                ENDIF
 
                 IF (k==kts) THEN
                    zw(k)=0.
@@ -2142,7 +2546,13 @@ SUBROUTINE mynn_bl_driver(&
                 k_m(i,k,j)=0.
                 k_h(i,k,j)=0.
                 k_q(i,k,j)=0.
-                el_mynn(i,k,j)=0.
+                qke(i,k,j)=0.1-MIN(zw(k)*0.001, 0.0)
+                qke1(k)=qke(i,k,j)
+                el(k)=el_pbl(i,k,j)
+                sh(k)=Sh3D(i,k,j)
+                tsq1(k)=tsq(i,k,j)
+                qsq1(k)=qsq(i,k,j)
+                cov1(k)=cov(i,k,j)
 
                 IF ( bl_mynn_tkebudget == 1) THEN
                    !TKE BUDGET VARIABLES
@@ -2154,29 +2564,43 @@ SUBROUTINE mynn_bl_driver(&
                 ENDIF
              ENDDO
 
-             zw(ktf+1)=zw(ktf)+dz(i,ktf,j)
+             zw(kte+1)=zw(kte)+dz(i,kte,j)
              
-             CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav(kts:kte),&
-               &    Qke(i,kts:kte,j),zw(kts:kte+1),dz(i,kts:kte,j),xland(i,j))
+             CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,&
+               &  Qke1,zw,dz1,xland(i,j),KPBL(i,j))
 
              CALL mym_initialize ( kts,kte,&
-                  &dz(i,kts:kte,j), zw(kts:kte+1),  &
-                  &u(i,kts:kte,j), v(i,kts:kte,j), &
-                  &thl(kts:kte), sqv(kts:kte),&
-!JOE-BouLac mod
-                  &PBLH(i,j),th(i,kts:kte,j),&
-!JOE-end
+                  &dz1, zw, u1, v1, thl, sqv,&
+                  &PBLH(i,j),th1,&                      !JOE-BouLac mod
+                  &sh,&                                 !JOE-cloudPDF mod
                   &ust(i,j), rmol(i,j),&
-                  &Qke(i,kts:kte,j), Tsq(i,kts:kte,j), &
-                  &Qsq(i,kts:kte,j), Cov(i,kts:kte,j))
-                          
+                  &el, Qke1, Tsq1, Qsq1, Cov1)
+
+             !UPDATE 3D VARIABLES
+             DO k=KTS,KTE !KTF
+                el_pbl(i,k,j)=el(k)
+                sh3d(i,k,j)=sh(k)
+                qke(i,k,j)=qke1(k)
+                tsq(i,k,j)=tsq1(k)
+                qsq(i,k,j)=qsq1(k)
+                cov(i,k,j)=cov1(k)
 !ACF,JOE- initialize qke_adv array if using advection
-             IF (bl_mynn_tkeadvect) THEN
-                DO k=KTS,KTF
-                   qke_adv(i,k,j)=qke(i,k,j)
-                ENDDO
-             ENDIF
-!ACF,JOE-end
+                IF (bl_mynn_tkeadvect) THEN
+                   qke_adv(i,k,j)=qke1(k)
+                ENDIF
+!ACF,JOE-end                
+             ENDDO
+
+!***  Begin debugging
+!             k=kdebug
+!             IF(I==IMD .AND. J==JMD)THEN
+!               PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k)
+!               PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",k_m(i,k,j)
+!               PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j)
+!               PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",Tsq(i,k,j)
+!               PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j)
+!             ENDIF
+!***  End debugging
 
           ENDDO
        ENDDO
@@ -2196,11 +2620,48 @@ SUBROUTINE mynn_bl_driver(&
              IF ( bl_mynn_tkebudget == 1) THEN
                 dqke(i,k,j)=qke(i,k,j)
              END IF
-             sqv(k)=qv(i,k,j)/(1.+qv(i,k,j))
-             sqc(k)=qc(i,k,j)/(1.+qc(i,k,j))
-             sqw(k)=sqv(k)+sqc(k)
-             thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k)
-             thetav(k)=th(i,k,j)*(1.+0.61*sqv(k))
+             dz1(k)= dz(i,k,j)
+             u1(k) = u(i,k,j)
+             v1(k) = v(i,k,j)
+             th1(k)= th(i,k,j)
+             qv1(k)= qv(i,k,j)
+             qc1(k)= qc(i,k,j)
+             sqv(k)= qv(i,k,j)/(1.+qv(i,k,j))
+             sqc(k)= qc(i,k,j)/(1.+qc(i,k,j))
+             IF(PRESENT(qi) .AND. FLAG_QI)THEN
+                qi1(k)= qi(i,k,j)
+                sqi(k)= qi(i,k,j)/(1.+qi(i,k,j))
+                sqw(k)= sqv(k)+sqc(k)+sqi(k)
+                thl(k)= th(i,k,j) - xlvcp/exner(i,k,j)*sqc(k) &
+                     &            - xlscp/exner(i,k,j)*sqi(k)
+                !print*,"MYNN: Flag_qi=",FLAG_QI,qi(i,k,j)
+             ELSE
+                qi1(k)=0.0
+                sqi(k)=0.0
+                sqw(k)= sqv(k)+sqc(k)
+                thl(k)= th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k)
+             ENDIF
+             IF (PRESENT(qni) .AND. FLAG_QNI ) THEN
+                qni1(k)=qni(i,k,j)
+                !print*,"MYNN: Flag_qni=",FLAG_QNI,qni(i,k,j)
+             ELSE
+                qni1(k)=0.0
+             ENDIF
+             !IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN
+             !   qnc1(k)=qnc(i,k,j)
+             !   !print*,"MYNN: Flag_qnc=",FLAG_QNC,qnc(i,k,j)
+             !ELSE
+             !   qnc1(k)=0.0
+             !ENDIF
+             thetav(k)=th(i,k,j)*(1.+0.608*sqv(k))
+             p1(k) = p(i,k,j)
+             ex1(k)= exner(i,k,j)
+             el(k) = el_pbl(i,k,j)
+             qke1(k)=qke(i,k,j)
+             sh(k) = sh3d(i,k,j)
+             tsq1(k)=tsq(i,k,j)
+             qsq1(k)=qsq(i,k,j)
+             cov1(k)=cov(i,k,j)
 
              IF (k==kts) THEN
                 zw(k)=0.
@@ -2209,23 +2670,31 @@ SUBROUTINE mynn_bl_driver(&
              ENDIF
           ENDDO
 
-          zw(ktf+1)=zw(ktf)+dz(i,ktf,j)          
+          zw(kte+1)=zw(kte)+dz(i,kte,j)          
           
-          CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav(kts:kte),&
-              Qke(i,kts:kte,j),zw(kts:kte+1),dz(i,kts:kte,j),xland(i,j))
+          CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,&
+          & Qke1,zw,dz1,xland(i,j),KPBL(i,j))
           
-          sqcg=qcg(i,j)/(1.+qcg(i,j))
-          cpm=cp*(1.+0.8*qv(i,kts,j))
-
-! The exchange coefficient for cloud water is assumed to be the same as
-! that for heat. CH is multiplied by WSPD. See module_sf_mynn.F
+          sqcg= 0.0   !JOE, it was: qcg(i,j)/(1.+qcg(i,j))
+          cpm=cp*(1.+0.84*qv(i,kts,j))
           exnerg=(ps(i,j)/p1000mb)**rcp
+
+          !-----------------------------------------------------
+          !ORIGINAL CODE
+          !flt = hfx(i,j)/( rho(i,kts,j)*cpm ) &
+          ! +xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j) -sqcg/exnerg)
+          !flq = qfx(i,j)/  rho(i,kts,j)       &
+          !    -ch(i,j)*(sqc(kts)   -sqcg )
+          !-----------------------------------------------------
+          ! Katata-added - The deposition velocity of cloud (fog) 
+          ! water is used instead of CH.
           flt = hfx(i,j)/( rho(i,kts,j)*cpm ) &
-         +xlvcp*ch(i,j)*(sqc(kts)/exner(i,kts,j)-sqcg/exnerg)
+            & +xlvcp*vdfg(i,j)*(sqc(kts)/exner(i,kts,j)- sqcg/exnerg)
           flq = qfx(i,j)/  rho(i,kts,j)       &
-               -ch(i,j)*(sqc(kts)               -sqcg       )
+            & -vdfg(i,j)*(sqc(kts) - sqcg )
+          flqv = qfx(i,j)/rho(i,kts,j)
+          flqc = -vdfg(i,j)*(sqc(kts) - sqcg )
 
-!!!!!
           zet = 0.5*dz(i,kts,j)*rmol(i,j)
           if ( zet >= 0.0 ) then
             pmz = 1.0 + (cphm_st-1.0) * zet
@@ -2234,79 +2703,133 @@ SUBROUTINE mynn_bl_driver(&
             pmz = 1.0/    (1.0-cphm_unst*zet)**0.25 - zet
             phh = 1.0/SQRT(1.0-cphh_unst*zet)
           end if
-!!!!!
+
+!!!!! estimate wstar & delta for GRIMS shallow-cu
+          govrth = g/th1(kts)
+          sflux = hfx(i,j)/rho(i,kts,j)/cpm + &
+                  qfx(i,j)/rho(i,kts,j)*ep_1*th1(kts)
+          bfx0 = max(sflux,0.)
+          wstar3     = (govrth*bfx0*pblh(i,j))
+          wstar(i,j) = wstar3**h1
+          wm3        = wstar3 + 5.*ust(i,j)**3.
+          wm2        = wm3**h2
+          delb       = govrth*d3*pblh(i,j)
+          delta(i,j) = min(d1*pblh(i,j) + d2*wm2/delb, 100.)
+!!!!! end GRIMS
 
           CALL  mym_condensation ( kts,kte,&
-               &dz(i,kts:kte,j), &
-               &thl(kts:kte), sqw(kts:kte), &
-               &p(i,kts:kte,j),exner(i,kts:kte,j), &
-               &tsq(i,kts:kte,j), qsq(i,kts:kte,j), cov(i,kts:kte,j), &
-               &Vt(kts:kte), Vq(kts:kte))
-
-          CALL mym_turbulence ( kts,kte,&
-               &levflag, &
-               &dz(i,kts:kte,j), zw(kts:kte+1), &
-               &u(i,kts:kte,j), v(i,kts:kte,j), thl(kts:kte),&
-               &sqc(kts:kte), sqw(kts:kte), &
-               &qke(i,kts:kte,j), tsq(i,kts:kte,j), &
-               &qsq(i,kts:kte,j), cov(i,kts:kte,j), &
-               &vt(kts:kte), vq(kts:kte),&
+               &dz1,thl,sqw,p1,ex1, &
+               &tsq1, qsq1, cov1, &
+               &Sh,el,bl_mynn_cloudpdf, & !JOE-added for cloud PDF testing (from Kuwano-Yoshida et al. 2010)
+               &Vt, Vq)
+
+          CALL mym_turbulence ( kts,kte,levflag, &
+               &dz1, zw, u1, v1, thl, sqc, sqw, &
+               &qke1, tsq1, qsq1, cov1, &
+               &vt, vq,&
                &rmol(i,j), flt, flq, &
-!JOE-BouLac mod
-               &PBLH(i,j),th(i,kts:kte,j),&
-!JOE-end
-               &el_mynn(i,kts:kte,j), &
-               &Dfm(kts:kte),Dfh(kts:kte),Dfq(kts:kte), &
-               &Tcd(kts:kte),Qcd(kts:kte),Pdk(kts:kte), &
-               &Pdt(kts:kte),Pdq(kts:kte),Pdc(kts:kte) &
-!JOE-TKE BUDGET
-               &,qWT(i,kts:kte,j),qSHEAR(i,kts:kte,j),&
-               &qBUOY(i,kts:kte,j),qDISS(i,kts:kte,j),&
-               &bl_mynn_tkebudget                     &
-!JOE-end
+               &PBLH(i,j),th1,&                  !JOE-BouLac mod
+               &Sh,&                             !JOE-cloudPDF mod
+               &el,&  
+               &Dfm,Dfh,Dfq, &
+               &Tcd,Qcd,Pdk, &
+               &Pdt,Pdq,Pdc &
+               &,qWT1,qSHEAR1,qBUOY1,qDISS1  &   !JOE-TKE BUDGET
+               &,bl_mynn_tkebudget           &   !JOE-TKE BUDGET
                &)
 
-
-          CALL mym_predict (kts,kte,&
-               &levflag,  &
-               &delt,&
-               &dz(i,kts:kte,j), &
+          CALL mym_predict (kts,kte,levflag,  &
+               &delt, dz1, &
                &ust(i,j), flt, flq, pmz, phh, &
-               &el_mynn(i,kts:kte,j), dfq(kts:kte), pdk(kts:kte), &
-               &pdt(kts:kte), pdq(kts:kte), pdc(kts:kte),&
-               &Qke(i,kts:kte,j), Tsq(i,kts:kte,j),   &
-               &Qsq(i,kts:kte,j), Cov(i,kts:kte,j))
+               &el, dfq, pdk, pdt, pdq, pdc, &
+               &Qke1, Tsq1, Qsq1, Cov1)
 
           CALL mynn_tendencies(kts,kte,&
                &levflag,grav_settling,&
-               &delt,&
-               &dz(i,kts:kte,j),&
-               &u(i,kts:kte,j),v(i,kts:kte,j),&
-               &th(i,kts:kte,j),qv(i,kts:kte,j),qc(i,kts:kte,j),&
-               &p(i,kts:kte,j),exner(i,kts:kte,j),&
-               &thl(kts:kte),sqv(kts:kte),sqc(kts:kte),sqw(kts:kte),&
-               &ust(i,j),flt,flq,wspd(i,j),qcg(i,j),&
-               &tsq(i,kts:kte,j),qsq(i,kts:kte,j),cov(i,kts:kte,j),&
-               &tcd(kts:kte),qcd(kts:kte),&
-               &dfm(kts:kte),dfh(kts:kte),dfq(kts:kte),&
-               &Du(i,kts:kte,j),Dv(i,kts:kte,j),Dth(i,kts:kte,j),&
-               &Dqv(i,kts:kte,j),Dqc(i,kts:kte,j))
+               &delt, dz1,&
+               &u1, v1, th1, qv1, qc1, qi1, qni1,&! qnc1,&
+               &p1, ex1, thl, sqv, sqc, sqi, sqw,&
+               &ust(i,j),flt,flq,flqv,flqc,wspd(i,j),qcg(i,j),&
+               &uoce(i,j),voce(i,j),&
+               &tsq1, qsq1, cov1,&
+               &tcd, qcd, &
+               &dfm, dfh, dfq,&
+               &Du1, Dv1, Dth1, Dqv1, Dqc1, Dqi1, Dqni1& !, Dqnc1&
+               &,vdfg(i,j)&                 !JOE/Katata- fog deposition
+               &,FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC &
+               &)
+
+                !print*,"MYNN: qi_ten, qni_ten=",Dqi1(4),Dqni1(4)
+                !print*,"MYNN: qc_ten, qnc_ten=",Dqc1(4),Dqnc1(4)
 
           CALL retrieve_exchange_coeffs(kts,kte,&
-               &dfm(kts:kte),dfh(kts:kte),dfq(kts:kte),dz(i,kts:kte,j),&
-               &K_m(i,kts:kte,j),K_h(i,kts:kte,j),K_q(i,kts:kte,j))
+               &dfm, dfh, dfq, dz1,&
+               &K_m1, K_h1, K_q1)
 
-!JOE-TKE BUDGET
-          IF ( bl_mynn_tkebudget == 1) THEN
-             DO k=KTS,KTF
-                dqke(i,k,j)  = (qke(i,k,j)-dqke(i,k,j))*0.5  !qke->tke
-                qWT(i,k,j)   = qWT(i,k,j)*delt
-                qSHEAR(i,k,j)= qSHEAR(i,k,j)*delt
-                qBUOY(i,k,j) = qBUOY(i,k,j)*delt
-                qDISS(i,k,j) = qDISS(i,k,j)*delt
-             ENDDO
-          ENDIF
-!JOE-end
+          !UPDATE 3D ARRAYS
+          DO k=KTS,KTF
+             K_m(i,k,j)=K_m1(k)
+             K_h(i,k,j)=K_h1(k)
+             K_q(i,k,j)=K_q1(k)
+             du(i,k,j)=du1(k)
+             dv(i,k,j)=dv1(k)
+             dth(i,k,j)=dth1(k)
+             dqv(i,k,j)=dqv1(k)
+             dqc(i,k,j)=dqc1(k)
+             IF (PRESENT(qi) .AND. FLAG_QI) dqi(i,k,j)=dqi1(k)
+             !IF (PRESENT(qnc) .AND. FLAG_QNC) dqnc(i,k,j)=dqnc1(k)
+             IF (PRESENT(qni) .AND. FLAG_QNI) dqni(i,k,j)=dqni1(k)
+             el_pbl(i,k,j)=el(k)
+             qke(i,k,j)=qke1(k)
+             tsq(i,k,j)=tsq1(k)
+             qsq(i,k,j)=qsq1(k)
+             cov(i,k,j)=cov1(k)
+             sh3d(i,k,j)=sh(k)
+             IF ( bl_mynn_tkebudget == 1) THEN
+                dqke(i,k,j)  = (qke1(k)-dqke(i,k,j))*0.5  !qke->tke
+                qWT(i,k,j)   = qWT1(k)*delt
+                qSHEAR(i,k,j)= qSHEAR1(k)*delt
+                qBUOY(i,k,j) = qBUOY1(k)*delt
+                qDISS(i,k,j) = qDISS1(k)*delt
+             ENDIF
+             !***  Begin debugging
+!             IF ( sh(k) < 0. .OR. sh(k)> 200. .OR. &
+!                & qke(i,k,j) < -5. .OR. qke(i,k,j)> 200. .OR. &
+!                & el_pbl(i,k,j) < 0. .OR. el_pbl(i,k,j)> 2000. .OR. &
+!                & ABS(vt(k)) > 0.8 .OR. ABS(vq(k)) > 1100. .OR. &
+!                & k_m(i,k,j) < 0. .OR. k_m(i,k,j)> 2000. .OR. &
+!                & vdfg(i,j) < 0. .OR. vdfg(i,j)>5. ) THEN
+!                  PRINT*,"SUSPICIOUS VALUES AT: k=",k," sh=",sh(k)
+!                  PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",k_m(i,k,j)
+!                  PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j)
+!                  PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",tsq(i,k,j)
+!                  PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j)
+!                  PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i,j)
+!             ENDIF
+             !***  End debugging
+          ENDDO
+!JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.)
+!    TKE_PBL is defined on interfaces, while QKE is at middle of layer.
+          tke_pbl(i,kts,j) = 0.5*MAX(qke(i,kts,j),1.0e-10)
+          DO k = kts+1,kte
+             afk = dz1(k)/( dz1(k)+dz1(k-1) )
+             abk = 1.0 -afk
+             tke_pbl(i,k,j) = 0.5*MAX(qke(i,k,j)*abk+qke(i,k-1,j)*afk,1.0e-3)
+          ENDDO
+!JOE-end tke_pbl
+!JOE-end addition
+
+!***  Begin debugging
+!          IF(I==IMD .AND. J==JMD)THEN
+!             k=kdebug
+!             PRINT*,"MYNN DRIVER END: k=",1," sh=",sh(k)
+!             PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",k_m(i,k,j)
+!             PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j)
+!             PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",tsq(i,k,j)
+!             PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j)
+!             PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i,j)
+!          ENDIF
+!***  End debugging
 
        ENDDO
     ENDDO
@@ -2321,9 +2844,10 @@ END SUBROUTINE mynn_bl_driver
 
 ! ==================================================================
   SUBROUTINE mynn_bl_init_driver(&
-       &Du,Dv,Dth,&
-       &Dqv,Dqc&
-       &,RESTART,ALLOWED_TO_READ,LEVEL&
+       &Du,Dv,Dth,Dqv,Dqc,Dqi                       &
+       !&,Dqnc,Dqni                                  &
+       &,QKE,TKE_PBL,EXCH_H                         &
+       &,RESTART,ALLOWED_TO_READ,LEVEL              &
        &,IDS,IDE,JDS,JDE,KDS,KDE                    &
        &,IMS,IME,JMS,JME,KMS,KME                    &
        &,ITS,ITE,JTS,JTE,KTS,KTE)
@@ -2337,8 +2861,9 @@ SUBROUTINE mynn_bl_init_driver(&
          &                ITS,ITE,JTS,JTE,KTS,KTE
     
     
-    REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: &
-         &Du,Dv,Dth,Dqv,Dqc
+    REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: &
+         &Du,Dv,Dth,Dqv,Dqc,Dqi, & !Dqnc,Dqni,
+         &QKE,TKE_PBL,EXCH_H
 
     INTEGER :: I,J,K,ITF,JTF,KTF
     
@@ -2354,7 +2879,13 @@ SUBROUTINE mynn_bl_init_driver(&
                 Dv(i,k,j)=0.
                 Dth(i,k,j)=0.
                 Dqv(i,k,j)=0.
-                Dqc(i,k,j)=0.
+                if( p_qc >= param_first_scalar ) Dqc(i,k,j)=0.
+                if( p_qi >= param_first_scalar ) Dqi(i,k,j)=0.
+                !if( p_qnc >= param_first_scalar ) Dqnc(i,k,j)=0.
+                !if( p_qni >= param_first_scalar ) Dqni(i,k,j)=0.
+                QKE(i,k,j)=0.
+                TKE_PBL(i,k,j)=0.
+                EXCH_H(i,k,j)=0.
              ENDDO
           ENDDO
        ENDDO
@@ -2366,7 +2897,7 @@ END SUBROUTINE mynn_bl_init_driver
 
 ! ==================================================================
 
-  SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea)
+  SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi)
 
     !---------------------------------------------------------------
     !             NOTES ON THE PBLH FORMULATION
@@ -2395,7 +2926,12 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea)
     REAL :: delt_thv   !delta theta-v; dependent on land/sea point
     REAL, PARAMETER :: sbl_lim  = 200. !typical scale of stable BL (m).
     REAL, PARAMETER :: sbl_damp = 400. !transition length for blending (m).
-    INTEGER :: I,J,K,kthv,ktke
+    INTEGER :: I,J,K,kthv,ktke,kzi,kzi2
+
+    !ADD KPBL (kzi) for coupling to some Cu schemes, initialize at k=2                                  
+    !kzi2 is the TKE-based part of the hybrid KPBL                                                      
+    kzi = 1
+    kzi2= 1
 
     !FIND MAX TKE AND MIN THETAV IN THE LOWEST 500 M
     k = kts+1
@@ -2427,15 +2963,17 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea)
         delt_thv = 0.75
     ELSE         
         ! LAND     
-        delt_thv = 1.5  
+        delt_thv = 1.25
     ENDIF
 
     zi=0.
     k = kthv+1
     DO WHILE (zi .EQ. 0.) 
        IF (thetav1D(k) .GE. (minthv + delt_thv))THEN
+          kzi = MAX(k-1,1)
           zi = zw1D(k) - dz1D(k-1)* &
-             & MIN((thetav1D(k)-(minthv + delt_thv))/MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0)
+             & MIN((thetav1D(k)-(minthv + delt_thv))/ &
+             & MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0)
        ENDIF
        k = k+1
        IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD
@@ -2454,6 +2992,7 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea)
        qtke  =MAX(Qke1D(k)/2.,0.)      ! maximum TKE
        qtkem1=MAX(Qke1D(k-1)/2.,0.)
        IF (qtke .LE. TKEeps) THEN
+           kzi2 = MAX(k-1,1)
            PBLH_TKE = zw1D(k) - dz1D(k-1)* &
              & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0)
            !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL.
@@ -2469,12 +3008,16 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea)
     !so an artificial limit is imposed to not let PBLH_TKE exceed 4km.
     !This has no impact on 98-99% of the domain, but is the simplest patch
     !that adequately addresses these extremely large PBLHs.
-    PBLH_TKE = MIN(PBLH_TKE,4000.)
+    !PBLH_TKE = MIN(PBLH_TKE,4000.)
+    PBLH_TKE = MIN(PBLH_TKE,zi+500.)
 
     !BLEND THE TWO PBLH TYPES HERE: 
     wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5
     zi=PBLH_TKE*(1.-wt) + zi*wt
 
+    !ADD KPBL (kzi) for coupling to some Cu schemes
+     kzi = INT(kzi2*(1.-wt) + kzi*wt)
+
   END SUBROUTINE GET_PBLH
   
 ! ==================================================================
diff --git a/wrfv2_fire/phys/module_bl_temf.F b/wrfv2_fire/phys/module_bl_temf.F
index f8691151..a0ead6a5 100644
--- a/wrfv2_fire/phys/module_bl_temf.F
+++ b/wrfv2_fire/phys/module_bl_temf.F
@@ -356,23 +356,18 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
 !
 ! TE model constants
    logical, parameter :: MFopt = .true.  ! Use mass flux or not
-!   real, parameter :: visc_temf = 1.57e-5
-!   real, parameter :: conduc_temf = 1.57e-5 / 0.733
    real, parameter :: visc_temf = 1.57e-4   ! WA TEST bigger minimum K
    real, parameter :: conduc_temf = 1.57e-4 / 0.733
    real, parameter :: Pr_temf = 0.733
    real, parameter :: TEmin = 1e-3
    real, parameter :: ftau0 = 0.17
    real, parameter :: fth0 = 0.145
-!   real, parameter :: fth0 = 0.12    ! WA 10/13/10 to make PrT0 ~= 1
    real, parameter :: critRi = 0.25
    real, parameter :: Cf = 0.185
    real, parameter :: CN = 2.0
-!   real, parameter :: Ceps = ftau0**1.5
    real, parameter :: Ceps = 0.070
    real, parameter :: Cgamma = Ceps
    real, parameter :: Cphi = Ceps
-!   real, parameter :: PrT0 = Cphi/Ceps * ftau0**2. / 2 / fth0**2.
    real, parameter :: PrT0 = Cphi/Ceps * ftau0**2 / 2. / fth0**2
 ! EDMF constants
    real, parameter :: CM = 0.03      ! Proportionality constant for subcloud MF
@@ -391,8 +386,8 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
    real, dimension( its:ite)    ::  sfcTHVF
    real, dimension( its:ite)    ::  z0t
    integer, dimension( its:ite) ::  hdidx,lclidx,hctidx,htidx
+   integer, dimension( its:ite) ::  hmax_idx
    integer, dimension( its:ite) ::  tval
-   ! real, dimension( its:ite )   ::  sfcHF, sfcQF
    real, dimension( its:ite, kts:kte) :: thetal, qt
    real, dimension( its:ite, kts:kte) :: u_temf, v_temf
    real, dimension( its:ite, kts:kte) :: rv, rl, rt
@@ -425,7 +420,7 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
    real, dimension( its:ite, kts:kte) :: thup_new, qvup_new
    real, dimension( its:ite, kts:kte) :: beta1 ! For saturation humidity calculations
    real Cepsmf    ! Prefactor for entrainment rate
-   real red_fact  ! WA TEST for reducing MF components
+   real red_fact  ! for reducing MF components
    logical is_convective
    ! Vars for cloud fraction calculation
    real, dimension( its:ite, kts:kte) :: au, sigq, qst, satdef
@@ -462,9 +457,7 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
 !                                 z2d(1) - zsrf
 !
 ! WA I take the temperature at z0 to be
-! TSK.  This isn't exactly robust.  Also I pass out the surface
-! exchange coefficients flhc, flqc for the surface scheme to use in the 
-! next timestep.
+! TSK.  This isn't exactly robust.
 ! WA 2/16/11 removed calculation of flhc, flqc which are not needed here.
 ! These should be removed from the calling sequence someday.
 !
@@ -477,20 +470,13 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
 
       ! Get incoming surface theta from TSK (WA for now)
       thetal(i,1) = tsk(i) / pi2d(i,1)  ! WA really should use Exner func. at z0
-      if (exch_temfx(i) > 1.0e-12) then
-         qt(i,1) = qfx(i) / exch_temfx(i) + qvx(i,1)  ! WA assumes no liquid at z0
-      else
-         qt(i,1) = qvx(i,1)
-      end if
+      qt(i,1) = qvx(i,1)
       rv(i,1) = qt(i,1) / (1.-qt(i,1))   ! Water vapor
       rl(i,1) = 0.
       rt(i,1) = rv(i,1) + rl(i,1)        ! Total water (without ice)
       chi_poisson(i,1) = rcp * (1.+rv(i,1)/ep2) / (1.+rv(i,1)*cpv/cp)
       gam(i,1) = rv(i,1) * r_v / (cp + rv(i,1)*cpv)
-      ! thetav(i,1) = thetal(i,1) * (1. + 0.608*qt(i,1))  ! WA Assumes ql(env)=0, what if it isn't?
       thetav(i,1) = thetal(i,1) * (1. + 0.608*qt(i,1) - qcx(i,1))  ! WA 4/6/10 allow environment liquid
-      ! WA TEST (R5) set z0t = z0
-      ! z0t(i) = znt(i) / 10.0   ! WA this is hard coded in Matlab version
       z0t(i) = znt(i)
 
       ! Convert incoming theta to thetal and qv,qc to qt
@@ -502,9 +488,11 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
          rt(i,k) = rv(i,k) + rl(i,k)        ! Total water (without ice)
          chi_poisson(i,k) = rcp * (1.+rv(i,k)/ep2) / (1.+rv(i,k)*cpv/cp)
          gam(i,k) = rt(i,k) * r_v / (cp + rt(i,k)*cpv)
-         thetal(i,k) = thx(i,k-1) * ((ep2+rv(i,k))/(ep2+rt(i,k)))**chi_poisson(i,k) * (rv(i,k)/rt(i,k))**(-gam(i,k)) * exp( -xlv*rl(i,k) / ((cp + rt(i,k)*cpv) * tx(i,k)))
+         thetal(i,k) = thx(i,k-1) * &
+            ((ep2+rv(i,k))/(ep2+rt(i,k)))**chi_poisson(i,k) * &
+            (rv(i,k)/rt(i,k))**(-gam(i,k)) * exp( -xlv*rl(i,k) / &
+            ((cp + rt(i,k)*cpv) * tx(i,k)))
          qt(i,k) = qvx(i,k-1) + qcx(i,k-1)
-         ! thetav(i,k) = thetal(i,k) * (1. + 0.608*qt(i,k))  ! WA Assumes ql(env)=0, what if it isn't?
          thetav(i,k) = thetal(i,k) * (1. + 0.608*qt(i,k) - qcx(i,k-1))  ! WA 4/6/10 allow environment liquid
       end do
 
@@ -545,18 +533,15 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
       h0idx(i) = 1
       h0(i) = zm(i,1)
 
-      ! WA TEST (R4) remove lower limit on leps
-      ! lepsmin(i,kts) = min(0.4*zt(i,kts), 5.)
       lepsmin(i,kts) = 0.
 
+      ! WA 2/11/13 find index just above hmax for use below
+      hmax_idx(i) = kte-1
+
       do k = kts+1,kte-1
-         ! WA TEST (R4) remove lower limit on leps
-         ! lepsmin(i,k) = min(0.4*zt(i,k), 5.)
          lepsmin(i,k) = 0.
-         ! lepsmin(i,k) = min(zt(i,k), 20.)  ! WA to deal with runaway
 
          ! Mean gradients
-         ! dthdz(i,k) = (thx(i,k) - thx(i,k-1)) / dzt(i,k)  ! WA 1/12/10
          dthdz(i,k) = (thetal(i,k+1) - thetal(i,k)) / dzt(i,k)
          dqtdz(i,k) = (qt(i,k+1) - qt(i,k)) / dzt(i,k)
          dudz(i,k) = (u_temf(i,k+1) - u_temf(i,k)) / dzt(i,k)
@@ -573,6 +558,10 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
                h0(i) = hmax
             end if
          end if
+         ! WA 2/11/13 find index just above hmax for use below
+         if (zm(i,k) > hmax) then
+            hmax_idx(i) = min(hmax_idx(i),k)
+         end if
       end do
 
       ! Gradients at top level   
@@ -620,9 +609,12 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
          TKE(i,kt) = te_temfx(i,kt) * (1. - ratio(i,kt))
          ustrtilde(i,kt) = sqrt(ftau(i,kt) * TKE(i,kt))
          if (N2(i,kt) > 0.) then
-            linv(i,kt) = 1./karman / zt(i,kt) + abs(fCor(i)) / (Cf*ustrtilde(i,kt)) + sqrt(N2(i,kt))/(CN*ustrtilde(i,kt)) + 1./lasymp  ! WA Test 11/20/09
+            linv(i,kt) = 1./karman / zt(i,kt) + abs(fCor(i)) / &
+               (Cf*ustrtilde(i,kt)) + &
+               sqrt(N2(i,kt))/(CN*ustrtilde(i,kt)) + 1./lasymp
          else
-            linv(i,kt) = 1./karman / zt(i,kt) + abs(fCor(i)) / (Cf*ustrtilde(i,kt)) + 1./lasymp  ! WA Test 11/20/09
+            linv(i,kt) = 1./karman / zt(i,kt) + abs(fCor(i)) / &
+               (Cf*ustrtilde(i,kt)) + 1./lasymp
          end if
          leps(i,kt) = 1./linv(i,kt)
          leps(i,kt) = max(leps(i,kt),lepsmin(i,kt))
@@ -649,7 +641,8 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
          km(i,kt) = TKE(i,kt)**1.5 * ftau(i,kt)**2. / (Ceps * sqrt(TKE(i,kt)*te_temfx(i,kt)) / leps(i,kt))
          kh(i,kt) = 2. * leps(i,kt) * fth(i,kt)**2. * TKE(i,kt) / sqrt(te_temfx(i,kt)) / Cphi
          if ( is_convective) then
-            if (kt <= h0idx(i)) then
+            ! WA 2/20/14 trap rare "equality" of h0 and zt (only when h0 = hmax)
+            if (kt <= h0idx(i) .AND. h0(i)-zt(i,kt) > 1e-15) then
                lconv(i,kt) = 1. / (1. / (karman*zt(i,kt)) + Cc / (karman * (h0(i) - zt(i,kt))))
             else
                lconv(i,kt) = 0.
@@ -664,7 +657,6 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
                km(i,kt) = km_conv(i,kt)
                kh(i,kt) = kh_conv(i,kt)
             end if
-            ! WA TEST 1/11/10 go back to max in upper BL
             if (zt(i,kt) > h0(i)/2. .AND. kt <= h0idx(i)) then
                km(i,kt) = max(km(i,kt),km_conv(i,kt),visc_temf)
                kh(i,kt) = max(kh(i,kt),kh_conv(i,kt),conduc_temf)
@@ -674,9 +666,9 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
          kh(i,kt) = max(kh(i,kt),conduc_temf)
          Fz(i,kt) = -kh(i,kt) * dthdz(i,kt)  ! Diffusive heat flux
       end do
-      km(i,kte) = km(i,kte-1)  ! WA 12/22/09
+      km(i,kte) = km(i,kte-1)
       kh(i,kte) = kh(i,kte-1)
-      Fz(i,kte) = 0.0          ! WA 4/2/10
+      Fz(i,kte) = 0.0
 
 
       !*** Mass flux block starts here ***
@@ -684,7 +676,7 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
       if ( is_convective) then
 
          Cepsmf = 2. / max(200.,h0(i))
-         Cepsmf = max(Cepsmf,0.002)    ! WA 7/20/10
+         Cepsmf = max(Cepsmf,0.002)
          do k = kts,kte
             ! Calculate lateral entrainment fraction for subcloud layer
             ! epsilon and delta are defined on mass grid (half levels)
@@ -702,7 +694,6 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
          thetavUPD(i,1) = thup_temfx(i,1) * (1. + 0.608*qtup_temfx(i,1))  ! WA Assumes no liquid
          thetavUPDmoist(i,1) = thup_temfx(i,1) * (1. + 0.608*qtup_temfx(i,1))  ! WA Assumes no liquid
          TEUPD(i,1) = te_temfx(i,1) + g / thetav(i,1) * sfcTHVF(i)
-         ! qlUPD(i,1) = 0.
          qlUPD(i,1) = qcx(i,1)  ! WA allow environment liquid
          TUPD(i,1) = thup_temfx(i,1) * pi2d(i,1)   
          rstUPD(i,1) = rsat(p2d(i,1),TUPD(i,1),ep2)  
@@ -710,53 +701,63 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
 
          ! Calculate updraft parameters counting up
          do k = 2,kte
-            dthUPDdz(i,k-1) = -epsmf(i,k) * (thup_temfx(i,k-1) - thetal(i,k-1))
-            thup_temfx(i,k) = thup_temfx(i,k-1) + dthUPDdz(i,k-1) * dzm(i,k-1)
-            dqtup_temfxdz(i,k-1) = -epsmf(i,k) * (qtup_temfx(i,k-1) - qt(i,k-1))
-            qtup_temfx(i,k) = qtup_temfx(i,k-1) + dqtup_temfxdz(i,k-1) * dzm(i,k-1)
-            thetavUPD(i,k) = thup_temfx(i,k) * (1. + 0.608*qtup_temfx(i,k))  ! WA Assumes no liquid
-            B(i,k-1) = g * (thetavUPD(i,k) - thetav(i,k)) / thetav(i,k)
-            if ( wupd_dry(i,k-1) < 1e-15 ) then
-               wupd_dry(i,k) = 0.
-            else
-               dwUPDdz(i,k-1) = -2. *epsmf(i,k)*wupd_dry(i,k-1) + 0.33*B(i,k-1)/wupd_dry(i,k-1)
-               wupd_dry(i,k) = wupd_dry(i,k-1) + dwUPDdz(i,k-1) * dzm(i,k-1)
-            end if
-            dUUPDdz(i,k-1) = -epsmf(i,k) * (UUPD(i,k-1) - u_temf(i,k-1))
-            UUPD(i,k) = UUPD(i,k-1) + dUUPDdz(i,k-1) * dzm(i,k-1)
-            dVUPDdz(i,k-1) = -epsmf(i,k) * (VUPD(i,k-1) - v_temf(i,k-1))
-            VUPD(i,k) = VUPD(i,k-1) + dVUPDdz(i,k-1) * dzm(i,k-1)
-            dTEUPDdz(i,k-1) = -epsmf(i,k) * (TEUPD(i,k-1) - te_temfx(i,k-1))
-            TEUPD(i,k) = TEUPD(i,k-1) + dTEUPDdz(i,k-1) * dzm(i,k-1)
-            ! Alternative updraft velocity based on moist thetav
-            ! Need thetavUPDmoist, qlUPD
-            rUPD(i,k) = qtup_temfx(i,k) / (1. - qtup_temfx(i,k))
-            ! WA Updraft temperature assuming no liquid
-            TUPD(i,k) = thup_temfx(i,k) * pi2d(i,k)   
-            ! Updraft saturation mixing ratio 
-            ! rstUPD(i,k) = rsat(p2d(i,k),TUPD(i,k),ep2)  ! WA 4/19/10
-            rstUPD(i,k) = rsat(p2d(i,k-1),TUPD(i,k),ep2)  
-            ! Correct to actual temperature (Sommeria & Deardorff 1977)
-            beta1(i,k) = 0.622 * (xlv/(r_d*TUPD(i,k))) * (xlv/(cp*TUPD(i,k)))
-            rstUPD(i,k) = rstUPD(i,k) * (1.0+beta1(i,k)*rUPD(i,k)) / (1.0+beta1(i,k)*rstUPD(i,k))
-            qstUPD(i,k) = rstUPD(i,k) / (1. + rstUPD(i,k))
-            if (rUPD(i,k) > rstUPD(i,k)) then
-               rlUPD(i,k) = rUPD(i,k) - rstUPD(i,k)
-               qlUPD(i,k) = rlUPD(i,k) / (1. + rlUPD(i,k))
-               thetavUPDmoist(i,k) = (thup_temfx(i,k) + ((xlv/cp)*qlUPD(i,k)/pi2d(i,k))) * (1. + 0.608*qstUPD(i,k) - qlUPD(i,k))
+            ! WA 2/11/13 use hmax index to prevent oddness high up
+            if ( k < hmax_idx(i)) then
+               dthUPDdz(i,k-1) = -epsmf(i,k) * (thup_temfx(i,k-1) - thetal(i,k-1))
+               thup_temfx(i,k) = thup_temfx(i,k-1) + dthUPDdz(i,k-1) * dzm(i,k-1)
+               dqtup_temfxdz(i,k-1) = -epsmf(i,k) * (qtup_temfx(i,k-1) - qt(i,k-1))
+               qtup_temfx(i,k) = qtup_temfx(i,k-1) + dqtup_temfxdz(i,k-1) * dzm(i,k-1)
+               thetavUPD(i,k) = thup_temfx(i,k) * (1. + 0.608*qtup_temfx(i,k))  ! WA Assumes no liquid
+               B(i,k-1) = g * (thetavUPD(i,k) - thetav(i,k)) / thetav(i,k)
+               if ( wupd_dry(i,k-1) < 1e-15 ) then
+                  wupd_dry(i,k) = 0.
+               else
+                  dwUPDdz(i,k-1) = -2. *epsmf(i,k)*wupd_dry(i,k-1) + 0.33*B(i,k-1)/wupd_dry(i,k-1)
+                  wupd_dry(i,k) = wupd_dry(i,k-1) + dwUPDdz(i,k-1) * dzm(i,k-1)
+               end if
+               dUUPDdz(i,k-1) = -epsmf(i,k) * (UUPD(i,k-1) - u_temf(i,k-1))
+               UUPD(i,k) = UUPD(i,k-1) + dUUPDdz(i,k-1) * dzm(i,k-1)
+               dVUPDdz(i,k-1) = -epsmf(i,k) * (VUPD(i,k-1) - v_temf(i,k-1))
+               VUPD(i,k) = VUPD(i,k-1) + dVUPDdz(i,k-1) * dzm(i,k-1)
+               dTEUPDdz(i,k-1) = -epsmf(i,k) * (TEUPD(i,k-1) - te_temfx(i,k-1))
+               TEUPD(i,k) = TEUPD(i,k-1) + dTEUPDdz(i,k-1) * dzm(i,k-1)
+               ! Alternative updraft velocity based on moist thetav
+               ! Need thetavUPDmoist, qlUPD
+               rUPD(i,k) = qtup_temfx(i,k) / (1. - qtup_temfx(i,k))
+               ! WA Updraft temperature assuming no liquid
+               TUPD(i,k) = thup_temfx(i,k) * pi2d(i,k)   
+               ! Updraft saturation mixing ratio 
+               rstUPD(i,k) = rsat(p2d(i,k-1),TUPD(i,k),ep2)  
+               ! Correct to actual temperature (Sommeria & Deardorff 1977)
+               beta1(i,k) = 0.622 * (xlv/(r_d*TUPD(i,k))) * (xlv/(cp*TUPD(i,k)))
+               rstUPD(i,k) = rstUPD(i,k) * (1.0+beta1(i,k)*rUPD(i,k)) / (1.0+beta1(i,k)*rstUPD(i,k))
+               qstUPD(i,k) = rstUPD(i,k) / (1. + rstUPD(i,k))
+               if (rUPD(i,k) > rstUPD(i,k)) then
+                  rlUPD(i,k) = rUPD(i,k) - rstUPD(i,k)
+                  qlUPD(i,k) = rlUPD(i,k) / (1. + rlUPD(i,k))
+                  thetavUPDmoist(i,k) = (thup_temfx(i,k) + ((xlv/cp)*qlUPD(i,k)/pi2d(i,k))) * &
+                                        (1. + 0.608*qstUPD(i,k) - qlUPD(i,k))
+               else
+                  rlUPD(i,k) = 0.
+                  qlUPD(i,k) = qcx(i,k-1)   ! WA 4/6/10 allow environment liquid
+                  thetavUPDmoist(i,k) = thup_temfx(i,k) * (1. + 0.608*qtup_temfx(i,k))
+               end if
+               Bmoist(i,k-1) = g * (thetavUPDmoist(i,k) - thetav(i,k)) / thetav(i,k)
+               if ( wupd_temfx(i,k-1) < 1e-15 ) then
+                  wupd_temfx(i,k) = 0.
+               else
+                  dwUPDmoistdz(i,k-1) = -2. *epsmf(i,k)*wupd_temfx(i,k-1) + 0.33*Bmoist(i,k-1)/wupd_temfx(i,k-1)
+                  wupd_temfx(i,k) = wupd_temfx(i,k-1) + dwUPDmoistdz(i,k-1) * dzm(i,k-1)
+               end if
             else
-               rlUPD(i,k) = 0.
-               ! qlUPD(i,k) = 0.
-               qlUPD(i,k) = qcx(i,k-1)   ! WA 4/6/10 allow environment liquid
-               ! WA does this make sense?  Should be covered above?
-               thetavUPDmoist(i,k) = thup_temfx(i,k) * (1. + 0.608*qtup_temfx(i,k))
-            end if
-            Bmoist(i,k-1) = g * (thetavUPDmoist(i,k) - thetav(i,k)) / thetav(i,k)
-            if ( wupd_temfx(i,k-1) < 1e-15 ) then
+               thup_temfx(i,k) = thetal(i,k)
+               qtup_temfx(i,k) = qt(i,k)
+               wupd_dry(i,k) = 0.
+               UUPD(i,k) = u_temf(i,k)
+               VUPD(i,k) = v_temf(i,k)
+               TEUPD(i,k) = te_temfx(i,k)
+               qlUPD(i,k) = qcx(i,k-1)
                wupd_temfx(i,k) = 0.
-            else
-               dwUPDmoistdz(i,k-1) = -2. *epsmf(i,k)*wupd_temfx(i,k-1) + 0.33*Bmoist(i,k-1)/wupd_temfx(i,k-1)
-               wupd_temfx(i,k) = wupd_temfx(i,k-1) + dwUPDmoistdz(i,k-1) * dzm(i,k-1)
             end if
          end do
 
@@ -767,21 +768,20 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
             hdidx(i) = kte  ! In case wUPD <= 0 not found
             do k = 2,kte
                ! if (wupd_dry(i,k) <= 0.) then
-               if (wupd_dry(i,k) <= 0. .OR. zm(i,k) > hmax) then  ! WA Test
+               if (wupd_dry(i,k) <= 0. .OR. zm(i,k) > hmax) then 
                   hdidx(i) = k
                   goto 100   ! FORTRAN made me do it!
                end if
             end do
          end if
 100      hd(i) = zm(i,hdidx(i))
-         ! kpbl1d(i) = hd(i)        ! WA not sure if this is what I want for diagnostic out to larger WRF universe....and it's not right if not convective
-         kpbl1d(i) = hdidx(i)  ! WA 5/11/10 kpbl should be index
+         kpbl1d(i) = hdidx(i)
          hpbl(i) = hd(i)       ! WA 5/11/10 hpbl is height.  Should still be replaced by something that works whether convective or not.
 
          ! Find LCL, hct, and ht
          lclidx(i) = kte   ! In case LCL not found
          do k = kts,kte
-            if (rUPD(i,k) > rstUPD(i,k)) then
+            if ( k < hmax_idx(i) .AND. rUPD(i,k) > rstUPD(i,k)) then
                lclidx(i) = k
                goto 200
             end if
@@ -795,7 +795,7 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
             else
                hctidx(i) = kte  ! In case wUPD <= 0 not found
                do k = 2,kte
-                  if (wupd_temfx(i,k) <= 0. .OR. zm(i,k) > hmax) then  ! WA Test
+                  if (wupd_temfx(i,k) <= 0. .OR. zm(i,k) > hmax) then
                      hctidx(i) = k
                      goto 300   ! FORTRAN made me do it!
                   end if
@@ -827,7 +827,10 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
             thup_temfx(i,k) = tval(i) * thup_temfx(i,k) + (1-tval(i))*thetal(i,k)
             thetavUPD(i,k) = tval(i) * thetavUPD(i,k) + (1-tval(i))*thetav(i,k)
             qtup_temfx(i,k) = tval(i) * qtup_temfx(i,k) + (1-tval(i)) * qt(i,k)
-            qlUPD(i,k) = tval(i) * qlUPD(i,k) + (1-tval(i)) * qcx(i,k-1)
+            ! WA 6/21/13 was a subscript error when k=1
+            if (k > 1) then
+               qlUPD(i,k) = tval(i) * qlUPD(i,k) + (1-tval(i)) * qcx(i,k-1)
+            end if
             UUPD(i,k) = tval(i) * UUPD(i,k) + (1-tval(i)) * u_temf(i,k)
             VUPD(i,k) = tval(i) * VUPD(i,k) + (1-tval(i)) * v_temf(i,k)
             TEUPD(i,k) = tval(i) * TEUPD(i,k) + (1-tval(i)) * te_temfx(i,k)
@@ -843,7 +846,8 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
          deltmf(i,1) = Cepsmf
          do k = 2,kte-1
             if (hctidx(i) > hdidx(i)+1) then      ! Some cloud
-               deltmf(i,k) = 0.9 * Cepsmf + Cdelt * (atan((zm(i,k)-(lcl(i)+(hct(i)-lcl(i))/1.5))/((hct(i)-lcl(i))/8))+(3.1415926/2))/3.1415926
+               deltmf(i,k) = 0.9 * Cepsmf + Cdelt * (atan((zm(i,k)-(lcl(i)+(hct(i)-lcl(i))/1.5))/ &
+                                                          ((hct(i)-lcl(i))/8))+(3.1415926/2))/3.1415926
             else if (k < hdidx(i)) then   ! No cloud, below hd
                deltmf(i,k) = Cepsmf + 0.05 * 1. / (hd(i) - zm(i,k))
             else if (k >= hdidx(i)) then    ! No cloud, above hd
@@ -871,12 +875,24 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
 
          ! Calculate mass flux contributions to fluxes (defined on turb levels)
          ! Use log interpolation at first level
-         MFCth(i,1) = mf_temfx(i,1) * (thup_temfx(i,1)-thetal(i,1) + (thup_temfx(i,2)-thetal(i,2) - (thup_temfx(i,1)-thetal(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
-         MFCq(i,1) = mf_temfx(i,1) * (qtup_temfx(i,1)-qt(i,1) + (qtup_temfx(i,2)-qt(i,2) - (qtup_temfx(i,1)-qt(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
-         MFCu(i,1) = mf_temfx(i,1) * (UUPD(i,1)-u_temf(i,1) + (UUPD(i,2)-u_temf(i,2) - (UUPD(i,1)-u_temf(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
-         MFCv(i,1) = mf_temfx(i,1) * (VUPD(i,1)-v_temf(i,1) + (VUPD(i,2)-v_temf(i,2) - (VUPD(i,1)-v_temf(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
-         MFCql(i,1) = mf_temfx(i,1) * (qlUPD(i,1)-qcx(i,1) + (qlUPD(i,2)-qcx(i,2) - (qlUPD(i,1)-qcx(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
-         MFCTE(i,1) = mf_temfx(i,1) * (TEUPD(i,1)-te_temfx(i,1) + (TEUPD(i,2)-te_temfx(i,2) - (TEUPD(i,1)-te_temfx(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))  ! WA Check this
+         MFCth(i,1) = mf_temfx(i,1) * (thup_temfx(i,1)-thetal(i,1) &
+            + (thup_temfx(i,2)-thetal(i,2) - &
+            (thup_temfx(i,1)-thetal(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
+         MFCq(i,1) = mf_temfx(i,1) * (qtup_temfx(i,1)-qt(i,1) &
+            + (qtup_temfx(i,2)-qt(i,2) - &
+            (qtup_temfx(i,1)-qt(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
+         MFCu(i,1) = mf_temfx(i,1) * (UUPD(i,1)-u_temf(i,1) &
+            + (UUPD(i,2)-u_temf(i,2) - &
+            (UUPD(i,1)-u_temf(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
+         MFCv(i,1) = mf_temfx(i,1) * (VUPD(i,1)-v_temf(i,1) &
+            + (VUPD(i,2)-v_temf(i,2) - &
+            (VUPD(i,1)-v_temf(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
+         MFCql(i,1) = mf_temfx(i,1) * (qlUPD(i,1)-qcx(i,1) &
+            + (qlUPD(i,2)-qcx(i,2) - &
+            (qlUPD(i,1)-qcx(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))
+         MFCTE(i,1) = mf_temfx(i,1) * (TEUPD(i,1)-te_temfx(i,1) &
+            + (TEUPD(i,2)-te_temfx(i,2) - &
+            (TEUPD(i,1)-te_temfx(i,1))) * log(zt(i,1)/znt(i))/log(zm(i,2)/znt(i)))  ! WA Check this
          do kt = 2,kte-1
             MFCth(i,kt) = mf_temfx(i,kt) * (thup_temfx(i,kt)-thetal(i,kt) + thup_temfx(i,kt+1)-thetal(i,kt+1)) / 2.
             MFCq(i,kt) = mf_temfx(i,kt) * (qtup_temfx(i,kt)-qt(i,kt) + qtup_temfx(i,kt+1)-qt(i,kt+1)) / 2.
@@ -977,28 +993,29 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
       end do
 
       ! Surface momentum fluxes
-      ust(i) = sqrt(ftau(i,1)/ftau0) * sqrt(u_temf(i,2)**2. + v_temf(i,2)**2.) * leps(i,1) / log(zm(i,2)/znt(i)) / zt(i,1)
+      ! WA TEST 11/7/13 use w* as a component of the mean wind inside the
+      ! u* calculation instead of in the velocity scale below (Felix)
+      ! ust(i) = sqrt(ftau(i,1)/ftau0) * sqrt(u_temf(i,2)**2. + v_temf(i,2)**2.) * leps(i,1) / log(zm(i,2)/znt(i)) / zt(i,1)
+      ust(i) = sqrt(ftau(i,1)/ftau0) * sqrt(u_temf(i,2)**2. + v_temf(i,2)**2. + (0.5*wstr(i))**2.) * leps(i,1) / log(zm(i,2)/znt(i)) / zt(i,1)
+
       ang(i) = atan2(v_temf(i,2),u_temf(i,2))
       uw_temfx(i,1) = -cos(ang(i)) * ust(i)**2.
       vw_temfx(i,1) = -sin(ang(i)) * ust(i)**2.
 
       ! Calculate mixed scaling velocity (Moeng & Sullivan 1994 JAS p.1021)
-      ! Replaces ust everywhere (WA need to reconsider?)
-      ! wm(i) = (1./5. * (wstr(i)**3. + 5. * ust(i)**3.)) ** (1./3.) 
-      ! WA TEST (R2,R11) 7/23/10 reduce velocity scale to fix excessive fluxes
-      wm(i) = 0.5 * (1./5. * (wstr(i)**3. + 5. * ust(i)**3.)) ** (1./3.) 
-      ! WA TEST 2/14/11 limit contribution of w*
-      ! wm(i) = 0.5 * (1./5. * (min(0.8,wstr(i))**3. + 5. * ust(i)**3.)) ** (1./3.) 
-      ! WA TEST (R3-R11) 7/23/10 wm = u*
-      ! wm(i) = ust(i)
+      ! Replaces ust everywhere
+      ! WA TEST 11/7/13 back to wm = u* but with "whole" wind in u* above
+      wm(i) = ust(i)
+      ! WA 7/23/10 reduce velocity scale to fix excessive fluxes
+      ! wm(i) = 0.5 * (1./5. * (wstr(i)**3. + 5. * ust(i)**3.)) ** (1./3.) 
 
       ! Specified flux versions (flux is modified by land surface)
-      shf_temfx(i,1) = hfx(i)/(rho(i,1)*cp) + (shf_temfx(i,2) - hfx(i)/(rho(i,1)*cp)) * (zt(i,2)-zt(i,1)) / (zt(i,2)-znt(i))
-      qf_temfx(i,1) = qfx(i)/rho(i,1) + (qf_temfx(i,2)-qfx(i)/rho(i,1)) * (zt(i,2)-zt(i,1)) / (zt(i,2)-znt(i))
+      ! WA 5/31/13 use whole surface flux to improve heat conservation
+      shf_temfx(i,1) = hfx(i)/(rho(i,1)*cp)
+      qf_temfx(i,1) = qfx(i)/rho(i,1)
       Fz(i,1) = shf_temfx(i,1) - MFCth(i,1)
       QFK(i,1) = qf_temfx(i,1) - MFCq(i,1)
 
-
       ! Calculate thetav and its flux
       ! From Lewellen 2004 eq. 3
       ! WA The constants and combinations below should probably be replaced
@@ -1010,11 +1027,14 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
       end do
       alpha2(i,1) = 0.61 * (thetal(i,1) + (thetal(i,2)-thetal(i,1)) * (zt(i,2) - znt(i)) / (zm(i,2) - znt(i)))
       alpha2(i,kte) = 0.61 * thetal(i,kte)
-      beta2(i,1) = (100000. / p2di(i,1))**0.286 * 2.45e-6 / 1004.67 - 1.61 * (thetal(i,1) + (thetal(i,2) - thetal(i,1))  * (zt(i,2) - znt(i)) / (zm(i,2) - znt(i)))
+      beta2(i,1) = (100000. / p2di(i,1))**0.286 * 2.45e-6 / &
+         1004.67 - 1.61 * (thetal(i,1) + (thetal(i,2) - thetal(i,1)) &
+         * (zt(i,2) - znt(i)) / (zm(i,2) - znt(i)))
       beta2(i,kte) = (100000. / p2di(i,kte))**0.286 * 2.45e-6 / 1004.67 - 1.61 * thetal(i,kte)
       if ( is_convective ) then ! Activate EDMF components
          do kt = 1,kte-1
-            MFCthv(i,kt) = (1. + 0.61 * (qtup_temfx(i,kt)+qtup_temfx(i,kt+1))) / 2. * MFCth(i,kt) + alpha2(i,kt) * MFCq(i,kt) + beta2(i,kt) * MFCql(i,kt)
+            MFCthv(i,kt) = (1. + 0.61 * (qtup_temfx(i,kt)+qtup_temfx(i,kt+1))) / 2. * MFCth(i,kt) + &
+                           alpha2(i,kt) * MFCq(i,kt) + beta2(i,kt) * MFCql(i,kt)
          end do
          MFCthv(i,kte) = 0.
       else    ! No MF components
@@ -1034,23 +1054,27 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
       ! in Matlab code are now handled by WRF outside this PBL context.
 
       u_new(i,:) = u_temf(i,:)
-      call solve_implicit_temf(km(i,kts:kte-1),u_new(i,kts+1:kte),uw_temfx(i,1),dzm(i,kts:kte-1),dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
+      call solve_implicit_temf(km(i,kts:kte-1),u_new(i,kts+1:kte), &
+         uw_temfx(i,1),dzm(i,kts:kte-1),dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
       do k = 2,kte-1
          u_new(i,k) = u_new(i,k) + dt * (-(MFCu(i,k)-MFCu(i,k-1))) / dzm(i,k)
       end do
 
       v_new(i,:) = v_temf(i,:)
-      call solve_implicit_temf(km(i,kts:kte-1),v_new(i,kts+1:kte),vw_temfx(i,1),dzm(i,kts:kte-1),dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
+      call solve_implicit_temf(km(i,kts:kte-1),v_new(i,kts+1:kte), &
+         vw_temfx(i,1),dzm(i,kts:kte-1),dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
       do k = 2,kte-1
          v_new(i,k) = v_new(i,k) + dt * (-(MFCv(i,k)-MFCv(i,k-1))) / dzm(i,k)
       end do
 
-      call solve_implicit_temf(kh(i,kts:kte-1),thetal(i,kts+1:kte),Fz(i,1),dzm(i,kts:kte-1),dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
+      call solve_implicit_temf(kh(i,kts:kte-1),thetal(i,kts+1:kte),Fz(i,1),dzm(i,kts:kte-1),&
+                               dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
       do k = 2,kte-1
          thetal(i,k) = thetal(i,k) + dt * (-(MFCth(i,k)-MFCth(i,k-1))) / dzm(i,k)
       end do
 
-      call solve_implicit_temf(kh(i,kts:kte-1),qt(i,kts+1:kte),QFK(i,1),dzm(i,kts:kte-1),dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
+      call solve_implicit_temf(kh(i,kts:kte-1),qt(i,kts+1:kte),QFK(i,1),dzm(i,kts:kte-1),&
+                               dzt(i,kts:kte-1),kts,kte-1,dt,.FALSE.)
       do k = 2,kte-1
          qt(i,k) = qt(i,k) + dt * (-(MFCq(i,k)-MFCq(i,k-1))) / dzm(i,k)
       end do
@@ -1063,7 +1087,8 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
       else
          convection_TKE_surface_src(i) = 0.
       end if
-      te_temfx(i,1) = max(te_temfx(i,1), (leps(i,1) / Cgamma * (ust(i)**2. * S(i,1) + convection_TKE_surface_src(i)))**(2./3.))
+      te_temfx(i,1) = max(te_temfx(i,1), &
+                          (leps(i,1) / Cgamma * (ust(i)**2. * S(i,1) + convection_TKE_surface_src(i)))**(2./3.))
       if (te_temfx(i,1) > 20.0) then
          te_temfx(i,1) = 20.0    ! WA 9/28/11 limit max TE
       end if
@@ -1075,15 +1100,17 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
          else
             buoy_src(i,kt) = 0.  ! Cancel buoyancy term when locally stable
          end if
-         srcs(i,kt) = -uw_temfx(i,kt) * dudz(i,kt) - vw_temfx(i,kt) * dvdz(i,kt) - Cgamma * te_temfx(i,kt)**1.5 * linv(i,kt) + buoy_src(i,kt)
+         srcs(i,kt) = -uw_temfx(i,kt) * dudz(i,kt) - vw_temfx(i,kt) * dvdz(i,kt) - &
+                      Cgamma * te_temfx(i,kt)**1.5 * linv(i,kt) + buoy_src(i,kt)
       end do
-      call solve_implicit_temf((km(i,kts:kte-1)+km(i,kts+1:kte))/2.0,te_temfx(i,kts+1:kte),sfcFTE(i),dzt(i,kts+1:kte),dzt(i,kts:kte-1),kts,kte-1,dt,.false.)
+      call solve_implicit_temf((km(i,kts:kte-1)+km(i,kts+1:kte))/2.0, &
+         te_temfx(i,kts+1:kte),sfcFTE(i),dzt(i,kts+1:kte),dzt(i,kts:kte-1),kts,kte-1,dt,.false.)
       do kt = 2,kte-1
          te_temfx(i,kt) = te_temfx(i,kt) + dt * srcs(i,kt)
          te_temfx(i,kt) = te_temfx(i,kt) + dt * (-(MFCTE(i,kt)-MFCTE(i,kt-1))) / dzt(i,kt)
          if (te_temfx(i,kt) < TEmin) te_temfx(i,kt) = TEmin
       end do
-      te_temfx(i,kte) = 0.0   ! WA 4/2/10
+      te_temfx(i,kte) = 0.0
       do kt = 2,kte-1
          if (te_temfx(i,kt) > 20.0) then
             te_temfx(i,kt) = 20.0    ! WA 9/29/11 reduce limit max TE from 30
@@ -1101,7 +1128,9 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
       ! See opposite conversion at top of subroutine
       ! WA this accounts for offset of indexing between
       ! WRF and TEMF, see notes at top of this routine.
-      call thlqt2thqvqc(thetal(i,kts+1:kte),qt(i,kts+1:kte),thx_new(i,kts:kte-1),qvx_new(i,kts:kte-1),qcx_new(i,kts:kte-1),p2d(i,kts:kte-1),pi2d(i,kts:kte-1),kts,kte-1,ep2,xlv,cp)
+      call thlqt2thqvqc(thetal(i,kts+1:kte),qt(i,kts+1:kte), &
+         thx_new(i,kts:kte-1),qvx_new(i,kts:kte-1),qcx_new(i,kts:kte-1), &
+         p2d(i,kts:kte-1),pi2d(i,kts:kte-1),kts,kte-1,ep2,xlv,cp)
 
       do k = kts,kte-1
          ! Calculate tendency terms
@@ -1121,17 +1150,7 @@ subroutine temf2d(j,ux,vx,tx,thx,qvx,qcx,qix,p2d,p2di,pi2d,rho,            &
 
       ! Populate surface exchange coefficient variables to go back out
       ! for next time step of surface scheme
-      ! Unit specifications in SLAB and sfclay are conflicting and probably
-      ! incorrect.  This will give a dynamic heat flux (W/m^2) or moisture
-      ! flux (kg(water)/(m^2*s)) when multiplied by a difference.
-      ! These formulae are the same as what's used above to get surface
-      ! flux from surface temperature and specific humidity.
       ! WA 2/16/11 removed, not needed in BL
-      ! flhc(i) = rho(i,1) * cp * fth(i,1)/fth0 * wm(i) * leps(i,1) / PrT0 / log(zm(i,2)/z0t(i)) / zt(i,1)
-      ! flqc(i)  = rho(i,1) * fth(i,1)/fth0 * wm(i) * leps(i,1) / PrT0 / log(zm(i,2)/z0t(i)) / zt(i,1)
-      ! WA Must exchange coeffs be limited to avoid runaway in some 
-      ! (convective?) conditions?  Something like this is done in sfclay.
-      ! Doing nothing for now.
 
       ! Populate 10 m winds and 2 m temp
       ! WA Note this only works if first mass level is above 10 m
diff --git a/wrfv2_fire/phys/module_bl_ysu.F b/wrfv2_fire/phys/module_bl_ysu.F
index 537c58d6..f682615d 100644
--- a/wrfv2_fire/phys/module_bl_ysu.F
+++ b/wrfv2_fire/phys/module_bl_ysu.F
@@ -24,6 +24,7 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,               &
                   exch_h,                                                      &
                   wstar,delta,                                                 &
                   u10,v10,                                                     &
+                  uoce,voce,                                                   &        
                   ctopo,ctopo2,                                                &
                   ids,ide, jds,jde, kds,kde,                                   &
                   ims,ime, jms,jme, kms,kme,                                   &
@@ -77,6 +78,8 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,               &
 !-- wspd        wind speed at lowest model level (m/s)
 !-- u10         u-wind speed at 10 m (m/s)
 !-- v10         v-wind speed at 10 m (m/s)
+!-- uoce        sea surface zonal currents (m s-1)
+!-- voce        sea surface meridional currents (m s-1)
 !-- br          bulk richardson number in surface layer
 !-- dt          time step (s)
 !-- rvovrd      r_v divided by r_d (dimensionless)
@@ -142,6 +145,9 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,               &
    real,     dimension( ims:ime, jms:jme )                                   , &
              intent(inout)   ::                                           u10, &
                                                                           v10
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(in   )   ::                                          uoce, &
+                                                                         voce
 !
    real,     dimension( ims:ime, jms:jme )                                   , &
              intent(in   )   ::                                         xland, &
@@ -256,6 +262,7 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,               &
               ,wstar=wstar(ims,j)                                              &
               ,delta=delta(ims,j)                                              &
               ,u10=u10(ims,j),v10=v10(ims,j)                                   &
+              ,uox=uoce(ims,j),vox=voce(ims,j)                                 &
               ,ctopo=ctopo(ims,j),ctopo2=ctopo2(ims,j)                         &
               ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde               &
               ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme               &
@@ -287,6 +294,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d,                               &
                   exch_hx,                                                     &
                   wstar,delta,                                                 &
                   u10,v10,                                                     &
+                  uox,vox,                                                     &
                   ctopo,ctopo2,                                                &
                   ids,ide, jds,jde, kds,kde,                                   &
                   ims,ime, jms,jme, kms,kme,                                   &
@@ -467,6 +475,9 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d,                               &
    real,    dimension( ims:ime )                                             , &
             intent(inout)    ::                                           u10, &
                                                                           v10
+   real,    dimension( ims:ime )                                             , & 
+            intent(in  )    ::                                            uox, &
+                                                                          vox
    real,    dimension( its:ite )    ::                                         &
                                                                          brcr, &
                                                                         sflux, &
@@ -584,7 +595,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d,                               &
    qtnp(its:ite,:) = 0.
 !
    do i = its,ite
-     wspd1(i) = sqrt(ux(i,1)*ux(i,1)+vx(i,1)*vx(i,1))+1.e-9
+     wspd1(i) = sqrt( (ux(i,1)-uox(i))*(ux(i,1)-uox(i)) + (vx(i,1)-vox(i))*(vx(i,1)-vox(i)) )+1.e-9
    enddo
 !
 !---- compute vertical diffusion
@@ -945,6 +956,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d,                               &
          dk = rl2*sqrt(ss)
          if(ri.lt.0.)then
 ! unstable regime
+           ri = max(ri, rimin)
            sri = sqrt(-ri)
            xkzm(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri))
            xkzh(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri))
@@ -1178,8 +1190,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d,                               &
        ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2                  &
         *(wspd1(i)/wspd(i))**2
      endif
-     f1(i,1) = ux(i,1)
-     f2(i,1) = vx(i,1)
+     f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i)
+     f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i)
    enddo
 !
    do k = kts,kte-1
diff --git a/wrfv2_fire/phys/module_cam_bl_eddy_diff.F b/wrfv2_fire/phys/module_cam_bl_eddy_diff.F
index 20b38021..561b4610 100644
--- a/wrfv2_fire/phys/module_cam_bl_eddy_diff.F
+++ b/wrfv2_fire/phys/module_cam_bl_eddy_diff.F
@@ -2309,7 +2309,8 @@ subroutine caleddy( pcols        , pver         , ncol        ,
                   lwp         = ql(i,kt-1) * ( pi(i,kt) - pi(i,kt-1) ) / g
                   opt_depth   = 156._r8 * lwp  ! Estimated LW optical depth in the CL top layer
                   radinvfrac  = opt_depth * ( 4._r8 + opt_depth ) / ( 6._r8 * ( 4._r8 + opt_depth) + opt_depth**2 )
-                  radf        = radf + max( radinvfrac * qrlw(i,kt-1) / ( pi(i,kt-1) - pi(i,kt) ) * ( zi(i,kt-1) - zi(i,kt) ), 0._r8 )
+                  radf        = radf + max( radinvfrac * qrlw(i,kt-1) / ( pi(i,kt-1) - pi(i,kt) ) * ( zi(i,kt-1) - zi(i,kt) ), &
+                                            0._r8 )
                   radf        = max( radf, 0._r8 ) * chs(i,kt) 
 
           endif
diff --git a/wrfv2_fire/phys/module_cam_mp_cldwat2m_micro.F b/wrfv2_fire/phys/module_cam_mp_cldwat2m_micro.F
index e00e9417..2a1ea4c4 100644
--- a/wrfv2_fire/phys/module_cam_mp_cldwat2m_micro.F
+++ b/wrfv2_fire/phys/module_cam_mp_cldwat2m_micro.F
@@ -1882,20 +1882,24 @@ subroutine mmicro_pcond ( sub_column,       &
            if (sub_column) then
  
                mnucct(k) = &
-                        (ndfaer1*(nacon(i,k,1)*tcnt)+ndfaer2*(nacon(i,k,2)*tcnt)+ndfaer3*(nacon(i,k,3)*tcnt)+ndfaer4*(nacon(i,k,4)*tcnt))*pi*pi/3._r8*rhow* &
+                        (ndfaer1*(nacon(i,k,1)*tcnt)+ndfaer2*(nacon(i,k,2)*tcnt)+&
+                                  ndfaer3*(nacon(i,k,3)*tcnt)+ndfaer4*(nacon(i,k,4)*tcnt))*pi*pi/3._r8*rhow* &
                         cdist1(k)*gamma(pgam(k)+5._r8)/lamc(k)**4
  
-               nnucct(k) = (ndfaer1*(nacon(i,k,1)*tcnt)+ndfaer2*(nacon(i,k,2)*tcnt)+ndfaer3*(nacon(i,k,3)*tcnt)+ndfaer4*(nacon(i,k,4)*tcnt))*2._r8*pi*  &
+               nnucct(k) = (ndfaer1*(nacon(i,k,1)*tcnt)+ndfaer2*(nacon(i,k,2)*tcnt)+&
+                                     ndfaer3*(nacon(i,k,3)*tcnt)+ndfaer4*(nacon(i,k,4)*tcnt))*2._r8*pi*  &
                         cdist1(k)*gamma(pgam(k)+2._r8)/lamc(k)
  
            else
 
                mnucct(k) = gamma(qcvar+4._r8/3._r8)/(cons3*qcvar**(4._r8/3._r8))*  &
-                       (ndfaer1*(nacon(i,k,1)*tcnt)+ndfaer2*(nacon(i,k,2)*tcnt)+ndfaer3*(nacon(i,k,3)*tcnt)+ndfaer4*(nacon(i,k,4)*tcnt))*pi*pi/3._r8*rhow* &
+                       (ndfaer1*(nacon(i,k,1)*tcnt)+ndfaer2*(nacon(i,k,2)*tcnt)+&
+                                 ndfaer3*(nacon(i,k,3)*tcnt)+ndfaer4*(nacon(i,k,4)*tcnt))*pi*pi/3._r8*rhow* &
                        cdist1(k)*gamma(pgam(k)+5._r8)/lamc(k)**4
 
                 nnucct(k) =  gamma(qcvar+1._r8/3._r8)/(cons3*qcvar**(1._r8/3._r8))*  &
-                         (ndfaer1*(nacon(i,k,1)*tcnt)+ndfaer2*(nacon(i,k,2)*tcnt)+ndfaer3*(nacon(i,k,3)*tcnt)+ndfaer4*(nacon(i,k,4)*tcnt))*2._r8*pi*  &
+                         (ndfaer1*(nacon(i,k,1)*tcnt)+ndfaer2*(nacon(i,k,2)*tcnt)+&
+                                   ndfaer3*(nacon(i,k,3)*tcnt)+ndfaer4*(nacon(i,k,4)*tcnt))*2._r8*pi*  &
                        cdist1(k)*gamma(pgam(k)+2._r8)/lamc(k)
 
            end if      ! sub-column switch
diff --git a/wrfv2_fire/phys/module_cam_mp_microp_aero.F b/wrfv2_fire/phys/module_cam_mp_microp_aero.F
index a47d5097..c8b0e8ea 100644
--- a/wrfv2_fire/phys/module_cam_mp_microp_aero.F
+++ b/wrfv2_fire/phys/module_cam_mp_microp_aero.F
@@ -1512,11 +1512,11 @@ end subroutine hf
 !    You may use, copy, modify this code for any purpose and 
 !    without fee. You may distribute this ORIGINAL package.
 
-      function derf(x)
+      real(r8) function derf(x)
       implicit real (a - h, o - z)
 ! pjj/cray function type
 !     real(r8) a,b,x
-      real(r8) a,b,x,derf
+      real(r8) a,b,x
       dimension a(0 : 64), b(0 : 64)
       integer i,k
       data (a(i), i = 0, 12) / & 
diff --git a/wrfv2_fire/phys/module_cu_gf.F b/wrfv2_fire/phys/module_cu_gf.F
index 7aa50ab2..a17d498f 100644
--- a/wrfv2_fire/phys/module_cu_gf.F
+++ b/wrfv2_fire/phys/module_cu_gf.F
@@ -186,7 +186,7 @@ SUBROUTINE GFDRV(                                            &
                           APRi_GR,APRi_W,APRi_MC,APRi_ST,APRi_AS,    &
                          edti_out,APRi_CAPMA,APRi_CAPME,APRi_CAPMI,gswi
      real,    dimension (its:ite,kts:kte) ::                    &
-        SUBT,SUBQ,OUTT,OUTQ,OUTQC,phh,subm,cupclw,dhdt,         &
+        SUBT,SUBQ,OUTT,OUTQ,OUTQC,phh,subm,cupclw,cupclws,dhdt,         &
         outts,outqs,outqcs
      real,    dimension (its:ite)         ::                    &
         ztexec,zqexec,pret, ter11, aa0, fp,xlandi
@@ -235,8 +235,8 @@ SUBROUTINE GFDRV(                                            &
    high_resolution=0
    subcenter=0.
    iens=1
-   ipr=0
-   jpr=0
+   ipr=0 !639
+   jpr=0 !141
    IF ( periodic_x ) THEN
       ibeg=max(its,ids)
       iend=min(ite,ide-1)
@@ -363,7 +363,7 @@ SUBROUTINE GFDRV(                                            &
          zo(i,k)=zo(i,k-1)+.5*(dz8w(i,k-1,j)+dz8w(i,k,j))
          enddo
      ENDDO
-     if(j.eq.jpr .and. (ipr.gt.its .and. ipr.lt.itf))write(0,*)psur(ipr),ter11(ipr),kpbli(ipr)
+!    if(j.eq.jpr .and. (ipr.gt.its .and. ipr.lt.itf))write(0,*)psur(ipr),ter11(ipr),kpbli(ipr)
      DO K=kts,ktf
      DO I=ITS,ITF
          po(i,k)=phh(i,k)*.01
@@ -391,6 +391,7 @@ SUBROUTINE GFDRV(                                            &
          QSHALL(I,K)=q2d(i,k)+RQVBLTEN(i,k,j)*dt
          IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K)
          IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08
+         cupclws(i,k) = 0.
      ENDDO
      ENDDO
      if(use_excess.gt.0 .or. use_excess_sh.gt.0)then
@@ -477,18 +478,18 @@ SUBROUTINE GFDRV(                                            &
 !
 ! this turns off shallow convection when deep convection is active
 !
-       do i=its,ite
-        if(pret(i).gt.0.)then
-            ierrs(i)=1
-            aaeq(i)=-100.
-        endif
-       enddo
+!      do i=its,ite
+!       if(pret(i).gt.0.)then
+!           ierrs(i)=1
+!           aaeq(i)=-100.
+!       endif
+!      enddo
    call CUP_gf_sh(xmbs,zo,OUTQCs,J,AAEQ,T2D,Q2D,TER11,                    &
               Tshall,Qshall,P2d,PRET,P2d,OUTTS,OUTQS,DT,itimestep,PSUR,US,VS,    &
               TCRIT,ztexec,zqexec,ccn,ccnclean,rhoi,dx,dhdt, &
-              kpbli,kbcons,ktops,k22s,         &   !-lxz
+              kpbli,kbcons,ktops,cupclws,k22s,         &   !-lxz
               xlandi,gswi,tscl_kf,               &
-              xlv,r_v,cp,g,ichoice,ipr,jpr,ierrs,ierrcs,         &
+              xlv,r_v,cp,g,ichoice,0,0,ierrs,ierrcs,         &
               autoconv,itf,jtf,ktf,               &
               use_excess_sh,its,ite, jts,jte, kts,kte &
                                                               )
@@ -552,7 +553,7 @@ SUBROUTINE GFDRV(                                            &
                 DO K=kts,ktf
                 DO I=ibegc,iendc
                    RQCCUTEN(I,K,J)=outqcs(i,k)+outqc(I,K)*cuten(i)
-                   IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i)
+                   IF ( PRESENT( GDC ) ) GDC(I,K,J)=cupclws(i,k)+CUPCLW(I,K)*cuten(i)
                    IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=0.
                 ENDDO
                 ENDDO
@@ -568,11 +569,11 @@ SUBROUTINE GFDRV(                                            &
                    if(t2d(i,k).lt.258.)then
                       RQICUTEN(I,K,J)=outqcs(i,k)+outqc(I,K)*cuten(i)
                       RQCCUTEN(I,K,J)=0.
-                      IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=CUPCLW(I,K)*cuten(i)
+                      IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=cupclws(i,k)+CUPCLW(I,K)*cuten(i)
                    else
                       RQICUTEN(I,K,J)=0.
                       RQCCUTEN(I,K,J)=outqcs(i,k)+outqc(I,K)*cuten(i)
-                      IF ( PRESENT( GDC ) ) GDC(I,K,J)=CUPCLW(I,K)*cuten(i)
+                      IF ( PRESENT( GDC ) ) GDC(I,K,J)=cupclws(i,k)+CUPCLW(I,K)*cuten(i)
                    endif
                 ENDDO
                 ENDDO
@@ -775,7 +776,7 @@ SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
   ! dellaq = change of q per unit mass flux of cloud ensemble
   ! dellaqc = change of qc per unit mass flux of cloud ensemble
 
-        cd,cdd,DELLAH,DELLAQ,DELLAT,DELLAQC,dsubt,dsubq
+        cd,cdd,DELLAH,DELLAQ,DELLAT,DELLAQC,dsubt,dsubh,dsubq
 
   ! aa0 cloud work function for downdraft
   ! edt = epsilon
@@ -833,17 +834,18 @@ SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
 !--- specify entrainmentrate and detrainmentrate
 !--- highly tuneable !
 !
-      entr_rate=1.e-4
-      radius=.2/entr_rate
-      frh=3.14*(2.*radius)*(2.*radius)/dx/dx
+      entr_rate=7.e-5
+      radius=.1/entr_rate
+      frh=3.14*(radius*radius)/dx/dx
       if(frh .gt. 0.7)then
          frh=.7
-         radius=sqrt(frh*dx*dx/(3.14*4.))
+         radius=sqrt(frh*dx*dx/3.14)
          entr_rate=.2/radius
       endif
       do i=its,itf
          sig(i)=(1.-frh)**2
       enddo
+!      sig(:)=1.
 
 !
 !--- entrainment of mass
@@ -874,7 +876,7 @@ SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
 !
 !--- minimum depth (m), clouds must have
 !
-      depth_min=1000.
+      depth_min=1000.   ! gg 500
 !
 !--- maximum depth (mb) of capping 
 !--- inversion (larger cap = no convection)
@@ -906,7 +908,7 @@ SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
 !
 !--- depth(m) over which downdraft detrains all its mass
 !
-      z_detr=1250.
+      z_detr=1250.   !1000
 !
       do nens=1,maxens
          mbdt_ens(nens)=(float(nens)-3.)*dtime*1.e-3+dtime*5.E-03
@@ -987,11 +989,13 @@ SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
            its,ite, jts,jte, kts,kte)
        DO 36 i=its,itf
          IF(ierr(I).eq.0)THEN
-         IF(K22(I).GE.KBMAX(i))then
-           ierr(i)=2
-           ierrc(i)="could not find k22"
-         endif
-         endif
+           frh=q_cup(i,k22(i))/qes_cup(i,k22(i))
+           IF(omeg(i,k22(i),1).lt.0. .and. frh.ge.0.99 .and. sig(i).lt.0.091)ierr(i)=1200
+           IF(K22(I).GE.KBMAX(i))THEN
+             ierr(i)=2
+             ierrc(i)="could not find k22"
+           ENDIF
+         ENDIF
  36   CONTINUE
 !
 !--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
@@ -1001,10 +1005,10 @@ SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
          if(use_excess == 2) then
              k1=max(1,k22(i)-1)
              k2=k22(i)+1
-             hkb(i) =sum(he_cup(i,k1:k2))/float(k2-k1+1)+xl*zqexec(i)+cp*ztexec(i)
+             hkb(i) =he_cup(i,k22(i)) ! sum(he_cup(i,k1:k2))/float(k2-k1+1)+xl*zqexec(i)+cp*ztexec(i)
              hkbo(i)=sum(heo_cup(i,k1:k2))/float(k2-k1+1)+xl*zqexec(i)+cp*ztexec(i)
         else if(use_excess <= 1)then
-         hkb(i)=he_cup(i,k22(i))+float(use_excess)*(xl*zqexec(i)+cp*ztexec(i))
+         hkb(i)=he_cup(i,k22(i)) ! +float(use_excess)*(xl*zqexec(i)+cp*ztexec(i))
          hkbo(i)=heo_cup(i,k22(i))+float(use_excess)*(xl*zqexec(i)+cp*ztexec(i))
         endif  ! excess
        endif ! ierr
@@ -1013,6 +1017,7 @@ SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
 
       call cup_kbcon(ierrc,cap_max_increment,1,k22,kbcon,heo_cup,heso_cup, &
            hkbo,ierr,kbmax,po_cup,cap_max, &
+           xl,cp,ztexec,zqexec,use_excess,       &
            itf,jtf,ktf, &
            its,ite, jts,jte, kts,kte)
 !
@@ -1021,6 +1026,14 @@ SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
       CALL cup_minimi(HEso_cup,Kbcon,kstabm,kstabi,ierr,  &
            itf,jtf,ktf, &
            its,ite, jts,jte, kts,kte)
+      DO i=its,itf
+         IF(ierr(I).eq.0)THEN
+         do k=k22(i),kbcon(i)
+         frh=q_cup(i,k)/qes_cup(i,k)
+         if(omeg(i,k,1).lt.-1.e-6 .and. frh.ge.0.99 .and. sig(i).lt.0.091)ierr(i)=1200
+         enddo
+         endif
+      enddo
 !
 ! the following section insures a smooth normalized mass flux profile. See Grell
 ! and Freitas (2013) for a description
@@ -1435,6 +1448,7 @@ SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
       do i=its,itf
         dellah(i,k)=0.
         dsubt(i,k)=0.
+        dsubh(i,k)=0.
         dellaq(i,k)=0.
         dsubq(i,k)=0.
       enddo
@@ -1597,19 +1611,20 @@ SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
       do i=its,itf
          dellat(i,k)=0.
          if(ierr(i).eq.0)then
-            trash=dsubt(i,k)
+!           if(i.eq.ipr.and.j.eq.jpr.and.k.eq.kts)write(0,*)'mbdt = ',mbdt,mbdt_ens,dtime
+            dsubh(i,k)=dsubt(i,k)
             XHE(I,K)=(dsubt(i,k)+DELLAH(I,K))*MBDT+HEO(I,K)
-            XQ(I,K)=(dsubq(i,k)+DELLAQ(I,K))*MBDT+QO(I,K)
+            XQ(I,K)=(dsubq(i,k)+DELLAQ(I,K)+dellaqc(i,k))*MBDT+QO(I,K)
             DELLAT(I,K)=(1./cp)*(DELLAH(I,K)-xl*DELLAQ(I,K))
             dSUBT(I,K)=(1./cp)*(dsubt(i,k)-xl*dsubq(i,k))
-            XT(I,K)= (DELLAT(I,K)+dsubt(i,k))*MBDT+TN(I,K)
+            XT(I,K)= (DELLAT(I,K)+dsubt(i,k)-dellaqc(i,k)*xl/cp)*MBDT+TN(I,K)
             IF(XQ(I,K).LE.0.)XQ(I,K)=1.E-08
          ENDIF
       enddo
       enddo
       do i=its,itf
       if(ierr(i).eq.0)then
-      xhkb(i)=hkbo(i)+(dsubt(i,k22(i))+DELLAH(I,K22(i)))*MBDT
+      xhkb(i)=hkbo(i)+(dsubh(i,k22(i))+DELLAH(I,K22(i)))*MBDT
       XHE(I,ktf)=HEO(I,ktf)
       XQ(I,ktf)=QO(I,ktf)
       XT(I,ktf)=TN(I,ktf)
@@ -1753,17 +1768,20 @@ SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
       do i=its,itf
          ierr2(i)=ierr(i)
          ierr3(i)=ierr(i)
+         k22x(i)=k22(i)
       enddo
-       if(maxens.gt.1)then
-      CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22x,ierr, &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
+       if(maxens.gt.0)then
+!     CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22x,ierr, &
+!          itf,jtf,ktf, &
+!          its,ite, jts,jte, kts,kte)
       call cup_kbcon(ierrc,cap_max_increment,2,k22x,kbconx,heo_cup, &
            heso_cup,hkbo,ierr2,kbmax,po_cup,cap_max, &
+           xl,cp,ztexec,zqexec,use_excess,       &
            itf,jtf,ktf, &
            its,ite, jts,jte, kts,kte)
       call cup_kbcon(ierrc,cap_max_increment,3,k22x,kbconx,heo_cup, &
            heso_cup,hkbo,ierr3,kbmax,po_cup,cap_max, &
+           xl,cp,ztexec,zqexec,use_excess,       &
            itf,jtf,ktf, &
            its,ite, jts,jte, kts,kte)
       endif
@@ -2434,7 +2452,8 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
        pcrit,acrit,acritt
 
      integer :: nall2,ixxx,irandom
-     integer,  dimension (2) :: seed
+     integer,  dimension (8) :: seed
+     real, dimension (its:ite) :: ens_adj
 
 
       DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,    &
@@ -2446,6 +2465,7 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
                   .743,.813,.886,.947,1.138,1.377,1.896/
 
 !
+       ens_adj=1.
        seed=0
        do i=its,itf
         if(ierr(i).eq.0)then
@@ -2467,6 +2487,9 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
            ierr(i)=0
           endif
           IF(ierr(i).eq.0)then
+          ens_adj(i)=1.
+          if(ierr2(i).gt.0.and.ierr3(i).eq.0)ens_adj(i)=0. ! 2./3.
+          if(ierr2(i).gt.0.and.ierr3(i).gt.0)ens_adj(i)=0.
 !
 !---
 !
@@ -2475,7 +2498,7 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
                 a_ave=0.
                 do ne=1,ens4
                   a_ave=a_ave+axx(i,ne)
-!               if(i.eq.ipr.and.j.eq.jpr)write(0,*)'in forcing, a_ave,axx(i,ne) = ',a_ave,axx(i,ne)
+!               if(i.eq.ipr.and.j.eq.jpr)write(0,*)'in forcing, a_ave,axx(i,ne) = ',a_ave,axx(i,ne),maxens,xland(i)
                 enddo
                 a_ave=max(0.,a_ave/fens4)
                 a_ave=min(a_ave,aa1(i))
@@ -2487,7 +2510,7 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
                 xff_ens3(1)=max(0.,(AA1(I)-AA0(I))/dtime)
                 xff_ens3(2)=max(0.,(a_ave-AA0(I))/dtime)
 
-!               if(i.eq.ipr.and.j.eq.jpr)write(0,*)AA1(I),AA0(I),xff_ens3(1),xff_ens3(2)
+!               if(i.eq.ipr.and.j.eq.jpr)write(0,*)AA1(I),AA0(I),xff_ens3(1),xff_ens3(2),dtime
                 if(irandom.eq.1)then
                    call random_number (xxx)
                    ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8)))
@@ -2537,6 +2560,8 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
                    enddo
                    enddo
                    if(xff_ens3(6).lt.0.)xff_ens3(6)=0.
+                   xff_ens3(5)=xff_ens3(6)
+                   xff_ens3(4)=xff_ens3(6)
 !               if(i.eq.ipr.and.j.eq.jpr)write(0,*)xff_ens3(4),xff_ens3(5)
 !
 !--- more like Krishnamurti et al.; pick max and average values
@@ -2568,18 +2593,20 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
 !
 !--- more like Fritsch Chappel or Kain Fritsch (plus triggers)
 !
-                xff_ens3(10)=AA0(i)/(60.*40.)
-                xff_ens3(11)=AA0(I)/(60.*40.)
+                xff_ens3(10)=AA0(i)/(60.*20.)
+                xff_ens3(11)=AA0(I)/(60.*20.)
+                xff_ens3(16)=AA0(I)/(60.*20.)
                 if(irandom.eq.1)then
                    call random_number (xxx)
                    ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8)))
-                   xff_ens3(12)=AA0(I)/(60.*40.)
+                   xff_ens3(12)=AA0(I)/(60.*20.)
                 else
-                   xff_ens3(12)=AA0(I)/(60.*40.)
+                   xff_ens3(12)=AA0(I)/(60.*20.)
                 endif
 !  
 !--- more original Arakawa-Schubert (climatologic value of aa0)
 !
+!gtest
                 if(icoic.eq.0)then
                 if(xff0.lt.0.)then
                      xff_ens3(1)=0.
@@ -2590,8 +2617,12 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
                      xff_ens3(11)=0.
                      xff_ens3(12)=0.
                 endif
+                  if(xff0.lt.0 .and. xland(i).lt.0.1)then
+                     xff_ens3(:)=0.
+                  endif
                 endif
 
+!                  if(i.eq.ipr.and.j.eq.jpr)write(0,*)'xff_ens = ',i,j,ipr,jpr,xff_ens3
 
 
                 do nens=1,maxens
@@ -2623,25 +2654,28 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
                    nall=(iens-1)*maxens3*maxens*maxens2 &
                         +(iedt-1)*maxens*maxens3 &
                         +(ne-1)*maxens3
+!                 if(i.eq.ipr.and.j.eq.jpr)write(0,*)'maxens',ne,nall,iens,maxens3,maxens,maxens2,iedt
 !
 ! over water, enfor!e small cap for some of the closures
 !
-                if(maxens.gt.1)then
-                if(xland(i).lt.0.1)then
+                if(maxens.gt.0 .and. xland(i).lt.0.1)then
                  if(ierr2(i).gt.0.or.ierr3(i).gt.0)then
-                      xff_ens3(1) =0.
-                      xff_ens3(2) =0.
-                      xff_ens3(3) =0.
-                      xff_ens3(10) =0.
-                      xff_ens3(11) =0.
-                      xff_ens3(12) =0.
-                      xff_ens3(7) =0.
-                      xff_ens3(8) =0.
-                      xff_ens3(9) =0.
-                      xff_ens3(13) =0.
-                      xff_ens3(15) =0.
-                endif
-                endif
+                      xff_ens3(1) =ens_adj(i)*xff_ens3(1)
+                      xff_ens3(2) =ens_adj(i)*xff_ens3(2)
+                      xff_ens3(3) =ens_adj(i)*xff_ens3(3)
+                      xff_ens3(13) =ens_adj(i)*xff_ens3(13)
+                      xff_ens3(10) =ens_adj(i)*xff_ens3(10)
+                      xff_ens3(11) =ens_adj(i)*xff_ens3(11)
+                      xff_ens3(12) =ens_adj(i)*xff_ens3(12)
+                      xff_ens3(16) =ens_adj(i)*xff_ens3(16)
+                      xff_ens3(7) =ens_adj(i)*xff_ens3(7)
+                      xff_ens3(8) =ens_adj(i)*xff_ens3(8)
+                      xff_ens3(9) =ens_adj(i)*xff_ens3(9)
+                      xff_ens3(15) =ens_adj(i)*xff_ens3(15)
+!                     xff_ens3(7) =0.
+!                     xff_ens3(8) =0.
+!                     xff_ens3(9) =0.
+                 endif
                 endif
 !
 ! end water treatment
@@ -2665,6 +2699,7 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
                          if(xff_ens3(2).gt.0)xf_ens(i,j,nall+2)=max(0.,-xff_ens3(2)/xk(ne))
                          if(xff_ens3(3).gt.0)xf_ens(i,j,nall+3)=max(0.,-xff_ens3(3)/xk(ne))
                          if(xff_ens3(13).gt.0)xf_ens(i,j,nall+13)=max(0.,-xff_ens3(13)/xk(ne))
+!                      if(i.eq.ipr.and.j.eq.jpr)write(0,*)'xf_ens(nall+1) ',i,j,nall,xf_ens(i,j,nall+1)
                       endif
 !
 !--- if iresult.eq.1, following independent of xff0
@@ -2686,6 +2721,7 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
                             xf_ens(i,j,nall+10)=max(0.,-xff_ens3(10)/xk(ne))
                             xf_ens(i,j,nall+11)=max(0.,-xff_ens3(11)/xk(ne))
                             xf_ens(i,j,nall+12)=max(0.,-xff_ens3(12)/xk(ne))
+                            xf_ens(i,j,nall+16)=max(0.,-xff_ens3(16)/xk(ne))
                          endif
                       if(icoic.ge.1)then
                       closure_n(i)=0.
@@ -2713,8 +2749,8 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
                    call random_number (xxx)
                    ixxx=min(15,max(1,int(15.*xxx+1.e-8)))
                    xf_ens(i,j,nall+16)=xf_ens(i,j,nall+ixxx)
-                else
-                   xf_ens(i,j,nall+16)=xf_ens(i,j,nall+1)
+!               else
+!                  xf_ens(i,j,nall+16)=xf_ens(i,j,nall+1)
                 endif
 !
 !
@@ -2723,6 +2759,7 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
 !     do not care for caps here for closure groups 1 and 5,
 !     they are fine, do not turn them off here
 !
+!!!!    NOT USED FOR "NORMAL" APPLICATION (maxens=1)
 !
                 if(maxens.gt.1)then
                 if(ne.eq.2.and.ierr2(i).gt.0)then
@@ -2786,7 +2823,9 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
                       xf_ens(i,j,nall+10)=xf_ens(i,j,nall2+10)
                       xf_ens(i,j,nall+11)=xf_ens(i,j,nall2+11)
                       xf_ens(i,j,nall+12)=xf_ens(i,j,nall2+12)
+!                     if(i.eq.ipr.and.j.eq.jpr)write(0,*)'should not be here'
                    endif
+!         if(i.eq.ipr.and.j.eq.jpr)write(0,*)'xff_ens3=',xff_ens3
                 go to 100
              endif
           elseif(ierr(i).ne.20.and.ierr(i).ne.0)then
@@ -2794,6 +2833,7 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
                xf_ens(i,j,n)=0.
              enddo
           endif
+!         if(i.eq.ipr.and.j.eq.jpr)write(0,*)'xff_ens3=',xff_ens3
  100   continue
 
    END SUBROUTINE cup_forcing_ens_3d
@@ -2801,6 +2841,7 @@ END SUBROUTINE cup_forcing_ens_3d
 
    SUBROUTINE cup_kbcon(ierrc,cap_inc,iloop,k22,kbcon,he_cup,hes_cup, &
               hkb,ierr,kbmax,p_cup,cap_max,                         &
+              xl,cp,ztexec,zqexec,use_excess,       &
               itf,jtf,ktf,                        &
               its,ite, jts,jte, kts,kte                        )
 
@@ -2811,7 +2852,7 @@ SUBROUTINE cup_kbcon(ierrc,cap_inc,iloop,k22,kbcon,he_cup,hes_cup, &
 
      integer                                                           &
         ,intent (in   )                   ::                           &
-        itf,jtf,ktf,           &
+        use_excess,itf,jtf,ktf,           &
         its,ite, jts,jte, kts,kte
   ! 
   ! 
@@ -2823,7 +2864,12 @@ SUBROUTINE cup_kbcon(ierrc,cap_inc,iloop,k22,kbcon,he_cup,hes_cup, &
         he_cup,hes_cup,p_cup
      real,    dimension (its:ite)                                      &
         ,intent (in   )                   ::                           &
-        hkb,cap_max,cap_inc
+        ztexec,zqexec,cap_max,cap_inc
+     real,intent (in   )                  ::                           &
+        xl,cp
+     real,    dimension (its:ite)                                      &
+        ,intent (inout   )                   ::                           &
+        hkb
      integer, dimension (its:ite)                                      &
         ,intent (in   )                   ::                           &
         kbmax
@@ -2839,7 +2885,7 @@ SUBROUTINE cup_kbcon(ierrc,cap_inc,iloop,k22,kbcon,he_cup,hes_cup, &
 !
 
      integer                              ::                           &
-        i,k
+        i,k,k1,k2
      real                                 ::                           &
         pbcdif,plus,hetest
 !
@@ -2861,7 +2907,7 @@ SUBROUTINE cup_kbcon(ierrc,cap_inc,iloop,k22,kbcon,he_cup,hes_cup, &
         GO TO 27
       ENDIF
  32   CONTINUE
-      hetest=HE_cup(I,K22(I))
+      hetest=hkb(i) ! HE_cup(I,K22(I))
       if(iloop.eq.5)then
        hetest=HKB(I)
 !      do k=1,k22(i)
@@ -2888,6 +2934,15 @@ SUBROUTINE cup_kbcon(ierrc,cap_inc,iloop,k22,kbcon,he_cup,hes_cup, &
 !       write(0,*)'htest',k22(i),kbcon(i),plus,-P_cup(I,KBCON(I))+P_cup(I,K22(I))
         K22(I)=K22(I)+1
         KBCON(I)=K22(I)+1
+         if(use_excess == 2) then
+             k1=max(1,k22(i)-1)
+             k2=max(1,min(kbcon(i)-1,k22(i)+1))  !kbcon(i)-1
+             k2=k22(i)+1
+             hkb(i)=sum(he_cup(i,k1:k2))/float(k2-k1+1)+(xl*zqexec(i)+cp*ztexec(i))/float(k2-k1+1)
+        else if(use_excess <= 1)then
+             hkb(i)=he_cup(i,k22(i))+float(use_excess)*(xl*zqexec(i)+cp*ztexec(i))
+        endif  ! excess
+
         if(iloop.eq.5)KBCON(I)=K22(I)
         IF(KBCON(I).GT.KBMAX(i)+2)THEN
          if(iloop.ne.4)then
@@ -3950,7 +4005,7 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
               TN,QO,PO,PRE,P,OUTT,OUTQ,DTIME,ktau,PSUR,US,VS,    &
               TCRIT,                                        &
               ztexec,zqexec,ccn,ccnclean,rho,dx,dhdt,                               &
-              kpbl,kbcon,ktop,k22,         &   !-lxz
+              kpbl,kbcon,ktop,cupclws,k22,         &   !-lxz
               xland,gsw,tscl_kf,              &
               xl,rv,cp,g,ichoice,ipr,jpr,ierr,ierrc,         &
               autoconv,itf,jtf,ktf,               &
@@ -3977,7 +4032,7 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
   ! pre    = output precip
      real,    dimension (its:ite,kts:kte)                              &
         ,intent (inout  )                   ::                           &
-        OUTT,OUTQ,OUTQC
+        cupclws,OUTT,OUTQ,OUTQC
      real,    dimension (its:ite)                                      &
         ,intent (out  )                   ::                           &
         pre,xmb_out
@@ -4095,7 +4150,7 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
   ! dellaq = change of q per unit mass flux of cloud ensemble
   ! dellaqc = change of qc per unit mass flux of cloud ensemble
 
-        cd,cdd,DELLAH,DELLAQ,DELLAT,DELLAQC,dsubt,dsubq,subt,subq
+        cd,cdd,DELLAH,DELLAQ,DELLAT,DELLAQC,dsubt,dsubh,dsubq,subt,subq
 
   ! aa0 cloud work function for downdraft
   ! edt = epsilon
@@ -4126,7 +4181,7 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
       real :: power_entr,zustart,zufinal,dzm1,dzp1
 
 
-     integer :: jprnt,k1,k2,kbegzu,kfinalzu,kstart,jmini,levadj
+     integer :: tun_lim,jprnt,k1,k2,kbegzu,kfinalzu,kstart,jmini,levadj
      logical :: keep_going
      real xff_shal(9),blqe,xkshal
      character*50 :: ierrc(its:ite)
@@ -4151,6 +4206,7 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
 !--- program
 !
       entr_rate =.2/200.
+      tun_lim=7
       
 !
 !--- initial detrainmentrates
@@ -4256,7 +4312,7 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
          else
              ierrc(i)="why here? "
          endif
-       if(j.eq.jpr .and. i.eq.ipr)write(0,*)'initial k22 = ',k22(ipr),kpbl(i)
+!      if(j.eq.jpr .and. i.eq.ipr)write(0,*)'initial k22 = ',k22(ipr),kpbl(i)
  36   CONTINUE
 !
 !--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
@@ -4285,6 +4341,7 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
       enddo
       call cup_kbcon(ierrc,cap_max_increment,5,k22,kbcon,heo_cup,heso_cup, &
            hkbo,ierr,kbmax,po_cup,cap_max, &
+           xl,cp,ztexec,zqexec,use_excess,       &
            itf,jtf,ktf, &
            its,ite, jts,jte, kts,kte)
 !
@@ -4310,17 +4367,17 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
              cd(i,k)=0.
              entr_rate_2d(i,k)=((frh*(float((k+1))**power_entr)+dh)/zuhe(i)-1.+cd(i,k)*dz)/dz
              zuhe(i)=zuhe(i)+entr_rate_2d(i,k)*dz*zuhe(i)-cd(i,k)*dz*zuhe(i)
-             if(i.eq.ipr.and.j.eq.jpr)write(0,*)'entr = ',k,entr_rate_2d(i,k),dh,frh,zuhe(i),dz
+!            if(i.eq.ipr.and.j.eq.jpr)write(0,*)'entr = ',k,entr_rate_2d(i,k),dh,frh,zuhe(i),dz
             enddo
-            frh=-(0.1-zuhe(i))/((float(kbcon(i)+4)**power_entr)-(float(kbcon(i)-1)**power_entr))
+            frh=-(0.1-zuhe(i))/((float(kbcon(i)+tun_lim)**power_entr)-(float(kbcon(i)-1)**power_entr))
             dh=zuhe(i)+frh*(float(kbcon(i))**power_entr)
-               do k=kbcon(i),kbcon(i)+4
+               do k=kbcon(i),kbcon(i)+tun_lim
                  dz=z_cup(i,k+1)-z_cup(i,k)
                  cd(i,k)=-((-frh*(float((k+1))**power_entr)+dh)/zuhe(i)-1.-entr_rate_2d(i,k)*dz)/dz
                  zuhe(i)=zuhe(i)+entr_rate_2d(i,k)*dz*zuhe(i)-cd(i,k)*dz*zuhe(i)
-             if(i.eq.ipr.and.j.eq.jpr)write(0,*)'entr = ',k,entr_rate_2d(i,k),cd(i,k),zuhe(i)
+!            if(i.eq.ipr.and.j.eq.jpr)write(0,*)'entr = ',k,entr_rate_2d(i,k),cd(i,k),zuhe(i)
                enddo
-               do k=kbcon(i)+4+1,ktf
+               do k=kbcon(i)+tun_lim+1,ktf
                 entr_rate_2d(i,k)=0.
                 cd(i,k)=0.
                enddo
@@ -4413,6 +4470,7 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
                          up_massentr(i,k-1)*qo(i,k-1))   /            &
                          (zuo(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
           qrco(i,k)=max(0.,qco(i,k)-trash)
+          cupclws(i,k)=qrco(i,k)*.5
          enddo
          do k=ktop(i)+1,ktf
            HC(i,K)=hes_cup(i,k)
@@ -4428,12 +4486,12 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
            up_massentro(i,k)=0.
            up_massdetro(i,k)=0.
          enddo
-         if(i.eq.ipr.and.j.eq.jpr)then
-            write(0,*)'hcnew = '
-            do k=1,ktf
-              write(0,*)k,hco(i,k),dbyo(i,k)
-            enddo
-         endif
+!        if(i.eq.ipr.and.j.eq.jpr)then
+!           write(0,*)'hcnew = '
+!           do k=1,ktf
+!             write(0,*)k,hco(i,k),dbyo(i,k)
+!           enddo
+!        endif
       endif
 42    continue
 !     enddo
@@ -4468,6 +4526,7 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
       do i=its,itf
         dellah(i,k)=0.
         dsubt(i,k)=0.
+        dsubh(i,k)=0.
         dellaq(i,k)=0.
         dsubq(i,k)=0.
       enddo
@@ -4574,9 +4633,9 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
                     -zuo(i,k)*heo_cup(i,k))*g/dp
              dsubq(i,k)=(zuo(i,k+1)*qo_cup(i,k+1) &
                     -zuo(i,k)*qo_cup(i,k))*g/dp
-           if(i.eq.ipr.and.j.eq.jpr)then
-            write(0,*)'dq3',k,zuo(i,k+1)*heo_cup(i,k+1),zuo(i,k)*heo_cup(i,k)
-           endif
+!          if(i.eq.ipr.and.j.eq.jpr)then
+!           write(0,*)'dq3',k,zuo(i,k+1)*heo_cup(i,k+1),zuo(i,k)*heo_cup(i,k)
+!          endif
            endif
 !
        enddo   ! k
@@ -4613,7 +4672,9 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
       do i=its,itf
          dellat(i,k)=0.
          if(ierr(i).eq.0)then
-            trash=dsubt(i,k)
+            dsubh(i,k)=dsubt(i,k)
+            dellaq(i,k)=dellaq(i,k)+dellaqc(i,k)
+            dellaqc(i,k)=0.
             XHE(I,K)=(dsubt(i,k)+DELLAH(I,K))*MBDT+HEO(I,K)
             XQ(I,K)=(dsubq(i,k)+DELLAQ(I,K))*MBDT+QO(I,K)
             DELLAT(I,K)=(1./cp)*(DELLAH(I,K)-xl*DELLAQ(I,K))
@@ -4625,7 +4686,7 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
       enddo
       do i=its,itf
       if(ierr(i).eq.0)then
-      xhkb(i)=hkbo(i)+(dsubt(i,k22(i))+DELLAH(I,K22(i)))*MBDT
+      xhkb(i)=hkbo(i)+(dsubh(i,k22(i))+DELLAH(I,K22(i)))*MBDT
       XHE(I,ktf)=HEO(I,ktf)
       XQ(I,ktf)=QO(I,ktf)
       XT(I,ktf)=TN(I,ktf)
@@ -4769,13 +4830,13 @@ SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
            fsum=fsum+1.
           enddo
           xmb(i)=min(xmbmax(i),xmb(i)/fsum)
-          if(i.eq.ipr.and.j.eq.jpr)write(0,*)',ierr,xffs',ierr(i),xff_shal(1:9),xmb(i),xmbmax(i)
+!         if(i.eq.ipr.and.j.eq.jpr)write(0,*)',ierr,xffs',ierr(i),xff_shal(1:9),xmb(i),xmbmax(i)
           if(xmb(i).eq.0.)ierr(i)=22
           if(xmb(i).eq.0.)ierrc(i)="22"
           if(xmb(i).lt.0.)then
              ierr(i)=21
              ierrc(i)="21"
-             write(0,*)'neg xmb,i,j,xmb for shallow = ',i,j,k22(i),ierr(i)
+!            write(0,*)'neg xmb,i,j,xmb for shallow = ',i,j,k22(i),ierr(i)
           endif
         endif
         if(ierr(i).ne.0)then
diff --git a/wrfv2_fire/phys/module_cu_kfeta.F b/wrfv2_fire/phys/module_cu_kfeta.F
index ddf1f1fb..dbf9173f 100644
--- a/wrfv2_fire/phys/module_cu_kfeta.F
+++ b/wrfv2_fire/phys/module_cu_kfeta.F
@@ -8,6 +8,11 @@ MODULE module_cu_kfeta
 !   the cumulus parameterization for tropical cyclone prediction: 
 !   Convection trigger. Atmospheric Research, 92, 190 - 211.
 !
+!ckay
+!  WRF v3.5 with diagnosed deep and shallow KF cloud fraction using 
+!  CAM3-CAM5 methodology, along with captured liquid and ice condensates.
+!    JAH & KA (U.S. EPA) -- May 2013
+!
 !--------------------------------------------------------------------
 ! Lookup table variables:
       INTEGER, PARAMETER :: KFNT=250,KFNP=220
@@ -37,6 +42,9 @@ SUBROUTINE KF_eta_CPS(                                    &
              ,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS       &
              ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN            &
              ,RQICUTEN,RQSCUTEN, RQVFTEN                     &
+!ckay
+             ,cldfra_dp_KF,cldfra_sh_KF                      &
+             ,qc_KF,qi_KF                                    &
                                                              )
 !
 !-------------------------------------------------------------
@@ -72,7 +80,7 @@ SUBROUTINE KF_eta_CPS(                                    &
 !
    REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
           INTENT(INOUT) ::                                   &
-                                                      W0AVG
+                                                      W0AVG   
 
    REAL,  INTENT(IN   ) :: DT, DX
    REAL,  INTENT(IN   ) :: CUDT
@@ -122,6 +130,13 @@ SUBROUTINE KF_eta_CPS(                                    &
                                                   ,F_QI      &
                                                   ,F_QS
 
+!ckay
+   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
+          INTENT(INOUT) ::                                   &
+                                               cldfra_dp_KF, &
+                                               cldfra_sh_KF, &
+                                                      qc_KF, &
+                                                      qi_KF
 
 ! LOCAL VARS
 
@@ -380,6 +395,11 @@ SUBROUTINE KF_eta_CPS(                                    &
                DQRDT(k)=0.
                DQSDT(k)=0.
                DTDT(k)=0.
+!ckay
+               cldfra_dp_KF(I,k,J)=0.
+               cldfra_sh_KF(I,k,J)=0.
+               qc_KF(I,k,J)=0.
+               qi_KF(I,k,J)=0.
             ENDDO
             RAINCV(I,J)=0.
             CUTOP(I,J)=KTS
@@ -418,7 +438,10 @@ SUBROUTINE KF_eta_CPS(                                    &
                  CUTOP,CUBOT,CUDT,                  &
                  ids,ide, jds,jde, kds,kde,         &
                  ims,ime, jms,jme, kms,kme,         &
-                 its,ite, jts,jte, kts,kte)
+                 its,ite, jts,jte, kts,kte,         &
+!ckay
+                 cldfra_dp_KF,cldfra_sh_KF,         &
+                 qc_KF,qi_KF                        )
             IF(PRESENT(rthcuten).AND.PRESENT(rqvcuten)) THEN
               DO K=kts,kte
                  RTHCUTEN(I,K,J)=DTDT(K)/pi(I,K,J)
@@ -480,7 +503,10 @@ SUBROUTINE KF_eta_PARA (I, J,                           &
                       CUTOP,CUBOT,CUDT,                    &
                       ids,ide, jds,jde, kds,kde,           &
                       ims,ime, jms,jme, kms,kme,           &
-                      its,ite, jts,jte, kts,kte)
+                      its,ite, jts,jte, kts,kte,           &
+!ckay
+                      cldfra_dp_KF,cldfra_sh_KF,           &
+                      qc_KF,qi_KF                          )
 !-----------------------------------------------------------
 !***** The KF scheme that is currently used in experimental runs of EMCs 
 !***** Eta model....jsk 8/00
@@ -528,6 +554,13 @@ SUBROUTINE KF_eta_PARA (I, J,                           &
       REAL,    DIMENSION( ims:ime , jms:jme ),             &
             INTENT(INOUT) ::                          NCA
 
+!ckay
+      REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),      &
+            INTENT(INOUT) ::                 cldfra_dp_KF, &
+                                             cldfra_sh_KF, &
+                                                    qc_KF, &
+                                                    qi_KF
+
       REAL, DIMENSION( ims:ime , jms:jme ),                &
             INTENT(INOUT) ::                       RAINCV
 
@@ -599,6 +632,8 @@ SUBROUTINE KF_eta_PARA (I, J,                           &
       INTEGER :: INDLU,NU,NUCHM,NNN,KLFS
    REAL    :: CHMIN,PM15,CHMAX,DTRH,RAD,DPPP
    REAL    :: TVDIFF,DTTOT,ABSOMG,ABSOMGTC,FRDP
+!ckay
+   REAL    :: xcldfra,UMF_new
 
       INTEGER :: KX,K,KL
 !
@@ -829,17 +864,24 @@ SUBROUTINE KF_eta_PARA (I, J,                           &
           TLCL=AMIN1(TLCL,TMIX)
           TVLCL=TLCL*(1.+0.608*QMIX)
           ZLCL = ZMIX+(TLCL-TMIX)/GDRY
-          NK = LC-1
-          DO 
-            NK = NK+1
-            KLCL=NK
-            IF(ZLCL.LE.Z0(NK) .or. NK.GT.KL)THEN
-              EXIT
-            ENDIF 
-          ENDDO   
-          IF(NK.GT.KL)THEN
-            RETURN  
-          ENDIF
+     !     NK = LC-1
+     !     DO 
+     !       NK = NK+1
+     !       KLCL=NK
+     !       IF(ZLCL.LE.Z0(NK) .or. NK.GT.KL)THEN
+     !         EXIT
+     !       ENDIF 
+     !     ENDDO   
+     !     IF(NK.GT.KL)THEN
+     !       RETURN  
+     !     ENDIF
+
+       DO NK = LC, KL
+         KLCL = NK
+         IF ( ZLCL.LE.Z0(NK) )  EXIT
+     END DO
+     IF ( ZLCL.GT.Z0(KL) )  RETURN
+
           K=KLCL-1
 ! calculate DLP using Z instead of log(P)
           DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K))
@@ -1227,6 +1269,11 @@ SUBROUTINE KF_eta_PARA (I, J,                           &
             ELSEIF(TLCL.LT.273.)THEN
               CHMIN = 2.E3
             ENDIF
+!ckay
+            DO NK=K,LTOP
+              qc_KF(I,NK,J)=QLIQ(NK)
+              qi_KF(I,NK,J)=QICE(NK)
+            END DO
 
 !     
 !...If cloud top height is less than the specified minimum for deep 
@@ -1254,15 +1301,28 @@ SUBROUTINE KF_eta_PARA (I, J,                           &
                 DETIC(NK)=0.
                 PPTLIQ(NK)=0.
                 PPTICE(NK)=0.
+!ckay
+                cldfra_dp_KF(I,NK,J)=0.
+                cldfra_sh_KF(I,NK,J)=0.
+                qc_KF(I,NK,J)=0.
+                qi_KF(I,NK,J)=0.
               ENDDO
 !        
             ELSEIF(CLDHGT(LC).GT.CHMIN .and. ABE.GT.1)THEN      ! Deep Convection allowed
               ISHALL=0
+!ckay
+              DO NK=K,LTOP
+                cldfra_sh_KF(I,NK,J)=0.
+              ENDDO
               EXIT usl
             ELSE
 !
 !...TO DISALLOW SHALLOW CONVECTION, COMMENT OUT NEXT LINE !!!!!!!!
               ISHALL = 1
+!ckay
+              DO NK=K,LTOP
+                cldfra_dp_KF(I,NK,J)=0.
+              ENDDO
               IF(NU.EQ.NUCHM)THEN
                 EXIT usl               ! Shallow Convection from this layer
               ELSE
@@ -1275,6 +1335,11 @@ SUBROUTINE KF_eta_PARA (I, J,                           &
                   DETIC(NK)=0.
                   PPTLIQ(NK)=0.
                   PPTICE(NK)=0.
+!ckay
+                  cldfra_dp_KF(I,NK,J)=0.
+                  cldfra_sh_KF(I,NK,J)=0.
+                  qc_KF(I,NK,J)=0.
+                  qi_KF(I,NK,J)=0.
                 ENDDO
               ENDIF
             ENDIF
@@ -1362,6 +1427,11 @@ SUBROUTINE KF_eta_PARA (I, J,                           &
         UMF(NK)=0.
         WU(NK)=0.
         UER(NK)=0.
+!ckay
+        cldfra_dp_KF(I,NK,J)=0.
+        cldfra_sh_KF(I,NK,J)=0.
+        qc_KF(I,NK,J)=0.
+        qi_KF(I,NK,J)=0.
       ENDIF
       UDR(NK)=0.
       QDT(NK)=0.
@@ -1400,6 +1470,11 @@ SUBROUTINE KF_eta_PARA (I, J,                           &
           TU(NK)=0.
           QU(NK)=0.
           WU(NK)=0.
+!ckay
+          cldfra_dp_KF(I,NK,J)=0.
+          cldfra_sh_KF(I,NK,J)=0.
+          qc_KF(I,NK,J)=0.
+          qi_KF(I,NK,J)=0.
         ENDIF
         THTA0(NK)=0.
         THTAU(NK)=0.
@@ -2118,6 +2193,23 @@ SUBROUTINE KF_eta_PARA (I, J,                           &
 !     
           ENDIF
         ENDDO iter
+!ckay
+! get the cloud fraction for layer NK+1=NK1
+        IF(ISHALL.EQ.1) THEN
+          DO NK=KLCL-1, LTOP1
+            UMF_new = UMF(NK)/DXSQ
+            xcldfra = 0.07*alog(1.+(500.*UMF_new))
+            xcldfra = amax1(0.01,xcldfra)
+            cldfra_sh_KF(I,NK,J) = amin1(0.2,xcldfra)
+          ENDDO
+        ELSE 
+          DO NK=KLCL-1, LTOP1
+            UMF_new = UMF(NK)/DXSQ
+            xcldfra = 0.14*alog(1.+(500.*UMF_new))
+            xcldfra = amax1(0.01,xcldfra)
+            cldfra_dp_KF(I,NK,J) = amin1(0.6,xcldfra)
+          ENDDO
+        ENDIF
 !     
 !...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV...
 !     
diff --git a/wrfv2_fire/phys/module_cu_mesosas.F b/wrfv2_fire/phys/module_cu_mesosas.F
new file mode 100644
index 00000000..a18bbbf2
--- /dev/null
+++ b/wrfv2_fire/phys/module_cu_mesosas.F
@@ -0,0 +1,7780 @@
+!!
+MODULE module_cu_mesosas 
+
+CONTAINS
+
+!-----------------------------------------------------------------
+      SUBROUTINE CU_MESO_SAS(DT,ITIMESTEP,STEPCU,                   &
+                 RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,               &
+                 RUCUTEN,RVCUTEN,                                   & 
+                 RAINCV,PRATEC,HTOP,HBOT,                           &
+                 U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D,           &
+                 DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG,                   &
+                 P_QC,                                              & 
+                 MOMMIX, & ! gopal's doing
+                 PGCON,sas_mass_flux,                               &
+                 shalconv,shal_pgcon,                               &
+                 HPBL2D,EVAP2D,HEAT2D,                              & !Kwon for shallow convection
+                 P_QI,P_FIRST_SCALAR,                               & 
+                 ids,ide, jds,jde, kds,kde,                         &
+                 ims,ime, jms,jme, kms,kme,                         &
+                 its,ite, jts,jte, kts,kte                          )
+
+!-------------------------------------------------------------------
+      USE MODULE_GFS_MACHINE , ONLY : kind_phys
+      USE MODULE_GFS_FUNCPHYS , ONLY : gfuncphys
+      USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP  &
+     &,             RV => con_RV, FV => con_fvirt, T0C => con_T0C       &
+     &,             CVAP => con_CVAP, CLIQ => con_CLIQ                  & 
+     &,             EPS => con_eps, EPSM1 => con_epsm1                  &
+     &,             ROVCP => con_rocp, RD => con_rd
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+!-- U3D         3D u-velocity interpolated to theta points (m/s)
+!-- V3D         3D v-velocity interpolated to theta points (m/s)
+!-- TH3D	3D potential temperature (K)
+!-- T3D         temperature (K)
+!-- QV3D        3D water vapor mixing ratio (Kg/Kg)
+!-- QC3D        3D cloud mixing ratio (Kg/Kg)
+!-- QI3D        3D ice mixing ratio (Kg/Kg)
+!-- P8w         3D pressure at full levels (Pa)
+!-- Pcps        3D pressure (Pa)
+!-- PI3D	3D exner function (dimensionless)
+!-- rr3D	3D dry air density (kg/m^3)
+!-- RUBLTEN     U tendency due to
+!               PBL parameterization (m/s^2)
+!-- RVBLTEN     V tendency due to
+!               PBL parameterization (m/s^2)
+!-- RTHBLTEN    Theta tendency due to
+!               PBL parameterization (K/s)
+!-- RQVBLTEN    Qv tendency due to
+!               PBL parameterization (kg/kg/s)
+!-- RQCBLTEN    Qc tendency due to
+!               PBL parameterization (kg/kg/s)
+!-- RQIBLTEN    Qi tendency due to
+!               PBL parameterization (kg/kg/s)
+!
+!-- MOMMIX      MOMENTUM MIXING COEFFICIENT (can be set in the namelist)
+!-- RUCUTEN     U tendency due to Cumulus Momentum Mixing (gopal's doing for SAS)
+!-- RVCUTEN     V tendency due to Cumulus Momentum Mixing (gopal's doing for SAS)
+!
+!-- CP          heat capacity at constant pressure for dry air (J/kg/K)
+!-- GRAV        acceleration due to gravity (m/s^2)
+!-- ROVCP       R/CP
+!-- RD          gas constant for dry air (J/kg/K)
+!-- ROVG 	R/G
+!-- P_QI	species index for cloud ice
+!-- dz8w	dz between full levels (m)
+!-- z		height above sea level (m)
+!-- PSFC        pressure at the surface (Pa)
+!-- UST		u* in similarity theory (m/s)
+!-- PBL		PBL height (m)
+!-- PSIM        similarity stability function for momentum
+!-- PSIH        similarity stability function for heat
+!-- HFX		upward heat flux at the surface (W/m^2)
+!-- QFX		upward moisture flux at the surface (kg/m^2/s)
+!-- TSK		surface temperature (K)
+!-- GZ1OZ0      log(z/z0) where z0 is roughness length
+!-- WSPD        wind speed at lowest model level (m/s)
+!-- BR          bulk Richardson number in surface layer
+!-- DT		time step (s)
+!-- rvovrd      R_v divided by R_d (dimensionless)
+!-- EP1         constant for virtual temperature (R_v/R_d - 1) (dimensionless)
+!-- KARMAN      Von Karman constant
+!-- ids         start index for i in domain
+!-- ide         end index for i in domain
+!-- jds         start index for j in domain
+!-- jde         end index for j in domain
+!-- kds         start index for k in domain
+!-- kde         end index for k in domain
+!-- ims         start index for i in memory
+!-- ime         end index for i in memory
+!-- jms         start index for j in memory
+!-- jme         end index for j in memory
+!-- kms         start index for k in memory
+!-- kme         end index for k in memory
+!-- its         start index for i in tile
+!-- ite         end index for i in tile
+!-- jts         start index for j in tile
+!-- jte         end index for j in tile
+!-- kts         start index for k in tile
+!-- kte         end index for k in tile
+!-------------------------------------------------------------------
+
+      INTEGER ::                        ICLDCK
+
+      INTEGER, INTENT(IN) ::            ids,ide, jds,jde, kds,kde,      &
+                                        ims,ime, jms,jme, kms,kme,      &
+                                        its,ite, jts,jte, kts,kte,      &
+                                        ITIMESTEP,                      &     !NSTD
+                                        P_FIRST_SCALAR,                 &
+                                        P_QC,                           &
+                                        P_QI,                           &
+                                        STEPCU
+
+      REAL,    INTENT(IN) ::                                            &
+                                        DT
+
+      REAL, OPTIONAL, INTENT(IN) :: PGCON,sas_mass_flux,shal_pgcon
+      INTEGER, OPTIONAL, INTENT(IN) :: shalconv
+      REAL(kind=kind_phys)       :: PGCON_USE,SHAL_PGCON_USE,massf
+      INTEGER :: shalconv_use
+      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::      &
+                                        RQCCUTEN,                       &
+                                        RQICUTEN,                       &
+                                        RQVCUTEN,                       &
+                                        RTHCUTEN
+      REAL, DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(INOUT) ::      &
+                                        RUCUTEN,                        &  
+                                        RVCUTEN                             
+      REAL, OPTIONAL,   INTENT(IN) ::    MOMMIX
+
+      REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL,                   &
+                         INTENT(IN) :: HPBL2D,EVAP2D,HEAT2D                !Kwon for sha
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
+                                        XLAND
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            &
+                                        RAINCV, PRATEC
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::              &
+                                        HBOT,                           &
+                                        HTOP
+
+      LOGICAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) ::             &
+                                        CU_ACT_FLAG
+
+
+      REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::      &
+                                        DZ8W,                           &
+                                        P8w,                            &
+                                        Pcps,                           &
+                                        PI3D,                           &
+                                        QC3D,                           &
+                                        QI3D,                           &
+                                        QV3D,                           &
+                                        RHO3D,                          &
+                                        T3D,                            &
+                                        U3D,                            &
+                                        V3D,                            &
+                                        W
+
+!--------------------------- LOCAL VARS ------------------------------
+
+      REAL,    DIMENSION(ims:ime, jms:jme) ::                           &
+                                        PSFC
+
+      REAL,    DIMENSION(its:ite, jts:jte) ::                           &
+                                        RAINCV1, PRATEC1
+      REAL,    DIMENSION(its:ite, jts:jte) ::                           &
+                                        RAINCV2, PRATEC2
+
+      REAL     (kind=kind_phys) ::                                      &
+                                        DELT,                           &
+                                        DPSHC,                          &
+                                        RDELT,                          &
+                                        RSEED
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite) ::                  &
+                                        CLDWRK,                         &
+                                        PS,                             &
+                                        RCS,                            &
+                                        RN,                             &
+                                        SLIMSK,                         &
+                                        HPBL,EVAP,HEAT                     !Kwon for shallow convection
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte+1) ::       &
+                                        PRSI                            
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte) ::         &
+                                        DEL,                            &
+                                        DOT,                            &
+                                        PHIL,                           &
+                                        PRSL,                           &
+                                        PRSLK,                          &
+                                        Q1,                             & 
+                                        T1,                             & 
+                                        U1,                             & 
+                                        V1,                             & 
+                                        ZI,                             & 
+                                        ZL 
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte, 2) ::      &
+                                        QL 
+
+      INTEGER, DIMENSION(its:ite) ::                                    &
+                                        KBOT,                           &
+                                        KTOP,                           &
+                                        KCNV
+
+      INTEGER ::                                                        &
+                                        I,                              &
+                                        IGPVS,                          &
+                                        IM,                             &
+                                        J,                              &
+                                        JCAP,                           &
+                                        K,                              &
+                                        KM,                             &
+                                        KP,                             &
+                                        KX,                             &
+                                        NCLOUD 
+
+      DATA IGPVS/0/
+
+!-----------------------------------------------------------------------
+!
+
+      if(present(shalconv)) then
+         shalconv_use=shalconv
+      else
+#if (NMM_CORE==1)
+         shalconv_use=0
+#else
+#if (EM_CORE==1)
+         shalconv_use=1
+#else
+         shalconv_use=0
+#endif
+#endif
+      endif
+
+      if(present(pgcon)) then
+         pgcon_use  = pgcon
+      else
+!        pgcon_use  = 0.7     ! Gregory et al. (1997, QJRMS)
+         pgcon_use  = 0.55    ! Zhang & Wu (2003,JAS), used in GFS (25km res spectral)
+!        pgcon_use  = 0.2     ! HWRF, for model tuning purposes
+!        pgcon_use  = 0.3     ! GFDL, or so I am told
+
+         ! For those attempting to tune pgcon:
+
+         ! The value of 0.55 comes from an observational study of
+         ! synoptic-scale deep convection and 0.7 came from an
+         ! incorrect fit to the same data.  That value is likely
+         ! correct for deep convection at gridscales near that of GFS,
+         ! but is questionable in shallow convection, or for scales
+         ! much finer than synoptic scales.
+
+         ! Then again, the assumptions of SAS break down when the
+         ! gridscale is near the convection scale anyway.  In a large
+         ! storm such as a hurricane, there is often no environment to
+         ! detrain into since adjancent gridsquares are also undergoing
+         ! active convection.  Each gridsquare will no longer have many
+         ! updrafts and downdrafts.  At sub-convective timescales, you
+         ! will find unstable columns for many (say, 5 second length)
+         ! timesteps in a real atmosphere during a convection cell's
+         ! lifetime, so forcing it to be neutrally stable is unphysical.
+
+         ! Hence, in scales near the convection scale (cells have
+         ! ~0.5-4km diameter in hurricanes), this parameter is more of a
+         ! tuning parameter to get a scheme that is inappropriate for
+         ! that resolution to do a reasonable job.
+
+         ! Your mileage might vary.
+
+         ! - Sam Trahan
+      endif
+
+      if(present(sas_mass_flux)) then
+         massf=sas_mass_flux
+         ! Use this to reduce the fluxes added by SAS to prevent
+         ! computational instability as a result of large fluxes.
+      else
+         massf=9e9 ! large number to disable check
+      endif
+
+      if(present(shal_pgcon)) then
+         if(shal_pgcon>=0) then
+            shal_pgcon_use  = shal_pgcon
+         else
+            ! shal_pgcon<0 means use deep pgcon
+            shal_pgcon_use  = pgcon_use
+         endif
+      else
+         ! Default: Same as deep convection pgcon
+         shal_pgcon_use  = pgcon_use
+         ! Read the warning above though.  It may be advisable for
+         ! these to be different.  
+      endif
+
+      DO J=JTS,JTE
+         DO I=ITS,ITE
+            CU_ACT_FLAG(I,J)=.TRUE.
+         ENDDO
+      ENDDO
+ 
+      IM=ITE-ITS+1
+      KX=KTE-KTS+1
+      JCAP=126
+      DPSHC=30_kind_phys
+      DELT=DT*STEPCU
+      RDELT=1./DELT
+      NCLOUD=1
+
+
+   DO J=jms,jme
+     DO I=ims,ime
+       PSFC(i,j)=P8w(i,kms,j)
+     ENDDO
+   ENDDO
+
+   if(igpvs.eq.0) CALL GFUNCPHYS
+   igpvs=1
+
+!-------------  J LOOP (OUTER) --------------------------------------------------
+
+   big_outer_j_loop: DO J=jts,jte
+
+! --------------- compute zi and zl -----------------------------------------
+      DO i=its,ite
+        ZI(I,KTS)=0.0
+      ENDDO
+
+      DO k=kts+1,kte
+        KM=K-1
+        DO i=its,ite
+          ZI(I,K)=ZI(I,KM)+dz8w(i,km,j)
+        ENDDO
+      ENDDO
+
+      DO k=kts+1,kte
+        KM=K-1
+        DO i=its,ite
+          ZL(I,KM)=(ZI(I,K)+ZI(I,KM))*0.5
+        ENDDO
+      ENDDO
+
+      DO i=its,ite
+        ZL(I,KTE)=2.*ZI(I,KTE)-ZL(I,KTE-1)
+      ENDDO
+
+! --------------- end compute zi and zl -------------------------------------
+
+      DO i=its,ite
+        PS(i)=PSFC(i,j)*.001
+        RCS(i)=1.
+        SLIMSK(i)=ABS(XLAND(i,j)-2.)
+      ENDDO
+
+#if (NMM_CORE == 1)
+      if(shalconv_use==1) then
+      DO i=its,ite
+         HPBL(I) = HPBL2D(I,J)          !kwon for shallow convection
+         EVAP(I) = EVAP2D(I,J)          !kwon for shallow convection
+         HEAT(I) = HEAT2D(I,J)          !kwon for shallow convection
+      ENDDO
+      endif
+#endif
+
+      DO i=its,ite
+        PRSI(i,kts)=PS(i)
+      ENDDO
+
+      DO k=kts,kte
+        kp=k+1
+        DO i=its,ite
+          PRSL(I,K)=Pcps(i,k,j)*.001
+          PHIL(I,K)=ZL(I,K)*GRAV
+          DOT(i,k)=-5.0E-4*GRAV*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j))
+        ENDDO
+      ENDDO
+
+      DO k=kts,kte
+        DO i=its,ite
+          DEL(i,k)=PRSL(i,k)*GRAV/RD*dz8w(i,k,j)/T3D(i,k,j)
+          U1(i,k)=U3D(i,k,j)
+          V1(i,k)=V3D(i,k,j)
+          Q1(i,k)=QV3D(i,k,j)/(1.+QV3D(i,k,j))
+          T1(i,k)=T3D(i,k,j)
+          QL(i,k,1)=QI3D(i,k,j)/(1.+QI3D(i,k,j))
+          QL(i,k,2)=QC3D(i,k,j)/(1.+QC3D(i,k,j))
+          PRSLK(I,K)=(PRSL(i,k)*.01)**ROVCP
+        ENDDO
+      ENDDO
+
+      DO k=kts+1,kte+1
+        km=k-1
+        DO i=its,ite
+          PRSI(i,k)=PRSI(i,km)-del(i,km) 
+        ENDDO
+      ENDDO
+
+!      CALL SASCNVN(IM,IM,KX,JCAP,DELT,DEL,PRSL,PS,PHIL,                  &
+!                  QL,Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,                    &
+!                  KTOP,KCNV,SLIMSK,DOT,NCLOUD,PGCON_USE,massf)
+      CALL SASCNVN_H(IM,IM,KX,JCAP,DELT,DEL,PRSL,PS,PHIL,               &
+                    QL,Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,                  &
+              KTOP,KCNV,SLIMSK,DOT,NCLOUD,PGCON_USE,massf)
+!
+      do i=its,ite
+        RAINCV1(I,J)=RN(I)*1000./STEPCU
+        PRATEC1(I,J)=RN(I)*1000./(STEPCU * DT)
+      enddo
+!
+      do i=its,ite
+        RAINCV2(I,J)=0.
+        PRATEC2(I,J)=0.
+      enddo
+!
+
+      if_shallow_conv: if(shalconv_use==1) then
+#if (NMM_CORE == 1)
+         ! NMM calls the new shallow convection developed by J Han
+         ! (Added to WRF by Y.Kwon)
+        call shalcnv(im,im,kx,jcap,delt,del,prsl,ps,phil,ql,        &
+     &               q1,t1,u1,v1,rcs,rn,kbot,ktop,kcnv,slimsk,      &
+     &               dot,ncloud,hpbl,heat,evap,shal_pgcon_use)
+!
+      DO I=ITS,ITE
+        RAINCV2(I,J)=RN(I)*1000./STEPCU
+        PRATEC2(I,J)=RN(I)*1000./(STEPCU * DT)
+      ENDDO
+!
+#else
+#if (EM_CORE == 1)
+        ! NOTE: ARW should be able to call the new shalcnv here, but
+        ! they need to add the three new variables, so I'm leaving the
+        ! old shallow convection call here - Sam Trahan
+        CALL OLD_ARW_SHALCV(IM,IM,KX,DELT,DEL,PRSI,PRSL,PRSLK,KCNV,Q1,T1,DPSHC)
+#else
+        ! Shallow convection is untested for other cores.
+#endif
+#endif
+     endif if_shallow_conv
+
+        DO I=ITS,ITE
+        RAINCV(I,J)= RAINCV1(I,J) + RAINCV2(I,J)
+        PRATEC(I,J)= PRATEC1(I,J) + PRATEC2(I,J)
+        HBOT(I,J)=KBOT(I)
+        HTOP(I,J)=KTOP(I)
+      ENDDO
+
+      DO K=KTS,KTE
+        DO I=ITS,ITE
+          RTHCUTEN(I,K,J)=(T1(I,K)-T3D(I,K,J))/PI3D(I,K,J)*RDELT
+          RQVCUTEN(I,K,J)=(Q1(I,K)/(1.-q1(i,k))-QV3D(I,K,J))*RDELT
+        ENDDO
+      ENDDO
+
+!===============================================================================
+!     ADD MOMENTUM MIXING TERM AS TENDENCIES. This is gopal's doing for SAS
+!     MOMMIX is the reduction factor set to 0.7 by default. Because NMM has 
+!     divergence damping term, a reducion factor for cumulum mixing may be
+!     required otherwise storms were too weak.
+!===============================================================================
+!
+#if (NMM_CORE == 1)
+      DO K=KTS,KTE
+        DO I=ITS,ITE
+!         RUCUTEN(I,J,K)=MOMMIX*(U1(I,K)-U3D(I,K,J))*RDELT
+!         RVCUTEN(I,J,K)=MOMMIX*(V1(I,K)-V3D(I,K,J))*RDELT
+         RUCUTEN(I,J,K)=(U1(I,K)-U3D(I,K,J))*RDELT
+         RVCUTEN(I,J,K)=(V1(I,K)-V3D(I,K,J))*RDELT
+        ENDDO
+      ENDDO
+#endif
+
+
+      IF(P_QC .ge. P_FIRST_SCALAR)THEN
+        DO K=KTS,KTE
+          DO I=ITS,ITE
+            RQCCUTEN(I,K,J)=(QL(I,K,2)/(1.-ql(i,k,2))-QC3D(I,K,J))*RDELT
+          ENDDO
+        ENDDO
+      ENDIF
+
+      IF(P_QI .ge. P_FIRST_SCALAR)THEN
+        DO K=KTS,KTE
+          DO I=ITS,ITE
+            RQICUTEN(I,K,J)=(QL(I,K,1)/(1.-ql(i,k,1))-QI3D(I,K,J))*RDELT
+          ENDDO
+        ENDDO
+      ENDIF
+
+   ENDDO big_outer_j_loop    ! Outer most J loop
+
+   END SUBROUTINE CU_MESO_SAS
+
+!====================================================================
+   SUBROUTINE msasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,          &
+                      RUCUTEN,RVCUTEN,                              &   
+                      RESTART,P_QC,P_QI,P_FIRST_SCALAR,             &
+                      allowed_to_read,                              &
+                      ids, ide, jds, jde, kds, kde,                 &
+                      ims, ime, jms, jme, kms, kme,                 &
+                      its, ite, jts, jte, kts, kte                  )
+!--------------------------------------------------------------------
+   IMPLICIT NONE
+!--------------------------------------------------------------------
+   LOGICAL , INTENT(IN)           ::  allowed_to_read,restart
+   INTEGER , INTENT(IN)           ::  ids, ide, jds, jde, kds, kde, &
+                                      ims, ime, jms, jme, kms, kme, &
+                                      its, ite, jts, jte, kts, kte
+   INTEGER , INTENT(IN)           ::  P_FIRST_SCALAR, P_QI, P_QC
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::  &
+                                                              RTHCUTEN, &
+                                                              RQVCUTEN, &
+                                                              RQCCUTEN, &
+                                                              RQICUTEN
+   REAL,     DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(OUT) ::  &
+                                                              RUCUTEN,  & ! gopal's doing for SAS
+                                                              RVCUTEN   
+
+   INTEGER :: i, j, k, itf, jtf, ktf
+
+   jtf=min0(jte,jde-1)
+   ktf=min0(kte,kde-1)
+   itf=min0(ite,ide-1)
+
+#ifdef HWRF
+!zhang's doing
+   IF(.not.restart .or. .not.allowed_to_read)THEN
+!end of zhang's doing
+#else
+   IF(.not.restart)THEN
+#endif
+     DO j=jts,jtf
+     DO k=kts,ktf
+     DO i=its,itf
+       RTHCUTEN(i,k,j)=0.
+       RQVCUTEN(i,k,j)=0.
+       RUCUTEN(i,j,k)=0.   
+       RVCUTEN(i,j,k)=0.    
+     ENDDO
+     ENDDO
+     ENDDO
+
+     IF (P_QC .ge. P_FIRST_SCALAR) THEN
+        DO j=jts,jtf
+        DO k=kts,ktf
+        DO i=its,itf
+           RQCCUTEN(i,k,j)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+     ENDIF
+
+     IF (P_QI .ge. P_FIRST_SCALAR) THEN
+        DO j=jts,jtf
+        DO k=kts,ktf
+        DO i=its,itf
+           RQICUTEN(i,k,j)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+     ENDIF
+   ENDIF
+
+      END SUBROUTINE msasinit
+
+! ------------------------------------------------------------------------
+
+      SUBROUTINE SASCNV(IM,IX,KM,JCAP,DELT,DEL,PRSL,PS,PHIL,QL,         &
+!     SUBROUTINE SASCNV(IM,IX,KM,JCAP,DLT,DEL,PRSL,PHIL,QL,             &
+     &       Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,KTOP,KUO,SLIMSK,            &
+     &       DOT,XKT2,ncloud)
+!  for cloud water version
+!     parameter(ncloud=0)
+!     SUBROUTINE SASCNV(KM,JCAP,DELT,DEL,SL,SLK,PS,QL,
+!    &       Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,KTOP,KUO,SLIMSK,
+!    &       DOT,xkt2,ncloud)
+!
+      USE MODULE_GFS_MACHINE , ONLY : kind_phys
+      USE MODULE_GFS_FUNCPHYS ,ONLY : fpvs
+      USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP &
+     &,             RV => con_RV, FV => con_fvirt, T0C => con_T0C       &
+     &,             CVAP => con_CVAP, CLIQ => con_CLIQ                  &
+     &,             EPS => con_eps, EPSM1 => con_epsm1
+
+      implicit none
+!
+!     include 'constant.h'
+!
+      integer            IM, IX,  KM, JCAP, ncloud,                     &
+     &                   KBOT(IM), KTOP(IM), KUO(IM), J
+      real(kind=kind_phys) DELT
+      real(kind=kind_phys) PS(IM),      DEL(IX,KM),  PRSL(IX,KM),       &
+!     real(kind=kind_phys)              DEL(IX,KM),  PRSL(IX,KM),
+     &                     QL(IX,KM,2), Q1(IX,KM),   T1(IX,KM),         &
+     &                     U1(IX,KM),   V1(IX,KM),   RCS(IM),           &
+     &                     CLDWRK(IM),  RN(IM),      SLIMSK(IM),        &
+     &                     DOT(IX,KM),  XKT2(IM),    PHIL(IX,KM)
+!
+      integer              I, INDX, jmn, k, knumb, latd, lond, km1
+!
+      real(kind=kind_phys) adw,     alpha,   alphal,  alphas,           &
+     &                     aup,     beta,    betal,   betas,            &
+     &                     c0,      cpoel,   dellat,  delta,            &
+     &                     desdt,   deta,    detad,   dg,               &
+     &                     dh,      dhh,     dlnsig,  dp,               &
+     &                     dq,      dqsdp,   dqsdt,   dt,               &
+     &                     dt2,     dtmax,   dtmin,   dv1,              &
+     &                     dv1q,    dv2,     dv2q,    dv1u,             &
+     &                     dv1v,    dv2u,    dv2v,    dv3u,             &
+     &                     dv3v,    dv3,     dv3q,    dvq1,             &
+     &                     dz,      dz1,     e1,      edtmax,           &
+     &                     edtmaxl, edtmaxs, el2orc,  elocp,            &
+     &                     es,      etah,                               &
+     &                     evef,    evfact,  evfactl, fact1,            &
+     &                     fact2,   factor,  fjcap,   fkm,              &
+     &                     fuv,     g,       gamma,   onemf,            &
+     &                     onemfu,  pdetrn,  pdpdwn,  pprime,           &
+     &                     qc,      qlk,     qrch,    qs,               &
+     &                     rain,    rfact,   shear,   tem1,             &
+     &                     tem2,    terr,    val,     val1,             &
+     &                     val2,    w1,      w1l,     w1s,              &
+     &                     w2,      w2l,     w2s,     w3,               &
+     &                     w3l,     w3s,     w4,      w4l,              & 
+     &                     w4s,     xdby,    xpw,     xpwd,             & 
+     &                     xqc,     xqrch,   xlambu,  mbdt,             &
+     &                     tem
+!
+!
+      integer              JMIN(IM), KB(IM), KBCON(IM), KBDTR(IM),      & 
+     &                     KT2(IM),  KTCON(IM), LMIN(IM),               &
+     &                     kbm(IM),  kbmax(IM), kmax(IM)
+!
+      real(kind=kind_phys) AA1(IM),     ACRT(IM),   ACRTFCT(IM),        & 
+     &                     DELHBAR(IM), DELQ(IM),   DELQ2(IM),          &
+     &                     DELQBAR(IM), DELQEV(IM), DELTBAR(IM),        &
+     &                     DELTV(IM),   DTCONV(IM), EDT(IM),            &
+     &                     EDTO(IM),    EDTX(IM),   FLD(IM),            &
+     &                     HCDO(IM),    HKBO(IM),   HMAX(IM),           &
+     &                     HMIN(IM),    HSBAR(IM),  UCDO(IM),           &
+     &                     UKBO(IM),    VCDO(IM),   VKBO(IM),           &
+     &                     PBCDIF(IM),  PDOT(IM),   PO(IM,KM),          &
+     &                                  PWAVO(IM),  PWEVO(IM),          &
+!    &                     PSFC(IM),    PWAVO(IM),  PWEVO(IM),          &
+     &                     QCDO(IM),    QCOND(IM),  QEVAP(IM),          &
+     &                     QKBO(IM),    RNTOT(IM),  VSHEAR(IM),         &
+     &                     XAA0(IM),    XHCD(IM),   XHKB(IM),           & 
+     &                     XK(IM),      XLAMB(IM),  XLAMD(IM),          &
+     &                     XMB(IM),     XMBMAX(IM), XPWAV(IM),          &
+     &                     XPWEV(IM),   XQCD(IM),   XQKB(IM)
+!
+!  PHYSICAL PARAMETERS
+      PARAMETER(G=grav)
+      PARAMETER(CPOEL=CP/HVAP,ELOCP=HVAP/CP,                            &
+     &          EL2ORC=HVAP*HVAP/(RV*CP))
+      PARAMETER(TERR=0.,C0=.002,DELTA=fv)
+      PARAMETER(FACT1=(CVAP-CLIQ)/RV,FACT2=HVAP/RV-FACT1*T0C)
+!  LOCAL VARIABLES AND ARRAYS
+      real(kind=kind_phys) PFLD(IM,KM),    TO(IM,KM),     QO(IM,KM),    &
+     &                     UO(IM,KM),      VO(IM,KM),     QESO(IM,KM)
+!  cloud water
+      real(kind=kind_phys) QLKO_KTCON(IM), DELLAL(IM),    TVO(IM,KM),   &
+     &                     DBYO(IM,KM),    ZO(IM,KM),     SUMZ(IM,KM),  &
+     &                     SUMH(IM,KM),    HEO(IM,KM),    HESO(IM,KM),  &
+     &                     QRCD(IM,KM),    DELLAH(IM,KM), DELLAQ(IM,KM),&
+     &                     DELLAU(IM,KM),  DELLAV(IM,KM), HCKO(IM,KM),  &
+     &                     UCKO(IM,KM),    VCKO(IM,KM),   QCKO(IM,KM),  &
+     &                     ETA(IM,KM),     ETAU(IM,KM),   ETAD(IM,KM),  &
+     &                     QRCDO(IM,KM),   PWO(IM,KM),    PWDO(IM,KM),  &
+     &                     RHBAR(IM),      TX1(IM)
+!
+      LOGICAL TOTFLG, CNVFLG(IM), DWNFLG(IM), DWNFLG2(IM), FLG(IM)
+!
+      real(kind=kind_phys) PCRIT(15), ACRITT(15), ACRIT(15)
+!     SAVE PCRIT, ACRITT
+      DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,     &
+     &           350.,300.,250.,200.,150./
+      DATA ACRITT/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216,       &
+     &           .3151,.3677,.41,.5255,.7663,1.1686,1.6851/
+!  GDAS DERIVED ACRIT
+!     DATA ACRITT/.203,.515,.521,.566,.625,.665,.659,.688,              & 
+!    &            .743,.813,.886,.947,1.138,1.377,1.896/
+!
+      real(kind=kind_phys) TF, TCR, TCRF, RZERO, RONE
+      parameter (TF=233.16, TCR=263.16, TCRF=1.0/(TCR-TF))
+      parameter (RZERO=0.0,RONE=1.0)
+!-----------------------------------------------------------------------
+!
+      km1 = km - 1
+!  INITIALIZE ARRAYS
+!
+      DO I=1,IM
+        RN(I)=0.
+        KBOT(I)=KM+1
+        KTOP(I)=0
+        KUO(I)=0
+        CNVFLG(I) = .TRUE.
+        DTCONV(I) = 3600.
+        CLDWRK(I) = 0.
+        PDOT(I) = 0.
+        KT2(I) = 0
+        QLKO_KTCON(I) = 0.
+        DELLAL(I) = 0.
+      ENDDO
+!!
+      DO K = 1, 15
+        ACRIT(K) = ACRITT(K) * (975. - PCRIT(K))
+      ENDDO
+      DT2 = DELT
+!cmr  dtmin = max(dt2,1200.)
+      val   =         1200.
+      dtmin = max(dt2, val )
+!cmr  dtmax = max(dt2,3600.)
+      val   =         3600.
+      dtmax = max(dt2, val )
+!  MODEL TUNABLE PARAMETERS ARE ALL HERE
+      MBDT    = 10.
+      EDTMAXl = .3
+      EDTMAXs = .3
+      ALPHAl  = .5
+      ALPHAs  = .5
+      BETAl   = .15
+      betas   = .15
+      BETAl   = .05
+      betas   = .05
+!     change for hurricane model
+        BETAl = .5
+        betas = .5
+!     EVEF    = 0.07
+      evfact  = 0.3
+      evfactl = 0.3
+!     change for hurricane model
+         evfact = 0.6
+         evfactl = .6
+#if ( EM_CORE == 1 )
+!  HAWAII TEST - ZCX
+      ALPHAl  = .5
+      ALPHAs  = .75
+      BETAl   = .05
+      betas   = .05
+      evfact  = 0.5
+      evfactl = 0.5
+#endif
+      PDPDWN  = 0.
+      PDETRN  = 200.
+      xlambu  = 1.e-4
+      fjcap   = (float(jcap) / 126.) ** 2
+!cmr  fjcap   = max(fjcap,1.)
+      val     =           1.
+      fjcap   = max(fjcap,val)
+      fkm     = (float(km) / 28.) ** 2
+!cmr  fkm     = max(fkm,1.)
+      fkm     = max(fkm,val)
+      W1l     = -8.E-3 
+      W2l     = -4.E-2
+      W3l     = -5.E-3 
+      W4l     = -5.E-4
+      W1s     = -2.E-4
+      W2s     = -2.E-3
+      W3s     = -1.E-3
+      W4s     = -2.E-5
+!CCCC IF(IM.EQ.384) THEN
+        LATD  = 92
+        lond  = 189
+!CCCC ELSEIF(IM.EQ.768) THEN
+!CCCC   LATD = 80
+!CCCC ELSE
+!CCCC   LATD = 0
+!CCCC ENDIF
+!
+!  DEFINE TOP LAYER FOR SEARCH OF THE DOWNDRAFT ORIGINATING LAYER
+!  AND THE MAXIMUM THETAE FOR UPDRAFT
+!
+      DO I=1,IM
+        KBMAX(I) = KM
+        KBM(I)   = KM
+        KMAX(I)  = KM
+        TX1(I)   = 1.0 / PS(I)
+      ENDDO
+!     
+      DO K = 1, KM
+        DO I=1,IM
+          IF (prSL(I,K)*tx1(I) .GT. 0.45) KBMAX(I) = K + 1
+          IF (prSL(I,K)*tx1(I) .GT. 0.70) KBM(I)   = K + 1
+          IF (prSL(I,K)*tx1(I) .GT. 0.04) KMAX(I)  = MIN(KM,K + 1)
+        ENDDO
+      ENDDO
+      DO I=1,IM
+        KBMAX(I) = MIN(KBMAX(I),KMAX(I))
+        KBM(I)   = MIN(KBM(I),KMAX(I))
+      ENDDO
+!
+!   CONVERT SURFACE PRESSURE TO MB FROM CB
+!
+!!
+      DO K = 1, KM
+        DO I=1,IM
+          if (K .le. kmax(i)) then
+            PFLD(I,k) = PRSL(I,K) * 10.0
+            PWO(I,k)  = 0.
+            PWDO(I,k) = 0.
+            TO(I,k)   = T1(I,k)
+            QO(I,k)   = Q1(I,k)
+            UO(I,k)   = U1(I,k)
+            VO(I,k)   = V1(I,k)
+            DBYO(I,k) = 0.
+            SUMZ(I,k) = 0.
+            SUMH(I,k) = 0.
+          endif
+        ENDDO
+      ENDDO
+
+!
+!  COLUMN VARIABLES
+!  P IS PRESSURE OF THE LAYER (MB)
+!  T IS TEMPERATURE AT T-DT (K)..TN
+!  Q IS MIXING RATIO AT T-DT (KG/KG)..QN
+!  TO IS TEMPERATURE AT T+DT (K)... THIS IS AFTER ADVECTION AND TURBULAN
+!  QO IS MIXING RATIO AT T+DT (KG/KG)..Q1
+!
+      DO K = 1, KM
+        DO I=1,IM
+          if (k .le. kmax(i)) then
+         !jfe        QESO(I,k) = 10. * FPVS(T1(I,k))
+         !
+            QESO(I,k) = 0.01 * fpvs(T1(I,K))      ! fpvs is in Pa
+         !
+            QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k) + EPSM1*QESO(I,k))
+         !cmr        QESO(I,k) = MAX(QESO(I,k),1.E-8)
+            val1      =             1.E-8
+            QESO(I,k) = MAX(QESO(I,k), val1)
+         !cmr        QO(I,k)   = max(QO(I,k),1.e-10)
+            val2      =           1.e-10
+            QO(I,k)   = max(QO(I,k), val2 )
+         !           QO(I,k)   = MIN(QO(I,k),QESO(I,k))
+            TVO(I,k)  = TO(I,k) + DELTA * TO(I,k) * QO(I,k)
+          endif
+        ENDDO
+      ENDDO
+
+!
+!  HYDROSTATIC HEIGHT ASSUME ZERO TERR
+!
+      DO K = 1, KM
+        DO I=1,IM
+          ZO(I,k) = PHIL(I,k) / G
+        ENDDO
+      ENDDO
+!  COMPUTE MOIST STATIC ENERGY
+      DO K = 1, KM
+        DO I=1,IM
+          if (K .le. kmax(i)) then
+!           tem       = G * ZO(I,k) + CP * TO(I,k)
+            tem       = PHIL(I,k) + CP * TO(I,k)
+            HEO(I,k)  = tem  + HVAP * QO(I,k)
+            HESO(I,k) = tem  + HVAP * QESO(I,k)
+!           HEO(I,k)  = MIN(HEO(I,k),HESO(I,k))
+          endif
+        ENDDO
+      ENDDO
+!
+!  DETERMINE LEVEL WITH LARGEST MOIST STATIC ENERGY
+!  THIS IS THE LEVEL WHERE UPDRAFT STARTS
+!
+      DO I=1,IM
+        HMAX(I) = HEO(I,1)
+        KB(I) = 1
+      ENDDO
+!!
+      DO K = 2, KM
+        DO I=1,IM
+          if (k .le. kbm(i)) then
+            IF(HEO(I,k).GT.HMAX(I).AND.CNVFLG(I)) THEN
+              KB(I)   = K
+              HMAX(I) = HEO(I,k)
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!     DO K = 1, KMAX - 1
+!         TOL(k) = .5 * (TO(I,k) + TO(I,k+1))
+!         QOL(k) = .5 * (QO(I,k) + QO(I,k+1))
+!         QESOL(I,k) = .5 * (QESO(I,k) + QESO(I,k+1))
+!         HEOL(I,k) = .5 * (HEO(I,k) + HEO(I,k+1))
+!         HESOL(I,k) = .5 * (HESO(I,k) + HESO(I,k+1))
+!     ENDDO
+      DO K = 1, KM1
+        DO I=1,IM
+          if (k .le. kmax(i)-1) then
+            DZ      = .5 * (ZO(I,k+1) - ZO(I,k))
+            DP      = .5 * (PFLD(I,k+1) - PFLD(I,k))
+!jfe        ES      = 10. * FPVS(TO(I,k+1))
+!
+            ES      = 0.01 * fpvs(TO(I,K+1))      ! fpvs is in Pa
+!
+            PPRIME  = PFLD(I,k+1) + EPSM1 * ES
+            QS      = EPS * ES / PPRIME
+            DQSDP   = - QS / PPRIME
+            DESDT   = ES * (FACT1 / TO(I,k+1) + FACT2 / (TO(I,k+1)**2))
+            DQSDT   = QS * PFLD(I,k+1) * DESDT / (ES * PPRIME)
+            GAMMA   = EL2ORC * QESO(I,k+1) / (TO(I,k+1)**2)
+            DT      = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA))
+            DQ      = DQSDT * DT + DQSDP * DP
+            TO(I,k) = TO(I,k+1) + DT
+            QO(I,k) = QO(I,k+1) + DQ
+            PO(I,k) = .5 * (PFLD(I,k) + PFLD(I,k+1))
+          endif
+        ENDDO
+      ENDDO
+!
+      DO K = 1, KM1
+        DO I=1,IM
+          if (k .le. kmax(I)-1) then
+!jfe        QESO(I,k) = 10. * FPVS(TO(I,k))
+!
+            QESO(I,k) = 0.01 * fpvs(TO(I,K))      ! fpvs is in Pa
+!
+            QESO(I,k) = EPS * QESO(I,k) / (PO(I,k) + EPSM1*QESO(I,k))
+!cmr        QESO(I,k) = MAX(QESO(I,k),1.E-8)
+            val1      =             1.E-8
+            QESO(I,k) = MAX(QESO(I,k), val1)
+!cmr        QO(I,k)   = max(QO(I,k),1.e-10)
+            val2      =           1.e-10
+            QO(I,k)   = max(QO(I,k), val2 )
+!           QO(I,k)   = MIN(QO(I,k),QESO(I,k))
+            HEO(I,k)  = .5 * G * (ZO(I,k) + ZO(I,k+1)) +                &
+     &                  CP * TO(I,k) + HVAP * QO(I,k)
+            HESO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) +                & 
+     &                  CP * TO(I,k) + HVAP * QESO(I,k)
+            UO(I,k)   = .5 * (UO(I,k) + UO(I,k+1))
+            VO(I,k)   = .5 * (VO(I,k) + VO(I,k+1))
+          endif
+        ENDDO
+      ENDDO
+!     k = kmax
+!       HEO(I,k) = HEO(I,k)
+!       hesol(k) = HESO(I,k)
+!      IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
+!        PRINT *, '   HEO ='
+!        PRINT 6001, (HEO(I,K),K=1,KMAX)
+!        PRINT *, '   HESO ='
+!        PRINT 6001, (HESO(I,K),K=1,KMAX)
+!        PRINT *, '   TO ='
+!        PRINT 6002, (TO(I,K)-273.16,K=1,KMAX)
+!        PRINT *, '   QO ='
+!        PRINT 6003, (QO(I,K),K=1,KMAX)
+!        PRINT *, '   QSO ='
+!        PRINT 6003, (QESO(I,K),K=1,KMAX)
+!      ENDIF
+!
+!  LOOK FOR CONVECTIVE CLOUD BASE AS THE LEVEL OF FREE CONVECTION
+!
+      DO I=1,IM
+        IF(CNVFLG(I)) THEN
+          INDX    = KB(I)
+          HKBO(I) = HEO(I,INDX)
+          QKBO(I) = QO(I,INDX)
+          UKBO(I) = UO(I,INDX)
+          VKBO(I) = VO(I,INDX)
+        ENDIF
+        FLG(I)    = CNVFLG(I)
+        KBCON(I)  = KMAX(I)
+      ENDDO
+!!
+      DO K = 1, KM
+        DO I=1,IM
+          if (k .le. kbmax(i)) then
+            IF(FLG(I).AND.K.GT.KB(I)) THEN
+              HSBAR(I)   = HESO(I,k)
+              IF(HKBO(I).GT.HSBAR(I)) THEN
+                FLG(I)   = .FALSE.
+                KBCON(I) = K
+              ENDIF
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+      DO I=1,IM
+        IF(CNVFLG(I)) THEN
+          PBCDIF(I) = -PFLD(I,KBCON(I)) + PFLD(I,KB(I))
+          PDOT(I)   = 10.* DOT(I,KBCON(I))
+          IF(PBCDIF(I).GT.150.)    CNVFLG(I) = .FALSE.
+          IF(KBCON(I).EQ.KMAX(I))  CNVFLG(I) = .FALSE.
+        ENDIF
+      ENDDO
+!!
+      TOTFLG = .TRUE.
+      DO I=1,IM
+        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
+      ENDDO
+      IF(TOTFLG) RETURN
+!  FOUND LFC, CAN DEFINE REST OF VARIABLES
+ 6001 FORMAT(2X,-2P10F12.2)
+ 6002 FORMAT(2X,10F12.2)
+ 6003 FORMAT(2X,3P10F12.2)
+
+!
+!  DETERMINE ENTRAINMENT RATE BETWEEN KB AND KBCON
+!
+      DO I = 1, IM
+        alpha = alphas
+        if(SLIMSK(I).eq.1.) alpha = alphal
+        IF(CNVFLG(I)) THEN
+          IF(KB(I).EQ.1) THEN
+            DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1)) - ZO(I,1)
+          ELSE
+            DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1))               &
+     &         - .5 * (ZO(I,KB(I)) + ZO(I,KB(I)-1))
+          ENDIF
+          IF(KBCON(I).NE.KB(I)) THEN
+!cmr        XLAMB(I) = -ALOG(ALPHA) / DZ
+            XLAMB(I) = - LOG(ALPHA) / DZ
+          ELSE
+            XLAMB(I) = 0.
+          ENDIF
+        ENDIF
+      ENDDO
+!  DETERMINE UPDRAFT MASS FLUX
+      DO K = 1, KM
+        DO I = 1, IM
+          if (k .le. kmax(i) .and. CNVFLG(I)) then
+            ETA(I,k)  = 1.
+            ETAU(I,k) = 1.
+          ENDIF
+        ENDDO
+      ENDDO
+      DO K = KM1, 2, -1
+        DO I = 1, IM
+          if (k .le. kbmax(i)) then
+            IF(CNVFLG(I).AND.K.LT.KBCON(I).AND.K.GE.KB(I)) THEN
+              DZ        = .5 * (ZO(I,k+1) - ZO(I,k-1))
+              ETA(I,k)  = ETA(I,k+1) * EXP(-XLAMB(I) * DZ)
+              ETAU(I,k) = ETA(I,k)
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+      DO I = 1, IM
+        IF(CNVFLG(I).AND.KB(I).EQ.1.AND.KBCON(I).GT.1) THEN
+          DZ = .5 * (ZO(I,2) - ZO(I,1))
+          ETA(I,1) = ETA(I,2) * EXP(-XLAMB(I) * DZ)
+          ETAU(I,1) = ETA(I,1)
+        ENDIF
+      ENDDO
+!
+!  WORK UP UPDRAFT CLOUD PROPERTIES
+!
+      DO I = 1, IM
+        IF(CNVFLG(I)) THEN
+          INDX         = KB(I)
+          HCKO(I,INDX) = HKBO(I)
+          QCKO(I,INDX) = QKBO(I)
+          UCKO(I,INDX) = UKBO(I)
+          VCKO(I,INDX) = VKBO(I)
+          PWAVO(I)     = 0.
+        ENDIF
+      ENDDO
+!
+!  CLOUD PROPERTY BELOW CLOUD BASE IS MODIFIED BY THE ENTRAINMENT PROCES
+!
+      DO K = 2, KM1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+            IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN
+              FACTOR = ETA(I,k-1) / ETA(I,k)
+              ONEMF = 1. - FACTOR
+              HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF *                &
+     &                    .5 * (HEO(I,k) + HEO(I,k+1))
+              UCKO(I,k) = FACTOR * UCKO(I,k-1) + ONEMF *                & 
+     &                    .5 * (UO(I,k) + UO(I,k+1))
+              VCKO(I,k) = FACTOR * VCKO(I,k-1) + ONEMF *                &
+     &                    .5 * (VO(I,k) + VO(I,k+1))
+              DBYO(I,k) = HCKO(I,k) - HESO(I,k)
+            ENDIF
+            IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN
+              HCKO(I,k) = HCKO(I,k-1)
+              UCKO(I,k) = UCKO(I,k-1)
+              VCKO(I,k) = VCKO(I,k-1)
+              DBYO(I,k) = HCKO(I,k) - HESO(I,k)
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!  DETERMINE CLOUD TOP
+      DO I = 1, IM
+        FLG(I) = CNVFLG(I)
+        KTCON(I) = 1
+      ENDDO
+!     DO K = 2, KMAX
+!       KK = KMAX - K + 1
+!         IF(DBYO(I,kK).GE.0..AND.FLG(I).AND.KK.GT.KBCON(I)) THEN
+!           KTCON(I) = KK + 1
+!           FLG(I) = .FALSE.
+!         ENDIF
+!     ENDDO
+      DO K = 2, KM
+        DO I = 1, IM
+          if (k .le. kmax(i)) then
+            IF(DBYO(I,k).LT.0..AND.FLG(I).AND.K.GT.KBCON(I)) THEN
+              KTCON(I) = K
+              FLG(I) = .FALSE.
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+      DO I = 1, IM
+        IF(CNVFLG(I).AND.(PFLD(I,KBCON(I)) - PFLD(I,KTCON(I))).LT.150.) &
+     &  CNVFLG(I) = .FALSE.
+      ENDDO
+      TOTFLG = .TRUE.
+      DO I = 1, IM
+        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
+      ENDDO
+      IF(TOTFLG) RETURN
+!
+!  SEARCH FOR DOWNDRAFT ORIGINATING LEVEL ABOVE THETA-E MINIMUM
+!
+      DO I = 1, IM
+        HMIN(I) = HEO(I,KBCON(I))
+        LMIN(I) = KBMAX(I)
+        JMIN(I) = KBMAX(I)
+      ENDDO
+      DO I = 1, IM
+        DO K = KBCON(I), KBMAX(I)
+          IF(HEO(I,k).LT.HMIN(I).AND.CNVFLG(I)) THEN
+            LMIN(I) = K + 1
+            HMIN(I) = HEO(I,k)
+          ENDIF
+        ENDDO
+      ENDDO
+!
+!  Make sure that JMIN(I) is within the cloud
+!
+      DO I = 1, IM
+        IF(CNVFLG(I)) THEN
+          JMIN(I) = MIN(LMIN(I),KTCON(I)-1)
+          XMBMAX(I) = .1
+          JMIN(I) = MAX(JMIN(I),KBCON(I)+1)
+        ENDIF
+      ENDDO
+!
+!  ENTRAINING CLOUD
+!
+      do k = 2, km1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+            if(CNVFLG(I).and.k.gt.JMIN(I).and.k.le.KTCON(I)) THEN
+              SUMZ(I,k) = SUMZ(I,k-1) + .5 * (ZO(I,k+1) - ZO(I,k-1))
+              SUMH(I,k) = SUMH(I,k-1) + .5 * (ZO(I,k+1) - ZO(I,k-1))    &
+     &                  * HEO(I,k)
+            ENDIF
+          endif
+        enddo
+      enddo
+!!
+      DO I = 1, IM
+        IF(CNVFLG(I)) THEN
+!         call random_number(XKT2)
+!         call srand(fhour)
+!         XKT2(I) = rand()
+          KT2(I) = nint(XKT2(I)*float(KTCON(I)-JMIN(I))-.5)+JMIN(I)+1
+!         KT2(I) = nint(sqrt(XKT2(I))*float(KTCON(I)-JMIN(I))-.5) + JMIN(I) + 1
+!         KT2(I) = nint(ranf() *float(KTCON(I)-JMIN(I))-.5) + JMIN(I) + 1
+          tem1 = (HCKO(I,JMIN(I)) - HESO(I,KT2(I)))
+          tem2 = (SUMZ(I,KT2(I)) * HESO(I,KT2(I)) - SUMH(I,KT2(I)))
+          if (abs(tem2) .gt. 0.000001) THEN
+            XLAMB(I) = tem1 / tem2
+          else
+            CNVFLG(I) = .false.
+          ENDIF
+!         XLAMB(I) = (HCKO(I,JMIN(I)) - HESO(I,KT2(I)))
+!    &          / (SUMZ(I,KT2(I)) * HESO(I,KT2(I)) - SUMH(I,KT2(I)))
+          XLAMB(I) = max(XLAMB(I),RZERO)
+          XLAMB(I) = min(XLAMB(I),2.3/SUMZ(I,KT2(I)))
+        ENDIF
+      ENDDO
+!!
+      DO I = 1, IM
+       DWNFLG(I)  = CNVFLG(I)
+       DWNFLG2(I) = CNVFLG(I)
+       IF(CNVFLG(I)) THEN
+        if(KT2(I).ge.KTCON(I)) DWNFLG(I) = .false.
+      if(XLAMB(I).le.1.e-30.or.HCKO(I,JMIN(I))-HESO(I,KT2(I)).le.1.e-30)&
+     &  DWNFLG(I) = .false.
+        do k = JMIN(I), KT2(I)
+          if(DWNFLG(I).and.HEO(I,k).gt.HESO(I,KT2(I))) DWNFLG(I)=.false.
+        enddo
+!       IF(CNVFLG(I).AND.(PFLD(KBCON(I))-PFLD(KTCON(I))).GT.PDETRN)
+!    &     DWNFLG(I)=.FALSE.
+        IF(CNVFLG(I).AND.(PFLD(I,KBCON(I))-PFLD(I,KTCON(I))).LT.PDPDWN) &
+     &     DWNFLG2(I)=.FALSE.
+       ENDIF
+      ENDDO
+!!
+      DO K = 2, KM1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+            IF(DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KT2(I)) THEN
+              DZ        = .5 * (ZO(I,k+1) - ZO(I,k-1))
+!             ETA(I,k)  = ETA(I,k-1) * EXP( XLAMB(I) * DZ)
+!  to simplify matter, we will take the linear approach here
+!
+              ETA(I,k)  = ETA(I,k-1) * (1. + XLAMB(I) * dz)
+              ETAU(I,k) = ETAU(I,k-1) * (1. + (XLAMB(I)+xlambu) * dz)
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!!
+      DO K = 2, KM1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+!           IF(.NOT.DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KT2(I)) THEN
+            IF(.NOT.DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KTCON(I)) THEN
+              DZ        = .5 * (ZO(I,k+1) - ZO(I,k-1))
+              ETAU(I,k) = ETAU(I,k-1) * (1. + xlambu * dz)
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!      IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
+!        PRINT *, ' LMIN(I), KT2(I)=', LMIN(I), KT2(I)
+!        PRINT *, ' KBOT, KTOP, JMIN(I) =', KBCON(I), KTCON(I), JMIN(I)
+!      ENDIF
+!     IF(LAT.EQ.LATD.AND.lon.eq.lond) THEN
+!       print *, ' xlamb =', xlamb
+!       print *, ' eta =', (eta(k),k=1,KT2(I))
+!       print *, ' ETAU =', (ETAU(I,k),k=1,KT2(I))
+!       print *, ' HCKO =', (HCKO(I,k),k=1,KT2(I))
+!       print *, ' SUMZ =', (SUMZ(I,k),k=1,KT2(I))
+!       print *, ' SUMH =', (SUMH(I,k),k=1,KT2(I))
+!     ENDIF
+      DO I = 1, IM
+        if(DWNFLG(I)) THEN
+          KTCON(I) = KT2(I)
+        ENDIF
+      ENDDO
+!
+!  CLOUD PROPERTY ABOVE CLOUD Base IS MODIFIED BY THE DETRAINMENT PROCESS
+!
+      DO K = 2, KM1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+!jfe
+            IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN
+!jfe      IF(K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN
+              FACTOR    = ETA(I,k-1) / ETA(I,k)
+              ONEMF     = 1. - FACTOR
+              fuv       = ETAU(I,k-1) / ETAU(I,k)
+              onemfu    = 1. - fuv
+              HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF *                &
+     &                    .5 * (HEO(I,k) + HEO(I,k+1))
+              UCKO(I,k) = fuv * UCKO(I,k-1) + ONEMFu *                  &
+     &                    .5 * (UO(I,k) + UO(I,k+1))
+              VCKO(I,k) = fuv * VCKO(I,k-1) + ONEMFu *                  &
+     &                    .5 * (VO(I,k) + VO(I,k+1))
+              DBYO(I,k) = HCKO(I,k) - HESO(I,k)
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!      IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
+!        PRINT *, ' UCKO=', (UCKO(I,k),k=KBCON(I)+1,KTCON(I))
+!        PRINT *, ' uenv=', (.5*(UO(I,k)+UO(I,k-1)),k=KBCON(I)+1,KTCON(I))
+!      ENDIF
+      DO I = 1, IM
+        if(CNVFLG(I).and.DWNFLG2(I).and.JMIN(I).le.KBCON(I))            &
+     &     THEN
+          CNVFLG(I) = .false.
+          DWNFLG(I) = .false.
+          DWNFLG2(I) = .false.
+        ENDIF
+      ENDDO
+!!
+      TOTFLG = .TRUE.
+      DO I = 1, IM
+        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
+      ENDDO
+      IF(TOTFLG) RETURN
+!!
+!
+!  COMPUTE CLOUD MOISTURE PROPERTY AND PRECIPITATION
+!
+      DO I = 1, IM
+          AA1(I) = 0.
+          RHBAR(I) = 0.
+      ENDDO
+      DO K = 1, KM
+        DO I = 1, IM
+          if (k .le. kmax(i)) then
+            IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN
+              DZ = .5 * (ZO(I,k+1) - ZO(I,k-1))
+              DZ1 = (ZO(I,k) - ZO(I,k-1))
+              GAMMA = EL2ORC * QESO(I,k) / (TO(I,k)**2)
+              QRCH = QESO(I,k)                                          &
+     &             + GAMMA * DBYO(I,k) / (HVAP * (1. + GAMMA))
+              FACTOR = ETA(I,k-1) / ETA(I,k)
+              ONEMF = 1. - FACTOR
+              QCKO(I,k) = FACTOR * QCKO(I,k-1) + ONEMF *                &
+     &                    .5 * (QO(I,k) + QO(I,k+1))
+              DQ = ETA(I,k) * QCKO(I,k) - ETA(I,k) * QRCH
+              RHBAR(I) = RHBAR(I) + QO(I,k) / QESO(I,k)
+!
+!  BELOW LFC CHECK IF THERE IS EXCESS MOISTURE TO RELEASE LATENT HEAT
+!
+              IF(DQ.GT.0.) THEN
+                ETAH = .5 * (ETA(I,k) + ETA(I,k-1))
+                QLK = DQ / (ETA(I,k) + ETAH * C0 * DZ)
+                AA1(I) = AA1(I) - DZ1 * G * QLK
+                QC = QLK + QRCH
+                PWO(I,k) = ETAH * C0 * DZ * QLK
+                QCKO(I,k) = QC
+                PWAVO(I) = PWAVO(I) + PWO(I,k)
+              ENDIF
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+      DO I = 1, IM
+        RHBAR(I) = RHBAR(I) / float(KTCON(I) - KB(I) - 1)
+      ENDDO
+!
+!  this section is ready for cloud water
+!
+      if(ncloud.gt.0) THEN
+!
+!  compute liquid and vapor separation at cloud top
+!
+      DO I = 1, IM
+        k = KTCON(I)
+        IF(CNVFLG(I)) THEN
+          GAMMA = EL2ORC * QESO(I,K) / (TO(I,K)**2)
+          QRCH = QESO(I,K)                                              &
+     &         + GAMMA * DBYO(I,K) / (HVAP * (1. + GAMMA))
+          DQ = QCKO(I,K-1) - QRCH
+!
+!  CHECK IF THERE IS EXCESS MOISTURE TO RELEASE LATENT HEAT
+!
+          IF(DQ.GT.0.) THEN
+            QLKO_KTCON(I) = dq
+            QCKO(I,K-1) = QRCH
+          ENDIF
+        ENDIF
+      ENDDO
+      ENDIF
+!
+!  CALCULATE CLOUD WORK FUNCTION AT T+DT
+!
+      DO K = 1, KM
+        DO I = 1, IM
+          if (k .le. kmax(i)) then
+            IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN
+              DZ1 = ZO(I,k) - ZO(I,k-1)
+              GAMMA = EL2ORC * QESO(I,k-1) / (TO(I,k-1)**2)
+              RFACT =  1. + DELTA * CP * GAMMA                          &
+     &                 * TO(I,k-1) / HVAP
+              AA1(I) = AA1(I) +                                         &
+     &                 DZ1 * (G / (CP * TO(I,k-1)))                     &
+     &                 * DBYO(I,k-1) / (1. + GAMMA)                     &
+     &                 * RFACT
+              val = 0.
+              AA1(I)=AA1(I)+                                            &
+     &                 DZ1 * G * DELTA *                                &
+!cmr &                 MAX( 0.,(QESO(I,k-1) - QO(I,k-1)))               & 
+     &                 MAX(val,(QESO(I,k-1) - QO(I,k-1)))
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+      DO I = 1, IM
+        IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG(I)  = .FALSE.
+        IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG2(I) = .FALSE.
+        IF(CNVFLG(I).AND.AA1(I).LE.0.) CNVFLG(I)  = .FALSE.
+      ENDDO
+!!
+      TOTFLG = .TRUE.
+      DO I = 1, IM
+        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
+      ENDDO
+      IF(TOTFLG) RETURN
+!!
+!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
+!cccc   PRINT *, ' AA1(I) BEFORE DWNDRFT =', AA1(I)
+!cccc ENDIF
+!
+!------- DOWNDRAFT CALCULATIONS
+!
+!
+!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
+!
+      DO I = 1, IM
+        IF(CNVFLG(I)) THEN
+          VSHEAR(I) = 0.
+        ENDIF
+      ENDDO
+      DO K = 1, KM
+        DO I = 1, IM
+          if (k .le. kmax(i)) then
+            IF(K.GE.KB(I).AND.K.LE.KTCON(I).AND.CNVFLG(I)) THEN
+              shear=rcs(I) * sqrt((UO(I,k+1)-UO(I,k)) ** 2              &
+     &                          + (VO(I,k+1)-VO(I,k)) ** 2)
+              VSHEAR(I) = VSHEAR(I) + SHEAR
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+      DO I = 1, IM
+        EDT(I) = 0.
+        IF(CNVFLG(I)) THEN
+          KNUMB = KTCON(I) - KB(I) + 1
+          KNUMB = MAX(KNUMB,1)
+          VSHEAR(I) = 1.E3 * VSHEAR(I) / (ZO(I,KTCON(I))-ZO(I,KB(I)))
+          E1=1.591-.639*VSHEAR(I)                                       &
+     &       +.0953*(VSHEAR(I)**2)-.00496*(VSHEAR(I)**3)
+          EDT(I)=1.-E1
+!cmr      EDT(I) = MIN(EDT(I),.9)
+          val =         .9
+          EDT(I) = MIN(EDT(I),val)
+!cmr      EDT(I) = MAX(EDT(I),.0)
+          val =         .0
+          EDT(I) = MAX(EDT(I),val)
+          EDTO(I)=EDT(I)
+          EDTX(I)=EDT(I)
+        ENDIF
+      ENDDO
+!  DETERMINE DETRAINMENT RATE BETWEEN 1 AND KBDTR
+      DO I = 1, IM
+        KBDTR(I) = KBCON(I)
+        beta = betas
+        if(SLIMSK(I).eq.1.) beta = betal
+        IF(CNVFLG(I)) THEN
+          KBDTR(I) = KBCON(I)
+          KBDTR(I) = MAX(KBDTR(I),1)
+          XLAMD(I) = 0.
+          IF(KBDTR(I).GT.1) THEN
+            DZ = .5 * ZO(I,KBDTR(I)) + .5 * ZO(I,KBDTR(I)-1)            &
+     &         - ZO(I,1)
+            XLAMD(I) =  LOG(BETA) / DZ
+          ENDIF
+        ENDIF
+      ENDDO
+!  DETERMINE DOWNDRAFT MASS FLUX
+      DO K = 1, KM
+        DO I = 1, IM
+          IF(k .le. kmax(i)) then
+            IF(CNVFLG(I)) THEN
+              ETAD(I,k) = 1.
+            ENDIF
+            QRCDO(I,k) = 0.
+          endif
+        ENDDO
+      ENDDO
+      DO K = KM1, 2, -1
+        DO I = 1, IM
+          if (k .le. kbmax(i)) then
+            IF(CNVFLG(I).AND.K.LT.KBDTR(I)) THEN
+              DZ        = .5 * (ZO(I,k+1) - ZO(I,k-1))
+              ETAD(I,k) = ETAD(I,k+1) * EXP(XLAMD(I) * DZ)
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+      K = 1
+      DO I = 1, IM
+        IF(CNVFLG(I).AND.KBDTR(I).GT.1) THEN
+          DZ = .5 * (ZO(I,2) - ZO(I,1))
+          ETAD(I,k) = ETAD(I,k+1) * EXP(XLAMD(I) * DZ)
+        ENDIF
+      ENDDO
+!
+!--- DOWNDRAFT MOISTURE PROPERTIES
+!
+      DO I = 1, IM
+        PWEVO(I) = 0.
+        FLG(I) = CNVFLG(I)
+      ENDDO
+      DO I = 1, IM
+        IF(CNVFLG(I)) THEN
+          JMN = JMIN(I)
+          HCDO(I) = HEO(I,JMN)
+          QCDO(I) = QO(I,JMN)
+          QRCDO(I,JMN) = QESO(I,JMN)
+          UCDO(I) = UO(I,JMN)
+          VCDO(I) = VO(I,JMN)
+        ENDIF
+      ENDDO
+      DO K = KM1, 1, -1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+            IF(CNVFLG(I).AND.K.LT.JMIN(I)) THEN
+              DQ = QESO(I,k)
+              DT = TO(I,k)
+              GAMMA      = EL2ORC * DQ / DT**2
+              DH         = HCDO(I) - HESO(I,k)
+              QRCDO(I,k) = DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH
+              DETAD      = ETAD(I,k+1) - ETAD(I,k)
+              PWDO(I,k)  = ETAD(I,k+1) * QCDO(I) -                      &
+     &                     ETAD(I,k) * QRCDO(I,k)
+              PWDO(I,k)  = PWDO(I,k) - DETAD *                          &
+     &                    .5 * (QRCDO(I,k) + QRCDO(I,k+1))
+              QCDO(I)    = QRCDO(I,k)
+              PWEVO(I)   = PWEVO(I) + PWDO(I,k)
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!     IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG(I)) THEN
+!       PRINT *, ' PWAVO(I), PWEVO(I) =', PWAVO(I), PWEVO(I)
+!     ENDIF
+!
+!--- FINAL DOWNDRAFT STRENGTH DEPENDENT ON PRECIP
+!--- EFFICIENCY (EDT), NORMALIZED CONDENSATE (PWAV), AND
+!--- EVAPORATE (PWEV)
+!
+      DO I = 1, IM
+        edtmax = edtmaxl
+        if(SLIMSK(I).eq.0.) edtmax = edtmaxs
+        IF(DWNFLG2(I)) THEN
+          IF(PWEVO(I).LT.0.) THEN
+            EDTO(I) = -EDTO(I) * PWAVO(I) / PWEVO(I)
+            EDTO(I) = MIN(EDTO(I),EDTMAX)
+          ELSE
+            EDTO(I) = 0.
+          ENDIF
+        ELSE
+          EDTO(I) = 0.
+        ENDIF
+      ENDDO
+!
+!
+!--- DOWNDRAFT CLOUDWORK FUNCTIONS
+!
+!
+      DO K = KM1, 1, -1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+            IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN
+              GAMMA = EL2ORC * QESO(I,k+1) / TO(I,k+1)**2
+              DHH=HCDO(I)
+              DT=TO(I,k+1)
+              DG=GAMMA
+              DH=HESO(I,k+1)
+              DZ=-1.*(ZO(I,k+1)-ZO(I,k))
+              AA1(I)=AA1(I)+EDTO(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG))   &
+     &               *(1.+DELTA*CP*DG*DT/HVAP)
+              val=0.
+              AA1(I)=AA1(I)+EDTO(I)*                                    & 
+!cmr &        DZ*G*DELTA*MAX( 0.,(QESO(I,k+1)-QO(I,k+1)))               &
+     &        DZ*G*DELTA*MAX(val,(QESO(I,k+1)-QO(I,k+1)))
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG2(I)) THEN
+!cccc   PRINT *, '  AA1(I) AFTER DWNDRFT =', AA1(I)
+!cccc ENDIF
+      DO I = 1, IM
+        IF(AA1(I).LE.0.) CNVFLG(I)  = .FALSE.
+        IF(AA1(I).LE.0.) DWNFLG(I)  = .FALSE.
+        IF(AA1(I).LE.0.) DWNFLG2(I) = .FALSE.
+      ENDDO
+!!
+      TOTFLG = .TRUE.
+      DO I = 1, IM
+        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
+      ENDDO
+      IF(TOTFLG) RETURN
+!!
+!
+!
+!--- WHAT WOULD THE CHANGE BE, THAT A CLOUD WITH UNIT MASS
+!--- WILL DO TO THE ENVIRONMENT?
+!
+      DO K = 1, KM
+        DO I = 1, IM
+          IF(k .le. kmax(i) .and. CNVFLG(I)) THEN
+            DELLAH(I,k) = 0.
+            DELLAQ(I,k) = 0.
+            DELLAU(I,k) = 0.
+            DELLAV(I,k) = 0.
+          ENDIF
+        ENDDO
+      ENDDO
+      DO I = 1, IM
+        IF(CNVFLG(I)) THEN
+          DP = 1000. * DEL(I,1)
+          DELLAH(I,1) = EDTO(I) * ETAD(I,1) * (HCDO(I)                  &
+     &                - HEO(I,1)) * G / DP
+          DELLAQ(I,1) = EDTO(I) * ETAD(I,1) * (QCDO(I)                  &
+     &                - QO(I,1)) * G / DP
+          DELLAU(I,1) = EDTO(I) * ETAD(I,1) * (UCDO(I)                  &
+     &                - UO(I,1)) * G / DP
+          DELLAV(I,1) = EDTO(I) * ETAD(I,1) * (VCDO(I)                  &
+     &                - VO(I,1)) * G / DP
+        ENDIF
+      ENDDO
+!
+!--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT
+!
+      DO K = 2, KM1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+            IF(CNVFLG(I).AND.K.LT.KTCON(I)) THEN
+              AUP = 1.
+              IF(K.LE.KB(I)) AUP = 0.
+              ADW = 1.
+              IF(K.GT.JMIN(I)) ADW = 0.
+              DV1= HEO(I,k)
+              DV2 = .5 * (HEO(I,k) + HEO(I,k+1))
+              DV3= HEO(I,k-1)
+              DV1Q= QO(I,k)
+              DV2Q = .5 * (QO(I,k) + QO(I,k+1))
+              DV3Q= QO(I,k-1)
+              DV1U= UO(I,k)
+              DV2U = .5 * (UO(I,k) + UO(I,k+1))
+              DV3U= UO(I,k-1)
+              DV1V= VO(I,k)
+              DV2V = .5 * (VO(I,k) + VO(I,k+1))
+              DV3V= VO(I,k-1)
+              DP = 1000. * DEL(I,K)
+              DZ = .5 * (ZO(I,k+1) - ZO(I,k-1))
+              DETA = ETA(I,k) - ETA(I,k-1)
+              DETAD = ETAD(I,k) - ETAD(I,k-1)
+              DELLAH(I,k) = DELLAH(I,k) +                               &
+     &            ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1   &
+     &        - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3   &
+     &                    - AUP * DETA * DV2                            &
+     &                    + ADW * EDTO(I) * DETAD * HCDO(I)) * G / DP
+              DELLAQ(I,k) = DELLAQ(I,k) +                               &
+     &            ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1Q  &
+     &        - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3Q  &
+     &                    - AUP * DETA * DV2Q                           &
+     &       +ADW*EDTO(I)*DETAD*.5*(QRCDO(I,k)+QRCDO(I,k-1))) * G / DP
+              DELLAU(I,k) = DELLAU(I,k) +                               &
+     &            ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1U  &
+     &        - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3U  &
+     &                     - AUP * DETA * DV2U                          &
+     &                    + ADW * EDTO(I) * DETAD * UCDO(I)             & 
+     &                    ) * G / DP
+              DELLAV(I,k) = DELLAV(I,k) +                               &
+     &            ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1V  &
+     &        - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3V  &
+     &                     - AUP * DETA * DV2V                          &
+     &                    + ADW * EDTO(I) * DETAD * VCDO(I)             &
+     &                    ) * G / DP
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!
+!------- CLOUD TOP
+!
+      DO I = 1, IM
+        IF(CNVFLG(I)) THEN
+          INDX = KTCON(I)
+          DP = 1000. * DEL(I,INDX)
+          DV1 = HEO(I,INDX-1)
+          DELLAH(I,INDX) = ETA(I,INDX-1) *                              &
+     &                     (HCKO(I,INDX-1) - DV1) * G / DP
+          DVQ1 = QO(I,INDX-1) 
+          DELLAQ(I,INDX) = ETA(I,INDX-1) *                              &
+     &                     (QCKO(I,INDX-1) - DVQ1) * G / DP
+          DV1U = UO(I,INDX-1)
+          DELLAU(I,INDX) = ETA(I,INDX-1) *                              &
+     &                     (UCKO(I,INDX-1) - DV1U) * G / DP
+          DV1V = VO(I,INDX-1)
+          DELLAV(I,INDX) = ETA(I,INDX-1) *                              &
+     &                     (VCKO(I,INDX-1) - DV1V) * G / DP
+!
+!  cloud water
+!
+          DELLAL(I) = ETA(I,INDX-1) * QLKO_KTCON(I) * g / dp
+        ENDIF
+      ENDDO
+!
+!------- FINAL CHANGED VARIABLE PER UNIT MASS FLUX
+!
+      DO K = 1, KM
+        DO I = 1, IM
+          if (k .le. kmax(i)) then
+            IF(CNVFLG(I).and.k.gt.KTCON(I)) THEN
+              QO(I,k) = Q1(I,k)
+              TO(I,k) = T1(I,k)
+              UO(I,k) = U1(I,k)
+              VO(I,k) = V1(I,k)
+            ENDIF
+            IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN
+              QO(I,k) = DELLAQ(I,k) * MBDT + Q1(I,k)
+              DELLAT = (DELLAH(I,k) - HVAP * DELLAQ(I,k)) / CP
+              TO(I,k) = DELLAT * MBDT + T1(I,k)
+!cmr          QO(I,k) = max(QO(I,k),1.e-10)
+              val   =           1.e-10
+              QO(I,k) = max(QO(I,k), val  )
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!--- THE ABOVE CHANGED ENVIRONMENT IS NOW USED TO CALULATE THE
+!--- EFFECT THE ARBITRARY CLOUD (WITH UNIT MASS FLUX)
+!--- WOULD HAVE ON THE STABILITY,
+!--- WHICH THEN IS USED TO CALCULATE THE REAL MASS FLUX,
+!--- NECESSARY TO KEEP THIS CHANGE IN BALANCE WITH THE LARGE-SCALE
+!--- DESTABILIZATION.
+!
+!--- ENVIRONMENTAL CONDITIONS AGAIN, FIRST HEIGHTS
+!
+      DO K = 1, KM
+        DO I = 1, IM
+          IF(k .le. kmax(i) .and. CNVFLG(I)) THEN
+!jfe        QESO(I,k) = 10. * FPVS(TO(I,k))
+!
+            QESO(I,k) = 0.01 * fpvs(TO(I,K))      ! fpvs is in Pa
+!
+            QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k)+EPSM1*QESO(I,k))
+!cmr        QESO(I,k) = MAX(QESO(I,k),1.E-8)
+            val       =             1.E-8
+            QESO(I,k) = MAX(QESO(I,k), val )
+            TVO(I,k)  = TO(I,k) + DELTA * TO(I,k) * QO(I,k)
+          ENDIF
+        ENDDO
+      ENDDO
+      DO I = 1, IM
+        IF(CNVFLG(I)) THEN
+          XAA0(I) = 0.
+          XPWAV(I) = 0.
+        ENDIF
+      ENDDO
+!
+!  HYDROSTATIC HEIGHT ASSUME ZERO TERR
+!
+!     DO I = 1, IM
+!       IF(CNVFLG(I)) THEN
+!         DLNSIG =  LOG(PRSL(I,1)/PS(I))
+!         ZO(I,1) = TERR - DLNSIG * RD / G * TVO(I,1)
+!       ENDIF
+!     ENDDO
+!     DO K = 2, KM
+!       DO I = 1, IM
+!         IF(k .le. kmax(i) .and. CNVFLG(I)) THEN
+!           DLNSIG =  LOG(PRSL(I,K) / PRSL(I,K-1))
+!           ZO(I,k) = ZO(I,k-1) - DLNSIG * RD / G
+!    &             * .5 * (TVO(I,k) + TVO(I,k-1))
+!         ENDIF
+!       ENDDO
+!     ENDDO
+!
+!--- MOIST STATIC ENERGY
+!
+      DO K = 1, KM1
+        DO I = 1, IM
+          IF(k .le. kmax(i)-1 .and. CNVFLG(I)) THEN
+            DZ = .5 * (ZO(I,k+1) - ZO(I,k))
+            DP = .5 * (PFLD(I,k+1) - PFLD(I,k))
+!jfe        ES = 10. * FPVS(TO(I,k+1))
+!
+            ES = 0.01 * fpvs(TO(I,K+1))      ! fpvs is in Pa
+!
+            PPRIME = PFLD(I,k+1) + EPSM1 * ES
+            QS = EPS * ES / PPRIME
+            DQSDP = - QS / PPRIME
+            DESDT = ES * (FACT1 / TO(I,k+1) + FACT2 / (TO(I,k+1)**2))
+            DQSDT = QS * PFLD(I,k+1) * DESDT / (ES * PPRIME)
+            GAMMA = EL2ORC * QESO(I,k+1) / (TO(I,k+1)**2)
+            DT = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA))
+            DQ = DQSDT * DT + DQSDP * DP
+            TO(I,k) = TO(I,k+1) + DT
+            QO(I,k) = QO(I,k+1) + DQ
+            PO(I,k) = .5 * (PFLD(I,k) + PFLD(I,k+1))
+          ENDIF
+        ENDDO
+      ENDDO
+      DO K = 1, KM1
+        DO I = 1, IM
+          IF(k .le. kmax(i)-1 .and. CNVFLG(I)) THEN
+!jfe        QESO(I,k) = 10. * FPVS(TO(I,k))
+!
+            QESO(I,k) = 0.01 * fpvs(TO(I,K))      ! fpvs is in Pa
+!
+            QESO(I,k) = EPS * QESO(I,k) / (PO(I,k) + EPSM1 * QESO(I,k))
+!cmr        QESO(I,k) = MAX(QESO(I,k),1.E-8)
+            val1      =             1.E-8
+            QESO(I,k) = MAX(QESO(I,k), val1)
+!cmr        QO(I,k)   = max(QO(I,k),1.e-10)
+            val2      =           1.e-10
+            QO(I,k)   = max(QO(I,k), val2 )
+!           QO(I,k)   = MIN(QO(I,k),QESO(I,k))
+            HEO(I,k)   = .5 * G * (ZO(I,k) + ZO(I,k+1)) +               &
+     &                    CP * TO(I,k) + HVAP * QO(I,k)
+            HESO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) +                &
+     &                  CP * TO(I,k) + HVAP * QESO(I,k)
+          ENDIF
+        ENDDO
+      ENDDO
+      DO I = 1, IM
+        k = kmax(i)
+        IF(CNVFLG(I)) THEN
+          HEO(I,k) = G * ZO(I,k) + CP * TO(I,k) + HVAP * QO(I,k)
+          HESO(I,k) = G * ZO(I,k) + CP * TO(I,k) + HVAP * QESO(I,k)
+!         HEO(I,k) = MIN(HEO(I,k),HESO(I,k))
+        ENDIF
+      ENDDO
+      DO I = 1, IM
+        IF(CNVFLG(I)) THEN
+          INDX = KB(I)
+          XHKB(I) = HEO(I,INDX)
+          XQKB(I) = QO(I,INDX)
+          HCKO(I,INDX) = XHKB(I)
+          QCKO(I,INDX) = XQKB(I)
+        ENDIF
+      ENDDO
+!
+!
+!**************************** STATIC CONTROL
+!
+!
+!------- MOISTURE AND CLOUD WORK FUNCTIONS
+!
+      DO K = 2, KM1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+!           IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN
+            IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KTCON(I)) THEN
+              FACTOR = ETA(I,k-1) / ETA(I,k)
+              ONEMF = 1. - FACTOR
+              HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF *                &
+     &                    .5 * (HEO(I,k) + HEO(I,k+1))
+            ENDIF
+!           IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN
+!             HEO(I,k) = HEO(I,k-1)
+!           ENDIF
+          endif
+        ENDDO
+      ENDDO
+      DO K = 2, KM1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+            IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN
+              DZ = .5 * (ZO(I,k+1) - ZO(I,k-1))
+              GAMMA = EL2ORC * QESO(I,k) / (TO(I,k)**2)
+              XDBY = HCKO(I,k) - HESO(I,k)
+!cmr          XDBY = MAX(XDBY,0.)
+              val  =          0.
+              XDBY = MAX(XDBY,val)
+              XQRCH = QESO(I,k)                                         &
+     &              + GAMMA * XDBY / (HVAP * (1. + GAMMA))
+              FACTOR = ETA(I,k-1) / ETA(I,k)
+              ONEMF = 1. - FACTOR
+              QCKO(I,k) = FACTOR * QCKO(I,k-1) + ONEMF *                &
+     &                    .5 * (QO(I,k) + QO(I,k+1))
+              DQ = ETA(I,k) * QCKO(I,k) - ETA(I,k) * XQRCH
+              IF(DQ.GT.0.) THEN
+                ETAH = .5 * (ETA(I,k) + ETA(I,k-1))
+                QLK = DQ / (ETA(I,k) + ETAH * C0 * DZ)
+                XAA0(I) = XAA0(I) - (ZO(I,k) - ZO(I,k-1)) * G * QLK
+                XQC = QLK + XQRCH
+                XPW = ETAH * C0 * DZ * QLK
+                QCKO(I,k) = XQC
+                XPWAV(I) = XPWAV(I) + XPW
+              ENDIF
+            ENDIF
+!           IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LT.KTCON(I)) THEN
+            IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN
+              DZ1 = ZO(I,k) - ZO(I,k-1)
+              GAMMA = EL2ORC * QESO(I,k-1) / (TO(I,k-1)**2)
+              RFACT =  1. + DELTA * CP * GAMMA                          &
+     &                 * TO(I,k-1) / HVAP
+              XDBY = HCKO(I,k-1) - HESO(I,k-1)
+              XAA0(I) = XAA0(I)                                         & 
+     &                + DZ1 * (G / (CP * TO(I,k-1)))                    &
+     &                * XDBY / (1. + GAMMA)                             &
+     &                * RFACT
+              val=0.
+              XAA0(I)=XAA0(I)+                                          &
+     &                 DZ1 * G * DELTA *                                &
+!cmr &                 MAX( 0.,(QESO(I,k-1) - QO(I,k-1)))               & 
+     &                 MAX(val,(QESO(I,k-1) - QO(I,k-1)))
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
+!cccc   PRINT *, ' XAA BEFORE DWNDRFT =', XAA0(I)
+!cccc ENDIF
+!
+!------- DOWNDRAFT CALCULATIONS
+!
+!
+!--- DOWNDRAFT MOISTURE PROPERTIES
+!
+      DO I = 1, IM
+        XPWEV(I) = 0.
+      ENDDO
+      DO I = 1, IM
+        IF(DWNFLG2(I)) THEN
+          JMN = JMIN(I)
+          XHCD(I) = HEO(I,JMN)
+          XQCD(I) = QO(I,JMN)
+          QRCD(I,JMN) = QESO(I,JMN)
+        ENDIF
+      ENDDO
+      DO K = KM1, 1, -1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+            IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN
+              DQ = QESO(I,k)
+              DT = TO(I,k)
+              GAMMA    = EL2ORC * DQ / DT**2
+              DH       = XHCD(I) - HESO(I,k)
+              QRCD(I,k)=DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH
+              DETAD    = ETAD(I,k+1) - ETAD(I,k)
+              XPWD     = ETAD(I,k+1) * QRCD(I,k+1) -                    &
+     &                   ETAD(I,k) * QRCD(I,k)
+              XPWD     = XPWD - DETAD *                                 & 
+     &                 .5 * (QRCD(I,k) + QRCD(I,k+1))
+              XPWEV(I) = XPWEV(I) + XPWD
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!
+      DO I = 1, IM
+        edtmax = edtmaxl
+        if(SLIMSK(I).eq.0.) edtmax = edtmaxs
+        IF(DWNFLG2(I)) THEN
+          IF(XPWEV(I).GE.0.) THEN
+            EDTX(I) = 0.
+          ELSE
+            EDTX(I) = -EDTX(I) * XPWAV(I) / XPWEV(I)
+            EDTX(I) = MIN(EDTX(I),EDTMAX)
+          ENDIF
+        ELSE
+          EDTX(I) = 0.
+        ENDIF
+      ENDDO
+!
+!
+!
+!--- DOWNDRAFT CLOUDWORK FUNCTIONS
+!
+!
+      DO K = KM1, 1, -1
+        DO I = 1, IM
+          if (k .le. kmax(i)-1) then
+            IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN
+              GAMMA = EL2ORC * QESO(I,k+1) / TO(I,k+1)**2
+              DHH=XHCD(I)
+              DT= TO(I,k+1)
+              DG= GAMMA
+              DH= HESO(I,k+1)
+              DZ=-1.*(ZO(I,k+1)-ZO(I,k))
+              XAA0(I)=XAA0(I)+EDTX(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG)) &
+     &                *(1.+DELTA*CP*DG*DT/HVAP)
+              val=0.
+              XAA0(I)=XAA0(I)+EDTX(I)*                                  &
+!cmr &        DZ*G*DELTA*MAX( 0.,(QESO(I,k+1)-QO(I,k+1)))               &
+     &        DZ*G*DELTA*MAX(val,(QESO(I,k+1)-QO(I,k+1)))
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG2(I)) THEN
+!cccc   PRINT *, '  XAA AFTER DWNDRFT =', XAA0(I)
+!cccc ENDIF
+!
+!  CALCULATE CRITICAL CLOUD WORK FUNCTION
+!
+      DO I = 1, IM
+        ACRT(I) = 0.
+        IF(CNVFLG(I)) THEN
+!       IF(CNVFLG(I).AND.SLIMSK(I).NE.1.) THEN
+          IF(PFLD(I,KTCON(I)).LT.PCRIT(15))THEN
+            ACRT(I)=ACRIT(15)*(975.-PFLD(I,KTCON(I)))                   &    
+     &              /(975.-PCRIT(15))
+          ELSE IF(PFLD(I,KTCON(I)).GT.PCRIT(1))THEN
+            ACRT(I)=ACRIT(1)
+          ELSE
+!cmr        K = IFIX((850. - PFLD(I,KTCON(I)))/50.) + 2
+            K =  int((850. - PFLD(I,KTCON(I)))/50.) + 2
+            K = MIN(K,15)
+            K = MAX(K,2)
+            ACRT(I)=ACRIT(K)+(ACRIT(K-1)-ACRIT(K))*                     &
+     &           (PFLD(I,KTCON(I))-PCRIT(K))/(PCRIT(K-1)-PCRIT(K))
+           ENDIF
+!        ELSE
+!          ACRT(I) = .5 * (PFLD(I,KBCON(I)) - PFLD(I,KTCON(I)))
+         ENDIF
+      ENDDO
+      DO I = 1, IM
+        ACRTFCT(I) = 1.
+        IF(CNVFLG(I)) THEN
+          if(SLIMSK(I).eq.1.) THEN
+            w1 = w1l
+            w2 = w2l
+            w3 = w3l
+            w4 = w4l
+          else
+            w1 = w1s
+            w2 = w2s
+            w3 = w3s
+            w4 = w4s
+          ENDIF
+!C       IF(CNVFLG(I).AND.SLIMSK(I).EQ.1.) THEN
+!         ACRTFCT(I) = PDOT(I) / W3
+!
+!  modify critical cloud workfunction by cloud base vertical velocity
+!
+          IF(PDOT(I).LE.W4) THEN
+            ACRTFCT(I) = (PDOT(I) - W4) / (W3 - W4)
+          ELSEIF(PDOT(I).GE.-W4) THEN
+            ACRTFCT(I) = - (PDOT(I) + W4) / (W4 - W3)
+          ELSE
+            ACRTFCT(I) = 0.
+          ENDIF
+!cmr      ACRTFCT(I) = MAX(ACRTFCT(I),-1.)
+          val1    =             -1.
+          ACRTFCT(I) = MAX(ACRTFCT(I),val1)
+!cmr      ACRTFCT(I) = MIN(ACRTFCT(I),1.)
+          val2    =             1.
+          ACRTFCT(I) = MIN(ACRTFCT(I),val2)
+          ACRTFCT(I) = 1. - ACRTFCT(I)
+!
+!  modify ACRTFCT(I) by colume mean rh if RHBAR(I) is greater than 80 percent
+!
+!         if(RHBAR(I).ge..8) THEN
+!           ACRTFCT(I) = ACRTFCT(I) * (.9 - min(RHBAR(I),.9)) * 10.
+!         ENDIF
+!
+!  modify adjustment time scale by cloud base vertical velocity
+!
+          DTCONV(I) = DT2 + max((1800. - DT2),RZERO) *                  &
+     &                (PDOT(I) - W2) / (W1 - W2)
+!         DTCONV(I) = MAX(DTCONV(I), DT2)
+!         DTCONV(I) = 1800. * (PDOT(I) - w2) / (w1 - w2)
+          DTCONV(I) = max(DTCONV(I),dtmin)
+          DTCONV(I) = min(DTCONV(I),dtmax)
+
+        ENDIF
+      ENDDO
+!
+!--- LARGE SCALE FORCING
+!
+      DO I= 1, IM
+        FLG(I) = CNVFLG(I)
+        IF(CNVFLG(I)) THEN
+!         F = AA1(I) / DTCONV(I)
+          FLD(I) = (AA1(I) - ACRT(I) * ACRTFCT(I)) / DTCONV(I)
+          IF(FLD(I).LE.0.) FLG(I) = .FALSE.
+        ENDIF
+        CNVFLG(I) = FLG(I)
+        IF(CNVFLG(I)) THEN
+!         XAA0(I) = MAX(XAA0(I),0.)
+          XK(I) = (XAA0(I) - AA1(I)) / MBDT
+          IF(XK(I).GE.0.) FLG(I) = .FALSE.
+        ENDIF
+!
+!--- KERNEL, CLOUD BASE MASS FLUX
+!
+        CNVFLG(I) = FLG(I)
+        IF(CNVFLG(I)) THEN
+          XMB(I) = -FLD(I) / XK(I)
+          XMB(I) = MIN(XMB(I),XMBMAX(I))
+        ENDIF
+      ENDDO
+!      IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
+!        print *, ' RHBAR(I), ACRTFCT(I) =', RHBAR(I), ACRTFCT(I)
+!        PRINT *, '  A1, XA =', AA1(I), XAA0(I)
+!        PRINT *, ' XMB(I), ACRT =', XMB(I), ACRT
+!      ENDIF
+      TOTFLG = .TRUE.
+      DO I = 1, IM
+        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
+      ENDDO
+      IF(TOTFLG) RETURN
+!
+!  restore t0 and QO to t1 and q1 in case convection stops
+!
+      do k = 1, km
+        DO I = 1, IM
+          if (k .le. kmax(i)) then
+            TO(I,k) = T1(I,k)
+            QO(I,k) = Q1(I,k)
+!jfe        QESO(I,k) = 10. * FPVS(T1(I,k))
+!
+            QESO(I,k) = 0.01 * fpvs(T1(I,K))      ! fpvs is in Pa
+!
+            QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k) + EPSM1*QESO(I,k))
+!cmr        QESO(I,k) = MAX(QESO(I,k),1.E-8)
+            val     =             1.E-8
+            QESO(I,k) = MAX(QESO(I,k), val )
+          endif
+        enddo
+      enddo
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!--- FEEDBACK: SIMPLY THE CHANGES FROM THE CLOUD WITH UNIT MASS FLUX
+!---           MULTIPLIED BY  THE MASS FLUX NECESSARY TO KEEP THE
+!---           EQUILIBRIUM WITH THE LARGER-SCALE.
+!
+      DO I = 1, IM
+        DELHBAR(I) = 0.
+        DELQBAR(I) = 0.
+        DELTBAR(I) = 0.
+        QCOND(I) = 0.
+      ENDDO
+      DO K = 1, KM
+        DO I = 1, IM
+          if (k .le. kmax(i)) then
+            IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN
+              AUP = 1.
+              IF(K.Le.KB(I)) AUP = 0.
+              ADW = 1.
+              IF(K.GT.JMIN(I)) ADW = 0.
+              DELLAT = (DELLAH(I,k) - HVAP * DELLAQ(I,k)) / CP
+              T1(I,k) = T1(I,k) + DELLAT * XMB(I) * DT2
+              Q1(I,k) = Q1(I,k) + DELLAQ(I,k) * XMB(I) * DT2
+              U1(I,k) = U1(I,k) + DELLAU(I,k) * XMB(I) * DT2
+              V1(I,k) = V1(I,k) + DELLAV(I,k) * XMB(I) * DT2
+              DP = 1000. * DEL(I,K)
+              DELHBAR(I) = DELHBAR(I) + DELLAH(I,k)*XMB(I)*DP/G
+              DELQBAR(I) = DELQBAR(I) + DELLAQ(I,k)*XMB(I)*DP/G
+              DELTBAR(I) = DELTBAR(I) + DELLAT*XMB(I)*DP/G
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+      DO K = 1, KM
+        DO I = 1, IM
+          if (k .le. kmax(i)) then
+            IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN
+!jfe          QESO(I,k) = 10. * FPVS(T1(I,k))
+!
+              QESO(I,k) = 0.01 * fpvs(T1(I,K))      ! fpvs is in Pa
+!
+              QESO(I,k) = EPS * QESO(I,k)/(PFLD(I,k) + EPSM1*QESO(I,k))
+!cmr          QESO(I,k) = MAX(QESO(I,k),1.E-8)
+              val     =             1.E-8
+              QESO(I,k) = MAX(QESO(I,k), val )
+!
+!  cloud water
+!
+              if(ncloud.gt.0.and.CNVFLG(I).and.k.eq.KTCON(I)) THEN
+                tem  = DELLAL(I) * XMB(I) * dt2
+                tem1 = MAX(RZERO, MIN(RONE, (TCR-t1(I,K))*TCRF))
+                if (QL(I,k,2) .gt. -999.0) then
+                  QL(I,k,1) = QL(I,k,1) + tem * tem1            ! Ice
+                  QL(I,k,2) = QL(I,k,2) + tem *(1.0-tem1)       ! Water
+                else
+                  tem2      = QL(I,k,1) + tem
+                  QL(I,k,1) = tem2 * tem1                       ! Ice
+                  QL(I,k,2) = tem2 - QL(I,k,1)                  ! Water
+                endif
+!               QL(I,k) = QL(I,k) + DELLAL(I) * XMB(I) * dt2
+                dp = 1000. * del(i,k)
+                DELLAL(I) = DELLAL(I) * XMB(I) * dp / g
+              ENDIF
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!     IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I) ) THEN
+!       PRINT *, ' DELHBAR, DELQBAR, DELTBAR ='
+!       PRINT *, DELHBAR, HVAP*DELQBAR, CP*DELTBAR
+!       PRINT *, '   DELLBAR ='
+!       PRINT 6003,  HVAP*DELLbar
+!       PRINT *, '   DELLAQ ='
+!       PRINT 6003, (HVAP*DELLAQ(I,k)*XMB(I),K=1,KMAX)
+!       PRINT *, '   DELLAT ='
+!       PRINT 6003, (DELLAH(i,k)*XMB(I)-HVAP*DELLAQ(I,k)*XMB(I),         &
+!    &               K=1,KMAX)
+!     ENDIF
+      DO I = 1, IM
+        RNTOT(I) = 0.
+        DELQEV(I) = 0.
+        DELQ2(I) = 0.
+        FLG(I) = CNVFLG(I)
+      ENDDO
+      DO K = KM, 1, -1
+        DO I = 1, IM
+          if (k .le. kmax(i)) then
+            IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN
+              AUP = 1.
+              IF(K.Le.KB(I)) AUP = 0.
+              ADW = 1.
+              IF(K.GT.JMIN(I)) ADW = 0.
+              rain =  AUP * PWO(I,k) + ADW * EDTO(I) * PWDO(I,k)
+              RNTOT(I) = RNTOT(I) + rain * XMB(I) * .001 * dt2
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+      DO K = KM, 1, -1
+        DO I = 1, IM
+          if (k .le. kmax(i)) then
+            DELTV(I) = 0.
+            DELQ(I) = 0.
+            QEVAP(I) = 0.
+            IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN
+              AUP = 1.
+              IF(K.Le.KB(I)) AUP = 0.
+              ADW = 1.
+              IF(K.GT.JMIN(I)) ADW = 0.
+              rain =  AUP * PWO(I,k) + ADW * EDTO(I) * PWDO(I,k)
+              RN(I) = RN(I) + rain * XMB(I) * .001 * dt2
+            ENDIF
+            IF(FLG(I).AND.K.LE.KTCON(I)) THEN
+              evef = EDT(I) * evfact
+              if(SLIMSK(I).eq.1.) evef=EDT(I) * evfactl
+!             if(SLIMSK(I).eq.1.) evef=.07
+!             if(SLIMSK(I).ne.1.) evef = 0.
+              QCOND(I) = EVEF * (Q1(I,k) - QESO(I,k))                   &
+     &                 / (1. + EL2ORC * QESO(I,k) / T1(I,k)**2)
+              DP = 1000. * DEL(I,K)
+              IF(RN(I).GT.0..AND.QCOND(I).LT.0.) THEN
+                QEVAP(I) = -QCOND(I) * (1.-EXP(-.32*SQRT(DT2*RN(I))))
+                QEVAP(I) = MIN(QEVAP(I), RN(I)*1000.*G/DP)
+                DELQ2(I) = DELQEV(I) + .001 * QEVAP(I) * dp / g
+              ENDIF
+              if(RN(I).gt.0..and.QCOND(I).LT.0..and.                    &
+     &           DELQ2(I).gt.RNTOT(I)) THEN
+                QEVAP(I) = 1000.* g * (RNTOT(I) - DELQEV(I)) / dp
+                FLG(I) = .false.
+              ENDIF
+              IF(RN(I).GT.0..AND.QEVAP(I).gt.0.) THEN
+                Q1(I,k) = Q1(I,k) + QEVAP(I)
+                T1(I,k) = T1(I,k) - ELOCP * QEVAP(I)
+                RN(I) = RN(I) - .001 * QEVAP(I) * DP / G
+                DELTV(I) = - ELOCP*QEVAP(I)/DT2
+                DELQ(I) =  + QEVAP(I)/DT2
+                DELQEV(I) = DELQEV(I) + .001*dp*QEVAP(I)/g
+              ENDIF
+              DELLAQ(I,k) = DELLAQ(I,k) + DELQ(I) / XMB(I)
+              DELQBAR(I) = DELQBAR(I) + DELQ(I)*DP/G
+              DELTBAR(I) = DELTBAR(I) + DELTV(I)*DP/G
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!      IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I) ) THEN
+!        PRINT *, '   DELLAH ='
+!        PRINT 6003, (DELLAH(k)*XMB(I),K=1,KMAX)
+!        PRINT *, '   DELLAQ ='
+!        PRINT 6003, (HVAP*DELLAQ(I,k)*XMB(I),K=1,KMAX)
+!        PRINT *, ' DELHBAR, DELQBAR, DELTBAR ='
+!        PRINT *, DELHBAR, HVAP*DELQBAR, CP*DELTBAR
+!        PRINT *, ' PRECIP =', HVAP*RN(I)*1000./DT2
+!CCCC   PRINT *, '   DELLBAR ='
+!CCCC   PRINT *,  HVAP*DELLbar
+!      ENDIF
+!
+!  PRECIPITATION RATE CONVERTED TO ACTUAL PRECIP
+!  IN UNIT OF M INSTEAD OF KG
+!
+      DO I = 1, IM
+        IF(CNVFLG(I)) THEN
+!
+!  IN THE EVENT OF UPPER LEVEL RAIN EVAPORATION AND LOWER LEVEL DOWNDRAF
+!    MOISTENING, RN CAN BECOME NEGATIVE, IN THIS CASE, WE BACK OUT OF TH
+!    HEATING AND THE MOISTENING
+!
+          if(RN(I).lt.0..and..not.FLG(I)) RN(I) = 0.
+          IF(RN(I).LE.0.) THEN
+            RN(I) = 0.
+          ELSE
+            KTOP(I) = KTCON(I)
+            KBOT(I) = KBCON(I)
+            KUO(I) = 1
+            CLDWRK(I) = AA1(I)
+          ENDIF
+        ENDIF
+      ENDDO
+      DO K = 1, KM
+        DO I = 1, IM
+          if (k .le. kmax(i)) then
+            IF(CNVFLG(I).AND.RN(I).LE.0.) THEN
+              T1(I,k) = TO(I,k)
+              Q1(I,k) = QO(I,k)
+            ENDIF
+          endif
+        ENDDO
+      ENDDO
+!!
+      RETURN
+   END SUBROUTINE SASCNV
+
+! ------------------------------------------------------------------------
+
+      SUBROUTINE OLD_ARW_SHALCV(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,KUO,Q,T,DPSHC)
+!
+      USE MODULE_GFS_MACHINE , ONLY : kind_phys
+      USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP &
+     &,             RD => con_RD
+
+      implicit none
+!
+!     include 'constant.h'
+!
+      integer              IM, IX, KM, KUO(IM)
+      real(kind=kind_phys) DEL(IX,KM),   PRSI(IX,KM+1), PRSL(IX,KM),    &
+     &                     PRSLK(IX,KM),                                &
+     &                     Q(IX,KM),     T(IX,KM),      DT, DPSHC
+!
+!     Locals
+!
+      real(kind=kind_phys) ck,    cpdt,   dmse,   dsdz1, dsdz2,         &
+     &                     dsig,  dtodsl, dtodsu, eldq,  g,             &
+     &                     gocp,  rtdls
+!
+      integer              k,k1,k2,kliftl,kliftu,kt,N2,I,iku,ik1,ik,ii
+      integer              INDEX2(IM), KLCL(IM), KBOT(IM), KTOP(IM),kk  &
+     &,                    KTOPM(IM)
+!!
+!  PHYSICAL PARAMETERS
+      PARAMETER(G=GRAV, GOCP=G/CP)
+!  BOUNDS OF PARCEL ORIGIN
+      PARAMETER(KLIFTL=2,KLIFTU=2)
+      LOGICAL   LSHC(IM)
+      real(kind=kind_phys) Q2(IM*KM),     T2(IM*KM),                    &
+     &                     PRSL2(IM*KM),  PRSLK2(IM*KM),                &
+     &                     AL(IM*(KM-1)), AD(IM*KM), AU(IM*(KM-1))
+!-----------------------------------------------------------------------
+!  COMPRESS FIELDS TO POINTS WITH NO DEEP CONVECTION
+!  AND MOIST STATIC INSTABILITY.
+      DO I=1,IM
+        LSHC(I)=.FALSE.
+      ENDDO
+      DO K=1,KM-1
+        DO I=1,IM
+          IF(KUO(I).EQ.0) THEN
+            ELDQ    = HVAP*(Q(I,K)-Q(I,K+1))
+            CPDT    = CP*(T(I,K)-T(I,K+1))
+            RTDLS   = (PRSL(I,K)-PRSL(I,K+1)) /                         &
+     &                 PRSI(I,K+1)*RD*0.5*(T(I,K)+T(I,K+1))
+            DMSE    = ELDQ+CPDT-RTDLS
+            LSHC(I) = LSHC(I).OR.DMSE.GT.0.
+          ENDIF
+        ENDDO
+      ENDDO
+      N2 = 0
+      DO I=1,IM
+        IF(LSHC(I)) THEN
+          N2         = N2 + 1
+          INDEX2(N2) = I
+        ENDIF
+      ENDDO
+      IF(N2.EQ.0) RETURN
+      DO K=1,KM
+        KK = (K-1)*N2
+        DO I=1,N2
+          IK         = KK + I
+          ii         = index2(i)
+          Q2(IK)     = Q(II,K)
+          T2(IK)     = T(II,K)
+          PRSL2(IK)  = PRSL(II,K)
+          PRSLK2(IK) = PRSLK(II,K)
+        ENDDO
+      ENDDO
+      do i=1,N2
+        ktopm(i) = KM
+      enddo
+      do k=2,KM
+        do i=1,N2
+          ii = index2(i)
+          if (prsi(ii,1)-prsi(ii,k) .le. dpshc) ktopm(i) = k
+        enddo
+      enddo
+
+!-----------------------------------------------------------------------
+!  COMPUTE MOIST ADIABAT AND DETERMINE LIMITS OF SHALLOW CONVECTION.
+!  CHECK FOR MOIST STATIC INSTABILITY AGAIN WITHIN CLOUD.
+      CALL MSTADBT3(N2,KM-1,KLIFTL,KLIFTU,PRSL2,PRSLK2,T2,Q2,           &
+     &            KLCL,KBOT,KTOP,AL,AU)
+      DO I=1,N2
+        KBOT(I) = min(KLCL(I)-1, ktopm(i)-1)
+        KTOP(I) = min(KTOP(I)+1, ktopm(i))
+        LSHC(I) = .FALSE.
+      ENDDO
+      DO K=1,KM-1
+        KK = (K-1)*N2
+        DO I=1,N2
+          IF(K.GE.KBOT(I).AND.K.LT.KTOP(I)) THEN
+            IK      = KK + I
+            IKU     = IK + N2
+            ELDQ    = HVAP * (Q2(IK)-Q2(IKU))
+            CPDT    = CP   * (T2(IK)-T2(IKU))
+            RTDLS   = (PRSL2(IK)-PRSL2(IKU)) /                          &
+     &                 PRSI(index2(i),K+1)*RD*0.5*(T2(IK)+T2(IKU))
+            DMSE    = ELDQ + CPDT - RTDLS
+            LSHC(I) = LSHC(I).OR.DMSE.GT.0.
+            AU(IK)  = G/RTDLS
+          ENDIF
+        ENDDO
+      ENDDO
+      K1=KM+1
+      K2=0
+      DO I=1,N2
+        IF(.NOT.LSHC(I)) THEN
+          KBOT(I) = KM+1
+          KTOP(I) = 0
+        ENDIF
+        K1 = MIN(K1,KBOT(I))
+        K2 = MAX(K2,KTOP(I))
+      ENDDO
+      KT = K2-K1+1
+      IF(KT.LT.2) RETURN
+!-----------------------------------------------------------------------
+!  SET EDDY VISCOSITY COEFFICIENT CKU AT SIGMA INTERFACES.
+!  COMPUTE DIAGONALS AND RHS FOR TRIDIAGONAL MATRIX SOLVER.
+!  EXPAND FINAL FIELDS.
+      KK = (K1-1) * N2
+      DO I=1,N2
+        IK     = KK + I
+        AD(IK) = 1.
+      ENDDO
+!
+!     DTODSU=DT/DEL(K1)
+      DO K=K1,K2-1
+!       DTODSL=DTODSU
+!       DTODSU=   DT/DEL(K+1)
+!       DSIG=SL(K)-SL(K+1)
+        KK = (K-1) * N2
+        DO I=1,N2
+          ii     = index2(i)
+          DTODSL = DT/DEL(II,K)
+          DTODSU = DT/DEL(II,K+1)
+          DSIG   = PRSL(II,K) - PRSL(II,K+1)
+          IK     = KK + I
+          IKU    = IK + N2
+          IF(K.EQ.KBOT(I)) THEN
+            CK=1.5
+          ELSEIF(K.EQ.KTOP(I)-1) THEN
+            CK=1.
+          ELSEIF(K.EQ.KTOP(I)-2) THEN
+            CK=3.
+          ELSEIF(K.GT.KBOT(I).AND.K.LT.KTOP(I)-2) THEN
+            CK=5.
+          ELSE
+            CK=0.
+          ENDIF
+          DSDZ1   = CK*DSIG*AU(IK)*GOCP
+          DSDZ2   = CK*DSIG*AU(IK)*AU(IK)
+          AU(IK)  = -DTODSL*DSDZ2
+          AL(IK)  = -DTODSU*DSDZ2
+          AD(IK)  = AD(IK)-AU(IK)
+          AD(IKU) = 1.-AL(IK)
+          T2(IK)  = T2(IK)+DTODSL*DSDZ1
+          T2(IKU) = T2(IKU)-DTODSU*DSDZ1
+        ENDDO
+      ENDDO
+      IK1=(K1-1)*N2+1
+      CALL TRIDI2T3(N2,KT,AL(IK1),AD(IK1),AU(IK1),Q2(IK1),T2(IK1),      &
+     &                                  AU(IK1),Q2(IK1),T2(IK1))
+      DO K=K1,K2
+        KK = (K-1)*N2
+        DO I=1,N2
+          IK = KK + I
+          Q(INDEX2(I),K) = Q2(IK)
+          T(INDEX2(I),K) = T2(IK)
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      RETURN
+      END SUBROUTINE OLD_ARW_SHALCV
+
+!-----------------------------------------------------------------------
+      SUBROUTINE TRIDI2T3(L,N,CL,CM,CU,R1,R2,AU,A1,A2)
+!yt      INCLUDE DBTRIDI2;
+!!
+      USE MODULE_GFS_MACHINE , ONLY : kind_phys
+      implicit none
+      integer             k,n,l,i
+      real(kind=kind_phys) fk
+!!
+      real(kind=kind_phys)                                              &
+     &          CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N),            &
+     &          AU(L,N-1),A1(L,N),A2(L,N)
+!-----------------------------------------------------------------------
+      DO I=1,L
+        FK=1./CM(I,1)
+        AU(I,1)=FK*CU(I,1)
+        A1(I,1)=FK*R1(I,1)
+        A2(I,1)=FK*R2(I,1)
+      ENDDO
+      DO K=2,N-1
+        DO I=1,L
+          FK=1./(CM(I,K)-CL(I,K)*AU(I,K-1))
+          AU(I,K)=FK*CU(I,K)
+          A1(I,K)=FK*(R1(I,K)-CL(I,K)*A1(I,K-1))
+          A2(I,K)=FK*(R2(I,K)-CL(I,K)*A2(I,K-1))
+        ENDDO
+      ENDDO
+      DO I=1,L
+        FK=1./(CM(I,N)-CL(I,N)*AU(I,N-1))
+        A1(I,N)=FK*(R1(I,N)-CL(I,N)*A1(I,N-1))
+        A2(I,N)=FK*(R2(I,N)-CL(I,N)*A2(I,N-1))
+      ENDDO
+      DO K=N-1,1,-1
+        DO I=1,L
+          A1(I,K)=A1(I,K)-AU(I,K)*A1(I,K+1)
+          A2(I,K)=A2(I,K)-AU(I,K)*A2(I,K+1)
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      RETURN
+      END SUBROUTINE TRIDI2T3
+!-----------------------------------------------------------------------
+
+      SUBROUTINE MSTADBT3(IM,KM,K1,K2,PRSL,PRSLK,TENV,QENV,             &
+     &                  KLCL,KBOT,KTOP,TCLD,QCLD)
+!yt      INCLUDE DBMSTADB;
+!!
+      USE MODULE_GFS_MACHINE, ONLY : kind_phys
+      USE MODULE_GFS_FUNCPHYS, ONLY : FTDP, FTHE, FTLCL, STMA
+      USE MODULE_GFS_PHYSCONS, EPS => con_eps, EPSM1 => con_epsm1, FV => con_FVirt
+
+      implicit none
+!!
+!     include 'constant.h'
+!!
+      integer              k,k1,k2,km,i,im
+      real(kind=kind_phys) pv,qma,slklcl,tdpd,thelcl,tlcl
+      real(kind=kind_phys) tma,tvcld,tvenv
+!!
+      real(kind=kind_phys) PRSL(IM,KM), PRSLK(IM,KM), TENV(IM,KM),      &
+     &                     QENV(IM,KM), TCLD(IM,KM),  QCLD(IM,KM)
+      INTEGER              KLCL(IM),    KBOT(IM),      KTOP(IM)
+!  LOCAL ARRAYS
+      real(kind=kind_phys) SLKMA(IM), THEMA(IM)
+!-----------------------------------------------------------------------
+!  DETERMINE WARMEST POTENTIAL WET-BULB TEMPERATURE BETWEEN K1 AND K2.
+!  COMPUTE ITS LIFTING CONDENSATION LEVEL.
+!
+      DO I=1,IM
+        SLKMA(I) = 0.
+        THEMA(I) = 0.
+      ENDDO
+      DO K=K1,K2
+        DO I=1,IM
+          PV   = 1000.0 * PRSL(I,K)*QENV(I,K)/(EPS-EPSM1*QENV(I,K))
+          TDPD = TENV(I,K)-FTDP(PV)
+          IF(TDPD.GT.0.) THEN
+            TLCL   = FTLCL(TENV(I,K),TDPD)
+            SLKLCL = PRSLK(I,K)*TLCL/TENV(I,K)
+          ELSE
+            TLCL   = TENV(I,K)
+            SLKLCL = PRSLK(I,K)
+          ENDIF
+          THELCL=FTHE(TLCL,SLKLCL)
+          IF(THELCL.GT.THEMA(I)) THEN
+            SLKMA(I) = SLKLCL
+            THEMA(I) = THELCL
+          ENDIF
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+!  SET CLOUD TEMPERATURES AND HUMIDITIES WHEREVER THE PARCEL LIFTED UP
+!  THE MOIST ADIABAT IS BUOYANT WITH RESPECT TO THE ENVIRONMENT.
+      DO I=1,IM
+        KLCL(I)=KM+1
+        KBOT(I)=KM+1
+        KTOP(I)=0
+      ENDDO
+      DO K=1,KM
+        DO I=1,IM
+          TCLD(I,K)=0.
+          QCLD(I,K)=0.
+        ENDDO
+      ENDDO
+      DO K=K1,KM
+        DO I=1,IM
+          IF(PRSLK(I,K).LE.SLKMA(I)) THEN
+            KLCL(I)=MIN(KLCL(I),K)
+            CALL STMA(THEMA(I),PRSLK(I,K),TMA,QMA)
+!           TMA=FTMA(THEMA(I),PRSLK(I,K),QMA)
+            TVCLD=TMA*(1.+FV*QMA)
+            TVENV=TENV(I,K)*(1.+FV*QENV(I,K))
+            IF(TVCLD.GT.TVENV) THEN
+              KBOT(I)=MIN(KBOT(I),K)
+              KTOP(I)=MAX(KTOP(I),K)
+              TCLD(I,K)=TMA-TENV(I,K)
+              QCLD(I,K)=QMA-QENV(I,K)
+            ENDIF
+          ENDIF
+        ENDDO
+      ENDDO
+!-----------------------------------------------------------------------
+      RETURN
+      END SUBROUTINE MSTADBT3
+
+      subroutine sascnvn(im,ix,km,jcap,delt,del,prsl,ps,phil,ql,   & 
+     &     q1,t1,u1,v1,rcs,cldwrk,rn,kbot,ktop,kcnv,slimsk,        &
+     &     dot,ncloud,pgcon,sas_mass_flux)                         
+!     &     dot,ncloud,ud_mf,dd_mf,dt_mf)                         
+!    &     dot,ncloud,ud_mf,dd_mf,dt_mf,me)
+!
+!      use machine , only : kind_phys
+!      use funcphys , only : fpvs
+!      use physcons, grav => con_g, cp => con_cp, hvap => con_hvap  &
+      USE MODULE_GFS_MACHINE, ONLY : kind_phys
+      USE MODULE_GFS_FUNCPHYS, ONLY : fpvs
+      USE MODULE_GFS_PHYSCONS, grav => con_g, cp => con_cp         &
+     &,             hvap => con_hvap                               &
+     &,             rv => con_rv, fv => con_fvirt, t0c => con_t0c  &
+     &,             cvap => con_cvap, cliq => con_cliq             &
+     &,             eps => con_eps, epsm1 => con_epsm1
+      implicit none
+!
+      integer            im, ix,  km, jcap, ncloud,                &
+     &                   kbot(im), ktop(im), kcnv(im) 
+!    &,                  me
+      real(kind=kind_phys) delt,sas_mass_flux
+      real(kind=kind_phys) ps(im),     del(ix,km),  prsl(ix,km),   &
+     &                     ql(ix,km,2),q1(ix,km),   t1(ix,km),     &
+     &                     u1(ix,km),  v1(ix,km),   rcs(im),       &
+     &                     cldwrk(im), rn(im),      slimsk(im),    &
+     &                     dot(ix,km), phil(ix,km)
+! hchuang code change mass flux output
+!     &,                    ud_mf(im,km),dd_mf(im,km),dt_mf(im,km)
+!
+      integer              i, j, indx, jmn, k, kk, latd, lond, km1
+!
+      real(kind=kind_phys) clam, cxlamu, xlamde, xlamdd
+! 
+      real(kind=kind_phys) adw,     aup,     aafac,                &
+     &                     beta,    betal,   betas,                &
+     &                     c0,      cpoel,   dellat,  delta,       &
+     &                     desdt,   deta,    detad,   dg,          &
+     &                     dh,      dhh,     dlnsig,  dp,          &
+     &                     dq,      dqsdp,   dqsdt,   dt,          &
+     &                     dt2,     dtmax,   dtmin,   dv1h,        &
+     &                     dv1q,    dv2h,    dv2q,    dv1u,        &
+     &                     dv1v,    dv2u,    dv2v,    dv3q,        &
+     &                     dv3h,    dv3u,    dv3v,                 &
+     &                     dz,      dz1,     e1,      edtmax,      &
+     &                     edtmaxl, edtmaxs, el2orc,  elocp,       &
+     &                     es,      etah,    cthk,    dthk,        &
+     &                     evef,    evfact,  evfactl, fact1,       &
+     &                     fact2,   factor,  fjcap,   fkm,         &
+     &                     g,       gamma,   pprime,               &
+     &                     qlk,     qrch,    qs,      c1,          &
+     &                     rain,    rfact,   shear,   tem1,        &
+     &                     tem2,    terr,    val,     val1,        &
+     &                     val2,    w1,      w1l,     w1s,         &
+     &                     w2,      w2l,     w2s,     w3,          &
+     &                     w3l,     w3s,     w4,      w4l,         &
+     &                     w4s,     xdby,    xpw,     xpwd,        &
+     &                     xqrch,   mbdt,    tem,                  &
+     &                     ptem,    ptem1
+!
+      real(kind=kind_phys), intent(in) :: pgcon
+
+      integer              kb(im), kbcon(im), kbcon1(im),          &
+     &                     ktcon(im), ktcon1(im),                  &
+     &                     jmin(im), lmin(im), kbmax(im),          &
+     &                     kbm(im), kmax(im)
+!
+      real(kind=kind_phys) aa1(im),     acrt(im),   acrtfct(im),   &
+     &                     delhbar(im), delq(im),   delq2(im),     &
+     &                     delqbar(im), delqev(im), deltbar(im),   &
+     &                     deltv(im),   dtconv(im), edt(im),       &
+     &                     edto(im),    edtx(im),   fld(im),       &
+     &                     hcdo(im,km), hmax(im),   hmin(im),      &
+     &                     ucdo(im,km), vcdo(im,km),aa2(im),       &
+     &                     pbcdif(im),  pdot(im),   po(im,km),     &
+     &                     pwavo(im),   pwevo(im),  xlamud(im),    &
+     &                     qcdo(im,km), qcond(im),  qevap(im),     &
+     &                     rntot(im),   vshear(im), xaa0(im),      &
+     &                     xk(im),      xlamd(im),                 &
+     &                     xmb(im),     xmbmax(im), xpwav(im),     &
+     &                     xpwev(im),   delubar(im),delvbar(im)
+!cj
+      real(kind=kind_phys) cincr, cincrmax, cincrmin
+      real(kind=kind_phys) xmbmx1
+!cj
+!c  physical parameters
+      parameter(g=grav)
+      parameter(cpoel=cp/hvap,elocp=hvap/cp,                       &
+     &          el2orc=hvap*hvap/(rv*cp))
+      parameter(terr=0.,c0=.002,c1=.002,delta=fv)
+      parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c)
+      parameter(cthk=150.,cincrmax=180.,cincrmin=120.,dthk=25.)
+!c  local variables and arrays
+      real(kind=kind_phys) pfld(im,km),to(im,km), qo(im,km),       &
+     &                     uo(im,km),  vo(im,km), qeso(im,km)
+!c  cloud water
+      real(kind=kind_phys)qlko_ktcon(im),dellal(im,km),tvo(im,km), &
+     &                dbyo(im,km), zo(im,km),    xlamue(im,km),    &
+     &                fent1(im,km),fent2(im,km), frh(im,km),       &
+     &                heo(im,km),  heso(im,km),                    &
+     &                qrcd(im,km), dellah(im,km), dellaq(im,km),   &
+     &                dellau(im,km),dellav(im,km), hcko(im,km),    &
+     &                ucko(im,km), vcko(im,km),   qcko(im,km),     &
+     &                eta(im,km),  etad(im,km),   zi(im,km),       &
+     &                qrcdo(im,km),pwo(im,km),    pwdo(im,km),     &
+     &                tx1(im),     sumx(im)
+!    &,               rhbar(im)
+!
+      logical totflg, cnvflg(im), flg(im)
+!
+      real(kind=kind_phys) pcrit(15), acritt(15), acrit(15)
+!     save pcrit, acritt
+      data pcrit/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,&
+     &           350.,300.,250.,200.,150./
+      data acritt/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216,  &
+     &           .3151,.3677,.41,.5255,.7663,1.1686,1.6851/
+!c  gdas derived acrit
+!c     data acritt/.203,.515,.521,.566,.625,.665,.659,.688,
+!c    &            .743,.813,.886,.947,1.138,1.377,1.896/
+      real(kind=kind_phys) tf, tcr, tcrf
+      parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf))
+!
+!c-----------------------------------------------------------------------
+!
+
+      km1 = km - 1
+!c
+!c  initialize arrays
+!c
+      do i=1,im
+        kcnv(i)=0
+        cnvflg(i) = .true.
+        rn(i)=0.
+        kbot(i)=km+1
+        ktop(i)=0
+        kbcon(i)=km
+        ktcon(i)=1
+        dtconv(i) = 3600.
+        cldwrk(i) = 0.
+        pdot(i) = 0.
+        pbcdif(i)= 0.
+        lmin(i) = 1
+        jmin(i) = 1
+        qlko_ktcon(i) = 0.
+        edt(i)  = 0.
+        edto(i) = 0.
+        edtx(i) = 0.
+        acrt(i) = 0.
+        acrtfct(i) = 1.
+        aa1(i)  = 0.
+        aa2(i)  = 0.
+        xaa0(i) = 0.
+        pwavo(i)= 0.
+        pwevo(i)= 0.
+        xpwav(i)= 0.
+        xpwev(i)= 0.
+        vshear(i) = 0.
+      enddo
+! hchuang code change
+!      do k = 1, km
+!        do i = 1, im
+!          ud_mf(i,k) = 0.
+!          dd_mf(i,k) = 0.
+!          dt_mf(i,k) = 0.
+!        enddo
+!      enddo
+!c
+      do k = 1, 15
+        acrit(k) = acritt(k) * (975. - pcrit(k))
+      enddo
+      dt2 = delt
+      val   =         1200.
+      dtmin = max(dt2, val )
+      val   =         3600.
+      dtmax = max(dt2, val )
+!c  model tunable parameters are all here
+      mbdt    = 10.
+      edtmaxl = .3
+      edtmaxs = .3
+      clam    = .1
+      aafac   = .1
+!     betal   = .15
+!     betas   = .15
+      betal   = .05
+      betas   = .05
+!c     evef    = 0.07
+      evfact  = 0.3
+      evfactl = 0.3
+#if ( EM_CORE == 1 )
+!  HAWAII TEST - ZCX
+      BETAl   = .05
+      betas   = .05
+      evfact  = 0.5
+      evfactl = 0.5
+#endif
+!
+      cxlamu  = 1.0e-4
+      xlamde  = 1.0e-4
+      xlamdd  = 1.0e-4
+!
+      fjcap   = (float(jcap) / 126.) ** 2
+      val     =           1.
+      fjcap   = max(fjcap,val)
+      fkm     = (float(km) / 28.) ** 2
+      fkm     = max(fkm,val)
+      w1l     = -8.e-3 
+      w2l     = -4.e-2
+      w3l     = -5.e-3 
+      w4l     = -5.e-4
+      w1s     = -2.e-4
+      w2s     = -2.e-3
+      w3s     = -1.e-3
+      w4s     = -2.e-5
+!c
+!c  define top layer for search of the downdraft originating layer
+!c  and the maximum thetae for updraft
+!c
+      do i=1,im
+        kbmax(i) = km
+        kbm(i)   = km
+        kmax(i)  = km
+        tx1(i)   = 1.0 / ps(i)
+      enddo
+!     
+      do k = 1, km
+        do i=1,im
+          IF (prSL(I,K)*tx1(I) .GT. 0.04) KMAX(I)  = MIN(KM,K + 1)
+!2011bugfix          if (prsl(i,k)*tx1(i) .gt. 0.04) kmax(i)  = k + 1
+          if (prsl(i,k)*tx1(i) .gt. 0.45) kbmax(i) = k + 1
+          if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i)   = k + 1
+        enddo
+      enddo
+      do i=1,im
+        kbmax(i) = min(kbmax(i),kmax(i))
+        kbm(i)   = min(kbm(i),kmax(i))
+      enddo
+!c
+!c  hydrostatic height assume zero terr and initially assume
+!c    updraft entrainment rate as an inverse function of height 
+!c
+      do k = 1, km
+        do i=1,im
+          zo(i,k) = phil(i,k) / g
+        enddo
+      enddo
+      do k = 1, km1
+        do i=1,im
+          zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1))
+          xlamue(i,k) = clam / zi(i,k)
+        enddo
+      enddo
+!c
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c   convert surface pressure to mb from cb
+!c
+      do k = 1, km
+        do i = 1, im
+          if (k .le. kmax(i)) then
+            pfld(i,k) = prsl(i,k) * 10.0
+            eta(i,k)  = 1.
+            fent1(i,k)= 1.
+            fent2(i,k)= 1.
+            frh(i,k)  = 0.
+            hcko(i,k) = 0.
+            qcko(i,k) = 0.
+            ucko(i,k) = 0.
+            vcko(i,k) = 0.
+            etad(i,k) = 1.
+            hcdo(i,k) = 0.
+            qcdo(i,k) = 0.
+            ucdo(i,k) = 0.
+            vcdo(i,k) = 0.
+            qrcd(i,k) = 0.
+            qrcdo(i,k)= 0.
+            dbyo(i,k) = 0.
+            pwo(i,k)  = 0.
+            pwdo(i,k) = 0.
+            dellal(i,k) = 0.
+            to(i,k)   = t1(i,k)
+            qo(i,k)   = q1(i,k)
+            uo(i,k)   = u1(i,k) * rcs(i)
+            vo(i,k)   = v1(i,k) * rcs(i)
+          endif
+        enddo
+      enddo
+!c
+!c  column variables
+!c  p is pressure of the layer (mb)
+!c  t is temperature at t-dt (k)..tn
+!c  q is mixing ratio at t-dt (kg/kg)..qn
+!c  to is temperature at t+dt (k)... this is after advection and turbulan
+!c  qo is mixing ratio at t+dt (kg/kg)..q1
+!c
+      do k = 1, km
+        do i=1,im
+          if (k .le. kmax(i)) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c  compute moist static energy
+!c
+      do k = 1, km
+        do i=1,im
+          if (k .le. kmax(i)) then
+!           tem       = g * zo(i,k) + cp * to(i,k)
+            tem       = phil(i,k) + cp * to(i,k)
+            heo(i,k)  = tem  + hvap * qo(i,k)
+            heso(i,k) = tem  + hvap * qeso(i,k)
+!c           heo(i,k)  = min(heo(i,k),heso(i,k))
+          endif
+        enddo
+      enddo
+!c
+!c  determine level with largest moist static energy
+!c  this is the level where updraft starts
+!c
+      do i=1,im
+        hmax(i) = heo(i,1)
+        kb(i)   = 1
+      enddo
+      do k = 2, km
+        do i=1,im
+          if (k .le. kbm(i)) then
+            if(heo(i,k).gt.hmax(i)) then
+              kb(i)   = k
+              hmax(i) = heo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do k = 1, km1
+        do i=1,im
+          if (k .le. kmax(i)-1) then
+            dz      = .5 * (zo(i,k+1) - zo(i,k))
+            dp      = .5 * (pfld(i,k+1) - pfld(i,k))
+            es      = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
+            pprime  = pfld(i,k+1) + epsm1 * es
+            qs      = eps * es / pprime
+            dqsdp   = - qs / pprime
+            desdt   = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+            dqsdt   = qs * pfld(i,k+1) * desdt / (es * pprime)
+            gamma   = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
+            dt      = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
+            dq      = dqsdt * dt + dqsdp * dp
+            to(i,k) = to(i,k+1) + dt
+            qo(i,k) = qo(i,k+1) + dq
+            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
+          endif
+        enddo
+      enddo
+!
+      do k = 1, km1
+        do i=1,im
+          if (k .le. kmax(i)-1) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+            val1      = 1.0
+            frh(i,k)  = 1. - min(qo(i,k)/qeso(i,k), val1)
+            heo(i,k)  = .5 * g * (zo(i,k) + zo(i,k+1)) +      &
+     &                  cp * to(i,k) + hvap * qo(i,k)
+            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +      &
+     &                  cp * to(i,k) + hvap * qeso(i,k)
+            uo(i,k)   = .5 * (uo(i,k) + uo(i,k+1))
+            vo(i,k)   = .5 * (vo(i,k) + vo(i,k+1))
+          endif
+        enddo
+      enddo
+!c
+!c  look for the level of free convection as cloud base
+!c
+      do i=1,im
+        flg(i)   = .true.
+        kbcon(i) = kmax(i)
+      enddo
+      do k = 1, km1
+        do i=1,im
+          if (flg(i).and.k.le.kbmax(i)) then
+            if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then
+              kbcon(i) = k
+              flg(i)   = .false.
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do i=1,im
+        if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false.
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  determine critical convective inhibition
+!c  as a function of vertical velocity at cloud base.
+!c
+      do i=1,im
+        if(cnvflg(i)) then
+          pdot(i)  = 10.* dot(i,kbcon(i))
+        endif
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          if(slimsk(i).eq.1.) then
+            w1 = w1l
+            w2 = w2l
+            w3 = w3l
+            w4 = w4l
+          else
+            w1 = w1s
+            w2 = w2s
+            w3 = w3s
+            w4 = w4s
+          endif
+          if(pdot(i).le.w4) then
+            tem = (pdot(i) - w4) / (w3 - w4)
+          elseif(pdot(i).ge.-w4) then
+            tem = - (pdot(i) + w4) / (w4 - w3)
+          else
+            tem = 0.
+          endif
+          val1    =             -1.
+          tem = max(tem,val1)
+          val2    =             1.
+          tem = min(tem,val2)
+          tem = 1. - tem
+          tem1= .5*(cincrmax-cincrmin)
+          cincr = cincrmax - tem * tem1
+          pbcdif(i) = pfld(i,kb(i)) - pfld(i,kbcon(i))
+          if(pbcdif(i).gt.cincr) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  assume that updraft entrainment rate above cloud base is
+!c    same as that at cloud base
+!c
+      do k = 2, km1
+        do i=1,im
+          if(cnvflg(i).and.                            &
+     &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
+              xlamue(i,k) = xlamue(i,kbcon(i))
+          endif
+        enddo
+      enddo
+!c
+!c  assume the detrainment rate for the updrafts to be same as
+!c  the entrainment rate at cloud base
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          xlamud(i) = xlamue(i,kbcon(i))
+        endif
+      enddo
+!c
+!c  functions rapidly decreasing with height, mimicking a cloud ensemble
+!c    (Bechtold et al., 2008)
+!c
+      do k = 2, km1
+        do i=1,im
+          if(cnvflg(i).and.                          &
+     &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
+              tem = qeso(i,k)/qeso(i,kbcon(i))
+              fent1(i,k) = tem**2
+              fent2(i,k) = tem**3
+          endif
+        enddo
+      enddo
+!c
+!c  final entrainment rate as the sum of turbulent part and organized entrainment
+!c    depending on the environmental relative humidity
+!c    (Bechtold et al., 2008)
+!c
+      do k = 2, km1
+        do i=1,im
+          if(cnvflg(i).and.                         &
+     &      (k.ge.kbcon(i).and.k.lt.kmax(i))) then
+              tem = cxlamu * frh(i,k) * fent2(i,k)
+              xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem
+          endif
+        enddo
+      enddo
+!c
+!c  determine updraft mass flux for the subcloud layers
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.lt.kbcon(i).and.k.ge.kb(i)) then
+              dz       = zi(i,k+1) - zi(i,k)
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i)
+              eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  compute mass flux above cloud base
+!c
+      do k = 2, km1
+        do i = 1, im
+         if(cnvflg(i))then
+           if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
+              dz       = zi(i,k) - zi(i,k-1)
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i)
+              eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
+           endif
+         endif
+        enddo
+      enddo
+!c
+!c  compute updraft cloud properties
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx         = kb(i)
+          hcko(i,indx) = heo(i,indx)
+          ucko(i,indx) = uo(i,indx)
+          vcko(i,indx) = vo(i,indx)
+          pwavo(i)     = 0.
+        endif
+      enddo
+!c
+!c  cloud property is modified by the entrainment process
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.kmax(i)) then
+              dz   = zi(i,k) - zi(i,k-1)
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              ptem = 0.5 * tem + pgcon
+              ptem1= 0.5 * tem - pgcon
+              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*     &
+     &                     (heo(i,k)+heo(i,k-1)))/factor
+              ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k) &
+     &                     +ptem1*uo(i,k-1))/factor
+              vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k) &
+     &                     +ptem1*vo(i,k-1))/factor
+              dbyo(i,k) = hcko(i,k) - heso(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c   taking account into convection inhibition due to existence of
+!c    dry layers below cloud base
+!c
+      do i=1,im
+        flg(i) = cnvflg(i)
+        kbcon1(i) = kmax(i)
+      enddo
+      do k = 2, km1
+      do i=1,im
+        if (flg(i).and.k.lt.kmax(i)) then
+          if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
+            kbcon1(i) = k
+            flg(i)    = .false.
+          endif
+        endif
+      enddo
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false.
+        endif
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i))
+          if(tem.gt.dthk) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i = 1, im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  determine first guess cloud top as the level of zero buoyancy
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+        ktcon(i) = 1
+      enddo
+      do k = 2, km1
+      do i = 1, im
+        if (flg(i).and.k .lt. kmax(i)) then
+          if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then
+             ktcon(i) = k
+             flg(i)   = .false.
+          endif
+        endif
+      enddo
+      enddo
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          tem = pfld(i,kbcon(i))-pfld(i,ktcon(i))
+          if(tem.lt.cthk) cnvflg(i) = .false.
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i = 1, im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  search for downdraft originating level above theta-e minimum
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+           hmin(i) = heo(i,kbcon1(i))
+           lmin(i) = kbmax(i)
+           jmin(i) = kbmax(i)
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kbmax(i)) then
+            if(k.gt.kbcon1(i).and.heo(i,k).lt.hmin(i)) then
+               lmin(i) = k + 1
+               hmin(i) = heo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  make sure that jmin(i) is within the cloud
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          jmin(i) = min(lmin(i),ktcon(i)-1)
+          jmin(i) = max(jmin(i),kbcon1(i)+1)
+          if(jmin(i).ge.ktcon(i)) cnvflg(i) = .false.
+        endif
+      enddo
+!c
+!c  specify upper limit of mass flux at cloud base
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+!         xmbmax(i) = .1
+!
+          k = kbcon(i)
+          dp = 1000. * del(i,k)
+          xmbmax(i) = dp / (g * dt2)
+          xmbmax(i) = min(sas_mass_flux,xmbmax(i))
+!
+!         tem = dp / (g * dt2)
+!         xmbmax(i) = min(tem, xmbmax(i))
+        endif
+      enddo
+!c
+!c  compute cloud moisture property and precipitation
+!c
+      do i = 1, im
+        if (cnvflg(i)) then
+          aa1(i) = 0.
+          qcko(i,kb(i)) = qo(i,kb(i))
+!         rhbar(i) = 0.
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                             &
+     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*  &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+!cj
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!c
+!             rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k)
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+              if(k.ge.kbcon(i).and.dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0..and.k.gt.jmin(i)) then
+                  dp = 1000. * del(i,k)
+                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0 * dz)
+                endif
+                aa1(i) = aa1(i) - dz * g * qlk
+                qcko(i,k) = qlk + qrch
+                pwo(i,k) = etah * c0 * dz * qlk
+                pwavo(i) = pwavo(i) + pwo(i,k)
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!     do i = 1, im
+!       if(cnvflg(i)) then
+!         indx = ktcon(i) - kb(i) - 1
+!         rhbar(i) = rhbar(i) / float(indx)
+!       endif
+!     enddo
+!c
+!c  calculate cloud work function
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma            &
+     &                 * to(i,k) / hvap
+              aa1(i) = aa1(i) +                           &
+     &                 dz1 * (g / (cp * to(i,k)))         &
+     &                 * dbyo(i,k) / (1. + gamma)         &
+     &                 * rfact
+              val = 0.
+              aa1(i)=aa1(i)+                              &
+     &                 dz1 * g * delta *                  &
+     &                 max(val,(qeso(i,k) - qo(i,k)))
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  estimate the onvective overshooting as the level 
+!c    where the [aafac * cloud work function] becomes zero,
+!c    which is the final cloud top
+!c
+      do i = 1, im
+        if (cnvflg(i)) then
+          aa2(i) = aafac * aa1(i)
+        endif
+      enddo
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+        ktcon1(i) = kmax(i) - 1
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (flg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.kmax(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma          &
+     &                 * to(i,k) / hvap
+              aa2(i) = aa2(i) +                         &
+     &                 dz1 * (g / (cp * to(i,k)))       &
+     &                 * dbyo(i,k) / (1. + gamma)       &
+     &                 * rfact
+              if(aa2(i).lt.0.) then
+                ktcon1(i) = k
+                flg(i) = .false.
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  compute cloud moisture property, detraining cloud water 
+!c    and precipitation in overshooting layers 
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                              &
+     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*   &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+!cj
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+              if(dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0.) then
+                  dp = 1000. * del(i,k)
+                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0 * dz)
+                endif
+                qcko(i,k) = qlk + qrch
+                pwo(i,k) = etah * c0 * dz * qlk
+                pwavo(i) = pwavo(i) + pwo(i,k)
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c exchange ktcon with ktcon1
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          kk = ktcon(i)
+          ktcon(i) = ktcon1(i)
+          ktcon1(i) = kk
+        endif
+      enddo
+!c
+!c  this section is ready for cloud water
+!c
+      if(ncloud.gt.0) then
+!c
+!c  compute liquid and vapor separation at cloud top
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          k = ktcon(i) - 1
+          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+          qrch = qeso(i,k)                              &
+     &         + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+          dq = qcko(i,k) - qrch
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+          if(dq.gt.0.) then
+            qlko_ktcon(i) = dq
+            qcko(i,k) = qrch
+          endif
+        endif
+      enddo
+      endif
+!c
+!ccccc if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then
+!ccccc   print *, ' aa1(i) before dwndrft =', aa1(i)
+!ccccc endif
+!c
+!c------- downdraft calculations
+!c
+!c--- compute precipitation efficiency in terms of windshear
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          vshear(i) = 0.
+        endif
+      enddo
+      do k = 2, km
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2      &
+     &                  + (vo(i,k)-vo(i,k-1)) ** 2)
+              vshear(i) = vshear(i) + shear
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
+          e1=1.591-.639*vshear(i)                       &
+     &       +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
+          edt(i)=1.-e1
+          val =         .9
+          edt(i) = min(edt(i),val)
+          val =         .0
+          edt(i) = max(edt(i),val)
+          edto(i)=edt(i)
+          edtx(i)=edt(i)
+        endif
+      enddo
+!c
+!c  determine detrainment rate between 1 and kbcon
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          sumx(i) = 0.
+        endif
+      enddo
+      do k = 1, km1
+      do i = 1, im
+        if(cnvflg(i).and.k.ge.1.and.k.lt.kbcon(i)) then
+          dz = zi(i,k+1) - zi(i,k)
+          sumx(i) = sumx(i) + dz
+        endif
+      enddo
+      enddo
+      do i = 1, im
+        beta = betas
+        if(slimsk(i).eq.1.) beta = betal
+        if(cnvflg(i)) then
+          dz  = (sumx(i)+zi(i,1))/float(kbcon(i))
+          tem = 1./float(kbcon(i))
+          xlamd(i) = (1.-beta**tem)/dz
+        endif
+      enddo
+!c
+!c  determine downdraft mass flux
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)-1) then
+           if(k.lt.jmin(i).and.k.ge.kbcon(i)) then
+              dz        = zi(i,k+1) - zi(i,k)
+              ptem      = xlamdd - xlamde
+              etad(i,k) = etad(i,k+1) * (1. - ptem * dz)
+           else if(k.lt.kbcon(i)) then
+              dz        = zi(i,k+1) - zi(i,k)
+              ptem      = xlamd(i) + xlamdd - xlamde
+              etad(i,k) = etad(i,k+1) * (1. - ptem * dz)
+           endif
+          endif
+        enddo
+      enddo
+!c
+!c--- downdraft moisture properties
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          jmn = jmin(i)
+          hcdo(i,jmn) = heo(i,jmn)
+          qcdo(i,jmn) = qo(i,jmn)
+          qrcdo(i,jmn)= qeso(i,jmn)
+          ucdo(i,jmn) = uo(i,jmn)
+          vcdo(i,jmn) = vo(i,jmn)
+          pwevo(i) = 0.
+        endif
+      enddo
+!cj
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k.lt.jmin(i)) then
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              ptem = 0.5 * tem - pgcon
+              ptem1= 0.5 * tem + pgcon
+              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*       &
+     &                     (heo(i,k)+heo(i,k+1)))/factor
+              ucdo(i,k) = ((1.-tem1)*ucdo(i,k+1)+ptem*uo(i,k+1) &
+     &                     +ptem1*uo(i,k))/factor
+              vcdo(i,k) = ((1.-tem1)*vcdo(i,k+1)+ptem*vo(i,k+1) &
+     &                     +ptem1*vo(i,k))/factor
+              dbyo(i,k) = hcdo(i,k) - heso(i,k)
+          endif
+        enddo
+      enddo
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i).and.k.lt.jmin(i)) then
+              gamma      = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrcdo(i,k) = qeso(i,k)+                          &
+     &                (1./hvap)*(gamma/(1.+gamma))*dbyo(i,k)
+!             detad      = etad(i,k+1) - etad(i,k)
+!cj
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5*     &
+     &                     (qo(i,k)+qo(i,k+1)))/factor
+!cj
+!             pwdo(i,k)  = etad(i,k+1) * qcdo(i,k+1) -
+!    &                     etad(i,k) * qrcdo(i,k)
+!             pwdo(i,k)  = pwdo(i,k) - detad *
+!    &                    .5 * (qrcdo(i,k) + qrcdo(i,k+1))
+!cj
+              pwdo(i,k)  = etad(i,k+1) * (qcdo(i,k) - qrcdo(i,k))
+              qcdo(i,k)  = qrcdo(i,k)
+              pwevo(i)   = pwevo(i) + pwdo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c--- final downdraft strength dependent on precip
+!c--- efficiency (edt), normalized condensate (pwav), and
+!c--- evaporate (pwev)
+!c
+      do i = 1, im
+        edtmax = edtmaxl
+        if(slimsk(i).eq.0.) edtmax = edtmaxs
+        if(cnvflg(i)) then
+          if(pwevo(i).lt.0.) then
+            edto(i) = -edto(i) * pwavo(i) / pwevo(i)
+            edto(i) = min(edto(i),edtmax)
+          else
+            edto(i) = 0.
+          endif
+        endif
+      enddo
+!c
+!c--- downdraft cloudwork functions
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k .lt. jmin(i)) then
+              gamma = el2orc * qeso(i,k) / to(i,k)**2
+              dhh=hcdo(i,k)
+              dt=to(i,k)
+              dg=gamma
+              dh=heso(i,k)
+              dz=-1.*(zo(i,k+1)-zo(i,k))
+              aa1(i)=aa1(i)+edto(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg)) &
+     &               *(1.+delta*cp*dg*dt/hvap)
+              val=0.
+              aa1(i)=aa1(i)+edto(i)*                    &
+     &        dz*g*delta*max(val,(qeso(i,k)-qo(i,k)))
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i).and.aa1(i).le.0.) then
+           cnvflg(i) = .false.
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c--- what would the change be, that a cloud with unit mass
+!c--- will do to the environment?
+!c
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)) then
+            dellah(i,k) = 0.
+            dellaq(i,k) = 0.
+            dellau(i,k) = 0.
+            dellav(i,k) = 0.
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          dp = 1000. * del(i,1)
+          dellah(i,1) = edto(i) * etad(i,1) * (hcdo(i,1)     &
+     &                   - heo(i,1)) * g / dp
+          dellaq(i,1) = edto(i) * etad(i,1) * (qcdo(i,1)     &
+     &                   - qo(i,1)) * g / dp
+          dellau(i,1) = edto(i) * etad(i,1) * (ucdo(i,1)     &
+     &                   - uo(i,1)) * g / dp
+          dellav(i,1) = edto(i) * etad(i,1) * (vcdo(i,1)     &
+     &                   - vo(i,1)) * g / dp
+        endif
+      enddo
+!c
+!c--- changed due to subsidence and entrainment
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i).and.k.lt.ktcon(i)) then
+              aup = 1.
+              if(k.le.kb(i)) aup = 0.
+              adw = 1.
+              if(k.gt.jmin(i)) adw = 0.
+              dp = 1000. * del(i,k)
+              dz = zi(i,k) - zi(i,k-1)
+!c
+              dv1h = heo(i,k)
+              dv2h = .5 * (heo(i,k) + heo(i,k-1))
+              dv3h = heo(i,k-1)
+              dv1q = qo(i,k)
+              dv2q = .5 * (qo(i,k) + qo(i,k-1))
+              dv3q = qo(i,k-1)
+              dv1u = uo(i,k)
+              dv2u = .5 * (uo(i,k) + uo(i,k-1))
+              dv3u = uo(i,k-1)
+              dv1v = vo(i,k)
+              dv2v = .5 * (vo(i,k) + vo(i,k-1))
+              dv3v = vo(i,k-1)
+!c
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1))
+              tem1 = xlamud(i)
+!c
+              if(k.le.kbcon(i)) then
+                ptem  = xlamde
+                ptem1 = xlamd(i)+xlamdd
+              else
+                ptem  = xlamde
+                ptem1 = xlamdd
+              endif
+!cj
+              dellah(i,k) = dellah(i,k) +                           &
+     &     ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1h               &
+     &    - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3h           &
+     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2h*dz &
+     &    +  aup*tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz      &
+     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1)) &
+     &         *dz) *g/dp
+!cj
+              dellaq(i,k) = dellaq(i,k) +                             &
+     &     ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1q                 &
+     &    - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3q             &
+     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2q*dz   &
+     &    +  aup*tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz        &
+     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qrcdo(i,k-1)) &
+     &         *dz) *g/dp
+!23456789012345678901234567890123456789012345678901234567890123456789012
+!cj
+              dellau(i,k) = dellau(i,k) +                             &
+     &     ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1u                 &
+     &    - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3u             &
+     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2u*dz   &
+     &    +  aup*tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz        &
+     &    + adw*edto(i)*ptem1*etad(i,k)*.5*(ucdo(i,k)+ucdo(i,k-1))*dz &
+     &    -  pgcon*(aup*eta(i,k-1)-adw*edto(i)*etad(i,k))*(dv1u-dv3u) &
+     &         ) *g/dp
+!cj
+              dellav(i,k) = dellav(i,k) +                             &
+     &     ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1v                 &
+     &    - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3v             &
+     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2v*dz   &
+     &    +  aup*tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz        &
+     &    + adw*edto(i)*ptem1*etad(i,k)*.5*(vcdo(i,k)+vcdo(i,k-1))*dz &
+     &    -  pgcon*(aup*eta(i,k-1)-adw*edto(i)*etad(i,k))*(dv1v-dv3v) &
+     &         ) *g/dp
+!cj
+          endif
+        enddo
+      enddo
+!c
+!c------- cloud top
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx = ktcon(i)
+          dp = 1000. * del(i,indx)
+          dv1h = heo(i,indx-1)
+          dellah(i,indx) = eta(i,indx-1) *                    &
+     &                     (hcko(i,indx-1) - dv1h) * g / dp
+          dv1q = qo(i,indx-1)
+          dellaq(i,indx) = eta(i,indx-1) *                    &
+     &                     (qcko(i,indx-1) - dv1q) * g / dp
+          dv1u = uo(i,indx-1)
+          dellau(i,indx) = eta(i,indx-1) *                    &
+     &                     (ucko(i,indx-1) - dv1u) * g / dp
+          dv1v = vo(i,indx-1)
+          dellav(i,indx) = eta(i,indx-1) *                    &
+     &                     (vcko(i,indx-1) - dv1v) * g / dp
+!c
+!c  cloud water
+!c
+          dellal(i,indx) = eta(i,indx-1) *                    &
+     &                     qlko_ktcon(i) * g / dp
+        endif
+      enddo
+!c
+!c------- final changed variable per unit mass flux
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i).and.k .le. kmax(i)) then
+            if(k.gt.ktcon(i)) then
+              qo(i,k) = q1(i,k)
+              to(i,k) = t1(i,k)
+            endif
+            if(k.le.ktcon(i)) then
+              qo(i,k) = dellaq(i,k) * mbdt + q1(i,k)
+              dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp
+              to(i,k) = dellat * mbdt + t1(i,k)
+              val   =           1.e-10
+              qo(i,k) = max(qo(i,k), val  )
+            endif
+          endif
+        enddo
+      enddo
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+!c--- the above changed environment is now used to calulate the
+!c--- effect the arbitrary cloud (with unit mass flux)
+!c--- would have on the stability,
+!c--- which then is used to calculate the real mass flux,
+!c--- necessary to keep this change in balance with the large-scale
+!c--- destabilization.
+!c
+!c--- environmental conditions again, first heights
+!c
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k)+epsm1*qeso(i,k))
+            val       =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val )
+!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c--- moist static energy
+!c
+      do k = 1, km1
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)-1) then
+            dz = .5 * (zo(i,k+1) - zo(i,k))
+            dp = .5 * (pfld(i,k+1) - pfld(i,k))
+            es = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
+            pprime = pfld(i,k+1) + epsm1 * es
+            qs = eps * es / pprime
+            dqsdp = - qs / pprime
+            desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+            dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime)
+            gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
+            dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
+            dq = dqsdt * dt + dqsdp * dp
+            to(i,k) = to(i,k+1) + dt
+            qo(i,k) = qo(i,k+1) + dq
+            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
+          endif
+        enddo
+      enddo
+      do k = 1, km1
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)-1) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1 * qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+            heo(i,k)   = .5 * g * (zo(i,k) + zo(i,k+1)) +     &
+     &                    cp * to(i,k) + hvap * qo(i,k)
+            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +      &
+     &                  cp * to(i,k) + hvap * qeso(i,k)
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          k = kmax(i)
+          heo(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qo(i,k)
+          heso(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qeso(i,k)
+!c         heo(i,k) = min(heo(i,k),heso(i,k))
+        endif
+      enddo
+!c
+!c**************************** static control
+!c
+!c------- moisture and cloud work functions
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          xaa0(i) = 0.
+          xpwav(i) = 0.
+        endif
+      enddo
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx = kb(i)
+          hcko(i,indx) = heo(i,indx)
+          qcko(i,indx) = qo(i,indx)
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              dz = zi(i,k) - zi(i,k-1)
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*    &
+     &                     (heo(i,k)+heo(i,k-1)))/factor
+            endif
+          endif
+        enddo
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dz = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              xdby = hcko(i,k) - heso(i,k)
+              xqrch = qeso(i,k)                             &
+     &              + gamma * xdby / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*   &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+!cj
+              dq = eta(i,k) * (qcko(i,k) - xqrch)
+!c
+              if(k.ge.kbcon(i).and.dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0..and.k.gt.jmin(i)) then
+                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+                else
+                  qlk = dq / (eta(i,k) + etah * c0 * dz)
+                endif
+                if(k.lt.ktcon1(i)) then
+                  xaa0(i) = xaa0(i) - dz * g * qlk
+                endif
+                qcko(i,k) = qlk + xqrch
+                xpw = etah * c0 * dz * qlk
+                xpwav(i) = xpwav(i) + xpw
+              endif
+            endif
+            if(k.ge.kbcon(i).and.k.lt.ktcon1(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma          &
+     &                 * to(i,k) / hvap
+              xaa0(i) = xaa0(i)                         &
+     &                + dz1 * (g / (cp * to(i,k)))      &
+     &                * xdby / (1. + gamma)             &
+     &                * rfact
+              val=0.
+              xaa0(i)=xaa0(i)+                          &
+     &                 dz1 * g * delta *                &
+     &                 max(val,(qeso(i,k) - qo(i,k)))
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c------- downdraft calculations
+!c
+!c--- downdraft moisture properties
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          jmn = jmin(i)
+          hcdo(i,jmn) = heo(i,jmn)
+          qcdo(i,jmn) = qo(i,jmn)
+          qrcd(i,jmn) = qeso(i,jmn)
+          xpwev(i) = 0.
+        endif
+      enddo
+!cj
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k.lt.jmin(i)) then
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*      &
+     &                     (heo(i,k)+heo(i,k+1)))/factor
+          endif
+        enddo
+      enddo
+!cj
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k .lt. jmin(i)) then
+              dq = qeso(i,k)
+              dt = to(i,k)
+              gamma    = el2orc * dq / dt**2
+              dh       = hcdo(i,k) - heso(i,k)
+              qrcd(i,k)=dq+(1./hvap)*(gamma/(1.+gamma))*dh
+!             detad    = etad(i,k+1) - etad(i,k)
+!cj
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5*     &
+     &                     (qo(i,k)+qo(i,k+1)))/factor
+!cj
+!             xpwd     = etad(i,k+1) * qcdo(i,k+1) -
+!    &                   etad(i,k) * qrcd(i,k)
+!             xpwd     = xpwd - detad *
+!    &                 .5 * (qrcd(i,k) + qrcd(i,k+1))
+!cj
+              xpwd     = etad(i,k+1) * (qcdo(i,k) - qrcd(i,k))
+              qcdo(i,k)= qrcd(i,k)
+              xpwev(i) = xpwev(i) + xpwd
+          endif
+        enddo
+      enddo
+!c
+      do i = 1, im
+        edtmax = edtmaxl
+        if(slimsk(i).eq.0.) edtmax = edtmaxs
+        if(cnvflg(i)) then
+          if(xpwev(i).ge.0.) then
+            edtx(i) = 0.
+          else
+            edtx(i) = -edtx(i) * xpwav(i) / xpwev(i)
+            edtx(i) = min(edtx(i),edtmax)
+          endif
+        endif
+      enddo
+!c
+!c
+!c--- downdraft cloudwork functions
+!c
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k.lt.jmin(i)) then
+              gamma = el2orc * qeso(i,k) / to(i,k)**2
+              dhh=hcdo(i,k)
+              dt= to(i,k)
+              dg= gamma
+              dh= heso(i,k)
+              dz=-1.*(zo(i,k+1)-zo(i,k))
+              xaa0(i)=xaa0(i)+edtx(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg)) &
+     &                *(1.+delta*cp*dg*dt/hvap)
+              val=0.
+              xaa0(i)=xaa0(i)+edtx(i)*                         &
+     &        dz*g*delta*max(val,(qeso(i,k)-qo(i,k)))
+          endif
+        enddo
+      enddo
+!c
+!c  calculate critical cloud work function
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          if(pfld(i,ktcon(i)).lt.pcrit(15))then
+            acrt(i)=acrit(15)*(975.-pfld(i,ktcon(i)))          &
+     &              /(975.-pcrit(15))
+          else if(pfld(i,ktcon(i)).gt.pcrit(1))then
+            acrt(i)=acrit(1)
+          else
+            k =  int((850. - pfld(i,ktcon(i)))/50.) + 2
+            k = min(k,15)
+            k = max(k,2)
+            acrt(i)=acrit(k)+(acrit(k-1)-acrit(k))*            &
+     &           (pfld(i,ktcon(i))-pcrit(k))/(pcrit(k-1)-pcrit(k))
+          endif
+        endif
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          if(slimsk(i).eq.1.) then
+            w1 = w1l
+            w2 = w2l
+            w3 = w3l
+            w4 = w4l
+          else
+            w1 = w1s
+            w2 = w2s
+            w3 = w3s
+            w4 = w4s
+          endif
+!c
+!c  modify critical cloud workfunction by cloud base vertical velocity
+!c
+          if(pdot(i).le.w4) then
+            acrtfct(i) = (pdot(i) - w4) / (w3 - w4)
+          elseif(pdot(i).ge.-w4) then
+            acrtfct(i) = - (pdot(i) + w4) / (w4 - w3)
+          else
+            acrtfct(i) = 0.
+          endif
+          val1    =             -1.
+          acrtfct(i) = max(acrtfct(i),val1)
+          val2    =             1.
+          acrtfct(i) = min(acrtfct(i),val2)
+          acrtfct(i) = 1. - acrtfct(i)
+!c
+!c  modify acrtfct(i) by colume mean rh if rhbar(i) is greater than 80 percent
+!c
+!c         if(rhbar(i).ge..8) then
+!c           acrtfct(i) = acrtfct(i) * (.9 - min(rhbar(i),.9)) * 10.
+!c         endif
+!c
+!c  modify adjustment time scale by cloud base vertical velocity
+!c
+          val1=0.
+          dtconv(i) = dt2 + max((1800. - dt2),val1) *         &
+     &                (pdot(i) - w2) / (w1 - w2)
+!c         dtconv(i) = max(dtconv(i), dt2)
+!c         dtconv(i) = 1800. * (pdot(i) - w2) / (w1 - w2)
+          dtconv(i) = max(dtconv(i),dtmin)
+          dtconv(i) = min(dtconv(i),dtmax)
+!c
+        endif
+      enddo
+!c
+!c--- large scale forcing
+!c
+      xmbmx1=-1.e20
+      do i= 1, im
+        if(cnvflg(i)) then
+          fld(i)=(aa1(i)-acrt(i)* acrtfct(i))/dtconv(i)
+          if(fld(i).le.0.) cnvflg(i) = .false.
+        endif
+        if(cnvflg(i)) then
+!c         xaa0(i) = max(xaa0(i),0.)
+          xk(i) = (xaa0(i) - aa1(i)) / mbdt
+          if(xk(i).ge.0.) cnvflg(i) = .false.
+        endif
+!c
+!c--- kernel, cloud base mass flux
+!c
+        if(cnvflg(i)) then
+          xmb(i) = -fld(i) / xk(i)
+          xmb(i) = min(xmb(i),xmbmax(i))
+          xmbmx1=max(xmbmx1,xmb(i))
+        endif
+      enddo
+!      if(xmbmx1.gt.0.4)print*,'qingfu test xmbmx1=',xmbmx1
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  restore to,qo,uo,vo to t1,q1,u1,v1 in case convection stops
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            to(i,k) = t1(i,k)
+            qo(i,k) = q1(i,k)
+            uo(i,k) = u1(i,k)
+            vo(i,k) = v1(i,k)
+            qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
+            val     =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val )
+          endif
+        enddo
+      enddo
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+!c--- feedback: simply the changes from the cloud with unit mass flux
+!c---           multiplied by  the mass flux necessary to keep the
+!c---           equilibrium with the larger-scale.
+!c
+      do i = 1, im
+        delhbar(i) = 0.
+        delqbar(i) = 0.
+        deltbar(i) = 0.
+        delubar(i) = 0.
+        delvbar(i) = 0.
+        qcond(i) = 0.
+      enddo
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            if(k.le.ktcon(i)) then
+              dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp
+              t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2
+              q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2
+              tem = 1./rcs(i)
+              u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem
+              v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem
+              dp = 1000. * del(i,k)
+              delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g
+              delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g
+              deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g
+              delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g
+              delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g
+            endif
+          endif
+        enddo
+      enddo
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            if(k.le.ktcon(i)) then
+              qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
+              qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k))
+              val     =             1.e-8
+              qeso(i,k) = max(qeso(i,k), val )
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do i = 1, im
+        rntot(i) = 0.
+        delqev(i) = 0.
+        delq2(i) = 0.
+        flg(i) = cnvflg(i)
+      enddo
+      do k = km, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            if(k.lt.ktcon(i)) then
+              aup = 1.
+              if(k.le.kb(i)) aup = 0.
+              adw = 1.
+              if(k.ge.jmin(i)) adw = 0.
+              rain =  aup * pwo(i,k) + adw * edto(i) * pwdo(i,k)
+              rntot(i) = rntot(i) + rain * xmb(i) * .001 * dt2
+            endif
+          endif
+        enddo
+      enddo
+      do k = km, 1, -1
+        do i = 1, im
+          if (k .le. kmax(i)) then
+            deltv(i) = 0.
+            delq(i) = 0.
+            qevap(i) = 0.
+            if(cnvflg(i).and.k.lt.ktcon(i)) then
+              aup = 1.
+              if(k.le.kb(i)) aup = 0.
+              adw = 1.
+              if(k.ge.jmin(i)) adw = 0.
+              rain =  aup * pwo(i,k) + adw * edto(i) * pwdo(i,k)
+              rn(i) = rn(i) + rain * xmb(i) * .001 * dt2
+            endif
+            if(flg(i).and.k.lt.ktcon(i)) then
+              evef = edt(i) * evfact
+              if(slimsk(i).eq.1.) evef=edt(i) * evfactl
+!             if(slimsk(i).eq.1.) evef=.07
+!c             if(slimsk(i).ne.1.) evef = 0.
+              qcond(i) = evef * (q1(i,k) - qeso(i,k))     &
+     &                 / (1. + el2orc * qeso(i,k) / t1(i,k)**2)
+              dp = 1000. * del(i,k)
+              if(rn(i).gt.0..and.qcond(i).lt.0.) then
+                qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i))))
+                qevap(i) = min(qevap(i), rn(i)*1000.*g/dp)
+                delq2(i) = delqev(i) + .001 * qevap(i) * dp / g
+              endif
+              if(rn(i).gt.0..and.qcond(i).lt.0..and.      &
+     &           delq2(i).gt.rntot(i)) then
+                qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp
+                flg(i) = .false.
+              endif
+              if(rn(i).gt.0..and.qevap(i).gt.0.) then
+                q1(i,k) = q1(i,k) + qevap(i)
+                t1(i,k) = t1(i,k) - elocp * qevap(i)
+                rn(i) = rn(i) - .001 * qevap(i) * dp / g
+                deltv(i) = - elocp*qevap(i)/dt2
+                delq(i) =  + qevap(i)/dt2
+                delqev(i) = delqev(i) + .001*dp*qevap(i)/g
+              endif
+              dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i)
+              delqbar(i) = delqbar(i) + delq(i)*dp/g
+              deltbar(i) = deltbar(i) + deltv(i)*dp/g
+            endif
+          endif
+        enddo
+      enddo
+!cj
+!     do i = 1, im
+!     if(me.eq.31.and.cnvflg(i)) then
+!     if(cnvflg(i)) then
+!       print *, ' deep delhbar, delqbar, deltbar = ',
+!    &             delhbar(i),hvap*delqbar(i),cp*deltbar(i)
+!       print *, ' deep delubar, delvbar = ',delubar(i),delvbar(i)
+!       print *, ' precip =', hvap*rn(i)*1000./dt2
+!       print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i))
+!     endif
+!     enddo
+!c
+!c  precipitation rate converted to actual precip
+!c  in unit of m instead of kg
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+!c
+!c  in the event of upper level rain evaporation and lower level downdraft
+!c    moistening, rn can become negative, in this case, we back out of the
+!c    heating and the moistening
+!c
+          if(rn(i).lt.0..and..not.flg(i)) rn(i) = 0.
+          if(rn(i).le.0.) then
+            rn(i) = 0.
+          else
+            ktop(i) = ktcon(i)
+            kbot(i) = kbcon(i)
+            kcnv(i) = 1
+            cldwrk(i) = aa1(i)
+          endif
+        endif
+      enddo
+!c
+!c  cloud water
+!c
+      if (ncloud.gt.0) then
+!
+      val1=1.0
+      val2=0.0
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. rn(i).gt.0.) then
+            if (k.gt.kb(i).and.k.le.ktcon(i)) then
+              tem  = dellal(i,k) * xmb(i) * dt2
+              tem1 = max(val2, min(val1, (tcr-t1(i,k))*tcrf))
+              if (ql(i,k,2) .gt. -999.0) then
+                ql(i,k,1) = ql(i,k,1) + tem * tem1            ! ice
+                ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1)       ! water
+              else
+                ql(i,k,1) = ql(i,k,1) + tem
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+      endif
+!c
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i).and.rn(i).le.0.) then
+            if (k .le. kmax(i)) then
+              t1(i,k) = to(i,k)
+              q1(i,k) = qo(i,k)
+              u1(i,k) = uo(i,k)
+              v1(i,k) = vo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!
+! hchuang code change
+!
+!      do k = 1, km
+!        do i = 1, im
+!          if(cnvflg(i).and.rn(i).gt.0.) then
+!            if(k.ge.kb(i) .and. k.lt.ktop(i)) then
+!              ud_mf(i,k) = eta(i,k) * xmb(i) * dt2
+!            endif
+!          endif
+!        enddo
+!      enddo
+!      do i = 1, im
+!        if(cnvflg(i).and.rn(i).gt.0.) then
+!           k = ktop(i)-1
+!           dt_mf(i,k) = ud_mf(i,k)
+!        endif
+!      enddo
+!      do k = 1, km
+!        do i = 1, im
+!          if(cnvflg(i).and.rn(i).gt.0.) then
+!            if(k.ge.1 .and. k.le.jmin(i)) then
+!              dd_mf(i,k) = edto(i) * etad(i,k) * xmb(i) * dt2
+!            endif
+!          endif
+!        enddo
+!      enddo
+!!
+      return
+      end subroutine sascnvn      
+
+      subroutine shalcnv(im,ix,km,jcap,delt,del,prsl,ps,phil,ql,   &
+     &     q1,t1,u1,v1,rcs,rn,kbot,ktop,kcnv,slimsk,               &
+     &     dot,ncloud,hpbl,heat,evap,pgcon)
+!
+      use MODULE_GFS_machine , only : kind_phys
+      use MODULE_GFS_funcphys , only : fpvs
+      use MODULE_GFS_physcons, grav => con_g, cp => con_cp, hvap => con_hvap         &
+     &,             rv => con_rv, fv => con_fvirt, t0c => con_t0c         &
+     &,             rd => con_rd, cvap => con_cvap, cliq => con_cliq      &
+     &,             eps => con_eps, epsm1 => con_epsm1
+      implicit none
+!
+      integer            im, ix,  km, jcap, ncloud,                       &
+     &                   kbot(im), ktop(im), kcnv(im)                   
+      real(kind=kind_phys) delt
+      real(kind=kind_phys) ps(im),     del(ix,km),  prsl(ix,km),          &
+     &                     ql(ix,km,2),q1(ix,km),   t1(ix,km),            &
+     &                     u1(ix,km),  v1(ix,km),   rcs(im),              &
+     &                     rn(im),     slimsk(im),                        &
+     &                     dot(ix,km), phil(ix,km), hpbl(im),             &
+     &                     heat(im),   evap(im)                           
+!     &,                    ud_mf(im,km),dt_mf(im,km)
+
+      real  ud_mf(im,km),dt_mf(im,km)
+!
+      integer              i,j,indx, jmn, k, kk, latd, lond, km1
+      integer              kpbl(im)
+!
+      real(kind=kind_phys) c0,      cpoel,   dellat,  delta,        &
+     &                     desdt,   deta,    detad,   dg,           &
+     &                     dh,      dhh,     dlnsig,  dp,           &
+     &                     dq,      dqsdp,   dqsdt,   dt,           &
+     &                     dt2,     dtmax,   dtmin,   dv1h,         &
+     &                     dv1q,    dv2h,    dv2q,    dv1u,         &
+     &                     dv1v,    dv2u,    dv2v,    dv3q,         &
+     &                     dv3h,    dv3u,    dv3v,    clam,         &
+     &                     dz,      dz1,     e1,                    &
+     &                     el2orc,  elocp,   aafac,   cthk,         &
+     &                     es,      etah,    h1,      dthk,         &
+     &                     evef,    evfact,  evfactl, fact1,        &
+     &                     fact2,   factor,  fjcap,                 &
+     &                     g,       gamma,   pprime,  betaw,        &
+     &                     qlk,     qrch,    qs,      c1,           &
+     &                     rain,    rfact,   shear,   tem1,         &
+     &                     tem2,    terr,    val,     val1,         &
+     &                     val2,    w1,      w1l,     w1s,          &
+     &                     w2,      w2l,     w2s,     w3,           &
+     &                     w3l,     w3s,     w4,      w4l,          &
+     &                     w4s,     tem,     ptem,    ptem1,        &
+     &                     pgcon
+!
+      integer              kb(im), kbcon(im), kbcon1(im),           &
+     &                     ktcon(im), ktcon1(im),                   &
+     &                     kbm(im), kmax(im)
+!
+      real(kind=kind_phys) aa1(im),                                 &
+     &                     delhbar(im), delq(im),   delq2(im),      &
+     &                     delqbar(im), delqev(im), deltbar(im),    &
+     &                     deltv(im),   edt(im),                    &
+     &                     wstar(im),   sflx(im),                   &
+     &                     pdot(im),    po(im,km),                  &
+     &                     qcond(im),   qevap(im),  hmax(im),       &
+     &                     rntot(im),   vshear(im),                 &
+     &                     xlamud(im),  xmb(im),    xmbmax(im),     &
+     &                     delubar(im), delvbar(im)
+!c
+      real(kind=kind_phys) cincr, cincrmax, cincrmin
+!cc
+!c  physical parameters
+      parameter(g=grav)
+      parameter(cpoel=cp/hvap,elocp=hvap/cp,                            &
+     &          el2orc=hvap*hvap/(rv*cp))
+      parameter(terr=0.,c0=.002,c1=5.e-4,delta=fv)
+      parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c)
+      parameter(cthk=50.,cincrmax=180.,cincrmin=120.,dthk=25.)
+      parameter(h1=0.33333333)
+!c  local variables and arrays
+      real(kind=kind_phys) pfld(im,km),    to(im,km),     qo(im,km),    &
+     &                     uo(im,km),      vo(im,km),     qeso(im,km)
+!c  cloud water
+      real(kind=kind_phys) qlko_ktcon(im), dellal(im,km),                   &
+     &                     dbyo(im,km),    zo(im,km),     xlamue(im,km),    &
+     &                     heo(im,km),     heso(im,km),                     &
+     &                     dellah(im,km),  dellaq(im,km),                   &
+     &                     dellau(im,km),  dellav(im,km), hcko(im,km),      &
+     &                     ucko(im,km),    vcko(im,km),   qcko(im,km),      &
+     &                     eta(im,km),     zi(im,km),     pwo(im,km),       &
+     &                     tx1(im)
+!
+      logical totflg, cnvflg(im), flg(im)
+!
+      real(kind=kind_phys) tf, tcr, tcrf
+      parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf))
+!
+!c-----------------------------------------------------------------------
+!
+      km1 = km - 1
+!c
+!c  compute surface buoyancy flux
+!c
+      do i=1,im
+        sflx(i) = heat(i)+fv*t1(i,1)*evap(i)
+      enddo
+!c
+!c  initialize arrays
+!c
+      do i=1,im
+        cnvflg(i) = .true.
+        if(kcnv(i).eq.1) cnvflg(i) = .false.
+        if(sflx(i).le.0.) cnvflg(i) = .false.
+        if(cnvflg(i)) then
+          kbot(i)=km+1
+          ktop(i)=0
+        endif
+        rn(i)=0.
+        kbcon(i)=km
+        ktcon(i)=1
+        kb(i)=km
+        pdot(i) = 0.
+        qlko_ktcon(i) = 0.
+        edt(i)  = 0.
+        aa1(i)  = 0.
+        vshear(i) = 0.
+      enddo
+! hchuang code change
+      do k = 1, km
+        do i = 1, im
+          ud_mf(i,k) = 0.
+          dt_mf(i,k) = 0.
+        enddo
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+      dt2   = delt
+      val   =         1200.
+      dtmin = max(dt2, val )
+      val   =         3600.
+      dtmax = max(dt2, val )
+!c  model tunable parameters are all here
+      clam    = .3
+      aafac   = .1
+      betaw   = .03
+!c     evef    = 0.07
+      evfact  = 0.3
+      evfactl = 0.3
+!
+      fjcap   = (float(jcap) / 126.) ** 2
+      val     =           1.
+      fjcap   = max(fjcap,val)
+      w1l     = -8.e-3 
+      w2l     = -4.e-2
+      w3l     = -5.e-3 
+      w4l     = -5.e-4
+      w1s     = -2.e-4
+      w2s     = -2.e-3
+      w3s     = -1.e-3
+      w4s     = -2.e-5
+!c
+!c  define top layer for search of the downdraft originating layer
+!c  and the maximum thetae for updraft
+!c
+      do i=1,im
+        kbm(i)   = km
+        kmax(i)  = km
+        tx1(i)   = 1.0 / ps(i)
+      enddo
+!     
+      do k = 1, km
+        do i=1,im
+          if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i)   = k + 1
+          if (prsl(i,k)*tx1(i) .gt. 0.60) kmax(i)  = k + 1
+        enddo
+      enddo
+      do i=1,im
+        kbm(i)   = min(kbm(i),kmax(i))
+      enddo
+!c
+!!c  hydrostatic height assume zero terr and compute
+!c  updraft entrainment rate as an inverse function of height
+!c
+      do k = 1, km
+        do i=1,im
+          zo(i,k) = phil(i,k) / g
+        enddo
+      enddo
+      do k = 1, km1
+        do i=1,im
+          zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1))
+          xlamue(i,k) = clam / zi(i,k)
+        enddo
+      enddo
+      do i=1,im
+        xlamue(i,km) = xlamue(i,km1)
+      enddo
+!c
+!c  pbl height
+!c
+      do i=1,im
+        flg(i) = cnvflg(i)
+        kpbl(i)= 1
+      enddo
+      do k = 2, km1
+        do i=1,im
+          if (flg(i).and.zo(i,k).le.hpbl(i)) then
+            kpbl(i) = k
+          else
+            flg(i) = .false.
+          endif
+        enddo
+      enddo
+      do i=1,im
+        kpbl(i)= min(kpbl(i),kbm(i))
+      enddo
+!c
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c   convert surface pressure to mb from cb
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            pfld(i,k) = prsl(i,k) * 10.0
+            eta(i,k)  = 1.
+            hcko(i,k) = 0.
+            qcko(i,k) = 0.
+            ucko(i,k) = 0.
+            vcko(i,k) = 0.
+            dbyo(i,k) = 0.
+            pwo(i,k)  = 0.
+            dellal(i,k) = 0.
+            to(i,k)   = t1(i,k)
+            qo(i,k)   = q1(i,k)
+            uo(i,k)   = u1(i,k) * rcs(i)
+            vo(i,k)   = v1(i,k) * rcs(i)
+          endif
+        enddo
+      enddo
+!c
+!c  column variables
+!c  p is pressure of the layer (mb)
+!c  t is temperature at t-dt (k)..tn
+!c  q is mixing ratio at t-dt (kg/kg)..qn
+!c  to is temperature at t+dt (k)... this is after advection and turbulan
+!c  qo is mixing ratio at t+dt (kg/kg)..q1
+!c
+      do k = 1, km
+        do i=1,im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c  compute moist static energy
+!c
+      do k = 1, km
+        do i=1,im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+!           tem       = g * zo(i,k) + cp * to(i,k)
+            tem       = phil(i,k) + cp * to(i,k)
+            heo(i,k)  = tem  + hvap * qo(i,k)
+            heso(i,k) = tem  + hvap * qeso(i,k)
+!c           heo(i,k)  = min(heo(i,k),heso(i,k))
+          endif
+        enddo
+      enddo
+!c
+!c  determine level with largest moist static energy within pbl
+!c  this is the level where updraft starts
+!c
+      do i=1,im
+         if (cnvflg(i)) then
+            hmax(i) = heo(i,1)
+            kb(i) = 1
+         endif
+      enddo
+      do k = 2, km
+        do i=1,im
+          if (cnvflg(i).and.k.le.kpbl(i)) then
+            if(heo(i,k).gt.hmax(i)) then
+              kb(i)   = k
+              hmax(i) = heo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do k = 1, km1
+        do i=1,im
+          if (cnvflg(i) .and. k .le. kmax(i)-1) then
+            dz      = .5 * (zo(i,k+1) - zo(i,k))
+            dp      = .5 * (pfld(i,k+1) - pfld(i,k))
+            es      = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
+            pprime  = pfld(i,k+1) + epsm1 * es
+            qs      = eps * es / pprime
+            dqsdp   = - qs / pprime
+            desdt   = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+            dqsdt   = qs * pfld(i,k+1) * desdt / (es * pprime)
+            gamma   = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
+            dt      = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
+            dq      = dqsdt * dt + dqsdp * dp
+            to(i,k) = to(i,k+1) + dt
+            qo(i,k) = qo(i,k+1) + dq
+            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
+          endif
+        enddo
+      enddo
+!
+      do k = 1, km1
+        do i=1,im
+          if (cnvflg(i) .and. k .le. kmax(i)-1) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+            heo(i,k)  = .5 * g * (zo(i,k) + zo(i,k+1)) +                  &
+     &                  cp * to(i,k) + hvap * qo(i,k)
+            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +                  &
+     &                  cp * to(i,k) + hvap * qeso(i,k)
+            uo(i,k)   = .5 * (uo(i,k) + uo(i,k+1))
+            vo(i,k)   = .5 * (vo(i,k) + vo(i,k+1))
+          endif
+        enddo
+      enddo
+!c
+!c  look for the level of free convection as cloud base
+!c
+      do i=1,im
+        flg(i)   = cnvflg(i)
+        if(flg(i)) kbcon(i) = kmax(i)
+      enddo
+      do k = 2, km1
+        do i=1,im
+          if (flg(i).and.k.lt.kbm(i)) then
+            if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then
+              kbcon(i) = k
+              flg(i)   = .false.
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do i=1,im
+        if(cnvflg(i)) then
+          if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false.
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  determine critical convective inhibition
+!c  as a function of vertical velocity at cloud base.
+!c
+      do i=1,im
+        if(cnvflg(i)) then
+          pdot(i)  = 10.* dot(i,kbcon(i))
+        endif
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          if(slimsk(i).eq.1.) then
+            w1 = w1l
+            w2 = w2l
+            w3 = w3l
+            w4 = w4l
+          else
+            w1 = w1s
+            w2 = w2s
+            w3 = w3s
+            w4 = w4s
+          endif
+          if(pdot(i).le.w4) then
+            ptem = (pdot(i) - w4) / (w3 - w4)
+          elseif(pdot(i).ge.-w4) then
+            ptem = - (pdot(i) + w4) / (w4 - w3)
+          else
+            ptem = 0.
+          endif
+          val1    =             -1.
+          ptem = max(ptem,val1)
+          val2    =             1.
+          ptem = min(ptem,val2)
+          ptem = 1. - ptem
+          ptem1= .5*(cincrmax-cincrmin)
+          cincr = cincrmax - ptem * ptem1
+          tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i))
+          if(tem1.gt.cincr) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  assume the detrainment rate for the updrafts to be same as 
+!c  the entrainment rate at cloud base
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          xlamud(i) = xlamue(i,kbcon(i))
+        endif
+      enddo
+!c
+!c  determine updraft mass flux for the subcloud layers
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.lt.kbcon(i).and.k.ge.kb(i)) then
+              dz       = zi(i,k+1) - zi(i,k)
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i)
+              eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  compute mass flux above cloud base
+!c
+      do k = 2, km1
+        do i = 1, im
+         if(cnvflg(i))then
+           if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
+              dz       = zi(i,k) - zi(i,k-1)
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i)
+              eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
+           endif
+         endif
+        enddo
+      enddo
+!c
+!c  compute updraft cloud property
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx         = kb(i)
+          hcko(i,indx) = heo(i,indx)
+          ucko(i,indx) = uo(i,indx)
+          vcko(i,indx) = vo(i,indx)
+        endif
+      enddo
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.kmax(i)) then
+              dz   = zi(i,k) - zi(i,k-1)
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              ptem = 0.5 * tem + pgcon
+              ptem1= 0.5 * tem - pgcon
+              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*                        &
+     &                     (heo(i,k)+heo(i,k-1)))/factor
+              ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k)                    &
+     &                     +ptem1*uo(i,k-1))/factor
+              vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k)                    &
+     &                     +ptem1*vo(i,k-1))/factor
+              dbyo(i,k) = hcko(i,k) - heso(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c   taking account into convection inhibition due to existence of
+!c    dry layers below cloud base
+!c
+      do i=1,im
+        flg(i) = cnvflg(i)
+        kbcon1(i) = kmax(i)
+      enddo
+      do k = 2, km1
+      do i=1,im
+        if (flg(i).and.k.lt.kbm(i)) then
+          if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
+            kbcon1(i) = k
+            flg(i)    = .false.
+          endif
+        endif
+      enddo
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false.
+        endif
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i))
+          if(tem.gt.dthk) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i = 1, im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  determine first guess cloud top as the level of zero buoyancy
+!c    limited to the level of sigma=0.7
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+        if(flg(i)) ktcon(i) = kbm(i)
+      enddo
+      do k = 2, km1
+      do i=1,im
+        if (flg(i).and.k .lt. kbm(i)) then
+          if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then
+             ktcon(i) = k
+             flg(i)   = .false.
+          endif
+        endif
+      enddo
+      enddo
+!c
+!c  turn off shallow convection if cloud top is less than pbl top
+!c
+     do i=1,im
+       if(cnvflg(i)) then
+         kk = kpbl(i)+1
+         if(ktcon(i).le.kk) cnvflg(i) = .false.
+       endif
+     enddo
+! c
+! c  turn off shallow convection if cloud depth is less than
+! c    a threshold value (cthk)
+! c
+       do i = 1, im
+         if(cnvflg(i)) then
+           tem = pfld(i,kbcon(i))-pfld(i,ktcon(i))
+           if(tem.lt.cthk) cnvflg(i) = .false.
+         endif
+       enddo
+!!
+     totflg = .true.
+     do i = 1, im
+       totflg = totflg .and. (.not. cnvflg(i))
+     enddo
+     if(totflg) return
+!!
+!c
+!c  specify upper limit of mass flux at cloud base
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+!         xmbmax(i) = .1
+!
+          k = kbcon(i)
+          dp = 1000. * del(i,k)
+          xmbmax(i) = dp / (g * dt2)
+!
+!         tem = dp / (g * dt2)
+!         xmbmax(i) = min(tem, xmbmax(i))
+        endif
+      enddo
+!c
+!c  compute cloud moisture property and precipitation
+!c
+      do i = 1, im
+        if (cnvflg(i)) then
+          aa1(i) = 0.
+          qcko(i,kb(i)) = qo(i,kb(i))
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                                      &
+     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*           &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+!cj
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!c
+!             rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k)
+!c
+!c  below lfc check if there is excess moisture to release latent heat
+!c
+              if(k.ge.kbcon(i).and.dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0.) then
+                  dp = 1000. * del(i,k)
+                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0 * dz)
+                endif
+                aa1(i) = aa1(i) - dz * g * qlk
+                qcko(i,k)= qlk + qrch
+                pwo(i,k) = etah * c0 * dz * qlk
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  calculate cloud work function
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma                 &
+     &                 * to(i,k) / hvap
+              aa1(i) = aa1(i) +                                &
+     &                 dz1 * (g / (cp * to(i,k)))              &
+     &                 * dbyo(i,k) / (1. + gamma)              &
+     &                 * rfact
+              val = 0.
+              aa1(i)=aa1(i)+                                   &
+     &                 dz1 * g * delta *                       &
+     &                 max(val,(qeso(i,k) - qo(i,k)))
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  estimate the onvective overshooting as the level
+!c    where the [aafac * cloud work function] becomes zero,
+!c    which is the final cloud top
+!c    limited to the level of sigma=0.7
+!c
+      do i = 1, im
+        if (cnvflg(i)) then
+          aa1(i) = aafac * aa1(i)
+        endif
+      enddo
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+        ktcon1(i) = kbm(i)
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (flg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.kbm(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma                            &
+     &                 * to(i,k) / hvap
+              aa1(i) = aa1(i) +                                           &
+     &                 dz1 * (g / (cp * to(i,k)))                         &
+     &                 * dbyo(i,k) / (1. + gamma)                         &
+     &                 * rfact
+              if(aa1(i).lt.0.) then
+                ktcon1(i) = k
+                flg(i) = .false.
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  compute cloud moisture property, detraining cloud water
+!c    and precipitation in overshooting layers
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                                            &
+     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                  &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+!cj
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+              if(dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0.) then
+                  dp = 1000. * del(i,k)
+                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0 * dz)
+                endif
+                qcko(i,k) = qlk + qrch
+                pwo(i,k) = etah * c0 * dz * qlk
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c exchange ktcon with ktcon1
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          kk = ktcon(i)
+          ktcon(i) = ktcon1(i)
+          ktcon1(i) = kk
+        endif
+      enddo
+!c
+!c  this section is ready for cloud water
+!c
+      if(ncloud.gt.0) then
+!c
+!c  compute liquid and vapor separation at cloud top
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          k = ktcon(i) - 1
+          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+          qrch = qeso(i,k)                                             &
+     &         + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+          dq = qcko(i,k) - qrch
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+          if(dq.gt.0.) then
+            qlko_ktcon(i) = dq
+            qcko(i,k) = qrch
+          endif
+        endif
+      enddo
+      endif
+!!c
+!c--- compute precipitation efficiency in terms of windshear
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          vshear(i) = 0.
+        endif
+      enddo
+      do k = 2, km
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2                       &
+     &                  + (vo(i,k)-vo(i,k-1)) ** 2)
+              vshear(i) = vshear(i) + shear
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
+          e1=1.591-.639*vshear(i)                                               &
+     &       +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
+          edt(i)=1.-e1
+          val =         .9
+          edt(i) = min(edt(i),val)
+          val =         .0
+          edt(i) = max(edt(i),val)
+        endif
+      enddo
+!c
+!c--- what would the change be, that a cloud with unit mass
+!c--- will do to the environment?
+!c
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)) then
+            dellah(i,k) = 0.
+            dellaq(i,k) = 0.
+            dellau(i,k) = 0.
+            dellav(i,k) = 0.
+          endif
+        enddo
+      enddo
+!c
+!c--- changed due to subsidence and entrainment
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dp = 1000. * del(i,k)
+              dz = zi(i,k) - zi(i,k-1)
+!c
+              dv1h = heo(i,k)
+              dv2h = .5 * (heo(i,k) + heo(i,k-1))
+              dv3h = heo(i,k-1)
+              dv1q = qo(i,k)
+              dv2q = .5 * (qo(i,k) + qo(i,k-1))
+              dv3q = qo(i,k-1)
+              dv1u = uo(i,k)
+              dv2u = .5 * (uo(i,k) + uo(i,k-1))
+              dv3u = uo(i,k-1)
+              dv1v = vo(i,k)
+              dv2v = .5 * (vo(i,k) + vo(i,k-1))
+              dv3v = vo(i,k-1)
+!c
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1))
+              tem1 = xlamud(i)
+!cj
+              dellah(i,k) = dellah(i,k) +                        &
+     &     ( eta(i,k)*dv1h - eta(i,k-1)*dv3h                     &
+     &    -  tem*eta(i,k-1)*dv2h*dz                              &
+     &    +  tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz       &
+     &         ) *g/dp
+!cj
+              dellaq(i,k) = dellaq(i,k) +                        &
+     &     ( eta(i,k)*dv1q - eta(i,k-1)*dv3q                     &
+     &    -  tem*eta(i,k-1)*dv2q*dz                              &
+     &    +  tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz       &
+     &         ) *g/dp
+!cj
+              dellau(i,k) = dellau(i,k) +                        &
+     &     ( eta(i,k)*dv1u - eta(i,k-1)*dv3u                     &
+     &    -  tem*eta(i,k-1)*dv2u*dz                              &
+     &    +  tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz       &
+     &    -  pgcon*eta(i,k-1)*(dv1u-dv3u)                        &
+     &         ) *g/dp
+!cj
+              dellav(i,k) = dellav(i,k) +                        &
+     &     ( eta(i,k)*dv1v - eta(i,k-1)*dv3v                     &
+     &    -  tem*eta(i,k-1)*dv2v*dz                              &
+     &    +  tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz       &
+     &    -  pgcon*eta(i,k-1)*(dv1v-dv3v)                        &
+     &         ) *g/dp
+!cj
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c------- cloud top
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx = ktcon(i)
+          dp = 1000. * del(i,indx)
+          dv1h = heo(i,indx-1)
+          dellah(i,indx) = eta(i,indx-1) *                      &
+     &                     (hcko(i,indx-1) - dv1h) * g / dp
+          dv1q = qo(i,indx-1)
+          dellaq(i,indx) = eta(i,indx-1) *                      &
+     &                     (qcko(i,indx-1) - dv1q) * g / dp
+          dv1u = uo(i,indx-1)
+          dellau(i,indx) = eta(i,indx-1) *                      &
+     &                     (ucko(i,indx-1) - dv1u) * g / dp
+          dv1v = vo(i,indx-1)
+          dellav(i,indx) = eta(i,indx-1) *                      &
+     &                     (vcko(i,indx-1) - dv1v) * g / dp
+!c
+!c  cloud water
+!c
+          dellal(i,indx) = eta(i,indx-1) *                      &
+     &                     qlko_ktcon(i) * g / dp
+        endif
+      enddo
+!c
+!c  mass flux at cloud base for shallow convection
+!c  (Grant, 2001)
+!c
+      do i= 1, im
+        if(cnvflg(i)) then
+          k = kbcon(i)
+!         ptem = g*sflx(i)*zi(i,k)/t1(i,1)
+          ptem = g*sflx(i)*hpbl(i)/t1(i,1)
+          wstar(i) = ptem**h1
+          tem = po(i,k)*100. / (rd*t1(i,k))
+          xmb(i) = betaw*tem*wstar(i)
+          xmb(i) = min(xmb(i),xmbmax(i))
+        endif
+      enddo
+!c
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
+            val     =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val )
+          endif
+        enddo
+      enddo
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+      do i = 1, im
+        delhbar(i) = 0.
+        delqbar(i) = 0.
+        deltbar(i) = 0.
+        delubar(i) = 0.
+        delvbar(i) = 0.
+        qcond(i) = 0.
+      enddo
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp
+              t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2
+              q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2
+              tem = 1./rcs(i)
+              u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem
+              v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem
+              dp = 1000. * del(i,k)
+              delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g
+              delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g
+              deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g
+              delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g
+              delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g
+            endif
+          endif
+        enddo
+      enddo
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
+              qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k))
+              val     =             1.e-8
+              qeso(i,k) = max(qeso(i,k), val )
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do i = 1, im
+        rntot(i) = 0.
+        delqev(i) = 0.
+        delq2(i) = 0.
+        flg(i) = cnvflg(i)
+      enddo
+      do k = km, 1, -1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.lt.ktcon(i).and.k.gt.kb(i)) then
+              rntot(i) = rntot(i) + pwo(i,k) * xmb(i) * .001 * dt2
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c evaporating rain
+!c
+      do k = km, 1, -1
+        do i = 1, im
+          if (k .le. kmax(i)) then
+            deltv(i) = 0.
+            delq(i) = 0.
+            qevap(i) = 0.
+            if(cnvflg(i)) then
+              if(k.lt.ktcon(i).and.k.gt.kb(i)) then
+                rn(i) = rn(i) + pwo(i,k) * xmb(i) * .001 * dt2
+              endif
+            endif
+            if(flg(i).and.k.lt.ktcon(i)) then
+              evef = edt(i) * evfact
+              if(slimsk(i).eq.1.) evef=edt(i) * evfactl
+!             if(slimsk(i).eq.1.) evef=.07
+!c             if(slimsk(i).ne.1.) evef = 0.
+              qcond(i) = evef * (q1(i,k) - qeso(i,k))                            &
+     &                 / (1. + el2orc * qeso(i,k) / t1(i,k)**2)
+              dp = 1000. * del(i,k)
+              if(rn(i).gt.0..and.qcond(i).lt.0.) then
+                qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i))))
+                qevap(i) = min(qevap(i), rn(i)*1000.*g/dp)
+                delq2(i) = delqev(i) + .001 * qevap(i) * dp / g
+              endif
+              if(rn(i).gt.0..and.qcond(i).lt.0..and.                            &
+     &           delq2(i).gt.rntot(i)) then
+                qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp
+                flg(i) = .false.
+              endif
+              if(rn(i).gt.0..and.qevap(i).gt.0.) then
+                tem  = .001 * dp / g
+                tem1 = qevap(i) * tem
+                if(tem1.gt.rn(i)) then
+                  qevap(i) = rn(i) / tem
+                  rn(i) = 0.
+                else
+                  rn(i) = rn(i) - tem1
+                endif
+                q1(i,k) = q1(i,k) + qevap(i)
+                t1(i,k) = t1(i,k) - elocp * qevap(i)
+                deltv(i) = - elocp*qevap(i)/dt2
+                delq(i) =  + qevap(i)/dt2
+                delqev(i) = delqev(i) + .001*dp*qevap(i)/g
+              endif
+              dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i)
+              delqbar(i) = delqbar(i) + delq(i)*dp/g
+              deltbar(i) = deltbar(i) + deltv(i)*dp/g
+            endif
+          endif
+        enddo
+      enddo
+!cj
+!     do i = 1, im
+!     if(me.eq.31.and.cnvflg(i)) then
+!     if(cnvflg(i)) then
+!       print *, ' shallow delhbar, delqbar, deltbar = ',
+!    &             delhbar(i),hvap*delqbar(i),cp*deltbar(i)
+!       print *, ' shallow delubar, delvbar = ',delubar(i),delvbar(i)
+!       print *, ' precip =', hvap*rn(i)*1000./dt2
+!       print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i))
+!     endif
+!     enddo
+!cj
+      do i = 1, im
+        if(cnvflg(i)) then
+          if(rn(i).lt.0..or..not.flg(i)) rn(i) = 0.
+          ktop(i) = ktcon(i)
+          kbot(i) = kbcon(i)
+          kcnv(i) = 0
+        endif
+      enddo
+!c
+!c  cloud water
+!c
+      if (ncloud.gt.0) then
+!
+      val1 = 1.0
+      val2 = 0.
+      do k = 1, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if (k.gt.kb(i).and.k.le.ktcon(i)) then
+              tem  = dellal(i,k) * xmb(i) * dt2
+!             tem1 = max(0.0,  min(1.0,  (tcr-t1(i,k))*tcrf))
+              tem1 = max(val2, min(val1, (tcr-t1(i,k))*tcrf))
+              if (ql(i,k,2) .gt. -999.0) then
+                ql(i,k,1) = ql(i,k,1) + tem * tem1            ! ice
+                ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1)       ! water
+              else
+                ql(i,k,1) = ql(i,k,1) + tem
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+      endif
+!
+! hchuang code change
+!
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i)) then
+            if(k.ge.kb(i) .and. k.lt.ktop(i)) then
+              ud_mf(i,k) = eta(i,k) * xmb(i) * dt2
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+           k = ktop(i)-1
+           dt_mf(i,k) = ud_mf(i,k)
+        endif
+      enddo
+!!
+      return
+    end subroutine shalcnv
+
+      subroutine sascnvn_h(im,ix,km,jcap,delt,del,prsl,ps,phil,ql, &
+     &     q1,t1,u1,v1,rcs,cldwrk,rn,kbot,ktop,kcnv,slimsk,        &
+     &     dot,ncloud,pgcon,sas_mass_flux)
+!     &     dot,ncloud,pgcon,sas_mass_flux,sigma,jqfliu)
+!     &     dot,ncloud,sigma,pgcon,sas_mass_flux)
+!    &     dot,ncloud,ud_mf,dd_mf,dt_mf,me)
+!
+! Version 20120809
+!  Modified on 20120803 to add dbyod, include definition of heotd to jmin level, and fix bug
+!   on the calculation of qotd
+!  Modified on 20120807 to fix bug in the dhdt calculation
+!
+!  Adding in consistency with the pwo, pwdo so rain is consistent with heating and drying
+!  after the tilda terms are computed.
+!
+!  20120822
+!   Turns off SAS when sigma is greater than .9
+!   Correct cloud top cloud water detrainment
+!
+!      use machine , only : kind_phys
+!      use funcphys , only : fpvs
+!      use physcons, grav => con_g, cp => con_cp, hvap => con_hvap  &
+      USE MODULE_GFS_MACHINE, ONLY : kind_phys
+      USE MODULE_GFS_FUNCPHYS, ONLY : fpvs
+      USE MODULE_GFS_PHYSCONS, grav => con_g, cp => con_cp         &
+     &,             hvap => con_hvap                               &
+     &,             rv => con_rv, fv => con_fvirt, t0c => con_t0c  &
+     &,             cvap => con_cvap, cliq => con_cliq             &
+     &,             eps => con_eps, epsm1 => con_epsm1             &
+     &,             rd => con_rd
+      implicit none
+!
+      integer            im, ix,  km, jcap, ncloud,                &
+     &                   kbot(im), ktop(im), kcnv(im),jqfliu
+!    &,                  me
+      real(kind=kind_phys) delt, sas_mass_flux
+      real(kind=kind_phys) ps(im),     del(ix,km),  prsl(ix,km),   &
+     &                     ql(ix,km,2),q1(ix,km),   t1(ix,km),     &
+     &                     u1(ix,km),  v1(ix,km),   rcs(im),       &
+     &                     cldwrk(im), rn(im),      slimsk(im),    &
+     &                     dot(ix,km), phil(ix,km)                 &
+! hchuang code change mass flux output
+     &,                    ud_mf(im,km),dd_mf(im,km),dt_mf(im,km)
+!
+      integer              i, j, indx, jmn, k, kk, latd, lond, km1
+!
+      real(kind=kind_phys) clam, cxlamu, xlamde, xlamdd
+!
+      real(kind=kind_phys) adw,     aup,     aafac,                &
+     &                     beta,    betal,   betas,                &
+     &                     c0,      cpoel,   dellat,  delta,       &
+     &                     desdt,   deta,    detad,   dg,          &
+     &                     dh,      dhh,     dlnsig,  dp,          &
+     &                     dq,      dqsdp,   dqsdt,   dt,          &
+     &                     dt2,     dtmax,   dtmin,   dv1h,        &
+     &                     dv1q,    dv2h,    dv2q,    dv1u,        &
+     &                     dv1v,    dv2u,    dv2v,    dv3q,        &
+     &                     dv3h,    dv3u,    dv3v,                 &
+     &                     dv1hd,   dv1qd,   dv2hd,   dv2qd,       &
+     &                     dv1ud,   dv1vd,   dv2ud,   dv2vd,       &
+     &                     dv3hd,   dv3qd,   dv3ud,   dv3vd,       &
+     &                     dz,      dz1,     e1,      edtmax,      &
+     &                     edtmaxl, edtmaxs, el2orc,  elocp,       &
+     &                     es,      etah,    cthk,    dthk,        &
+     &                     evef,    evfact,  evfactl, fact1,       &
+     &                     fact2,   factor,  fjcap,   fkm,         &
+     &                     g,       gamma,   pprime,               &
+     &                     qlk,     qrch,    qs,      c1,          &
+     &                     rain,    rfact,   shear,   tem1,        &
+     &                     tem2,    terr,    val,     val1,        &
+     &                     val2,    w1,      w1l,     w1s,         &
+     &                     w2,      w2l,     w2s,     w3,          &
+     &                     w3l,     w3s,     w4,      w4l,         &
+     &                     w4s,     xdby,    xpw,     xpwd,        &
+     &                     xqrch,   armb,    ardt,    mbdt,        &
+     &                     delhz,   delqz,   deluz,   delvz,       &
+     &                     tem,     ptem,    ptem1
+!
+      real(kind=kind_phys), intent(in) :: pgcon
+!
+      integer              kb(im), kbcon(im), kbcon1(im),          &
+     &                     ktcon(im), ktcon1(im),                  &
+     &                     jmin(im), lmin(im), kbmax(im),          &
+     &                     kbm(im), kmax(im)
+!
+      real(kind=kind_phys) aa1(im),     acrt(im),   acrtfct(im),   &
+     &                     delhbar(im), delq(im),   delq2(im),     &
+     &                     delqbar(im), delqev(im), deltbar(im),   &
+     &                     deltv(im),   dtconv(im), edt(im),       &
+     &                     edto(im),    edtx(im),   fld(im),       &
+     &                     hcdo(im,km), hmax(im),   hmin(im),      &
+     &                     ucdo(im,km), vcdo(im,km),aa2(im),       &
+     &                     pbcdif(im),  pdot(im),   po(im,km),     &
+     &                     pwavo(im),   pwevo(im),  xlamud(im),    &
+     &                     qcdo(im,km), qcond(im),  qevap(im),     &
+     &                     rntot(im),   vshear(im), xaa0(im),      &
+     &                     xk(im),      xlamd(im),                 &
+     &                     xmb(im),     xmbmax(im), xpwav(im),     &
+     &                     xpwev(im),   delubar(im),delvbar(im)
+!cj
+      real(kind=kind_phys) cincr, cincrmax, cincrmin
+!cj
+!c  physical parameters
+      parameter(g=grav)
+      parameter(cpoel=cp/hvap,elocp=hvap/cp,                       &
+     &          el2orc=hvap*hvap/(rv*cp))
+      parameter(terr=0.,c0=.002,c1=.002,delta=fv)
+      parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c)
+      parameter(cthk=150.,cincrmax=180.,cincrmin=120.,dthk=25.)
+! Qingfu modified
+!      parameter(cthk=150.,cincrmax=160.,cincrmin=100.,dthk=25.)
+!c  local variables and arrays
+      real(kind=kind_phys) pfld(im,km),to(im,km), qo(im,km),       &
+     &                     uo(im,km),  vo(im,km), qeso(im,km)
+!c  cloud water
+      real(kind=kind_phys)qlko_ktcon(im),dellal(im,km),tvo(im,km), &
+     &                dbyo(im,km),  zo(im,km),     xlamue(im,km),  &
+     &                fent1(im,km), fent2(im,km),  frh(im,km),     &
+     &                heo(im,km),   heso(im,km),   doto(im,km-1),  &
+!c  heotu and qeotu are the environmental mean h and q for updraft
+!c  heotd and qeotd are the environmental mean h and q for downdraft
+     &                heotu(im,km), qotu(im,km),   uotu(im,km),    &
+     &                votu(im,km),  heotd(im,km),  qotd(im,km),    &
+     &                uotd(im,km),  votd(im,km),                   &
+     &                delhx(im,km), delqx(im,km),                  &
+     &                delux(im,km), delvx(im,km),                  &
+     &                qrcd(im,km),  dellah(im,km), dellaq(im,km),  &
+     &                dellau(im,km),dellav(im,km), hcko(im,km),    &
+     &                ucko(im,km),  vcko(im,km),   qcko(im,km),    &
+     &                eta(im,km),   etad(im,km),   zi(im,km),      &
+     &                qrcdo(im,km), pwo(im,km),    pwdo(im,km),    &
+     &                wc(im),       wbar(im),                      &
+     &                sigma(im),    sigi1(im),     sigi2(im),      &
+     &                tx1(im),      sumx(im),      dbyod(im,km)
+!    &,               rhbar(im)
+!
+      logical totflg, cnvflg(im), cnvdflg(im), flg(im)
+!
+      real(kind=kind_phys) pcrit(15), acritt(15), acrit(15)
+!     save pcrit, acritt
+      data pcrit/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,  &
+     &           350.,300.,250.,200.,150./
+      data acritt/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216,    &
+     &           .3151,.3677,.41,.5255,.7663,1.1686,1.6851/
+!c  gdas derived acrit
+!c     data acritt/.203,.515,.521,.566,.625,.665,.659,.688,
+!c    &            .743,.813,.886,.947,1.138,1.377,1.896/
+      real(kind=kind_phys) tf, tcr, tcrf
+      parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf))
+
+      real    sigma_sum
+!
+!c-----------------------------------------------------------------------
+!
+      km1 = km - 1
+!c
+!c  initialize arrays
+!c
+      do i=1,im
+        kcnv(i)=0
+        cnvflg(i) = .true.
+        rn(i)=0.
+        kbot(i)=km+1
+        ktop(i)=0
+        kbcon(i)=km
+        ktcon(i)=1
+        dtconv(i) = 3600.
+        cldwrk(i) = 0.
+        pdot(i) = 0.
+        pbcdif(i)= 0.
+        lmin(i) = 1
+        jmin(i) = 1
+        qlko_ktcon(i) = 0.
+        edt(i)  = 0.
+        edto(i) = 0.
+        edtx(i) = 0.
+        acrt(i) = 0.
+        acrtfct(i) = 1.
+        aa1(i)  = 0.
+        aa2(i)  = 0.
+        xaa0(i) = 0.
+        pwavo(i)= 0.
+        pwevo(i)= 0.
+        xpwav(i)= 0.
+        xpwev(i)= 0.
+        vshear(i) = 0.
+        wc(i) = 0.
+        wbar(i) = 0.
+        xmb(i) = 0.
+      enddo
+! hchuang code change
+      do k = 1, km
+        do i = 1, im
+          ud_mf(i,k) = 0.
+          dd_mf(i,k) = 0.
+          dt_mf(i,k) = 0.
+        enddo
+      enddo
+!c
+      do k = 1, 15
+        acrit(k) = acritt(k) * (975. - pcrit(k))
+      enddo
+      dt2 = delt
+      val   =         1200.
+      dtmin = max(dt2, val )
+      val   =         3600.
+      dtmax = max(dt2, val )
+!c  model tunable parameters are all here
+!      mbdt    = 10.
+      armb    = 1.             ! arbitrary cloud base mass flux
+      ardt    = 10.            ! arbitrary time step
+      mbdt    = armb * ardt
+      mbdt    = min(mbdt, dt2)
+      edtmaxl = .3
+      edtmaxs = .3
+      clam    = .1
+      aafac   = .1
+!     betal   = .15
+!     betas   = .15
+      betal   = .05
+      betas   = .05
+!c     evef    = 0.07
+      evfact  = 0.3
+      evfactl = 0.3
+!
+      cxlamu  = 1.0e-4
+      xlamde  = 1.0e-4
+      xlamdd  = 1.0e-4
+!
+      fjcap   = (float(jcap) / 126.) ** 2
+      val     =           1.
+      fjcap   = max(fjcap,val)
+      fkm     = (float(km) / 28.) ** 2
+      fkm     = max(fkm,val)
+      w1l     = -8.e-3
+      w2l     = -4.e-2
+      w3l     = -5.e-3
+      w4l     = -5.e-4
+      w1s     = -2.e-4
+      w2s     = -2.e-3
+      w3s     = -1.e-3
+      w4s     = -2.e-5
+!c
+!c  define top layer for search of the downdraft originating layer
+!c  and the maximum thetae for updraft
+!c
+      do i=1,im
+        kbmax(i) = km
+        kbm(i)   = km
+        kmax(i)  = km
+        tx1(i)   = 1.0 / ps(i)
+      enddo
+!
+      do k = 1, km1
+        do i=1,im
+          if (prsl(i,k)*tx1(i) .gt. 0.04) kmax(i)  = k + 1
+          if (prsl(i,k)*tx1(i) .gt. 0.45) kbmax(i) = k + 1
+          if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i)   = k + 1
+        enddo
+      enddo
+      do i=1,im
+        kbmax(i) = min(kbmax(i),kmax(i))
+        kbm(i)   = min(kbm(i),kmax(i))
+        kmax(i) = min(km,kmax(i))
+      enddo
+!c
+!c  hydrostatic height assume zero terr and initially assume
+!c    updraft entrainment rate as an inverse function of height
+!c
+      do k = 1, km
+        do i=1,im
+          zo(i,k) = phil(i,k) / g
+        enddo
+      enddo
+      do k = 1, km1
+        do i=1,im
+          zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1))
+          xlamue(i,k) = clam / zi(i,k)
+        enddo
+      enddo
+!c
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c   convert surface pressure to mb from cb
+!c
+      do k = 1, km
+        do i = 1, im
+          if (k .le. kmax(i)) then
+            pfld(i,k) = prsl(i,k) * 10.0
+            eta(i,k)  = 1.
+            fent1(i,k)= 1.
+            fent2(i,k)= 1.
+            frh(i,k)  = 0.
+            hcko(i,k) = 0.
+            qcko(i,k) = 0.
+            ucko(i,k) = 0.
+            vcko(i,k) = 0.
+            etad(i,k) = 1.
+            hcdo(i,k) = 0.
+            qcdo(i,k) = 0.
+            ucdo(i,k) = 0.
+            vcdo(i,k) = 0.
+            qrcd(i,k) = 0.
+            qrcdo(i,k)= 0.
+            dbyo(i,k) = 0.
+            dbyod(i,k) = 0.
+            pwo(i,k)  = 0.
+            pwdo(i,k) = 0.
+            dellal(i,k) = 0.
+            to(i,k)   = t1(i,k)
+            qo(i,k)   = q1(i,k)
+            uo(i,k)   = u1(i,k) * rcs(i)
+            vo(i,k)   = v1(i,k) * rcs(i)
+            delhx(i,k) = 0.
+            delqx(i,k) = 0.
+            delux(i,k) = 0.
+            delvx(i,k) = 0.
+          endif
+        enddo
+      enddo
+!c
+!c  column variables
+!c  p is pressure of the layer (mb)
+!c  t is temperature at t-dt (k)..tn
+!c  q is mixing ratio at t-dt (kg/kg)..qn
+!c  to is temperature at t+dt (k)... this is after advection and turbulan
+!c  qo is mixing ratio at t+dt (kg/kg)..q1
+!c
+      do k = 1, km
+        do i=1,im
+          if (k .le. kmax(i)) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c  compute moist static energy
+!c
+      do k = 1, km
+        do i=1,im
+          if (k .le. kmax(i)) then
+!           tem       = g * zo(i,k) + cp * to(i,k)
+            tem       = phil(i,k) + cp * to(i,k)
+            heo(i,k)  = tem  + hvap * qo(i,k)
+            heso(i,k) = tem  + hvap * qeso(i,k)
+!c           heo(i,k)  = min(heo(i,k),heso(i,k))
+          endif
+        enddo
+      enddo
+!c
+!c  determine level with largest moist static energy
+!c  this is the level where updraft starts
+!c
+      do i=1,im
+        hmax(i) = heo(i,1)
+        kb(i)   = 1
+      enddo
+      do k = 2, km
+        do i=1,im
+          if (k .le. kbm(i)) then
+            if(heo(i,k).gt.hmax(i)) then
+              kb(i)   = k
+              hmax(i) = heo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do k = 1, km1
+        do i=1,im
+          if (k .le. kmax(i)-1) then
+            dz      = .5 * (zo(i,k+1) - zo(i,k))
+            dp      = .5 * (pfld(i,k+1) - pfld(i,k))
+            es      = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
+            pprime  = pfld(i,k+1) + epsm1 * es
+            qs      = eps * es / pprime
+            dqsdp   = - qs / pprime
+            desdt   = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+            dqsdt   = qs * pfld(i,k+1) * desdt / (es * pprime)
+            gamma   = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
+            dt      = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
+            dq      = dqsdt * dt + dqsdp * dp
+            to(i,k) = to(i,k+1) + dt
+            qo(i,k) = qo(i,k+1) + dq
+            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
+          endif
+        enddo
+      enddo
+!
+      do k = 1, km1
+        do i=1,im
+          if (k .le. kmax(i)-1) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+            val1      = 1.
+            frh(i,k)  = 1. - min(qo(i,k)/qeso(i,k), val1)
+            heo(i,k)  = .5 * g * (zo(i,k) + zo(i,k+1)) +            &
+     &                  cp * to(i,k) + hvap * qo(i,k)
+            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +            &
+     &                  cp * to(i,k) + hvap * qeso(i,k)
+            uo(i,k)   = .5 * (uo(i,k) + uo(i,k+1))
+            vo(i,k)   = .5 * (vo(i,k) + vo(i,k+1))
+            doto(i,k) = 1000. * dot(i,k+1)          ! pa/s
+          endif
+        enddo
+      enddo
+!c
+!c  initialize environmental property as grid mean value
+!c
+      do k = 1, km
+        do i=1,im
+          if (k .le. kmax(i)) then
+            heotu(i,k) = heo(i,k)
+            qotu(i,k) = qo(i,k)
+            uotu(i,k) = uo(i,k)
+            votu(i,k) = vo(i,k)
+            heotd(i,k) = heo(i,k)
+            qotd(i,k) = qo(i,k)
+            uotd(i,k) = uo(i,k)
+            votd(i,k) = vo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c  look for the level of free convection as cloud base
+!c
+      do i=1,im
+        flg(i)   = .true.
+        kbcon(i) = kmax(i)
+      enddo
+      do k = 1, km1
+        do i=1,im
+          if (flg(i).and.k.le.kbmax(i)) then
+            if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then
+              kbcon(i) = k
+              flg(i)   = .false.
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do i=1,im
+        if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false.
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  determine critical convective inhibition
+!c  as a function of vertical velocity at cloud base.
+!c
+      do i=1,im
+        if(cnvflg(i)) then
+          pdot(i)  = 10.* dot(i,kbcon(i))
+        endif
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          if(slimsk(i).eq.1.) then
+            w1 = w1l
+            w2 = w2l
+            w3 = w3l
+            w4 = w4l
+          else
+            w1 = w1s
+            w2 = w2s
+            w3 = w3s
+            w4 = w4s
+          endif
+          if(pdot(i).le.w4) then
+            tem = (pdot(i) - w4) / (w3 - w4)
+          elseif(pdot(i).ge.-w4) then
+            tem = - (pdot(i) + w4) / (w4 - w3)
+          else
+            tem = 0.
+          endif
+          val1    =             -1.
+          tem = max(tem,val1)
+          val2    =             1.
+          tem = min(tem,val2)
+          tem = 1. - tem
+          tem1= .5*(cincrmax-cincrmin)
+          cincr = cincrmax - tem * tem1
+          pbcdif(i) = pfld(i,kb(i)) - pfld(i,kbcon(i))
+          if(pbcdif(i).gt.cincr) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  assume that updraft entrainment rate above cloud base is
+!c    same as that at cloud base
+!c
+      do k = 2, km1
+        do i=1,im
+          if(cnvflg(i).and.                                 &
+     &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
+              xlamue(i,k) = xlamue(i,kbcon(i))
+          endif
+        enddo
+      enddo
+!c
+!c  assume the detrainment rate for the updrafts to be same as
+!c  the entrainment rate at cloud base
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          xlamud(i) = xlamue(i,kbcon(i))
+        endif
+      enddo
+!c
+!c  functions rapidly decreasing with height, mimicking a cloud ensemble
+!c    (Bechtold et al., 2008)
+!c
+      val1=1.0
+      do k = 2, km1
+        do i=1,im
+          if(cnvflg(i).and.                                &
+     &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
+!              tem = qeso(i,k)/qeso(i,kbcon(i))
+              tem = min(val1,qeso(i,k)/qeso(i,kbcon(i)))
+              fent1(i,k) = tem**2
+              fent2(i,k) = tem**3
+          endif
+        enddo
+      enddo
+!c
+!c  final entrainment rate as the sum of turbulent part and organized entrainment
+!c    depending on the environmental relative humidity
+!c    (Bechtold et al., 2008)
+!c
+      do k = 2, km1
+        do i=1,im
+          if(cnvflg(i).and.                                &
+     &      (k.ge.kbcon(i).and.k.lt.kmax(i))) then
+              tem = cxlamu * frh(i,k) * fent2(i,k)
+              xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem
+          endif
+        enddo
+      enddo
+!c
+!c  determine updraft mass flux for the subcloud layers
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.lt.kbcon(i).and.k.ge.kb(i)) then
+              dz       = zi(i,k+1) - zi(i,k)
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i)
+              eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  compute mass flux above cloud base
+!c
+      do k = 2, km1
+        do i = 1, im
+         if(cnvflg(i))then
+           if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
+              dz       = zi(i,k) - zi(i,k-1)
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i)
+              eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
+           endif
+         endif
+        enddo
+      enddo
+!c
+!c  compute updraft cloud properties
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx         = kb(i)
+          hcko(i,indx) = heo(i,indx)
+          ucko(i,indx) = uo(i,indx)
+          vcko(i,indx) = vo(i,indx)
+          pwavo(i)     = 0.
+        endif
+      enddo
+!c
+!c  cloud property is modified by the entrainment process
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.kmax(i)) then
+              dz   = zi(i,k) - zi(i,k-1)
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              ptem = 0.5 * tem + pgcon
+              ptem1= 0.5 * tem - pgcon
+              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*       &
+     &                     (heo(i,k)+heo(i,k-1)))/factor
+              ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k)   &
+     &                     +ptem1*uo(i,k-1))/factor
+              vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k)   &
+     &                     +ptem1*vo(i,k-1))/factor
+              dbyo(i,k) = hcko(i,k) - heso(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c   taking account into convection inhibition due to existence of
+!c    dry layers below cloud base
+!c
+      do i=1,im
+        flg(i) = cnvflg(i)
+        kbcon1(i) = kmax(i)
+      enddo
+      do k = 2, km1
+      do i=1,im
+        if (flg(i).and.k.lt.kmax(i)) then
+          if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
+            kbcon1(i) = k
+            flg(i)    = .false.
+          endif
+        endif
+      enddo
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false.
+        endif
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i))
+          if(tem.gt.dthk) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i = 1, im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  determine first guess cloud top as the level of zero buoyancy
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+        ktcon(i) = 1
+      enddo
+      do k = 2, km1
+      do i = 1, im
+        if (flg(i).and.k .lt. kmax(i)) then
+          if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then
+             ktcon(i) = k
+             flg(i)   = .false.
+          endif
+        endif
+      enddo
+      enddo
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          tem = pfld(i,kbcon(i))-pfld(i,ktcon(i))
+          if(tem.lt.cthk) cnvflg(i) = .false.
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i = 1, im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  search for downdraft originating level above theta-e minimum
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+           hmin(i) = heo(i,kbcon1(i))
+           lmin(i) = kbmax(i)
+           jmin(i) = kbmax(i)
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kbmax(i)) then
+            if(k.gt.kbcon1(i).and.heo(i,k).lt.hmin(i)) then
+               lmin(i) = k + 1
+               hmin(i) = heo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  make sure that jmin(i) is within the cloud
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          jmin(i) = min(lmin(i),ktcon(i)-1)
+          jmin(i) = max(jmin(i),kbcon1(i)+1)
+          if(jmin(i).ge.ktcon(i)) cnvflg(i) = .false.
+        endif
+      enddo
+!c
+!c  specify upper limit of mass flux at cloud base
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+!         xmbmax(i) = .1
+!
+          k = kbcon(i)
+          dp = 1000. * del(i,k)
+          xmbmax(i) = dp / (g * dt2)
+          xmbmax(i) = min(sas_mass_flux,xmbmax(i))
+!
+!         tem = dp / (g * dt2)
+!         xmbmax(i) = min(tem, xmbmax(i))
+        endif
+      enddo
+!c
+!c  compute cloud moisture property and precipitation
+!c
+      do i = 1, im
+        if (cnvflg(i)) then
+          aa1(i) = 0.
+          indx = kb(i)
+          qcko(i,indx) = qo(i,indx)
+          qcko(i,1) = qcko(i,indx)
+!         rhbar(i) = 0.
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                                  &
+     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*       &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+!cj
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!c
+!             rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k)
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+              if(k.ge.kbcon(i).and.dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0.and.k.gt.jmin(i)) then
+                  dp = 1000. * del(i,k)
+                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0 * dz)
+                endif
+                aa1(i) = aa1(i) - dz * g * qlk
+                qcko(i,k) = qlk + qrch
+                pwo(i,k) = etah * c0 * dz * qlk
+                pwavo(i) = pwavo(i) + pwo(i,k)
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!     do i = 1, im
+!       if(cnvflg(i)) then
+!         indx = ktcon(i) - kb(i) - 1
+!         rhbar(i) = rhbar(i) / float(indx)
+!       endif
+!     enddo
+!c
+!c  calculate cloud work function
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma                &
+     &                 * to(i,k) / hvap
+              aa1(i) = aa1(i) +                               &
+     &                 dz1 * (g / (cp * to(i,k)))             &
+     &                 * dbyo(i,k) / (1. + gamma)             &
+     &                 * rfact
+              val = 0.
+              aa1(i)=aa1(i)+                                  &
+     &                 dz1 * g * delta *                      &
+     &                 max(val,(qeso(i,k) - qo(i,k)))
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  calculate the updraft area sigma as a function of the updraft speed wc=sqrt(2*aa1 + wbar**2 (at cloud base))
+!c  and the area mean vertical wind speed wbar = -omega / (rho * g)
+!c
+!c  po is in the unit of mb and dot in the unit of cb/sec
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+              tem = po(i,k) / (rd * to(i,k) * (1. + delta * qo(i,k)))
+              tem1 = - 10. * dot(i,k) / (tem * g)
+              wbar(i) = max(wbar(i),tem1)
+            endif
+          endif
+        enddo
+      enddo
+!
+!
+!c   cloud base updraft speed is added here. For the time being, we use the same wbar as above. This guarantee that
+!c   the calculated sigma never exceeds one.
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+!          k = kbcon(i)
+!          tem = po(i,k) / (rd * to(i,k) * (1. + delta * qo(i,k)))
+!          tem1 = - 10. * dot(i,k) / (tem * g)
+!          wc(i) = sqrt(tem1*tem1+2.*aa1(i))
+          wc(i) = sqrt(wbar(i) * wbar(i) + 2. * aa1(i))
+        endif
+      enddo
+      sigma_sum=0.
+      val1=0.09
+!      val1=0.0
+      do i = 1, im
+        if(cnvflg(i).and.wc(i).gt.0.) then
+!
+!  Scale sigma assuming magnitude of w_tilda to be .1 w_c
+!
+          sigma(i) = .91 * wbar(i) / (wc(i) + 1.E-20) + .09
+!          sigma(i) = wbar(i) / (wc(i) + 1.E-20)
+          sigma(i) = max(sigma(i),val1)
+          if(sigma(i).gt.0.5.and.wbar(i).lt.10.)sigma(i)=0.5
+          if(sigma(i).gt.0.9) then
+            sigma(i)=0.9
+            cnvflg(i)=.false.
+          end if
+        endif
+        if(sigma_sum.lt.sigma(i))sigma_sum=sigma(i)
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  turn off downdraft if sigma is larger than 0.5
+!c
+      do i = 1, im
+        cnvdflg(i) = cnvflg(i)
+        if(cnvflg(i).and.sigma(i).gt.0.5) then
+          cnvdflg(i) = .false.
+        endif
+      enddo
+!c
+!c  estimate the onvective overshooting as the level
+!c    where the [aafac * cloud work function] becomes zero,
+!c    which is the final cloud top
+!c
+      do i = 1, im
+        if (cnvflg(i)) then
+          aa2(i) = aafac * aa1(i)
+        endif
+      enddo
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+        ktcon1(i) = kmax(i) - 1
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (flg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.kmax(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma           &
+     &                 * to(i,k) / hvap
+              aa2(i) = aa2(i) +                          &
+     &                 dz1 * (g / (cp * to(i,k)))        &
+     &                 * dbyo(i,k) / (1. + gamma)        &
+     &                 * rfact
+              if(aa2(i).lt.0.) then
+                ktcon1(i) = k
+                flg(i) = .false.
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  compute cloud moisture property, detraining cloud water
+!c    and precipitation in overshooting layers
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                               &
+     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*    &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+!cj
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+              if(dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0) then
+                  dp = 1000. * del(i,k)
+                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0 * dz)
+                endif
+                qcko(i,k) = qlk + qrch
+                pwo(i,k) = etah * c0 * dz * qlk
+                pwavo(i) = pwavo(i) + pwo(i,k)
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c exchange ktcon with ktcon1
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          kk = ktcon(i)
+          ktcon(i) = ktcon1(i)
+          ktcon1(i) = kk
+        endif
+      enddo
+!c
+!c  this section is ready for cloud water
+!c
+      if(ncloud.gt.0) then
+!c
+!c  compute liquid and vapor separation at cloud top
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          k = ktcon(i) - 1
+          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+          qrch = qeso(i,k)                               &
+     &         + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+          dq = qcko(i,k) - qrch
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+          if(dq.gt.0.) then
+            qlko_ktcon(i) = dq
+            qcko(i,k) = qrch
+          endif
+        endif
+      enddo
+      endif
+!c
+!ccccc if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then
+!ccccc   print *, ' aa1(i) before dwndrft =', aa1(i)
+!ccccc endif
+!c
+!c------- downdraft calculations
+!c
+!c--- compute precipitation efficiency in terms of windshear
+!c
+      do i = 1, im
+        if(cnvdflg(i)) then
+          vshear(i) = 0.
+        endif
+      enddo
+      do k = 2, km
+        do i = 1, im
+          if (cnvdflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2      &
+     &                  + (vo(i,k)-vo(i,k-1)) ** 2)
+              vshear(i) = vshear(i) + shear
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvdflg(i)) then
+          vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
+          e1=1.591-.639*vshear(i)                       &
+     &       +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
+          edt(i)=1.-e1
+          val =         .9
+          edt(i) = min(edt(i),val)
+          val =         .0
+          edt(i) = max(edt(i),val)
+          edto(i)=edt(i)
+          edtx(i)=edt(i)
+        endif
+      enddo
+!c
+!c  determine detrainment rate between 1 and kbcon
+!c
+      do i = 1, im
+        if(cnvdflg(i)) then
+          sumx(i) = 0.
+        endif
+      enddo
+      do k = 1, km1
+      do i = 1, im
+        if(cnvdflg(i).and.k.ge.1.and.k.lt.kbcon(i)) then
+          dz = zi(i,k+1) - zi(i,k)
+          sumx(i) = sumx(i) + dz
+        endif
+      enddo
+      enddo
+      do i = 1, im
+        beta = betas
+        if(slimsk(i).eq.1.) beta = betal
+        if(cnvdflg(i)) then
+          dz  = (sumx(i)+zi(i,1))/float(kbcon(i))
+          tem = 1./float(kbcon(i))
+          xlamd(i) = (1.-beta**tem)/dz
+        endif
+      enddo
+!c
+!c  determine downdraft mass flux
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvdflg(i) .and. k .le. kmax(i)-1) then
+           if(k.lt.jmin(i).and.k.ge.kbcon(i)) then
+              dz        = zi(i,k+1) - zi(i,k)
+              ptem      = xlamdd - xlamde
+              etad(i,k) = etad(i,k+1) * (1. - ptem * dz)
+           else if(k.lt.kbcon(i)) then
+              dz        = zi(i,k+1) - zi(i,k)
+              ptem      = xlamd(i) + xlamdd - xlamde
+              etad(i,k) = etad(i,k+1) * (1. - ptem * dz)
+           endif
+          endif
+        enddo
+      enddo
+!c
+!c--- downdraft moisture properties
+!c
+      do i = 1, im
+        if(cnvdflg(i)) then
+          jmn = jmin(i)
+          hcdo(i,jmn) = heo(i,jmn)
+          qcdo(i,jmn) = qo(i,jmn)
+          qrcdo(i,jmn)= qeso(i,jmn)
+          ucdo(i,jmn) = uo(i,jmn)
+          vcdo(i,jmn) = vo(i,jmn)
+          pwevo(i) = 0.
+        endif
+      enddo
+!cj
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvdflg(i) .and. k.lt.jmin(i)) then
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              ptem = 0.5 * tem - pgcon
+              ptem1= 0.5 * tem + pgcon
+              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*        &
+     &                     (heo(i,k)+heo(i,k+1)))/factor
+              ucdo(i,k) = ((1.-tem1)*ucdo(i,k+1)+ptem*uo(i,k+1)  &
+     &                     +ptem1*uo(i,k))/factor
+              vcdo(i,k) = ((1.-tem1)*vcdo(i,k+1)+ptem*vo(i,k+1)  &
+     &                     +ptem1*vo(i,k))/factor
+              dbyod(i,k) = hcdo(i,k) - heso(i,k)
+          endif
+        enddo
+      enddo
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvdflg(i).and.k.lt.jmin(i)) then
+              gamma      = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrcdo(i,k) = qeso(i,k)+                            &
+     &                (1./hvap)*(gamma/(1.+gamma))*dbyod(i,k)
+!             detad      = etad(i,k+1) - etad(i,k)
+!cj
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5*        &
+     &                     (qo(i,k)+qo(i,k+1)))/factor
+!cj
+!             pwdo(i,k)  = etad(i,k+1) * qcdo(i,k+1) -
+!    &                     etad(i,k) * qrcdo(i,k)
+!             pwdo(i,k)  = pwdo(i,k) - detad *
+!    &                    .5 * (qrcdo(i,k) + qrcdo(i,k+1))
+!cj
+              pwdo(i,k)  = etad(i,k+1) * (qcdo(i,k) - qrcdo(i,k))
+              qcdo(i,k)  = qrcdo(i,k)
+              pwevo(i)   = pwevo(i) + pwdo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c--- final downdraft strength dependent on precip
+!c--- efficiency (edt), normalized condensate (pwav), and
+!c--- evaporate (pwev)
+!c
+      do i = 1, im
+        edtmax = edtmaxl
+        if(slimsk(i).eq.0.) edtmax = edtmaxs
+        if(cnvdflg(i)) then
+          if(pwevo(i).lt.0.) then
+            edto(i) = -edto(i) * pwavo(i) / pwevo(i)
+            edto(i) = min(edto(i),edtmax)
+          else
+            edto(i) = 0.
+          endif
+        endif
+      enddo
+!c
+!c--- downdraft cloudwork functions
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvdflg(i) .and. k .lt. jmin(i)) then
+              gamma = el2orc * qeso(i,k) / to(i,k)**2
+              dhh=hcdo(i,k)
+              dt=to(i,k)
+              dg=gamma
+              dh=heso(i,k)
+              dz=-1.*(zo(i,k+1)-zo(i,k))
+              aa1(i)=aa1(i)+edto(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg))  &
+     &               *(1.+delta*cp*dg*dt/hvap)
+              val=0.
+              aa1(i)=aa1(i)+edto(i)*                                   &
+     &        dz*g*delta*max(val,(qeso(i,k)-qo(i,k)))
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvdflg(i).and.aa1(i).le.0.) then
+           cnvdflg(i) = .false.
+           cnvflg(i) = .false.
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  calculate environmental values of heo, qo, uo, and vo
+!c
+!c   updraft
+      sigma_sum=0.
+      do i = 1, im
+        if(cnvflg(i)) then
+           tem = 1. - sigma(i)
+           sigi1(i) = 1. / tem
+           sigi2(i) = sigma(i) / tem
+           if(sigma_sum.lt.sigi1(i))sigma_sum=sigi1(i)
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              heotu(i,k)=sigi1(i)*heo(i,k)-sigi2(i)*hcko(i,k)
+              qotu(i,k) =sigi1(i)*qo(i,k) -sigi2(i)*qcko(i,k)
+              uotu(i,k) =sigi1(i)*uo(i,k) -sigi2(i)*ucko(i,k)
+              votu(i,k) =sigi1(i)*vo(i,k) -sigi2(i)*vcko(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c   downdraft
+      do i = 1, im
+        if(cnvdflg(i)) then
+           tem = 1. - edto(i)*sigma(i)
+           sigi1(i) = 1. / tem
+           sigi2(i) = edto(i)*sigma(i) / tem
+        endif
+      enddo
+      do k = 1, km1
+        do i = 1, im
+          if (cnvdflg(i)) then
+!
+!   we need to define heotd at jmin level
+!
+            if(k.le.jmin(i)) then
+!            if(k.lt.jmin(i)) then
+              heotd(i,k)=sigi1(i)*heo(i,k)-sigi2(i)*hcdo(i,k)
+              qotd(i,k) =sigi1(i)*qo(i,k) -sigi2(i)*qcdo(i,k)
+              uotd(i,k) =sigi1(i)*uo(i,k) -sigi2(i)*ucdo(i,k)
+              votd(i,k) =sigi1(i)*vo(i,k) -sigi2(i)*vcdo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+
+!      GO TO 659
+! 
+! Do iteration to the cloud property using the environmental properties now
+!
+!c
+!c  compute updraft cloud properties
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx         = kb(i)
+          hcko(i,indx) = heo(i,indx)
+          ucko(i,indx) = uo(i,indx)
+          vcko(i,indx) = vo(i,indx)
+          pwavo(i)     = 0.
+        endif
+      enddo
+!c
+!c  cloud property is modified by the entrainment process
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.kmax(i)) then
+              dz   = zi(i,k) - zi(i,k-1)
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              ptem = 0.5 * tem + pgcon
+              ptem1= 0.5 * tem - pgcon
+              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*       &
+     &                     (heotu(i,k)+heotu(i,k-1)))/factor
+              ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uotu(i,k)   &
+     &                     +ptem1*uotu(i,k-1))/factor
+              vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*votu(i,k)   &
+     &                     +ptem1*votu(i,k-1))/factor
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  compute cloud moisture property and precipitation
+!c
+      do i = 1, im
+        if (cnvflg(i)) then
+          indx = kb(i)
+          qcko(i,indx) = qo(i,indx)
+          qcko(i,1) = qcko(i,indx)
+          pwavo(i) = 0.
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                                  &
+     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*       &
+     &                     (qotu(i,k)+qotu(i,k-1)))/factor
+!cj
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!c
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+              if(k.ge.kbcon(i).and.dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0.and.k.gt.jmin(i)) then
+                  dp = 1000. * del(i,k)
+                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0 * dz)
+                endif
+                qcko(i,k) = qlk + qrch
+                pwo(i,k) = etah * c0 * dz * qlk
+                pwavo(i) = pwavo(i) + pwo(i,k)
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  this section is ready for cloud water
+!c
+      if(ncloud.gt.0) then
+!c
+!c  compute liquid and vapor separation at cloud top
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          k = ktcon(i) - 1
+          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+          qrch = qeso(i,k)                               &
+     &         + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+          dq = qcko(i,k) - qrch
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+          if(dq.gt.0.) then
+            qlko_ktcon(i) = dq
+            qcko(i,k) = qrch
+          endif
+        endif
+      enddo
+      endif
+!c
+!c--- downdraft moisture properties
+!c
+      do i = 1, im
+        if(cnvdflg(i)) then
+          jmn = jmin(i)
+          hcdo(i,jmn) = heo(i,jmn)
+          qcdo(i,jmn) = qo(i,jmn)
+          qrcdo(i,jmn)= qeso(i,jmn)
+          ucdo(i,jmn) = uo(i,jmn)
+          vcdo(i,jmn) = vo(i,jmn)
+          pwevo(i) = 0.
+        endif
+      enddo
+!cj
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvdflg(i) .and. k.lt.jmin(i)) then
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              ptem = 0.5 * tem - pgcon
+              ptem1= 0.5 * tem + pgcon
+              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*        &
+     &                     (heotd(i,k)+heotd(i,k+1)))/factor
+              ucdo(i,k) = ((1.-tem1)*ucdo(i,k+1)+ptem*uotd(i,k+1)  &
+     &                     +ptem1*uotd(i,k))/factor
+              vcdo(i,k) = ((1.-tem1)*vcdo(i,k+1)+ptem*votd(i,k+1)  &
+     &                     +ptem1*votd(i,k))/factor
+          endif
+        enddo
+      enddo
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvdflg(i).and.k.lt.jmin(i)) then
+              gamma      = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrcdo(i,k) = qeso(i,k)+                            &
+     &                (1./hvap)*(gamma/(1.+gamma))*dbyod(i,k)
+!             detad      = etad(i,k+1) - etad(i,k)
+!cj
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5*        &
+     &                     (qotd(i,k)+qotd(i,k+1)))/factor
+              pwdo(i,k)  = etad(i,k+1) * (qcdo(i,k) - qrcdo(i,k))
+              qcdo(i,k)  = qrcdo(i,k)
+              pwevo(i)   = pwevo(i) + pwdo(i,k)
+          endif
+        enddo
+      enddo
+
+ 659  continue
+
+!c
+!c--- what would the change be, that a cloud with unit mass
+!c--- will do to the environment?
+!c
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)) then
+            dellah(i,k) = 0.
+            dellaq(i,k) = 0.
+            dellau(i,k) = 0.
+            dellav(i,k) = 0.
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvdflg(i)) then
+          dp = 1000. * del(i,1)
+          dellah(i,1) = edto(i) * etad(i,1) * (hcdo(i,1)          &
+     &                   - heotd(i,1)) * g / dp
+!
+          dellaq(i,1) = edto(i) * etad(i,1) * (qcdo(i,1)          &
+     &                   - qotd(i,1)) * g / dp
+!
+          dellau(i,1) = edto(i) * etad(i,1) * (ucdo(i,1)          &
+     &                   - uotd(i,1)) * g / dp
+!
+          dellav(i,1) = edto(i) * etad(i,1) * (vcdo(i,1)          &
+     &                   - votd(i,1)) * g / dp
+        endif
+      enddo
+!c
+!c--- changed due to subsidence and entrainment
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i).and.k.lt.ktcon(i)) then
+              aup = 1.
+              if(k.le.kb(i)) aup = 0.
+              adw = 1.
+              if(k.gt.jmin(i).or..not.cnvdflg(i)) adw = 0.
+              dp = 1000. * del(i,k)
+              dz = zi(i,k) - zi(i,k-1)
+!c
+              dv1h = heotu(i,k)
+              dv2h = .5 * (heotu(i,k) + heotu(i,k-1))
+              dv3h = heotu(i,k-1)
+              dv1q = qotu(i,k)
+              dv2q = .5 * (qotu(i,k) + qotu(i,k-1))
+              dv3q = qotu(i,k-1)
+              dv1u = uotu(i,k)
+              dv2u = .5 * (uotu(i,k) + uotu(i,k-1))
+              dv3u = uotu(i,k-1)
+              dv1v = votu(i,k)
+              dv2v = .5 * (votu(i,k) + votu(i,k-1))
+              dv3v = votu(i,k-1)
+!c
+              dv1hd = heotd(i,k)
+              dv2hd = .5 * (heotd(i,k) + heotd(i,k-1))
+              dv3hd = heotd(i,k-1)
+              dv1qd = qotd(i,k)
+              dv2qd = .5 * (qotd(i,k) + qotd(i,k-1))
+              dv3qd = qotd(i,k-1)
+              dv1ud = uotd(i,k)
+              dv2ud = .5 * (uotd(i,k) + uotd(i,k-1))
+              dv3ud = uotd(i,k-1)
+              dv1vd = votd(i,k)
+              dv2vd = .5 * (votd(i,k) + votd(i,k-1))
+              dv3vd = votd(i,k-1)
+!c
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1))
+              tem1 = xlamud(i)
+!c
+              if(k.le.kbcon(i)) then
+                ptem  = xlamde
+                ptem1 = xlamd(i)+xlamdd
+              else
+                ptem  = xlamde
+                ptem1 = xlamdd
+              endif
+!cj
+              dellah(i,k) = dellah(i,k) +                               &
+     &     (aup*(eta(i,k)*heotu(i,k)-eta(i,k-1)*heotu(i,k-1))           &
+     &    - adw*edto(i)*(etad(i,k)*heotd(i,k)-etad(i,k-1)*heotd(i,k-1)) &
+!     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2h*dz     &
+     &    - (aup*tem*eta(i,k-1))*dv2h*dz-(adw*edto(i)*ptem*etad(i,k))*dv2hd*dz     &
+     &    +  aup*tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz          &
+     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1))*dz  &
+     &         ) *g/dp
+
+!
+!c delhx = -(g/dp) * (rho * wbar) * del(htilda-hbar) 
+!c rho * g * wbar is replaced by -omega_bar which is doto in Pa/sec
+!c dp is in Pa
+!
+              delhx(i,k) = ( aup*(doto(i,k)*(heotu(i,k)-heo(i,k))           &
+     &                          - doto(i,k-1)*(heotu(i,k-1)-heo(i,k-1)))     &
+     &                     ) / dp
+!cj
+              dellaq(i,k) = dellaq(i,k) +                               &
+     &     (aup*(eta(i,k)*qotu(i,k)-eta(i,k-1)*qotu(i,k-1))             &
+     &    - adw*edto(i)*(etad(i,k)*qotd(i,k)-etad(i,k-1)*qotd(i,k-1))   &
+     &    - (aup*tem*eta(i,k-1))*dv2q*dz-(adw*edto(i)*ptem*etad(i,k))*dv2qd*dz     &
+     &    +  aup*tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz          &
+     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qrcdo(i,k-1))*dz  &
+     &         ) *g/dp
+!
+
+              delqx(i,k) = ( aup*(doto(i,k)*(qotu(i,k)-qo(i,k))            &
+     &                          - doto(i,k-1)*(qotu(i,k-1)-qo(i,k-1)))       &
+     &                     ) / dp
+!cj
+              dellau(i,k) = dellau(i,k) +                               &
+     &     (aup*(eta(i,k)*uotu(i,k)-eta(i,k-1)*uotu(i,k-1))             &
+     &    - adw*edto(i)*(etad(i,k)*uotd(i,k)-etad(i,k-1)*uotd(i,k-1))   &
+     &    - (aup*tem*eta(i,k-1))*dv2u*dz-(adw*edto(i)*ptem*etad(i,k))*dv2ud*dz     &
+     &    +  aup*tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz          &
+     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(ucdo(i,k)+ucdo(i,k-1))*dz  &
+     &    -  pgcon*(aup*eta(i,k-1)*(dv1u-dv3u)-adw*edto(i)*etad(i,k)*(dv1ud-dv3ud))   &
+     &         ) *g/dp
+!
+              delux(i,k) = ( aup*(doto(i,k)*(uotu(i,k)-uo(i,k))            &
+     &                          - doto(i,k-1)*(uotu(i,k-1)-uo(i,k-1)))       &
+     &                     ) / dp
+!cj
+              dellav(i,k) = dellav(i,k) +                               &
+     &     (aup*(eta(i,k)*votu(i,k)-eta(i,k-1)*votu(i,k-1))             &
+     &    - adw*edto(i)*(etad(i,k)*votd(i,k)-etad(i,k-1)*votd(i,k-1))   &
+     &    - (aup*tem*eta(i,k-1))*dv2v*dz-(adw*edto(i)*ptem*etad(i,k))*dv2vd*dz     &
+     &    +  aup*tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz          &
+     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(vcdo(i,k)+vcdo(i,k-1))*dz  &
+     &    -  pgcon*(aup*eta(i,k-1)*(dv1v-dv3v)-adw*edto(i)*etad(i,k)*(dv1vd-dv3vd))   &
+     &         ) *g/dp
+!
+
+              delvx(i,k) = ( aup*(doto(i,k)*(votu(i,k)-vo(i,k))            &
+     &                          - doto(i,k-1)*(votu(i,k-1)-vo(i,k-1)))       &
+     &                     ) / dp
+!          if(abs(delvx(i,k)).gt.1.0)print*,'qingfu test999=',        &
+!              i,k,delvx(i,k),aup,adw,doto(i,k),(votu(i,k)-vo(i,k))      &
+!              ,(votu(i,k-1)-vo(i,k-1)),dp
+
+!cj
+          endif
+        enddo
+      enddo
+!c
+!c------- cloud top
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx = ktcon(i)
+          dp = 1000. * del(i,indx)
+          dv1h = heo(i,indx-1)
+          dellah(i,indx) = eta(i,indx-1) *                              &
+     &              (hcko(i,indx-1) - heotu(i,indx-1)) * g / dp
+!          delhx(i,indx) = doto(i,indx-1)*dv1h / dp
+          delhx(i,indx) = doto(i,indx-1)*(dv1h-heotu(i,indx-1)) / dp
+!
+          dv1q = qo(i,indx-1)
+          dellaq(i,indx) = eta(i,indx-1) *                              &
+     &              (qcko(i,indx-1) - qotu(i,indx-1)) * g / dp
+!          delqx(i,indx) = doto(i,indx-1)*dv1q / dp
+          delqx(i,indx) = doto(i,indx-1)*(dv1q-qotu(i,indx-1)) / dp
+!
+          dv1u = uo(i,indx-1)
+          dellau(i,indx) = eta(i,indx-1) *                              &
+     &              (ucko(i,indx-1) - uotu(i,indx-1)) * g / dp
+!          delux(i,indx) = doto(i,indx-1)*dv1u / dp
+          delux(i,indx) = doto(i,indx-1)*(dv1u-uotu(i,indx-1)) / dp
+!
+          dv1v = vo(i,indx-1)
+          dellav(i,indx) = eta(i,indx-1) *                              &
+     &              (vcko(i,indx-1) - votu(i,indx-1)) * g / dp
+!          delvx(i,indx) = doto(i,indx-1)*dv1v / dp
+          delvx(i,indx) = doto(i,indx-1)*(dv1v-votu(i,indx-1)) / dp
+!          if(abs(delvx(i,indx)).gt.5.0)print*,'qingfu test888=',      &
+!              i,indx,delvx(i,indx),doto(i,indx-1),dv1v,votu(i,indx-1),dp
+!c
+!c  cloud water
+!c
+          dellal(i,indx) = eta(i,indx-1) *                              &
+     &                     qlko_ktcon(i) * g / dp
+        endif
+      enddo
+!c
+!c------- final changed variable per unit mass flux
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i).and.k .le. kmax(i)) then
+            if(k.gt.ktcon(i)) then
+              qo(i,k) = q1(i,k)
+              to(i,k) = t1(i,k)
+            endif
+            if(k.le.ktcon(i)) then
+!
+!c   We need to scale the w-bar contribution (delhx and delqx) by rho * wc
+!c   po is in mb but rho (tem) is now in standard unit, wc is in m/sec
+!c   tem1 is wbar in m/sec, doto is in pa/sec
+!
+              tem = po(i,k) / (rd * to(i,k) * (1. + delta * qo(i,k))) * 100.
+              tem1 = -doto(i,k) / (tem * g)
+              tem1 = tem1 / (wc(i) + 1.E-20)
+              tem1 = max(tem1,real(0.,kind=kind_phys))
+              tem1 = min(tem1,real(1.,kind=kind_phys))
+!              delqz = dellaq(i,k)* (1.-tem1) *mbdt / (1. - sigma)
+!     &              + delqx(i,k)*ardt / ((1. - sigma(i)) * tem * wc(i))
+              delqz = dellaq(i,k) * mbdt
+              qo(i,k) = q1(i,k) + delqz
+!              delhz = dellah(i,k)* (1.-tem1) *mbdt / (1. - sigma)
+!     &              + delhx(i,k)*ardt / ((1. - sigma(i)) * tem * wc(i))
+              delhz = dellah(i,k) * mbdt
+              dellat = (delhz - hvap * delqz) / cp
+              to(i,k) = t1(i,k) + dellat
+              val   =           1.e-10
+              qo(i,k) = max(qo(i,k), val  )
+            endif
+          endif
+        enddo
+      enddo
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+!c--- the above changed environment is now used to calulate the
+!c--- effect the arbitrary cloud (with unit mass flux)
+!c--- would have on the stability,
+!c--- which then is used to calculate the real mass flux,
+!c--- necessary to keep this change in balance with the large-scale
+!c--- destabilization.
+!c
+!c--- environmental conditions again, first heights
+!c
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k)+epsm1*qeso(i,k))
+            val       =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val )
+!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c--- moist static energy
+!c
+      do k = 1, km1
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)-1) then
+            dz = .5 * (zo(i,k+1) - zo(i,k))
+            dp = .5 * (pfld(i,k+1) - pfld(i,k))
+            es = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
+            pprime = pfld(i,k+1) + epsm1 * es
+            qs = eps * es / pprime
+            dqsdp = - qs / pprime
+            desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+            dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime)
+            gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
+            dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
+            dq = dqsdt * dt + dqsdp * dp
+            to(i,k) = to(i,k+1) + dt
+            qo(i,k) = qo(i,k+1) + dq
+            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
+          endif
+        enddo
+      enddo
+      do k = 1, km1
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)-1) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1 * qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+            heo(i,k)   = .5 * g * (zo(i,k) + zo(i,k+1)) +           &
+     &                    cp * to(i,k) + hvap * qo(i,k)
+            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +            &
+     &                  cp * to(i,k) + hvap * qeso(i,k)
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          k = kmax(i)
+          heo(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qo(i,k)
+          heso(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qeso(i,k)
+!c         heo(i,k) = min(heo(i,k),heso(i,k))
+        endif
+      enddo
+!c
+!c**************************** static control
+!c
+!c------- moisture and cloud work functions
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          xaa0(i) = 0.
+          xpwav(i) = 0.
+        endif
+      enddo
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx = kb(i)
+          hcko(i,indx) = heo(i,indx)
+          qcko(i,indx) = qo(i,indx)
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              dz = zi(i,k) - zi(i,k-1)
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*          &
+     &                     (heo(i,k)+heo(i,k-1)))/factor
+            endif
+          endif
+        enddo
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dz = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              xdby = hcko(i,k) - heso(i,k)
+              xqrch = qeso(i,k)                                    &
+     &              + gamma * xdby / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*          &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+!cj
+              dq = eta(i,k) * (qcko(i,k) - xqrch)
+!c
+              if(k.ge.kbcon(i).and.dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0.and.k.gt.jmin(i)) then
+                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+                else
+                  qlk = dq / (eta(i,k) + etah * c0 * dz)
+                endif
+                if(k.lt.ktcon1(i)) then
+                  xaa0(i) = xaa0(i) - dz * g * qlk
+                endif
+                qcko(i,k) = qlk + xqrch
+                xpw = etah * c0 * dz * qlk
+                xpwav(i) = xpwav(i) + xpw
+              endif
+            endif
+            if(k.ge.kbcon(i).and.k.lt.ktcon1(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma                    &
+     &                 * to(i,k) / hvap
+              xaa0(i) = xaa0(i)                                   &
+     &                + dz1 * (g / (cp * to(i,k)))                &
+     &                * xdby / (1. + gamma)                       &
+     &                * rfact
+              val=0.
+              xaa0(i)=xaa0(i)+                                    &
+     &                 dz1 * g * delta *                          &
+     &                 max(val,(qeso(i,k) - qo(i,k)))
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c------- downdraft calculations
+!c
+!c--- downdraft moisture properties
+!c
+      do i = 1, im
+        if(cnvdflg(i)) then
+          jmn = jmin(i)
+          hcdo(i,jmn) = heo(i,jmn)
+          qcdo(i,jmn) = qo(i,jmn)
+          qrcd(i,jmn) = qeso(i,jmn)
+          xpwev(i) = 0.
+        endif
+      enddo
+!cj
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvdflg(i) .and. k.lt.jmin(i)) then
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*        &
+     &                     (heo(i,k)+heo(i,k+1)))/factor
+          endif
+        enddo
+      enddo
+!cj
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvdflg(i) .and. k .lt. jmin(i)) then
+              dq = qeso(i,k)
+              dt = to(i,k)
+              gamma    = el2orc * dq / dt**2
+              dh       = hcdo(i,k) - heso(i,k)
+              qrcd(i,k)=dq+(1./hvap)*(gamma/(1.+gamma))*dh
+!             detad    = etad(i,k+1) - etad(i,k)
+!cj
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5*        &
+     &                     (qo(i,k)+qo(i,k+1)))/factor
+!cj
+!             xpwd     = etad(i,k+1) * qcdo(i,k+1) -
+!    &                   etad(i,k) * qrcd(i,k)
+!             xpwd     = xpwd - detad *
+!    &                 .5 * (qrcd(i,k) + qrcd(i,k+1))
+!cj
+              xpwd     = etad(i,k+1) * (qcdo(i,k) - qrcd(i,k))
+              qcdo(i,k)= qrcd(i,k)
+              xpwev(i) = xpwev(i) + xpwd
+          endif
+        enddo
+      enddo
+!c
+      do i = 1, im
+        edtmax = edtmaxl
+        if(slimsk(i).eq.0.) edtmax = edtmaxs
+        if(cnvdflg(i)) then
+          if(xpwev(i).ge.0.) then
+            edtx(i) = 0.
+          else
+            edtx(i) = -edtx(i) * xpwav(i) / xpwev(i)
+            edtx(i) = min(edtx(i),edtmax)
+          endif
+        endif
+      enddo
+!c
+!c
+!c--- downdraft cloudwork functions
+!c
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvdflg(i) .and. k.lt.jmin(i)) then
+              gamma = el2orc * qeso(i,k) / to(i,k)**2
+              dhh=hcdo(i,k)
+              dt= to(i,k)
+              dg= gamma
+              dh= heso(i,k)
+              dz=-1.*(zo(i,k+1)-zo(i,k))
+              xaa0(i)=xaa0(i)+edtx(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg))  &
+     &                *(1.+delta*cp*dg*dt/hvap)
+              val=0.
+              xaa0(i)=xaa0(i)+edtx(i)*                             &
+     &        dz*g*delta*max(val,(qeso(i,k)-qo(i,k)))
+          endif
+        enddo
+      enddo
+!c
+!c  calculate critical cloud work function
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          if(pfld(i,ktcon(i)).lt.pcrit(15))then
+            acrt(i)=acrit(15)*(975.-pfld(i,ktcon(i)))              &
+     &              /(975.-pcrit(15))
+          else if(pfld(i,ktcon(i)).gt.pcrit(1))then
+            acrt(i)=acrit(1)
+          else
+            k =  int((850. - pfld(i,ktcon(i)))/50.) + 2
+            k = min(k,15)
+            k = max(k,2)
+            acrt(i)=acrit(k)+(acrit(k-1)-acrit(k))*                &
+     &           (pfld(i,ktcon(i))-pcrit(k))/(pcrit(k-1)-pcrit(k))
+          endif
+        endif
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          if(slimsk(i).eq.1.) then
+            w1 = w1l
+            w2 = w2l
+            w3 = w3l
+            w4 = w4l
+          else
+            w1 = w1s
+            w2 = w2s
+            w3 = w3s
+            w4 = w4s
+          endif
+!c
+!c  modify critical cloud workfunction by cloud base vertical velocity
+!c
+          if(pdot(i).le.w4) then
+            acrtfct(i) = (pdot(i) - w4) / (w3 - w4)
+          elseif(pdot(i).ge.-w4) then
+            acrtfct(i) = - (pdot(i) + w4) / (w4 - w3)
+          else
+            acrtfct(i) = 0.
+          endif
+          val1    =             -1.
+          acrtfct(i) = max(acrtfct(i),val1)
+          val2    =             1.
+          acrtfct(i) = min(acrtfct(i),val2)
+          acrtfct(i) = 1. - acrtfct(i)
+!c
+!c  modify acrtfct(i) by colume mean rh if rhbar(i) is greater than 80 percent
+!c
+!c         if(rhbar(i).ge..8) then
+!c           acrtfct(i) = acrtfct(i) * (.9 - min(rhbar(i),.9)) * 10.
+!c         endif
+!c
+!c  modify adjustment time scale by cloud base vertical velocity
+!c
+          val1=0.0
+          dtconv(i) = dt2 + max((1800. - dt2),val1) *             &
+     &                (pdot(i) - w2) / (w1 - w2)
+!c         dtconv(i) = max(dtconv(i), dt2)
+!c         dtconv(i) = 1800. * (pdot(i) - w2) / (w1 - w2)
+          dtconv(i) = max(dtconv(i),dtmin)
+          dtconv(i) = min(dtconv(i),dtmax)
+!c
+        endif
+      enddo
+!c
+!c--- large scale forcing
+!c
+      do i= 1, im
+        if(cnvflg(i)) then
+          fld(i)=(aa1(i)-acrt(i)* acrtfct(i))/dtconv(i)
+          if(fld(i).le.0.) cnvflg(i) = .false.
+        endif
+        if(cnvflg(i)) then
+!c         xaa0(i) = max(xaa0(i),0.)
+          xk(i) = (xaa0(i) - aa1(i)) / mbdt
+          if(xk(i).ge.0.) cnvflg(i) = .false.
+        endif
+!c
+!c--- kernel, cloud base mass flux
+!c
+        if(cnvflg(i)) then
+          xmb(i) = -fld(i) / xk(i)
+          xmb(i) = min(xmb(i),xmbmax(i))
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  restore to,qo,uo,vo to t1,q1,u1,v1 in case convection stops
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            to(i,k) = t1(i,k)
+            qo(i,k) = q1(i,k)
+            uo(i,k) = u1(i,k)
+            vo(i,k) = v1(i,k)
+            qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
+            val     =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val )
+          endif
+        enddo
+      enddo
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+!c--- feedback: simply the changes from the cloud with unit mass flux
+!c---           multiplied by  the mass flux necessary to keep the
+!c---           equilibrium with the larger-scale.
+!c
+      do i = 1, im
+        delhbar(i) = 0.
+        delqbar(i) = 0.
+        deltbar(i) = 0.
+        delubar(i) = 0.
+        delvbar(i) = 0.
+        qcond(i) = 0.
+      enddo
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            if(k.le.ktcon(i)) then
+              delhz = dellah(i,k)*xmb(i) + delhx(i,k)
+              delqz = dellaq(i,k)*xmb(i) + delqx(i,k)
+              deluz = dellau(i,k)*xmb(i) + delux(i,k)
+              delvz = dellav(i,k)*xmb(i) + delvx(i,k)
+              dellat = (delhz - hvap * delqz) / cp
+              t1(i,k) = t1(i,k) + dellat * dt2
+              q1(i,k) = q1(i,k) + delqz * dt2
+              tem = 1./rcs(i)
+              u1(i,k) = u1(i,k) + deluz * dt2 * tem
+              v1(i,k) = v1(i,k) + delvz * dt2 * tem
+              dp = 1000. * del(i,k)
+              delhbar(i) = delhbar(i) + delhz * dp / g
+              delqbar(i) = delqbar(i) + delqz * dp / g
+              deltbar(i) = deltbar(i) + dellat * dp / g
+              delubar(i) = delubar(i) + deluz * dp / g
+              delvbar(i) = delvbar(i) + delvz * dp / g
+            endif
+          endif
+        enddo
+      enddo
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            if(k.le.ktcon(i)) then
+              qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
+              qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k))
+              val     =             1.e-8
+              qeso(i,k) = max(qeso(i,k), val )
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do i = 1, im
+        rntot(i) = 0.
+        delqev(i) = 0.
+        delq2(i) = 0.
+        flg(i) = cnvflg(i)
+      enddo
+      do k = km, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            if(k.lt.ktcon(i)) then
+              aup = 1.
+              if(k.le.kb(i)) aup = 0.
+              adw = 1.
+              if(k.ge.jmin(i).or..not.cnvdflg(i)) adw = 0.
+              rain =  aup * pwo(i,k) + adw * edto(i) * pwdo(i,k)
+              rntot(i) = rntot(i) + rain * xmb(i) * .001 * dt2
+            endif
+          endif
+        enddo
+      enddo
+      do k = km, 1, -1
+        do i = 1, im
+          if (k .le. kmax(i)) then
+            deltv(i) = 0.
+            delq(i) = 0.
+            qevap(i) = 0.
+            if(cnvflg(i).and.k.lt.ktcon(i)) then
+              aup = 1.
+              if(k.le.kb(i)) aup = 0.
+              adw = 1.
+              if(k.ge.jmin(i).or..not.cnvdflg(i)) adw = 0.
+              rain =  aup * pwo(i,k) + adw * edto(i) * pwdo(i,k)
+              rn(i) = rn(i) + rain * xmb(i) * .001 * dt2
+            endif
+            if(flg(i).and.k.lt.ktcon(i)) then
+              evef = edt(i) * evfact
+              if(slimsk(i).eq.1.) evef=edt(i) * evfactl
+!             if(slimsk(i).eq.1.) evef=.07
+!c             if(slimsk(i).ne.1.) evef = 0.
+              qcond(i) = evef * (q1(i,k) - qeso(i,k))                &
+     &                 / (1. + el2orc * qeso(i,k) / t1(i,k)**2)
+              dp = 1000. * del(i,k)
+              if(rn(i).gt.0..and.qcond(i).lt.0.) then
+                qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i))))
+                qevap(i) = min(qevap(i), rn(i)*1000.*g/dp)
+                delq2(i) = delqev(i) + .001 * qevap(i) * dp / g
+              endif
+              if(rn(i).gt.0..and.qcond(i).lt.0..and.                 &
+     &           delq2(i).gt.rntot(i)) then
+                qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp
+                flg(i) = .false.
+              endif
+              if(rn(i).gt.0..and.qevap(i).gt.0.) then
+                q1(i,k) = q1(i,k) + qevap(i)
+                t1(i,k) = t1(i,k) - elocp * qevap(i)
+                rn(i) = rn(i) - .001 * qevap(i) * dp / g
+                deltv(i) = - elocp*qevap(i)/dt2
+                delq(i) =  + qevap(i)/dt2
+                delqev(i) = delqev(i) + .001*dp*qevap(i)/g
+              endif
+              dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i)
+              delqbar(i) = delqbar(i) + delq(i)*dp/g
+              deltbar(i) = deltbar(i) + deltv(i)*dp/g
+            endif
+          endif
+        enddo
+      enddo
+!cj
+!     do i = 1, im
+!     if(me.eq.31.and.cnvflg(i)) then
+!     if(cnvflg(i)) then
+!       print *, ' deep delhbar, delqbar, deltbar = ',
+!    &             delhbar(i),hvap*delqbar(i),cp*deltbar(i)
+!       print *, ' deep delubar, delvbar = ',delubar(i),delvbar(i)
+!       print *, ' precip =', hvap*rn(i)*1000./dt2
+!       print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i))
+!     endif
+!     enddo
+!c
+!c  precipitation rate converted to actual precip
+!c  in unit of m instead of kg
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+!c
+!c  in the event of upper level rain evaporation and lower level downdraft
+!c    moistening, rn can become negative, in this case, we back out of the
+!c    heating and the moistening
+!c
+          if(rn(i).lt.0..and..not.flg(i)) rn(i) = 0.
+          if(rn(i).le.0.) then
+            rn(i) = 0.
+          else
+            ktop(i) = ktcon(i)
+            kbot(i) = kbcon(i)
+            kcnv(i) = 1
+            cldwrk(i) = aa1(i)
+          endif
+        endif
+      enddo
+!c
+!c  cloud water
+!c
+      if (ncloud.gt.0) then
+!
+      val1=0.0
+      val2=1.0
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. rn(i).gt.0.) then
+            if (k.gt.kb(i).and.k.le.ktcon(i)) then
+              tem  = dellal(i,k) * xmb(i) * dt2
+              tem1 = max(val1, min(val2, (tcr-t1(i,k))*tcrf))
+              if (ql(i,k,2) .gt. -999.0) then
+                ql(i,k,1) = ql(i,k,1) + tem * tem1            ! ice
+                ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1)       ! water
+              else
+                ql(i,k,1) = ql(i,k,1) + tem
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+      endif
+!c
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i).and.rn(i).le.0.) then
+            if (k .le. kmax(i)) then
+              t1(i,k) = to(i,k)
+              q1(i,k) = qo(i,k)
+              u1(i,k) = uo(i,k)
+              v1(i,k) = vo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!
+! hchuang code change
+!
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i).and.rn(i).gt.0.) then
+            if(k.ge.kb(i) .and. k.lt.ktop(i)) then
+              ud_mf(i,k) = eta(i,k) * xmb(i) * dt2
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i).and.rn(i).gt.0.) then
+           k = ktop(i)-1
+           dt_mf(i,k) = ud_mf(i,k)
+        endif
+      enddo
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i).and.rn(i).gt.0.) then
+            if(k.ge.1 .and. k.le.jmin(i)) then
+              dd_mf(i,k) = edto(i) * etad(i,k) * xmb(i) * dt2
+            endif
+          endif
+        enddo
+      enddo
+!!
+
+      sigma_sum=0.
+      do I=1,im
+         sigma_sum=sigma_sum+abs(sigma(I))
+      end do
+!      if(sigma_sum.gt.0.1)then
+!        print*,'qliu test sigma_c='
+!        write(*,333)sigma
+!      end if
+!333   format(1x,'inside sascnvn_h sigma_c=',9F10.3)
+
+      return
+      end subroutine sascnvn_h
+
+      END MODULE module_cu_mesosas
+
diff --git a/wrfv2_fire/phys/module_cu_nsas.F b/wrfv2_fire/phys/module_cu_nsas.F
index 8b30c839..2b4d4324 100644
--- a/wrfv2_fire/phys/module_cu_nsas.F
+++ b/wrfv2_fire/phys/module_cu_nsas.F
@@ -4,15 +4,14 @@
 !
 MODULE module_cu_nsas
 CONTAINS
-!
 !-------------------------------------------------------------------------------
-   subroutine cu_nsas(dt,p3di,p3d,pi3d,qc3d,qi3d,rho3d,itimestep,stepcu,       &
+   subroutine cu_nsas(dt,dx,p3di,p3d,pi3d,qc3d,qi3d,rho3d,itimestep,stepcu,    &
                      hbot,htop,cu_act_flag,                                    &
                      rthcuten,rqvcuten,rqccuten,rqicuten,                      &
                      rucuten,rvcuten,                                          &
                      qv3d,t3d,raincv,pratec,xland,dz8w,w,u3d,v3d,              &
                      hpbl,hfx,qfx,                                             &
-                     mp_physics,                                               &
+                     mp_physics,dx_factor_nsas,                                &
                      p_qc,p_qi,p_first_scalar,                                 &
                      pgcon,                                                    &
                      cp,cliq,cpv,g,xlv,r_d,r_v,ep_1,ep_2,                      &
@@ -21,10 +20,10 @@ subroutine cu_nsas(dt,p3di,p3d,pi3d,qc3d,qi3d,rho3d,itimestep,stepcu,       &
                      ims,ime, jms,jme, kms,kme,                                &
                      its,ite, jts,jte, kts,kte)
 !-------------------------------------------------------------------------------
-  implicit none
+   implicit none
 !-------------------------------------------------------------------------------
-!
 !-- dt          time step (s)
+!-- dx          grid interval (m)
 !-- p3di        3d pressure (pa) at interface level
 !-- p3d         3d pressure (pa)
 !-- pi3d        3d exner function (dimensionless)
@@ -57,187 +56,191 @@ subroutine cu_nsas(dt,p3di,p3d,pi3d,qc3d,qi3d,rho3d,itimestep,stepcu,       &
 !-- kts         start index for k in tile
 !-- kte         end index for k in tile
 !-------------------------------------------------------------------------------
-  integer,  intent(in   )   ::       ids,ide, jds,jde, kds,kde,                &
-                                     ims,ime, jms,jme, kms,kme,                &
-                                     its,ite, jts,jte, kts,kte,                &
-                                     itimestep, stepcu,                        &
-                                     p_qc,p_qi,p_first_scalar
-!
-  real,     intent(in   )   ::      cp,cliq,cpv,g,xlv,r_d,r_v,ep_1,ep_2,       &
-                                    cice,xls,psat
-  real,     intent(in   )   ::      dt
-  real,     optional, intent(in   )   ::      pgcon
-!
-  real,     dimension( ims:ime, kms:kme, jms:jme ),optional                  , &
-            intent(inout)   ::                                       rthcuten, &
-                                                                      rucuten, &
-                                                                      rvcuten, &
-                                                                     rqccuten, &
-                                                                     rqicuten, &
-                                                                     rqvcuten
-  logical, optional ::                                              F_QC,F_QI
-  real,     dimension( ims:ime, kms:kme, jms:jme )                           , &
-            intent(in   )   ::                                           qv3d, &
-                                                                         qc3d, &
-                                                                         qi3d, &
-                                                                        rho3d, &
-                                                                          p3d, &
-                                                                         pi3d, &
-                                                                          t3d
-  real,     dimension( ims:ime, kms:kme, jms:jme )                           , &
-            intent(in   )   ::                                           p3di
-  real,     dimension( ims:ime, kms:kme, jms:jme )                           , &
-            intent(in   )   ::                                           dz8w, &  
-                                                                            w
-  real,     dimension( ims:ime, jms:jme )                                    , &
-            intent(inout) ::                                           raincv, &
-                                                                       pratec
-  real,     dimension( ims:ime, jms:jme )                                    , &
-            intent(out) ::                                               hbot, &
-                                                                         htop
-  real,     dimension( ims:ime, jms:jme )                                    , &
-            intent(in   ) ::                                            xland
-!
-  real,     dimension( ims:ime, kms:kme, jms:jme )                           , &
-             intent(in   )   ::                                           u3d, &
-                                                                          v3d
-  logical,  dimension( ims:ime, jms:jme )                                    , &
-            intent(inout) ::                                      cu_act_flag
-
-!
-  real,     dimension( ims:ime, jms:jme )                                    , &
-             intent(in   )   ::                                          hpbl, &
-                                                                          hfx, &
-                                                                          qfx
-  integer,   intent(in   )   ::                                    mp_physics
-  integer :: ncloud
+   integer,  intent(in   )   ::       ids,ide, jds,jde, kds,kde,               &
+                                      ims,ime, jms,jme, kms,kme,               &
+                                      its,ite, jts,jte, kts,kte,               &
+                                      itimestep, stepcu,                       &
+                                      p_qc,p_qi,p_first_scalar
+   real,     intent(in   )   ::      cp,cliq,cpv,g,xlv,r_d,r_v,ep_1,ep_2,      &
+                                     cice,xls,psat
+   real,     intent(in   )   ::      dt,dx
+   real,     optional, intent(in ) :: pgcon
+   real,     dimension( ims:ime, kms:kme, jms:jme ),optional                  ,&
+             intent(inout)   ::                                       rthcuten,&
+                                                                       rucuten,&
+                                                                       rvcuten,&
+                                                                      rqccuten,&
+                                                                      rqicuten,&
+                                                                      rqvcuten
+   logical, optional ::                                              F_QC,F_QI
+   real,     dimension( ims:ime, kms:kme, jms:jme )                           ,&
+             intent(in   )   ::                                           qv3d,&
+                                                                          qc3d,&
+                                                                          qi3d,&
+                                                                         rho3d,&
+                                                                           p3d,&
+                                                                          pi3d,&
+                                                                           t3d
+   real,     dimension( ims:ime, kms:kme, jms:jme )                           ,&
+             intent(in   )   ::                                           p3di
+   real,     dimension( ims:ime, kms:kme, jms:jme )                           ,&
+             intent(in   )   ::                                           dz8w,&  
+                                                                             w
+   real,     dimension( ims:ime, jms:jme )                                    ,&
+             intent(inout) ::                                           raincv,&
+                                                                        pratec
+   real,     dimension( ims:ime, jms:jme )                                    ,&
+             intent(out) ::                                               hbot,&
+                                                                          htop
+!
+   real,     dimension( ims:ime, jms:jme )                                    ,&
+             intent(in   ) ::                                            xland
+!
+   real,     dimension( ims:ime, kms:kme, jms:jme )                           ,&
+              intent(in   )   ::                                           u3d,&
+                                                                           v3d
+   logical,  dimension( ims:ime, jms:jme )                                    ,&
+             intent(inout) ::                                      cu_act_flag
+!
+   real,     dimension( ims:ime, jms:jme )                                    ,&
+              intent(in   )   ::                                          hpbl,&
+                                                                           hfx,&
+                                                                           qfx
+   integer,   intent(in   )   ::                                    mp_physics
+   integer,   intent(in   )   ::                                dx_factor_nsas 
+   integer :: ncloud
 !
 !local
 !
-  real,  dimension( its:ite, jts:jte )  ::                            raincv1, &
-                                                                      raincv2, &
-                                                                      pratec1, &
-                                                                      pratec2
-  real,   dimension( its:ite, kts:kte )  ::                               del, &
-                                                                        prsll, &
-                                                                          dot, &
-                                                                           u1, &
-                                                                           v1, &
-                                                                           t1, &
-                                                                          q1,  &
-                                                                          qc2, &
-                                                                          qi2
-  real,   dimension( its:ite, kts:kte+1 )  ::                           prsii, &
-                                                                          zii
-  real,   dimension( its:ite, kts:kte )  ::                               zll 
-  real,   dimension( its:ite)  ::                                         rain
-  real ::                                                          delt,rdelt
-  integer, dimension (its:ite)  ::                                       kbot, &
-                                                                         ktop, &
-                                                                          kuo
-  real    :: pgcon_use
-  integer ::  i,j,k,kp
+   real,  dimension( its:ite, jts:jte )  ::                            raincv1,&
+                                                                       raincv2,&
+                                                                       pratec1,&
+                                                                       pratec2
+   real,   dimension( its:ite, kts:kte )  ::                               del,&
+                                                                         prsll,&
+                                                                           dot,&
+                                                                            u1,&
+                                                                            v1,&
+                                                                            t1,&
+                                                                           q1, &
+                                                                           qc2,&
+                                                                           qi2
+   real,   dimension( its:ite, kts:kte+1 )  ::                           prsii,&
+                                                                           zii
+   real,   dimension( its:ite, kts:kte )  ::                               zll 
+   real,   dimension( its:ite)  ::                                         rain
+   real ::                                                          delt,rdelt
+   integer, dimension (its:ite)  ::                                       kbot,&
+                                                                          ktop,&
+                                                                          icps
+   real :: pgcon_use
+   integer ::  i,j,k,kp
 !
-!-------------------------------------------------------------------------------
 ! microphysics scheme --> ncloud 
+!
    if (mp_physics .eq. 0) then
      ncloud = 0
    elseif ( mp_physics .eq. 1 .or. mp_physics .eq. 3 ) then
      ncloud = 1
    else
      ncloud = 2
-   endif  
+   endif
 !
-!-------------------------------------------------------------------------------
+   if(present(pgcon)) then
+     pgcon_use = pgcon
+   else
+!    pgcon_use  = 0.7     ! Gregory et al. (1997, QJRMS)
+     pgcon_use  = 0.55    ! Zhang & Wu (2003,JAS)
+     ! 0.55 is a physically-based value used by GFS
+     ! HWRF uses 0.2, for model tuning purposes
+   endif
 !
-
-      if(present(pgcon)) then
-         pgcon_use  = pgcon
-      else
-!        pgcon_use  = 0.7     ! Gregory et al. (1997, QJRMS)
-         pgcon_use  = 0.55    ! Zhang & Wu (2003,JAS)
-         ! 0.55 is a physically-based value used by GFS
-         ! HWRF uses 0.2, for model tuning purposes
-      endif
-
-      do j=jts,jte
-        do i=its,ite
-          cu_act_flag(i,j)=.TRUE.
-        enddo
-      enddo
-      delt=dt*stepcu
-      rdelt=1./delt
-!
-   do j = jts,jte  !outer most J_loop
-      do k = kts,kte
-        kp = k+1
-        do i = its,ite
-          dot(i,k) = -5.0e-4*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j))
-          prsll(i,k)=p3d(i,k,j)*0.001
-          prsii(i,k)=p3di(i,k,j)*0.001
-        enddo
-      enddo
-      do i = its,ite
-        prsii(i,kte+1)=p3di(i,kte+1,j)*0.001
-      enddo
-!
-      do i=its,ite
-        zii(i,1)=0.0
-      enddo     
-!
-      do k=kts,kte                                            
-        do i=its,ite
-          zii(i,k+1)=zii(i,k)+dz8w(i,k,j)
-        enddo
-      enddo
-!
-      do k=kts,kte                
-        do i=its,ite                                                  
-          zll(i,k)=0.5*(zii(i,k)+zii(i,k+1))
-        enddo                                                         
-      enddo
-!
-      do k=kts,kte
-        do i=its,ite
-          del(i,k)=prsll(i,k)*g/r_d*dz8w(i,k,j)/t3d(i,k,j)
-          u1(i,k)=u3d(i,k,j)
-          v1(i,k)=v3d(i,k,j)
-          t1(i,k)=t3d(i,k,j)
-          q1(i,k)=qv3d(i,k,j)
-          qi2(i,k) = qi3d(i,k,j)
-          qc2(i,k) = qc3d(i,k,j)
-        enddo
-      enddo
+   do j = jts,jte
+     do i = its,ite
+       cu_act_flag(i,j)=.TRUE.
+     enddo
+   enddo
+   delt=dt*stepcu
+   rdelt=1./delt
+!
+! outer most J_loop
+!
+   do j = jts,jte
+     do k = kts,kte
+       kp = k+1
+       do i = its,ite
+         dot(i,k) = -5.0e-4*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j))
+         prsll(i,k)=p3d(i,k,j)*0.001
+         prsii(i,k)=p3di(i,k,j)*0.001
+       enddo
+     enddo
+!
+     do i = its,ite
+       prsii(i,kte+1)=p3di(i,kte+1,j)*0.001
+     enddo
+!
+     do i = its,ite
+       zii(i,1)=0.0
+     enddo     
+!
+     do k = kts,kte                                            
+       do i = its,ite
+         zii(i,k+1)=zii(i,k)+dz8w(i,k,j)
+       enddo
+     enddo
+!
+     do k = kts,kte                
+       do i = its,ite                                                  
+         zll(i,k)=0.5*(zii(i,k)+zii(i,k+1))
+       enddo                                                         
+     enddo
+!
+     do k = kts,kte
+       do i = its,ite
+         del(i,k)=prsll(i,k)*g/r_d*dz8w(i,k,j)/t3d(i,k,j)
+         u1(i,k)=u3d(i,k,j)
+         v1(i,k)=v3d(i,k,j)
+         q1(i,k)=qv3d(i,k,j)
+!        q1(i,k)=qv3d(i,k,j)/(1.+qv3d(i,k,j))
+         t1(i,k)=t3d(i,k,j)
+         qi2(i,k) = qi3d(i,k,j)
+         qc2(i,k) = qc3d(i,k,j)
+       enddo
+     enddo
 !
 ! NCEP SAS 
-      call nsas2d(delt=dt,del=del(its,kts),prsl=prsll(its,kts),                &
-              prsi=prsii(its,kts),prslk=pi3d(ims,kms,j),zl=zll(its,kts),       &
-              zi=zii(its,kts),ncloud=ncloud,qc2=qc2(its,kts),qi2=qi2(its,kts), &
+!
+     call nsas2d(delt=dt,delx=dx,del=del(its,kts),                             &
+              prsl=prsll(its,kts),prsi=prsii(its,kts),prslk=pi3d(ims,kms,j),   &
+              zl=zll(its,kts),zi=zii(its,kts),                                 &
+              ncloud=ncloud,qc2=qc2(its,kts),qi2=qi2(its,kts),                 &
               q1=q1(its,kts),t1=t1(its,kts),rain=rain(its),                    &
               kbot=kbot(its),ktop=ktop(its),                                   &
-              kuo=kuo(its),                                                    &
+              icps=icps(its),                                                  &
               lat=j,slimsk=xland(ims,j),dot=dot(its,kts),                      &
               u1=u1(its,kts), v1=v1(its,kts),                                  &
               cp_=cp,cliq_=cliq,cvap_=cpv,g_=g,hvap_=xlv,                      &
               rd_=r_d,rv_=r_v,fv_=ep_1,ep2=ep_2,                               &
               cice=cice,xls=xls,psat=psat,                                     &
               pgcon=pgcon_use,                                                 &
+              dx_factor_nsas=dx_factor_nsas,                                   &
               ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde,               &
               ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme,               &
               its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte   )
 !
-      do i=its,ite
-        pratec1(i,j)=rain(i)*1000./(stepcu*dt)
-        raincv1(i,j)=rain(i)*1000./(stepcu)
-      enddo
+     do i = its,ite
+       pratec1(i,j)=rain(i)*1000./(stepcu*dt)
+       raincv1(i,j)=rain(i)*1000./(stepcu)
+     enddo
 !
 ! NCEP SCV
-      call nscv2d(delt=dt,del=del(its,kts),prsl=prsll(its,kts),                &
+!
+     call nscv2d(delt=dt,del=del(its,kts),prsl=prsll(its,kts),                 &
               prsi=prsii(its,kts),prslk=pi3d(ims,kms,j),zl=zll(its,kts),       &
               zi=zii(its,kts),ncloud=ncloud,qc2=qc2(its,kts),qi2=qi2(its,kts), &
               q1=q1(its,kts),t1=t1(its,kts),rain=rain(its),                    &
               kbot=kbot(its),ktop=ktop(its),                                   &
-              kuo=kuo(its),                                                    &
+              icps=icps(its),                                                  &
               slimsk=xland(ims,j),dot=dot(its,kts),                            &
               u1=u1(its,kts), v1=v1(its,kts),                                  &
               cp_=cp,cliq_=cliq,cvap_=cpv,g_=g,hvap_=xlv,                      &
@@ -249,75 +252,77 @@ subroutine cu_nsas(dt,p3di,p3d,pi3d,qc3d,qi3d,rho3d,itimestep,stepcu,       &
               ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme,               &
               its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte   )
 !
-   do i=its,ite
-     pratec2(i,j)=rain(i)*1000./(stepcu*dt)
-     raincv2(i,j)=rain(i)*1000./(stepcu)
-   enddo
+     do i = its,ite
+       pratec2(i,j)=rain(i)*1000./(stepcu*dt)
+       raincv2(i,j)=rain(i)*1000./(stepcu)
+     enddo
 !
-   do i=its,ite
-     raincv(i,j) = raincv1(i,j) + raincv2(i,j)
-     pratec(i,j) = pratec1(i,j) + pratec2(i,j)
-     hbot(i,j) = kbot(i)
-     htop(i,j) = ktop(i)
-   enddo
-!
-      IF(PRESENT(rthcuten).AND.PRESENT(rqvcuten)) THEN
-      do k = kts,kte
-        do i= its,ite
-          rthcuten(i,k,j)=(t1(i,k)-t3d(i,k,j))/pi3d(i,k,j)*rdelt
-          rqvcuten(i,k,j)=(q1(i,k)-qv3d(i,k,j))*rdelt
-        enddo
-      enddo
-      ENDIF
-!
-      IF(PRESENT(rucuten).AND.PRESENT(rvcuten)) THEN
-      do k = kts,kte
-        do i= its,ite
-          rucuten(i,k,j)=(u1(i,k)-u3d(i,k,j))*rdelt
-          rvcuten(i,k,j)=(v1(i,k)-v3d(i,k,j))*rdelt
-        enddo
-      enddo
-      ENDIF
-!
-      if(PRESENT( rqicuten )) THEN
-        IF ( F_QI ) THEN
-        do k=kts,kte
-          do i=its,ite
-            rqicuten(i,k,j)=(qi2(i,k)-qi3d(i,k,j))*rdelt
-          enddo
-        enddo
-        endif
-      endif
-      if(PRESENT( rqccuten )) THEN
-        IF ( F_QC ) THEN
-        do k=kts,kte
-          do i=its,ite
-            rqccuten(i,k,j)=(qc2(i,k)-qc3d(i,k,j))*rdelt
-          enddo
-        enddo
-        endif
-      endif
+     do i = its,ite
+       raincv(i,j) = raincv1(i,j) + raincv2(i,j)
+       pratec(i,j) = pratec1(i,j) + pratec2(i,j)
+       hbot(i,j) = kbot(i)
+       htop(i,j) = ktop(i)
+     enddo
+!
+     IF(PRESENT(rthcuten).AND.PRESENT(rqvcuten)) THEN
+       do k = kts,kte
+         do i = its,ite
+           rthcuten(i,k,j)=(t1(i,k)-t3d(i,k,j))/pi3d(i,k,j)*rdelt
+           rqvcuten(i,k,j)=(q1(i,k)-qv3d(i,k,j))*rdelt
+         enddo
+       enddo
+     ENDIF
+!
+     IF(PRESENT(rucuten).AND.PRESENT(rvcuten)) THEN
+       do k = kts,kte
+         do i = its,ite
+           rucuten(i,k,j)=(u1(i,k)-u3d(i,k,j))*rdelt
+           rvcuten(i,k,j)=(v1(i,k)-v3d(i,k,j))*rdelt
+         enddo
+       enddo
+     ENDIF
+!
+     IF(PRESENT( rqicuten )) THEN
+       IF ( F_QI ) THEN
+         do k = kts,kte
+           do i = its,ite
+             rqicuten(i,k,j)=(qi2(i,k)-qi3d(i,k,j))*rdelt
+           enddo
+         enddo
+       ENDIF
+     ENDIF
+!
+     IF(PRESENT( rqccuten )) THEN
+       IF ( F_QC ) THEN
+         do k = kts,kte
+           do i = its,ite
+             rqccuten(i,k,j)=(qc2(i,k)-qc3d(i,k,j))*rdelt
+           enddo
+         enddo
+       ENDIF
+     ENDIF
 !
    enddo ! outer most J_loop
 !
+   return
    end subroutine cu_nsas
 !
-!==============================================================================
+!-------------------------------------------------------------------------------
 ! NCEP SAS (Deep Convection Scheme)
-!==============================================================================
-   subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
+!-------------------------------------------------------------------------------
+   subroutine nsas2d(delt,delx,del,prsl,prsi,prslk,zl,zi,                      &
             ncloud,                                                            & 
             qc2,qi2,                                                           & 
             q1,t1,rain,kbot,ktop,                                              &
-            kuo,                                                               &
+            icps,                                                              &
             lat,slimsk,dot,u1,v1,cp_,cliq_,cvap_,g_,hvap_,rd_,rv_,fv_,ep2,     &
             cice,xls,psat,                                                     &
             pgcon,                                                             &
+            dx_factor_nsas,                                                    &
             ids,ide, jds,jde, kds,kde,                                         &
             ims,ime, jms,jme, kms,kme,                                         &
             its,ite, jts,jte, kts,kte)
-!
-!------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
 !
 ! subprogram:    phys_cps_sas      computes convective heating and moistening
 !                                                      and momentum transport
@@ -344,11 +349,12 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !   09-10-01  jung-eun kim     f90 format with standard physics modules
 !   10-07-01  jong-il han      revised cloud model,trigger, as in gfs july 2010
 !   10-12-01  kyosun sunny lim wrf compatible version
+!   14-01-09  song-you hong    dx dependent trigger, closure, and mass flux
 !
 !
 ! usage:    call phys_cps_sas(delt,delx,del,prsl,prsi,prslk,prsik,zl,zi,       &
 !                             q2,q1,t1,u1,v1,rcs,slimsk,dot,cldwrk,rain,       &
-!                             jcap,ncloud,lat,kbot,ktop,kuo,                   &
+!                             jcap,ncloud,lat,kbot,ktop,icps,                  &
 !                             ids,ide, jds,jde, kds,kde,                       &
 !                             ims,ime, jms,jme, kms,kme,                       &
 !                             its,ite, jts,jte, kts,kte)
@@ -365,8 +371,8 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !   rcs      - real
 !   slimsk   - real (ims:ime) land(1),sea(0), ice(2) flag
 !   dot      - real (ims:ime,kms:kme) vertical velocity
-!   jcap     - integer spectral truncation
-!   ncloud   - integer no_cloud(0),no_ice(1),cloud+ice(2)
+!   jcap     - integer wave number 
+!   ncloud   - integer no_cloud(0),no_ice(1),cloud+ice(2) 
 !   lat      - integer  current latitude index
 !
 ! output argument list:
@@ -380,7 +386,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !   rain     - real (ims:ime) convective rain in meters
 !   kbot     - integer (ims:ime) cloud bottom level
 !   ktop     - integer (ims:ime) cloud top level
-!   kuo      - integer (ims:ime) bit flag indicating deep convection
+!   icps     - integer (ims:ime) bit flag indicating deep convection
 !
 ! subprograms called:
 !   fpvs     - function to compute saturation vapor pressure
@@ -395,10 +401,10 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !   byun and hong (2007, mon wea rev)
 !   han and pan   (2011, wea. forecasting)
 !
-!------------------------------------------------------------------------------
-!------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
    implicit none
-!------------------------------------------------------------------------------
+!-------------------------------------------------------------------------------
 !
 ! model tunable parameters 
 !
@@ -411,14 +417,6 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
    real,parameter  ::  aafac  = 0.1
    real,parameter  ::  dthk=25.
    real,parameter  ::  cincrmax = 180.,cincrmin = 120.
-   real,parameter  ::  W1l = -8.E-3 
-   real,parameter  ::  W2l = -4.E-2
-   real,parameter  ::  W3l = -5.E-3 
-   real,parameter  ::  W4l = -5.E-4
-   real,parameter  ::  W1s = -2.E-4
-   real,parameter  ::  W2s = -2.E-3
-   real,parameter  ::  W3s = -1.E-3
-   real,parameter  ::  W4s = -2.E-5
    real,parameter  ::  mbdt = 10., edtmaxl = 0.3, edtmaxs = 0.3
    real,parameter  ::  evfacts = 0.3, evfactl = 0.3
 !
@@ -430,6 +428,8 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !
    real            ::  cp_,cliq_,cvap_,g_,hvap_,rd_,rv_,fv_,ep2
    real            ::  pi_,qmin_,t0c_,cice,xlv0,xls,psat
+   real            ::  pgcon
+   integer         ::  dx_factor_nsas
    integer         ::  lat,                                                    &
                        ncloud,                                                 &
                        ids,ide, jds,jde, kds,kde,                              &
@@ -448,9 +448,8 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
    real            ::  qc2(its:ite,kts:kte)
 !
    real            ::  rain(its:ite)
-   integer         ::  kbot(its:ite),ktop(its:ite),kuo(its:ite)
+   integer         ::  kbot(its:ite),ktop(its:ite),icps(its:ite)
    real            ::  slimsk(ims:ime)
-   real            ::  pgcon
 !
 !
 !  local variables and arrays
@@ -479,7 +478,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
    integer         ::  kbds(its:ite),lmin(its:ite),jmin(its:ite)
    integer         ::  ktcon(its:ite)
    integer         ::  ktcon1(its:ite)
-   integer         ::  kbdtr(its:ite),kpbl(its:ite)
+   integer         ::  kbdtr(its:ite)
    integer         ::  klcl(its:ite),ktdown(its:ite)
    real            ::  vmax(its:ite)
    real            ::  hmin(its:ite),pwavo(its:ite)
@@ -524,7 +523,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
                        tem,tem1,cincr
    real            ::  dz,dp,es,pprime,qs,                                     &
                        dqsdp,desdt,dqsdt,gamma,                                &
-                       dt,dq,po,thei,delza,dzfac,                              &
+                       dt,dq,po,thei,delx,delza,dzfac,                         &
                        thec,theb,thekb,thekh,theavg,thedif,                    &
                        omgkb,omgkbp1,omgdif,omgfac,heom,rh,thermal,chi,        &
                        factor,onemf,dz1,qrch,etah,qlk,qc,rfact,shear,          &
@@ -532,9 +531,11 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
                        dv1,dv2,dv3,dv1q,dv2q,dv3q,dvq1,                        &
                        dv1u,dv2u,dv3u,dv1v,dv2v,dv3v,                          &
                        dellat,xdby,xqrch,xqc,xpw,xpwd,                         &
-                       w1,w2,w3,w4,qrsk,evef,ptem,ptem1
+                       W1l,W2l,W3l,W4l,W1s,W2s,W3s,W4s,                        & 
+                       w1,w2,w3,w4,qrsk(its:ite,kts:kte),evef,ptem,ptem1
 !
-   logical         ::  totflg, cnvflg(its:ite),flg(its:ite)
+   logical         ::  totflg, cnvflg(its:ite),flg(its:ite),lclflg
+   real            ::  dx_factor
 !
 !  climatological critical cloud work functions for closure
 !
@@ -562,14 +563,35 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
    dtmin  = max(dt2,1200.)
    dtmax  = max(dt2,3600.)
 !
+   if (dx_factor_nsas == 1) then
+   dx_factor = 250. / delx ! assume 2.5 ms-1 (1km) and 1.125 cms-1 (200km)
+   W1l = dx_factor * 0.1 * (-1.)
+   W2l = dx_factor * (-1.)
+   W3l = dx_factor * (-1.)
+   W4l = dx_factor * 0.1 * (-1.)
+   W1s = W1l
+   W2s = W2l
+   W3s = W3l
+   W4s = W4l
+   else 
+   W1l = -8.E-3
+   W2l = -4.E-2
+   W3l = -5.E-3
+   W4l = -5.E-4
+   W1s = -2.E-4
+   W2s = -2.E-3
+   W3s = -1.E-3
+   W4s = -2.E-5
+   endif
 !
 !  initialize arrays
 !
+   lclflg = .true.
    do i = its,ite
      rain(i)     = 0.0
      kbot(i)   = kte+1
      ktop(i)   = 0
-     kuo(i)    = 0
+     icps(i)   = 0
      cnvflg(i) = .true.
      dtconv(i) = 3600.
      pdot(i)   = 0.0
@@ -578,7 +600,6 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
      xmbmax(i) = 0.3
      excess(i) = 0.0
      plcl(i)   = 0.0
-     kpbl(i)   = 1
      aa2(i) = 0.0
      qlko_ktcon(i) = 0.0
      pbcdif(i)= 0.0
@@ -594,16 +615,16 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 ! Define top layer for search of the downdraft originating layer
 ! and the maximum thetae for updraft
 !
-   kbmax = kte
-   kbm   = kte
-   kmax  = kte
-   do k = kts,kte
-     do i = its,ite
-       if(prsl(i,k).gt.prsi(i,1)*0.45) kbmax = k + 1
-       if(prsl(i,k).gt.prsi(i,1)*0.70) kbm   = k + 1
-       if(prsl(i,k).gt.prsi(i,1)*0.04) kmax  = k + 1
-     enddo
-   enddo
+   kbmax = kte 
+   kbm   = kte 
+   kmax  = kte 
+   do k = kts,kte 
+     do i = its,ite 
+       if(prsl(i,k).gt.prsi(i,1)*0.45) kbmax = k + 1 
+       if(prsl(i,k).gt.prsi(i,1)*0.70) kbm   = k + 1 
+       if(prsl(i,k).gt.prsi(i,1)*0.04) kmax  = k + 1 
+     enddo 
+   enddo 
    kmax = min(kmax,kte)
    kmax1 = kmax - 1
    kbm = min(kbm,kte)
@@ -733,61 +754,61 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
      kbcon(i) = kmax
    enddo
 !
-     do k = kts,kbmax
-       do i = its,ite
-         if(flg(i).and.k.gt.kb(i)) then
-           hsbar(i) = heso(i,k)
-           if(hkbo(i).gt.hsbar(i)) then
-             flg(i) = .false.
-             kbcon(i) = k
-           endif
-         endif
-       enddo
-     enddo
+   do k = kts,kbmax
      do i = its,ite
-       if(kbcon(i).eq.kmax) cnvflg(i) = .false.
+       if(flg(i).and.k.gt.kb(i)) then
+         hsbar(i) = heso(i,k)
+         if(hkbo(i).gt.hsbar(i)) then
+           flg(i) = .false.
+           kbcon(i) = k
+         endif
+       endif
      enddo
+   enddo
+   do i = its,ite
+     if(kbcon(i).eq.kmax) cnvflg(i) = .false.
+   enddo
 !
-     totflg = .true.
-     do i = its,ite
-       totflg = totflg .and. (.not. cnvflg(i))
-     enddo
-     if(totflg) return
+   totflg = .true.
+   do i = its,ite
+     totflg = totflg .and. (.not. cnvflg(i))
+   enddo
+   if(totflg) return
 !
-     do i = its,ite
-       if(cnvflg(i)) then
+   do i = its,ite
+     if(cnvflg(i)) then
 !
 !  determine critical convective inhibition
 !  as a function of vertical velocity at cloud base.
 !
-          pdot(i)  = 10.* dot(i,kbcon(i))
-          if(slimsk(i).eq.1.) then
-            w1 = w1l
-            w2 = w2l
-            w3 = w3l
-            w4 = w4l
-          else
-            w1 = w1s
-            w2 = w2s
-            w3 = w3s
-            w4 = w4s
-          endif
-          if(pdot(i).le.w4) then
-            tem = (pdot(i) - w4) / (w3 - w4)
-          elseif(pdot(i).ge.-w4) then
-            tem = - (pdot(i) + w4) / (w4 - w3)
-          else
-            tem = 0.
-          endif
-          tem = max(tem,-1.)
-          tem = min(tem,1.)
-          tem = 1. - tem
-          tem1= .5*(cincrmax-cincrmin)
-          cincr = cincrmax - tem * tem1
-         pbcdif(i) = -p(i,kbcon(i)) + p(i,kb(i))
-         if(pbcdif(i).gt.cincr) cnvflg(i) = .false.
+       pdot(i)  = 10.* dot(i,kbcon(i))
+       if(slimsk(i).eq.1.) then
+         w1 = w1l
+         w2 = w2l
+         w3 = w3l
+         w4 = w4l
+       else
+         w1 = w1s
+         w2 = w2s
+         w3 = w3s
+         w4 = w4s
        endif
-     enddo
+       if(pdot(i).le.w4) then
+         tem = (pdot(i) - w4) / (w3 - w4)
+       elseif(pdot(i).ge.-w4) then
+         tem = - (pdot(i) + w4) / (w4 - w3)
+       else
+         tem = 0.
+       endif
+       tem = max(tem,-1.)
+       tem = min(tem,1.)
+       tem = 1. - tem
+       tem1= .5*(cincrmax-cincrmin)
+       cincr = cincrmax - tem * tem1
+       pbcdif(i) = -p(i,kbcon(i)) + p(i,kb(i))
+       if(pbcdif(i).gt.cincr) cnvflg(i) = .false.
+     endif
+   enddo
 !
 !
    totflg = .true.
@@ -942,7 +963,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
      endif
    enddo
 !
-   do i =its,ite
+   do i = its,ite
      if(cnvflg(i)) then
        tem = p(i,kbcon(i)) - p(i,kbcon1(i))
        if(tem.gt.dthk) then
@@ -1064,7 +1085,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
            else
              qlk = qcirs(i,k) / (eta(i,k) + etah * c0 * dz1)
            endif
-	   aa1(i) = aa1(i) - dz1 * g_ * qlk
+           aa1(i) = aa1(i) - dz1 * g_ * qlk
            qc = qlk + qrch
            pwo(i,k) = etah * c0 * dz1 * qlk
            qcko(i,k) = qc
@@ -1094,44 +1115,44 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
      if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
    enddo
 !
-      totflg = .true.
-      do i=its,ite
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
+   totflg = .true.
+   do i = its,ite
+     totflg = totflg .and. (.not. cnvflg(i))
+   enddo
+   if(totflg) return
 !
 !    estimate the convective overshooting as the level
 !    where the [aafac * cloud work function] becomes zero,
 !    which is the final cloud top
 !
-      do i = its,ite
-        if (cnvflg(i)) then
-          aa2(i) = aafac * aa1(i)
-        endif
-      enddo
-!
-      do i = its,ite
-        flg(i) = cnvflg(i)
-        ktcon1(i) = kmax1
-      enddo
-!
-      do k = kts1, kmax
-        do i = its, ite
-          if (flg(i)) then
-            if(k.ge.ktcon(i).and.k.lt.kmax) then
-              dz1 = zl(i,k+1) - zl(i,k)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              rfact =  1. + fv_ * cp_ * gamma* to(i,k) / hvap_
-              aa2(i) = aa2(i) +dz1 * (g_ / (cp_ * to(i,k)))                    &
+   do i = its,ite
+     if (cnvflg(i)) then
+       aa2(i) = aafac * aa1(i)
+     endif
+   enddo
+!
+   do i = its,ite
+     flg(i) = cnvflg(i)
+     ktcon1(i) = kmax1
+   enddo
+!
+   do k = kts1,kmax
+     do i = its, ite
+       if (flg(i)) then
+         if(k.ge.ktcon(i).and.k.lt.kmax) then
+           dz1 = zl(i,k+1) - zl(i,k)
+           gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+           rfact =  1. + fv_ * cp_ * gamma* to(i,k) / hvap_
+           aa2(i) = aa2(i) +dz1 * (g_ / (cp_ * to(i,k)))                    &
                        * dbyo(i,k) / (1. + gamma)* rfact
-              if(aa2(i).lt.0.) then
-                ktcon1(i) = k
-                flg(i) = .false.
-              endif
-            endif
-          endif
-        enddo
-      enddo
+           if(aa2(i).lt.0.) then
+             ktcon1(i) = k
+             flg(i) = .false.
+           endif
+         endif
+       endif
+     enddo
+   enddo
 !
 !  compute cloud moisture property, detraining cloud water
 !  and precipitation in overshooting layers
@@ -1187,22 +1208,22 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !
 !  compute liquid and vapor separation at cloud top
 ! 
-   do i = its,ite
-     if(cnvflg(i)) then
-     k = ktcon(i)-1
-       gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-       qrch = qeso(i,k)                                                     &
-              + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
-       dq = qcko(i,k) - qrch
+     do i = its,ite
+       if(cnvflg(i)) then
+         k = ktcon(i)-1
+         gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+         qrch = qeso(i,k)                                                      &
+                + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
+         dq = qcko(i,k) - qrch
 !
 !  check if there is excess moisture to release latent heat
 !
-       if(dq.gt.0.) then
-         qlko_ktcon(i) = dq
-         qcko(i,k) = qrch
+         if(dq.gt.0.) then
+           qlko_ktcon(i) = dq
+           qcko(i,k) = qrch
+         endif
        endif
-     endif
-   enddo
+     enddo
    endif
 !
 ! ..... downdraft calculations .....
@@ -1231,6 +1252,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
        e1 = 1.591-.639*vshear(i)                                               &
            +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
        edt(i)  = 1.-e1
+!
        edt(i)  = min(edt(i),.9)
        edt(i)  = max(edt(i),.0)
        edto(i) = edt(i)
@@ -1407,7 +1429,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
    enddo
 !
    totflg = .true.
-   do i=its,ite
+   do i = its,ite
      totflg = totflg .and. (.not. cnvflg(i))
    enddo
    if(totflg) return
@@ -1698,6 +1720,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
    do i = its,ite
      xpwev(i) = 0.
    enddo
+!
    do i = its,ite
      if(cnvflg(i)) then
        jmn = jmin(i)
@@ -1707,7 +1730,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
      endif
    enddo
 !
-   do k = kmax1,kts, -1
+   do k = kmax1,kts,-1
      do i = its,ite
        if(cnvflg(i).and.k.lt.jmin(i)) then
          dz = zi(i,k+2) - zi(i,k+1)
@@ -1725,7 +1748,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
      enddo
    enddo
 !
-   do k = kmax1,kts, -1
+   do k = kmax1,kts,-1
      do i = its,ite
        if(cnvflg(i).and.k.lt.jmin(i)) then
          dq = qeso(i,k)
@@ -1766,7 +1789,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !
 ! downdraft cloudwork functions
 !
-   do k = kmax1,kts, -1
+   do k = kmax1,kts,-1
      do i = its,ite
        if(cnvflg(i).and.k.lt.jmin(i)) then
          gamma = el2orc * qeso(i,k) / to(i,k)**2
@@ -1834,7 +1857,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !
 ! large scale forcing
 !
-   do i= its,ite
+   do i = its,ite
      if(cnvflg(i)) then
        f(i) = (aa1(i) - acrt(i) * acrtfct(i)) / dtconv(i)
        if(f(i).le.0.) cnvflg(i) = .false.
@@ -1968,7 +1991,8 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
                + (aup * pwo(i,k) + adw * edto(i) * pwdo(i,k))                  &
                * xmb(i) * .001 * dt2
        endif
-       if(flg(i).and.k.lt.ktcon(i)) then
+       if(cnvflg(i).and.flg(i).and.k.lt.ktcon(i)) then
+!
          evef = edt(i) * evfacts
          if(slimsk(i).eq.1.) evef = edt(i) * evfactl
          qcond(i) = evef * (q1(i,k) - qeso(i,k)) / (1. + el2orc *              &
@@ -2009,7 +2033,7 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
        else
          ktop(i) = ktcon(i)
          kbot(i) = kbcon(i)
-         kuo(i) = 1
+         icps(i) = 1
        endif
      endif
    enddo
@@ -2047,50 +2071,51 @@ subroutine nsas2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
    endif
 !
    end subroutine nsas2d
-!===============================================================================
-      REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c)
 !-------------------------------------------------------------------------------
-      IMPLICIT NONE
+   REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c)
+!-------------------------------------------------------------------------------
+   IMPLICIT NONE
 !-------------------------------------------------------------------------------
-      REAL :: t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti,      &
+   REAL :: t,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c,dldt,xa,xb,dldti,         &
            xai,xbi,ttp,tr
-      INTEGER :: ice
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-      ttp=t0c+0.01
-      dldt=cvap-cliq
-      xa=-dldt/rv
-      xb=xa+hvap/(rv*ttp)
-      dldti=cvap-cice
-      xai=-dldti/rv
-      xbi=xai+hsub/(rv*ttp)
-      tr=ttp/t
-      if(t.lt.ttp.and.ice.eq.1) then
-        fpvs=psat*(tr**xai)*exp(xbi*(1.-tr))
-      else
-        fpvs=psat*(tr**xa)*exp(xb*(1.-tr))
-      endif
+   INTEGER :: ice
+!
+   ttp=t0c+0.01
+   dldt=cvap-cliq
+   xa=-dldt/rv
+   xb=xa+hvap/(rv*ttp)
+   dldti=cvap-cice
+   xai=-dldti/rv
+   xbi=xai+hsub/(rv*ttp)
+   tr=ttp/t
+   if(t.lt.ttp.and.ice.eq.1) then
+     fpvs=psat*(tr**xai)*exp(xbi*(1.-tr))
+   else
+     fpvs=psat*(tr**xa)*exp(xb*(1.-tr))
+   endif
 !
-      if (t.lt.180.) then
-        tr=ttp/180.
-        if(t.lt.ttp.and.ice.eq.1) then
-          fpvs=psat*(tr**xai)*exp(xbi*(1.-tr))
-        else
-          fpvs=psat*(tr**xa)*exp(xb*(1.-tr))
-        endif
-      endif
+   if (t.lt.180.) then
+     tr=ttp/180.
+     if(t.lt.ttp.and.ice.eq.1) then
+       fpvs=psat*(tr**xai)*exp(xbi*(1.-tr))
+     else
+       fpvs=psat*(tr**xa)*exp(xb*(1.-tr))
+     endif
+   endif
 !
-      if (t.ge.330.) then
-        tr=ttp/330
-        if(t.lt.ttp.and.ice.eq.1) then
-          fpvs=psat*(tr**xai)*exp(xbi*(1.-tr))
-        else
-          fpvs=psat*(tr**xa)*exp(xb*(1.-tr))
-        endif
-      endif
+   if (t.ge.330.) then
+     tr=ttp/330
+     if(t.lt.ttp.and.ice.eq.1) then
+       fpvs=psat*(tr**xai)*exp(xbi*(1.-tr))
+     else
+       fpvs=psat*(tr**xa)*exp(xb*(1.-tr))
+     endif
+   endif
+!
+   END FUNCTION fpvs
+!-------------------------------------------------------------------------------
 !
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-      END FUNCTION fpvs
-!===============================================================================
+!-------------------------------------------------------------------------------
    subroutine nsasinit(rthcuten,rqvcuten,rqccuten,rqicuten,                    &
                       rucuten,rvcuten,                                         &  
                       restart,p_qc,p_qi,p_first_scalar,                        &
@@ -2114,47 +2139,52 @@ subroutine nsasinit(rthcuten,rqvcuten,rqccuten,rqicuten,                    &
                                                               rqccuten,        &
                                                               rqicuten
    integer :: i, j, k, itf, jtf, ktf
+!
    jtf=min0(jte,jde-1)
    ktf=min0(kte,kde-1)
    itf=min0(ite,ide-1)
+!
    if(.not.restart)then
-     do j=jts,jtf
-     do k=kts,ktf
-     do i=its,itf
-       rthcuten(i,k,j)=0.
-       rqvcuten(i,k,j)=0.
-       rucuten(i,k,j)=0.   
-       rvcuten(i,k,j)=0.   
-     enddo
-     enddo
+     do j = jts,jtf
+       do k = kts,ktf
+         do i = its,itf
+           rthcuten(i,k,j)=0.
+           rqvcuten(i,k,j)=0.
+           rucuten(i,k,j)=0.   
+           rvcuten(i,k,j)=0.   
+         enddo
+       enddo
      enddo
+!
      if (p_qc .ge. p_first_scalar) then
-        do j=jts,jtf
-        do k=kts,ktf
-        do i=its,itf
-           rqccuten(i,k,j)=0.
-        enddo
-        enddo
-        enddo
+       do j = jts,jtf
+         do k = kts,ktf
+           do i = its,itf
+             rqccuten(i,k,j)=0.
+           enddo
+         enddo
+       enddo
      endif
+!
      if (p_qi .ge. p_first_scalar) then
-        do j=jts,jtf
-        do k=kts,ktf
-        do i=its,itf
-           rqicuten(i,k,j)=0.
-        enddo
-        enddo
-        enddo
+       do j = jts,jtf
+         do k = kts,ktf
+           do i = its,itf
+             rqicuten(i,k,j)=0.
+           enddo
+         enddo
+       enddo
      endif
    endif
-      end subroutine nsasinit
 !
-!==============================================================================
+   end subroutine nsasinit
+!
+!-------------------------------------------------------------------------------
 ! NCEP SCV (Shallow Convection Scheme)
-!==============================================================================
+!-------------------------------------------------------------------------------
    subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
                  ncloud,qc2,qi2,q1,t1,rain,kbot,ktop,                          &
-                 kuo,                                                          &
+                 icps,                                                         &
                  slimsk,dot,u1,v1,                                             &
                  cp_,cliq_,cvap_,g_,hvap_,rd_,rv_,fv_,ep2,                     &
                  cice,xls,psat,                                                &
@@ -2163,9 +2193,7 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
                  ids,ide, jds,jde, kds,kde,                                    &
                  ims,ime, jms,jme, kms,kme,                                    &
                  its,ite, jts,jte, kts,kte)
-!
 !-------------------------------------------------------------------------------
-!
 ! subprogram:    nscv2d           computes shallow-convective heating and moisng
 !
 ! abstract: computes non-precipitating convective heating and moistening 
@@ -2191,6 +2219,7 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
+!
 !  in/out variables
 !
    integer         ::  ids,ide, jds,jde, kds,kde,                              &
@@ -2216,11 +2245,10 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
                        t1(its:ite,kts:kte),                                    &
                        u1(its:ite,kts:kte),                                    &
                        v1(its:ite,kts:kte)
-   integer         ::  kuo(its:ite)
+   integer         ::  icps(its:ite)
 !
    real            ::  rain(its:ite)
    integer         ::  kbot(its:ite),ktop(its:ite)
-   real            ::  pgcon
 !
 !  local variables and arrays
 !
@@ -2248,7 +2276,8 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
                        val2,    w1,      w1l,     w1s,                         &
                        w2,      w2l,     w2s,     w3,                          &
                        w3l,     w3s,     w4,      w4l,                         &
-                       w4s,     tem,     ptem,    ptem1
+                       w4s,     tem,     ptem,    ptem1,                       &
+                       pgcon
 !
    integer         ::  kb(its:ite), kbcon(its:ite), kbcon1(its:ite),           &
                        ktcon(its:ite), ktcon1(its:ite),                        &
@@ -2298,164 +2327,164 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
    real            ::  el2orc,fact1,fact2,eps
    real,parameter  ::  h1=0.33333333
    real,parameter  ::  tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)
-!
 !-------------------------------------------------------------------------------
-!
    pi_ = 3.14159
    qmin_ = 1.0e-30
    t0c_ = 273.15
    xlv0 = hvap_
-      km1 = kte - 1
+   km1 = kte - 1
 !
 !  compute surface buoyancy flux
 !
-      do k = kts,kte
-        do i = its,ite
-          thx(i,k) = t1(i,k)/prslk(i,k)
-        enddo
-      enddo
+   do k = kts,kte
+     do i = its,ite
+       thx(i,k) = t1(i,k)/prslk(i,k)
+     enddo
+   enddo
 !
-      do i=its,ite
-         tvcon = (1.+fv_*q1(i,1))
-         rhox(i) = prsl(i,1)*1.e3/(rd_*t1(i,1)*tvcon)
-      enddo
+   do i = its,ite
+     tvcon = (1.+fv_*q1(i,1))
+     rhox(i) = prsl(i,1)*1.e3/(rd_*t1(i,1)*tvcon)
+   enddo
 !
-      do i=its,ite
-!        sflx(i) = heat(i)+fv_*t1(i,1)*evap(i)
-         sflx(i) = hfx(i)/rhox(i)/cp_ + qfx(i)/rhox(i)*fv_*thx(i,1)
-      enddo
+   do i = its,ite
+!    sflx(i) = heat(i)+fv_*t1(i,1)*evap(i)
+     sflx(i) = hfx(i)/rhox(i)/cp_ + qfx(i)/rhox(i)*fv_*thx(i,1)
+   enddo
 !
 !  initialize arrays
 !
-      do i=its,ite
-        cnvflg(i) = .true.
-        if(kuo(i).eq.1) cnvflg(i) = .false.
-        if(sflx(i).le.0.) cnvflg(i) = .false.
-        if(cnvflg(i)) then
-          kbot(i)=kte+1
-          ktop(i)=0
-        endif
-        rain(i)=0.
-        kbcon(i)=kte
-        ktcon(i)=1
-        kb(i)=kte
-        pdot(i) = 0.
-        qlko_ktcon(i) = 0.
-        edt(i)  = 0.
-        aa1(i)  = 0.
-        vshear(i) = 0.
-      enddo
-!
-      totflg = .true.
-      do i=its,ite
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!
-      dt2   =  delt
-      val   =         1200.
-      dtmin = max(dt2, val )
-      val   =         3600.
-      dtmax = max(dt2, val )
+   do i = its,ite
+     cnvflg(i) = .true.
+     if(icps(i).eq.1) cnvflg(i) = .false.
+     if(sflx(i).le.0.) cnvflg(i) = .false.
+     if(cnvflg(i)) then
+       kbot(i)=kte+1
+       ktop(i)=0
+     endif
+     rain(i)=0.
+     kbcon(i)=kte
+     ktcon(i)=1
+     kb(i)=kte
+     pdot(i) = 0.
+     qlko_ktcon(i) = 0.
+     edt(i)  = 0.
+     aa1(i)  = 0.
+     vshear(i) = 0.
+   enddo
+!
+   totflg = .true.
+   do i = its,ite
+     totflg = totflg .and. (.not. cnvflg(i))
+   enddo
+   if(totflg) return
+!
+   dt2   =  delt
+   val   =         1200.
+   dtmin = max(dt2, val )
+   val   =         3600.
+   dtmax = max(dt2, val )
+!
 !  model tunable parameters are all here
-      clam    = .3
-      aafac   = .1
-      betaw   = .03
-      evfact  = 0.3
-      evfactl = 0.3
-! namelist parameter...
-!      pgcon   = 0.55    ! Zhang & Wu (2003,JAS)
-      val     =           1.
+!
+   clam    = .3
+   aafac   = .1
+   betaw   = .03
+   evfact  = 0.3
+   evfactl = 0.3
+   val     = 1.
 !
 ! define miscellaneous values
 !
-     el2orc = hvap_*hvap_/(rv_*cp_)
-     eps    = rd_/rv_ 
-     fact1  = (cvap_-cliq_)/rv_
-     fact2  = hvap_/rv_-fact1*t0c_
+   el2orc = hvap_*hvap_/(rv_*cp_)
+   eps    = rd_/rv_ 
+   fact1  = (cvap_-cliq_)/rv_
+   fact2  = hvap_/rv_-fact1*t0c_
 !
-      w1l     = -8.e-3
-      w2l     = -4.e-2
-      w3l     = -5.e-3
-      w4l     = -5.e-4
-      w1s     = -2.e-4
-      w2s     = -2.e-3
-      w3s     = -1.e-3
-      w4s     = -2.e-5
+   w1l     = -8.e-3
+   w2l     = -4.e-2
+   w3l     = -5.e-3
+   w4l     = -5.e-4
+   w1s     = -2.e-4
+   w2s     = -2.e-3
+   w3s     = -1.e-3
+   w4s     = -2.e-5
 !
 !  define top layer for search of the downdraft originating layer
 !  and the maximum thetae for updraft
 !
-      do i=its,ite
-        kbm(i)   = kte
-        kmax(i)  = kte
-      enddo
+   do i = its,ite
+     kbm(i)   = kte
+     kmax(i)  = kte
+   enddo
 !     
-      do k = kts, kte
-        do i=its,ite
-          if (prsl(i,k).gt.prsi(i,1)*0.70) kbm(i) = k + 1
-          if (prsl(i,k).gt.prsi(i,1)*0.60) kmax(i) = k + 1
-        enddo
-      enddo
-      do i=its,ite
-        kbm(i)   = min(kbm(i),kmax(i))
-      enddo
+   do k = kts,kte
+     do i = its,ite
+       if (prsl(i,k).gt.prsi(i,1)*0.70) kbm(i) = k + 1
+       if (prsl(i,k).gt.prsi(i,1)*0.60) kmax(i) = k + 1
+     enddo
+   enddo
+!
+   do i = its,ite
+     kbm(i)   = min(kbm(i),kmax(i))
+   enddo
 !
 !  hydrostatic height assume zero terr and compute
 !  updraft entrainment rate as an inverse function of height
 !
-      do k = kts, km1
-        do i=its,ite
-          xlamue(i,k) = clam / zi(i,k+1)
-        enddo
-      enddo
-      do i=its,ite
-        xlamue(i,kte) = xlamue(i,km1)
-      enddo
+   do k = kts,km1
+     do i = its,ite
+       xlamue(i,k) = clam / zi(i,k+1)
+     enddo
+   enddo
+!
+   do i = its,ite
+     xlamue(i,kte) = xlamue(i,km1)
+   enddo
 !
 !  pbl height
 !
-      do i=its,ite
-        flg(i) = cnvflg(i)
-        kpbl(i)= 1
-      enddo
-!
-      do k = kts+1, km1
-        do i=its,ite
-          if (flg(i).and.zl(i,k).le.hpbl(i)) then 
-            kpbl(i) = k
-          else
-            flg(i) = .false.
-          endif
-        enddo
-      enddo
+   do i = its,ite
+     flg(i) = cnvflg(i)
+     kpbl(i)= 1
+   enddo
+!
+   do k = kts+1,km1
+     do i = its,ite
+       if (flg(i).and.zl(i,k).le.hpbl(i)) then 
+         kpbl(i) = k
+       else
+         flg(i) = .false.
+       endif
+     enddo
+   enddo
 !
-      do i=its,ite
-        kpbl(i)= min(kpbl(i),kbm(i))
-      enddo
+   do i = its,ite
+     kpbl(i)= min(kpbl(i),kbm(i))
+   enddo
 !
 !   convert surface pressure to mb from cb
 !
-      rcs = 1.
-      do k = kts, kte
-        do i =its,ite
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            p(i,k) = prsl(i,k) * 10.0
-            eta(i,k)  = 1.
-            hcko(i,k) = 0.
-            qcko(i,k) = 0.
-            ucko(i,k) = 0.
-            vcko(i,k) = 0.
-            dbyo(i,k) = 0.
-            pwo(i,k)  = 0.
-            dellal(i,k) = 0.
-            to(i,k)   = t1(i,k)
-            qo(i,k)   = q1(i,k)
-            uo(i,k)   = u1(i,k) * rcs
-            vo(i,k)   = v1(i,k) * rcs
-          endif
-        enddo
-      enddo
+   rcs = 1.
+   do k = kts,kte
+     do i = its,ite
+       if (cnvflg(i) .and. k .le. kmax(i)) then
+         p(i,k) = prsl(i,k) * 10.0
+         eta(i,k)  = 1.
+         hcko(i,k) = 0.
+         qcko(i,k) = 0.
+         ucko(i,k) = 0.
+         vcko(i,k) = 0.
+         dbyo(i,k) = 0.
+         pwo(i,k)  = 0.
+         dellal(i,k) = 0.
+         to(i,k)   = t1(i,k)
+         qo(i,k)   = q1(i,k)
+         uo(i,k)   = u1(i,k) * rcs
+         vo(i,k)   = v1(i,k) * rcs
+       endif
+     enddo
+   enddo
 !
 !
 !  column variables
@@ -2465,793 +2494,785 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !  to is temperature at t+dt (k)... this is after advection and turbulan
 !  qo is mixing ratio at t+dt (kg/kg)..q1
 !
-      do k = kts, kte
-        do i=its,ite
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            qeso(i,k) = 0.01 * fpvs(to(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
-            qeso(i,k) = eps * qeso(i,k) / (p(i,k) + (eps-1.)*qeso(i,k))
-            val1      =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val1)
-            val2      =           1.e-10
-            qo(i,k)   = max(qo(i,k), val2 )
-          endif
-        enddo
-      enddo
+   do k = kts, kte
+     do i=its,ite
+       if (cnvflg(i) .and. k .le. kmax(i)) then
+         qeso(i,k) = 0.01 * fpvs(to(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+         qeso(i,k) = eps * qeso(i,k) / (p(i,k) + (eps-1.)*qeso(i,k))
+         val1      =             1.e-8
+         qeso(i,k) = max(qeso(i,k), val1)
+         val2      =           1.e-10
+         qo(i,k)   = max(qo(i,k), val2 )
+       endif
+     enddo
+   enddo
 !
 !  compute moist static energy
 !
-      do k = kts,kte
-        do i=its,ite
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            tem       = g_ * zl(i,k) + cp_ * to(i,k)
-            heo(i,k)  = tem  + hvap_ * qo(i,k)
-            heso(i,k) = tem  + hvap_ * qeso(i,k)
-          endif
-        enddo
-      enddo
+   do k = kts,kte
+     do i=its,ite
+       if (cnvflg(i) .and. k .le. kmax(i)) then
+         tem       = g_ * zl(i,k) + cp_ * to(i,k)
+         heo(i,k)  = tem  + hvap_ * qo(i,k)
+         heso(i,k) = tem  + hvap_ * qeso(i,k)
+       endif
+     enddo
+   enddo
 !
 !  determine level with largest moist static energy within pbl
 !  this is the level where updraft starts
 !
-      do i=its,ite
-         if (cnvflg(i)) then
-            hmax(i) = heo(i,1)
-            kb(i) = 1
+   do i=its,ite
+     if (cnvflg(i)) then
+       hmax(i) = heo(i,1)
+       kb(i) = 1
+     endif
+   enddo
+!
+   do k = kts+1, kte
+     do i=its,ite
+       if (cnvflg(i).and.k.le.kpbl(i)) then
+         if(heo(i,k).gt.hmax(i)) then
+           kb(i)   = k
+           hmax(i) = heo(i,k)
          endif
-      enddo
-!
-      do k = kts+1, kte
-        do i=its,ite
-          if (cnvflg(i).and.k.le.kpbl(i)) then
-            if(heo(i,k).gt.hmax(i)) then
-              kb(i)   = k
-              hmax(i) = heo(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!
-      do k = kts, km1
-        do i=its,ite
-          if (cnvflg(i) .and. k .le. kmax(i)-1) then
-            dz      = .5 * (zl(i,k+1) - zl(i,k))
-            dp      = .5 * (p(i,k+1) - p(i,k))
-            es = 0.01*fpvs(to(i,k+1),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
-            pprime  = p(i,k+1) + (eps-1.) * es
-            qs      = eps * es / pprime
-            dqsdp   = - qs / pprime
-            desdt   = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
-            dqsdt   = qs * p(i,k+1) * desdt / (es * pprime)
-            gamma   = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
-            dt      = (g_ * dz + hvap_ * dqsdp * dp) / (cp_ * (1. + gamma))
-            dq      = dqsdt * dt + dqsdp * dp
-            to(i,k) = to(i,k+1) + dt
-            qo(i,k) = qo(i,k+1) + dq
-            po(i,k) = .5 * (p(i,k) + p(i,k+1))
-          endif
-        enddo
-      enddo
-!
-      do k = kts, km1
-        do i=its,ite
-          if (cnvflg(i) .and. k .le. kmax(i)-1) then
-            qeso(i,k)=0.01*fpvs(to(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
-            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + (eps-1.) * qeso(i,k))
-            val1      =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val1)
-            val2      =           1.e-10
-            qo(i,k)   = max(qo(i,k), val2 )
-            heo(i,k)  = .5 * g_ * (zl(i,k) + zl(i,k+1)) +                      &
+       endif
+     enddo
+   enddo
+!
+   do k = kts, km1
+     do i=its,ite
+       if (cnvflg(i) .and. k .le. kmax(i)-1) then
+         dz      = .5 * (zl(i,k+1) - zl(i,k))
+         dp      = .5 * (p(i,k+1) - p(i,k))
+         es = 0.01*fpvs(to(i,k+1),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+         pprime  = p(i,k+1) + (eps-1.) * es
+         qs      = eps * es / pprime
+         dqsdp   = - qs / pprime
+         desdt   = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+         dqsdt   = qs * p(i,k+1) * desdt / (es * pprime)
+         gamma   = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
+         dt      = (g_ * dz + hvap_ * dqsdp * dp) / (cp_ * (1. + gamma))
+         dq      = dqsdt * dt + dqsdp * dp
+         to(i,k) = to(i,k+1) + dt
+         qo(i,k) = qo(i,k+1) + dq
+         po(i,k) = .5 * (p(i,k) + p(i,k+1))
+       endif
+     enddo
+   enddo
+!
+   do k = kts, km1
+     do i=its,ite
+       if (cnvflg(i) .and. k .le. kmax(i)-1) then
+         qeso(i,k)=0.01*fpvs(to(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+         qeso(i,k) = eps * qeso(i,k) / (po(i,k) + (eps-1.) * qeso(i,k))
+         val1      =             1.e-8
+         qeso(i,k) = max(qeso(i,k), val1)
+         val2      =           1.e-10
+         qo(i,k)   = max(qo(i,k), val2 )
+         heo(i,k)  = .5 * g_ * (zl(i,k) + zl(i,k+1)) +                         &
                         cp_ * to(i,k) + hvap_ * qo(i,k)
-            heso(i,k) = .5 * g_ * (zl(i,k) + zl(i,k+1)) +                      &
+         heso(i,k) = .5 * g_ * (zl(i,k) + zl(i,k+1)) +                         &
                         cp_ * to(i,k) + hvap_ * qeso(i,k)
-            uo(i,k)   = .5 * (uo(i,k) + uo(i,k+1))
-            vo(i,k)   = .5 * (vo(i,k) + vo(i,k+1))
-          endif
-        enddo
-      enddo
+         uo(i,k)   = .5 * (uo(i,k) + uo(i,k+1))
+         vo(i,k)   = .5 * (vo(i,k) + vo(i,k+1))
+       endif
+     enddo
+   enddo
 !
 !  look for the level of free convection as cloud base
 !
-      do i=its,ite
-        flg(i)   = cnvflg(i)
-        if(flg(i)) kbcon(i) = kmax(i)
-      enddo
-!
-      do k = kts+1, km1
-        do i=its,ite
-          if (flg(i).and.k.lt.kbm(i)) then
-            if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then
-              kbcon(i) = k
-              flg(i)   = .false.
-            endif
-          endif
-        enddo
-      enddo
+   do i=its,ite
+     flg(i)   = cnvflg(i)
+     if(flg(i)) kbcon(i) = kmax(i)
+   enddo
 !
-      do i=its,ite
-        if(cnvflg(i)) then
-          if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false.
-        endif
-      enddo
+   do k = kts+1, km1
+     do i=its,ite
+       if (flg(i).and.k.lt.kbm(i)) then
+         if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then
+           kbcon(i) = k
+           flg(i)   = .false.
+         endif
+       endif
+     enddo
+   enddo
+!
+   do i=its,ite
+     if(cnvflg(i)) then
+       if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false.
+     endif
+   enddo
 !
-      totflg = .true.
-      do i=its,ite
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
+   totflg = .true.
+   do i=its,ite
+     totflg = totflg .and. (.not. cnvflg(i))
+   enddo
+   if(totflg) return
 !
 !  determine critical convective inhibition
 !  as a function of vertical velocity at cloud base.
 !
-      do i=its,ite
-        if(cnvflg(i)) then
-          pdot(i)  = 10.* dot(i,kbcon(i))
-        endif
-      enddo
-!
-      do i=its,ite
-        if(cnvflg(i)) then
-          if(slimsk(i).eq.1.) then
-            w1 = w1l
-            w2 = w2l
-            w3 = w3l
-            w4 = w4l
-          else
-            w1 = w1s
-            w2 = w2s
-            w3 = w3s
-            w4 = w4s
-          endif
-          if(pdot(i).le.w4) then
-            ptem = (pdot(i) - w4) / (w3 - w4)
-          elseif(pdot(i).ge.-w4) then
-            ptem = - (pdot(i) + w4) / (w4 - w3)
-          else
-            ptem = 0.
-          endif
-          val1    =             -1.
-          ptem = max(ptem,val1)
-          val2    =             1.
-          ptem = min(ptem,val2)
-          ptem = 1. - ptem
-          ptem1= .5*(cincrmax-cincrmin)
-          cincr = cincrmax - ptem * ptem1
-          tem1 = p(i,kb(i)) - p(i,kbcon(i))
-          if(tem1.gt.cincr) then
-             cnvflg(i) = .false.
-          endif
-        endif
-      enddo
+   do i=its,ite
+     if(cnvflg(i)) then
+       pdot(i)  = 10.* dot(i,kbcon(i))
+     endif
+   enddo
 !
-      totflg = .true.
-      do i=its,ite
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
+   do i=its,ite
+     if(cnvflg(i)) then
+       if(slimsk(i).eq.1.) then
+         w1 = w1l
+         w2 = w2l
+         w3 = w3l
+         w4 = w4l
+       else
+         w1 = w1s
+         w2 = w2s
+         w3 = w3s
+         w4 = w4s
+       endif
+       if(pdot(i).le.w4) then
+         ptem = (pdot(i) - w4) / (w3 - w4)
+       elseif(pdot(i).ge.-w4) then
+         ptem = - (pdot(i) + w4) / (w4 - w3)
+       else
+         ptem = 0.
+       endif
+       val1    =             -1.
+       ptem = max(ptem,val1)
+       val2    =             1.
+       ptem = min(ptem,val2)
+       ptem = 1. - ptem
+       ptem1= .5*(cincrmax-cincrmin)
+       cincr = cincrmax - ptem * ptem1
+       tem1 = p(i,kb(i)) - p(i,kbcon(i))
+       if(tem1.gt.cincr) then
+         cnvflg(i) = .false.
+       endif
+     endif
+   enddo
+!
+   totflg = .true.
+   do i=its,ite
+     totflg = totflg .and. (.not. cnvflg(i))
+   enddo
+   if(totflg) return
 !
 !  assume the detrainment rate for the updrafts to be same as 
 !  the entrainment rate at cloud base
 !
-      do i = its,ite
-        if(cnvflg(i)) then
-          xlamud(i) = xlamue(i,kbcon(i))
-        endif
-      enddo
+   do i = its,ite
+     if(cnvflg(i)) then
+       xlamud(i) = xlamue(i,kbcon(i))
+     endif
+   enddo
 !
 !  determine updraft mass flux for the subcloud layers
 !
-       do k = km1, kts, -1
-        do i = its,ite
-          if (cnvflg(i)) then
-            if(k.lt.kbcon(i).and.k.ge.kb(i)) then
-              dz       = zi(i,k+1) - zi(i,k)
-              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i)
-              eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
-            endif
-          endif
-        enddo
-      enddo
+   do k = km1, kts, -1
+     do i = its,ite
+       if (cnvflg(i)) then
+         if(k.lt.kbcon(i).and.k.ge.kb(i)) then
+           dz       = zi(i,k+1) - zi(i,k)
+           ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i)
+           eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
+         endif
+       endif
+     enddo
+   enddo
 !
 !  compute mass flux above cloud base
 !
-      do k = kts+1, km1
-        do i = its,ite
-         if(cnvflg(i))then
-           if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
-              dz       = zi(i,k) - zi(i,k-1)
-              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i)
-              eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
-           endif
+   do k = kts+1, km1
+     do i = its,ite
+       if(cnvflg(i))then
+         if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
+           dz       = zi(i,k) - zi(i,k-1)
+           ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i)
+           eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
          endif
-        enddo
-      enddo
+       endif
+     enddo
+   enddo
 !
 !  compute updraft cloud property
 !
-      do i = its,ite
-        if(cnvflg(i)) then
-          indx         = kb(i)
-          hcko(i,indx) = heo(i,indx)
-          ucko(i,indx) = uo(i,indx)
-          vcko(i,indx) = vo(i,indx)
-        endif
-      enddo
-!
-      do k = kts+1, km1
-        do i = its,ite
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.kmax(i)) then
-              dz   = zi(i,k) - zi(i,k-1)
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              ptem = 0.5 * tem + pgcon
-              ptem1= 0.5 * tem - pgcon
-              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*                      &
-                          (heo(i,k)+heo(i,k-1)))/factor
-              ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k)                  &
-                          +ptem1*uo(i,k-1))/factor
-              vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k)                  &
-                          +ptem1*vo(i,k-1))/factor
-              dbyo(i,k) = hcko(i,k) - heso(i,k)
-            endif
-          endif
-        enddo
-      enddo
+   do i = its,ite
+     if(cnvflg(i)) then
+       indx         = kb(i)
+       hcko(i,indx) = heo(i,indx)
+       ucko(i,indx) = uo(i,indx)
+       vcko(i,indx) = vo(i,indx)
+     endif
+   enddo
+!
+   do k = kts+1, km1
+     do i = its,ite
+       if (cnvflg(i)) then
+         if(k.gt.kb(i).and.k.lt.kmax(i)) then
+           dz   = zi(i,k) - zi(i,k-1)
+           tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+           tem1 = 0.5 * xlamud(i) * dz
+           factor = 1. + tem - tem1
+           ptem = 0.5 * tem + pgcon
+           ptem1= 0.5 * tem - pgcon
+           hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*                         &
+                       (heo(i,k)+heo(i,k-1)))/factor
+           ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k)                     &
+                       +ptem1*uo(i,k-1))/factor
+           vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k)                     &
+                       +ptem1*vo(i,k-1))/factor
+           dbyo(i,k) = hcko(i,k) - heso(i,k)
+         endif
+       endif
+     enddo
+   enddo
 !
 !   taking account into convection inhibition due to existence of
 !    dry layers below cloud base
 !
-      do i=its,ite
-        flg(i) = cnvflg(i)
-        kbcon1(i) = kmax(i)
-      enddo
-!
-      do k = kts+1, km1
-        do i=its,ite
-          if (flg(i).and.k.lt.kbm(i)) then
-            if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
-              kbcon1(i) = k
-              flg(i)    = .false.
-            endif
-          endif
-        enddo
-      enddo
+   do i=its,ite
+     flg(i) = cnvflg(i)
+     kbcon1(i) = kmax(i)
+   enddo
 !
-      do i=its,ite
-        if(cnvflg(i)) then
-          if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false.
-        endif
-      enddo
+   do k = kts+1, km1
+     do i=its,ite
+       if (flg(i).and.k.lt.kbm(i)) then
+         if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
+           kbcon1(i) = k
+           flg(i)    = .false.
+         endif
+       endif
+     enddo
+   enddo
 !
-      do i=its,ite
-        if(cnvflg(i)) then
-          tem = p(i,kbcon(i)) - p(i,kbcon1(i))
-          if(tem.gt.dthk) then
-             cnvflg(i) = .false.
-          endif
-        endif
-      enddo
+   do i=its,ite
+     if(cnvflg(i)) then
+       if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false.
+     endif
+   enddo
 !
-      totflg = .true.
-      do i = its,ite
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
+   do i=its,ite
+     if(cnvflg(i)) then
+       tem = p(i,kbcon(i)) - p(i,kbcon1(i))
+       if(tem.gt.dthk) then
+         cnvflg(i) = .false.
+       endif
+     endif
+   enddo
+!
+   totflg = .true.
+   do i = its,ite
+     totflg = totflg .and. (.not. cnvflg(i))
+   enddo
+   if(totflg) return
 !
 !  determine first guess cloud top as the level of zero buoyancy
 !    limited to the level of sigma=0.7
 !
-      do i = its,ite
-        flg(i) = cnvflg(i)
-        if(flg(i)) ktcon(i) = kbm(i)
-      enddo
-!
-      do k = kts+1, km1
-        do i=its,ite
-          if (flg(i).and.k .lt. kbm(i)) then
-            if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then
-               ktcon(i) = k
-               flg(i)   = .false.
-            endif
-          endif
-        enddo
-      enddo
+   do i = its,ite
+     flg(i) = cnvflg(i)
+     if(flg(i)) ktcon(i) = kbm(i)
+   enddo
+!
+   do k = kts+1, km1
+     do i=its,ite
+       if (flg(i).and.k .lt. kbm(i)) then
+         if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then
+           ktcon(i) = k
+           flg(i)   = .false.
+         endif
+       endif
+     enddo
+   enddo
 !
 !  specify upper limit of mass flux at cloud base
 !
-      do i = its,ite
-        if(cnvflg(i)) then
-          k = kbcon(i)
-          dp = 1000. * del(i,k)
-          xmbmax(i) = dp / (g_ * dt2)
-        endif
-      enddo
+   do i = its,ite
+     if(cnvflg(i)) then
+       k = kbcon(i)
+       dp = 1000. * del(i,k)
+       xmbmax(i) = dp / (g_ * dt2)
+     endif
+   enddo
 !
 !  compute cloud moisture property and precipitation
 !
-      do i = its,ite
-        if (cnvflg(i)) then
-          aa1(i) = 0.
-          qcko(i,kb(i)) = qo(i,kb(i))
-        endif
-      enddo
-!
-      do k = kts+1, km1
-        do i = its,ite
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
-              dz    = zi(i,k) - zi(i,k-1)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrch = qeso(i,k)                                                 &
-                   + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                      &
-                          (qo(i,k)+qo(i,k-1)))/factor
-              dq = eta(i,k) * (qcko(i,k) - qrch)
-!
-!             rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k)
+   do i = its,ite
+     if (cnvflg(i)) then
+       aa1(i) = 0.
+       qcko(i,kb(i)) = qo(i,kb(i))
+     endif
+   enddo
+!
+   do k = kts+1, km1
+     do i = its,ite
+       if (cnvflg(i)) then
+         if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+           dz    = zi(i,k) - zi(i,k-1)
+           gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+           qrch = qeso(i,k) + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
+           tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+           tem1 = 0.5 * xlamud(i) * dz
+           factor = 1. + tem - tem1
+           qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                         &
+                       (qo(i,k)+qo(i,k-1)))/factor
+           dq = eta(i,k) * (qcko(i,k) - qrch)
+!
+!          rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k)
 !
 !  below lfc check if there is excess moisture to release latent heat
 !
-              if(k.ge.kbcon(i).and.dq.gt.0.) then
-                etah = .5 * (eta(i,k) + eta(i,k-1))
-                if(ncloud.gt.0) then
-                  dp = 1000. * del(i,k)
-                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
-                  dellal(i,k) = etah * c1 * dz * qlk * g_ / dp
-                else
-                  qlk = dq / (eta(i,k) + etah * c0 * dz)
-                endif
-                aa1(i) = aa1(i) - dz * g_ * qlk
-                qcko(i,k)= qlk + qrch
-                pwo(i,k) = etah * c0 * dz * qlk
-              endif
-            endif
-          endif
-        enddo
-      enddo
+           if(k.ge.kbcon(i).and.dq.gt.0.) then
+             etah = .5 * (eta(i,k) + eta(i,k-1))
+             if(ncloud.gt.0) then
+               dp = 1000. * del(i,k)
+               qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+               dellal(i,k) = etah * c1 * dz * qlk * g_ / dp
+             else
+               qlk = dq / (eta(i,k) + etah * c0 * dz)
+             endif
+             aa1(i) = aa1(i) - dz * g_ * qlk
+             qcko(i,k)= qlk + qrch
+             pwo(i,k) = etah * c0 * dz * qlk
+           endif
+         endif
+       endif
+     enddo
+   enddo
 !
 !  calculate cloud work function
 !
-      do k = kts+1, km1
-        do i = its,ite
-          if (cnvflg(i)) then
-            if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
-              dz1 = zl(i,k+1) - zl(i,k)        
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              rfact =  1. + fv_ * cp_ * gamma                                  &
-                      * to(i,k) / hvap_
-              aa1(i) = aa1(i) + dz1 * (g_ / (cp_ * to(i,k)))                   &
-                      * dbyo(i,k) / (1. + gamma) * rfact
-              val = 0.
-              aa1(i)=aa1(i)+ dz1 * g_ * fv_ *                                  &
-                      max(val,(qeso(i,k) - qo(i,k)))
-            endif
-          endif
-        enddo
-      enddo
+   do k = kts+1, km1
+     do i = its,ite
+       if (cnvflg(i)) then
+         if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+           dz1 = zl(i,k+1) - zl(i,k)        
+           gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+           rfact =  1. + fv_ * cp_ * gamma * to(i,k) / hvap_
+           aa1(i) = aa1(i) + dz1 * (g_ / (cp_ * to(i,k)))                      &
+                  * dbyo(i,k) / (1. + gamma) * rfact
+           val = 0.
+           aa1(i)=aa1(i)+ dz1 * g_ * fv_ * max(val,(qeso(i,k) - qo(i,k)))
+         endif
+       endif
+     enddo
+   enddo
 !
-      do i = its,ite
-        if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
-      enddo
+   do i = its,ite
+     if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
+   enddo
 !
-      totflg = .true.
-      do i=its,ite
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
+   totflg = .true.
+   do i=its,ite
+     totflg = totflg .and. (.not. cnvflg(i))
+   enddo
+   if(totflg) return
 !
 !  estimate the convective overshooting as the level
 !    where the [aafac * cloud work function] becomes zero,
 !    which is the final cloud top limited to the level of sigma=0.7
 !
-      do i = its,ite
-        if (cnvflg(i)) then
-          aa1(i) = aafac * aa1(i)
-        endif
-      enddo
-!
-      do i = its,ite
-        flg(i) = cnvflg(i)
-        ktcon1(i) = kbm(i)
-      enddo
-!
-      do k = kts+1, km1
-        do i = its,ite
-          if (flg(i)) then
-            if(k.ge.ktcon(i).and.k.lt.kbm(i)) then
-              dz1 = zl(i,k+1) - zl(i,k)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              rfact =  1. + fv_ * cp_ * gamma                                  &
-                      * to(i,k) / hvap_
-              aa1(i) = aa1(i) +                                                &
-                      dz1 * (g_ / (cp_ * to(i,k)))                             &
-                      * dbyo(i,k) / (1. + gamma) * rfact
-              if(aa1(i).lt.0.) then
-                ktcon1(i) = k
-                flg(i) = .false.
-              endif
-            endif
-          endif
-        enddo
-      enddo
+   do i = its,ite
+     if (cnvflg(i)) then
+       aa1(i) = aafac * aa1(i)
+     endif
+   enddo
+!
+   do i = its,ite
+     flg(i) = cnvflg(i)
+     ktcon1(i) = kbm(i)
+   enddo
+!
+   do k = kts+1,km1
+     do i = its,ite
+       if (flg(i)) then
+         if(k.ge.ktcon(i).and.k.lt.kbm(i)) then
+           dz1 = zl(i,k+1) - zl(i,k)
+           gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+           rfact =  1. + fv_ * cp_ * gamma                                     &
+                   * to(i,k) / hvap_
+           aa1(i) = aa1(i) +                                                   &
+                   dz1 * (g_ / (cp_ * to(i,k)))                                &
+                   * dbyo(i,k) / (1. + gamma) * rfact
+           if(aa1(i).lt.0.) then
+             ktcon1(i) = k
+             flg(i) = .false.
+           endif
+         endif
+       endif
+     enddo
+   enddo
 !
 !  compute cloud moisture property, detraining cloud water
 !    and precipitation in overshooting layers
 !
-      do k = kts+1, km1
-        do i = its,ite
-          if (cnvflg(i)) then
-            if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
-              dz    = zi(i,k) - zi(i,k-1)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrch = qeso(i,k)                                                 &
-                   + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                      &
-                          (qo(i,k)+qo(i,k-1)))/factor
-              dq = eta(i,k) * (qcko(i,k) - qrch)
+   do k = kts+1,km1
+     do i = its,ite
+       if (cnvflg(i)) then
+         if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
+           dz    = zi(i,k) - zi(i,k-1)
+           gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+           qrch = qeso(i,k)                                                    &
+                + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
+           tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+           tem1 = 0.5 * xlamud(i) * dz
+           factor = 1. + tem - tem1
+           qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                         &
+                       (qo(i,k)+qo(i,k-1)))/factor
+           dq = eta(i,k) * (qcko(i,k) - qrch)
 !
 !  check if there is excess moisture to release latent heat
 !
-              if(dq.gt.0.) then
-                etah = .5 * (eta(i,k) + eta(i,k-1))
-                if(ncloud.gt.0) then
-                  dp = 1000. * del(i,k)
-                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
-                  dellal(i,k) = etah * c1 * dz * qlk * g_ / dp
-                else
-                  qlk = dq / (eta(i,k) + etah * c0 * dz)
-                endif
-                qcko(i,k) = qlk + qrch
-                pwo(i,k) = etah * c0 * dz * qlk
-              endif
-            endif
-          endif
-        enddo
-      enddo
+           if(dq.gt.0.) then
+             etah = .5 * (eta(i,k) + eta(i,k-1))
+             if(ncloud.gt.0) then
+               dp = 1000. * del(i,k)
+               qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
+               dellal(i,k) = etah * c1 * dz * qlk * g_ / dp
+             else
+               qlk = dq / (eta(i,k) + etah * c0 * dz)
+             endif
+             qcko(i,k) = qlk + qrch
+             pwo(i,k) = etah * c0 * dz * qlk
+           endif
+         endif
+       endif
+     enddo
+   enddo
 !
 ! exchange ktcon with ktcon1
 !
-      do i = its,ite
-        if(cnvflg(i)) then
-          kk = ktcon(i)
-          ktcon(i) = ktcon1(i)
-          ktcon1(i) = kk
-        endif
-      enddo
+   do i = its,ite
+     if(cnvflg(i)) then
+       kk = ktcon(i)
+       ktcon(i) = ktcon1(i)
+       ktcon1(i) = kk
+     endif
+   enddo
 !
 !  this section is ready for cloud water
 !
-      if(ncloud.gt.0) then
+   if(ncloud.gt.0) then
 !
 !  compute liquid and vapor separation at cloud top
 !
-      do i = its,ite
-        if(cnvflg(i)) then
-          k = ktcon(i) - 1
-          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-          qrch = qeso(i,k)                                                     &
-               + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
-          dq = qcko(i,k) - qrch
+     do i = its,ite
+       if(cnvflg(i)) then
+         k = ktcon(i) - 1
+         gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+         qrch = qeso(i,k)                                                      &
+              + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
+         dq = qcko(i,k) - qrch
 !
 !  check if there is excess moisture to release latent heat
 !
-          if(dq.gt.0.) then
-            qlko_ktcon(i) = dq
-            qcko(i,k) = qrch
-          endif
-        endif
-      enddo
+         if(dq.gt.0.) then
+           qlko_ktcon(i) = dq
+           qcko(i,k) = qrch
+         endif
+       endif
+     enddo
 !
-      endif
+   endif
 !
 !--- compute precipitation efficiency in terms of windshear
 !
-      do i = its,ite
-        if(cnvflg(i)) then
-          vshear(i) = 0.
-        endif
-      enddo
-!
-      do k = kts+1,kte
-        do i = its,ite
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.le.ktcon(i)) then
-              shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2                             &
-                        + (vo(i,k)-vo(i,k-1)) ** 2)
-              vshear(i) = vshear(i) + shear
-            endif
-          endif
-        enddo
-      enddo
+   do i = its,ite
+     if(cnvflg(i)) then
+       vshear(i) = 0.
+     endif
+   enddo
+!
+   do k = kts+1,kte
+     do i = its,ite
+       if (cnvflg(i)) then
+         if(k.gt.kb(i).and.k.le.ktcon(i)) then
+           shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2 + (vo(i,k)-vo(i,k-1)) ** 2)
+           vshear(i) = vshear(i) + shear
+         endif
+       endif
+     enddo
+   enddo
 !
-      do i = its,ite
-        if(cnvflg(i)) then
-          vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
-          e1=1.591-.639*vshear(i)                                              &
+   do i = its,ite
+     if(cnvflg(i)) then
+       vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
+       e1=1.591-.639*vshear(i)                                                 &
              +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
-          edt(i)=1.-e1
-          val =         .9
-          edt(i) = min(edt(i),val)
-          val =         .0
-          edt(i) = max(edt(i),val)
-        endif
-      enddo
+       edt(i)=1.-e1
+       val =         .9
+       edt(i) = min(edt(i),val)
+       val =         .0
+       edt(i) = max(edt(i),val)
+     endif
+   enddo
 !
 !--- what would the change be, that a cloud with unit mass
 !--- will do to the environment?
 !
-      do k = kts,kte
-        do i = its,ite
-          if(cnvflg(i) .and. k .le. kmax(i)) then
-            dellah(i,k) = 0.
-            dellaq(i,k) = 0.
-            dellau(i,k) = 0.
-            dellav(i,k) = 0.
-          endif
-        enddo
-      enddo
+   do k = kts,kte
+     do i = its,ite
+       if(cnvflg(i) .and. k .le. kmax(i)) then
+         dellah(i,k) = 0.
+         dellaq(i,k) = 0.
+         dellau(i,k) = 0.
+         dellav(i,k) = 0.
+       endif
+     enddo
+   enddo
 !
 !--- changed due to subsidence and entrainment
 !
-      do k = kts+1, km1
-        do i = its,ite
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
-              dp = 1000. * del(i,k)
-              dz = zi(i,k) - zi(i,k-1)
-!
-              dv1h = heo(i,k)
-              dv2h = .5 * (heo(i,k) + heo(i,k-1))
-              dv3h = heo(i,k-1)
-              dv1q = qo(i,k)
-              dv2q = .5 * (qo(i,k) + qo(i,k-1))
-              dv3q = qo(i,k-1)
-              dv1u = uo(i,k)
-              dv2u = .5 * (uo(i,k) + uo(i,k-1))
-              dv3u = uo(i,k-1)
-              dv1v = vo(i,k)
-              dv2v = .5 * (vo(i,k) + vo(i,k-1))
-              dv3v = vo(i,k-1)
-!
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1))
-              tem1 = xlamud(i)
-!
-              dellah(i,k) = dellah(i,k) +                                      &
+   do k = kts+1,km1
+     do i = its,ite
+       if (cnvflg(i)) then
+         if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+           dp = 1000. * del(i,k)
+           dz = zi(i,k) - zi(i,k-1)
+!
+           dv1h = heo(i,k)
+           dv2h = .5 * (heo(i,k) + heo(i,k-1))
+           dv3h = heo(i,k-1)
+           dv1q = qo(i,k)
+           dv2q = .5 * (qo(i,k) + qo(i,k-1))
+           dv3q = qo(i,k-1)
+           dv1u = uo(i,k)
+           dv2u = .5 * (uo(i,k) + uo(i,k-1))
+           dv3u = uo(i,k-1)
+           dv1v = vo(i,k)
+           dv2v = .5 * (vo(i,k) + vo(i,k-1))
+           dv3v = vo(i,k-1)
+!
+           tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1))
+           tem1 = xlamud(i)
+!
+           dellah(i,k) = dellah(i,k) +                                         &
           ( eta(i,k)*dv1h - eta(i,k-1)*dv3h                                    &
          -  tem*eta(i,k-1)*dv2h*dz                                             &
-         +  tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz                      &
-              ) *g_/dp
+         +  tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz ) *g_/dp
 !
-              dellaq(i,k) = dellaq(i,k) +                                      &
+           dellaq(i,k) = dellaq(i,k) +                                         &
           ( eta(i,k)*dv1q - eta(i,k-1)*dv3q                                    &
          -  tem*eta(i,k-1)*dv2q*dz                                             &
-         +  tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz                      &
-              ) *g_/dp
+         +  tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz ) *g_/dp
 !
-              dellau(i,k) = dellau(i,k) +                                      &
+           dellau(i,k) = dellau(i,k) +                                         &
           ( eta(i,k)*dv1u - eta(i,k-1)*dv3u                                    &
          -  tem*eta(i,k-1)*dv2u*dz                                             &
          +  tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz                      &
-         -  pgcon*eta(i,k-1)*(dv1u-dv3u)                                       &
-              ) *g_/dp
+         -  pgcon*eta(i,k-1)*(dv1u-dv3u) ) *g_/dp
 !
-              dellav(i,k) = dellav(i,k) +                                      &
+           dellav(i,k) = dellav(i,k) +                                         &
           ( eta(i,k)*dv1v - eta(i,k-1)*dv3v                                    &
          -  tem*eta(i,k-1)*dv2v*dz                                             &
          +  tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz                      &
-         -  pgcon*eta(i,k-1)*(dv1v-dv3v)                                       &
-              ) *g_/dp
+         -  pgcon*eta(i,k-1)*(dv1v-dv3v) ) *g_/dp
 !
-            endif
-          endif
-        enddo
-      enddo
+         endif
+       endif
+     enddo
+   enddo
 !
 !------- cloud top
 !
-      do i = its,ite
-        if(cnvflg(i)) then
-          indx = ktcon(i)
-          dp = 1000. * del(i,indx)
-          dv1h = heo(i,indx-1)
-          dellah(i,indx) = eta(i,indx-1) *                                     &
-                          (hcko(i,indx-1) - dv1h) * g_ / dp
-          dv1q = qo(i,indx-1)
-          dellaq(i,indx) = eta(i,indx-1) *                                     &
-                          (qcko(i,indx-1) - dv1q) * g_ / dp
-          dv1u = uo(i,indx-1)
-          dellau(i,indx) = eta(i,indx-1) *                                     &
-                          (ucko(i,indx-1) - dv1u) * g_ / dp
-          dv1v = vo(i,indx-1)
-          dellav(i,indx) = eta(i,indx-1) *                                     &
-                          (vcko(i,indx-1) - dv1v) * g_ / dp
+   do i = its,ite
+     if(cnvflg(i)) then
+       indx = ktcon(i)
+       dp = 1000. * del(i,indx)
+       dv1h = heo(i,indx-1)
+       dellah(i,indx) = eta(i,indx-1) *                                        &
+                       (hcko(i,indx-1) - dv1h) * g_ / dp
+       dv1q = qo(i,indx-1)
+       dellaq(i,indx) = eta(i,indx-1) *                                        &
+                       (qcko(i,indx-1) - dv1q) * g_ / dp
+       dv1u = uo(i,indx-1)
+       dellau(i,indx) = eta(i,indx-1) *                                        &
+                       (ucko(i,indx-1) - dv1u) * g_ / dp
+       dv1v = vo(i,indx-1)
+       dellav(i,indx) = eta(i,indx-1) *                                        &
+                       (vcko(i,indx-1) - dv1v) * g_ / dp
 !
 !  cloud water
 !
-          dellal(i,indx) = eta(i,indx-1) *                                     &
-                          qlko_ktcon(i) * g_ / dp
-        endif
-      enddo
+       dellal(i,indx) = eta(i,indx-1) *                                        &
+                       qlko_ktcon(i) * g_ / dp
+     endif
+   enddo
 !
 !  mass flux at cloud base for shallow convection
 !  (Grant, 2001)
 !
-      do i= its,ite
-        if(cnvflg(i)) then
-          k = kbcon(i)
-          ptem = g_*sflx(i)*hpbl(i)/t1(i,1)
-          wstar(i) = ptem**h1
-          tem = po(i,k)*100. / (rd_*t1(i,k))
-          xmb(i) = betaw*tem*wstar(i)
-          xmb(i) = min(xmb(i),xmbmax(i))
-        endif
-      enddo
-!
-      do k = kts,kte
-        do i = its,ite
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            qeso(i,k)=0.01* fpvs(t1(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
-            qeso(i,k) = eps * qeso(i,k) / (p(i,k) + (eps-1.)*qeso(i,k))
-            val     =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val )
-          endif
-        enddo
-      enddo
-!
-      do i = its,ite
-        delhbar(i) = 0.
-        delqbar(i) = 0.
-        deltbar(i) = 0.
-        delubar(i) = 0.
-        delvbar(i) = 0.
-        qcond(i) = 0.
-      enddo
-!
-      do k = kts,kte
-        do i = its,ite
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.le.ktcon(i)) then
-              dellat = (dellah(i,k) - hvap_ * dellaq(i,k)) / cp_
-              t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2
-              q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2
-              tem = 1./rcs
-              u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem
-              v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem
-              dp = 1000. * del(i,k)
-              delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g_
-              delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g_
-              deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g_
-              delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g_
-              delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g_
-            endif
-          endif
-        enddo
-      enddo
-!
-      do k = kts,kte
-        do i = its,ite
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.le.ktcon(i)) then
-              qeso(i,k)=0.01* fpvs(t1(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls &
-                        ,psat,t0c_)
-              qeso(i,k) = eps * qeso(i,k)/(p(i,k) + (eps-1.)*qeso(i,k))
-              val     =             1.e-8
-              qeso(i,k) = max(qeso(i,k), val )
-            endif
-          endif
-        enddo
-      enddo
-!
-      do i = its,ite
-        rntot(i) = 0.
-        delqev(i) = 0.
-        delq2(i) = 0.
-        flg(i) = cnvflg(i)
-      enddo
-!
-      do k = kte, kts, -1
-        do i = its,ite
-          if (cnvflg(i)) then
-            if(k.lt.ktcon(i).and.k.gt.kb(i)) then
-              rntot(i) = rntot(i) + pwo(i,k) * xmb(i) * .001 * dt2
-            endif
-          endif
-        enddo
-      enddo
+   do i= its,ite
+     if(cnvflg(i)) then
+       k = kbcon(i)
+       ptem = g_*sflx(i)*hpbl(i)/t1(i,1)
+       wstar(i) = ptem**h1
+       tem = po(i,k)*100. / (rd_*t1(i,k))
+       xmb(i) = betaw*tem*wstar(i)
+       xmb(i) = min(xmb(i),xmbmax(i))
+     endif
+   enddo
+!
+   do k = kts,kte
+     do i = its,ite
+       if (cnvflg(i) .and. k .le. kmax(i)) then
+         qeso(i,k)=0.01* fpvs(t1(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls,psat,t0c_)
+         qeso(i,k) = eps * qeso(i,k) / (p(i,k) + (eps-1.)*qeso(i,k))
+         val     =             1.e-8
+         qeso(i,k) = max(qeso(i,k), val )
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     delhbar(i) = 0.
+     delqbar(i) = 0.
+     deltbar(i) = 0.
+     delubar(i) = 0.
+     delvbar(i) = 0.
+     qcond(i) = 0.
+   enddo
+!
+   do k = kts,kte
+     do i = its,ite
+       if (cnvflg(i)) then
+         if(k.gt.kb(i).and.k.le.ktcon(i)) then
+           dellat = (dellah(i,k) - hvap_ * dellaq(i,k)) / cp_
+           t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2
+           q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2
+           tem = 1./rcs
+           u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem
+           v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem
+           dp = 1000. * del(i,k)
+           delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g_
+           delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g_
+           deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g_
+           delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g_
+           delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g_
+         endif
+       endif
+     enddo
+   enddo
+!
+   do k = kts,kte
+     do i = its,ite
+       if (cnvflg(i)) then
+         if(k.gt.kb(i).and.k.le.ktcon(i)) then
+           qeso(i,k)=0.01* fpvs(t1(i,k),1,rd_,rv_,cvap_,cliq_,cice,xlv0,xls    &
+                     ,psat,t0c_)
+           qeso(i,k) = eps * qeso(i,k)/(p(i,k) + (eps-1.)*qeso(i,k))
+           val     =             1.e-8
+           qeso(i,k) = max(qeso(i,k), val )
+         endif
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     rntot(i) = 0.
+     delqev(i) = 0.
+     delq2(i) = 0.
+     flg(i) = cnvflg(i)
+   enddo
+!
+   do k = kte,kts,-1
+     do i = its,ite
+       if (cnvflg(i)) then
+         if(k.lt.ktcon(i).and.k.gt.kb(i)) then
+           rntot(i) = rntot(i) + pwo(i,k) * xmb(i) * .001 * dt2
+         endif
+       endif
+     enddo
+   enddo
 !
 ! evaporating rain
 !
-      do k = kte, kts, -1
-        do i = its,ite
-          if (k .le. kmax(i)) then
-            deltv(i) = 0.
-            delq(i) = 0.
-            qevap(i) = 0.
-            if(cnvflg(i)) then
-              if(k.lt.ktcon(i).and.k.gt.kb(i)) then
-                rain(i) = rain(i) + pwo(i,k) * xmb(i) * .001 * dt2
-              endif
-            endif
-            if(flg(i).and.k.lt.ktcon(i)) then
-              evef = edt(i) * evfact
-              if(slimsk(i).eq.1.) evef=edt(i) * evfactl
-              qcond(i) = evef * (q1(i,k) - qeso(i,k))                          &
-                       / (1. + el2orc * qeso(i,k) / t1(i,k)**2)
-              dp = 1000. * del(i,k)
-              if(rain(i).gt.0..and.qcond(i).lt.0.) then
-                qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rain(i))))
-                qevap(i) = min(qevap(i), rain(i)*1000.*g_/dp)
-                delq2(i) = delqev(i) + .001 * qevap(i) * dp / g_
-              endif
-              if(rain(i).gt.0..and.qcond(i).lt.0..and.                         &
-                 delq2(i).gt.rntot(i)) then
-                qevap(i) = 1000.* g_ * (rntot(i) - delqev(i)) / dp
-                flg(i) = .false.
-              endif
-              if(rain(i).gt.0..and.qevap(i).gt.0.) then
-                tem  = .001 * dp / g_
-                tem1 = qevap(i) * tem
-                if(tem1.gt.rain(i)) then
-                  qevap(i) = rain(i) / tem
-                  rain(i) = 0.
-                else
-                  rain(i) = rain(i) - tem1
-                endif
-                q1(i,k) = q1(i,k) + qevap(i)
-                t1(i,k) = t1(i,k) - (hvap_/cp_) * qevap(i)
-                deltv(i) = - (hvap_/cp_)*qevap(i)/dt2
-                delq(i) =  + qevap(i)/dt2
-                delqev(i) = delqev(i) + .001*dp*qevap(i)/g_
-              endif
-              dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i)
-              delqbar(i) = delqbar(i) + delq(i)*dp/g_
-              deltbar(i) = deltbar(i) + deltv(i)*dp/g_
-            endif
-          endif
-        enddo
-      enddo
-!
-      do i = its,ite
-        if(cnvflg(i)) then
-          if(rain(i).lt.0..or..not.flg(i)) rain(i) = 0.
-          ktop(i) = ktcon(i)
-          kbot(i) = kbcon(i)
-          kuo(i) = 0
-        endif
-      enddo
+   do k = kte,kts,-1
+     do i = its,ite
+       if (k .le. kmax(i)) then
+         deltv(i) = 0.
+         delq(i) = 0.
+         qevap(i) = 0.
+         if(cnvflg(i)) then
+           if(k.lt.ktcon(i).and.k.gt.kb(i)) then
+             rain(i) = rain(i) + pwo(i,k) * xmb(i) * .001 * dt2
+           endif
+         endif
+         if(flg(i).and.k.lt.ktcon(i)) then
+           evef = edt(i) * evfact
+           if(slimsk(i).eq.1.) evef=edt(i) * evfactl
+           qcond(i) = evef * (q1(i,k) - qeso(i,k))                             &
+                    / (1. + el2orc * qeso(i,k) / t1(i,k)**2)
+           dp = 1000. * del(i,k)
+           if(rain(i).gt.0..and.qcond(i).lt.0.) then
+             qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rain(i))))
+             qevap(i) = min(qevap(i), rain(i)*1000.*g_/dp)
+             delq2(i) = delqev(i) + .001 * qevap(i) * dp / g_
+           endif
+           if(rain(i).gt.0..and.qcond(i).lt.0..and.delq2(i).gt.rntot(i)) then
+             qevap(i) = 1000.* g_ * (rntot(i) - delqev(i)) / dp
+             flg(i) = .false.
+           endif
+           if(rain(i).gt.0..and.qevap(i).gt.0.) then
+             tem  = .001 * dp / g_
+             tem1 = qevap(i) * tem
+             if(tem1.gt.rain(i)) then
+               qevap(i) = rain(i) / tem
+               rain(i) = 0.
+             else
+               rain(i) = rain(i) - tem1
+             endif
+             q1(i,k) = q1(i,k) + qevap(i)
+             t1(i,k) = t1(i,k) - (hvap_/cp_) * qevap(i)
+             deltv(i) = - (hvap_/cp_)*qevap(i)/dt2
+             delq(i) =  + qevap(i)/dt2
+             delqev(i) = delqev(i) + .001*dp*qevap(i)/g_
+           endif
+           dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i)
+           delqbar(i) = delqbar(i) + delq(i)*dp/g_
+           deltbar(i) = deltbar(i) + deltv(i)*dp/g_
+         endif
+       endif
+     enddo
+   enddo
+!
+   do i = its,ite
+     if(cnvflg(i)) then
+       if(rain(i).lt.0..or..not.flg(i)) rain(i) = 0.
+       ktop(i) = ktcon(i)
+       kbot(i) = kbcon(i)
+       icps(i) = 0
+     endif
+   enddo
 !
 ! cloud water
 !
-      if (ncloud.gt.0) then
-!
-      do k = kts, km1
-        do i = its,ite
-          if (cnvflg(i)) then
-            if (k.ge.kbcon(i).and.k.le.ktcon(i)) then
-              tem  = dellal(i,k) * xmb(i) * dt2
-              tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf))
-              if (ncloud.ge.4) then
-                qi2(i,k) = qi2(i,k) + tem * tem1            ! ice
-                qc2(i,k) = qc2(i,k) + tem *(1.0-tem1)       ! water
-              else
-                qc2(i,k) = qc2(i,k) + tem
-              endif
-            endif
-          endif
-        enddo
-      enddo
+   if (ncloud.gt.0) then
 !
-      endif
+     do k = kts,km1
+       do i = its,ite
+         if (cnvflg(i)) then
+           if (k.ge.kbcon(i).and.k.le.ktcon(i)) then
+             tem  = dellal(i,k) * xmb(i) * dt2
+             tem1 = max(0.0, min(1.0, (tcr-t1(i,k))*tcrf))
+             if (ncloud.ge.2) then
+               qi2(i,k) = qi2(i,k) + tem * tem1            ! ice
+               qc2(i,k) = qc2(i,k) + tem *(1.0-tem1)       ! water
+             else
+               qc2(i,k) = qc2(i,k) + tem
+             endif
+           endif
+         endif
+       enddo
+     enddo
+!
+   endif
 !
       end subroutine nscv2d
 !-------------------------------------------------------------------------------
 !
 END MODULE module_cu_nsas
+!
diff --git a/wrfv2_fire/phys/module_cu_tiedtke.F b/wrfv2_fire/phys/module_cu_tiedtke.F
index f1b32fc2..61a6e824 100644
--- a/wrfv2_fire/phys/module_cu_tiedtke.F
+++ b/wrfv2_fire/phys/module_cu_tiedtke.F
@@ -2043,7 +2043,7 @@ SUBROUTINE CUASC_NEW &
 ! New scheme
 ! Let's define the fscale
         else if(orgen .eq. 2 ) then
-        tt(jl) = ptenh(jl,ikb)
+        tt(jl) = ptenh(jl,ikb-1)
         zqsat(jl) = TLUCUA(tt(jl))/paph(jl,ikb-1)
         zqsat(jl) = zqsat(jl)/(1.-VTMPC1*zqsat(jl))
         ttb(jl) = ptenh(jl,ikb)
diff --git a/wrfv2_fire/phys/module_cumulus_driver.F b/wrfv2_fire/phys/module_cumulus_driver.F
index 97702181..f6ad0d5d 100644
--- a/wrfv2_fire/phys/module_cumulus_driver.F
+++ b/wrfv2_fire/phys/module_cumulus_driver.F
@@ -17,6 +17,8 @@ SUBROUTINE cumulus_driver(grid                                     &
                      ,itimestep,dt,dx,cudt,curr_secs,adapt_step_flag  &
                      ,cudtacttime                                     & 
                      ,rainc,raincv,pratec,nca                         &
+                     ,cldfra_dp,cldfra_sh                             & !ckay for subgrid cloud
+                     ,QC_CU,QI_CU                                     &
                      ,z,z_at_w,dz8w,mavail,pblh,p8w,psfc,tsk          &
                      ,tke_pbl, ust                                    &
                      ,forcet,forceq,w0avg,stepcu,gsw                  &
@@ -75,6 +77,7 @@ SUBROUTINE cumulus_driver(grid                                     &
                      ,CFU1,CFD1,DFU1,EFU1,DFD1,EFD1,f_flux            &
                  ! Optional trigger function activation variable
                      ,kfeta_trigger                                   &
+                     ,nsas_dx_factor                                  &
 #if ( WRF_DFI_RADAR == 1 )
                  ! Optional CAP suppress option      --- 3.2 CLEANUP TODO -- THESE SHOULD BE OPTIONAL, NOT #IF/#ENDIF
                      ,do_capsuppress                                  &
@@ -87,7 +90,7 @@ SUBROUTINE cumulus_driver(grid                                     &
                                           ,G3SCHEME,GFSCHEME          &
                                           ,P_QC,P_QI,Param_FIRST_SCALAR &
                                           ,CAMZMSCHEME, SASSCHEME     &
-                                          ,OSASSCHEME                 &
+                                          ,OSASSCHEME,MESO_SAS        &  !Kwon
                                           ,NSASSCHEME                 &
 # if (EM_CORE == 1)
                                           , CAMMGMPSCHEME             &
@@ -109,8 +112,9 @@ SUBROUTINE cumulus_driver(grid                                     &
    USE module_cu_gd     , ONLY : grelldrv
    USE module_cu_gf     , ONLY : gfdrv
    USE module_cu_g3     , ONLY : g3drv,conv_grell_spread3d
-   USE module_cu_sas
-   USE module_cu_osas   
+   USE module_cu_sas    , ONLY : cu_sas
+   USE module_cu_osas   , ONLY : cu_osas
+   USE module_cu_mesosas, ONLY : cu_meso_sas
    USE module_cu_camzm_driver, ONLY : camzm_driver
    USE module_cu_tiedtke, ONLY : cu_tiedtke
    USE module_cu_nsas   , ONLY : cu_nsas
@@ -231,6 +235,7 @@ SUBROUTINE cumulus_driver(grid                                     &
 !-- CU_ACT_FLAG
 !-- W0AVG         average vertical velocity, (for KF scheme) (m/s)
 !-- kfeta_trigger namelist for KF trigger (=1, default; =2, moisture-advection-dependent trigger)
+!-- nsas_dx_factor namelist for NSAS deep scheme to have some dependency on grid sizes
 !-- rho           density (kg/m^3)
 !-- CLDEFI        precipitation efficiency (for BMJ scheme) (dimensionless)
 !-- STEPCU        # of fundamental timesteps between convection calls
@@ -334,8 +339,11 @@ SUBROUTINE cumulus_driver(grid                                     &
 
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
          INTENT(INOUT)  ::                                       &
-                                                          W0AVG
-
+                                                          W0AVG 
+!ckay
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
+         INTENT(INOUT)  ::                            cldfra_dp  &
+                                                    , cldfra_sh
 
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) ::           &
           GSW,HT,XLAND
@@ -362,6 +370,7 @@ SUBROUTINE cumulus_driver(grid                                     &
           INTENT(INOUT) :: CU_ACT_FLAG
 
    INTEGER, INTENT(IN   ), OPTIONAL        ::   kfeta_trigger
+   INTEGER, INTENT(IN   ), OPTIONAL        ::   nsas_dx_factor
 
    REAL,  INTENT(IN   ) :: DT, DX
    INTEGER,      INTENT(IN   ),OPTIONAL    ::                             &
@@ -430,6 +439,10 @@ SUBROUTINE cumulus_driver(grid                                     &
                   zmmtu, zmmtv, zmupgu, zmupgd, zmvpgu, zmvpgd,  &
                   zmicuu, zmicud, zmicvu, zmicvd, zmdice, zmdliq,&
                   dp3d, du3d, ed3d, eu3d, md3d, mu3d
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
+                  INTENT(INOUT) ::                               &
+                  QC_CU,QI_CU
                   
    REAL, DIMENSION( ims:ime , jms:jme , 1:ensdim ),              &
           OPTIONAL,                                              &
@@ -473,7 +486,7 @@ SUBROUTINE cumulus_driver(grid                                     &
 
 ! LOCAL  VAR
 
-   INTEGER :: i,j,k,its,ite,jts,jte,ij,trigger_kf
+   INTEGER :: i,j,k,its,ite,jts,jte,ij,trigger_kf,dx_factor_nsas
    logical :: l_flux
    LOGICAL :: decided , run_param , doing_adapt_dt
 
@@ -516,6 +529,12 @@ SUBROUTINE cumulus_driver(grid                                     &
       trigger_kf = kfeta_trigger
    endif
 
+   if (.not. PRESENT(nsas_dx_factor)) then
+      dx_factor_nsas = 0
+   else
+      dx_factor_nsas = nsas_dx_factor
+   endif
+
    IF (cu_physics .eq. 0) return
 
 !  Initialization for adaptive time step.
@@ -709,6 +728,9 @@ SUBROUTINE cumulus_driver(grid                                     &
                ,RQSCUTEN=rqscuten, RQVFTEN=RQVFTEN              &
                ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr                   &
                ,F_QI=f_qi,F_QS=f_qs                             &
+               ,CLDFRA_DP_KF=cldfra_dp                          & ! ckay for sub-grid cloud
+               ,CLDFRA_SH_KF=cldfra_sh                          &
+               ,QC_KF=QC_CU,QI_KF=QI_CU                         &
                                                                 )
 
      CASE (GDSCHEME)
@@ -780,6 +802,34 @@ SUBROUTINE cumulus_driver(grid                                     &
                ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme &
                ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte &
                                                                 )
+     CASE (MESO_SAS)                  !Kwon
+
+          IF ( adapt_step_flag_pass ) THEN
+            WRITE( wrf_err_message , * ) 'The meso SAS cumulus option will not work properly with an adaptive time step'
+            CALL wrf_error_fatal ( wrf_err_message )
+          END IF
+          CALL wrf_debug(100,'in cu_mesosas')
+          CALL CU_MESO_SAS(                                          &
+                DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU         &
+               ,RTHCUTEN=RTHCUTEN,RQVCUTEN=RQVCUTEN             &
+               ,RQCCUTEN=RQCCUTEN,RQICUTEN=RQICUTEN             &
+               ,RUCUTEN=RUCUTEN, RVCUTEN=RVCUTEN                &
+               ,RAINCV=RAINCV,PRATEC=tmpPRATEC,HTOP=HTOP,HBOT=HBOT &
+               ,U3D=u,V3D=v,W=w,T3D=t                           &
+               ,QV3D=QV_CURR,QC3D=QC_CURR,QI3D=QI_CURR          &
+               ,PI3D=pi,RHO3D=rho                               &
+               ,DZ8W=dz8w,PCPS=p,P8W=p8w,XLAND=XLAND            &
+               ,CU_ACT_FLAG=CU_ACT_FLAG                         &
+               ,P_QC=p_qc                                       &
+               ,MOMMIX=MOMMIX  &
+               ,pgcon=pgcon,sas_mass_flux=sas_mass_flux         &
+               ,shalconv=shalconv,shal_pgcon=shal_pgcon         &
+               ,hpbl2d=hpbl2d,evap2d=evap2d,heat2d=heat2d       &
+               ,P_QI=p_qi,P_FIRST_SCALAR=param_first_scalar     &
+               ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde &
+               ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme &
+               ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte &
+                                                                )
      CASE (OSASSCHEME)
                                                                                                                                            
           IF ( adapt_step_flag_pass ) THEN
@@ -1024,7 +1074,7 @@ SUBROUTINE cumulus_driver(grid                                     &
         IF ( PRESENT ( QFX ) .AND. PRESENT( HFX ) ) THEN
           CALL wrf_debug(100,'in nsas_cps')
           CALL CU_NSAS(                                         &
-                DT=dt,P3DI=p8w,P3D=p,PI3D=pi,                   &
+                DT=dt,DX=dx,P3DI=p8w,P3D=p,PI3D=pi,             &
                 QC3D=QC_CURR,QI3D=QI_CURR,RHO3D=rho,            &
                 ITIMESTEP=itimestep,STEPCU=STEPCU,              &
                 HBOT=HBOT,HTOP=HTOP,                            &
@@ -1037,6 +1087,7 @@ SUBROUTINE cumulus_driver(grid                                     &
                 XLAND=XLAND,DZ8W=dz8w,W=w,U3D=u,V3D=v,          &
                 HPBL=pblh,HFX=hfx,QFX=qfx,                      & 
                 MP_PHYSICS=mp_physics,                          & 
+                DX_FACTOR_NSAS=dx_factor_nsas,                  & 
                 pgcon=pgcon,                                    &
                 P_QC=p_qc,P_QI=p_qi,                            &
                 P_FIRST_SCALAR=param_first_scalar               &
diff --git a/wrfv2_fire/phys/module_diag_afwa.F b/wrfv2_fire/phys/module_diag_afwa.F
new file mode 100644
index 00000000..2bbe6272
--- /dev/null
+++ b/wrfv2_fire/phys/module_diag_afwa.F
@@ -0,0 +1,2357 @@
+#if (NMM_CORE == 1)
+MODULE module_diag_afwa
+CONTAINS
+   SUBROUTINE diag_afwa_stub
+   END SUBROUTINE diag_afwa_stub
+END MODULE module_diag_afwa
+#else
+
+!WRF:MEDIATION_LAYER:PHYSICS
+
+MODULE module_diag_afwa
+
+CONTAINS
+
+  SUBROUTINE afwa_diagnostics_driver (   grid , config_flags     &
+                             , moist                             &
+                             , scalar                            &
+                             , chem                              &
+                             , th_phy , pi_phy , p_phy           &
+                             , dz8w , p8w , t8w , rho_phy        &
+                             , ids, ide, jds, jde, kds, kde      &
+                             , ims, ime, jms, jme, kms, kme      &
+                             , ips, ipe, jps, jpe, kps, kpe      &
+                             , its, ite, jts, jte                &
+                             , k_start, k_end               )
+
+    !USE module_domain, ONLY : domain
+    USE module_domain
+    USE module_configure, ONLY : grid_config_rec_type, model_config_rec
+    USE module_state_description
+    USE module_model_constants
+#ifdef DM_PARALLEL
+    USE module_dm, ONLY: wrf_dm_sum_real, wrf_dm_maxval
+#endif
+
+    IMPLICIT NONE
+
+    TYPE ( domain ), INTENT(INOUT) :: grid
+    TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags
+
+    INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde,        &
+                           ims, ime, jms, jme, kms, kme,        &
+                           ips, ipe, jps, jpe, kps, kpe
+    INTEGER             :: k_start , k_end, its, ite, jts, jte
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme , num_moist),    &
+         INTENT(IN   ) ::                                moist
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme , num_scalar),    &
+         INTENT(IN   ) ::                                scalar
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme , num_chem),     &
+         INTENT(IN   ) ::                                 chem
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),               &
+         INTENT(IN   ) ::                               th_phy  &
+                                              ,         pi_phy  &
+                                              ,          p_phy  &
+                                              ,           dz8w  &
+                                              ,            p8w  &
+                                              ,            t8w  &
+                                              ,        rho_phy
+
+    ! Local
+    ! -----
+    CHARACTER*256 :: message, timestr 
+    INTEGER :: i,j,k
+    INTEGER :: icing_opt
+    REAL :: bdump
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) ::      qrain  &
+                                              ,          qsnow  &
+                                              ,          qgrpl  &
+                                              ,          qvapr  &
+                                              ,         qcloud  &
+                                              ,           qice  &
+                                              ,         ncloud  &
+                                              ,             rh  &
+                                              ,           ptot  &
+                                              ,            z_e  &
+                                              ,           zagl
+
+    REAL, DIMENSION( ims:ime, jms:jme, 5 ) ::            dustc
+    REAL, DIMENSION( ims:ime, jms:jme ) ::                rh2m  &
+                                              ,        wind10m
+
+    ! Timing
+    TYPE(WRFU_Time) :: hist_time, aux2_time, CurrTime
+    TYPE(WRFU_TimeInterval) :: dtint, histint, aux2int
+    LOGICAL :: is_after_history_dump, is_output_timestep
+
+    ! Chirp the routine name for debugging purposes
+    ! ---------------------------------------------
+    write ( message, * ) 'inside afwa_diagnostics_driver'
+    CALL wrf_debug( 100 , message )
+
+    ! Get timing info 
+    ! Want to know if when the last history output was
+    ! Check history and auxhist2 alarms to check last ring time and how often
+    ! they are set to ring
+    ! -----------------------------------------------------------------------
+    CALL WRFU_ALARMGET( grid%alarms( HISTORY_ALARM ), prevringtime=hist_time, &
+         ringinterval=histint)
+    CALL WRFU_ALARMGET( grid%alarms( AUXHIST2_ALARM ), prevringtime=aux2_time, &
+         ringinterval=aux2int)
+
+    ! Get domain clock
+    ! ----------------
+    CALL domain_clock_get ( grid, current_time=CurrTime, &
+         current_timestr=timestr, time_step=dtint )
+
+    ! Set some booleans for use later
+    ! Following uses an overloaded .lt.
+    ! ---------------------------------
+    is_after_history_dump = ( Currtime .lt. hist_time + dtint )
+
+    ! Following uses an overloaded .ge.
+    ! ---------------------------------
+    is_output_timestep = (Currtime .ge. hist_time + histint - dtint .or. &
+                         Currtime .ge. aux2_time + aux2int - dtint )
+    write ( message, * ) 'is output timestep? ', is_output_timestep
+    CALL wrf_debug( 100 , message )
+        
+    ! 3-D arrays for moisture variables
+    ! ---------------------------------
+    DO i=ims, ime
+      DO k=kms, kme
+        DO j=jms, jme
+          qvapr(i,k,j) = moist(i,k,j,P_QV)
+          qrain(i,k,j) = moist(i,k,j,P_QR)
+          qsnow(i,k,j) = moist(i,k,j,P_QS)
+          qgrpl(i,k,j) = moist(i,k,j,P_QG)
+          qcloud(i,k,j) = moist(i,k,j,P_QC)
+          qice(i,k,j) = moist(i,k,j,P_QI)
+          ncloud(i,k,j) = scalar(i,k,j,P_QNC)
+        ENDDO
+      ENDDO
+    ENDDO
+    
+    ! Total pressure
+    ! -------------- 
+    DO i=ims, ime
+      DO k=kms, kme
+        DO j=jms, jme
+          ptot(i,k,j)=grid%pb(i,k,j)+grid%p(i,k,j)
+        ENDDO
+      ENDDO
+    ENDDO
+
+    ! Calculate relative humidity and mid-level relative humidity
+    ! -----------------------------------------------------------
+    DO i=ims,ime
+      DO k=kms,kme    
+        DO j=jms,jme
+          rh(i,k,j)=calc_rh(ptot(i,k,j),grid%t_phy(i,k,j), qvapr(i,k,j))
+        ENDDO
+      ENDDO
+    ENDDO
+
+#ifdef WRF_CHEM
+    ! Surface dust concentration array (ug m-3)
+    ! ----------------------------------------- 
+    DO i=ims, ime
+      DO j=jms, jme
+        dustc(i,j,1)=chem(i,k_start,j,p_dust_1)*grid%rho(i,k_start,j)
+        dustc(i,j,2)=chem(i,k_start,j,p_dust_2)*grid%rho(i,k_start,j)
+        dustc(i,j,3)=chem(i,k_start,j,p_dust_3)*grid%rho(i,k_start,j)
+        dustc(i,j,4)=chem(i,k_start,j,p_dust_4)*grid%rho(i,k_start,j)
+        dustc(i,j,5)=chem(i,k_start,j,p_dust_5)*grid%rho(i,k_start,j)
+      ENDDO
+    ENDDO
+#else
+    dustc(ims:ime,jms:jme,:)=0.
+#endif
+   
+    ! Calculate severe weather diagnostics.  These variables should only be
+    ! output at highest frequency output.  (e.g. auxhist2)
+    ! ---------------------------------------------------------------------
+    IF ( config_flags % afwa_severe_opt == 1 ) THEN
+
+      ! After each history dump, reset max/min value arrays
+      ! Note: This resets up_heli_max which is currently calculated within
+      ! rk_first_rk_step_part2.F, may want to move to this diagnostics package
+      ! later
+      ! ----------------------------------------------------------------------
+      IF ( is_after_history_dump ) THEN
+        DO j = jms, jme
+          DO i = ims, ime
+            grid%wspd10max(i,j) = 0.
+            grid%w_up_max(i,j) = 0.
+            grid%w_dn_max(i,j) = 0.
+            grid%tcoli_max(i,j) = 0.
+            grid%up_heli_max(i,j) = 0.
+            grid%refd_max(i,j) = 0.
+            grid%afwa_llws(i,j) = 0.
+            grid%afwa_hail(i,j) = 0.
+            grid%afwa_tornado(i,j) = 0.
+            grid%midrh_min_old(i,j) = grid%midrh_min(i,j) ! Save old midrh_min
+            grid%midrh_min(i,j) = 999.
+          ENDDO
+        ENDDO
+      ENDIF  ! is_after_history_dump
+
+      CALL severe_wx_diagnostics ( grid % wspd10max             &
+                             , grid % w_up_max                  &
+                             , grid % w_dn_max                  &
+                             , grid % up_heli_max               &
+                             , grid % tcoli_max                 &
+                             , grid % midrh_min_old             &
+                             , grid % midrh_min                 &
+                             , grid % afwa_hail                 &
+                             , grid % afwa_cape                 &
+                             , grid % afwa_zlfc                 &
+                             , grid % afwa_plfc                 &
+                             , grid % afwa_llws                 &
+                             , grid % afwa_tornado              &
+                             , grid % u10                       &
+                             , grid % v10                       &
+                             , grid % w_2                       &
+                             , grid % uh                        &
+                             , grid % t_phy                     &
+                             , grid % t2                        &
+                             , grid % z                         &
+                             , grid % ht                        &
+                             , grid % u_phy                     &
+                             , grid % v_phy                     &
+                             , ptot                             &
+                             , qice                             &
+                             , qsnow                            &
+                             , qgrpl                            &
+                             , grid % rho                       &
+                             , dz8w                             &
+                             , rh                               &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , its, ite, jts, jte               &
+                             , k_start, k_end               )
+    ENDIF   ! afwa_severe_opt == 1
+
+    ! Calculate precipitation type diagnostics
+    ! ----------------------------------------
+    IF ( config_flags % afwa_ptype_opt == 1 ) THEN
+    
+      ! First initialize precip buckets
+      ! -------------------------------
+      IF ( grid % itimestep .eq. 1) THEN
+        DO i=ims,ime
+          DO j=jms,jme
+            grid % afwa_rain(i,j)=0.
+            grid % afwa_snow(i,j)=0.
+            grid % afwa_ice(i,j)=0.
+            grid % afwa_fzra(i,j)=0.
+            grid % afwa_snowfall(i,j)=0.
+          ENDDO
+        ENDDO
+      ENDIF
+  
+      ! Time-step precipitation (convective + nonconvective)
+      ! ------------------------------------------------------
+      DO i=ims,ime
+        DO j=jms,jme
+          grid%afwa_precip(i,j)=grid%raincv(i,j)+grid%rainncv(i,j)
+        ENDDO
+      ENDDO
+
+      ! Diagnose precipitation type
+      ! ---------------------------
+      CALL precip_type_diagnostics ( grid % t_phy               &
+                             , grid % t2                        &
+                             , rh                               &
+                             , grid % z                         &
+                             , grid % ht                        &
+                             , grid % afwa_precip               &
+                             , grid % swdown                    &
+                             , grid % afwa_rain                 &
+                             , grid % afwa_snow                 &
+                             , grid % afwa_ice                  &
+                             , grid % afwa_fzra                 &
+                             , grid % afwa_snowfall             &
+                             , grid % afwa_ptype_ccn_tmp        &
+                             , grid % afwa_ptype_tot_melt       &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+    ENDIF  ! afwa_ptype_opt == 1
+  
+    ! The following packages are calculated only on output timesteps
+    ! --------------------------------------------------------------
+    IF ( is_output_timestep ) THEN      
+
+      ! Calculate equivalent radar reflectivity factor (z_e) using 
+      ! old RIP code (2004) if running radar or VIL packages.
+      ! ----------------------------------------------------------
+      IF ( config_flags % afwa_radar_opt == 1 .or. &
+         config_flags % afwa_vil_opt == 1 ) THEN
+        write ( message, * ) 'Calculating Radar'
+        CALL wrf_debug( 100 , message )
+        CALL wrf_dbzcalc ( grid%rho                             &
+                             , grid%t_phy                       &
+                             , qrain                            &
+                             , qsnow                            &
+                             , qgrpl                            &
+                             , z_e                              &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+      ENDIF  ! afwa_radar_opt == 1 .or. afwa_vil_opt == 1
+
+      ! Calculate derived radar variables
+      ! ---------------------------------
+      IF ( config_flags % afwa_radar_opt == 1 ) THEN
+        write ( message, * ) 'Calculating derived radar variables'
+        CALL wrf_debug( 100 , message )
+        CALL radar_diagnostics ( grid % refd                    &
+                             , grid % refd_com                  &
+                             , grid % refd_max                  &
+                             , grid % echotop                   &
+                             , grid % z                         &
+                             , z_e                              &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+      ENDIF  ! afwa_radar_opt == 1
+
+      ! Calculate VIL and reflectivity every history output timestep
+      ! ------------------------------------------------------------
+      IF ( config_flags % afwa_vil_opt == 1 ) THEN
+        write ( message, * ) 'Calculating VIL'
+        CALL wrf_debug( 100 , message )
+        CALL vert_int_liquid_diagnostics ( grid % vil           &
+                             , grid % radarvil                  &
+                             , grid % t_phy                     &
+                             , qrain                            &
+                             , qsnow                            &
+                             , qgrpl                            &
+                             , z_e                              &
+                             , dz8w                             &
+                             , grid % rho                       &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+      ENDIF  ! afwa_vil_opt ==1 
+
+      ! Calculate icing and freezing level
+      ! ----------------------------------
+      IF ( config_flags % afwa_icing_opt == 1 ) THEN
+
+        ! Determine icing option from microphysics scheme
+        ! -----------------------------------------------
+        
+        IF ( config_flags % mp_physics == GSFCGCESCHEME ) THEN
+          icing_opt=1
+        ELSEIF ( config_flags % mp_physics == ETAMPNEW ) THEN
+          icing_opt=2
+        ELSEIF ( config_flags % mp_physics == THOMPSON ) THEN
+          icing_opt=3
+        ELSEIF ( config_flags % mp_physics == WSM5SCHEME .OR.   &
+                 config_flags % mp_physics == WSM6SCHEME ) THEN
+          icing_opt=4
+        ELSEIF ( config_flags % mp_physics == MORR_TWO_MOMENT ) THEN
+          !-->RAS13.2
+          !Is this run with prognostic cloud droplets or no?
+          IF (config_flags % progn > 0) THEN
+             icing_opt=6
+          ELSE
+             icing_opt=5
+          ENDIF
+        ELSEIF ( config_flags % mp_physics == WDM6SCHEME ) THEN
+          icing_opt=7
+        ELSE
+          icing_opt=0  ! Not supported
+        ENDIF
+ 
+        write ( message, * ) 'Calculating Icing with icing opt ',icing_opt 
+        CALL wrf_debug( 100 , message )
+        CALL icing_diagnostics ( icing_opt                      &
+                             , grid % fzlev                     &
+                             , grid % icing_lg                  &
+                             , grid % icing_sm                  &
+                             , grid % qicing_lg_max             &
+                             , grid % qicing_sm_max             &
+                             , grid % qicing_lg                 &
+                             , grid % qicing_sm                 &
+                             , grid % icingtop                  &
+                             , grid % icingbot                  &
+                             , grid % t_phy                     &
+                             , grid % z                         &
+                             , dz8w                             &
+                             , grid % rho                       &
+                             , qrain                            &
+                             , qcloud                           &
+                             , ncloud                           &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+      ENDIF  ! afwa_icing_opt
+
+      IF ( config_flags % afwa_vis_opt == 1 ) THEN
+   
+        ! Calculate 2 meter relative humidity
+        ! -----------------------------------
+        DO i=ims,ime
+          DO j=jms,jme
+            rh2m(i,j)=calc_rh(grid%psfc(i,j), grid%t2(i,j), grid%q2(i,j))
+          ENDDO
+        ENDDO
+      
+        ! Calculate 10 meter winds
+        ! ------------------------
+        DO i=ims,ime
+          DO j=jms,jme
+            wind10m(i,j)=uv_wind(grid%u10(i,j),grid%v10(i,j))
+          ENDDO
+        ENDDO
+
+        write ( message, * ) 'Calculating visibility'
+        CALL wrf_debug( 100 , message )
+        CALL vis_diagnostics ( qcloud(ims:ime,k_start,jms:jme)  &
+                             , qrain(ims:ime,k_start,jms:jme)   &
+                             , qice(ims:ime,k_start,jms:jme)    &
+                             , qsnow(ims:ime,k_start,jms:jme)   &
+                             , wind10m                          &
+                             , rh2m                             &
+                             , dustc                            &
+                             , grid % afwa_vis                  &
+                             , grid % afwa_vis_dust             &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe ) 
+      ENDIF
+
+      IF ( config_flags % afwa_cloud_opt == 1 ) THEN
+        CALL cloud_diagnostics (qcloud                          &
+                             , qice                             &
+                             , qsnow                            &
+                             , rh                               &
+                             , dz8w                             &
+                             , grid % rho                       &
+                             , grid % z                         &
+                             , grid % ht                        &
+                             , grid % afwa_cloud                &
+                             , grid % afwa_cloud_ceil           &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+      ENDIF
+
+    ENDIF  ! is_output_timestep
+
+  END SUBROUTINE afwa_diagnostics_driver
+
+
+
+  SUBROUTINE severe_wx_diagnostics ( wspd10max                  &
+                             , w_up_max                         &
+                             , w_dn_max                         &
+                             , up_heli_max                      &
+                             , tcoli_max                        &
+                             , midrh_min_old                    &
+                             , midrh_min                        &
+                             , afwa_hail                        &
+                             , cape                             &
+                             , zlfc                             &
+                             , plfc                             &
+                             , llws_max                         &
+                             , afwa_tornado                     &
+                             , u10                              &
+                             , v10                              &
+                             , w_2                              &
+                             , uh                               &
+                             , t_phy                            &
+                             , t2                               &
+                             , z                                &
+                             , ht                               &
+                             , u_phy                            &
+                             , v_phy                            &
+                             , p                                &
+                             , qi                               &
+                             , qs                               &
+                             , qg                               &
+                             , rho                              &
+                             , dz8w                             &
+                             , rh                               &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , its, ite, jts, jte               &
+                             , k_start, k_end               )
+
+    INTEGER, INTENT(IN) :: its, ite, jts, jte, k_start, k_end   &
+                         , ims, ime, jms, jme, kms, kme
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),               &
+         INTENT(IN   ) ::                                    p  &
+                                              ,            w_2  &
+                                              ,          t_phy  &
+                                              ,          u_phy  &
+                                              ,          v_phy  &
+                                              ,             qi  &
+                                              ,             qs  &
+                                              ,             qg  &
+                                              ,            rho  &
+                                              ,              z  &
+                                              ,           dz8w  &
+                                              ,             rh
+
+
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(IN   ) ::                                  u10  &
+                                              ,            v10  &
+                                              ,             uh  &
+                                              ,             t2  &
+                                              ,             ht  &
+                                              ,  midrh_min_old  &
+                                              ,    up_heli_max
+
+
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(INOUT) ::                            wspd10max  &
+                                              ,       w_up_max  &
+                                              ,       w_dn_max  &
+                                              ,      tcoli_max  &
+                                              ,      midrh_min  &
+                                              ,       llws_max  &
+                                              ,      afwa_hail  &
+                                              ,   afwa_tornado
+
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(  OUT) ::                                 cape  &
+                                              ,           zlfc  &
+                                              ,           plfc
+
+    ! Local
+    ! -----
+    INTEGER :: i,j,k
+    INTEGER :: kts,kte
+    REAL    :: zagl, zlfc_msl, melt_term, midrh_term, hail, midrh
+    REAL    :: tornado, lfc_term, shr_term, midrh2_term, uh_term
+    REAL    :: u2000, v2000, us, vs
+    REAL    :: wind_vel, p_tot, tcoli
+    INTEGER :: nz, ostat
+    LOGICAL :: is_target_level
+    REAL, DIMENSION( ims:ime, jms:jme ) ::                w_up  &
+                                              ,           w_dn  &
+                                              ,           llws
+                         
+
+    ! Calculate midlevel relative humidity minimum
+    ! --------------------------------------------
+    DO i=ims,ime
+      DO j=jms,jme
+        is_target_level=.false.
+        DO k=kms,kme    
+          zagl = z(i,k,j) - ht(i,j)
+          IF ( ( zagl >= 3500. ) .and. &
+               ( .NOT. is_target_level ) .and. &
+               ( k .ne. kms ) ) THEN
+            is_target_level = .true.
+            midrh = rh(i,k-1,j) + (3500. - (z(i,k-1,j) - ht(i,j))) &
+                    * ((rh(i,k,j) - rh(i,k-1,j))/(z(i,k,j) - z(i,k-1,j)))
+            IF ( midrh .lt. midrh_min(i,j) ) THEN
+              midrh_min(i,j) = midrh
+            ENDIF
+          ENDIF
+        ENDDO
+      ENDDO
+    ENDDO
+
+    ! Calculate the max 10 m wind speed between output times
+    ! ------------------------------------------------------
+    DO j = jts, jte
+      DO i = its, ite
+        !wind_vel = sqrt( u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j) )
+        wind_vel = uv_wind ( u10(i,j) , v10(i,j) )
+        IF ( wind_vel .GT. wspd10max(i,j) ) THEN
+          wspd10max(i,j) = wind_vel
+        ENDIF
+      ENDDO
+    ENDDO
+ 
+    ! Vertical velocity quantities between output times
+    ! -------------------------------------------------
+    w_up=0.
+    w_dn=0.
+    DO j = jts, jte
+      DO k = k_start, k_end
+        DO i = its, ite
+          p_tot = p(i,k,j) / 100.
+ 
+          ! Check vertical velocity field below 400 mb
+          !IF ( p_tot .GT. 400. .AND. w_2(i,k,j) .GT. w_up_max(i,j) ) THEN
+          !  w_up_max(i,j) = w_2(i,k,j)
+          !ENDIF
+          !IF ( p_tot .GT. 400. .AND. w_2(i,k,j) .LT. w_dn_max(i,j) ) THEN
+          !  w_dn_max(i,j) = w_2(i,k,j)
+          !ENDIF
+
+          ! Check vertical velocity field below 400 mb
+          IF ( p_tot .GT. 400. .AND. w_2(i,k,j) .GT. w_up(i,j) ) THEN
+            w_up(i,j) = w_2(i,k,j)
+            IF ( w_up(i,j) .GT. w_up_max(i,j) ) THEN
+              w_up_max(i,j) = w_up(i,j)
+            ENDIF
+          ENDIF
+          IF ( p_tot .GT. 400. .AND. w_2(i,k,j) .LT. w_dn(i,j) ) THEN
+            w_dn(i,j) = w_2(i,k,j)
+            IF ( w_dn(i,j) .GT. w_dn_max(i,j) ) THEN
+              w_dn_max(i,j) = w_dn(i,j)
+            ENDIF
+          ENDIF
+        ENDDO
+      ENDDO
+    ENDDO
+   
+    ! Hail diameter in millimeters (Weibull distribution)
+    ! ---------------------------------------------------
+    DO j = jts, jte
+      DO i = its, ite
+        melt_term=max(t2(i,j)-288.15,0.)
+        midrh_term=max(2*(min(midrh_min(i,j),midrh_min_old(i,j))-70.),0.)
+        hail=max((w_up(i,j)/1.4)**1.25-melt_term-midrh_term,0.)
+        IF ( hail .gt. afwa_hail(i,j) ) THEN
+          afwa_hail(i,j)=hail
+        ENDIF
+      ENDDO
+    ENDDO
+
+    ! Lightning (total column-integrated cloud ice)
+    ! Note this formula is basically stolen from the VIL calculation.
+    ! ---------------------------------------------------------------
+    DO j = jts, jte
+      DO i = its, ite
+        tcoli=0.
+        DO k = k_start, k_end
+          tcoli =  tcoli + &
+          (qi (i,k,j) + &
+           qs (i,k,j) + &
+           qg (i,k,j))  &
+           *dz8w (i,k,j) * rho(i,k,j)
+        ENDDO
+        IF ( tcoli .GT. tcoli_max(i,j) ) THEN
+          tcoli_max(i,j) = tcoli
+        ENDIF
+      ENDDO
+    ENDDO
+
+    ! Calculate buoyancy parameters.
+    ! ------------------------------
+    nz = k_end - k_start
+    DO j = jts, jte
+      DO i = its, ite
+        ostat = Buoyancy (                                   nz &
+                                     , t_phy(i,kms:kme      ,j) &
+                                     ,    rh(i,kms:kme      ,j) &
+                                     ,     p(i,kms:kme      ,j) &
+                                     ,     z(i,kms:kme      ,j) &
+                                     ,                        1 &
+                                     ,                cape(i,j) &
+                                     ,                 zlfc_msl &
+                                     ,                plfc(i,j) &
+                                     ,                        3 ) !Surface
+        IF ( ostat /= 0 ) then
+          WRITE (*,*) "something went wrong with buoyancy calc at i=",i," j=",j
+        ENDIF
+        
+        ! Subtract terrain height to convert ZLFC from MSL to AGL
+        ! -------------------------------------------------------
+        zlfc(i,j)=zlfc_msl-ht(i,j)
+
+      ENDDO
+    ENDDO
+
+    ! Calculate 0-2000 foot (0 - 609.6 meter) shear.
+    ! ----------------------------------------------
+    DO j = jts, jte
+      DO i = its, ite
+        is_target_level=.false.
+        DO k=kms,kme    
+          zagl = z(i,k,j) - ht(i,j)
+          IF ( ( zagl >= 609.6 ) .and. &
+               ( .NOT. is_target_level ) .and. &
+               ( k .ne. kms ) ) THEN
+            is_target_level = .true.
+            u2000 = u_phy(i,k-1,j) + (609.6 - (z(i,k-1,j) - ht(i,j))) &
+                    * ((u_phy(i,k,j) - u_phy(i,k-1,j))/(z(i,k,j) - z(i,k-1,j)))
+            v2000 = v_phy(i,k-1,j) + (609.6 - (z(i,k-1,j) - ht(i,j))) &
+                    * ((v_phy(i,k,j) - v_phy(i,k-1,j))/(z(i,k,j) - z(i,k-1,j)))
+            us = u2000 - u10(i,j) 
+            vs = v2000 - v10(i,j) 
+            llws(i,j) = uv_wind ( us , vs )
+            IF ( llws(i,j) .gt. llws_max(i,j) ) THEN
+              llws_max(i,j) = llws(i,j)
+            ENDIF
+          ENDIF
+        ENDDO
+      ENDDO
+    ENDDO
+
+    ! Maximum tornado wind speed in ms-1.
+    ! -----------------------------------
+    DO j = jts, jte
+      DO i = its, ite
+        IF ( zlfc(i,j) .ge. 0. ) THEN
+          !uh_term = min(max((up_heli_max(i,j) - 25.) / 50., 0.), 1.)
+          uh_term = min(max((uh(i,j) - 25.) / 50., 0.), 1.)
+          shr_term = min(max((llws(i,j) - 2.) / 10., 0.), 1.)
+          lfc_term = min(max((3000. - zlfc(i,j)) / 1500., 0.), 1.)
+          midrh2_term = min(max((90. - min(midrh_min(i,j),midrh_min_old(i,j))) / 30., 0.), 1.)
+          tornado = 50. * uh_term * shr_term * lfc_term * midrh2_term
+          IF (tornado .gt. afwa_tornado(i,j)) THEN
+            afwa_tornado(i,j) = tornado
+          ENDIF
+        ENDIF
+      ENDDO
+    ENDDO
+    
+
+  END SUBROUTINE severe_wx_diagnostics
+
+
+
+  SUBROUTINE vert_int_liquid_diagnostics ( vil                  &
+                             , radarvil                         &
+                             , t_phy                            &
+                             , qrain                            &
+                             , qsnow                            &
+                             , qgrpl                            &
+                             , z_e                              &
+                             , dz8w                             &
+                             , rho                              &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+
+    INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde,        &
+                           ims, ime, jms, jme, kms, kme,        &
+                           ips, ipe, jps, jpe, kps, kpe
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),               &
+         INTENT(IN) ::                                     rho  &
+                                              ,          qrain  &
+                                              ,          qsnow  &
+                                              ,          qgrpl  & 
+                                              ,          t_phy  &
+                                              ,            z_e  & 
+                                              ,           dz8w
+
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(INOUT) ::                                  vil  &
+                                              ,       radarvil
+
+    ! Local
+    ! -----
+    INTEGER :: i,j,k,ktime
+
+    ! Calculate vertically integrated liquid water (though its mostly not
+    ! "liquid" now is it?)
+    ! -------------------------------------------------------------------
+    DO i = ips, MIN(ipe,ide-1)
+    DO j = jps, MIN(jpe,jde-1)
+      vil (i,j) = 0.0
+      DO k = kps, MIN(kpe,kde-1)
+        vil (i,j) =  vil (i,j) + &
+         (qrain (i,k,j) + &
+          qsnow (i,k,j) + &
+          qgrpl (i,k,j))  &
+          *dz8w (i,k,j) * rho(i,k,j)
+      ENDDO
+    ENDDO
+    ENDDO
+
+    ! Diagnose "radar-derived VIL" from equivalent radar reflectivity
+    ! radarVIL = (integral of LW*dz )/1000.0  (in kg/m^2)
+    ! LW = 0.00344 * z_e** (4/7)  in g/m^3
+    ! ---------------------------------------------------------------
+    DO i = ips, MIN(ipe,ide-1)
+    DO j = jps, MIN(jpe,jde-1)
+      radarvil (i,j) = 0.0
+      DO k = kps, MIN(kpe,kde-1)
+        radarvil (i,j) = radarvil (i,j) + &
+        0.00344 * z_e(i,k,j)**0.57143 &
+        *dz8w (i,k,j)/1000.0
+      END DO
+    END DO
+    END DO
+
+  END SUBROUTINE vert_int_liquid_diagnostics
+
+
+
+  SUBROUTINE icing_diagnostics ( icing_opt                      &
+                             , fzlev                            &
+                             , icing_lg                         &
+                             , icing_sm                         & 
+                             , qicing_lg_max                    &
+                             , qicing_sm_max                    &
+                             , qicing_lg                        &
+                             , qicing_sm                        &
+                             , icingtop                         &
+                             , icingbot                         &
+                             , t_phy                            &
+                             , z                                &
+                             , dz8w                             &
+                             , rho                              &
+                             , qrain                            &
+                             , qcloud                           &
+                             , ncloud                           &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+
+    INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde,        &
+                           ims, ime, jms, jme, kms, kme,        &
+                           ips, ipe, jps, jpe, kps, kpe
+
+    INTEGER, INTENT(IN) :: icing_opt
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),               &
+         INTENT(IN) ::                                       z  &
+                                              ,          qrain  &
+                                              ,         qcloud  &
+                                              ,         ncloud  &
+                                              ,            rho  &
+                                              ,           dz8w  &
+                                              ,          t_phy
+
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(  OUT) ::                                fzlev  &
+                                              ,       icing_lg  &
+                                              ,       icing_sm  &
+                                              ,  qicing_lg_max  &
+                                              ,  qicing_sm_max  &
+                                              ,       icingtop  &
+                                              ,       icingbot
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),               &
+         INTENT(  OUT) ::                            qicing_lg  &
+                                              ,      qicing_sm
+         
+
+    ! Local
+    ! -----
+    INTEGER :: i,j,k,ktime,ktop,kbot
+    REAL    :: qcfrac_lg, qcfrac_sm, qc, qr, small, all
+
+    ! Initializations
+    ! ---------------
+    fzlev (ips:ipe,jps:jpe) = -999.        ! Arbitrary unset/initial value
+    icingtop (ips:ipe,jps:jpe) = -999.     ! Arbitrary unset/initial value
+    icingbot (ips:ipe,jps:jpe) = -999.     ! Arbitrary unset/initial value
+    icing_lg (ips:ipe,jps:jpe) = 0.        
+    icing_sm (ips:ipe,jps:jpe) = 0.
+    qicing_lg_max (ips:ipe,jps:jpe) = 0. 
+    qicing_sm_max (ips:ipe,jps:jpe) = 0. 
+    qicing_sm(ips:ipe,kps:kpe,jps:jpe)=0.
+    qicing_lg(ips:ipe,kps:kpe,jps:jpe)=0.   
+
+    ! Loop through i and j
+    ! --------------------
+    DO i = ips, MIN(ipe,ide-1)
+    DO j = jps, MIN(jpe,jde-1)
+
+      ! Go up the column and look for sub freezing temperatures
+      ! -------------------------------------------------------
+      ktop=-1
+      kbot=-1
+      DO k = kps, MIN(kpe,kde-1)
+        IF (t_phy(i,k,j) .lt. 273.15) THEN
+
+          ! Any cloud water we find will be supercooled.
+          ! Based on microphysics scheme, determine the fraction of
+          ! large (>50 um) supercooled cloud water drops.
+          ! Source: Becky Selin, 16WS
+          ! -------------------------------------------------------
+          qc = qcloud (i,k,j)
+          qr = qrain (i,k,j)
+          nc = ncloud(i,k,j)
+          den = rho(i,k,j)
+          qcfrac_lg = 0.
+          qcfrac_sm = 0.
+          
+          ! Eta (Ferrier)
+          ! -------------
+          IF (icing_opt .eq. 2) THEN
+            IF (qc .lt. 2.5E-4) THEN
+              qcfrac_lg = 395000. * qc**2. + 102.9 * qc
+            ELSEIF (qc .lt. 1.4E-3) THEN
+              qcfrac_lg = 276.1 * qc - 0.01861
+            ELSE
+              qcfrac_lg = 0.3 * log(641.789 * qc) + 0.4
+            ENDIF
+
+          ! Thompson
+          ! --------
+          ! RAS13.2 Per James McCormick's stats, more large supercooled
+          ! drops are needed from the Thompson members.  Changing 
+          ! calculation to be like WSM5/6 members.
+          !ELSEIF (icing_opt .eq. 3) THEN
+          !  IF (qc .lt. 1.0E-3) THEN
+          !    qcfrac_lg = 2205.0 * qc**2. + 3.232 * qc
+          !  ELSEIF (qc .lt. 3.0E-3) THEN
+          !    qcfrac_lg = 24.1 * qc - 0.01866
+          !  ELSE
+          !    qcfrac_lg = 0.127063 * log(550.0 * qc) - 0.01
+          !  ENDIF
+
+          ! Thompson or WSM5/6
+          ! ------------------
+          !ELSEIF (icing_opt .eq. 4) THEN
+          ELSEIF ((icing_opt .eq. 3) .OR. (icing_opt .eq. 4)) THEN
+            IF (qc .lt. 5.E-4) THEN
+              qcfrac_lg = 50420.0 * qc**2. + 29.39 * qc
+            ELSEIF (qc .lt. 1.4E-3) THEN
+              qcfrac_lg = 97.65 * qc - 0.02152
+            ELSE
+              qcfrac_lg = 0.2 * log(646.908 * qc) + 0.135
+            ENDIF
+
+          ! Morrison 2-moment, constant CCN
+          ! -------------------------------
+          ELSEIF (icing_opt .eq. 5) THEN
+            IF (qc .lt. 1.4E-3) THEN
+              qcfrac_lg = 28000. * qc**2. + 0.1 * qc 
+            ELSEIF (qc .lt. 2.6E-3) THEN
+              qcfrac_lg = 112.351 * qc - 0.102272
+            ELSE 
+              qcfrac_lg = 0.3 * log(654.92 * qc) * 0.301607
+            ENDIF
+
+          ! WDM6 or Morrison 2-moment w/ prognostic CCN
+          ! -------------------------------------------
+          ELSEIF ((icing_opt .eq. 6) .OR. (icing_opt .eq. 7)) THEN
+            IF ((qc .gt. 1.0E-12) .and. (nc .gt. 1.0E-12)) THEN
+               small = -nc * exp(-nc*3141.59265*(5.E-5)**3./(6000.*den*qc))+nc
+               all = -nc * exp(-nc*3141.59265*(2.)**3./(6000.*den*qc))+nc
+               qcfrac_lg = 1. - (small / all)
+            ELSE
+               qcfac_lg = 0.
+            ENDIF
+          ENDIF
+          qcfrac_lg = max(qcfrac_lg, 0.)
+          
+          ! Small (<50 um) supercooled cloud water drop fraction (1 - large).
+          ! -----------------------------------------------------------------
+          IF (icing_opt .ne. 0 ) THEN
+            qcfrac_sm = 1 - qcfrac_lg
+          ENDIF
+
+          ! Supercooled drop mixing ratio
+          ! -----------------------------
+          qicing_lg (i,k,j) = max(qr + qcfrac_lg * qc, 0.)
+          qicing_sm (i,k,j) = max(qcfrac_sm * qc, 0.)        
+
+          ! Column integrated icing
+          ! -----------------------
+          icing_lg (i,j) = icing_lg (i,j) + qicing_lg (i,k,j) &
+                            * dz8w (i,k,j) * rho(i,k,j)
+          icing_sm (i,j) = icing_sm (i,j) + qicing_sm (i,k,j) &
+                            * dz8w (i,k,j) * rho(i,k,j)
+
+          ! Column maximum supercooled drop mixing ratio 
+          ! --------------------------------------------
+          IF ( qicing_lg(i,k,j) .gt. qicing_lg_max(i,j) ) THEN
+            qicing_lg_max (i,j) = qicing_lg(i,k,j)
+          ENDIF
+          IF ( qicing_sm(i,k,j) .gt. qicing_sm_max(i,j) ) THEN
+            qicing_sm_max (i,j) = qicing_sm(i,k,j)
+          ENDIF
+           
+          ! Freezing level calculation
+          ! --------------------------
+          IF (fzlev (i,j) .eq. -999.) THEN  ! At freezing level
+            IF (k .ne. kps) THEN  ! If not at surface, interpolate.      
+              fzlev (i,j) = z (i,k-1,j) + &
+                             ((273.15 - t_phy (i,k-1,j)) &
+                            /(t_phy (i,k,j) - t_phy (i,k-1,j))) &
+                            *(z (i,k,j) - z (i,k-1,j))
+            ELSE  ! If at surface, use first level.
+              fzlev(i,j) = z (i,k,j)
+            ENDIF
+          ENDIF
+
+          ! Icing layer top and bottom indices (where icing > some arbitrary
+          ! small value). Set bottom index of icing layer to current k index 
+          ! if not yet set. Set top index of icing layer to current k index.
+          ! ----------------------------------------------------------------
+          IF ((qicing_lg (i,k,j) + qicing_sm (i,k,j)) .ge. 1.E-5) THEN
+            IF (kbot .eq. -1) kbot = k  
+            ktop=k
+          ENDIF
+        ENDIF
+      END DO
+
+      ! Interpolate bottom of icing layer from kbot (bottom index of icing
+      ! layer). Icing bottom should not go below freezing level.
+      ! ------------------------------------------------------------------
+      IF (kbot .ne. -1) THEN
+        IF (kbot .ne. kps) THEN ! If not at surface, interpolate
+          icingbot (i,j) = z (i,kbot-1,j) + ((1.E-5 - &
+                   (qicing_lg (i,kbot-1,j) + qicing_sm (i,kbot-1,j))) &
+                  / ((qicing_lg (i,kbot,j) + qicing_sm (i,kbot,j)) &
+                  - (qicing_lg (i,kbot-1,j) + qicing_sm (i,kbot-1,j)))) &
+                  * (z (i,kbot,j) - z (i,kbot-1,j))
+          icingbot (i,j) = MAX(icingbot (i,j), fzlev (i,j))
+        ELSE  ! If at surface use first level.
+          icingbot (i,j) = z(i,kbot,j)
+        ENDIF
+      ENDIF
+
+      ! Interpolate top of icing layer from ktop (top index of icing layer).
+      ! Icing top should not go below icing bottom (obviously).
+      ! --------------------------------------------------------------------
+      IF (ktop .ne. -1 .and. ktop .ne. kpe) THEN ! If not undefined or model top
+        icingtop (i,j) = z (i,ktop,j) + ((1.E-5 - &
+                 (qicing_lg (i,ktop,j) + qicing_sm (i,ktop,j))) &
+                 / ((qicing_lg (i,ktop+1,j) + qicing_sm (i,ktop+1,j)) &
+                 - (qicing_lg (i,ktop,j) + qicing_sm (i,ktop,j)))) &
+                 * (z (i,ktop+1,j) - z (i,ktop,j))
+        icingtop (i,j) = MAX(icingtop (i,j), icingbot (i,j))
+      ENDIF
+    END DO
+    END DO
+
+  END SUBROUTINE icing_diagnostics
+
+
+
+  SUBROUTINE radar_diagnostics ( refd                           &
+                             , refd_com                         &
+                             , refd_max                         &
+                             , echotop                          &
+                             , z                                &
+                             , z_e                              &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+
+    INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde,        &
+                           ims, ime, jms, jme, kms, kme,        &
+                           ips, ipe, jps, jpe, kps, kpe
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),               &
+         INTENT(IN) ::                                       z  &
+                                              ,            z_e
+
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(INOUT) ::                                 refd  &
+                                              ,       refd_com  &
+                                              ,       refd_max  &
+                                              ,        echotop
+
+    ! Local
+    ! -----
+    INTEGER :: i,j,k,ktime
+    
+    DO j = jps, MIN(jpe,jde-1)
+    DO i = ips, MIN(ipe,ide-1)
+      ktop = -1  ! Undefined
+      echotop (i,j) = 0.
+      refd_com (i,j) = 0.
+      refd (i,j) = 0.
+      DO k = kps, MIN(kpe,kde-1)
+        IF (z_e(i,k,j) .gt. 1.e-20) THEN
+
+          ! Reflectivity (first level)
+          ! --------------------------
+          IF (k == kps) refd(i,j) = MAX(10.0 * log10(z_e(i,k,j)),0.)
+   
+          ! Max reflectivity over the output interval
+          ! -----------------------------------------
+          IF (refd(i,j) .gt. refd_max(i,j)) refd_max(i,j) = refd(i,j)
+
+          ! Composite reflectivity calc (max reflectivity in the column)
+          ! ------------------------------------------------------------
+          IF (10.0 * log10(z_e(i,k,j)) .gt. refd_com(i,j)) THEN
+            refd_com(i,j) = 10.0 * log10(z_e(i,k,j))
+          ENDIF
+        ENDIF
+        
+        ! Echo top - the highest level w/ dBZ > 18 (z_e > 63.0957)
+        ! --------------------------------------------------------
+        IF ( z_e(i,k,j) .gt. 63.0957) THEN
+          ktop = k
+        ENDIF
+      END DO
+      IF ( ktop .ne. -1 ) THEN  ! Interpolate to echo top height (GAC)
+        echotop (i,j) = z (i,ktop,j) + &
+                          ((63.0957 - z_e (i,ktop,j)) &
+                         /(z_e (i,ktop+1,j) - z_e (i,ktop,j))) &
+                         *(z (i,ktop+1,j) - z (i,ktop,j))
+      ENDIF
+    END DO
+    END DO
+
+  END SUBROUTINE radar_diagnostics
+
+
+
+  SUBROUTINE wrf_dbzcalc( rho                                   &
+                             , t_phy                            &
+                             , qr                               &
+                             , qs                               &
+                             , qg                               &
+                             , z_e                              &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+
+    INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde,        &
+                           ims, ime, jms, jme, kms, kme,        &
+                           ips, ipe, jps, jpe, kps, kpe
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),               &
+         INTENT(IN   ) ::                                  rho  &
+                                              ,          t_phy  &
+                                              ,             qr  &
+                                              ,             qs  &
+                                              ,             qg
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),               &
+         INTENT(  OUT) ::                                  z_e
+
+    REAL :: factor_r, factor_s, factor_g, factorb_s, factorb_g, ronv, sonv, gonv
+    REAL :: temp_c, rhoair, qgr, qra, qsn
+    INTEGER :: i, j, k
+
+    INTEGER, PARAMETER :: iBrightBand = 1
+    REAL, PARAMETER :: T_0 = 273.15
+    REAL, PARAMETER :: PI = 3.1415926536
+    REAL, PARAMETER :: rgas=287.04, gamma_seven = 720.0, alpha2 = 0.224
+
+    ! Densities of rain, snow, graupel, and cloud ice.
+    ! ------------------------------------------------
+    REAL, PARAMETER :: rho_w = 1000.0, rho_r = 1000.0, rho_s = 100.0
+    REAL, PARAMETER :: rho_g = 400.0, rho_i = 890.0
+    REAL, PARAMETER :: ron=8.e6, son=2.e7, gon=5.e7, r1=1.e-15
+    REAL, PARAMETER :: ron_min = 8.e6, ron2=1.e10
+    REAL, PARAMETER :: ron_qr0 = 0.0001, ron_delqr0 = 0.25*ron_qr0
+    REAL, PARAMETER :: ron_const1r = (ron2-ron_min)*0.5
+    REAL, PARAMETER :: ron_const2r = (ron2+ron_min)*0.5
+
+    ! Constant intercepts
+    ! -------------------
+    ronv = 8.e6    ! m^-4
+    sonv = 2.e7    ! m^-4
+    gonv = 4.e6    ! m^-4
+
+    factor_r = gamma_seven * 1.e18 * (1./(pi*rho_r))**1.75
+    factor_s = gamma_seven * 1.e18 * (1./(pi*rho_s))**1.75  &
+              * (rho_s/rho_w)**2 * alpha2
+    factor_g = gamma_seven * 1.e18 * (1./(pi*rho_g))**1.75  &
+              * (rho_g/rho_w)**2 * alpha2
+
+    ! For each grid point
+    ! -------------------
+    DO j = jps, jpe
+    DO k = kps, kpe
+    DO i = ips, ipe
+
+      factorb_s = factor_s
+      factorb_g = factor_g
+
+      ! In this case snow or graupel particle scatters like liquid
+      ! water because it is assumed to have a liquid skin
+      ! ----------------------------------------------------------
+      IF( iBrightBand == 1 ) THEN
+        IF (t_phy(i,k,j) > T_0) THEN
+          factorb_s = factor_s /alpha2
+          factorb_g = factor_g /alpha2
+        ENDIF
+      ENDIF
+ 
+      ! Calculate variable intercept parameters
+      ! ---------------------------------------
+      temp_c = amin1(-0.001, t_phy(i,k,j)- T_0)
+      sonv = amin1(2.0e8, 2.0e6*exp(-0.12*temp_c))
+      gonv = gon
+      qgr = QG(i,k,j)
+      qra = QR(i,k,j)
+      qsn = QS(i,k,j)
+      IF (qgr.gt.r1) THEN
+        gonv = 2.38*(pi*rho_g/(rho(i,k,j)*qgr))**0.92
+        gonv = max(1.e4, min(gonv,gon))
+      ENDIF
+      ronv = ron2
+      IF (qra.gt. r1) THEN
+        ronv = ron_const1r*tanh((ron_qr0-qra)/ron_delqr0) + ron_const2r
+      ENDIF
+ 
+      IF (qra < 0.0 ) qra = 0.0
+      IF (qsn < 0.0 ) qsn = 0.0
+      IF (qgr < 0.0 ) qgr = 0.0
+      z_e(i,k,j) = factor_r * (rho(i,k,j) * qra)**1.75 / ronv**.75 + &
+                     factorb_s * (rho(i,k,j) * qsn)**1.75 / sonv**.75 + &
+                     factorb_g * (rho(i,k,j) * qgr)**1.75 / gonv**.75
+ 
+      IF ( z_e(i,k,j) < 0.0 ) z_e(i,k,j) = 0.0
+ 
+    END DO
+    END DO
+    END DO
+
+  END SUBROUTINE wrf_dbzcalc
+
+
+
+  SUBROUTINE precip_type_diagnostics ( t_phy                    &
+                             , t2                               &
+                             , rh                               &
+                             , z                                &
+                             , ht                               &
+                             , precip                           &
+                             , swdown                           &
+                             , rain                             &
+                             , snow                             &
+                             , ice                              &
+                             , frz_rain                         &
+                             , snowfall                         &
+                             , ccn_tmp                          &
+                             , total_melt                       &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+
+    INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde,        &
+                           ims, ime, jms, jme, kms, kme,        &
+                           ips, ipe, jps, jpe, kps, kpe
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),               &
+         INTENT(IN   ) ::                                t_phy  &
+                                              ,             rh  &
+                                              ,              z
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(IN   ) ::                                   t2  &
+                                              ,             ht  &
+                                              ,         precip  &
+                                              ,         swdown
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(INOUT) ::                             snowfall  &
+                                              ,           rain  &
+                                              ,       frz_rain  &
+                                              ,           snow  &
+                                              ,            ice
+    REAL, INTENT(IN) :: ccn_tmp
+    REAL, INTENT(IN) :: total_melt
+
+    ! Local
+    ! -----
+    REAL, DIMENSION( ims:ime, jms:jme ) ::                      &
+                                     melt                       &
+                                   , mod_2m_tmp                 &
+                                   , cloud_top_tmp              &
+                                   , maxtmp
+
+    INTEGER, DIMENSION( ims:ime, jms:jme ) ::                   &
+                                     cloud_top_k_index          &
+                                   , precip_type
+
+    LOGICAL, DIMENSION (ims:ime, jms:jme ) ::                   &
+                                     saturation 
+
+    REAL, PARAMETER :: snow_ratio=5.0
+
+    ! Loop through all points
+    ! Search vertically twice--first to find the cloud top temperature and the 
+    ! maximum temperature. Second, determine if any melting or re-freezing will
+    ! occur to make ice pellets or freezing rain
+    ! -------------------------------------------------------------------------
+    DO i=ips,ipe
+    DO j=jps,jpe
+  
+      saturation(i,j)=.false.
+      melt(i,j)=0.0 
+      precip_type(i,j)=0
+        
+      ! Modify surface temperature for solar insolation (W/m2)
+      ! Set max temperature in the atmopshere
+      ! ------------------------------------------------------
+      mod_2m_tmp(i,j)=t2(i,j)+(swdown(i,j)/100.0)
+      maxtmp(i,j)=mod_2m_tmp(i,j)
+  
+      ! Only look at points that have precip and are not warm at the surface
+      ! --------------------------------------------------------------------
+      IF (precip(i,j) .gt. 0.0) THEN
+        !IF (mod_2m_tmp(i,j) .gt. 277.15) THEN
+        IF (mod_2m_tmp(i,j) .gt. 275.15) THEN
+          precip_type(i,j)=1  ! Rain
+        ELSE
+  
+          ! Check sounding from top for saturation (RH-water gt 80%)--this is 
+          ! the cloud top. Erase saturation if RH lt 70% (spurious moist layer
+          ! aloft)
+          ! ------------------------------------------------------------------
+          cloud_top_k_index(i,j)=kpe
+          DO k=kpe,kps,-1
+            IF ((z(i,k,j)-ht(i,j)) .gt. 0.0) THEN
+              IF (t_phy(i,k,j) .gt. maxtmp(i,j)) THEN
+                maxtmp(i,j)=t_phy(i,k,j)
+              ENDIF
+              IF ( ( rh(i,k,j) .gt. 80 ) .and. & 
+                   ( .NOT. saturation(i,j) ) ) THEN
+                cloud_top_tmp(i,j)=t_phy(i,k,j)
+                cloud_top_k_index(i,j)=k
+                saturation(i,j)=.true.
+                precip_type(i,j)=2 ! Snow
+              ENDIF
+              IF ( ( rh(i,k,j) .le. 70 ) .and. &
+                   ( saturation(i,j) ) ) THEN
+                saturation(i,j)=.false.
+              ENDIF
+            ENDIF
+          ENDDO
+
+          ! Perform simple check to assign types with no melting layer
+          ! shenanigans going on
+          ! ----------------------------------------------------------------
+          IF (cloud_top_tmp(i,j) .le. ccn_tmp .and. &
+          maxtmp(i,j) .le. 273.15) THEN
+            precip_type(i,j)=2  ! Snow
+          ENDIF
+
+          ! ELSE, have to go through the profile again to see if snow melts, 
+          ! and if anything re-freezes
+          ! ----------------------------------------------------------------
+          DO k=cloud_top_k_index(i,j),kps,-1
+            IF ((z(i,k,j)-ht(i,j)) .gt. 0.0) THEN
+ 
+              ! Condition 0--assign falling rain when we get to the 
+              ! supercooled temperature if too warm
+              ! ---------------------------------------------------
+              IF (cloud_top_tmp(i,j) .eq. t_phy(i,k,j) .and. &
+              cloud_top_tmp(i,j) .gt. ccn_tmp) THEN
+                 precip_type(i,j)=1  ! Rain
+              ENDIF
+
+              ! Condition 1--falling frozen precip that will start to melt
+              ! Add up melting energy over warm layers--if enough, turn to 
+              ! liquid
+              ! ----------------------------------------------------------
+              IF ((precip_type(i,j) .eq. 2 .or. precip_type(i,j) .eq. 3) .and. &
+              t_phy(i,k,j) .gt. 273.15) THEN
+                melt(i,j)=melt(i,j)+9.8*(((t_phy(i,k,j)-273.15)/273.15)* &
+                          (z(i,k,j)-z(i,k-1,j)))
+                IF (melt(i,j) .gt. total_melt) THEN
+                  precip_type(i,j)=1  ! Rain
+                  melt(i,j)=0.0  ! Reset melting energy in case it re-freezes
+                ENDIF
+              ENDIF
+
+              ! Condition 2--falling partially melted precip encounters 
+              ! sub-freezing air. Snow will be converted to ice pellets if 
+              ! at least 1/4 of it melted. Instantaneous freeze-up, simplistic 
+              ! --------------------------------------------------------------
+              IF (t_phy(i,k,j) .le. 273.15 .and. &
+              melt(i,j) .gt. total_melt/4.0 .and. &
+              (precip_type(i,j) .eq. 2 .or. precip_type(i,j) .eq. 3)) THEN
+                precip_type(i,j)=3  ! Ice
+                melt(i,j)=0.0
+              ENDIF
+             
+              ! Condition 3--falling liquid that will re-freeze--must reach 
+              ! nucleation temperature
+              ! -----------------------------------------------------------
+              IF (precip_type(i,j) .eq. 1) THEN
+                IF (t_phy(i,k,j) .le. ccn_tmp) THEN
+                  precip_type(i,j)=3  ! Ice
+                ENDIF
+              ENDIF
+            ENDIF  ! End if (z-ht)>0
+          ENDDO  ! End do k=kpe,kps,-1
+        ENDIF  ! End if mod_2m_tmp>273.15
+
+        ! Accumulate precip according to precip_type
+        ! ------------------------------------------
+        IF (precip_type(i,j) .eq. 3) THEN 
+          ice(i,j)=ice(i,j)+precip(i,j)
+        ENDIF
+        IF (precip_type(i,j) .eq. 2) THEN
+          snow(i,j)=snow(i,j)+precip(i,j)
+          snowfall(i,j)=snowfall(i,j)+snow_ratio*precip(i,j) &
+                        *(5.-mod_2m_tmp(i,j)+273.15)**0.5
+        ENDIF
+        IF (precip_type(i,j) .eq. 1) THEN
+          IF (mod_2m_tmp(i,j) .gt. 273.15) THEN
+            rain(i,j)=rain(i,j)+precip(i,j)
+          ELSE
+            frz_rain(i,j)=frz_rain(i,j)+precip(i,j)
+          ENDIF
+        ENDIF
+
+      ENDIF  ! End if precip>0
+
+    ENDDO  ! End do j=jps,jpe
+    ENDDO  ! End do i=ips,ipe
+
+  END SUBROUTINE precip_type_diagnostics
+
+
+
+  SUBROUTINE vis_diagnostics ( qcloud                           &
+                             , qrain                            &
+                             , qice                             &
+                             , qsnow                            &
+                             , wind10m                          &
+                             , rh2m                             &
+                             , dustc                            &
+                             , vis                              &
+                             , vis_dust                         &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+
+    INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde,        &
+                           ims, ime, jms, jme, kms, kme,        &
+                           ips, ipe, jps, jpe, kps, kpe
+
+    INTEGER, PARAMETER :: ndust=5
+
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(IN   ) ::                               qcloud  &
+                                              ,          qrain  &
+                                              ,           qice  & 
+                                              ,          qsnow  & 
+                                              ,        wind10m  & 
+                                              ,           rh2m
+    REAL, DIMENSION( ims:ime, jms:jme, ndust ),                 &
+         INTENT(IN   ) ::                                dustc
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(  OUT) ::                                  vis  &
+                                              ,       vis_dust
+
+    ! Local
+    ! -----
+    INTEGER :: i,j,k,d
+    REAL, PARAMETER :: visfactor=3.912
+    REAL, DIMENSION (ndust) :: dustfact
+    REAL :: bc, br, bi, bs, dust_extcoeff, hydro_extcoeff, extcoeff, vis_haze
+
+    ! Dust factor based on 5 bin AFWA dust scheme.  This is a simplification
+    ! of the scheme in WRFPOST.  More weight is applied to smaller particles.
+    ! -----------------------------------------------------------------------
+    dustfact=(/1.470E-6,7.877E-7,4.623E-7,2.429E-7,1.387E-7/)
+
+    DO i=ims,ime
+      DO j=jms,jme
+
+        ! Hydrometeor extinction coefficient
+        ! ----------------------------------
+        bc=144.7*qcloud(i,j)**0.88
+        br=2.240*qrain(i,j)**0.75
+        bi=327.8*qice(i,j)
+        bs=10.36*qsnow(i,j)**0.78
+        hydro_extcoeff=bc+br+bi+bs
+
+        ! Dust extinction coefficient
+        ! ---------------------------
+        dust_extcoeff=0.
+        DO d=1,ndust
+          dust_extcoeff=dust_extcoeff+dustfact(d)*dustc(i,j,d)
+        ENDDO
+
+        ! Visibility due to haze obscuration
+        ! ----------------------------------
+        vis_haze=1500.*(105.-rh2m(i,j)+wind10m(i,j))
+        
+        ! Calculate total visibility
+        ! Take minimum visibility from hydro/lithometeors and haze
+        ! Define maximum visibility as 20 km (UPDATE: 999.999 km)
+        ! --------------------------------------------------------
+        extcoeff=hydro_extcoeff+dust_extcoeff
+        IF (extcoeff .gt. 0.) THEN
+          vis(i,j)=MIN(visfactor/extcoeff,vis_haze)
+        ELSE
+          vis(i,j)=999999.
+        ENDIF
+
+        ! Calculate dust visibility
+        ! Again, define maximum visibility as 20 km
+        ! -----------------------------------------
+        IF (dust_extcoeff .gt. 0.) THEN
+          vis_dust(i,j)=MIN(visfactor/dust_extcoeff,999999.)
+        ELSE
+          vis_dust(i,j)=999999.
+        ENDIF
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE vis_diagnostics
+  
+  
+
+  SUBROUTINE cloud_diagnostics (qcloud                          &
+                             , qice                             &
+                             , qsnow                            &
+                             , rh                               &
+                             , dz8w                             &
+                             , rho                              &
+                             , z                                &
+                             , ht                               &
+                             , cloud                            &
+                             , cloud_ceil                       &
+                             , ids, ide, jds, jde, kds, kde     &
+                             , ims, ime, jms, jme, kms, kme     &
+                             , ips, ipe, jps, jpe, kps, kpe )
+
+    INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde,        &
+                           ims, ime, jms, jme, kms, kme,        &
+                           ips, ipe, jps, jpe, kps, kpe
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),               &
+         INTENT(IN   ) ::                               qcloud  &
+                                              ,           qice  & 
+                                              ,          qsnow  & 
+                                              ,             rh  & 
+                                              ,           dz8w  & 
+                                              ,            rho  &
+                                              ,              z
+
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(IN   ) ::                                   ht
+
+    REAL, DIMENSION( ims:ime, jms:jme ),                        &
+         INTENT(  OUT) ::                                cloud  &
+                                              ,     cloud_ceil
+
+    ! Local
+    ! -----
+    INTEGER :: i, j, k
+    REAL    :: tot_cld_cond, maxrh, cld_frm_cnd, cld_frm_rh
+
+    ! Calculate cloud cover based on total cloud condensate, or if none
+    ! present, from maximum relative humidity in the column.
+    ! -----------------------------------------------------------------
+    DO i=ims,ime
+      DO j=jms,jme
+        tot_cld_cond = 0.
+        maxrh = -9999.
+        cloud_ceil(i,j) = -9999.
+        DO k=kms,kme
+
+          ! Total cloud condensate
+          ! ----------------------
+          tot_cld_cond = tot_cld_cond + (qcloud (i,k,j) + qice (i,k,j) &
+                         + qsnow (i,k,j)) * dz8w (i,k,j) * rho(i,k,j)
+
+          ! Maximum column relative humidity
+          ! --------------------------------
+          IF (rh (i,k,j) .gt. maxrh) THEN
+            maxrh = rh (i,k,j)
+          ENDIF
+          
+          ! Cloud cover parameterization. Take maximum value
+          ! from condensate and relative humidity terms.
+          ! ------------------------------------------------
+          cld_frm_cnd = 50. * tot_cld_cond
+          cld_frm_rh = MAX(((maxrh - 70.) / 30.),0.)
+          cloud (i,j) = MAX(cld_frm_cnd,cld_frm_rh)
+
+          ! Calculate cloud ceiling, the level at which
+          ! parameterization of cloud cover exceeds 80%
+          ! -------------------------------------------
+          IF ( cloud_ceil (i,j) .eq. -9999. .and. cloud (i,j) .gt. 0.8 ) THEN
+            cloud_ceil (i,j) = z (i,k,j) - ht (i,j)
+          ENDIF
+        ENDDO
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE cloud_diagnostics
+
+
+
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  !~ 
+  !~ Name:
+  !~    calc_rh
+  !~
+  !~ Description:
+  !~    This function calculates relative humidity given pressure, 
+  !~    temperature, and water vapor mixing ratio.
+  !~ 
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  FUNCTION calc_rh ( p, t, qv ) result ( rh )
+    
+    IMPLICIT NONE
+ 
+    REAL, INTENT(IN) :: p, t, qv
+    REAL :: rh
+
+    ! Local
+    ! -----
+    REAL, PARAMETER :: pq0=379.90516
+    REAL, PARAMETER :: a2=17.2693882
+    REAL, PARAMETER :: a3=273.16
+    REAL, PARAMETER :: a4=35.86
+    REAL, PARAMETER :: rhmin=1.
+    REAL :: q, qs
+    INTEGER :: i,j,k
+  
+    ! Following algorithms adapted from WRFPOST
+    ! May want to substitute with another later
+    ! -----------------------------------------
+      q=qv/(1.0+qv)
+      qs=pq0/p*exp(a2*(t-a3)/(t-a4))
+      rh=100.*q/qs
+      IF (rh .gt. 100.) THEN
+        rh=100.
+      ELSE IF (rh .lt. rhmin) THEN
+        rh=rhmin
+      ENDIF
+
+  END FUNCTION calc_rh
+
+
+
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  !~ 
+  !~ Name:
+  !~    uv_wind
+  !~
+  !~ Description:
+  !~    This function calculates the wind speed given U and V wind
+  !~    components.
+  !~ 
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  FUNCTION uv_wind ( u, v ) result ( wind_speed )
+ 
+    IMPLICIT NONE
+ 
+    REAL, INTENT(IN) :: u, v
+    REAL :: wind_speed
+
+    wind_speed = sqrt( u*u + v*v )
+
+  END FUNCTION uv_wind
+
+
+  
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  !~
+  !~ Name:
+  !~    Theta
+  !~
+  !~ Description:
+  !~    This function calculates potential temperature as defined by
+  !~    Poisson's equation, given temperature and pressure ( hPa ).
+  !~
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  FUNCTION Theta ( t, p )
+  IMPLICIT NONE
+
+     !~ Variable declaration
+     !  --------------------
+     REAL, INTENT ( IN ) :: t
+     REAL, INTENT ( IN ) :: p
+     REAL                :: theta
+
+     REAL :: Rd ! Dry gas constant
+     REAL :: Cp ! Specific heat of dry air at constant pressure
+     REAL :: p0 ! Standard pressure ( 1000 hPa )
+  
+     Rd =  287.04
+     Cp = 1004.67
+     p0 = 1000.00
+
+     !~ Poisson's equation
+     !  ------------------
+     theta = t * ( (p0/p)**(Rd/Cp) )
+  
+  END FUNCTION Theta
+
+
+
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  !~
+  !~ Name:
+  !~    Thetae
+  !~
+  !~ Description:
+  !~    This function returns equivalent potential temperature using the 
+  !~    method described in Bolton 1980, Monthly Weather Review, equation 43.
+  !~
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  FUNCTION Thetae ( tK, p, rh, mixr )
+  IMPLICIT NONE
+
+     !~ Variable Declarations
+     !  ---------------------
+     REAL :: tK        ! Temperature ( K )
+     REAL :: p         ! Pressure ( hPa )
+     REAL :: rh        ! Relative humidity
+     REAL :: mixr      ! Mixing Ratio ( kg kg^-1)
+     REAL :: te        ! Equivalent temperature ( K )
+     REAL :: thetae    ! Equivalent potential temperature
+  
+     REAL, PARAMETER :: R  = 287.04         ! Universal gas constant (J/deg kg)
+     REAL, PARAMETER :: P0 = 1000.0         ! Standard pressure at surface (hPa)
+     REAL, PARAMETER :: lv = 2.54*(10**6)   ! Latent heat of vaporization
+                                            ! (J kg^-1)
+     REAL, PARAMETER :: cp = 1004.67        ! Specific heat of dry air constant
+                                            ! at pressure (J/deg kg)
+     REAL :: tlc                            ! LCL temperature
+  
+     !~ Calculate the temperature of the LCL
+     !  ------------------------------------
+     tlc = TLCL ( tK, rh )
+  
+     !~ Calculate theta-e
+     !  -----------------
+     thetae = (tK * (p0/p)**( (R/Cp)*(1.- ( (.28E-3)*mixr*1000.) ) ) )* &
+                 exp( (((3.376/tlc)-.00254))*&
+                    (mixr*1000.*(1.+(.81E-3)*mixr*1000.)) )
+  
+  END FUNCTION Thetae
+
+
+
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  !~
+  !~ Name:
+  !~    The2T.f90
+  !~
+  !~ Description:
+  !~    This function returns the temperature at any pressure level along a
+  !~    saturation adiabat by iteratively solving for it from the parcel
+  !~    thetae.
+  !~
+  !~ Dependencies:
+  !~    function thetae.f90
+  !~
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  FUNCTION The2T ( thetaeK, pres, flag ) result ( tparcel )
+  IMPLICIT NONE
+  
+     !~ Variable Declaration
+     !  --------------------
+     REAL,    INTENT     ( IN ) :: thetaeK
+     REAL,    INTENT     ( IN ) :: pres
+     LOGICAL, INTENT ( INOUT )  :: flag
+     REAL                       :: tparcel
+  
+     REAL :: thetaK
+     REAL :: tovtheta
+     REAL :: tcheck
+     REAL :: svpr, svpr2
+     REAL :: smixr, smixr2
+     REAL :: thetae_check, thetae_check2
+     REAL :: tguess_2, correction
+  
+     LOGICAL :: found
+     INTEGER :: iter
+  
+     REAL :: R     ! Dry gas constant
+     REAL :: Cp    ! Specific heat for dry air
+     REAL :: kappa ! Rd / Cp
+     REAL :: Lv    ! Latent heat of vaporization at 0 deg. C
+  
+     R     = 287.04
+     Cp    = 1004.67
+     Kappa = R/Cp
+     Lv    = 2.500E+6
+
+     !~ Make initial guess for temperature of the parcel
+     !  ------------------------------------------------
+     tovtheta = (pres/100000.0)**(r/cp)
+     tparcel  = thetaeK/exp(lv*.012/(cp*295.))*tovtheta
+
+     iter = 1
+     found = .false.
+     flag = .false.
+
+     DO
+        IF ( iter > 105 ) EXIT
+
+        tguess_2 = tparcel + REAL ( 1 )
+
+        svpr   = 6.122 * exp ( (17.67*(tparcel-273.15)) / (tparcel-29.66) )
+        smixr  = ( 0.622*svpr ) / ( (pres/100.0)-svpr )
+        svpr2  = 6.122 * exp ( (17.67*(tguess_2-273.15)) / (tguess_2-29.66) )
+        smixr2 = ( 0.622*svpr2 ) / ( (pres/100.0)-svpr2 )
+
+        !  ------------------------------------------------------------------ ~!
+        !~ When this function was orinially written, the final parcel         ~!
+        !~ temperature check was based off of the parcel temperature and      ~!
+        !~ not the theta-e it produced.  As there are multiple temperature-   ~!
+        !~ mixing ratio combinations that can produce a single theta-e value, ~!
+        !~ we change the check to be based off of the resultant theta-e       ~!
+        !~ value.  This seems to be the most accurate way of backing out      ~!
+        !~ temperature from theta-e.                                          ~!
+        !~                                                                    ~!
+        !~ Rentschler, April 2010                                             ~!
+        !  ------------------------------------------------------------------  !
+
+        !~ Old way...
+        !thetaK = thetaeK / EXP (lv * smixr  /(cp*tparcel) )
+        !tcheck = thetaK * tovtheta
+
+        !~ New way
+        thetae_check  = Thetae ( tparcel,  pres/100., 100., smixr  )
+        thetae_check2 = Thetae ( tguess_2, pres/100., 100., smixr2 )
+
+        !~ Whew doggies - that there is some accuracy...
+        !IF ( ABS (tparcel-tcheck) < .05) THEN
+        IF ( ABS (thetaeK-thetae_check) < .001) THEN
+           found = .true.
+           flag  = .true.
+           EXIT
+        END IF
+
+        !~ Old
+        !tparcel = tparcel + (tcheck - tparcel)*.3
+
+        !~ New
+        correction = ( thetaeK-thetae_check ) / ( thetae_check2-thetae_check )
+        tparcel = tparcel + correction
+
+        iter = iter + 1
+     END DO
+
+     IF ( .not. found ) THEN
+        print*, "Warning! Thetae to temperature calculation did not converge!"
+        print*, "Thetae ", thetaeK, "Pressure ", pres
+     END IF
+
+  END FUNCTION The2T
+
+
+
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  !~
+  !~ Name:
+  !~    VirtualTemperature
+  !~
+  !~ Description:
+  !~    This function returns virtual temperature given temperature ( K )
+  !~    and mixing ratio.
+  !~
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  FUNCTION VirtualTemperature ( tK, w ) result ( Tv )
+  IMPLICIT NONE
+
+     !~ Variable declaration
+     real, intent ( in ) :: tK !~ Temperature
+     real, intent ( in ) :: w  !~ Mixing ratio ( kg kg^-1 )
+     real                :: Tv !~ Virtual temperature
+
+     Tv = tK * ( 1.0 + (w/0.622) ) / ( 1.0 + w )
+
+  END FUNCTION VirtualTemperature
+
+
+
+
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  !~
+  !~ Name:
+  !~    SaturationMixingRatio
+  !~
+  !~ Description:
+  !~    This function calculates saturation mixing ratio given the
+  !~    temperature ( K ) and the ambient pressure ( Pa ).  Uses 
+  !~    approximation of saturation vapor pressure.
+  !~
+  !~ References:
+  !~    Bolton (1980), Monthly Weather Review, pg. 1047, Eq. 10
+  !~
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  FUNCTION SaturationMixingRatio ( tK, p ) result ( ws )
+
+    IMPLICIT NONE
+
+    REAL, INTENT ( IN ) :: tK
+    REAL, INTENT ( IN ) :: p
+    REAL                :: ws
+
+    REAL :: es
+
+    es = 6.122 * exp ( (17.67*(tK-273.15))/ (tK-29.66) )
+    ws = ( 0.622*es ) / ( (p/100.0)-es )
+
+  END FUNCTION SaturationMixingRatio
+
+
+
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  !~                                                                     
+  !~ Name:                                                                
+  !~    tlcl                                                               
+  !~                                                                        
+  !~ Description:                                                            
+  !~    This function calculates the temperature of a parcel of air would have
+  !~    if lifed dry adiabatically to it's lifting condensation level (lcl).  
+  !~                                                                          
+  !~ References:                                                              
+  !~    Bolton (1980), Monthly Weather Review, pg. 1048, Eq. 22
+  !~                                                                          
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  FUNCTION TLCL ( tk, rh )
+    
+    IMPLICIT NONE
+ 
+    REAL, INTENT ( IN ) :: tK   !~ Temperature ( K )
+    REAL, INTENT ( IN ) :: rh   !~ Relative Humidity ( % )
+    REAL                :: tlcl
+    
+    REAL :: denom, term1, term2
+
+    term1 = 1.0 / ( tK - 55.0 )
+    IF ( rh > REAL (0) ) THEN
+      term2 = ( LOG (rh/100.0)  / 2840.0 )
+    ELSE
+      term2 = ( LOG (0.001/1.0) / 2840.0 )
+    END IF
+    denom = term1 - term2
+    tlcl = ( 1.0 / denom ) + REAL ( 55 ) 
+
+  END FUNCTION TLCL
+
+
+
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+  !~                                                                          ~!
+  !~ Name:                                                                    ~!
+  !~    Buoyancy                                                              ~!
+  !~                                                                          ~!
+  !~ Description:                                                             ~!
+  !~    This function computes Convective Available Potential Energy (CAPE)   ~!
+  !~    with inhibition as a result of water loading given the data required  ~!
+  !~    to run up a sounding.                                                 ~!
+  !~                                                                          ~!
+  !~    Additionally, since we are running up a sounding anyways, this        ~!
+  !~    function returns the height of the Level of Free Convection (LFC) and ~!
+  !~    the pressure at the LFC.  That-a-ways, we don't have to run up a      ~!
+  !~    sounding later, saving a relatively computationally expensive         ~!
+  !~    routine.                                                              ~!
+  !~                                                                          ~!
+  !~ Usage:                                                                   ~!
+  !~    ostat = Buoyancy ( tK, rh, p, hgt, sfc, CAPE, ZLFC, PLFC, parcel )    ~!
+  !~                                                                          ~!
+  !~ Where:                                                                   ~!
+  !~                                                                          ~!
+  !~    IN                                                                    ~!
+  !~    --                                                                    ~!
+  !~    tK   = Temperature ( K )                                              ~!
+  !~    rh   = Relative Humidity ( % )                                        ~!
+  !~    p    = Pressure ( Pa )                                                ~!
+  !~    hgt  = Geopotential heights ( m )                                     ~!
+  !~    sfc  = integer rank within submitted arrays that represents the       ~!
+  !~           surface                                                        ~!
+  !~                                                                          ~!
+  !~    OUT                                                                   ~!
+  !~    ---                                                                   ~!
+  !~    ostat         INTEGER return status. Nonzero is bad.                  ~!
+  !~    CAPE ( J/kg ) Convective Available Potential Energy                   ~!
+  !~    ZLFC ( gpm )  Height at the LFC                                       ~!
+  !~    PLFC ( Pa )   Pressure at the LFC                                     ~!
+  !~                                                                          ~!
+  !~    tK, rh, p, and hgt are all REAL arrays, arranged from lower levels    ~!
+  !~    to higher levels.                                                     ~!
+  !~                                                                          ~!
+  !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!!
+    FUNCTION Buoyancy ( nz, tk, rh, p, hgt, sfc, cape, zlfc, plfc, parcel ) &
+               result (ostat)
+  
+      IMPLICIT NONE
+  
+      INTEGER, INTENT ( IN )  :: nz          !~ Number of vertical levels
+      INTEGER, INTENT ( IN )  :: sfc         !~ Surface level in the profile
+      REAL,    INTENT ( IN )  :: tk   ( nz ) !~ Temperature profile ( K )
+      REAL,    INTENT ( IN )  :: rh   ( nz ) !~ Relative Humidity profile ( % )
+      REAL,    INTENT ( IN )  :: p    ( nz ) !~ Pressure profile ( Pa )
+      REAL,    INTENT ( IN )  :: hgt  ( nz ) !~ Height profile ( gpm )
+      REAL,    INTENT ( OUT ) :: cape        !~ CAPE ( J kg^-1 )
+      REAL,    INTENT ( OUT ) :: zlfc        !~ LFC Height ( gpm )
+      REAL,    INTENT ( OUT ) :: plfc        !~ LFC Pressure ( Pa )
+      INTEGER                 :: ostat       !~ Function return status
+                                             !~ Nonzero is bad.
+
+      INTEGER, INTENT ( IN  ) :: parcel      !~ Most Unstable = 1 (default)
+                                             !~ Mean layer    = 2
+                                             !~ Surface based = 3
+  
+      !~ Derived profile variables
+      !  -------------------------
+      REAL                    :: ws   ( nz ) !~ Saturation mixing ratio
+      REAL                    :: w    ( nz ) !~ Mixing ratio
+      REAL                    :: buoy ( nz ) !~ Buoyancy
+      REAL                    :: tlclK       !~ LCL temperature ( K )
+      REAL                    :: plcl        !~ LCL pressure ( Pa )
+      REAL                    :: nbuoy       !~ Negative buoyancy
+      REAL                    :: pbuoy       !~ Positive buoyancy
+  
+      !~ Source parcel information
+      !  -------------------------
+      REAL                    :: srctK       !~ Source parcel temperature ( K )
+      REAL                    :: srcrh       !~ Source parcel rh ( % )
+      REAL                    :: srcws       !~ Source parcel sat. mixing ratio
+      REAL                    :: srcw        !~ Source parcel mixing ratio
+      REAL                    :: srcp        !~ Source parcel pressure ( Pa )
+      REAL                    :: srctheta    !~ Source parcel theta ( K )
+      REAL                    :: srcthetaeK  !~ Source parcel theta-e ( K )
+      INTEGER                 :: srclev      !~ Level of the source parcel
+      INTEGER                 :: sfcoff      !~ Surface offset
+      REAL                    :: spdiff      !~ Pressure difference
+   
+      !~ Parcel variables
+      !  ----------------
+      REAL                    :: ptK        !~ Parcel temperature ( K )
+      REAL                    :: ptvK       !~ Parcel virtual temperature ( K )
+      REAL                    :: tvK        !~ Ambient virtual temperature ( K )
+      REAL                    :: pw         !~ Parcel mixing ratio
+  
+      !~ Other utility variables
+      !  -----------------------
+      INTEGER                 :: i, j, k    !~ Dummy iterator
+      INTEGER                 :: lfclev     !~ Level of LFC
+      INTEGER                 :: prcl       !~ Internal parcel type indicator
+      INTEGER                 :: mlev       !~ Level for ML calculation
+      INTEGER                 :: lyrcnt     !~ Number of layers in mean layer
+      LOGICAL                 :: flag       !~ Dummy flag
+      LOGICAL                 :: wflag      !~ Saturation flag
+      REAL                    :: freeze     !~ Water loading multiplier
+      REAL                    :: CIN        !~ Convective inhibition
+      REAL                    :: pdiff      !~ Pressure difference between levs 
+  
+      !~ Thermo / dynamical constants
+      !  ----------------------------
+      REAL                    :: Rd         !~ Dry gas constant
+         PARAMETER ( Rd = 287.058 )         !~ J deg^-1 kg^-1
+      REAL                    :: Cp         !~ Specific heat constant pressure
+         PARAMETER ( Cp = 1004.67 )         !~ J deg^-1 kg^-1
+      REAL                    :: g          !~ Acceleration due to gravity
+         PARAMETER ( g  = 9.80665 )         !~ m s^-2
+      REAL                    :: RUNDEF
+         PARAMETER ( RUNDEF = -9.999E30 )
+  
+      !~ Initialize variables
+      !  --------------------
+      ostat  = 0
+      CAPE   = REAL ( 0 )
+      ZLFC   = RUNDEF
+      PLFC   = RUNDEF
+  
+      !~ Look for submitted parcel definition
+      !~ 1 = Most unstable
+      !~ 2 = Mean layer
+      !~ 3 = Surface based
+      !  -------------------------------------
+      IF ( parcel > 3 .or. parcel < 1 ) THEN
+         !WRITE( *,* ) ' WARNING: User submitted parcel not valid.'
+         !WRITE( *,* ) ' Defaulting to MU parcel.'
+         !return
+         prcl = 1
+      ELSE
+         prcl =  parcel
+      END IF
+  
+      !~ Initalize our parcel to be (sort of) surface based.  Because of
+      !~ issues we've been observing in the WRF model, specifically with
+      !~ excessive surface moisture values at the surface, using a true
+      !~ surface based parcel is resulting a more unstable environment
+      !~ than is actually occuring.  To address this, our surface parcel
+      !~ is now going to be defined as the parcel between 25-50 hPa
+      !~ above the surface.
+      !  ----------------------------------------------------------------
+  
+      !~ Compute mixing ratio values for the layer
+      !  -----------------------------------------
+      DO k = sfc, nz
+        ws  ( k )   = SaturationMixingRatio ( tK(k), p(k) )
+        w   ( k )   = ( rh(k)/100.0 ) * ws ( k )
+      END DO
+  
+      sfcoff=0
+      DO k = 2, nz
+         spdiff = ( p (1) - p (k) ) / REAL ( 100 )
+         IF ( spdiff >= 25. .and. spdiff <= 50. ) THEN
+            sfcoff = ( k - 1 )
+            EXIT
+         END IF
+      END DO
+   
+      sfcoff = 0  ! This negates the 25-50 hPa work-around above
+   
+      srclev      = sfc+sfcoff
+      srctK       = tK    ( sfc+sfcoff )
+      srcrh       = rh    ( sfc+sfcoff )
+      srcp        = p     ( sfc+sfcoff )
+      srcws       = ws    ( sfc+sfcoff )
+      srcw        = w     ( sfc+sfcoff )
+      srctheta    = Theta ( tK(sfc+sfcoff), p(sfc+sfcoff)/100.0 )
+   
+      !~ Compute the profile mixing ratio.  If the parcel is the MU parcel,
+      !~ define our parcel to be the most unstable parcel below 700 hPa
+      !  -------------------------------------------------------------------
+      mlev = sfc + 1
+      DO k = sfc + 1, nz
+   
+         !~ Identify the last layer within 100 hPa of the surface
+         !  -----------------------------------------------------
+         pdiff = ( p (k) - p (sfc) ) / REAL ( 100 )
+         IF ( pdiff <= REAL (100) ) mlev = k
+   
+         IF ( prcl == 1 ) THEN
+            IF ( (p(k) > 70000.0) .and. (w(k) > srcw) ) THEN
+               srctheta = Theta ( tK(k), p(k)/100.0 )
+               srcw = w ( k )
+               srclev  = k
+               srctK   = tK ( k )
+               srcrh   = rh ( k )
+               srcp    = p  ( k )
+            END IF
+         END IF
+   
+      END DO
+   
+      !~ If we want the mean layer parcel, compute the mean values in the
+      !~ lowest 100 hPa.
+      !  ----------------------------------------------------------------
+      lyrcnt =  mlev - sfc + 1
+      IF ( prcl == 2 ) THEN
+   
+         srclev   = sfc
+         srctK    = SUM ( tK (sfc:mlev) ) / REAL ( lyrcnt )
+         srcw     = SUM ( w  (sfc:mlev) ) / REAL ( lyrcnt )
+         srcrh    = SUM ( rh (sfc:mlev) ) / REAL ( lyrcnt )
+         srcp     = SUM ( p  (sfc:mlev) ) / REAL ( lyrcnt )
+         srctheta = Theta ( srctK, srcp/100. )
+   
+      END IF
+   
+      !~ Chirp status as necessary.
+      !  --------------------------
+  !       WRITE ( *,* ) ''
+  !       WRITE ( *,* ) ' ==================================== '
+  !       WRITE ( *,* ) ' Now in Buoyancy '
+  !       WRITE ( *,* ) ''
+  !       WRITE ( *,* ) ' User submitted data: '
+  !       WRITE ( *,'(a,I7)' ) '  Number of vertical levels: ', nz
+  !       WRITE ( *,'(6A12)' ) 'Level', 'Temp', 'RH', 'Pres', 'Hgt', 'MixRat'
+  !       DO i = 1, nz
+  !          WRITE ( *,'(i12,5f12.3)' ) i, tK ( i ), rh ( i ) &
+  !                , p ( i )/REAL ( 100 ), hgt ( i ), w ( i )*REAL ( 1000 )
+  !       END DO
+  !       WRITE ( *,* ) ' Surface level: ', sfc
+  !       WRITE ( *,* ) ''
+   
+      srcthetaeK = Thetae ( srctK, srcp/100.0, srcrh, srcw )
+   
+      !~ Chirp status again
+      !  ------------------
+  !    10 FORMAT ( A15,F12.3,A8 )
+  !       WRITE ( *,* ) 'Source parcel values: '
+  !       WRITE ( *,'(A15,I8)' ) ' Source parcel level: ', srclev
+  !       WRITE ( *,FMT=10 ) ' Mixing Ratio:', srcw * REAL ( 1000 ), 'g/kg'
+  !       WRITE ( *,FMT=10 ) ' Temperature:', srctK, 'K'
+  !       WRITE ( *,FMT=10 ) ' RH:',srcrh, '%'
+  !       WRITE ( *,FMT=10 ) ' Pressure:', srcp/REAL (100), 'hPa'
+  !       WRITE ( *,FMT=10 ) ' Theta-E:', srcthetaeK, 'K'
+  !       WRITE ( *,* ) ''
+   
+   
+      !~ Calculate temperature and pressure of the LCL
+      !  ---------------------------------------------
+      tlclK = TLCL ( tK(srclev), rh(srclev) )
+      plcl  = p(srclev) * ( (tlclK/tK(srclev))**(Cp/Rd) )
+   
+      !~ Chirp
+      !  -----
+  !       WRITE ( *,* ) ' LCL Temperature: ', tlclK
+  !       WRITE ( *,* ) ' LCL Pressure:    ', plcl / REAL ( 100 )
+  !       WRITE ( *,* ) ''
+  !       WRITE ( *,* ) ' Now lifting parcel...'
+  !       WRITE ( *,'(7A15)') 'Level', 'Pressure', 'Parcel Tmp', 'Parcel Mixr' &
+  !                         , 'Parcel Tv', 'Ambient Tv', 'Buoyancy'
+   
+   
+      buoy  = REAL ( 0 )
+      pw    = srcw
+      wflag = .false.
+      DO k  = srclev, nz
+         IF ( tK (k) < 253.15 ) EXIT
+         IF ( p (k) <= plcl ) THEN
+   
+            !~ The first level after we pass the LCL, we're still going to
+            !~ lift the parcel dry adiabatically, as we haven't added the
+            !~ the required code to switch between the dry adiabatic and moist
+            !~ adiabatic cooling.  Since the dry version results in a greater
+            !~ temperature loss, doing that for the first step so we don't over
+            !~ guesstimate the instability.
+            !  ----------------------------------------------------------------
+   
+            IF ( wflag ) THEN
+               flag  = .false.
+   
+               !~ Above the LCL, our parcel is now undergoing moist adiabatic
+               !~ cooling.  Because of the latent heating being undergone as
+               !~ the parcel rises above the LFC, must iterative solve for the
+               !~ parcel temperature using equivalant potential temperature,
+               !~ which is conserved during both dry adiabatic and
+               !~ pseudoadiabatic displacements.
+               !  --------------------------------------------------------------
+               ptK   = The2T ( srcthetaeK, p(k), flag )
+   
+               !~ Calculate the parcel mixing ratio, which is now changing
+               !~ as we condense moisture out of the parcel, and is equivalent
+               !~ to the saturation mixing ratio, since we are, in theory, at
+               !~ saturation.
+               !  ------------------------------------------------------------
+               pw = SaturationMixingRatio ( ptK, p(k) )
+   
+               !~ Now we can calculate the virtual temperature of the parcel
+               !~ and the surrounding environment to assess the buoyancy.
+               !  ----------------------------------------------------------
+               ptvK  = VirtualTemperature ( ptK, pw )
+               tvK   = VirtualTemperature ( tK (k), w (k) )
+   
+               !~ Calculate the buoyancy at the level
+               !  -----------------------------------
+               !buoy ( k ) = g * ( (ptvK - tvK)/tvK )
+   
+               !~ Modification to account for water loading
+               !  -----------------------------------------
+               freeze = 0.033 * ( 263.15 - pTvK )
+               IF ( freeze > 1.0 ) freeze = 1.0
+               IF ( freeze < 0.0 ) freeze = 0.0
+   
+               !~ Approximate how much of the water vapor has condensed out
+               !~ of the parcel at this level
+               !  ---------------------------------------------------------
+               freeze = freeze * 333700.0 * ( srcw - pw ) / 1005.7
+   
+               pTvK = pTvK - pTvK * ( srcw - pw ) + freeze
+               buoy ( k ) = g * ( (ptvK - tvK)/tvK )
+   
+            ELSE
+   
+               !~ Since the theta remains constant whilst undergoing dry
+               !~ adiabatic processes, can back out the parcel temperature
+               !~ from potential temperature below the LCL
+               !  --------------------------------------------------------
+               ptK   = srctheta / ( 100000.0/p(k) )**(Rd/Cp)
+   
+               !~ Grab the parcel virtual temperture, can use the source
+               !~ mixing ratio since we are undergoing dry adiabatic cooling
+               !  ----------------------------------------------------------
+               ptvK  = VirtualTemperature ( ptK, srcw )
+   
+               !~ Virtual temperature of the environment
+               !  --------------------------------------
+               tvK   = VirtualTemperature ( tK (k), w (k) )
+   
+               !~ Buoyancy at this level
+               !  ----------------------
+               buoy ( k ) = g * ( (ptvK - tvK)/tvK )
+   
+               wflag = .true.
+   
+            END IF
+   
+         ELSE
+   
+            !~ Since the theta remains constant whilst undergoing dry
+            !~ adiabatic processes, can back out the parcel temperature
+            !~ from potential temperature below the LCL
+            !  --------------------------------------------------------
+            ptK   = srctheta / ( 100000.0/p(k) )**(Rd/Cp)
+   
+            !~ Grab the parcel virtual temperture, can use the source
+            !~ mixing ratio since we are undergoing dry adiabatic cooling
+            !  ----------------------------------------------------------
+            ptvK  = VirtualTemperature ( ptK, srcw )
+   
+            !~ Virtual temperature of the environment
+            !  --------------------------------------
+            tvK   = VirtualTemperature ( tK (k), w (k) )
+   
+            !~ Buoyancy at this level
+            !  ---------------------
+            buoy ( k ) = g * ( (ptvK - tvK)/tvK )
+   
+         END IF
+   
+         !~ Chirp
+         !  -----
+  !          WRITE ( *,'(I15,6F15.3)' )k,p(k)/100.,ptK,pw*1000.,ptvK,tvK,buoy(k)
+   
+      END DO
+   
+      !~ Add up the buoyancies, find the LFC
+      !  -----------------------------------
+      flag   = .false.
+      lfclev = -1
+      nbuoy  = REAL ( 0 )
+      pbuoy = REAL ( 0 )
+      DO k = sfc + 1, nz
+         IF ( tK (k) < 253.15 ) EXIT
+         CAPE = CAPE + MAX ( buoy (k), 0.0 ) * ( hgt (k) - hgt (k-1) )
+         CIN  = CIN  + MIN ( buoy (k), 0.0 ) * ( hgt (k) - hgt (k-1) )
+   
+         !~ If we've already passed the LFC
+         !  -------------------------------
+         IF ( flag .and. buoy (k) > REAL (0) ) THEN
+            pbuoy = pbuoy + buoy (k)
+         END IF
+   
+         !~ We are buoyant now - passed the LFC
+         !  -----------------------------------
+         IF ( .not. flag .and. buoy (k) > REAL (0) .and. p (k) < plcl ) THEN
+            flag = .true.
+            pbuoy = pbuoy + buoy (k)
+            lfclev = k
+         END IF
+   
+         !~ If we think we've passed the LFC, but encounter a negative layer
+         !~ start adding it up.
+         !  ----------------------------------------------------------------
+         IF ( flag .and. buoy (k) < REAL (0) ) THEN
+            nbuoy = nbuoy + buoy (k)
+
+            !~ If the accumulated negative buoyancy is greater than the
+            !~ positive buoyancy, then we are capped off.  Got to go higher
+            !~ to find the LFC. Reset positive and negative buoyancy summations
+            !  ----------------------------------------------------------------
+            IF ( ABS (nbuoy) > pbuoy ) THEN
+               flag   = .false.
+               nbuoy  = REAL ( 0 )
+               pbuoy  = REAL ( 0 )
+               lfclev = -1
+            END IF
+         END IF
+   
+      END DO
+   
+      !~ Assuming the the LFC is at a pressure level for now
+      !  ---------------------------------------------------
+      IF ( lfclev > 0 ) THEN
+         PLFC = p   ( lfclev )
+         ZLFC = hgt ( lfclev )
+      END IF
+   
+      IF ( PLFC /= PLFC .OR. PLFC < REAL (0) ) THEN
+         PLFC = REAL ( -1 )
+         ZLFC = REAL ( -1 )
+      END IF
+   
+      IF ( CAPE /= CAPE ) cape = REAL ( 0 )
+   
+      !~ Chirp
+      !  -----
+  !       WRITE ( *,* ) ' CAPE: ', cape, ' CIN:  ', cin
+  !       WRITE ( *,* ) ' LFC:  ', ZLFC, ' PLFC: ', PLFC
+  !       WRITE ( *,* ) ''
+  !       WRITE ( *,* ) ' Exiting buoyancy.'
+  !       WRITE ( *,* ) ' ==================================== '
+  !       WRITE ( *,* ) ''
+   
+  END FUNCTION Buoyancy 
+
+END MODULE module_diag_afwa
+#endif
diff --git a/wrfv2_fire/phys/module_diag_cl.F b/wrfv2_fire/phys/module_diag_cl.F
new file mode 100644
index 00000000..a05ed0c5
--- /dev/null
+++ b/wrfv2_fire/phys/module_diag_cl.F
@@ -0,0 +1,424 @@
+#if (NMM_CORE == 1)
+MODULE module_diag_cl
+CONTAINS
+   SUBROUTINE diag_cl_stub
+   END SUBROUTINE diag_cl_stub
+END MODULE module_diag_cl
+#else
+!WRF:MEDIATION_LAYER:PHYSICS
+!
+
+MODULE module_diag_cl
+CONTAINS
+
+   SUBROUTINE clwrf_output_calc(                                      &
+                      ids,ide, jds,jde, kds,kde,                      &
+                      ims,ime, jms,jme, kms,kme,                      &
+                      ips,ipe, jps,jpe, kps,kpe,                      & ! patch  dims
+                      i_start,i_end,j_start,j_end,kts,kte,num_tiles   &
+                     ,is_restart                                      & ! CLWRF
+                     ,clwrfH,t2,q2,u10,v10, skintemp                  & ! CLWRF
+                     ,t2clmin,t2clmax,tt2clmin,tt2clmax               & ! CLWRF
+                     ,t2clmean,t2clstd                                & ! CLWRF
+                     ,q2clmin,q2clmax,tq2clmin,tq2clmax               & ! CLWRF
+                     ,q2clmean,q2clstd                                & ! CLWRF
+                     ,u10clmax,v10clmax,spduv10clmax,tspduv10clmax    & ! CLWRF
+                     ,u10clmean,v10clmean,spduv10clmean               & ! CLWRF
+                     ,u10clstd,v10clstd,spduv10clstd                  & ! CLWRF
+                     ,raincclmax,rainncclmax,traincclmax,trainncclmax & ! CLWRF
+                     ,raincclmean,rainncclmean,raincclstd,rainncclstd & ! CLWRF
+                     ,skintempclmin,skintempclmax                     & ! CLWRF
+                     ,tskintempclmin,tskintempclmax                   & ! CLWRF
+                     ,skintempclmean,skintempclstd                    & ! CLWRF
+                     ,raincv,rainncv                                  &
+                     ,dt,xtime,curr_secs2                             &
+                                                                      )
+!----------------------------------------------------------------------
+
+  USE module_dm, ONLY: wrf_dm_sum_real, wrf_dm_maxval
+  USE module_configure 
+
+   IMPLICIT NONE
+!======================================================================
+! Definitions
+!-----------
+!-- DT            time step (second)
+!-- XTIME         forecast time
+!-- curr_secs2    current time in seconds since simulation restart
+!
+!-- RAINCV        cumulus scheme precipitation in one time step (mm)
+!-- RAINNCV       explicit scheme precipitation in one time step (mm)
+!
+!-- ids           start index for i in domain
+!-- ide           end index for i in domain
+!-- jds           start index for j in domain
+!-- jde           end index for j in domain
+!-- kds           start index for k in domain
+!-- kde           end index for k in domain
+!-- ims           start index for i in memory
+!-- ime           end index for i in memory
+!-- jms           start index for j in memory
+!-- jme           end index for j in memory
+!-- ips           start index for i in patch
+!-- ipe           end index for i in patch
+!-- jps           start index for j in patch
+!-- jpe           end index for j in patch
+!-- kms           start index for k in memory
+!-- kme           end index for k in memory
+!-- i_start       start indices for i in tile
+!-- i_end         end indices for i in tile
+!-- j_start       start indices for j in tile
+!-- j_end         end indices for j in tile
+!-- kts           start index for k in tile
+!-- kte           end index for k in tile
+!-- num_tiles     number of tiles
+!
+! CLWRF-UC May.09 definitions
+!-----------
+! is_restart: whether if simulation is a restart
+! clwrfH: Interval (hour) of accumulation for computations 
+! [var]cl[min/max]: [minimum/maximum] of variable [var] during interval
+! t[var]cl[min/max]: Time (minutes) of [minimum/maximum] of variable 
+!    [var] during interval 
+! [var]clmean: mean of variable [var] during interval
+! [var]clstd: standard dev. of variable [var] during interval
+!    Variables are written on aux_hist_out7 (established
+!    in Registry)
+!
+!======================================================================
+
+   INTEGER,      INTENT(IN   )                     ::            &
+                                      ids,ide, jds,jde, kds,kde, &
+                                      ims,ime, jms,jme, kms,kme, &
+                                      ips,ipe, jps,jpe, kps,kpe, &
+                                                        kts,kte, &
+                                                      num_tiles
+
+   INTEGER, DIMENSION(num_tiles), INTENT(IN)       :: i_start,   &
+                                      i_end,j_start,j_end
+
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) ::           & 
+                                      RAINNCV, RAINCV, SKINTEMP 
+
+   REAL,  INTENT(IN   )                            :: DT, XTIME
+   REAL,  INTENT(IN   )                            :: curr_secs2
+
+! LOCAL  VAR
+
+   INTEGER                                   :: i,j,k,its,ite,jts,jte,ij
+   INTEGER                                   :: idp,jdp,irc,jrc,irnc,jrnc,isnh,jsnh
+   INTEGER                                   :: prfreq
+
+   REAL                                      :: xtimep
+   LOGICAL, EXTERNAL                         :: wrf_dm_on_monitor
+   CHARACTER*256                             :: outstring
+   CHARACTER*6                               :: grid_str
+
+!!-------------------
+!! CLWRF-UC Nov.09
+
+   CHARACTER (LEN=80)                        :: timestr
+
+   REAL, DIMENSION( ims:ime , jms:jme ),                                          & 
+                          INTENT(IN)         :: t2, q2, u10, v10 
+   REAL, DIMENSION( ims:ime , jms:jme ),                                          &
+                          INTENT(OUT)        :: t2clmin, t2clmax, tt2clmin,       &
+                          tt2clmax, t2clmean, t2clstd,                            & 
+                          q2clmin, q2clmax, tq2clmin, tq2clmax, q2clmean, q2clstd,&
+                          u10clmax, v10clmax, spduv10clmax, tspduv10clmax,        &
+                          u10clmean, v10clmean, spduv10clmean,                    &
+                          u10clstd, v10clstd, spduv10clstd, skintempclmin,        &
+                          skintempclmax, tskintempclmin, tskintempclmax,          &
+                          skintempclmean, skintempclstd
+   REAL, DIMENSION( ims:ime , jms:jme ),                                          &
+                          INTENT(OUT)        :: raincclmax, rainncclmax,          &
+                          traincclmax, trainncclmax, raincclmean, rainncclmean,   & 
+                          raincclstd, rainncclstd 
+   REAL, PARAMETER                           :: minimum0= 1000000.,               &
+                          maximum0= -1000000. 
+   REAL                                      :: value
+   INTEGER, INTENT(IN)                       :: clwrfH
+   CHARACTER (LEN=1024)                      :: message
+   INTEGER, SAVE                             :: nsteps
+   LOGICAL                                   :: is_restart
+
+!-----------------------------------------------------------------
+! Compute minutes from reference times clwrfH
+
+! Initialize [var] values
+! SET START AND END POINTS FOR TILES
+!  !$OMP PARALLEL DO   &
+!  !$OMP PRIVATE ( ij )
+
+!  IF ( MOD(NINT(XTIME), clwrfH) == 0 ) THEN
+  IF (( MOD(NINT(curr_secs2/dt),NINT(clwrfH*60./dt)) == 0) .AND. (.NOT.is_restart)) THEN
+    DO ij = 1 , num_tiles
+      IF  ( wrf_dm_on_monitor() ) THEN
+        WRITE(message, *)'CLWRFdiag - T2; tile: ',ij,' T2clmin:',           & 
+          t2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' T2clmax:',               &
+          t2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TT2clmin:',              &
+          tt2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TT2clmax:',              &
+          tt2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' T2clmean:',              &
+          t2clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' T2clstd:',               &
+          t2clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2)
+        CALL wrf_debug(75, message)
+        WRITE(message, *)'CLWRFdiag - Q2; tile: ',ij,' Q2clmin:',           &
+          q2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' Q2clmax:',               &
+          q2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TQ2clmin:',              &
+          tq2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TQ2clmax:',              &
+          tq2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' Q2clmean:',              &
+          q2clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' Q2clstd:',               &
+          q2clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2)
+        CALL wrf_debug(75, message)
+        WRITE(message, *)'CLWRFdiag - WINDSPEED; tile: ',ij,' U10clmax:',   &
+          u10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' V10clmax:',              &
+          v10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SPDUV10clmax:',          &
+          spduv10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,               &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TSPDUV10clmax:',         &
+          tspduv10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,              &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' U10clmean:',             &
+          u10clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,                  &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' V10clmean:',             &
+          v10clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,                  &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SPDUV10clmean:',         &
+          spduv10clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,              &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' U10clstd:',              &
+          u10clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' V10clstd:',              &
+          v10clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SPDUV10clstd:',          &
+          spduv10clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,               &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2)
+        CALL wrf_debug(75, message)
+        WRITE(message, *)'CLWRFdiag - RAIN; tile: ',ij,' RAINCclmax:',      &
+          raincclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                 &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINNCclmax:',           &
+          rainncclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TRAINCclmax:',           &
+          traincclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TRAINNCclmax:',          &
+          trainncclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,               &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINCclmean:',           &
+          raincclmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,                &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINNCclmean:',          &
+          rainncclmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,               &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINCclstd:',            &
+          raincclstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                 &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINNCclstd:',           &
+          rainncclstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2)
+        CALL wrf_debug(75, message)
+        WRITE(message,*)'CLWRFdiag - SKINTEMP; tile: ',ij,' SKINTEMPclmin:',&
+          skintempclmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,              &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SKINTEMPclmax:',         &
+          skintempclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,              &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TSKINTEMPclmin:',        &
+          tskintempclmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,             &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TSKINTEMPclmax:',        &
+          tskintempclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,             &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SKINTEMPclmean:',        &
+          skintempclmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,             &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SKINTEMPclstd:',         &
+          skintempclstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,              &
+          j_start(ij)+(j_end(ij)-j_start(ij))/2)
+        CALL wrf_debug(75, message)
+      ENDIF
+      DO j = j_start(ij), j_end(ij)
+        DO i = i_start(ij), i_end(ij)
+          t2clmin(i,j)=t2(i,j)
+          t2clmax(i,j)=t2(i,j)
+          t2clmean(i,j)=t2(i,j)
+          t2clstd(i,j)=t2(i,j)*t2(i,j)
+          q2clmin(i,j)=q2(i,j)
+          q2clmax(i,j)=q2(i,j)
+          q2clmean(i,j)=q2(i,j)
+          q2clstd(i,j)=q2(i,j)*q2(i,j)
+          spduv10clmax(i,j)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
+          u10clmean(i,j)=u10(i,j)
+          v10clmean(i,j)=v10(i,j)
+          spduv10clmean(i,j)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
+          u10clstd(i,j)=u10(i,j)*u10(i,j)
+          v10clstd(i,j)=v10(i,j)*v10(i,j)
+          spduv10clstd(i,j)=u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)
+          raincclmax(i,j)=raincv(i,j)/dt
+          rainncclmax(i,j)=rainncv(i,j)/dt
+          raincclmean(i,j)=raincv(i,j)/dt
+          rainncclmean(i,j)=rainncv(i,j)/dt
+          raincclstd(i,j)=(raincv(i,j)/dt)*(raincv(i,j)/dt)
+          rainncclstd(i,j)=(rainncv(i,j)/dt)*(rainncv(i,j)/dt)
+          skintempclmin(i,j)=skintemp(i,j)
+          skintempclmax(i,j)=skintemp(i,j)
+          skintempclmean(i,j)=skintemp(i,j)
+          skintempclstd(i,j)=skintemp(i,j)*skintemp(i,j)
+          nsteps=0
+        ENDDO
+      ENDDO
+  ENDDO
+!    nsteps=clwrfH*60./dt
+  ELSE
+    xtimep = xtime + dt/60.   ! value at end of timestep for time info
+    nsteps=nsteps+1
+!   nsteps=clwrfH*60./dt
+!      DO j = j_start(ij), j_end(ij)
+!        DO i = i_start(ij), i_end(ij)
+!     DO j = jps, jpe
+!       DO i = ips, ipe
+! Temperature
+          CALL varstatistics(t2,xtimep,ime-ims+1,jme-jms+1,t2clmin,t2clmax,   &
+            tt2clmin,tt2clmax,t2clmean,t2clstd)
+! Water vapor mixing ratio
+          CALL varstatistics(q2,xtimep,ime-ims+1,jme-jms+1,q2clmin,q2clmax,   &
+            tq2clmin,tq2clmax,q2clmean,q2clstd)
+! Wind speed
+          CALL varstatisticsWIND(u10,v10,xtimep,ime-ims+1,jme-jms+1,u10clmax, &
+            v10clmax,spduv10clmax,tspduv10clmax,u10clmean,v10clmean,         &
+            spduv10clmean,u10clstd,v10clstd,spduv10clstd)
+! Precipitation flux
+          CALL varstatisticsMAX(raincv/dt,xtimep,ime-ims+1,jme-jms+1,         &
+            raincclmax,traincclmax,raincclmean,raincclstd) 
+          CALL varstatisticsMAX(rainncv/dt,xtimep,ime-ims+1,jme-jms+1,        &
+            rainncclmax,trainncclmax,rainncclmean,rainncclstd)
+! Skin Temperature 
+          CALL varstatistics(skintemp,xtimep,ime-ims+1,jme-jms+1,skintempclmin,&
+            skintempclmax, tskintempclmin,tskintempclmax,skintempclmean,      &
+            skintempclstd)
+
+!          IF (MOD(NINT(XTIME),clwrfH) == 0) THEN
+!          IF (MOD(NINT(XTIME+dt/60.),clwrfH) == 0) THEN
+           IF (MOD(NINT((curr_secs2+dt)/dt),NINT(clwrfH*60./dt)) == 0) THEN
+             IF  ( wrf_dm_on_monitor() ) PRINT *,'nsteps=',nsteps,' xtime:',  &
+               xtime,' clwrfH:',clwrfH 
+               t2clmean=t2clmean/nsteps
+               t2clstd=SQRT(t2clstd/nsteps-t2clmean**2.)
+               q2clmean=q2clmean/nsteps
+               q2clstd=SQRT(q2clstd/nsteps-q2clmean**2.)
+               u10clmean=u10clmean/nsteps
+               v10clmean=v10clmean/nsteps
+               spduv10clmean=spduv10clmean/nsteps
+               u10clstd=SQRT(u10clstd/nsteps-u10clmean**2.)
+               v10clstd=SQRT(v10clstd/nsteps-v10clmean**2.)
+               spduv10clstd=SQRT(spduv10clstd/nsteps-                        &
+                 spduv10clmean**2)
+               raincclmean=raincclmean/nsteps
+               rainncclmean=rainncclmean/nsteps
+               raincclstd=SQRT(raincclstd/nsteps-raincclmean**2.)
+               rainncclstd=SQRT(rainncclstd/nsteps-rainncclmean**2.)
+               skintempclmean=skintempclmean/nsteps
+              skintempclstd=SQRT(skintempclstd/nsteps-skintempclmean**2.)
+            END IF
+!        ENDDO
+!      ENDDO
+  ENDIF
+!  !$OMP END PARALLEL DO
+
+   END SUBROUTINE clwrf_output_calc
+
+! UC.CLWRF Nov.09
+SUBROUTINE varstatisticsWIND(varu, varv, tt, dx, dy, varumax, varvmax,       &
+  varuvmax, tvaruvmax, varumean, varvmean, varuvmean, varustd, varvstd,     & 
+  varuvstd) 
+! Subroutine to compute variable statistics for a wind somponents 
+
+IMPLICIT NONE
+
+INTEGER                                                        :: i, j
+INTEGER, INTENT(IN)                                            :: dx, dy
+REAL, DIMENSION(dx,dy), INTENT(IN)                             :: varu, varv
+REAL, INTENT(IN)                                               :: tt
+REAL, DIMENSION(dx,dy), INTENT(INOUT)                          :: varumax,   &
+  varvmax, varuvmax, tvaruvmax, varumean, varvmean, varuvmean, varustd,      & 
+  varvstd, varuvstd
+REAL                                                           :: varuv
+
+DO i=1,dx
+  DO j=1,dy
+    varuv=sqrt(varu(i,j)*varu(i,j)+varv(i,j)*varv(i,j))
+      IF (varuv > varuvmax(i,j)) THEN
+        varumax(i,j)=varu(i,j)
+        varvmax(i,j)=varv(i,j)
+        varuvmax(i,j)=varuv
+        tvaruvmax(i,j)=tt
+      END IF
+    varuvmean(i,j)=varuvmean(i,j)+varuv
+    varuvstd(i,j)=varuvstd(i,j)+varuv**2
+  END DO
+END DO
+varumean=varumean+varu
+varvmean=varvmean+varv
+varustd=varustd+varu**2
+varvstd=varvstd+varv**2
+
+END SUBROUTINE varstatisticsWIND
+
+SUBROUTINE varstatisticsMAX(var, tt, dx, dy, varmax, tvarmax, varmean,       &
+   varstd)
+! Subroutine to compute variable statistics for a max only variable values
+
+IMPLICIT NONE
+
+INTEGER                                                        :: i,j
+INTEGER, INTENT(IN)                                            :: dx, dy
+REAL, DIMENSION(dx,dy), INTENT(IN)                             :: var
+REAL, INTENT(IN)                                               :: tt
+REAL, DIMENSION(dx,dy), INTENT(INOUT)                          :: varmax,    &
+  tvarmax, varmean, varstd
+
+DO i=1,dx
+  DO j=1,dy
+    IF (var(i,j) > varmax(i,j)) THEN
+      varmax(i,j)=var(i,j)
+      tvarmax(i,j)=tt
+    END IF
+  END DO
+END DO
+varmean=varmean+var
+varstd=varstd+var**2
+
+END SUBROUTINE varstatisticsMAX 
+
+SUBROUTINE varstatistics(var, tt, dx, dy, varmin, varmax, tvarmin, tvarmax,  & 
+  varmean, varstd) 
+! Subroutine to compute variable statistics
+
+IMPLICIT NONE
+
+INTEGER                                                        :: i,j
+INTEGER, INTENT(IN)                                            :: dx, dy
+REAL, DIMENSION(dx,dy), INTENT(IN)                             :: var
+REAL, INTENT(IN)                                               :: tt
+REAL, DIMENSION(dx,dy), INTENT(INOUT)                          :: varmin,    &
+  varmax, tvarmin, tvarmax, varmean, varstd
+
+DO i=1,dx
+  DO j=1,dy
+    IF (var(i,j) < varmin(i,j)) THEN
+      varmin(i,j)=var(i,j)
+      tvarmin(i,j)=tt
+    END IF
+    IF (var(i,j) > varmax(i,j)) THEN
+      varmax(i,j)=var(i,j)
+      tvarmax(i,j)=tt
+    END IF
+  END DO
+END DO
+varmean=varmean+var
+varstd=varstd+var**2
+
+END SUBROUTINE varstatistics
+
+END MODULE module_diag_cl
+#endif
diff --git a/wrfv2_fire/phys/module_diag_misc.F b/wrfv2_fire/phys/module_diag_misc.F
new file mode 100644
index 00000000..eca4228a
--- /dev/null
+++ b/wrfv2_fire/phys/module_diag_misc.F
@@ -0,0 +1,726 @@
+#if ( NMM_CORE == 1)
+MODULE module_diag_misc
+CONTAINS
+   SUBROUTINE diag_misc_stub
+   END SUBROUTINE diag_misc_stub
+END MODULE module_diag_misc
+#else
+!WRF:MEDIATION_LAYER:PHYSICS
+!
+
+MODULE module_diag_misc
+CONTAINS
+   SUBROUTINE diagnostic_output_calc(                                 &
+                      ids,ide, jds,jde, kds,kde,                      &
+                      ims,ime, jms,jme, kms,kme,                      &
+                      ips,ipe, jps,jpe, kps,kpe,                      & ! patch  dims
+                      i_start,i_end,j_start,j_end,kts,kte,num_tiles   &
+                     ,dpsdt,dmudt                                     &
+                     ,p8w,pk1m,mu_2,mu_2m                             &
+                     ,u,v                                             &
+                     ,raincv,rainncv,rainc,rainnc                     &
+                     ,i_rainc,i_rainnc                                &
+                     ,hfx,sfcevp,lh                                   &
+                     ,ACSWUPT,ACSWUPTC,ACSWDNT,ACSWDNTC               & ! Optional
+                     ,ACSWUPB,ACSWUPBC,ACSWDNB,ACSWDNBC               & ! Optional
+                     ,ACLWUPT,ACLWUPTC,ACLWDNT,ACLWDNTC               & ! Optional
+                     ,ACLWUPB,ACLWUPBC,ACLWDNB,ACLWDNBC               & ! Optional
+                     ,I_ACSWUPT,I_ACSWUPTC,I_ACSWDNT,I_ACSWDNTC       & ! Optional
+                     ,I_ACSWUPB,I_ACSWUPBC,I_ACSWDNB,I_ACSWDNBC       & ! Optional
+                     ,I_ACLWUPT,I_ACLWUPTC,I_ACLWDNT,I_ACLWDNTC       & ! Optional
+                     ,I_ACLWUPB,I_ACLWUPBC,I_ACLWDNB,I_ACLWDNBC       & ! Optional
+                     ,dt,xtime,sbw,t2                                 &
+                     ,diag_print                                      &
+                     ,bucket_mm, bucket_J                             &
+                     ,prec_acc_c, prec_acc_nc, snow_acc_nc            &
+                     ,snowncv, prec_acc_dt, curr_secs2                &
+                     ,nwp_diagnostics, diagflag                       &
+                     ,history_interval                                &
+                     ,itimestep                                       &
+                     ,u10,v10,w                                       &
+                     ,wspd10max                                       &
+                     ,up_heli_max                                     &
+                     ,w_up_max,w_dn_max                               &
+                     ,znw,w_colmean                                   &
+                     ,numcolpts,w_mean                                &
+                     ,grpl_max,grpl_colint,refd_max,refl_10cm         &
+                     ,qg_curr                                         &
+                     ,rho,ph,phb,g                                    &
+                                                                      )
+!----------------------------------------------------------------------
+
+  USE module_dm, ONLY: wrf_dm_sum_real, wrf_dm_maxval
+
+   IMPLICIT NONE
+!======================================================================
+! Definitions
+!-----------
+!-- DIAG_PRINT    print control: 0 - no diagnostics; 1 - dmudt only; 2 - all
+!-- DT            time step (second)
+!-- XTIME         forecast time
+!-- SBW           specified boundary width - used later
+!
+!-- P8W           3D pressure array at full eta levels
+!-- MU            dry column hydrostatic pressure
+!-- RAINC         cumulus scheme precipitation since hour 0
+!-- RAINCV        cumulus scheme precipitation in one time step (mm)
+!-- RAINNC        explicit scheme precipitation since hour 0
+!-- RAINNCV       explicit scheme precipitation in one time step (mm)
+!-- SNOWNCV       explicit scheme snow in one time step (mm)
+!-- HFX           surface sensible heat flux
+!-- LH            surface latent heat flux
+!-- SFCEVP        total surface evaporation
+!-- U             u component of wind - to be used later to compute k.e.
+!-- V             v component of wind - to be used later to compute k.e.
+!-- PREC_ACC_C    accumulated convective precip over accumulation time prec_acc_dt
+!-- PREC_ACC_NC   accumulated explicit precip over accumulation time prec_acc_dt
+!-- SNOW_ACC_NC   accumulated explicit snow precip over accumulation time prec_acc_dt
+!-- PREC_ACC_DT   precip accumulation time, default is 60 min
+!-- CURR_SECS2    Time (s) since the beginning of the restart
+!-- NWP_DIAGNOSTICS  = 1, compute hourly maximum fields
+!-- DIAGFLAG      logical flag to indicate if this is a history output time
+!-- U10, V10      10 m wind components
+!-- WSPD10MAX     10 m max wind speed
+!-- UP_HELI_MAX   max updraft helicity
+!-- W_UP_MAX      max updraft vertical velocity
+!-- W_DN_MAX      max downdraft vertical velocity
+!-- W_COLMEAN     column mean vertical velocity
+!-- NUMCOLPTS     no of column points
+!-- GRPL_MAX      max column-integrated graupel
+!-- GRPL_COLINT   column-integrated graupel
+!-- REF_MAX       max derived radar reflectivity
+!-- REFL_10CM     model computed 3D reflectivity
+!
+!-- ids           start index for i in domain
+!-- ide           end index for i in domain
+!-- jds           start index for j in domain
+!-- jde           end index for j in domain
+!-- kds           start index for k in domain
+!-- kde           end index for k in domain
+!-- ims           start index for i in memory
+!-- ime           end index for i in memory
+!-- jms           start index for j in memory
+!-- jme           end index for j in memory
+!-- ips           start index for i in patch
+!-- ipe           end index for i in patch
+!-- jps           start index for j in patch
+!-- jpe           end index for j in patch
+!-- kms           start index for k in memory
+!-- kme           end index for k in memory
+!-- i_start       start indices for i in tile
+!-- i_end         end indices for i in tile
+!-- j_start       start indices for j in tile
+!-- j_end         end indices for j in tile
+!-- kts           start index for k in tile
+!-- kte           end index for k in tile
+!-- num_tiles     number of tiles
+!
+!======================================================================
+
+   INTEGER,      INTENT(IN   )    ::                             &
+                                      ids,ide, jds,jde, kds,kde, &
+                                      ims,ime, jms,jme, kms,kme, &
+                                      ips,ipe, jps,jpe, kps,kpe, &
+                                                        kts,kte, &
+                                                      num_tiles
+
+   INTEGER, DIMENSION(num_tiles), INTENT(IN) ::                  &
+     &           i_start,i_end,j_start,j_end
+
+   INTEGER,      INTENT(IN   )    ::   diag_print
+   REAL,      INTENT(IN   )    ::   bucket_mm, bucket_J
+   INTEGER,   INTENT(IN   )    ::   nwp_diagnostics
+   LOGICAL,   INTENT(IN   )    ::   diagflag
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
+         INTENT(IN ) ::                                       u  &
+                                                    ,         v  &
+                                                    ,       p8w
+
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) ::           &
+                                                           MU_2  &
+                                                    ,   RAINNCV  &
+                                                    ,    RAINCV  &
+                                                    ,   SNOWNCV  &
+                                                    ,       HFX  &
+                                                    ,        LH  &
+                                                    ,    SFCEVP  &  
+                                                    ,        T2     
+
+   REAL, DIMENSION( ims:ime , jms:jme ),                         &
+          INTENT(INOUT) ::                                DPSDT  &
+                                                    ,     DMUDT  &
+                                                    ,    RAINNC  &
+                                                    ,     RAINC  &
+                                                    ,     MU_2M  &
+                                                    ,      PK1M
+ 
+   REAL,  INTENT(IN   ) :: DT, XTIME
+   INTEGER,  INTENT(IN   ) :: SBW
+   INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) ::     &
+                                                       I_RAINC,  &
+                                                       I_RAINNC
+   REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
+                      ACSWUPT,ACSWUPTC,ACSWDNT,ACSWDNTC,          &
+                      ACSWUPB,ACSWUPBC,ACSWDNB,ACSWDNBC,          &
+                      ACLWUPT,ACLWUPTC,ACLWDNT,ACLWDNTC,          &
+                      ACLWUPB,ACLWUPBC,ACLWDNB,ACLWDNBC
+   INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
+                      I_ACSWUPT,I_ACSWUPTC,I_ACSWDNT,I_ACSWDNTC,  &
+                      I_ACSWUPB,I_ACSWUPBC,I_ACSWDNB,I_ACSWDNBC,  &
+                      I_ACLWUPT,I_ACLWUPTC,I_ACLWDNT,I_ACLWDNTC,  &
+                      I_ACLWUPB,I_ACLWUPBC,I_ACLWDNB,I_ACLWDNBC
+
+   REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
+                      PREC_ACC_C, PREC_ACC_NC, SNOW_ACC_NC
+
+   REAL, OPTIONAL, INTENT(IN)::  PREC_ACC_DT, CURR_SECS2
+
+   INTEGER :: i,j,k,its,ite,jts,jte,ij
+   INTEGER :: idp,jdp,irc,jrc,irnc,jrnc,isnh,jsnh
+   INTEGER :: prfreq
+
+   REAL              :: no_points
+   REAL              :: dpsdt_sum, dmudt_sum, dardt_sum, drcdt_sum, drndt_sum
+   REAL              :: hfx_sum, lh_sum, sfcevp_sum, rainc_sum, rainnc_sum, raint_sum
+   REAL              :: dmumax, raincmax, rainncmax, snowhmax
+   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
+   CHARACTER*256     :: outstring
+   CHARACTER*6       :: grid_str
+
+   INTEGER, INTENT(IN) ::                                        &
+                                     history_interval,itimestep
+
+   REAL, DIMENSION( kms:kme ), INTENT(IN) ::                     &
+                                                            znw
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) ::   &
+                                                              w  &
+                                                       ,qg_curr  &
+                                                           ,rho  &
+                                                     ,refl_10cm  &
+                                                        ,ph,phb
+
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) ::            &
+                                                            u10  &
+                                                           ,v10
+
+   REAL, INTENT(IN) :: g
+
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) ::        &
+                                                      wspd10max  &
+                                                   ,up_heli_max  &
+                                             ,w_up_max,w_dn_max  &
+                                    ,w_colmean,numcolpts,w_mean  &
+                                          ,grpl_max,grpl_colint  &
+                                                      ,refd_max
+
+   INTEGER :: idump
+
+   REAL :: wind_vel
+   REAL :: depth
+
+!-----------------------------------------------------------------
+! Handle accumulations with buckets to prevent round-off truncation in long runs
+! This is done every 360 minutes assuming time step fits exactly into 360 minutes
+   IF(bucket_mm .gt. 0. .AND. MOD(NINT(XTIME),360) .EQ. 0)THEN
+! SET START AND END POINTS FOR TILES
+!  !$OMP PARALLEL DO   &
+!  !$OMP PRIVATE ( ij )
+
+   DO ij = 1 , num_tiles
+
+      IF (xtime .eq. 0.0)THEN
+        DO j=j_start(ij),j_end(ij)
+        DO i=i_start(ij),i_end(ij)
+          i_rainnc(i,j) = 0
+          i_rainc(i,j) = 0
+        ENDDO      
+        ENDDO
+      ENDIF
+      DO j=j_start(ij),j_end(ij)
+      DO i=i_start(ij),i_end(ij)
+        IF(rainnc(i,j) .gt. bucket_mm)THEN
+          rainnc(i,j) = rainnc(i,j) - bucket_mm
+          i_rainnc(i,j) =  i_rainnc(i,j) + 1
+        ENDIF
+        IF(rainc(i,j) .gt. bucket_mm)THEN
+          rainc(i,j) = rainc(i,j) - bucket_mm
+          i_rainc(i,j) =  i_rainc(i,j) + 1
+        ENDIF
+      ENDDO      
+      ENDDO
+
+      IF (xtime .eq. 0.0 .and. bucket_J .gt. 0.0 .and. PRESENT(ACSWUPT))THEN
+        DO j=j_start(ij),j_end(ij)
+        DO i=i_start(ij),i_end(ij)
+          i_acswupt(i,j) = 0
+          i_acswuptc(i,j) = 0
+          i_acswdnt(i,j) = 0
+          i_acswdntc(i,j) = 0
+          i_acswupb(i,j) = 0
+          i_acswupbc(i,j) = 0
+          i_acswdnb(i,j) = 0
+          i_acswdnbc(i,j) = 0
+        ENDDO      
+        ENDDO
+      ENDIF
+      IF (xtime .eq. 0.0  .and. bucket_J .gt. 0.0 .and. PRESENT(ACLWUPT))THEN
+        DO j=j_start(ij),j_end(ij)
+        DO i=i_start(ij),i_end(ij)
+          i_aclwupt(i,j) = 0
+          i_aclwuptc(i,j) = 0
+          i_aclwdnt(i,j) = 0
+          i_aclwdntc(i,j) = 0
+          i_aclwupb(i,j) = 0
+          i_aclwupbc(i,j) = 0
+          i_aclwdnb(i,j) = 0
+          i_aclwdnbc(i,j) = 0
+        ENDDO      
+        ENDDO
+      ENDIF
+      IF (PRESENT(ACSWUPT) .and. bucket_J .gt. 0.0)THEN
+      DO j=j_start(ij),j_end(ij)
+      DO i=i_start(ij),i_end(ij)
+        IF(acswupt(i,j) .gt. bucket_J)THEN
+          acswupt(i,j) = acswupt(i,j) - bucket_J
+          i_acswupt(i,j) =  i_acswupt(i,j) + 1
+        ENDIF
+        IF(acswuptc(i,j) .gt. bucket_J)THEN
+          acswuptc(i,j) = acswuptc(i,j) - bucket_J
+          i_acswuptc(i,j) =  i_acswuptc(i,j) + 1
+        ENDIF
+        IF(acswdnt(i,j) .gt. bucket_J)THEN
+          acswdnt(i,j) = acswdnt(i,j) - bucket_J
+          i_acswdnt(i,j) =  i_acswdnt(i,j) + 1
+        ENDIF
+        IF(acswdntc(i,j) .gt. bucket_J)THEN
+          acswdntc(i,j) = acswdntc(i,j) - bucket_J
+          i_acswdntc(i,j) =  i_acswdntc(i,j) + 1
+        ENDIF
+        IF(acswupb(i,j) .gt. bucket_J)THEN
+          acswupb(i,j) = acswupb(i,j) - bucket_J
+          i_acswupb(i,j) =  i_acswupb(i,j) + 1
+        ENDIF
+        IF(acswupbc(i,j) .gt. bucket_J)THEN
+          acswupbc(i,j) = acswupbc(i,j) - bucket_J
+          i_acswupbc(i,j) =  i_acswupbc(i,j) + 1
+        ENDIF
+        IF(acswdnb(i,j) .gt. bucket_J)THEN
+          acswdnb(i,j) = acswdnb(i,j) - bucket_J
+          i_acswdnb(i,j) =  i_acswdnb(i,j) + 1
+        ENDIF
+        IF(acswdnbc(i,j) .gt. bucket_J)THEN
+          acswdnbc(i,j) = acswdnbc(i,j) - bucket_J
+          i_acswdnbc(i,j) =  i_acswdnbc(i,j) + 1
+        ENDIF
+      ENDDO      
+      ENDDO
+      ENDIF
+      IF (PRESENT(ACLWUPT) .and. bucket_J .gt. 0.0)THEN
+      DO j=j_start(ij),j_end(ij)
+      DO i=i_start(ij),i_end(ij)
+        IF(aclwupt(i,j) .gt. bucket_J)THEN
+          aclwupt(i,j) = aclwupt(i,j) - bucket_J
+          i_aclwupt(i,j) =  i_aclwupt(i,j) + 1
+        ENDIF
+        IF(aclwuptc(i,j) .gt. bucket_J)THEN
+          aclwuptc(i,j) = aclwuptc(i,j) - bucket_J
+          i_aclwuptc(i,j) =  i_aclwuptc(i,j) + 1
+        ENDIF
+        IF(aclwdnt(i,j) .gt. bucket_J)THEN
+          aclwdnt(i,j) = aclwdnt(i,j) - bucket_J
+          i_aclwdnt(i,j) =  i_aclwdnt(i,j) + 1
+        ENDIF
+        IF(aclwdntc(i,j) .gt. bucket_J)THEN
+          aclwdntc(i,j) = aclwdntc(i,j) - bucket_J
+          i_aclwdntc(i,j) =  i_aclwdntc(i,j) + 1
+        ENDIF
+        IF(aclwupb(i,j) .gt. bucket_J)THEN
+          aclwupb(i,j) = aclwupb(i,j) - bucket_J
+          i_aclwupb(i,j) =  i_aclwupb(i,j) + 1
+        ENDIF
+        IF(aclwupbc(i,j) .gt. bucket_J)THEN
+          aclwupbc(i,j) = aclwupbc(i,j) - bucket_J
+          i_aclwupbc(i,j) =  i_aclwupbc(i,j) + 1
+        ENDIF
+        IF(aclwdnb(i,j) .gt. bucket_J)THEN
+          aclwdnb(i,j) = aclwdnb(i,j) - bucket_J
+          i_aclwdnb(i,j) =  i_aclwdnb(i,j) + 1
+        ENDIF
+        IF(aclwdnbc(i,j) .gt. bucket_J)THEN
+          aclwdnbc(i,j) = aclwdnbc(i,j) - bucket_J
+          i_aclwdnbc(i,j) =  i_aclwdnbc(i,j) + 1
+        ENDIF
+      ENDDO      
+      ENDDO
+      ENDIF
+   ENDDO
+!  !$OMP END PARALLEL DO
+   ENDIF
+
+! Compute precipitation accumulation in a given time window: prec_acc_dt
+   IF (prec_acc_dt .gt. 0.) THEN
+
+!  !$OMP PARALLEL DO   &
+!  !$OMP PRIVATE ( ij )
+
+   DO ij = 1 , num_tiles
+
+      DO j=j_start(ij),j_end(ij)
+      DO i=i_start(ij),i_end(ij)
+         IF (mod(curr_secs2, 60.* prec_acc_dt) == 0.) THEN
+            prec_acc_c(i,j)  = 0.
+            prec_acc_nc(i,j) = 0.
+            snow_acc_nc(i,j)  = 0.
+         ENDIF
+         prec_acc_c(i,j)  = prec_acc_c(i,j)  +  RAINCV(i,j)
+         prec_acc_nc(i,j) = prec_acc_nc(i,j) + RAINNCV(i,j)
+         prec_acc_c(i,j)  = MAX (prec_acc_c(i,j), 0.0)
+         prec_acc_nc(i,j) = MAX (prec_acc_nc(i,j), 0.0)
+         snow_acc_nc(i,j)   = snow_acc_nc(i,j) + SNOWNCV(I,J)
+! add convective precip to snow bucket if t2 < 273.15
+         IF ( t2(i,j) .lt. 273.15 ) THEN
+         snow_acc_nc(i,j)   = snow_acc_nc(i,j) +  RAINCV(i,j)
+         snow_acc_nc(i,j)   = MAX (snow_acc_nc(i,j), 0.0)
+         ENDIF
+      ENDDO     
+      ENDDO     
+
+   ENDDO     
+
+!  !$OMP END PARALLEL DO
+   ENDIF
+
+! NSSL
+
+   IF ( nwp_diagnostics .EQ. 1 ) THEN
+
+     idump = (history_interval * 60.) / dt
+
+!   print *,' history_interval = ', history_interval
+!   print *,' itimestep        = ', itimestep
+!   print *,' idump            = ', idump
+!   print *,' xtime            = ', xtime
+
+! IF ( MOD(itimestep, idump) .eq. 0 ) THEN
+!    WRITE(outstring,*) 'Computing PH0 for this domain with curr_secs2 = ', curr_secs2
+!    CALL wrf_message ( TRIM(outstring) )
+
+   IF ( MOD((itimestep - 1), idump) .eq. 0 ) THEN
+     WRITE(outstring,*) 'NSSL Diagnostics: Resetting max arrays for domain with dt = ', dt
+     CALL wrf_debug ( 10,TRIM(outstring) )
+
+!  !$OMP PARALLEL DO   &
+!  !$OMP PRIVATE ( ij )
+     DO ij = 1 , num_tiles
+       DO j=j_start(ij),j_end(ij)
+       DO i=i_start(ij),i_end(ij)
+         wspd10max(i,j)   = 0.
+         up_heli_max(i,j) = 0.
+         w_up_max(i,j)    = 0.
+         w_dn_max(i,j)    = 0.
+         w_mean(i,j)      = 0.
+         grpl_max(i,j)    = 0.
+         refd_max(i,j)    = 0.
+       ENDDO
+       ENDDO
+     ENDDO
+!  !$OMP END PARALLEL DO
+   ENDIF
+
+!  !$OMP PARALLEL DO   &
+!  !$OMP PRIVATE ( ij )
+   DO ij = 1 , num_tiles
+     DO j=j_start(ij),j_end(ij)
+     DO i=i_start(ij),i_end(ij)
+
+! Zero some accounting arrays that will be used below
+
+       w_colmean(i,j)   = 0.
+       numcolpts(i,j)   = 0.
+       grpl_colint(i,j) = 0.
+     ENDDO
+     ENDDO
+   ENDDO
+!  !$OMP END PARALLEL DO
+
+!  !$OMP PARALLEL DO   &
+!  !$OMP PRIVATE ( ij )
+   DO ij = 1 , num_tiles
+     DO j=j_start(ij),j_end(ij)
+     DO k=kms,kme
+     DO i=i_start(ij),i_end(ij)
+
+! Find vertical velocity max (up and down) below 400 mb
+
+       IF ( p8w(i,k,j) .GT. 40000. .AND. w(i,k,j) .GT. w_up_max(i,j) ) THEN
+         w_up_max(i,j) = w(i,k,j)
+       ENDIF
+
+       IF ( p8w(i,k,j) .GT. 40000. .AND. w(i,k,j) .LT. w_dn_max(i,j) ) THEN
+         w_dn_max(i,j) = w(i,k,j)
+       ENDIF
+
+! For the column mean vertical velocity calculation, first
+! total the vertical velocity between sigma levels 0.5 and 0.8
+
+       IF ( znw(k) .GE. 0.5 .AND. znw(k) .LE. 0.8 ) THEN
+         w_colmean(i,j) = w_colmean(i,j) + w(i,k,j)
+         numcolpts(i,j) = numcolpts(i,j) + 1
+       ENDIF
+     ENDDO
+     ENDDO
+     ENDDO
+   ENDDO
+!  !$OMP END PARALLEL DO
+
+!  !$OMP PARALLEL DO   &
+!  !$OMP PRIVATE ( ij )
+   DO ij = 1 , num_tiles
+     DO j=j_start(ij),j_end(ij)
+     DO k=kms,kme-1
+     DO i=i_start(ij),i_end(ij)
+
+! Calculate the column integrated graupel
+
+       depth = ( ( ph(i,k+1,j) + phb(i,k+1,j) ) / g ) - &
+               ( ( ph(i,k  ,j) + phb(i,k  ,j) ) / g )
+       grpl_colint(i,j) = grpl_colint(i,j) + qg_curr(i,k,j) * depth * rho(i,k,j)
+     ENDDO
+     ENDDO
+     ENDDO
+   ENDDO
+!  !$OMP END PARALLEL DO
+
+!  !$OMP PARALLEL DO   &
+!  !$OMP PRIVATE ( ij )
+   DO ij = 1 , num_tiles
+     DO j=j_start(ij),j_end(ij)
+     DO i=i_start(ij),i_end(ij)
+
+! Calculate the max 10 m wind speed between output times
+
+       wind_vel = sqrt ( u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j) )
+       IF ( wind_vel .GT. wspd10max(i,j) ) THEN
+         wspd10max(i,j) = wind_vel
+       ENDIF
+
+! Calculate the column mean vertical velocity between output times
+
+       w_mean(i,j) = w_mean(i,j) + w_colmean(i,j) / numcolpts(i,j)
+
+       IF ( MOD(itimestep, idump) .eq. 0 ) THEN
+         w_mean(i,j) = w_mean(i,j) / idump
+       ENDIF
+
+! Calculate the max column integrated graupel between output times
+
+       IF ( grpl_colint(i,j) .gt. grpl_max(i,j) ) THEN
+          grpl_max(i,j) = grpl_colint(i,j)
+       ENDIF
+
+! Calculate the max radar reflectivity between output times
+
+       IF ( refl_10cm(i,kms,j) .GT. refd_max(i,j) ) THEN
+         refd_max(i,j) = refl_10cm(i,kms,j)
+       ENDIF
+     ENDDO
+     ENDDO
+   ENDDO
+!  !$OMP END PARALLEL DO
+   ENDIF
+! NSSL
+
+   if (diag_print .eq. 0 ) return
+
+   IF ( xtime .ne. 0. ) THEN
+
+    if(diag_print.eq.1) then
+       prfreq = dt
+!      prfreq = max(2,int(dt/60.))   ! in min
+    else
+       prfreq=10                   ! in min
+    endif
+   
+    IF (MOD(nint(dt),prfreq) == 0) THEN
+
+! COMPUTE THE NUMBER OF MASS GRID POINTS
+   no_points = float((ide-ids)*(jde-jds))
+
+! SET START AND END POINTS FOR TILES
+!  !$OMP PARALLEL DO   &
+!  !$OMP PRIVATE ( ij )
+
+   dmumax = 0.
+   DO ij = 1 , num_tiles
+
+!     print *, i_start(ij),i_end(ij),j_start(ij),j_end(ij)
+      DO j=j_start(ij),j_end(ij)
+      DO i=i_start(ij),i_end(ij)
+         dpsdt(i,j)=(p8w(i,kms,j)-pk1m(i,j))/dt
+         dmudt(i,j)=(mu_2(i,j)-mu_2m(i,j))/dt
+         if(abs(dmudt(i,j)*dt).gt.dmumax)then
+           dmumax=abs(dmudt(i,j)*dt)
+           idp=i
+           jdp=j
+         endif
+      ENDDO      
+      ENDDO
+
+   ENDDO
+!  !$OMP END PARALLEL DO
+
+! convert DMUMAX from (PA) to (bars) per time step
+   dmumax = dmumax*1.e-5
+! compute global MAX
+   CALL wrf_dm_maxval ( dmumax,  idp, jdp )
+
+!  print *, 'p8w(30,1,30),pk1m(30,30) : ', p8w(30,1,30),pk1m(30,30)
+!  print *, 'mu_2(30,30),mu_2m(30,30) : ', mu_2(30,30),mu_2m(30,30)
+   dpsdt_sum = 0.
+   dmudt_sum = 0.
+
+   DO j = jps, min(jpe,jde-1)
+     DO i = ips, min(ipe,ide-1)
+       dpsdt_sum = dpsdt_sum + abs(dpsdt(i,j))
+       dmudt_sum = dmudt_sum + abs(dmudt(i,j))
+     ENDDO
+   ENDDO
+
+! compute global sum
+   dpsdt_sum = wrf_dm_sum_real ( dpsdt_sum )
+   dmudt_sum = wrf_dm_sum_real ( dmudt_sum )
+
+!  print *, 'dpsdt, dmudt : ', dpsdt_sum, dmudt_sum
+
+   IF ( diag_print .eq. 2 ) THEN
+   dardt_sum = 0.
+   drcdt_sum = 0.
+   drndt_sum = 0.
+   rainc_sum = 0.
+   raint_sum = 0.
+   rainnc_sum = 0.
+   sfcevp_sum = 0.
+   hfx_sum = 0.
+   lh_sum = 0.
+   raincmax = 0.
+   rainncmax = 0.
+
+   DO j = jps, min(jpe,jde-1)
+     DO i = ips, min(ipe,ide-1)
+       drcdt_sum = drcdt_sum + abs(raincv(i,j))
+       drndt_sum = drndt_sum + abs(rainncv(i,j))
+       dardt_sum = dardt_sum + abs(raincv(i,j)) + abs(rainncv(i,j))
+       rainc_sum = rainc_sum + abs(rainc(i,j))
+! MAX for accumulated conv precip
+       IF(rainc(i,j).gt.raincmax)then
+          raincmax=rainc(i,j)
+          irc=i
+          jrc=j
+       ENDIF
+       rainnc_sum = rainnc_sum + abs(rainnc(i,j))
+! MAX for accumulated resolved precip
+       IF(rainnc(i,j).gt.rainncmax)then
+          rainncmax=rainnc(i,j)
+          irnc=i
+          jrnc=j
+       ENDIF
+       raint_sum = raint_sum + abs(rainc(i,j)) + abs(rainnc(i,j))
+       sfcevp_sum = sfcevp_sum + abs(sfcevp(i,j))
+       hfx_sum = hfx_sum + abs(hfx(i,j))
+       lh_sum = lh_sum + abs(lh(i,j))
+     ENDDO
+   ENDDO
+
+! compute global MAX
+   CALL wrf_dm_maxval ( raincmax, irc, jrc )
+   CALL wrf_dm_maxval ( rainncmax, irnc, jrnc )
+
+! compute global sum
+   drcdt_sum = wrf_dm_sum_real ( drcdt_sum )
+   drndt_sum = wrf_dm_sum_real ( drndt_sum )
+   dardt_sum = wrf_dm_sum_real ( dardt_sum )
+   rainc_sum = wrf_dm_sum_real ( rainc_sum )
+   rainnc_sum = wrf_dm_sum_real ( rainnc_sum )
+   raint_sum = wrf_dm_sum_real ( raint_sum )
+   sfcevp_sum = wrf_dm_sum_real ( sfcevp_sum )
+   hfx_sum = wrf_dm_sum_real ( hfx_sum )
+   lh_sum = wrf_dm_sum_real ( lh_sum )
+
+   ENDIF
+
+! print out the average values
+
+   CALL get_current_grid_name( grid_str )
+
+#ifdef DM_PARALLEL
+   IF ( wrf_dm_on_monitor() ) THEN
+#endif
+     WRITE(outstring,*) grid_str,'Domain average of dpsdt, dmudt (mb/3h): ', xtime, &
+           dpsdt_sum/no_points*108., &
+           dmudt_sum/no_points*108.
+     CALL wrf_message ( TRIM(outstring) )
+
+     WRITE(outstring,*) grid_str,'Max mu change time step: ', idp,jdp,dmumax
+     CALL wrf_message ( TRIM(outstring) )
+
+     IF ( diag_print .eq. 2) THEN
+     WRITE(outstring,*) grid_str,'Domain average of dardt, drcdt, drndt (mm/sec): ', xtime, &
+           dardt_sum/dt/no_points, &
+           drcdt_sum/dt/no_points, &
+           drndt_sum/dt/no_points
+     CALL wrf_message ( TRIM(outstring) )
+     WRITE(outstring,*) grid_str,'Domain average of rt_sum, rc_sum, rnc_sum (mm): ', xtime, &
+           raint_sum/no_points, &
+           rainc_sum/no_points, &
+           rainnc_sum/no_points
+     CALL wrf_message ( TRIM(outstring) )
+     WRITE(outstring,*) grid_str,'Max Accum Resolved Precip,   I,J  (mm): '               ,&
+           rainncmax,irnc,jrnc
+     CALL wrf_message ( TRIM(outstring) )
+     WRITE(outstring,*) grid_str,'Max Accum Convective Precip,   I,J  (mm): '             ,&
+           raincmax,irc,jrc
+     CALL wrf_message ( TRIM(outstring) )
+     WRITE(outstring,*) grid_str,'Domain average of sfcevp, hfx, lh: ', xtime, &
+           sfcevp_sum/no_points, &
+           hfx_sum/no_points, &
+           lh_sum/no_points
+     CALL wrf_message ( TRIM(outstring) )
+     ENDIF
+#ifdef DM_PARALLEL
+   ENDIF
+#endif
+
+    ENDIF        ! print frequency
+   ENDIF
+
+! save values at this time step
+   !$OMP PARALLEL DO   &
+   !$OMP PRIVATE ( ij,i,j )
+   DO ij = 1 , num_tiles
+
+      DO j=j_start(ij),j_end(ij)
+      DO i=i_start(ij),i_end(ij)
+         pk1m(i,j)=p8w(i,kms,j)
+         mu_2m(i,j)=mu_2(i,j)
+      ENDDO
+      ENDDO
+
+      IF ( xtime .lt. 0.0001 ) THEN
+      DO j=j_start(ij),j_end(ij)
+      DO i=i_start(ij),i_end(ij)
+         dpsdt(i,j)=0.
+         dmudt(i,j)=0.
+      ENDDO
+      ENDDO
+      ENDIF
+
+   ENDDO
+   !$OMP END PARALLEL DO
+
+   END SUBROUTINE diagnostic_output_calc
+
+
+END MODULE module_diag_misc
+#endif
diff --git a/wrfv2_fire/phys/module_diag_pld.F b/wrfv2_fire/phys/module_diag_pld.F
new file mode 100644
index 00000000..bd2bca6d
--- /dev/null
+++ b/wrfv2_fire/phys/module_diag_pld.F
@@ -0,0 +1,197 @@
+#if (NMM_CORE == 1)
+MODULE module_diag_pld
+CONTAINS
+   SUBROUTINE diag_pld_stub
+   END SUBROUTINE diag_pld_stub
+END MODULE module_diag_pld
+#else
+!WRF:MEDIATION_LAYER:PHYSICS
+!
+
+MODULE module_diag_pld
+CONTAINS
+
+   SUBROUTINE pld ( u,v,w,t,qv,zp,zb,pp,pb,p,pw,                    &
+                    msfux,msfuy,msfvx,msfvy,msftx,msfty,            &
+                    f,e,                                            &
+                    use_tot_or_hyd_p,missing,                       &
+                    num_press_levels,max_press_levels,press_levels, &
+                    p_pl,u_pl,v_pl,t_pl,rh_pl,ght_pl,s_pl,td_pl,    &
+                    ids,ide, jds,jde, kds,kde,                      &
+                    ims,ime, jms,jme, kms,kme,                      &
+                    its,ite, jts,jte, kts,kte                       )
+   
+      USE module_model_constants
+   
+      IMPLICIT NONE
+   
+   
+      !  Input variables
+   
+      INTEGER, INTENT(IN   )                                          :: ids,ide, jds,jde, kds,kde, &
+                                                                         ims,ime, jms,jme, kms,kme, &
+                                                                         its,ite, jts,jte, kts,kte
+      REAL   , INTENT(IN   ) , DIMENSION(ims:ime , jms:jme)           :: msfux,msfuy,msfvx,msfvy,msftx,msfty, &
+                                                                         f,e
+      INTEGER, INTENT(IN   )                                          :: use_tot_or_hyd_p
+      REAL   , INTENT(IN   )                                          :: missing
+      REAL   , INTENT(IN   ) , DIMENSION(ims:ime , kms:kme , jms:jme) :: u,v,w,t,qv,zp,zb,pp,pb,p,pw
+      INTEGER, INTENT(IN   )                                          :: num_press_levels, max_press_levels
+      REAL   , INTENT(IN   ) , DIMENSION(max_press_levels)            :: press_levels
+   
+      !  Output variables
+   
+      REAL   , INTENT(  OUT) ,  DIMENSION(num_press_levels)                     :: p_pl
+      REAL   , INTENT(  OUT) ,  DIMENSION(ims:ime , num_press_levels , jms:jme) :: u_pl,v_pl,t_pl,rh_pl,ght_pl,s_pl,td_pl
+   
+      !  Local variables
+   
+      REAL, PARAMETER :: eps = 0.622, t_kelvin = svpt0 , s1 = 243.5, s2 = svp2 , s3 = svp1*10., s4 = 611.0, s5 = 5418.12
+   
+      INTEGER :: i, j, ke, kp, ke_h, ke_f
+      REAL    :: pu, pd, pm , &
+                 tu, td     , &
+                 su, sd     , &
+                 uu, ud     , &
+                 vu, vd     , &
+                 zu, zd     , &
+                 qu, qd, qm , &
+                 eu, ed, em , &
+                 du, dd
+      REAL    :: es, qs
+   
+      !  Silly, but transfer the small namelist.input array into the grid structure for output purposes.
+   
+      DO kp = 1 , num_press_levels
+         p_pl(kp) = press_levels(kp)
+      END DO
+   
+      !  Initialize pressure level data to un-initialized
+   
+      DO j = jts , jte
+         DO kp = 1 , num_press_levels
+            DO i = its , ite
+               u_pl  (i,kp,j) = missing
+               v_pl  (i,kp,j) = missing
+               t_pl  (i,kp,j) = missing
+               rh_pl (i,kp,j) = missing
+               ght_pl(i,kp,j) = missing
+               s_pl  (i,kp,j) = missing
+               td_pl (i,kp,j) = missing
+            END DO
+         END DO
+      END DO
+   
+      !  Loop over each i,j location
+   
+      j_loop : DO j = jts , MIN(jte,jde-1)
+         i_loop : DO i = its , MIN(ite,ide-1)
+   
+            !  For each i,j location, loop over the selected pressure levels to find
+   
+            ke_h = kts
+            ke_f = kts
+            kp_loop : DO kp = 1 , num_press_levels
+   
+               !  For this particular i,j and pressure level, find the eta levels that surround this point
+               !  on half-levels.
+   
+               ke_loop_half : DO ke = ke_h , kte-2
+   
+                  IF      ( use_tot_or_hyd_p .EQ. 1 ) THEN     !  total pressure
+                     pu = pp(i,ke+1,j)+pb(i,ke+1,j)
+                     pd = pp(i,ke  ,j)+pb(i,ke  ,j)
+                  ELSE IF ( use_tot_or_hyd_p .EQ. 2 ) THEN     !  hydrostatic pressure
+                     pu = p(i,ke+1,j)
+                     pd = p(i,ke  ,j)
+                  END IF
+                  pm = p_pl(kp)
+   
+                  IF ( ( pd .GE. pm ) .AND. &
+                       ( pu .LT. pm ) ) THEN
+   
+                     !  Found trapping pressure: up, middle, down.  We are doing first order interpolation.  
+                     !  Now we just put in a list of diagnostics for this level.
+   
+                     !  1. Temperature (K)
+   
+                     tu = (t(i,ke+1,j)+t0)*(pu/p1000mb)**rcp
+                     td = (t(i,ke  ,j)+t0)*(pd/p1000mb)**rcp
+                     t_pl(i,kp,j) = ( tu * (pm-pd) + td * (pu-pm) ) / (pu-pd)
+   
+                     !  2. Speed (m s-1)
+   
+                     su = 0.5 * SQRT ( ( u(i,ke+1,j)+u(i+1,ke+1,j) )**2 + ( v(i,ke+1,j)+v(i,ke+1,j+1) )**2 ) 
+                     sd = 0.5 * SQRT ( ( u(i,ke  ,j)+u(i+1,ke  ,j) )**2 + ( v(i,ke  ,j)+v(i,ke  ,j+1) )**2 ) 
+                     s_pl(i,kp,j) = ( su * (pm-pd) + sd * (pu-pm) ) / (pu-pd)
+   
+                     !  3. U and V (m s-1)
+   
+                     uu = 0.5 *        ( u(i,ke+1,j)+u(i+1,ke+1,j) )
+                     ud = 0.5 *        ( u(i,ke  ,j)+u(i+1,ke  ,j) )
+                     u_pl(i,kp,j) = ( uu * (pm-pd) + ud * (pu-pm) ) / (pu-pd)
+   
+                     vu = 0.5 *                                           ( v(i,ke+1,j)+v(i,ke+1,j+1) )
+                     vd = 0.5 *                                           ( v(i,ke  ,j)+v(i,ke  ,j+1) )
+                     v_pl(i,kp,j) = ( vu * (pm-pd) + vd * (pu-pm) ) / (pu-pd)
+   
+                     !  4. Dewpoint (K) - Use Bolton's approximation
+   
+                     qu = MAX(qv(i,ke+1,j),0.)
+                     qd = MAX(qv(i,ke  ,j),0.)
+                     eu = qu * pu * 0.01 / ( eps + qu )       ! water vapor pressure in mb.
+                     ed = qd * pd * 0.01 / ( eps + qd )       ! water vapor pressure in mb.
+                     eu = max(eu, 0.001)
+                     ed = max(ed, 0.001)
+   
+                     du = t_kelvin + ( s1 / ((s2 / log(eu/s3)) - 1.0) )
+                     dd = t_kelvin + ( s1 / ((s2 / log(ed/s3)) - 1.0) )
+                     td_pl(i,kp,j) = ( du * (pm-pd) + dd * (pu-pm) ) / (pu-pd)
+   
+                     !  5. Relative humidity (%)
+   
+                     qm = ( qu * (pm-pd) + qd * (pu-pm) ) / (pu-pd)                           ! qvapor at the pressure level.
+                     es = s4 * exp(s5 * (1.0 / 273.0 - 1.0 / t_pl(i,kp,j)))
+                     qs = eps * es / (pm - es)
+                     rh_pl(i,kp,j)   = qm / qs * 100.
+   
+                     !em = qm * pm * 0.01 / ( eps + qm )                                       ! water vapor pressure at the level.
+                     !es = s3 * exp( s2 * (t_pl(i,kp,j) - t_kelvin)/(t_pl(i,kp,j) - s4) )      ! sat vapor pressure over liquid water in mb.
+                     !rh_pl(i,kp,j) = 100. * em * ( pm * 0.01 - es ) / ( es * ( pm * 0.01 - em ) )
+   
+                     ke_h = ke
+                     EXIT ke_loop_half
+                  END IF
+               END DO ke_loop_half
+   
+               ke_loop_full : DO ke = ke_f , kte-1
+                  IF ( ( pw(i,ke  ,j) .GE. p_pl(kp) ) .AND. &
+                       ( pw(i,ke+1,j) .LT. p_pl(kp) ) ) THEN
+   
+                     !  Found trapping pressure: up, middle, down.  We are doing first order interpolation.
+   
+                     pu = LOG(pw(i,ke+1,j))
+                     pm = LOG(p_pl(kp))
+                     pd = LOG(pw(i,ke  ,j))
+   
+                     !  Now we just put in a list of diagnostics for this level.
+   
+                     !  1. Geopotential height (m)
+   
+                     zu = ( zp(i,ke+1,j)+zb(i,ke+1,j) ) / g
+                     zd = ( zp(i,ke  ,j)+zb(i,ke  ,j) ) / g
+                     ght_pl(i,kp,j) = ( zu * (pm-pd) + zd * (pu-pm) ) / (pu-pd)
+   
+                     ke_f = ke
+                     EXIT ke_loop_full
+                  END IF
+               END DO ke_loop_full
+   
+            END DO kp_loop
+         END DO i_loop
+      END DO j_loop
+
+   END SUBROUTINE pld
+
+END MODULE module_diag_pld
+#endif
diff --git a/wrfv2_fire/phys/module_diag_refl.F b/wrfv2_fire/phys/module_diag_refl.F
new file mode 100644
index 00000000..a8b776eb
--- /dev/null
+++ b/wrfv2_fire/phys/module_diag_refl.F
@@ -0,0 +1,89 @@
+!WRF:MEDIATION_LAYER:PHYSICS
+!
+
+MODULE module_diag_refl
+CONTAINS
+
+#if (NMM_CORE==1)
+   SUBROUTINE diagnostic_output_calc_refl(                            &
+                      ids,ide, jds,jde, kds,kde,                      &
+                      ims,ime, jms,jme, kms,kme,                      &
+                      its,ite, jts,jte, kts,kte,                      & ! tile dims
+                      diagflag,                                       &
+                      refd_max,refl_10cm                              &
+                                                                     )
+!----------------------------------------------------------------------
+
+
+   IMPLICIT NONE
+!======================================================================
+! Definitions
+!-----------
+!-- DIAGFLAG      logical flag to indicate if this is a history output time
+!-- REF_MAX       max derived radar reflectivity
+!-- REFL_10CM     model computed 3D reflectivity
+!
+!-- ids           start index for i in domain
+!-- ide           end index for i in domain
+!-- jds           start index for j in domain
+!-- jde           end index for j in domain
+!-- kds           start index for k in domain
+!-- kde           end index for k in domain
+!-- ims           start index for i in memory
+!-- ime           end index for i in memory
+!-- jms           start index for j in memory
+!-- jme           end index for j in memory
+!-- kms           start index for k in memory
+!-- kme           end index for k in memory
+!-- its           start index for i in tile
+!-- ite           end index for i in tile
+!-- jts           start index for j in tile
+!-- jte           end index for j in tile
+!-- kts           start index for k in tile
+!-- kte           end index for k in tile
+!
+!======================================================================
+
+   INTEGER,      INTENT(IN   )    ::                             &
+                                      ids,ide, jds,jde, kds,kde, &
+                                      ims,ime, jms,jme, kms,kme, &
+                                      its,ite, jts,jte, kts,kte
+
+   LOGICAL,   INTENT(IN   )    ::   diagflag
+
+
+   INTEGER :: i,j,k
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) ::   &
+                                                      refl_10cm
+
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) ::        &
+                                                       refd_max
+
+       DO j=jts,jte
+       DO i=its,ite
+         refd_max(i,j)    = -35.
+       ENDDO
+       ENDDO
+
+     DO j=jts,jte
+     DO k=kts,kte
+     DO i=its,ite
+
+! Calculate the max radar reflectivity between output times
+
+       IF ( refl_10cm(i,k,j) .GT. refd_max(i,j) ) THEN
+         refd_max(i,j) = refl_10cm(i,k,j)
+       ENDIF
+     ENDDO
+     ENDDO
+     ENDDO
+!  !$OMP END PARALLEL DO
+
+
+   END SUBROUTINE diagnostic_output_calc_refl
+#endif
+
+
+
+END MODULE module_diag_refl
diff --git a/wrfv2_fire/phys/module_diagnostics.F b/wrfv2_fire/phys/module_diagnostics.F
deleted file mode 100644
index 669e9730..00000000
--- a/wrfv2_fire/phys/module_diagnostics.F
+++ /dev/null
@@ -1,1351 +0,0 @@
-!WRF:MEDIATION_LAYER:PHYSICS
-!
-
-MODULE module_diagnostics
-CONTAINS
-   SUBROUTINE diagnostic_output_calc(                                 &
-                      ids,ide, jds,jde, kds,kde,                      &
-                      ims,ime, jms,jme, kms,kme,                      &
-                      ips,ipe, jps,jpe, kps,kpe,                      & ! patch  dims
-                      i_start,i_end,j_start,j_end,kts,kte,num_tiles   &
-                     ,dpsdt,dmudt                                     &
-                     ,p8w,pk1m,mu_2,mu_2m                             &
-                     ,u,v                                             &
-                     ,raincv,rainncv,rainc,rainnc                     &
-                     ,i_rainc,i_rainnc                                &
-                     ,hfx,sfcevp,lh                                   &
-                     ,ACSWUPT,ACSWUPTC,ACSWDNT,ACSWDNTC               & ! Optional
-                     ,ACSWUPB,ACSWUPBC,ACSWDNB,ACSWDNBC               & ! Optional
-                     ,ACLWUPT,ACLWUPTC,ACLWDNT,ACLWDNTC               & ! Optional
-                     ,ACLWUPB,ACLWUPBC,ACLWDNB,ACLWDNBC               & ! Optional
-                     ,I_ACSWUPT,I_ACSWUPTC,I_ACSWDNT,I_ACSWDNTC       & ! Optional
-                     ,I_ACSWUPB,I_ACSWUPBC,I_ACSWDNB,I_ACSWDNBC       & ! Optional
-                     ,I_ACLWUPT,I_ACLWUPTC,I_ACLWDNT,I_ACLWDNTC       & ! Optional
-                     ,I_ACLWUPB,I_ACLWUPBC,I_ACLWDNB,I_ACLWDNBC       & ! Optional
-                     ,dt,xtime,sbw,t2                                 &
-                     ,diag_print                                      &
-                     ,bucket_mm, bucket_J                             &
-                     ,prec_acc_c, prec_acc_nc, snow_acc_nc            &
-                     ,snowncv, prec_acc_dt, curr_secs                 &
-                     ,nwp_diagnostics, diagflag                       &
-                     ,history_interval                                &
-                     ,itimestep                                       &
-                     ,u10,v10,w                                       &
-                     ,wspd10max                                       &
-                     ,up_heli_max                                     &
-                     ,w_up_max,w_dn_max                               &
-                     ,znw,w_colmean                                   &
-                     ,numcolpts,w_mean                                &
-                     ,grpl_max,grpl_colint,refd_max,refl_10cm         &
-                     ,qg_curr                                         &
-                     ,rho,ph,phb,g                                    &
-                                                                      )
-!----------------------------------------------------------------------
-
-  USE module_dm, ONLY: wrf_dm_sum_real, wrf_dm_maxval
-
-   IMPLICIT NONE
-!======================================================================
-! Definitions
-!-----------
-!-- DIAG_PRINT    print control: 0 - no diagnostics; 1 - dmudt only; 2 - all
-!-- DT            time step (second)
-!-- XTIME         forecast time
-!-- SBW           specified boundary width - used later
-!
-!-- P8W           3D pressure array at full eta levels
-!-- MU            dry column hydrostatic pressure
-!-- RAINC         cumulus scheme precipitation since hour 0
-!-- RAINCV        cumulus scheme precipitation in one time step (mm)
-!-- RAINNC        explicit scheme precipitation since hour 0
-!-- RAINNCV       explicit scheme precipitation in one time step (mm)
-!-- SNOWNCV       explicit scheme snow in one time step (mm)
-!-- HFX           surface sensible heat flux
-!-- LH            surface latent heat flux
-!-- SFCEVP        total surface evaporation
-!-- U             u component of wind - to be used later to compute k.e.
-!-- V             v component of wind - to be used later to compute k.e.
-!-- PREC_ACC_C    accumulated convective precip over accumulation time prec_acc_dt
-!-- PREC_ACC_NC   accumulated explicit precip over accumulation time prec_acc_dt
-!-- SNOW_ACC_NC   accumulated explicit snow precip over accumulation time prec_acc_dt
-!-- PREC_ACC_DT   precip accumulation time, default is 60 min
-!-- CURR_SECS     model time in seconds
-!-- NWP_DIAGNOSTICS  = 1, compute hourly maximum fields
-!-- DIAGFLAG      logical flag to indicate if this is a history output time
-!-- U10, V10      10 m wind components
-!-- WSPD10MAX     10 m max wind speed
-!-- UP_HELI_MAX   max updraft helicity
-!-- W_UP_MAX      max updraft vertical velocity
-!-- W_DN_MAX      max downdraft vertical velocity
-!-- W_COLMEAN     column mean vertical velocity
-!-- NUMCOLPTS     no of column points
-!-- GRPL_MAX      max column-integrated graupel
-!-- GRPL_COLINT   column-integrated graupel
-!-- REF_MAX       max derived radar reflectivity
-!-- REFL_10CM     model computed 3D reflectivity
-!
-!-- ids           start index for i in domain
-!-- ide           end index for i in domain
-!-- jds           start index for j in domain
-!-- jde           end index for j in domain
-!-- kds           start index for k in domain
-!-- kde           end index for k in domain
-!-- ims           start index for i in memory
-!-- ime           end index for i in memory
-!-- jms           start index for j in memory
-!-- jme           end index for j in memory
-!-- ips           start index for i in patch
-!-- ipe           end index for i in patch
-!-- jps           start index for j in patch
-!-- jpe           end index for j in patch
-!-- kms           start index for k in memory
-!-- kme           end index for k in memory
-!-- i_start       start indices for i in tile
-!-- i_end         end indices for i in tile
-!-- j_start       start indices for j in tile
-!-- j_end         end indices for j in tile
-!-- kts           start index for k in tile
-!-- kte           end index for k in tile
-!-- num_tiles     number of tiles
-!
-!======================================================================
-
-   INTEGER,      INTENT(IN   )    ::                             &
-                                      ids,ide, jds,jde, kds,kde, &
-                                      ims,ime, jms,jme, kms,kme, &
-                                      ips,ipe, jps,jpe, kps,kpe, &
-                                                        kts,kte, &
-                                                      num_tiles
-
-   INTEGER, DIMENSION(num_tiles), INTENT(IN) ::                  &
-     &           i_start,i_end,j_start,j_end
-
-   INTEGER,      INTENT(IN   )    ::   diag_print
-   REAL,      INTENT(IN   )    ::   bucket_mm, bucket_J
-   INTEGER,   INTENT(IN   )    ::   nwp_diagnostics
-   LOGICAL,   INTENT(IN   )    ::   diagflag
-
-   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
-         INTENT(IN ) ::                                       u  &
-                                                    ,         v  &
-                                                    ,       p8w
-
-   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) ::           &
-                                                           MU_2  &
-                                                    ,   RAINNCV  &
-                                                    ,    RAINCV  &
-                                                    ,   SNOWNCV  &
-                                                    ,       HFX  &
-                                                    ,        LH  &
-                                                    ,    SFCEVP  &  
-                                                    ,        T2     
-
-   REAL, DIMENSION( ims:ime , jms:jme ),                         &
-          INTENT(INOUT) ::                                DPSDT  &
-                                                    ,     DMUDT  &
-                                                    ,    RAINNC  &
-                                                    ,     RAINC  &
-                                                    ,     MU_2M  &
-                                                    ,      PK1M
- 
-   REAL,  INTENT(IN   ) :: DT, XTIME
-   INTEGER,  INTENT(IN   ) :: SBW
-   INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) ::     &
-                                                       I_RAINC,  &
-                                                       I_RAINNC
-   REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
-                      ACSWUPT,ACSWUPTC,ACSWDNT,ACSWDNTC,          &
-                      ACSWUPB,ACSWUPBC,ACSWDNB,ACSWDNBC,          &
-                      ACLWUPT,ACLWUPTC,ACLWDNT,ACLWDNTC,          &
-                      ACLWUPB,ACLWUPBC,ACLWDNB,ACLWDNBC
-   INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
-                      I_ACSWUPT,I_ACSWUPTC,I_ACSWDNT,I_ACSWDNTC,  &
-                      I_ACSWUPB,I_ACSWUPBC,I_ACSWDNB,I_ACSWDNBC,  &
-                      I_ACLWUPT,I_ACLWUPTC,I_ACLWDNT,I_ACLWDNTC,  &
-                      I_ACLWUPB,I_ACLWUPBC,I_ACLWDNB,I_ACLWDNBC
-
-   REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) ::&
-                      PREC_ACC_C, PREC_ACC_NC, SNOW_ACC_NC
-
-   REAL, OPTIONAL, INTENT(IN)::  PREC_ACC_DT, CURR_SECS
-
-   INTEGER :: i,j,k,its,ite,jts,jte,ij
-   INTEGER :: idp,jdp,irc,jrc,irnc,jrnc,isnh,jsnh
-   INTEGER :: prfreq
-
-   REAL              :: no_points
-   REAL              :: dpsdt_sum, dmudt_sum, dardt_sum, drcdt_sum, drndt_sum
-   REAL              :: hfx_sum, lh_sum, sfcevp_sum, rainc_sum, rainnc_sum, raint_sum
-   REAL              :: dmumax, raincmax, rainncmax, snowhmax
-   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
-   CHARACTER*256     :: outstring
-   CHARACTER*6       :: grid_str
-
-   INTEGER, INTENT(IN) ::                                        &
-                                     history_interval,itimestep
-
-   REAL, DIMENSION( kms:kme ), INTENT(IN) ::                     &
-                                                            znw
-
-   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) ::   &
-                                                              w  &
-                                                       ,qg_curr  &
-                                                           ,rho  &
-                                                     ,refl_10cm  &
-                                                        ,ph,phb
-
-   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) ::            &
-                                                            u10  &
-                                                           ,v10
-
-   REAL, INTENT(IN) :: g
-
-   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) ::        &
-                                                      wspd10max  &
-                                                   ,up_heli_max  &
-                                             ,w_up_max,w_dn_max  &
-                                    ,w_colmean,numcolpts,w_mean  &
-                                          ,grpl_max,grpl_colint  &
-                                                      ,refd_max
-
-   INTEGER :: idump
-
-   REAL :: wind_vel
-   REAL :: depth
-
-!-----------------------------------------------------------------
-! Handle accumulations with buckets to prevent round-off truncation in long runs
-! This is done every 360 minutes assuming time step fits exactly into 360 minutes
-   IF(bucket_mm .gt. 0. .AND. MOD(NINT(XTIME),360) .EQ. 0)THEN
-! SET START AND END POINTS FOR TILES
-!  !$OMP PARALLEL DO   &
-!  !$OMP PRIVATE ( ij )
-
-   DO ij = 1 , num_tiles
-
-      IF (xtime .eq. 0.0)THEN
-        DO j=j_start(ij),j_end(ij)
-        DO i=i_start(ij),i_end(ij)
-          i_rainnc(i,j) = 0
-          i_rainc(i,j) = 0
-        ENDDO      
-        ENDDO
-      ENDIF
-      DO j=j_start(ij),j_end(ij)
-      DO i=i_start(ij),i_end(ij)
-        IF(rainnc(i,j) .gt. bucket_mm)THEN
-          rainnc(i,j) = rainnc(i,j) - bucket_mm
-          i_rainnc(i,j) =  i_rainnc(i,j) + 1
-        ENDIF
-        IF(rainc(i,j) .gt. bucket_mm)THEN
-          rainc(i,j) = rainc(i,j) - bucket_mm
-          i_rainc(i,j) =  i_rainc(i,j) + 1
-        ENDIF
-      ENDDO      
-      ENDDO
-
-      IF (xtime .eq. 0.0 .and. bucket_J .gt. 0.0 .and. PRESENT(ACSWUPT))THEN
-        DO j=j_start(ij),j_end(ij)
-        DO i=i_start(ij),i_end(ij)
-          i_acswupt(i,j) = 0
-          i_acswuptc(i,j) = 0
-          i_acswdnt(i,j) = 0
-          i_acswdntc(i,j) = 0
-          i_acswupb(i,j) = 0
-          i_acswupbc(i,j) = 0
-          i_acswdnb(i,j) = 0
-          i_acswdnbc(i,j) = 0
-        ENDDO      
-        ENDDO
-      ENDIF
-      IF (xtime .eq. 0.0  .and. bucket_J .gt. 0.0 .and. PRESENT(ACLWUPT))THEN
-        DO j=j_start(ij),j_end(ij)
-        DO i=i_start(ij),i_end(ij)
-          i_aclwupt(i,j) = 0
-          i_aclwuptc(i,j) = 0
-          i_aclwdnt(i,j) = 0
-          i_aclwdntc(i,j) = 0
-          i_aclwupb(i,j) = 0
-          i_aclwupbc(i,j) = 0
-          i_aclwdnb(i,j) = 0
-          i_aclwdnbc(i,j) = 0
-        ENDDO      
-        ENDDO
-      ENDIF
-      IF (PRESENT(ACSWUPT) .and. bucket_J .gt. 0.0)THEN
-      DO j=j_start(ij),j_end(ij)
-      DO i=i_start(ij),i_end(ij)
-        IF(acswupt(i,j) .gt. bucket_J)THEN
-          acswupt(i,j) = acswupt(i,j) - bucket_J
-          i_acswupt(i,j) =  i_acswupt(i,j) + 1
-        ENDIF
-        IF(acswuptc(i,j) .gt. bucket_J)THEN
-          acswuptc(i,j) = acswuptc(i,j) - bucket_J
-          i_acswuptc(i,j) =  i_acswuptc(i,j) + 1
-        ENDIF
-        IF(acswdnt(i,j) .gt. bucket_J)THEN
-          acswdnt(i,j) = acswdnt(i,j) - bucket_J
-          i_acswdnt(i,j) =  i_acswdnt(i,j) + 1
-        ENDIF
-        IF(acswdntc(i,j) .gt. bucket_J)THEN
-          acswdntc(i,j) = acswdntc(i,j) - bucket_J
-          i_acswdntc(i,j) =  i_acswdntc(i,j) + 1
-        ENDIF
-        IF(acswupb(i,j) .gt. bucket_J)THEN
-          acswupb(i,j) = acswupb(i,j) - bucket_J
-          i_acswupb(i,j) =  i_acswupb(i,j) + 1
-        ENDIF
-        IF(acswupbc(i,j) .gt. bucket_J)THEN
-          acswupbc(i,j) = acswupbc(i,j) - bucket_J
-          i_acswupbc(i,j) =  i_acswupbc(i,j) + 1
-        ENDIF
-        IF(acswdnb(i,j) .gt. bucket_J)THEN
-          acswdnb(i,j) = acswdnb(i,j) - bucket_J
-          i_acswdnb(i,j) =  i_acswdnb(i,j) + 1
-        ENDIF
-        IF(acswdnbc(i,j) .gt. bucket_J)THEN
-          acswdnbc(i,j) = acswdnbc(i,j) - bucket_J
-          i_acswdnbc(i,j) =  i_acswdnbc(i,j) + 1
-        ENDIF
-      ENDDO      
-      ENDDO
-      ENDIF
-      IF (PRESENT(ACLWUPT) .and. bucket_J .gt. 0.0)THEN
-      DO j=j_start(ij),j_end(ij)
-      DO i=i_start(ij),i_end(ij)
-        IF(aclwupt(i,j) .gt. bucket_J)THEN
-          aclwupt(i,j) = aclwupt(i,j) - bucket_J
-          i_aclwupt(i,j) =  i_aclwupt(i,j) + 1
-        ENDIF
-        IF(aclwuptc(i,j) .gt. bucket_J)THEN
-          aclwuptc(i,j) = aclwuptc(i,j) - bucket_J
-          i_aclwuptc(i,j) =  i_aclwuptc(i,j) + 1
-        ENDIF
-        IF(aclwdnt(i,j) .gt. bucket_J)THEN
-          aclwdnt(i,j) = aclwdnt(i,j) - bucket_J
-          i_aclwdnt(i,j) =  i_aclwdnt(i,j) + 1
-        ENDIF
-        IF(aclwdntc(i,j) .gt. bucket_J)THEN
-          aclwdntc(i,j) = aclwdntc(i,j) - bucket_J
-          i_aclwdntc(i,j) =  i_aclwdntc(i,j) + 1
-        ENDIF
-        IF(aclwupb(i,j) .gt. bucket_J)THEN
-          aclwupb(i,j) = aclwupb(i,j) - bucket_J
-          i_aclwupb(i,j) =  i_aclwupb(i,j) + 1
-        ENDIF
-        IF(aclwupbc(i,j) .gt. bucket_J)THEN
-          aclwupbc(i,j) = aclwupbc(i,j) - bucket_J
-          i_aclwupbc(i,j) =  i_aclwupbc(i,j) + 1
-        ENDIF
-        IF(aclwdnb(i,j) .gt. bucket_J)THEN
-          aclwdnb(i,j) = aclwdnb(i,j) - bucket_J
-          i_aclwdnb(i,j) =  i_aclwdnb(i,j) + 1
-        ENDIF
-        IF(aclwdnbc(i,j) .gt. bucket_J)THEN
-          aclwdnbc(i,j) = aclwdnbc(i,j) - bucket_J
-          i_aclwdnbc(i,j) =  i_aclwdnbc(i,j) + 1
-        ENDIF
-      ENDDO      
-      ENDDO
-      ENDIF
-   ENDDO
-!  !$OMP END PARALLEL DO
-   ENDIF
-
-! Compute precipitation accumulation in a given time window: prec_acc_dt
-   IF (prec_acc_dt .gt. 0.) THEN
-
-!  !$OMP PARALLEL DO   &
-!  !$OMP PRIVATE ( ij )
-
-   DO ij = 1 , num_tiles
-
-      DO j=j_start(ij),j_end(ij)
-      DO i=i_start(ij),i_end(ij)
-         IF (mod(curr_secs, 60.* prec_acc_dt) == 0.) THEN
-            prec_acc_c(i,j)  = 0.
-            prec_acc_nc(i,j) = 0.
-            snow_acc_nc(i,j)  = 0.
-         ENDIF
-         prec_acc_c(i,j)  = prec_acc_c(i,j)  +  RAINCV(i,j)
-         prec_acc_nc(i,j) = prec_acc_nc(i,j) + RAINNCV(i,j)
-         prec_acc_c(i,j)  = MAX (prec_acc_c(i,j), 0.0)
-         prec_acc_nc(i,j) = MAX (prec_acc_nc(i,j), 0.0)
-         snow_acc_nc(i,j)   = snow_acc_nc(i,j) + SNOWNCV(I,J)
-! add convective precip to snow bucket if t2 < 273.15
-         IF ( t2(i,j) .lt. 273.15 ) THEN
-         snow_acc_nc(i,j)   = snow_acc_nc(i,j) +  RAINCV(i,j)
-         snow_acc_nc(i,j)   = MAX (snow_acc_nc(i,j), 0.0)
-         ENDIF
-      ENDDO     
-      ENDDO     
-
-   ENDDO     
-
-!  !$OMP END PARALLEL DO
-   ENDIF
-
-! NSSL
-
-   IF ( nwp_diagnostics .EQ. 1 ) THEN
-
-     idump = (history_interval * 60.) / dt
-
-!   print *,' history_interval = ', history_interval
-!   print *,' itimestep        = ', itimestep
-!   print *,' idump            = ', idump
-!   print *,' xtime            = ', xtime
-
-! IF ( MOD(itimestep, idump) .eq. 0 ) THEN
-!    WRITE(outstring,*) 'Computing PH0 for this domain with curr_secs = ', curr_secs
-!    CALL wrf_message ( TRIM(outstring) )
-
-   IF ( MOD((itimestep - 1), idump) .eq. 0 ) THEN
-     WRITE(outstring,*) 'NSSL Diagnostics: Resetting max arrays for domain with dt = ', dt
-     CALL wrf_debug ( 10,TRIM(outstring) )
-
-!  !$OMP PARALLEL DO   &
-!  !$OMP PRIVATE ( ij )
-     DO ij = 1 , num_tiles
-       DO j=j_start(ij),j_end(ij)
-       DO i=i_start(ij),i_end(ij)
-         wspd10max(i,j)   = 0.
-         up_heli_max(i,j) = 0.
-         w_up_max(i,j)    = 0.
-         w_dn_max(i,j)    = 0.
-         w_mean(i,j)      = 0.
-         grpl_max(i,j)    = 0.
-         refd_max(i,j)    = 0.
-       ENDDO
-       ENDDO
-     ENDDO
-!  !$OMP END PARALLEL DO
-   ENDIF
-
-!  !$OMP PARALLEL DO   &
-!  !$OMP PRIVATE ( ij )
-   DO ij = 1 , num_tiles
-     DO j=j_start(ij),j_end(ij)
-     DO i=i_start(ij),i_end(ij)
-
-! Zero some accounting arrays that will be used below
-
-       w_colmean(i,j)   = 0.
-       numcolpts(i,j)   = 0.
-       grpl_colint(i,j) = 0.
-     ENDDO
-     ENDDO
-   ENDDO
-!  !$OMP END PARALLEL DO
-
-!  !$OMP PARALLEL DO   &
-!  !$OMP PRIVATE ( ij )
-   DO ij = 1 , num_tiles
-     DO j=j_start(ij),j_end(ij)
-     DO k=kms,kme
-     DO i=i_start(ij),i_end(ij)
-
-! Find vertical velocity max (up and down) below 400 mb
-
-       IF ( p8w(i,k,j) .GT. 40000. .AND. w(i,k,j) .GT. w_up_max(i,j) ) THEN
-         w_up_max(i,j) = w(i,k,j)
-       ENDIF
-
-       IF ( p8w(i,k,j) .GT. 40000. .AND. w(i,k,j) .LT. w_dn_max(i,j) ) THEN
-         w_dn_max(i,j) = w(i,k,j)
-       ENDIF
-
-! For the column mean vertical velocity calculation, first
-! total the vertical velocity between sigma levels 0.5 and 0.8
-
-       IF ( znw(k) .GE. 0.5 .AND. znw(k) .LE. 0.8 ) THEN
-         w_colmean(i,j) = w_colmean(i,j) + w(i,k,j)
-         numcolpts(i,j) = numcolpts(i,j) + 1
-       ENDIF
-     ENDDO
-     ENDDO
-     ENDDO
-   ENDDO
-!  !$OMP END PARALLEL DO
-
-!  !$OMP PARALLEL DO   &
-!  !$OMP PRIVATE ( ij )
-   DO ij = 1 , num_tiles
-     DO j=j_start(ij),j_end(ij)
-     DO k=kms,kme-1
-     DO i=i_start(ij),i_end(ij)
-
-! Calculate the column integrated graupel
-
-       depth = ( ( ph(i,k+1,j) + phb(i,k+1,j) ) / g ) - \
-               ( ( ph(i,k  ,j) + phb(i,k  ,j) ) / g )
-       grpl_colint(i,j) = grpl_colint(i,j) + qg_curr(i,k,j) * depth * rho(i,k,j)
-     ENDDO
-     ENDDO
-     ENDDO
-   ENDDO
-!  !$OMP END PARALLEL DO
-
-!  !$OMP PARALLEL DO   &
-!  !$OMP PRIVATE ( ij )
-   DO ij = 1 , num_tiles
-     DO j=j_start(ij),j_end(ij)
-     DO i=i_start(ij),i_end(ij)
-
-! Calculate the max 10 m wind speed between output times
-
-       wind_vel = sqrt ( u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j) )
-       IF ( wind_vel .GT. wspd10max(i,j) ) THEN
-         wspd10max(i,j) = wind_vel
-       ENDIF
-
-! Calculate the column mean vertical velocity between output times
-
-       w_mean(i,j) = w_mean(i,j) + w_colmean(i,j) / numcolpts(i,j)
-
-       IF ( MOD(itimestep, idump) .eq. 0 ) THEN
-         w_mean(i,j) = w_mean(i,j) / idump
-       ENDIF
-
-! Calculate the max column integrated graupel between output times
-
-       IF ( grpl_colint(i,j) .gt. grpl_max(i,j) ) THEN
-          grpl_max(i,j) = grpl_colint(i,j)
-       ENDIF
-
-! Calculate the max radar reflectivity between output times
-
-       IF ( refl_10cm(i,kms,j) .GT. refd_max(i,j) ) THEN
-         refd_max(i,j) = refl_10cm(i,kms,j)
-       ENDIF
-     ENDDO
-     ENDDO
-   ENDDO
-!  !$OMP END PARALLEL DO
-   ENDIF
-! NSSL
-
-   if (diag_print .eq. 0 ) return
-
-   IF ( xtime .ne. 0. ) THEN
-
-    if(diag_print.eq.1) then
-       prfreq = dt
-!      prfreq = max(2,int(dt/60.))   ! in min
-    else
-       prfreq=10                   ! in min
-    endif
-   
-    IF (MOD(nint(dt),prfreq) == 0) THEN
-
-! COMPUTE THE NUMBER OF MASS GRID POINTS
-   no_points = float((ide-ids)*(jde-jds))
-
-! SET START AND END POINTS FOR TILES
-!  !$OMP PARALLEL DO   &
-!  !$OMP PRIVATE ( ij )
-
-   dmumax = 0.
-   DO ij = 1 , num_tiles
-
-!     print *, i_start(ij),i_end(ij),j_start(ij),j_end(ij)
-      DO j=j_start(ij),j_end(ij)
-      DO i=i_start(ij),i_end(ij)
-         dpsdt(i,j)=(p8w(i,kms,j)-pk1m(i,j))/dt
-         dmudt(i,j)=(mu_2(i,j)-mu_2m(i,j))/dt
-         if(abs(dmudt(i,j)*dt).gt.dmumax)then
-           dmumax=abs(dmudt(i,j)*dt)
-           idp=i
-           jdp=j
-         endif
-      ENDDO      
-      ENDDO
-
-   ENDDO
-!  !$OMP END PARALLEL DO
-
-! convert DMUMAX from (PA) to (bars) per time step
-   dmumax = dmumax*1.e-5
-! compute global MAX
-   CALL wrf_dm_maxval ( dmumax,  idp, jdp )
-
-!  print *, 'p8w(30,1,30),pk1m(30,30) : ', p8w(30,1,30),pk1m(30,30)
-!  print *, 'mu_2(30,30),mu_2m(30,30) : ', mu_2(30,30),mu_2m(30,30)
-   dpsdt_sum = 0.
-   dmudt_sum = 0.
-
-   DO j = jps, min(jpe,jde-1)
-     DO i = ips, min(ipe,ide-1)
-       dpsdt_sum = dpsdt_sum + abs(dpsdt(i,j))
-       dmudt_sum = dmudt_sum + abs(dmudt(i,j))
-     ENDDO
-   ENDDO
-
-! compute global sum
-   dpsdt_sum = wrf_dm_sum_real ( dpsdt_sum )
-   dmudt_sum = wrf_dm_sum_real ( dmudt_sum )
-
-!  print *, 'dpsdt, dmudt : ', dpsdt_sum, dmudt_sum
-
-   IF ( diag_print .eq. 2 ) THEN
-   dardt_sum = 0.
-   drcdt_sum = 0.
-   drndt_sum = 0.
-   rainc_sum = 0.
-   raint_sum = 0.
-   rainnc_sum = 0.
-   sfcevp_sum = 0.
-   hfx_sum = 0.
-   lh_sum = 0.
-   raincmax = 0.
-   rainncmax = 0.
-
-   DO j = jps, min(jpe,jde-1)
-     DO i = ips, min(ipe,ide-1)
-       drcdt_sum = drcdt_sum + abs(raincv(i,j))
-       drndt_sum = drndt_sum + abs(rainncv(i,j))
-       dardt_sum = dardt_sum + abs(raincv(i,j)) + abs(rainncv(i,j))
-       rainc_sum = rainc_sum + abs(rainc(i,j))
-! MAX for accumulated conv precip
-       IF(rainc(i,j).gt.raincmax)then
-          raincmax=rainc(i,j)
-          irc=i
-          jrc=j
-       ENDIF
-       rainnc_sum = rainnc_sum + abs(rainnc(i,j))
-! MAX for accumulated resolved precip
-       IF(rainnc(i,j).gt.rainncmax)then
-          rainncmax=rainnc(i,j)
-          irnc=i
-          jrnc=j
-       ENDIF
-       raint_sum = raint_sum + abs(rainc(i,j)) + abs(rainnc(i,j))
-       sfcevp_sum = sfcevp_sum + abs(sfcevp(i,j))
-       hfx_sum = hfx_sum + abs(hfx(i,j))
-       lh_sum = lh_sum + abs(lh(i,j))
-     ENDDO
-   ENDDO
-
-! compute global MAX
-   CALL wrf_dm_maxval ( raincmax, irc, jrc )
-   CALL wrf_dm_maxval ( rainncmax, irnc, jrnc )
-
-! compute global sum
-   drcdt_sum = wrf_dm_sum_real ( drcdt_sum )
-   drndt_sum = wrf_dm_sum_real ( drndt_sum )
-   dardt_sum = wrf_dm_sum_real ( dardt_sum )
-   rainc_sum = wrf_dm_sum_real ( rainc_sum )
-   rainnc_sum = wrf_dm_sum_real ( rainnc_sum )
-   raint_sum = wrf_dm_sum_real ( raint_sum )
-   sfcevp_sum = wrf_dm_sum_real ( sfcevp_sum )
-   hfx_sum = wrf_dm_sum_real ( hfx_sum )
-   lh_sum = wrf_dm_sum_real ( lh_sum )
-
-   ENDIF
-
-! print out the average values
-
-   CALL get_current_grid_name( grid_str )
-
-#ifdef DM_PARALLEL
-   IF ( wrf_dm_on_monitor() ) THEN
-#endif
-     WRITE(outstring,*) grid_str,'Domain average of dpsdt, dmudt (mb/3h): ', xtime, &
-           dpsdt_sum/no_points*108., &
-           dmudt_sum/no_points*108.
-     CALL wrf_message ( TRIM(outstring) )
-
-     WRITE(outstring,*) grid_str,'Max mu change time step: ', idp,jdp,dmumax
-     CALL wrf_message ( TRIM(outstring) )
-
-     IF ( diag_print .eq. 2) THEN
-     WRITE(outstring,*) grid_str,'Domain average of dardt, drcdt, drndt (mm/sec): ', xtime, &
-           dardt_sum/dt/no_points, &
-           drcdt_sum/dt/no_points, &
-           drndt_sum/dt/no_points
-     CALL wrf_message ( TRIM(outstring) )
-     WRITE(outstring,*) grid_str,'Domain average of rt_sum, rc_sum, rnc_sum (mm): ', xtime, &
-           raint_sum/no_points, &
-           rainc_sum/no_points, &
-           rainnc_sum/no_points
-     CALL wrf_message ( TRIM(outstring) )
-     WRITE(outstring,*) grid_str,'Max Accum Resolved Precip,   I,J  (mm): '               ,&
-           rainncmax,irnc,jrnc
-     CALL wrf_message ( TRIM(outstring) )
-     WRITE(outstring,*) grid_str,'Max Accum Convective Precip,   I,J  (mm): '             ,&
-           raincmax,irc,jrc
-     CALL wrf_message ( TRIM(outstring) )
-     WRITE(outstring,*) grid_str,'Domain average of sfcevp, hfx, lh: ', xtime, &
-           sfcevp_sum/no_points, &
-           hfx_sum/no_points, &
-           lh_sum/no_points
-     CALL wrf_message ( TRIM(outstring) )
-     ENDIF
-#ifdef DM_PARALLEL
-   ENDIF
-#endif
-
-    ENDIF        ! print frequency
-   ENDIF
-
-! save values at this time step
-   !$OMP PARALLEL DO   &
-   !$OMP PRIVATE ( ij,i,j )
-   DO ij = 1 , num_tiles
-
-      DO j=j_start(ij),j_end(ij)
-      DO i=i_start(ij),i_end(ij)
-         pk1m(i,j)=p8w(i,kms,j)
-         mu_2m(i,j)=mu_2(i,j)
-      ENDDO
-      ENDDO
-
-      IF ( xtime .lt. 0.0001 ) THEN
-      DO j=j_start(ij),j_end(ij)
-      DO i=i_start(ij),i_end(ij)
-         dpsdt(i,j)=0.
-         dmudt(i,j)=0.
-      ENDDO
-      ENDDO
-      ENDIF
-
-   ENDDO
-   !$OMP END PARALLEL DO
-
-   END SUBROUTINE diagnostic_output_calc
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-   SUBROUTINE clwrf_output_calc(                                      &
-                      ids,ide, jds,jde, kds,kde,                      &
-                      ims,ime, jms,jme, kms,kme,                      &
-                      ips,ipe, jps,jpe, kps,kpe,                      & ! patch  dims
-                      i_start,i_end,j_start,j_end,kts,kte,num_tiles   &
-                     ,dpsdt,dmudt                                     &
-                     ,p8w,pk1m,mu_2,mu_2m                             &
-                     ,u,v                                             &
-                     ,is_restart                                      & ! CLWRF
-                     ,clwrfH,t2,q2,u10,v10, skintemp                  & ! CLWRF
-                     ,t2clmin,t2clmax,tt2clmin,tt2clmax               & ! CLWRF
-                     ,t2clmean,t2clstd                                & ! CLWRF
-                     ,q2clmin,q2clmax,tq2clmin,tq2clmax               & ! CLWRF
-                     ,q2clmean,q2clstd                                & ! CLWRF
-                     ,u10clmax,v10clmax,spduv10clmax,tspduv10clmax    & ! CLWRF
-                     ,u10clmean,v10clmean,spduv10clmean               & ! CLWRF
-                     ,u10clstd,v10clstd,spduv10clstd                  & ! CLWRF
-                     ,raincclmax,rainncclmax,traincclmax,trainncclmax & ! CLWRF
-                     ,raincclmean,rainncclmean,raincclstd,rainncclstd & ! CLWRF
-                     ,skintempclmin,skintempclmax                     & ! CLWRF
-                     ,tskintempclmin,tskintempclmax                   & ! CLWRF
-                     ,skintempclmean,skintempclstd                    & ! CLWRF
-                     ,raincv,rainncv,rainc,rainnc                     &
-                     ,i_rainc,i_rainnc                                &
-                     ,hfx,sfcevp,lh                                   &
-                     ,dt,xtime,sbw                                    &
-                     ,diag_print                                      &
-                     ,bucket_mm, bucket_J                             &
-                                                                      )
-!----------------------------------------------------------------------
-
-  USE module_dm, ONLY: wrf_dm_sum_real, wrf_dm_maxval
-  USE module_configure 
-
-   IMPLICIT NONE
-!======================================================================
-! Definitions
-!-----------
-!-- DT            time step (second)
-!-- XTIME         forecast time
-!-- SBW           specified boundary width - used later
-!
-!-- P8W           3D pressure array at full eta levels
-!-- MU            dry column hydrostatic pressure
-!-- RAINC         cumulus scheme precipitation since hour 0
-!-- RAINCV        cumulus scheme precipitation in one time step (mm)
-!-- RAINNC        explicit scheme precipitation since hour 0
-!-- RAINNCV       explicit scheme precipitation in one time step (mm)
-!-- HFX           surface sensible heat flux
-!-- LH            surface latent heat flux
-!-- SFCEVP        total surface evaporation
-!-- U             u component of wind - to be used later to compute k.e.
-!-- V             v component of wind - to be used later to compute k.e.
-!
-!-- ids           start index for i in domain
-!-- ide           end index for i in domain
-!-- jds           start index for j in domain
-!-- jde           end index for j in domain
-!-- kds           start index for k in domain
-!-- kde           end index for k in domain
-!-- ims           start index for i in memory
-!-- ime           end index for i in memory
-!-- jms           start index for j in memory
-!-- jme           end index for j in memory
-!-- ips           start index for i in patch
-!-- ipe           end index for i in patch
-!-- jps           start index for j in patch
-!-- jpe           end index for j in patch
-!-- kms           start index for k in memory
-!-- kme           end index for k in memory
-!-- i_start       start indices for i in tile
-!-- i_end         end indices for i in tile
-!-- j_start       start indices for j in tile
-!-- j_end         end indices for j in tile
-!-- kts           start index for k in tile
-!-- kte           end index for k in tile
-!-- num_tiles     number of tiles
-!
-! CLWRF-UC May.09 definitions
-!-----------
-! is_restart: whether if simulation is a restart
-! clwrfH: Interval (hour) of accumulation for computations 
-! [var]cl[min/max]: [minimum/maximum] of variable [var] during interval
-! t[var]cl[min/max]: Time (minutes) of [minimum/maximum] of variable 
-!    [var] during interval 
-! [var]clmean: mean of variable [var] during interval
-! [var]clstd: standard dev. of variable [var] during interval
-!    Variables are written on aux_hist_out7 (established
-!    in Registry)
-!
-!======================================================================
-
-   INTEGER,      INTENT(IN   )                     ::            &
-                                      ids,ide, jds,jde, kds,kde, &
-                                      ims,ime, jms,jme, kms,kme, &
-                                      ips,ipe, jps,jpe, kps,kpe, &
-                                                        kts,kte, &
-                                                      num_tiles
-
-   INTEGER, DIMENSION(num_tiles), INTENT(IN)       :: i_start,   &
-                                      i_end,j_start,j_end
-
-   INTEGER,      INTENT(IN   )                     :: diag_print
-   REAL,      INTENT(IN   )                        :: bucket_mm, &
-                                      bucket_J
-
-   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                 &
-                                       INTENT(IN ) :: u,v,p8w    
-
-   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: MU_2,     & 
-                                      RAINNCV, RAINCV, HFX,      &
-                                      SFCEVP, LH, SKINTEMP 
-
-   REAL, DIMENSION( ims:ime , jms:jme ),                         &
-                                     INTENT(INOUT) :: DPSDT,     &
-                                     DMUDT, RAINNC, RAINC,       &
-                                     MU_2M, PK1M
- 
-   REAL,  INTENT(IN   )                            :: DT, XTIME
-   INTEGER,  INTENT(IN   )                         :: SBW
-   INTEGER, DIMENSION( ims:ime , jms:jme ),                      & 
-                                     INTENT(INOUT) :: I_RAINC,   &
-                                     I_RAINNC
-
-! LOCAL  VAR
-
-   INTEGER                                   :: i,j,k,its,ite,jts,jte,ij
-   INTEGER                                   :: idp,jdp,irc,jrc,irnc,jrnc,isnh,jsnh
-   INTEGER                                   :: prfreq
-
-   REAL                                      :: dpsdt_sum, dmudt_sum, dardt_sum,  & 
-                          drcdt_sum, drndt_sum
-   REAL                                      :: hfx_sum, lh_sum, sfcevp_sum,      &
-                          rainc_sum, rainnc_sum, raint_sum
-   REAL                                      :: dmumax, raincmax, rainncmax,      &
-                          snowhmax
-   REAL                                      :: xtimep
-   LOGICAL, EXTERNAL                         :: wrf_dm_on_monitor
-   CHARACTER*256                             :: outstring
-   CHARACTER*6                               :: grid_str
-
-!!-------------------
-!! CLWRF-UC Nov.09
-
-   CHARACTER (LEN=80)                        :: timestr
-
-   REAL, DIMENSION( ims:ime , jms:jme ),                                          & 
-                          INTENT(IN)         :: t2, q2, u10, v10 
-   REAL, DIMENSION( ims:ime , jms:jme ),                                          &
-                          INTENT(OUT)        :: t2clmin, t2clmax, tt2clmin,       &
-                          tt2clmax, t2clmean, t2clstd,                            & 
-                          q2clmin, q2clmax, tq2clmin, tq2clmax, q2clmean, q2clstd,&
-                          u10clmax, v10clmax, spduv10clmax, tspduv10clmax,        &
-                          u10clmean, v10clmean, spduv10clmean,                    &
-                          u10clstd, v10clstd, spduv10clstd, skintempclmin,        &
-                          skintempclmax, tskintempclmin, tskintempclmax,          &
-                          skintempclmean, skintempclstd
-   REAL, DIMENSION( ims:ime , jms:jme ),                                          &
-                          INTENT(OUT)        :: raincclmax, rainncclmax,          &
-                          traincclmax, trainncclmax, raincclmean, rainncclmean,   & 
-                          raincclstd, rainncclstd 
-   REAL, PARAMETER                           :: minimum0= 1000000.,               &
-                          maximum0= -1000000. 
-   REAL                                      :: value
-   INTEGER, INTENT(IN)                       :: clwrfH
-   CHARACTER (LEN=1024)                      :: message
-   REAL, SAVE                                :: nsteps
-   LOGICAL                                   :: is_restart
-
-!-----------------------------------------------------------------
-! Compute minutes from reference times clwrfH
-
-! Initialize [var] values
-! SET START AND END POINTS FOR TILES
-!  !$OMP PARALLEL DO   &
-!  !$OMP PRIVATE ( ij )
-
-!  IF ( MOD(NINT(XTIME), clwrfH) == 0 ) THEN
-  IF (( MOD(NINT(XTIME/dt*60.),NINT(clwrfH/dt*60.)) == 0) .AND. (.NOT.is_restart)) THEN
-    DO ij = 1 , num_tiles
-      IF  ( wrf_dm_on_monitor() ) THEN
-        WRITE(message, *)'CLWRFdiag - T2; tile: ',ij,' T2clmin:',           & 
-          t2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' T2clmax:',               &
-          t2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TT2clmin:',              &
-          tt2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TT2clmax:',              &
-          tt2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' T2clmean:',              &
-          t2clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' T2clstd:',               &
-          t2clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2)
-        CALL wrf_debug(75, message)
-        WRITE(message, *)'CLWRFdiag - Q2; tile: ',ij,' Q2clmin:',           &
-          q2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' Q2clmax:',               &
-          q2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TQ2clmin:',              &
-          tq2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TQ2clmax:',              &
-          tq2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' Q2clmean:',              &
-          q2clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' Q2clstd:',               &
-          q2clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                    &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2)
-        CALL wrf_debug(75, message)
-        WRITE(message, *)'CLWRFdiag - WINDSPEED; tile: ',ij,' U10clmax:',   &
-          u10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' V10clmax:',              &
-          v10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SPDUV10clmax:',          &
-          spduv10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,               &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TSPDUV10clmax:',         &
-          tspduv10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,              &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' U10clmean:',             &
-          u10clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,                  &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' V10clmean:',             &
-          v10clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,                  &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SPDUV10clmean:',         &
-          spduv10clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,              &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' U10clstd:',              &
-          u10clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' V10clstd:',              &
-          v10clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                   &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SPDUV10clstd:',          &
-          spduv10clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,               &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2)
-        CALL wrf_debug(75, message)
-        WRITE(message, *)'CLWRFdiag - RAIN; tile: ',ij,' RAINCclmax:',      &
-          raincclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                 &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINNCclmax:',           &
-          rainncclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TRAINCclmax:',           &
-          traincclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,                &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TRAINNCclmax:',          &
-          trainncclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,               &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINCclmean:',           &
-          raincclmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,                &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINNCclmean:',          &
-          rainncclmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,               &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINCclstd:',            &
-          raincclstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                 &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINNCclstd:',           &
-          rainncclstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,                &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2)
-        CALL wrf_debug(75, message)
-        WRITE(message,*)'CLWRFdiag - SKINTEMP; tile: ',ij,' SKINTEMPclmin:',&
-          skintempclmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,              &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SKINTEMPclmax:',         &
-          skintempclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,              &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TSKINTEMPclmin:',        &
-          tskintempclmin(i_start(ij)+(i_end(ij)-i_start(ij))/2,             &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' TSKINTEMPclmax:',        &
-          tskintempclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2,             &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SKINTEMPclmean:',        &
-          skintempclmean(i_start(ij)+(i_end(ij)-i_start(ij))/2,             &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2),' SKINTEMPclstd:',         &
-          skintempclstd(i_start(ij)+(i_end(ij)-i_start(ij))/2,              &
-          j_start(ij)+(j_end(ij)-j_start(ij))/2)
-        CALL wrf_debug(75, message)
-      ENDIF
-      DO j = j_start(ij), j_end(ij)
-        DO i = i_start(ij), i_end(ij)
-          t2clmin(i,j)=t2(i,j)
-          t2clmax(i,j)=t2(i,j)
-          t2clmean(i,j)=t2(i,j)
-          t2clstd(i,j)=t2(i,j)*t2(i,j)
-          q2clmin(i,j)=q2(i,j)
-          q2clmax(i,j)=q2(i,j)
-          q2clmean(i,j)=q2(i,j)
-          q2clstd(i,j)=q2(i,j)*q2(i,j)
-          spduv10clmax(i,j)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
-          u10clmean(i,j)=u10(i,j)
-          v10clmean(i,j)=v10(i,j)
-          spduv10clmean(i,j)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
-          u10clstd(i,j)=u10(i,j)*u10(i,j)
-          v10clstd(i,j)=v10(i,j)*v10(i,j)
-          spduv10clstd(i,j)=u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)
-          raincclmax(i,j)=raincv(i,j)/dt
-          rainncclmax(i,j)=rainncv(i,j)/dt
-          raincclmean(i,j)=raincv(i,j)/dt
-          rainncclmean(i,j)=rainncv(i,j)/dt
-          raincclstd(i,j)=(raincv(i,j)/dt)*(raincv(i,j)/dt)
-          rainncclstd(i,j)=(rainncv(i,j)/dt)*(rainncv(i,j)/dt)
-          skintempclmin(i,j)=skintemp(i,j)
-          skintempclmax(i,j)=skintemp(i,j)
-          skintempclmean(i,j)=skintemp(i,j)
-          skintempclstd(i,j)=skintemp(i,j)*skintemp(i,j)
-!          nsteps=0.
-        ENDDO
-      ENDDO
-  ENDDO
-    nsteps=clwrfH*60./dt
-  ELSE
-    xtimep = xtime + dt/60.   ! value at end of timestep for time info
-!    nsteps=nsteps+1.
-    nsteps=clwrfH*60./dt
-!      DO j = j_start(ij), j_end(ij)
-!        DO i = i_start(ij), i_end(ij)
-!     DO j = jps, jpe
-!       DO i = ips, ipe
-! Temperature
-          CALL varstatistics(t2,xtimep,ime-ims+1,jme-jms+1,t2clmin,t2clmax,   &
-            tt2clmin,tt2clmax,t2clmean,t2clstd)
-! Water vapor mixing ratio
-          CALL varstatistics(q2,xtimep,ime-ims+1,jme-jms+1,q2clmin,q2clmax,   &
-            tq2clmin,tq2clmax,q2clmean,q2clstd)
-! Wind speed
-          CALL varstatisticsWIND(u10,v10,xtimep,ime-ims+1,jme-jms+1,u10clmax, &
-            v10clmax,spduv10clmax,tspduv10clmax,u10clmean,v10clmean,         &
-            spduv10clmean,u10clstd,v10clstd,spduv10clstd)
-! Precipitation flux
-          CALL varstatisticsMAX(raincv/dt,xtimep,ime-ims+1,jme-jms+1,         &
-            raincclmax,traincclmax,raincclmean,raincclstd) 
-          CALL varstatisticsMAX(rainncv/dt,xtimep,ime-ims+1,jme-jms+1,        &
-            rainncclmax,trainncclmax,rainncclmean,rainncclstd)
-! Skin Temperature 
-          CALL varstatistics(skintemp,xtimep,ime-ims+1,jme-jms+1,skintempclmin,&
-            skintempclmax, tskintempclmin,tskintempclmax,skintempclmean,      &
-            skintempclstd)
-
-!          IF (MOD(NINT(XTIME),clwrfH) == 0) THEN
-!          IF (MOD(NINT(XTIME+dt/60.),clwrfH) == 0) THEN
-           IF ((MOD(NINT((XTIME+dt/60.)*60./dt),NINT(clwrfH*60./dt)) == 0)) THEN
-             IF  ( wrf_dm_on_monitor() ) PRINT *,'nsteps=',nsteps,' xtime:',  &
-               xtime,' clwrfH:',clwrfH 
-               t2clmean=t2clmean/nsteps
-               t2clstd=SQRT(t2clstd/nsteps-t2clmean**2.)
-               q2clmean=q2clmean/nsteps
-               q2clstd=SQRT(q2clstd/nsteps-q2clmean**2.)
-               u10clmean=u10clmean/nsteps
-               v10clmean=v10clmean/nsteps
-               spduv10clmean=spduv10clmean/nsteps
-               u10clstd=SQRT(u10clstd/nsteps-u10clmean**2.)
-               v10clstd=SQRT(v10clstd/nsteps-v10clmean**2.)
-               spduv10clstd=SQRT(spduv10clstd/nsteps-                        &
-                 spduv10clmean**2)
-               raincclmean=raincclmean/nsteps
-               rainncclmean=rainncclmean/nsteps
-               raincclstd=SQRT(raincclstd/nsteps-raincclmean**2.)
-               rainncclstd=SQRT(rainncclstd/nsteps-rainncclmean**2.)
-               skintempclmean=skintempclmean/nsteps
-              skintempclstd=SQRT(skintempclstd/nsteps-skintempclmean**2.)
-            END IF
-!        ENDDO
-!      ENDDO
-  ENDIF
-!  !$OMP END PARALLEL DO
-
-   END SUBROUTINE clwrf_output_calc
-
-! UC.CLWRF Nov.09
-SUBROUTINE varstatisticsWIND(varu, varv, tt, dx, dy, varumax, varvmax,       &
-  varuvmax, tvaruvmax, varumean, varvmean, varuvmean, varustd, varvstd,     & 
-  varuvstd) 
-! Subroutine to compute variable statistics for a wind somponents 
-
-IMPLICIT NONE
-
-INTEGER                                                        :: i, j
-INTEGER, INTENT(IN)                                            :: dx, dy
-REAL, DIMENSION(dx,dy), INTENT(IN)                             :: varu, varv
-REAL, INTENT(IN)                                               :: tt
-REAL, DIMENSION(dx,dy), INTENT(INOUT)                          :: varumax,   &
-  varvmax, varuvmax, tvaruvmax, varumean, varvmean, varuvmean, varustd,      & 
-  varvstd, varuvstd
-REAL                                                           :: varuv
-
-DO i=1,dx
-  DO j=1,dy
-    varuv=sqrt(varu(i,j)*varu(i,j)+varv(i,j)*varv(i,j))
-      IF (varuv > varuvmax(i,j)) THEN
-        varumax(i,j)=varu(i,j)
-        varvmax(i,j)=varv(i,j)
-        varuvmax(i,j)=varuv
-        tvaruvmax(i,j)=tt
-      END IF
-    varuvmean(i,j)=varuvmean(i,j)+varuv
-    varuvstd(i,j)=varuvstd(i,j)+varuv**2
-  END DO
-END DO
-varumean=varumean+varu
-varvmean=varvmean+varv
-varustd=varustd+varu**2
-varvstd=varvstd+varv**2
-
-END SUBROUTINE varstatisticsWIND
-
-SUBROUTINE varstatisticsMAX(var, tt, dx, dy, varmax, tvarmax, varmean,       &
-   varstd)
-! Subroutine to compute variable statistics for a max only variable values
-
-IMPLICIT NONE
-
-INTEGER                                                        :: i,j
-INTEGER, INTENT(IN)                                            :: dx, dy
-REAL, DIMENSION(dx,dy), INTENT(IN)                             :: var
-REAL, INTENT(IN)                                               :: tt
-REAL, DIMENSION(dx,dy), INTENT(INOUT)                          :: varmax,    &
-  tvarmax, varmean, varstd
-
-DO i=1,dx
-  DO j=1,dy
-    IF (var(i,j) > varmax(i,j)) THEN
-      varmax(i,j)=var(i,j)
-      tvarmax(i,j)=tt
-    END IF
-  END DO
-END DO
-varmean=varmean+var
-varstd=varstd+var**2
-
-END SUBROUTINE varstatisticsMAX 
-
-SUBROUTINE varstatistics(var, tt, dx, dy, varmin, varmax, tvarmin, tvarmax,  & 
-  varmean, varstd) 
-! Subroutine to compute variable statistics
-
-IMPLICIT NONE
-
-INTEGER                                                        :: i,j
-INTEGER, INTENT(IN)                                            :: dx, dy
-REAL, DIMENSION(dx,dy), INTENT(IN)                             :: var
-REAL, INTENT(IN)                                               :: tt
-REAL, DIMENSION(dx,dy), INTENT(INOUT)                          :: varmin,    &
-  varmax, tvarmin, tvarmax, varmean, varstd
-
-DO i=1,dx
-  DO j=1,dy
-    IF (var(i,j) < varmin(i,j)) THEN
-      varmin(i,j)=var(i,j)
-      tvarmin(i,j)=tt
-    END IF
-    IF (var(i,j) > varmax(i,j)) THEN
-      varmax(i,j)=var(i,j)
-      tvarmax(i,j)=tt
-    END IF
-  END DO
-END DO
-varmean=varmean+var
-varstd=varstd+var**2
-
-END SUBROUTINE varstatistics
-
-SUBROUTINE pld ( u,v,w,t,qv,zp,zb,pp,pb,p,pw,                    &
-                 msfux,msfuy,msfvx,msfvy,msftx,msfty,            &
-                 f,e,                                            &
-                 use_tot_or_hyd_p,missing,                       &
-                 num_press_levels,max_press_levels,press_levels, &
-                 p_pl,u_pl,v_pl,t_pl,rh_pl,ght_pl,s_pl,td_pl,    &
-                 ids,ide, jds,jde, kds,kde,                      &
-                 ims,ime, jms,jme, kms,kme,                      &
-                 its,ite, jts,jte, kts,kte                       )
-
-   USE module_model_constants
-
-   IMPLICIT NONE
-
-
-   !  Input variables
-
-   INTEGER, INTENT(IN   )                                          :: ids,ide, jds,jde, kds,kde, &
-                                                                      ims,ime, jms,jme, kms,kme, &
-                                                                      its,ite, jts,jte, kts,kte
-   REAL   , INTENT(IN   ) , DIMENSION(ims:ime , jms:jme)           :: msfux,msfuy,msfvx,msfvy,msftx,msfty, &
-                                                                      f,e
-   INTEGER, INTENT(IN   )                                          :: use_tot_or_hyd_p
-   REAL   , INTENT(IN   )                                          :: missing
-   REAL   , INTENT(IN   ) , DIMENSION(ims:ime , kms:kme , jms:jme) :: u,v,w,t,qv,zp,zb,pp,pb,p,pw
-   INTEGER, INTENT(IN   )                                          :: num_press_levels, max_press_levels
-   REAL   , INTENT(IN   ) , DIMENSION(max_press_levels)            :: press_levels
-
-   !  Output variables
-
-   REAL   , INTENT(  OUT) ,  DIMENSION(num_press_levels)                     :: p_pl
-   REAL   , INTENT(  OUT) ,  DIMENSION(ims:ime , num_press_levels , jms:jme) :: u_pl,v_pl,t_pl,rh_pl,ght_pl,s_pl,td_pl
-
-   !  Local variables
-
-   REAL, PARAMETER :: eps = 0.622, t_kelvin = svpt0 , s1 = 243.5, s2 = svp2 , s3 = svp1*10., s4 = 611.0, s5 = 5418.12
-
-   INTEGER :: i, j, ke, kp, ke_h, ke_f
-   REAL    :: pu, pd, pm , &
-              tu, td     , &
-              su, sd     , &
-              uu, ud     , &
-              vu, vd     , &
-              zu, zd     , &
-              qu, qd, qm , &
-              eu, ed, em , &
-              du, dd
-   REAL    :: es, qs
-
-   !  Silly, but transfer the small namelist.input array into the grid structure for output purposes.
-
-   DO kp = 1 , num_press_levels
-      p_pl(kp) = press_levels(kp)
-   END DO
-
-   !  Initialize pressure level data to un-initialized
-
-   DO j = jts , jte
-      DO kp = 1 , num_press_levels
-         DO i = its , ite
-            u_pl  (i,kp,j) = missing
-            v_pl  (i,kp,j) = missing
-            t_pl  (i,kp,j) = missing
-            rh_pl (i,kp,j) = missing
-            ght_pl(i,kp,j) = missing
-            s_pl  (i,kp,j) = missing
-            td_pl (i,kp,j) = missing
-         END DO
-      END DO
-   END DO
-
-   !  Loop over each i,j location
-
-   j_loop : DO j = jts , MIN(jte,jde-1)
-      i_loop : DO i = its , MIN(ite,ide-1)
-
-         !  For each i,j location, loop over the selected pressure levels to find
-
-         ke_h = kts
-         ke_f = kts
-         kp_loop : DO kp = 1 , num_press_levels
-
-            !  For this particular i,j and pressure level, find the eta levels that surround this point
-            !  on half-levels.
-
-            ke_loop_half : DO ke = ke_h , kte-2
-
-               IF      ( use_tot_or_hyd_p .EQ. 1 ) THEN     !  total pressure
-                  pu = pp(i,ke+1,j)+pb(i,ke+1,j)
-                  pd = pp(i,ke  ,j)+pb(i,ke  ,j)
-               ELSE IF ( use_tot_or_hyd_p .EQ. 2 ) THEN     !  hydrostatic pressure
-                  pu = p(i,ke+1,j)
-                  pd = p(i,ke  ,j)
-               END IF
-               pm = p_pl(kp)
-
-               IF ( ( pd .GE. pm ) .AND. &
-                    ( pu .LT. pm ) ) THEN
-
-                  !  Found trapping pressure: up, middle, down.  We are doing first order interpolation.  
-                  !  Now we just put in a list of diagnostics for this level.
-
-                  !  1. Temperature (K)
-
-                  tu = (t(i,ke+1,j)+t0)*(pu/p1000mb)**rcp
-                  td = (t(i,ke  ,j)+t0)*(pd/p1000mb)**rcp
-                  t_pl(i,kp,j) = ( tu * (pm-pd) + td * (pu-pm) ) / (pu-pd)
-
-                  !  2. Speed (m s-1)
-
-                  su = 0.5 * SQRT ( ( u(i,ke+1,j)+u(i+1,ke+1,j) )**2 + ( v(i,ke+1,j)+v(i,ke+1,j+1) )**2 ) 
-                  sd = 0.5 * SQRT ( ( u(i,ke  ,j)+u(i+1,ke  ,j) )**2 + ( v(i,ke  ,j)+v(i,ke  ,j+1) )**2 ) 
-                  s_pl(i,kp,j) = ( su * (pm-pd) + sd * (pu-pm) ) / (pu-pd)
-
-                  !  3. U and V (m s-1)
-
-                  uu = 0.5 *        ( u(i,ke+1,j)+u(i+1,ke+1,j) )
-                  ud = 0.5 *        ( u(i,ke  ,j)+u(i+1,ke  ,j) )
-                  u_pl(i,kp,j) = ( uu * (pm-pd) + ud * (pu-pm) ) / (pu-pd)
-
-                  vu = 0.5 *                                           ( v(i,ke+1,j)+v(i,ke+1,j+1) )
-                  vd = 0.5 *                                           ( v(i,ke  ,j)+v(i,ke  ,j+1) )
-                  v_pl(i,kp,j) = ( vu * (pm-pd) + vd * (pu-pm) ) / (pu-pd)
-
-                  !  4. Dewpoint (K) - Use Bolton's approximation
-
-                  qu = MAX(qv(i,ke+1,j),0.)
-                  qd = MAX(qv(i,ke  ,j),0.)
-                  eu = qu * pu * 0.01 / ( eps + qu )       ! water vapor pressure in mb.
-                  ed = qd * pd * 0.01 / ( eps + qd )       ! water vapor pressure in mb.
-                  eu = max(eu, 0.001)
-                  ed = max(ed, 0.001)
-
-                  du = t_kelvin + ( s1 / ((s2 / log(eu/s3)) - 1.0) )
-                  dd = t_kelvin + ( s1 / ((s2 / log(ed/s3)) - 1.0) )
-                  td_pl(i,kp,j) = ( du * (pm-pd) + dd * (pu-pm) ) / (pu-pd)
-
-                  !  5. Relative humidity (%)
-
-                  qm = ( qu * (pm-pd) + qd * (pu-pm) ) / (pu-pd)                           ! qvapor at the pressure level.
-                  es = s4 * exp(s5 * (1.0 / 273.0 - 1.0 / t_pl(i,kp,j)))
-                  qs = eps * es / (pm - es)
-                  rh_pl(i,kp,j)   = qm / qs * 100.
-
-                  !em = qm * pm * 0.01 / ( eps + qm )                                       ! water vapor pressure at the level.
-                  !es = s3 * exp( s2 * (t_pl(i,kp,j) - t_kelvin)/(t_pl(i,kp,j) - s4) )      ! sat vapor pressure over liquid water in mb.
-                  !rh_pl(i,kp,j) = 100. * em * ( pm * 0.01 - es ) / ( es * ( pm * 0.01 - em ) )
-
-                  ke_h = ke
-                  EXIT ke_loop_half
-               END IF
-            END DO ke_loop_half
-
-            ke_loop_full : DO ke = ke_f , kte-1
-               IF ( ( pw(i,ke  ,j) .GE. p_pl(kp) ) .AND. &
-                    ( pw(i,ke+1,j) .LT. p_pl(kp) ) ) THEN
-
-                  !  Found trapping pressure: up, middle, down.  We are doing first order interpolation.
-
-                  pu = LOG(pw(i,ke+1,j))
-                  pm = LOG(p_pl(kp))
-                  pd = LOG(pw(i,ke  ,j))
-
-                  !  Now we just put in a list of diagnostics for this level.
-
-                  !  1. Geopotential height (m)
-
-                  zu = ( zp(i,ke+1,j)+zb(i,ke+1,j) ) / g
-                  zd = ( zp(i,ke  ,j)+zb(i,ke  ,j) ) / g
-                  ght_pl(i,kp,j) = ( zu * (pm-pd) + zd * (pu-pm) ) / (pu-pd)
-
-                  ke_f = ke
-                  EXIT ke_loop_full
-               END IF
-            END DO ke_loop_full
-
-         END DO kp_loop
-      END DO i_loop
-   END DO j_loop
-
-   
-
-END SUBROUTINE pld
-
-
-END MODULE module_diagnostics
diff --git a/wrfv2_fire/phys/module_diagnostics_driver.F b/wrfv2_fire/phys/module_diagnostics_driver.F
new file mode 100644
index 00000000..4ad1194d
--- /dev/null
+++ b/wrfv2_fire/phys/module_diagnostics_driver.F
@@ -0,0 +1,452 @@
+#if (NMM_CORE == 1)
+MODULE module_diagnostics_driver
+CONTAINS
+   SUBROUTINE diagnostics_driver_stub
+   END SUBROUTINE diagnostics_driver_stub
+END MODULE module_diagnostics_driver
+#else
+!WRF:MODEL_LAYER:PHYSICS
+
+MODULE module_diagnostics_driver
+
+CONTAINS
+
+   !  This subroutine is the driver for the diagnostics packages.
+
+
+   SUBROUTINE diagnostics_driver ( grid, config_flags,                  &
+                                   moist, chem, tracer, scalar,         &
+                                   th_phy, pi_phy, p_phy, rho_phy,      & 
+                                   p8w, t8w, dz8w,                      &
+                                   curr_secs2,                          &
+                                   diag_flag,                           &
+                                   ids,  ide,  jds,  jde,  kds,  kde,   &
+                                   ims,  ime,  jms,  jme,  kms,  kme,   &
+                                   ips,  ipe,  jps,  jpe,  kps,  kpe,   &
+                                   imsx, imex, jmsx, jmex, kmsx, kmex,  &
+                                   ipsx, ipex, jpsx, jpex, kpsx, kpex,  &
+                                   imsy, imey, jmsy, jmey, kmsy, kmey,  &
+                                   ipsy, ipey, jpsy, jpey, kpsy, kpey   )
+
+
+      !=============================================================
+      !  USE Association for Generic WRF Infrastructure
+      !=============================================================
+
+      !  Pick up the number of members for each of the 4d arrays - for declaration purposes.
+
+      USE module_state_description, ONLY: num_moist, num_chem, num_tracer, num_scalar, &
+                                          P_QG, P_QV,                                  &
+                                          SKIP_PRESS_DIAGS
+
+      USE module_driver_constants, ONLY: max_plevs
+
+      !  From where we preferably are pulling g, Cp, etc.
+
+      USE module_model_constants, ONLY: g
+
+      !  This gives us the type definition for grid (domain) and some clock information.
+
+!     USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_subgrid
+      USE module_domain, ONLY : domain ,domain_get_current_time
+
+      !  All of the information from the namelist is in config_flags.  The
+      !  type declaration for this puppy must be available.  While each domain
+      !  has a config_flags, together they are stored in model_config_rec.
+
+      USE module_configure, ONLY : grid_config_rec_type, &
+                                   model_config_rec
+
+
+      !=============================================================
+      !  USE Association for the Diagnostic Packages
+      !=============================================================
+      
+      USE module_lightning_driver, ONLY : lightning_driver      
+      USE module_diag_misc, ONLY : diagnostic_output_calc
+      USE module_diag_cl, ONLY : clwrf_output_calc
+      USE module_diag_pld, ONLY : pld
+      USE module_diag_afwa, ONLY : afwa_diagnostics_driver
+
+
+      IMPLICIT NONE
+
+
+      !=============================================================
+      !  Subroutine Arguments
+      !=============================================================
+
+      !  Arguments passed in.  All of the diagnostics are part of the grid structure, so
+      !  even though we are not changing any of the fundamental variables, we are computing
+      !  the diagnostics.  Therefore grid is INOUT.
+
+      TYPE ( domain ), INTENT(INOUT) :: grid
+
+      !  We are not changing any of the namelist settings.
+
+      TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags
+
+      !  The 4d arrays are input only, no mods to them.
+
+      REAL , DIMENSION(ims:ime,kms:kme,jms:jme,num_moist ) , INTENT(IN) :: moist
+      REAL , DIMENSION(ims:ime,kms:kme,jms:jme,num_chem  ) , INTENT(IN) :: chem
+      REAL , DIMENSION(ims:ime,kms:kme,jms:jme,num_tracer) , INTENT(IN) :: tracer
+      REAL , DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar) , INTENT(IN) :: scalar
+
+      !  A few handy 3d arrays computed for the physics scheme: pressure (Pa) and
+      !  temperature (K), on both half (_phy) and full levels.
+
+      REAL , DIMENSION(ims:ime,kms:kme,jms:jme)            , INTENT(IN) :: th_phy  , &
+                                                                           p_phy   , &
+                                                                           pi_phy  , &
+                                                                           rho_phy , &
+                                                                           dz8w    , &
+                                                                           p8w     , &
+                                                                           t8w
+
+      !  Time (s) since the beginning of the restart.
+
+      REAL :: curr_secs2
+
+      !  Is this to be a history output time?  If so, compute the diagnostics.
+
+      LOGICAL :: diag_flag
+
+      !  The sundry dimensions required to keep a model running smoothly:
+      !     The first letter:
+      !        i: refers to the nominally west east direction, the inner-most (fastest)
+      !           incrementing index
+      !        j: refers to the nominally south north direction, the outer-most (slowest)
+      !           incrementing index
+      !        k: refers to the vertical direction form bottom to top, the second dimension
+      !           in all 3d arrays
+      !     The second letter: 
+      !        d: refers to the domain size, the geophysical extent of the entire domain,
+      !           not used in dimensions or looping, used to determine when we are close to
+      !           the edge of the boundary
+      !        m: refers to the memory size size, all 2d and 3d arrays from the Registry
+      !           (passed into here via the grid structure or the I1 variables [such as
+      !           p_phy, for example]) use these values for dimensioning
+      !        p: refers to the patch size, the extent over which computational loops run
+
+      INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde,     &
+                              ims, ime, jms, jme, kms, kme,     &
+                              ips, ipe, jps, jpe, kps, kpe
+
+      !  Hopefully unnecessary, these are the filtered dimensions.
+
+      INTEGER , INTENT(IN) :: imsx,imex,jmsx,jmex,kmsx,kmex,    &
+                              ipsx,ipex,jpsx,jpex,kpsx,kpex,    &
+                              imsy,imey,jmsy,jmey,kmsy,kmey,    &
+                              ipsy,ipey,jpsy,jpey,kpsy,kpey
+
+
+      !=============================================================
+      !  Local Variables
+      !=============================================================
+
+      !  Handy little character string for use instead of print statements.
+
+      CHARACTER (LEN=1000) :: diag_message
+
+      !  OpenMP indexing of tiles.
+
+      INTEGER :: ij
+
+      !  Vertical indexing that only goes up to the half levels.
+
+      INTEGER :: k_start, k_end
+
+
+      !=============================================================
+      !  Start of executable code
+      !=============================================================
+
+      CALL wrf_debug ( 100 , '--> TOP OF DIAGNOSTICS PACKAGE' )
+
+      !  Some routine initializations.
+
+      k_start = kps
+      k_end   = kpe-1
+
+
+
+      !  Lightning flash rate diagnostic production.
+
+      LIGHTNING: IF ( config_flags%lightning_option /= 0 ) THEN 
+         CALL wrf_debug ( 100 , '--> CALL DIAGNOSTICS PACKAGE: LIGHTNING_DRIVER' )
+         CALL lightning_driver ( &
+          ! Frequently used prognostics
+            grid%itimestep, grid%dt, grid%dx, grid%dy,         &
+            grid%xlat, grid%xlong, grid%xland, grid%ht,        &
+            grid%t_phy, p_phy, grid%rho,                       &
+            grid%u_phy, grid%v_phy, grid%w_2,                  &    
+            grid%z, moist,                                     &
+          ! Scheme specific prognostics
+            grid%ktop_deep, grid%refl_10cm,                    &
+            domain_get_current_time( grid ),                   &
+          ! Flashrate namelist inputs
+            config_flags%lightning_option,                     &
+            config_flags%lightning_dt,                         &
+            config_flags%lightning_start_seconds,              &
+            config_flags%flashrate_factor,                     &
+          ! IC:CG namelist settings
+            config_flags%iccg_method,                          &
+            config_flags%iccg_prescribed_num,                  &
+            config_flags%iccg_prescribed_den,                  &
+          ! IC:CG inputs
+            grid%iccg_in_num, grid%iccg_in_den,                &
+          ! Scheme specific namelist inputs
+            config_flags%cellcount_method,                     &
+            config_flags%cldtop_adjustment,                    &
+          ! Order dependent args for domain, mem, and tile dims 
+            ids, ide, jds, jde, kds, kde,         &
+            ims, ime, jms, jme, kms, kme,         &
+            ips, ipe, jps, jpe, kps, kpe,         &
+          ! Mandatory outputs for all quantitative schemes
+            grid%ic_flashcount, grid%ic_flashrate,          &
+            grid%cg_flashcount, grid%cg_flashrate           &
+      )    
+      END IF LIGHTNING
+
+
+
+
+      !  Mostly surface values, precip, column integrated quantities.
+
+      CALL wrf_debug ( 100 , '--> CALL DIAGNOSTICS PACKAGE: NWP DIAGNOSTICS' )
+
+      CALL diagnostic_output_calc(                                   &
+                 DPSDT=grid%dpsdt   ,DMUDT=grid%dmudt                &
+                ,P8W=p8w   ,PK1M=grid%pk1m                           &
+                ,MU_2=grid%mu_2  ,MU_2M=grid%mu_2m                   &
+                ,U=grid%u_2    ,V=grid%v_2                           &
+                ,RAINCV=grid%raincv    ,RAINNCV=grid%rainncv         &
+                ,RAINC=grid%rainc    ,RAINNC=grid%rainnc             &
+                ,I_RAINC=grid%i_rainc    ,I_RAINNC=grid%i_rainnc     &
+                ,HFX=grid%hfx   ,SFCEVP=grid%sfcevp    ,LH=grid%lh   &    
+                ,DT=grid%dt      ,SBW=config_flags%spec_bdy_width    &    
+                ,XTIME=grid%xtime   ,T2=grid%t2                      &
+           ,ACSWUPT=grid%acswupt    ,ACSWUPTC=grid%acswuptc          &
+           ,ACSWDNT=grid%acswdnt    ,ACSWDNTC=grid%acswdntc          &
+           ,ACSWUPB=grid%acswupb    ,ACSWUPBC=grid%acswupbc          &
+           ,ACSWDNB=grid%acswdnb    ,ACSWDNBC=grid%acswdnbc          &
+           ,ACLWUPT=grid%aclwupt    ,ACLWUPTC=grid%aclwuptc          &
+           ,ACLWDNT=grid%aclwdnt    ,ACLWDNTC=grid%aclwdntc          &
+           ,ACLWUPB=grid%aclwupb    ,ACLWUPBC=grid%aclwupbc          &
+           ,ACLWDNB=grid%aclwdnb    ,ACLWDNBC=grid%aclwdnbc          &
+         ,I_ACSWUPT=grid%i_acswupt  ,I_ACSWUPTC=grid%i_acswuptc      &
+         ,I_ACSWDNT=grid%i_acswdnt  ,I_ACSWDNTC=grid%i_acswdntc      &
+         ,I_ACSWUPB=grid%i_acswupb  ,I_ACSWUPBC=grid%i_acswupbc      &
+         ,I_ACSWDNB=grid%i_acswdnb  ,I_ACSWDNBC=grid%i_acswdnbc      &
+         ,I_ACLWUPT=grid%i_aclwupt  ,I_ACLWUPTC=grid%i_aclwuptc      &
+         ,I_ACLWDNT=grid%i_aclwdnt  ,I_ACLWDNTC=grid%i_aclwdntc      &
+         ,I_ACLWUPB=grid%i_aclwupb  ,I_ACLWUPBC=grid%i_aclwupbc      &
+         ,I_ACLWDNB=grid%i_aclwdnb  ,I_ACLWDNBC=grid%i_aclwdnbc      &
+      ! Selection flag 
+                ,DIAG_PRINT=config_flags%diag_print                  &
+                ,BUCKET_MM=config_flags%bucket_mm                    &
+                ,BUCKET_J =config_flags%bucket_J                     &
+                ,SNOWNCV=grid%snowncv, SNOW_ACC_NC=grid%snow_acc_nc  &    
+                ,PREC_ACC_C=grid%prec_acc_c                          &
+                ,PREC_ACC_NC=grid%prec_acc_nc                        &
+                ,PREC_ACC_DT=config_flags%prec_acc_dt                &
+                ,CURR_SECS2=curr_secs2                               &
+                ,NWP_DIAGNOSTICS=config_flags%nwp_diagnostics        &
+                ,DIAGFLAG=diag_flag                                  &
+                ,HISTORY_INTERVAL=grid%history_interval              &
+                ,ITIMESTEP=grid%itimestep                            &
+                ,U10=grid%u10,V10=grid%v10,W=grid%w_2                &
+                ,WSPD10MAX=grid%wspd10max                            &
+                ,UP_HELI_MAX=grid%up_heli_max                        &
+                ,W_UP_MAX=grid%w_up_max,W_DN_MAX=grid%w_dn_max       &
+                ,ZNW=grid%znw,W_COLMEAN=grid%w_colmean               &
+                ,NUMCOLPTS=grid%numcolpts,W_MEAN=grid%w_mean         &
+                ,GRPL_MAX=grid%grpl_max,GRPL_COLINT=grid%grpl_colint &
+                ,REFD_MAX=grid%refd_max                              &
+                ,refl_10cm=grid%refl_10cm                            &
+                ,QG_CURR=moist(ims,kms,jms,P_QG)                     &
+                ,RHO=grid%rho,PH=grid%ph_2,PHB=grid%phb,G=g          &
+      ! Dimension arguments
+                ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde   &
+                ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme   &
+                ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe   &
+                ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1)   &
+                ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1)   &
+                ,KTS=k_start, KTE=min(k_end,kde-1)                   &
+                ,NUM_TILES=grid%num_tiles                            &
+                                                                    )
+
+
+
+      !  Climate-oriented diagnostic quantities.
+
+      CLIMATE_DIAGS : IF ( config_flags%output_diagnostics == 1 ) THEN
+
+         IF ( ( config_flags%auxhist3_interval == 0 ) ) THEN
+            WRITE (diag_message , * ) &
+            "CLWRF: ERROR -- error -- ERROR -- error : NO 'auxhist3_interval' has been defined in 'namelist.input'"
+            CALL wrf_error_fatal ( diag_message )
+         END IF
+
+         CALL wrf_debug ( 100 , '--> CALL DIAGNOSTICS PACKAGE: CLIMATE DIAGNOSTICS' )
+
+         CALL clwrf_output_calc(                                           &
+                     is_restart=config_flags%restart                       &
+                    ,clwrfH=config_flags%auxhist3_interval                 &
+                    ,T2=grid%t2, Q2=grid%q2, U10=grid%u10, V10=grid%v10    &
+                    ,SKINTEMP=grid%tsk                                     &
+                    ,T2CLMIN=grid%t2min, T2CLMAX=grid%t2max                &
+                    ,TT2CLMIN=grid%tt2min, TT2CLMAX=grid%tt2max            &
+                    ,T2CLMEAN=grid%t2mean, T2CLSTD=grid%t2std              &
+                    ,Q2CLMIN=grid%q2min, Q2CLMAX=grid%q2max                &
+                    ,TQ2CLMIN=grid%tq2min, TQ2CLMAX=grid%tq2max            &
+                    ,Q2CLMEAN=grid%q2mean, Q2CLSTD=grid%q2std              &
+                    ,U10CLMAX=grid%u10max, V10CLMAX=grid%v10max            &
+                    ,SPDUV10CLMAX=grid%spduv10max                          &
+                    ,TSPDUV10CLMAX=grid%tspduv10max                        &
+                    ,U10CLMEAN=grid%u10mean, V10CLMEAN=grid%v10mean        &
+                    ,SPDUV10CLMEAN=grid%spduv10mean                        &
+                    ,U10CLSTD=grid%u10std, V10CLSTD=grid%v10std            &
+                    ,SPDUV10CLSTD=grid%spduv10std                          &
+                    ,RAINCCLMAX=grid%raincvmax                             &
+                    ,RAINNCCLMAX=grid%rainncvmax                           &
+                    ,TRAINCCLMAX=grid%traincvmax                           &
+                    ,TRAINNCCLMAX=grid%trainncvmax                         &
+                    ,RAINCCLMEAN=grid%raincvmean                           &
+                    ,RAINNCCLMEAN=grid%rainncvmean                         &
+                    ,RAINCCLSTD=grid%raincvstd                             &
+                    ,RAINNCCLSTD=grid%rainncvstd                           &
+                    ,SKINTEMPCLMIN=grid%skintempmin                        &
+                    ,SKINTEMPCLMAX=grid%skintempmax                        &
+                    ,TSKINTEMPCLMIN=grid%tskintempmin                      &
+                    ,TSKINTEMPCLMAX=grid%tskintempmax                      &
+                    ,SKINTEMPCLMEAN=grid%skintempmean                      &
+                    ,SKINTEMPCLSTD=grid%skintempstd                        &
+                    ,RAINCV=grid%raincv    ,RAINNCV=grid%rainncv           &
+                    ,DT=grid%dt                                            &
+                    ,XTIME=grid%xtime,CURR_SECS2=curr_secs2                &
+         ! Dimension arguments
+                    ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde     &
+                    ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme     &
+                    ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe     &
+                    ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1)     &
+                    ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1)     &
+                    ,KTS=k_start, KTE=k_end                                &
+                    ,NUM_TILES=grid%num_tiles                              &
+                                                                   )
+      END IF CLIMATE_DIAGS
+
+
+
+
+
+      !  Pressure level diagnostics.
+
+
+      PL_DIAGNOSTICS : IF ( config_flags%p_lev_diags .NE. SKIP_PRESS_DIAGS ) THEN
+
+      !  Process the diags if this is the correct time step OR
+      !  if this is an adaptive timestep forecast.
+
+         TIME_TO_DO_PL_DIAGS : IF ( ( ( MOD(NINT(curr_secs2+grid%dt),NINT(config_flags%p_lev_interval)) .EQ. 0 ) ) .OR. &
+               ( config_flags%use_adaptive_time_step ) ) THEN
+
+            !$OMP PARALLEL DO   &
+            !$OMP PRIVATE ( ij )
+            DO ij = 1 , grid%num_tiles
+
+               CALL wrf_debug ( 100 , '--> CALL DIAGNOSTICS PACKAGE: PRESSURE LEVEL DIAGNOSTICS' )
+
+               CALL pld (                                                   &
+               !  Input data for computing
+                       U=grid%u_2                                           &
+                      ,V=grid%v_2                                           &
+                      ,W=grid%w_2                                           &
+                      ,t=grid%t_2                                           &
+                      ,qv=moist(:,:,:,P_QV)                                 &
+                      ,zp=grid%ph_2                                         &
+                      ,zb=grid%phb                                          &
+                      ,pp=grid%p                                            &
+                      ,pb=grid%pb                                           &
+                      ,p=grid%p_hyd                                         &
+                      ,pw=grid%p_hyd_w                                      &
+               !  Map factors, coriolis for diags
+                      ,msfux=grid%msfux                                     &
+                      ,msfuy=grid%msfuy                                     &
+                      ,msfvx=grid%msfvx                                     &
+                      ,msfvy=grid%msfvy                                     &
+                      ,msftx=grid%msftx                                     &
+                      ,msfty=grid%msfty                                     &
+                      ,f=grid%f                                             &
+                      ,e=grid%e                                             &
+               !  Namelist info
+                      ,use_tot_or_hyd_p=config_flags%use_tot_or_hyd_p       &
+                      ,missing=config_flags%p_lev_missing                   &
+               !  The diagnostics, mostly output variables
+                      ,num_press_levels=config_flags%num_press_levels       &
+                      ,max_press_levels=max_plevs                           &
+                      ,press_levels=model_config_rec%press_levels           &
+                      ,p_pl  = grid%p_pl                                    &
+                      ,u_pl  = grid%u_pl                                    &
+                      ,v_pl  = grid%v_pl                                    &
+                      ,t_pl  = grid%t_pl                                    &
+                      ,rh_pl = grid%rh_pl                                   &
+                      ,ght_pl= grid%ght_pl                                  &
+                      ,s_pl  = grid%s_pl                                    &
+                      ,td_pl = grid%td_pl                                   &
+               !  Dimension arguments
+                      ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde    &
+                      ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme    &
+                      ,ITS=grid%i_start(ij),ITE=grid%i_end(ij)              &
+                      ,JTS=grid%j_start(ij),JTE=grid%j_end(ij)              &
+                      ,KTS=k_start,KTE=k_end+1                              )
+            END DO
+            !$OMP END PARALLEL DO
+         END IF TIME_TO_DO_PL_DIAGS
+      END IF PL_DIAGNOSTICS
+
+
+
+
+      !  AFWA diagnostic package.
+
+      AFWA_DIAGS : IF ( config_flags%afwa_diag_opt == 1 ) THEN
+
+         IF ( ( config_flags%auxhist2_interval == 0 ) ) THEN
+            WRITE (diag_message , * ) &
+            "Error : No 'auxhist2_interval' has been defined in 'namelist.input'"
+            CALL wrf_error_fatal ( diag_message )
+         END IF
+
+         !$OMP PARALLEL DO   &
+         !$OMP PRIVATE ( ij )
+         DO ij = 1 , grid%num_tiles
+
+            CALL wrf_debug ( 100 , '--> CALL DIAGNOSTICS PACKAGE: AFWA DIAGNOSTICS' )
+
+            CALL afwa_diagnostics_driver (   grid , config_flags              &
+                         ,moist                                               &
+                         ,scalar                                              &
+                         ,chem                                                &
+                         ,th_phy , pi_phy , p_phy                             &
+                         ,dz8w , p8w , t8w , rho_phy                          &
+                         ,ids, ide, jds, jde, kds, kde                        &
+                         ,ims, ime, jms, jme, kms, kme                        &
+                         ,ips, ipe, jps, jpe, kps, kpe                        &
+                         ,ITS=grid%i_start(ij),ITE=grid%i_end(ij)             &
+                         ,JTS=grid%j_start(ij),JTE=grid%j_end(ij)             &
+                         ,K_START=k_start,K_END=k_end                         )
+
+            END DO
+            !$OMP END PARALLEL DO
+      ENDIF AFWA_DIAGS
+
+
+
+
+
+   END SUBROUTINE diagnostics_driver
+
+END MODULE module_diagnostics_driver
+#endif
diff --git a/wrfv2_fire/phys/module_fddagd_driver.F b/wrfv2_fire/phys/module_fddagd_driver.F
index dc2a53a5..374b1459 100644
--- a/wrfv2_fire/phys/module_fddagd_driver.F
+++ b/wrfv2_fire/phys/module_fddagd_driver.F
@@ -342,11 +342,10 @@ SUBROUTINE fddagd_driver(itimestep,dt,xtime,                   &
        DO ij = 1 , num_tiles
         CALL wrf_debug(100,'in PSU FDDA scheme')
 
-           IF( config_flags%bl_pbl_physics /= 1 &
-         .AND. config_flags%bl_pbl_physics /= 5 &
-         .AND. config_flags%bl_pbl_physics /= 6 &
-         .AND. config_flags%bl_pbl_physics /= 7 &
-         .AND. config_flags%bl_pbl_physics /= 99 ) THEN
+           IF( config_flags%sf_sfclay_physics /= sfclayscheme &
+         .AND. config_flags%sf_sfclay_physics /= mynnsfcscheme &
+         .AND. config_flags%sf_sfclay_physics /= pxsfcscheme &
+         .AND. config_flags%sf_sfclay_physics /= sfclayrevscheme ) THEN
              DO j=MAX(j_start(ij)-1,jds),j_end(ij)
              DO i=MAX(i_start(ij)-1,ids),i_end(ij)
                IF( pblh(i,j) > z_at_w(i,2,j)-ht(i,j) ) THEN
diff --git a/wrfv2_fire/phys/module_fddaobs_driver.F b/wrfv2_fire/phys/module_fddaobs_driver.F
index 99709f15..46a79b91 100644
--- a/wrfv2_fire/phys/module_fddaobs_driver.F
+++ b/wrfv2_fire/phys/module_fddaobs_driver.F
@@ -229,11 +229,10 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart,         &
 
 ! Make sure regime array is set over entire grid
 ! (ajb: Copied code from fddagd)
-    IF( config_flags%bl_pbl_physics /= 1 &
-  .AND. config_flags%bl_pbl_physics /= 5 &
-  .AND. config_flags%bl_pbl_physics /= 6 &
-  .AND. config_flags%bl_pbl_physics /= 7 &
-  .AND. config_flags%bl_pbl_physics /= 99 ) THEN
+    IF( config_flags%sf_sfclay_physics /= sfclayscheme &
+  .AND. config_flags%sf_sfclay_physics /= mynnsfcscheme &
+  .AND. config_flags%sf_sfclay_physics /= pxsfcscheme &
+  .AND. config_flags%sf_sfclay_physics /= sfclayrevscheme ) THEN
       DO j = jts, jte
       DO i = its, ite
            IF( pblh(i,j) > z_at_w(i,2,j)-ht(i,j) ) THEN
@@ -374,7 +373,8 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart,         &
                   iprt_nudob,                                        &
                   ids,ide, jds,jde, kds,kde,                         & ! domain dims
                   ims,ime, jms,jme, kms,kme,                         & ! memory dims
-                  its,ite, jts,jte, kts,kte         )                  ! tile   dims
+                  its,ite, jts,jte, kts,kte,                         & ! tile   dims
+                  qvb, config_flags%obs_scl_neg_qv_innov ) ! Water vapor mixing ratio / scale negative qv innovations
 !         write(6,*) 'return from nudob: IVAR=3, J = ',j
        ENDIF
 
@@ -406,7 +406,8 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart,         &
                   iprt_nudob,                                        &
                   ids,ide, jds,jde, kds,kde,                         & ! domain dims
                   ims,ime, jms,jme, kms,kme,                         & ! memory dims
-                  its,ite, jts,jte, kts,kte         )                  ! tile   dims
+                  its,ite, jts,jte, kts,kte,                         & ! tile   dims
+                  qvb, config_flags%obs_scl_neg_qv_innov ) ! Water vapor mixing ratio / scale negative qv innovations
 !         write(6,*) 'return from nudob: IVAR=4, J = ',j
        ENDIF
      ENDIF
@@ -439,7 +440,8 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart,         &
                 iprt_nudob,                                          &
                 ids,ide, jds,jde, kds,kde,                           & ! domain dims
                 ims,ime, jms,jme, kms,kme,                           & ! memory dims
-                its,ite, jts,jte, kts,kte         )                    ! tile   dims
+                its,ite, jts,jte, kts,kte,                           & ! tile   dims
+                qvb, config_flags%obs_scl_neg_qv_innov ) ! Water vapor mixing ratio / scale negative qv innovations
 !       write(6,*) 'return from nudob: IVAR=1, J = ',j
 
 !       write(6,*) 'calling nudob: IVAR=2, J = ',j
@@ -468,7 +470,8 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart,         &
                 iprt_nudob,                                          &
                 ids,ide, jds,jde, kds,kde,                           & ! domain dims
                 ims,ime, jms,jme, kms,kme,                           & ! memory dims
-                its,ite, jts,jte, kts,kte         )                    ! tile   dims
+                its,ite, jts,jte, kts,kte,                           & ! tile   dims
+                qvb, config_flags%obs_scl_neg_qv_innov ) ! Water vapor mixing ratio / scale negative qv innovations
 !       write(6,*) 'return from nudob: IVAR=2, J = ',j
      ENDIF
   ENDDO
diff --git a/wrfv2_fire/phys/module_fddaobs_rtfdda.F b/wrfv2_fire/phys/module_fddaobs_rtfdda.F
index a242981e..b7ffd364 100644
--- a/wrfv2_fire/phys/module_fddaobs_rtfdda.F
+++ b/wrfv2_fire/phys/module_fddaobs_rtfdda.F
@@ -567,6 +567,7 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp,  &
 !         7                    Model surface press at obs loc (U-points)
 !         8                    Model surface press at obs loc (V-points)
 !         9                    RKO at U-points
+!         10                   Model Q at obs loc (T-points)
 
 !-----------------------------------------------------------------------
 !
@@ -1293,6 +1294,19 @@ SUBROUTINE errob(inest, ub, vb, tb, t0, qvb, pbase, pp, rovcp,  &
                       )*QVB(IOB,KOBP,JOB+1)+DxOB*                       &
                       QVB(IOB+1,KOBP,JOB+1))))
 
+!           Store model moisture value (not the error!) at the location
+!           that the error was calculated
+            ERRF(10,N)=ERRF(10,N)+((1.-DZOB)*((1.-DyOB)*((1.- &
+                      DxOB)*QVB(IOB,KOB,JOB)+DxOB*                      &
+                      QVB(IOB+1,KOB,JOB))+DyOB*((1.-DxOB)*              &
+                      QVB(IOB,KOB,JOB+1)+DxOB*                          &
+                      QVB(IOB+1,KOB,JOB+1)))+DZOB*((1.-                 &
+                      DyOB)*((1.-DxOB)*QVB(IOB,KOBP,JOB)+DxOB           &
+                      *QVB(IOB+1,KOBP,JOB))+DyOB*((1.-DxOB              &
+                      )*QVB(IOB,KOBP,JOB+1)+DxOB*                       &
+                      QVB(IOB+1,KOBP,JOB+1))))
+
+
 !           Store model surface pressure (not the error!) at T-point
             ERRF(6,N)= .001*                                            &
                       ((1.-DyOB)*((1.-DxOB)*pbase(IOB,1,JOB)+DxOB*      &
@@ -1522,7 +1536,8 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
                        iprt,                                          &
                        ids,ide, jds,jde, kds,kde,                     &  ! domain dims
                        ims,ime, jms,jme, kms,kme,                     &  ! memory dims
-                       its,ite, jts,jte, kts,kte )                       ! tile   dims
+                       its,ite, jts,jte, kts,kte,                     &  ! tile   dims
+                       qvb, obs_scl_neg_qv_innov ) ! Water vapor mixing ratio / scale negative qv innovations
 
 !-----------------------------------------------------------------------
   USE module_model_constants
@@ -1648,8 +1663,14 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
   REAL, INTENT(IN)     :: terrh(ims:ime) ! Terrain height (m)
 ! INTEGER, INTENT(IN)  :: vik1(its:ite) ! Vertical infl k-level for full wts
 ! INTEGER, INTENT(IN)  :: vik2(its:ite) ! Vertical infl k-level for ramp
-  REAL, INTENT(IN)     :: zslab(ims:ime, kms:kme)    ! model ht above ground (m)
+  REAL, INTENT(IN)     :: zslab(ims:ime, kms:kme)    ! model ht above sea level (m)
   LOGICAL, INTENT(IN)  :: iprt                       ! print flag
+  REAL                 :: abs_pdiff_below, abs_pdiff_above
+  REAL,   INTENT(IN)   :: qvb( ims:ime, kms:kme, jms:jme ) ! Water vapor mixing ratio (QV)
+  INTEGER, INTENT(IN)  :: obs_scl_neg_qv_innov ! User choice on whether negative qv innovations should be scaled
+  REAL                 :: qvb_at_cur_loc, qvb_at_ob_loc ! QV at the current model or the observation location
+  REAL                 :: SCALE_FACTOR_NEG_QV_INNOV ! Multiply QV innovation by this factor to avoid nudging toward negative QV
+  REAL                 :: QVB_CUR_LOC_OVER_OB_LOC ! Ratio of QV at current model location compared to ob location
 
 ! Local variables
   integer :: mm(maxdom)
@@ -1926,6 +1947,7 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
           RX=RJ-RB(N)
 ! WEIGHTS FOR THE 3-D VARIABLES
           ERFIVR=ERRF(IVAR,N)
+          QVB_AT_OB_LOC=ERRF(10,N)
  
 !ajb Compute and add weights to sum only if nudge_pbl switch is on.
           if(nudge_pbl) then
@@ -1981,8 +2003,42 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
                   wtsig(k)=float(komax-k+1)/dk
                   WT(I,K)=WT(I,K)+TIMEWT*WTSIG(K)*WTIJ(i)
 
+                  !See Reen et al. poster/extended abstract (P13) from 2013 WRF
+                  !User's Workshop regarding the following moisture innovation 
+                  !scaling code.
+                  !If dealing with moisture and user chose to scale certain
+                  !negative QV innovations
+                  IF((IVAR.EQ.4).AND.(obs_scl_neg_qv_innov.gt.0)) THEN
+                   QVB_AT_CUR_LOC = MAX(QVB(I,K,J),0.0)
+                   !If the moisture innovation is negative and the model moisture
+                   ! is less at the current location where we are about to apply 
+                   ! the innovation than at the location where the ob was taken
+                   IF((ERFIVR.LT.0).AND.(QVB_AT_CUR_LOC.LT.QVB_AT_OB_LOC)) THEN
+                    !The ratio of the model moisture at the current location 
+                    ! compared to the ob location will be used to scale the
+                    !  innovation.
+                    QVB_CUR_LOC_OVER_OB_LOC = QVB_AT_CUR_LOC/QVB_AT_OB_LOC
+                    IF(obs_scl_neg_qv_innov.eq.1) THEN
+                     !Limit the innovation such that it cannot nudge towards a
+                     !negative value
+                     SCALE_FACTOR_NEG_QV_INNOV = MIN(1.0,ABS(QVB_AT_CUR_LOC/ERFIVR))
+                    ELSE
+                     !If the user chose a value for obs_scl_neg_qv_innov that
+                     !this code is unaware of, stop WRF
+                     IF (iprt) then
+                      write(msg,*) 'Unknown value of obs_scl_neg_qv_innov = ',obs_scl_neg_qv_innov
+                      call wrf_message(msg)
+                     ENDIF
+                     call wrf_error_fatal ( 'module_fddaobs_rtfdda: nudob: Unknown value of obs_scl_neg_qv_innov' )
+                    ENDIF
+                    !Scale the innovation
+                    ERFIVR = ERFIVR*SCALE_FACTOR_NEG_QV_INNOV
+                   ENDIF
+
+                  ENDIF
                   WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ(i)*WTIJ(i)*WTSIG(K)    &
                               *WTSIG(K)*ERFIVR
+
                 enddo
               ENDDO
 
@@ -2024,7 +2080,43 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
 
                   if(wtsig(k).le.0.0) EXIT LML
                     WT(I,K)=WT(I,K)+TIMEWT*WTSIG(K)*WTIJ(i)
-                    WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ(i)*WTIJ(i)*WTSIG(K)    &
+
+                   !See Reen et al. poster/extended abstract (P13) from 2013 WRF
+                   !User's Workshop regarding the following moisture innovation
+                   !If dealing with moisture and user chose to scale certain
+                   !negative QV innovations
+                   IF((IVAR.EQ.4).AND.(obs_scl_neg_qv_innov.gt.0)) THEN
+                    QVB_AT_CUR_LOC = MAX(QVB(I,K,J),0.0)
+                    !If the moisture innovation is negative and the model
+                    !moisture
+                    ! is less at the current location where we are about to apply
+                    ! the innovation than at the location where the ob was taken
+                    IF((ERFIVR.LT.0).AND.(QVB_AT_CUR_LOC.LT.QVB_AT_OB_LOC)) THEN
+                     !The ratio of the model moisture at the current location
+                     ! compared to the ob location will be used to scale the
+                     !  innovation.
+                     QVB_CUR_LOC_OVER_OB_LOC = QVB_AT_CUR_LOC/QVB_AT_OB_LOC
+                     IF(obs_scl_neg_qv_innov.eq.1) THEN
+                      !Limit the innovation such that it cannot nudge towards a
+                      !negative value
+                      SCALE_FACTOR_NEG_QV_INNOV = MIN(1.0,ABS(QVB_AT_CUR_LOC/ERFIVR))
+                     ELSE
+                      !If the user chose a value for obs_scl_neg_qv_innov that
+                      !this code is unaware of, stop WRF
+                      IF (iprt) then
+                       write(msg,*) 'Unknown value of obs_scl_neg_qv_innov = ',obs_scl_neg_qv_innov
+                       call wrf_message(msg)
+                      ENDIF
+                      call wrf_error_fatal ( 'module_fddaobs_rtfdda: nudob: Unknown value of obs_scl_neg_qv_innov' )
+                     ENDIF
+                     !Scale the innovation
+                     ERFIVR = ERFIVR*SCALE_FACTOR_NEG_QV_INNOV
+
+                    ENDIF
+                   ENDIF
+
+
+                   WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ(i)*WTIJ(i)*WTSIG(K)    &
                                 *WTSIG(K)*ERFIVR
                   enddo LML
               ENDDO
@@ -2102,6 +2194,8 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
 ! WEIGHTS FOR THE 3-D VARIABLES
 !
           ERFIVR=ERRF(IVAR,N)
+! Model QV at the observation location
+          QVB_AT_OB_LOC=ERRF(10,N)
 ! jc
           nsndlev=int(nlevs_ob(n)-lev_in_ob(n))+1
 ! yliu start
@@ -2209,6 +2303,39 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
 ! Now calculate WT and WT2ERR for each i,j,k point                      cajb
                   WT(I,K)=WT(I,K)+TIMEWT*WTIJ(i)*wtsig(k)
 
+
+                  !See Reen et al. poster/extended abstract (P13) from 2013 WRF
+                  !User's Workshop regarding the following moisture innovation
+                  !scaling code.
+                  !If dealing with moisture and user chose to scale certain
+                  !negative QV innovations
+                  IF((IVAR.EQ.4).AND.(obs_scl_neg_qv_innov.GT.0)) THEN
+                   QVB_AT_CUR_LOC = MAX(QVB(I,K,J),0.0)
+                   !If the moisture innovation is negative and the model moisture
+                   ! is less at the current location where we are about to apply
+                   ! the innovation than at the location where the ob was taken
+                   IF((ERFIVR.LT.0).AND.(QVB_AT_CUR_LOC.LT.QVB_AT_OB_LOC)) THEN
+                    !The ratio of the model moisture at the current location
+                    ! compared to the ob location will be used to scale the
+                    !  innovation.
+                    QVB_CUR_LOC_OVER_OB_LOC = QVB_AT_CUR_LOC/QVB_AT_OB_LOC
+                    IF(obs_scl_neg_qv_innov.eq.1) THEN
+                     !Limit the innovation such that it cannot nudge towards a
+                     !negative value
+                     SCALE_FACTOR_NEG_QV_INNOV = MIN(1.0,ABS(QVB_AT_CUR_LOC/ERFIVR))
+                    ELSE
+                     !If the user chose an value for obs_scl_neg_qv_innov that
+                     !this code is unaware of, stop WRF
+                     IF (iprt) then
+                      write(msg,*) 'Unknown value of obs_scl_neg_qv_innov = ',obs_scl_neg_qv_innov
+                      call wrf_message(msg)
+                     ENDIF
+                     call wrf_error_fatal ( 'module_fddaobs_rtfdda: nudob: Unknown value of obs_scl_neg_qv_innov' )
+                    ENDIF
+                    reserf(k) = reserf(k)*SCALE_FACTOR_NEG_QV_INNOV
+                   ENDIF
+                  ENDIF
+
                   WT2ERR(I,K)=WT2ERR(I,K)+TIMEWT*TIMEWT*WTIJ(i)*WTIJ(i)*        &
                               reserf(k)*wtsig(k)*wtsig(k)
                 enddo
@@ -2280,6 +2407,10 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
                 WTIJ(i)=(RIS-RSQ)/(RIS+RSQ)      
                 WTIJ(i)=AMAX1(0.0,WTIJ(i))
 ! yliu end
+! Set the pressure difference between the current model level and
+! both the level above and below to a number larger than the maximum (BPR)
+               abs_pdiff_above = maxsnd_gap+1.0
+               abs_pdiff_below = maxsnd_gap+1.0
 
 ! this loop goes to 1503
                 do nn=2,nsndlev
@@ -2291,14 +2422,19 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
                   .and. varobs(5,n+nn-1).gt.-800000.) then
                     pobhi=varobs(5,n+nn-1)
                     nhi=n+nn-1
-                    if(pobhi.lt.pijk .and. abs(pobhi-pijk).lt.0.5*maxsnd_gap) then
-                      go to 1502        ! within maxsnd_gap/2 of obs height
+! Check if current level in the innovation is above the current
+! model level but within maxsnd_gap (BPR)
+                    abs_pdiff_above=abs(pobhi-pijk)
+                    if(pobhi.le.pijk .and. abs_pdiff_above.le.maxsnd_gap) then
+                      go to 1502        ! within maxsnd_gap of obs height
                     endif
                   endif
 
                 enddo
 
-! did not find any ob above within maxsnd_gap/2, so jump out 
+! OLD: did not find any ob above within maxsnd_gap/2, so jump out
+! NEW: did not find any ob above within maxsnd_gap, so jump out
+
                 go to 1501
  1502           continue
 
@@ -2308,21 +2444,85 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
                   .and. varobs(5,nnjc).gt.-800000.) then
                     poblo=varobs(5,nnjc)
                     nlo=nnjc
-                    if(poblo.gt.pijk .and. abs(poblo-pijk).lt.0.5*maxsnd_gap) then
-                      go to 1505        ! within maxsnd_gap/2 of obs height
+! Check if current level in the innovation is below the current
+! model level but within maxsnd_gap (BPR)
+                    abs_pdiff_below=abs(poblo-pijk)
+                    if(poblo.ge.pijk .and. abs_pdiff_below.le.maxsnd_gap) then
+                      go to 1505        ! within maxsnd_gap of obs height
                     endif
                   endif
                 enddo
 !yliu end --
 
-! did not find any ob below within maxsnd_gap/2, so jump out 
+! OLD: did not find any ob below within maxsnd_gap/2, so jump out
+! NEW: did not find any ob below within maxsnd_gap, so jump out
+
                 go to 1501
  1505           continue
+!BPR BEGIN
+! Ensure that sum of gap between model level and the closest
+! innovation level above that combined with the sum of the gap
+! between the model level and the closest innovation level below
+! that is less than or equal to the maximum allowed gap
+                if((abs_pdiff_below+abs_pdiff_above).gt.maxsnd_gap) then
+                 goto 1501
+                endif
 
 ! interpolate to model level
-                pdiffj=alog(pijk/poblo)/alog(pobhi/poblo)
+! Avoid potential division by zero (or near-zero) that may now
+! occur when the model pressure exactly matches the pressure of
+! one of the levels in the innovation profile.
+! Note that these variables are in terms of cb so we are assuming that
+! if the closest innovation level below the model level is within
+! 0.00001 hPa of the the closest innovation level above the model
+! level then those two levels are identical. (BPR)
+                IF(abs(pobhi-poblo).lt.0.000001) THEN
+                 pdiffj=0
+                ELSE
+                 !Original code just used following statement
+                 pdiffj=alog(pijk/poblo)/alog(pobhi/poblo)
+                ENDIF
+
                 reserf(k)=errf(ivar,nlo)+                               &
                             (errf(ivar,nhi)-errf(ivar,nlo))*pdiffj
+
+                !See Reen et al. poster/extended abstract (P13) from 2013 WRF
+                !User's Workshop regarding the following moisture innovation
+                !scaling code.
+                !If dealing with moisture and user chose to scale certain
+                !negative QV innovations
+                IF((IVAR.EQ.4).AND.(obs_scl_neg_qv_innov.GT.0)) THEN
+                 QVB_AT_CUR_LOC = QVB(I,K,J)
+                 !Vertically intepolate observed moisture
+                 QVB_AT_OB_LOC=errf(10,nlo)+                               &
+                              (errf(10,nhi)-errf(10,nlo))*pdiffj
+                 !If the moisture innovation is negative and the model
+                 !moisture
+                 ! is less at the current location where we are about to apply
+                 ! the innovation than at the location where the ob was taken
+                 IF((reserf(k).LT.0).AND.(QVB_AT_CUR_LOC.LT.QVB_AT_OB_LOC)) THEN
+                  !The ratio of the model moisture at the current location
+                  ! compared to the ob location will be used to scale the
+                  !  innovation.
+                  QVB_CUR_LOC_OVER_OB_LOC = QVB_AT_CUR_LOC/QVB_AT_OB_LOC
+                  IF(obs_scl_neg_qv_innov.eq.1) THEN
+                   !Limit the innovation such that it cannot nudge towards a
+                   !negative value
+                   SCALE_FACTOR_NEG_QV_INNOV = MIN(1.0,ABS(QVB_AT_CUR_LOC/reserf(k)))
+                  ELSE
+                   !If the user chose a value for obs_scl_neg_qv_innov that
+                   !this code is unaware of, stop WRF
+                   IF (iprt) then
+                    write(msg,*) 'Unknown value of obs_scl_neg_qv_innov = ',obs_scl_neg_qv_innov
+                    call wrf_message(msg)
+                   ENDIF
+                   call wrf_error_fatal ( 'module_fddaobs_rtfdda: nudob: Unknown value of obs_scl_neg_qv_innov' )
+                  ENDIF
+                  reserf(k) = reserf(k)*SCALE_FACTOR_NEG_QV_INNOV
+                 ENDIF
+
+                ENDIF
+
                 wtsig(k)=1.
   
  1501           continue
diff --git a/wrfv2_fire/phys/module_ltng_crmpr92.F b/wrfv2_fire/phys/module_ltng_crmpr92.F
index 435dd129..83ffafdb 100644
--- a/wrfv2_fire/phys/module_ltng_crmpr92.F
+++ b/wrfv2_fire/phys/module_ltng_crmpr92.F
@@ -183,7 +183,7 @@ SUBROUTINE ltng_crmpr92z ( &
  count = 0
  DO i=ips,ipe
    DO j=jps,jpe
-     IF ( (refl(i,k,j) .gt. reflthreshold) .and. (t(i,k,j) .gt. 273.15) ) THEN
+     IF ( (refl(i,k,j) .gt. reflthreshold) .and. (t(i,k,j) .lt. 273.15) ) THEN
        IF (z(i,k,j)-ht(i,j) .gt. zmax) THEN
          zmax = z(i,k,j)-ht(i,j)
        ENDIF
@@ -194,7 +194,9 @@ SUBROUTINE ltng_crmpr92z ( &
  ENDDO
  mostlyland = mostlyland/count
 
- zmax = zmax * 1E3
+ zmax = zmax * 1.e-3
+ WRITE(message, * ) ' ltng_crmpr92z: reflectivity cloud top height: ', zmax
+ CALL wrf_debug ( 15, message )
 
  if ( cellcount_method .eq. 2 ) THEN
    zmax = wrf_dm_max_real(zmax)
diff --git a/wrfv2_fire/phys/module_microphysics_driver.F b/wrfv2_fire/phys/module_microphysics_driver.F
index 037ac64f..af034503 100644
--- a/wrfv2_fire/phys/module_microphysics_driver.F
+++ b/wrfv2_fire/phys/module_microphysics_driver.F
@@ -26,8 +26,9 @@ SUBROUTINE microphysics_driver(                                          &
                       !Variables required for CAMMGMP Scheme
                       ,dlf,dlf2,t_phy,p_hyd,p8w_hyd,tke_pbl,z_at_w,qfx   &
                       ,rliq,turbtype3d,smaw3d,wsedl3d,cldfra_old_mp      &
-                      ,cldfra_mp,cldfra_mp_all,cldfrai,cldfral,cldfra_conv&
-                      ,alt       &
+                      ,cldfra_mp,cldfra_mp_all,lradius,iradius           &
+                      ,cldfrai,cldfral,cldfra_conv                       &
+                      ,alt                                               &
                       ,accum_mode,aitken_mode,coarse_mode                &
                       ,icwmrsh3d,icwmrdp3d,shfrc3d,cmfmc3d,cmfmc2_3d     &
                       ,config_flags,fnm,fnp,rh_old_mp,lcd_old_mp         &
@@ -38,20 +39,30 @@ SUBROUTINE microphysics_driver(                                          &
 #endif
 !======================                                   
                       ,qv_curr,qc_curr,qr_curr,qi_curr,qs_curr,qg_curr   &
+                      ,qic_curr,qip_curr,qid_curr &
+                      ,qnic_curr,qnip_curr,qnid_curr &
                       ,qndrop_curr,qni_curr,qh_curr,qnh_curr             &
                       ,qzr_curr,qzi_curr,qzs_curr,qzg_curr,qzh_curr      &
                       ,qns_curr,qnr_curr,qng_curr,qnn_curr,qnc_curr      &
+                      ,qnwfa_curr,qnifa_curr                             & ! for water/ice-friendly aerosols
+                      ,f_qnwfa,f_qnifa                                   & ! for water/ice-friendly aerosols
                       ,qvolg_curr                                        &
+                      ,effr_curr,ice_effr_curr,tot_effr_curr             &
+                       ,qic_effr_curr,qip_effr_curr,qid_effr_curr        &             
                       ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni      &
                       ,f_qns,f_qnr,f_qng,f_qnc,f_qnn,f_qh,f_qnh          &
                       ,            f_qzr,f_qzi,f_qzs,f_qzg,f_qzh         &
                       ,f_qvolg                                           &
+                      ,f_qic,f_qip,f_qid &
+                      ,f_qnic,f_qnip,f_qnid &
+                      ,f_effr,f_ice_effr,f_tot_effr                      &
+                      ,f_qic_effr,f_qip_effr,f_qid_effr                  &                 
                       ,qrcuten, qscuten, qicuten, mu                     &
                       ,qt_curr,f_qt                                      &
                       ,mp_restart_state,tbpvs_state,tbpvs0_state         & ! for etampnew or etampold
                       ,hail,ice2                                         & ! for mp_gsfcgce
 !                     ,ccntype                                           & ! for mp_milbrandt2mom
-                      ,w ,z                                              &
+                      ,u,v,w,z                                          &   
                       ,rainnc,    rainncv                                &
                       ,snownc,    snowncv                                &
                       ,hailnc,    hailncv                                &
@@ -60,26 +71,40 @@ SUBROUTINE microphysics_driver(                                          &
                       ,rainprod, evapprod                                &
                       ,qv_b4mp, qc_b4mp, qi_b4mp, qs_b4mp                &
 #endif
+                      ,qnwfa2d                                           & ! for water/ice-friendly aerosols
                       ,refl_10cm                                         & ! HM, 9/22/09, add for refl
 ! YLIN
 ! Added the RI_CURR array to the call
                       ,ri_curr                                           &
                       ,diagflag,   do_radar_ref                          &
+                      ,re_cloud, re_ice, re_snow                         & ! G. Thompson
+                      ,has_reqc, has_reqi, has_reqs                      & ! G. Thompson
+                      ,scalar,num_scalar                                   &
+                      ,kext_ql,kext_qs,kext_qg            &
+                      ,kext_qh,kext_qa                         &
+                      ,kext_qic,kext_qid,kext_qip         &
+                      ,kext_ft_qic,kext_ft_qid,kext_ft_qip         &
+                      ,kext_ft_qs,kext_ft_qg            &
+                      ,height,tempc &
+                      ,TH_OLD                                            &
+                      ,QV_OLD                                            &
+                      ,xlat,xlong,ivgtyp                                  &
+
                                                    )
 ! Framework
 #if(NMM_CORE==1)
    USE module_state_description, ONLY :                                  &
                      KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME    &
-                    ,WSM6SCHEME, ETAMPNEW, ETAMPOLD, etamp_HWRF,THOMPSON, MORR_TWO_MOMENT     &
+                    ,WSM6SCHEME, ETAMPNEW, ETAMPOLD, etamp_HWRF,THOMPSON, THOMPSONAERO, MORR_TWO_MOMENT     &
                     ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME &
                     ,MILBRANDT2MOM !,MILBRANDT3MOM 
 #else
    USE module_state_description, ONLY :                                  &
                      KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME    &
-                    ,WSM6SCHEME, ETAMPNEW, ETAMPOLD, THOMPSON, MORR_TWO_MOMENT     &
+                    ,WSM6SCHEME, ETAMPNEW, ETAMPOLD, THOMPSON, THOMPSONAERO, FAST_KHAIN_LYNN, MORR_TWO_MOMENT     &
                     ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN  &
                     ,NSSL_1MOM,NSSL_1MOMLFO & ! ,NSSL_3MOM       &
-                    ,MILBRANDT2MOM , CAMMGMPSCHEME  !,MILBRANDT3MOM
+                    ,MILBRANDT2MOM , CAMMGMPSCHEME,FULL_KHAIN_LYNN  !,MILBRANDT3MOM
 #endif
 
 ! Model Layer
@@ -87,7 +112,8 @@ SUBROUTINE microphysics_driver(                                          &
    USE module_wrf_error
    USE module_configure, only: grid_config_rec_type
 #ifdef WRF_CHEM   
-   USE module_state_description, only: num_chem                 ! For CAMMGMP scheme Prognostic aerosols
+!mchen   USE module_state_description, only: num_scalar               ! For CAMMGMP scheme Prognostic aerosols
+   USE module_state_description, only: num_chem               ! mchen 
    USE modal_aero_data, only:  ntot_amode_cam_mam => ntot_amode ! For CAMMGMP scheme Prognostic aerosols
 #endif
 
@@ -102,6 +128,8 @@ SUBROUTINE microphysics_driver(                                          &
    USE module_mp_etanew
    USE module_mp_etaold
    USE module_mp_thompson
+   USE module_mp_full_sbm
+   USE module_mp_fast_sbm
    USE module_mp_gsfcgce
    USE module_mp_morr_two_moment
    USE module_mp_wdm5
@@ -285,7 +313,7 @@ SUBROUTINE microphysics_driver(                                          &
    INTEGER, OPTIONAL, INTENT(IN   )    :: hail, ice2 !, ccntype
 !
    INTEGER,      INTENT(IN   )    ::       ids,ide, jds,jde, kds,kde
-   INTEGER,      INTENT(IN   )    ::       ims,ime, jms,jme, kms,kme
+   INTEGER,      INTENT(IN   )    ::       ims,ime, jms,jme, kms,kme,num_scalar
    INTEGER, OPTIONAL, INTENT(IN   )    ::       ips,ipe, jps,jpe, kps,kpe
    INTEGER,      INTENT(IN   )    ::                         kts,kte
    INTEGER,      INTENT(IN   )    ::     itimestep,num_tiles,spec_zone
@@ -306,6 +334,11 @@ SUBROUTINE microphysics_driver(                                          &
                                                                  p8w, &
                                                               pi_phy, &
                                                                    p
+    REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),INTENT(INOUT), OPTIONAL :: th_old,qv_old
+    REAL,DIMENSION(ims:ime,kms:kme,jms:jme,num_scalar),INTENT(INOUT), OPTIONAL   :: scalar
+    INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN), OPTIONAL::   IVGTYP
+    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN), OPTIONAL    :: XLAT, XLONG
+
 !=================
 !Data for CAMMGMP scheme
    REAL,INTENT(IN), OPTIONAL ::accum_mode,aitken_mode,coarse_mode  
@@ -359,11 +392,13 @@ SUBROUTINE microphysics_driver(                                          &
 !outs
 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                        &
       INTENT(INOUT) , OPTIONAL::                                                 &
-                                                            wsedl3d, &        !Sedimentation velocity of stratiform liquid cloud droplet (m/s) 
+                                                            wsedl3d, &    !Sedimentation velocity of stratiform liquid cloud droplet (m/s) 
                                                           cldfra_mp, &    !Old Cloud fraction for CAMMGMP microphysics only
                                                       cldfra_mp_all, &    !Old Cloud fraction for CAMMGMP microphysics only
                                                             cldfrai, &    !Old Cloud fraction for CAMMGMP microphysics only
-                                                            cldfral, &       !Old Cloud fraction for CAMMGMP microphysics only
+                                                            cldfral, &    !Old Cloud fraction for CAMMGMP microphysics only
+                                                            lradius, &    !Old Cloud fraction for CAMMGMP microphysics only
+                                                            iradius, &    !Old Cloud fraction for CAMMGMP microphysics only                                                            
                                                         cldfra_conv 
 
 #ifdef WRF_CHEM
@@ -407,17 +442,30 @@ SUBROUTINE microphysics_driver(                                          &
 
    LOGICAL,  OPTIONAL,   INTENT(IN   )    :: channel_switch
    REAL, OPTIONAL,  INTENT(INOUT   ) :: naer  ! aerosol number concentration (/kg)
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) , OPTIONAL :: qnwfa2d      ! Added by G. Thompson
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
          OPTIONAL,                                                &
          INTENT(INOUT ) ::                                        &
-                  w, z, t8w                                       &
+                  u,v,w, z, t8w                                       &
                  ,cldfra, cldfra_old, exch_h                      &
                  ,qv_curr,qc_curr,qr_curr,qi_curr,qs_curr,qg_curr &
                  ,qt_curr,qndrop_curr,qni_curr,qh_curr,qnh_curr   &
                  ,qns_curr,qnr_curr,qng_curr,qnn_curr,qnc_curr    &
+                 ,qic_curr,qip_curr,qid_curr &
+                 ,qnic_curr,qnip_curr,qnid_curr &
                  ,qzr_curr,qzi_curr,qzs_curr,qzg_curr,qzh_curr    &
+                 ,effr_curr,ice_effr_curr,tot_effr_curr           &
+                 ,qic_effr_curr,qip_effr_curr,qid_effr_curr           &
+                  ,kext_ql,kext_qs,kext_qg          &
+                 ,kext_qh,kext_qa                       &
+                 ,kext_qic,kext_qip,kext_qid,tempc,height      &
+                 ,kext_ft_qic,kext_ft_qip,kext_ft_qid &
+                 ,kext_ft_qs,kext_ft_qg                           &
+                 ,qnwfa_curr,qnifa_curr                           & ! Added by G. Thompson
                  ,qvolg_curr
 
+
+
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
          OPTIONAL,                                                &
          INTENT(IN) :: qrcuten, qscuten, qicuten
@@ -465,10 +513,19 @@ SUBROUTINE microphysics_driver(                                          &
 
    LOGICAL, OPTIONAL :: f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni,f_qt    &
                        ,f_qns,f_qnr,f_qng,f_qnn,f_qnc,f_qh,f_qnh,f_qzr       &
-                       ,f_qzi,f_qzs,f_qzg,f_qzh,f_qvolg
+                      ,f_effr,f_ice_effr,f_tot_effr &
+                       ,f_qic_effr,f_qip_effr,f_qid_effr &
+                      ,f_qic,f_qip,f_qid &
+                      ,f_qnic,f_qnip,f_qnid                                  &
+                       ,f_qzi,f_qzs,f_qzg,f_qzh,f_qvolg                      &
+                       ,f_qnwfa, f_qnifa                         ! Added by G. Thompson
+
 
    LOGICAL, OPTIONAL, INTENT(IN) :: diagflag
    INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) ::  & ! G. Thompson
+                 re_cloud, re_ice, re_snow
+   INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
 
 ! LOCAL  VAR
 
@@ -571,7 +628,8 @@ SUBROUTINE microphysics_driver(                                          &
                   F_QC=f_qc, F_QI=f_qi                          )
           END IF
        ELSE IF( progn==1 .AND. mp_physics/=LINSCHEME .AND. mp_physics/=MORR_TWO_MOMENT) THEN
-             call wrf_error_fatal("SETTINGS ERROR: Prognostic cloud droplet number can only be used with the mp_physics=LINSCHEME or MORRISON.")
+             call wrf_error_fatal( &
+             "SETTINGS ERROR: Prognostic cloud droplet number can only be used with the mp_physics=LINSCHEME or MORRISON.")
        END IF
        END IF
 
@@ -601,6 +659,70 @@ SUBROUTINE microphysics_driver(                                          &
                 CALL wrf_error_fatal ( 'arguments not present for calling kessler' )
              ENDIF
 
+!
+        CASE (THOMPSONAERO)
+             CALL wrf_debug ( 100 , 'microphysics_driver: calling thompson' )
+             IF ( PRESENT( QV_CURR ) .AND. PRESENT ( QC_CURR )   .AND.  &
+                  PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR )   .AND.  &
+                  PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR )   .AND.  &
+                  PRESENT( QNR_CURR) .AND. PRESENT ( QNI_CURR)   .AND.  &
+                  PRESENT( QNC_CURR) .AND. PRESENT ( QNWFA_CURR) .AND.  &
+                  PRESENT( QNIFA_CURR).AND.PRESENT ( QNWFA2D)    .AND.  &
+                  PRESENT( SNOWNC)   .AND. PRESENT ( SNOWNCV)    .AND.  &
+                  PRESENT( GRAUPELNC).AND. PRESENT ( GRAUPELNCV) .AND.  &
+                  PRESENT( RAINNC  ) .AND. PRESENT ( RAINNCV ) ) THEN
+#ifdef WRF_CHEM
+                 qv_b4mp(its:ite,kts:kte,jts:jte) = qv_curr(its:ite,kts:kte,jts:jte)
+                 qc_b4mp(its:ite,kts:kte,jts:jte) = qc_curr(its:ite,kts:kte,jts:jte)
+                 qi_b4mp(its:ite,kts:kte,jts:jte) = qi_curr(its:ite,kts:kte,jts:jte)
+                 qs_b4mp(its:ite,kts:kte,jts:jte) = qs_curr(its:ite,kts:kte,jts:jte)
+#endif
+             CALL mp_gt_driver(                          &
+                     QV=qv_curr,                         &
+                     QC=qc_curr,                         &
+                     QR=qr_curr,                         &
+                     QI=qi_curr,                         &
+                     QS=qs_curr,                         &
+                     QG=qg_curr,                         &
+                     NI=qni_curr,                        &
+                     NR=qnr_curr,                        &
+                     NC=qnc_curr,                        &
+                     NWFA=qnwfa_curr,                    &
+                     NIFA=qnifa_curr,                    &
+                     NWFA2D=qnwfa2d,                     &
+                     TH=th,                              &
+                     PII=pi_phy,                         &
+                     P=p,                                &
+                     W=w,                                &
+                     DZ=dz8w,                            &
+                     DT_IN=dt,                           &
+                     ITIMESTEP=itimestep,                &
+                     RAINNC=RAINNC,                      &
+                     RAINNCV=RAINNCV,                    &
+                     SNOWNC=SNOWNC,                      &
+                     SNOWNCV=SNOWNCV,                    &
+                     GRAUPELNC=GRAUPELNC,                &
+                     GRAUPELNCV=GRAUPELNCV,              &
+                     SR=SR,                              &
+#ifdef WRF_CHEM
+                     RAINPROD=rainprod,                  &
+                     EVAPPROD=evapprod,                  &
+#endif
+                     REFL_10CM=refl_10cm,                &
+                     diagflag=diagflag,                  &
+                     do_radar_ref=do_radar_ref,          &
+                     re_cloud=re_cloud,                  &
+                     re_ice=re_ice,                      &
+                     re_snow=re_snow,                    &
+                     has_reqc=has_reqc,                  & ! G. Thompson
+                     has_reqi=has_reqi,                  & ! G. Thompson
+                     has_reqs=has_reqs,                  & ! G. Thompson
+                 IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, &
+                 IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, &
+                 ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte)
+             ELSE
+                CALL wrf_error_fatal ( 'arguments not present for calling thompson_et_al' )
+             ENDIF
 !
         CASE (THOMPSON)
              CALL wrf_debug ( 100 , 'microphysics_driver: calling thompson' )
@@ -608,6 +730,8 @@ SUBROUTINE microphysics_driver(                                          &
                   PRESENT( QR_CURR ) .AND. PRESENT ( QI_CURR ) .AND.  &
                   PRESENT( QS_CURR ) .AND. PRESENT ( QG_CURR ) .AND.  &
                   PRESENT( QNR_CURR) .AND. PRESENT ( QNI_CURR) .AND.  &
+!                  PRESENT( SNOWNC) .AND. PRESENT ( SNOWNCV) .AND.        &
+!                  PRESENT( GRAUPELNC) .AND. PRESENT ( GRAUPELNCV) .AND.  &
                   PRESENT( RAINNC  ) .AND. PRESENT ( RAINNCV ) ) THEN
 #ifdef WRF_CHEM
                  qv_b4mp(its:ite,kts:kte,jts:jte) = qv_curr(its:ite,kts:kte,jts:jte)
@@ -627,6 +751,7 @@ SUBROUTINE microphysics_driver(                                          &
                      TH=th,                              &
                      PII=pi_phy,                         &
                      P=p,                                &
+                     W=w,                                &
                      DZ=dz8w,                            &
                      DT_IN=dt,                           &
                      ITIMESTEP=itimestep,                &
@@ -644,12 +769,109 @@ SUBROUTINE microphysics_driver(                                          &
                      REFL_10CM=refl_10cm,                &
                      diagflag=diagflag,                  &
                      do_radar_ref=do_radar_ref,          &
+                     re_cloud=re_cloud,                  & ! G. Thompson
+                     re_ice=re_ice,                      & ! G. Thompson
+                     re_snow=re_snow,                    & ! G. Thompson
+                     has_reqc=has_reqc,                  & ! G. Thompson
+                     has_reqi=has_reqi,                  & ! G. Thompson
+                     has_reqs=has_reqs,                  & ! G. Thompson
                  IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, &
                  IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, &
                  ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte)
              ELSE
                 CALL wrf_error_fatal ( 'arguments not present for calling thompson_et_al' )
              ENDIF
+#if (EM_CORE==1)
+       CASE (FAST_KHAIN_LYNN)
+             CALL wrf_debug ( 100 , 'microphysics_driver: calling sbm' )
+               CALL fast_sbm(W=w,U=u,V=v,TH_OLD=th_old          &
+                 ,CHEM_new=scalar,N_CHEM=num_scalar                     &
+                 ,ITIMESTEP=itimestep,DT=dt,DX=dx,DY=dy             &
+                 ,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,PI_PHY=pi_phy,TH_PHY=th &
+                 ,xland=xland                                       &
+                 ,ivgtyp=ivgtyp                                      &
+                 ,xlat=xlat                                        &
+                 ,xlong=xlong                                        &
+                 ,QV=qv_curr                                        &
+                 ,QC=qc_curr                                        &
+                 ,QR=qr_curr                                        &
+                 ,QI=qi_curr                                        &
+                 ,QS=qs_curr                                        &
+                 ,QG=qg_curr                                        &
+                 ,QV_OLD=qv_old                                     &
+                 ,QNC=qnc_curr                                      &
+                 ,QNR=qnr_curr                                      &
+                 ,QNS=qns_curr                                      &
+                 ,QNG=qng_curr                                      &
+                 ,QNA=qnn_curr                                      &
+                 ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
+                 ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
+                 ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
+                 ,REFL_10CM=refl_10cm                 &  ! added for radar reflectivity
+                 ,diagflag=diagflag                   &  ! added for radar reflectivity
+                 ,do_radar_ref=do_radar_ref           &  ! added for radar reflectivity
+                 ,RAINNC=rainnc)
+
+!
+       CASE (FULL_KHAIN_LYNN)
+             CALL wrf_debug ( 100 , 'microphysics_driver: calling sbm' )
+               CALL sbm(W=w,U=u,V=v,TH_OLD=th_old          &
+                 ,CHEM_new=scalar,N_CHEM=num_scalar                     &
+                 ,ITIMESTEP=itimestep,DT=dt,DX=dx,DY=dy             &
+                 ,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,PI_PHY=pi_phy,TH_PHY=th &
+                 ,xland=xland                                       &
+                 ,ivgtyp=ivgtyp                                      &
+                 ,xlat=xlat                                        &
+                 ,xlong=xlong                                        &
+                 ,QV=qv_curr                                        &
+                 ,QC=qc_curr                                        &
+                 ,QR=qr_curr                                        &
+                 ,QIP=qip_curr                                        &
+                 ,QIC=qic_curr                                        &
+                 ,QID=qid_curr                                        &
+                 ,QS=qs_curr                                        &
+                 ,QG=qg_curr                                        &
+                 ,QH=qh_curr                                        &
+                 ,QV_OLD=qv_old                                     &
+                 ,QNC=qnc_curr                                      &
+                 ,QNR=qnr_curr                                      &
+                 ,QNIP=qnip_curr                                      &
+                 ,QNIC=qnic_curr                                      &
+                 ,QNID=qnid_curr                                      &
+                 ,QNS=qns_curr                                      &
+                 ,QNG=qng_curr                                      &
+                 ,QNH=qng_curr                                      &
+                 ,QNA=qnn_curr                                      &
+                 ,EFFR=effr_curr                                  &
+                 ,ICE_EFFR=ice_effr_curr                                  &
+                 ,TOT_EFFR=tot_effr_curr                                  &
+                 ,QIC_EFFR=qic_effr_curr                                  &
+                 ,QIP_EFFR=qip_effr_curr                                  &
+                 ,QID_EFFR=qid_effr_curr                                  &
+                 ,height=height                                        &
+                 ,tempc=tempc                                         &
+                 ,kext_ql=kext_ql                                       &
+                 ,kext_qs=kext_qs                                       &
+                 ,kext_qg=kext_qg                                       &
+                 ,kext_qh=kext_qh                                       &
+                 ,kext_qa=kext_qa                                       &
+                 ,kext_qic=kext_qic                                       &
+                 ,kext_qip=kext_qip                                       &
+                 ,kext_qid=kext_qid                                       &
+                 ,kext_ft_qic=kext_ft_qic                                       &
+                 ,kext_ft_qip=kext_ft_qip                                       &
+                 ,kext_ft_qid=kext_ft_qid                                       &
+                 ,kext_ft_qs=kext_ft_qs                                       &
+                 ,kext_ft_qg=kext_ft_qg                                       &
+                 ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
+                 ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
+                 ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
+                 ,REFL_10CM=refl_10cm                 &  ! added for radar reflectivity
+                 ,diagflag=diagflag                   &  ! added for radar reflectivity
+                 ,do_radar_ref=do_radar_ref           &  ! added for radar reflectivity
+                 ,RAINNC=rainnc)
+#endif
+
 !
 
     CASE (MORR_TWO_MOMENT)
@@ -686,6 +908,10 @@ SUBROUTINE microphysics_driver(                                          &
                      W=w                                 &  !*
                     ,RAINNC=RAINNC                       &  !*
                     ,RAINNCV=RAINNCV                     &  !*
+                    ,SNOWNC=SNOWNC                       &  !*
+                    ,SNOWNCV=SNOWNCV                     &  !*
+                    ,GRAUPELNC=GRAUPELNC                 &  !*
+                    ,GRAUPELNCV=GRAUPELNCV               &  !*
                     ,SR=SR                               &  !* !hm
                     ,REFL_10CM=refl_10cm                 &  ! added for radar reflectivity
                     ,diagflag=diagflag                   &  ! added for radar reflectivity
@@ -1420,6 +1646,12 @@ SUBROUTINE microphysics_driver(                                          &
                   PRESENT( dgnumwet4D ) .AND.                           &
 #endif
                   PRESENT( qni_curr   ) .AND. PRESENT( RAINNC      ) ) THEN
+#ifdef WRF_CHEM
+                qv_b4mp(its:ite,kts:kte,jts:jte) = qv_curr(its:ite,kts:kte,jts:jte)
+                qc_b4mp(its:ite,kts:kte,jts:jte) = qc_curr(its:ite,kts:kte,jts:jte)
+                qi_b4mp(its:ite,kts:kte,jts:jte) = qi_curr(its:ite,kts:kte,jts:jte)
+                qs_b4mp(its:ite,kts:kte,jts:jte) = qs_curr(its:ite,kts:kte,jts:jte)
+#endif
                   
                 CALL CAMMGMP(ITIMESTEP=itimestep,DT=dt,P8W=p8w_hyd,P_HYD=p_hyd    &
                      ,T_PHY=t_phy,PI_PHY=pi_phy,Z_AT_W=z_at_w,QFX=qfx             &
@@ -1439,8 +1671,9 @@ SUBROUTINE microphysics_driver(                                          &
                      ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte           &
 !Output variables from CAMMGMP
                      ,TH=th,CLDFRA_OLD_MP=cldfra_old_mp,CLDFRA_MP=cldfra_mp       &
-                     ,CLDFRA_MP_ALL=cldfra_mp_all,CLDFRAI=cldfrai,CLDFRAL=cldfral &
-                     ,CLDFRA_CONV=cldfra_conv,WSEDL3D=wsedl3d           &
+                     ,CLDFRA_MP_ALL=cldfra_mp_all,lradius=lradius,iradius=iradius &
+                     ,CLDFRAI=cldfrai,CLDFRAL=cldfral                             &
+                     ,CLDFRA_CONV=cldfra_conv,WSEDL3D=wsedl3d                     &
                      ,RAINNC=rainnc,RAINNCV=rainncv,SNOWNC=snownc,SNOWNCV=snowncv &
                      ,SR=sr,QV_CURR=qv_curr,QC_CURR=qc_curr,QI_CURR=qi_curr       &
                      ,QS_CURR=qs_curr,QR_CURR=qr_curr,NC3D=qnc_curr               &
diff --git a/wrfv2_fire/phys/module_mixactivate.F b/wrfv2_fire/phys/module_mixactivate.F
index c8a76257..ababfc10 100644
--- a/wrfv2_fire/phys/module_mixactivate.F
+++ b/wrfv2_fire/phys/module_mixactivate.F
@@ -231,7 +231,7 @@ subroutine mixactivate(  msectional,            &
 !     doesn't distinguish between warm, cold clouds
 
   USE module_model_constants, only: g, rhowater, xlv, cp, rvovrd, r_d, r_v, mwdry, ep_2
-  USE module_radiation_driver, only: cal_cldfra
+  USE module_radiation_driver, only: cal_cldfra2
 
   implicit none
 
@@ -464,7 +464,7 @@ subroutine mixactivate(  msectional,            &
   enddo
 
   IF( PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN
-     CALL cal_cldfra(CLDFRA,qc,qi,f_qc,f_qi,      &
+     CALL cal_cldfra2(CLDFRA,qc,qi,f_qc,f_qi,     &
           ids,ide, jds,jde, kds,kde,              &
           ims,ime, jms,jme, kms,kme,              &
           its,ite, jts,jte, kts,kte               )
diff --git a/wrfv2_fire/phys/module_mp_HWRF.F b/wrfv2_fire/phys/module_mp_HWRF.F
index 9ee8465c..e26a98a7 100755
--- a/wrfv2_fire/phys/module_mp_HWRF.F
+++ b/wrfv2_fire/phys/module_mp_HWRF.F
@@ -16,8 +16,8 @@ MODULE module_mp_HWRF
       REAL,PRIVATE,DIMENSION(MY_T1:MY_T2),SAVE :: MY_GROWTH
 !
       REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3,           &
-     &      DelDMI=1.e-6,XMImin=1.e6*DMImin
-      INTEGER, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax, XMIexp=.0536,    &
+     &      DelDMI=1.e-6,XMImin=1.e6*DMImin, XMIexp=.0536  
+      INTEGER, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax,                  &
      &                             MDImin=XMImin, MDImax=XMImax
       REAL, PRIVATE,DIMENSION(MDImin:MDImax) ::                         &
      &      ACCRI,SDENS,VSNOWI,VENTI1,VENTI2
diff --git a/wrfv2_fire/phys/module_mp_cammgmp_driver.F b/wrfv2_fire/phys/module_mp_cammgmp_driver.F
index 0210d6ec..cf3059bb 100644
--- a/wrfv2_fire/phys/module_mp_cammgmp_driver.F
+++ b/wrfv2_fire/phys/module_mp_cammgmp_driver.F
@@ -96,7 +96,7 @@ module module_mp_cammgmp_driver
   
   subroutine CAMMGMP(itimestep, dt, p8w, p_hyd   &
        , t_phy, pi_phy, z_at_w, qfx              &
-       , tke_pbl, turbtype3d, smaw3d           &
+       , tke_pbl, turbtype3d, smaw3d             &
        , dlf3d, dlf2_3d, rliq2d, z_sea_level     &
        , kvh3d, ht, alt, accum_mode              &
        , aitken_mode, coarse_mode, icwmrsh3d     &
@@ -109,12 +109,13 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd   &
        , ims, ime,  jms, jme,  kms, kme          &
        , its, ite,  jts, jte,  kts, kte          &
        !Output variables from CAMMGMP
-       , th, cldfra_old_mp, cldfra_mp,cldfra_mp_all,cldfrai    &
-       , cldfral, cldfra_conv,wsedl3d, rainnc                &
+       , th, cldfra_old_mp, cldfra_mp            &
+       ,cldfra_mp_all, lradius, iradius, cldfrai &
+       , cldfral, cldfra_conv,wsedl3d, rainnc    &
        , rainncv, snownc, snowncv,sr             &
        , qv_curr, qc_curr, qi_curr,qs_curr       &
        , qr_curr, nc3d, ni3d,ns3d,nr3d,qndrop    &
-       , rh_old_mp,lcd_old_mp                     & !PMA- added for macrophysics
+       , rh_old_mp,lcd_old_mp                    & !PMA- added for macrophysics
 #ifdef WRF_CHEM                     
        , chem                                    &
        , qme3d,prain3d,nevapr3d                  &
@@ -229,6 +230,8 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd   &
     real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: cldfra_mp      !New Cloud fraction 
     real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: cldfra_conv    !New Cloud fraction 
     real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: cldfra_mp_all  !New Cloud fraction 
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: lradius
+    real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: iradius
     real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: cldfrai
     real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: cldfral
 #ifdef WRF_CHEM
@@ -595,6 +598,11 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd   &
     
     !Time step is stored in the (r8) format in dtime
     dtime = dt
+
+    
+    !default values for radius 
+    lradius(:,:,:) = 10._r8
+    iradius(:,:,:) = 25._r8
   
     !Flag for first time step
     is_first_step  = .false.
@@ -1255,8 +1263,8 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd   &
           
           !! Averaging for new output fields
           
-          efcout(:,:)      = 0._r8
-          efiout(:,:)      = 0._r8
+          efcout(:,:)      = 10._r8 
+          efiout(:,:)      = 25._r8 
           ncout(:,:)       = 0._r8
           niout(:,:)       = 0._r8	
           freql(:,:)       = 0._r8
@@ -1343,6 +1351,8 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd   &
              qvs(1,kflip)     = max(1.e-30_r8,epsqs*esl(1,kflip)/(state_pmid(1,kflip)-(1._r8-epsqs)*esl(1,kflip)))
              rh_old_mp(iw,kw,jw)     = max(0._r8,state_q(1,kflip,1) / qvs(1,kflip))
              lcd_old_mp(iw,kw,jw)    = alst(1,kflip)
+             lradius(iw,kw,jw)    = efcout(1,kflip)
+             iradius(iw,kw,jw)    = efiout(1,kflip)
              
 #ifdef WRF_CHEM
              if(chem_opt .NE. 0 .and. config_flags%CAM_MP_MAM_cpled ) then
diff --git a/wrfv2_fire/phys/module_mp_etanew.F b/wrfv2_fire/phys/module_mp_etanew.F
index e3ed2956..1910e1aa 100644
--- a/wrfv2_fire/phys/module_mp_etanew.F
+++ b/wrfv2_fire/phys/module_mp_etanew.F
@@ -13,13 +13,13 @@ MODULE module_mp_etanew
       REAL,PRIVATE,DIMENSION(MY_T1:MY_T2),SAVE :: MY_GROWTH
 !
       REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3,           &
-     &      DelDMI=1.e-6,XMImin=1.e6*DMImin
-      INTEGER, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax, XMIexp=.0536,    &
+     &      DelDMI=1.e-6,XMImin=1.e6*DMImin, XMIexp=.0536
+      INTEGER, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax,                  &
      &                             MDImin=XMImin, MDImax=XMImax
       REAL, PRIVATE,DIMENSION(MDImin:MDImax) ::                         &
      &      ACCRI,SDENS,VSNOWI,VENTI1,VENTI2
 !
-      REAL, PRIVATE,PARAMETER :: DMRmin=.05e-3, DMRmax=1.e-3,          &
+      REAL, PRIVATE,PARAMETER :: DMRmin=.05e-3, DMRmax=1.e-3,           &
      &      DelDMR=1.e-6,XMRmin=1.e6*DMRmin, XMRmax=1.e6*DMRmax
       INTEGER, PRIVATE,PARAMETER :: MDRmin=XMRmin, MDRmax=XMRmax                   
       REAL, PRIVATE,DIMENSION(MDRmin:MDRmax)::                          &
@@ -2333,6 +2333,7 @@ SUBROUTINE ETANEWinit (GSMDT,DT,DELX,DELY,LOWLYR,restart,         &
         RR_DR3=N0r0*RRATE(MDR3)         ! RR for mean drop diameter of .32 mm
         RR_DR4=N0r0*RRATE(MDR4)         ! RR for mean drop diameter of .45 mm
         RR_DR5=N0r0*RRATE(MDR5)         ! RR for mean drop diameter of .675 mm
+        RR_DRmax=N0r0*RRATE(MDRmax)     ! RR for mean drop diameter of .45 mm
 !
         RQR_DRmin=N0r0*MASSR(MDRmin)    ! Rain content for mean drop diameter of .05 mm
 
diff --git a/wrfv2_fire/phys/module_mp_etaold.F b/wrfv2_fire/phys/module_mp_etaold.F
index 2837970e..0403ff61 100644
--- a/wrfv2_fire/phys/module_mp_etaold.F
+++ b/wrfv2_fire/phys/module_mp_etaold.F
@@ -12,8 +12,8 @@ MODULE module_mp_etaold
       REAL,PRIVATE,DIMENSION(MY_T1:MY_T2),SAVE :: MY_GROWTH
 !
       REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3,           &
-     &      DelDMI=1.e-6,XMImin=1.e6*DMImin
-      INTEGER, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax, XMIexp=.0536,    &
+     &      DelDMI=1.e-6,XMImin=1.e6*DMImin, XMIexp=.0536
+      INTEGER, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax,                  &
      &                             MDImin=XMImin, MDImax=XMImax
       REAL, PRIVATE,DIMENSION(MDImin:MDImax) ::                         &
      &      ACCRI,SDENS,VSNOWI,VENTI1,VENTI2
diff --git a/wrfv2_fire/phys/module_mp_fast_sbm.F b/wrfv2_fire/phys/module_mp_fast_sbm.F
new file mode 100644
index 00000000..887715b4
--- /dev/null
+++ b/wrfv2_fire/phys/module_mp_fast_sbm.F
@@ -0,0 +1,8980 @@
+!WRF:MODEL_MP:PHYSICS
+! The fast version calculates hydrometeor distributions for qc,qr,qs,qg, and their number concentrations
+! (including aerosol concentrations).
+! To use the FAST version of SBM, please do the following.
+! Set DX_BOUND to some value larger than the first inner nest, but smaller than the outer domain in meters
+! Set the aerosol concentration with the variables FCCNR_MAR, and FCCNR_CON, FCCNR_MIX.  
+! Each of the aerosol distributions are set with ACCN (concentration of ccn particles at 1% saturation), and
+! BCCN (the "k" coefficient; for example: FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN). 
+! Questions: contact barry.h.lynn@gmail.com (Barry Lynn)
+!
+MODULE module_mp_fast_sbm
+USE module_mp_radar
+!      USE module_state_description
+!
+!-----------------------------------------------------------------------
+! BARRY
+      INTEGER,PRIVATE,PARAMETER :: REMSAT = 0
+!     LOGICAL, PRIVATE,PARAMETER : : ICEPROCS=.FALSE.,BULKNUC=.TRUE.  
+      INTEGER, PRIVATE,PARAMETER :: IBREAKUP=1
+      INTEGER, PRIVATE,PARAMETER :: p_ff1i01=2, p_ff1i33=34,p_ff5i01=35,p_ff5i33=67,p_ff6i01=68,&
+     & p_ff6i33=100,p_ff8i01=101,p_ff8i33=133
+
+      LOGICAL, PRIVATE,PARAMETER :: CONSERV=.TRUE.
+! SET ONE = TRUE
+!     LOGICAL, PRIVATE,PARAMETER :: ORIGINAL_MELT=.FALSE.
+!     LOGICAL, PRIVATE,PARAMETER :: JIWEN_FAN_MELT=.TRUE.
+      LOGICAL, PRIVATE,PARAMETER :: ORIGINAL_MELT=.TRUE.
+      LOGICAL, PRIVATE,PARAMETER :: JIWEN_FAN_MELT=.FALSE.
+      REAL, PRIVATE,PARAMETER :: PI_MORR = 3.1415926535897932384626434
+      REAL, PRIVATE,PARAMETER ::  R_MORR = 287.15
+
+
+
+      REAL,PRIVATE,PARAMETER :: DX_BOUND=7500.
+      REAL ACCN,BCCN
+      REAL,PRIVATE,PARAMETER :: ACCN_MAR=1.0000E02, BCCN_MAR=0.900E00,ROCCN0=0.1000E01
+      REAL,PRIVATE,PARAMETER :: ACCN_CON=4.00000E03, BCCN_CON=0.400E00,ROCCN03=0.1000E01
+      REAL,PRIVATE,PARAMETER :: I3POINT=1
+      INTEGER,PRIVATE,PARAMETER :: ICCN = 1
+       DOUBLE PRECISION, PRIVATE, PARAMETER ::  SCAL=1.d0
+       INTEGER, PRIVATE,PARAMETER :: ICEPROCS=1,BULKNUC=0 
+       INTEGER, PRIVATE,PARAMETER :: ICETURB=0,LIQTURB=0
+!      INTEGER, PRIVATE,PARAMETER :: RAIN_INIT=1,GRAUPEL_INIT=1
+!      INTEGER, PRIVATE,PARAMETER :: ICE_INIT=0,SNOW_INIT=1
+
+       INTEGER, PRIVATE,PARAMETER :: ICEMAX=3,NCD=33,NHYDR=5,NHYDRO=7  &
+     &        ,ifreez_down1=0,ifreez_down2=1,ifreez_top=1              &
+     &        ,K0_LL=8,KRMIN_LL=1,KRMAX_LL=19,L0_LL=6                  &
+     &        , IEPS_400=1,IEPS_800=0,IEPS_1600=0                      &
+     &        ,K0L_GL=16,K0G_GL=16                                     &
+     &        ,KRMINL_GL=1,KRMAXL_GL=24                                &
+     &        ,KRMING_GL=1,KRMAXG_GL=33                                &
+     &        ,KRDROP=18,KRBREAK=17,KRICE=18                           &
+     &        ,NKR=33,JMAX=33,NRG=2,JBREAK = 18 
+       REAL dt_coll
+       REAL, PRIVATE,PARAMETER ::C1_MEY=0.00033,C2_MEY=0.              &
+! New CONTINENTAL
+!      REAL, PRIVATE,PARAMETER ::C1_MEY=0.0033,C2_MEY=0.              &
+     &        ,an0_freez=10.,COL=0.23105                                
+       REAL, PRIVATE,PARAMETER :: p1=1000000.0,p2=750000.0,p3=500000.0                     
+!      INTEGER, PRIVATE,PARAMETER :: NCOND=3
+!      INTEGER, PRIVATE,PARAMETER :: NCOND=6
+       INTEGER, PRIVATE :: NCOND
+       INTEGER, PRIVATE,PARAMETER :: kr_icempl=9
+!      REAL, PRIVATE, PARAMETER :: ALCR = 1.0
+!      REAL, PRIVATE, PARAMETER :: ALCR = 2.0
+!      REAL, PRIVATE, PARAMETER :: ALCR = 1.5
+       REAL, PRIVATE, PARAMETER :: ALCR = 2.25
+!      REAL, PRIVATE, PARAMETER :: ALCR = 3.0
+       REAL, PRIVATE, PARAMETER :: ALCR_G = 3.0
+!      REAL, PRIVATE, PARAMETER :: ALCR_G = 1.0
+       INTEGER,PRIVATE,PARAMETER :: icempl=1
+       REAL, PRIVATE, PARAMETER :: COEFREFLL=1.E6*36.E6*COL/3.1453/3.1453 
+       REAL, PRIVATE, PARAMETER :: COEFREFLI=1.E9*36.E3*COL/3.1453/3.1453/5.
+       REAL, PRIVATE, PARAMETER :: COEFREF00=1.E9*36.E3*COL/3.1453/3.1453       
+       REAL, PRIVATE,DIMENSION(NKR) ::COLREFLL,COLREFLI,COLREFLS,COLREFLG,COLREFLH
+
+
+! YWLL_1000MB(nkr,nkr) - input array of kernels for pressure 1000mb
+! YWLL_750MB(nkr,nkr) - input array of kernels for pressure 750mb
+! YWLL_500MB(nkr,nkr) - input array of kernels for pressure 500mb
+       REAL, PRIVATE, SAVE :: &
+! CRYSTALS 
+     &YWLI(NKR,NKR,ICEMAX) &
+! MIXTURES
+     &,YWIL(NKR,NKR,ICEMAX),YWII(NKR,NKR,ICEMAX,ICEMAX) &
+     &,YWIS(NKR,NKR,ICEMAX),YWIG(NKR,NKR,ICEMAX) &
+     &,YWIH(NKR,NKR,ICEMAX),YWSI(NKR,NKR,ICEMAX) &
+     &,YWGI(NKR,NKR,ICEMAX),YWHI(NKR,NKR,ICEMAX)
+!
+      REAL,PRIVATE,DIMENSION(NKR,NKR),SAVE :: &
+     & YWLL_1000MB,YWLL_750MB,YWLL_500MB,YWLL,YWLS,YWLG,YWLH &
+! SNOW :
+     &,YWSL,YWSS,YWSG,YWSH &
+! GRAUPELS :
+     &,YWGL,YWGS,YWGG,YWGH &
+! HAIL :
+     &,YWHL,YWHS,YWHG,YWHH
+       REAL, PRIVATE, SAVE :: &
+     &  XI(NKR,ICEMAX) &
+     & ,RADXX(NKR,NHYDR-1),MASSXX(NKR,NHYDR-1),DENXX(NKR,NHYDR-1) &
+     & ,RADXXO(NKR,NHYDRO),MASSXXO(NKR,NHYDRO),DENXXO(NKR,NHYDRO) &
+     & ,RIEC(NKR,ICEMAX),COEFIN(NKR),SLIC(NKR,6),TLIC(NKR,2) &
+     & ,RO2BL(NKR,ICEMAX)
+       REAL, PRIVATE, SAVE :: VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR) &
+     & ,VR4(NKR),VR5(NKR),VRX(NKR)
+      REAL,PRIVATE,DIMENSION(NKR),SAVE ::  &
+     &  XL,RLEC,XX,XCCN,XS,RSEC &
+     & ,XG,RGEC,XH,RHEC,RO1BL,RO3BL,RO4BL,RO5BL &
+     & ,ROCCN,RCCN,DROPRADII
+  
+      REAL, PRIVATE,SAVE ::  FCCNR_MAR(NKR),FCCNR_CON(NKR)
+      REAL, PRIVATE,SAVE ::  FCCNR_MIX(NKR)
+      REAL, PRIVATE,SAVE ::  FCCNR(NKR)
+
+        REAL, PRIVATE :: C2,C3,C4
+      double precision,private,save ::  cwll(nkr,nkr)
+      double precision,private,save::  &
+     & xl_mg(0:nkr),xs_mg(0:nkr),xg_mg(0:nkr),xh_mg(0:nkr) &
+     &,xi1_mg(0:nkr),xi2_mg(0:nkr),xi3_mg(0:nkr) &
+     &,chucm(nkr,nkr),ima(nkr,nkr) &
+     &,cwll_1000mb(nkr,nkr),cwll_750mb(nkr,nkr),cwll_500mb(nkr,nkr) &
+     &,cwli_1(nkr,nkr),cwli_2(nkr,nkr),cwli_3(nkr,nkr) &
+     &,cwls(nkr,nkr),cwlg(nkr,nkr),cwlh(nkr,nkr) &
+
+     &,cwil_1(nkr,nkr),cwil_2(nkr,nkr),cwil_3(nkr,nkr) &
+
+     &,cwii_1_1(nkr,nkr),cwii_1_2(nkr,nkr),cwii_1_3(nkr,nkr) &
+     &,cwii_2_1(nkr,nkr),cwii_2_2(nkr,nkr),cwii_2_3(nkr,nkr) &
+     &,cwii_3_1(nkr,nkr),cwii_3_2(nkr,nkr),cwii_3_3(nkr,nkr) &
+
+     &,cwis_1(nkr,nkr),cwis_2(nkr,nkr),cwis_3(nkr,nkr) &
+     &,cwig_1(nkr,nkr),cwig_2(nkr,nkr),cwig_3(nkr,nkr) &
+     &,cwih_1(nkr,nkr),cwih_2(nkr,nkr),cwih_3(nkr,nkr) &
+
+     &,cwsl(nkr,nkr) &
+     &,cwsi_1(nkr,nkr),cwsi_2(nkr,nkr),cwsi_3(nkr,nkr)&
+     &,cwss(nkr,nkr),cwsg(nkr,nkr),cwsh(nkr,nkr) &
+     &,cwgl(nkr,nkr)&
+     &,cwgi_1(nkr,nkr),cwgi_2(nkr,nkr),cwgi_3(nkr,nkr)&
+     &,cwgs(nkr,nkr),cwgg(nkr,nkr),cwgh(nkr,nkr) &
+
+     &,cwhl(nkr,nkr) &
+     &,cwhi_1(nkr,nkr),cwhi_2(nkr,nkr),cwhi_3(nkr,nkr) &
+     &,cwhs(nkr,nkr),cwhg(nkr,nkr),cwhh(nkr,nkr) &
+     &,dlnr &
+     &,CTURBLL(KRMAX_LL,KRMAX_LL)&
+     &,CTURB_LL(K0_LL,K0_LL)&
+     &,CTURBGL(KRMAXG_GL,KRMAXL_GL)&
+     &,CTURB_GL(K0G_GL,K0L_GL)
+
+      DOUBLE PRECISION,private, save :: &
+     &   BRKWEIGHT(JBREAK),PKIJ(JBREAK,JBREAK,JBREAK), &
+     &   QKJ(JBREAK,JBREAK),ECOALMASSM(NKR,NKR)
+
+ 
+
+
+
+!
+!
+      CONTAINS
+
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      SUBROUTINE FAST_SBM (w,u,v,th_old,                                &
+     &                      chem_new,n_chem,                              &
+     &                      itimestep,DT,DX,DY,                         &
+     &                      dz8w,rho_phy,p_phy,pi_phy,th_phy,           &
+     &                      xland,ivgtyp,xlat,xlong,                           &
+     &                      QV,QC,QR,QI,QS,QG,QV_OLD,                   &
+     &                      QNC,QNR,QNS,QNG,QNA,                        &
+     &                      ids,ide, jds,jde, kds,kde,		        &
+     &                      ims,ime, jms,jme, kms,kme,		        &
+     &                      its,ite, jts,jte, kts,kte,                  &
+     &                      refl_10cm, diagflag, do_radar_ref,      & ! GT added for reflectivity calcs
+     &                      RAINNC                             )
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+      INTEGER, PARAMETER :: ITLO=-60, ITHI=40
+      INTEGER NKRO,NKRE
+      INTEGER KR,IKL,ICE
+
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE                     &
+     &                     ,ITIMESTEP,N_CHEM
+
+      REAL, INTENT(IN) 	    :: DT,DX,DY
+   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
+          INTENT(IN   ) ::                                   &
+                                                          U, &
+                                                          V, &
+                                                          W   
+!                                                        pi
+  REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem),INTENT(INOUT)   :: chem_new
+  REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
+        INTENT(INOUT) ::                                          &
+                                                              qv, &
+                                                          qv_old, &
+                                                          th_old, &
+                                                              qc, &
+                                                              qr, &
+                                                              qi, &
+                                                              qs, &
+                                                              qg, &
+                                                              qnc, &
+                                                              qnr, &
+                                                              qns, &
+                                                              qng, &
+                                                              qna
+
+
+
+      REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN)   :: XLAND
+      LOGICAL, OPTIONAL, INTENT(IN) :: diagflag
+      INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref
+
+      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT)::       &  
+                          refl_10cm
+
+      INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN)::   IVGTYP
+      REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )    :: XLAT, XLONG
+      REAL, INTENT(IN),     DIMENSION(ims:ime, kms:kme, jms:jme)::      &
+     &                      dz8w,p_phy,pi_phy,rho_phy
+      REAL, INTENT(INOUT),  DIMENSION(ims:ime, kms:kme, jms:jme)::      &
+     &                      th_phy
+      REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
+     &                                                   RAINNC
+!     REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
+!     REAL,                 DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
+!    &              LIQUEXP,ICEEXP,SNOWEXP,GRAUEXP,HAILEXP
+!
+
+!-----------------------------------------------------------------------
+!     LOCAL VARS
+!-----------------------------------------------------------------------
+
+!     NSTATS,QMAX,QTOT are diagnostic vars
+
+      INTEGER,DIMENSION(ITLO:ITHI,4) :: NSTATS
+!     REAL,   DIMENSION(ITLO:ITHI,5) :: QMAX
+      REAL,   DIMENSION(ITLO:ITHI,22):: QTOT
+
+!     SOME VARS WILL BE USED FOR DATA ASSIMILATION (DON'T NEED THEM NOW). 
+!     THEY ARE TREATED AS LOCAL VARS, BUT WILL BECOME STATE VARS IN THE 
+!     FUTURE. SO, WE DECLARED THEM AS MEMORY SIZES FOR THE FUTURE USE
+
+!     TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related 
+!     the microphysics scheme. Instead, they will be used by Eta precip 
+!     assimilation.
+
+      REAL,  DIMENSION( ims:ime, kms:kme, jms:jme ) ::                  &
+     &       TLATGS_PHY,TRAIN_PHY
+      REAL,  DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC
+      REAL,  DIMENSION(its-1:ite+1, kts:kte, jts-1:jte+1):: t_new,t_old,   &
+     &                                      zcgs,       rhocgs,pcgs
+
+      INTEGER :: I,J,K,KFLIP
+! BARRY
+      INTEGER :: KRFREEZ
+! DATA
+       REAL Z0IN,ZMIN
+       DATA  ZMIN/2.0E5/
+       DATA  Z0IN/2.0E5 /
+
+!      REAL,DIMENSION(1) :: EPSF2D, &
+       REAL EPSF2D, &
+     &        TAUR1,TAUR2,EPS_R1,EPS_R2,ANC1IN, &
+     &        PEPL,PEPI,PERL,PERI,ANC1,ANC2,PARSP, &
+     &        AFREEZMY,BFREEZMY,BFREEZMAX, &
+     &        TCRIT,TTCOAL, &
+     &        EPSF1,EPSF3,EPSF4, &
+     &        SUP2_OLD, DSUPICEXZ,TFREEZ_OLD,DTFREEZXZ, &
+     &        AA1_MY,BB1_MY,AA2_MY,BB2_MY, &
+     &        DTIME,DTCOND, &
+     &        A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
+        DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN  &
+     &      /2.53,5.42,3.41E1,6.13/
+        DATA AA1_MY,BB1_MY,AA2_MY,BB2_MY/2.53E12,5.42E3,3.41E13,6.13E3/
+!            QSUM,ISUM,QSUM1,QSUM2,CCNSUM1,CCNSUM2
+        DATA KRFREEZ,BFREEZMAX,ANC1,ANC2,PARSP,PEPL,PEPI,PERL,PERI, &
+     &  TAUR1,TAUR2,EPS_R1,EPS_R2,TTCOAL,AFREEZMY,&
+     &  BFREEZMY,EPSF1,EPSF3,EPSF4,TCRIT/21,&
+     &  0.6600E00, &
+     &  1.0000E02,1.0000E02,0.9000E02, &
+     &  0.6000E00,0.6000E00,1.0000E-03,1.0000E-03, &
+     &  0.5000E00,0.8000E00,0.1500E09,0.1500E09, &
+     &  2.3315E02,0.3333E-04,0.6600E00, &
+     &  0.1000E-02,0.1000E-05,0.1000E-05, &
+     &  2.7015E02/
+! JIMY: N_CHEM,variables read in as data
+! SBM VARIABLES
+      REAL,DIMENSION (nkr) :: FF1IN,FF3IN,FF4IN,FF5IN,&
+     &              FF1R,FF3R,FF4R,FF5R,FCCN
+      REAL,DIMENSION (nkr,icemax) :: FF2IN,FF2R
+!!!! NOTE: ZCGS AND OTHER VARIABLES ARE ALSO DIMENSIONED IN FALFLUXHUCM
+      DOUBLE PRECISION DEL1NR,DEL2NR,DEL12R,DEL12RD,ES1N,ES2N,EW1N,EW1PN
+      DOUBLE PRECISION DELSUP1,DELSUP2,DELDIV1,DELDIV2
+      DOUBLE PRECISION TT,QQ,TTA,QQA,PP,DPSA,DELTATEMP,DELTAQ
+      DOUBLE PRECISION DIV1,DIV2,DIV3,DIV4,DEL1IN,DEL2IN,DEL1AD,DEL2AD
+      REAL DEL_BB,DEL_BBN,DEL_BBR
+      REAL FACTZ,CONCCCN_XZ,CONCDROP
+       REAL SUPICE(KTE),AR1,AR2, &
+     & DERIVT_X,DERIVT_Y,DERIVT_Z,DERIVS_X,DERIVS_Y,DERIVS_Z, &
+     & ES2NPLSX,ES2NPLSY,EW1NPLSX,EW1NPLSY,UX,VX, &
+     & DEL2INPLSX,DEL2INPLSY,DZZ(KTE)
+       INTEGER KRR,I_START,I_END,J_START,J_END
+   
+       REAL DTFREEZ_XYZ(ITE,KTE,JTE),DSUPICE_XYZ(ITE,KTE,JTE)
+
+       REAL DXHUCM,DYHUCM
+       REAL FMAX1,FMAX2,FMAX3,FMAX4,FMAX5
+       INTEGER ISYM1,ISYM2,ISYM3,ISYM4,ISYM5
+       INTEGER DIFFU
+       REAL DELTAW
+       real zcgs_z(kts:kte),pcgs_z(kts:kte),rhocgs_z(kts:kte),ffx_z(kts:kte,nkr)
+       real z_full
+! SLOPE INTERCEPT FOR RAIN, SNOW, AND GRAUPEL                                    PARAMR.32
+!     RON=8.E6                                                                   PARAMR.33
+!     RON2=1.E10                                                                 23DEC04.211
+!     RON2=1.E9                                                                  23DEC04.212
+!     SON=2.E7                                                                   PARAMR.36
+!     GON=5.E7                                                                   23DEC04.213
+!     GON=4.E6
+       REAL, PARAMETER :: RON=8.E6, GON=5.E7
+       REAL EFF_N,EFF_D
+       real nzero,son,nzero_less
+       parameter (son=2.E7)
+       real raddumb(nkr),massdumb(nkr)
+       real hydrosum
+
+       integer imax,kmax,jmax
+       real gmax
+       real tmax,qmax,divmax,rainmax
+       real qnmax,inmax,knmax
+       real hydro
+       real difmax,tdif,tt_old,w_stag,qq_old
+       real teten,es
+      REAL, DIMENSION(kts:kte)::                            &
+                      qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
+      REAL, DIMENSION(kts:kte):: dBZ
+
+       integer  print_int
+       parameter (print_int=300)
+
+       integer t_print,xlong10
+       t_print=print_int/dt
+
+       difmax = 0
+!      print*,'itimestep = ',itimestep
+!        if (itimestep.gt.150)return
+        if (itimestep.eq.1)then
+         if (iceprocs.eq.1) call wrf_message("SBM FAST: ICE PROCESES ACTIVE")
+         if (iceprocs.eq.0) call wrf_message("SBM FAST: LIQUID PROCESES ONLY")
+        print*,'num_chem = ',n_chem
+        end if
+       tmax = 0
+! COAL BOTT IS EITHER CALLED EVERY TIME STEP OR TWICE
+       NCOND = 0
+!       if (mod(dx,1000.).eq.0)then
+!       NCOND=dx/1000
+!       else if (mod(dx,2000.).eq.0)then
+!       NCOND=dx/500
+!       else if (mod(dx,3000.).eq.0)then
+!       NCOND=dx/1000
+!       else if (mod(dx,4000.).eq.0)then
+!       NCOND=dx/1000
+!       else if (mod(dx,1333.).eq.0)then
+!       NCOND=dx/1.3333
+!       end if
+       NCOND=nint(dx/1000)
+
+ !      IF (NCOND.EQ.0)NCOND=3
+       NCOND=max(NCOND,1)
+       DTCOND=DT/NCOND
+       dt_coll=dt
+       call kernals(dt)
+!      if (itimestep.eq.1.or.itimestep.eq.3)then
+!            do kr = 1,nkr
+!             print*,'xl = ',xl(kr),vr1(kr),RLEC(kr),RO1BL(kr)
+!             print*,'xi = ',xi(kr,1),vr2(kr,1),RIEC(KR,1),RO2BL(KR,1)
+!             print*,'xi = ',xi(kr,2),vr2(kr,2),RIEC(KR,2),RO2BL(KR,2)
+!             print*,'xi = ',xi(kr,3),vr2(kr,3),RIEC(KR,3),RO2BL(KR,3)
+!             print*,'xs = ',xs(kr),vr3(kr),RSEC(kr),RO3BL(kr)
+!             print*,'xg = ',xg(kr),vr4(kr),RGEC(kr),RO4BL(kr)
+!             print*,'xh = ',xh(kr),vr5(kr),RHEC(kr),RO5BL(kr)
+!            end do
+!       end if
+
+!
+      DEL_BB=BB2_MY-BB1_MY
+      DEL_BBN=BB2_MYN-BB1_MYN
+      DEL_BBR=BB1_MYN/DEL_BBN
+!
+      if (conserv)then
+      DO j = jts,jte
+      DO i = its,ite
+      DO k = kts,kte
+      rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
+      KRR=0
+      DO kr=p_ff1i01,p_ff1i33
+      KRR=KRR+1
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KRR)/XL(KRR)/3.0
+      END DO
+      KRR=0
+      DO KR=p_ff5i01,p_ff5i33
+        KRR=KRR+1
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3.0
+      END DO
+      KRR=0
+      DO KR=p_ff6i01,p_ff6i33
+        KRR=KRR+1
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3.0
+      END DO
+      KRR=0
+      DO KR=p_ff8i01,p_ff8i33
+        KRR=KRR+1
+! change by J. Fan
+!        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/XCCN(KRR)
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/1000.   ! chem_new (input) is #/kg
+      END DO
+      END DO
+      END DO
+      END DO
+      end if
+
+      call kernals(dt)
+
+      DXHUCM=100.*DX
+      DYHUCM=100.*DY
+
+! JIMY
+      I_START=MAX(1,ITS-1)
+      J_START=MAX(1,JTS-1)
+      I_END=MIN(IDE-1,ITE+1)
+      J_END=MIN(JDE-1,JTE+1)
+!     print*,'ide-1 = ',ide-1
+!     print*,'jde-1 = ',jde-1
+!     print*,'kte = ',kte
+!     print*,'i_start,i_end = ',i_start,i_end
+!     print*,'j_start,j_end = ',j_start,j_end
+!     print*,'its,ite = ',its,ite
+!     print*,'jts,jte = ',jts,jte
+      if (itimestep.eq.1)then
+      DO j = j_start,j_end
+      DO k = kts,kte
+      DO i = i_start,i_end
+         th_old(i,k,j)=th_phy(i,k,j)
+         qv_old(i,k,j)=qv(i,k,j)
+      END DO
+      END DO
+      END DO
+      end if
+      DO j = j_start,j_end
+      DO k = kts,kte
+      DO i = i_start,i_end
+        t_new(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j)
+        t_old(i,k,j) = th_old(i,k,j)*pi_phy(i,k,j)
+      ENDDO
+      ENDDO
+      ENDDO
+      DO j = j_start,j_end
+      DO i = i_start,i_end
+      z_full=0.
+      DO k = kts,kte
+          pcgs(I,K,J)=P_PHY(I,K,J)*10.
+          rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
+          zcgs(I,K,J)=z_full+0.5*dz8w(I,K,J)*100
+          z_full=z_full+dz8w(i,k,j)*100.
+      ENDDO
+      ENDDO
+      ENDDO
+ 
+!!!!!
+         if (itimestep.eq.1)then
+!      DO j = j_start,j_end
+!      DO i = i_start,i_end
+       DO j = jts,jte
+       DO i = its,ite
+       DO k = kts,kte
+         IF (zcgs(I,K,J).LE.ZMIN)THEN
+            FACTZ=1.
+         ELSE
+            FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
+         END IF
+!        FACTZ = 1
+         KRR=0
+         DO KR=p_ff8i01,p_ff8i33
+          KRR=KRR+1
+          if (xland(i,j).eq.1.and.(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.1))then
+             chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ
+          else
+             chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
+          end if
+!         if (dx.ge.4500)then
+!         if (xlat(i,j).ge.10.and.xlat(i,j).le.30.and.zcgs(i,k,j).le.300000)then
+!             chem_new(I,K,J,KR)=FCCNR_MIX(KRR)
+!         end if
+!         end if
+
+         END DO
+       end do
+       end do
+       end do
+         end if
+       if (itimestep.ne.1.and.dx.gt.dx_bound)then  
+       DO j = jts,jte
+       DO k = kts,kte
+       DO i = its,ite
+        if (i.le.5.or.i.ge.IDE-5.OR. &
+     &       j.le.5.or.j.ge.JDE-5)THEN
+         IF (zcgs(I,K,J).LE.ZMIN)THEN
+            FACTZ=1.
+         ELSE
+            FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
+         END IF
+         KRR=0
+         DO kr=p_ff8i01,p_ff8i33
+          KRR=KRR+1
+          if (xland(i,j).eq.1.and.(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.1))then
+             chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ
+          else
+             chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
+          end if
+         End do
+        end if
+       end do
+       end do
+       end do
+       end if
+
+!     print*,'dxhucm = ',dxhucm
+!     print*,'dyhucm = ',dyhucm
+!
+!-----------------------------------------------------------------------
+!**********************************************************************
+!-----------------------------------------------------------------------
+!
+!
+!     print*,'here at 1'
+      DO j = jts,jte
+      DO i = its,ite
+      DO k = kts,kte
+       IF(K.EQ.KTE)THEN
+        DZZ(K)=(zcgs(I,K,J)-zcgs(I,K-1,J))
+       ELSE IF(K.EQ.1)THEN
+        DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K,J))
+       ELSE
+        DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K-1,J))
+       END IF
+       ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
+       EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
+       SUPICE(K)=EW1N/ES2N-1.
+       IF(SUPICE(K).GT.0.5) SUPICE(K)=.5
+ 
+      END DO
+      DO k = kts,kte
+       IF(T_OLD(I,K,J).GE.238.15.AND.T_OLD(I,K,J).LT.274.15) THEN
+       if (k.lt.kte)then       
+        w_stag=50.*(w(i,k,j)+w(i,k+1,j)) 
+       else
+        w_stag=100*w(i,k,j)
+       end if
+             IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
+              UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
+              VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
+             ELSE
+              UX=U(I,K,J)*100.
+              VX=V(I,K,J)*100.
+             END IF  
+             IF(K.EQ.1) DERIVT_Z=(T_OLD(I,K+1,J)-T_OLD(I,K,J))/DZZ(K)
+             IF(K.EQ.KTE) DERIVT_Z=(T_OLD(I,K,J)-T_OLD(I,K-1,J))/DZZ(K)
+             IF(K.GT.1.AND.K.LT.KTE) DERIVT_Z= &
+     &        (T_OLD(I,K+1,J)-T_OLD(I,K-1,J))/DZZ(K)
+             IF (I.EQ.1)THEN
+              DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I,K,J))/(DXHUCM)
+             ELSE IF (I.EQ.IDE-1)THEN
+              DERIVT_X=(T_OLD(I,K,J)-T_OLD(I-1,K,J))/(DXHUCM)
+             ELSE
+              DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I-1,K,J))/(2.*DXHUCM)
+             END IF
+             IF (J.EQ.1)THEN
+              DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J))/(DYHUCM)
+             ELSE IF (J.EQ.JDE-1)THEN
+              DERIVT_Y=(T_OLD(I,K,J)-T_OLD(I,K,J-1))/(DYHUCM)
+             ELSE
+              DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J-1))/(2.*DYHUCM)
+             END IF
+             DTFREEZ_XYZ(I,K,J)=DT*(VX*DERIVT_Y+ &
+     &            UX*DERIVT_X+w_stag*DERIVT_Z)
+          ELSE
+             DTFREEZ_XYZ(I,K,J)=0.
+          ENDIF
+          IF(SUPICE(K).GE.0.02.AND.T_OLD(I,K,J).LT.268.15) THEN
+            IF (I.LT.IDE-1)THEN
+             ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I+1,K,J))
+             EW1NPLSX=QV_OLD(I+1,K,J)*pcgs(I+1,K,J)/ &
+     &               (0.622+0.378*QV_OLD(I+1,K,J))
+            ELSE
+             ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
+             EW1NPLSX=QV_OLD(I,K,J)*pcgs(I,K,J)/ &
+     &               (0.622+0.378*QV_OLD(I,K,J))
+            END IF
+            IF (ES2NPLSX.EQ.0)THEN
+             DEL2INPLSX=0.5
+            ELSE
+             DEL2INPLSX=EW1NPLSX/ES2NPLSX-1.
+            END IF
+            IF(DEL2INPLSX.GT.0.5) DEL2INPLSX=.5
+            IF (I.GT.1)THEN
+             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I-1,K,J))
+             EW1N=QV_OLD(I-1,K,J)*pcgs(I-1,K,J)/(0.622+0.378*QV_OLD(I-1,K,J))
+            ELSE
+             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
+             EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
+            END IF
+            DEL2IN=EW1N/ES2N-1.
+            IF(DEL2IN.GT.0.5) DEL2IN=.5
+            IF (I.GT.1.AND.I.LT.IDE-1)THEN
+             DERIVS_X=(DEL2INPLSX-DEL2IN)/(2.*DXHUCM)
+            ELSE
+             DERIVS_X=(DEL2INPLSX-DEL2IN)/(DXHUCM)
+            END IF
+            IF (J.LT.JDE-1)THEN
+             ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J+1))
+             EW1NPLSY=QV_OLD(I,K,J+1)*pcgs(I,K,J+1)/(0.622+0.378*QV_OLD(I,K,J+1))
+            ELSE
+             ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
+             EW1NPLSY=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
+            END IF
+            DEL2INPLSY=EW1NPLSY/ES2NPLSY-1.
+            IF(DEL2INPLSY.GT.0.5) DEL2INPLSY=.5
+            IF (J.GT.1)THEN
+             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J-1))
+             EW1N=QV_OLD(I,K,J-1)*pcgs(I,K,J-1)/(0.622+0.378*QV_OLD(I,K,J-1))
+            ELSE
+             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
+             EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
+            END IF
+             DEL2IN=EW1N/ES2N-1.
+            IF(DEL2IN.GT.0.5) DEL2IN=.5
+            IF (J.GT.1.AND.J.LT.JDE-1)THEN
+             DERIVS_Y=(DEL2INPLSY-DEL2IN)/(2.*DYHUCM)
+            ELSE
+             DERIVS_Y=(DEL2INPLSY-DEL2IN)/(DYHUCM)
+            END IF
+!
+            IF (K.EQ.1)DERIVS_Z=(SUPICE(K+1)-SUPICE(K))/DZZ(K)
+            IF (K.EQ.KTE)DERIVS_Z=(SUPICE(K)-SUPICE(K-1))/DZZ(K)
+            IF(K.GT.1.and.K.LT.KTE) DERIVS_Z=(SUPICE(K+1)-SUPICE(K-1))/DZZ(K)
+            IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
+             UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
+             VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
+            ELSE
+             UX=U(I,K,J)*100.
+             VX=V(I,K,J)*100.
+            END IF  
+            DSUPICE_XYZ(I,K,J)=(UX*DERIVS_X+VX*DERIVS_Y+ &
+      &                        w_stag*DERIVS_Z)*DTCOND
+          ELSE
+            DSUPICE_XYZ(I,K,J)=0.0
+          END IF
+         END DO
+         END DO
+         END DO
+     
+
+      do j = jts,jte
+      do i = its,ite
+      do k = kts,kte
+!     if (i.eq.214.and.j.eq.60.and.k.eq.14)then
+!     if (i.eq.214.and.j.eq.60)then
+!     print*,'i,j = ',i,j,k
+!     end if
+!     print*,'i,j = ',i,j,k
+!     print*,'i,j,k = ',i,j,k
+! LIQUID
+!      do kr=1,nkr
+!       if (ff4r(kr).lt.0)then
+!        print*,'i,k,j = ',i,k,j
+!        print*,'ff4r 0 = ',kr,ff4r(kr)
+!       end if
+!      end do
+
+          KRR=0
+          DO KR=p_ff1i01,p_ff1i33
+          KRR=KRR+1
+!          FF1R(KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KR)/XL(KR)/3
+           FF1R(KRR)=chem_new(I,K,J,KR)
+           IF (FF1R(KRR).LT.0)FF1R(KRR)=0.
+          END DO
+!        DO KR=1,NKR
+!          FF1R(KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KR)/XL(KR)/3
+!          IF (FF1R(KR).LT.0)FF1R(KR)=0.
+!         END DO   
+! CCN
+        KRR=0
+        DO KR=p_ff8i01,p_ff8i33
+          KRR=KRR+1
+!         FCCN(KRR)=chem_new(I,K,J,KR)
+!         FCCN(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/XCCN(KRR)
+          FCCN(KRR)=chem_new(I,K,J,KR)
+          if (fccn(krr).lt.0)fccn(krr)=0.
+        END DO
+        IF (ICEPROCS.EQ.1)THEN
+! COLUMNS!
+         KRR=0
+         DO KR=NKR+1,NKR*2
+          KRR=KRR+1
+          FF2R(KRR,1)=0.
+         END DO
+! PLATES!
+         KRR=0
+         DO KR=NKR*2+1,NKR*3
+          KRR=KRR+1
+          FF2R(KRR,2)=0.
+         END DO
+! DENDRITES!
+         KRR=0
+         DO KR=NKR*3+1,NKR*4
+          KRR=KRR+1
+          FF2R(KRR,3)=0.
+         END DO
+! SNOW
+           KRR=0
+           DO KR=p_ff5i01,p_ff5i33
+            KRR=KRR+1
+!           FF3R(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3
+            FF3R(KRR)=chem_new(I,K,J,KR)
+            if (ff3r(krr).lt.0)ff3r(krr)=0.
+           END DO
+
+!          KRR=0
+!          DO KR=NKR*1+1,NKR*2
+!           KRR=KRR+1
+!           FF3R(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3
+!           if (ff3r(krr).lt.0)ff3r(krr)=0.
+!          END DO
+! Graupel
+           KRR=0
+           DO KR=p_ff6i01,p_ff6i33
+            KRR=KRR+1
+!           FF4R(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3
+            FF4R(KRR)=chem_new(I,K,J,KR)
+            IF (FF4R(KRR).LT.0)FF4R(KRR)=0.
+           END DO
+
+!          KRR=0
+!          DO KR=NKR*2+1,NKR*3
+!           KRR=KRR+1
+!           FF4R(KRR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3
+!           IF (FF4R(KRR).LT.0)FF4R(KRR)=0.
+!          END DO   
+! Hail
+         KRR=0
+         DO KR=NKR*6+1,NKR*7
+          KRR=KRR+1
+          FF5R(KRR)=0.
+          if (ff5r(krr).lt.0)ff5r(krr)=0.
+         END DO
+!
+!     if (i.eq.43.and.k.eq.6.and.j.eq.41)then
+!      print*,'here 2'
+!     end if
+
+!      do kr=1,nkr
+!       if (ff4r(kr).lt.0)then
+!        print*,'i,k,j = ',i,k,j
+!        print*,'ff4r 1 = ',kr,ff4r(kr)
+!       end if
+!      end do
+         CALL FREEZ &
+     &     (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
+     &      T_NEW(I,K,J),DT,rhocgs(I,K,J), &
+     &      COL,AFREEZMY,BFREEZMY,BFREEZMAX, &
+     &      KRFREEZ,ICEMAX,NKR)
+         IF (ORIGINAL_MELT)THEN
+         CALL ORIG_MELT  &
+     &    (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
+     &     T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR)
+         END IF
+         IF (JIWEN_FAN_MELT) THEN
+         CALL J_W_MELT &
+     &    (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
+     &     T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR)
+         END IF
+
+        ENDIF
+!      do kr=1,nkr
+!       if (ff4r(kr).lt.0)then
+!        print*,'i,k,j = ',i,k,j
+!        print*,'ff4r 2 = ',ff4r(kr)
+!       end if
+!       end do
+!     if(i.eq.64.and.j.eq.2.and.k.eq.16)then
+!        print*,'T_NEW(I,K,J) = ',T_NEW(I,K,J)
+!        print*,'T_OLD(I,K,J) = ',T_OLD(I,K,J)
+!     end if
+        DO KR=1,NKR
+         DO ICE=1,ICEMAX
+             FF3R(KR)=FF3R(KR)+FF2R(KR,ICE)
+             FF2R(KR,ICE)=0.
+         ENDDO
+         FF4R(KR)=FF4R(KR)+FF5R(KR)
+         FF5R(KR)=0.
+        END DO
+!      do kr=1,nkr
+!       if (ff4r(kr).lt.0)then
+!        print*,'i,k,j = ',i,k,j
+!        print*,'ff4r 3 = ',ff4r(kr)
+!       end if
+!       end do
+        IF (T_OLD(I,K,J).GT.233)THEN     
+         TT=T_OLD(I,K,J)
+         QQ=QV_OLD(I,K,J)
+         IF (QQ.LE.0)  call wrf_message("WARNING : SBM FAST: QQ < 0")
+         IF (QQ.LE.0)QQ=1.D-10
+         PP=pcgs(I,K,J)
+         TTA=T_NEW(I,K,J)
+         QQA=QV(I,K,J)
+         IF (QQA.LE.0) call wrf_message("WARNING : SBM FAST: QQA < 0")
+    !     IF (QQA.LE.0)print*,'QQA = ',qqa
+    !     IF (QQA.LE.0)print*,'i,k,j = ',i,k,j
+    !     IF (QQA.LE.0)print*,'tta = ',tta
+    !     IF (QQA.LE.0)print*,'tt = ',tt
+    !     IF (QQA.LE.0)print*,'qq = ',qq
+         IF (QQA.LE.0)QQA=1.D-10
+         ES1N=AA1_MY*DEXP(-BB1_MY/TT)
+         ES2N=AA2_MY*DEXP(-BB2_MY/TT)
+         EW1N=QQ*PP/(0.622+0.378*QQ)
+         DIV1=EW1N/ES1N
+!     if(i.eq.64.and.j.eq.2.and.k.eq.16)then
+!        print*,'T_NEW(I,K,J) = ',T_NEW(I,K,J)
+!        print*,'tt = ',tt
+!        print*,'qq = ',qq
+!        print*,'tta = ',tta
+!        print*,'qqa = ',qqa
+!        print*,'ES1N = ',ES1N
+!        print*,'ES2N = ',ES2N
+!        print*,'EW1N = ',EW1N
+!        print*,'DIV1 = ',DIV1
+!        print*,'pp = ',pp
+!        print*,'zcgs = ',zcgs(i,k,j)
+!     end if
+
+         DEL1IN=EW1N/ES1N-1.
+         DIV2=EW1N/ES2N
+         DEL2IN=EW1N/ES2N-1.
+         ES1N=AA1_MY*DEXP(-BB1_MY/TTA)
+         ES2N=AA2_MY*DEXP(-BB2_MY/TTA)
+         EW1N=QQA*PP/(0.622+0.378*QQA)
+         DIV3=EW1N/ES1N
+         DEL1AD=EW1N/ES1N-1.
+         DIV4=EW1N/ES2N
+         DEL2AD=EW1N/ES2N-1.
+         SUP2_OLD=DEL2IN
+         DELSUP1=(DEL1AD-DEL1IN)/NCOND
+         DELSUP2=(DEL2AD-DEL2IN)/NCOND
+         DELDIV1=(DIV3-DIV1)/NCOND
+         DELDIV2=(DIV4-DIV2)/NCOND
+         DELTATEMP=0
+         DELTAQ=0
+         tt_old = TT
+         qq_old = qq
+!     if (i.eq.43.and.k.eq.6.and.j.eq.41)then
+!      print*,'here 4'
+!     end if
+         DIFFU=1
+         DO IKL=1,NCOND
+          IF (DIFFU.NE.0)THEN
+          DEL1IN=DEL1IN+DELSUP1
+          DEL2IN=DEL2IN+DELSUP2
+          DIV1=DIV1+DELDIV1
+          DIV2=DIV2+DELDIV2
+          END IF
+!959       format (' ',i3,1x,f7.1,1x,f6.1,1x,f6.4,1x,f6.2,1x,f6.3)
+          IF (DIV1.GT.DIV2.AND.TT.LE.265)THEN
+           call wrf_error_fatal("fatal error in module_mp_fast_sbm (DIV1>DIV2), model stop")
+           DIFFU=0
+          END IF
+          IF (DIFFU.NE.0)THEN
+          DEL1NR=A1_MYN*(100.*DIV1)
+          DEL2NR=A2_MYN*(100.*DIV2)
+ !         IF (DEL2NR.EQ.0) PRINT*,'DEL2NR = 0'
+          IF (DEL2NR.EQ.0)call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL2NR.EQ.0), model stop")
+          DEL12R=DEL1NR/DEL2NR
+          DEL12RD=DEL12R**DEL_BBR
+          EW1PN=AA1_MY*100.*DIV1*DEL12RD/100.
+!          IF (DEL12R.EQ.0)PRINT*,'DEL12R = 0'
+          IF (DEL12R.EQ.0)call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL12R.EQ.0), model stop")
+          TT=-DEL_BB/DLOG(DEL12R)
+          QQ=0.622*EW1PN/(PP-0.378*EW1PN)
+          DO KR=1,NKR
+            FF1IN(KR)=FF1R(KR)
+            DO ICE=1,ICEMAX
+             FF2IN(KR,ICE)=FF2R(KR,ICE)
+            ENDDO
+          ENDDO
+          IF (BULKNUC.eq.1)THEN
+            IF (DEL1IN.GT.0)THEN
+              IF (zcgs(I,K,J).LE.500.E2)THEN
+                FACTZ=0.
+              ELSE
+                FACTZ=1
+!               FACTZ=EXP(-(zcgs(I,K,J)-2.E5)/Z0IN)
+              END IF
+             CONCCCN_XZ=FACTZ*ACCN*(100.*DEL1IN)**BCCN
+
+             CONCDROP=0.D0
+
+             DO KR=1,NKR
+               CONCDROP=CONCDROP+FF1IN(KR)*XL(KR)
+             ENDDO
+
+             CONCDROP=CONCDROP*3.D0*COL
+             IF(CONCCCN_XZ.GT.CONCDROP) &
+     &       FF1IN(1)=FF1IN(1)+(CONCCCN_XZ-CONCDROP)/(3.D0*COL*XL(1))
+            END IF
+          ELSE
+            IF(DEL1IN.GT.0.OR.DEL2IN.GT.0)THEN
+             CALL JERNUCL01(FF1IN,FF2IN,FCCN &
+     &       ,XL,XI,TT,QQ &
+     &       ,rhocgs(I,K,J),pcgs(I,K,J) &
+     &       ,DEL1IN,DEL2IN &
+     &       ,COL,AA1_MY, BB1_MY, AA2_MY,BB2_MY &
+     &       ,C1_MEY,C2_MEY,SUP2_OLD,DSUPICE_XYZ(I,K,J) &
+     &       ,RCCN,DROPRADII,NKR,ICEMAX,ICEPROCS)
+            END IF
+          END IF
+          DO KR=1,NKR
+            DO ICE=1,ICEMAX
+             FF3R(KR)=FF3R(KR)+FF2IN(KR,ICE)
+             FF2IN(KR,ICE)=0.
+             FF2R(KR,ICE)=0.
+            END DO
+          END DO
+          DO KR=1,NKR
+            FF1R(KR)=FF1IN(KR)
+!           DO ICE=1,ICEMAX
+!            FF2R(KR,ICE)=FF2IN(KR,ICE)
+!           ENDDO
+          ENDDO
+          FMAX1=0.
+          FMAX2=0.
+          FMAX3=0.
+          FMAX4=0.
+          FMAX5=0.
+          DO KR=1,NKR
+            FF1IN(KR)=FF1R(KR)
+            FMAX1=AMAX1(FF1R(KR),FMAX1)
+            FF3IN(KR)=FF3R(KR)
+            FMAX3=AMAX1(FF3R(KR),FMAX3)
+            FF4IN(KR)=FF4R(KR)
+            FMAX4=AMAX1(FF4R(KR),FMAX4)
+            FF5IN(KR)=FF5R(KR)
+            FMAX5=AMAX1(FF5R(KR),FMAX5)
+            DO ICE=1,ICEMAX
+             FF2IN(KR,ICE)=FF2R(KR,ICE)
+             FMAX2=AMAX1(FF2R(KR,ICE),FMAX2)
+            END DO
+          END DO
+          ISYM1=0
+          ISYM2=0
+          ISYM3=0
+          ISYM4=0
+          ISYM5=0
+          IF(FMAX1.GT.0)ISYM1=1
+          IF (ICEPROCS.EQ.1)THEN
+           IF(FMAX2.GT.1.E-4)ISYM2=1
+           IF(FMAX3.GT.1.E-4)ISYM3=1
+           IF(FMAX4.GT.1.E-4)ISYM4=1
+           IF(FMAX5.GT.1.E-4)ISYM5=1
+          END IF
+! Avoid Diffusional Growth
+!         IF (T_OLD(I,K,J).GE.237)THEN     
+! Same temperature range as above.
+          IF (T_OLD(I,K,J).GT.233)THEN     
+          IF(ISYM1.EQ.1.AND.((TT-273.15).GT.-0.187.OR. &
+     &     (ISYM2.EQ.0.AND. &
+     &     ISYM3.EQ.0.AND.ISYM4.EQ.0.AND.ISYM5.EQ.0)))THEN
+           CALL ONECOND1(TT,QQ,PP,rhocgs(I,K,J) &
+     &      ,VR1,pcgs(I,K,J) &
+     &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
+     &      ,FF1R,FF1IN,XL,RLEC,RO1BL &
+     &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &      ,C1_MEY,C2_MEY &
+     &      ,COL,DTCOND,ICEMAX,NKR)
+          ELSE IF(ISYM1.EQ.0.AND.(TT-273.15).LE.-0.187.AND. &
+     &     (ISYM2.EQ.1.OR.ISYM3.EQ.1.OR.ISYM4.EQ.1.OR.ISYM5.EQ.1))THEN
+           CALL ONECOND2(TT,QQ,PP,rhocgs(I,K,J) &
+     &      ,VR2,VR3,VR4,VR5,pcgs(I,K,J) &
+     &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
+     &      ,FF2R,FF2IN,XI,RIEC,RO2BL &
+     &      ,FF3R,FF3IN,XS,RSEC,RO3BL &
+     &      ,FF4R,FF4IN,XG,RGEC,RO4BL &
+     &      ,FF5R,FF5IN,XH,RHEC,RO5BL &
+     &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &      ,C1_MEY,C2_MEY &
+     &      ,COL,DTCOND,ICEMAX,NKR &
+     &      ,ISYM2,ISYM3,ISYM4,ISYM5)
+          ELSE IF(ISYM1.EQ.1.AND.(TT-273.15).LE.-0.187.AND. &
+     &     (ISYM2.EQ.1.OR.ISYM3.EQ.1.OR.ISYM4.EQ.1 &
+     &     .OR.ISYM5.EQ.1))THEN
+           CALL ONECOND3(TT,QQ,PP,rhocgs(I,K,J) &
+     &      ,VR1,VR2,VR3,VR4,VR5,pcgs(I,K,J) &
+     &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
+     &      ,FF1R,FF1IN,XL,RLEC,RO1BL &
+     &      ,FF2R,FF2IN,XI,RIEC,RO2BL &
+     &      ,FF3R,FF3IN,XS,RSEC,RO3BL &
+     &      ,FF4R,FF4IN,XG,RGEC,RO4BL &
+     &      ,FF5R,FF5IN,XH,RHEC,RO5BL &
+     &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &      ,C1_MEY,C2_MEY &
+     &      ,COL,DTCOND,ICEMAX,NKR &
+     &      ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
+          END IF
+          DO KR=1,NKR
+            DO ICE=1,ICEMAX
+             FF3R(KR)=FF3R(KR)+FF2R(KR,ICE)
+             FF2R(KR,ICE)=0
+            END DO
+            FF4R(KR)=FF4R(KR)+FF5R(KR)
+            FF5R(KR)=0
+          END DO
+          END IF
+          END IF
+             IF (IKL.EQ.NCOND)CALL COAL_BOTT_NEW(FF1R,FF2R,FF3R, &
+     &       FF4R,FF5R,TT,QQ,PP,rhocgs(I,K,J),dt_coll,TCRIT,TTCOAL)
+         END DO
+         IF (DIFFU.EQ.0)THEN
+         th_phy(i,k,j) = tt_old/pi_phy(i,k,j)
+         qv(i,k,j)=qq_old
+    !     print*,'tt_old = ',tt_old
+    !     print*,'qq_old = ',qq_old
+         ELSE
+         th_phy(i,k,j) = tt/pi_phy(i,k,j)
+         qv(i,k,j)=qq
+         END IF
+        END IF
+! LIQIUD
+        IF (REMSAT.EQ.1)THEN
+        DO KR=1,NKR
+         FF1R(KR)=0.
+         FCCN(KR)=0
+         IF (ICEPROCS.EQ.1)THEN
+          FF2R(KR,1)=0.
+          FF2R(KR,2)=0.
+          FF2R(KR,3)=0.
+          FF3R(KR)=0.
+          FF4R(KR)=0.
+          FF5R(KR)=0.
+         END IF
+        END DO
+        END IF
+        KRR=0
+        DO KR=p_ff1i01,p_ff1i33
+          KRR=KRR+1
+          chem_new(I,K,J,KR)=FF1R(KRR)
+        END DO   
+! CCN
+        KRR=0
+        DO KR=p_ff8i01,p_ff8i33
+          KRR=KRR+1
+!         chem_new(I,K,J,KR)=FCCN(KRR)
+!         chem_new(I,K,J,KR)=FCCN(KRR)/RHOCGS(I,K,J)*XCCN(KRR)
+          chem_new(I,K,J,KR)=FCCN(KRR)
+        END DO
+        IF (ICEPROCS.EQ.1)THEN
+         KRR=0
+         DO KR=p_ff5i01,p_ff5i33
+          KRR=KRR+1
+!         chem_new(I,K,J,KR)=FF3R(KRR)
+!         chem_new(I,K,J,KR)=FF3R(KRR)*(1./RHOCGS(I,K,J))*COL*XS(KRR)*XS(KRR)*3
+          chem_new(I,K,J,KR)=FF3R(KRR)
+         END DO
+! Graupel
+         KRR=0
+         DO KR=p_ff6i01,p_ff6i33
+          KRR=KRR+1
+!         chem_new(I,K,J,KR)=FF4R(KRR)
+!         chem_new(I,K,J,KR)=FF4R(KRR)*(1./RHOCGS(I,K,J))*COL*XG(KRR)*XG(KRR)*3
+          chem_new(I,K,J,KR)=FF4R(KRR)
+         END DO
+        END IF
+      END DO
+      END DO
+      END DO
+      NKRO=1
+      NKRE=NKR
+      DO j = jts,jte
+      DO i = its,ite
+      DO k = kts,kte
+      rhocgs_z(k)=rhocgs(i,k,j)
+      pcgs_z(k)=pcgs(i,k,j)
+      zcgs_z(k)=zcgs(i,k,j)
+      krr=0
+      do kr=p_ff1i01,p_ff1i33
+       krr=krr+1
+       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
+      end do
+      end do
+      CALL FALFLUXHUCM(ffx_z,VR1,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
+      DO k = kts,kte
+      krr=0
+      do kr=p_ff1i01,p_ff1i33
+       krr=krr+1
+       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
+      end do
+      end do
+      if (iceprocs.eq.1)then
+      DO k = kts,kte
+      rhocgs_z(k)=rhocgs(i,k,j)
+      pcgs_z(k)=pcgs(i,k,j)
+      zcgs_z(k)=zcgs(i,k,j)
+      krr=0
+      do kr=p_ff5i01,p_ff5i33
+       krr=krr+1
+       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
+      end do
+      end do
+      CALL FALFLUXHUCM(ffx_z,VR3,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
+      DO k = kts,kte
+      krr=0
+      do kr=p_ff5i01,p_ff5i33
+       krr=krr+1
+       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
+      end do
+      end do
+      DO k = kts,kte
+      rhocgs_z(k)=rhocgs(i,k,j)
+      pcgs_z(k)=pcgs(i,k,j)
+      zcgs_z(k)=zcgs(i,k,j)
+      krr=0
+      do kr=p_ff6i01,p_ff6i33
+       krr=krr+1
+       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
+      end do
+      end do
+      CALL FALFLUXHUCM(ffx_z,VR4,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
+      DO k = kts,kte
+      krr=0
+      do kr=p_ff6i01,p_ff6i33
+       krr=krr+1
+       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
+      end do
+      end do
+!    &     ims,ime,jms,jme,kms,kme)
+      end if
+     end do 
+     end do 
+
+      gmax=0
+      qmax=0
+      imax=0
+      kmax=0
+      qnmax=0
+      inmax=0
+      knmax=0
+      DO j = jts,jte
+      DO i = its,ite
+      DO k = kts,kte
+      QC(I,K,J)=0
+      QR(I,K,J)=0
+!     QI(I,K,J)=0
+!     QIC(I,K,J)=0
+!     QIP(I,K,J)=0
+!     QID(I,K,J)=0
+      QI(I,K,J)=0
+      QS(I,K,J)=0
+      QG(I,K,J)=0
+      QNC(I,K,J)=0
+      QNR(I,K,J)=0
+      QNS(I,K,J)=0
+      QNG(I,K,J)=0
+      QNA(I,K,J)=0
+!     EFFR(I,K,J)=0
+!     if (mod(itimestep,t_print).eq.0)then
+      tt= th_phy(i,k,j)*pi_phy(i,k,j)
+      DO KR=1,NKR
+      COLREFLL(KR)=COEFREFLL
+      COLREFLI(KR)=COEFREFLI
+        IF(TT.GE.271.15.AND.TT.LE.273.15) THEN
+               COLREFLS(KR)=COEFREF00/0.09
+               COLREFLG(KR)=COEFREF00/RO4BL(KR)/RO4BL(KR)
+               COLREFLH(KR)=COEFREF00/RO5BL(KR)/RO5BL(KR)
+        ELSE
+               COLREFLS(KR)=COEFREFLI
+               COLREFLG(KR)=COEFREFLI
+               COLREFLH(KR)=COEFREFLI
+        ENDIF
+      END DO
+!     END IF
+      EFF_N=0.
+      EFF_D=0.
+      krr=0
+      DO kr= p_ff1i01,p_ff1i33
+          KRR=KRR+1
+        IF (KRR.LT.KRDROP)THEN
+          EFF_N=DROPRADII(KRR)**3*chem_new(i,k,j,KR)*XL(KRR)+EFF_N
+          EFF_D=DROPRADII(KRR)**2*chem_new(i,k,j,KR)*XL(KRR)+EFF_D
+          QC(I,K,J)=QC(I,K,J) &
+     &      +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3
+!          QNC(I,K,J)=QNC(I,K,J) &
+! J. Fan
+!     &      +COL*chem_new(I,K,J,KR)*XL(KR)*3
+           QNC(I,K,J)=QNC(I,K,J) &
+    &       +COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg
+        ELSE
+          QR(I,K,J)=QR(I,K,J) &
+     &      +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3
+          QNR(I,K,J)=QNR(I,K,J) &
+     &      +COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
+        END IF
+      END DO
+!     IF(QC(I,K,J).GT.1.E-6.and.EFF_D.GT.0)THEN
+!         EFFR(I,K,J)=EFF_N/EFF_D
+!     END IF
+      KRR=0
+      IF (ICEPROCS.EQ.1)THEN
+       KRR=0
+       DO  KR=p_ff5i01,p_ff5i33
+        KRR=KRR+1
+        if (KRR.LE.KRICE)THEN
+        QI(I,K,J)=QI(I,K,J) &
+     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3
+        ELSE
+        QS(I,K,J)=QS(I,K,J) &
+     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3
+        END IF
+        QNS(I,K,J)=QNS(I,K,J) &
+!     &   +1000*COL*chem_new(I,K,J,KR)*XS(KRR)*3
+     &   +COL*chem_new(I,K,J,KR)*XS(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
+       END DO
+       KRR=0
+       DO  KR=p_ff6i01,p_ff6i33
+        KRR=KRR+1
+        QG(I,K,J)=QG(I,K,J) &
+     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XG(KRR)*XG(KRR)*3
+        QNG(I,K,J)=QNG(I,K,J) &
+!     &   +1000*COL*chem_new(I,K,J,KR)*XG(KRR)*3
+     &   +COL*chem_new(I,K,J,KR)*XG(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
+       END DO
+      END IF
+       KRR=0
+       DO  KR=p_ff8i01,p_ff8i33
+        KRR=KRR+1
+        QNA(I,K,J)=QNA(I,K,J) &
+!     &   +COL*chem_new(I,K,J,KR)*3
+!  change by J.Fan
+     &   +COL*chem_new(I,K,J,KR)/rhocgs(I,K,J)*1000.   ! #/kg
+       END DO
+
+      END DO
+      END DO
+      END DO
+
+
+
+998   format(' ',10(f10.1,1x))
+      DO j = jts,jte
+      DO i = its,ite
+       krr=0
+       DO KR=p_ff1i01,p_ff1i33
+        krr=krr+1
+        DELTAW=VR1(KRR)
+        RAINNC(I,J)=RAINNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
+       END DO
+       KRR=0
+       DO KR= p_ff5i01,p_ff5i33
+        KRR=KRR+1
+        DELTAW=VR3(KRR)
+        RAINNC(I,J)=RAINNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
+       END DO
+       KRR=0
+       DO KR=p_ff6i01,p_ff6i33
+        KRR=KRR+1
+        DELTAW=VR4(KRR)
+        RAINNC(I,J)=RAINNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
+       END DO
+      do k=kts,kte
+
+
+          qv1d(k)=qv(i,k,j)
+          qr1d(k)=qr(i,k,j)
+          nr1d(k)=qnr(i,k,j)
+          qs1d(k)=qs(i,k,j)
+          ns1d(k)=qns(i,k,j)
+          qg1d(k)=qg(i,k,j)
+          ng1d(k)=qng(i,k,j)
+          t1d(k)=th_phy(i,k,j)*pi_phy(i,k,j)
+          p1d(k)=P_PHY(I,K,J)
+       end do
+! wrf-chem
+
+!+---+-----------------------------------------------------------------+
+         IF ( PRESENT (diagflag) ) THEN
+         if (diagflag .and. do_radar_ref == 1) then
+          call refl10cm_hm (qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d,   &
+                      t1d, p1d, dBZ, kts, kte, i, j)
+          do k = kts, kte
+             refl_10cm(i,k,j) = MAX(-35., dBZ(k))
+          enddo
+         endif
+         ENDIF
+
+!     print*, i,j,rainnc(i,j)
+      END DO
+      END DO
+
+
+      do j=jts,jte
+      do k=kts,kte
+      do i=its,ite
+         th_old(i,k,j)=th_phy(i,k,j)
+         qv_old(i,k,j)=qv(i,k,j)
+      end do
+      end do
+      end do
+      if (conserv)then
+      DO j = jts,jte
+      DO i = its,ite
+      DO k = kts,kte
+      rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
+      krr=0
+      DO KR=p_ff1i01,p_ff1i33
+        krr=krr+1
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XL(KRR)*XL(KRR)*3.0
+      END DO
+      KRR=0
+      DO KR=p_ff5i01,p_ff5i33
+       KRR=KRR+1
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XS(KRR)*XS(KRR)*3.0
+      END DO
+      KRR=0
+      DO KR=p_ff6i01,p_ff6i33
+       KRR=KRR+1
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XG(KRR)*XG(KRR)*3.0
+      END DO
+      KRR=0
+      DO KR=p_ff8i01,p_ff8i33
+       KRR=KRR+1
+! change by Fan
+!       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*XCCN(KRR)
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*1000.          ! #/kg; remember chem_new for CCN is #/cm3, not #/(gcm-3)
+      END DO
+      END DO
+      END DO
+      END DO
+      END IF
+     
+      RETURN
+  END SUBROUTINE FAST_SBM
+      SUBROUTINE FALFLUXHUCM(chem_new,VR1,RHOCGS,PCGS,ZCGS,DT, &
+     &     kts,kte,nkr)
+      IMPLICIT NONE
+      INTEGER I,J,K,KR
+      INTEGER    kts,kte,nkr
+      REAL TFALL,DTFALL,VFALL(KTE),DWFLUX(KTE)
+      REAL DT
+      INTEGER IFALL,N,NSUB
+      REAL, DIMENSION( kts:kte,nkr ) :: chem_new 
+      REAL,  DIMENSION(kts:kte) :: rhocgs,pcgs,zcgs
+      REAL VR1(NKR)
+
+! FALLING FLUXES FOR EACH KIND OF CLOUD PARTICLES: C.G.S. UNIT
+! ADAPTED FROM GSFC CODE FOR HUCM
+!  The flux at k=1 is assumed to be the ground so FLUX(1) is the
+! flux into the ground. DWFLUX(1) is at the lowest half level where
+! Q(1) etc are defined. The formula for FLUX(1) uses Q(1) etc which
+! is actually half a grid level above it. This is what is meant by
+! an upstream method. Upstream in this case is above because the
+! velocity is downwards.      
+! USE UPSTREAM METHOD (VFALL IS POSITIVE)                 
+!        print*,'pcgs(i,k,j) = ',pcgs(100,10,1)
+!        print*,'pcgs(i,k,j) = ',pcgs(100,1,1)
+!      read(5,*)
+!        print*,'pcgs(i,k,j) = ',zcgs(100,10,1)
+!        print*,'pcgs(i,k,j) = ',zcgs(100,1,1)
+!      read(5,*)
+      DO KR=1,NKR
+       IFALL=0
+       DO k = kts,kte
+          IF(chem_new(K,KR).GE.1.E-10)IFALL=1
+       END DO 
+       IF (IFALL.EQ.1)THEN
+        TFALL=1.E10                
+        DO K=kts,kte
+         VFALL(K) = VR1(KR)*SQRT(1.E6/PCGS(K))
+!        if (krr.eq.20.or.krr.eq.33)then
+!        if (k.eq.5.or.k.eq.10.or.k.eq.20)then
+!        print*,'vr1(krr) = ',krr,vr1(krr)
+!        print*, 'SQRT(1.E6/PCGS(I,K,J)) = ',i,k,SQRT(1.E6/PCGS(I,K,J))
+!        print*,'vfall(k) = ',i,k,vfall(k)
+!        print*,'zcgs(k) = ',i,k,zcgs(i,k,j)
+!        read(5,*)
+!        end if
+!        end if
+         TFALL=AMIN1(TFALL,ZCGS(K)/(VFALL(K)+1.E-20))    
+!        print*,'tfall = ',i,k,tfall
+!        if (krr.eq.5.or.krr.eq.10.or.krr.eq.20.or.krr.eq.33)read(5,*)
+        END DO                                                 
+        IF(TFALL.GE.1.E10)call wrf_error_fatal("fatal error in module_mp_fast_sbm (TFALL.GE.1.E10), model stop")
+        NSUB=(INT(2.0*DT/TFALL)+1)                           
+        DTFALL=DT/NSUB                                      
+
+        DO N=1,NSUB                                    
+          DO K=KTS,KTE-1                               
+           DWFLUX(K)=-(RHOCGS(K)*VFALL(K)*chem_new(k,kr)- &
+     &     RHOCGS(K+1)* &
+     &     VFALL(K+1)*chem_new(K+1,KR))/(RHOCGS(K)*(ZCGS(K+1)- &
+     &      ZCGS(K)))    
+          END DO    
+! NO Z ABOVE TOP, SO USE THE SAME DELTAZ
+          DWFLUX(KTE)=-(RHOCGS(KTE)*VFALL(KTE)* & 
+     &       chem_new(kte,kr))/(RHOCGS(KTE)*(ZCGS(KTE)-ZCGS(KTE-1)))         
+          DO K=kts,kte                                         
+           chem_new(k,kr)=chem_new(k,kr)+DWFLUX(K)*DTFALL
+          END DO  
+        END DO  
+       END IF
+      END DO  
+      RETURN                                                                  
+      END SUBROUTINE FALFLUXHUCM                                                                    
+      SUBROUTINE FAST_HUCMINIT(DT)
+      IMPLICIT NONE
+      INTEGER IKERN_0,IKERN_Z,L0_REAL,L0_INTEGER,INEWMEY,INEST
+      INTEGER I,J,K,KR
+      REAL DT
+      INTEGER :: hujisbm_unit1
+      LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
+      LOGICAL :: opened 
+      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
+      CHARACTER*80 errmess
+      REAL PI
+      double precision ax
+      data pi/3.141592654/
+! dtime - timestep of integration (calculated in main program) :
+! ax - coefficient used for masses calculation 
+! ima(i,j) - k-category number, c(i,j) - courant number 
+
+        REAL C1(NKR,NKR)
+! DON'T NEED ALL THESE VARIABLES: STILL NEED EDITING
+       INTEGER ICE,KGRAN,IPRINT01
+       REAL TWSIN,TWCIN,TWNUC,XF5,XF4,XF3,CONCHIN,CONCGIN,CONCSIN, &
+     & CONCCLIN,TWHIN,RADH,RADS,RADG,RADL,CONCLIN,A1_MY,A2,A2_MY,XLK, &
+     & A1N,A3_MY,A3,A1_MYN,R0CCN,X0DROP,DEG01,CONTCCNIN,CONCCCNIN, &
+     & A,B,X0CCN,S_KR,RCCNKR,R0,X0,TWCALLIN,A1,RCCNKR_CM,SUMIIN,TWGIN, &
+     & XF1N,XF1,WC1N,RF1N,WNUC,RNUC,WC5,RF5, &
+     & WC4,RF4,WC3,RF3,WC1,RF1,SMAX
+       REAL TWIIN(ICEMAX)
+       REAL RO_SOLUTE      
+       REAL A_FALL,B_FALL
+       real graupel_fall(nkr)
+       data graupel_fall/0.36840E-01,0.57471E-01,0.88417E-01,0.13999E+00,&
+     &  0.22841E+00,0.36104E+00,0.56734E+00, 0.88417E+00, 0.13999E+01,&
+     &  0.22104E+01, 0.35367E+01, 0.54524E+01, 0.81049E+01,0.12526E+02,&
+     &  0.19157E+02, 0.27262E+02, 0.34627E+02, 0.39776E+02,0.45690E+02,& 
+     &  0.52485E+02, 0.60289E+02, 0.69254E+02, 0.10000E+03, 0.15429E+03,&
+     &  0.18561E+03, 0.22329E+03, 0.26863E+03,  0.32316E+03,0.38877E+03,& 
+     &  0.46770E+03, 0.56266E+03, 0.67690E+03,  0.81432E+03/
+
+       PARAMETER (RO_SOLUTE=2.16)
+       INTEGER KR_MIN,KR_MIN1,KR_MAX
+       REAL RADCCN_MIN,RADCCN_MIN1,RADCCN_MAX
+     REAL  ::      RHOSU       ! STANDARD AIR DENSITY AT 850 MB
+     REAL ::      RHOW        ! DENSITY OF LIQUID WATER
+     REAL ::      RHOI        ! BULK DENSITY OF CLOUD ICE
+     REAL ::      RHOSN       ! BULK DENSITY OF SNOW
+     REAL ::      RHOG        ! BULK DENSITY OF GRAUPEL
+     REAL ::      CI,DI,CS,DS,CG,DG ! SIZE DISTRIBUTION PARAMETERS FOR CLOUD ICE, SNOW, GRAUPE
+
+       REAL FR_CON,FR_MAR
+       FR_MAR=1.0
+!      FR_CON=1-FR_MAR
+       FR_CON=1.0
+ !       PRINT*, 'INITIALIZING HUCM'  
+!	print *, ' ****** HUCM *******'
+       call wrf_message("SBM FAST: INITIALIZING HUCM")
+
+! INPUT :
+        dlnr=dlog(2.d0)/(3.d0*scal)
+!     print*,'here in hucmint 1'
+!
+!--- Read in various lookup tables
+!
+    !    print*,'wrf_dm_on_monitor() =',wrf_dm_on_monitor() 
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2061
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2061     CONTINUE
+        ENDIF
+!
+!     print*,'here in hucmint 2',hujisbm_unit1
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!     print*,'here in hucmint 3',hujisbm_unit1
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+!       print*,'here at 1'
+!      print*,'here in hucmint 4'
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="capacity.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+
+  900	FORMAT(6E13.5)
+	READ(hujisbm_unit1,900) RLEC,RIEC,RSEC,RGEC,RHEC
+	CLOSE(hujisbm_unit1)
+!     print*,'here in hucmint 5'
+        END IF
+        CALL wrf_dm_bcast_bytes ( RLEC , size ( RLEC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( RIEC , size ( RIEC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( RSEC , size ( RSEC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( RGEC , size ( RGEC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( RHEC , size ( RHEC ) * RWORDSIZE )
+! MASSES :
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2062
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2062     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="masses.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+	READ(hujisbm_unit1,900) XL,XI,XS,XG,XH          
+	CLOSE(hujisbm_unit1)
+!	print *, ' ***** file2: succesfull *******'
+        call wrf_message("SBM FAST: file2: succesfull")
+        ENDIF
+        CALL wrf_dm_bcast_bytes ( XL , size ( XL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( XI , size ( XI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( XS , size ( XS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( XG , size ( XG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( XH , size ( XH ) * RWORDSIZE )
+! TERMINAL VELOSITY :
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2063
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2063     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="termvels.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+	READ(hujisbm_unit1,900) VR1,VR2,VR3,VR4,VR5     
+	CLOSE(hujisbm_unit1)
+!	print *, ' ***** file3: succesfull *******'
+        call wrf_message("SBM FAST: file3: succesfull")
+        ENDIF
+        CALL wrf_dm_bcast_bytes ( VR1 , size ( VR1 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VR2 , size ( VR2 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VR3 , size ( VR3 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VR4 , size ( VR4 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VR5 , size ( VR5 ) * RWORDSIZE )
+! CHANGE FALL VELOCITY OF GRAUPEL
+        DO KR=1,NKR
+!        A=RADXXO(KR,6)
+!        B=RADXXO(KR,7)
+         if (kr.le.17)then
+          A_FALL=1
+          B_FALL=0
+         else
+          B_FALL=1
+          A_FALL=0
+         end if
+  
+!        VR4(KR)=A_FALL*VR4(KR)+B_FALL*VR5(KR)
+!        print*,'vr4,vr5,graupel_fall=',vr3(kr),vr5(kr),graupel_fall(kr)
+         VR4(KR)=graupel_fall(kr)
+        END DO
+ 
+! CONSTANTS :
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2065
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2065     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="constants.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+	READ(hujisbm_unit1,900) SLIC,TLIC,COEFIN,C2,C3,C4
+	CLOSE(hujisbm_unit1)
+!	print *, ' ***** file4: succesfull *******'
+        call wrf_message("SBM FAST: file4: succesfull")
+        END IF
+        CALL wrf_dm_bcast_bytes ( SLIC , size ( SLIC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( TLIC , size ( TLIC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( COEFIN , size ( COEFIN ) * RWORDSIZE )
+!       CALL wrf_dm_bcast_bytes ( C2 , size ( C2 ) * RWORDSIZE )
+!       CALL wrf_dm_bcast_bytes ( C3 , size ( C3 ) * RWORDSIZE )
+!       CALL wrf_dm_bcast_bytes ( C4 , size ( C4 ) * RWORDSIZE )
+! CONSTANTS :
+! KERNELS DEPENDING ON PRESSURE :
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2066
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2066     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="kernels_z.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+        READ(hujisbm_unit1,900)  &
+     &  YWLL_1000MB,YWLL_750MB,YWLL_500MB
+	CLOSE(hujisbm_unit1)
+        END IF
+        CALL wrf_dm_bcast_bytes ( YWLL_1000MB , size ( YWLL_1000MB ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLL_750MB , size ( YWLL_750MB ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLL_500MB , size ( YWLL_500MB ) * RWORDSIZE )
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2067
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2067     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="kernels.asc_s_0_03_0_9",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+! KERNELS NOT DEPENDING ON PRESSURE :
+	READ(hujisbm_unit1,900) &
+     &  YWLL,YWLI,YWLS,YWLG,YWLH, &
+     &  YWIL,YWII,YWIS,YWIG,YWIH, &
+     &  YWSL,YWSI,YWSS,YWSG,YWSH, &
+     &  YWGL,YWGI,YWGS,YWGG,YWGH, &
+     &  YWHL,YWHI,YWHS,YWHG,YWHH
+       close (hujisbm_unit1)
+        END IF
+        CALL wrf_dm_bcast_bytes ( YWLL , size ( YWLL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLI , size ( YWLI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLS , size ( YWLS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLG , size ( YWLG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLH , size ( YWLH ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWIL , size ( YWIL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWII , size ( YWII ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWIS , size ( YWIS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWIG , size ( YWIG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWIH , size ( YWIH ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWSL , size ( YWSL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWSI , size ( YWSI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWSS , size ( YWSS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWSG , size ( YWSG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWSH , size ( YWSH ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWGL , size ( YWGL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWGI , size ( YWGI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWGS , size ( YWGS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWGG , size ( YWGG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWGH , size ( YWGH ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWHL , size ( YWHL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWHI , size ( YWHI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWHS , size ( YWHS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWHG , size ( YWHG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWHH , size ( YWHH ) * RWORDSIZE )
+! BULKDENSITY :
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2068
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2068     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="bulkdens.asc_s_0_03_0_9",         & 
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+	READ(hujisbm_unit1,900) RO1BL,RO2BL,RO3BL,RO4BL,RO5BL
+	CLOSE(hujisbm_unit1)
+!	print *, ' ***** file6: succesfull *******'
+        call wrf_message("SBM FAST: file6: succesfull")
+        END IF
+        CALL wrf_dm_bcast_bytes (RO1BL  , size ( RO1BL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes (RO2BL  , size ( RO2BL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes (RO3BL  , size ( RO3BL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes (RO4BL  , size ( RO4BL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes (RO5BL  , size ( RO5BL ) * RWORDSIZE )
+! BULKRADIUS
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2069
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2069     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="bulkradii.asc_s_0_03_0_9",         & 
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+	READ(hujisbm_unit1,*) RADXXO
+	CLOSE(hujisbm_unit1)
+!	print *, ' ***** file7: succesfull *******'
+        call wrf_message("SBM FAST: file7: succesfull")
+!	PRINT *, '******* Hebrew Univ Cloud model-HUCM *******'
+        call wrf_message("SBM FAST: Hebrew Univ Cloud model-HUCM")
+
+        END IF
+        CALL wrf_dm_bcast_bytes (RADXXO  , size ( RADXXO ) * RWORDSIZE )
+! calculation of the mass(in mg) for categories boundaries :
+        ax=2.d0**(1.0/scal)
+        xl_mg(1)=0.3351d-7
+	do i=2,nkr
+           xl_mg(i)=ax*xl_mg(i-1)
+!        if (i.eq.22)print*,'printing xl_mg = ',xl_mg(22)
+        enddo
+	do i=1,nkr
+           xs_mg(i)=xs(i)*1.e3
+           xg_mg(i)=xg(i)*1.e3
+           xh_mg(i)=xh(i)*1.e3
+           xi1_mg(i)=xi(i,1)*1.e3
+           xi2_mg(i)=xi(i,2)*1.e3
+           xi3_mg(i)=xi(i,3)*1.e3
+        enddo
+! calculation of c(i,j) and ima(i,j) :
+! ima(i,j) - k-category number, c(i,j) - courant number 
+!       print*, 'calling courant_bott'
+        call courant_bott
+!       print*, 'called courant_bott'
+ 
+
+	DEG01=1./3.
+
+!------------------------------------------------------------------
+
+!       print*,'XL(ICCN) = ',ICCN,XL
+	X0DROP=XL(ICCN)
+!       print*,'X0DROP = ',X0DROP
+	X0CCN =X0DROP/(2.**(NKR-1))
+	R0CCN =(3.*X0CCN/4./3.141593/ROCCN0)**DEG01
+!------------------------------------------------------------------
+! THIS TEXT FROM TWOINITM.F_203
+!------------------------------------------------------------------
+! TEMPERATURA IN SURFACE LAYER EQUAL 15 Celsius(288.15 K)  
+        A=3.3E-05/288.15
+        B=2.*4.3/(22.9+35.5)
+        B=B*(4./3.)*3.14*RO_SOLUTE
+        A1=2.*(A/3.)**1.5/SQRT(B)
+        A2=A1*100.
+!------------------------------------------------------------------
+	CONCCCNIN=0.
+	CONTCCNIN=0.
+	DO KR=1,NKR
+           DROPRADII(KR)=(3.*XL(KR)/4./3.141593/1.)**DEG01
+        ENDDO
+	DO KR=1,NKR
+!          print*,'ROCCN0 = ',ROCCN0
+!          print*, 'X0CCN = ',X0CCN 
+!          print*, 'DEG01 = ',DEG01
+	   ROCCN(KR)=ROCCN0
+	   X0=X0CCN*2.**(KR-1)
+	   R0=(3.*X0/4./3.141593/ROCCN(KR))**DEG01
+	   XCCN(KR)=X0
+	   RCCN(KR)=R0
+!          print*,'RCCN(KR)= ', KR,RCCN(KR)
+           RCCNKR_CM=R0
+! CCN SPECTRUM 
+
+           S_KR=A2/RCCNKR_CM**1.5
+           ACCN=ACCN_CON
+           BCCN=BCCN_CON
+!          print*,'accn, bccn,S_KR = ',accn,bccn,S_KR
+!  CONTINENTAL
+           FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN
+           FCCNR_CON(KR)=FCCNR(KR)
+!  MARITIME
+           ACCN=ACCN_MAR
+           BCCN=BCCN_MAR
+           FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN
+           FCCNR_MAR(KR)=FCCNR(KR)
+
+	     CONTCCNIN=CONTCCNIN+COL*FCCNR(KR)*R0*R0*R0
+             CONCCCNIN=CONCCCNIN+COL*FCCNR(KR)
+	ENDDO
+!PRINT *, '********* MAR CCN CONCENTRATION & MASS *******'
+!	PRINT 200, CONCCCNIN,CONTCCNIN
+! CALCULATION OF FINAL MARITIME
+!RCCN(KR)=            1  1.2303877E-07
+!RCCN(KR)=            2  1.5501914E-07
+!RCCN(KR)=            3  1.9531187E-07
+!RCCN(KR)=           16  3.9372408E-06
+!RCCN(KR)=           21  1.2499960E-05
+!RCCN(KR)=           33  1.9999935E-04
+        RADCCN_MAX=RCCN(NKR)
+        RADCCN_MIN=0.005E-4         
+        RADCCN_MIN1=0.02E-4         
+!       print*,'ALOG(RADCCN_MIN) = ',ALOG(RADCCN_MIN)
+!       print*,'ALOG(RCCN(1) = ',ALOG(RCCN(1))
+!       print*,'ALOG(RADCCN_MAX) = ',ALOG(RADCCN_MAX)
+!       KR_MIN=(ALOG(RADCCN_MIN)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+!       KR_MIN1=(ALOG(RADCCN_MIN1)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+        KR_MIN=1.+ 3*(ALOG(RADCCN_MIN)- ALOG(R0CCN))/ALOG(2.)
+        KR_MIN1=1.+3*(ALOG(RADCCN_MIN1)- ALOG(R0CCN))/ALOG(2.)
+!       KR_MAX=(ALOG(RADCCN_MAX)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+        KR_MAX=1.+3.*(ALOG(RADCCN_MAX)- ALOG(R0CCN))/ALOG(2.)
+        KR_MIN=MAX(KR_MIN,1)
+        KR_MIN1=MAX(KR_MIN,KR_MIN1)
+        KR_MAX=MIN(NKR,KR_MAX)
+!       print*,'kr_min,kr_min1 = ',kr_min,kr_min1
+!       print*,'kr_max = ',kr_max
+! Interpolation
+        DO KR=1,NKR
+        IF (kr.ge.kr_min.and.kr.lt.kr_min1)then
+           FCCNR_MAR(KR)=FCCNR_MAR(KR_MIN1)* &
+     &      (ALOG(RCCN(KR))-ALOG(RCCN(KR_MIN)))/ &
+     &      (ALOG(RCCN(KR_MIN1))-ALOG(RCCN(KR_MIN)))
+
+        END IF
+        IF (KR.GT.KR_MAX.OR.KR.LT.KR_MIN)FCCNR_MAR(KR)=0
+!          print*,'FCCNR_MAR(KR) = ',KR,FCCNR_MAR(KR)
+        END DO
+! CALCULATION OF FINAL CONTINENTAL
+        RADCCN_MAX=0.6E-4
+        RADCCN_MIN=0.005E-4         
+        RADCCN_MIN1=0.02E-4         
+!       KR_MIN=(ALOG(RADCCN_MIN)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+!       KR_MIN1=(ALOG(RADCCN_MIN1)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+        KR_MIN=1.+ 3*(ALOG(RADCCN_MIN)- ALOG(R0CCN))/ALOG(2.)
+        KR_MIN1=1.+3*(ALOG(RADCCN_MIN1)- ALOG(R0CCN))/ALOG(2.)
+!       KR_MAX=(ALOG(RADCCN_MAX)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+        KR_MAX=1.+3.*(ALOG(RADCCN_MAX)- ALOG(R0CCN))/ALOG(2.)
+        KR_MIN=MAX(KR_MIN,1)
+        KR_MIN1=MAX(KR_MIN,KR_MIN1)
+        KR_MAX=MIN(NKR,KR_MAX)
+!       print*,'contin kr_min,kr_min1 = ',kr_min,kr_min1
+!       print*,'kr_max = ',kr_max
+! Interpolation
+        DO KR=1,NKR
+        IF (kr.ge.kr_min.and.kr.lt.kr_min1)then
+           FCCNR_CON(KR)=FCCNR_CON(KR_MIN1)* &
+     &      (ALOG(RCCN(KR))-ALOG(RCCN(KR_MIN)))/ &
+     &      (ALOG(RCCN(KR_MIN1))-ALOG(RCCN(KR_MIN)))
+        END IF
+        IF (KR.GT.KR_MAX.OR.KR.LT.KR_MIN)FCCNR_CON(KR)=0
+!          print*,'FCCNR_CON(KR) = ',KR,FCCNR_CON(KR)
+        END DO
+! CALCULATION OF MIXTURE
+        DO KR=1,NKR
+         FCCNR_MIX(KR)=FR_CON*FCCNR_CON(KR)+FR_MAR*FCCNR_MAR(KR)
+!        print*,'FCCNR_MIX(KR) = ',FCCNR_MIX(KR)
+        END DO
+
+
+         CALL BREAKINIT
+!        CALL TWOINITMXVAR
+
+!	PRINT *, '**** MIN CCN RADIUS,MASS & DENSITY ***'
+!	PRINT 200, R0CCN,X0CCN,ROCCN0
+!	PRINT *, '*********  CONT CCN CONCENTRATION & MASS *******'
+!	PRINT 200, CONCCCNIN,CONTCCNIN
+!	PRINT *, '*********  DROP RADII *******'
+!	PRINT 200, DROPRADII
+!	PRINT *, '*********  CCN RADII *******'
+!	PRINT 200, RCCN
+!	PRINT *, '********* CCN MASSES *******'
+!	PRINT 200, XCCN
+!	PRINT *, '********* INITIAL CCN DISTRIBUTION *******'
+        
+     
+
+!	IF(IPRINT01.NE.0) THEN
+
+!  PRINT *, '******** INITIAL: TWC,TWI(ICEMAX),TWS ********'
+!  PRINT 300, TWCIN,TWIIN,TWSIN
+!  PRINT *, '******** INITIAL: CONCLIN ********'
+!  PRINT 300, CONCLIN
+
+! IN CASE : IPRINT01.NE.0
+
+!	ENDIF
+
+  100	FORMAT(10I4)
+  101   FORMAT(3X,F7.5,E13.5)
+  102	FORMAT(4E12.4)
+  105	FORMAT(A48)
+  106	FORMAT(A80)
+  123	FORMAT(3E12.4,3I4)
+  200	FORMAT(6E13.5)
+  201   FORMAT(6D13.5)
+  300	FORMAT(8E14.6) 
+  301   FORMAT(3X,F8.3,3X,E13.5)
+  302   FORMAT(5E13.5)
+!       if (IFREST)THEN
+!       dtime=dt*0.5
+!       else
+!       END IF
+        call kernals(dt)
+! from morr_two_moment
+!..Set these variables needed for computing radar reflectivity.  These
+!.. get used within radar_init to create other variables used in the
+!.. radar module.
+! SIZE DISTRIBUTION PARAMETERS
+         RHOW = 997.
+         RHOI = 500.
+         RHOSN = 100.
+!        IF (IHAIL.EQ.0) THEN
+!        RHOG = 400.
+!        ELSE
+!        RHOG = 900.
+!        END IF
+         RHOG=450
+
+
+         CI = RHOI*PI_MORR/6.
+         DI = 3.
+         CS = RHOSN*PI_MORR/6.
+         DS = 3.
+         CG = RHOG*PI_MORR/6.
+         DG = 3.
+
+
+         xam_r = PI_MORR*RHOW/6.
+         xbm_r = 3.
+         xmu_r = 0.
+         xam_s = CS
+         xbm_s = DS
+         xmu_s = 0.
+         xam_g = CG
+         xbm_g = DG
+         xmu_g = 0.
+
+         call radar_init
+
+        return
+2070  continue
+      WRITE( errmess , '(A,I4)' )                                        &
+       'module_mp_fast_sbm: error opening hujisbm_DATA on unit '          &
+     &, hujisbm_unit1
+      CALL wrf_error_fatal(errmess)
+        end  subroutine fast_hucminit
+      SUBROUTINE BREAKINIT
+      IMPLICIT NONE
+      INTEGER :: hujisbm_unit1
+      LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
+      LOGICAL :: opened 
+      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
+      CHARACTER*80 errmess
+!.....INPUT VARIABLES
+!
+!     GT    : MASS DISTRIBUTION FUNCTION
+!     XT_MG : MASS OF BIN IN MG
+!     JMAX  : NUMBER OF BINS
+
+
+!.....LOCAL VARIABLES
+
+      INTEGER AP,IE,JE,KE
+
+      PARAMETER (AP = 1)
+
+      INTEGER I,J,K,JDIFF
+      REAL  RPKIJ(JBREAK,JBREAK,JBREAK),RQKJ(JBREAK,JBREAK)
+
+
+      REAL PI,D0,HLP
+      DOUBLE PRECISION M(0:JBREAK),ALM
+      REAL DBREAK(JBREAK),GAIN,LOSS
+!     REAL ECOALMASS
+!     REAL XL(JMAX)
+
+
+!.....DECLARATIONS FOR INIT
+
+      INTEGER IP,KP,JP,KQ,JQ
+      REAL XTJ
+
+      CHARACTER*20 FILENAME_P,FILENAME_Q
+
+      FILENAME_P = 'coeff_p.asc'
+      FILENAME_Q = 'coeff_q.asc'
+
+      IE = JBREAK
+      JE = JBREAK
+      KE = JBREAK
+      PI    = 3.1415927
+      D0    = 0.0101593
+      M(1)  = PI/6.0 * D0**3
+
+!.....IN CGS
+
+
+!.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID
+
+      JDIFF = JMAX - JBREAK
+
+!.....INITIALIZATION
+
+!     IF (FIRSTCALL.NE.1) THEN
+
+!........CALCULATING THE BREAKUP GRID
+!        ALM  = 2.**(1./FLOAT(AP))
+         ALM  = 2.d0
+         M(0)  = M(1)/ALM
+         DO K=1,KE-1
+            M(K+1) = M(K)*ALM
+         ENDDO
+         DO K=1,KE
+            BRKWEIGHT(K) = 2./(M(K)**2 - M(K-1)**2)
+!           print*,'m(k) = ',m(k)
+!           print*,'m(k-1) = ',m(k-1)
+!           print*, 'MWEIGHT = ',BRKWEIGHT(K)
+         ENDDO
+
+!........OUTPUT
+
+         WRITE (*,*) 'COLL_BREAKUP_INI: COAGULATION AND BREAKUP GRID'
+         WRITE (*,'(2A5,5A15)') 'ICOAG','IBREAK', &
+     &        'XCOAG','DCOAG', &
+     &        'XBREAK','DBREAK','MWEIGHT'
+
+!........READ DER BREAKUP COEFFICIENTS FROM INPUT FILE
+
+         WRITE (*,*) 'COLL_BREAKUP: READ THE BREAKUP COEFFS'
+         WRITE (*,*) '              FILE PKIJ: ', FILENAME_P
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2061
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2061     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="coeff_p.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+
+!         print*,'here at 3'
+         DO K=1,KE
+            DO I=1,IE
+               DO J=1,I
+                  READ(hujisbm_unit1,'(3I6,1E16.8)') KP,IP,JP,PKIJ(KP,IP,JP)
+!                 WRITE(6,*)'PKIJ(KP,IP,JP) =', &
+!    &               KP,IP,JP,PKIJ(KP,IP,JP)
+!                 IF(RPKIJ(KP,IP,JP).EQ.0) THEN
+!    *             PKIJ(KP,IP,JP)=INT(RPKIJ(KP,IP,JP))
+!                 ELSE
+!                  PKIJ(KP,IP,JP)=RPKIJ(KP,IP,JP)
+!                 END IF
+!                 WRITE(6,*)'RPKIJ(KP,IP,JP) =',
+!    *               KP,IP,JP,RPKIJ(KP,IP,JP),
+!    *               PKIJ(KP,IP,JP)
+               ENDDO
+            ENDDO
+!           READ(6,*)
+         ENDDO
+	CLOSE(hujisbm_unit1)
+         WRITE (*,*) '              FILE QKJ:  ', FILENAME_Q
+        END IF
+        CALL wrf_dm_bcast_bytes (PKIJ  , size ( PKIJ ) * DWORDSIZE )
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2062
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2062     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_fast: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="coeff_q.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+
+         DO K=1,KE
+            DO J=1,JE
+               READ(hujisbm_unit1,'(2I6,1E16.8)') KQ,JQ,QKJ(KQ,JQ)
+!              WRITE(6,*) KQ,JQ,QKJ(KQ,JQ)
+!              QKJ(KQ,JQ) = RQKJ(KQ,JQ)
+!              IF(QKJ(KQ,JQ).LE.1E-35)QKJ(KQ,JQ)=0.D0
+            ENDDO
+         ENDDO
+         CLOSE(hujisbm_unit1)
+
+         WRITE (*,*) 'COLL_BREAKUP READ: ... OK'
+         END IF
+        CALL wrf_dm_bcast_bytes (QKJ  , size ( QKJ ) * DWORDSIZE )
+!     ENDIF
+!        DO K=1,KE
+!           DO J=1,JE
+!              WRITE(6,*) 'After Broadcast, QKJ = ',K,J,QKJ(K,J)
+!           ENDDO
+!        ENDDO
+!        DO K=1,KE
+!           DO I=1,IE
+!              DO J=1,I
+!                 WRITE(6,*)'After Broadcast PKIJ(K,I,J) =', &
+!    &               K,I,J,PKIJ(K,I,J)
+!              ENDDO
+!           ENDDO
+!        ENDDO
+      DO I=1,JMAX
+         DO J=1,JMAX
+              ECOALMASSM(I,J)=1.0D0
+         ENDDO
+      ENDDO
+
+      DO I=1,JMAX
+         DO J=1,JMAX
+           ECOALMASSM(I,J)=ECOALMASS(XL(I),XL(J))
+         ENDDO
+      ENDDO
+      RETURN
+2070  continue
+      WRITE( errmess , '(A,I4)' )                                        &
+       'module_mp_fast: error opening hujisbm_DATA on unit '          &
+     &, hujisbm_unit1
+      CALL wrf_error_fatal(errmess)
+      END SUBROUTINE BREAKINIT
+
+      REAL FUNCTION ECOALMASS(ETA,KSI)
+      IMPLICIT NONE
+!     REAL ECOALMASS
+      REAL PI
+      PARAMETER (PI = 3.1415927)
+
+      REAL ETA,KSI
+      REAL KPI,RHO
+      REAL DETA,DKSI
+
+      PARAMETER (RHO  = 1.0)
+
+!     REAL ECOALDIAM
+!     EXTERNAL ECOALDIAM
+
+      KPI = 6./PI
+
+      DETA = (KPI*ETA/RHO)**(1./3.)
+      DKSI = (KPI*KSI/RHO)**(1./3.)
+
+      ECOALMASS = ECOALDIAM(DETA,DKSI)
+
+      RETURN
+      END FUNCTION ECOALMASS
+
+
+!------------------------------------------------
+!     COALESCENCE EFFICIENCY AS FUNC OF DIAMETERS
+!------------------------------------------------
+
+      REAL FUNCTION ECOALDIAM(DETA,DKSI)
+!     IMPLICIT NONE
+
+      INTEGER N
+      REAL DETA,DKSI
+      REAL DGR,DKL,RGR,RKL,P,Q,E,X,Y,QMIN,QMAX
+      REAL ZERO,ONE,EPS,PI
+
+      PARAMETER (ZERO = 0.0)
+      PARAMETER (ONE  = 1.0)
+      PARAMETER (EPS  = 1.0E-30)
+      PARAMETER (PI   = 3.1415927)
+
+!     REAL   ECOALLOWLIST,ECOALOCHS
+!     EXTERNAL ECOALLOWLIST,ECOALOCHS
+
+      DGR = MAX(DETA,DKSI)
+      DKL = MIN(DETA,DKSI)
+
+      RGR = 0.5*DGR
+      RKL = 0.5*DKL
+
+      P = (RKL / RGR)
+      Q = (RKL * RGR)**0.5
+      Q = 0.5 * (RKL + RGR)
+
+      qmin = 250e-4
+      qmax = 400e-4        
+      if (q.lt.qmin) then
+         e = max(ecoalOchs(Dgr,Dkl),ecoalBeard(Dgr,Dkl)) 
+      elseif (q.ge.qmin.and.q.lt.qmax) then
+         x = (q - qmin) / (qmax - qmin)
+         e = sin(pi/2.0*x)**2 * ecoalLowList(Dgr,Dkl) &
+     &     + sin(pi/2.0*(1 - x))**2 * ecoalOchs(Dgr,Dkl)
+      elseif (q.ge.qmax) then
+         e = ecoalLowList(Dgr,Dkl)
+      else
+         e  = 1.0
+      endif
+
+      ECOALDIAM  = MAX(MIN(ONE,E),EPS)
+
+      RETURN
+      END FUNCTION  ECOALDIAM
+
+!--------------------------------------------------
+!     COALESCENCE EFFICIENCY (LOW&LIST)
+!--------------------------------------------------
+
+      REAL FUNCTION ECOALLOWLIST(DGR,DKL)
+      IMPLICIT NONE
+!     REAL ecoallowlist
+      REAL PI,SIGMA,KA,KB,EPSI
+      REAL DGR,DKL,RGR,RKL,X
+      REAL ST,SC,ET,DSTSC,CKE,W1,W2,DC,ECL
+      REAL QQ0,QQ1,QQ2
+
+      PARAMETER (EPSI=1.E-20)
+
+      PI = 3.1415927
+      SIGMA = 72.8
+      KA = 0.778
+      KB = 2.61E-4
+
+      RGR = 0.5*DGR
+      RKL = 0.5*DKL
+
+      CALL COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC)
+
+      DSTSC = ST-SC
+      ET = CKE+DSTSC
+      IF (ET .LT. 50.0) THEN
+         QQ0=1.0+(DKL/DGR)
+         QQ1=KA/QQ0**2
+         QQ2=KB*SIGMA*(ET**2)/(SC+EPSI)
+         ECL=QQ1*EXP(-QQ2)
+      ELSE
+         ECL=0.0
+      ENDIF
+
+      ECOALLOWLIST = ECL
+
+      RETURN
+      END FUNCTION ECOALLOWLIST
+
+!--------------------------------------------------
+!     COALESCENCE EFFICIENCY (BEARD AND OCHS)
+!--------------------------------------------------
+
+      REAL FUNCTION ECOALOCHS(D_L,D_S)
+      IMPLICIT NONE
+!     real ecoalochs
+      REAL D_L,D_S
+      REAL PI,SIGMA,N_W,R_S,R_L,DV,P,G,X,E
+!      REAL VTBEARD,EPSF,FPMIN
+      REAL EPSF,FPMIN
+
+!     EXTERNAL VTBEARD
+      PARAMETER (EPSF  = 1.E-30)
+      PARAMETER (FPMIN = 1.E-30)
+
+      PI = 3.1415927
+      SIGMA = 72.8
+
+      R_S = 0.5 * D_S
+      R_L = 0.5 * D_L
+      P   = R_S / R_L
+
+      DV  = ABS(VTBEARD(D_L) - VTBEARD(D_S))
+      IF (DV.LT.FPMIN) DV = FPMIN
+      N_W = R_S * DV**2 / SIGMA
+      G   = 2**(3./2.)/(6.*PI) * P**4 * (1.+ P) / ((1.+P**2)*(1.+P**3))
+      X   = N_W**(0.5) * G
+      E   = 0.767 - 10.14 * X
+
+      ECOALOCHS = E
+
+      RETURN
+      END FUNCTION ECOALOCHS
+
+!-----------------------------------------
+!     CALCULATING THE COLLISION ENERGY
+!-----------------------------------------
+
+      SUBROUTINE COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC)
+!     IMPLICIT NONE
+
+      REAL DGR,DKL,DC
+      REAL K10,PI,SIGMA,RHO
+      REAL CKE,W1,W2,ST,SC
+      REAL DGKA3,DGKB3,DGKA2
+      REAL V1,V2,DV
+!     REAL VTBEARD,EPSF,FPMIN
+      REAL EPSF,FPMIN
+
+!     EXTERNAL VTBEARD
+      PARAMETER (EPSF  = 1.E-30)
+      PARAMETER (FPMIN = 1.E-30)
+
+      PI    = 3.1415927
+      RHO   = 1.0
+      SIGMA = 72.8
+
+      K10=RHO*PI/12.0D0
+
+      DGR = MAX(DGR,EPSF)
+      DKL = MAX(DKL,EPSF)
+
+      DGKA2=(DGR**2)+(DKL**2)
+
+      DGKA3=(DGR**3)+(DKL**3)
+
+      IF (DGR.NE.DKL) THEN
+         V1 = VTBEARD(DGR)
+         V2 = VTBEARD(DKL)
+         DV = (V1-V2)
+         IF (DV.LT.FPMIN) DV = FPMIN
+         DV = DV**2
+         IF (DV.LT.FPMIN) DV = FPMIN
+         DGKB3=(DGR**3)*(DKL**3)
+         CKE = K10 * DV * DGKB3/DGKA3
+      ELSE
+         CKE = 0.0D0
+      ENDIF
+      ST = PI*SIGMA*DGKA2
+      SC = PI*SIGMA*DGKA3**(2./3.)
+
+      W1=CKE/(SC+EPSF)
+      W2=CKE/(ST+EPSF)
+
+      DC=DGKA3**(1./3.)
+
+      RETURN
+      END SUBROUTINE COLLENERGY
+
+!--------------------------------------------------
+!     CALCULATING TERMINAL VELOCITY (BEARD-FORMULA)
+!--------------------------------------------------
+
+      REAL FUNCTION VTBEARD(DIAM)
+      IMPLICIT NONE
+!     REAL VTBEARD
+
+      REAL DIAM,AA
+      REAL ROP,RU,AMT,PP,RL,TT,ETA,DENS,CD,D,A
+      REAL ALA,GR,SI,BOND,PART,XX,YY,RE,VT
+      REAL B00,B11,B22,B33,B44,B55,B0,B1,B2,B3,B4,B5,B6
+      INTEGER ID
+
+      DATA B00,B11,B22,B33,B44,B55,B0,B1,B2,B3,B4,B5,B6/-5.00015, &
+     &5.23778,-2.04914,.475294,-.0542819,.00238449,-3.18657,.992696, &
+     &-.153193E-2,-.987059E-3,-.578878E-3,.855176E-4,-.327815E-5/
+
+      AA   = DIAM/2.0
+      ROP  = 1.0
+      RU   = 8.3144E+7
+      AMT  = 28.9644
+      ID   = 10000
+      PP   = FLOAT(ID)*100.
+      RL   = RU/AMT
+      TT   = 283.15
+      ETA  = (1.718+.0049*(TT-273.15))*1.E-4
+      DENS = PP/TT/RL
+      ALA  = 6.6E-6*1.01325E+6/PP*TT/293.15
+      GR   = 979.69
+      SI   = 76.1-.155*(TT-273.15)
+
+      IF (AA.GT.500.E-4) THEN
+         BOND = GR*(ROP-DENS)*AA*AA/SI
+         PART = (SI**3*DENS*DENS/(ETA**4*GR*(ROP-DENS)))**(1./6.)
+         XX = LOG(16./3.*BOND*PART)
+         YY = B00+B11*XX+B22*XX*XX+B33*XX**3+B44*XX**4+B55*XX**5
+         RE = PART*EXP(YY)
+         VT = ETA*RE/2./DENS/AA
+      ELSEIF (AA.GT.1.E-3) THEN
+         CD = 32.*AA*AA*AA*(ROP-DENS)*DENS*GR/3./ETA/ETA
+         XX = LOG(CD)
+         RE = EXP(B0+B1*XX+B2*XX*XX+B3*XX**3+B4*XX**4+B5*XX**5+B6*XX**6)
+         D  = CD/RE/24.-1.
+         VT = ETA*RE/2./DENS/AA
+      ELSE
+         A  = 1.+1.26*ALA/AA
+         A  = A*2.*AA*AA*GR*(ROP-DENS)/9./ETA
+         CD = 12*ETA/A/AA/DENS
+         VT = A
+      ENDIF
+
+      VTBEARD = VT
+
+      RETURN
+      END FUNCTION VTBEARD
+
+
+      
+!-------------------------------------------------- 
+!     Function f. Coalescence-Efficiency 
+!     Eq. (7) of Beard and Ochs (1995)
+!--------------------------------------------------      
+ 
+      REAL FUNCTION ecoalBeard(D_l,D_s) 
+       
+      IMPLICIT NONE 
+!     REAL ecoalBeard
+!     REAL ECOALMASS
+      REAL            D_l,D_s
+      REAL            R_s,R_l
+      REAL            rcoeff
+      REAL epsf
+      PARAMETER (epsf  = 1.e-30) 
+
+      INTEGER its
+      COMPLEX acoeff(4),x
+
+      R_s = 0.5 * D_s
+      R_l = 0.5 * D_l      
+
+      rcoeff = 5.07 - log(R_s*1e4) - log(R_l*1e4/200.0)
+
+      acoeff(1) = CMPLX(rcoeff)
+      acoeff(2) = CMPLX(-5.94)
+      acoeff(3) = CMPLX(+7.27)
+      acoeff(4) = CMPLX(-5.29)
+
+      x = (0.50,0)
+
+      CALL LAGUER(acoeff,3,x,its)
+
+      EcoalBeard = REAL(x)
+
+      RETURN 
+      END FUNCTION ecoalBeard 
+
+!--------------------------------------------------       
+
+      SUBROUTINE laguer(a,m,x,its)
+      INTEGER m,its,MAXIT,MR,MT
+      REAL EPSS
+      COMPLEX a(m+1),x
+      PARAMETER (EPSS=2.e-7,MR=8,MT=10,MAXIT=MT*MR)
+      INTEGER iter,j
+      REAL abx,abp,abm,err,frac(MR)
+      COMPLEX dx,x1,b,d,f,g,h,sq,gp,gm,g2
+      SAVE frac
+      DATA frac /.5,.25,.75,.13,.38,.62,.88,1./
+      do 12 iter=1,MAXIT
+        its=iter
+        b=a(m+1)
+        err=abs(b)
+        d=cmplx(0.,0.)
+        f=cmplx(0.,0.)
+        abx=abs(x)
+        do 11 j=m,1,-1
+          f=x*f+d
+          d=x*d+b
+          b=x*b+a(j)
+          err=abs(b)+abx*err
+11      continue
+        err=EPSS*err
+        if(abs(b).le.err) then
+          return
+        else
+          g=d/b
+          g2=g*g
+          h=g2-2.*f/b
+          sq=sqrt((m-1)*(m*h-g2))
+          gp=g+sq
+          gm=g-sq
+          abp=abs(gp)
+          abm=abs(gm)
+          if(abp.lt.abm) gp=gm
+          if (max(abp,abm).gt.0.) then
+            dx=m/gp
+          else
+            dx=exp(cmplx(log(1.+abx),float(iter)))
+          endif
+        endif
+        x1=x-dx
+        if(x.eq.x1)return
+        if (mod(iter,MT).ne.0) then
+          x=x1
+        else
+          x=x-dx*frac(iter/MT)
+        endif
+12    continue
+      pause 'too many iterations in laguer'
+      return
+      END SUBROUTINE laguer
+
+
+
+
+      subroutine courant_bott
+      implicit none
+      integer k,kk,j,i
+      double precision x0
+! ima(i,j) - k-category number,
+! chucm(i,j)   - courant number :
+! logarithmic grid distance(dlnr) :
+
+
+!================================================================
+! BARRY     
+!     print*,'dlnr in courant_bott = ',dlnr
+      xl_mg(0)=xl_mg(1)/2
+! BARRY
+      do i=1,nkr
+         do j=i,nkr
+            x0=xl_mg(i)+xl_mg(j)
+            do k=j,nkr
+               kk=k
+               if (k.eq.1)then
+!                  print*,'xl_mg(k) = ',xl_mg(k)
+!                  print*,'x0 = ',x0
+! xl_mg(k) =   3.351000000000000E-008
+!  x0 =   6.702000000000000E-008
+!		   read (6,*)
+               end if
+               if(xl_mg(k).ge.x0.and.xl_mg(k-1).lt.x0) then
+                 chucm(i,j)=dlog(x0/xl_mg(k-1))/(3.d0*dlnr)
+ 102             continue
+                 if(chucm(i,j).gt.1.-1.d-08) then
+                   chucm(i,j)=0.
+                   kk=kk+1
+                 endif
+                 ima(i,j)=min(nkr-1,kk-1)
+
+                 goto 2000
+               endif
+            enddo
+ 2000       continue
+!            if(i.eq.nkr.or.j.eq.nkr) ima(i,j)=nkr
+            chucm(j,i)=chucm(i,j)
+            ima(j,i)=ima(i,j)
+         enddo
+      enddo
+      return
+      end subroutine courant_bott
+
+
+      SUBROUTINE KERNALS(DTIME)
+! KHAIN30/07/99
+      IMPLICIT NONE
+      INTEGER I,J
+      REAL PI
+!******************************************************************
+      data pi/3.141592654/
+! dtime - timestep of integration (calculated in main program) :
+! dlnr - logarithmic grid distance
+! ima(i,j) - k-category number, c(i,j) - courant number 
+! cw*(i,j) (in cm**3) - multiply help kernel with constant 
+! timestep(dt) and logarithmic grid distance(dlnr) :
+        REAL DTIME
+! logarithmic grid distance(dlnr) :
+!       dlnr=dlog(2.d0)/(3.d0*scal)
+! scal is micro.prm file parameter(scal=1.d0 for x(k+1)=x(k)*2)
+! calculation of cw*(i,j) (in cm**3) - multiply help kernel 
+! with constant timestep(dtime) and logarithmic grid distance(dlnr) :
+!     print*,'dlnr in kernal = ',dlnr,dtime
+        DO I=1,NKR
+           DO J=1,NKR
+              CWLL_1000MB(I,J)=DTIME*DLNR*YWLL_1000MB(I,J)
+              CWLL_750MB(I,J)=DTIME*DLNR*YWLL_750MB(I,J)
+              CWLL_500MB(I,J)=DTIME*DLNR*YWLL_500MB(I,J)
+
+              CWLL(I,J)=DTIME*DLNR*YWLL(I,J)
+              CWLG(I,J)=DTIME*DLNR*YWLG(I,J)
+              CWLH(I,J)=DTIME*DLNR*YWLH(I,J)
+
+! barry
+              if (i.le.16.and.j.le.16)then
+              CWSL(I,J)=0.d0
+!             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
+              CWSL(i,j)=DTIME*DLNR*YWIL(I,J,2)
+              CWLS(I,J)=0.d0
+!             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
+              CWLS(I,J)=DTIME*DLNR*YWLI(I,J,2)
+              else
+              CWSL(I,J)=DTIME*DLNR*YWSL(I,J)
+              CWLS(I,J)=DTIME*DLNR*YWLS(I,J)
+              end if
+              CWSS(I,J)=DTIME*DLNR*YWSS(I,J)
+              CWSG(I,J)=DTIME*DLNR*YWSG(I,J)
+              CWSH(I,J)=DTIME*DLNR*YWSH(I,J)
+
+              CWGL(I,J)=0.8*DTIME*DLNR*YWGL(I,J)
+              IF(RADXXO(I,6).LT.2.0D-2) THEN
+                IF(RADXXO(J,1).LT.1.0D-3) THEN
+                  IF(RADXXO(J,1).GE.7.0D-4) THEN
+                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/1.5D0
+                  ELSE
+                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/3.0D0
+                  ENDIF
+                ENDIF
+              ENDIF
+              IF(I.LE.14.AND.J.LE.7) CWGL(I,J)=0.0D0
+!             IF(I.LE.17.AND.J.LE.7) CWGL(I,J)=0.0D0
+!             IF(I.LE.14.AND.J.LE.14) CWGL(I,J)=0.0D0
+              CWGS(I,J)=DTIME*DLNR*YWGS(I,J)
+              CWGG(I,J)=DTIME*DLNR*YWGG(I,J)
+              CWGH(I,J)=DTIME*DLNR*YWGH(I,J)
+
+              CWHL(I,J)=DTIME*DLNR*YWHL(I,J)
+              CWHS(I,J)=DTIME*DLNR*YWHS(I,J)
+              CWHG(I,J)=DTIME*DLNR*YWHG(I,J)
+              CWHH(I,J)=DTIME*DLNR*YWHH(I,J)
+
+              CWLI_1(I,J)=DTIME*DLNR*YWLI(I,J,1)
+              CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
+              CWLI_3(I,J)=DTIME*DLNR*YWLI(I,J,3)
+              
+              CWIL_1(I,J)=DTIME*DLNR*YWIL(I,J,1)
+              CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
+              CWIL_3(I,J)=DTIME*DLNR*YWIL(I,J,3)
+
+              CWIS_1(I,J)=DTIME*DLNR*YWIS(I,J,1)
+              CWIS_2(I,J)=DTIME*DLNR*YWIS(I,J,2)
+              CWIS_3(I,J)=DTIME*DLNR*YWIS(I,J,3)
+
+              CWSI_1(I,J)=DTIME*DLNR*YWSI(I,J,1)
+              CWSI_2(I,J)=DTIME*DLNR*YWSI(I,J,2)
+              CWSI_3(I,J)=DTIME*DLNR*YWSI(I,J,3)
+
+              CWIG_1(I,J)=DTIME*DLNR*YWIG(I,J,1)
+              CWIG_2(I,J)=DTIME*DLNR*YWIG(I,J,2)
+              CWIG_3(I,J)=DTIME*DLNR*YWIG(I,J,3)
+
+              CWGI_1(I,J)=DTIME*DLNR*YWGI(I,J,1)
+              CWGI_2(I,J)=DTIME*DLNR*YWGI(I,J,2)
+              CWGI_3(I,J)=DTIME*DLNR*YWGI(I,J,3)
+
+              CWIH_1(I,J)=DTIME*DLNR*YWIH(I,J,1)
+              CWIH_2(I,J)=DTIME*DLNR*YWIH(I,J,2)
+              CWIH_3(I,J)=DTIME*DLNR*YWIH(I,J,3)
+
+              CWHI_1(I,J)=DTIME*DLNR*YWHI(I,J,1)
+              CWHI_2(I,J)=DTIME*DLNR*YWHI(I,J,2)
+              CWHI_3(I,J)=DTIME*DLNR*YWHI(I,J,3)
+! barry
+              if (i.lt.12.and.j.lt.12)then
+
+               CWII_1_1(I,J)=0.D0
+               CWII_1_2(I,J)=0.D0
+               CWII_1_3(I,J)=0.D0
+
+               CWII_2_1(I,J)=0.D0
+               CWII_2_2(I,J)=0.D0
+               CWII_2_3(I,J)=0.D0
+
+               CWII_3_1(I,J)=0.D0
+               CWII_3_2(I,J)=0.D0
+               CWII_3_3(I,J)=0.D0
+!barry
+              else
+               CWII_1_1(I,J)=DTIME*DLNR*YWII(I,J,1,1)
+               CWII_1_2(I,J)=DTIME*DLNR*YWII(I,J,1,2)
+               CWII_1_3(I,J)=DTIME*DLNR*YWII(I,J,1,3)
+
+               CWII_2_1(I,J)=DTIME*DLNR*YWII(I,J,2,1)
+               CWII_2_2(I,J)=DTIME*DLNR*YWII(I,J,2,2)
+               CWII_2_3(I,J)=DTIME*DLNR*YWII(I,J,2,3)
+
+               CWII_3_1(I,J)=DTIME*DLNR*YWII(I,J,3,1)
+               CWII_3_2(I,J)=DTIME*DLNR*YWII(I,J,3,2)
+               CWII_3_3(I,J)=DTIME*DLNR*YWII(I,J,3,3)
+              end if
+           ENDDO
+        ENDDO
+!       GO TO 88
+! NEW CHANGES 2.06.01 (BEGIN)
+        CALL TURBCOEF
+        DO J=1,7
+           DO I=15,24-J
+              CWGL(I,J)=0.0D0
+           ENDDO
+        ENDDO
+! NEW CHANGES 2.06.01 (END)
+! NEW CHANGES 3.02.01 (BEGIN)
+        DO I=1,NKR
+           DO J=1,NKR
+              CWLG(J,I)=CWGL(I,J)
+           ENDDO
+        ENDDO
+!       print*, 'ICETURB = ',ICETURB
+          DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+               IF (ICETURB.EQ.1)THEN
+                CWGL(I,J)=CTURBGL(I,J)*CWGL(I,J)
+               ELSE
+                CWGL(I,J)=CWGL(I,J)
+               END IF
+             ENDDO
+          ENDDO
+          DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+                CWLG(J,I)=CWGL(I,J)
+             ENDDO
+          ENDDO
+
+88     CONTINUE
+	RETURN
+	END SUBROUTINE KERNALS
+
+      SUBROUTINE KERNALS_IN(DTIME)
+! KHAIN30/07/99
+      IMPLICIT NONE
+      INTEGER I,J
+      REAL PI
+!******************************************************************
+      data pi/3.141592654/
+! dtime - timestep of integration (calculated in main program) :
+! dlnr - logarithmic grid distance
+! ima(i,j) - k-category number, c(i,j) - courant number 
+! cw*(i,j) (in cm**3) - multiply help kernel with constant 
+! timestep(dt) and logarithmic grid distance(dlnr) :
+        REAL DTIME
+! logarithmic grid distance(dlnr) :
+!       dlnr=dlog(2.d0)/(3.d0*scal)
+! scal is micro.prm file parameter(scal=1.d0 for x(k+1)=x(k)*2)
+! calculation of cw*(i,j) (in cm**3) - multiply help kernel 
+! with constant timestep(dtime) and logarithmic grid distance(dlnr) :
+!     print*,'dlnr in kernal = ',dlnr,dtime
+        DO I=1,NKR
+           DO J=1,NKR
+              CWLL_1000MB(I,J)=DTIME*DLNR*YWLL_1000MB(I,J)
+              CWLL_750MB(I,J)=DTIME*DLNR*YWLL_750MB(I,J)
+              CWLL_500MB(I,J)=DTIME*DLNR*YWLL_500MB(I,J)
+
+              CWLL(I,J)=DTIME*DLNR*YWLL(I,J)
+              CWLG(I,J)=DTIME*DLNR*YWLG(I,J)
+!             CWLH(I,J)=DTIME*DLNR*YWLH(I,J)
+
+! barry
+              if (i.le.16.and.j.le.16)then
+              CWSL(I,J)=0.d0
+!             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
+              CWSL(i,j)=DTIME*DLNR*YWIL(I,J,2)
+              CWLS(I,J)=0.d0
+!             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
+              CWLS(I,J)=DTIME*DLNR*YWLI(I,J,2)
+              else
+              CWSL(I,J)=DTIME*DLNR*YWSL(I,J)
+              CWLS(I,J)=DTIME*DLNR*YWLS(I,J)
+              end if
+              CWSS(I,J)=DTIME*DLNR*YWSS(I,J)
+              CWSG(I,J)=DTIME*DLNR*YWSG(I,J)
+!             CWSH(I,J)=DTIME*DLNR*YWSH(I,J)
+
+              CWGL(I,J)=0.8*DTIME*DLNR*YWGL(I,J)
+              IF(RADXXO(I,6).LT.2.0D-2) THEN
+                IF(RADXXO(J,1).LT.1.0D-3) THEN
+                  IF(RADXXO(J,1).GE.7.0D-4) THEN
+                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/1.5D0
+                  ELSE
+                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/3.0D0
+                  ENDIF
+                ENDIF
+              ENDIF
+              IF(I.LE.14.AND.J.LE.7) CWGL(I,J)=0.0D0
+!             IF(I.LE.17.AND.J.LE.7) CWGL(I,J)=0.0D0
+!             IF(I.LE.14.AND.J.LE.14) CWGL(I,J)=0.0D0
+              CWGS(I,J)=DTIME*DLNR*YWGS(I,J)
+              CWGG(I,J)=DTIME*DLNR*YWGG(I,J)
+!             CWGH(I,J)=DTIME*DLNR*YWGH(I,J)
+
+!             CWHL(I,J)=DTIME*DLNR*YWHL(I,J)
+!             CWHS(I,J)=DTIME*DLNR*YWHS(I,J)
+!             CWHG(I,J)=DTIME*DLNR*YWHG(I,J)
+!             CWHH(I,J)=DTIME*DLNR*YWHH(I,J)
+
+!             CWLI_1(I,J)=DTIME*DLNR*YWLI(I,J,1)
+!             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
+!             CWLI_3(I,J)=DTIME*DLNR*YWLI(I,J,3)
+              
+!             CWIL_1(I,J)=DTIME*DLNR*YWIL(I,J,1)
+!             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
+!             CWIL_3(I,J)=DTIME*DLNR*YWIL(I,J,3)
+
+!             CWIS_1(I,J)=DTIME*DLNR*YWIS(I,J,1)
+!             CWIS_2(I,J)=DTIME*DLNR*YWIS(I,J,2)
+!             CWIS_3(I,J)=DTIME*DLNR*YWIS(I,J,3)
+
+!             CWSI_1(I,J)=DTIME*DLNR*YWSI(I,J,1)
+!             CWSI_2(I,J)=DTIME*DLNR*YWSI(I,J,2)
+!             CWSI_3(I,J)=DTIME*DLNR*YWSI(I,J,3)
+
+!             CWIG_1(I,J)=DTIME*DLNR*YWIG(I,J,1)
+!             CWIG_2(I,J)=DTIME*DLNR*YWIG(I,J,2)
+!             CWIG_3(I,J)=DTIME*DLNR*YWIG(I,J,3)
+
+!             CWGI_1(I,J)=DTIME*DLNR*YWGI(I,J,1)
+!             CWGI_2(I,J)=DTIME*DLNR*YWGI(I,J,2)
+!             CWGI_3(I,J)=DTIME*DLNR*YWGI(I,J,3)
+
+!             CWIH_1(I,J)=DTIME*DLNR*YWIH(I,J,1)
+!             CWIH_2(I,J)=DTIME*DLNR*YWIH(I,J,2)
+!             CWIH_3(I,J)=DTIME*DLNR*YWIH(I,J,3)
+
+!             CWHI_1(I,J)=DTIME*DLNR*YWHI(I,J,1)
+!             CWHI_2(I,J)=DTIME*DLNR*YWHI(I,J,2)
+!             CWHI_3(I,J)=DTIME*DLNR*YWHI(I,J,3)
+! barry
+              if (i.lt.12.and.j.lt.12)then
+
+!              CWII_1_1(I,J)=0.D0
+!              CWII_1_2(I,J)=0.D0
+!              CWII_1_3(I,J)=0.D0
+
+!              CWII_2_1(I,J)=0.D0
+!              CWII_2_2(I,J)=0.D0
+!              CWII_2_3(I,J)=0.D0
+
+!              CWII_3_1(I,J)=0.D0
+!              CWII_3_2(I,J)=0.D0
+!              CWII_3_3(I,J)=0.D0
+!barry
+              else
+!              CWII_1_1(I,J)=DTIME*DLNR*YWII(I,J,1,1)
+!              CWII_1_2(I,J)=DTIME*DLNR*YWII(I,J,1,2)
+!              CWII_1_3(I,J)=DTIME*DLNR*YWII(I,J,1,3)
+
+!              CWII_2_1(I,J)=DTIME*DLNR*YWII(I,J,2,1)
+!              CWII_2_2(I,J)=DTIME*DLNR*YWII(I,J,2,2)
+!              CWII_2_3(I,J)=DTIME*DLNR*YWII(I,J,2,3)
+
+!              CWII_3_1(I,J)=DTIME*DLNR*YWII(I,J,3,1)
+!              CWII_3_2(I,J)=DTIME*DLNR*YWII(I,J,3,2)
+!              CWII_3_3(I,J)=DTIME*DLNR*YWII(I,J,3,3)
+              end if
+           ENDDO
+        ENDDO
+!       GO TO 88
+! NEW CHANGES 2.06.01 (BEGIN)
+        CALL TURBCOEF
+        DO J=1,7
+           DO I=15,24-J
+              CWGL(I,J)=0.0D0
+           ENDDO
+        ENDDO
+! NEW CHANGES 2.06.01 (END)
+! NEW CHANGES 3.02.01 (BEGIN)
+        DO I=1,NKR
+           DO J=1,NKR
+              CWLG(J,I)=CWGL(I,J)
+           ENDDO
+        ENDDO
+!       print*, 'ICETURB = ',ICETURB
+          DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+               IF (ICETURB.EQ.1)THEN
+                CWGL(I,J)=CTURBGL(I,J)*CWGL(I,J)
+               ELSE
+                CWGL(I,J)=CWGL(I,J)
+               END IF
+             ENDDO
+          ENDDO
+          DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+                CWLG(J,I)=CWGL(I,J)
+             ENDDO
+          ENDDO
+
+88     CONTINUE
+	RETURN
+	END SUBROUTINE KERNALS_IN
+        SUBROUTINE TURBCOEF
+        IMPLICIT NONE
+        INTEGER I,J
+!       DOUBLE PRECISION X_KERN,Y_KERN,F
+        DOUBLE PRECISION X_KERN,Y_KERN
+	DOUBLE PRECISION RL_LL(K0_LL),RL_GL(K0L_GL),RG_GL(K0G_GL)
+          RL_LL(1)=RADXXO(KRMIN_LL,1)*1.E4
+          RL_LL(2)=10.0D0
+          RL_LL(3)=20.0D0
+          RL_LL(4)=30.0D0
+          RL_LL(5)=40.0D0
+          RL_LL(6)=50.0D0
+          RL_LL(7)=60.0D0
+          RL_LL(8)=RADXXO(KRMAX_LL,1)*1.E4
+          DO J=1,K0_LL
+             DO I=1,K0_LL
+                CTURB_LL(I,J)=1.0D0
+             ENDDO
+          ENDDO 
+	  CTURB_LL(1,1)=4.50D0
+	  CTURB_LL(1,2)=4.50D0
+	  CTURB_LL(1,3)=3.00D0
+	  CTURB_LL(1,4)=2.25D0
+	  CTURB_LL(1,5)=1.95D0
+	  CTURB_LL(1,6)=1.40D0
+	  CTURB_LL(1,7)=1.40D0
+	  CTURB_LL(1,8)=1.40D0
+
+	  CTURB_LL(2,1)=4.50D0
+	  CTURB_LL(2,2)=4.50D0
+	  CTURB_LL(2,3)=3.00D0
+	  CTURB_LL(2,4)=2.25D0
+	  CTURB_LL(2,5)=1.95D0
+	  CTURB_LL(2,6)=1.40D0
+	  CTURB_LL(2,7)=1.40D0
+	  CTURB_LL(2,8)=1.40D0
+
+	  CTURB_LL(3,1)=3.00D0
+	  CTURB_LL(3,2)=3.00D0
+	  CTURB_LL(3,3)=2.70D0
+	  CTURB_LL(3,4)=2.25D0
+	  CTURB_LL(3,5)=1.65D0
+	  CTURB_LL(3,6)=1.40D0
+	  CTURB_LL(3,7)=1.40D0
+	  CTURB_LL(3,8)=1.40D0
+
+	  CTURB_LL(4,1)=2.25D0
+	  CTURB_LL(4,2)=2.25D0
+	  CTURB_LL(4,3)=2.25D0
+	  CTURB_LL(4,4)=1.95D0
+	  CTURB_LL(4,5)=1.65D0
+	  CTURB_LL(4,6)=1.40D0
+	  CTURB_LL(4,7)=1.40D0
+	  CTURB_LL(4,8)=1.40D0
+
+	  CTURB_LL(5,1)=1.95D0
+	  CTURB_LL(5,2)=1.95D0
+	  CTURB_LL(5,3)=1.65D0
+	  CTURB_LL(5,4)=1.65D0
+	  CTURB_LL(5,5)=1.65D0
+	  CTURB_LL(5,6)=1.40D0
+	  CTURB_LL(5,7)=1.40D0
+	  CTURB_LL(5,8)=1.40D0
+
+	  CTURB_LL(6,1)=1.40D0
+	  CTURB_LL(6,2)=1.40D0
+	  CTURB_LL(6,3)=1.40D0
+	  CTURB_LL(6,4)=1.40D0
+	  CTURB_LL(6,5)=1.40D0
+	  CTURB_LL(6,6)=1.40D0
+	  CTURB_LL(6,7)=1.40D0
+	  CTURB_LL(6,8)=1.40D0
+
+	  CTURB_LL(7,1)=1.40D0
+	  CTURB_LL(7,2)=1.40D0
+	  CTURB_LL(7,3)=1.40D0
+	  CTURB_LL(7,4)=1.40D0
+	  CTURB_LL(7,5)=1.40D0
+	  CTURB_LL(7,6)=1.40D0
+	  CTURB_LL(7,7)=1.40D0
+	  CTURB_LL(7,8)=1.40D0
+
+	  CTURB_LL(8,1)=1.40D0
+	  CTURB_LL(8,2)=1.40D0
+	  CTURB_LL(8,3)=1.40D0
+	  CTURB_LL(8,4)=1.40D0
+	  CTURB_LL(8,5)=1.40D0
+	  CTURB_LL(8,6)=1.40D0
+	  CTURB_LL(8,7)=1.40D0
+	  CTURB_LL(8,8)=1.40D0
+          DO J=1,K0_LL
+             DO I=1,K0_LL
+                CTURB_LL(I,J)=(CTURB_LL(I,J)-1.0D0)/1.5D0+1.0D0
+             ENDDO
+          ENDDO
+	  DO I=KRMIN_LL,KRMAX_LL
+             DO J=KRMIN_LL,KRMAX_LL
+                CTURBLL(I,J)=1.0D0
+             ENDDO
+          ENDDO
+          DO I=KRMIN_LL,KRMAX_LL
+             X_KERN=RADXXO(I,1)*1.0D4
+             IF(X_KERN.LT.RL_LL(1)) X_KERN=RL_LL(1)
+             IF(X_KERN.GT.RL_LL(K0_LL)) X_KERN=RL_LL(K0_LL) 
+             DO J=KRMIN_LL,KRMAX_LL
+                Y_KERN=RADXXO(J,1)*1.0D4
+                IF(Y_KERN.LT.RL_LL(1)) Y_KERN=RL_LL(1)
+                IF(Y_KERN.GT.RL_LL(K0_LL)) Y_KERN=RL_LL(K0_LL)
+                CTURBLL(I,J)=F(X_KERN,Y_KERN,RL_LL,RL_LL,CTURB_LL &
+     &                      ,K0_LL,K0_LL)	                         
+             ENDDO
+          ENDDO
+          RL_GL(1) = RADXXO(1,1)*1.E4 
+          RL_GL(2) = 8.0D0
+          RL_GL(3) = 10.0D0
+	  RL_GL(4) = 16.0D0
+          RL_GL(5) = 20.0D0
+          RL_GL(6) = 30.0D0
+          RL_GL(7) = 40.0D0
+          RL_GL(8) = 50.0D0
+          RL_GL(9) = 60.0D0
+          RL_GL(10)= 70.0D0
+          RL_GL(11)= 80.0D0
+	  RL_GL(12)= 90.0D0
+	  RL_GL(13)=100.0D0
+	  RL_GL(14)=200.0D0
+	  RL_GL(15)=300.0D0
+	  RL_GL(16)=RADXXO(24,1)*1.0D4
+! TURBULENCE GRAUPEL BULK RADII IN MKM
+          RG_GL(1) = RADXXO(1,6)*1.0D4 
+          RG_GL(2) = 30.0D0  
+          RG_GL(3) = 60.0D0 
+          RG_GL(4) = 100.0D0 
+          RG_GL(5) = 200.0D0 
+	  RG_GL(6) = 300.0D0
+	  RG_GL(7) = 400.0D0
+	  RG_GL(8) = 500.0D0
+	  RG_GL(9) = 600.0D0
+	  RG_GL(10)= 700.0D0
+	  RG_GL(11)= 800.0D0
+	  RG_GL(12)= 900.0D0
+	  RG_GL(13)=1000.0D0
+	  RG_GL(14)=2000.0D0
+	  RG_GL(15)=3000.0D0
+	  RG_GL(16)=RADXXO(33,6)*1.0D4
+	  DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+                CTURBGL(I,J)=1.0D0
+             ENDDO
+          ENDDO
+          DO I=1,K0G_GL
+             DO J=1,K0L_GL
+                CTURB_GL(I,J)=1.0D0
+             ENDDO
+          ENDDO 
+          IF(IEPS_400.EQ.1) THEN
+	    CTURB_GL(1,1)=0.0D0
+	    CTURB_GL(1,2)=0.0D0
+	    CTURB_GL(1,3)=1.2D0
+	    CTURB_GL(1,4)=1.3D0
+	    CTURB_GL(1,5)=1.4D0
+	    CTURB_GL(1,6)=1.5D0
+	    CTURB_GL(1,7)=1.5D0
+	    CTURB_GL(1,8)=1.5D0
+	    CTURB_GL(1,9)=1.5D0
+	    CTURB_GL(1,10)=1.5D0
+	    CTURB_GL(1,11)=1.5D0
+	    CTURB_GL(1,12)=1.0D0
+	    CTURB_GL(1,13)=1.0D0
+	    CTURB_GL(1,14)=1.0D0
+	    CTURB_GL(1,15)=1.0D0
+	
+	    CTURB_GL(2,1)=1.0D0
+	    CTURB_GL(2,2)=1.4D0
+	    CTURB_GL(2,3)=1.8D0
+	    CTURB_GL(2,4)=2.2D0
+	    CTURB_GL(2,5)=2.6D0
+	    CTURB_GL(2,6)=3.0D0
+	    CTURB_GL(2,7)=2.85D0
+	    CTURB_GL(2,8)=2.7D0
+	    CTURB_GL(2,9)=2.55D0
+	    CTURB_GL(2,10)=2.4D0
+	    CTURB_GL(2,11)=2.25D0
+	    CTURB_GL(2,12)=1.0D0
+	    CTURB_GL(2,13)=1.0D0
+	    CTURB_GL(2,14)=1.0D0
+
+	    CTURB_GL(3,1)=7.5D0
+	    CTURB_GL(3,2)=7.5D0
+	    CTURB_GL(3,3)=4.5D0	
+	    CTURB_GL(3,4)=4.5D0	
+	    CTURB_GL(3,5)=4.65D0	
+	    CTURB_GL(3,6)=4.65D0	
+	    CTURB_GL(3,7)=4.5D0	
+	    CTURB_GL(3,8)=4.5D0	
+	    CTURB_GL(3,9)=4.0D0	
+	    CTURB_GL(3,10)=3.0D0	
+	    CTURB_GL(3,11)=2.0D0	
+	    CTURB_GL(3,12)=1.5D0	
+	    CTURB_GL(3,13)=1.3D0	
+	    CTURB_GL(3,14)=1.0D0	
+    
+	    CTURB_GL(4,1)=5.5D0
+	    CTURB_GL(4,2)=5.5D0
+	    CTURB_GL(4,3)=4.5D0
+	    CTURB_GL(4,4)=4.5D0
+	    CTURB_GL(4,5)=4.65D0
+	    CTURB_GL(4,6)=4.65D0
+	    CTURB_GL(4,7)=4.5D0
+	    CTURB_GL(4,8)=4.5D0
+	    CTURB_GL(4,9)=4.0D0
+	    CTURB_GL(4,10)=3.0D0
+	    CTURB_GL(4,11)=2.0D0
+	    CTURB_GL(4,12)=1.5D0
+	    CTURB_GL(4,13)=1.35D0
+	    CTURB_GL(4,14)=1.0D0
+	 
+	    CTURB_GL(5,1)=4.5D0
+	    CTURB_GL(5,2)=4.5D0
+	    CTURB_GL(5,3)=3.3D0	
+	    CTURB_GL(5,4)=3.3D0	
+	    CTURB_GL(5,5)=3.3D0	
+	    CTURB_GL(5,6)=3.4D0	
+	    CTURB_GL(5,7)=3.8D0	
+	    CTURB_GL(5,8)=3.8D0	
+	    CTURB_GL(5,9)=3.8D0	
+	    CTURB_GL(5,10)=3.6D0
+	    CTURB_GL(5,11)=2.5D0	
+	    CTURB_GL(5,12)=2.0D0	
+	    CTURB_GL(5,13)=1.4D0	
+	    CTURB_GL(5,14)=1.0D0	
+			 		
+	    CTURB_GL(6,1)=4.0D0
+	    CTURB_GL(6,2)=4.0D0
+	    CTURB_GL(6,3)=2.8D0
+	    CTURB_GL(6,4)=2.8D0
+	    CTURB_GL(6,5)=2.85D0
+	    CTURB_GL(6,6)=2.9D0
+	    CTURB_GL(6,7)=3.0D0
+	    CTURB_GL(6,8)=3.1D0
+	    CTURB_GL(6,9)=2.9D0
+	    CTURB_GL(6,10)=2.6D0
+	    CTURB_GL(6,11)=2.5D0
+	    CTURB_GL(6,12)=2.0D0
+	    CTURB_GL(6,13)=1.3D0
+	    CTURB_GL(6,14)=1.1D0
+
+	    CTURB_GL(7,1)=3.5D0
+	    CTURB_GL(7,2)=3.5D0
+	    CTURB_GL(7,3)=2.5D0
+	    CTURB_GL(7,4)=2.5D0
+	    CTURB_GL(7,5)=2.6D0
+	    CTURB_GL(7,6)=2.7D0
+	    CTURB_GL(7,7)=2.8D0
+	    CTURB_GL(7,8)=2.8D0
+	    CTURB_GL(7,9)=2.8D0
+	    CTURB_GL(7,10)=2.6D0
+	    CTURB_GL(7,11)=2.3D0
+	    CTURB_GL(7,12)=2.0D0
+	    CTURB_GL(7,13)=1.3D0
+	    CTURB_GL(7,14)=1.1D0
+
+	    CTURB_GL(8,1)=3.25D0
+	    CTURB_GL(8,2)=3.25D0
+	    CTURB_GL(8,3)=2.3D0
+	    CTURB_GL(8,4)=2.3D0
+	    CTURB_GL(8,5)=2.35D0
+	    CTURB_GL(8,6)=2.37D0
+	    CTURB_GL(8,7)=2.55D0
+	    CTURB_GL(8,8)=2.55D0
+	    CTURB_GL(8,9)=2.55D0
+	    CTURB_GL(8,10)=2.3D0
+	    CTURB_GL(8,11)=2.1D0
+	    CTURB_GL(8,12)=1.9D0
+	    CTURB_GL(8,13)=1.3D0
+	    CTURB_GL(8,14)=1.1D0
+
+	    CTURB_GL(9,1)=3.0D0
+	    CTURB_GL(9,2)=3.0D0
+	    CTURB_GL(9,3)=3.1D0
+	    CTURB_GL(9,4)=2.2D0
+	    CTURB_GL(9,5)=2.2D0
+	    CTURB_GL(9,6)=2.2D0
+	    CTURB_GL(9,7)=2.3D0
+	    CTURB_GL(9,8)=2.3D0
+	    CTURB_GL(9,9)=2.5D0
+	    CTURB_GL(9,10)=2.5D0
+	    CTURB_GL(9,11)=2.2D0
+	    CTURB_GL(9,12)=1.8D0
+	    CTURB_GL(9,13)=1.25D0
+	    CTURB_GL(9,14)=1.1D0
+
+	    CTURB_GL(10,1)=2.75D0
+	    CTURB_GL(10,2)=2.75D0
+	    CTURB_GL(10,3)=2.0D0
+	    CTURB_GL(10,4)=2.0D0
+	    CTURB_GL(10,5)=2.0D0
+	    CTURB_GL(10,6)=2.1D0
+	    CTURB_GL(10,7)=2.2D0
+	    CTURB_GL(10,8)=2.2D0
+	    CTURB_GL(10,9)=2.3D0
+	    CTURB_GL(10,10)=2.3D0
+	    CTURB_GL(10,11)=2.3D0
+	    CTURB_GL(10,12)=1.8D0
+	    CTURB_GL(10,13)=1.2D0
+	    CTURB_GL(10,14)=1.1D0
+
+	    CTURB_GL(11,1)=2.6D0
+	    CTURB_GL(11,2)=2.6D0
+	    CTURB_GL(11,3)=1.95D0
+	    CTURB_GL(11,4)=1.95D0
+	    CTURB_GL(11,5)=1.95D0
+	    CTURB_GL(11,6)=2.05D0
+	    CTURB_GL(11,7)=2.15D0
+	    CTURB_GL(11,8)=2.15D0
+	    CTURB_GL(11,9)=2.25D0
+	    CTURB_GL(11,10)=2.25D0
+	    CTURB_GL(11,11)=1.9D0
+	    CTURB_GL(11,12)=1.8D0
+	    CTURB_GL(11,13)=1.2D0
+	    CTURB_GL(11,14)=1.1D0
+
+	    CTURB_GL(12,1)=2.4D0
+	    CTURB_GL(12,2)=2.4D0
+	    CTURB_GL(12,3)=1.85D0
+	    CTURB_GL(12,4)=1.85D0
+	    CTURB_GL(12,5)=1.85D0
+	    CTURB_GL(12,6)=1.75D0
+	    CTURB_GL(12,7)=1.85D0
+	    CTURB_GL(12,8)=1.85D0
+	    CTURB_GL(12,9)=2.1D0
+	    CTURB_GL(12,10)=2.1D0
+	    CTURB_GL(12,11)=1.9D0
+	    CTURB_GL(12,12)=1.8D0 
+	    CTURB_GL(12,13)=1.3D0
+	    CTURB_GL(12,14)=1.1D0
+
+	    CTURB_GL(13,1)=1.67D0
+	    CTURB_GL(13,2)=1.67D0
+	    CTURB_GL(13,3)=1.75D0
+	    CTURB_GL(13,4)=1.83D0
+	    CTURB_GL(13,5)=1.87D0
+	    CTURB_GL(13,6)=2.0D0
+	    CTURB_GL(13,7)=2.1D0
+	    CTURB_GL(13,8)=2.12D0
+	    CTURB_GL(13,9)=2.15D0
+	    CTURB_GL(13,10)=2.18D0
+	    CTURB_GL(13,11)=2.19D0
+	    CTURB_GL(13,12)=1.67D0
+	    CTURB_GL(13,13)=1.28D0
+	    CTURB_GL(13,14)=1.0D0
+
+	    CTURB_GL(14,1)=1.3D0
+	    CTURB_GL(14,2)=1.3D0
+	    CTURB_GL(14,3)=1.35D0
+	    CTURB_GL(14,4)=1.4D0
+	    CTURB_GL(14,5)=1.6D0
+	    CTURB_GL(14,6)=1.7D0
+	    CTURB_GL(14,7)=1.7D0
+	    CTURB_GL(14,8)=1.7D0
+	    CTURB_GL(14,9)=1.7D0
+	    CTURB_GL(14,10)=1.7D0
+	    CTURB_GL(14,11)=1.7D0
+	    CTURB_GL(14,12)=1.4D0
+	    CTURB_GL(14,13)=1.25D0
+	    CTURB_GL(14,14)=1.0D0
+
+	    CTURB_GL(15,1)=1.17D0
+	    CTURB_GL(15,2)=1.17D0
+	    CTURB_GL(15,3)=1.17D0
+	    CTURB_GL(15,4)=1.25D0
+	    CTURB_GL(15,5)=1.3D0
+	    CTURB_GL(15,6)=1.35D0
+	    CTURB_GL(15,7)=1.4D0
+	    CTURB_GL(15,8)=1.4D0
+	    CTURB_GL(15,9)=1.45D0
+	    CTURB_GL(15,10)=1.47D0
+	    CTURB_GL(15,11)=1.44D0
+	    CTURB_GL(15,12)=1.3D0
+	    CTURB_GL(15,13)=1.12D0
+	    CTURB_GL(15,14)=1.0D0
+
+	    CTURB_GL(16,1)=1.17D0
+	    CTURB_GL(16,2)=1.17D0
+	    CTURB_GL(16,3)=1.17D0
+	    CTURB_GL(16,4)=1.25D0
+	    CTURB_GL(16,5)=1.3D0
+	    CTURB_GL(16,6)=1.35D0
+	    CTURB_GL(16,7)=1.4D0
+	    CTURB_GL(16,8)=1.45D0
+	    CTURB_GL(16,9)=1.45D0
+	    CTURB_GL(16,10)=1.47D0
+	    CTURB_GL(16,11)=1.44D0
+	    CTURB_GL(16,12)=1.3D0
+	    CTURB_GL(16,13)=1.12D0
+	    CTURB_GL(16,14)=1.0D0
+          ENDIF
+          IF(IEPS_800.EQ.1) THEN
+	    CTURB_GL(1,1) =0.00D0
+	    CTURB_GL(1,2) =0.00D0
+	    CTURB_GL(1,3) =1.00D0
+            CTURB_GL(1,4) =1.50D0
+	    CTURB_GL(1,5) =1.40D0
+	    CTURB_GL(1,6) =1.30D0
+	    CTURB_GL(1,7) =1.20D0
+	    CTURB_GL(1,8) =1.10D0
+	    CTURB_GL(1,9) =1.00D0
+	    CTURB_GL(1,10)=1.00D0
+	    CTURB_GL(1,11)=1.00D0
+	    CTURB_GL(1,12)=1.00D0
+	    CTURB_GL(1,13)=1.00D0
+	    CTURB_GL(1,14)=1.00D0
+	    CTURB_GL(1,15)=1.00D0
+	    CTURB_GL(1,16)=1.00D0
+
+	    CTURB_GL(2,1) =0.00D0
+	    CTURB_GL(2,2) =0.00D0
+	    CTURB_GL(2,3) =1.00D0
+	    CTURB_GL(2,4) =2.00D0
+	    CTURB_GL(2,5) =1.80D0
+	    CTURB_GL(2,6) =1.70D0
+	    CTURB_GL(2,7) =1.60D0
+	    CTURB_GL(2,8) =1.50D0
+	    CTURB_GL(2,9) =1.50D0
+	    CTURB_GL(2,10)=1.50D0
+	    CTURB_GL(2,11)=1.50D0
+	    CTURB_GL(2,12)=1.50D0
+	    CTURB_GL(2,13)=1.50D0
+	    CTURB_GL(2,14)=1.00D0
+	    CTURB_GL(2,15)=1.00D0
+	    CTURB_GL(2,16)=1.00D0
+
+	    CTURB_GL(3,1) =0.00D0
+	    CTURB_GL(3,2) =0.00D0
+	    CTURB_GL(3,3) =4.00D0
+	    CTURB_GL(3,4) =7.65D0
+	    CTURB_GL(3,5) =7.65D0
+	    CTURB_GL(3,6) =8.00D0
+	    CTURB_GL(3,7) =8.00D0
+	    CTURB_GL(3,8) =7.50D0
+	    CTURB_GL(3,9) =6.50D0
+	    CTURB_GL(3,10)=6.00D0
+	    CTURB_GL(3,11)=5.00D0
+	    CTURB_GL(3,12)=4.50D0
+	    CTURB_GL(3,13)=4.00D0
+	    CTURB_GL(3,14)=2.00D0
+	    CTURB_GL(3,15)=1.30D0
+	    CTURB_GL(3,16)=1.00D0
+
+	    CTURB_GL(4,1) =7.50D0
+	    CTURB_GL(4,2) =7.50D0
+	    CTURB_GL(4,3) =7.50D0
+	    CTURB_GL(4,4) =7.65D0	
+	    CTURB_GL(4,5) =7.65D0	
+	    CTURB_GL(4,6) =8.00D0	
+	    CTURB_GL(4,7) =8.00D0	
+	    CTURB_GL(4,8) =7.50D0	
+	    CTURB_GL(4,9) =6.50D0	
+	    CTURB_GL(4,10)=6.00D0	
+	    CTURB_GL(4,11)=5.00D0	
+	    CTURB_GL(4,12)=4.50D0	
+	    CTURB_GL(4,13)=4.00D0	
+	    CTURB_GL(4,14)=2.00D0	
+	    CTURB_GL(4,15)=1.30D0	
+	    CTURB_GL(4,16)=1.00D0	
+    
+	    CTURB_GL(5,1) =5.50D0
+	    CTURB_GL(5,2) =5.50D0
+	    CTURB_GL(5,3) =5.50D0
+	    CTURB_GL(5,4) =5.75D0
+	    CTURB_GL(5,5) =5.75D0
+	    CTURB_GL(5,6) =6.00D0
+	    CTURB_GL(5,7) =6.25D0
+	    CTURB_GL(5,8) =6.17D0
+	    CTURB_GL(5,9) =5.75D0
+	    CTURB_GL(5,10)=5.25D0
+	    CTURB_GL(5,11)=4.75D0
+	    CTURB_GL(5,12)=4.25D0
+	    CTURB_GL(5,13)=4.00D0
+	    CTURB_GL(5,14)=2.00D0
+	    CTURB_GL(5,15)=1.35D0
+	    CTURB_GL(5,16)=1.00D0
+	 
+	    CTURB_GL(6,1) =4.50D0
+	    CTURB_GL(6,2) =4.50D0
+	    CTURB_GL(6,3) =4.50D0
+	    CTURB_GL(6,4) =4.75D0	
+	    CTURB_GL(6,5) =4.75D0	
+	    CTURB_GL(6,6) =5.00D0	
+	    CTURB_GL(6,7) =5.25D0	
+	    CTURB_GL(6,8) =5.25D0	
+	    CTURB_GL(6,9) =5.00D0	
+	    CTURB_GL(6,10)=4.75D0	
+	    CTURB_GL(6,11)=4.50D0	
+	    CTURB_GL(6,12)=4.00D0	
+	    CTURB_GL(6,13)=3.75D0	
+	    CTURB_GL(6,14)=2.00D0	
+	    CTURB_GL(6,15)=1.40D0	
+	    CTURB_GL(6,16)=1.00D0	
+			 		
+	    CTURB_GL(7,1) =4.00D0
+	    CTURB_GL(7,2) =4.00D0
+	    CTURB_GL(7,3) =4.00D0
+	    CTURB_GL(7,4) =4.00D0
+	    CTURB_GL(7,5) =4.00D0
+	    CTURB_GL(7,6) =4.25D0
+	    CTURB_GL(7,7) =4.50D0
+	    CTURB_GL(7,8) =4.67D0
+	    CTURB_GL(7,9) =4.50D0
+	    CTURB_GL(7,10)=4.30D0
+	    CTURB_GL(7,11)=4.10D0
+	    CTURB_GL(7,12)=3.80D0
+	    CTURB_GL(7,13)=3.50D0
+	    CTURB_GL(7,14)=2.00D0
+	    CTURB_GL(7,15)=1.30D0
+	    CTURB_GL(7,16)=1.10D0
+
+	    CTURB_GL(8,1) =3.50D0
+	    CTURB_GL(8,2) =3.50D0
+	    CTURB_GL(8,3) =3.50D0
+	    CTURB_GL(8,4) =3.65D0
+	    CTURB_GL(8,5) =3.65D0
+	    CTURB_GL(8,6) =3.80D0
+	    CTURB_GL(8,7) =4.1D02
+	    CTURB_GL(8,8) =4.17D0
+	    CTURB_GL(8,9) =4.17D0
+	    CTURB_GL(8,10)=4.00D0
+	    CTURB_GL(8,11)=3.80D0
+	    CTURB_GL(8,12)=3.67D0
+	    CTURB_GL(8,13)=3.40D0
+	    CTURB_GL(8,14)=2.00D0
+	    CTURB_GL(8,15)=1.30D0
+	    CTURB_GL(8,16)=1.10D0
+
+	    CTURB_GL(9,1) =3.25D0
+	    CTURB_GL(9,2) =3.25D0
+	    CTURB_GL(9,3) =3.25D0
+	    CTURB_GL(9,4) =3.25D0
+	    CTURB_GL(9,5) =3.25D0
+	    CTURB_GL(9,6) =3.50D0
+	    CTURB_GL(9,7) =3.75D0
+	    CTURB_GL(9,8) =3.75D0
+	    CTURB_GL(9,9) =3.75D0
+	    CTURB_GL(9,10)=3.75D0
+	    CTURB_GL(9,11)=3.60D0
+	    CTURB_GL(9,12)=3.40D0
+	    CTURB_GL(9,13)=3.25D0
+	    CTURB_GL(9,14)=2.00D0
+	    CTURB_GL(9,15)=1.30D0
+	    CTURB_GL(9,16)=1.10D0
+	    
+	    CTURB_GL(10,1) =3.00D0
+	    CTURB_GL(10,2) =3.00D0
+	    CTURB_GL(10,3) =3.00D0
+	    CTURB_GL(10,4) =3.10D0
+	    CTURB_GL(10,5) =3.10D0
+	    CTURB_GL(10,6) =3.25D0
+	    CTURB_GL(10,7) =3.40D0
+	    CTURB_GL(10,8) =3.50D0
+	    CTURB_GL(10,9) =3.50D0
+	    CTURB_GL(10,10)=3.50D0
+	    CTURB_GL(10,11)=3.40D0
+	    CTURB_GL(10,12)=3.25D0
+	    CTURB_GL(10,13)=3.15D0
+	    CTURB_GL(10,14)=1.90D0
+	    CTURB_GL(10,15)=1.30D0
+	    CTURB_GL(10,16)=1.10D0
+
+	    CTURB_GL(11,1) =2.75D0
+	    CTURB_GL(11,2) =2.75D0
+	    CTURB_GL(11,3) =2.75D0
+	    CTURB_GL(11,4) =2.75D0
+	    CTURB_GL(11,5) =2.75D0
+	    CTURB_GL(11,6) =3.00D0
+	    CTURB_GL(11,7) =3.25D0
+	    CTURB_GL(11,8) =3.25D0
+	    CTURB_GL(11,9) =3.25D0
+	    CTURB_GL(11,10)=3.25D0
+	    CTURB_GL(11,11)=3.25D0
+	    CTURB_GL(11,12)=3.15D0
+	    CTURB_GL(11,13)=3.00D0
+	    CTURB_GL(11,14)=1.80D0
+	    CTURB_GL(11,15)=1.30D0
+	    CTURB_GL(11,16)=1.10D0
+
+	    CTURB_GL(12,1) =2.60D0
+	    CTURB_GL(12,2) =2.60D0
+	    CTURB_GL(12,3) =2.60D0
+	    CTURB_GL(12,4) =2.67D0
+	    CTURB_GL(12,5) =2.67D0
+	    CTURB_GL(12,6) =2.75D0
+	    CTURB_GL(12,7) =3.00D0
+	    CTURB_GL(12,8) =3.17D0
+	    CTURB_GL(12,9) =3.17D0
+	    CTURB_GL(12,10)=3.17D0
+	    CTURB_GL(12,11)=3.10D0
+	    CTURB_GL(12,12)=2.90D0
+	    CTURB_GL(12,13)=2.80D0
+	    CTURB_GL(12,14)=1.87D0
+	    CTURB_GL(12,15)=1.37D0
+	    CTURB_GL(12,16)=1.10D0
+
+	    CTURB_GL(13,1) =2.40D0
+	    CTURB_GL(13,2) =2.40D0
+	    CTURB_GL(13,3) =2.40D0
+	    CTURB_GL(13,4) =2.50D0
+	    CTURB_GL(13,5) =2.50D0
+	    CTURB_GL(13,6) =2.67D0
+	    CTURB_GL(13,7) =2.83D0
+	    CTURB_GL(13,8) =2.90D0
+	    CTURB_GL(13,9) =3.00D0
+	    CTURB_GL(13,10)=2.90D0
+	    CTURB_GL(13,11)=2.85D0
+	    CTURB_GL(13,12)=2.80D0
+	    CTURB_GL(13,13)=2.75D0
+	    CTURB_GL(13,14)=1.83D0
+	    CTURB_GL(13,15)=1.30D0
+	    CTURB_GL(13,16)=1.10D0
+
+	    CTURB_GL(14,1) =1.67D0
+	    CTURB_GL(14,2) =1.67D0
+	    CTURB_GL(14,3) =1.67D0
+	    CTURB_GL(14,4) =1.75D0
+	    CTURB_GL(14,5) =1.75D0
+	    CTURB_GL(14,6) =1.83D0
+	    CTURB_GL(14,7) =1.87D0
+	    CTURB_GL(14,8) =2.00D0
+	    CTURB_GL(14,9) =2.10D0
+	    CTURB_GL(14,10)=2.12D0
+	    CTURB_GL(14,11)=2.15D0
+	    CTURB_GL(14,12)=2.18D0
+	    CTURB_GL(14,13)=2.19D0
+	    CTURB_GL(14,14)=1.67D0
+	    CTURB_GL(14,15)=1.28D0
+	    CTURB_GL(14,16)=1.00D0
+
+	    CTURB_GL(15,1) =1.30D0
+	    CTURB_GL(15,2) =1.30D0
+	    CTURB_GL(15,3) =1.30D0
+	    CTURB_GL(15,4) =1.35D0
+	    CTURB_GL(15,5) =1.35D0
+	    CTURB_GL(15,6) =1.40D0
+	    CTURB_GL(15,7) =1.60D0
+	    CTURB_GL(15,8) =1.70D0
+	    CTURB_GL(15,9) =1.70D0
+	    CTURB_GL(15,10)=1.70D0
+	    CTURB_GL(15,11)=1.70D0
+	    CTURB_GL(15,12)=1.70D0
+	    CTURB_GL(15,13)=1.70D0
+	    CTURB_GL(15,14)=1.40D0
+	    CTURB_GL(15,15)=1.25D0
+	    CTURB_GL(15,16)=1.00D0
+
+	    CTURB_GL(16,1) =1.17D0
+	    CTURB_GL(16,2) =1.17D0
+	    CTURB_GL(16,3) =1.17D0
+	    CTURB_GL(16,4) =1.17D0
+	    CTURB_GL(16,5) =1.17D0
+	    CTURB_GL(16,6) =1.25D0
+	    CTURB_GL(16,7) =1.30D0
+	    CTURB_GL(16,8) =1.35D0
+	    CTURB_GL(16,9) =1.40D0
+	    CTURB_GL(16,10)=1.45D0
+	    CTURB_GL(16,11)=1.45D0
+	    CTURB_GL(16,12)=1.47D0
+	    CTURB_GL(16,13)=1.44D0
+	    CTURB_GL(16,14)=1.30D0
+	    CTURB_GL(16,15)=1.12D0
+	    CTURB_GL(16,16)=1.00D0
+          ENDIF
+          IF(IEPS_800.EQ.1.AND.IEPS_1600.EQ.1) THEN
+            DO I=1,K0G_GL
+               DO J=1,K0L_GL
+                  CTURB_GL(I,J)=CTURB_GL(I,J)*1.7D0
+               ENDDO
+            ENDDO 
+          ENDIF
+          DO J=1,K0L_GL
+             DO I=1,K0G_GL
+                CTURB_GL(I,J)=(CTURB_GL(I,J)-1.0D0)/1.5D0+1.0D0
+             ENDDO
+          ENDDO
+	  DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+                CTURBGL(I,J)=1.
+             ENDDO
+          ENDDO
+          DO I=KRMING_GL,KRMAXG_GL                   
+             X_KERN=RADXXO(I,6)*1.0D4
+             IF(X_KERN.LT.RG_GL(1)) X_KERN=RG_GL(1)
+             IF(X_KERN.GT.RG_GL(K0G_GL)) X_KERN=RG_GL(K0G_GL) 
+             DO J=KRMINL_GL,KRMAXL_GL
+                Y_KERN=RADXXO(J,1)*1.0D4
+                IF(Y_KERN.LT.RL_GL(1)) Y_KERN=RL_GL(1)
+                IF(Y_KERN.GT.RL_GL(K0L_GL)) Y_KERN=RL_GL(K0L_GL)
+                CTURBGL(I,J)=F(X_KERN,Y_KERN,RG_GL,RL_GL,CTURB_GL &
+     &                      ,K0G_GL,K0L_GL)	      
+             ENDDO
+          ENDDO
+          IF(IEPS_800.EQ.1) THEN
+            DO I=KRMING_GL,15
+               DO J=KRMINL_GL,13
+                  IF(CTURBGL(I,J).LT.3.0D0) CTURBGL(I,J)=3.0D0
+               ENDDO
+            ENDDO
+          ENDIF
+          IF(IEPS_1600.EQ.1) THEN
+            DO I=KRMING_GL,15
+               DO J=KRMINL_GL,13
+                  IF(CTURBGL(I,J).LT.5.1D0) CTURBGL(I,J)=5.1D0
+               ENDDO
+            ENDDO
+          ENDIF
+	  DO I=1,33
+             DO J=1,24
+                IF(I.LE.14.AND.J.EQ.8) CTURBGL(I,J)=1.0D0
+                IF(I.GT.14.AND.J.LE.8) CTURBGL(I,J)=1.2D0
+	     ENDDO
+          ENDDO                       
+	RETURN
+	END SUBROUTINE TURBCOEF
+!===================================================================
+! QUESTION
+        real * 8 function f(x,y,x0,y0,table,k0,kk0)
+! two-dimensional linear interpolation of the collision efficiency
+! with help table(k0,kk0)
+
+       implicit none
+       integer k0,kk0,k,ir,kk,iq
+       double precision x,y,p,q,ec,ek
+!      double precision x,y,p,q,ec,ek,f
+       double precision x0(k0),y0(kk0),table(k0,kk0)
+
+
+        do k=2,k0
+           if(x.le.x0(k).and.x.ge.x0(k-1)) then
+             ir=k     
+           elseif(x.gt.x0(k0)) then
+             ir=k0+1
+           elseif(x.lt.x0(1)) then
+             ir=1
+           endif
+        enddo
+        do kk=2,kk0
+           if(y.le.y0(kk).and.y.ge.y0(kk-1)) iq=kk
+        enddo
+        if(ir.lt.k0+1) then
+          if(ir.ge.2) then
+            p =(x-x0(ir-1))/(x0(ir)-x0(ir-1))
+            q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
+            ec=(1.d0-p)*(1.d0-q)*table(ir-1,iq-1)+ &
+     &              p*(1.d0-q)*table(ir,iq-1)+ &
+     &              q*(1.d0-p)*table(ir-1,iq)+ &
+     &                   p*q*table(ir,iq)    
+          else
+            q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
+            ec=(1.d0-q)*table(1,iq-1)+q*table(1,iq)    
+          endif
+        else
+          q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
+          ek=(1.d0-q)*table(k0,iq-1)+q*table(k0,iq)
+          ec=min(ek,1.d0) 
+        endif
+        f=ec
+        return
+        end function f
+! function f
+                                                                            
+
+                                                                            
+
+!======================================================================
+        SUBROUTINE FREEZ(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
+     &,TIN,DT,RO,COL,AFREEZMY,BFREEZMY,BFREEZMAX,KRFREEZ,ICEMAX,NKR)       
+      IMPLICIT NONE 
+      INTEGER KR,ICE,ICE_TYPE
+      REAL COL,AFREEZMY,BFREEZMY,BFREEZMAX
+      INTEGER KRFREEZ,ICEMAX,NKR
+      REAL DT,RO,YKK,PF,PF_1,DEL_T,TT_DROP,ARG_1,YK2,DF1,BF,ARG_M, & 
+     & TT_DROP_AFTER_FREEZ,CFREEZ,SUM_ICE,TIN,TTIN,AF,FF_MAX,F1_MAX, &
+     & F2_MAX,F3_MAX,F4_MAX,F5_MAX
+
+
+	REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX) &
+     &           ,XI(NKR,ICEMAX),FF3(NKR),XS(NKR),FF4(NKR) &
+     &           ,XG(NKR),FF5(NKR),XH(NKR)
+
+
+
+	TTIN=TIN
+        DEL_T	=TTIN-273.15
+	ICE_TYPE=2
+	F1_MAX=0.
+	F2_MAX=0.
+	F3_MAX=0.
+	F4_MAX=0.
+	F5_MAX=0.
+	DO 1 KR=1,NKR
+	F1_MAX=AMAX1(F1_MAX,FF1(KR))
+	F3_MAX=AMAX1(F3_MAX,FF3(KR))
+	F4_MAX=AMAX1(F4_MAX,FF4(KR))
+	F5_MAX=AMAX1(F5_MAX,FF5(KR))
+	DO 1 ICE=1,ICEMAX
+     	F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
+    1   CONTINUE
+    	FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
+!
+!******************************* FREEZING ****************************
+!
+        IF(DEL_T.LT.0.AND.F1_MAX.NE.0) THEN
+	SUM_ICE=0.
+	AF	=AFREEZMY
+	CFREEZ	=(BFREEZMAX-BFREEZMY)/XL(NKR)
+!
+!***************************** MASS LOOP **************************
+!
+         DO  KR	=1,NKR
+	 ARG_M	=XL(KR)
+	 BF	=BFREEZMY+CFREEZ*ARG_M
+         PF_1	=AF*EXP(-BF*DEL_T)
+         PF	=ARG_M*PF_1
+	 YKK	=EXP(-PF*DT)
+         DF1	=FF1(KR)*(1.-YKK)
+	 YK2	=DF1
+         FF1(KR)=FF1(KR)*YKK
+	 IF(KR.LE.KRFREEZ)  THEN
+	 FF2(KR,ICE_TYPE)=FF2(KR,ICE_TYPE)+YK2
+			    ELSE
+	  FF5(KR)	=FF5(KR)+YK2
+	 ENDIF
+         SUM_ICE=SUM_ICE+YK2*3.*XL(KR)*XL(KR)*COL
+!
+!************************ END OF "MASS LOOP" **************************
+!
+	 ENDDO
+!
+!************************** NEW TEMPERATURE *************************
+!	
+	ARG_1	=333.*SUM_ICE/RO
+      	TT_DROP_AFTER_FREEZ=TTIN+ARG_1
+	TIN	=TT_DROP_AFTER_FREEZ
+!
+!************************** END OF "FREEZING" ****************************
+!
+	ENDIF
+!
+   	RETURN                                                           
+      	END SUBROUTINE FREEZ                                                             
+
+        SUBROUTINE ORIG_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
+     &                           ,TIN,DT,RO,COL,ICEMAX,NKR)
+      IMPLICIT NONE
+      INTEGER KR,ICE,ICE_TYPE
+      INTEGER ICEMAX,NKR
+      REAL COL
+      REAL ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DT,DF1,DN,DN0, &
+     & RO,A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, &
+     & DEL_T,gamma,TIN
+        REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX),XI(NKR,ICEMAX) &
+     &           ,FF3(NKR),XS(NKR),FF4(NKR) &
+     &           ,XG(NKR),FF5(NKR),XH(NKR)
+
+
+        gamma=4.4
+        DEL_T	=TIN-273.15
+	ICE_TYPE=2
+	F1_MAX=0.
+	F2_MAX=0.
+	F3_MAX=0.
+	F4_MAX=0.
+	F5_MAX=0.
+	DO 1 KR=1,NKR
+	F1_MAX=AMAX1(F1_MAX,FF1(KR))
+	F3_MAX=AMAX1(F3_MAX,FF3(KR))
+	F4_MAX=AMAX1(F4_MAX,FF4(KR))
+	F5_MAX=AMAX1(F5_MAX,FF5(KR))
+	DO 1 ICE=1,ICEMAX
+     	F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
+    1	CONTINUE
+    	FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
+! MELTING :
+	IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN
+	  SUM_ICE=0.
+! MASS LOOP :
+  	  DO KR=1,NKR
+	     ARG_M=FF3(KR)+FF4(KR)+FF5(KR)
+	     DO ICE=1,ICEMAX
+	        ARG_M=ARG_M+FF2(KR,ICE)
+      	        FF2(KR,ICE)=0.
+ 	     ENDDO
+      	     FF1(KR)=FF1(KR)+ARG_M
+      	     FF3(KR)=0.
+             FF4(KR)=0.
+      	     FF5(KR)=0.
+	     SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL
+! END OF "MASS LOOP"
+	  ENDDO
+! CYCLE BY KR
+! NEW TEMPERATURE :
+	  ARG_1=333.*SUM_ICE/RO	
+	  TIN=TIN-ARG_1
+! END OF MELTING
+! IN CASE DEL_T.GE.0.AND.FF_MAX.NE.0
+	ENDIF
+   	RETURN                                                           
+      	END SUBROUTINE ORIG_MELT                                                             
+!===================================================================
+       SUBROUTINE J_W_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
+     &                           ,TIN,DT,RO,COL,ICEMAX,NKR)
+      IMPLICIT NONE
+      INTEGER KR,ICE,ICE_TYPE
+      INTEGER ICEMAX,NKR
+      REAL COL
+      REAL ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DT,DF1,DN,DN0, &
+     & RO,A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, &
+     & DEL_T,TIN,meltrate
+        REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX),XI(NKR,ICEMAX) &
+     &           ,FF3(NKR),XS(NKR),FF4(NKR) &
+     &           ,XG(NKR),FF5(NKR),XH(NKR)
+
+
+!       gamma=4.4
+        DEL_T	=TIN-273.15
+	F1_MAX=0.
+	F2_MAX=0.
+	F3_MAX=0.
+	F4_MAX=0.
+	F5_MAX=0.
+	DO 1 KR=1,NKR
+	F1_MAX=AMAX1(F1_MAX,FF1(KR))
+	F3_MAX=AMAX1(F3_MAX,FF3(KR))
+	F4_MAX=AMAX1(F4_MAX,FF4(KR))
+	F5_MAX=AMAX1(F5_MAX,FF5(KR))
+	DO 1 ICE=1,ICEMAX
+     	F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
+    1	CONTINUE
+    	FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
+! MELTING :
+	SUM_ICE=0.
+	IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN
+! Fan's "MASS LOOP"
+          DO KR = 1,NKR
+             ARG_M = 0.
+            DO ICE = 1,ICEMAX
+             IF (ICE ==1) THEN
+                 IF (KR .le. 10) THEN
+                     FF2(KR,ICE)=0.
+                     ARG_M = ARG_M+FF2(KR,ICE)
+                 ELSEIF (KR .gt. 10 .and. KR .lt. 18) THEN
+                     meltrate = 0.5/50.
+                     FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
+                     ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
+                 ELSE
+                     meltrate = 0.683/120.
+                     FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
+                     ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
+                 ENDIF
+             ENDIF
+             IF (ICE ==2 .or. ICE ==3) THEN
+                IF (kr .le. 12) THEN
+                    FF2(KR,ICE)=0.
+                    ARG_M = ARG_M+FF2(KR,ICE)
+                ELSEIF (kr .gt. 12 .and. kr .lt. 20) THEN
+                    meltrate = 0.5/50.
+                    FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
+                    ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
+                 ELSE
+                     meltrate = 0.683/120.
+                    FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
+                    ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
+                 ENDIF
+             ENDIF
+            ENDDO  ! Do ice
+! snow
+                 IF (kr .le. 14) THEN
+                    FF3(KR)=0.
+                    ARG_M = ARG_M+FF3(KR)
+                 ELSEIF (kr .gt. 14 .and. kr .lt. 22) THEN
+                    meltrate = 0.5/50.
+                    FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
+                    ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
+                 ELSE
+                    meltrate = 0.683/120.
+                    FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
+                    ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
+                 ENDIF
+! graupel/hail
+                 IF (kr .le. 13) then
+                     FF4(KR)=0.
+                     FF5(KR)=0.
+                     ARG_M = ARG_M+FF4(KR)+FF5(KR)
+                 ELSEIF (kr .gt. 13 .and. kr .lt. 23) THEN
+                     meltrate = 0.5/50.
+                     FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
+                     FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
+                     ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
+                 ELSE
+                     meltrate = 0.683/120.
+                    FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
+                    FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
+                    ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
+                 ENDIF
+
+                   FF1(KR)=FF1(KR)+ARG_M
+
+                   SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL
+! END OF Fan'a "MASS LOOP"
+       ENDDO
+! CYCLE BY KR
+! NEW TEMPERATURE :
+        ARG_1=333.*SUM_ICE/RO
+        TIN=TIN-ARG_1
+! END OF MELTING
+
+	ENDIF
+   	RETURN                                                           
+      	END SUBROUTINE J_W_MELT                                                             
+      SUBROUTINE JERNUCL01(PSI1,PSI2,FCCNR &
+     &                    ,X1,X2,DTT,DQQ,ROR,PP,DSUP1,DSUP2 &
+     &  ,COL,AA1_MY, BB1_MY, AA2_MY, BB2_MY &
+     &  ,C1_MEY,C2_MEY,SUP2_OLD,DSUPICEXZ &
+     &  ,RCCN,DROPRADII,NKR,ICEMAX,ICEPROCS)
+      IMPLICIT NONE 
+!
+      INTEGER ICEMAX,NKR
+      INTEGER ICEPROCS
+      REAL COL,AA1_MY, BB1_MY, AA2_MY, BB2_MY, &
+     &  C1_MEY,C2_MEY,SUP2_OLD,DSUPICEXZ, &
+     &  RCCN(NKR),DROPRADII(NKR),FCCNR(NKR)
+!
+      INTEGER KR,ICE,ITYPE,NRGI,ICORR,II,JJ,KK,NKRDROP,NCRITI
+       DOUBLE PRECISION DTT,DQQ,DSUP1,DSUP2
+       REAL TT,QQ,              &
+     & DX,BMASS,CONCD,C2,CONCDF,DELTACD,CONCDIN,ROR, &
+     & DELTAF,DELMASSL,FMASS,HELEK1,DEL2NN,FF1BN, &
+     & HELEK2,TPCC,PP,ADDF,DSUP2N,FACT,EW1N,ES2N,ES1N,FNEW, &
+     & C1,SUP1N,SUP2N,QPN,TPN,TPC,SUP1,SUP2,DEL1N,DEL2N,AL1,AL2, &
+     & TEMP1,TEMP2,TEMP3,A1,B1,A2,B2 
+!
+
+!********************************************************************
+
+! NEW MEYERS IN JERNUCL01 SUBROUTINE 
+
+
+
+!********************************************************************
+
+
+
+      REAL PSI1(NKR),X1(NKR),DROPCONCN(NKR) &
+     &     ,PSI2(NKR,ICEMAX),X2(NKR,ICEMAX)
+      
+
+      DATA A1,B1,A2,B2/-0.639,0.1296,-2.8,0.262/
+      DATA TEMP1,TEMP2,TEMP3/-5.,-2.,-20./
+      DATA AL1/2500./,AL2/2834./
+      SUP1=DSUP1
+      SUP2=DSUP2
+
+
+      TT=DTT
+      QQ=DQQ
+! DROPLETS NUCLEATION (BEGIN)
+
+        TPN=TT
+        QPN=QQ
+
+        DEL1N=100.*SUP1
+        TPC=TT-273.15
+
+        IF(DEL1N.GT.0.AND.TPC.GT.-30.) THEN
+         CALL WATER_NUCL (PSI1,FCCNR,X1,TT,SUP1  &
+     &        ,COL,RCCN,DROPRADII,NKR,ICEMAX)
+        ENDIF
+! DROPLETS NUCLEATION (END)
+! drop nucleation                                               (end)
+! nucleation of crystals                                      (begin)
+
+       IF (ICEPROCS.EQ.1)THEN
+        DEL2N=100.*SUP2
+        IF(TPC.LT.0..AND.TPC.GE.-35..AND.DEL2N.GT.0.) THEN
+
+              CALL ICE_NUCL (PSI2,X2,TT,ROR,SUP2,SUP2_OLD &
+     &                      ,C1_MEY,C2_MEY,COL,DSUPICEXZ &
+     &                      ,NKR,ICEMAX)
+        ENDIF
+       ENDIF
+! nucleation of crystals                                        (end)
+! new change in drop nucleation                               (begin)
+! no sink of water vapour by nucleation
+      RETURN
+      END SUBROUTINE JERNUCL01
+
+! SUBROUTINE JERNUCL01
+!======================================================================      
+      SUBROUTINE WATER_NUCL (PSI1,FCCNR,X1,TT,SUP1 &
+     &,COL,RCCN,DROPRADII,NKR,ICEMAX)
+      IMPLICIT NONE
+      INTEGER NDROPMAX,KR,ICEMAX,NKR
+      REAL PSI1(NKR),FCCNR(NKR),X1(NKR)
+      REAL DROPCONCN(NKR)
+      REAL RCCN(NKR),DROPRADII(NKR)
+      REAL TT,SUP1,DX,COL
+
+
+      CALL NUCLEATION (SUP1,TT,FCCNR,DROPCONCN  &
+     &,NDROPMAX,COL,RCCN,DROPRADII,NKR,ICEMAX)
+
+! NEW WATER SIZE DISTRIBUTION FUNCTION (BEGIN)
+        DO KR=1,NDROPMAX
+           DX=3.*COL*X1(KR)
+! new changes 25.06.01                                        (begin)
+           PSI1(KR)=PSI1(KR)+DROPCONCN(KR)/DX
+! new changes 25.06.01                                          (end)
+        ENDDO
+
+      RETURN
+      END SUBROUTINE WATER_NUCL
+      SUBROUTINE ICE_NUCL (PSI2,X2,TT,ROR,SUP2,SUP2_OLD &
+     &                      ,C1_MEY,C2_MEY,COL,DSUPICEXZ &
+     &                      ,NKR,ICEMAX)
+        IMPLICIT NONE
+        INTEGER ITYPE,KR,ICE,NRGI,ICEMAX,NKR
+        REAL DEL2N,SUP2,C1,C2,C1_MEY,C2_MEY,TPC,TT,ROR
+        REAL DX,COL,BMASS,BFMASS,FMASS
+        REAL HELEK1,HELEK2,TPCC,DEL2NN,FF1BN,DSUPICEXZ
+        REAL FACT,DSUP2N,SUP2_OLD,DELTACD,DELTAF,ADDF,FNEW
+        REAL X2(NKR,ICEMAX),PSI2(NKR,ICEMAX)
+
+        REAL A1,B1,A2,B2
+        DATA A1,B1,A2,B2/-0.639,0.1296,-2.8,0.262/
+        REAL TEMP1,TEMP2,TEMP3
+        DATA TEMP1,TEMP2,TEMP3/-5.,-2.,-20./
+
+        C1=C1_MEY
+        C2=C2_MEY
+! TYPE OF ICE WITH NUCLEATION (BEGIN)
+
+        TPC=TT-273.15
+        ITYPE=0
+
+        IF((TPC.GT.-4.0).OR.(TPC.LE.-8.1.AND.TPC.GT.-12.7).OR.&
+     &  (TPC.LE.-17.8.AND.TPC.GT.-22.4)) THEN
+          ITYPE=2
+        ELSE
+          IF((TPC.LE.-4.0.AND.TPC.GT.-8.1).OR.(TPC.LE.-22.4)) THEN
+            ITYPE=1
+          ELSE
+            ITYPE=3
+          ENDIF
+        ENDIF
+
+
+
+! NEW CRYSTAL SIZE DISTRIBUTION FUNCTION                      (BEGIN)
+
+        ICE=ITYPE
+
+        NRGI=2
+        IF(TPC.LT.TEMP1) THEN
+          DEL2N=100.*SUP2
+          DEL2NN=DEL2N
+          IF(DEL2N.GT.50.0) DEL2NN=50.
+          HELEK1=C1*EXP(A1+B1*DEL2NN)
+        ELSE
+          HELEK1=0.
+        ENDIF
+
+        IF(TPC.LT.TEMP2) THEN
+          TPCC=TPC
+          IF(TPCC.LT.TEMP3) TPCC=TEMP3
+          HELEK2=C2*EXP(A2-B2*TPCC)
+        ELSE
+          HELEK2=0.
+        ENDIF
+
+        FF1BN=HELEK1+HELEK2
+
+        FACT=1.
+        DSUP2N=(SUP2-SUP2_OLD+DSUPICEXZ)*100.
+
+        SUP2_OLD=SUP2
+
+        IF(DSUP2N.GT.50.) DSUP2N=50.
+
+        DELTACD=FF1BN*B1*DSUP2N
+
+        IF(DELTACD.GE.FF1BN) DELTACD=FF1BN
+
+        IF(DELTACD.GT.0.) THEN
+          DELTAF=DELTACD*FACT
+          DO KR=1,NRGI-1
+             DX=3.*X2(KR,ICE)*COL
+             ADDF=DELTAF/DX
+             PSI2(KR,ICE)=PSI2(KR,ICE)+ADDF
+          ENDDO
+        ENDIF
+! NEW CRYSTAL SIZE DISTRIBUTION FUNCTION                        (END)
+       RETURN
+       END SUBROUTINE ICE_NUCL
+
+
+
+
+
+      SUBROUTINE NUCLEATION (SUP1,TT,FCCNR,DROPCONCN  &
+     &,NDROPMAX,COL,RCCN,DROPRADII,NKR,ICEMAX)
+! DROPCONCN(KR), 1/cm^3 - drop bin concentrations, KR=1,...,NKR
+
+! determination of new size spectra due to drop nucleation
+
+      IMPLICIT NONE
+      INTEGER NDROPMAX,IDROP,ICCN,INEXT,ISMALL,KR,NCRITI
+      INTEGER ICEMAX,IMIN,IMAX,NKR,I,II,I0,I1
+      REAL &
+     &  SUP1,TT,RACTMAX,XKOE,R03,SUPCRITI,AKOE23,RCRITI,BKOE, &
+     &  AKOE,CONCCCNIN,DEG01,ALN_IP
+      REAL CCNCONC(NKR)
+      REAL CCNCONC_BFNUCL
+
+
+      REAL COL
+      REAL RCCN(NKR),DROPRADII(NKR),FCCNR(NKR)
+      REAL RACT(NKR),DROPCONC(NKR),DROPCONCN(NKR)
+      REAL DLN1,DLN2,FOLD_IP
+
+
+
+        DEG01=1./3.
+
+
+! calculation initial value of NDROPMAX - maximal number of drop bin
+! which is activated
+
+! initial value of NDROPMAX
+
+        NDROPMAX=0
+
+        DO KR=1,NKR
+! initialization of bin radii of activated drops
+           RACT(KR)=0.
+! initialization of aerosol(CCN) bin concentrations
+           CCNCONC(KR)=0.
+! initialization of drop bin concentrations
+           DROPCONCN(KR)=0.
+        ENDDO
+
+
+! CCNCONC_BFNUCL - concentration of aerosol particles before
+!                  nucleation
+
+        CCNCONC_BFNUCL=0.
+        DO I=1,NKR
+           CCNCONC_BFNUCL=CCNCONC_BFNUCL+FCCNR(I)
+        ENDDO
+
+        CCNCONC_BFNUCL=CCNCONC_BFNUCL*COL
+
+        IF(CCNCONC_BFNUCL.EQ.0.) THEN
+           RETURN    
+        ELSE
+           CALL BOUNDARY(IMIN,IMAX,FCCNR,NKR)
+           CALL CRITICAL (AKOE,BKOE,TT,RCRITI,SUP1,DEG01)
+           IF(RCRITI.GE.RCCN(IMAX))  RETURN
+        END IF
+
+! calculation of CCNCONC(I) - aerosol(CCN) bin concentrations;
+!                             I=IMIN,...,IMAX
+! determination of NCRITI - number bin in which is located RCRITI
+        IF (IMIN.EQ.1)THEN
+         CALL CCNIMIN(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
+     &       FCCNR,NKR)
+         CALL CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
+     &       FCCNR,NKR)
+        ELSE
+         CALL CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
+     &       FCCNR,NKR)
+        END IF
+
+
+! calculation CCNCONC_AFNUCL - ccn concentration after nucleation
+
+!       CCNCONC_AFNUCL=0.
+
+!       DO I=IMIN,IMAX
+!          CCNCONC_AFNUCL=CCNCONC_AFNUCL+FCCNR(I)
+!       ENDDO
+
+!       CCNCONC_AFNUCL=CCNCONC_AFNUCL*COL
+
+! calculation DEL_CCNCONC
+
+!       DEL_CCNCONC=CCNCONC_BFNUCL-CCNCONC_AFNUCL
+        CALL ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT,RACTMAX,NKR)
+
+
+
+        CALL DROPMAX(DROPRADII,RACTMAX,NDROPMAX,NKR)
+! put nucleated droplets into the drop bin according to radius
+! change in drop concentration due to activation DROPCONCN(IDROP)
+        ISMALL=NCRITI
+
+        INEXT=ISMALL
+!       ISMALL=1
+
+!       INEXT=ISMALL
+
+        DO IDROP=1,NDROPMAX
+           DROPCONCN(IDROP)=0.
+           DO I=ISMALL,IMAX
+              IF(RACT(I).LE.DROPRADII(IDROP)) THEN
+                DROPCONCN(IDROP)=DROPCONCN(IDROP)+CCNCONC(I)
+                INEXT=I+1
+              ENDIF
+           ENDDO
+           ISMALL=INEXT
+        ENDDO
+
+!999    CONTINUE
+
+
+        RETURN
+        END SUBROUTINE NUCLEATION
+
+
+
+        SUBROUTINE BOUNDARY(IMIN,IMAX,FCCNR,NKR)
+! IMIN - left CCN spectrum boundary
+        IMPLICIT NONE
+        INTEGER I,IMIN,IMAX,NKR
+        REAL FCCNR(NKR)
+
+        IMIN=0
+
+        DO I=1,NKR
+           IF(FCCNR(I).NE.0.) THEN
+             IMIN=I
+             GOTO 40
+           ENDIF
+        ENDDO
+
+ 40     CONTINUE
+
+! IMAX - right CCN spectrum boundary
+
+        IMAX=0
+
+        DO I=NKR,1,-1
+           IF(FCCNR(I).NE.0.) THEN
+             IMAX=I
+             GOTO 41
+           ENDIF
+        ENDDO
+
+ 41     CONTINUE
+        RETURN
+        END  SUBROUTINE BOUNDARY
+
+        SUBROUTINE CRITICAL (AKOE,BKOE,TT,RCRITI,SUP1,DEG01)
+! AKOE & BKOE - constants in Koehler equation
+        IMPLICIT NONE
+        REAL AKOE,BKOE,TT,RCRITI,SUP1,DEG01
+        REAL RO_SOLUTE
+        PARAMETER (RO_SOLUTE=2.16)
+
+         
+
+        AKOE=3.3E-05/TT
+        BKOE=2.*4.3/(22.9+35.5)
+! new change 21.07.02                                         (begin)
+        BKOE=BKOE*(4./3.)*3.141593*RO_SOLUTE                  
+! new change 21.07.02                                           (end)
+        
+
+! table of critical aerosol radii
+
+!	GOTO 992
+
+! SUP1_TEST(I), %
+!       SUP1_TEST(1)=0.01
+!       DO I=1,99
+!          SUP1_TEST(I+1)=SUP1_TEST(I)+0.01
+!          SUP1_I=SUP1_TEST(I)*0.01
+!          RCRITI_TEST(I)=(AKOE/3.)*(4./BKOE/SUP1_I/SUP1_I)**DEG01
+!       ENDDO
+
+! RCRITI, cm - critical radius of "dry" aerosol
+
+        RCRITI=(AKOE/3.)*(4./BKOE/SUP1/SUP1)**DEG01
+        RETURN
+        END  SUBROUTINE CRITICAL
+            
+        SUBROUTINE CCNIMIN(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
+     &       FCCNR,NKR)
+! FOR    IMIN=1
+        IMPLICIT NONE
+        INTEGER IMIN,II,IMAX,NCRITI,NKR
+        REAL RCRITI,COL
+        REAL RCCN(NKR),FCCNR(NKR),CCNCONC(NKR)
+        REAL RCCN_MIN
+        REAL DLN1,DLN2,FOLD_IP
+! rccn_min - minimum aerosol(ccn) radius
+        RCCN_MIN=RCCN(1)/10000.
+! calculation of ccnconc(ii)=fccnr(ii)*col - aerosol(ccn) bin
+!                                            concentrations,
+!                                            ii=imin,...,imax
+! determination of ncriti   - number bin in which is located rcriti
+! calculation of ccnconc(ncriti)=fccnr(ncriti)*dln1/(dln1+dln2),
+! where,    
+! dln1=Ln(rcriti)-Ln(rccn_min)
+! dln2=Ln(rccn(1)-Ln(rcriti)
+! calculation of new value of fccnr(ncriti)
+
+!       IF(IMIN.EQ.1) THEN
+          IF(RCRITI.LE.RCCN_MIN) THEN
+            NCRITI=1
+            DO II=NCRITI+1,IMAX
+               CCNCONC(II)=COL*FCCNR(II)     
+               FCCNR(II)=0.                  
+            ENDDO
+            GOTO 42
+          ENDIF
+          IF(RCRITI.GT.RCCN_MIN.AND.RCRITI.LT.RCCN(IMIN)) THEN
+            NCRITI=1
+            DO II=NCRITI+1,IMAX
+               CCNCONC(II)=COL*FCCNR(II)
+               FCCNR(II)=0.
+            ENDDO
+            DLN1=ALOG(RCRITI)-ALOG(RCCN_MIN)
+            DLN2=ALOG(RCCN(1))-ALOG(RCRITI)
+            CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
+            FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/(DLN1+DLN2)
+            GOTO 42
+! in case RCRITI.GT.RCCN_MIN.AND.RCRITI.LT.RCCN(IMIN)
+          ENDIF
+! in case IMIN.EQ.1
+42       CONTINUE
+     
+         RETURN
+         END SUBROUTINE CCNIMIN
+        SUBROUTINE CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
+     &       FCCNR,NKR)
+        IMPLICIT NONE
+         INTEGER I,IMIN,IMAX,NKR,II,NCRITI
+         REAL COL
+         REAL RCRITI,RCCN(NKR),CCNCONC(NKR),FCCNR(NKR)
+         REAL DLN1,DLN2,FOLD_IP
+        IF(IMIN.GT.1) THEN
+          IF(RCRITI.LE.RCCN(IMIN-1)) THEN
+            NCRITI=IMIN
+            DO II=NCRITI,IMAX
+               CCNCONC(II)=COL*FCCNR(II)
+               FCCNR(II)=0.
+            ENDDO
+            GOTO 42
+          ENDIF
+          IF(RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)) &
+     &    THEN
+! this line eliminates bug you found (when IMIN=IMAX)
+            NCRITI=IMIN
+            
+            DO II=NCRITI+1,IMAX
+               CCNCONC(II)=COL*FCCNR(II)
+               FCCNR(II)=0.
+            ENDDO
+            DLN1=ALOG(RCRITI)-ALOG(RCCN(IMIN-1))
+            DLN2=COL-DLN1
+            CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
+            FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/COL
+            GOTO 42
+! in case RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)
+          ENDIF
+! in case IMIN.GT.1
+        ENDIF
+        
+! END of part of interest. so in case
+!RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)
+!we go to 42 and avoid the next loop
+
+      
+
+         DO I=IMIN,IMAX-1
+           IF(RCRITI.EQ.RCCN(I)) THEN
+             NCRITI=I+1
+             DO II=I+1,IMAX
+                CCNCONC(II)=COL*FCCNR(II)
+                FCCNR(II)=0.
+             ENDDO
+             GOTO 42
+           ENDIF
+           IF(RCRITI.GT.RCCN(I).AND.RCRITI.LT.RCCN(I+1)) THEN
+             NCRITI=I+1
+             IF(I.NE.IMAX-1) THEN
+               DO II=NCRITI+1,IMAX
+                  CCNCONC(II)=COL*FCCNR(II)
+                  FCCNR(II)=0.
+               ENDDO
+             ENDIF
+             DLN1=ALOG(RCRITI)-ALOG(RCCN(I))
+             DLN2=COL-DLN1
+             CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
+             FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/COL
+             GOTO 42
+! in case RCRITI.GT.RCCN(I).AND.RCRITI.LT.RCCN(I+1)
+           END IF
+      
+
+         ENDDO
+! cycle by I, I=IMIN,...,IMAX-1
+
+  42    CONTINUE
+        RETURN
+        END  SUBROUTINE CCNLOOP
+       SUBROUTINE ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT, RACTMAX,NKR)
+       IMPLICIT NONE
+
+       INTEGER IMIN,IMAX,NKR
+       INTEGER I,I0,I1
+       REAL RCCN(NKR)
+        REAL  R03,SUPCRITI,RACT(NKR),XKOE
+        REAL AKOE,BKOE,AKOE23,RACTMAX
+! Spectrum of activated drops                                 (begin) 
+        DO I=IMIN,IMAX
+
+! critical water supersaturations appropriating CCN radii
+
+           XKOE=(4./27.)*(AKOE**3/BKOE)
+           AKOE23=AKOE*2./3.
+           R03=RCCN(I)**3
+           SUPCRITI=SQRT(XKOE/R03)
+
+! RACT(I) - radii of activated drops, I=IMIN,...,IMAX
+
+           IF(RCCN(I).LE.(0.3E-5)) &
+     &     RACT(I)=AKOE23/SUPCRITI
+           IF(RCCN(I).GT.(0.3E-5))&
+     &     RACT(I)=5.*RCCN(I)
+        ENDDO
+! cycle by I
+
+! calculation of I0
+
+        I0=IMIN
+
+        DO I=IMIN,IMAX-1
+           IF(RACT(I+1).LT.RACT(I)) THEN
+             I0=I+1
+             GOTO 45
+           ENDIF
+        ENDDO
+
+ 45     CONTINUE
+! new changes 9.04.02                                         (begin)
+        I1=I0-1
+! new changes 9.04.02                                           (end)
+
+        IF(I0.EQ.IMIN) GOTO 47
+
+! new changes 9.04.02                                         (begin)
+
+        IF(I0.EQ.IMAX) THEN
+          RACT(IMAX)=RACT(IMAX-1)
+          GOTO 47
+        ENDIF
+
+        IF(RACT(IMAX).LE.RACT(I0-1)) THEN
+          DO I=I0,IMAX
+             RACT(I)=RACT(I0-1)
+          ENDDO
+          GOTO 47
+        ENDIF
+
+! new changes 9.04.02                                           (end)
+
+
+
+! calculation of I1
+
+        DO I=I0+1,IMAX
+           IF(RACT(I).GE.RACT(I0-1)) THEN
+             I1=I
+             GOTO 46
+           ENDIF
+        ENDDO
+ 46     CONTINUE
+
+! spectrum of activated drops                                   (end)
+
+
+! line interpolation RACT(I) for I=I0,...,I1
+
+        DO I=I0,I1
+           RACT(I)=RACT(I0-1)+(I-I0+1)*(RACT(I1)-RACT(I0-1)) &
+     &                       /(I1-I0+1)
+        ENDDO
+
+
+  47    CONTINUE
+
+
+
+        RACTMAX=0.
+
+        DO I=IMIN,IMAX
+           RACTMAX=AMAX1(RACTMAX,RACT(I))
+	ENDDO
+        RETURN
+
+        END SUBROUTINE ACTIVATE
+        SUBROUTINE DROPMAX(DROPRADII,RACTMAX,NDROPMAX,NKR)
+        IMPLICIT NONE
+        INTEGER IDROP,NKR,NDROPMAX
+        REAL RACTMAX,DROPRADII(NKR)
+! calculation of NDROPMAX - maximal number of drop bin which
+! is activated
+
+        NDROPMAX=1
+
+        DO IDROP=1,NKR
+           IF(RACTMAX.LE.DROPRADII(IDROP)) THEN
+             NDROPMAX=IDROP
+             GOTO 44
+           ENDIF
+        ENDDO
+ 44     CONTINUE
+        RETURN
+        END  SUBROUTINE DROPMAX
+
+
+        SUBROUTINE ONECOND1 &
+     & (TT,QQ,PP,ROR &
+     & ,VR1,PSINGLE &
+     & ,DEL1N,DEL2N,DIV1,DIV2 &
+     & ,FF1,PSI1,R1,RLEC,RO1BL &
+     & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     & ,C1_MEY,C2_MEY &
+     & ,COL,DTCOND,ICEMAX,NKR)
+
+       IMPLICIT NONE
+
+
+      INTEGER NKR,ICEMAX
+      REAL    COL,VR1(NKR),PSINGLE &
+     &       ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &       ,DTCOND
+
+      REAL C1_MEY,C2_MEY
+      INTEGER I_ABERGERON,I_BERGERON, &
+     & KR,ICE,ITIME,KCOND,NR,NRM, &
+     & KLIMIT, &
+     & KM,KLIMITL  
+      REAL AL1,AL2,D,GAM,POD, &
+     & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
+     & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
+     & TPC1, TPC2, TPC3, TPC4, TPC5, &
+     & EPSDEL, EPSDEL2,DT0L, DT0I,&
+     & ROR, &
+     & CWHUCM,B6,B8L,B8I, &
+     & DEL1,DEL2,DEL1S,DEL2S, &
+     & TIMENEW,TIMEREV,SFN11,SFN12, &
+     & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,RW,RI,QW,PW, &
+     & PI,QI,DEL1N0,DEL2N0,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
+     & DEL_R1,DT0L0,DT0I0, &
+     & DTNEWL0, &
+     & DTNEWL2 
+       REAL DT_WATER_COND,DT_WATER_EVAP
+
+       INTEGER K
+! NEW ALGORITHM OF CONDENSATION (12.01.00)
+
+      REAL  FF1_OLD(NKR),SUPINTW(NKR)
+      DOUBLE PRECISION DSUPINTW(NKR),DD1N,DB11_MY,DAL1,DAL2
+      DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
+     &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
+     &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
+     &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
+     &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
+     &                  ,ES1N,ES2N,EW1N,ARGEXP &
+     &                  ,TT,QQ,PP &
+     &                  ,DEL1N,DEL2N,DIV1,DIV2 &
+     &                  ,OPER2,OPER3,AR1,AR2
+
+       DOUBLE PRECISION DELMASSL1
+
+! DROPLETS 
+                                                                       
+        REAL R1(NKR) &
+     &           ,RLEC(NKR),RO1BL(NKR) &
+     &           ,FI1(NKR),FF1(NKR),PSI1(NKR) &
+     &           ,B11_MY(NKR),B12_MY(NKR)
+
+! WORK ARRAYS 
+
+! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION
+
+       
+	REAL DTIMEO(NKR),DTIMEL(NKR) &
+     &           ,TIMESTEPD(NKR)
+
+! NEW ALGORITHM (NO TYPE OF ICE)
+
+
+
+	OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
+	OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
+
+        DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
+     &      ,GAM /1.E-4/, POD /10./ 
+           
+	DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
+     &      /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/
+
+	DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
+     &      /2.53,5.42,3.41E1,6.13/
+
+	DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
+     &      /-4.0,-8.1,-12.7,-17.8,-22.4/ 
+
+
+        DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/  
+    
+	DATA DT0L, DT0I /1.E20,1.E20/
+
+! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
+
+
+! CONTROL OF TIMESTEP ITERATIONS IN MIXED PHASE: EVAPORATION
+        
+        I_ABERGERON=0
+        I_BERGERON=0
+        COL3=3.0*COL
+        ITIME=0
+        KCOND=0
+        DT_WATER_COND=0.4
+        DT_WATER_EVAP=0.4
+	ITIME=0
+	KCOND=0
+        DT0LREF=0.2
+        DTLREF=0.4
+
+	NR=NKR
+	NRM=NKR-1
+	DT=DTCOND
+	DTT=DTCOND
+	XRAD=0.
+
+!     BARRY
+	CWHUCM=0.
+	XRAD=0.
+	B6=CWHUCM*GAM-XRAD
+	B8L=1./ROR
+	B8I=1./ROR
+        RORI=1./ROR
+
+! INITIALIZATION OF SOME ARRAYS
+!       print*, 'got to here 0'
+
+!       BARRY: REMOVE RS2 LOOP
+        DO KR=1,NKR
+           FF1_OLD(KR)=FF1(KR)
+           SUPINTW(KR)=0.
+           DSUPINTW(KR)=0.
+        ENDDO
+! OLD TREATMENT OF "T" & "Q" 
+!DEL12RD=DEL12R**DEL_BBR
+! BARRY
+!       EW1PN=AA1_MY*(100.+DEL1IN*100.)*DEL12RD/100.
+! 	QQIN=OPER4(EW1PN,PP)
+        TPN=TT
+        QPN=QQ
+        DO 19 KR=1,NKR
+              FI1(KR)=FF1(KR)
+19     CONTINUE
+! WARM OR NO ICE (BEGIN)
+! ONLY WATER (CONDENSATION OR EVAPORATION) (BEGIN)
+              TIMENEW=0.
+              ITIME=0
+! NEW CHANGES 10.01.01 (BEGIN)
+              TOLD=TPN
+              QOLD=QPN
+! NEW CHANGES 10.01.01 (END)
+   56         ITIME=ITIME+1
+              TIMEREV=DT-TIMENEW
+              TIMEREV=DT-TIMENEW
+              DEL1=DEL1N
+              DEL2=DEL2N
+              DEL1S=DEL1N
+              DEL2S=DEL2N
+              TPS=TPN
+              QPS=QPN
+! NO QPS IN JERRATE
+              CALL JERRATE(R1,TPS,PP,ROR,VR1,PSINGLE &
+     &                    ,RLEC,RO1BL,B11_MY,B12_MY,1,1,ICEMAX,NKR)
+
+! INTEGRALS IN DELTA EQUATION (ONLY WATER)
+
+! CONTROL OF DROP SPECRUM IN SUBROUTINE ONECOND
+
+
+! CALL JERTIMESC WATER - 1 (ONLY WATER)
+
+              CALL JERTIMESC(FI1,R1,SFN11,SFN12 &
+     &                      ,B11_MY,B12_MY,RLEC,B8L,1,COL,NKR)        
+
+
+	      SFNL=SFN11+SFN12
+	      SFNI=0.       
+
+! SOME CONSTANTS 
+	      B5L=BB1_MY/TPS/TPS
+	      B5I=BB2_MY/TPS/TPS
+              B7L=B5L*B6                                                     
+              B7I=B5I*B6
+	      DOPL=1.+DEL1S                                                     
+	      DOPI=1.+DEL2S                                                     
+              RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL                                                 
+              RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
+	      QW=B7L*DOPL
+	      PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
+              PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
+              QI=B7I*DOPI
+
+! SOLVING FOR TIMEZERO
+
+
+
+	      KCOND=10
+
+	      IF(DEL1.GT.0) KCOND=11
+
+! PROCESS'S TYPE 
+
+	      IF(KCOND.EQ.11) THEN
+! NEW TIME STEP IN CONDENSATION (ONLY WATER) (BEGIN)
+                IF (DEL1N.EQ.0)THEN
+	           DTNEWL=DT
+                ELSE
+                 DTNEWL=ABS(R1(ITIME)/(B11_MY(ITIME)*DEL1N &
+     &                               -B12_MY(ITIME)))
+	         IF(DTNEWL.GT.DT) DTNEWL=DT
+                END IF
+                IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
+                ENDIF
+                TIMESTEPD(ITIME)=DTNEWL
+
+! NEW TIME STEP (ONLY WATER: CONDENSATION)
+
+
+	        IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  & 
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+
+	        TIMESTEPD(ITIME)=DTNEWL
+
+	        TIMENEW=TIMENEW+DTNEWL
+
+	        DTT=DTNEWL
+
+! SOLVING FOR SUPERSATURATION 
+
+! CALL JERSUPSAT - 2 (NEW TIMESTEP - ONLY WATER)
+
+
+	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                        ,RW,PW,RI,PI,QW,QI &
+     &                        ,DTT,D1N,D2N,DT0L,DT0I)
+
+! END OF "NEW SUPERSATURATION"
+
+! DROPLETS 
+
+! DROPLET DISTRIBUTION FUNCTION 
+                                                         
+! CALL JERDFUN WATER - 1 (ONLY WATER: CONDENSATION)
+	          CALL JERDFUN(R1,B11_MY,B12_MY &
+     &                        ,FI1,PSI1,D1N &
+     &                        ,1,1,COL,NKR,TPN)
+
+	        IF((DEL1.GT.0.AND.DEL1N.LT.0) &
+     &         .AND.ABS(DEL1N).GT.EPSDEL) THEN
+             call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL1.GT.0.AND.DEL1N.LT.0), model stop")
+	        ENDIF
+
+! IN CASE : KCOND.EQ.11
+
+	      ELSE
+
+! EVAPORATION - ONLY WATER 
+
+! IN CASE : KCOND.NE.11
+               IF (DEL1N.EQ.0)THEN
+                DTIMEO(1)=DT
+	        DO KR=2,NKR
+	           DTIMEO(KR)=DT
+	        ENDDO
+               ELSE
+	        DTIMEO(1)=-R1(1)/(B11_MY(1)*DEL1N-B12_MY(1))
+
+	        DO KR=2,NKR
+	           KM=KR-1
+	           DTIMEO(KR)=(R1(KM)-R1(KR))/(B11_MY(KR)*DEL1N &
+     &                                       -B12_MY(KR))
+	        ENDDO
+               END IF
+
+	        KLIMIT=1
+
+	        DO KR=1,NKR
+	           IF(DTIMEO(KR).GT.TIMEREV) GOTO 55
+	           KLIMIT=KR
+	        ENDDO
+
+   55           KLIMIT=KLIMIT-1
+
+	        IF(KLIMIT.LT.1) KLIMIT=1
+
+! BARRY THIS LINE CAUSED A PROBLEM BECAUSE DTNEWL GOES FROM
+! LARGE TO SMALL
+  	        DTNEWL1=AMIN1(DTIMEO(3),TIMEREV)
+                IF(DTNEWL1.LT.DTLREF) DTNEWL1=AMIN1(DTLREF,TIMEREV)
+	        DTNEWL=DTNEWL1
+	        IF(ITIME.GE.NKR) THEN
+           call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
+	        ENDIF
+
+	        TIMESTEPD(ITIME)=DTNEWL
+
+! NEW TIME STEP (ONLY_WATER: EVAPORATION)
+
+	        IF(DTNEWL.GT.DT) DTNEWL=DT
+                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+
+	        TIMESTEPD(ITIME)=DTNEWL
+
+	        TIMENEW=TIMENEW+DTNEWL
+
+	        DTT=DTNEWL
+
+! SOLVING FOR SUPERSATURATION 
+
+
+! CALL JERSUPSAT - 3 (ONLY_WATER: EVAPORATION)
+
+	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                        ,RW,PW,RI,PI,QW,QI &
+     &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
+! END OF "NEW SUPERSATURATION"
+
+
+! DROPLETS 
+
+
+! DROPLET DISTRIBUTION FUNCTION (ONLY_WATER: EVAPORATION)
+                                                         
+! CALL JERDFUN WATER - 2 (ONLY_WATER: EVAPORATION)
+             
+ 	          CALL JERDFUN(R1,B11_MY,B12_MY &
+     &                        ,FI1,PSI1,D1N &
+     &                        ,1,1,COL,NKR,TPN)
+
+! IN CASE : ISYML.NE.0 (ENDING OF 
+! "DROPLET DISTRIBUTION FUNCTION" (ONLY WATER: EVAPORATION)
+
+!        ENDIF
+
+	        IF((DEL1.LT.0.AND.DEL1N.GT.0) &
+     &         .AND.ABS(DEL1N).GT.EPSDEL) THEN
+            call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL1.LT.0.AND.DEL1N.GT.0), model stop")
+	        ENDIF
+
+! END OF "PROCESS'S TYPE" 
+
+! IN CASE : KCOND.NE.11 (ONLY WATER: EVAPORATION)
+
+              ENDIF
+
+! IN CASES : KCOND.EQ.11 OR KCOND.NE.11 (BOTH CONDENSATION AND
+! EVAPORATION : ONLY WATER)
+
+! CONCENTRATION & MASS (ONLY WATER) 
+
+      RMASSLBB=0.
+      RMASSLAA=0.
+
+! BEFORE JERNEWF (ONLY WATER) 
+
+              DO K=1,NKR
+                 FI1_K=FI1(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLBB=RMASSLBB+FI1R1
+              ENDDO
+              RMASSLBB=RMASSLBB*COL3*RORI
+! NEW CHANGE RMASSLBB
+              IF(RMASSLBB.LE.0.) RMASSLBB=0.
+              DO K=1,NKR
+                 FI1_K=PSI1(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLAA=RMASSLAA+FI1R1
+              ENDDO
+              RMASSLAA=RMASSLAA*COL3*RORI
+              IF(RMASSLAA.LE.0.) RMASSLAA=0.
+! NEW TREATMENT OF "T" & "Q" (ONLY WATER)
+              DELMASSL1=RMASSLAA-RMASSLBB
+              QPN=QPS-DELMASSL1
+              DAL1=AL1
+              TPN=TPS+DAL1*DELMASSL1
+! SUPERSATURATION (ONLY WATER)
+              ARGEXP=-BB1_MY/TPN
+              ES1N=AA1_MY*DEXP(ARGEXP)
+              ARGEXP=-BB2_MY/TPN
+              ES2N=AA2_MY*DEXP(ARGEXP)
+              EW1N=OPER3(QPN,PP)
+              IF(ES1N.EQ.0)THEN
+               DEL1N=0.5
+               DIV1=1.5
+              ELSE
+               DIV1=EW1N/ES1N
+               DEL1N=EW1N/ES1N-1.
+              END IF
+              IF(ES2N.EQ.0)THEN
+               DEL2N=0.5
+               DIV2=1.5
+              ELSE
+               DEL2N=EW1N/ES2N-1.
+               DIV2=EW1N/ES2N
+              END IF
+              DO KR=1,NKR
+                SUPINTW(KR)=SUPINTW(KR)+B11_MY(KR)*D1N
+                DD1N=D1N
+                DB11_MY=B11_MY(KR)
+                DSUPINTW(KR)=DSUPINTW(KR)+DB11_MY*DD1N
+              ENDDO
+! REPEATE TIME STEP (ONLY WATER: CONDENSATION OR EVAPORATION) 
+	      IF(TIMENEW.LT.DT) GOTO 56
+57            CONTINUE
+              CALL JERDFUN_NEW(R1,DSUPINTW &
+     &                        ,FF1_OLD,PSI1,D1N &
+     &                        ,1,1,COL,NKR,TPN)
+              RMASSLAA=0.0
+              RMASSLBB=0.0
+! BEFORE JERNEWF
+              DO K=1,NKR
+                 FI1_K=FF1_OLD(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLBB=RMASSLBB+FI1R1
+              ENDDO
+              RMASSLBB=RMASSLBB*COL3*RORI
+! NEW CHANGE RMASSLBB
+              IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
+! AFTER  JERNEWF
+              DO K=1,NKR
+                 FI1_K=PSI1(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLAA=RMASSLAA+FI1R1
+              ENDDO
+              RMASSLAA=RMASSLAA*COL3*RORI
+! NEW CHANGE RMASSLAA
+              IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
+              IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
+! NEW TREATMENT OF "T" & "Q"
+              DELMASSL1=RMASSLAA-RMASSLBB
+! NEW CHANGES 10.01.01 (BEGIN)
+              QPN=QOLD-DELMASSL1
+              DAL1 = AL1
+              TPN=TOLD+DAL1*DELMASSL1
+! NEW CHANGES 10.01.01 (END)
+! SUPERSATURATION
+              ARGEXP=-BB1_MY/TPN
+              ES1N=AA1_MY*DEXP(ARGEXP)
+              ARGEXP=-BB2_MY/TPN
+              ES2N=AA2_MY*DEXP(ARGEXP)
+              EW1N=OPER3(QPN,PP)
+              IF(ES1N.EQ.0)THEN
+               DEL1N=0.5
+               DIV1=1.5
+   call wrf_error_fatal("fatal error in module_mp_fast_sbm (ES1N.EQ.0), model stop")
+              ELSE
+               DIV1=EW1N/ES1N
+               DEL1N=EW1N/ES1N-1.
+              END IF
+              IF(ES2N.EQ.0)THEN
+               DEL2N=0.5
+               DIV2=1.5
+   call wrf_error_fatal("fatal error in module_mp_fast_sbm (ES2N.EQ.0), model stop")
+              ELSE
+               DEL2N=EW1N/ES2N-1.
+               DIV2=EW1N/ES2N
+              END IF
+        TT=TPN
+        QQ=QPN
+	DO KR=1,NKR
+	   FF1(KR)=PSI1(KR)
+	ENDDO
+
+
+
+
+       RETURN
+!      END 
+
+  END SUBROUTINE ONECOND1
+!==================================================================
+
+
+
+!BARRY
+        SUBROUTINE JERDFUN(R2,B21_MY,B22_MY &
+     &                    ,FI2,PSI2,DEL2N &
+     &                    ,IND,ITYPE,COL,NKR,TPN)
+       IMPLICIT NONE
+
+! CRYSTALS 
+       REAL COL,DEL2N
+                                                                       
+      INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,NKR,IDROP
+       REAL &
+     &       R2(NKR,IND),R2N(NKR,IND) &
+     &      ,FI2(NKR,IND),PSI2(NKR,IND) &
+     &      ,B21_MY(NKR,IND),B22_MY(NKR,IND) &
+     &      ,DEL_R2M(NKR,IND)
+        DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
+        DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND),DDEL2N, &
+     &     DB21_MY(NKR,IND)
+       DOUBLE PRECISION CHECK,TPN
+          CHECK=0.D0
+           DO KR=1,NKR
+             CHECK=B21_MY(1,1)*B21_MY(KR,1)
+             IF (CHECK.LT.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (CHECK.LT.0), model stop") 
+           END DO
+
+	IF(IND.NE.1) THEN
+	  ITYP=ITYPE
+        ELSE
+	  ITYP=1
+	ENDIF
+
+           DDEL2N=DEL2N
+	DO KR=1,NKR
+	   PSI2R(KR)=FI2(KR,ITYP)
+	   FI2R(KR)=FI2(KR,ITYP)
+           DR2(KR,ITYP)=R2(KR,ITYP)
+           DB21_MY(KR,ITYP)=B21_MY(KR,ITYP)
+	ENDDO
+!
+!Q2=0.
+	NR=NKR
+	NRM=NKR-1
+
+! NEW DISTRIBUTION FUNCTION 
+
+	  DO 8 ICE=1,IND
+	       IF(ITYP.EQ.ICE) THEN
+	          DO KR=1,NKR
+                    DR2N(KR,ICE)=DR2(KR,ICE)+DDEL2N*DB21_MY(KR,ICE)
+                    R2N(KR,ICE)=DR2N(KR,ICE)
+!                   IF (D1N.LT.0)THEN
+!	             if (DR2N(KR,ICE).EQ.DR2(KR,ICE))THEN
+!		        KK=NKR-KR+1
+!	       		DR2N(KR,ICE)=R2N(KR,ICE)-2.E-15/2**KK
+!                    end if
+!                   END IF
+
+	          ENDDO
+	        ENDIF
+    8	  CONTINUE
+! CRYSTAL DISTRIBUTION FUNCTION 
+                                                          
+	  DO ICE=1,IND
+
+! ICE_TYPE 
+	     IF(ITYP.EQ.ICE) THEN
+!       Q2=20.*ITYPE+ICE
+               DO 5 KR=1,NKR
+	            R2R(KR)=DR2(KR,ICE)
+	            R2NR(KR)=DR2N(KR,ICE)               
+    5         continue
+! Andrei's new change 1.12.09                                 (start)
+!            IDROP=1
+!            IDROP=0
+             IF(IND.EQ.1.AND.ITYPE.EQ.1) IDROP=1
+! Andrei's new change 1.12.09                                   (end)
+             CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR &
+! Andrei's new change 1.12.09                                 (start)
+     &                   ,IDROP,TPN)
+! Andrei's new change 1.12.09                                   (end)
+
+
+
+!              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
+	       DO KR=1,NKR                              
+	          PSI2(KR,ICE)=PSI2R(KR)
+	       ENDDO
+
+
+! END OF "ICE_TYPE" 
+
+	     ENDIF
+
+! END OF "CRYSTAL DISTRIBUTION FUNCTION" 
+                                                          
+	  ENDDO
+
+! END OF "NEW DISTRIBUTION FUNCTION"
+
+
+	RETURN
+	END SUBROUTINE JERDFUN
+!===================================================================
+        SUBROUTINE JERDFUN_NEW(R2,B21_MY &
+     &                    ,FI2,PSI2,DEL2N &
+     &                    ,IND,ITYPE,COL,NKR,TPN)
+       IMPLICIT NONE
+
+! CRYSTALS 
+       REAL COL,DEL2N
+                                                                       
+      INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,KK,NKR,IDROP
+       REAL &
+     &       R2(NKR,IND),R2N(NKR,IND) &
+     &      ,FI2(NKR,IND),PSI2(NKR,IND)
+       DOUBLE PRECISION TPN
+       DOUBLE PRECISION  B21_MY(NKR,IND)
+        DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
+        DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND),DDEL2N, &
+     &     DB21_MY(NKR,IND)
+	IF(IND.NE.1) THEN
+	  ITYP=ITYPE
+        ELSE
+	  ITYP=1
+	ENDIF
+
+           DDEL2N=DEL2N
+	DO KR=1,NKR
+	   PSI2R(KR)=FI2(KR,ITYP)
+	   FI2R(KR)=FI2(KR,ITYP)
+           DR2(KR,ITYP)=R2(KR,ITYP)
+	ENDDO
+!
+!Q2=0.
+	NR=NKR
+	NRM=NKR-1
+
+! NEW DISTRIBUTION FUNCTION 
+
+! CRYSTAL DISTRIBUTION FUNCTION 
+	  DO ICE=1,IND
+! ICE_TYPE 
+	     IF(ITYP.EQ.ICE) THEN
+               DO 5 KR=1,NKR
+	            R2R(KR)=DR2(KR,ICE)
+	            R2NR(KR)=DR2(KR,ICE)+B21_MY(KR,ICE)
+                    R2N(KR,ICE)=R2NR(KR)
+!                   IF (D1N.LT.0)THEN
+!	            	 if (R2NR(KR).EQ.R2R(KR))THEN
+!	       		 KK=NKR-KR+1
+!		        R2NR(KR)=R2R(KR)-2.E-15/2**KK
+!		      end if
+!	            END IF
+    5         continue
+! Andrei's new change 1.12.09                                 (start)
+             IDROP=1
+!            IDROP=0
+             CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR &
+     &                   ,IDROP,TPN)
+! Andrei's new change 1.12.09                                   (end)
+
+
+!              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
+	       DO KR=1,NKR                              
+	          PSI2(KR,ICE)=PSI2R(KR)
+	       ENDDO
+
+! END OF "ICE_TYPE" 
+
+	     ENDIF
+
+! END OF "CRYSTAL DISTRIBUTION FUNCTION" 
+                                                          
+	  ENDDO
+
+! END OF "NEW DISTRIBUTION FUNCTION"
+
+
+	RETURN
+	END SUBROUTINE JERDFUN_NEW
+! SUBROUTINE JERDFUN_NEW (NEW ALGORITHM OF CONDENSATION, 12.01.00)
+
+! new change 30.01.06                                         (start)
+!       SUBROUTINE JERNEWF(NRX,NRM,RR,FI,PSI,RN,COL,NKR)
+
+        SUBROUTINE JERNEWF &
+       (NRX,NRM,RR,FI_OLD,PSI,RN,COL,NKR, &
+! Andrei's new change 1.12.09                                 (start)           
+        IDROP,TPN)
+! Andrei's new change 1.12.09                                   (end)	
+ 
+        IMPLICIT NONE
+        INTEGER  & 
+        I,K,KM,NRXP,IM,IP,IFIN,IIN,ISYM,NKR
+	
+! Andrei's new change 1.12.09                                 (start)
+
+        INTEGER &
+	KRDROP_REMAP_MIN,KRDROP_REMAP_MAX,IDROP,KMAX
+	
+        DOUBLE PRECISION &
+	COEFF_REMAP,TPN
+	
+        DOUBLE PRECISION & 
+        CDROP(NRX),DELTA_CDROP(NRX)
+		
+! Andrei's new change 1.12.09                                   (end)                      	
+
+ 
+        REAL & 
+        COL
+
+        DOUBLE PRECISION &
+	AOLDCON,ANEWCON,AOLDMASS,ANEWMASS
+
+        DOUBLE PRECISION &
+        RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, &
+        GN1,GN1P,GN2,GN3,GMAT2
+
+        DOUBLE PRECISION &
+        DRP,FNEW,FIK,PSINEW,DRM,GMAT,R1,R2,R3,DMASS,CONCL,RRI,RNK
+
+        INTEGER NRX,NRM
+
+        DOUBLE PRECISION & 
+        RR(NRX),FI(NRX),PSI(NRX),RN(NRX) &
+       ,RRS(NKR+1),RNS(NKR+1),PSIN(NKR+1),FIN(NKR+1)
+
+        DOUBLE PRECISION & 
+        FI_OLD(NRX)
+! ANDREI                                                      (start) 
+! new change 7.02.06                                          (start)
+        DOUBLE PRECISION & 
+        PSI_IM,PSI_I,PSI_IP
+! ANDREI                                                        (end) 
+! new change 7.02.06                                            (end)
+
+! Andrei's new change 1.12.09                                 (start)           
+
+       IF(TPN.LT.273.15-7.0D0) IDROP=0
+! LEAVE REMAPPING ON
+!      IDROP=0
+ 
+! VALUES FOR SOME REMAPING VARIABLES
+
+        KRDROP_REMAP_MIN=8
+	KRDROP_REMAP_MAX=13 
+	
+        COEFF_REMAP=1.0D0/150.0D0 
+	       	
+! Andrei's new change 1.12.09                                   (end)                      
+	
+! INITIAL VALUES FOR SOME VARIABLES
+
+	NRXP=NRX+1
+
+	DO K=1,NRX
+	   FI(K)=FI_OLD(K)
+        ENDDO
+ 
+	DO K=1,NRX
+	   PSI(K)=0.0D0
+        ENDDO
+! ANDREI                                                      (start) 
+! new change 7.02.06                                          (start)
+
+	IF(RN(NRX).NE.RR(NRX)) THEN
+
+! Kovetz-Olund method                                         (start)
+
+! ANDREI                                                        (end) 
+! new change 7.02.06                                            (end)
+
+	  ISYM=1
+
+	  IF(RN(1).LT.RR(1)) ISYM=-1
+
+! CALCULATION OF DISTRIBUTION FUNCTION 
+
+	  IF(ISYM.GT.0) THEN
+	
+! CONDENSATION 
+
+	    RNS(NRXP)=1024.0D0*RR(NRX)
+	    RRS(NRXP)=1024.0D0*RR(NRX)
+
+  	    PSIN(NRXP)=0.0D0
+	    FIN(NRXP)=0.0D0
+
+	    DO K=1,NRX
+	       RNS(K)=RN(K)
+	       RRS(K)=RR(K)
+	       PSIN(K)=0.0D0
+! FIN(K) - initial(before condensation) concentration of hydrometeors
+	       FIN(K)=3.0D0*FI(K)*RR(K)*COL
+	    ENDDO
+
+! NUMBER OF NEW RADII POSITION IN REGULAR GRID 
+
+! RNK - new first bin mass(after condensation)
+
+	    RNK=RNS(1)
+
+	    DO I=1,NRX
+	       RRI=RRS(I)
+	       IF(RRI.GT.RNK) GOTO 3
+            ENDDO
+
+    3	    IIN=I-1
+
+	    IFIN=NRX
+
+	    CONCL=0.0D0
+            DMASS=0.0D0
+                        
+            DO 6 I=IIN,IFIN
+
+                 IP=I+1
+                                                                                
+                 IM=MAX(1,I-1)
+
+	         R1=RRS(IM)
+	         R2=RRS(I)
+	         R3=RRS(IP)
+
+	         DRM=R2-R1
+	         DRP=R3-R2
+
+	         FNEW=0.0D0
+
+	         DO 7 K=1,I
+                 
+	              FIK=FIN(K)
+
+	              IF(FIK.NE.0.0D0) THEN
+
+	                KM=K-1
+
+! RNK - new bin mass(after condensation)
+
+	                RNK=RNS(K)
+
+	                IF(RNK.NE.R2) THEN
+	                  GMAT=0.0D0
+	                  IF(RNK.GT.R1.AND.RNK.LT.R3) THEN
+	                    IF(RNK.LT.R2) THEN
+	                      GMAT=(RNK-R1)/DRM
+		            ELSE
+	                      GMAT=(R3-RNK)/DRP
+	                    ENDIF
+	                  ENDIF
+	                ELSE
+	                  GMAT=1.0D0
+	                ENDIF
+
+                        FNEW=FNEW+FIK*GMAT
+! in case FIK.NE.0.0D0
+	              ENDIF
+                 
+   7	         CONTINUE
+
+	         CONCL=CONCL+FNEW
+
+	         DMASS=DMASS+FNEW*R2
+
+! PSIN(I)) - new concentration of hydrometeors after condensation
+
+    	         PSIN(I)=FNEW
+                        	
+   6        CONTINUE
+
+! NEW VALUES OF DISTRIBUTION FUNCTION
+ 
+! PSI(K) - new size distribution function of hydrometeors after 
+!          condensation, K=1,...,NRX=NKR
+
+	    DO K=1,NRX
+	       PSI(K)=PSIN(K)/3./RR(K)/COL
+	    ENDDO
+
+! IN CASE: ISYM.GT.0 (CONDENSATION)
+	
+          ELSE
+
+! IN CASE: ISYM.LE.0 (EVAPORATION)
+
+	    RNS(1)=0.0D0
+	    RRS(1)=0.0D0
+	    FIN(1)=0.0D0
+	    PSIN(1)=0.0D0
+
+! FIN(K) - initial(before evaporation) concentration of hydrometeors
+
+	    DO K=2,NRXP
+	       KM=K-1
+	       RNS(K)=RN(KM)
+	       RRS(K)=RR(KM)
+	       PSIN(K)=0.0D0
+	       FIN(K)=3.0D0*FI(KM)*RR(KM)*COL
+	    ENDDO
+
+	    DO I=1,NRXP
+
+               IM=MAX(I-1,1)
+               IP=MIN(I+1,NRXP)
+
+   	       R1=RRS(IP)
+	       R2=RRS(I)
+	       R3=RRS(IM)
+
+               DRM=R1-R2
+               DRP=R2-R3
+
+	       FNEW=0.0D0
+
+	       DO K=I,NRXP
+	          RNK=RNS(K)
+                  IF(RNK.GE.R1) GOTO 4321
+                  IF(RNK.GT.R3)THEN
+                    IF(RNK.GT.R2) THEN
+                      FNEW=FNEW+FIN(K)*(R1-RNK)/DRM
+                    ELSE
+                      FNEW=FNEW+FIN(K)*(RNK-R3)/DRP
+	            ENDIF
+	          ENDIF
+               ENDDO
+
+ 4321          CONTINUE
+
+! PSIN(I) - new concentration of hydrometeors after evaporation
+
+    	       PSIN(I)=FNEW
+	
+            ENDDO
+! cycle by I
+
+! NEW VALUES OF DISTRIBUTION FUNCTION                         (start)
+
+! PSI(K), 1/g/cm^3 - new size distribution function of hydrometeors 
+!                    after evaporation, K=1,...,NRX
+	    DO K=2,NRXP
+	       KM=K-1
+	       R1=PSIN(K)*RR(KM)
+	       PSINEW=PSIN(K)/3.0D0/RR(KM)/COL
+	       IF(R1.LT.1.0D-20) PSINEW=0.0D0
+	       PSI(KM)=PSINEW
+	    ENDDO
+
+! NEW VALUES OF DISTRIBUTION FUNCTION                           (end)
+
+! IN CASE: ISYM.LE.0 (EVAPORATION)
+
+	  ENDIF
+	
+! Andrei's new change 1.12.09                                 (start)
+          IF(I3POINT.NE.0.AND.ISYM.GT.0) THEN
+! DIFFERENCE
+!         IF(I3POINT.NE.0) THEN
+! Andrei's new change 1.12.09                                   (end)                      
+
+	    DO K=1,NKR
+	       RRS(K)=RR(K)
+	    ENDDO
+
+            RRS(NKR+1)=RRS(NKR)*1024.0D0
+
+	    DO I=1,NKR
+ 
+               PSI(I)=PSI(I)*RR(I)
+
+! PSI(I) - concenration hydrometeors after KO divided on COL*3.0D0
+! RN(I), g - new masses after condensation or evaporation
+
+               IF(RN(I).LT.0.0D0) THEN 
+                 RN(I)=1.0D-50
+	         FI(I)=0.0D0
+               ENDIF
+
+            ENDDO
+ 
+	    DO K=1,NKR
+
+               IF(FI(K).NE.0.0D0) THEN
+
+                 IF(RRS(2).LT.RN(K)) THEN
+ 
+                   I=2
+
+                   DO  WHILE &
+                     (.NOT.(RRS(I).LT.RN(K).AND.RRS(I+1).GT.RN(K)) &
+                      .AND.I.LT.NKR)
+                       I=I+1
+	           ENDDO
+! ANDREI                                                      (start) 
+! new change 7.02.06                                          (start)
+                   IF(I.LT.NKR-2) THEN
+! new change 7.02.06                                            (end)
+! ANDREI                                                        (end)
+                     RNTMP=RN(K)
+
+                     RRTMP=RRS(I)
+                     RRP=RRS(I+1)
+                     RRM=RRS(I-1)
+ 
+                     RNTMP2=RN(K+1)
+
+                     RRTMP2=RRS(I+1)
+                     RRP2=RRS(I+2)
+                     RRM2=RRS(I)
+ 
+                     GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ &
+                       (RRTMP-RRM)
+
+                     GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ &
+                        (RRP2-RRM2)/(RRTMP2-RRM2)
+
+                     GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ &
+                       (RRTMP-RRM)
+ 
+	             GMAT=(RRP-RNTMP)/(RRP-RRTMP)
+! ANDREI                                                      (start) 
+! new change 7.02.06                                          (start)
+                     GN3=(RRTMP-RNTMP)*(RRM-RNTMP)/(RRP-RRM)/ &
+                                                 (RRP-RRTMP)
+	             GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
+
+                     PSI_IM=PSI(I-1)+GN1*FI(K)*RR(K)
+! Andrei's new change 1.12.09                                 (start)           
+!                    PSI_I=PSI(I)+(GN1P+GN2-GMAT)*FI(K+1)*RR(K+1)
+
+                     PSI_I=PSI(I)+GN1P*FI(K+1)*RR(K+1)+&
+	                         (GN2-GMAT)*FI(K)*RR(K)
+! Andrei's new change 1.12.09                                   (end)           
+                     PSI_IP=PSI(I+1)+(GN3-GMAT2)*FI(K)*RR(K)
+                    
+                     IF(PSI_IM.GT.0.0D0) THEN
+
+                       IF(PSI_IP.GT.0.0D0) THEN
+
+                         IF(I.GT.2) THEN
+! smoothing criteria
+                           IF(PSI_IM.GT.PSI(I-2).AND.PSI_IM.LT.PSI_I &
+                          .AND.PSI(I-2).LT.PSI(I).OR.PSI(I-2) &
+                          .GE.PSI(I)) THEN
+
+                             PSI(I-1)=PSI_IM
+
+                             PSI(I)=PSI(I)+FI(K)*RR(K)*(GN2-GMAT)
+
+                             PSI(I+1)=PSI_IP
+
+! in case smoothing criteria
+
+                           ENDIF 
+! in case I.GT.2
+                         ENDIF
+
+! in case PSI_IP.GT.0.0D0
+
+	               ENDIF
+
+! in case PSI_IM.GT.0.0D0
+
+	             ENDIF
+
+! in case I.LT.NKR-2
+
+                   ENDIF
+! new change 7.02.06                                            (end)
+! ANDREI                                                        (end)
+! in case RRS(2).LT.RN(K)
+
+                 ENDIF
+ 
+! in case FI(K).NE.0.0D0
+
+               ENDIF
+
+ 1000          CONTINUE
+
+	    ENDDO
+! cycle by K
+	    AOLDCON=0.0D0
+	    ANEWCON=0.0D0
+	    AOLDMASS=0.0D0
+	    ANEWMASS=0.0D0
+
+	    DO K=1,NKR
+	       AOLDCON=AOLDCON+FI(K)*RR(K)
+	       ANEWCON=ANEWCON+PSI(K)
+	       AOLDMASS=AOLDMASS+FI(K)*RR(K)*RN(K)
+	       ANEWMASS=ANEWMASS+PSI(K)*RR(K)
+	    ENDDO
+
+! new change 8.02.06                                          (start)
+! ANDREI                                                      (start)
+
+! PSI(K) - new hydrometeor size distribution function(sdf)
+
+	    DO K=1,NKR
+	       PSI(K)=PSI(K)/RR(K)
+            ENDDO
+	  
+! new change 8.02.06                                            (end)	       
+! ANDREI                                                        (end)
+
+! 3 point method                                                (end)	       
+								     	       
+! in case I3POINT.NE.0.AND.ISYM.GT.0						     		 
+								     		    
+	  ENDIF
+
+! Andrei's new change 1.12.09                                 (start)           
+
+          IF(IDROP.NE.0.AND.ISYM.GT.0) THEN
+	  
+	    DO K=KRDROP_REMAP_MIN,KRDROP_REMAP_MAX
+	       CDROP(K)=3.0D0*COL*PSI(K)*RR(K)
+	    ENDDO
+								     		 
+! KMAX - right boundary of drop sdf spectrum
+!(KRDROP_REMAP_MIN =< KMAX =< KRDROP_REMAP_MAX)
+
+            DO K=KRDROP_REMAP_MAX,KRDROP_REMAP_MIN,-1
+               KMAX=K
+               IF(PSI(K).GT.0.0D0) GOTO 2011
+            ENDDO
+
+ 2011       CONTINUE
+ 
+! Andrei start
+!           DO K=KMAX-1,1,-1
+! Andre end
+!Alex, Andrei, Barry
+            DO K=KMAX-1,KRDROP_REMAP_MIN,-1
+!Alex, Andrei, Barry
+	       IF(CDROP(K).GT.1.d-20) THEN
+                 DELTA_CDROP(K)=CDROP(K+1)/CDROP(K)
+	         IF(DELTA_CDROP(K).LT.COEFF_REMAP) THEN
+	           CDROP(K)=CDROP(K)+CDROP(K+1)
+		   CDROP(K+1)=0.0D0
+	         ENDIF
+	       ENDIF
+            ENDDO
+	    
+	    DO K=KRDROP_REMAP_MIN,KMAX
+	       PSI(K)=CDROP(K)/(3.0D0*COL*RR(K))
+	    ENDDO
+	    
+! in case IDROP.NE.0.AND.ISYM.GT.0
+		      
+	  ENDIF
+	    	  
+! Andrei's new change 1.12.09                                   (end)           
+! ANDREI                                                      (start) 
+! new change 8.02.06                                          (start)
+
+! in case RN(NRX).NE.RR(NRX)
+
+        ELSE
+
+! in case RN(NRX).EQ.RR(NRX)
+
+	  DO K=1,NKR
+	     PSI(K)=FI(K)
+	  ENDDO
+
+        ENDIF
+
+! new change 8.02.06                                            (end)           
+! ANDREI                                            
+
+        RETURN 
+
+! SUBROUTINE JERNEWF
+        END SUBROUTINE JERNEWF
+
+! BARRY REMOVED QP,ROR
+        SUBROUTINE JERRATEOLD(R1S,TP,PP,ROR,VR1,PSINGLE,RIEC,RO1BL &
+     &                    ,B11_MY,B12_MY,ID,IN,ICEMAX,NKR)
+       IMPLICIT NONE
+       INTEGER ID,IN,KR,ICE,NRM,ICEMAX,NKR
+      DOUBLE PRECISION TP,PP
+      REAL DETL,FACTPL,VENTPL,VR1K,CONSTL,RO1,RVT,D_MY, &
+     & CONST
+       REAL VR1(NKR,ID),PSINGLE,ROR
+        REAL       &
+     & R1S(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
+     &,RO1BL(NKR,ID),RIEC(NKR,ID) &
+     &,VR1KL(NKR,ICEMAX),VENTRL(NKR,ICEMAX) &
+     &,FD1(NKR,ICEMAX),FK1(NKR,ICEMAX),FACTRL(NKR,ICEMAX) &
+     &,R11_MY(NKR,ICEMAX),R12_MY(NKR,ICEMAX) &
+     &,R1_MY1(NKR,ICEMAX),R1_MY2(NKR,ICEMAX),R1_MY3(NKR,ICEMAX) &
+     &,AL1(2),AL1_MY(2),A1_MY(2),BB1_MY(2),ESAT1(2),CONSTLI(ICEMAX)
+      DOUBLE PRECISION TZERO
+      REAL PZERO,CF_MY,D_MYIN,RV_MY
+      PARAMETER (TZERO=273.150,PZERO=1.013E6)
+      DATA AL1/2500.,2833./
+	CONST=12.566372
+        AL1_MY(1)=2.5E10
+        AL1_MY(2)=2.834E10
+        A1_MY(1)=2.53E12
+        A1_MY(2)=3.41E13
+        BB1_MY(1)=5.42E3
+        BB1_MY(2)=6.13E3
+        CF_MY=2.4E3
+        D_MYIN=0.221
+        RV_MY=461.5E4
+	NRM=NKR-1
+
+! RHS FOR "MAXWELL" EQUATION 
+
+	D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94
+	RVT=RV_MY*TP
+	ESAT1(IN)=A1_MY(IN)*EXP(-BB1_MY(IN)/TP)
+
+	DO 1 ICE=1,ID
+	     DO 1 KR=1,NKR
+	     RO1=RO1BL(KR,ICE)
+	     CONSTL=CONST*RIEC(KR,ICE)
+	     CONSTLI(ICE)=CONSTL
+	     VR1K=0.
+	     VR1KL(KR,ICE)=VR1K
+	     VENTPL=1.
+	     VENTRL(KR,ICE)=VENTPL
+	     FACTPL=1.
+	     FACTRL(KR,ICE)=FACTPL
+	     FD1(KR,ICE)=RVT/D_MY/ESAT1(IN)/FACTPL
+	     FK1(KR,ICE)=(AL1_MY(IN)/RVT-1.)*AL1_MY(IN)/CF_MY/TP
+	     R1_MY1(KR,ICE)=VENTPL*CONSTL
+	     R11_MY(KR,ICE)=R1_MY1(KR,ICE)
+!BARRY
+!     R1_MY2(KR,ICE)=VENTPL*CONSTL*0.
+!     R1_MY3(KR,ICE)=VENTPL*CONSTL*0.
+!     R12_MY(KR,ICE)=R1_MY2(KR,ICE)-R1_MY3(KR,ICE)
+!BARRY
+! GROWTH RATE
+
+	     DETL=FK1(KR,ICE)+FD1(KR,ICE)
+	     B11_MY(KR,ICE)=R11_MY(KR,ICE)/DETL
+!BARRY     B12_MY(KR,ICE)=R12_MY(KR,ICE)/DETL
+           B12_MY(KR,ICE)=0                       
+    1	CONTINUE
+
+	RETURN
+	END SUBROUTINE JERRATEOLD
+
+! SUBROUTINE JERRATE
+!========================================================================
+!BARRY    CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N
+!    *                        ,RW,PW,RI,PI,QW,QI
+! SUBROUTINE JERNEWF
+!=========================================================================
+! BARRY REMOVED QP
+        SUBROUTINE JERRATE(R1S,TP,PP,ROR,VR1,PSINGLE,RIEC,RO1BL &
+     &                    ,B11_MY,B12_MY,ID,IN,ICEMAX,NKR)
+       IMPLICIT NONE
+       INTEGER ID,IN,KR,ICE,NRM,ICEMAX,NKR
+      DOUBLE PRECISION TP,PP
+      REAL DETL,FACTPL,VENTPL,VR1K,CONSTL,RO1,RVT,D_MY, &
+     & CONST
+        REAL VR1(NKR,ID),PSINGLE &
+     &,R1S(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
+     &,RO1BL(NKR,ID),RIEC(NKR,ID) &
+     &,VR1KL(NKR,ICEMAX),VENTRL(NKR,ICEMAX) &
+     &,FD1(NKR,ICEMAX),FK1(NKR,ICEMAX),FACTRL(NKR,ICEMAX) &
+     &,R11_MY(NKR,ICEMAX),R12_MY(NKR,ICEMAX) &
+     &,R1_MY1(NKR,ICEMAX),R1_MY2(NKR,ICEMAX),R1_MY3(NKR,ICEMAX) &
+     &,AL1(2),AL1_MY(2),A1_MY(2),BB1_MY(2),ESAT1(2),CONSTLI(ICEMAX)
+      DOUBLE PRECISION TZERO
+      REAL PZERO,CF_MY,D_MYIN,RV_MY,DEG01,DEG03
+      REAL COEFF_VISCOUS,SHMIDT_NUMBER,A,B
+      REAL REINOLDS_NUMBER,RESHM,ROR
+      PARAMETER (TZERO=273.150,PZERO=1.013E6)
+      DATA AL1/2500.,2833./
+        DEG01=1./3.     
+        DEG03=1./3.     
+	CONST=12.566372
+        AL1_MY(1)=2.5E10
+        AL1_MY(2)=2.834E10
+        A1_MY(1)=2.53E12
+        A1_MY(2)=3.41E13
+        BB1_MY(1)=5.42E3
+        BB1_MY(2)=6.13E3
+        CF_MY=2.4E3
+        D_MYIN=0.221
+        RV_MY=461.5E4
+	NRM=NKR-1
+! rhs for "maxwell" equation
+! coefficient of diffusion
+        D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94
+! new change 20.04.02
+! coefficient of viscousity
+        COEFF_VISCOUS=1.72E-2*SQRT(TP/273.)*393./(TP-120.)/ROR
+! Shmidt number
+        SHMIDT_NUMBER=COEFF_VISCOUS/D_MY
+! Constants used for calculation of Reinolds number
+        A=2.*(3./4./3.141593)**DEG01
+        B=A/COEFF_VISCOUS
+        
+        RVT=RV_MY*TP
+        ESAT1(IN)=A1_MY(IN)*EXP(-BB1_MY(IN)/TP)
+        DO ICE=1,ID
+           DO KR=1,NKR
+! Reinolds numbers
+              REINOLDS_NUMBER= &
+     &        B*VR1(KR,ICE)*SQRT(1.E6/PSINGLE)* &
+     &        (R1S(KR,ICE)/RO1BL(KR,ICE))**DEG03
+              RESHM=SQRT(REINOLDS_NUMBER)*SHMIDT_NUMBER**DEG03
+              IF(REINOLDS_NUMBER.LT.2.5) THEN
+                VENTPL=1.+0.108*RESHM*RESHM
+              ELSE
+                VENTPL=0.78+0.308*RESHM
+              ENDIF
+! new change 20.04.02                                           (end)
+              CONSTL=CONST*RIEC(KR,ICE)                         
+              CONSTLI(ICE)=CONSTL
+!             VR1K=0.
+!             VR1KL(KR,ICE)=VR1K
+! new change 20.04.02                                         (begin)
+!             VENTPL=1.                                       
+!             VENTRL(KR,ICE)=VENTPL                           
+! new change 20.04.02                                           (end)
+              FACTPL=1.                                         
+              FACTRL(KR,ICE)=FACTPL                             
+              FD1(KR,ICE)=RVT/D_MY/ESAT1(IN)/FACTPL             
+              FK1(KR,ICE)=(AL1_MY(IN)/RVT-1.)*AL1_MY(IN)/CF_MY/TP
+              R1_MY1(KR,ICE)=VENTPL*CONSTL
+!             R1_MY2(KR,ICE)=VENTPL*CONSTL*0.
+!             R1_MY3(KR,ICE)=VENTPL*CONSTL*0.
+              R11_MY(KR,ICE)=R1_MY1(KR,ICE)
+!BARRY        R12_MY(KR,ICE)=R1_MY2(KR,ICE)-R1_MY3(KR,ICE)
+! growth rate 
+              DETL=FK1(KR,ICE)+FD1(KR,ICE)
+              B11_MY(KR,ICE)=R11_MY(KR,ICE)/DETL
+!BARRY        B12_MY(KR,ICE)=R12_MY(KR,ICE)/DETL
+              B12_MY(KR,ICE)=0.
+           ENDDO
+        ENDDO
+
+
+	RETURN
+	END SUBROUTINE JERRATE
+
+! SUBROUTINE JERRATE
+!========================================================================
+!BARRY    CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N
+!    *                        ,RW,PW,RI,PI,QW,QI
+!    *                        ,DTT,D1N,D2N,DT0L,DT0I)
+	SUBROUTINE JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                      ,RW,PW,RI,PI,QW,QI &
+     &                      ,DT,DEL1INT,DEL2INT,DT0L,DT0I)
+      IMPLICIT NONE
+   
+      INTEGER ITYPE
+      REAL DEL1,DEL2,RW,PW,RI,PI,QW,QI, &
+     &  DT,DEL1INT,DEL2INT,DT0L,DT0I,DTLIN,DTIIN
+      REAL DETER,DBLRW,DBLPW,DBLPI,DBLRI, &
+     &  DBLDEL1,DBLDEL2,DBLDEL1INT,DBLDTLIN,DBLDTIIN, &
+     &  EXPM,EXPP,ALFAMX,ALFAPX,X,ALFA,DELX,DBLDEL2INT, &
+     &  R1RES,R2RES,R1,R2,R3,R4,R21,R11,R10,R41,R31,R30,DBLDT, &
+     &  DBLDEL1N,DBLDEL2N
+      DOUBLE PRECISION DEL1N,DEL2N
+
+        DOUBLE PRECISION DEL1N_2P,DEL1INT_2P,DEL2N_2P,DEL2INT_2P 
+        DOUBLE PRECISION EXPP_2P,EXPM_2P,ARGEXP     
+! BARRY
+      DOUBLE PRECISION RW_DP,PW_DP,PI_DP,RI_DP,X_DP,ALFA_DP
+!    * ,ALFAPX_DP
+! Andrei's new change 9.03.10                                 (start)
+      DOUBLE PRECISION  EXPM1
+      EXPM1(x_dp)= &
+     &x_dp+x_dp*x_dp/2.0D0+x_dp*x_dp*x_dp/6.0D0+x_dp*x_dp*x_dp*x_dp/24.0D0+x_dp*x_dp*x_dp*x_dp*x_dp/120.0D0
+      DOUBLE PRECISION  DETER_MIN
+! Andrei's new change 9.03.10                                 (start)
+
+      DOUBLE PRECISION EXP1, EXP2
+
+! Andrei's new change 9.03.10                                   (end)
+	DTLIN=1000.E17
+	DTIIN=1000.E17
+! Andrei's new change 9.03.10                                 (start)
+      DETER=RW*PI-PW*RI
+!     DETER_MIN=1.0D-20
+! Andrei's new change 9.03.10                                 (end)
+! SOLUTION  
+!IF(DETER.EQ.0)  THEN
+       IF(RW.EQ.0.AND.RI.EQ.0) THEN
+! NO CLOUD: WITHOUT WATER & ICE
+	    DEL1N_2P=DEL1
+	    DEL2N_2P=DEL2
+	    DEL1INT_2P=DEL1*DT
+	    DEL2INT_2P=DEL2*DT
+! IN CASE: RW.NE.0 OR RI.NE.0 (WATER OR ICE) 
+       ELSE IF(RW.NE.0.AND.RI*1.E5.LT.RW) THEN
+! ONLY WATER
+              ARGEXP=-RW*DT
+
+	      DEL1N_2P=DEL1*DEXP(ARGEXP)+QW*(1.-DEXP(ARGEXP))
+	      DEL1INT_2P=(DEL1-DEL1N_2P)/RW
+	      DEL2N_2P=DEL2-PW*DEL1INT_2P
+	      DEL2INT_2P= &
+     &       (DEL2N_2P-PW*DEL1N_2P/RW)*DT+PW*DEL1INT_2P/RW
+	ELSE IF(RI.NE.0.AND.RW*1.E5.LT.RI) THEN
+! IN CASE: RW.EQ.0
+! ONLY ICE 
+              ARGEXP=-PI*DT
+
+	      DEL2N_2P=DEL2*DEXP(ARGEXP)+QI*(1.-DEXP(ARGEXP))
+	      DEL2INT_2P=(DEL2-DEL2N_2P)/PI
+	      DEL1N_2P=DEL1-RI*DEL2INT_2P
+	      DEL1INT_2P= &
+     &       (DEL1N_2P-RI*DEL2N_2P/PI)*DT+RI*DEL2INT_2P/PI
+!             GOTO 100
+! IN CASE: RW.NE.0 OR RI.NE.0 (WATER OR ICE)
+! IN CASE: DETER.EQ.0
+        ELSE
+! IN CASE: DETER.NE.0
+! COMPLETE SOLUTION 
+!  ALFA=SQRT((RW-PI)*(RW-PI)+4.*PW*RI)
+!  X=RW+PI
+!  ALFAPX=.5*(ALFA+X)
+! BARRY 
+          RW_DP=RW
+          RI_DP=RI
+          PI_DP=PI
+          PW_DP=PW
+          IF (RW.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (RW.LE.0), model stop")
+          IF (PW.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (PW.LE.0), model stop")
+          IF (RI.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (RI.LE.0), model stop")
+          IF (PI.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (PI.LE.0), model stop")
+          ALFA_DP=SQRT((RW_DP-PI_DP)*(RW_DP-PI_DP)+4.*PW_DP*RI_DP) 
+	  X_DP=RW_DP+PI_DP
+	  ALFAPX=.5*(ALFA_DP+X_DP)
+          IF (ALFAPX.LE.0) call wrf_error_fatal("fatal error in module_mp_fast_sbm (CHECK.LT.0), model stop")
+	  ALFAMX=.5*(ALFA_DP-X_DP)
+!
+! 
+          ARGEXP=-ALFAPX*DT
+! Andrei 11/04/10
+	  EXPP_2P=DEXP(ARGEXP)
+          IF(DABS(ARGEXP).LE.1.0E-6) THEN
+               EXP1=EXPM1(ARGEXP)
+          ELSE
+               EXP1=EXPP_2P-1.0D0
+          ENDIF
+!
+          ARGEXP=ALFAMX*DT
+!Andre 11/04/10
+	  EXPM_2P=DEXP(ARGEXP)
+              IF(DABS(ARGEXP).LE.1.0E-6) THEN
+                EXP2=EXPM1(ARGEXP)
+              ELSE
+                EXP2=EXPM_2P-1.0D0
+              ENDIF
+!
+! DROPLETS 
+	  R10=RW*DEL1+RI*DEL2
+	  R11=R10-ALFAPX*DEL1
+	  R21=R10+ALFAMX*DEL1
+	  DEL1N_2P=(R21*EXPP_2P-R11*EXPM_2P)/ALFA_DP
+! BARRY
+	  IF(ALFAMX.NE.0) THEN
+	    R1=-R11/ALFAMX
+	    R2=R21/ALFAPX
+!    DEL1INT_2P=(R1*(EXPM_2P-1.)-R2*(EXPP_2P-1.))/ALFA_DP
+            DEL1INT_2P=(R1*EXP2-R2*EXP1)/ALFA_DP
+	  ELSE
+            DEL1INT_2P = 0.
+	  ENDIF
+! BARRY
+	  R1RES=0.
+	  IF(R11.NE.0) R1RES=R21/R11
+	  IF(R1RES.GT.0) DTLIN=ALOG(R1RES)/ALFA_DP
+! ICE 
+	  R30=PW*DEL1+PI*DEL2
+	  R31=R30-ALFAPX*DEL2
+	  R41=R30+ALFAMX*DEL2
+! BARRY
+	  DEL2N_2P=(R41*EXPP_2P-R31*EXPM_2P)/ALFA_DP
+	  IF(ALFAMX.NE.0.AND.ALFAPX.NE.0) THEN
+	    R3=-R31/ALFAMX
+	    R4=R41/ALFAPX
+!           DEL2INT_2P=(R3*(EXPM_2P-1.)-R4*(EXPP_2P-1.))/ALFA_DP
+            DEL2INT_2P=(R3*EXP2-R4*EXP1)/ALFA_DP
+          ELSE
+	    DEL2INT_2P=0.
+	  ENDIF
+	  R2RES=0.
+	  IF(R31.NE.0) R2RES=R41/R31
+	  IF(R2RES.GT.0) DTIIN=ALOG(R2RES)/ALFA_DP
+! IN CASE: DETER.NE.0
+! END OF COMPLETE SOLUTION
+	ENDIF
+! IN CASES: DETER.EQ.0 OR DETER.NE.0
+ 100    CONTINUE
+        DEL1N=DEL1N_2P
+        DEL2N=DEL2N_2P
+       
+! BARRY
+        DEL1INT=DEL1INT_2P
+        DEL2INT=DEL2INT_2P
+	DT0L=DTLIN
+	IF(DT0L.LT.0) DT0L=1.E20
+	DT0I=DTIIN
+	IF(DT0I.LT.0) DT0I=1.E20
+	RETURN
+	END SUBROUTINE JERSUPSAT
+!==========================================================================
+        SUBROUTINE JERTIMESC(FI1,X1,SFN11,SFN12 &
+     &                      ,B11_MY,B12_MY,RIEC,CF,ID,COL,NKR)        
+      IMPLICIT NONE
+       INTEGER NRM,KR,ICE,ID,NKR
+      REAL B12,B11,FUN,DELM,FK,CF,SFN12S,SFN11S
+	REAL  COL, &
+     & X1(NKR,ID),FI1(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
+     &,RIEC(NKR,ID),SFN11,SFN12
+
+	NRM=NKR-1
+	DO 1 ICE=1,ID  
+             SFN11S=0.                              
+             SFN12S=0.
+	     SFN11=CF*SFN11S	
+	     SFN12=CF*SFN12S
+             DO KR=1,NRM
+! VALUE OF DISTRIBUTION FUNCTION
+	        FK=FI1(KR,ICE)
+! DELTA-M 
+	        DELM=X1(KR,ICE)*3.*COL
+! INTEGRAL'S EXPRESSION 
+	        FUN=FK*DELM
+! VALUES OF INTEGRALS
+	        B11=B11_MY(KR,ICE)
+        	B12=B12_MY(KR,ICE)
+                SFN11S=SFN11S+FUN*B11                               
+                SFN12S=SFN12S+FUN*B12
+	     ENDDO
+! CORRECTION 
+	     SFN11=CF*SFN11S
+             SFN12=CF*SFN12S
+    1   CONTINUE
+! END 
+	RETURN
+	END SUBROUTINE JERTIMESC
+!
+        SUBROUTINE JERTIMESC_ICE(FI1,X1,SFN11,SFN12 &
+     &                      ,B11_MY,B12_MY,RIEC,CF,ID,COL,NKR)        
+      IMPLICIT NONE
+       INTEGER NRM,KR,ICE,ID,NKR
+      REAL B12,B11,FUN,DELM,FK,CF,SFN12S,SFN11S
+	REAL  COL, &
+     & X1(NKR,ID),FI1(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
+     &,RIEC(NKR,ID),SFN11(ID),SFN12(ID)
+
+	NRM=NKR-1
+	DO 1 ICE=1,ID  
+             SFN11S=0.                              
+             SFN12S=0.
+	     SFN11(ICE)=CF*SFN11S	
+	     SFN12(ICE)=CF*SFN12S
+             DO KR=1,NRM
+! VALUE OF DISTRIBUTION FUNCTION
+	        FK=FI1(KR,ICE)
+! DELTA-M 
+	        DELM=X1(KR,ICE)*3.*COL
+! INTEGRAL'S EXPRESSION 
+	        FUN=FK*DELM
+! VALUES OF INTEGRALS
+	        B11=B11_MY(KR,ICE)
+        	B12=B12_MY(KR,ICE)
+                SFN11S=SFN11S+FUN*B11                               
+                SFN12S=SFN12S+FUN*B12
+	     ENDDO
+! CORRECTION 
+	     SFN11(ICE)=CF*SFN11S
+             SFN12(ICE)=CF*SFN12S
+    1   CONTINUE
+! END 
+	RETURN
+	END SUBROUTINE JERTIMESC_ICE
+
+
+        SUBROUTINE ONECOND2 &
+     & (TT,QQ,PP,ROR  &
+     & ,VR2,VR3,VR4,VR5,PSINGLE &
+     & ,DEL1N,DEL2N,DIV1,DIV2 &
+     & ,FF2,PSI2,R2,RIEC,RO2BL &
+     & ,FF3,PSI3,R3,RSEC,RO3BL &
+     & ,FF4,PSI4,R4,RGEC,RO4BL &
+     & ,FF5,PSI5,R5,RHEC,RO5BL &
+     & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     & ,C1_MEY,C2_MEY &
+     & ,COL,DTCOND,ICEMAX,NKR &
+     & ,ISYM2,ISYM3,ISYM4,ISYM5)
+
+       IMPLICIT NONE
+
+      INTEGER NKR,ICEMAX
+      REAL    COL,VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
+     &           ,VR5(NKR),PSINGLE &
+     &       ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &       ,DTCOND
+
+      REAL C1_MEY,C2_MEY
+      INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON, &
+     & KR,ICE,ITIME,ICM,KCOND,NR,NRM,INUC, &
+     & ISYM2,ISYM3,ISYM4,ISYM5,KP,KLIMIT, &
+     & KM,ITER,KLIMITL,KLIMITG,KLIMITH,KLIMITI_1,KLIMITI_2,KLIMITI_3, &
+     & NCRITI
+      REAL AL1,AL2,D,GAM,POD, &
+     & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
+     & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
+     & TPC1, TPC2, TPC3, TPC4, TPC5, &
+     & EPSDEL, DT0L, DT0I, &
+     & ROR, &
+     & DEL1NUC,DEL2NUC, &
+     & CWHUCM,B6,B8L,B8I,RMASSGL,RMASSGI, &
+     & DEL1,DEL2,DEL1S,DEL2S, &
+     & TIMENEW,TIMEREV,SFN11,SFN12, &
+     & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,OPERQ,RW,RI,QW,PW, &
+     & PI,QI,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
+     & DEL_R1,DT0L0,DT0I0,SFN31,SFN32,SFN52, &
+     & SFNII1,SFN21,SFN22,DTNEWI3,DTNEWI4,DTNEWI5,DTNEWI2_1, &
+     & DTNEWI2_2,DTNEWI1,DEL_R2,DEL_R4,DEL_R5,SFN41,SFN42, &
+     & SNF51,DTNEWI2_3,DTNEWI2,DTNEWI_1,DTNEWI_2, &
+     & DTNEWL0,DTNEWG1,DTNEWH1,DTNEWI_3, &
+     & DTNEWL2,SFN51,SFNII2,DEL_R3,DTNEWI  
+       REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
+     &  DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON
+
+       INTEGER K
+
+! NEW ALGORITHM OF CONDENSATION (12.01.00)
+
+      DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
+      DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
+     &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
+     &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
+     &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
+     &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
+     &                  ,ES1N,ES2N,EW1N,ARGEXP &
+     &                  ,TT,QQ,PP &
+     &                  ,DEL1N,DEL2N,DIV1,DIV2 &
+     &                  ,OPER2,OPER3,AR1,AR2  
+
+       DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
+
+! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
+
+        CHARACTER*70 CPRINT
+
+
+
+
+
+
+
+! CRYSTALS
+                                                                       
+	REAL R2(NKR,ICEMAX) &
+     &           ,RIEC(NKR,ICEMAX) &
+     &           ,RO2BL(NKR,ICEMAX) &
+     &           ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
+     &           ,FF2(NKR,ICEMAX) &
+     &           ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX)
+
+! SNOW                                                                          
+        REAL R3(NKR) &
+     &           ,RSEC(NKR),RO3BL(NKR) &
+     &           ,FI3(NKR),FF3(NKR),PSI3(NKR) &
+     &           ,B31_MY(NKR),B32_MY(NKR)
+
+! GRAUPELS 
+                                                                       
+        REAL R4(NKR) &
+     &           ,RGEC(NKR),RO4BL(NKR) &
+     &           ,FI4(NKR),FF4(NKR),PSI4(NKR) &
+     &           ,B41_MY(NKR),B42_MY(NKR)  
+
+! HAIL                                                                          
+        REAL R5(NKR) &
+     &           ,RHEC(NKR),RO5BL(NKR) &
+     &           ,FI5(NKR),FF5(NKR),PSI5(NKR) &
+     &           ,B51_MY(NKR),B52_MY(NKR)  
+
+! CCN                                                                       
+
+! WORK ARRAYS 
+
+! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION
+
+	REAL DTIMEG(NKR),DTIMEH(NKR) 
+       
+	REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
+
+! NEW ALGORITHM (NO TYPE OF ICE)
+
+     &           ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR) &
+     &           ,SFNI1(ICEMAX),SFNI2(ICEMAX) &
+     &           ,TIMESTEPD(NKR) &
+     &           ,FI1REF(NKR),PSI1REF(NKR) &
+     &           ,FI2REF(NKR,ICEMAX),PSI2REF(NKR,ICEMAX)&
+     &           ,FCCNRREF(NKR)
+
+
+	OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
+	OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
+
+        DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
+     &      ,GAM /1.E-4/, POD /10./ 
+           
+	DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
+     &      /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/
+
+	DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
+     &      /2.53,5.42,3.41E1,6.13/
+
+	DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
+     &      /-4.0,-8.1,-12.7,-17.8,-22.4/ 
+
+
+        DATA EPSDEL/0.1E-03/
+    
+	DATA DT0L, DT0I /1.E20,1.E20/
+
+! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
+
+
+! CONTROL OF TIMESTEP ITERATIONS IN MIXED PHASE: EVAPORATION
+        
+        I_MIXCOND=0
+        I_MIXEVAP=0
+        I_ABERGERON=0
+        I_BERGERON=0
+! SOME CONSTANTS 
+        COL3=3.0*COL
+        ICM=ICEMAX
+        ITIME=0
+        KCOND=0
+        DT_WATER_COND=0.4
+        DT_WATER_EVAP=0.4
+        DT_ICE_COND=0.4
+        DT_ICE_EVAP=0.4
+        DT_MIX_COND=0.4
+        DT_MIX_EVAP=0.4
+        DT_MIX_BERGERON=0.4
+        DT_MIX_ANTIBERGERON=0.4
+	ICM=ICEMAX
+	ITIME=0
+	KCOND=0
+        DT0LREF=0.2
+        DTLREF=0.4
+
+	NR=NKR
+	NRM=NKR-1
+	DT=DTCOND
+	DTT=DTCOND
+	XRAD=0.
+
+!     BARRY
+	CWHUCM=0.
+	XRAD=0.
+	B6=CWHUCM*GAM-XRAD
+	B8L=1./ROR
+	B8I=1./ROR
+        RORI=1./ROR
+
+! INITIALIZATION OF SOME ARRAYS
+
+!       BARRY
+        TPN=TT
+        QPN=QQ
+
+
+! TYPE OF ICE IN DIFFUSIONAL GROWTH 
+
+	      DO ICE=1,ICEMAX
+	         SFNI1(ICE)=0.
+	         SFNI2(ICE)=0.
+	         DEL2D(ICE)=0.
+	      ENDDO
+
+! TIME SPLITTING 
+
+	      TIMENEW=0.
+	      ITIME=0
+
+! ONLY ICE (CONDENSATION OR EVAPORATION) :
+
+   46         ITIME=ITIME+1
+
+	      TIMEREV=DT-TIMENEW
+
+	      DEL1=DEL1N
+	      DEL2=DEL2N
+	      DEL1S=DEL1N
+	      DEL2S=DEL2N
+	      DEL2D(1)=DEL2N
+	      DEL2D(2)=DEL2N
+	      DEL2D(3)=DEL2N
+	      TPS=TPN
+	      QPS=QPN
+              DO KR=1,NKR
+                 FI3(KR)=PSI3(KR)
+                 FI4(KR)=PSI4(KR)
+                 FI5(KR)=PSI5(KR)
+                 DO ICE=1,ICEMAX
+                    FI2(KR,ICE)=PSI2(KR,ICE)
+                 ENDDO
+              ENDDO
+! TIME-STEP GROWTH RATE: 
+! ONLY ICE (CONDENSATION OR EVAPORATION)
+              CALL JERRATE(R2,TPS,PP,ROR,VR2,PSINGLE &
+     &                    ,RIEC,RO2BL,B21_MY,B22_MY,3,2,ICEMAX,NKR)   
+              CALL JERRATE(R3,TPS,PP,ROR,VR3,PSINGLE &
+     &                    ,RSEC,RO3BL,B31_MY,B32_MY,1,2,ICEMAX,NKR)
+              CALL JERRATE(R4,TPS,PP,ROR,VR4,PSINGLE &
+     &                    ,RGEC,RO4BL,B41_MY,B42_MY,1,2,ICEMAX,NKR)
+              CALL JERRATE(R5,TPS,PP,ROR,VR5,PSINGLE &
+     &                    ,RHEC,RO5BL,B51_MY,B52_MY,1,2,ICEMAX,NKR)
+
+
+! INTEGRALS IN DELTA EQUATION
+
+! CALL JERTIMESC CRYSTAL - 1 (ONLY ICE)
+              CALL JERTIMESC_ICE  &
+     &       (FI2,R2,SFNI1,SFNI2,B21_MY,B22_MY,RIEC,B8I,ICM,COL,NKR) 
+              CALL JERTIMESC &
+     &       (FI3,R3,SFN31,SFN32,B31_MY,B32_MY,RSEC,B8I,1,COL,NKR)  
+              CALL JERTIMESC &
+     &       (FI4,R4,SFN41,SFN42,B41_MY,B42_MY,RGEC,B8I,1,COL,NKR) 
+              CALL JERTIMESC &
+     &       (FI5,R5,SFN51,SFN52,B51_MY,B52_MY,RHEC,B8I,1,COL,NKR)
+	      SFNII1=SFNI1(1)+SFNI1(2)+SFNI1(3)
+	      SFNII2=SFNI2(1)+SFNI2(2)+SFNI2(3)
+	      SFN21=SFNII1+SFN31+SFN41+SFN51        
+	      SFN22=SFNII2+SFN32+SFN42+SFN52 
+	      SFNL=0.
+	      SFNI=SFN21+SFN22       
+! SOME CONSTANTS 
+	      B5L=BB1_MY/TPS/TPS
+	      B5I=BB2_MY/TPS/TPS
+              B7L=B5L*B6                                                     
+              B7I=B5I*B6
+	      DOPL=1.+DEL1S                                                     
+	      DOPI=1.+DEL2S                                                     
+	      OPERQ=OPER2(QPS)  
+              RW=(OPERQ+B5L*AL1)*DOPL*SFNL                                      
+              QW=B7L*DOPL
+              PW=(OPERQ+B5I*AL1)*DOPI*SFNL
+              RI=(OPERQ+B5L*AL2)*DOPL*SFNI
+              PI=(OPERQ+B5I*AL2)*DOPI*SFNI
+              QI=B7I*DOPI
+	      KCOND=20
+	      IF(DEL2.GT.0) KCOND=21
+
+! PROCESS'S TYPE (ONLY ICE) 
+
+	      IF(KCOND.EQ.21)  THEN
+
+! ONLY_ICE: CONDENSATION
+
+	      
+                DT0I=1.E20
+	        DTNEWI1=DTCOND
+	        DTNEWL=DTNEWI1
+	        IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
+	        ENDIF
+	        TIMESTEPD(ITIME)=DTNEWL
+! NEW TIME STEP (ONLY_ICE: CONDENSATION)
+	        IF(DTNEWL.GT.DT) DTNEWL=DT
+	        IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+	        TIMESTEPD(ITIME)=DTNEWL
+	        TIMENEW=TIMENEW+DTNEWL
+	        DTT=DTNEWL
+! SOLVING FOR SUPERSATURATION (ONLY ICE: CONDENSATION) 
+
+! CALL JERSUPSAT - 4 (ONLY ICE: CONDENSATION)
+
+	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                        ,RW,PW,RI,PI,QW,QI &
+     &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
+
+! END OF "NEW SUPERSATURATION" (ONLY ICE: CONDENSATION)
+
+
+! CRYSTALS (ONLY ICE: CONDENSATION) 
+
+	        IF(ISYM2.NE.0) THEN
+
+! CRYSTAL DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
+ 
+! CALL JERDFUN CRYSTAL - 1 (ONLY ICE: CONDENSATION)
+
+! NEW ALGORITHM (NO TYPE ICE)
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                        ,FI2,PSI2,D2N &
+     &                        ,ICM,1,COL,NKR,TPN)
+
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                        ,FI2,PSI2,D2N &
+     &                        ,ICM,2,COL,NKR,TPN)
+
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                        ,FI2,PSI2,D2N &
+     &                        ,ICM,3,COL,NKR,TPN)
+! IN CASE : ISYM2.NE.0
+
+	        ENDIF
+! SNOW 
+	        IF(ISYM3.NE.0) THEN
+
+! SNOW DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
+                                                         
+
+! CALL JERDFUN SNOW - 1 (ONLY ICE: CONDENSATION)
+                  CALL JERDFUN(R3,B31_MY,B32_MY &
+     &                        ,FI3,PSI3,D2N &
+     &                        ,1,3,COL,NKR,TPN)
+
+	        ENDIF
+! IN CASE : ISYM4.NE.0
+! GRAUPELS (ONLY_ICE: EVAPORATION)
+
+                IF(ISYM4.NE.0) THEN
+
+! GRAUPEL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION)
+
+                  CALL JERDFUN(R4,B41_MY,B42_MY &
+     &                        ,FI4,PSI4,D2N &
+     &                        ,1,4,COL,NKR,TPN)
+! IN CASE : ISYM4.NE.0
+
+                ENDIF
+
+
+
+! HAIL (ONLY ICE: CONDENSATION) 
+
+	        IF(ISYM5.NE.0) THEN
+
+! HAIL DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
+                                                         
+! CALL JERDFUN HAIL - 1 (ONLY ICE: CONDENSATION) 
+	          CALL JERDFUN(R5,B51_MY,B52_MY &
+     &                        ,FI5,PSI5,D2N &
+     &                        ,1,5,COL,NKR,TPN)
+! IN CASE : ISYM5.NE.0
+
+	        ENDIF
+
+	        IF((DEL2.GT.0.AND.DEL2N.LT.0) &
+     &         .AND.ABS(DEL2N).GT.EPSDEL) THEN
+               call wrf_error_fatal("fatal error in module_mp_fast_sbm (DEL2.GT.0.AND.DEL2N.LT.0), model stop")
+                ENDIF
+
+	      ELSE
+
+! IN CASE KCOND.NE.21 
+
+! ONLY ICE: EVAPORATION  
+
+! NEW TREATMENT OF TIME STEP (ONLY ICE: EVAPORATION) 
+
+	        DT0I=1.E20
+                IF (DEL2N.EQ.0)THEN
+	          DTNEWL=DT
+                ELSE
+	         DTNEWI3=-R3(3)/(B31_MY(3)*DEL2N-B32_MY(3))
+	         DTNEWI4=-R4(3)/(B41_MY(3)*DEL2N-B42_MY(3))
+	         DTNEWI5=-R5(3)/(B51_MY(3)*DEL2N-B52_MY(3))
+! NEW ALGORITHM (NO TYPE OF ICE)
+	         DTNEWI2_1=-R2(3,1)/(B21_MY(1,1)*DEL2N-B22_MY(1,1))
+	         DTNEWI2_2=-R2(3,2)/(B21_MY(1,2)*DEL2N-B22_MY(1,2))
+	         DTNEWI2_3=-R2(3,3)/(B21_MY(1,3)*DEL2N-B22_MY(1,3))
+                 DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
+	         DTNEWI1=AMIN1(DTNEWI2,DTNEWI3,DTNEWI4 &
+     &                       ,DTNEWI5,DT0I,TIMEREV)
+	         DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I,TIMEREV)
+	         DTNEWL=DTNEWI1
+	         IF(DTNEWL.LT.DTLREF) DTNEWL=AMIN1(DTLREF,TIMEREV)
+                END IF
+	        IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
+                ENDIF
+	        TIMESTEPD(ITIME)=DTNEWL
+
+! NEW TIME STEP (ONLY_ICE: EVAPORATION)
+
+	        IF(DTNEWL.GT.DT) DTNEWL=DT
+	        IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+	        TIMENEW=TIMENEW+DTNEWL
+	        TIMESTEPD(ITIME)=DTNEWL
+	        DTT=DTNEWL
+! SOLVING FOR SUPERSATURATION (ONLY_ICE: EVAPORATION) 
+	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                        ,RW,PW,RI,PI,QW,QI &
+     &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
+! END OF "NEW SUPERSATURATION" (ONLY_ICE: EVAPORATION) 
+
+! CRYSTALS
+	        IF(ISYM2.NE.0) THEN
+
+! CRYSTAL DISTRIBUTION FUNCTION 
+
+! NEW ALGORITHM (NO TYPE ICE) 
+
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                         ,FI2,PSI2,D2N &
+     &                         ,ICM,1,COL,NKR,TPN)
+
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                         ,FI2,PSI2,D2N &
+     &                         ,ICM,2,COL,NKR,TPN)
+
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                         ,FI2,PSI2,D2N &
+     &                         ,ICM,3,COL,NKR,TPN)
+	        ENDIF
+! SNOW 
+	        IF(ISYM3.NE.0) THEN
+
+! SNOW DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
+                                                         
+
+! CALL JERDFUN - SNOW - 2 (ONLY_ICE: EVAPORATION)
+
+	          CALL JERDFUN(R3,B31_MY,B32_MY &
+     &                        ,FI3,PSI3,D2N &
+     &                        ,1,3,COL,NKR,TPN)
+
+
+
+
+
+! IN CASE : ISYM3.NE.0
+
+	        ENDIF
+
+! GRAUPELS (ONLY_ICE: EVAPORATION) 
+
+	        IF(ISYM4.NE.0) THEN
+
+! GRAUPEL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
+                                                         
+	          CALL JERDFUN(R4,B41_MY,B42_MY &
+     &                        ,FI4,PSI4,D2N &
+     &                        ,1,4,COL,NKR,TPN)
+! IN CASE : ISYM4.NE.0
+
+	        ENDIF
+
+! HAIL (ONLY_ICE: EVAPORATION) 
+
+	        IF(ISYM5.NE.0) THEN
+
+! HAIL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
+                                                         
+	          CALL JERDFUN(R5,B51_MY,B52_MY &
+     &                        ,FI5,PSI5,D2N &
+     &                        ,1,5,COL,NKR,TPN)
+! IN CASE : ISYM5.NE.0
+
+	        ENDIF
+
+	        IF((DEL2.LT.0.AND.DEL2N.GT.0) &
+     &         .AND.ABS(DEL2N).GT.EPSDEL) THEN
+                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ABS(DEL2N).GT.EPSDEL), model stop")
+	        ENDIF
+
+! IN CASE : KCOND.NE.21
+ 
+	      ENDIF
+
+! IN CASES : KCOND = 21 OR KCOND.NE.21
+
+! END OF "PROCESS'S TYPE" 
+!
+! MASSES
+              RMASSIBB=0.0
+              RMASSIAA=0.0
+! BEFORE JERNEWF
+              DO K=1,NKR
+                 DO ICE =1,ICEMAX
+                    FI2_K=FI2(K,ICE)
+                    R2_K=R2(K,ICE)
+                    FI2R2=FI2_K*R2_K*R2_K
+                    RMASSIBB=RMASSIBB+FI2R2
+                 ENDDO
+                 FI3_K=FI3(K)
+                 FI4_K=FI4(K)
+                 FI5_K=FI5(K)
+                 R3_K=R3(K)
+                 R4_K=R4(K)
+                 R5_K=R5(K)
+                 FI3R3=FI3_K*R3_K*R3_K
+                 FI4R4=FI4_K*R4_K*R4_K
+                 FI5R5=FI5_K*R5_K*R5_K
+                 RMASSIBB=RMASSIBB+FI3R3
+                 RMASSIBB=RMASSIBB+FI4R4
+                 RMASSIBB=RMASSIBB+FI5R5
+              ENDDO
+              RMASSIBB=RMASSIBB*COL3*RORI
+! NEW CHANGE RMASSIBB
+              IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
+! AFTER JERNEWF
+              DO K=1,NKR
+                 DO ICE =1,ICEMAX
+                    FI2_K=PSI2(K,ICE)
+                    R2_K=R2(K,ICE)
+                    FI2R2=FI2_K*R2_K*R2_K
+                    RMASSIAA=RMASSIAA+FI2R2
+                 ENDDO
+                 FI3_K=PSI3(K)
+                 FI4_K=PSI4(K)
+                 FI5_K=PSI5(K)
+                 R3_K=R3(K)
+                 R4_K=R4(K)
+                 R5_K=R5(K)
+                 FI3R3=FI3_K*R3_K*R3_K
+                 FI4R4=FI4_K*R4_K*R4_K
+                 FI5R5=FI5_K*R5_K*R5_K
+                 RMASSIAA=RMASSIAA+FI3R3
+                 RMASSIAA=RMASSIAA+FI4R4
+                 RMASSIAA=RMASSIAA+FI5R5
+              ENDDO
+              RMASSIAA=RMASSIAA*COL3*RORI
+! NEW CHANGE RMASSIAA
+              IF(RMASSIAA.LT.0.0) RMASSIAA=0.0
+! NEW TREATMENT OF "T" & "Q"
+              DELMASSI1=RMASSIAA-RMASSIBB
+              QPN=QPS-DELMASSI1
+              DAL2=AL2
+              TPN=TPS+DAL2*DELMASSI1
+! SUPERSATURATION
+              ARGEXP=-BB1_MY/TPN
+              ES1N=AA1_MY*DEXP(ARGEXP)
+              ARGEXP=-BB2_MY/TPN
+              ES2N=AA2_MY*DEXP(ARGEXP)
+              EW1N=OPER3(QPN,PP)
+              IF(ES1N.EQ.0)THEN
+               DEL1N=0.5
+               DIV1=1.5
+              call wrf_error_fatal("fatal error in module_mp_fast_sbm (ES1N.EQ.0), model stop")
+              ELSE
+               DIV1=EW1N/ES1N
+               DEL1N=EW1N/ES1N-1.
+              END IF
+              IF(ES2N.EQ.0)THEN
+               DEL2N=0.5
+               DIV2=1.5
+              call wrf_error_fatal("fatal error in module_mp_fast_sbm (ES2N.EQ.0), model stop")
+              ELSE
+               DEL2N=EW1N/ES2N-1.
+               DIV2=EW1N/ES2N
+              END IF
+
+!  END OF TIME SPLITTING 
+! (ONLY ICE: CONDENSATION OR EVAPORATION) 
+	      IF(TIMENEW.LT.DT) GOTO 46
+        TT=TPN
+        QQ=QPN
+	DO KR=1,NKR
+	   DO ICE=1,ICEMAX
+	      FF2(KR,ICE)=PSI2(KR,ICE)
+	   ENDDO
+	   FF3(KR)=PSI3(KR)
+	   FF4(KR)=PSI4(KR)
+	   FF5(KR)=PSI5(KR)
+	ENDDO
+
+
+! GO TO "CONDENSATION AND VAPORATION"
+
+
+        RETURN                                          
+        END SUBROUTINE ONECOND2
+!==================================================================
+
+        SUBROUTINE ONECOND3 &
+     & (TT,QQ,PP,ROR &
+     & ,VR1,VR2,VR3,VR4,VR5,PSINGLE &
+     & ,DEL1N,DEL2N,DIV1,DIV2 &
+     & ,FF1,PSI1,R1,RLEC,RO1BL &
+     & ,FF2,PSI2,R2,RIEC,RO2BL &
+     & ,FF3,PSI3,R3,RSEC,RO3BL &
+     & ,FF4,PSI4,R4,RGEC,RO4BL &
+     & ,FF5,PSI5,R5,RHEC,RO5BL &
+     & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     & ,C1_MEY,C2_MEY &
+     & ,COL,DTCOND,ICEMAX,NKR &
+     & ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
+       IMPLICIT NONE
+       INTEGER ICEMAX,NKR,KR,ITIME,ICE,KCOND,K &
+     &           ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5
+       INTEGER KLIMITL,KLIMITG,KLIMITH,KLIMITI_1, &
+     &  KLIMITI_2,KLIMITI_3
+       INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON  
+       REAL ROR,VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
+     &           ,VR5(NKR),PSINGLE &
+     &           ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &           ,C1_MEY,C2_MEY &
+     &           ,COL,DTCOND
+
+! DROPLETS 
+                                                                       
+        REAL R1(NKR)&
+     &           ,RLEC(NKR),RO1BL(NKR) &
+     &           ,FI1(NKR),FF1(NKR),PSI1(NKR) &
+     &           ,B11_MY(NKR),B12_MY(NKR)
+
+! CRYSTALS
+                                                                       
+	REAL R2(NKR,ICEMAX) &
+     &           ,RIEC(NKR,ICEMAX) &
+     &           ,RO2BL(NKR,ICEMAX) &
+     &           ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
+     &           ,FF2(NKR,ICEMAX) &
+     &           ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX) &
+     &           ,RATE2(NKR,ICEMAX),DEL_R2M(NKR,ICEMAX)
+
+! SNOW                                                                          
+        REAL R3(NKR) &
+     &           ,RSEC(NKR),RO3BL(NKR) &
+     &           ,FI3(NKR),FF3(NKR),PSI3(NKR) &
+     &           ,B31_MY(NKR),B32_MY(NKR) &
+     &           ,DEL_R3M(NKR)  
+
+! GRAUPELS 
+                                                                       
+        REAL R4(NKR),R4N(NKR) &
+     &           ,RGEC(NKR),RO4BL(NKR) &
+     &           ,FI4(NKR),FF4(NKR),PSI4(NKR) &
+     &           ,B41_MY(NKR),B42_MY(NKR) &
+     &           ,DEL_R4M(NKR)
+
+! HAIL                                                                          
+        REAL R5(NKR),R5N(NKR) &
+     &           ,RHEC(NKR),RO5BL(NKR) &
+     &           ,FI5(NKR),FF5(NKR),PSI5(NKR) &
+     &           ,B51_MY(NKR),B52_MY(NKR) &
+     &           ,DEL_R5M(NKR)
+
+      DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
+      DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
+     &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
+     &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
+     &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
+     &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
+     &                  ,ES1N,ES2N,EW1N,ARGEXP &
+     &                  ,TT,QQ,PP,DEL1N0,DEL2N0 &
+     &                  ,DEL1N,DEL2N,DIV1,DIV2 &
+     &                  ,OPER2,OPER3,AR1,AR2
+
+       DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
+
+       REAL A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
+        DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
+     &      /2.53,5.42,3.41E1,6.13/
+       REAL B8L,B8I,SFN11,SFN12,SFNL,SFNI
+       REAL B5L,B5I,B7L,B7I,B6,DOPL,DEL1S,DEL2S,DOPI,RW,QW,PW, &
+     &  RI,PI,QI,SFNI1(ICEMAX),SFNI2(ICEMAX),AL1,AL2
+       REAL D1N,D2N,DT0L, DT0I,D1N0,D2N0
+       REAL SFN21,SFN22,SFNII1,SFNII2,SFN31,SFN32,SFN41,SFN42,SFN51, &
+     &  SFN52
+       REAL DEL1,DEL2
+       REAL  TIMEREV,DT,DTT,TIMENEW
+       REAL DTIMEG(NKR),DTIMEH(NKR)
+
+       REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
+     &           ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR)
+       REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
+     &  DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON
+       REAL DTNEWL0,DTNEWL1,DTNEWI1,DTNEWI2_1,DTNEWI2_2,DTNEWI2_3, &
+     & DTNEWI2,DTNEWI_1,DTNEWI_2,DTNEWI3,DTNEWI4,DTNEWI5, &
+     & DTNEWL,DTNEWL2,DTNEWG1,DTNEWH1
+       REAL TIMESTEPD(NKR)
+
+       DATA AL1 /2500./, AL2 /2834./
+       REAL EPSDEL,EPSDEL2
+       DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/
+       OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
+       OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
+      
+! BELOW
+!
+        DT_WATER_COND=0.4
+        DT_WATER_EVAP=0.4
+        DT_ICE_COND=0.4
+        DT_ICE_EVAP=0.4
+        DT_MIX_COND=0.4
+        DT_MIX_EVAP=0.4
+        DT_MIX_BERGERON=0.4
+        DT_MIX_ANTIBERGERON=0.4
+
+        I_MIXCOND=0
+        I_MIXEVAP=0
+        I_ABERGERON=0
+        I_BERGERON=0
+
+       ITIME = 0
+       TIMENEW=0.
+       DT=DTCOND
+       DTT=DTCOND
+
+       B6=0.
+       B8L=1./ROR
+       B8I=1./ROR
+! NEW CHANGES 19.04.01 (BEGIN)
+        RORI=1.D0/ROR
+! NEW CHANGES 19.04.01 (END)
+! NEW CHANGES 19.04.01 (BEGIN)
+        COL3=3.D0*COL
+! NEW CHANGES 19.04.01 (END)
+
+
+
+! BARRY:DIV
+        TPN=TT
+        QPN=QQ
+! HERE
+   16         ITIME=ITIME+1
+! BARRY
+!             TPC_NEW=TPN-273.15
+              IF((TPN-273.15).GE.-0.187) GO TO 17
+              TIMEREV=DT-TIMENEW
+              DEL1=DEL1N
+              DEL2=DEL2N
+              DEL1S=DEL1N
+              DEL2S=DEL2N
+! NEW ALGORITHM (NO TYPE ICE)
+              DEL2D(1)=DEL2N
+              DEL2D(2)=DEL2N
+              DEL2D(3)=DEL2N
+              TPS=TPN
+              QPS=QPN
+              DO KR=1,NKR
+                 FI1(KR)=PSI1(KR)
+                 FI3(KR)=PSI3(KR)
+                 FI4(KR)=PSI4(KR)
+                 FI5(KR)=PSI5(KR)
+                 DO ICE=1,ICEMAX
+                    FI2(KR,ICE)=PSI2(KR,ICE)
+                 ENDDO
+              ENDDO
+! TIME-STEP GROWTH RATE
+! HERE
+              CALL JERRATE(R1,TPS,PP,ROR,VR1,PSINGLE &
+     &                    ,RLEC,RO1BL,B11_MY,B12_MY,1,1,ICEMAX,NKR)
+              CALL JERRATE(R2,TPS,PP,ROR,VR2,PSINGLE &
+     &                    ,RIEC,RO2BL,B21_MY,B22_MY,3,2,ICEMAX,NKR)
+              CALL JERRATE(R3,TPS,PP,ROR,VR3,PSINGLE &
+     &                    ,RSEC,RO3BL,B31_MY,B32_MY,1,2,ICEMAX,NKR)
+              CALL JERRATE(R4,TPS,PP,ROR,VR4,PSINGLE &
+     &                    ,RGEC,RO4BL,B41_MY,B42_MY,1,2,ICEMAX,NKR)
+              CALL JERRATE(R5,TPS,PP,ROR,VR5,PSINGLE &
+     &                    ,RHEC,RO5BL,B51_MY,B52_MY,1,2,ICEMAX,NKR)
+              CALL JERTIMESC(FI1,R1,SFN11,SFN12 &
+     &                      ,B11_MY,B12_MY,RLEC,B8L,1,COL,NKR)
+              CALL JERTIMESC_ICE(FI2,R2,SFNI1,SFNI2 &
+     &                      ,B21_MY,B22_MY,RIEC,B8I,ICEMAX,COL,NKR)
+              CALL JERTIMESC(FI3,R3,SFN31,SFN32 &
+     &                      ,B31_MY,B32_MY,RSEC,B8I,1,COL,NKR)
+              CALL JERTIMESC(FI4,R4,SFN41,SFN42 &
+     &                      ,B41_MY,B42_MY,RGEC,B8I,1,COL,NKR)
+              CALL JERTIMESC(FI5,R5,SFN51,SFN52 &
+     &                      ,B51_MY,B52_MY,RHEC,B8I,1,COL,NKR)
+! NEW ALGORITHM (NO TYPE ICE)
+              SFNII1=SFNI1(1)+SFNI1(2)+SFNI1(3)
+              SFNII2=SFNI2(1)+SFNI2(2)+SFNI2(3)
+              SFN21=SFNII1+SFN31+SFN41+SFN51
+              SFN22=SFNII2+SFN32+SFN42+SFN52
+              SFNL=SFN11+SFN12
+              SFNI=SFN21+SFN22
+! SOME CONSTANTS (QW,QI=0,since B6=0.)
+              B5L=BB1_MY/TPS/TPS
+              B5I=BB2_MY/TPS/TPS
+              B7L=B5L*B6
+              B7I=B5I*B6
+              DOPL=1.+DEL1S
+              DOPI=1.+DEL2S
+              RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL
+              QW=B7L*DOPL
+              PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
+              RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
+              PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
+              QI=B7I*DOPI
+! SOLVING FOR TIMEZERO
+              CALL JERSUPSAT(DEL1,DEL2,DEL1N0,DEL2N0 &
+     &                      ,RW,PW,RI,PI,QW,QI &
+     &                      ,DTT,D1N0,D2N0,DT0L,DT0I)
+! DEL1 > 0, DEL2 < 0    (ANTIBERGERON MIXED PHASE - KCOND=50)
+! DEL1 < 0 AND DEL2 < 0 (EVAPORATION MIXED_PHASE - KCOND=30)
+! DEL1 > 0 AND DEL2 > 0 (CONDENSATION MIXED PHASE - KCOND=31)
+! DEL1 < 0, DEL2 > 0    (BERGERON MIXED PHASE - KCOND=32)
+              KCOND=50
+
+              IF(DEL1.LT.0.AND.DEL2.LT.0) KCOND=30
+              IF(DEL1.GT.0.AND.DEL2.GT.0) KCOND=31
+              IF(DEL1.LT.0.AND.DEL2.GT.0) KCOND=32
+              IF(KCOND.EQ.50) THEN 
+                I_ABERGERON=I_ABERGERON+1
+                IF(DT0L.EQ.0) THEN
+                  DTNEWL=DT
+                ELSE
+                  DTNEWL=AMIN1(DT,DT0L)
+                ENDIF
+! NEW TIME STEP (ANTIBERGERON MIXED PHASE)
+                IF(DTNEWL.GT.DT) DTNEWL=DT
+                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+                TIMENEW=TIMENEW+DTNEWL
+                DTT=DTNEWL
+                IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
+                ENDIF
+                TIMESTEPD(ITIME)=DTNEWL
+! ANTIBERGERON MIXED PHASE (BEGIN)
+! IN CASE : KCOND = 50
+              ENDIF
+              IF(KCOND.EQ.31) THEN
+! CONDENSATION MIXED PHASE (BEGIN)
+! CONTROL OF TIMESTEP ITERATIONS
+                I_MIXCOND=I_MIXCOND+1
+               IF (DEL1N.EQ.0)THEN
+                DTNEWL0=DT
+               ELSE
+                DTNEWL0=ABS(R1(ITIME)/(B11_MY(ITIME)*DEL1N- &
+     &                                 B12_MY(ITIME)))
+               END IF
+! NEW ALGORITHM (NO TYPE OF ICE)
+
+               IF (DEL2N.EQ.0)THEN
+                DTNEWI2_1=DT
+                DTNEWI2_2=DT
+                DTNEWI2_3=DT
+                DTNEWI3=DT
+                DTNEWI4=DT
+                DTNEWI5=DT
+               ELSE
+                DTNEWI2_1=ABS(R2(ITIME,1)/ &
+     &         (B21_MY(ITIME,1)*DEL2N-B22_MY(ITIME,1)))
+                DTNEWI2_2=ABS(R2(ITIME,2)/ &
+     &         (B21_MY(ITIME,2)*DEL2N-B22_MY(ITIME,2))) 
+                DTNEWI2_3=ABS(R2(ITIME,3)/ &
+     &         (B21_MY(ITIME,3)*DEL2N-B22_MY(ITIME,3)))  
+                DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
+
+                DTNEWI3=ABS(R3(ITIME)/(B31_MY(ITIME)*DEL2N- &
+     &                                 B32_MY(ITIME)))
+                DTNEWI4=ABS(R4(ITIME)/(B41_MY(ITIME)*DEL2N- &
+     &                                 B42_MY(ITIME)))
+                DTNEWI5=ABS(R5(ITIME)/(B51_MY(ITIME)*DEL2N- &
+     &                                 B52_MY(ITIME)))
+               END IF
+                DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I)
+                IF(DT0L.NE.0) THEN
+                  IF(ABS(DT0L).LT.DT_MIX_COND) THEN
+                    DTNEWL1=AMIN1(DT_MIX_COND,DTNEWL0)
+                  ELSE
+                    DTNEWL1=AMIN1(DT0L,DTNEWL0)
+                  ENDIF
+                ELSE
+                  DTNEWL1=DTNEWL0
+                ENDIF
+                DTNEWL=AMIN1(DTNEWL1,DTNEWI1)
+                IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
+                ENDIF
+                TIMESTEPD(ITIME)=DTNEWL
+! NEW TIME STEP (CONDENSATION MIXED PHASE)
+                IF(DTNEWL.GT.DT) DTNEWL=DT
+                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+                TIMENEW=TIMENEW+DTNEWL
+                TIMESTEPD(ITIME)=DTNEWL
+                DTT=DTNEWL
+! CONDENSATION MIXED PHASE (END)
+! IN CASE : KCOND = 31
+              ENDIF
+              IF(KCOND.EQ.30) THEN
+! EVAPORATION MIXED PHASE (BEGIN)
+! CONTROL OF TIMESTEP ITERATIONS
+                I_MIXEVAP=I_MIXEVAP+1
+                DO KR=1,NKR
+                   DTIMEL(KR)=0.
+                   DTIMEG(KR)=0.
+                   DTIMEH(KR)=0.
+! NEW ALGORITHM (NO TYPE ICE)
+                   DTIMEI_1(KR)=0.
+                   DTIMEI_2(KR)=0.
+                   DTIMEI_3(KR)=0.
+                ENDDO
+                DO KR=1,NKR
+                 IF (DEL1N.EQ.0) THEN
+                   DTIMEL(KR)=DT
+                   DTIMEG(KR)=DT
+                   DTIMEH(KR)=DT
+                 ELSE
+                   DTIMEL(KR)=-R1(KR)/(B11_MY(KR)*DEL1N- &
+     &                                 B12_MY(KR))
+                   DTIMEG(KR)=-R4(KR)/(B41_MY(KR)*DEL1N- &
+     &                                 B42_MY(KR))
+                   DTIMEH(KR)=-R5(KR)/(B51_MY(KR)*DEL1N- &
+     &                             B52_MY(KR))
+! NEW ALGORITHM (NO TYPE OF ICE)
+                 END IF
+                 IF (DEL2N.EQ.0) THEN
+                   DTIMEI_1(KR)=DT
+                   DTIMEI_2(KR)=DT
+                   DTIMEI_3(KR)=DT
+                 ELSE
+                   DTIMEI_1(KR)=-R2(KR,1)/ &
+     &               (B21_MY(KR,1)*DEL2N-B22_MY(KR,1))
+                   DTIMEI_2(KR)=-R2(KR,2)/ &
+     &               (B21_MY(KR,2)*DEL2N-B22_MY(KR,2))
+                   DTIMEI_3(KR)=-R2(KR,3)/ &
+     &               (B21_MY(KR,3)*DEL2N-B22_MY(KR,3))
+                 END IF
+                ENDDO
+! WATER
+                KLIMITL=1
+                DO KR=1,NKR
+                   IF(DTIMEL(KR).GT.TIMEREV) GOTO 355
+                   KLIMITL=KR
+                ENDDO
+  355           KLIMITL=KLIMITL-1
+                IF(KLIMITL.LT.1) KLIMITL=1
+                DTNEWL1=AMIN1(DTIMEL(KLIMITL),DT0L,TIMEREV)
+! GRAUPELS
+                KLIMITG=1
+                DO KR=1,NKR
+                   IF(DTIMEG(KR).GT.TIMEREV) GOTO 455
+                   KLIMITG=KR
+                ENDDO
+  455           KLIMITG=KLIMITG-1
+                IF(KLIMITG.LT.1) KLIMITG=1
+                DTNEWG1=AMIN1(DTIMEG(KLIMITG),TIMEREV)
+! HAIL
+                KLIMITH=1
+                DO KR=1,NKR
+                   IF(DTIMEH(KR).GT.TIMEREV) GOTO 555
+                   KLIMITH=KR
+                ENDDO
+  555           KLIMITH=KLIMITH-1
+                IF(KLIMITH.LT.1) KLIMITH=1
+                DTNEWH1=AMIN1(DTIMEH(KLIMITH),TIMEREV)
+! ICE CRYSTALS
+! NEW ALGORITHM (NO TYPE OF ICE) (BEGIN)
+                KLIMITI_1=1
+                KLIMITI_2=1
+                KLIMITI_3=1
+                DO KR=1,NKR
+                   IF(DTIMEI_1(KR).GT.TIMEREV) GOTO 655
+                   KLIMITI_1=KR
+                ENDDO
+  655           CONTINUE
+                DO KR=1,NKR
+                   IF(DTIMEI_2(KR).GT.TIMEREV) GOTO 656
+                   KLIMITI_2=KR
+                ENDDO
+  656           CONTINUE
+                DO KR=1,NKR
+                   IF(DTIMEI_3(KR).GT.TIMEREV) GOTO 657
+                   KLIMITI_3=KR
+                ENDDO
+  657           CONTINUE
+                KLIMITI_1=KLIMITI_1-1
+                IF(KLIMITI_1.LT.1) KLIMITI_1=1
+                DTNEWI2_1=AMIN1(DTIMEI_1(KLIMITI_1),TIMEREV)
+                KLIMITI_2=KLIMITI_2-1
+                IF(KLIMITI_2.LT.1) KLIMITI_2=1
+                DTNEWI2_2=AMIN1(DTIMEI_2(KLIMITI_2),TIMEREV)
+                KLIMITI_3=KLIMITI_3-1
+                IF(KLIMITI_3.LT.1) KLIMITI_3=1
+                DTNEWI2_3=AMIN1(DTIMEI_3(KLIMITI_3),TIMEREV)
+                DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
+! NEW ALGORITHM (NO TYPE OF ICE) (END)
+                DTNEWI1=AMIN1(DTNEWI2,DTNEWG1,DTNEWH1,DT0I)
+                IF(ABS(DEL2N).LT.EPSDEL2) &
+     &          DTNEWI1=AMIN1(DTNEWI2,DTNEWG1,DTNEWH1)
+                DTNEWL2=AMIN1(DTNEWL1,DTNEWI1)
+                DTNEWL=DTNEWL2
+                IF(DTNEWL.LT.DT_MIX_EVAP) &
+     &          DTNEWL=AMIN1(DT_MIX_EVAP,TIMEREV)  
+                IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_fast_sbm (ITIME.GE.NKR), model stop")
+                ENDIF
+                TIMESTEPD(ITIME)=DTNEWL
+! NEW TIME STEP (EVAPORATION MIXED PHASE)
+                IF(DTNEWL.GT.DT) DTNEWL=DT
+                IF((TIMENEW+DTNEWL).GT.DT &
+     &         .AND.ITIME.LT.(NKR-1)) &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+                TIMESTEPD(ITIME)=DTNEWL
+                TIMENEW=TIMENEW+DTNEWL
+                DTT=DTNEWL
+! EVAPORATION MIXED PHASE (END)
+! IN CASE : KCOND = 30
+              ENDIF
+              IF(KCOND.EQ.32) THEN
+! BERGERON MIXED PHASE (BEGIN)
+! CONTROL OF TIMESTEP ITERATIONS
+                I_BERGERON=I_BERGERON+1
+! NEW TREATMENT OF TIME STEP (BERGERON MIXED PHASE)
+               IF (DEL1N.EQ.0)THEN
+                DTNEWL0=DT
+               ELSE
+                DTNEWL0=-R1(1)/(B11_MY(1)*DEL1N-B12_MY(1))
+               END IF
+! NEW ALGORITHM (NO TYPE ICE)
+               IF (DEL2N.EQ.0)THEN
+                DTNEWI2_1=DT
+                DTNEWI2_2=DT
+                DTNEWI2_3=DT
+               ELSE
+                DTNEWI2_1=R2(1,1)/(B21_MY(1,1)*DEL2N-B22_MY(1,1))
+                DTNEWI2_2=R2(1,2)/(B21_MY(1,2)*DEL2N-B22_MY(1,2))
+                DTNEWI2_3=R2(1,3)/(B21_MY(1,3)*DEL2N-B22_MY(1,3))
+               END IF
+               DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
+               IF (DEL2N.EQ.0)THEN
+                DTNEWI3=DT
+                DTNEWI4=DT
+                DTNEWI5=DT
+               ELSE
+                DTNEWI3=R3(1)/(B31_MY(1)*DEL2N-B32_MY(1))
+                DTNEWI4=R4(1)/(B41_MY(1)*DEL2N-B42_MY(1))
+                DTNEWI5=R5(1)/(B51_MY(1)*DEL2N-B52_MY(1))
+               END IF
+                DTNEWL1=AMIN1(DTNEWL0,DT0L,TIMEREV)
+                DTNEWI1=AMIN1(DTNEWI2,DTNEWI3,DTNEWI4 &
+     &                       ,DTNEWI5,DT0I,TIMEREV)
+                DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I,TIMEREV)
+                DTNEWL=AMIN1(DTNEWL1,DTNEWI1)
+! NEW CHANGES 23.04.01 (BEGIN)
+                IF(DTNEWL.LT.DT_MIX_BERGERON) &
+     &          DTNEWL=AMIN1(DT_MIX_BERGERON,TIMEREV)
+                TIMESTEPD(ITIME)=DTNEWL
+! NEW TIME STEP (BERGERON MIXED PHASE)
+                IF(DTNEWL.GT.DT) DTNEWL=DT
+                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+                TIMESTEPD(ITIME)=DTNEWL
+                TIMENEW=TIMENEW+DTNEWL
+                DTT=DTNEWL
+! BERGERON MIXED PHASE (END)
+! IN CASE : KCOND = 32
+              ENDIF
+! SOLVING FOR SUPERSATURATION 
+! CALL JERSUPSAT - 7 (MIXED_PHASE)
+         
+	      CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                      ,RW,PW,RI,PI,QW,QI &
+     &                      ,DTT,D1N,D2N,DT0L,DT0I)
+! END OF "NEW SUPERSATURATION" 
+
+! DROPLETS 
+	      IF(ISYM1.NE.0) THEN
+
+! DROPLET DISTRIBUTION FUNCTION 
+
+                                                         
+! CALL JERDFUN - 3
+	        CALL JERDFUN(R1,B11_MY,B12_MY &
+     &                      ,FI1,PSI1,D1N &
+     &                      ,1,1,COL,NKR,TPN)
+! END OF "DROPLET DISTRIBUTION FUNCTION" 
+ 
+! IN CASE ISYM1.NE.0
+
+ 	      ENDIF                     
+! CRYSTALS 
+	      IF(ISYM2.NE.0) THEN
+
+! CRYSTAL DISTRIBUTION FUNCTION 
+ 
+	        CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                      ,FI2,PSI2,D2N &
+     &                      ,ICEMAX,1,COL,NKR,TPN)
+
+	        CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                      ,FI2,PSI2,D2N &
+     &                      ,ICEMAX,2,COL,NKR,TPN)
+
+	        CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                      ,FI2,PSI2,D2N &
+     &                      ,ICEMAX,3,COL,NKR,TPN)
+! IN CASE ISYM2.NE.0
+
+	      ENDIF
+! SNOW 
+	      IF(ISYM3.NE.0) THEN
+
+! SNOW DISTRIBUTION FUNCTION 
+                                                         
+
+! CALL JERDFUN - SNOW - 3
+
+ 	        CALL JERDFUN(R3,B31_MY,B32_MY &
+     &                      ,FI3,PSI3,D2N &
+     &                      ,1,3,COL,NKR,TPN)
+
+
+! IN CASE ISYM3.NE.0
+
+  	      ENDIF
+
+! GRAUPELS 
+
+	      IF(ISYM4.NE.0) THEN
+
+! GRAUPEL DISTRIBUTION FUNCTION
+                                                         
+	        CALL JERDFUN(R4,B41_MY,B42_MY &
+     &                      ,FI4,PSI4,D2N &
+     &                      ,1,4,COL,NKR,TPN)
+! IN CASE ISYM4.NE.0
+
+	      ENDIF
+! HAIL 
+	      IF(ISYM5.NE.0) THEN
+
+! HAIL DISTRIBUTION FUNCTION 
+                                                         
+	        CALL JERDFUN(R5,B51_MY,B52_MY &
+     &                      ,FI5,PSI5,D2N &
+     &                      ,1,5,COL,NKR,TPN)
+! IN CASE ISYM5.NE.0
+
+	      ENDIF
+! MASSES
+              RMASSLBB=0.D0
+              RMASSIBB=0.D0
+              RMASSLAA=0.D0
+              RMASSIAA=0.D0
+! BEFORE JERNEWF
+              DO K=1,NKR
+                 FI1_K=FI1(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLBB=RMASSLBB+FI1R1
+                 DO ICE =1,ICEMAX
+                    FI2_K=FI2(K,ICE)
+                    R2_K=R2(K,ICE)
+                    FI2R2=FI2_K*R2_K*R2_K
+                    RMASSIBB=RMASSIBB+FI2R2
+                 ENDDO
+                 FI3_K=FI3(K)
+                 FI4_K=FI4(K)
+                 FI5_K=FI5(K)
+                 R3_K=R3(K)
+                 R4_K=R4(K)
+                 R5_K=R5(K)
+                 FI3R3=FI3_K*R3_K*R3_K
+                 FI4R4=FI4_K*R4_K*R4_K
+                 FI5R5=FI5_K*R5_K*R5_K
+                 RMASSIBB=RMASSIBB+FI3R3
+                 RMASSIBB=RMASSIBB+FI4R4
+                 RMASSIBB=RMASSIBB+FI5R5
+              ENDDO
+              RMASSIBB=RMASSIBB*COL3*RORI
+! NEW CHANGE RMASSIBB
+              IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
+              RMASSLBB=RMASSLBB*COL3*RORI
+! NEW CHANGE RMASSLBB
+              IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
+! AFTER  JERNEWF
+              DO K=1,NKR
+                 FI1_K=PSI1(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLAA=RMASSLAA+FI1R1
+                 DO ICE =1,ICEMAX
+                    FI2(K,ICE)=PSI2(K,ICE)
+                    FI2_K=FI2(K,ICE)
+                    R2_K=R2(K,ICE)
+                    FI2R2=FI2_K*R2_K*R2_K
+                    RMASSIAA=RMASSIAA+FI2R2
+                 ENDDO
+                 FI3_K=PSI3(K)
+                 FI4_K=PSI4(K)
+                 FI5_K=PSI5(K)
+                 R3_K=R3(K)
+                 R4_K=R4(K)
+                 R5_K=R5(K)
+                 FI3R3=FI3_K*R3_K*R3_K
+                 FI4R4=FI4_K*R4_K*R4_K
+                 FI5R5=FI5_K*R5_K*R5_K
+                 RMASSIAA=RMASSIAA+FI3R3
+                 RMASSIAA=RMASSIAA+FI4R4
+                 RMASSIAA=RMASSIAA+FI5R5
+              ENDDO
+              RMASSIAA=RMASSIAA*COL3*RORI
+! NEW CHANGE RMASSIAA
+              IF(RMASSIAA.LE.0.0) RMASSIAA=0.0
+              RMASSLAA=RMASSLAA*COL3*RORI
+! NEW CHANGE RMASSLAA
+              IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
+! NEW TREATMENT OF "T" & "Q"
+              DELMASSL1=RMASSLAA-RMASSLBB
+              DELMASSI1=RMASSIAA-RMASSIBB
+              DELTAQ1=DELMASSL1+DELMASSI1
+!             QPN=QPS-DELTAQ1-CWQ*DTT
+              QPN=QPS-DELTAQ1
+              DAL1=AL1
+              DAL2=AL2
+!             TPN=TPS+DAL1*DELMASSL1+AL2*DELMASSI1-CWQ*DTT
+              TPN=TPS+DAL1*DELMASSL1+DAL2*DELMASSI1
+! SUPERSATURATION
+              ARGEXP=-BB1_MY/TPN
+              ES1N=AA1_MY*DEXP(ARGEXP)
+              ARGEXP=-BB2_MY/TPN
+              ES2N=AA2_MY*DEXP(ARGEXP)
+              EW1N=OPER3(QPN,PP)
+              IF(ES1N.EQ.0)THEN
+               DEL1N=0.5
+               DIV1=1.5
+!              print*,'es1n onecond3 = 0'
+!              stop
+              ELSE
+               DIV1=EW1N/ES1N
+               DEL1N=EW1N/ES1N-1.
+              END IF
+              IF(ES2N.EQ.0)THEN
+               DEL2N=0.5
+               DIV2=1.5
+!              print*,'es2n onecond3 = 0'
+!              stop
+              ELSE
+               DEL2N=EW1N/ES2N-1.
+               DIV2=EW1N/ES2N
+              END IF
+! END OF TIME SPLITTING
+
+! HERE
+
+        IF(TIMENEW.LT.DT) GOTO 16
+17      CONTINUE
+
+        TT=TPN
+        QQ=QPN
+        DO KR=1,NKR
+           FF1(KR)=PSI1(KR)
+           DO ICE=1,ICEMAX
+              FF2(KR,ICE)=PSI2(KR,ICE)
+           ENDDO
+           FF3(KR)=PSI3(KR)
+           FF4(KR)=PSI4(KR)
+           FF5(KR)=PSI5(KR)
+        ENDDO
+
+
+        RETURN                                          
+        END SUBROUTINE ONECOND3
+        SUBROUTINE COAL_BOTT_NEW(FF1R,FF2R,FF3R, &
+     &   FF4R,FF5R,TT,QQ,PP,RHO,dt_coll,TCRIT,TTCOAL)
+       implicit none
+       INTEGER KR,ICE
+       INTEGER icol_drop,icol_snow,icol_graupel,icol_hail, &
+     & icol_column,icol_plate,icol_dendrite,icol_drop_brk
+       double precision  g1(nkr),g2(nkr,icemax),g3(nkr),g4(nkr),g5(nkr)
+       double precision gdumb(JMAX),xl_dumb(0:nkr),g_orig(nkr)
+       double precision g2_1(nkr),g2_2(nkr),g2_3(nkr)
+       real cont_fin_drop,dconc,conc_icempl,deldrop,t_new, &
+     & delt_new,cont_fin_ice,conc_old,conc_new,cont_init_ice, &
+     & cont_init_drop,ALWC
+       REAL    FF1R(NKR),FF2R(NKR,ICEMAX),FF3R(NKR),FF4R(NKR),FF5R(NKR)
+       REAL dt_coll
+       REAL TCRIT,TTCOAL
+       real tt_no_coll
+       parameter (tt_no_coll=273.16)
+
+
+       
+   
+! SHARED
+       INTEGER I,J,IT,NDIV
+       REAL RHO
+       DOUBLE PRECISION break_drop_bef,break_drop_aft,dtbreakup
+       DOUBLE PRECISION break_drop_per
+       DOUBLE PRECISION TT,QQ,PP,prdkrn,prdkrn1
+       parameter (prdkrn1=1.d0)
+!     print*,'tcrit = ',tcrit
+!     print*,'ttcoal = ',ttcoal
+!     print*,'col = ',col
+!     print*,'p1,p2,p3 = ',p1,p2,p3
+!     print*,'icempl,kr_icempl  = ',icempl,kr_icempl
+!     print*,'dt_coll = ',dt_coll
+      icol_drop_brk=0
+      icol_drop=0
+      icol_snow=0
+      icol_graupel=0
+      icol_hail=0
+      icol_column=0
+      icol_plate=0
+      icol_dendrite=0
+
+
+       t_new=tt
+         CALL MISC1(PP,cwll_1000mb,cwll_750mb,cwll_500mb, &
+     &    cwll,nkr)
+! THIS IS FOR BREAKUP
+         DO I=1,NKR
+            DO J=1,NKR
+               CWLL(I,J)=ECOALMASSM(I,J)*CWLL(I,J)
+            ENDDO
+         ENDDO
+!
+! THIS IS FOR TURBULENCE
+        IF (LIQTURB.EQ.1)THEN
+         DO I=1,KRMAX_LL
+           DO J=1,KRMAX_LL
+               CWLL(I,J)=CTURBLL(I,J)*CWLL(I,J)
+           END DO
+         END DO
+        END IF
+         CALL MODKRN(TT,QQ,PP,PRDKRN,TTCOAL)
+        DO 13 KR=1,NKR
+         G1(KR)=FF1R(KR)*3.*XL(KR)*XL(KR)*1.E3
+         G2(KR,1)=FF2R(KR,1)*3*xi(KR,1)*XI(KR,1)*1.e3
+         G2(KR,2)=FF2R(KR,2)*3.*xi(KR,2)*XI(KR,2)*1.e3
+         G2(KR,3)=FF2R(KR,3)*3.*xi(KR,3)*XI(KR,3)*1.e3
+         G3(KR)=FF3R(KR)*3.*xs(kr)*xs(kr)*1.e3
+         G4(KR)=FF4R(KR)*3.*xg(kr)*xg(kr)*1.e3
+         G5(KR)=FF5R(KR)*3.*xh(kr)*xh(kr)*1.e3
+         g2_1(kr)=g2(KR,1)
+         g2_2(KR)=g2(KR,2)
+         g2_3(KR)=g2(KR,3)
+         if(kr.gt.(nkr-jbreak).and.g1(kr).gt.1.e-17)icol_drop_brk=1
+!        icol_drop_brk=0
+         IF (IBREAKUP.NE.1)icol_drop_brk=0 
+         if(g1(kr).gt.1.e-10)icol_drop=1
+         if (tt.le.tt_no_coll)then
+         if(g2_1(kr).gt.1.e-10)icol_column=1
+         if(g2_2(kr).gt.1.e-10)icol_plate=1
+         if(g2_3(kr).gt.1.e-10)icol_dendrite=1
+         if(g3(kr).gt.1.e-10)icol_snow=1
+         if(g4(kr).gt.1.e-10)icol_graupel=1
+         if(g5(kr).gt.1.e-10)icol_hail=1
+         end if
+13     CONTINUE 
+! calculation of initial hydromteors content in g/cm**3 :
+      cont_init_drop=0.
+      cont_init_ice=0.
+      do kr=1,nkr
+         cont_init_drop=cont_init_drop+g1(kr)
+         cont_init_ice=cont_init_ice+g3(kr)+g4(kr)+g5(kr)
+         do ice=1,icemax
+            cont_init_ice=cont_init_ice+g2(kr,ice)
+         enddo
+      enddo
+      cont_init_drop=col*cont_init_drop*1.e-3
+      cont_init_ice=col*cont_init_ice*1.e-3
+! calculation of alwc in g/m**3
+      alwc=cont_init_drop*1.e6
+! calculation interactions :
+! droplets - droplets and droplets - ice :
+! water-water = water
+
+      if (icol_drop.eq.1)then 
+! break-up
+
+       call coll_xxx (G1,CWLL,XL_MG,CHUCM,IMA,NKR)
+! breakup!
+       if(icol_drop_brk.eq.1)then
+       ndiv=1
+10     continue
+       do it = 1,ndiv
+         if (ndiv.gt.10000) call wrf_error_fatal("fatal error in module_mp_fast_sbm (ndiv.gt.10000), model stop")
+         dtbreakup = dt_coll/ndiv
+         if (it.eq.1)then
+!         do kr=1,nkr
+          do kr=1,JMAX
+           gdumb(kr)= g1(kr)*1.D-3
+           xl_dumb(kr)=xl_mg(KR)*1.D-3
+          end do
+          break_drop_bef=0.d0
+!         do kr=1,nkr
+          do kr=1,JMAX
+            break_drop_bef=break_drop_bef+g1(kr)*1.D-3
+          enddo
+         end if
+         call breakup(gdumb,xl_dumb,dtbreakup,brkweight, &
+     &        pkij,qkj,JMAX,jbreak)
+       end do
+       break_drop_aft=0.0d0
+       do kr=1,JMAX
+           break_drop_aft=break_drop_aft+gdumb(kr)
+       enddo
+       break_drop_per=break_drop_aft/break_drop_bef
+       if (break_drop_per.gt.1.001)then
+           ndiv=ndiv*2
+           GO TO 10
+       else
+           do kr=1,JMAX
+            g1(kr)=gdumb(kr)*1.D3
+           end do
+       end if
+       end if
+      end if
+       if (icol_snow.eq.1)then 
+         call coll_xyz (g1,g3,g4,cwls,xl_mg,xs_mg, &
+     &                chucm,ima,prdkrn1,nkr,0)
+         if(alwc.lt.alcr) then
+         call coll_xyx (g3,g1,cwsl,xs_mg,xl_mg, &
+     &                chucm,ima,prdkrn1,nkr,1)
+         endif
+         if(alwc.ge.alcr) then
+!        call coll_xyz (g3,g1,g4,cwsl,xs_mg,xl_mg, &
+!    &                chucm,ima,prdkrn1,nkr,1)
+            call coll_xyxz_h (g3,g1,g4,cwsl,xs_mg,xl_mg, &
+     &                chucm,ima,prdkrn1,nkr,1)
+         endif
+! in case : icolxz_snow.ne.0
+       end if
+! interactions between water and  graupel (begin)
+! water - graupel = graupel (t < tcrit ; xl_mg ge xg_mg)
+! graupel - water = graupel (t < tcrit ; xg_mg > xl_mg)
+! water - graupel = hail (t ge tcrit ; xl_mg ge xg_mg)
+! graupel - water = hail (t ge tcrit ; xg_mg > xl_mg)
+       if (icol_graupel.eq.1)then 
+! water-graupel
+! included kp_bound = 25
+!!         call coll_xyyz_h (g1,g4,g5,cwlg,xl_mg,xg_mg, &
+!!     &                chucm,ima,prdkrn1,nkr,1)
+! for ice multiplication
+          conc_old=0.
+          conc_new=0.
+          do kr=kr_icempl,nkr
+               conc_old=conc_old+col*g1(kr)/xl_mg(kr)
+          enddo
+! graupel-water
+!          if(alwc.lt.alcr_g) then
+! water-graupel
+! TEST
+            call coll_xyy (g1,g4,cwlg,xl_mg,xg_mg, &
+     &               chucm,ima,prdkrn1,nkr,0)
+            call coll_xyx (g4,g1,cwgl,xg_mg,xl_mg, &
+     &          chucm,ima,prdkrn1,nkr,1)
+! TEST
+!          else
+!!          call coll_xyxz_h (g4,g1,g5,cwgl,xg_mg,xl_mg, &
+!!   &                chucm,ima,prdkrn1,nkr,1)
+!          end if
+! interactions between water and  graupels (end)
+
+         if(icempl.eq.1) then
+          if(tt.ge.265.15.and.tt.le.tcrit) then
+! ice-multiplication :
+            do kr=kr_icempl,nkr
+               conc_new=conc_new+col*g1(kr)/xl_mg(kr)
+            enddo
+            dconc=conc_old-conc_new
+            if(tt.le.268.15) then
+              conc_icempl=dconc*4.e-3*(265.15-tt)/(265.15-268.15)
+            endif
+            if(tt.gt.268.15) then
+             conc_icempl=dconc*4.e-3*(tcrit-tt)/(tcrit-268.15)
+            endif
+!CHANGE FOR FOUR BIN SCHEME           g2_2(1)=g2_2(1)+conc_icempl*xi2_mg(1)/col
+            g3(1)=g3(1)+conc_icempl*xs_mg(1)/col
+! in case t.ge.265.15 :
+          endif
+! in case icempl=1
+         endif
+! interactions between water and  graupels (end)
+! in case icolxz_graup.ne.0
+       endif
+! water - hail = hail (xl_mg ge xh_mg)                      (kxyy=2)
+! hail - water = hail (xh_mg > xl_mg)                       (kxyx=3)
+!      if(icol_hail.eq.1) then
+!       call coll_xyy (g1,g5,cwlh,xl_mg,xh_mg, &
+!    &               chucm,ima,prdkrn1,nkr,0)
+!       call coll_xyx (g5,g1,cwhl,xh_mg,xl_mg, &
+!    &               chucm,ima,prdkrn1,nkr,1)
+! in case icolxz_hail.ne.0
+!      endif
+! interactions between water and hail (end)
+! interactions between water and crystals :
+! interactions between water and columns :
+! water - columns = graupel (t < tcrit ; xl_mg ge xi_mg)    (kxyz=6)
+! water - columns = hail (t ge tcrit ; xl_mg ge xi_mg)      (kxyz=7)
+! columns - water = columns/graupel (xi_mg > xl_mg)             (kxyx=4); kxyxz=2)
+! now: columns - water = columns (xi_mg > xl_mg)             (kxyx=4); kxyxz=2)
+!      if(icol_column.eq.1) then
+!       if(tt.lt.tcrit) then
+!        call coll_xyz (g1,g2_1,g4,cwli_1,xl_mg,xi1_mg, &
+!    &                 chucm,ima,prdkrn,nkr,0)
+!       endif
+!       if(tt.ge.tcrit) then
+!        call coll_xyz (g1,g2_1,g5,cwli_1,xl_mg,xi1_mg, &
+!    &                 chucm,ima,prdkrn,nkr,0)
+!       endif
+!       call coll_xyxz (g2_1,g1,g4,cwil_1,xi1_mg,xl_mg, &
+!    &                 chucm,ima,prdkrn,nkr,1)
+!       call coll_xyx (g2_1,g1,cwil_1,xi1_mg,xl_mg, &
+!    &                 chucm,ima,prdkrn,nkr,1)
+! in case icolxz_column.ne.0
+!      endif
+
+!     if(icolxz_plate.ne.0) then
+! interactions between water and plates :
+! water - plates = graupel (t < tcrit ; xl_mg ge xi2_mg)    (kxyz=8)
+! water - plates = hail (t ge tcrit ; xl_mg ge xi2_mg)      (kxyz=9)
+! plates - water = plates/graupel (xi2_mg > xl_mg)              (kxyx=5; kxyxz=3)
+!now: plates - water = plates (xi2_mg > xl_mg)              (kxyx=5; kxyxz=3)
+!      if(icol_plate.eq.1) then
+!       if(tt.lt.tcrit) then
+!        call coll_xyz (g1,g2_2,g4,cwli_2,xl_mg,xi2_mg, &
+!    &                 chucm,ima,prdkrn,nkr,0)
+!       endif
+!       if(tt.ge.tcrit) then
+!        call coll_xyz (g1,g2_2,g5,cwli_2,xl_mg,xi2_mg, &
+!    &                 chucm,ima,prdkrn,nkr,0)
+!       endif
+!       call coll_xyxz (g2_2,g1,g4,cwil_2,xi2_mg,xl_mg, &
+!    &                 chucm,ima,prdkrn,nkr,1)
+!       call coll_xyx (g2_2,g1,cwil_2,xi2_mg,xl_mg, &
+!    &                 chucm,ima,prdkrn,nkr,1)
+! in case icolxz_plate.ne.0
+!      endif
+
+! interactions between water and dendrites :
+! water - dendrites = graupel (t < tcrit ; xl_mg ge xi3_mg) (kxyz=10)
+! water - dendrites = hail (t ge tcrit ; xl_mg ge xi3_mg)   (kxyz=11)
+! dendrites - water = dendrites/graupel (xi3_mg > xl_mg)         (kxyx=6; kxyxz=4)
+!now dendrites - water = dendrites (xi3_mg > xl_mg)         (kxyx=6; kxyxz=4)
+!      if(icol_dendrite.eq.1) then
+!       if(tt.lt.tcrit) then
+!        call coll_xyz (g1,g2_3,g4,cwli_3,xl_mg,xi3_mg, &
+!    &                 chucm,ima,prdkrn,nkr,0)
+!       endif
+!       if(tt.ge.tcrit) then
+!        call coll_xyz (g1,g2_3,g5,cwli_3,xl_mg,xi3_mg, &
+!    &                 chucm,ima,prdkrn,nkr,0)
+!       endif
+!       call coll_xyxz (g2_3,g1,g4,cwil_3,xi3_mg,xl_mg, &
+!    &                 chucm,ima,prdkrn,nkr,1)
+!       call coll_xyx (g2_3,g1,cwil_3,xi3_mg,xl_mg, &
+!    &                 chucm,ima,prdkrn,nkr,1)
+! in case icolxz_dendr.ne.0
+!      endif
+! interactions between water and dendrites (end)
+! in case icolxz_drop.ne.0
+!     endif
+! interactions between water and crystals (end)
+
+! interactions between crystals :
+! if(t.le.TTCOAL) - no interactions between crystals
+!     if(tt.gt.TTCOAL) then
+! interactions between columns and other particles (begin)
+!      if(icol_column.eq.1) then
+! columns - columns = snow
+!       call coll_xxy (g2_1,g3,cwii_1_1,xi1_mg, &
+!    &                 chucm,ima,prdkrn,nkr)
+! interactions between columns and plates :
+! columns - plates = snow (xi1_mg ge xi2_mg)                (kxyz=12)
+! plates - columns = snow (xi2_mg > xi1_mg)                 (kxyz=13)
+!       if(icol_plate.eq.1) then     
+!        call coll_xyz (g2_1,g2_2,g3,cwii_1_2,xi1_mg,xi2_mg, &
+!    &                 chucm,ima,prdkrn,nkr,0)
+!        call coll_xyz (g2_2,g2_1,g3,cwii_2_1,xi2_mg,xi1_mg, &
+!    &                 chucm,ima,prdkrn,nkr,1)
+!       end if
+! interactions between columns and dendrites :
+! columns - dendrites = snow (xi1_mg ge xi3_mg)             (kxyz=14)
+! dendrites - columns = snow (xi3_mg > xi1_mg)              (kxyz=15)
+!       if(icol_dendrite.eq.1) then
+!          call coll_xyz (g2_1,g2_3,g3,cwii_1_3,xi1_mg,xi3_mg, &
+!    &                 chucm,ima,prdkrn,nkr,0)
+!          call coll_xyz (g2_3,g2_1,g3,cwii_3_1,xi3_mg,xi1_mg, &
+!    &                 chucm,ima,prdkrn,nkr,1)
+!       end if
+! interactions between columns and snow :
+! columns - snow = snow (xi1_mg ge xs_mg)                   (kxyy=3)
+! snow - columns = snow (xs_mg > xi1_mg)                    (kxyx=7)
+! ALEX?
+!       if(icol_snow.eq.1) then
+!B       call coll_xyy (g2_1,g3,cwis_1,xi1_mg,xs_mg,
+!B   1                 chucm,ima,prdkrn,nkr,0)
+!!        call coll_xyx (g3,g2_1,cwsi_1,xs_mg,xi1_mg, &
+!!    &                 chucm,ima,prdkrn,nkr,1)
+!       endif          
+! in case icolxz_column.ne.0
+!      endif
+! interactions between columns and other particles (end)
+! interactions between plates and other particles (begin)
+! plates - plates = snow
+!      if(icol_plate.eq.1) then
+!       call coll_xxy (g2_2,g3,cwii_2_2,xi2_mg, &
+!    &                 chucm,ima,prdkrn,nkr)
+! interactions between plates and dendrites :
+! plates - dendrites = snow (xi2_mg ge xi3_mg)              (kxyz=17)
+! dendrites - plates = snow (xi3_mg > xi2_mg)               (kxyz=18)
+!       if(icol_dendrite.eq.1) then
+!        call coll_xyz (g2_2,g2_3,g3,cwii_2_3,xi2_mg,xi3_mg, &
+!    &                 chucm,ima,prdkrn,nkr,0)
+!        call coll_xyz (g2_3,g2_2,g3,cwii_3_2,xi3_mg,xi2_mg, &
+!    &                 chucm,ima,prdkrn,nkr,1)
+!       end if
+! interactions between plates and snow :
+! plates - snow = snow (xi2_mg ge xs_mg)                    (kxyy=4)
+! snow - plates = snow (xs_mg > xi2_mg)                     (kxyx=12)
+!       if(icol_snow.eq.1) then
+! ALEX
+!B       call coll_xyy (g2_2,g3,cwis_2,xi2_mg,xs_mg,
+!B   1                 chucm,ima,prdkrn,nkr,0)
+!!        call coll_xyx (g3,g2_2,cwsi_2,xs_mg,xi2_mg, &
+!!     &                 chucm,ima,prdkrn,nkr,1)
+!        end if
+! in case icolxz_plate.ne.0
+!      endif
+! interactions between plates and others particles (end)
+! interactions between dendrites and other hydrometeors (begin)
+! dendrites - dendrites = snow
+!      if(icol_dendrite.eq.1) then
+!!       call coll_xxy (g2_3,g3,cwii_3_3,xi3_mg, &
+!!    &                  chucm,ima,prdkrn,nkr)
+! interactions between dendrites and snow :
+! dendrites - snow = snow (xi3_mg ge xs_mg)                 (kxyy=5)
+! snow - dendrites = snow (xs_mg > xi3_mg)                  (kxyx=17)
+!       if(icol_snow.eq.1) then
+! ALEX
+!B       call coll_xyy (g2_3,g3,cwis_3,xi3_mg,xs_mg,
+!B   1                 chucm,ima,prdkrn,nkr,0)
+!!        call coll_xyx (g3,g2_3,cwsi_3,xs_mg,xi3_mg, &
+!!   &                 chucm,ima,prdkrn,nkr,1)
+!       end if
+! in case icolxz_dendr.ne.0
+!      endif
+! interactions between dendrites and other hydrometeors (end)
+! interactions between snowflakes and other hydromteors (begin)
+!       if(icol_snow.ne.0) then
+! interactions between snowflakes
+! snow - snow = snow
+         call coll_xxx_prd (g3,cwss,xs_mg,chucm,ima,prdkrn,nkr)
+! interactions between snowflakes and graupels :
+! snow - graupel = snow (xs_mg > xg_mg)                     (kxyx=22)
+! graupel - snow = graupel (xg_mg ge xs_mg)                 (kxyx=23)
+!        if(icol_graupel.eq.1) then
+!!         call coll_xyx (g3,g4,cwsg,xs_mg,xg_mg, &
+!!   &                chucm,ima,prdkrn,nkr,1)
+! in case icolxz_graup.ne.0
+!        endif
+! in case icolxz_snow.ne.0
+!       endif
+! interactions between snowflakes and other hydromteors (end)
+! in case : t > TTCOAL
+!     endif
+! in case : t > TTCOAL or t.le.TTCOAL
+! calculation of finish hydrometeors contents in g/cm**3 :
+      cont_fin_drop=0.
+      cont_fin_ice=0.
+      do kr=1,nkr
+!        g2(kr,1)=g2_1(kr)
+!        g2(kr,2)=g2_2(kr)
+!        g2(kr,3)=g2_3(kr)
+         cont_fin_drop=cont_fin_drop+g1(kr)
+!        cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)+g5(kr)
+         cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)
+!        do ice=1,icemax
+!           cont_fin_ice=cont_fin_ice+g2(kr,ice)
+!        enddo
+      enddo
+      cont_fin_drop=col*cont_fin_drop*1.e-3
+      cont_fin_ice=col*cont_fin_ice*1.e-3
+      deldrop=cont_init_drop-cont_fin_drop
+! deldrop in g/cm**3
+! resulted value of temperature (rob in g/cm**3) :
+      if(t_new.le.273.15) then
+        if(deldrop.ge.0.) then
+          t_new=t_new+320.*deldrop/rho
+        else
+! if deldrop < 0
+          if(abs(deldrop).gt.cont_init_drop*0.05) then
+            call wrf_error_fatal("fatal error in module_mp_fast_sbm, abs(deldrop).gt.cont_init_drop, model stop")
+          endif
+        endif
+       endif
+
+61    continue
+! recalculation of density function f1,f2,f3,f4,f5 in 1/(g*cm**3) :  
+        DO 15 KR=1,NKR
+         FF1R(KR)=G1(KR)/(3.*XL(KR)*XL(KR)*1.E3)
+!        FF2R(KR,1)=G2(KR,1)/(3*xi(KR,1)*XI(KR,1)*1.e3)
+!        FF2R(KR,2)=G2(KR,2)/(3.*xi(KR,2)*XI(KR,2)*1.e3)
+!        FF2R(KR,3)=G2(KR,3)/(3.*xi(KR,3)*XI(KR,3)*1.e3)
+         FF3R(KR)=G3(KR)/(3.*xs(kr)*xs(kr)*1.e3)
+         FF4R(KR)=G4(KR)/(3.*xg(kr)*xg(kr)*1.e3)
+!        FF5R(KR)=G5(KR)/(3.*xh(kr)*xh(kr)*1.e3)
+15     CONTINUE 
+      tt=t_new
+      RETURN
+      END SUBROUTINE COAL_BOTT_NEW
+
+      SUBROUTINE MISC1(PP,cwll_1000mb,cwll_750mb,cwll_500mb, &
+     &      cwll,nkr)
+      IMPLICIT NONE
+      INTEGER kr1,kr2,NKR
+      DOUBLE PRECISION PP
+      REAL P_Z
+      double precision cwll(nkr,nkr),cwll_1,cwll_2,cwll_3 &
+     &,cwll_1000mb(nkr,nkr),cwll_750mb(nkr,nkr),cwll_500mb(nkr,nkr)
+      P_Z=PP
+              do 12 kr1=1,nkr
+              do 12 kr2=1,nkr
+               cwll_1=cwll_1000mb(kr1,kr2)
+               cwll_2=cwll_750mb(kr1,kr2)
+               cwll_3=cwll_500mb(kr1,kr2)
+               if(p_z.ge.p1) cwll(kr1,kr2)=cwll_1
+               if(p_z.eq.p2) cwll(kr1,kr2)=cwll_2
+               if(p_z.eq.p3) cwll(kr1,kr2)=cwll_3
+               if(p_z.lt.p1.and.p_z.gt.p2) &
+     &         cwll(kr1,kr2)=cwll_2+ &
+     &         (cwll_1-cwll_2)*(p_z-p2)/(p1-p2) 
+               if(p_z.lt.p2.and.p_z.gt.p3) &
+     &         cwll(kr1,kr2)=cwll_3+ &
+     &         (cwll_2-cwll_3)*(p_z-p3)/(p2-p3)
+               if(p_z.lt.p3) cwll(kr1,kr2)=cwll_3
+12            CONTINUE 
+      RETURN
+      END SUBROUTINE  MISC1
+
+        subroutine coll_xxx (g,ckxx,x,chucm,ima,nkr)
+        implicit double precision (a-h,o-z)
+        dimension g(nkr),ckxx(nkr,nkr),x(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+!       gmin=1.d-15
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(g(i).gt.gmin) goto 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(g(i).gt.gmin) goto 2010
+        enddo
+ 2010   continue
+! J. Dudhia gave reasons why this can't be looped with a
+! multiprocessor.
+! BARRY
+!       do i=ix0,ix1
+!          do j=i,ix1
+        do i=ix0,ix1-1
+           do j=i+1,ix1
+
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxx(i,j)*g(i)*g(j)
+              x0=min(x0,g(i)*x(j))
+              if(j.ne.k) then
+                x0=min(x0,g(j)*x(i))
+              endif
+              gsi=x0/x(j)
+              gsj=x0/x(i)
+              gsk=gsi+gsj
+              g(i)=g(i)-gsi
+              if(g(i).lt.0.d0) g(i)=0.d0
+              g(j)=g(j)-gsj
+              gk=g(k)+gsk
+              if(g(j).lt.0.d0.and.gk.lt.gmin) then
+                g(j)=0.d0
+                g(k)=g(k)+gsi
+              endif
+              flux=0.d0
+!
+! BARRY
+              if(gk.gt.gmin) then
+                x1=dlog(g(kp)/gk+1.d-15)
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+
+! new changes 23.01.01 (end)
+                g(k)=gk-flux
+                if(g(k).lt.0.d0) g(k)=0.d0
+                g(kp)=g(kp)+flux
+! in case gk > gmin :
+              endif
+            end do
+        end do
+ 2020   continue
+        return
+        end subroutine coll_xxx
+        subroutine coll_xxx_prd (g,ckxx,x,chucm,ima,prdkrn,nkr)
+        implicit double precision (a-h,o-z)
+        dimension g(nkr),ckxx(nkr,nkr),x(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+! this is character values containes adresses of temporary files      
+        gmin=1.d-60
+!       gmin=1.d-15
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(g(i).gt.gmin) goto 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(g(i).gt.gmin) goto 2010
+        enddo
+ 2010   continue
+! J. Dudhia gave reasons why this can't be looped with a
+! multiprocessor.
+! BARRY
+!       do i=ix0,ix1
+!          do j=i,ix1
+        do i=ix0,ix1-1
+           do j=i+1,ix1
+
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxx(i,j)*g(i)*g(j)*prdkrn
+              x0=min(x0,g(i)*x(j))
+              if(j.ne.k) then
+                x0=min(x0,g(j)*x(i))
+              endif
+              gsi=x0/x(j)
+              gsj=x0/x(i)
+              gsk=gsi+gsj
+              g(i)=g(i)-gsi
+              if(g(i).lt.0.d0) g(i)=0.d0
+              g(j)=g(j)-gsj
+              gk=g(k)+gsk
+              if(g(j).lt.0.d0.and.gk.lt.gmin) then
+                g(j)=0.d0
+                g(k)=g(k)+gsi
+              endif
+              flux=0.d0
+!
+! BARRY
+              if(gk.gt.gmin) then
+                x1=dlog(g(kp)/gk+1.d-15)
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+
+! new changes 23.01.01 (end)
+                g(k)=gk-flux
+                if(g(k).lt.0.d0) g(k)=0.d0
+                g(kp)=g(kp)+flux
+! in case gk > gmin :
+              endif
+            end do
+        end do
+ 2020   continue
+        return
+        end subroutine coll_xxx_prd 
+      subroutine modkrn(TT,QQ,PP,PRDKRN,TTCOAL)
+      implicit none
+      real epsf,tc,ttt1,ttt,factor,qs2,qq1,dele,f,factor_t
+      double precision TT,QQ,PP,satq2,t,p
+      double precision prdkrn
+      REAL at,bt,ct,dt,temp,a,b,c,d,tc_min,tc_max
+       real factor_max,factor_min
+      REAL TTCOAL
+	data at,bt,ct,dt/0.88333,0.0931878,0.0034793,4.5185186e-05/
+        satq2(t,p)=3.80e3*(10**(9.76421-2667.1/t))/p
+        temp(a,b,c,d,tc)=d*tc*tc*tc+c*tc*tc+b*tc+a
+        IF (QQ.LE.0)QQ=1.E-12
+        epsf    =.5
+        tc      =tt-273.15
+        factor=0 ! mchen add temporarily
+        if(tc.le.0) then
+! in case tc.le.0
+          ttt1  =temp(at,bt,ct,dt,tc)
+          ttt   =ttt1
+          qs2   =satq2(tt,pp)
+          qq1   =qq*(0.622+0.378*qs2)/(0.622+0.378*qq)/qs2
+          dele  =ttt*qq1
+! new change 27.06.00
+          if(tc.ge.-6.) then
+            factor = dele
+            if(factor.lt.epsf) factor=epsf
+            if(factor.gt.1.) factor=1.
+! in case : tc.ge.-6.
+          endif                        
+          factor_t=factor
+          if(tc.ge.-12.5.and.tc.lt.-6.) factor_t=0.5
+          if(tc.ge.-17.0.and.tc.lt.-12.5) factor_t=1.
+          if(tc.ge.-20.0.and.tc.lt.-17.) factor_t=0.4
+          if(tc.lt.-20.) then
+            tc_min=ttcoal-273.15
+            tc_max=-20.
+            factor_max=0.25
+            factor_min=0.
+            f=factor_min+(tc-tc_min)*(factor_max-factor_min)/  &
+     &                               (tc_max-tc_min)
+            factor_t=f
+          endif
+! BARRY
+          if (factor_t.lt.0)factor_t=0.01
+          prdkrn=factor_t
+      else
+          prdkrn=1.d0
+      end if
+      RETURN
+      END SUBROUTINE modkrn 
+           
+
+
+        subroutine coll_xxy(gx,gy,ckxx,x,chucm,ima,prdkrn,nkr)
+        implicit double precision (a-h,o-z)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        dimension  &
+     &  gx(nkr),gy(nkr),ckxx(nkr,nkr),x(0:nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) goto 2000
+        enddo
+        if(ix0.eq.nkr-1) goto 2020
+ 2000   continue
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) goto 2010
+        enddo
+ 2010   continue
+! collisions
+        do i=ix0,ix1
+           do j=i,ix1
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxx(i,j)*gx(i)*gx(j)*prdkrn
+              x0=min(x0,gx(i)*x(j))
+              x0=min(x0,gx(j)*x(i))
+              gsi=x0/x(j)
+              gsj=x0/x(i)
+              gsk=gsi+gsj
+              gx(i)=gx(i)-gsi
+              if(gx(i).lt.0.d0) gx(i)=0.d0
+              gx(j)=gx(j)-gsj
+              if(gx(j).lt.0.d0) gx(j)=0.d0
+              gk=gy(k)+gsk
+              flux=0.d0
+! BARRY
+              if(gk.gt.gmin) then
+! new changes 13.01.01 (begin)
+                x1=dlog(gy(kp)/gk+1.d-15)
+! BARRY
+!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+! new changes 23.01.01 (begin)
+!               flux=min(flux,gk)
+!               flux=min(flux,gsk)
+! new changes 23.01.01 (end)
+! new changes 13.01.01 (end)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+                gy(k)=gk-flux
+                if(gy(k).lt.0.d0) gy(k)=0.d0
+                gy(kp)=gy(kp)+flux
+! in case gk > gmin :
+              endif
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xxy
+!====================================================================
+        subroutine coll_xyy(gx,gy,ckxy,x,y,chucm,ima, &
+     &     prdkrn,nkr,indc)
+        implicit double precision (a-h,o-z)
+        dimension  &
+     &  gy(nkr),gx(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) go to 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) go to 2010
+        enddo
+ 2010   continue
+! lower and upper integration limit iy0,iy1
+        do i=1,nkr-1
+           iy0=i
+           if(gy(i).gt.gmin) go to 2001
+        enddo
+ 2001   continue
+        if(iy0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           iy1=i
+           if(gy(i).gt.gmin) go to 2011
+        enddo
+ 2011   continue
+! collisions :
+        do i=iy0,iy1
+           jmin=i
+           if(jmin.eq.(nkr-1)) goto 2020
+           if(i.lt.ix0) jmin=ix0-indc
+	   do j=jmin+indc,ix1         
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
+              x0=min(x0,gy(i)*x(j))
+              x0=min(x0,gx(j)*y(i))
+              gsi=x0/x(j)
+              gsj=x0/y(i)
+              gsk=gsi+gsj
+              gy(i)=gy(i)-gsi
+              if(gy(i).lt.0.d0) gy(i)=0.d0
+              gx(j)=gx(j)-gsj
+              if(gx(j).lt.0.d0) gx(j)=0.d0
+              gk=gy(k)+gsk
+              flux=0.d0
+! BARRY
+              if(gk.gt.gmin) then
+                x1=dlog(gy(kp)/gk+1.d-15)
+! BARRY
+!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+! new changes 23.01.01 (begin)
+!               flux=min(flux,gk)
+!               flux=min(flux,gsk)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+! new changes 23.01.01 (end)
+                gy(k)=gk-flux
+                if(gy(k).lt.0.d0) gy(k)=0.d0
+                gy(kp)=gy(kp)+flux
+! in case gk > gmin :
+              endif
+! in case gk > gmin or gk.le.gmin
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xyy
+!=================================================================
+        subroutine coll_xyx(gx,gy,ckxy,x,y,chucm,ima, &
+     &    prdkrn,nkr,indc)
+        implicit double precision (a-h,o-z)
+        dimension gy(nkr),gx(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) go to 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) go to 2010
+        enddo
+ 2010   continue
+! lower and upper integration limit iy0,iy1
+        do i=1,nkr-1
+           iy0=i
+           if(gy(i).gt.gmin) go to 2001
+        enddo
+ 2001   continue
+        if(iy0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           iy1=i
+           if(gy(i).gt.gmin) go to 2011
+        enddo
+ 2011   continue
+! collisions :
+        do i=iy0,iy1
+           jmin=i
+           if(jmin.eq.(nkr-1)) goto 2020
+           if(i.lt.ix0) jmin=ix0-indc
+	   do j=jmin+indc,ix1
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
+              x0=min(x0,gy(i)*x(j))
+              if(j.ne.k) then
+                x0=min(x0,gx(j)*y(i))
+              endif
+              gsi=x0/x(j)
+              gsj=x0/y(i)
+              gsk=gsi+gsj
+              gy(i)=gy(i)-gsi
+              if(gy(i).lt.0.d0) gy(i)=0.d0
+              gx(j)=gx(j)-gsj
+              gk=gx(k)+gsk
+! BARRY
+!             if(gx(j).lt.0.d0)then
+!                gy(i)=gy(i)+gsi
+!                gx(j)=gx(j)+gsj
+!                go to 10
+!             end if
+              if(gx(j).lt.0.d0.and.gk.lt.gmin) then
+                gx(j)=0.d0
+                gx(k)=gx(k)+gsi
+              endif
+              flux=0.d0            
+! BARRY
+              if(gk.gt.gmin) then
+                x1=dlog(gx(kp)/gk+1.d-15)
+! BARRY
+!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+! new changes 23.01.01 (begin)
+!               flux=min(flux,gk)
+!               flux=min(flux,gsk)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+! new changes 23.01.01 (end)
+                gx(k)=gk-flux
+                if(gx(k).lt.0.d0) gx(k)=0.d0
+                gx(kp)=gx(kp)+flux
+! in case gk > gmin :
+              endif
+! in case gk > gmin or gk.le.gmin
+! BARRY
+10         continue
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xyx
+!=====================================================================
+        subroutine coll_xyxz(gx,gy,gz,ckxy,x,y,chucm,ima, &
+     &    prdkrn,nkr,indc)
+        implicit double precision (a-h,o-z)
+      dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) go to 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) go to 2010
+        enddo
+ 2010   continue
+! lower and upper integration limit iy0,iy1
+        do i=1,nkr-1
+           iy0=i
+           if(gy(i).gt.gmin) go to 2001
+        enddo
+ 2001   continue
+        if(iy0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           iy1=i
+           if(gy(i).gt.gmin) go to 2011
+        enddo
+ 2011   continue
+! collisions :
+        do i=iy0,iy1
+           jmin=i
+           if(jmin.eq.(nkr-1)) goto 2020
+           if(i.lt.ix0) jmin=ix0-indc
+	   do j=jmin+indc,ix1
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
+              x0=min(x0,gy(i)*x(j))
+              if(j.ne.k) then
+                x0=min(x0,gx(j)*y(i))
+              endif
+              gsi=x0/x(j)
+              gsj=x0/y(i)
+              gsk=gsi+gsj
+              gy(i)=gy(i)-gsi
+              if(gy(i).lt.0.d0) gy(i)=0.d0
+              gx(j)=gx(j)-gsj
+              gk=gx(k)+gsk
+              if(gx(j).lt.0.d0.and.gk.lt.gmin) then
+                gx(j)=0.d0
+                gx(k)=gx(k)+gsi
+              endif
+              flux=0.d0
+! BARRY
+              if(kp.lt.17) gkp=gx(kp)
+              if(kp.ge.17) gkp=gz(kp)
+              if(gk.gt.gmin) then
+                x1=dlog(gkp/gk+1.d-15)
+! BARRY
+!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+! new changes 23.01.01 (begin)
+!               flux=min(flux,gk)
+!               flux=min(flux,gsk)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+! new changes 23.01.01 (end)
+                gx(k)=gk-flux
+                if(gx(k).lt.0.d0) gx(k)=0.d0
+                if(kp.lt.17) gx(kp)=gkp+flux
+                if(kp.ge.17) gz(kp)=gkp+flux
+! ALEX 15 11 2005
+!               if(kp.ge.17) gx(kp)=gkp+flux
+! in case gk > gmin :
+              endif
+! in case gk > gmin or gk.le.gmin
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xyxz
+!=====================================================================
+        subroutine coll_xyxz_h(gx,gy,gz,ckxy,x,y,chucm,ima, &
+     &    prdkrn,nkr,indc)
+        implicit double precision (a-h,o-z)
+      dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) go to 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) go to 2010
+        enddo
+ 2010   continue
+! lower and upper integration limit iy0,iy1
+        do i=1,nkr-1
+           iy0=i
+           if(gy(i).gt.gmin) go to 2001
+        enddo
+ 2001   continue
+        if(iy0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           iy1=i
+           if(gy(i).gt.gmin) go to 2011
+        enddo
+ 2011   continue
+! collisions :
+        do i=iy0,iy1
+           jmin=i
+           if(jmin.eq.(nkr-1)) goto 2020
+           if(i.lt.ix0) jmin=ix0-indc
+	   do j=jmin+indc,ix1
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
+              x0=min(x0,gy(i)*x(j))
+              if(j.ne.k) then
+                x0=min(x0,gx(j)*y(i))
+              endif
+              gsi=x0/x(j)
+              gsj=x0/y(i)
+              gsk=gsi+gsj
+              gy(i)=gy(i)-gsi
+              if(gy(i).lt.0.d0) gy(i)=0.d0
+              gx(j)=gx(j)-gsj
+              gk=gx(k)+gsk
+              if(gx(j).lt.0.d0.and.gk.lt.gmin) then
+                gx(j)=0.d0
+                gx(k)=gx(k)+gsi
+              endif
+              flux=0.d0
+! BARRY
+              if(kp.lt.22) gkp=gx(kp)
+              if(kp.ge.22) gkp=gz(kp)
+              if(gk.gt.gmin) then
+                x1=dlog(gkp/gk+1.d-15)
+! BARRY
+!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+! new changes 23.01.01 (begin)
+!               flux=min(flux,gk)
+!               flux=min(flux,gsk)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+! new changes 23.01.01 (end)
+                gx(k)=gk-flux
+                if(gx(k).lt.0.d0) gx(k)=0.d0
+                if(kp.lt.22) gx(kp)=gkp+flux
+                if(kp.ge.22) gz(kp)=gkp+flux
+! ALEX 15 11 2005
+!               if(kp.ge.25) gx(kp)=gkp+flux
+! in case gk > gmin :
+              endif
+! in case gk > gmin or gk.le.gmin
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xyxz_h
+!=====================================================================
+        subroutine coll_xyz(gx,gy,gz,ckxy,x,y,chucm,ima, &
+     &                      prdkrn,nkr,indc)
+        implicit double precision (a-h,o-z)
+      dimension gx(nkr),gy(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) go to 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) go to 2010
+        enddo
+ 2010   continue
+! lower and upper integration limit iy0,iy1
+        do i=1,nkr-1
+           iy0=i
+           if(gy(i).gt.gmin) go to 2001
+        enddo
+ 2001   continue
+        if(iy0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           iy1=i
+           if(gy(i).gt.gmin) go to 2011
+        enddo
+ 2011   continue
+! collisions :
+        do i=iy0,iy1
+           jmin=i
+           if(jmin.eq.(nkr-1)) goto 2020
+           if(i.lt.ix0) jmin=ix0-indc
+	   do j=jmin+indc,ix1         
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
+              x0=min(x0,gy(i)*x(j))
+              x0=min(x0,gx(j)*y(i))
+              gsi=x0/x(j)
+              gsj=x0/y(i)
+              gsk=gsi+gsj
+              gy(i)=gy(i)-gsi
+              if(gy(i).lt.0.d0) gy(i)=0.d0
+              gx(j)=gx(j)-gsj
+              if(gx(j).lt.0.d0) gx(j)=0.d0
+              gk=gz(k)+gsk
+              flux=0.d0
+! BARRY
+              if(gk.gt.gmin) then
+                x1=dlog(gz(kp)/gk+1.d-15)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+! new changes 23.01.01 (end)
+                gz(k)=gk-flux
+                if(gz(k).lt.0.d0) gz(k)=0.d0
+                gz(kp)=gz(kp)+flux
+! in case gk > gmin :
+              endif
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xyz
+!===============================================================
+!****************************************************************
+! SEE /include/microhucm.incl for setting of krdrop and krbreak
+!****************************************************************
+      SUBROUTINE BREAKUP(GT_MG,XT_MG,DT,BRKWEIGHT, &
+     &           PKIJ,QKJ,JMAX,JBREAK)
+!     SUBROUTINE BREAKUP(GT_MG,DT,JMAX,JBREAK)
+!     implicit double precision (a-h,o-z)
+
+!.....INPUT VARIABLES
+!
+!     GT    : MASS DISTRIBUTION FUNCTION
+!     XT_MG : MASS OF BIN IN MG
+!     JMAX  : NUMBER OF BINS
+!     DT    : TIMESTEP IN S
+
+      INTEGER JMAX
+
+!.....LOCAL VARIABLES
+
+      LOGICAL LTHAN
+      INTEGER JBREAK,AP,IA,JA,KA,IE,JE,KE
+      DOUBLE PRECISION EPS,NEGSUM
+
+      PARAMETER (AP = 1)
+      PARAMETER (IA = 1)
+      PARAMETER (JA = 1)
+      PARAMETER (KA = 1)
+      PARAMETER (EPS = 1.D-20)
+
+      INTEGER I,J,K,JJ,JDIFF
+      DOUBLE PRECISION GT_MG(JMAX),XT_MG(0:JMAX),DT
+!     xl_mg(0:nkr)
+      DOUBLE PRECISION BRKWEIGHT(JBREAK),PKIJ(JBREAK,JBREAK,JBREAK), &
+     &    QKJ(JBREAK,JBREAK)
+      DOUBLE PRECISION D0,ALM,HLP(JMAX)
+      DOUBLE PRECISION FT(JMAX),FA(JMAX)
+      DOUBLE PRECISION DG(JMAX),DF(JMAX),DBREAK(JBREAK),GAIN,LOSS
+      REAL PI
+      PARAMETER (PI = 3.1415927)
+      INTEGER IP,KP,JP,KQ,JQ
+      IE = JBREAK
+      JE = JBREAK
+      KE = JBREAK
+
+
+
+
+
+
+
+!.....IN CGS
+
+!     DO J=1,JMAX
+!        XT(J) = XT_MG(J) * 1E-3
+!        GT_MG(J) = GT_MG(J)* 1E-3
+!     ENDDO
+
+!.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID
+
+      JDIFF = JMAX - JBREAK
+!       14  =  33  - 19
+
+!.....INITIALIZATION
+
+!.....TRANSFORMATION FROM G(LN X) = X**2 F(X) TO F(X)
+      DO J=1,JMAX
+         FT(J) = GT_MG(J) / XT_MG(J)**2
+      ENDDO
+
+!.....SHIFT TO BREAKUP GRID
+
+      DO K=1,KE
+         FA(K) = FT(K+JDIFF)
+      ENDDO
+
+!.....BREAKUP: BLECK'S FIRST ORDER METHOD
+!
+!     PKIJ: GAIN COEFFICIENTS
+!     QKJ : LOSS COEFFICIENTS
+!
+
+      DO K=1,KE
+         GAIN = 0.0
+         DO I=1,IE
+            DO J=1,I
+               GAIN = GAIN + FA(I)*FA(J)*PKIJ(K,I,J)
+            ENDDO
+         ENDDO
+         LOSS = 0.0
+         DO J=1,JE
+            LOSS = LOSS + FA(J)*QKJ(K,J)
+         ENDDO
+         DBREAK(K) = BRKWEIGHT(K) * (GAIN - FA(K)*LOSS)
+      ENDDO
+
+!.....SHIFT RATE TO COAGULATION GRID
+
+      DO J=1,JDIFF
+         DF(J) = 0.0
+      ENDDO
+      DO J=1,KE
+         DF(J+JDIFF) = DBREAK(J)
+      ENDDO
+!.....TRANSFORMATION TO MASS DISTRIBUTION FUNCTION G(LN X)
+
+      DO J=1,JMAX
+         DG(J) = DF(J) * XT_MG(J)**2
+      ENDDO
+
+!.....TIME INTEGRATION
+
+      DO J=1,JMAX
+      HLP(J) = 0.0
+      NEGSUM = 0.0
+         GT_MG(J) = GT_MG(J) + DG(J) * DT
+         IF (GT_MG(J).LT.0) THEN
+            HLP(J) = MIN(GT_MG(J),HLP(J))
+            GT_MG(J) = EPS
+!           NEGSUM = NEGSUM+GT_MG(J)
+!           GT_MG(J) = 0.D0
+         ENDIF
+      ENDDO
+!     DO J=1,JMAX
+!      IF (HLP(J).LT.0.) THEN
+!        GT_MG(J-1)=GT_MG(J-1)-NEGSUM -EPS
+!      END IF
+!      GO TO 10
+!     END DO
+!10    CONTINUE
+!     IF (HLP.LT.-1E-7) THEN
+! BARRY
+!     LTHAN=.FALSE.
+!     DO J=1,JMAX
+!      IF (HLP(J).LT.0.OR.LTHAN) THEN
+!        WRITE (*,'(1X,A,E10.4)')
+!    F        'COLL_BREAKUP: WARNING! G(J) < 0, MIN = ' 
+!        IF(HLP(J).LT.0.OR.LTHAN)WRITE(6,*)
+!    F      'J,G(J)  = ',J,HLP(J),GT_MG(J)
+!        LTHAN=.TRUE.  C     ENDIF
+!     END DO
+
+!     DO J=1,JMAX
+!        GT_MG(J) = GT_MG(J) * 1E3
+!     ENDDO
+
+!.....THAT'S IT
+      RETURN
+
+      END SUBROUTINE BREAKUP
+
+      SUBROUTINE BOUNDNUM(MASSMM5,FCONC,RHOX,COL,NZERO, &
+     &       RADXX,MASSXX,HYDROSUM, &
+     &       NKR)
+      IMPLICIT NONE
+     
+      INTEGER NKR,NKRI,KRBEG,KREND,IP,IPCNT
+      REAL NZERO,LAMBDAHYD,MASSMM5,RHOX,HYDROMASS,COL
+      REAL RADXX(NKR),MASSXX(NKR)
+      REAL TERM1,TERM2A,TERM2B,TERM2C
+      REAL FCONC(NKR),HYDROSUM 
+      DOUBLE PRECISION D1,D2,D3,D4,D5,D6,D7A,D7B 
+      DOUBLE PRECISION VAR1,VAR2,VAR3,VAR4,VAR5,VAR6
+!     HYDROMASS IN kg/kg
+!     VAR1=NZERO           
+!     VAR2=RHOX            
+!     VAR3=MASSXX(1,IHYDR)
+!     VAR4=RADXX(1,IHYDR)
+!     VAR5=MASSMM5       
+!     VAR6=(6.*VAR1/VAR2)*VAR3/(8.*VAR4**3)*(1./VAR5)
+!     var6 =sqrt(sqrt(var6))
+!     print*,'radxx(1) = ',RADXX(1)
+!     print*,'rhox = ',rhox
+!     print*,'massmm5 = ',massmm5
+!     print*,'nzero = ',nzerO
+!     print*,'massxx = ',MASSXX(1)
+      LAMBDAHYD=(6.*NZERO/RHOX)*MASSXX(1)/(8.*RADXX(1)**3) &
+     &     *(1./MASSMM5)
+      LAMBDAHYD=SQRT(SQRT(LAMBDAHYD))
+      HYDROSUM  =0
+      TERM1=(NZERO/RHOX)*(MASSXX(1)/(8.*RADXX(1)**3))
+      DO NKRI=1,NKR
+       IF(NKRI.EQ.1)THEN
+        D1=LAMBDAHYD*2.*RADXX(NKRI)
+        D2=0
+       ELSE
+        D1=LAMBDAHYD*2.*RADXX(NKRI)
+        D2=LAMBDAHYD*2.*RADXX(NKRI-1)
+       END IF
+       D3=DEXP(-D1)
+       D4=DEXP(-D2)
+       D5 = (1./LAMBDAHYD**4)
+       D6=TERM1
+       IF (NKRI.EQ.1)THEN
+        D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
+        D7B=-6.*D5
+       ELSE
+        D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
+        D7B= -D5*D4*(D2**3+3.*D2**2+6.*D2+6)
+       END IF
+       HYDROMASS= D6*(D7A-D7B)
+       HYDROSUM=HYDROSUM+HYDROMASS   
+       FCONC(NKRI)=HYDROMASS*RHOX/(COL  &
+     &          *MASSXX(NKRI)*MASSXX(NKRI)*3)
+        IF (HYDROMASS .LT.0)THEN
+        call wrf_error_fatal("fatal error in module_mp_fast_sbm,(HYDROMASS.LT.0) , model stop")
+        END IF
+      END DO
+!     print*, 'massmm5,hydrosum  =',massmm5,hydrosum  
+      IF (HYDROSUM.LT.MASSMM5)THEN
+       D1=LAMBDAHYD*2.*RADXX(NKR)
+       D2=LAMBDAHYD*2.*RADXX(NKR-1)
+       D3=DEXP(-D1)
+       D4=DEXP(-D2)
+       D5 = (1./LAMBDAHYD**4)
+       D6=TERM1
+       D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
+       D7B= -D5*D4*(D2**3+3.*D2**2+6.*D2+6)
+       HYDROMASS= D6*(D7A-D7B)+(MASSMM5-HYDROSUM)
+       FCONC(NKR)=HYDROMASS*RHOX/(COL &
+     &          *MASSXX(NKR)*MASSXX(NKR)*3)
+       HYDROSUM=HYDROSUM+(MASSMM5-HYDROSUM)
+      END IF
+!     print*, 'massmm5,hydrosum adj  =',massmm5,hydrosum  
+      RETURN
+      END SUBROUTINE BOUNDNUM
+
+! from module_mp_morr_two_moment.F
+      subroutine refl10cm_hm (qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, &
+                      t1d, p1d, dBZ, kts, kte, ii, jj)
+
+      IMPLICIT NONE
+
+!..Sub arguments
+      INTEGER, INTENT(IN):: kts, kte, ii, jj
+      REAL, DIMENSION(kts:kte), INTENT(IN)::                            &
+                      qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
+      REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ
+
+!..Local variables
+      REAL, DIMENSION(kts:kte):: temp, pres, qv, rho
+      REAL, DIMENSION(kts:kte):: rr, nr, rs, ns, rg, ng
+
+      DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, ilams
+      DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_g, N0_s
+      DOUBLE PRECISION:: lamr, lamg, lams
+      LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg
+
+      REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel
+      DOUBLE PRECISION:: fmelt_s, fmelt_g
+      DOUBLE PRECISION:: cback, x, eta, f_d
+
+      INTEGER:: i, k, k_0, kbot, n
+      LOGICAL:: melti
+
+!+---+
+
+      do k = kts, kte
+         dBZ(k) = -35.0
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Put column of data into local arrays.
+!+---+-----------------------------------------------------------------+
+      do k = kts, kte
+         temp(k) = t1d(k)
+         qv(k) = MAX(1.E-10, qv1d(k))
+         pres(k) = p1d(k)
+         rho(k) = 0.622*pres(k)/(R_MORR*temp(k)*(qv(k)+0.622))
+
+         if (qr1d(k) .gt. 1.E-9) then
+            rr(k) = qr1d(k)*rho(k)
+            nr(k) = nr1d(k)*rho(k)
+            lamr = (xam_r*xcrg(3)*xorg2*nr(k)/rr(k))**xobmr
+            ilamr(k) = 1./lamr
+            N0_r(k) = nr(k)*xorg2*lamr**xcre(2)
+            L_qr(k) = .true.
+         else
+            rr(k) = 1.E-12
+            nr(k) = 1.E-12
+            L_qr(k) = .false.
+         endif
+
+         if (qs1d(k) .gt. 1.E-9) then
+            rs(k) = qs1d(k)*rho(k)
+            ns(k) = ns1d(k)*rho(k)
+            lams = (xam_s*xcsg(3)*xosg2*ns(k)/rs(k))**xobms
+            ilams(k) = 1./lams
+            N0_s(k) = ns(k)*xosg2*lams**xcse(2)
+            L_qs(k) = .true.
+         else
+            rs(k) = 1.E-12
+            ns(k) = 1.E-12
+            L_qs(k) = .false.
+         endif
+
+         if (qg1d(k) .gt. 1.E-9) then
+            rg(k) = qg1d(k)*rho(k)
+            ng(k) = ng1d(k)*rho(k)
+            lamg = (xam_g*xcgg(3)*xogg2*ng(k)/rg(k))**xobmg
+            ilamg(k) = 1./lamg
+            N0_g(k) = ng(k)*xogg2*lamg**xcge(2)
+            L_qg(k) = .true.
+         else
+            rg(k) = 1.E-12
+            ng(k) = 1.E-12
+            L_qg(k) = .false.
+         endif
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Locate K-level of start of melting (k_0 is level above).
+!+---+-----------------------------------------------------------------+
+      melti = .false.
+      k_0 = kts
+      do k = kte-1, kts, -1
+         if ( (temp(k).gt.273.15) .and. L_qr(k)                         &
+                                  .and. (L_qs(k+1).or.L_qg(k+1)) ) then
+            k_0 = MAX(k+1, k_0)
+            melti=.true.
+            goto 195
+         endif
+      enddo
+ 195  continue
+
+!+---+-----------------------------------------------------------------+
+!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps)
+!.. and non-water-coated snow and graupel when below freezing are
+!.. simple. Integrations of m(D)*m(D)*N(D)*dD.
+!+---+-----------------------------------------------------------------+
+
+      do k = kts, kte
+         ze_rain(k) = 1.e-22
+         ze_snow(k) = 1.e-22
+         ze_graupel(k) = 1.e-22
+         if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4)
+         if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI_MORR)*(6.0/PI_MORR)     &
+                                 * (xam_s/900.0)*(xam_s/900.0)          &
+                                 * N0_s(k)*xcsg(4)*ilams(k)**xcse(4)
+         if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI_MORR)*(6.0/PI_MORR)  &
+                                    * (xam_g/900.0)*(xam_g/900.0)       &
+                                    * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4)
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Special case of melting ice (snow/graupel) particles.  Assume the
+!.. ice is surrounded by the liquid water.  Fraction of meltwater is
+!.. extremely simple based on amount found above the melting level.
+!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting
+!.. routines).
+!+---+-----------------------------------------------------------------+
+
+      if (melti .and. k_0.ge.kts+1) then
+       do k = k_0-1, kts, -1
+
+!..Reflectivity contributed by melting snow
+          if (L_qs(k) .and. L_qs(k_0) ) then
+           fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0))
+           eta = 0.d0
+           lams = 1./ilams(k)
+           do n = 1, nrbins
+              x = xam_s * xxDs(n)**xbm_s
+              call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), &
+                    fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, &
+                    CBACK, mixingrulestring_s, matrixstring_s,          &
+                    inclusionstring_s, hoststring_s,                    &
+                    hostmatrixstring_s, hostinclusionstring_s)
+              f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n))
+              eta = eta + f_d * CBACK * simpson(n) * xdts(n)
+           enddo
+           ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
+          endif
+
+
+!..Reflectivity contributed by melting graupel
+
+          if (L_qg(k) .and. L_qg(k_0) ) then
+           fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0))
+           eta = 0.d0
+           lamg = 1./ilamg(k)
+           do n = 1, nrbins
+              x = xam_g * xxDg(n)**xbm_g
+              call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), &
+                    fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, &
+                    CBACK, mixingrulestring_g, matrixstring_g,          &
+                    inclusionstring_g, hoststring_g,                    &
+                    hostmatrixstring_g, hostinclusionstring_g)
+              f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n))
+              eta = eta + f_d * CBACK * simpson(n) * xdtg(n)
+           enddo
+           ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
+          endif
+
+       enddo
+      endif
+
+      do k = kte, kts, -1
+         dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18)
+      enddo
+
+
+      end subroutine refl10cm_hm
+      END MODULE module_mp_fast_sbm
diff --git a/wrfv2_fire/phys/module_mp_full_sbm.F b/wrfv2_fire/phys/module_mp_full_sbm.F
new file mode 100644
index 00000000..9602a59c
--- /dev/null
+++ b/wrfv2_fire/phys/module_mp_full_sbm.F
@@ -0,0 +1,13422 @@
+!WRF:MODEL_MP:PHYSICS
+! The FULL version calculates hydrometeor distributions for qc,qr,qs,qg. and qh, and three ice types,
+! and their number concentrations (and aerosol concentrations).
+! To use the FULL version of SBM, please do the following.
+! Set DX_BOUND to some value larger than the first inner nest, but smaller than the outer domain in meters
+! Set the aerosol concentration with the variables FCCNR_MAR, and FCCNR_CON, FCCNR_MIX.  
+! Each of the aerosol distributions are set with ACCN (concentration of ccn particles at 1% saturation), and
+! BCCN (the "k" coefficient; for example: FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN). 
+! Questions: contact barry.h.lynn@gmail.com (Barry Lynn)
+
+!
+MODULE module_mp_full_sbm
+USE module_mp_radar
+!
+!-----------------------------------------------------------------------
+! BARRY
+      INTEGER,PRIVATE,PARAMETER :: REMSAT = 0
+!     LOGICAL, PRIVATE,PARAMETER : : ICEPROCS=.FALSE.,BULKNUC=.TRUE.  
+      INTEGER, PRIVATE,PARAMETER :: IBREAKUP=1
+      LOGICAL, PRIVATE,PARAMETER :: CONSERV=.TRUE.
+! SET ONE = TRUE
+      LOGICAL, PRIVATE,PARAMETER :: ORIGINAL_MELT=.FALSE.
+      LOGICAL, PRIVATE,PARAMETER :: JIWEN_FAN_MELT=.TRUE.
+!     LOGICAL, PRIVATE,PARAMETER :: ORIGINAL_MELT=.TRUE.
+!     LOGICAL, PRIVATE,PARAMETER :: JIWEN_FAN_MELT=.FALSE.
+      INTEGER, PRIVATE,PARAMETER :: p_ff1i01=2, p_ff1i33=34,p_ff5i01=35,p_ff5i33=67,p_ff6i01=68,&
+     & p_ff6i33=100,p_ff8i01=101,p_ff8i33=133,p_ff2i01=134,p_ff2i33=166,p_ff3i01=167,p_ff3i33=199,&
+     & p_ff4i01=200,p_ff4i33=232,p_ff7i01=233,p_ff7i33=265
+!p_ff1i01 =            2
+!p_ff1i33 =           34
+!p_ff5i01 =           35
+!p_ff5i33 =           67
+!p_ff6i01 =           68
+!p_ff6i33 =          100
+!p_ff8i01 =          101
+!p_ff8i33 =          133
+!p_ff2i01 =          134
+!p_ff2i33 =          166
+!p_ff3i01 =          167
+!p_ff3i33 =          199
+!p_ff4i01 =          200
+!p_ff4i33 =          232
+!p_ff7i01 =          233
+!p_ff7i33 =          265
+
+
+!     100
+!     REAL,PRIVATE,PARAMETER :: F_AMOUNT=0.1
+!     TEN 
+!     REAL,PRIVATE,PARAMETER :: F_AMOUNT=0.01
+!     ONE
+      REAL, PRIVATE,PARAMETER :: PI_MORR = 3.1415926535897932384626434
+      REAL, PRIVATE,PARAMETER ::  R_MORR = 287.15
+      REAL,PRIVATE,PARAMETER :: F_AMOUNT=0.001
+      REAL,PRIVATE,PARAMETER :: DX_BOUND=7500
+      REAL ACCN,BCCN
+      REAL,PRIVATE,PARAMETER :: ACCN_MAR=1.0000E02, BCCN_MAR=0.900E00,ROCCN0=0.1000E01
+      REAL,PRIVATE,PARAMETER :: ACCN_CON=2.00000E03, BCCN_CON=0.400E00,ROCCN03=0.1000E01
+      REAL,PRIVATE,PARAMETER :: I3POINT=1
+      INTEGER,PRIVATE,PARAMETER :: ICCN = 1
+       DOUBLE PRECISION, PRIVATE, PARAMETER ::  SCAL=1.d0
+       INTEGER, PRIVATE,PARAMETER :: ICEPROCS=1,BULKNUC=0 
+       INTEGER, PRIVATE,PARAMETER :: ICETURB=0,LIQTURB=0
+!      INTEGER, PRIVATE,PARAMETER :: RAIN_INIT=1,GRAUPEL_INIT=1
+!      INTEGER, PRIVATE,PARAMETER :: ICE_INIT=0,SNOW_INIT=1
+
+       INTEGER, PRIVATE,PARAMETER :: ICEMAX=3,NCD=33,NHYDR=5,NHYDRO=7  &
+     &        ,ifreez_down1=0,ifreez_down2=1,ifreez_top=1              &
+     &        ,K0_LL=8,KRMIN_LL=1,KRMAX_LL=19,L0_LL=6                  &
+     &        , IEPS_400=1,IEPS_800=0,IEPS_1600=0                      &
+     &        ,K0L_GL=16,K0G_GL=16                                     &
+     &        ,KRMINL_GL=1,KRMAXL_GL=24                                &
+     &        ,KRMING_GL=1,KRMAXG_GL=33                                &
+     &        ,KRDROP=18,KRBREAK=17,KRICE=18                           &
+     &        ,NKR=33,JMAX=33,NRG=2,JBREAK = 18 
+       REAL dt_coll
+!      REAL, PRIVATE,PARAMETER ::C1_MEY=0.0033,C2_MEY=0.              &
+       REAL, PRIVATE,PARAMETER ::C1_MEY=0.00033,C2_MEY=0.              &
+! New CONTINENTAL
+!      REAL, PRIVATE,PARAMETER ::C1_MEY=0.0033,C2_MEY=0.              &
+     &        ,an0_freez=10.,COL=0.23105                                
+       REAL, PRIVATE,PARAMETER :: p1=1000000.0,p2=750000.0,p3=500000.0                     
+!      INTEGER, PRIVATE,PARAMETER :: NCOND=3
+!      INTEGER, PRIVATE,PARAMETER :: NCOND=6
+       INTEGER, PRIVATE :: NCOND
+       INTEGER, PRIVATE,PARAMETER :: kr_icempl=9
+!      REAL, PRIVATE, PARAMETER :: ALCR = 1.0
+!      REAL, PRIVATE, PARAMETER :: ALCR = 2.0
+!      REAL, PRIVATE, PARAMETER :: ALCR = 1.5
+       REAL, PRIVATE, PARAMETER :: ALCR = 2.25
+!      REAL, PRIVATE, PARAMETER :: ALCR = 3.0
+       REAL, PRIVATE, PARAMETER :: ALCR_G = 3.0
+!      REAL, PRIVATE, PARAMETER :: ALCR_G = 1.0
+       INTEGER,PRIVATE,PARAMETER :: icempl=1
+       REAL, PRIVATE, PARAMETER :: COEFREFLL=1.E6*36.E6*COL/3.1453/3.1453 
+       REAL, PRIVATE, PARAMETER :: COEFREFLI=1.E9*36.E3*COL/3.1453/3.1453/5.
+       REAL, PRIVATE, PARAMETER :: COEFREF00=1.E9*36.E3*COL/3.1453/3.1453       
+       REAL, PRIVATE,DIMENSION(NKR) ::COLREFLL,COLREFLI,COLREFLS,COLREFLG,COLREFLH
+
+
+! YWLL_1000MB(nkr,nkr) - input array of kernels for pressure 1000mb
+! YWLL_750MB(nkr,nkr) - input array of kernels for pressure 750mb
+! YWLL_500MB(nkr,nkr) - input array of kernels for pressure 500mb
+       REAL, PRIVATE, SAVE :: &
+! CRYSTALS 
+     &YWLI(NKR,NKR,ICEMAX) &
+! MIXTURES
+     &,YWIL(NKR,NKR,ICEMAX),YWII(NKR,NKR,ICEMAX,ICEMAX) &
+     &,YWIS(NKR,NKR,ICEMAX),YWIG(NKR,NKR,ICEMAX) &
+     &,YWIH(NKR,NKR,ICEMAX),YWSI(NKR,NKR,ICEMAX) &
+     &,YWGI(NKR,NKR,ICEMAX),YWHI(NKR,NKR,ICEMAX)
+!
+      REAL,PRIVATE,DIMENSION(NKR,NKR),SAVE :: &
+     & YWLL_1000MB,YWLL_750MB,YWLL_500MB,YWLL,YWLS,YWLG,YWLH &
+! SNOW :
+     &,YWSL,YWSS,YWSG,YWSH &
+! GRAUPELS :
+     &,YWGL,YWGS,YWGG,YWGH &
+! HAIL :
+     &,YWHL,YWHS,YWHG,YWHH
+       REAL, PRIVATE, SAVE :: &
+     &  XI(NKR,ICEMAX) &
+     & ,RADXX(NKR,NHYDR-1),MASSXX(NKR,NHYDR-1),DENXX(NKR,NHYDR-1) &
+     & ,RADXXO(NKR,NHYDRO),MASSXXO(NKR,NHYDRO),DENXXO(NKR,NHYDRO) &
+     & ,RIEC(NKR,ICEMAX),COEFIN(NKR),SLIC(NKR,6),TLIC(NKR,2) &
+     & ,RO2BL(NKR,ICEMAX)
+       REAL, PRIVATE, SAVE :: VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR) &
+     & ,VR4(NKR),VR5(NKR),VRX(NKR),VRI(NKR)
+      REAL,PRIVATE,DIMENSION(NKR),SAVE ::  &
+     &  XL,RLEC,XX,XCCN,XS,RSEC &
+     & ,XG,RGEC,XH,RHEC,RO1BL,RO3BL,RO4BL,RO5BL &
+     & ,ROCCN,RCCN,DROPRADII
+  
+      REAL, PRIVATE,SAVE ::  FCCNR_MAR(NKR),FCCNR_CON(NKR)
+      REAL, PRIVATE,SAVE ::  FCCNR_MIX(NKR)
+      REAL, PRIVATE,SAVE ::  FCCNR(NKR)
+
+
+        REAL, PRIVATE :: C2,C3,C4
+      double precision,private,save ::  cwll(nkr,nkr)
+      double precision,private,save::  &
+     & xl_mg(0:nkr),xs_mg(0:nkr),xg_mg(0:nkr),xh_mg(0:nkr) &
+     &,xi1_mg(0:nkr),xi2_mg(0:nkr),xi3_mg(0:nkr) &
+     &,chucm(nkr,nkr),ima(nkr,nkr) &
+     &,cwll_1000mb(nkr,nkr),cwll_750mb(nkr,nkr),cwll_500mb(nkr,nkr) &
+     &,cwli_1(nkr,nkr),cwli_2(nkr,nkr),cwli_3(nkr,nkr) &
+     &,cwls(nkr,nkr),cwlg(nkr,nkr),cwlh(nkr,nkr) &
+
+     &,cwil_1(nkr,nkr),cwil_2(nkr,nkr),cwil_3(nkr,nkr) &
+
+     &,cwii_1_1(nkr,nkr),cwii_1_2(nkr,nkr),cwii_1_3(nkr,nkr) &
+     &,cwii_2_1(nkr,nkr),cwii_2_2(nkr,nkr),cwii_2_3(nkr,nkr) &
+     &,cwii_3_1(nkr,nkr),cwii_3_2(nkr,nkr),cwii_3_3(nkr,nkr) &
+
+     &,cwis_1(nkr,nkr),cwis_2(nkr,nkr),cwis_3(nkr,nkr) &
+     &,cwig_1(nkr,nkr),cwig_2(nkr,nkr),cwig_3(nkr,nkr) &
+     &,cwih_1(nkr,nkr),cwih_2(nkr,nkr),cwih_3(nkr,nkr) &
+
+     &,cwsl(nkr,nkr) &
+     &,cwsi_1(nkr,nkr),cwsi_2(nkr,nkr),cwsi_3(nkr,nkr)&
+     &,cwss(nkr,nkr),cwsg(nkr,nkr),cwsh(nkr,nkr) &
+     &,cwgl(nkr,nkr)&
+     &,cwgi_1(nkr,nkr),cwgi_2(nkr,nkr),cwgi_3(nkr,nkr)&
+     &,cwgs(nkr,nkr),cwgg(nkr,nkr),cwgh(nkr,nkr) &
+
+     &,cwhl(nkr,nkr) &
+     &,cwhi_1(nkr,nkr),cwhi_2(nkr,nkr),cwhi_3(nkr,nkr) &
+     &,cwhs(nkr,nkr),cwhg(nkr,nkr),cwhh(nkr,nkr) &
+     &,dlnr &
+     &,CTURBLL(KRMAX_LL,KRMAX_LL)&
+     &,CTURB_LL(K0_LL,K0_LL)&
+     &,CTURBGL(KRMAXG_GL,KRMAXL_GL)&
+     &,CTURB_GL(K0G_GL,K0L_GL)
+
+      DOUBLE PRECISION,private, save :: &
+     &   BRKWEIGHT(JBREAK),PKIJ(JBREAK,JBREAK,JBREAK), &
+     &   QKJ(JBREAK,JBREAK),ECOALMASSM(NKR,NKR)
+
+ 
+
+
+
+!
+!
+      CONTAINS
+
+!-----------------------------------------------------------------------
+!-----------------------------------------------------------------------
+      SUBROUTINE SBM (w,u,v,th_old,                                &
+     &                      chem_new,n_chem,                              &
+     &                      itimestep,DT,DX,DY,                         &
+     &                      dz8w,rho_phy,p_phy,pi_phy,th_phy,           &
+     &                      xland,ivgtyp,xlat,xlong,                           &
+     &                      QV,QC,QR,QIP,QIC,QID,QS,QG,QH,QV_OLD,                   &
+     &                      QNC,QNR,QNIP,QNIC,QNID,QNS,QNG,QNH,QNA,EFFR,ICE_EFFR,TOT_EFFR,       &
+     &                      QIC_EFFR,QIP_EFFR,QID_EFFR,       &
+     &                      height,tempc,&
+!    &                      QRRAD,QSRAD,QGRAD,QTIRAD,QTOTRAD,           &
+!    &                      QRRAD,QSRAD,QGRAD,                          &
+     &                      kext_ql,kext_qs,kext_qg,kext_qh,kext_qa,    &
+     &                      kext_qic,kext_qip,kext_qid,                 &
+     &                      kext_ft_qic,kext_ft_qip,kext_ft_qid,                 &
+     &                      kext_ft_qs,kext_ft_qg,                 &
+     &                      ids,ide, jds,jde, kds,kde,		        &
+     &                      ims,ime, jms,jme, kms,kme,		        &
+     &                      its,ite, jts,jte, kts,kte,                  &
+     &                      refl_10cm, diagflag, do_radar_ref,      & ! MO added for reflectivity calcs
+     &                      RAINNC                             )
+!-----------------------------------------------------------------------
+      IMPLICIT NONE
+!-----------------------------------------------------------------------
+      INTEGER, PARAMETER :: ITLO=-60, ITHI=40
+      INTEGER NKRO,NKRE
+      INTEGER KR,IKL,ICE
+
+      INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE                     &
+     &                     ,IMS,IME,JMS,JME,KMS,KME                     &
+     &                     ,ITS,ITE,JTS,JTE,KTS,KTE                     &
+     &                     ,ITIMESTEP,N_CHEM
+
+      REAL, INTENT(IN) 	    :: DT,DX,DY
+   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         , &
+          INTENT(IN   ) ::                                   &
+                                                          U, &
+                                                          V, &
+                                                          W   
+!                                                        pi
+  REAL    ,DIMENSION(ims:ime,kms:kme,jms:jme,n_chem),INTENT(INOUT)   :: chem_new
+  REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),                 &
+        INTENT(INOUT) ::                                          &
+                                                              qv, &
+                                                          qv_old, &
+                                                          th_old, &
+                                                              qc, &
+                                                              qr, &
+                                                              qip, &
+                                                              qic, &
+                                                              qid, &
+                                                              qs, &
+                                                              qg, &
+                                                              qh, &
+                                                              qnc, &
+                                                              qnr, &
+                                                              qns, &
+                                                              qnip, &
+                                                              qnic, &
+                                                              qnid, &
+                                                              qng, &
+                                                              qnh, &
+                                                              qna, &
+                                                              kext_ql, &
+                                                              kext_qs, &
+                                                              kext_qg, &
+                                                              kext_qh, &
+                                                              kext_qa, &
+                                                              kext_qic, &
+                                                              kext_qip, &
+                                                              kext_qid, &
+                                                              kext_ft_qic, &
+                                                              kext_ft_qip, &
+                                                              kext_ft_qid, &
+                                                              kext_ft_qs, &
+                                                              kext_ft_qg, &
+                                                              effr, &
+                                                              ice_effr,&
+                                                              tot_effr,&
+                                                              qic_effr,&
+                                                              qip_effr,&
+                                                              qid_effr,&
+                                                              height,  &
+                                                              tempc    
+!                                                             effr, &
+!                                                            qtirad, &
+!                                                             qtotrad
+
+
+
+      REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN)   :: XLAND
+      LOGICAL, OPTIONAL, INTENT(IN) :: diagflag
+      INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref
+
+      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT)::       &  ! GT
+                          refl_10cm
+
+      INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(IN)::   IVGTYP
+      REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )    :: XLAT, XLONG
+      REAL, INTENT(IN),     DIMENSION(ims:ime, kms:kme, jms:jme)::      &
+     &                      dz8w,p_phy,pi_phy,rho_phy
+      REAL, INTENT(INOUT),  DIMENSION(ims:ime, kms:kme, jms:jme)::      &
+     &                      th_phy
+      REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
+     &                                                   RAINNC
+!     REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
+!     REAL,                 DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
+!    &              LIQUEXP,ICEEXP,SNOWEXP,GRAUEXP,HAILEXP
+!
+
+!-----------------------------------------------------------------------
+!     LOCAL VARS
+!-----------------------------------------------------------------------
+
+!     NSTATS,QMAX,QTOT are diagnostic vars
+
+      INTEGER,DIMENSION(ITLO:ITHI,4) :: NSTATS
+!     REAL,   DIMENSION(ITLO:ITHI,5) :: QMAX
+      REAL,   DIMENSION(ITLO:ITHI,22):: QTOT
+
+!     SOME VARS WILL BE USED FOR DATA ASSIMILATION (DON'T NEED THEM NOW). 
+!     THEY ARE TREATED AS LOCAL VARS, BUT WILL BECOME STATE VARS IN THE 
+!     FUTURE. SO, WE DECLARED THEM AS MEMORY SIZES FOR THE FUTURE USE
+
+!     TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related 
+!     the microphysics scheme. Instead, they will be used by Eta precip 
+!     assimilation.
+
+      REAL,  DIMENSION( ims:ime, kms:kme, jms:jme ) ::                  &
+     &       TLATGS_PHY,TRAIN_PHY
+      REAL,  DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC
+      REAL,  DIMENSION(its-1:ite+1, kts:kte, jts-1:jte+1):: t_new,t_old,   &
+     &                                      zcgs,       rhocgs,pcgs
+
+      INTEGER :: I,J,K,KFLIP
+! BARRY
+      INTEGER :: KRFREEZ
+! DATA
+       REAL Z0IN,ZMIN
+       DATA  ZMIN/2.0E5/
+       DATA  Z0IN/2.0E5 /
+
+!      REAL,DIMENSION(1) :: EPSF2D, &
+       REAL EPSF2D, &
+     &        TAUR1,TAUR2,EPS_R1,EPS_R2,ANC1IN, &
+     &        PEPL,PEPI,PERL,PERI,ANC1,ANC2,PARSP, &
+     &        AFREEZMY,BFREEZMY,BFREEZMAX, &
+     &        TCRIT,TTCOAL, &
+     &        EPSF1,EPSF3,EPSF4, &
+     &        SUP2_OLD, DSUPICEXZ,TFREEZ_OLD,DTFREEZXZ, &
+     &        AA1_MY,BB1_MY,AA2_MY,BB2_MY, &
+     &        DTIME,DTCOND, &
+     &        A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
+        DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN  &
+     &      /2.53,5.42,3.41E1,6.13/
+        DATA AA1_MY,BB1_MY,AA2_MY,BB2_MY/2.53E12,5.42E3,3.41E13,6.13E3/
+!            QSUM,ISUM,QSUM1,QSUM2,CCNSUM1,CCNSUM2
+        DATA KRFREEZ,BFREEZMAX,ANC1,ANC2,PARSP,PEPL,PEPI,PERL,PERI, &
+     &  TAUR1,TAUR2,EPS_R1,EPS_R2,TTCOAL,AFREEZMY,&
+     &  BFREEZMY,EPSF1,EPSF3,EPSF4,TCRIT/21,&
+     &  0.6600E00, &
+     &  1.0000E02,1.0000E02,0.9000E02, &
+     &  0.6000E00,0.6000E00,1.0000E-03,1.0000E-03, &
+     &  0.5000E00,0.8000E00,0.1500E09,0.1500E09, &
+     &  2.3315E02,0.3333E-04,0.6600E00, &
+     &  0.1000E-02,0.1000E-05,0.1000E-05, &
+     &  2.7015E02/
+! JIMY: N_CHEM,variables read in as data
+! SBM VARIABLES
+      REAL,DIMENSION (nkr) :: FF1IN,FF3IN,FF4IN,FF5IN,&
+     &              FF1R,FF3R,FF4R,FF5R,FCCN
+      REAL,DIMENSION (nkr,icemax) :: FF2IN,FF2R
+!!!! NOTE: ZCGS AND OTHER VARIABLES ARE ALSO DIMENSIONED IN FALFLUXHUCM
+      DOUBLE PRECISION DEL1NR,DEL2NR,DEL12R,DEL12RD,ES1N,ES2N,EW1N,EW1PN
+      DOUBLE PRECISION DELSUP1,DELSUP2,DELDIV1,DELDIV2
+      DOUBLE PRECISION TT,QQ,TTA,QQA,PP,DPSA,DELTATEMP,DELTAQ
+      DOUBLE PRECISION DIV1,DIV2,DIV3,DIV4,DEL1IN,DEL2IN,DEL1AD,DEL2AD
+      REAL DEL_BB,DEL_BBN,DEL_BBR
+      REAL FACTZ,CONCCCN_XZ,CONCDROP
+       REAL SUPICE(KTE),AR1,AR2, &
+     & DERIVT_X,DERIVT_Y,DERIVT_Z,DERIVS_X,DERIVS_Y,DERIVS_Z, &
+     & ES2NPLSX,ES2NPLSY,EW1NPLSX,EW1NPLSY,UX,VX, &
+     & DEL2INPLSX,DEL2INPLSY,DZZ(KTE)
+       INTEGER KRR,I_START,I_END,J_START,J_END
+   
+       REAL DTFREEZ_XYZ(ITE,KTE,JTE),DSUPICE_XYZ(ITE,KTE,JTE)
+
+       REAL DXHUCM,DYHUCM
+       REAL FMAX1,FMAX2,FMAX3,FMAX4,FMAX5
+       INTEGER ISYM1,ISYM2,ISYM3,ISYM4,ISYM5
+       INTEGER DIFFU
+       REAL DELTAW
+       real zcgs_z(kts:kte),pcgs_z(kts:kte),rhocgs_z(kts:kte),ffx_z(kts:kte,nkr)
+       real z_full
+! SLOPE INTERCEPT FOR RAIN, SNOW, AND GRAUPEL                                    PARAMR.32
+!     RON=8.E6                                                                   PARAMR.33
+!     RON2=1.E10                                                                 23DEC04.211
+!     RON2=1.E9                                                                  23DEC04.212
+!     SON=2.E7                                                                   PARAMR.36
+!     GON=5.E7                                                                   23DEC04.213
+!     GON=4.E6
+       REAL, PARAMETER :: RON=8.E6, GON=5.E7,PI=3.14159265359
+       REAL EFF_N,EFF_D
+       REAL EFF_NI(its:ite,kts:kte,jts:jte),eff_di(its:ite,kts:kte,jts:jte)
+       REAL EFF_NQIC,eff_DQIC
+       REAL EFF_NQIP,eff_DQIP
+       REAL EFF_NQID,eff_DQID
+       real lambda,chi0,xi1,xi2,xi3,xi4,xi5,r_e,chi_3,f1,f2,volume,surface_area,xi6,ft,chi_e
+       real ft_bin
+      REAL, DIMENSION(kts:kte)::                            &
+                      qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
+      REAL, DIMENSION(kts:kte):: dBZ
+      
+
+       real nzero,son,nzero_less
+       parameter (son=2.E7)
+       real raddumb(nkr),massdumb(nkr)
+       real hydrosum
+
+       integer imax,kmax,jmax
+       real gmax
+       real tmax,qmax,divmax,rainmax
+       real qnmax,inmax,knmax
+       real hydro
+       real difmax,tdif,tt_old,w_stag,qq_old
+       real teten,es
+       integer  print_int
+       parameter (print_int=300)
+       real ft_liq(nkr)
+       data ft_liq/ 6.254894e-01,6.615571e-01,6.922125e-01,7.514451e-01,7.391191e-01,7.592261e-01,7.417122e-01&
+     &             ,7.388885e-01,7.430871e-01,7.570534e-01,7.584263e-01,7.735341e-01,7.721352e-01,7.724897e-01&
+     &             ,7.744899e-01,7.745646e-01,7.768777e-01,7.776348e-01, 7.788586e-01,7.774171e-01,7.789876e-01 &
+     &             ,7.801301e-01,7.806936e-01,7.801274e-01,7.821974e-01,7.815210e-01,7.822269e-01,7.822353e-01 &
+     &             ,7.808765e-01,7.824246e-01,7.814153e-01,7.818192e-01, 7.818231e-01/
+!
+!
+! GUY'S Variables
+       real geo_cs
+       integer t_print
+       t_print=print_int/dt
+
+!      print*,'n_chem = ',n_chem
+       difmax = 0
+!      print*,'itimestep = ',itimestep
+!        if (itimestep.gt.150)return
+       if (itimestep.eq.1)then
+        if (iceprocs.eq.1) call wrf_message(" FULL SBM: ICE PROCESES ACTIVE ")
+        if (iceprocs.eq.0) call wrf_message(" FULL SBM: LIQUID PROCESES ONLY")
+       end if
+       tmax = 0
+! COAL BOTT IS EITHER CALLED EVERY TIME STEP OR TWICE
+       NCOND = 0
+!       if (mod(dx,1000.).eq.0)then
+!       NCOND=dx/1000
+!       else if (mod(dx,2000.).eq.0)then
+!       NCOND=dx/500
+!       else if (mod(dx,3000.).eq.0)then
+!       NCOND=dx/1000
+!       else if (mod(dx,4000.).eq.0)then
+!       NCOND=dx/1000
+!       else if (mod(dx,1333.).eq.0)then
+!       NCOND=dx/1.3333
+!       end if
+         NCOND=nint(dx/1000)
+
+!       IF (NCOND.EQ.0)NCOND=3
+       NCOND=max(NCOND,1)
+       DTCOND=DT/REAL(NCOND)
+       dt_coll=dt
+       call kernals(dt)
+!      if (itimestep.eq.1.or.itimestep.eq.3)then
+!            do kr = 1,nkr
+!             print*,'xl = ',xl(kr),vr1(kr),RLEC(kr),RO1BL(kr)
+!             print*,'xi = ',xi(kr,1),vr2(kr,1),RIEC(KR,1),RO2BL(KR,1)
+!             print*,'xi = ',xi(kr,2),vr2(kr,2),RIEC(KR,2),RO2BL(KR,2)
+!             print*,'xi = ',xi(kr,3),vr2(kr,3),RIEC(KR,3),RO2BL(KR,3)
+!             print*,'xs = ',xs(kr),vr3(kr),RSEC(kr),RO3BL(kr)
+!             print*,'xg = ',xg(kr),vr4(kr),RGEC(kr),RO4BL(kr)
+!             print*,'xh = ',xh(kr),vr5(kr),RHEC(kr),RO5BL(kr)
+!            end do
+!       end if
+
+!
+      DEL_BB=BB2_MY-BB1_MY
+      DEL_BBN=BB2_MYN-BB1_MYN
+      DEL_BBR=BB1_MYN/DEL_BBN
+!
+      if (conserv)then
+      DO j = jts,jte
+      DO i = its,ite
+      DO k = kts,kte
+      rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
+      KRR=0
+      DO KR=p_ff1i01,p_ff1i33
+        KRR=KRR+1
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XL(KRR)/XL(KRR)/3.0
+      END DO
+      KRR=0
+      DO KR=p_ff5i01,p_ff5i33
+        KRR=KRR+1
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XS(KRR)/XS(KRR)/3.0
+      END DO
+      KRR=0
+      DO KR=p_ff6i01,p_ff6i33
+        KRR=KRR+1
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XG(KRR)/XG(KRR)/3.0
+      END DO
+!      if (i.eq.100.and.j.eq.100)then
+!       print*,'qna  1 = ', k,FACTZ,qna(i,k,j)
+!      end if
+      KRR=0
+      DO KR=p_ff8i01,p_ff8i33
+        KRR=KRR+1
+! change by J. Fan
+!        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/XCCN(KRR)
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/1000.   ! chem_new (input) is #/kg
+      END DO
+! Columns
+      KRR=0
+      DO KR=p_ff2i01,p_ff2i33
+        KRR=KRR+1
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XI(KRR,1)/XI(KRR,1)/3.0
+!         if (i.eq.230.and.j.eq.146.and.k.eq.13)then
+      END DO
+! Plates 
+      KRR=0
+      DO KR=p_ff3i01,p_ff3i33
+        KRR=KRR+1
+!         if (i.eq.230.and.j.eq.146.and.k.eq.13)then
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XI(KRR,2)/XI(KRR,2)/3.0
+      END DO
+! Dendrites
+      KRR=0
+      DO KR=p_ff4i01,p_ff4i33
+        KRR=KRR+1
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XI(KRR,3)/XI(KRR,3)/3.0
+      END DO
+      KRR=0
+      DO KR=p_ff7i01,p_ff7i33
+        KRR=KRR+1
+        chem_new(I,K,J,KR)=chem_new(I,K,J,KR)*RHOCGS(I,K,J)/COL/XH(KRR)/XH(KRR)/3.0
+      END DO
+      END DO
+      END DO
+      END DO
+      end if
+
+      call kernals(dt)
+
+      DXHUCM=100.*DX
+      DYHUCM=100.*DY
+!     print*,'dxhucm = ',dxhucm
+!     print*,'dyhucm = ',dyhucm
+!-----------------------------------------------------------------------
+!**********************************************************************
+!-----------------------------------------------------------------------
+!
+!
+! JIMY
+      I_START=MAX(1,ITS-1)
+      J_START=MAX(1,JTS-1)
+      I_END=MIN(IDE-1,ITE+1)
+      J_END=MIN(JDE-1,JTE+1)
+!     print*,'ide-1 = ',ide-1
+!     print*,'jde-1 = ',jde-1
+!     print*,'kte = ',kte
+!     print*,'i_start,i_end = ',i_start,i_end
+!     print*,'j_start,j_end = ',j_start,j_end
+!     print*,'its,ite = ',its,ite
+!     print*,'jts,jte = ',jts,jte
+      DO j = j_start,j_end
+      DO i = i_start,i_end
+      z_full=0.
+      DO k = kts,kte
+          pcgs(I,K,J)=P_PHY(I,K,J)*10.
+          rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
+          zcgs(I,K,J)=z_full+0.5*dz8w(I,K,J)*100
+          z_full=z_full+dz8w(i,k,j)*100.
+      ENDDO
+      ENDDO
+      ENDDO
+!!!!!
+         if (itimestep.eq.1)then
+       DO j = jts,jte
+       DO i = its,ite
+       DO k = kts,kte
+         IF (zcgs(I,K,J).LE.ZMIN)THEN
+            FACTZ=1.
+         ELSE
+            FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
+         END IF
+!        FACTZ = 1
+         KRR=0
+         DO KR=p_ff8i01,p_ff8i33
+          KRR=KRR+1
+          if (xland(i,j).eq.1)then
+             chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
+          else
+             chem_new(I,K,J,KR)=FCCNR_MIX(KRR)*FACTZ
+          end if
+!         if (xlat(i,j).ge.10.and.xlat(i,j).le.30.and.zcgs(i,k,j).le.300000)then
+!            if (zcgs(i,k,j).le.25000)then
+!             chem_new(I,K,J,KR)=FCCNR0(KRR)+FCCNR3(KRR)
+!            else
+!             chem_new(I,K,J,KR)=FCCNR3(KRR)
+!            end if
+!         end if
+
+         END DO
+       end do
+       end do
+       end do
+       end if
+       if (itimestep.ne.1.and.dx.gt.dx_bound)then
+       DO j = jts,jte
+       DO k = kts,kte
+       DO i = its,ite
+        if (i.le.5.or.i.ge.IDE-5.OR. &
+     &       j.le.5.or.j.ge.JDE-5)THEN
+         IF (zcgs(I,K,J).LE.ZMIN)THEN
+            FACTZ=1.
+         ELSE
+            FACTZ=EXP(-(zcgs(I,K,J)-ZMIN)/Z0IN)
+         END IF
+         KRR=0
+         DO kr=p_ff8i01,p_ff8i33
+          KRR=KRR+1
+          if (xland(i,j).eq.1)then
+             chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ
+          else
+             chem_new(I,K,J,KR)=FCCNR_MIX(KRR)*FACTZ
+          end if
+!         if (xlat(i,j).ge.10.and.xlat(i,j).le.30.and.zcgs(i,k,j).le.300000)then
+!            if (zcgs(i,k,j).le.25000)then
+!             chem_new(I,K,J,KR)=FCCNR0(KRR)+FCCNR3(KRR)
+!            else
+!             chem_new(I,K,J,KR)=FCCNR3(KRR)
+!            end if
+!         end if
+         End do
+        end if
+       end do
+       end do
+       end do
+       end if
+      if (itimestep.eq.1)then
+      DO j = j_start,j_end
+      DO k = kts,kte
+      DO i = i_start,i_end
+         th_old(i,k,j)=th_phy(i,k,j)
+         qv_old(i,k,j)=qv(i,k,j)
+      END DO
+      END DO
+      END DO
+      end if
+      DO j = j_start,j_end
+      DO k = kts,kte
+      DO i = i_start,i_end
+        t_new(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j)
+        tempc(i,k,j)=t_new(i,k,j)-273.16
+        t_old(i,k,j) = th_old(i,k,j)*pi_phy(i,k,j)
+      ENDDO
+      ENDDO
+      ENDDO
+
+
+
+
+!1         172           1           1
+
+!     print*,'here at 1'
+      DO j = jts,jte
+      DO i = its,ite
+      DO k = kts,kte
+       IF(K.EQ.KTE)THEN
+        DZZ(K)=(zcgs(I,K,J)-zcgs(I,K-1,J))
+       ELSE IF(K.EQ.1)THEN
+        DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K,J))
+       ELSE
+        DZZ(K)=(zcgs(I,K+1,J)-zcgs(I,K-1,J))
+       END IF
+       ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
+       EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
+       SUPICE(K)=EW1N/ES2N-1.
+       IF(SUPICE(K).GT.0.5) SUPICE(K)=.5
+ 
+      END DO
+      DO k = kts,kte
+       IF(T_OLD(I,K,J).GE.238.15.AND.T_OLD(I,K,J).LT.274.15) THEN
+       if (k.lt.kte)then       
+        w_stag=50.*(w(i,k,j)+w(i,k+1,j)) 
+       else
+        w_stag=100*w(i,k,j)
+       end if
+             IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
+              UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
+              VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
+             ELSE
+              UX=U(I,K,J)*100.
+              VX=V(I,K,J)*100.
+             END IF  
+             IF(K.EQ.1) DERIVT_Z=(T_OLD(I,K+1,J)-T_OLD(I,K,J))/DZZ(K)
+             IF(K.EQ.KTE) DERIVT_Z=(T_OLD(I,K,J)-T_OLD(I,K-1,J))/DZZ(K)
+             IF(K.GT.1.AND.K.LT.KTE) DERIVT_Z= &
+     &        (T_OLD(I,K+1,J)-T_OLD(I,K-1,J))/DZZ(K)
+             IF (I.EQ.1)THEN
+              DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I,K,J))/(DXHUCM)
+             ELSE IF (I.EQ.IDE-1)THEN
+              DERIVT_X=(T_OLD(I,K,J)-T_OLD(I-1,K,J))/(DXHUCM)
+             ELSE
+              DERIVT_X=(T_OLD(I+1,K,J)-T_OLD(I-1,K,J))/(2.*DXHUCM)
+             END IF
+             IF (J.EQ.1)THEN
+              DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J))/(DYHUCM)
+             ELSE IF (J.EQ.JDE-1)THEN
+              DERIVT_Y=(T_OLD(I,K,J)-T_OLD(I,K,J-1))/(DYHUCM)
+             ELSE
+              DERIVT_Y=(T_OLD(I,K,J+1)-T_OLD(I,K,J-1))/(2.*DYHUCM)
+             END IF
+             DTFREEZ_XYZ(I,K,J)=DT*(VX*DERIVT_Y+ &
+     &            UX*DERIVT_X+w_stag*DERIVT_Z)
+          ELSE
+             DTFREEZ_XYZ(I,K,J)=0.
+          ENDIF
+          IF(SUPICE(K).GE.0.02.AND.T_OLD(I,K,J).LT.268.15) THEN
+            IF (I.LT.IDE-1)THEN
+             ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I+1,K,J))
+             EW1NPLSX=QV_OLD(I+1,K,J)*pcgs(I+1,K,J)/ &
+     &               (0.622+0.378*QV_OLD(I+1,K,J))
+            ELSE
+             ES2NPLSX=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
+             EW1NPLSX=QV_OLD(I,K,J)*pcgs(I,K,J)/ &
+     &               (0.622+0.378*QV_OLD(I,K,J))
+            END IF
+            IF (ES2NPLSX.EQ.0)THEN
+             DEL2INPLSX=0.5
+            ELSE
+             DEL2INPLSX=EW1NPLSX/ES2NPLSX-1.
+            END IF
+            IF(DEL2INPLSX.GT.0.5) DEL2INPLSX=.5
+            IF (I.GT.1)THEN
+             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I-1,K,J))
+             EW1N=QV_OLD(I-1,K,J)*pcgs(I-1,K,J)/(0.622+0.378*QV_OLD(I-1,K,J))
+            ELSE
+             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
+             EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
+            END IF
+            DEL2IN=EW1N/ES2N-1.
+            IF(DEL2IN.GT.0.5) DEL2IN=.5
+            IF (I.GT.1.AND.I.LT.IDE-1)THEN
+             DERIVS_X=(DEL2INPLSX-DEL2IN)/(2.*DXHUCM)
+            ELSE
+             DERIVS_X=(DEL2INPLSX-DEL2IN)/(DXHUCM)
+            END IF
+            IF (J.LT.JDE-1)THEN
+             ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J+1))
+             EW1NPLSY=QV_OLD(I,K,J+1)*pcgs(I,K,J+1)/(0.622+0.378*QV_OLD(I,K,J+1))
+            ELSE
+             ES2NPLSY=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
+             EW1NPLSY=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
+            END IF
+            DEL2INPLSY=EW1NPLSY/ES2NPLSY-1.
+            IF(DEL2INPLSY.GT.0.5) DEL2INPLSY=.5
+            IF (J.GT.1)THEN
+             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J-1))
+             EW1N=QV_OLD(I,K,J-1)*pcgs(I,K,J-1)/(0.622+0.378*QV_OLD(I,K,J-1))
+            ELSE
+             ES2N=AA2_MY*EXP(-BB2_MY/T_OLD(I,K,J))
+             EW1N=QV_OLD(I,K,J)*pcgs(I,K,J)/(0.622+0.378*QV_OLD(I,K,J))
+            END IF
+             DEL2IN=EW1N/ES2N-1.
+            IF(DEL2IN.GT.0.5) DEL2IN=.5
+            IF (J.GT.1.AND.J.LT.JDE-1)THEN
+             DERIVS_Y=(DEL2INPLSY-DEL2IN)/(2.*DYHUCM)
+            ELSE
+             DERIVS_Y=(DEL2INPLSY-DEL2IN)/(DYHUCM)
+            END IF
+!
+            IF (K.EQ.1)DERIVS_Z=(SUPICE(K+1)-SUPICE(K))/DZZ(K)
+            IF (K.EQ.KTE)DERIVS_Z=(SUPICE(K)-SUPICE(K-1))/DZZ(K)
+            IF(K.GT.1.and.K.LT.KTE) DERIVS_Z=(SUPICE(K+1)-SUPICE(K-1))/DZZ(K)
+            IF (I.LT.IDE-1.AND.J.LT.JDE-1)THEN
+             UX=25.*(U(I,K,J)+U(I+1,K,J)+U(I,K,J+1)+U(I+1,K,J+1))
+             VX=25.*(V(I,K,J)+V(I+1,K,J)+V(I,K,J+1)+V(I+1,K,J+1))
+            ELSE
+             UX=U(I,K,J)*100.
+             VX=V(I,K,J)*100.
+            END IF  
+            DSUPICE_XYZ(I,K,J)=(UX*DERIVS_X+VX*DERIVS_Y+ &
+      &                        w_stag*DERIVS_Z)*DTCOND
+          ELSE
+            DSUPICE_XYZ(I,K,J)=0.0
+          END IF
+         END DO
+         END DO
+         END DO
+     
+
+      do j = jts,jte
+      do k = kts,kte
+      do i = its,ite
+!     print*,'i,j,k = ',i,j,k
+! LIQUID
+!      do kr=1,nkr
+!       if (ff4r(kr).lt.0)then
+!        print*,'i,k,j = ',i,k,j
+!        print*,'ff4r 0 = ',kr,ff4r(kr)
+!       end if
+!      end do
+          KRR=0
+          DO kr=p_ff1i01,p_ff1i33
+           KRR=KRR+1
+           FF1R(KRR)=chem_new(I,K,J,KR)
+           IF (FF1R(KRR).LT.0)FF1R(KRR)=0.
+          END DO
+! CCN
+        KRR=0
+        DO kr=p_ff8i01,p_ff8i33
+          KRR=KRR+1
+          FCCN(KRR)=chem_new(I,K,J,KR)
+          if (fccn(krr).lt.0)fccn(krr)=0.
+        END DO
+        IF (ICEPROCS.EQ.1)THEN
+! COLUMNS!
+         KRR=0
+         DO kr=p_ff2i01,p_ff2i33
+          KRR=KRR+1
+          FF2R(KRR,1)=chem_new(I,K,J,KR)
+          if (ff2r(krr,1).lt.0)ff2r(krr,1)=0
+         END DO
+! PLATES!
+         KRR=0
+         DO kr=p_ff3i01,p_ff3i33
+          KRR=KRR+1
+          FF2R(KRR,2)=chem_new(I,K,J,KR)
+!i,j,k =          230         146          13
+          if (ff2r(krr,2).lt.0)ff2r(krr,2)=0
+          
+         END DO
+
+! DENDRITES!
+         KRR=0
+         DO KR=p_ff4i01,p_ff4i33
+          KRR=KRR+1
+          FF2R(KRR,3)=chem_new(I,K,J,KR)
+          if (ff2r(krr,3).lt.0)ff2r(krr,3)=0
+         END DO
+! SNOW
+           KRR=0
+           DO kr=p_ff5i01,p_ff5i33
+            KRR=KRR+1
+            FF3R(KRR)=chem_new(I,K,J,KR)
+            if (ff3r(krr).lt.0)ff3r(krr)=0.
+           END DO
+
+! Graupel
+           KRR=0
+           DO kr=p_ff6i01,p_ff6i33
+            KRR=KRR+1
+            FF4R(KRR)=chem_new(I,K,J,KR)
+            IF (FF4R(KRR).LT.0)FF4R(KRR)=0.
+           END DO
+
+! Hail
+         KRR=0
+         DO kr=p_ff7i01,p_ff7i33
+          KRR=KRR+1
+          FF5R(KRR)=chem_new(I,K,J,KR)
+          if (ff5r(krr).lt.0)ff5r(krr)=0.
+         END DO
+         CALL FREEZ &
+     &     (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
+     &      T_NEW(I,K,J),DT,rhocgs(I,K,J), &
+     &      COL,AFREEZMY,BFREEZMY,BFREEZMAX, &
+     &      KRFREEZ,ICEMAX,NKR)
+         IF (ORIGINAL_MELT)THEN
+         CALL ORIG_MELT  &
+     &    (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
+     &     T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR)
+         END IF
+         IF (JIWEN_FAN_MELT) THEN
+         CALL J_W_MELT &
+     &    (FF1R,XL,FF2R,XI,FF3R,XS,FF4R,XG,FF5R,XH, &
+     &     T_NEW(I,K,J),DT,rhocgs(I,K,J),COL,ICEMAX,NKR)
+         END IF
+        ENDIF
+!       IF (T_OLD(I,K,J).GT.223)THEN     
+        IF (T_OLD(I,K,J).GT.213)THEN     
+         TT=T_OLD(I,K,J)
+         QQ=QV_OLD(I,K,J)
+ !        IF (QQ.LE.0)print*,'QQ < 0'
+         IF (QQ.LE.0)QQ=1.D-10
+         PP=pcgs(I,K,J)
+         TTA=T_NEW(I,K,J)
+         QQA=QV(I,K,J)
+         IF (QQA.LE.0) call wrf_message("WARNING: FULL SBM, QQA < 0   ")
+ !        IF (QQA.LE.0)print*,'QQA = ',qqa
+ !        IF (QQA.LE.0)print*,'i,k,j = ',i,k,j
+ !        IF (QQA.LE.0)print*,'tta = ',tta
+ !        IF (QQA.LE.0)print*,'tt = ',tt
+ !        IF (QQA.LE.0)print*,'qq = ',qq
+ !        IF (QQA.LE.0)QQA=1.D-10
+         ES1N=AA1_MY*DEXP(-BB1_MY/TT)
+         ES2N=AA2_MY*DEXP(-BB2_MY/TT)
+         EW1N=QQ*PP/(0.622+0.378*QQ)
+         DIV1=EW1N/ES1N
+         DEL1IN=EW1N/ES1N-1.
+         DIV2=EW1N/ES2N
+         DEL2IN=EW1N/ES2N-1.
+         ES1N=AA1_MY*DEXP(-BB1_MY/TTA)
+         ES2N=AA2_MY*DEXP(-BB2_MY/TTA)
+         EW1N=QQA*PP/(0.622+0.378*QQA)
+         DIV3=EW1N/ES1N
+         DEL1AD=EW1N/ES1N-1.
+         DIV4=EW1N/ES2N
+         DEL2AD=EW1N/ES2N-1.
+         SUP2_OLD=DEL2IN
+         DELSUP1=(DEL1AD-DEL1IN)/NCOND
+         DELSUP2=(DEL2AD-DEL2IN)/NCOND
+         DELDIV1=(DIV3-DIV1)/NCOND
+         DELDIV2=(DIV4-DIV2)/NCOND
+         DELTATEMP=0
+         DELTAQ=0
+         tt_old = TT
+         qq_old = qq
+         DIFFU=1
+         DO IKL=1,NCOND
+          IF (DIFFU.NE.0)THEN
+          DEL1IN=DEL1IN+DELSUP1
+          DEL2IN=DEL2IN+DELSUP2
+          DIV1=DIV1+DELDIV1
+          DIV2=DIV2+DELDIV2
+          END IF
+!959       format (' ',i3,1x,f7.1,1x,f6.1,1x,f6.4,1x,f6.2,1x,f6.3)
+          IF (DIV1.GT.DIV2.AND.TT.LE.265)THEN
+!          print*,'div1 > div2',div1,div2
+!          print*,'delsup1, delsup2 = ',delsup1,delsup2
+!          print*,'del1in, del2in = ',del1in,del2in
+!          print*,'STOP'
+!          print*,'RESET'
+!          print*,'ikl,i,j,k = ',ikl,i,j,k
+!          print*,'zcgs = ',zcgs(i,k,j)
+!          print*,'tt,qq = ',tt,qq
+!          DIV1=0.99999*DIV2
+!          DEL1IN=0.99999*DEL2IN
+!          STOP
+           DIFFU=0
+          END IF
+          IF (DIFFU.NE.0)THEN
+          DEL1NR=A1_MYN*(100.*DIV1)
+          DEL2NR=A2_MYN*(100.*DIV2)
+     !     IF (DEL2NR.EQ.0)PRINT*,'DEL2NR = 0'
+     !     IF (DEL2NR.EQ.0)PRINT*,'DEL2NR = 0'
+     !     IF (DEL2NR.EQ.0)PRINT*,'DELDIV2 = ',DELDIV2
+     !     IF (DEL2NR.EQ.0)PRINT*,'DIV1 = ',DIV1
+     !     IF (DEL2NR.EQ.0)PRINT*,'DIV2 = ',DIV2
+          IF (DEL2NR.EQ.0)call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL2NR.EQ.0) , model stop ")
+          DEL12R=DEL1NR/DEL2NR
+          DEL12RD=DEL12R**DEL_BBR
+          EW1PN=AA1_MY*100.*DIV1*DEL12RD/100.
+          TT=-DEL_BB/DLOG(DEL12R)
+          QQ=0.622*EW1PN/(PP-0.378*EW1PN)
+
+          DO KR=1,NKR
+            FF1IN(KR)=FF1R(KR)
+            DO ICE=1,ICEMAX
+             FF2IN(KR,ICE)=FF2R(KR,ICE)
+            ENDDO
+          ENDDO
+          IF (BULKNUC.eq.1)THEN
+            IF (DEL1IN.GT.0)THEN
+              IF (zcgs(I,K,J).LE.500.E2)THEN
+                FACTZ=0.
+              ELSE
+                FACTZ=1
+!               FACTZ=EXP(-(zcgs(I,K,J)-2.E5)/Z0IN)
+              END IF
+             CONCCCN_XZ=FACTZ*ACCN*(100.*DEL1IN)**BCCN
+
+             CONCDROP=0.D0
+
+             DO KR=1,NKR
+               CONCDROP=CONCDROP+FF1IN(KR)*XL(KR)
+             ENDDO
+
+             CONCDROP=CONCDROP*3.D0*COL
+             IF(CONCCCN_XZ.GT.CONCDROP) &
+     &       FF1IN(1)=FF1IN(1)+(CONCCCN_XZ-CONCDROP)/(3.D0*COL*XL(1))
+            END IF
+          ELSE
+            IF(DEL1IN.GT.0.OR.DEL2IN.GT.0)THEN
+             CALL JERNUCL01(FF1IN,FF2IN,FCCN &
+     &       ,XL,XI,TT,QQ &
+     &       ,rhocgs(I,K,J),pcgs(I,K,J) &
+     &       ,DEL1IN,DEL2IN &
+     &       ,COL,AA1_MY, BB1_MY, AA2_MY,BB2_MY &
+     &       ,C1_MEY,C2_MEY,SUP2_OLD,DSUPICE_XYZ(I,K,J) &
+     &       ,RCCN,DROPRADII,NKR,ICEMAX,ICEPROCS)
+             IF (T_OLD(I,K,J).GT.220.AND.T_OLD(I,K,J).LE.233)THEN
+              DO KR=1,NKR
+               FF2IN(KR,2)=FF2IN(KR,2)+FF1IN(KR)
+               FF1IN(KR)=0.
+              END DO
+             END IF
+            END IF
+ 
+          END IF
+!  
+          DO KR=1,NKR
+            FF1R(KR)=FF1IN(KR)
+            DO ICE=1,ICEMAX
+             FF2R(KR,ICE)=FF2IN(KR,ICE)
+            ENDDO
+          ENDDO
+          FMAX1=0.
+          FMAX2=0.
+          FMAX3=0.
+          FMAX4=0.
+          FMAX5=0.
+          DO KR=1,NKR
+            FF1IN(KR)=FF1R(KR)
+            FMAX1=AMAX1(FF1R(KR),FMAX1)
+            FF3IN(KR)=FF3R(KR)
+            FMAX3=AMAX1(FF3R(KR),FMAX3)
+            FF4IN(KR)=FF4R(KR)
+            FMAX4=AMAX1(FF4R(KR),FMAX4)
+            FF5IN(KR)=FF5R(KR)
+            FMAX5=AMAX1(FF5R(KR),FMAX5)
+            DO ICE=1,ICEMAX
+             FF2IN(KR,ICE)=FF2R(KR,ICE)
+             FMAX2=AMAX1(FF2R(KR,ICE),FMAX2)
+            END DO
+          END DO
+          ISYM1=0
+          ISYM2=0
+          ISYM3=0
+          ISYM4=0
+          ISYM5=0
+          IF(FMAX1.GT.0)ISYM1=1
+          IF (ICEPROCS.EQ.1)THEN
+           IF(FMAX2.GT.1.E-4)ISYM2=1
+           IF(FMAX3.GT.1.E-4)ISYM3=1
+           IF(FMAX4.GT.1.E-4)ISYM4=1
+           IF(FMAX5.GT.1.E-4)ISYM5=1
+          END IF
+! Avoid Diffusional Growth
+!         IF (T_OLD(I,K,J).GE.237)THEN     
+! Same temperature range as above.
+!         IF (T_OLD(I,K,J).GT.233)THEN
+          IF(ISYM1.EQ.1.AND.((TT-273.15).GT.-0.187.OR. &
+     &     (ISYM2.EQ.0.AND. &
+     &     ISYM3.EQ.0.AND.ISYM4.EQ.0.AND.ISYM5.EQ.0)))THEN
+           IF (T_OLD(I,K,J).GT.233)THEN     
+           CALL ONECOND1(TT,QQ,PP,rhocgs(I,K,J) &
+     &      ,VR1,pcgs(I,K,J) &
+     &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
+     &      ,FF1R,FF1IN,XL,RLEC,RO1BL &
+     &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &      ,C1_MEY,C2_MEY &
+     &      ,COL,DTCOND,ICEMAX,NKR)
+           END IF
+          ELSE IF(ISYM1.EQ.0.AND.(TT-273.15).LE.-0.187.AND. &
+     &     (ISYM2.EQ.1.OR.ISYM3.EQ.1.OR.ISYM4.EQ.1.OR.ISYM5.EQ.1))THEN
+           IF (T_OLD(I,K,J).GT.233)THEN     
+           CALL ONECOND2(TT,QQ,PP,rhocgs(I,K,J) &
+     &      ,VR2,VR3,VR4,VR5,pcgs(I,K,J) &
+     &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
+     &      ,FF2R,FF2IN,XI,RIEC,RO2BL &
+     &      ,FF3R,FF3IN,XS,RSEC,RO3BL &
+     &      ,FF4R,FF4IN,XG,RGEC,RO4BL &
+     &      ,FF5R,FF5IN,XH,RHEC,RO5BL &
+     &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &      ,C1_MEY,C2_MEY &
+     &      ,COL,DTCOND,ICEMAX,NKR &
+     &      ,ISYM2,ISYM3,ISYM4,ISYM5)
+           END IF
+          ELSE IF(ISYM1.EQ.1.AND.(TT-273.15).LE.-0.187.AND. &
+     &     (ISYM2.EQ.1.OR.ISYM3.EQ.1.OR.ISYM4.EQ.1 &
+     &     .OR.ISYM5.EQ.1))THEN
+           CALL ONECOND3(TT,QQ,PP,rhocgs(I,K,J) &
+     &      ,VR1,VR2,VR3,VR4,VR5,pcgs(I,K,J) &
+     &      ,DEL1IN,DEL2IN,DIV1,DIV2 &
+     &      ,FF1R,FF1IN,XL,RLEC,RO1BL &
+     &      ,FF2R,FF2IN,XI,RIEC,RO2BL &
+     &      ,FF3R,FF3IN,XS,RSEC,RO3BL &
+     &      ,FF4R,FF4IN,XG,RGEC,RO4BL &
+     &      ,FF5R,FF5IN,XH,RHEC,RO5BL &
+     &      ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &      ,C1_MEY,C2_MEY &
+     &      ,COL,DTCOND,ICEMAX,NKR &
+     &      ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
+          END IF
+          END IF
+!         END IF
+             IF (IKL.EQ.NCOND)CALL COAL_BOTT_NEW(FF1R,FF2R,FF3R, &
+     &       FF4R,FF5R,TT,QQ,PP,rhocgs(I,K,J),dt_coll,TCRIT,TTCOAL)
+         END DO
+         IF (DIFFU.EQ.0)THEN
+         th_phy(i,k,j) = tt_old/pi_phy(i,k,j)
+         qv(i,k,j)=qq_old
+!        print*,'problem calculating diffusion in sbm'
+!        print*,'tt_old = ',tt_old
+!        print*,'qq_old = ',qq_old
+         ELSE
+         th_phy(i,k,j) = tt/pi_phy(i,k,j)
+         qv(i,k,j)=qq
+         END IF
+        END IF
+! LIQIUD
+        IF (REMSAT.EQ.1)THEN
+        DO KR=1,NKR
+         FF1R(KR)=0.
+         FCCN(KR)=0
+         IF (ICEPROCS.EQ.1)THEN
+          FF2R(KR,1)=0.
+          FF2R(KR,2)=0.
+          FF2R(KR,3)=0.
+          FF3R(KR)=0.
+          FF4R(KR)=0.
+          FF5R(KR)=0.
+         END IF
+        END DO
+        END IF
+!Liquid Water
+!Alex is not responsible the "2" below.
+!Alex is responsible fo rthe geo_cs formulas.
+        kext_ql(i,k,j)=0.
+        krr=0
+        DO kr=p_ff1i01,p_ff1i33
+          KRR=KRR+1
+          chem_new(I,K,J,KR)=FF1R(KRR)
+          geo_cs=3.1415*(3.*xl(krr)/(4.*3.1415*1.))**(2./3.)
+          ft=0.
+          kext_ql(i,k,j)=kext_ql(i,k,j)+(1.-ft_liq(krr))*2.*geo_cs*(100.*col*3.*xl(krr))*ff1r(krr)
+!         if (i.eq.ime/2.and.j.eq.jme/2.and.k.eq.10)then
+!         if (krr.eq.1)write(6,*)'ft_bin_water information'
+!            geo_cs=3.1415*(3.*xl(krr)/(4.*3.1415*1.))**(2./3.)
+!           write(6,901)krr,xl(krr),ro1bl(krr),RADXXO(krr,1),geo_cs
+!         end if
+
+        END DO   
+! He wants per meter, so we multiply by 100 above
+! CCN
+        KRR=0
+        kext_qa(i,k,j)=0.
+        DO kr=p_ff8i01,p_ff8i33
+          KRR=KRR+1
+          chem_new(I,K,J,KR)=FCCN(KRR)
+           geo_cs=3.1415*(3*XCCN(krr)/(4*3.1415*0.4))**(2./3.)
+           kext_qa(i,k,j)=kext_qa(i,k,j)+2.*geo_cs*fccn(krr)
+
+        END DO
+        IF (ICEPROCS.EQ.1)THEN
+!SNOW
+         EFF_NI(i,k,j)=0.
+         eff_di(i,k,j)=0.
+         EFF_NQIC=0
+         EFF_DQIC=0
+         EFF_NQIP=0
+         EFF_DQIP=0
+         EFF_NQID=0
+         EFF_DQID=0
+         KRR=0
+         kext_qs(i,k,j)=0.
+         kext_ft_qs(i,k,j)=0.
+         lambda = 0.55
+         chi0 = 0.00000
+         xi1 = 0.12534e-2
+         xi2 = 0.38929e-2
+         xi3 = 0.36593
+         xi4 = 0.38827e-1
+         xi5 = 0.87616
+         DO kr=p_ff5i01,p_ff5i33
+          KRR=KRR+1
+          chem_new(I,K,J,KR)=FF3R(KRR)
+          geo_cs=3.1415*(xs(krr)/(1.2*3.1415*ro3bl(krr)))**(2./3.)
+          volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XS(KRR)
+          surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XS(KRR)
+          if (surface_area.ne.0.and.volume.ne.0)then
+          r_e = 3.0/4.0*volume/surface_area
+          chi_e = 2.0*pi*(r_e*1.E4)/lambda
+
+          f1 = (1.0 - xi1)* &
+     &         (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
+          f2 = (1.0 - xi3)* &
+     &         (1.0 - exp(-xi4*(chi_e - chi0)))
+          if(chi_e.le.chi0) then 
+             ft = 0
+          else 
+           ft = (1.0 - xi5)*f1 + xi5*f2
+          end if
+          else 
+          ft=0.
+          end if
+          ft=0.
+          kext_qs(i,k,j)=kext_qs(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3.*xs(krr))*ff3r(krr)
+         END DO
+
+! HERE
+! Graupel
+         KRR=0
+         kext_qg(i,k,j)=0.
+         kext_ft_qg(i,k,j)=0.
+       lambda = 0.55
+       chi0 = 0.00000
+       xi1 = 0.39026e-1
+       xi2 = 0.94264e-5
+       xi3 = 0.11281e-2
+       xi4 = 0.35218e-1
+       xi5 = 0.51453
+         DO kr=p_ff6i01,p_ff6i33
+          KRR=KRR+1
+          chem_new(I,K,J,KR)=FF4R(KRR)
+          geo_cs=3.1415*(3.*xg(krr)/(4.*3.1415*0.4))**(2./3.)
+          volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XG(KRR)
+          surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XG(KRR)
+          if (surface_area.ne.0.and.volume.ne.0)then
+          r_e = 3.0/4.0*volume/surface_area
+          chi_e = 2.0*pi*(r_e*1.E4)/lambda
+
+          f1 = (1.0 - xi1)* &
+     &         (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
+          f2 = (1.0 - xi3)* &
+     &         (1.0 - exp(-xi4*(chi_e - chi0)))
+          if(chi_e.le.chi0) then 
+             ft = 0
+          else 
+           ft = (1.0 - xi5)*f1 + xi5*f2
+          end if
+          else 
+          ft=0.
+          end if
+          ft=0.
+          kext_qg(i,k,j)=kext_qg(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3.*xg(krr))*ff4r(krr)
+         END DO
+
+! Columns
+         KRR=0
+         kext_qic(i,k,j)=0.
+         kext_ft_qic(i,k,j)=0.
+       lambda = 0.55
+       chi0 = 0.00000
+       xi1 = 0.60202
+       xi2 = 0.85513e-3
+       xi3 = 0.97065e-1
+       xi4 = 0.21320e-1
+       xi5 = 0.66985
+         DO kr=p_ff2i01,p_ff2i33
+          KRR=KRR+1
+          chem_new(I,K,J,KR)=FF2R(KRR,1)
+          geo_cs=0.26*(xi(krr,1)/(ro2bl(krr,1)*0.2))**1.28
+          volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,1)
+          surface_area=sqrt(geo_cs/3.1415)**2.*chem_new(i,k,j,KR)*XI(KRR,1)
+          if (surface_area.ne.0.and.volume.ne.0)then
+          r_e = 3.0/4.0*volume/surface_area
+          chi_e = 2.0*pi*(r_e*1.E4)/lambda
+
+          f1 = (1.0 - xi1)* &
+     &         (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
+          f2 = (1.0 - xi3)* &
+     &         (1.0 - exp(-xi4*(chi_e - chi0)))
+          if(chi_e.le.chi0) then 
+             ft = 0
+          else 
+           ft = (1.0 - xi5)*f1 + xi5*f2
+          end if
+          else
+          ft=0.
+          end if
+          ft=0.
+          kext_qic(i,k,j)=kext_qic(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3.*xi(krr,1))*ff2r(krr,1)
+          EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,1)+EFF_NI(i,k,j)
+          eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,1)+eff_di(i,k,j)
+          EFF_NQIC=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,1)+EFF_NQIC
+          eff_dqic=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,1)+eff_dqic
+         END DO
+         IF (EFF_DQIC.NE.0)THEN
+         QIC_EFFR(I,K,J)=EFF_NQIC/EFF_DQIC
+         ELSE
+         QIC_EFFR(I,K,J)=0.
+         END IF
+         krr=0
+
+901      format(' ',i3,1x,f12.9,1x,3(f12.9,1x),f12.6,f12.3,1x,10(f12.8,1x))
+
+! Plates
+         KRR=0
+         kext_qip(i,k,j)=0.
+       lambda = 0.55
+       chi0 = 0.00000
+       xi1 = 0.23397e-2
+       xi2 = 0.19513e-2
+       xi3 = 0.51912e-4
+       xi4 = 0.15159e-1
+       xi5 = 0.81012
+         DO kr=p_ff3i01,p_ff3i33
+          KRR=KRR+1
+          chem_new(I,K,J,KR)=FF2R(KRR,2)
+          geo_cs=(3.1415/4)*(xi(krr,2)/(ro2bl(krr,2)*0.108))**0.72
+          volume=sqrt(geo_cs/3.1415)**3.*chem_new(i,k,j,KR)*XI(KRR,2)
+          surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,2)
+          if (surface_area.ne.0.and.volume.ne.0)then
+          r_e = 3.0/4.0*volume/surface_area
+          chi_e = 2.0*pi*(r_e*1.E4)/lambda
+
+          f1 = (1.0 - xi1)* &
+     &         (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
+          f2 = (1.0 - xi3)* &
+     &         (1.0 - exp(-xi4*(chi_e - chi0)))
+          if(chi_e.le.chi0) then 
+             ft = 0
+          else 
+           ft = (1.0 - xi5)*f1 + xi5*f2
+          end if
+          else 
+           ft=0.
+          end if
+          ft=0.
+          kext_qip(i,k,j)=kext_qip(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3*xi(krr,2))*ff2r(krr,2)
+          EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,2)+EFF_NI(i,k,j)
+          eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,2)+eff_di(i,k,j)
+          EFF_NQIP=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,2)+EFF_NQIP
+          eff_dqiP=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,2)+eff_dqip
+         END DO
+         IF (EFF_DQIP.NE.0)THEN
+         QIP_EFFR(I,K,J)=EFF_NQIP/EFF_DQIP
+         ELSE
+         QIP_EFFR(I,K,J)=0.
+         END IF
+
+
+
+!             s=(3.1415/4)*0.097**(-0.72)*(m(nkr))**0.72^M
+! Dendrites
+         KRR=0
+         kext_qid(i,k,j)=0.
+         lambda = 0.55
+         chi0 = 0.00000
+         xi1 = 0.14875
+         xi2 = 0.49514e-2
+         xi3 = 0.36201
+         xi4 = 0.36993e-1
+         xi5 = 0.87020
+         DO KR=p_ff4i01,p_ff4i33
+          KRR=KRR+1
+          chem_new(I,K,J,KR)=FF2R(KRR,3)
+          geo_cs=(3.1415/4)*(xi(krr,3)/(ro2bl(krr,3)*7.8E-3))**0.828
+          volume=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,3)
+          surface_area=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,3)
+          if (surface_area.ne.0.and.volume.ne.0)then
+          r_e = 3.0/4.0*volume/surface_area
+          chi_e = 2.0*pi*(r_e*1.E4)/lambda
+
+          f1 = (1.0 - xi1)* &
+     &         (1.0 - (1.0 - exp(-xi2*(chi_e - chi0)))/xi2/(chi_e - chi0))
+          f2 = (1.0 - xi3)* &
+     &         (1.0 - exp(-xi4*(chi_e - chi0)))
+          if(chi_e.le.chi0) then 
+             ft = 0
+          else 
+           ft = (1.0 - xi5)*f1 + xi5*f2
+          end if
+          else
+           ft=0.
+          end if
+          ft=0.
+          kext_qid(i,k,j)=kext_qid(i,k,j)+(1.-ft)*2.*geo_cs*(100.*col*3*xi(krr,3))*ff2r(krr,3)
+          EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,3)+EFF_NI(i,k,j)
+          eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,3)+eff_di(i,k,j)
+          EFF_NQID=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XI(KRR,3)+EFF_NQID
+          eff_dqiD=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XI(KRR,3)+eff_dqiD
+         END DO
+         IF (EFF_DQID.NE.0)THEN
+         QID_EFFR(I,K,J)=EFF_NQID/EFF_DQID
+         ELSE
+         QID_EFFR(I,K,J)=0.
+         END IF
+
+!s=(3.1415/4)*(4.6*(10**(-3.377)))**(-0.98)*(m(nkr))**0.98
+! HAIL
+         KRR=0
+         kext_qh(i,k,j)=0.
+         DO KR=p_ff7i01,p_ff7i33
+          KRR=KRR+1
+          chem_new(I,K,J,KR)=FF5R(KRR)
+          geo_cs=3.1415*(3*xh(krr)/(4*3.1415*0.9))**(2/3)
+          kext_qh(i,k,j)=kext_qh(i,k,j)+2.*geo_cs*(100.*col*3*xh(krr))*ff5r(krr)
+          EFF_NI(i,k,j)=sqrt(geo_cs/3.1415)**3*chem_new(i,k,j,KR)*XH(KRR)+EFF_NI(i,k,j)
+          eff_di(i,k,j)=sqrt(geo_cs/3.1415)**2*chem_new(i,k,j,KR)*XH(KRR)+eff_di(i,k,j)
+         END DO
+
+        END IF
+      END DO
+      END DO
+      END DO
+
+      NKRO=1
+      NKRE=NKR
+      DO j = jts,jte
+      DO i = its,ite
+      DO k = kts,kte
+      rhocgs_z(k)=rhocgs(i,k,j)
+      pcgs_z(k)=pcgs(i,k,j)
+      zcgs_z(k)=zcgs(i,k,j)
+      krr=0
+      do kr=p_ff1i01,p_ff1i33
+       krr=krr+1
+       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
+      end do
+      end do
+      CALL FALFLUXHUCM(ffx_z,VR1,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
+      DO k = kts,kte
+      krr=0
+      do kr=p_ff1i01,p_ff1i33
+       krr=krr+1
+       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
+      end do
+      end do
+      if (iceprocs.eq.1)then
+      DO k = kts,kte
+      rhocgs_z(k)=rhocgs(i,k,j)
+      pcgs_z(k)=pcgs(i,k,j)
+      zcgs_z(k)=zcgs(i,k,j)
+      krr=0
+      do kr=p_ff5i01,p_ff5i33
+       krr=krr+1
+       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
+      end do
+      end do
+      CALL FALFLUXHUCM(ffx_z,VR3,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
+      DO k = kts,kte
+      krr=0
+      do kr=p_ff5i01,p_ff5i33
+       krr=krr+1
+       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
+      end do
+      end do
+      DO k = kts,kte
+      rhocgs_z(k)=rhocgs(i,k,j)
+      pcgs_z(k)=pcgs(i,k,j)
+      zcgs_z(k)=zcgs(i,k,j)
+      krr=0
+      do kr=p_ff6i01,p_ff6i33
+       krr=krr+1
+       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
+      end do
+      end do
+      CALL FALFLUXHUCM(ffx_z,VR4,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
+      DO k = kts,kte
+      krr=0
+      do kr=p_ff6i01,p_ff6i33
+       krr=krr+1
+       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
+      end do
+      end do
+!    &     ims,ime,jms,jme,kms,kme)
+      DO k = kts,kte
+      rhocgs_z(k)=rhocgs(i,k,j)
+      pcgs_z(k)=pcgs(i,k,j)
+      zcgs_z(k)=zcgs(i,k,j)
+      krr=0
+      do kr=p_ff2i01,p_ff2i33
+       krr=krr+1
+       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
+       vri(krr)=vr2(krr,1)
+      end do
+      end do
+      CALL FALFLUXHUCM(ffx_z,VRI,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
+      DO k = kts,kte
+      krr=0
+      do kr=p_ff2i01,p_ff2i33
+       krr=krr+1
+       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
+      end do
+      end do
+      DO k = kts,kte
+      rhocgs_z(k)=rhocgs(i,k,j)
+      pcgs_z(k)=pcgs(i,k,j)
+      zcgs_z(k)=zcgs(i,k,j)
+      krr=0
+      do kr=p_ff3i01,p_ff3i33
+       krr=krr+1
+       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
+       vri(krr)=vr2(krr,2)
+      end do
+      end do
+      CALL FALFLUXHUCM(ffx_z,VRI,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
+      DO k = kts,kte
+      krr=0
+      do kr=p_ff3i01,p_ff3i33
+       krr=krr+1
+       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
+      end do
+      end do
+      DO k = kts,kte
+      rhocgs_z(k)=rhocgs(i,k,j)
+      pcgs_z(k)=pcgs(i,k,j)
+      zcgs_z(k)=zcgs(i,k,j)
+      krr=0
+      do kr=p_ff4i01,p_ff4i33
+       krr=krr+1
+       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
+       vri(krr)=vr2(krr,3)
+      end do
+      end do
+      CALL FALFLUXHUCM(ffx_z,VRI,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
+      DO k = kts,kte
+      krr=0
+      do kr=p_ff4i01,p_ff4i33
+       krr=krr+1
+       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
+      end do
+      end do
+      DO k = kts,kte
+      rhocgs_z(k)=rhocgs(i,k,j)
+      pcgs_z(k)=pcgs(i,k,j)
+      zcgs_z(k)=zcgs(i,k,j)
+      krr=0
+      do kr=p_ff7i01,p_ff7i33
+       krr=krr+1
+       ffx_z(k,krr)=chem_new(i,k,j,kr)/rhocgs(i,k,j)
+      end do
+      end do
+      CALL FALFLUXHUCM(ffx_z,VR5,RHOCGS_z,PCGS_z,ZCGS_z,DT,kts,kte,nkr)
+      DO k = kts,kte
+      krr=0
+      do kr=p_ff7i01,p_ff7i33
+       krr=krr+1
+       chem_new(i,k,j,kr)=ffx_z(k,krr)*rhocgs(i,k,j)
+      end do
+      end do
+      end if
+      end do 
+      end do 
+
+      gmax=0
+      qmax=0
+      imax=0
+      kmax=0
+      qnmax=0
+      inmax=0
+      knmax=0
+      DO j = jts,jte
+      DO k = kts,kte
+      DO i = its,ite
+      QC(I,K,J)=0
+      QR(I,K,J)=0
+      QIC(I,K,J)=0
+      QIP(I,K,J)=0
+      QID(I,K,J)=0
+      QS(I,K,J)=0
+      QG(I,K,J)=0
+      QH(I,K,J)=0
+      QNC(I,K,J)=0
+      QNR(I,K,J)=0
+      QNIP(I,K,J)=0
+      QNIC(I,K,J)=0
+      QNID(I,K,J)=0
+      QNS(I,K,J)=0
+      QNG(I,K,J)=0
+      QNH(I,K,J)=0
+      QNA(I,K,J)=0
+      tt= th_phy(i,k,j)*pi_phy(i,k,j)
+      DO KR=1,NKR
+      COLREFLL(KR)=COEFREFLL
+      COLREFLI(KR)=COEFREFLI
+        IF(TT.GE.271.15.AND.TT.LE.273.15) THEN
+               COLREFLS(KR)=COEFREF00/0.09
+               COLREFLG(KR)=COEFREF00/RO4BL(KR)/RO4BL(KR)
+               COLREFLH(KR)=COEFREF00/RO5BL(KR)/RO5BL(KR)
+        ELSE
+               COLREFLS(KR)=COEFREFLI
+               COLREFLG(KR)=COEFREFLI
+               COLREFLH(KR)=COEFREFLI
+        ENDIF
+      END DO
+!     END IF
+      EFF_N=0.
+      EFF_D=0.
+      KRR=0
+      DO KR = p_ff1i01,p_ff1i33
+        KRR=KRR+1
+        IF (KRR.LT.KRDROP)THEN
+          EFF_N=DROPRADII(KRR)**3*chem_new(i,k,j,KR)*XL(KRR)+EFF_N
+          EFF_D=DROPRADII(KRR)**2*chem_new(i,k,j,KR)*XL(KRR)+EFF_D
+          QC(I,K,J)=QC(I,K,J) &
+     &      +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3
+!          QNC(I,K,J)=QNC(I,K,J) &
+! J. Fan
+!     &      +COL*chem_new(I,K,J,KR)*XL(KR)*3
+           QNC(I,K,J)=QNC(I,K,J) &
+    &       +COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg
+        ELSE
+          QR(I,K,J)=QR(I,K,J) &
+     &      +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XL(KRR)*XL(KRR)*3
+          QNR(I,K,J)=QNR(I,K,J) &
+!     &      +COL*chem_new(I,K,J,KR)*XL(KR)*3
+     &      +COL*chem_new(I,K,J,KR)*XL(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
+        END IF
+      END DO
+      IF(QC(I,K,J).GT.1.E-6.and.EFF_D.GT.0)THEN
+          EFFR(I,K,J)=EFF_N/EFF_D
+      ELSE
+          EFFR(I,K,J)=0.
+      END IF
+      KRR=0
+      IF (ICEPROCS.EQ.1)THEN
+       KRR=0
+       DO  KR=p_ff5i01,p_ff5i33
+        KRR=KRR+1
+!       if (KRR.LE.KRICE)THEN
+!       QI(I,K,J)=QI(I,K,J) &
+!    &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3
+!       ELSE
+        QS(I,K,J)=QS(I,K,J) &
+     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XS(KRR)*XS(KRR)*3
+!       END IF
+        QNS(I,K,J)=QNS(I,K,J) &
+     &   +COL*chem_new(I,K,J,KR)*XS(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
+       END DO
+       KRR=0
+       DO  KR=p_ff6i01,p_ff6i33
+        KRR=KRR+1
+        QG(I,K,J)=QG(I,K,J) &
+     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XG(KRR)*XG(KRR)*3
+        QNG(I,K,J)=QNG(I,K,J) &
+!     &   +1000*COL*chem_new(I,K,J,KR)*XG(KRR)*3
+     &   +COL*chem_new(I,K,J,KR)*XG(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
+       END DO
+       KRR=0
+       DO  KR=p_ff2i01,p_ff2i33
+        KRR=KRR+1
+        QIC(I,K,J)=QIC(I,K,J) &
+     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XI(KRR,1)*XI(KRR,1)*3
+        QNIC(I,K,J)=QNIC(I,K,J) &
+     &   +COL*chem_new(I,K,J,KR)*XI(KRR,1)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
+       END DO
+       KRR=0
+       DO  KR=p_ff3i01,p_ff3i33
+        KRR=KRR+1
+        QIP(I,K,J)=QIP(I,K,J) &
+     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XI(KRR,2)*XI(KRR,2)*3
+        QNIP(I,K,J)=QNIP(I,K,J) &
+     &   +COL*chem_new(I,K,J,KR)*XI(KRR,2)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
+       END DO
+       KRR=0
+       DO  KR=p_ff4i01,p_ff4i33
+        KRR=KRR+1
+        QID(I,K,J)=QID(I,K,J) &
+     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XI(KRR,3)*XI(KRR,3)*3
+        QNID(I,K,J)=QNID(I,K,J) &
+     &   +COL*chem_new(I,K,J,KR)*XI(KRR,3)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
+       END DO
+         IF((QIP(I,K,J).GT.1.E-6.OR.QIC(I,K,J).GT.1.E-6.OR.QID(I,K,J).GT.1.E-6)&
+     &   .and.eff_di(i,k,j).GT.0)THEN
+          ICE_EFFR(I,K,J)=EFF_NI(i,k,j)/eff_di(i,k,j)
+         ELSE
+          ICE_EFFR(I,K,J)=0.
+         END IF
+      END IF
+       KRR=0
+       DO  KR=p_ff8i01,p_ff8i33
+        KRR=KRR+1
+        QNA(I,K,J)=QNA(I,K,J) &
+!     &   +COL*chem_new(I,K,J,KR)*3
+!  change by J.Fan
+     &   +COL*chem_new(I,K,J,KR)/rhocgs(I,K,J)*1000.   ! #/kg
+       END DO
+!       if (i.eq.100.and.j.eq.100)then
+!       print*,'qna = ', k,qna(i,k,j)
+!       end if
+       KRR=0
+       DO  KR=p_ff7i01,p_ff7i33
+        KRR=KRR+1
+        QH(I,K,J)=QH(I,K,J) &
+     &   +(1./RHOCGS(I,K,J))*COL*chem_new(I,K,J,KR)*XH(KRR)*XH(KRR)*3
+        QNH(I,K,J)=QNH(I,K,J) &
+     &   +COL*chem_new(I,K,J,KR)*XH(KRR)*3/rhocgs(I,K,J)*1000. ! #/kg by Fan
+       END DO
+      END DO
+      END DO
+      END DO
+
+
+
+
+998   format(' ',10(f10.1,1x))
+      DO j = jts,jte
+      DO i = its,ite
+       krr=0
+       DO KR=p_ff1i01,p_ff1i33
+        krr=krr+1
+        DELTAW=VR1(KRR)
+        RAINNC(I,J)=RAINNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
+       END DO
+       KRR=0
+       DO KR=p_ff5i01,p_ff5i33
+        KRR=KRR+1
+        DELTAW=VR3(KRR)
+        RAINNC(I,J)=RAINNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
+       END DO
+       KRR=0
+       DO KR=p_ff6i01,p_ff6i33
+        KRR=KRR+1
+        DELTAW=VR4(KRR)
+        RAINNC(I,J)=RAINNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
+       END DO
+       KRR=0
+       DO KR=p_ff2i01,p_ff2i33
+        KRR=KRR+1
+        DELTAW=VR2(KRR,1)
+        RAINNC(I,J)=RAINNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
+       END DO
+       KRR=0
+       DO KR=p_ff3i01,p_ff3i33
+        KRR=KRR+1
+        DELTAW=VR2(KRR,2)
+        RAINNC(I,J)=RAINNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
+       END DO
+       KRR=0
+       DO KR=p_ff4i01,p_ff4i33
+        KRR=KRR+1
+        DELTAW=VR2(KRR,3)
+        RAINNC(I,J)=RAINNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
+       END DO
+       KRR=0
+       DO KR=p_ff7i01,p_ff7i33
+        KRR=KRR+1
+        DELTAW=VR5(KRR)
+        RAINNC(I,J)=RAINNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
+       END DO
+!     print*, i,j,rainnc(i,j)
+  ! Transfer 1D arrays back into 3D arrays
+   !
+      do k=kts,kte
+
+
+          qv1d(k)=qv(i,k,j)
+          qr1d(k)=qr(i,k,j)
+          nr1d(k)=qnr(i,k,j)
+          qs1d(k)=qs(i,k,j)
+          ns1d(k)=qns(i,k,j)
+          qg1d(k)=qg(i,k,j)+qh(i,k,j)
+          ng1d(k)=qng(i,k,j)+qnh(i,k,j)
+          t1d(k)=th_phy(i,k,j)*pi_phy(i,k,j)
+          p1d(k)=P_PHY(I,K,J)
+       end do
+! wrf-chem
+
+!+---+-----------------------------------------------------------------+
+         IF ( PRESENT (diagflag) ) THEN
+         if (diagflag .and. do_radar_ref == 1) then
+          call refl10cm_hm (qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d,   &
+                      t1d, p1d, dBZ, kts, kte, i, j)
+          do k = kts, kte
+             refl_10cm(i,k,j) = MAX(-35., dBZ(k))
+          enddo
+         endif
+         ENDIF
+
+      END DO
+      END DO
+
+
+!     print*,'here 7'
+      do j=jts,jte
+      do k=kts,kte
+      do i=its,ite
+!        th_old_2(i,k,j)=th_phy(i,k,j)
+!        qv_old_2(i,k,j)=qv(i,k,j)
+         th_old(i,k,j)=th_phy(i,k,j)
+         qv_old(i,k,j)=qv(i,k,j)
+!     if(i.eq.64.and.j.eq.2.and.k.eq.16)then
+!        print*,'th_phy(I,K,J),tt = ',th_phy(I,K,J),tt
+!        print*,'qv(I,K,J) = ',qv(I,K,J)
+!     end if
+      end do
+      end do
+      end do
+!     stop
+!     print*,'here 8'
+      if (conserv)then
+      DO j = jts,jte
+      DO i = its,ite
+      DO k = kts,kte
+      rhocgs(I,K,J)=rho_phy(I,K,J)*0.001
+      krr=0
+      DO KR=p_ff1i01,p_ff1i33
+        krr=krr+1
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XL(KRR)*XL(KRR)*3.0
+       if (qc(i,k,j)+qr(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
+      END DO
+      KRR=0
+      DO KR=p_ff5i01,p_ff5i33
+       KRR=KRR+1
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XS(KRR)*XS(KRR)*3.0
+       if (qs(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
+      END DO
+      KRR=0
+      DO KR=p_ff6i01,p_ff6i33
+       KRR=KRR+1
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XG(KRR)*XG(KRR)*3.0
+       if (qg(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
+      END DO
+      KRR=0
+!      if (i.eq.100.and.j.eq.100)then
+!       print*,'qna 3 = ', k,qna(i,k,j)
+!      end if
+      DO KR=p_ff8i01,p_ff8i33
+       KRR=KRR+1
+! change by Fan
+!       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*XCCN(KRR)
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*1000.          ! #/kg; remember chem_new for CCN is #/cm3, not #/(gcm-3)
+      END DO
+!      if (i.eq.100.and.j.eq.100)then
+!       print*,'qna  4 = ', k,qna(i,k,j)
+!      end if
+      KRR=0
+      DO KR=p_ff2i01,p_ff2i33
+       KRR=KRR+1
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XI(KRR,1)*XI(KRR,1)*3.0
+       if (qic(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
+      END DO
+      KRR=0
+      DO KR=p_ff3i01,p_ff3i33
+       KRR=KRR+1
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XI(KRR,2)*XI(KRR,2)*3.0
+       if (qip(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
+      END DO
+      KRR=0
+      DO KR=p_ff4i01,p_ff4i33
+       KRR=KRR+1
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XI(KRR,3)*XI(KRR,3)*3.0
+       if (qid(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
+      END DO
+      KRR=0
+      DO KR=p_ff7i01,p_ff7i33
+       KRR=KRR+1
+       chem_new(I,K,J,KR)=chem_new(I,K,J,KR)/RHOCGS(I,K,J)*COL*XH(KRR)*XH(KRR)*3.0
+       if (qh(i,k,j).lt.1.e-13)chem_new(I,K,J,KR)=0.
+      END DO
+      END DO
+      END DO
+      END DO
+      END IF
+     
+!     print*,'here 9'
+      RETURN
+  END SUBROUTINE SBM
+      SUBROUTINE FALFLUXHUCM(chem_new,VR1,RHOCGS,PCGS,ZCGS,DT, &
+     &     kts,kte,nkr)
+      IMPLICIT NONE
+      INTEGER I,J,K,KR
+      INTEGER    kts,kte,nkr
+      REAL TFALL,DTFALL,VFALL(KTE),DWFLUX(KTE)
+      REAL DT
+      INTEGER IFALL,N,NSUB
+      REAL, DIMENSION( kts:kte,nkr ) :: chem_new 
+      REAL,  DIMENSION(kts:kte) :: rhocgs,pcgs,zcgs
+      REAL VR1(NKR)
+
+! FALLING FLUXES FOR EACH KIND OF CLOUD PARTICLES: C.G.S. UNIT
+! ADAPTED FROM GSFC CODE FOR HUCM
+!  The flux at k=1 is assumed to be the ground so FLUX(1) is the
+! flux into the ground. DWFLUX(1) is at the lowest half level where
+! Q(1) etc are defined. The formula for FLUX(1) uses Q(1) etc which
+! is actually half a grid level above it. This is what is meant by
+! an upstream method. Upstream in this case is above because the
+! velocity is downwards.      
+! USE UPSTREAM METHOD (VFALL IS POSITIVE)                 
+!        print*,'pcgs(i,k,j) = ',pcgs(100,10,1)
+!        print*,'pcgs(i,k,j) = ',pcgs(100,1,1)
+!      read(5,*)
+!        print*,'pcgs(i,k,j) = ',zcgs(100,10,1)
+!        print*,'pcgs(i,k,j) = ',zcgs(100,1,1)
+!      read(5,*)
+      DO KR=1,NKR
+       IFALL=0
+       DO k = kts,kte
+          IF(chem_new(K,KR).GE.1.E-10)IFALL=1
+       END DO 
+       IF (IFALL.EQ.1)THEN
+        TFALL=1.E10                
+        DO K=kts,kte
+         VFALL(K) = VR1(KR)*SQRT(1.E6/PCGS(K))
+!        if (krr.eq.20.or.krr.eq.33)then
+!        if (k.eq.5.or.k.eq.10.or.k.eq.20)then
+!        print*,'vr1(krr) = ',krr,vr1(krr)
+!        print*, 'SQRT(1.E6/PCGS(I,K,J)) = ',i,k,SQRT(1.E6/PCGS(I,K,J))
+!        print*,'vfall(k) = ',i,k,vfall(k)
+!        print*,'zcgs(k) = ',i,k,zcgs(i,k,j)
+!        read(5,*)
+!        end if
+!        end if
+         TFALL=AMIN1(TFALL,ZCGS(K)/(VFALL(K)+1.E-20))    
+!        print*,'tfall = ',i,k,tfall
+!        if (krr.eq.5.or.krr.eq.10.or.krr.eq.20.or.krr.eq.33)read(5,*)
+        END DO                                                 
+        IF(TFALL.GE.1.E10) call wrf_error_fatal("fatal error in module_mp_full_sbm (TFALL.GE.1.E10), model stop")
+        NSUB=(INT(2.0*DT/TFALL)+1)                           
+        DTFALL=DT/NSUB                                      
+
+        DO N=1,NSUB                                    
+          DO K=KTS,KTE-1                               
+           DWFLUX(K)=-(RHOCGS(K)*VFALL(K)*chem_new(k,kr)- &
+     &     RHOCGS(K+1)* &
+     &     VFALL(K+1)*chem_new(K+1,KR))/(RHOCGS(K)*(ZCGS(K+1)- &
+     &      ZCGS(K)))    
+          END DO    
+! NO Z ABOVE TOP, SO USE THE SAME DELTAZ
+          DWFLUX(KTE)=-(RHOCGS(KTE)*VFALL(KTE)* & 
+     &       chem_new(kte,kr))/(RHOCGS(KTE)*(ZCGS(KTE)-ZCGS(KTE-1)))         
+          DO K=kts,kte                                         
+           chem_new(k,kr)=chem_new(k,kr)+DWFLUX(K)*DTFALL
+          END DO  
+        END DO  
+       END IF
+      END DO  
+      RETURN                                                                  
+      END SUBROUTINE FALFLUXHUCM                                                                    
+      SUBROUTINE FULL_HUCMINIT(DT)
+      IMPLICIT NONE
+      INTEGER IKERN_0,IKERN_Z,L0_REAL,L0_INTEGER,INEWMEY,INEST
+      INTEGER I,J,K,KR
+      REAL DT
+      INTEGER :: hujisbm_unit1
+      LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
+      LOGICAL :: opened 
+      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
+      CHARACTER*80 errmess
+      REAL PI
+      double precision ax
+      data pi/3.141592654/
+! dtime - timestep of integration (calculated in main program) :
+! ax - coefficient used for masses calculation 
+! ima(i,j) - k-category number, c(i,j) - courant number 
+
+        REAL C1(NKR,NKR)
+! DON'T NEED ALL THESE VARIABLES: STILL NEED EDITING
+       INTEGER ICE,KGRAN,IPRINT01
+       REAL TWSIN,TWCIN,TWNUC,XF5,XF4,XF3,CONCHIN,CONCGIN,CONCSIN, &
+     & CONCCLIN,TWHIN,RADH,RADS,RADG,RADL,CONCLIN,A1_MY,A2,A2_MY,XLK, &
+     & A1N,A3_MY,A3,A1_MYN,R0CCN,X0DROP,DEG01,CONTCCNIN,CONCCCNIN, &
+     & A,B,X0CCN,S_KR,RCCNKR,R0,X0,TWCALLIN,A1,RCCNKR_CM,SUMIIN,TWGIN, &
+     & XF1N,XF1,WC1N,RF1N,WNUC,RNUC,WC5,RF5, &
+     & WC4,RF4,WC3,RF3,WC1,RF1,SMAX
+       REAL TWIIN(ICEMAX)
+       REAL RO_SOLUTE      
+       REAL A_FALL,B_FALL
+       real graupel_fall(nkr)
+       data graupel_fall/0.36840E-01,0.57471E-01,0.88417E-01,0.13999E+00,&
+     &  0.22841E+00,0.36104E+00,0.56734E+00, 0.88417E+00, 0.13999E+01,&
+     &  0.22104E+01, 0.35367E+01, 0.54524E+01, 0.81049E+01,0.12526E+02,&
+     &  0.19157E+02, 0.27262E+02, 0.34627E+02, 0.39776E+02,0.45690E+02,& 
+     &  0.52485E+02, 0.60289E+02, 0.69254E+02, 0.10000E+03, 0.15429E+03,&
+     &  0.18561E+03, 0.22329E+03, 0.26863E+03,  0.32316E+03,0.38877E+03,& 
+     &  0.46770E+03, 0.56266E+03, 0.67690E+03,  0.81432E+03/
+
+       INTEGER  KZ_MIN,KZ_MAX
+       PARAMETER (RO_SOLUTE=2.16)
+       INTEGER KR_MIN,KR_MIN1,KR_MAX
+       REAL RADCCN_MIN,RADCCN_MIN1,RADCCN_MAX
+       REAL FR_CON,FR_MAR
+     REAL  ::      RHOSU       ! STANDARD AIR DENSITY AT 850 MB
+     REAL ::      RHOW        ! DENSITY OF LIQUID WATER
+     REAL ::      RHOI        ! BULK DENSITY OF CLOUD ICE
+     REAL ::      RHOSN       ! BULK DENSITY OF SNOW
+     REAL ::      RHOG        ! BULK DENSITY OF GRAUPEL
+     REAL ::      CI,DI,CS,DS,CG,DG ! SIZE DISTRIBUTION PARAMETERS FOR CLOUD ICE, SNOW, GRAUPE
+       FR_MAR=1.0
+!      FR_CON=1-FR_MAR
+       FR_CON=1.0
+
+!      KZ_MIN=16
+!      KZ_MAX=21
+
+
+
+        call wrf_message(" FULL SBM: INITIALIZING HUCM ")
+        call wrf_message(" FULL SBM: ****** HUCM ******* ")
+!        PRINT*, 'INITIALIZING HUCM'  
+!	print *, ' ****** HUCM *******'
+
+! INPUT :
+        dlnr=dlog(2.d0)/(3.d0*scal)
+!     print*,'here in hucmint 1'
+!
+!--- Read in various lookup tables
+!
+!        print*,'wrf_dm_on_monitor() =',wrf_dm_on_monitor() 
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2061
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2061     CONTINUE
+        ENDIF
+!
+!     print*,'here in hucmint 2',hujisbm_unit1
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!     print*,'here in hucmint 3',hujisbm_unit1
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+!       print*,'here at 1'
+!      print*,'here in hucmint 4'
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="capacity.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+
+  900	FORMAT(6E13.5)
+	READ(hujisbm_unit1,900) RLEC,RIEC,RSEC,RGEC,RHEC
+	CLOSE(hujisbm_unit1)
+!     print*,'here in hucmint 5'
+        END IF
+        CALL wrf_dm_bcast_bytes ( RLEC , size ( RLEC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( RIEC , size ( RIEC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( RSEC , size ( RSEC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( RGEC , size ( RGEC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( RHEC , size ( RHEC ) * RWORDSIZE )
+! MASSES :
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2062
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2062     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="masses.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+	READ(hujisbm_unit1,900) XL,XI,XS,XG,XH          
+	CLOSE(hujisbm_unit1)
+!	print *, ' ***** file2: succesfull *******'
+        call wrf_message(" FULL SBM: ****** file2: succesfull  ******* ")
+        ENDIF
+        CALL wrf_dm_bcast_bytes ( XL , size ( XL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( XI , size ( XI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( XS , size ( XS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( XG , size ( XG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( XH , size ( XH ) * RWORDSIZE )
+! TERMINAL VELOSITY :
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2063
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2063     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="termvels.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+	READ(hujisbm_unit1,900) VR1,VR2,VR3,VR4,VR5     
+	CLOSE(hujisbm_unit1)
+!	print *, ' ***** file3: succesfull *******'
+        call wrf_message(" FULL SBM: ****** file3: succesfull  ******* ")
+        ENDIF
+        CALL wrf_dm_bcast_bytes ( VR1 , size ( VR1 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VR2 , size ( VR2 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VR3 , size ( VR3 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VR4 , size ( VR4 ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( VR5 , size ( VR5 ) * RWORDSIZE )
+! CHANGE FALL VELOCITY OF GRAUPEL
+        DO KR=1,NKR
+!        A=RADXXO(KR,6)
+!        B=RADXXO(KR,7)
+         if (kr.le.17)then
+          A_FALL=1
+          B_FALL=0
+         else
+          B_FALL=1
+          A_FALL=0
+         end if
+  
+!        VR4(KR)=A_FALL*VR4(KR)+B_FALL*VR5(KR)
+!        print*,'vr4,vr5,graupel_fall=',vr3(kr),vr5(kr),graupel_fall(kr)
+!        VR4(KR)=graupel_fall(kr)
+        END DO
+ 
+! CONSTANTS :
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2065
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2065     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="constants.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+	READ(hujisbm_unit1,900) SLIC,TLIC,COEFIN,C2,C3,C4
+	CLOSE(hujisbm_unit1)
+!	print *, ' ***** file4: succesfull *******'
+        call wrf_message(" FULL SBM: ****** file4: succesfull  ******* ")
+        END IF
+        CALL wrf_dm_bcast_bytes ( SLIC , size ( SLIC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( TLIC , size ( TLIC ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( COEFIN , size ( COEFIN ) * RWORDSIZE )
+!       CALL wrf_dm_bcast_bytes ( C2 , size ( C2 ) * RWORDSIZE )
+!       CALL wrf_dm_bcast_bytes ( C3 , size ( C3 ) * RWORDSIZE )
+!       CALL wrf_dm_bcast_bytes ( C4 , size ( C4 ) * RWORDSIZE )
+! CONSTANTS :
+! KERNELS DEPENDING ON PRESSURE :
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2066
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2066     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="kernels_z.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+        READ(hujisbm_unit1,900)  &
+     &  YWLL_1000MB,YWLL_750MB,YWLL_500MB
+	CLOSE(hujisbm_unit1)
+        END IF
+        CALL wrf_dm_bcast_bytes ( YWLL_1000MB , size ( YWLL_1000MB ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLL_750MB , size ( YWLL_750MB ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLL_500MB , size ( YWLL_500MB ) * RWORDSIZE )
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2067
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2067     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="kernels.asc_s_0_03_0_9",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+! KERNELS NOT DEPENDING ON PRESSURE :
+	READ(hujisbm_unit1,900) &
+     &  YWLL,YWLI,YWLS,YWLG,YWLH, &
+     &  YWIL,YWII,YWIS,YWIG,YWIH, &
+     &  YWSL,YWSI,YWSS,YWSG,YWSH, &
+     &  YWGL,YWGI,YWGS,YWGG,YWGH, &
+     &  YWHL,YWHI,YWHS,YWHG,YWHH
+       close (hujisbm_unit1)
+        END IF
+        CALL wrf_dm_bcast_bytes ( YWLL , size ( YWLL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLI , size ( YWLI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLS , size ( YWLS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLG , size ( YWLG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWLH , size ( YWLH ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWIL , size ( YWIL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWII , size ( YWII ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWIS , size ( YWIS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWIG , size ( YWIG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWIH , size ( YWIH ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWSL , size ( YWSL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWSI , size ( YWSI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWSS , size ( YWSS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWSG , size ( YWSG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWSH , size ( YWSH ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWGL , size ( YWGL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWGI , size ( YWGI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWGS , size ( YWGS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWGG , size ( YWGG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWGH , size ( YWGH ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWHL , size ( YWHL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWHI , size ( YWHI ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWHS , size ( YWHS ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWHG , size ( YWHG ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes ( YWHH , size ( YWHH ) * RWORDSIZE )
+! BULKDENSITY :
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2068
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2068     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="bulkdens.asc_s_0_03_0_9",         & 
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+	READ(hujisbm_unit1,900) RO1BL,RO2BL,RO3BL,RO4BL,RO5BL
+	CLOSE(hujisbm_unit1)
+!	print *, ' ***** file6: succesfull *******'
+        call wrf_message(" FULL SBM: ****** file6: succesfull  ******* ")
+        END IF
+        CALL wrf_dm_bcast_bytes (RO1BL  , size ( RO1BL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes (RO2BL  , size ( RO2BL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes (RO3BL  , size ( RO3BL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes (RO4BL  , size ( RO4BL ) * RWORDSIZE )
+        CALL wrf_dm_bcast_bytes (RO5BL  , size ( RO5BL ) * RWORDSIZE )
+! BULKRADIUS
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2069
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2069     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="bulkradii.asc_s_0_03_0_9",         & 
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+	READ(hujisbm_unit1,*) RADXXO
+	CLOSE(hujisbm_unit1)
+!	print *, ' ***** file7: succesfull *******'
+        call wrf_message(" FULL SBM: ****** file7: succesfull  ******* ")
+!	PRINT *, '******* Hebrew Univ Cloud model-HUCM *******'
+        call wrf_message(" FULL SBM: Hebrew Univ Cloud model-HUCM ")
+
+        END IF
+        CALL wrf_dm_bcast_bytes (RADXXO  , size ( RADXXO ) * RWORDSIZE )
+! calculation of the mass(in mg) for categories boundaries :
+        ax=2.d0**(1.0/scal)
+        xl_mg(1)=0.3351d-7
+	do i=2,nkr
+           xl_mg(i)=ax*xl_mg(i-1)
+!        if (i.eq.22)print*,'printing xl_mg = ',xl_mg(22)
+        enddo
+	do i=1,nkr
+           xs_mg(i)=xs(i)*1.e3
+           xg_mg(i)=xg(i)*1.e3
+           xh_mg(i)=xh(i)*1.e3
+           xi1_mg(i)=xi(i,1)*1.e3
+           xi2_mg(i)=xi(i,2)*1.e3
+           xi3_mg(i)=xi(i,3)*1.e3
+        enddo
+! calculation of c(i,j) and ima(i,j) :
+! ima(i,j) - k-category number, c(i,j) - courant number 
+!       print*, 'calling courant_bott'
+        call courant_bott
+!       print*, 'called courant_bott'
+ 
+
+	DEG01=1./3.
+
+!------------------------------------------------------------------
+
+!       print*,'XL(ICCN) = ',ICCN,XL
+	X0DROP=XL(ICCN)
+!       print*,'X0DROP = ',X0DROP
+	X0CCN =X0DROP/(2.**(NKR-1))
+	R0CCN =(3.*X0CCN/4./3.141593/ROCCN0)**DEG01
+!------------------------------------------------------------------
+! THIS TEXT FROM TWOINITM.F_203
+!------------------------------------------------------------------
+! TEMPERATURA IN SURFACE LAYER EQUAL 15 Celsius(288.15 K)  
+        A=3.3E-05/288.15
+        B=2.*4.3/(22.9+35.5)
+        B=B*(4./3.)*3.14*RO_SOLUTE
+        A1=2.*(A/3.)**1.5/SQRT(B)
+        A2=A1*100.
+!------------------------------------------------------------------
+	CONCCCNIN=0.
+	CONTCCNIN=0.
+	DO KR=1,NKR
+           DROPRADII(KR)=(3.*XL(KR)/4./3.141593/1.)**DEG01
+        ENDDO
+	DO KR=1,NKR
+!          print*,'ROCCN0 = ',ROCCN0
+!          print*, 'X0CCN = ',X0CCN 
+!          print*, 'DEG01 = ',DEG01
+	   ROCCN(KR)=ROCCN0
+	   X0=X0CCN*2.**(KR-1)
+	   R0=(3.*X0/4./3.141593/ROCCN(KR))**DEG01
+	   XCCN(KR)=X0
+	   RCCN(KR)=R0
+!          print*,'RCCN(KR)= ', KR,RCCN(KR)
+           RCCNKR_CM=R0
+! CCN SPECTRUM 
+
+           S_KR=A2/RCCNKR_CM**1.5
+           ACCN=ACCN_CON
+           BCCN=BCCN_CON
+!          print*,'accn, bccn,S_KR = ',accn,bccn,S_KR
+!  CONTINENTAL
+           FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN
+           FCCNR_CON(KR)=FCCNR(KR)
+!  MARITIME
+           ACCN=ACCN_MAR
+           BCCN=BCCN_MAR
+           FCCNR(KR)=1.5*ACCN*BCCN*S_KR**BCCN
+           FCCNR_MAR(KR)=FCCNR(KR)
+
+	     CONTCCNIN=CONTCCNIN+COL*FCCNR(KR)*R0*R0*R0
+             CONCCCNIN=CONCCCNIN+COL*FCCNR(KR)
+	ENDDO
+!	PRINT *, '********* MAR CCN CONCENTRATION & MASS *******'
+!        call wrf_message(" FULL SBM: MAR CCN CONCENTRATION & MASS ")
+!	PRINT 200, CONCCCNIN,CONTCCNIN
+! CALCULATION OF FINAL MARITIME
+!RCCN(KR)=            1  1.2303877E-07
+!RCCN(KR)=            2  1.5501914E-07
+!RCCN(KR)=            3  1.9531187E-07
+!RCCN(KR)=           16  3.9372408E-06
+!RCCN(KR)=           21  1.2499960E-05
+!RCCN(KR)=           33  1.9999935E-04
+        RADCCN_MAX=RCCN(NKR)
+        RADCCN_MIN=0.005E-4         
+        RADCCN_MIN1=0.02E-4         
+!       print*,'ALOG(RADCCN_MIN) = ',ALOG(RADCCN_MIN)
+!       print*,'ALOG(RCCN(1) = ',ALOG(RCCN(1))
+!       print*,'ALOG(RADCCN_MAX) = ',ALOG(RADCCN_MAX)
+!       KR_MIN=(ALOG(RADCCN_MIN)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+!       KR_MIN1=(ALOG(RADCCN_MIN1)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+        KR_MIN=1.+ 3*(ALOG(RADCCN_MIN)- ALOG(R0CCN))/ALOG(2.)
+        KR_MIN1=1.+3*(ALOG(RADCCN_MIN1)- ALOG(R0CCN))/ALOG(2.)
+!       KR_MAX=(ALOG(RADCCN_MAX)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+        KR_MAX=1.+3.*(ALOG(RADCCN_MAX)- ALOG(R0CCN))/ALOG(2.)
+        KR_MIN=MAX(KR_MIN,1)
+        KR_MIN1=MAX(KR_MIN,KR_MIN1)
+        KR_MAX=MIN(NKR,KR_MAX)
+!       print*,'kr_min,kr_min1 = ',kr_min,kr_min1
+!       print*,'kr_max = ',kr_max
+! Interpolation
+        DO KR=1,NKR
+        IF (kr.ge.kr_min.and.kr.lt.kr_min1)then
+           FCCNR_MAR(KR)=FCCNR_MAR(KR_MIN1)* &
+     &      (ALOG(RCCN(KR))-ALOG(RCCN(KR_MIN)))/ &
+     &      (ALOG(RCCN(KR_MIN1))-ALOG(RCCN(KR_MIN)))
+
+        END IF
+        IF (KR.GT.KR_MAX.OR.KR.LT.KR_MIN)FCCNR_MAR(KR)=0
+!          print*,'FCCNR_MAR(KR) = ',KR,FCCNR_MAR(KR)
+        END DO
+! CALCULATION OF FINAL CONTINENTAL
+        RADCCN_MAX=0.6E-4
+        RADCCN_MIN=0.005E-4         
+        RADCCN_MIN1=0.02E-4         
+!       KR_MIN=(ALOG(RADCCN_MIN)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+!       KR_MIN1=(ALOG(RADCCN_MIN1)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+        KR_MIN=1.+ 3*(ALOG(RADCCN_MIN)- ALOG(R0CCN))/ALOG(2.)
+        KR_MIN1=1.+3*(ALOG(RADCCN_MIN1)- ALOG(R0CCN))/ALOG(2.)
+!       KR_MAX=(ALOG(RADCCN_MAX)-ALOG(RCCN(1)))/(3.*ALOG(2.))+1.
+        KR_MAX=1.+3.*(ALOG(RADCCN_MAX)- ALOG(R0CCN))/ALOG(2.)
+        KR_MIN=MAX(KR_MIN,1)
+        KR_MIN1=MAX(KR_MIN,KR_MIN1)
+        KR_MAX=MIN(NKR,KR_MAX)
+!       print*,'contin kr_min,kr_min1 = ',kr_min,kr_min1
+!       print*,'kr_max = ',kr_max
+! Interpolation
+        DO KR=1,NKR
+        IF (kr.ge.kr_min.and.kr.lt.kr_min1)then
+           FCCNR_CON(KR)=FCCNR_CON(KR_MIN1)* &
+     &      (ALOG(RCCN(KR))-ALOG(RCCN(KR_MIN)))/ &
+     &      (ALOG(RCCN(KR_MIN1))-ALOG(RCCN(KR_MIN)))
+        END IF
+        IF (KR.GT.KR_MAX.OR.KR.LT.KR_MIN)FCCNR_CON(KR)=0
+!          print*,'FCCNR_CON(KR) = ',KR,FCCNR_CON(KR)
+        END DO
+! CALCULATION OF MIXTURE
+        DO KR=1,NKR
+         FCCNR_MIX(KR)=FR_CON*FCCNR_CON(KR)+FR_MAR*FCCNR_MAR(KR)
+!        print*,'FCCNR_MIX(KR) = ',FCCNR_MIX(KR)
+        END DO
+!        STOP
+         CALL BREAKINIT
+!        CALL TWOINITMXVAR
+
+! IN CASE : IPRINT01.NE.0
+
+
+  100	FORMAT(10I4)
+  101   FORMAT(3X,F7.5,E13.5)
+  102	FORMAT(4E12.4)
+  105	FORMAT(A48)
+  106	FORMAT(A80)
+  123	FORMAT(3E12.4,3I4)
+  200	FORMAT(6E13.5)
+  201   FORMAT(6D13.5)
+  300	FORMAT(8E14.6) 
+  301   FORMAT(3X,F8.3,3X,E13.5)
+  302   FORMAT(5E13.5)
+!       if (IFREST)THEN
+!       dtime=dt*0.5
+!       else
+!       END IF
+        call kernals(dt)
+!+---+-----------------------------------------------------------------+
+! from morr_two_moment
+!..Set these variables needed for computing radar reflectivity.  These
+!.. get used within radar_init to create other variables used in the
+!.. radar module.
+! SIZE DISTRIBUTION PARAMETERS
+         RHOW = 997.
+         RHOI = 500.
+         RHOSN = 100.
+!        IF (IHAIL.EQ.0) THEN
+!        RHOG = 400.
+!        ELSE
+!        RHOG = 900.
+!        END IF
+         RHOG=450
+
+
+         CI = RHOI*PI_MORR/6.
+         DI = 3.
+         CS = RHOSN*PI_MORR/6.
+         DS = 3.
+         CG = RHOG*PI_MORR/6.
+         DG = 3.
+
+
+         xam_r = PI_MORR*RHOW/6.
+         xbm_r = 3.
+         xmu_r = 0.
+         xam_s = CS
+         xbm_s = DS
+         xmu_s = 0.
+         xam_g = CG
+         xbm_g = DG
+         xmu_g = 0.
+
+         call radar_init
+!+---+-----------------------------------------------------------------+
+
+        return
+2070  continue
+      WRITE( errmess , '(A,I4)' )                                        &
+       'module_mp_full_sbm: error opening hujisbm_DATA on unit '          &
+     &, hujisbm_unit1
+      CALL wrf_error_fatal(errmess)
+        end  subroutine full_hucminit
+      SUBROUTINE BREAKINIT
+      IMPLICIT NONE
+      INTEGER :: hujisbm_unit1
+      LOGICAL, PARAMETER :: PRINT_diag=.FALSE.
+      LOGICAL :: opened 
+      LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
+      CHARACTER*80 errmess
+!.....INPUT VARIABLES
+!
+!     GT    : MASS DISTRIBUTION FUNCTION
+!     XT_MG : MASS OF BIN IN MG
+!     JMAX  : NUMBER OF BINS
+
+
+!.....LOCAL VARIABLES
+
+      INTEGER AP,IE,JE,KE
+
+      PARAMETER (AP = 1)
+
+      INTEGER I,J,K,JDIFF
+      REAL  RPKIJ(JBREAK,JBREAK,JBREAK),RQKJ(JBREAK,JBREAK)
+
+
+      REAL PI,D0,HLP
+      DOUBLE PRECISION M(0:JBREAK),ALM
+      REAL DBREAK(JBREAK),GAIN,LOSS
+!     REAL ECOALMASS
+!     REAL XL(JMAX)
+
+
+!.....DECLARATIONS FOR INIT
+
+      INTEGER IP,KP,JP,KQ,JQ
+      REAL XTJ
+
+      CHARACTER*20 FILENAME_P,FILENAME_Q
+
+      FILENAME_P = 'coeff_p.asc'
+      FILENAME_Q = 'coeff_q.asc'
+
+      IE = JBREAK
+      JE = JBREAK
+      KE = JBREAK
+      PI    = 3.1415927
+      D0    = 0.0101593
+      M(1)  = PI/6.0 * D0**3
+
+!.....IN CGS
+
+
+!.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID
+
+      JDIFF = JMAX - JBREAK
+
+!.....INITIALIZATION
+
+!     IF (FIRSTCALL.NE.1) THEN
+
+!........CALCULATING THE BREAKUP GRID
+!        ALM  = 2.**(1./FLOAT(AP))
+         ALM  = 2.d0
+         M(0)  = M(1)/ALM
+         DO K=1,KE-1
+            M(K+1) = M(K)*ALM
+         ENDDO
+         DO K=1,KE
+            BRKWEIGHT(K) = 2./(M(K)**2 - M(K-1)**2)
+!           print*,'m(k) = ',m(k)
+!           print*,'m(k-1) = ',m(k-1)
+!           print*, 'MWEIGHT = ',BRKWEIGHT(K)
+         ENDDO
+
+!........OUTPUT
+
+         WRITE (*,*) 'COLL_BREAKUP_INI: COAGULATION AND BREAKUP GRID'
+         WRITE (*,'(2A5,5A15)') 'ICOAG','IBREAK', &
+     &        'XCOAG','DCOAG', &
+     &        'XBREAK','DBREAK','MWEIGHT'
+
+!........READ DER BREAKUP COEFFICIENTS FROM INPUT FILE
+
+!        WRITE (*,*) 'COLL_BREAKUP: READ THE BREAKUP COEFFS'
+!        WRITE (*,*) '              FILE PKIJ: ', FILENAME_P
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2061
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2061     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="coeff_p.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+
+!         print*,'here at 3'
+         DO K=1,KE
+            DO I=1,IE
+               DO J=1,I
+                  READ(hujisbm_unit1,'(3I6,1E16.8)') KP,IP,JP,PKIJ(KP,IP,JP)
+!                 WRITE(6,*)'PKIJ(KP,IP,JP) =', &
+!    &               KP,IP,JP,PKIJ(KP,IP,JP)
+!                 IF(RPKIJ(KP,IP,JP).EQ.0) THEN
+!    *             PKIJ(KP,IP,JP)=INT(RPKIJ(KP,IP,JP))
+!                 ELSE
+!                  PKIJ(KP,IP,JP)=RPKIJ(KP,IP,JP)
+!                 END IF
+!                 WRITE(6,*)'RPKIJ(KP,IP,JP) =',
+!    *               KP,IP,JP,RPKIJ(KP,IP,JP),
+!    *               PKIJ(KP,IP,JP)
+               ENDDO
+            ENDDO
+!           READ(6,*)
+         ENDDO
+	CLOSE(hujisbm_unit1)
+!        WRITE (*,*) '              FILE QKJ:  ', FILENAME_Q
+        END IF
+        CALL wrf_dm_bcast_bytes (PKIJ  , size ( PKIJ ) * DWORDSIZE )
+        IF ( wrf_dm_on_monitor() ) THEN
+          DO i = 31,99
+            INQUIRE ( i , OPENED = opened )
+            IF ( .NOT. opened ) THEN
+              hujisbm_unit1 = i
+              GOTO 2062
+            ENDIF
+          ENDDO
+          hujisbm_unit1 = -1
+ 2062     CONTINUE
+        ENDIF
+!
+        CALL wrf_dm_bcast_bytes ( hujisbm_unit1 , IWORDSIZE )
+!
+        IF ( hujisbm_unit1 < 0 ) THEN
+          CALL wrf_error_fatal ( 'module_mp_full: etanewinit: Can not find unused fortran unit to read in lookup table.' )
+        ENDIF
+!
+        IF ( wrf_dm_on_monitor() ) THEN
+          OPEN(UNIT=hujisbm_unit1,FILE="coeff_q.asc",                  &
+     &        FORM="FORMATTED",STATUS="OLD",ERR=2070)
+
+         DO K=1,KE
+            DO J=1,JE
+               READ(hujisbm_unit1,'(2I6,1E16.8)') KQ,JQ,QKJ(KQ,JQ)
+!              WRITE(6,*) KQ,JQ,QKJ(KQ,JQ)
+!              QKJ(KQ,JQ) = RQKJ(KQ,JQ)
+!              IF(QKJ(KQ,JQ).LE.1E-35)QKJ(KQ,JQ)=0.D0
+            ENDDO
+         ENDDO
+         CLOSE(hujisbm_unit1)
+
+         WRITE (*,*) 'COLL_BREAKUP READ: ... OK'
+         END IF
+        CALL wrf_dm_bcast_bytes (QKJ  , size ( QKJ ) * DWORDSIZE )
+!     ENDIF
+!        DO K=1,KE
+!           DO J=1,JE
+!              WRITE(6,*) 'After Broadcast, QKJ = ',K,J,QKJ(K,J)
+!           ENDDO
+!        ENDDO
+!        DO K=1,KE
+!           DO I=1,IE
+!              DO J=1,I
+!                 WRITE(6,*)'After Broadcast PKIJ(K,I,J) =', &
+!    &               K,I,J,PKIJ(K,I,J)
+!              ENDDO
+!           ENDDO
+!        ENDDO
+      DO I=1,JMAX
+         DO J=1,JMAX
+              ECOALMASSM(I,J)=1.0D0
+         ENDDO
+      ENDDO
+
+      DO I=1,JMAX
+         DO J=1,JMAX
+           ECOALMASSM(I,J)=ECOALMASS(XL(I),XL(J))
+         ENDDO
+      ENDDO
+      RETURN
+2070  continue
+      WRITE( errmess , '(A,I4)' )                                        &
+       'module_mp_full: error opening hujisbm_DATA on unit '          &
+     &, hujisbm_unit1
+      CALL wrf_error_fatal(errmess)
+      END SUBROUTINE BREAKINIT
+
+      REAL FUNCTION ECOALMASS(ETA,KSI)
+      IMPLICIT NONE
+!     REAL ECOALMASS
+      REAL PI
+      PARAMETER (PI = 3.1415927)
+
+      REAL ETA,KSI
+      REAL KPI,RHO
+      REAL DETA,DKSI
+
+      PARAMETER (RHO  = 1.0)
+
+!     REAL ECOALDIAM
+!     EXTERNAL ECOALDIAM
+
+      KPI = 6./PI
+
+      DETA = (KPI*ETA/RHO)**(1./3.)
+      DKSI = (KPI*KSI/RHO)**(1./3.)
+
+      ECOALMASS = ECOALDIAM(DETA,DKSI)
+
+      RETURN
+      END FUNCTION ECOALMASS
+
+
+!------------------------------------------------
+!     COALESCENCE EFFICIENCY AS FUNC OF DIAMETERS
+!------------------------------------------------
+
+      REAL FUNCTION ECOALDIAM(DETA,DKSI)
+!     IMPLICIT NONE
+
+      INTEGER N
+      REAL DETA,DKSI
+      REAL DGR,DKL,RGR,RKL,P,Q,E,X,Y,QMIN,QMAX
+      REAL ZERO,ONE,EPS,PI
+
+      PARAMETER (ZERO = 0.0)
+      PARAMETER (ONE  = 1.0)
+      PARAMETER (EPS  = 1.0E-30)
+      PARAMETER (PI   = 3.1415927)
+
+!     REAL   ECOALLOWLIST,ECOALOCHS
+!     EXTERNAL ECOALLOWLIST,ECOALOCHS
+
+      DGR = MAX(DETA,DKSI)
+      DKL = MIN(DETA,DKSI)
+
+      RGR = 0.5*DGR
+      RKL = 0.5*DKL
+
+      P = (RKL / RGR)
+      Q = (RKL * RGR)**0.5
+      Q = 0.5 * (RKL + RGR)
+
+      qmin = 250e-4
+      qmax = 400e-4        
+      if (q.lt.qmin) then
+         e = max(ecoalOchs(Dgr,Dkl),ecoalBeard(Dgr,Dkl)) 
+      elseif (q.ge.qmin.and.q.lt.qmax) then
+         x = (q - qmin) / (qmax - qmin)
+         e = sin(pi/2.0*x)**2 * ecoalLowList(Dgr,Dkl) &
+     &     + sin(pi/2.0*(1 - x))**2 * ecoalOchs(Dgr,Dkl)
+      elseif (q.ge.qmax) then
+         e = ecoalLowList(Dgr,Dkl)
+      else
+         e  = 1.0
+      endif
+
+      ECOALDIAM  = MAX(MIN(ONE,E),EPS)
+
+      RETURN
+      END FUNCTION  ECOALDIAM
+
+!--------------------------------------------------
+!     COALESCENCE EFFICIENCY (LOW&LIST)
+!--------------------------------------------------
+
+      REAL FUNCTION ECOALLOWLIST(DGR,DKL)
+      IMPLICIT NONE
+!     REAL ecoallowlist
+      REAL PI,SIGMA,KA,KB,EPSI
+      REAL DGR,DKL,RGR,RKL,X
+      REAL ST,SC,ET,DSTSC,CKE,W1,W2,DC,ECL
+      REAL QQ0,QQ1,QQ2
+
+      PARAMETER (EPSI=1.E-20)
+
+      PI = 3.1415927
+      SIGMA = 72.8
+      KA = 0.778
+      KB = 2.61E-4
+
+      RGR = 0.5*DGR
+      RKL = 0.5*DKL
+
+      CALL COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC)
+
+      DSTSC = ST-SC
+      ET = CKE+DSTSC
+      IF (ET .LT. 50.0) THEN
+         QQ0=1.0+(DKL/DGR)
+         QQ1=KA/QQ0**2
+         QQ2=KB*SIGMA*(ET**2)/(SC+EPSI)
+         ECL=QQ1*EXP(-QQ2)
+      ELSE
+         ECL=0.0
+      ENDIF
+
+      ECOALLOWLIST = ECL
+
+      RETURN
+      END FUNCTION ECOALLOWLIST
+
+!--------------------------------------------------
+!     COALESCENCE EFFICIENCY (BEARD AND OCHS)
+!--------------------------------------------------
+
+      REAL FUNCTION ECOALOCHS(D_L,D_S)
+      IMPLICIT NONE
+!     real ecoalochs
+      REAL D_L,D_S
+      REAL PI,SIGMA,N_W,R_S,R_L,DV,P,G,X,E
+!      REAL VTBEARD,EPSF,FPMIN
+      REAL EPSF,FPMIN
+
+!     EXTERNAL VTBEARD
+      PARAMETER (EPSF  = 1.E-30)
+      PARAMETER (FPMIN = 1.E-30)
+
+      PI = 3.1415927
+      SIGMA = 72.8
+
+      R_S = 0.5 * D_S
+      R_L = 0.5 * D_L
+      P   = R_S / R_L
+
+      DV  = ABS(VTBEARD(D_L) - VTBEARD(D_S))
+      IF (DV.LT.FPMIN) DV = FPMIN
+      N_W = R_S * DV**2 / SIGMA
+      G   = 2**(3./2.)/(6.*PI) * P**4 * (1.+ P) / ((1.+P**2)*(1.+P**3))
+      X   = N_W**(0.5) * G
+      E   = 0.767 - 10.14 * X
+
+      ECOALOCHS = E
+
+      RETURN
+      END FUNCTION ECOALOCHS
+
+!-----------------------------------------
+!     CALCULATING THE COLLISION ENERGY
+!-----------------------------------------
+
+      SUBROUTINE COLLENERGY(DGR,DKL,CKE,ST,SC,W1,W2,DC)
+!     IMPLICIT NONE
+
+      REAL DGR,DKL,DC
+      REAL K10,PI,SIGMA,RHO
+      REAL CKE,W1,W2,ST,SC
+      REAL DGKA3,DGKB3,DGKA2
+      REAL V1,V2,DV
+!     REAL VTBEARD,EPSF,FPMIN
+      REAL EPSF,FPMIN
+
+!     EXTERNAL VTBEARD
+      PARAMETER (EPSF  = 1.E-30)
+      PARAMETER (FPMIN = 1.E-30)
+
+      PI    = 3.1415927
+      RHO   = 1.0
+      SIGMA = 72.8
+
+      K10=RHO*PI/12.0D0
+
+      DGR = MAX(DGR,EPSF)
+      DKL = MAX(DKL,EPSF)
+
+      DGKA2=(DGR**2)+(DKL**2)
+
+      DGKA3=(DGR**3)+(DKL**3)
+
+      IF (DGR.NE.DKL) THEN
+         V1 = VTBEARD(DGR)
+         V2 = VTBEARD(DKL)
+         DV = (V1-V2)
+         IF (DV.LT.FPMIN) DV = FPMIN
+         DV = DV**2
+         IF (DV.LT.FPMIN) DV = FPMIN
+         DGKB3=(DGR**3)*(DKL**3)
+         CKE = K10 * DV * DGKB3/DGKA3
+      ELSE
+         CKE = 0.0D0
+      ENDIF
+      ST = PI*SIGMA*DGKA2
+      SC = PI*SIGMA*DGKA3**(2./3.)
+
+      W1=CKE/(SC+EPSF)
+      W2=CKE/(ST+EPSF)
+
+      DC=DGKA3**(1./3.)
+
+      RETURN
+      END SUBROUTINE COLLENERGY
+
+!--------------------------------------------------
+!     CALCULATING TERMINAL VELOCITY (BEARD-FORMULA)
+!--------------------------------------------------
+
+      REAL FUNCTION VTBEARD(DIAM)
+      IMPLICIT NONE
+!     REAL VTBEARD
+
+      REAL DIAM,AA
+      REAL ROP,RU,AMT,PP,RL,TT,ETA,DENS,CD,D,A
+      REAL ALA,GR,SI,BOND,PART,XX,YY,RE,VT
+      REAL B00,B11,B22,B33,B44,B55,B0,B1,B2,B3,B4,B5,B6
+      INTEGER ID
+
+      DATA B00,B11,B22,B33,B44,B55,B0,B1,B2,B3,B4,B5,B6/-5.00015, &
+     &5.23778,-2.04914,.475294,-.0542819,.00238449,-3.18657,.992696, &
+     &-.153193E-2,-.987059E-3,-.578878E-3,.855176E-4,-.327815E-5/
+
+      AA   = DIAM/2.0
+      ROP  = 1.0
+      RU   = 8.3144E+7
+      AMT  = 28.9644
+      ID   = 10000
+      PP   = FLOAT(ID)*100.
+      RL   = RU/AMT
+      TT   = 283.15
+      ETA  = (1.718+.0049*(TT-273.15))*1.E-4
+      DENS = PP/TT/RL
+      ALA  = 6.6E-6*1.01325E+6/PP*TT/293.15
+      GR   = 979.69
+      SI   = 76.1-.155*(TT-273.15)
+
+      IF (AA.GT.500.E-4) THEN
+         BOND = GR*(ROP-DENS)*AA*AA/SI
+         PART = (SI**3*DENS*DENS/(ETA**4*GR*(ROP-DENS)))**(1./6.)
+         XX = LOG(16./3.*BOND*PART)
+         YY = B00+B11*XX+B22*XX*XX+B33*XX**3+B44*XX**4+B55*XX**5
+         RE = PART*EXP(YY)
+         VT = ETA*RE/2./DENS/AA
+      ELSEIF (AA.GT.1.E-3) THEN
+         CD = 32.*AA*AA*AA*(ROP-DENS)*DENS*GR/3./ETA/ETA
+         XX = LOG(CD)
+         RE = EXP(B0+B1*XX+B2*XX*XX+B3*XX**3+B4*XX**4+B5*XX**5+B6*XX**6)
+         D  = CD/RE/24.-1.
+         VT = ETA*RE/2./DENS/AA
+      ELSE
+         A  = 1.+1.26*ALA/AA
+         A  = A*2.*AA*AA*GR*(ROP-DENS)/9./ETA
+         CD = 12*ETA/A/AA/DENS
+         VT = A
+      ENDIF
+
+      VTBEARD = VT
+
+      RETURN
+      END FUNCTION VTBEARD
+
+
+      
+!-------------------------------------------------- 
+!     Function f. Coalescence-Efficiency 
+!     Eq. (7) of Beard and Ochs (1995)
+!--------------------------------------------------      
+ 
+      REAL FUNCTION ecoalBeard(D_l,D_s) 
+       
+      IMPLICIT NONE 
+!     REAL ecoalBeard
+!     REAL ECOALMASS
+      REAL            D_l,D_s
+      REAL            R_s,R_l
+      REAL            rcoeff
+      REAL epsf
+      PARAMETER (epsf  = 1.e-30) 
+
+      INTEGER its
+      COMPLEX acoeff(4),x
+
+      R_s = 0.5 * D_s
+      R_l = 0.5 * D_l      
+
+      rcoeff = 5.07 - log(R_s*1e4) - log(R_l*1e4/200.0)
+
+      acoeff(1) = CMPLX(rcoeff)
+      acoeff(2) = CMPLX(-5.94)
+      acoeff(3) = CMPLX(+7.27)
+      acoeff(4) = CMPLX(-5.29)
+
+      x = (0.50,0)
+
+      CALL LAGUER(acoeff,3,x,its)
+
+      EcoalBeard = REAL(x)
+
+      RETURN 
+      END FUNCTION ecoalBeard 
+
+!--------------------------------------------------       
+
+      SUBROUTINE laguer(a,m,x,its)
+      INTEGER m,its,MAXIT,MR,MT
+      REAL EPSS
+      COMPLEX a(m+1),x
+      PARAMETER (EPSS=2.e-7,MR=8,MT=10,MAXIT=MT*MR)
+      INTEGER iter,j
+      REAL abx,abp,abm,err,frac(MR)
+      COMPLEX dx,x1,b,d,f,g,h,sq,gp,gm,g2
+      SAVE frac
+      DATA frac /.5,.25,.75,.13,.38,.62,.88,1./
+      do 12 iter=1,MAXIT
+        its=iter
+        b=a(m+1)
+        err=abs(b)
+        d=cmplx(0.,0.)
+        f=cmplx(0.,0.)
+        abx=abs(x)
+        do 11 j=m,1,-1
+          f=x*f+d
+          d=x*d+b
+          b=x*b+a(j)
+          err=abs(b)+abx*err
+11      continue
+        err=EPSS*err
+        if(abs(b).le.err) then
+          return
+        else
+          g=d/b
+          g2=g*g
+          h=g2-2.*f/b
+          sq=sqrt((m-1)*(m*h-g2))
+          gp=g+sq
+          gm=g-sq
+          abp=abs(gp)
+          abm=abs(gm)
+          if(abp.lt.abm) gp=gm
+          if (max(abp,abm).gt.0.) then
+            dx=m/gp
+          else
+            dx=exp(cmplx(log(1.+abx),float(iter)))
+          endif
+        endif
+        x1=x-dx
+        if(x.eq.x1)return
+        if (mod(iter,MT).ne.0) then
+          x=x1
+        else
+          x=x-dx*frac(iter/MT)
+        endif
+12    continue
+      pause 'too many iterations in laguer'
+      return
+      END SUBROUTINE laguer
+
+
+
+
+      subroutine courant_bott
+      implicit none
+      integer k,kk,j,i
+      double precision x0
+! ima(i,j) - k-category number,
+! chucm(i,j)   - courant number :
+! logarithmic grid distance(dlnr) :
+
+
+!================================================================
+! BARRY     
+!     print*,'dlnr in courant_bott = ',dlnr
+      xl_mg(0)=xl_mg(1)/2
+! BARRY
+      do i=1,nkr
+         do j=i,nkr
+            x0=xl_mg(i)+xl_mg(j)
+            do k=j,nkr
+               kk=k
+!              if (k.eq.1)then
+!                  print*,'xl_mg(k) = ',xl_mg(k)
+!                  print*,'x0 = ',x0
+! xl_mg(k) =   3.351000000000000E-008
+!  x0 =   6.702000000000000E-008
+!		   read (6,*)
+!              end if
+               if(xl_mg(k).ge.x0.and.xl_mg(k-1).lt.x0) then
+                 chucm(i,j)=dlog(x0/xl_mg(k-1))/(3.d0*dlnr)
+ 102             continue
+                 if(chucm(i,j).gt.1.-1.d-08) then
+                   chucm(i,j)=0.
+                   kk=kk+1
+                 endif
+                 ima(i,j)=min(nkr-1,kk-1)
+
+                 goto 2000
+               endif
+            enddo
+ 2000       continue
+!            if(i.eq.nkr.or.j.eq.nkr) ima(i,j)=nkr
+            chucm(j,i)=chucm(i,j)
+            ima(j,i)=ima(i,j)
+         enddo
+      enddo
+      return
+      end subroutine courant_bott
+
+
+      SUBROUTINE KERNALS(DTIME)
+! KHAIN30/07/99
+      IMPLICIT NONE
+      INTEGER I,J
+      REAL PI
+!******************************************************************
+      data pi/3.141592654/
+! dtime - timestep of integration (calculated in main program) :
+! dlnr - logarithmic grid distance
+! ima(i,j) - k-category number, c(i,j) - courant number 
+! cw*(i,j) (in cm**3) - multiply help kernel with constant 
+! timestep(dt) and logarithmic grid distance(dlnr) :
+        REAL DTIME
+! logarithmic grid distance(dlnr) :
+!       dlnr=dlog(2.d0)/(3.d0*scal)
+! scal is micro.prm file parameter(scal=1.d0 for x(k+1)=x(k)*2)
+! calculation of cw*(i,j) (in cm**3) - multiply help kernel 
+! with constant timestep(dtime) and logarithmic grid distance(dlnr) :
+!     print*,'dlnr in kernal = ',dlnr,dtime
+        DO I=1,NKR
+           DO J=1,NKR
+              CWLL_1000MB(I,J)=DTIME*DLNR*YWLL_1000MB(I,J)
+              CWLL_750MB(I,J)=DTIME*DLNR*YWLL_750MB(I,J)
+              CWLL_500MB(I,J)=DTIME*DLNR*YWLL_500MB(I,J)
+
+              CWLL(I,J)=DTIME*DLNR*YWLL(I,J)
+              CWLG(I,J)=DTIME*DLNR*YWLG(I,J)
+              CWLH(I,J)=DTIME*DLNR*YWLH(I,J)
+
+! barry
+              if (i.le.16.and.j.le.16)then
+              CWSL(I,J)=0.d0
+!             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
+              CWSL(i,j)=DTIME*DLNR*YWIL(I,J,2)
+              CWLS(I,J)=0.d0
+!             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
+              CWLS(I,J)=DTIME*DLNR*YWLI(I,J,2)
+              else
+              CWSL(I,J)=DTIME*DLNR*YWSL(I,J)
+              CWLS(I,J)=DTIME*DLNR*YWLS(I,J)
+              end if
+              CWSS(I,J)=DTIME*DLNR*YWSS(I,J)
+              CWSG(I,J)=DTIME*DLNR*YWSG(I,J)
+              CWSH(I,J)=DTIME*DLNR*YWSH(I,J)
+
+              CWGL(I,J)=0.8*DTIME*DLNR*YWGL(I,J)
+              IF(RADXXO(I,6).LT.2.0D-2) THEN
+                IF(RADXXO(J,1).LT.1.0D-3) THEN
+                  IF(RADXXO(J,1).GE.7.0D-4) THEN
+                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/1.5D0
+                  ELSE
+                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/3.0D0
+                  ENDIF
+                ENDIF
+              ENDIF
+              IF(I.LE.14.AND.J.LE.7) CWGL(I,J)=0.0D0
+!             IF(I.LE.17.AND.J.LE.7) CWGL(I,J)=0.0D0
+!             IF(I.LE.14.AND.J.LE.14) CWGL(I,J)=0.0D0
+              CWGS(I,J)=DTIME*DLNR*YWGS(I,J)
+              CWGG(I,J)=DTIME*DLNR*YWGG(I,J)
+              CWGH(I,J)=DTIME*DLNR*YWGH(I,J)
+
+              CWHL(I,J)=DTIME*DLNR*YWHL(I,J)
+              CWHS(I,J)=DTIME*DLNR*YWHS(I,J)
+              CWHG(I,J)=DTIME*DLNR*YWHG(I,J)
+              CWHH(I,J)=DTIME*DLNR*YWHH(I,J)
+
+              CWLI_1(I,J)=DTIME*DLNR*YWLI(I,J,1)
+              CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
+              CWLI_3(I,J)=DTIME*DLNR*YWLI(I,J,3)
+              
+              CWIL_1(I,J)=DTIME*DLNR*YWIL(I,J,1)
+              CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
+              CWIL_3(I,J)=DTIME*DLNR*YWIL(I,J,3)
+
+              CWIS_1(I,J)=DTIME*DLNR*YWIS(I,J,1)
+              CWIS_2(I,J)=DTIME*DLNR*YWIS(I,J,2)
+              CWIS_3(I,J)=DTIME*DLNR*YWIS(I,J,3)
+
+              CWSI_1(I,J)=DTIME*DLNR*YWSI(I,J,1)
+              CWSI_2(I,J)=DTIME*DLNR*YWSI(I,J,2)
+              CWSI_3(I,J)=DTIME*DLNR*YWSI(I,J,3)
+
+              CWIG_1(I,J)=DTIME*DLNR*YWIG(I,J,1)
+              CWIG_2(I,J)=DTIME*DLNR*YWIG(I,J,2)
+              CWIG_3(I,J)=DTIME*DLNR*YWIG(I,J,3)
+
+              CWGI_1(I,J)=DTIME*DLNR*YWGI(I,J,1)
+              CWGI_2(I,J)=DTIME*DLNR*YWGI(I,J,2)
+              CWGI_3(I,J)=DTIME*DLNR*YWGI(I,J,3)
+
+              CWIH_1(I,J)=DTIME*DLNR*YWIH(I,J,1)
+              CWIH_2(I,J)=DTIME*DLNR*YWIH(I,J,2)
+              CWIH_3(I,J)=DTIME*DLNR*YWIH(I,J,3)
+
+              CWHI_1(I,J)=DTIME*DLNR*YWHI(I,J,1)
+              CWHI_2(I,J)=DTIME*DLNR*YWHI(I,J,2)
+              CWHI_3(I,J)=DTIME*DLNR*YWHI(I,J,3)
+! barry
+              if (i.lt.12.and.j.lt.12)then
+
+               CWII_1_1(I,J)=0.D0
+               CWII_1_2(I,J)=0.D0
+               CWII_1_3(I,J)=0.D0
+
+               CWII_2_1(I,J)=0.D0
+               CWII_2_2(I,J)=0.D0
+               CWII_2_3(I,J)=0.D0
+
+               CWII_3_1(I,J)=0.D0
+               CWII_3_2(I,J)=0.D0
+               CWII_3_3(I,J)=0.D0
+!barry
+              else
+               CWII_1_1(I,J)=DTIME*DLNR*YWII(I,J,1,1)
+               CWII_1_2(I,J)=DTIME*DLNR*YWII(I,J,1,2)
+               CWII_1_3(I,J)=DTIME*DLNR*YWII(I,J,1,3)
+
+               CWII_2_1(I,J)=DTIME*DLNR*YWII(I,J,2,1)
+               CWII_2_2(I,J)=DTIME*DLNR*YWII(I,J,2,2)
+               CWII_2_3(I,J)=DTIME*DLNR*YWII(I,J,2,3)
+
+               CWII_3_1(I,J)=DTIME*DLNR*YWII(I,J,3,1)
+               CWII_3_2(I,J)=DTIME*DLNR*YWII(I,J,3,2)
+               CWII_3_3(I,J)=DTIME*DLNR*YWII(I,J,3,3)
+              end if
+           ENDDO
+        ENDDO
+!       GO TO 88
+! NEW CHANGES 2.06.01 (BEGIN)
+        CALL TURBCOEF
+        DO J=1,7
+           DO I=15,24-J
+              CWGL(I,J)=0.0D0
+           ENDDO
+        ENDDO
+! NEW CHANGES 2.06.01 (END)
+! NEW CHANGES 3.02.01 (BEGIN)
+        DO I=1,NKR
+           DO J=1,NKR
+              CWLG(J,I)=CWGL(I,J)
+           ENDDO
+        ENDDO
+!       print*, 'ICETURB = ',ICETURB
+          DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+               IF (ICETURB.EQ.1)THEN
+                CWGL(I,J)=CTURBGL(I,J)*CWGL(I,J)
+               ELSE
+                CWGL(I,J)=CWGL(I,J)
+               END IF
+             ENDDO
+          ENDDO
+          DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+                CWLG(J,I)=CWGL(I,J)
+             ENDDO
+          ENDDO
+
+88     CONTINUE
+	RETURN
+	END SUBROUTINE KERNALS
+
+      SUBROUTINE KERNALS_IN(DTIME)
+! KHAIN30/07/99
+      IMPLICIT NONE
+      INTEGER I,J
+      REAL PI
+!******************************************************************
+      data pi/3.141592654/
+! dtime - timestep of integration (calculated in main program) :
+! dlnr - logarithmic grid distance
+! ima(i,j) - k-category number, c(i,j) - courant number 
+! cw*(i,j) (in cm**3) - multiply help kernel with constant 
+! timestep(dt) and logarithmic grid distance(dlnr) :
+        REAL DTIME
+! logarithmic grid distance(dlnr) :
+!       dlnr=dlog(2.d0)/(3.d0*scal)
+! scal is micro.prm file parameter(scal=1.d0 for x(k+1)=x(k)*2)
+! calculation of cw*(i,j) (in cm**3) - multiply help kernel 
+! with constant timestep(dtime) and logarithmic grid distance(dlnr) :
+!     print*,'dlnr in kernal = ',dlnr,dtime
+        DO I=1,NKR
+           DO J=1,NKR
+              CWLL_1000MB(I,J)=DTIME*DLNR*YWLL_1000MB(I,J)
+              CWLL_750MB(I,J)=DTIME*DLNR*YWLL_750MB(I,J)
+              CWLL_500MB(I,J)=DTIME*DLNR*YWLL_500MB(I,J)
+
+              CWLL(I,J)=DTIME*DLNR*YWLL(I,J)
+              CWLG(I,J)=DTIME*DLNR*YWLG(I,J)
+!             CWLH(I,J)=DTIME*DLNR*YWLH(I,J)
+
+! barry
+              if (i.le.16.and.j.le.16)then
+              CWSL(I,J)=0.d0
+!             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
+              CWSL(i,j)=DTIME*DLNR*YWIL(I,J,2)
+              CWLS(I,J)=0.d0
+!             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
+              CWLS(I,J)=DTIME*DLNR*YWLI(I,J,2)
+              else
+              CWSL(I,J)=DTIME*DLNR*YWSL(I,J)
+              CWLS(I,J)=DTIME*DLNR*YWLS(I,J)
+              end if
+              CWSS(I,J)=DTIME*DLNR*YWSS(I,J)
+              CWSG(I,J)=DTIME*DLNR*YWSG(I,J)
+!             CWSH(I,J)=DTIME*DLNR*YWSH(I,J)
+
+              CWGL(I,J)=0.8*DTIME*DLNR*YWGL(I,J)
+              IF(RADXXO(I,6).LT.2.0D-2) THEN
+                IF(RADXXO(J,1).LT.1.0D-3) THEN
+                  IF(RADXXO(J,1).GE.7.0D-4) THEN
+                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/1.5D0
+                  ELSE
+                    CWGL(I,J)=DTIME*DLNR*YWGL(I,J)/3.0D0
+                  ENDIF
+                ENDIF
+              ENDIF
+              IF(I.LE.14.AND.J.LE.7) CWGL(I,J)=0.0D0
+!             IF(I.LE.17.AND.J.LE.7) CWGL(I,J)=0.0D0
+!             IF(I.LE.14.AND.J.LE.14) CWGL(I,J)=0.0D0
+              CWGS(I,J)=DTIME*DLNR*YWGS(I,J)
+              CWGG(I,J)=DTIME*DLNR*YWGG(I,J)
+!             CWGH(I,J)=DTIME*DLNR*YWGH(I,J)
+
+!             CWHL(I,J)=DTIME*DLNR*YWHL(I,J)
+!             CWHS(I,J)=DTIME*DLNR*YWHS(I,J)
+!             CWHG(I,J)=DTIME*DLNR*YWHG(I,J)
+!             CWHH(I,J)=DTIME*DLNR*YWHH(I,J)
+
+!             CWLI_1(I,J)=DTIME*DLNR*YWLI(I,J,1)
+!             CWLI_2(I,J)=DTIME*DLNR*YWLI(I,J,2)
+!             CWLI_3(I,J)=DTIME*DLNR*YWLI(I,J,3)
+              
+!             CWIL_1(I,J)=DTIME*DLNR*YWIL(I,J,1)
+!             CWIL_2(I,J)=DTIME*DLNR*YWIL(I,J,2)
+!             CWIL_3(I,J)=DTIME*DLNR*YWIL(I,J,3)
+
+!             CWIS_1(I,J)=DTIME*DLNR*YWIS(I,J,1)
+!             CWIS_2(I,J)=DTIME*DLNR*YWIS(I,J,2)
+!             CWIS_3(I,J)=DTIME*DLNR*YWIS(I,J,3)
+
+!             CWSI_1(I,J)=DTIME*DLNR*YWSI(I,J,1)
+!             CWSI_2(I,J)=DTIME*DLNR*YWSI(I,J,2)
+!             CWSI_3(I,J)=DTIME*DLNR*YWSI(I,J,3)
+
+!             CWIG_1(I,J)=DTIME*DLNR*YWIG(I,J,1)
+!             CWIG_2(I,J)=DTIME*DLNR*YWIG(I,J,2)
+!             CWIG_3(I,J)=DTIME*DLNR*YWIG(I,J,3)
+
+!             CWGI_1(I,J)=DTIME*DLNR*YWGI(I,J,1)
+!             CWGI_2(I,J)=DTIME*DLNR*YWGI(I,J,2)
+!             CWGI_3(I,J)=DTIME*DLNR*YWGI(I,J,3)
+
+!             CWIH_1(I,J)=DTIME*DLNR*YWIH(I,J,1)
+!             CWIH_2(I,J)=DTIME*DLNR*YWIH(I,J,2)
+!             CWIH_3(I,J)=DTIME*DLNR*YWIH(I,J,3)
+
+!             CWHI_1(I,J)=DTIME*DLNR*YWHI(I,J,1)
+!             CWHI_2(I,J)=DTIME*DLNR*YWHI(I,J,2)
+!             CWHI_3(I,J)=DTIME*DLNR*YWHI(I,J,3)
+! barry
+              if (i.lt.12.and.j.lt.12)then
+
+!              CWII_1_1(I,J)=0.D0
+!              CWII_1_2(I,J)=0.D0
+!              CWII_1_3(I,J)=0.D0
+
+!              CWII_2_1(I,J)=0.D0
+!              CWII_2_2(I,J)=0.D0
+!              CWII_2_3(I,J)=0.D0
+
+!              CWII_3_1(I,J)=0.D0
+!              CWII_3_2(I,J)=0.D0
+!              CWII_3_3(I,J)=0.D0
+!barry
+              else
+!              CWII_1_1(I,J)=DTIME*DLNR*YWII(I,J,1,1)
+!              CWII_1_2(I,J)=DTIME*DLNR*YWII(I,J,1,2)
+!              CWII_1_3(I,J)=DTIME*DLNR*YWII(I,J,1,3)
+
+!              CWII_2_1(I,J)=DTIME*DLNR*YWII(I,J,2,1)
+!              CWII_2_2(I,J)=DTIME*DLNR*YWII(I,J,2,2)
+!              CWII_2_3(I,J)=DTIME*DLNR*YWII(I,J,2,3)
+
+!              CWII_3_1(I,J)=DTIME*DLNR*YWII(I,J,3,1)
+!              CWII_3_2(I,J)=DTIME*DLNR*YWII(I,J,3,2)
+!              CWII_3_3(I,J)=DTIME*DLNR*YWII(I,J,3,3)
+              end if
+           ENDDO
+        ENDDO
+!       GO TO 88
+! NEW CHANGES 2.06.01 (BEGIN)
+        CALL TURBCOEF
+        DO J=1,7
+           DO I=15,24-J
+              CWGL(I,J)=0.0D0
+           ENDDO
+        ENDDO
+! NEW CHANGES 2.06.01 (END)
+! NEW CHANGES 3.02.01 (BEGIN)
+        DO I=1,NKR
+           DO J=1,NKR
+              CWLG(J,I)=CWGL(I,J)
+           ENDDO
+        ENDDO
+!       print*, 'ICETURB = ',ICETURB
+          DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+               IF (ICETURB.EQ.1)THEN
+                CWGL(I,J)=CTURBGL(I,J)*CWGL(I,J)
+               ELSE
+                CWGL(I,J)=CWGL(I,J)
+               END IF
+             ENDDO
+          ENDDO
+          DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+                CWLG(J,I)=CWGL(I,J)
+             ENDDO
+          ENDDO
+
+88     CONTINUE
+	RETURN
+	END SUBROUTINE KERNALS_IN
+        SUBROUTINE TURBCOEF
+        IMPLICIT NONE
+        INTEGER I,J
+!       DOUBLE PRECISION X_KERN,Y_KERN,F
+        DOUBLE PRECISION X_KERN,Y_KERN
+	DOUBLE PRECISION RL_LL(K0_LL),RL_GL(K0L_GL),RG_GL(K0G_GL)
+          RL_LL(1)=RADXXO(KRMIN_LL,1)*1.E4
+          RL_LL(2)=10.0D0
+          RL_LL(3)=20.0D0
+          RL_LL(4)=30.0D0
+          RL_LL(5)=40.0D0
+          RL_LL(6)=50.0D0
+          RL_LL(7)=60.0D0
+          RL_LL(8)=RADXXO(KRMAX_LL,1)*1.E4
+          DO J=1,K0_LL
+             DO I=1,K0_LL
+                CTURB_LL(I,J)=1.0D0
+             ENDDO
+          ENDDO 
+	  CTURB_LL(1,1)=4.50D0
+	  CTURB_LL(1,2)=4.50D0
+	  CTURB_LL(1,3)=3.00D0
+	  CTURB_LL(1,4)=2.25D0
+	  CTURB_LL(1,5)=1.95D0
+	  CTURB_LL(1,6)=1.40D0
+	  CTURB_LL(1,7)=1.40D0
+	  CTURB_LL(1,8)=1.40D0
+
+	  CTURB_LL(2,1)=4.50D0
+	  CTURB_LL(2,2)=4.50D0
+	  CTURB_LL(2,3)=3.00D0
+	  CTURB_LL(2,4)=2.25D0
+	  CTURB_LL(2,5)=1.95D0
+	  CTURB_LL(2,6)=1.40D0
+	  CTURB_LL(2,7)=1.40D0
+	  CTURB_LL(2,8)=1.40D0
+
+	  CTURB_LL(3,1)=3.00D0
+	  CTURB_LL(3,2)=3.00D0
+	  CTURB_LL(3,3)=2.70D0
+	  CTURB_LL(3,4)=2.25D0
+	  CTURB_LL(3,5)=1.65D0
+	  CTURB_LL(3,6)=1.40D0
+	  CTURB_LL(3,7)=1.40D0
+	  CTURB_LL(3,8)=1.40D0
+
+	  CTURB_LL(4,1)=2.25D0
+	  CTURB_LL(4,2)=2.25D0
+	  CTURB_LL(4,3)=2.25D0
+	  CTURB_LL(4,4)=1.95D0
+	  CTURB_LL(4,5)=1.65D0
+	  CTURB_LL(4,6)=1.40D0
+	  CTURB_LL(4,7)=1.40D0
+	  CTURB_LL(4,8)=1.40D0
+
+	  CTURB_LL(5,1)=1.95D0
+	  CTURB_LL(5,2)=1.95D0
+	  CTURB_LL(5,3)=1.65D0
+	  CTURB_LL(5,4)=1.65D0
+	  CTURB_LL(5,5)=1.65D0
+	  CTURB_LL(5,6)=1.40D0
+	  CTURB_LL(5,7)=1.40D0
+	  CTURB_LL(5,8)=1.40D0
+
+	  CTURB_LL(6,1)=1.40D0
+	  CTURB_LL(6,2)=1.40D0
+	  CTURB_LL(6,3)=1.40D0
+	  CTURB_LL(6,4)=1.40D0
+	  CTURB_LL(6,5)=1.40D0
+	  CTURB_LL(6,6)=1.40D0
+	  CTURB_LL(6,7)=1.40D0
+	  CTURB_LL(6,8)=1.40D0
+
+	  CTURB_LL(7,1)=1.40D0
+	  CTURB_LL(7,2)=1.40D0
+	  CTURB_LL(7,3)=1.40D0
+	  CTURB_LL(7,4)=1.40D0
+	  CTURB_LL(7,5)=1.40D0
+	  CTURB_LL(7,6)=1.40D0
+	  CTURB_LL(7,7)=1.40D0
+	  CTURB_LL(7,8)=1.40D0
+
+	  CTURB_LL(8,1)=1.40D0
+	  CTURB_LL(8,2)=1.40D0
+	  CTURB_LL(8,3)=1.40D0
+	  CTURB_LL(8,4)=1.40D0
+	  CTURB_LL(8,5)=1.40D0
+	  CTURB_LL(8,6)=1.40D0
+	  CTURB_LL(8,7)=1.40D0
+	  CTURB_LL(8,8)=1.40D0
+          DO J=1,K0_LL
+             DO I=1,K0_LL
+                CTURB_LL(I,J)=(CTURB_LL(I,J)-1.0D0)/1.5D0+1.0D0
+             ENDDO
+          ENDDO
+	  DO I=KRMIN_LL,KRMAX_LL
+             DO J=KRMIN_LL,KRMAX_LL
+                CTURBLL(I,J)=1.0D0
+             ENDDO
+          ENDDO
+          DO I=KRMIN_LL,KRMAX_LL
+             X_KERN=RADXXO(I,1)*1.0D4
+             IF(X_KERN.LT.RL_LL(1)) X_KERN=RL_LL(1)
+             IF(X_KERN.GT.RL_LL(K0_LL)) X_KERN=RL_LL(K0_LL) 
+             DO J=KRMIN_LL,KRMAX_LL
+                Y_KERN=RADXXO(J,1)*1.0D4
+                IF(Y_KERN.LT.RL_LL(1)) Y_KERN=RL_LL(1)
+                IF(Y_KERN.GT.RL_LL(K0_LL)) Y_KERN=RL_LL(K0_LL)
+                CTURBLL(I,J)=F(X_KERN,Y_KERN,RL_LL,RL_LL,CTURB_LL &
+     &                      ,K0_LL,K0_LL)	                         
+             ENDDO
+          ENDDO
+          RL_GL(1) = RADXXO(1,1)*1.E4 
+          RL_GL(2) = 8.0D0
+          RL_GL(3) = 10.0D0
+	  RL_GL(4) = 16.0D0
+          RL_GL(5) = 20.0D0
+          RL_GL(6) = 30.0D0
+          RL_GL(7) = 40.0D0
+          RL_GL(8) = 50.0D0
+          RL_GL(9) = 60.0D0
+          RL_GL(10)= 70.0D0
+          RL_GL(11)= 80.0D0
+	  RL_GL(12)= 90.0D0
+	  RL_GL(13)=100.0D0
+	  RL_GL(14)=200.0D0
+	  RL_GL(15)=300.0D0
+	  RL_GL(16)=RADXXO(24,1)*1.0D4
+! TURBULENCE GRAUPEL BULK RADII IN MKM
+          RG_GL(1) = RADXXO(1,6)*1.0D4 
+          RG_GL(2) = 30.0D0  
+          RG_GL(3) = 60.0D0 
+          RG_GL(4) = 100.0D0 
+          RG_GL(5) = 200.0D0 
+	  RG_GL(6) = 300.0D0
+	  RG_GL(7) = 400.0D0
+	  RG_GL(8) = 500.0D0
+	  RG_GL(9) = 600.0D0
+	  RG_GL(10)= 700.0D0
+	  RG_GL(11)= 800.0D0
+	  RG_GL(12)= 900.0D0
+	  RG_GL(13)=1000.0D0
+	  RG_GL(14)=2000.0D0
+	  RG_GL(15)=3000.0D0
+	  RG_GL(16)=RADXXO(33,6)*1.0D4
+	  DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+                CTURBGL(I,J)=1.0D0
+             ENDDO
+          ENDDO
+          DO I=1,K0G_GL
+             DO J=1,K0L_GL
+                CTURB_GL(I,J)=1.0D0
+             ENDDO
+          ENDDO 
+          IF(IEPS_400.EQ.1) THEN
+	    CTURB_GL(1,1)=0.0D0
+	    CTURB_GL(1,2)=0.0D0
+	    CTURB_GL(1,3)=1.2D0
+	    CTURB_GL(1,4)=1.3D0
+	    CTURB_GL(1,5)=1.4D0
+	    CTURB_GL(1,6)=1.5D0
+	    CTURB_GL(1,7)=1.5D0
+	    CTURB_GL(1,8)=1.5D0
+	    CTURB_GL(1,9)=1.5D0
+	    CTURB_GL(1,10)=1.5D0
+	    CTURB_GL(1,11)=1.5D0
+	    CTURB_GL(1,12)=1.0D0
+	    CTURB_GL(1,13)=1.0D0
+	    CTURB_GL(1,14)=1.0D0
+	    CTURB_GL(1,15)=1.0D0
+	
+	    CTURB_GL(2,1)=1.0D0
+	    CTURB_GL(2,2)=1.4D0
+	    CTURB_GL(2,3)=1.8D0
+	    CTURB_GL(2,4)=2.2D0
+	    CTURB_GL(2,5)=2.6D0
+	    CTURB_GL(2,6)=3.0D0
+	    CTURB_GL(2,7)=2.85D0
+	    CTURB_GL(2,8)=2.7D0
+	    CTURB_GL(2,9)=2.55D0
+	    CTURB_GL(2,10)=2.4D0
+	    CTURB_GL(2,11)=2.25D0
+	    CTURB_GL(2,12)=1.0D0
+	    CTURB_GL(2,13)=1.0D0
+	    CTURB_GL(2,14)=1.0D0
+
+	    CTURB_GL(3,1)=7.5D0
+	    CTURB_GL(3,2)=7.5D0
+	    CTURB_GL(3,3)=4.5D0	
+	    CTURB_GL(3,4)=4.5D0	
+	    CTURB_GL(3,5)=4.65D0	
+	    CTURB_GL(3,6)=4.65D0	
+	    CTURB_GL(3,7)=4.5D0	
+	    CTURB_GL(3,8)=4.5D0	
+	    CTURB_GL(3,9)=4.0D0	
+	    CTURB_GL(3,10)=3.0D0	
+	    CTURB_GL(3,11)=2.0D0	
+	    CTURB_GL(3,12)=1.5D0	
+	    CTURB_GL(3,13)=1.3D0	
+	    CTURB_GL(3,14)=1.0D0	
+    
+	    CTURB_GL(4,1)=5.5D0
+	    CTURB_GL(4,2)=5.5D0
+	    CTURB_GL(4,3)=4.5D0
+	    CTURB_GL(4,4)=4.5D0
+	    CTURB_GL(4,5)=4.65D0
+	    CTURB_GL(4,6)=4.65D0
+	    CTURB_GL(4,7)=4.5D0
+	    CTURB_GL(4,8)=4.5D0
+	    CTURB_GL(4,9)=4.0D0
+	    CTURB_GL(4,10)=3.0D0
+	    CTURB_GL(4,11)=2.0D0
+	    CTURB_GL(4,12)=1.5D0
+	    CTURB_GL(4,13)=1.35D0
+	    CTURB_GL(4,14)=1.0D0
+	 
+	    CTURB_GL(5,1)=4.5D0
+	    CTURB_GL(5,2)=4.5D0
+	    CTURB_GL(5,3)=3.3D0	
+	    CTURB_GL(5,4)=3.3D0	
+	    CTURB_GL(5,5)=3.3D0	
+	    CTURB_GL(5,6)=3.4D0	
+	    CTURB_GL(5,7)=3.8D0	
+	    CTURB_GL(5,8)=3.8D0	
+	    CTURB_GL(5,9)=3.8D0	
+	    CTURB_GL(5,10)=3.6D0
+	    CTURB_GL(5,11)=2.5D0	
+	    CTURB_GL(5,12)=2.0D0	
+	    CTURB_GL(5,13)=1.4D0	
+	    CTURB_GL(5,14)=1.0D0	
+			 		
+	    CTURB_GL(6,1)=4.0D0
+	    CTURB_GL(6,2)=4.0D0
+	    CTURB_GL(6,3)=2.8D0
+	    CTURB_GL(6,4)=2.8D0
+	    CTURB_GL(6,5)=2.85D0
+	    CTURB_GL(6,6)=2.9D0
+	    CTURB_GL(6,7)=3.0D0
+	    CTURB_GL(6,8)=3.1D0
+	    CTURB_GL(6,9)=2.9D0
+	    CTURB_GL(6,10)=2.6D0
+	    CTURB_GL(6,11)=2.5D0
+	    CTURB_GL(6,12)=2.0D0
+	    CTURB_GL(6,13)=1.3D0
+	    CTURB_GL(6,14)=1.1D0
+
+	    CTURB_GL(7,1)=3.5D0
+	    CTURB_GL(7,2)=3.5D0
+	    CTURB_GL(7,3)=2.5D0
+	    CTURB_GL(7,4)=2.5D0
+	    CTURB_GL(7,5)=2.6D0
+	    CTURB_GL(7,6)=2.7D0
+	    CTURB_GL(7,7)=2.8D0
+	    CTURB_GL(7,8)=2.8D0
+	    CTURB_GL(7,9)=2.8D0
+	    CTURB_GL(7,10)=2.6D0
+	    CTURB_GL(7,11)=2.3D0
+	    CTURB_GL(7,12)=2.0D0
+	    CTURB_GL(7,13)=1.3D0
+	    CTURB_GL(7,14)=1.1D0
+
+	    CTURB_GL(8,1)=3.25D0
+	    CTURB_GL(8,2)=3.25D0
+	    CTURB_GL(8,3)=2.3D0
+	    CTURB_GL(8,4)=2.3D0
+	    CTURB_GL(8,5)=2.35D0
+	    CTURB_GL(8,6)=2.37D0
+	    CTURB_GL(8,7)=2.55D0
+	    CTURB_GL(8,8)=2.55D0
+	    CTURB_GL(8,9)=2.55D0
+	    CTURB_GL(8,10)=2.3D0
+	    CTURB_GL(8,11)=2.1D0
+	    CTURB_GL(8,12)=1.9D0
+	    CTURB_GL(8,13)=1.3D0
+	    CTURB_GL(8,14)=1.1D0
+
+	    CTURB_GL(9,1)=3.0D0
+	    CTURB_GL(9,2)=3.0D0
+	    CTURB_GL(9,3)=3.1D0
+	    CTURB_GL(9,4)=2.2D0
+	    CTURB_GL(9,5)=2.2D0
+	    CTURB_GL(9,6)=2.2D0
+	    CTURB_GL(9,7)=2.3D0
+	    CTURB_GL(9,8)=2.3D0
+	    CTURB_GL(9,9)=2.5D0
+	    CTURB_GL(9,10)=2.5D0
+	    CTURB_GL(9,11)=2.2D0
+	    CTURB_GL(9,12)=1.8D0
+	    CTURB_GL(9,13)=1.25D0
+	    CTURB_GL(9,14)=1.1D0
+
+	    CTURB_GL(10,1)=2.75D0
+	    CTURB_GL(10,2)=2.75D0
+	    CTURB_GL(10,3)=2.0D0
+	    CTURB_GL(10,4)=2.0D0
+	    CTURB_GL(10,5)=2.0D0
+	    CTURB_GL(10,6)=2.1D0
+	    CTURB_GL(10,7)=2.2D0
+	    CTURB_GL(10,8)=2.2D0
+	    CTURB_GL(10,9)=2.3D0
+	    CTURB_GL(10,10)=2.3D0
+	    CTURB_GL(10,11)=2.3D0
+	    CTURB_GL(10,12)=1.8D0
+	    CTURB_GL(10,13)=1.2D0
+	    CTURB_GL(10,14)=1.1D0
+
+	    CTURB_GL(11,1)=2.6D0
+	    CTURB_GL(11,2)=2.6D0
+	    CTURB_GL(11,3)=1.95D0
+	    CTURB_GL(11,4)=1.95D0
+	    CTURB_GL(11,5)=1.95D0
+	    CTURB_GL(11,6)=2.05D0
+	    CTURB_GL(11,7)=2.15D0
+	    CTURB_GL(11,8)=2.15D0
+	    CTURB_GL(11,9)=2.25D0
+	    CTURB_GL(11,10)=2.25D0
+	    CTURB_GL(11,11)=1.9D0
+	    CTURB_GL(11,12)=1.8D0
+	    CTURB_GL(11,13)=1.2D0
+	    CTURB_GL(11,14)=1.1D0
+
+	    CTURB_GL(12,1)=2.4D0
+	    CTURB_GL(12,2)=2.4D0
+	    CTURB_GL(12,3)=1.85D0
+	    CTURB_GL(12,4)=1.85D0
+	    CTURB_GL(12,5)=1.85D0
+	    CTURB_GL(12,6)=1.75D0
+	    CTURB_GL(12,7)=1.85D0
+	    CTURB_GL(12,8)=1.85D0
+	    CTURB_GL(12,9)=2.1D0
+	    CTURB_GL(12,10)=2.1D0
+	    CTURB_GL(12,11)=1.9D0
+	    CTURB_GL(12,12)=1.8D0 
+	    CTURB_GL(12,13)=1.3D0
+	    CTURB_GL(12,14)=1.1D0
+
+	    CTURB_GL(13,1)=1.67D0
+	    CTURB_GL(13,2)=1.67D0
+	    CTURB_GL(13,3)=1.75D0
+	    CTURB_GL(13,4)=1.83D0
+	    CTURB_GL(13,5)=1.87D0
+	    CTURB_GL(13,6)=2.0D0
+	    CTURB_GL(13,7)=2.1D0
+	    CTURB_GL(13,8)=2.12D0
+	    CTURB_GL(13,9)=2.15D0
+	    CTURB_GL(13,10)=2.18D0
+	    CTURB_GL(13,11)=2.19D0
+	    CTURB_GL(13,12)=1.67D0
+	    CTURB_GL(13,13)=1.28D0
+	    CTURB_GL(13,14)=1.0D0
+
+	    CTURB_GL(14,1)=1.3D0
+	    CTURB_GL(14,2)=1.3D0
+	    CTURB_GL(14,3)=1.35D0
+	    CTURB_GL(14,4)=1.4D0
+	    CTURB_GL(14,5)=1.6D0
+	    CTURB_GL(14,6)=1.7D0
+	    CTURB_GL(14,7)=1.7D0
+	    CTURB_GL(14,8)=1.7D0
+	    CTURB_GL(14,9)=1.7D0
+	    CTURB_GL(14,10)=1.7D0
+	    CTURB_GL(14,11)=1.7D0
+	    CTURB_GL(14,12)=1.4D0
+	    CTURB_GL(14,13)=1.25D0
+	    CTURB_GL(14,14)=1.0D0
+
+	    CTURB_GL(15,1)=1.17D0
+	    CTURB_GL(15,2)=1.17D0
+	    CTURB_GL(15,3)=1.17D0
+	    CTURB_GL(15,4)=1.25D0
+	    CTURB_GL(15,5)=1.3D0
+	    CTURB_GL(15,6)=1.35D0
+	    CTURB_GL(15,7)=1.4D0
+	    CTURB_GL(15,8)=1.4D0
+	    CTURB_GL(15,9)=1.45D0
+	    CTURB_GL(15,10)=1.47D0
+	    CTURB_GL(15,11)=1.44D0
+	    CTURB_GL(15,12)=1.3D0
+	    CTURB_GL(15,13)=1.12D0
+	    CTURB_GL(15,14)=1.0D0
+
+	    CTURB_GL(16,1)=1.17D0
+	    CTURB_GL(16,2)=1.17D0
+	    CTURB_GL(16,3)=1.17D0
+	    CTURB_GL(16,4)=1.25D0
+	    CTURB_GL(16,5)=1.3D0
+	    CTURB_GL(16,6)=1.35D0
+	    CTURB_GL(16,7)=1.4D0
+	    CTURB_GL(16,8)=1.45D0
+	    CTURB_GL(16,9)=1.45D0
+	    CTURB_GL(16,10)=1.47D0
+	    CTURB_GL(16,11)=1.44D0
+	    CTURB_GL(16,12)=1.3D0
+	    CTURB_GL(16,13)=1.12D0
+	    CTURB_GL(16,14)=1.0D0
+          ENDIF
+          IF(IEPS_800.EQ.1) THEN
+	    CTURB_GL(1,1) =0.00D0
+	    CTURB_GL(1,2) =0.00D0
+	    CTURB_GL(1,3) =1.00D0
+            CTURB_GL(1,4) =1.50D0
+	    CTURB_GL(1,5) =1.40D0
+	    CTURB_GL(1,6) =1.30D0
+	    CTURB_GL(1,7) =1.20D0
+	    CTURB_GL(1,8) =1.10D0
+	    CTURB_GL(1,9) =1.00D0
+	    CTURB_GL(1,10)=1.00D0
+	    CTURB_GL(1,11)=1.00D0
+	    CTURB_GL(1,12)=1.00D0
+	    CTURB_GL(1,13)=1.00D0
+	    CTURB_GL(1,14)=1.00D0
+	    CTURB_GL(1,15)=1.00D0
+	    CTURB_GL(1,16)=1.00D0
+
+	    CTURB_GL(2,1) =0.00D0
+	    CTURB_GL(2,2) =0.00D0
+	    CTURB_GL(2,3) =1.00D0
+	    CTURB_GL(2,4) =2.00D0
+	    CTURB_GL(2,5) =1.80D0
+	    CTURB_GL(2,6) =1.70D0
+	    CTURB_GL(2,7) =1.60D0
+	    CTURB_GL(2,8) =1.50D0
+	    CTURB_GL(2,9) =1.50D0
+	    CTURB_GL(2,10)=1.50D0
+	    CTURB_GL(2,11)=1.50D0
+	    CTURB_GL(2,12)=1.50D0
+	    CTURB_GL(2,13)=1.50D0
+	    CTURB_GL(2,14)=1.00D0
+	    CTURB_GL(2,15)=1.00D0
+	    CTURB_GL(2,16)=1.00D0
+
+	    CTURB_GL(3,1) =0.00D0
+	    CTURB_GL(3,2) =0.00D0
+	    CTURB_GL(3,3) =4.00D0
+	    CTURB_GL(3,4) =7.65D0
+	    CTURB_GL(3,5) =7.65D0
+	    CTURB_GL(3,6) =8.00D0
+	    CTURB_GL(3,7) =8.00D0
+	    CTURB_GL(3,8) =7.50D0
+	    CTURB_GL(3,9) =6.50D0
+	    CTURB_GL(3,10)=6.00D0
+	    CTURB_GL(3,11)=5.00D0
+	    CTURB_GL(3,12)=4.50D0
+	    CTURB_GL(3,13)=4.00D0
+	    CTURB_GL(3,14)=2.00D0
+	    CTURB_GL(3,15)=1.30D0
+	    CTURB_GL(3,16)=1.00D0
+
+	    CTURB_GL(4,1) =7.50D0
+	    CTURB_GL(4,2) =7.50D0
+	    CTURB_GL(4,3) =7.50D0
+	    CTURB_GL(4,4) =7.65D0	
+	    CTURB_GL(4,5) =7.65D0	
+	    CTURB_GL(4,6) =8.00D0	
+	    CTURB_GL(4,7) =8.00D0	
+	    CTURB_GL(4,8) =7.50D0	
+	    CTURB_GL(4,9) =6.50D0	
+	    CTURB_GL(4,10)=6.00D0	
+	    CTURB_GL(4,11)=5.00D0	
+	    CTURB_GL(4,12)=4.50D0	
+	    CTURB_GL(4,13)=4.00D0	
+	    CTURB_GL(4,14)=2.00D0	
+	    CTURB_GL(4,15)=1.30D0	
+	    CTURB_GL(4,16)=1.00D0	
+    
+	    CTURB_GL(5,1) =5.50D0
+	    CTURB_GL(5,2) =5.50D0
+	    CTURB_GL(5,3) =5.50D0
+	    CTURB_GL(5,4) =5.75D0
+	    CTURB_GL(5,5) =5.75D0
+	    CTURB_GL(5,6) =6.00D0
+	    CTURB_GL(5,7) =6.25D0
+	    CTURB_GL(5,8) =6.17D0
+	    CTURB_GL(5,9) =5.75D0
+	    CTURB_GL(5,10)=5.25D0
+	    CTURB_GL(5,11)=4.75D0
+	    CTURB_GL(5,12)=4.25D0
+	    CTURB_GL(5,13)=4.00D0
+	    CTURB_GL(5,14)=2.00D0
+	    CTURB_GL(5,15)=1.35D0
+	    CTURB_GL(5,16)=1.00D0
+	 
+	    CTURB_GL(6,1) =4.50D0
+	    CTURB_GL(6,2) =4.50D0
+	    CTURB_GL(6,3) =4.50D0
+	    CTURB_GL(6,4) =4.75D0	
+	    CTURB_GL(6,5) =4.75D0	
+	    CTURB_GL(6,6) =5.00D0	
+	    CTURB_GL(6,7) =5.25D0	
+	    CTURB_GL(6,8) =5.25D0	
+	    CTURB_GL(6,9) =5.00D0	
+	    CTURB_GL(6,10)=4.75D0	
+	    CTURB_GL(6,11)=4.50D0	
+	    CTURB_GL(6,12)=4.00D0	
+	    CTURB_GL(6,13)=3.75D0	
+	    CTURB_GL(6,14)=2.00D0	
+	    CTURB_GL(6,15)=1.40D0	
+	    CTURB_GL(6,16)=1.00D0	
+			 		
+	    CTURB_GL(7,1) =4.00D0
+	    CTURB_GL(7,2) =4.00D0
+	    CTURB_GL(7,3) =4.00D0
+	    CTURB_GL(7,4) =4.00D0
+	    CTURB_GL(7,5) =4.00D0
+	    CTURB_GL(7,6) =4.25D0
+	    CTURB_GL(7,7) =4.50D0
+	    CTURB_GL(7,8) =4.67D0
+	    CTURB_GL(7,9) =4.50D0
+	    CTURB_GL(7,10)=4.30D0
+	    CTURB_GL(7,11)=4.10D0
+	    CTURB_GL(7,12)=3.80D0
+	    CTURB_GL(7,13)=3.50D0
+	    CTURB_GL(7,14)=2.00D0
+	    CTURB_GL(7,15)=1.30D0
+	    CTURB_GL(7,16)=1.10D0
+
+	    CTURB_GL(8,1) =3.50D0
+	    CTURB_GL(8,2) =3.50D0
+	    CTURB_GL(8,3) =3.50D0
+	    CTURB_GL(8,4) =3.65D0
+	    CTURB_GL(8,5) =3.65D0
+	    CTURB_GL(8,6) =3.80D0
+	    CTURB_GL(8,7) =4.1D02
+	    CTURB_GL(8,8) =4.17D0
+	    CTURB_GL(8,9) =4.17D0
+	    CTURB_GL(8,10)=4.00D0
+	    CTURB_GL(8,11)=3.80D0
+	    CTURB_GL(8,12)=3.67D0
+	    CTURB_GL(8,13)=3.40D0
+	    CTURB_GL(8,14)=2.00D0
+	    CTURB_GL(8,15)=1.30D0
+	    CTURB_GL(8,16)=1.10D0
+
+	    CTURB_GL(9,1) =3.25D0
+	    CTURB_GL(9,2) =3.25D0
+	    CTURB_GL(9,3) =3.25D0
+	    CTURB_GL(9,4) =3.25D0
+	    CTURB_GL(9,5) =3.25D0
+	    CTURB_GL(9,6) =3.50D0
+	    CTURB_GL(9,7) =3.75D0
+	    CTURB_GL(9,8) =3.75D0
+	    CTURB_GL(9,9) =3.75D0
+	    CTURB_GL(9,10)=3.75D0
+	    CTURB_GL(9,11)=3.60D0
+	    CTURB_GL(9,12)=3.40D0
+	    CTURB_GL(9,13)=3.25D0
+	    CTURB_GL(9,14)=2.00D0
+	    CTURB_GL(9,15)=1.30D0
+	    CTURB_GL(9,16)=1.10D0
+	    
+	    CTURB_GL(10,1) =3.00D0
+	    CTURB_GL(10,2) =3.00D0
+	    CTURB_GL(10,3) =3.00D0
+	    CTURB_GL(10,4) =3.10D0
+	    CTURB_GL(10,5) =3.10D0
+	    CTURB_GL(10,6) =3.25D0
+	    CTURB_GL(10,7) =3.40D0
+	    CTURB_GL(10,8) =3.50D0
+	    CTURB_GL(10,9) =3.50D0
+	    CTURB_GL(10,10)=3.50D0
+	    CTURB_GL(10,11)=3.40D0
+	    CTURB_GL(10,12)=3.25D0
+	    CTURB_GL(10,13)=3.15D0
+	    CTURB_GL(10,14)=1.90D0
+	    CTURB_GL(10,15)=1.30D0
+	    CTURB_GL(10,16)=1.10D0
+
+	    CTURB_GL(11,1) =2.75D0
+	    CTURB_GL(11,2) =2.75D0
+	    CTURB_GL(11,3) =2.75D0
+	    CTURB_GL(11,4) =2.75D0
+	    CTURB_GL(11,5) =2.75D0
+	    CTURB_GL(11,6) =3.00D0
+	    CTURB_GL(11,7) =3.25D0
+	    CTURB_GL(11,8) =3.25D0
+	    CTURB_GL(11,9) =3.25D0
+	    CTURB_GL(11,10)=3.25D0
+	    CTURB_GL(11,11)=3.25D0
+	    CTURB_GL(11,12)=3.15D0
+	    CTURB_GL(11,13)=3.00D0
+	    CTURB_GL(11,14)=1.80D0
+	    CTURB_GL(11,15)=1.30D0
+	    CTURB_GL(11,16)=1.10D0
+
+	    CTURB_GL(12,1) =2.60D0
+	    CTURB_GL(12,2) =2.60D0
+	    CTURB_GL(12,3) =2.60D0
+	    CTURB_GL(12,4) =2.67D0
+	    CTURB_GL(12,5) =2.67D0
+	    CTURB_GL(12,6) =2.75D0
+	    CTURB_GL(12,7) =3.00D0
+	    CTURB_GL(12,8) =3.17D0
+	    CTURB_GL(12,9) =3.17D0
+	    CTURB_GL(12,10)=3.17D0
+	    CTURB_GL(12,11)=3.10D0
+	    CTURB_GL(12,12)=2.90D0
+	    CTURB_GL(12,13)=2.80D0
+	    CTURB_GL(12,14)=1.87D0
+	    CTURB_GL(12,15)=1.37D0
+	    CTURB_GL(12,16)=1.10D0
+
+	    CTURB_GL(13,1) =2.40D0
+	    CTURB_GL(13,2) =2.40D0
+	    CTURB_GL(13,3) =2.40D0
+	    CTURB_GL(13,4) =2.50D0
+	    CTURB_GL(13,5) =2.50D0
+	    CTURB_GL(13,6) =2.67D0
+	    CTURB_GL(13,7) =2.83D0
+	    CTURB_GL(13,8) =2.90D0
+	    CTURB_GL(13,9) =3.00D0
+	    CTURB_GL(13,10)=2.90D0
+	    CTURB_GL(13,11)=2.85D0
+	    CTURB_GL(13,12)=2.80D0
+	    CTURB_GL(13,13)=2.75D0
+	    CTURB_GL(13,14)=1.83D0
+	    CTURB_GL(13,15)=1.30D0
+	    CTURB_GL(13,16)=1.10D0
+
+	    CTURB_GL(14,1) =1.67D0
+	    CTURB_GL(14,2) =1.67D0
+	    CTURB_GL(14,3) =1.67D0
+	    CTURB_GL(14,4) =1.75D0
+	    CTURB_GL(14,5) =1.75D0
+	    CTURB_GL(14,6) =1.83D0
+	    CTURB_GL(14,7) =1.87D0
+	    CTURB_GL(14,8) =2.00D0
+	    CTURB_GL(14,9) =2.10D0
+	    CTURB_GL(14,10)=2.12D0
+	    CTURB_GL(14,11)=2.15D0
+	    CTURB_GL(14,12)=2.18D0
+	    CTURB_GL(14,13)=2.19D0
+	    CTURB_GL(14,14)=1.67D0
+	    CTURB_GL(14,15)=1.28D0
+	    CTURB_GL(14,16)=1.00D0
+
+	    CTURB_GL(15,1) =1.30D0
+	    CTURB_GL(15,2) =1.30D0
+	    CTURB_GL(15,3) =1.30D0
+	    CTURB_GL(15,4) =1.35D0
+	    CTURB_GL(15,5) =1.35D0
+	    CTURB_GL(15,6) =1.40D0
+	    CTURB_GL(15,7) =1.60D0
+	    CTURB_GL(15,8) =1.70D0
+	    CTURB_GL(15,9) =1.70D0
+	    CTURB_GL(15,10)=1.70D0
+	    CTURB_GL(15,11)=1.70D0
+	    CTURB_GL(15,12)=1.70D0
+	    CTURB_GL(15,13)=1.70D0
+	    CTURB_GL(15,14)=1.40D0
+	    CTURB_GL(15,15)=1.25D0
+	    CTURB_GL(15,16)=1.00D0
+
+	    CTURB_GL(16,1) =1.17D0
+	    CTURB_GL(16,2) =1.17D0
+	    CTURB_GL(16,3) =1.17D0
+	    CTURB_GL(16,4) =1.17D0
+	    CTURB_GL(16,5) =1.17D0
+	    CTURB_GL(16,6) =1.25D0
+	    CTURB_GL(16,7) =1.30D0
+	    CTURB_GL(16,8) =1.35D0
+	    CTURB_GL(16,9) =1.40D0
+	    CTURB_GL(16,10)=1.45D0
+	    CTURB_GL(16,11)=1.45D0
+	    CTURB_GL(16,12)=1.47D0
+	    CTURB_GL(16,13)=1.44D0
+	    CTURB_GL(16,14)=1.30D0
+	    CTURB_GL(16,15)=1.12D0
+	    CTURB_GL(16,16)=1.00D0
+          ENDIF
+          IF(IEPS_800.EQ.1.AND.IEPS_1600.EQ.1) THEN
+            DO I=1,K0G_GL
+               DO J=1,K0L_GL
+                  CTURB_GL(I,J)=CTURB_GL(I,J)*1.7D0
+               ENDDO
+            ENDDO 
+          ENDIF
+          DO J=1,K0L_GL
+             DO I=1,K0G_GL
+                CTURB_GL(I,J)=(CTURB_GL(I,J)-1.0D0)/1.5D0+1.0D0
+             ENDDO
+          ENDDO
+	  DO I=KRMING_GL,KRMAXG_GL
+             DO J=KRMINL_GL,KRMAXL_GL
+                CTURBGL(I,J)=1.
+             ENDDO
+          ENDDO
+          DO I=KRMING_GL,KRMAXG_GL                   
+             X_KERN=RADXXO(I,6)*1.0D4
+             IF(X_KERN.LT.RG_GL(1)) X_KERN=RG_GL(1)
+             IF(X_KERN.GT.RG_GL(K0G_GL)) X_KERN=RG_GL(K0G_GL) 
+             DO J=KRMINL_GL,KRMAXL_GL
+                Y_KERN=RADXXO(J,1)*1.0D4
+                IF(Y_KERN.LT.RL_GL(1)) Y_KERN=RL_GL(1)
+                IF(Y_KERN.GT.RL_GL(K0L_GL)) Y_KERN=RL_GL(K0L_GL)
+                CTURBGL(I,J)=F(X_KERN,Y_KERN,RG_GL,RL_GL,CTURB_GL &
+     &                      ,K0G_GL,K0L_GL)	      
+             ENDDO
+          ENDDO
+          IF(IEPS_800.EQ.1) THEN
+            DO I=KRMING_GL,15
+               DO J=KRMINL_GL,13
+                  IF(CTURBGL(I,J).LT.3.0D0) CTURBGL(I,J)=3.0D0
+               ENDDO
+            ENDDO
+          ENDIF
+          IF(IEPS_1600.EQ.1) THEN
+            DO I=KRMING_GL,15
+               DO J=KRMINL_GL,13
+                  IF(CTURBGL(I,J).LT.5.1D0) CTURBGL(I,J)=5.1D0
+               ENDDO
+            ENDDO
+          ENDIF
+	  DO I=1,33
+             DO J=1,24
+                IF(I.LE.14.AND.J.EQ.8) CTURBGL(I,J)=1.0D0
+                IF(I.GT.14.AND.J.LE.8) CTURBGL(I,J)=1.2D0
+	     ENDDO
+          ENDDO                       
+	RETURN
+	END SUBROUTINE TURBCOEF
+!===================================================================
+! QUESTION
+        real * 8 function f(x,y,x0,y0,table,k0,kk0)
+! two-dimensional linear interpolation of the collision efficiency
+! with help table(k0,kk0)
+
+       implicit none
+       integer k0,kk0,k,ir,kk,iq
+       double precision x,y,p,q,ec,ek
+!      double precision x,y,p,q,ec,ek,f
+       double precision x0(k0),y0(kk0),table(k0,kk0)
+
+
+        do k=2,k0
+           if(x.le.x0(k).and.x.ge.x0(k-1)) then
+             ir=k     
+           elseif(x.gt.x0(k0)) then
+             ir=k0+1
+           elseif(x.lt.x0(1)) then
+             ir=1
+           endif
+        enddo
+        do kk=2,kk0
+           if(y.le.y0(kk).and.y.ge.y0(kk-1)) iq=kk
+        enddo
+        if(ir.lt.k0+1) then
+          if(ir.ge.2) then
+            p =(x-x0(ir-1))/(x0(ir)-x0(ir-1))
+            q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
+            ec=(1.d0-p)*(1.d0-q)*table(ir-1,iq-1)+ &
+     &              p*(1.d0-q)*table(ir,iq-1)+ &
+     &              q*(1.d0-p)*table(ir-1,iq)+ &
+     &                   p*q*table(ir,iq)    
+          else
+            q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
+            ec=(1.d0-q)*table(1,iq-1)+q*table(1,iq)    
+          endif
+        else
+          q =(y-y0(iq-1))/(y0(iq)-y0(iq-1))
+          ek=(1.d0-q)*table(k0,iq-1)+q*table(k0,iq)
+          ec=min(ek,1.d0) 
+        endif
+        f=ec
+        return
+        end function f
+! function f
+                                                                            
+
+                                                                            
+
+!======================================================================
+        SUBROUTINE FREEZ(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
+     &,TIN,DT,RO,COL,AFREEZMY,BFREEZMY,BFREEZMAX,KRFREEZ,ICEMAX,NKR)       
+      IMPLICIT NONE 
+      INTEGER KR,ICE,ICE_TYPE
+      REAL COL,AFREEZMY,BFREEZMY,BFREEZMAX
+      INTEGER KRFREEZ,ICEMAX,NKR
+      REAL DT,RO,YKK,PF,PF_1,DEL_T,TT_DROP,ARG_1,YK2,DF1,BF,ARG_M, & 
+     & TT_DROP_AFTER_FREEZ,CFREEZ,SUM_ICE,TIN,TTIN,AF,FF_MAX,F1_MAX, &
+     & F2_MAX,F3_MAX,F4_MAX,F5_MAX
+
+
+	REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX) &
+     &           ,XI(NKR,ICEMAX),FF3(NKR),XS(NKR),FF4(NKR) &
+     &           ,XG(NKR),FF5(NKR),XH(NKR)
+
+
+
+	TTIN=TIN
+        DEL_T	=TTIN-273.15
+	ICE_TYPE=2
+	F1_MAX=0.
+	F2_MAX=0.
+	F3_MAX=0.
+	F4_MAX=0.
+	F5_MAX=0.
+	DO 1 KR=1,NKR
+	F1_MAX=AMAX1(F1_MAX,FF1(KR))
+	F3_MAX=AMAX1(F3_MAX,FF3(KR))
+	F4_MAX=AMAX1(F4_MAX,FF4(KR))
+	F5_MAX=AMAX1(F5_MAX,FF5(KR))
+	DO 1 ICE=1,ICEMAX
+     	F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
+    1   CONTINUE
+    	FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
+!
+!******************************* FREEZING ****************************
+!
+        IF(DEL_T.LT.0.AND.F1_MAX.NE.0) THEN
+	SUM_ICE=0.
+	AF	=AFREEZMY
+	CFREEZ	=(BFREEZMAX-BFREEZMY)/XL(NKR)
+!
+!***************************** MASS LOOP **************************
+!
+         DO  KR	=1,NKR
+	 ARG_M	=XL(KR)
+	 BF	=BFREEZMY+CFREEZ*ARG_M
+         PF_1	=AF*EXP(-BF*DEL_T)
+         PF	=ARG_M*PF_1
+	 YKK	=EXP(-PF*DT)
+         DF1	=FF1(KR)*(1.-YKK)
+	 YK2	=DF1
+         FF1(KR)=FF1(KR)*YKK
+	 IF(KR.LE.KRFREEZ)  THEN
+	 FF2(KR,ICE_TYPE)=FF2(KR,ICE_TYPE)+YK2
+			    ELSE
+	  FF5(KR)	=FF5(KR)+YK2
+	 ENDIF
+         SUM_ICE=SUM_ICE+YK2*3.*XL(KR)*XL(KR)*COL
+!
+!************************ END OF "MASS LOOP" **************************
+!
+	 ENDDO
+!
+!************************** NEW TEMPERATURE *************************
+!	
+	ARG_1	=333.*SUM_ICE/RO
+      	TT_DROP_AFTER_FREEZ=TTIN+ARG_1
+	TIN	=TT_DROP_AFTER_FREEZ
+!
+!************************** END OF "FREEZING" ****************************
+!
+	ENDIF
+!
+   	RETURN                                                           
+      	END SUBROUTINE FREEZ                                                             
+
+        SUBROUTINE ORIG_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
+     &                           ,TIN,DT,RO,COL,ICEMAX,NKR)
+      IMPLICIT NONE
+      INTEGER KR,ICE,ICE_TYPE
+      INTEGER ICEMAX,NKR
+      REAL COL
+      REAL ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DT,DF1,DN,DN0, &
+     & RO,A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, &
+     & DEL_T,TIN
+        REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX),XI(NKR,ICEMAX) &
+     &           ,FF3(NKR),XS(NKR),FF4(NKR) &
+     &           ,XG(NKR),FF5(NKR),XH(NKR)
+
+
+!       gamma=4.4
+        DEL_T	=TIN-273.15
+	ICE_TYPE=2
+	F1_MAX=0.
+	F2_MAX=0.
+	F3_MAX=0.
+	F4_MAX=0.
+	F5_MAX=0.
+	DO 1 KR=1,NKR
+	F1_MAX=AMAX1(F1_MAX,FF1(KR))
+	F3_MAX=AMAX1(F3_MAX,FF3(KR))
+	F4_MAX=AMAX1(F4_MAX,FF4(KR))
+	F5_MAX=AMAX1(F5_MAX,FF5(KR))
+	DO 1 ICE=1,ICEMAX
+     	F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
+    1	CONTINUE
+    	FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
+! MELTING :
+	IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN
+	  SUM_ICE=0.
+! MASS LOOP :
+  	  DO KR=1,NKR
+	     ARG_M=FF3(KR)+FF4(KR)+FF5(KR)
+	     DO ICE=1,ICEMAX
+	        ARG_M=ARG_M+FF2(KR,ICE)
+      	        FF2(KR,ICE)=0.
+ 	     ENDDO
+      	     FF1(KR)=FF1(KR)+ARG_M
+      	     FF3(KR)=0.
+             FF4(KR)=0.
+      	     FF5(KR)=0.
+	     SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL
+! END OF "MASS LOOP"
+	  ENDDO
+! CYCLE BY KR
+! NEW TEMPERATURE :
+	  ARG_1=333.*SUM_ICE/RO	
+	  TIN=TIN-ARG_1
+! END OF MELTING
+! IN CASE DEL_T.GE.0.AND.FF_MAX.NE.0
+	ENDIF
+   	RETURN                                                           
+      	END SUBROUTINE ORIG_MELT                                                             
+       SUBROUTINE J_W_MELT(FF1,XL,FF2,XI,FF3,XS,FF4,XG,FF5,XH &
+     &                           ,TIN,DT,RO,COL,ICEMAX,NKR)
+      IMPLICIT NONE
+      INTEGER KR,ICE,ICE_TYPE
+      INTEGER ICEMAX,NKR
+      REAL COL
+      REAL ARG_M,TT_DROP,ARG_1,TT_DROP_AFTER_FREEZ,DT,DF1,DN,DN0, &
+     & RO,A,B,DTFREEZ,SUM_ICE,FF_MAX,F1_MAX,F2_MAX,F3_MAX,F4_MAX,F5_MAX, &
+     & DEL_T,TIN,meltrate
+        REAL FF1(NKR),XL(NKR),FF2(NKR,ICEMAX),XI(NKR,ICEMAX) &
+     &           ,FF3(NKR),XS(NKR),FF4(NKR) &
+     &           ,XG(NKR),FF5(NKR),XH(NKR)
+
+
+!       gamma=4.4
+        DEL_T	=TIN-273.15
+	F1_MAX=0.
+	F2_MAX=0.
+	F3_MAX=0.
+	F4_MAX=0.
+	F5_MAX=0.
+	DO 1 KR=1,NKR
+	F1_MAX=AMAX1(F1_MAX,FF1(KR))
+	F3_MAX=AMAX1(F3_MAX,FF3(KR))
+	F4_MAX=AMAX1(F4_MAX,FF4(KR))
+	F5_MAX=AMAX1(F5_MAX,FF5(KR))
+	DO 1 ICE=1,ICEMAX
+     	F2_MAX=AMAX1(F2_MAX,FF2(KR,ICE))
+    1	CONTINUE
+    	FF_MAX=AMAX1(F2_MAX,F3_MAX,F4_MAX,F5_MAX)
+! MELTING :
+	SUM_ICE=0.
+	IF(DEL_T.GE.0.AND.FF_MAX.NE.0) THEN
+! Fan's "MASS LOOP"
+          DO KR = 1,NKR
+             ARG_M = 0.
+            DO ICE = 1,ICEMAX
+             IF (ICE ==1) THEN
+                 IF (KR .le. 10) THEN
+                     FF2(KR,ICE)=0.
+                     ARG_M = ARG_M+FF2(KR,ICE)
+                 ELSEIF (KR .gt. 10 .and. KR .lt. 18) THEN
+                     meltrate = 0.5/50.
+                     FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
+                     ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
+                 ELSE
+                     meltrate = 0.683/120.
+                     FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
+                     ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
+                 ENDIF
+             ENDIF
+             IF (ICE ==2 .or. ICE ==3) THEN
+                IF (kr .le. 12) THEN
+                    FF2(KR,ICE)=0.
+                    ARG_M = ARG_M+FF2(KR,ICE)
+                ELSEIF (kr .gt. 12 .and. kr .lt. 20) THEN
+                    meltrate = 0.5/50.
+                    FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
+                    ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
+                 ELSE
+                     meltrate = 0.683/120.
+                    FF2(KR,ICE)=FF2(KR,ICE)-FF2(KR,ICE)*(meltrate*dt)
+                    ARG_M=ARG_M+FF2(KR,ICE)*(meltrate*dt)
+                 ENDIF
+             ENDIF
+            ENDDO  ! Do ice
+! snow
+                 IF (kr .le. 14) THEN
+                    FF3(KR)=0.
+                    ARG_M = ARG_M+FF3(KR)
+                 ELSEIF (kr .gt. 14 .and. kr .lt. 22) THEN
+                    meltrate = 0.5/50.
+                    FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
+                    ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
+                 ELSE
+                    meltrate = 0.683/120.
+                    FF3(KR)=FF3(KR)-FF3(KR)*(meltrate*dt)
+                    ARG_M=ARG_M+FF3(KR)*(meltrate*dt)
+                 ENDIF
+! graupel/hail
+                 IF (kr .le. 13) then
+                     FF4(KR)=0.
+                     FF5(KR)=0.
+                     ARG_M = ARG_M+FF4(KR)+FF5(KR)
+                 ELSEIF (kr .gt. 13 .and. kr .lt. 23) THEN
+                     meltrate = 0.5/50.
+                     FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
+                     FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
+                     ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
+                 ELSE
+                     meltrate = 0.683/120.
+                    FF4(KR)=FF4(KR)-FF4(KR)*(meltrate*dt)
+                    FF5(KR)=FF5(KR)-FF5(KR)*(meltrate*dt)
+                    ARG_M=ARG_M+(FF4(KR)+FF5(KR))*(meltrate*dt)
+                 ENDIF
+
+                   FF1(KR)=FF1(KR)+ARG_M
+
+                   SUM_ICE=SUM_ICE+ARG_M*3.*XL(KR)*XL(KR)*COL
+! END OF Fan'a "MASS LOOP"
+       ENDDO
+! CYCLE BY KR
+! NEW TEMPERATURE :
+        ARG_1=333.*SUM_ICE/RO
+        TIN=TIN-ARG_1
+! END OF MELTING
+
+	ENDIF
+   	RETURN                                                           
+      	END SUBROUTINE J_W_MELT                                                             
+!===================================================================
+      SUBROUTINE JERNUCL01(PSI1,PSI2,FCCNR &
+     &                    ,X1,X2,DTT,DQQ,ROR,PP,DSUP1,DSUP2 &
+     &  ,COL,AA1_MY, BB1_MY, AA2_MY, BB2_MY &
+     &  ,C1_MEY,C2_MEY,SUP2_OLD,DSUPICEXZ &
+     &  ,RCCN,DROPRADII,NKR,ICEMAX,ICEPROCS)
+      IMPLICIT NONE 
+!
+      INTEGER ICEMAX,NKR
+      INTEGER ICEPROCS
+      REAL COL,AA1_MY, BB1_MY, AA2_MY, BB2_MY, &
+     &  C1_MEY,C2_MEY,SUP2_OLD,DSUPICEXZ, &
+     &  RCCN(NKR),DROPRADII(NKR),FCCNR(NKR)
+!
+      INTEGER KR,ICE,ITYPE,NRGI,ICORR,II,JJ,KK,NKRDROP,NCRITI
+       DOUBLE PRECISION DTT,DQQ,DSUP1,DSUP2
+       REAL TT,QQ,              &
+     & DX,BMASS,CONCD,C2,CONCDF,DELTACD,CONCDIN,ROR, &
+     & DELTAF,DELMASSL,FMASS,HELEK1,DEL2NN,FF1BN, &
+     & HELEK2,TPCC,PP,ADDF,DSUP2N,FACT,EW1N,ES2N,ES1N,FNEW, &
+     & C1,SUP1N,SUP2N,QPN,TPN,TPC,SUP1,SUP2,DEL1N,DEL2N,AL1,AL2, &
+     & TEMP1,TEMP2,TEMP3,A1,B1,A2,B2 
+!
+
+!********************************************************************
+
+! NEW MEYERS IN JERNUCL01 SUBROUTINE 
+
+
+
+!********************************************************************
+
+
+
+      REAL PSI1(NKR),X1(NKR),DROPCONCN(NKR) &
+     &     ,PSI2(NKR,ICEMAX),X2(NKR,ICEMAX)
+      
+
+      DATA A1,B1,A2,B2/-0.639,0.1296,-2.8,0.262/
+      DATA TEMP1,TEMP2,TEMP3/-5.,-2.,-20./
+      DATA AL1/2500./,AL2/2834./
+      SUP1=DSUP1
+      SUP2=DSUP2
+
+
+      TT=DTT
+      QQ=DQQ
+! DROPLETS NUCLEATION (BEGIN)
+
+        TPN=TT
+        QPN=QQ
+
+        DEL1N=100.*SUP1
+        TPC=TT-273.15
+
+        IF(DEL1N.GT.0.AND.TPC.GT.-73.16) THEN
+         CALL WATER_NUCL (PSI1,FCCNR,X1,TT,SUP1  &
+     &        ,COL,RCCN,DROPRADII,NKR,ICEMAX)
+        ENDIF
+! DROPLETS NUCLEATION (END)
+! drop nucleation                                               (end)
+! nucleation of crystals                                      (begin)
+
+       IF (ICEPROCS.EQ.1)THEN
+        DEL2N=100.*SUP2
+        IF(TPC.LT.0..AND.TPC.GE.-73.16.AND.DEL2N.GT.0.) THEN
+
+              CALL ICE_NUCL (PSI2,X2,TT,ROR,SUP2,SUP2_OLD &
+     &                      ,C1_MEY,C2_MEY,COL,DSUPICEXZ &
+     &                      ,NKR,ICEMAX)
+        ENDIF
+       ENDIF
+! nucleation of crystals                                        (end)
+! new change in drop nucleation                               (begin)
+! no sink of water vapour by nucleation
+      RETURN
+      END SUBROUTINE JERNUCL01
+
+! SUBROUTINE JERNUCL01
+!======================================================================      
+      SUBROUTINE WATER_NUCL (PSI1,FCCNR,X1,TT,SUP1 &
+     &,COL,RCCN,DROPRADII,NKR,ICEMAX)
+      IMPLICIT NONE
+      INTEGER NDROPMAX,KR,ICEMAX,NKR
+      REAL PSI1(NKR),FCCNR(NKR),X1(NKR)
+      REAL DROPCONCN(NKR)
+      REAL RCCN(NKR),DROPRADII(NKR)
+      REAL TT,SUP1,DX,COL
+
+
+      CALL NUCLEATION (SUP1,TT,FCCNR,DROPCONCN  &
+     &,NDROPMAX,COL,RCCN,DROPRADII,NKR,ICEMAX)
+
+! NEW WATER SIZE DISTRIBUTION FUNCTION (BEGIN)
+        DO KR=1,NDROPMAX
+           DX=3.*COL*X1(KR)
+! new changes 25.06.01                                        (begin)
+           PSI1(KR)=PSI1(KR)+DROPCONCN(KR)/DX
+! new changes 25.06.01                                          (end)
+        ENDDO
+
+      RETURN
+      END SUBROUTINE WATER_NUCL
+      SUBROUTINE ICE_NUCL (PSI2,X2,TT,ROR,SUP2,SUP2_OLD &
+     &                      ,C1_MEY,C2_MEY,COL,DSUPICEXZ &
+     &                      ,NKR,ICEMAX)
+        IMPLICIT NONE
+        INTEGER ITYPE,KR,ICE,NRGI,ICEMAX,NKR
+        REAL DEL2N,SUP2,C1,C2,C1_MEY,C2_MEY,TPC,TT,ROR
+        REAL DX,COL,BMASS,BFMASS,FMASS
+        REAL HELEK1,HELEK2,TPCC,DEL2NN,FF1BN,DSUPICEXZ
+        REAL FACT,DSUP2N,SUP2_OLD,DELTACD,DELTAF,ADDF,FNEW
+        REAL X2(NKR,ICEMAX),PSI2(NKR,ICEMAX)
+
+        REAL A1,B1,A2,B2
+        DATA A1,B1,A2,B2/-0.639,0.1296,-2.8,0.262/
+!       DATA A1,B1,A2,B2/-0.639,0.15,-2.8,0.262/
+        REAL TEMP1,TEMP2,TEMP3
+        DATA TEMP1,TEMP2,TEMP3/-5.,-2.,-20./
+        REAL ICE_CON
+
+        C1=C1_MEY
+        C2=C2_MEY
+! TYPE OF ICE WITH NUCLEATION (BEGIN)
+
+        TPC=TT-273.15
+        ITYPE=0
+
+        IF((TPC.GT.-4.0).OR.(TPC.LE.-8.1.AND.TPC.GT.-12.7).OR.&
+     &  (TPC.LE.-17.8.AND.TPC.GT.-22.4)) THEN
+          ITYPE=2
+        ELSE
+          IF((TPC.LE.-4.0.AND.TPC.GT.-8.1).OR.(TPC.LE.-22.4)) THEN
+            ITYPE=1
+          ELSE
+            ITYPE=3
+          ENDIF
+        ENDIF
+
+
+
+! NEW CRYSTAL SIZE DISTRIBUTION FUNCTION                      (BEGIN)
+
+        ICE=ITYPE
+
+        NRGI=2
+        IF(TPC.LT.TEMP1) THEN
+          DEL2N=100.*SUP2
+          DEL2NN=DEL2N
+          IF(DEL2N.GT.50.0) DEL2NN=50.
+          HELEK1=C1*EXP(A1+B1*DEL2NN)
+        ELSE
+          HELEK1=0.
+        ENDIF
+
+        IF(TPC.LT.TEMP2) THEN
+          TPCC=TPC
+          IF(TPCC.LT.TEMP3) TPCC=TEMP3
+          HELEK2=C2*EXP(A2-B2*TPCC)
+        ELSE
+          HELEK2=0.
+        ENDIF
+
+        FF1BN=HELEK1+HELEK2
+
+        FACT=1.
+        DSUP2N=(SUP2-SUP2_OLD+DSUPICEXZ)*100.
+
+        SUP2_OLD=SUP2
+
+        IF(DSUP2N.GT.50.) DSUP2N=50.
+
+        DELTACD=FF1BN*B1*DSUP2N
+
+        IF(DELTACD.GE.FF1BN) DELTACD=FF1BN
+
+        IF(DELTACD.GT.0.) THEN
+          ICE_CON=0.
+          DO KR=1,NRGI-1
+             DX=3.*X2(KR,ICE)*COL
+             ICE_CON=ICE_CON+DX*PSI2(KR,ICE)
+          ENDDO
+          IF(ICE_CON.GT.HELEK1)THEN
+!           CONTINUE
+          ELSE 
+           DELTAF=DELTACD*FACT
+           DO KR=1,NRGI-1
+             DX=3.*X2(KR,ICE)*COL
+             ADDF=DELTAF/DX
+             PSI2(KR,ICE)=PSI2(KR,ICE)+ADDF
+           ENDDO
+          END IF
+        ENDIF
+! NEW CRYSTAL SIZE DISTRIBUTION FUNCTION                        (END)
+       RETURN
+       END SUBROUTINE ICE_NUCL
+
+
+
+
+
+      SUBROUTINE NUCLEATION (SUP1,TT,FCCNR,DROPCONCN  &
+     &,NDROPMAX,COL,RCCN,DROPRADII,NKR,ICEMAX)
+! DROPCONCN(KR), 1/cm^3 - drop bin concentrations, KR=1,...,NKR
+
+! determination of new size spectra due to drop nucleation
+
+      IMPLICIT NONE
+      INTEGER NDROPMAX,IDROP,ICCN,INEXT,ISMALL,KR,NCRITI
+      INTEGER ICEMAX,IMIN,IMAX,NKR,I,II,I0,I1
+      REAL &
+     &  SUP1,TT,RACTMAX,XKOE,R03,SUPCRITI,AKOE23,RCRITI,BKOE, &
+     &  AKOE,CONCCCNIN,DEG01,ALN_IP
+      REAL CCNCONC(NKR)
+      REAL CCNCONC_BFNUCL
+
+
+      REAL COL
+      REAL RCCN(NKR),DROPRADII(NKR),FCCNR(NKR)
+      REAL RACT(NKR),DROPCONC(NKR),DROPCONCN(NKR)
+      REAL DLN1,DLN2,FOLD_IP
+
+
+
+        DEG01=1./3.
+
+
+! calculation initial value of NDROPMAX - maximal number of drop bin
+! which is activated
+
+! initial value of NDROPMAX
+
+        NDROPMAX=0
+
+        DO KR=1,NKR
+! initialization of bin radii of activated drops
+           RACT(KR)=0.
+! initialization of aerosol(CCN) bin concentrations
+           CCNCONC(KR)=0.
+! initialization of drop bin concentrations
+           DROPCONCN(KR)=0.
+        ENDDO
+
+
+! CCNCONC_BFNUCL - concentration of aerosol particles before
+!                  nucleation
+
+        CCNCONC_BFNUCL=0.
+        DO I=1,NKR
+           CCNCONC_BFNUCL=CCNCONC_BFNUCL+FCCNR(I)
+        ENDDO
+
+        CCNCONC_BFNUCL=CCNCONC_BFNUCL*COL
+
+        IF(CCNCONC_BFNUCL.EQ.0.) THEN
+           RETURN    
+        ELSE
+           CALL BOUNDARY(IMIN,IMAX,FCCNR,NKR)
+           CALL CRITICAL (AKOE,BKOE,TT,RCRITI,SUP1,DEG01)
+           IF(RCRITI.GE.RCCN(IMAX))  RETURN
+        END IF
+
+! calculation of CCNCONC(I) - aerosol(CCN) bin concentrations;
+!                             I=IMIN,...,IMAX
+! determination of NCRITI - number bin in which is located RCRITI
+        IF (IMIN.EQ.1)THEN
+         CALL CCNIMIN(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
+     &       FCCNR,NKR)
+         CALL CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
+     &       FCCNR,NKR)
+        ELSE
+         CALL CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
+     &       FCCNR,NKR)
+        END IF
+
+
+! calculation CCNCONC_AFNUCL - ccn concentration after nucleation
+
+!       CCNCONC_AFNUCL=0.
+
+!       DO I=IMIN,IMAX
+!          CCNCONC_AFNUCL=CCNCONC_AFNUCL+FCCNR(I)
+!       ENDDO
+
+!       CCNCONC_AFNUCL=CCNCONC_AFNUCL*COL
+
+! calculation DEL_CCNCONC
+
+!       DEL_CCNCONC=CCNCONC_BFNUCL-CCNCONC_AFNUCL
+        CALL ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT,RACTMAX,NKR)
+
+
+
+        CALL DROPMAX(DROPRADII,RACTMAX,NDROPMAX,NKR)
+! put nucleated droplets into the drop bin according to radius
+! change in drop concentration due to activation DROPCONCN(IDROP)
+        ISMALL=NCRITI
+
+        INEXT=ISMALL
+!       ISMALL=1
+
+!       INEXT=ISMALL
+
+        DO IDROP=1,NDROPMAX
+           DROPCONCN(IDROP)=0.
+           DO I=ISMALL,IMAX
+              IF(RACT(I).LE.DROPRADII(IDROP)) THEN
+                DROPCONCN(IDROP)=DROPCONCN(IDROP)+CCNCONC(I)
+                INEXT=I+1
+              ENDIF
+           ENDDO
+           ISMALL=INEXT
+        ENDDO
+
+!999    CONTINUE
+
+
+        RETURN
+        END SUBROUTINE NUCLEATION
+
+
+
+        SUBROUTINE BOUNDARY(IMIN,IMAX,FCCNR,NKR)
+! IMIN - left CCN spectrum boundary
+        IMPLICIT NONE
+        INTEGER I,IMIN,IMAX,NKR
+        REAL FCCNR(NKR)
+
+        IMIN=0
+
+        DO I=1,NKR
+           IF(FCCNR(I).NE.0.) THEN
+             IMIN=I
+             GOTO 40
+           ENDIF
+        ENDDO
+
+ 40     CONTINUE
+
+! IMAX - right CCN spectrum boundary
+
+        IMAX=0
+
+        DO I=NKR,1,-1
+           IF(FCCNR(I).NE.0.) THEN
+             IMAX=I
+             GOTO 41
+           ENDIF
+        ENDDO
+
+ 41     CONTINUE
+        RETURN
+        END  SUBROUTINE BOUNDARY
+
+        SUBROUTINE CRITICAL (AKOE,BKOE,TT,RCRITI,SUP1,DEG01)
+! AKOE & BKOE - constants in Koehler equation
+        IMPLICIT NONE
+        REAL AKOE,BKOE,TT,RCRITI,SUP1,DEG01
+        REAL RO_SOLUTE
+        PARAMETER (RO_SOLUTE=2.16)
+
+         
+
+        AKOE=3.3E-05/TT
+        BKOE=2.*4.3/(22.9+35.5)
+! new change 21.07.02                                         (begin)
+        BKOE=BKOE*(4./3.)*3.141593*RO_SOLUTE                  
+! new change 21.07.02                                           (end)
+        
+
+! table of critical aerosol radii
+
+!	GOTO 992
+
+! SUP1_TEST(I), %
+!       SUP1_TEST(1)=0.01
+!       DO I=1,99
+!          SUP1_TEST(I+1)=SUP1_TEST(I)+0.01
+!          SUP1_I=SUP1_TEST(I)*0.01
+!          RCRITI_TEST(I)=(AKOE/3.)*(4./BKOE/SUP1_I/SUP1_I)**DEG01
+!       ENDDO
+
+! RCRITI, cm - critical radius of "dry" aerosol
+
+        RCRITI=(AKOE/3.)*(4./BKOE/SUP1/SUP1)**DEG01
+        RETURN
+        END  SUBROUTINE CRITICAL
+            
+        SUBROUTINE CCNIMIN(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
+     &       FCCNR,NKR)
+! FOR    IMIN=1
+        IMPLICIT NONE
+        INTEGER IMIN,II,IMAX,NCRITI,NKR
+        REAL RCRITI,COL
+        REAL RCCN(NKR),FCCNR(NKR),CCNCONC(NKR)
+        REAL RCCN_MIN
+        REAL DLN1,DLN2,FOLD_IP
+! rccn_min - minimum aerosol(ccn) radius
+        RCCN_MIN=RCCN(1)/10000.
+! calculation of ccnconc(ii)=fccnr(ii)*col - aerosol(ccn) bin
+!                                            concentrations,
+!                                            ii=imin,...,imax
+! determination of ncriti   - number bin in which is located rcriti
+! calculation of ccnconc(ncriti)=fccnr(ncriti)*dln1/(dln1+dln2),
+! where,    
+! dln1=Ln(rcriti)-Ln(rccn_min)
+! dln2=Ln(rccn(1)-Ln(rcriti)
+! calculation of new value of fccnr(ncriti)
+
+!       IF(IMIN.EQ.1) THEN
+          IF(RCRITI.LE.RCCN_MIN) THEN
+            NCRITI=1
+            DO II=NCRITI+1,IMAX
+               CCNCONC(II)=COL*FCCNR(II)     
+               FCCNR(II)=0.                  
+            ENDDO
+            GOTO 42
+          ENDIF
+          IF(RCRITI.GT.RCCN_MIN.AND.RCRITI.LT.RCCN(IMIN)) THEN
+            NCRITI=1
+            DO II=NCRITI+1,IMAX
+               CCNCONC(II)=COL*FCCNR(II)
+               FCCNR(II)=0.
+            ENDDO
+            DLN1=ALOG(RCRITI)-ALOG(RCCN_MIN)
+            DLN2=ALOG(RCCN(1))-ALOG(RCRITI)
+            CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
+            FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/(DLN1+DLN2)
+            GOTO 42
+! in case RCRITI.GT.RCCN_MIN.AND.RCRITI.LT.RCCN(IMIN)
+          ENDIF
+! in case IMIN.EQ.1
+42       CONTINUE
+     
+         RETURN
+         END SUBROUTINE CCNIMIN
+        SUBROUTINE CCNLOOP(IMIN,IMAX,RCRITI,NCRITI,RCCN,CCNCONC,COL, &
+     &       FCCNR,NKR)
+        IMPLICIT NONE
+         INTEGER I,IMIN,IMAX,NKR,II,NCRITI
+         REAL COL
+         REAL RCRITI,RCCN(NKR),CCNCONC(NKR),FCCNR(NKR)
+         REAL DLN1,DLN2,FOLD_IP
+        IF(IMIN.GT.1) THEN
+          IF(RCRITI.LE.RCCN(IMIN-1)) THEN
+            NCRITI=IMIN
+            DO II=NCRITI,IMAX
+               CCNCONC(II)=COL*FCCNR(II)
+               FCCNR(II)=0.
+            ENDDO
+            GOTO 42
+          ENDIF
+          IF(RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)) &
+     &    THEN
+! this line eliminates bug you found (when IMIN=IMAX)
+            NCRITI=IMIN
+            
+            DO II=NCRITI+1,IMAX
+               CCNCONC(II)=COL*FCCNR(II)
+               FCCNR(II)=0.
+            ENDDO
+            DLN1=ALOG(RCRITI)-ALOG(RCCN(IMIN-1))
+            DLN2=COL-DLN1
+            CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
+            FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/COL
+            GOTO 42
+! in case RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)
+          ENDIF
+! in case IMIN.GT.1
+        ENDIF
+        
+! END of part of interest. so in case
+!RCRITI.LT.RCCN(IMIN).AND.RCRITI.GT.RCCN(IMIN-1)
+!we go to 42 and avoid the next loop
+
+      
+
+         DO I=IMIN,IMAX-1
+           IF(RCRITI.EQ.RCCN(I)) THEN
+             NCRITI=I+1
+             DO II=I+1,IMAX
+                CCNCONC(II)=COL*FCCNR(II)
+                FCCNR(II)=0.
+             ENDDO
+             GOTO 42
+           ENDIF
+           IF(RCRITI.GT.RCCN(I).AND.RCRITI.LT.RCCN(I+1)) THEN
+             NCRITI=I+1
+             IF(I.NE.IMAX-1) THEN
+               DO II=NCRITI+1,IMAX
+                  CCNCONC(II)=COL*FCCNR(II)
+                  FCCNR(II)=0.
+               ENDDO
+             ENDIF
+             DLN1=ALOG(RCRITI)-ALOG(RCCN(I))
+             DLN2=COL-DLN1
+             CCNCONC(NCRITI)=DLN2*FCCNR(NCRITI)
+             FCCNR(NCRITI)=FCCNR(NCRITI)*DLN1/COL
+             GOTO 42
+! in case RCRITI.GT.RCCN(I).AND.RCRITI.LT.RCCN(I+1)
+           END IF
+      
+
+         ENDDO
+! cycle by I, I=IMIN,...,IMAX-1
+
+  42    CONTINUE
+        RETURN
+        END  SUBROUTINE CCNLOOP
+       SUBROUTINE ACTIVATE(IMIN,IMAX,AKOE,BKOE,RCCN,RACT,RACTMAX,NKR)
+       IMPLICIT NONE
+
+       INTEGER IMIN,IMAX,NKR
+       INTEGER I,I0,I1
+       REAL RCCN(NKR)
+        REAL  R03,SUPCRITI,RACT(NKR),XKOE
+        REAL AKOE,BKOE,AKOE23,RACTMAX
+! Spectrum of activated drops                                 (begin) 
+        DO I=IMIN,IMAX
+
+! critical water supersaturations appropriating CCN radii
+
+           XKOE=(4./27.)*(AKOE**3/BKOE)
+           AKOE23=AKOE*2./3.
+           R03=RCCN(I)**3
+           SUPCRITI=SQRT(XKOE/R03)
+
+! RACT(I) - radii of activated drops, I=IMIN,...,IMAX
+
+           IF(RCCN(I).LE.(0.3E-5)) &
+     &     RACT(I)=AKOE23/SUPCRITI
+           IF(RCCN(I).GT.(0.3E-5))&
+     &     RACT(I)=5.*RCCN(I)
+        ENDDO
+! cycle by I
+
+! calculation of I0
+
+        I0=IMIN
+
+        DO I=IMIN,IMAX-1
+           IF(RACT(I+1).LT.RACT(I)) THEN
+             I0=I+1
+             GOTO 45
+           ENDIF
+        ENDDO
+
+ 45     CONTINUE
+! new changes 9.04.02                                         (begin)
+        I1=I0-1
+! new changes 9.04.02                                           (end)
+
+        IF(I0.EQ.IMIN) GOTO 47
+
+! new changes 9.04.02                                         (begin)
+
+        IF(I0.EQ.IMAX) THEN
+          RACT(IMAX)=RACT(IMAX-1)
+          GOTO 47
+        ENDIF
+
+        IF(RACT(IMAX).LE.RACT(I0-1)) THEN
+          DO I=I0,IMAX
+             RACT(I)=RACT(I0-1)
+          ENDDO
+          GOTO 47
+        ENDIF
+
+! new changes 9.04.02                                           (end)
+
+
+
+! calculation of I1
+
+        DO I=I0+1,IMAX
+           IF(RACT(I).GE.RACT(I0-1)) THEN
+             I1=I
+             GOTO 46
+           ENDIF
+        ENDDO
+ 46     CONTINUE
+
+! spectrum of activated drops                                   (end)
+
+
+! line interpolation RACT(I) for I=I0,...,I1
+
+        DO I=I0,I1
+           RACT(I)=RACT(I0-1)+(I-I0+1)*(RACT(I1)-RACT(I0-1)) &
+     &                       /(I1-I0+1)
+        ENDDO
+
+
+  47    CONTINUE
+
+
+
+        RACTMAX=0.
+
+        DO I=IMIN,IMAX
+           RACTMAX=AMAX1(RACTMAX,RACT(I))
+	ENDDO
+        RETURN
+
+        END SUBROUTINE ACTIVATE
+        SUBROUTINE DROPMAX(DROPRADII,RACTMAX,NDROPMAX,NKR)
+        IMPLICIT NONE
+        INTEGER IDROP,NKR,NDROPMAX
+        REAL RACTMAX,DROPRADII(NKR)
+! calculation of NDROPMAX - maximal number of drop bin which
+! is activated
+
+        NDROPMAX=1
+
+        DO IDROP=1,NKR
+           IF(RACTMAX.LE.DROPRADII(IDROP)) THEN
+             NDROPMAX=IDROP
+             GOTO 44
+           ENDIF
+        ENDDO
+ 44     CONTINUE
+        RETURN
+        END  SUBROUTINE DROPMAX
+
+
+        SUBROUTINE ONECOND1 &
+     & (TT,QQ,PP,ROR &
+     & ,VR1,PSINGLE &
+     & ,DEL1N,DEL2N,DIV1,DIV2 &
+     & ,FF1,PSI1,R1,RLEC,RO1BL &
+     & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     & ,C1_MEY,C2_MEY &
+     & ,COL,DTCOND,ICEMAX,NKR)
+
+       IMPLICIT NONE
+
+
+      INTEGER NKR,ICEMAX
+      REAL    COL,VR1(NKR),PSINGLE &
+     &       ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &       ,DTCOND
+
+      REAL C1_MEY,C2_MEY
+      INTEGER I_ABERGERON,I_BERGERON, &
+     & KR,ICE,ITIME,KCOND,NR,NRM, &
+     & KLIMIT, &
+     & KM,KLIMITL  
+      REAL AL1,AL2,D,GAM,POD, &
+     & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
+     & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
+     & TPC1, TPC2, TPC3, TPC4, TPC5, &
+     & EPSDEL, EPSDEL2,DT0L, DT0I,&
+     & ROR, &
+     & CWHUCM,B6,B8L,B8I, &
+     & DEL1,DEL2,DEL1S,DEL2S, &
+     & TIMENEW,TIMEREV,SFN11,SFN12, &
+     & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,RW,RI,QW,PW, &
+     & PI,QI,DEL1N0,DEL2N0,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
+     & DEL_R1,DT0L0,DT0I0, &
+     & DTNEWL0, &
+     & DTNEWL2 
+       REAL DT_WATER_COND,DT_WATER_EVAP
+
+       INTEGER K
+! NEW ALGORITHM OF CONDENSATION (12.01.00)
+
+      REAL  FF1_OLD(NKR),SUPINTW(NKR)
+      DOUBLE PRECISION DSUPINTW(NKR),DD1N,DB11_MY,DAL1,DAL2
+      DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
+     &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
+     &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
+     &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
+     &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
+     &                  ,ES1N,ES2N,EW1N,ARGEXP &
+     &                  ,TT,QQ,PP &
+     &                  ,DEL1N,DEL2N,DIV1,DIV2 &
+     &                  ,OPER2,OPER3,AR1,AR2
+
+       DOUBLE PRECISION DELMASSL1
+
+! DROPLETS 
+                                                                       
+        REAL R1(NKR) &
+     &           ,RLEC(NKR),RO1BL(NKR) &
+     &           ,FI1(NKR),FF1(NKR),PSI1(NKR) &
+     &           ,B11_MY(NKR),B12_MY(NKR)
+
+! WORK ARRAYS 
+
+! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION
+
+       
+	REAL DTIMEO(NKR),DTIMEL(NKR) &
+     &           ,TIMESTEPD(NKR)
+
+! NEW ALGORITHM (NO TYPE OF ICE)
+
+
+
+	OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
+	OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
+
+        DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
+     &      ,GAM /1.E-4/, POD /10./ 
+           
+	DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
+     &      /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/
+
+	DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
+     &      /2.53,5.42,3.41E1,6.13/
+
+	DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
+     &      /-4.0,-8.1,-12.7,-17.8,-22.4/ 
+
+
+        DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/  
+    
+	DATA DT0L, DT0I /1.E20,1.E20/
+
+! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
+
+
+! CONTROL OF TIMESTEP ITERATIONS IN MIXED PHASE: EVAPORATION
+        
+        I_ABERGERON=0
+        I_BERGERON=0
+        COL3=3.0*COL
+        ITIME=0
+        KCOND=0
+        DT_WATER_COND=0.4
+        DT_WATER_EVAP=0.4
+	ITIME=0
+	KCOND=0
+        DT0LREF=0.2
+        DTLREF=0.4
+
+	NR=NKR
+	NRM=NKR-1
+	DT=DTCOND
+	DTT=DTCOND
+	XRAD=0.
+
+!     BARRY
+	CWHUCM=0.
+	XRAD=0.
+	B6=CWHUCM*GAM-XRAD
+	B8L=1./ROR
+	B8I=1./ROR
+        RORI=1./ROR
+
+! INITIALIZATION OF SOME ARRAYS
+!       print*, 'got to here 0'
+
+!       BARRY: REMOVE RS2 LOOP
+        DO KR=1,NKR
+           FF1_OLD(KR)=FF1(KR)
+           SUPINTW(KR)=0.
+           DSUPINTW(KR)=0.
+        ENDDO
+! OLD TREATMENT OF "T" & "Q" 
+!DEL12RD=DEL12R**DEL_BBR
+! BARRY
+!       EW1PN=AA1_MY*(100.+DEL1IN*100.)*DEL12RD/100.
+! 	QQIN=OPER4(EW1PN,PP)
+        TPN=TT
+        QPN=QQ
+        DO 19 KR=1,NKR
+              FI1(KR)=FF1(KR)
+19     CONTINUE
+! WARM OR NO ICE (BEGIN)
+! ONLY WATER (CONDENSATION OR EVAPORATION) (BEGIN)
+              TIMENEW=0.
+              ITIME=0
+! NEW CHANGES 10.01.01 (BEGIN)
+              TOLD=TPN
+              QOLD=QPN
+! NEW CHANGES 10.01.01 (END)
+   56         ITIME=ITIME+1
+              TIMEREV=DT-TIMENEW
+              TIMEREV=DT-TIMENEW
+              DEL1=DEL1N
+              DEL2=DEL2N
+              DEL1S=DEL1N
+              DEL2S=DEL2N
+              TPS=TPN
+              QPS=QPN
+! NO QPS IN JERRATE
+              CALL JERRATE(R1,TPS,PP,ROR,VR1,PSINGLE &
+     &                    ,RLEC,RO1BL,B11_MY,B12_MY,1,1,ICEMAX,NKR)
+
+! INTEGRALS IN DELTA EQUATION (ONLY WATER)
+
+! CONTROL OF DROP SPECRUM IN SUBROUTINE ONECOND
+
+
+! CALL JERTIMESC WATER - 1 (ONLY WATER)
+
+              CALL JERTIMESC(FI1,R1,SFN11,SFN12 &
+     &                      ,B11_MY,B12_MY,RLEC,B8L,1,COL,NKR)        
+
+
+	      SFNL=SFN11+SFN12
+	      SFNI=0.       
+
+! SOME CONSTANTS 
+	      B5L=BB1_MY/TPS/TPS
+	      B5I=BB2_MY/TPS/TPS
+              B7L=B5L*B6                                                     
+              B7I=B5I*B6
+	      DOPL=1.+DEL1S                                                     
+	      DOPI=1.+DEL2S                                                     
+              RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL                                                 
+              RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
+	      QW=B7L*DOPL
+	      PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
+              PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
+              QI=B7I*DOPI
+
+! SOLVING FOR TIMEZERO
+
+
+
+	      KCOND=10
+
+	      IF(DEL1.GT.0) KCOND=11
+
+! PROCESS'S TYPE 
+
+	      IF(KCOND.EQ.11) THEN
+! NEW TIME STEP IN CONDENSATION (ONLY WATER) (BEGIN)
+                IF (DEL1N.EQ.0)THEN
+	           DTNEWL=DT
+                ELSE
+                 DTNEWL=ABS(R1(ITIME)/(B11_MY(ITIME)*DEL1N &
+     &                               -B12_MY(ITIME)))
+	         IF(DTNEWL.GT.DT) DTNEWL=DT
+                END IF
+                IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
+                ENDIF
+                TIMESTEPD(ITIME)=DTNEWL
+
+! NEW TIME STEP (ONLY WATER: CONDENSATION)
+
+
+	        IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  & 
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+
+	        TIMESTEPD(ITIME)=DTNEWL
+
+	        TIMENEW=TIMENEW+DTNEWL
+
+	        DTT=DTNEWL
+
+! SOLVING FOR SUPERSATURATION 
+
+! CALL JERSUPSAT - 2 (NEW TIMESTEP - ONLY WATER)
+
+
+	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                        ,RW,PW,RI,PI,QW,QI &
+     &                        ,DTT,D1N,D2N,DT0L,DT0I)
+
+! END OF "NEW SUPERSATURATION"
+
+! DROPLETS 
+
+! DROPLET DISTRIBUTION FUNCTION 
+                                                         
+! CALL JERDFUN WATER - 1 (ONLY WATER: CONDENSATION)
+	          CALL JERDFUN(R1,B11_MY,B12_MY &
+     &                        ,FI1,PSI1,D1N &
+     &                        ,1,1,COL,NKR,TPN)
+
+	        IF((DEL1.GT.0.AND.DEL1N.LT.0) &
+     &         .AND.ABS(DEL1N).GT.EPSDEL) THEN
+                call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL1.GT.0.AND.DEL1N.LT.0), model stop")
+	        ENDIF
+
+! IN CASE : KCOND.EQ.11
+
+	      ELSE
+
+! EVAPORATION - ONLY WATER 
+
+! IN CASE : KCOND.NE.11
+               IF (DEL1N.EQ.0)THEN
+                DTIMEO(1)=DT
+	        DO KR=2,NKR
+	           DTIMEO(KR)=DT
+	        ENDDO
+               ELSE
+	        DTIMEO(1)=-R1(1)/(B11_MY(1)*DEL1N-B12_MY(1))
+
+	        DO KR=2,NKR
+	           KM=KR-1
+	           DTIMEO(KR)=(R1(KM)-R1(KR))/(B11_MY(KR)*DEL1N &
+     &                                       -B12_MY(KR))
+	        ENDDO
+               END IF
+
+	        KLIMIT=1
+
+	        DO KR=1,NKR
+	           IF(DTIMEO(KR).GT.TIMEREV) GOTO 55
+	           KLIMIT=KR
+	        ENDDO
+
+   55           KLIMIT=KLIMIT-1
+
+	        IF(KLIMIT.LT.1) KLIMIT=1
+
+! BARRY THIS LINE CAUSED A PROBLEM BECAUSE DTNEWL GOES FROM
+! LARGE TO SMALL
+  	        DTNEWL1=AMIN1(DTIMEO(3),TIMEREV)
+                IF(DTNEWL1.LT.DTLREF) DTNEWL1=AMIN1(DTLREF,TIMEREV)
+	        DTNEWL=DTNEWL1
+	        IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
+	        ENDIF
+
+	        TIMESTEPD(ITIME)=DTNEWL
+
+! NEW TIME STEP (ONLY_WATER: EVAPORATION)
+
+	        IF(DTNEWL.GT.DT) DTNEWL=DT
+                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+
+	        TIMESTEPD(ITIME)=DTNEWL
+
+	        TIMENEW=TIMENEW+DTNEWL
+
+	        DTT=DTNEWL
+
+! SOLVING FOR SUPERSATURATION 
+
+
+! CALL JERSUPSAT - 3 (ONLY_WATER: EVAPORATION)
+
+	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                        ,RW,PW,RI,PI,QW,QI &
+     &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
+! END OF "NEW SUPERSATURATION"
+
+
+! DROPLETS 
+
+
+! DROPLET DISTRIBUTION FUNCTION (ONLY_WATER: EVAPORATION)
+                                                         
+! CALL JERDFUN WATER - 2 (ONLY_WATER: EVAPORATION)
+             
+ 	          CALL JERDFUN(R1,B11_MY,B12_MY &
+     &                        ,FI1,PSI1,D1N &
+     &                        ,1,1,COL,NKR,TPN)
+
+! IN CASE : ISYML.NE.0 (ENDING OF 
+! "DROPLET DISTRIBUTION FUNCTION" (ONLY WATER: EVAPORATION)
+
+!        ENDIF
+
+	        IF((DEL1.LT.0.AND.DEL1N.GT.0) &
+     &         .AND.ABS(DEL1N).GT.EPSDEL) THEN
+                call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL1.LT.0.AND.DEL1N.GT.0), model stop")
+	        ENDIF
+
+! END OF "PROCESS'S TYPE" 
+
+! IN CASE : KCOND.NE.11 (ONLY WATER: EVAPORATION)
+
+              ENDIF
+
+! IN CASES : KCOND.EQ.11 OR KCOND.NE.11 (BOTH CONDENSATION AND
+! EVAPORATION : ONLY WATER)
+
+! CONCENTRATION & MASS (ONLY WATER) 
+
+      RMASSLBB=0.
+      RMASSLAA=0.
+
+! BEFORE JERNEWF (ONLY WATER) 
+
+              DO K=1,NKR
+                 FI1_K=FI1(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLBB=RMASSLBB+FI1R1
+              ENDDO
+              RMASSLBB=RMASSLBB*COL3*RORI
+! NEW CHANGE RMASSLBB
+              IF(RMASSLBB.LE.0.) RMASSLBB=0.
+              DO K=1,NKR
+                 FI1_K=PSI1(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLAA=RMASSLAA+FI1R1
+              ENDDO
+              RMASSLAA=RMASSLAA*COL3*RORI
+              IF(RMASSLAA.LE.0.) RMASSLAA=0.
+! NEW TREATMENT OF "T" & "Q" (ONLY WATER)
+              DELMASSL1=RMASSLAA-RMASSLBB
+              QPN=QPS-DELMASSL1
+              DAL1=AL1
+              TPN=TPS+DAL1*DELMASSL1
+! SUPERSATURATION (ONLY WATER)
+              ARGEXP=-BB1_MY/TPN
+              ES1N=AA1_MY*DEXP(ARGEXP)
+              ARGEXP=-BB2_MY/TPN
+              ES2N=AA2_MY*DEXP(ARGEXP)
+              EW1N=OPER3(QPN,PP)
+              IF(ES1N.EQ.0)THEN
+               DEL1N=0.5
+               DIV1=1.5
+              ELSE
+               DIV1=EW1N/ES1N
+               DEL1N=EW1N/ES1N-1.
+              END IF
+              IF(ES2N.EQ.0)THEN
+               DEL2N=0.5
+               DIV2=1.5
+              ELSE
+               DEL2N=EW1N/ES2N-1.
+               DIV2=EW1N/ES2N
+              END IF
+              DO KR=1,NKR
+                SUPINTW(KR)=SUPINTW(KR)+B11_MY(KR)*D1N
+                DD1N=D1N
+                DB11_MY=B11_MY(KR)
+                DSUPINTW(KR)=DSUPINTW(KR)+DB11_MY*DD1N
+              ENDDO
+! REPEATE TIME STEP (ONLY WATER: CONDENSATION OR EVAPORATION) 
+	      IF(TIMENEW.LT.DT) GOTO 56
+57            CONTINUE
+              CALL JERDFUN_NEW(R1,DSUPINTW &
+     &                        ,FF1_OLD,PSI1,D1N &
+     &                        ,1,1,COL,NKR,TPN)
+              RMASSLAA=0.0
+              RMASSLBB=0.0
+! BEFORE JERNEWF
+              DO K=1,NKR
+                 FI1_K=FF1_OLD(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLBB=RMASSLBB+FI1R1
+              ENDDO
+              RMASSLBB=RMASSLBB*COL3*RORI
+! NEW CHANGE RMASSLBB
+              IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
+! AFTER  JERNEWF
+              DO K=1,NKR
+                 FI1_K=PSI1(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLAA=RMASSLAA+FI1R1
+              ENDDO
+              RMASSLAA=RMASSLAA*COL3*RORI
+! NEW CHANGE RMASSLAA
+              IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
+              IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
+! NEW TREATMENT OF "T" & "Q"
+              DELMASSL1=RMASSLAA-RMASSLBB
+! NEW CHANGES 10.01.01 (BEGIN)
+              QPN=QOLD-DELMASSL1
+              DAL1 = AL1
+              TPN=TOLD+DAL1*DELMASSL1
+! NEW CHANGES 10.01.01 (END)
+! SUPERSATURATION
+              ARGEXP=-BB1_MY/TPN
+              ES1N=AA1_MY*DEXP(ARGEXP)
+              ARGEXP=-BB2_MY/TPN
+              ES2N=AA2_MY*DEXP(ARGEXP)
+              EW1N=OPER3(QPN,PP)
+              IF(ES1N.EQ.0)THEN
+               DEL1N=0.5
+               DIV1=1.5
+              call wrf_error_fatal("fatal error in module_mp_full_sbm (ES1N.EQ.0), model stop")
+              ELSE
+               DIV1=EW1N/ES1N
+               DEL1N=EW1N/ES1N-1.
+              END IF
+              IF(ES2N.EQ.0)THEN
+               DEL2N=0.5
+               DIV2=1.5
+              call wrf_error_fatal("fatal error in module_mp_full_sbm (ES2N.EQ.0), model stop")
+              ELSE
+               DEL2N=EW1N/ES2N-1.
+               DIV2=EW1N/ES2N
+              END IF
+        TT=TPN
+        QQ=QPN
+	DO KR=1,NKR
+	   FF1(KR)=PSI1(KR)
+	ENDDO
+
+
+
+
+       RETURN
+!      END 
+
+  END SUBROUTINE ONECOND1
+!==================================================================
+
+
+
+!BARRY
+        SUBROUTINE JERDFUN(R2,B21_MY,B22_MY &
+     &                    ,FI2,PSI2,DEL2N &
+     &                    ,IND,ITYPE,COL,NKR,TPN)
+       IMPLICIT NONE
+
+! CRYSTALS 
+       REAL COL,DEL2N
+                                                                       
+      INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,NKR,IDROP
+       REAL &
+     &       R2(NKR,IND),R2N(NKR,IND) &
+     &      ,FI2(NKR,IND),PSI2(NKR,IND) &
+     &      ,B21_MY(NKR,IND),B22_MY(NKR,IND) &
+     &      ,DEL_R2M(NKR,IND)
+        DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
+        DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND),DDEL2N, &
+     &     DB21_MY(NKR,IND)
+       DOUBLE PRECISION CHECK,TPN
+          CHECK=0.D0
+           DO KR=1,NKR
+             CHECK=B21_MY(1,1)*B21_MY(KR,1)
+             IF (CHECK.LT.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (CHECK.LT.0), model stop")
+           END DO
+
+	IF(IND.NE.1) THEN
+	  ITYP=ITYPE
+        ELSE
+	  ITYP=1
+	ENDIF
+
+           DDEL2N=DEL2N
+	DO KR=1,NKR
+	   PSI2R(KR)=FI2(KR,ITYP)
+	   FI2R(KR)=FI2(KR,ITYP)
+           DR2(KR,ITYP)=R2(KR,ITYP)
+           DB21_MY(KR,ITYP)=B21_MY(KR,ITYP)
+	ENDDO
+!
+!Q2=0.
+	NR=NKR
+	NRM=NKR-1
+
+! NEW DISTRIBUTION FUNCTION 
+
+	  DO 8 ICE=1,IND
+	       IF(ITYP.EQ.ICE) THEN
+	          DO KR=1,NKR
+                    DR2N(KR,ICE)=DR2(KR,ICE)+DDEL2N*DB21_MY(KR,ICE)
+                    R2N(KR,ICE)=DR2N(KR,ICE)
+!                   IF (D1N.LT.0)THEN
+!	             if (DR2N(KR,ICE).EQ.DR2(KR,ICE))THEN
+!		        KK=NKR-KR+1
+!	       		DR2N(KR,ICE)=R2N(KR,ICE)-2.E-15/2**KK
+!                    end if
+!                   END IF
+
+	          ENDDO
+	        ENDIF
+    8	  CONTINUE
+! CRYSTAL DISTRIBUTION FUNCTION 
+                                                          
+	  DO ICE=1,IND
+
+! ICE_TYPE 
+	     IF(ITYP.EQ.ICE) THEN
+!       Q2=20.*ITYPE+ICE
+               DO 5 KR=1,NKR
+	            R2R(KR)=DR2(KR,ICE)
+	            R2NR(KR)=DR2N(KR,ICE)               
+    5         continue
+! Andrei's new change 1.12.09                                 (start)
+!            IDROP=1
+!            IDROP=0
+             IF(IND.EQ.1.AND.ITYPE.EQ.1) IDROP=1
+! Andrei's new change 1.12.09                                   (end)
+             CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR &
+! Andrei's new change 1.12.09                                 (start)
+     &                   ,IDROP,TPN)
+! Andrei's new change 1.12.09                                   (end)
+
+
+
+!              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
+	       DO KR=1,NKR                              
+	          PSI2(KR,ICE)=PSI2R(KR)
+	       ENDDO
+
+
+! END OF "ICE_TYPE" 
+
+	     ENDIF
+
+! END OF "CRYSTAL DISTRIBUTION FUNCTION" 
+                                                          
+	  ENDDO
+
+! END OF "NEW DISTRIBUTION FUNCTION"
+
+
+	RETURN
+	END SUBROUTINE JERDFUN
+!===================================================================
+        SUBROUTINE JERDFUN_NEW(R2,B21_MY &
+     &                    ,FI2,PSI2,DEL2N &
+     &                    ,IND,ITYPE,COL,NKR,TPN)
+       IMPLICIT NONE
+
+! CRYSTALS 
+       REAL COL,DEL2N
+                                                                       
+      INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,KK,NKR,IDROP
+       REAL &
+     &       R2(NKR,IND),R2N(NKR,IND) &
+     &      ,FI2(NKR,IND),PSI2(NKR,IND)
+       DOUBLE PRECISION TPN
+       DOUBLE PRECISION  B21_MY(NKR,IND)
+        DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
+        DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND),DDEL2N, &
+     &     DB21_MY(NKR,IND)
+	IF(IND.NE.1) THEN
+	  ITYP=ITYPE
+        ELSE
+	  ITYP=1
+	ENDIF
+
+           DDEL2N=DEL2N
+	DO KR=1,NKR
+	   PSI2R(KR)=FI2(KR,ITYP)
+	   FI2R(KR)=FI2(KR,ITYP)
+           DR2(KR,ITYP)=R2(KR,ITYP)
+	ENDDO
+!
+!Q2=0.
+	NR=NKR
+	NRM=NKR-1
+
+! NEW DISTRIBUTION FUNCTION 
+
+! CRYSTAL DISTRIBUTION FUNCTION 
+	  DO ICE=1,IND
+! ICE_TYPE 
+	     IF(ITYP.EQ.ICE) THEN
+               DO 5 KR=1,NKR
+	            R2R(KR)=DR2(KR,ICE)
+	            R2NR(KR)=DR2(KR,ICE)+B21_MY(KR,ICE)
+                    R2N(KR,ICE)=R2NR(KR)
+!                   IF (D1N.LT.0)THEN
+!	            	 if (R2NR(KR).EQ.R2R(KR))THEN
+!	       		 KK=NKR-KR+1
+!		        R2NR(KR)=R2R(KR)-2.E-15/2**KK
+!		      end if
+!	            END IF
+    5         continue
+! Andrei's new change 1.12.09                                 (start)
+             IDROP=1
+!            IDROP=0
+             CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR &
+     &                   ,IDROP,TPN)
+! Andrei's new change 1.12.09                                   (end)
+
+
+!              CALL JERNEWF(NR,NRM,R2R,FI2R,PSI2R,R2NR,COL,NKR)
+	       DO KR=1,NKR                              
+	          PSI2(KR,ICE)=PSI2R(KR)
+	       ENDDO
+
+! END OF "ICE_TYPE" 
+
+	     ENDIF
+
+! END OF "CRYSTAL DISTRIBUTION FUNCTION" 
+                                                          
+	  ENDDO
+
+! END OF "NEW DISTRIBUTION FUNCTION"
+
+
+	RETURN
+	END SUBROUTINE JERDFUN_NEW
+! SUBROUTINE JERDFUN_NEW (NEW ALGORITHM OF CONDENSATION, 12.01.00)
+
+! new change 30.01.06                                         (start)
+!       SUBROUTINE JERNEWF(NRX,NRM,RR,FI,PSI,RN,COL,NKR)
+
+        SUBROUTINE JERNEWF &
+       (NRX,NRM,RR,FI_OLD,PSI,RN,COL,NKR, &
+! Andrei's new change 1.12.09                                 (start)           
+        IDROP,TPN)
+! Andrei's new change 1.12.09                                   (end)	
+ 
+        IMPLICIT NONE
+	
+! Andrei's new change 1.12.09                                 (start)
+
+        INTEGER &
+	KRDROP_REMAP_MIN,KRDROP_REMAP_MAX,IDROP,KMAX
+        INTEGER NRX
+	
+        DOUBLE PRECISION &
+	COEFF_REMAP,TPN
+	
+        DOUBLE PRECISION & 
+        CDROP(NRX),DELTA_CDROP(NRX)
+		
+! Andrei's new change 1.12.09                                   (end)                      	
+
+        INTEGER  & 
+        I,K,KM,NRXP,IM,IP,IFIN,IIN,ISYM,NKR
+ 
+        REAL & 
+        COL
+
+        DOUBLE PRECISION &
+	AOLDCON,ANEWCON,AOLDMASS,ANEWMASS
+
+        DOUBLE PRECISION &
+        RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, &
+        GN1,GN1P,GN2,GN3,GMAT2
+
+        DOUBLE PRECISION &
+        DRP,FNEW,FIK,PSINEW,DRM,GMAT,R1,R2,R3,DMASS,CONCL,RRI,RNK
+
+        INTEGER NRM
+
+        DOUBLE PRECISION & 
+        RR(NRX),FI(NRX),PSI(NRX),RN(NRX) &
+       ,RRS(NKR+1),RNS(NKR+1),PSIN(NKR+1),FIN(NKR+1)
+
+        DOUBLE PRECISION & 
+        FI_OLD(NRX)
+! ANDREI                                                      (start) 
+! new change 7.02.06                                          (start)
+        DOUBLE PRECISION & 
+        PSI_IM,PSI_I,PSI_IP
+! ANDREI                                                        (end) 
+! new change 7.02.06                                            (end)
+
+! Andrei's new change 1.12.09                                 (start)           
+
+       IF(TPN.LT.273.15-7.0D0) IDROP=0
+! LEAVE REMAPPING ON
+!      IDROP=0
+ 
+! VALUES FOR SOME REMAPING VARIABLES
+
+        KRDROP_REMAP_MIN=8
+	KRDROP_REMAP_MAX=13 
+	
+        COEFF_REMAP=1.0D0/150.0D0 
+	       	
+! Andrei's new change 1.12.09                                   (end)                      
+	
+! INITIAL VALUES FOR SOME VARIABLES
+
+	NRXP=NRX+1
+
+	DO K=1,NRX
+	   FI(K)=FI_OLD(K)
+        ENDDO
+ 
+	DO K=1,NRX
+	   PSI(K)=0.0D0
+        ENDDO
+! ANDREI                                                      (start) 
+! new change 7.02.06                                          (start)
+
+	IF(RN(NRX).NE.RR(NRX)) THEN
+
+! Kovetz-Olund method                                         (start)
+
+! ANDREI                                                        (end) 
+! new change 7.02.06                                            (end)
+
+	  ISYM=1
+
+	  IF(RN(1).LT.RR(1)) ISYM=-1
+
+! CALCULATION OF DISTRIBUTION FUNCTION 
+
+	  IF(ISYM.GT.0) THEN
+	
+! CONDENSATION 
+
+	    RNS(NRXP)=1024.0D0*RR(NRX)
+	    RRS(NRXP)=1024.0D0*RR(NRX)
+
+  	    PSIN(NRXP)=0.0D0
+	    FIN(NRXP)=0.0D0
+
+	    DO K=1,NRX
+	       RNS(K)=RN(K)
+	       RRS(K)=RR(K)
+	       PSIN(K)=0.0D0
+! FIN(K) - initial(before condensation) concentration of hydrometeors
+	       FIN(K)=3.0D0*FI(K)*RR(K)*COL
+	    ENDDO
+
+! NUMBER OF NEW RADII POSITION IN REGULAR GRID 
+
+! RNK - new first bin mass(after condensation)
+
+	    RNK=RNS(1)
+
+	    DO I=1,NRX
+	       RRI=RRS(I)
+	       IF(RRI.GT.RNK) GOTO 3
+            ENDDO
+
+    3	    IIN=I-1
+
+	    IFIN=NRX
+
+	    CONCL=0.0D0
+            DMASS=0.0D0
+                        
+            DO 6 I=IIN,IFIN
+
+                 IP=I+1
+                                                                                
+                 IM=MAX(1,I-1)
+
+	         R1=RRS(IM)
+	         R2=RRS(I)
+	         R3=RRS(IP)
+
+	         DRM=R2-R1
+	         DRP=R3-R2
+
+	         FNEW=0.0D0
+
+	         DO 7 K=1,I
+                 
+	              FIK=FIN(K)
+
+	              IF(FIK.NE.0.0D0) THEN
+
+	                KM=K-1
+
+! RNK - new bin mass(after condensation)
+
+	                RNK=RNS(K)
+
+	                IF(RNK.NE.R2) THEN
+	                  GMAT=0.0D0
+	                  IF(RNK.GT.R1.AND.RNK.LT.R3) THEN
+	                    IF(RNK.LT.R2) THEN
+	                      GMAT=(RNK-R1)/DRM
+		            ELSE
+	                      GMAT=(R3-RNK)/DRP
+	                    ENDIF
+	                  ENDIF
+	                ELSE
+	                  GMAT=1.0D0
+	                ENDIF
+
+                        FNEW=FNEW+FIK*GMAT
+! in case FIK.NE.0.0D0
+	              ENDIF
+                 
+   7	         CONTINUE
+
+	         CONCL=CONCL+FNEW
+
+	         DMASS=DMASS+FNEW*R2
+
+! PSIN(I)) - new concentration of hydrometeors after condensation
+
+    	         PSIN(I)=FNEW
+                        	
+   6        CONTINUE
+
+! NEW VALUES OF DISTRIBUTION FUNCTION
+ 
+! PSI(K) - new size distribution function of hydrometeors after 
+!          condensation, K=1,...,NRX=NKR
+
+	    DO K=1,NRX
+	       PSI(K)=PSIN(K)/3./RR(K)/COL
+	    ENDDO
+
+! IN CASE: ISYM.GT.0 (CONDENSATION)
+	
+          ELSE
+
+! IN CASE: ISYM.LE.0 (EVAPORATION)
+
+	    RNS(1)=0.0D0
+	    RRS(1)=0.0D0
+	    FIN(1)=0.0D0
+	    PSIN(1)=0.0D0
+
+! FIN(K) - initial(before evaporation) concentration of hydrometeors
+
+	    DO K=2,NRXP
+	       KM=K-1
+	       RNS(K)=RN(KM)
+	       RRS(K)=RR(KM)
+	       PSIN(K)=0.0D0
+	       FIN(K)=3.0D0*FI(KM)*RR(KM)*COL
+	    ENDDO
+
+	    DO I=1,NRXP
+
+               IM=MAX(I-1,1)
+               IP=MIN(I+1,NRXP)
+
+   	       R1=RRS(IP)
+	       R2=RRS(I)
+	       R3=RRS(IM)
+
+               DRM=R1-R2
+               DRP=R2-R3
+
+	       FNEW=0.0D0
+
+	       DO K=I,NRXP
+	          RNK=RNS(K)
+                  IF(RNK.GE.R1) GOTO 4321
+                  IF(RNK.GT.R3)THEN
+                    IF(RNK.GT.R2) THEN
+                      FNEW=FNEW+FIN(K)*(R1-RNK)/DRM
+                    ELSE
+                      FNEW=FNEW+FIN(K)*(RNK-R3)/DRP
+	            ENDIF
+	          ENDIF
+               ENDDO
+
+ 4321          CONTINUE
+
+! PSIN(I) - new concentration of hydrometeors after evaporation
+
+    	       PSIN(I)=FNEW
+	
+            ENDDO
+! cycle by I
+
+! NEW VALUES OF DISTRIBUTION FUNCTION                         (start)
+
+! PSI(K), 1/g/cm^3 - new size distribution function of hydrometeors 
+!                    after evaporation, K=1,...,NRX
+	    DO K=2,NRXP
+	       KM=K-1
+	       R1=PSIN(K)*RR(KM)
+	       PSINEW=PSIN(K)/3.0D0/RR(KM)/COL
+	       IF(R1.LT.1.0D-20) PSINEW=0.0D0
+	       PSI(KM)=PSINEW
+	    ENDDO
+
+! NEW VALUES OF DISTRIBUTION FUNCTION                           (end)
+
+! IN CASE: ISYM.LE.0 (EVAPORATION)
+
+	  ENDIF
+	
+! Andrei's new change 1.12.09                                 (start)
+          IF(I3POINT.NE.0.AND.ISYM.GT.0) THEN
+! DIFFERENCE
+!         IF(I3POINT.NE.0) THEN
+! Andrei's new change 1.12.09                                   (end)                      
+
+	    DO K=1,NKR
+	       RRS(K)=RR(K)
+	    ENDDO
+
+            RRS(NKR+1)=RRS(NKR)*1024.0D0
+
+	    DO I=1,NKR
+ 
+               PSI(I)=PSI(I)*RR(I)
+
+! PSI(I) - concenration hydrometeors after KO divided on COL*3.0D0
+! RN(I), g - new masses after condensation or evaporation
+
+               IF(RN(I).LT.0.0D0) THEN 
+                 RN(I)=1.0D-50
+	         FI(I)=0.0D0
+               ENDIF
+
+            ENDDO
+ 
+	    DO K=1,NKR
+
+               IF(FI(K).NE.0.0D0) THEN
+
+                 IF(RRS(2).LT.RN(K)) THEN
+ 
+                   I=2
+
+                   DO  WHILE &
+                     (.NOT.(RRS(I).LT.RN(K).AND.RRS(I+1).GT.RN(K)) &
+                      .AND.I.LT.NKR)
+                       I=I+1
+	           ENDDO
+! ANDREI                                                      (start) 
+! new change 7.02.06                                          (start)
+                   IF(I.LT.NKR-2) THEN
+! new change 7.02.06                                            (end)
+! ANDREI                                                        (end)
+                     RNTMP=RN(K)
+
+                     RRTMP=RRS(I)
+                     RRP=RRS(I+1)
+                     RRM=RRS(I-1)
+ 
+                     RNTMP2=RN(K+1)
+
+                     RRTMP2=RRS(I+1)
+                     RRP2=RRS(I+2)
+                     RRM2=RRS(I)
+ 
+                     GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ &
+                       (RRTMP-RRM)
+
+                     GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ &
+                        (RRP2-RRM2)/(RRTMP2-RRM2)
+
+                     GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ &
+                       (RRTMP-RRM)
+ 
+	             GMAT=(RRP-RNTMP)/(RRP-RRTMP)
+! ANDREI                                                      (start) 
+! new change 7.02.06                                          (start)
+                     GN3=(RRTMP-RNTMP)*(RRM-RNTMP)/(RRP-RRM)/ &
+                                                 (RRP-RRTMP)
+	             GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
+
+                     PSI_IM=PSI(I-1)+GN1*FI(K)*RR(K)
+! Andrei's new change 1.12.09                                 (start)           
+!                    PSI_I=PSI(I)+(GN1P+GN2-GMAT)*FI(K+1)*RR(K+1)
+
+                     PSI_I=PSI(I)+GN1P*FI(K+1)*RR(K+1)+&
+	                         (GN2-GMAT)*FI(K)*RR(K)
+! Andrei's new change 1.12.09                                   (end)           
+                     PSI_IP=PSI(I+1)+(GN3-GMAT2)*FI(K)*RR(K)
+                    
+                     IF(PSI_IM.GT.0.0D0) THEN
+
+                       IF(PSI_IP.GT.0.0D0) THEN
+
+                         IF(I.GT.2) THEN
+! smoothing criteria
+                           IF(PSI_IM.GT.PSI(I-2).AND.PSI_IM.LT.PSI_I &
+                          .AND.PSI(I-2).LT.PSI(I).OR.PSI(I-2) &
+                          .GE.PSI(I)) THEN
+
+                             PSI(I-1)=PSI_IM
+
+                             PSI(I)=PSI(I)+FI(K)*RR(K)*(GN2-GMAT)
+
+                             PSI(I+1)=PSI_IP
+
+! in case smoothing criteria
+
+                           ENDIF 
+! in case I.GT.2
+                         ENDIF
+
+! in case PSI_IP.GT.0.0D0
+
+	               ENDIF
+
+! in case PSI_IM.GT.0.0D0
+
+	             ENDIF
+
+! in case I.LT.NKR-2
+
+                   ENDIF
+! new change 7.02.06                                            (end)
+! ANDREI                                                        (end)
+! in case RRS(2).LT.RN(K)
+
+                 ENDIF
+ 
+! in case FI(K).NE.0.0D0
+
+               ENDIF
+
+ 1000          CONTINUE
+
+	    ENDDO
+! cycle by K
+	    AOLDCON=0.0D0
+	    ANEWCON=0.0D0
+	    AOLDMASS=0.0D0
+	    ANEWMASS=0.0D0
+
+	    DO K=1,NKR
+	       AOLDCON=AOLDCON+FI(K)*RR(K)
+	       ANEWCON=ANEWCON+PSI(K)
+	       AOLDMASS=AOLDMASS+FI(K)*RR(K)*RN(K)
+	       ANEWMASS=ANEWMASS+PSI(K)*RR(K)
+	    ENDDO
+
+! new change 8.02.06                                          (start)
+! ANDREI                                                      (start)
+
+! PSI(K) - new hydrometeor size distribution function(sdf)
+
+	    DO K=1,NKR
+	       PSI(K)=PSI(K)/RR(K)
+            ENDDO
+	  
+! new change 8.02.06                                            (end)	       
+! ANDREI                                                        (end)
+
+! 3 point method                                                (end)	       
+								     	       
+! in case I3POINT.NE.0.AND.ISYM.GT.0						     		 
+								     		    
+	  ENDIF
+
+! Andrei's new change 1.12.09                                 (start)           
+
+          IF(IDROP.NE.0.AND.ISYM.GT.0) THEN
+	  
+	    DO K=KRDROP_REMAP_MIN,KRDROP_REMAP_MAX
+	       CDROP(K)=3.0D0*COL*PSI(K)*RR(K)
+	    ENDDO
+								     		 
+! KMAX - right boundary of drop sdf spectrum
+!(KRDROP_REMAP_MIN =< KMAX =< KRDROP_REMAP_MAX)
+
+            DO K=KRDROP_REMAP_MAX,KRDROP_REMAP_MIN,-1
+               KMAX=K
+               IF(PSI(K).GT.0.0D0) GOTO 2011
+            ENDDO
+
+ 2011       CONTINUE
+ 
+! Andrei start
+!           DO K=KMAX-1,1,-1
+! Andre end
+!Alex, Andrei, Barry
+            DO K=KMAX-1,KRDROP_REMAP_MIN,-1
+!Alex, Andrei, Barry
+	       IF(CDROP(K).GT.1.d-20) THEN
+                 DELTA_CDROP(K)=CDROP(K+1)/CDROP(K)
+	         IF(DELTA_CDROP(K).LT.COEFF_REMAP) THEN
+	           CDROP(K)=CDROP(K)+CDROP(K+1)
+		   CDROP(K+1)=0.0D0
+	         ENDIF
+	       ENDIF
+            ENDDO
+	    
+	    DO K=KRDROP_REMAP_MIN,KMAX
+	       PSI(K)=CDROP(K)/(3.0D0*COL*RR(K))
+	    ENDDO
+	    
+! in case IDROP.NE.0.AND.ISYM.GT.0
+		      
+	  ENDIF
+	    	  
+! Andrei's new change 1.12.09                                   (end)           
+! ANDREI                                                      (start) 
+! new change 8.02.06                                          (start)
+
+! in case RN(NRX).NE.RR(NRX)
+
+        ELSE
+
+! in case RN(NRX).EQ.RR(NRX)
+
+	  DO K=1,NKR
+	     PSI(K)=FI(K)
+	  ENDDO
+
+        ENDIF
+
+! new change 8.02.06                                            (end)           
+! ANDREI                                            
+
+        RETURN 
+
+! SUBROUTINE JERNEWF
+        END SUBROUTINE JERNEWF
+
+! BARRY REMOVED QP,ROR
+        SUBROUTINE JERRATEOLD(R1S,TP,PP,ROR,VR1,PSINGLE,RIEC,RO1BL &
+     &                    ,B11_MY,B12_MY,ID,IN,ICEMAX,NKR)
+       IMPLICIT NONE
+       INTEGER ID,IN,KR,ICE,NRM,ICEMAX,NKR
+      DOUBLE PRECISION TP,PP
+      REAL DETL,FACTPL,VENTPL,VR1K,CONSTL,RO1,RVT,D_MY, &
+     & CONST
+       REAL VR1(NKR,ID),PSINGLE,ROR
+        REAL       &
+     & R1S(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
+     &,RO1BL(NKR,ID),RIEC(NKR,ID) &
+     &,VR1KL(NKR,ICEMAX),VENTRL(NKR,ICEMAX) &
+     &,FD1(NKR,ICEMAX),FK1(NKR,ICEMAX),FACTRL(NKR,ICEMAX) &
+     &,R11_MY(NKR,ICEMAX),R12_MY(NKR,ICEMAX) &
+     &,R1_MY1(NKR,ICEMAX),R1_MY2(NKR,ICEMAX),R1_MY3(NKR,ICEMAX) &
+     &,AL1(2),AL1_MY(2),A1_MY(2),BB1_MY(2),ESAT1(2),CONSTLI(ICEMAX)
+      DOUBLE PRECISION TZERO
+      REAL PZERO,CF_MY,D_MYIN,RV_MY
+      PARAMETER (TZERO=273.150,PZERO=1.013E6)
+      DATA AL1/2500.,2833./
+	CONST=12.566372
+        AL1_MY(1)=2.5E10
+        AL1_MY(2)=2.834E10
+        A1_MY(1)=2.53E12
+        A1_MY(2)=3.41E13
+        BB1_MY(1)=5.42E3
+        BB1_MY(2)=6.13E3
+        CF_MY=2.4E3
+        D_MYIN=0.221
+        RV_MY=461.5E4
+	NRM=NKR-1
+
+! RHS FOR "MAXWELL" EQUATION 
+
+	D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94
+	RVT=RV_MY*TP
+	ESAT1(IN)=A1_MY(IN)*EXP(-BB1_MY(IN)/TP)
+
+	DO 1 ICE=1,ID
+	     DO 1 KR=1,NKR
+	     RO1=RO1BL(KR,ICE)
+	     CONSTL=CONST*RIEC(KR,ICE)
+	     CONSTLI(ICE)=CONSTL
+	     VR1K=0.
+	     VR1KL(KR,ICE)=VR1K
+	     VENTPL=1.
+	     VENTRL(KR,ICE)=VENTPL
+	     FACTPL=1.
+	     FACTRL(KR,ICE)=FACTPL
+	     FD1(KR,ICE)=RVT/D_MY/ESAT1(IN)/FACTPL
+	     FK1(KR,ICE)=(AL1_MY(IN)/RVT-1.)*AL1_MY(IN)/CF_MY/TP
+	     R1_MY1(KR,ICE)=VENTPL*CONSTL
+	     R11_MY(KR,ICE)=R1_MY1(KR,ICE)
+!BARRY
+!     R1_MY2(KR,ICE)=VENTPL*CONSTL*0.
+!     R1_MY3(KR,ICE)=VENTPL*CONSTL*0.
+!     R12_MY(KR,ICE)=R1_MY2(KR,ICE)-R1_MY3(KR,ICE)
+!BARRY
+! GROWTH RATE
+
+	     DETL=FK1(KR,ICE)+FD1(KR,ICE)
+	     B11_MY(KR,ICE)=R11_MY(KR,ICE)/DETL
+!BARRY     B12_MY(KR,ICE)=R12_MY(KR,ICE)/DETL
+           B12_MY(KR,ICE)=0                       
+    1	CONTINUE
+
+	RETURN
+	END SUBROUTINE JERRATEOLD
+
+! SUBROUTINE JERRATE
+!========================================================================
+!BARRY    CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N
+!    *                        ,RW,PW,RI,PI,QW,QI
+! SUBROUTINE JERNEWF
+!=========================================================================
+! BARRY REMOVED QP
+        SUBROUTINE JERRATE(R1S,TP,PP,ROR,VR1,PSINGLE,RIEC,RO1BL &
+     &                    ,B11_MY,B12_MY,ID,IN,ICEMAX,NKR)
+       IMPLICIT NONE
+       INTEGER ID,IN,KR,ICE,NRM,ICEMAX,NKR
+      DOUBLE PRECISION TP,PP
+      REAL DETL,FACTPL,VENTPL,VR1K,CONSTL,RO1,RVT,D_MY, &
+     & CONST
+        REAL VR1(NKR,ID),PSINGLE &
+     &,R1S(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
+     &,RO1BL(NKR,ID),RIEC(NKR,ID) &
+     &,VR1KL(NKR,ICEMAX),VENTRL(NKR,ICEMAX) &
+     &,FD1(NKR,ICEMAX),FK1(NKR,ICEMAX),FACTRL(NKR,ICEMAX) &
+     &,R11_MY(NKR,ICEMAX),R12_MY(NKR,ICEMAX) &
+     &,R1_MY1(NKR,ICEMAX),R1_MY2(NKR,ICEMAX),R1_MY3(NKR,ICEMAX) &
+     &,AL1(2),AL1_MY(2),A1_MY(2),BB1_MY(2),ESAT1(2),CONSTLI(ICEMAX)
+      DOUBLE PRECISION TZERO
+      REAL PZERO,CF_MY,D_MYIN,RV_MY,DEG01,DEG03
+      REAL COEFF_VISCOUS,SHMIDT_NUMBER,A,B
+      REAL REINOLDS_NUMBER,RESHM,ROR
+      PARAMETER (TZERO=273.150,PZERO=1.013E6)
+      DATA AL1/2500.,2833./
+        DEG01=1./3.     
+        DEG03=1./3.     
+	CONST=12.566372
+        AL1_MY(1)=2.5E10
+        AL1_MY(2)=2.834E10
+        A1_MY(1)=2.53E12
+        A1_MY(2)=3.41E13
+        BB1_MY(1)=5.42E3
+        BB1_MY(2)=6.13E3
+        CF_MY=2.4E3
+        D_MYIN=0.221
+        RV_MY=461.5E4
+	NRM=NKR-1
+! rhs for "maxwell" equation
+! coefficient of diffusion
+        D_MY=D_MYIN*(PZERO/PP)*(TP/TZERO)**1.94
+! new change 20.04.02
+! coefficient of viscousity
+        COEFF_VISCOUS=1.72E-2*SQRT(TP/273.)*393./(TP-120.)/ROR
+! Shmidt number
+        SHMIDT_NUMBER=COEFF_VISCOUS/D_MY
+! Constants used for calculation of Reinolds number
+        A=2.*(3./4./3.141593)**DEG01
+        B=A/COEFF_VISCOUS
+        
+        RVT=RV_MY*TP
+        ESAT1(IN)=A1_MY(IN)*EXP(-BB1_MY(IN)/TP)
+        DO ICE=1,ID
+           DO KR=1,NKR
+! Reinolds numbers
+              REINOLDS_NUMBER= &
+     &        B*VR1(KR,ICE)*SQRT(1.E6/PSINGLE)* &
+     &        (R1S(KR,ICE)/RO1BL(KR,ICE))**DEG03
+              RESHM=SQRT(REINOLDS_NUMBER)*SHMIDT_NUMBER**DEG03
+              IF(REINOLDS_NUMBER.LT.2.5) THEN
+                VENTPL=1.+0.108*RESHM*RESHM
+              ELSE
+                VENTPL=0.78+0.308*RESHM
+              ENDIF
+! new change 20.04.02                                           (end)
+              CONSTL=CONST*RIEC(KR,ICE)                         
+              CONSTLI(ICE)=CONSTL
+!             VR1K=0.
+!             VR1KL(KR,ICE)=VR1K
+! new change 20.04.02                                         (begin)
+!             VENTPL=1.                                       
+!             VENTRL(KR,ICE)=VENTPL                           
+! new change 20.04.02                                           (end)
+              FACTPL=1.                                         
+              FACTRL(KR,ICE)=FACTPL                             
+              FD1(KR,ICE)=RVT/D_MY/ESAT1(IN)/FACTPL             
+              FK1(KR,ICE)=(AL1_MY(IN)/RVT-1.)*AL1_MY(IN)/CF_MY/TP
+              R1_MY1(KR,ICE)=VENTPL*CONSTL
+!             R1_MY2(KR,ICE)=VENTPL*CONSTL*0.
+!             R1_MY3(KR,ICE)=VENTPL*CONSTL*0.
+              R11_MY(KR,ICE)=R1_MY1(KR,ICE)
+!BARRY        R12_MY(KR,ICE)=R1_MY2(KR,ICE)-R1_MY3(KR,ICE)
+! growth rate 
+              DETL=FK1(KR,ICE)+FD1(KR,ICE)
+              B11_MY(KR,ICE)=R11_MY(KR,ICE)/DETL
+!BARRY        B12_MY(KR,ICE)=R12_MY(KR,ICE)/DETL
+              B12_MY(KR,ICE)=0.
+           ENDDO
+        ENDDO
+
+
+	RETURN
+	END SUBROUTINE JERRATE
+
+! SUBROUTINE JERRATE
+!========================================================================
+!BARRY    CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N
+!    *                        ,RW,PW,RI,PI,QW,QI
+!    *                        ,DTT,D1N,D2N,DT0L,DT0I)
+	SUBROUTINE JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                      ,RW,PW,RI,PI,QW,QI &
+     &                      ,DT,DEL1INT,DEL2INT,DT0L,DT0I)
+      IMPLICIT NONE
+   
+      INTEGER ITYPE
+      REAL DEL1,DEL2,RW,PW,RI,PI,QW,QI, &
+     &  DT,DEL1INT,DEL2INT,DT0L,DT0I,DTLIN,DTIIN
+      REAL DETER,DBLRW,DBLPW,DBLPI,DBLRI, &
+     &  DBLDEL1,DBLDEL2,DBLDEL1INT,DBLDTLIN,DBLDTIIN, &
+     &  EXPM,EXPP,ALFAMX,ALFAPX,X,ALFA,DELX,DBLDEL2INT, &
+     &  R1RES,R2RES,R1,R2,R3,R4,R21,R11,R10,R41,R31,R30,DBLDT, &
+     &  DBLDEL1N,DBLDEL2N
+      DOUBLE PRECISION DEL1N,DEL2N
+
+        DOUBLE PRECISION DEL1N_2P,DEL1INT_2P,DEL2N_2P,DEL2INT_2P 
+        DOUBLE PRECISION EXPP_2P,EXPM_2P,ARGEXP     
+! BARRY
+      DOUBLE PRECISION RW_DP,PW_DP,PI_DP,RI_DP,X_DP,ALFA_DP
+!    * ,ALFAPX_DP
+! Andrei's new change 9.03.10                                 (start)
+      DOUBLE PRECISION  EXPM1
+      EXPM1(x_dp)= &
+     &x_dp+x_dp*x_dp/2.0D0+x_dp*x_dp*x_dp/6.0D0+x_dp*x_dp*x_dp*x_dp/24.0D0+x_dp*x_dp*x_dp*x_dp*x_dp/120.0D0
+      DOUBLE PRECISION  DETER_MIN
+! Andrei's new change 9.03.10                                 (start)
+
+      DOUBLE PRECISION EXP1, EXP2
+
+! Andrei's new change 9.03.10                                   (end)
+	DTLIN=1000.E17
+	DTIIN=1000.E17
+! Andrei's new change 9.03.10                                 (start)
+      DETER=RW*PI-PW*RI
+!     DETER_MIN=1.0D-20
+! Andrei's new change 9.03.10                                 (end)
+! SOLUTION  
+!IF(DETER.EQ.0)  THEN
+       IF(RW.EQ.0.AND.RI.EQ.0) THEN
+! NO CLOUD: WITHOUT WATER & ICE
+	    DEL1N_2P=DEL1
+	    DEL2N_2P=DEL2
+	    DEL1INT_2P=DEL1*DT
+	    DEL2INT_2P=DEL2*DT
+! IN CASE: RW.NE.0 OR RI.NE.0 (WATER OR ICE) 
+       ELSE IF(RW.NE.0.AND.RI*1.E5.LT.RW) THEN
+! ONLY WATER
+              ARGEXP=-RW*DT
+
+	      DEL1N_2P=DEL1*DEXP(ARGEXP)+QW*(1.-DEXP(ARGEXP))
+	      DEL1INT_2P=(DEL1-DEL1N_2P)/RW
+	      DEL2N_2P=DEL2-PW*DEL1INT_2P
+	      DEL2INT_2P= &
+     &       (DEL2N_2P-PW*DEL1N_2P/RW)*DT+PW*DEL1INT_2P/RW
+	ELSE IF(RI.NE.0.AND.RW*1.E5.LT.RI) THEN
+! IN CASE: RW.EQ.0
+! ONLY ICE 
+              ARGEXP=-PI*DT
+
+	      DEL2N_2P=DEL2*DEXP(ARGEXP)+QI*(1.-DEXP(ARGEXP))
+	      DEL2INT_2P=(DEL2-DEL2N_2P)/PI
+	      DEL1N_2P=DEL1-RI*DEL2INT_2P
+	      DEL1INT_2P= &
+     &       (DEL1N_2P-RI*DEL2N_2P/PI)*DT+RI*DEL2INT_2P/PI
+!             GOTO 100
+! IN CASE: RW.NE.0 OR RI.NE.0 (WATER OR ICE)
+! IN CASE: DETER.EQ.0
+        ELSE
+! IN CASE: DETER.NE.0
+! COMPLETE SOLUTION 
+!  ALFA=SQRT((RW-PI)*(RW-PI)+4.*PW*RI)
+!  X=RW+PI
+!  ALFAPX=.5*(ALFA+X)
+! BARRY 
+          RW_DP=RW
+          RI_DP=RI
+          PI_DP=PI
+          PW_DP=PW
+          IF (RW.LE.0)PRINT*,'RW = ',RW
+          IF (PW.LE.0)PRINT*,'PW = ',PW
+          IF (RI.LE.0)PRINT*,'RI = ',RI
+          IF (PI.LE.0)PRINT*,'PI = ',PI
+          IF (RW.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (RW.LE.0), model stop")
+          IF (PW.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (PW.LE.0), model stop")
+          IF (RI.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (RI.LE.0), model stop")
+          IF (PI.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (PI.LE.0), model stop")
+          ALFA_DP=SQRT((RW_DP-PI_DP)*(RW_DP-PI_DP)+4.*PW_DP*RI_DP) 
+	  X_DP=RW_DP+PI_DP
+	  ALFAPX=.5*(ALFA_DP+X_DP)
+          IF (ALFAPX.LE.0) call wrf_error_fatal("fatal error in module_mp_full_sbm (ALFAPX.LE.0), model stop") 
+	  ALFAMX=.5*(ALFA_DP-X_DP)
+!
+! 
+          ARGEXP=-ALFAPX*DT
+! Andrei 11/04/10
+	  EXPP_2P=DEXP(ARGEXP)
+          IF(DABS(ARGEXP).LE.1.0E-6) THEN
+               EXP1=EXPM1(ARGEXP)
+          ELSE
+               EXP1=EXPP_2P-1.0D0
+          ENDIF
+!
+          ARGEXP=ALFAMX*DT
+!Andre 11/04/10
+	  EXPM_2P=DEXP(ARGEXP)
+              IF(DABS(ARGEXP).LE.1.0E-6) THEN
+                EXP2=EXPM1(ARGEXP)
+              ELSE
+                EXP2=EXPM_2P-1.0D0
+              ENDIF
+!
+! DROPLETS 
+	  R10=RW*DEL1+RI*DEL2
+	  R11=R10-ALFAPX*DEL1
+	  R21=R10+ALFAMX*DEL1
+	  DEL1N_2P=(R21*EXPP_2P-R11*EXPM_2P)/ALFA_DP
+! BARRY
+	  IF(ALFAMX.NE.0) THEN
+	    R1=-R11/ALFAMX
+	    R2=R21/ALFAPX
+!    DEL1INT_2P=(R1*(EXPM_2P-1.)-R2*(EXPP_2P-1.))/ALFA_DP
+            DEL1INT_2P=(R1*EXP2-R2*EXP1)/ALFA_DP
+	  ELSE
+            DEL1INT_2P = 0.
+	  ENDIF
+! BARRY
+	  R1RES=0.
+	  IF(R11.NE.0) R1RES=R21/R11
+	  IF(R1RES.GT.0) DTLIN=ALOG(R1RES)/ALFA_DP
+! ICE 
+	  R30=PW*DEL1+PI*DEL2
+	  R31=R30-ALFAPX*DEL2
+	  R41=R30+ALFAMX*DEL2
+! BARRY
+	  DEL2N_2P=(R41*EXPP_2P-R31*EXPM_2P)/ALFA_DP
+	  IF(ALFAMX.NE.0.AND.ALFAPX.NE.0) THEN
+	    R3=-R31/ALFAMX
+	    R4=R41/ALFAPX
+!           DEL2INT_2P=(R3*(EXPM_2P-1.)-R4*(EXPP_2P-1.))/ALFA_DP
+            DEL2INT_2P=(R3*EXP2-R4*EXP1)/ALFA_DP
+          ELSE
+	    DEL2INT_2P=0.
+	  ENDIF
+	  R2RES=0.
+	  IF(R31.NE.0) R2RES=R41/R31
+	  IF(R2RES.GT.0) DTIIN=ALOG(R2RES)/ALFA_DP
+! IN CASE: DETER.NE.0
+! END OF COMPLETE SOLUTION
+	ENDIF
+! IN CASES: DETER.EQ.0 OR DETER.NE.0
+ 100    CONTINUE
+        DEL1N=DEL1N_2P
+        DEL2N=DEL2N_2P
+       
+! BARRY
+        DEL1INT=DEL1INT_2P
+        DEL2INT=DEL2INT_2P
+	DT0L=DTLIN
+	IF(DT0L.LT.0) DT0L=1.E20
+	DT0I=DTIIN
+	IF(DT0I.LT.0) DT0I=1.E20
+	RETURN
+	END SUBROUTINE JERSUPSAT
+!==========================================================================
+        SUBROUTINE JERTIMESC(FI1,X1,SFN11,SFN12 &
+     &                      ,B11_MY,B12_MY,RIEC,CF,ID,COL,NKR)        
+      IMPLICIT NONE
+       INTEGER NRM,KR,ICE,ID,NKR
+      REAL B12,B11,FUN,DELM,FK,CF,SFN12S,SFN11S
+	REAL  COL, &
+     & X1(NKR,ID),FI1(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
+     &,RIEC(NKR,ID),SFN11,SFN12
+
+	NRM=NKR-1
+	DO 1 ICE=1,ID  
+             SFN11S=0.                              
+             SFN12S=0.
+	     SFN11=CF*SFN11S	
+	     SFN12=CF*SFN12S
+             DO KR=1,NRM
+! VALUE OF DISTRIBUTION FUNCTION
+	        FK=FI1(KR,ICE)
+! DELTA-M 
+	        DELM=X1(KR,ICE)*3.*COL
+! INTEGRAL'S EXPRESSION 
+	        FUN=FK*DELM
+! VALUES OF INTEGRALS
+	        B11=B11_MY(KR,ICE)
+        	B12=B12_MY(KR,ICE)
+                SFN11S=SFN11S+FUN*B11                               
+                SFN12S=SFN12S+FUN*B12
+	     ENDDO
+! CORRECTION 
+	     SFN11=CF*SFN11S
+             SFN12=CF*SFN12S
+    1   CONTINUE
+! END 
+	RETURN
+	END SUBROUTINE JERTIMESC
+!
+        SUBROUTINE JERTIMESC_ICE(FI1,X1,SFN11,SFN12 &
+     &                      ,B11_MY,B12_MY,RIEC,CF,ID,COL,NKR)        
+      IMPLICIT NONE
+       INTEGER NRM,KR,ICE,ID,NKR
+      REAL B12,B11,FUN,DELM,FK,CF,SFN12S,SFN11S
+	REAL  COL, &
+     & X1(NKR,ID),FI1(NKR,ID),B11_MY(NKR,ID),B12_MY(NKR,ID) &
+     &,RIEC(NKR,ID),SFN11(ID),SFN12(ID)
+
+	NRM=NKR-1
+	DO 1 ICE=1,ID  
+             SFN11S=0.                              
+             SFN12S=0.
+	     SFN11(ICE)=CF*SFN11S	
+	     SFN12(ICE)=CF*SFN12S
+             DO KR=1,NRM
+! VALUE OF DISTRIBUTION FUNCTION
+	        FK=FI1(KR,ICE)
+! DELTA-M 
+	        DELM=X1(KR,ICE)*3.*COL
+! INTEGRAL'S EXPRESSION 
+	        FUN=FK*DELM
+! VALUES OF INTEGRALS
+	        B11=B11_MY(KR,ICE)
+        	B12=B12_MY(KR,ICE)
+                SFN11S=SFN11S+FUN*B11                               
+                SFN12S=SFN12S+FUN*B12
+	     ENDDO
+! CORRECTION 
+	     SFN11(ICE)=CF*SFN11S
+             SFN12(ICE)=CF*SFN12S
+    1   CONTINUE
+! END 
+	RETURN
+	END SUBROUTINE JERTIMESC_ICE
+
+
+        SUBROUTINE ONECOND2 &
+     & (TT,QQ,PP,ROR  &
+     & ,VR2,VR3,VR4,VR5,PSINGLE &
+     & ,DEL1N,DEL2N,DIV1,DIV2 &
+     & ,FF2,PSI2,R2,RIEC,RO2BL &
+     & ,FF3,PSI3,R3,RSEC,RO3BL &
+     & ,FF4,PSI4,R4,RGEC,RO4BL &
+     & ,FF5,PSI5,R5,RHEC,RO5BL &
+     & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     & ,C1_MEY,C2_MEY &
+     & ,COL,DTCOND,ICEMAX,NKR &
+     & ,ISYM2,ISYM3,ISYM4,ISYM5)
+
+       IMPLICIT NONE
+
+      INTEGER NKR,ICEMAX
+      REAL    COL,VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
+     &           ,VR5(NKR),PSINGLE &
+     &       ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &       ,DTCOND
+
+      REAL C1_MEY,C2_MEY
+      INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON, &
+     & KR,ICE,ITIME,ICM,KCOND,NR,NRM,INUC, &
+     & ISYM2,ISYM3,ISYM4,ISYM5,KP,KLIMIT, &
+     & KM,ITER,KLIMITL,KLIMITG,KLIMITH,KLIMITI_1,KLIMITI_2,KLIMITI_3, &
+     & NCRITI
+      REAL AL1,AL2,D,GAM,POD, &
+     & RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY,ALC,DT0LREF,DTLREF, &
+     & A1_MYN, BB1_MYN, A2_MYN, BB2_MYN,DT,DTT,XRAD, &
+     & TPC1, TPC2, TPC3, TPC4, TPC5, &
+     & EPSDEL, DT0L, DT0I, &
+     & ROR, &
+     & DEL1NUC,DEL2NUC, &
+     & CWHUCM,B6,B8L,B8I,RMASSGL,RMASSGI, &
+     & DEL1,DEL2,DEL1S,DEL2S, &
+     & TIMENEW,TIMEREV,SFN11,SFN12, &
+     & SFNL,SFNI,B5L,B5I,B7L,B7I,DOPL,DOPI,OPERQ,RW,RI,QW,PW, &
+     & PI,QI,D1N0,D2N0,DTNEWL,DTNEWL1,D1N,D2N, &
+     & DEL_R1,DT0L0,DT0I0,SFN31,SFN32,SFN52, &
+     & SFNII1,SFN21,SFN22,DTNEWI3,DTNEWI4,DTNEWI5,DTNEWI2_1, &
+     & DTNEWI2_2,DTNEWI1,DEL_R2,DEL_R4,DEL_R5,SFN41,SFN42, &
+     & SNF51,DTNEWI2_3,DTNEWI2,DTNEWI_1,DTNEWI_2, &
+     & DTNEWL0,DTNEWG1,DTNEWH1,DTNEWI_3, &
+     & DTNEWL2,SFN51,SFNII2,DEL_R3,DTNEWI  
+       REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
+     &  DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON
+
+       INTEGER K
+
+! NEW ALGORITHM OF CONDENSATION (12.01.00)
+
+      DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
+      DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
+     &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
+     &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
+     &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
+     &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
+     &                  ,ES1N,ES2N,EW1N,ARGEXP &
+     &                  ,TT,QQ,PP &
+     &                  ,DEL1N,DEL2N,DIV1,DIV2 &
+     &                  ,OPER2,OPER3,AR1,AR2  
+
+       DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
+
+! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
+
+        CHARACTER*70 CPRINT
+
+
+
+
+
+
+
+! CRYSTALS
+                                                                       
+	REAL R2(NKR,ICEMAX) &
+     &           ,RIEC(NKR,ICEMAX) &
+     &           ,RO2BL(NKR,ICEMAX) &
+     &           ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
+     &           ,FF2(NKR,ICEMAX) &
+     &           ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX)
+
+! SNOW                                                                          
+        REAL R3(NKR) &
+     &           ,RSEC(NKR),RO3BL(NKR) &
+     &           ,FI3(NKR),FF3(NKR),PSI3(NKR) &
+     &           ,B31_MY(NKR),B32_MY(NKR)
+
+! GRAUPELS 
+                                                                       
+        REAL R4(NKR) &
+     &           ,RGEC(NKR),RO4BL(NKR) &
+     &           ,FI4(NKR),FF4(NKR),PSI4(NKR) &
+     &           ,B41_MY(NKR),B42_MY(NKR)  
+
+! HAIL                                                                          
+        REAL R5(NKR) &
+     &           ,RHEC(NKR),RO5BL(NKR) &
+     &           ,FI5(NKR),FF5(NKR),PSI5(NKR) &
+     &           ,B51_MY(NKR),B52_MY(NKR)  
+
+! CCN                                                                       
+
+! WORK ARRAYS 
+
+! NEW ALGORITHM OF MIXED PHASE FOR EVAPORATION
+
+	REAL DTIMEG(NKR),DTIMEH(NKR) 
+       
+	REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
+
+! NEW ALGORITHM (NO TYPE OF ICE)
+
+     &           ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR) &
+     &           ,SFNI1(ICEMAX),SFNI2(ICEMAX) &
+     &           ,TIMESTEPD(NKR) &
+     &           ,FI1REF(NKR),PSI1REF(NKR) &
+     &           ,FI2REF(NKR,ICEMAX),PSI2REF(NKR,ICEMAX)&
+     &           ,FCCNRREF(NKR)
+
+
+	OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
+	OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
+
+        DATA AL1 /2500./, AL2 /2834./, D /0.211/ &
+     &      ,GAM /1.E-4/, POD /10./ 
+           
+	DATA RV_MY,CF_MY,D_MYIN,AL1_MY,AL2_MY &
+     &      /461.5,0.24E-1,0.211E-4,2.5E6,2.834E6/
+
+	DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
+     &      /2.53,5.42,3.41E1,6.13/
+
+	DATA TPC1, TPC2, TPC3, TPC4, TPC5 &
+     &      /-4.0,-8.1,-12.7,-17.8,-22.4/ 
+
+
+        DATA EPSDEL/0.1E-03/
+    
+	DATA DT0L, DT0I /1.E20,1.E20/
+
+! CONTROL OF DROP SPECTRUM IN SUBROUTINE ONECOND
+
+
+! CONTROL OF TIMESTEP ITERATIONS IN MIXED PHASE: EVAPORATION
+        
+        I_MIXCOND=0
+        I_MIXEVAP=0
+        I_ABERGERON=0
+        I_BERGERON=0
+! SOME CONSTANTS 
+        COL3=3.0*COL
+        ICM=ICEMAX
+        ITIME=0
+        KCOND=0
+        DT_WATER_COND=0.4
+        DT_WATER_EVAP=0.4
+        DT_ICE_COND=0.4
+        DT_ICE_EVAP=0.4
+        DT_MIX_COND=0.4
+        DT_MIX_EVAP=0.4
+        DT_MIX_BERGERON=0.4
+        DT_MIX_ANTIBERGERON=0.4
+	ICM=ICEMAX
+	ITIME=0
+	KCOND=0
+        DT0LREF=0.2
+        DTLREF=0.4
+
+	NR=NKR
+	NRM=NKR-1
+	DT=DTCOND
+	DTT=DTCOND
+	XRAD=0.
+
+!     BARRY
+	CWHUCM=0.
+	XRAD=0.
+	B6=CWHUCM*GAM-XRAD
+	B8L=1./ROR
+	B8I=1./ROR
+        RORI=1./ROR
+
+! INITIALIZATION OF SOME ARRAYS
+
+!       BARRY
+        TPN=TT
+        QPN=QQ
+
+
+! TYPE OF ICE IN DIFFUSIONAL GROWTH 
+
+	      DO ICE=1,ICEMAX
+	         SFNI1(ICE)=0.
+	         SFNI2(ICE)=0.
+	         DEL2D(ICE)=0.
+	      ENDDO
+
+! TIME SPLITTING 
+
+	      TIMENEW=0.
+	      ITIME=0
+
+! ONLY ICE (CONDENSATION OR EVAPORATION) :
+
+   46         ITIME=ITIME+1
+
+	      TIMEREV=DT-TIMENEW
+
+	      DEL1=DEL1N
+	      DEL2=DEL2N
+	      DEL1S=DEL1N
+	      DEL2S=DEL2N
+	      DEL2D(1)=DEL2N
+	      DEL2D(2)=DEL2N
+	      DEL2D(3)=DEL2N
+	      TPS=TPN
+	      QPS=QPN
+              DO KR=1,NKR
+                 FI3(KR)=PSI3(KR)
+                 FI4(KR)=PSI4(KR)
+                 FI5(KR)=PSI5(KR)
+                 DO ICE=1,ICEMAX
+                    FI2(KR,ICE)=PSI2(KR,ICE)
+                 ENDDO
+              ENDDO
+! TIME-STEP GROWTH RATE: 
+! ONLY ICE (CONDENSATION OR EVAPORATION)
+              CALL JERRATE(R2,TPS,PP,ROR,VR2,PSINGLE &
+     &                    ,RIEC,RO2BL,B21_MY,B22_MY,3,2,ICEMAX,NKR)   
+              CALL JERRATE(R3,TPS,PP,ROR,VR3,PSINGLE &
+     &                    ,RSEC,RO3BL,B31_MY,B32_MY,1,2,ICEMAX,NKR)
+              CALL JERRATE(R4,TPS,PP,ROR,VR4,PSINGLE &
+     &                    ,RGEC,RO4BL,B41_MY,B42_MY,1,2,ICEMAX,NKR)
+              CALL JERRATE(R5,TPS,PP,ROR,VR5,PSINGLE &
+     &                    ,RHEC,RO5BL,B51_MY,B52_MY,1,2,ICEMAX,NKR)
+
+
+! INTEGRALS IN DELTA EQUATION
+
+! CALL JERTIMESC CRYSTAL - 1 (ONLY ICE)
+              CALL JERTIMESC_ICE  &
+     &       (FI2,R2,SFNI1,SFNI2,B21_MY,B22_MY,RIEC,B8I,ICM,COL,NKR) 
+              CALL JERTIMESC &
+     &       (FI3,R3,SFN31,SFN32,B31_MY,B32_MY,RSEC,B8I,1,COL,NKR)  
+              CALL JERTIMESC &
+     &       (FI4,R4,SFN41,SFN42,B41_MY,B42_MY,RGEC,B8I,1,COL,NKR) 
+              CALL JERTIMESC &
+     &       (FI5,R5,SFN51,SFN52,B51_MY,B52_MY,RHEC,B8I,1,COL,NKR)
+	      SFNII1=SFNI1(1)+SFNI1(2)+SFNI1(3)
+	      SFNII2=SFNI2(1)+SFNI2(2)+SFNI2(3)
+	      SFN21=SFNII1+SFN31+SFN41+SFN51        
+	      SFN22=SFNII2+SFN32+SFN42+SFN52 
+	      SFNL=0.
+	      SFNI=SFN21+SFN22       
+! SOME CONSTANTS 
+	      B5L=BB1_MY/TPS/TPS
+	      B5I=BB2_MY/TPS/TPS
+              B7L=B5L*B6                                                     
+              B7I=B5I*B6
+	      DOPL=1.+DEL1S                                                     
+	      DOPI=1.+DEL2S                                                     
+	      OPERQ=OPER2(QPS)  
+              RW=(OPERQ+B5L*AL1)*DOPL*SFNL                                      
+              QW=B7L*DOPL
+              PW=(OPERQ+B5I*AL1)*DOPI*SFNL
+              RI=(OPERQ+B5L*AL2)*DOPL*SFNI
+              PI=(OPERQ+B5I*AL2)*DOPI*SFNI
+              QI=B7I*DOPI
+	      KCOND=20
+	      IF(DEL2.GT.0) KCOND=21
+
+! PROCESS'S TYPE (ONLY ICE) 
+
+	      IF(KCOND.EQ.21)  THEN
+
+! ONLY_ICE: CONDENSATION
+
+	      
+                DT0I=1.E20
+	        DTNEWI1=DTCOND
+	        DTNEWL=DTNEWI1
+	        IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
+	        ENDIF
+	        TIMESTEPD(ITIME)=DTNEWL
+! NEW TIME STEP (ONLY_ICE: CONDENSATION)
+	        IF(DTNEWL.GT.DT) DTNEWL=DT
+	        IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+	        TIMESTEPD(ITIME)=DTNEWL
+	        TIMENEW=TIMENEW+DTNEWL
+	        DTT=DTNEWL
+! SOLVING FOR SUPERSATURATION (ONLY ICE: CONDENSATION) 
+
+! CALL JERSUPSAT - 4 (ONLY ICE: CONDENSATION)
+
+	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                        ,RW,PW,RI,PI,QW,QI &
+     &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
+
+! END OF "NEW SUPERSATURATION" (ONLY ICE: CONDENSATION)
+
+
+! CRYSTALS (ONLY ICE: CONDENSATION) 
+
+	        IF(ISYM2.NE.0) THEN
+
+! CRYSTAL DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
+ 
+! CALL JERDFUN CRYSTAL - 1 (ONLY ICE: CONDENSATION)
+
+! NEW ALGORITHM (NO TYPE ICE)
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                        ,FI2,PSI2,D2N &
+     &                        ,ICM,1,COL,NKR,TPN)
+
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                        ,FI2,PSI2,D2N &
+     &                        ,ICM,2,COL,NKR,TPN)
+
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                        ,FI2,PSI2,D2N &
+     &                        ,ICM,3,COL,NKR,TPN)
+! IN CASE : ISYM2.NE.0
+
+	        ENDIF
+! SNOW 
+	        IF(ISYM3.NE.0) THEN
+
+! SNOW DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
+                                                         
+
+! CALL JERDFUN SNOW - 1 (ONLY ICE: CONDENSATION)
+                  CALL JERDFUN(R3,B31_MY,B32_MY &
+     &                        ,FI3,PSI3,D2N &
+     &                        ,1,3,COL,NKR,TPN)
+
+	        ENDIF
+! IN CASE : ISYM4.NE.0
+! GRAUPELS (ONLY_ICE: EVAPORATION)
+
+                IF(ISYM4.NE.0) THEN
+
+! GRAUPEL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION)
+
+                  CALL JERDFUN(R4,B41_MY,B42_MY &
+     &                        ,FI4,PSI4,D2N &
+     &                        ,1,4,COL,NKR,TPN)
+! IN CASE : ISYM4.NE.0
+
+                ENDIF
+
+
+
+! HAIL (ONLY ICE: CONDENSATION) 
+
+	        IF(ISYM5.NE.0) THEN
+
+! HAIL DTRIBUTION FUNCTION (ONLY ICE: CONDENSATION) 
+                                                         
+! CALL JERDFUN HAIL - 1 (ONLY ICE: CONDENSATION) 
+	          CALL JERDFUN(R5,B51_MY,B52_MY &
+     &                        ,FI5,PSI5,D2N &
+     &                        ,1,5,COL,NKR,TPN)
+! IN CASE : ISYM5.NE.0
+
+	        ENDIF
+
+	        IF((DEL2.GT.0.AND.DEL2N.LT.0) &
+     &         .AND.ABS(DEL2N).GT.EPSDEL) THEN
+                call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL2.GT.0.AND.DEL2N.LT.0), model stop")
+                ENDIF
+
+	      ELSE
+
+! IN CASE KCOND.NE.21 
+
+! ONLY ICE: EVAPORATION  
+
+! NEW TREATMENT OF TIME STEP (ONLY ICE: EVAPORATION) 
+
+	        DT0I=1.E20
+                IF (DEL2N.EQ.0)THEN
+	          DTNEWL=DT
+                ELSE
+	         DTNEWI3=-R3(3)/(B31_MY(3)*DEL2N-B32_MY(3))
+	         DTNEWI4=-R4(3)/(B41_MY(3)*DEL2N-B42_MY(3))
+	         DTNEWI5=-R5(3)/(B51_MY(3)*DEL2N-B52_MY(3))
+! NEW ALGORITHM (NO TYPE OF ICE)
+	         DTNEWI2_1=-R2(3,1)/(B21_MY(1,1)*DEL2N-B22_MY(1,1))
+	         DTNEWI2_2=-R2(3,2)/(B21_MY(1,2)*DEL2N-B22_MY(1,2))
+	         DTNEWI2_3=-R2(3,3)/(B21_MY(1,3)*DEL2N-B22_MY(1,3))
+                 DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
+	         DTNEWI1=AMIN1(DTNEWI2,DTNEWI3,DTNEWI4 &
+     &                       ,DTNEWI5,DT0I,TIMEREV)
+	         DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I,TIMEREV)
+	         DTNEWL=DTNEWI1
+	         IF(DTNEWL.LT.DTLREF) DTNEWL=AMIN1(DTLREF,TIMEREV)
+                END IF
+	        IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
+                ENDIF
+	        TIMESTEPD(ITIME)=DTNEWL
+
+! NEW TIME STEP (ONLY_ICE: EVAPORATION)
+
+	        IF(DTNEWL.GT.DT) DTNEWL=DT
+	        IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1))  &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+	        TIMENEW=TIMENEW+DTNEWL
+	        TIMESTEPD(ITIME)=DTNEWL
+	        DTT=DTNEWL
+! SOLVING FOR SUPERSATURATION (ONLY_ICE: EVAPORATION) 
+	        CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                        ,RW,PW,RI,PI,QW,QI &
+     &                        ,DTT,D1N,D2N,DT0L0,DT0I0)
+! END OF "NEW SUPERSATURATION" (ONLY_ICE: EVAPORATION) 
+
+! CRYSTALS
+	        IF(ISYM2.NE.0) THEN
+
+! CRYSTAL DISTRIBUTION FUNCTION 
+
+! NEW ALGORITHM (NO TYPE ICE) 
+
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                         ,FI2,PSI2,D2N &
+     &                         ,ICM,1,COL,NKR,TPN)
+
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                         ,FI2,PSI2,D2N &
+     &                         ,ICM,2,COL,NKR,TPN)
+
+	          CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                         ,FI2,PSI2,D2N &
+     &                         ,ICM,3,COL,NKR,TPN)
+	        ENDIF
+! SNOW 
+	        IF(ISYM3.NE.0) THEN
+
+! SNOW DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
+                                                         
+
+! CALL JERDFUN - SNOW - 2 (ONLY_ICE: EVAPORATION)
+
+	          CALL JERDFUN(R3,B31_MY,B32_MY &
+     &                        ,FI3,PSI3,D2N &
+     &                        ,1,3,COL,NKR,TPN)
+
+
+
+
+
+! IN CASE : ISYM3.NE.0
+
+	        ENDIF
+
+! GRAUPELS (ONLY_ICE: EVAPORATION) 
+
+	        IF(ISYM4.NE.0) THEN
+
+! GRAUPEL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
+                                                         
+	          CALL JERDFUN(R4,B41_MY,B42_MY &
+     &                        ,FI4,PSI4,D2N &
+     &                        ,1,4,COL,NKR,TPN)
+! IN CASE : ISYM4.NE.0
+
+	        ENDIF
+
+! HAIL (ONLY_ICE: EVAPORATION) 
+
+	        IF(ISYM5.NE.0) THEN
+
+! HAIL DISTRIBUTION FUNCTION (ONLY_ICE: EVAPORATION) 
+                                                         
+	          CALL JERDFUN(R5,B51_MY,B52_MY &
+     &                        ,FI5,PSI5,D2N &
+     &                        ,1,5,COL,NKR,TPN)
+! IN CASE : ISYM5.NE.0
+
+	        ENDIF
+
+	        IF((DEL2.LT.0.AND.DEL2N.GT.0) &
+     &         .AND.ABS(DEL2N).GT.EPSDEL) THEN
+                call wrf_error_fatal("fatal error in module_mp_full_sbm (DEL2.LT.0.AND.DEL2N.GT.0), model stop")
+	        ENDIF
+
+! IN CASE : KCOND.NE.21
+ 
+	      ENDIF
+
+! IN CASES : KCOND = 21 OR KCOND.NE.21
+
+! END OF "PROCESS'S TYPE" 
+!
+! MASSES
+              RMASSIBB=0.0
+              RMASSIAA=0.0
+! BEFORE JERNEWF
+              DO K=1,NKR
+                 DO ICE =1,ICEMAX
+                    FI2_K=FI2(K,ICE)
+                    R2_K=R2(K,ICE)
+                    FI2R2=FI2_K*R2_K*R2_K
+                    RMASSIBB=RMASSIBB+FI2R2
+                 ENDDO
+                 FI3_K=FI3(K)
+                 FI4_K=FI4(K)
+                 FI5_K=FI5(K)
+                 R3_K=R3(K)
+                 R4_K=R4(K)
+                 R5_K=R5(K)
+                 FI3R3=FI3_K*R3_K*R3_K
+                 FI4R4=FI4_K*R4_K*R4_K
+                 FI5R5=FI5_K*R5_K*R5_K
+                 RMASSIBB=RMASSIBB+FI3R3
+                 RMASSIBB=RMASSIBB+FI4R4
+                 RMASSIBB=RMASSIBB+FI5R5
+              ENDDO
+              RMASSIBB=RMASSIBB*COL3*RORI
+! NEW CHANGE RMASSIBB
+              IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
+! AFTER JERNEWF
+              DO K=1,NKR
+                 DO ICE =1,ICEMAX
+                    FI2_K=PSI2(K,ICE)
+                    R2_K=R2(K,ICE)
+                    FI2R2=FI2_K*R2_K*R2_K
+                    RMASSIAA=RMASSIAA+FI2R2
+                 ENDDO
+                 FI3_K=PSI3(K)
+                 FI4_K=PSI4(K)
+                 FI5_K=PSI5(K)
+                 R3_K=R3(K)
+                 R4_K=R4(K)
+                 R5_K=R5(K)
+                 FI3R3=FI3_K*R3_K*R3_K
+                 FI4R4=FI4_K*R4_K*R4_K
+                 FI5R5=FI5_K*R5_K*R5_K
+                 RMASSIAA=RMASSIAA+FI3R3
+                 RMASSIAA=RMASSIAA+FI4R4
+                 RMASSIAA=RMASSIAA+FI5R5
+              ENDDO
+              RMASSIAA=RMASSIAA*COL3*RORI
+! NEW CHANGE RMASSIAA
+              IF(RMASSIAA.LT.0.0) RMASSIAA=0.0
+! NEW TREATMENT OF "T" & "Q"
+              DELMASSI1=RMASSIAA-RMASSIBB
+              QPN=QPS-DELMASSI1
+              DAL2=AL2
+              TPN=TPS+DAL2*DELMASSI1
+! SUPERSATURATION
+              ARGEXP=-BB1_MY/TPN
+              ES1N=AA1_MY*DEXP(ARGEXP)
+              ARGEXP=-BB2_MY/TPN
+              ES2N=AA2_MY*DEXP(ARGEXP)
+              EW1N=OPER3(QPN,PP)
+              IF(ES1N.EQ.0)THEN
+               DEL1N=0.5
+               DIV1=1.5
+               call wrf_error_fatal("fatal error in module_mp_full_sbm (ES1N.EQ.0), model stop")
+              ELSE
+               DIV1=EW1N/ES1N
+               DEL1N=EW1N/ES1N-1.
+              END IF
+              IF(ES2N.EQ.0)THEN
+               DEL2N=0.5
+               DIV2=1.5
+               call wrf_error_fatal("fatal error in module_mp_full_sbm (ES2N.EQ.0), model stop")
+              ELSE
+               DEL2N=EW1N/ES2N-1.
+               DIV2=EW1N/ES2N
+              END IF
+
+!  END OF TIME SPLITTING 
+! (ONLY ICE: CONDENSATION OR EVAPORATION) 
+	      IF(TIMENEW.LT.DT) GOTO 46
+        TT=TPN
+        QQ=QPN
+	DO KR=1,NKR
+	   DO ICE=1,ICEMAX
+	      FF2(KR,ICE)=PSI2(KR,ICE)
+	   ENDDO
+	   FF3(KR)=PSI3(KR)
+	   FF4(KR)=PSI4(KR)
+	   FF5(KR)=PSI5(KR)
+	ENDDO
+
+
+! GO TO "CONDENSATION AND VAPORATION"
+
+
+        RETURN                                          
+        END SUBROUTINE ONECOND2
+!==================================================================
+
+        SUBROUTINE ONECOND3 &
+     & (TT,QQ,PP,ROR &
+     & ,VR1,VR2,VR3,VR4,VR5,PSINGLE &
+     & ,DEL1N,DEL2N,DIV1,DIV2 &
+     & ,FF1,PSI1,R1,RLEC,RO1BL &
+     & ,FF2,PSI2,R2,RIEC,RO2BL &
+     & ,FF3,PSI3,R3,RSEC,RO3BL &
+     & ,FF4,PSI4,R4,RGEC,RO4BL &
+     & ,FF5,PSI5,R5,RHEC,RO5BL &
+     & ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     & ,C1_MEY,C2_MEY &
+     & ,COL,DTCOND,ICEMAX,NKR &
+     & ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
+       IMPLICIT NONE
+       INTEGER ICEMAX,NKR,KR,ITIME,ICE,KCOND,K &
+     &           ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5
+       INTEGER KLIMITL,KLIMITG,KLIMITH,KLIMITI_1, &
+     &  KLIMITI_2,KLIMITI_3
+       INTEGER I_MIXCOND,I_MIXEVAP,I_ABERGERON,I_BERGERON  
+       REAL ROR,VR1(NKR),VR2(NKR,ICEMAX),VR3(NKR),VR4(NKR) &
+     &           ,VR5(NKR),PSINGLE &
+     &           ,AA1_MY,BB1_MY,AA2_MY,BB2_MY &
+     &           ,C1_MEY,C2_MEY &
+     &           ,COL,DTCOND
+
+! DROPLETS 
+                                                                       
+        REAL R1(NKR)&
+     &           ,RLEC(NKR),RO1BL(NKR) &
+     &           ,FI1(NKR),FF1(NKR),PSI1(NKR) &
+     &           ,B11_MY(NKR),B12_MY(NKR)
+
+! CRYSTALS
+                                                                       
+	REAL R2(NKR,ICEMAX) &
+     &           ,RIEC(NKR,ICEMAX) &
+     &           ,RO2BL(NKR,ICEMAX) &
+     &           ,FI2(NKR,ICEMAX),PSI2(NKR,ICEMAX) &
+     &           ,FF2(NKR,ICEMAX) &
+     &           ,B21_MY(NKR,ICEMAX),B22_MY(NKR,ICEMAX) &
+     &           ,RATE2(NKR,ICEMAX),DEL_R2M(NKR,ICEMAX)
+
+! SNOW                                                                          
+        REAL R3(NKR) &
+     &           ,RSEC(NKR),RO3BL(NKR) &
+     &           ,FI3(NKR),FF3(NKR),PSI3(NKR) &
+     &           ,B31_MY(NKR),B32_MY(NKR) &
+     &           ,DEL_R3M(NKR)  
+
+! GRAUPELS 
+                                                                       
+        REAL R4(NKR),R4N(NKR) &
+     &           ,RGEC(NKR),RO4BL(NKR) &
+     &           ,FI4(NKR),FF4(NKR),PSI4(NKR) &
+     &           ,B41_MY(NKR),B42_MY(NKR) &
+     &           ,DEL_R4M(NKR)
+
+! HAIL                                                                          
+        REAL R5(NKR),R5N(NKR) &
+     &           ,RHEC(NKR),RO5BL(NKR) &
+     &           ,FI5(NKR),FF5(NKR),PSI5(NKR) &
+     &           ,B51_MY(NKR),B52_MY(NKR) &
+     &           ,DEL_R5M(NKR)
+
+      DOUBLE PRECISION DD1N,DB11_MY,DAL1,DAL2
+      DOUBLE PRECISION COL3,RORI,TPN,TPS,QPN,QPS,TOLD,QOLD &
+     &                  ,FI1_K,FI2_K,FI3_K,FI4_K,FI5_K &
+     &                  ,R1_K,R2_K,R3_K,R4_K,R5_K &
+     &                  ,FI1R1,FI2R2,FI3R3,FI4R4,FI5R5 &
+     &                  ,RMASSLAA,RMASSLBB,RMASSIAA,RMASSIBB &
+     &                  ,ES1N,ES2N,EW1N,ARGEXP &
+     &                  ,TT,QQ,PP,DEL1N0,DEL2N0 &
+     &                  ,DEL1N,DEL2N,DIV1,DIV2 &
+     &                  ,OPER2,OPER3,AR1,AR2
+
+       DOUBLE PRECISION DELTAQ1,DELMASSI1,DELMASSL1
+
+       REAL A1_MYN, BB1_MYN, A2_MYN, BB2_MYN
+        DATA A1_MYN, BB1_MYN, A2_MYN, BB2_MYN &
+     &      /2.53,5.42,3.41E1,6.13/
+       REAL B8L,B8I,SFN11,SFN12,SFNL,SFNI
+       REAL B5L,B5I,B7L,B7I,B6,DOPL,DEL1S,DEL2S,DOPI,RW,QW,PW, &
+     &  RI,PI,QI,SFNI1(ICEMAX),SFNI2(ICEMAX),AL1,AL2
+       REAL D1N,D2N,DT0L, DT0I,D1N0,D2N0
+       REAL SFN21,SFN22,SFNII1,SFNII2,SFN31,SFN32,SFN41,SFN42,SFN51, &
+     &  SFN52
+       REAL DEL1,DEL2
+       REAL  TIMEREV,DT,DTT,TIMENEW
+       REAL DTIMEG(NKR),DTIMEH(NKR)
+
+       REAL DEL2D(ICEMAX),DTIMEO(NKR),DTIMEL(NKR) &
+     &           ,DTIMEI_1(NKR),DTIMEI_2(NKR),DTIMEI_3(NKR)
+       REAL DT_WATER_COND,DT_WATER_EVAP,DT_ICE_COND,DT_ICE_EVAP, &
+     &  DT_MIX_COND,DT_MIX_EVAP,DT_MIX_BERGERON,DT_MIX_ANTIBERGERON
+       REAL DTNEWL0,DTNEWL1,DTNEWI1,DTNEWI2_1,DTNEWI2_2,DTNEWI2_3, &
+     & DTNEWI2,DTNEWI_1,DTNEWI_2,DTNEWI3,DTNEWI4,DTNEWI5, &
+     & DTNEWL,DTNEWL2,DTNEWG1,DTNEWH1
+       REAL TIMESTEPD(NKR)
+
+       DATA AL1 /2500./, AL2 /2834./
+       REAL EPSDEL,EPSDEL2
+       DATA EPSDEL, EPSDEL2 /0.1E-03,0.1E-03/
+       OPER2(AR1)=0.622/(0.622+0.378*AR1)/AR1
+       OPER3(AR1,AR2)=AR1*AR2/(0.622+0.378*AR1)
+      
+! BELOW
+!
+        DT_WATER_COND=0.4
+        DT_WATER_EVAP=0.4
+        DT_ICE_COND=0.4
+        DT_ICE_EVAP=0.4
+        DT_MIX_COND=0.4
+        DT_MIX_EVAP=0.4
+        DT_MIX_BERGERON=0.4
+        DT_MIX_ANTIBERGERON=0.4
+
+        I_MIXCOND=0
+        I_MIXEVAP=0
+        I_ABERGERON=0
+        I_BERGERON=0
+
+       ITIME = 0
+       TIMENEW=0.
+       DT=DTCOND
+       DTT=DTCOND
+
+       B6=0.
+       B8L=1./ROR
+       B8I=1./ROR
+! NEW CHANGES 19.04.01 (BEGIN)
+        RORI=1.D0/ROR
+! NEW CHANGES 19.04.01 (END)
+! NEW CHANGES 19.04.01 (BEGIN)
+        COL3=3.D0*COL
+! NEW CHANGES 19.04.01 (END)
+
+
+
+! BARRY:DIV
+        TPN=TT
+        QPN=QQ
+! HERE
+   16         ITIME=ITIME+1
+! BARRY
+!             TPC_NEW=TPN-273.15
+              IF((TPN-273.15).GE.-0.187) GO TO 17
+              TIMEREV=DT-TIMENEW
+              DEL1=DEL1N
+              DEL2=DEL2N
+              DEL1S=DEL1N
+              DEL2S=DEL2N
+! NEW ALGORITHM (NO TYPE ICE)
+              DEL2D(1)=DEL2N
+              DEL2D(2)=DEL2N
+              DEL2D(3)=DEL2N
+              TPS=TPN
+              QPS=QPN
+              DO KR=1,NKR
+                 FI1(KR)=PSI1(KR)
+                 FI3(KR)=PSI3(KR)
+                 FI4(KR)=PSI4(KR)
+                 FI5(KR)=PSI5(KR)
+                 DO ICE=1,ICEMAX
+                    FI2(KR,ICE)=PSI2(KR,ICE)
+                 ENDDO
+              ENDDO
+! TIME-STEP GROWTH RATE
+! HERE
+              CALL JERRATE(R1,TPS,PP,ROR,VR1,PSINGLE &
+     &                    ,RLEC,RO1BL,B11_MY,B12_MY,1,1,ICEMAX,NKR)
+              CALL JERRATE(R2,TPS,PP,ROR,VR2,PSINGLE &
+     &                    ,RIEC,RO2BL,B21_MY,B22_MY,3,2,ICEMAX,NKR)
+              CALL JERRATE(R3,TPS,PP,ROR,VR3,PSINGLE &
+     &                    ,RSEC,RO3BL,B31_MY,B32_MY,1,2,ICEMAX,NKR)
+              CALL JERRATE(R4,TPS,PP,ROR,VR4,PSINGLE &
+     &                    ,RGEC,RO4BL,B41_MY,B42_MY,1,2,ICEMAX,NKR)
+              CALL JERRATE(R5,TPS,PP,ROR,VR5,PSINGLE &
+     &                    ,RHEC,RO5BL,B51_MY,B52_MY,1,2,ICEMAX,NKR)
+              CALL JERTIMESC(FI1,R1,SFN11,SFN12 &
+     &                      ,B11_MY,B12_MY,RLEC,B8L,1,COL,NKR)
+              CALL JERTIMESC_ICE(FI2,R2,SFNI1,SFNI2 &
+     &                      ,B21_MY,B22_MY,RIEC,B8I,ICEMAX,COL,NKR)
+              CALL JERTIMESC(FI3,R3,SFN31,SFN32 &
+     &                      ,B31_MY,B32_MY,RSEC,B8I,1,COL,NKR)
+              CALL JERTIMESC(FI4,R4,SFN41,SFN42 &
+     &                      ,B41_MY,B42_MY,RGEC,B8I,1,COL,NKR)
+              CALL JERTIMESC(FI5,R5,SFN51,SFN52 &
+     &                      ,B51_MY,B52_MY,RHEC,B8I,1,COL,NKR)
+! NEW ALGORITHM (NO TYPE ICE)
+              SFNII1=SFNI1(1)+SFNI1(2)+SFNI1(3)
+              SFNII2=SFNI2(1)+SFNI2(2)+SFNI2(3)
+              SFN21=SFNII1+SFN31+SFN41+SFN51
+              SFN22=SFNII2+SFN32+SFN42+SFN52
+              SFNL=SFN11+SFN12
+              SFNI=SFN21+SFN22
+! SOME CONSTANTS (QW,QI=0,since B6=0.)
+              B5L=BB1_MY/TPS/TPS
+              B5I=BB2_MY/TPS/TPS
+              B7L=B5L*B6
+              B7I=B5I*B6
+              DOPL=1.+DEL1S
+              DOPI=1.+DEL2S
+              RW=(OPER2(QPS)+B5L*AL1)*DOPL*SFNL
+              QW=B7L*DOPL
+              PW=(OPER2(QPS)+B5I*AL1)*DOPI*SFNL
+              RI=(OPER2(QPS)+B5L*AL2)*DOPL*SFNI
+              PI=(OPER2(QPS)+B5I*AL2)*DOPI*SFNI
+              QI=B7I*DOPI
+! SOLVING FOR TIMEZERO
+              CALL JERSUPSAT(DEL1,DEL2,DEL1N0,DEL2N0 &
+     &                      ,RW,PW,RI,PI,QW,QI &
+     &                      ,DTT,D1N0,D2N0,DT0L,DT0I)
+! DEL1 > 0, DEL2 < 0    (ANTIBERGERON MIXED PHASE - KCOND=50)
+! DEL1 < 0 AND DEL2 < 0 (EVAPORATION MIXED_PHASE - KCOND=30)
+! DEL1 > 0 AND DEL2 > 0 (CONDENSATION MIXED PHASE - KCOND=31)
+! DEL1 < 0, DEL2 > 0    (BERGERON MIXED PHASE - KCOND=32)
+              KCOND=50
+
+              IF(DEL1.LT.0.AND.DEL2.LT.0) KCOND=30
+              IF(DEL1.GT.0.AND.DEL2.GT.0) KCOND=31
+              IF(DEL1.LT.0.AND.DEL2.GT.0) KCOND=32
+              IF(KCOND.EQ.50) THEN 
+                I_ABERGERON=I_ABERGERON+1
+                IF(DT0L.EQ.0) THEN
+                  DTNEWL=DT
+                ELSE
+                  DTNEWL=AMIN1(DT,DT0L)
+                ENDIF
+! NEW TIME STEP (ANTIBERGERON MIXED PHASE)
+                IF(DTNEWL.GT.DT) DTNEWL=DT
+                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+                TIMENEW=TIMENEW+DTNEWL
+                DTT=DTNEWL
+                IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
+                ENDIF
+                TIMESTEPD(ITIME)=DTNEWL
+! ANTIBERGERON MIXED PHASE (BEGIN)
+! IN CASE : KCOND = 50
+              ENDIF
+              IF(KCOND.EQ.31) THEN
+! CONDENSATION MIXED PHASE (BEGIN)
+! CONTROL OF TIMESTEP ITERATIONS
+                I_MIXCOND=I_MIXCOND+1
+               IF (DEL1N.EQ.0)THEN
+                DTNEWL0=DT
+               ELSE
+                DTNEWL0=ABS(R1(ITIME)/(B11_MY(ITIME)*DEL1N- &
+     &                                 B12_MY(ITIME)))
+               END IF
+! NEW ALGORITHM (NO TYPE OF ICE)
+
+               IF (DEL2N.EQ.0)THEN
+                DTNEWI2_1=DT
+                DTNEWI2_2=DT
+                DTNEWI2_3=DT
+                DTNEWI3=DT
+                DTNEWI4=DT
+                DTNEWI5=DT
+               ELSE
+                DTNEWI2_1=ABS(R2(ITIME,1)/ &
+     &         (B21_MY(ITIME,1)*DEL2N-B22_MY(ITIME,1)))
+                DTNEWI2_2=ABS(R2(ITIME,2)/ &
+     &         (B21_MY(ITIME,2)*DEL2N-B22_MY(ITIME,2))) 
+                DTNEWI2_3=ABS(R2(ITIME,3)/ &
+     &         (B21_MY(ITIME,3)*DEL2N-B22_MY(ITIME,3)))  
+                DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
+
+                DTNEWI3=ABS(R3(ITIME)/(B31_MY(ITIME)*DEL2N- &
+     &                                 B32_MY(ITIME)))
+                DTNEWI4=ABS(R4(ITIME)/(B41_MY(ITIME)*DEL2N- &
+     &                                 B42_MY(ITIME)))
+                DTNEWI5=ABS(R5(ITIME)/(B51_MY(ITIME)*DEL2N- &
+     &                                 B52_MY(ITIME)))
+               END IF
+                DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I)
+                IF(DT0L.NE.0) THEN
+                  IF(ABS(DT0L).LT.DT_MIX_COND) THEN
+                    DTNEWL1=AMIN1(DT_MIX_COND,DTNEWL0)
+                  ELSE
+                    DTNEWL1=AMIN1(DT0L,DTNEWL0)
+                  ENDIF
+                ELSE
+                  DTNEWL1=DTNEWL0
+                ENDIF
+                DTNEWL=AMIN1(DTNEWL1,DTNEWI1)
+                IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
+                ENDIF
+                TIMESTEPD(ITIME)=DTNEWL
+! NEW TIME STEP (CONDENSATION MIXED PHASE)
+                IF(DTNEWL.GT.DT) DTNEWL=DT
+                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+                TIMENEW=TIMENEW+DTNEWL
+                TIMESTEPD(ITIME)=DTNEWL
+                DTT=DTNEWL
+! CONDENSATION MIXED PHASE (END)
+! IN CASE : KCOND = 31
+              ENDIF
+              IF(KCOND.EQ.30) THEN
+! EVAPORATION MIXED PHASE (BEGIN)
+! CONTROL OF TIMESTEP ITERATIONS
+                I_MIXEVAP=I_MIXEVAP+1
+                DO KR=1,NKR
+                   DTIMEL(KR)=0.
+                   DTIMEG(KR)=0.
+                   DTIMEH(KR)=0.
+! NEW ALGORITHM (NO TYPE ICE)
+                   DTIMEI_1(KR)=0.
+                   DTIMEI_2(KR)=0.
+                   DTIMEI_3(KR)=0.
+                ENDDO
+                DO KR=1,NKR
+                 IF (DEL1N.EQ.0) THEN
+                   DTIMEL(KR)=DT
+                   DTIMEG(KR)=DT
+                   DTIMEH(KR)=DT
+                 ELSE
+                   DTIMEL(KR)=-R1(KR)/(B11_MY(KR)*DEL1N- &
+     &                                 B12_MY(KR))
+                   DTIMEG(KR)=-R4(KR)/(B41_MY(KR)*DEL1N- &
+     &                                 B42_MY(KR))
+                   DTIMEH(KR)=-R5(KR)/(B51_MY(KR)*DEL1N- &
+     &                             B52_MY(KR))
+! NEW ALGORITHM (NO TYPE OF ICE)
+                 END IF
+                 IF (DEL2N.EQ.0) THEN
+                   DTIMEI_1(KR)=DT
+                   DTIMEI_2(KR)=DT
+                   DTIMEI_3(KR)=DT
+                 ELSE
+                   DTIMEI_1(KR)=-R2(KR,1)/ &
+     &               (B21_MY(KR,1)*DEL2N-B22_MY(KR,1))
+                   DTIMEI_2(KR)=-R2(KR,2)/ &
+     &               (B21_MY(KR,2)*DEL2N-B22_MY(KR,2))
+                   DTIMEI_3(KR)=-R2(KR,3)/ &
+     &               (B21_MY(KR,3)*DEL2N-B22_MY(KR,3))
+                 END IF
+                ENDDO
+! WATER
+                KLIMITL=1
+                DO KR=1,NKR
+                   IF(DTIMEL(KR).GT.TIMEREV) GOTO 355
+                   KLIMITL=KR
+                ENDDO
+  355           KLIMITL=KLIMITL-1
+                IF(KLIMITL.LT.1) KLIMITL=1
+                DTNEWL1=AMIN1(DTIMEL(KLIMITL),DT0L,TIMEREV)
+! GRAUPELS
+                KLIMITG=1
+                DO KR=1,NKR
+                   IF(DTIMEG(KR).GT.TIMEREV) GOTO 455
+                   KLIMITG=KR
+                ENDDO
+  455           KLIMITG=KLIMITG-1
+                IF(KLIMITG.LT.1) KLIMITG=1
+                DTNEWG1=AMIN1(DTIMEG(KLIMITG),TIMEREV)
+! HAIL
+                KLIMITH=1
+                DO KR=1,NKR
+                   IF(DTIMEH(KR).GT.TIMEREV) GOTO 555
+                   KLIMITH=KR
+                ENDDO
+  555           KLIMITH=KLIMITH-1
+                IF(KLIMITH.LT.1) KLIMITH=1
+                DTNEWH1=AMIN1(DTIMEH(KLIMITH),TIMEREV)
+! ICE CRYSTALS
+! NEW ALGORITHM (NO TYPE OF ICE) (BEGIN)
+                KLIMITI_1=1
+                KLIMITI_2=1
+                KLIMITI_3=1
+                DO KR=1,NKR
+                   IF(DTIMEI_1(KR).GT.TIMEREV) GOTO 655
+                   KLIMITI_1=KR
+                ENDDO
+  655           CONTINUE
+                DO KR=1,NKR
+                   IF(DTIMEI_2(KR).GT.TIMEREV) GOTO 656
+                   KLIMITI_2=KR
+                ENDDO
+  656           CONTINUE
+                DO KR=1,NKR
+                   IF(DTIMEI_3(KR).GT.TIMEREV) GOTO 657
+                   KLIMITI_3=KR
+                ENDDO
+  657           CONTINUE
+                KLIMITI_1=KLIMITI_1-1
+                IF(KLIMITI_1.LT.1) KLIMITI_1=1
+                DTNEWI2_1=AMIN1(DTIMEI_1(KLIMITI_1),TIMEREV)
+                KLIMITI_2=KLIMITI_2-1
+                IF(KLIMITI_2.LT.1) KLIMITI_2=1
+                DTNEWI2_2=AMIN1(DTIMEI_2(KLIMITI_2),TIMEREV)
+                KLIMITI_3=KLIMITI_3-1
+                IF(KLIMITI_3.LT.1) KLIMITI_3=1
+                DTNEWI2_3=AMIN1(DTIMEI_3(KLIMITI_3),TIMEREV)
+                DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
+! NEW ALGORITHM (NO TYPE OF ICE) (END)
+                DTNEWI1=AMIN1(DTNEWI2,DTNEWG1,DTNEWH1,DT0I)
+                IF(ABS(DEL2N).LT.EPSDEL2) &
+     &          DTNEWI1=AMIN1(DTNEWI2,DTNEWG1,DTNEWH1)
+                DTNEWL2=AMIN1(DTNEWL1,DTNEWI1)
+                DTNEWL=DTNEWL2
+                IF(DTNEWL.LT.DT_MIX_EVAP) &
+     &          DTNEWL=AMIN1(DT_MIX_EVAP,TIMEREV)  
+                IF(ITIME.GE.NKR) THEN
+                call wrf_error_fatal("fatal error in module_mp_full_sbm (ITIME.GE.NKR), model stop")
+                ENDIF
+                TIMESTEPD(ITIME)=DTNEWL
+! NEW TIME STEP (EVAPORATION MIXED PHASE)
+                IF(DTNEWL.GT.DT) DTNEWL=DT
+                IF((TIMENEW+DTNEWL).GT.DT &
+     &         .AND.ITIME.LT.(NKR-1)) &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+                TIMESTEPD(ITIME)=DTNEWL
+                TIMENEW=TIMENEW+DTNEWL
+                DTT=DTNEWL
+! EVAPORATION MIXED PHASE (END)
+! IN CASE : KCOND = 30
+              ENDIF
+              IF(KCOND.EQ.32) THEN
+! BERGERON MIXED PHASE (BEGIN)
+! CONTROL OF TIMESTEP ITERATIONS
+                I_BERGERON=I_BERGERON+1
+! NEW TREATMENT OF TIME STEP (BERGERON MIXED PHASE)
+               IF (DEL1N.EQ.0)THEN
+                DTNEWL0=DT
+               ELSE
+                DTNEWL0=-R1(1)/(B11_MY(1)*DEL1N-B12_MY(1))
+               END IF
+! NEW ALGORITHM (NO TYPE ICE)
+               IF (DEL2N.EQ.0)THEN
+                DTNEWI2_1=DT
+                DTNEWI2_2=DT
+                DTNEWI2_3=DT
+               ELSE
+                DTNEWI2_1=R2(1,1)/(B21_MY(1,1)*DEL2N-B22_MY(1,1))
+                DTNEWI2_2=R2(1,2)/(B21_MY(1,2)*DEL2N-B22_MY(1,2))
+                DTNEWI2_3=R2(1,3)/(B21_MY(1,3)*DEL2N-B22_MY(1,3))
+               END IF
+               DTNEWI2=AMIN1(DTNEWI2_1,DTNEWI2_2,DTNEWI2_3)
+               IF (DEL2N.EQ.0)THEN
+                DTNEWI3=DT
+                DTNEWI4=DT
+                DTNEWI5=DT
+               ELSE
+                DTNEWI3=R3(1)/(B31_MY(1)*DEL2N-B32_MY(1))
+                DTNEWI4=R4(1)/(B41_MY(1)*DEL2N-B42_MY(1))
+                DTNEWI5=R5(1)/(B51_MY(1)*DEL2N-B52_MY(1))
+               END IF
+                DTNEWL1=AMIN1(DTNEWL0,DT0L,TIMEREV)
+                DTNEWI1=AMIN1(DTNEWI2,DTNEWI3,DTNEWI4 &
+     &                       ,DTNEWI5,DT0I,TIMEREV)
+                DTNEWI1=AMIN1(DTNEWI2,DTNEWI4,DTNEWI5,DT0I,TIMEREV)
+                DTNEWL=AMIN1(DTNEWL1,DTNEWI1)
+! NEW CHANGES 23.04.01 (BEGIN)
+                IF(DTNEWL.LT.DT_MIX_BERGERON) &
+     &          DTNEWL=AMIN1(DT_MIX_BERGERON,TIMEREV)
+                TIMESTEPD(ITIME)=DTNEWL
+! NEW TIME STEP (BERGERON MIXED PHASE)
+                IF(DTNEWL.GT.DT) DTNEWL=DT
+                IF((TIMENEW+DTNEWL).GT.DT.AND.ITIME.LT.(NKR-1)) &
+     &          DTNEWL=DT-TIMENEW
+                IF(ITIME.EQ.(NKR-1)) DTNEWL=DT-TIMENEW
+                TIMESTEPD(ITIME)=DTNEWL
+                TIMENEW=TIMENEW+DTNEWL
+                DTT=DTNEWL
+! BERGERON MIXED PHASE (END)
+! IN CASE : KCOND = 32
+              ENDIF
+! SOLVING FOR SUPERSATURATION 
+! CALL JERSUPSAT - 7 (MIXED_PHASE)
+         
+	      CALL JERSUPSAT(DEL1,DEL2,DEL1N,DEL2N &
+     &                      ,RW,PW,RI,PI,QW,QI &
+     &                      ,DTT,D1N,D2N,DT0L,DT0I)
+! END OF "NEW SUPERSATURATION" 
+
+! DROPLETS 
+	      IF(ISYM1.NE.0) THEN
+
+! DROPLET DISTRIBUTION FUNCTION 
+
+                                                         
+! CALL JERDFUN - 3
+	        CALL JERDFUN(R1,B11_MY,B12_MY &
+     &                      ,FI1,PSI1,D1N &
+     &                      ,1,1,COL,NKR,TPN)
+! END OF "DROPLET DISTRIBUTION FUNCTION" 
+ 
+! IN CASE ISYM1.NE.0
+
+ 	      ENDIF                     
+! CRYSTALS 
+	      IF(ISYM2.NE.0) THEN
+
+! CRYSTAL DISTRIBUTION FUNCTION 
+ 
+	        CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                      ,FI2,PSI2,D2N &
+     &                      ,ICEMAX,1,COL,NKR,TPN)
+
+	        CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                      ,FI2,PSI2,D2N &
+     &                      ,ICEMAX,2,COL,NKR,TPN)
+
+	        CALL JERDFUN(R2,B21_MY,B22_MY &
+     &                      ,FI2,PSI2,D2N &
+     &                      ,ICEMAX,3,COL,NKR,TPN)
+! IN CASE ISYM2.NE.0
+
+	      ENDIF
+! SNOW 
+	      IF(ISYM3.NE.0) THEN
+
+! SNOW DISTRIBUTION FUNCTION 
+                                                         
+
+! CALL JERDFUN - SNOW - 3
+
+ 	        CALL JERDFUN(R3,B31_MY,B32_MY &
+     &                      ,FI3,PSI3,D2N &
+     &                      ,1,3,COL,NKR,TPN)
+
+
+! IN CASE ISYM3.NE.0
+
+  	      ENDIF
+
+! GRAUPELS 
+
+	      IF(ISYM4.NE.0) THEN
+
+! GRAUPEL DISTRIBUTION FUNCTION
+                                                         
+	        CALL JERDFUN(R4,B41_MY,B42_MY &
+     &                      ,FI4,PSI4,D2N &
+     &                      ,1,4,COL,NKR,TPN)
+! IN CASE ISYM4.NE.0
+
+	      ENDIF
+! HAIL 
+	      IF(ISYM5.NE.0) THEN
+
+! HAIL DISTRIBUTION FUNCTION 
+                                                         
+	        CALL JERDFUN(R5,B51_MY,B52_MY &
+     &                      ,FI5,PSI5,D2N &
+     &                      ,1,5,COL,NKR,TPN)
+! IN CASE ISYM5.NE.0
+
+	      ENDIF
+! MASSES
+              RMASSLBB=0.D0
+              RMASSIBB=0.D0
+              RMASSLAA=0.D0
+              RMASSIAA=0.D0
+! BEFORE JERNEWF
+              DO K=1,NKR
+                 FI1_K=FI1(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLBB=RMASSLBB+FI1R1
+                 DO ICE =1,ICEMAX
+                    FI2_K=FI2(K,ICE)
+                    R2_K=R2(K,ICE)
+                    FI2R2=FI2_K*R2_K*R2_K
+                    RMASSIBB=RMASSIBB+FI2R2
+                 ENDDO
+                 FI3_K=FI3(K)
+                 FI4_K=FI4(K)
+                 FI5_K=FI5(K)
+                 R3_K=R3(K)
+                 R4_K=R4(K)
+                 R5_K=R5(K)
+                 FI3R3=FI3_K*R3_K*R3_K
+                 FI4R4=FI4_K*R4_K*R4_K
+                 FI5R5=FI5_K*R5_K*R5_K
+                 RMASSIBB=RMASSIBB+FI3R3
+                 RMASSIBB=RMASSIBB+FI4R4
+                 RMASSIBB=RMASSIBB+FI5R5
+              ENDDO
+              RMASSIBB=RMASSIBB*COL3*RORI
+! NEW CHANGE RMASSIBB
+              IF(RMASSIBB.LT.0.0) RMASSIBB=0.0
+              RMASSLBB=RMASSLBB*COL3*RORI
+! NEW CHANGE RMASSLBB
+              IF(RMASSLBB.LT.0.0) RMASSLBB=0.0
+! AFTER  JERNEWF
+              DO K=1,NKR
+                 FI1_K=PSI1(K)
+                 R1_K=R1(K)
+                 FI1R1=FI1_K*R1_K*R1_K
+                 RMASSLAA=RMASSLAA+FI1R1
+                 DO ICE =1,ICEMAX
+                    FI2(K,ICE)=PSI2(K,ICE)
+                    FI2_K=FI2(K,ICE)
+                    R2_K=R2(K,ICE)
+                    FI2R2=FI2_K*R2_K*R2_K
+                    RMASSIAA=RMASSIAA+FI2R2
+                 ENDDO
+                 FI3_K=PSI3(K)
+                 FI4_K=PSI4(K)
+                 FI5_K=PSI5(K)
+                 R3_K=R3(K)
+                 R4_K=R4(K)
+                 R5_K=R5(K)
+                 FI3R3=FI3_K*R3_K*R3_K
+                 FI4R4=FI4_K*R4_K*R4_K
+                 FI5R5=FI5_K*R5_K*R5_K
+                 RMASSIAA=RMASSIAA+FI3R3
+                 RMASSIAA=RMASSIAA+FI4R4
+                 RMASSIAA=RMASSIAA+FI5R5
+              ENDDO
+              RMASSIAA=RMASSIAA*COL3*RORI
+! NEW CHANGE RMASSIAA
+              IF(RMASSIAA.LE.0.0) RMASSIAA=0.0
+              RMASSLAA=RMASSLAA*COL3*RORI
+! NEW CHANGE RMASSLAA
+              IF(RMASSLAA.LT.0.0) RMASSLAA=0.0
+! NEW TREATMENT OF "T" & "Q"
+              DELMASSL1=RMASSLAA-RMASSLBB
+              DELMASSI1=RMASSIAA-RMASSIBB
+              DELTAQ1=DELMASSL1+DELMASSI1
+!             QPN=QPS-DELTAQ1-CWQ*DTT
+              QPN=QPS-DELTAQ1
+              DAL1=AL1
+              DAL2=AL2
+!             TPN=TPS+DAL1*DELMASSL1+AL2*DELMASSI1-CWQ*DTT
+              TPN=TPS+DAL1*DELMASSL1+DAL2*DELMASSI1
+! SUPERSATURATION
+              ARGEXP=-BB1_MY/TPN
+              ES1N=AA1_MY*DEXP(ARGEXP)
+              ARGEXP=-BB2_MY/TPN
+              ES2N=AA2_MY*DEXP(ARGEXP)
+              EW1N=OPER3(QPN,PP)
+              IF(ES1N.EQ.0)THEN
+               DEL1N=0.5
+               DIV1=1.5
+               print*,'es1n onecond3 = 0'
+!              stop
+              ELSE
+               DIV1=EW1N/ES1N
+               DEL1N=EW1N/ES1N-1.
+              END IF
+              IF(ES2N.EQ.0)THEN
+               DEL2N=0.5
+               DIV2=1.5
+               print*,'es2n onecond3 = 0'
+!              stop
+              ELSE
+               DEL2N=EW1N/ES2N-1.
+               DIV2=EW1N/ES2N
+              END IF
+! END OF TIME SPLITTING
+
+! HERE
+
+        IF(TIMENEW.LT.DT) GOTO 16
+17      CONTINUE
+
+        TT=TPN
+        QQ=QPN
+        DO KR=1,NKR
+           FF1(KR)=PSI1(KR)
+           DO ICE=1,ICEMAX
+              FF2(KR,ICE)=PSI2(KR,ICE)
+           ENDDO
+           FF3(KR)=PSI3(KR)
+           FF4(KR)=PSI4(KR)
+           FF5(KR)=PSI5(KR)
+        ENDDO
+
+
+        RETURN                                          
+        END SUBROUTINE ONECOND3
+
+        SUBROUTINE COAL_BOTT_NEW(FF1R,FF2R,FF3R, &
+     &   FF4R,FF5R,TT,QQ,PP,RHO,dt_coll,TCRIT,TTCOAL)
+       implicit none
+       INTEGER KR,ICE
+       INTEGER icol_drop,icol_snow,icol_graupel,icol_hail, &
+     & icol_column,icol_plate,icol_dendrite,icol_drop_brk
+       double precision  g1(nkr),g2(nkr,icemax),g3(nkr),g4(nkr),g5(nkr)
+       double precision gdumb(JMAX),xl_dumb(0:nkr),g_orig(nkr)
+       double precision g2_1(nkr),g2_2(nkr),g2_3(nkr)
+       real cont_fin_drop,dconc,conc_icempl,deldrop,t_new, &
+     & delt_new,cont_fin_ice,conc_old,conc_new,cont_init_ice, &
+     & cont_init_drop,ALWC
+       REAL    FF1R(NKR),FF2R(NKR,ICEMAX),FF3R(NKR),FF4R(NKR),FF5R(NKR)
+       REAL dt_coll
+       REAL TCRIT,TTCOAL
+       real tt_no_coll
+       parameter (tt_no_coll=273.16)
+
+
+       
+   
+! SHARED
+       INTEGER I,J,IT,NDIV
+       REAL RHO
+       DOUBLE PRECISION break_drop_bef,break_drop_aft,dtbreakup
+       DOUBLE PRECISION break_drop_per
+       DOUBLE PRECISION TT,QQ,PP,prdkrn,prdkrn1
+       parameter (prdkrn1=1.d0)
+!     print*,'tcrit = ',tcrit
+!     print*,'ttcoal = ',ttcoal
+!     print*,'col = ',col
+!     print*,'p1,p2,p3 = ',p1,p2,p3
+!     print*,'icempl,kr_icempl  = ',icempl,kr_icempl
+!     print*,'dt_coll = ',dt_coll
+      icol_drop_brk=0
+      icol_drop=0
+      icol_snow=0
+      icol_graupel=0
+      icol_hail=0
+      icol_column=0
+      icol_plate=0
+      icol_dendrite=0
+
+
+       t_new=tt
+         CALL MISC1(PP,cwll_1000mb,cwll_750mb,cwll_500mb, &
+     &    cwll,nkr)
+! THIS IS FOR BREAKUP
+         DO I=1,NKR
+            DO J=1,NKR
+               CWLL(I,J)=ECOALMASSM(I,J)*CWLL(I,J)
+            ENDDO
+         ENDDO
+!
+! THIS IS FOR TURBULENCE
+        IF (LIQTURB.EQ.1)THEN
+         DO I=1,KRMAX_LL
+           DO J=1,KRMAX_LL
+               CWLL(I,J)=CTURBLL(I,J)*CWLL(I,J)
+           END DO
+         END DO
+        END IF
+         CALL MODKRN(TT,QQ,PP,PRDKRN,TTCOAL)
+        DO 13 KR=1,NKR
+         G1(KR)=FF1R(KR)*3.*XL(KR)*XL(KR)*1.E3
+         G2(KR,1)=FF2R(KR,1)*3*xi(KR,1)*XI(KR,1)*1.e3
+         G2(KR,2)=FF2R(KR,2)*3.*xi(KR,2)*XI(KR,2)*1.e3
+         G2(KR,3)=FF2R(KR,3)*3.*xi(KR,3)*XI(KR,3)*1.e3
+         G3(KR)=FF3R(KR)*3.*xs(kr)*xs(kr)*1.e3
+         G4(KR)=FF4R(KR)*3.*xg(kr)*xg(kr)*1.e3
+         G5(KR)=FF5R(KR)*3.*xh(kr)*xh(kr)*1.e3
+         g2_1(kr)=g2(KR,1)
+         g2_2(KR)=g2(KR,2)
+         g2_3(KR)=g2(KR,3)
+         if(kr.gt.(nkr-jbreak).and.g1(kr).gt.1.e-17)icol_drop_brk=1
+!        icol_drop_brk=0
+         IF (IBREAKUP.NE.1)icol_drop_brk=0 
+         if(g1(kr).gt.1.e-10)icol_drop=1
+         if (tt.le.tt_no_coll)then
+         if(g2_1(kr).gt.1.e-10)icol_column=1
+         if(g2_2(kr).gt.1.e-10)icol_plate=1
+         if(g2_3(kr).gt.1.e-10)icol_dendrite=1
+         if(g3(kr).gt.1.e-10)icol_snow=1
+         if(g4(kr).gt.1.e-10)icol_graupel=1
+         if(g5(kr).gt.1.e-10)icol_hail=1
+         end if
+13     CONTINUE 
+! calculation of initial hydromteors content in g/cm**3 :
+      cont_init_drop=0.
+      cont_init_ice=0.
+      do kr=1,nkr
+         cont_init_drop=cont_init_drop+g1(kr)
+         cont_init_ice=cont_init_ice+g3(kr)+g4(kr)+g5(kr)
+         do ice=1,icemax
+            cont_init_ice=cont_init_ice+g2(kr,ice)
+         enddo
+      enddo
+      cont_init_drop=col*cont_init_drop*1.e-3
+      cont_init_ice=col*cont_init_ice*1.e-3
+! calculation of alwc in g/m**3
+      alwc=cont_init_drop*1.e6
+! calculation interactions :
+! droplets - droplets and droplets - ice :
+! water-water = water
+
+      if (icol_drop.eq.1)then 
+! break-up
+
+       call coll_xxx (G1,CWLL,XL_MG,CHUCM,IMA,NKR)
+! breakup!
+       if(icol_drop_brk.eq.1)then
+       ndiv=1
+10     continue
+       do it = 1,ndiv
+         if (ndiv.gt.1024)print*,'ndiv in coal_bott_new = ',ndiv
+         if (ndiv.gt.10000) call wrf_error_fatal("fatal error in module_mp_full_sbm (ndiv.gt.10000), model stop")
+         dtbreakup = dt_coll/ndiv
+         if (it.eq.1)then
+!         do kr=1,nkr
+          do kr=1,JMAX
+           gdumb(kr)= g1(kr)*1.D-3
+           xl_dumb(kr)=xl_mg(KR)*1.D-3
+          end do
+          break_drop_bef=0.d0
+!         do kr=1,nkr
+          do kr=1,JMAX
+            break_drop_bef=break_drop_bef+g1(kr)*1.D-3
+          enddo
+         end if
+         call breakup(gdumb,xl_dumb,dtbreakup,brkweight, &
+     &        pkij,qkj,JMAX,jbreak)
+       end do
+       break_drop_aft=0.0d0
+       do kr=1,JMAX
+           break_drop_aft=break_drop_aft+gdumb(kr)
+       enddo
+       break_drop_per=break_drop_aft/break_drop_bef
+       if (break_drop_per.gt.1.001)then
+           ndiv=ndiv*2
+           GO TO 10
+       else
+           do kr=1,JMAX
+            g1(kr)=gdumb(kr)*1.D3
+           end do
+       end if
+       end if
+      end if
+       if (icol_snow.eq.1)then 
+         call coll_xyz (g1,g3,g4,cwls,xl_mg,xs_mg, &
+     &                chucm,ima,prdkrn1,nkr,0)
+         if(alwc.lt.alcr) then
+         call coll_xyx (g3,g1,cwsl,xs_mg,xl_mg, &
+     &                chucm,ima,prdkrn1,nkr,1)
+         endif
+         if(alwc.ge.alcr) then
+!        call coll_xyz (g3,g1,g4,cwsl,xs_mg,xl_mg, &
+!    &                chucm,ima,prdkrn1,nkr,1)
+            call coll_xyxz_h (g3,g1,g4,cwsl,xs_mg,xl_mg, &
+     &                chucm,ima,prdkrn1,nkr,1)
+         endif
+! in case : icolxz_snow.ne.0
+       end if
+! interactions between water and  graupel (begin)
+! water - graupel = graupel (t < tcrit ; xl_mg ge xg_mg)
+! graupel - water = graupel (t < tcrit ; xg_mg > xl_mg)
+! water - graupel = hail (t ge tcrit ; xl_mg ge xg_mg)
+! graupel - water = hail (t ge tcrit ; xg_mg > xl_mg)
+       if (icol_graupel.eq.1)then 
+! water-graupel
+! included kp_bound = 25
+         call coll_xyyz_h (g1,g4,g5,cwlg,xl_mg,xg_mg, &
+       &                chucm,ima,prdkrn1,nkr,1)
+! for ice multiplication
+          conc_old=0.
+          conc_new=0.
+          do kr=kr_icempl,nkr
+               conc_old=conc_old+col*g1(kr)/xl_mg(kr)
+          enddo
+! graupel-water
+           if(alwc.lt.alcr_g) then
+! water-graupel
+! TEST
+            call coll_xyy (g1,g4,cwlg,xl_mg,xg_mg, &
+     &               chucm,ima,prdkrn1,nkr,0)
+            call coll_xyx (g4,g1,cwgl,xg_mg,xl_mg, &
+     &          chucm,ima,prdkrn1,nkr,1)
+! TEST
+           else
+            call coll_xyxz_h (g4,g1,g5,cwgl,xg_mg,xl_mg, &
+     &                chucm,ima,prdkrn1,nkr,1)
+           end if
+! interactions between water and  graupels (end)
+
+         if(icempl.eq.1) then
+          if(tt.ge.265.15.and.tt.le.tcrit) then
+! ice-multiplication :
+            do kr=kr_icempl,nkr
+               conc_new=conc_new+col*g1(kr)/xl_mg(kr)
+            enddo
+            dconc=conc_old-conc_new
+            if(tt.le.268.15) then
+              conc_icempl=dconc*4.e-3*(265.15-tt)/(265.15-268.15)
+            endif
+            if(tt.gt.268.15) then
+             conc_icempl=dconc*4.e-3*(tcrit-tt)/(tcrit-268.15)
+            endif
+!CHANGE FOR FOUR BIN SCHEME           g2_2(1)=g2_2(1)+conc_icempl*xi2_mg(1)/col
+            g2_2(1)=g2_2(1)+conc_icempl*xi2_mg(1)/col
+!           g3(1)=g3(1)+conc_icempl*xs_mg(1)/col
+! in case t.ge.265.15 :
+          endif
+! in case icempl=1
+         endif
+! interactions between water and  graupels (end)
+! in case icolxz_graup.ne.0
+       endif
+! water - hail = hail (xl_mg ge xh_mg)                      (kxyy=2)
+! hail - water = hail (xh_mg > xl_mg)                       (kxyx=3)
+       if(icol_hail.eq.1) then
+        call coll_xyy (g1,g5,cwlh,xl_mg,xh_mg, &
+     &               chucm,ima,prdkrn1,nkr,0)
+        call coll_xyx (g5,g1,cwhl,xh_mg,xl_mg, &
+     &               chucm,ima,prdkrn1,nkr,1)
+! in case icolxz_hail.ne.0
+       endif
+! interactions between water and hail (end)
+! interactions between water and crystals :
+! interactions between water and columns :
+! water - columns = graupel (t < tcrit ; xl_mg ge xi_mg)    (kxyz=6)
+! water - columns = hail (t ge tcrit ; xl_mg ge xi_mg)      (kxyz=7)
+! columns - water = columns/graupel (xi_mg > xl_mg)             (kxyx=4); kxyxz=2)
+! now: columns - water = columns (xi_mg > xl_mg)             (kxyx=4); kxyxz=2)
+       if(icol_column.eq.1) then
+        if(tt.lt.tcrit) then
+         call coll_xyz (g1,g2_1,g4,cwli_1,xl_mg,xi1_mg, &
+     &                 chucm,ima,prdkrn,nkr,0)
+        endif
+        if(tt.ge.tcrit) then
+         call coll_xyz (g1,g2_1,g5,cwli_1,xl_mg,xi1_mg, &
+     &                 chucm,ima,prdkrn,nkr,0)
+        endif
+        call coll_xyxz (g2_1,g1,g4,cwil_1,xi1_mg,xl_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+        call coll_xyx (g2_1,g1,cwil_1,xi1_mg,xl_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+! in case icolxz_column.ne.0
+       endif
+
+!     if(icolxz_plate.ne.0) then
+! interactions between water and plates :
+! water - plates = graupel (t < tcrit ; xl_mg ge xi2_mg)    (kxyz=8)
+! water - plates = hail (t ge tcrit ; xl_mg ge xi2_mg)      (kxyz=9)
+! plates - water = plates/graupel (xi2_mg > xl_mg)              (kxyx=5; kxyxz=3)
+!now: plates - water = plates (xi2_mg > xl_mg)              (kxyx=5; kxyxz=3)
+       if(icol_plate.eq.1) then
+        if(tt.lt.tcrit) then
+         call coll_xyz (g1,g2_2,g4,cwli_2,xl_mg,xi2_mg, &
+     &                 chucm,ima,prdkrn,nkr,0)
+        endif
+        if(tt.ge.tcrit) then
+         call coll_xyz (g1,g2_2,g5,cwli_2,xl_mg,xi2_mg, &
+     &                 chucm,ima,prdkrn,nkr,0)
+        endif
+        call coll_xyxz (g2_2,g1,g4,cwil_2,xi2_mg,xl_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+        call coll_xyx (g2_2,g1,cwil_2,xi2_mg,xl_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+! in case icolxz_plate.ne.0
+       endif
+
+! interactions between water and dendrites :
+! water - dendrites = graupel (t < tcrit ; xl_mg ge xi3_mg) (kxyz=10)
+! water - dendrites = hail (t ge tcrit ; xl_mg ge xi3_mg)   (kxyz=11)
+! dendrites - water = dendrites/graupel (xi3_mg > xl_mg)         (kxyx=6; kxyxz=4)
+!now dendrites - water = dendrites (xi3_mg > xl_mg)         (kxyx=6; kxyxz=4)
+       if(icol_dendrite.eq.1) then
+        if(tt.lt.tcrit) then
+         call coll_xyz (g1,g2_3,g4,cwli_3,xl_mg,xi3_mg, &
+     &                 chucm,ima,prdkrn,nkr,0)
+        endif
+        if(tt.ge.tcrit) then
+         call coll_xyz (g1,g2_3,g5,cwli_3,xl_mg,xi3_mg, &
+     &                 chucm,ima,prdkrn,nkr,0)
+        endif
+        call coll_xyxz (g2_3,g1,g4,cwil_3,xi3_mg,xl_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+        call coll_xyx (g2_3,g1,cwil_3,xi3_mg,xl_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+! in case icolxz_dendr.ne.0
+       endif
+! interactions between water and dendrites (end)
+! in case icolxz_drop.ne.0
+!     endif
+! interactions between water and crystals (end)
+
+! interactions between crystals :
+! if(t.le.TTCOAL) - no interactions between crystals
+      if(tt.gt.TTCOAL) then
+! interactions between columns and other particles (begin)
+       if(icol_column.eq.1) then
+! columns - columns = snow
+        call coll_xxy (g2_1,g3,cwii_1_1,xi1_mg, &
+     &                 chucm,ima,prdkrn,nkr)
+! interactions between columns and plates :
+! columns - plates = snow (xi1_mg ge xi2_mg)                (kxyz=12)
+! plates - columns = snow (xi2_mg > xi1_mg)                 (kxyz=13)
+        if(icol_plate.eq.1) then     
+         call coll_xyz (g2_1,g2_2,g3,cwii_1_2,xi1_mg,xi2_mg, &
+     &                 chucm,ima,prdkrn,nkr,0)
+         call coll_xyz (g2_2,g2_1,g3,cwii_2_1,xi2_mg,xi1_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+        end if
+! interactions between columns and dendrites :
+! columns - dendrites = snow (xi1_mg ge xi3_mg)             (kxyz=14)
+! dendrites - columns = snow (xi3_mg > xi1_mg)              (kxyz=15)
+        if(icol_dendrite.eq.1) then
+           call coll_xyz (g2_1,g2_3,g3,cwii_1_3,xi1_mg,xi3_mg, &
+     &                 chucm,ima,prdkrn,nkr,0)
+           call coll_xyz (g2_3,g2_1,g3,cwii_3_1,xi3_mg,xi1_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+        end if
+! interactions between columns and snow :
+! columns - snow = snow (xi1_mg ge xs_mg)                   (kxyy=3)
+! snow - columns = snow (xs_mg > xi1_mg)                    (kxyx=7)
+! ALEX?
+        if(icol_snow.eq.1) then
+         call coll_xyy (g2_1,g3,cwis_1,xi1_mg,xs_mg, &
+     &                 chucm,ima,prdkrn,nkr,0)
+         call coll_xyx (g3,g2_1,cwsi_1,xs_mg,xi1_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+        endif          
+! in case icolxz_column.ne.0
+       endif
+! interactions between columns and other particles (end)
+! interactions between plates and other particles (begin)
+! plates - plates = snow
+       if(icol_plate.eq.1) then
+        call coll_xxy (g2_2,g3,cwii_2_2,xi2_mg, &
+     &                 chucm,ima,prdkrn,nkr)
+! interactions between plates and dendrites :
+! plates - dendrites = snow (xi2_mg ge xi3_mg)              (kxyz=17)
+! dendrites - plates = snow (xi3_mg > xi2_mg)               (kxyz=18)
+        if(icol_dendrite.eq.1) then
+         call coll_xyz (g2_2,g2_3,g3,cwii_2_3,xi2_mg,xi3_mg, &
+     &                 chucm,ima,prdkrn,nkr,0)
+         call coll_xyz (g2_3,g2_2,g3,cwii_3_2,xi3_mg,xi2_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+        end if
+! interactions between plates and snow :
+! plates - snow = snow (xi2_mg ge xs_mg)                    (kxyy=4)
+! snow - plates = snow (xs_mg > xi2_mg)                     (kxyx=12)
+        if(icol_snow.eq.1) then
+! ALEX
+         call coll_xyy (g2_2,g3,cwis_2,xi2_mg,xs_mg, &
+     &                 chucm,ima,prdkrn,nkr,0)
+          call coll_xyx (g3,g2_2,cwsi_2,xs_mg,xi2_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+         end if
+! in case icolxz_plate.ne.0
+       endif
+! interactions between plates and others particles (end)
+! interactions between dendrites and other hydrometeors (begin)
+! dendrites - dendrites = snow
+       if(icol_dendrite.eq.1) then
+         call coll_xxy (g2_3,g3,cwii_3_3,xi3_mg, &
+      &                  chucm,ima,prdkrn,nkr)
+! interactions between dendrites and snow :
+! dendrites - snow = snow (xi3_mg ge xs_mg)                 (kxyy=5)
+! snow - dendrites = snow (xs_mg > xi3_mg)                  (kxyx=17)
+        if(icol_snow.eq.1) then
+! ALEX
+         call coll_xyy (g2_3,g3,cwis_3,xi3_mg,xs_mg,  &
+     &                 chucm,ima,prdkrn,nkr,0)
+          call coll_xyx (g3,g2_3,cwsi_3,xs_mg,xi3_mg, &
+     &                 chucm,ima,prdkrn,nkr,1)
+        end if
+! in case icolxz_dendr.ne.0
+       endif
+! interactions between dendrites and other hydrometeors (end)
+! interactions between snowflakes and other hydromteors (begin)
+        if(icol_snow.ne.0) then
+! interactions between snowflakes
+! snow - snow = snow
+         call coll_xxx_prd (g3,cwss,xs_mg,chucm,ima,prdkrn,nkr)
+! interactions between snowflakes and graupels :
+! snow - graupel = snow (xs_mg > xg_mg)                     (kxyx=22)
+! graupel - snow = graupel (xg_mg ge xs_mg)                 (kxyx=23)
+         if(icol_graupel.eq.1) then
+           call coll_xyx (g3,g4,cwsg,xs_mg,xg_mg, &
+     &                chucm,ima,prdkrn,nkr,1)
+! in case icolxz_graup.ne.0
+         endif
+! in case icolxz_snow.ne.0
+        endif
+! interactions between snowflakes and other hydromteors (end)
+! in case : t > TTCOAL
+      endif
+! in case : t > TTCOAL or t.le.TTCOAL
+! calculation of finish hydrometeors contents in g/cm**3 :
+      cont_fin_drop=0.
+      cont_fin_ice=0.
+      do kr=1,nkr
+         g2(kr,1)=g2_1(kr)
+         g2(kr,2)=g2_2(kr)
+         g2(kr,3)=g2_3(kr)
+         cont_fin_drop=cont_fin_drop+g1(kr)
+         cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)+g5(kr)
+!        cont_fin_ice=cont_fin_ice+g3(kr)+g4(kr)
+         do ice=1,icemax
+            cont_fin_ice=cont_fin_ice+g2(kr,ice)
+         enddo
+      enddo
+      cont_fin_drop=col*cont_fin_drop*1.e-3
+      cont_fin_ice=col*cont_fin_ice*1.e-3
+      deldrop=cont_init_drop-cont_fin_drop
+! deldrop in g/cm**3
+! resulted value of temperature (rob in g/cm**3) :
+      if(t_new.le.273.15) then
+        if(deldrop.ge.0.) then
+          t_new=t_new+320.*deldrop/rho
+        else
+! if deldrop < 0
+          if(abs(deldrop).gt.cont_init_drop*0.05) then
+            call wrf_error_fatal("fatal error in module_mp_full_sbm (abs(deldrop).gt.cont_init_drop), model stop")
+          endif
+        endif
+       endif
+
+61    continue
+! recalculation of density function f1,f2,f3,f4,f5 in 1/(g*cm**3) :  
+        DO 15 KR=1,NKR
+         FF1R(KR)=G1(KR)/(3.*XL(KR)*XL(KR)*1.E3)
+         FF2R(KR,1)=G2(KR,1)/(3*xi(KR,1)*XI(KR,1)*1.e3)
+         FF2R(KR,2)=G2(KR,2)/(3.*xi(KR,2)*XI(KR,2)*1.e3)
+         FF2R(KR,3)=G2(KR,3)/(3.*xi(KR,3)*XI(KR,3)*1.e3)
+         FF3R(KR)=G3(KR)/(3.*xs(kr)*xs(kr)*1.e3)
+         FF4R(KR)=G4(KR)/(3.*xg(kr)*xg(kr)*1.e3)
+         FF5R(KR)=G5(KR)/(3.*xh(kr)*xh(kr)*1.e3)
+15     CONTINUE 
+      tt=t_new
+      RETURN
+      END SUBROUTINE COAL_BOTT_NEW
+      SUBROUTINE MISC1(PP,cwll_1000mb,cwll_750mb,cwll_500mb, &
+     &      cwll,nkr)
+      IMPLICIT NONE
+      INTEGER kr1,kr2,NKR
+      DOUBLE PRECISION PP
+      REAL P_Z
+      double precision cwll(nkr,nkr),cwll_1,cwll_2,cwll_3 &
+     &,cwll_1000mb(nkr,nkr),cwll_750mb(nkr,nkr),cwll_500mb(nkr,nkr)
+      P_Z=PP
+              do 12 kr1=1,nkr
+              do 12 kr2=1,nkr
+               cwll_1=cwll_1000mb(kr1,kr2)
+               cwll_2=cwll_750mb(kr1,kr2)
+               cwll_3=cwll_500mb(kr1,kr2)
+               if(p_z.ge.p1) cwll(kr1,kr2)=cwll_1
+               if(p_z.eq.p2) cwll(kr1,kr2)=cwll_2
+               if(p_z.eq.p3) cwll(kr1,kr2)=cwll_3
+               if(p_z.lt.p1.and.p_z.gt.p2) &
+     &         cwll(kr1,kr2)=cwll_2+ &
+     &         (cwll_1-cwll_2)*(p_z-p2)/(p1-p2) 
+               if(p_z.lt.p2.and.p_z.gt.p3) &
+     &         cwll(kr1,kr2)=cwll_3+ &
+     &         (cwll_2-cwll_3)*(p_z-p3)/(p2-p3)
+               if(p_z.lt.p3) cwll(kr1,kr2)=cwll_3
+12            CONTINUE 
+      RETURN
+      END SUBROUTINE  MISC1
+
+        subroutine coll_xxx (g,ckxx,x,chucm,ima,nkr)
+        implicit double precision (a-h,o-z)
+        dimension g(nkr),ckxx(nkr,nkr),x(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+!       gmin=1.d-15
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(g(i).gt.gmin) goto 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(g(i).gt.gmin) goto 2010
+        enddo
+ 2010   continue
+! J. Dudhia gave reasons why this can't be looped with a
+! multiprocessor.
+! BARRY
+!       do i=ix0,ix1
+!          do j=i,ix1
+        do i=ix0,ix1-1
+           do j=i+1,ix1
+
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxx(i,j)*g(i)*g(j)
+              x0=min(x0,g(i)*x(j))
+              if(j.ne.k) then
+                x0=min(x0,g(j)*x(i))
+              endif
+              gsi=x0/x(j)
+              gsj=x0/x(i)
+              gsk=gsi+gsj
+              g(i)=g(i)-gsi
+              if(g(i).lt.0.d0) g(i)=0.d0
+              g(j)=g(j)-gsj
+              gk=g(k)+gsk
+              if(g(j).lt.0.d0.and.gk.lt.gmin) then
+                g(j)=0.d0
+                g(k)=g(k)+gsi
+              endif
+              flux=0.d0
+!
+! BARRY
+              if(gk.gt.gmin) then
+                x1=dlog(g(kp)/gk+1.d-15)
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+
+! new changes 23.01.01 (end)
+                g(k)=gk-flux
+                if(g(k).lt.0.d0) g(k)=0.d0
+                g(kp)=g(kp)+flux
+! in case gk > gmin :
+              endif
+            end do
+        end do
+ 2020   continue
+        return
+        end subroutine coll_xxx
+        subroutine coll_xxx_prd (g,ckxx,x,chucm,ima,prdkrn,nkr)
+        implicit double precision (a-h,o-z)
+        dimension g(nkr),ckxx(nkr,nkr),x(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+! this is character values containes adresses of temporary files      
+        gmin=1.d-60
+!       gmin=1.d-15
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(g(i).gt.gmin) goto 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(g(i).gt.gmin) goto 2010
+        enddo
+ 2010   continue
+! J. Dudhia gave reasons why this can't be looped with a
+! multiprocessor.
+! BARRY
+!       do i=ix0,ix1
+!          do j=i,ix1
+        do i=ix0,ix1-1
+           do j=i+1,ix1
+
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxx(i,j)*g(i)*g(j)*prdkrn
+              x0=min(x0,g(i)*x(j))
+              if(j.ne.k) then
+                x0=min(x0,g(j)*x(i))
+              endif
+              gsi=x0/x(j)
+              gsj=x0/x(i)
+              gsk=gsi+gsj
+              g(i)=g(i)-gsi
+              if(g(i).lt.0.d0) g(i)=0.d0
+              g(j)=g(j)-gsj
+              gk=g(k)+gsk
+              if(g(j).lt.0.d0.and.gk.lt.gmin) then
+                g(j)=0.d0
+                g(k)=g(k)+gsi
+              endif
+              flux=0.d0
+!
+! BARRY
+              if(gk.gt.gmin) then
+                x1=dlog(g(kp)/gk+1.d-15)
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+
+! new changes 23.01.01 (end)
+                g(k)=gk-flux
+                if(g(k).lt.0.d0) g(k)=0.d0
+                g(kp)=g(kp)+flux
+! in case gk > gmin :
+              endif
+            end do
+        end do
+ 2020   continue
+        return
+        end subroutine coll_xxx_prd 
+      subroutine modkrn(TT,QQ,PP,PRDKRN,TTCOAL)
+      implicit none
+      real epsf,tc,ttt1,ttt,factor,qs2,qq1,dele,f,factor_t
+      double precision TT,QQ,PP,satq2,t,p
+      double precision prdkrn
+      REAL at,bt,ct,dt,temp,a,b,c,d,tc_min,tc_max
+       real factor_max,factor_min
+      REAL TTCOAL
+	data at,bt,ct,dt/0.88333,0.0931878,0.0034793,4.5185186e-05/
+        satq2(t,p)=3.80e3*(10**(9.76421-2667.1/t))/p
+        temp(a,b,c,d,tc)=d*tc*tc*tc+c*tc*tc+b*tc+a
+        IF (QQ.LE.0)QQ=1.E-12
+        epsf    =.5
+        tc      =tt-273.15
+        factor=1  !mchen add 
+        if(tc.le.0) then
+! in case tc.le.0
+          ttt1  =temp(at,bt,ct,dt,tc)
+          ttt   =ttt1
+          qs2   =satq2(tt,pp)
+          qq1   =qq*(0.622+0.378*qs2)/(0.622+0.378*qq)/qs2
+          dele  =ttt*qq1
+! new change 27.06.00
+          if(tc.ge.-6.) then
+            factor = dele
+            if(factor.lt.epsf) factor=epsf
+            if(factor.gt.1.) factor=1.
+! in case : tc.ge.-6.
+          endif                        
+          factor_t=factor
+          if(tc.ge.-12.5.and.tc.lt.-6.) factor_t=0.5
+          if(tc.ge.-17.0.and.tc.lt.-12.5) factor_t=1.
+          if(tc.ge.-20.0.and.tc.lt.-17.) factor_t=0.4
+          if(tc.lt.-20.) then
+            tc_min=ttcoal-273.15
+            tc_max=-20.
+            factor_max=0.25
+            factor_min=0.
+            f=factor_min+(tc-tc_min)*(factor_max-factor_min)/  &
+     &                               (tc_max-tc_min)
+            factor_t=f
+          endif
+! BARRY
+          if (factor_t.lt.0)factor_t=0.01
+          prdkrn=factor_t
+      else
+          prdkrn=1.d0
+      end if
+      RETURN
+      END SUBROUTINE modkrn 
+           
+
+
+        subroutine coll_xxy(gx,gy,ckxx,x,chucm,ima,prdkrn,nkr)
+        implicit double precision (a-h,o-z)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        dimension  &
+     &  gx(nkr),gy(nkr),ckxx(nkr,nkr),x(0:nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) goto 2000
+        enddo
+        if(ix0.eq.nkr-1) goto 2020
+ 2000   continue
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) goto 2010
+        enddo
+ 2010   continue
+! collisions
+        do i=ix0,ix1
+           do j=i,ix1
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxx(i,j)*gx(i)*gx(j)*prdkrn
+              x0=min(x0,gx(i)*x(j))
+              x0=min(x0,gx(j)*x(i))
+              gsi=x0/x(j)
+              gsj=x0/x(i)
+              gsk=gsi+gsj
+              gx(i)=gx(i)-gsi
+              if(gx(i).lt.0.d0) gx(i)=0.d0
+              gx(j)=gx(j)-gsj
+              if(gx(j).lt.0.d0) gx(j)=0.d0
+              gk=gy(k)+gsk
+              flux=0.d0
+! BARRY
+              if(gk.gt.gmin) then
+! new changes 13.01.01 (begin)
+                x1=dlog(gy(kp)/gk+1.d-15)
+! BARRY
+!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+! new changes 23.01.01 (begin)
+!               flux=min(flux,gk)
+!               flux=min(flux,gsk)
+! new changes 23.01.01 (end)
+! new changes 13.01.01 (end)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+                gy(k)=gk-flux
+                if(gy(k).lt.0.d0) gy(k)=0.d0
+                gy(kp)=gy(kp)+flux
+! in case gk > gmin :
+              endif
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xxy
+!====================================================================
+        subroutine coll_xyy(gx,gy,ckxy,x,y,chucm,ima, &
+     &     prdkrn,nkr,indc)
+        implicit double precision (a-h,o-z)
+        dimension  &
+     &  gy(nkr),gx(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) go to 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) go to 2010
+        enddo
+ 2010   continue
+! lower and upper integration limit iy0,iy1
+        do i=1,nkr-1
+           iy0=i
+           if(gy(i).gt.gmin) go to 2001
+        enddo
+ 2001   continue
+        if(iy0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           iy1=i
+           if(gy(i).gt.gmin) go to 2011
+        enddo
+ 2011   continue
+! collisions :
+        do i=iy0,iy1
+           jmin=i
+           if(jmin.eq.(nkr-1)) goto 2020
+           if(i.lt.ix0) jmin=ix0-indc
+	   do j=jmin+indc,ix1         
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
+              x0=min(x0,gy(i)*x(j))
+              x0=min(x0,gx(j)*y(i))
+              gsi=x0/x(j)
+              gsj=x0/y(i)
+              gsk=gsi+gsj
+              gy(i)=gy(i)-gsi
+              if(gy(i).lt.0.d0) gy(i)=0.d0
+              gx(j)=gx(j)-gsj
+              if(gx(j).lt.0.d0) gx(j)=0.d0
+              gk=gy(k)+gsk
+              flux=0.d0
+! BARRY
+              if(gk.gt.gmin) then
+                x1=dlog(gy(kp)/gk+1.d-15)
+! BARRY
+!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+! new changes 23.01.01 (begin)
+!               flux=min(flux,gk)
+!               flux=min(flux,gsk)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+! new changes 23.01.01 (end)
+                gy(k)=gk-flux
+                if(gy(k).lt.0.d0) gy(k)=0.d0
+                gy(kp)=gy(kp)+flux
+! in case gk > gmin :
+              endif
+! in case gk > gmin or gk.le.gmin
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xyy
+!=================================================================
+        subroutine coll_xyx(gx,gy,ckxy,x,y,chucm,ima, &
+     &    prdkrn,nkr,indc)
+        implicit double precision (a-h,o-z)
+        dimension gy(nkr),gx(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) go to 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) go to 2010
+        enddo
+ 2010   continue
+! lower and upper integration limit iy0,iy1
+        do i=1,nkr-1
+           iy0=i
+           if(gy(i).gt.gmin) go to 2001
+        enddo
+ 2001   continue
+        if(iy0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           iy1=i
+           if(gy(i).gt.gmin) go to 2011
+        enddo
+ 2011   continue
+! collisions :
+        do i=iy0,iy1
+           jmin=i
+           if(jmin.eq.(nkr-1)) goto 2020
+           if(i.lt.ix0) jmin=ix0-indc
+	   do j=jmin+indc,ix1
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
+              x0=min(x0,gy(i)*x(j))
+              if(j.ne.k) then
+                x0=min(x0,gx(j)*y(i))
+              endif
+              gsi=x0/x(j)
+              gsj=x0/y(i)
+              gsk=gsi+gsj
+              gy(i)=gy(i)-gsi
+              if(gy(i).lt.0.d0) gy(i)=0.d0
+              gx(j)=gx(j)-gsj
+              gk=gx(k)+gsk
+! BARRY
+!             if(gx(j).lt.0.d0)then
+!                gy(i)=gy(i)+gsi
+!                gx(j)=gx(j)+gsj
+!                go to 10
+!             end if
+              if(gx(j).lt.0.d0.and.gk.lt.gmin) then
+                gx(j)=0.d0
+                gx(k)=gx(k)+gsi
+              endif
+              flux=0.d0            
+! BARRY
+              if(gk.gt.gmin) then
+                x1=dlog(gx(kp)/gk+1.d-15)
+! BARRY
+!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+! new changes 23.01.01 (begin)
+!               flux=min(flux,gk)
+!               flux=min(flux,gsk)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+! new changes 23.01.01 (end)
+                gx(k)=gk-flux
+                if(gx(k).lt.0.d0) gx(k)=0.d0
+                gx(kp)=gx(kp)+flux
+! in case gk > gmin :
+              endif
+! in case gk > gmin or gk.le.gmin
+! BARRY
+10         continue
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xyx
+!=====================================================================
+        subroutine coll_xyxz(gx,gy,gz,ckxy,x,y,chucm,ima, &
+     &    prdkrn,nkr,indc)
+        implicit double precision (a-h,o-z)
+      dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) go to 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) go to 2010
+        enddo
+ 2010   continue
+! lower and upper integration limit iy0,iy1
+        do i=1,nkr-1
+           iy0=i
+           if(gy(i).gt.gmin) go to 2001
+        enddo
+ 2001   continue
+        if(iy0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           iy1=i
+           if(gy(i).gt.gmin) go to 2011
+        enddo
+ 2011   continue
+! collisions :
+        do i=iy0,iy1
+           jmin=i
+           if(jmin.eq.(nkr-1)) goto 2020
+           if(i.lt.ix0) jmin=ix0-indc
+	   do j=jmin+indc,ix1
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
+              x0=min(x0,gy(i)*x(j))
+              if(j.ne.k) then
+                x0=min(x0,gx(j)*y(i))
+              endif
+              gsi=x0/x(j)
+              gsj=x0/y(i)
+              gsk=gsi+gsj
+              gy(i)=gy(i)-gsi
+              if(gy(i).lt.0.d0) gy(i)=0.d0
+              gx(j)=gx(j)-gsj
+              gk=gx(k)+gsk
+              if(gx(j).lt.0.d0.and.gk.lt.gmin) then
+                gx(j)=0.d0
+                gx(k)=gx(k)+gsi
+              endif
+              flux=0.d0
+! BARRY
+              if(kp.lt.17) gkp=gx(kp)
+              if(kp.ge.17) gkp=gz(kp)
+              if(gk.gt.gmin) then
+                x1=dlog(gkp/gk+1.d-15)
+! BARRY
+!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+! new changes 23.01.01 (begin)
+!               flux=min(flux,gk)
+!               flux=min(flux,gsk)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+! new changes 23.01.01 (end)
+                gx(k)=gk-flux
+                if(gx(k).lt.0.d0) gx(k)=0.d0
+                if(kp.lt.17) gx(kp)=gkp+flux
+                if(kp.ge.17) gz(kp)=gkp+flux
+! ALEX 15 11 2005
+!               if(kp.ge.17) gx(kp)=gkp+flux
+! in case gk > gmin :
+              endif
+! in case gk > gmin or gk.le.gmin
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xyxz
+!=====================================================================
+        subroutine coll_xyxz_h(gx,gy,gz,ckxy,x,y,chucm,ima, &
+     &    prdkrn,nkr,indc)
+        implicit double precision (a-h,o-z)
+      dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) go to 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) go to 2010
+        enddo
+ 2010   continue
+! lower and upper integration limit iy0,iy1
+        do i=1,nkr-1
+           iy0=i
+           if(gy(i).gt.gmin) go to 2001
+        enddo
+ 2001   continue
+        if(iy0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           iy1=i
+           if(gy(i).gt.gmin) go to 2011
+        enddo
+ 2011   continue
+! collisions :
+        do i=iy0,iy1
+           jmin=i
+           if(jmin.eq.(nkr-1)) goto 2020
+           if(i.lt.ix0) jmin=ix0-indc
+	   do j=jmin+indc,ix1
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
+              x0=min(x0,gy(i)*x(j))
+              if(j.ne.k) then
+                x0=min(x0,gx(j)*y(i))
+              endif
+              gsi=x0/x(j)
+              gsj=x0/y(i)
+              gsk=gsi+gsj
+              gy(i)=gy(i)-gsi
+              if(gy(i).lt.0.d0) gy(i)=0.d0
+              gx(j)=gx(j)-gsj
+              gk=gx(k)+gsk
+              if(gx(j).lt.0.d0.and.gk.lt.gmin) then
+                gx(j)=0.d0
+                gx(k)=gx(k)+gsi
+              endif
+              flux=0.d0
+! BARRY
+              if(kp.lt.22) gkp=gx(kp)
+              if(kp.ge.22) gkp=gz(kp)
+              if(gk.gt.gmin) then
+                x1=dlog(gkp/gk+1.d-15)
+! BARRY
+!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+! new changes 23.01.01 (begin)
+!               flux=min(flux,gk)
+!               flux=min(flux,gsk)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+! new changes 23.01.01 (end)
+                gx(k)=gk-flux
+                if(gx(k).lt.0.d0) gx(k)=0.d0
+                if(kp.lt.22) gx(kp)=gkp+flux
+                if(kp.ge.22) gz(kp)=gkp+flux
+! ALEX 15 11 2005
+!               if(kp.ge.25) gx(kp)=gkp+flux
+! in case gk > gmin :
+              endif
+! in case gk > gmin or gk.le.gmin
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xyxz_h
+!=====================================================================
+        subroutine coll_xyz(gx,gy,gz,ckxy,x,y,chucm,ima, &
+     &                      prdkrn,nkr,indc)
+        implicit double precision (a-h,o-z)
+      dimension gx(nkr),gy(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) go to 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) go to 2010
+        enddo
+ 2010   continue
+! lower and upper integration limit iy0,iy1
+        do i=1,nkr-1
+           iy0=i
+           if(gy(i).gt.gmin) go to 2001
+        enddo
+ 2001   continue
+        if(iy0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           iy1=i
+           if(gy(i).gt.gmin) go to 2011
+        enddo
+ 2011   continue
+! collisions :
+        do i=iy0,iy1
+           jmin=i
+           if(jmin.eq.(nkr-1)) goto 2020
+           if(i.lt.ix0) jmin=ix0-indc
+	   do j=jmin+indc,ix1         
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
+              x0=min(x0,gy(i)*x(j))
+              x0=min(x0,gx(j)*y(i))
+              gsi=x0/x(j)
+              gsj=x0/y(i)
+              gsk=gsi+gsj
+              gy(i)=gy(i)-gsi
+              if(gy(i).lt.0.d0) gy(i)=0.d0
+              gx(j)=gx(j)-gsj
+              if(gx(j).lt.0.d0) gx(j)=0.d0
+              gk=gz(k)+gsk
+              flux=0.d0
+! BARRY
+              if(gk.gt.gmin) then
+                x1=dlog(gz(kp)/gk+1.d-15)
+! BARRY
+               if (x1.eq.0)then
+                flux=0  
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+! new changes 23.01.01 (end)
+                gz(k)=gk-flux
+                if(gz(k).lt.0.d0) gz(k)=0.d0
+                gz(kp)=gz(kp)+flux
+! in case gk > gmin :
+              endif
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xyz
+
+        subroutine coll_xyyz_h(gx,gy,gz,ckxy,x,y,chucm,ima, &
+     &    prdkrn,nkr,indc)
+        implicit double precision (a-h,o-z)
+      dimension gy(nkr),gx(nkr),gz(nkr),ckxy(nkr,nkr),x(0:nkr),y(0:nkr)
+        dimension chucm(nkr,nkr)
+        double precision ima(nkr,nkr)
+        gmin=1.d-60
+! lower and upper integration limit ix0,ix1
+        do i=1,nkr-1
+           ix0=i
+           if(gx(i).gt.gmin) go to 2000
+        enddo
+ 2000   continue
+        if(ix0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           ix1=i
+           if(gx(i).gt.gmin) go to 2010
+        enddo
+ 2010   continue
+! lower and upper integration limit iy0,iy1
+        do i=1,nkr-1
+           iy0=i
+           if(gy(i).gt.gmin) go to 2001
+        enddo
+ 2001   continue
+        if(iy0.eq.nkr-1) goto 2020
+        do i=nkr-1,1,-1
+           iy1=i
+           if(gy(i).gt.gmin) go to 2011
+        enddo
+ 2011   continue
+! collisions :
+        do i=iy0,iy1
+           jmin=i
+           if(jmin.eq.(nkr-1)) goto 2020
+           if(i.lt.ix0) jmin=ix0-indc
+           do j=jmin+indc,ix1
+              k=ima(i,j)
+              kp=k+1
+              x0=ckxy(j,i)*gy(i)*gx(j)*prdkrn
+              x0=min(x0,gy(i)*x(j))
+              if(j.ne.k) then
+                x0=min(x0,gx(j)*y(i))
+              endif
+              gsi=x0/x(j)
+              gsj=x0/y(i)
+              gsk=gsi+gsj
+              gy(i)=gy(i)-gsi
+              if(gy(i).lt.0.d0) gy(i)=0.d0
+              gx(j)=gx(j)-gsj
+              gk=gx(k)+gsk
+              if(gx(j).lt.0.d0.and.gk.lt.gmin) then
+                gx(j)=0.d0
+                gx(k)=gx(k)+gsi
+              endif
+              flux=0.d0
+! BARRY
+              if(kp.lt.25) gkp=gy(kp)
+              if(kp.ge.25) gkp=gz(kp)
+              if(gk.gt.gmin) then
+                x1=dlog(gkp/gk+1.d-15)
+! BARRY
+!               flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+! new changes 23.01.01 (begin)
+!               flux=min(flux,gk)
+!               flux=min(flux,gsk)
+! BARRY
+               if (x1.eq.0)then
+                flux=0
+               else
+                flux=gsk/x1*(dexp(0.5*x1)-dexp(x1*(0.5-chucm(i,j))))
+                flux=min(flux,gsk)
+               end if
+! new changes 23.01.01 (end)
+                gx(k)=gk-flux
+                if(gx(k).lt.0.d0) gx(k)=0.d0
+                if(kp.lt.25) gy(kp)=gkp+flux
+                if(kp.ge.25) gz(kp)=gkp+flux
+! ALEX 15 11 2005
+!               if(kp.ge.25) gx(kp)=gkp+flux
+! in case gk > gmin :
+              endif
+! in case gk > gmin or gk.le.gmin
+           enddo
+        enddo
+ 2020   continue
+        return
+        end subroutine coll_xyyz_h
+!===============================================================
+!****************************************************************
+! SEE /include/microhucm.incl for setting of krdrop and krbreak
+!****************************************************************
+      SUBROUTINE BREAKUP(GT_MG,XT_MG,DT,BRKWEIGHT, &
+     &           PKIJ,QKJ,JMAX,JBREAK)
+!     SUBROUTINE BREAKUP(GT_MG,DT,JMAX,JBREAK)
+!     implicit double precision (a-h,o-z)
+
+!.....INPUT VARIABLES
+!
+!     GT    : MASS DISTRIBUTION FUNCTION
+!     XT_MG : MASS OF BIN IN MG
+!     JMAX  : NUMBER OF BINS
+!     DT    : TIMESTEP IN S
+
+      INTEGER JMAX
+
+!.....LOCAL VARIABLES
+
+      LOGICAL LTHAN
+      INTEGER JBREAK,AP,IA,JA,KA,IE,JE,KE
+      DOUBLE PRECISION EPS,NEGSUM
+
+      PARAMETER (AP = 1)
+      PARAMETER (IA = 1)
+      PARAMETER (JA = 1)
+      PARAMETER (KA = 1)
+      PARAMETER (EPS = 1.D-20)
+
+      INTEGER I,J,K,JJ,JDIFF
+      DOUBLE PRECISION GT_MG(JMAX),XT_MG(0:JMAX),DT
+!     xl_mg(0:nkr)
+      DOUBLE PRECISION BRKWEIGHT(JBREAK),PKIJ(JBREAK,JBREAK,JBREAK), &
+     &    QKJ(JBREAK,JBREAK)
+      DOUBLE PRECISION D0,ALM,HLP(JMAX)
+      DOUBLE PRECISION FT(JMAX),FA(JMAX)
+      DOUBLE PRECISION DG(JMAX),DF(JMAX),DBREAK(JBREAK),GAIN,LOSS
+      REAL PI
+      PARAMETER (PI = 3.1415927)
+      INTEGER IP,KP,JP,KQ,JQ
+      IE = JBREAK
+      JE = JBREAK
+      KE = JBREAK
+
+
+
+
+
+
+
+!.....IN CGS
+
+!     DO J=1,JMAX
+!        XT(J) = XT_MG(J) * 1E-3
+!        GT_MG(J) = GT_MG(J)* 1E-3
+!     ENDDO
+
+!.....SHIFT BETWEEN COAGULATION AND BREAKUP GRID
+
+      JDIFF = JMAX - JBREAK
+!       14  =  33  - 19
+
+!.....INITIALIZATION
+
+!.....TRANSFORMATION FROM G(LN X) = X**2 F(X) TO F(X)
+      DO J=1,JMAX
+         FT(J) = GT_MG(J) / XT_MG(J)**2
+      ENDDO
+
+!.....SHIFT TO BREAKUP GRID
+
+      DO K=1,KE
+         FA(K) = FT(K+JDIFF)
+      ENDDO
+
+!.....BREAKUP: BLECK'S FIRST ORDER METHOD
+!
+!     PKIJ: GAIN COEFFICIENTS
+!     QKJ : LOSS COEFFICIENTS
+!
+
+      DO K=1,KE
+         GAIN = 0.0
+         DO I=1,IE
+            DO J=1,I
+               GAIN = GAIN + FA(I)*FA(J)*PKIJ(K,I,J)
+            ENDDO
+         ENDDO
+         LOSS = 0.0
+         DO J=1,JE
+            LOSS = LOSS + FA(J)*QKJ(K,J)
+         ENDDO
+         DBREAK(K) = BRKWEIGHT(K) * (GAIN - FA(K)*LOSS)
+      ENDDO
+
+!.....SHIFT RATE TO COAGULATION GRID
+
+      DO J=1,JDIFF
+         DF(J) = 0.0
+      ENDDO
+      DO J=1,KE
+         DF(J+JDIFF) = DBREAK(J)
+      ENDDO
+!.....TRANSFORMATION TO MASS DISTRIBUTION FUNCTION G(LN X)
+
+      DO J=1,JMAX
+         DG(J) = DF(J) * XT_MG(J)**2
+      ENDDO
+
+!.....TIME INTEGRATION
+
+      DO J=1,JMAX
+      HLP(J) = 0.0
+      NEGSUM = 0.0
+         GT_MG(J) = GT_MG(J) + DG(J) * DT
+         IF (GT_MG(J).LT.0) THEN
+            HLP(J) = MIN(GT_MG(J),HLP(J))
+            GT_MG(J) = EPS
+!           NEGSUM = NEGSUM+GT_MG(J)
+!           GT_MG(J) = 0.D0
+         ENDIF
+      ENDDO
+!     DO J=1,JMAX
+!      IF (HLP(J).LT.0.) THEN
+!        GT_MG(J-1)=GT_MG(J-1)-NEGSUM -EPS
+!      END IF
+!      GO TO 10
+!     END DO
+!10    CONTINUE
+!     IF (HLP.LT.-1E-7) THEN
+! BARRY
+!     LTHAN=.FALSE.
+!     DO J=1,JMAX
+!      IF (HLP(J).LT.0.OR.LTHAN) THEN
+!        WRITE (*,'(1X,A,E10.4)')
+!    F        'COLL_BREAKUP: WARNING! G(J) < 0, MIN = ' 
+!        IF(HLP(J).LT.0.OR.LTHAN)WRITE(6,*)
+!    F      'J,G(J)  = ',J,HLP(J),GT_MG(J)
+!        LTHAN=.TRUE.  C     ENDIF
+!     END DO
+
+!     DO J=1,JMAX
+!        GT_MG(J) = GT_MG(J) * 1E3
+!     ENDDO
+
+!.....THAT'S IT
+      RETURN
+
+      END SUBROUTINE BREAKUP
+
+      SUBROUTINE BOUNDNUM(MASSMM5,FCONC,RHOX,COL,NZERO, &
+     &       RADXX,MASSXX,HYDROSUM, &
+     &       NKR)
+      IMPLICIT NONE
+     
+      INTEGER NKR,NKRI,KRBEG,KREND,IP,IPCNT
+      REAL NZERO,LAMBDAHYD,MASSMM5,RHOX,HYDROMASS,COL
+      REAL RADXX(NKR),MASSXX(NKR)
+      REAL TERM1,TERM2A,TERM2B,TERM2C
+      REAL FCONC(NKR),HYDROSUM 
+      DOUBLE PRECISION D1,D2,D3,D4,D5,D6,D7A,D7B 
+      DOUBLE PRECISION VAR1,VAR2,VAR3,VAR4,VAR5,VAR6
+!     HYDROMASS IN kg/kg
+!     VAR1=NZERO           
+!     VAR2=RHOX            
+!     VAR3=MASSXX(1,IHYDR)
+!     VAR4=RADXX(1,IHYDR)
+!     VAR5=MASSMM5       
+!     VAR6=(6.*VAR1/VAR2)*VAR3/(8.*VAR4**3)*(1./VAR5)
+!     var6 =sqrt(sqrt(var6))
+!     print*,'radxx(1) = ',RADXX(1)
+!     print*,'rhox = ',rhox
+!     print*,'massmm5 = ',massmm5
+!     print*,'nzero = ',nzerO
+!     print*,'massxx = ',MASSXX(1)
+      LAMBDAHYD=(6.*NZERO/RHOX)*MASSXX(1)/(8.*RADXX(1)**3) &
+     &     *(1./MASSMM5)
+      LAMBDAHYD=SQRT(SQRT(LAMBDAHYD))
+      HYDROSUM  =0
+      TERM1=(NZERO/RHOX)*(MASSXX(1)/(8.*RADXX(1)**3))
+      DO NKRI=1,NKR
+       IF(NKRI.EQ.1)THEN
+        D1=LAMBDAHYD*2.*RADXX(NKRI)
+        D2=0
+       ELSE
+        D1=LAMBDAHYD*2.*RADXX(NKRI)
+        D2=LAMBDAHYD*2.*RADXX(NKRI-1)
+       END IF
+       D3=DEXP(-D1)
+       D4=DEXP(-D2)
+       D5 = (1./LAMBDAHYD**4)
+       D6=TERM1
+       IF (NKRI.EQ.1)THEN
+        D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
+        D7B=-6.*D5
+       ELSE
+        D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
+        D7B= -D5*D4*(D2**3+3.*D2**2+6.*D2+6)
+       END IF
+       HYDROMASS= D6*(D7A-D7B)
+       HYDROSUM=HYDROSUM+HYDROMASS   
+       FCONC(NKRI)=HYDROMASS*RHOX/(COL  &
+     &          *MASSXX(NKRI)*MASSXX(NKRI)*3)
+        IF (HYDROMASS .LT.0)THEN
+        call wrf_error_fatal("fatal error in module_mp_full_sbm (HYDROMASS.LT.0), model stop")
+        END IF
+      END DO
+!     print*, 'massmm5,hydrosum  =',massmm5,hydrosum  
+      IF (HYDROSUM.LT.MASSMM5)THEN
+       D1=LAMBDAHYD*2.*RADXX(NKR)
+       D2=LAMBDAHYD*2.*RADXX(NKR-1)
+       D3=DEXP(-D1)
+       D4=DEXP(-D2)
+       D5 = (1./LAMBDAHYD**4)
+       D6=TERM1
+       D7A= -D5*D3*(D1**3+3.*D1**2+6.*D1+6)
+       D7B= -D5*D4*(D2**3+3.*D2**2+6.*D2+6)
+       HYDROMASS= D6*(D7A-D7B)+(MASSMM5-HYDROSUM)
+       FCONC(NKR)=HYDROMASS*RHOX/(COL &
+     &          *MASSXX(NKR)*MASSXX(NKR)*3)
+       HYDROSUM=HYDROSUM+(MASSMM5-HYDROSUM)
+      END IF
+!     print*, 'massmm5,hydrosum adj  =',massmm5,hydrosum  
+      RETURN
+      END SUBROUTINE BOUNDNUM
+! NEW (OLD) MELTING CODE
+!====================================================================
+! Version of 23.08.04 
+
+SUBROUTINE MELTING &
+
+(ihucm_flag &
+
+,FF1,XL,VTL &
+,FF2,XI,V2,VTC,FLIQFR_I,RHO_I &
+,FF3,XS,V3,VTS,FLIQFR_S,RHO_S &
+,FF4,XG,V4,VTG,FLIQFR_G,RHO_G &
+,FF5,XH,V5,VTH,FLIQFR_H,RHO_H &
+,XI_MELT,XS_MELT,XG_MELT,XH_MELT &
+,TIN,rhoa,pres,DT,QQV)
+
+!===============================================!
+! EXPLICIT MELTING SCHEME                       !
+! Author: Vaughan T.J. PHILLIPS, August 2004    !
+! at Princeton University (AOS program)         !
+! and GFDL, NOAA/OAR, USA                       !
+!===============================================!
+
+implicit double precision (a-h,o-z)
+
+! new change 27.03.07                                         (start)
+
+!PARAMETER(NKR=33, NK=129, ICEMAX=3)
+
+! new change 27.03.07                                           (end)
+
+! new change 12.02.07                                         (start)
+
+PARAMETER(CP=1004.7D0, RV=461.51D0, RD=287.039D0, &
+          EPS=RD/RV, FJOULES_IN_A_CAL=4.187D0, PI=3.141592654D0, &
+          AR_LIM=2.D0, GRAV=9.8D0, RHO_ICE=920.D0, &
+          RHO_WATER=1000.D0, FLIQFRAC_LIM=0.9D0, &
+          PETIT_PARAMETRE=1.D-10)
+PARAMETER (ivt_G_H_interpol=0)
+
+! new change 12.02.07                                           (end)
+
+! new change 12.02.07                                         (start)
+
+PARAMETER(ISHEDDING_ON=1, IVT_ADJUST=1, IPRINTING=0, &
+          ITEMP_ADJUST=1, IEVAP_ADJUST=1, ISUBLIME_ADJUST=1)
+
+! new change 12.02.07                                           (end)
+
+! control in main program & others subroutines
+
+
+! new change 29.10.08                                         (start)           
+
+
+! new change 29.10.08                                           (end)
+
+
+
+
+DIMENSION FF1(NKR), XL(NKR), VTL(NKR)
+
+DIMENSION FF2(NKR,ICEMAX),XI(NKR,ICEMAX),V2(NKR,ICEMAX), &
+          VTC(NKR,ICEMAX),FLIQFR_I(NKR,ICEMAX),RHO_I(NKR,ICEMAX)
+
+DIMENSION FF3(NKR),XS(NKR),V3(NKR), &
+          VTS(NKR),FLIQFR_S(NKR),RHO_S(NKR)
+
+DIMENSION FF4(NKR),XG(NKR),V4(NKR), &
+          VTG(NKR),FLIQFR_G(NKR),RHO_G(NKR)
+
+DIMENSION FF5(NKR),XH(NKR),V5(NKR), &
+          VTH(NKR),FLIQFR_H(NKR),RHO_H(NKR)
+
+DIMENSION FF1_SI(NKR), XL_SI(NKR), VTL_SI(NKR)
+
+DIMENSION FF2_SI(NKR,ICEMAX),XI_SI(NKR,ICEMAX),V2_SI(NKR,ICEMAX), &
+          VTC_SI(NKR,ICEMAX),RHO_I_SI(NKR,ICEMAX)
+
+DIMENSION FF3_SI(NKR),XS_SI(NKR),V3_SI(NKR), &
+          VTS_SI(NKR), RHO_S_SI(NKR)
+	  
+DIMENSION FF4_SI(NKR),XG_SI(NKR),V4_SI(NKR), &
+          VTG_SI(NKR), RHO_G_SI(NKR)
+
+DIMENSION FF5_SI(NKR),XH_SI(NKR),V5_SI(NKR), &
+          VTH_SI(NKR), RHO_H_SI(NKR)
+DIMENSION &
+XI_MELT(NKR,ICEMAX),XS_MELT(NKR),XG_MELT(NKR),XH_MELT(NKR)
+
+DIMENSION &
+XI_MELT_SI(NKR,ICEMAX),XS_MELT_SI(NKR),XG_MELT_SI(NKR),XH_MELT_SI(NKR)
+
+INTRINSIC SUM
+
+If(TIN <= 273.15D0) then
+  RETURN
+ENDIF
+
+if(SUM(FF2) <= 0.D0.and.SUM(FF3) <= 0.D0.and.SUM(FF4) <= 0.D0.and. &
+SUM(FF5) <= 0.D0) then
+  return
+endif
+
+!=============================================================
+!       UNIT CONVERSION OF ALL INPUTS to SI
+!=============================================================
+
+if(ihucm_flag == 1) then
+
+RHO_I_SI = RHO_I*1000.D0
+RHO_S_SI = RHO_S*1000.D0
+RHO_G_SI = RHO_G*1000.D0
+RHO_H_SI = RHO_H*1000.D0
+
+XL_SI = XL/1000.D0
+XI_SI = XI/1000.D0
+XS_SI = XS/1000.D0
+XG_SI = XG/1000.D0
+XH_SI = XH/1000.D0
+
+XI_MELT_SI = XI_SI
+XS_MELT_SI = XS_SI
+XG_MELT_SI = XG_SI
+XH_MELT_SI = XH_SI
+
+VTL_SI = VTL/100.D0
+VTC_SI = VTC/100.D0
+VTS_SI = VTS/100.D0
+!do kr=1,nkr
+! print*,'vts within = ',vts(kr)
+!end do
+VTG_SI = VTG/100.D0
+VTH_SI = VTH/100.D0
+
+V2_SI = V2/100.D0
+V3_SI = V3/100.D0
+V4_SI = V4/100.D0
+V5_SI = V5/100.D0
+
+FF1_SI = 1.E9*FF1
+FF2_SI = 1.E9*FF2
+FF3_SI = 1.E9*FF3
+FF4_SI = 1.E9*FF4
+FF5_SI = 1.E9*FF5
+
+pres_SI = pres/10.D0
+rhoa_SI = rhoa*1000.D0
+
+! in case ihucm_flag == 1
+
+else
+
+! in case ihucm_flag.NE.1
+
+RHO_I_SI = RHO_I
+RHO_S_SI = RHO_S
+RHO_G_SI = RHO_G
+RHO_H_SI = RHO_H
+
+XL_SI = XL
+XI_SI = XI
+XS_SI = XS
+XG_SI = XG
+XH_SI = XH
+
+XI_MELT_SI = XI_SI
+XS_MELT_SI = XS_SI
+XG_MELT_SI = XG_SI
+XH_MELT_SI = XH_SI
+
+VTL_SI = VTL
+VTC_SI = VTC
+VTS_SI = VTS
+VTG_SI = VTG
+VTH_SI = VTH
+
+V2_SI = V2
+V3_SI = V3
+V4_SI = V4
+V5_SI = V5
+
+FF1_SI = FF1
+FF2_SI = FF2
+FF3_SI = FF3
+FF4_SI = FF4
+FF5_SI = FF5
+
+pres_SI = pres
+rhoa_SI = rhoa
+
+! in case ihucm_flag.NE.1
+endif
+
+
+!=============================================================
+!       INITIALISATION
+!=============================================================
+!
+V2_SI(:,:) = VTC_SI(:,:)
+V3_SI(:) = VTS_SI(:)
+V4_SI(:) = VTG_SI(:)
+V5_SI(:) = VTH_SI(:)
+
+ee = QQV*pres_SI/(EPS + QQV)
+
+es_zero = 611.21D0
+
+if(pres_SI > 200000.D0.or.pres_SI < 10000.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (PSI is wrong), model stop")
+
+D_V=0.211D0*((TIN/273.15D0)**1.94D0)*(101325.D0/pres_SI)/1.D4
+
+! D_V = 2.21D-5
+! FK_a = 2.40D-2
+
+FK_a =(5.69D0+0.017D0*(TIN-273.15D0))*1.0D-3*4.187D0
+
+! XLV = 2.50D6
+! XLF = 2.83D6 - XLV
+
+! The expressions for latent heats used by R&H, 1987,
+! seem more applicable to
+! T > 0degC than
+! those by P & K 1997, and more modern
+
+! XLV=597.3D0*((273.15D0/TIN)**(0.167D0+3.67D-4*TIN))
+
+XLV = 597.3D0
+XLV = XLV*FJOULES_IN_A_CAL*1000.D0
+XLS = 2.83D6
+
+!XLF=79.7+0.485D0*(TIN-273.15D0)-2.5D-3*(TIN-273.15D0)*(TIN-273.15D0)
+
+XLF = 79.7D0
+XLF = XLF*FJOULES_IN_A_CAL*1000.D0
+
+! FNSC=0.632D0
+
+etaa = (1.718D0 + 0.0049D0*(TIN-273.15D0) - &
+        1.2D-5*(TIN-273.15D0)*(TIN-273.15D0))*1.D-5
+
+! etaa/rhoa_SI = kinematic viscosity
+
+FNSC = etaa/(rhoa_SI*D_V)
+
+! FNPR=0.71D0
+
+ALPHA_H = FK_a/(CP*rhoa_SI)
+FNPR = etaa/(rhoa_SI*ALPHA_H)
+RHO_CRIT = 910.D0
+
+!if(IPRINTING==1) print *, &
+!                'FNSC,FNPR,XLF,XLV = ', FNSC, FNPR, XLF, XLV
+
+if(rhoa_SI > 2.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (rhoa_SI>2), model stop 111")
+
+if(rhoa_SI < 0.1D0) then
+  call wrf_error_fatal("fatal error in module_mp_full_sbm (rhoa_SI<0.1), model stop 112")
+endif
+
+if(RHO_H_SI(1) < 1.D0) then
+  call wrf_error_fatal("fatal error in module_mp_full_sbm (RHO_H_SI(1) < 1.D0kg/m3), model stop 113")
+endif
+
+
+! new changes 23.08.04                                        (start)
+
+TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), 1.D0, XLS, RV)
+if(TS > 273.15D0) TS = 273.15D0
+
+! new changes 23.08.04                                          (end)
+      
+!=============================================================
+!       CRYSTALS
+!=============================================================
+
+
+DO I = 1, ICEMAX
+
+   I_MELT=I
+
+DO IK = 1, NKR
+
+   IK_MELT=IK
+
+if(TIN > 273.15D0) then
+
+IF(FLIQFR_I(IK,I).GE.1.D0.OR.FF2_SI(IK,I).LE.PETIT_PARAMETRE.OR. &
+TIN <= 273.15D0) THEN
+  IF(FLIQFR_I(IK,I) > 1.D0) FLIQFR_I(IK,I) = 1.D0
+  CYCLE
+ENDIF
+
+rho_p=RHO_I_SI(IK,I)+FLIQFR_I(IK,I)*(RHO_WATER-RHO_I_SI(IK,I))
+fm_i = XI_SI(IK,I)*(1.D0 - FLIQFR_I(IK,I))
+fm_w = XI_SI(IK,I)*FLIQFR_I(IK,I)
+V_p = (fm_i+fm_w)/rho_p
+V_i = V_p
+rhoi = fm_i/V_i
+
+! COLUMN (Heymsfield 1972) AR = 2 to 5
+
+IF(I.eq.1) then
+
+  AR_izero = column_AR(XI_SI(IK,I), RHO_I_SI(IK,I))
+  AR_i = AR_izero + FLIQFR_I(IK,I)*(1.D0 - AR_izero)
+  if(AR_i < AR_LIM) AR_i = AR_LIM
+  CAP_izero = COLUMN_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
+
+  vt_R = VTL_SI(IK)
+  vt_start = VTC_SI(IK,I)
+  vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
+
+  fnre = vt *FL_star*rhoa_SI/etaa
+  fv = COLUMN_VENTILATION_COEF(fnre, FNSC)
+
+! in case I.eq.1
+endif
+
+! PLATE C1g type (see P1a in p52 in P&K)
+
+IF(I.eq.2) then
+
+  AR_izero = PLATE_AR(XI_SI(IK,I))
+  AR_i = AR_izero + FLIQFR_I(IK,I)*(1.D0 - AR_izero)
+  if(AR_i > 1.D0/AR_LIM) AR_i = 1.D0/AR_LIM
+
+  CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
+
+  vt_R = VTL_SI(IK)
+  vt_start = VTC_SI(IK,I)
+  vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
+
+  fnre = vt * FL_star*rhoa_SI/etaa
+  fv = PLATE_VENTILATION_COEF(fnre, FNSC)
+
+! in case I.eq.2
+endif
+
+! DENDRITES P1c type (see P1c in p52 in P&K)
+
+IF(I.eq.3) then
+
+  AR_izero = DENDRITE_AR(XI_SI(IK,I))
+  AR_i = AR_izero + FLIQFR_I(IK,I)*(1.D0 - AR_izero)
+  if(AR_i > 1./AR_LIM) AR_i = 1.D0/AR_LIM
+
+  CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
+
+        vt_R = VTL_SI(IK)
+        vt_start = VTC_SI(IK,I)
+        vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
+
+        fnre = vt * FL_star*rhoa_SI/etaa
+        fv = DENDRITE_VENTILATION_COEF(fnre, FNSC)
+
+! in case I.eq.3
+endif
+
+! CAP = V**(1./3.)
+
+V2_SI(IK,I) = vt
+CAP = CAP_izero*(0.8D0 + FLIQFR_I(IK,I)*0.2D0)
+
+FICEMASS = XI_SI(IK,I) * (1.D0 - FLIQFR_I(IK,I))
+DMELT = DT * ( 4.D0*PI*CAP*fv/XLF) * &
+(FK_a*(TIN - 273.15D0) + (D_V*XLV/RV) * &
+(ee/TIN - es_zero/273.15D0))
+
+! new changes 23.08.04                                        (start)
+
+if(TS < 273.15D0 .and. FLIQFR_I(IK,I) <= 0.D0) DMELT = 0.D0
+
+! new changes 23.08.04                                          (end)
+
+call fmass_limits(DMELT, FICEMASS, fm_w, XI_SI(IK,I))
+
+if(ITEMP_ADJUST == 1) then
+
+  call thermodynamical_limits &
+ (FF2_SI(IK,I), XI_SI(IK,I), rhoa_SI, XLF/CP, TIN, DMELT)
+
+
+! in case ITEMP_ADJUST == 1
+
+endif
+
+FICEMASS = FICEMASS - DMELT
+
+! DMELT > 0 for melting
+
+FLIQFR_I(IK,I) = (XI_SI(IK,I) - FICEMASS)/XI_SI(IK,I)
+
+if(FLIQFR_I(IK,I) < 0.D0) FLIQFR_I(IK,I) = 0.D0
+
+if(FLIQFR_I(IK,I) > 0.D0) then
+
+  if(IEVAP_ADJUST == 1 ) then
+
+    if(FLIQFR_I(IK,I) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (FLIQFR_I > 1), model stop 114")
+
+! HEAT_EVAP = Joules of latent heat absorbed (released) 
+! by FMASS_EVAP, kg
+! of water evaporating (condensation)
+! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
+
+    HEAT_EVAP=-DMELT*XLF+DT*(4.D0*PI*CAP*fv)*FK_a*(TIN-273.15D0)
+
+! new changes 24.08.04                                        (start)
+
+    IF(HEAT_EVAP.LT.0.D0) THEN
+
+!      PRINT*, 'HEAT_EVAP < 0'
+
+!      PRINT*, 'CRYSTAL'
+
+!      PRINT*, 'I_MELT' 
+!      PRINT*,  I_MELT 
+      
+!      PRINT*, 'IJK,KX,KZ,IK'
+!      PRINT*,  IJK,KX,KZ,IK_MELT
+
+!      HEAT_EVAP=0.D0
+
+
+! in case HEAT_EVAP.LT.0.D0
+
+    ENDIF
+    
+! new changes 24.08.04                                          (end)
+
+    FMASS_EVAP = HEAT_EVAP/XLV
+
+    if(FMASS_EVAP > FLIQFR_I(IK,I) * XI_SI(IK,I)) then
+      FMASS_EVAP = FLIQFR_I(IK,I) * XI_SI(IK,I)
+    endif
+
+    Q_EVAP=FMASS_EVAP*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
+
+
+    CALL EVAP_MELTWATER &
+   (XI_SI(IK,I),rhoa_SI,Q_EVAP,FLIQFR_I(IK,I),FF2_SI(IK,I))
+
+   XI_MELT_SI(IK,I)=XX_MELT
+
+! I assume that, during the period before the RH-dependent onset
+! of melting is reached, the loss of mass of water
+! by evaporation is as negligible as the source of mass
+! of meltwater from melting itself
+!(see Rasmussen and Pruppacher 1982; P & K 1997)
+
+    TIN=TIN-XLV/CP*Q_EVAP
+
+    QQV=QQV+Q_EVAP
+
+! new changes 24.08.04                                        (start)
+
+    ee = QQV*pres_SI/(EPS + QQV)
+
+! new changes 24.08.04                                          (end)
+
+    if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
+    if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
+
+! in case IEVAP_ADJUST == 1
+  endif
+
+! in case FLIQFR_I(IK,I) > 0.D0
+
+else
+
+! in case FLIQFR_I(IK,I).LE.0.D0
+
+  if(ISUBLIME_ADJUST == 1 ) then
+
+! new changes 24.08.04                                        (start)
+
+    if(TS > 273.16) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 13655")
+    sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
+    sub_fac = sub_fac + RV*TIN/((100.D0*GGESI(TS))*D_V)
+    DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
+
+! new changes 24.08.04                                          (end)
+
+    if(DSUB >  XI_SI(IK,I)) then
+      DSUB = XI_SI(IK,I)
+    endif
+
+    Q_SUBL = DSUB*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
+
+
+    CALL SUBLIME_ICE &
+   (XI_SI(IK,I),rhoa_SI,Q_SUBL,FF2_SI(IK,I))
+
+    XI_MELT_SI(IK,I)=XX_MELT
+
+    TIN=TIN-XLS/CP*Q_SUBL
+    QQV=QQV+Q_SUBL
+
+! new changes 24.08.04                                        (start)
+
+    ee = QQV*pres_SI/(EPS + QQV)
+
+! new changes 24.08.04                                          (end)
+
+    if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm (QQV < 0), model stop ")
+    if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm ( TIN < 150) , model stop ")
+
+
+! in case ISUBLIME_ADJUST == 1
+  endif
+
+! in case FLIQFR_I(IK,I).LE.0.D0
+endif
+
+if(FLIQFR_I(IK,I) < 0.D0) then
+  FLIQFR_I(IK,I) = 0.D0
+endif
+
+IF(FLIQFR_I(IK,I) > FLIQFRAC_LIM) then
+
+  if(XL_SI(IK).NE.XI_SI(IK,I)) call wrf_error_fatal("fatal error in module_mp_full_sbm (QQV < 0), model stop 7011")
+
+  if(ITEMP_ADJUST == 1) then
+
+
+    Q_ICE_MELTED= &
+    FICEMASS*FF2_SI(IK,I)*XI_SI(IK,I)*3.D0*COL/rhoa_SI
+
+    TIN=TIN-XLF/CP*Q_ICE_MELTED
+
+
+! in case ITEMP_ADJUST == 1
+  endif
+
+  FF1_SI(IK) = FF1_SI(IK) + FF2_SI(IK,I)
+
+!  FLIQFR_I(IK,I) = 0.
+
+  FLIQFR_I(IK,I) = 1.D0
+
+  FF2_SI(IK,I) = 0.D0
+
+! in case FLIQFR_I(IK,I) > FLIQFRAC_LIM
+
+ENDIF
+
+! in case TIN > 273.15D0
+
+endif
+
+ENDDO
+! cycle by IK
+
+ENDDO
+! cycle by I
+
+!=============================================================
+!       SNOW
+!=============================================================
+
+
+DO IK = 1, NKR
+
+   IK_MELT=IK
+   I_MELT=0
+
+if(TIN > 273.15D0) then
+
+IF(FLIQFR_S(IK).GE.1.D0.OR.FF3_SI(IK).LE.PETIT_PARAMETRE.OR. &
+TIN <= 273.15D0) THEN
+  IF(FLIQFR_S(IK) > 1.D0) FLIQFR_S(IK) = 1.D0
+CYCLE
+ENDIF
+
+rho_p = RHO_S_SI(IK) + FLIQFR_S(IK)* &
+       (RHO_WATER - RHO_S_SI(IK))
+
+fm_i = XS_SI(IK)*(1.D0 - FLIQFR_S(IK))
+fm_w = XS_SI(IK)*FLIQFR_S(IK)
+V_p = (fm_i + fm_w)/rho_p
+V_i = V_p
+rhoi = fm_i/V_i
+!
+! Based on Mitra et al. (1990)/Matsuo and Sasyo (1981)
+! V_p = (4/3) PI AR a_i**3
+!
+! ASSUME:- (1) snowflakes have an ice skeleton structure that
+! is incollapsable,
+! but of varing AR, until completion of melting;
+! (2) melting occurs only at snowflake exterior surface and water
+! then penetrates inside
+!
+! fm_i in the text of Mitra et al is the mass of the ice component
+! a_i (b_i) are the major (minor) axes of the ice skeleton
+! AR = b_i/a_i
+
+AR_p = 0.3D0 + 0.7D0 * FLIQFR_S(IK)
+
+! new change 26.07.04                                         (start)
+
+! the rest of the HUCM seems to assume that snow is spherical 
+!(see JERRATE)
+! AR_p = 1.
+
+! new change 26.07.04                                           (end)
+
+AR_i = AR_p
+
+CAP_izero = PLANAR_CAP_ZERO(fm_i, AR_i, rhoi, FL_star)
+CAP = CAP_izero*(0.8D0 + FLIQFR_S(IK)*0.2D0)
+
+vt_R = VTL_SI(IK)
+vt_start = VTS_SI(IK)
+vt = vt_start + (vt_R - vt_start) * chi_fra(fm_w/(fm_i+fm_w))
+fnre = FL_star * vt*rhoa_SI/etaa
+
+! new change 24.08.04                                         (start)
+
+fv = SNOW_VENTILATION_COEF(fnre, FNSC, AR_i)
+
+! new change 24.08.04                                           (end)
+
+V3_SI(IK) = vt
+
+FICEMASS = XS_SI(IK) * (1.D0 - FLIQFR_S(IK))
+
+DMELT = DT * ( 4.D0*PI*CAP*fv/XLF) * &
+(FK_a*(TIN - 273.15D0) + (D_V*XLV/RV) * &
+(ee/TIN - es_zero/273.15D0))
+
+! new change 24.08.04                                         (start) 
+
+if(TS < 273.15D0 .and. FLIQFR_S(IK) <= 0.D0) DMELT = 0.D0
+
+! new change 24.08.04                                           (end) 
+
+call fmass_limits(DMELT, FICEMASS, fm_w, XS_SI(IK))
+
+if(ITEMP_ADJUST == 1) then
+
+
+  call thermodynamical_limits &
+ (FF3_SI(IK), XS_SI(IK), rhoa_SI, XLF/CP, TIN, DMELT)
+
+
+! in case ITEMP_ADJUST == 1
+endif
+
+FICEMASS = FICEMASS - DMELT
+
+FLIQFR_S(IK) = (XS_SI(IK) - FICEMASS)/XS_SI(IK)
+
+if(FLIQFR_S(IK) < 0.D0) then
+  FLIQFR_S(IK) = 0.D0
+endif
+
+if(FLIQFR_S(IK) > 0.D0) then
+
+  if(IEVAP_ADJUST == 1) then
+
+    if(FLIQFR_S(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 905")
+
+! HEAT_EVAP = Joules of latent heat absorbed by FMASS_EVAP kg
+! of water evaporating
+! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
+
+    HEAT_EVAP=-DMELT*XLF+ DT*(4.D0*PI*CAP*fv)*FK_a*(TIN-273.15D0)
+
+! new change 24.08.04                                         (start)
+
+    IF(HEAT_EVAP.LT.0.D0) THEN
+      
+!      PRINT*, 'HEAT_EVAP < 0'
+
+!      PRINT*, 'SNOW'
+
+!      PRINT*, 'IJK,KX,KZ,IK'
+!      PRINT*,  IJK,KX,KZ,IK_MELT
+ 
+!      HEAT_EVAP=0.D0
+
+
+    ENDIF
+    
+! new change 24.08.04                                           (end)
+
+    FMASS_EVAP = HEAT_EVAP/XLV
+
+    if(FMASS_EVAP > FLIQFR_S(IK) * XS_SI(IK)) then
+      FMASS_EVAP = FLIQFR_S(IK) * XS_SI(IK)
+    endif
+
+    Q_EVAP= FMASS_EVAP*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
+
+
+    CALL EVAP_MELTWATER &
+   (XS_SI(IK),rhoa_SI,Q_EVAP,FLIQFR_S(IK),FF3_SI(IK))
+
+    XS_MELT_SI(IK)=XX_MELT
+
+    TIN=TIN-XLV/CP*Q_EVAP
+    QQV=QQV+Q_EVAP
+
+! new change 24.08.04                                         (start)
+
+    ee = QQV*pres_SI/(EPS + QQV)
+
+! new change 24.08.04                                           (end)
+
+    if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 915")
+    if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 916")
+
+
+! in case IEVAP_ADJUST == 1
+  endif
+
+! in case FLIQFR_S(IK) > 0.D0
+
+else
+
+! in case FLIQFR_S(IK).LE.0.D0
+
+  if(ISUBLIME_ADJUST == 1) then
+
+    sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
+
+! new change 24.08.04                                         (start)
+
+    sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
+
+    DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
+
+! new change 24.08.04                                           (end)
+
+    if(DSUB >  XS_SI(IK)) then
+      DSUB = XS_SI(IK)
+    endif
+
+    Q_SUBL = DSUB*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
+
+
+    CALL SUBLIME_ICE(XS_SI(IK),rhoa_SI,Q_SUBL,FF3_SI(IK))
+
+    XS_MELT_SI(IK)=XX_MELT
+
+    TIN=TIN-XLS/CP*Q_SUBL
+    QQV=QQV+Q_SUBL
+
+! new change 24.08.04                                         (start)
+
+    ee = QQV*pres_SI/(EPS + QQV)
+
+! new change 24.08.04                                           (end)
+
+    if(QQV < 0.) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
+    if(TIN < 150.) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
+
+
+! in case ISUBLIME_ADJUST == 1
+  endif
+
+! in case FLIQFR_S(IK).LE.0.D0
+endif
+
+if(FLIQFR_S(IK) < 0.D0) then
+        FLIQFR_S(IK) = 0.D0
+endif
+
+IF(FLIQFR_S(IK) > FLIQFRAC_LIM) then
+
+  if(XL_SI(IK).NE.XS_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7012")
+
+  if(ITEMP_ADJUST == 1) then
+
+
+    Q_ICE_MELTED=FICEMASS*FF3_SI(IK)*XS_SI(IK)*3.D0*COL/rhoa_SI
+
+    TIN=TIN-XLF/CP*Q_ICE_MELTED
+
+
+
+! in case ITEMP_ADJUST == 1
+
+  endif
+
+  FF1_SI(IK) = FF1_SI(IK) + FF3_SI(IK)
+
+!  FLIQFR_S(IK) = 0.D0
+
+  FLIQFR_S(IK) = 1.D0
+
+  FF3_SI(IK) = 0.D0
+
+! in case FLIQFR_S(IK) > FLIQFRAC_LIM
+ENDIF
+
+! in case TIN > 273.15D0
+endif
+
+ENDDO
+! cycle by IK
+!
+!=============================================================
+!               GRAUPEL (assumed to be spheres)
+!=============================================================
+
+
+DO IK = 1, NKR
+
+   IK_MELT=IK
+   I_MELT=0
+
+if(TIN > 273.15D0) then
+
+IF(FLIQFR_G(IK).GE.1.D0.OR.FF4_SI(IK).LE.PETIT_PARAMETRE.OR. &
+TIN <= 273.15D0) THEN
+  IF(FLIQFR_G(IK) > 1.D0) FLIQFR_G(IK) = 1.D0
+CYCLE
+ENDIF
+!
+vt_start = 0.D0
+vt_end = 0.D0
+!
+rhoi = RHO_G_SI(IK)
+fm_i = XG_SI(IK)*(1.D0 - FLIQFR_G(IK))
+V_i = fm_i/rhoi
+fm_w = XG_SI(IK)*FLIQFR_G(IK)
+V_w = fm_w/RHO_WATER
+
+if(rhoi < RHO_CRIT) then
+  V_soakable = V_i - fm_i/RHO_ICE
+else
+  V_soakable = 0.D0
+endif
+
+a_i = rad_sphere(V_i)
+a_izero = rad_sphere(XG_SI(IK)/rhoi)
+fnre_dry = VTG_SI(IK) * 2.D0*rhoa_SI*a_izero/etaa
+
+! FIND RE (ie. CD) OF SMOOTH SPHERE OF SAME MASS
+!(fnre_smooth is invariant during melting)
+
+X_Best = 8.D0 * XG_SI(IK) * rhoa_SI * GRAV / (PI * etaa * etaa)
+fnre_smooth = fnre_sphere(X_Best)
+
+if(V_w < V_soakable) then
+
+  a_d = a_i
+  vt=VT_LOW_DENSITY_SOAKING &
+    (fnre_dry,fnre_smooth,VTG_SI(IK),a_i,a_izero,etaa,rhoa_SI)
+
+! in case V_w < V_soakable
+
+else
+
+! in case V_w >= V_soakable
+
+  a_d = rad_sphere(V_i + (V_w - V_soakable))
+  fm_w_soaked = RHO_WATER* V_soakable
+  fm_w_crit = (0.268D0 + (fm_i + fm_w_soaked) * 1.D3 * 0.1389D0)
+  fm_w_crit = fm_w_crit* 1.D-3
+  a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
+
+  if(rhoi < RHO_CRIT) then
+    vt_start = VT_LOW_DENSITY_TRANS &
+              (fnre_dry, fnre_smooth, &
+               VTG_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XG_SI(IK))
+  else
+    vt_start=VT_HIGH_DENSITY_TRANS &
+            (fnre_dry,fnre_smooth,VTG_SI(IK),a_izero,etaa,rhoa_SI)
+  endif
+
+  vt_end=equilibrium_fallspeed &
+        (fm_i+fm_w_soaked,fm_w_crit, &
+         XG(:),VTL_SI(:),rhoa_SI,etaa,a_crit)
+
+  frac_eqm=(fm_w-fm_w_soaked)/fm_w_crit
+
+  if(frac_eqm < 0.D0) frac_eqm = 0.D0
+  if(frac_eqm > 1.D0) frac_eqm = 1.D0
+
+  vt = vt_start + (vt_end - vt_start) * frac_eqm
+
+  if(vt < 0.D0) vt = 0.D0
+
+! in case V_w >= V_soakable
+
+endif
+
+! new changes 23.01.08                                        (start)
+
+! new changes 3.02.08                                         (start)
+
+if(ivt_G_H_interpol.ne.0) then
+
+  vt=VTG_SI(IK)+FLIQFR_G(IK)*(VTL_SI(IK) - VTG_SI(IK))
+
+endif
+
+! new changes 3.02.08                                          (end)
+
+! new changes 23.01.08                                          (end)
+
+V4_SI(IK) = vt
+
+fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
+
+! new change 5.02.07                                          (start)
+
+fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
+fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
+
+! new change 5.02.07                                            (end)
+
+! new change 24.08.04                                         (start)
+
+if(FLIQFR_G(IK) <= 0.D0) then
+  TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
+else
+  TS = 273.15D0
+endif
+
+if(TS > 273.15D0) TS = 273.15D0
+
+! new change 24.08.04                                           (end)
+
+if(fnre < 6000.D0) then
+  CAP = a_d
+else
+  CAP = a_i
+endif
+
+FICEMASS = XG_SI(IK) * (1.D0 - FLIQFR_G(IK))
+
+DMELT = DT*(4.D0*PI*CAP/XLF) * &
+(FK_a*(TIN-273.15D0)*fh+(D_V*XLV/RV)*fv*(ee/TIN - es_zero/273.15D0))
+
+! new change 24.08.04                                         (start)
+
+if(TS < 273.15D0 .and. FLIQFR_G(IK) <= 0.) DMELT = 0.D0
+
+! new change 24.08.04                                           (end)
+
+
+call fmass_limits(DMELT, FICEMASS, fm_w, XG_SI(IK))
+
+if(ITEMP_ADJUST == 1) then
+
+
+  call thermodynamical_limits &
+ (FF4_SI(IK), XG_SI(IK), rhoa_SI, XLF/CP, TIN, DMELT)
+
+
+! in case ITEMP_ADJUST == 1
+
+endif
+
+FICEMASS = FICEMASS - DMELT
+
+FLIQFR_G(IK) = (XG_SI(IK) - FICEMASS)/XG_SI(IK)
+
+if(FLIQFR_G(IK) < 0.D0) then
+  FLIQFR_G(IK) = 0.D0
+endif
+
+if(FLIQFR_G(IK) > 0.D0) then
+
+  if(IEVAP_ADJUST == 1) then
+
+    if(FLIQFR_G(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 901")
+
+! HEAT_EVAP = Joules of latent heat absorbed by FMASS_EVAP kg
+! of water evaporating
+! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
+
+    HEAT_EVAP=-DMELT*XLF+ DT*(4.D0*PI*CAP)*FK_a*(TIN-273.15D0)*fh
+
+! new changes 24.08.04                                        (start)
+
+    IF(HEAT_EVAP.LT.0.D0) THEN
+      
+!      PRINT*, 'HEAT_EVAP < 0'
+
+!      PRINT*, 'GRAUPEL'
+
+!      PRINT*, 'IJK,KX,KZ,IK'
+!      PRINT*,  IJK,KX,KZ,IK_MELT
+ 
+!      HEAT_EVAP=0.D0
+
+
+    ENDIF
+
+! new change 24.08.04                                           (end)
+
+    FMASS_EVAP=HEAT_EVAP/XLV
+
+    if(FMASS_EVAP > FLIQFR_G(IK)*XG_SI(IK)) then
+      FMASS_EVAP = FLIQFR_G(IK)*XG_SI(IK)
+    endif
+
+    Q_EVAP =  FMASS_EVAP * FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
+
+
+! in case IEVAP_ADJUST == 1
+  endif
+
+! in case FLIQFR_G(IK) > 0.D0
+
+else
+
+! in case FLIQFR_G(IK) <= 0.D0
+
+  if(ISUBLIME_ADJUST == 1)then
+
+    sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
+
+! new change 24.08.04                                         (start)
+
+    sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
+
+    DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
+    
+! new change 24.08.04                                           (end)
+
+    if(DSUB >  XG_SI(IK)) then
+      DSUB = XG_SI(IK)
+    endif
+
+    Q_SUBL = DSUB*FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
+
+
+    CALL SUBLIME_ICE( XG_SI(IK), rhoa_SI, Q_SUBL, FF4_SI(IK))
+
+    XG_MELT_SI(IK)=XX_MELT
+!
+    TIN = TIN - XLS/CP*Q_SUBL
+    QQV = QQV + Q_SUBL
+
+! new change 24.08.04                                         (start)
+
+    ee = QQV*pres_SI/(EPS + QQV)
+
+! new change 24.08.04                                           (end)
+
+    if(QQV < 0.D0)  call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
+    if(TIN < 150.D0)   call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
+
+
+! in case ISUBLIME_ADJUST == 1
+
+  endif
+
+! in case FLIQFR_G(IK) <= 0.D0
+
+endif
+
+IF(FLIQFR_G(IK) > FLIQFRAC_LIM) then
+
+  if(XL_SI(IK).NE.XG_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7013")
+
+  if(ITEMP_ADJUST == 1) then
+
+
+    Q_ICE_MELTED = FICEMASS *FF4_SI(IK)*XG_SI(IK)*3.D0*COL/rhoa_SI
+
+    TIN = TIN - XLF/CP*Q_ICE_MELTED
+
+
+! in case ITEMP_ADJUST == 1
+
+  endif
+
+  FF1_SI(IK) = FF1_SI(IK) + FF4_SI(IK)
+
+!  FLIQFR_G(IK) = 0.D0
+
+  FLIQFR_G(IK) = 1.D0
+
+  FF4_SI(IK) = 0.D0
+
+! in case FLIQFR_G(IK) > FLIQFRAC_LIM
+
+ENDIF
+
+! in case TIN > 273.15D0
+
+endif
+
+ENDDO
+! cycle by IK
+!
+!=============================================================
+!               HAIL (assumed to be spheres)
+!=============================================================
+
+
+DO IK = 1, NKR
+
+   IK_MELT=IK
+   I_MELT=0
+
+if(TIN > 273.15D0) then
+
+IF(FLIQFR_H(IK).GE.1.D0.OR.FF5_SI(IK).LE.PETIT_PARAMETRE.OR. &
+TIN <= 273.15D0) THEN
+  IF(FLIQFR_H(IK) > 1.D0) FLIQFR_H(IK) = 1.D0
+CYCLE
+ENDIF
+
+vt_start = 0.D0
+vt_end = 0.D0
+
+rhoi  = RHO_H_SI(IK)
+fm_i = XH_SI(IK)*(1.D0 - FLIQFR_H(IK))
+V_i = fm_i/rhoi
+fm_w = XH_SI(IK)*FLIQFR_H(IK)
+V_w = fm_w/RHO_WATER
+
+if(rhoi < RHO_CRIT) then
+  V_soakable = V_i - fm_i/RHO_ICE
+else
+  V_soakable = 0.D0
+endif
+
+a_i = rad_sphere(V_i)
+a_izero = rad_sphere(XH_SI(IK)/rhoi)
+
+! FIND RE OF SMOOTH SPHERE OF SAME MASS
+! (fnre_smooth is invariant during melting)
+
+if(IPRINTING == 1) print *, 'fnre_dry = ', fnre_dry
+
+fnre_dry=VTH_SI(IK)*2.D0*rhoa_SI*a_izero/etaa
+X_Best=8.D0*XH_SI(IK)*rhoa_SI*GRAV/(PI * etaa * etaa)
+fnre_smooth=fnre_sphere(X_Best)
+
+vt_justwet = 0.D0
+vt_justsoaked = 0.D0
+
+if(V_w < V_soakable) then
+
+! SOAKING OF WATER
+
+  a_d = a_i
+  vt=VT_LOW_DENSITY_SOAKING &
+    (fnre_dry,fnre_smooth,VTH_SI(IK),a_i,a_izero,etaa,rhoa_SI)
+
+! in case V_w < V_soakable
+
+else
+
+! in case V_w >= V_soakable
+
+  a_d = rad_sphere(V_i + (V_w - V_soakable))
+  fm_w_soaked = RHO_WATER* V_soakable
+  fm_w_crit=(0.268D0+(fm_i+fm_w_soaked)*1.D3*0.1389D0)
+  fm_w_crit = fm_w_crit* 1.D-3
+  a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
+
+!RH87: Just-wet terminal velocity - look at history
+!of same particle passing 0oC
+!(ie. 'just-wet' means when 0degC is just reached
+!by surface and melting commences):
+
+  if(rhoi < RHO_CRIT) then
+
+    vt_start = VT_LOW_DENSITY_TRANS &
+              (fnre_dry,fnre_smooth, &
+               VTH_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XH_SI(IK))
+  else
+
+    vt_start = VT_HIGH_DENSITY_TRANS(fnre_dry, fnre_smooth, &
+    VTH_SI(IK), a_izero, etaa, rhoa_SI)
+
+  endif
+
+    vt_end=equilibrium_fallspeed &
+          (fm_i + fm_w_soaked, fm_w_crit, XH(:), &
+           VTL_SI(:), rhoa_SI, etaa, a_crit)
+
+! RH87: Interpolation based on fraction of equilibrium water
+! on surface
+
+    frac_eqm = (fm_w - fm_w_soaked)/fm_w_crit
+    if(frac_eqm < 0.D0) frac_eqm = 0.D0
+    if(frac_eqm > 1.D0) frac_eqm = 1.D0
+
+    vt = vt_start + (vt_end - vt_start) * frac_eqm
+
+    if(vt < 0.D0) then
+      if(IPRINTING == 1) print *, 'WARNING: vt < 0', vt
+      vt = 0.D0
+    endif
+
+    if(IPRINTING == 1) print *, &
+   'HERE 2:: vt_start,vt_end,a_izero/a_i= ', &
+             vt_start,vt_end,a_izero/a_i
+
+    if(IPRINTING == 1) print *, &
+   'HERE 2:: fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet', &
+             fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet
+
+! in case V_w >= V_soakable
+
+endif
+
+! new changes 23.01.08                                      (start)
+
+! new changes 3.02.08                                       (start)
+
+if(ivt_G_H_interpol.ne.0) then
+
+  vt=VTH_SI(IK)+FLIQFR_H(IK)*(VTL_SI(IK) - VTH_SI(IK))
+  
+endif
+
+! new changes 3.02.08                                         (end)
+  
+! new changes 23.01.08                                        (end)
+
+V5_SI(IK) = vt
+
+if(IPRINTING == 1) print *, 'HERE 2: VT,LIQUID FRACTION,IK', &
+                                     V5_SI(IK),FLIQFR_H(IK),IK
+fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
+
+! new change 5.02.07                                          (start)
+
+fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
+fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
+
+! new change 5.02.07                                            (end)
+
+! new change 24.08.04                                         (start)
+
+if(FLIQFR_H(IK) <= 0.D0) then
+  TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
+else
+  TS = 273.15D0
+endif
+
+if(TS > 273.15D0) TS = 273.15D0
+
+! new change 24.08.04                                           (end)
+
+
+if(fnre < 6000.D0) then
+  CAP = a_d
+else
+  CAP = a_i
+endif
+
+
+FICEMASS = XH_SI(IK) * (1.D0 - FLIQFR_H(IK))
+
+DMELT = DT*4.D0*PI*CAP/XLF* &
+(FK_a*(TIN-273.15D0)*fh+D_V*XLV/RV*fv*(ee/TIN-es_zero/273.15D0))
+
+! new change 24.08.04                                         (start)
+
+if(TS < 273.15D0 .and. FLIQFR_H(IK) <= 0.) DMELT = 0.D0
+
+! new change 24.08.04                                           (end)
+
+
+!
+call fmass_limits (DMELT,FICEMASS,fm_w,XH_SI(IK))
+
+!
+if(ITEMP_ADJUST == 1) then
+
+
+  call thermodynamical_limits &
+ (FF5_SI(IK),XH_SI(IK),rhoa_SI,XLF/CP,TIN,DMELT)
+
+
+! in case ITEMP_ADJUST == 1
+
+endif
+
+FICEMASS = FICEMASS - DMELT
+
+FLIQFR_H(IK) = (XH_SI(IK) - FICEMASS)/XH_SI(IK)
+
+
+
+if(FLIQFR_H(IK) < 0.D0) then
+  FLIQFR_H(IK) = 0.D0
+endif
+
+if(FLIQFR_H(IK) > 0.D0) then
+
+  if(IEVAP_ADJUST == 1) then
+
+    if( FLIQFR_H(IK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 906")
+
+! HEAT_EVAP = Joules of latent heat absorbed by FMASS_EVAP kg
+! of water evaporating
+
+! Q_EVAP = the gain of vapour mixing ratio (kg/kg) from evaporation
+
+    HEAT_EVAP=-DMELT*XLF+DT*(4.D0*PI*CAP)*FK_a*(TIN-273.15D0)*fh
+
+! new changes 24.08.04                                        (start)
+
+    IF(HEAT_EVAP.LT.0.D0) THEN
+      
+!      PRINT*, 'HEAT_EVAP < 0'
+
+!      PRINT*, 'GRAUPEL'
+
+!      PRINT*, 'IJK,KX,KZ,IK'
+!      PRINT*,  IJK,KX,KZ,IK_MELT
+ 
+!      HEAT_EVAP=0.D0
+
+
+    ENDIF
+
+! new change 24.08.04                                           (end)
+
+    FMASS_EVAP = HEAT_EVAP/XLV
+
+    if(FMASS_EVAP > FLIQFR_H(IK) * XH_SI(IK)) then
+      FMASS_EVAP = FLIQFR_H(IK) * XH_SI(IK)
+    endif
+
+    Q_EVAP=FMASS_EVAP*FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
+
+
+    CALL EVAP_MELTWATER &
+   (XH_SI(IK),rhoa_SI,Q_EVAP,FLIQFR_H(IK),FF5_SI(IK))
+
+    XH_MELT_SI(IK)=XX_MELT
+
+    TIN = TIN - XLV/CP*Q_EVAP
+    QQV = QQV + Q_EVAP
+
+! new change 24.08.04                                         (start)
+
+    ee = QQV*pres_SI/(EPS + QQV)
+
+! new change 24.08.04                                           (end)
+
+    if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
+    if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
+
+
+! in case IEVAP_ADJUST == 1
+
+  endif
+
+! in case FLIQFR_H(IK) > 0.D0
+
+else
+
+! in case FLIQFR_H(IK) <= 0.D0
+
+  if(ISUBLIME_ADJUST == 1) then
+
+    sub_fac = (XLS/(RV*TIN) - 1.D0)*XLS/(FK_a * TIN)
+
+! new change 24.08.04                                         (start)
+
+    sub_fac = sub_fac + RV* TIN/((100.D0*GGESI(TS)) * D_V)
+
+    DSUB = -DT*4.D0*PI*CAP*fv*(ee/(100.D0*GGESI(TS)) - 1.D0)/sub_fac
+
+! new change 24.08.04                                           (end)
+
+    if(DSUB > XH_SI(IK)) then
+      DSUB = XH_SI(IK)
+    endif
+
+    Q_SUBL = DSUB*FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
+
+
+    CALL SUBLIME_ICE(XH_SI(IK),rhoa_SI,Q_SUBL,FF5_SI(IK))
+
+    XH_MELT_SI(IK)=XX_MELT
+
+    TIN = TIN - XLS/CP*Q_SUBL
+    QQV = QQV + Q_SUBL
+
+! new change 24.08.04                                         (start)
+
+    ee = QQV*pres_SI/(EPS + QQV)
+
+! new change 24.08.04                                           (end)
+
+    if(QQV < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 135")
+    if(TIN < 150.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 138")
+
+
+! in case ISUBLIME_ADJUST == 1
+  endif
+
+! in case FLIQFR_H(IK) <= 0.D0
+
+endif
+
+if(FLIQFR_H(IK) < 0.D0) then
+  FLIQFR_H(IK) = 0.D0
+endif
+
+IF(FLIQFR_H(IK) > FLIQFRAC_LIM) then
+
+  if(XL_SI(IK).NE.XH_SI(IK)) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 7014")
+
+  if(ITEMP_ADJUST == 1) then
+
+
+    Q_ICE_MELTED = FICEMASS *FF5_SI(IK)*XH_SI(IK)*3.D0*COL/rhoa_SI
+
+    TIN = TIN - XLF/CP*Q_ICE_MELTED
+    
+
+! in case ITEMP_ADJUST == 1
+
+  endif
+
+  FF1_SI(IK) = FF1_SI(IK) + FF5_SI(IK)
+
+!  FLIQFR_H(IK) = 0.D0
+
+  FLIQFR_H(IK) = 1.D0
+
+  FF5_SI(IK) = 0.D0
+
+! in case FLIQFR_H(IK) > FLIQFRAC_LIM
+
+ENDIF
+
+! in case TIN > 273.15D0
+
+endif
+
+ENDDO
+! cycle by IK
+
+!=============================================================
+!       UNIT CONVERSION OF ALL OUTPUTS from SI
+!=============================================================
+!
+if(ihucm_flag == 1) then
+
+  if(IVT_ADJUST == 1) then
+    V2 = 100.D0 * V2_SI
+    V3 = 100.D0 * V3_SI
+    V4 = 100.D0 * V4_SI
+    V5 = 100.D0 * V5_SI
+  endif
+
+  FF1 = 1.D-9*FF1_SI
+  FF2 = 1.D-9*FF2_SI
+  FF3 = 1.D-9*FF3_SI
+  FF4 = 1.D-9*FF4_SI
+  FF5 = 1.D-9*FF5_SI
+
+  XI_MELT = XI_MELT_SI*1000.D0
+  XS_MELT = XS_MELT_SI*1000.D0
+  XG_MELT = XG_MELT_SI*1000.D0
+  XH_MELT = XH_MELT_SI*1000.D0
+
+! in case ihucm_flag == 1
+
+else
+
+! in case ihucm_flag.NE.1
+
+  if(IVT_ADJUST == 1) then
+    V2 = V2_SI
+    V3 = V3_SI
+    V4 = V4_SI
+    V5 = V5_SI
+  endif
+  
+  FF1 = FF1_SI
+  FF2 = FF2_SI
+  FF3 = FF3_SI
+  FF4 = FF4_SI
+  FF5 = FF5_SI
+
+  XI_MELT = XI_MELT_SI
+  XS_MELT = XS_MELT_SI
+  XG_MELT = XG_MELT_SI
+  XH_MELT = XH_MELT_SI
+
+! in case ihucm_flag.NE.1
+
+endif
+
+ 101 FORMAT(1X,D13.5)
+ 102 FORMAT(1X,2D13.5)
+ 103 FORMAT(1X,3D13.5)
+ 104 FORMAT(1X,4D13.5)
+ 105 FORMAT(1X,5D13.5)
+ 106 FORMAT(1X,6D13.5)
+ 107 FORMAT(1X,7D13.5)
+ 201 FORMAT(1X,I2,D13.5)
+ 202 FORMAT(1X,I2,2D13.5)
+ 203 FORMAT(1X,I2,3D13.5)
+ 204 FORMAT(1X,I2,4D13.5)
+
+END SUBROUTINE MELTING
+
+! end of melting subroutine
+SUBROUTINE EVAP_MELTWATER(XX,rhoax,Q_EVAPX,FLIQFRX,FFX)
+
+implicit double precision (a-h,o-z)
+
+PARAMETER(COL=0.23105D0)
+
+! control in main program & others subroutines
+
+! new change 29.10.08                                         (start)           
+
+
+! new change 29.10.08                                           (end)
+
+
+
+
+total_mass= XX*FFX*XX*3.D0*COL/rhoax
+total_mass_ice=(1.D0-FLIQFRX)*total_mass
+total_mass_liq=FLIQFRX*total_mass
+
+
+if(Q_EVAPX > total_mass_liq) Q_EVAPX = total_mass_liq
+if(Q_EVAPX > total_mass) Q_EVAPX = total_mass
+
+total_mass_liq = total_mass_liq - Q_EVAPX
+total_mass = total_mass - Q_EVAPX
+
+XX_MELT=total_mass*rhoax/(3.D0*XX*FFX*COL)
+
+FFX = total_mass/(XX*XX*3.D0*COL/rhoax)
+
+if(FFX < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 136")
+
+if(total_mass_liq < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 137")
+if(total_mass_ice < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 140")
+if(total_mass < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 141")
+
+IF(total_mass.EQ.0.D0) THEN
+  FLIQFRX =1.D0
+ELSE
+  FLIQFRX = (total_mass - total_mass_ice)/total_mass
+ENDIF
+
+if(FLIQFRX < 0.D0) FLIQFRX = 0.D0
+if(FLIQFRX > 1.D0) FLIQFRX = 1.D0
+
+101 FORMAT(1X,D13.5)
+102 FORMAT(1X,2D13.5)
+103 FORMAT(1X,3D13.5)
+104 FORMAT(1X,4D13.5)
+105 FORMAT(1X,5D13.5)
+106 FORMAT(1X,6D13.5)
+
+END SUBROUTINE evap_meltwater
+
+! end of evap_meltwater subroutine
+!====================================================================
+SUBROUTINE SUBLIME_ICE (XX,rhoax,Q_SUBLX,FFX)
+
+implicit double precision (a-h,o-z)
+
+PARAMETER(COL = 0.23105D0)
+
+! new change 24.08.04                                         (start)
+
+
+! new change 24.08.04                                           (end)
+
+total_mass =  XX*FFX*XX*3.D0*COL/rhoax
+
+if(Q_SUBLX > total_mass) Q_SUBLX = total_mass
+
+total_mass = total_mass - Q_SUBLX
+
+! new change 20.06.04                                         (start)
+
+XX_MELT=total_mass*rhoax/(3.D0*FFX*XX*COL)
+
+! new change 20.06.04                                           (end)
+
+FFX = total_mass/(XX*XX*3.D0*COL/rhoax)
+
+if(FFX < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 140")
+
+if(total_mass < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 141")
+
+END SUBROUTINE sublime_ice
+
+! end of sublime_ice subroutine
+!====================================================================
+FUNCTION VT_LOW_DENSITY_SOAKING &
+(fnre_dryx,fnre_smoothx,vt_dryx,a_ix,a_izerox,etaax,rhoax)
+
+implicit double precision (a-h,o-z)
+
+
+! During melting, Re is constant (see RH87, Appendix B)
+! but size changes
+
+! Same as for just-wet case, except we use the current ice size
+
+if(fnre_dryx > 4000.D0) then
+
+  vtx = vt_dryx * a_izerox/a_ix
+
+
+! in case fnre_dryx > 4000.D0
+
+else
+
+! in case fnre_dryx <= 4000.D0
+
+  vtx = fnre_smoothx * etaax/(2.D0 * a_ix * rhoax)
+
+
+! in case fnre_dryx <= 4000.D0
+endif
+
+VT_LOW_DENSITY_SOAKING = vtx
+
+RETURN
+END FUNCTION VT_LOW_DENSITY_SOAKING 
+
+! end of vt_low_density_soaking function
+!====================================================================
+FUNCTION VT_LOW_DENSITY_TRANS &
+(fnre_dryx,fnre_smoothx,vt_dryx,a_izerox,etaax,rhoax,rhoix,fm_tot)
+
+implicit double precision (a-h,o-z)
+
+PARAMETER(RHO_WATER=1000.D0, RHO_ICE=920.D0, PI = 3.141592654D0)
+
+fm_ijustsoaked=fm_tot/(1.D0+RHO_WATER/rhoix-RHO_WATER/RHO_ICE)
+a_ijustsoaked=rad_sphere(fm_ijustsoaked/rhoix)
+
+if(fnre_dryx <=  4000.D0.or.rhoix < 800.D0) then
+  vt_justsoaked=fnre_smoothx*etaax/(2.D0*a_ijustsoaked*rhoax)
+else
+  vt_justsoaked=vt_dryx*a_izerox/a_ijustsoaked
+endif
+
+vtx = vt_justsoaked
+
+VT_LOW_DENSITY_TRANS = vtx
+
+RETURN
+END FUNCTION VT_LOW_DENSITY_TRANS
+
+! end of function vt_low_density_trans
+!====================================================================
+FUNCTION VT_HIGH_DENSITY_TRANS &
+(fnre_dryx,fnre_smoothx,vt_dryx,a_izerox,etaax,rhoax)
+
+implicit double precision (a-h,o-z)
+
+PARAMETER(RHO_WATER=1000.D0, RHO_ICE=920.D0, PI = 3.141592654D0)
+
+! Just-wet size = a_izero
+
+if(fnre_dryx > 4000.D0) then
+  vt_justwet=vt_dryx
+else
+  vt_justwet=fnre_smoothx*etaax/(2.D0*a_izerox*rhoax)
+endif
+
+vtx = vt_justwet
+
+VT_HIGH_DENSITY_TRANS = vtx
+
+RETURN
+END FUNCTION VT_HIGH_DENSITY_TRANS
+
+! end of function vt_high_density_trans
+!====================================================================
+! new change 5.02.07                                          (start)
+
+FUNCTION HAIL_VENTILATION_COEF (fnrex, fnumber, KR)
+
+! new change 5.02.07                                            (end)
+
+implicit double precision (a-h,o-z)
+
+! new change 29.10.08                                         (start)           
+
+
+! new change 29.10.08                                           (end)
+
+if(fnrex < 6000.D0) then
+
+  X_F = (fnrex**0.5D0)*(fnumber**(1.D0/3.D0))
+
+  IF(X_F < 1.4D0) then
+    fx = 1.D0 + 0.108D0*X_F*X_F
+  ELSE
+    fx = 0.78D0 + 0.308D0*X_F
+  ENDIF
+
+  if(fnrex < 250.D0) then
+    fx = fx*2.D0
+  endif
+
+! in case fnrex < 6000.D0
+
+else
+
+! in case fnrex >= 6000.D0
+
+  if(fnrex < 20000.D0) then
+    chi_fr = 0.76D0
+  else
+    chi_fr = 0.57 + fnrex*9.D-6
+  endif
+
+  fx = chi_fr*(fnrex**0.5D0)*(fnumber**(1.D0/3.D0))/2.D0
+
+! in case fnrex >= 6000.D0
+
+endif
+
+if(fx < 1.D0) then
+  fx = 1.D0
+endif
+
+! new change 5.02.07                                          (start)
+
+!if(fx > 100.D0) stop 99991
+if(fx > 100.D0) then
+!  print*,   'IJK,KX,KZ,KR'
+!  print*,    IJK,KX,KZ,KR
+!  print*,   'chi_fr,fnrex,fnumber,fx'
+!  print 204, chi_fr,fnrex,fnumber,fx
+!  print*,   'stop 99991 : fx > 100.D0'
+! stop 99991
+  fx=100.D0
+endif
+
+! new change 5.02.07                                            (end)
+
+HAIL_VENTILATION_COEF = fx
+
+  201   FORMAT(E13.5)
+  202   FORMAT(2E13.5)
+  203   FORMAT(3E13.5)
+  204   FORMAT(4E13.5)
+  205   FORMAT(5E13.5)
+  206   FORMAT(6E13.5)
+  207   FORMAT(7E13.5)
+
+return
+end function HAIL_VENTILATION_COEF
+
+! end of hail_ventilation_coef function
+!====================================================================
+! new change 24.08.04                                          (start)
+
+      FUNCTION GGESI(T)
+
+implicit double precision (a-h,o-z)
+
+intrinsic DLOG10
+!
+!     SATURATION VAPOR PRESSURE OVER ICE
+!      (GOFF AND GRATCH)
+!
+!     ESI     SATURATION VAPOR PRESSURE  (MB)
+!     T       TEMP  (KELVIN)
+!
+      DATA C1_MELT/-9.09718D0/C2_MELT/-3.56654D0/C3_MELT/0.876793D0/C4_MELT/0.78583503D0/
+!
+      A = 273.16D0/T
+      B = C1_MELT*(A-1.0D0)+C2_MELT*DLOG10(A)+C3_MELT*(1.0D0-1.0D0/A)+C4_MELT
+      GGESI = 10.0D0**B
+
+      RETURN
+      END FUNCTION GGESI
+
+! ending of GGESI function
+
+! new change 24.08.04                                           (end)
+!====================================================================
+! new change 24.08.04                                         (start)
+
+FUNCTION SNOW_VENTILATION_COEF(fnrex,fnumber, ARx)
+
+! new change 24.08.04                                           (end)
+
+implicit double precision (a-h,o-z)
+
+X_F = (fnrex**0.5D0) * (fnumber**(1.D0/3.D0))
+
+! new change 24.08.04                                         (start)
+
+if(ARx == 1.D0) then
+
+! real snow is not spherical, so this should not be used
+
+  IF(X_F < 1.4D0) then
+    fx = 1.D0 + 0.108D0*X_F*X_F
+  ELSE
+    fx = 0.78D0 + 0.308D0*X_F
+  ENDIF
+
+else
+
+! this is the correct formula for real snow
+
+! new change 24.08.04                                           (end)
+
+if(X_F.le.1.D0) then
+  fx=1.D0 + 0.14D0*X_F*X_F
+else
+  fx = 0.86D0 + 0.28D0*X_F
+endif
+
+endif
+
+if(fx < 1.D0) then
+  fx = 1.D0
+endif
+
+if(fx > 100.D0) then
+
+print *,'99992 stop:',fx,X_F,fnrex,fnumber, ARx
+fx = 100.D0
+!stop 99992
+endif
+
+SNOW_VENTILATION_COEF = fx
+
+return
+end function SNOW_VENTILATION_COEF
+
+! ending of SNOW_VENTILATION_COEF function
+!====================================================================
+! new change 24.08.04                                         (start)
+
+!REAL FUNCTION SURFACE_TEMP(eex, tempK, factor_vap, fvofh, XLS, RV)
+
+FUNCTION SURFACE_TEMP(eex, tempK, factor_vap, fvofh, XLS, RV)
+
+! new change 24.08.04                                           (end)
+ 
+implicit double precision (a-h,o-z)
+
+intrinsic  DEXP, DABS
+
+tsxold = 269.D0
+
+tsx = 270.D0
+
+tdiff = 1.D0
+
+ilj = 0
+
+alpha_ts = factor_vap*fvofh
+
+beta_ts = alpha_ts*eex/tempK
+
+do while(tdiff > 1.D-6)
+
+! esix_check=611.21D0*(DEXP((tsx-273.15)*XLS /(RV * tsx * 273.15)))
+
+   esix = 100.D0*GGESI(tsx)
+
+! print *, 'E_si = ', esix, ' Pa', ilj, esix_check
+
+  f_tsx = tempK - tsx - alpha_ts*esix/tsx + beta_ts
+
+  f_tsxold= &
+  tempK-tsxold-alpha_ts*100.D0*GGESI(tsxold)/tsxold+beta_ts
+
+  tsxnew = tsx - f_tsx*(tsx - tsxold)/(f_tsx - f_tsxold)
+
+  tsxold = tsx
+  tsx = tsxnew
+
+  tdiff = DABS(tsx - tsxold)
+
+  ilj = ilj + 1
+
+  if(ilj > 1e6) then
+    print *, &
+   'SURFACE_TEMP not converging', tsx,tempK,tdiff,fvofh,eex,esix
+    tsx = tempK
+    exit
+  endif
+
+enddo
+
+SURFACE_TEMP = tsx
+
+return
+END FUNCTION SURFACE_TEMP
+
+! ending of SURFACE_TEMP function
+
+! new change 24.08.04                                           (end)
+!====================================================================
+FUNCTION COLUMN_VENTILATION_COEF(fnrex, fnumber)
+
+implicit double precision (a-h,o-z)
+
+if(fnrex < 50.D0) then
+  X_F = (fnrex**0.5D0) * (fnumber**(1.D0/3.D0))
+else
+  X_F = (50.D0**0.5D0) * (fnumber**(1.D0/3.D0))
+endif
+
+fx=1.D0-0.00668D0*X_F/4.D0+2.39402D0*((X_F/4.D0)**2.D0)+ &
+   0.73409D0*((X_F/4.D0)**3.D0)-0.73911D0*((X_F/4.D0)**4.D0)
+
+if(fx < 1.D0) then
+  fx = 1.D0
+endif
+
+if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99993")
+
+COLUMN_VENTILATION_COEF = fx
+
+return
+end function COLUMN_VENTILATION_COEF
+
+! end of column_ventilation_coef function
+!====================================================================
+FUNCTION PLATE_VENTILATION_COEF(fnrex, fnumber)
+
+implicit double precision (a-h,o-z)
+
+if(fnrex < 150.D0) then
+  X_F = fnrex**0.5D0 * fnumber**(1.D0/3.D0)
+else
+  X_F = 150.D0**0.5D0 * fnumber**(1.D0/3.D0)
+endif
+
+fx=1.D0-0.06042D0*X_F/10.D0+2.79820D0*((X_F/10.D0)**2.D0) - &
+   0.31933D0*((X_F/10.D0)**3.D0)-0.06247D0*((X_F/10.D0)**4.D0)
+
+if(fx < 1.D0) then
+  fx = 1.D0
+endif
+
+if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99994")
+
+PLATE_VENTILATION_COEF = fx
+
+return
+end function PLATE_VENTILATION_COEF
+
+! end of plate_ventilation_coef function
+!====================================================================
+FUNCTION DENDRITE_VENTILATION_COEF(fnrex, fnumber)
+
+implicit double precision (a-h,o-z)
+
+if(fnrex < 150.D0) then
+  X_F = (fnrex**0.5D0) * (fnumber**(1.D0/3.D0))
+else
+  X_F = (150.D0**0.5D0) * (fnumber**(1.D0/3.D0))
+endif
+
+fx=1.D0+0.35463D0*X_F/10.D0+3.55338D0*((X_F/10.D0)**2.D0)
+
+if(fx < 1.D0) then
+  fx = 1.D0
+endif
+
+if(fx > 100.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99995")
+
+DENDRITE_VENTILATION_COEF = fx
+
+return
+end function DENDRITE_VENTILATION_COEF
+
+! end of dendrite_ventilation_coef function
+!====================================================================
+FUNCTION chi_fra(fra)
+
+implicit double precision (a-h,o-z)
+
+DIMENSION xxa(14), yya(14)
+
+pc = 100.D0 * fra
+
+if(pc.le.0.D0) then
+  chi_fra = 0.D0
+  return
+endif
+
+if(pc.ge.100.D0) then
+  chi_fra = 1.D0
+  return
+endif
+
+xxa(1) = 0.D0
+yya(1) = 0.D0
+xxa(2) = 10.D0
+yya(2) = 1.25D0
+xxa(3) = 20.D0
+yya(3) = 3.12D0
+xxa(4) = 30.D0
+yya(4) = 5.D0
+xxa(5) = 40.D0
+yya(5) = 8.12D0
+xxa(6) = 50.D0
+yya(6) = 11.87D0
+xxa(7) = 60.D0
+yya(7) = 17.49D0
+xxa(8) = 70.D0
+yya(8) = 24.36D0
+xxa(9) = 75.D0
+yya(9) = 28.73D0
+xxa(10) = 80.D0
+yya(10) = 34.98D0
+xxa(11) = 85.D0
+yya(11) = 43.72D0
+xxa(12) = 90.D0
+yya(12) = 56.84D0
+xxa(13) = 95.D0
+yya(13) = 73.08D0
+xxa(14) = 100.D0
+yya(14) = 100.D0
+
+ix_max = 14
+
+ix = 0
+
+pc_hi = 0.D0
+
+DO WHILE(pc_hi < pc)
+
+ix = ix + 1
+
+if(ix > ix_max) then
+ix = ix - 1
+exit
+endif
+
+pc_hi = xxa(ix)
+
+ENDDO
+
+! new change 24.08.04                                         (start)
+
+if(ix -1 < 1) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 42567")
+if(ix  > ix_max) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 42568")
+
+! new change 24.08.04                                           (end)
+
+chi_fra=yya(ix-1)+ &
+(pc-xxa(ix-1))*(yya(ix)-yya(ix-1))/(xxa(ix)-xxa(ix-1))
+
+chi_fra = chi_fra/100.D0
+
+if(chi_fra  < 0.D0) chi_fra  = 0.D0
+if(chi_fra  > 1.D0) chi_fra  = 1.D0
+
+! new change 24.08.04                                         (start)
+
+if(chi_fra > 0.3D0 .and. pc < 75.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 1478")
+if(chi_fra > 0.6D0 .and. pc < 90.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 1477")
+
+! new change 24.08.04                                           (end)
+
+RETURN
+END FUNCTION chi_fra
+
+! end of chi_fra function
+!====================================================================
+function fnre_sphere(xd)
+
+implicit double precision (a-h,o-z)
+
+INTRINSIC DLOG10
+
+ww1 = dlog10(xd)
+
+ww2 = ww1 * ww1
+ww3 = ww1 * ww1* ww1
+
+fnre_sphere = 0.d0
+
+if(xd < 73.D0) then
+  fnre_sphere = xd/24.D0
+endif
+
+if(xd < 562.D0.and.xd >= 73.D0) then
+  fnre_sphere = - 1.7095D0 + 1.33438D0*ww1 - 0.11591D0*ww2
+  fnre_sphere = 10.D0**fnre_sphere
+endif
+
+if(xd < 1.83D3.and.xd >= 562.D0) then
+  fnre_sphere= &
+  -1.81391D0 + 1.34671D0*ww1 - 0.12427D0*ww2 + 0.0063D0*ww3
+  fnre_sphere = 10.D0**fnre_sphere
+endif
+
+if(xd < 5.4D10.and.xd >= 1.83D3) then
+  fnre_sphere= &
+  0.003567D0*ww3 - 0.089620D0*ww2 + 1.225713D0*ww1 - 1.706026D0
+  fnre_sphere = 10.D0**fnre_sphere
+endif
+
+if(xd >= 5.4D10) then
+  fnre_sphere = (xd/0.1D0)**0.5D0
+endif
+
+end function fnre_sphere
+
+! end of fnre_sphere function
+!====================================================================
+function equilibrium_fallspeed (fm_s, fm_w_critx, XXL, vt_rain, &
+                                rhoax, etaax, a_eqm)
+implicit double precision (a-h,o-z)
+
+!PARAMETER(PI = 3.141592654D0, NKR = 43, GRAV = 9.8D0)
+PARAMETER(PI = 3.141592654D0, GRAV = 9.8D0)
+
+DIMENSION XXL(NKR), vt_rain(NKR)
+
+fnre_shed = 4800.D0 + 4831.5D0*1000.D0*fm_s
+
+if(fnre_shed >= 5000.D0.and.fnre_shed <= 2.5D4) then
+
+! a_d or a_eqm here?
+
+! new change 21.06.04                                         (start)
+
+  vt_eqm = 1.5D-5* fnre_shed/(2.D0*a_eqm)
+  
+! new change 21.06.04                                           (end)
+
+  vt_eqm = vt_eqm* ((1.20D0/rhoax)**0.5D0)
+
+  if(vt_eqm > 100.D0) then
+  !  print *, 'WARNING: vt_eqm exceeding 100 m/s', vt_eqm
+  !  print *, 'fnre_shed, etaax, rhoax, a_eqm ::', &
+  !  fnre_shed, etaax, rhoax, a_eqm
+  call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9999")
+  endif
+
+! in case fnre_shed >= 5000.D0.and.fnre_shed <= 2.5D4
+
+else
+
+! in case fnre_shed < 5000.D0.or.fnre_shed > 2.5D4
+
+  if(fnre_shed > 2.5D4) then
+
+    X_Best_crit=8.D0*(fm_s+fm_w_critx)*rhoax*GRAV/(PI*etaax*etaax)
+    fnre_fast=(X_Best_crit/0.6D0)**0.5D0
+    vt_eqm=fnre_fast*etaax/(2.D0*a_eqm*rhoax)
+
+! in case fnre_shed > 2.5D4
+
+  else
+
+! in case fnre_shed < 5000.D0
+
+    ILIQ = IFIND_IK (fm_s + fm_w_critx, XXL, finter_frac)
+
+    if(ILIQ < NKR ) then
+      vt_eqm = &
+      vt_rain(ILIQ)+finter_frac*(vt_rain(ILIQ+1)-vt_rain(ILIQ))
+    else
+      vt_eqm = vt_rain(NKR)
+    endif
+
+! in case fnre_shed < 5000.D0
+  endif
+
+! in case fnre_shed < 5000.D0.or.fnre_shed > 2.5D4
+endif
+
+equilibrium_fallspeed = vt_eqm
+
+end function equilibrium_fallspeed
+
+! end of equilibrium_fallspeed function
+!====================================================================
+FUNCTION IFIND_IK (fmass_target, fmass_array, fraction)
+
+implicit double precision (a-h,o-z)
+
+!PARAMETER(NKR = 43)
+
+DIMENSION fmass_array(NKR)
+
+IKX = 2
+
+DO WHILE(fmass_array(IKX) < fmass_target)
+   if(IKX > NKR - 1) exit
+   IKX = IKX + 1
+ENDDO
+
+IKX = IKX - 1
+
+fraction= &
+(fmass_target-fmass_array(IKX))/(fmass_array(IKX+1)-fmass_array(IKX))
+if(fraction < 0.D0) fraction = 0.D0
+if(fraction > 1.D0) fraction = 1.D0
+
+if(IKX > NKR.or.IKX < 1) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 99999")
+
+IFIND_IK = IKX
+
+END FUNCTION IFIND_IK
+
+! end of ifind_ik function
+!====================================================================
+FUNCTION COLUMN_AR (fmassx, rhoix)
+
+implicit double precision (a-h,o-z)
+
+parameter (PI = 3.141592654D0)
+
+! estimate equivalent diameter (mm)
+
+d_equiv = (fmassx/rhoix)/(4.D0*PI/3.D0)
+d_equiv = d_equiv**(1.D0/3.D0)
+d_equiv = 2.D0*d_equiv*1000.D0
+
+! apply Table 1 from Heymsfield (1972)
+
+if(d_equiv < 0.3D0) then
+  shape = 2.D0
+else
+  shape = d_equiv/(0.1973D0*(d_equiv**0.414D0))
+endif
+
+! Now improve the estimate of AR
+
+FL_i = 4.D0*shape*shape*(fmassx/rhoix)/PI
+FL_i = FL_i**(1.D0/3.D0)
+FL_i = FL_i* 1000.D0
+
+if(FL_i < 0.3D0) then
+  COLUMN_AR = 2.D0
+else
+  COLUMN_AR = FL_i/(0.1973D0*(FL_i**0.414D0))
+endif
+
+if(COLUMN_AR > 5.D0) COLUMN_AR = 5.D0
+
+return
+end function COLUMN_AR
+
+! end of COLUMN_AR function
+!====================================================================
+FUNCTION PLATE_AR (fmassx)
+
+implicit double precision (a-h,o-z)
+
+d_i = (fmassx/1.d-3)/0.03760d0
+d_i = d_i**(1.d0/3.31d0)
+d_i = d_i/100.d0
+h_i = 0.0141d0*( (d_i*100.d0)**0.474d0)
+h_i = h_i/100.d0
+
+PLATE_AR = h_i/d_i
+
+return
+end function  PLATE_AR
+
+! end of plate_ar function
+!====================================================================
+FUNCTION DENDRITE_AR(fmassx)
+
+implicit double precision (a-h,o-z)
+
+d_i = (fmassx/1.d-3)/0.00376D0
+d_i = d_i**(1.D0/2.79D0)
+d_i = d_i/100.D0
+h_i = 0.00996D0*((d_i*100.D0)** 0.415D0)
+h_i = h_i/100.D0
+
+DENDRITE_AR = h_i/d_i
+
+return
+end function DENDRITE_AR
+
+! end of dendrite_ar function
+!====================================================================
+FUNCTION COLUMN_CAP_ZERO (fm_ice, AR_ice, rho_ice, FLstar)
+
+implicit double precision (a-h,o-z)
+
+PARAMETER(PI = 3.141592654D0)
+
+INTRINSIC DLOG
+
+a_ix = (fm_ice/rho_ice)/(4.D0*PI*AR_ice/3.D0)
+a_ix = a_ix**(1.D0/3.D0)
+b_i = AR_ice*a_ix
+
+if(AR_ice < 0.D0.or.AR_ice < 1.D0) then
+call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9011")
+endif
+
+epsil_i = b_i*b_i - a_ix*a_ix
+
+if(epsil_i.le.0.D0) then
+!  print*, a_ix, b_i , fm_ice, AR_ice
+call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9044")
+endif
+
+epsil_i = epsil_i**0.5D0
+
+COLUMN_CAP_ZERO= (b_i+epsil_i)/a_ix
+COLUMN_CAP_ZERO = epsil_i /(DLOG(COLUMN_CAP_ZERO))
+
+omega_i = 2.D0*(PI*a_ix*a_ix) + 4.D0*b_i*a_ix
+
+P_i = 2.D0*PI*a_ix
+
+FLstar = omega_i/P_i
+
+return
+end function COLUMN_CAP_ZERO
+
+! end of column_cap_zero function
+!====================================================================
+FUNCTION PLANAR_CAP_ZERO (fm_ice, AR_ice, rho_ice, FLstar)
+
+implicit double precision (a-h,o-z)
+
+PARAMETER(PI = 3.141592654D0)
+
+! new change 29.06.04                                         (start)
+
+!INTRINSIC DLOG, DSIN
+INTRINSIC DLOG, DASIN
+
+! new change 29.06.04                                           (end)
+
+a_ix = (fm_ice/rho_ice)/(4.D0*PI*AR_ice/3.D0)
+a_ix = a_ix**(1.D0/3.D0)
+
+if(AR_ice < 0.D0.or.AR_ice > 1.D0) then
+ call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9022")
+endif
+
+epsil_i = 1.D0 - AR_ice*AR_ice
+
+if( epsil_i < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9086")
+
+epsil_i = epsil_i**0.5D0
+
+if(epsil_i > 0.D0) then
+
+! new change 29.06.04                                         (start)
+
+!  PLANAR_CAP_ZERO = a_ix*epsil_i/DSIN(epsil_i)
+  PLANAR_CAP_ZERO = a_ix*epsil_i/DASIN(epsil_i)
+
+! new change 29.06.04                                           (end)
+
+  if((1.D0+epsil_i)/(1.D0-epsil_i).le.0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9054")
+
+  omega_i = DLOG((1.D0+ epsil_i)/( 1.D0- epsil_i))
+  omega_i = 2.D0 + PI*AR_ice*(1.D0/epsil_i)*omega_i
+  omega_i = PI*a_ix*a_ix*omega_i
+
+  P_i = 2.D0*PI*a_ix
+  FLstar = omega_i/P_i
+
+else
+
+  PLANAR_CAP_ZERO = a_ix
+  FLstar = 2.D0*a_ix
+
+endif
+
+return
+end function PLANAR_CAP_ZERO
+
+! end of planar_cap_zero function
+!====================================================================
+FUNCTION rad_sphere (volume)
+
+implicit double precision (a-h,o-z)
+
+PARAMETER(PI = 3.141592654D0)
+
+rad_sphere = volume/(4.D0*PI/3.D0)
+rad_sphere = rad_sphere**(1.D0/3.D0)
+
+return
+end FUNCTION rad_sphere
+
+! end of rad_sphere function
+!====================================================================
+SUBROUTINE thermodynamical_limits &
+(FFX, fm_tot, rhoax, XLFOCP, tempx, dmeltx)
+
+implicit double precision (a-h,o-z)
+
+PARAMETER (COL=0.23105D0)
+
+! control in main program & others subroutines
+
+! new change 29.10.08                                         (start)           
+
+
+! new change 29.10.08                                           (end)
+
+
+
+! PROBLEMS HERE: is "fnumber_MR" correct
+! for the particle number mixing ratio ( /m3) ?
+
+
+
+fnumber_MR = 3.D0*FFX*fm_tot*COL/rhoax
+
+Q_ICE_MELTED = dmeltx*fnumber_MR
+
+temp_star = tempx - XLFOCP*Q_ICE_MELTED
+
+if(temp_star < 273.15D0) then
+
+  Q_ICE_MELTED = (tempx - 273.15D0)/XLFOCP
+  dmeltx = Q_ICE_MELTED / fnumber_MR
+  tempx = 273.15D0
+
+! in case temp_star < 273.15D0
+
+else
+
+! in case temp_star >= 273.15D0
+
+  tempx = temp_star
+
+
+endif
+
+101 FORMAT(1X,D13.5)
+102 FORMAT(1X,2D13.5)
+103 FORMAT(1X,3D13.5)
+104 FORMAT(1X,4D13.5)
+105 FORMAT(1X,5D13.5)
+106 FORMAT(1X,6D13.5)
+
+END SUBROUTINE thermodynamical_limits
+
+! end of thermodynamical_limits subroutine
+!====================================================================
+SUBROUTINE fmass_limits (dmeltx, ficemassx, fm_water, fm_tot)
+
+implicit double precision (a-h,o-z)
+
+INTRINSIC DABS
+
+! new change 29.10.08                                         (start)           
+
+
+! new change 29.10.08                                           (end)
+
+if(dmeltx > ficemassx) then
+  dmeltx = ficemassx
+endif
+
+if(dmeltx < 0.D0.and.DABS(dmeltx) > fm_water) then
+        dmeltx = - fm_water
+endif
+
+if(ficemassx - dmeltx > fm_tot) then
+  dmeltx = ficemassx - fm_tot
+endif
+
+
+101 FORMAT(1X,D13.5)
+102 FORMAT(1X,2D13.5)
+103 FORMAT(1X,3D13.5)
+104 FORMAT(1X,4D13.5)
+105 FORMAT(1X,5D13.5)
+106 FORMAT(1X,6D13.5)
+
+end subroutine fmass_limits
+
+! end of fmass_limits subroutine
+! Version of 3.06.04
+
+! new size distribution functions after evaporation
+
+	SUBROUTINE JERDFUN_MELT &
+
+     & (R2,R2N&
+     & ,FI2,PSI2&
+     & ,FL2_OLD,FL2_NEW&
+     & ,IND,ITYPE)
+! new change 29.09.10                                          (end)
+       implicit none     
+!       implicit double precision (a-h,o-z)
+       REAL DEL2N
+
+      INTEGER IND,ITYPE,KR,ICE,ITYP,NRM,NR,IDROP
+      INTEGER NRX,I_3POINT,ICE_TYPE
+     
+
+! include file
+
+!INCLUDE 'MICRO.PRM'
+
+ REAL &
+     &  R2(NKR,IND),R2N(NKR,IND) &
+     & ,FI2(NKR,IND),PSI2(NKR,IND) &
+     & ,FL2_OLD(NKR,IND),FL2_NEW(NKR,IND)
+
+! work arrays
+!      DOUBLE PRECISION TPN
+!      DOUBLE PRECISION  B21_MY(NKR,IND)
+        DOUBLE PRECISION R2R(NKR),R2NR(NKR),FI2R(NKR),PSI2R(NKR)
+        DOUBLE PRECISION DR2(NKR,IND),DR2N(NKR,IND)
+
+	DOUBLE PRECISION FL2R_OLD(NKR),FL2R_NEW(NKR)
+
+        NRX=NKR
+
+	IF(IND.NE.1) THEN
+	  ITYP=ITYPE
+        ELSE
+	  ITYP=1
+	ENDIF
+
+! recalculation of size distribution functions                (start)
+
+	DO ICE_TYPE=1,IND
+
+	   IF(ITYP.EQ.ICE_TYPE) THEN
+
+             DO KR=1,NKR
+
+	        R2R(KR)=R2(KR,ICE_TYPE)
+	        R2NR(KR)=R2N(KR,ICE_TYPE)               
+                FI2R(KR)=FI2(KR,ICE_TYPE)
+                PSI2R(KR)=FI2R(KR)
+                FL2R_OLD(KR)=FL2_OLD(KR,ICE_TYPE)
+                FL2R_NEW(KR)=FL2R_OLD(KR)
+                
+             ENDDO
+
+
+! new size distribution functions after evaporatiion          (start)
+
+! new change 12.06.06                                         (start)
+             I_3POINT=0
+! new change 12.06.06                                           (end)
+             CALL JERNEWF_MELT(NRX,R2R,R2NR,FI2R,PSI2R,FL2R_OLD,FL2R_NEW,I_3POINT)
+
+	     DO KR=1,NKR                              
+	        PSI2(KR,ICE_TYPE)=PSI2R(KR)
+                FL2_NEW(KR,ICE_TYPE)=FL2R_NEW(KR)
+	     ENDDO
+
+
+! in case ITYP.EQ.ICE_TYPE
+
+	   ENDIF
+
+        ENDDO
+
+! cycle by ICE_TYPE
+
+! recalculation of size distribution functions                  (end)
+
+! new size distribution functions                               (end)
+
+ 128    FORMAT(1X,I2,2D13.5) 
+
+	RETURN
+	END SUBROUTINE JERDFUN_MELT
+
+! end of SUBROUTINE JERDFUN_MELT
+        SUBROUTINE JERNEWF_MELT &
+! new change 27.10.08                                         (start)
+       (NRX,RR,RN,FI,PSI,FL_OLD,FL_NEW,I3POINT)
+ 
+        IMPLICIT NONE
+
+        INTEGER & 
+        KR
+
+
+        INTEGER & 
+        I,K,NRXP,I3POINT
+
+! new change 10.06.06                                         (start)
+        INTEGER & 
+        ISIGN_DIFFUSIONAL_GROWTH
+! new change 10.06.06                                           (end)
+ 
+        DOUBLE PRECISION &
+	AOLDCON,ANEWCON,AOLDMASS,ANEWMASS
+
+        DOUBLE PRECISION &
+        RNTMP,RRTMP,RRP,RRM,RNTMP2,RRTMP2,RRP2,RRM2, &
+        GN1,GN2,GN3,GN1P,GMAT,GMAT2
+
+        INTEGER & 
+        NRX
+
+        DOUBLE PRECISION & 
+        RR(NRX),FI(NRX),PSI(NRX),RN(NRX) &
+! new change 12.06.06                                         (start)
+       ,RRS(NRX+1),PSINEW(NRX+1)
+! new change 12.06.06                                           (end)
+
+        DOUBLE PRECISION & 
+        FL_OLD(NRX),FL_NEW(NRX)
+
+        DOUBLE PRECISION & 
+! new change 12.06.06                                         (start)
+        DROPMASS(NRX+1)
+! new change 12.06.06                                           (end)
+
+        DOUBLE PRECISION & 
+        PSI_IM,PSI_I,PSI_IP
+
+! INITIAL VALUES FOR SOME VARIABLES
+ 
+	NRXP=NRX+1
+
+        DO I=1,NRX
+
+! RN(I), g - new masses after condensation or evaporation
+
+           IF(RN(I).LT.0.0D0) THEN 
+             RN(I)=1.0D-50
+	     FI(I)=0.0D0
+           ENDIF
+
+        ENDDO
+
+	DO K=1,NRX
+	   PSI(K)=0.0D0
+! new change 12.06.06                                         (start)
+	   PSINEW(K)=0.0D0
+! new change 12.06.06                                           (end)
+	   RRS(K)=RR(K)
+           DROPMASS(K)=0.0D0
+	ENDDO
+	
+        RRS(NRXP)=RRS(NRX)*1024.0D0
+! new change 12.06.06                                         (start)
+        PSINEW(NRXP)=0.0D0
+! new change 12.06.06                                           (end)
+
+! new change 7.05.07                                         (start)
+        DROPMASS(NRXP)=0.0D0
+! new change 7.05.07                                           (end)
+ 
+! new change 10.06.06                                         (start)
+
+        ISIGN_DIFFUSIONAL_GROWTH=0
+
+	DO K=1,NRX
+           IF(RN(K).NE.RR(K)) THEN
+              ISIGN_DIFFUSIONAL_GROWTH=1
+              GOTO 2000
+           ENDIF
+        ENDDO
+
+ 2000   CONTINUE
+       
+        IF(ISIGN_DIFFUSIONAL_GROWTH.NE.0) THEN
+
+! new change 10.06.06                                           (end)
+
+! Kovetz-Olund method                                         (start)
+
+	  DO K=1,NRX
+
+             IF(FI(K).NE.0.0D0) THEN
+
+               I=1
+
+               DO WHILE &
+! new change 12.06.06                                         (start)
+                (.NOT.(RRS(I).LE.RN(K).AND.RRS(I+1).GT.RN(K)) &
+! new change 12.06.06                                           (end)
+                 .AND.I.LT.NRX)
+                  I=I+1
+	       ENDDO
+
+	       IF(RN(K).LT.RRS(1)) THEN
+
+                 RNTMP=RN(K)
+                 RRTMP=0.0D0
+                 RRP=RRS(1)
+    	         GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
+! new change 13.06.06                                         (start)
+                 PSINEW(1)=PSINEW(1)+FI(K)*RR(K)*GMAT2
+                 DROPMASS(1)= &
+                 DROPMASS(1)+FL_OLD(K)*RR(1)*FI(K)*RR(K)*GMAT2
+! new change 13.06.06                                           (end)
+
+               ELSE
+
+                 RNTMP=RN(K)
+                 RRTMP=RRS(I)
+                 RRP=RRS(I+1)
+	         GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
+	         GMAT=(RRP-RNTMP)/(RRP-RRTMP)
+! new change 13.06.06                                         (start)
+                 PSINEW(I)=PSINEW(I)+FI(K)*RR(K)*GMAT
+                 PSINEW(I+1)=PSINEW(I+1)+FI(K)*RR(K)*GMAT2
+
+                 DROPMASS(I)= &
+                 DROPMASS(I)+FL_OLD(K)*RR(I)*FI(K)*RR(K)*GMAT
+! new change 7.05.07                                         (start)
+!                 DROPMASS(I+1)= &
+!                 DROPMASS(I+1)+FL_OLD(K)*RR(I+1)*FI(K)*RR(K)*GMAT2
+                 DROPMASS(I+1)= &
+                 DROPMASS(I+1)+FL_OLD(K)*RRS(I+1)*FI(K)*RR(K)*GMAT2
+! new change 7.05.07                                         (start)
+! new change 13.06.06                                           (end)
+
+               ENDIF
+
+! in case FI(K).NE.0.0D0
+
+             ENDIF
+
+	  ENDDO
+
+! cycle by K
+
+          DO I=1,NRX
+! new change 12.06.06                                         (start)
+             PSI(I)=PSINEW(I)
+! new change 12.06.06                                           (end)
+             IF(PSI(I).NE.0.D0) THEN
+               FL_NEW(I)=DROPMASS(I)/RR(I)/PSI(I)
+             ELSE
+! new change 19.03.08                                         (start)
+!               FL_NEW(I)=1.0D0
+               FL_NEW(I)=0.0D0
+! new change 19.03.08                                           (end)
+             ENDIF
+          ENDDO
+               
+! Kovetz-Olund method                                           (end)
+
+! calculation both new total drop concentrations(after KO) and new 
+! total drop masses (after KO)
+
+	  AOLDCON=0.0D0
+	  ANEWCON=0.0D0
+	  AOLDMASS=0.0D0
+	  ANEWMASS=0.0D0
+	
+	  DO K=1,NRX
+	     AOLDCON=AOLDCON+FI(K)*RR(K)
+	     ANEWCON=ANEWCON+PSI(K)
+	     AOLDMASS=AOLDMASS+FI(K)*RR(K)*RN(K)
+	     ANEWMASS=ANEWMASS+PSI(K)*RR(K)
+	  ENDDO
+	  
+! new change 29.04.08                                         (start)                     
+!          IF(I3POINT.NE.0) THEN
+          IF(I3POINT.NE.0) GOTO 2001
+! new change 29.04.08                                           (end)
+ 
+	    DO K=1,NRX
+
+               IF(FI(K).NE.0.0D0) THEN
+
+                 IF(RRS(2).LT.RN(K)) THEN
+ 
+                   I=2
+
+                   DO  WHILE &
+                     (.NOT.(RRS(I).LT.RN(K).AND.RRS(I+1).GT.RN(K)) &
+                      .AND.I.LT.NRX)
+                       I=I+1
+	           ENDDO
+
+                   IF(I.LT.NRX-2) THEN
+
+                     RNTMP=RN(K)
+
+                     RRTMP=RRS(I)
+                     RRP=RRS(I+1)
+                     RRM=RRS(I-1)
+ 
+                     RNTMP2=RN(K+1)
+
+                     RRTMP2=RRS(I+1)
+                     RRP2=RRS(I+2)
+                     RRM2=RRS(I)
+ 
+                     GN1=(RRP-RNTMP)*(RRTMP-RNTMP)/(RRP-RRM)/ &
+                         (RRTMP-RRM)
+
+                     GN1P=(RRP2-RNTMP2)*(RRTMP2-RNTMP2)/ &
+                          (RRP2-RRM2)/(RRTMP2-RRM2)
+
+                     GN2=(RRP-RNTMP)*(RNTMP-RRM)/(RRP-RRTMP)/ &
+                         (RRTMP-RRM)
+ 
+	             GMAT=(RRP-RNTMP)/(RRP-RRTMP)
+
+                     GN3=(RRTMP-RNTMP)*(RRM-RNTMP)/(RRP-RRM)/ &
+                                                 (RRP-RRTMP)
+	             GMAT2=(RNTMP-RRTMP)/(RRP-RRTMP)
+
+                     PSI_IM=PSI(I-1)+GN1*FI(K)*RR(K)
+                     PSI_I=PSI(I)+(GN1P+GN2-GMAT)*FI(K+1)*RR(K+1)
+                     PSI_IP=PSI(I+1)+(GN3-GMAT2)*FI(K)*RR(K)
+                    
+                     IF(PSI_IM.GT.0.0D0) THEN
+
+                       IF(PSI_IP.GT.0.0D0) THEN
+
+                         IF(I.GT.2) THEN
+! smoothing criteria
+                           IF(PSI_IM.GT.PSI(I-2) &
+                          .AND.PSI_IM.LT.PSI_I &
+                          .AND.PSI(I-2).LT.PSI(I) &
+                          .OR.PSI(I-2).GE.PSI(I)) THEN
+
+                             PSI(I-1)=PSI_IM
+
+                             PSI(I)=PSI(I)+FI(K)*RR(K)*(GN2-GMAT)
+
+                             PSI(I+1)=PSI_IP
+! in case smoothing criteria
+                           ENDIF 
+! in case I.GT.2
+                         ENDIF
+
+! in case PSI_IP.GT.0.0D0
+
+	               ENDIF
+
+! in case PSI_IM.GT.0.0D0
+
+	             ENDIF
+! in case I.LT.NRX-2
+                   ENDIF
+
+! in case RRS(2).LT.RN(K)
+
+                 ENDIF
+ 
+! in case FI(K).NE.0.0D0
+
+               ENDIF
+
+ 1000          CONTINUE
+
+	    ENDDO
+! cycle by K
+	    AOLDCON=0.0D0
+	    ANEWCON=0.0D0
+	    AOLDMASS=0.0D0
+	    ANEWMASS=0.0D0
+
+	    DO K=1,NRX
+	       AOLDCON=AOLDCON+FI(K)*RR(K)
+	       ANEWCON=ANEWCON+PSI(K)
+	       AOLDMASS=AOLDMASS+FI(K)*RR(K)*RN(K)
+	       ANEWMASS=ANEWMASS+PSI(K)*RR(K)
+	    ENDDO
+
+! 3 point method                                                (end)
+
+! new change 29.04.08                                         (start)                     
+
+! in case I3POINT.NE.0
+
+!	  ENDIF
+
+ 2001     CONTINUE
+
+! new change 29.04.08                                           (end)
+
+! PSI(K) - new hydrometeor size distribution function
+
+	  DO K=1,NRX
+	     PSI(K)=PSI(K)/RR(K)
+	  ENDDO
+
+! new change 10.06.06                                         (start)
+
+! in case ISIGN_DIFFUSIONAL_GROWTH.NE.0
+
+        ELSE
+
+! in case ISIGN_DIFFUSIONAL_GROWTH.EQ.0
+
+! new change 10.06.06                                           (end)
+
+	  DO K=1,NRX
+	     PSI(K)=FI(K)
+	  ENDDO
+
+        ENDIF
+
+
+  201	FORMAT(1X,D13.5)
+  202	FORMAT(1X,2D13.5)
+  203	FORMAT(1X,3D13.5)
+  204	FORMAT(1X,4D13.5)
+  205	FORMAT(1X,5D13.5)
+  206	FORMAT(1X,6D13.5)
+  301   FORMAT(1X,I2,2X,D13.5)
+  302   FORMAT(1X,I2,2X,2D13.5)
+  303   FORMAT(1X,I2,2X,3D13.5)
+  304   FORMAT(1X,I2,2X,4D13.5)
+  305   FORMAT(1X,I2,2X,5D13.5)
+  306   FORMAT(1X,I2,2X,6D13.5)
+
+        RETURN 
+        END SUBROUTINE JERNEWF_MELT
+
+! SUBROUTINE JERNEWF_MELT
+! Version of 10.02.08 
+
+! new changes 10.02.08                                       (start)
+
+SUBROUTINE SHEDDING &
+
+(ihucm_flag&
+
+,FF1,XL,VTL &
+,FF4,XG,V4,VTG,FLIQFR_G,RHO_G &
+,FF5,XH,V5,VTH,FLIQFR_H,RHO_H &
+,TIN,rhoa,pres,DT,QQV)
+! new changes 25.01.08                                         (end)
+
+! new changes 10.02.08                                         (end)
+
+!===============================================!
+! EXPLICIT MELTING SCHEME                       !
+! Author: Vaughan T.J. PHILLIPS, August 2004    !
+! at Princeton University (AOS program)         !
+! and GFDL, NOAA/OAR, USA                       !
+!===============================================!
+
+implicit double precision (a-h,o-z)
+
+!PARAMETER(NKR=33, NK=129, ICEMAX=3)
+
+! new changes 25.01.08                                       (start)
+
+PARAMETER(COL=0.23105D0, CP=1004.7D0, RV=461.51D0, RD=287.039D0, &
+          EPS=RD/RV, FJOULES_IN_A_CAL=4.187D0, PI=3.141592654D0, &
+          AR_LIM=2.D0, GRAV=9.8D0, RHO_ICE=920.D0, &
+          RHO_WATER=1000.D0, FLIQFRAC_LIM=0.9D0, &
+          PETIT_PARAMETRE=1.D-10)
+	  
+! new changes 12.02.08                                       (start)
+PARAMETER(ISHEDDING_ON=1, IVT_ADJUST=1, IPRINTING=0, &
+          ITEMP_ADJUST=1, IEVAP_ADJUST=1, ISUBLIME_ADJUST=1)
+! new changes 12.02.08                                         (end)
+
+! new changes 25.01.08                                         (end)
+
+! control in main program & others subroutines
+
+! new changes 12.02.08                                       (start)
+
+DIMENSION FF1(NKR), XL(NKR), VTL(NKR)
+
+! new changes 10.02.08                                         (end)
+
+DIMENSION FF4(NKR),XG(NKR),V4(NKR), &
+          VTG(NKR),FLIQFR_G(NKR),RHO_G(NKR)
+
+DIMENSION FF5(NKR),XH(NKR),V5(NKR), &
+          VTH(NKR),FLIQFR_H(NKR),RHO_H(NKR)
+
+DIMENSION FF1_SI(NKR), XL_SI(NKR), & 
+          VTL_SI(NKR)
+
+DIMENSION FF4_SI(NKR),XG_SI(NKR),V4_SI(NKR), &
+          VTG_SI(NKR), RHO_G_SI(NKR)
+
+DIMENSION FF5_SI(NKR),XH_SI(NKR),V5_SI(NKR), &
+          VTH_SI(NKR), RHO_H_SI(NKR)
+	  
+INTRINSIC SUM
+
+
+If(TIN <= 273.15D0) then
+  RETURN
+ENDIF
+
+if(SUM(FF4) <= 0.D0.and.SUM(FF5) <= 0.D0) then
+
+  return
+  
+endif
+
+!=============================================================
+!       UNIT CONVERSION OF ALL INPUTS to SI
+!=============================================================
+
+if(ihucm_flag == 1) then
+
+RHO_G_SI = RHO_G*1000.D0
+RHO_H_SI = RHO_H*1000.D0
+
+XL_SI = XL/1000.D0
+XG_SI = XG/1000.D0
+XH_SI = XH/1000.D0
+
+
+VTL_SI = VTL/100.D0
+VTG_SI = VTG/100.D0
+VTH_SI = VTH/100.D0
+
+V4_SI = V4/100.D0
+V5_SI = V5/100.D0
+
+FF1_SI = 1.E9*FF1
+FF4_SI = 1.E9*FF4
+FF5_SI = 1.E9*FF5
+
+pres_SI = pres/10.D0
+rhoa_SI = rhoa*1000.D0
+
+! in case ihucm_flag == 1
+
+else
+
+! in case ihucm_flag.NE.1
+
+RHO_G_SI = RHO_G
+RHO_H_SI = RHO_H
+
+
+XL_SI = XL
+XG_SI = XG
+XH_SI = XH
+
+VTL_SI = VTL
+VTG_SI = VTG
+VTH_SI = VTH
+
+V4_SI = V4
+V5_SI = V5
+
+FF1_SI = FF1
+FF4_SI = FF4
+FF5_SI = FF5
+
+pres_SI = pres
+rhoa_SI = rhoa
+
+! in case ihucm_flag.NE.1
+
+endif
+
+!=============================================================
+!       INITIALISATION
+!=============================================================
+!
+V4_SI(:) = VTG_SI(:)
+V5_SI(:) = VTH_SI(:)
+
+ee = QQV*pres_SI/(EPS + QQV)
+
+es_zero = 611.21D0
+
+if(pres_SI > 200000.D0.or.pres_SI < 10000.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9071")
+
+D_V=0.211D0*((TIN/273.15D0)**1.94D0)*(101325.D0/pres_SI)/1.D4
+
+! D_V = 2.21D-5
+! FK_a = 2.40D-2
+
+FK_a =(5.69D0+0.017D0*(TIN-273.15D0))*1.0D-3*4.187D0
+
+! XLV = 2.50D6
+! XLF = 2.83D6 - XLV
+
+! The expressions for latent heats used by R&H, 1987,
+! seem more applicable to
+! T > 0degC than
+! those by P & K 1997, and more modern
+
+! XLV=597.3D0*((273.15D0/TIN)**(0.167D0+3.67D-4*TIN))
+
+XLV = 597.3D0
+XLV = XLV*FJOULES_IN_A_CAL*1000.D0
+XLS = 2.83D6
+
+!XLF=79.7+0.485D0*(TIN-273.15D0)-2.5D-3*(TIN-273.15D0)*(TIN-273.15D0)
+
+XLF = 79.7D0
+XLF = XLF*FJOULES_IN_A_CAL*1000.D0
+
+! FNSC=0.632D0
+
+etaa = (1.718D0 + 0.0049D0*(TIN-273.15D0) - &
+        1.2D-5*(TIN-273.15D0)*(TIN-273.15D0))*1.D-5
+
+! etaa/rhoa_SI = kinematic viscosity
+
+FNSC = etaa/(rhoa_SI*D_V)
+
+! FNPR=0.71D0
+
+ALPHA_H = FK_a/(CP*rhoa_SI)
+FNPR = etaa/(rhoa_SI*ALPHA_H)
+RHO_CRIT = 910.D0
+
+if(rhoa_SI > 2.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 111")
+
+if(rhoa_SI < 0.1D0) then
+!  print*, &
+! 'rhoa_SI < 0.1D0 kg/m3::TIN,rhoa_SI,PRES,DT,QQV = ', &
+!  TIN,rhoa_SI,pres_SI,DT,QQV
+  call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 112")
+endif
+
+if(RHO_H_SI(1) < 1.D0) then
+ ! print *, 'RHO_H_SI(1) < 1.D0kg/m3'
+  call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 113")
+endif
+
+TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), 1.D0, XLS, RV)
+if(TS > 273.15D0) TS = 273.15D0
+
+!=============================================================
+!               GRAUPEL (assumed to be spheres)
+!=============================================================
+
+ISIGN_GRAUPEL=1
+ISIGN_HAIL=0
+
+DO IK = 1, NKR
+
+   IK_MELT=IK
+   I_MELT=0
+
+if(TIN > 273.15D0) then
+
+IF(FLIQFR_G(IK).GE.1.D0.OR.FF4_SI(IK).LE.PETIT_PARAMETRE.OR. &
+TIN <= 273.15D0) THEN
+  IF(FLIQFR_G(IK) > 1.D0) FLIQFR_G(IK) = 1.D0
+CYCLE
+ENDIF
+!
+vt_start = 0.D0
+vt_end = 0.D0
+!
+rhoi = RHO_G_SI(IK)
+fm_i = XG_SI(IK)*(1.D0 - FLIQFR_G(IK))
+V_i = fm_i/rhoi
+
+fm_w = XG_SI(IK)*FLIQFR_G(IK)
+V_w = fm_w/RHO_WATER
+
+if(rhoi < RHO_CRIT) then
+  V_soakable = V_i - fm_i/RHO_ICE
+else
+  V_soakable = 0.D0
+endif
+
+a_i = rad_sphere(V_i)
+a_izero = rad_sphere(XG_SI(IK)/rhoi)
+fnre_dry = VTG_SI(IK) * 2.D0*rhoa_SI*a_izero/etaa
+
+! FIND RE (ie. CD) OF SMOOTH SPHERE OF SAME MASS
+!(fnre_smooth is invariant during melting)
+
+X_Best = 8.D0 * XG_SI(IK) * rhoa_SI * GRAV / (PI * etaa * etaa)
+fnre_smooth = fnre_sphere(X_Best)
+
+if(V_w < V_soakable) then
+
+  a_d = a_i
+  vt=VT_LOW_DENSITY_SOAKING &
+    (fnre_dry,fnre_smooth,VTG_SI(IK),a_i,a_izero,etaa,rhoa_SI)
+
+! in case V_w < V_soakable
+
+else
+
+! in case V_w >= V_soakable
+
+  a_d = rad_sphere(V_i + (V_w - V_soakable))
+  fm_w_soaked = RHO_WATER* V_soakable
+  fm_w_crit = (0.268D0 + (fm_i + fm_w_soaked) * 1.D3 * 0.1389D0)
+  fm_w_crit = fm_w_crit* 1.D-3
+  a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
+
+  if(rhoi < RHO_CRIT) then
+    vt_start = VT_LOW_DENSITY_TRANS &
+              (fnre_dry, fnre_smooth, &
+               VTG_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XG_SI(IK))
+  else
+    vt_start=VT_HIGH_DENSITY_TRANS &
+            (fnre_dry,fnre_smooth,VTG_SI(IK),a_izero,etaa,rhoa_SI)
+  endif
+
+  vt_end=equilibrium_fallspeed &
+        (fm_i+fm_w_soaked,fm_w_crit, &
+         XG(:),VTL_SI(:),rhoa_SI,etaa,a_crit)
+
+  frac_eqm=(fm_w-fm_w_soaked)/fm_w_crit
+
+  if(frac_eqm < 0.D0) frac_eqm = 0.D0
+  if(frac_eqm > 1.D0) frac_eqm = 1.D0
+
+  vt = vt_start + (vt_end - vt_start) * frac_eqm
+
+  if(vt < 0.D0) vt = 0.D0
+
+! in case V_w >= V_soakable
+
+endif
+
+! new changes 3.02.08                                        (start)
+
+if(ivt_G_H_interpol.ne.0) then
+
+  vt=VTG_SI(IK)+FLIQFR_G(IK)*(VTL_SI(IK) - VTG_SI(IK))
+  
+endif
+
+! new changes 3.02.08                                          (end)
+
+V4_SI(IK) = vt
+
+fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
+
+fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
+fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
+
+! new change 10.02.08                                        (start)
+
+if(FLIQFR_G(IK) <= 0.D0) then
+  TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
+else
+  TS = 273.15D0
+endif
+
+! new change 10.02.08                                          (end)
+
+if(TS > 273.15D0) TS = 273.15D0
+
+if(fnre < 6000.D0) then
+  CAP = a_d
+else
+  CAP = a_i
+endif
+
+if(FLIQFR_G(IK) <= FLIQFRAC_LIM) then
+
+  if(ISHEDDING_ON.eq.1) then
+
+    if(IPRINTING == 1) print *,' SHEDDING CODE(GRAUPEL)  '
+
+    CALL SHED_MELTWATER &
+   (fnre,rhoi,RHO_CRIT,XG_SI,FF4_SI,FLIQFR_G,XL_SI,FF1_SI,IK)
+
+  endif
+  
+! in case FLIQFR_G(IK) <= FLIQFRAC_LIM
+
+endif
+
+! in case TIN > 273.15D0
+
+endif
+
+ENDDO
+! cycle by IK
+!
+!=============================================================
+!               HAIL (assumed to be spheres)
+!=============================================================
+
+ISIGN_GRAUPEL=0
+ISIGN_HAIL=1
+
+DO IK = 1, NKR
+
+   IK_MELT=IK
+   I_MELT=0
+
+if(TIN > 273.15D0) then
+
+IF(FLIQFR_H(IK).GE.1.D0.OR.FF5_SI(IK).LE.PETIT_PARAMETRE.OR. &
+TIN <= 273.15D0) THEN
+  IF(FLIQFR_H(IK) > 1.D0) FLIQFR_H(IK) = 1.D0
+CYCLE
+ENDIF
+
+vt_start = 0.D0
+vt_end = 0.D0
+
+rhoi  = RHO_H_SI(IK)
+fm_i = XH_SI(IK)*(1.D0 - FLIQFR_H(IK))
+V_i = fm_i/rhoi
+
+fm_w = XH_SI(IK)*FLIQFR_H(IK)
+V_w = fm_w/RHO_WATER
+
+if(rhoi < RHO_CRIT) then
+  V_soakable = V_i - fm_i/RHO_ICE
+else
+  V_soakable = 0.D0
+endif
+
+a_i = rad_sphere(V_i)
+a_izero = rad_sphere(XH_SI(IK)/rhoi)
+
+! FIND RE OF SMOOTH SPHERE OF SAME MASS
+! (fnre_smooth is invariant during melting)
+
+if(IPRINTING == 1) print *, 'fnre_dry = ', fnre_dry
+
+fnre_dry=VTH_SI(IK)*2.D0*rhoa_SI*a_izero/etaa
+X_Best=8.D0*XH_SI(IK)*rhoa_SI*GRAV/(PI * etaa * etaa)
+fnre_smooth=fnre_sphere(X_Best)
+
+vt_justwet = 0.D0
+vt_justsoaked = 0.D0
+
+if(V_w < V_soakable) then
+
+! SOAKING OF WATER
+
+  a_d = a_i
+  vt=VT_LOW_DENSITY_SOAKING &
+    (fnre_dry,fnre_smooth,VTH_SI(IK),a_i,a_izero,etaa,rhoa_SI)
+
+! in case V_w < V_soakable
+
+else
+
+! in case V_w >= V_soakable
+
+  a_d = rad_sphere(V_i + (V_w - V_soakable))
+  fm_w_soaked = RHO_WATER* V_soakable
+  fm_w_crit=(0.268D0+(fm_i+fm_w_soaked)*1.D3*0.1389D0)
+  fm_w_crit = fm_w_crit* 1.D-3
+  a_crit = rad_sphere(V_i + fm_w_crit/RHO_WATER)
+
+!RH87: Just-wet terminal velocity - look at history
+!of same particle passing 0oC
+!(ie. 'just-wet' means when 0degC is just reached
+!by surface and melting commences):
+
+  if(rhoi < RHO_CRIT) then
+
+    vt_start = VT_LOW_DENSITY_TRANS &
+              (fnre_dry,fnre_smooth, &
+               VTH_SI(IK),a_izero,etaa,rhoa_SI,rhoi,XH_SI(IK))
+  else
+
+    vt_start = VT_HIGH_DENSITY_TRANS(fnre_dry, fnre_smooth, &
+    VTH_SI(IK), a_izero, etaa, rhoa_SI)
+
+  endif
+
+    vt_end=equilibrium_fallspeed &
+          (fm_i + fm_w_soaked, fm_w_crit, XH(:), &
+           VTL_SI(:), rhoa_SI, etaa, a_crit)
+
+! RH87: Interpolation based on fraction of equilibrium water
+! on surface
+
+    frac_eqm = (fm_w - fm_w_soaked)/fm_w_crit
+    if(frac_eqm < 0.D0) frac_eqm = 0.D0
+    if(frac_eqm > 1.D0) frac_eqm = 1.D0
+
+    vt = vt_start + (vt_end - vt_start) * frac_eqm
+
+    if(vt < 0.D0) then
+      if(IPRINTING == 1) print *, 'WARNING: vt < 0', vt
+      vt = 0.D0
+    endif
+
+    if(IPRINTING == 1) print *, &
+   'HERE 2:: vt_start,vt_end,a_izero/a_i= ', &
+             vt_start,vt_end,a_izero/a_i
+
+    if(IPRINTING == 1) print *, &
+   'HERE 2:: fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet', &
+             fnre_dry,fnre_smooth,vt_justsoaked,vt_justwet
+
+! in case V_w >= V_soakable
+
+endif
+
+! new changes 3.02.08                                        (start)
+
+if(ivt_G_H_interpol.ne.0) then
+
+  vt=VTH_SI(IK)+FLIQFR_H(IK)*(VTL_SI(IK) - VTH_SI(IK))
+  
+endif
+  
+! new changes 3.02.08                                          (end)
+
+V5_SI(IK) = vt
+
+fnre = vt * (2.D0 * a_d * rhoa_SI)/etaa
+
+! new change 5.02.07                                          (start)
+
+fv = HAIL_VENTILATION_COEF(fnre,FNSC,IK)
+fh = HAIL_VENTILATION_COEF(fnre,FNPR,IK)
+
+! new change 10.02.08                                         (start)
+
+if(FLIQFR_H(IK) <= 0.D0) then
+  TS = SURFACE_TEMP(ee, TIN, XLS*D_V/(FK_a*RV), fv/fh, XLS, RV)
+else
+  TS = 273.15D0
+endif
+
+! new change 10.02.08                                           (end)
+
+if(TS > 273.15D0) TS = 273.15D0
+
+if(fnre < 6000.D0) then
+  CAP = a_d
+else
+  CAP = a_i
+endif
+
+if(FLIQFR_H(IK) <= FLIQFRAC_LIM) then
+
+  if(ISHEDDING_ON.eq.1) then
+
+    CALL SHED_MELTWATER &
+   (fnre,rhoi,RHO_CRIT,XH_SI,FF5_SI,FLIQFR_H,XL_SI,FF1_SI,IK)
+
+! in case ISHEDDING_ON.eq.1
+
+  endif
+  
+! in case FLIQFR_H(IK) <= FLIQFRAC_LIM
+
+endif
+
+! in case TIN > 273.15D0
+
+endif
+
+ENDDO
+! cycle by IK
+
+!=============================================================
+!       UNIT CONVERSION OF ALL OUTPUTS from SI
+!=============================================================
+!
+if(ihucm_flag == 1) then
+
+  if(IVT_ADJUST == 1) then
+    V4 = 100.D0 * V4_SI
+    V5 = 100.D0 * V5_SI
+  endif
+
+  FF1 = 1.D-9*FF1_SI
+  FF4 = 1.D-9*FF4_SI
+  FF5 = 1.D-9*FF5_SI
+  
+! in case ihucm_flag == 1
+
+else
+
+! in case ihucm_flag.NE.1
+
+  if(IVT_ADJUST == 1) then
+    V4 = V4_SI
+    V5 = V5_SI
+  endif
+
+  FF1 = FF1_SI
+  FF4 = FF4_SI
+  FF5 = FF5_SI
+  
+! in case ihucm_flag.NE.1
+
+endif
+
+ 101 FORMAT(1X,D13.5)
+ 102 FORMAT(1X,2D13.5)
+ 103 FORMAT(1X,3D13.5)
+ 104 FORMAT(1X,4D13.5)
+ 105 FORMAT(1X,5D13.5)
+ 106 FORMAT(1X,6D13.5)
+ 107 FORMAT(1X,7D13.5)
+ 201 FORMAT(1X,I2,D13.5)
+ 202 FORMAT(1X,I2,2D13.5)
+ 203 FORMAT(1X,I2,3D13.5)
+ 204 FORMAT(1X,I2,4D13.5)
+
+END SUBROUTINE
+
+! end of shedding subroutine
+!====================================================================
+SUBROUTINE SHED_MELTWATER &
+(fnrex,rhoix,RHO_CRITX,XX,FFX,FLIQFR_X,XL_SI,FF1_SI,INK)
+
+implicit double precision (a-h,o-z)
+
+! new change 27.03.07                                         (start)
+
+!PARAMETER(NKR=33, &
+PARAMETER(PI=3.141592654D0, RHO_ICE=920D0, RHO_WATER=1000.D0, &
+
+! new change 27.03.07                                           (end)
+
+! new change 27.08.04                                         (start)
+
+IPRINTING=0, & 
+!IPRINTING=1, & 
+
+COL=0.23105D0, FMAX_DROP_MASS_FRACTION=0.5D0)
+
+! new change 27.08.04                                           (end)
+
+! new change 21.06.04                                         (start)
+
+! new change 30.10.04                                         (start)
+DIMENSION XX(NKR), XL_SI(NKR)
+DIMENSION FFX(NKR), FF1_SI(NKR), FLIQFR_X(NKR)
+
+DIMENSION fmass_ice(NKR), fmass_X(NKR)
+
+INTRINSIC DABS, SUM
+
+fm_i = XX(INK)*(1.D0 - FLIQFR_X(INK))
+
+V_i = fm_i/rhoix
+
+fm_w = XX(INK)*FLIQFR_X(INK)
+
+V_w = fm_w/RHO_WATER
+
+if(rhoix < RHO_CRITX) then
+  V_soakable = V_i - fm_i/RHO_ICE
+else
+  V_soakable = 0.D0
+endif
+
+if(V_w > V_soakable) then
+
+! new change 21.06.04                                         (start)
+
+! new change 21.06.04                                           (end)
+
+  fm_w_soaked = RHO_WATER*V_soakable
+  fm_w_crit=(0.268D0+(fm_i+fm_w_soaked)*1.D3*0.1389D0)
+  fm_w_crit = fm_w_crit*1.D-3
+
+! new change 22.06.04                                         (start)
+
+! new change 22.06.04                                           (end)
+
+  if(fm_w - fm_w_soaked > fm_w_crit) then
+
+! new change 21.06.04                                         (start)
+
+! new change 21.06.04                                           (end)
+
+    if(fnrex > 1.5D4) then
+      melting_mode = 2
+    else
+      if(fnrex > 1.D4 ) then
+        melting_mode = 3
+      else
+        melting_mode = 4
+      endif
+    endif
+
+    select case (melting_mode)
+
+       case(2)
+       d_w_shed = 1.5D-3
+
+       case(3)
+       d_w_shed = 3.D-3
+
+       case(4)
+       d_w_shed = 4.5E-3
+
+       case default
+
+ call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9999")
+
+    end select
+
+    drop_mass = RHO_WATER*(PI/6.D0)*(d_w_shed**3.D0)
+
+    if(drop_mass > fm_w_crit*FMAX_DROP_MASS_FRACTION) &
+    drop_mass = fm_w_crit*FMAX_DROP_MASS_FRACTION
+
+    fm_w_save=fm_w
+
+    if(melting_mode == 2) then
+
+      if(fnrex > 2.5D4) then
+
+! all melt-water on sfc is shed
+
+        fm_w = fm_w_soaked
+
+      else
+
+! small drops shed continuously
+
+        fm_w = fm_w_crit + fm_w_soaked
+
+      endif
+
+! in case melting_mode == 2
+
+    else
+
+! in case melting_mode.ne.2
+
+! intermittent shedding of up to FMAX_DROP_MASS_FRACTION
+! of exterior meltwater
+
+      fm_w =  fm_w - drop_mass
+
+! in case melting_mode.ne.2
+
+    endif
+
+    if(fm_w - fm_w_soaked > fm_w_crit) fm_w = fm_w_crit + fm_w_soaked
+
+    if(fm_w < fm_w_soaked) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9065")
+
+    fm_w_shed = fm_w_save - fm_w
+
+    ILIQ = IFIND_IK(drop_mass, XL_SI, frac_liq)
+
+    INEW = IFIND_IK(fm_w + fm_i, XX, frac)
+
+    if(INEW < INK) then
+
+! new change 21.06.04                                         (start)
+
+! new change 21.06.04                                           (end)
+
+      fmass_X(:)=FFX(:)*XX(:)*XX(:)*3.D0*COL
+      fmass_ice(:)=FFX(:)*XX(:)*(1.D0-FLIQFR_X(:))*XX(:)*3.D0*COL
+      fm_X_before = SUM(fmass_X)
+      fm_ice_before = SUM(fmass_ice)
+
+! take mass of water shed out of mass_X(IK) and place
+! in temporary reservoir 1
+
+      res_mass_shed =  FFX(INK) * fm_w_shed * XX(INK)*3.D0*COL
+      fmass_X(INK) = fmass_X(INK) - res_mass_shed
+
+      if(fmass_X(INK) < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8020")
+      if(res_mass_shed < 0.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8021")
+
+! take all remaining water out of mass_X/mass_ice and place
+! in temporary reservoirs 2 and 3
+
+      res_mass_X = fmass_X(INK)
+      fmass_X(INK) = 0.D0
+      res_mass_ice = fmass_ice(INK)
+      fmass_ice(INK) = 0.D0
+
+! transfer water of reservoir 2 into the two size-bins adjacent
+! to fm_w+m_i
+
+      fmass_X(INEW)=fmass_X(INEW )+(1.D0-frac)*res_mass_X
+      fmass_X(INEW+1)=fmass_X(INEW+1)+frac*res_mass_X
+      res_mass_X = 0.D0
+
+! transfer ice of reservoir 3 into the two size-bins adjacent
+! to fm_w+m_i
+
+      fmass_ice(INEW)=fmass_ice(INEW)+(1.D0-frac)*res_mass_ice
+      fmass_ice(INEW+1)=fmass_ice(INEW+1)+frac*res_mass_ice
+      res_mass_ice=0.D0
+
+! transfer shed water of reservoir 1 into liquid bins
+
+      FF1_SI(ILIQ)=FF1_SI(ILIQ)+ &
+      res_mass_shed/(XL_SI(ILIQ)*XL_SI(ILIQ)*3.D0*COL)
+
+      FFX(INEW)=fmass_X (INEW)/(XX(INEW)*XX(INEW)*3.D0*COL)
+      FFX(INEW+1)=fmass_X (INEW+1)/(XX(INEW+1)*XX(INEW+1)*3.D0*COL)
+      FFX(INK)=fmass_X (INK)/(XX(INK)*XX(INK)*3.D0*COL)
+
+      if(FFX(INEW) > 0.D0) then
+      
+        FLIQFR_X(INEW)= &
+        1.D0-fmass_ice (INEW)/(XX(INEW)*FFX(INEW)*XX(INEW)*3.D0*COL)
+	
+! new change 9.12.07                                          (start)
+        if(DABS(FLIQFR_X(INEW)) < 1.0D-3) FLIQFR_X(INEW)= 0.0D0 
+! new change 9.12.07                                            (end)
+
+      else
+
+        FLIQFR_X(INEW) = 1.D0
+
+      endif
+
+      if(FFX(INEW+1) > 0.D0) then
+
+        FLIQFR_X(INEW+1)=1.D0 - &
+                         fmass_ice(INEW+1)/ &
+                        (XX(INEW+1)*FFX(INEW+1)*XX(INEW+1)*3.D0*COL)
+! new change 9.12.07                                          (start)
+        if(DABS(FLIQFR_X(INEW+1)) < 1.0D-3) FLIQFR_X(INEW+1)= 0.0D0 
+! new change 9.12.07                                            (end)
+
+      else
+
+        FLIQFR_X(INEW+1) = 1.D0
+
+      endif
+
+      if(FFX(INK) > 0.D0) then
+
+        FLIQFR_X(INK)=1.D0 - fmass_ice(INK)/ &
+                            (XX(INK)*FFX(INK)*XX(INK)*3.D0*COL)
+! new change 9.12.07                                          (start)
+        if(DABS(FLIQFR_X(INK)) < 1.0D-3) FLIQFR_X(INK)= 0.0D0 
+! new change 9.12.07                                            (end)
+
+      else
+
+        FLIQFR_X(INK) = 1.D0
+
+      endif
+
+! new change 21.06.04                                         (start)
+
+! new change 21.06.04                                           (end)
+
+! new change 9.12.07                                          (start)
+
+!      if(FLIQFR_X(INEW) < 0.D0.or.FLIQFR_X(INEW) > 1.D0) stop 8003
+
+      if(FLIQFR_X(INEW) < 0.D0.or.FLIQFR_X(INEW) > 1.D0) THEN
+      
+      !  PRINT*, 'IJK,KX,KZ,INK,INEW'
+      !  PRINT*,  IJK,KX,KZ,INK,INEW
+!	
+!        PRINT*,   'FLIQFR_X(INEW)'
+!        PRINT 106, FLIQFR_X(INEW)
+!	
+!        PRINT*,   'XX(INEW),FFX(INEW),fmass_ice(INEW)'
+!        PRINT 106, XX(INEW),FFX(INEW),fmass_ice(INEW)
+!	
+!	PRINT*, &
+!       'STOP 8003: FLIQFR_X(INEW) < 0.D0.or.FLIQFR_X(INEW) > 1.D0'
+       
+          call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8003")
+	
+      endif
+	
+! new change 9.12.07                                            (end)
+ 
+      if(FLIQFR_X(INEW+1) < 0.D0.or.FLIQFR_X(INEW+1) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8004")
+      if(FLIQFR_X(INK) < 0.D0.or.FLIQFR_X(INK) > 1.D0) call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 8005")
+
+      fmass_X(:)=FFX(:)*XX(:)*XX(:)*3.D0*COL
+      fmass_ice(:)=FFX(:)*XX(:)*(1.D0-FLIQFR_X(:))*XX(:)*3.D0*COL
+
+      fm_X_after = SUM(fmass_X)
+      fm_ice_after = SUM(fmass_ice)
+
+      if(fm_ice_before > 0.D0) then
+
+        fjunk = (fm_ice_after/fm_ice_before-1.D0)*100.D0
+
+! new change 9.12.07                                          (start)
+
+! new change 21.06.04                                           (end)
+
+!       if(DABS(fjunk) > 1.D0) stop 8011
+
+! in case fm_ice_before > 0.D0
+
+      endif
+
+      if(fm_X_before > 0.D0) then
+
+        fjunk=((fm_X_after+res_mass_shed)/fm_X_before-1.D0)*100.D0
+
+! new change 21.06.04                                         (start)
+! new change 21.06.04                                           (end)
+
+!       if(DABS(fjunk) > 1.D0) stop 8012
+
+! in case fm_X_before > 0.D0
+
+      endif
+
+! new change 21.06.04                                         (start)
+
+! new change 21.06.04                                           (end)
+
+! in case INEW < INK
+
+    else
+
+! in case INEW >= INK
+
+! new change 21.06.04                                          (start)
+
+   !   print*, & 
+
+ !'STOP: drop_mass is too large compared to total mass of particle'
+
+ !     print*,   'INEW >= INK'
+
+ !     print*,   'INEW,INK'
+ !     print*,    INEW,INK 
+
+ !     print*,   'drop_mass,fm_i+fm_w' 
+ !     print 106, drop_mass,fm_i+fm_w
+
+       call wrf_error_fatal("fatal error in module_mp_full_sbm , model stop 9089")
+      
+! new change 21.06.04                                            (end)
+
+! in case INEW >= INK
+
+    endif
+
+! in case fm_w - fm_w_soaked > fm_w_crit
+
+  endif
+
+! in case V_w > V_soakable
+
+endif
+
+! new change 21.06.04                                          (start)
+
+106 FORMAT(1X,6D13.5)
+
+! new change 21.06.04                                            (end)
+
+END SUBROUTINE
+
+! end of shed_meltwater subroutine
+!====================================================================
+! from module_mp_morr_two_moment.F
+      subroutine refl10cm_hm (qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, &
+                      t1d, p1d, dBZ, kts, kte, ii, jj)
+
+      IMPLICIT NONE
+
+!..Sub arguments
+      INTEGER, INTENT(IN):: kts, kte, ii, jj
+      REAL, DIMENSION(kts:kte), INTENT(IN)::                            &
+                      qv1d, qr1d, nr1d, qs1d, ns1d, qg1d, ng1d, t1d, p1d
+      REAL, DIMENSION(kts:kte), INTENT(INOUT):: dBZ
+
+!..Local variables
+      REAL, DIMENSION(kts:kte):: temp, pres, qv, rho
+      REAL, DIMENSION(kts:kte):: rr, nr, rs, ns, rg, ng
+
+      DOUBLE PRECISION, DIMENSION(kts:kte):: ilamr, ilamg, ilams
+      DOUBLE PRECISION, DIMENSION(kts:kte):: N0_r, N0_g, N0_s
+      DOUBLE PRECISION:: lamr, lamg, lams
+      LOGICAL, DIMENSION(kts:kte):: L_qr, L_qs, L_qg
+
+      REAL, DIMENSION(kts:kte):: ze_rain, ze_snow, ze_graupel
+      DOUBLE PRECISION:: fmelt_s, fmelt_g
+      DOUBLE PRECISION:: cback, x, eta, f_d
+
+      INTEGER:: i, k, k_0, kbot, n
+      LOGICAL:: melti
+
+!+---+
+
+      do k = kts, kte
+         dBZ(k) = -35.0
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Put column of data into local arrays.
+!+---+-----------------------------------------------------------------+
+      do k = kts, kte
+         temp(k) = t1d(k)
+         qv(k) = MAX(1.E-10, qv1d(k))
+         pres(k) = p1d(k)
+         rho(k) = 0.622*pres(k)/(R_MORR*temp(k)*(qv(k)+0.622))
+
+         if (qr1d(k) .gt. 1.E-9) then
+            rr(k) = qr1d(k)*rho(k)
+            nr(k) = nr1d(k)*rho(k)
+            lamr = (xam_r*xcrg(3)*xorg2*nr(k)/rr(k))**xobmr
+            ilamr(k) = 1./lamr
+            N0_r(k) = nr(k)*xorg2*lamr**xcre(2)
+            L_qr(k) = .true.
+         else
+            rr(k) = 1.E-12
+            nr(k) = 1.E-12
+            L_qr(k) = .false.
+         endif
+
+         if (qs1d(k) .gt. 1.E-9) then
+            rs(k) = qs1d(k)*rho(k)
+            ns(k) = ns1d(k)*rho(k)
+            lams = (xam_s*xcsg(3)*xosg2*ns(k)/rs(k))**xobms
+            ilams(k) = 1./lams
+            N0_s(k) = ns(k)*xosg2*lams**xcse(2)
+            L_qs(k) = .true.
+         else
+            rs(k) = 1.E-12
+            ns(k) = 1.E-12
+            L_qs(k) = .false.
+         endif
+
+         if (qg1d(k) .gt. 1.E-9) then
+            rg(k) = qg1d(k)*rho(k)
+            ng(k) = ng1d(k)*rho(k)
+            lamg = (xam_g*xcgg(3)*xogg2*ng(k)/rg(k))**xobmg
+            ilamg(k) = 1./lamg
+            N0_g(k) = ng(k)*xogg2*lamg**xcge(2)
+            L_qg(k) = .true.
+         else
+            rg(k) = 1.E-12
+            ng(k) = 1.E-12
+            L_qg(k) = .false.
+         endif
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Locate K-level of start of melting (k_0 is level above).
+!+---+-----------------------------------------------------------------+
+      melti = .false.
+      k_0 = kts
+      do k = kte-1, kts, -1
+         if ( (temp(k).gt.273.15) .and. L_qr(k)                         &
+                                  .and. (L_qs(k+1).or.L_qg(k+1)) ) then
+            k_0 = MAX(k+1, k_0)
+            melti=.true.
+            goto 195
+         endif
+      enddo
+ 195  continue
+
+!+---+-----------------------------------------------------------------+
+!..Assume Rayleigh approximation at 10 cm wavelength. Rain (all temps)
+!.. and non-water-coated snow and graupel when below freezing are
+!.. simple. Integrations of m(D)*m(D)*N(D)*dD.
+!+---+-----------------------------------------------------------------+
+
+      do k = kts, kte
+         ze_rain(k) = 1.e-22
+         ze_snow(k) = 1.e-22
+         ze_graupel(k) = 1.e-22
+         if (L_qr(k)) ze_rain(k) = N0_r(k)*xcrg(4)*ilamr(k)**xcre(4)
+         if (L_qs(k)) ze_snow(k) = (0.176/0.93) * (6.0/PI_MORR)*(6.0/PI_MORR)     &
+                                 * (xam_s/900.0)*(xam_s/900.0)          &
+                                 * N0_s(k)*xcsg(4)*ilams(k)**xcse(4)
+         if (L_qg(k)) ze_graupel(k) = (0.176/0.93) * (6.0/PI_MORR)*(6.0/PI_MORR)  &
+                                    * (xam_g/900.0)*(xam_g/900.0)       &
+                                    * N0_g(k)*xcgg(4)*ilamg(k)**xcge(4)
+      enddo
+
+!+---+-----------------------------------------------------------------+
+!..Special case of melting ice (snow/graupel) particles.  Assume the
+!.. ice is surrounded by the liquid water.  Fraction of meltwater is
+!.. extremely simple based on amount found above the melting level.
+!.. Uses code from Uli Blahak (rayleigh_soak_wetgraupel and supporting
+!.. routines).
+!+---+-----------------------------------------------------------------+
+
+      if (melti .and. k_0.ge.kts+1) then
+       do k = k_0-1, kts, -1
+
+!..Reflectivity contributed by melting snow
+          if (L_qs(k) .and. L_qs(k_0) ) then
+           fmelt_s = MAX(0.005d0, MIN(1.0d0-rs(k)/rs(k_0), 0.99d0))
+           eta = 0.d0
+           lams = 1./ilams(k)
+           do n = 1, nrbins
+              x = xam_s * xxDs(n)**xbm_s
+              call rayleigh_soak_wetgraupel (x,DBLE(xocms),DBLE(xobms), &
+                    fmelt_s, melt_outside_s, m_w_0, m_i_0, lamda_radar, &
+                    CBACK, mixingrulestring_s, matrixstring_s,          &
+                    inclusionstring_s, hoststring_s,                    &
+                    hostmatrixstring_s, hostinclusionstring_s)
+              f_d = N0_s(k)*xxDs(n)**xmu_s * DEXP(-lams*xxDs(n))
+              eta = eta + f_d * CBACK * simpson(n) * xdts(n)
+           enddo
+           ze_snow(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
+          endif
+
+
+!..Reflectivity contributed by melting graupel
+
+          if (L_qg(k) .and. L_qg(k_0) ) then
+           fmelt_g = MAX(0.005d0, MIN(1.0d0-rg(k)/rg(k_0), 0.99d0))
+           eta = 0.d0
+           lamg = 1./ilamg(k)
+           do n = 1, nrbins
+              x = xam_g * xxDg(n)**xbm_g
+              call rayleigh_soak_wetgraupel (x,DBLE(xocmg),DBLE(xobmg), &
+                    fmelt_g, melt_outside_g, m_w_0, m_i_0, lamda_radar, &
+                    CBACK, mixingrulestring_g, matrixstring_g,          &
+                    inclusionstring_g, hoststring_g,                    &
+                    hostmatrixstring_g, hostinclusionstring_g)
+              f_d = N0_g(k)*xxDg(n)**xmu_g * DEXP(-lamg*xxDg(n))
+              eta = eta + f_d * CBACK * simpson(n) * xdtg(n)
+           enddo
+           ze_graupel(k) = SNGL(lamda4 / (pi5 * K_w) * eta)
+          endif
+
+       enddo
+      endif
+
+      do k = kte, kts, -1
+         dBZ(k) = 10.*log10((ze_rain(k)+ze_snow(k)+ze_graupel(k))*1.d18)
+      enddo
+
+
+      end subroutine refl10cm_hm
+
+      END MODULE module_mp_full_sbm
diff --git a/wrfv2_fire/phys/module_mp_milbrandt2mom.F b/wrfv2_fire/phys/module_mp_milbrandt2mom.F
index 32f4e18a..c80e8ac5 100644
--- a/wrfv2_fire/phys/module_mp_milbrandt2mom.F
+++ b/wrfv2_fire/phys/module_mp_milbrandt2mom.F
@@ -11,22 +11,19 @@
 !  updates to the code (before the next offical WRF release) please contact     !
 !  Jason Milbrandt (Environment Canada) at jason.milbrandt@ec.gc.ca             !
 !                                                                               !
-!  Last modified:  2011-03-02                                                   !
+!  Last modified:  2014-03-19                                                   !
 !_______________________________________________________________________________!
 
 module my_fncs_mod
 
 !==============================================================================!
 !  The following functions are used by the schemes in the multimoment package. !
-!                                                                              !
-!  Package version:  2.19.0      (internal bookkeeping)                        !
-!  Last modified  :  2009-04-27                                                !
 !==============================================================================!
 
    implicit none
 
    private
-   public  :: NccnFNC,SxFNC,gamma,gammaDP,gser,gammln,gammp,cfg,gamminc
+   public  :: NccnFNC,SxFNC,gamma,gser,gammln,gammp,cfg,gamminc,polysvp,qsat
 
    contains
 
@@ -203,149 +200,6 @@ real FUNCTION gamma(xx)
 
  END FUNCTION gamma
 !======================================================================!
-! ! !
-! ! ! -- USED BY DIAGNOSTIC-ALPHA DOUBLE-MOMENT (SINGLE-PRECISION) VERSION --
-! ! !      FOR FUTURE VERSIONS OF M-Y PACKAGE WITH, THIS S/R CAN BE USED
-! ! !
-! ! !  real FUNCTION diagAlpha(Dm,x)
-! ! !
-! ! !   IMPLICIT NONE
-! ! !
-! ! !   integer :: x
-! ! !   real    :: Dm
-! ! !   real, dimension(5) :: c1,c2,c3,c4
-! ! !   real, parameter    :: pi = 3.14159265
-! ! !   real, parameter    :: alphaMAX= 80.e0
-! ! !   data c1 /19.0, 12.0, 4.5, 5.5, 3.7/
-! ! !   data c2 / 0.6,  0.7, 0.5, 0.7, 0.3/
-! ! !   data c3 / 1.8,  1.7, 5.0, 4.5, 9.0/
-! ! !   data c4 /17.0, 11.0, 5.5, 8.5, 6.5/
-! ! !   diagAlpha= c1(x)*tanh(c2(x)*(1.e3*Dm-c3(x)))+c4(x)
-! ! !   if (x==5.and.Dm>0.008) diagAlpha= 1.e3*Dm-2.6
-! ! !   diagAlpha= min(diagAlpha, alphaMAX)
-! ! !
-! ! !  END function diagAlpha
-! ! !
-! ! ! !======================================================================!
-! ! !
-! ! ! -- USED BY DIAGNOSTIC-ALPHA DOUBLE-MOMENT (SINGLE-PRECISION) VERSION --
-! ! !      FOR FUTURE VERSIONS OF M-Y PACKAGE WITH, THIS S/R CAN BE USED
-! ! !
-! ! !  real FUNCTION solveAlpha(Q,N,Z,Cx,rho)
-! ! !
-! ! !  IMPLICIT NONE
-! ! !
-! ! ! ! PASSING PARAMETERS:
-! ! !   real, intent(IN) :: Q, N, Z, Cx, rho
-! ! !
-! ! ! ! LOCAL PARAMETERS:
-! ! !   real             :: a,g,a1,g1,g2,tmp1
-! ! !   integer          :: i
-! ! !   real, parameter  :: alphaMax= 40.
-! ! !   real, parameter  :: epsQ    = 1.e-14
-! ! !   real, parameter  :: epsN    = 1.e-3
-! ! !   real, parameter  :: epsZ    = 1.e-32
-! ! !
-! ! ! !  Q         mass mixing ratio
-! ! ! !  N         total concentration
-! ! ! !  Z         reflectivity
-! ! ! !  Cx        (pi/6)*RHOx
-! ! ! !  rho       air density
-! ! ! !  a         alpha (returned as solveAlpha)
-! ! ! !  g         function g(a)= [(6+a)(5+a)(4+a)]/[(3+a)(2+a)(1+a)],
-! ! ! !              where g = (Cx/(rho*Q))**2.*(Z*N)
-! ! !
-! ! !
-! ! !   if (Q==0. .or. N==0. .or. Z==0. .or. Cx==0. .or. rho==0.) then
-! ! !   ! For testing/debugging only; this module should never be called
-! ! !   ! if the above condition is true.
-! ! !     print*,'*** STOPPED in MODULE ### solveAlpha *** '
-! ! !     print*,'*** : ',Q,N,Z,Cx*1.9099,rho
-! ! !     stop
-! ! !   endif
-! ! !
-! ! !   IF (Q>epsQ .and. N>epsN .and. Z>epsZ ) THEN
-! ! !
-! ! !      tmp1= Cx/(rho*Q)
-! ! !      g   = tmp1*Z*tmp1*N    ! g = (Z*N)*[Cx / (rho*Q)]^2
-! ! !
-! ! !  !Note: The above order avoids OVERFLOW, since tmp1*tmp1 is very large
-! ! !
-! ! ! !----------------------------------------------------------!
-! ! ! ! !Solve alpha numerically: (brute-force; for testing only)
-! ! ! !      a= 0.
-! ! ! !      g2= 999.
-! ! ! !      do i=0,4000
-! ! ! !         a1= i*0.01
-! ! ! !         g1= (6.+a1)*(5.+a1)*(4.+a1)/((3.+a1)*(2.+a1)*(1.+a1))
-! ! ! !         if(abs(g-g1)=20.) then
-! ! !        a= 0.
-! ! !      else
-! ! !        g2= g*g
-! ! !        if (g<20.  .and.g>=13.31) a= 3.3638e-3*g2 - 1.7152e-1*g + 2.0857e+0
-! ! !        if (g<13.31.and.g>=7.123) a= 1.5900e-2*g2 - 4.8202e-1*g + 4.0108e+0
-! ! !        if (g<7.123.and.g>=4.200) a= 1.0730e-1*g2 - 1.7481e+0*g + 8.4246e+0
-! ! !        if (g<4.200.and.g>=2.946) a= 5.9070e-1*g2 - 5.7918e+0*g + 1.6919e+1
-! ! !        if (g<2.946.and.g>=1.793) a= 4.3966e+0*g2 - 2.6659e+1*g + 4.5477e+1
-! ! !        if (g<1.793.and.g>=1.405) a= 4.7552e+1*g2 - 1.7958e+2*g + 1.8126e+2
-! ! !        if (g<1.405.and.g>=1.230) a= 3.0889e+2*g2 - 9.0854e+2*g + 6.8995e+2
-! ! !        if (g<1.230) a= alphaMax
-! ! !      endif
-! ! !
-! ! !      solveAlpha= max(0.,min(a,alphaMax))
-! ! !
-! ! !   ELSE
-! ! !
-! ! !      solveAlpha= 0.
-! ! !
-! ! !   ENDIF
-! ! !
-! ! !  END FUNCTION solveAlpha
-!======================================================================!
-
- FUNCTION gammaDP(xx)
-
-!  Modified from "Numerical Recipes"
-
-  IMPLICIT NONE
-
-! PASSING PARAMETERS:
-  DOUBLE PRECISION, INTENT(IN) :: xx
-
-! LOCAL PARAMETERS:
-  DOUBLE PRECISION  :: gammaDP
-  INTEGER  :: j
-  DOUBLE PRECISION  :: ser,stp,tmp,x,y,cof(6)
-
-
-  SAVE cof,stp
-  DATA cof,stp/76.18009172947146d0,-86.50532032941677d0,               &
-       24.01409824083091d0,-1.231739572450155d0,.1208650973866179d-2,  &
-       -.5395239384953d-5,2.5066282746310005d0/
-  x=xx
-  y=x
-  tmp=x+5.5d0
-  tmp=(x+0.5d0)*log(tmp)-tmp
-  ser=1.000000000190015d0
-! do j=1,6   !original
-  do j=1,4
-!!do j=1,3   !gives result to within ~ 3 %
-     y=y+1.d0
-     ser=ser+cof(j)/y
-  enddo
-  gammaDP=tmp+log(stp*ser/x)
-  gammaDP= exp(gammaDP)
-
- END FUNCTION gammaDP
-!======================================================================!
 
  SUBROUTINE gser(gamser,a,x,gln)
 
@@ -494,501 +348,771 @@ real FUNCTION gamminc(p,xmax)
  gamminc= gammp(p,xmax)*exp(gammln(p))
 
  end FUNCTION gamminc
-
-!======================================================================!
-!  real function x_tothe_y(x,y)
-!
-!     implicit none
-!     real, intent(in) :: x,y
-!     x_tothe_y= exp(y*log(x))
-!
-!  end function x_tothe_y
 !======================================================================!
 
-end module my_fncs_mod
+ real function polysvp(T,TYPE)
 
-!________________________________________________________________________________________!
+!--------------------------------------------------------------
+! Taken from 'module_mp_morr_two_moment.F' (WRFV3.4)
 
-module my_sedi_mod
+!  COMPUTE SATURATION VAPOR PRESSURE
 
-!================================================================================!
-!  The following subroutines are used by the schemes in the multimoment package. !
-!                                                                                !
-!  Package version:  2.19.0     (internal bookkeeping)                           !
-!  Last modified  :  2011-01-07                                                  !
-!================================================================================!
+!  POLYSVP RETURNED IN UNITS OF PA.
+!  T IS INPUT IN UNITS OF K.
+!  TYPE REFERS TO SATURATION WITH RESPECT TO LIQUID (0) OR ICE (1)
 
-   implicit none
+! REPLACE GOFF-GRATCH WITH FASTER FORMULATION FROM FLATAU ET AL. 1992,
+! TABLE 4 (RIGHT-HAND COLUMN)
+!--------------------------------------------------------------
 
-  private
-  public :: SEDI_main_1b,SEDI_main_2,countColumns
+      IMPLICIT NONE
 
-   contains
+      REAL DUM
+      REAL T
+      INTEGER TYPE
+! ice
+      real a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i
+      data a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i /&
+	6.11147274, 0.503160820, 0.188439774e-1, &
+        0.420895665e-3, 0.615021634e-5,0.602588177e-7, &
+        0.385852041e-9, 0.146898966e-11, 0.252751365e-14/
 
-!=====================================================================================!
- SUBROUTINE SEDI_main_2(QX,NX,cat,Q,T,DE,iDE,gamfact,epsQ,epsN,afx,bfx,cmx,dmx,      &
-                        ckQx1,ckQx2,ckQx4,LXP,ni,nk,VxMax,DxMax,dt,DZ,massFlux,      &
-                        ktop_sedi,GRAV,massFlux3D)
+! liquid
+      real a0,a1,a2,a3,a4,a5,a6,a7,a8
 
-!-------------------------------------------------------------------------------------!
-!  DOUBLE-MOMENT version of sedimentation subroutine for categories whose
-!  fall velocity equation is V(D) = gamfact * afx * D^bfx
-!-------------------------------------------------------------------------------------!
+! V1.7
+      data a0,a1,a2,a3,a4,a5,a6,a7,a8 /&
+	6.11239921, 0.443987641, 0.142986287e-1, &
+        0.264847430e-3, 0.302950461e-5, 0.206739458e-7, &
+        0.640689451e-10,-0.952447341e-13,-0.976195544e-15/
+      real dt
 
-! Passing parameters:
-!
-!  VAR   Description
-!  ---   ------------
-!  QX    mass mixing ratio of category x
-!  NX    number concentration of category x
-!  cat:  hydrometeor category:
-!   1     rain
-!   2     ice
-!   3     snow
-!   4     graupel
-!   5     hail
-!-------------------------------------------------------------------------------------!
-
-  use my_fncs_mod
+! ICE
 
-  implicit none
+      IF (TYPE.EQ.1) THEN
 
-! PASSING PARAMETERS:
-  real, dimension(:,:), intent(inout) :: QX,NX,Q,T
-  real, dimension(:),    intent(out)  :: massFlux
-  real, optional, dimension(:,:), intent(out) :: massFlux3D
-  real, dimension(:,:), intent(in)    :: DE,iDE,DZ
-  real, intent(in) :: epsQ,epsN,VxMax,LXP,afx,bfx,cmx,dmx,ckQx1,ckQx2,ckQx4,DxMax,dt,GRAV
-  integer, dimension(:), intent(in)   :: ktop_sedi
-  integer, intent(in)                 :: ni,nk,cat
-
-! LOCAL PARAMETERS:
-  logical                :: slabHASmass,locallim,QxPresent
-  integer                :: nnn,a,i,k,counter,l,km1,kp1,ks,kw,idzmin
-  integer, dimension(nk) :: flim_Q,flim_N
-  integer, dimension(ni) :: activeColumn,npassx,ke
-  real                   :: VqMax,VnMax,iLAMx,iLAMxB0,tmp1,tmp2,tmp3,Dx,iDxMax,icmx,     &
-                            VincFact,ratio_Vn2Vq,zmax_Q,zmax_N,tempo,idmx,Nos_Thompson,  &
-                            No_s,iLAMs
-  real, dimension(ni,nk) :: VVQ,VVN,RHOQX,gamfact
-  real, dimension(ni)    :: dzMIN,dtx,VxMaxx
-  real, dimension(nk)    :: vp_Q,vp_N,zt_Q,zt_N,zb_Q,zb_N,dzi,Q_star,N_star
-  real, dimension(0:nk)  :: zz
-  real, parameter        :: epsilon = 1.e-2
-  real, parameter        :: thrd    = 1./3.
-  real, parameter        :: sxth    = 1./6.
-  real, parameter        :: CoMAX   = 2.0
+!         POLYSVP = 10.**(-9.09718*(273.16/T-1.)-3.56654*                &
+!          LOG10(273.16/T)+0.876793*(1.-T/273.16)+						&
+!          LOG10(6.1071))*100.
 
-!-------------------------------------------------------------------------------------!
 
-   massFlux = 0.
+      dt = max(-80.,t-273.16)
+      polysvp = a0i + dt*(a1i+dt*(a2i+dt*(a3i+dt*(a4i+dt*(a5i+dt*(a6i+dt*(a7i+a8i*dt)))))))
+      polysvp = polysvp*100.
 
-  !Factor to estimate increased V from size-sorting:
-  ! - this factor should be higher for categories with more time-splitting, since Vmax
-  !   increases after each sedimentation split step (to be tuned)
-   VincFact = 1.
-   if (present(massFlux3D)) massFlux3D= 0.  !(for use in MAIN for diagnostics)
+      END IF
 
-  !Determine for which slabs and columns sedimentation should be computes:
-   call countColumns(QX,ni,nk,epsQ,counter,activeColumn,ktop_sedi)
+! LIQUID
 
-   ratio_Vn2Vq= ckQx2/ckQx1
-   iDxMax= 1./DxMax
-   icmx  = 1./cmx
-   idmx  = 1./dmx
-   ks    = nk
-   ke    = ktop_sedi  !(i-array) - formerly ke=1; now depends on max. level with hydrometeor
-   kw    = -1         !direction of vertical leveling; -1 implies nk is bottom
+      IF (TYPE.EQ.0) THEN
 
-   VVQ  = 0.
-   VVN  = 0.
-   VqMax= 0.
-   VnMax= 0.
+       dt = max(-80.,t-273.16)
+       polysvp = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt)))))))
+       polysvp = polysvp*100.
 
-   DO a= 1,counter
-      i= activeColumn(a)
+!         POLYSVP = 10.**(-7.90298*(373.16/T-1.)+                        &
+!             5.02808*LOG10(373.16/T)-									&
+!             1.3816E-7*(10**(11.344*(1.-T/373.16))-1.)+				&
+!             8.1328E-3*(10**(-3.49149*(373.16/T-1.))-1.)+				&
+!             LOG10(1013.246))*100.
 
-      VVQ(i,:) = 0.
-      do k= ktop_sedi(i),nk  !formerly do k= 1,nk
-         QxPresent =  (QX(i,k)>epsQ .and. NX(i,k)>epsN)
-         if (QxPresent) VVQ(i,k)= calcVV()*ckQx1
-         if (present(massFlux3D)) massFlux3D(i,k)= VVQ(i,k)*DE(i,k)*QX(i,k)  !(for use in MAIN)
-      enddo  !k-loop
-      Vxmaxx(i)= min( VxMax, maxval(VVQ(i,:))*VincFact )
+         END IF
 
-     !note: dzMIN is min. value in column (not necessarily lowest layer in general)
-      dzMIN(i) = minval(DZ(i,:))
-      npassx(i)= max(1, nint( dt*Vxmaxx(i)/(CoMAX*dzMIN(i)) ))
-      dtx(i)   = dt/float(npassx(i))
+ end function polysvp
 
-!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
-      DO nnn= 1,npassx(i)
+!==============================================================================!
+ real function qsat(temp,pres,wtype)
 
-         locallim = (nnn==1)
+!-----------------------------------------------------------------------------
+! Returns the saturation mixing ratio [kg kg-1], as a function of temperature
+! pressure, with respect to liquid water [wtype=0] or ice [wtype=1], by calling
+! function POLYSVP to obtain the saturation vapor pressure.
 
-         do k= ktop_sedi(i),nk  !formerly do k= 1,nk
-           RHOQX(i,k) = DE(i,k)*QX(i,k)
-           QxPresent  = (QX(i,k)>epsQ .and. NX(i,k)>epsN)
-           if (QxPresent) then
-              if (locallim) then     !to avoid re-computing VVQ on first pass
-                 VVQ(i,k)= -VVQ(i,k)
-              else
-                 VVQ(i,k)= -calcVV()*ckQx1
-              endif
-              VVN(i,k)= VVQ(i,k)*ratio_Vn2Vq
-              VqMax   = max(VxMAX,-VVQ(i,k))
-              VnMax   = max(VxMAX,-VVN(i,k))
-           else
-              VVQ(i,k)= 0.
-              VVN(i,k)= 0.
-              VqMax   = 0.
-              VnMax   = 0.
-           endif
-         enddo  !k-loop
-
-        !sum instantaneous surface mass flux at each split step: (for division later)
-         massFlux(i)= massFlux(i) - VVQ(i,nk)*DE(i,nk)*QX(i,nk)
-
-     !-- Perform single split sedimentation step:
-     !   (formerly by calls to s/r 'blg4sedi', a modified [JM] version of 'blg2.ftn')
-         zz(ks)= 0.
-         do k= ks,ke(i),kw
-            zz(k+kw)= zz(k)+dz(i,k)
-            dzi(k)  = 1./dz(i,k)
-            vp_Q(k) = 0.
-            vp_N(k) = 0.
-         enddo
+! 2013-08-06
+!-----------------------------------------------------------------------------
 
-         do k=ks,ke(i),kw
-            zb_Q(k)= zz(k) + VVQ(i,k)*dtx(i)
-            zb_N(k)= zz(k) + VVN(i,k)*dtx(i)
-         enddo
+  implicit none
 
-         zt_Q(ke(i))= zb_Q(ke(i)) + dz(i,ke(i))
-         zt_N(ke(i))= zb_N(ke(i)) + dz(i,ke(i))
-         do k= ks,ke(i)-kw,kw
-            zb_Q(k)= min(zb_Q(k+kw)-epsilon*dz(i,k), zz(k)+VVQ(i,k)*dtx(i))
-            zb_N(k)= min(zb_N(k+kw)-epsilon*dz(i,k), zz(k)+VVN(i,k)*dtx(i))
-            zt_Q(k)= zb_Q(k+kw)
-            zt_N(k)= zb_N(k+kw)
-         enddo
+ !Calling parameters:
+  real, intent(in)    :: temp     !temperature [K]
+  real, intent(in)    :: pres     !pressure    [Pa]
+  integer, intent(in) :: wtype    !0=liquid water; 1=ice
 
-         do k=ks,ke(i),kw    !formerly k=1,nk
-            Q_star(k)= RHOQX(i,k)*dz(i,k)/(zt_Q(k)-zb_Q(k))
-            N_star(k)=    NX(i,k)*dz(i,k)/(zt_N(k)-zb_N(k))
-         enddo
+ !Local variables:
+  real :: tmp1
 
-         if (locallim) then
-            zmax_Q= abs(VqMax*dtx(i))
-            zmax_N= abs(VnMax*dtx(i))
-            do l=ks,ke(i),kw
-               flim_Q(l)= l
-               flim_N(l)= l
-               do k= l,ke(i),kw
-                  if (zmax_Q.ge.zz(k)-zz(l+kw)) flim_Q(l)= k
-                  if (zmax_N.ge.zz(k)-zz(l+kw)) flim_N(l)= k
-               enddo
-            enddo
-         endif
+  tmp1 = polysvp(temp,wtype)       !esat [Pa], wrt liquid (Flatau formulation)
+  qsat = 0.622*tmp1/(pres-tmp1)
 
-         do l=ks,ke(i),kw
-            do k=l,flim_Q(l),kw
-               vp_Q(l)= vp_Q(l) + Q_star(k)*max(0.,min(zz(l+kw),zt_Q(k))-max(zz(l),zb_Q(k)))
-            enddo
-            do k=l,flim_N(l),kw
-               vp_N(l)= vp_N(l) + N_star(k)*max(0.,min(zz(l+kw),zt_N(k))-max(zz(l),zb_N(k)))
-            enddo
-         enddo
+  end function qsat
 
-         do k=ks,ke(i),kw
-            RHOQX(i,k)= vp_Q(k)*dzi(k)
-               NX(i,k)= vp_N(k)*dzi(k)
-         enddo
-     !--
+!___________________________________________________________________________________
 
-         do k= ktop_sedi(i),nk  !formerly do k= 1,nk
-           QX(i,k)= RHOQX(i,k)*iDE(i,k)
-
-         !Prevent levels with zero N and nonzero Q and size-limiter:
-           QxPresent=  (QX(i,k)>epsQ .and. NX(i,k)>epsN)
-           if (QxPresent) then    !size limiter
-              Dx= (DE(i,k)*QX(i,k)/(NX(i,k)*cmx))**idmx
-              if (cat==1 .and. Dx>3.e-3) then
-                 tmp1   =  Dx-3.e-3;   tmp1= tmp1*tmp1
-                 tmp2   = (Dx/DxMAX);  tmp2= tmp2*tmp2*tmp2
-                 NX(i,k)= NX(i,k)*max((1.+2.e4*tmp1),tmp2)
-              else
-                 NX(i,k)= NX(i,k)*(max(Dx,DxMAX)*iDxMAX)**dmx   !impose Dx_max
-              endif
-           else   !here, "QxPresent" implies correlated QX and NX
-              Q(i,k) = Q(i,k) + QX(i,k)
-              T(i,k) = T(i,k) - LXP*QX(i,k)   !LCP for rain; LSP for i,s,g,h
-              QX(i,k)= 0.
-              NX(i,k)= 0.
-           endif
+end module my_fncs_mod
 
-         enddo
+!________________________________________________________________________________________!
 
-       ENDDO  !nnn-loop
-!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
-      !compute average mass flux during the full time step: (used to compute the
-      !instantaneous sedimentation rate [liq. equiv. volume flux] in the main s/r)
-       massFlux(i)= massFlux(i)/float(npassx(i))
+module my_sedi_mod
 
-    ENDDO  !a(i)-loop
-!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+!================================================================================!
+!  The following subroutines are used by the schemes in the multimoment package. !
+!================================================================================!
 
-CONTAINS
+  implicit none
 
-   real function calcVV()
-   !Calculates portion of moment-weighted fall velocities
-      iLAMx   = ((QX(i,k)*DE(i,k)/NX(i,k))*ckQx4)**idmx
-      iLAMxB0 = iLAMx**bfx
-      calcVV  = gamfact(i,k)*iLAMxB0
-   end function calcVV
+  private
+  public :: compute_sublevels,sedi_wrapper,sedi_1D,count_columns
 
- END SUBROUTINE SEDI_main_2
+  contains
 
 !=====================================================================================!
- SUBROUTINE SEDI_main_1b(QX,cat,T,DE,iDE,gamfact,epsQ,afx,bfx,icmx,dmx,ckQx1,ckQx4, &
-                         ni,nk,VxMax,DxMax,dt,DZ,massFlux,No_x,ktop_sedi,GRAV,      &
-                         massFlux3D)
+ SUBROUTINE compute_sublevels(ktop,kbot,kdir,nk,nk_skip,nk_sub,kskip,kfull,iint)
 
 !-------------------------------------------------------------------------------------!
-!  SINGLE-MOMENT version of sedimentation subroutine for categories whose
-!  fall velocity equation is V(D) = gamfact * afx * D^bfx
+! Accepts array of levels to be skipped (possibly) for sedimentation; computes and
+! returns array of full level indices in "sub-level space" (kfull) plus array 'iint'
+! used in s/r 'sedi_wrapper' to interpolate sub-levels to intermediate full levels
+! after sedimentation is computed by 'sedi_1D'.
 !-------------------------------------------------------------------------------------!
 
-! Passing parameters:
+implicit none
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+! ARGUMENTS:      DESCRIPTIONS:
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+! -- INPUT: --
+!
+!  ktop           index of top level
+!  kbot           index of bottom level
+!  kdir           -1 if kbot = nk (GEM); 1 if kbot = 1 (WRF)
+!  nk             number of full levels
+!  nk_skip        number of levels skipped
+!  nk_sub         number of sub levels (used for sedimentation)
+!  kskip          array of level indices to skip for sedimentation
+!
+! -- OUTPUT: --
+!
+!  kfull          array of indices of full level
+!  iint           array of level indices at skipped level, level above, and level below
 !
-!  VAR   Description
-!  ---   ------------
-!  QX    mass mixing ratio of category x
-!  cat:  hydrometeor category:
-!   1     rain
-!   2     ice
-!   3     snow
-!   4     graupel
-!   5     hail
+!  Note:  Currently hard-coded for GEM levels; eventually need to generalize
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+
+!CALLING PARAMETERS:
+ integer,                       intent(in)  :: ktop,kbot,kdir,nk,nk_skip,nk_sub
+ integer, dimension(nk_skip),   intent(in)  :: kskip
+ integer, dimension(nk_sub),    intent(out) :: kfull
+ integer, dimension(nk_skip,3), intent(out) :: iint
+
+ !LOCAL VARIABLES:
+ logical :: skip_this_one
+ integer :: k1,k2,k3
+!---
+
+ !Construct 'kfull':
+ kfull = 0
+ k3 = 1
+ do k1=1,nk
+    skip_this_one = .false.
+    do k2 = 1,nk_skip
+      if (k1==kskip(k2)) then     !if actual levels to skip are supplied
+!     if (k1==nk-kskip(k2)) then  !if levels from the bottom to skip are supplied
+         skip_this_one = .true.
+         exit
+      endif
+    enddo
+    if (.not. skip_this_one) then
+       kfull(k3) = k1
+       k3 = k3 + 1
+    endif
+ enddo
+
+ !Construct 'iint':
+ do k1 = 1,nk_skip
+    iint(k1,1) = kskip(k1)
+    do k2 = 1,nk_sub
+       if (kfull(k2)>kskip(k1)) exit
+    enddo
+    iint(k1,2) = kfull(k2-1)
+    iint(k1,3) = kfull(k2)
+ enddo
+
+END SUBROUTINE compute_sublevels
+
+!=====================================================================================!
+ SUBROUTINE sedi_wrapper(QX,NX,cat,epsQ,epsQ_sedi,epsN,dmx,ni,nk_sub,VxMax,DxMax,dt,     &
+                massFlux_bot,kdir,kbot,ktop_sedi,GRAV,nk_skip,kfull,iint,DE_sub,iDE_sub, &
+                iDP_sub,DZ_sub,iDZ_sub,gamfact_sub,zheight,nk,DE,iDE,iDP,DZ,iDZ,gamfact, &
+                kskip1,kount,afx_in,bfx_in,cmx_in,ckQx1_in,ckQx2_in,ckQx4_in,BX,epsB)
+
+!-------------------------------------------------------------------------------------!
+!  Wrapper for s/r SEDI_main_2.  Called from MY2_MAIN.  Reduces the number of levels,
+!  calls SEDI_main_2, then interpolates updated QX,NX back to full levels before
+!  passing back.
 !-------------------------------------------------------------------------------------!
 
-  use my_fncs_mod
+! use my2_fncs_mod
+  use my_fncs_mod   !GEM
 
   implicit none
 
 ! PASSING PARAMETERS:
-  real, dimension(:,:), intent(inout) :: QX,T
-  real, dimension(:),    intent(out)   :: massFlux
-  real, optional, dimension(:,:), intent(out) :: massFlux3D
-  real, dimension(:,:), intent(in)    :: DE,iDE,DZ
-  real,    intent(in)    :: epsQ,VxMax,afx,bfx,icmx,dmx,ckQx1,ckQx4,DxMax,dt,GRAV,No_x
-  integer, dimension(:), intent(in) :: ktop_sedi
-  integer, intent(in)    :: ni,nk,cat !,ktop_sedi
+  real, dimension(:,:), intent(inout),optional :: BX
+  real, dimension(:,:), intent(inout) :: QX,NX
+  real, dimension(:),   intent(out)   :: massFlux_bot
+  real, dimension(:,:), intent(in)    :: DE_sub,iDE_sub,iDP_sub,DZ_sub,iDZ_sub,          &
+                                         gamfact_sub,zheight, DE,iDE,iDP,DZ,iDZ,gamfact
+  real, intent(in)                    :: epsQ,epsQ_sedi,epsN,VxMax,dmx,DxMax,dt,GRAV
+  real, intent(in), optional          :: afx_in,bfx_in,cmx_in,ckQx1_in,ckQx2_in,         &
+                                         ckQx4_in,epsB
+  integer, dimension(:), intent(in)   :: ktop_sedi,kfull
+  integer, intent(in)                 :: ni,nk_sub,cat,kbot,kdir,nk_skip,nk,kskip1,kount
+  integer, dimension(:,:), intent(in) :: iint
+
+! LOCAL VARIABLES:
+  real, dimension(:,:), allocatable   :: QX_sub,NX_sub,BX_sub
+  real                                :: i_Zrun
+  integer, dimension(size(QX,dim=1))  :: activeColumn,ktop
+  integer                             :: counter
+  integer                             :: status
+  integer                             :: a,i,k,i_sub,k_sub
+  logical                             :: sediOnFull,found_blank,found_Q
+
+real :: tmp1,tmp2
 
-! LOCAL PARAMETERS:
-  logical                :: slabHASmass,locallim,QxPresent
-  integer                :: nnn,a,i,k,counter,l,km1,kp1,ks,kw,idzmin !,ke
-  integer, dimension(nk) :: flim_Q
-  integer, dimension(ni) :: activeColumn,npassx,ke
-  real                   :: VqMax,iLAMx,iLAMxB0,tmp1,tmp2,Dx,iDxMax,VincFact,NX,iNo_x,   &
-                            zmax_Q,zmax_N,tempo
-  real, dimension(ni,nk) :: VVQ,RHOQX,gamfact
-  real, dimension(ni)    :: dzMIN,dtx,VxMaxx
-  real, dimension(nk)    :: vp_Q,zt_Q,zb_Q,dzi,Q_star
-  real, dimension(0:nk)  :: zz
-  real, parameter        :: epsilon = 1.e-2
-  real, parameter        :: thrd  = 1./3.
-  real, parameter        :: sxth  = 1./6.
-  real, parameter        :: CoMAX = 2.0
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+! ARGUMENTS:      DESCRIPTIONS:
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+!
+! X (or x) in variables/parameters denots hydrometeor category x, where x = r,i,s,g,h
+! for rain, ice, snow, graupel, and hail, respectively.
+!
+! -- INPUT: --
+!
+! ktop_sedi       array of k-indices of max height to consider sedi (in each column)
+! ni              number of columns in slab
+! nk              number of vertical levels
+! kskip1          index of highest level to be skipped for sedimentation (0 = full levels only)
+! {x}_sub         arrays on sub-levels for which sedimentaion is computed
+! DZ              height difference between level k and k+kdir (below) [m]
+! DP              pressure difference between level k and k+kdir (below) [Pa]
+! DE              air density [kg m-3]
+! gamfact         air density correction factor for fall speed
+! epsQ            minimum allowable value of QX  [kg m-3]
+! epsQ_sedi       minimum value of QX to compute sedimentation [kg m-3]
+! epsN            minimum allowable value of NX [m-3]
+! zheight         height above surface at level k [m]
+! VxMax           maximum allowable fall speed for hydrometeor category x [m s-1]
+! afx, bfx        fall speed parameters for hydrometeor category x
+! cmx, dmx        mass-diameter parameters for hydrometeor category x
+! ckQx[1,2,4]     precomputed expressions related to gamma functions for category x
+! DxMax           maximum allowable mean-mass diameter for category x [m]
+! dt              dynamical time step of model [s]
+! GRAV            gravitational constant [m s-2]
+!
+! -- OUTPUT: --
+!
+! massFlux_bot    mass flux at lowest level (for compute sedimentation rate) [kg s-1]
+!
+! -- INPUT/OUTPUT: --
+!
+! QX, NX          mixing ratio and number concentration of category X
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+! LOCAL:          DESCRIPTIONS:
+!
+! QX_sub,NX_sub   QX,NX on active columns and sublevels to treat sedimentation
+! i_Zrun          denominator of height slope for interpolation back to full levels
+! activeColumn    array of i-indices for columns to treat sedimentation (with QX>epsQ_sedi)
+! ktop            array of k-indices with highest level to treat sedimentation
+! counter         number of columns to treat sedimentation
+! status          for allocate/deallocate statements (0 for success)
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
 
 !-------------------------------------------------------------------------------------!
 
-   massFlux= 0.
-  !Factor to estimate increased V from size-sorting:
-  ! - this factor should be higher for categories with more time-splitting, since Vmax
-  !   increases after each sedimentation split step (to be tuned)
-   VincFact= 1.
-   if (present(massFlux3D)) massFlux3D= 0.  !(for use in MAIN for diagnostics)
-
-  !Determine for which slabs and columns sedimentation should be computes:
-   call countColumns(QX,ni,nk,epsQ,counter,activeColumn,ktop_sedi)
-   iNo_x = 1./No_x
-   iDxMax= 1./DxMax
-   ks    = nk
-   ke    = ktop_sedi  !(i-array) - old: ke=1
-   kw    = -1         !direction of vertical leveling
-
-   VVQ  = 0.
-   VqMax= 0.
-
-   DO a= 1,counter
-      i= activeColumn(a)
+   massFlux_bot = 0.
 
-      VVQ(i,:) = 0.
-      do k= ktop_sedi(i),nk  !do k= 1,nk
-         QxPresent =  (QX(i,k)>epsQ)
-!        if (QxPresent) VVQ(i,k)= calcVV()*ckQx1
+  !Determine for which columns sedimentation should be computed:
+  ! (returns the number of columns with non-negible hydrometeor content [counter], the
+  !  array of i-points to treat [activeColumn], and the max. height [plus one level higher]
+  !  containing non-neglible content in that column)
+   ktop = ktop_sedi  !(i-array)  - for complete column, ktop(:)=1
+   call count_columns(QX,ni,epsQ_sedi,counter,activeColumn,kdir,kbot,ktop)
+!   ni_sub = counter !ni of columns to process for sedi
 
-         if (QxPresent) then
-            !ice:
-              if (cat==2) then
-                 NX    = 5.*exp(0.304*(273.15-max(233.,T(i,k))))
-                 iLAMx = (ckQx4*QX(i,k)*DE(i,k)/NX)**thrd
-            !snow:
-              else if (cat==3) then
-                 iNo_x = 1./min(2.e+8, 2.e+6*exp(-0.12*min(-0.001,T(i,k)-273.15)))
-                 iLAMx = sqrt(sqrt(QX(i,k)*DE(i,k)*icmx*sxth*iNo_x))
-            !rain, graupel, hail:
-              else
-                 iLAMx = sqrt(sqrt(QX(i,k)*DE(i,k)*icmx*sxth*iNo_x))
-              endif
-              VVQ(i,k) = -gamfact(i,k)*ckQx1*iLAMx**bfx
-         !    VqMax    = max(VxMAX,-VVQ(i,k))
-         endif
-         if (present(massFlux3D)) massFlux3D(i,k)= -VVQ(i,k)*DE(i,k)*QX(i,k)  !(for use in MAIN)
+   DO a = 1,counter
+      i= activeColumn(a)
+     !From here, all sedi calcs are done for each column i
+
+     sediOnFull = .true. !WRF
+! !      !--- determine FULL or SUB:
+! !       if (kskip1==0) then
+! !          sediOnFull  = .true.
+! !       else
+! !          sediOnFull  = .false.
+! !         !NOTE:  Rather than using kskip1, base this on 2 or 3 levels higher (see notes 2013-04-25)
+! !          found_blank = QX(i,kskip1-5)<=epsQ
+! !          found_Q     = QX(i,kskip1-5)>epsQ
+! !          do k=kskip1+1-5,nk
+! !             if (.not. found_blank) found_blank = (QX(i,k)<=epsQ)
+! !             if (.not. found_Q)     found_Q     = (QX(i,k)>epsQ)
+! !             if (found_blank .and. found_Q) then
+! !                sediOnFull = .true.
+! !                go to 66 !exit
+! !             endif
+! !          enddo
+! ! 66       continue
+! !       endif
+!===
 
-      enddo  !k-loop
-      Vxmaxx(i)= min( VxMax, maxval(VVQ(i,:))*VincFact )
+! !       if (sediOnFull) then
+! !       !perform sedimentation on full set of levels:
+
+! !         if (present(BX)) then
+! !          call sedi_1D(QX(i,:),NX(i,:),cat,DE(i,:),iDE(i,:),iDP(i,:),gamfact(i,:),epsQ,   &
+! ! !            epsN,dmx,VxMax,DxMax,dt,DZ(i,:),iDZ(i,:),massFlux_bot(i),kdir,nk,ktop(i),GRAV,BX1d=BX(i,:),epsB=epsB)
+! !              epsN,dmx,VxMax,DxMax,dt,DZ(i,:),iDZ(i,:),massFlux_bot(i),kdir,kbot,ktop(i), &
+! !              GRAV,BX1d=BX(i,:),epsB=epsB)
+! !         else
+         call sedi_1D(QX(i,:),NX(i,:),cat,DE(i,:),iDE(i,:),iDP(i,:),gamfact(i,:),epsQ,   &
+!            epsN,dmx,VxMax,DxMax,dt,DZ(i,:),iDZ(i,:),massFlux_bot(i),kdir,nk,ktop(i),GRAV,afx_in=afx_in,bfx_in=bfx_in,cmx_in=cmx_in,ckQx1_in=ckQx1_in,ckQx2_in=ckQx2_in,ckQx4_in=ckQx4_in)
+             epsN,dmx,VxMax,DxMax,dt,DZ(i,:),iDZ(i,:),massFlux_bot(i),kdir,kbot,ktop(i), &
+             GRAV,afx_in=afx_in,bfx_in=bfx_in,cmx_in=cmx_in,ckQx1_in=ckQx1_in,ckQx2_in=  &
+             ckQx2_in,ckQx4_in=ckQx4_in)
+! !         endif
+
+! !       else
+! !       !perform sedimentation on sub-levels only:
+! !
+! !          allocate ( QX_sub( ni,nk_sub), STAT=status )
+! !          allocate ( NX_sub( ni,nk_sub), STAT=status )
+! !
+! !          do k_sub = 1,nk_sub
+! !             k= kfull(k_sub)
+! !             QX_sub(:,k_sub) = QX(:,k)
+! !             NX_sub(:,k_sub) = NX(:,k)
+! !          enddo
+! !         !
+! !          if (present(BX)) then
+! !             allocate ( BX_sub( ni,nk_sub), STAT=status )
+! !             do k_sub = 1,nk_sub
+! !                k= kfull(k_sub)
+! !                BX_sub(:,k_sub) = BX(:,k)
+! !             enddo
+! !          endif
+! !
+! !         if (present(BX)) then
+! !          call sedi_1D(QX_sub(i,:),NX_sub(i,:),cat,DE_sub(i,:),iDE_sub(i,:),iDP_sub(i,:), &
+! !                       gamfact_sub(i,:),epsQ,epsN,dmx,VxMax,DxMax,dt,DZ_sub(i,:),         &
+! !                       iDZ_sub(i,:),massFlux_bot(i),kdir,nk_sub,ktop(i),GRAV,             &
+! !                       BX1d=BX_sub(i,:),epsB=epsB)
+! !         else
+! !          call sedi_1D(QX_sub(i,:),NX_sub(i,:),cat,DE_sub(i,:),iDE_sub(i,:),iDP_sub(i,:), &
+! !                       gamfact_sub(i,:),epsQ,epsN,dmx,VxMax,DxMax,dt,DZ_sub(i,:),         &
+! !                       iDZ_sub(i,:),massFlux_bot(i),kdir,nk_sub,ktop(i),GRAV,             &
+! !                       afx_in=afx_in,bfx_in=bfx_in,cmx_in=cmx_in,ckQx1_in=ckQx1_in,       &
+! !                       ckQx2_in=ckQx2_in,ckQx4_in=ckQx4_in)
+! !         endif
+! !
+! !      !interpolate  {VAR}_sub to {VAR}:
+! !
+! !         !- common levels:
+! !          do k_sub = 1,nk_sub
+! !             k= kfull(k_sub)
+! !             QX(i,k) = QX_sub(i,k_sub)
+! !             NX(i,k) = NX_sub(i,k_sub)
+! !          enddo
+! !         !
+! !          if (present(BX)) then
+! !             do k_sub = 1,nk_sub
+! !                k= kfull(k_sub)
+! !                BX(i,k) = BX_sub(i,k_sub)
+! !             enddo
+! !          endif
+! !         !=
+! !
+! !         !- interpolated levels:
+! !          do k = 1,nk_skip
+! !             i_Zrun = 1./(zheight(i,iint(k,2))-zheight(i,iint(k,3)))
+! !             QX(i,iint(k,1))= QX(i,iint(k,3))+(zheight(i,iint(k,1))-zheight(i,iint(k,3)))* &
+! !                              ( (QX(i,iint(k,2))-QX(i,iint(k,3)))*i_Zrun )
+! !             NX(i,iint(k,1))= NX(i,iint(k,3))+(zheight(i,iint(k,1))-zheight(i,iint(k,3)))* &
+! !                              ( (NX(i,iint(k,2))-NX(i,iint(k,3)))*i_Zrun )
+! !          enddo
+! !         !
+! !          if (present(BX)) then
+! !            do k = 1,nk_skip
+! !               i_Zrun = 1./(zheight(i,iint(k,2))-zheight(i,iint(k,3)))
+! !               BX(i,iint(k,1))=BX(i,iint(k,3))+(zheight(i,iint(k,1))-zheight(i,iint(k,3)))*&
+! !                                ( (BX(i,iint(k,2))-BX(i,iint(k,3)))*i_Zrun )
+! !            enddo
+! !          endif
+! !         !=
+! !
+! !          deallocate ( QX_sub, STAT=status )
+! !          deallocate ( NX_sub, STAT=status )
+! !          if (present(BX)) deallocate ( BX_sub, STAT=status )
+! !
+! !       endif  !if (sediOnFull)
+
+   ENDDO  !a-loop
+
+ END SUBROUTINE sedi_wrapper
 
-     !note: dzMIN is min. value in column (not necessarily lowest layer in general)
-      dzMIN(i) = minval(DZ(i,:))
-      npassx(i)= max(1, nint( dt*Vxmaxx(i)/(CoMAX*dzMIN(i)) ))
-      dtx(i)   = dt/float(npassx(i))
+!=====================================================================================!
+ SUBROUTINE sedi_1D(QX1d,NX1d,cat,DE1d,iDE1d,iDP1d,gamfact1d,epsQ,epsN,dmx,VxMax,DxMax,  &
+                    dt,DZ1d,iDZ1d,massFlux_bot,kdir,kbot,ktop,GRAV,afx_in,bfx_in,cmx_in, &
+                    ckQx1_in,ckQx2_in,ckQx4_in,BX1d,epsB)
+
+!-------------------------------------------------------------------------------------!
+!  Performs 2-moment sedimentation on a single column for hydrometeor categories whose
+!  fall velocity equation is V(D) = gamfact * afx * D^bfx.
+!  Sub-time stepping for numerical stability is determined locally.
+!-------------------------------------------------------------------------------------!
 
 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
-      DO nnn= 1,npassx(i)
-
-         locallim = (nnn==1)
-
-         do k= ktop_sedi(i),nk  !do k= 1,nk
-           RHOQX(i,k) = DE(i,k)*QX(i,k)
-           QxPresent  = (QX(i,k)>epsQ)
-            if (QxPresent) then
-             !ice:
-               if (cat==2) then
-                  NX    = 5.*exp(0.304*(273.15-max(233.,T(i,k))))
-                  iLAMx = (ckQx4*QX(i,k)*DE(i,k)/NX)**thrd
-             !snow:
-               else if (cat==3) then
-                  iNo_x = 1./min(2.e+8, 2.e+6*exp(-0.12*min(-0.001,T(i,k)-273.15)))
-                  iLAMx = sqrt(sqrt(QX(i,k)*DE(i,k)*icmx*sxth*iNo_x))
-             !rain, graupel, hail:
-               else
-                  iLAMx = sqrt(sqrt(QX(i,k)*DE(i,k)*icmx*sxth*iNo_x))
-               endif
-               VVQ(i,k) = -gamfact(i,k)*ckQx1*iLAMx**bfx
-               VqMax    = max(VxMAX,-VVQ(i,k))
-            endif
+! ARGUMENTS:      DESCRIPTIONS:
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+!
+! X (or x) in variables/parameters denots hydrometeor category x, where x = r,i,s,g,h
+! for rain, ice, snow, graupel, and hail, respectively.
+!
+! -- INPUT: --
+!
+! cat          hydrometeor category (value of 1,2,3,4,5 for x=r,i,s,g,h, respectively)
+! DE           air density
+! iDE          1./DE
+! iDP          1./(pressure difference beween level k and level above)
+! gamfact      air density correction factor
+! epsQ         minimum allowable mixing ratio
+! epsN         minimum allowable number concentration
+! afx          fall velocity parameter (coefficient)
+! bfx          fall velocity parameter (exponent)
+! cmx          mass-diameter parameter (coefficient)
+! dmx          mass-diameter parameter (exponent)
+! ckQx1        size distribution term [function of GAMMA(...)]
+! ckQx2        size distribution term [function of GAMMA(...)]
+! ckQx4        size distribution term [function of GAMMA(...)]
+! VxMax        maximum mass-weighted fall velocity (for category X)
+! DxMax        maximum mean-mass diameter (for category x)
+! dt           model tim step
+! DZ           vertical grid spacing between level k and level below
+! iDZ          1./DZ
+! kdir         vertical leveling increment, (GEM: kdir=-1;  WRF: kdir=1)
+! kbot         k index of bottom level      (GEM: kbot=nk;  WRF: kbot=1)
+! GRAV         gravitational constant
+!
+! -- OUTPUT: --
+!
+! massFlux_bot mass flux (at lowest model level)
+!
+! -- INPUT/OUTPUT: --
+!
+! QX           hydrometeor mixing ratio
+! NX           hydrometeor total number concentration
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
 
-         enddo  !k-loop
+! use my2_fncs_mod
+  use my_fncs_mod   !GEM
 
-     !-- Perform single split sedimentation step:  (formerly by calls to s/r 'blg4sedi')
-         zz(ks)= 0.
-         do k= ks,ke(i),kw
-            zz(k+kw)= zz(k)+dz(i,k)
-            dzi(k)  = 1./dz(i,k)
-            vp_Q(k) = 0.
-         enddo
+  implicit none
 
-         do k=ks,ke(i),kw
-            zb_Q(k)= zz(k) + VVQ(i,k)*dtx(i)
-         enddo
+! PASSING PARAMETERS:
+  real, dimension(:),  intent(inout), optional :: BX1d
+  real, dimension(:),  intent(inout) :: QX1d,NX1d
+  real, dimension(:),  intent(in)    :: gamfact1d
+  real,                intent(out)   :: massFlux_bot
+  real, dimension(:),  intent(in)    :: DE1d,iDE1d,iDP1d,DZ1d,iDZ1d
+  real,                intent(in)    :: epsQ,epsN,VxMax,dmx,DxMax,dt,GRAV
+  real, optional,      intent(in)    :: afx_in,bfx_in,cmx_in,ckQx1_in,ckQx2_in,          &
+                                        ckQx4_in,epsB
+  integer,             intent(in)    :: cat,kbot,kdir
+  integer,             intent(in)    :: ktop
 
-         zt_Q(ke(i))= zb_Q(ke(i)) + dz(i,ke(i))
-         do k= ks,ke(i)-kw,kw
-            zb_Q(k)= min(zb_Q(k+kw)-epsilon*dz(i,k), zz(k)+VVQ(i,k)*dtx(i))
-            zt_Q(k)= zb_Q(k+kw)
-         enddo
+! LOCAL PARAMETERS:
+  integer                            :: npassx
+  real, dimension(size(QX1d,dim=1))  :: VVQ,VVN
+  real                               :: dzMIN,dtx,VxMaxx
+  logical                            :: firstPass,QxPresent,BX_present
+  integer                            :: nnn,i,k,l,km1,kp1,idzmin,kk
+  real                               :: VqMax,VnMax,iLAMx,iLAMxB0,tmp1,tmp2,tmp3,Dx,     &
+                                        iDxMax,icmx,VincFact,ratio_Vn2Vq,zmax_Q,zmax_N,  &
+                                        idmx
+  real                               :: alpha_x,afx,bfx,cmx,ckQx1,ckQx2,ckQx4
 
-         do k=ks,ke(i),kw    !k=1,nk
-            Q_star(k)= RHOQX(i,k)*dz(i,k)/(zt_Q(k)-zb_Q(k))
-         enddo
+  real, parameter :: thrd    = 1./3.
+  real, parameter :: sxth    = 1./6.
+! real, parameter :: CoMAX   = 0.5  !0.8
+  real, parameter :: CoMAX   = 0.8
+  real, parameter :: PIov6   = 3.14159265*sxth
+!-------------------------------------------------------------------------------------!
 
-         if (locallim) then
-            zmax_Q= abs(VqMax*dtx(i))
-            do l=ks,ke(i),kw
-               flim_Q(l)= l
-               do k= l,ke(i),kw
-                  if (zmax_Q.ge.zz(k)-zz(l+kw)) flim_Q(l)= k
-               enddo
-            enddo
-         endif
+   BX_present = present(BX1d)
+
+  !for rain, ice, snow, hail:
+   if (.not. (cat==4 .and. BX_present)) then
+      afx   = afx_in
+      bfx   = bfx_in
+      cmx   = cmx_in
+      icmx  = 1./cmx
+      ckQx1 = ckQx1_in
+      ckQx2 = ckQx2_in
+      ckQx4 = ckQx4_in
+      ratio_Vn2Vq  = ckQx2/ckQx1
+   endif
 
-         do l=ks,ke(i),kw
-            do k=l,flim_Q(l),kw
-               vp_Q(l)= vp_Q(l) + Q_star(k)*max(0.,min(zz(l+kw),zt_Q(k))-max(zz(l),zb_Q(k)))
-            enddo
-         enddo
+   massFlux_bot = 0.
+   iDxMax = 1./DxMax
+   idmx   = 1./dmx
+   VVQ    = 0.
+   VVN    = 0.
+   VqMax  = 0.
+   VnMax  = 0.
+   VVQ(:) = 0.
+
+! !    if (cat==4 .and. BX_present) then
+! !     !for graupel:
+! !       do k= kbot,ktop,kdir
+! !          QxPresent =  (QX1d(k)>epsQ .and. NX1d(k)>epsN .and. BX1d(k)>epsB)
+! !          if (QxPresent) then
+! !             call compute_graupel_parameters(2,QX1d(k),NX1d(k),BX1d(k),epsQ,epsN,epsB,    &
+! !                          DE1d(k),PIov6,thrd,dmx,alpha_x,iLAMx,afx,bfx,cmx,icmx,ckQx1,    &
+! !                          ckQx2,ckQx4)
+! !             ratio_Vn2Vq  = ckQx2/ckQx1
+! !             VVQ(k)       = VV_Qg()
+! !          endif
+! !       enddo
+! !    else
+! !     !for rain, ice, snow, hail:
+      do k= kbot,ktop,kdir
+         QxPresent =  (QX1d(k)>epsQ .and. NX1d(k)>epsN)
+         if (QxPresent) VVQ(k)= VV_Q()
+      enddo
+! !    endif
 
-         do k=ks,ke(i),kw
-            RHOQX(i,k)= vp_Q(k)*dzi(k)
-         enddo
+   Vxmaxx= min( VxMax, maxval(VVQ(:)))
+   if (kdir==1) then
+      dzMIN = minval(DZ1d(ktop-kdir:kbot))  !WRF (to be tested)
+   else
+      dzMIN = minval(DZ1d(ktop:kbot+kdir))  !GEM
+   endif
+   npassx= max(1, nint( dt*Vxmaxx/(CoMAX*dzMIN) ))
+
+!test:
+!  if (cat==4 .or. cat==5) npassx= max(1, nint( dt*Vxmaxx/(0.5*CoMAX*dzMIN) ))
+!  if (cat==4 .or. cat==5) npassx= npassx + 2
+!  if (cat==4            ) npassx= max(4, nint( dt*Vxmaxx/(0.5*CoMAX*dzMIN) ))
+
+   dtx   = dt/float(npassx)
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
+   DO nnn= 1,npassx
+
+      firstPass = (nnn==1)
+
+! !      if (cat==4 .and. BX_present) then
+! !
+! !     !for graupel:
+! !       do k= kbot,ktop,kdir
+! !          QxPresent  = (QX1d(k)>epsQ .and. NX1d(k)>epsN .and. BX1d(k)>epsB)
+! !          if (QxPresent) then
+! !             if (firstPass) then     !to avoid re-computing VVQ on first pass
+! !                VVQ(k)= -VVQ(k)
+! !             else
+! !                call compute_graupel_parameters(3,QX1d(k),NX1d(k),BX1d(k),epsQ,epsN,epsB, &
+! !                             DE1d(k),PIov6,thrd,dmx,alpha_x,iLAMx,afx,bfx,cmx,icmx,ckQx1, &
+! !                             ckQx2,ckQx4)
+! !                ratio_Vn2Vq  = ckQx2/ckQx1
+! !                VVQ(k)       = -VV_Qg()
+! !             endif
+! !             !--
+! ! !           !to control excessive size-sorting for graupel:
+! ! !           !  note: with constant alpha_g=3, there appears to be no need for extra
+! ! !           !        control of size-sorting.  (commented code is left as a placeholder)
+! ! !           tmp1 = (icmx*QX1d(k)/NX1d(k))**thrd   !Dmg
+! ! !           tmp2 = min(50., 0.5*(1000.*tmp1))     !mu = const*Dmg [mm]
+! ! !           ratio_Vn2Vq = ((3.+tmp2)*(2.+tmp2)*(1.+tmp2))/((3.+bfx+tmp2)*             &
+! ! !                          (2.+bfx+tmp2)*(1.+bfx+tmp2))
+! !             !==
+! !             VVN(k) = VVQ(k)*ratio_Vn2Vq
+! !             VqMax  = max(VxMAX,-VVQ(k))
+! !             VnMax  = max(VxMAX,-VVN(k))
+! !          else
+! !             VVQ(k) = 0.
+! !             VVN(k) = 0.
+! !             VqMax  = 0.
+! !             VnMax  = 0.
+! !          endif
+! !       enddo  !k-loop
+! !
+! !      else
+! !
+! !     !for rain, ice, snow, hail:
+      do k= kbot,ktop,kdir
+         QxPresent  = (QX1d(k)>epsQ .and. NX1d(k)>epsN)
+         if (QxPresent) then
+            if (firstPass) then     !to avoid re-computing VVQ on first pass
+               VVQ(k)= -VVQ(k)
+            else
+               VVQ(k)= -VV_Q()
+            endif
+!!*** TUNING FOR HAIL ***
+!             if (cat==5) then
+!               !to control excessive size-sorting for hail:
+!                tmp1 = (icmx*QX1d(k)/NX1d(k))**thrd   !Dmh
+!                tmp2 = min(50., 0.1*(1000.*tmp1))     !mu = const*Dmh [mm]
+!                ratio_Vn2Vq = ((3.+tmp2)*(2.+tmp2)*(1.+tmp2))/((3.+bfx+tmp2)*             &
+!                               (2.+bfx+tmp2)*(1.+bfx+tmp2))
+!             endif
+!!***
+            VVN(k) = VVQ(k)*ratio_Vn2Vq
+            VqMax  = max(VxMAX,-VVQ(k))
+            VnMax  = max(VxMAX,-VVN(k))
+         else
+            VVQ(k) = 0.
+            VVN(k) = 0.
+            VqMax  = 0.
+            VnMax  = 0.
+         endif
+      enddo  !k-loop
+
+! !      endif
+
+      !sum instantaneous surface mass flux at each split step: (for division later)
+      massFlux_bot= massFlux_bot - VVQ(kbot)*DE1d(kbot)*QX1d(kbot)
+     !-- Perform single split sedimentation step (Eulerian FIT-BIS):
+     !     note: VVQ and VVN are negative (downward)
+!   !p-coordinates:
+!      do k= kbot,ktop,kdir
+!        QX1d(k)= QX1d(k) + dtx*GRAV*iDP1d(k+kdir)*(-DE1d(k+kdir)*QX1d(k+kdir)*  &
+!                           VVQ(k+kdir)+DE1d(k)*QX1d(k)*VVQ(k))
+!        NX1d(k)= NX1d(k) + dtx*GRAV*iDP1d(k+kdir)*DE1d(k)*(-NX1d(k+kdir)*       &
+!                           VVN(k+kdir)+ NX1d(k)*VVN(k))
+!     enddo
+    !z-coordinates:
+      do k= kbot,ktop,kdir
+         QX1d(k)= QX1d(k) + dtx*iDE1d(k)*(-DE1d(k+kdir)*QX1d(k+kdir)*VVQ(k+kdir) +       &
+                            DE1d(k)*QX1d(k)*VVQ(k))*iDZ1d(k+kdir)
+         NX1d(k)= NX1d(k) + dtx*(-NX1d(k+kdir)*VVN(k+kdir) + NX1d(k)*VVN(k))*iDZ1d(k+kdir)
+         QX1d(k) = max( QX1d(k), 0.)
+         NX1d(k) = max( NX1d(k), 0.)
+      enddo
+     !
+      if (BX_present) then
+       do k= kbot,ktop,kdir
+         BX1d(k)= BX1d(k) + dtx*iDE1d(k)*(-DE1d(k+kdir)*BX1d(k+kdir)*VVQ(k+kdir) +       &
+                            DE1d(k)*BX1d(k)*VVQ(k))*iDZ1d(k+kdir)
+         BX1d(k) = max( BX1d(k), 0.)
+       enddo
+      endif
      !--
 
-         do k= ktop_sedi(i),nk  ! do k= 1,nk
-           QX(i,k)= RHOQX(i,k)*iDE(i,k)
-         enddo
+      do k= kbot,ktop,kdir
+
+        !Prescribe NX if QX>0.and.NX=0:
+        if (QX1d(k)>epsQ .and. NX1d(k)epsN
+           do kk = k+kdir,ktop,kdir
+              !note: the following condition should normally be satisfied immediately;
+              !      that is, the next level up should contain NX>epsN
+              if (NX1d(kk)>=epsN) exit
+           enddo
+          !prescribe new NX:
+          !  note: if no kk with NX>epsN found [i.e. if kk=ktop at this point] then
+          !        epsN is prescribed; this will then be modified via size-limiter below
+           NX1d(k) = max(epsN,NX1d(kk))
+        endif
 
-        !sum instantaneous flux at each split step: (for division later)
-         massFlux(i)= massFlux(i) - VVQ(i,nk)*DE(i,nk)*QX(i,nk)
+        !Impose size-limiter / drop-breakup:
+        if (QX1d(k)>epsQ .and. NX1d(k)>epsN) then
+           Dx= (DE1d(k)*QX1d(k)/(NX1d(k)*cmx))**idmx
+           if (cat==1 .and. Dx>3.e-3) then
+              NX1d(k)= NX1d(k)*max((1.+2.e4*(Dx-3.e-3)**2),(Dx*iDxMAX)**3)
+           else
+              NX1d(k)= NX1d(k)*(max(Dx,DxMAX)*iDxMAX)**dmx   !impose Dx_max
+           endif
+        endif
+
+      enddo
 
-       ENDDO  !nnn-loop
+   ENDDO  !nnn-loop
 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
-      !compute average flux during the full time step: (this will be used to compute
-      ! the instantaneous sedimentation rate [volume flux] in the main s/r)
-       massFlux(i)= massFlux(i)/float(npassx(i))
+  !Compute average mass flux during the full time step: (used to compute the
+  !instantaneous sedimentation rate [liq. equiv. volume flux] in the main s/r)
+   massFlux_bot= massFlux_bot/float(npassx)
 
-    ENDDO  !a(i)-loop
 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
 
- END SUBROUTINE SEDI_main_1b
+   CONTAINS
+
+   real function VV_Q()
+   !Calculates Q-weighted fall velocity
+      iLAMx   = ((QX1d(k)*DE1d(k)/NX1d(k))*ckQx4)**idmx
+      iLAMxB0 = iLAMx**bfx
+      VV_Q    = gamfact1d(k)*iLAMxB0*ckQx1
+   end function VV_Q
+
+   real function VV_Qg()
+   !Calculates Q-weighted fall velocity
+!     iLAMx is already computed in 'calc_grpl_params' (for graupel only)
+      iLAMxB0 = iLAMx**bfx
+      VV_Qg   = gamfact1d(k)*iLAMxB0*ckQx1
+   end function VV_Qg
+
+ END SUBROUTINE sedi_1D
 
 !=====================================================================================!
- SUBROUTINE countColumns(QX,ni,nk,minQX,counter,activeColumn,ktop_sedi)
+ SUBROUTINE count_columns(QX,ni,minQX,counter,activeColumn,kdir,kbot,ktop)
 
-! Searches the hydrometeor array QX(ni,nk) for non-zero (>minQX) values.
-! Returns the array if i-indices (activeColumn) for the columns (i)
-! which contain at least one non-zero value, as well as the number of such
-! columns (counter).
+ !--------------------------------------------------------------------------
+ ! Searches the hydrometeor array QX(ni,nk) for non-zero (>minQX) values.
+ ! Returns the array if i-indices (activeColumn) for the column indices (i) which
+ ! contain at least one non-zero value, the number of such columns (counter),
+ ! and the k-indices of the maximum level to compute sedimentation.
+ !--------------------------------------------------------------------------
 
   implicit none
 
 !PASSING PARAMETERS:
-  integer, intent(in)                   :: ni,nk !,ktop_sedi
-  integer, dimension(:), intent(in)     :: ktop_sedi
-  integer,                 intent(out)  :: counter
-  integer, dimension(:), intent(out)    :: activeColumn
-  real,    dimension(:,:), intent(in)   :: QX
-  real,    intent(in)                   :: minQX
+  real,    dimension(:,:),intent(in)   :: QX            ! mixing ratio
+  real,    intent(in)                  :: minQX         ! mixing ratio threshold
+  integer, intent(in)                  :: ni            ! total number of columns (input)
+  integer, intent(in)                  :: kbot          ! k index of lowest level
+  integer, intent(in)                  :: kdir          ! -1 of k=1 is top (GEM); 1 if k=1 is bottom (WRF)
+  integer, dimension(:),  intent(inout):: ktop          ! IN: array of highest level to look at; OUT: array of highest level with QX>epsQ
+  integer,                intent(out)  :: counter       ! number of columns containing at least one QX>epsQ
+  integer, dimension(:),  intent(out)  :: activeColumn  ! array of i-indices with columns containing at least one QX>epsQ
 
 !LOCAL PARAMETERS:
-  integer                               :: i !,k
-  integer, dimension(ni)                :: k
+  integer                              :: i
+  integer, dimension(size(QX,dim=1))   :: k
 
-!    k= ktop_sedi-1  !  k=0
-   counter     = 0
-   activeColumn= 0
+   counter       = 0
+   activeColumn  = 0
+
+ !Note:  k_top(i) must be at least one level higher than the level with non-zero Qx
 
    do i=1,ni
-      k(i)= ktop_sedi(i)-1  !  k=0
+      k(i)= ktop(i)
       do
-         k(i)=k(i)+1
+         k(i)=k(i)-kdir               !step 1 level downward (towards lowest-level k)
          if (QX(i,k(i))>minQX) then
             counter=counter+1
             activeColumn(counter)=i
-            k(i)=0
+            ktop(i)= k(i)             !set ktop(k) to highest level with QX>minQX
             exit
          else
-            if (k(i)==nk) then
-               k(i)=0
+            if (k(i)==kbot) then
+               ktop(i) = kbot
                exit
             endif
          endif
       enddo
-   enddo  !i-loop
-
- END SUBROUTINE countColumns
+   enddo
 
+ END SUBROUTINE count_columns
 !=====================================================================================!
 
 end module my_sedi_mod
@@ -1006,14 +1130,10 @@ module my_dmom_mod
 
 !_______________________________________________________________________________________!
 
- SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS,TM,  &
-     QM,QCM,QRM,QIM,QNM,QGM,QHM,NCM,NRM,NYM,NNM,NGM,NHM,PSM,S,RT_rn1,RT_rn2,RT_fr1,RT_fr2,&
-     RT_sn1,RT_sn2,RT_sn3,RT_pe1,RT_pe2,RT_peL,RT_snd,GZ,T_TEND,Q_TEND,QCTEND,QRTEND,     &
-     QITEND,QNTEND,QGTEND,QHTEND,NCTEND,NRTEND,NYTEND,NNTEND,NGTEND,NHTEND,dt,NI,N,NK,    &
-     J,KOUNT,CCNtype,precipDiag_ON,sedi_ON,warmphase_ON,autoconv_ON,icephase_ON,snow_ON,  &
-     initN,dblMom_c,dblMom_r,dblMom_i,dblMom_s,dblMom_g,dblMom_h,Dm_c,Dm_r,Dm_i,Dm_s,     &
-     Dm_g,Dm_h,ZET,ZEC,SLW,VIS,VIS1,VIS2,VIS3,h_CB,h_ML1,h_ML2,h_SN,SS01,SS02,SS03,SS04,  &
-     SS05,SS06,SS07,SS08,SS09,SS10,SS11,SS12,SS13,SS14,SS15,SS16,SS17,SS18,SS19,SS20)
+ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS,          &
+     sigma,RT_rn1,RT_rn2,RT_fr1,RT_fr2,RT_sn1,RT_sn2,RT_sn3,RT_pe1,RT_pe2,RT_peL,RT_snd,  &
+     dt,NI,NK,J,KOUNT,CCNtype,precipDiag_ON,sedi_ON,warmphase_ON,autoconv_ON,icephase_ON, &
+     snow_ON,Dm_c,Dm_r,Dm_i,Dm_s,Dm_g,Dm_h,ZET,ZEC,SS,nk_bottom)
 
 
   use my_fncs_mod
@@ -1026,30 +1146,25 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
   implicit none
 
 !CALLING PARAMETERS:
-  integer,               intent(in)    :: NI,NK,N,J,KOUNT,CCNtype
+  integer,               intent(in)    :: NI,NK,J,KOUNT,CCNtype
   real,                  intent(in)    :: dt
-  real, dimension(:),    intent(in)    :: PS,PSM
-  real, dimension(:),    intent(out)   :: h_CB,h_ML1,h_ML2,h_SN
-  real, dimension(:),    intent(out)   :: RT_rn1,RT_rn2,RT_fr1,RT_fr2,RT_sn1,RT_sn2,   &
+  real, dimension(:),    intent(in)    :: PS
+  real, dimension(:),    intent(out)   :: RT_rn1,RT_rn2,RT_fr1,RT_fr2,RT_sn1,RT_sn2,     &
                                           RT_sn3,RT_pe1,RT_pe2,RT_peL,ZEC,RT_snd
-  real, dimension(:,:),  intent(in)    :: W_omega,S,GZ
-  real, dimension(:,:),  intent(inout) :: T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,     &
-        TM,QM,QCM,QRM,QIM,QNM,QGM,QHM,NCM,NRM,NYM,NNM,NGM,NHM
-  real, dimension(:,:),  intent(out)   :: T_TEND,QCTEND,QRTEND,QITEND,QNTEND,          &
-        QGTEND,QHTEND,Q_TEND,NCTEND,NRTEND,NYTEND,NNTEND,NGTEND,NHTEND,ZET,Dm_c,       &
-        Dm_r,Dm_i,Dm_s,Dm_g,Dm_h,SLW,VIS,VIS1,VIS2,VIS3,SS01,SS02,SS03,SS04,SS05,SS06, &
-        SS07,SS08,SS09,SS10,SS11,SS12,SS13,SS14,SS15,SS16,SS17,SS18,SS19,SS20
-  logical,               intent(in)    :: dblMom_c,dblMom_r,dblMom_i,dblMom_s,         &
-        dblMom_g,dblMom_h,precipDiag_ON,sedi_ON,icephase_ON,snow_ON,warmphase_ON,      &
-        autoconv_ON,initN
+  real, dimension(:,:),  intent(in)    :: WZ,sigma
+  real, dimension(:,:),  intent(inout) :: T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
+  real, dimension(:,:),  intent(out)   :: ZET,Dm_c,Dm_r,Dm_i,Dm_s,Dm_g,Dm_h
+  real, dimension(:,:,:),intent(out)   :: SS
+  logical,               intent(in)    :: precipDiag_ON,sedi_ON,icephase_ON,snow_ON,     &
+                                          warmphase_ON,autoconv_ON,nk_BOTTOM
 
 !_______________________________________________________________________________________
 !                                                                                       !
 !                    Milbrandt-Yau Multimoment Bulk Microphysics Scheme                 !
 !                              - double-moment version   -                              !
 !_______________________________________________________________________________________!
-!  Package version:   2.19.0      (internal bookkeeping)                                !
-!  Last modified  :   2011-03-02                                                        !
+!  Package version:   2.25.0      (internal bookkeeping)                                !
+!  Last modified  :   2014-03                                                           !
 !_______________________________________________________________________________________!
 !
 !  Author:
@@ -1117,26 +1232,22 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
 !                      2 = continental 1              --> N_c = 200 cm-3     "       "
 !                      3 = continental 2  (polluted)  --> N_c = 500 cm-3     "       "
 !                      4 = land-sea-mask-dependent (TBA)
-! W_omega            vertical velocity                                    [Pa s-1]
-! S                  sigma (=p/p_sfc)
-! GZ                 geopotential
-! dblMom_(x)         logical switch for double(T)-single(F)-moment for category (x)
+! WZ                 vertical velocity                                    [m s-1]
+! sigma              sigma = p/p_sfc
 ! precipDiag_ON      logical switch, .F. to suppress calc. of sfc precip types
 ! sedi_ON            logical switch, .F. to suppress sedimentation
 ! warmphase_ON       logical switch, .F. to suppress warm-phase (Part II)
 ! autoconv_ON        logical switch, .F. to supppress autoconversion (cld->rn)
 ! icephase_ON        logical switch, .F. to suppress ice-phase (Part I)
 ! snow_ON            logical switch, .F. to suppress snow initiation
+! nk_BOTTOM          logical switch, .T. for  nk at bottom (GEM, 1dkin); .F. for nk at top (WRF, 2dkin)
 !
 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
 !            - Input/Output -
 !
 ! T                  air temperature at time (t*)                         [K]
-! TM                 air temperature at time (t-dt)                       [K]
 ! Q                  water vapor mixing ratio at (t*)                     [kg kg-1]
-! QM                 water vapor mixing ratio at (t-dt)                   [kg kg-1]
 ! PS                 surface pressure at time (t*)                        [Pa]
-! PSM                surface pressure at time (t-dt)                      [Pa]
 !
 !  For x = (C,R,I,N,G,H):  C = cloud
 !                          R = rain
@@ -1146,31 +1257,12 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
 !                          H = hail
 !
 ! Q(x)               mixing ratio for hydrometeor x at (t*)               [kg kg-1]
-! Q(x)M              mixing ratio for hydrometeor x at (t-dt)             [kg kg-1]
 ! N(x)               total number concentration for hydrometeor x  (t*)   [m-3]
-! N(x)M              total number concentration for hydrometeor x  (t-dt) [m-3]
 !
-! Note:  The arrays "VM" (e.g. variables TM,QM,QCM etc.) are declared as INTENT(INOUT)
-!        such that their values are modified in the code [VM = 0.5*(VM + V)].
-!        This is to approxiate the values at time level (t), which are needed by
-!        this routine but are unavailable to the PHYSICS.  The new values are discared
-!        by the calling routine ('vkuocon6.ftn').  However, care should be taken with
-!        interfacing with other modelling systems.  For GEM/MC2, it does not matter if
-!        VM is modified since the calling module passes back only the tendencies
-!        (VTEND) to the model.
-
 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -!
 !            - Output -
 !
-! Q_TEND             tendency for water vapor mixing ratio                [kg kg-1 s-1]
-! T_TEND             tendency for air temperature                         [K s-1]
-! Q(x)TEND           tendency for mixing ratio for hydrometeor x          [kg kg-1 s-1]
-! N(x)TEND           tendency for number concentration for hydrometeor x  [m-3 s-1]
 ! Dm_(x)             mean-mass diameter for hydrometeor x                 [m]
-! H_CB               height of cloud base                                 [m]
-! h_ML1              height of first melting level from ground            [m]
-! h_ML2              height of first melting level from top               [m]
-! h_SN               height of snow level                                 [m]
 ! RT_rn1             precipitation rate (at sfc) of liquid rain           [m+3 m-2 s-1]
 ! RT_rn2             precipitation rate (at sfc) of liquid drizzle        [m+3 m-2 s-1]
 ! RT_fr1             precipitation rate (at sfc) of freezing rain         [m+3 m-2 s-1]
@@ -1182,12 +1274,7 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
 ! RT_pe1             precipitation rate (at sfc) of ice pellets (liq-eq)  [m+3 m-2 s-1]
 ! RT_pe2             precipitation rate (at sfc) of hail (total; liq-eq)  [m+3 m-2 s-1]
 ! RT_peL             precipitation rate (at sfc) of hail (large only)     [m+3 m-2 s-1]
-! SSxx               S/S terms (for testing purposes)
-! SLW                supercooled liquid water content                     [kg m-3]
-! VIS                visibility resulting from fog, rain, snow            [m]
-! VIS1               visibility component through liquid cloud (fog)      [m]
-! VIS2               visibility component through rain                    [m]
-! VIS3               visibility component through snow                    [m]
+! SS(i,k,n)          array (n) for 3D diagnostic output (e.g. S/S term)
 ! ZET                total equivalent radar reflectivity                  [dBZ]
 ! ZEC                composite (column-max) of ZET                        [dBZ]
 !_______________________________________________________________________________________!
@@ -1200,13 +1287,13 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
              SN_found
   logical, dimension(size(QC,dim=1),size(QC,dim=2)) :: activePoint
   integer, dimension(size(QC,dim=1)) :: ktop_sedi
-  integer :: i,k,niter,ll,start
+  integer :: i,k,niter,ll,start,kskip_1,ktop,kbot,kdir
 
   real    :: tmp1,tmp2,tmp3,tmp4,tmp5,tmp6,tmp7,tmp8,tmp9,tmp10,                    &
        VDmax,NNUmax,X,D,DEL,QREVP,NuDEPSOR,NuCONTA,NuCONTB,NuCONTC,iMUkin,Ecg,Erg,  &
        NuCONT,GG,Na,Tcc,F1,F2,Kdiff,PSIa,Kn,source,sink,sour,ratio,qvs0,Kstoke,     &
        DELqvs,ft,esi,Si,Simax,Vq,Vn,Vz,LAMr,No_r_DM,No_i,No_s,No_g,No_h,D_sll,      &
-       iABi,ABw,VENTr,VENTs,VENTg,VENTi,VENTh,Cdiff,Ka,MUdyn,MUkin,DEo,Ng_tail,     &
+       iABi,ABw,VENTr,VENTs,VENTg,VENTi,VENTh,Cdiff,Ka,MUdyn,MUkin,Ng_tail,         &
        gam,ScTHRD,Tc,mi,ff,Ec,Ntr,Dho,DMrain,Ech,DMice,DMsnow,DMgrpl,DMhail,        &
        ssat,Swmax,dey,Esh,Eii,Eis,Ess,Eig,Eih,FRAC,JJ,Dirg,Dirh,Dsrs,Dsrg,Dsrh,     &
        Dgrg,Dgrh,SIGc,L,TAU,DrAUT,DrINIT,Di,Ds,Dg,Dh,qFact,nFact,Ki,Rz,NgCNgh,      &
@@ -1218,11 +1305,11 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
        NCLgrh,NVDvg,NMLgr,NiCNis,NsCNis,NVDvs,NMLsr,NCLsh,NCLss,NNUvi,NFZci,NVDvi,  &
        NCLis,NCLig,NCLih,NMLir,NCLrs,NCNsg,NCLcs,NCLcg,NIMsi,NIMgi,NCLgr,NCLrg,     &
        NSHhr,RCAUTR,RCACCR,CCACCR,CCSCOC,CCAUTR,CRSCOR,ALFx,des_pmlt,Ecs,des,ides,  &
-       LAMx,iLAMx,iLAMxB0,Dx,ffx,iLAMc,iNCM,iNRM,iNYM,iNNM,iNGM,iLAMs_D3,           &
-       iLAMg,iLAMg2,iLAMgB0,iLAMgB1,iLAMgB2,iLAMh,iLAMhB0,iLAMhB1,iLAMhB2,iNHM,     &
+       LAMx,iLAMx,iLAMxB0,Dx,ffx,iLAMc,iNC,iNR,iNY,iNN,iNG,iLAMs_D3,                &
+       iLAMg,iLAMg2,iLAMgB0,iLAMgB1,iLAMgB2,iLAMh,iLAMhB0,iLAMhB1,iLAMhB2,iNH,      &
        iLAMi,iLAMi2,iLAMi3,iLAMi4,iLAMi5,iLAMiB0,iLAMiB1,iLAMiB2,iLAMr6,iLAMh2,     &
        iLAMs,iLAMs2,iLAMsB0,iLAMsB1,iLAMsB2,iLAMr,iLAMr2,iLAMr3,iLAMr4,iLAMr5,      &
-       iLAMc2,iLAMc3,iLAMc4,iLAMc5,iLAMc6,iQCM,iQRM,iQIM,iQNM,iQGM,iQHM,iEih,iEsh,  &
+       iLAMc2,iLAMc3,iLAMc4,iLAMc5,iLAMc6,iQC,iQR,iQI,iQN,iQG,iQH,iEih,iEsh,        &
        N_c,N_r,N_i,N_s,N_g,N_h,fluxV_i,fluxV_g,fluxV_s,rhos_mlt,fracLiq
 
  !Variables that only need to be calulated on the first step (and saved):
@@ -1303,10 +1390,11 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
   !       [GAMmax=sqrt(DEo/DEmin)=sqrt(1.25/0.4)~2.]  e.g. VrMAX = 2.*8.m/s = 16.m/s
   real, parameter :: DrMax=  5.e-3,   VrMax= 16.,   epsQr_sedi= 1.e-8
   real, parameter :: DiMax=  5.e-3,   ViMax=  2.,   epsQi_sedi= 1.e-10
-  real, parameter :: DsMax=  5.e-3,   VsMax=  2.,   epsQs_sedi= 1.e-8
-  real, parameter :: DgMax= 50.e-3,   VgMax=  8.,   epsQg_sedi= 1.e-8
+  real, parameter :: DsMax=  5.e-3,   VsMax=  4.,   epsQs_sedi= 1.e-8
+  real, parameter :: DgMax=  5.e-3,   VgMax=  6.,   epsQg_sedi= 1.e-8
   real, parameter :: DhMax= 80.e-3,   VhMax= 25.,   epsQh_sedi= 1.e-10
 
+  real, parameter :: DEo     = 1.225              ![kg m-3] reference air density
   real, parameter :: thrd    = 1./3.
   real, parameter :: sixth   = 0.5*thrd
   real, parameter :: Ers     = 1., Eci= 1.        !collection efficiencies, Exy, between categories x and y
@@ -1324,32 +1412,27 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
   real, parameter :: KK1         = 3.03e3         !parameter in Long (1974) kernel
   real, parameter :: KK2         = 2.59e15        !parameter in Long (1974) kernel
   real, parameter :: Dhh         = 82.e-6         ![m] diameter that rain hump first appears
-  real, parameter :: gzMax_sedi  = 200000.        !GZ value below which sedimentation is computed
+  real, parameter :: zMax_sedi   = 20000.         ![m] maximum height to compute sedimentation
   real, parameter :: Dr_large    = 200.e-6        ![m] size threshold to distinguish rain/drizzle for precip rates
   real, parameter :: Ds_large    = 200.e-6        ![m] size threshold to distinguish snow/snow-grains for precip rates
   real, parameter :: Dh_large    = 1.0e-2         ![m] size threshold for "large" hail precipitation rate
-  real, parameter :: Dh_min      = 5.0e-3         ![m] size threhsold for below which hail converts to graupel
+  real, parameter :: Dh_min      = 1.0e-3         ![m] size threhsold for below which hail converts to graupel
   real, parameter :: Dr_3cmpThrs = 2.5e-3         ![m] size threshold for hail production from 3-comp freezing
   real, parameter :: w_CNgh      = 3.             ![m s-1] vertical motion  threshold for CNgh
-! real, parameter :: r_CNgh      = 0.05           !Dg/Dho ratio threshold for CNgh
-  real, parameter :: Ngh_crit    = 0.01           ![m-3] critical graupel concentration for CNgh
+  real, parameter :: Ngh_crit    = 1.e+0          ![m-3] critical graupel concentration for CNgh
   real, parameter :: Tc_FZrh     = -10.           !temp-threshold (C) for FZrh
   real, parameter :: CNsgThres   = 1.0            !threshold for CLcs/VDvs ratio for CNsg
   real, parameter :: capFact_i   = 0.5            !capacitace factor for ice  (C= 0.5*D*capFact_i)
   real, parameter :: capFact_s   = 0.5            !capacitace factor for snow (C= 0.5*D*capFact_s)
-  real, parameter :: noVal_h_XX  = -1.            !non-value indicator for h_CB, h_ML1, h_ML2, h_SN
-  real, parameter :: minSnowSize = 1.e-4          ![m] snow size threshold to compute h_SN
   real, parameter :: Fv_Dsmin    = 125.e-6        ![m] min snow size to compute volume flux
   real, parameter :: Fv_Dsmax    = 0.008          ![m] max snow size to compute volume flux
   real, parameter :: Ni_max      = 1.e+7          ![m-3] max ice crystal concentration
 
+!------------------------------------------------------------------------------!
 !-- For GEM:
 !#include "consphy.cdk"
-!#include "dintern.cdk"
-!#include "fintern.cdk"
 
 !-- For WRF:
-!------------------------------------------------------------------------------!
 !#include "consphy.cdk"
 ! real, parameter :: CPD      =.100546e+4         !J K-1 kg-1; specific heat of dry air
 ! real, parameter :: CPV      =.186946e+4         !J K-1 kg-1; specific heat of water vapour
@@ -1375,155 +1458,7 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
   real, parameter :: RIC      =.2                 !Critical Richardson number
 ! real, parameter :: CHLC     =.2501e+7           !J kg-1; latent heat of condensation
 ! real, parameter :: CHLF     =.334e+6            !J kg-1; latent heat of fusion
-
 !------------------------------------------------------------------------------!
-!#include "dintern.cdk"
-      REAL   TTT, PRS, QQQ, EEE, TVI, QST, QQH
-      REAL   T00, PR0, TF, PF,FFF , DDFF
-      REAL   QSM , DLEMX
-      REAL*8 FOEW,FODLE,FOQST,FODQS,FOEFQ,FOQFE,FOTVT,FOTTV,FOHR
-      REAL*8 FOLV,FOLS,FOPOIT,FOPOIP,FOTTVH,FOTVHT
-      REAL*8 FOEWA,FODLA,FOQSA,FODQA,FOHRA
-      REAL*8 FESI,FDLESI,FESMX,FDLESMX,FQSMX,FDQSMX
-
-!------------------------------------------------------------------------------!
-!#include "fintern.cdk"
-!   DEFINITION DES FONCTIONS THERMODYNAMIQUES DE BASE
-!   POUR LES CONSTANTES, UTILISER LE COMMON /CONSPHY/
-!     NOTE: TOUTES LES FONCTIONS TRAVAILLENT AVEC LES UNITES S.I.
-!           I.E. TTT EN DEG K, PRS EN PA, QQQ EN KG/KG
-!          *** N. BRUNET - MAI 90 ***
-!          * REVISION 01 - MAI 94 - N. BRUNET
-!                          NOUVELLE VERSION POUR FAIBLES PRESSIONS
-!          * REVISION 02 - AOUT 2000 - J-P TOVIESSI
-!                          CALCUL EN REAL*8
-!          * REVISION 03 - SEPT 2000 - N. BRUNET
-!                          AJOUT DE NOUVELLES FONCTIONS
-!          * REVISION 04 - JANV 2000 - J. MAILHOT
-!                          FONCTIONS EN PHASE MIXTE
-!          * REVISION 05 - DEC 2001 - G. LEMAY
-!                          DOUBLE PRECISION POUR PHASE MIXTE
-!          * REVISION 06 - AVR 2002 - A. PLANTE
-!                          AJOUT DES NOUVELLES FONCTIONS FOTTVH ET FOTVHT
-!
-!     FONCTION DE TENSION DE VAPEUR SATURANTE (TETENS) - EW OU EI SELON TT
-      FOEW(TTT) = 610.78D0*DEXP( DMIN1(DSIGN(17.269D0,                     &
-       DBLE(TTT)-DBLE(TRPL)),DSIGN                                         &
-       (21.875D0,DBLE(TTT)-DBLE(TRPL)))*DABS(DBLE(TTT)-DBLE(TRPL))/        &
-       (DBLE(TTT)-35.86D0+DMAX1(0.D0,DSIGN                                 &
-       (28.2D0,DBLE(TRPL)-DBLE(TTT)))))
-!
-!     FONCTION CALCULANT LA DERIVEE SELON T DE  LN EW (OU LN EI)
-      FODLE(TTT)=(4097.93D0+DMAX1(0.D0,DSIGN(1709.88D0,                    &
-       DBLE(TRPL)-DBLE(TTT))))                                             &
-       /((DBLE(TTT)-35.86D0+DMAX1(0.D0,DSIGN(28.2D0,                       &
-       DBLE(TRPL)-DBLE(TTT))))*(DBLE(TTT)-35.86D0+DMAX1(0.D0               &
-       ,DSIGN(28.2D0,DBLE(TRPL)-DBLE(TTT)))))
-!
-!     FONCTION CALCULANT L'HUMIDITE SPECIFIQUE SATURANTE (QSAT)
-      FOQST(TTT,PRS) = DBLE(EPS1)/(DMAX1(1.D0,DBLE(PRS)/FOEW(TTT))-        &
-       DBLE(EPS2))
-!
-!     FONCTION CALCULANT LA DERIVEE DE QSAT SELON T
-      FODQS(QST,TTT)=DBLE(QST)*(1.D0+DBLE(DELTA)*DBLE(QST))*FODLE(TTT)
-!     QST EST LA SORTIE DE FOQST
-!
-!     FONCTION CALCULANT TENSION VAP (EEE) FN DE HUM SP (QQQ) ET PRS
-      FOEFQ(QQQ,PRS) = DMIN1(DBLE(PRS),(DBLE(QQQ)*DBLE(PRS)) /             &
-       (DBLE(EPS1) + DBLE(EPS2)*DBLE(QQQ)))
-!
-!      FONCTION CALCULANT HUM SP (QQQ) DE TENS. VAP (EEE) ET PRES (PRS)
-      FOQFE(EEE,PRS) = DMIN1(1.D0,DBLE(EPS1)*DBLE(EEE)/(DBLE(PRS)-         &
-       DBLE(EPS2)*DBLE(EEE)))
-!
-!      FONCTION CALCULANT TEMP VIRT. (TVI) DE TEMP (TTT) ET HUM SP (QQQ)
-      FOTVT(TTT,QQQ) = DBLE(TTT) * (1.0D0 + DBLE(DELTA)*DBLE(QQQ))
-
-!      FONCTION CALCULANT TEMP VIRT. (TVI) DE TEMP (TTT), HUM SP (QQQ) ET
-!      MASSE SP DES HYDROMETEORES.
-      FOTVHT(TTT,QQQ,QQH) = DBLE(TTT) *                                    &
-           (1.0D0 + DBLE(DELTA)*DBLE(QQQ) - DBLE(QQH))
-!
-!      FONCTION CALCULANT TTT DE TEMP VIRT. (TVI) ET HUM SP (QQQ)
-      FOTTV(TVI,QQQ) = DBLE(TVI) / (1.0D0 + DBLE(DELTA)*DBLE(QQQ))
-
-!      FONCTION CALCULANT TTT DE TEMP VIRT. (TVI), HUM SP (QQQ) ET
-!      MASSE SP DES HYDROMETEORES (QQH)
-      FOTTVH(TVI,QQQ,QQH) = DBLE(TVI) /                                    &
-           (1.0D0 + DBLE(DELTA)*DBLE(QQQ) - DBLE(QQH))
-!
-!      FONCTION CALCULANT HUM REL DE HUM SP (QQQ), TEMP (TTT) ET PRES (PRS)
-!      HR = E/ESAT
-#if (DWORDSIZE == 8 && RWORDSIZE == 8)
-       FOHR(QQQ,TTT,PRS) = MIN(     PRS ,FOEFQ(QQQ,PRS)) / FOEW(TTT)
-#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
-       FOHR(QQQ,TTT,PRS) = MIN(DBLE(PRS),FOEFQ(QQQ,PRS)) / FOEW(TTT)
-#else
-     This is a temporary hack assuming double precision is 8 bytes.
-#endif
-!
-!     FONCTION CALCULANT LA CHALEUR LATENTE DE CONDENSATION
-      FOLV(TTT) =DBLE(CHLC) - 2317.D0*(DBLE(TTT)-DBLE(TRPL))
-!
-!     FONCTION CALCULANT LA CHALEUR LATENTE DE SUBLIMATION
-      FOLS(TTT) = DBLE(CHLC)+DBLE(CHLF)+(DBLE(CPV)-                        &
-                  (7.24D0*DBLE(TTT)+128.4D0))*(DBLE(TTT)-DBLE(TRPL))
-!
-!     FONCTION RESOLVANT L'EQN. DE POISSON POUR LA TEMPERATURE
-!     NOTE: SI PF=1000*100, "FOPOIT" DONNE LE THETA STANDARD
-      FOPOIT(T00,PR0,PF)=DBLE(T00)*(DBLE(PR0)/DBLE(PF))**                  &
-                       (-DBLE(CAPPA))
-!
-!     FONCTION RESOLVANT L'EQN. DE POISSON POUR LA PRESSION
-      FOPOIP(T00,TF,PR0)=DBLE(PR0)*DEXP(-(DLOG(DBLE(T00)/DBLE(TF))/        &
-                       DBLE(CAPPA)))
-!
-!     LES 5 FONCTIONS SUIVANTES SONT VALIDES DANS LE CONTEXTE OU ON
-!     NE DESIRE PAS TENIR COMPTE DE LA PHASE GLACE DANS LES CALCULS
-!     DE SATURATION.
-!   FONCTION DE VAPEUR SATURANTE (TETENS)
-      FOEWA(TTT)=610.78D0*DEXP(17.269D0*(DBLE(TTT)-DBLE(TRPL))/            &
-       (DBLE(TTT)-35.86D0))
-!   FONCTION CALCULANT LA DERIVEE SELON T DE LN EW
-      FODLA(TTT)=17.269D0*(DBLE(TRPL)-35.86D0)/(DBLE(TTT)-35.86D0)**2
-!   FONCTION CALCULANT L'HUMIDITE SPECIFIQUE SATURANTE
-      FOQSA(TTT,PRS)=DBLE(EPS1)/(DMAX1(1.D0,DBLE(PRS)/FOEWA(TTT))-         &
-       DBLE(EPS2))
-!   FONCTION CALCULANT LA DERIVEE DE QSAT SELON T
-      FODQA(QST,TTT)=DBLE(QST)*(1.D0+DBLE(DELTA)*DBLE(QST))*FODLA(TTT)
-!   FONCTION CALCULANT L'HUMIDITE RELATIVE
-#if (DWORDSIZE == 8 && RWORDSIZE == 8)
-      FOHRA(QQQ,TTT,PRS)=MIN(     PRS ,FOEFQ(QQQ,PRS))/FOEWA(TTT)
-#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
-      FOHRA(QQQ,TTT,PRS)=MIN(DBLE(PRS),FOEFQ(QQQ,PRS))/FOEWA(TTT)
-#else
-     This is a temporary hack assuming double precision is 8 bytes.
-#endif
-!
-!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
-!
-!   Definition of basic thermodynamic functions in mixed-phase mode
-!     FFF is the fraction of ice and DDFF its derivative w/r to T
-!     NOTE: S.I. units are used
-!           i.e. TTT in deg K, PRS in Pa
-!          *** J. Mailhot - Jan. 2000 ***
-!
-!     Saturation calculations in presence of liquid phase only
-!     Function for saturation vapor pressure (TETENS)
-      FESI(TTT)=610.78D0*DEXP(21.875D0*(DBLE(TTT)-DBLE(TRPL))/             &
-             (DBLE(TTT)-7.66D0)  )
-      FDLESI(TTT)=21.875D0*(DBLE(TRPL)-7.66D0)/(DBLE(TTT)-7.66D0)**2
-      FESMX(TTT,FFF) = (1.D0-DBLE(FFF))*FOEWA(TTT)+DBLE(FFF)*FESI(TTT)
-      FDLESMX(TTT,FFF,DDFF) = ( (1.D0-DBLE(FFF))*FOEWA(TTT)*FODLA(TTT)     &
-                            + DBLE(FFF)*FESI(TTT)*FDLESI(TTT)              &
-                  + DBLE(DDFF)*(FESI(TTT)-FOEWA(TTT)) )/FESMX(TTT,FFF)
-      FQSMX(TTT,PRS,FFF) = DBLE(EPS1)/                                     &
-              (DMAX1(1.D0,DBLE(PRS)/FESMX(TTT,FFF) ) - DBLE(EPS2)  )
-      FDQSMX(QSM,DLEMX) = DBLE(QSM ) *(1.D0 + DBLE(DELTA)* DBLE(QSM ) )    &
-                           * DBLE(DLEMX )
-!
-! ! !------------------------------------------------------------------------------!
-!***** END of Replace 3 #includes (for WRF) ***
 
   ! Constants used for contact ice nucleation:
   real, parameter :: LAMa0  = 6.6e-8     ![m] mean free path at T0 and p0 [W95_eqn58]
@@ -1542,20 +1477,17 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
   integer, parameter :: primIceNucl   = 1       !1= Meyers+contact ;  2= Cooper
   real,    parameter :: outfreq       =  60.    !frequency to compute output diagnostics [s]
 
-!Passed as physics namelist parameters:
-! logical, parameter :: precipDiag_ON = .true.  !.false. to suppress calc. of sfc precip types
-! logical, parameter :: sedi_ON       = .true.  !.false. to suppress sedimentation
-! logical, parameter :: warmphase_ON  = .true.  !.false. to suppress warm-phase (Part II)
-! logical, parameter :: autoconv_ON   = .true.  ! autoconversion ON/OFF
-! logical, parameter :: icephase_ON   = .true.  !.false. to suppress ice-phase (Part I)
-! logical, parameter :: snow_ON       = .true.  !.false. to suppress snow initiation
-! logical, parameter :: initN         = .true.  !.true.  to initialize Nx of Qx>0 and Nx=0
-
-  real, dimension(size(QC,dim=1),size(QC,dim=2)) :: DE,iDE,DP,QSS,QSW,QSI,WZ,DZ,RHOQX,FLIM,  &
-        VQQ,gamfact,gamfact_r,massFlux3D_r,massFlux3D_s
-  real, dimension(size(QC,dim=1))                :: fluxM_r,fluxM_i,fluxM_s,fluxM_g,fluxM_h, &
-        HPS,dum
+  real, dimension(size(QC,dim=1),size(QC,dim=2)) :: DE,iDE,iDP,QSW,QSI,DZ,iDZ,zz,VQQ,    &
+        gamfact,pres,zheight,QC_in,QR_in,NC_in,NR_in
+  real, dimension(size(QC,dim=1))                :: fluxM_r,fluxM_i,fluxM_s,fluxM_g,     &
+        fluxM_h,dum
   integer, dimension(size(QC,dim=1))             :: activeColumn
+  integer                                        :: k_sub,nk_sub,nk_skip
+  integer                                        :: status  !for allocate/deallocate statements (0 for success)
+  integer, allocatable, dimension(:)             :: kfull,kskip
+  integer, allocatable, dimension(:,:)           :: iint
+  real, dimension(:,:), allocatable              :: DE_sub,iDE_sub,iDP_sub,pres_sub,     &
+        DZ_sub,zheight_sub,iDZ_sub,gamfact_sub
 
 
   !==================================================================================!
@@ -1564,41 +1496,58 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
   !                      PART 1:   Prelimiary Calculations                           !
   !----------------------------------------------------------------------------------!
 
-!-------------
-!Convert N from #/kg to #/m3:
-  do k= 1,nk
-    do i= 1,ni
-      tmp1= S(i,k)*PSM(i)/(RGASD*TM(i,k))  !air density at time (t-1)
-      tmp2= S(i,k)*PS(i)/(RGASD*T(i,k))    !air density at time (*)
-
-      NCM(i,k)= NCM(i,k)*tmp1;   NC(i,k)= NC(i,k)*tmp2
-      NRM(i,k)= NRM(i,k)*tmp1;   NR(i,k)= NR(i,k)*tmp2
-      NYM(i,k)= NYM(i,k)*tmp1;   NY(i,k)= NY(i,k)*tmp2
-      NNM(i,k)= NNM(i,k)*tmp1;   NN(i,k)= NN(i,k)*tmp2
-      NGM(i,k)= NGM(i,k)*tmp1;   NG(i,k)= NG(i,k)*tmp2
-      NHM(i,k)= NHM(i,k)*tmp1;   NH(i,k)= NH(i,k)*tmp2
-    enddo
+  if (nk_BOTTOM) then
+!    !GEM / kin_1d:
+     ktop  = 1          !k of top level
+     kbot  = nk         !k of bottom level
+     kdir  = -1         !direction of vertical leveling (k: 1=top, nk=bottom)
+  else
+   !WRF / kin_2d: (assuming no array flipping in wrapper)
+     ktop  = nk         !k of top level
+     kbot  = 1          !k of bottom level
+     kdir  = 1          !direction of vertical leveling (k: 1=bottom, nk=top)
+  endif
+
+!!-------- Specify levels to skip for sedimentation: -----!
+!       User-specified  (assuming nk=bottom)
+! !-- L(general), full levels
+     nk_skip = 0
+     allocate ( kskip(nk_skip), STAT=status  )
+     kskip   = 0
+! !-- L57, subset 2
+! nk_skip = 8
+! allocate ( kskip(nk_skip), STAT=status  )
+! kskip   = (/ 45, 47, 49,50, 52,53,55,56 /)
+!!========================================================!
+
+
+  do k= kbot,ktop,kdir
+     pres(:,k)= PS(:)*sigma(:,k)               !air pressure [Pa]
+     do i=1,ni
+        QSW(i,k) = qsat(T(i,k),pres(i,k),0)    !wrt. liquid water
+        QSI(i,k) = qsat(T(i,k),pres(i,k),1)    !wrt. ice
+     enddo
   enddo
-!=============
 
-  ! The SSxx arrays are for passed to the volatile bus for output as 3-D diagnostic
-  ! output variables, for testing purposes.  For example, to output the
-  ! instantanous value of the deposition rate, add 'SS01(i,k) = QVDvi'  in the
-  ! appropriate place.  It can then be output as a 3-D physics variable by adding
-  ! it to the sortie_p list in 'outcfgs.out'
+ !Air density:
+  DE  = pres/(RGASD*T)
+  iDE = 1./DE
 
-  SS01= 0.; SS02= 0.; SS03= 0.; SS04= 0.; SS05= 0.; SS06= 0.; SS07= 0.; SS08= 0.
-  SS09= 0.; SS10= 0.; SS11= 0.; SS12= 0.; SS13= 0.; SS14= 0.; SS15= 0.; SS16= 0.
-  SS17= 0.; SS18= 0.; SS19= 0.; SS20= 0.
+ !Convert N from #/kg to #/m3:
+  NC = NC*DE
+  NR = NR*DE
+  NY = NY*DE
+  NN = NN*DE
+  NG = NG*DE
+  NH = NH*DE
 
- !Determine the upper-most level in each column to which to compute sedimentation:
-  ktop_sedi= 0
-  do i=1,ni
-     do k=1,nk
-       ktop_sedi(i)= k
-       if (GZ(i,k)epsQ .and. NC(i,k)0 and Nx=0:  (for nesting from 1-moment to 2-moment):
-  IF (initN) THEN
-     do k= 1,nk
-        do i= 1,ni
-           tmp1= S(i,k)*PSM(i)/(RGASD*TM(i,k))  !air density at time (t-1)
-           tmp2= S(i,k)*PS(i)/(RGASD*T(i,k))    !air density at time (*)
+       !rain
+        if (QR(i,k)>epsQ .and. NR(i,k)epsQ .and. NCM(i,k)epsQ  .and. NC(i,k)epsQ .and. NRM(i,k)epsQ  .and. NR(i,k)epsQ .and. NYM(i,k)epsQ  .and. NY(i,k)epsQ .and. NNM(i,k)epsQ  .and. NN(i,k)epsQ .and. NGM(i,k)epsQ  .and. NG(i,k)epsQ .and. NHM(i,k)epsQ  .and. NH(i,k)epsQ .and. NY(i,k)epsQ .and. NN(i,k)epsQ .and. NG(i,k)epsQ .and. NH(i,k)TRPL) .and. log1)                   !T>0C & no i,g,s,h
-        log4= log1.and.log2.and.(QM(i,k)TRPL) .and. log1)                   !T>0C & no i,g,s,h
+        log4= log1.and.log2.and.(Q(i,k)50.)   &
         print*, '***WARNING*** -- In MICROPHYSICS --  Ambient Temp.(C):',Tc
-       Cdiff = (2.2157e-5+0.0155e-5*Tc)*1.e5/(S(i,k)*HPS(i))
-       MUdyn = 1.72e-5*(393./(TM(i,k)+120.))*(TM(i,k)/TRPL)**1.5 !RYp.102
+!      Cdiff = (2.2157e-5+0.0155e-5*Tc)*1.e5/(sigma(i,k)*HPS(i))
+       Cdiff = (2.2157e-5+0.0155e-5*Tc)*1.e5/pres(i,k)
+       MUdyn = 1.72e-5*(393./(T(i,k)+120.))*(T(i,k)/TRPL)**1.5 !RYp.102
        MUkin = MUdyn*iDE(i,k)
        iMUkin= 1./MUkin
        ScTHRD= (MUkin/Cdiff)**thrd       ! i.e. Sc^(1/3)
        Ka    = 2.3971e-2 + 0.0078e-2*Tc                                   !therm.cond.(air)
-       Kdiff = (9.1018e-11*TM(i,k)*TM(i,k)+8.8197e-8*TM(i,k)-(1.0654e-5)) !therm.diff.(air)
+       Kdiff = (9.1018e-11*T(i,k)*T(i,k)+8.8197e-8*T(i,k)-(1.0654e-5)) !therm.diff.(air)
        gam   = gamfact(i,k)
 
       !Collection efficiencies:
@@ -2110,24 +1932,16 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
        !       - Ecg is computed in CLcg section
        !       - Erg is computed in CLrg section
 
-!WRF:
-#if (DWORDSIZE == 8 && RWORDSIZE == 8)
-       qvs0  =      FOQSA(TRPL,HPS(i)*S(i,k))       !sat.mix.ratio at 0C
-#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
-       qvs0  = sngl(FOQSA(TRPL,HPS(i)*S(i,k)))      !sat.mix.ratio at 0C
-#else
-!!     This is a temporary hack assuming double precision is 8 bytes.
-#endif
-       DELqvs= qvs0-(QM(i,k))
+       qvs0   = qsat(TRPL,pres(i,k),0)      !sat.mix.ratio at 0C
+       DELqvs = qvs0-(Q(i,k))
 
     ! Cloud:
-       if (QCM(i,k)>epsQ) then
-          if (.not. dblMom_c) NCM(i,k)= N_c_SM
-          iQCM   = 1./QCM(i,k)
-          iNCM   = 1./NCM(i,k)
-          Dc     = Dm_x(DE(i,k),QCM(i,k),iNCM,icmr,thrd)
+       if (QC(i,k)>epsQ) then
+          iQC   = 1./QC(i,k)
+          iNC   = 1./NC(i,k)
+          Dc     = Dm_x(DE(i,k),QC(i,k),iNC,icmr,thrd)
 
-          iLAMc  = iLAMDA_x(DE(i,k),QCM(i,k),iNCM,icexc9,thrd)
+          iLAMc  = iLAMDA_x(DE(i,k),QC(i,k),iNC,icexc9,thrd)
           iLAMc2 = iLAMc *iLAMc
           iLAMc3 = iLAMc2*iLAMc
           iLAMc4 = iLAMc2*iLAMc2
@@ -2139,19 +1953,18 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
        endif
 
     ! Rain:
-       if (QRM(i,k)>epsQ) then
-          if (.not. dblMom_r) NRM(i,k)= GR50*sqrt(sqrt(GR31*iGR34*DE(i,k)*QRM(i,k)*icmr))
-          iQRM   = 1./QRM(i,k)
-          iNRM   = 1./NRM(i,k)
-          Dr     = Dm_x(DE(i,k),QRM(i,k),iNRM,icmr,thrd)
-          iLAMr  = max( iLAMmin1, iLAMDA_x(DE(i,k),QRM(i,k),iNRM,icexr9,thrd) )
+       if (QR(i,k)>epsQ) then
+          iQR   = 1./QR(i,k)
+          iNR   = 1./NR(i,k)
+          Dr     = Dm_x(DE(i,k),QR(i,k),iNR,icmr,thrd)
+          iLAMr  = max( iLAMmin1, iLAMDA_x(DE(i,k),QR(i,k),iNR,icexr9,thrd) )
           tmp1   = 1./iLAMr
-          iLAMr2 = iLAMr *iLAMr
-          iLAMr3 = iLAMr2*iLAMr
-          iLAMr4 = iLAMr2*iLAMr2
-          iLAMr5 = iLAMr3*iLAMr2
+          iLAMr2 = iLAMr**2
+          iLAMr3 = iLAMr**3
+          iLAMr4 = iLAMr**4
+          iLAMr5 = iLAMr**5
           if (Dr>40.e-6) then
-             vr0 = gamfact_r(i,k)*ckQr1*iLAMr**bfr
+             vr0 = gamfact(i,k)*ckQr1*iLAMr**bfr
           else
              vr0 = 0.
           endif
@@ -2161,21 +1974,19 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
        endif
 
     ! Ice:
-       if (QIM(i,k)>epsQ) then
-          if (.not. dblMom_i) NYM(i,k)= N_Cooper(TRPL,TM(i,k))
-
-          iQIM   = 1./QIM(i,k)
-          iNYM   = 1./NYM(i,k)
-          iLAMi  = max( iLAMmin2, iLAMDA_x(DE(i,k),QIM(i,k),iNYM,icexi9,thrd) )
-          iLAMi2 = iLAMi *iLAMi
-          iLAMi3 = iLAMi2*iLAMi
-          iLAMi4 = iLAMi2*iLAMi2
-          iLAMi5 = iLAMi3*iLAMi2
+       if (QI(i,k)>epsQ) then
+          iQI   = 1./QI(i,k)
+          iNY   = 1./NY(i,k)
+          iLAMi  = max( iLAMmin2, iLAMDA_x(DE(i,k),QI(i,k),iNY,icexi9,thrd) )
+          iLAMi2 = iLAMi**2
+          iLAMi3 = iLAMi**3
+          iLAMi4 = iLAMi**4
+          iLAMi5 = iLAMi**5
           iLAMiB0= iLAMi**(bfi)
           iLAMiB1= iLAMi**(bfi+1.)
           iLAMiB2= iLAMi**(bfi+2.)
           vi0    = gamfact(i,k)*ckQi1*iLAMiB0
-          Di     = Dm_x(DE(i,k),QIM(i,k),iNYM,icmi,thrd)
+          Di     = Dm_x(DE(i,k),QI(i,k),iNY,icmi,thrd)
        else
           iLAMi  = 0.;  vi0    = 0.;  Di     = 0.
           iLAMi2 = 0.;  iLAMi3 = 0.;  iLAMi4 = 0.;  iLAMi5= 0.
@@ -2183,91 +1994,72 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
        endif
 
     ! Snow:
-       if (QNM(i,k)>epsQ) then
-          if (.not.dblMom_s) then
-             No_s_SM = Nos_Thompson(TRPL,TM(i,k))
-             NNM(i,k)= (No_s*GS31)**(dms*icexs2)*(GS31*iGS40*icms*DE(i,k)*QNM(i,k))**    &
-                       ((1.+alpha_s)*icexs2)
-          endif
-          iQNM   = 1./QNM(i,k)
-          iNNM   = 1./NNM(i,k)
-          iLAMs  = max( iLAMmin2, iLAMDA_x(DE(i,k),QNM(i,k),iNNM,iGS20,idms) )
-          iLAMs_D3= max(iLAMmin2, iLAMDA_x(DE(i,k),QNM(i,k),iNNM,iGS20_D3,thrd) )
-          iLAMs2 = iLAMs*iLAMs
+       if (QN(i,k)>epsQ) then
+          iQN   = 1./QN(i,k)
+          iNN   = 1./NN(i,k)
+          iLAMs  = max( iLAMmin2, iLAMDA_x(DE(i,k),QN(i,k),iNN,iGS20,idms) )
+          iLAMs_D3= max(iLAMmin2, iLAMDA_x(DE(i,k),QN(i,k),iNN,iGS20_D3,thrd) )
+          iLAMs2 = iLAMs**2
           iLAMsB0= iLAMs**(bfs)
           iLAMsB1= iLAMs**(bfs+1.)
           iLAMsB2= iLAMs**(bfs+2.)
           vs0    = gamfact(i,k)*ckQs1*iLAMsB0
-          Ds     = min(DsMax, Dm_x(DE(i,k),QNM(i,k),iNNM,icms,idms))
+          Ds     = min(DsMax, Dm_x(DE(i,k),QN(i,k),iNN,icms,idms))
           if (snowSpherical) then
              des = desFix
           else
              des = des_OF_Ds(Ds,desMax,eds,fds)
           endif
          !!-- generalized equations (any alpha_s):
-         !    No_s  = (NNM(i,k))*iGS31/iLAMs**(1.+alpha_s)
+         !    No_s  = (NN(i,k))*iGS31/iLAMs**(1.+alpha_s)
          !    VENTs = Avx*GS32*iLAMs**(2.+alpha_s)+Bvx*ScTHRD*sqrt(gam*afs*iMUkin)*      &
          !!--         GS09*iLAMs**(2.5+0.5*bfs+alpha_s)
          !The following equations for No_s and VENTs is based on m(D)=(pi/6)*100.*D**3 for snow.
          !  Strict application of m(D)=c*D**2 would require re-derivation using implied
          !  definition of D as the MAXIMUM DIMENSION of an ellipsoid, rather than a sphere.
          !  For simplicity, the m-D^3 relation is applied -- used for VDvs and MLsr only.
-         if (dblMom_s) then
-           !No_s= NNM(i,k)*iGS31/iLAMs     !optimized for alpha_s=0
-            No_s= NNM(i,k)*iGS31/iLAMs_D3  !based on m-D^3 (consistent with VENTs, below)
-         else
-            No_s= No_s_SM
-         endif
+        !No_s= NN(i,k)*iGS31/iLAMs     !optimized for alpha_s=0
+         No_s= NN(i,k)*iGS31/iLAMs_D3  !based on m-D^3 (consistent with VENTs, below)
          VENTs= Avx*GS32*iLAMs_D3**2. + Bvx*ScTHRD*sqrt(gamfact(i,k)*afs*iMUkin)*GS09*   &
                 iLAMs_D3**cexs1
        else
           iLAMs  = 0.;  vs0    = 0.;  Ds     = 0.;  iLAMs2= 0.
           iLAMsB0= 0.;  iLAMsB1= 0.;  iLAMsB1= 0.
-          des    = desFix !used for 3-component freezing if QNM=0 (even for snowSpherical=.F.)
+          des    = desFix !used for 3-component freezing if QN=0 (even for snowSpherical=.F.)
        endif
        ides  = 1./des
 
 
     ! Graupel:
-       if (QGM(i,k)>epsQ) then
-          if (.not.dblMom_g) NGM(i,k)= GG50*sqrt(sqrt(GG31*GG34*DE(i,k)*QGM(i,k)*icmg))
-          iQGM   = 1./QGM(i,k)
-          iNGM   = 1./NGM(i,k)
-          iLAMg  = max( iLAMmin1, iLAMDA_x(DE(i,k),QGM(i,k),iNGM,iGG99,thrd) )
-          iLAMg2 = iLAMg *iLAMg
+       if (QG(i,k)>epsQ) then
+          iQG    = 1./QG(i,k)
+          iNG    = 1./NG(i,k)
+          iLAMg  = max( iLAMmin1, iLAMDA_x(DE(i,k),QG(i,k),iNG,iGG99,thrd) )
+          iLAMg2 = iLAMg**2
           iLAMgB0= iLAMg**(bfg)
           iLAMgB1= iLAMg**(bfg+1.)
           iLAMgB2= iLAMg**(bfg+2.)
-          if (dblMom_g) then
-            !No_g = (NGM(i,k))*iGG31/iLAMg**(1.+alpha_g)
-             No_g= NGM(i,k)*iGG31/iLAMg     !optimized for alpha_g=0
-          else
-             No_g= No_g_SM
-          endif
+         !No_g = (NG(i,k))*iGG31/iLAMg**(1.+alpha_g)
+          No_g= NG(i,k)*iGG31/iLAMg     !optimized for alpha_g=0
           vg0    = gamfact(i,k)*ckQg1*iLAMgB0
-          Dg     = Dm_x(DE(i,k),QGM(i,k),iNGM,icmg,thrd)
+          Dg     = Dm_x(DE(i,k),QG(i,k),iNG,icmg,thrd)
        else
           iLAMg  = 0.;  vg0    = 0.;  Dg     = 0.;  No_g   = 0.
           iLAMg2 = 0.;  iLAMgB0= 0.;  iLAMgB1= 0.;  iLAMgB1= 0.
        endif
 
     ! Hail:
-       if (QHM(i,k)>epsQ) then
-          if (.not.dblMom_h) NHM(i,k)= GH50*sqrt(sqrt(GH31*iGH34*DE(i,k)*QHM(i,k)*icmh))
-          iQHM   = 1./QHM(i,k)
-          iNHM   = 1./NHM(i,k)
-          iLAMh  = max( iLAMmin1, iLAMDA_x(DE(i,k),QHM(i,k),iNHM,iGH99,thrd) )
-          iLAMh2 = iLAMh*iLAMh
+       if (QH(i,k)>epsQ) then
+          iQH    = 1./QH(i,k)
+          iNH    = 1./NH(i,k)
+          iLAMh  = max( iLAMmin1, iLAMDA_x(DE(i,k),QH(i,k),iNH,iGH99,thrd) )
+          iLAMh2 = iLAMh**2
           iLAMhB0= iLAMh**(bfh)
           iLAMhB1= iLAMh**(bfh+1.)
           iLAMhB2= iLAMh**(bfh+2.)
-          if (dblMom_h) then
-               No_h= NHM(i,k)*iGH31/iLAMh**(1.+alpha_h)
-          else
-               No_h= No_h_SM
-          endif
+          No_h= NH(i,k)*iGH31/iLAMh**(1.+alpha_h)
           vh0    = gamfact(i,k)*ckQh1*iLAMhB0
-          Dh     = Dm_x(DE(i,k),QHM(i,k),iNHM,icmh,thrd)
+          Dh     = Dm_x(DE(i,k),QH(i,k),iNH,icmh,thrd)
        else
           iLAMh  = 0.;  vh0    = 0.;  Dh     = 0.;  No_h= 0.
           iLAMhB0= 0.;  iLAMhB1= 0.;  iLAMhB1= 0.
@@ -2297,26 +2089,29 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
 
    !-------------------------------------------------------------------------------------------!
 
+       Si    = Q(i,k)/QSI(i,k)
+       iABi  = 1./( CHLS*CHLS/(Ka*RGASV*T(i,k)**2) + 1./(DE(i,k)*(QSI(i,k))*Cdiff) )
+
            ! COLLECTION by snow, graupel, hail:
            !  (i.e. wet or dry ice-categories [=> excludes ice crystals])
 
            ! Collection by SNOW:
-       if (QNM(i,k)>epsQ) then
+       if (QN(i,k)>epsQ) then
           ! cloud:
-          if (QCM(i,k)>epsQ) then
+          if (QC(i,k)>epsQ) then
 
             !Approximation of Ecs based on Pruppacher & Klett (1997) Fig. 14-11
              Ecs= min(Dc,30.e-6)*3.333e+4*sqrt(min(Ds,1.e-3)*1.e+3)
-             QCLcs= dt*gam*afs*cmr*Ecs*PIov4*iDE(i,k)*(NCM(i,k)*NNM(i,k))*iGC5*iGS31*    &
+             QCLcs= dt*gam*afs*cmr*Ecs*PIov4*iDE(i,k)*(NC(i,k)*NN(i,k))*iGC5*iGS31*    &
                     (GC13*GS13*iLAMc3*iLAMsB2+2.*GC14*GS12*iLAMc4*iLAMsB1+GC15*GS11*     &
                     iLAMc5*iLAMsB0)
 
-             NCLcs= dt*gam*afs*PIov4*Ecs*(NCM(i,k)*NNM(i,k))*iGC5*iGS31*(GC5*GS13*       &
+             NCLcs= dt*gam*afs*PIov4*Ecs*(NC(i,k)*NN(i,k))*iGC5*iGS31*(GC5*GS13*       &
                     iLAMsB2+2.*GC11*GS12*iLAMc*iLAMsB1+GC12*GS11*iLAMc2*iLAMsB0)
 
             !continuous collection: (alternative; gives values ~0.95 of SCE [above])
-            !QCLcs= dt*gam*Ecs*PIov4*afs*QCM(i,k)*NNM(i,k)*iLAMs**(2.+bfs)*GS13*iGS31
-            !NCLcs= QCLcs*NCM(i,k)/QCM(i,k)
+            !QCLcs= dt*gam*Ecs*PIov4*afs*QC(i,k)*NN(i,k)*iLAMs**(2.+bfs)*GS13*iGS31
+            !NCLcs= QCLcs*NC(i,k)/QC(i,k)
 
             !Correction factor for non-spherical snow [D = maximum dimension] which
             !changes projected area:   [assumption: A=0.50*D**2 (vs. A=(PI/4)*D**2)]
@@ -2328,164 +2123,179 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
                 NCLcs= tmp1*NCLcs
              endif
 
-             QCLcs= min(QCLcs, QCM(i,k))
-             NCLcs= min(NCLcs, NCM(i,k))
+             QCLcs= min(QCLcs, QC(i,k))
+             NCLcs= min(NCLcs, NC(i,k))
           else
              QCLcs= 0.;   NCLcs= 0.
           endif
 
           ! ice:
-          if (QIM(i,k)>epsQ) then
+          if (QI(i,k)>epsQ) then
              tmp1= vs0-vi0
              tmp3= sqrt(tmp1*tmp1+0.04*vs0*vi0)
 
-             QCLis= dt*cmi*iDE(i,k)*PI*6.*Eis*(NYM(i,k)*NNM(i,k))*tmp3*iGI31*iGS31*(0.5* &
+             QCLis= dt*cmi*iDE(i,k)*PI*6.*Eis*(NY(i,k)*NN(i,k))*tmp3*iGI31*iGS31*(0.5* &
                     iLAMs2*iLAMi3+2.*iLAMs*iLAMi4+5.*iLAMi5)
 
-             NCLis= dt*PIov4*Eis*(NYM(i,k)*NNM(i,k))*GI31*GS31*tmp3*(GI33*GS31*iLAMi2+   &
+             NCLis= dt*PIov4*Eis*(NY(i,k)*NN(i,k))*GI31*GS31*tmp3*(GI33*GS31*iLAMi2+   &
                     2.*GI32*GS32*iLAMi*iLAMs+GI31*GS33*iLAMs2)
 
-             QCLis= min(QCLis, (QIM(i,k)))
-             NCLis= min(QCLis*(NYM(i,k)*iQIM), NCLis)
+             QCLis= min(QCLis, (QI(i,k)))
+             NCLis= min(QCLis*(NY(i,k)*iQI), NCLis)
           else
              QCLis= 0.;   NCLis= 0.
           endif
 
-          if (dblMom_s) then
-             !snow: (i.e. self-collection [aggregation])
-             NCLss= dt*0.93952*Ess*(DE(i,k)*(QNM(i,k)))**((2.+bfs)*thrd)*(NNM(i,k))**    &
-                    ((4.-bfs)*thrd)
-               !Note: 0.91226 = I(bfs)*afs*PI^((1-bfs)/3)*des^((-2-bfs)/3); I(bfs=0.41)=1138
-               !      0.93952 = I(bfs)*afs*PI^((1-bfs)/3)*des^((-2-bfs)/3); I(bfs=0.42)=1172
-               !      [interpolated from 3rd-order polynomial approx. of values given in RRB98;
-               !       see eqn(A.35)]
-             NCLss= min(NCLss, 0.5*(NNM(i,k)))
-          endif
+          !snow: (i.e. self-collection [aggregation])
+          NCLss= dt*0.93952*Ess*(DE(i,k)*(QN(i,k)))**((2.+bfs)*thrd)*(NN(i,k))**    &
+                   ((4.-bfs)*thrd)
+            !Note: 0.91226 = I(bfs)*afs*PI^((1-bfs)/3)*des^((-2-bfs)/3); I(bfs=0.41)=1138
+            !      0.93952 = I(bfs)*afs*PI^((1-bfs)/3)*des^((-2-bfs)/3); I(bfs=0.42)=1172
+            !      [interpolated from 3rd-order polynomial approx. of values given in RRB98;
+            !       see eqn(A.35)]
+           NCLss= min(NCLss, 0.5*(NN(i,k)))
 
        else
           QCLcs= 0.;   NCLcs= 0.;   QCLis= 0.;   NCLis= 0.;  NCLss= 0.
        endif
 
        ! Collection by GRAUPEL:
-       if (QGM(i,k)>epsQ) then
+       if (QG(i,k)>epsQ) then
 
           ! cloud:
-          if (QCM(i,k)>epsQ) then
+          if (QC(i,k)>epsQ) then
 
             !(parameterization of Ecg based on Cober and List, 1993 [JAS])
              Kstoke = dew*vg0*Dc*Dc/(9.*MUdyn*Dg)
              Kstoke = max(1.5,min(10.,Kstoke))
              Ecg    = 0.55*log10(2.51*Kstoke)
 
-             QCLcg= dt*gam*afg*cmr*Ecg*PIov4*iDE(i,k)*(NCM(i,k)*NGM(i,k))*iGC5*iGG31*    &
+             QCLcg= dt*gam*afg*cmr*Ecg*PIov4*iDE(i,k)*(NC(i,k)*NG(i,k))*iGC5*iGG31*    &
                     (GC13*GG13*iLAMc3*iLAMgB2+ 2.*GC14*GG12*iLAMc4*iLAMgB1+GC15*GG11*    &
                     iLAMc5*iLAMgB0)
 
-             NCLcg= dt*gam*afg*PIov4*Ecg*(NCM(i,k)*NGM(i,k))*iGC5*iGG31*(GC5*GG13*       &
+             NCLcg= dt*gam*afg*PIov4*Ecg*(NC(i,k)*NG(i,k))*iGC5*iGG31*(GC5*GG13*       &
                     iLAMgB2+2.*GC11*GG12*iLAMc*iLAMgB1+GC12*GG11*iLAMc2*iLAMgB0)
 
-             QCLcg= min(QCLcg, (QCM(i,k)))
-             NCLcg= min(NCLcg, (NCM(i,k)))
+             QCLcg= min(QCLcg, (QC(i,k)))
+             NCLcg= min(NCLcg, (NC(i,k)))
           else
              QCLcg= 0.;   NCLcg= 0.
           endif
 
           ! ice:
-          if (QIM(i,k)>epsQ) then
+          if (QI(i,k)>epsQ) then
              tmp1= vg0-vi0
              tmp3= sqrt(tmp1*tmp1+0.04*vg0*vi0)
 
-             QCLig= dt*cmi*iDE(i,k)*PI*6.*Eig*(NYM(i,k)*NGM(i,k))*tmp3*iGI31*iGG31*(0.5* &
+             QCLig= dt*cmi*iDE(i,k)*PI*6.*Eig*(NY(i,k)*NG(i,k))*tmp3*iGI31*iGG31*(0.5* &
                     iLAMg2*iLAMi3+2.*iLAMg*iLAMi4+5.*iLAMi5)
-             NCLig= dt*PIov4*Eig*(NYM(i,k)*NGM(i,k))*GI31*GG31*tmp3*(GI33*GG31*iLAMi2+   &
+             NCLig= dt*PIov4*Eig*(NY(i,k)*NG(i,k))*GI31*GG31*tmp3*(GI33*GG31*iLAMi2+   &
                     2.*GI32*GG32*iLAMi*iLAMg+GI31*GG33*iLAMg2)
 
-             QCLig= min(QCLig, (QIM(i,k)))
-             NCLig= min(QCLig*(NYM(i,k)*iQIM), NCLig)
+             QCLig= min(QCLig, (QI(i,k)))
+             NCLig= min(QCLig*(NY(i,k)*iQI), NCLig)
           else
              QCLig= 0.;   NCLig= 0.
           endif
 
+         !Deposition/sublimation:
+          VENTg= Avx*GG32*iLAMg*iLAMg+Bvx*ScTHRD*sqrt(gam*afg*iMUkin)*GG09*iLAMg**       &
+                 (2.5+0.5*bfg+alpha_g)
+!         QVDvg = dt*iDE(i,k)*iABi*(PI2*(Si-1.)*No_g*VENTg - CHLS*CHLF/(Ka*RGASV*        &
+!                   T(i,k)**2)*QCLcg*idt)
+          QVDvg = dt*iDE(i,k)*iABi*(PI2*(Si-1.)*No_g*VENTg)   !neglect accretion term
+          ! Prevent overdepletion of vapor:
+          VDmax = (Q(i,k)-QSI(i,k))/(1.+ck6*QSI(i,k)/(T(i,k)-7.66)**2)  !KY97_A.33
+          if(Si>=1.) then
+             QVDvg= min(max(QVDvg,0.),VDmax)
+          else
+             if (VDmax<0.) QVDvg= max(QVDvg,VDmax)
+             !IF prevents subl.(QVDvs<0 at t) changing to dep.(VDmax>0 at t*)
+          endif
+         !NVDvg = -min(0.,NG(i,k)*iQG*QVDvg)  !assume slope  does not change during sublimation (pos. quantity)
+          NVDvg = 0.                            !assume number does not change during sublimation
+
        else
           QCLcg= 0.;   QCLrg= 0.;   QCLig= 0.
           NCLcg= 0.;   NCLrg= 0.;   NCLig= 0.
        endif
 
        ! Collection by HAIL:
-       if (QHM(i,k)>epsQ) then
+       if (QH(i,k)>epsQ) then
 
          ! cloud:
-          if (QCM(i,k)>epsQ) then
+          if (QC(i,k)>epsQ) then
              Ech  = exp(-8.68e-7*Dc**(-1.6)*Dh)    !Ziegler (1985) A24
 
-             QCLch= dt*gam*afh*cmr*Ech*PIov4*iDE(i,k)*(NCM(i,k)*NHM(i,k))*iGC5*iGH31*    &
+             QCLch= dt*gam*afh*cmr*Ech*PIov4*iDE(i,k)*(NC(i,k)*NH(i,k))*iGC5*iGH31*    &
                     (GC13*GH13*iLAMc3*iLAMhB2+2.*GC14*GH12*iLAMc4*iLAMhB1+GC15*GH11*     &
                     iLAMc5*iLAMhB0)
 
-             NCLch= dt*gam*afh*PIov4*Ech*(NCM(i,k)*NHM(i,k))*iGC5*iGH31*(GC5*GH13*       &
+             NCLch= dt*gam*afh*PIov4*Ech*(NC(i,k)*NH(i,k))*iGC5*iGH31*(GC5*GH13*       &
                     iLAMhB2+2.*GC11*GH12*iLAMc*iLAMhB1+GC12*GH11*iLAMc2*iLAMhB0)
 
-             QCLch= min(QCLch, QCM(i,k))
-             NCLch= min(NCLch, NCM(i,k))
+             QCLch= min(QCLch, QC(i,k))
+             NCLch= min(NCLch, NC(i,k))
           else
              QCLch= 0.;   NCLch= 0.
           endif
 
           ! rain:
-          if (QRM(i,k)>epsQ) then
+          if (QR(i,k)>epsQ) then
              tmp1= vh0-vr0
              tmp3= sqrt(tmp1*tmp1+0.04*vh0*vr0)
-             QCLrh= dt*cmr*Erh*PIov4*iDE(i,k)*(NHM(i,k)*NRM(i,k))*iGR31*iGH31*tmp3*      &
+             QCLrh= dt*cmr*Erh*PIov4*iDE(i,k)*(NH(i,k)*NR(i,k))*iGR31*iGH31*tmp3*      &
                     (GR36*GH31*iLAMr5+2.*GR35*GH32*iLAMr4*iLAMh+GR34*GH33*iLAMr3*iLAMh2)
 
-             NCLrh= dt*PIov4*Erh*(NHM(i,k)*NRM(i,k))*iGR31*iGH31*tmp3*(GR33*GH31*        &
+             NCLrh= dt*PIov4*Erh*(NH(i,k)*NR(i,k))*iGR31*iGH31*tmp3*(GR33*GH31*        &
                     iLAMr2+2.*GR32*GH32*iLAMr*iLAMh+GR31*GH33*iLAMh2)
 
-             QCLrh= min(QCLrh, QRM(i,k))
-             NCLrh= min(NCLrh, QCLrh*(NRM(i,k)*iQRM))
+             QCLrh= min(QCLrh, QR(i,k))
+             NCLrh= min(NCLrh, QCLrh*(NR(i,k)*iQR))
           else
              QCLrh= 0.;   NCLrh= 0.
           endif
 
           ! ice:
-          if (QIM(i,k)>epsQ) then
+          if (QI(i,k)>epsQ) then
              tmp1 = vh0-vi0
              tmp3 = sqrt(tmp1*tmp1+0.04*vh0*vi0)
 
-             QCLih= dt*cmi*iDE(i,k)*PI*6.*Eih*(NYM(i,k)*NHM(i,k))*tmp3*iGI31*iGH31*(0.5* &
+             QCLih= dt*cmi*iDE(i,k)*PI*6.*Eih*(NY(i,k)*NH(i,k))*tmp3*iGI31*iGH31*(0.5* &
                     iLAMh2*iLAMi3+2.*iLAMh*iLAMi4+5.*iLAMi5)
 
-             NCLih= dt*PIov4*Eih*(NYM(i,k)*NHM(i,k))*GI31*GH31*tmp3*(GI33*GH31*iLAMi2+   &
+             NCLih= dt*PIov4*Eih*(NY(i,k)*NH(i,k))*GI31*GH31*tmp3*(GI33*GH31*iLAMi2+   &
                     2.*GI32*GH32*iLAMi*iLAMh+GI31*GH33*iLAMh2)
 
-             QCLih= min(QCLih, QIM(i,k))
-             NCLih= min(QCLih*(NYM(i,k)*iQIM), NCLih)
+             QCLih= min(QCLih, QI(i,k))
+             NCLih= min(QCLih*(NY(i,k)*iQI), NCLih)
           else
              QCLih= 0.;   NCLih= 0.
           endif
 
           ! snow:
-          if (QNM(i,k)>epsQ) then
+          if (QN(i,k)>epsQ) then
              tmp1 = vh0-vs0
              tmp3 = sqrt(tmp1*tmp1+0.04*vh0*vs0)
              tmp4 = iLAMs2*iLAMs2
 
              if (snowSpherical) then
                !hardcoded for dms=3:
-                QCLsh= dt*cms*iDE(i,k)*PI*6.*Esh*(NNM(i,k)*NHM(i,k))*tmp3*iGS31*iGH31*  &
+                QCLsh= dt*cms*iDE(i,k)*PI*6.*Esh*(NN(i,k)*NH(i,k))*tmp3*iGS31*iGH31*  &
                        (0.5*iLAMh2*iLAMs2*iLAMs+2.*iLAMh*tmp4+5.*tmp4*iLAMs)
              else
                !hardcoded for dms=2:
-                QCLsh= dt*cms*iDE(i,k)*PI*0.25*Esh*tmp3*NNM(i,k)*NHM(i,k)*iGS31*iGH31*  &
+                QCLsh= dt*cms*iDE(i,k)*PI*0.25*Esh*tmp3*NN(i,k)*NH(i,k)*iGS31*iGH31*  &
                        (GH33*GS33*iLAMh**2.*iLAMs**2. + 2.*GH32*GS34*iLAMh*iLAMs**3. +  &
                         GH31*GS35*iLAMs**4.)
              endif
 
-             NCLsh= dt*PIov4*Esh*(NNM(i,k)*NHM(i,k))*GS31*GH31*tmp3*(GS33*GH31*iLAMs2+  &
+             NCLsh= dt*PIov4*Esh*(NN(i,k)*NH(i,k))*GS31*GH31*tmp3*(GS33*GH31*iLAMs2+  &
                     2.*GS32*GH32*iLAMs*iLAMh+GS31*GH33*iLAMh2)
 
-             QCLsh= min(QCLsh, (QNM(i,k)))
-             NCLsh= min((NNM(i,k)*iQNM)*QCLsh, NCLsh, (NNM(i,k)))
+             QCLsh= min(QCLsh, (QN(i,k)))
+             NCLsh= min((NN(i,k)*iQN)*QCLsh, NCLsh, (NN(i,k)))
           else
              QCLsh= 0.;   NCLsh= 0.
           endif
@@ -2496,89 +2306,96 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
           QHwet= max(0., dt*PI2*(DE(i,k)*CHLC*Cdiff*DELqvs-Ka*Tc)*No_h*iDE(i,k)/(CHLF+   &
                  CPW*Tc)*VENTh+(QCLih*iEih+QCLsh*iEsh)*(1.-CPI*Tc/(CHLF+CPW*Tc)) )
 
+         !Deposition/sublimation:
+!         QVDvh = dt*iDE(i,k)*iABi*(PI2*(Si-1.)*No_h*VENTh - CHLS*CHLF/(Ka*RGASV*        &
+!                   T(i,k)**2)*QCLch*idt)
+          QVDvh = dt*iDE(i,k)*iABi*(PI2*(Si-1.)*No_h*VENTh)   !neglect acretion term
+          !prevent overdepletion of vapor:
+          VDmax = (Q(i,k)-QSI(i,k))/(1.+ck6*(QSI(i,k))/(T(i,k)-7.66)**2)  !KY97_A.33    ** USED BY OTHERS; COULD BE PUT ABOVE
+          if(Si>=1.) then
+             QVDvh= min(max(QVDvh,0.),VDmax)
+          else
+             if (VDmax<0.) QVDvh= max(QVDvh,VDmax)  !prevents subl.(QVDvs<0 at t) changing to dep.(VDmax>0 at t*)
+          endif
+!         NVDvh= -min(0.,NH(i,k)*iQH*QVDvh)  !assume SLOPE does not change during sublimation (pos. quantity)
+          NVDvh= 0.                            !assume NUMBER does not change during sublimation
+
        else
           QCLch= 0.;   QCLrh= 0.;   QCLih= 0.;   QCLsh= 0.;   QHwet= 0.
           NCLch= 0.;   NCLrh= 0.;   NCLsh= 0.;   NCLih= 0.
        endif
 
-       IF (TM(i,k)>TRPL .and. warmphase_ON) THEN
+       IF (T(i,k)>TRPL .and. warmphase_ON) THEN
           !**********!
           !  T > To  !
           !**********!
 
           ! MELTING of frozen particles:
           !  ICE:
-          QMLir   = QIM(i,k)  !all pristine ice melts in one time step
-          QIM(i,k)= 0.
-          NMLir   = NYM(i,k)
+          QMLir   = QI(i,k)  !all pristine ice melts in one time step
+          QI(i,k)= 0.
+          NMLir   = NY(i,k)
 
           !  SNOW:
-          if (QNM(i,k)>epsQ) then
+          if (QN(i,k)>epsQ) then
              QMLsr= dt*(PI2*iDE(i,k)*iCHLF*No_s*VENTs*(Ka*Tc-CHLC*Cdiff*DELqvs) + CPW*   &
                     iCHLF*Tc*(QCLcs+QCLrs)*idt)
-             QMLsr= min(max(QMLsr,0.), QNM(i,k))
-             NMLsr= NNM(i,k)*iQNM*QMLsr
+             QMLsr= min(max(QMLsr,0.), QN(i,k))
+             NMLsr= NN(i,k)*iQN*QMLsr
           else
              QMLsr= 0.;   NMLsr= 0.
           endif
 
           !  GRAUPEL:
-          if (QGM(i,k)>epsQ) then
-             VENTg= Avx*GG32*iLAMg*iLAMg+Bvx*ScTHRD*sqrt(gam*afg*iMUkin)*GG09*iLAMg**    &
-                    (2.5+0.5*bfg+alpha_g)
+          if (QG(i,k)>epsQ) then
              QMLgr= dt*(PI2*iDE(i,k)*iCHLF*No_g*VENTg*(Ka*Tc-CHLC*Cdiff*DELqvs) + CPW*   &
                     iCHLF*Tc*(QCLcg+QCLrg)*idt)
-             QMLgr= min(max(QMLgr,0.), QGM(i,k))
-             NMLgr= NGM(i,k)*iQGM*QMLgr
+             QMLgr= min(max(QMLgr,0.), QG(i,k))
+             NMLgr= NG(i,k)*iQG*QMLgr
           else
              QMLgr= 0.;   NMLgr= 0.
           endif
 
           !  HAIL:
-          if (QHM(i,k)>epsQ.and.Tc>5.) then
+          if (QH(i,k)>epsQ.and.Tc>5.) then
              VENTh= Avx*GH32*iLAMh**(2.+alpha_h) + Bvx*ScTHRD*sqrt(gam*afh*iMUkin)*GH09* &
                     iLAMh**(2.5+0.5*bfh+alpha_h)
              QMLhr= dt*(PI2*iDE(i,k)*iCHLF*No_h*VENTh*(Ka*Tc-CHLC*Cdiff*DELqvs) + CPW/   &
                     CHLF*Tc*(QCLch+QCLrh)*idt)
-             QMLhr= min(max(QMLhr,0.), QHM(i,k))
-             NMLhr= NHM(i,k)*iQHM*QMLhr
+             QMLhr= min(max(QMLhr,0.), QH(i,k))
+             NMLhr= NH(i,k)*iQH*QMLhr
              if(QCLrh>0.) NMLhr= NMLhr*0.1   !Prevents problems when hail is ML & CL
           else
              QMLhr= 0.;   NMLhr= 0.
           endif
 
          ! Cold (sub-zero) source/sink terms:
-          QNUvi= 0.;   QFZci= 0.;   QVDvi= 0.;   QVDvs= 0.;   QVDvg= 0.
-          QCLis= 0.;   QCNis1=0.;   QCNis2=0.
-          QCNgh= 0.;   QIMsi= 0.;   QIMgi= 0.;   QCLir= 0.;   QCLri= 0.
-          QCLrs= 0.;   QCLgr= 0.;   QCLrg= 0.;   QCNis= 0.;   QVDvh= 0.
+          QNUvi= 0.;   QFZci= 0.;   QVDvi= 0.;   QVDvs= 0.
+          QCLis= 0.;   QCNis1=0.;   QCNis2=0.;   QCLri= 0.
+          QCNgh= 0.;   QIMsi= 0.;   QIMgi= 0.;   QCLir= 0.
+          QCLrs= 0.;   QCLgr= 0.;   QCLrg= 0.;   QCNis= 0.
           QCNsg= 0.;   QCLsr= 0.
 
           NNUvi= 0.;   NFZci= 0.;   NCLgr= 0.;   NCLrg= 0.;   NgCNgh= 0.
-          NCLis= 0.;   NVDvi= 0.;   NVDvs= 0.;   NVDvg= 0.;   NVDvh= 0.
-          NCNsg= 0.;   NhCNgh= 0.;  NiCNis=0.;   NsCNis=0.;   NCLrs= 0.
-          NIMsi= 0.;   NIMgi= 0.;   NCLir= 0.;   NCLri= 0.;   NCLsr= 0.
-
-       ELSE
-          !----------!
-          !  T < To  !
-          !----------!
-          tmp1  = 1./QSI(i,k)
-          Si    = QM(i,k) *tmp1
-          tmp2  = TM(i,k)*TM(i,k)
-          iABi  = 1./( CHLS*CHLS/(Ka*RGASV*tmp2) + 1./(DE(i,k)*(QSI(i,k))*Cdiff) )
+          NCLis= 0.;   NVDvi= 0.;   NVDvs= 0.;   NCLri= 0.;   NCLsr= 0.
+          NCNsg= 0.;   NhCNgh= 0.;  NiCNis=0.;   NsCNis=0.
+          NIMsi= 0.;   NIMgi= 0.;   NCLir= 0.;   NCLrs= 0.
+
+       ELSE  !----------!
+             !  T < To  !
+             !----------!
 
           ! Warm-air-only source/sink terms:
           QMLir= 0.;   QMLsr= 0.;   QMLgr= 0.;   QMLhr= 0.
           NMLir= 0.;   NMLsr= 0.;   NMLgr= 0.;   NMLhr= 0.
 
           !Probabilistic freezing (Bigg) of rain:
-          if (TcepsQ .and. hail_ON) then
+          if (TcepsQ .and. hail_ON) then
              !note: - (Tc<-10.C) condition is based on Pruppacher-Klett (1997) Fig. 9-41
              !      - Small raindrops will freeze to hail. However, if after all S/S terms
              !        are added DhepsQ) then
-                tmp2  = Tc*Tc; tmp3= tmp2*Tc; tmp4= tmp2*tmp2
-                JJ    = (10.**max(-20.,(-606.3952-52.6611*Tc-1.7439*tmp2-0.0265*tmp3-    &
-                         1.536e-4*tmp4)))
-                tmp1  = 1.e6*(DE(i,k)*(QCM(i,k)*iNCM)*icmr) !i.e. Dc[cm]**3
-                FRAC  = 1.-exp(-JJ*PIov6*tmp1*dt)
-                if (Tc>-30.) FRAC= 0.
-                if (Tc<-50.) FRAC= 1.
-                QFZci= FRAC*QCM(i,k)
-                NFZci= FRAC*NCM(i,k)
-             else
-                QFZci= 0.;   NFZci= 0.
-             endif
+          if (QC(i,k)>epsQ) then
+             tmp2  = Tc*Tc; tmp3= tmp2*Tc; tmp4= tmp2*tmp2
+             JJ    = (10.**max(-20.,(-606.3952-52.6611*Tc-1.7439*tmp2-0.0265*tmp3-    &
+                      1.536e-4*tmp4)))
+             tmp1  = 1.e6*(DE(i,k)*(QC(i,k)*iNC)*icmr) !i.e. Dc[cm]**3
+             FRAC  = 1.-exp(-JJ*PIov6*tmp1*dt)
+             if (Tc>-30.) FRAC= 0.
+             if (Tc<-50.) FRAC= 1.
+             QFZci= FRAC*QC(i,k)
+             NFZci= FRAC*NC(i,k)
           else
-             !Homogeneous freezing of cloud to ice:  (simplified)
-             if (QCM(i,k)>epsQ .and. Tc<-35.) then
-                FRAC= 1.  !if T<-35
-                QFZci= FRAC*QCM(i,k)
-                NFZci= FRAC*N_c_SM
-             else
-                QFZci= 0.;   NFZci= 0.
-             endif
+             QFZci= 0.;   NFZci= 0.
           endif
 
-          if (dblMom_i) then
-            !Primary ice nucleation:
-            NNUvi= 0.;   QNUvi= 0.
-            if (primIceNucl==1) then
-
-               NuDEPSOR= 0.;   NuCONT= 0.
-               Simax   = min(Si, SxFNC(WZ(i,k),Tc,HPS(i)*S(i,k),QSW(i,k),QSI(i,k),CCNtype, &
-                              2))
-               tmp1    = T(i,k)-7.66
-               NNUmax  = max(0., DE(i,k)/mio*(Q(i,k)-QSS(i,k))/(1.+ck6*(QSS(i,k)/(tmp1*    &
-                        tmp1))))
-               !Deposition/sorption nucleation:
-               if (Tc<-5. .and. Si>1.) then
-                  NuDEPSOR= max(0., 1.e3*exp(12.96*(Simax-1.)-0.639)-(NYM(i,k))) !Meyers(1992)
-               endif
-               !Contact nucleation:
-               if (QCM(i,k)>epsQ .and. Tc<-2.) then
-                  GG     =  1.*idew/(RGASV*(TM(i,k))/((QSW(i,k)*HPS(i)*S(i,k))/EPS1)/      &
-                              Cdiff+CHLC/Ka/(TM(i,k))*(CHLC/RGASV/(TM(i,k))-1.))  !CP00a
-                  Swmax  =  SxFNC(WZ(i,k),Tc,HPS(i)*S(i,k),QSW(i,k),QSI(i,k),CCNtype,1)
-                  ssat   =  min((QM(i,k)/QSW(i,k)), Swmax) -1.
-                  Tcc    =  Tc + GG*ssat*CHLC/Kdiff                            !C86_eqn64
-                  Na     =  exp(4.11-0.262*Tcc)                                !W95_eqn60/M92_2.6
-                  Kn     =  LAMa0*(TM(i,k))*p0/(T0*(HPS(i)*S(i,k))*Ra)         !W95_eqn59
-                  PSIa   =  -kBoltz*Tcc/(6.*pi*Ra*MUdyn)*(1.+Kn)               !W95_eqn58
-                  ft     =  0.4*(1.+1.45*Kn+0.4*Kn*exp(-1./Kn))*(Ka+2.5*Kn*KAPa)/          &
-                           (1.+3.*Kn)/(2.*Ka+5.*KAPa*Kn+KAPa)                  !W95_eqn57
-                  Dc     =  (DE(i,k)*(QCM(i,k)*iNCM)*icmr)**thrd
-                  F1     =  PI2*Dc*Na*(NCM(i,k))                               !W95_eqn55
-                  F2     =  Ka/(HPS(i)*S(i,k))*(Tc-Tcc)                        !W95_eqn56
-                  NuCONTA= -F1*F2*RGASV*(TM(i,k))/CHLC*iDE(i,k)                !diffusiophoresis
-                  NuCONTB=  F1*F2*ft*iDE(i,k)                                  !thermeophoresis
-                  NuCONTC=  F1*PSIa                                            !Brownian diffusion
-                  NuCONT =  max(0.,(NuCONTA+NuCONTB+NuCONTC)*dt)
-               endif
-               !Total primary ice nucleation:
-               if (icephase_ON) then
-                  NNUvi= min(NNUmax, NuDEPSOR + NuCONT )
-                  QNUvi= mio*iDE(i,k)*NNUvi
-                  QNUvi= min(QNUvi,(Q(i,k)))
-               endif
-
-            elseif (primIceNucl==2) then
-               if (Tc<-5. .and. Si>1.08) then !following Thompson etal (2006)
-                  NNUvi= max(N_Cooper(TRPL,T(i,k))-NYM(i,k),0.)
-                  QNUvi= min(mio*iDE(i,k)*NNUvi, Q(i,k))
-               endif
-           !elseif (primIceNucl==3) then
-           !! (for alternative [future] ice nucleation parameterizations)
-           !   NNUvi=...
-           !   QNUvi=...
-            endif !if (primIceNucl==1)
-
-          else !dblMom_i
-          !Ice initiation (single-moment):
-             if (QIM(i,k)<=epsQ .and. Tc<-5. .and. Si>1.08) then !following Thompson etal (2006)
-                NNUvi = N_Cooper(TRPL,T(i,k))
+          !Primary ice nucleation:
+          NNUvi= 0.;   QNUvi= 0.
+          if (primIceNucl==1) then
+
+             NuDEPSOR= 0.;   NuCONT= 0.
+             Simax   = min(Si, SxFNC(WZ(i,k),Tc,pres(i,k),QSW(i,k),QSI(i,k),CCNtype,2))
+             tmp1    = T(i,k)-7.66
+             NNUmax  = max(0., DE(i,k)/mio*(Q(i,k)-QSI(i,k))/(1.+ck6*(QSI(i,k)/(tmp1*    &
+                       tmp1))))
+             !Deposition/sorption nucleation:
+             if (Tc<-5. .and. Si>1.) then
+                NuDEPSOR= max(0., 1.e3*exp(12.96*(Simax-1.)-0.639)-(NY(i,k))) !Meyers(1992)
+             endif
+             !Contact nucleation:
+             if (QC(i,k)>epsQ .and. Tc<-2.) then
+                GG     =  1.*idew/(RGASV*(T(i,k))/((QSW(i,k)*pres(i,k))/EPS1)/          &
+                            Cdiff+CHLC/Ka/(T(i,k))*(CHLC/RGASV/(T(i,k))-1.))  !CP00a
+                Swmax  =  SxFNC(WZ(i,k),Tc,pres(i,k),QSW(i,k),QSI(i,k),CCNtype,1)
+                ssat   =  min((Q(i,k)/QSW(i,k)), Swmax) -1.
+                Tcc    =  Tc + GG*ssat*CHLC/Kdiff                            !C86_eqn64
+                Na     =  exp(4.11-0.262*Tcc)                                !W95_eqn60/M92_2.6
+                Kn     =  LAMa0*(T(i,k))*p0/(T0*pres(i,k)*Ra)               !W95_eqn59
+                PSIa   =  -kBoltz*Tcc/(6.*pi*Ra*MUdyn)*(1.+Kn)               !W95_eqn58
+                ft     =  0.4*(1.+1.45*Kn+0.4*Kn*exp(-1./Kn))*(Ka+2.5*Kn*KAPa)/          &
+                         (1.+3.*Kn)/(2.*Ka+5.*KAPa*Kn+KAPa)                  !W95_eqn57
+                Dc     =  (DE(i,k)*(QC(i,k)*iNC)*icmr)**thrd
+                F1     =  PI2*Dc*Na*(NC(i,k))                               !W95_eqn55
+                F2     =  Ka/pres(i,k)*(Tc-Tcc)                              !W95_eqn56
+                NuCONTA= -F1*F2*RGASV*(T(i,k))/CHLC*iDE(i,k)                !diffusiophoresis
+                NuCONTB=  F1*F2*ft*iDE(i,k)                                  !thermeophoresis
+                NuCONTC=  F1*PSIa                                            !Brownian diffusion
+                NuCONT =  max(0.,(NuCONTA+NuCONTB+NuCONTC)*dt)
+             endif
+             !Total primary ice nucleation:
+             if (icephase_ON) then
+                NNUvi= min(NNUmax, NuDEPSOR + NuCONT )
                 QNUvi= mio*iDE(i,k)*NNUvi
-                QNUvi= min(QNUvi,Q(i,k))
+                QNUvi= min(QNUvi,(Q(i,k)))
+             endif
+
+          elseif (primIceNucl==2) then
+             if (Tc<-5. .and. Si>1.08) then !following Thompson etal (2006)
+                NNUvi= max(N_Cooper(TRPL,T(i,k))-NY(i,k),0.)
+                QNUvi= min(mio*iDE(i,k)*NNUvi, Q(i,k))
              endif
-          endif !dblMom_i
+         !elseif (primIceNucl==3) then
+         !! (for alternative [future] ice nucleation parameterizations)
+         !   NNUvi=...
+         !   QNUvi=...
+          endif !if (primIceNucl==1)
 
 
-          IF (QIM(i,k)>epsQ) THEN
+
+          IF (QI(i,k)>epsQ) THEN
 
              !Deposition/sublimation:
-!            No_i  = NYM(i,k)*iGI31/iLAMi**(1.+alpha_i)
+!            No_i  = NY(i,k)*iGI31/iLAMi**(1.+alpha_i)
 !            VENTi= Avx*GI32*iLAMi**(2.+alpha_i)+Bvx*ScTHRD*sqrt(gam*afi*iMUkin)*GI6*    &
 !                     iLAMi**(2.5+0.5*bfi+alpha_i)
-             No_i  = NYM(i,k)*iGI31/iLAMi    !optimized for alpha_i=0
+             No_i  = NY(i,k)*iGI31/iLAMi    !optimized for alpha_i=0
              VENTi= Avx*GI32*iLAMi*iLAMi+Bvx*ScTHRD*sqrt(gam*afi*iMUkin)*GI6*iLAMi**     &
                     (2.5+0.5*bfi+alpha_i)
             !Note: ice crystal capacitance is implicitly C = 0.5*D*capFact_i
-             QVDvi= dt*capFact_i*iABi*(PI2*(Si-1.)*No_i*VENTi)
+!            QVDvi= dt*capFact_i*iABi*(PI2*(Si-1.)*No_i*VENTi)
+             QVDvi = dt*iDE(i,k)*capFact_i*iABi*(PI2*(Si-1.)*No_i*VENTi)
 
              ! Prevent overdepletion of vapor:
-             tmp1  = T(i,k)-7.66
-             VDmax = (Q(i,k)-QSS(i,k))/(1.+ck6*(QSS(i,k))/(tmp1*tmp1))
+             VDmax = (Q(i,k)-QSI(i,k))/(1.+ck6*(QSI(i,k))/(T(i,k)-7.66)**2)
              if(Si>=1.) then
                 QVDvi= min(max(QVDvi,0.),VDmax)
              else
@@ -2706,56 +2502,54 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
                !IF prevents subl.(QVDvi<0 at t) changing to dep.(VDmax>0 at t*)  2005-06-28
              endif
              if (.not. iceDep_ON) QVDvi= 0. !suppresses depositional growth
-             NVDvi= min(0., (NYM(i,k)*iQIM)*QVDvi) !dNi/dt=0 for deposition
+             NVDvi= min(0., (NY(i,k)*iQI)*QVDvi) !dNi/dt=0 for deposition
 
              ! Conversion to snow:
-             !   +depostion of ice:
-             mi= DE(i,k)*(QIM(i,k)*iNYM)
-             if (mi<=0.5*mso.and.abs(0.5*mso-mi)>1.e-20) then
-                QCNis1= (mi/(mso-mi))*QVDvi
-             else
-                QCNis1= QVDvi + (1.-0.5*mso/mi)*QIM(i,k)
-             endif
-             QCNis1= max(0., QCNis1)
-             !   +aggregation of ice:
-             if(Di<0.5*Dso) then
-                Ki    = PIov6*Di*Di*vi0*Eii*Xdisp
-                tmp1  = log(Di/Dso)
-                tmp2  = tmp1*tmp1*tmp1
-                QCNis2= -dt*0.5*(QIM(i,k)*NYM(i,k))*Ki/tmp2
-             else
-                Ki= 0.;   QCNis2= 0.
+             if (QI(i,k)+QVDvi>epsQ .and. NY(i,k)+NVDvi>epsN) then
+                tmp5   = iLAMi !hold value
+                tmp6   = No_i  !hold value
+               !estimate ice PSD after VDvi (if there were no CNis):
+                tmp1   = QI(i,k) + QVDvi
+                tmp2   = NY(i,k) + NVDvi
+                iLAMi  = max( iLAMmin2, iLAMDA_x(DE(i,k),tmp1,1./tmp2,icexi9,thrd) )
+                No_i   = tmp2*iGI31/iLAMi    !optimized for alpha_i=0
+               !compute number and mass of ice converted to snow as the integral from
+               ! Dso to INF of Ni(D)dD and m(D)Ni(D)dD, respectively:
+                tmp4   = exp(-Dso/iLAMi)
+                NiCNis = No_i*iLAMi*tmp4
+                NsCNis = NiCNis
+                QCNis  = cmi*No_i*tmp4*(Dso**3*iLAMi + 3.*Dso**2*iLAMi**2 + 6.*Dso*      &
+                         iLAMi**3 + 6.*iLAMi**4)
+                iLAMi  = tmp5  !(restore value)
+                No_i   = tmp6  !(restore value)
              endif
-             !   +total conversion rate:
-             QCNis = QCNis1 + QCNis2
-             NsCNis= DE(i,k)*imso*QCNis                               !source for snow (Ns)
-             NiCNis= (DE(i,k)*imso*QCNis1 + 0.5*Ki*NYM(i,k)*NYM(i,k)) !sink for ice (Ni)
-             NiCNis= min(NiCNis, NYM(i,k)*0.1) !Prevents overdepl. of NY when final QI>0
-
-             if (.not.(snow_ON)) then
-                QCNis= 0.; NiCNis= 0.; NsCNis= 0.  !Suppress SNOW initiation
+
+             if (.not.(snow_ON)) then  !Suppress SNOW initiation (for testing only)
+                QCNis  = 0.
+                NiCNis = 0.
+                NsCNis = 0.
              endif
 
              ! 3-component freezing (collisions with rain):
-             if (QRM(i,k)>epsQ .and. QIM(i,k)>epsQ) then
+             if (QR(i,k)>epsQ .and. QI(i,k)>epsQ) then
                 tmp1 = vr0-vi0
                 tmp3 = sqrt(tmp1*tmp1+0.04*vr0*vi0)
 
-                QCLir= dt*cmi*Eri*PIov4*iDE(i,k)*(NRM(i,k)*NYM(i,k))*iGI31*iGR31*tmp3*   &
+                QCLir= dt*cmi*Eri*PIov4*iDE(i,k)*(NR(i,k)*NY(i,k))*iGI31*iGR31*tmp3*   &
                        (GI36*GR31*iLAMi5+2.*GI35*GR32*iLAMi4*iLAMr+GI34*GR33*iLAMi3*     &
                        iLAMr2)
 
-                NCLri= dt*PIov4*Eri*(NRM(i,k)*NYM(i,k))*iGI31*iGR31*tmp3*(GI33*GR31*     &
+                NCLri= dt*PIov4*Eri*(NR(i,k)*NY(i,k))*iGI31*iGR31*tmp3*(GI33*GR31*     &
                        iLAMi2+2.*GI32*GR32*iLAMi*iLAMr+GI31*GR33*iLAMr2)
 
-                QCLri= dt*cmr*Eri*PIov4*iDE(i,k)*(NYM(i,k)*NRM(i,k))*iGR31*iGI31*tmp3*   &
+                QCLri= dt*cmr*Eri*PIov4*iDE(i,k)*(NY(i,k)*NR(i,k))*iGR31*iGI31*tmp3*   &
                        (GR36*GI31 *iLAMr5+2.*GR35*GI32*iLAMr4*iLAMi+GR34*GI33*iLAMr3*    &
                        iLAMi2)
 
                !note: For explicit eqns, both NCLri and NCLir are mathematically identical)
-                NCLir= min(QCLir*(NYM(i,k)*iQIM), NCLri)
-                QCLri= min(QCLri, (QRM(i,k)));  QCLir= min(QCLir, (QIM(i,k)))
-                NCLri= min(NCLri, (NRM(i,k)));  NCLir= min(NCLir, (NYM(i,k)))
+                NCLir= min(QCLir*(NY(i,k)*iQI), NCLri)
+                QCLri= min(QCLri, (QR(i,k)));  QCLir= min(QCLir, (QI(i,k)))
+                NCLri= min(NCLri, (NR(i,k)));  NCLir= min(NCLir, (NY(i,k)))
 
                 !Determine destination of 3-comp.freezing:
                 tmp1= max(Di,Dr)
@@ -2792,69 +2586,71 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
           !---------!
           !  SNOW:  !
           !---------!
-          IF (QNM(i,k)>epsQ) THEN
+          IF (QN(i,k)>epsQ) THEN
 
             !Deposition/sublimation:
              !note: - snow crystal capacitance is implicitly C = 0.5*D*capFact_s
              !      - No_s and VENTs are computed above
-             QVDvs = dt*capFact_s*iABi*(PI2*(Si-1.)*No_s*VENTs - CHLS*CHLF/(Ka*RGASV*    &
-                     TM(i,k)*TM(i,k))*QCLcs*idt)
+!             QVDvs = dt*capFact_s*iABi*(PI2*(Si-1.)*No_s*VENTs - CHLS*CHLF/(Ka*RGASV*    &
+!                     T(i,k)*T(i,k))*QCLcs*idt)
+             QVDvs = dt*iDE(i,k)*capFact_s*iABi*(PI2*(Si-1.)*No_s*VENTs - CHLS*CHLF/(Ka* &
+                     RGASV*T(i,k)**2)*QCLcs*idt)
 
              ! Prevent overdepletion of vapor:
-             tmp1  = T(i,k)-7.66
-             VDmax = (Q(i,k)-QSS(i,k))/(1.+ck6*(QSS(i,k))/(tmp1*tmp1))  !KY97_A.33
+             VDmax = (Q(i,k)-QSI(i,k))/(1.+ck6*(QSI(i,k))/(T(i,k)-7.66)**2)
              if(Si>=1.) then
                 QVDvs= min(max(QVDvs,0.),VDmax)
              else
                 if (VDmax<0.) QVDvs= max(QVDvs,VDmax)
                 !IF prevents subl.(QVDvs<0 at t) changing to dep.(VDmax>0 at t*)
              endif
-             NVDvs= -min(0.,(NNM(i,k)*iQNM)*QVDvs)  !pos. quantity
+             NVDvs= -min(0.,(NN(i,k)*iQN)*QVDvs)  !pos. quantity
 
              ! Conversion to graupel:
-             if (QCLcs>CNsgThres*QVDvs .and. 0.99*deg>des) then
-               !note: The (deg>des) condition equates to (Ds>330microns) for m(D)=0.069D^2
-               !      relation for snow, which implies a variable bulk density.  The physical
-               !      assumption in the QCNsg equation is that snow converts to graupel due
-               !      to densification from riming.
-               !      The 0.99 is to prevent overflow if des~deg
-                QCNsg= (deg/(deg-des))*QCLcs
+             if (QCLcs>0. .and. QCLcs>CNsgThres*QVDvs .and. grpl_ON) then
+                tmp1 = 100.  !tuning factor: controls amount of mass either added or removed
+                             !from snow (QN) during partial conversion to graupel. [If QCLcs/QN > 1/tmp1,
+                             !then some snow mass will be converted to graupel (in addition to rime mass).]
+                QCNsg = min( QN(i,k)+QCLcs, QCLcs*(tmp1*QCLcs/QN(i,k)) )
+               !calculate NCNsg: [explicit logic]
+               !mgo   = DE(i,k)*(QN(i,k)+QCLsg)/NN(i,k)  !mean-mass of new graupel
+               !NCNsg = DE(i,k)*QCNsg/mgo
+               !calculate NCNsg: [optimized; substituting mgo and factoring]
+                NCNsg = DE(i,k)*QCNsg/(QN(i,k)+QCLcs)
              else
-                QCNsg= 0.
+                QCNsg = 0.
+                NCNsg = 0.
              endif
-             if (.not. grpl_ON) QCNsg= 0.
-             NCNsg= DE(i,k)*imgo*QCNsg
-             NCNsg= min(NCNsg, (0.5*NNM(i,k)*iQNM)*QCNsg) !Prevents incorrect Ns-depletion
 
              ! 3-component freezing (collisions with rain):
-              if (QRM(i,k)>epsQ .and. QNM(i,k)>epsQ .and. Tc<-5.) then
+              if (QR(i,k)>epsQ .and. QN(i,k)>epsQ .and. Tc<-5.) then
                 tmp1 = vs0-vr0
                 tmp2 = sqrt(tmp1*tmp1+0.04*vs0*vr0)
                 tmp6 = iLAMs2*iLAMs2*iLAMs
 
-                QCLrs= dt*cmr*Ers*PIov4*iDE(i,k)*NNM(i,k)*NRM(i,k)*iGR31*iGS31*tmp2*     &
+                QCLrs= dt*cmr*Ers*PIov4*iDE(i,k)*NN(i,k)*NR(i,k)*iGR31*iGS31*tmp2*     &
                        (GR36*GS31*iLAMr5+2.*GR35*GS32*iLAMr4*iLAMs+GR34*GS33*iLAMr3*     &
                        iLAMs2)
 
-                NCLrs= dt*0.25e0*PI*Ers*(NNM(i,k)*NRM(i,k))*iGR31*iGS31*tmp2*(GR33*      &
+                NCLrs= dt*0.25e0*PI*Ers*(NN(i,k)*NR(i,k))*iGR31*iGS31*tmp2*(GR33*      &
                        GS31*iLAMr2+2.*GR32*GS32*iLAMr*iLAMs+GR31*GS33*iLAMs2)
 
                 if (snowSpherical) then
                   !hardcoded for dms=3:
-                   QCLsr= dt*cms*Ers*PIov4*iDE(i,k)*(NRM(i,k)*NNM(i,k))*iGS31*iGR31*     &
+                   QCLsr= dt*cms*Ers*PIov4*iDE(i,k)*(NR(i,k)*NN(i,k))*iGS31*iGR31*     &
                           tmp2*(GS36*GR31*tmp6+2.*GS35*GR32*iLAMs2*iLAMs2*iLAMr+GS34*    &
                           GR33*iLAMs2*iLAMs*iLAMr2)
                 else
                   !hardcoded for dms=2:
-                   QCLsr= dt*cms*iDE(i,k)*PI*0.25*ERS*tmp2*NNM(i,k)*NRM(i,k)*iGS31*      &
+                   QCLsr= dt*cms*iDE(i,k)*PI*0.25*ERS*tmp2*NN(i,k)*NR(i,k)*iGS31*      &
                           iGR31*(GR33*GS33*iLAMr**2.*iLAMs**2. + 2.*GR32*GS34*iLAMr*     &
                           iLAMs**3. +GR31*GS35*iLAMs**4.)
                 endif
 
                !note: For explicit eqns, NCLsr = NCLrs
-                NCLsr= min(QCLsr*(NNM(i,k)*iQNM), NCLrs)
-                QCLrs= min(QCLrs, QRM(i,k));  QCLsr= min(QCLsr, QNM(i,k))
-                NCLrs= min(NCLrs, NRM(i,k));  NCLsr= min(NCLsr, NNM(i,k))
+                NCLsr= min(QCLsr*(NN(i,k)*iQN), NCLrs)
+                QCLrs= min(QCLrs, QR(i,k));  QCLsr= min(QCLsr, QN(i,k))
+                NCLrs= min(NCLrs, NR(i,k));  NCLsr= min(NCLsr, NN(i,k))
 
                 ! Determine destination of 3-comp.freezing:
                 Dsrs= 0.;   Dsrg= 0.;    Dsrh= 0.
@@ -2883,57 +2679,42 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
           !------------!
           !  GRAUPEL:  !
           !------------!
-          IF (QGM(i,k)>epsQ) THEN
+          IF (QG(i,k)>epsQ) THEN
 
            !Conversion to hail:    (D_sll given by S-L limit)
-             if (WZ(i,k)>w_CNgh .and. hail_ON) then
-                D_sll = 0.01*(exp(min(20.,-Tc/(1.1e4*DE(i,k)*(QCM(i,k)+QRM(i,k))-1.3e3*  &
-                        DE(i,k)*(QIM(i,k))+1.)))-1.)
-               !Add correction factor: [to account error in equation of Ziegler (1985), as per Young (1993)]
-                D_sll = 2.0*D_sll
+             if ( (QCLcg+QCLrg)>0. .and. hail_ON ) then
+!               D_sll = 0.01*(exp(min(20.,-Tc/(1.1e4*DE(i,k)*(QC(i,k)+QR(i,k))-1.3e3*DE(i,k)*QI(i,k)+1.)))-1.)
+!               D_sll = 2.0*D_sll !correction factor [error Ziegler (1985), as per Young (1993)]
+                D_sll = 2.*0.01*(exp(min(20.,-Tc/(1.1e4*DE(i,k)*(QC(i,k)+QR(i,k)) + 1.)))-1.)
                 D_sll = min(1., max(0.0001,D_sll))    !smallest D_sll=0.1mm; largest=1m
-
-            !Old approach:  (pre-my-2.15.0)
-!                 ratio= Dg/D_sll
-!                 if (ratio>r_CNgh) then
-!                    QCNgh= (0.5*ratio)*(QCLcg+QCLrg+QCLig)
-!                    QCNgh= min(QCNgh,(QGM(i,k))+QCLcg+QCLrg+QCLig)
-!                    NCNgh= DE(i,k)*QCNgh*icmh/(D_sll*D_sll*D_sll)
-!                 else
-!                    QCNgh= 0.
-!                    NCNgh= 0.
-!                 endif
-            !New approach:
-                tmp1     = exp(-D_sll/iLAMg)
-                Ng_tail  = No_g*iLAMg*tmp1  !integral(Dsll,inf) of N(D)dD
+                tmp1  = iLAMg !hold value
+                tmp2  = No_g  !hold value
+               !estimate PSD after accretion (and before conversion to hail): (assume inverse-exponential)
+                tmp3  = QG(i,k) + QCLcg + QCLrg
+                iLAMg = exp(thrd*log(DE(i,k)*tmp3/(NG(i,k)*6*cmg)))
+                No_g  = NG(i,k)/iLAMg
+                tmp4  = exp(-D_sll/iLAMg)
+                Ng_tail = No_g*iLAMg*tmp4
                 if (Ng_tail > Ngh_crit) then
-                   QCNgh = idt*cmg*No_g*tmp1*(D_sll**3.*iLAMg + 3.*D_sll**2.*iLAMg**2.   &
-                           + 6.*D_sll*iLAMg**3. + 6.*iLAMg**4.)
-                   NgCNgh= idt*No_g*iLAMg*tmp1
+                   NgCNgh= min(NG(i,k), Ng_tail)
+                   QCNgh = min(QG(i,k), cmg*No_g*tmp4*(D_sll**3*iLAMg + 3.*D_sll**2*    &
+                                         iLAMg**2 + 6.*D_sll*iLAMg**3 + 6.*iLAMg**4) )
                    Rz= 1.
-                   !---
-                   ! The Rz factor (<>1) serves to conserve reflectivity when graupel
+                   ! The Rz factor (/=1) serves to conserve reflectivity when graupel
                    ! converts to hail with a a different shape parameter, alpha.
-                   ! The factor Rz non-conserves N while acting to conserve Z for
-                   ! double-moment.  See Ferrier, 1994 App. D).  However, Rz=1 is
-                   ! used since it is deemed more important to conserve concentration
-                   ! than reflectivity (see Milbrandt and McTaggart-Cowan, 2010 JAS).
-                   !---
-                   ! Code to conserve total reflectivity:
-                   ! if  (QHM(i,k)>epsQ) then
-                   !    Rz= (gamma(7.+alpha_h)*GH31*GG34**2.)/(GG36*GG31*GH34**2.)
-                   ! else
-                   !    Rz= 1.
-                   ! endif
-                   !---
-                   NhCNgh= Rz*NgCNgh
+                   ! (See Ferrier, 1994 App. D).
+                   NhCNgh = Rz*NgCNgh
                 else
-                   QCNgh  = 0.;   NgCNgh = 0.;   NhCNgh = 0.
+                   QCNgh  = 0.
+                   NgCNgh = 0.
+                   NhCNgh = 0.
                 endif
+                iLAMg = tmp1  !restore value
+                No_g  = tmp2  !restore value
              endif
 
           !3-component freezing (collisions with rain):
-             if (QRM(i,k)>epsQ) then
+             if (QR(i,k)>epsQ) then
                 tmp1 = vg0-vr0
                 tmp2 = sqrt(tmp1*tmp1 + 0.04*vg0*vr0)
                 tmp8 = iLAMg2*iLAMg      ! iLAMg**3
@@ -2945,20 +2726,20 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
                 Kstoke = max(1.5,min(10.,Kstoke))
                 Erg    = 0.55*log10(2.51*Kstoke)
 
-                QCLrg= dt*cmr*Erg*PIov4*iDE(i,k)*(NGM(i,k)*NRM(i,k))*iGR31*iGG31*tmp2*   &
+                QCLrg= dt*cmr*Erg*PIov4*iDE(i,k)*(NG(i,k)*NR(i,k))*iGR31*iGG31*tmp2*   &
                        (GR36*GG31*iLAMr5+2.*GR35*GG32*iLAMr4*iLAMg+GR34*GG33*iLAMr3*     &
                        iLAMg2)
 
-                NCLrg= dt*PIov4*Erg*(NGM(i,k)*NRM(i,k))*iGR31*iGG31*tmp2*(GR33*GG31*     &
+                NCLrg= dt*PIov4*Erg*(NG(i,k)*NR(i,k))*iGR31*iGG31*tmp2*(GR33*GG31*     &
                        iLAMr2+2.*GR32*GG32*iLAMr*iLAMg+GR31*GG33*iLAMg2)
 
-                QCLgr= dt*cmg*Erg*PIov4*iDE(i,k)*(NRM(i,k)*NGM(i,k))*iGG31*iGR31*tmp2*   &
+                QCLgr= dt*cmg*Erg*PIov4*iDE(i,k)*(NR(i,k)*NG(i,k))*iGG31*iGR31*tmp2*   &
                        (GG36*GR31*tmp10+2.*GG35*GR32*tmp9*iLAMr+GG34*GR33*tmp8*iLAMr2)
 
                !(note: For explicit eqns, NCLgr= NCLrg)
-                NCLgr= min(NCLrg, QCLgr*(NGM(i,k)*iQGM))
-                QCLrg= min(QCLrg, QRM(i,k));  QCLgr= min(QCLgr, QGM(i,k))
-                NCLrg= min(NCLrg, NRM(i,k));  NCLgr= min(NCLgr, NGM(i,k))
+                NCLgr= min(NCLrg, QCLgr*(NG(i,k)*iQG))
+                QCLrg= min(QCLrg, QR(i,k));  QCLgr= min(QCLgr, QG(i,k))
+                NCLrg= min(NCLrg, NR(i,k));  NCLgr= min(NCLgr, NG(i,k))
 
                ! Determine destination of 3-comp.freezing:
                 tmp1= max(Dg,Dr)
@@ -2975,21 +2756,21 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
 
           ELSE
 
-             QVDvg= 0.;  QCNgh= 0.;  QCLgr= 0.;  QCLrg= 0.;  NgCNgh= 0.
-             NVDvg= 0.;  NhCNgh= 0.; NCLgr= 0.;  NCLrg= 0.
+             QCNgh= 0.;  QCLgr= 0.;  QCLrg= 0.;  NgCNgh= 0.
+             NhCNgh= 0.; NCLgr= 0.;  NCLrg= 0.
 
           ENDIF
           !---------!
           !  HAIL:  !
           !---------!
-          IF (QHM(i,k)>epsQ) THEN
+          IF (QH(i,k)>epsQ) THEN
 
             !Wet growth:
              if (QHwet<(QCLch+QCLrh+QCLih+QCLsh) .and. Tc>-40.) then
-                QCLih= min(QCLih*iEih, QIM(i,k))  !change Eih to 1. in CLih
-                NCLih= min(NCLih*iEih, NYM(i,k))  !  "    "
-                QCLsh= min(QCLsh*iEsh, QNM(i,k))  !change Esh to 1. in CLsh
-                NCLsh= min(NCLsh*iEsh, NNM(i,k))  !  "    "
+                QCLih= min(QCLih*iEih, QI(i,k))  !change Eih to 1. in CLih
+                NCLih= min(NCLih*iEih, NY(i,k))  !  "    "
+                QCLsh= min(QCLsh*iEsh, QN(i,k))  !change Esh to 1. in CLsh
+                NCLsh= min(NCLsh*iEsh, NN(i,k))  !  "    "
                 tmp3 = QCLrh
                 QCLrh= QHwet-(QCLch+QCLih+QCLsh)  !actual QCLrh minus QSHhr
                 QSHhr= tmp3-QCLrh                 !QSHhr used here only
@@ -2998,7 +2779,7 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
                 NSHhr= 0.
              endif
           ELSE
-             QVDvh= 0.;   NVDvh= 0.;   NSHhr= 0.
+             NSHhr= 0.
           ENDIF
 
        ENDIF  ! ( if Tc<0C Block )
@@ -3165,115 +2946,100 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
                         +QCLih +QCLsh +QFZrh +QCLrh +QCNgh +Dgrh*(QCLrg+QCLgr)
 
        ! N-Source/Sink Terms:
-       if (dblMom_c) NC(i,k)= NC(i,k) -NCLcs -NCLcg -NCLch -NFZci
-       if (dblMom_r) NR(i,k)= NR(i,k) -NCLri -NCLrs -NCLrg -NCLrh +NMLsr +NMLgr +NMLhr   &
-                                      -NrFZrh +NMLir +NSHhr
-       if (dblMom_i) NY(i,k)= NY(i,k) +NNUvi +NVDvi +NFZci -NCLir -NCLis -NCLig -NCLih   &
-                                      -NMLir +NIMsi +NIMgi -NiCNis
-       if (dblMom_s) NN(i,k)= NN(i,k) +NsCNis -NVDvs -NCNsg -NMLsr -NCLss -NCLsr -NCLsh  &
-                                      +NCLsrs
-       if (dblMom_g) NG(i,k)= NG(i,k) +NCNsg -NCLgr -NVDvg -NMLgr +NCLirg +NCLsrg        &
-                                      +NCLgrg -NgCNgh
-       if (dblMom_h) NH(i,k)= NH(i,k) +NhFZrh +NhCNgh -NMLhr -NVDvh +NCLirh +NCLsrh       &
-                                      +NCLgrh
+       NC(i,k)= NC(i,k) -NCLcs -NCLcg -NCLch -NFZci
+       NR(i,k)= NR(i,k) -NCLri -NCLrs -NCLrg -NCLrh +NMLsr +NMLgr +NMLhr -NrFZrh +NMLir  &
+                        +NSHhr
+       NY(i,k)= NY(i,k) +NNUvi +NVDvi +NFZci -NCLir -NCLis -NCLig -NCLih -NMLir +NIMsi   &
+                        +NIMgi -NiCNis
+       NN(i,k)= NN(i,k) +NsCNis -NVDvs -NCNsg -NMLsr -NCLss -NCLsr -NCLsh +NCLsrs
+       NG(i,k)= NG(i,k) +NCNsg -NCLgr -NVDvg -NMLgr +NCLirg +NCLsrg +NCLgrg -NgCNgh
+       NH(i,k)= NH(i,k) +NhFZrh +NhCNgh -NMLhr -NVDvh +NCLirh +NCLsrh +NCLgrh
 
        T(i,k)= T(i,k)   +LFP*(QCLri+QCLcs+QCLrs+QFZci-QMLsr+QCLcg+QCLrg-QMLir-QMLgr      &
                         -QMLhr+QCLch+QCLrh+QFZrh) +LSP*(QNUvi+QVDvi+QVDvs+QVDvg+QVDvh)
 
-     !Prevent overdepletion:
-       IF (dblMom_c) THEN
-         if(QC(i,k)epsQ .and. NC(i,k)epsQ .and. NR(i,k)epsQ .and. NY(i,k)epsQ .and. NN(i,k)epsQ .and. NG(i,k)epsQ .and. NH(i,k)epsQ .and. NH(i,k)>epsN) then
-          !Conversion to graupel of hail is small:
-            Dh= (DE(i,k)*QH(i,k)/NH(i,k)*icmh)**thrd
-            if (DhepsQ .and. NH(i,k)>epsN) then
+          !transfer small hail to graupel:
+            Dh = Dm_x(DE(i,k),QH(i,k),1./NH(i,k),icmh,thrd)
+            if (Dh < Dh_min) then
+               QG(i,k) = QG(i,k) + QH(i,k)
+               NG(i,k) = NG(i,k) + NH(i,k)
+               QH(i,k) = 0.
+               NH(i,k) = 0.
             endif
          endif
-       ELSE
-         if (QH(i,k)epsQ .and. NRM(i,k)>epsN)
-        else
-           rainPresent= (QRM(i,k)>epsQ)
-        endif
+        rainPresent= (QR_in(i,k)>epsQ .and. NR_in(i,k)>epsN)
 
-        if (.not. dblMom_c) NCM(i,k)= N_c_SM
-        if (QCM(i,k)>epsQ .and. NCM(i,k)>epsN) then
-           iLAMc = iLAMDA_x(DE(i,k),QCM(i,k),1./NCM(i,k),icexc9,thrd)
+        if (QC_in(i,k)>epsQ .and. NC_in(i,k)>epsN) then
+           iLAMc = iLAMDA_x(DE(i,k),QC_in(i,k),1./NC_in(i,k),icexc9,thrd)
            iLAMc3= iLAMc*iLAMc*iLAMc
            iLAMc6= iLAMc3*iLAMc3
            Dc    = iLAMc*(GC2*iGC1)**thrd
            SIGc  = iLAMc*( GC3*iGC1- (GC2*iGC1)*(GC2*iGC1) )**sixth
-           L     = 0.027*DE(i,k)*QCM(i,k)*(6.25e18*SIGc*SIGc*SIGc*Dc-0.4)
-           if (SIGc>SIGcTHRS) TAU= 3.7/(DE(i,k)*(QCM(i,k))*(0.5e6*SIGc-7.5))
+           L     = 0.027*DE(i,k)*QC_in(i,k)*(6.25e18*SIGc*SIGc*SIGc*Dc-0.4)
+           if (SIGc>SIGcTHRS) TAU= 3.7/(DE(i,k)*(QC_in(i,k))*(0.5e6*SIGc-7.5))
         endif
 
         if (rainPresent) then
-           if (dblMom_r) then
-              Dr = Dm_x(DE(i,k),QRM(i,k),1./NRM(i,k),icmr,thrd)
-             !Drop-size limiter [prevents initially large drops from melted hail]
-              if (Dr>3.e-3) then
-                 tmp1    = (Dr-3.e-3);  tmp2= (Dr/DrMAX); tmp3= tmp2*tmp2*tmp2
-                 NRM(i,k)= NRM(i,k)*max((1.+2.e4*tmp1*tmp1),tmp3)
-                 tmp1    = DE(i,k)*QRM(i,k)*icmr
-                 Dr      = (tmp1/NRM(i,k))**thrd
-              endif
-           else
-              NRM(i,k)= GR50*sqrt(sqrt(GR31*iGR34*DE(i,k)*QRM(i,k)*icmr))
-              Dr = Dm_x(DE(i,k),QRM(i,k),1./NRM(i,k),icmr,thrd)
+           Dr = Dm_x(DE(i,k),QR_in(i,k),1./NR_in(i,k),icmr,thrd)
+          !Drop-size limiter [prevents initially large drops from melted hail]
+            if (Dr>3.e-3) then
+              tmp1    = (Dr-3.e-3);  tmp2= (Dr/DrMAX); tmp3= tmp2*tmp2*tmp2
+              NR_in(i,k)= NR_in(i,k)*max((1.+2.e4*tmp1*tmp1),tmp3)
+              tmp1    = DE(i,k)*QR_in(i,k)*icmr
+              Dr      = (tmp1/NR_in(i,k))**thrd
            endif
-           iLAMr = iLAMDA_x(DE(i,k),QRM(i,k),1./NRM(i,k),icexr9,thrd)
+           iLAMr = iLAMDA_x(DE(i,k),QR(i,k),1./NR(i,k),icexr9,thrd)
            iLAMr3= iLAMr*iLAMr*iLAMr
            iLAMr6= iLAMr3*iLAMr3
         endif
 
         !  Autoconversion:
-        if (QCM(i,k)>epsQ .and. SIGc>SIGcTHRS .and. autoconv_ON) then
-           RCAUTR= min( max(L/TAU,0.), QCM(i,k)*idt )
+        if (QC_in(i,k)>epsQ .and. SIGc>SIGcTHRS .and. autoconv_ON) then
+           RCAUTR= min( max(L/TAU,0.), QC(i,k)*idt )
            DrINIT= max(83.e-6, 12.6e-4/(0.5e6*SIGc-3.5))  !initiation regime Dr
            DrAUT = max(DrINIT, Dr)                     !init. or feeding DrAUT
            CCAUTR= RCAUTR*DE(i,k)/(cmr*DrAUT*DrAUT*DrAUT)
@@ -3359,28 +3115,27 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
            ! ---------------------------------------------------------------------------- !
 
            ! cloud self-collection: (dNc/dt_autoconversion)   {CP eqn(25)}
-           if (dblMom_c) CCSCOC= min(KK2*NCM(i,k)*NCM(i,k)*GC3*iGC1*iLAMc6, NCM(i,k)*    &
-                                 idt)  !{CP00a eqn(25)}
+           CCSCOC= min(KK2*NC_in(i,k)*NC_in(i,k)*GC3*iGC1*iLAMc6, NC_in(i,k)*idt)  !{CP00a eqn(25)}
         endif
 
         ! Accretion, rain self-collection, and collisional breakup:
-        if (((QRM(i,k))>1.2*max(L,0.)*iDE(i,k).or.Dr>max(5.e-6,DrINIT)).and.rainAccr_ON  &
+        if (((QR_in(i,k))>1.2*max(L,0.)*iDE(i,k).or.Dr>max(5.e-6,DrINIT)).and.rainAccr_ON  &
              .and. rainPresent) then
 
            !  Accretion:                                                      !{CP00a eqn(22)}
-           if (QCM(i,k)>epsQ.and.L>0.) then
+           if (QC_in(i,k)>epsQ.and.L>0.) then
               if (Dr.ge.100.e-6) then
-                 CCACCR = KK1*(NCM(i,k)*NRM(i,k))*(GC2*iGC1*iLAMc3+GR34*iGR31*iLAMr3)
-                 RCACCR = cmr*iDE(i,k)*KK1*(NCM(i,k)*NRM(i,k))*iLAMc3*(GC3*iGC1*iLAMc3+  &
+                 CCACCR = KK1*(NC_in(i,k)*NR_in(i,k))*(GC2*iGC1*iLAMc3+GR34*iGR31*iLAMr3)
+                 RCACCR = cmr*iDE(i,k)*KK1*(NC_in(i,k)*NR_in(i,k))*iLAMc3*(GC3*iGC1*iLAMc3+  &
                           GC2*iGC1*GR34*iGR31*iLAMr3)
               else
-                 CCACCR = KK2*(NCM(i,k)*NRM(i,k))*(GC3*iGC1*iLAMc6+GR37*iGR31*iLAMr6)
+                 CCACCR = KK2*(NC_in(i,k)*NR_in(i,k))*(GC3*iGC1*iLAMc6+GR37*iGR31*iLAMr6)
 
-!                  RCACCR= cmr*iDE(i,k)*KK2*(NCM(i,k)*NRM(i,k))*iLAMc3*                  &
+!                  RCACCR= cmr*iDE(i,k)*KK2*(NC(i,k)*NR(i,k))*iLAMc3*                  &
 !                          (GC4*iGR31*iLAMc6+GC2*iGC1*GR37*iGR31*iLAMr6)
 !++  The following calculation of RCACCR avoids overflow:
                  tmp1   = cmr*iDE(i,k)
-                 tmp2   = KK2*(NCM(i,k)*NRM(i,k))*iLAMc3
+                 tmp2   = KK2*(NC_in(i,k)*NR_in(i,k))*iLAMc3
                  RCACCR = tmp1 * tmp2
                  tmp1   = GC4*iGR31
                  tmp1   = (tmp1)*iLAMc6
@@ -3394,20 +3149,19 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
               RCACCR = min(RCACCR,(QC(i,k))*idt)
             endif
 
-           if (dblMom_r) then
-            !Rain self-collection:
-              tmp1= NRM(i,k)*NRM(i,k)
-              if (Dr.ge.100.e-6) then
-                 CRSCOR= KK1*tmp1*GR34*iGR31*iLAMr3                        !{CP00a eqn(24)}
-              else
-                 CRSCOR= KK2*tmp1*GR37*iGR31*iLAMr6                        !{CP00a eqn(25)}
-              endif
-            !Raindrop breakup:                                             !{CP00a eqn(26)}
-              Ec= 1.
-              if (Dr >=  600.e-6) Ec= exp(-2.5e3*(Dr-6.e-4))
-              if (Dr >= 2000.e-6) Ec= 0.
-              CRSCOR= min(Ec*CRSCOR,(0.5*NR(i,k))*idt) !0.5 prevents depletion of NR
+         !Rain self-collection:
+           tmp1= NR_in(i,k)*NR_in(i,k)
+           if (Dr.ge.100.e-6) then
+              CRSCOR= KK1*tmp1*GR34*iGR31*iLAMr3                        !{CP00a eqn(24)}
+           else
+              CRSCOR= KK2*tmp1*GR37*iGR31*iLAMr6                        !{CP00a eqn(25)}
            endif
+         !Raindrop breakup:                                             !{CP00a eqn(26)}
+           Ec= 1.
+!          if (Dr > 300.e-6) Ec = 2.-exp(2300.*(Dr-300.e-6))
+           if (iLAMr > 300.e-6) Ec = 2.-exp(2300.*(iLAMr-300.e-6))  !(assumes alpha_r=0)
+
+           CRSCOR= min(Ec*CRSCOR,(0.5*NR(i,k))*idt) !0.5 prevents depletion of NR
 
         endif  !accretion/self-collection/breakup
 
@@ -3424,152 +3178,147 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
         ! Apply tendencies:
         QC(i,k)= max(0., QC(i,k)+(-RCAUTR-RCACCR)*dt )
         QR(i,k)= max(0., QR(i,k)+( RCAUTR+RCACCR)*dt )
-        if (dblMom_c) NC(i,k)= max(0., NC(i,k)+(-CCACCR-CCSCOC)*dt )
-        if (dblMom_r) NR(i,k)= max(0., NR(i,k)+( CCAUTR-CRSCOR)*dt )
-
-        if (dblMom_r) then
-           if (QR(i,k)>epsQ .and. NR(i,k)>epsN) then
-              Dr = Dm_x(DE(i,k),QR(i,k),1./NR(i,k),icmr,thrd)
-              if (Dr>3.e-3) then
-                 tmp1= (Dr-3.e-3);   tmp2= tmp1*tmp1
-                 tmp3= (Dr/DrMAX);   tmp4= tmp3*tmp3*tmp3
-                 NR(i,k)= NR(i,k)*(max((1.+2.e4*tmp2),tmp4))
-              elseif (DrepsQ .and. NR(i,k)>epsN) then
+           Dr = Dm_x(DE(i,k),QR(i,k),1./NR(i,k),icmr,thrd)
+           if (Dr>3.e-3) then
+              tmp1= (Dr-3.e-3);   tmp2= tmp1*tmp1
+              tmp3= (Dr/DrMAX);   tmp4= tmp3*tmp3*tmp3
+              NR(i,k)= NR(i,k)*(max((1.+2.e4*tmp2),tmp4))
+           elseif (Dreps)
-        endif
-
-     ENDDO
-  ENDDO
+           endif
+        else
+           QR(i,k)= 0.;   NR(i,k)= 0.
+        endif  !(Qr,Nr>eps)
 
   ! Part 3b - Condensation/Evaporation:
 
-  DO k=1,nk
-     DO i=1,ni
-
-        DEo     = DE(i,nk)
-        gam     = sqrt(DEo*iDE(i,k))
-#if (DWORDSIZE == 8 && RWORDSIZE == 8)
-        QSS(i,k)=      FOQSA(T(i,k), PS(i)*S(i,k))   ! Re-calculates QS with new T (w.r.t. liquid)
-#elif (DWORDSIZE == 8 && RWORDSIZE == 4)
-        QSS(i,k)= sngl(FOQSA(T(i,k), PS(i)*S(i,k)))  ! Re-calculates QS with new T (w.r.t. liquid)
-#else
-     This is a temporary hack assuming double precision is 8 bytes.
-#endif
-        ssat    = Q(i,k)/QSS(i,k)-1.
-        Tc      = T(i,k)-TRPL
-        Cdiff   = max(1.62e-5, (2.2157e-5 + 0.0155e-5*Tc)) *1.e5/(S(i,k)*PS(i))
-        MUdyn   = max(1.51e-5, (1.7153e-5 + 0.0050e-5*Tc))
-        MUkin   = MUdyn*iDE(i,k)
-        iMUkin  = 1./MUkin
-        Ka      = max(2.07e-2, (2.3971e-2 + 0.0078e-2*Tc))
-        ScTHRD  = (MUkin/Cdiff)**thrd ! i.e. Sc^(1/3)
-
-        !Condensation/evaporation:
-        ! Capacity of evap/cond in one time step is determined by saturation
-        ! adjustment technique [Kong and Yau, 1997 App.A].  Equation for rain evaporation rate
-        ! comes from Cohard and Pinty, 2000a.  Explicit condensation rate is not considered
-        ! (as it is in Ziegler, 1985), but rather complete removal of supersaturation is assumed.
-
-        X= Q(i,k)-QSS(i,k)
-        if (dblMom_r) then
-           rainPresent= (QR(i,k)>epsQ .and. NR(i,k)>epsN)
+        QSW(i,k) = qsat(T(i,k),pres(i,k),0)              !Flatau formulation
+        ssat    = Q(i,k)/QSW(i,k)-1.                     !supersaturation ratio
+        X       = Q(i,k)-QSW(i,k)                        !saturation exesss (deficit)
+        !adjustment for latent heating during cond/evap
+!       X       = X/(1.+ck5*QSW(i,k)/(T(i,k)-35.86)**2)                                   !orig (KY97)
+        X       = X / ( 1.+ ((3.1484e6-2370.*T(i,k))**2 * QSW(i,k))/( (1005.*(1.+       & !morr2mom
+                        0.887*Q(i,k))) *461.5*T(i,k)**2 ) )
+        X       = max(X, -QC(i,k))                       !ensure no overdepletion of QC
+        QC(i,k) = QC(i,k) + X
+        Q(i,k)  = Q(i,k)  - X
+        T(i,k)  = T(i,k)  + LCP*X
+        if (ssat>0. .and. WZ(i,k)>0.001) then
+           ! Nucleation of cloud droplets:
+           !   note: WZ threshold of 1 mm/s is to overflow problem in NccnFNC, which
+           !         uses a polynomial approximation that is invalid for tiny WZ.
+          !NC(i,k)= max(NC(i,k),NccnFNC(WZ(i,k),T(i,k),HPS(i)*sigma(i,k),CCNtype))
+           NC(i,k) = max(NC(i,k), NccnFNC(WZ(i,k),T(i,k),pres(i,k),CCNtype))
         else
-           rainPresent= (QR(i,k)>epsQ)
+           NC(i,k) = max(0., NC(i,k) + X*NC(i,k)/max(QC(i,k),epsQ) ) !(dNc/dt)|evap
         endif
-        IF(X>0. .or. QC(i,k)>epsQ .or. rainPresent) THEN
-           tmp1 = T(i,k)-35.86
-           X    = X/(1.+ck5*QSS(i,k)/(tmp1*tmp1))
-           if (X<(-QC(i,k))) then
-              D= 0.
-              if(rainPresent) then
-                 if(QM(i,k)QREVP) then             !Note: QREVP is [(dQ/dt)*dt]
-                       DEL= -QREVP
-                    else
-                       DEL= -QR(i,k)
-                    endif
-                    D= max(X+QC(i,k), DEL)
-                 endif  !QM< QSM
-              endif   !QR0. .and. dblMom_r)                                              &
-                   NR(i,k)= max(0.,NR(i,k)+D*NR(i,k)/QR(i,k)) !(dNr/dt)|evap
-              ! The above expression of (dNr/dt)|evap is from Ferrier, 1994.
-              ! In CP2000a, Nr is not affected by evap. (except if Qr goes to zero).
-              QC(i,k)= 0.;   NC(i,k)= 0.
-              T(i,k) = T(i,k) + LCP*X
-              Q(i,k) = Q(i,k) - X
-
-           else  ![if(X >= -QC)]
-
-              ! Nucleation of cloud droplets:
-              if (ssat>0. .and. WZ(i,k)>0. .and. dblMom_c)                                &
-                   NC(i,k)= max(NC(i,k),NccnFNC(WZ(i,k),TM(i,k),HPS(i)*S(i,k),CCNtype))
-
-              ! All supersaturation is removed (condensed onto cloud field).
-              T(i,k)  = T(i,k)  + LCP*X
-              Q(i,k)  = Q(i,k)  - X
-              QC(i,k) = QC(i,k) + X
-              if (dblMom_c) then
-                  if (X<0.) then
-                     if (QC(i,k)>0.) then
-                        NC(i,k)= max(0., NC(i,k) + X*NC(i,k)/QC(i,k) ) !(dNc/dt)|evap
-                     else
-                        NC(i,k)= 0.
-                     endif
-                  endif
-                  if (QC(i,k)>0..and.NC(i,k)==0.) NC(i,k)= 1.e7 !prevents non-zero_Q & zero_N
-              endif
+        !ensure consistency for cloud:
+        if (QC(i,k)>epsQ .and. NC(i,k)epsQ) then
+
+           ssat     = Q(i,k)/QSW(i,k)-1.
+           Tc      = T(i,k)-TRPL
+           Cdiff   = max(1.62e-5, (2.2157e-5 + 0.0155e-5*Tc)) *1.e5/pres(i,k)
+          !Cdiff   = max(1.62e-5, (2.2157e-5 + 0.0155e-5*Tc)) *1.e5/pres(i,k)
+           MUdyn   = max(1.51e-5, (1.7153e-5 + 0.0050e-5*Tc))
+           Ka      = max(2.07e-2, (2.3971e-2 + 0.0078e-2*Tc))
+           MUkin   = MUdyn*iDE(i,k)
+           iMUkin  = 1./MUkin
+           ScTHRD  = (MUkin/Cdiff)**thrd
+           X       = QSW(i,k) - Q(i,k)                      !saturation exesss(deficit)
+           !adjustment for latent cooling during evaporation:
+!          X       = X/(1.+ck5*QSW(i,k)/(T(i,k)-35.86)**2)                                  !orig (KY97)
+           X       = X / ( 1.+ ((3.1484e6-2370.*T(i,k))**2 * QSW(i,k))/( (1005.*(1.+     &  !morr2mom
+                     0.887*Q(i,k))) *461.5*T(i,k)**2 ) )
+           DE(i,k)  = pres(i,k)/(RGASD*T(i,k))        !recompute air density (with updated T)
+           iDE(i,k) = 1./DE(i,k)
+           gam      = sqrt(DEo*iDE(i,k))
+           iLAMr    = iLAMDA_x(DE(i,k),QR(i,k),1./NR(i,k),icexr9,thrd)
+           LAMr     = 1./iLAMr
+          !note: The following coding of 'No_r=...' prevents overflow:
+          !No_r     = NR(i,k)*LAMr**(1.+alpha_r))*iGR31
+           No_r     = sngl(dble(NR(i,k))*dble(LAMr)**dble(1.+alpha_r))*iGR31
+          !note: There is an error in MY05a_eq(8) for VENTx (corrected in code)
+           VENTr    = Avx*GR32*iLAMr**cexr5 + Bvx*ScTHRD*sqrt(gam*afr*iMUkin)*GR17*iLAMr**cexr6
+           ABw      = CHLC**2/(Ka*RGASV*T(i,k)**2)+1./(DE(i,k)*(QSW(i,k))*Cdiff)
+           QREVP    = min( QR(i,k), -dt*(iDE(i,k)*PI2*ssat*No_r*VENTr/ABw) )
+           tmp1     = QR(i,k)   !value of QR before update, used in NR update eqn
+           T(i,k)   = T(i,k)  - LCP*QREVP
+           Q(i,k)   = Q(i,k)  + QREVP
+           QR(i,k)  = QR(i,k) - QREVP
+           NR(i,k)  = max(0., NR(i,k) - QREVP*NR(i,k)/tmp1)
+          !Protect against negative values due to overdepletion:
+           if (QR(i,k)epsQ .and. Tc<-30. .and. icephase_ON) then
+
+         !-detailed:
+!            Tc    = T(i,k) - TRPL
+!            JJ    = (10.**max(-20.,(-606.3952-52.6611*Tc-1.7439*Tc**2-0.0265*Tc**3-       &
+!                     1.536e-4*Tc**4)))
+!            tmp1  = 1.e6*(DE(i,k)*(QC(i,k)/NC(i,k))*icmr) !i.e. Dc[cm]**3
+!            FRAC  = 1.-exp(-JJ*PIov6*tmp1*dt)
+!            if (Tc>-30.) FRAC= 0.
+!            if (Tc<-50.) FRAC= 1.
+         !-simplified:
+           if (Tc<-35.) then
+              FRAC = 1.
+           else
+              FRAC = 0.
+           endif
+          !=
+           QFZci   = FRAC*QC(i,k)
+           NFZci   = FRAC*NC(i,k)
+           QC(i,k) = QC(i,k) - QFZci
+           NC(i,k) = NC(i,k) - NFZci
+           QI(i,k) = QI(i,k) + QFZci
+           NY(i,k) = NY(i,k) + NFZci
+           T(i,k)  = T(i,k)  + LFP*QFZci
+
+           if (QC(i,k)>epsQ .and. NC(i,k)epsQ .and. NY(i,k)epsQ .and. N_r>epsN) then
-            Dm_r(i,nk)= (DE(i,nk)*icmr*QR(i,nk)/N_r)**thrd
-            if (Dm_r(i,nk)>Dr_large) then  !Dr_large is rain/drizzle size threshold
+         N_r= NR(i,nk)
+         if (QR(i,kbot)>epsQ .and. N_r>epsN) then
+            Dm_r(i,kbot)= (DE(i,nk)*icmr*QR(i,kbot)/N_r)**thrd
+            if (Dm_r(i,kbot)>Dr_large) then  !Dr_large is rain/drizzle size threshold
                RT_rn2(i)= RT_rn1(i);   RT_rn1(i)= 0.
             endif
          endif
@@ -3799,15 +3507,10 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
          endif
 
       !large hail:
-         if (QH(i,nk)>epsQ) then
-            if (DblMom_h) then
-               N_h= NH(i,nk)
-            else
-               N_h= (No_h_SM*GH31)**(3./(4.+alpha_h))*(GH31*iGH34*DE(i,nk)*QH(i,nk)*     &
-                  icmh)**((1.+alpha_h)/(4.+alpha_h))   !i.e. Nh = f(No_h,Qh)
-            endif
-            Dm_h(i,nk)= Dm_x(DE(i,nk),QH(i,nk),1./N_h,icmh,thrd)
-            if (DM_h(i,nk)>Dh_large) RT_peL(i)= RT_pe2(i)
+         if (QH(i,kbot)>epsQ) then
+            N_h= NH(i,kbot)
+            Dm_h(i,kbot)= Dm_x(DE(i,kbot),QH(i,kbot),1./N_h,icmh,thrd)
+            if (DM_h(i,kbot)>Dh_large) RT_peL(i)= RT_pe2(i)
             !note: large hail (RT_peL) is a subset of the total hail (RT_pe2)
          endif
 
@@ -3816,11 +3519,6 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
  !
  !++++
 
- ELSE
-
-    massFlux3D_r= 0.
-    massFlux3D_s= 0.
-
  ENDIF  ! if (sedi_ON)
 
  where (Q<0.) Q= 0.
@@ -3854,47 +3552,17 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
      Gzg= (6.+alpha_g)*(5.+alpha_g)*(4.+alpha_g)/((3.+alpha_g)*(2.+alpha_g)*(1.+alpha_g))
      Gzh= (6.+alpha_h)*(5.+alpha_h)*(4.+alpha_h)/((3.+alpha_h)*(2.+alpha_h)*(1.+alpha_h))
 
-     do k= 1,nk
+     do k= ktop,kbot,-kdir
        do i= 1,ni
-           DE(i,k)= S(i,k)*PS(i)/(RGASD*T(i,k))
+           DE(i,k)= pres(i,k)/(RGASD*T(i,k))
            tmp9= DE(i,k)*DE(i,k)
 
-        !Compute N_x for single-moment categories:
-           if (DblMom_c) then
-              N_c= NC(i,k)
-           else
-              N_c= N_c_SM
-           endif
-           if (DblMom_r) then
-              N_r= NR(i,k)
-           else
-              N_r= (No_r_SM*GR31)**(3./(4.+alpha_r))*(GR31*iGR34*DE(i,k)*QR(i,k)*icmr)** &
-                   ((1.+alpha_r)/(4.+alpha_r))             !i.e. NR = f(No_r,QR)
-           endif
-           if (DblMom_i) then
-              N_i= NY(i,k)
-           else
-              N_i= N_Cooper(TRPL,T(i,k))
-           endif
-           if (DblMom_s) then
-              N_s= NN(i,k)
-           else
-              No_s= Nos_Thompson(TRPL,T(i,k))
-              N_s = (No_s*GS31)**(dms/(1.+dms+alpha_s))*(GS31*iGS34*DE(i,k)*QN(i,k)*     &
-                    icms)**((1.+alpha_s)/(1.+dms+alpha_s))
-           endif
-           if (DblMom_g) then
-              N_g= NG(i,k)
-           else
-              N_g= (No_g_SM*GG31)**(3./(4.+alpha_g))*(GG31*GG34*DE(i,k)*QG(i,k)*icmg)**  &
-                   ((1.+alpha_g)/(4.+alpha_g))             !i.e. NX = f(No_x,QX)
-           endif
-           if (DblMom_h) then
-              N_h= NH(i,k)
-           else
-              N_h= (No_h_SM*GH31)**(3./(4.+alpha_h))*(GH31*iGH34*DE(i,k)*QH(i,k)*icmh)** &
-                   ((1.+alpha_h)/(4.+alpha_h))             !i.e. NX = f(No_x,QX)
-           endif
+           N_c= NC(i,k)
+           N_r= NR(i,k)
+           N_i= NY(i,k)
+           N_s= NN(i,k)
+           N_g= NG(i,k)
+           N_h= NH(i,k)
 
         !Total equivalent reflectivity:     (units of [dBZ])
            tmp1= 0.;  tmp2= 0.;  tmp3= 0.;  tmp4= 0.;  tmp5= 0.
@@ -3929,144 +3597,28 @@ SUBROUTINE mp_milbrandt2mom_main(W_omega,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH
            if(QG(i,k)>epsQ.and.N_g>epsN) Dm_g(i,k)=Dm_x(DE(i,k),QG(i,k),1./N_g,icmg,thrd)
            if(QH(i,k)>epsQ.and.N_h>epsN) Dm_h(i,k)=Dm_x(DE(i,k),QH(i,k),1./N_h,icmh,thrd)
 
-         !Supercooled liquid water:
-           SLW(i,k)= 0.
-           if (T(i,k)0.005 .and. tmp2>1.) then
-              VIS1(i,k)= max(epsVIS,1000.*(1.13*(tmp1*tmp2)**(-0.51))) !based on FRAM [GM2007, eqn (4)
-             !VIS1(i,k)= max(epsVIS,min(maxVIS, (tmp1*tmp2)**(-0.65))) !based on RACE [GM2007, eqn (3)
-           else
-              VIS1(i,k)= 3.*maxVIS  !gets set to maxVIS after calc. of VIS
-           endif
-
-          !VIS2: component through rain  !based on Gultepe and Milbrandt, 2008, Table 2 eqn (1)
-           tmp1= massFlux3D_r(i,k)*idew*3.6e+6                        !rain rate [mm h-1]
-           if (tmp1>0.01) then
-              VIS2(i,k)= max(epsVIS,1000.*(-4.12*tmp1**0.176+9.01))   ![m]
-           else
-              VIS2(i,k)= 3.*maxVIS
-           endif
-
-          !VIS3: component through snow  !based on Gultepe and Milbrandt, 2008, Table 2 eqn (6)
-           tmp1= massFlux3D_s(i,k)*idew*3.6e+6                        !snow rate, liq-eq [mm h-1]
-           if (tmp1>0.01) then
-              VIS3(i,k)= max(epsVIS,1000.*(1.10*tmp1**(-0.701)))      ![m]
-           else
-              VIS3(i,k)= 3.*maxVIS
-           endif
-
-          !VIS:  visibility due to reduction from all components 1, 2, and 3
-          !      (based on sum of extinction coefficients and Koschmieders's Law)
-           VIS(i,k) = min(maxVIS, 1./(1./VIS1(i,k) + 1./VIS2(i,k) + 1./VIS3(i,k)))
-           VIS1(i,k)= min(maxVIS, VIS1(i,k))
-           VIS2(i,k)= min(maxVIS, VIS2(i,k))
-           VIS3(i,k)= min(maxVIS, VIS3(i,k))
-
         enddo  !i-loop
      enddo     !k-loop
 
-    !Diagnostic levels:
-     h_CB = noVal_h_XX   !height (AGL) of cloud base
-     h_SN = noVal_h_XX   !height (AGL) of snow level [conventional snow (not just QN>0.)]
-     h_ML1= noVal_h_XX   !height (AGL) of melting level [first 0C isotherm from ground]
-     h_ML2= noVal_h_XX   !height (AGL) of melting level [first 0C isotherm from top]
-                         ! note: h_ML2 = h_ML1 implies only 1 melting level
-     tmp1= 1./GRAV
-     do i= 1,ni
-        CB_found= .false.;   SN_found= .false.;   ML_found= .false.
-        do k= nk,2,-1
-          !cloud base:
-           if ((QC(i,k)>epsQ2.or.QI(i,k)>epsQ2) .and. .not.CB_found)  then
-              h_CB(i) = GZ(i,k)*tmp1
-              CB_found= .true.
-           endif
-          !snow level:
-           if ( ((QN(i,k)>epsQ2 .and. Dm_s(i,k)>minSnowSize)  .or.                       &
-                 (QG(i,k)>epsQ2 .and. Dm_g(i,k)>minSnowSize)) .and. .not.SN_found) then
-              h_SN(i) = GZ(i,k)*tmp1
-              SN_found= .true.
-           endif
-          !melting level: (height of lowest 0C isotherm)
-           if (T(i,k)>TRPL .and. T(i,k-1)TRPL .and. T(i,k-1) N_c =  80 cm-3 for dblMom_c = .F.
       CCNtype       = 2.  !continental   --> N_c = 200 cm-3 for dblMom_c = .F.
 
-      precipDiag_ON = .true.;     dblMom_c = .true.
-      sedi_ON       = .true.;     dblMom_r = .true.
-      warmphase_ON  = .true.;     dblMom_i = .true.
-      autoconv_ON   = .true.;     dblMom_s = .true.
-      icephase_ON   = .true.;     dblMom_g = .true.
-      snow_ON       = .true.;     dblMom_h = .true.
-      initN         = .true.
+      precipDiag_ON = .true.
+      sedi_ON       = .true.
+      warmphase_ON  = .true.
+      autoconv_ON   = .true.
+      icephase_ON   = .true.
+      snow_ON       = .true.
    !---
 
-
-      qc_max = 0.;   nc_max = 0.
-      qr_max = 0.;   nr_max = 0.
-      qi_max = 0.;   ni_max = 0.
-      qs_max = 0.;   ns_max = 0.
-      qg_max = 0.;   ng_max = 0.
-      qh_max = 0.;   nh_max = 0.
-
-      imax_qc = 0;   imax_nc = 0;   jmax_qc = 0;   jmax_nc = 0;   kmax_qc = 0;   kmax_nc = 0
-      imax_qr = 0;   imax_nr = 0;   jmax_qr = 0;   jmax_nr = 0;   kmax_qr = 0;   kmax_nr = 0
-      imax_qi = 0;   imax_ni = 0;   jmax_qi = 0;   jmax_ni = 0;   kmax_qi = 0;   kmax_ni = 0
-      imax_qs = 0;   imax_ns = 0;   jmax_qs = 0;   jmax_ns = 0;   kmax_qs = 0;   kmax_ns = 0
-      imax_qg = 0;   imax_ng = 0;   jmax_qg = 0;   jmax_ng = 0;   kmax_qg = 0;   kmax_ng = 0
-      imax_qh = 0;   imax_nh = 0;   jmax_qh = 0;   jmax_nh = 0;   kmax_qh = 0;   kmax_nh = 0
-
       RAINNCV(its:ite,jts:jte) = 0.
       SNOWNCV(its:ite,jts:jte) = 0.
       GRPLNCV(its:ite,jts:jte) = 0.
       HAILNCV(its:ite,jts:jte) = 0.
       SR(its:ite,jts:jte)      = 0.
 
-      do i = 1, 512
-         mp_debug(i:i) = char(0)
-      enddo
-
-      j_loop1:  do j = jts, jte
+      do j = jts, jte
 
-         j2d = j-jts+1  !index value for 2D arrays, to be passed to main micro scheme
+         t2d(:,:) = th(its:ite,kts:kte,j)*pii(its:ite,kts:kte,j)
+         p2d(:,:) = p(its:ite,kts:kte,j)
+         p_sfc(:) = p2d(:,k2d_max)
 
-       i_loop1:  do i = its, ite
+         do i = its, ite
+            i2d = i-its+1
+            sigma2d(i2d,:) = p2d(i2d,:)/p_sfc(i2d)
+         enddo
 
-         i2d = i-its+1  !index value for 2D arrays, to be passed to main micro scheme
+         call mp_milbrandt2mom_main(w(its:ite,kts:kte,j),t2d,qv(its:ite,kts:kte,j), &
+               qc(its:ite,kts:kte,j),qr(its:ite,kts:kte,j),qi(its:ite,kts:kte,j),   &
+               qs(its:ite,kts:kte,j),qg(its:ite,kts:kte,j),qh(its:ite,kts:kte,j),   &
+               nc(its:ite,kts:kte,j),nr(its:ite,kts:kte,j),ni(its:ite,kts:kte,j),   &
+               ns(its:ite,kts:kte,j),ng(its:ite,kts:kte,j),nh(its:ite,kts:kte,j),   &
+               p_sfc,sigma2d,rt_rn1,rt_rn2,rt_fr1,rt_fr2,rt_sn1,rt_sn2,rt_sn3,      &
+               rt_pe1,rt_pe2,rt_peL,rt_snd,dt,i2d_max,k2d_max,j,itimestep,CCNtype,  &
+               precipDiag_ON,sedi_ON,warmphase_ON,autoconv_ON,icephase_ON,snow_ON,  &
+               Dm_c,Dm_r,Dm_i,Dm_s,Dm_g,Dm_h,Zet(its:ite,kts:kte,j),ZEC,SS,nk_BOTTOM)
 
-        !Approximate geopotential:
-        ! (assumes lowest model level is at sea-level; acceptable for purposes of scheme)
-         gz2d(i2d,kts)= 0.
-         do k = kts+1, kte
-             gz2d(i2d,k)= gz2d(i2d,k-1) + dz(i,k,j)*9.81
-         enddo
+         th(its:ite,kts:kte,j) = t2d(:,:)/pii(its:ite,kts:kte,j)
 
-         k_loop1:  do k = kts, kte
-            k2d = k-kts+1  !index value for 2D arrays, to be passed to main micro scheme
-
-         !Note: The 3D number concentration variables (seen by WRF dynamics) are in units of 1/kg.
-         !      However, the 2D variables must be converted to units of 1/m3 (by multiplying by air
-         !      density) before being passed to the main subroutine mp_milbrandtsmom.  They are then
-         !      converted back after the call, upon putting them back from 2D to 3D variables.
-
-         !Convert 3D to 2D arrays (etc.):
-            t2d(i2d,k2d)  = th(i,k,j)*pii(i,k,j)
-            p2d(i2d,k2d)  = p(i,k,j)
-            dz2d(i2d,k2d) = dz(i,k,j)
-            qv2d(i2d,k2d) = qv(i,k,j)
-          !chen  rho(i2d,k2d)  = p2d(i2d,k2d)/(R_d*t2d(i2d,k2d))
-          !chen  omega2d(i2d,k2d)= -w(i,k,j)*p2d(i2d,k2d)*9.81
-            rho(i2d,k2d)  = p2d(i2d,k)/(R_d*t2d(i2d,k))
-            omega2d(i2d,k2d)= -w(i,k,j)*rho(i2d,k2d)*9.81
-            qc2d(i2d,k2d) = qc(i,k,j);   nc2d(i2d,k2d) = nc(i,k,j)
-            qi2d(i2d,k2d) = qi(i,k,j);   ni2d(i2d,k2d) = ni(i,k,j)
-            qr2d(i2d,k2d) = qr(i,k,j);   nr2d(i2d,k2d) = nr(i,k,j)
-            qs2d(i2d,k2d) = qs(i,k,j);   ns2d(i2d,k2d) = ns(i,k,j)
-            qg2d(i2d,k2d) = qg(i,k,j);   ng2d(i2d,k2d) = ng(i,k,j)
-            qh2d(i2d,k2d) = qh(i,k,j);   nh2d(i2d,k2d) = nh(i,k,j)
-            !sigma2d(i2d,k2d)= p2d(i2d,k2d)/p2d(i2d,kte-kts+1)
-
-         enddo k_loop1
-
-           K_loop9: do k= kts, kte
-            k2d = k-kts+1  !index value for 2D arrays, to be passed to main micro scheme
-            sigma2d(i2d,k2d)= p2d(i2d,k2d)/p2d(i2d,kte-kts+1)
-           enddo K_loop9
-
-       enddo i_loop1
-
-       p_src(:)= p2d(:,k2d_max)
-
-      !Flip arrays: (to conform to vertical leveling in GEM)
-        ! Note:  This step (and the flipping back) could be avoided by changing the indexing
-        !        in the sedimentation subroutine.  It is done this way to allow for directly
-        !        pasting the GEM code directly into this subdriver without having to change
-        !        the code.
-       tmp01= omega2d;  tmp02= t2d;  tmp03= qv2d;  tmp04= qc2d;  tmp05=qr2d;  tmp06=qi2d
-       tmp07= qs2d;     tmp08= qg2d; tmp09= qh2d;  tmp10= nc2d;  tmp11=nr2d;  tmp12=ni2d
-       tmp13= ns2d;     tmp14= ng2d; tmp15= nh2d;  tmp16= sigma2d; tmp17=dz2d; tmp18=gz2d
-       do k = kts-1,kte-1
-          k2d = k-kts+1
-          omega2d(:,k2d+1)= tmp01(:,k2d_max-k2d)
-          t2d(:,k2d+1)    = tmp02(:,k2d_max-k2d)
-          qv2d(:,k2d+1)   = tmp03(:,k2d_max-k2d)
-          qc2d(:,k2d+1)   = tmp04(:,k2d_max-k2d)
-          qr2d(:,k2d+1)   = tmp05(:,k2d_max-k2d)
-          qi2d(:,k2d+1)   = tmp06(:,k2d_max-k2d)
-          qs2d(:,k2d+1)   = tmp07(:,k2d_max-k2d)
-          qg2d(:,k2d+1)   = tmp08(:,k2d_max-k2d)
-          qh2d(:,k2d+1)   = tmp09(:,k2d_max-k2d)
-          nc2d(:,k2d+1)   = tmp10(:,k2d_max-k2d)
-          nr2d(:,k2d+1)   = tmp11(:,k2d_max-k2d)
-          ni2d(:,k2d+1)   = tmp12(:,k2d_max-k2d)
-          ns2d(:,k2d+1)   = tmp13(:,k2d_max-k2d)
-          ng2d(:,k2d+1)   = tmp14(:,k2d_max-k2d)
-          nh2d(:,k2d+1)   = tmp15(:,k2d_max-k2d)
-          sigma2d(:,k2d+1)= tmp16(:,k2d_max-k2d)
-          dz2d(:,k2d+1)   = tmp17(:,k2d_max-k2d)
-          gz2d(:,k2d+1)   = tmp18(:,k2d_max-k2d)
-       enddo
+         !Convert individual precipitation rates (in m/s) to WRF precipitation fields (mm/step):
+         RAINNCV(its:ite,j) = ( rt_rn1(:)+rt_rn2(:)+rt_fr1(:)+rt_fr2(:)+rt_sn1(:)+rt_sn2(:)+ &
+                                rt_sn3(:)+rt_pe1(:)+rt_pe2(:) )*ms2mmstp
+         SNOWNCV(its:ite,j) = (rt_sn1(:) + rt_sn2(:))*ms2mmstp
+         HAILNCV(its:ite,j) = (rt_pe1(:) + rt_pe2(:))*ms2mmstp
+         GRPLNCV(its:ite,j) = rt_sn3(:)*ms2mmstp
 
-      !Copy 2d arrays xx2d to xx2d_m: (to facilitate inclusion of main milbrandt2mom
-      ! subroutine which uses arrays at two different time levels, for GEM model)
-       t2d_m  = t2d;    qv2d_m = qv2d
-       qc2d_m = qc2d;   nc2d_m = nc2d
-       qr2d_m = qr2d;   nr2d_m = nr2d
-       qi2d_m = qi2d;   ni2d_m = ni2d
-       qs2d_m = qs2d;   ns2d_m = ns2d
-       qg2d_m = qg2d;   ng2d_m = ng2d
-       qh2d_m = qh2d;   nh2d_m = nh2d
-       call mp_milbrandt2mom_main(omega2d,t2d,qv2d,qc2d,qr2d,qi2d,qs2d,qg2d,qh2d,nc2d,   &
-            nr2d,ni2d,ns2d,ng2d,nh2d,p_src,t2d_m,qv2d_m,qc2d_m,qr2d_m,qi2d_m,qs2d_m,     &
-            qg2d_m,qh2d_m,nc2d_m,nr2d_m,ni2d_m,ns2d_m,ng2d_m,nh2d_m,p_src,sigma2d,       &
-            rt_rn1,rt_rn2,rt_fr1,rt_fr2,rt_sn1,rt_sn2,rt_sn3,rt_pe1,rt_pe2,rt_peL,rt_snd,&
-            gz2d,T_tend,Q_tend,QCtend,QRtend,QItend,QStend,QGtend,QHtend,NCtend,NRtend,  &
-            NItend,NStend,NGtend,NHtend,dt,i2d_max,1,k2d_max,j,itimestep,CCNtype,precipDiag_ON,&
-            sedi_ON,warmphase_ON,autoconv_ON,icephase_ON,snow_ON,initN,dblMom_c,dblMom_r,&
-            dblMom_i,dblMom_s,dblMom_g,dblMom_h,Dm_c,Dm_r,Dm_i,Dm_s,Dm_g,Dm_h,Zet2d,ZEC, &
-            SLW,VIS,VIS1,VIS2,VIS3,h_CB,h_ML1,h_ML2,h_SN,SS01,SS02,SS03,SS04,SS05,SS06,  &
-            SS07,SS08,SS09,SS10,SS11,SS12,SS13,SS14,SS15,SS16,SS17,SS18,SS19,SS20)
-
-      !Add tendencies:
-       t2d(:,:) = t2d(:,:)  + T_tend(:,:)*dt
-       qv2d(:,:)= qv2d(:,:) + Q_tend(:,:)*dt
-       qc2d(:,:)= qc2d(:,:) + QCtend(:,:)*dt;  nc2d(:,:)= nc2d(:,:) + NCtend(:,:)*dt
-       qr2d(:,:)= qr2d(:,:) + QRtend(:,:)*dt;  nr2d(:,:)= nr2d(:,:) + NRtend(:,:)*dt
-       qi2d(:,:)= qi2d(:,:) + QItend(:,:)*dt;  ni2d(:,:)= ni2d(:,:) + NItend(:,:)*dt
-       qs2d(:,:)= qs2d(:,:) + QStend(:,:)*dt;  ns2d(:,:)= ns2d(:,:) + NStend(:,:)*dt
-       qg2d(:,:)= qg2d(:,:) + QGtend(:,:)*dt;  ng2d(:,:)= ng2d(:,:) + NGtend(:,:)*dt
-       qh2d(:,:)= qh2d(:,:) + QHtend(:,:)*dt;  nh2d(:,:)= nh2d(:,:) + NHtend(:,:)*dt
-
-
-      !Flip arrays back : (to conform to vertical leveling in WRF)
-       tmp02= t2d;    tmp03= qv2d; tmp04= qc2d;  tmp05=qr2d;   tmp06=qi2d
-       tmp07= qs2d;   tmp08= qg2d; tmp09= qh2d;  tmp10= nc2d;  tmp11=nr2d;  tmp12=ni2d
-       tmp13= ns2d;   tmp14= ng2d; tmp15= nh2d;  tmp16= Zet2d; tmp17=ss01;  tmp18=ss02
-       do k = kts-1,kte-1
-          k2d = k-kts+1
-          t2d(:,k2d+1)    = tmp02(:,k2d_max-k2d)
-          qv2d(:,k2d+1)   = tmp03(:,k2d_max-k2d)
-          qc2d(:,k2d+1)   = tmp04(:,k2d_max-k2d)
-          qr2d(:,k2d+1)   = tmp05(:,k2d_max-k2d)
-          qi2d(:,k2d+1)   = tmp06(:,k2d_max-k2d)
-          qs2d(:,k2d+1)   = tmp07(:,k2d_max-k2d)
-          qg2d(:,k2d+1)   = tmp08(:,k2d_max-k2d)
-          qh2d(:,k2d+1)   = tmp09(:,k2d_max-k2d)
-          nc2d(:,k2d+1)   = tmp10(:,k2d_max-k2d)
-          nr2d(:,k2d+1)   = tmp11(:,k2d_max-k2d)
-          ni2d(:,k2d+1)   = tmp12(:,k2d_max-k2d)
-          ns2d(:,k2d+1)   = tmp13(:,k2d_max-k2d)
-          ng2d(:,k2d+1)   = tmp14(:,k2d_max-k2d)
-          nh2d(:,k2d+1)   = tmp15(:,k2d_max-k2d)
-          Zet2d(:,k2d+1)  = tmp16(:,k2d_max-k2d)
-       enddo
-       i_loop2:  do i = its, ite
-         i2d = i-its+1
-
-       !Convert individual precipitation rates (in m/s) to WRF precipitation fields:
-       !  note:  RAINNC is not actually "rain"; it is the total precipitation.
-       !         The liquid precipitation is the total multiplied by the liquid fraction,
-       !         --> rain = RAINNC*(1-SR)  (done elsewhere in WRF)
-
-         RAINNCV(i,j) = (rt_rn1(i2d)+rt_rn2(i2d)+rt_fr1(i2d)+rt_fr2(i2d)+rt_sn1(i2d)+         &
-                         rt_sn2(i2d)+rt_sn3(i2d)+rt_pe1(i2d)+rt_pe2(i2d))*ms2mmstp
-         SNOWNCV(i,j) = (rt_sn1(i2d) + rt_sn2(i2d))*ms2mmstp
-         HAILNCV(i,j) = (rt_pe1(i2d) + rt_pe2(i2d))*ms2mmstp
-         GRPLNCV(i,j) =              rt_sn3(i2d) *ms2mmstp
-         RAINNC(i,j)  = RAINNC(i,j) + RAINNCV(i,j)
-         SNOWNC(i,j)  = SNOWNC(i,j) + SNOWNCV(i,j)
-         HAILNC(i,j)  = HAILNC(i,j) + HAILNCV(i,j)
-         GRPLNC(i,j)  = GRPLNC(i,j) + GRPLNCV(i,j)
-         SR(i,j)      = (SNOWNCV(i,j)+HAILNCV(i,j)+GRPLNCV(i,j))/(RAINNCV(i,j)+1.e-12)
-
-         k_loop2:  do k = kts, kte
-            k2d = k-kts+1
-            if(.not.(t2d(i2d,k2d)>=173.) .or. (t2d(i2d,k2d)>1000.)) then
-               write(6,*)
-               write(6,*) '*** Stopping in mp_milbrandt2mom_driver due to unrealistic temperature ***'
-               write(6,*) ' step: ',itimestep
-               write(6,'(a5,5i5,8e15.5)') 'i,k: ',i,j,k,i2d,k2d,t2d(i2d,k2d),qv2d(i2d,k2d),qc2d(i2d,k2d),qr2d(i2d,k2d), &
-                                                     qi2d(i2d,k2d),qs2d(i2d,k2d),qg2d(i2d,k2d),qh2d(i2d,k2d)
-               write(6,*)
-               stop
-            endif
 
-          !Convert back to 3D arrays (and change units of number concentrations back to kg-1):
-            th(i,k,j) = t2d(i2d,k2d)/pii(i,k,j)
-            qv(i,k,j) = qv2d(i2d,k2d)
-         !   irho(i,k) = R_d*t2d(i2d,k2d)/p2d(i2d,k2d)
-            qc(i,k,j) = qc2d(i2d,k2d);   nc(i,k,j) = nc2d(i2d,k2d)
-            qi(i,k,j) = qi2d(i2d,k2d);   ni(i,k,j) = ni2d(i2d,k2d)
-            qr(i,k,j) = qr2d(i2d,k2d);   nr(i,k,j) = nr2d(i2d,k2d)
-            qs(i,k,j) = qs2d(i2d,k2d);   ns(i,k,j) = ns2d(i2d,k2d)
-            qg(i,k,j) = qg2d(i2d,k2d);   ng(i,k,j) = ng2d(i2d,k2d)
-            qh(i,k,j) = qh2d(i2d,k2d);   nh(i,k,j) = nh2d(i2d,k2d)
-            Zet(i,k,j)= Zet2d(i2d,k2d)
-
-         enddo k_loop2
-       enddo i_loop2
-
-      enddo j_loop1
-
-      do i = 1, 256
-         mp_debug(i:i) = char(0)
-      enddo
+      enddo !j_loop
 
       END SUBROUTINE mp_milbrandt2mom_driver
 
diff --git a/wrfv2_fire/phys/module_mp_morr_two_moment.F b/wrfv2_fire/phys/module_mp_morr_two_moment.F
index 54e7131a..147126e9 100644
--- a/wrfv2_fire/phys/module_mp_morr_two_moment.F
+++ b/wrfv2_fire/phys/module_mp_morr_two_moment.F
@@ -55,6 +55,18 @@
 !    cm-3. This was done to address the problem of excessive and persistent
 !    anvil cirrus produced by the scheme.
 
+! CHANGES FOR WRFV3.5.1
+! 1) added output for snow+cloud ice and graupel time step and accumulated
+!    surface precipitation
+! 2) bug fix to option w/o graupel/hail (IGRAUP = 1), include PRACI, PGSACW,
+!    and PGRACS as sources for snow instead of graupel/hail, bug reported by
+!    Hailong Wang (PNNL)
+! 3) very minor fix to immersion freezing rate formulation (negligible impact)
+! 4) clarifications to code comments
+! 5) minor change to shedding of rain, remove limit so that the number of 
+!    collected drops can smaller than number of shed drops
+! 6) change of specific heat of liquid water from 4218 to 4187 J/kg/K
+
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 ! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING
@@ -366,7 +378,9 @@ SUBROUTINE MORR_TWO_MOMENT_INIT
          EII = 0.1
          ECI = 0.7
 ! HM, ADD FOR V3.2
-         CPW = 4218.
+! hm, 7/23/13
+!         CPW = 4218.
+         CPW = 4187.
 
 ! SIZE DISTRIBUTION PARAMETERS
 
@@ -524,6 +538,7 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP,                       &
                 TH, QV, QC, QR, QI, QS, QG, NI, NS, NR, NG, &
                 RHO, PII, P, DT_IN, DZ, HT, W,          &
                 RAINNC, RAINNCV, SR,                    &
+		SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,    & ! hm added 7/13/13
                 refl_10cm, diagflag, do_radar_ref,      & ! GT added for reflectivity calcs
                 qrcuten, qscuten, qicuten, mu           & ! hm added
                ,F_QNDROP, qndrop                        & ! hm added, wrf-chem 
@@ -554,6 +569,10 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP,                       &
 ! ITIMESTEP - time step counter
 ! RAINNC - accumulated grid-scale precipitation (mm)
 ! RAINNCV - one time step grid scale precipitation (mm/time step)
+! SNOWNC - accumulated grid-scale snow plus cloud ice (mm)
+! SNOWNCV - one time step grid scale snow plus cloud ice (mm/time step)
+! GRAUPELNC - accumulated grid-scale graupel (mm)
+! GRAUPELNCV - one time step grid scale graupel (mm/time step)
 ! SR - one time step mass ratio of snow to total precip
 ! qrcuten, rain tendency from parameterized cumulus convection
 ! qscuten, snow tendency from parameterized cumulus convection
@@ -613,7 +632,9 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP,                       &
    INTEGER, INTENT(IN):: ITIMESTEP
 
    REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: &
-                          RAINNC, RAINNCV, SR
+                          RAINNC, RAINNCV, SR, &
+! hm added 7/13/13
+                          SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV
 
    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT)::       &  ! GT
                           refl_10cm
@@ -658,7 +679,7 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP,                       &
 ! HM add reflectivity      
    REAL, DIMENSION(kts:kte) :: dBZ
                           
-   REAL PRECPRT1D, SNOWRT1D
+   REAL PRECPRT1D, SNOWRT1D, SNOWPRT1D, GRPLPRT1D ! hm added 7/13/13
 
    INTEGER I,K,J
 
@@ -760,6 +781,7 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP,                       &
        QC1D, QI1D, QS1D, QR1D,NI1D, NS1D, NR1D,                                          &
        T_TEND1D,QV_TEND1D, T1D, QV1D, P1D, DZ1D, W1D, WVAR1D,                   &
        PRECPRT1D,SNOWRT1D,                                                               &
+       SNOWPRT1D,GRPLPRT1D,                 & ! hm added 7/13/13
        EFFC1D,EFFI1D,EFFS1D,EFFR1D,DT,                                                   &
                                             IMS,IME, JMS,JME, KMS,KME,                   &
                                             ITS,ITE, JTS,JTE, KTS,KTE,                   & ! HM ADD GRAUPEL
@@ -827,6 +849,11 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP,                       &
 ! hm modified so that m2005 precip variables correctly match wrf precip variables
       RAINNC(i,j) = RAINNC(I,J)+PRECPRT1D
       RAINNCV(i,j) = PRECPRT1D
+! hm, added 7/13/13
+      SNOWNC(i,j) = SNOWNC(I,J)+SNOWPRT1D
+      SNOWNCV(i,j) = SNOWPRT1D
+      GRAUPELNC(i,j) = GRAUPELNC(I,J)+GRPLPRT1D
+      GRAUPELNCV(i,j) = GRPLPRT1D
       SR(i,j) = SNOWRT1D/(PRECPRT1D+1.E-12)
 
 !+---+-----------------------------------------------------------------+
@@ -851,6 +878,7 @@ END SUBROUTINE MP_MORR_TWO_MOMENT
       SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
        NI3DTEN,NS3DTEN,NR3DTEN,QC3D,QI3D,QNI3D,QR3D,NI3D,NS3D,NR3D,              &
        T3DTEN,QV3DTEN,T3D,QV3D,PRES,DZQ,W3D,WVAR,PRECRT,SNOWRT,            &
+       SNOWPRT,GRPLPRT,                & ! hm added 7/13/13
        EFFC,EFFI,EFFS,EFFR,DT,                                                   &
                                             IMS,IME, JMS,JME, KMS,KME,           &
                                             ITS,ITE, JTS,JTE, KTS,KTE,           & ! ADD GRAUPEL
@@ -941,6 +969,9 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
 
         REAL PRECRT                ! TOTAL PRECIP PER TIME STEP (mm)
         REAL SNOWRT                ! SNOW PER TIME STEP (mm)
+! hm added 7/13/13
+        REAL SNOWPRT      ! TOTAL CLOUD ICE PLUS SNOW PER TIME STEP (mm)
+	REAL GRPLPRT	  ! TOTAL GRAUPEL PER TIME STEP (mm)
 
         REAL, DIMENSION(KTS:KTE) ::   EFFC            ! DROPLET EFFECTIVE RADIUS (MICRON)
         REAL, DIMENSION(KTS:KTE) ::   EFFI            ! CLOUD ICE EFFECTIVE RADIUS (MICRON)
@@ -989,7 +1020,7 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
      REAL, DIMENSION(KTS:KTE) ::  MNUCCR    ! CHANGE Q DUE TO CONTACT FREEZ RAIN
      REAL, DIMENSION(KTS:KTE) ::  NNUCCR    ! CHANGE N DUE TO CONTACT FREEZ RAIN
      REAL, DIMENSION(KTS:KTE) ::  NPRA      ! CHANGE IN N DUE TO DROPLET ACC BY RAIN
-     REAL, DIMENSION(KTS:KTE) ::  NRAGG     ! SELF-COLLECTION OF RAIN
+     REAL, DIMENSION(KTS:KTE) ::  NRAGG     ! SELF-COLLECTION/BREAKUP OF RAIN
      REAL, DIMENSION(KTS:KTE) ::  NSAGG     ! SELF-COLLECTION OF SNOW
      REAL, DIMENSION(KTS:KTE) ::  NPRC      ! CHANGE NC AUTOCONVERSION DROPLETS
      REAL, DIMENSION(KTS:KTE) ::  NPRC1      ! CHANGE NR AUTOCONVERSION DROPLETS
@@ -1678,7 +1709,10 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
                  1./(LAMR(K)**2*LAMG(K)**2)+                   &
                  1./(LAMR(K)*LAMG(K)**3))
 
-            NPRACG(K)=MAX(NPRACG(K)-DUM,0.)
+! hm 7/15/13, remove limit so that the number of collected drops can smaller than 
+! number of shed drops
+!            NPRACG(K)=MAX(NPRACG(K)-DUM,0.)
+            NPRACG(K)=NPRACG(K)-DUM
 
 	    END IF
 
@@ -2247,13 +2281,22 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
 
 ! IMMERSION FREEZING (BIGG 1953)
 
+!           MNUCCC(K) = MNUCCC(K)+CONS39*                   &
+!                  EXP(LOG(CDIST1(K))+LOG(GAMMA(7.+PGAM(K)))-6.*LOG(LAMC(K)))*             &
+!                   EXP(AIMM*(273.15-T3D(K)))
+
+!           NNUCCC(K) = NNUCCC(K)+                                  &
+!            CONS40*EXP(LOG(CDIST1(K))+LOG(GAMMA(PGAM(K)+4.))-3.*LOG(LAMC(K)))              &
+!                *EXP(AIMM*(273.15-T3D(K)))
+
+! hm 7/15/13 fix for consistency w/ original formula
            MNUCCC(K) = MNUCCC(K)+CONS39*                   &
                   EXP(LOG(CDIST1(K))+LOG(GAMMA(7.+PGAM(K)))-6.*LOG(LAMC(K)))*             &
-                   EXP(AIMM*(273.15-T3D(K)))
+                   (EXP(AIMM*(273.15-T3D(K)))-1.)
 
            NNUCCC(K) = NNUCCC(K)+                                  &
             CONS40*EXP(LOG(CDIST1(K))+LOG(GAMMA(PGAM(K)+4.))-3.*LOG(LAMC(K)))              &
-                *EXP(AIMM*(273.15-T3D(K)))
+                *(EXP(AIMM*(273.15-T3D(K)))-1.)
 
 ! PUT IN A CATCH HERE TO PREVENT DIVERGENCE BETWEEN NUMBER CONC. AND
 ! MIXING RATIO, SINCE STRICT CONSERVATION NOT CHECKED FOR NUMBER CONC
@@ -2401,8 +2444,6 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
 ! COLLECTION OF SNOW BY RAIN - NEEDED FOR GRAUPEL CONVERSION CALCULATIONS
 ! ONLY CALCULATE IF SNOW AND RAIN MIXING RATIOS EXCEED 0.1 G/KG
 
-! ASSUME COLLECTION OF SNOW BY RAIN PRODUCES GRAUPEL NOT HAIL
-
 ! HM MODIFY FOR WRFV3.1
 !            IF (IHAIL.EQ.0) THEN
             IF (QNI3D(K).GE.0.1E-3.AND.QR3D(K).GE.0.1E-3) THEN
@@ -2530,7 +2571,6 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
 ! HM ADD THRESHOLD SNOW MIXING RATIO FOR RIME-SPLINTERING
 ! TO LIMIT RIME-SPLINTERING IN STRATIFORM CLOUDS
 
-! ONLY CALCULATE FOR GRAUPEL NOT HAIL
 !         IF (IHAIL.EQ.0) THEN
 ! v1.4
          IF (QG3D(K).GE.0.1E-3) THEN
@@ -2584,10 +2624,7 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
 !         END IF
 
 !........................................................................
-! CONVERSION OF RIMED CLOUD WATER ONTO SNOW TO GRAUPEL
-! ASSUME CONVERTED SNOW FORMS GRAUPEL NOT HAIL
-! HAIL ASSUMED TO ONLY FORM BY FREEZING OF RAIN
-! OR COLLISIONS OF RAIN WITH CLOUD ICE
+! CONVERSION OF RIMED CLOUD WATER ONTO SNOW TO GRAUPEL/HAIL
 
 !           IF (IHAIL.EQ.0) THEN
 	   IF (PSACWS(K).GT.0.) THEN
@@ -2645,10 +2682,16 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
          IF (T3D(K).LT.269.15.AND.QR3D(K).GE.QSMALL) THEN
 
 ! IMMERSION FREEZING (BIGG 1953)
-            MNUCCR(K) = CONS20*NR3D(K)*EXP(AIMM*(273.15-T3D(K)))/LAMR(K)**3 &
+!            MNUCCR(K) = CONS20*NR3D(K)*EXP(AIMM*(273.15-T3D(K)))/LAMR(K)**3 &
+!                 /LAMR(K)**3
+
+!            NNUCCR(K) = PI*NR3D(K)*BIMM*EXP(AIMM*(273.15-T3D(K)))/LAMR(K)**3
+
+! hm fix 7/15/13 for consistency w/ original formula
+            MNUCCR(K) = CONS20*NR3D(K)*(EXP(AIMM*(273.15-T3D(K)))-1.)/LAMR(K)**3 &
                  /LAMR(K)**3
 
-            NNUCCR(K) = PI*NR3D(K)*BIMM*EXP(AIMM*(273.15-T3D(K)))/LAMR(K)**3
+            NNUCCR(K) = PI*NR3D(K)*BIMM*(EXP(AIMM*(273.15-T3D(K)))-1.)/LAMR(K)**3
 
 ! PREVENT DIVERGENCE BETWEEN MIXING RATIO AND NUMBER CONC
             NNUCCR(K) = MIN(NNUCCR(K),NR3D(K)/DT)
@@ -2929,8 +2972,6 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
             PRACG(K) = 0.
             PSACR(K) = 0.
 	    PSACWG(K) = 0.
-	    PGSACW(K) = 0.
-            PGRACS(K) = 0.
 	    PRDG(K) = 0.
 	    EPRDG(K) = 0.
             EVPMG(K) = 0.
@@ -2945,6 +2986,13 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
 ! fix 053011
             PIACRS(K)=PIACRS(K)+PIACR(K)
             PIACR(K) = 0.
+! fix 070713
+	    PRACIS(K)=PRACIS(K)+PRACI(K)
+	    PRACI(K) = 0.
+	    PSACWS(K)=PSACWS(K)+PGSACW(K)
+	    PGSACW(K) = 0.
+	    PRACS(K)=PRACS(K)+PGRACS(K)
+	    PGRACS(K) = 0.
        END IF
 
 ! CONSERVATION OF QC
@@ -3190,6 +3238,9 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
 ! INITIALIZE PRECIP AND SNOW RATES
       PRECRT = 0.
       SNOWRT = 0.
+! hm added 7/13/13
+      SNOWPRT = 0.
+      GRPLPRT = 0.
 
 ! IF THERE ARE NO HYDROMETEORS, THEN SKIP TO END OF SUBROUTINE
 
@@ -3511,6 +3562,9 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
         PRECRT = PRECRT+(FALOUTR(KTS)+FALOUTC(KTS)+FALOUTS(KTS)+FALOUTI(KTS)+FALOUTG(KTS))  &
                      *DT/NSTEP
         SNOWRT = SNOWRT+(FALOUTS(KTS)+FALOUTI(KTS)+FALOUTG(KTS))*DT/NSTEP
+! hm added 7/13/13
+        SNOWPRT = SNOWPRT+(FALOUTI(KTS)+FALOUTS(KTS))*DT/NSTEP
+        GRPLPRT = GRPLPRT+(FALOUTG(KTS))*DT/NSTEP
 
       END DO
 
diff --git a/wrfv2_fire/phys/module_mp_nssl_2mom.F b/wrfv2_fire/phys/module_mp_nssl_2mom.F
index 97117c9c..804ac45f 100644
--- a/wrfv2_fire/phys/module_mp_nssl_2mom.F
+++ b/wrfv2_fire/phys/module_mp_nssl_2mom.F
@@ -1,6 +1,9 @@
 
 
 !WRF:MODEL_LAYER:PHYSICS
+
+
+
 !---------------------------------------------------------------------
 ! IMPORTANT: Best results are attained using the new 5th-order WENO advection option (4) for scalars:
 ! moist_adv_opt                       = 4,
@@ -10,9 +13,9 @@
 ! This module provides a 2-moment bulk microphysics scheme originally 
 ! developed by Conrad Ziegler (Zeigler, 1985, JAS) and modified/upgraded in 
 ! in Mansell, Zeigler, and Bruning (2010, JAS).  Two-moment adaptive sedimentation 
-! follows Mansell (2010, JAS), using parameter infall = 2 for Method II (new default 
-! because it is cheaper). Change to infall = 4 for slightly better size-sorting but
-! more computationally expensive.
+! follows Mansell (2010, JAS), using parameter infall = 4.
+!
+! Added info on graupel density and soaking is in Mansell and Ziegler (2013, JAS)
 !
 ! Average graupel particle density is predicted, which affects fall speed as well. 
 ! Hail density prediction is by default disabled in this version, but may be enabled
@@ -42,29 +45,35 @@
 !
 ! Note: Some parameters below apply to unreleased features.
 !
-!
-!  2/19/2013: Update to sedimentation to reduce computational expense.
-!
 !---------------------------------------------------------------------
 
 
-
-
 MODULE module_mp_nssl_2mom
 
   IMPLICIT NONE
   
   public nssl_2mom_driver
   public nssl_2mom_init
-  private gamma,GAML02, GAML02d300, GAML02d500, fqvs, fqis
+  private gamma,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis
   private delbk, delabk
   private gammadp
   
+  logical, public :: cleardiag = .false.
   PRIVATE
+  
+  integer, private :: eqtset = 1 ! Flag for use with cm1 to use alternate equation set (changes latent heating rates)
+   double precision, parameter, public :: zscale = 1.0d0 ! 1.000e-10
+   double precision, parameter, public :: zscaleinv = 1.0d0/zscale ! 1.000e-10
 
   
   real, parameter :: warmonly = 0.0 ! testing parameter, set to 1.0 to reduce to warm-rain physics (ice variables stay zero)
   
+  logical, parameter :: lwsm6 = .false. ! act like wsm6 for some single moment interactions
+
+! some constants from WSM6
+  real, parameter  :: dimax = 500.e-6    ! limited maximum value for the cloud-ice diamter
+  real, parameter  :: roqimax = 2.08e22*dimax**8
+  
 ! Params for dbz:
   integer  :: iuseferrier = 1  ! =1: use dry graupel only from Ferrier 1994; = 0: Use Smith (wet graupel)
   integer  :: idbzci      = 0
@@ -85,18 +94,18 @@ MODULE module_mp_nssl_2mom
   real :: cnohlmn = 1.e-2 ! minimum intercept for 2-moment hail (alphahl < 0.5)
   
 ! Autoconversion parameters
-      
+
   real   , private :: qcmincwrn      = 2.0e-3    ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5)
   real   , private :: cwdiap         = 20.0e-6   ! threshold diameter of cloud drops (Ferrier 1994 autoconversion)
   real   , private :: cwdisp         = 0.15      ! assume droplet dispersion parameter (can be 0.3 for maritime)
-  real   , private :: ccn            = 0.6e+09   ! Central plains CCN value
+  real   , private  :: ccn            = 1.5e+09   ! set in namelist!! Central plains CCN value
   real   , private :: qccn             ! ccn "mixing ratio"
   integer, private :: iauttim        = 1         ! 10-ice rain delay flag
   real   , private :: auttim         = 300.      ! 10-ice rain delay time
   real   , private :: qcwmntim       = 1.0e-5    ! 10-ice rain delay min qc for time accrual
 
 
-! sedimentation flags  
+! sedimentation flags
 ! itfall -> 0 = 1st order fallout (other options removed)
 ! iscfall, infall -> fallout options for charge and number concentration, respectively
 !                    1 = mass-weighted fall speed; 2 = number-weighted fallspeed.
@@ -109,12 +118,18 @@ MODULE module_mp_nssl_2mom
                           ! 3 -> uses number-wgt for N and Z-weighted correction for N (Method I in Mansell, 2010 JAS)
                           ! 4 -> Hybrid of 2 and 3: Uses minimum N from each method (z-wgt and m-wgt corrections) (Method I+II in Mansell, 2010 JAS)
                           ! 5 -> uses number-wgt for N and uses average of N-wgt and q-wgt instead of Max.
+  real    :: rainfallfac = 1.0 ! factor to adjust rain fall speed (single moment only)
   integer, private :: icdx = 3 ! (graupel) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
   integer, private :: icdxhl = 3 ! (hail) 0=Ferrier; 1=leave drag coef. cd fixed; 2=vary by density, 4=set by user with cdxmin,cdxmax,etc.
   real   , private :: cdhmin = 0.45, cdhmax = 0.8        ! defaults for graupel (icdx=4)
   real   , private :: cdhdnmin = 500., cdhdnmax = 800.0  ! defaults for graupel (icdx=4)
   real   , private :: cdhlmin = 0.45, cdhlmax = 0.6      ! defaults for hail (icdx=4)
   real   , private :: cdhldnmin = 500., cdhldnmax = 800.0  ! defaults for hail (icdx=4)
+  
+  integer :: rssflg = 1   ! Rain size-sorting allowed (1, default), or disallowed (0).  If 0, sets N and Z-weighted fall speeds to q-weighted value
+  integer :: sssflg = 1   ! As above but for snow
+  integer :: hssflg = 1   ! As above but for graupel
+  integer :: hlssflg = 1  ! As above but for hail
 
 ! input flags
 
@@ -122,34 +137,38 @@ MODULE module_mp_nssl_2mom
   integer, private :: ipconc = 5
   integer, private :: ichaff = 0
   integer, private :: ilimit = 0
-  
+
   real, private :: cimn = 1.0e3, cimx = 1.0e6
-  
+
 
   real   , private :: ifrzg = 1.0 ! fraction of frozen drops going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail
   integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget)
   integer, private :: irimtim = 0 ! future use
 !  integer, private :: infdo = 1   ! 1 = calculate number-weighted fall speeds
-  
+
   real   , private :: rimc1 = 300.0, rimc2 = 0.44  ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985)
   real   , private :: rimc3 = 170.0                ! minimum rime density
   real   , private :: rimtim = 120.0               ! cut-off rime time (10ICE)
   real   , private :: eqtot = 1.0e-9               ! threshold for mass budget reporting
-  
+
   integer, private :: ireadmic = 0
-  
+
   integer, private :: iccwflg = 1     ! sets max size of first droplets in parcel to 4 micron radius (in two-moment liquid)
                              ! (first nucleation is done with a KW sat. adj. step)
   integer, private :: issfilt = 0     ! flag to turn on filtering of supersaturation field
-  integer, private :: irenuc = 1      ! =1 to always allow renucleation of droplets within the cloud 
+  integer, private :: irenuc = 2      ! =1 to always allow renucleation of droplets within the cloud
+                                      ! =2 renucleation following Twomey/Cohard&Pinty
                              ! i.e., not only at cloud base
-  integer, private :: irenuc3d = 0      ! =1 to include horizontal gradient in renucleation of droplets within the cloud 
-  real   , private :: cck = 0.6       ! exponent in Twomey expression 
+  integer, private :: irenuc3d = 0      ! =1 to include horizontal gradient in renucleation of droplets within the cloud
+  real    :: renucfrac = 0.0 ! = 0 : cnuc = cwccn
+                             ! = 1 : cnuc = actual available CCN
+                             ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac
+  real   , private :: cck = 0.6       ! exponent in Twomey expression
   real   , private :: xcradmx = 40.0e-6,ciintmx = 1.0e6
-  
+
   real   , private :: cwccn ! , cwmasn,cwmasx
   real   , private :: ccwmx
-  
+
   integer, private :: idocw = 1, idorw = 1, idoci = 1, idoir = 1, idoip = 1, idosw = 1
   integer, private :: idogl = 1, idogm = 1, idogh = 1, idofw = 1, idohw = 1, idohl = 1
 !  integer, private :: ido(3:14) = / 12*1 /
@@ -157,13 +176,15 @@ MODULE module_mp_nssl_2mom
 
 ! 0,2, 5.00e-10, 1, 0, 0, 0      : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr
   integer, private :: itype1 = 0, itype2 = 2  ! controls Hallett-Mossop process
+  integer, private :: icenucopt = 2       ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott)
   integer, private :: icfn = 2                ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version
   integer, private :: ihrn = 0            ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only)
-  integer, private :: ibfc = 0            ! Flag to use Bigg freezing on droplets (recommend default of 0 = off)
-  integer, private :: iacr = 2            ! Flag for drop contact freezing with crytals 
+  integer, private :: ibfc = 1            ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on)
+  integer, private :: iacr = 2            ! Flag for drop contact freezing with crytals
                                  ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron)
-  integer, private :: ibfr = 2            ! Flag for Bigg freezing conversion of freezing drops to graupel 
+  integer, private :: ibfr = 2            ! Flag for Bigg freezing conversion of freezing drops to graupel
                                  ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation)
+  integer, private :: ibiggopt = 1        ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however)
   integer, private :: iacrsize = 1        ! assumed min size of drops freezing by capture
                                  !  1: > 500 micron diam
                                  !  2: > 300 micron
@@ -178,25 +199,25 @@ MODULE module_mp_nssl_2mom
   integer, private :: iehw = 1            ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data
   integer, private :: iehlw = 1           ! 0 -> ehlw=ehlw0; 1 -> old ehlw; 2 -> test ehlw with Mason table data
                                  ! For ehw/ehlw = 1, ehw0/ehlw0 act as maximum limit on collection efficiency (defaults are 1.0)
-  integer, private :: ierw = 1            ! for single-moment rain (LFO/Z) 
-  real   , private :: ehw0 = 1.0          ! constant or max assumed graupel-droplet collection efficiency
+  integer, private :: ierw = 1            ! for single-moment rain (LFO/Z)
+  real   , private :: ehw0 = 0.9          ! constant or max assumed graupel-droplet collection efficiency
   real   , private :: erw0 = 1.0          ! constant assumed rain-droplet collection efficiency
-  real   , private :: ehlw0 = 1.0         ! constant or max assumed hail-droplet collection efficiency
-  
+  real   , private :: ehlw0 = 0.9         ! constant or max assumed hail-droplet collection efficiency
+
   real   , private :: esilfo0 = 1.0       ! factor for LFO collection efficiency of snow for cloud ice.
   real   , private :: ehslfo0 = 1.0       ! factor for LFO collection efficiency of hail/graupel for snow.
-  
+
   integer, private :: ircnw    = 5        ! single-moment warm-rain autoconversion option.  5= Ferrier 1994.
   real   , private :: qminrncw = 2.0e-3   ! qc threshold for rain autoconversion (NA for ircnw=5)
-  
+
   integer, private :: iqcinit = 2         ! For ZVDxx schemes, flag to choose which way to initialize droplets
                                  ! 1 = Soong-Ogura adjustment
                                  ! 2 = Saturation adjustment to value of ssmxinit
                                  ! 3 = KW adjustment
-  
+
   real   , private :: ssmxinit = 0.4      ! saturation percentage to adjust down to for initial cloud
                                  ! formation (ZVDxx scheme only)
-  
+
   real   , private :: ewfac = 1.0         ! hack factor applied to graupel and hail collection eff. for droplets
   real   , private :: eii0 = 0.1 ,eii1 = 0.1  ! graupel-crystal coll. eff. parameters: eii0*exp(eii1*min(temcg(mgs),0.0))
                                      ! set eii1 = 0 to get a constant value of eii0
@@ -213,7 +234,7 @@ MODULE module_mp_nssl_2mom
   real   , private :: ehsmax = 0.5 ! Maximum collection efficiency (graupel - snow)
   integer, private :: iglcnvi = 1  ! flag for riming conversion from cloud ice to rimed ice/graupel
   integer, private :: iglcnvs = 2  ! flag for conversion from snow to rimed ice/graupel
-  
+
   real   , private :: rz          ! reflectivity conservation factor for graupel/rain
                          ! now calculated in icezvd_dr.F from alphah and rnu
                          ! currently only used for graupel melting to rain
@@ -223,9 +244,9 @@ MODULE module_mp_nssl_2mom
   real   , private :: alphahacx = 0.0 ! assumed minimum shape parameter for zhacw and zhacr
 
   real   , private :: fconv = 1.0  ! factor to boost max graupel depletion by riming conversions in 10ICE
-  
+
   real   , private :: rg0 = 400.0  ! reference graupel density for graupel fall speed
-  
+
   integer, private :: rcond = 2    ! (Z only) rcond = 2 includes rain condensation in loop with droplet condensation
                                    ! 0 = no condensation on rain; 1 = bulk condensation on rain
   integer, parameter, private :: icond = 1    ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation
@@ -233,16 +254,26 @@ MODULE module_mp_nssl_2mom
   
   real   , private :: dfrz = 0.15e-3  ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1
                             ! and for ciacrf for iacr=4
-  real   , private :: dmlt = 0.6e-3  ! nominal diameter for rain melting from graupel and hail
-  
+  real   , private :: dmlt = 3.0e-3  ! maximum diameter for rain melting from graupel and hail
+  real   , private :: dshd = 1.0e-3  ! nominal diameter for drops shed from graupel/hail
+
   integer, private :: ihmlt = 2      ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail
+  integer, private :: imltshddmr = 0 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail
+                            ! and max mean diameter of rain)
+                            ! 1=new method where mean diameter of rain during melting is adjusted linearly downward 
+                            ! toward 3 mm for large (> sheddiam) graupel and hail, to take into account shedding of 
+                            ! smaller drops.  sheddiam0 controls the size of graupel/hail above which the assumed 
+                            ! mean diameter of rain is set to 3 mm
+                            ! Only valid for ihmlt = 2 for ZVD(H) but also applies to ZVD(H)M
+
 
   integer, private :: nsplinter = 0  ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle
   integer, private :: isnwfrac = 0   ! 0= no snow fragmentation; 1 = turn on snow fragmentation (Schuur, 2000)
 
 !  integer, private :: denscale = 1  ! 1=scale num. conc. and charge by air density for advection, 0=turn off for comparison
-  
+
   logical, private :: mixedphase = .false.   ! .false.=off, true=on to include mixed phase graupel
+  integer, private :: imixedphase = 0
   logical, private :: qsdenmod = .false.     ! true = modify snow density by linear interpolation of snow and rain density
   logical, private :: qhdenmod = .false.     ! true = modify graupel density by linear interpolation of graupel and rain density
   logical, private :: qsvtmod = .false.      ! true = modify snow fall speed by linear interpolation of snow and rain vt
@@ -275,9 +306,12 @@ MODULE module_mp_nssl_2mom
   integer, parameter :: li = 5
   integer, parameter :: ls = 6
   integer, parameter :: lh = 7
-  integer :: lhl = 8
+  integer :: lhl = 0
 
-  integer, private :: lccn = 9 ! 0 or 9, other indices adjusted accordingly
+  integer, private  :: lccn = 9 ! 0 or 9, other indices adjusted accordingly
+  integer, private :: lccna = 0
+  integer, private :: lcina = 0
+  integer, private :: lcin = 0
   integer, private :: lnc = 9
   integer, private :: lnr = 10
   integer, private :: lni = 11
@@ -316,25 +350,47 @@ MODULE module_mp_nssl_2mom
   integer :: lzf = 0
   integer :: lzh = 0
   integer :: lzhl = 0
-  
+
+! Space charge
+
+  integer :: lscw = 0
+  integer :: lscr = 0
+  integer :: lsci = 0
+  integer :: lscs = 0
+  integer :: lsch = 0
+  integer :: lschl = 0
+  integer :: lscwi = 0
+  integer :: lscpi = 0
+  integer :: lscni = 0
+  integer :: lscpli = 0
+  integer :: lscnli = 0
+  integer :: lschab = 0
+
+  integer :: lscb = 0
+  integer :: lsce = 0
+  integer :: lsceq = 0
+
+!  integer, parameter :: lscmx = 100
+
   integer :: lne = 0 ! last varible for transforming
-  
-  real :: cnoh0 = 4.0e+5 
+
+  real :: cnoh0 = 4.0e+5
   real :: hwdn1 = 700.0
 
   real    :: alphai  = 0.0 ! shape parameter for ZIEG ice crystals ! not currently used
   real    :: alphas  = 0.0 ! shape parameter for ZIEG snow         ! used only for single moment
   real    :: alphar  = 0.0 ! shape parameter for rain (imurain=1 only)
-  real, public :: alphah  = 0.0 ! set in namelist!! shape parameter for ZIEG graupel
-  real    :: alphahl = 1.0 ! set in namelist!! shape parameter for ZIEG hail
+  real, private    :: alphah  = 0.0 ! set in namelist!! shape parameter for ZIEG graupel
+  real, private    :: alphahl = 1.0 ! set in namelist!! shape parameter for ZIEG hail
 
   real    :: dmuh    = 1.0  ! power in exponential part (graupel)
   real    :: dmuhl   = 1.0  ! power in exponential part (hail)
 
-  real :: alphamax = 15.
-  real :: alphamin = 0.
-  real :: rnumin = -0.8
-  real :: rnumax = 15.0
+  real, parameter :: alpharmax = 8. ! limited for rwvent calculation
+  real, parameter :: alphamax = 15.
+  real, parameter :: alphamin = 0.
+  real, parameter :: rnumin = -0.8
+  real, parameter :: rnumax = 15.0
 
   
   real            :: cnu = 0.0
@@ -348,6 +404,7 @@ MODULE module_mp_nssl_2mom
   
   real ax(lc:lqmx)
   real bx(lc:lqmx)
+  real fx(lc:lqmx)
 
       real da0 (lc:lqmx)          ! collection coefficients from Seifert 2005
       real dab0(lc:lqmx,lc:lqmx)  ! collection coefficients from Seifert 2005
@@ -363,9 +420,12 @@ MODULE module_mp_nssl_2mom
       real xvsmn, xvsmx  ! min, max snow volumes
       real xvfmn, xvfmx  ! min, max frozen drop volumes
       real xvgmn, xvgmx  ! min, max graupel volumes
-      real xvhmn, xvhmx  ! min, max hail volumes
+      real xvhmn, xvhmn0, xvhmx, xvhmx0  ! min, max hail volumes
       real xvhlmn, xvhlmx  ! min, max lg hail volumes
 
+      real, private :: dhmn = -1., dhmx = -1.
+      real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3
+
       parameter( xvcmn=4.188e-18 )   ! mks  min volume = 1 micron radius
       parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 )  ! mks
       real     :: xvdmx = -1.0 ! 3.0e-3
@@ -373,11 +433,12 @@ MODULE module_mp_nssl_2mom
       parameter( xvsmn=0.523599*(0.1e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 )  ! mks
       parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 )  ! mks xvfmx = (pi/6)*(10mm)**3
       parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 )  ! mks xvfmx = (pi/6)*(10mm)**3
-      parameter( xvhmn=0.523599*(0.3e-3)**3, xvhmx=0.523599*(10.e-3)**3 )  ! mks xvfmx = (pi/6)*(10mm)**3
+      parameter( xvhmn0=0.523599*(0.15e-3)**3, xvhmx0=0.523599*(10.e-3)**3 )  ! mks xvfmx = (pi/6)*(10mm)**3
       parameter( xvhlmn=0.523599*(0.3e-3)**3, xvhlmx=0.523599*(25.e-3)**3 )  ! mks xvfmx = (pi/6)*(10mm)**3
-
 ! put ipelec here for now....
   integer :: ipelec = 0
+  integer :: isaund = 0
+  logical :: idonic = .false.
 !
 !  gamma function lookup table
 !
@@ -386,6 +447,18 @@ MODULE module_mp_nssl_2mom
       real, parameter :: dgam = 0.01, dgami = 100.
       real gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2)
 
+      integer, parameter :: nqiacralpha = 15, nqiacrratio = 25
+      real,    parameter :: dqiacralpha = 1., dqiacrratio = 1.
+      real :: ciacrratio(0:nqiacrratio,0:nqiacralpha)
+      real :: qiacrratio(0:nqiacrratio,0:nqiacralpha)
+
+    integer, parameter :: ngdnmm = 9
+    real :: mmgraupvt(ngdnmm,3)  ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail
+
+    DATA mmgraupvt(:,1) / 50., 150., 250., 350., 450., 550., 650., 750., 850./
+    DATA mmgraupvt(:,2) / 62.923, 94.122, 114.74, 131.21, 145.26, 157.71, 168.98, 179.36, 189.02 /
+    DATA mmgraupvt(:,3) / 0.67819, 0.63789, 0.62197, 0.61240, 0.60572, 0.60066, 0.59663, 0.59330, 0.59048 /
+
       integer lsc(lc:lqmx)
       integer ln(lc:lqmx)
       integer ipc(lc:lqmx)
@@ -414,7 +487,6 @@ MODULE module_mp_nssl_2mom
 !  constants
 !
       real, parameter :: cp608 = 0.608          ! constant used in conversion of T to Tv
-      real, parameter :: cv = 717.0             ! specific heat at constant volume - air
       real, parameter :: ar = 841.99666         ! rain terminal velocity power law coefficient (LFO)
       real, parameter :: br = 0.8               ! rain terminal velocity power law coefficient (LFO)
       real, parameter :: aradcw = -0.27544      !
@@ -437,6 +509,16 @@ MODULE module_mp_nssl_2mom
 
       real, parameter :: gr = 9.8
 
+!
+!  electrical permitivity of air C / (N m**2) -  check the units
+!
+      real eperao
+      parameter (eperao  = 8.8592e-12 )
+
+      real ec,eci  ! fundamental unit of charge
+      parameter (ec = 1.602e-19)
+      parameter (eci = 1.0/ec)
+
 !
 !  constants
 !
@@ -448,7 +530,7 @@ MODULE module_mp_nssl_2mom
       real, parameter :: cbw = 35.86
 
       real, parameter :: tfr = 273.15, tfrh = 233.15
-      
+
       real, parameter :: cp = 1004.0, rd = 287.04
       real, parameter :: cpi = 1./cp
       real, parameter :: cap = rd/cp, poo = 1.0e+05
@@ -460,28 +542,47 @@ MODULE module_mp_nssl_2mom
       real, parameter :: tfrcbw = tfr - cbw
       real, parameter :: tfrcbi = tfr - cbi
 
+     ! GHB: Needed for eqtset=2 in cm1
+!     REAL, PRIVATE ::      cv = cp - rd
+     real, private, parameter ::      cv = 717.0             ! specific heat at constant volume - air
+     REAL, PRIVATE, parameter ::      cvv = 1408.5
+     REAL, PRIVATE, parameter ::      cpl = 4190.0
+     REAL, PRIVATE, parameter ::      cpigb = 2106.0
+     ! GHB
+
       real, parameter ::  bfnu0 = (rnu + 2.0)/(rnu + 1.0) 
       real :: ventr, ventrn, ventc, c1sw
 
-      real, parameter :: cwmasn = 5.23e-13   ! minimum mass, defined by radius of 5.0e-6
-      real, parameter :: cwmasn5 =  5.23e-13
-      real, parameter :: cwradn = 5.0e-6     ! minimum radius
-      real, parameter :: cwmasx = 5.25e-10   ! maximum mass, defined by radius of 50.0e-6
+      real :: cwmasn = 5.23e-13   ! minimum mass, defined by radius of 5.0e-6
+      real :: cwmasn5 =  5.23e-13
+      real :: cwradn = 5.0e-6     ! minimum radius
+      real :: cwmasx = 5.25e-10   ! maximum mass, defined by radius of 50.0e-6
       real, parameter :: cwc1 = 6.0/(pi*1000.)
 
       real :: cckm,ccne,ccnefac,cnexp
-      
+
       integer :: na = 9
 
       real gf4p5, gf4ds, gf4br
       real gfcinu1, gfcinu1p47, gfcinu2p47
-      
+
       real :: cwchtmp0 = 1.0
       real :: cwchltmp0 = 1.0
 
-      integer :: imurain      = 3 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain.
-      integer :: izwisventr   = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3)
+      integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain.
+      integer :: iturbenhance = 0 ! enhancement of rain self-collection by turbulence
+      integer, private :: isedonly = 0 ! 1= only do sedimentation and skip other microphysics
+      integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1)
+      integer, private :: izwisventr   = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3)
       integer :: iresetmoments = 1 ! if >0, then set all moments to zero when one of them is zero (3-moment only)
+      integer, private :: imaxdiaopt    = 3 ! = 1 use mean diameter for breakup
+                                   ! = 2 use maximum mass diameter for breakup
+                                   ! = 3 use mass-weighted diameter for breakup
+      integer, private :: dmrauto       = 0 ! = -1 no limiter on crcnw
+                                  ! =  0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002)
+                                  ! =  1 DTD version based on MY code
+                                  ! =  2 DTD mass-weighted version based on MY code
+                                  ! =  3 Milbrandt version (from Cohard and Pinty's code
       real    :: cxmin = 1.e-4  ! threshold cutoff for number concentration
       real    :: zxmin = 1.e-28 ! threshold cutoff for reflectivity moment
   
@@ -491,10 +592,19 @@ MODULE module_mp_nssl_2mom
 
       integer :: ivhmltsoak = 1   ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting 
                              ! when liquid fraction is not predicted
-  real    :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option.
-  real    :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1)
-  integer :: icvhl2h = 0   ! allow conversion of hail back to graupel when hail density gets close to minimum allowed
-      
+      integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories
+  
+      integer :: ibiggsnow   = 0 ! 1 = switch conversion over to snow for small frozen drops
+  
+      integer :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi)
+  
+      real    :: evapfac     = 1.0 ! Multiplier on rain evaporation rate
+  
+      real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option.
+      real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1)
+      integer :: icvhl2h = 0   ! allow conversion of hail back to graupel when hail density gets close to minimum allowed
+
+
 ! #####################################################################
 ! #####################################################################
 
@@ -503,36 +613,44 @@ MODULE module_mp_nssl_2mom
 ! #####################################################################
 ! #####################################################################
 
- REAL FUNCTION fqvs(t) 
+ REAL FUNCTION fqvs(t)
   implicit none
   real :: t
   fqvs = exp(caw*(t-273.15)/(t-cbw))
  END FUNCTION fqvs
 
- REAL FUNCTION fqis(t) 
+ REAL FUNCTION fqis(t)
   implicit none
   real :: t
   fqis = exp(cai*(t-273.15)/(t-cbi))
  END FUNCTION fqis
+
+! #####################################################################
  
-SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idonictmp)
+       SUBROUTINE nssl_2mom_init(  &
+     & ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixphase,ihvol,idonictmp)
+
   implicit none
   
    integer, intent(in) :: ims,ime, jms,jme, kms,kme
    real,    intent(in), dimension(20) :: nssl_params
    integer, intent(in) :: ipctmp,mixphase,ihvol
    logical, optional, intent(in) :: idonictmp
-  
+
      real    :: arg, temq
      integer :: igam
-     integer :: il,j,l
+     integer :: i,il,j,l
      integer :: ltmp
+     integer :: isub
+
+      real    :: alp,ratio,x,y
      
+
+
 !
 ! set some global values from namelist input
 !
       ccn = nssl_params(1)
-      cwccn = ccn
       alphah   = nssl_params(2)
       alphahl  = nssl_params(3)
       cnoh     = nssl_params(4)
@@ -543,6 +661,10 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       rho_qhl  = nssl_params(9)
       rho_qs   = nssl_params(10)
 
+      cwccn = ccn
+
+      IF ( ipelec > 0 ) idonic = .true.
+
 !
 ! Build lookup table for saturation mixing ratio (Soong and Ogura 73)
 !
@@ -550,10 +672,10 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       do l = 1,nqsat
       temq = 163.15 + (l-1)*fqsat
       tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw))
-      dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + & 
+      dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + &
      &                 caw/(temq - cbw))*tabqvs(l)
       tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi))
-      dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + & 
+      dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + &
      &                 cai/(temq - cbi))*tabqis(l)
       end do
 
@@ -564,11 +686,45 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       gmoi(igam) = gamma(arg)
      end do
 
-     
+     ! build lookup table to compute the number and mass fractions of rain drops 
+     ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr
+     ! Uses incomplete gamma functions
+      
+      DO j = 0,nqiacralpha
+      alp = float(j)
+      y = gamma(1.+alp)
+      DO i = 1,nqiacrratio
+        ratio = float(i)
+        x = gamxinf( 1.+alp, ratio )
+!        write(0,*) 'i, x/y = ',i, x/y
+        ciacrratio(i,j) = x/y
+      ENDDO
+      ENDDO
+      ciacrratio(0,:) = 1.0
+
+      DO j = 0,nqiacralpha
+      alp = float(j)
+      y = gamma(4.+alp)
+      DO i = 1,nqiacrratio
+        ratio = float(i)
+        x = gamxinf( 4.+alp, ratio )
+!        write(0,*) 'i, x/y = ',i, x/y
+        qiacrratio(i,j) = x/y
+      ENDDO
+      ENDDO
+      qiacrratio(0,:) = 1.0
+
+
       lhab = 8
-      IF ( ihvol == -1 ) lhab = 7  ! turns off hail -- option for single moment, only!!
+      lhl = 8
+      IF ( ihvol == -1 ) THEN
+        lhab = 7  ! turns off hail -- option for single moment, only!!
+        lhl = 0
+      ENDIF
+      isub = Min( 0, ihvol) ! is -1 or 0
 
       lccn = 0
+      lccna = 0
       lnc = 0
       lnr = 0
       lni = 0
@@ -583,13 +739,13 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       lsw = 0
       lhw = 0
       lhlw = 0
-      
+
       denscale(:) = 0
       
 !      lccn = 9
 
     ipconc = ipctmp
-    
+
     IF ( ipconc == 0 ) THEN
        IF ( ihvol >= 0 ) THEN
        lvh = 9
@@ -600,14 +756,16 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
        lhl = 0
        ENDIF
     ELSEIF ( ipconc == 5 ) THEN
-      lccn = 9
-      lnc = 10
-      lnr = 11
-      lni = 12
-      lns = 13
-      lnh = 14
-      lnhl = 15
-      lvh = 16
+      lccn = lhab+1 ! 9
+      lnc = lhab+2 ! 10
+      lnr = lhab+3 ! 11
+      lni = lhab+4 !12
+      lns = lhab+5 !13
+      lnh = lhab+6 !14
+      IF ( ihvol >= 0 ) THEN
+      lnhl = lhab+7 ! 15
+      ENDIF
+      lvh = lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off
       ltmp = lvh
       denscale(lccn:lvh) = 1
       IF ( ihvol == 1 ) THEN
@@ -628,10 +786,12 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       lni = 12
       lns = 13
       lnh = 14
+      IF ( ihvol >= 0 ) THEN
       lnhl = 15
+      ENDIF
       IF ( ipconc == 6 ) THEN
-      lzh = 16
-      lvh = 17
+      lzh = 16 + isub
+      lvh = 17 + isub
       ELSEIF ( ipconc == 7 ) THEN
       lzh = 16
       lzr = 17
@@ -658,9 +818,11 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
     ELSE
       CALL wrf_error_fatal( 'nssl_2mom_init: Invalid value of ipctmp' )
     ENDIF
+
+
     
       na = ltmp
-     
+      
       ln(lc) = lnc
       ln(lr) = lnr
       ln(li) = lni
@@ -686,24 +848,40 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       lne = Max(lne,lvh)
       lne = Max(lne,lvhl)
       lne = Max(lne,na)
-      
+
+      lsc(:) = 0
+      lsc(lc) = lscw
+      lsc(lr) = lscr
+      lsc(li) = lsci
+      lsc(ls) = lscs
+      lsc(lh) = lsch
+      IF ( lhl .gt. 1 ) lsc(lhl) = lschl
+
+
       DO il = lc,lhab
         ldovol = ldovol .or. ( lvol(il) .gt. 1 )
       ENDDO
-      
+
 !      write(0,*) 'nssl_2mom_init: ldovol = ',ldovol
-      
+
       lz(:) = 0
       lz(lr) = lzr
       lz(li) = lzi
       lz(ls) = lzs
       lz(lh) = lzh
       IF ( lhl .gt. 1 .and. lzhl > 1 ) lz(lhl) = lzhl
-      
+
       lliq(:) = 0
       lliq(ls) = lsw
       lliq(lh) = lhw
       IF ( lhl .gt. 1 ) lliq(lhl) = lhlw
+      IF ( mixedphase ) THEN
+!       write(0,*) 'lsw,lhw,lhlw = ',lsw,lhw,lhlw
+      ENDIF
+
+      bx(lr) = 0.85
+      ax(lr) = 1647.81
+      fx(lr) = 135.477
       
       IF ( icdx > 0 ) THEN
         bx(lh) = 0.5
@@ -713,7 +891,7 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
         ax(lh) = 19.3
       ENDIF
 !      bx(lh) = 0.6
-      
+
       IF ( lhl .gt. 1 ) THEN
         IF (icdxhl > 0 ) THEN
          bx(lhl) = 0.5
@@ -728,8 +906,13 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       xnu(lc) = 0.0
       xmu(lc) = 1.
       
-      xnu(lr) = -0.8
-      xmu(lr) = 1.
+      IF ( imurain == 3 ) THEN
+        xnu(lr) = -0.8
+        xmu(lr) = 1.
+      ELSEIF ( imurain == 1 ) THEN
+        xnu(lr) = (alphar - 2.0)/3.0
+        xmu(lr) = 1./3.
+      ENDIF
 
       xnu(li) = 0.0
       xmu(li) = 1.
@@ -739,7 +922,7 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
 
       dnu(lr) = 3.*xnu(lr) + 2. ! alphar
       dmu(lr) = 3.*xmu(lr)
-      
+
       dnu(ls) = -0.4 ! alphas
       dmu(ls) = 3.
 
@@ -751,18 +934,18 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
 
       xnu(lh) = (dnu(lh) - 2.)/3.
       xmu(lh) = dmuh/3.
-      
-      rz =  ((4 + alphah)*(5 + alphah)*(6 + alphah)*(1. + xnu(lr)))/ & 
+
+      rz =  ((4 + alphah)*(5 + alphah)*(6 + alphah)*(1. + xnu(lr)))/ &
      &  ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr)))
 
 !      IF ( ipconc .lt. 5 ) alphahl = alphah
-      
-      rzhl =  ((4 + alphahl)*(5 + alphahl)*(6 + alphahl)*(1. + xnu(lr)))/ & 
+
+      rzhl =  ((4 + alphahl)*(5 + alphahl)*(6 + alphahl)*(1. + xnu(lr)))/ &
      &  ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(2. + xnu(lr)))
 
-       
+
 !      write(0,*) 'rz,rzhl = ', rz,rzhl
-       
+
       IF ( ipconc .lt. 4 ) THEN
 
       dnu(ls) = alphas
@@ -770,10 +953,10 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
 
       xnu(ls) = (dnu(ls) - 2.)/3.
       xmu(ls) = 1./3.
-      
-      
+
+
       ENDIF
-      
+
       IF ( lhl .gt. 1 ) THEN
 
       dnu(lhl) = alphahl
@@ -783,18 +966,18 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       xmu(lhl) = dmuhl/3.
 
       ENDIF
-     
+
       cno(lc)  = 1.0e+08
       IF ( li .gt. 1 ) cno(li)  = 1.0e+08
-      cno(lr)  = cnor 
-      IF ( ls .gt. 1 ) cno(ls)  = cnos ! 8.0e+06 
+      cno(lr)  = cnor
+      IF ( ls .gt. 1 ) cno(ls)  = cnos ! 8.0e+06
       IF ( lh .gt. 1 ) cno(lh)  = cnoh ! 4.0e+05
       IF ( lhl .gt. 1 ) cno(lhl)  = cnohl ! 4.0e+05
 !
 !  density maximums and minimums
 !
       xdnmx(:) = 900.0
-      
+
       xdnmx(lr) = 1000.0
       xdnmx(lc) = 1000.0
       xdnmx(li) =  917.0
@@ -803,7 +986,7 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0
 !
       xdnmn(:) = 900.0
-      
+
       xdnmn(lr) = 1000.0
       xdnmn(lc) = 1000.0
       xdnmn(li) =  100.0
@@ -812,7 +995,7 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       IF ( lhl .gt. 1 ) xdnmn(lhl) = hldnmn
 
       xdn0(:) = 900.0
-      
+
       xdn0(lc) = 1000.0
       xdn0(li) = 900.0
       xdn0(lr) = 1000.0
@@ -828,9 +1011,9 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       cdx(lh) = 0.8 ! 1.0 ! 0.45
       cdx(ls) = 2.00
       IF ( lhl .gt. 1 ) cdx(lhl) = 0.45
-     
+
       ido(lc) = idocw
-      ido(lr) = idorw 
+      ido(lr) = idorw
       ido(li) = idoci
       ido(ls) = idosw
       ido(lh)  = idohw
@@ -849,6 +1032,20 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
         xvrmx = xvrmx0
       ENDIF
 
+         IF ( dhmn <= 0.0 ) THEN
+           xvhmn = xvhmn0
+!           xvhmn = Min(xvhmn0, 0.523599*(dfrz)**3 )
+         ELSE
+           xvhmn = 0.523599*(dhmn)**3
+!           xvhmn = 0.523599*(Min(dhmn,dfrz))**3
+         ENDIF
+
+         IF ( dhmx <= 0.0 ) THEN
+           xvhmx = xvhmx0
+         ELSE
+           xvhmx = 0.523599*(dhmx)**3
+         ENDIF
+
 ! load max/min diameters
       xvmn(lc) = xvcmn
       xvmn(lr) = xvrmn
@@ -859,30 +1056,62 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       xvmx(lr) = xvrmx
       xvmx(ls) = xvsmx
       xvmx(lh) = xvhmx
-      
+
       IF ( lhl .gt. 1 ) THEN
       xvmn(lhl) = xvhlmn
       xvmx(lhl) = xvhlmx
       ENDIF
 
+!
+!  cloud water constants in mks units
+!
+!      cwmasn = 4.25e-15  ! radius of 1.0e-6
+      cwmasn = 5.23e-13   ! minimum mass, defined by radius of 5.0e-6
+      cwmasn5 =  5.23e-13
+      cwradn = 5.0e-6     ! minimum radius
+      cwmasx = 5.25e-10   ! maximum mass, defined by radius of 50.0e-6
+!      mwfac = 6.0**(1./3.)
+      IF ( ipconc .ge. 2 ) THEN
+        cwmasn = xvmn(lc)*1000.  ! minimum mass, defined by minimum droplet volume
+        cwradn = 1.0e-6          ! minimum radius
+        cwmasx = xvmx(lc)*1000.  ! maximum mass, defined by maximum droplet volume
+        
+      ENDIF
+!        rwmasn = xvmn(lr)*1000.  ! minimum mass, defined by minimum rain volume
+!        rwmasx = xvmx(lr)*1000.  ! maximum mass, defined by maximum rain volume
+
       IF ( lhl < 1 ) ifrzg = 1
 
-      ventr   = Gamma(rnu + 4./3.)/(rnu + 1.)**(1./3.)/Gamma(rnu + 1.)
-      ventrn =  Gamma(rnu + 1.5 + br/6.)/Gamma(rnu + 1.)  ! adapted from Wisner et al. 1972; for second term in rwvent
+      ventr = 1.
+      IF ( imurain == 3 ) THEN
+!       IF ( izwisventr == 1 ) THEN
+        ventr = Gamma(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma(rnu + 1.)) ! Ziegler 1985
+!       ELSE
+        ventrn =  Gamma(rnu + 1.5 + br/6.)/(Gamma(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ! adapted from Wisner et al. 1972; for second term in rwvent
+!        ventr = Gamma(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma(rnu + 1.)) ! Ziegler 1985, still use for first term in rwvent
+!        ventr  = Gamma(rnu + 4./3.)/Gamma(rnu + 1.) 
+!       ENDIF
+      ELSE ! imurain == 1
+!       IF ( iferwisventr == 1 ) THEN
+        ventr = Gamma(2. + alphar)  ! Ferrier 1994
+!       ELSEIF ( iferwisventr == 2 ) THEN
+        ventrn =  Gamma(alphar + 2.5 + br/2.)/Gamma(alphar + 1.) ! adapted from Wisner et al. 1972
+!       ENDIF
+      ENDIF
       ventc   = Gamma(cnu + 4./3.)/(cnu + 1.)**(1./3.)/Gamma(cnu + 1.)
       c1sw = Gamma(snu + 4./3.)*(snu + 1.0)**(-1./3.)/gamma(snu + 1.0) 
 
   ! set threshold mixing ratios
-      
+
       qxmin(:) = 1.0e-12
-      
+
       qxmin(lc) = 1.e-9
       qxmin(lr) = 1.e-7
       IF ( li > 1 ) qxmin(li) = 1.e-12
       IF ( ls > 1 ) qxmin(ls) = 1.e-7
       IF ( lh > 1 ) qxmin(lh) = 1.e-7
       IF ( lhl .gt. 1 ) qxmin(lhl) = 1.e-7
-      
+
       IF ( lc .gt. 1 .and. lnc .gt. 1 ) qxmin(lc) = 1.0e-13
       IF ( lr .gt. 1 .and. lnr .gt. 1 ) qxmin(lr) = 1.0e-12
 
@@ -892,19 +1121,18 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-9
 
   ! constants for droplet nucleation
-  
+
       cckm = cck-1.
       ccnefac =  (1.63/(cck * beta(3./2., cck/2.)))**(cck/(cck + 2.0))
       cnexp   = (3./2.)*cck/(cck+2.0)
 ! ccne is all the factors with w in eq. A7 in Mansell et al. 2010 (JAS).  The constant changes
 ! if k (cck) is changed!
       ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
-  
       IF ( cwccn .lt. 0.0 ) THEN
       cwccn = Abs(cwccn)
       ccwmx = cwccn
       ELSE
-      ccwmx = cwccn*1.4
+      ccwmx = cwccn ! *1.4
       ENDIF
 
 !
@@ -916,20 +1144,20 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
       DO il = lc,lhab
         da0(il) = delbk(bb(il), xnu(il), xmu(il), 0)
         da1(il) = delbk(bb(il), xnu(il), xmu(il), 1)
-        
+
 !        write(0,*) 'il, da0, da1, xnu, xmu = ', il, da0(il), da1(il), xnu(il), xmu(il)
       ENDDO
 
       dab0(:,:) = 0.0
       dab1(:,:) = 0.0
-      
+
       DO il = lc,lhab
         DO j = lc,lhab
           IF ( il .ne. j ) THEN
-          
+
             dab0(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 0)
             dab1(il,j) = delabk(bb(il), bb(j), xnu(il), xnu(j), xmu(il), xmu(j), 1)
-          
+
 !           write(0,*) 'il, j, dab0, dab1 = ',il, j, dab0(il,j), dab1(il,j)
           ENDIF
         ENDDO
@@ -944,8 +1172,8 @@ SUBROUTINE nssl_2mom_init(ims,ime, jms,jme, kms,kme, nssl_params, ipctmp, mixpha
 
         IF ( lh  .gt. 1 ) cwchtmp0 = 6.0/pi*gamma( (xnu(lh) + 1.)/xmu(lh) )/gamma( (xnu(lh) + 2.)/xmu(lh) )
         IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma( (xnu(lhl) + 1)/xmu(lhl) )/gamma( (xnu(lhl) + 2)/xmu(lhl) )
-  
-  
+
+
   RETURN
 END SUBROUTINE nssl_2mom_init
 
@@ -954,47 +1182,71 @@ END SUBROUTINE nssl_2mom_init
 
 SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw, chl,  &
                               cn, vhw, vhl,                                             &
+                              zrw, zhw, zhl,                                            &
+                              qsw, qhw, qhlw,                                           &
                               th, pii, p, w, dn, dz, dtp, itimestep,                    &
-                              RAINNC, RAINNCV, SNOWNC, SNOWNCV, GRPLNC, GRPLNCV,        &
-                              SR,HAILNC, HAILNCV,  dbz, vzf,compdbz,                    &
+                              RAINNC,RAINNCV, SNOWNC, SNOWNCV, GRPLNC, GRPLNCV,         &
+                              SR,HAILNC, HAILNCV,                                       &
+                              dx, dy,                                                   &
+                              dbz, vzf,compdbz,                                         &
+                              rscghis_3d, rscghis_2d,                                   &
+                              scr,scw,sci,scs,sch,schl,sctot,noninduc,                  &
+                              induc,elec,scion,sciona,                                  &
+                              ipelectmp,                                                &
                               diagflag,                                                 &
                               ids,ide, jds,jde, kds,kde,                                &  ! domain dims
                               ims,ime, jms,jme, kms,kme,                                &  ! memory dims
                               its,ite, jts,jte, kts,kte)                                   ! tile dims
 
+
+
+
       implicit none
 
+      integer :: mytask = 0
+
  !Subroutine arguments:
-      integer, intent(in):: ids,ide, jds,jde, kds,kde,                                   &
+
+      integer, intent(in)::                                                             &
+                            ids,ide, jds,jde, kds,kde,                                   &
                             ims,ime, jms,jme, kms,kme,                                   &
                             its,ite, jts,jte, kts,kte
       real, dimension(ims:ime, kms:kme, jms:jme), intent(inout)::                        &
                             qv,qc,qr,qi,qs,qh,th
       real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::                        &
+                              zrw, zhw, zhl,                                            &
+                              qsw, qhw, qhlw,                                           &
                             qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl
       real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn
       real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz
+      real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d
+      real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d
+      real, dimension(ims:ime, kms:kme, jms:jme),  optional, intent(inout)::                   &
+                            scr,scw,sci,scs,sch,schl,sciona,sctot,induc,noninduc  ! space charge
+      real, dimension(ims:ime, kms:kme, jms:jme),  optional, intent(in) :: elec ! elecsave = Ez     
+      real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion  
       real, dimension(ims:ime, kms:kme, jms:jme), intent(in)::                           &
                             pii,p,w,dz,dn
       real, dimension(ims:ime, jms:jme), intent(inout)::                                 &
                             RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR        ! accumulated precip (NC) and rate (NCV)
-
       real, dimension(ims:ime, jms:jme), optional, intent(inout)::                                 &
                             HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV)
+      real, optional, intent(in) :: dx,dy
       real, intent(in)::    dtp
       integer, intent(in):: itimestep !, ccntype
       logical, optional, intent(in) :: diagflag
+      real, optional, intent(in) :: ipelectmp
 !
 ! local variables
 !
-!     integer, parameter :: na = 16
+     real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+
      real, dimension(its:ite, 1, kts:kte, na) :: an
      real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9
      real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d
      real, dimension(its:ite, 1, na) :: xfall
      integer, parameter :: nor = 0, ng = 0
      integer :: nx,ny,nz
-     integer ix,jy,kz,i,j,k,il
+     integer ix,jy,kz,i,j,k,il,n
      integer :: infdo
      real :: ssival, ssifac, t8s, t9s, qvapor
      integer :: ltemq
@@ -1004,35 +1256,45 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
      real    :: dbzmx
      integer :: vzflag0 = 0
      logical :: makediag
-     logical,save :: cleardiag = .true.
-     
       real, parameter :: cnin20 = 1.0e3
       real, parameter :: cnin10 = 5.0e1
       real, parameter :: cnin1a = 4.5
       real, parameter :: cnin2a = 12.96
       real, parameter :: cnin2b = 0.639
 
+      real :: tmp,dv
+
+      double precision :: dt1,dt2
+      double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed
+      double precision :: timevtcalc,timesetvt
+      
+
+! -------------------------------------------------------------------
+
+
+      
+!      write(0,*) 'N2M: entering routine'
+      
+      
      IF ( present( vzf ) ) vzflag0 = 1
      
-     IF ( cleardiag ) THEN
-       cleardiag = .false.
-       IF ( present( dbz ) ) THEN
-       DO jy = jts,jte
-         DO kz = kts,kte
-           DO ix = its,ite
-             dbz(ix,kz,jy) = 0.0
-           ENDDO
-         ENDDO
-       ENDDO
-       ENDIF
+     IF ( present( ipelectmp ) ) ipelec = Nint(ipelectmp)
+!       IF ( present( dbz ) ) THEN
+!       DO jy = jts,jte
+!         DO kz = kts,kte
+!           DO ix = its,ite
+!             dbz(ix,kz,jy) = 0.0
+!           ENDDO
+!         ENDDO
+!       ENDDO
+!       ENDIF
 
-     ENDIF
      
      makediag = .true.
      IF ( present( diagflag ) ) THEN
       makediag = diagflag
-      IF ( diagflag ) cleardiag = .true.
      ENDIF
+
 !     write(0,*) 'N2M: makediag = ',makediag
      
      
@@ -1051,6 +1313,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
          ENDDO
        ENDDO
        ENDIF
+
      ENDIF ! itimestep == 1
 
 ! sedimentation settings
@@ -1068,19 +1331,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
       ENDIF
      
 
-      RAINNCV(its:ite,jts:jte) = 0.
-      SNOWNCV(its:ite,jts:jte) = 0.
-      GRPLNCV(its:ite,jts:jte) = 0.
-      IF ( present( HAILNCV ) ) THEN ! for WRF 3.1 compatibility
+      IF ( present( HAILNCV ) .and. lhl < 1 ) THEN ! for WRF 3.1 compatibility
         HAILNCV(its:ite,jts:jte) = 0.
       ENDIF
-      SR(its:ite,jts:jte)      = 0.
 
      lnb = Max(lh,lhl)+1 ! lnc
 !     IF ( lccn > 1 ) lnb = lccn
 
        jye = jte
-     
+
      IF ( present( compdbz ) .and. makediag ) THEN
      DO jy = jts,jye
        DO ix = its,ite
@@ -1088,10 +1347,26 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
        ENDDO
      ENDDO
      ENDIF
-     
+
+      zmaxsed = 0.0d0
+      timevtcalc = 0.0d0
+      timesetvt = 0.0d0
+      timesed = 0.0d0
+      timesed1 = 0.0d0
+      timesed2 = 0.0d0
+      timesed3 = 0.0d0
+      timegs = 0.0d0
+      timenucond = 0.0d0
+
+
+!     write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl)
+
      DO jy = jts,jye
      
      xfall(:,:,:) = 0.0
+
+
+!     write(0,*) 'N2M: load an, jy = ',jy
      
    ! copy from 3D array to 2D slab
    
@@ -1125,6 +1400,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
           IF ( lvhl > 0 .and. present( vhl ) ) an(ix,1,kz,lvhl)  = vhl(ix,kz,jy)
 
           
+
+
           
           t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin)
           t1(ix,1,kz) = 0.0
@@ -1162,36 +1439,62 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
 
       if ( ssival .gt. 1.0 ) then
 !
+      IF ( icenucopt == 1 ) THEN
+
       if ( t0(ix,1,kz).le.268.15 ) then
-        
+
        dp1 = cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) )
        t7(ix,1,kz) = Min(dp1, 1.0d30)
       end if
-      
+
 !
 !   Default value of imeyers5 turns off nucleation by Meyer at higher temperatures
 !  This is really from Ferrier (1994), eq. 4.31 - 4.34
       IF ( imeyers5 ) THEN
       if ( t0(ix,1,kz).lt.tfr .and. t0(ix,1,kz).gt.268.15 ) then
-      qvapor = max(an(ix,1,kz,lv),0.0) 
+      qvapor = max(an(ix,1,kz,lv),0.0)
       ssifac = 0.0
       if ( (qvapor-t9s) .gt. 1.0e-5 ) then
       if ( (t8s-t9s) .gt. 1.0e-5 ) then
       ssifac = (qvapor-t9s) /(t8s-t9s)
-      ssifac = ssifac**cnin1a   
+      ssifac = ssifac**cnin1a
       end if
       end if
       t7(ix,1,kz) = cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1)
       end if
       ENDIF
-!
+
+      ELSEIF ( icenucopt == 2 ) THEN ! Thompson/Cooper; Note Thompson 2004 has constants of
+                                     ! 0.005 and 0.304 because the line function was estimated from Cooper's plot
+                                     ! Here, the fit line values from Cooper 1986 are converted. Very little difference 
+                                     ! in practice
+      
+        t7(ix,1,kz) = 0.00446684*exp(0.3108*(273.16 - Max(233.0, t0(ix,1,kz) ) ) )
+!        write(0,*) 'Cooper t7,ssival = ',ix,kz,t7(ix,1,kz),ssival
+      
+      ELSEIF ( icenucopt == 3 ) THEN ! Phillips (Meyers/DeMott)
+
+      if ( t0(ix,1,kz).le.268.15 .and.  t0(ix,1,kz) > 243.15 ) then ! Meyers with factor of Psi=0.06
+        
+       dp1 = 0.06*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) )
+       t7(ix,1,kz) = Min(dp1, 1.0d30)
+      elseif ( t0(ix,1,kz) <= 243.15 ) then ! Phillips estimate of DeMott et al (2003) data
+       dp1 = 1000.*( exp( Min( 57.0 ,cnin2a*(ssival-1.1) ) ) )**0.3
+       t7(ix,1,kz) = Min(dp1, 1.0d30)
+      
       end if
+      
+      ENDIF ! icenucopt
+
+
+!
+      end if ! ( ssival .gt. 1.0 )
 !
 
         ENDDO
        ENDDO
 
-        
+
    ! transform from number mixing ratios to number conc.
      
      DO il = lnb,na
@@ -1203,16 +1506,26 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
          ENDDO
        ENDIF
      ENDDO ! il
-
+        
 ! sedimentation
       xfall(:,:,:) = 0.0
-
        
+      IF ( .true. ) THEN
+
+
+! for real cases when hydrometeor mixing ratios have been initialized without concentrations
+       IF ( itimestep == 1 .and. ipconc > 0 ) THEN
+         call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1)
+       ENDIF
       call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, &
-     &                    t0,t7,infdo,jy,its,jts)
-   
+     &                    t0,t7,infdo,jy,its,jts &
+     &   ,timesed1,timesed2,timesed3,zmaxsed,timesetvt)
+
+
 ! copy xfall to appropriate places...
 
+!     write(0,*) 'N2M: end sediment, jy = ',jy
+
        DO ix = its,ite
          IF ( lhl > 1 ) THEN
          RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + &
@@ -1224,6 +1537,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
          SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr)
          GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr)
          RAINNC(ix,jy)  = RAINNC(ix,jy) + RAINNCV(ix,jy)
+
          SNOWNC(ix,jy)  = SNOWNC(ix,jy) + SNOWNCV(ix,jy)
          IF ( lhl > 1 ) THEN
            IF ( present( HAILNC ) ) THEN
@@ -1240,9 +1554,16 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
            SR(ix,jy)      = (SNOWNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12)
          ENDIF
        ENDDO
-        
+       
+      ENDIF ! .false.
+ 
+      IF ( isedonly /= 1 ) THEN
    ! call nssl_2mom_gs: main gather-scatter routine to calculate microphysics
 
+!     write(0,*) 'N2M: gs, jy = ',jy
+!      IF ( isedonly /= 2 ) THEN
+
+
       call nssl_2mom_gs   &
      &  (nx,ny,nz,na,jy   &
      &  ,nor,nor          &
@@ -1252,11 +1573,18 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
      &  ,pn,wn,0                   &
      &  ,t00,t77,                             &
      &   ventr,ventc,c1sw,1,ido,    &
-     &   xdnmx,xdnmn,lsc,               &
-     &   ln,ipc,lvol,lz,lliq,   &
+     &   xdnmx,xdnmn,                  &
+!     &   ln,ipc,lvol,lz,lliq,   &
      &   cdx,                              &
-     &   xdn0,dbz2d)
-   
+     &   xdn0,dbz2d,timevtcalc  &
+     & )
+
+
+
+
+
+
+   ENDIF ! isedonly /= 1
    
  ! droplet nucleation/condensation/evaporation
    CALL NUCOND    &
@@ -1266,16 +1594,18 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
      &  ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & 
      &  ,an,dn1,t77 & 
      &  ,pn,wn & 
-     &  ,ssat,t00,t77,dbz2d)
+     &  ,ssat,t00,t77,dbz2d,scion2)
+
+
 
 ! compute diagnostic S-band reflectivity if needed
      IF ( present( dbz ) .and. makediag ) THEN
    ! calc dbz
-
-! write(0,*) 'N2M: call radardd02'
-
+      
+      IF ( .true. ) THEN
       call radardd02(nx,ny,nz,nor,na,an,t0,         &
      &    dbz2d,dn1,nz,cnoh,rho_qh,ipconc, 0)
+      ENDIF ! .false.
 
      
        DO kz = kts,kte
@@ -1305,6 +1635,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
      ENDDO ! il
    
    ! copy 2D slabs back to 3D
+
    
        DO kz = kts,kte
         DO ix = its,ite
@@ -1331,6 +1662,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
 
 
 
+
          IF ( lvh > 0 )  vhw(ix,kz,jy) = an(ix,1,kz,lvh)
          IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl)
 
@@ -1340,6 +1672,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
      ENDDO ! jy
 
 
+
+
   RETURN
 END SUBROUTINE nssl_2mom_driver
 
@@ -1382,6 +1716,64 @@ REAL FUNCTION GAMMA(xx)
 
       RETURN
       END FUNCTION GAMMA
+
+! #####################################################################
+
+        real function GAMXINF(A1,X1)
+
+!       ===================================================
+!       Purpose: Compute the incomplete gamma function
+!                from x to infinity
+!       Input :  a   --- Parameter ( a ó 170 )
+!                x   --- Argument 
+!       Output:  GIM --- â(a,x) t=x,Infinity
+!       Routine called: GAMMA for computing â(x)
+!       ===================================================
+
+!        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
+        implicit none
+        real :: a1,x1
+        double precision :: xam,dlog,s,r,ga,t0,a,x
+        integer :: k
+        double precision :: gin, gim
+        
+        a = a1
+        x = x1
+        XAM=-X+A*DLOG(X)
+        IF (XAM.GT.700.0.OR.A.GT.170.0) THEN
+           WRITE(*,*)'a and/or x too large'
+           STOP
+        ENDIF
+        IF (X.EQ.0.0) THEN
+           GIN=0.0
+           GIM = GAMMA(A1)
+        ELSE IF (X.LE.1.0+A) THEN
+           S=1.0D0/A
+           R=S
+           DO 10 K=1,60
+              R=R*X/(A+K)
+              S=S+R
+              IF (DABS(R/S).LT.1.0D-15) GO TO 15
+10         CONTINUE
+15         GIN=DEXP(XAM)*S
+           ga = GAMMA(A1)
+           GIM=GA-GIN
+        ELSE IF (X.GT.1.0+A) THEN
+           T0=0.0D0
+           DO 20 K=60,1,-1
+              T0=(K-A)/(1.0D0+K/(X+T0))
+20         CONTINUE
+           GIM=DEXP(XAM)/(X+T0)
+!           GA = GAMMA(A1)
+!           GIN=GA-GIM
+        ENDIF
+        
+        gamxinf = GIM
+        return
+        END function GAMXINF
+
+! #####################################################################
+
 !**************************** GAML02 *********************** 
 !  This calculates Gamma(0.2,x)/Gamma[0.2], where is a ratio
 !   It is used for qiacr with the gamma of volume to calculate what 
@@ -1736,7 +2128,8 @@ END Function delabk
 !--------------------------------------------------------------------------
 !
       subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
-     &                    t0,t7,infdo,jslab,its,jts)
+     &                    t0,t7,infdo,jslab,its,jts,  &
+     &   timesed1,timesed2,timesed3,zmaxsed,timesetvt) ! used for timing
 !
 ! Sedimentation driver -- column by column
 !
@@ -1745,7 +2138,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
 !
 !
       implicit none
-      
+
       integer nx,ny,nz,nor,norz,ngt,jgs,na,ia
       integer id ! =1 use density, =0 no density
       integer :: its,jts ! SW point of local tile
@@ -1779,6 +2172,8 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
       
       real :: rhovtzx(nz,nx)
       
+      double precision :: timesed1,timesed2,timesed3, zmaxsed,timesetvt,dummy
+      double precision :: dt1,dt2,dt3,dt4
 
       integer,parameter :: ngs = 128 
       integer :: ngscnt,mgs,ipconc0
@@ -1842,7 +2237,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
 
       xvt(:,:,:,:) = 0.0
 
-      if ( ndebug .gt. 0 ) print*,'dbg = 3a'
+      if ( ndebug .gt. 0 ) write(0,*) 'dbg = 3a'
 
 
       DO kz = kzb,kze
@@ -1869,12 +2264,24 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
       ENDDO
       ENDIF
 
-      if (ndebug .gt. 0 ) print*,'dbg = 3a2'
+      
+      DO il = lc+1,lhab
+       DO ix = ixb,ixe
+!        hasmass(ix,il) = Any( an(ix,jy,:,il) > qxmin(il) )
+       ENDDO
+      ENDDO
+
+
+
+
+      if (ndebug .gt. 0 ) write(0,*) 'dbg = 3a2'
 
 ! loop over columns
       DO ix = ixb,ixe
       
+      dummy = 0.d0
 
+      
       call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & 
      &  xvt, rhovtzx, & 
      &  an,dn,ipconc,t0,t7,cwmasn,cwmasx, & 
@@ -1882,8 +2289,9 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
      &  qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & 
      &  ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, &
      &  rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, &
-     &  cnostmp,             &
-     &  infdo,0)
+     &  cnostmp,              &
+     &  infdo,0               &
+     & )
 
 
 ! loop over each species and do sedimentation for all moments
@@ -1903,6 +2311,15 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
       vtmax = Max(vtmax,xvt(kz,ix,2,il)*dz2dinv(kz,ix))
       vtmax = Max(vtmax,xvt(kz,ix,3,il)*dz2dinv(kz,ix))
 
+!      IF ( dtp*xvt(kz,ix,1,il)*dz2dinv(kz,ix) >= 0.7 .or. &
+!     &     dtp*xvt(kz,ix,2,il)*dz2dinv(kz,ix) >= 0.7 .or. &
+!     &     dtp*xvt(kz,ix,3,il)*dz2dinv(kz,ix) >= 0.7 ) THEN
+!          
+!          zmaxsed = Max(zmaxsed, float(kz) )
+!!          plo = Min(plo,kz)
+!!          phi = Max(phi,kz)
+!           
+!      ENDIF
       
       ENDDO
       
@@ -1913,20 +2330,24 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
       IF ( dtp*vtmax .lt. 0.7 ) THEN ! check whether multiple steps are needed.
         ndfall = 1
       ELSE
-!        ndfall = Max(2, Int(dtp*vtmax/0.7) + 1)
-        ndfall = 1+Int(dtp*vtmax + 0.301)
+       IF ( dtp > 20.0 ) THEN ! more stringent subdivision for large time steps
+         ndfall = Max(2, Int(dtp*vtmax/0.7) + 1)
+       ELSE ! more relaxed for small time steps, but might still be a problem for very thin vertical layers near the ground
+         ndfall = 1+Int(dtp*vtmax + 0.301)
+       ENDIF
       ENDIF
       
       IF ( ndfall .gt. 1 ) THEN
         dtptmp = dtp/Real(ndfall)
-!        write(0,*) 'subdivide fallout on its,jts = ',its,jts
-!        write(0,*) 'for il,jsblab,c = ',il,jslab,dtp*vtmax
+!        write(0,*) 'subdivide fallout on its,jts,ix,plo,phi = ',its,jts,ix,plo,phi
+!        write(0,*) 'for il,jsblab,c,ndfall = ',il,jslab,dtp*vtmax,ndfall
       ELSE
         dtptmp = dtp
       ENDIF
       
       dtfrac = dtptmp/dtp
 
+
       DO n = 1,ndfall
 
       IF ( n .ge. 2 ) THEN
@@ -1935,6 +2356,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
 !
       
 !      xvt(:,:,:,il) = 0.0
+      dummy = 0.d0
       call ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ix, & 
      &  xvt, rhovtzx, & 
      &  an,dn,ipconc,t0,t7,cwmasn,cwmasx, & 
@@ -1948,6 +2370,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
 
       ENDIF ! (n .ge. 2)
 
+
         IF ( il >= lr .and. ( infall .eq. 3 .or. infall .eq. 4 ) .and. ln(il) > 0 ) THEN
            IF ( (il .eq. lr .and. irfall .eq. infall .and. lzr < 1) .or. (il .ge. lh .and. lz(il) .lt. 1 ) ) THEN
             call calczgr1d(nx,ny,nz,nor,na,an,ixe,kze, & 
@@ -1955,7 +2378,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
            ENDIF
         ENDIF
 
-      if (ndebug .gt. 0 ) print*,'dbg = 1b'
+      if (ndebug .gt. 0 ) write(0,*) 'dbg = 1b'
 
 ! mixing ratio
 
@@ -1963,7 +2386,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
      &             an,db1,il,1,xfall,dtz1,ix)
 
 
-      if (ndebug .gt. 0 ) print*,'dbg = 3c'
+      if (ndebug .gt. 0 ) write(0,*) 'dbg = 3c'
 
 ! volume
 
@@ -1975,7 +2398,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
       ENDIF
 
 
-      if (ndebug .gt. 0 ) print*,'dbg = 3d'
+      if (ndebug .gt. 0 ) write(0,*) 'dbg = 3d'
 
       
       IF ( ipconc .gt. 0 ) THEN !{
@@ -2014,7 +2437,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
       ENDIF !}
 
 
-      if (ndebug .gt. 0 ) print*,'dbg = 3f'
+      if (ndebug .gt. 0 ) write(0,*) 'dbg = 3f'
 
        in = 2
        IF ( infall .eq. 1 ) in = 1
@@ -2078,12 +2501,14 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
 
       ENDIF !}
 
+
       ENDDO ! n=1,ndfall
       ENDDO ! il
       
       ENDDO ! ix
 
 
+
       
       RETURN
       END SUBROUTINE SEDIMENT1D
@@ -2110,7 +2535,7 @@ subroutine fallout1d(nx,ny,nz,nor,na,dtp,dtfrac,jgs,vt,   &
 !
 !
       implicit none
-      
+
       integer nx,ny,nz,nor,ngt,jgs,na,ia
       integer id ! =1 use density, =0 no density
       integer ng1
@@ -2215,7 +2640,7 @@ END SUBROUTINE FALLOUT1D
       subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze,              &
      &    z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qh, ixcol)
 
-      
+
       implicit none
 
       integer nx,ny,nz,nor,na,ngt,jgs
@@ -2225,7 +2650,7 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze,              &
       real z(-nor+1:nx+nor,-nor+1:nz+nor,lr:lhab)   ! reflectivity
       real db(nx,nz+1)  ! air density
 !      real gt(-nor+1:nx+nor,-nor+1:ny+nor,-nor+1:nz+nor,ngt)
-      
+
       integer ixe,kze
       real    alpha
       real    qmin
@@ -2235,8 +2660,8 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze,              &
       integer ln  ! index for N
       integer lvol ! index for volume
       real    rho_qh
-      
-      
+
+
       integer ix,jy,kz
       real vr,qr,nrx,rd,xv,g1,zx,chw,xdn
       
@@ -2257,7 +2682,7 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze,              &
                 IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN
                   xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol)
                   xdn = Min( 900., Max( 170., xdn ) )
-                ELSE 
+                ELSE
                   xdn = rho_qh
                 ENDIF
             ELSE
@@ -2280,8 +2705,8 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze,              &
              zx = g1*db(ix,kz)**2*(a(ix,jy,kz,l))*a(ix,jy,kz,l)/chw
 !             z(ix,kz,l)  = 1.e18*zx*(6./(pi*1000.))**2
              z(ix,kz,l)  = zx*(6./(pi*1000.))**2
-            
-          
+
+
 !          IF ( ny.eq.2 .and. kz .ge. 25 .and. kz .le. 29 .and. z(ix,kz,l) .gt. 0. ) THEN
 !             write(*,*) 'calczgr: z,dbz,xdn = ',ix,kz,z(ix,kz,l),10*log10(z(ix,kz,l)),xdn
 !          ENDIF
@@ -2440,8 +2865,7 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze,    &
             ENDIF
 
            ELSE ! } {
-           
-            IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN
+             IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN
               IF ( t1(ix,jy,kz) .gt. a(ix,jy,kz,ln) ) THEN
                 nmwgt = nmwgt + 1
               ELSE
@@ -2450,11 +2874,11 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze,    &
             ENDIF
             a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) )
             nrx = a(ix,jy,kz,ln)
-            
 
-           
+
+
            ENDIF ! }
-          
+
            ! }
           ELSE ! {
             IF ( t1(ix,jy,kz) .gt. 0 .and. a(ix,jy,kz,ln) .gt. 0 ) THEN
@@ -2484,36 +2908,173 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze,    &
      &          .and. t0(ix,jy,kz) .gt. z0(ix,kz,l) ) THEN
 
             vr = db(ix,kz)*a(ix,jy,kz,l)/(xdn)
-            
-            chw =  a(ix,jy,kz,ln)
+             chw =  a(ix,jy,kz,ln)
             nrx =   3.6*(rnu+2.0)*vr**2/((rnu+1.0)*t0(ix,jy,kz))
-            
-            IF ( infall .eq. 3 ) THEN
+             IF ( infall .eq. 3 ) THEN
               a(ix,jy,kz,ln) = Max( real(nrx), a(ix,jy,kz,ln) )
             ELSEIF ( infall .eq. 4 ) THEN
               a(ix,jy,kz,ln) = Max( Min( real(nrx), t1(ix,jy,kz)), a(ix,jy,kz,ln) )
             ENDIF
 
            ELSE
-           
+
             a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) )
-            
+
            ENDIF
-            
+
           ELSE
-           
+
             a(ix,jy,kz,ln) = Max(t1(ix,jy,kz), a(ix,jy,kz,ln) )
-            
+
           ENDIF
-      
-          
+
+
       ENDDO
-      
+
       ENDIF
+
+      RETURN
+
+      END subroutine calcnfromz1d
+
+
+! ##############################################################################
+! ##############################################################################
+!
+!  Subroutine to calculate number concentrations from initial state that has only mixing ratio.
+!  N will be in #/kg, NOT #/m^3, since sedimentation is done next.
+!
+
+      subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn)
+
+      
+      implicit none
+
+      integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol
+
+      real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)  ! scalars (q, N, Z)
+
+      real dn(nx,nz+1)  ! air density
+      
+      integer ixe,kze
+      real    alpha
+      real    qmin
+      real    xvmn,xvmx
+      integer ipconc
+      integer lvol ! index for volume
+      real    rho_qh
+      integer infall
+      
+      
+      integer ix,jy,kz
+      double precision vr,q,nrx,rd,g1h,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1
+      double precision :: zr, zs, zh, dninv
+      real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4
+      real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 900.0
+      real, parameter :: zhfac = 1./(pi*xdnh*xn0h)
+      real, parameter :: zrfac = 1./(pi*xdnr*xn0r)
+      real, parameter :: zsfac = 1./(pi*xdns*xn0s)
+      real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0))
+
+      real xv,xdn
+      integer :: ndbz, nmwgt, nnwgt, nwlessthanz
+
+! ------------------------------------------------------------------
+      
+      
+      jy = 1
+      
+      
+         g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/  &
+     &        ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah))
+     
+         IF ( imurain == 3 ) THEN
+         g1r = (rnu+2.0)/(rnu+1.0)
+         ELSE ! imurain == 1
+         g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/  &
+     &        ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
+         ENDIF
+
+         g1s = (snu+2.0)/(snu+1.0)
+      
+      DO kz = 1,nz
+       DO ix = 1,nx ! ixcol
+
+         dninv = 1./dn(ix,kz)
+         
+   !  Cloud droplets
+         
+         IF ( lnc > 1 ) THEN
+           IF ( an(ix,jy,kz,lnc) <= 0.0 .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN
+             an(ix,jy,kz,lnc) = qccn
+           ENDIF
+         ENDIF
+
+   !  rain
+         
+         IF ( lnr > 1 ) THEN
+           IF ( an(ix,jy,kz,lnr) <= 0.0 .and. an(ix,jy,kz,lr) > qxmin(lr) ) THEN
+
+             q = an(ix,jy,kz,lr)
+             
+             laminv1 = (dn(ix,kz) * q * zrfac)**(0.25)  ! inverse of slope
+             
+             n1 = laminv1*xn0h  ! number concentration for inv. exponential single moment input
+             
+             nrx =  n1*g1r/g0   ! number concentration for different shape parameter
+
+             an(ix,jy,kz,lnr) = nrx ! *dninv ! convert to number mixing ratio
+             
+           ENDIF
+         ENDIF
+
+  ! snow
+         IF ( lns > 1 ) THEN
+           IF ( an(ix,jy,kz,lns) <= 0.0 .and. an(ix,jy,kz,ls) > qxmin(ls) ) THEN
+
+             q = an(ix,jy,kz,ls)
+             
+             laminv1 = (dn(ix,kz) * q * zsfac)**(0.25)  ! inverse of slope
+             
+             n1 = laminv1*xn0s  ! number concentration for inv. exponential single moment input
+             
+             nrx =  n1*g1s/g0   ! number concentration for different shape parameter
+
+             an(ix,jy,kz,lns) = nrx ! *dninv ! convert to number mixing ratio
+             
+           ENDIF
+         ENDIF
+         
+    ! graupel
+
+         IF ( lnh > 1 ) THEN
+           IF ( an(ix,jy,kz,lnh) <= 0.0 .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN
+             IF ( lvh > 1 ) THEN
+               IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN
+                 an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh
+               ENDIF
+             ENDIF
+
+             q = an(ix,jy,kz,lh)
+             
+             laminv1 = (dn(ix,kz) * q * zhfac)**(0.25)  ! inverse of slope
+             
+             n1 = laminv1*xn0h  ! number concentration for inv. exponential single moment input
+             
+             nrx =  n1*g1h/g0   ! number concentration for different shape parameter
+
+             an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio
+
+           ENDIF
+         ENDIF
+ 
+      ENDDO ! ix
+      ENDDO ! kz
       
       RETURN
       
-      END subroutine calcnfromz1d
+      END subroutine calcnfromq
+
 
 
 ! #####################################################################
@@ -2528,7 +3089,7 @@ SUBROUTINE NUCOND    &
      &  ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & 
      &  ,an,dn,p2 & 
      &  ,pn,w & 
-     &  ,ssfilt,t00,t77,tmp3d)
+     &  ,ssfilt,t00,t77,tmp3d,scion)
 
    implicit none
 
@@ -2569,6 +3130,8 @@ SUBROUTINE NUCOND    &
       real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
 
       real tmp3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz)
+
+      real scion(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,2)
       
     ! local
 
@@ -2576,13 +3139,14 @@ SUBROUTINE NUCOND    &
 !  declarations microphysics and for gather/scatter
 !
       integer nxmpb,nzmpb,nxz
-      integer jgs,mgs,ngs,numgs,inumgs
-      parameter (ngs=50)
+      integer mgs,ngs,numgs,inumgs
+      parameter (ngs=500)
       integer ngscnt,igs(ngs),kgs(ngs)
       integer kgsp(ngs),kgsm(ngs)
       integer nsvcnt
       
-      integer ix,jy,kz,i,n
+      integer ix,kz,i,n, kp1
+      integer :: jy, jgs
       integer ixb,ixe,jyb,jye,kzb,kze
     
       integer itile,jtile,ktile
@@ -2594,7 +3158,7 @@ SUBROUTINE NUCOND    &
 !      
 
 
-      real ccnc(ngs)
+      real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs)
       real sscb  ! 'cloud base' SS threshold
       parameter ( sscb = 2.0 )
       integer idecss  ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals
@@ -2618,10 +3182,12 @@ SUBROUTINE NUCOND    &
 
       real ec0, ex1, ft, rhoinv(ngs)
       
-      real chw, g1
+      real chw, g1, rd1
 
       real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super
-      real x,y,del,r,rtmp
+      real x,y,del,r,alpr
+      double precision :: vent1,vent2
+      real g1palp
       real bs
       real v1, v2
       real d1r, d1i, d1s, e1i
@@ -2657,7 +3223,7 @@ SUBROUTINE NUCOND    &
       parameter (epsi = 0.622, d = 0.266)
       real r1,qevap ! ,slv
       
-      real vr,nrx,qr,z1,rdi,alp,xnutmp,xnuc
+      real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc
       real ctmp, ccwtmp
       real f5, qvs0  ! Kessler condensation factor
       real    :: t0p1, t0p3
@@ -2665,12 +3231,12 @@ SUBROUTINE NUCOND    &
       
 !      real, dimension(ngs) :: temp, tempc, elv, elf, els, pqs, theta, temg, temcg
       real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs)
-!      real delqci(ngs) ! ,delqip(ngs)
       real temp(ngs),tempc(ngs)
       real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) ! ,tembzg(ngs)
       real temgx(ngs),temcgx(ngs)
       real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs)
       real felv(ngs),felf(ngs),fels(ngs)
+      real felvcp(ngs)
       real gamw(ngs),gams(ngs)   !   qciavl(ngs),
       real tsqr(ngs),ssi(ngs),ssw(ngs)
       real cc3(ngs),cqv1(ngs),cqv2(ngs)
@@ -2692,10 +3258,11 @@ SUBROUTINE NUCOND    &
       real fcqv1(ngs)
       real wvel(ngs),wvelkm1(ngs)
 
-      real wvdf(ngs),tka(ngs) 
+      real wvdf(ngs),tka(ngs)
       real advisc(ngs)
-      
+
       real rwvent(ngs)
+      
 
       real :: qx(ngs,lv:lhab)
       real :: cx(ngs,lc:lhab)
@@ -2704,13 +3271,18 @@ SUBROUTINE NUCOND    &
       real :: xdn(ngs,lc:lhab)
       real :: xdia(ngs,lc:lhab,3)
       real :: alpha(ngs,lr:lhab)
-      
+      real :: zx(ngs,lr:lhab)
+
+
       logical zerocx(lc:lqmx)
 
       integer, parameter :: iunit = 0
       
       real :: frac, hwdn, tmpg
       
+      real :: cvm
+
+! -------------------------------------------------------------------------------
       itile = nx
       jtile = ny
       ktile = nz
@@ -2722,8 +3294,10 @@ SUBROUTINE NUCOND    &
       nzend = nz
       kzbeg = 1
       nzbeg = 1
+
+      jy = 1
       
-      IF ( ipconc <= 1 ) GOTO 2200
+      IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200
 
 !
 !  Ziegler nucleation 
@@ -2731,38 +3305,33 @@ SUBROUTINE NUCOND    &
 
       ssfilt(:,:,:) = 0.0
 
-
-      jy = 1
-      do kz = 1,nz-1
+      do kz = 1,nz
         do ix = 1,nx
 
          temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz)
-        
-         t0(ix,jy,kz) = temp1
-         
-         ltemq = Int( (temp1-163.15)/fqsat+1.5 )
+          t0(ix,jy,kz) = temp1
+          ltemq = Int( (temp1-163.15)/fqsat+1.5 )
          ltemq = Min( nqsat, Max(1,ltemq) )
 
           c1 = t00(ix,jy,kz)*tabqvs(ltemq)
 
           ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0)  ! from "new" values
-          
+
 
         ENDDO
       ENDDO
 
-      
+
 !
-     jy = 1 ! working on a 2d slab
-     
-!  VERY IMPORTANT:  SET jgs = jy
+!     jy = 1 ! working on a 2d slab
+!!  VERY IMPORTANT:  SET jgs = jy
 
       jgs = jy
-      
+
 !
-!..Gather microphysics  
+!..Gather microphysics
 !
-      if ( ndebug .gt. 0 ) print*,'ICEZVD_DR: Gather stage'
+      if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Gather stage'
 
       nxmpb = 1
       nzmpb = 1
@@ -2776,7 +3345,7 @@ SUBROUTINE NUCOND    &
 
 
       kzb = nzmpb
-      kze = nz-2
+      kze = nz
  !     if (kzbeg .le. nzmpb .and. kzend .gt. nzmpb) kzb = nzmpb
 
       ixb = nxmpb
@@ -2787,8 +3356,8 @@ SUBROUTINE NUCOND    &
       do ix = nxmpb,nx
 
       pqs(1) = 380.0/pn(ix,jy,kz)
-      theta(1) = an(ix,jy,kz,lt) 
-      temg(1) = t0(ix,jy,kz) 
+      theta(1) = an(ix,jy,kz,lt)
+      temg(1) = t0(ix,jy,kz)
 
       temcg(1) = temg(1) - tfr
       ltemq = (temg(1)-163.15)/fqsat+1.5
@@ -2802,25 +3371,28 @@ SUBROUTINE NUCOND    &
       if ( temg(1) .lt. tfr ) then
       end if
 !
-      if ( temg(1) .gt. tfrh .and.  & 
-     &   ( an(ix,jy,kz,lv)  .gt. qss(1) .or. & 
-     &     an(ix,jy,kz,lc)  .gt. qxmin(lc)   .or.  & 
-     &     ( an(ix,jy,kz,lr)  .gt. qxmin(lr) .and. rcond == 2 )  & 
+      if ( (temg(1) .gt. tfrh ) .and.  &
+     &   ( an(ix,jy,kz,lv)  .gt. qss(1) .or. &
+     &     an(ix,jy,kz,lc)  .gt. qxmin(lc)   .or.  &
+     &     ( an(ix,jy,kz,lr)  .gt. qxmin(lr) .and. rcond == 2 )  &
      &     )) then
       ngscnt = ngscnt + 1
       igs(ngscnt) = ix
       kgs(ngscnt) = kz
       if ( ngscnt .eq. ngs ) goto 2100
       end if
+
       end do  !ix
+
       nxmpb = 1
       end do  !kz
 !      if ( jy .eq. (ny-jstag) ) iend = 1
  2100 continue
-      
+
       if ( ngscnt .eq. 0 ) go to 29998
 
-      if (ndebug .gt. 0 ) print*,'ICEZVD_DR: dbg = 8'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8'
+
       
       qx(:,:) = 0.0
       cx(:,:) = 0.0
@@ -2836,21 +3408,22 @@ SUBROUTINE NUCOND    &
       DO mgs = 1,ngscnt
       qx(mgs,lv) = an(igs(mgs),jy,kgs(mgs),lv)
        DO il = lc,lhab
-        qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) 
+        qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0)
        ENDDO
 
        qcwtmp(mgs) = qx(mgs,lc)
-       
 
-      theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) ! 
+
+      theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) !
       thetap(mgs) = 0.0
       theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt)
       qv0(mgs) =  qx(mgs,lv)
-      qwvp(mgs) = qx(mgs,lv) - qv0(mgs) 
+      qwvp(mgs) = qx(mgs,lv) - qv0(mgs)
 
        pres(mgs) = pn(igs(mgs),jy,kgs(mgs))
        rho0(mgs) = dn(igs(mgs),jy,kgs(mgs))
        rhoinv(mgs) = 1.0/rho0(mgs)
+       rhovt(mgs) = Sqrt(rho00/rho0(mgs))
        pi0(mgs) = p2(igs(mgs),jy,kgs(mgs))
        temg(mgs) = t0(igs(mgs),jy,kgs(mgs))
        pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap
@@ -2871,6 +3444,16 @@ SUBROUTINE NUCOND    &
         temgx(mgs) = max(temgx(mgs),233.15)
         felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs))
 !
+        IF ( eqtset <= 1 ) THEN
+          felvcp(mgs) = felv(mgs)*cpi
+        ELSE ! equation set 2 in cm1
+          tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
+          IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
+          cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr))   &
+                                  +cpigb*(tmp)
+          felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm
+        ENDIF
+
         temcgx(mgs) = min(temg(mgs),273.15)
         temcgx(mgs) = max(temcgx(mgs),223.15)
         temcgx(mgs) = temcgx(mgs)-273.15
@@ -2879,13 +3462,13 @@ SUBROUTINE NUCOND    &
         fels(mgs) = felv(mgs) + felf(mgs)
         fcqv1(mgs) = 4098.0258*felv(mgs)*cpi
 
-      wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & 
+      wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* &
      &  (101325.0/pn(igs(mgs),jgs,kgs(mgs)))                            ! diffusivity of water vapor, Hall and Pruppacher (76)
-      advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & 
+      advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* &
      &  (temg(mgs)/296.0)**(1.5)                         ! dynamic viscosity (SMT; see Beard & Pruppacher 71)
       tka(mgs) = tka0*advisc(mgs)/advisc1                 ! thermal conductivity
 
-      
+
       ENDDO
 
 
@@ -2901,8 +3484,21 @@ SUBROUTINE NUCOND    &
       if ( ipconc .ge. 2 ) then
        do mgs = 1,ngscnt
         cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0)
+        cwnccn(mgs) = cwccn*rho0(mgs)/rho00
+        cn(mgs) = 0.0
         IF ( lccn .gt. 1 ) THEN
           ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
+        ELSE
+          ccnc(mgs) = cwnccn(mgs)
+        ENDIF
+        IF ( lccna > 1 ) THEN
+          ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna)
+        ELSE
+          IF ( lccn > 1 ) THEN
+            ccna(mgs) = cwnccn(mgs) - ccnc(mgs)
+          ELSE
+            ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn
+          ENDIF
         ENDIF
        end do
       end if
@@ -2912,24 +3508,28 @@ SUBROUTINE NUCOND    &
        end do
       end if
 
+        cnuc(1:ngscnt) = cwccn*(1. - renucfrac) + ccnc(1:ngscnt)*renucfrac
 
 
 !  Set density
 !
-      if (ndebug .gt. 0 ) print*,'ICEZVD_DR: Set density'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set density'
 
       do mgs = 1,ngscnt
         xdn(mgs,lc) = xdn0(lc)
         xdn(mgs,lr) = xdn0(lr)
       end do
 
+      ventrx(:) = ventr
+      ventrxn(:) = ventrn
+      
 
 
       
       DO mgs = 1,ngscnt
       
-      
-      wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)+1) & 
+      kp1 = Min(nz, kgs(mgs)+1 )
+      wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & 
      &                  +w(igs(mgs),jgs,kgs(mgs)))
       wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & 
      &                  +w(igs(mgs),jgs,Max(1,kgs(mgs)-1)))
@@ -2939,7 +3539,7 @@ SUBROUTINE NUCOND    &
       
       ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1))
       ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1))
-      
+
 
       ENDDO
 
@@ -2949,26 +3549,26 @@ SUBROUTINE NUCOND    &
 !  cloud water variables
 !
 
-      if ( ndebug .gt. 0 )print*,'ICEZVD_DR: Set cloud water variables'
+      if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables'
 
       do mgs = 1,ngscnt
       xv(mgs,lc) = 0.0
       IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN
-        xmas(mgs,lc) = & 
+        xmas(mgs,lc) = &
      &    min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
         xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
       ELSE
        IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN
-        xmas(mgs,lc) = & 
-     &     min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & 
+        xmas(mgs,lc) = &
+     &     min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), &
      &      xdn(mgs,lc)*xvmx(lc) )
-        
+
         cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)
-        
+
        ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN
         xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3
         cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)
-        
+
        ELSE
         xmas(mgs,lc) = cwmasn
        ENDIF
@@ -2982,7 +3582,7 @@ SUBROUTINE NUCOND    &
 !
       do mgs = 1,ngscnt
       if ( qx(mgs,lr) .gt. qxmin(lr) ) then
-      
+
       if ( ipconc .ge. 3 ) then
         xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-9,cx(mgs,lr)))
 !      parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 )  ! mks
@@ -2995,7 +3595,13 @@ SUBROUTINE NUCOND    &
         ENDIF
 
         xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr)
-        xdia(mgs,lr,1) = (xmas(mgs,lr)*cwc1)**(1./3.)
+        xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1)
+        IF ( imurain == 3 ) THEN
+!          xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.)
+          xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1)
+        ELSE ! imurain == 1, Characteristic diameter (1/lambda)
+          xdia(mgs,lr,1) = (6.*piinv*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.)
+        ENDIF
 !        rwrad(mgs) = 0.5*xdia(mgs,lr,1)
 
 ! Inverse exponential version:
@@ -3003,8 +3609,8 @@ SUBROUTINE NUCOND    &
 !     >  (qx(mgs,lr)*rho0(mgs)
 !     > /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333)
       ELSE
-        xdia(mgs,lr,1) = & 
-     &  (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) 
+        xdia(mgs,lr,1) = &
+     &  (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25)
       end if
       else
         xdia(mgs,lr,1) = 1.e-9
@@ -3012,7 +3618,7 @@ SUBROUTINE NUCOND    &
       end if
 
       end do
-      
+
 
 !
 !  Ventilation coefficients
@@ -3033,22 +3639,22 @@ SUBROUTINE NUCOND    &
       fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5))
 
       end do
-
+!
 !
 !  Ziegler nucleation 
 !
 !
 ! cloud evaporation, condensation, and nucleation
 !  sqsat -> qss(mgs)
-      
+
       DO mgs=1,ngscnt
         dcloud = 0.0
         IF ( temg(mgs) .le. tfrh ) THEN
-        
-        
+
+
          CYCLE
         ENDIF
-        
+
       IF( ssat0(mgs) .GT. 0. .OR. ssf(mgs) .GT. 0. ) GO TO 620
 !6/4      IF( qvap(mgs) .EQ. qss(mgs) ) GO TO 631
 !
@@ -3058,11 +3664,11 @@ SUBROUTINE NUCOND    &
       IF ( qx(mgs,lc) .LE. 0. ) GO TO 631
 !.... CLOUD EVAPORATION.
 ! convert input 'cp' to cgs
-      R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ & 
+      R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ &
      &            (cp*(temg(mgs) - cbw)**2))
       QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) )
-      
-      
+
+
       IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63
         qwvp(mgs) = qwvp(mgs) + qx(mgs,lc)
         thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs))
@@ -3093,13 +3699,13 @@ SUBROUTINE NUCOND    &
 !       ac1 =  xdn(mgs,lc)*elv(kgs(mgs))**2*epsi/
 !     :        (tka(kgs(mgs))*rw*temg(mgs)**2)
 ! took out xdn factor because it cancels later...
-       ac1 =  felv(mgs)**2*epsi/(tka(mgs)*rw*temg(mgs)**2)
-       
+       ac1 =  felv(mgs)**2/(tka(mgs)*rw*temg(mgs)**2)
+
 
 !       bc = xdn(mgs,lc)*rw*temg(mgs)/
 !     :       (epsi*wvdf(kgs(mgs))*es(mgs))
 ! took out xdn factor because it cancels later...
-       bc =   rw*temg(mgs)/(epsi*wvdf(mgs)*es(mgs))
+       bc =   rw*temg(mgs)/(wvdf(mgs)*es(mgs))
 
 !       bs = rho0(mgs)*((rd*temg(mgs)/(epsi*es(mgs)))+
 !     :             (epsi*elv(kgs(mgs))**2/(pres(mgs)*temg(mgs)*cp)))
@@ -3107,35 +3713,80 @@ SUBROUTINE NUCOND    &
 !       taus = Min(dtp, xdn(mgs,lc)*rho0(mgs)*(ac1+bc)/
 !     :        (4*pi*0.89298*BS*0.5*xdia(mgs,lc,1)*cx(mgs,lc)*xdn(mgs,lc)))
 
-!      
+!
       IF ( ssf(mgs) .gt. 0.0 .or. ssat0(mgs) .gt. 0.0 ) THEN
        IF ( ny .le. 2 ) THEN
-!        print*, 'undershoot: ',ssf(mgs),
+!        write(0,*)  'undershoot: ',ssf(mgs),
 !     :   ( (qx(mgs,lv) - dcloud)/c1 - 1.0)*100.
        ENDIF
 
 
-       
+
        IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN
 
          IF ( xdia(mgs,lc,1) .le. 0.0 ) THEN
           xmas(mgs,lc) = cwmasn
-          xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 
+          xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3
          ENDIF
-        d1 = (1./(ac1 + bc))*4.0*pi*ventc & 
+        d1 = (1./(ac1 + bc))*4.0*pi*ventc &
      &        *0.5*xdia(mgs,lc,1)*cx(mgs,lc)*rhoinv(mgs)
-       
+
        ELSE
          d1 = 0.0
        ENDIF
 
        IF ( rcond .eq. 2 .and. qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > 1.e-9 ) THEN
-!       rwvent(mgs) = ventr*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046)
+          IF ( imurain == 3 ) THEN
+           IF ( izwisventr == 1 ) THEN
+            rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046)
+           ELSE ! izwisventr = 2
 !  Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier's rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
           rwvent(mgs) =   &
-     &  (0.78*ventr + 0.308*ventrn*fvent(mgs)   &
+     &  (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs)   &
      &   *Sqrt((ar*rhovt(mgs)))   &
      &    *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
+           ENDIF
+
+          ELSE ! imurain == 1
+
+           IF ( iferwisventr == 1 ) THEN
+             alpr = Min(alpharmax,alpha(mgs,lr) )
+!             alpr = alpha(mgs,lr)
+             x =  1. + alpr
+
+              tmp = 1 + alpr
+              i = Int(dgami*(tmp))
+              del = tmp - dgam*i
+              g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+              tmp = 2.5 + alpr + 0.5*bx(lr)
+              i = Int(dgami*(tmp))
+              del = tmp - dgam*i
+              y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions
+
+         vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr)
+         vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr))
+        
+        
+        rwvent(mgs) =    &
+     &    0.78*x +    &
+     &    0.308*fvent(mgs)*y*   &
+     &            Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
+
+           ELSEIF ( iferwisventr == 2 ) THEN
+          
+!  Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier's rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
+            x =  1. + alpha(mgs,lr)
+
+            rwvent(mgs) =   &
+     &        (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs)   &
+     &         *Sqrt((ar*rhovt(mgs)))   &
+     &         *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
+
+          
+          ENDIF ! iferwisventr
+          
+       ENDIF ! imurain
 
        d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & 
      &        *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs)
@@ -3144,18 +3795,18 @@ SUBROUTINE NUCOND    &
        ENDIF
        
        
-       e1  = felv(mgs)/(CP*pi0(mgs))
+       e1  = felvcp(mgs)/(pi0(mgs))
        f1 = pk(mgs) ! (pres(mgs)/poo)**cap
 
 !
-!  fifth trial to see what happens: 
+!  fifth trial to see what happens:
 !
        ltemq = (temg(mgs)-163.15)/fqsat+1.5
        ltemq = Min( nqsat, Max(1,ltemq) )
-       ltemq1 = ltemq 
+       ltemq1 = ltemq
        temp1 = temg(mgs)
        p380 = 380.0/pres(mgs)
-       
+
 !       taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) )
 !       nc = NInt(dtp/Min(1.0,0.5*taus))
 !       dtcon = dtp/float(nc)
@@ -3167,11 +3818,11 @@ SUBROUTINE NUCOND    &
        qis1 = qis(mgs)
        dt1 = 0.0
 
-          
+
 !          dtcon = Max(dtcon,0.2)
 !          nc = Nint(dtp/dtcon)
 
-       ltemq1 = ltemq 
+       ltemq1 = ltemq
 ! want to start out with a small time step to handle the steep slope
 ! and fast changes, then can switch to a larger step (dtcon2) for the
 ! rest of the big time step.
@@ -3195,8 +3846,8 @@ SUBROUTINE NUCOND    &
        dqr = 0.0
        dqi = 0.0
        dqs = 0.0
-       
-       RK2c: DO WHILE ( dt1 .lt. dtp ) 
+
+       RK2c: DO WHILE ( dt1 .lt. dtp )
           nc = 0
           IF ( n .le. 4 ) THEN
             dtcon = dtcon1
@@ -3206,7 +3857,7 @@ SUBROUTINE NUCOND    &
  609       dqv  = -(ss1 - 1.)*d1*dtcon
            dqvr = -(ss1 - 1.)*d1r*dtcon
             dtemp = -0.5*e1*f1*(dqv + dqvr)
-!          print*,'RK2c dqv1 = ',dqv
+!          write(0,*) 'RK2c dqv1 = ',dqv
 ! calculate midpoint values:
            ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5)
            IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN
@@ -3220,6 +3871,7 @@ SUBROUTINE NUCOND    &
              write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta
              write(0,*) ' nc,dtp = ',nc,dtp
              write(0,*) ' rwvent,xdia,crw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr)
+             write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr)
              write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1
            ENDIF
             dqvs = dtemp*p380*dtabqvs(ltemq1m)
@@ -3243,7 +3895,7 @@ SUBROUTINE NUCOND    &
           dqvr = -(ss1m - 1.)*d1r*dtcon
 
 
-!          print*,'RK2a dqv1m = ',dqv
+!          write(0,*) 'RK2a dqv1m = ',dqv
           dtemp = -e1*f1*(dqv + dqvr)
           ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5)
            IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN
@@ -3261,10 +3913,10 @@ SUBROUTINE NUCOND    &
           qvs1 = qvs1 + dqvs
           ss1 = qv1/qvs1
           temp1 = temp1 + dtemp
-          IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or.  & 
-     &           ss1 .eq. 1.00 .or.  & 
+          IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or.  &
+     &           ss1 .eq. 1.00 .or.  &
      &      ( n .gt. 10 .and. ss1 .lt. 1.0005 ) ) THEN
-!           print*,'RK2c break'
+!           write(0,*) 'RK2c break'
            EXIT
           ELSE
            ss2 = ss1
@@ -3273,8 +3925,8 @@ SUBROUTINE NUCOND    &
            n = n + 1
           ENDIF
        ENDDO RK2c
-       
-        
+
+
         dcloud = dqc ! qx(mgs,lv) - qv1
         thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr)
         qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr)
@@ -3290,25 +3942,25 @@ SUBROUTINE NUCOND    &
         ltemq = Min( nqsat, Max(1,ltemq) )
         qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
         es(mgs) = 6.1078e2*tabqvs(ltemq)
-        
-!            
-      
+
+!
+
       ENDIF  ! dcloud .gt. 0.
-     
+
 
       ELSE  ! qc .le. qxmin(lc)
 
         IF ( ssf(mgs) .gt. 0.0 ) THEN ! .and.  ssmax(mgs) .lt. sscb ) THEN
 
           IF ( iqcinit == 1 ) THEN
-         
+
          qvs0   = 380.*exp(17.27*(temg(mgs)-273.)/(temg(mgs)- 36.))/pk(mgs)
 
          dcloud = Max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) )
-          
+
           ELSEIF ( iqcinit == 3 ) THEN
-              R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ & 
-     &             (cp*(temg(mgs) - cbw)**2))
+              R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & 
+     &             ((temg(mgs) - cbw)**2))
             DCLOUD=R1*(qvap(mgs) - qvs(mgs))  ! KW model adjustment; 
                               ! this will put mass into qc if qv > sqsat exists
           
@@ -3321,7 +3973,7 @@ SUBROUTINE NUCOND    &
 
           IF ( ssf(mgs) > ssmx ) THEN
            CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & 
-     &      pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felv,ssmx,pk,ngscnt)
+     &      pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt)
           ELSE
             dcloud = 0.0
           ENDIF
@@ -3330,7 +3982,7 @@ SUBROUTINE NUCOND    &
             dcloud = 0.0
         ENDIF
 
-        thetap(mgs) = thetap(mgs) + felv(mgs)*DCLOUD/(CP*pi0(mgs))
+        thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
         qwvp(mgs) = qwvp(mgs) - DCLOUD
         qx(mgs,lc) = qx(mgs,lc) + DCLOUD
 
@@ -3345,6 +3997,54 @@ SUBROUTINE NUCOND    &
         qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
         es(mgs) = 6.1078e2*tabqvs(ltemq)
 
+!.... S. TWOMEY (1959)
+! Note: get here if there is no previous cloud water and w > 0.
+      cn(mgs) = 0.0
+      
+      IF ( ncdebug .ge. 1 ) THEN
+        write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs)
+      ENDIF
+      
+!      IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN
+      IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN
+       CN(mgs) =   CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465
+        IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0    &
+     &                    .and. ncdebug .ge. 1 ) THEN ! .and. kgs(mgs) <= 6 ) THEN
+          write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3,   &
+     &       wvel(mgs), dcloud*1.e3
+          IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ',   &
+     &       1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3,   &
+     &   igs(mgs),kgs(mgs),temcg(mgs),    &
+     &   1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc)
+        ENDIF
+        IF ( iccwflg .eq. 1 ) THEN
+          cn(mgs) = Min(cwccn, Max(cn(mgs),   &
+     &       rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)))
+        ENDIF
+      ELSE
+          cn(mgs) = Min(cwccn,    &
+     &       rho0(mgs)*dcloud/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3) )
+      ENDIF
+
+      IF ( cn(mgs) .gt. 0.0 ) THEN
+       IF ( cn(mgs) .gt. ccnc(mgs) ) THEN
+         cn(mgs) = ccnc(mgs)
+!         ccnc(mgs) = 0.0
+       ENDIF
+!      cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+      ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+      ccna(mgs) = ccna(mgs) + cn(mgs)
+      ENDIF
+
+!       write(91,*) 'nuc1: cn, ix, kz = ',cn(mgs),igs(mgs),kgs(mgs),wvel(mgs),cnexp,ccnc(mgs)
+
+      IF( CN(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = CN(mgs)
+      IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN
+        cx(mgs,lc) = 0.
+      ELSE
+        cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn)
+      ENDIF
+
         END IF ! qc .gt. 0.
 
 !        ES=EES(PIB(K)*PT)
@@ -3360,9 +4060,9 @@ SUBROUTINE NUCOND    &
       IF ( kzbeg-1+kgs(mgs) .eq. 1 .and. wvel(mgs) .gt. 0. ) GO TO 613         !TWOMEY (1959) Nucleation
 !.... ATTEMPT ZIEGLER CLOUD NUCLEATION IN CLOUD INTERIOR UNLESS...
   616 IF ( ssf(mgs) .LE. SUPCB .AND. wvel(mgs) .GT. 0. ) GO TO 631 !... weakly saturated updraft
-      IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND.  & 
-     &    (ssfkp1(mgs) .GE. SUPMX .OR. & 
-     &     ssf(mgs)    .GE. SUPMX .OR. & 
+      IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND.  &
+     &    (ssfkp1(mgs) .GE. SUPMX .OR. &
+     &     ssf(mgs)    .GE. SUPMX .OR. &
      &     ssfkm1(mgs) .GE. SUPMX)) GO TO 631                      !... too much vapour
       IF (ssf(mgs) .LT. 1.E-10 .OR. ssf(mgs) .GE. SUPMX) GO TO 631 !... at the extremes for ss
 
@@ -3376,6 +4076,8 @@ SUBROUTINE NUCOND    &
       r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs))
       IF ( irenuc >= 0 ) THEN
 
+      IF ( irenuc /= 2 ) THEN !{
+
         IF ( kzend == nzend ) THEN
           t0p3 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+3))
           t0p1 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+1))
@@ -3384,27 +4086,27 @@ SUBROUTINE NUCOND    &
           t0p1 = t0(igs(mgs),jgs,kgs(mgs)+1)
         ENDIF
 
-      IF ( ( ssf(mgs) .gt. ssmax(mgs) .or.  irenuc .eq. 1 ) & 
-     &   .and.  ( ( lccn .lt. 1 .and.  & 
-     &            cx(mgs,lc) .lt. cwccn*(Min(1.0,rho0(mgs)))) .or. & 
-     &    ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. )   ) & 
+      IF ( ( ssf(mgs) .gt. ssmax(mgs) .or.  irenuc .eq. 1 ) &
+     &   .and.  ( ( lccn .lt. 1 .and.  &
+     &            cx(mgs,lc) .lt. cwccn*(Min(1.0,rho0(mgs)))) .or. &
+     &    ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. )   ) &
      &    ) THEN
-      IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & 
-     &  .and. ssf(mgs) .gt. 0.0 & 
+      IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 &
+     &  .and. ssf(mgs) .gt. 0.0 &
      &  .and. ssfkp1(mgs) .LT. SUPMX .and. ssfkp1(mgs) .ge. 0.0  &
-     &  .AND. ssfkm1(mgs) .LT. SUPMX .AND. ssfkm1(mgs) .ge. 0.0  & 
-     &  .AND. ssfkp1(mgs) .gt. ssfkm1(mgs)  & 
+     &  .AND. ssfkm1(mgs) .LT. SUPMX .AND. ssfkm1(mgs) .ge. 0.0  &
+     &  .AND. ssfkp1(mgs) .gt. ssfkm1(mgs)  &
      &  .and. t0p3 .gt. 233.2) THEN
           DSSDZ = (ssfkp1(mgs) - ssfkm1(mgs))*R2DZM
 !
 ! otherwise check for cloud base condition with updraft:
 !
         ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 &
-!        IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 & 
-     &  .and. ssf(mgs) .gt. 0.0  .and. wvel(mgs) .gt. 0.0 & 
+!        IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 &
+     &  .and. ssf(mgs) .gt. 0.0  .and. wvel(mgs) .gt. 0.0 &
      &  .and. ssfkp1(mgs) .gt. 0.0   &
-     &  .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 & 
-     &  .AND. ssf(mgs) .gt. ssfkm1(mgs)  & 
+     &  .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 &
+     &  .AND. ssf(mgs) .gt. ssfkm1(mgs)  &
      &  .and. t0p1 .gt. 233.2) THEN
          DSSDZ = 2.*(ssf(mgs) - ssfkm1(mgs))*R2DZM  ! 1-sided difference
         ENDIF
@@ -3413,7 +4115,7 @@ SUBROUTINE NUCOND    &
 !
 !CLZ  IF(wijk.LE.0.) CN=CCN*ssfilt(ix,jy,kz)**CCK
 ! note: CCN -> cwccn, DELT -> dtp
-      c1 = Max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ & 
+      c1 = Max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ &
      &        (xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3))
       IF ( lccn .lt. 1 ) THEN
        CN(mgs) = cwccn*CCK*ssf(mgs)**CCKM*dtp*   &
@@ -3421,15 +4123,12 @@ SUBROUTINE NUCOND    &
      &         (wvel(mgs)*DSSDZ) )      ! probably the vertical gradient dominates
       ELSE
       CN(mgs) =  &
-!     :   Min(Min(c1,ccnc(mgs)), cwccn*CCK*ssf(mgs)**CCKM*dtp*
-!     :   Min(ccnc(mgs), cwccn*CCK*ssf(mgs)**CCKM*dtp*
-!     &    ( cwccn*CCK*ssf(mgs)**CCKM*dtp*   &
-     &    Min(ccnc(mgs), ccnc(mgs)*CCK*ssf(mgs)**CCKM*dtp*   &
+     &    Min(ccnc(mgs), cnuc(mgs)*CCK*ssf(mgs)**CCKM*dtp*   &
      & Max(0.0,    &
-     &         (  wvel(mgs)*DSSDZ) )  )
+     &         ( wvel(mgs)*DSSDZ) )  )
 !      IF ( cn(mgs) .gt. 0 ) ccnc(mgs) = ccnc(mgs) - cn(mgs)
       ENDIF
-      
+
       IF ( cn(mgs) .gt. 0.0 ) THEN
        IF ( ccnc(mgs) .lt. 5.e7 .and. cn(mgs) .ge. 5.e7 ) THEN
           cn(mgs) = 5.e7
@@ -3442,6 +4141,20 @@ SUBROUTINE NUCOND    &
       ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
       ENDIF
 
+      ELSEIF ( irenuc == 2 ) THEN !} { 
+      ! simple Twomey scheme
+       CN(mgs) =   CCNE*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465
+!!       CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) )
+       CN(mgs) = Min(cn(mgs), ccnc(mgs))
+       
+       cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+       
+       ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+       
+      ENDIF ! }
+
+      ccna(mgs) = ccna(mgs) + cn(mgs)
+
       ENDIF ! irenuc >= 0
 
       IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0.
@@ -3449,43 +4162,6 @@ SUBROUTINE NUCOND    &
 !.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT
 
   613 CONTINUE
-!.... S. TWOMEY (1959)
-! Note: get here if there is no previous cloud water and w > 0.
-      cn(mgs) = 0.0
-      IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN
-       CN(mgs) =   CCNE*wvel(mgs)**cnexp ! 0.3465
-        IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0    &
-     &                    .and. ncdebug .ge. 1 ) THEN
-          print*, 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3,   &
-     &       wvel(mgs), dcloud*1.e3
-          IF ( cn(mgs) .gt. 1.0 ) print*, 'cwrad = ',   &
-     &       1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3,   &
-     &   igs(mgs),kgs(mgs),temcg(mgs),    &
-     &   1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc)
-        ENDIF
-        IF ( iccwflg .eq. 1 ) THEN
-          cn(mgs) = Min(cwccn, Max(cn(mgs),   &
-     &       rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)))
-        ENDIF
-      ELSE
-       cn(mgs) = 0.0
-      ENDIF
-
-      IF ( cn(mgs) .gt. 0.0 ) THEN
-       IF ( cn(mgs) .gt. ccnc(mgs) ) THEN
-         cn(mgs) = ccnc(mgs)
-         ccnc(mgs) = 0.0
-       ENDIF
-!      cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
-      ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
-      ENDIF
-
-      IF( CN(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = CN(mgs)
-      IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN
-        cx(mgs,lc) = 0.
-      ELSE
-        cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn)
-      ENDIF
 
   631  CONTINUE
 
@@ -3503,12 +4179,12 @@ SUBROUTINE NUCOND    &
         ssmx = 100.*(ssmx - 1.0)
 
         CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex,   &
-     &    pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felv,ssmx,pk,ngscnt)
+     &    pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt)
 
 
 
         IF ( qvex .gt. 0.0 ) THEN
-        thetap(mgs) = thetap(mgs) + felv(mgs)*qvex/(CP*pi0(mgs))
+        thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs))
 
 !        t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (qvex)/dtp*felv(mgs)/(cp*pi0(mgs)) !* &
 !!     &                 dx*dy*dz3d(igs(mgs),jy,kgs(mgs))
@@ -3535,7 +4211,7 @@ SUBROUTINE NUCOND    &
 
 
       cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) )
-      IF( cx(mgs,lc) .GT. 1.0e7 .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN
+      IF ( cx(mgs,lc) .GT. 1.0e7 .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN
         xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc))
       ENDIF
 
@@ -3543,23 +4219,23 @@ SUBROUTINE NUCOND    &
       xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn )
 
 
-      IF( cx(mgs,lc) .GT. 10.e6 .AND. qx(mgs,lc) .GT. qxmin(lc) ) GO TO 681
-        ccwtmp = cx(mgs,lc)
-        cwmastmp = xmas(mgs,lc)
-       xmas(mgs,lc) = Max(xmas(mgs,lc), cwmasn)
-       IF(qx(mgs,lc) .GT. qxmin(lc) .AND. cx(mgs,lc) .le. 0.) THEN
-          cx(mgs,lc) = Min(0.5*cwccn,rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc))
-          xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc)
-       ENDIF
-      IF(cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .GT. qxmin(lc))    &
-     &        xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc)
-      IF(qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .LT. cwmasn)    &
-     &          xmas(mgs,lc) = cwmasn
-      IF(qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .GT. cwmasx)    &
-     &    xmas(mgs,lc) = cwmasx
-      IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN
-        cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc))
-      ENDIF
+!      IF( cx(mgs,lc) .GT. 10.e6 .AND. qx(mgs,lc) .GT. qxmin(lc) ) GO TO 681
+!        ccwtmp = cx(mgs,lc)
+!        cwmastmp = xmas(mgs,lc)
+!       xmas(mgs,lc) = Max(xmas(mgs,lc), cwmasn)
+!       IF (qx(mgs,lc) .GT. qxmin(lc) .AND. cx(mgs,lc) .le. 0.) THEN
+!          cx(mgs,lc) = Min(0.5*cwccn,rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc))
+!          xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc)
+!       ENDIF
+!      IF (cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .GT. qxmin(lc))    &
+!     &        xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc)
+!      IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .LT. cwmasn)    &
+!     &          xmas(mgs,lc) = cwmasn
+!      IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .GT. cwmasx)    &
+!     &    xmas(mgs,lc) = cwmasx
+!      IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN
+!        cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc))
+!      ENDIF
         
 
  681  CONTINUE
@@ -3567,13 +4243,13 @@ SUBROUTINE NUCOND    &
       IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN
 
         
-        IF(cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr))    &
+        IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr))    &
      &       xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr))
-        IF(xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr)
-        IF(xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr)
+        IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr)
+        IF (xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr)
 
       ENDIF
-      
+
 
 
       ENDDO ! mgs
@@ -3589,25 +4265,25 @@ SUBROUTINE NUCOND    &
 !
 
       do mgs = 1,ngscnt
-      an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs) 
-      an(igs(mgs),jy,kgs(mgs),lv) =  qv0(mgs) + qwvp(mgs) 
+      an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs)
+      an(igs(mgs),jy,kgs(mgs),lv) =  qv0(mgs) + qwvp(mgs)
 !      tmp3d(igs(mgs),jy,kgs(mgs)) = tmp3d(igs(mgs),jy,kgs(mgs)) + t9(igs(mgs),jy,kgs(mgs)) !  pi0(mgs) ! wvdf(mgs) ! ssf(mgs) ! cn(mgs)
 !
        if ( ido(lc) .eq. 1 )  then
         an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) +    &
-     &    min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 )  
+     &    min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 )
 !        qx(mgs,lc) = an(igs(mgs),jy,kgs(mgs),lc)
        end if
 !
 
        if ( ido(lr) .eq. 1 .and. rcond == 2 )  then
         an(igs(mgs),jy,kgs(mgs),lr) = qx(mgs,lr) +    &
-     &    min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 )  
+     &    min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 )
 !        qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr)
        end if
 
 
-      
+
        IF (  ipconc .ge. 2 ) THEN
         an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0)
         IF ( lccn .gt. 1 ) THEN
@@ -3630,7 +4306,7 @@ SUBROUTINE NUCOND    &
          nzmpb = kz
         endif
       else
-        nzmpb = kz 
+        nzmpb = kz
       end if
 
       if ( ix .ge. nx ) then
@@ -3657,11 +4333,13 @@ SUBROUTINE NUCOND    &
 
 
       do kz = 1,nz
-      do jy = 1,1
+!      do jy = 1,1
       do ix = 1,nx
       
+      zerocx(:) = .false.
       DO il = lc,lhab
         IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin )
+        IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. an(ix,jy,kz,lz(il)) < zxmin )
       ENDDO
 
       IF ( lhl .gt. 1 ) THEN
@@ -3689,7 +4367,7 @@ SUBROUTINE NUCOND    &
         IF ( lzhl .gt. 1 ) THEN
            an(ix,jy,kz,lzhl) = 0.0
         ENDIF
-      
+
       ELSE
        IF ( lvol(lhl) .gt. 1 ) THEN  ! check density
         IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN
@@ -3707,8 +4385,8 @@ SUBROUTINE NUCOND    &
 !     :       an(ix,jy,kz,lnhl), an(ix,jy,kz,lvhl)
 !          write(iunit,*) 'lvhl = ',lvhl
 !        ENDIF
-        
-        
+
+
         IF ( tmp .gt. xdnmx(lhl) .or. tmp .lt. xdnmn(lhl) ) THEN
           tmp = Min( xdnmx(lhl), Max( xdnmn(lhl) , tmp ) )
           an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp
@@ -3734,11 +4412,11 @@ SUBROUTINE NUCOND    &
        
        ENDIF
 !      ELSE  ! check mean size here?
-        
+
       end if
-      
-      
-      
+
+
+
       ENDIF !lhl
 
 
@@ -3764,21 +4442,21 @@ SUBROUTINE NUCOND    &
         IF ( lzh .gt. 1 ) THEN
            an(ix,jy,kz,lzh) = 0.0
         ENDIF
-      
+
       ELSE
        IF ( lvol(lh) .gt. 1 ) THEN  ! check density
         IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN
          tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh)
-        ELSE 
+        ELSE
          tmp = rho_qh
           an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
         ENDIF
 
         IF (  tmp .lt. xdnmn(lh) ) THEN
-          tmp = Max( xdnmn(lh), tmp ) 
+          tmp = Max( xdnmn(lh), tmp )
           an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
         ENDIF
-        
+
         IF ( tmp .gt. xdnmx(lh) .and. lhw .le. 0 ) THEN ! no liquid allowed on graupel
           tmp = Min( xdnmx(lh), tmp )
           an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
@@ -3787,11 +4465,11 @@ SUBROUTINE NUCOND    &
             tmp = Min( xdnmx(lh), tmp )
             an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
           ELSEIF ( tmp .gt. xdnmx(lr) ) THEN
-            tmp =  xdnmn(lr) 
+            tmp =  xdnmn(lr)
             an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp
           ENDIF
         ENDIF
-        
+
         IF ( lhw .gt. 1 ) THEN ! check if basically pure water
           IF ( an(ix,jy,kz,lhw) .gt. 0.98*an(ix,jy,kz,lh) ) THEN
            tmp = xdnmx(lr)
@@ -3867,8 +4545,9 @@ SUBROUTINE NUCOND    &
 !          an(ix,jy,kz,lnr) = an(ix,jy,kz,lnr) + an(ix,jy,kz,lns)
           an(ix,jy,kz,lns) = 0.0
         ENDIF
-      
+
       ENDIF
+      
 
       ELSEIF ( lvol(ls) .gt. 1 ) THEN  ! check density
         IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN
@@ -3877,11 +4556,11 @@ SUBROUTINE NUCOND    &
             tmp = Min( xdnmx(ls), Max( xdnmn(ls), tmp ) )
             an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp
           ENDIF
-        ELSE 
+        ELSE
           tmp = rho_qs
           an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp
         ENDIF
-        
+
 
       end if
 
@@ -3895,7 +4574,6 @@ SUBROUTINE NUCOND    &
           an(ix,jy,kz,lnr) = 0.0
         ENDIF
         
-      
       end if
 
 !
@@ -3909,10 +4587,11 @@ SUBROUTINE NUCOND    &
          an(ix,jy,kz,lni) = 0.0
        ENDIF
       ENDIF
-      
+
 !
 !  for qcw
 !
+
       IF ( an(ix,jy,kz,lc) .le. frac*qxmin(lc) .or. zerocx(lc)   &
      &       ) THEN
       an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc)
@@ -3923,14 +4602,13 @@ SUBROUTINE NUCOND    &
      &      Min( ccwmx, an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) )
         ENDIF
          an(ix,jy,kz,lnc) = 0.0
-       
-       
+
        ENDIF
 
       ENDIF
 
       end do
-      end do
+!      end do
       end do
       
       
@@ -3945,7 +4623,7 @@ END SUBROUTINE NUCOND
 ! #####################################################################
 
       SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, &
-     &    qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felv,ss1,pk,ngscnt)
+     &    qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt)
       
 !#####################################################################
 !  Purpose: find the amount of vapor that can be condensed to liquid
@@ -3968,7 +4646,7 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, &
 !
       real qv0(ngs), qcw1(ngscnt), pres(ngs), qwvp0(mgs)
       real thetap0(ngs), theta0(ngs)
-      real fcqv1(ngs), felv(ngs), pi0(ngs)
+      real fcqv1(ngs), felvcp(ngs), pi0(ngs)
       real pk(ngs)
       
       real tabqvs(nqsat)
@@ -3986,15 +4664,9 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, &
       
       real tfr
       parameter ( tfr = 273.15 )
-      
-      real cp, rd
-      parameter ( cp = 1004.0, rd = 287.04 )
-      
-      real cpi
-      parameter ( cpi = 1./cp )
-      
-      real poo,cap
-      parameter ( cap = rd/cp, poo = 1.0e+05 )
+            
+!      real poo,cap
+!      parameter ( cap = rd/cp, poo = 1.0e+05 )
 !
 !
 !  Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR)
@@ -4054,8 +4726,8 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, &
         qcw(mgs) = qcw(mgs) + dqcw(mgs)
 
         thetap(mgs) = thetap(mgs) +  &
-     &                cpi/pi0(mgs)*  &
-     &                (felv(mgs)*dqcw(mgs) )
+     &                1./pi0(mgs)*  &
+     &                (felvcp(mgs)*dqcw(mgs) )
 
       end if  ! dqwv(mgs) .lt. 0. (end of evap/sublim)
 !
@@ -4070,8 +4742,8 @@ SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, &
       dqcw(mgs) = dqvcnd(mgs)
 !
       thetap(mgs) = thetap(mgs) +  &
-     &   (felv(mgs)*dqcw(mgs) )    &
-     & / (pi0(mgs)*cp)
+     &   (felvcp(mgs)*dqcw(mgs) )    &
+     & / (pi0(mgs))
       qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) )
       qcw(mgs) = qcw(mgs) + dqcw(mgs)
 !
@@ -4104,6 +4776,7 @@ END SUBROUTINE QVEXCESS
 
 
 
+! #undef CHGELEC
 
 !#include "sam.def.h"
 !#define ICE10
@@ -4163,11 +4836,11 @@ subroutine nssl_2mom_gs   &
      &  ,pn,w,iunit                   &
      &  ,t00,t77,                             &
      &   ventr,ventc,c1sw,jgs,ido,    &
-     &   xdnmx,xdnmn,lsc,               &
-     &   ln,ipc,lvol,lz,lliq,   &
+     &   xdnmx,xdnmn,               &
+!     &   ln,ipc,lvol,lz,lliq,   &
      &   cdx,                              &
-     &   xdn0,tmp3d)
-
+     &   xdn0,tmp3d,timevtcalc  &
+     & )
 !
 !--------------------------------------------------------------------------
 !                                
@@ -4222,21 +4895,17 @@ subroutine nssl_2mom_gs   &
 !
 !
       implicit none
+
 !
 !      integer icond 
 !      parameter ( icond = 2 )
 
       
-      integer jyslab
+      integer jyslab,its,ids,ide,jds,jde ! domain boundaries
       integer ng1
-      integer iunit !,iunit0
+      integer, intent(in) :: iunit !,iunit0
       parameter(ng1 = 1)
-      
       real qvex
-      
-!      character*100 line
-!      integer istat1
-      
       integer iraincv, icgxconv
       parameter ( iraincv = 1, icgxconv = 1)
       real ffrz
@@ -4249,10 +4918,19 @@ subroutine nssl_2mom_gs   &
       
       double precision dp1
       
-!      real delqnw, delqxw
-!      real :: tindmn = 233, tindmx = 298.0  ! min and max temperatures where inductive charging is allowed
+      real    :: delqnw = -1.0e-10!-1.0e-12 !
+      real    :: delqxw =  1.0e-10! 1.0e-12 !
+      real :: tindmn = 233, tindmx = 298.0  ! min and max temperatures where inductive charging is allowed
+
+      double precision frac, frach, xvfrz
+
+      integer iexy(lc:lqmx,lc:lqmx)
+      integer :: ieswi = 1,  ieswc = 1, ieswr = 0
+      integer :: iehlsw = 1, iehli = 1,  iehlc = 1, iehlr = 0
+      integer :: iehwsw = 1, iehwi = 1,  iehwc = 1, iehwr = 0
       
-      double precision frac
+      double precision :: timevtcalc
+      double precision :: dpt1,dpt2
             
 !      real rar  ! rime accretion rate as calculated from qxacw
 
@@ -4261,28 +4939,21 @@ subroutine nssl_2mom_gs   &
       real vtmax
       integer n,ndfall
       
-!      logical lsavetime  !  flag that it is time to save stuff (open a
-                         !  file and call the save subroutine )
-!      character*80 savename
-!      integer   isaveunit,isaveunit2
-      
-      double precision chgneg,chgpos,sctot
+      double precision chgneg,chgpos
       
       real temgtmp
       integer nx,ny,nz,na,nba,nv
-!      integer ng
       integer nor,norz,istag,jstag,kstag ! ,nht,ngt,igsr
       integer iwrite
       real dtp,dx,dy,dz
-!      real dzc(nz)                         ! 1/dz(k)
       real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
       
+      real qimax,xni0,roqi0
+
 
       real dv
 
       real dtptmp
-!      integer nxl,nyl,nzl
-
       integer itest,nidx,id1,jd1,kd1
       parameter (itest=1)
       parameter (nidx=10)
@@ -4290,47 +4961,21 @@ subroutine nssl_2mom_gs   &
       integer ierr
       integer iend
 
-      integer ix,jy,kz, il, ic, ir, icp1, irp1
+      integer ix,kz, il, ic, ir, icp1, irp1, ip1,jp1,kp1
+      integer :: jy
       integer i,j
       real slope1, slope2
-      real x1, x2
-!      integer nxm,nym,nzm
+      real x1, x2, x3
       real eps,eps2
       parameter (eps=1.e-20,eps2=1.e-5)
 !
-!  electrical permitivity of air C / (N m**2) -  check the units
-!
-      real eperao
-      parameter (eperao  = 8.8592e-12 )
-      
-      real ec,eci  ! fundamental unit of charge
-      parameter (ec = 1.602e-19)
-      parameter (eci = 1.0/ec)
-!
 !  Other elec. vars
 !
       real  temele
       real  trev
-!      parameter (trever=-15.)  ! read it in instead
-
-!
-      
-      
-
-      integer lsc(lc:lhab)
-      integer ln(lc:lhab)
-      integer ipc(lc:lhab)
-      integer lvol(lc:lhab)
-      integer lz(lc:lhab)
-      integer lliq(ls:lhab)
       
       logical ldovol, ishail, ltest
 !
-! temporary arrays-self contained-sizes
-!
-!      integer iex,iey,iez,iemag,ipot
-!      parameter (iex=1,iey=2,iez=3,iemag=4,ipot=5)
-!      integer neelec
 !
 !  wind indicies
 !
@@ -4347,47 +4992,11 @@ subroutine nssl_2mom_gs   &
       parameter (xftem=0.5,yftem=1.)
       parameter (xfqcw=2000.,yfqcw=1.)
       parameter (xfqxw=2000.,yfqxw=1.)
-      
-! moved def of fwm to micro_module
-!      real fwm ! maximum liquid water fraction on precipitating ice 
-!      parameter (fwm=0.5)
-!
-!  charge fallout arrays
-!
-!      real xfall(nx,ny,na) !, xfalltot(nx,ny,na)
-!      real xfall0(nx,ny)
-!      real gt0(-nor+ng1:nx+nor,-nor+ng1:1+nor,-nor+ng1:nz+nor,ngt)
-
-!
-! params read in from inmicro
-!
-!      integer iptemp
-!      parameter ( iptemp = 0 )
-!      integer iptemp0
-
       real dtfac
       parameter ( dtfac = 1.0 )
-
-      
-
-!      real dtrim
-
-      
-
-
-!
-!      integer nsave
-!
       integer ido(lc:lqmx)
-      
-!      integer idocw, idorw, idoci, idoir, idoip, idosw
-!
-!      integer idogl, idogm, idogh, idofw, idohw, idohl
-!
-!      integer iexy(ls:lhab,lc:ls)
-      integer iexy(lc:lqmx,lc:lqmx)
 
-      
+!      integer iexy(lc:lqmx,lc:lqmx)
 !      integer ieswi, ieswir, ieswip, ieswc, ieswr
 !      integer ieglsw, iegli, ieglir, ieglip, ieglc, ieglr
 !      integer iegmsw, iegmi, iegmir, iegmip, iegmc, iegmr
@@ -4400,9 +5009,6 @@ subroutine nssl_2mom_gs   &
 
        real delqnxa(lc:lqmx)
        real delqxxa(lc:lqmx)
-      
-!      real scippmx,scwppmx
-
 !
 ! external temporary arrays
 !
@@ -4424,30 +5030,25 @@ subroutine nssl_2mom_gs   &
       real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz)
       real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,na)
       real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz)
-!      real an(nx,ny,nz,na)
-!      real vn(-nor+1:ny+nor,-norz+ng1:nz+norz,-nor+1:nx+nor,nv)
       real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz)
 
       real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz)
-      
 
 ! 
 !  declarations microphyscs and for gather/scatter
 !
       integer nxmpb,nzmpb,nxz
       integer jgs,mgs,ngs,numgs
-      parameter (ngs=50) !500)
+      parameter (ngs=500) !500)
       integer, parameter :: ngsz = 500
       integer ntt
       parameter (ntt=300)
 
       integer ngscnt,igs(ngs),kgs(ngs)
       integer kgsp(ngs),kgsm(ngs),kgsm2(ngs)
-!      integer nsvcnt
-!      integer isave(ntt)
       integer ncuse
       parameter (ncuse=0)
-      integer il0(ngs),il5(ngs),il2(ngs),il3(ngs),imixedphase
+      integer il0(ngs),il5(ngs),il2(ngs),il3(ngs)
 !      integer il1m(ngs),il2m(ngs),il3m(ngs),il4m(ngs),il5m(ngs)
 !
       real cai,caw,cbi,cbw
@@ -4456,33 +5057,18 @@ subroutine nssl_2mom_gs   &
       real tfr,tfrh
       parameter ( tfr = 273.15, tfrh = 233.15)
       
-      real cp, rd
-      parameter ( cp = 1004.0, rd = 287.04 )
-      
-      real cpi
-      parameter ( cpi = 1./cp )
-      
-      real poo,cap
-      parameter ( cap = rd/cp, poo = 1.0e+05 )
-
-!      real tmxs(ntt),xmxs(ntt),xmns(ntt)
 !
 !  Ice Multiplication Arrays.
 !
       real  fimt1(ngs),fimta(ngs),fimt2(ngs) !,qmul1(ngs),qmul2(ngs)
       real xcwmas
 !
-!  gamma function
-!
-!      integer ngm0,ngm1,ngm2
-!      parameter (ngm0=3000,ngm1=500,ngm2=500)
-!      real gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2)
 !
 ! Variables for Ziegler warm rain microphysics
 !      
 
 
-      real ccnc(ngs)
+      real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs)
       real sscb  ! 'cloud base' SS threshold
       parameter ( sscb = 2.0 )
       integer idecss  ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals
@@ -4494,13 +5080,14 @@ subroutine nssl_2mom_gs   &
       integer ifilt   ! =1 to filter ssat, =0 to set ssfilt=ssat
       parameter ( ifilt = 0 ) 
       real temp1,temp2 ! ,ssold
-      real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit
+      real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor
+      real, parameter :: shedalp = 3.  ! set 3 for maximum mass diameter, 4 for mass-weighted diameter
       real ssmax(ngs)       ! maximum SS experienced by a parcel
       real ssmx
       real dnnet,dqnet
 !      real cnu,rnu,snu,cinu
 !      parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 )
-      real bfnu, bfnu0
+      real bfnu, bfnu0, bfnu1
       parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0)  )
       real ventr, ventc
       real volb, aa1, aa2
@@ -4520,18 +5107,22 @@ subroutine nssl_2mom_gs   &
       real ex1, ft, rhoinv(ngs)
       double precision ec0(ngs)
       
-!      integer kbound
-      real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super
+      real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4 ! , sstdy, super
+      real ratio, delx, dely
+      real dbigg,volt
       real chgtmp,fac
-      real x,y,del,r,rtmp
+      real x,y,del,r,alpr
+      double precision :: vent1,vent2,dprwvent
+      real g1palp
       real fqt !charge separation as fn of temperature from Dong and Hallett 1992
       real bs
       real v1, v2
       real d1r, d1i, d1s, e1i
       real c1sw   ! integration factor for snow melting with snu = -0.8
       real, parameter :: vr1mm = 5.23599e-10 ! volume of 1mm diameter sphere (m**3)
+      real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3   ! volume of a 3 mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS)
       real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 ! volume of 4.5mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS)
-      real vmlt
+      real vmlt,vshd
       real rhosm
       parameter ( rhosm = 500. )
       integer nc ! condensation step
@@ -4539,21 +5130,14 @@ subroutine nssl_2mom_gs   &
       real delta
       integer ltemq1,ltemq1m ! ,ltemq1m2
       real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1   ! temporaries for condensation
-!      real  dtemp2,ss1m2
       real ssi1, ssi2, dqvi, dqvis, dqvii,qis1
       real dqvr, dqc, dqr, dqi, dqs
       real qv1m,qvs1m,ss1m,ssi1m,qis1m
-      real cwmastmp 
+      real cwmastmp
       real  dcloud,dcloud2 ! ,as, bs
-      real cn(ngs) 
-!      real xvc(ngs), xvr(ngs)
+      real cn(ngs)
       double precision xvc, xvr
-!      real xvs(ngs),xvgl(ngs),xvgm(ngs),xvgh(ngs),xvf(ngs)
-!      real xvh(ngs),xvhl(ngs)
       real mwfac
-!      parameter ( mwfac = 6.0**(1./3.) ) 
-!      ! factor for mass-weighted rain volume diameter
-!      real wijk ! wvel
       real  es(ngs) ! ss(ngs),
       real  eis(ngs)
 
@@ -4570,14 +5154,13 @@ subroutine nssl_2mom_gs   &
       
       real, parameter :: rhofrz = 900.   ! density of graupel from newly-frozen rain
       real, parameter :: rimedens = 500. ! default rime density
-      
+
 !      real svc(ngs)  !  droplet volume
 !
 !  contact freezing nucleation
 !
       real raero,kaero !assumd aerosol radius, thermal conductivity
-      parameter ( raero = 3.e-7, kaero = 5.39e-3 ) 
-      
+      parameter ( raero = 3.e-7, kaero = 5.39e-3 )
       real kb   ! Boltzman constant  J K-1
       parameter (kb = 1.3807e-23)
       
@@ -4588,31 +5171,24 @@ subroutine nssl_2mom_gs   &
       
       real ccia(ngs)
       real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs)
-
-!      
+!
 !  misc
 !
       real ni,nr,d0
-      
-
       real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs)
-!      real delqci(ngs) ! ,delqip(ngs)
       real tempc(ngs)
-      real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) ! ,tembzg(ngs)
+      real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) 
       real temgkm1(ngs), temgkm2(ngs)
       real temgx(ngs),temcgx(ngs)
       real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs)
       real elv(ngs),elf(ngs),els(ngs)
       real tsqr(ngs),ssi(ngs),ssw(ngs)
-!      real qcwdif(ngs) ! ,dcwnc
-      real qcwtmp(ngs),qtmp,qtot(ngs) ! ,cwnc(ngs)
+      real qcwtmp(ngs),qtmp,qtot(ngs) 
       real qcond(ngs)
       real ctmp, sctmp
       real cwmasn,cwmasx
       real cwmasn5
       real cwradn
-!      real cinccn(nz)
-!      real cinc(ngs)    !  ,qcitmp(ngs)
       real cimasn,cimasx,ccimx
       real pid4
       real ar,br,cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1
@@ -4624,27 +5200,26 @@ subroutine nssl_2mom_gs   &
       
       real clionpmx,clionnmx
       parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84
-      
-      real cionp(ngs),cionn(ngs),clionp(ngs),clionn(ngs)
 !
 !  other arrays
-!
-      
-      
-      real fwet1(ngs),fwet2(ngs)   !   ,fwet3(ngs)
-      real fmlt1(ngs),fmlt2(ngs)   !   ,fmlt3(ngs)
-      real fvds(ngs),fvce(ngs),fiinit(ngs) ! ,fcinit(ngs)
+
+      real fwet1(ngs),fwet2(ngs)   
+      real fmlt1(ngs),fmlt2(ngs)  
+      real fvds(ngs),fvce(ngs),fiinit(ngs) 
       real fvent(ngs),fraci(ngs),fracl(ngs)
 !
       real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs)
       real felv(ngs),fels(ngs),felf(ngs)
+      real felvcp(ngs),felscp(ngs),felfcp(ngs)
       real felvs(ngs),felss(ngs)      !   ,felfs(ngs)
       real fwvdf(ngs),ftka(ngs),fthdf(ngs)
       real fadvisc(ngs),fakvisc(ngs)
       real fci(ngs),fcw(ngs)
       real fschm(ngs),fpndl(ngs)
       real fgamw(ngs),fgams(ngs)
-      real fcqv1(ngs),fcqv2(ngs),fcc3(ngs)  
+      real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) 
+      
+      real cvm
 !
       real fcci(ngs), fcip(ngs)
 !
@@ -4658,29 +5233,36 @@ subroutine nssl_2mom_gs   &
        real qitmp(ngs)
        
       real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs)
-             
-       real :: qx(ngs,lv:lhab)
-       real :: qxw(ngs,ls:lhab)
-       real :: cx(ngs,lc:lhab)
-       real :: cxmxd(ngs,lc:lhab)
-       real :: qxmxd(ngs,lv:lhab)
-       real :: scx(ngs,lc:lhab)
-       real :: xv(ngs,lc:lhab)
-!       real :: xsfca(ngs,lc:lhab)
-       real :: vtxbar(ngs,lc:lhab,3)
-       real :: xmas(ngs,lc:lhab)
-       real :: xdn(ngs,lc:lhab)
-       real :: xdia(ngs,lc:lhab,3)
-       real :: rarx(ngs,ls:lhab)
-       real :: vx(ngs,li:lhab)
-       real :: rimdn(ngs,li:lhab)
-       real :: raindn(ngs,li:lhab)
-       real :: alpha(ngs,lr:lhab)
-       real :: dab0lh(ngs,lc:lhab,lr:lhab)
-       real :: dab1lh(ngs,lc:lhab,lr:lhab)
-       real :: zx(ngs,lr:lhab)
-       real :: zxmxd(ngs,lr:lhab)
-       real :: g1x(ngs,lr:lhab)
+      real vt2ave(ngs)
+
+      real ::  qx(ngs,lv:lhab)
+      real ::  qxw(ngs,ls:lhab)
+      real ::  cx(ngs,lc:lhab)
+      real ::  cxmxd(ngs,lc:lhab)
+      real ::  qxmxd(ngs,lv:lhab)
+      real ::  scx(ngs,lc:lhab)
+      real ::  xv(ngs,lc:lhab)
+!      real ::  xsfca(ngs,lc:lhab)
+      real ::  vtxbar(ngs,lc:lhab,3)
+      real ::  xmas(ngs,lc:lhab)
+      real ::  xdn(ngs,lc:lhab)
+      real ::  xdia(ngs,lc:lhab,3)
+      real ::  rarx(ngs,ls:lhab)
+      real ::  vx(ngs,li:lhab)
+      real ::  rimdn(ngs,li:lhab)
+      real ::  raindn(ngs,li:lhab)
+      real ::  alpha(ngs,lr:lhab)
+      real ::  dab0lh(ngs,lc:lhab,lr:lhab)
+      real ::  dab1lh(ngs,lc:lhab,lr:lhab)
+      
+      
+      real, parameter :: alpharaut = 0.0 ! MY2005 for autoconversion
+      real, parameter :: galpharaut = (6.+alpharaut)* &
+     &                                (5.+alpharaut)* &
+     &                                (4.+alpharaut)/ &
+     &                               ((3.+alpharaut)* &
+     &                                (2.+alpharaut)* &
+     &                                (1.+alpharaut))
       
       real ventrx(ngs)
       real ventrxn(ngs)
@@ -4710,8 +5292,8 @@ subroutine nssl_2mom_gs   &
 
 !
 !
-      real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs) ! ,cfmul1(ngs)
-      real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs) ! ,qfmul1(ngs)
+      real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs)
+      real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs)
       
       real csplinter(ngs),qsplinter(ngs)
       real csplinter2(ngs),qsplinter2(ngs)
@@ -4719,52 +5301,44 @@ subroutine nssl_2mom_gs   &
 !
 !  concentration arrays...
 !
-!
-
       real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs)
       real cracif(ngs), ciacrf(ngs)
       real cracr(ngs)
 
 !
       real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs)
-
-      real cicint(ngs)  !  , ciracir(ngs), ciaci(ngs)
-      real cipint(ngs) !, cipacwi(ngs)
-!
-      real ciacw(ngs), cwacii(ngs) ! , cwaci(ngs)
+      real cicint(ngs)
+      real cipint(ngs)
+      real ciacw(ngs), cwacii(ngs) 
       real ciacr(ngs), craci(ngs)
-!
-      real csacw(ngs) !,   cwacs(ngs)
-      real csacr(ngs) ! ,   cracs(ngs)
+      real csacw(ngs)
+      real csacr(ngs)
       real csaci(ngs),   csacs(ngs)
-!
-!
-      real cracw(ngs) ! ,cwacr(ngs)
+      real cracw(ngs) 
       real chacw(ngs), chacr(ngs)
       real :: chlacw(ngs) ! = 0.0
       real chaci(ngs), chacs(ngs)
 !
       real :: chlacr(ngs)
       real :: chlaci(ngs), chlacs(ngs)
-
-      real crcnw(ngs) ! ,ciacwi(ngs)
+      real crcnw(ngs) 
       real cidpv(ngs),cisbv(ngs)
       real cimlr(ngs)
 
       real chlsbv(ngs), chldpv(ngs)
-      real chlmlr(ngs), chlmlrr(ngs) ! ,chlcev(ngs),chldsv(ngs)
+      real chlmlr(ngs), chlmlrr(ngs) 
       real chlshr(ngs), chlshrr(ngs)
 
-      real chdpv(ngs),chsbv(ngs) ! chcnv(ngs),chevv(ngs),
-      real chmlr(ngs),chcev(ngs) !,chdsv(ngs)
+      real chdpv(ngs),chsbv(ngs)
+      real chmlr(ngs),chcev(ngs)
       real chmlrr(ngs)
       real chshr(ngs), chshrr(ngs)
 
-      real csdpv(ngs),cssbv(ngs) ! cscnv(ngs),csevv(ngs),
-      real csmlr(ngs),cscev(ngs) !,csdsv(ngs)
-      real csshr(ngs) ! cswet(ngs),csdry(ngs),
+      real csdpv(ngs),cssbv(ngs)
+      real csmlr(ngs),cscev(ngs)
+      real csshr(ngs)
 
-      real crcev(ngs) ! ,crmlr(ngs)
+      real crcev(ngs)
       real crshr(ngs)
 !
 !
@@ -4790,38 +5364,27 @@ subroutine nssl_2mom_gs   &
 !
 !  arrays for x-ac-r and r-ac-x; 
 !
-!      real qfacr(ngs) ! ,qracf(ngs)
-!      real qaacr(ngs),qraca(ngs)
       real qsacr(ngs),qracs(ngs)
       real qhacr(ngs) ! ,qrach(ngs)
-      real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs)
+      real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs)
       real qiacr(ngs),qraci(ngs)
       
       real ziacr(ngs)
 
-      real qracif(ngs),qiacrf(ngs)
+      real qracif(ngs),qiacrf(ngs),qiacrs(ngs)
 
       real :: qhlacr(ngs) ! = 0.0
-
-!
       real qsacrs(ngs) !,qracss(ngs)
 !
 !  ice - ice interactions
 !
       real qsaci(ngs)
-
-!
-
       real qhaci(ngs)
-
       real qhacs(ngs)
 
       real :: qhlaci(ngs) ! = 0.0
-
       real :: qhlacs(ngs) ! = 0.0
 !
-!
-!
 !  conversions
 !
       real qrfrz(ngs) ! , qirirhr(ngs)
@@ -4831,6 +5394,8 @@ subroutine nssl_2mom_gs   &
       real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs)
       real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs)
       real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs)
+      real zhwdn(ngs) ! change in Z due to density changes
+      real zhldn(ngs) ! change in Z due to density changes
 
       real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs)
       real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs)
@@ -4850,16 +5415,11 @@ subroutine nssl_2mom_gs   &
       real cipiphr(ngs), qipiphr(ngs)
       real qscni(ngs), cscni(ngs), cscnis(ngs)
       real qscnvi(ngs), cscnvi(ngs), cscnvis(ngs)
-!      real qscnir(ngs),cscnir(ngs)
-!      real qscnip(ngs),cscnip(ngs)
-!      real qscnx(ngs,nhab)
       real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs)
       real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs)
       real qiint(ngs),qipipnt(ngs),qicicnt(ngs)
-!      real qsfw(ngs),qsfi(ngs)
-!      real timflg(ngs)
-!      real ssifac(ngs)
       real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs)
+      real tke(ngs)
       real uvel(ngs),vvel(ngs)
 !
       real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs),
@@ -4874,7 +5434,6 @@ subroutine nssl_2mom_gs   &
       real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs),
       real :: qhlmlr(ngs), qhldsv(ngs) 
       real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) 
-!      real :: qhlshrp(ngs)
 !
       real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs)
 !
@@ -4905,58 +5464,46 @@ subroutine nssl_2mom_gs   &
       real qsfzs(ngs)
 !
 !
-      real qipdpv(ngs),qipsbv(ngs) ! qipcnv(ngs),qipevv(ngs),
-      real qipmlr(ngs),qipdsv(ngs) ! ,qipcev(ngs)
-!      real qipshr(ngs) ! qipwet(ngs),qipdry(ngs),
-!      real qipshrp(ngs)
+      real qipdpv(ngs),qipsbv(ngs)
+      real qipmlr(ngs),qipdsv(ngs)
 !
-      real qirdpv(ngs),qirsbv(ngs) ! qircnv(ngs),qirevv(ngs),
-      real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs)  ! ,qircev(ngs)
-!      real qirshr(ngs) ! qirwet(ngs),qirdry(ngs),
-!      real qirshrp(ngs)
+      real qirdpv(ngs),qirsbv(ngs)
+      real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs)
 !
-      real qgldpv(ngs),qglsbv(ngs) ! qglcnv(ngs),qglevv(ngs),
-      real qglmlr(ngs),qgldsv(ngs) ! ,qglcev(ngs)
+      real qgldpv(ngs),qglsbv(ngs)
+      real qglmlr(ngs),qgldsv(ngs)
       real qglwet(ngs),qgldry(ngs),qglshr(ngs)
       real qglshrp(ngs)
 !
-      real qgmdpv(ngs),qgmsbv(ngs) ! qgmcnv(ngs),qgmevv(ngs),
-      real qgmmlr(ngs),qgmdsv(ngs) ! ,qgmcev(ngs)
+      real qgmdpv(ngs),qgmsbv(ngs)
+      real qgmmlr(ngs),qgmdsv(ngs)
       real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs)
       real qgmshrp(ngs)
-!
-      real qghdpv(ngs),qghsbv(ngs) ! qghcnv(ngs),qghevv(ngs),
-      real qghmlr(ngs),qghdsv(ngs) ! ,qghcev(ngs)
+      real qghdpv(ngs),qghsbv(ngs)
+      real qghmlr(ngs),qghdsv(ngs) 
       real qghwet(ngs),qghdry(ngs),qghshr(ngs)
       real qghshrp(ngs)
 !
       real qrztot(ngs),qrzmax(ngs),qrzfac(ngs)
       real qrcev(ngs)
       real qrshr(ngs)
-!
-!      real ffglwg(ngs),ffgmwg(ngs),ffghwg(ngs),ffswwg(ngs)
-!      real ffhwwg(ngs),ffagwg(ngs),fffwwg(ngs),ffciwg(ngs)
-
       real fsw(ngs),fhw(ngs),fhlw(ngs) !liquid water fractions
-
-      real qhcnf(ngs) ! ,qhcnhl(ngs),qhlcnhx(ngs)
-      real :: qhlcnh(ngs) ! = 0.0 
+      real qhcnf(ngs) 
+      real :: qhlcnh(ngs) ! = 0.0
       real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs)
       
       real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel
-!
-!      real exwidia(nhab),exwwdia(nhab)
 
-      real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs) ! eww(ngs),
+      real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs)
       real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs)
-      real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) ! eaw(ngs),
+      real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs)
       real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs)
-      real ehxr(ngs),ehlr(ngs),egmr(ngs) ! ,eipr(ngs),ear(ngs)
+      real ehxr(ngs),ehlr(ngs),egmr(ngs) 
       real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs)
-      real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs) ! eai(ngs),
+      real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs) 
       real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs)
       real ehscnv(ngs)
-      real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) ! eas(ngs),
+      real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) 
 
       real ew(8,6)
       real cwr(8,2)  ! radius and inverse of interval
@@ -4975,24 +5522,18 @@ subroutine nssl_2mom_gs   &
      &         0.17, 0.40, 0.54, 0.71, 0.83, 0.88, 0.94, 0.98,  & ! 600
      &         0.15, 0.37, 0.52, 0.74, 0.82, 0.88, 0.94, 0.98 / ! 1000
 !     :         0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400
-      
-      
+
+
+      real da0lr(ngs)
       real da0lh(ngs)
       real da0lhl(ngs)
-      
+
 
 
       real va0 (lc:lqmx)          ! collection coefficients from Seifert 2005
       real vab0(lc:lqmx,lc:lqmx)  ! collection coefficients from Seifert 2005
       real vab1(lc:lqmx,lc:lqmx)  ! collection coefficients from Seifert 2005
       real va1 (lc:lqmx)          ! collection coefficients from Seifert 2005
-
-!      save va0, vab0, vab1, va1
-      
-!      real alpha(lc:lqmx) ! shape parameter
-      
-!      save alpha
-      
       real ehip(ngs),ehlip(ngs),ehlir(ngs)
       real erir(ngs),esir(ngs),eglir(ngs),egmir(ngs),eghir(ngs)
       real efir(ngs),ehir(ngs),eirw(ngs),eirir(ngs),ehr(ngs)
@@ -5001,8 +5542,7 @@ subroutine nssl_2mom_gs   &
 !
 !  arrays for production terms
 !
-      real ptotal(ngs) ! , pqtot(ngs) 
-     
+      real ptotal(ngs) ! , pqtot(ngs)
 !
       real pqcwi(ngs),pqcii(ngs),pqrwi(ngs)
       real pqswi(ngs),pqhwi(ngs),pqwvi(ngs)
@@ -5046,8 +5586,6 @@ subroutine nssl_2mom_gs   &
 !
 !  other arrays
 !
-!
-!      real wvdf(ngs),tka(ngs) !,akvisc(ngs),ci(ngs),cw(ngs),thdf(ngs)
       real dqisdt(ngs) !,advisc(ngs) !dqwsdt(ngs), ,schm(ngs),pndl(ngs)
 
       real qss0(ngs)
@@ -5061,25 +5599,15 @@ subroutine nssl_2mom_gs   &
       real rhovt(ngs)
       real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs)
       real thsave(ngs)
-!      real pceds(ngs) ! ,ppceds(ngs),pmceds(ngs)
-!      real qwfzi(ngs) ! ,qimlw(ngs)
       real ptwfzi(ngs),ptimlw(ngs)
       real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs)
       
       real cnostmp(ngs)   ! for diagnosed snow intercept
-      
-!      real fload(ngs)
-!      character*80 filnam
-!      character*15 rrshcm
-!      character*2  headr1
-!      character*5  rstime
-!      character*6  rstime
-!      character*2  nmliter
 !
 !  iholef = 1 to do hole filling technique version 1
 !  which uses all hydrometerors to do hole filling of all hydrometeors
 !  iholef = 2 to do hole filling technique version 2
-!  which uses an individual hydrometeror species to do hole 
+!  which uses an individual hydrometeror species to do hole
 !  filling of a species of a hydrometeor
 !
 !  iholen = interval that hole filling is done
@@ -5107,7 +5635,6 @@ subroutine nssl_2mom_gs   &
       real  cvtotp
       real  cftotp
       real  chltotp
-!      real  chxtotp
       real  cgltotp
       real  cgmtotp
       real  cghtotp
@@ -5128,29 +5655,23 @@ subroutine nssl_2mom_gs   &
 !
 !   Miscellaneous variables
 !
-      integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh ! ,ltim,ltem,lqcw,lqfw
-      integer lqrw 
+      integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh 
+      integer lqrw
       real vt
-      real arg  ! gamma is a function  
+      real arg  ! gamma is a function
       real erbnd1, fdgt1, costhe1
       real qeps
-      real dyi2,dzi2,cp608,cv,bta1,cnit,dragh,dnz00,rho00,pii
+      real dyi2,dzi2,cp608,bta1,cnit,dragh,dnz00,rho00,pii
       real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds,gr
 
-!      real cnoi,cnoip,cnoir,cnor,cnos,cnogl,cnogm,cnogh,cnof,cnoh
-!      real cnohl,
-!      real rwdnmx,cwdnmx,cidnmx,xidnmx,swdnmx,gldnmx,gmdnmx
-!      real cirdn0, cwdn0, rwdn0, swdn0, gldn0
-!      real gmdn0, ghdn0, fwdn0, hwdn0, hldn0
       
       real xdn0(lc:lhab)
+      real xdn_new,drhodt
       
-!      real ghdnmx,fwdnmx,hwdnmx,hldnmx,rwdnmn,cwdnmn,xidnmn,cidnmn
-!      real swdnmn,gldnmn,gmdnmn,ghdnmn,fwdnmn
-      integer l ,ltemq,inumgs, idelq ! , ib
-!      real hwdnmn,hldnmn,
-      real c1f3,brz,arz,rw,temq ! ,cmn,cmi40,cmi50
-!      real ri50,vti50,bsfw,cm50a,a,cm40b,cm50b
+      integer l ,ltemq,inumgs, idelq
+
+      real c1f3,brz,arz,rw,temq
+
       real ssival,tqvcon
       real cdx(lc:lhab)
       real cnox
@@ -5162,13 +5683,11 @@ subroutine nssl_2mom_gs   &
       real cirventb
       integer igmrwa,igmrwb,igmswa, igmswb,igmfwa,igmfwb,igmhwa,igmhwb
       real rwventa ,rwventb,swventa,swventb,fwventa,fwventb,fwventc
-      real hwventa,hwventb 
-      
+      real hwventa,hwventb
       real    hwventc, hlventa, hlventb,  hlventc
-      real  glventa, glventb, glventc 
-      real   gmventa, gmventb,  gmventc, ghventa, ghventb, ghventc 
-
-      real  dzfacp,  dzfacm,  cmassin,  cwdiar ! , cwmasr
+      real  glventa, glventb, glventc
+      real   gmventa, gmventb,  gmventc, ghventa, ghventb, ghventc
+      real  dzfacp,  dzfacm,  cmassin,  cwdiar 
       real  rimmas, rhobar
       real   argtim, argqcw, argqxw, argtem
       real   frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1
@@ -5179,10 +5698,10 @@ subroutine nssl_2mom_gs   &
       real   frcswrsw, frcswrgl,  frcswrgm,  frcswrgh, frcswrfw
       real   frcswrsw1
       real   frcrswsw, frcrswgl, frcrswgm, frcrswgh, frcrswfw
-      real  frcrswsw1 
+      real  frcrswsw1
       real  frcglrgl, frcglrgm, frcglrgh,  frcglrfw, frcglrgl1
-      real  frcrglgl  
-      real  frcrglgm,  frcrglgh, frcrglfw, frcrglgl1  
+      real  frcrglgl
+      real  frcrglgm,  frcrglgh, frcrglfw, frcrglgl1
       real  frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw,  frcgmrgm1
       real  frcrgmgl, frcrgmgm,  frcrgmgh, frcrgmfw, frcrgmgm1
       real  sum,  qweps,  gf2a, gf4a, dqldt, dqidt, dqdt
@@ -5190,13 +5709,13 @@ subroutine nssl_2mom_gs   &
       real frcrghgm, frcrghgh,  frcrghfw, frcrghgh1
       real    a1,a2,a3,a4,a5,a6
       real   gamss
-      real cdw, cdi, denom1, denom2, delqci1, delqip1 ! , dtz1, dtz2
+      real cdw, cdi, denom1, denom2, delqci1, delqip1
       real cirtotn,  ciptotn, cgmtotn, chltotn,  cirtotp
       real  cgmfac, chlfac,  cirfac
       integer igmhla, igmhlb, igmgla, igmglb, igmgma,  igmgmb
       integer igmgha, igmghb
-      integer idqis, item, itim0 ! ,  itim
-      integer  iqgl, iqgm, iqgh, iqrw, iqsw ! ,iqcw, iqfw
+      integer idqis, item, itim0 
+      integer  iqgl, iqgm, iqgh, iqrw, iqsw 
       integer  itertd, ia
       
       real tau, ewtmp
@@ -5205,6 +5724,8 @@ subroutine nssl_2mom_gs   &
       real     q_noliqmn, q_noliqmx
       real     scsacimn, scsacimx
       
+      double precision :: dtpinv
+      
 !   arrays for temporary bin space
 
       integer nbin
@@ -5217,9 +5738,11 @@ subroutine nssl_2mom_gs   &
 !       parameter ( hjo = 0.8*7.5*nbin/(41.) )
        parameter (hmmin = 1.e-11, hjo = 0.8*7.5 )
  
-       integer itile,jtile,ktile
+      integer itile,jtile,ktile
       integer ixend,jyend,kzend,kzbeg
       integer nxend,nyend,nzend,nzbeg
+      
+      real :: qaacw ! combined qsacw-qhacw for WSM6 variation
 
 
 !
@@ -5228,6 +5751,24 @@ subroutine nssl_2mom_gs   &
 !  Start routine
 !
 ! ####################################################################
+
+
+
+      iexy(:,:)=0; ! sets to zero the ones Imight have forgotten
+
+!     snow
+      iexy(ls,li) = ieswi
+      iexy(ls,lc) = ieswc ; iexy(ls,lr) = ieswr ;
+
+!     graupel
+      iexy(lh,ls)  = iehwsw ; iexy(lh,li) = iehwi ;
+      iexy(lh,lc) = iehwc ; iexy(lh,lr)  = iehwr ;
+
+!     hail
+      IF (lhl .gt. 1 ) THEN
+      iexy(lhl,ls)  = iehlsw ; iexy(lhl,li) = iehli ;
+      iexy(lhl,lc) = iehlc ; iexy(lhl,lr)  = iehlr ;
+      ENDIF
 !
 
       itile = nx
@@ -5241,36 +5782,32 @@ subroutine nssl_2mom_gs   &
       nzend = nz
       kzbeg = 1
       nzbeg = 1
-      
+
       istag = 0
       jstag = 0
       kstag = 1
 
-      imixedphase = 0
-      IF ( mixedphase ) imixedphase = 1
-
-
 !
 !  slope intercepts
 !
-      
+
       IF ( ngs .lt. nz ) THEN
 !       write(0,*) 'Error in ICEZVD: Must have ngs .ge. nz!'
 !       STOP
       ENDIF
-      
+
       cntnic_noliq = 0
       q_noliqmn = 0.0
       q_noliqmx = 0.0
       scsacimn = 0.0
       scsacimx = 0.0
-      
+
       ldovol = .false.
-      
+
       DO il = lc,lhab
         ldovol = ldovol .or. ( lvol(il) .gt. 1 )
       ENDDO
-      
+
 
 !      DO il = lc,lhab
 !        write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il)
@@ -5285,7 +5822,7 @@ subroutine nssl_2mom_gs   &
 !    also set drag coefficients
 !
 
-      
+      dtpinv = 1.d0/dtp
 
 !
 
@@ -5308,7 +5845,6 @@ subroutine nssl_2mom_gs   &
       cbw = 35.86
 
       cp608 = 0.608
-      cv = 717.0
       ar = 841.99666  
       br = 0.8
       aradcw = -0.27544
@@ -5361,8 +5897,11 @@ subroutine nssl_2mom_gs   &
       cbi = 7.66
       cbw = 35.86
       
+      bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/((1. + alphar)*(2. + alphar)*(3. + alphar))
+      
       vfrz = 0.523599*(dfrz)**3 
-      vmlt = 0.523599*(dmlt)**3 
+      vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 )
+      vshd = Min(xvmx(lr), 0.523599*(dshd)**3 )
 
       
 
@@ -5395,11 +5934,11 @@ subroutine nssl_2mom_gs   &
 !
 !  ci constants in mks units
 !
-      cimasn = 6.88e-13 ! 12 microns for  0.1871*(xmas(mgs,li)**(0.3429))
+      cimasn = Min(cimas0, 6.88e-13) ! 12 microns for  0.1871*(xmas(mgs,li)**(0.3429))
       cimasx = 1.0e-8   ! 338 microns
       ccimx = 5000.0e3   ! max of 5000 per liter
 
-! 
+!
 !  constants for paramerization
 !
 !
@@ -5407,11 +5946,11 @@ subroutine nssl_2mom_gs   &
 !
 !      nsvcnt = 0
       iend = 0
-      
+
 !      timetd1 = etime(tarray)
 !      timetd1 = tarray(1)
 
-! 
+!
 !$     ndebug = -1
 ! cmic$  cncall
 !***********************************************************
@@ -5432,29 +5971,29 @@ subroutine nssl_2mom_gs   &
          ENDDO
         ENDDO
       ENDIF
-
+      
 !
 !..Gather microphysics  
 !
-      if ( ndebug .gt. 0 ) print*,'ICEZVD_GS: ENTER GATHER STAGE'
-      
-      
+      if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE'
+
+
       nxmpb = 1
       nzmpb = 1
       nxz = nx*nz
       numgs = nxz/ngs + 1
 !      write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE: nx,nz,nxz,numgs,ngs = ',nx,nz,nxz,numgs,ngs
-      
+
       do 1000 inumgs = 1,numgs
       ngscnt = 0
       
-      do kz = nzmpb,nz-kstag-1 
+      do kz = nzmpb,nz
       do ix = nxmpb,nx
 
       pqs(1) = t00(ix,jy,kz)
 !      pqs(kz) = t00(ix,jy,kz)
 
-      theta(1) = an(ix,jy,kz,lt) 
+      theta(1) = an(ix,jy,kz,lt)
       temg(1) = t0(ix,jy,kz)
       temcg(1) = temg(1) - tfr
       tqvcon = temg(1)-cbw
@@ -5464,13 +6003,13 @@ subroutine nssl_2mom_gs   &
       qis(1) = pqs(1)*tabqis(ltemq)
 
       qss(1) = qvs(1)
-      
+
 !      IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN
 !       write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz)
 !      ENDIF
-      
+
       if ( temg(1) .lt. tfr ) then
-!      if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) 
+!      if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
 !     >  qss(kz) = qis(kz)
 !      if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
 !     >   qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) /
@@ -5508,6 +6047,7 @@ subroutine nssl_2mom_gs   &
 
       if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5'
 
+!      write(0,*) 'allocating qc
 
       
       xv(:,:) = 0.0
@@ -5517,6 +6057,7 @@ subroutine nssl_2mom_gs   &
       xdia(:,:,:) = 0.0
       raindn(:,:) = 900.
       cx(:,:) = 0.0
+      alpha(:,:) = 0.0
       DO il = li,lhab
         DO mgs = 1,ngscnt
           rimdn(mgs,il)  = rimedens ! xdn0(il)
@@ -5529,11 +6070,11 @@ subroutine nssl_2mom_gs   &
       kgsm(mgs) = max(kgs(mgs)-1,1)
       kgsm2(mgs) = Max(kgs(mgs)-2,1)
       kgsp(mgs) = min(kgs(mgs)+1,nz-1)
-      theta0(mgs) = 0.0 
+      theta0(mgs) = 0.0
       thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs)
       theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt)
       qv0(mgs) = 0.0
-      qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv)  - qv0(mgs)
+      qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv)  - qv0(mgs) ! qv0(mgs) is zero, so qwvp is the FULL qv!
 
       pres(mgs) = pn(igs(mgs),jy,kgs(mgs))
       rho0(mgs) = dn(igs(mgs),jy,kgs(mgs))
@@ -5556,10 +6097,17 @@ subroutine nssl_2mom_gs   &
       cnostmp(mgs) = cno(ls)
 !
       il5(mgs) = 0
-      if ( temg(mgs) .lt. tfr ) then 
+      if ( temg(mgs) .lt. tfr ) then
       il5(mgs) = 1
       end if
       enddo !mgs
+      
+      IF ( ipconc < 1 .and. lwsm6 ) THEN
+        DO mgs = 1,ngscnt
+          tmp = Min( 0.0, temcg(mgs) )
+          cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) )
+        ENDDO
+      ENDIF
 
 
 !
@@ -5580,14 +6128,19 @@ subroutine nssl_2mom_gs   &
       qxw(:,:) = 0.0
 
 
-
+        scx(:,:) = 0.0
 !
 !  set shape parameters
 !
+      IF ( imurain == 1 ) THEN
+        alpha(:,lr) = alphar
+      ELSEIF ( imurain == 3 ) THEN
+        alpha(:,lr) = xnu(lr)
+      ENDIF
+
       DO il = lc,lhab
       do mgs = 1,ngscnt
         IF ( il .ge. lg ) alpha(mgs,il) = dnu(il)
-        IF ( il == lr ) alpha(mgs,il) = xnu(lr)
         DO ic = lr,lhab
         dab0lh(mgs,il,ic) = dab0(ic,il)
         dab1lh(mgs,il,ic) = dab1(ic,il)
@@ -5598,6 +6151,7 @@ subroutine nssl_2mom_gs   &
       
 !      DO mgs = 1,ngscnt
         da0lh(:) = da0(lh)
+        da0lr(:) = da0(lr)
         IF ( lzh < 1 .or. lzhl < 1 ) THEN
           rzxhlh(:) = rzhl/rz
         ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN
@@ -5625,12 +6179,20 @@ subroutine nssl_2mom_gs   &
 !  set concentrations
 !
 !      ssmax = 0.0
-      
-      
-      
+
+
+
       if ( ipconc .ge. 1 ) then
        do mgs = 1,ngscnt
         cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
+        IF ( lcina .gt. 1 ) THEN
+         cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina)
+        ELSE
+         cina(mgs) = cx(mgs,li)
+        ENDIF
+        IF ( lcin > 1 ) THEN
+         ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin)
+        ENDIF
         IF ( qx(mgs,li) .le. qxmin(li) .or. cx(mgs,li) .le. 0.0 ) THEN
           cx(mgs,li) = 0.0
           an(igs(mgs),jy,kgs(mgs),lni) = 0.0
@@ -5677,7 +6239,7 @@ subroutine nssl_2mom_gs   &
          STOP
        ENDIF
         ENDIF
-        
+
        end do
       end if
       if ( ipconc .ge. 4 ) then
@@ -5717,7 +6279,7 @@ subroutine nssl_2mom_gs   &
           qx(mgs,lh) = 0.0
         ENDIF
         IF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN
-          qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) 
+          qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh)
           qx(mgs,lh) = 0.0
         ELSE
           cx(mgs,lh) = Max( 1.e-9, cx(mgs,lh) )
@@ -5744,7 +6306,7 @@ subroutine nssl_2mom_gs   &
           qx(mgs,lhl) = 0.0
         ENDIF
         IF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN
-          qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) 
+          qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl)
           qx(mgs,lhl) = 0.0
         ELSE
           cx(mgs,lhl) = Max( 1.e-9, cx(mgs,lhl) )
@@ -5764,21 +6326,21 @@ subroutine nssl_2mom_gs   &
 ! Set mean particle volume
 !
       IF ( ldovol ) THEN
-      
+
       vx(:,:) = 0.0
-      
+
        DO il = li,lhab
-        
+
         IF ( lvol(il) .ge. 1 ) THEN
-        
+
           DO mgs = 1,ngscnt
             vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0)
           ENDDO
-          
+
         ENDIF
-      
+
        ENDDO
-      
+
       ENDIF
 
 
@@ -5810,13 +6372,27 @@ subroutine nssl_2mom_gs   &
 !
       felvs(mgs) = felv(mgs)*felv(mgs)
       felss(mgs) = fels(mgs)*fels(mgs)
+      
+        IF ( eqtset <= 1 ) THEN
+          felvcp(mgs) = felv(mgs)*cpi
+          felscp(mgs) = fels(mgs)*cpi
+          felfcp(mgs) = felf(mgs)*cpi
+        ELSE
+          tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh)
+          IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl)
+          cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr))   &
+                                  +cpigb*(tmp)
+          felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm
+          felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm
+          felfcp(mgs) = felf(mgs)/cvm
+        ENDIF
 !
-      fgamw(mgs) = felv(mgs)*cpi/pi0(mgs)
-      fgams(mgs) = fels(mgs)*cpi/pi0(mgs)
+      fgamw(mgs) = felvcp(mgs)/pi0(mgs)
+      fgams(mgs) = felscp(mgs)/pi0(mgs)
 !
       fcqv1(mgs) = 4098.0258*pi0(mgs)*fgamw(mgs)
       fcqv2(mgs) = 5807.6953*pi0(mgs)*fgams(mgs)
-      fcc3(mgs) = cpi*felf(mgs)/pi0(mgs)
+      fcc3(mgs) = felfcp(mgs)/pi0(mgs)
 !
 !  fwvdf = water vapor diffusivity
       fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)*(101325.0/(pres(mgs)))
@@ -5856,7 +6432,7 @@ subroutine nssl_2mom_gs   &
       fav(mgs) = (felv(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2)
       fbv(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qvs(mgs)))
 !
-      end do       
+      end do
 !
 !
 !   ice habit fractions
@@ -5865,7 +6441,7 @@ subroutine nssl_2mom_gs   &
 !
 !  Set density
 !
-      if (ndebug .gt. 0 ) print*,'ICEZVD_GS: Set density'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set density'
 !
 
       do mgs = 1,ngscnt
@@ -5882,7 +6458,7 @@ subroutine nssl_2mom_gs   &
 
         IF ( lvol(lh) .gt. 1 ) THEN
          IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN
-           IF ( mixedphase ) THEN 
+           IF ( mixedphase ) THEN
            ELSE
              dnmx = xdnmx(lh)
            ENDIF
@@ -5898,7 +6474,7 @@ subroutine nssl_2mom_gs   &
           IF ( lvol(lhl) .gt. 1 ) THEN
            IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN
 
-           IF ( mixedphase .and. lhlw > 1 ) THEN 
+           IF ( mixedphase .and. lhlw > 1 ) THEN
            ELSE
              dnmx = xdnmx(lhl)
            ENDIF
@@ -5907,7 +6483,7 @@ subroutine nssl_2mom_gs   &
              vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
            ENDIF
           ENDIF
-        
+
         ENDIF
 
 ! adjust density for wet snow and graupel (Ferrier 94)
@@ -5920,7 +6496,7 @@ subroutine nssl_2mom_gs   &
             IF(fsw(mgs) .eq. 1.) xdn(mgs,ls) = rho_qr   ! fsw = 1 means it's liquid water, yo!
            ENDIF
           ENDIF
-          
+
           IF (qhdenmod) THEN
 !          IF(fhw(mgs) .gt. 0.01) THEN
 !           IF(fhw(mgs) .lt. 1.) xdn(mgs,lh) = rho_qh / (1. - fhw(mgs))       !Ferrier: 400./(1.-fsw(mgs))
@@ -5936,7 +6512,8 @@ subroutine nssl_2mom_gs   &
 !  set some values for ice nucleation
 !
       do mgs = 1,ngscnt
-      wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)+1)   &
+      kp1 = Min(nz, kgs(mgs)+1 )
+      wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1)   &
      &                  +w(igs(mgs),jgs,kgs(mgs)))
       wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs))   &
      &                  +w(igs(mgs),jgs,Max(1,kgs(mgs)-1)))
@@ -5960,18 +6537,34 @@ subroutine nssl_2mom_gs   &
 !     &                 cwmasn,cwmasx,cwradn,cnina,cimna,cimxa,      &
 !     &                 itype1a,itype2a,temcg,infdo,alpha)
 
+
       call setvtz(ngscnt,ngs,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp,   &
      &                 xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,   &
      &                 ipconc,ndebug,ngs,nz,kgs,fadvisc,   &
      &                 cwmasn,cwmasx,cwradn,cnina,cimn,cimx,   &
      &                 itype1,itype2,temcg,0,alpha,0)
 
-      
+
+       IF ( lwsm6 .and. ipconc == 0 ) THEN
+         tmp = Max(qxmin(lh), qxmin(ls))
+         DO mgs = 1,ngscnt
+           sum = qx(mgs,lh) + qx(mgs,ls)
+           IF ( sum > tmp ) THEN
+             vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum
+           ELSE
+             vt2ave(mgs) = 0.0
+           ENDIF
+         ENDDO
+       ENDIF
+
 
 !
 !  Set number concentrations (need xdia from setvt)
 !
-      if ( ndebug .gt. 0 ) print*,'ICEZVD_GS: Set concentration'
+      if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration'
+      IF ( ipconc .lt. 1 ) THEN
+         cina(1:ngscnt) = cx(1:ngscnt,li)
+      ENDIF
       if ( ipconc .lt. 5 ) then
       do mgs = 1,ngscnt
 
@@ -5993,7 +6586,7 @@ subroutine nssl_2mom_gs   &
       end if
       ENDIF ! ( ipconc .lt. 4 )
 
-      IF ( ipconc .lt. 5 ) THEN 
+      IF ( ipconc .lt. 5 ) THEN
 
 
 !      cx(mgs,lh) = 0.0
@@ -6007,7 +6600,7 @@ subroutine nssl_2mom_gs   &
 
       end do
       end if
-      
+
       IF ( ipconc .ge. 2 ) THEN
       DO mgs = 1,ngscnt
         rb(mgs) = 0.5*xdia(mgs,lc,1)*((1./(1.+cnu)))**(1./6.)
@@ -6026,10 +6619,10 @@ subroutine nssl_2mom_gs   &
         ENDIF
       ENDDO
       ENDIF
-      
+
+!
 !
 !
-!              
 !
 !  maximum depletion tendency by any one source
 !
@@ -6062,7 +6655,7 @@ subroutine nssl_2mom_gs   &
       endif
 
       do mgs = 1,ngscnt
-!  
+!
       if ( qx(mgs,lc) .le. qxmin(lc) ) then
       ccmxd(mgs)  = 0.20*cx(mgs,lc)/dtp
       else
@@ -6083,7 +6676,7 @@ subroutine nssl_2mom_gs   &
       ENDIF
       end if
 !
-!  
+!
       crmxd(mgs)  = 0.10*cx(mgs,lr)/dtp
       csmxd(mgs)  = frac*cx(mgs,ls)/dtp
       chmxd(mgs)  = frac*cx(mgs,lh)/dtp
@@ -6093,9 +6686,9 @@ subroutine nssl_2mom_gs   &
       crmxd(mgs)  = frac*cx(mgs,lr)/dtp
       csmxd(mgs)  = frac*cx(mgs,ls)/dtp
       chmxd(mgs)  = frac*cx(mgs,lh)/dtp
-      
+
       qxmxd(mgs,lv) = Max(0.0, 0.1*(qx(mgs,lv) - qvs(mgs))/dtp)
-      
+
       DO il = lc,lhab
        qxmxd(mgs,il) = frac*qx(mgs,il)/dtp
        cxmxd(mgs,il) = frac*cx(mgs,il)/dtp
@@ -6103,7 +6696,8 @@ subroutine nssl_2mom_gs   &
 
 
       end do
- 
+
+
 !
 !
 !
@@ -6114,7 +6708,7 @@ subroutine nssl_2mom_gs   &
 !
 !  Collection efficiencies:
 !
-      if (ndebug .gt. 0 ) print*,'ICEZVD_GS: Set collection efficiencies'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies'
 !
       do mgs = 1,ngscnt
 !
@@ -6149,7 +6743,7 @@ subroutine nssl_2mom_gs   &
 !
       eiw(mgs) = 0.0
       eii(mgs) = 0.0
-      
+
       icwr(mgs) = 1
       IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN
        cwrad = 0.5*xdia(mgs,lc,1)
@@ -6231,7 +6825,7 @@ subroutine nssl_2mom_gs   &
 
        IF ( lnr .gt. 1 ) THEN
        erw(mgs) = 1.0
-       
+
        ELSE
 
 !      cwrad = 0.5*xdia(mgs,lc,1)
@@ -6247,8 +6841,8 @@ subroutine nssl_2mom_gs   &
        icp1 = Min( 8, ic+1 )
        ir = irwr(mgs)
        irp1 = Min( 6, ir+1 )
-       cwrad = 0.5*xdia(mgs,lc,1)
-       rwrad = 0.5*xdia(mgs,lr,1)
+       cwrad = 0.5*xdia(mgs,lc,3)
+       rwrad = 0.5*xdia(mgs,lr,3)
        
        slope1 = (ew(icp1, ir  ) - ew(ic,ir  ))*cwr(ic,2)
        slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2)
@@ -6257,21 +6851,21 @@ subroutine nssl_2mom_gs   &
 
        x1 = ew(ic,  ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) )
        x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) )
-       
+
        slope1 = (x2 - x1)*grad(ir,2)
-       
+
        erw(mgs) = Max(0.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ))
-       
+
 !       write(iunit,*) 'erw: ',erw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2
 !       write(iunit,*)
-       
+
        erw(mgs) = Max(0.0, erw(mgs) )
        IF ( rwrad .lt. 50.e-6 ) THEN
          erw(mgs) = 0.0
        ELSEIF (  rwrad .lt. 100.e-6 ) THEN  ! linear change from zero at 50 to erw at 100 microns
          erw(mgs) = erw(mgs)*(rwrad - 50.e-6)/50.e-6
        ENDIF
-       
+
        ENDIF
       end if
       IF ( cx(mgs,lc) .le. 0.0 ) erw(mgs) = 0.0
@@ -6285,7 +6879,7 @@ subroutine nssl_2mom_gs   &
       end if
 !
       if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,li).gt.qxmin(li) ) then
-!        IF ( vtxbar(mgs,lr,1) .gt. vtxbar(mgs,li,1) .and. 
+!        IF ( vtxbar(mgs,lr,1) .gt. vtxbar(mgs,li,1) .and.
 !     :       xdia(mgs,lr,3) .gt. 200.e-6 .and. xdia(mgs,li,3) .gt. 100.e-6 ) THEN
          eri(mgs) = eri0
 !      cwrad = 0.5*xdia(mgs,li,3)
@@ -6302,7 +6896,7 @@ subroutine nssl_2mom_gs   &
 !
 ! Modified by ERM with a linear function for small droplets and large
 ! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997, which
-! allows collection of very small droplets, albeit at low efficiency.  But slow 
+! allows collection of very small droplets, albeit at low efficiency.  But slow
 ! fall speeds of snow make up for the efficiency.
 !
       esw(mgs) = 0.0
@@ -6326,20 +6920,29 @@ subroutine nssl_2mom_gs   &
         il3(mgs) = 1
       ENDIF
 !
-      if ( qx(mgs,ls).gt.qxmin(ls) ) then
-      IF ( ipconc .lt. 4 ) THEN
+!      if ( qx(mgs,ls).gt.qxmin(ls) ) then
+      if ( temcg(mgs) < 0.0 ) then
+      IF ( ipconc .lt. 4 .or. temcg(mgs) < -25. ) THEN
         ess(mgs) = 0.0
 !        ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0))
 !        ess(mgs)=min(0.1,ess(mgs))
       ELSE
+        IF ( temcg(mgs) > -25. .and. temcg(mgs) < -20. ) THEN
+        ess(mgs) = ess0*Exp(ess1*(-20.) )*(temcg(mgs) + 25.)/5.
+        ELSEIF ( temcg(mgs) >= -20.0 ) THEN
         ess(mgs) = ess0*Exp(ess1*Min( temcg(mgs), 0.0 ) )
+        ENDIF
       ENDIF
       end if
 !
       if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,li).gt.qxmin(li) ) then
 !      IF ( ipconc .lt. 4 ) THEN
-      esi(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0))
-      esi(mgs)=min(0.1,esi(mgs))
+      IF ( ipconc < 1 .and. lwsm6 ) THEN
+        esi(mgs) = exp(0.7*min(temcg(mgs),0.0))
+      ELSE
+        esi(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0))
+        esi(mgs)=min(0.1,esi(mgs))
+      ENDIF
       IF ( ipconc .le. 3 ) THEN
        esi(mgs) =  exp(0.025*min(temcg(mgs),0.0)) ! LFO
 !       esi(mgs) =  Min(0.5, exp(0.025*min(temcg(mgs),0.0)) ) ! LFO
@@ -6359,15 +6962,16 @@ subroutine nssl_2mom_gs   &
 !
        xmascw(mgs) = xmas(mgs,lc)
       if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc).gt.qxmin(lc) ) then
+       ehw(mgs) = 1.0
        IF ( iehw .eq. 0 ) THEN
        ehw(mgs) = ehw0  ! default value is 1.0
-       ELSEIF ( iehw .eq. 1 ) THEN
+       ELSEIF ( iehw .eq. 1 .or. iehw .eq. 10 ) THEN
       cwrad = 0.5*xdia(mgs,lc,1)
       ehw(mgs) = Min( ehw0,    &
      &  ewfac*min((aradcw + cwrad*(bradcw + cwrad*   &
      &  (cradcw + cwrad*(dradcw)))), 1.0) )
       
-       ELSEIF ( iehw .eq. 2 ) THEN
+       ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN
        ic = icwr(mgs)
        icp1 = Min( 8, ic+1 )
        ir = igwr(mgs)
@@ -6385,8 +6989,8 @@ subroutine nssl_2mom_gs   &
        
        slope1 = (x2 - x1)*grad(ir,2)
        
-       ehw(mgs) = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) )
-       ehw(mgs) = Min( ehw0, ehw(mgs) )
+       tmp = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) )
+       ehw(mgs) = Min( ehw(mgs), tmp )
 
 !       write(iunit,*) 'ehw: ',ehw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2
 !       write(iunit,*)
@@ -6396,11 +7000,25 @@ subroutine nssl_2mom_gs   &
 !      ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00
 !      ehw(mgs) = ehw(mgs) + (1.0 - ehw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2
 
-       ELSEIF ( iehw .eq. 3 ) THEN ! use fraction of droplets greater than dmincw diameter
-         ehw(mgs) = Exp(- (dmincw/xdia(mgs,lc,1))**3)
+       ELSEIF ( iehw .eq. 3 .or. iehw .eq. 10 ) THEN ! use fraction of droplets greater than dmincw diameter
+         tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3)
          xmascw(mgs) = xmas(mgs,lc) + xdn0(lc)*(pi*dmincw**3/6.0) ! this is the average mass of the droplets with d > dmincw
+         ehw(mgs) = Min( ehw(mgs), tmp )
+       ELSEIF ( iehw .eq. 4 .or. iehw .eq. 10 ) THEN ! Cober and List 1993
+         tmp =  &
+     &   2.0*xdn(mgs,lc)*vtxbar(mgs,lh,1)*(0.5*xdia(mgs,lc,1))**2 &
+     &  /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lh,3))
+         tmp = Max( 1.5, Min(10.0, tmp) )
+         ehw(mgs) = Min( ehw(mgs), 0.55*Log10(2.51*tmp) )
        ENDIF
       if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0
+
+       ehw(mgs) = Min( ehw0, ehw(mgs) )
+       
+       IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN
+        ehw(mgs) = 0.0
+       ENDIF 
+
       end if
 !
       if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lr).gt.qxmin(lr)    &
@@ -6426,7 +7044,7 @@ subroutine nssl_2mom_gs   &
       ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) )
       if ( temg(mgs) .gt. 273.15 ) ehi(mgs) = 0.0
       end if
-      
+
 
 !
 !
@@ -6434,18 +7052,20 @@ subroutine nssl_2mom_gs   &
 !
 !
       IF ( lhl .gt. 1 ) THEN
-      
+
       if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lc).gt.qxmin(lc) ) then
        IF ( iehw == 3 ) iehlw = 3
+       IF ( iehw == 4 ) iehlw = 4
+       ehlw(mgs) = ehlw0
        IF ( iehlw .eq. 0 ) THEN
        ehlw(mgs) = ehlw0  ! default value is 1.0
-       ELSEIF ( iehlw .eq. 1 ) THEN
+       ELSEIF ( iehlw .eq. 1 .or. iehlw .eq. 10 ) THEN
       cwrad = 0.5*xdia(mgs,lc,1)
       ehlw(mgs) = Min( ehlw0,    &
      &  ewfac*min((aradcw + cwrad*(bradcw + cwrad*   &
      &  (cradcw + cwrad*(dradcw)))), 1.0) )
       
-       ELSEIF ( iehlw .eq. 2 ) THEN
+       ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN
        ic = icwr(mgs)
        icp1 = Min( 8, ic+1 )
        ir = ihlr(mgs)
@@ -6461,17 +7081,31 @@ subroutine nssl_2mom_gs   &
        
        slope1 = (x2 - x1)*grad(ir,2)
        
-       ehlw(mgs) = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) )
+       tmp = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) )
+         ehlw(mgs) = Min( ehlw(mgs), tmp )
        ehlw(mgs) = Min( ehlw0, ehlw(mgs) )
 !       ehw(mgs) = Max( 0.2, ehw(mgs) )
 !  assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that
 !      ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00
 !      ehlw(mgs) = ehlw(mgs) + (1.0 - ehlw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2
 
-       ELSEIF ( iehlw .eq. 3 ) THEN ! use fraction of droplets greater than 15 micron diameter
-         ehlw(mgs) = Exp(- (dmincw/xdia(mgs,lc,1))**3)
+       ELSEIF ( iehlw .eq. 3 .or. iehlw .eq. 10 ) THEN ! use fraction of droplets greater than 15 micron diameter
+         tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3)
+         ehlw(mgs) = Min( ehlw(mgs), tmp )
+       ELSEIF ( iehlw .eq. 4 .or. iehlw .eq. 10 ) THEN ! Cober and List 1993
+         tmp =  &
+     &   2.0*xdn(mgs,lc)*vtxbar(mgs,lhl,1)*(0.5*xdia(mgs,lc,1))**2 &
+     &  /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lhl,3))
+         tmp = Max( 1.5, Min(10.0, tmp) )
+         ehlw(mgs) = Min( ehlw(mgs), 0.55*Log10(2.51*tmp) )
        ENDIF
       if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0
+       ehlw(mgs) = Min( ehlw0, ehlw(mgs) )
+
+       IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN 
+        ehlw(mgs) = 0.0
+       ENDIF 
+
       end if
 !
       if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lr).gt.qxmin(lr)    &
@@ -6491,8 +7125,8 @@ subroutine nssl_2mom_gs   &
       ehli(mgs) = Min( ehimax, Max( ehli(mgs), ehimin ) )
       if ( temg(mgs) .gt. 273.15 ) ehli(mgs) = 1.0
       end if
-      
-      
+
+
       ENDIF ! lhl .gt. 1
 
       ENDDO  ! mgs loop for collection efficiencies
@@ -6505,26 +7139,26 @@ subroutine nssl_2mom_gs   &
 !
       do mgs = 1,ngscnt
 !
-      xplate(mgs) = 0.0 
+      xplate(mgs) = 0.0
       xcolmn(mgs) = 1.0
 !
 !      if ( temcg(mgs) .lt. 0. .and. temcg(mgs) .ge. -4. ) then
-!      xplate(mgs) = 1.0 
+!      xplate(mgs) = 1.0
 !      xcolmn(mgs) = 0.0
 !      end if
 !c
 !      if ( temcg(mgs) .lt. -4. .and. temcg(mgs) .ge. -9. ) then
-!      xplate(mgs) = 0.0 
+!      xplate(mgs) = 0.0
 !      xcolmn(mgs) = 1.0
 !      end if
 !c
 !      if ( temcg(mgs) .lt. -9. .and. temcg(mgs) .ge. -22.5 ) then
-!      xplate(mgs) = 1.0 
+!      xplate(mgs) = 1.0
 !      xcolmn(mgs) = 0.0
 !      end if
 !c
 !      if ( temcg(mgs) .lt. -22.5 .and. temcg(mgs) .ge. -90. ) then
-!      xplate(mgs) = 0.0 
+!      xplate(mgs) = 0.0
 !      xcolmn(mgs) = 1.0
 !      end if
 !
@@ -6535,7 +7169,7 @@ subroutine nssl_2mom_gs   &
 !  Collection growth equations....
 !
 !
-      if (ndebug .gt. 0 ) print*,'Collection: rain collects xxxxx'      
+      if (ndebug .gt. 0 ) write(0,*) 'Collection: rain collects xxxxx'
 !
       do mgs = 1,ngscnt
       qracw(mgs) =  0.0
@@ -6549,38 +7183,50 @@ subroutine nssl_2mom_gs   &
      &  *Max(0.0, vtxbar(mgs,lr,1)-vt)   &
      &  *(  gf3*xdia(mgs,lr,2)    &
      &    + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,lc,1)    &
-     &    + gf1*xdia(mgs,lc,2) )  
+     &    + gf1*xdia(mgs,lc,2) )
 !       qracw(mgs) = 0.0
 !      write(iunit,*) 'qracw,cx =',qracw(mgs),1.e6*xdia(mgs,lr,1),erw(mgs)
 !      write(iunit,*) 'qracw,cx =',qracw(mgs),cx(mgs,lc),kgs(mgs),cx(mgs,lr),1.e6*xdia(mgs,lr,1),vtxbar(mgs,lr,1),vt
-!      write(iunit,*) 'vtr: ',vtxbar(mgs,lr,1), ar*gf4br/6.0*xdia(mgs,lr,1)**br, rhovt(mgs), 
+!      write(iunit,*) 'vtr: ',vtxbar(mgs,lr,1), ar*gf4br/6.0*xdia(mgs,lr,1)**br, rhovt(mgs),
 !     :         ar*gf4br/6.0*xdia(mgs,lr,1)**br * rhovt(mgs)
        ENDIF
       ELSE
 
-       rwrad = 0.5*xdia(mgs,lr,1)
+      IF ( dmrauto <= 0 .or.  rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN 
+       rwrad = 0.5*xdia(mgs,lr,3)
         IF ( rwrad .gt. rh(mgs) ) THEN ! .or. cx(mgs,lr) .gt. nh(mgs) ) THEN
          IF ( rwrad .gt. rwradmn ) THEN
 !      DM1CCC=A2*XNC*XNR*XVC*(((CNU+2.)/(CNU+1.))*XVC+XVR)       ! (A12)
+!     NOTE: Result is independent of imurain, assumes mucloud = 3
            qracw(mgs) = erw(mgs)*aa2*cx(mgs,lr)*cx(mgs,lc)*xmas(mgs,lc)*   &
      &        ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,lr))/rho0(mgs) !*rhoinv(mgs)
          ELSE
 
+          IF ( imurain == 3 ) THEN
+
 !      DM1CCC=A1*XNC*XNR*(((CNU+3.)*(CNU+2.)/(CNU+1.)**2)*XVC**3+ ! (A14)
 !     1 ((RNU+2.)/(RNU+1.))*XVC*XVR**2)
 
-           qracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)*   &
-     &        ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**3/(cnu + 1.)**2 +    &
-     &         (alpha(mgs,lr) + 2.)*xv(mgs,lc)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))/rho0(mgs) !*rhoinv(mgs)
+!           qracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)*   &
+!     &        ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**3/(cnu + 1.)**2 +    &
+!     &         (alpha(mgs,lr) + 2.)*xv(mgs,lc)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))/rho0(mgs) !*rhoinv(mgs)
+! save multiplies by converting cx*xdn*xv/rho0 to qx
+           qracw(mgs) = aa1*cx(mgs,lr)*qx(mgs,lc)*   &
+     &        ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.)**2 +    &
+     &         (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) 
+           
+           ELSE ! imurain == 1
 
-!           xvc = xv(mgs,lc)*(1.e6)
-!           xvr = xv(mgs,lr)*1.e6
+           qracw(mgs) = aa1*cx(mgs,lr)*qx(mgs,lc)*   &
+     &        ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.)**2 +    &
+     &         (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ &
+     &          ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) 
+           
+           ENDIF
            
-!           qracw(mgs) = 1.e-18*(aa1*xvc*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)*
-!     :        ((cnu + 3.)*(cnu + 2.)*xvc**2/(cnu + 1.)**2 + 
-!     :         (alpha(mgs,lr) + 2.)*xvr**2/(alpha(mgs,lr) + 1.))/rho0(mgs)) !*rhoinv(mgs)
          ENDIF
         ENDIF
+        ENDIF
        ENDIF
 !       qracw(mgs) = Min(qracw(mgs), qx(mgs,lc))
        qracw(mgs) = Min(qracw(mgs), qcmxd(mgs))
@@ -6590,31 +7236,31 @@ subroutine nssl_2mom_gs   &
       do mgs = 1,ngscnt
       qraci(mgs) = 0.0
       craci(mgs) = 0.0
-      IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 ) THEN
+      IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN
         IF ( ipconc .ge. 3 ) THEN
-      
+
            tmp = eri(mgs)*aa2*cx(mgs,lr)*cx(mgs,li)*   &
      &        ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,lr))
-       
+
         qraci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) )
         craci(mgs) = Min( cxmxd(mgs,li), tmp )
 
-!       vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + 
+!       vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 +
 !     :            0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) )
 !
 !          qraci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*qx(mgs,li)*vt*
-!     :         (  da0(lr)*xdia(mgs,lr,3)**2 +  
-!     :            dab1(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + 
-!     :            da1(li)*xdia(mgs,li,3)**2 ) 
+!     :         (  da0(lr)*xdia(mgs,lr,3)**2 +
+!     :            dab1(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) +
+!     :            da1(li)*xdia(mgs,li,3)**2 )
 !
 !
-!       vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + 
+!       vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 +
 !     :            0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) )
 !
 !          craci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*cx(mgs,li)*vt*
-!     :         (  da0(lr)*xdia(mgs,lr,3)**2 +  
-!     :            dab0(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + 
-!     :            da0(li)*xdia(mgs,li,3)**2 ) 
+!     :         (  da0(lr)*xdia(mgs,lr,3)**2 +
+!     :            dab0(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) +
+!     :            da0(li)*xdia(mgs,li,3)**2 )
 !
 !          qraci(mgs) = Min( qraci(mgs), qxmxd(mgs,li) )
 !          craci(mgs) = Min( craci(mgs), cxmxd(mgs,li) )
@@ -6638,10 +7284,15 @@ subroutine nssl_2mom_gs   &
       do mgs = 1,ngscnt
       qracs(mgs) =  0.0
       IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN
+       IF ( lwsm6 .and. ipconc == 0 ) THEN
+         vt = vt2ave(mgs)
+       ELSE
+         vt = vtxbar(mgs,ls,1)
+       ENDIF
       qracs(mgs) =      &
      &   min(     &
      &   ((0.25)*pi/gf4)*ers(mgs)*qx(mgs,ls)*cx(mgs,lr)     &
-     &  *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,ls,1))     &
+     &  *abs(vtxbar(mgs,lr,1)-vt)     &
      &  *(  gf6*gf1*xdia(mgs,ls,2)     &
      &    + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lr,1)      &
      &    + gf4*gf3*xdia(mgs,lr,2) )      &
@@ -6651,7 +7302,7 @@ subroutine nssl_2mom_gs   &
 
 !
 !
-      if (ndebug .gt. 0 ) print*,'Collection: snow collects xxxxx'
+      if (ndebug .gt. 0 ) write(0,*) 'Collection: snow collects xxxxx'
 !
       do mgs = 1,ngscnt
       qsacw(mgs) =  0.0
@@ -6667,7 +7318,7 @@ subroutine nssl_2mom_gs   &
 !     :        ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls))
         tmp = 1.0*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)*   &
      &        ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls))
-        
+
         qsacw(mgs) = Min( qxmxd(mgs,lc), tmp*xmas(mgs,lc)*rhoinv(mgs) )
         csacw(mgs) = Min( cxmxd(mgs,lc), tmp )
 
@@ -6690,20 +7341,20 @@ subroutine nssl_2mom_gs   &
 !     :        ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls))*rhoinv(mgs)
        ELSE
 !      qsacw(mgs) =
-!     >   min( 
+!     >   min(
 !     >   ((0.25)*pi)*esw(mgs)*qx(mgs,lc)*cx(mgs,ls)
 !     >  *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1))
-!     >  *(  gf3*xdia(mgs,ls,2) 
-!     >    + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,lc,1) 
-!     >    + gf1*xdia(mgs,lc,2) )  
+!     >  *(  gf3*xdia(mgs,ls,2)
+!     >    + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,lc,1)
+!     >    + gf1*xdia(mgs,lc,2) )
 !     <  , qcmxd(mgs))
 
-            vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) 
+            vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1))
 
           qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt*   &
      &         (  da0(ls)*xdia(mgs,ls,3)**2 +     &
      &            dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) +    &
-     &            da1(lc)*xdia(mgs,lc,3)**2 ) 
+     &            da1(lc)*xdia(mgs,lc,3)**2 )
         qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) )
         csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc)
        ENDIF
@@ -6721,22 +7372,22 @@ subroutine nssl_2mom_gs   &
 
         tmp = esi(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,li)*   &
      &        ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,ls))
-        
+
         qsaci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) )
         csaci(mgs) = Min( cxmxd(mgs,li), tmp )
 
-!      qsaci(mgs) = 
+!      qsaci(mgs) =
 !     >   min(
 !     >   ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls)
 !     >  *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1))
-!     >  *(  gf3*xdia(mgs,ls,2) 
-!     >    + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) 
-!     >    + gf1*xdia(mgs,li,2) )  
+!     >  *(  gf3*xdia(mgs,ls,2)
+!     >    + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1)
+!     >    + gf1*xdia(mgs,li,2) )
 !     <  , qimxd(mgs))
       ENDIF
       ELSE ! 
       IF ( esi(mgs) .gt. 0.0 ) THEN
-      qsaci(mgs) =    &
+         qsaci(mgs) =    &
      &   min(   &
      &   ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls)   &
      &  *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1))   &
@@ -6767,10 +7418,16 @@ subroutine nssl_2mom_gs   &
 !        csacr(mgs) = qsacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
 !        csacr(mgs) = min(csacr(mgs),crmxd(mgs))
       ELSE
+       IF ( lwsm6 .and. ipconc == 0 ) THEN
+         vt = vt2ave(mgs)
+       ELSE
+         vt = vtxbar(mgs,ls,1)
+       ENDIF
+       
        qsacr(mgs) =   &
      &   min(   &
      &   ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls)   &
-     &  *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,ls,1))   &
+     &  *abs(vtxbar(mgs,lr,1)-vt)   &
      &  *(  gf6*gf1*xdia(mgs,lr,2)   &
      &    + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,ls,1)    &
      &    + gf4*gf3*xdia(mgs,ls,2) )    &
@@ -6781,7 +7438,7 @@ subroutine nssl_2mom_gs   &
 !
 !
 !
-      if (ndebug .gt. 0 ) print*,'Collection: graupel collects xxxxx'
+      if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx'
 !
       do mgs = 1,ngscnt
       qhacw(mgs) = 0.0
@@ -6841,6 +7498,14 @@ subroutine nssl_2mom_gs   &
 !     <  , qxmxd(mgs,lc))
 !     <  , qcmxd(mgs))
        
+       
+         IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and.  qhacw(mgs) > 0.0) THEN
+           qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh))
+!           qaacw = Min( qaacw, 0.5*(qsacw(mgs) + qhacw(mgs) ) )
+           qsacw(mgs) = qaacw
+           qhacw(mgs) = qaacw
+         ENDIF
+         
        ENDIF
 
           IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail
@@ -6942,34 +7607,34 @@ subroutine nssl_2mom_gs   &
        qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt*   &
      &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
      &            dab1lh(mgs,lr,lh)*xdia(mgs,lh,3)*xdia(mgs,lr,3) +    &
-     &            da1(lr)*xdia(mgs,lr,3)**2 ) 
-!       IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) print*,'qhacr= ',qhacr(mgs),tmp
+     &            da1(lr)*xdia(mgs,lr,3)**2 )
+!       IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp
 !!        qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) )
 !!        chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
 !!        chacr(mgs) = min(chacr(mgs),crmxd(mgs))
-        
+
         qhacr(mgs) = Min( qhacr(mgs), qxmxd(mgs,lr) )
 !        chacr(mgs) = Min( qhacr(mgs)*rho0(mgs)/xmas(mgs,lr), cxmxd(mgs,lr) )
 
 !       chacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt*
 !     :     cx(mgs,lr)*0.25*pi*
-!     :      (0.69874*xdia(mgs,lr,2) + 
-!     :       1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) + 
+!     :      (0.69874*xdia(mgs,lr,2) +
+!     :       1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) +
 !     :       2.*xdia(mgs,lh,2))
-     
+
 !        chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt*
-!     :         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +  
-!     :            dab0lh(mgs,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + 
-!     :            da0(lr)*xdia(mgs,lr,3)**2 ) 
+!     :         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +
+!     :            dab0lh(mgs,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) +
+!     :            da0(lr)*xdia(mgs,lr,3)**2 )
 
-!       IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) print*,'chacr= ',chacr(mgs),tmp
+!       IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp
 
         chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
         chacr(mgs) = min(chacr(mgs),crmxd(mgs))
-      
+
       IF ( lzh .gt. 1 ) THEN
           tmp = qx(mgs,lh)/cx(mgs,lh)
-          
+
 !          g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/
 !     :         ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))
 !          alp = Max( 1.0, alpha(mgs,lh)+1. )
@@ -6980,10 +7645,16 @@ subroutine nssl_2mom_gs   &
       ENDIF
       
       ELSE
+       IF ( lwsm6 .and. ipconc == 0 ) THEN
+         vt = vt2ave(mgs)
+       ELSE
+         vt = vtxbar(mgs,lh,1)
+       ENDIF
+
       qhacr(mgs) =   &
      &   min(   &
      &   ((0.25)*pi/gf4)*ehr(mgs)*qx(mgs,lr)*cx(mgs,lh)   &
-     &  *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))   &
+     &  *abs(vt-vtxbar(mgs,lr,1))   &
      &  *(  gf6*gf1*xdia(mgs,lr,2)   &
      &    + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1)   &
      &    + gf4*gf3*xdia(mgs,lh,2) )   &
@@ -6993,11 +7664,11 @@ subroutine nssl_2mom_gs   &
          vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh)
         ENDIF
       ENDIF
-      end do   
+      end do
 
 !
 !
-      if (ndebug .gt. 0 ) print*,'Collection: hail collects xxxxx'
+      if (ndebug .gt. 0 ) write(0,*) 'Collection: hail collects xxxxx'
 !
 
       do mgs = 1,ngscnt
@@ -7014,24 +7685,24 @@ subroutine nssl_2mom_gs   &
       IF ( lhl > 0 ) THEN
       rarx(mgs,lhl) = 0.0
       ENDIF
-      
+
       IF ( lhl .gt. 1 .and. ehlw(mgs) .gt. 0.0 ) THEN
-      
-      
+
+
 !        IF ( ipconc .ge. 2 ) THEN
 
-            vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) 
+            vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))
 
           qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*qx(mgs,lc)*vt*   &
      &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
      &            dab1lh(mgs,lc,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) +    &
-     &            da1(lc)*xdia(mgs,lc,3)**2 ) 
-         
+     &            da1(lc)*xdia(mgs,lc,3)**2 )
+
 
           qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)/dtp )
 
           IF ( lvol(lhl) .gt. 1 ) THEN
-             
+
              IF ( temg(mgs) .lt. 273.15) THEN
              rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1))   &
      &                *((0.60)*vtxbar(mgs,lhl,1))   &
@@ -7040,19 +7711,19 @@ subroutine nssl_2mom_gs   &
              ELSE
              rimdn(mgs,lhl) = 1000.
              ENDIF
-             
+
              vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/rimdn(mgs,lhl)
 
           ENDIF
 
-      
+
         IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .gt. 0 ) THEN
          rarx(mgs,lhl) =     &
      &    qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl))
         ENDIF
-      
-      ENDIF  
-      end do   
+
+      ENDIF
+      end do
 
       qhlaci(:) = 0.0
       IF ( lhl .gt. 1  ) THEN
@@ -7066,11 +7737,11 @@ subroutine nssl_2mom_gs   &
           qhlaci(mgs) = 0.25*pi*ehli(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt*   &
      &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
      &            dab1lh(mgs,li,lhl)*xdia(mgs,lhl,3)*xdia(mgs,li,3) +    &
-     &            da1(li)*xdia(mgs,li,3)**2 ) 
+     &            da1(li)*xdia(mgs,li,3)**2 )
           qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) )
        ENDIF
       ENDIF
-      end do  
+      end do
       ENDIF
 !
       qhlacs(:) = 0.0
@@ -7085,13 +7756,13 @@ subroutine nssl_2mom_gs   &
           qhlacs(mgs) = 0.25*pi*ehli(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt*   &
      &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
      &            dab1lh(mgs,ls,lhl)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) +    &
-     &            da1(ls)*xdia(mgs,ls,3)**2 ) 
-      
+     &            da1(ls)*xdia(mgs,ls,3)**2 )
+
           qhlacs(mgs) = Min( qhlacs(mgs), qsmxd(mgs) )
 
         ENDIF
       ENDIF
-      end do   
+      end do
       ENDIF
 
 
@@ -7105,23 +7776,23 @@ subroutine nssl_2mom_gs   &
       IF ( ipconc .ge. 3 ) THEN
        vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 +    &
      &            0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) )
-     
+
        qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt*   &
      &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
      &            dab1lh(mgs,lr,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) +    &
-     &            da1(lr)*xdia(mgs,lr,3)**2 ) 
-!       IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) print*,'qhacr= ',qhacr(mgs),tmp
+     &            da1(lr)*xdia(mgs,lr,3)**2 )
+!       IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp
 !!        qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) )
 !!        chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
 !!        chacr(mgs) = min(chacr(mgs),crmxd(mgs))
-        
+
         qhlacr(mgs) = Min( qhlacr(mgs), qxmxd(mgs,lr) )
 
-     
+
         chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt*   &
      &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
      &            dab0(lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) +    &
-     &            da0(lr)*xdia(mgs,lr,3)**2 ) 
+     &            da0(lr)*xdia(mgs,lr,3)**2 )
 
         chlacr(mgs) = min(chlacr(mgs),crmxd(mgs))
 
@@ -7130,17 +7801,17 @@ subroutine nssl_2mom_gs   &
         ENDIF
       ENDIF
       ENDIF
-      end do  
-      
+      end do
+
 
 
 !
 !
 !
 !
-      if (ndebug .gt. 0 ) print*,'Collection: Cloud collects xxxxx'
+      if (ndebug .gt. 0 ) write(0,*) 'Collection: Cloud collects xxxxx'
 
-      if (ndebug .gt. 0 ) print*,'Collection: cloud ice collects xxxx2'      
+      if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx2'
 !
       do mgs = 1,ngscnt
       qiacw(mgs) = 0.0
@@ -7152,18 +7823,19 @@ subroutine nssl_2mom_gs   &
           qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt*   &
      &         (  da0(li)*xdia(mgs,li,3)**2 +     &
      &            dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) +    &
-     &            da1(lc)*xdia(mgs,lc,3)**2 ) 
-       
+     &            da1(lc)*xdia(mgs,lc,3)**2 )
+
        qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) )
       ENDIF
       end do
 !
 !
-      if (ndebug .gt. 0 ) print*,'Collection: cloud ice collects xxxx8'      
+      if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8'
 !
       do mgs = 1,ngscnt
       qiacr(mgs) = 0.0
       qiacrf(mgs) = 0.0
+      qiacrs(mgs) = 0.0
       ciacr(mgs) = 0.0
       ciacrf(mgs) = 0.0
       viacrf(mgs) = 0.0
@@ -7178,8 +7850,63 @@ subroutine nssl_2mom_gs   &
          IF ( xdia(mgs,li,1) .ge. 10.e-6 ) THEN
           ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 )
          ENDIF
+       IF ( imurain == 1 ) THEN ! gamma of diameter
+           IF ( iacrsize .eq. 1 ) THEN
+             ratio = 500.e-6/xdia(mgs,lr,1)
+           ELSEIF ( iacrsize .eq. 2 ) THEN
+             ratio = 300.e-6/xdia(mgs,lr,1)
+           ELSEIF ( iacrsize .eq. 3 ) THEN
+             ratio = 40.e-6/xdia(mgs,lr,1)
+           ENDIF
+           
+           i = Int(Min(25.0,ratio))
+           j = Int(Max(0.0,Min(15.,alpha(mgs,lr))))
+           delx = ratio - float(i)
+           dely = alpha(mgs,lr) - float(j)
+           ip1 = Min( i+1, nqiacrratio )
+           jp1 = Min( j+1, nqiacralpha )
+
+           ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out
+           tmp1 = ciacrratio(i,j) + delx*(ciacrratio(ip1,j) - ciacrratio(i,j))
+           tmp2 = ciacrratio(i,jp1) + delx*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1))
+           
+           ! interpoate along alpha; note interval spacing is 1., so division is left out
+           
+           nr = (tmp1 + dely*(tmp2 - tmp1))*cx(mgs,lr)
+           
+           ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out
+           tmp1 = qiacrratio(i,j) + delx*(qiacrratio(ip1,j) - qiacrratio(i,j))
+           tmp2 = qiacrratio(i,jp1) + delx*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1))
+           
+           ! interpoate along alpha; note interval spacing is 1., so division is left out
+           
+           qr = (tmp1 + dely*(tmp2 - tmp1))*qx(mgs,lr)
+
+          vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 +     &
+     &            0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) )
+
+          qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt*   &
+     &         (  da0(li)*xdia(mgs,li,3)**2 +     &
+     &            dab1lh(mgs,lr,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) +    &
+     &            da1(lr)*xdia(mgs,lr,3)**2 ) 
+
+          qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) )
+
+          ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt*   &
+     &         (  da0(li)*xdia(mgs,li,3)**2 +     &
+     &            dab0lh(mgs,lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) +    &
+     &            da0(lr)*xdia(mgs,lr,3)**2 ) 
+
+          ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) )
+          
+!          write(iunit,*) 'qiacr: ',cx(mgs,lr),nr,qx(mgs,lr),qr,qiacr(mgs),ciacr(mgs)
+!          write(iunit,*) 'xdia r li = ',xdia(mgs,lr,3),xdia(mgs,li,3),xdia(mgs,lr,1),xdia(mgs,li,1)
+!          write(iunit,*) 'i,j,ratio = ',i,j,ciacrratio(i,j),qiacrratio(i,j)
+!          write(iunit,*) 'ni,ci = ',ni,cx(mgs,li),qx(mgs,li)
+
+       ELSEIF ( imurain == 3 ) THEN ! gamma of volume
 !   Set nr to the number of drops greater than 40 microns.
-         arg = 1000.*xdia(mgs,lr,1)
+         arg = 1000.*xdia(mgs,lr,3)
 !         nr = cx(mgs,lr)*gaml02( arg )
 !        IF ( iacr .eq. 1 ) THEN
          IF ( ipconc .ge. 3 ) THEN
@@ -7199,7 +7926,7 @@ subroutine nssl_2mom_gs   &
 !         nr = cx(mgs,lr)*gaml02d300( arg )  ! number greater than 300 microns in diameter
 !        ENDIF
        IF ( ni .gt. 0.0 .and. nr .gt. 0.0 ) THEN
-       d0 = xdia(mgs,lr,1)
+       d0 = xdia(mgs,lr,3)
        qiacr(mgs) = xdn(mgs,lr)*rhoinv(mgs)*   &
      &     (0.217239*(0.522295*(d0**5) +    &
      &      49711.81*(d0**6) -    &
@@ -7215,6 +7942,7 @@ subroutine nssl_2mom_gs   &
      &      2.133344e10*(d0**6))*ni*nr)
       ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) )
 !      ciacr(mgs) = qiacr(mgs)*cx(mgs,lr)/qx(mgs,lr)
+      ENDIF
        IF ( iacr .eq. 1 .or. iacr .eq. 3 ) THEN
          ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vr1mm*1000.0)*rho0(mgs) ) ! *rzxh(mgs)
        ELSEIF ( iacr .eq. 2 ) THEN
@@ -7226,7 +7954,9 @@ subroutine nssl_2mom_gs   &
        ENDIF 
 !      crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*27.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
        ENDIF
-      ELSE
+      
+      
+      ELSE ! single-moment rain
       qiacr(mgs) =    &
      &  min(        &
      &   ((0.25/gf4)*pi)*eri(mgs)*cx(mgs,li)*qx(mgs,lr)   &
@@ -7234,14 +7964,14 @@ subroutine nssl_2mom_gs   &
      &  *(  gf6*gf1*xdia(mgs,lr,2)    &
      &    + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1)    &
      &    + gf4*gf3*xdia(mgs,li,2) )     &
-     &  , qrmxd(mgs)) 
+     &  , qrmxd(mgs))
       ENDIF
 !      if ( temg(mgs) .gt. 268.15 ) then
 !      qiacr(mgs) = 0.0
 !      ciacr(mgs) = 0.0
 !      end if
       ENDIF
-      
+
       IF ( ipconc .ge. 1 ) THEN
         IF ( nsplinter .ge. 0 ) THEN
           csplinter(mgs) = nsplinter*ciacr(mgs)
@@ -7252,6 +7982,10 @@ subroutine nssl_2mom_gs   &
       ENDIF
       
       qiacrf(mgs) = qiacr(mgs)
+!      IF ( lwsm6 .and. ipconc == 0 .and. qx(mgs,lr) < 1.e-4 ) THEN
+!        qiacrs(mgs) = qiacr(mgs)
+!        qiacrf(mgs) = 0.0
+!      ENDIF
 
       IF ( lvol(lh) > 1 ) THEN
          viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz
@@ -7264,7 +7998,7 @@ subroutine nssl_2mom_gs   &
 !
 
 ! snow aggregation here
-      if ( ipconc .ge. 4 .or. ipelec .ge. 100 ) then ! 
+      if ( ipconc .ge. 4 .or. ipelec .ge. 100 ) then !
       do mgs = 1,ngscnt
       csacs(mgs) = 0.0
       IF ( ess(mgs) .gt. 0.0 ) THEN
@@ -7276,19 +8010,19 @@ subroutine nssl_2mom_gs   &
       end if
 !
 !
-      if (ndebug .gt. 0 ) print*,'ICEZVD_GS: conc 11'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 11'
       if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then
       do mgs = 1,ngscnt
       ciacw(mgs) = 0.0
       IF ( eiw(mgs) .gt. 0.0 ) THEN
-      
+
         ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc)
       ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs))
       ENDIF
       end do
       end if
 
-      if (ndebug .gt. 0 ) print*,'ICEZVD_GS: conc 18'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18'
       if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then
       do mgs = 1,ngscnt
        cracw(mgs) = 0.0
@@ -7307,47 +8041,67 @@ subroutine nssl_2mom_gs   &
      &    + gf3*xdia(mgs,lr,2) )
         ENDIF
        ELSE ! IF ( ipconc .ge. 3 .and. 
-        IF ( 0.5*xdia(mgs,lr,1) .gt. rh(mgs) ) THEN !  .or. cx(mgs,lr) .gt. nh(mgs) ) THEN
+        IF ( dmrauto <= 0 .or.  rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN  !{
+        IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) 
 !        IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN
-        IF ( 0.5*xdia(mgs,lr,1) .gt. rwradmn ) THEN ! 50.e-6 ) THEN
-!      DM0CCC=A2*XNC*XNR*(XVC+XVR)                               ! (A11)
-          cracw(mgs) = aa2*cx(mgs,lr)*cx(mgs,lc)*(xv(mgs,lc) + xv(mgs,lr))
-        ELSE
-!      DM0CCC=A1*XNC*XNR*(((CNU+2.)/(CNU+1.))*XVC**2+            ! (A13)
-!     1 ((RNU+2.)/(RNU+1.))*XVR**2)
-          cracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*   &
-     &        ((cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.) +    &
-     &         (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))
-        ENDIF
-        ENDIF
-       ENDIF
-      ENDIF
+          IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6 
+!          DM0CCC=A2*XNC*XNR*(XVC+XVR)                               ! (A11)
+!         NOTE: murain drops out, so same result for imurain = 1 and 3
+            cracw(mgs) = aa2*cx(mgs,lr)*cx(mgs,lc)*(xv(mgs,lc) + xv(mgs,lr))
+          ELSE
+            IF ( imurain == 3 ) THEN
+!          DM0CCC=A1*XNC*XNR*(((CNU+2.)/(CNU+1.))*XVC**2+((RNU+2.)/(RNU+1.))*XVR**2) ! (A13)
+            cracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*   &
+     &          ((cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.) +    &
+     &          (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))
+            ELSE ! imurain == 1 USE CP00 for rain DSD in diameter
+            cracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*   &
+     &          ((cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.) +    &
+     &          (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/  &
+     &             ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) )
+            ENDIF ! imurain
+          ENDIF
+        ENDIF ! } rh
+        ENDIF ! } dmrauto
+       ENDIF ! ipconc
+      ENDIF ! qc > qcmin & qr > qrmin
         
 ! Rain self collection (cracr) and break-up (factor of ec0)
+!
 !       
         ec0(mgs) = 2.e9
         IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
-        rwrad = 0.5*xdia(mgs,lr,1)
-        IF ( xdia(mgs,lr,1) .gt. 2.0e-3 ) THEN
+        rwrad = 0.5*xdia(mgs,lr,3)
+        IF ( xdia(mgs,lr,3) .gt. 2.0e-3 ) THEN
           ec0(mgs) = 0.0
           cracr(mgs) = 0.0
         ELSE
-          IF ( xdia(mgs,lr,1) .lt. 6.1e-4 ) THEN
+         IF ( dmrauto <= 0 .or.  rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN 
+          IF ( xdia(mgs,lr,3) .lt. 6.1e-4 ) THEN
             ec0(mgs) = 1.0
           ELSE
-            ec0(mgs) = Exp(-50.0*(50.0*(xdia(mgs,lr,1) - 6.0e-4)))
+            ec0(mgs) = Exp(-50.0*(50.0*(xdia(mgs,lr,3) - 6.0e-4)))
           ENDIF
-        
+          
+
           IF ( rwrad .ge. 50.e-6 ) THEN
-            cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr)
+              cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr)
           ELSE
-            cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2*   &
+            IF ( imurain == 3 ) THEN
+             cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2*   &
      &                   (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.)
+            ELSE ! imurain == 1
+             cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2*   &
+     &                   (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ &
+     &                  ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))
+              
+            ENDIF
           ENDIF
 !          cracr(mgs) = Min(cracr(mgs),crmxd(mgs))
+         ENDIF
         ENDIF
         ENDIF
-        
+
 !      cracw(mgs) = min(cracw(mgs),ccmxd(mgs))
       end do
       end if
@@ -7356,11 +8110,11 @@ subroutine nssl_2mom_gs   &
 !
 !  Graupel
 !
-      if (ndebug .gt. 0 ) print*,'ICEZVD_GS: conc 22ii'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii'
+      chacw(:) = 0.0
       if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
       do mgs = 1,ngscnt
-      chacw(mgs) = 0.0
-      
+
       IF ( ipconc .ge. 5 ) THEN
        IF ( qhacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN
 
@@ -7369,8 +8123,8 @@ subroutine nssl_2mom_gs   &
 !  This may _not_ be the case for cnu other than zero!
 !          chacw(mgs) = (ehw(mgs)*cx(mgs,lc)*cx(mgs,lh)*(pi/4.)*
 !     :    abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))*
-!     :    (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + 
-!     :         xdia(mgs,lc,1)*gf43rds) + 
+!     :    (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) +
+!     :         xdia(mgs,lc,1)*gf43rds) +
 !     :      xdia(mgs,lc,2)*gf53rds))
 
 !          chacw(mgs) = Min( chacw(mgs), 0.6*cx(mgs,lc)/dtp )
@@ -7396,10 +8150,10 @@ subroutine nssl_2mom_gs   &
       end do
       end if
 !
-      if (ndebug .gt. 0 ) print*,'ICEZVD_GS: conc 22kk'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
+      chaci(:) = 0.0
       if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
       do mgs = 1,ngscnt
-      chaci(mgs) = 0.0
       IF ( ehi(mgs) .gt. 0.0 ) THEN
        IF ( ipconc .ge. 5 ) THEN
 
@@ -7409,8 +8163,8 @@ subroutine nssl_2mom_gs   &
           chaci(mgs) = 0.25*pi*ehi(mgs)*cx(mgs,lh)*cx(mgs,li)*vt*   &
      &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
      &            dab0lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) +    &
-     &            da0(li)*xdia(mgs,li,3)**2 ) 
-       
+     &            da0(li)*xdia(mgs,li,3)**2 )
+
        ELSE
         chaci(mgs) =   &
      &   ((0.25)*pi)*ehi(mgs)*cx(mgs,li)*cx(mgs,lh)   &
@@ -7419,17 +8173,17 @@ subroutine nssl_2mom_gs   &
      &    + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lh,1)   &
      &    + gf3*xdia(mgs,lh,2) )
         ENDIF
-        
+
         chaci(mgs) = min(chaci(mgs),cimxd(mgs))
        ENDIF
       end do
       end if
 !
 !
-      if (ndebug .gt. 0 ) print*,'ICEZVD_GS: conc 22nn'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn'
+      chacs(:) = 0.0
       if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
       do mgs = 1,ngscnt
-      chacs(mgs) = 0.0
       IF ( ehs(mgs) .gt. 0 ) THEN
        IF ( ipconc .ge. 5 ) THEN
 
@@ -7439,8 +8193,8 @@ subroutine nssl_2mom_gs   &
           chacs(mgs) = 0.25*pi*ehs(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt*   &
      &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
      &            dab0lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) +    &
-     &            da0(ls)*xdia(mgs,ls,3)**2 ) 
-       
+     &            da0(ls)*xdia(mgs,ls,3)**2 )
+
        ELSE
       chacs(mgs) =   &
      &   ((0.25)*pi)*ehs(mgs)*cx(mgs,ls)*cx(mgs,lh)   &
@@ -7453,17 +8207,17 @@ subroutine nssl_2mom_gs   &
       ENDIF
       end do
       end if
-        
+
 
 !
 !
 !  Hail
 !
-      if (ndebug .gt. 0 ) print*,'ICEZVD_GS: conc 22ii'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii'
+      chlacw(:) = 0.0
       if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
       do mgs = 1,ngscnt
-      chlacw(mgs) = 0.0
-      
+
       IF ( lhl .gt. 1 .and. ipconc .ge. 5 ) THEN
        IF ( qhlacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN
 
@@ -7472,8 +8226,8 @@ subroutine nssl_2mom_gs   &
 !  This may _not_ be the case for cnu other than zero!
 !          chlacw(mgs) = (ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)*(pi/4.)*
 !     :    abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))*
-!     :    (2.0*xdia(mgs,lhl,1)*(xdia(mgs,lhl,1) + 
-!     :         xdia(mgs,lc,1)*gf43rds) + 
+!     :    (2.0*xdia(mgs,lhl,1)*(xdia(mgs,lhl,1) +
+!     :         xdia(mgs,lc,1)*gf43rds) +
 !     :      xdia(mgs,lc,2)*gf53rds))
 
 !          chlacw(mgs) = Min( chlacw(mgs), 0.6*cx(mgs,lc)/dtp )
@@ -7499,10 +8253,10 @@ subroutine nssl_2mom_gs   &
       end do
       end if
 !
-      if (ndebug .gt. 0 ) print*,'ICEZVD_GS: conc 22kk'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
+      chlaci(:) = 0.0
       if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
       do mgs = 1,ngscnt
-      chlaci(mgs) = 0.0
       IF ( lhl .gt. 1 .and. ehli(mgs) .gt. 0.0 ) THEN
        IF ( ipconc .ge. 5 ) THEN
 
@@ -7512,8 +8266,8 @@ subroutine nssl_2mom_gs   &
           chlaci(mgs) = 0.25*pi*ehli(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt*   &
      &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
      &            dab0(lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) +    &
-     &            da0(li)*xdia(mgs,li,3)**2 ) 
-       
+     &            da0(li)*xdia(mgs,li,3)**2 )
+
 !       ELSE
 !        chlaci(mgs) =
 !     >   ((0.25)*pi)*ehli(mgs)*cx(mgs,li)*cx(mgs,lhl)
@@ -7522,17 +8276,17 @@ subroutine nssl_2mom_gs   &
 !     >    + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lhl,1)
 !     >    + gf3*xdia(mgs,lhl,2) )
         ENDIF
-        
+
         chlaci(mgs) = min(chlaci(mgs),cimxd(mgs))
        ENDIF
       end do
       end if
 !
 !
-      if (ndebug .gt. 0 ) print*,'ICEZVD_GS: conc 22nn'
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj'
+      chlacs(:) = 0.0
       if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then
       do mgs = 1,ngscnt
-      chlacs(mgs) = 0.0
       IF ( lhl .gt. 1 .and. ehls(mgs) .gt. 0 ) THEN
        IF ( ipconc .ge. 5 ) THEN
 
@@ -7542,8 +8296,8 @@ subroutine nssl_2mom_gs   &
           chlacs(mgs) = 0.25*pi*ehls(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt*   &
      &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
      &            dab0(lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) +    &
-     &            da0(ls)*xdia(mgs,ls,3)**2 ) 
-       
+     &            da0(ls)*xdia(mgs,ls,3)**2 )
+
 !       ELSE
 !      chlacs(mgs) =
 !     >   ((0.25)*pi)*ehls(mgs)*cx(mgs,ls)*cx(mgs,lhl)
@@ -7556,15 +8310,13 @@ subroutine nssl_2mom_gs   &
       ENDIF
       end do
       end if
-        
-!
-!
-!
+
 !
 ! Ziegler (1985) autoconversion
 !
 !
-      IF ( ipconc .ge. 2 ) THEN
+      IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion.  If -1, turns off autoconversion
+      if (ndebug .gt. 0 ) write(0,*) 'conc 26a'
       
       DO mgs = 1,ngscnt
         zrcnw(mgs) = 0.0
@@ -7576,7 +8328,8 @@ subroutine nssl_2mom_gs   &
       DO mgs = 1,ngscnt
 !      qracw(mgs) = 0.0
 !      cracw(mgs) = 0.0
-       IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4. ) THEN
+       IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN
+       ! .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing                                                                                                            
          volb = xv(mgs,lc)*(1./(1.+CNU))**(1./2.)
          cautn(mgs) = Min(ccmxd(mgs),   &
      &      ((CNU+2.)/(CNU+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2)
@@ -7595,48 +8348,59 @@ subroutine nssl_2mom_gs   &
            qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) )
            crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) )
            
+           IF ( dmrauto == 0 ) THEN
+             IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19)
+               crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs)
+             ENDIF
+           ELSEIF ( dmrauto == 1  .and. cx(mgs,lr) > cxmin) THEN
+             IF ( qx(mgs,lr) > qxmin(lr) ) THEN
+               tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
+               crcnw(mgs) = Min(tmp,crcnw(mgs) )
+             ENDIF
+           ELSEIF ( dmrauto == 2  .and. cx(mgs,lr) > cxmin) THEN
+               tmp = crcnw(mgs)
+               tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr)
+               ! try mass-weighted average of old and new Dmr
+               crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr))
+           ELSEIF ( dmrauto == 3  .and. cx(mgs,lr) > cxmin) THEN ! adapted from MY/CP code
+              tmp = Max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) )
+              crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3)
+           ENDIF
            
            IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0
 
-           IF ( lzr > 1 .and. qrcnw(mgs) > 0.0 ) THEN
-!             vr = rho0(mgs)*qrcnw(mgs)/(1000.*crcnw(mgs))
-!             zrcnw(mgs) = 36.*(xnu(lr)+2.0)*crcnw(mgs)*vr**2/((xnu(lr)+1.0)*pi**2)
-             vr = rho0(mgs)*qrcnw(mgs)/(1000.)
-             zrcnw(mgs) = 36.*(xnu(lc)+2.0)*vr**2/(crcnw(mgs)*(xnu(lc)+1.0)*pi**2)
-           ENDIF
-
 !           IF (  crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 )
 !     :          THEN
-!             print*, 'crcnw,cautn ',crcnw(mgs)/cautn(mgs),
+!             write(0,*)  'crcnw,cautn ',crcnw(mgs)/cautn(mgs),
 !     :          crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s,qx(mgs,lr)
-!             print*, '            ',qx(mgs,lc),cx(mgs,lc),0.5e6*xdia(mgs,lc,1)
-!             print*, '            ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs),
+!             write(0,*)  '            ',qx(mgs,lc),cx(mgs,lc),0.5e6*xdia(mgs,lc,1)
+!             write(0,*)  '            ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs),
 !     :         1.e6*(( 3/(4.*pi))*rho0(mgs)*qrcnw(mgs)/
 !     :       (crcnw(mgs)*xdn(mgs,lr)))**(1./3.),rh(mgs)*1.e6,rwrad(mgs)
 !           ELSEIF ( crcnw(mgs) .gt. 1.0 .and. cautn(mgs) .gt. 0.) THEN
-!             print*, 'crcnw,cautn ',crcnw(mgs)/cautn(mgs),
+!             write(0,*)  'crcnw,cautn ',crcnw(mgs)/cautn(mgs),
 !     :          crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s
-!             print*, '            ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs),
+!             write(0,*)  '            ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs),
 !     :  1.e6*(( 3*pi/4.)*rho0(mgs)*qrcnw(mgs)/
 !     :   (crcnw(mgs)*xdn(mgs,lr)))**(1./3.)
 !           ENDIF
 !           crcnw(mgs) = Min(cautn(mgs),3.5e9*xl2p(mgs)/t2s)
-           
+
 !           IF ( qrcnw(mgs) .gt. 0.3e-2 ) THEN
-!            print*, 'QRCNW'
-!            print*, qrcnw(mgs),crcnw(mgs),cautn(mgs)
-!            print*, xl2p,t2s,rho0(mgs),xv(mgs,lc),cx(mgs,lc),qx(mgs,lc)
-!            print*, rb,0.5*xdia(mgs,lc,1),mgs,igs(mgs),kgs(mgs)
+!            write(0,*)  'QRCNW'
+!            write(0,*)  qrcnw(mgs),crcnw(mgs),cautn(mgs)
+!            write(0,*)  xl2p,t2s,rho0(mgs),xv(mgs,lc),cx(mgs,lc),qx(mgs,lc)
+!            write(0,*)  rb,0.5*xdia(mgs,lc,1),mgs,igs(mgs),kgs(mgs)
 !           ENDIF
 !           qrcnw(mgs) = Min(qrcnw(mgs),qcmxd(mgs))
          ENDIF
-         
-         
+
+
        ENDIF
       ENDDO
 
-      
-      
+
+
       ELSE
 
 !
@@ -7657,7 +8421,7 @@ subroutine nssl_2mom_gs   &
       qrcnw(mgs) = (max(qrcnw(mgs),0.0))
       end if
       end do
-      
+
       ENDIF
 !
 !
@@ -7679,12 +8443,12 @@ subroutine nssl_2mom_gs   &
 !     >  timflg(mgs)*rho0(mgs)*(qdiff**2)/argrcnw   &
      &  1.0e-3*rho0(mgs)*(qdiff**2)/argrcnw
       qrcnw(mgs) = Min(qxmxd(mgs,lc), (max(qrcnw(mgs),0.0)) )
-      
+
 !      write(iunit,*) 'qrcnw,cx =',qrcnw(mgs),cx(mgs,lc),mgs,1.e3*qx(mgs,lc),cno(lr)
       end if
       end do
       end if
-      
+
 !
 !
 !  kessler auto conversion for rain.
@@ -7717,9 +8481,9 @@ subroutine nssl_2mom_gs   &
       end if
       end do
       end if
-      
-      
-      
+
+
+
       ENDIF  !  ( ipconc .ge. 2 )
 
 !
@@ -7727,20 +8491,22 @@ subroutine nssl_2mom_gs   &
 !
 !  Bigg Freezing of Rain
 !
-      if (ndebug .gt. 0 ) print*,'conc 27a'
+      if (ndebug .gt. 0 ) write(0,*) 'conc 27a'
+      qrfrz(:) = 0.0
+      qrfrzs(:) = 0.0
+      qrfrzf(:) = 0.0
+      vrfrzf(:) = 0.0
+      crfrz(:) = 0.0
+      crfrzs(:) = 0.0
+      crfrzf(:) = 0.0
+      zrfrz(:)  = 0.0
+      zrfrzf(:)  = 0.0
+      qwcnr(:) = 0.0
+      
+      IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN
+      
       do mgs = 1,ngscnt 
-      qrfrz(mgs) = 0.0
-      qrfrzs(mgs) = 0.0
-      qrfrzf(mgs) = 0.0
-      vrfrzf(mgs) = 0.0
-      crfrz(mgs) = 0.0
-      crfrzs(mgs) = 0.0
-      crfrzf(mgs) = 0.0
-      zrfrz(mgs)  = 0.0
-      zrfrzf(mgs)  = 0.0
-      qwcnr(mgs) = 0.0
-      
-      if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. 0. ) then
+      if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. ) then
 !      brz = 100.0
 !      arz = 0.66
        IF ( ipconc .lt. 3 ) THEN
@@ -7756,16 +8522,121 @@ subroutine nssl_2mom_gs   &
        ELSEIF ( ipconc .ge. 3 ) THEN
 !         tmp = brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0)
 !         crfrz(mgs) = xv(mgs,lr)*tmp
+
+         frach = 1.0d0
+         
+         IF ( ibiggopt == 2 .and. imurain == 1 ) THEN
+         ! integrate from Bigg diameter (for given supercooling Ts) to infinity
+           
+           volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 !  Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 
+                                               ! for mean temperature for freezing: -ln (V) = a*Ts - b
+                                               ! volt is given in cm**3, so convert to m**3
+           dbigg = (6./pi* volt )**(1./3.) 
+           
+           ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. 
+           
+             ratio = dbigg/xdia(mgs,lr,1)
+           
+           i = Int(Min(25.0,ratio))
+           j = Int(Max(0.0,Min(15.,alpha(mgs,lr))))
+           delx = ratio - float(i)
+           dely = alpha(mgs,lr) - float(j)
+           ip1 = Min( i+1, nqiacrratio )
+           jp1 = Min( j+1, nqiacralpha )
+
+           ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out
+           tmp1 = ciacrratio(i,j) + delx*(ciacrratio(ip1,j) - ciacrratio(i,j))
+           tmp2 = ciacrratio(i,jp1) + delx*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1))
+           
+           ! interpolate along alpha; note interval spacing is 1., so division is left out
+           
+           crfrz(mgs) = (tmp1 + dely*(tmp2 - tmp1))*cx(mgs,lr)/dtp
+           
+           ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out
+           tmp1 = qiacrratio(i,j) + delx*(qiacrratio(ip1,j) - qiacrratio(i,j))
+           tmp2 = qiacrratio(i,jp1) + delx*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1))
+           
+           ! interpolate along alpha; note interval spacing is 1., so division is left out
+           
+           qrfrz(mgs) = (tmp1 + dely*(tmp2 - tmp1))*qx(mgs,lr)/dtp
+           
+           
+           
+           IF ( dbigg < Max(dfrz,dhmn) .and. ibiggsnow > 0 ) THEN ! convert some to snow or ice crystals
+            ! temporarily store qrfrz and crfrz in snow terms
+            crfrzs(mgs) = qrfrz(mgs)
+            qrfrzs(mgs) = crfrz(mgs)
+
+
+           ! recalculate using dhmn for ratio
+           ratio = Max(dfrz,dhmn)/xdia(mgs,lr,1)
+           
+           i = Int(Min(25.0,ratio))
+           j = Int(Max(0.0,Min(15.,alpha(mgs,lr))))
+           delx = ratio - float(i)
+           dely = alpha(mgs,lr) - float(j)
+           ip1 = Min( i+1, nqiacrratio )
+           jp1 = Min( j+1, nqiacralpha )
+
+           ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out
+           tmp1 = ciacrratio(i,j) + delx*(ciacrratio(ip1,j) - ciacrratio(i,j))
+           tmp2 = ciacrratio(i,jp1) + delx*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1))
+           
+           ! interpolate along alpha; note interval spacing is 1., so division is left out
+           
+           crfrz(mgs) = (tmp1 + dely*(tmp2 - tmp1))*cx(mgs,lr)/dtp
+           
+           ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out
+           tmp1 = qiacrratio(i,j) + delx*(qiacrratio(ip1,j) - qiacrratio(i,j))
+           tmp2 = qiacrratio(i,jp1) + delx*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1))
+           
+           ! interpolate along alpha; note interval spacing is 1., so division is left out
+           
+           qrfrz(mgs) = (tmp1 + dely*(tmp2 - tmp1))*qx(mgs,lr)/dtp
+
+           ! now subtract off the difference
+            crfrzs(mgs) = crfrzs(mgs) - crfrz(mgs)
+            qrfrzs(mgs) = qrfrzs(mgs) - qrfrz(mgs)
+
+           
+           ELSE
+            crfrzs(mgs) = 0.0
+            qrfrzs(mgs) = 0.0
+           ENDIF
+           
+           IF ( (qrfrzs(mgs) + qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN
+             fac = ( qrfrzs(mgs) + qrfrz(mgs) )*dtp/qx(mgs,lr)
+             qrfrz(mgs) = fac*qrfrz(mgs)
+             qrfrzs(mgs) = fac*qrfrzs(mgs)
+             qrfrzf(mgs) = fac*qrfrzf(mgs)
+             crfrz(mgs) = fac*crfrz(mgs)
+             crfrzs(mgs) = fac*crfrzs(mgs)
+             crfrzf(mgs) = fac*crfrzf(mgs)
+           ENDIF
+!           IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN
+!             fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr)
+!             crfrz(mgs) = fac*crfrz(mgs)
+!             crfrzs(mgs) = fac*crfrzs(mgs)
+!           ENDIF
+           
+           qrfrzf(mgs) = qrfrz(mgs)
+           crfrzf(mgs) = crfrz(mgs)
+           
+           qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs)
+           crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs)
+
+           
+         ELSE ! ibiggopt == 1 
          
          tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0)
-         IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN
+         IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN ! {
 !           write(iunit,*) 'Bigg Freezing problem!',mgs,igs(mgs),kgs(mgs)
 !           write(iunit,*)  'tmp, cx(lr), xv = ',tmp, cx(mgs,lr), xv(mgs,lr), (Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0)
 !           write(iunit,*)  'qr,temcg = ',qx(mgs,lr)*1000.,temcg(mgs)
            crfrz(mgs) = cxmxd(mgs,lr) ! cx(mgs,lr)/dtp
            qrfrz(mgs) = qxmxd(mgs,lr) ! qx(mgs,lr)/dtp
 !           STOP
-         ELSE
+         ELSE ! } {
          crfrz(mgs) = tmp
  !        crfrzfmx = cx(mgs,lr)*Exp(-4./3.*pi*(40.e-6)**3/xv(mgs,lr))
  !        IF ( crfrz(mgs) .gt. crfrzmx ) THEN
@@ -7774,33 +8645,61 @@ subroutine nssl_2mom_gs   &
  !          qwcnr(mgs) = cx(mgs,lr) - crfrzmx
  !        ELSE
          IF ( lzr < 1 ) THEN
-          bfnu = bfnu0
+           IF ( imurain == 3 ) THEN
+             bfnu = bfnu0
+           ELSE !imurain == 1
+             bfnu = bfnu1
+           ENDIF
          ELSE
-          bfnu = 1.0 ! (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.)
-         ENDIF
+ !         bfnu = 1.0 ! (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.)
+           IF ( imurain == 3 ) THEN
+             bfnu = (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.)
+           ELSE !imurain == 1
+!             bfnu = bfnu1
+            bfnu = (4. + alpha(mgs,lr))*(5. + alpha(mgs,lr))*(6. + alpha(mgs,lr))/  &
+     &            ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr)))
+!            bfnu = 1.
+           ENDIF
+         ENDIF 
          qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs)
-         qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)/dtp ) ! qxmxd(mgs,lr) )
-         crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)/dtp ) !cxmxd(mgs,lr) )
+
+         qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)/dtp ) ! qxmxd(mgs,lr) 
+         crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)/dtp ) !cxmxd(mgs,lr) 
          qrfrz(mgs) = Min( qrfrz(mgs), qx(mgs,lr) )
          qrfrzf(mgs) = qrfrz(mgs)
-         ENDIF
+         ENDIF !}
+
+         
+         
+         
          IF ( crfrz(mgs) .gt. 0.0 ) THEN
 !          IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN
 !           IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN
+           
+           IF ( ibiggsnow == 1 .or. ibiggsnow == 3 ) THEN
+           xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density
+           frach = 0.5 *(1. +  Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh))))
+
+             qrfrzs(mgs) = (1.-frach)*qrfrz(mgs)
+             crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs)
+!             qrfrzf(mgs) = frach*qrfrz(mgs)
+           
+           ENDIF
+           
            IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN
              qrfrzs(mgs) = qrfrz(mgs)
              crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs)
            ELSE
 !           crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)/dtp ) ! cxmxd(mgs,lr) )
 !           qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)/dtp ) ! qxmxd(mgs,lr) )
-             qrfrzf(mgs) = qrfrz(mgs)
+             qrfrzf(mgs) = frach*qrfrz(mgs)
 !             crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) )
             IF ( ibfr .le. 1 ) THEN
-             crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
+             crfrzf(mgs) = Min(frach*crfrz(mgs), dble(qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs)) ) ! rzxh(mgs)*crfrz(mgs)
             ELSEIF ( ibfr .eq. 5 ) THEN
-             crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) )*rzxh(mgs)  !*crfrz(mgs)
+             crfrzf(mgs) = Min(frach*crfrz(mgs), dble(qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs)) )*rzxh(mgs)  !*crfrz(mgs)
             ELSE
-             crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
+             crfrzf(mgs) = Min(frach*crfrz(mgs), dble(qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs)) ) ! rzxh(mgs)*crfrz(mgs)
             ENDIF
 !             crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs)
 !            IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN
@@ -7809,25 +8708,17 @@ subroutine nssl_2mom_gs   &
             
            ENDIF
 !         crfrz(mgs) = Min( cxmxd(mgs,lr), rho0(mgs)*qrfrz(mgs)/xmas(mgs,lr) )
-          IF ( lvol(lh) .gt. 1 ) THEN
-           vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz
-          ENDIF
          ELSE
           crfrz(mgs) = 0.0
           qrfrz(mgs) = 0.0
          ENDIF
 
-        IF ( lzh .gt. 1 .or. lzr .gt. 1 ) THEN
-          tmp = qx(mgs,lr)/cx(mgs,lr)
-          IF ( lzr .gt. 1 ) THEN
-            zrfrz(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) *  &
-     &       ( 2.*tmp * qrfrz(mgs) - tmp**2 * crfrz(mgs)  )
-          ENDIF
-          IF ( lzh .gt. 1 ) THEN
-            zrfrzf(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) *  &
-     &       ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs)  )
+         ENDIF ! ibiggopt
+
+          IF ( lvol(lh) .gt. 1 ) THEN
+           vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz
           ENDIF
-        ENDIF
+
         
         IF ( nsplinter .ne. 0 ) THEN
           IF ( nsplinter .gt. 0 ) THEN
@@ -7857,11 +8748,13 @@ subroutine nssl_2mom_gs   &
 !      end if
       end if
       end do
+      
+      ENDIF
 !
 !  Homogeneous freezing of cloud drops to ice crystals
 !  following Bigg (1953) and Ferrier (1994).
 !
-      if (ndebug .gt. 0 ) print*,'conc 25b'
+      if (ndebug .gt. 0 ) write(0,*) 'conc 25b'
       do mgs = 1,ngscnt
       qwfrz(mgs) = 0.0
       cwfrz(mgs) = 0.0
@@ -7869,19 +8762,44 @@ subroutine nssl_2mom_gs   &
       cwfrzc(mgs) = 0.0
       qwfrzp(mgs) = 0.0
       cwfrzp(mgs) = 0.0
-      IF ( ibfc .ge. 1 ) THEN
-      if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1. .and.   &
-     &     .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then
+      IF ( ibfc == 1 .and. temg(mgs) <= 268.15 ) THEN
+!      if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1.  .and.   &
+!     &     .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then
+      if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.0 ) THEN
+      IF ( ipconc < 2 ) THEN
       qwfrz(mgs) = ((2.0)*(brz)/(xdn(mgs,lc)*cx(mgs,lc)))   &
      &  *(exp(max(-arz*temcg(mgs), 0.0))-1.0)   &
      &  *rho0(mgs)*(qx(mgs,lc)**2)
       qwfrz(mgs) = max(qwfrz(mgs), 0.0)
       qwfrz(mgs) = min(qwfrz(mgs),qcmxd(mgs))
-       IF ( ipconc .ge. 2 ) THEN
-         cwfrz(mgs) = 0.5*qwfrz(mgs)*rho0(mgs)/xmas(mgs,lc)
-         cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs))
-       ELSE
          cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li)
+       ELSEIF ( ipconc .ge. 2 ) THEN
+         IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN
+          volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 !  Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 
+                                               ! for mean temperature for freezing: -ln (V) = a*Ts - b
+                                               ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3
+!           dbigg = (6./pi* volt )**(1./3.) 
+
+         
+         cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))/dtp ! number of droplets with volume greater than volt
+!turn off limit so that all can freeze at low temp
+!!!       cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs))
+
+         qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc))
+!         cwfrz(mgs) = cx(mgs,lc)*qwfrz(mgs)/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes 
+                                                       ! sure that cwfrz and qwfrz are consistent and prevents 
+                                                       ! spurious creation of ice crystals.
+         IF ( temg(mgs) < tfrh - 3 ) THEN
+          cwfrz(mgs) = cx(mgs,lc)
+          qwfrz(mgs) = qx(mgs,lc)
+         ENDIF
+!         IF ( qwfrz(mgs) > 0.5*qx(mgs,lc) ) THEN
+!           write(0,*) 'Problem with qwfrz(mgs): qwfrz,temcg,volt,xv,cx = ',qwfrz(mgs),qx(mgs,lc),temcg(mgs),volt,xv(mgs,lc),cx(mgs,lc),cwfrz(mgs)
+!           STOP
+!         ENDIF
+!turn off limit so that all can freeze at low temp
+!!!         qwfrz(mgs) = Min( qwfrz(mgs), qxmxd(mgs,lc) )
+         ENDIF
        ENDIF
       if ( temg(mgs) .gt. 268.15 ) then
       qwfrz(mgs) = 0.0
@@ -7903,46 +8821,46 @@ subroutine nssl_2mom_gs   &
 !     qwfrzp(mgs) = 0.0
 !     qwfrzc(mgs) = qwfrz(mgs)
 !
-      end do 
+      end do
 !
 !
 !  Contact freezing nucleation:  factor is to convert from L-1
 !  T < -2C:  via Meyers et al. JAM July, 1992 (31, 708-721)
 !
-      if (ndebug .gt. 0 ) print*,'conc 25a'
+      if (ndebug .gt. 0 ) write(0,*) 'conc 25a'
       do mgs = 1,ngscnt
 
        ccia(mgs) = 0.0
-       
+
        cwctfz(mgs) = 0.0
        qwctfz(mgs) = 0.0
        ctfzbd(mgs) = 0.0
        ctfzth(mgs) = 0.0
        ctfzdi(mgs) = 0.0
-       
+
        cwctfzc(mgs) = 0.0
        qwctfzc(mgs) = 0.0
        cwctfzp(mgs) = 0.0
        qwctfzp(mgs) = 0.0
-       
+
        IF ( icfn .ge. 1 ) THEN
-       
+
        IF ( temg(mgs) .lt. 271.15  .and. qx(mgs,lc) .gt. qxmin(lc)) THEN
 
 !       find available # of ice nuclei & limit value to max depletion of cloud water
-        
+
         IF ( icfn .ge. 2 ) THEN
          ccia(mgs) = exp( 4.11 - (0.262)*temcg(mgs) )  ! in m-3, see Walko et al. 1995
          !ccia(mgs) = Min(cwctfz(mgs), ccmxd(mgs) )
 
-!       now find how many of these collect cloud water to form IN 
+!       now find how many of these collect cloud water to form IN
 !       Cotton et al 1986
-        
+
          knud(mgs) = 2.28e-5 * temg(mgs) / ( pres(mgs)*raero ) !Walko et al. 1995
          knuda(mgs) = 1.257 + 0.4*exp(-1.1/knud(mgs))          !Pruppacher & Klett 1997 eqn 11-16
          gtp(mgs) = 1. / ( fai(mgs) + fbi(mgs) )               !Byers 65 / Cotton 72b
          dfar(mgs) = kb*temg(mgs)*(1.+knuda(mgs)*knud(mgs))/(6.*pi*fadvisc(mgs)*raero) !P&K 1997 eqn 11-15
-         fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs) 
+         fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs)
          fn2(mgs) = -gtp(mgs)*(ssw(mgs)-1.)*felv(mgs)/pres(mgs)
          fnft(mgs) = 0.4*(1.+1.45*knud(mgs)+0.4*knud(mgs)*exp(-1./knud(mgs)))*(ftka(mgs)+2.5*knud(mgs)*kaero)      &
      &              / ( (1.+3.*knud(mgs))*(2*ftka(mgs)+5.*knud(mgs)*kaero+kaero) )
@@ -7953,10 +8871,10 @@ subroutine nssl_2mom_gs   &
 
 !      Thermophoretic contact nucleation
          ctfzth(mgs) = fn1(mgs)*fn2(mgs)*fnft(mgs)/rho0(mgs)
-        
-!      Diffusiophoretic contact nucleation         
+
+!      Diffusiophoretic contact nucleation
          ctfzdi(mgs) = fn1(mgs)*fn2(mgs)*rw*temg(mgs)/(felv(mgs)*rho0(mgs))
-        
+
          cwctfz(mgs) = max( ctfzbd(mgs) + ctfzth(mgs) + ctfzdi(mgs) , 0.)
 
 !      Sum of the contact nucleation processes
@@ -7966,14 +8884,14 @@ subroutine nssl_2mom_gs   &
 !          write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs),fn1(mgs),fn2(mgs)
 !          write(6,*) 'more = ',nstep,ssw(mgs),dfar(mgs),gtp(mgs),felv(mgs),pres(mgs)
 !         ENDIF
-         
+
         ELSEIF ( icfn .eq. 1 ) THEN
          IF ( wvel(mgs) .lt. -0.05 ) THEN ! older kludgy version
-           cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) ) 
+           cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) )
            cwctfz(mgs) = Min((1.0e3)*cwctfz(mgs), ccmxd(mgs) )  !convert to m-3
          ENDIF
         ENDIF   ! icfn
-        
+
         IF ( ipconc .ge. 2 ) THEN
          cwctfz(mgs) = Min( cwctfz(mgs)/dtp, ccmxd(mgs) )
          qwctfz(mgs) = xmas(mgs,lc)*cwctfz(mgs)/rho0(mgs)
@@ -7998,16 +8916,16 @@ subroutine nssl_2mom_gs   &
 !     qwctfzp(mgs) = 0.0
 !
        end if
-       
+
        ENDIF ! icfn
-      
+
       end do
 !
 !
 !
 ! Hobbs-Rangno ice enhancement (Ferrier, 1994)
 !
-      if (ndebug .gt. 0 ) print*,'conc 23a'
+      if (ndebug .gt. 0 ) write(0,*) 'conc 23a'
       dtrh = 300.0
       hrifac = (1.e-3)*((0.044)*(0.01**3))
       do mgs = 1,ngscnt
@@ -8028,7 +8946,7 @@ subroutine nssl_2mom_gs   &
 !     :  (cx(mgs,lc)*(1.e-6)),
 !     : ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)),
 !     : (alog(cx(mgs,lc)*(1.e-6)/(3.0)) *
-!     >  ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6))) 
+!     >  ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))
 
       IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN
       ciihr(mgs) = ((1.69e17)/dtrh)   &
@@ -8060,13 +8978,13 @@ subroutine nssl_2mom_gs   &
 !
 !
 !
-!  simple frozen rain to hail conversion.  All of the 
+!  simple frozen rain to hail conversion.  All of the
 !  frozen rain larger than 5.0e-3 m in diameter are converted
 !  to hail.  This is done by considering the equation for
 !  frozen rain mixing ratio:
 !
 !
-!  qfw = [ cno(lf) * pi * fwdn / (6 rhoair) ] 
+!  qfw = [ cno(lf) * pi * fwdn / (6 rhoair) ]
 !
 !         /inf
 !      *  |     fwdia*3 exp(-dia/fwdia) d(dia)
@@ -8076,7 +8994,7 @@ subroutine nssl_2mom_gs   &
 !  Do to inf where Do is 5.0e-3 m.
 !
 !
-!  qfauh = [ cno(lf) * pi * fwdn / (6 rhoair) ] 
+!  qfauh = [ cno(lf) * pi * fwdn / (6 rhoair) ]
 !
 !
 
@@ -8107,7 +9025,7 @@ subroutine nssl_2mom_gs   &
           ENDIF
          ENDIF  ! }
         end if ! }
-      
+
        ELSEIF ( ipconc .lt. 4 ) THEN
 
         qscnvi(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0)
@@ -8128,7 +9046,7 @@ subroutine nssl_2mom_gs   &
       end do
 !
 !
-      if ( ndebug .gt. 0 ) print*,'civent'
+      if ( ndebug .gt. 0 ) write(0,*) 'civent'
 !
       civenta = 1.258e4
       civentb = 2.331
@@ -8159,7 +9077,7 @@ subroutine nssl_2mom_gs   &
       ENDIF
       ENDIF ! icond .eq. 1
       end do
-      
+
 !
 !
       igmrwa = 100.0*2.0
@@ -8169,15 +9087,64 @@ subroutine nssl_2mom_gs   &
       do mgs = 1,ngscnt
       IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
         IF ( ipconc .ge. 3 ) THEN
-          IF ( izwisventr == 1 ) THEN
+          IF ( imurain == 3 ) THEN
+           IF ( izwisventr == 1 ) THEN
             rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046)
-          ELSE
+           ELSE ! izwisventr = 2
 !  Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier's rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
           rwvent(mgs) =   &
      &  (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs)   &
      &   *Sqrt((ar*rhovt(mgs)))   &
      &    *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
-          ENDIF
+           ENDIF
+
+          ELSE ! imurain == 1
+       ! linear interpolation of complete gamma function
+!        tmp = 2. + alpha(mgs,lr)
+!        i = Int(dgami*(tmp))
+!        del = tmp - dgam*i
+!        x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+        IF ( iferwisventr == 1 ) THEN
+ 
+         alpr = Min(alpharmax, alpha(mgs,lr))
+!        alpr = alpha(mgs,lr)
+        x =  1. + alpr
+
+        tmp = 1 + alpr
+        i = Int(dgami*(tmp))
+        del = tmp - dgam*i
+        g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+
+        tmp = 2.5 + alpr + 0.5*bx(lr)
+        i = Int(dgami*(tmp))
+        del = tmp - dgam*i
+        y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions
+
+        
+         vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr)
+         vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr))
+        
+        
+        rwvent(mgs) =    &
+     &    0.78*x +    &
+     &    0.308*fvent(mgs)*y*   &
+     &            Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
+       
+        ELSEIF ( iferwisventr == 2 ) THEN
+          
+!  Following Wisner et al. (1972) 
+         x =  1. + alpha(mgs,lr)
+
+           rwvent(mgs) =   &
+     &  (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs)   &
+     &   *Sqrt((ar*rhovt(mgs)))   &
+     &    *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
+
+          
+          ENDIF ! iferwisventr
+          
+          ENDIF ! imurain
         ELSE
          rwvent(mgs) =   &
      &  (rwventa + rwventb*fvent(mgs)   &
@@ -8210,7 +9177,7 @@ subroutine nssl_2mom_gs   &
       end do
 !
 !
-      
+
       igmhwa = 100.0*2.0
       igmhwb = 100.0*2.75
       hwventa = (0.78)*gmoi(igmhwa)
@@ -8225,26 +9192,27 @@ subroutine nssl_2mom_gs   &
      &    *(xdia(mgs,lh,1)**(0.75)))
        ELSE ! Ferrier 1994, eq. B.36
        ! linear interpolation of complete gamma function
-        tmp = 2. + alpha(mgs,lh)
-        i = Int(dgami*(tmp))
-        del = tmp - dgam*i
-        x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+!        tmp = 2. + alpha(mgs,lh)
+!        i = Int(dgami*(tmp))
+!        del = tmp - dgam*i
+!        x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+        
+        x =  1. + alpha(mgs,lh)
 
-        tmp = 2.5 + alpha(mgs,lh) + 0.5*bx(lh)
+        tmp = 1 + alpha(mgs,lh)
         i = Int(dgami*(tmp))
         del = tmp - dgam*i
-        y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+        g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
 
-
-        tmp = 1 + alpha(mgs,lh)
+        tmp = 2.5 + alpha(mgs,lh) + 0.5*bx(lh)
         i = Int(dgami*(tmp))
         del = tmp - dgam*i
-        tmp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+        y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp
         
         hwvent(mgs) =    &
      &  ( 0.78*x +    &
      &    0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bx(lh)))*   &
-     &            Sqrt(xdn(mgs,lh)*ax(lh)*rhovt(mgs)/rg0))/tmp
+     &            Sqrt(xdn(mgs,lh)*ax(lh)*rhovt(mgs)/rg0) )
        
        ENDIF
       ELSE
@@ -8270,33 +9238,34 @@ subroutine nssl_2mom_gs   &
      &    *(xdia(mgs,lhl,1)**(0.75)))
        ELSE ! Ferrier 1994, eq. B.36
        ! linear interpolation of complete gamma function
-        tmp = 2. + alpha(mgs,lhl)
+!        tmp = 2. + alpha(mgs,lhl)
+!        i = Int(dgami*(tmp))
+!        del = tmp - dgam*i
+!        x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+        x =  1. + alpha(mgs,lhl)
+
+        tmp = 1 + alpha(mgs,lhl)
         i = Int(dgami*(tmp))
         del = tmp - dgam*i
-        x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
+        g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
 
         tmp = 2.5 + alpha(mgs,lhl) + 0.5*bx(lhl)
         i = Int(dgami*(tmp))
         del = tmp - dgam*i
-        y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
-
+        y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions
 
-        tmp = 1 + alpha(mgs,lhl)
-        i = Int(dgami*(tmp))
-        del = tmp - dgam*i
-        tmp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
         
         hlvent(mgs) =    &
      &  ( 0.78*x +    &
      &    0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bx(lhl)))*   &
-     &            Sqrt(ax(lhl)*rhovt(mgs)))/tmp
+     &            Sqrt(ax(lhl)*rhovt(mgs)))
 !     :            Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp
-       
+
         ENDIF
        ENDIF
       end do
       ENDIF
-      
+
 !
 !
 !
@@ -8311,7 +9280,7 @@ subroutine nssl_2mom_gs   &
       fwet2(mgs) =   &
      &  (1.0)-fci(mgs)*temcg(mgs)   &
      & / ( felf(mgs)+fcw(mgs)*temcg(mgs) )
-      end do 
+      end do
 !
 !  Melting constants
 !
@@ -8320,7 +9289,7 @@ subroutine nssl_2mom_gs   &
      &  ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv))   &
      &   -ftka(mgs)*temcg(mgs)/rho0(mgs) )    &
      &  / (felf(mgs))
-      fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) 
+      fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs)
       end do
 !
 !  Vapor Deposition constants
@@ -8335,6 +9304,7 @@ subroutine nssl_2mom_gs   &
      &  (4.0*pi/rho0(mgs))*(ssw(mgs)-1.0)*   &
      &  (1.0/(fav(mgs)+fbv(mgs)))
       end do
+
 !
 !  deposition, sublimation, and melting of snow, graupel and hail
 !
@@ -8376,7 +9346,7 @@ subroutine nssl_2mom_gs   &
      &   , 0.0 )
       ENDIF
       
-!       IF ( qx(mgs,ls) .gt. 0.1e-4 ) print*,'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs),
+!       IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs),
 !     :        temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv)
 !      ELSE
 !       qsmlr(mgs) = 0.0
@@ -8471,13 +9441,21 @@ subroutine nssl_2mom_gs   &
      IF ( chmlr(mgs) < 0.0 ) THEN
       
       IF ( ihmlt .eq. 1 ) THEN
-        chmlrr(mgs)  = Max( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain 
+        chmlrr(mgs)  = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain 
       ELSEIF ( ihmlt .eq. 2 ) THEN
         IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN
 !        chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain 
 ! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas
-!        chmlrr(mgs) =  rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh)))  ! into rain 
-        chmlrr(mgs) =  chmlr(mgs)  ! allow huge drops for now -- take care of artificial breakup later
+          IF(imltshddmr > 0) THEN
+            ! DTD: If Dmg < sheddiam, then assume complete melting into
+            ! maximal raindrop.  Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop
+            tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size
+            tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter
+            chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam)
+            chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs)))
+          ELSE ! Old method
+            chmlrr(mgs) =  rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh)))  ! into rain 
+          ENDIF
         ELSE
         chmlrr(mgs) = chmlr(mgs)
         ENDIF
@@ -8497,11 +9475,19 @@ subroutine nssl_2mom_gs   &
 !      ENDIF
       
       IF ( ihmlt .eq. 1 ) THEN
-        chlmlrr(mgs)  = Max( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain 
+        chlmlrr(mgs)  = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain 
       ELSEIF ( ihmlt .eq. 2 ) THEN
         IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN
+!        chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl)))  ! into rain 
 !        chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain 
-        chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl)))  ! into rain 
+          IF(imltshddmr > 0) THEN
+            tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size
+            tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter
+            chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam)
+            chlmlrr(mgs) = -Max(tmp,Min(tmp2,chlmlrr(mgs)))
+          ELSE
+            chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl)))  ! into rain 
+          ENDIF
         ELSE
         chlmlrr(mgs) = chlmlr(mgs)
         ENDIF
@@ -8509,7 +9495,6 @@ subroutine nssl_2mom_gs   &
         chlmlrr(mgs) = chlmlr(mgs)
       ENDIF
         
- 
       ENDIF ! }
 
       ENDIF ! .not. mixedphase
@@ -8518,13 +9503,13 @@ subroutine nssl_2mom_gs   &
 !      chmlr(mgs)  = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs)
 !      chmlrr(mgs) = chmlr(mgs)
       end do
-      end if  
+      end if
 
 !
 !  deposition/sublimation of ice
 !
       DO mgs = 1,ngscnt
-      
+
       rwcap(mgs) = (0.5)*xdia(mgs,lr,1)
       swcap(mgs) = (0.5)*xdia(mgs,ls,1)
       hwcap(mgs) = (0.5)*xdia(mgs,lh,1)
@@ -8548,7 +9533,7 @@ subroutine nssl_2mom_gs   &
 !
 !
       qhldsv(:) = 0.0
-      
+
       do mgs = 1,ngscnt
       IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh    &
      &      .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN
@@ -8558,7 +9543,7 @@ subroutine nssl_2mom_gs   &
      &    fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs)
 !        IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs)
 !     :       .and. qx(mgs,li) .gt. qxmin(li) ) THEN
-!         print*,'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1),
+!         write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1),
 !     :            fvds(mgs),civent(mgs),cicap(mgs)
 !        ENDIF
       ELSE
@@ -8597,17 +9582,17 @@ subroutine nssl_2mom_gs   &
 
       qhlsbv(mgs) = 0.0
       qhldpv(mgs) = 0.0
-      IF ( lhl .gt. 1 ) THEN 
+      IF ( lhl .gt. 1 ) THEN
         qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) )
         qhldpv(mgs) = Max(qhldsv(mgs), 0.0)
       ENDIF
-      
+
       temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs)
-      
+
       IF ( temp1 .gt. qvimxd(mgs) ) THEN
-      
+
       frac = qvimxd(mgs)/temp1
-      
+
       qidpv(mgs) = frac*qidpv(mgs)
       qsdpv(mgs) = frac*qsdpv(mgs)
       qhdpv(mgs) = frac*qhdpv(mgs)
@@ -8615,9 +9600,9 @@ subroutine nssl_2mom_gs   &
 
 !        IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs)
 !     :       .and. qx(mgs,li) .gt. qxmin(li) ) THEN
-!         print*,'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac
+!         write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac
 !        ENDIF
-      
+
       ENDIF
 
       end do
@@ -8639,8 +9624,8 @@ subroutine nssl_2mom_gs   &
 !
 !  Aggregation of crystals
 !
-      if (ndebug .gt. 0 ) print*,'conc 29a'
-      do mgs = 1,ngscnt 
+      if (ndebug .gt. 0 ) write(0,*) 'conc 29a'
+      do mgs = 1,ngscnt
       qscni(mgs) =  0.0
       cscni(mgs) = 0.0
       cscnis(mgs) = 0.0
@@ -8669,14 +9654,14 @@ subroutine nssl_2mom_gs   &
 !              cscnis(mgs) = 0.0
 !            ENDIF
           ENDIF
-          
+
            IF ( iscni .ne. 4 ) THEN
 ! erm 9/5/08 commented second line and added xv to 1st line (zrnic et al 1993)
              tmp = ess(mgs)*rvt*aa2*cx(mgs,li)*cx(mgs,li)*xv(mgs,li)
 !     :         ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,li))
 
 !           csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls)
-        
+
              qscni(mgs) = qscni(mgs) + Min( qxmxd(mgs,li), 2.0*tmp*xmas(mgs,li)*rhoinv(mgs) )
              cscni(mgs) = cscni(mgs) + Min( cxmxd(mgs,li), 2.0*tmp )
              cscnis(mgs) = cscnis(mgs) + Min( cxmxd(mgs,li), tmp )
@@ -8690,8 +9675,13 @@ subroutine nssl_2mom_gs   &
         ENDIF
 
       ELSEIF ( ipconc < 4 ) THEN ! LFO
-           qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0)
-           qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li))
+           IF ( lwsm6 ) THEN
+             qimax = rhoinv(mgs)*roqimax
+             qscni(mgs) = Min(0.9d0*qx(mgs,li), Max( 0.d0, (qx(mgs,li) - qimax)*dtpinv ) )
+           ELSE
+             qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0)
+             qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li))
+           ENDIF
       else ! 10-ice version
       if ( qx(mgs,li) .gt. qxmin(li) ) then
           qscni(mgs) =    &
@@ -8700,7 +9690,7 @@ subroutine nssl_2mom_gs   &
      &    *vtxbar(mgs,li,1)/xmas(mgs,li)
          cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li))
         end if
-      
+
       end if
       end do
 
@@ -8753,7 +9743,7 @@ subroutine nssl_2mom_gs   &
        ENDIF
 !
 !      qhlwet(mgs) = qhldry(mgs)
-      
+
       end do
 !
 ! shedding rate
@@ -8836,21 +9826,39 @@ subroutine nssl_2mom_gs   &
       csshr(mgs)  = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs))
       chshr(mgs)  = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs)
       IF ( temg(mgs) < tfr ) THEN
-         chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn0(lr)*vr4p5mm) ) ! maximum of 4.5mm drops from shedding
+         chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding
       ELSE
-         chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain
+        IF(imltshddmr > 0) THEN
+          ! DTD: If Dmg < sheddiam, then assume complete melting into
+          ! maximal raindrop.  Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop
+          tmp = -Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain
+          tmp2 = -rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter
+          chshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam)
+          chshrr(mgs) = -Max(tmp,Min(tmp2,chshrr(mgs)))
+        ELSE
+         chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to maximum size allowed for rain or 4.5mm diameter, whichever is smaller
 !        chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl)))  ! into rain 
+        ENDIF
       ENDIF
       chlshr(mgs) = 0.0
       chlshrr(mgs) = 0.0
       IF ( lhl .gt. 1 ) THEN 
          chlshr(mgs)  = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs)
         IF ( temg(mgs) < tfr ) THEN
-          chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vr4p5mm) ) ! maximum of 4.5mm drops from shedding
+          chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding
 !         chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vr1mm) ) ! maximum of 1mm drops from shedding
         ELSE
-           chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain
+          IF(imltshddmr > 0) THEN
+            ! DTD: If Dmg < sheddiam, then assume complete melting into
+            ! maximal raindrop.  Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop
+            tmp = -Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain
+            tmp2 = -rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter
+            chlshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lhl,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(sheddiam0-sheddiam)
+            chlshrr(mgs) = -Max(tmp,Min(tmp2,chlshrr(mgs)))
+          ELSE
+           chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to 4.5mm diameter or maximum size allowed for rain, whichever is smaller
 !        chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl)))  ! into rain 
+          ENDIF
         ENDIF
       ENDIF
       end do
@@ -8875,7 +9883,7 @@ subroutine nssl_2mom_gs   &
 !     qswet(mgs) = 0.0
 !     else
 !     qsdry(mgs) = 0.0
-!     end if 
+!     end if
 !
 
 ! zero the shedding rates when wet snow/graupel included.
@@ -9048,7 +10056,7 @@ subroutine nssl_2mom_gs   &
         !  m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2
         !  V = 2*m/(rhoi + rhorime)
         
-!        print*, 'rime dens = ',tmp
+!        write(0,*)  'rime dens = ',tmp
         
         IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN
           r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) )
@@ -9085,12 +10093,12 @@ subroutine nssl_2mom_gs   &
       IF ( lhl .gt. 1  ) THEN
       
       IF ( ihlcnh == 1 ) THEN
-      
+
 !
 !  Graupel (h) conversion to hail (hl) based on Milbrandt and Yau 2005b
 !
       DO mgs = 1,ngscnt
-      
+
 !        IF ( lhl .gt. 1 .and. ipconc .ge. 5 .and. qx(mgs,lh) .gt. 1.0e-3 .and.
 !     :        xdn(mgs,lh) .gt. 750. .and. qhshr(mgs) .lt. 0.0 .and.
 !     :        xdia(mgs,lh,3) .gt. 1.e-3 ) THEN
@@ -9176,7 +10184,7 @@ subroutine nssl_2mom_gs   &
         ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp))           &
        *exp(-hldia1/xdia(mgs,lh,1))                                    &
        *( (hldia1**3) + 3.0*(hldia1**2)*xdia(mgs,lh,1)                  &
-        + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) 
+        + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) )
       qhlcnh(mgs) =   min(qhlcnh(mgs),qhmxd(mgs))
       IF ( ipconc .ge. 5 ) THEN
         chlcnh(mgs) = Min( cxmxd(mgs,lh), cx(mgs,lh)*Exp(-hldia1/xdia(mgs,lh,1)))
@@ -9187,9 +10195,9 @@ subroutine nssl_2mom_gs   &
       end if
       end if
       end do
-      
+
       ENDIF
-      
+
       ENDIF ! lhl > 1
 
 
@@ -9197,14 +10205,14 @@ subroutine nssl_2mom_gs   &
 ! Ziegler snow conversion to graupel
 !
       DO mgs = 1,ngscnt
-      
+
       qhcns(mgs) = 0.0
       chcns(mgs) = 0.0
       chcnsh(mgs) = 0.0
       vhcns(mgs) = 0.0
-      
+
       IF ( ipconc .ge. 5 ) THEN
-      
+
         IF ( qx(mgs,ls) .gt. qxmin(ls) .and. qsacw(mgs) .gt. 0.0 ) THEN
 
 !      DATA VGRA/1.413E-2/  ! this is the volume (cm**3) of a 3mm diam. sphere
@@ -9213,53 +10221,53 @@ subroutine nssl_2mom_gs   &
 !      DNNET=DNCNV-DNAGG
 !      DQNET=QXCON+QSACC+SDEP
 !
-!      DNSCNV=EXP(-(ROS*XNS*VGRA/(RO*QI)))*((1.-(XNS*VGRA*ROS/ 
+!      DNSCNV=EXP(-(ROS*XNS*VGRA/(RO*QI)))*((1.-(XNS*VGRA*ROS/
 !     / (RO*QI)))*DNNET + (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET)
 !      IF(DNSCNV.LT.0.) DNSCNV=0.
 !
-!      QIHC=(ROS*VGRA/RO)*DNSCNV 
+!      QIHC=(ROS*VGRA/RO)*DNSCNV
 !
 !      QH=QH+DT*QIHC
 !      QI=QI-DT*QIHC
 !      XNH=XNH+DT*DNSCNV
 !      XNS=XNS-DT*DNSCNV
-        
+
         IF ( iglcnvs .eq. 1 ) THEN  ! Zrnic, Ziegler et al (1993)
-        
+
         dnnet = cscnvis(mgs) + cscnis(mgs) - csacs(mgs)
         dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs)
-        
+
         a3 = 1./(rho0(mgs)*qx(mgs,ls))
         a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 )  ! EXP(-(ROS*XNS*VGRA/(RO*QI)))
 ! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET
         a2 =  (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet
 ! (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET
         a4 = cx(mgs,ls)**2*vgra*xdn(mgs,ls)*a3/qx(mgs,ls)*dqnet
-        
+
         chcns(mgs) = Max( 0.0, a1*(a2 + a4) )
         chcns(mgs) = Min( chcns(mgs), cxmxd(mgs,ls) )
         chcnsh(mgs) = chcns(mgs)
-        
+
         qhcns(mgs) = Min( xdn(mgs,ls)*vgra*rhoinv(mgs)*chcns(mgs), qxmxd(mgs,ls) )
         vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),xdnmn(lh))
 !        vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.)
-        
+
         ELSEIF ( iglcnvs .ge. 2  ) THEN  ! treat like ice crystals, i.e., check for rime density (ERM)
-        
+
           IF ( temg(mgs) .lt. 273.0 .and. qsacw(mgs) - qsdpv(mgs) .gt. 0.0 ) THEN
-      
-        
+
+
         tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1))   &
      &                *((0.60)*vtxbar(mgs,ls,1))   &
      &                /(temg(mgs)-273.15))**(rimc2)
         tmp = Min( Max( rimc3, tmp ), 900.0 )
-        
+
         !  Assume that half the volume of the embryo is rime with density 'tmp'
         !  m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2
         !  V = 2*m/(rhoi + rhorime)
-        
-!        print*, 'rime dens = ',tmp
-        
+
+!        write(0,*)  'rime dens = ',tmp
+
         IF ( tmp .ge. 200.0 .or. iglcnvs >= 3 ) THEN
           r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) )
 !          r = Max( r, 400. )
@@ -9270,20 +10278,20 @@ subroutine nssl_2mom_gs   &
 !          vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp)
           vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r
         ENDIF
-      
+
       ENDIF
-        
+
         ENDIF
 
 
         ENDIF
-        
+
        ELSE ! single moment lfo
 
         qhcns(mgs) = 0.001*ehscnv(mgs)*max((qx(mgs,ls)-6.e-4),0.0)
         qhcns(mgs) = min(qhcns(mgs),qxmxd(mgs,ls))
         IF ( lvol(lh) .ge. 1 ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.)
-       
+
        ENDIF
       ENDDO
 !
@@ -9308,7 +10316,7 @@ subroutine nssl_2mom_gs   &
       qrzmax(mgs) = max(qrzmax(mgs), 0.0)
       qrzmax(mgs) = min(qrztot(mgs), qrzmax(mgs))
       qrzmax(mgs) = min(qx(mgs,lr)/dtp, qrzmax(mgs))
-      
+
       IF ( temcg(mgs) < -30. ) THEN ! allow all to freeze if T < -30 because fwet becomes invalid (negative)
         qrzmax(mgs) = qx(mgs,lr)/dtp
       ENDIF
@@ -9345,11 +10353,6 @@ subroutine nssl_2mom_gs   &
       ciacrf(mgs)  = qrzfac(mgs)*ciacrf(mgs)
 
       
-      IF ( lzh .gt. 1 ) THEN
-        zrfrzf(mgs) = 3.6476*rho0(mgs)**2*(alpha(mgs,lr)+2.)/(xdn0(lr)**2*(alpha(mgs,lr)+1.)) * &
-        ( 2.*tmp * qrfrzf(mgs) - tmp**2 * crfrzf(mgs)  )
-      ENDIF
-      
        vrfrzf(mgs)  = qrzfac(mgs)*vrfrzf(mgs)
        viacrf(mgs)  = qrzfac(mgs)*viacrf(mgs)
       end if
@@ -9367,12 +10370,12 @@ subroutine nssl_2mom_gs   &
 !
       qrcev(:) = 0.0
       crcev(:) = 0.0
-      
+
 
       do mgs = 1,ngscnt
 !
       IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN
-      
+
       qrcev(mgs) =   &
      &  fvce(mgs)*cx(mgs,lr)*rwvent(mgs)*rwcap(mgs)
 ! this line to allow condensation on rain:
@@ -9385,7 +10388,7 @@ subroutine nssl_2mom_gs   &
 
       qrcev(mgs) = max(qrcev(mgs), -qrmxd(mgs))
 !      if ( temg(mgs) .lt. 273.15 ) qrcev(mgs) = 0.0
-      IF ( qrcev(mgs) .lt. 0. ) THEN
+      IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN
 !        qrcev(mgs) =   -qrmxd(mgs)
 !        crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs)
       crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs)
@@ -9393,9 +10396,9 @@ subroutine nssl_2mom_gs   &
          crcev(mgs) = 0.0
       ENDIF
 !      if ( temg(mgs) .lt. 273.15 ) crcev(mgs) = 0.0
-!  
+!
       ENDIF
-      
+
       end do
 !
 ! evaporation/condensation of wet graupel and snow
@@ -9430,7 +10433,7 @@ subroutine nssl_2mom_gs   &
       IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 )   &
      &              .and. qx(mgs,lc) .gt. qxmin(lc)) THEN
       if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then
-       IF ( ipconc .ge. 0 ) THEN
+       IF ( ipconc .ge. 2 ) THEN
         IF ( xv(mgs,lc) .gt. 0.0     &
      &     .and.  ltest &
 !     .and. itype2 .ge. 2    &
@@ -9666,12 +10669,15 @@ subroutine nssl_2mom_gs   &
       cicint(mgs) = 0.0
       qipipnt(mgs) = 0.0
       cipint(mgs) = 0.0
+      IF ( icenucopt == 1 ) THEN
       if ( ( temg(mgs) .lt. 268.15 .or.  &
 !     : ( imeyers5 .and. temg(mgs) .lt.  273.0) ) .and.    &
      & ( imeyers5 .and. temg(mgs) .lt.  272.0 .and. temgkm2(mgs) .lt. tfr) ) .and.    &
      &    ciintmx .gt. (cx(mgs,li))  &
 !     :    .and. cninm(mgs) .gt. 0.   &
      &     ) then
+       IF ( ipconc >= 4 .or. .not. lwsm6 ) THEN
+      
       fiinit(mgs) = (felv(mgs)**2)/(cp*rw)
       dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/   &
      &  (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs))
@@ -9690,6 +10696,17 @@ subroutine nssl_2mom_gs   &
 
       qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) 
       ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin
+      
+       ELSE ! lwsm6 = true
+
+        IF ( ssi(mgs) .gt. 1.0 ) THEN
+          xni0 = 1.e3*exp(0.1*temcg(mgs))
+          roqi0 = 4.92e-11*xni0**1.33
+!          qiint(mgs) = Max(0.,(roqi0*rhoinv(mgs) - Max(qx(mgs,li),0.))*dtpinv)
+          qiint(mgs) = Max(0.0d0,dble(roqi0*rhoinv(mgs) - Max(qx(mgs,li),0.))*dtpinv)
+!             ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin
+        ENDIF
+       ENDIF
 
       ENDIF
 !
@@ -9702,6 +10719,33 @@ subroutine nssl_2mom_gs   &
         qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
       ENDIF
 !
+      end if
+      ELSEIF ( icenucopt == 2 ) THEN
+
+!        IF ( temg(mgs) .lt. 268.15 )  write(0,*) 'Cooper: i,k,ssi = ',igs(mgs),kgs(mgs),ssi(mgs)
+      
+        IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 0.999 ) .or. ssi(mgs) > 1.05 ) THEN
+          ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )
+          qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
+
+          fiinit(mgs) = (felv(mgs)**2)/(cp*rw)
+          dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/(1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs))
+          qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0))
+          ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin
+
+!          IF ( qiint(mgs) > 0.0 ) write(0,*) 'Cooper: i,k,qiint = ',igs(mgs),kgs(mgs),qiint(mgs),ssi(mgs),cnina(mgs),cina(mgs)
+        ENDIF
+      
+      
+      
+      ELSEIF ( icenucopt == 3 ) THEN
+        IF (  temg(mgs) .lt. 268.15 ) THEN
+          ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )
+          qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs)
+        ENDIF
+
+      ENDIF
+
       if ( xplate(mgs) .eq. 1 ) then
       qipipnt(mgs) = qiint(mgs)
       cipint(mgs) = ciint(mgs)
@@ -9715,7 +10759,6 @@ subroutine nssl_2mom_gs   &
 !     qipipnt(mgs) = 0.0
 !     qicicnt(mgs) = qiint(mgs)
 !
-      end if
       end do
 !
 ! 
@@ -9723,10 +10766,10 @@ subroutine nssl_2mom_gs   &
 !
 !  vapor to cloud droplets   UP
 !
-      if (ndebug .gt. 0 ) print*,'dbg = 8'
+      if (ndebug .gt. 0 ) write(0,*) 'dbg = 8'
 !
 !
-      if (ndebug .gt. 0 ) print*,'Collection: set 3-component'
+      if (ndebug .gt. 0 ) write(0,*) 'Collection: set 3-component'
 !
 !  time for riming....
 !
@@ -9884,20 +10927,22 @@ subroutine nssl_2mom_gs   &
 !       cautn(mgs) = 0.0 
 !       crcnw(mgs) = 0.0
 !       qrcnw(mgs) = 0.0
-      
+
       pccwd(mgs) =    &
      &  - cautn(mgs) -cracw(mgs)
       ENDIF
+
+
       IF ( -pccwd(mgs)*dtp .gt. cx(mgs,lc) ) THEN
 !       write(0,*) 'OUCH! pccwd(mgs)*dtp .gt. ccw(mgs) ',pccwd(mgs),cx(mgs,lc)
 !       write(0,*) 'qc = ',qx(mgs,lc)
 !       write(0,*) -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs)-cwfrzc(mgs)-cwctfzc(mgs)
 !       write(0,*)  -cracw(mgs) -csacw(mgs)  -chacw(mgs)
 !       write(0,*) - cautn(mgs)
-       
+
        frac = -cx(mgs,lc)/(pccwd(mgs)*dtp)
        pccwd(mgs) = -cx(mgs,lc)/dtp
-       
+
         ciacw(mgs)   = frac*ciacw(mgs)
         cwfrzp(mgs)  = frac*cwfrzp(mgs)
         cwctfzp(mgs) = frac*cwctfzp(mgs)
@@ -9907,13 +10952,15 @@ subroutine nssl_2mom_gs   &
         csacw(mgs)   = frac*csacw(mgs)
         chacw(mgs)   = frac*chacw(mgs)
         cautn(mgs)   = frac*cautn(mgs)
-        IF ( lhl .gt. 1 ) chlacw(mgs)   = frac*chlacw(mgs)
        
+        pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))
+        IF ( lhl .gt. 1 ) chlacw(mgs)   = frac*chlacw(mgs)
+
 !       STOP
       ENDIF
 
       end do
-      
+
       ENDIF ! ipconc
 
 !
@@ -9930,7 +10977,8 @@ subroutine nssl_2mom_gs   &
      &  +(1-il5(mgs))*(   &
      &    -chmlrr(mgs)/rzxh(mgs)   &
      &    -chlmlrr(mgs)/rzxhl(mgs)   &
-     &    -csmlr(mgs) )   &
+     &    -csmlr(mgs)     &
+     &   - cimlr(mgs) )   &
      &  -crshr(mgs)             !null at this point when wet snow/graupel included
       pcrwd(mgs) =   &
      &   il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs))
@@ -9960,48 +11008,48 @@ subroutine nssl_2mom_gs   &
       pcrwd(mgs) =   &
      &  +crcev(mgs)   &
      &  - cracr(mgs)
-      
+
 !        tmp3d(igs(mgs),jy,kgs(mgs)) = vtxbar(mgs,lr,1) ! crcnw(mgs) ! (pcrwi(mgs) + pcrwd(mgs))
 !        pcrwi(mgs) = 0.0
 !        pcrwd(mgs) = 0.0
 !        qrcnw(mgs) = 0.0
-        
+
       ENDIF
 
-      
+
       frac = 0.0
       IF ( -pcrwd(mgs)*dtp .gt. cx(mgs,lr) ) THEN
 !       write(0,*) 'OUCH! pcrwd(mgs)*dtp .gt. crw(mgs) ',pcrwd(mgs)*dtp,cx(mgs,lr),mgs,igs(mgs),kgs(mgs)
-!       write(0,*) -ciacr(mgs) 
+!       write(0,*) -ciacr(mgs)
 !       write(0,*) -crfrz(mgs)
 !       write(0,*) -chacr(mgs)
 !       write(0,*)  crcev(mgs)
 !       write(0,*)  -cracr(mgs)
-       
+
        frac =  -cx(mgs,lr)/(pcrwd(mgs)*dtp)
        pcrwd(mgs) = -cx(mgs,lr)/dtp
-        
+
         ciacr(mgs) = frac*ciacr(mgs)
         crfrz(mgs) = frac*crfrz(mgs)
         crfrzf(mgs) = frac*crfrzf(mgs)
         chacr(mgs) = frac*chacr(mgs)
         crcev(mgs) = frac*crcev(mgs)
         cracr(mgs) = frac*cracr(mgs)
-       
+
 !       STOP
       ENDIF
 
       end do
-      
+
       ENDIF
-      
+
 
       IF ( warmonly < 0.5 ) THEN
 
 !
 !  Snow
 !
-      IF ( ipconc .ge. 4 ) THEN ! 
+      IF ( ipconc .ge. 4 ) THEN !
 
       do mgs = 1,ngscnt
       pcswi(mgs) =   &
@@ -10016,13 +11064,13 @@ subroutine nssl_2mom_gs   &
      &   + cssbv(mgs)   &
      &  - csacs(mgs)
       end do
-      
+
       ENDIF
 
 !
 !  Graupel
 !
-      IF ( ipconc .ge. 5 ) THEN ! 
+      IF ( ipconc .ge. 5 ) THEN !
       do mgs = 1,ngscnt
       pchwi(mgs) =   &
      &  +ifrzg*(crfrzf(mgs)   &
@@ -10040,7 +11088,7 @@ subroutine nssl_2mom_gs   &
 !
 !  Hail
 !
-      IF ( lhl .gt. 1 ) THEN ! 
+      IF ( lhl .gt. 1 ) THEN !
       do mgs = 1,ngscnt
       pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs) +il5(mgs)*(ciacrf(mgs) ))  &
      & + chlcnh(mgs) *rzxhlh(mgs)
@@ -10049,35 +11097,35 @@ subroutine nssl_2mom_gs   &
      &  (1-il5(mgs))*chlmlr(mgs)   &
 !     >  + il5(mgs)*chlsbv(mgs)   &
      &  + chlsbv(mgs)
-      
+
 !      IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN
 !       write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs)
 !      ENDIF
       end do
-      
+
       ENDIF
 !
 
       ENDIF ! (ipconc .ge. 5 )
-      
+
       ELSEIF ( warmonly < 0.8 ) THEN
 
 !
 !  Graupel
 !
-      IF ( ipconc .ge. 5 ) THEN ! 
+      IF ( ipconc .ge. 5 ) THEN !
       do mgs = 1,ngscnt
       pchwi(mgs) =   &
-     &  +ifrzg*(crfrzf(mgs) ) 
+     &  +ifrzg*(crfrzf(mgs) )
 
       pchwd(mgs) =   &
      &  (1-il5(mgs))*chmlr(mgs) &
-     &  - il5(mgs)*chlcnh(mgs) 
+     &  - il5(mgs)*chlcnh(mgs)
       end do
 !
 !  Hail
 !
-      IF ( lhl .gt. 1 ) THEN ! 
+      IF ( lhl .gt. 1 ) THEN !
       do mgs = 1,ngscnt
       pchli(mgs) = & ! (1.0-ifrzg)*(crfrzf(mgs) +il5(mgs)*(ciacrf(mgs) ))  &
      & + chlcnh(mgs) *rzxhl(mgs)/rzxh(mgs)
@@ -10086,16 +11134,16 @@ subroutine nssl_2mom_gs   &
      &  (1-il5(mgs))*chlmlr(mgs) !  &
 !     >  + il5(mgs)*chlsbv(mgs)   &
 !     &  + chlsbv(mgs)
-      
+
 !      IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN
 !       write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs)
 !      ENDIF
       end do
-      
+
       ENDIF
 
       ENDIF ! ipconc >= 5
-      
+
       ENDIF ! warmonly
 
 !
@@ -10166,7 +11214,7 @@ subroutine nssl_2mom_gs   &
      &  -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs))   &
      &  -il5(mgs)*qidpv(mgs)
       end do
-      
+
       ELSEIF ( warmonly < 0.8 ) THEN
       do mgs = 1,ngscnt
       pqwvi(mgs) =    &
@@ -10192,9 +11240,9 @@ subroutine nssl_2mom_gs   &
       ENDIF ! warmonly
 !
 !  Cloud water
-! 
+!
       do mgs = 1,ngscnt
-      
+
       pqcwi(mgs) =  (0.0) + qwcnr(mgs)
 
       IF ( warmonly < 0.5 ) THEN
@@ -10208,17 +11256,17 @@ subroutine nssl_2mom_gs   &
      &  il5(mgs)*(-qiacw(mgs)-qwfrzc(mgs)-qwctfzc(mgs))   &
 !     &  il5(mgs)*(-qwfrzc(mgs)-qwctfzc(mgs))   &
      &  -il5(mgs)*(qicichr(mgs))   &
-     &  -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs) 
+     &  -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs)
       ELSE
       pqcwd(mgs) =    &
-     &  -qracw(mgs) - qrcnw(mgs) 
+     &  -qracw(mgs) - qrcnw(mgs)
       ENDIF
-      
+
       IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN
 
        frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp)
        pqcwd(mgs) = -qx(mgs,lc)/dtp
-       
+
         qiacw(mgs)   = frac*qiacw(mgs)
 !        qwfrzp(mgs)  = frac*qwfrzp(mgs)
 !        qwctfzp(mgs) = frac*qwctfzp(mgs)
@@ -10237,6 +11285,7 @@ subroutine nssl_2mom_gs   &
 
 !       STOP
       ENDIF
+      
 
       end do
 !
@@ -10295,7 +11344,7 @@ subroutine nssl_2mom_gs   &
      &  +(1.-il5(mgs))*qimlr(mgs)  ! &
 !     &  - qhcni(mgs)
       end do
-      
+
       ENDIF
 !
 !  Rain
@@ -10331,11 +11380,11 @@ subroutine nssl_2mom_gs   &
      &  + Min(0.0,qrcev(mgs))
       ELSE
       pqrwi(mgs) =     &
-     &   qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs))  
+     &   qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs))
       pqrwd(mgs) =  Min(0.0,qrcev(mgs))
       ENDIF ! warmonly
-     
-     
+
+
  !      IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr)  ) THEN
       IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr)  ) THEN
 
@@ -10348,7 +11397,7 @@ subroutine nssl_2mom_gs   &
        pqwvd(mgs) =  pqwvd(mgs)   &
      &  + Max(0.0, qrcev(mgs))   &
      &  - frac*Max(0.0, qrcev(mgs))
-       
+
        qiacr(mgs)  = frac*qiacr(mgs)
        qiacrf(mgs) = frac*qiacrf(mgs)
        viacrf(mgs) = frac*viacrf(mgs)
@@ -10380,6 +11429,29 @@ subroutine nssl_2mom_gs   &
        pqrwd(mgs) =  Min(0.0,qrcev(mgs))
       ENDIF ! warmonly
 
+!
+! Resum for vapor since qrcev has changed
+!
+      IF ( qrcev(mgs) .ne. 0.0 ) THEN
+       pqwvi(mgs) =    &
+     &  -Min(0.0, qrcev(mgs))   &
+     &  -Min(0.0, qhcev(mgs))   &
+     &  -Min(0.0, qhlcev(mgs))   &
+     &  -Min(0.0, qscev(mgs))   &
+!     >  +il5(mgs)*(-qhsbv(mgs)  - qhlsbv(mgs) )   &
+     &  -qhsbv(mgs)  - qhlsbv(mgs)   &
+     &  -qssbv(mgs)    &
+     &  -il5(mgs)*qisbv(mgs)
+       pqwvd(mgs) =     &
+     &  -Max(0.0, qrcev(mgs))   &
+     &  -Max(0.0, qhcev(mgs))   &
+     &  -Max(0.0, qhlcev(mgs))   &
+     &  -Max(0.0, qscev(mgs))   &
+     &  +il5(mgs)*(-qiint(mgs)   &
+     &  -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs))   &
+     &  -il5(mgs)*qidpv(mgs)
+       ENDIF
+
 
 !       STOP
       ENDIF
@@ -10396,7 +11468,7 @@ subroutine nssl_2mom_gs   &
      &   + qscnvi(mgs) + qrfrzs(mgs) + il2(mgs)*qsacr(mgs))   &
      &   + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) &
      &   + Max(0.0, qscev(mgs))   &
-     &   + qsacw(mgs) + qsacr(mgs)
+     &   + qsacw(mgs)
       pqswd(mgs) =    &
 !     >  -qfacs(mgs) ! -qwacs(mgs)   &
      &  -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs)   &
@@ -10437,7 +11509,7 @@ subroutine nssl_2mom_gs   &
 !  Hail
 !
       IF ( lhl .gt. 1 ) THEN
-      
+
       do mgs = 1,ngscnt
       pqhli(mgs) =    &
      &  +il5(mgs)*(qhldpv(mgs) + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs)  + qracif(mgs)))   &
@@ -10477,7 +11549,7 @@ subroutine nssl_2mom_gs   &
 !  Hail
 !
       IF ( lhl .gt. 1 ) THEN
-      
+
       do mgs = 1,ngscnt
       pqhli(mgs) =    &
      &  +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs)  + qracif(mgs)))   &
@@ -10490,11 +11562,11 @@ subroutine nssl_2mom_gs   &
 !     >  +il5(mgs)*qhlsbv(mgs)   &
      &  + qhlsbv(mgs)   &
      &  -qhlmul1(mgs)
-      
+
       end do
-      
+
       ENDIF ! lhl
-      
+
       ENDIF ! warmonly
 
 !
@@ -10528,7 +11600,7 @@ subroutine nssl_2mom_gs   &
       IF ( lvol(ls) .gt. 1 ) THEN
       do mgs = 1,ngscnt
 !      pvswi(mgs) = rho0(mgs)*( pqswi(mgs) )/xdn0(ls)
-      
+
       pvswi(mgs) = rho0(mgs)*(    &
 !aps     >   il5*qsfzs(mgs)/xdn(mgs,ls)   &
 !aps     >  -il5*qsfzs(mgs)/xdn(mgs,lr)   &
@@ -10539,13 +11611,13 @@ subroutine nssl_2mom_gs   &
       pvswd(mgs) = rho0(mgs)*( pqswd(mgs) )/xdn0(ls)  &
 !     >  -qhacs(mgs)
 !     >  -qhcns(mgs)
-!     >  +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) 
+!     >  +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs)
 !     >  +il5(mgs)*(qssbv(mgs))
      &   -rho0(mgs)*qsmul(mgs)/xdn0(ls)
 !aps     >   +rho0(mgs)*(1-il5(mgs))*(
 !aps     >             qsmlr(mgs)/xdn(mgs,ls)
 !aps     >    +(qscev-qsmlr(mgs))/xdn(mgs,lr) )
-      end do 
+      end do
 
 !aps      IF (mixedphase) THEN
 !aps        pvswd(mgs) = pvswd(mgs)
@@ -10559,10 +11631,10 @@ subroutine nssl_2mom_gs   &
       IF ( lvol(lh) .gt. 1 ) THEN
       DO mgs = 1,ngscnt
 !      pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) )/xdn0(lh) )
-      
-!      pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) - il5(mgs)*qrfrzf(mgs) )/xdn0(lh) ! 
+
+!      pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) - il5(mgs)*qrfrzf(mgs) )/xdn0(lh) !
 !     :  +  il5(mgs)*qrfrzf(mgs)/rhofrz )
- 
+
       pvhwi(mgs) = rho0(mgs)*(   &
      &  +il5(mgs)*( qracif(mgs))/rhofrz   &
 !erm     >  + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)?   &
@@ -10617,7 +11689,7 @@ subroutine nssl_2mom_gs   &
       write(iunit,*)   'qhsbv', qhsbv(mgs)
       write(iunit,*)   'qhlcnh',-qhlcnh(mgs)
       write(iunit,*)   'qhmul1',-qhmul1(mgs)
-      write(iunit,*)   'pqhwd = ', pqhwd(mgs) 
+      write(iunit,*)   'pqhwd = ', pqhwd(mgs)
       write(iunit,*)
       write(iunit,*)  'Volume'
       write(iunit,*)
@@ -10625,26 +11697,26 @@ subroutine nssl_2mom_gs   &
       write(iunit,*)   'vhcns', vhcns(mgs)
       write(iunit,*)  'vhacr,vhacw',vhacr(mgs), vhacw(mgs) ! qhacw(mgs)/rimdn(mgs,lh)
       write(iunit,*)  'vhcni',vhcni(mgs)
-      write(iunit,*)  
+      write(iunit,*)
       write(iunit,*)  'pvhwd',pvhwd(mgs)
       write(iunit,*)  'vhlcnh,vhshdr,vhsoak ', vhlcnh(mgs),  vhshdr(mgs), vhsoak(mgs)
       write(iunit,*)  'vhmlr', vhmlr(mgs)
-      write(iunit,*)  
-!      write(iunit,*)  
-!      write(iunit,*)  
-!      write(iunit,*)  
+      write(iunit,*)
+!      write(iunit,*)
+!      write(iunit,*)
+!      write(iunit,*)
       write(iunit,*)  'Concentration'
       write(iunit,*)   pchwi(mgs),pchwd(mgs)
       write(iunit,*)  crfrzf(mgs)
       write(iunit,*)  chcns(mgs)
       write(iunit,*)  ciacrf(mgs)
-        
-      
+
+
       ENDIF
 
 
       ENDDO
-      
+
       ENDIF
 !
 !
@@ -10656,7 +11728,7 @@ subroutine nssl_2mom_gs   &
       IF ( lhl .gt. 1 ) THEN
       IF ( lvol(lhl) .gt. 1 ) THEN
       DO mgs = 1,ngscnt
- 
+
       pvhli(mgs) = rho0(mgs)*(   &
      &  + (  il5(mgs)*qhldpv(mgs)   &
 !     &  +    Max(0.0, qhlcev(mgs))   &
@@ -10673,7 +11745,8 @@ subroutine nssl_2mom_gs   &
 !     &   + vhlmlr(mgs)                    &
      &   + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl)  &
      &   + vhlshdr(mgs) - vhlsoak(mgs)
-      
+
+
       ENDDO
       
       ENDIF
@@ -10692,20 +11765,20 @@ subroutine nssl_2mom_gs   &
      &  + pqswi(mgs) + pqswd(mgs)   &
      &  + pqhwi(mgs) + pqhwd(mgs)   &
      &  + pqhli(mgs) + pqhld(mgs)
-!      
+!
 
       if ( ( (ndebug .ge. 1  ) .and. abs(ptotal(mgs)) .gt. eqtot )   &
 !      if ( (  abs(ptotal(mgs)) .gt. eqtot )
 !     :    .or. pqswi(mgs)*dtp .gt. 1.e-3
 !     :    .or. pqhwi(mgs)*dtp .gt. 1.e-3
-!     :     .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3 
-!     :     .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7 
+!     :     .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3
+!     :     .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7
 !     :     .or. dtp*(pcipi(mgs)+pcipd(mgs)) .gt. 1.e7    &
      &  .or.  .not. (ptotal(mgs) .lt. 1.0 .and.   &
      &            ptotal(mgs) .gt. -1.0)    ) then
       write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs,   &
      &       kgs(mgs),ptotal(mgs)
-     
+
       write(iunit,*) 't7: ', t7(igs(mgs),jgs,kgs(mgs))
       write(iunit,*)  'cci,ccw,crw,rdia: ',cx(mgs,li),cx(mgs,lc),cx(mgs,lr),0.5*xdia(mgs,lr,1)
       write(iunit,*)  'qc,qi,qr : ',qx(mgs,lc),qx(mgs,li),qx(mgs,lr)
@@ -10715,12 +11788,12 @@ subroutine nssl_2mom_gs   &
       write(iunit,*)  'snow: ',qx(mgs,ls),cx(mgs,ls),swvent(mgs),vtxbar(mgs,ls,1),xdia(mgs,ls,1)
       write(iunit,*)  'graupel: ',qx(mgs,lh),cx(mgs,lh),hwvent(mgs),vtxbar(mgs,lh,1),xdia(mgs,lh,1)
       IF ( lhl .gt. 1 ) write(iunit,*)  'hail: ',qx(mgs,lhl),cx(mgs,lhl),hlvent(mgs),vtxbar(mgs,lhl,1),xdia(mgs,lhl,1)
-      
-      
+
+
       write(iunit,*)  'li: ',xdia(mgs,li,1),xdia(mgs,li,2),xmas(mgs,li),qx(mgs,li),   &
      &         vtxbar(mgs,li,1)
-      
-      
+
+
       write(iunit,*)  'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr)
       write(iunit,*)  'temcg = ', temcg(mgs)
 
@@ -10740,16 +11813,16 @@ subroutine nssl_2mom_gs   &
       write(iunit,*)   'Vapor'
 !
       write(iunit,*)   -Min(0.0,qrcev(mgs))
-      write(iunit,*)   -il5(mgs)*qhsbv(mgs) 
-      write(iunit,*)   -il5(mgs)*qhlsbv(mgs) 
-      write(iunit,*)   -il5(mgs)*qssbv(mgs) 
+      write(iunit,*)   -il5(mgs)*qhsbv(mgs)
+      write(iunit,*)   -il5(mgs)*qhlsbv(mgs)
+      write(iunit,*)   -il5(mgs)*qssbv(mgs)
       write(iunit,*)   -il5(mgs)*qisbv(mgs)
-      write(iunit,*)    'pqwvi= ', pqwvi(mgs) 
+      write(iunit,*)    'pqwvi= ', pqwvi(mgs)
       write(iunit,*)   -Max(0.0,qrcev(mgs))
       write(iunit,*)   -il5(mgs)*qiint(mgs)
-      write(iunit,*)   -il5(mgs)*qhdpv(mgs) 
-      write(iunit,*)   -il5(mgs)*qhldpv(mgs) 
-      write(iunit,*)   -il5(mgs)*qsdpv(mgs) 
+      write(iunit,*)   -il5(mgs)*qhdpv(mgs)
+      write(iunit,*)   -il5(mgs)*qhldpv(mgs)
+      write(iunit,*)   -il5(mgs)*qsdpv(mgs)
       write(iunit,*)   -il5(mgs)*qidpv(mgs)
       write(iunit,*)    'pqwvd = ', pqwvd(mgs)
 !
@@ -10764,17 +11837,17 @@ subroutine nssl_2mom_gs   &
       write(iunit,*)   il5(mgs)*qicichr(mgs)
       write(iunit,*)   qhmul1(mgs)
       write(iunit,*)   qhlmul1(mgs)
-      write(iunit,*)   'pqcii = ', pqcii(mgs)  
+      write(iunit,*)   'pqcii = ', pqcii(mgs)
       write(iunit,*)   -il5(mgs)*qscni(mgs)
       write(iunit,*)   -il5(mgs)*qscnvi(mgs)
-      write(iunit,*)   -il5(mgs)*qraci(mgs) 
+      write(iunit,*)   -il5(mgs)*qraci(mgs)
       write(iunit,*)   -il5(mgs)*qsaci(mgs)
       write(iunit,*)   -il5(mgs)*qhaci(mgs)
       write(iunit,*)   -il5(mgs)*qhlaci(mgs)
       write(iunit,*)   il5(mgs)*qisbv(mgs)
       write(iunit,*)   (1.-il5(mgs))*qimlr(mgs)
-      write(iunit,*)   -il5(mgs)*qhcni(mgs) 
-      write(iunit,*)   'pqcid = ', pqcid(mgs) 
+      write(iunit,*)   -il5(mgs)*qhcni(mgs)
+      write(iunit,*)   'pqcid = ', pqcid(mgs)
       write(iunit,*)   ' Conc:'
       write(iunit,*)   pccii(mgs),pccid(mgs)
       write(iunit,*)   il5(mgs),cicint(mgs)
@@ -10790,7 +11863,7 @@ subroutine nssl_2mom_gs   &
       write(iunit,*)
       write(iunit,*)   'Cloud water'
 !
-      write(iunit,*)   'pqcwi =', pqcwi(mgs) 
+      write(iunit,*)   'pqcwi =', pqcwi(mgs)
       write(iunit,*)   -il5(mgs)*qiacw(mgs)
       write(iunit,*)   -il5(mgs)*qwfrzc(mgs)
       write(iunit,*)   -il5(mgs)*qwctfzc(mgs)
@@ -10800,25 +11873,25 @@ subroutine nssl_2mom_gs   &
       write(iunit,*)   -il5(mgs)*qicichr(mgs)
       write(iunit,*)   -il5(mgs)*qipiphr(mgs)
       write(iunit,*)   -qracw(mgs)
-      write(iunit,*)   -qsacw(mgs) 
-      write(iunit,*)   -qrcnw(mgs) 
+      write(iunit,*)   -qsacw(mgs)
+      write(iunit,*)   -qrcnw(mgs)
       write(iunit,*)   -qhacw(mgs)
       write(iunit,*)   -qhlacw(mgs)
-      write(iunit,*)   'pqcwd = ', pqcwd(mgs) 
+      write(iunit,*)   'pqcwd = ', pqcwd(mgs)
 
 
       write(iunit,*)
       write(iunit,*)  'Concentration:'
-      write(iunit,*)   -cautn(mgs) 
+      write(iunit,*)   -cautn(mgs)
       write(iunit,*)   -cracw(mgs)
-      write(iunit,*)   -csacw(mgs) 
+      write(iunit,*)   -csacw(mgs)
       write(iunit,*)   -chacw(mgs)
-      write(iunit,*)  -ciacw(mgs)   
-      write(iunit,*)  -cwfrzp(mgs)  
-      write(iunit,*)  -cwctfzp(mgs) 
-      write(iunit,*)  -cwfrzc(mgs)  
-      write(iunit,*)  -cwctfzc(mgs) 
-      write(iunit,*)   pccwd(mgs) 
+      write(iunit,*)  -ciacw(mgs)
+      write(iunit,*)  -cwfrzp(mgs)
+      write(iunit,*)  -cwctfzp(mgs)
+      write(iunit,*)  -cwfrzc(mgs)
+      write(iunit,*)  -cwctfzc(mgs)
+      write(iunit,*)   pccwd(mgs)
 !
       write(iunit,*)
       write(iunit,*)      'Rain '
@@ -10871,16 +11944,16 @@ subroutine nssl_2mom_gs   &
       write(iunit,*)        il5(mgs)*qsdpv(mgs)
       write(iunit,*)        qsacw(mgs)
       write(iunit,*)        qsacr(mgs)
-      write(iunit,*)        'pqswi = ',pqswi(mgs)  
+      write(iunit,*)        'pqswi = ',pqswi(mgs)
       write(iunit,*)        -qhcns(mgs)
 !      write(iunit,*)        -qracs(mgs)
       write(iunit,*)        -qhacs(mgs)
       write(iunit,*)        -qhlacs(mgs)
-      write(iunit,*)       (1-il5(mgs))*qsmlr(mgs) 
-      write(iunit,*)       qsshr(mgs) 
+      write(iunit,*)       (1-il5(mgs))*qsmlr(mgs)
+      write(iunit,*)       qsshr(mgs)
 !      write(iunit,*)       qsshrp(mgs)
       write(iunit,*)       il5(mgs)*(qssbv(mgs))
-      write(iunit,*)       'pqswd = ', pqswd(mgs)  
+      write(iunit,*)       'pqswd = ', pqswd(mgs)
 !
 !
       write(iunit,*)
@@ -10903,7 +11976,7 @@ subroutine nssl_2mom_gs   &
       write(iunit,*)   il5(mgs),qhsbv(mgs)
       write(iunit,*)   -qhlcnh(mgs)
       write(iunit,*)   -qhmul1(mgs)
-      write(iunit,*)   'pqhwd = ', pqhwd(mgs) 
+      write(iunit,*)   'pqhwd = ', pqhwd(mgs)
       write(iunit,*)  'Concentration'
       write(iunit,*)   pchwi(mgs),pchwd(mgs)
       write(iunit,*)  crfrzf(mgs)
@@ -10925,7 +11998,7 @@ subroutine nssl_2mom_gs   &
       write(iunit,*)   qhlshr(mgs)
       write(iunit,*)   (1-il5(mgs))*qhlmlr(mgs)
       write(iunit,*)   il5(mgs)*qhlsbv(mgs)
-      write(iunit,*)   pqhld(mgs) 
+      write(iunit,*)   pqhld(mgs)
       write(iunit,*)  'Concentration'
       write(iunit,*)   pchli(mgs),pchld(mgs)
       write(iunit,*)  chlcnh(mgs)
@@ -11009,37 +12082,40 @@ subroutine nssl_2mom_gs   &
       pvap(mgs) = qrcev(mgs)
       ENDIF ! warmonly
       ptem(mgs) =    &
-     &  (cpi/pi0(mgs))*   &
-     &  (felf(mgs)*pfrz(mgs)   &
-     &  +fels(mgs)*psub(mgs)    &
-     &  +felv(mgs)*pvap(mgs))
+     &  (1./pi0(mgs))*   &
+     &  (felfcp(mgs)*pfrz(mgs)   &
+     &  +felscp(mgs)*psub(mgs)    &
+     &  +felvcp(mgs)*pvap(mgs))
       thetap(mgs) = thetap(mgs) + dtp*ptem(mgs)
       end do
 
+
+
+
 !
 !  sum the sources and sinks for qwvp, qcw, qci, qrw, qsw
 !
 !
       do mgs = 1,ngscnt
       qwvp(mgs) = qwvp(mgs) +        &
-     &   dtp*(pqwvi(mgs)+pqwvd(mgs)) 
+     &   dtp*(pqwvi(mgs)+pqwvd(mgs))
       qx(mgs,lc) = qx(mgs,lc) +   &
-     &   dtp*(pqcwi(mgs)+pqcwd(mgs)) 
+     &   dtp*(pqcwi(mgs)+pqcwd(mgs))
 !      IF ( qx(mgs,lr) .gt. 10.0e-3 )  THEN
-!       print*, 'RAIN1a: ',igs(mgs),kgs(mgs),qx(mgs,lr)
+!       write(0,*)  'RAIN1a: ',igs(mgs),kgs(mgs),qx(mgs,lr)
 !      ENDIF
       qx(mgs,lr) = qx(mgs,lr) +   &
-     &   dtp*(pqrwi(mgs)+pqrwd(mgs)) 
+     &   dtp*(pqrwi(mgs)+pqrwd(mgs))
 !      IF ( qx(mgs,lr) .gt. 10.0e-3 ) THEN
-!        print*, 'RAIN1b: ',igs(mgs),kgs(mgs),qx(mgs,lr)
-!        print*, pqrwi(mgs),pqrwd(mgs)
+!        write(0,*)  'RAIN1b: ',igs(mgs),kgs(mgs),qx(mgs,lr)
+!        write(0,*)  pqrwi(mgs),pqrwd(mgs)
 !       ENDIF
       qx(mgs,li) = qx(mgs,li) +   &
-     &   dtp*(pqcii(mgs)+pqcid(mgs)) 
+     &   dtp*(pqcii(mgs)+pqcid(mgs))
       qx(mgs,ls) = qx(mgs,ls) +   &
-     &   dtp*(pqswi(mgs)+pqswd(mgs)) 
+     &   dtp*(pqswi(mgs)+pqswd(mgs))
       qx(mgs,lh) = qx(mgs,lh) +    &
-     &   dtp*(pqhwi(mgs)+pqhwd(mgs)) 
+     &   dtp*(pqhwi(mgs)+pqhwd(mgs))
       IF ( lhl .gt. 1 ) THEN
       qx(mgs,lhl) = qx(mgs,lhl) +    &
      &   dtp*(pqhli(mgs)+pqhld(mgs))
@@ -11057,27 +12133,27 @@ subroutine nssl_2mom_gs   &
 
       IF ( lvol(ls) .gt. 1 ) THEN
       vx(mgs,ls) = vx(mgs,ls) +    &
-     &   dtp*(pvswi(mgs)+pvswd(mgs)) 
+     &   dtp*(pvswi(mgs)+pvswd(mgs))
       ENDIF
-      
+
       IF ( lvol(lh) .gt. 1 ) THEN
       vx(mgs,lh) = vx(mgs,lh) +    &
-     &   dtp*(pvhwi(mgs)+pvhwd(mgs)) 
+     &   dtp*(pvhwi(mgs)+pvhwd(mgs))
 !     >   rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh)
       ENDIF
 
       IF ( lhl .gt. 1 ) THEN
       IF ( lvol(lhl) .gt. 1 ) THEN
       vx(mgs,lhl) = vx(mgs,lhl) +    &
-     &   dtp*(pvhli(mgs)+pvhld(mgs)) 
+     &   dtp*(pvhli(mgs)+pvhld(mgs))
 !     >   rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh)
       ENDIF
       ENDIF
-      
+
       ENDDO
-      
+
       ENDIF  ! ldovol
-    
+
 !
 !
 !
@@ -11086,25 +12162,25 @@ subroutine nssl_2mom_gs   &
       if ( ipconc .ge. 1  ) then
       do mgs = 1,ngscnt
       cx(mgs,li) = cx(mgs,li) +   &
-     &   dtp*(pccii(mgs)+pccid(mgs)) 
+     &   dtp*(pccii(mgs)+pccid(mgs))
       IF ( ipconc .ge. 2 ) THEN
       cx(mgs,lc) = cx(mgs,lc) +   &
-     &   dtp*(pccwi(mgs)+pccwd(mgs)) 
+     &   dtp*(pccwi(mgs)+pccwd(mgs))
       ENDIF
       IF ( ipconc .ge. 3 ) THEN
       cx(mgs,lr) = cx(mgs,lr) +   &
-     &   dtp*(pcrwi(mgs)+pcrwd(mgs)) 
+     &   dtp*(pcrwi(mgs)+pcrwd(mgs))
       ENDIF
       IF ( ipconc .ge. 4 ) THEN
       cx(mgs,ls) = cx(mgs,ls) +   &
-     &   dtp*(pcswi(mgs)+pcswd(mgs)) 
+     &   dtp*(pcswi(mgs)+pcswd(mgs))
       ENDIF
       IF ( ipconc .ge. 5 ) THEN
       cx(mgs,lh) = cx(mgs,lh) +    &
-     &   dtp*(pchwi(mgs)+pchwd(mgs)) 
+     &   dtp*(pchwi(mgs)+pchwd(mgs))
        IF ( lhl .gt. 1 ) THEN
         cx(mgs,lhl) = cx(mgs,lhl) +    &
-     &     dtp*(pchli(mgs)+pchld(mgs)) 
+     &     dtp*(pchli(mgs)+pchld(mgs))
 !      IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN
 !       write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs)
 !      ENDIF
@@ -11117,7 +12193,7 @@ subroutine nssl_2mom_gs   &
 !
 ! start saturation adjustment
 !
-      if (ndebug .gt. 0 ) print*,'conc 30a'
+      if (ndebug .gt. 0 ) write(0,*) 'conc 30a'
 !      include 'sam.jms.satadj.sgi'
 !
 !
@@ -11147,7 +12223,10 @@ subroutine nssl_2mom_gs   &
       if( temg(mgs) .gt. tfr .and.   &
      &    qitmp(mgs) .gt. 0.0 ) then
       qx(mgs,lc) = qx(mgs,lc) + qitmp(mgs)
-      pfrz(mgs) = pfrz(mgs) - qitmp(mgs)/dtp
+!      pfrz(mgs) = pfrz(mgs) - qitmp(mgs)/dtp
+      ptem(mgs) =  ptem(mgs) +   &
+     &  (1./pi0(mgs))*   &
+     &  felfcp(mgs)*(- qitmp(mgs)/dtp)  
       pmlt(mgs) = pmlt(mgs) - qitmp(mgs)/dtp
       scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li)
       thetap(mgs) = thetap(mgs) -   &
@@ -11172,30 +12251,49 @@ subroutine nssl_2mom_gs   &
 !  homogeneous freezing of cloud water
 !
       IF ( warmonly < 0.8 ) THEN
-      
+
       do mgs = 1,ngscnt
       qcwtmp(mgs) = qx(mgs,lc)
       ptwfzi(mgs) = 0.0
       end do
 !
       do mgs = 1,ngscnt
-      
+
 !      if( temg(mgs) .lt. tfrh ) THEN
 !       write(0,*) 'GS: mgs,temp,qc,qi = ',mgs,temg(mgs),temcg(mgs),qx(mgs,lc),qx(mgs,li)
 !      ENDIF
 
-      qtmp = 0.0
       ctmp = 0.0
       frac = 0.0
+      qtmp = 0.0
       
-      if( temg(mgs) .lt. thnuc + 2. .and.    &
-     &  qx(mgs,lc) .gt. 0.0 ) then
-      
+!      if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and.    &
+!     &  qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then
+      if( temg(mgs) .lt. thnuc + 0. .and.    &
+     &  qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then
+
+      IF ( ibfc /= 2 .or. ipconc < 2 ) THEN
       frac = Max( 0.25, Min( 1., ((thnuc + 2.) - temg(mgs) )/4.0 ) )
-      qtmp = frac*qx(mgs,lc) 
+      ELSE
+          volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 !  Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 
+                                               ! for mean temperature for freezing: -ln (V) = a*Ts - b
+                                               ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3
+         
+         cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc)) ! number of droplets with volume greater than volt
+
+         qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc))
+         frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes 
+                                                       ! sure that cwfrz and qwfrz are consistent and prevents 
+                                                       ! spurious creation of ice crystals.
       
+      ENDIF
+      qtmp = frac*qx(mgs,lc)
+
       qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc)
       pfrz(mgs) = pfrz(mgs) + qtmp/dtp
+      ptem(mgs) =  ptem(mgs) +   &
+     &  (1./pi0(mgs))*   &
+     &  felfcp(mgs)*(qtmp/dtp)  
 !      IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qx(mgs,lc)/xdn0(li)
       IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li)
 
@@ -11204,6 +12302,7 @@ subroutine nssl_2mom_gs   &
 !        cx(mgs,li) = cx(mgs,li) + cx(mgs,lc)
         cx(mgs,li) = cx(mgs,li) + ctmp
       ELSE ! (ipconc .lt. 2 )
+        ctmp = 0.0
         IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN
            qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1)  
 
@@ -11214,7 +12313,7 @@ subroutine nssl_2mom_gs   &
      &      /gz(igs(mgs),jgs,kgs(mgs))
           cx(mgs,lc) = cwccn
         ENDIF
-       
+
        IF ( ipconc .ge. 1 ) cx(mgs,li) = Min(ccimx, cx(mgs,li) + cx(mgs,lc))
       ENDIF
 
@@ -11233,7 +12332,7 @@ subroutine nssl_2mom_gs   &
       scx(mgs,lc) = scx(mgs,lc) - sctmp
       end if
       end do
-      
+
       ENDIF ! warmonly
 !
 !      do mgs = 1,ngscnt
@@ -11244,19 +12343,53 @@ subroutine nssl_2mom_gs   &
 !
       qcond(:) = 0.0
       
-      IF ( ipconc .le. 1 ) THEN
+      IF ( ipconc .le. 1 .and.  lwsm6 ) THEN ! Explicit cloud condensation/evaporation (Rutledge and Hobbs 1983)
+       DO mgs = 1,ngscnt
+
+        qcwtmp(mgs) = qx(mgs,lc)
+        theta(mgs) = thetap(mgs) + theta0(mgs)
+        temgtmp = temg(mgs)
+!        temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap
+!        temsav = temg(mgs)
+!        thsave(mgs) = thetap(mgs)
+        temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap
+        temcg(mgs) = temg(mgs) - tfr
+        ltemq = (temg(mgs)-163.15)/fqsat+1.5
+        ltemq = Min( nqsat, Max(1,ltemq) )
+
+        qvs(mgs) = pqs(mgs)*tabqvs(ltemq)
+
+        IF ( ( qwvp(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN
+          tmp = (qwvp(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) )
+          qcond(mgs) = Min( Max( 0.0, tmp ), (qwvp(mgs)-qvs(mgs)) )
+          IF ( qx(mgs,lc) > qxmin(lc) .and. tmp < 0.0 ) THEN ! evaporation
+            qcond(mgs) = Max( tmp, -qx(mgs,lc) )
+          ENDIF
+          qwvp(mgs) = qwvp(mgs) - qcond(mgs)
+          qx(mgs,lc) = Max( 0.0, qx(mgs,lc) + qcond(mgs) )
+          thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs))
+          
+        ENDIF
+        
+        ENDDO
+      
+      ENDIF
+      
+      
+      IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN
+!      IF ( ipconc .le. 1  ) THEN
       
       do mgs = 1,ngscnt
       qx(mgs,lv) = max( 0.0, qvap(mgs) )
       qx(mgs,lc) = max( 0.0, qx(mgs,lc) )
       qx(mgs,li) = max( 0.0, qx(mgs,li) )
-      qitmp(mgs) = qx(mgs,li) 
+      qitmp(mgs) = qx(mgs,li)
       end do
 !
 !
       do mgs = 1,ngscnt
       qcwtmp(mgs) = qx(mgs,lc)
-      qitmp(mgs) = qx(mgs,li) 
+      qitmp(mgs) = qx(mgs,li)
       theta(mgs) = thetap(mgs) + theta0(mgs)
       temgtmp = temg(mgs)
       temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap
@@ -11282,7 +12415,7 @@ subroutine nssl_2mom_gs   &
       qis(mgs) = pqs(mgs)*tabqis(ltemq)
 !      qss(kz) = qvs(kz)
 !      if ( temg(kz) .lt. tfr ) then
-!      if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) 
+!      if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
 !     >  qss(kz) = qis(kz)
 !      if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li))
 !     >   qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) /
@@ -11351,7 +12484,7 @@ subroutine nssl_2mom_gs   &
 !
 ! This next line removed 3/19/2003 thanks to Adam Houston,
 !  who found the bug in the 3-ICE code
-!      qwvp(mgs) = max(qwvp(mgs), 0.0) 
+!      qwvp(mgs) = max(qwvp(mgs), 0.0)
       qitmp(mgs) = qx(mgs,li)
       IF ( qitmp(mgs) .gt. qxmin(li) ) THEN
         fcci(mgs) = qx(mgs,li)/(qitmp(mgs))
@@ -11361,8 +12494,8 @@ subroutine nssl_2mom_gs   &
       qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs)
       qx(mgs,li) = qx(mgs,li) + dqci(mgs) * fcci(mgs)
       thetap(mgs) = thetap(mgs) +   &
-     &  cpi/pi0(mgs)*   &
-     &  (felv(mgs)*dqcw(mgs) +fels(mgs)*dqci(mgs))
+     &  1./pi0(mgs)*   &
+     &  (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs))
 
       end if  ! dqwv(mgs) .lt. 0. (end of evap/sublim)
 !
@@ -11385,8 +12518,8 @@ subroutine nssl_2mom_gs   &
          end if
         fraci(mgs) = 1.0-fracl(mgs)
 !
-       gamss = (felv(mgs)*fracl(mgs) + fels(mgs)*fraci(mgs))   &
-     &      / (pi0(mgs)*cp)
+       gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs))   &
+     &      / (pi0(mgs))
 !
       IF ( temg(mgs) .lt. tfr ) then
         IF (qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) then
@@ -11425,8 +12558,8 @@ subroutine nssl_2mom_gs   &
       dqci(mgs) = dqvcnd(mgs)*fraci(mgs)
 !
       thetap(mgs) = thetap(mgs) +   &
-     &   (felv(mgs)*dqcw(mgs) + fels(mgs)*dqci(mgs))   &
-     & / (pi0(mgs)*cp)
+     &   (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs))   &
+     & / (pi0(mgs))
       qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) )
       qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs)
       IF ( qitmp(mgs) .gt. qxmin(li) ) THEN
@@ -11485,23 +12618,20 @@ subroutine nssl_2mom_gs   &
       end do
 
      ENDIF ! ( ipconc .le. 1 )
-      
+
 !
 !  spread the growth owing to vapor diffusion onto the
 !  ice crystal categories using the
 !
 !  END OF SATURATION ADJUSTMENT
-!            
+!
 
-      if (ndebug .gt. 0 ) print*,'conc 30b'
+      if (ndebug .gt. 0 ) write(0,*) 'conc 30b'
 !
 !
 !  end of saturation adjustment
 !
 !
-!
-!
-!
 ! !DIR$ IVDEP
       do mgs = 1,ngscnt
       t0(igs(mgs),jy,kgs(mgs)) =  temg(mgs)
@@ -11511,13 +12641,13 @@ subroutine nssl_2mom_gs   &
 !
 
 
-      if (ndebug .gt. 0 ) print*,'gs 11'
+      if (ndebug .gt. 0 ) write(0,*) 'gs 11'
 
       do mgs = 1,ngscnt
 !
       an(igs(mgs),jy,kgs(mgs),lt) =    &
      &  theta0(mgs) + thetap(mgs) 
-      an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) 
+      an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) ! qv0(mgs) is zero, so qwvp is the FULL qv!
 !
       
       DO il = lc,lhab
@@ -11529,18 +12659,25 @@ subroutine nssl_2mom_gs   &
       ENDDO
 
 
-
 !
       end do
 !
 
       if ( ipconc .ge. 1 ) then
-! !DIR$ IVDEP
-      DO il = lc,lhab
+      DO il = lc,lhab !{
 
-        IF ( ipconc .ge. ipc(il) ) THEN
+!        write(0,*) 'limiter loop: il,ipc,lz: ',il,ipc(il),lz(il),ipconc
+
+       IF ( ipconc .ge. ipc(il) ) THEN ! {
+
+         IF (  ipconc .ge. 4 .and. ipc(il) .ge. 3 ) THEN ! {
+
+!            write(0,*) 'MY limiter: il,ipc,lz: ',il,ipc(il),lz(il),lr,lzr
+!            STOP
+
+          IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN ! { { is a two-moment category so dont worry about reflectivity
+          
 
-         IF (  ipconc .ge. 4 .and. ipc(il) .ge. 4 ) THEN
            DO mgs = 1,ngscnt
             IF ( qx(mgs,il) .le. 0.0 ) THEN
               cx(mgs,il) = 0.0
@@ -11561,14 +12698,23 @@ subroutine nssl_2mom_gs   &
 !              ENDIF
 
             ENDIF
-          ENDDO
-        ENDIF
+           ENDDO ! mgs
+          
+          
+          ENDIF ! }}
+          ENDIF ! }
 
           DO mgs = 1,ngscnt
             an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0)
           ENDDO
-        ENDIF
-      ENDDO
+        ENDIF ! }
+      ENDDO ! il }
+
+      IF (   lcin > 1 ) THEN
+      do mgs = 1,ngscnt
+        an(igs(mgs),jy,kgs(mgs),lcin) = Max(0.0, ccin(mgs))
+      end do
+      ENDIF
 
       IF (  ipconc .ge. 2 ) THEN
       do mgs = 1,ngscnt
@@ -11582,19 +12728,19 @@ subroutine nssl_2mom_gs   &
       
           DO mgs = 1,ngscnt
             an(igs(mgs),jy,kgs(mgs),lni) = Max(cx(mgs,li), 0.0)
-          ENDDO      
+          ENDDO
 
 
-      end if 
+      end if
 
       IF ( ldovol ) THEN
-      
+
        DO il = li,lhab
-        
+
         IF ( lvol(il) .ge. 1 ) THEN
-          
+
           DO mgs = 1,ngscnt
-          
+
            an(igs(mgs),jy,kgs(mgs),lvol(il)) = Max( 0.0, vx(mgs,il) )
           ENDDO
           
@@ -11608,10 +12754,12 @@ subroutine nssl_2mom_gs   &
 !
 !
 !
-      if (ndebug .gt. 0 ) print*,'gs 12'
+      if (ndebug .gt. 0 ) write(0,*) 'gs 12'
+
+
+
+      if (ndebug .gt. 0 ) write(0,*) 'gs 13'
 
-      if (ndebug .gt. 0 ) print*,'gs 13'
-      
  9998 continue
 
       if ( kz .gt. nz-1 .and. ix .ge. nx) then
@@ -11621,7 +12769,7 @@ subroutine nssl_2mom_gs   &
          nzmpb = kz
         endif
       else
-        nzmpb = kz 
+        nzmpb = kz
       end if
 
       if ( ix .ge. nx ) then
@@ -11630,7 +12778,7 @@ subroutine nssl_2mom_gs   &
       else
        nxmpb = ix+1
       end if
- 
+
  1000 continue
  1200 continue
 !
@@ -11653,10 +12801,10 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
      &                 ipconc1,ndebug1,ngs,nz,kgs,fadvisc,   &
      &                 cwmasn,cwmasx,cwradn,cnina,cimna,cimxa,      &
      &                 itype1a,itype2a,temcg,infdo,alpha,ildo)
-      
-      
+
+
       implicit none
-      
+
 !      include 'sam.index.ion.h'
 !      include 'swm.index.zieg.h'
       
@@ -11694,6 +12842,9 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
       
 ! Local vars
 
+      real :: axh(ngs0),bxh(ngs0)
+      real :: axhl(ngs0),bxhl(ngs0)
+
       real cd
       real cwc0 ! ,cwc1
       real :: cwch(ngscnt), cwchl(ngscnt)
@@ -11726,10 +12877,12 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
       real bta1,cnit
       parameter ( bta1 = 0.6, cnit = 1.0e-02 )
       real x,y,tmp,del
-      real aax
+      real aax,bbx,delrho
+      integer :: indxr
       real mwt
       real, parameter :: rho00 = 1.225
       integer i
+      real xvbarmax
 
       integer l1, l2
 
@@ -11825,10 +12978,9 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
           ENDDO
         
         ENDIF
-!      ENDIF
        
 
-      cimasn = 6.88e-13 
+      cimasn = Min( cimas0, 6.88e-13)
       cimasx = 1.0e-8
       ccimx = 5000.0e3   ! max of 5000 per liter
 
@@ -11857,7 +13009,7 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
       
       IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN !{
       
-      IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN !{
+      IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e-9 ) THEN !{
         xmas(mgs,lc) =  &
      &    min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx )
         xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
@@ -11876,9 +13028,11 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
        ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN
         xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3
         cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)
+        xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc)
         
        ELSE
         xmas(mgs,lc) = cwmasn
+        xv(mgs,lc) = xmas(mgs,lc)/1000.
 ! do not define ccw here! it can feed back to ccn!!!    cx(mgs,lc) = 0.0 ! cwnc(mgs)
        ENDIF !}
       ENDIF !}
@@ -11908,6 +13062,7 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
        IF ( ipconc .le. 1 ) cx(mgs,lc) = 0.01
        xdia(mgs,lc,1) = 2.*cwradn
        xdia(mgs,lc,2) = 4.*cwradn**2
+       xdia(mgs,lc,3) = xdia(mgs,lc,1)
        vtxbar(mgs,lc,1) = 0.0
        
       ENDIF !} qcw .gt. qxmin(lc)
@@ -11971,8 +13126,13 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
 !       xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429))
 
 !       xdia(mgs,li,1) = (132.694*5.40662/xmas(mgs,li))**(-1./2.9163)  ! for inverse exponential distribution
+       IF ( ixtaltype == 1 ) THEN ! column
        xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429))
        xdia(mgs,li,3) = 0.1871*(xmas(mgs,li)**(0.3429))
+       ELSEIF  ( ixtaltype == 2 ) THEN ! disk
+        xdia(mgs,li,1) = 0.277823*xmas(mgs,li)**0.359971
+        xdia(mgs,li,3) = 0.277823*xmas(mgs,li)**0.359971
+       ENDIF
       end if
 !      end if
 !      xdia(mgs,li,1) = max(xdia(mgs,li,1), 5.e-6)
@@ -11982,11 +13142,20 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
 !      vtxbar(mgs,li,1) = rhovt(mgs)*49420.*40.0005/5.40662*xdia(mgs,li,1)**(1.415) ! mass-weighted
 !      vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150))
         xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li)
+        IF ( ixtaltype == 1 ) THEN ! column
+        tmp = (67056.6300748612*rhovt(mgs))/  &
+     &   (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1)
+        vtxbar(mgs,li,2) = tmp*gfcinu1p47
+        vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu)
+        vtxbar(mgs,li,3) = vtxbar(mgs,li,1) 
+        ELSEIF  ( ixtaltype == 2 ) THEN ! disk -- but just use column fall speed for now
         tmp = (67056.6300748612*rhovt(mgs))/  &
      &   (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1)
         vtxbar(mgs,li,2) = tmp*gfcinu1p47
         vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu)
         vtxbar(mgs,li,3) = vtxbar(mgs,li,1) 
+        
+        ENDIF
 !      vtxbar(mgs,li,1) = vtxbar(mgs,li,2)*(1.+cinu)/(1. + cinu)
 !      xdn(mgs,li)   = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0)
 !      xdn(mgs,li) = 900.0
@@ -12007,6 +13176,7 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
        xdn(mgs,li)  = 900.0
        xdia(mgs,li,1) = 1.e-7
        xdia(mgs,li,2) = (1.e-14)
+       xdia(mgs,li,3) = 1.e-7
        vtxbar(mgs,li,1) = 0.0
 !       cicap(mgs) = 0.0
 !       ciat(mgs) = 0.0
@@ -12027,22 +13197,35 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
       if ( qx(mgs,lr) .gt. qxmin(lr) ) then
       
 !      IF ( qx(mgs,lr) .gt. 10.0e-3 ) &
-!     &  print*, 'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr)
+!     &  write(0,*)  'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr)
       
       if ( ipconc .ge. 3 ) then
         xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr)))
-        IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN
-          xv(mgs,lr) = xvmx(lr)
-          cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr))
+        xvbarmax = xvmx(lr)
+        IF ( imaxdiaopt == 1 ) THEN
+          xvbarmax = xvmx(lr)
+        ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter
+         IF ( imurain == 1 ) THEN
+           xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr))))
+         ELSEIF ( imurain == 3 ) THEN
+           
+         ENDIF
+        ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter
+         IF ( imurain == 1 ) THEN
+           xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr))))
+         ELSEIF ( imurain == 3 ) THEN
+           
+         ENDIF
+        ENDIF
+       
+        IF ( xv(mgs,lr) .gt. xvbarmax ) THEN
+          xv(mgs,lr) = xvbarmax
+          cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*xdn(mgs,lr))
         ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN
           xv(mgs,lr) = xvmn(lr)
           cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr))
         ENDIF
-       IF ( .not. ( cx(mgs,lr) < 1.e30 .and. cx(mgs,lr) > -1.e20 ) ) THEN
-         write(0,*) 'setvt: problem with cx(mgs,lr)! ',qx(mgs,lr),cx(mgs,lr),xvmx(lr),xdn(mgs,lr),rho0(mgs)
-         write(0,*) 'mgs,ngs,ngscnt,ngs0 = ',mgs,ngs,ngscnt,ngs0
-         STOP
-       ENDIF
+
 
         xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr)
         xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1)
@@ -12110,6 +13293,7 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
       end if
       else
       xdia(mgs,ls,1) = 1.e-9
+      xdia(mgs,ls,3) = 1.e-9
       cx(mgs,ls) = 0.0
       end if
       xdia(mgs,ls,2) = xdia(mgs,ls,1)**2
@@ -12156,6 +13340,7 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
       end if
       else
       xdia(mgs,lh,1) = 1.e-9
+      xdia(mgs,lh,3) = 1.e-9
       end if
       xdia(mgs,lh,2) = xdia(mgs,lh,1)**2
 !      hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1)
@@ -12203,6 +13388,7 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
       end if
       else
       xdia(mgs,lhl,1) = 1.e-9
+      xdia(mgs,lhl,3) = 1.e-9
       end if
       xdia(mgs,lhl,2) = xdia(mgs,lhl,1)**2
 !      hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1)
@@ -12236,23 +13422,30 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
       do mgs = 1,ngscnt
       if ( qx(mgs,lr) .gt. qxmin(lr) ) then
       IF ( ipconc .lt. 3 ) THEN
-        vtxbar(mgs,lr,1) = (ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs)
+        vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs)
 !        write(91,*) 'vtxbar: ',vtxbar(mgs,lr,1),mgs,gf4br,xdia(mgs,lr,1),rhovt(mgs)
       ELSE
         
         IF ( imurain == 1 ) THEN ! DSD of Diameter
         
+        ! using functional form of  arx*(1 - Exp(-frx*diameter) ), with arx =       arx = 10.
+        !  and frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters.
+
+        
           alp = alpha(mgs,lr)
           
-          IF ( infdo .ge. 1 ) THEN
+          vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted
+          
+          IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN
             vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ! number weighted
+          ELSE
+            vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1)
           ENDIF
-        
-            vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted
-          
           
-          IF ( infdo .ge. 2 ) THEN
+          IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN
             vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ! z-weighted
+          ELSE
+            vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1)
           ENDIF
           
 !          write(91,*) 'setvt: alp,vn,vm,vz = ',alp,vtxbar(mgs,lr,2), vtxbar(mgs,lr,1), vtxbar(mgs,lr,3),alpha(mgs,lr)
@@ -12284,7 +13477,7 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
         vr = xv(mgs,lr)
         rnux = alpha(mgs,lr)
         
-        IF ( infdo .ge. 1 ) THEN ! number-weighted
+        IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag
         vtxbar(mgs,lr,2) = rhovt(mgs)*                             &
      &     (((1. + rnux)/vr)**(-1.333333)*                         &
      &    (0.0911229*((1. + rnux)/vr)**1.333333*Gamma(1. + rnux) + &
@@ -12307,9 +13500,13 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
      &    8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma(3 + rnux) -      &
      &    2.3303765697228556e9*vr**1.3333333333333333*                                 &
      &     Gamma(3.333333333333333 + rnux))/                                           &
-     &  ((1 + rnux)**2.333333333333333*Gamma(1 + rnux))      
+     &  ((1 + rnux)**2.333333333333333*Gamma(1 + rnux)) 
+     
+        IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted
+          vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1)
+        ENDIF     
       
-        IF ( infdo .ge. 2 ) THEN ! Z-weighted fall speed
+        IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed
         vtxbar(mgs,lr,3)  =   rhovt(mgs)*                                          &
      &  ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma(3. + rnux) +  &
      &      5430.313059683277*(1 + rnux)*vr**0.3333333333333333*                   &
@@ -12324,6 +13521,8 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
 !         write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo
 !         write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3)
         
+        ELSEIF (infdo .ge. 2) THEN ! No size-sorting, set Z-weighted fall speed to mass-weighted
+          vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1)
         ENDIF
         
         
@@ -12360,8 +13559,12 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
         IF ( ipconc .ge. 4 ) THEN
          if ( mixedphase .and. qsvtmod ) then
          else
-          vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.)
-          vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.)
+           vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.)
+          IF(sssflg == 1) THEN
+            vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.)
+          ELSE
+            vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1)
+          ENDIF
           vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1)
          endif
         ELSE
@@ -12401,14 +13604,35 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
      &        (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) )
        ELSEIF ( icdx .eq. 5 ) THEN
          cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2/3)
+       ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
+         indxr = Int( (xdn(mgs,lh)-50.)/100. ) + 1
+         indxr = Min( ngdnmm, Max(1,indxr) )
+         
+         
+         delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) )
+         IF ( indxr < ngdnmm ) THEN
+          
+          axh(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) )
+          bxh(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) )
+
+          
+         ELSE
+          axh(mgs) = mmgraupvt(indxr,2)
+          bxh(mgs) = mmgraupvt(indxr,3)
+         ENDIF
+         
+         aax = axh(mgs)
+         bbx = bxh(mgs)
+         
        ENDIF
        
-      IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 ) THEN
+      IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN
       vtxbar(mgs,lh,1) = (gf4p5/6.0)*  &
      &  Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) /  &
      &    (3.0*cd*rho0(mgs)) )
       ELSE
-        tmp = 4. + alpha(mgs,lh) + bx(lh)
+        IF ( icdx /= 6 ) bbx = bx(lh)
+        tmp = 4. + alpha(mgs,lh) + bbx
         i = Int(dgami*(tmp))
         del = tmp - dgam*i
         x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
@@ -12421,9 +13645,11 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
 !        aax = Max( 1.0, Min(2.0, (xdn(mgs,lh)/400.) ) )
 !        vtxbar(mgs,lh,1) =  rhovt(mgs)*aax*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y
         
-        IF ( icdx > 0 ) THEN
+        IF ( icdx > 0 .and. icdx /= 6) THEN
           aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00))
           vtxbar(mgs,lh,1) =  rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y
+        ELSEIF (icdx == 6 ) THEN
+          vtxbar(mgs,lh,1) =  rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y
         ELSE
           vtxbar(mgs,lh,1) =  rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y          
         ENDIF
@@ -12431,6 +13657,11 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
 !     &    Gamma(4.0 + dnu(lh) + 0.6))/Gamma(4. + dnu(lh))
       ENDIF
 
+      IF ( lwsm6 .and. ipconc == 0 ) THEN
+!         vtxbar(mgs,lh,1) = (330.*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs)
+         vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs)
+      ENDIF
+      
       end if
       end do
       if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt'
@@ -12456,6 +13687,26 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
        ELSEIF ( icdxhl .eq. 4 ) THEN
          cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)*  &
      &       (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) )
+       ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
+         indxr = Int( (xdn(mgs,lhl)-50.)/100. ) + 1
+         indxr = Min( ngdnmm, Max(1,indxr) )
+         
+         
+         delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) )
+         IF ( indxr < ngdnmm ) THEN
+          
+          axhl(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) )
+          bxhl(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) )
+
+          
+         ELSE
+          axhl(mgs) = mmgraupvt(indxr,2)
+          bxhl(mgs) = mmgraupvt(indxr,3)
+         ENDIF
+         
+         aax = axhl(mgs)
+         bbx = bxhl(mgs)
+         
        ELSE
 !         cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) )
 !        cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) )
@@ -12467,7 +13718,8 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
      &  Sqrt( (xdn(mgs,lhl)*xdia(mgs,lhl,1)*4.0*gr) / &
      &    (3.0*cd*rho0(mgs)) )
       ELSE
-        tmp = 4. + alpha(mgs,lhl) + bx(lhl)
+        IF ( icdx /= 6 ) bbx = bx(lhl)
+        tmp = 4. + alpha(mgs,lhl) + bbx
         i = Int(dgami*(tmp))
         del = tmp - dgam*i
         x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
@@ -12477,9 +13729,11 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
         del = tmp - dgam*i
         y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
 
-        IF ( icdxhl > 0 ) THEN
+        IF ( icdxhl > 0 .and. icdxhl /= 6) THEN
           aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00))
           vtxbar(mgs,lhl,1) =  rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y
+        ELSEIF ( icdx == 6 ) THEN
+          vtxbar(mgs,lhl,1) =  rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y
         ELSE
          vtxbar(mgs,lhl,1) =  rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y
         ENDIF
@@ -12523,7 +13777,10 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
 
             DO mgs = 1,ngscnt
              IF ( qx(mgs,il) .gt. qxmin(il) ) THEN
-              IF ( il .eq. lh .or. ( lhl .gt. 1 .and. il .eq. lhl ) ) THEN
+              IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN ! DTD: added flag for size-sorting
+              
+              ! DTD: allow for setting of number-weighted and z-weighted fall speeds to the mass-weighted value,
+              ! effectively turning off size-sorting
 
               IF ( il .eq. lh ) THEN ! {
              
@@ -12542,6 +13799,9 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
      &            (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) )
                ELSEIF ( icdx .eq. 5 ) THEN
                  cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2/3)
+               ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
+                  aax = axh(mgs)
+                  bbx = bxh(mgs)
                ENDIF
                
               ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN
@@ -12554,22 +13814,27 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
                ELSEIF ( icdxhl .eq. 4 ) THEN
                 cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)*  &
      &               (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) )
-               ELSE
+               ELSEIF ( icdxhl == 5 ) THEN
 !                cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) )
 !                cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) )
                  cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) )
+               ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013)
+                  aax = axhl(mgs)
+                  bbx = bxhl(mgs)
                ENDIF
                
               ENDIF ! }
 
                IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and.   &
-               ( ( il==lh .and. icdx > 0 ) .or. ( il==lhl .and. icdxhl > 0 ) ) ) THEN ! {
+               ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! {
                  vtxbar(mgs,il,2) =   &
      &              Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / &
      &                (3.0*cd*rho0(mgs)) )
 
                ELSE
-               tmp = 1. + alpha(mgs,il) + bx(il)
+               IF ( il == lh  .and. icdx   /= 6 ) bbx = bx(il)
+               IF ( il == lhl .and. icdxhl /= 6 ) bbx = bx(il)
+               tmp = 1. + alpha(mgs,il) + bbx
                i = Int(dgami*(tmp))
                del = tmp - dgam*i
                x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
@@ -12581,19 +13846,27 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
 
                  IF ( il .eq. lh  .or. il .eq. lhl) THEN ! {
                    IF ( ( il==lh .and. icdx > 0 ) ) THEN
-                     aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00))
-                     vtxbar(mgs,il,2) =  rhovt(mgs)*aax* xdia(mgs,il,1)**0.5 * x/y
+                     IF ( icdx /= 6 ) THEN
+                      aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00))
+                      vtxbar(mgs,il,2) =  rhovt(mgs)*aax* xdia(mgs,il,1)**0.5 * x/y
+                     ELSE !  (icdx == 6 ) THEN
+                       vtxbar(mgs,il,2) =  rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y
+                     ENDIF
 !                   ELSE
 !                     aax = ax(il)
-!                     vtxbar(mgs,il,2) =  rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y          
+!                     vtxbar(mgs,il,2) =  rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y
 !                   ENDIF
 
                    ELSEIF ( ( il==lhl .and. icdxhl > 0 ) ) THEN
-                     aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00))
-                     vtxbar(mgs,il,2) =  rhovt(mgs)*aax* xdia(mgs,il,1)**0.5 * x/y
+                     IF ( icdxhl /= 6 ) THEN
+                       aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00))
+                       vtxbar(mgs,il,2) =  rhovt(mgs)*aax* xdia(mgs,il,1)**0.5 * x/y
+                     ELSE ! ( icdxhl == 6 )
+                       vtxbar(mgs,il,2) =  rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y
+                     ENDIF
                    ELSE
                      aax = ax(il)
-                     vtxbar(mgs,il,2) =  rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y          
+                     vtxbar(mgs,il,2) =  rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y
                    ENDIF
 
 !                  vtxbar(mgs,il,2) =  &
@@ -12636,7 +13909,9 @@ SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
 !               IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN
 !                write(0,*) 'setvt: ',qx(mgs,il),xdia(mgs,il,1),xdia(mgs,il,3),dnu(il),ax(il),bx(il)
 !               ENDIF
-
+             ELSEIF ( (il .eq. lh .and. hssflg == 0) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 0) ) THEN ! no size-sorting for graupel or hail
+              vtxbar(mgs,il,2) = vtxbar(mgs,il,1)
+              vtxbar(mgs,il,3) = vtxbar(mgs,il,1)
              ELSE ! not lh or lhl
               vtxbar(mgs,il,2) = &
      &            Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) /  &
@@ -12702,7 +13977,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
      &  ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, &
      &  rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, &
      &  cnostmp,                     &
-     &  infdo,ildo)
+     &  infdo,ildo,timesetvt)
 
 ! 12.16.2005: .F version use in transitional SWM model
 !
@@ -12718,7 +13993,6 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
 !
       
       implicit none
-
       integer ng1
       parameter(ng1 = 1)
       
@@ -12746,6 +14020,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
       real qxmin(lc:lhab)
       real xdn0(lc:lhab)
       real xvmn(lc:lhab), xvmx(lc:lhab)
+      double precision,optional :: timesetvt
 
       integer :: ngs
       integer :: ngscnt,mgs,ipconc0
@@ -12816,6 +14091,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
       real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp
       
       real vtmax
+      real xvbarmax
       
       integer l1, l2
       
@@ -12884,7 +14160,8 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
       nxmpb = ixcol
       nzmpb = 1
       nxz = 1*nz
-      numgs = nxz/ngs + 1
+!      ngs = nz
+      numgs = 1
 
       IF ( ildo == 0 ) THEN
         l1 = lc
@@ -12916,7 +14193,9 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
         kgs(ngscnt) = kz
         if ( ngscnt .eq. ngs ) goto 1100
         end if
+!#ifndef MPI
         end do !!ix
+!#endif
         nxmpb = 1
        end do !! kz
 
@@ -12929,6 +14208,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
 !  set temporaries for microphysics variables
 !
 
+
 !
 !  Reconstruct various quantities 
 !
@@ -12974,6 +14254,12 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
       end do
       
       cnostmp(:) = cno(ls)
+      IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN
+        DO mgs = 1,ngscnt
+          tmp = Min( 0.0, temcg(mgs) )
+          cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) )
+        ENDDO
+      ENDIF
 
 
 !
@@ -12983,7 +14269,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
       
       if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then
        do mgs = 1,ngscnt
-        cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni)*rho0(mgs), 0.0)
+        cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0)
        end do
       end if
       if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then
@@ -13086,18 +14372,20 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
 
 
 
+
 !
 !  Set density
 !
       if (ndebugzf .gt. 0 ) write(0,*)  'ZIEGFALL: call setvtz'
 !
-
+      
       call setvtz(ngscnt,ngs,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp,   &
      &                 xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx,        &
      &                 ipconc,ndebugzf,ngs,nz,kgs,fadvisc, &
      &                 cwmasn,cwmasx,cwradn,cnina,cimn,cimx,    &
      &                 itype1,itype2,temcg,infdo,alpha,ildo)
 
+
 !
 ! put fall speeds into the x-z arrays
 !
@@ -13145,6 +14433,8 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
 
       if (ndebugzf .gt. 0 ) write(0,*)  'ZIEGFALL: COPIED FALL SPEEDS'
 
+
+
  9998 continue
 
       if (ndebugzf .gt. 0 ) write(0,*)  'ZIEGFALL: DONE WITH LOOP'
@@ -13155,11 +14445,11 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
         nzmpb = kz 
       end if
 
-      if (ndebugzf .gt. 0 ) print*,'ZIEGFALL: SET NZMPB'
+      if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB'
 
       end do !! inumgs
 
-      if (ndebugzf .gt. 0 ) print*,'ZIEGFALL: SET NXMPB'
+      if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NXMPB'
 
  1200 continue
 
@@ -13255,7 +14545,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
       real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor)   ! reflectivity
       real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4)
       
-      real g,cv,cp,rgas,rcp,eta,inveta,rcpinv,cpr,cvr
+!      real g,rgas,eta,inveta
       real cr1, cr2 ,  hwdnsq,swdnsq
       real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc
       real reflectmin,  kw_sq
@@ -13328,16 +14618,14 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
       
       izieg = 0
       ice10 = 0
-      g=9.806                 ! g: gravity constant
-      cv=717.0                ! cv: specific heat at constant volume
-      cp=1004.0               ! cp: specific heat at constant pressure
-      rgas=287.04             ! rgas: gas constant for dry air
-      rcp=rgas/cp             ! rcp: gamma constant
-      eta=0.622
-      inveta = 1./eta
-      rcpinv = 1./rcp
-      cpr=cp/rgas
-      cvr=cv/rgas
+!      g=9.806                 ! g: gravity constant
+!      rgas=287.04             ! rgas: gas constant for dry air
+!      rcp=rgas/cp             ! rcp: gamma constant
+!      eta=0.622
+!      inveta = 1./eta
+!      rcpinv = 1./rcp
+!      cpr=cp/rgas
+!      cvr=cv/rgas
       pi = 4.0*ATan(1.)
       cwc0 = piinv ! 1./pi ! 6.0/pi
       
@@ -13375,7 +14663,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
 
        IF ( microp(1:4) .eq. 'ZIEG' ) THEN !  na .ge. 14 .and. ipconc .ge. 3 ) THEN 
 
-!        print*, 'Set reflectivity for ZIEG'
+!        write(0,*)  'Set reflectivity for ZIEG'
          izieg = 1
 
          hwdn = hwdn1t ! 500.
@@ -13601,7 +14889,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
 
       DO jy=1,1
 
-        DO kz = 1,nz-1
+        DO kz = 1,nz
          
           DO ix=1,nx
             dbz(ix,jy,kz) = 0.0
@@ -13627,8 +14915,15 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
                gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25)
                dtmp(ix,kz) = zrc*gtmp(ix,kz)**7
              ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN
-               vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr))
-               dtmp(ix,kz) = 3.6e18*(rnu+2)*an(ix,jy,kz,lnr)*vr**2/(rnu+1)
+               IF ( imurain == 3 ) THEN
+                 vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr))
+                 dtmp(ix,kz) = 3.6e18*(rnu+2.)*an(ix,jy,kz,lnr)*vr**2/(rnu+1.)
+               ELSE ! imurain == 1
+                g1 = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
+                zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lr))**2/an(ix,jy,kz,lnr)
+                ze =1.e18*zx*(6./(pi*1000.))**2 ! note: using 1000. here for water density
+                dtmp(ix,kz) = ze
+               ENDIF
              ENDIF
              dtmpr = dtmp(ix,kz)
            ENDIF
@@ -13890,7 +15185,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
              
             ENDIF
              
-        !     IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) print*, 'Graupel Z : ',dtmph,ze
+        !     IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*)  'Graupel Z : ',dtmph,ze
            ENDIF
           
           ELSE
@@ -13984,7 +15279,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
              
              ENDIF !}
             ENDIF!}
-        !     IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) print*, 'Graupel Z : ',dtmph,ze
+        !     IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*)  'Graupel Z : ',dtmph,ze
            ENDIF
 
           
@@ -14047,19 +15342,21 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
 
 !         IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and. 
 !     &        dbz(ix,jy,kz) .le. 0.0 ) THEN
-!          print*,'dbz = ',dbz(ix,jy,kz)
-!          print*,'Hail intercept: ',xcnoh,ix,kz
-!          print*,'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls)
-!          print*,'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns)
-!          print*,'dtmps,dtmph = ',dtmps,dtmph
+!          write(0,*) 'dbz = ',dbz(ix,jy,kz)
+!          write(0,*) 'Hail intercept: ',xcnoh,ix,kz
+!          write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls)
+!          write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns)
+!          write(0,*) 'dtmps,dtmph = ',dtmps,dtmph
 !         ENDIF
-        IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 90.0 ) THEN
+        IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN
 !        IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN
 !          write(0,*) 'my_rank = ',my_rank
           write(0,*) 'ix,jy,kz = ',ix,jy,kz
           write(0,*) 'dbz = ',dbz(ix,jy,kz)
+          write(0,*) 'db, zhdryc = ',db(ix,jy,kz),zhdryc
           write(0,*) 'Hail intercept: ',xcnoh,ix,kz
           write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls)
+          write(0,*) 'graupel density hwdn = ',hwdn
           write(0,*) 'rain q: ',an(ix,jy,kz,lr)
           write(0,*) 'ice q: ',an(ix,jy,kz,li)
           IF ( lhl .gt. 1 ) write(0,*) 'Hail (lhl): ',an(ix,jy,kz,lhl)
@@ -14092,7 +15389,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
       
       
       
-!      print*, 'na,lr = ',na,lr
+!      write(0,*)  'na,lr = ',na,lr
       IF ( printyn .eq. 1 ) THEN
 !      IF ( dbzmax .gt. dbzmin ) THEN
         write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx
@@ -14109,7 +15406,6 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
       ENDIF
       
       
-      
       RETURN
       END subroutine radardd02
       
@@ -14117,5 +15413,5 @@ END subroutine radardd02
 ! ##############################################################################
 ! ##############################################################################
 
-      
+
 END MODULE module_mp_nssl_2mom
diff --git a/wrfv2_fire/phys/module_mp_thompson.F b/wrfv2_fire/phys/module_mp_thompson.F
index cb841e22..648db6ba 100644
--- a/wrfv2_fire/phys/module_mp_thompson.F
+++ b/wrfv2_fire/phys/module_mp_thompson.F
@@ -11,6 +11,15 @@
 !.. described in the reference above, but in v3.1 and higher, the
 !.. scheme is two-moment rain (predicted rain number concentration).
 !..
+!.. Beginning with WRFv3.6, this is also the "aerosol-aware" scheme as
+!.. described in Thompson, G. and T. Eidhammer, 2014:  A study of
+!.. aerosol impacts on clouds and precipitation development in a large
+!.. winter cyclone.  J. Atmos. Sci., 1??, ????-????.  Setting WRF
+!.. namelist option mp_physics=8 utilizes the older one-moment cloud
+!.. water with constant droplet concentration set as Nt_c (found below)
+!.. while mp_physics=28 uses double-moment cloud droplet number
+!.. concentration, which is not permitted to exceed Nt_c_max below.
+!..
 !.. Most importantly, users may wish to modify the prescribed number of
 !.. cloud droplets (Nt_c; see guidelines mentioned below).  Otherwise,
 !.. users may alter the rain and graupel size distribution parameters
@@ -27,7 +36,7 @@
 !.. Remaining values should probably be left alone.
 !..
 !..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805
-!..Last modified: 27 Jul 2012
+!..Last modified: 19 Mar 2014   Aerosol additions to v3.5.1 code 9/2013
 !+---+-----------------------------------------------------------------+
 !wrft:model_layer:physics
 !+---+-----------------------------------------------------------------+
@@ -36,12 +45,14 @@ MODULE module_mp_thompson
 
       USE module_wrf_error
       USE module_mp_radar
-      USE module_utility, ONLY: WRFU_Clock, WRFU_Alarm
-      USE module_domain, ONLY : HISTORY_ALARM, Is_alarm_tstep
 
       IMPLICIT NONE
 
       LOGICAL, PARAMETER, PRIVATE:: iiwarm = .false.
+      LOGICAL, PRIVATE:: is_aerosol_aware = .false.
+      LOGICAL, PARAMETER, PRIVATE:: dustyIce = .true.
+      LOGICAL, PARAMETER, PRIVATE:: homogIce = .true.
+
       INTEGER, PARAMETER, PRIVATE:: IFDRY = 0
       REAL, PARAMETER, PRIVATE:: T_0 = 273.15
       REAL, PARAMETER, PRIVATE:: PI = 3.1415926536
@@ -56,8 +67,19 @@ MODULE module_mp_thompson
 !.. roughly 100 per cc (100.E6 m^-3) for Maritime cases and
 !.. 300 per cc (300.E6 m^-3) for Continental.  Gamma shape parameter,
 !.. mu_c, calculated based on Nt_c is important in autoconversion
-!.. scheme.
+!.. scheme.  In 2-moment cloud water, Nt_c represents a maximum of
+!.. droplet concentration and nu_c is also variable depending on local
+!.. droplet number concentration.
       REAL, PARAMETER, PRIVATE:: Nt_c = 100.E6
+      REAL, PARAMETER, PRIVATE:: Nt_c_max = 1999.E6
+
+!..Declaration of constants for assumed CCN/IN aerosols when none in
+!.. the input data.  Look inside the init routine for modifications
+!.. due to surface land-sea points or vegetation characteristics.
+      REAL, PARAMETER, PRIVATE:: naIN0 = 1.5E6
+      REAL, PARAMETER, PRIVATE:: naIN1 = 0.5E6
+      REAL, PARAMETER, PRIVATE:: naCCN0 = 300.0E6
+      REAL, PARAMETER, PRIVATE:: naCCN1 = 50.0E6
 
 !..Generalized gamma distributions for rain, graupel and cloud ice.
 !.. N(D) = N_0 * D**mu * exp(-lamda*D);  mu=0 is exponential.
@@ -65,6 +87,7 @@ MODULE module_mp_thompson
       REAL, PARAMETER, PRIVATE:: mu_g = 0.0
       REAL, PARAMETER, PRIVATE:: mu_i = 0.0
       REAL, PRIVATE:: mu_c
+      INTEGER, PRIVATE:: nu_c
 
 !..Sum of two gamma distrib for snow (Field et al. 2005).
 !.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3)
@@ -108,6 +131,8 @@ MODULE module_mp_thompson
       REAL, PARAMETER, PRIVATE:: bv_g = 0.89
       REAL, PARAMETER, PRIVATE:: av_i = 1847.5
       REAL, PARAMETER, PRIVATE:: bv_i = 1.0
+      REAL, PARAMETER, PRIVATE:: av_c = 0.316946E8
+      REAL, PARAMETER, PRIVATE:: bv_c = 2.0
 
 !..Capacitance of sphere and plates/aggregates: D**3, D**2
       REAL, PARAMETER, PRIVATE:: C_cube = 0.5
@@ -149,6 +174,14 @@ MODULE module_mp_thompson
       REAL, PARAMETER, PRIVATE:: oRv = 1./Rv
       REAL, PARAMETER, PRIVATE:: R = 287.04
       REAL, PARAMETER, PRIVATE:: Cp = 1004.0
+      REAL, PARAMETER, PRIVATE:: R_uni = 8.314                           ! J (mol K)-1
+
+      DOUBLE PRECISION, PARAMETER, PRIVATE:: k_b = 1.38065E-23           ! Boltzmann constant [J/K]
+      DOUBLE PRECISION, PARAMETER, PRIVATE:: M_w = 18.01528E-3           ! molecular mass of water [kg/mol]
+      DOUBLE PRECISION, PARAMETER, PRIVATE:: M_a = 28.96E-3              ! molecular mass of air [kg/mol]
+      DOUBLE PRECISION, PARAMETER, PRIVATE:: N_avo = 6.022E23            ! Avogadro number [1/mol]
+      DOUBLE PRECISION, PARAMETER, PRIVATE:: ma_w = M_w / N_avo          ! mass of water molecule [kg]
+      REAL, PARAMETER, PRIVATE:: ar_volume = 4./3.*PI*(2.5e-6)**3        ! assume radius of 0.025 micrometer, 2.5e-6 cm
 
 !..Enthalpy of sublimation, vaporization, and fusion at 0C.
       REAL, PARAMETER, PRIVATE:: lsub = 2.834E6
@@ -181,7 +214,14 @@ MODULE module_mp_thompson
       INTEGER, PARAMETER, PRIVATE:: ntb_r1 = 37
       INTEGER, PARAMETER, PRIVATE:: ntb_i1 = 55
       INTEGER, PARAMETER, PRIVATE:: ntb_t = 9
-      INTEGER, PRIVATE:: nic2, nii2, nii3, nir2, nir3, nis2, nig2, nig3
+      INTEGER, PRIVATE:: nic1, nic2, nii2, nii3, nir2, nir3, nis2, nig2, nig3
+      INTEGER, PARAMETER, PRIVATE:: ntb_arc = 7
+      INTEGER, PARAMETER, PRIVATE:: ntb_arw = 9
+      INTEGER, PARAMETER, PRIVATE:: ntb_art = 7
+      INTEGER, PARAMETER, PRIVATE:: ntb_arr = 5
+      INTEGER, PARAMETER, PRIVATE:: ntb_ark = 4
+      INTEGER, PARAMETER, PRIVATE:: ntb_IN = 55
+      INTEGER, PRIVATE:: niIN2
 
       DOUBLE PRECISION, DIMENSION(nbins+1):: xDx
       DOUBLE PRECISION, DIMENSION(nbc):: Dc, dtc
@@ -189,6 +229,7 @@ MODULE module_mp_thompson
       DOUBLE PRECISION, DIMENSION(nbr):: Dr, dtr
       DOUBLE PRECISION, DIMENSION(nbs):: Ds, dts
       DOUBLE PRECISION, DIMENSION(nbg):: Dg, dtg
+      DOUBLE PRECISION, DIMENSION(nbc):: t_Nc
 
 !..Lookup tables for cloud water content (kg/m**3).
       REAL, DIMENSION(ntb_c), PARAMETER, PRIVATE:: &
@@ -257,6 +298,29 @@ MODULE module_mp_thompson
                1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, &
                1.e6/)
 
+!..Aerosol table parameter: Number of available aerosols, vertical
+!.. velocity, temperature, aerosol mean radius, and hygroscopicity.
+      REAL, DIMENSION(ntb_arc), PARAMETER, PRIVATE:: &
+      ta_Na = (/10.0, 31.6, 100.0, 316.0, 1000.0, 3160.0, 10000.0/)
+      REAL, DIMENSION(ntb_arw), PARAMETER, PRIVATE:: &
+      ta_Ww = (/0.01, 0.0316, 0.1, 0.316, 1.0, 3.16, 10.0, 31.6, 100.0/)
+      REAL, DIMENSION(ntb_art), PARAMETER, PRIVATE:: &
+      ta_Tk = (/243.15, 253.15, 263.15, 273.15, 283.15, 293.15, 303.15/)
+      REAL, DIMENSION(ntb_arr), PARAMETER, PRIVATE:: &
+      ta_Ra = (/0.01, 0.02, 0.04, 0.08, 0.16/)
+      REAL, DIMENSION(ntb_ark), PARAMETER, PRIVATE:: &
+      ta_Ka = (/0.2, 0.4, 0.6, 0.8/)
+
+!..Lookup tables for IN concentration (/m**3) from 0.001 to 1000/Liter.
+      REAL, DIMENSION(ntb_IN), PARAMETER, PRIVATE:: &
+      Nt_IN = (/1.0,2.0,3.0,4.0,5.0,6.0,7.0,8.0,9.0, &
+               1.e1,2.e1,3.e1,4.e1,5.e1,6.e1,7.e1,8.e1,9.e1, &
+               1.e2,2.e2,3.e2,4.e2,5.e2,6.e2,7.e2,8.e2,9.e2, &
+               1.e3,2.e3,3.e3,4.e3,5.e3,6.e3,7.e3,8.e3,9.e3, &
+               1.e4,2.e4,3.e4,4.e4,5.e4,6.e4,7.e4,8.e4,9.e4, &
+               1.e5,2.e5,3.e5,4.e5,5.e5,6.e5,7.e5,8.e5,9.e5, &
+               1.e6/)
+
 !..For snow moments conversions (from Field et al. 2005)
       REAL, DIMENSION(10), PARAMETER, PRIVATE:: &
       sa = (/ 5.065339, -0.062659, -3.032362, 0.029469, -0.000285, &
@@ -275,6 +339,7 @@ MODULE module_mp_thompson
 !.. represent lookup tables.  Save compile-time memory by making
 !.. allocatable (2009Jun12, J. Michalakes).
       INTEGER, PARAMETER, PRIVATE:: R8SIZE = 8
+      INTEGER, PARAMETER, PRIVATE:: R4SIZE = 4
       REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:)::             &
                 tcg_racg, tmr_racg, tcr_gacr, tmg_gacr,                 &
                 tnr_racg, tnr_gacr
@@ -282,20 +347,23 @@ MODULE module_mp_thompson
                 tcs_racs1, tmr_racs1, tcs_racs2, tmr_racs2,             &
                 tcr_sacr1, tms_sacr1, tcr_sacr2, tms_sacr2,             &
                 tnr_racs1, tnr_racs2, tnr_sacr1, tnr_sacr2
-      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:)::                 &
+      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:)::             &
                 tpi_qcfz, tni_qcfz
-      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:)::               &
+      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:,:)::             &
                 tpi_qrfz, tpg_qrfz, tni_qrfz, tnr_qrfz
       REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:)::                 &
                 tps_iaus, tni_iaus, tpi_ide
       REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efrw
       REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:):: t_Efsw
       REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:):: tnr_rev
+      REAL (KIND=R8SIZE), ALLOCATABLE, DIMENSION(:,:,:)::               &
+                tpc_wev, tnc_wev
+      REAL (KIND=R4SIZE), ALLOCATABLE, DIMENSION(:,:,:,:,:):: tnccn_act
 
 !..Variables holding a bunch of exponents and gamma values (cloud water,
 !.. cloud ice, rain, snow, then graupel).
-      REAL, DIMENSION(3), PRIVATE:: cce, ccg
-      REAL, PRIVATE::  ocg1, ocg2
+      REAL, DIMENSION(5,15), PRIVATE:: cce, ccg
+      REAL, DIMENSION(15), PRIVATE::  ocg1, ocg2
       REAL, DIMENSION(7), PRIVATE:: cie, cig
       REAL, PRIVATE:: oig1, oig2, obmi
       REAL, DIMENSION(13), PRIVATE:: cre, crg
@@ -322,15 +390,148 @@ MODULE module_mp_thompson
 
       CONTAINS
 
-      SUBROUTINE thompson_init
+      SUBROUTINE thompson_init(hgt, nwfa2d, nwfa, nifa, dx, dy,         &
+                          is_start,                                     &
+                          ids, ide, jds, jde, kds, kde,                 &
+                          ims, ime, jms, jme, kms, kme,                 &
+                          its, ite, jts, jte, kts, kte)
 
       IMPLICIT NONE
 
-      INTEGER:: i, j, k, m, n
-      LOGICAL:: micro_init
+      INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, &
+                            ims,ime, jms,jme, kms,kme, &
+                            its,ite, jts,jte, kts,kte
+      REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: hgt
+
+!..OPTIONAL variables that control application of aerosol-aware scheme
 
-!..Allocate space for lookup tables (J. Michalakes 2009Jun08).
+      REAL, DIMENSION(ims:ime,kms:kme,jms:jme), OPTIONAL, INTENT(INOUT) :: nwfa, nifa
+      REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL, INTENT(INOUT) :: nwfa2d
+      REAL, OPTIONAL, INTENT(IN) :: DX, DY
+      LOGICAL, OPTIONAL, INTENT(IN) :: is_start
+
+      INTEGER:: i, j, k, l, m, n
+      REAL:: h_01, niIN3, niCCN3
+      LOGICAL:: micro_init, has_CCN, has_IN
+
+      is_aerosol_aware = .FALSE.
       micro_init = .FALSE.
+      has_CCN    = .FALSE.
+      has_IN     = .FALSE.
+
+      write(mp_debug,*) ' DEBUG  checking column of hgt ', its+1,jts+1
+      CALL wrf_debug(250, mp_debug)
+      do k = kts, kte
+         write(mp_debug,*) ' DEBUGT  k, hgt = ', k, hgt(its+1,k,jts+1)
+         CALL wrf_debug(250, mp_debug)
+      enddo
+
+      if (PRESENT(nwfa2d) .AND. PRESENT(nwfa) .AND. PRESENT(nifa)) is_aerosol_aware = .TRUE.
+
+      if (is_aerosol_aware) then
+
+!..Check for existing aerosol data, both CCN and IN aerosols.  If missing
+!.. fill in just a basic vertical profile, somewhat boundary-layer following.
+
+      if (SUM(nwfa(its,:,jts)) .lt. eps) then
+         write(mp_debug,*) ' Apparently there are no initial CCN aerosols.'
+         CALL wrf_debug(100, mp_debug)
+         write(mp_debug,*) '   checked column at point (i,j) = ', its,jts
+         CALL wrf_debug(100, mp_debug)
+         do j = jts, min(jde-1,jte)
+         do i = its, min(ide-1,ite)
+            if (hgt(i,1,j).le.1000.0) then
+               h_01 = 0.8
+            elseif (hgt(i,1,j).ge.2500.0) then
+               h_01 = 0.01
+            else
+               h_01 = 0.8*cos(hgt(i,1,j)*0.001 - 1.0)
+            endif
+            niCCN3 = -1.0*ALOG(naCCN1/naCCN0)/h_01
+            nwfa(i,1,j) = naCCN1+naCCN0*exp(-((hgt(i,2,j)-hgt(i,1,j))/1000.)*niCCN3)
+            do k = 2, kte
+               nwfa(i,k,j) = naCCN1+naCCN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niCCN3)
+            enddo
+         enddo
+         enddo
+      else
+         has_CCN    = .TRUE.
+         write(mp_debug,*) ' Apparently initial CCN aerosols are present.'
+         CALL wrf_debug(100, mp_debug)
+         write(mp_debug,*) '   column sum at point (i,j) = ', its,jts, SUM(nwfa(its,:,jts))
+         CALL wrf_debug(100, mp_debug)
+      endif
+
+      if (SUM(nifa(its,:,jts)) .lt. eps) then
+         write(mp_debug,*) ' Apparently there are no initial IN aerosols.'
+         CALL wrf_debug(100, mp_debug)
+         write(mp_debug,*) '   checked column at point (i,j) = ', its,jts
+         CALL wrf_debug(100, mp_debug)
+         do j = jts, min(jde-1,jte)
+         do i = its, min(ide-1,ite)
+            if (hgt(i,1,j).le.1000.0) then
+               h_01 = 0.8
+            elseif (hgt(i,1,j).ge.2500.0) then
+               h_01 = 0.01
+            else
+               h_01 = 0.8*cos(hgt(i,1,j)*0.001 - 1.0)
+            endif
+            niIN3 = -1.0*ALOG(naIN1/naIN0)/h_01
+            nifa(i,1,j) = naIN1+naIN0*exp(-((hgt(i,2,j)-hgt(i,1,j))/1000.)*niIN3)
+            do k = 2, kte
+               nifa(i,k,j) = naIN1+naIN0*exp(-((hgt(i,k,j)-hgt(i,1,j))/1000.)*niIN3)
+            enddo
+         enddo
+         enddo
+      else
+         has_IN     = .TRUE.
+         write(mp_debug,*) ' Apparently initial IN aerosols are present.'
+         CALL wrf_debug(100, mp_debug)
+         write(mp_debug,*) '   column sum at point (i,j) = ', its,jts, SUM(nifa(its,:,jts))
+         CALL wrf_debug(100, mp_debug)
+      endif
+
+!..Capture initial state lowest level CCN aerosol data in 2D array.
+
+!     do j = jts, min(jde-1,jte)
+!     do i = its, min(ide-1,ite)
+!        nwfa2d(i,j) = nwfa(i,kts,j)
+!     enddo
+!     enddo
+
+!..Scale the lowest level aerosol data into an emissions rate.  This is
+!.. very far from ideal, but need higher emissions where larger amount
+!.. of existing and lesser emissions where not already lots of aerosols
+!.. for first-order simplistic approach.  Later, proper connection to
+!.. emission inventory would be better, but, for now, scale like this:
+!.. where: Nwfa=50 per cc, emit 0.875E4 aerosols per kg per second
+!..        Nwfa=500 per cc, emit 0.875E5 aerosols per kg per second
+!..        Nwfa=5000 per cc, emit 0.875E6 aerosols per kg per second
+!.. for a grid with 20km spacing and scale accordingly for other spacings.
+
+      if (is_start) then
+         if (SQRT(DX*DY)/20000.0 .ge. 1.0) then
+            h_01 = 0.875
+         else
+            h_01 = (0.875 + 0.125*((20000.-SQRT(DX*DY))/16000.)) * SQRT(DX*DY)/20000.
+         endif
+         write(mp_debug,*) '   aerosol surface flux emission scale factor is: ', h_01
+         CALL wrf_debug(100, mp_debug)
+         do j = jts, min(jde-1,jte)
+         do i = its, min(ide-1,ite)
+            nwfa2d(i,j) = 10.0**(LOG10(nwfa(i,kts,j)*1.E-6)-3.69897)
+            nwfa2d(i,j) = nwfa2d(i,j)*h_01 * 1.E6
+         enddo
+         enddo
+      else
+         write(mp_debug,*) '   sample (lower-left) aerosol surface flux emission rate: ', nwfa2d(1,1)
+         CALL wrf_debug(100, mp_debug)
+      endif
+
+      endif
+
+
+!..Allocate space for lookup tables (J. Michalakes 2009Jun08).
 
       if (.NOT. ALLOCATED(tcg_racg) ) then
          ALLOCATE(tcg_racg(ntb_g1,ntb_g,ntb_r1,ntb_r))
@@ -356,13 +557,13 @@ SUBROUTINE thompson_init
       if (.NOT. ALLOCATED(tnr_sacr1)) ALLOCATE(tnr_sacr1(ntb_s,ntb_t,ntb_r1,ntb_r))
       if (.NOT. ALLOCATED(tnr_sacr2)) ALLOCATE(tnr_sacr2(ntb_s,ntb_t,ntb_r1,ntb_r))
 
-      if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,45))
-      if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,45))
+      if (.NOT. ALLOCATED(tpi_qcfz)) ALLOCATE(tpi_qcfz(ntb_c,nbc,45,ntb_IN))
+      if (.NOT. ALLOCATED(tni_qcfz)) ALLOCATE(tni_qcfz(ntb_c,nbc,45,ntb_IN))
 
-      if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45))
-      if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45))
-      if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45))
-      if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45))
+      if (.NOT. ALLOCATED(tpi_qrfz)) ALLOCATE(tpi_qrfz(ntb_r,ntb_r1,45,ntb_IN))
+      if (.NOT. ALLOCATED(tpg_qrfz)) ALLOCATE(tpg_qrfz(ntb_r,ntb_r1,45,ntb_IN))
+      if (.NOT. ALLOCATED(tni_qrfz)) ALLOCATE(tni_qrfz(ntb_r,ntb_r1,45,ntb_IN))
+      if (.NOT. ALLOCATED(tnr_qrfz)) ALLOCATE(tnr_qrfz(ntb_r,ntb_r1,45,ntb_IN))
 
       if (.NOT. ALLOCATED(tps_iaus)) ALLOCATE(tps_iaus(ntb_i,ntb_i1))
       if (.NOT. ALLOCATED(tni_iaus)) ALLOCATE(tni_iaus(ntb_i,ntb_i1))
@@ -372,6 +573,11 @@ SUBROUTINE thompson_init
       if (.NOT. ALLOCATED(t_Efsw)) ALLOCATE(t_Efsw(nbs,nbc))
 
       if (.NOT. ALLOCATED(tnr_rev)) ALLOCATE(tnr_rev(nbr, ntb_r1, ntb_r))
+      if (.NOT. ALLOCATED(tpc_wev)) ALLOCATE(tpc_wev(nbc,ntb_c,nbc))
+      if (.NOT. ALLOCATED(tnc_wev)) ALLOCATE(tnc_wev(nbc,ntb_c,nbc))
+
+      if (.NOT. ALLOCATED(tnccn_act))                                   &
+            ALLOCATE(tnccn_act(ntb_arc,ntb_arw,ntb_art,ntb_arr,ntb_ark))
 
       if (micro_init) then
 
@@ -379,7 +585,8 @@ SUBROUTINE thompson_init
 !.. drops according to general dispersion characteristics (disp=~0.25
 !.. for Maritime and 0.45 for Continental).
 !.. disp=SQRT((mu+2)/(mu+1) - 1) so mu varies from 15 for Maritime
-!.. to 2 for really dirty air.
+!.. to 2 for really dirty air.  This not used in 2-moment cloud water
+!.. scheme and nu_c used instead and varies from 2 to 15 (integer-only).
       mu_c = MIN(15., (1000.E6/Nt_c + 2.))
 
 !..Schmidt number to one-third used numerous times.
@@ -392,14 +599,20 @@ SUBROUTINE thompson_init
 
 !..These constants various exponents and gamma() assoc with cloud,
 !.. rain, snow, and graupel.
-      cce(1) = mu_c + 1.
-      cce(2) = bm_r + mu_c + 1.
-      cce(3) = bm_r + mu_c + 4.
-      ccg(1) = WGAMMA(cce(1))
-      ccg(2) = WGAMMA(cce(2))
-      ccg(3) = WGAMMA(cce(3))
-      ocg1 = 1./ccg(1)
-      ocg2 = 1./ccg(2)
+      do n = 1, 15
+         cce(1,n) = n + 1.
+         cce(2,n) = bm_r + n + 1.
+         cce(3,n) = bm_r + n + 4.
+         cce(4,n) = n + bv_c + 1.
+         cce(5,n) = bm_r + n + bv_c + 1.
+         ccg(1,n) = WGAMMA(cce(1,n))
+         ccg(2,n) = WGAMMA(cce(2,n))
+         ccg(3,n) = WGAMMA(cce(3,n))
+         ccg(4,n) = WGAMMA(cce(4,n))
+         ccg(5,n) = WGAMMA(cce(5,n))
+         ocg1(n) = 1./ccg(1,n)
+         ocg2(n) = 1./ccg(2,n)
+      enddo
 
       cie(1) = mu_i + 1.
       cie(2) = bm_i + mu_i + 1.
@@ -536,6 +749,7 @@ SUBROUTINE thompson_init
       nis2 = NINT(ALOG10(r_s(1)))
       nig2 = NINT(ALOG10(r_g(1)))
       nig3 = NINT(ALOG10(N0g_exp(1)))
+      niIN2 = NINT(ALOG10(Nt_IN(1)))
 
 !..Create bins of cloud water (from min diameter up to 100 microns).
       Dc(1) = D0c*1.0d0
@@ -593,6 +807,18 @@ SUBROUTINE thompson_init
          dtg(n) = xDx(n+1) - xDx(n)
       enddo
 
+!..Create bins of cloud droplet number concentration (1 to 3000 per cc).
+      xDx(1) = 1.0d0
+      xDx(nbc+1) = 3000.0d0
+      do n = 2, nbc
+         xDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(nbc)                          &
+                  *DLOG(xDx(nbc+1)/xDx(1)) +DLOG(xDx(1)))
+      enddo
+      do n = 1, nbc
+         t_Nc(n) = DSQRT(xDx(n)*xDx(n+1)) * 1.D6
+      enddo
+      nic1 = DLOG(t_Nc(nbc)/t_Nc(1))
+
 !+---+-----------------------------------------------------------------+
 !..Create lookup tables for most costly calculations.
 !+---+-----------------------------------------------------------------+
@@ -633,18 +859,22 @@ SUBROUTINE thompson_init
          enddo
       enddo
 
-      do k = 1, 45
-         do j = 1, ntb_r1
-            do i = 1, ntb_r
-               tpi_qrfz(i,j,k) = 0.0d0
-               tni_qrfz(i,j,k) = 0.0d0
-               tpg_qrfz(i,j,k) = 0.0d0
-               tnr_qrfz(i,j,k) = 0.0d0
+      do m = 1, ntb_IN
+         do k = 1, 45
+            do j = 1, ntb_r1
+               do i = 1, ntb_r
+                  tpi_qrfz(i,j,k,m) = 0.0d0
+                  tni_qrfz(i,j,k,m) = 0.0d0
+                  tpg_qrfz(i,j,k,m) = 0.0d0
+                  tnr_qrfz(i,j,k,m) = 0.0d0
+               enddo
+            enddo
+            do j = 1, nbc
+               do i = 1, ntb_c
+                  tpi_qcfz(i,j,k,m) = 0.0d0
+                  tni_qcfz(i,j,k,m) = 0.0d0
+               enddo
             enddo
-         enddo
-         do i = 1, ntb_c
-            tpi_qcfz(i,k) = 0.0d0
-            tni_qcfz(i,k) = 0.0d0
          enddo
       enddo
 
@@ -673,19 +903,48 @@ SUBROUTINE thompson_init
          enddo
       enddo
 
+      do k = 1, nbc
+         do j = 1, ntb_c
+            do i = 1, nbc
+               tpc_wev(i,j,k) = 0.0d0
+               tnc_wev(i,j,k) = 0.0d0
+            enddo
+         enddo
+      enddo
+
+      do m = 1, ntb_ark
+         do l = 1, ntb_arr
+            do k = 1, ntb_art
+               do j = 1, ntb_arw
+                  do i = 1, ntb_arc
+                     tnccn_act(i,j,k,l,m) = 1.0
+                  enddo
+               enddo
+            enddo
+         enddo
+      enddo
+
       CALL wrf_debug(150, 'CREATING MICROPHYSICS LOOKUP TABLES ... ')
       WRITE (wrf_err_message, '(a, f5.2, a, f5.2, a, f5.2, a, f5.2)') &
           ' using: mu_c=',mu_c,' mu_i=',mu_i,' mu_r=',mu_r,' mu_g=',mu_g
       CALL wrf_debug(150, wrf_err_message)
 
+!..Read a static file containing CCN activation of aerosols. The
+!.. data were created from a parcel model by Feingold & Heymsfield with
+!.. further changes by Eidhammer and Kriedenweis.
+      if (is_aerosol_aware) then
+         CALL wrf_debug(200, '  calling table_ccnAct routine')
+         call table_ccnAct
+      endif
+
 !..Collision efficiency between rain/snow and cloud water.
       CALL wrf_debug(200, '  creating qc collision eff tables')
       call table_Efrw
       call table_Efsw
 
 !..Drop evaporation.
-!     CALL wrf_debug(200, '  creating rain evap table')
-!     call table_dropEvap
+      CALL wrf_debug(200, '  creating rain evap table')
+      call table_dropEvap
 
 !..Initialize various constants for computing radar reflectivity.
       xam_r = am_r
@@ -725,12 +984,13 @@ SUBROUTINE thompson_init
 
       END SUBROUTINE thompson_init
 !+---+-----------------------------------------------------------------+
-!
+!ctrlL
 !+---+-----------------------------------------------------------------+
 !..This is a wrapper routine designed to transfer values from 3D to 1D.
 !+---+-----------------------------------------------------------------+
-      SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
-                              th, pii, p, dz, dt_in, itimestep, &
+      SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc,       &
+                              nwfa, nifa, nwfa2d,                       &
+                              th, pii, p, w, dz, dt_in, itimestep,      &
                               RAINNC, RAINNCV, &
                               SNOWNC, SNOWNCV, &
                               GRAUPELNC, GRAUPELNCV, SR, &
@@ -738,6 +998,8 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
                               rainprod, evapprod, &
 #endif
                               refl_10cm, diagflag, do_radar_ref,      &
+                              re_cloud, re_ice, re_snow,              &
+                              has_reqc, has_reqi, has_reqs,           &
                               ids,ide, jds,jde, kds,kde, &             ! domain dims
                               ims,ime, jms,jme, kms,kme, &             ! memory dims
                               its,ite, jts,jte, kts,kte)               ! tile dims
@@ -750,12 +1012,18 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
                             its,ite, jts,jte, kts,kte
       REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: &
                           qv, qc, qr, qi, qs, qg, ni, nr, th
+      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), OPTIONAL, INTENT(INOUT):: &
+                          nc, nwfa, nifa
+      REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(IN):: nwfa2d
+      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: &
+                          re_cloud, re_ice, re_snow
+      INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
 #ifdef WRF_CHEM
       REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: &
                           rainprod, evapprod
 #endif
       REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: &
-                          pii, p, dz
+                          pii, p, w, dz
       REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT):: &
                           RAINNC, RAINNCV, SR
       REAL, DIMENSION(ims:ime, jms:jme), OPTIONAL, INTENT(INOUT)::      &
@@ -767,8 +1035,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
 
 !..Local variables
       REAL, DIMENSION(kts:kte):: &
-                          qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
-                          nr1d, t1d, p1d, dz1d, dBZ
+                          qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d,     &
+                          nr1d, nc1d, nwfa1d, nifa1d,                   &
+                          t1d, p1d, w1d, dz1d, dBZ
+      REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d
 #ifdef WRF_CHEM
       REAL, DIMENSION(kts:kte):: &
                           rainprod1d, evapprod1d
@@ -776,6 +1046,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
       REAL, DIMENSION(its:ite, jts:jte):: pcp_ra, pcp_sn, pcp_gr, pcp_ic
       REAL:: dt, pptrain, pptsnow, pptgraul, pptice
       REAL:: qc_max, qr_max, qs_max, qi_max, qg_max, ni_max, nr_max
+      REAL:: nwfa1
       INTEGER:: i, j, k
       INTEGER:: imax_qc,imax_qr,imax_qi,imax_qs,imax_qg,imax_ni,imax_nr
       INTEGER:: jmax_qc,jmax_qr,jmax_qi,jmax_qs,jmax_qg,jmax_ni,jmax_nr
@@ -834,6 +1105,12 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
          mp_debug(i:i) = char(0)
       enddo
 
+      if (.NOT. is_aerosol_aware .AND. PRESENT(nc) .AND. PRESENT(nwfa)  &
+                .AND. PRESENT(nifa) .AND. PRESENT(nwfa2d)) then
+         write(mp_debug,*) 'WARNING, nc-nwfa-nifa-nwfa2d present but is_aerosol_aware is FALSE'
+         CALL wrf_debug(0, mp_debug)
+      endif
+
       j_loop:  do j = j_start, j_end
       i_loop:  do i = i_start, i_end
 
@@ -853,6 +1130,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
          do k = kts, kte
             t1d(k) = th(i,k,j)*pii(i,k,j)
             p1d(k) = p(i,k,j)
+            w1d(k) = w(i,k,j)
             dz1d(k) = dz(i,k,j)
             qv1d(k) = qv(i,k,j)
             qc1d(k) = qc(i,k,j)
@@ -863,9 +1141,24 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
             ni1d(k) = ni(i,k,j)
             nr1d(k) = nr(i,k,j)
          enddo
+         if (is_aerosol_aware) then
+            do k = kts, kte
+               nc1d(k) = nc(i,k,j)
+               nwfa1d(k) = nwfa(i,k,j)
+               nifa1d(k) = nifa(i,k,j)
+            enddo
+            nwfa1 = nwfa2d(i,j)
+         else
+            do k = kts, kte
+               nc1d(k) = Nt_c
+               nwfa1d(k) = 11.1E6
+               nifa1d(k) = naIN1*0.01
+            enddo
+            nwfa1 = 11.1E6
+         endif
 
-         call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
-                      nr1d, t1d, p1d, dz1d, &
+         call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d,     &
+                      nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dz1d,  &
                       pptrain, pptsnow, pptgraul, pptice, &
 #ifdef WRF_CHEM
                       rainprod1d, evapprod1d, &
@@ -888,6 +1181,22 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
          ENDIF
          SR(i,j) = (pptsnow + pptgraul + pptice)/(RAINNCV(i,j)+1.e-12)
 
+
+
+!..Reset lowest model level to initial state aerosols (fake sfc source).
+!.. Changed 13 May 2013 to fake emissions in which nwfa2d is aerosol
+!.. number tendency (number per kg per second).
+         if (is_aerosol_aware) then
+!-GT        nwfa1d(kts) = nwfa1
+            nwfa1d(kts) = nwfa1d(kts) + nwfa2d(i,j)*dt_in
+
+            do k = kts, kte
+               nc(i,k,j) = nc1d(k)
+               nwfa(i,k,j) = nwfa1d(k)
+               nifa(i,k,j) = nifa1d(k)
+            enddo
+         endif
+
          do k = kts, kte
             qv(i,k,j) = qv1d(k)
             qc(i,k,j) = qc1d(k)
@@ -897,11 +1206,11 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
             qg(i,k,j) = qg1d(k)
             ni(i,k,j) = ni1d(k)
             nr(i,k,j) = nr1d(k)
+            th(i,k,j) = t1d(k)/pii(i,k,j)
 #ifdef WRF_CHEM
             rainprod(i,k,j) = rainprod1d(k)
             evapprod(i,k,j) = evapprod1d(k)
 #endif
-            th(i,k,j) = t1d(k)/pii(i,k,j)
             if (qc1d(k) .gt. qc_max) then
              imax_qc = i
              jmax_qc = j
@@ -973,14 +1282,16 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
              CALL wrf_debug(150, mp_debug)
             endif
             if (qv1d(k) .lt. 0.0) then
+             write(mp_debug,*) 'WARNING, negative qv ', qv1d(k),        &
+                        ' at i,j,k=', i,j,k
+             CALL wrf_debug(150, mp_debug)
              if (k.lt.kte-2 .and. k.gt.kts+1) then
-                qv(i,k,j) = 0.5*(qv(i,k-1,j) + qv(i,k+1,j))
+                write(mp_debug,*) '   below and above are: ', qv(i,k-1,j), qv(i,k+1,j)
+                CALL wrf_debug(150, mp_debug)
+                qv(i,k,j) = MAX(1.E-7, 0.5*(qv(i,k-1,j) + qv(i,k+1,j)))
              else
                 qv(i,k,j) = 1.E-7
              endif
-             write(mp_debug,*) 'WARNING, negative qv ', qv1d(k),        &
-                        ' at i,j,k=', i,j,k
-             CALL wrf_debug(150, mp_debug)
             endif
          enddo
 
@@ -994,6 +1305,21 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
          endif
          ENDIF
 
+         IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN
+          do k = kts, kte
+             re_qc1d(k) = 2.51E-6
+             re_qi1d(k) = 10.01E-6
+             re_qs1d(k) = 25.E-6
+          enddo
+          call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d,  &
+                      re_qc1d, re_qi1d, re_qs1d, kts, kte)
+          do k = kts, kte
+             re_cloud(i,k,j) = MAX(2.51E-6, MIN(re_qc1d(k), 50.E-6))
+             re_ice(i,k,j)   = MAX(10.01E-6, MIN(re_qi1d(k), 125.E-6))
+             re_snow(i,k,j)  = MAX(25.E-6, MIN(re_qs1d(k), 999.E-6))
+          enddo
+         ENDIF
+
       enddo i_loop
       enddo j_loop
 
@@ -1016,7 +1342,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, &
       END SUBROUTINE mp_gt_driver
 
 !+---+-----------------------------------------------------------------+
-!
+!ctrlL
 !+---+-----------------------------------------------------------------+
 !+---+-----------------------------------------------------------------+
 !.. This subroutine computes the moisture tendencies of water vapor,
@@ -1027,7 +1353,7 @@ END SUBROUTINE mp_gt_driver
 !+---+-----------------------------------------------------------------+
 !
       subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
-                          nr1d, t1d, p1d, dzq, &
+                          nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, &
                           pptrain, pptsnow, pptgraul, pptice, &
 #ifdef WRF_CHEM
                           rainprod, evapprod, &
@@ -1040,21 +1366,27 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
       INTEGER, INTENT(IN):: kts, kte, ii, jj
       REAL, DIMENSION(kts:kte), INTENT(INOUT):: &
                           qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
-                          nr1d, t1d, p1d
+                          nr1d, nc1d, nwfa1d, nifa1d, t1d
+      REAL, DIMENSION(kts:kte), INTENT(IN):: p1d, w1d, dzq
+      REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice
+      REAL, INTENT(IN):: dt
 #ifdef WRF_CHEM
       REAL, DIMENSION(kts:kte), INTENT(INOUT):: &
                           rainprod, evapprod
 #endif
-      REAL, DIMENSION(kts:kte), INTENT(IN):: dzq
-      REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice
-      REAL, INTENT(IN):: dt
 
 !..Local variables
       REAL, DIMENSION(kts:kte):: tten, qvten, qcten, qiten, &
-           qrten, qsten, qgten, niten, nrten
+           qrten, qsten, qgten, niten, nrten, ncten, nwfaten, nifaten
 
       DOUBLE PRECISION, DIMENSION(kts:kte):: prw_vcd
 
+      DOUBLE PRECISION, DIMENSION(kts:kte):: pnc_wcd, pnc_wau, pnc_rcw, &
+           pnc_scw, pnc_gcw
+
+      DOUBLE PRECISION, DIMENSION(kts:kte):: pna_rca, pna_sca, pna_gca, &
+           pnd_rcd, pnd_scd, pnd_gcd
+
       DOUBLE PRECISION, DIMENSION(kts:kte):: prr_wau, prr_rcw, prr_rcs, &
            prr_rcg, prr_sml, prr_gml, &
            prr_rci, prv_rev,          &
@@ -1066,7 +1398,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
            pni_ihm, pri_wfz, pni_wfz, &
            pri_rfz, pni_rfz, pri_ide, &
            pni_ide, pri_rci, pni_rci, &
-           pni_sci, pni_iau
+           pni_sci, pni_iau, pri_iha, pni_iha
 
       DOUBLE PRECISION, DIMENSION(kts:kte):: prs_iau, prs_sci, prs_rcs, &
            prs_scw, prs_sde, prs_ihm, &
@@ -1079,7 +1411,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
       DOUBLE PRECISION, PARAMETER:: zeroD0 = 0.0d0
 
       REAL, DIMENSION(kts:kte):: temp, pres, qv
-      REAL, DIMENSION(kts:kte):: rc, ri, rr, rs, rg, ni, nr
+      REAL, DIMENSION(kts:kte):: rc, ri, rr, rs, rg, ni, nr, nc, nwfa, nifa
       REAL, DIMENSION(kts:kte):: rho, rhof, rhof2
       REAL, DIMENSION(kts:kte):: qvs, qvsi, delQvs
       REAL, DIMENSION(kts:kte):: satw, sati, ssatw, ssati
@@ -1091,18 +1423,19 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
       REAL, DIMENSION(kts:kte):: smob, smo2, smo1, smo0, &
            smoc, smod, smoe, smof
 
-      REAL, DIMENSION(kts:kte):: sed_r, sed_s, sed_g, sed_i, sed_n
+      REAL, DIMENSION(kts:kte):: sed_r, sed_s, sed_g, sed_i, sed_n,sed_c
 
       REAL:: rgvm, delta_tp, orho, lfus2
-      REAL, DIMENSION(4):: onstep
+      REAL, DIMENSION(5):: onstep
       DOUBLE PRECISION:: N0_exp, N0_min, lam_exp, lamc, lamr, lamg
-      DOUBLE PRECISION:: lami, ilami
+      DOUBLE PRECISION:: lami, ilami, ilamc
       REAL:: xDc, Dc_b, Dc_g, xDi, xDr, xDs, xDg, Ds_m, Dg_m
-      DOUBLE PRECISION:: Dr_star
+      DOUBLE PRECISION:: Dr_star, Dc_star
       REAL:: zeta1, zeta, taud, tau
       REAL:: stoke_r, stoke_s, stoke_g, stoke_i
-      REAL:: vti, vtr, vts, vtg
-      REAL, DIMENSION(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk
+      REAL:: vti, vtr, vts, vtg, vtc
+      REAL, DIMENSION(kts:kte+1):: vtik, vtnik, vtrk, vtnrk, vtsk, vtgk,  &
+           vtck, vtnck
       REAL, DIMENSION(kts:kte):: vts_boost
       REAL:: Mrat, ils1, ils2, t1_vts, t2_vts, t3_vts, t4_vts, C_snow
       REAL:: a_, b_, loga_, A1, A2, tf
@@ -1113,13 +1446,15 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
       REAL:: otemp, rvs, rvs_p, rvs_pp, gamsc, alphsc, t1_evap, t1_subl
       REAL:: r_frac, g_frac
       REAL:: Ef_rw, Ef_sw, Ef_gw, Ef_rr
-      REAL:: dtsave, odts, odt, odzq
-      REAL:: xslw1, ygra1, zans1
+      REAL:: Ef_ra, Ef_sa, Ef_ga
+      REAL:: dtsave, odts, odt, odzq, hgt_agl
+      REAL:: xslw1, ygra1, zans1, eva_factor
       INTEGER:: i, k, k2, n, nn, nstep, k_0, kbot, IT, iexfrq
-      INTEGER, DIMENSION(4):: ksed1
-      INTEGER:: nir, nis, nig, nii, nic
+      INTEGER, DIMENSION(5):: ksed1
+      INTEGER:: nir, nis, nig, nii, nic, niin
       INTEGER:: idx_tc, idx_t, idx_s, idx_g1, idx_g, idx_r1, idx_r,     &
-                idx_i1, idx_i, idx_c, idx, idx_d
+                idx_i1, idx_i, idx_c, idx, idx_d, idx_n, idx_in
+
       LOGICAL:: melti, no_micro
       LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg
       LOGICAL:: debug_flag
@@ -1127,7 +1462,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
 !+---+
 
       debug_flag = .false.
-!     if (ii.eq.315 .and. jj.eq.2) debug_flag = .true.
+!     if (ii.eq.901 .and. jj.eq.379) debug_flag = .true.
+      if(debug_flag) then
+        write(mp_debug, *) 'DEBUG INFO, mp_thompson at (i,j) ', ii, ', ', jj
+        CALL wrf_debug(550, mp_debug)
+      endif
 
       no_micro = .true.
       dtsave = dt
@@ -1160,9 +1499,18 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
          qgten(k) = 0.
          niten(k) = 0.
          nrten(k) = 0.
+         ncten(k) = 0.
+         nwfaten(k) = 0.
+         nifaten(k) = 0.
 
          prw_vcd(k) = 0.
 
+         pnc_wcd(k) = 0.
+         pnc_wau(k) = 0.
+         pnc_rcw(k) = 0.
+         pnc_scw(k) = 0.
+         pnc_gcw(k) = 0.
+
          prv_rev(k) = 0.
          prr_wau(k) = 0.
          prr_rcw(k) = 0.
@@ -1195,6 +1543,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
          pni_rci(k) = 0.
          pni_sci(k) = 0.
          pni_iau(k) = 0.
+         pri_iha(k) = 0.
+         pni_iha(k) = 0.
 
          prs_iau(k) = 0.
          prs_sci(k) = 0.
@@ -1212,6 +1562,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
          prg_rcs(k) = 0.
          prg_rcg(k) = 0.
          prg_ihm(k) = 0.
+
+         pna_rca(k) = 0.
+         pna_sca(k) = 0.
+         pna_gca(k) = 0.
+
+         pnd_rcd(k) = 0.
+         pnd_scd(k) = 0.
+         pnd_gcd(k) = 0.
       enddo
 #ifdef WRF_CHEM
       do k = kts, kte
@@ -1228,15 +1586,33 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
          qv(k) = MAX(1.E-10, qv1d(k))
          pres(k) = p1d(k)
          rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622))
+         nwfa(k) = MAX(11.1E6, MIN(9999.E6, nwfa1d(k)*rho(k)))
+         nifa(k) = MAX(naIN1*0.01, MIN(9999.E6, nifa1d(k)*rho(k)))
+
          if (qc1d(k) .gt. R1) then
             no_micro = .false.
             rc(k) = qc1d(k)*rho(k)
+            nc(k) = MAX(2., nc1d(k)*rho(k))
             L_qc(k) = .true.
+            nu_c = MIN(15, NINT(1000.E6/nc(k)) + 2)
+            lamc = (nc(k)*am_r*ccg(2,nu_c)*ocg1(nu_c)/rc(k))**obmr
+            xDc = (bm_r + nu_c + 1.) / lamc
+            if (xDc.lt. D0c) then
+             lamc = cce(2,nu_c)/D0c
+            elseif (xDc.gt. D0r*2.) then
+             lamc = cce(2,nu_c)/(D0r*2.)
+            endif
+            nc(k) = MIN( DBLE(Nt_c_max), ccg(1,nu_c)*ocg2(nu_c)*rc(k)   &
+                  / am_r*lamc**bm_r)
+            if (.NOT. is_aerosol_aware) nc(k) = Nt_c
          else
             qc1d(k) = 0.0
+            nc1d(k) = 0.0
             rc(k) = R1
+            nc(k) = 2.
             L_qc(k) = .false.
          endif
+
          if (qi1d(k) .gt. R1) then
             no_micro = .false.
             ri(k) = qi1d(k)*rho(k)
@@ -1247,7 +1623,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
             xDi = (bm_i + mu_i + 1.) * ilami
             if (xDi.lt. 20.E-6) then
              lami = cie(2)/20.E-6
-             ni(k) = MIN(250.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i)
+             ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i)
             elseif (xDi.gt. 300.E-6) then
              lami = cie(2)/300.E-6
              ni(k) = cig(1)*oig2*ri(k)/am_i*lami**bm_i
@@ -1303,6 +1679,17 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
          endif
       enddo
 
+!+---+-----------------------------------------------------------------+
+!     if (debug_flag) then
+!      write(mp_debug,*) 'DEBUG-VERBOSE at (i,j) ', ii, ', ', jj
+!      CALL wrf_debug(550, mp_debug)
+!      do k = kts, kte
+!        write(mp_debug, '(a,i3,f8.2,1x,f7.2,1x, 11(1x,e13.6))')        &
+!    &              'VERBOSE: ', k, pres(k)*0.01, temp(k)-273.15, qv(k), rc(k), rr(k), ri(k), rs(k), rg(k), nc(k), nr(k), ni(k), nwfa(k), nifa(k)
+!        CALL wrf_debug(550, mp_debug)
+!      enddo
+!     endif
+!+---+-----------------------------------------------------------------+
 
 !+---+-----------------------------------------------------------------+
 !..Derive various thermodynamic variables frequently used.
@@ -1455,15 +1842,6 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
          lamg = lam_exp * (cgg(3)*ogg2*ogg1)**obmg
          ilamg(k) = 1./lamg
          N0_g(k) = N0_exp/(cgg(2)*lam_exp) * lamg**cge(2)
-!+---+-----------------------------------------------------------------+
-!     if( debug_flag .and. k.lt.42) then
-!        if (k.eq.41) write(mp_debug,*) 'DEBUG-GT:   K,   zans1,      rc,        rr,         rg,        N0_g'
-!        if (k.eq.41) CALL wrf_debug(0, mp_debug)
-!        write(mp_debug, 'a, i2, 1x, f6.3, 1x, 4(1x,e13.6,1x)')         &
-!                   '  GT ', k, zans1, rc(k), rr(k), rg(k), N0_g(k)
-!        CALL wrf_debug(0, mp_debug)
-!     endif
-!+---+-----------------------------------------------------------------+
       enddo
 
       endif
@@ -1491,19 +1869,21 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
 !-GT      if (mvd_r(k) .gt. 1500.0E-6) then
              Ef_rr = 2.0 - EXP(2300.0*(mvd_r(k)-1600.0E-6))
 !-GT      endif
-          pnr_rcr(k) = Ef_rr * 4.*nr(k)*rr(k)
+          pnr_rcr(k) = Ef_rr * 0.5*nr(k)*rr(k)
          endif
 
          mvd_c(k) = D0c
-         if (.not. L_qc(k)) CYCLE
-         xDc = MAX(D0c*1.E6, ((rc(k)/(am_r*Nt_c))**obmr) * 1.E6)
-         lamc = (Nt_c*am_r* ccg(2) * ocg1 / rc(k))**obmr
-         mvd_c(k) = (3.0+mu_c+0.672) / lamc
+         if (L_qc(k)) then
+          nu_c = MIN(15, NINT(1000.E6/nc(k)) + 2)
+          xDc = MAX(D0c*1.E6, ((rc(k)/(am_r*nc(k)))**obmr) * 1.E6)
+          lamc = (nc(k)*am_r* ccg(2,nu_c) * ocg1(nu_c) / rc(k))**obmr
+          mvd_c(k) = (3.0+nu_c+0.672) / lamc
+         endif
 
 !..Autoconversion follows Berry & Reinhardt (1974) with characteristic
 !.. diameters correctly computed from gamma distrib of cloud droplets.
          if (rc(k).gt. 0.01e-3) then
-          Dc_g = ((ccg(3)*ocg2)**obmr / lamc) * 1.E6
+          Dc_g = ((ccg(3,nu_c)*ocg2(nu_c))**obmr / lamc) * 1.E6
           Dc_b = (xDc*xDc*xDc*Dc_g*Dc_g*Dc_g - xDc*xDc*xDc*xDc*xDc*xDc) &
                  **(1./6.)
           zeta1 = 0.5*((6.25E-6*xDc*Dc_b*Dc_b*Dc_b - 0.4) &
@@ -1513,7 +1893,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
           tau  = 3.72/(rc(k)*taud)
           prr_wau(k) = zeta/tau
           prr_wau(k) = MIN(DBLE(rc(k)*odts), prr_wau(k))
-          pnr_wau(k) = prr_wau(k) / (am_r*mu_c*D0r*D0r*D0r)              ! RAIN2M
+          pnr_wau(k) = prr_wau(k) / (am_r*nu_c*D0r*D0r*D0r)              ! RAIN2M
+          pnc_wau(k) = MIN(DBLE(nc(k)*odts), prr_wau(k)                 &
+                     / (am_r*mvd_c(k)*mvd_c(k)*mvd_c(k)))                   ! Qc2M
          endif
 
 !..Rain collecting cloud water.  In CE, assume Dc< p8w reads as "p-at-w" (w=full levels)
+   real, dimension(ims:ime, kms:kme, jms:jme), intent(in)    :: p,    & ! pressure (Pa)
+                                                                t3d,  & ! temperature (K)
+                                                                qv3d    ! water vapor mixing ratio (kg/kg)
+   real, dimension(ims:ime, kms:kme, jms:jme), intent(inout) :: rh      ! relative humidity at surface
+
+   ! local variables
+   real    :: tc,rv,es,e
+   integer :: i,j,k
+
+   do j=jts,jte
+      do i=its,ite
+         do k=kts,kte                               ! only calculations at surface level
+            tc=t3d(i,k,j)-273.15                    ! temperature (C)
+            rv=max(0.,qv3d(i,k,j))                  ! water vapor mixing ration (kg kg-1)
+            es=6.112*exp((17.6*tc)/(tc+243.5))      ! saturation vapor pressure, hPa, Bolton (1980)
+            e =0.01*rv*p(i,k,j)/(rv+0.62197)        ! vapor pressure, hPa, (ECMWF handouts, page 6, Atmosph. Thermdyn.)
+                                                    ! rv=eps * e/(p-e) -> e=p * rv/(rv+eps), eps=0.62197
+            rh(i,k,j)=min(99.,max(0.,100.*e/es))    ! relative humidity (%)
+         end do
+      end do
+   end do
+end subroutine calc_relative_humidity
+
+end module module_ra_aerosol
+
diff --git a/wrfv2_fire/phys/module_ra_cam.F b/wrfv2_fire/phys/module_ra_cam.F
index c5e549cd..ebc32a0d 100644
--- a/wrfv2_fire/phys/module_ra_cam.F
+++ b/wrfv2_fire/phys/module_ra_cam.F
@@ -224,12 +224,13 @@ subroutine camrad(RTHRATENLW,RTHRATENSW,                           &
                      doabsems,                                     &
                      ids,ide, jds,jde, kds,kde,                    &
                      ims,ime, jms,jme, kms,kme,                    &
-                     its,ite, jts,jte, kts,kte                     )
+                     its,ite, jts,jte, kts,kte,                    &
+                     coszen                                        )
 
 !ccc To use CLWRF time-varying trace gases
    USE MODULE_RA_CLWRF_SUPPORT, ONLY : read_CAMgases
    USE module_wrf_error
-   USE module_state_description, ONLY : SSIBSCHEME              !ssib
+   USE module_state_description, ONLY : SSIBSCHEME, CLMSCHEME          !ssib & clm
 
 !------------------------------------------------------------------
    IMPLICIT NONE
@@ -360,6 +361,7 @@ subroutine camrad(RTHRATENLW,RTHRATENSW,                           &
                                                           F_ICE_PHY, &
                                                          F_RAIN_PHY
 
+  real, dimension(ims:ime,jms:jme), optional, intent(in) :: coszen
 
 ! LOCAL VARIABLES
  
@@ -531,19 +533,27 @@ subroutine camrad(RTHRATENLW,RTHRATENSW,                           &
 
 !  call zenith (calday, clat, clon, coszrs, ncol)
 
-      do i = its,ite
-      ii = i - its + 1
-      ! XT24 is the fractional part of simulation days plus half of RADT expressed in 
-      ! units of minutes
-      ! JULIAN is in days
-      ! RADT is in minutes
-      XT24=MOD(XTIME+RADT*0.5,1440.)
-      TLOCTM=GMT+XT24/60.+XLONG(I,J)/15.
-      HRANG=15.*(TLOCTM-12.)*DEGRAD
-      XXLAT=XLAT(I,J)*DEGRAD
-      clat(ii)=xxlat
-      coszrs(II)=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
-      enddo
+      if (present(coszen)) then
+         do i=its,ite
+            ii=i-its+1
+            clat(ii)=XLAT(I,J)*DEGRAD
+            coszrs(ii)=coszen(i,j)
+         enddo
+      else
+         do i = its,ite
+            ii = i - its + 1
+            ! XT24 is the fractional part of simulation days plus half of RADT expressed in 
+            ! units of minutes
+            ! JULIAN is in days
+            ! RADT is in minutes
+            XT24=MOD(XTIME+RADT*0.5,1440.)
+            TLOCTM=GMT+XT24/60.+XLONG(I,J)/15.
+            HRANG=15.*(TLOCTM-12.)*DEGRAD
+            XXLAT=XLAT(I,J)*DEGRAD
+            clat(ii)=xxlat
+            coszrs(II)=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
+         enddo
+      end if
 
 ! moist variables
 
@@ -696,6 +706,32 @@ subroutine camrad(RTHRATENLW,RTHRATENSW,                           &
          aldif(ii) = albedo(i,j)
       enddo
    endif
+   CASE (CLMSCHEME)
+   if (xtime .gt. 1.0) then
+      do i = its,ite
+         ii = i - its + 1
+         if (xland(i,j).lt.1.5) then   !land points only
+           asdir(ii) = ALSWVISDIR(i,j) ! CLM visdir albedo
+           asdif(ii) = ALSWVISDIF(i,j) ! CLM visdif albedo
+           aldir(ii) = ALSWNIRDIR(i,j) ! CLM nirdir albedo
+           aldif(ii) = ALSWNIRDIF(i,j) ! CLM nirdif albedo
+         else
+           asdir(ii) = albedo(i,j)
+           asdif(ii) = albedo(i,j)
+           aldir(ii) = albedo(i,j)
+           aldif(ii) = albedo(i,j)
+         endif
+      enddo
+   else
+      do i = its,ite
+         ii = i - its + 1
+         asdir(ii) = albedo(i,j)
+         asdif(ii) = albedo(i,j)
+         aldir(ii) = albedo(i,j)
+         aldif(ii) = albedo(i,j)
+      enddo
+   endif
+
    CASE DEFAULT
       do i = its,ite
       ii = i - its + 1
@@ -855,6 +891,17 @@ subroutine camrad(RTHRATENLW,RTHRATENSW,                           &
         SWNIRDIF(I,J) = solld(ii) !SSiB 
       enddo
       endif
+  CASE (CLMSCHEME)
+      if(dosw)then
+      do i = its,ite
+        ii = i - its + 1
+        SWVISDIR(I,J) = sols(ii)  !CLM
+        SWVISDIF(I,J) = solsd(ii) !CLM
+        SWNIRDIR(I,J) = soll(ii)  !CLM
+        SWNIRDIF(I,J) = solld(ii) !CLM
+      enddo
+      endif
+
    END SELECT
 !-----------------------------
 
diff --git a/wrfv2_fire/phys/module_ra_flg.F b/wrfv2_fire/phys/module_ra_flg.F
index 74de5cae..101eed32 100644
--- a/wrfv2_fire/phys/module_ra_flg.F
+++ b/wrfv2_fire/phys/module_ra_flg.F
@@ -8527,7 +8527,7 @@ subroutine RAD_FLG                    &
 !C******************************************************************
 !C--- NPDE=1, papa. in terms of IWC & T (Gu & Liou, 2006)
 !C***********************************************************************
-          if (NPDE.eq.1.and.piwc(k).gt.0.) then
+          if (NPDE.eq.1.and.piwc(k) .gt. 1.e-7) then
 !C--- for temperature between 213K and 253K
 		    if (degrees(i,NK,j).lt.253.         &
                     .and.degrees(i,NK,j).gt.213.) then  !mchen
@@ -8554,7 +8554,7 @@ subroutine RAD_FLG                    &
 !C***********************************************************************
 !C---- NPDE=2, new de para. in terms of iwc (Liou et al. 2008)
 !C***********************************************************************
-          else if (NPDE.eq.2.and.piwc(k).gt.0.) then
+          else if (NPDE.eq.2.and.piwc(k) .gt. 1.e-7) then
 !C--- for tropics
 !	        if (j.ge.17.and.j.le.28) ncoef = 1
 	    if (abs(xlat(i,j)).lt.30.) ncoef = 1
@@ -8581,6 +8581,7 @@ subroutine RAD_FLG                    &
                            +cmin(ncoef)*temp_i**2.
 
 !C--- calculate de
+
             pde_mean = exp(pde_mean)
             pde_max = exp(pde_max)
             pde_min = exp(pde_min)
diff --git a/wrfv2_fire/phys/module_ra_goddard.F b/wrfv2_fire/phys/module_ra_goddard.F
index 3b43c394..7aa50e50 100644
--- a/wrfv2_fire/phys/module_ra_goddard.F
+++ b/wrfv2_fire/phys/module_ra_goddard.F
@@ -172,7 +172,11 @@ subroutine goddardrad( rthraten, gsf, xlat,xlong               &
                    ,its,ite, jts,jte, kts,kte                     & 
 !                   ,cosz_urb2d,omg_urb2d                          & !optional urban
                    ,ERBE_out                                      &  !optional sdsu
-                    )
+                   ,tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw           & ! jararias 2013/11
+                   ,swddir,swddni,swddif                          & ! jararias 2013/08
+                   ,coszen,julian                                 & ! jararias 2013/08
+                   ,aer_opt                                       &
+                                                                  )
    implicit none
 
 !------- I / O variables ----------------------------------------------
@@ -248,14 +252,29 @@ subroutine goddardrad( rthraten, gsf, xlat,xlong               &
  real, dimension( ims:ime, jms:jme ), intent(inout)  ::  &
          gsf    ! (for SW) : net short wave flux at ground surface (W/m^2) 
                 ! (for LW) : downward long wave flux at ground surface (W/m^2)
-
-!
 ! 
 ! Extra 3D variables (last dimension 1-TOA LW down, 2-TOA LW up, 3-surface LW down, 4-surface LW up)
 !                                    5-TOA SW down, 6-TOA SW up, 7-surface SW down, 8-surface SW up)
 
    real, optional,dimension(ims:ime, jms:jme, 1:8),intent(out) :: ERBE_out  !extra output for SDSU
 
+! jararias, 14/08/2013
+   real, optional, dimension(ims:ime, jms:jme), intent(out) :: &
+         swddir, & ! All-sky broadband surface direct horizontal irradiance
+         swddni, & ! All-sky broadband surface direct normal irradiance
+         swddif    ! All-sky braodband surface diffuse irradiance
+   real, optional, dimension(ims:ime, jms:jme), intent(in) :: &
+         coszen    ! cosine of the solar zenith angle
+   real, optional, intent(in) :: &
+         julian    ! julian day (1-365) ! jararias, 14/08/2013
+
+! jararias, 2013/11
+   real, dimension( ims:ime, kms:kme, jms:jme, ib_sw ), optional, intent(in) :: &
+         tauaer3d_sw, & ! 3D aerosol optical depth for SW bands
+         ssaaer3d_sw, & ! 3D single scattering albedo for SW bands
+         asyaer3d_sw    ! 3D asymmetry factor for SW bands
+   integer, intent(in) :: aer_opt
+
 !------- Local variables ----------------------------------------------
 
  integer :: i,j,k,nk,ib,is ! loop indice
@@ -316,6 +335,16 @@ subroutine goddardrad( rthraten, gsf, xlat,xlong               &
    real(Kind=fp_kind), dimension( its:ite , kts:kte+1 ) :: phyd    ! pressure (Pa)
    real(Kind=fp_kind), dimension( its:ite , kts:kte   ) :: phydmid ! pressure in middle (Pa)
 
+  ! jararias, 14/08/2013
+  real(Kind=fp_kind), dimension( its:ite ) :: &
+    fdiruv, & ! SW UV direct downwelling flux at surface (-)
+    fdifuv, & ! SW UV diffuse downwelling flux at surface (-)
+   fdirpar, & ! SW PAR direct downwelling flux at surface (-)
+   fdifpar, & ! SW PAR diffuse downwelling flux at surface (-)
+    fdirir, & ! SW IF direct downwelling flux at surface (-)
+    fdifir    ! SW IF diffuse downwelling flux at surface (-)
+  real(Kind=fp_kind) :: da,eot
+
 !
 ! ozone table
 !
@@ -703,7 +732,7 @@ subroutine goddardrad( rthraten, gsf, xlat,xlong               &
 	       if ( (f_qi) ) then
                   cwc(i,k,1)=max(0.,qi3d(i,nk,j))
                   reff(i,k,1) = 125. + (t2d(i,k)-243.16)*5.  ! ice effective radius depends on temp
-                  reff(i,k,1) = min(125.,max(25.,reff(i,k,1)))
+                  reff(i,k,1) = min(125._fp_kind,max(25._fp_kind,reff(i,k,1)))
                   x=1.02*10000.*( p8w2d(i,k+1)-p8w2d(i,k) )
                   taucldi(i,nk,j) = x * cwc(i,k,1) * ( -6.59e-3 + 1.65/reff(i,k,1) ) ! output purpose
                else
@@ -723,7 +752,7 @@ subroutine goddardrad( rthraten, gsf, xlat,xlong               &
                   if ( cwc(i,k,1) > 0. ) then !ice exist
                     cwc(i,k,1)=cwc(i,k,1) + max(0.,qs3d(i,nk,j)) ! ice + snow
                     reff(i,k,1) = 125. + (t2d(i,k)-243.16)*5.    ! ice + snow (use ice definition) 
-                    reff(i,k,1) = min(125.,max(25.,reff(i,k,1)))
+                    reff(i,k,1) = min(125._fp_kind,max(25._fp_kind,reff(i,k,1)))
                   else
                     cwc(i,k,1)= max(0.,qs3d(i,nk,j))  ! snow only (define snow is large aggrefated ice)
                     reff(i,k,1) = 125.                ! snow only (use largest reff of ice)
@@ -832,18 +861,35 @@ subroutine goddardrad( rthraten, gsf, xlat,xlong               &
      
       case ('sw')
 
-
-
 !
 ! solar zenith angle and surface albedo
 !
+      if (present(coszen)) then ! jararias, 14/08/2013
+         call wrf_debug(100,'using coszen from radiation driver')
+         do i=its,ite
+            cosz(i)=coszen(i,j)
+         end do
+      else
+!        da=6.2831853071795862*(julian-1)/365.
+!        eot=(0.000075+0.001868*cos(da)-0.032077*sin(da) &
+!           -0.014615*cos(2*da)-0.04089*sin(2*da))*(229.18)
+         xt24 = mod(xtime + radfrq * 0.5, 1440.) + eot
+         do i = its,ite
+           tloctm = gmt + xt24 / 60. + xlong(i,j) / 15.
+           hrang = 15. * (tloctm - 12.) * degrad
+           xxlat = xlat(i,j) * degrad
+           cosz(i) = sin(xxlat) * sin(declin) + &
+                     cos(xxlat) * cos(declin) * cos(hrang)
+         end do
+      end if
+
       do i = its,ite
-        xt24 = mod(xtime + radfrq * 0.5, 1440.)
-        tloctm = gmt + xt24 / 60. + xlong(i,j) / 15.
-        hrang = 15. * (tloctm - 12.) * degrad
-        xxlat = xlat(i,j) * degrad
-        cosz(i) = sin(xxlat) * sin(declin) + &
-                  cos(xxlat) * cos(declin) * cos(hrang)
+!       xt24 = mod(xtime + radfrq * 0.5, 1440.)
+!       tloctm = gmt + xt24 / 60. + xlong(i,j) / 15.
+!       hrang = 15. * (tloctm - 12.) * degrad
+!       xxlat = xlat(i,j) * degrad
+!       cosz(i) = sin(xxlat) * sin(declin) + &
+!                 cos(xxlat) * cos(declin) * cos(hrang)
 
 !
 ! surface spectrum albedo for direct and diffuse radiation
@@ -873,16 +919,38 @@ subroutine goddardrad( rthraten, gsf, xlat,xlong               &
       end do
    end do
 
+   ! jararias 2013/11
+   if ( present (tauaer3d_sw) ) then
+      if ( aer_opt .eq. 2 ) then
+         do ib=1,ib_sw
+            do i=its,ite
+               taual_sw(i,kts-1,ib)=0.
+               ssaal_sw(i,kts-1,ib)=0.
+               asyal_sw(i,kts-1,ib)=0.
+               do k=kts,kte
+                  nk=kte+kts-k
+                  taual_sw(i,nk,ib)=tauaer3d_sw(i,k,j,ib)
+                  ssaal_sw(i,nk,ib)=ssaaer3d_sw(i,k,j,ib)
+                  asyal_sw(i,nk,ib)=asyaer3d_sw(i,k,j,ib)
+               end do
+            end do
+         end do
+      end if
+   end if
 !
 ! 1-dimension driver of shortwave radiative transfer scheme
 !
      do i = its,ite
       if (cosz(i) .gt. cosz_min) then !for daytime only
-      call swrad ( m=1, np=mkx+1, pl=p8w2d(i,:), ta=t2d(i,:), wa=sh2d(i,:), oa=o3(i,:),         &
-                   cwc=cwc(i,:,:), reff=reff(i,:,:), fcld=fcld2d(i,:), ict=ict(i), icb=icb(i),      &
-                   taual=taual_sw(i,:,:), ssaal=ssaal_sw(i,:,:), asyal=asyal_sw(i,:,:), &
-                   cosz=cosz(i), rsuvbm=rsuvbm(i), rsuvdf=rsuvdf(i), rsirbm=rsirbm(i), rsirdf=rsirdf(i),  &
-                   flx=flx(i,:), flxd=flxd(i,:),flxu=flxu(i,:) )
+         call swrad ( m=1, np=mkx+1, pl=p8w2d(i,:), ta=t2d(i,:), wa=sh2d(i,:), oa=o3(i,:),                   &
+                      cwc=cwc(i,:,:), reff=reff(i,:,:), fcld=fcld2d(i,:), ict=ict(i), icb=icb(i),            &
+                      taual=taual_sw(i,:,:), ssaal=ssaal_sw(i,:,:), asyal=asyal_sw(i,:,:),                   &
+                      cosz=cosz(i), rsuvbm=rsuvbm(i), rsuvdf=rsuvdf(i), rsirbm=rsirbm(i), rsirdf=rsirdf(i),  &
+                      flx=flx(i,:), flxd=flxd(i,:),flxu=flxu(i,:),                                           &
+                      ! -- jararias, 14/08/2013
+                      fdiruv=fdiruv(i),fdifuv=fdifuv(i),                                                     &
+                      fdirpar=fdirpar(i),fdifpar=fdifpar(i),                                                 &
+                      fdirir=fdirir(i),fdifir=fdifir(i)                                                      )
       endif
      enddo
 !
@@ -892,8 +960,14 @@ subroutine goddardrad( rthraten, gsf, xlat,xlong               &
         do i = its, ite
           if (cosz(i) .le. cosz_min) then
             flx(i,k) = 0.
+            swddir(i,j) = 0. !jararias, 14/08/2013
+            swddif(i,j) = 0. !jararias, 14/08/2013
+            swddni(i,j) = 0. !jararias, 14/08/2013
           else
             flx(i,k) = flx(i,k) * solcon * cosz(i)
+            swddni(i,j) = ( fdiruv(i) + fdirpar(i) + fdirir(i) ) * solcon           !jararias, 14/08/2013
+            swddir(i,j) = swddni(i,j) * cosz(i)                                     !jararias, 14/08/2013
+            swddif(i,j) = ( fdifuv(i) + fdifpar(i) + fdifir(i) ) * solcon * cosz(i) !jararias, 14/08/2013
           endif
         end do
       end do
@@ -1033,9 +1107,10 @@ end subroutine goddardrad
 !GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
 !GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD GODDARD 
 
-  subroutine swrad (m,np,pl,ta,wa,oa, cwc,reff,fcld,ict,icb, &
+  subroutine swrad (m,np,pl,ta,wa,oa, cwc,reff,fcld,ict,icb,             &
                     taual,ssaal,asyal, cosz,rsuvbm,rsuvdf,rsirbm,rsirdf, &
-                    flx,flxd,flxu) 
+                    flx,flxd,flxu,                                       &
+                    fdiruv,fdifuv,fdirpar,fdifpar,fdirir,fdifir          ) !jararias, 14/08/2013
 
 !------------     corrections for bugs      ----------------------------
 !
@@ -1174,9 +1249,9 @@ subroutine swrad (m,np,pl,ta,wa,oa, cwc,reff,fcld,ict,icb, &
  real(Kind=fp_kind),intent(inout) :: flxu(m,np+1)   !upwelling flux fraction []
 !-----IO parameter used to be-----
  real(Kind=fp_kind) flc(m,np+1)
- real(Kind=fp_kind) fdiruv (m),fdifuv (m)
- real(Kind=fp_kind) fdirpar(m),fdifpar(m)
- real(Kind=fp_kind) fdirir (m),fdifir (m)
+ real(Kind=fp_kind),intent(inout) :: fdiruv (m),fdifuv (m)
+ real(Kind=fp_kind),intent(inout) :: fdirpar(m),fdifpar(m)
+ real(Kind=fp_kind),intent(inout) :: fdirir (m),fdifir (m)
 
 !-----temporary array
  integer i,j,k,ntop
diff --git a/wrfv2_fire/phys/module_ra_gsfcsw.F b/wrfv2_fire/phys/module_ra_gsfcsw.F
index a7de8d2a..9ef5bf49 100644
--- a/wrfv2_fire/phys/module_ra_gsfcsw.F
+++ b/wrfv2_fire/phys/module_ra_gsfcsw.F
@@ -625,12 +625,35 @@ SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong                   &
 ! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths
 ! these are: 200,235,270,287.5,302.5,305,362.5,550,1920,1745,6135; why the emphasis on the UV?
 ! taual - use angstrom exponent
-        if(tauaer300(i,k+1,j).gt.thresh .and. tauaer999(i,k+1,j).gt.thresh) then
-           ang=log(tauaer300(i,k+1,j)/tauaer999(i,k+1,j))/log(999./300.)
-!       write(6,*)i,k,ang,tauaer300(i,k+1,j),tauaer999(i,k+1,j)
-           taual(i,kte-k,ib)=tauaer400(i,k+1,j)*(0.4/midbands(ib))**ang ! notice reserved variable
-!       write(6,10001)i,k,ang,tauaer300(i,k+1,j),tauaer999(i,k+1,j),midbands(ib),taual(i,k,ib)
-!10001      format(i3,i3,5f12.6)
+        if(tauaer300(i,k+1,j).gt.thresh .and. tauaer999(i,k+1,j).gt.thresh .and. &
+           tauaer400(i,k+1,j).gt.thresh .and. tauaer600(i,k+1,j).gt.thresh) then
+! avoid negative ang that makes taual explode and crashes wrf
+           if(tauaer300(i,k+1,j).gt.tauaer999(i,k+1,j)) then 
+            ang=log(tauaer300(i,k+1,j)/tauaer999(i,k+1,j))/log(999./300.)
+ !       write(6,*)i,k,ang,tauaer300(i,k+1,j),tauaer999(i,k+1,j)
+            taual(i,kte-k,ib)=tauaer400(i,k+1,j)*(0.4/midbands(ib))**ang ! notice reserved variable
+ !       write(6,10001)i,k,ang,tauaer300(i,k+1,j),tauaer999(i,k+1,j),midbands(ib),taual(i,k,ib)
+ !10001      format(i3,i3,5f12.6)
+! use ang exponent for closer wavelenghts
+           else 
+            if(midbands(ib) .lt. 0.5) then
+             ang=log(tauaer300(i,k+1,j)/tauaer400(i,k+1,j))/log(400./300.)
+             taual(i,kte-k,ib)=tauaer400(i,k+1,j)*(0.4/midbands(ib))**ang ! notice reserved variable
+            else
+             ang=log(tauaer600(i,k+1,j)/tauaer999(i,k+1,j))/log(999./600.)
+             taual(i,kte-k,ib)=tauaer600(i,k+1,j)*(0.6/midbands(ib))**ang ! notice reserved variable   
+            endif
+           endif
+
+           ! diagnostic message
+           if(taual(i,kte-k,ib) .gt. 5.0) then
+            write(msg,'("WARNING: Large local optical depth of ",f8.2," at point i,j,k,ib=",4i5)') taual(i,kte-k,ib),i,j,k,ib
+            call wrf_debug(100, msg)
+            write(msg,'("Diagnostics: ang, tauaer300, tauaer400,tauaer600, tauaer999")')
+            call wrf_debug(100, msg)
+            write(msg,'(5E14.2)') ang,tauaer300(i,k+1,j),tauaer400(i,k+1,j),tauaer600(i,k+1,j),tauaer999(i,k+1,j)
+            call wrf_debug(100, msg)
+           endif
 
 ! ssa - linear interpolation; extrapolation
            slope=(waer600(i,k+1,j)-waer400(i,k+1,j))/.2
diff --git a/wrfv2_fire/phys/module_ra_rrtmg_lw.F b/wrfv2_fire/phys/module_ra_rrtmg_lw.F
index b92cd537..c565cd45 100644
--- a/wrfv2_fire/phys/module_ra_rrtmg_lw.F
+++ b/wrfv2_fire/phys/module_ra_rrtmg_lw.F
@@ -2087,8 +2087,8 @@ module mcica_subcol_gen_lw
 !------------------------------------------------------------------
 
       subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
-                       cldfrac, ciwp, clwp, rei, rel, tauc, cldfmcl, &
-                       ciwpmcl, clwpmcl, reicmcl, relqmcl, taucmcl)
+                       cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, cldfmcl, &
+                       ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, taucmcl)
 
 ! ----- Input -----
 ! Control
@@ -2121,10 +2121,14 @@ subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
                                                       !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: clwp(:,:)          ! in-cloud liquid water path
                                                       !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cswp(:,:)          ! in-cloud snow path
+                                                      !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: rei(:,:)           ! cloud ice particle size
                                                       !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: rel(:,:)           ! cloud liquid particle size
                                                       !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: res(:,:)           ! snow particle size
+                                                      !    Dimensions: (ncol,nlay)
 
 ! ----- Output -----
 ! Atmosphere/clouds - cldprmc [mcica]
@@ -2134,10 +2138,14 @@ subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
                                                       !    Dimensions: (ngptlw,ncol,nlay)
       real(kind=rb), intent(out) :: clwpmcl(:,:,:)    ! in-cloud liquid water path [mcica]
                                                       !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(out) :: cswpmcl(:,:,:)    ! in-cloud snow path [mcica]
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
       real(kind=rb), intent(out) :: relqmcl(:,:)      ! liquid particle size (microns)
                                                       !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(out) :: reicmcl(:,:)      ! ice partcle size (microns)
                                                       !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(out) :: resnmcl(:,:)      ! snow partcle size (microns)
+                                                      !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(out) :: taucmcl(:,:,:)    ! in-cloud optical depth [mcica]
                                                       !    Dimensions: (ngptlw,ncol,nlay)
 !      real(kind=rb), intent(out) :: ssacmcl(:,:,:)   ! in-cloud single scattering albedo [mcica]
@@ -2171,6 +2179,7 @@ subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
 
       reicmcl(:ncol,:nlay) = rei(:ncol,:nlay)
       relqmcl(:ncol,:nlay) = rel(:ncol,:nlay)
+      resnmcl(:ncol,:nlay) = res(:ncol,:nlay)
       pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb
 
 ! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components 
@@ -2189,15 +2198,15 @@ subroutine mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
 !      enddo
 
 !  Generate the stochastic subcolumns of cloud optical properties for the longwave;
-      call generate_stochastic_clouds (ncol, nlay, nsubclw, icld, irng, pmid, cldfrac, clwp, ciwp, tauc, &
-                               cldfmcl, clwpmcl, ciwpmcl, taucmcl, permuteseed)
+      call generate_stochastic_clouds (ncol, nlay, nsubclw, icld, irng, pmid, cldfrac, clwp, ciwp, cswp, tauc, &
+                               cldfmcl, clwpmcl, ciwpmcl, cswpmcl, taucmcl, permuteseed)
 
       end subroutine mcica_subcol_lw
 
 
 !-------------------------------------------------------------------------------------------------
-      subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld, clwp, ciwp, tauc, &
-                                   cld_stoch, clwp_stoch, ciwp_stoch, tauc_stoch, changeSeed) 
+      subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld, clwp, ciwp, cswp, tauc, &
+                                   cld_stoch, clwp_stoch, ciwp_stoch, cswp_stoch, tauc_stoch, changeSeed) 
 !-------------------------------------------------------------------------------------------------
 
   !----------------------------------------------------------------------------------------------------------------
@@ -2281,6 +2290,8 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld
                                                       !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: ciwp(:,:)          ! in-cloud ice water path
                                                       !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cswp(:,:)          ! in-cloud snow path
+                                                      !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: tauc(:,:,:)        ! in-cloud optical depth
                                                       !    Dimensions: (nbndlw,ncol,nlay)
 !      real(kind=rb), intent(in) :: ssac(:,:,:)       ! in-cloud single scattering albedo
@@ -2296,6 +2307,8 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld
                                                       !    Dimensions: (ngptlw,ncol,nlay)
       real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
                                                       !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow path
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
       real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
                                                       !    Dimensions: (ngptlw,ncol,nlay)
 !      real(kind=rb), intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo
@@ -2522,6 +2535,7 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld
                   cld_stoch(isubcol,i,ilev) = 1._rb
                   clwp_stoch(isubcol,i,ilev) = clwp(i,ilev)
                   ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev)
+                  cswp_stoch(isubcol,i,ilev) = cswp(i,ilev)
                   n = ngb(isubcol)
                   tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev)
 !                  ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev)
@@ -2530,6 +2544,7 @@ subroutine generate_stochastic_clouds(ncol, nlay, nsubcol, icld, irng, pmid, cld
                   cld_stoch(isubcol,i,ilev) = 0._rb
                   clwp_stoch(isubcol,i,ilev) = 0._rb
                   ciwp_stoch(isubcol,i,ilev) = 0._rb
+                  cswp_stoch(isubcol,i,ilev) = 0._rb
                   tauc_stoch(isubcol,i,ilev) = 0._rb
 !                  ssac_stoch(isubcol,i,ilev) = 1._rb
 !                  asmc_stoch(isubcol,i,ilev) = 1._rb
@@ -2636,7 +2651,7 @@ module rrtmg_lw_cldprmc
 
 ! ------------------------------------------------------------------------------
       subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
-                         ciwpmc, clwpmc, reicmc, relqmc, ncbands, taucmc)
+                         ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, ncbands, taucmc)
 ! ------------------------------------------------------------------------------
 
 ! Purpose:  Compute the cloud optical depth(s) for each cloudy layer.
@@ -2654,10 +2669,14 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
                                                       !    Dimensions: (ngptlw,nlayers)
       real(kind=rb), intent(in) :: clwpmc(:,:)        ! cloud liquid water path [mcica]
                                                       !    Dimensions: (ngptlw,nlayers)
+      real(kind=rb), intent(in) :: cswpmc(:,:)        ! cloud snow path [mcica]
+                                                      !    Dimensions: (ngptlw,nlayers)
       real(kind=rb), intent(in) :: relqmc(:)          ! liquid particle effective radius (microns)
                                                       !    Dimensions: (nlayers)
       real(kind=rb), intent(in) :: reicmc(:)          ! ice particle effective radius (microns)
                                                       !    Dimensions: (nlayers)
+      real(kind=rb), intent(in) :: resnmc(:)          ! snow particle effective radius (microns)
+                                                      !    Dimensions: (nlayers)
                                                       ! specific definition of reicmc depends on setting of iceflag:
                                                       ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992),
                                                       !              r_ec must be >= 10.0 microns
@@ -2685,13 +2704,16 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
 
       real(kind=rb) :: abscoice(ngptlw)               ! ice absorption coefficients
       real(kind=rb) :: abscoliq(ngptlw)               ! liquid absorption coefficients
+      real(kind=rb) :: abscosno(ngptlw)               ! snow absorption coefficients
       real(kind=rb) :: cwp                            ! cloud water path
       real(kind=rb) :: radice                         ! cloud ice effective size (microns)
       real(kind=rb) :: factor                         ! 
       real(kind=rb) :: fint                           ! 
       real(kind=rb) :: radliq                         ! cloud liquid droplet radius (microns)
+      real(kind=rb) :: radsno                         ! cloud snow effective size (microns)
       real(kind=rb), parameter :: eps = 1.e-6_rb      ! epsilon
       real(kind=rb), parameter :: cldmin = 1.e-20_rb  ! minimum value for cloud quantities
+      character*80 errmess
 
 ! ------- Definitions -------
 
@@ -2765,7 +2787,7 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
       do lay = 1, nlayers
 
         do ig = 1, ngptlw
-          cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
+          cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) + cswpmc(ig,lay)
           if (cldfmc(ig,lay) .ge. cldmin .and. &
              (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then
 
@@ -2780,16 +2802,18 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
 !               taucmc(ig,lay) = abscld1 * cwp
 
 ! Separate treatement of ice clouds and water clouds.
-            elseif(inflag .eq. 2) then
+            elseif(inflag .ge. 2) then
                radice = reicmc(lay)
 
 ! Calculation of absorption coefficients due to ice clouds.
-               if (ciwpmc(ig,lay) .eq. 0.0_rb) then
+               if ((ciwpmc(ig,lay)+cswpmc(ig,lay)) .eq. 0.0_rb) then
                   abscoice(ig) = 0.0_rb
+                  abscosno(ig) = 0.0_rb
 
                elseif (iceflag .eq. 0) then
                   if (radice .lt. 10.0_rb) stop 'ICE RADIUS TOO SMALL'
                   abscoice(ig) = absice0(1) + absice0(2)/radice
+                  abscosno(ig) = 0.0_rb
 
                elseif (iceflag .eq. 1) then
                   if (radice .lt. 13.0_rb .or. radice .gt. 130._rb) stop &
@@ -2797,6 +2821,7 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
                   ncbands = 5
                   ib = icb(ngb(ig))
                   abscoice(ig) = absice1(1,ib) + absice1(2,ib)/radice
+                  abscosno(ig) = 0.0_rb
 
 ! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns
 
@@ -2811,11 +2836,17 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
                      abscoice(ig) = &
                          absice2(index,ib) + fint * &
                          (absice2(index+1,ib) - (absice2(index,ib))) 
+                     abscosno(ig) = 0.0_rb
                
 ! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
 
-               elseif (iceflag .eq. 3) then
-                  if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
+               elseif (iceflag .ge. 3) then
+                  if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) then
+                         write(errmess,'(A,i5,i5,f8.2,f8.2)' )         &
+               'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'   &
+               ,ig, lay, ciwpmc(ig,lay), radice
+                         call wrf_error_fatal(errmess)
+                     end if
                      ncbands = 16
                      factor = (radice - 2._rb)/3._rb
                      index = int(factor)
@@ -2825,8 +2856,30 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
                      abscoice(ig) = &
                          absice3(index,ib) + fint * &
                          (absice3(index+1,ib) - (absice3(index,ib)))
+                     abscosno(ig) = 0.0_rb
    
                endif
+
+!..Incorporate additional effects due to snow.
+               if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then
+                  radsno = resnmc(lay)
+                  if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then
+                         write(errmess,'(A,i5,i5,f8.2,f8.2)' )         &
+               'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'   &
+               ,ig, lay, cswpmc(ig,lay), radsno
+                         call wrf_error_fatal(errmess)
+                     end if
+                     ncbands = 16
+                     factor = (radsno - 2._rb)/3._rb
+                     index = int(factor)
+                     if (index .eq. 46) index = 45
+                     fint = factor - float(index)
+                     ib = ngb(ig)
+                     abscosno(ig) = &
+                         absice3(index,ib) + fint * &
+                         (absice3(index+1,ib) - (absice3(index,ib)))
+               endif
+
                   
 ! Calculation of absorption coefficients due to water clouds.
                if (clwpmc(ig,lay) .eq. 0.0_rb) then
@@ -2850,7 +2903,8 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, &
                endif
 
                taucmc(ig,lay) = ciwpmc(ig,lay) * abscoice(ig) + &
-                                clwpmc(ig,lay) * abscoliq(ig)
+                                clwpmc(ig,lay) * abscoliq(ig) + &
+                                cswpmc(ig,lay) * abscosno(ig)
 
             endif
          endif
@@ -10521,7 +10575,7 @@ subroutine rrtmg_lw &
              h2ovmr  ,o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr  ,o2vmr , &
              cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis    , &
              inflglw ,iceflglw,liqflglw,cldfmcl , &
-             taucmcl ,ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
+             taucmcl ,ciwpmcl ,clwpmcl , cswpmcl ,reicmcl ,relqmcl , resnmcl , &
              tauaer  , &
              uflx    ,dflx    ,hr      ,uflxc   ,dflxc,  hrc)
 
@@ -10665,6 +10719,8 @@ subroutine rrtmg_lw &
                                                       !    Dimensions: (ngptlw,ncol,nlay)
       real(kind=rb), intent(in) :: clwpmcl(:,:,:)     ! In-cloud liquid water path (g/m2)
                                                       !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(in) :: cswpmcl(:,:,:)     ! In-cloud snow water path (g/m2)
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
       real(kind=rb), intent(in) :: reicmcl(:,:)       ! Cloud ice particle effective size (microns)
                                                       !    Dimensions: (ncol,nlay)
                                                       ! specific definition of reicmcl depends on setting of iceflglw:
@@ -10679,6 +10735,8 @@ subroutine rrtmg_lw &
                                                       !               [dge = 1.0315 * r_ec]
       real(kind=rb), intent(in) :: relqmcl(:,:)       ! Cloud water drop effective radius (microns)
                                                       !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: resnmcl(:,:)       ! Snow effective radius (microns)
+                                                      !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: taucmcl(:,:,:)     ! In-cloud optical depth
                                                       !    Dimensions: (ngptlw,ncol,nlay)
 !      real(kind=rb), intent(in) :: ssacmcl(:,:,:)    ! In-cloud single scattering albedo
@@ -10805,8 +10863,10 @@ subroutine rrtmg_lw &
       real(kind=rb) :: cldfmc(ngptlw,nlay+1)  ! cloud fraction [mcica]
       real(kind=rb) :: ciwpmc(ngptlw,nlay+1)  ! in-cloud ice water path [mcica]
       real(kind=rb) :: clwpmc(ngptlw,nlay+1)  ! in-cloud liquid water path [mcica]
+      real(kind=rb) :: cswpmc(ngptlw,nlay+1)  ! in-cloud snow path [mcica]
       real(kind=rb) :: relqmc(nlay+1)         ! liquid particle effective radius (microns)
       real(kind=rb) :: reicmc(nlay+1)         ! ice particle effective size (microns)
+      real(kind=rb) :: resnmc(nlay+1)         ! snow particle effective size (microns)
       real(kind=rb) :: taucmc(ngptlw,nlay+1)  ! in-cloud optical depth [mcica]
 !      real(kind=rb) :: ssacmc(ngptlw,nlay+1) ! in-cloud single scattering albedo [mcica]
                                               !   for future expansion 
@@ -10872,10 +10932,10 @@ subroutine rrtmg_lw &
               play, plev, tlay, tlev, tsfc, h2ovmr, &
               o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, &
               cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, &
-              cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, &
+              cldfmcl, taucmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, tauaer, &
               nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, &
               wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, &
-              cldfmc, taucmc, ciwpmc, clwpmc, reicmc, relqmc, taua)
+              cldfmc, taucmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, taua)
 
 !  For cloudy atmosphere, use cldprop to set cloud optical properties based on
 !  input cloud physical properties.  Select method based on choices described
@@ -10884,7 +10944,7 @@ subroutine rrtmg_lw &
 !  optical depth are transferred to rrtmg_lw arrays in cldprop.  
 
          call cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, ciwpmc, &
-                      clwpmc, reicmc, relqmc, ncbands, taucmc)
+                      clwpmc, cswpmc, reicmc, relqmc, resnmc, ncbands, taucmc)
 
 ! Calculate information needed by the radiative transfer routine
 ! that is specific to this atmosphere, especially some of the 
@@ -10967,10 +11027,10 @@ subroutine inatm (iplon, nlay, icld, iaer, &
               play, plev, tlay, tlev, tsfc, h2ovmr, &
               o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, cfc11vmr, cfc12vmr, &
               cfc22vmr, ccl4vmr, emis, inflglw, iceflglw, liqflglw, &
-              cldfmcl, taucmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, tauaer, &
+              cldfmcl, taucmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, tauaer, &
               nlayers, pavel, pz, tavel, tz, tbound, semiss, coldry, &
               wkl, wbrodl, wx, pwvcm, inflag, iceflag, liqflag, &
-              cldfmc, taucmc, ciwpmc, clwpmc, reicmc, relqmc, taua)
+              cldfmc, taucmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, taua)
 !***************************************************************************
 !
 !  Input atmospheric profile from GCM, and prepare it for use in RRTMG_LW.
@@ -11035,10 +11095,14 @@ subroutine inatm (iplon, nlay, icld, iaer, &
                                                       !    Dimensions: (ngptlw,ncol,nlay)
       real(kind=rb), intent(in) :: clwpmcl(:,:,:)     ! In-cloud liquid water path (g/m2)
                                                       !    Dimensions: (ngptlw,ncol,nlay)
+      real(kind=rb), intent(in) :: cswpmcl(:,:,:)     ! In-cloud snow water path (g/m2)
+                                                      !    Dimensions: (ngptlw,ncol,nlay)
       real(kind=rb), intent(in) :: relqmcl(:,:)       ! Cloud water drop effective radius (microns)
                                                       !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: reicmcl(:,:)       ! Cloud ice effective size (microns)
                                                       !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: resnmcl(:,:)       ! Snow effective size (microns)
+                                                      !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: taucmcl(:,:,:)     ! In-cloud optical depth
                                                       !    Dimensions: (ngptlw,ncol,nlay)
       real(kind=rb), intent(in) :: tauaer(:,:,:)      ! Aerosol optical depth
@@ -11080,10 +11144,14 @@ subroutine inatm (iplon, nlay, icld, iaer, &
                                                       !    Dimensions: (ngptlw,nlay)
       real(kind=rb), intent(out) :: clwpmc(:,:)       ! in-cloud liquid water path [mcica]
                                                       !    Dimensions: (ngptlw,nlay)
+      real(kind=rb), intent(out) :: cswpmc(:,:)       ! in-cloud snow path [mcica]
+                                                      !    Dimensions: (ngptlw,nlay)
       real(kind=rb), intent(out) :: relqmc(:)         ! liquid particle effective radius (microns)
                                                       !    Dimensions: (nlay)
       real(kind=rb), intent(out) :: reicmc(:)         ! ice particle effective size (microns)
                                                       !    Dimensions: (nlay)
+      real(kind=rb), intent(out) :: resnmc(:)         ! snow effective size (microns)
+                                                      !    Dimensions: (nlay)
       real(kind=rb), intent(out) :: taucmc(:,:)       ! in-cloud optical depth [mcica]
                                                       !    Dimensions: (ngptlw,nlay)
       real(kind=rb), intent(out) :: taua(:,:)         ! aerosol optical depth
@@ -11129,8 +11197,10 @@ subroutine inatm (iplon, nlay, icld, iaer, &
       taucmc(:,:) = 0.0_rb
       ciwpmc(:,:) = 0.0_rb
       clwpmc(:,:) = 0.0_rb
+      cswpmc(:,:) = 0.0_rb
       reicmc(:) = 0.0_rb
       relqmc(:) = 0.0_rb
+      resnmc(:) = 0.0_rb
       taua(:,:) = 0.0_rb
       amttl = 0.0_rb
       wvttl = 0.0_rb
@@ -11270,9 +11340,11 @@ subroutine inatm (iplon, nlay, icld, iaer, &
                taucmc(ig,l) = taucmcl(ig,iplon,l)
                ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
                clwpmc(ig,l) = clwpmcl(ig,iplon,l)
+               cswpmc(ig,l) = cswpmcl(ig,iplon,l)
             enddo
             reicmc(l) = reicmcl(iplon,l)
             relqmc(l) = relqmcl(iplon,l)
+            resnmc(l) = resnmcl(iplon,l)
          enddo
 
 ! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer.
@@ -11339,12 +11411,16 @@ SUBROUTINE RRTMG_LWRAD(                                        &
                        p8w, p3d, pi3d,                            &
                        dz8w, tsk, t3d, t8w, rho3d, r, g,          &
                        icloud, warm_rain, cldfra3d,               &
+                       lradius,iradius,                           & 
+                       is_cammgmp_used,                           & 
                        f_ice_phy, f_rain_phy,                     &
                        xland, xice, snow,                         &
                        qv3d, qc3d, qr3d,                          &
                        qi3d, qs3d, qg3d,                          &
                        o3input, o33d,                             &
                        f_qv, f_qc, f_qr, f_qi, f_qs, f_qg,        &
+                       re_cloud, re_ice, re_snow,                 &  ! G. Thompson
+                       has_reqc, has_reqi, has_reqs,              &  ! G. Thompson
                        tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4,   & ! czhao 
                        tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8,   & ! czhao 
                        tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12,   & ! czhao 
@@ -11354,20 +11430,21 @@ SUBROUTINE RRTMG_LWRAD(                                        &
                        progn,                                     & !czhao
                        qndrop3d,f_qndrop,                         & !czhao
 !ccc added for time varying gases.
-                       yr,julian,                                 & 
-!ccc 
+                       yr,julian,                                 &
+!ccc
                        ids,ide, jds,jde, kds,kde,                 & 
                        ims,ime, jms,jme, kms,kme,                 &
                        its,ite, jts,jte, kts,kte,                 &
                        lwupflx, lwupflxc, lwdnflx, lwdnflxc       &
                                                                   )
-!------------------------------------------------------------------                                                                  )
+!------------------------------------------------------------------
 !ccc To use clWRF time varying trace gases
    USE MODULE_RA_CLWRF_SUPPORT, ONLY : read_CAMgases
 
    IMPLICIT NONE
 !------------------------------------------------------------------
    LOGICAL, INTENT(IN )      ::        warm_rain
+   LOGICAL, INTENT(IN )      ::   is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP
 !
    INTEGER, INTENT(IN )      ::        ids,ide, jds,jde, kds,kde, &
                                        ims,ime, jms,jme, kms,kme, &
@@ -11402,7 +11479,6 @@ SUBROUTINE RRTMG_LWRAD(                                        &
          INTENT(IN   )  ::                                 XLAND, &
                                                             XICE, &
                                                             SNOW
-
 !ccc Added for time-varying trace gases.
    INTEGER, INTENT(IN    ) ::                                 yr
    REAL, INTENT(IN    ) ::                                julian
@@ -11415,6 +11491,9 @@ SUBROUTINE RRTMG_LWRAD(                                        &
          OPTIONAL                                               , &
          INTENT(IN   ) ::                                         &
                                                         CLDFRA3D, &
+                                                         LRADIUS, &
+                                                         IRADIUS, &
+
                                                             QV3D, &
                                                             QC3D, &
                                                             QR3D, &
@@ -11422,6 +11501,14 @@ SUBROUTINE RRTMG_LWRAD(                                        &
                                                             QS3D, &
                                                             QG3D, &
                                                         QNDROP3D
+
+!..Added by G. Thompson to couple cloud physics effective radii.
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN)::         &
+                                                        re_cloud, &
+                                                          re_ice, &
+                                                         re_snow
+   INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
+
    real pi,third,relconst,lwpmin,rhoh2o
 
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
@@ -11510,6 +11597,7 @@ SUBROUTINE RRTMG_LWRAD(                                        &
 ! For old cloud property specification for rrtm_lw
     real, dimension( kts:kte )  ::                          clwp, &
                                                             ciwp, &
+                                                            cswp, &
                                                             plwp, &
                                                             piwp
 ! Surface emissivity (for 16 LW spectral bands)
@@ -11518,15 +11606,19 @@ SUBROUTINE RRTMG_LWRAD(                                        &
 ! though no clouds are allowed in extra layer
     real, dimension( 1, kts:nlayers )  ::                 clwpth, &
                                                           ciwpth, &
+                                                          cswpth, &
                                                              rel, &
                                                              rei, &
+                                                             res, &
                                                          cldfrac, &
                                                          relqmcl, &
-                                                         reicmcl
+                                                         reicmcl, &
+                                                         resnmcl
     real, dimension( nbndlw, 1, kts:nlayers )  ::        taucld
     real, dimension( ngptlw, 1, kts:nlayers )  ::        cldfmcl, &
                                                          clwpmcl, &
                                                          ciwpmcl, &
+                                                         cswpmcl, &
                                                          taucmcl
     real, dimension( 1, kts:nlayers, nbndlw )  ::           tauaer
 
@@ -11542,15 +11634,20 @@ SUBROUTINE RRTMG_LWRAD(                                        &
                                                               ps
     real ::                                                   ro, &
                                                               dz
+    real:: snow_mass_factor
 
-!ccc To add time-varying trace gases (CO2, N2O and CH4). Read the conc. from file
+!..We can use message interface regardless of what options are running,
+!.. so let us ask for it here.
+      CHARACTER(LEN=256)                           :: message
+      LOGICAL, EXTERNAL                            :: wrf_dm_on_monitor
+
+!ccc To add time-varying trace gases (CO2, N2O and CH4). Read the conc.  from file
 ! then interpolate to date of run.
 #ifdef CLWRFGHG
-! CLWRF-UC June.09 
-      REAL(8)                                      :: co2, n2o, ch4, cfc11, cfc12 
-      LOGICAL, EXTERNAL                            :: wrf_dm_on_monitor
-      CHARACTER(LEN=256)                           :: message
+! CLWRF-UC June.09
+      REAL(8)                                      :: co2, n2o, ch4, cfc11, cfc12
 #else
+
 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
 ! carbon dioxide (379 ppmv)
     real :: co2
@@ -11612,9 +11709,14 @@ SUBROUTINE RRTMG_LWRAD(                                        &
 
     real, dimension(1, 1:kte-kts+1) ::   cicewp, &     ! in-cloud cloud ice water path
                                          cliqwp, &     ! in-cloud cloud liquid water path
+                                         csnowp, &     ! in-cloud snow water path
                                           reliq, &     ! effective drop radius (microns)
-                                          reice        ! ice effective drop size (microns)
-    real :: gliqwp, gicewp, gravmks
+                                          reice        ! effective ice crystal size (microns)
+    real, dimension(1, 1:kte-kts+1):: recloud1d, &
+                                        reice1d, &
+                                       resnow1d
+
+    real :: gliqwp, gicewp, gsnowp, gravmks
 
 !
 !    REAL   ::  TSFC,GLW0,OLR0,EMISS0,FP
@@ -11690,7 +11792,7 @@ SUBROUTINE RRTMG_LWRAD(                                        &
 ! Pressures are in mb
 !
 !ccc Read time-varying trace gases concentrations and interpolate them to run date.
-! 
+!
 #ifdef CLWRFGHG
 
    CALL read_CAMgases(yr,julian,"RRTMG",co2,n2o,ch4,cfc11,cfc12)
@@ -11705,7 +11807,6 @@ SUBROUTINE RRTMG_LWRAD(                                        &
 #endif
 !ccc
 
-
 ! latitude loop
   j_loop: do j = jts,jte
 
@@ -11729,11 +11830,18 @@ SUBROUTINE RRTMG_LWRAD(                                        &
          DO K=kts,kte
             QV1D(K)=QV3D(I,K,J)
             QV1D(K)=max(0.,QV1D(K))
-            IF ( PRESENT( O33D ) ) THEN
-            O31D(K)=O33D(I,K,J)
-            ENDIF
          ENDDO
 
+         IF (PRESENT(O33D)) THEN
+            DO K=kts,kte
+               O31D(K)=O33D(I,K,J)
+            ENDDO
+         ELSE
+            DO K=kts,kte
+               O31D(K)=0.0
+            ENDDO
+         ENDIF
+
          DO K=kts,kte
             TTEN1D(K)=0.
             T1D(K)=T3D(I,K,J)
@@ -11829,7 +11937,8 @@ SUBROUTINE RRTMG_LWRAD(                                        &
             IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
                IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
                   DO K=kts,kte
-                     qi1d(k) = qs3d(i,k,j)
+                     qi1d(k) = 0.1*qs3d(i,k,j)
+                     qs1d(k) = 0.9*qs3d(i,k,j)
                      qc1d(k) = qc3d(i,k,j)
                      qi1d(k) = max(0.,qi1d(k))
                      qc1d(k) = max(0.,qc1d(k))
@@ -11868,6 +11977,56 @@ SUBROUTINE RRTMG_LWRAD(                                        &
          iceflglw = 3
          liqflglw = 1
 
+!Mukul change the flags here with reference to the new effective cloud/ice/snow radius
+         IF (ICLOUD .ne. 0) THEN
+            IF ( has_reqc .ne. 0) THEN
+               IF ( wrf_dm_on_monitor() ) THEN
+                 WRITE(message,*)'RRTMG: pre-computed cloud droplet effective radius found, setting inflglw=3'
+                 call wrf_debug(150, message)
+               ENDIF
+               inflglw = 3
+               DO K=kts,kte
+                  recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
+               ENDDO
+            ELSE
+               DO K=kts,kte
+                  recloud1D(ncol,K) = 5.0
+               ENDDO
+            ENDIF
+
+            IF ( has_reqi .ne. 0) THEN
+               IF ( wrf_dm_on_monitor() ) THEN
+                 WRITE(message,*)'RRTMG: pre-computed cloud ice effective radius found, setting inflglw=4 and iceflglw=4'
+                 call wrf_debug(150, message)
+               ENDIF
+               inflglw  = 4
+               iceflglw = 4
+               DO K=kts,kte
+                  reice1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
+               ENDDO
+            ELSE
+               DO K=kts,kte
+                  reice1D(ncol,K) = 10.0
+               ENDDO
+            ENDIF
+
+            IF ( has_reqs .ne. 0) THEN
+               IF ( wrf_dm_on_monitor() ) THEN
+                 WRITE(message,*)'RRTMG: pre-computed snow effective radius found, setting inflglw=5 and iceflglw=5'
+                 call wrf_debug(150, message)
+               ENDIF
+               inflglw  = 5
+               iceflglw = 5
+               DO K=kts,kte
+                  resnow1D(ncol,K) = MAX(10., re_snow(I,K,J)*1.E6)
+               ENDDO
+            ELSE
+               DO K=kts,kte
+                  resnow1D(ncol,K) = 10.0
+               ENDDO
+            ENDIF
+         ENDIF
+
 ! Layer indexing goes bottom to top here for all fields.
 ! Water vapor and ozone are converted from mmr to vmr. 
 ! Pressures are in units of mb here. 
@@ -11991,6 +12150,7 @@ SUBROUTINE RRTMG_LWRAD(                                        &
          call inirad (o3mmr,plev,kts,nlay-1)
 
 ! Steven Cavallo: Changed to nlayers from kte+1
+        if(present(o33d)) then
          do k = kts, nlayers
             o3vmr(ncol,k) = o3mmr(k) * amdo
             IF ( PRESENT( O33D ) ) THEN
@@ -11999,12 +12159,17 @@ SUBROUTINE RRTMG_LWRAD(                                        &
                  o3vmr(ncol,k) = o31d(k)
                else
 ! apply shifted climatology profile above model top
-                 o3vmr(ncol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo 
+                 o3vmr(ncol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo
                  if(o3vmr(ncol,k) .le. 0.)o3vmr(ncol,k) = o3mmr(k)*amdo
                endif
             endif
             ENDIF
          enddo
+        else
+         do k = kts, nlayers
+            o3vmr(ncol,k) = o3mmr(k) * amdo
+         enddo
+        endif
 
 ! Set surface emissivity in each RRTMG longwave band
          do nb = 1, nbndlw
@@ -12074,6 +12239,44 @@ SUBROUTINE RRTMG_LWRAD(                                        &
                cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k))               ! In-cloud liquid water path.
             end do
 
+
+! Mukul
+!..The ice water path is already sum of cloud ice and snow, but when we have explicit
+!.. ice effective radius, overwrite the ice path with only the cloud ice variable,
+!.. leaving out the snow for its own effect.
+           if(iceflglw.ge.4)then
+              do k = kts, kte
+                     gicewp = qi1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0     ! Grid box ice water path.
+                     cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k))               ! In-cloud ice water path.
+              end do
+           end if
+
+!..Here the snow path is adjusted if (radiation) effective radius of snow is
+!.. larger than what we currently have in the lookup tables.  Since mass goes
+!.. rather close to diameter squared, adjust the mixing ratio of snow used
+!.. to compute its water path in combination with the max diameter.  Not a
+!.. perfect fix, but certainly better than using all snow mass when diameter is
+!.. far larger than table currently contains and crystal sizes much larger than
+!.. about 140 microns have lesser impact than those much smaller sizes.
+
+           if(iceflglw.eq.5)then
+              do k = kts, kte
+                 snow_mass_factor = 1.0
+                 if (resnow1d(ncol,k) .gt. 130.)then
+                     snow_mass_factor = (130.0/resnow1d(ncol,k))*(130.0/resnow1d(ncol,k))
+                     resnow1d(ncol,k)   = 130.0
+                     IF ( wrf_dm_on_monitor() ) THEN
+                       WRITE(message,*)'RRTMG:  reducing snow mass (cloud path) to ', &
+                                       nint(snow_mass_factor*100.), ' percent of full value'
+                       call wrf_debug(150, message)
+                     ENDIF
+                 endif
+                 gsnowp = qs1d(k) * snow_mass_factor * pdel(ncol,k)*100.0 / gravmks * 1000.0     ! Grid box snow water path.
+                 csnowp(ncol,k) = gsnowp / max(0.01,cldfrac(ncol,k))
+              end do
+           end if
+
+
 !link the aerosol feedback to cloud  -czhao
   if( PRESENT( progn ) ) then
     if (progn == 1) then
@@ -12104,7 +12307,7 @@ SUBROUTINE RRTMG_LWRAD(                                        &
       end do
 !jdfcz     else ! prescribe 
 ! following Kiehl
-      call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+!     call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
 !     write(0,*) 'lw prescribe aerosol',maxval(qndrop3d)
 !jdfcz     endif
     else  ! progn   
@@ -12117,6 +12320,21 @@ SUBROUTINE RRTMG_LWRAD(                                        &
 ! following Kristjansson and Mitchell
             call reicalc(ncol, pcols, pver, tlay, reice)
 
+
+!..If we already have effective radius of cloud and ice, then just overwrite what
+!.. was computed in the relcalc and reicalc subroutines above.
+
+      if (inflglw .ge. 3) then
+         do k = kts, kte
+            reliq(ncol,k) = recloud1d(ncol,k)
+         end do
+      endif
+      if (iceflglw .ge. 4) then
+         do k = kts, kte
+            reice(ncol,k) = reice1d(ncol,k)
+         end do
+      endif
+
 ! Limit upper bound of reice for Fu ice parameterization and convert
 ! from effective radius to generalized effective size (*1.0315; Fu, 1996)
             if (iceflglw .eq. 3) then
@@ -12125,6 +12343,24 @@ SUBROUTINE RRTMG_LWRAD(                                        &
                   reice(ncol,k) = min(140.0,reice(ncol,k))
                end do
             endif
+!if CAMMGMP is used, use output from CAMMGMP
+            if(is_CAMMGMP_used) then
+               do k = kts, kte
+                  if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then
+                     reice(ncol,k) = iradius(i,k,j)
+                  else
+                     reice(ncol,k) = 25.
+                  end if
+                  reice(ncol,k) = max(5., min(140.0,reice(ncol,k)))
+                  if ( qc1d(k) .gt. 1.e-20) then
+                     reliq(ncol,k) = lradius(i,k,j)
+                  else
+                     reliq(ncol,k) = 10.
+                  end if
+                  reliq(ncol,k) = max(2.5, min(60.0,reliq(ncol,k)))
+               enddo
+            endif
+
 
 ! Set cloud physical property arrays
             do k = kts, kte
@@ -12134,6 +12370,19 @@ SUBROUTINE RRTMG_LWRAD(                                        &
                rei(ncol,k) = reice(ncol,k)
             enddo
 
+!Mukul
+            if (inflglw .eq. 5) then
+               do k = kts, kte
+                  cswpth(ncol,k) = csnowp(ncol,k)
+                  res(ncol,k) = resnow1d(ncol,k)
+               end do
+            else
+               do k = kts, kte
+                  cswpth(ncol,k) = 0.
+                  res(ncol,k) = 10.
+               end do
+            endif
+
 ! Zero out cloud optical properties here; not used when passing physical properties
 ! to radiation and taucld is calculated in radiation 
             do k = kts, kte
@@ -12150,8 +12399,10 @@ SUBROUTINE RRTMG_LWRAD(                                        &
 
          clwpth(ncol,kte+1) = 0.
          ciwpth(ncol,kte+1) = 0.
+         cswpth(ncol,kte+1) = 0.
          rel(ncol,kte+1) = 10.
          rei(ncol,kte+1) = 10.
+         res(ncol,kte+1) = 10.
          cldfrac(ncol,kte+1) = 0.
          do nb = 1, nbndlw
             taucld(nb,ncol,kte+1) = 0.
@@ -12163,8 +12414,10 @@ SUBROUTINE RRTMG_LWRAD(                                        &
 	 do k=kte+1,nlayers
 	    clwpth(ncol,k) = 0.
 	    ciwpth(ncol,k) = 0.
+	    cswpth(ncol,k) = 0.
 	    rel(ncol,k) = 10.
             rei(ncol,k) = 10.
+            res(ncol,k) = 10.
             cldfrac(ncol,k) = 0.
 	    do nb = 1,nbndlw
                taucld(nb,ncol,k) = 0.
@@ -12177,8 +12430,8 @@ SUBROUTINE RRTMG_LWRAD(                                        &
 
 ! Sub-column generator for McICA
          call mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
-                       cldfrac, ciwpth, clwpth, rei, rel, taucld, cldfmcl, &
-                       ciwpmcl, clwpmcl, reicmcl, relqmcl, taucmcl)
+                       cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, cldfmcl, &
+                       ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, taucmcl)
 
 !--------------------------------------------------------------------------
 ! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
@@ -12257,7 +12510,7 @@ SUBROUTINE RRTMG_LWRAD(                                        &
              h2ovmr  ,o3vmr   ,co2vmr  ,ch4vmr  ,n2ovmr  ,o2vmr , &
              cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis    , &
              inflglw ,iceflglw,liqflglw,cldfmcl , &
-             taucmcl ,ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
+             taucmcl ,ciwpmcl ,clwpmcl ,cswpmcl, reicmcl ,relqmcl ,resnmcl , &
              tauaer  , &
              uflx    ,dflx    ,hr      ,uflxc   ,dflxc,  hrc)
 
diff --git a/wrfv2_fire/phys/module_ra_rrtmg_sw.F b/wrfv2_fire/phys/module_ra_rrtmg_sw.F
index 21689501..0d5ec52f 100644
--- a/wrfv2_fire/phys/module_ra_rrtmg_sw.F
+++ b/wrfv2_fire/phys/module_ra_rrtmg_sw.F
@@ -1390,8 +1390,8 @@ module mcica_subcol_gen_sw
 !------------------------------------------------------------------
 
       subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
-                       cldfrac, ciwp, clwp, rei, rel, tauc, ssac, asmc, fsfc, &
-                       cldfmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, &
+                       cldfrac, ciwp, clwp, cswp, rei, rel, res, tauc, ssac, asmc, fsfc, &
+                       cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, &
                        taucmcl, ssacmcl, asmcmcl, fsfcmcl)
 
 ! ----- Input -----
@@ -1427,10 +1427,14 @@ subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
                                                       !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: clwp(:,:)          ! in-cloud liquid water path
                                                       !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cswp(:,:)          ! in-cloud snow water path
+                                                      !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: rei(:,:)           ! cloud ice particle size
                                                       !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: rel(:,:)           ! cloud liquid particle size
                                                       !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: res(:,:)           ! cloud snow particle size
+                                                      !    Dimensions: (ncol,nlay)
 
 ! ----- Output -----
 ! Atmosphere/clouds - cldprmc [mcica]
@@ -1440,10 +1444,14 @@ subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
                                                       !    Dimensions: (ngptsw,ncol,nlay)
       real(kind=rb), intent(out) :: clwpmcl(:,:,:)    ! in-cloud liquid water path [mcica]
                                                       !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: cswpmcl(:,:,:)    ! in-cloud snow water path [mcica]
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
       real(kind=rb), intent(out) :: relqmcl(:,:)      ! liquid particle size (microns)
                                                       !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(out) :: reicmcl(:,:)      ! ice partcle size (microns)
                                                       !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(out) :: resnmcl(:,:)      ! snow partcle size (microns)
+                                                      !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(out) :: taucmcl(:,:,:)    ! in-cloud optical depth [mcica]
                                                       !    Dimensions: (ngptsw,ncol,nlay)
       real(kind=rb), intent(out) :: ssacmcl(:,:,:)    ! in-cloud single scattering albedo [mcica]
@@ -1479,6 +1487,7 @@ subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
 
       reicmcl(:ncol,:nlay) = rei(:ncol,:nlay)
       relqmcl(:ncol,:nlay) = rel(:ncol,:nlay)
+      resnmcl(:ncol,:nlay) = res(:ncol,:nlay)
       pmid(:ncol,:nlay) = play(:ncol,:nlay)*1.e2_rb
 
 ! Convert input ice and liquid cloud water paths to specific humidity ice and liquid components 
@@ -1497,16 +1506,16 @@ subroutine mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
 !      enddo
 
 !  Generate the stochastic subcolumns of cloud optical properties for the shortwave;
-      call generate_stochastic_clouds_sw (ncol, nlay, nsubcsw, icld, irng, pmid, cldfrac, clwp, ciwp, &
-                               tauc, ssac, asmc, fsfc, cldfmcl, clwpmcl, ciwpmcl, &
+      call generate_stochastic_clouds_sw (ncol, nlay, nsubcsw, icld, irng, pmid, cldfrac, clwp, ciwp, cswp, &
+                               tauc, ssac, asmc, fsfc, cldfmcl, clwpmcl, ciwpmcl, cswpmcl, &
                                taucmcl, ssacmcl, asmcmcl, fsfcmcl, permuteseed)
 
       end subroutine mcica_subcol_sw
 
 
 !-------------------------------------------------------------------------------------------------
-      subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid, cld, clwp, ciwp, &
-                               tauc, ssac, asmc, fsfc, cld_stoch, clwp_stoch, ciwp_stoch, &
+      subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid, cld, clwp, ciwp, cswp, &
+                               tauc, ssac, asmc, fsfc, cld_stoch, clwp_stoch, ciwp_stoch, cswp_stoch,        &
                                tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed) 
 !-------------------------------------------------------------------------------------------------
 
@@ -1591,6 +1600,8 @@ subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid,
                                                       !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: ciwp(:,:)          ! in-cloud ice water path (g/m2)
                                                       !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: cswp(:,:)          ! in-cloud snow water path (g/m2)
+                                                      !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: tauc(:,:,:)        ! in-cloud optical depth (non-delta scaled)
                                                       !    Dimensions: (nbndsw,ncol,nlay)
       real(kind=rb), intent(in) :: ssac(:,:,:)        ! in-cloud single scattering albedo (non-delta scaled)
@@ -1606,6 +1617,8 @@ subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid,
                                                       !    Dimensions: (ngptsw,ncol,nlay)
       real(kind=rb), intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path
                                                       !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
       real(kind=rb), intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth
                                                       !    Dimensions: (ngptsw,ncol,nlay)
       real(kind=rb), intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo
@@ -1835,6 +1848,7 @@ subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid,
                   cld_stoch(isubcol,i,ilev) = 1._rb
                   clwp_stoch(isubcol,i,ilev) = clwp(i,ilev)
                   ciwp_stoch(isubcol,i,ilev) = ciwp(i,ilev)
+                  cswp_stoch(isubcol,i,ilev) = cswp(i,ilev)
                   n = ngb(isubcol) - ngbm
                   tauc_stoch(isubcol,i,ilev) = tauc(n,i,ilev)
                   ssac_stoch(isubcol,i,ilev) = ssac(n,i,ilev)
@@ -1844,6 +1858,7 @@ subroutine generate_stochastic_clouds_sw(ncol, nlay, nsubcol, icld, irng, pmid,
                   cld_stoch(isubcol,i,ilev) = 0._rb
                   clwp_stoch(isubcol,i,ilev) = 0._rb
                   ciwp_stoch(isubcol,i,ilev) = 0._rb
+                  cswp_stoch(isubcol,i,ilev) = 0._rb
                   tauc_stoch(isubcol,i,ilev) = 0._rb
                   ssac_stoch(isubcol,i,ilev) = 1._rb
                   asmc_stoch(isubcol,i,ilev) = 0._rb
@@ -1952,7 +1967,7 @@ module rrtmg_sw_cldprmc
 
 ! ----------------------------------------------------------------------------
       subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
-                            ciwpmc, clwpmc, reicmc, relqmc, &
+                            ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
                             taormc, taucmc, ssacmc, asmcmc, fsfcmc)
 ! ----------------------------------------------------------------------------
 
@@ -1974,6 +1989,10 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
                                                       !    Dimensions: (ngptsw,nlayers)
       real(kind=rb), intent(in) :: clwpmc(:,:)        ! cloud liquid water path [mcica]
                                                       !    Dimensions: (ngptsw,nlayers)
+      real(kind=rb), intent(in) :: cswpmc(:,:)        ! cloud snow water path [mcica]
+                                                      !    Dimensions: (ngptsw,nlayers)
+      real(kind=rb), intent(in) :: resnmc(:)          ! cloud snow particle effective radius (microns)
+                                                      !    Dimensions: (nlayers)
       real(kind=rb), intent(in) :: relqmc(:)          ! cloud liquid particle effective radius (microns)
                                                       !    Dimensions: (nlayers)
       real(kind=rb), intent(in) :: reicmc(:)          ! cloud ice particle effective radius (microns)
@@ -2010,17 +2029,23 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
       real(kind=rb) :: cwp                            ! total cloud water path
       real(kind=rb) :: radliq                         ! cloud liquid droplet radius (microns)
       real(kind=rb) :: radice                         ! cloud ice effective size (microns)
+      real(kind=rb) :: radsno                         ! cloud snow effective size (microns)
       real(kind=rb) :: factor
       real(kind=rb) :: fint
 
       real(kind=rb) :: taucldorig_a, taucloud_a, ssacloud_a, ffp, ffp1, ffpssa
       real(kind=rb) :: tauiceorig, scatice, ssaice, tauice, tauliqorig, scatliq, ssaliq, tauliq
+      real(kind=rb) :: tausnoorig, scatsno, ssasno, tausno
 
       real(kind=rb) :: fdelta(ngptsw)
       real(kind=rb) :: extcoice(ngptsw), gice(ngptsw)
       real(kind=rb) :: ssacoice(ngptsw), forwice(ngptsw)
       real(kind=rb) :: extcoliq(ngptsw), gliq(ngptsw)
       real(kind=rb) :: ssacoliq(ngptsw), forwliq(ngptsw)
+      real(kind=rb) :: extcosno(ngptsw), gsno(ngptsw)
+      real(kind=rb) :: ssacosno(ngptsw), forwsno(ngptsw)
+
+      CHARACTER*80 errmess
 
 ! Initialize
 
@@ -2041,7 +2066,7 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
 
 ! Main g-point interval loop
          do ig = 1, ngptsw 
-            cwp = ciwpmc(ig,lay) + clwpmc(ig,lay)
+            cwp = ciwpmc(ig,lay) + clwpmc(ig,lay) + cswpmc(ig,lay)
 
             if (cldfmc(ig,lay) .ge. cldmin .and. &
                (cwp .ge. cldmin .or. taucmc(ig,lay) .ge. cldmin)) then
@@ -2066,16 +2091,21 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
                   stop 'INFLAG = 1 OPTION NOT AVAILABLE WITH MCICA'
 
 ! (inflag=2): Separate treatement of ice clouds and water clouds.
-               elseif (inflag .eq. 2) then       
+               elseif (inflag .ge. 2) then
                   radice = reicmc(lay)
 
 ! Calculation of absorption coefficients due to ice clouds.
-                  if (ciwpmc(ig,lay) .eq. 0.0_rb) then
+                  if ((ciwpmc(ig,lay)+cswpmc(ig,lay)) .eq. 0.0_rb) then
                      extcoice(ig) = 0.0_rb
                      ssacoice(ig) = 0.0_rb
                      gice(ig)     = 0.0_rb
                      forwice(ig)  = 0.0_rb
 
+                     extcosno(ig) = 0.0_rb
+                     ssacosno(ig) = 0.0_rb
+                     gsno(ig)     = 0.0_rb
+                     forwsno(ig)  = 0.0_rb
+
 ! (iceflag = 1): 
 ! Note: This option uses Ebert and Curry approach for all particle sizes similar to
 ! CAM3 implementation, though this is somewhat unjustified for large ice particles
@@ -2130,8 +2160,13 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
 
 ! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns
 
-                  elseif (iceflag .eq. 3) then
-                     if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) stop 'ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'
+                  elseif (iceflag .ge. 3) then
+                     if (radice .lt. 5.0_rb .or. radice .gt. 140.0_rb) then
+                         write(errmess,'(A,i5,i5,f8.2,f8.2)' )         &
+               'ERROR: ICE GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'   &
+               ,ig, lay, ciwpmc(ig,lay), radice
+                         call wrf_error_fatal(errmess)
+                     end if
                      factor = (radice - 2._rb)/3._rb
                      index = int(factor)
                      if (index .eq. 46) index = 45
@@ -2145,8 +2180,14 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
                                (asyice3(index+1,ib) - asyice3(index,ib))
                      fdelta(ig) = fdlice3(index,ib) + fint * &
                                  (fdlice3(index+1,ib) - fdlice3(index,ib))
-                     if (fdelta(ig) .lt. 0.0_rb) stop 'FDELTA LESS THAN 0.0'
-                     if (fdelta(ig) .gt. 1.0_rb) stop 'FDELTA GT THAN 1.0'
+                     if (fdelta(ig) .lt. 0.0_rb) then
+                      write(errmess, *) 'FDELTA LESS THAN 0.0'
+                      call wrf_error_fatal(errmess)
+                     end if
+                     if (fdelta(ig) .gt. 1.0_rb) then
+                      write(errmess, *) 'FDELTA GT THAN 1.0'
+                      call wrf_error_fatal(errmess)
+                     end if
                      forwice(ig) = fdelta(ig) + 0.5_rb / ssacoice(ig)
 ! See Fu 1996 p. 2067 
                      if (forwice(ig) .gt. gice(ig)) forwice(ig) = gice(ig)
@@ -2159,6 +2200,75 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
 
                   endif
 
+!!!!!!!!!!!!!!!!!! Mukul !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!  INSERT THE EQUIVALENT SNOW VARIABLE CODE HERE
+!!!! Although far from perfect, the snow will utilize the
+!!!! same lookup table constants as cloud ice.  Changes
+!!!! to those constants for larger particle snow would be
+!!!! an improvement.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+                  if (cswpmc(ig,lay).gt.0.0_rb .and. iceflag .eq. 5) then
+                     radsno = resnmc(lay)
+                     if (radsno .lt. 5.0_rb .or. radsno .gt. 140.0_rb) then
+                         write(errmess,'(A,i5,i5,f8.2,f8.2)' )         &
+               'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS'   &
+               ,ig, lay, cswpmc(ig,lay), radsno
+                         call wrf_error_fatal(errmess)
+                     end if
+                     factor = (radsno - 2._rb)/3._rb
+                     index = int(factor)
+                     if (index .eq. 46) index = 45
+                     fint = factor - float(index)
+                     ib = ngb(ig)
+                     extcosno(ig) = extice3(index,ib) + fint * &
+                                   (extice3(index+1,ib) - extice3(index,ib))
+                     ssacosno(ig) = ssaice3(index,ib) + fint * &
+                                   (ssaice3(index+1,ib) - ssaice3(index,ib))
+                     gsno(ig) = asyice3(index,ib) + fint * &
+                               (asyice3(index+1,ib) - asyice3(index,ib))
+                     fdelta(ig) = fdlice3(index,ib) + fint * &
+                                 (fdlice3(index+1,ib) - fdlice3(index,ib))
+                     if (fdelta(ig) .lt. 0.0_rb) then
+                      write(errmess, *) 'FDELTA LESS THAN 0.0'
+                      call wrf_error_fatal(errmess)
+                     end if
+                     if (fdelta(ig) .gt. 1.0_rb) then
+                      write(errmess, *) 'FDELTA GT THAN 1.0'
+                      call wrf_error_fatal(errmess)
+                     end if
+                     forwsno(ig) = fdelta(ig) + 0.5_rb / ssacosno(ig)
+! See Fu 1996 p. 2067
+                     if (forwsno(ig) .gt. gsno(ig)) forwsno(ig) = gsno(ig)
+! Check to ensure all calculated quantities are within physical limits.  
+                     if (extcosno(ig) .lt. 0.0_rb) then
+                      write(errmess, *) 'SNOW EXTINCTION LESS THAN 0.0'
+                      call wrf_error_fatal(errmess)
+                     end if
+                     if (ssacosno(ig) .gt. 1.0_rb) then
+                      write(errmess, *) 'SNOW SSA GRTR THAN 1.0'
+                      call wrf_error_fatal(errmess)
+                     end if
+                     if (ssacosno(ig) .lt. 0.0_rb)  then
+                      write(errmess, *) 'SNOW SSA LESS THAN 0.0'
+                      call wrf_error_fatal(errmess)
+                     end if
+                     if (gsno(ig) .gt. 1.0_rb)  then
+                      write(errmess, *) 'SNOW ASYM GRTR THAN 1.0'
+                      call wrf_error_fatal(errmess)
+                     end if
+                     if (gsno(ig) .lt. 0.0_rb)  then
+                      write(errmess, *) 'SNOW ASYM LESS THAN 0.0'
+                      call wrf_error_fatal(errmess)
+                     end if
+                  else
+                     extcosno(ig) = 0.0_rb
+                     ssacosno(ig) = 0.0_rb
+                     gsno(ig)     = 0.0_rb
+                     forwsno(ig)  = 0.0_rb
+                  endif
+
+
 ! Calculation of absorption coefficients due to water clouds.
                   if (clwpmc(ig,lay) .eq. 0.0_rb) then
                      extcoliq(ig) = 0.0_rb
@@ -2192,28 +2302,55 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
                      if (gliq(ig) .lt. 0.0_rb) stop 'LIQUID ASYM LESS THAN 0.0'
                   endif
    
-                  tauliqorig = clwpmc(ig,lay) * extcoliq(ig)
-                  tauiceorig = ciwpmc(ig,lay) * extcoice(ig)
-                  taormc(ig,lay) = tauliqorig + tauiceorig
-
-                  ssaliq = ssacoliq(ig) * (1._rb - forwliq(ig)) / &
-                          (1._rb - forwliq(ig) * ssacoliq(ig))
-                  tauliq = (1._rb - forwliq(ig) * ssacoliq(ig)) * tauliqorig
-                  ssaice = ssacoice(ig) * (1._rb - forwice(ig)) / &
-                          (1._rb - forwice(ig) * ssacoice(ig))
-                  tauice = (1._rb - forwice(ig) * ssacoice(ig)) * tauiceorig
 
-                  scatliq = ssaliq * tauliq
-                  scatice = ssaice * tauice
-                  taucmc(ig,lay) = tauliq + tauice
+                  if (iceflag .lt. 5) then
+                      tauliqorig = clwpmc(ig,lay) * extcoliq(ig)
+                      tauiceorig = ciwpmc(ig,lay) * extcoice(ig)
+                      taormc(ig,lay) = tauliqorig + tauiceorig
+  
+                      ssaliq = ssacoliq(ig) * (1._rb - forwliq(ig)) / &
+                               (1._rb - forwliq(ig) * ssacoliq(ig))
+                      tauliq = (1._rb - forwliq(ig) * ssacoliq(ig)) * tauliqorig
+                      ssaice = ssacoice(ig) * (1._rb - forwice(ig)) / &
+                               (1._rb - forwice(ig) * ssacoice(ig))
+                      tauice = (1._rb - forwice(ig) * ssacoice(ig)) * tauiceorig
+                      scatliq = ssaliq * tauliq
+                      scatice = ssaice * tauice
+                      scatsno = 0.0_rb 
+                      taucmc(ig,lay) = tauliq + tauice
+                  else
+                      tauliqorig = clwpmc(ig,lay) * extcoliq(ig)
+                      tauiceorig = ciwpmc(ig,lay) * extcoice(ig)
+                      tausnoorig = cswpmc(ig,lay) * extcosno(ig)
+                      taormc(ig,lay) = tauliqorig + tauiceorig + tausnoorig
+
+                      ssaliq = ssacoliq(ig) * (1._rb - forwliq(ig)) / &
+                               (1._rb - forwliq(ig) * ssacoliq(ig))
+                      tauliq = (1._rb - forwliq(ig) * ssacoliq(ig)) * tauliqorig
+                      ssaice = ssacoice(ig) * (1._rb - forwice(ig)) / &
+                               (1._rb - forwice(ig) * ssacoice(ig))
+                      tauice = (1._rb - forwice(ig) * ssacoice(ig)) * tauiceorig
+                      ssasno = ssacosno(ig) * (1._rb - forwsno(ig)) / &
+                               (1._rb - forwsno(ig) * ssacosno(ig))
+                      tausno = (1._rb - forwsno(ig) * ssacosno(ig)) * tausnoorig
+                      scatliq = ssaliq * tauliq
+                      scatice = ssaice * tauice
+                      scatsno = ssasno * tausno
+                      taucmc(ig,lay) = tauliq + tauice + tausno
+                  endif
 
 ! Ensure non-zero taucmc and scatice
                   if(taucmc(ig,lay).eq.0.) taucmc(ig,lay) = cldmin
                   if(scatice.eq.0.) scatice = cldmin
+                  if(scatsno.eq.0.) scatsno = cldmin
 
-                  ssacmc(ig,lay) = (scatliq + scatice) / taucmc(ig,lay)
+                  if (iceflag .lt. 5) then
+                      ssacmc(ig,lay) = (scatliq + scatice) / taucmc(ig,lay)
+                  else
+                      ssacmc(ig,lay) = (scatliq + scatice + scatsno) / taucmc(ig,lay)
+                  endif
 
-                  if (iceflag .eq. 3) then
+                  if (iceflag .eq. 3 .or. iceflag.eq.4) then
 ! In accordance with the 1996 Fu paper, equation A.3, 
 ! the moments for ice were calculated depending on whether using spheres
 ! or hexagonal ice crystals.
@@ -2223,6 +2360,12 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
                         (scatliq*(gliq(ig)**istr - forwliq(ig)) / &
                         (1.0_rb - forwliq(ig)) + scatice * ((gice(ig)-forwice(ig))/ &
                         (1.0_rb - forwice(ig)))**istr)
+                  elseif (iceflag .eq. 5) then
+                     istr = 1
+                     asmcmc(ig,lay) = (1.0_rb/(scatliq+scatice+scatsno))                               &
+                                    *  (scatliq*(gliq(ig)**istr - forwliq(ig))/(1.0_rb - forwliq(ig))  &
+                                    + scatice * ((gice(ig)-forwice(ig))/(1.0_rb - forwice(ig)))        &
+                                    + scatsno * ((gsno(ig)-forwsno(ig))/(1.0_rb - forwsno(ig)))**istr)
 
                   else 
 ! This code is the standard method for delta-m scaling. 
@@ -8253,7 +8396,6 @@ subroutine spcvmc_sw &
                zomcc(jk) = ztaur(ikl,iw) * 1.0_rb + ptaua(ikl,ibm) * pomga(ikl,ibm)
                zgcc(jk) = pasya(ikl,ibm) * pomga(ikl,ibm) * ptaua(ikl,ibm) / zomcc(jk)
                zomcc(jk) = zomcc(jk) / ztauc(jk)
-!endif
 
 ! Pre-delta-scaling clear and cloudy direct beam transmittance (must use 'orig', unscaled cloud OD)       
 !   \/\/\/ This block of code is only needed for direct beam calculation
@@ -8545,14 +8687,15 @@ subroutine rrtmg_sw &
              coszen  ,adjes   ,dyofyr  ,scon    , &
              inflgsw ,iceflgsw,liqflgsw,cldfmcl , &
              taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
-             ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
+             ciwpmcl ,clwpmcl ,cswpmcl ,reicmcl ,relqmcl ,resnmcl, &
              tauaer  ,ssaaer  ,asmaer  ,ecaer   , &
              swuflx  ,swdflx  ,swhr    ,swuflxc ,swdflxc ,swhrc, aer_opt,  &
 ! --------- Add the following four compenants for ssib shortwave down radiation ---!
 ! -------------------      by Zhenxin 2011-06-20      --------------------------------!
-             sibvisdir, sibvisdif, sibnirdir, sibnirdif          &
-                                                                )
+             sibvisdir, sibvisdif, sibnirdir, sibnirdif,         &
 ! ----------------------  End,  Zhenxin 2011-06-20    --------------------------------!
+             swdkdir,swdkdif                                & ! jararias, 2013/08/10
+                                                                )
 
 
 ! ------- Description -------
@@ -8719,6 +8862,8 @@ subroutine rrtmg_sw &
                                                       !    Dimensions: (ngptsw,ncol,nlay)
       real(kind=rb), intent(in) :: clwpmcl(:,:,:)     ! In-cloud liquid water path (g/m2)
                                                       !    Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: cswpmcl(:,:,:)     ! In-cloud snow water path (g/m2)
+                                                      !    Dimensions: (ngptsw,ncol,nlay)
       real(kind=rb), intent(in) :: reicmcl(:,:)       ! Cloud ice effective radius (microns)
                                                       !    Dimensions: (ncol,nlay)
                                                       ! specific definition of reicmcl depends on setting of iceflglw:
@@ -8733,6 +8878,8 @@ subroutine rrtmg_sw &
                                                       !               [dge = 1.0315 * r_ec]
       real(kind=rb), intent(in) :: relqmcl(:,:)       ! Cloud water drop effective radius (microns)
                                                       !    Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: resnmcl(:,:)       ! Cloud snow effective radius (microns)
+                                                      !    Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: tauaer(:,:,:)      ! Aerosol optical depth (iaer=10 only)
                                                       !    Dimensions: (ncol,nlay,nbndsw)
                                                       ! (non-delta scaled)      
@@ -8768,7 +8915,15 @@ subroutine rrtmg_sw &
                                                       !    Dimensions: (ncol,nlay+1)
       real(kind=rb), intent(out) :: swhrc(:,:)        ! Clear sky shortwave radiative heating rate (K/d)
                                                       !    Dimensions: (ncol,nlay)
+
       integer, intent(in)        :: aer_opt
+      real(kind=rb), intent(out) :: &
+        swdkdir(:,:), & ! Total shortwave downward direct flux (W/m2),  Dimensions: (ncol,nlay) jararias, 2013/08/10
+        swdkdif(:,:)    ! Total shortwave downward diffuse flux (W/m2), Dimensions: (ncol,nlay) jararias, 2013/08/10
+
+
+
+
 
 ! ----- Local -----
 
@@ -8867,8 +9022,10 @@ subroutine rrtmg_sw &
       real(kind=rb) :: cldfmc(ngptsw,nlay+1)    ! cloud fraction [mcica]
       real(kind=rb) :: ciwpmc(ngptsw,nlay+1)    ! in-cloud ice water path [mcica]
       real(kind=rb) :: clwpmc(ngptsw,nlay+1)    ! in-cloud liquid water path [mcica]
+      real(kind=rb) :: cswpmc(ngptsw,nlay+1)    ! in-cloud snow water path [mcica]
       real(kind=rb) :: relqmc(nlay+1)           ! liquid particle effective radius (microns)
       real(kind=rb) :: reicmc(nlay+1)           ! ice particle effective size (microns)
+      real(kind=rb) :: resnmc(nlay+1)           ! snow particle effective size (microns)
       real(kind=rb) :: taucmc(ngptsw,nlay+1)    ! in-cloud optical depth [mcica]
       real(kind=rb) :: taormc(ngptsw,nlay+1)    ! unscaled in-cloud optical depth [mcica]
       real(kind=rb) :: ssacmc(ngptsw,nlay+1)    ! in-cloud single scattering albedo [mcica]
@@ -8969,7 +9126,7 @@ subroutine rrtmg_sw &
 !           input aerosol optical depth at 0.55 microns for each aerosol type (ecaer)
 ! iaer = 10, input total aerosol optical depth, single scattering albedo 
 !            and asymmetry parameter (tauaer, ssaaer, asmaer) directly
-      if ( aer_opt .eq. 0 ) then
+      if ( aer_opt .eq. 0 .or. aer_opt .eq. 2 ) then
       iaer = 10
       else if ( aer_opt .eq. 1 ) then
       iaer = 6
@@ -8995,11 +9152,11 @@ subroutine rrtmg_sw &
               play, plev, tlay, tlev, tsfc, h2ovmr, &
               o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, &
               adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, &
-              cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, &
-              reicmcl, relqmcl, tauaer, ssaaer, asmaer, &
+              cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, cswpmcl, &
+              reicmcl, relqmcl, resnmcl, tauaer, ssaaer, asmaer, &
               nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, &
               adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, &
-              ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, reicmc, relqmc, &
+              ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
               taua, ssaa, asma)
 
 !  For cloudy atmosphere, use cldprop to set cloud optical properties based on
@@ -9009,7 +9166,7 @@ subroutine rrtmg_sw &
 !  optical properties are transferred to rrtmg_sw arrays in cldprop.  
 
          call cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, &
-                         ciwpmc, clwpmc, reicmc, relqmc, &
+                         ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
                          taormc, taucmc, ssacmc, asmcmc, fsfcmc)
          icpr = 1
 
@@ -9169,6 +9326,9 @@ subroutine rrtmg_sw &
 !  Direct/diffuse fluxes
             dirdflux(i) = zbbfddir(i)
             difdflux(i) = swdflx(iplon,i) - dirdflux(i)
+            swdkdir(iplon,i) = dirdflux(i) ! all-sky direct flux   jararias, 2013/08/10
+            swdkdif(iplon,i) = difdflux(i) ! all-sky diffuse flux  jararias, 2013/08/10
+
 !  UV/visible direct/diffuse fluxes
             dirdnuv(i) = zuvfddir(i)
             difdnuv(i) = zuvfd(i) - dirdnuv(i)
@@ -9237,12 +9397,12 @@ subroutine inatm_sw (iplon, nlay, icld, iaer, &
             play, plev, tlay, tlev, tsfc, h2ovmr, &
             o3vmr, co2vmr, ch4vmr, n2ovmr, o2vmr, &
             adjes, dyofyr, scon, inflgsw, iceflgsw, liqflgsw, &
-            cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, &
-            reicmcl, relqmcl, tauaer, ssaaer, asmaer, &
+            cldfmcl, taucmcl, ssacmcl, asmcmcl, fsfcmcl, ciwpmcl, clwpmcl, cswpmcl, &
+            reicmcl, relqmcl, resnmcl, tauaer, ssaaer, asmaer, &
             nlayers, pavel, pz, pdp, tavel, tz, tbound, coldry, wkl, &
             adjflux, solvar, inflag, iceflag, liqflag, cldfmc, taucmc, &
-            ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, reicmc, relqmc, &
-            taua, ssaa, asma)
+            ssacmc, asmcmc, fsfcmc, ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, &
+            taua, ssaa, asma)                                       
 !***************************************************************************
 !
 !  Input atmospheric profile from GCM, and prepare it for use in RRTMG_SW.
@@ -9311,10 +9471,14 @@ subroutine inatm_sw (iplon, nlay, icld, iaer, &
                                                       ! Dimensions: (ngptsw,ncol,nlay)
       real(kind=rb), intent(in) :: clwpmcl(:,:,:)     ! In-cloud liquid water path (g/m2)
                                                       ! Dimensions: (ngptsw,ncol,nlay)
+      real(kind=rb), intent(in) :: cswpmcl(:,:,:)     ! In-cloud snow water path (g/m2)
+                                                      ! Dimensions: (ngptsw,ncol,nlay)
       real(kind=rb), intent(in) :: reicmcl(:,:)       ! Cloud ice effective size (microns)
                                                       ! Dimensions: (ncol,nlay)
       real(kind=rb), intent(in) :: relqmcl(:,:)       ! Cloud water drop effective radius (microns)
                                                       ! Dimensions: (ncol,nlay)
+      real(kind=rb), intent(in) :: resnmcl(:,:)       ! Cloud snow effective radius (microns)
+                                                      ! Dimensions: (ncol,nlay)
 
       real(kind=rb), intent(in) :: tauaer(:,:,:)      ! Aerosol optical depth
                                                       ! Dimensions: (ncol,nlay,nbndsw)
@@ -9373,10 +9537,14 @@ subroutine inatm_sw (iplon, nlay, icld, iaer, &
                                                       ! Dimensions: (ngptsw,nlay)
       real(kind=rb), intent(out) :: clwpmc(:,:)       ! in-cloud liquid water path
                                                       ! Dimensions: (ngptsw,nlay)
+      real(kind=rb), intent(out) :: cswpmc(:,:)       ! in-cloud snow path
+                                                      ! Dimensions: (ngptsw,nlay)
       real(kind=rb), intent(out) :: relqmc(:)         ! liquid particle effective radius (microns)
                                                       ! Dimensions: (nlay)
       real(kind=rb), intent(out) :: reicmc(:)         ! ice particle effective size (microns)
                                                       ! Dimensions: (nlay)
+      real(kind=rb), intent(out) :: resnmc(:)         ! snow particle effective size (microns)
+                                                      ! Dimensions: (nlay)
 
 ! ----- Local -----
       real(kind=rb), parameter :: amd = 28.9660_rb    ! Effective molecular weight of dry air (g/mol)
@@ -9416,8 +9584,10 @@ subroutine inatm_sw (iplon, nlay, icld, iaer, &
        fsfcmc(:,:) = 0.0_rb
        ciwpmc(:,:) = 0.0_rb
        clwpmc(:,:) = 0.0_rb
+       cswpmc(:,:) = 0.0_rb
        reicmc(:) = 0.0_rb
        relqmc(:) = 0.0_rb
+       resnmc(:) = 0.0_rb
        taua(:,:) = 0.0_rb
        ssaa(:,:) = 1.0_rb
        asma(:,:) = 0.0_rb
@@ -9551,9 +9721,15 @@ subroutine inatm_sw (iplon, nlay, icld, iaer, &
                fsfcmc(ig,l) = fsfcmcl(ig,iplon,l)
                ciwpmc(ig,l) = ciwpmcl(ig,iplon,l)
                clwpmc(ig,l) = clwpmcl(ig,iplon,l)
+               if (iceflag.eq.5) then
+                  cswpmc(ig,l)=cswpmcl(ig,iplon,l)
+               endif 
             enddo
             reicmc(l) = reicmcl(iplon,l)
             relqmc(l) = relqmcl(iplon,l)
+            if (iceflag.eq.5) then
+               resnmc(l) = resnmcl(iplon,l)
+            endif 
          enddo
 
 ! If an extra layer is being used in RRTMG, set all cloud properties to zero in the extra layer.
@@ -9597,13 +9773,17 @@ SUBROUTINE RRTMG_SWRAD(                                        &
                        rthratensw,                                &
                        swupt, swuptc, swdnt, swdntc,              &
                        swupb, swupbc, swdnb, swdnbc,              &
+!                      swupflx, swupflxc, swdnflx, swdnflxc,      &
                        swcf, gsw,                                 &
                        xtime, gmt, xlat, xlong,                   &
                        radt, degrad, declin,                      &
                        coszr, julday, solcon,                     &
                        albedo, t3d, t8w, tsk,                     &
                        p3d, p8w, pi3d, rho3d,                     &
-                       dz8w, cldfra3d, r, g,                      &
+                       dz8w, cldfra3d, lradius, iradius,          & 
+                       is_cammgmp_used, r, g,                     &
+                       re_cloud,re_ice,re_snow,                   &
+                       has_reqc,has_reqi,has_reqs,                &
                        icloud, warm_rain,                         &
                        f_ice_phy, f_rain_phy,                     &
                        xland, xice, snow,                         &
@@ -9627,12 +9807,16 @@ SUBROUTINE RRTMG_SWRAD(                                        &
                        ids,ide, jds,jde, kds,kde,                 & 
                        ims,ime, jms,jme, kms,kme,                 &
                        its,ite, jts,jte, kts,kte,                 &
-                       swupflx, swupflxc, swdnflx, swdnflxc       &
+                       swupflx, swupflxc, swdnflx, swdnflxc,      &
+                       tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw,       & ! jararias 2013/11
+                       swddir, swddni, swddif,                    & ! jararias 2013/08
+                       xcoszen,julian                             & ! jararias 2013/08
                                                                   )
 !------------------------------------------------------------------
    IMPLICIT NONE
 !------------------------------------------------------------------
    LOGICAL, INTENT(IN )      ::        warm_rain
+   LOGICAL, INTENT(IN )      ::   is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP
 !
    INTEGER, INTENT(IN )      ::        ids,ide, jds,jde, kds,kde, &
                                        ims,ime, jms,jme, kms,kme, &
@@ -9688,6 +9872,22 @@ SUBROUTINE RRTMG_SWRAD(                                        &
 
 !  ----------------------- end Zhenxin --------------------------
 !
+
+! ------------------------ jararias 2013/08/10 -----------------
+   real, dimension(ims:ime,jms:jme), intent(out) :: &
+            swddir,  &  ! All-sky broadband surface direct horiz irradiance
+            swddni,  &  ! All-sky broadband surface direct normal irradiance
+            swddif      ! All-sky broadband surface diffuse irradiance
+   real, optional, intent(in) :: &
+            julian      ! julian day (1-366)
+   real, dimension(ims:ime,jms:jme), optional, intent(in) :: &
+            xcoszen     ! cosine of the solar zenith angle
+  real, dimension(ims:ime,kms:kme,jms:jme,nbndsw), optional,      &
+        intent(in)                                :: tauaer3d_sw, &
+                                                     ssaaer3d_sw, &
+                                                     asyaer3d_sw
+! ------------------------ jararias end snippet -----------------
+
    REAL, INTENT(IN  )   ::                                   R,G
 !
 ! Optional
@@ -9696,6 +9896,8 @@ SUBROUTINE RRTMG_SWRAD(                                        &
          OPTIONAL                                               , &
          INTENT(IN   ) ::                                         &
                                                         CLDFRA3D, &
+                                                         LRADIUS, &
+                                                         IRADIUS, &
                                                             QV3D, &
                                                             QC3D, &
                                                             QR3D, &
@@ -9704,6 +9906,13 @@ SUBROUTINE RRTMG_SWRAD(                                        &
                                                             QG3D, &
                                                         QNDROP3D
 
+!..Added by G. Thompson to couple cloud physics effective radii.
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN)::       &
+                                                        RE_CLOUD, &
+                                                          RE_ICE, &
+                                                         RE_SNOW
+   INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
+
    real pi,third,relconst,lwpmin,rhoh2o
 
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme )                 , &
@@ -9730,11 +9939,11 @@ SUBROUTINE RRTMG_SWRAD(                                        &
          INTENT(IN   ) :: O33D
    INTEGER, OPTIONAL, INTENT(IN ) :: o3input
 !  EC aerosol: no_src = naerec = 6
+   INTEGER,           INTENT(IN ) :: no_src
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:no_src )       , &
          OPTIONAL                                               , &
          INTENT(IN   ) :: aerod
    INTEGER, OPTIONAL, INTENT(IN ) :: aer_opt
-   INTEGER,           INTENT(IN ) :: no_src
 
       !wavelength corresponding to wavenum1 and wavenum2 (cm-1)
       real, save :: wavemin(nbndsw) ! Min wavelength (um) of 14 intervals
@@ -9808,11 +10017,14 @@ SUBROUTINE RRTMG_SWRAD(                                        &
 ! though no clouds are allowed in extra layer
     real, dimension( 1, kts:kte+1 )  ::                   clwpth, &
                                                           ciwpth, &
+                                                          cswpth, &
                                                              rel, &
                                                              rei, &
+                                                             res, &
                                                          cldfrac, &
                                                          relqmcl, &
-                                                         reicmcl
+                                                         reicmcl, &
+                                                         resnmcl
     real, dimension( nbndsw, 1, kts:kte+1 )  ::           taucld, &
                                                           ssacld, &
                                                           asmcld, &
@@ -9820,6 +10032,7 @@ SUBROUTINE RRTMG_SWRAD(                                        &
     real, dimension( ngptsw, 1, kts:kte+1 )  ::          cldfmcl, &
                                                          clwpmcl, &
                                                          ciwpmcl, &
+                                                         cswpmcl, &
                                                          taucmcl, &
                                                          ssacmcl, &
                                                          asmcmcl, &
@@ -9838,6 +10051,10 @@ SUBROUTINE RRTMG_SWRAD(                                        &
                                                        sibvisdif, &
                                                        sibnirdir, &
                                                        sibnirdif     ! Zhenxin 2011-06-20
+
+    real, dimension( 1, kts:kte+2 ) ::                   swdkdir, &  ! jararias, 2013/08/10
+                                                         swdkdif     ! jararias, 2013/08/10
+
     real, dimension( 1, kts:kte+1 )  ::                     swhr, &
                                                            swhrc
 
@@ -9847,7 +10064,8 @@ SUBROUTINE RRTMG_SWRAD(                                        &
     real ::                                                   ro, &
                                                               dz, &
                                                            adjes, &
-                                                            scon
+                                                            scon, &  
+                                                  snow_mass_factor
     integer ::                                            dyofyr
 
 ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007)
@@ -9898,9 +10116,13 @@ SUBROUTINE RRTMG_SWRAD(                                        &
 
     real, dimension(1, 1:kte-kts+1) ::   cicewp, &     ! in-cloud cloud ice water path
                                          cliqwp, &     ! in-cloud cloud liquid water path
+                                         csnowp, &     ! in-cloud snow water path
                                           reliq, &     ! effective drop radius (microns)
                                           reice        ! ice effective drop size (microns)
-    real :: gliqwp, gicewp, gravmks
+    real, dimension(1, 1:kte-kts+1):: recloud1d, &
+                                        reice1d, &
+                                       resnow1d
+    real :: gliqwp, gicewp, gsnowp, gravmks
 
 !
 !    REAL   ::  TSFC,GLW0,OLR0,EMISS0,FP
@@ -9919,6 +10141,8 @@ SUBROUTINE RRTMG_SWRAD(                                        &
     INTEGER :: i,j,K, na
     LOGICAL :: predicate
 
+    REAL :: da, eot ! jararias, 14/08/2013
+
 !------------------------------------------------------------------
 #ifdef WRF_CHEM
       IF ( aer_ra_feedback == 1) then
@@ -9946,6 +10170,11 @@ SUBROUTINE RRTMG_SWRAD(                                        &
 ! All fields are ordered vertically from bottom to top
 ! Pressures are in mb
 
+     ! jararias, 14/08/2013
+     if (present(xcoszen)) then
+         call wrf_debug(100,'coszen from radiation driver')
+     end if
+
 ! latitude loop
   j_loop: do j = jts,jte
 
@@ -9961,13 +10190,22 @@ SUBROUTINE RRTMG_SWRAD(                                        &
 ! units of minutes
 ! julian is in days
 ! radt is in minutes
-         xt24 = mod(xtime+radt*0.5,1440.)
-         tloctm = gmt + xt24/60. + xlong(i,j)/15.
-         hrang = 15. * (tloctm-12.) * degrad
-         xxlat = xlat(i,j) * degrad
-!         clat(i) = xxlat
-         coszrs = sin(xxlat) * sin(declin) + cos(xxlat) * cos(declin) * cos(hrang)
-         coszr(i,j) = coszrs
+          ! jararias, 14/08/2013
+          if (present(xcoszen)) then
+             coszr(i,j)=xcoszen(i,j)
+             coszrs=xcoszen(i,j)
+          else
+!            da=6.2831853071795862*(julian-1)/365.
+!            eot=(0.000075+0.001868*cos(da)-0.032077*sin(da) &
+!               -0.014615*cos(2*da)-0.04089*sin(2*da))*(229.18)
+             xt24 = mod(xtime+radt*0.5,1440.)+eot
+             tloctm = gmt + xt24/60. + xlong(i,j)/15.
+             hrang = 15. * (tloctm-12.) * degrad
+             xxlat = xlat(i,j) * degrad
+             coszrs = sin(xxlat) * sin(declin) &
+                    + cos(xxlat) * cos(declin) * cos(hrang)
+             coszr(i,j) = coszrs
+          end if
 
 ! Set flag to prevent shortwave calculation when sun below horizon
          if (coszrs.le.0.0) dorrsw = .false.
@@ -9992,11 +10230,18 @@ SUBROUTINE RRTMG_SWRAD(                                        &
          DO K=kts,kte
             QV1D(K)=QV3D(I,K,J)
             QV1D(K)=max(0.,QV1D(K))
-            IF ( PRESENT( O33D ) ) THEN
-            O31D(K)=O33D(I,K,J)
-            ENDIF
          ENDDO
 
+         IF (PRESENT(O33D)) THEN
+            DO K=kts,kte
+               O31D(K)=O33D(I,K,J)
+            ENDDO
+         ELSE
+            DO K=kts,kte
+               O31D(K)=0.0
+            ENDDO
+         ENDIF
+
          DO K=kts,kte
             TTEN1D(K)=0.
             T1D(K)=t3d(I,K,J)
@@ -10092,7 +10337,8 @@ SUBROUTINE RRTMG_SWRAD(                                        &
             IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN
                IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN
                   DO K=kts,kte
-                     qi1d(k) = qs3d(i,k,j)
+                     qi1d(k) = 0.1*qs3d(i,k,j)
+                     qs1d(k) = 0.9*qs3d(i,k,j)
                      qc1d(k) = qc3d(i,k,j)
                      qi1d(k) = max(0.,qi1d(k))
                      qc1d(k) = max(0.,qc1d(k))
@@ -10127,6 +10373,44 @@ SUBROUTINE RRTMG_SWRAD(                                        &
          iceflgsw = 3
          liqflgsw = 1
 
+!Mukul change the flags here with reference to the new effective cloud/ice/snow radius
+         IF (ICLOUD .ne. 0) THEN
+            IF ( has_reqc .ne. 0) THEN
+               inflgsw = 3
+               DO K=kts,kte
+                  recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
+               ENDDO
+            ELSE
+               DO K=kts,kte
+                  recloud1D(ncol,K) = 5.0
+               ENDDO
+            ENDIF
+
+            IF ( has_reqi .ne. 0) THEN
+               inflgsw  = 4
+               iceflgsw = 4
+               DO K=kts,kte
+                  reice1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
+               ENDDO
+            ELSE
+               DO K=kts,kte
+                  reice1D(ncol,K) = 10.0
+               ENDDO
+            ENDIF
+
+            IF ( has_reqs .ne. 0) THEN
+               inflgsw  = 5
+               iceflgsw = 5
+               DO K=kts,kte
+                  resnow1D(ncol,K) = MAX(10., re_snow(I,K,J)*1.E6)
+               ENDDO
+            ELSE
+               DO K=kts,kte
+                  resnow1D(ncol,K) = 10.0
+               ENDDO
+            ENDIF
+         ENDIF
+
 ! Set cosine of solar zenith angle
          coszen(ncol) = coszrs
 ! Set solar constant
@@ -10178,6 +10462,7 @@ SUBROUTINE RRTMG_SWRAD(                                        &
 ! Get ozone profile including amount in extra layer above model top
          call inirad (o3mmr,plev,kts,kte)
 
+        if(present(o33d)) then
          do k = kts, kte+1
             o3vmr(ncol,k) = o3mmr(k) * amdo
             IF ( PRESENT( O33D ) ) THEN
@@ -10192,6 +10477,11 @@ SUBROUTINE RRTMG_SWRAD(                                        &
             endif
             ENDIF
          enddo
+        else
+         do k = kts, kte+1
+            o3vmr(ncol,k) = o3mmr(k) * amdo
+         enddo
+        endif
 
 ! Set surface albedo for direct and diffuse radiation in UV/visible and
 ! near-IR spectral regions
@@ -10276,6 +10566,38 @@ SUBROUTINE RRTMG_SWRAD(                                        &
                cliqwp(ncol,k) = gliqwp / max(0.01,cldfrac(ncol,k))               ! In-cloud liquid water path.
             end do
 
+! Mukul
+!..The ice water path is already sum of cloud ice and snow, but when we have explicit
+!.. ice effective radius, overwrite the ice path with only the cloud ice variable,
+!.. leaving out the snow for its own effect.
+           if(iceflgsw.ge.4)then 
+              do k = kts, kte
+                     gicewp = qi1d(k) * pdel(ncol,k)*100.0 / gravmks * 1000.0     ! Grid box ice water path.
+                     cicewp(ncol,k) = gicewp / max(0.01,cldfrac(ncol,k))               ! In-cloud ice water path.
+              end do
+           end if
+
+!..Here the snow path is adjusted if (radiation) effective radius of snow is
+!.. larger than what we currently have in the lookup tables.  Since mass goes
+!.. rather close to diameter squared, adjust the mixing ratio of snow used
+!.. to compute its water path in combination with the max diameter.  Not a
+!.. perfect fix, but certainly better than using all snow mass when diameter is
+!.. far larger than table currently contains and crystal sizes much larger than
+!.. about 140 microns have lesser impact than those much smaller sizes.
+
+           if(iceflgsw.eq.5)then
+              do k = kts, kte
+                 snow_mass_factor = 1.0                 
+                 if (resnow1d(ncol,k) .gt. 130.)then 
+                     snow_mass_factor = (130.0/resnow1d(ncol,k))*(130.0/resnow1d(ncol,k))
+                     resnow1d(ncol,k)   = 130.0
+                 endif
+                 gsnowp = qs1d(k) * snow_mass_factor * pdel(ncol,k)*100.0 / gravmks * 1000.0     ! Grid box snow water path.
+                 csnowp(ncol,k) = gsnowp / max(0.01,cldfrac(ncol,k))
+              end do
+           end if
+
+
 !link the aerosol feedback to cloud  -czhao
   if( PRESENT( progn ) ) then
     if (progn == 1) then
@@ -10306,19 +10628,36 @@ SUBROUTINE RRTMG_SWRAD(                                        &
       end do
 !jdfcz     else ! prescribe 
 ! following Kiehl
-      call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
+!     call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
 !      write(0,*) 'sw prescribe aerosol',maxval(qndrop3d)
 !jdfcz     endif
-    else  ! progn   
+    else  ! progn   (progn=1)
       call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
     endif
-  else   !progn 
+  else   !progn   (PRESENT)
       call relcalc(ncol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh)
   endif
 
 ! following Kristjansson and Mitchell
       call reicalc(ncol, pcols, pver, tlay, reice)
 
+
+
+!..If we already have effective radius of cloud and ice, then just overwrite what
+!.. was computed in the relcalc and reicalc subroutines above.
+
+      if (inflgsw .ge. 3) then
+         do k = kts, kte
+            reliq(ncol,k) = recloud1d(ncol,k)
+         end do
+      endif
+      if (iceflgsw .ge. 4) then
+         do k = kts, kte
+            reice(ncol,k) = reice1d(ncol,k)
+         end do
+      endif
+
+
 #if 0
       if (i==80.and.j==30) then
 #if defined( DM_PARALLEL ) && ! defined( STUBMPI) 
@@ -10329,6 +10668,7 @@ SUBROUTINE RRTMG_SWRAD(                                        &
       endif
 #endif
 
+
 ! Limit upper bound of reice for Fu ice parameterization and convert
 ! from effective radius to generalized effective size (*1.0315; Fu, 1996)
             if (iceflgsw .eq. 3) then
@@ -10337,6 +10677,25 @@ SUBROUTINE RRTMG_SWRAD(                                        &
                   reice(ncol,k) = min(140.0,reice(ncol,k))
                end do
             endif
+            
+!if CAMMGMP is used, use output from CAMMGMP            
+!PMA
+            if(is_CAMMGMP_used) then
+               do k = kts, kte
+                  if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then
+                     reice(ncol,k) = iradius(i,k,j)
+                  else
+                     reice(ncol,k) = 25.
+                  end if
+                  reice(ncol,k) = max(5., min(140.0,reice(ncol,k)))
+                  if ( qc1d(k) .gt. 1.e-20) then
+                     reliq(ncol,k) = lradius(i,k,j)
+                  else
+                     reliq(ncol,k) = 10.
+                  end if
+                  reliq(ncol,k) = max(2.5, min(60.0,reliq(ncol,k)))
+               enddo
+            endif
 
 ! Set cloud physical property arrays
             do k = kts, kte
@@ -10346,6 +10705,19 @@ SUBROUTINE RRTMG_SWRAD(                                        &
                rei(ncol,k) = reice(ncol,k)
             enddo
 
+!Mukul
+            if (inflgsw .eq. 5) then
+               do k = kts, kte
+                  cswpth(ncol,k) = csnowp(ncol,k)
+                  res(ncol,k) = resnow1d(ncol,k)
+               end do
+            else
+               do k = kts, kte
+                  cswpth(ncol,k) = 0.0
+                  res(ncol,k) = 10.0
+               end do
+            endif
+
 ! Zero out cloud optical properties here, calculated in radiation 
             do k = kts, kte
                do nb = 1, nbndsw
@@ -10360,8 +10732,10 @@ SUBROUTINE RRTMG_SWRAD(                                        &
 ! No clouds are allowed in the extra layer from model top to TOA
          clwpth(ncol,kte+1) = 0.
          ciwpth(ncol,kte+1) = 0.
+         cswpth(ncol,kte+1) = 0.
          rel(ncol,kte+1) = 10.
          rei(ncol,kte+1) = 10.
+         res(ncol,kte+1) = 10.
          cldfrac(ncol,kte+1) = 0.
          do nb = 1, nbndsw
             taucld(nb,ncol,kte+1) = 0.
@@ -10377,10 +10751,11 @@ SUBROUTINE RRTMG_SWRAD(                                        &
 ! Sub-column generator for McICA
 
          call mcica_subcol_sw(iplon, ncol, nlay, icld, permuteseed, irng, play, &
-                       cldfrac, ciwpth, clwpth, rei, rel, taucld, ssacld, asmcld, fsfcld, &
-                       cldfmcl, ciwpmcl, clwpmcl, reicmcl, relqmcl, &
+                       cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, ssacld, asmcld, fsfcld, &
+                       cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, &
                        taucmcl, ssacmcl, asmcmcl, fsfcmcl)
 
+
 !--------------------------------------------------------------------------
 ! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010
 !--------------------------------------------------------------------------
@@ -10404,6 +10779,19 @@ SUBROUTINE RRTMG_SWRAD(                                        &
       end do
       end do
 
+      if ( present (tauaer3d_sw) ) then
+! ---- jararias 11/2012
+         if ( aer_opt .eq. 2) then
+            do nb=1,nbndsw
+               do k=kts,kte
+                  tauaer(ncol,k,nb)=tauaer3d_sw(i,k,j,nb)
+                  ssaaer(ncol,k,nb)=ssaaer3d_sw(i,k,j,nb)
+                  asmaer(ncol,k,nb)=asyaer3d_sw(i,k,j,nb)
+               end do
+            end do
+         end if
+      end if
+
 #ifdef WRF_CHEM
    IF ( AER_RA_FEEDBACK == 1) then
       do nb = 1, nbndsw
@@ -10485,6 +10873,7 @@ SUBROUTINE RRTMG_SWRAD(                                        &
       endif  ! aer_ra_feedback
 #endif
 
+
 ! Zero array for input of aerosol optical thickness for use with
 ! ECMWF aerosol types (not used)
          do na = 1, naerec
@@ -10522,13 +10911,15 @@ SUBROUTINE RRTMG_SWRAD(                                        &
              coszen  ,adjes   ,dyofyr  ,scon    , &
              inflgsw ,iceflgsw,liqflgsw,cldfmcl , &
              taucmcl ,ssacmcl ,asmcmcl ,fsfcmcl , &
-             ciwpmcl ,clwpmcl ,reicmcl ,relqmcl , &
+             ciwpmcl ,clwpmcl ,cswpmcl, reicmcl ,relqmcl ,resnmcl, &
              tauaer  ,ssaaer  ,asmaer  ,ecaer   , &
              swuflx  ,swdflx  ,swhr    ,swuflxc ,swdflxc ,swhrc, aer_opt, &
-! -----          Zhenxin added for ssib coupiling 2011-06-20 --------!
-             sibvisdir, sibvisdif, sibnirdir, sibnirdif          &
-                                                        )
+! -----      Zhenxin added for ssib coupiling 2011-06-20 --------!
+             sibvisdir, sibvisdif, sibnirdir, sibnirdif,         &
 ! --------------------   End of addiation by Zhenxin 2011-06-20 ------!
+             swdkdir, swdkdif                      &  ! jararias, 2012/08/10
+                                                   )
+
 
 ! Output net absorbed shortwave surface flux and shortwave cloud forcing
 ! at the top of atmosphere (W/m2)
@@ -10553,6 +10944,9 @@ SUBROUTINE RRTMG_SWRAD(                                        &
 !  Ended, Zhenxin (2011/06/20)
             swdnbc(i,j)    = swdflxc(1,1)
          endif
+            swddir(i,j)    = swdkdir(1,1)          ! jararias 2013/08/10
+            swddni(i,j)    = swddir(i,j) / coszrs  ! jararias 2013/08/10
+            swddif(i,j)    = swdkdif(1,1)          ! jararias 2013/08/10
 
 ! Output up and down layer fluxes for total and clear sky.
 ! Vertical ordering is from bottom to top in units of W m-2. 
@@ -10588,6 +10982,9 @@ SUBROUTINE RRTMG_SWRAD(                                        &
             swnirdir(i,j)  = 0.
             swnirdif(i,j)  = 0.  ! Add by Zhenxin (2011/06/20)
          endif
+            swddir(i,j)    = 0.  ! jararias 2013/08/10
+            swddni(i,j)    = 0.  ! jararias 2013/08/10
+            swddif(i,j)    = 0.  ! jararias 2013/08/10
 
       endif
 !
diff --git a/wrfv2_fire/phys/module_ra_sw.F b/wrfv2_fire/phys/module_ra_sw.F
index 48eded90..6f44d733 100644
--- a/wrfv2_fire/phys/module_ra_sw.F
+++ b/wrfv2_fire/phys/module_ra_sw.F
@@ -17,7 +17,8 @@ SUBROUTINE SWRAD(dt,RTHRATEN,GSW,XLAT,XLONG,ALBEDO,            &
                     RADFRQ,ICLOUD,DEGRAD,warm_rain,               &
                     ids,ide, jds,jde, kds,kde,                    & 
                     ims,ime, jms,jme, kms,kme,                    &
-                    its,ite, jts,jte, kts,kte                     &
+                    its,ite, jts,jte, kts,kte,                    &
+                    coszen,julian                                 & ! jararias, 14/08/2013
                     )
 !------------------------------------------------------------------
    IMPLICIT NONE
@@ -59,7 +60,9 @@ SUBROUTINE SWRAD(dt,RTHRATEN,GSW,XLAT,XLONG,ALBEDO,            &
 !
    INTEGER, INTENT(IN  ) ::                               JULDAY  
 
-
+   ! --- jararias 14/08/2013
+   REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: COSZEN
+   REAL, OPTIONAL, INTENT(IN) :: JULIAN
 
 !
 ! Optional
@@ -221,7 +224,8 @@ SUBROUTINE SWRAD(dt,RTHRATEN,GSW,XLAT,XLONG,ALBEDO,            &
                        XTIME,GMT,RHO01D,DZ,                        &
                        R,CP,G,DECLIN,SOLCON,                       &
                        RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1,   &
-                       kts,kte      )
+                       kts,kte,                                    &
+                       coszen(i,j),julian                          ) ! jararias, 14/08/2013
          GSW(I,J)=GSW0
          DO K=kts,kte          
             NK=kme-1-K+kms
@@ -234,12 +238,13 @@ SUBROUTINE SWRAD(dt,RTHRATEN,GSW,XLAT,XLONG,ALBEDO,            &
    END SUBROUTINE SWRAD
 
 !------------------------------------------------------------------
-   SUBROUTINE SWPARA(TTEN,GSW,XLAT,XLONG,ALBEDO,                  &
-                     T,QV,QC,QR,QI,QS,QG,P,            		  &
-                     XTIME, GMT, RHO0, DZ,             		  &
-                     R,CP,G,DECLIN,SOLCON,             		  &
-                     RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1,    &
-                     kts,kte,slope_rad,shadow,slp_azi,slope       )
+   SUBROUTINE SWPARA(TTEN,GSW,XLAT,XLONG,ALBEDO,               &
+                     T,QV,QC,QR,QI,QS,QG,P,                    &
+                     XTIME, GMT, RHO0, DZ,                     &
+                     R,CP,G,DECLIN,SOLCON,                     &
+                     RADFRQ,ICLOUD,DEGRAD,aer_dry1,aer_water1, &
+                     kts,kte,coszen,julian,                    &
+                     slope_rad,shadow,slp_azi,slope            )
 !------------------------------------------------------------------
 !     TO CALCULATE SHORT-WAVE ABSORPTION AND SCATTERING IN CLEAR
 !     AIR AND REFLECTION AND ABSORPTION IN CLOUD LAYERS (STEPHENS,
@@ -270,6 +275,9 @@ SUBROUTINE SWPARA(TTEN,GSW,XLAT,XLONG,ALBEDO,                  &
    REAL, INTENT(IN  )   ::               XTIME,GMT,R,CP,G,DECLIN, &
                                         SOLCON,XLAT,XLONG,ALBEDO, &
                                                   RADFRQ, DEGRAD
+
+   REAL, OPTIONAL, INTENT(IN) :: COSZEN, JULIAN ! jararias, 14/08/2013
+
 !
    INTEGER, INTENT(IN) :: icloud
    REAL, INTENT(INOUT)  ::                                   GSW
@@ -317,21 +325,30 @@ SUBROUTINE SWPARA(TTEN,GSW,XLAT,XLONG,ALBEDO,                  &
       REAL :: wgm, xalb, xi, xsca, xt24,xmu,xabsc,trans0,yj
       REAL :: xxlat,ww
       INTEGER :: iil,ii,jjl,ju,k,iu
+      REAL :: da,eot ! jararias 14/08/2013
 
 ! For slope-dependent radiation
 
    REAL :: diffuse_frac, corr_fac, csza_slp
 
-
-      GSW=0.0
-      bext340=5.E-6
-      bexth2o=5.E-6
-      SOLTOP=SOLCON
-      XT24=MOD(XTIME+RADFRQ*0.5,1440.)
-      TLOCTM=GMT+XT24/60.+XLONG/15.
-      HRANG=15.*(TLOCTM-12.)*DEGRAD
-      XXLAT=XLAT*DEGRAD
-      CSZA=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG)
+       GSW=0.0
+       bext340=5.E-6
+       bexth2o=5.E-6
+       SOLTOP=SOLCON
+       ! jararias, 14/08/2013
+       if (present(coszen)) then
+          csza=coszen
+       else
+!         da=6.2831853071795862*(julian-1)/365.
+!         eot=(0.000075+0.001868*cos(da)-0.032077*sin(da) &
+!            -0.014615*cos(2*da)-0.04089*sin(2*da))*(229.18)
+          xt24 = mod(xtime+radfrq*0.5,1440.)+eot
+          tloctm = gmt + xt24/60. + xlong/15.
+          hrang = 15. * (tloctm-12.) * degrad
+          xxlat = xlat * degrad
+          csza = sin(xxlat) * sin(declin) &
+               + cos(xxlat) * cos(declin) * cos(hrang)
+       end if
 
 !     RETURN IF NIGHT        
       IF(CSZA.LE.1.E-9)GOTO 7
diff --git a/wrfv2_fire/phys/module_radiation_driver.F b/wrfv2_fire/phys/module_radiation_driver.F
index 582d9be2..8c33b0bc 100644
--- a/wrfv2_fire/phys/module_radiation_driver.F
+++ b/wrfv2_fire/phys/module_radiation_driver.F
@@ -19,6 +19,7 @@ SUBROUTINE radiation_driver (                                  &
               ,NCFRCV ,NCFRST ,NPHS     &
               ,O3INPUT, O3RAD           &
               ,AER_OPT, aerod           &
+              ,swint_opt                &
               ,P8W    ,P ,PI            &
               ,RADT   ,RA_CALL_OFFSET   &
               ,RHO    ,RLWTOA           &
@@ -54,7 +55,13 @@ SUBROUTINE radiation_driver (                                  &
               , SLWDN, SLWUP                        & ! goddard schemes
               , TSWDN, TSWUP                        & ! goddard schemes
               , SSWDN, SSWUP                        & ! goddard schemes
-              , CLDFRA,CLDFRA_MP_ALL                              &
+              , CLDFRA,CLDFRA_MP_ALL                &
+#if (EM_CORE == 1)
+              , lradius,iradius                     &
+#endif
+              , cldfra_dp, cldfra_sh                & ! ckay for sub-grid cloud fraction
+              , re_cloud, re_ice, re_snow           & ! G. Thompson
+              , has_reqc, has_reqi, has_reqs        & ! G. Thompson
               , PB                                                &
               , F_ICE_PHY,F_RAIN_PHY       &
               , QV, F_QV                     &
@@ -88,9 +95,9 @@ SUBROUTINE radiation_driver (                                  &
               ,M_PS_1, M_PS_2, AEROSOLC_1     &
               ,AEROSOLC_2, M_HYBI0            &
               ,ABSTOT, ABSNXT, EMSTOT         &
-              ,CU_RAD_FEEDBACK                &
+              ,ICLOUD_CU                      &
               ,AER_RA_FEEDBACK                &
-              ,QC_ADJUST , QI_ADJUST          &
+              ,QC_CU , QI_CU                  &
               ,PM2_5_DRY, PM2_5_WATER         &
               ,PM2_5_DRY_EC                   &
               ,TAUAER300, TAUAER400 & ! jcb
@@ -115,6 +122,15 @@ SUBROUTINE radiation_driver (                                  &
               ,SWVISDIR, SWVISDIF, SWNIRDIR, SWNIRDIF                     & !fds ssib swr comp (06/2010)
               ,SF_SURFACE_PHYSICS, IS_CAMMGMP_USED                        & !fds
               ,EXPLICIT_CONVECTION                                        & ! .true.=no conv. scheme
+              ,swddir,swddni,swddif                                       & ! jararias 2013/08
+              ,swdown_ref,swddir_ref,coszen_ref,Gx,gg,Bx,bb               &
+              ,aer_type                                                   & ! jararias 2013/11
+              ,aer_aod550_opt, aer_aod550_val                             &
+              ,aer_angexp_opt, aer_angexp_val                             &
+              ,aer_ssa_opt, aer_ssa_val                                   &
+              ,aer_asy_opt, aer_asy_val                                   &
+              ,aod5502d, angexp2d, aerssa2d, aerasy2d                     &
+              ,aod5503d                                                   &
                                                                           )
 
 
@@ -158,6 +174,9 @@ SUBROUTINE radiation_driver (                                  &
    USE module_ra_goddard    , ONLY : goddardrad
    USE module_ra_flg        , ONLY : RAD_FLG
 
+   USE module_ra_aerosol    , ONLY : calc_aerosol_goddard_sw, &
+                                     calc_aerosol_rrtmg_sw
+
    !  This driver calls subroutines for the radiation parameterizations.
    !
    !  short wave radiation choices:
@@ -268,8 +287,10 @@ SUBROUTINE radiation_driver (                                  &
 !-- RSWTOA        upward short wave at top of atmosphere (w/m2)
 !-- XLAT          latitude, south is negative (degree)
 !-- XLONG         longitude, west is negative (degree)
-!-- ALBEDO                albedo (between 0 and 1)
+!-- ALBEDO        albedo (between 0 and 1)
 !-- CLDFRA        cloud fraction (between 0 and 1)
+!-- CLDFRA_DP     cloud fraction from deep cloud in a cumulus scheme
+!-- CLDFRA_SH     cloud fraction from shallow cloud in a cumulus scheme
 !-- CLDFRA_MP_ALL cloud fraction from CAMMGMP microphysics scheme
 !-- EMISS         surface emissivity (between 0 and 1)
 !-- rho_phy       density (kg/m^3)
@@ -329,8 +350,9 @@ SUBROUTINE radiation_driver (                                  &
                                        num_tiles
 
    INTEGER, INTENT(IN)            :: lw_physics, sw_physics
-   INTEGER, OPTIONAL, INTENT(IN)  :: o3input, aer_opt
+   INTEGER, INTENT(IN)            :: o3input, aer_opt
    INTEGER, INTENT(IN)            :: id
+   integer, intent(in)            :: swint_opt
 
    INTEGER, DIMENSION(num_tiles), INTENT(IN) ::                       &
                 i_start,i_end,j_start,j_end
@@ -394,8 +416,10 @@ SUBROUTINE radiation_driver (                                  &
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL ,       &
          INTENT(IN ) ::  tauaer300,tauaer400,tauaer600,tauaer999, & ! jcb
                                  gaer300,gaer400,gaer600,gaer999, & ! jcb
-                                 waer300,waer400,waer600,waer999, & ! jcb
-                                 qc_adjust, qi_adjust
+                                 waer300,waer400,waer600,waer999
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL ,       &
+         INTENT(IN ) ::          qc_cu, qi_cu
 
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL ,       &
          INTENT(IN ) ::  tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao 
@@ -403,7 +427,7 @@ SUBROUTINE radiation_driver (                                  &
                          tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao 
                          tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16
 
-   LOGICAL, INTENT(IN) :: cu_rad_feedback
+   INTEGER, INTENT(IN) :: icloud_cu
 
    INTEGER, INTENT(IN   ), OPTIONAL  ::   aer_ra_feedback
 
@@ -480,6 +504,32 @@ SUBROUTINE radiation_driver (                                  &
                                                              GLW
 
    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT)  ::   SWDOWN
+
+! ------------------------------------------------------------------------------ jararias 2013/08/10 -----------
+   REAL, DIMENSION( ims:ime, jms:jme ),  INTENT(OUT) :: swddir, & ! All-sky SW broadband surface direct irradiance
+                                                        swddni, & ! All-sky SW broadband surface direct normal irradiance
+                                                        swddif    ! All-sky SW broadband surface diffuse irradiance
+   REAL, DIMENSION( ims:ime, jms:jme ),  INTENT(INOUT) :: Gx,Bx,gg,bb, & ! For SW sza-interpolation
+                                                          swdown_ref,  &
+                                                          swddir_ref,  &
+                                                          coszen_ref
+! ------------------------------------------------------------------------------ jararias 2013/11    -----------
+    INTEGER,                             INTENT(IN)    :: aer_type,       & ! rural, urban, maritime, ...
+                                                          aer_aod550_opt, & ! input option for AOD at 550 nm
+                                                          aer_angexp_opt, & ! input option for aerosol Angstrom exponent
+                                                          aer_ssa_opt,    & ! input option for aerosol ssa
+                                                          aer_asy_opt       ! input option for aerosol asy
+    REAL,                                INTENT(IN)    :: aer_aod550_val, & ! AOD at 550 nm if aer_aod550_opt=1
+                                                          aer_angexp_val, & ! aerosol Angstrom exponent if aer_angexp_opt=1
+                                                          aer_ssa_val,    & ! aerosol ssa if aer_ssa_opt=1
+                                                          aer_asy_val       ! aerosol asy if aer_asy_opt=1
+    REAL, DIMENSION( ims:ime, jms:jme ),          OPTIONAL,               &
+          INTENT(INOUT)                                :: aod5502d,       & ! gridded AOD at 550 nm from auxinput
+                                                          angexp2d,       & ! gridded aerosol Angstrom exponent from auxinput
+                                                          aerssa2d,       & ! gridded aerosol ssa from auxinput
+                                                          aerasy2d          ! gridded aerosol asy from auxinput
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL,               &
+          INTENT(OUT)                                  :: aod5503d   ! 3D AOD at 550 nm
 !
    REAL, INTENT(IN  )   ::                                GMT,dt, &
                                                    julian, xtime
@@ -528,14 +578,31 @@ SUBROUTINE radiation_driver (                                  &
 !
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
          OPTIONAL,                                                &
-         INTENT(INOUT) ::                                 CLDFRA
+         INTENT(INOUT) ::                                 CLDFRA   
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  & ! ckay for sub-grid cloud fraction
+         OPTIONAL,                                                &
+         INTENT(INOUT) ::                              cldfra_dp, &
+                                                       cldfra_sh
+
+!..G. Thompson
+   REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: re_cloud, re_ice, re_snow
+   INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs
 
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                     &
          OPTIONAL,                                                   &
          INTENT(IN   ) ::                                            &
                                                           F_ICE_PHY, &
                                                          F_RAIN_PHY, &
-                                                         CLDFRA_MP_ALL
+                                                      CLDFRA_MP_ALL
+
+#if (EM_CORE == 1)
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                     &
+         OPTIONAL,                                                   &
+         INTENT(IN   ) ::                                            &
+                                                            LRADIUS, &
+                                                            IRADIUS
+#endif
 
    REAL, DIMENSION( ims:ime, jms:jme ),                           &
          OPTIONAL,                                                &
@@ -589,6 +656,8 @@ SUBROUTINE radiation_driver (                                  &
    REAL    ::    next_rad_time
    LOGICAL ::    run_param , doing_adapt_dt , decided
    LOGICAL ::    flg_lw, flg_sw
+!ckay
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) ::    cldfra_cu
 !------------------------------------------------------------------
 ! solar related variables are added to declaration
 !-------------------------------------------------
@@ -596,6 +665,13 @@ SUBROUTINE radiation_driver (                                  &
    REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: COSZEN
    REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme), INTENT(OUT) :: HRANG
 !------------------------------------------------------------------
+
+! jararias, 2013/08/10
+   real :: ioh,kt,airmass,kd
+   real, dimension(ims:ime,jms:jme) :: coszen_loc,hrang_loc
+! jararias 2013/11
+   real, dimension(:,:,:,:), allocatable :: tauaer_sw, ssaaer_sw, asyaer_sw
+
 #ifdef HWRF
    CHARACTER(len=265) :: wrf_err_message
 #endif
@@ -676,6 +752,20 @@ SUBROUTINE radiation_driver (                                  &
       radtacttime = curr_secs + radt*60
    END IF
 
+   if(swint_opt.eq.1) then
+      DO ij = 1 , num_tiles
+         its = i_start(ij)
+         ite = i_end(ij)
+         jts = j_start(ij)
+         jte = j_end(ij)
+         CALL radconst(XTIME,DECLIN,SOLCON,JULIAN,               &
+                       DEGRAD,DPD                                )
+         call calc_coszen(ims,ime,jms,jme,its,ite,jts,jte, &
+                          julian,xtime,gmt,declin,degrad,  &
+                          xlong,xlat,coszen_loc,hrang_loc)
+      end do
+   end if
+
    Radiation_step: IF ( run_param ) then
 
 ! CAM-specific additional radiation frequency - cam_abs_freq_s (=21600s by default)
@@ -700,7 +790,42 @@ SUBROUTINE radiation_driver (                                  &
    gfdl_lw = .false.
    gfdl_sw = .false.
 
+! Allocate aerosol arrays used by aer_opt = 2 option
+   IF ( PRESENT( AOD5502D ) ) THEN
+     ! jararias, 2013/11
+     IF ( aer_opt .EQ. 2 ) THEN
+        swrad_aerosol_select: select case(sw_physics)
+
+           case(GODDARDSWSCHEME)
+              allocate(tauaer_sw(ims:ime, kms:kme, jms:jme, 1:11))
+              allocate(ssaaer_sw(ims:ime, kms:kme, jms:jme, 1:11))
+              allocate(asyaer_sw(ims:ime, kms:kme, jms:jme, 1:11))
+
+           case(RRTMG_SWSCHEME)
+              allocate(tauaer_sw(ims:ime, kms:kme, jms:jme, 1:14))
+              allocate(ssaaer_sw(ims:ime, kms:kme, jms:jme, 1:14))
+              allocate(asyaer_sw(ims:ime, kms:kme, jms:jme, 1:14))
+
+        end select swrad_aerosol_select
+     ELSE
+        swrad_aerosol_select_stub: select case(sw_physics)
+
+           case(GODDARDSWSCHEME)
+              allocate(tauaer_sw(1, 1, 1, 1))
+              allocate(ssaaer_sw(1, 1, 1, 1))
+              allocate(asyaer_sw(1, 1, 1, 1))
+
+           case(RRTMG_SWSCHEME)
+              allocate(tauaer_sw(1, 1, 1, 1))
+              allocate(ssaaer_sw(1, 1, 1, 1))
+              allocate(asyaer_sw(1, 1, 1, 1))
+
+        end select swrad_aerosol_select_stub
+     ENDIF
+   ENDIF
 
+!---------------
+! Calculate constant for short wave radiation
 ! moved up and out of OMP loop because it only needs to be computed once
 ! and because it is not entirely thread-safe (XT24, TOLOCTM and XXLAT need
 ! their thread-privacy)  JM 20100217
@@ -718,21 +843,13 @@ SUBROUTINE radiation_driver (                                  &
        solconx=solcon
      ENDIF
 
-     IF(PRESENT(coszen).AND.PRESENT(hrang))THEN
-! state arrays of hrang and coszen used in surface driver
-       XT24=MOD(XTIME+RADT*0.5,1440.)
-       DO j=jts,jte
-       DO i=its,ite
-          TLOCTM=GMT+XT24/60.+XLONG(I,J)/15.
-          HRANG(I,J)=15.*(TLOCTM-12.)*DEGRAD
-          XXLAT=XLAT(I,J)*DEGRAD
-          COSZEN(I,J)=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG(I,J))
-       ENDDO
-       ENDDO
-     ENDIF
+! added coszen subroutine : jararias, 2013/08/10
+!   outputs: coszen, hrang
+     call calc_coszen(ims,ime,jms,jme,its,ite,jts,jte,  &
+                      julian,xtime+radt*0.5,gmt, &
+                      declin,degrad,xlong,xlat,coszen,hrang)
    ENDDO
 
-!---------------
    !$OMP PARALLEL DO   &
    !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte)
 
@@ -744,11 +861,25 @@ SUBROUTINE radiation_driver (                                  &
 
 ! initialize data
 
+     if ((itimestep.eq.1).and.(swint_opt.eq.1)) then
+        do j=jts,jte
+           do i=its,ite
+              Bx(i,j)=0.
+              bb(i,j)=0.
+              Gx(i,j)=0.
+              gg(i,j)=0.
+           end do
+        end do
+     end if
+
      DO j=jts,jte
      DO i=its,ite
         GSW(I,J)=0.
         GLW(I,J)=0.
         SWDOWN(I,J)=0.
+        swddir(i,j)=0.  ! jararias, 2013/08/10
+        swddni(i,j)=0.  ! jararias, 2013/08/10
+        swddif(i,j)=0.  ! jararias, 2013/08/10
         GLAT(I,J)=XLAT(I,J)*DEGRAD
         GLON(I,J)=XLONG(I,J)*DEGRAD
      ENDDO
@@ -792,22 +923,22 @@ SUBROUTINE radiation_driver (                                  &
 
 ! temporarily modify hydrometeors (currently only done for GD scheme and WRF-Chem)
 !
-       IF ( PRESENT( qc ) .AND. PRESENT( qc_adjust ) .AND. cu_rad_feedback ) THEN
+       IF ( PRESENT( qc ) .AND. PRESENT( qc_cu ) .AND. icloud_cu .EQ. 1 ) THEN
           DO j=jts,jte
           DO k=kts,kte
           DO i=its,ite
             qc_save(i,k,j) = qc(i,k,j)
-            qc(i,k,j) = qc(i,k,j) + qc_adjust(i,k,j)
+            qc(i,k,j) = qc(i,k,j) + qc_cu(i,k,j)
           ENDDO
           ENDDO
           ENDDO
        ENDIF
-       IF ( PRESENT( qi ) .AND. PRESENT( qi_adjust ) .AND. cu_rad_feedback ) THEN
+       IF ( PRESENT( qi ) .AND. PRESENT( qi_cu ) .AND. icloud_cu .EQ. 1 ) THEN
           DO j=jts,jte
           DO k=kts,kte
           DO i=its,ite
             qi_save(i,k,j) = qi(i,k,j)
-            qi(i,k,j) = qi(i,k,j) + qi_adjust(i,k,j)
+            qi(i,k,j) = qi(i,k,j) + qi_cu(i,k,j)
           ENDDO
           ENDDO
           ENDDO
@@ -832,58 +963,65 @@ SUBROUTINE radiation_driver (                                  &
         ENDDO
      endif
 ! Remove this - to match NAM operational (affects GFDL and HWRF schemes)
-!     if(PRESENT(qr) .and. PRESENT(F_QR)) then
-!        DO j=jts,jte
-!        DO k=kts,kte
-!        DO i=its,ite
-!           qc_temp(I,K,J) = qc_temp(I,K,J) + qr(I,K,J)
-!        ENDDO
-!        ENDDO
-!        ENDDO
-!     endif
-
-
-!---------------
-! Calculate constant for short wave radiation
-
-     lwrad_cldfra_select: SELECT CASE(lw_physics)
-
-        CASE (GFDLLWSCHEME)
-
-!-- Do nothing, since cloud fractions (with partial cloudiness effects) 
-!-- are defined in GFDL LW/SW schemes and do not need to be initialized.
+!    if(PRESENT(qr) .and. PRESENT(F_QR)) then
+!       DO j=jts,jte
+!       DO k=kts,kte
+!       DO i=its,ite
+!          qc_temp(I,K,J) = qc_temp(I,K,J) + qr(I,K,J)
+!       ENDDO
+!       ENDDO
+!       ENDDO
+!    endif
+
+! Choose how to compute cloud fraction (since 3.6)
+! Initialize to zero 
+     DO j=jts,jte
+     DO k=kts,kte
+     DO i=its,ite
+        CLDFRA(i,k,j) = 0.
+     END DO
+     END DO
+     END DO
 
-        CASE (CAMLWSCHEME)
+     IF ( ICLOUD == 1 ) THEN
 
      IF ( PRESENT ( CLDFRA ) .AND.                           &
           PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN
 ! Call to cloud fraction routine based on Randall 1994 (Hong Pan 1998)
 
-   CALL cal_cldfra2(CLDFRA,qv,qc,qi,qs,                     &
+        CALL wrf_debug (1, 'CALL cldfra2')
+        CALL cal_cldfra1(CLDFRA,qv,qc,qi,qs,               &
                    F_QV,F_QC,F_QI,F_QS,t,p,                &
                    F_ICE_PHY,F_RAIN_PHY,                   &
                    ids,ide, jds,jde, kds,kde,              &
                    ims,ime, jms,jme, kms,kme,              &
                    its,ite, jts,jte, kts,kte               )
 
-     ENDIF
-
-        CASE (RRTMG_LWSCHEME)
-
-     IF ( PRESENT ( CLDFRA ) .AND.                           &
-          PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN
-! Call to cloud fraction routine based on Randall 1994 (Hong Pan 1998)
-
-        CALL cal_cldfra2(CLDFRA,qv,qc,qi,qs,               &
-                   F_QV,F_QC,F_QI,F_QS,t,p,                &
-                   F_ICE_PHY,F_RAIN_PHY,                   &
-                   ids,ide, jds,jde, kds,kde,              &
-                   ims,ime, jms,jme, kms,kme,              &
-                   its,ite, jts,jte, kts,kte               )
+        IF ( PRESENT ( CLDFRA_DP ) ) THEN
+! this is for Kain-Fritsch scheme
+          IF ( icloud_cu .EQ. 2 ) THEN
+             CALL wrf_debug (1, 'use kf cldfra')
+             DO j = jts,jte
+             DO k = kts,kte
+             DO i = its,ite
+                cldfra_cu(i,k,j)=cldfra_dp(i,k,j)+cldfra_sh(i,k,j) ! Cu cloud fraction
+                CLDFRA(i,k,j)=(1.-cldfra_cu(i,k,j))*CLDFRA(i,k,j)  ! Update resolved cloud fraction for Cu punch-through
+                CLDFRA(i,k,j)=CLDFRA(i,k,j)+cldfra_cu(i,k,j)       ! New total cloud fraction
+                CLDFRA(i,k,j)=AMIN1(1.0,CLDFRA(i,k,j))
+                qc_save(i,k,j)=qc(i,k,j)
+                qc(i,k,j) = qc(i,k,j)+qc_cu(i,k,j)*cldfra_cu(i,k,j)
+                qi_save(i,k,j)=qi(i,k,j)
+                qi(i,k,j) = qi(i,k,j)+qi_cu(i,k,j)*cldfra_cu(i,k,j)
+             ENDDO
+             ENDDO
+             ENDDO
+          ENDIF
+        ENDIF
 
         IF ( PRESENT (cldfra_mp_all) ) THEN
           IF (is_CAMMGMP_used) THEN
             !BSINGH: cloud fraction from CAMMGMP is being used (Mods by Po-Lun)
+        CALL wrf_debug (1, 'use cammgmp')
             IF (itimestep .NE. 1) THEN
                DO j=jts,jte
                DO k=kts,kte
@@ -898,17 +1036,17 @@ SUBROUTINE radiation_driver (                                  &
         ENDIF
      ENDIF
  
-        CASE DEFAULT
+     ELSE IF ( ICLOUD == 2 ) THEN
 
      IF ( PRESENT ( CLDFRA ) .AND.                           &
           PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN
-       CALL cal_cldfra(CLDFRA,qc,qi,F_QC,F_QI,               &
+       CALL cal_cldfra2(CLDFRA,qc,qi,F_QC,F_QI,              &
                        ids,ide, jds,jde, kds,kde,            &
                        ims,ime, jms,jme, kms,kme,            &
                        its,ite, jts,jte, kts,kte             )
      ENDIF
 
-     END SELECT lwrad_cldfra_select    
+     END IF
 
 ! ww: Interpolating climatological ozone and aerosol to model time and levels
 !     Adapted from camrad code
@@ -1005,6 +1143,7 @@ SUBROUTINE radiation_driver (                                  &
                     ,f_qv=f_qv,f_qc=f_qc,f_qr=f_qr                     &
                     ,f_qi=f_qi,f_qs=f_qs,f_qg=f_qg                     &
                     ,erbe_out=erbe_out                                 & !optional
+                    ,aer_opt=aer_opt                                   &
                                                                        )
 
         CASE (GFDLLWSCHEME)
@@ -1125,7 +1264,7 @@ SUBROUTINE radiation_driver (                                  &
                  ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &     
                  ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
                  ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
-                                                                    )
+                 ,coszen=coszen                                     )
              ELSE
                 CALL wrf_error_fatal ( 'arguments not present for calling cam radiation' )
              ENDIF
@@ -1144,6 +1283,13 @@ SUBROUTINE radiation_driver (                                  &
                   P8W=p8w,P3D=p,PI3D=pi,DZ8W=dz8w,TSK=tsk,T3D=t,    &
                   T8W=t8w,RHO3D=rho,R=R_d,G=G,                      &
                   ICLOUD=icloud,WARM_RAIN=warm_rain,CLDFRA3D=CLDFRA,&
+#if (EM_CORE == 1)
+                  LRADIUS=lradius, IRADIUS=iradius,                 &
+#endif
+                  IS_CAMMGMP_USED=is_cammgmp_used,                  &
+
+!ckay
+!                 CLDFRA_KF3D=cldfra_KF,QC_KF3D=qc_KF,QI_KF3D=qi_KF,&
                   F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY,        &
                   XLAND=XLAND,XICE=XICE,SNOW=SNOW,                  &
                   QV3D=QV,QC3D=QC,QR3D=QR,                          &
@@ -1151,6 +1297,8 @@ SUBROUTINE radiation_driver (                                  &
                   O3INPUT=O3INPUT,O33D=O3RAD,                       &
                   F_QV=F_QV,F_QC=F_QC,F_QR=F_QR,                    &
                   F_QI=F_QI,F_QS=F_QS,F_QG=F_QG,                    &
+                  RE_CLOUD=re_cloud,RE_ICE=re_ice,RE_SNOW=re_snow,  & ! G. Thompson
+                  has_reqc=has_reqc,has_reqi=has_reqi,has_reqs=has_reqs, & ! G. Thompson
 #ifdef WRF_CHEM
                   TAUAERLW1=tauaerlw1,TAUAERLW2=tauaerlw2,          & ! jcb
                   TAUAERLW3=tauaerlw3,TAUAERLW4=tauaerlw4,          & ! jcb
@@ -1226,7 +1374,6 @@ SUBROUTINE radiation_driver (                                  &
           CALL wrf_debug(100, 'a4 Fu_Liou-Gu')
 ! -- end 
 
-
         CASE DEFAULT
   
              WRITE( wrf_err_message , * ) 'The longwave option does not exist: lw_physics = ', lw_physics
@@ -1259,41 +1406,45 @@ SUBROUTINE radiation_driver (                                  &
           ENDIF
      ENDIF       
 
-!
-     swrad_cldfra_select: SELECT CASE(sw_physics)
-
-        CASE (CAMSWSCHEME)
-
-     IF ( PRESENT ( CLDFRA ) .AND.                           &
-          PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN
-! Call to cloud fraction routine based on Randall 1994 (Hong Pan 1998)
-
-   CALL cal_cldfra2(CLDFRA,qv,qc,qi,qs,                     &
-                   F_QV,F_QC,F_QI,F_QS,t,p,                &
-                   F_ICE_PHY,F_RAIN_PHY,                   &
-                   ids,ide, jds,jde, kds,kde,              &
-                   ims,ime, jms,jme, kms,kme,              &
-                   its,ite, jts,jte, kts,kte               )
+     IF ( PRESENT( AOD5502D ) ) THEN
+     ! jararias, 2013/11
+     IF ( aer_opt .EQ. 2 ) THEN
+     swrad_aerosol_select2: select case(sw_physics)
+        case(GODDARDSWSCHEME)
+           call wrf_debug(100, 'call calc_aerosol_goddard_sw')
+           call calc_aerosol_goddard_sw(ht,dz8w,p,t,qv,aer_type,aer_aod550_opt,aer_angexp_opt,    &
+                                        aer_ssa_opt,aer_asy_opt,aer_aod550_val,aer_angexp_val,    &
+                                        aer_ssa_val,aer_asy_val,aod5502d,angexp2d,aerssa2d,       &
+                                        aerasy2d,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte, &
+                                        tauaer_sw,ssaaer_sw,asyaer_sw                             )
+           do j=jts,jte
+              do i=its,ite
+                 do k=kts,kte
+                    aod5503d(i,k,j)=tauaer_sw(i,k,j,8) ! band at 550 nm
+                 end do
+              end do
+           end do
+
+        case(RRTMG_SWSCHEME)
+           call wrf_debug(100, 'call calc_aerosol_rrtmg_sw')
+           call calc_aerosol_rrtmg_sw(ht,dz8w,p,t,qv,aer_type,aer_aod550_opt,aer_angexp_opt,    &
+                                      aer_ssa_opt,aer_asy_opt,aer_aod550_val,aer_angexp_val,    &
+                                      aer_ssa_val,aer_asy_val,aod5502d,angexp2d,aerssa2d,       &
+                                      aerasy2d,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte, &
+                                      tauaer_sw,ssaaer_sw,asyaer_sw                             )
+           do j=jts,jte
+              do i=its,ite
+                 do k=kts,kte
+                    aod5503d(i,k,j)=tauaer_sw(i,k,j,10) ! band at 550 nm
+                 end do
+              end do
+           end do
+
+        case default
+     end select swrad_aerosol_select2
      ENDIF
- 
-        CASE (RRTMG_SWSCHEME)
-
-     IF ( PRESENT ( CLDFRA ) .AND.                           &
-          PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN
-! Call to cloud fraction routine based on Randall 1994 (Hong Pan 1998)
-
-        CALL cal_cldfra2(CLDFRA,qv,qc,qi,qs,               &
-                   F_QV,F_QC,F_QI,F_QS,t,p,                &
-                   F_ICE_PHY,F_RAIN_PHY,                   &
-                   ids,ide, jds,jde, kds,kde,              &
-                   ims,ime, jms,jme, kms,kme,              &
-                   its,ite, jts,jte, kts,kte               )
      ENDIF
 
-        CASE DEFAULT
-
-     END SELECT swrad_cldfra_select    
-
      swrad_select: SELECT CASE(sw_physics)
 
         CASE (SWRADSCHEME)
@@ -1321,7 +1472,8 @@ SUBROUTINE radiation_driver (                                  &
                     ,QS3D=qs                                           &
                     ,QG3D=qg                                           &
                     ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr                     &
-                    ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg                     )
+                    ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg                     &
+                    ,coszen=coszen,julian=julian                       )
 
         CASE (GSFCSWSCHEME)
              CALL wrf_debug(100, 'CALL gsfcswrad')
@@ -1374,7 +1526,7 @@ SUBROUTINE radiation_driver (                                  &
                     ,gmt=gmt,cp=cp,g=g,t8w=t8w                         &
                     ,julday=julday,xtime=xtime                         &
                     ,declin=declin,solcon=solcon                       &
-                    , center_lat = cen_lat                             &
+                    ,center_lat = cen_lat                              &
                     ,radfrq=radt,degrad=degrad                         &
                     ,taucldi=taucldi,taucldc=taucldc                   &
                     ,warm_rain=warm_rain                               &
@@ -1391,6 +1543,12 @@ SUBROUTINE radiation_driver (                                  &
                     ,f_qv=f_qv,f_qc=f_qc,f_qr=f_qr                     &
                     ,f_qi=f_qi,f_qs=f_qs,f_qg=f_qg                     &
                     ,erbe_out=erbe_out                                 & !optional
+                    ,swddir=swddir,swddni=swddni,swddif=swddif         & ! jararias, 14/08/2013
+                    ,coszen=coszen,julian=julian                       & ! jararias, 14/08/2013
+                    ,tauaer3d_sw=tauaer_sw                             & ! jararias, 2013/11
+                    ,ssaaer3d_sw=ssaaer_sw                             & ! jararias, 2013/11
+                    ,asyaer3d_sw=asyaer_sw                             & ! jararias, 2012/11
+                    ,aer_opt=aer_opt                                   &
                                                                        )
 
         CASE (CAMSWSCHEME)
@@ -1443,7 +1601,7 @@ SUBROUTINE radiation_driver (                                  &
                  ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &     
                  ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
                  ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
-                                                                    )
+                 ,coszen=coszen                                     )
              ELSE
                 CALL wrf_error_fatal ( 'arguments not present for calling cam radiation' )
              ENDIF
@@ -1469,7 +1627,14 @@ SUBROUTINE radiation_driver (                                  &
                      COSZR=COSZR,JULDAY=JULDAY,SOLCON=SOLCON,          &
                      ALBEDO=ALBEDO,t3d=t,t8w=t8w,TSK=TSK,              &
                      p3d=p,p8w=p8w,pi3d=pi,rho3d=rho,                  &
-                     dz8w=dz8w,CLDFRA3D=CLDFRA,R=R_D,G=G,              &
+                     dz8w=dz8w,CLDFRA3D=CLDFRA,                        &
+#if (EM_CORE == 1)
+                     LRADIUS=lradius, IRADIUS=iradius,                 &
+#endif
+                     IS_CAMMGMP_USED=is_cammgmp_used,                  &
+                     R=R_D,G=G,              &
+!ckay
+!                    CLDFRA_KF3D=cldfra_KF,QC_KF3D=qc_KF,QI_KF3D=qi_KF,&
                      ICLOUD=icloud,WARM_RAIN=warm_rain,                &
                      F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY,        &
                      XLAND=XLAND,XICE=XICE,SNOW=SNOW,                  &
@@ -1484,6 +1649,8 @@ SUBROUTINE radiation_driver (                                  &
                      SF_SURFACE_PHYSICS=sf_surface_physics,            &  !Zhenxin ssib sw_phy   (06/2010)
                      F_QV=f_qv,F_QC=f_qc,F_QR=f_qr,                    &
                      F_QI=f_qi,F_QS=f_qs,F_QG=f_qg,                    &
+                     RE_CLOUD=re_cloud,RE_ICE=re_ice,RE_SNOW=re_snow,  & ! G. Thompson
+                     has_reqc=has_reqc,has_reqi=has_reqi,has_reqs=has_reqs, & ! G. Thompson
 #ifdef WRF_CHEM
                      TAUAER300=tauaer300,TAUAER400=tauaer400,          & ! jcb
                      TAUAER600=tauaer600,TAUAER999=tauaer999,          & ! jcb
@@ -1500,8 +1667,13 @@ SUBROUTINE radiation_driver (                                  &
                      IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme,&
                      ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte,&
                      SWUPFLX=SWUPFLX,SWUPFLXC=SWUPFLXC,                &
-                     SWDNFLX=SWDNFLX,SWDNFLXC=SWDNFLXC                 &
-                                                                       )
+                     SWDNFLX=SWDNFLX,SWDNFLXC=SWDNFLXC,                &
+                     tauaer3d_sw=tauaer_sw,                             & ! jararias 2013/11
+                     ssaaer3d_sw=ssaaer_sw,                             & ! jararias 2013/11
+                     asyaer3d_sw=asyaer_sw,                             & ! jararias 2013/11
+                     swddir=swddir,swddni=swddni,swddif=swddif,         & ! jararias 2013/08/10
+                     xcoszen=coszen,julian=julian                       ) ! jararias 2013/08/14
+
              DO j=jts,jte
              DO k=kts,kte
              DO i=its,ite
@@ -1624,10 +1796,34 @@ SUBROUTINE radiation_driver (                                  &
            SWDOWN(I,J)=GSW(I,J)/(1.-ALBEDO(I,J))
         ENDDO
         ENDDO
-
      ENDIF
 
-       IF ( PRESENT( qc  ) .AND. PRESENT( qc_adjust ) .AND. cu_rad_feedback ) THEN
+! jararias, 14/08/2013
+     ! surface direct and diffuse SW fluxes computation. Only for schemes other than RRTMG and Goddard
+     ! Backup method in case sw scheme in use does not provide surface SW direct and diffuse irradiances
+     if ((sw_physics .ne. rrtmg_swscheme) .and. (sw_physics .ne. goddardswscheme)) then
+        do j=jts,jte
+           do i=its,ite
+              if (coszen(i,j).gt.1e-3) then
+                 ioh=solcon*coszen(i,j) ! TOA irradiance
+                 kt=swdown(i,j)/max(ioh,1e-3) ! clearness index
+                 ! Optical air mass: Rigollier et al. (2000) doi: 10.1016/S0038-092X(99)00055-9
+                 airmass=exp(-ht(i,j)/8434.5)/(coszen(i,j)+ &
+                        0.50572*(asin(coszen(i,j))*57.295779513082323+6.07995)**(-1.6364))
+                 ! kt correction for air-mass at large sza: Perez et al. (1990) doi: 10.1016/0038-092X(90)90036-C
+                 kt=kt/(0.1+1.031*exp(-1.4/(0.9+(9.4/max(airmass,1e-3)))))
+                 ! Diffuse fraction: Ruiz-Arias et al. (2010) (Eq 33) doi: 10.1016/j.enconman.2009.11.024
+                 kd=0.952-1.041*exp(-exp(2.300-4.702*kt))
+                 swddif(i,j)=kd*swdown(i,j)
+                 swddir(i,j)=(1.-kd)*swdown(i,j)
+                 swddni(i,j)=swddir(i,j)/max(coszen(i,j),1e-4)
+              end if
+           end do
+        end do
+     end if
+
+       IF ( PRESENT( qc  ) .AND. PRESENT( qc_cu ) ) THEN 
+           IF ( icloud_cu .NE. 0 ) THEN
            DO j=jts,jte
            DO k=kts,kte
            DO i=its,ite
@@ -1635,8 +1831,10 @@ SUBROUTINE radiation_driver (                                  &
            ENDDO
            ENDDO
            ENDDO
+           ENDIF
         ENDIF
-        IF ( PRESENT( qi  ) .AND. PRESENT( qi_adjust ) .AND. cu_rad_feedback ) THEN
+        IF ( PRESENT( qi  ) .AND. PRESENT( qi_cu ) ) THEN
+           IF ( icloud_cu .NE. 0 ) THEN
            DO j=jts,jte
            DO k=kts,kte
            DO i=its,ite
@@ -1644,13 +1842,49 @@ SUBROUTINE radiation_driver (                                  &
            ENDDO
            ENDDO
            ENDDO
+           ENDIF
         ENDIF
 
+     ! jararias, aug 2013, updated 2013/11
+     ! parameters update for SW surface fluxes interpolation
+     if (swint_opt.eq.1) then
+        ! interpolation applies on all-sky fluxes (swddir, swdown)
+        call update_swinterp_parameters(ims,ime,jms,jme,its,ite,jts,jte,   &
+                                        coszen,coszen_loc,swddir,swdown,   &
+                                        swddir_ref,bb,Bx,swdown_ref,gg,Gx, &
+                                        coszen_ref                         )
+     end if
+
    ENDDO
    !$OMP END PARALLEL DO
 
+   IF ( allocated(tauaer_sw) ) deallocate(tauaer_sw)
+   IF ( allocated(ssaaer_sw) ) deallocate(ssaaer_sw)
+   IF ( allocated(asyaer_sw) ) deallocate(asyaer_sw)
+
    ENDIF Radiation_step
 
+ ! jararias, aug 2013
+ ! SW surface fluxes interpolation (meaningful when not in a Radiation_step)
+ if (swint_opt .eq. 1) then
+    call wrf_debug(100,'SW surface irradiance interpolation')
+
+    !---------------
+    !$OMP PARALLEL DO   &
+    !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte)
+    do ij = 1,num_tiles
+      its = i_start(ij)
+      ite = i_end(ij)
+      jts = j_start(ij)
+      jte = j_end(ij)
+      call interp_sw_radiation(ims,ime,jms,jme,its,ite,jts,jte,  &
+                               coszen_ref,coszen_loc,swddir_ref, &
+                               bb,Bx,swdown_ref,gg,Gx,           &
+                               swdown,swddir,swddni,swddif       )
+    enddo
+    !$OMP END PARALLEL DO
+ end if
+
      accumulate_lw_select: SELECT CASE(lw_physics)
 
      CASE (CAMLWSCHEME,RRTMG_LWSCHEME)
@@ -1941,11 +2175,165 @@ SUBROUTINE radconst(XTIME,DECLIN,SOLCON,JULIAN,                   &
    
    END SUBROUTINE radconst
 
+
+   SUBROUTINE calc_coszen(ims,ime,jms,jme,its,ite,jts,jte,  &
+                          julian,xtime,gmt, &
+                          declin,degrad,xlon,xlat,coszen,hrang)
+       ! Added Equation of Time correction : jararias, 2013/08/10
+       implicit none
+       integer, intent(in) :: ims,ime,jms,jme,its,ite,jts,jte
+       real, intent(in)    :: julian,declin,xtime,gmt,degrad
+       real, dimension(ims:ime,jms:jme), intent(in)    :: xlat,xlon
+       real, dimension(ims:ime,jms:jme), intent(inout) :: coszen,hrang
+
+       integer :: i,j
+       real    :: da,eot,xt24,tloctm,xxlat
+
+       da=6.2831853071795862*(julian-1)/365.
+       eot=(0.000075+0.001868*cos(da)-0.032077*sin(da) &
+            -0.014615*cos(2*da)-0.04089*sin(2*da))*(229.18)
+       xt24=mod(xtime,1440.)+eot
+       do j=jts,jte
+          do i=its,ite
+             tloctm=gmt+xt24/60.+xlon(i,j)/15.
+             hrang(i,j)=15.*(tloctm-12.)*degrad
+             xxlat=xlat(i,j)*degrad
+             coszen(i,j)=sin(xxlat)*sin(declin) &
+                        +cos(xxlat)*cos(declin) *cos(hrang(i,j))
+          enddo
+       enddo
+   END SUBROUTINE calc_coszen
+
+   subroutine update_swinterp_parameters(ims,ime,jms,jme,its,ite,jts,jte, &
+                                         coszen,coszen_loc,swddir,swdown, &
+                                         swddir_ref,bb,Bx,                &
+                                         swdown_ref,gg,Gx,                &
+                                         coszen_ref                       )
+      ! Author: jararias 2013/11
+      implicit None
+      integer, intent(in) :: ims,ime,jms,jme,its,ite,jts,jte
+      real, dimension(ims:ime,jms:jme), intent(in)    :: coszen,coszen_loc,swddir,swdown
+      real, dimension(ims:ime,jms:jme), intent(inout) :: swddir_ref,bb,Bx, &
+                                                         swdown_ref,gg,Gx, &
+                                                         coszen_ref
+
+      integer :: i,j
+      real :: swddir_0,swdown_0,coszen_0
+      real, parameter :: coszen_min=1e-4
+
+      do j=jts,jte
+         do i=its,ite
+            if ((coszen(i,j).gt.coszen_min) .and. (coszen_loc(i,j).gt.coszen_min)) then
+               ! parameters update for DIR
+               if (Bx(i,j).le.0) then
+                  swddir_0 =(coszen_loc(i,j)/coszen(i,j))*swddir(i,j) ! linear first guess estimation
+                  coszen_0 =coszen_loc(i,j)
+               else
+                  swddir_0 =swddir_ref(i,j)
+                  coszen_0 =coszen_ref(i,j)
+               end if
+               if ((coszen(i,j)/coszen_0).lt.1.) then
+                  bb(i,j) =log(max(1.,swddir(i,j))/max(1.,swddir_0)) / log(min(1.-1e-4,coszen(i,j)/coszen_0))
+               elseif ((coszen(i,j)/coszen_0).gt.1) then
+                  bb(i,j) =log(max(1.,swddir(i,j))/max(1.,swddir_0)) / log(max(1.+1e-4,coszen(i,j)/coszen_0))
+               else
+                  bb(i,j) =0.
+               end if
+               bb(i,j) =max(-.5,min(2.5,bb(i,j)))
+               Bx(i,j) =swddir(i,j)/(coszen(i,j)**bb(i,j))
+
+               !write(wrf_err_message,*) 'XXX I=',i,' J=',j,'  Bx=',Bx(i,j),'  bb=',bb(i,j),'  swddir=',swddir(i,j), &
+               !                         '  swddir_0=',swddir_0,'  coszen=',coszen(i,j),'  coszen_0=',coszen_0
+               !call wrf_debug(1,wrf_err_message)
+
+               ! parameters update for GHI
+               if (Gx(i,j).le.0) then
+                  swdown_0 =(coszen_loc(i,j)/coszen(i,j))*swdown(i,j) ! linear first guess estimation
+                  coszen_0 =coszen_loc(i,j)
+               else
+                  swdown_0 =swdown_ref(i,j)
+                  coszen_0 =coszen_ref(i,j)
+               end if
+               if ((coszen(i,j)/coszen_0).lt.1.) then
+                  gg(i,j) =log(max(1.,swdown(i,j))/max(1.,swdown_0)) / log(min(1.-1e-4,coszen(i,j)/coszen_0))
+               elseif ((coszen(i,j)/coszen_0).gt.1) then
+                  gg(i,j) =log(max(1.,swdown(i,j))/max(1.,swdown_0)) / log(max(1.+1e-4,coszen(i,j)/coszen_0))
+               else
+                  gg(i,j) =0.
+               end if
+               gg(i,j) =max(-.5,min(2.5,gg(i,j)))
+               Gx(i,j) =swdown(i,j)/(coszen(i,j)**gg(i,j))
+            else
+               Bx(i,j) =0.
+               bb(i,j) =0.
+               Gx(i,j) =0.
+               gg(i,j) =0.
+            end if
+
+            ! saving last SW run in state variables
+            coszen_ref(i,j) =coszen(i,j)
+            swdown_ref(i,j) =swdown(i,j)
+            swddir_ref(i,j) =swddir(i,j)
+
+            !if ((i.eq.20).and.(j.eq.20)) then
+            !   write(wrf_err_message,'("   RADSTEP : tn=",I4," csz_0=",F9.6," csz=",F9.6," csz_1=",F9.6," Gx=",F14.2," gg=",F9.5,  &
+            !                           " Bx=",F14.2," bb=",F9.5)') itimestep,coszen_0,coszen_loc(i,j),coszen(i,j),Gx(i,j),gg(i,j), &
+            !                           Bx(i,j),bb(i,j)
+            !   call wrf_debug(1,wrf_err_message)
+            !end if
+
+         end do
+      end do
+
+   end subroutine update_swinterp_parameters
+
+   subroutine interp_sw_radiation(ims,ime,jms,jme,its,ite,jts,jte,  &
+                                  coszen_ref,coszen_loc,swddir_ref, &
+                                  bb,Bx,swdown_ref,gg,Gx,           &
+                                  swdown,swddir,swddni,swddif       )
+      ! Author: jararias 2013/11
+      implicit None
+      integer, intent(in) :: ims,ime,jms,jme,its,ite,jts,jte
+      real, dimension(ims:ime,jms:jme), intent(in) :: coszen_ref,coszen_loc, &
+                                                      swddir_ref,Bx,bb,      &
+                                                      swdown_ref,Gx,gg       
+      real, dimension(ims:ime,jms:jme), intent(inout) :: swddir,swdown, &
+                                                         swddif,swddni    
+
+      integer :: i,j
+      real, parameter :: coszen_min=1e-4
+
+      do j=jts,jte
+         do i=its,ite
+            ! sza interpolation of surface fluxes
+            if ((coszen_ref(i,j).gt.coszen_min) .and. (coszen_loc(i,j).gt.coszen_min)) then
+               if ((bb(i,j).eq.-0.5).or.(bb(i,j).eq.2.5)) then
+                  swddir(i,j) =(coszen_loc(i,j)/coszen_ref(i,j))*swddir_ref(i,j)
+               else
+                  swddir(i,j) =Bx(i,j)*(coszen_loc(i,j)**bb(i,j))
+               end if
+               if ((gg(i,j).eq.-0.5).or.(gg(i,j).eq.2.5)) then
+                  swdown(i,j) =(coszen_loc(i,j)/coszen_ref(i,j))*swdown_ref(i,j)
+               else
+                  swdown(i,j) =Gx(i,j)*(coszen_loc(i,j)**gg(i,j))
+               end if
+               swddif(i,j) =swdown(i,j)-swddir(i,j)
+               swddni(i,j) =swddir(i,j)/coszen_loc(i,j)
+            else
+               swddir(i,j) =0.
+               swdown(i,j) =0.
+               swddif(i,j) =0.
+               swddni(i,j) =0.
+            end if
+         end do
+      end do
+   end subroutine interp_sw_radiation
+
 !---------------------------------------------------------------------
 !BOP
-! !IROUTINE: cal_cldfra - Compute cloud fraction
+! !IROUTINE: cal_cldfra2 - Compute cloud fraction
 ! !INTERFACE:
-   SUBROUTINE cal_cldfra(CLDFRA,QC,QI,F_QC,F_QI,                     &
+   SUBROUTINE cal_cldfra2(CLDFRA,QC,QI,F_QC,F_QI,                    &
           ids,ide, jds,jde, kds,kde,                                 &
           ims,ime, jms,jme, kms,kme,                                 &
           its,ite, jts,jte, kts,kte                                  )
@@ -2019,10 +2407,10 @@ SUBROUTINE cal_cldfra(CLDFRA,QC,QI,F_QC,F_QI,                     &
         ENDDO
      ENDIF
 
-   END SUBROUTINE cal_cldfra
+   END SUBROUTINE cal_cldfra2
 
 !BOP
-! !IROUTINE: cal_cldfra2 - Compute cloud fraction
+! !IROUTINE: cal_cldfra1 - Compute cloud fraction
 ! !INTERFACE:
 ! cal_cldfra_xr - Compute cloud fraction.
 ! Code adapted from that in module_ra_gfdleta.F in WRF_v2.0.3 by James Done
@@ -2031,7 +2419,7 @@ END SUBROUTINE cal_cldfra
 !!     (see Hong et al., 1998)
 !!     (modified by Ferrier, Feb '02)
 !
-   SUBROUTINE cal_cldfra2(CLDFRA, QV, QC, QI, QS,                     &
+   SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS,                     &
                          F_QV, F_QC, F_QI, F_QS, t_phy, p_phy,       &
                          F_ICE_PHY,F_RAIN_PHY,                       &
           ids,ide, jds,jde, kds,kde,                                 &
@@ -2223,7 +2611,7 @@ SUBROUTINE cal_cldfra2(CLDFRA, QV, QC, QI, QS,                     &
     ENDDO          !--- End DO k
     ENDDO          !--- End DO j
 
-   END SUBROUTINE cal_cldfra2
+   END SUBROUTINE cal_cldfra1
 
 
    SUBROUTINE toposhad_init(ht_shad,ht_loc,shadowmask,nested,iter,   &
@@ -3106,7 +3494,12 @@ SUBROUTINE aer_p_int(p ,pin, levsiz, aerodt, aerod, no_src, pf, totaod,   &
    end do
    end do
 
-!  totaod = 0.
+   do j=jts,jte
+   do i=its,ite
+      totaod(i,j) = 0.
+   end do
+   end do
+
    do s=1,no_src
    do j=jts,jte
    do k=1,pver
diff --git a/wrfv2_fire/phys/module_sf_clm.F b/wrfv2_fire/phys/module_sf_clm.F
index 1931d989..d3e6c208 100644
--- a/wrfv2_fire/phys/module_sf_clm.F
+++ b/wrfv2_fire/phys/module_sf_clm.F
@@ -399,6 +399,7 @@ module clm_varpar
 #endif
  integer, parameter :: max_pft_per_lu    = max(numpft+1, numcft, maxpatch_urb)
   integer, parameter :: max_pft_per_col   = max(numpft+1, numcft, maxpatch_urb)
+  integer  :: num_landcover_types 
 
 
 !Are these constants used?  I don't see max_col_per_lunit referenced anywhere.
@@ -417,7 +418,11 @@ module clm_varpar
 !  integer, parameter :: max_lunit_per_gcell = 5            !(soil,urban,lake,wetland,glacier)
 
 contains
-	subroutine clm_varpar_mod
+	subroutine clm_varpar_mod(nlcat)
+          integer,intent(in)  :: nlcat 
+
+          num_landcover_types = nlcat ! land use type
+
 	end subroutine clm_varpar_mod
 !------------------------------------------------------------------------------
 end module clm_varpar
@@ -433,7 +438,8 @@ module clm_varcon
 ! !USES:
   use shr_kind_mod, only: r8 => shr_kind_r8
   use clm_varpar, only : numcol,numrad,nlevlak,&
-                         maxpatch_pft,numpft,nlevgrnd
+                         maxpatch_pft,numpft,nlevgrnd,&
+                         num_landcover_types
 !
 ! !PUBLIC TYPES:
   implicit none
@@ -791,7 +797,7 @@ module clm_varcon
   !------------------------------------------------------------------
 
 
-  integer,parameter :: num_landcover_types  = 24  !24 (USGS)
+!!!!!  integer,parameter :: num_landcover_types   !24 (USGS); 20 (MODIS)
 
 
   ! saturated soil albedos for 8 color classes: 1=vis, 2=nir
@@ -837,8 +843,10 @@ module clm_varcon
     real(r8) :: sand(19)                           ! percent sand
     real(r8) :: clay(19)                           ! percent clay
     integer  :: soic(19)
-    integer  :: plant(24,maxpatch_pft)
-    real(r8) :: cover(24,maxpatch_pft)
+
+    integer, allocatable :: plant(:,:)
+    real(r8),allocatable :: cover(:,:)
+
 
     data(sand(i), i=1,19)/92.,80.,66.,20.,5.,43.,60.,&
       10.,32.,51., 6.,22.,39.7,0.,100.,54.,17.,100.,92./
@@ -870,46 +878,6 @@ module clm_varcon
 ! (18) lava
 ! (19) white-sand
 !----------------------------------------------------------------------------
-  data (plant(i,1),i=1,24) / 0,  15,  15,  15,  15,  15, &
-                            14,   9,   9,  14,   7,   3, &
-                             4,   1,   1,   0,   0,   4, &
-                            11,  11,   2,  11,  11,   0/
-  data (cover(i,1),i=1,24) /100.,  85.,  85.,  85.,  50.,  40., &
-                             60.,  80.,  50.,  70.,  75.,  50., &
-                             95.,  75.,  37., 100., 100.,  80., &
-                             10.,  30.,  13.,  20.,  10., 100./
-
-  data (plant(i,2),i=1,24) / 0,   0,   0,   0,  14,   3, &
-                            13,   0,  14,   6,   0,   0, &
-                             0,   0,   7,   0,   0,   0, &
-                             0,  12,   3,  12,  12,   0/
-  data (cover(i,2),i=1,24) /  0.,  15.,  15.,  15.,  35.,  30., &
-                             20.,  20.,  30.,  30.,  25.,  50., &
-                              5.,  25.,  37.,   0.,   0.,  20., &
-                             90.,  30.,  13.,  20.,  10.,   0./
-
-  data (plant(i,3),i=1,24) / 0,   0,   0,   0,   0,   0, &
-                             0,   0,   0,   0,   0,   0, &
-                             0,   0,   0,   0,   0,   0, &
-                             0,   0,  10,   0,   0,   0/
-
-  data (cover(i,3),i=1,24) /  0.,   0.,   0.,   0.,  15.,  30., &
-                             20.,   0.,  20.,   0.,   0.,   0., &
-                              0.,   0.,  26.,   0.,   0.,   0., &
-                              0.,  40.,  24.,  60.,  80.,   0./
-
-  data (plant(i,4),i=1,24) / 0,   0,   0,   0,   0,   0, &
-                             0,   0,   0,   0,   0,   0, &
-                             0,   0,   0,   0,   0,   0, &
-                             0,   0,   0,   0,   0,   0/
-
-  data (cover(i,4),i=1,24) / 0.,   0.,   0.,   0.,   0.,   0., &
-                             0.,   0.,   0.,   0.,   0.,   0., &
-                             0.,   0.,   0.,   0.,   0.,   0., &
-                             0.,   0.,  50.,   0.,   0.,   0./
-
-!-----------------------------------------------------------------------
-
 !USGS vegetation 24 categories
 !
 !Urban and Built-Up Land            1
@@ -936,6 +904,28 @@ module clm_varcon
 !Mixed Tundra                      22
 !Bare Ground Tundra                23
 !Snow or Ice                       24
+!-----------------------------------------------------------------------
+! MODIS vegetation 20 categories
+!'Evergreen Needleleaf Forest'       1 
+!'Evergreen Broadleaf Forest'        2
+!'Deciduous Needleleaf Forest'       3
+!'Deciduous Broadleaf Forest'        4
+!'Mixed Forests'                     5
+!'Closed Shrublands'                 6
+!'Open Shrublands'                   7
+!'Woody Savannas'                    8
+!'Savannas'                          9
+!'Grasslands'                        10
+!'Permanent wetlands'                11
+!'Croplands'                         12
+!'Urban and Built-Up'                13
+!'cropland/natural vegetation mosaic'14
+!'Snow and Ice'                      15
+!'Barren or Sparsely Vegetated'      16
+!'Water'                             17
+!'Wooded Tundra'                     18
+!'Mixed Tundra'                      19
+!'Barren Tundra'                     20
 !-----------------------------------------------------------------------
     real(r8):: lai(numpft,12),sai(numpft,12)
 
@@ -1118,6 +1108,80 @@ module clm_varcon
 contains
 
  subroutine var_par
+
+    allocate  (plant(num_landcover_types,maxpatch_pft))
+    allocate  (cover(num_landcover_types,maxpatch_pft))
+
+  if(num_landcover_types== 24.or. num_landcover_types==28) then ! USGS
+      plant(:,1) = (/ 0,  15,  15,  15,  15,  15, &
+                            14,   9,   9,  14,   7,   3, &
+                             4,   1,   1,   0,   0,   4, &
+                            11,  11,   2,  11,  11,   0/)
+
+      cover(:,1) = (/100.,  85.,  85.,  85.,  50.,  40., &
+                             60.,  80.,  50.,  70.,  75.,  50., &
+                             95.,  75.,  37., 100., 100.,  80., &
+                             10.,  30.,  13.,  20.,  10., 100./)
+
+      plant(:,2) = (/ 0,   0,   0,   0,  14,   3, &
+                            13,   0,  14,   6,   0,   0, &
+                             0,   0,   7,   0,   0,   0, &
+                             0,  12,   3,  12,  12,   0/)
+
+      cover(:,2) = (/0.,  15.,  15.,  15.,  35.,  30., &
+                             20.,  20.,  30.,  30.,  25.,  50., &
+                              5.,  25.,  37.,   0.,   0.,  20., &
+                             90.,  30.,  13.,  20.,  10.,   0./)
+
+      plant(:,3) = (/ 0,   0,   0,   0,   0,   0, &
+                             0,   0,   0,   0,   0,   0, &
+                             0,   0,   0,   0,   0,   0, &
+                             0,   0,  10,   0,   0,   0/)
+
+      cover(:,3) = (/0.,   0.,   0.,   0.,  15.,  30., &
+                             20.,   0.,  20.,   0.,   0.,   0., &
+                              0.,   0.,  26.,   0.,   0.,   0., &
+                              0.,  40.,  24.,  60.,  80.,   0./)
+
+      plant(:,4) = (/ 0,   0,   0,   0,   0,   0, &
+                             0,   0,   0,   0,   0,   0, &
+                             0,   0,   0,   0,   0,   0, &
+                             0,   0,   0,   0,   0,   0/)
+
+      cover(:,4) = (/ 0.,   0.,   0.,   0.,   0.,   0., &
+                             0.,   0.,   0.,   0.,   0.,   0., &
+                             0.,   0.,   0.,   0.,   0.,   0., &
+                             0.,   0.,  50.,   0.,   0.,   0./)
+
+  else if (num_landcover_types== 20.or. num_landcover_types==21) then !MODIS
+        plant(:,1) = (/1, 4,  3, 7,  1, 9,  9, 9, 14, 14, &
+                       0, 15, 0, 15, 0, 11, 0, 2, 11, 11/)
+
+        cover(:,1) = (/75., 95.,50.,  75., 37., 80., 50., 80., 70.,60.,&
+                       100.,85.,100., 50., 100.,10., 100.,13., 20.,10./)
+
+        plant(:,2) = (/0, 0, 0, 0, 7, 0, 14, 0, 6, 13, &
+                       0, 0, 0, 14,0, 0, 0,  3, 12,12/)
+
+        cover(:,2) = (/25., 5., 50.,25.,37.,20.,30.,20.,30.,20.,&
+                       0.,  15.,0., 35.,0., 90.,0., 13.,20.,10./)
+
+        plant(:,3) = (/0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
+                       0, 0, 0, 0, 0, 0, 0,10, 0, 0/)
+
+        cover(:,3) = (/0.,0.,0., 0., 26.,0., 20., 0., 0., 20.,&
+                       0.,0.,0., 15.,0., 0., 0., 24., 60.,80./)
+
+        plant(:,4) = (/0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
+                       0, 0, 0, 0, 0, 0, 0, 0, 0, 0/)
+
+        cover(:,4) = (/0.,0.,0.,0.,0.,0.,0.,0., 0.,0.,&
+                       0.,0.,0.,0.,0.,0.,0.,50.,0.,0./)
+  else
+        write(6,*)'CLM works only for USGS (24) and MODIS(20) land use types,&
+                 but the current number of land use types is ',num_landcover_types
+        call endrun()
+  end if 
  end subroutine var_par
 
 end module clm_varcon
@@ -3752,7 +3816,7 @@ subroutine clmdrv(zgcmxy     ,forc_qxy   ,ps   ,forc_txy    ,tsxy  &
                    ,qdnxy      ,ivgtyp     ,isltyp      ,vegfra      ,albxy     &
                    ,znt        ,z0         ,tmn         ,xland       ,xice      &
                    ,emiss      ,snowc      ,qsfc        ,prec        ,maxpatch  &
-                   ,num_soil_layers        ,dt          ,dzs         ,nstep     &
+                   ,num_soil_layers        ,dt          ,xtime      ,dtwrf ,dzs &
                    ,smois      ,tslb       ,snow        ,canwat      ,chs       &
                    ,chs2                                                        &
                    ,sh2o       ,snowh      ,forc_uxy    ,forc_vxy    ,shdmin    &
@@ -3761,7 +3825,7 @@ subroutine clmdrv(zgcmxy     ,forc_qxy   ,ps   ,forc_txy    ,tsxy  &
                    ,ids,ide, jds,jde, kds,kde                    &
                    ,ims,ime, jms,jme, kms,kme                    &
                    ,its,ite, jts,jte, kts,kte                    &
-                   ,inest, sf_urban_physics,                               &
+                   ,inest, sf_urban_physics,nlcat,               &
 !Optional urban
                 CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF,   &
                 tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d,  & !H urban
@@ -3855,14 +3919,16 @@ subroutine clmdrv(zgcmxy     ,forc_qxy   ,ps   ,forc_txy    ,tsxy  &
                                     ims,ime, jms,jme, kms,kme,  &
                                     its,ite, jts,jte, kts,kte
 
-  integer,intent(in)  :: num_soil_layers,maxpatch,nstep,sf_urban_physics,&
+  integer,intent(in)  :: num_soil_layers,maxpatch,sf_urban_physics,&
                          ra_sw_physics,history_interval
   real,dimension(ims:ime,1:num_soil_layers,jms:jme ),intent(inout) ::&
                                                          smois, & ! total soil moisture
                                                          sh2o,  & ! new soil liquid
                                                          tslb     ! TSLB     STEMP
 
+   integer,intent(in)  :: nlcat
   real,intent(in) :: dt,dx
+  real,intent(in) :: xtime, dtwrf   !fchen
   real(r8) :: dtt
   real, dimension(1:num_soil_layers), intent(in)::dzs
 
@@ -3953,6 +4019,7 @@ subroutine clmdrv(zgcmxy     ,forc_qxy   ,ps   ,forc_txy    ,tsxy  &
 #endif
 !!!
 
+  integer  :: nstep   !fchen
   integer  :: i,j,m,inest,k
   real, dimension(ims:ime, kms:kme,jms:jme),intent(in) ::&
             forc_txy,forc_uxy,forc_vxy,forc_qxy,zgcmxy,ps
@@ -4223,7 +4290,7 @@ subroutine clmdrv(zgcmxy     ,forc_qxy   ,ps   ,forc_txy    ,tsxy  &
  real, dimension(4) :: lf_urb
  
 ! ----------------------------------------------------------------------
-   call clm_varpar_mod
+   call clm_varpar_mod(nlcat)
 
    call CLMDebug('Now in clmdrv')
 
@@ -4231,6 +4298,8 @@ subroutine clmdrv(zgcmxy     ,forc_qxy   ,ps   ,forc_txy    ,tsxy  &
 !    print*,'nlevsoi and nlevlak must be equal to num_soil_layers in CLM; Stop in module_sf_clm.F'
 !    call endrun() 
 !  end if
+  nstep = nint( (xtime*60. + dtwrf) / dt)
+  if( nstep .le. 1 ) nstep = 1
 
   dtt = dt
   
@@ -4319,7 +4388,10 @@ subroutine clmdrv(zgcmxy     ,forc_qxy   ,ps   ,forc_txy    ,tsxy  &
       forc_txy_buf   = forc_txy(i,1,j)
       forc_uxy_buf   = forc_uxy(i,1,j)
       forc_vxy_buf   = forc_vxy(i,1,j)
-      forc_qxy_buf   = forc_qxy(i,1,j)
+ 
+! convert mixing raitio to specific humdity -- Jiming Jin 7/10/2013
+      forc_qxy_buf   = forc_qxy(i,1,j)/(1.0+forc_qxy(i,1,j))
+
       zgcmxy_buf     = zgcmxy(i,1,j)
       prec_buf       = prec(i,j)/dtt ! mm/s
       flwdsxy_buf    = flwdsxy(i,j)
@@ -23634,7 +23706,7 @@ subroutine surfrd(organicxy,efisopxy,gtixy,ilx,jlx,iveg,isl,lndmsk)
     use clm_varpar                      !parameters
     !use clm_varsur                      !surface data  !BSINGH:02/04/2013: Commented out this use statement as it is repeated below
     use pftvarcon, only : noveg, crop  !vegetation type (PFT) 
-    use clm_varcon,only : sand,clay,soic,plant,cover,num_landcover_types
+    use clm_varcon,only : sand,clay,soic,plant,cover
     use clm_varsur      , only :gti, wtxy,vegxy,soic2d,sand3d,clay3d,organic3d,efisop2d &
                                  ,pctgla,pctlak,pctwet,pcturb     !surface data 
     use decompMod , only: get_proc_bounds
@@ -24070,7 +24142,8 @@ subroutine surfrd(organicxy,efisopxy,gtixy,ilx,jlx,iveg,isl,lndmsk)
     deallocate(pctcft_lunit)
     deallocate(pctpft_lunit)
     deallocate(pctpft)
-
+    deallocate(plant)
+    deallocate(cover)
 
   end subroutine surfrd
 
@@ -38701,7 +38774,8 @@ subroutine BalanceCheck(lbp, ubp, lbc, ubc, lbl, ubl, lbg, ubg)
 
     found = .false.
     do c = lbc, ubc
-       if (abs(errsoi_col(c)) > 1.0e-7_r8 ) then
+   !    if (abs(errsoi_col(c)) > 1.0e-7_r8 ) then
+       if (abs(errsoi_col(c)) > 1.0e-2_r8 ) then
           found = .true.
           indexc = c
        end if
@@ -39109,7 +39183,7 @@ subroutine BareGroundFluxes(lbp, ubp, num_nolakep, filter_nolakep)
 
        ! Soil evaporation resistance
        www     = (h2osoi_liq(c,1)/denh2o+h2osoi_ice(c,1)/denice)/dz(c,1)/watsat(c,1)
-       www     = min(max(www,0.0_r8),1._r8)
+    !mchen???   www     = min(max(www,0.0_r8),1._r8)
 
        !changed by K.Sakaguchi. Soilbeta is used for evaporation
        if (dqh(p) .gt. 0._r8) then   !dew  (beta is not applied, just like rsoil used to be)
@@ -57635,8 +57709,6 @@ subroutine initialize(snl    ,snowdp  ,dzclm     ,zclm        &
 
     call CLMDebug('Now in Initialize. Next call varsur_alloc.')
 
-        call get_proc_bounds(begc,endc)
-
 !-----------------------------------------------------------------------
            longxy(1) = xlon
            latixy(1) = xlat
@@ -58504,7 +58576,7 @@ subroutine clm(forc_txy        ,forc_uxy           ,forc_vxy      &
 
         
        alswvisdir = alswvisdir + clm3%g%l%c%p%pps%albd(p,1)*wtp(p)
-       alswnirdif = alswnirdif + clm3%g%l%c%p%pps%albi(p,1)*wtp(p)
+       alswvisdif = alswvisdif + clm3%g%l%c%p%pps%albi(p,1)*wtp(p)
        alswnirdir = alswnirdir + clm3%g%l%c%p%pps%albd(p,2)*wtp(p)  !1=visible, 2=nir
        alswnirdif = alswnirdif + clm3%g%l%c%p%pps%albi(p,2)*wtp(p) 
 
diff --git a/wrfv2_fire/phys/module_sf_fogdes.F b/wrfv2_fire/phys/module_sf_fogdes.F
new file mode 100644
index 00000000..a1691798
--- /dev/null
+++ b/wrfv2_fire/phys/module_sf_fogdes.F
@@ -0,0 +1,253 @@
+MODULE module_sf_fogdes
+
+  USE module_model_constants
+!JOE - add for consistent vdfg calc when grav_settling=1
+  USE module_bl_mynn, only: qcgmin, gno, gpw
+!JOE-end
+!-------------------------------------------------------------------
+  IMPLICIT NONE
+!-------------------------------------------------------------------
+   REAL, PARAMETER :: myu = 1.8e-5  ! air viscosity (m^2/s)
+
+CONTAINS
+
+  SUBROUTINE sf_fogdes(&
+               vdfg,fgdp,dfgdp,ivgtyp,lai,wspd,qc_curr,            &
+               dtbl,rho,dz8w,grav_settling,nlcat,                  &
+               ids,ide, jds,jde, kds,kde,                          &
+               ims,ime, jms,jme, kms,kme,                          &
+               its,ite, jts,jte, kts,kte                           &
+                                                                   )
+
+!  This module calculates the cloud water (fog) deposition onto the
+!  surface due to turbulent exchange and gravitational settling using 
+!  simple Fog Deposition EStimation (FogDES) scheme.
+
+! References:
+!
+!  Katata, G., Nagai, H., Wrzesinsky, T., Klemm, O., Eugster, W.,
+!    Burkard, R. (2008), Development of a land surface model 
+!    including cloud water deposition on vegetation, Journal of 
+!    Applied Meteorology and Climatology, 47, 2129-2146.
+!  Katata, G., Kajino, M., Hiraki, T., Aikawa, M., Kobayashi, T.,
+!    Nagai, H. (2011), A method for simple and accurate estimation
+!    of fog deposition in a mountain forest using a meteorological
+!    model. Journal of Geophysical Research 116, D20102.
+!
+!-------------------------------------------------------------------
+  IMPLICIT NONE
+!======================================================================
+! Definitions
+!-----------
+!-- vdfg          deposition velocity of fog (m/s)
+!-- fgdp          accumulated fog deposition (mm)
+!-- dfgdp         fog deposition rate in one timestep (mm)
+!-- ivgtyp        dominant vegetation category
+!-- lai           leaf area index
+!-- wspd          wind speed (m/s)
+!-- qc_curr       cloud water mixing ratio (kg/kg)
+!-- dqc           cloud water mixing ratio tendency (not used -
+!                 claculated in MYNN PBL scheme)
+!-- dtbl          timestep (s)
+!-- rho           density of the air (kg/m^3)
+!-- dp_fog        mean fog droplet diameter (m)
+!-- dz8w          dz between full levels (m)
+!-- ch            drag coefficient for heat in mynn (m/s)
+!-- grav_settling flag for fog deposition at the lowest atmos layer
+!           = 2   FogDES scheme
+!           = 1   use Duynkerke (1991) - same as in atmos (above k = 1)
+!           = 0   No gravitational settling
+!-- lad           leaf area density (m^2/m^3)
+!-- spcfct        factor of vegetation species for vdfg calculation
+!-- vegh          canopy height for vegetative surface (m)
+!-- lwc           cloud liquid water content (kg/m^3)
+!-- ims           start index for i in memory
+!-- ime           end index for i in memory
+!-- jms           start index for j in memory
+!-- jme           end index for j in memory
+!-- kms           start index for k in memory
+!-- kme           end index for k in memory
+!-- its           start index for i in tile
+!-- ite           end index for i in tile
+!-- jts           start index for j in tile
+!-- jte           end index for j in tile
+!-- kts           start index for k in tile
+!-- kte           end index for k in tile
+!******************************************************************
+!------------------------------------------------------------------
+
+   INTEGER, INTENT(IN)                       :: ims,ime,jms,jme,kms,kme &
+                                               ,its,ite,jts,jte,kts,kte &
+                                               ,ids,ide,jds,jde,kds,kde
+
+   INTEGER, INTENT(IN)                       :: grav_settling,nlcat
+
+   INTEGER,DIMENSION( ims:ime , jms:jme ),INTENT(INOUT)       :: ivgtyp
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                        &
+                                       INTENT(IN),OPTIONAL    :: qc_curr
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                        &
+                                       INTENT(IN)             :: rho
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                        &
+                                       INTENT(IN   )          :: dz8w
+
+   REAL, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT),OPTIONAL :: vdfg
+   REAL, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT),OPTIONAL :: fgdp
+   REAL, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT),OPTIONAL :: dfgdp
+   REAL, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT),OPTIONAL :: lai
+   REAL, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT)          :: wspd
+
+   REAL, INTENT(INOUT),OPTIONAL                               :: dtbl
+
+!JOE-added for Dyunkerke(1991) & Dyunkerke and Driedonks (1988)
+!  (grav_settling = 1).
+   REAL,parameter :: gpw2=0.66666666666667
+!JOE-end
+
+! Local variables
+   INTEGER :: i,j
+   REAL    :: lad, spcfct, vegh, ftmp1, ftmp2, dp_fog, lwc
+   CHARACTER (LEN=25) :: land_use_type, lu_fogdes
+
+!------------------------------------------------------------------
+
+   IF     ((nlcat .eq. 20).or.(nlcat .eq. 21)) THEN ! includes lake category
+     land_use_type = 'MODIS'
+   ELSEIF ((nlcat .eq. 24).or.(nlcat .eq. 28)) THEN ! includes lake category
+     land_use_type = 'USGS'
+   ELSE
+     PRINT *, 'Unknown landuse category (sf_fogdes.F): num_land_cat=',nlcat
+     STOP
+   END IF
+
+   DO j=jts,jte
+    DO i=its,ite
+       lwc = rho(i,kts,j)*qc_curr(i,kts,j)
+! *-- FogDES scheme --
+       IF ( grav_settling .eq. 2 ) THEN
+! *-- USGS categories --
+        IF (land_use_type .eq. 'USGS') THEN
+         IF(  (ivgtyp(i,j) .ge.  2 .and. ivgtyp(i,j) .le. 15)           &
+         .or. (ivgtyp(i,j) .ge. 17 .and. ivgtyp(i,j) .le. 18)           &
+         .or. (ivgtyp(i,j) .ge. 20 .and. ivgtyp(i,j) .le. 22) ) THEN
+          IF    ((ivgtyp(i,j).ge. 2 .and. ivgtyp(i,j).le. 5)            &
+            .or. (ivgtyp(i,j).eq. 7)                                    &
+            .or. (ivgtyp(i,j).eq. 17)                                   &
+            .or. (ivgtyp(i,j).eq. 20)                         ) THEN
+            lu_fogdes= 'CROP_GRASS'
+          ELSEIF((ivgtyp(i,j).eq. 6) .or. (ivgtyp(i,j).eq. 9) ) THEN
+            lu_fogdes= 'MIXED_CROP_GRASS_WOOD'
+          ELSEIF( ivgtyp(i,j).eq. 8                           ) THEN
+            lu_fogdes= 'SHRUB'
+          ELSEIF((ivgtyp(i,j).eq.11) .or. (ivgtyp(i,j).eq.13) ) THEN
+            lu_fogdes= 'BROAD_FOREST'
+          ELSEIF((ivgtyp(i,j).eq.15) .or. (ivgtyp(i,j).eq.22) ) THEN
+            lu_fogdes= 'MIXED_FOREST'
+          ELSE
+            lu_fogdes= 'CONIFER_FOREST_ETC'
+          ENDIF
+         ELSE
+            lu_fogdes= 'OTHERS'
+         ENDIF
+        ELSE
+! *-- MODIS categories --
+         IF(  (ivgtyp(i,j) .ge.  1 .and. ivgtyp(i,j) .le. 10)           &
+         .or. (ivgtyp(i,j) .eq. 12)                                     &
+         .or. (ivgtyp(i,j) .eq. 14)                                     &
+         .or. (ivgtyp(i,j) .ge. 18 .and. ivgtyp(i,j) .le. 19) ) THEN
+          IF    ((ivgtyp(i,j).eq.10) .or. (ivgtyp(i,j).eq.12) ) THEN
+            lu_fogdes= 'CROP_GRASS'
+          ELSEIF( ivgtyp(i,j).eq.14                           ) THEN
+            lu_fogdes= 'MIXED_CROP_GRASS_WOOD'
+          ELSEIF((ivgtyp(i,j).eq. 6) .or. (ivgtyp(i,j).eq. 7) ) THEN
+            lu_fogdes= 'SHRUB'
+          ELSEIF((ivgtyp(i,j).eq. 2) .or. (ivgtyp(i,j).eq. 4) ) THEN
+            lu_fogdes= 'BROAD_FOREST'
+          ELSEIF((ivgtyp(i,j).eq. 5) .or. (ivgtyp(i,j).eq.19) ) THEN
+            lu_fogdes= 'MIXED_FOREST'
+          ELSE
+            lu_fogdes= 'CONIFER_FOREST_ETC'
+          ENDIF
+         ELSE
+            lu_fogdes= 'OTHERS'
+         ENDIF
+        ENDIF
+
+!       PRINT *,grav_settling,'luse:',land_use_type,lu_fogdes
+
+!  Deposition velocity is computed using the vegetation parameters of LAI
+!  and canopy height. Only gravitational settling is considered for non-
+!  vegetated landuse categories.
+
+        IF    ( lu_fogdes .eq. 'OTHERS'                ) THEN
+         dp_fog= (17.03*lwc*1.e3 + 9.72)*1.e-6 ! Katata et al. (2008) JAMC
+         vdfg(i,j)= (rhowater-rho(i,kts,j))*dp_fog**2.0*g/(18.0*myu)
+        ELSE
+         lu_select: SELECT CASE(lu_fogdes)
+         CASE ('CROP_GRASS')
+           spcfct= 0.2170
+           vegh  = 3.0               !// scaled from 3m tree calc.
+         CASE ('MIXED_CROP_GRASS_WOOD')
+           spcfct= ( 1.0 + 0.2170 )/2.0
+           vegh  = (20.0 + 3.0    )/2.0
+         CASE ('SHRUB')
+           spcfct= 1.0
+           vegh  = 4.0
+         CASE ('BROAD_FOREST')
+           spcfct= 0.8255
+           vegh  = 20.0
+         CASE ('MIXED_FOREST')
+           spcfct= ( 1.0 + 0.8255 )/2.0
+           vegh  = 20.0
+         CASE ('CONIFER_FOREST_ETC')
+           spcfct= 1.0
+           vegh  = 20.0
+         END SELECT lu_select
+ 
+!   simple linear functions for deposition velocity (vdfg)
+!   for large leaf area density LAD (ftmp1) and small LAD (ftmp2).
+
+         lad  = lai(i,j)/vegh
+         ftmp1= 0.0164*lad**(-0.5000 )             !// LAD>0.1-0.2
+         ftmp2= 0.0095*lai(i,j)**3.0 - 0.05*lai(i,j)**2.0             &
+              + 0.0916*lai(i,j) + 0.0082               !// LAI<2 (LAD<0.08)
+         vdfg(i,j)= spcfct*MIN( ftmp1, ftmp2 )*wspd(i,j)
+        ENDIF
+
+!       PRINT *,'vdfg:',spcfct,vegh,dp_fog,vdfg(i,j)
+
+       ELSE IF (grav_settling .eq. 0 ) THEN
+          ! *-- No settling --
+          vdfg(i,j) = 0.0
+       ELSE IF (grav_settling .eq. 1 ) THEN
+          !JOE-use the same gravitation settling as in the free atmosphere 
+          !(taken from the MYNN PBL, Duynkerke (1991))
+          IF ((qc_curr(i,kts,j)/(1.+qc_curr(i,kts,j))) > qcgmin) THEN
+             vdfg(i,j)=gno*(qc_curr(i,kts,j)/(1.+qc_curr(i,kts,j)))**gpw2
+          ELSE
+             vdfg(i,j)=0.
+          ENDIF
+       ENDIF
+
+!   vdfg can advect moisture through the lowest half-sigma layer depth 
+!   in one time-step.
+       vdfg(i,j)=MIN( 0.5*dz8w(i,kts,j)/dtbl, vdfg(i,j) )
+
+       IF ( PRESENT( fgdp ) ) THEN
+         dfgdp(i,j)= vdfg(i,j)*lwc*dtbl
+         fgdp(i,j) = fgdp(i,j)+dfgdp(i,j)
+       ELSE
+         CALL wrf_error_fatal('Missing arguments for FGDP in sf_fogdes')
+       ENDIF
+
+       dfgdp(i,j)= MAX (dfgdp(i,j), 0.0)
+       fgdp(i,j) = MAX (fgdp(i,j),  0.0)
+
+     ENDDO
+   ENDDO
+
+  END SUBROUTINE sf_fogdes
+
+! ==================================================================
+
+END MODULE module_sf_fogdes
diff --git a/wrfv2_fire/phys/module_sf_gfdl.F b/wrfv2_fire/phys/module_sf_gfdl.F
index aa2bb5a4..718bdaef 100755
--- a/wrfv2_fire/phys/module_sf_gfdl.F
+++ b/wrfv2_fire/phys/module_sf_gfdl.F
@@ -9,7 +9,11 @@ MODULE module_sf_gfdl
 !-------------------------------------------------------------------
    SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
                      CP,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2, CPM,    &
-                     DT, SMOIS,num_soil_layers,ISLTYP,ZNT,UST,PSIM,PSIH,  &
+                     DT, SMOIS,num_soil_layers,ISLTYP,ZNT,      &
+#if (HWRF==1)
+                     MZNT,                                      & 
+#endif
+                     UST,PSIM,PSIH,                             &   
                      XLAND,HFX,QFX,TAUX,TAUY,LH,GSW,GLW,TSK,FLHC,FLQC,    & ! gopal's doing for Ocean coupling
                      QGH,QSFC,U10,V10,                          &
                      GZ1OZ0,WSPD,BR,ISFFLX,                     &
@@ -35,7 +39,8 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
 !-- R           gas constant for dry air (J/kg/K)
 !-- XLV         latent heat of vaporization for water (J/kg)
 !-- PSFC	surface pressure (Pa)
-!-- ZNT		roughness length (m)
+!-- ZNT		thermal roughness length (m)
+!-- MZNT        momentum roughness length (m)
 !-- MAVAIL        surface moisture availability (between 0 and 1)
 !-- UST		u* in similarity theory (m/s)
 !-- PSIM        similarity stability function for momentum
@@ -130,6 +135,9 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
                                         QSFC,                           &
                                         UST,                            &
                                         ZNT,                            &
+#if (HWRF==1)
+                                        MZNT,                           &   !KWON momentum zo
+#endif
                                         WSPD,                           &
                                         TAUX,                           & ! gopal's doing for Ocean coupling
                                         TAUY
@@ -202,6 +210,7 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
                                         pkmax,                          &
                                         tstrc,                          &
                                         zoc,                            &
+                                        mzoc,                           &  !ADDED BY KWON FOR momentum Zo
                                         wetc,                           &
                                         slwdc,                          &
                                         rib,                            &
@@ -317,7 +326,7 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
 !                    pkmax(i),pspc(i),wetc(i),tjloc(i),zoc(i),tstrc(i)
 !     enddo
 
-     CALL MFLUX2(  fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,tstrc,   &
+     CALL MFLUX2(  fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,   &    !mzoc for momentum Zo KWON
                    pspc,pkmax,wetc,slwdc,tjloc,                &
                    upc,vpc,tpc,rpc,dt,J,wind10,xxfh2,ntsflg,SFENTH,   &
                    ids,ide, jds,jde, kds,kde,                  &
@@ -375,6 +384,9 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
 
 
         znt(i,j)= 0.01*abs(zoc(i))
+#if (HWRF==1)
+        mznt(i,j)= 0.01*abs(mzoc(i))
+#endif
         wspd(i,j) = SQRT(upc(kts,i)*upc(kts,i) + vpc(kts,i)*vpc(kts,i))
         wspd(i,j) = amax1(wspd(i,j)    ,100.)/100.
         u10m(i) = u1(i)*(wind10(i)/wspd(i,j))/100.
@@ -509,7 +521,7 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
    END SUBROUTINE SF_GFDL
 
 !-------------------------------------------------------------------
-       SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,tstrc,       &
+       SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mzoc KWON
                           pspc,pkmax,wetc,slwdc,tjloc,                    &
                           upc,vpc,tpc,rpc,dt,jfix,wind10,xxfh2,ntsflg,sfenth,    &
                           ids,ide, jds,jde, kds,kde,                      &
@@ -567,7 +579,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,tstrc,       &
       real, intent (out), dimension (ims :ime ) :: xxfh2
       real, intent (out), dimension (ims :ime ) :: wind10
 
-      real, intent ( inout), dimension (ims :ime ) :: zoc
+      real, intent ( inout), dimension (ims :ime ) :: zoc,mzoc    !KWON
       real, intent ( inout), dimension (ims :ime ) :: tstrc
 
       real, intent ( in)                        :: dt
@@ -860,6 +872,8 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,tstrc,       &
 !------------------------------------------------------------------------
 !     where necessary modify zo values over ocean.
 !------------------------------------------------------------------------
+!
+      mzoc(i) = zoc(i)                !FOR SAVE MOMENTUM Zo
 
       enddo
 
diff --git a/wrfv2_fire/phys/module_sf_lake.F b/wrfv2_fire/phys/module_sf_lake.F
new file mode 100644
index 00000000..ae49ac79
--- /dev/null
+++ b/wrfv2_fire/phys/module_sf_lake.F
@@ -0,0 +1,5400 @@
+MODULE module_sf_lake
+
+! The lake scheme was retrieved from the Community Land Model version 4.5 
+! (Oleson et al. 2013) with some modifications by Gu et al. (2013). It is a 
+! one-dimensional mass and energy balance scheme with 20-25 model layers, 
+! including up to 5 snow layers on the lake ice, 10 water layers, and 10 soil 
+! layers on the lake bottom. The lake scheme is used with actual lake points and 
+! lake depth derived from the WPS, and it also can be used with user defined 
+! lake points and lake depth in WRF (lake_min_elev and lakedepth_default). 
+! The lake scheme is independent of a land surface scheme and therefore 
+! can be used with any land surface scheme embedded in WRF. The lake scheme 
+! developments and evaluations were included in Subin et al. (2012) and Gu et al. (2013) 
+!
+!   Subin et al. 2012: Improved lake model for climate simulations, J. Adv. Model. 
+!   Earth Syst., 4, M02001. DOI:10.1029/2011MS000072; 
+!   Gu et al. 2013: Calibration and validation of lake surface temperature simulations 
+!   with the coupled WRF-Lake model. Climatic Change, 1-13, 10.1007/s10584-013-0978-y. 
+
+ USE module_wrf_error
+ USE module_model_constants, ONLY : rcp
+
+    implicit none 
+    integer, parameter ::      r8 = selected_real_kind(12) 
+
+    integer, parameter :: nlevsoil     =  10   ! number of soil layers
+    integer, parameter :: nlevlake     =  10   ! number of lake layers
+    integer, parameter :: nlevsnow     =   5   ! maximum number of snow layers
+
+    integer,parameter  ::     lbp = 1                        ! pft-index bounds
+    integer,parameter  ::     ubp = 1
+    integer,parameter  ::     lbc = 1                        ! column-index bounds
+    integer,parameter  ::     ubc = 1
+    integer,parameter  ::     num_shlakec       = 1          ! number of columns in lake filter
+    integer,parameter  ::     filter_shlakec(1) = 1          ! lake filter (columns)
+    integer,parameter  ::     num_shlakep       = 1          ! number of pfts in lake filter
+    integer,parameter  ::     filter_shlakep(1) = 1          ! lake filter (pfts)
+    integer,parameter  ::     pcolumn(1)        = 1  
+    integer,parameter  ::     pgridcell(1)      = 1  
+    integer,parameter  ::     cgridcell(1)      = 1          ! gridcell index of column
+    integer,parameter  ::     clandunit(1)      = 1          ! landunit index of column
+  
+    integer,parameter  ::     begg = 1
+    integer,parameter  ::     endg = 1
+    integer,parameter  ::     begl = 1
+    integer,parameter  ::     endl = 1
+    integer,parameter  ::     begc = 1
+    integer,parameter  ::     endc = 1
+    integer,parameter  ::     begp = 1
+    integer,parameter  ::     endp = 1
+
+    integer,parameter  ::     column    =1
+    logical,parameter  ::     lakpoi(1) = .true.
+   
+
+
+
+!Initialize physical constants:
+    real(r8), parameter :: vkc    = 0.4_r8       !von Karman constant [-]
+    real(r8), parameter :: pie    = 3.141592653589793_r8 ! pi
+    real(r8), parameter :: grav   = 9.80616_r8   !gravity constant [m/s2]
+    real(r8), parameter :: sb     = 5.67e-8_r8   !stefan-boltzmann constant  [W/m2/K4]
+    real(r8), parameter :: tfrz   = 273.16_r8    !freezing temperature [K]
+    real(r8), parameter :: denh2o = 1.000e3_r8   !density of liquid water [kg/m3]
+    real(r8), parameter :: denice = 0.917e3_r8   !density of ice [kg/m3]
+    real(r8), parameter :: cpice  = 2.11727e3_r8 !Specific heat of ice [J/kg-K]
+    real(r8), parameter :: cpliq  = 4.188e3_r8   !Specific heat of water [J/kg-K]
+    real(r8), parameter :: hfus   = 3.337e5_r8   !Latent heat of fusion for ice [J/kg]
+    real(r8), parameter :: hvap   = 2.501e6_r8   !Latent heat of evap for water [J/kg]
+    real(r8), parameter :: hsub   = 2.501e6_r8+3.337e5_r8 !Latent heat of sublimation    [J/kg]
+    real(r8), parameter :: rair   = 287.0423_r8  !gas constant for dry air [J/kg/K]
+    real(r8), parameter :: cpair  = 1.00464e3_r8 !specific heat of dry air [J/kg/K]
+    real(r8), parameter :: tcrit  = 2.5          !critical temperature to determine rain or snow
+    real(r8), parameter :: tkwat  = 0.6          !thermal conductivity of water [W/m/k]
+    real(r8), parameter :: tkice  = 2.290        !thermal conductivity of ice   [W/m/k]
+    real(r8), parameter :: tkairc = 0.023        !thermal conductivity of air   [W/m/k]
+    real(r8), parameter :: bdsno = 250.            !bulk density snow (kg/m**3)
+    
+    real(r8), public, parameter :: spval = 1.e36  !special value for missing data (ocean)
+
+    real, parameter  ::     depth_c = 50.          ! below the level t_lake3d will be 277.0  !mchen
+
+    
+   ! These are tunable constants
+    real(r8), parameter :: wimp   = 0.05    !Water impremeable if porosity less than wimp
+    real(r8), parameter :: ssi    = 0.033   !Irreducible water saturation of snow
+    real(r8), parameter :: cnfac  = 0.5     !Crank Nicholson factor between 0 and 1
+
+
+   ! Initialize water type constants
+    integer,parameter :: istsoil = 1  !soil         "water" type
+    integer, private  :: i  ! loop index 
+    real(r8) :: dtime                                    ! land model time step (sec)
+
+    real(r8) :: zlak(1:nlevlake)     !lake z  (layers)
+    real(r8) :: dzlak(1:nlevlake)    !lake dz (thickness)
+    real(r8) :: zsoi(1:nlevsoil)     !soil z  (layers)
+    real(r8) :: dzsoi(1:nlevsoil)    !soil dz (thickness)
+    real(r8) :: zisoi(0:nlevsoil)    !soil zi (interfaces)  
+
+
+    real(r8) :: sand(19)                           ! percent sand
+    real(r8) :: clay(19)                           ! percent clay
+
+    data(sand(i), i=1,19)/92.,80.,66.,20.,5.,43.,60.,&
+      10.,32.,51., 6.,22.,39.7,0.,100.,54.,17.,100.,92./
+
+    data(clay(i), i=1,19)/ 3., 5.,10.,15.,5.,18.,27.,&
+      33.,33.,41.,47.,58.,14.7,0., 0., 8.5,54.,  0., 3./
+
+
+  !  real(r8) :: dtime                  ! land model time step (sec)
+    real(r8) :: watsat(1,nlevsoil)      ! volumetric soil water at saturation (porosity)
+    real(r8) :: tksatu(1,nlevsoil)      ! thermal conductivity, saturated soil [W/m-K]
+    real(r8) :: tkmg(1,nlevsoil)        ! thermal conductivity, soil minerals  [W/m-K]
+    real(r8) :: tkdry(1,nlevsoil)       ! thermal conductivity, dry soil (W/m/Kelvin)
+    real(r8) :: csol(1,nlevsoil)        ! heat capacity, soil solids (J/m**3/Kelvin)
+    CONTAINS
+ 
+
+    SUBROUTINE Lake( t_phy        ,p8w            ,dz8w         ,qvcurr          ,&  !i
+                     u_phy        ,v_phy          , glw         ,emiss           ,&
+                     rainbl       ,dtbl           ,swdown       ,albedo          ,&
+                     xlat_urb2d   ,z_lake3d       ,dz_lake3d    ,lakedepth2d     ,&
+                     watsat3d     ,csol3d         ,tkmg3d       ,tkdry3d         ,&
+                     tksatu3d     ,ivgtyp         ,ht           ,xland           ,& 
+                     iswater, xice, xice_threshold, lake_min_elev                ,&
+                     ids          ,ide            ,jds          ,jde             ,&
+                     kds          ,kde            ,ims          ,ime             ,&
+                     jms          ,jme            ,kms          ,kme             ,&
+                     its          ,ite            ,jts          ,jte             ,&
+                     kts          ,kte                                           ,&
+                     h2osno2d     ,snowdp2d       ,snl2d        ,z3d             ,&  !h
+                     dz3d         ,zi3d           ,h2osoi_vol3d ,h2osoi_liq3d    ,&
+                     h2osoi_ice3d ,t_grnd2d       ,t_soisno3d   ,t_lake3d        ,&
+                     savedtke12d  ,lake_icefrac3d                                ,& 
+#if (EM_CORE==1)
+             !        lakemask     ,lakeflag                                      ,&
+                     lakemask                                          ,&
+#endif
+                     hfx          ,lh             ,grdflx       ,tsk             ,&  !o
+                     qfx          ,t2             ,th2          ,q2 )
+
+!==============================================================================
+! This subroutine was first edited by Hongping Gu and Jiming Jin for coupling
+! 07/20/2010
+!==============================================================================
+    IMPLICIT NONE
+    
+!in:
+    
+    INTEGER,  INTENT(IN   )   ::     ids,ide, jds,jde, kds,kde,  &
+                                     ims,ime, jms,jme, kms,kme,  &
+                                     its,ite, jts,jte, kts,kte
+    INTEGER , INTENT (IN) :: iswater
+    REAL,     INTENT(IN)  :: xice_threshold
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   XICE
+#if (EM_CORE==1)
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   LAKEMASK
+ !   INTEGER, INTENT(IN)::   LAKEFLAG
+#endif
+    
+    REAL,           DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN)  :: t_phy  
+    REAL,           DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN)  :: p8w    
+    REAL,           DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN)  :: dz8w
+    REAL,           DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN)  :: qvcurr
+    REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN)  :: U_PHY
+    REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN)  :: V_PHY
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(IN)  :: glw
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(IN)  :: emiss
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(IN)  :: rainbl
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(IN)  :: swdown
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(INOUT)  :: albedo
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(IN)  :: XLAND
+    REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme )         ,INTENT(IN)  :: XLAT_URB2D
+    INTEGER,        DIMENSION( ims:ime, jms:jme )         ,INTENT(INOUT)  :: IVGTYP
+    REAL,                                                  INTENT(IN)  :: dtbl
+    
+    REAL,           DIMENSION( ims:ime,1:nlevlake,jms:jme ),INTENT(IN)  :: z_lake3d
+    REAL,           DIMENSION( ims:ime,1:nlevlake,jms:jme ),INTENT(IN)  :: dz_lake3d
+    REAL,           DIMENSION( ims:ime,1:nlevsoil,jms:jme ),INTENT(IN)  :: watsat3d
+    REAL,           DIMENSION( ims:ime,1:nlevsoil,jms:jme ),INTENT(IN)  :: csol3d
+    REAL,           DIMENSION( ims:ime,1:nlevsoil,jms:jme ),INTENT(IN)  :: tkmg3d
+    REAL,           DIMENSION( ims:ime,1:nlevsoil,jms:jme ),INTENT(IN)  :: tkdry3d
+    REAL,           DIMENSION( ims:ime,1:nlevsoil,jms:jme ),INTENT(IN)  :: tksatu3d
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(IN)  :: lakedepth2d    
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(IN)  :: ht
+    REAL                                                  ,INTENT(IN)  :: lake_min_elev
+
+!out:
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(OUT) :: HFX
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(OUT) :: LH
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(OUT) :: GRDFLX
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(OUT) :: TSK
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(OUT) :: QFX   
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(OUT) :: T2
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(OUT) :: TH2
+    REAL,           DIMENSION( ims:ime, jms:jme )         ,INTENT(OUT) :: Q2
+
+!in&out:
+
+    real,           dimension(ims:ime,jms:jme )                ,intent(inout)  :: savedtke12d 
+    real,           dimension(ims:ime,jms:jme )                ,intent(inout)  :: snowdp2d,       &    
+                                                                                  h2osno2d,       &    
+                                                                                  snl2d,          &    
+                                                                                  t_grnd2d
+    
+    real,    dimension( ims:ime,1:nlevlake, jms:jme )           ,INTENT(inout)  :: t_lake3d,       &    
+                                                                                  lake_icefrac3d
+    real,    dimension( ims:ime,-nlevsnow+1:nlevsoil, jms:jme )  ,INTENT(inout)  :: t_soisno3d,     &    
+                                                                                  h2osoi_ice3d,   &    
+                                                                                  h2osoi_liq3d,   &    
+                                                                                  h2osoi_vol3d,   &    
+                                                                                  z3d,            &    
+                                                                                  dz3d 
+    real,    dimension( ims:ime,-nlevsnow+0:nlevsoil, jms:jme )  ,INTENT(inout)  :: zi3d    
+       
+
+!local variable:
+
+    REAL     :: SFCTMP,PBOT,PSFC,ZLVL,Q2K,EMISSI,LWDN,PRCP,SOLDN,SOLNET
+    INTEGER  :: C,i,j,k
+
+
+      !tempory varibles in:
+      real(r8)  :: forc_t(1)          ! atmospheric temperature (Kelvin)
+      real(r8)  :: forc_pbot(1)       ! atm bottom level pressure (Pa) 
+      real(r8)  :: forc_psrf(1)       ! atmospheric surface pressure (Pa)
+      real(r8)  :: forc_hgt(1)        ! atmospheric reference height (m)
+      real(r8)  :: forc_hgt_q(1)      ! observational height of humidity [m]
+      real(r8)  :: forc_hgt_t(1)      ! observational height of temperature [m]
+      real(r8)  :: forc_hgt_u(1)      ! observational height of wind [m]
+      real(r8)  :: forc_q(1)          ! atmospheric specific humidity (kg/kg)
+      real(r8)  :: forc_u(1)          ! atmospheric wind speed in east direction (m/s)
+      real(r8)  :: forc_v(1)          ! atmospheric wind speed in north direction (m/s)
+     ! real(r8)  :: forc_rho(1)        ! density (kg/m**3)
+      real(r8)  :: forc_lwrad(1)      ! downward infrared (longwave) radiation (W/m**2)
+      real(r8)  :: prec(1)               ! snow or rain rate [mm/s]
+      real(r8)  :: sabg(1)            ! solar radiation absorbed by ground (W/m**2)
+      real(r8)  :: lat(1)             ! latitude (radians)
+      real(r8)  :: z_lake(1,nlevlake)  ! layer depth for lake (m)
+      real(r8)  :: dz_lake(1,nlevlake)                  ! layer thickness for lake (m)
+
+      real(r8)  :: lakedepth(1)       ! column lake depth (m)
+      logical   :: do_capsnow(1)     ! true => do snow capping
+
+      !in&out
+      real(r8)  :: h2osoi_vol(1,-nlevsnow+1:nlevsoil)  ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3]
+      real(r8)  :: t_grnd(1)          ! ground temperature (Kelvin)
+      real(r8)  :: h2osno(1)          ! snow water (mm H2O)
+      real(r8)  :: snowdp(1)          ! snow height (m)
+      real(r8)  :: z(1,-nlevsnow+1:nlevsoil)             ! layer depth for snow & soil (m)
+      real(r8)  :: dz(1,-nlevsnow+1:nlevsoil)            ! layer thickness for soil or snow (m)
+      real(r8)  :: t_soisno(1,-nlevsnow+1:nlevsoil)      ! soil (or snow) temperature (Kelvin)
+      real(r8)  :: t_lake(1,nlevlake)                   ! lake temperature (Kelvin)
+      integer   :: snl(1)                              ! number of snow layers
+      real(r8)  :: h2osoi_liq(1,-nlevsnow+1:nlevsoil)    ! liquid water (kg/m2)
+      real(r8)  :: h2osoi_ice(1,-nlevsnow+1:nlevsoil)    ! ice lens (kg/m2)
+      real(r8)  :: savedtke1(1)       ! top level eddy conductivity from previous timestep (W/m.K)
+      real(r8)  :: zi(1,-nlevsnow+0:nlevsoil)            ! interface level below a "z" level (m)
+      real(r8)  :: lake_icefrac(1,nlevlake)  ! mass fraction of lake layer that is frozen
+
+
+      !out:
+      real(r8)  :: eflx_gnet(1)       !net heat flux into ground (W/m**2)
+      real(r8)  :: eflx_lwrad_net(1)  ! net infrared (longwave) rad (W/m**2) [+ = to atm]
+      real(r8)  :: eflx_sh_tot(1)     ! total sensible heat flux (W/m**2) [+ to atm]
+      real(r8)  :: eflx_lh_tot(1)     ! total latent heat flux (W/m8*2)  [+ to atm]
+      real(r8)  :: t_ref2m(1)         ! 2 m height surface air temperature (Kelvin)
+      real(r8)  :: q_ref2m(1)         ! 2 m height surface specific humidity (kg/kg)
+      real(r8)  :: taux(1)            ! wind (shear) stress: e-w (kg/m/s**2)
+      real(r8)  :: tauy(1)            ! wind (shear) stress: n-s (kg/m/s**2)
+      real(r8)  :: ram1(1)            ! aerodynamical resistance (s/m)
+                                               ! for calculation of decay of eddy diffusivity with depth
+                                               ! Change the type variable to pass back to WRF.
+      real(r8)  :: z0mg(1)            ! roughness length over ground, momentum (m(
+
+
+      dtime = dtbl
+
+        DO J = jts,jte
+        DO I = its,ite
+
+           SFCTMP  = t_phy(i,1,j)
+           PBOT    = p8w(i,2,j)
+           PSFC    = P8w(i,1,j) 
+           ZLVL    = 0.5 * dz8w(i,1,j) 
+           Q2K     = qvcurr(i,1,j)/(1.0 + qvcurr(i,1,j))
+           EMISSI  = EMISS(I,J) 
+           LWDN    = GLW(I,J)*EMISSI 
+           PRCP    = RAINBL(i,j)/dtbl
+           SOLDN   = SWDOWN(I,J)                        ! SOLDN is total incoming solar
+           SOLNET  = SOLDN*(1.-ALBEDO(I,J))             ! use mid-day albedo to determine net downward solar
+                                                        ! (no solar zenith angle correction) 
+!        IF (XLAND(I,J).GT.1.5) THEN    
+
+       !  if ( xice(i,j).gt.xice_threshold) then
+       !   ivgtyp(i,j) = iswater
+       !   xland(i,j) = 2.
+       !   lake_icefrac3d(i,1,j) = xice(i,j)
+       !   endif
+
+#if (EM_CORE==1)
+        if (lakemask(i,j).eq.1) THEN
+#else
+        if (ivgtyp(i,j)==iswater.and.ht(i,j)>= lake_min_elev ) THEN
+#endif
+    
+           do c = 1,column
+     
+            forc_t(c)          = SFCTMP           ! [K]
+            forc_pbot(c)       = PBOT 
+            forc_psrf(c)       = PSFC
+            forc_hgt(c)        = ZLVL             ! [m]
+            forc_hgt_q(c)      = ZLVL             ! [m]
+            forc_hgt_t(c)      = ZLVL             ! [m]
+            forc_hgt_u(c)      = ZLVL             ! [m]
+            forc_q(c)          = Q2K              ! [kg/kg]
+            forc_u(c)          = U_PHY(I,1,J)
+            forc_v(c)          = V_PHY(I,1,J)
+           ! forc_rho(c)        = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m] 
+            forc_lwrad(c)      = LWDN             ! [W/m/m]
+            prec(c)            = PRCP             ! [mm/s]
+            sabg(c)            = SOLNET
+            lat(c)             = XLAT_URB2D(I,J)*pie/180  ! [radian] 
+            do_capsnow(c)      = .false.
+
+            lakedepth(c)           = lakedepth2d(i,j)
+            savedtke1(c)           = savedtke12d(i,j)
+            snowdp(c)              = snowdp2d(i,j)
+            h2osno(c)              = h2osno2d(i,j)
+            snl(c)                 = snl2d(i,j)
+            t_grnd(c)              = t_grnd2d(i,j)
+            do k = 1,nlevlake
+               t_lake(c,k)        = t_lake3d(i,k,j)
+               lake_icefrac(c,k)  = lake_icefrac3d(i,k,j)
+               z_lake(c,k)        = z_lake3d(i,k,j)
+               dz_lake(c,k)       = dz_lake3d(i,k,j)
+            enddo
+            do k = -nlevsnow+1,nlevsoil
+               t_soisno(c,k)      = t_soisno3d(i,k,j)
+	       h2osoi_ice(c,k)    = h2osoi_ice3d(i,k,j)
+               h2osoi_liq(c,k)    = h2osoi_liq3d(i,k,j)
+               h2osoi_vol(c,k)    = h2osoi_vol3d(i,k,j)
+               z(c,k)             = z3d(i,k,j)
+               dz(c,k)            = dz3d(i,k,j)
+            enddo   
+            do k = -nlevsnow+0,nlevsoil
+               zi(c,k)            = zi3d(i,k,j)
+            enddo
+            do k = 1,nlevsoil
+               watsat(c,k)        = watsat3d(i,k,j)
+               csol(c,k)          = csol3d(i,k,j)
+               tkmg(c,k)          = tkmg3d(i,k,j)
+               tkdry(c,k)         = tkdry3d(i,k,j)
+               tksatu(c,k)        = tksatu3d(i,k,j)
+            enddo
+            
+          enddo
+            CALL LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q,   & !I  
+                          forc_hgt_t,forc_hgt_u,forc_q, forc_u,         &
+                          forc_v,forc_lwrad,prec, sabg,lat,             &
+                          z_lake,dz_lake,lakedepth,do_capsnow,          &
+                          h2osno,snowdp,snl,z,dz,zi,                    & !H
+                          h2osoi_vol,h2osoi_liq,h2osoi_ice,             &
+                          t_grnd,t_soisno,t_lake,                       &
+                          savedtke1,lake_icefrac,                       &
+                          eflx_lwrad_net,eflx_gnet,                     & !O 
+                          eflx_sh_tot,eflx_lh_tot,                      &
+                          t_ref2m,q_ref2m,                              &
+                          taux,tauy,ram1,z0mg)
+
+
+           do c = 1,column
+            HFX(I,J)          = eflx_sh_tot(c)            ![W/m/m]
+            LH(I,J)           = eflx_lh_tot(c)            !W/m/m]
+            GRDFLX(I,J)       = eflx_gnet(c)              !W/m/m]
+            TSK(I,J)          = t_grnd(c)                 ![K]
+            T2(I,J)           = t_ref2m(c)
+            TH2(I,J)          = T2(I,J)*(1.E5/PSFC)**RCP
+            Q2(I,J)           = q_ref2m(c) 
+            albedo(i,j)       = ( 0.6 * lake_icefrac(c,1) ) + ( (1.0-lake_icefrac(c,1)) * 0.08)  
+
+            if( tsk(i,j) >= tfrz ) then
+                qfx(i,j)      = eflx_lh_tot(c)/hvap
+            else
+                qfx(i,j)      = eflx_lh_tot(c)/hsub       ! heat flux (W/m^2)=>mass flux(kg/(sm^2))
+            endif
+           enddo
+
+! Renew Lake State Varialbes:(14)
+           do c = 1,column
+
+            savedtke12d(i,j)         = savedtke1(c)
+            snowdp2d(i,j)            = snowdp(c)
+            h2osno2d(i,j)            = h2osno(c)
+	    snl2d(i,j)               = snl(c)
+            t_grnd2d(i,j)            = t_grnd(c)
+            do k = 1,nlevlake
+               t_lake3d(i,k,j)       = t_lake(c,k)
+	       lake_icefrac3d(i,k,j) = lake_icefrac(c,k)
+            enddo
+	    do k = -nlevsnow+1,nlevsoil
+	       z3d(i,k,j)            = z(c,k)
+	       dz3d(i,k,j)           = dz(c,k) 
+	       t_soisno3d(i,k,j)     = t_soisno(c,k)
+	       h2osoi_liq3d(i,k,j)   = h2osoi_liq(c,k)
+	       h2osoi_ice3d(i,k,j)   = h2osoi_ice(c,k)
+               h2osoi_vol3d(i,k,j)   = h2osoi_vol(c,k)
+	   enddo
+           do k = -nlevsnow+0,nlevsoil
+               zi3d(i,k,j)           = zi(c,k)
+           enddo
+        
+         enddo
+
+        endif
+!        ENDIF    ! if xland = 2
+        ENDDO
+        ENDDO
+
+    END SUBROUTINE Lake
+
+
+    SUBROUTINE LakeMain(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q,     & !I  
+                          forc_hgt_t,forc_hgt_u,forc_q, forc_u,         &   
+                          forc_v,forc_lwrad,prec, sabg,lat,             &   
+                          z_lake,dz_lake,lakedepth,do_capsnow,          &
+                          h2osno,snowdp,snl,z,dz,zi,                    & !H
+                          h2osoi_vol,h2osoi_liq,h2osoi_ice,             &
+                          t_grnd,t_soisno,t_lake,                       &  
+                          savedtke1,lake_icefrac,                       &
+                          eflx_lwrad_net,eflx_gnet,                     & !O 
+                          eflx_sh_tot,eflx_lh_tot,                      &
+                          t_ref2m,q_ref2m,                              &
+                          taux,tauy,ram1,z0mg)
+    implicit none
+!in: 
+
+    real(r8),intent(in) :: forc_t(1)          ! atmospheric temperature (Kelvin)
+    real(r8),intent(in) :: forc_pbot(1)       ! atm bottom level pressure (Pa) 
+    real(r8),intent(in) :: forc_psrf(1)       ! atmospheric surface pressure (Pa)
+    real(r8),intent(in) :: forc_hgt(1)        ! atmospheric reference height (m)
+    real(r8),intent(in) :: forc_hgt_q(1)      ! observational height of humidity [m]
+    real(r8),intent(in) :: forc_hgt_t(1)      ! observational height of temperature [m]
+    real(r8),intent(in) :: forc_hgt_u(1)      ! observational height of wind [m]
+    real(r8),intent(in) :: forc_q(1)          ! atmospheric specific humidity (kg/kg)
+    real(r8),intent(in) :: forc_u(1)          ! atmospheric wind speed in east direction (m/s)
+    real(r8),intent(in) :: forc_v(1)          ! atmospheric wind speed in north direction (m/s)
+   ! real(r8),intent(in) :: forc_rho(1)        ! density (kg/m**3)
+    real(r8),intent(in) :: forc_lwrad(1)      ! downward infrared (longwave) radiation (W/m**2)
+    real(r8),intent(in) :: prec(1)               ! snow or rain rate [mm/s]
+    real(r8),intent(in) :: sabg(1)            ! solar radiation absorbed by ground (W/m**2)
+    real(r8),intent(in) :: lat(1)             ! latitude (radians)
+    real(r8),intent(in) :: z_lake(1,nlevlake)  ! layer depth for lake (m)
+    real(r8),intent(in) :: dz_lake(1,nlevlake)                  ! layer thickness for lake (m)
+
+    real(r8), intent(in) :: lakedepth(1)       ! column lake depth (m)
+    !!!!!!!!!!!!!!!!tep(in),hydro(in)   
+   ! real(r8), intent(in) :: watsat(1,1:nlevsoil)      ! volumetric soil water at saturation (porosity)
+    !!!!!!!!!!!!!!!!hydro
+    logical , intent(in) :: do_capsnow(1)     ! true => do snow capping
+   
+
+
+!in&out
+    real(r8),intent(inout) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil)  ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3]
+    real(r8),intent(inout) :: t_grnd(1)          ! ground temperature (Kelvin)
+    real(r8),intent(inout) :: h2osno(1)          ! snow water (mm H2O)
+    real(r8),intent(inout) :: snowdp(1)          ! snow height (m)
+    real(r8),intent(inout) :: z(1,-nlevsnow+1:nlevsoil)             ! layer depth for snow & soil (m)
+    real(r8),intent(inout) :: dz(1,-nlevsnow+1:nlevsoil)            ! layer thickness for soil or snow (m)
+    real(r8),intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil)      ! soil (or snow) temperature (Kelvin)
+    real(r8),intent(inout) :: t_lake(1,nlevlake)                   ! lake temperature (Kelvin)
+    integer ,intent(inout) :: snl(1)                              ! number of snow layers
+    real(r8),intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil)    ! liquid water (kg/m2)
+    real(r8),intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil)    ! ice lens (kg/m2)
+    real(r8),intent(inout) :: savedtke1(1)       ! top level eddy conductivity from previous timestep (W/m.K)
+    real(r8),intent(inout) :: zi(1,-nlevsnow+0:nlevsoil)            ! interface level below a "z" level (m)
+    real(r8),intent(inout) :: lake_icefrac(1,nlevlake)  ! mass fraction of lake layer that is frozen
+
+
+!out:
+    real(r8),intent(out) :: eflx_gnet(1)       !net heat flux into ground (W/m**2)
+    real(r8),intent(out) :: eflx_lwrad_net(1)  ! net infrared (longwave) rad (W/m**2) [+ = to atm]
+    real(r8),intent(out) :: eflx_sh_tot(1)     ! total sensible heat flux (W/m**2) [+ to atm]
+    real(r8),intent(out) :: eflx_lh_tot(1)     ! total latent heat flux (W/m8*2)  [+ to atm]
+    real(r8),intent(out) :: t_ref2m(1)         ! 2 m height surface air temperature (Kelvin)
+    real(r8),intent(out) :: q_ref2m(1)         ! 2 m height surface specific humidity (kg/kg)
+    real(r8),intent(out) :: taux(1)            ! wind (shear) stress: e-w (kg/m/s**2)
+    real(r8),intent(out) :: tauy(1)            ! wind (shear) stress: n-s (kg/m/s**2)
+    real(r8),intent(out) :: ram1(1)            ! aerodynamical resistance (s/m)
+                                               ! for calculation of decay of eddy diffusivity with depth
+                                               ! Change the type variable to pass back to WRF.
+    real(r8),intent(out) :: z0mg(1)            ! roughness length over ground, momentum (m(
+
+
+!local output
+    
+    real(r8) :: begwb(1)           ! water mass begining of the time step
+    real(r8) :: t_veg(1)           ! vegetation temperature (Kelvin)
+    real(r8) :: eflx_soil_grnd(1)  ! soil heat flux (W/m**2) [+ = into soil]
+    real(r8) :: eflx_lh_grnd(1)    ! ground evaporation heat flux (W/m**2) [+ to atm]
+    real(r8) :: eflx_sh_grnd(1)    ! sensible heat flux from ground (W/m**2) [+ to atm]
+    real(r8) :: eflx_lwrad_out(1)  ! emitted infrared (longwave) radiation (W/m**2)
+    real(r8) :: qflx_evap_tot(1)   ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg
+    real(r8) :: qflx_evap_soi(1)   ! soil evaporation (mm H2O/s) (+ = to atm)
+    real(r8) :: qflx_prec_grnd(1)  ! water onto ground including canopy runoff [kg/(m2 s)]
+    real(r8) :: forc_snow(1)       ! snow rate [mm/s]
+    real(r8) :: forc_rain(1)       ! rain rate [mm/s]
+    real(r8) :: ws(1)              ! surface friction velocity (m/s)
+    real(r8) :: ks(1)              ! coefficient passed to ShalLakeTemperature
+    real(r8) :: qflx_snomelt(1)    !snow melt (mm H2O /s) tem(out),snowwater(in)
+    integer  :: imelt(1,-nlevsnow+1:nlevsoil)      !flag for melting (=1), freezing (=2), Not=0 (new)
+    real(r8) :: endwb(1)         ! water mass end of the time step
+    real(r8) :: snowage(1)       ! non dimensional snow age [-]
+    real(r8) :: snowice(1)       ! average snow ice lens
+    real(r8) :: snowliq(1)       ! average snow liquid water
+    real(r8) :: t_snow(1)        ! vertically averaged snow temperature
+    real(r8) :: qflx_drain(1)    ! sub-surface runoff (mm H2O /s)
+    real(r8) :: qflx_surf(1)     ! surface runoff (mm H2O /s)
+    real(r8) :: qflx_infl(1)     ! infiltration (mm H2O /s)
+    real(r8) :: qflx_qrgwl(1)    ! qflx_surf at glaciers, wetlands, lakes
+    real(r8) :: qcharge(1)       ! aquifer recharge rate (mm/s)
+    real(r8) :: qflx_snowcap(1)       ! excess precipitation due to snow capping (mm H2O /s) [+]
+    real(r8) :: qflx_snowcap_col(1)   ! excess precipitation due to snow capping (mm H2O /s) [+]
+    real(r8) :: qflx_snow_grnd_pft(1) ! snow on ground after interception (mm H2O/s) [+]
+    real(r8) :: qflx_snow_grnd_col(1) ! snow on ground after interception (mm H2O/s) [+]
+    real(r8) :: qflx_rain_grnd(1)     ! rain on ground after interception (mm H2O/s) [+]
+    real(r8) :: frac_iceold(1,-nlevsnow+1:nlevsoil)      ! fraction of ice relative to the tot water
+    real(r8) :: qflx_evap_tot_col(1) !pft quantity averaged to the column (assuming one pft)
+    real(r8) :: soilalpha(1)     !factor that reduces ground saturated specific humidity (-)
+    real(r8) :: zwt(1)           !water table depth
+    real(r8) :: fcov(1)          !fractional area with water table at surface
+    real(r8) :: rootr_column(1,1:nlevsoil) !effective fraction of roots in each soil layer
+    real(r8) :: qflx_evap_grnd(1)  ! ground surface evaporation rate (mm H2O/s) [+]
+    real(r8) :: qflx_sub_snow(1)   ! sublimation rate from snow pack (mm H2O /s) [+]
+    real(r8) :: qflx_dew_snow(1)   ! surface dew added to snow pack (mm H2O /s) [+]
+    real(r8) :: qflx_dew_grnd(1)   ! ground surface dew formation (mm H2O /s) [+]
+    real(r8) :: qflx_rain_grnd_col(1)   !rain on ground after interception (mm H2O/s) [+]
+    
+
+!    lat  = lat*pie/180  ! [radian]
+
+    if (prec(1)> 0.) then
+        if ( forc_t(1) > (tfrz + tcrit)) then
+            forc_rain(1) = prec(1)
+            forc_snow(1) = 0.
+          !   flfall(1) = 1.
+         else
+            forc_rain(1) = 0.
+            forc_snow(1) = prec(1)
+
+          !  if ( forc_t(1) <= tfrz) then
+          !      flfall(1) = 0.
+          !  else if ( forc_t(1) <= tfrz+2.) then
+          !      flfall(1) = -54.632 + 0.2 *  forc_t(1)
+          !  else
+          !      flfall(1) = 0.4
+         endif
+    else
+         forc_rain(1) = 0.
+         forc_snow(1) = 0.
+       !  flfall(1) = 1.
+    endif
+
+    CALL ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q,   &  !i
+                          forc_hgt_t,forc_hgt_u,forc_q,                   &
+                          forc_u,forc_v,forc_lwrad,forc_snow,             &
+                          forc_rain,t_grnd,h2osno,snowdp,sabg,lat,        &
+                          dz,dz_lake,t_soisno,t_lake,snl,h2osoi_liq,      &
+                          h2osoi_ice,savedtke1,                           &
+                          qflx_prec_grnd,qflx_evap_soi,qflx_evap_tot,     &  !o
+                          eflx_sh_grnd,eflx_lwrad_out,eflx_lwrad_net,     &
+                          eflx_soil_grnd,eflx_sh_tot,eflx_lh_tot,         &
+                          eflx_lh_grnd,t_veg,t_ref2m,q_ref2m,taux,tauy,   &
+                          ram1,ws,ks,eflx_gnet,z0mg)
+ 
+
+    CALL ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi,             & !i
+                                 z_lake,ws,ks,snl,eflx_gnet,lakedepth,       &
+                                 lake_icefrac,snowdp,                        & !i&o
+                                 eflx_sh_grnd,eflx_sh_tot,eflx_soil_grnd,    & !o
+                                 t_lake,t_soisno,h2osoi_liq,                 &
+                                 h2osoi_ice,savedtke1,                       &
+                                 frac_iceold,qflx_snomelt,imelt)
+
+
+
+    CALL ShalLakeHydrology(dz_lake,forc_rain,forc_snow,                          & !i
+                               begwb,qflx_evap_tot,forc_t,do_capsnow,            &
+                               t_grnd,qflx_evap_soi,                             &
+                               qflx_snomelt,imelt,frac_iceold,                   & !i add by guhp
+                               z,dz,zi,snl,h2osno,snowdp,lake_icefrac,t_lake,      & !i&o
+                               endwb,snowage,snowice,snowliq,t_snow,             & !o
+                               t_soisno,h2osoi_ice,h2osoi_liq,h2osoi_vol,        &
+                               qflx_drain,qflx_surf,qflx_infl,qflx_qrgwl,        &
+                               qcharge,qflx_prec_grnd,qflx_snowcap,              &
+                               qflx_snowcap_col,qflx_snow_grnd_pft,              &
+                               qflx_snow_grnd_col,qflx_rain_grnd,                &
+                               qflx_evap_tot_col,soilalpha,zwt,fcov,             &
+                               rootr_column,qflx_evap_grnd,qflx_sub_snow,        &
+                               qflx_dew_snow,qflx_dew_grnd,qflx_rain_grnd_col)
+                       
+!==================================================================================
+! !DESCRIPTION:
+! Calculation of Shallow Lake Hydrology. Full hydrology of snow layers is
+! done. However, there is no infiltration, and the water budget is balanced with 
+                       
+   END SUBROUTINE LakeMain
+
+
+SUBROUTINE ShalLakeFluxes(forc_t,forc_pbot,forc_psrf,forc_hgt,forc_hgt_q,           &  !i
+                          forc_hgt_t,forc_hgt_u,forc_q,                   &
+                          forc_u,forc_v,forc_lwrad,forc_snow,             &
+                          forc_rain,t_grnd,h2osno,snowdp,sabg,lat,        &
+                          dz,dz_lake,t_soisno,t_lake,snl,h2osoi_liq,      &
+                          h2osoi_ice,savedtke1,                           &
+                          qflx_prec_grnd,qflx_evap_soi,qflx_evap_tot,     &  !o
+                          eflx_sh_grnd,eflx_lwrad_out,eflx_lwrad_net,     &
+                          eflx_soil_grnd,eflx_sh_tot,eflx_lh_tot,         &
+                          eflx_lh_grnd,t_veg,t_ref2m,q_ref2m,taux,tauy,   &
+                          ram1,ws,ks,eflx_gnet,z0mg)            
+!==============================================================================
+! DESCRIPTION:
+! Calculates lake temperatures and surface fluxes for shallow lakes.
+!
+! Shallow lakes have variable depth, possible snow layers above, freezing & thawing of lake water,
+! and soil layers with active temperature and gas diffusion below.
+!
+! WARNING: This subroutine assumes lake columns have one and only one pft.
+!
+! REVISION HISTORY:
+! Created by Zack Subin, 2009
+! Reedited by Hongping Gu, 2010 
+!==============================================================================
+
+   ! implicit none
+ 
+    implicit none
+
+!in: 
+
+    real(r8),intent(in) :: forc_t(1)          ! atmospheric temperature (Kelvin)
+    real(r8),intent(in) :: forc_pbot(1)       ! atmospheric pressure (Pa)
+    real(r8),intent(in) :: forc_psrf(1)       ! atmospheric surface pressure (Pa)
+    real(r8),intent(in) :: forc_hgt(1)        ! atmospheric reference height (m)
+    real(r8),intent(in) :: forc_hgt_q(1)      ! observational height of humidity [m]
+    real(r8),intent(in) :: forc_hgt_t(1)      ! observational height of temperature [m]
+    real(r8),intent(in) :: forc_hgt_u(1)      ! observational height of wind [m]
+    real(r8),intent(in) :: forc_q(1)          ! atmospheric specific humidity (kg/kg)
+    real(r8),intent(in) :: forc_u(1)          ! atmospheric wind speed in east direction (m/s)
+    real(r8),intent(in) :: forc_v(1)          ! atmospheric wind speed in north direction (m/s)
+    real(r8),intent(in) :: forc_lwrad(1)      ! downward infrared (longwave) radiation (W/m**2)
+   ! real(r8),intent(in) :: forc_rho(1)        ! density (kg/m**3)
+    real(r8),intent(in) :: forc_snow(1)       ! snow rate [mm/s]
+    real(r8),intent(in) :: forc_rain(1)       ! rain rate [mm/s]
+    real(r8),intent(in) :: h2osno(1)          ! snow water (mm H2O)
+    real(r8),intent(in) :: snowdp(1)          ! snow height (m)
+    real(r8),intent(in) :: sabg(1)            ! solar radiation absorbed by ground (W/m**2)
+    real(r8),intent(in) :: lat(1)             ! latitude (radians)
+    real(r8),intent(in) :: dz(1,-nlevsnow+1:nlevsoil)            ! layer thickness for soil or snow (m)
+    real(r8),intent(in) :: dz_lake(1,nlevlake)                  ! layer thickness for lake (m)
+    real(r8),intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil)      ! soil (or snow) temperature (Kelvin)
+    real(r8),intent(in) :: t_lake(1,nlevlake)                   ! lake temperature (Kelvin)
+    integer ,intent(in) :: snl(1)                              ! number of snow layers
+    real(r8),intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil)    ! liquid water (kg/m2)
+    real(r8),intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil)    ! ice lens (kg/m2)
+    real(r8),intent(in) :: savedtke1(1)       ! top level eddy conductivity from previous timestep (W/m.K)
+
+!inout:
+    real(r8),intent(inout) :: t_grnd(1)          ! ground temperature (Kelvin)
+!out:
+    real(r8),intent(out):: qflx_prec_grnd(1)  ! water onto ground including canopy runoff [kg/(m2 s)]
+    real(r8),intent(out):: qflx_evap_soi(1)   ! soil evaporation (mm H2O/s) (+ = to atm)
+    real(r8),intent(out):: qflx_evap_tot(1)   ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg
+    real(r8),intent(out):: eflx_sh_grnd(1)    ! sensible heat flux from ground (W/m**2) [+ to atm]
+    real(r8),intent(out):: eflx_lwrad_out(1)  ! emitted infrared (longwave) radiation (W/m**2)
+    real(r8),intent(out):: eflx_lwrad_net(1)  ! net infrared (longwave) rad (W/m**2) [+ = to atm]
+    real(r8),intent(out):: eflx_soil_grnd(1)  ! soil heat flux (W/m**2) [+ = into soil]
+    real(r8),intent(out):: eflx_sh_tot(1)     ! total sensible heat flux (W/m**2) [+ to atm]
+    real(r8),intent(out):: eflx_lh_tot(1)     ! total latent heat flux (W/m8*2)  [+ to atm]
+    real(r8),intent(out):: eflx_lh_grnd(1)    ! ground evaporation heat flux (W/m**2) [+ to atm]
+    real(r8),intent(out):: t_veg(1)           ! vegetation temperature (Kelvin)
+    real(r8),intent(out):: t_ref2m(1)         ! 2 m height surface air temperature (Kelvin)
+    real(r8),intent(out):: q_ref2m(1)         ! 2 m height surface specific humidity (kg/kg)
+    real(r8),intent(out):: taux(1)            ! wind (shear) stress: e-w (kg/m/s**2)
+    real(r8),intent(out):: tauy(1)            ! wind (shear) stress: n-s (kg/m/s**2)
+    real(r8),intent(out):: ram1(1)            ! aerodynamical resistance (s/m)
+    real(r8),intent(out):: ws(1)              ! surface friction velocity (m/s)
+    real(r8),intent(out):: ks(1)              ! coefficient passed to ShalLakeTemperature
+                                               ! for calculation of decay of eddy diffusivity with depth
+    real(r8),intent(out):: eflx_gnet(1)       !net heat flux into ground (W/m**2)
+                                               ! Change the type variable to pass back to WRF.
+    real(r8),intent(out):: z0mg(1)            ! roughness length over ground, momentum (m(
+
+
+
+!OTHER LOCAL VARIABLES:
+
+    integer , parameter :: islak  = 2       ! index of lake, 1 = deep lake, 2 = shallow lake
+    integer , parameter :: niters = 3       ! maximum number of iterations for surface temperature
+    real(r8), parameter :: beta1  = 1._r8   ! coefficient of convective velocity (in computing W_*) [-]
+    real(r8), parameter :: emg    = 0.97_r8 ! ground emissivity (0.97 for snow)
+    real(r8), parameter :: zii    = 1000._r8! convective boundary height [m]
+    real(r8), parameter :: tdmax  = 277._r8 ! temperature of maximum water density
+    real(r8) :: forc_th(1)         ! atmospheric potential temperature (Kelvin)
+    real(r8) :: forc_vp(1)         !atmospheric vapor pressure (Pa)
+    real(r8) :: forc_rho(1)        ! density (kg/m**3)
+    integer  :: i,fc,fp,g,c,p           ! do loop or array index
+    integer  :: fncopy                  ! number of values in pft filter copy
+    integer  :: fnold                   ! previous number of pft filter values
+    integer  :: fpcopy(num_shlakep)     ! pft filter copy for iteration loop
+    integer  :: iter                    ! iteration index
+    integer  :: nmozsgn(lbp:ubp)        ! number of times moz changes sign
+    integer  :: jtop(lbc:ubc)           ! top level for each column (no longer all 1)
+!    real(r8) :: dtime                   ! land model time step (sec)
+    real(r8) :: ax                      ! used in iteration loop for calculating t_grnd (numerator of NR solution)
+    real(r8) :: bx                      ! used in iteration loop for calculating t_grnd (denomin. of NR solution)
+    real(r8) :: degdT                   ! d(eg)/dT
+    real(r8) :: dqh(lbp:ubp)            ! diff of humidity between ref. height and surface
+    real(r8) :: dth(lbp:ubp)            ! diff of virtual temp. between ref. height and surface
+    real(r8) :: dthv                    ! diff of vir. poten. temp. between ref. height and surface
+    real(r8) :: dzsur(lbc:ubc)          ! 1/2 the top layer thickness (m)
+    real(r8) :: eg                      ! water vapor pressure at temperature T [pa]
+    real(r8) :: htvp(lbc:ubc)           ! latent heat of vapor of water (or sublimation) [j/kg]
+    real(r8) :: obu(lbp:ubp)            ! monin-obukhov length (m)
+    real(r8) :: obuold(lbp:ubp)         ! monin-obukhov length of previous iteration
+    real(r8) :: qsatg(lbc:ubc)          ! saturated humidity [kg/kg]
+    real(r8) :: qsatgdT(lbc:ubc)        ! d(qsatg)/dT
+    real(r8) :: qstar                   ! moisture scaling parameter
+    real(r8) :: ram(lbp:ubp)            ! aerodynamical resistance [s/m]
+    real(r8) :: rah(lbp:ubp)            ! thermal resistance [s/m]
+    real(r8) :: raw(lbp:ubp)            ! moisture resistance [s/m]
+    real(r8) :: stftg3(lbp:ubp)         ! derivative of fluxes w.r.t ground temperature
+    real(r8) :: temp1(lbp:ubp)          ! relation for potential temperature profile
+    real(r8) :: temp12m(lbp:ubp)        ! relation for potential temperature profile applied at 2-m
+    real(r8) :: temp2(lbp:ubp)          ! relation for specific humidity profile
+    real(r8) :: temp22m(lbp:ubp)        ! relation for specific humidity profile applied at 2-m
+    real(r8) :: tgbef(lbc:ubc)          ! initial ground temperature
+    real(r8) :: thm(lbc:ubc)            ! intermediate variable (forc_t+0.0098*forc_hgt_t)
+    real(r8) :: thv(lbc:ubc)            ! virtual potential temperature (kelvin)
+    real(r8) :: thvstar                 ! virtual potential temperature scaling parameter
+    real(r8) :: tksur                   ! thermal conductivity of snow/soil (w/m/kelvin)
+    real(r8) :: tsur                    ! top layer temperature
+    real(r8) :: tstar                   ! temperature scaling parameter
+    real(r8) :: um(lbp:ubp)             ! wind speed including the stablity effect [m/s]
+    real(r8) :: ur(lbp:ubp)             ! wind speed at reference height [m/s]
+    real(r8) :: ustar(lbp:ubp)          ! friction velocity [m/s]
+    real(r8) :: wc                      ! convective velocity [m/s]
+    real(r8) :: zeta                    ! dimensionless height used in Monin-Obukhov theory
+    real(r8) :: zldis(lbp:ubp)          ! reference height "minus" zero displacement height [m]
+    real(r8) :: displa(lbp:ubp)         ! displacement (always zero) [m]
+!    real(r8) :: z0mg(lbp:ubp)           ! roughness length over ground, momentum [m]
+    real(r8) :: z0hg(lbp:ubp)           ! roughness length over ground, sensible heat [m]
+    real(r8) :: z0qg(lbp:ubp)           ! roughness length over ground, latent heat [m]
+    real(r8) :: beta(2)                 ! fraction solar rad absorbed at surface: depends on lake type
+    real(r8) :: u2m                     ! 2 m wind speed (m/s)
+    real(r8) :: u10(1)         ! 10-m wind (m/s) (for dust model)
+    real(r8) :: fv(1)          ! friction velocity (m/s) (for dust model)
+
+    real(r8) :: fm(lbp:ubp)             ! needed for BGC only to diagnose 10m wind speed
+    real(r8) :: bw                       ! partial density of water (ice + liquid)
+    real(r8) :: t_grnd_temp              ! Used in surface flux correction over frozen ground
+    real(r8) :: betaprime(lbc:ubc)       ! Effective beta: 1 for snow layers, beta(islak) otherwise
+    character*256 :: message 
+      ! This assumes all radiation is absorbed in the top snow layer and will need
+      ! to be changed for CLM 4.
+!
+! Constants for lake temperature model
+!
+    data beta/0.4_r8, 0.4_r8/  ! (deep lake, shallow lake)
+    ! This is the energy absorbed at the lake surface if no snow.
+!    data za  /0.6_r8, 0.5_r8/
+!    data eta /0.1_r8, 0.5_r8/
+!-----------------------------------------------------------------------
+
+
+!    dtime = get_step_size()
+
+! Begin calculations
+
+!dir$ concurrent
+!cdir nodep
+    forc_th(1)  = forc_t(1) * (forc_psrf(1)/ forc_pbot(1))**(rair/cpair)
+    forc_vp(1)  = forc_q(1) * forc_pbot(1)/ (0.622 + 0.378 * forc_q(1))
+    forc_rho(1) = (forc_pbot(1) - 0.378 * forc_vp(1)) / (rair * forc_t(1))
+
+    do fc = 1, num_shlakec
+       c = filter_shlakec(fc)
+       g = cgridcell(c)
+
+       ! Surface temperature and fluxes
+
+       ! Find top layer
+       if (snl(c) > 0 .or. snl(c) < -5) then
+         WRITE(message,*)  'snl is not defined in ShalLakeFluxesMod'
+         CALL wrf_message(message)
+         CALL wrf_error_fatal("snl: out of range value")
+       end if
+!       if (snl(c) /= 0) then
+!           write(6,*)'snl is not equal to zero in ShalLakeFluxesMod'
+!           call endrun()
+!       end if
+       jtop(c) = snl(c) + 1
+
+
+       if (snl(c) < 0) then
+           betaprime(c) = 1._r8  !Assume all solar rad. absorbed at the surface of the top snow layer. 
+           dzsur(c) = dz(c,jtop(c))/2._r8
+       else
+           betaprime(c) = beta(islak)
+           dzsur(c) = dz_lake(c,1)/2._r8
+       end if
+       ! Originally this was 1*dz, but shouldn't it be 1/2?
+
+       ! Saturated vapor pressure, specific humidity and their derivatives
+       ! at lake surface
+
+       call QSat(t_grnd(c), forc_pbot(g), eg, degdT, qsatg(c), qsatgdT(c))
+
+       ! Potential, virtual potential temperature, and wind speed at the
+       ! reference height
+
+       thm(c) = forc_t(g) + 0.0098_r8*forc_hgt_t(g)   ! intermediate variable
+       thv(c) = forc_th(g)*(1._r8+0.61_r8*forc_q(g))     ! virtual potential T
+    end do
+
+!dir$ concurrent
+!cdir nodep
+    do fp = 1, num_shlakep
+       p = filter_shlakep(fp)
+       c = pcolumn(p)
+       g = pgridcell(p)
+
+       nmozsgn(p) = 0
+       obuold(p) = 0._r8
+       displa(p) = 0._r8
+
+       ! Roughness lengths
+ 
+
+! changed by Hongping Gu
+    !   if (t_grnd(c) >= tfrz) then   ! for unfrozen lake
+    !      z0mg(p) = 0.01_r8
+    !   else                          ! for frozen lake
+    !   ! Is this okay even if it is snow covered?  What is the roughness over
+    !   non-veg. snow?
+    !      z0mg(p) = 0.04_r8
+    !   end if
+ 
+       if (t_grnd(c) >= tfrz) then   ! for unfrozen lake
+          z0mg(p) = 0.001_r8        !original 0.01
+       else if(snl(c) == 0 ) then                         ! for frozen lake
+       ! Is this okay even if it is snow covered?  What is the roughness over
+       ! non-veg. snow?
+          z0mg(p) = 0.005_r8          !original 0.04, now for frozen lake without snow
+       else                          ! for frozen lake with snow   
+          z0mg(p) = 0.0024_r8
+       end if
+ 
+ 
+
+
+       z0hg(p) = z0mg(p)
+       z0qg(p) = z0mg(p)
+
+       ! Latent heat
+
+#if (defined PERGRO)
+       htvp(c) = hvap
+#else
+       if (t_grnd(c) > tfrz) then
+          htvp(c) = hvap
+       else
+          htvp(c) = hsub
+       end if
+#endif
+       ! Zack Subin, 3/26/09: Shouldn't this be the ground temperature rather than the air temperature above?
+       ! I'll change it for now.
+
+       ! Initialize stability variables
+
+       ur(p)    = max(1.0_r8,sqrt(forc_u(g)*forc_u(g)+forc_v(g)*forc_v(g)))
+       dth(p)   = thm(c)-t_grnd(c)
+       dqh(p)   = forc_q(g)-qsatg(c)
+       dthv     = dth(p)*(1._r8+0.61_r8*forc_q(g))+0.61_r8*forc_th(g)*dqh(p)
+       zldis(p) = forc_hgt_u(g) - 0._r8
+
+       ! Initialize Monin-Obukhov length and wind speed
+
+       call MoninObukIni(ur(p), thv(c), dthv, zldis(p), z0mg(p), um(p), obu(p))
+
+    end do
+
+    iter = 1
+    fncopy = num_shlakep
+    fpcopy(1:num_shlakep) = filter_shlakep(1:num_shlakep)
+
+    ! Begin stability iteration
+
+    ITERATION : do while (iter <= niters .and. fncopy > 0)
+
+       ! Determine friction velocity, and potential temperature and humidity
+       ! profiles of the surface boundary layer
+
+       call FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u,          & !i
+                             forc_hgt_t,forc_hgt_q,                  & !i
+                             lbp, ubp, fncopy, fpcopy,               & !i
+                             displa, z0mg, z0hg, z0qg,               & !i
+                             obu, iter, ur, um,                      & !i
+                             ustar,temp1, temp2, temp12m, temp22m,   & !o
+                             u10,fv,                                 & !o
+                             fm)  !i&o
+
+!dir$ concurrent
+!cdir nodep
+       do fp = 1, fncopy
+          p = fpcopy(fp)
+          c = pcolumn(p)
+          g = pgridcell(p)
+
+          tgbef(c) = t_grnd(c)
+          if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then
+             tksur = savedtke1(c)
+             ! Set this to the eddy conductivity from the last
+             ! timestep, as the molecular conductivity will be orders of magnitude too small.
+             ! Will have to deal with first timestep.
+             tsur = t_lake(c,1)
+          else if (snl(c) == 0) then  !frozen but no snow layers
+             tksur = tkice
+             tsur = t_lake(c,1)
+          else
+          !Need to calculate thermal conductivity of the top snow layer
+             bw = (h2osoi_ice(c,jtop(c))+h2osoi_liq(c,jtop(c)))/dz(c,jtop(c))
+             tksur = tkairc + (7.75e-5_r8 *bw + 1.105e-6_r8*bw*bw)*(tkice-tkairc)
+             tsur = t_soisno(c,jtop(c))
+          end if
+
+          ! Determine aerodynamic resistances
+
+          ram(p)  = 1._r8/(ustar(p)*ustar(p)/um(p))
+          rah(p)  = 1._r8/(temp1(p)*ustar(p))
+          raw(p)  = 1._r8/(temp2(p)*ustar(p))
+          ram1(p) = ram(p)   !pass value to global variable
+
+          ! Get derivative of fluxes with respect to ground temperature
+
+          stftg3(p) = emg*sb*tgbef(c)*tgbef(c)*tgbef(c)
+
+          ! Changed surface temperature from t_lake(c,1) to tsur.
+          ! Also adjusted so that if there are snow layers present, all radiation is absorbed in the top layer.
+          ax  = betaprime(c)*sabg(p) + emg*forc_lwrad(g) + 3._r8*stftg3(p)*tgbef(c) &
+               + forc_rho(g)*cpair/rah(p)*thm(c) &
+               - htvp(c)*forc_rho(g)/raw(p)*(qsatg(c)-qsatgdT(c)*tgbef(c) - forc_q(g)) &
+               + tksur*tsur/dzsur(c)
+          !Changed sabg(p) and to betaprime(c)*sabg(p).
+          bx  = 4._r8*stftg3(p) + forc_rho(g)*cpair/rah(p) &
+               + htvp(c)*forc_rho(g)/raw(p)*qsatgdT(c) + tksur/dzsur(c)
+
+          t_grnd(c) = ax/bx
+
+          ! Update htvp
+#ifndef PERGRO
+       if (t_grnd(c) > tfrz) then
+          htvp(c) = hvap
+       else
+          htvp(c) = hsub
+       end if
+#endif
+
+          ! Surface fluxes of momentum, sensible and latent heat
+          ! using ground temperatures from previous time step
+
+          eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(c))/rah(p)
+          qflx_evap_soi(p) = forc_rho(g)*(qsatg(c)+qsatgdT(c)*(t_grnd(c)-tgbef(c))-forc_q(g))/raw(p)
+
+          ! Re-calculate saturated vapor pressure, specific humidity and their
+          ! derivatives at lake surface
+
+          call QSat(t_grnd(c), forc_pbot(g), eg, degdT, qsatg(c), qsatgdT(c))
+
+          dth(p)=thm(c)-t_grnd(c)
+          dqh(p)=forc_q(g)-qsatg(c)
+
+          tstar = temp1(p)*dth(p)
+          qstar = temp2(p)*dqh(p)
+
+          thvstar=tstar*(1._r8+0.61_r8*forc_q(g)) + 0.61_r8*forc_th(g)*qstar
+          zeta=zldis(p)*vkc * grav*thvstar/(ustar(p)**2*thv(c))
+
+          if (zeta >= 0._r8) then     !stable
+             zeta = min(2._r8,max(zeta,0.01_r8))
+             um(p) = max(ur(p),0.1_r8)
+          else                     !unstable
+             zeta = max(-100._r8,min(zeta,-0.01_r8))
+             wc = beta1*(-grav*ustar(p)*thvstar*zii/thv(c))**0.333_r8
+             um(p) = sqrt(ur(p)*ur(p)+wc*wc)
+          end if
+          obu(p) = zldis(p)/zeta
+
+          if (obuold(p)*obu(p) < 0._r8) nmozsgn(p) = nmozsgn(p)+1
+
+          obuold(p) = obu(p)
+
+       end do   ! end of filtered pft loop
+
+       iter = iter + 1
+       if (iter <= niters ) then
+          ! Rebuild copy of pft filter for next pass through the ITERATION loop
+
+          fnold = fncopy
+          fncopy = 0
+          do fp = 1, fnold
+             p = fpcopy(fp)
+             if (nmozsgn(p) < 3) then
+                fncopy = fncopy + 1
+                fpcopy(fncopy) = p
+             end if
+          end do   ! end of filtered pft loop
+       end if
+
+    end do ITERATION   ! end of stability iteration
+
+!dir$ concurrent
+!cdir nodep
+    do fp = 1, num_shlakep
+       p = filter_shlakep(fp)
+       c = pcolumn(p)
+       g = pgridcell(p)
+
+       ! If there is snow on the ground and t_grnd > tfrz: reset t_grnd = tfrz.
+       ! Re-evaluate ground fluxes.
+       ! h2osno > 0.5 prevents spurious fluxes.
+       ! note that qsatg and qsatgdT should be f(tgbef) (PET: not sure what this
+       ! comment means)
+       ! Zack Subin, 3/27/09: Since they are now a function of whatever t_grnd was before cooling
+       !    to freezing temperature, then this value should be used in the derivative correction term.
+       ! Should this happen if the lake temperature is below freezing, too? I'll assume that for now.
+       ! Also, allow convection if ground temp is colder than lake but warmer than 4C, or warmer than 
+       !    lake which is warmer than freezing but less than 4C.
+!#ifndef SHLAKETEST
+       if ( (h2osno(c) > 0.5_r8 .or. t_lake(c,1) <= tfrz) .and. t_grnd(c) > tfrz) then
+!#else
+!       if ( t_lake(c,1) <= tfrz .and. t_grnd(c) > tfrz) then
+!#endif
+          t_grnd_temp = t_grnd(c)
+          t_grnd(c) = tfrz
+          eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(c))/rah(p)
+          qflx_evap_soi(p) = forc_rho(g)*(qsatg(c)+qsatgdT(c)*(t_grnd(c)-t_grnd_temp) - forc_q(g))/raw(p)
+       else if ( (t_lake(c,1) > t_grnd(c) .and. t_grnd(c) > tdmax) .or. &
+                 (t_lake(c,1) < t_grnd(c) .and. t_lake(c,1) > tfrz .and. t_grnd(c) < tdmax) ) then
+                 ! Convective mixing will occur at surface
+          t_grnd_temp = t_grnd(c)
+          t_grnd(c) = t_lake(c,1)
+          eflx_sh_grnd(p) = forc_rho(g)*cpair*(t_grnd(c)-thm(c))/rah(p)
+          qflx_evap_soi(p) = forc_rho(g)*(qsatg(c)+qsatgdT(c)*(t_grnd(c)-t_grnd_temp) - forc_q(g))/raw(p)
+       end if
+
+          ! Update htvp
+#ifndef PERGRO
+       if (t_grnd(c) > tfrz) then
+          htvp(c) = hvap
+       else
+          htvp(c) = hsub
+       end if
+#endif
+
+       ! Net longwave from ground to atmosphere
+
+!       eflx_lwrad_out(p) = (1._r8-emg)*forc_lwrad(g) + stftg3(p)*(-3._r8*tgbef(c)+4._r8*t_grnd(c))
+       ! What is tgbef doing in this equation? Can't it be exact now? --Zack Subin, 4/14/09
+       eflx_lwrad_out(p) = (1._r8-emg)*forc_lwrad(g) + emg*sb*t_grnd(c)**4
+
+       ! Ground heat flux
+
+       eflx_soil_grnd(p) = sabg(p) + forc_lwrad(g) - eflx_lwrad_out(p) - &
+            eflx_sh_grnd(p) - htvp(c)*qflx_evap_soi(p)
+       !Why is this sabg(p) and not beta*sabg(p)??
+       !I've kept this as the incorrect sabg so that the energy balance check will be correct.
+       !This is the effective energy flux into the ground including the lake solar absorption
+       !below the surface.  The variable eflx_gnet will be used to pass the actual heat flux
+       !from the ground interface into the lake.
+
+       taux(p) = -forc_rho(g)*forc_u(g)/ram(p)
+       tauy(p) = -forc_rho(g)*forc_v(g)/ram(p)
+
+       eflx_sh_tot(p)   = eflx_sh_grnd(p)
+       qflx_evap_tot(p) = qflx_evap_soi(p)
+       eflx_lh_tot(p)   = htvp(c)*qflx_evap_soi(p)
+       eflx_lh_grnd(p)  = htvp(c)*qflx_evap_soi(p)
+#if (defined LAKEDEBUG)
+       write(message,*) 'c, sensible heat = ', c, eflx_sh_tot(p), 'latent heat = ', eflx_lh_tot(p) &
+              , 'ground temp = ', t_grnd(c), 'h2osno = ', h2osno(c)
+       CALL wrf_message(message)
+       if (abs(eflx_sh_tot(p)) > 1500 .or. abs(eflx_lh_tot(p)) > 1500) then
+           write(message,*)'WARNING: SH, LH = ', eflx_sh_tot(p), eflx_lh_tot(p)
+           CALL wrf_message(message)
+       end if
+       if (abs(eflx_sh_tot(p)) > 10000 .or. abs(eflx_lh_tot(p)) > 10000 &
+             .or. abs(t_grnd(c)-288)>200 ) CALL wrf_error_fatal ( 't_grnd is out of range' ) 
+#endif
+       ! 2 m height air temperature
+       t_ref2m(p) = thm(c) + temp1(p)*dth(p)*(1._r8/temp12m(p) - 1._r8/temp1(p))
+
+       ! 2 m height specific humidity
+       q_ref2m(p) = forc_q(g) + temp2(p)*dqh(p)*(1._r8/temp22m(p) - 1._r8/temp2(p))
+
+       ! Energy residual used for melting snow
+       ! Effectively moved to ShalLakeTemp
+
+       ! Prepare for lake layer temperature calculations below
+       ! fin(c) = betaprime * sabg(p) + forc_lwrad(g) - (eflx_lwrad_out(p) + &
+       !          eflx_sh_tot(p) + eflx_lh_tot(p))
+       ! NOW this is just the net ground heat flux calculated below.
+
+       eflx_gnet(p) = betaprime(c) * sabg(p) + forc_lwrad(g) - (eflx_lwrad_out(p) + &
+            eflx_sh_tot(p) + eflx_lh_tot(p))
+       ! This is the actual heat flux from the ground interface into the lake, not including
+       ! the light that penetrates the surface.
+
+!       u2m = max(1.0_r8,ustar(p)/vkc*log(2._r8/z0mg(p)))
+       ! u2 often goes below 1 m/s; it seems like the only reason for this minimum is to
+       ! keep it from being zero in the ks equation below; 0.1 m/s is a better limit for
+       ! stable conditions --ZS
+       u2m = max(0.1_r8,ustar(p)/vkc*log(2._r8/z0mg(p)))
+
+       ws(c) = 1.2e-03_r8 * u2m
+       ks(c) = 6.6_r8*sqrt(abs(sin(lat(g))))*(u2m**(-1.84_r8))
+
+    end do
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! End of surface flux relevant code in original BiogeophysicsLakeMod until history loop.
+
+    ! The following are needed for global average on history tape.
+
+!dir$ concurrent
+!cdir nodep
+    do fp = 1, num_shlakep
+       p = filter_shlakep(fp)
+       c = pcolumn(p)
+       g = pgridcell(p)
+!       t_veg(p) = forc_t(g)
+        !This is an odd choice, since elsewhere t_veg = t_grnd for bare ground.
+        !Zack Subin, 4/09
+       t_veg(p) = t_grnd(c)
+       eflx_lwrad_net(p)  = eflx_lwrad_out(p) - forc_lwrad(g)
+       qflx_prec_grnd(p) = forc_rain(g) + forc_snow(g)
+    end do
+
+END SUBROUTINE ShalLakeFluxes
+ 
+SUBROUTINE ShalLakeTemperature(t_grnd,h2osno,sabg,dz,dz_lake,z,zi,           & !i
+                                 z_lake,ws,ks,snl,eflx_gnet,lakedepth,       &
+                                 lake_icefrac,snowdp,                        & !i&o
+                                 eflx_sh_grnd,eflx_sh_tot,eflx_soil_grnd,    & !o
+                                 t_lake,t_soisno,h2osoi_liq,                 &
+                                 h2osoi_ice,savedtke1,                       &
+                                 frac_iceold,qflx_snomelt,imelt)
+!=======================================================================================================
+! !DESCRIPTION:
+! Calculates temperatures in the 20-25 layer column of (possible) snow,
+! lake water, and soil beneath lake.
+! Snow and soil temperatures are determined as in SoilTemperature, except
+! for appropriate boundary conditions at the top of the snow (the flux is fixed
+! to be the ground heat flux calculated in ShalLakeFluxes), the bottom of the snow
+! (adjacent to top lake layer), and the top of the soil (adjacent to the bottom
+! lake layer). Also, the soil is assumed to be always fully saturated (ShalLakeHydrology
+! will have to insure this). The whole column is solved simultaneously as one tridiagonal matrix.
+! Lake temperatures are determined from the Hostetler model as before, except now:
+!    i) Lake water layers can freeze by any fraction and release latent heat; thermal
+!       and mechanical properties are adjusted for ice fraction.
+!   ii) Convective mixing (though not eddy diffusion) still occurs for frozen lakes.
+!  iii) No sunlight is absorbed in the lake if there are snow layers.
+!   iv) Light is allowed to reach the top soil layer (where it is assumed to be completely absorbed).
+!    v) Lakes have variable depth, set ultimately in surface data set but now in initShalLakeMod.
+!
+! Eddy + molecular diffusion:
+! d ts    d            d ts     1 ds
+! ---- = -- [(km + ke) ----] + -- --
+!  dt    dz             dz     cw dz
+!
+! where: ts = temperature (kelvin)
+!         t = time (s)
+!         z = depth (m)
+!        km = molecular diffusion coefficient (m**2/s)
+!        ke = eddy diffusion coefficient (m**2/s)
+!        cw = heat capacity (j/m**3/kelvin)
+!         s = heat source term (w/m**2)
+!
+!   Shallow lakes are allowed to have variable depth, set in _____.
+!
+!   For shallow lakes:    ke > 0 if unfrozen,
+!       and convective mixing occurs WHETHER OR NOT frozen. (See e.g. Martynov...)
+!
+! Use the Crank-Nicholson method to set up tridiagonal system of equations to
+! solve for ts at time n+1, where the temperature equation for layer i is
+! r_i = a_i [ts_i-1] n+1 + b_i [ts_i] n+1 + c_i [ts_i+1] n+1
+!
+! The solution conserves energy as:
+!
+! [For lake layers]
+! cw*([ts(      1)] n+1 - [ts(      1)] n)*dz(      1)/dt + ... +
+! cw*([ts(nlevlake)] n+1 - [ts(nlevlake)] n)*dz(nlevlake)/dt = fin
+! But now there is phase change, so cv is not constant and there is
+! latent heat.
+!
+! where:
+! [ts] n   = old temperature (kelvin)
+! [ts] n+1 = new temperature (kelvin)
+! fin      = heat flux into lake (w/m**2)
+!          = betaprime*sabg + forc_lwrad - eflx_lwrad_out - eflx_sh_tot - eflx_lh_tot
+!          (This is now the same as the ground heat flux.)
+!            + phi(1) + ... + phi(nlevlake) + phi(top soil level)
+! betaprime = beta(islak) for no snow layers, and 1 for snow layers.
+! This assumes all radiation is absorbed in the top snow layer and will need
+! to be changed for CLM 4.
+!
+! WARNING: This subroutine assumes lake columns have one and only one pft.
+!
+! Outline:
+! 1!) Initialization
+! 2!) Lake density
+! 3!) Diffusivity
+! 4!) Heat source term from solar radiation penetrating lake
+! 5!) Set thermal props and find initial energy content
+! 6!) Set up vectors for tridiagonal matrix solution
+! 7!) Solve tridiagonal and back-substitute
+! 8!) (Optional) Do first energy check using temperature change at constant heat capacity.
+! 9!) Phase change
+! 9.5!) (Optional) Do second energy check using temperature change and latent heat, considering changed heat capacity.
+!                  Also do soil water balance check.
+!10!) Convective mixing 
+!11!) Do final energy check to detect small numerical errors (especially from convection)
+!     and dump small imbalance into sensible heat, or pass large errors to BalanceCheckMod for abort.
+!
+! REVISION HISTORY:
+! Created by Zack Subin, 2009.
+! Reedited by Hongping Gu, 2010.
+!=========================================================================================================
+
+
+!    use TridiagonalMod     , only : Tridiagonal
+    
+    implicit none
+
+!in:
+    real(r8), intent(in) :: t_grnd(1)          ! ground temperature (Kelvin)
+    real(r8), intent(inout) :: h2osno(1)          ! snow water (mm H2O)
+    real(r8), intent(in) :: sabg(1)            ! solar radiation absorbed by ground (W/m**2)
+    real(r8), intent(in) :: dz(1,-nlevsnow + 1:nlevsoil)          ! layer thickness for snow & soil (m)
+    real(r8), intent(in) :: dz_lake(1,nlevlake)                  ! layer thickness for lake (m)
+    real(r8), intent(in) :: z(1,-nlevsnow+1:nlevsoil)             ! layer depth for snow & soil (m)
+    real(r8), intent(in) :: zi(1,-nlevsnow+0:nlevsoil)            ! interface level below a "z" level (m)
+                                                                ! the other z and dz variables
+    real(r8), intent(in) :: z_lake(1,nlevlake)  ! layer depth for lake (m)
+    real(r8), intent(in) :: ws(1)              ! surface friction velocity (m/s)
+    real(r8), intent(in) :: ks(1)              ! coefficient passed to ShalLakeTemperature
+                                               ! for calculation of decay of eddy diffusivity with depth
+    integer , intent(in) :: snl(1)             ! negative of number of snow layers
+    real(r8), intent(inout) :: eflx_gnet(1)       ! net heat flux into ground (W/m**2) at the surface interface
+    real(r8), intent(in) :: lakedepth(1)       ! column lake depth (m)
+    
+   ! real(r8), intent(in) :: watsat(1,nlevsoil)      ! volumetric soil water at saturation (porosity)
+    real(r8), intent(inout) :: snowdp(1)        !snow height (m)
+!out: 
+
+    real(r8), intent(out) :: eflx_sh_grnd(1)    ! sensible heat flux from ground (W/m**2) [+ to atm]
+    real(r8), intent(out) :: eflx_sh_tot(1)     ! total sensible heat flux (W/m**2) [+ to atm]
+    real(r8), intent(out) :: eflx_soil_grnd(1)  ! heat flux into snow / lake (W/m**2) [+ = into soil]
+                                               ! Here this includes the whole lake radiation absorbed.
+#if (defined SHLAKETEST)
+    real(r8), intent(out) :: qmelt(1)           ! snow melt [mm/s] [temporary]
+#endif
+    real(r8), intent(inout) :: t_lake(1,nlevlake)                 ! lake temperature (Kelvin)
+    real(r8), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil)    ! soil (or snow) temperature (Kelvin)
+    real(r8), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil)  ! liquid water (kg/m2) [for snow & soil layers]
+    real(r8), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil)  ! ice lens (kg/m2) [for snow & soil layers]
+    real(r8), intent(inout) :: lake_icefrac(1,nlevlake)           ! mass fraction of lake layer that is frozen
+    real(r8), intent(out) :: savedtke1(1)                      ! top level thermal conductivity (W/mK)
+    real(r8), intent(out) :: frac_iceold(1,-nlevsnow+1:nlevsoil) ! fraction of ice relative to the tot water
+    real(r8), intent(out) :: qflx_snomelt(1)  !snow melt (mm H2O /s)
+    integer, intent(out)  :: imelt(1,-nlevsnow+1:nlevsoil)        !flag for melting (=1), freezing (=2), Not=0 (new)
+
+
+! OTHER LOCAL VARIABLES:
+
+    integer , parameter  :: islak = 2     ! index of lake, 1 = deep lake, 2 = shallow lake
+    real(r8), parameter  :: p0 = 1._r8     ! neutral value of turbulent prandtl number
+    integer  :: i,j,fc,fp,g,c,p         ! do loop or array index
+!    real(r8) :: dtime                   ! land model time step (sec)
+    real(r8) :: beta(2)                 ! fraction solar rad absorbed at surface: depends on lake type
+    real(r8) :: za(2)                   ! base of surface absorption layer (m): depends on lake type
+    real(r8) :: eta(2)                  ! light extinction coefficient (/m): depends on lake type
+    real(r8) :: cwat                    ! specific heat capacity of water (j/m**3/kelvin)
+    real(r8) :: cice_eff                ! effective heat capacity of ice (using density of
+                                          ! water because layer depth is not adjusted when freezing
+    real(r8) :: cfus                    ! effective heat of fusion per unit volume
+                                          ! using water density as above
+    real(r8) :: km                      ! molecular diffusion coefficient (m**2/s)
+    real(r8) :: tkice_eff               ! effective conductivity since layer depth is constant
+    real(r8) :: a(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil)      ! "a" vector for tridiagonal matrix
+    real(r8) :: b(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil)      ! "b" vector for tridiagonal matrix
+    real(r8) :: c1(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil)     ! "c" vector for tridiagonal matrix
+    real(r8) :: r(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil)      ! "r" vector for tridiagonal solution
+    real(r8) :: rhow(lbc:ubc,nlevlake)   ! density of water (kg/m**3)
+    real(r8) :: phi(lbc:ubc,nlevlake)    ! solar radiation absorbed by layer (w/m**2)
+    real(r8) :: kme(lbc:ubc,nlevlake)    ! molecular + eddy diffusion coefficient (m**2/s)
+    real(r8) :: rsfin                   ! relative flux of solar radiation into layer
+    real(r8) :: rsfout                  ! relative flux of solar radiation out of layer
+    real(r8) :: phi_soil(lbc:ubc)       ! solar radiation into top soil layer (W/m**2)
+    real(r8) :: ri                      ! richardson number
+    real(r8) :: fin(lbc:ubc)            ! net heat flux into lake at ground interface (w/m**2)
+    real(r8) :: ocvts(lbc:ubc)          ! (cwat*(t_lake[n  ])*dz
+    real(r8) :: ncvts(lbc:ubc)          ! (cwat*(t_lake[n+1])*dz
+    real(r8) :: ke                      ! eddy diffusion coefficient (m**2/s)
+    real(r8) :: zin                     ! depth at top of layer (m)
+    real(r8) :: zout                    ! depth at bottom of layer (m)
+    real(r8) :: drhodz                  ! d [rhow] /dz (kg/m**4)
+    real(r8) :: n2                      ! brunt-vaisala frequency (/s**2)
+    real(r8) :: num                     ! used in calculating ri
+    real(r8) :: den                     ! used in calculating ri
+    real(r8) :: tav_froz(lbc:ubc)       ! used in aver temp for convectively mixed layers (C)
+    real(r8) :: tav_unfr(lbc:ubc)       ! "
+    real(r8) :: nav(lbc:ubc)            ! used in aver temp for convectively mixed layers
+    real(r8) :: phidum                  ! temporary value of phi
+    real(r8) :: iceav(lbc:ubc)          ! used in calc aver ice for convectively mixed layers
+    real(r8) :: qav(lbc:ubc)            ! used in calc aver heat content for conv. mixed layers
+    integer  :: jtop(lbc:ubc)           ! top level for each column (no longer all 1)
+    real(r8) :: cv (lbc:ubc,-nlevsnow+1:nlevsoil)  !heat capacity of soil/snow [J/(m2 K)]
+    real(r8) :: tk (lbc:ubc,-nlevsnow+1:nlevsoil)  !thermal conductivity of soil/snow [W/(m K)]
+                                                 !(at interface below, except for j=0)
+    real(r8) :: cv_lake (lbc:ubc,1:nlevlake)      !heat capacity [J/(m2 K)]
+    real(r8) :: tk_lake (lbc:ubc,1:nlevlake)  !thermal conductivity at layer node [W/(m K)]
+    real(r8) :: cvx (lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !heat capacity for whole column [J/(m2 K)]
+    real(r8) :: tkix(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !thermal conductivity at layer interfaces
+                                                         !for whole column [W/(m K)]
+    real(r8) :: tx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) ! temperature of whole column [K]
+    real(r8) :: tktopsoillay(lbc:ubc)          ! thermal conductivity [W/(m K)]
+    real(r8) :: fnx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil)  !heat diffusion through the layer interface below [W/m2]
+    real(r8) :: phix(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !solar source term for whole column [W/m**2]
+    real(r8) :: zx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil)   !interface depth (+ below surface) for whole column [m]
+    real(r8) :: dzm                              !used in computing tridiagonal matrix [m]
+    real(r8) :: dzp                              !used in computing tridiagonal matrix [m]
+    integer  :: jprime                   ! j - nlevlake
+    real(r8) :: factx(lbc:ubc,-nlevsnow+1:nlevlake+nlevsoil) !coefficient used in computing tridiagonal matrix
+    real(r8) :: t_lake_bef(lbc:ubc,1:nlevlake)    !beginning lake temp for energy conservation check [K]
+    real(r8) :: t_soisno_bef(lbc:ubc,-nlevsnow+1:nlevsoil) !beginning soil temp for E cons. check [K]
+    real(r8) :: lhabs(lbc:ubc)       ! total per-column latent heat abs. from phase change  (J/m^2)
+    real(r8) :: esum1(lbc:ubc)        ! temp for checking energy (J/m^2)
+    real(r8) :: esum2(lbc:ubc)        ! ""
+    real(r8) :: zsum(lbc:ubc)        ! temp for putting ice at the top during convection (m)
+    real(r8) :: wsum(lbc:ubc)        ! temp for checking water (kg/m^2)
+    real(r8) :: wsum_end(lbc:ubc)    ! temp for checking water (kg/m^2)
+    real(r8) :: errsoi(1)                         ! soil/lake energy conservation error (W/m**2)
+    real(r8) :: eflx_snomelt(1)  !snow melt heat flux (W/m**2)
+    CHARACTER*256 :: message
+!
+! Constants for lake temperature model
+!
+    data beta/0.4_r8, 0.4_r8/  ! (deep lake, shallow lake)
+    data za  /0.6_r8, 0.6_r8/
+!   For now, keep beta and za for shallow lake the same as deep lake, until better data is found.
+!   It looks like eta is key and that larger values give better results for shallow lakes.  Use
+!   empirical expression from Hakanson (below). This is still a very unconstrained parameter
+!   that deserves more attention.
+!   Some radiation will be allowed to reach the soil.
+!-----------------------------------------------------------------------
+
+
+    ! 1!) Initialization
+    ! Determine step size
+
+!    dtime = get_step_size()
+
+    ! Initialize constants
+    cwat = cpliq*denh2o ! water heat capacity per unit volume
+    cice_eff = cpice*denh2o !use water density because layer depth is not adjusted
+                              !for freezing
+    cfus = hfus*denh2o  ! latent heat per unit volume
+    tkice_eff = tkice * denice/denh2o !effective conductivity since layer depth is constant
+    km = tkwat/cwat     ! a constant (molecular diffusivity)
+
+    ! Begin calculations
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_shlakec
+       c = filter_shlakec(fc)
+
+       ! Initialize Ebal quantities computed below
+
+       ocvts(c) = 0._r8
+       ncvts(c) = 0._r8
+       esum1(c) = 0._r8
+       esum2(c) = 0._r8
+
+    end do
+
+    ! Initialize set of previous time-step variables as in DriverInit,
+    ! which is currently not called over lakes. This has to be done
+    ! here because phase change will occur in this routine.
+    ! Ice fraction of snow at previous time step
+
+    do j = -nlevsnow+1,0
+!dir$ concurrent
+!cdir nodep
+      do fc = 1, num_shlakec
+         c = filter_shlakec(fc)
+         if (j >= snl(c) + 1) then
+            frac_iceold(c,j) = h2osoi_ice(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j))
+         end if
+      end do
+    end do
+
+    ! Sum soil water.
+    do j = 1, nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+          if (j == 1) wsum(c) = 0._r8
+          wsum(c) = wsum(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j)
+       end do
+    end do
+
+!dir$ concurrent
+!cdir nodep
+    do fp = 1, num_shlakep
+       p = filter_shlakep(fp)
+       c = pcolumn(p)
+
+
+       ! Prepare for lake layer temperature calculations below
+
+       ! fin(c) = betaprime * sabg(p) + forc_lwrad(g) - (eflx_lwrad_out(p) + &
+       !     eflx_sh_tot(p) + eflx_lh_tot(p)) 
+       ! fin(c) now passed from ShalLakeFluxes as eflx_gnet
+       fin(c) = eflx_gnet(p)
+
+    end do
+
+    ! 2!) Lake density
+
+    do j = 1, nlevlake
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+          rhow(c,j) = (1._r8 - lake_icefrac(c,j)) * & 
+                      1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,j)-277._r8))**1.68_r8 ) &
+                    + lake_icefrac(c,j)*denice
+                    ! Allow for ice fraction; assume constant ice density.
+                    ! Is this the right weighted average?
+                    ! Using this average will make sure that surface ice is treated properly during
+                    ! convective mixing.
+       end do
+    end do
+
+    ! 3!) Diffusivity and implied thermal "conductivity" = diffusivity * cwat
+    do j = 1, nlevlake-1
+!dir$ prefervector
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+          drhodz = (rhow(c,j+1)-rhow(c,j)) / (z_lake(c,j+1)-z_lake(c,j))
+          n2 = grav / rhow(c,j) * drhodz
+          ! Fixed sign error here: our z goes up going down into the lake, so no negative
+          ! sign is needed to make this positive unlike in Hostetler. --ZS
+          num = 40._r8 * n2 * (vkc*z_lake(c,j))**2
+          den = max( (ws(c)**2) * exp(-2._r8*ks(c)*z_lake(c,j)), 1.e-10_r8 )
+          ri = ( -1._r8 + sqrt( max(1._r8+num/den, 0._r8) ) ) / 20._r8
+          if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then
+            ! ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri)
+
+             if( t_lake(c,1) > 277.15_r8 ) then 
+                if (lakedepth(c) > 15.0 ) then 
+                   ke = 1.e+2_r8*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri)
+                else 
+                   ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri)
+                endif
+             else 
+                if (lakedepth(c) > 15.0 ) then 
+                  if (lakedepth(c) > 150.0 ) then 
+                    ke = 1.e+5_r8*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri)
+                  else 
+                    ke =1.e+4_r8*vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri)
+                  end if
+                else 
+                  ke = vkc*ws(c)*z_lake(c,j)/p0 * exp(-ks(c)*z_lake(c,j)) / (1._r8+37._r8*ri*ri)
+                endif 
+             end if
+
+             kme(c,j) = km + ke
+             tk_lake(c,j) = kme(c,j)*cwat
+             ! If there is some ice in this layer (this should rarely happen because the surface
+             ! is unfrozen and it will be unstable), still use the cwat to get out the tk b/c the eddy
+             ! diffusivity equation assumes water.
+          else
+             kme(c,j) = km
+             tk_lake(c,j) = tkwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff &
+                            + tkwat*lake_icefrac(c,j) )
+             ! Assume the resistances add as for the calculation of conductivities at layer interfaces.
+          end if
+       end do
+    end do
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_shlakec
+       c = filter_shlakec(fc)
+
+       j = nlevlake
+       kme(c,nlevlake) = kme(c,nlevlake-1)
+
+       if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then
+          tk_lake(c,j) = tk_lake(c,j-1)
+       else
+          tk_lake(c,j) = tkwat*tkice_eff / ( (1._r8-lake_icefrac(c,j))*tkice_eff &
+                            + tkwat*lake_icefrac(c,j) )
+       end if
+
+       ! Use in surface flux calculation for next timestep.
+       savedtke1(c) = kme(c,1)*cwat ! Will only be used if unfrozen
+       ! set number of column levels for use by Tridiagonal below
+       jtop(c) = snl(c) + 1
+    end do
+
+    ! 4!) Heat source term: unfrozen lakes only
+    do j = 1, nlevlake
+!dir$ concurrent
+!cdir nodep
+       do fp = 1, num_shlakep
+          p = filter_shlakep(fp)
+          c = pcolumn(p)
+
+          ! Set eta(:), the extinction coefficient, according to L Hakanson, Aquatic Sciences, 1995
+          ! (regression of Secchi Depth with lake depth for small glacial basin lakes), and the
+          ! Poole & Atkins expression for extinction coeffient of 1.7 / Secchi Depth (m).
+#ifndef ETALAKE
+          eta(:) = 1.1925_r8*lakedepth(c)**(-0.424)
+#else
+          eta(:) = ETALAKE
+#endif
+
+          zin  = z_lake(c,j) - 0.5_r8*dz_lake(c,j)
+          zout = z_lake(c,j) + 0.5_r8*dz_lake(c,j)
+          rsfin  = exp( -eta(islak)*max(  zin-za(islak),0._r8 ) )
+          rsfout = exp( -eta(islak)*max( zout-za(islak),0._r8 ) )
+
+          ! Let rsfout for bottom layer go into soil.
+          ! This looks like it should be robust even for pathological cases,
+            ! like lakes thinner than za.
+          if (t_grnd(c) > tfrz .and. t_lake(c,1) > tfrz .and. snl(c) == 0) then
+             phidum = (rsfin-rsfout) * sabg(p) * (1._r8-beta(islak))
+             if (j == nlevlake) then
+                phi_soil(c) = rsfout * sabg(p) * (1._r8-beta(islak))
+             end if
+          else if (j == 1 .and. snl(c) == 0) then !if frozen but no snow layers
+             phidum = sabg(p) * (1._r8-beta(islak))
+          else !radiation absorbed at surface
+             phidum = 0._r8
+             if (j == nlevlake) phi_soil(c) = 0._r8
+          end if
+          phi(c,j) = phidum
+
+       end do
+    end do
+
+    ! 5!) Set thermal properties and check initial energy content.
+
+    ! For lake
+    do j = 1, nlevlake
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._r8-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j))
+       end do
+    end do
+
+    ! For snow / soil
+  call SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice,    &
+                           tk, cv, tktopsoillay)
+
+    ! Sum cv*t_lake for energy check
+    ! Include latent heat term, and correction for changing heat capacity with phase change.
+
+    ! This will need to be over all soil / lake / snow layers. Lake is below.
+    do j = 1, nlevlake
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+!          ocvts(c) = ocvts(c) + cv_lake(c,j)*t_lake(c,j) &
+          ocvts(c) = ocvts(c) + cv_lake(c,j)*(t_lake(c,j)-tfrz) &
+                   + cfus*dz_lake(c,j)*(1._r8-lake_icefrac(c,j)) !&
+!                   + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term
+          t_lake_bef(c,j) = t_lake(c,j)
+       end do
+    end do
+
+    ! Now do for soil / snow layers
+    do j = -nlevsnow + 1, nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          if (j >= jtop(c)) then
+!             ocvts(c) = ocvts(c) + cv(c,j)*t_soisno(c,j) &
+             ocvts(c) = ocvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) &
+                      + hfus*h2osoi_liq(c,j) !&
+!                      + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term
+             if (j == 1 .and. h2osno(c) > 0._r8 .and. j == jtop(c)) then
+                ocvts(c) = ocvts(c) - h2osno(c)*hfus
+             end if
+             t_soisno_bef(c,j) = t_soisno(c,j)
+             if(abs(t_soisno(c,j)-288) > 150)   then 
+                WRITE( message,* ) 'WARNING: Extreme t_soisno at c, level',c, j
+                CALL wrf_error_fatal ( message )
+             endif
+          end if
+       end do
+    end do
+
+!!!!!!!!!!!!!!!!!!!
+    ! 6!) Set up vector r and vectors a, b, c1 that define tridiagonal matrix
+
+    ! Heat capacity and resistance of snow without snow layers (<1cm) is ignored during diffusion,
+    ! but its capacity to absorb latent heat may be used during phase change.
+
+    ! Set up interface depths, zx, heat capacities, cvx, solar source terms, phix, and temperatures, tx.
+    do j = -nlevsnow+1, nlevlake+nlevsoil
+!dir$ prefervector
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,num_shlakec
+          c = filter_shlakec(fc)
+
+          jprime = j - nlevlake
+
+          if (j >= jtop(c)) then
+             if (j < 1) then !snow layer
+                zx(c,j) = z(c,j)
+                cvx(c,j) = cv(c,j)
+                phix(c,j) = 0._r8
+                tx(c,j) = t_soisno(c,j)
+             else if (j <= nlevlake) then !lake layer
+                zx(c,j) = z_lake(c,j)
+                cvx(c,j) = cv_lake(c,j)
+                phix(c,j) = phi(c,j)
+                tx(c,j) = t_lake(c,j)
+             else !soil layer
+                zx(c,j) = zx(c,nlevlake) + dz_lake(c,nlevlake)/2._r8 + z(c,jprime)
+                cvx(c,j) = cv(c,jprime)
+                if (j == nlevlake + 1) then !top soil layer
+                   phix(c,j) = phi_soil(c)
+                else !middle or bottom soil layer
+                   phix(c,j) = 0._r8
+                end if
+                tx(c,j) = t_soisno(c,jprime)
+             end if
+          end if
+
+       end do
+    end do
+
+    ! Determine interface thermal conductivities, tkix
+
+    do j = -nlevsnow+1, nlevlake+nlevsoil
+!dir$ prefervector
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,num_shlakec
+          c = filter_shlakec(fc)
+
+          jprime = j - nlevlake
+
+          if (j >= jtop(c)) then
+             if (j < 0) then !non-bottom snow layer
+                tkix(c,j) = tk(c,j)
+             else if (j == 0) then !bottom snow layer
+                dzp = zx(c,j+1) - zx(c,j)
+                tkix(c,j) = tk_lake(c,1)*tk(c,j)*dzp / &
+                      (tk(c,j)*z_lake(c,1) + tk_lake(c,1)*(-z(c,j)) )
+                ! tk(c,0) is the conductivity at the middle of that layer, as defined in SoilThermProp_Lake
+             else if (j < nlevlake) then !non-bottom lake layer
+                tkix(c,j) = ( tk_lake(c,j)*tk_lake(c,j+1) * (dz_lake(c,j+1)+dz_lake(c,j)) ) &
+                           / ( tk_lake(c,j)*dz_lake(c,j+1) + tk_lake(c,j+1)*dz_lake(c,j) )
+             else if (j == nlevlake) then !bottom lake layer
+                dzp = zx(c,j+1) - zx(c,j)
+                tkix(c,j) = (tktopsoillay(c)*tk_lake(c,j)*dzp / &
+                    (tktopsoillay(c)*dz_lake(c,j)/2._r8 + tk_lake(c,j)*z(c,1) ) )
+                    ! tktopsoillay is the conductivity at the middle of that layer, as defined in SoilThermProp_Lake
+             else !soil layer
+                tkix(c,j) = tk(c,jprime)
+             end if
+         end if
+
+      end do 
+   end do
+
+
+    ! Determine heat diffusion through the layer interface and factor used in computing
+    ! tridiagonal matrix and set up vector r and vectors a, b, c1 that define tridiagonal
+    ! matrix and solve system
+
+    do j = -nlevsnow+1, nlevlake+nlevsoil
+!dir$ prefervector
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,num_shlakec
+          c = filter_shlakec(fc)
+          if (j >= jtop(c)) then
+             if (j < nlevlake+nlevsoil) then !top or interior layer
+                factx(c,j) = dtime/cvx(c,j)
+                fnx(c,j) = tkix(c,j)*(tx(c,j+1)-tx(c,j))/(zx(c,j+1)-zx(c,j))
+             else !bottom soil layer
+                factx(c,j) = dtime/cvx(c,j)
+                fnx(c,j) = 0._r8 !not used
+             end if
+          end if
+       enddo
+    end do
+
+    do j = -nlevsnow+1,nlevlake+nlevsoil
+!dir$ prefervector
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,num_shlakec
+          c = filter_shlakec(fc)
+          if (j >= jtop(c)) then
+             if (j == jtop(c)) then !top layer
+                dzp    = zx(c,j+1)-zx(c,j)
+                a(c,j) = 0._r8
+                b(c,j) = 1+(1._r8-cnfac)*factx(c,j)*tkix(c,j)/dzp
+                c1(c,j) =  -(1._r8-cnfac)*factx(c,j)*tkix(c,j)/dzp
+                r(c,j) = tx(c,j) + factx(c,j)*( fin(c) + phix(c,j) + cnfac*fnx(c,j) )
+             else if (j < nlevlake+nlevsoil) then !middle layer
+                dzm    = (zx(c,j)-zx(c,j-1))
+                dzp    = (zx(c,j+1)-zx(c,j))
+                a(c,j) =   - (1._r8-cnfac)*factx(c,j)* tkix(c,j-1)/dzm
+                b(c,j) = 1._r8+ (1._r8-cnfac)*factx(c,j)*(tkix(c,j)/dzp + tkix(c,j-1)/dzm)
+                c1(c,j) =   - (1._r8-cnfac)*factx(c,j)* tkix(c,j)/dzp
+                r(c,j) = tx(c,j) + cnfac*factx(c,j)*( fnx(c,j) - fnx(c,j-1) ) + factx(c,j)*phix(c,j)
+             else  !bottom soil layer
+                dzm     = (zx(c,j)-zx(c,j-1))
+                a(c,j) =   - (1._r8-cnfac)*factx(c,j)*tkix(c,j-1)/dzm
+                b(c,j) = 1._r8+ (1._r8-cnfac)*factx(c,j)*tkix(c,j-1)/dzm
+                c1(c,j) = 0._r8
+                r(c,j) = tx(c,j) - cnfac*factx(c,j)*fnx(c,j-1)
+             end if
+          end if
+       enddo
+    end do
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+    ! 7!) Solve for tdsolution
+
+    call Tridiagonal(lbc, ubc, -nlevsnow + 1, nlevlake + nlevsoil, jtop, num_shlakec, filter_shlakec, &
+                     a, b, c1, r, tx)
+ 
+    ! Set t_soisno and t_lake
+    do j = -nlevsnow+1, nlevlake + nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          jprime = j - nlevlake
+
+          ! Don't do anything with invalid snow layers.
+          if (j >= jtop(c)) then
+             if (j < 1) then !snow layer
+             t_soisno(c,j) = tx(c,j)
+             else if (j <= nlevlake) then !lake layer
+             t_lake(c,j)   = tx(c,j)
+             else !soil layer
+             t_soisno(c,jprime) = tx(c,j)
+             end if
+          end if
+       end do
+    end do
+
+!!!!!!!!!!!!!!!!!!!!!!!
+
+    ! 8!) Sum energy content and total energy into lake for energy check. Any errors will be from the
+    !     Tridiagonal solution.
+
+#if (defined LAKEDEBUG)
+    do j = 1, nlevlake
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          esum1(c) = esum1(c) + (t_lake(c,j)-t_lake_bef(c,j))*cv_lake(c,j)
+          esum2(c) = esum2(c) + (t_lake(c,j)-tfrz)*cv_lake(c,j)
+       end do
+    end do
+
+    do j = -nlevsnow+1, nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          if (j >= jtop(c)) then
+             esum1(c) = esum1(c) + (t_soisno(c,j)-t_soisno_bef(c,j))*cv(c,j)
+             esum2(c) = esum2(c) + (t_soisno(c,j)-tfrz)*cv(c,j)
+          end if
+       end do
+    end do
+
+!dir$ concurrent
+!cdir nodep
+       do fp = 1, num_shlakep
+          p = filter_shlakep(fp)
+          c = pcolumn(p)
+          ! Again assuming only one pft per column
+!          esum1(c) = esum1(c) + lhabs(c)
+          errsoi(c) = esum1(c)/dtime - eflx_soil_grnd(p)
+                    ! eflx_soil_grnd includes all the solar radiation absorbed in the lake,
+                    ! unlike eflx_gnet
+          if(abs(errsoi(c)) > 1.e-5_r8) then
+             WRITE( message,* )'Primary soil energy conservation error in shlake &
+                                column during Tridiagonal Solution,', 'error (W/m^2):', c, errsoi(c) 
+             CALL wrf_error_fatal ( message )
+          end if
+       end do
+       ! This has to be done before convective mixing because the heat capacities for each layer
+       ! will get scrambled.
+
+#endif
+
+!!!!!!!!!!!!!!!!!!!!!!!
+
+    ! 9!) Phase change
+    call PhaseChange_Lake (snl,h2osno,dz,dz_lake,                            & !i
+                               t_soisno,h2osoi_liq,h2osoi_ice,               & !i&o
+                               lake_icefrac,t_lake, snowdp,                  & !i&o
+                               qflx_snomelt,eflx_snomelt,imelt,              & !o  
+                               cv, cv_lake,                                  & !i&o
+                               lhabs)                                          !o
+
+!!!!!!!!!!!!!!!!!!!!!!!
+
+    ! 9.5!) Second energy check and water check.  Now check energy balance before and after phase
+    !       change, considering the possibility of changed heat capacity during phase change, by
+    !       using initial heat capacity in the first step, final heat capacity in the second step,
+    !       and differences from tfrz only to avoid enthalpy correction for (cpliq-cpice)*melt*tfrz.
+    !       Also check soil water sum.
+
+#if (defined LAKEDEBUG)
+    do j = 1, nlevlake
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          esum2(c) = esum2(c) - (t_lake(c,j)-tfrz)*cv_lake(c,j)
+       end do
+    end do
+
+    do j = -nlevsnow+1, nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          if (j >= jtop(c)) then
+             esum2(c) = esum2(c) - (t_soisno(c,j)-tfrz)*cv(c,j)
+          end if
+       end do
+    end do
+
+!dir$ concurrent
+!cdir nodep
+       do fp = 1, num_shlakep
+          p = filter_shlakep(fp)
+          c = pcolumn(p)
+          ! Again assuming only one pft per column
+          esum2(c) = esum2(c) - lhabs(c)
+          errsoi(c) = esum2(c)/dtime
+          if(abs(errsoi(c)) > 1.e-5_r8) then
+             write(message,*)'Primary soil energy conservation error in shlake column during Phase Change, error (W/m^2):', &
+                       c, errsoi(c)
+             CALL wrf_error_fatal ( message )
+          end if
+       end do
+
+    ! Check soil water
+    ! Sum soil water.
+    do j = 1, nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+          if (j == 1) wsum_end(c) = 0._r8
+          wsum_end(c) = wsum_end(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j)
+          if (j == nlevsoil) then
+             if (abs(wsum(c)-wsum_end(c))>1.e-7_r8) then
+                write(message,*)'Soil water balance error during phase change in ShalLakeTemperature.', &
+                          'column, error (kg/m^2):', c, wsum_end(c)-wsum(c)
+                CALL wrf_error_fatal ( message )
+             end if
+          end if
+       end do
+    end do
+
+#endif
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! 10!) Convective mixing: make sure fracice*dz is conserved, heat content c*dz*T is conserved, and
+    ! all ice ends up at the top. Done over all lakes even if frozen.
+    ! Either an unstable density profile or ice in a layer below an incompletely frozen layer will trigger.
+
+    !Recalculate density
+    do j = 1, nlevlake
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+          rhow(c,j) = (1._r8 - lake_icefrac(c,j)) * &
+                      1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,j)-277._r8))**1.68_r8 ) &
+                    + lake_icefrac(c,j)*denice
+       end do
+    end do
+
+    do j = 1, nlevlake-1
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+          qav(c) = 0._r8
+          nav(c) = 0._r8
+          iceav(c) = 0._r8
+       end do
+
+       do i = 1, j+1
+!dir$ concurrent
+!cdir nodep
+          do fc = 1, num_shlakec
+             c = filter_shlakec(fc)
+             if (rhow(c,j) > rhow(c,j+1) .or. &
+                (lake_icefrac(c,j) < 1._r8 .and. lake_icefrac(c,j+1) > 0._r8) ) then
+#if (defined LAKEDEBUG)
+                if (i==1)  then
+                  write(message,*), 'Convective Mixing in column ', c, '.'
+                  CALL wrf_message(message)
+                endif
+#endif
+                qav(c) = qav(c) + dz_lake(c,i)*(t_lake(c,i)-tfrz) * & 
+                        ((1._r8 - lake_icefrac(c,i))*cwat + lake_icefrac(c,i)*cice_eff)
+!                tav(c) = tav(c) + t_lake(c,i)*dz_lake(c,i)
+                iceav(c) = iceav(c) + lake_icefrac(c,i)*dz_lake(c,i)
+                nav(c) = nav(c) + dz_lake(c,i)
+             end if
+          end do
+       end do
+
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+          if (rhow(c,j) > rhow(c,j+1) .or. &
+             (lake_icefrac(c,j) < 1._r8 .and. lake_icefrac(c,j+1) > 0._r8) ) then
+             qav(c) = qav(c)/nav(c)
+             iceav(c) = iceav(c)/nav(c)
+             !If the average temperature is above freezing, put the extra energy into the water.
+             !If it is below freezing, take it away from the ice.
+             if (qav(c) > 0._r8) then
+                tav_froz(c) = 0._r8 !Celsius
+                tav_unfr(c) = qav(c) / ((1._r8 - iceav(c))*cwat)
+             else if (qav(c) < 0._r8) then
+                tav_froz(c) = qav(c) / (iceav(c)*cice_eff)
+                tav_unfr(c) = 0._r8 !Celsius
+             else
+                tav_froz(c) = 0._r8
+                tav_unfr(c) = 0._r8
+             end if
+          end if
+       end do
+
+       do i = 1, j+1
+!dir$ concurrent
+!cdir nodep
+          do fc = 1, num_shlakec
+             c = filter_shlakec(fc)
+             if (nav(c) > 0._r8) then
+!             if(0==1) then
+
+                !Put all the ice at the top.!
+                !If the average temperature is above freezing, put the extra energy into the water.
+                !If it is below freezing, take it away from the ice.
+                !For the layer with both ice & water, be careful to use the average temperature
+                !that preserves the correct total heat content given what the heat capacity of that
+                !layer will actually be.
+                if (i == 1) zsum(c) = 0._r8
+                if ((zsum(c)+dz_lake(c,i))/nav(c) <= iceav(c)) then
+                   lake_icefrac(c,i) = 1._r8
+                   t_lake(c,i) = tav_froz(c) + tfrz
+                else if (zsum(c)/nav(c) < iceav(c)) then
+                   lake_icefrac(c,i) = (iceav(c)*nav(c) - zsum(c)) / dz_lake(c,i)
+                   ! Find average value that preserves correct heat content.
+                   t_lake(c,i) = ( lake_icefrac(c,i)*tav_froz(c)*cice_eff &
+                               + (1._r8 - lake_icefrac(c,i))*tav_unfr(c)*cwat ) &
+                               / ( lake_icefrac(c,i)*cice_eff + (1-lake_icefrac(c,i))*cwat ) + tfrz
+                else
+                   lake_icefrac(c,i) = 0._r8
+                   t_lake(c,i) = tav_unfr(c) + tfrz
+                end if
+                zsum(c) = zsum(c) + dz_lake(c,i)
+
+                rhow(c,i) = (1._r8 - lake_icefrac(c,i)) * & 
+                            1000._r8*( 1.0_r8 - 1.9549e-05_r8*(abs(t_lake(c,i)-277._r8))**1.68_r8 ) &
+                          + lake_icefrac(c,i)*denice
+             end if
+          end do
+       end do
+    end do
+
+!!!!!!!!!!!!!!!!!!!!!!!
+    ! 11!) Re-evaluate thermal properties and sum energy content.
+    ! For lake
+    do j = 1, nlevlake
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          cv_lake(c,j) = dz_lake(c,j) * (cwat*(1._r8-lake_icefrac(c,j)) + cice_eff*lake_icefrac(c,j))
+#if (defined LAKEDEBUG)
+          write(message,*)'Lake Ice Fraction, c, level:', c, j, lake_icefrac(c,j)
+          CALL wrf_message(message)
+#endif
+       end do
+    end do
+    ! For snow / soil
+  !  call SoilThermProp_Lake(lbc, ubc, num_shlakec, filter_shlakec, tk, cv, tktopsoillay)
+  call SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice,    &
+                           tk, cv, tktopsoillay)
+
+
+    ! Do as above to sum energy content
+    do j = 1, nlevlake
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+!          ncvts(c) = ncvts(c) + cv_lake(c,j)*t_lake(c,j) &
+          ncvts(c) = ncvts(c) + cv_lake(c,j)*(t_lake(c,j)-tfrz) &
+                   + cfus*dz_lake(c,j)*(1._r8-lake_icefrac(c,j)) !&
+!                   + (cwat-cice_eff)*lake_icefrac(c)*tfrz*dz_lake(c,j) !enthalpy reconciliation term
+          fin(c) = fin(c) + phi(c,j)
+       end do
+    end do
+
+    do j = -nlevsnow + 1, nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          if (j >= jtop(c)) then
+!             ncvts(c) = ncvts(c) + cv(c,j)*t_soisno(c,j) &
+             ncvts(c) = ncvts(c) + cv(c,j)*(t_soisno(c,j)-tfrz) &
+                      + hfus*h2osoi_liq(c,j) !&
+!                      + (cpliq-cpice)*h2osoi_ice(c,j)*tfrz !enthalpy reconciliation term
+             if (j == 1 .and. h2osno(c) > 0._r8 .and. j == jtop(c)) then
+                ncvts(c) = ncvts(c) - h2osno(c)*hfus
+             end if
+          end if
+          if (j == 1) fin(c) = fin(c) + phi_soil(c)
+       end do
+    end do
+
+
+    ! Check energy conservation.
+
+    do fp = 1, num_shlakep
+       p = filter_shlakep(fp)
+       c = pcolumn(p)
+       errsoi(c) = (ncvts(c)-ocvts(c)) / dtime - fin(c)
+#ifndef LAKEDEBUG
+!       if (abs(errsoi(c)) < 0.10_r8) then ! else send to Balance Check and abort
+       if (abs(errsoi(c)) < 10._r8) then ! else send to Balance Check and abort
+#else
+       if (abs(errsoi(c)) < 1._r8) then
+#endif
+          eflx_sh_tot(p) = eflx_sh_tot(p) - errsoi(c)
+          eflx_sh_grnd(p) = eflx_sh_grnd(p) - errsoi(c)
+          eflx_soil_grnd(p) = eflx_soil_grnd(p) + errsoi(c)
+          eflx_gnet(p) = eflx_gnet(p) + errsoi(c)
+!          if (abs(errsoi(c)) > 1.e-3_r8) then
+          if (abs(errsoi(c)) > 1.e-1_r8) then
+             write(message,*)'errsoi incorporated into sensible heat in ShalLakeTemperature: c, (W/m^2):', c, errsoi(c)
+             CALL wrf_message(message)
+          end if
+          errsoi(c) = 0._r8
+#if (defined LAKEDEBUG)
+       else
+          write(message,*)'Soil Energy Balance Error at column, ', c, 'G, fintotal, column E tendency = ', &
+             eflx_gnet(p), fin(c), (ncvts(c)-ocvts(c)) / dtime
+          CALL wrf_message(message)
+#endif
+       end if
+    end do
+    ! This loop assumes only one point per column.
+
+  end subroutine ShalLakeTemperature
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!-----------------------------------------------------------------------
+!BOP
+!
+! ROUTINE: SoilThermProp_Lake
+!
+! !INTERFACE:
+  subroutine SoilThermProp_Lake (snl,dz,zi,z,t_soisno,h2osoi_liq,h2osoi_ice,    &
+                           tk, cv, tktopsoillay)
+
+!
+! !DESCRIPTION:
+! Calculation of thermal conductivities and heat capacities of
+! snow/soil layers
+! (1) The volumetric heat capacity is calculated as a linear combination
+!     in terms of the volumetric fraction of the constituent phases.
+!
+! (2) The thermal conductivity of soil is computed from the algorithm of
+!     Johansen (as reported by Farouki 1981), and of snow is from the
+!     formulation used in SNTHERM (Jordan 1991).
+! The thermal conductivities at the interfaces between two neighboring
+! layers (j, j+1) are derived from an assumption that the flux across
+! the interface is equal to that from the node j to the interface and the
+! flux from the interface to the node j+1.
+!
+! For lakes, the proper soil layers (not snow) should always be saturated.
+!
+! !USES:
+
+    implicit none
+!in
+
+    integer , intent(in) :: snl(1)           ! number of snow layers
+!    real(r8), intent(in) :: h2osno(1)        ! snow water (mm H2O)
+   ! real(r8), intent(in) :: watsat(1,nlevsoil)      ! volumetric soil water at saturation (porosity)
+   ! real(r8), intent(in) :: tksatu(1,nlevsoil)      ! thermal conductivity, saturated soil [W/m-K]
+   ! real(r8), intent(in) :: tkmg(1,nlevsoil)        ! thermal conductivity, soil minerals  [W/m-K]
+   ! real(r8), intent(in) :: tkdry(1,nlevsoil)       ! thermal conductivity, dry soil (W/m/Kelvin)
+   ! real(r8), intent(in) :: csol(1,nlevsoil)        ! heat capacity, soil solids (J/m**3/Kelvin)
+    real(r8), intent(in) :: dz(1,-nlevsnow+1:nlevsoil)          ! layer thickness (m)
+    real(r8), intent(in) :: zi(1,-nlevsnow+0:nlevsoil)          ! interface level below a "z" level (m)
+    real(r8), intent(in) :: z(1,-nlevsnow+1:nlevsoil)           ! layer depth (m)
+    real(r8), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil)    ! soil temperature (Kelvin)
+    real(r8), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil)  ! liquid water (kg/m2)
+    real(r8), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil)  ! ice lens (kg/m2)
+
+!out
+    real(r8), intent(out) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil) ! heat capacity [J/(m2 K)]
+    real(r8), intent(out) :: tk(lbc:ubc,-nlevsnow+1:nlevsoil) ! thermal conductivity [W/(m K)]
+    real(r8), intent(out) :: tktopsoillay(lbc:ubc)          ! thermal conductivity [W/(m K)]
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !CALLED FROM:
+! subroutine ShalLakeTemperature in this module.
+!
+! !REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+! 2/13/02, Peter Thornton: migrated to new data structures
+! 7/01/03, Mariana Vertenstein: migrated to vector code
+! 4/09, Zack Subin, adjustment for ShalLake code.
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! !LOCAL VARIABLES:
+!
+! local pointers to original implicit in scalars
+!
+!    integer , pointer :: clandunit(:)     ! column's landunit
+!    integer , pointer :: ityplun(:)       ! landunit type
+!
+!EOP
+
+
+! OTHER LOCAL VARIABLES:
+
+    integer  :: l,c,j                     ! indices
+    integer  :: fc                        ! lake filtered column indices
+    real(r8) :: bw                        ! partial density of water (ice + liquid)
+    real(r8) :: dksat                     ! thermal conductivity for saturated soil (j/(k s m))
+    real(r8) :: dke                       ! kersten number
+    real(r8) :: fl                        ! fraction of liquid or unfrozen water to total water
+    real(r8) :: satw                      ! relative total water content of soil.
+    real(r8) :: thk(lbc:ubc,-nlevsnow+1:nlevsoil) ! thermal conductivity of layer
+    character*256 :: message 
+
+! Thermal conductivity of soil from Farouki (1981)
+
+    do j = -nlevsnow+1,nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          ! Only examine levels from 1->nlevsoil
+          if (j >= 1) then
+!             l = clandunit(c)
+!             if (ityplun(l) /= istwet .AND. ityplun(l) /= istice) then
+              ! This could be altered later for allowing this to be over glaciers.
+
+          ! Soil should be saturated.
+#if (defined LAKEDEBUG)
+                satw = (h2osoi_liq(c,j)/denh2o + h2osoi_ice(c,j)/denice)/(dz(c,j)*watsat(c,j))
+!                satw = min(1._r8, satw)
+                if (satw < 0.999_r8) then
+                   write(message,*)'WARNING: soil layer unsaturated in SoilThermProp_Lake, satw, j = ', satw, j
+                   CALL wrf_error_fatal ( message )
+                end if
+          ! Could use denice because if it starts out frozen, the volume of water will go below sat.,
+          ! since we're not yet doing excess ice.
+          ! But take care of this in HydrologyLake.
+#endif
+                satw = 1._r8
+                   fl = h2osoi_liq(c,j)/(h2osoi_ice(c,j)+h2osoi_liq(c,j))
+                   if (t_soisno(c,j) >= tfrz) then       ! Unfrozen soil
+                      dke = max(0._r8, log10(satw) + 1.0_r8)
+                      dksat = tksatu(c,j)
+                   else                               ! Frozen soil
+                      dke = satw
+                      dksat = tkmg(c,j)*0.249_r8**(fl*watsat(c,j))*2.29_r8**watsat(c,j)
+                   endif
+                   thk(c,j) = dke*dksat + (1._r8-dke)*tkdry(c,j)
+!             else
+!                thk(c,j) = tkwat
+!                if (t_soisno(c,j) < tfrz) thk(c,j) = tkice
+!             endif
+          endif
+
+          ! Thermal conductivity of snow, which from Jordan (1991) pp. 18
+          ! Only examine levels from snl(c)+1 -> 0 where snl(c) < 1
+          if (snl(c)+1 < 1 .AND. (j >= snl(c)+1) .AND. (j <= 0)) then
+             bw = (h2osoi_ice(c,j)+h2osoi_liq(c,j))/dz(c,j)
+             thk(c,j) = tkairc + (7.75e-5_r8 *bw + 1.105e-6_r8*bw*bw)*(tkice-tkairc)
+          end if
+
+       end do
+    end do
+
+    ! Thermal conductivity at the layer interface
+
+    ! Have to correct for the fact that bottom snow layer and top soil layer border lake.
+    ! For the first case, the snow layer conductivity for the middle of the layer will be returned.
+    ! Because the interfaces are below the soil layers, the conductivity for the top soil layer
+    ! will have to be returned separately.
+    do j = -nlevsnow+1,nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,num_shlakec
+          c = filter_shlakec(fc)
+          if (j >= snl(c)+1 .AND. j <= nlevsoil-1 .AND. j /= 0) then
+             tk(c,j) = thk(c,j)*thk(c,j+1)*(z(c,j+1)-z(c,j)) &
+                  /(thk(c,j)*(z(c,j+1)-zi(c,j))+thk(c,j+1)*(zi(c,j)-z(c,j)))
+          else if (j == 0) then
+             tk(c,j) = thk(c,j)
+          else if (j == nlevsoil) then
+             tk(c,j) = 0._r8
+          end if
+          ! For top soil layer.
+          if (j == 1) tktopsoillay(c) = thk(c,j)
+       end do
+    end do
+
+    ! Soil heat capacity, from de Vires (1963)
+
+    do j = 1, nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,num_shlakec
+          c = filter_shlakec(fc)
+!          l = clandunit(c)
+!          if (ityplun(l) /= istwet .AND. ityplun(l) /= istice) then
+             cv(c,j) = csol(c,j)*(1-watsat(c,j))*dz(c,j) +   &
+               (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq)
+!          else
+!             cv(c,j) = (h2osoi_ice(c,j)*cpice + h2osoi_liq(c,j)*cpliq)
+!          endif
+!          if (j == 1) then
+!             if (snl(c)+1 == 1 .AND. h2osno(c) > 0._r8) then
+!                cv(c,j) = cv(c,j) + cpice*h2osno(c)
+!             end if
+!          end if
+       ! Won't worry about heat capacity for thin snow on lake with no snow layers.
+       enddo
+    end do
+
+    ! Snow heat capacity
+
+    do j = -nlevsnow+1,0
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,num_shlakec
+          c = filter_shlakec(fc)
+          if (snl(c)+1 < 1 .and. j >= snl(c)+1) then
+             cv(c,j) = cpliq*h2osoi_liq(c,j) + cpice*h2osoi_ice(c,j)
+          end if
+       end do
+    end do
+
+  end subroutine SoilThermProp_Lake
+
+
+!-----------------------------------------------------------------------
+!BOP
+!
+! ROUTINE: PhaseChange_Lake
+!
+! !INTERFACE:
+  subroutine PhaseChange_Lake (snl,h2osno,dz,dz_lake,                        & !i
+                               t_soisno,h2osoi_liq,h2osoi_ice,               & !i&o
+                               lake_icefrac,t_lake, snowdp,                  & !i&o
+                               qflx_snomelt,eflx_snomelt,imelt,              & !o  
+                               cv, cv_lake,                                  & !i&o
+                               lhabs)                                          !o
+!=============================================================================================
+! !DESCRIPTION:
+! Calculation of the phase change within snow, soil, & lake layers:
+! (1) Check the conditions for which the phase change may take place,
+!     i.e., the layer temperature is great than the freezing point
+!     and the ice mass is not equal to zero (i.e. melting),
+!     or the layer temperature is less than the freezing point
+!     and the liquid water mass is greater than the allowable supercooled 
+!    (i.e. freezing).
+! (2) Assess the amount of phase change from the energy excess (or deficit)
+!     after setting the layer temperature to freezing point, depending on
+!     how much water or ice is available.
+! (3) Re-adjust the ice and liquid mass, and the layer temperature: either to
+!     the freezing point if enough water or ice is available to fully compensate,
+!     or to a remaining temperature.
+! The specific heats are assumed constant. Potential cycling errors resulting from
+! this assumption will be trapped at the end of ShalLakeTemperature.
+! !CALLED FROM:
+! subroutine ShalLakeTemperature in this module
+!
+! !REVISION HISTORY:
+! 04/2009 Zack Subin: Initial code
+!==============================================================================================
+! !USES:
+!
+! !ARGUMENTS:
+    implicit none
+!in: 
+
+    integer , intent(in) :: snl(1)           !number of snow layers
+    real(r8), intent(inout) :: h2osno(1)        !snow water (mm H2O)
+    real(r8), intent(in) :: dz(1,-nlevsnow+1:nlevsoil)          !layer thickness (m)
+    real(r8), intent(in) :: dz_lake(1,nlevlake)     !lake layer thickness (m)
+    ! Needed in case snow height is less than critical value.
+
+!inout: 
+
+    real(r8), intent(inout) :: snowdp(1)        !snow height (m)
+    real(r8), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil)     !soil temperature (Kelvin)
+    real(r8), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil)   !liquid water (kg/m2)
+    real(r8), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil)   !ice lens (kg/m2)
+    real(r8), intent(inout) :: lake_icefrac(1,nlevlake) ! mass fraction of lake layer that is frozen
+    real(r8), intent(inout) :: t_lake(1,nlevlake)       ! lake temperature (Kelvin)
+!out: 
+
+    real(r8), intent(out) :: qflx_snomelt(1)  !snow melt (mm H2O /s)
+    real(r8), intent(out) :: eflx_snomelt(1)  !snow melt heat flux (W/m**2)
+    integer, intent(out)  :: imelt(1,-nlevsnow+1:nlevsoil)        !flag for melting (=1), freezing (=2), Not=0 (new)
+                                          !What's the sign of this? Is it just output?
+    real(r8), intent(inout) :: cv(lbc:ubc,-nlevsnow+1:nlevsoil)       ! heat capacity [J/(m2 K)]
+    real(r8), intent(inout) :: cv_lake (lbc:ubc,1:nlevlake)          ! heat capacity [J/(m2 K)]
+    real(r8), intent(out):: lhabs(lbc:ubc)                       ! total per-column latent heat abs. (J/m^2)
+
+
+! OTHER LOCAL VARIABLES:
+
+    integer  :: j,c,g                              !do loop index
+    integer  :: fc                                 !lake filtered column indices
+!    real(r8) :: dtime                              !land model time step (sec)
+    real(r8) :: heatavail                          !available energy for melting or freezing (J/m^2)
+    real(r8) :: heatrem                            !energy residual or loss after melting or freezing
+    real(r8) :: melt                               !actual melting (+) or freezing (-) [kg/m2]
+    real(r8), parameter :: smallnumber = 1.e-7_r8  !to prevent tiny residuals from rounding error
+    logical  :: dophasechangeflag
+!-----------------------------------------------------------------------
+
+!    dtime = get_step_size()
+
+    ! Initialization
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1,num_shlakec
+       c = filter_shlakec(fc)
+
+       qflx_snomelt(c) = 0._r8
+       eflx_snomelt(c) = 0._r8
+       lhabs(c)        = 0._r8
+    end do
+
+    do j = -nlevsnow+1,0
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,num_shlakec
+          c = filter_shlakec(fc)
+
+          if (j >= snl(c) + 1) imelt(c,j) = 0
+       end do
+    end do
+
+    ! Check for case of snow without snow layers and top lake layer temp above freezing.
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1,num_shlakec
+       c = filter_shlakec(fc)
+
+       if (snl(c) == 0 .and. h2osno(c) > 0._r8 .and. t_lake(c,1) > tfrz) then
+          heatavail = (t_lake(c,1) - tfrz) * cv_lake(c,1)
+          melt = min(h2osno(c), heatavail/hfus)
+          heatrem = max(heatavail - melt*hfus, 0._r8)
+                       !catch small negative value to keep t at tfrz
+          t_lake(c,1) = tfrz + heatrem/(cv_lake(c,1))
+          snowdp(c) = snowdp(c)*(1._r8 - melt/h2osno(c))
+          h2osno(c) = h2osno(c) - melt
+          lhabs(c) = lhabs(c) + melt*hfus
+          qflx_snomelt(c) = qflx_snomelt(c) + melt
+          ! Prevent tiny residuals
+          if (h2osno(c) < smallnumber) h2osno(c) = 0._r8
+          if (snowdp(c) < smallnumber) snowdp(c) = 0._r8
+       end if
+    end do
+
+    ! Lake phase change
+
+    do j = 1,nlevlake
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,num_shlakec
+          c = filter_shlakec(fc)
+
+          dophasechangeflag = .false.
+          if (t_lake(c,j) > tfrz .and. lake_icefrac(c,j) > 0._r8) then ! melting
+             dophasechangeflag = .true.
+             heatavail = (t_lake(c,j) - tfrz) * cv_lake(c,j)
+             melt = min(lake_icefrac(c,j)*denh2o*dz_lake(c,j), heatavail/hfus)
+                        !denh2o is used because layer thickness is not adjusted for freezing
+             heatrem = max(heatavail - melt*hfus, 0._r8)
+                       !catch small negative value to keep t at tfrz
+          else if (t_lake(c,j) < tfrz .and. lake_icefrac(c,j) < 1._r8) then !freezing
+             dophasechangeflag = .true.
+             heatavail = (t_lake(c,j) - tfrz) * cv_lake(c,j)
+             melt = max(-(1._r8-lake_icefrac(c,j))*denh2o*dz_lake(c,j), heatavail/hfus)
+                        !denh2o is used because layer thickness is not adjusted for freezing
+             heatrem = min(heatavail - melt*hfus, 0._r8)
+                       !catch small positive value to keep t at tfrz
+          end if
+          ! Update temperature and ice fraction.
+          if (dophasechangeflag) then
+             lake_icefrac(c,j) = lake_icefrac(c,j) - melt/(denh2o*dz_lake(c,j))
+             lhabs(c) = lhabs(c) + melt*hfus
+          ! Update heat capacity
+             cv_lake(c,j) = cv_lake(c,j) + melt*(cpliq-cpice)
+             t_lake(c,j) = tfrz + heatrem/cv_lake(c,j)
+             ! Prevent tiny residuals
+             if (lake_icefrac(c,j) > 1._r8 - smallnumber) lake_icefrac(c,j) = 1._r8
+             if (lake_icefrac(c,j) < smallnumber)         lake_icefrac(c,j) = 0._r8
+          end if
+       end do
+    end do
+
+    ! Snow & soil phase change
+
+    do j = -nlevsnow+1,nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,num_shlakec
+          c = filter_shlakec(fc)
+          dophasechangeflag = .false.
+
+          if (j >= snl(c) + 1) then
+
+             if (t_soisno(c,j) > tfrz .and. h2osoi_ice(c,j) > 0._r8) then ! melting
+                dophasechangeflag = .true.
+                heatavail = (t_soisno(c,j) - tfrz) * cv(c,j)
+                melt = min(h2osoi_ice(c,j), heatavail/hfus)
+                heatrem = max(heatavail - melt*hfus, 0._r8)
+                          !catch small negative value to keep t at tfrz
+                if (j <= 0) then !snow
+                   imelt(c,j) = 1
+                   qflx_snomelt(c) = qflx_snomelt(c) + melt
+                end if
+             else if (t_soisno(c,j) < tfrz .and. h2osoi_liq(c,j) > 0._r8) then !freezing
+                dophasechangeflag = .true.
+                heatavail = (t_soisno(c,j) - tfrz) * cv(c,j)
+                melt = max(-h2osoi_liq(c,j), heatavail/hfus)
+                heatrem = min(heatavail - melt*hfus, 0._r8)
+                          !catch small positive value to keep t at tfrz
+                if (j <= 0) then !snow
+                   imelt(c,j) = 2
+                   qflx_snomelt(c) = qflx_snomelt(c) + melt
+                   ! Does this works for both signs of melt in SnowHydrology? I think
+                   ! qflx_snomelt(c) is just output.
+                end if
+             end if
+
+             ! Update temperature and soil components.
+             if (dophasechangeflag) then
+                h2osoi_ice(c,j) = h2osoi_ice(c,j) - melt
+                h2osoi_liq(c,j) = h2osoi_liq(c,j) + melt
+                lhabs(c) = lhabs(c) + melt*hfus
+             ! Update heat capacity
+                cv(c,j) = cv(c,j) + melt*(cpliq-cpice)
+                t_soisno(c,j) = tfrz + heatrem/cv(c,j)
+                ! Prevent tiny residuals
+                if (h2osoi_ice(c,j) < smallnumber) h2osoi_ice(c,j) = 0._r8
+                if (h2osoi_liq(c,j) < smallnumber) h2osoi_liq(c,j) = 0._r8
+             end if
+
+         end if
+      end do
+   end do
+
+   ! Update eflx_snomelt(c)
+!dir$ concurrent
+!cdir nodep
+    do fc = 1,num_shlakec
+       c = filter_shlakec(fc)
+       eflx_snomelt(c) = qflx_snomelt(c)*hfus
+    end do
+!!!
+
+   end subroutine PhaseChange_Lake
+
+
+  subroutine ShalLakeHydrology(dz_lake,forc_rain,forc_snow,                      & !i
+                               begwb,qflx_evap_tot,forc_t,do_capsnow,            &
+                               t_grnd,qflx_evap_soi,                             &
+                               qflx_snomelt,imelt,frac_iceold,                   & !i add by guhp
+                               z,dz,zi,snl,h2osno,snowdp,lake_icefrac,t_lake,      & !i&o
+                               endwb,snowage,snowice,snowliq,t_snow,             & !o
+                               t_soisno,h2osoi_ice,h2osoi_liq,h2osoi_vol,        &
+                               qflx_drain,qflx_surf,qflx_infl,qflx_qrgwl,        &
+                               qcharge,qflx_prec_grnd,qflx_snowcap,              &
+                               qflx_snowcap_col,qflx_snow_grnd_pft,              &
+                               qflx_snow_grnd_col,qflx_rain_grnd,                &
+                               qflx_evap_tot_col,soilalpha,zwt,fcov,             &
+                               rootr_column,qflx_evap_grnd,qflx_sub_snow,        &
+                               qflx_dew_snow,qflx_dew_grnd,qflx_rain_grnd_col)
+                       
+!==================================================================================
+! !DESCRIPTION:
+! Calculation of Shallow Lake Hydrology. Full hydrology of snow layers is
+! done. However, there is no infiltration, and the water budget is balanced with 
+! qflx_qrgwl. Lake water mass is kept constant. The soil is simply maintained at
+! volumetric saturation if ice melting frees up pore space. Likewise, if the water
+! portion alone at some point exceeds pore capacity, it is reduced. This is consistent
+! with the possibility of initializing the soil layer with excess ice. The only
+! real error with that is that the thermal conductivity will ignore the excess ice
+! (and accompanying thickness change).
+! 
+! If snow layers are present over an unfrozen lake, and the top layer of the lake
+! is capable of absorbing the latent heat without going below freezing, 
+! the snow-water is runoff and the latent heat is subtracted from the lake.
+!
+! WARNING: This subroutine assumes lake columns have one and only one pft.
+!
+! Sequence is:
+!  ShalLakeHydrology:
+!    Do needed tasks from Hydrology1, Biogeophysics2, & top of Hydrology2.
+!    -> SnowWater:             change of snow mass and snow water onto soil
+!    -> SnowCompaction:        compaction of snow layers
+!    -> CombineSnowLayers:     combine snow layers that are thinner than minimum
+!    -> DivideSnowLayers:      subdivide snow layers that are thicker than maximum
+!    Add water to soil if melting has left it with open pore space.
+!    Cleanup and do water balance.
+!    If snow layers are found above a lake with unfrozen top layer, whose top
+!    layer has enough heat to melt all the snow ice without freezing, do so
+!    and eliminate the snow layers.
+!
+! !REVISION HISTORY:
+! Created by Zack Subin, 2009
+!
+!============================================================================================
+
+! USES:
+!
+    implicit none
+
+! in:
+
+   ! integer , intent(in) :: clandunit(1)     ! column's landunit
+   ! integer , intent(in) :: ityplun(1)       ! landunit type
+   ! real(r8), intent(in) :: watsat(1,1:nlevsoil)      ! volumetric soil water at saturation (porosity)
+    real(r8), intent(in) :: dz_lake(1,nlevlake)     ! layer thickness for lake (m)
+    real(r8), intent(in) :: forc_rain(1)     ! rain rate [mm/s]
+    real(r8), intent(in) :: forc_snow(1)     ! snow rate [mm/s]
+    real(r8), intent(in) :: qflx_evap_tot(1) ! qflx_evap_soi + qflx_evap_veg + qflx_tran_veg
+    real(r8), intent(in) :: forc_t(1)        ! atmospheric temperature (Kelvin)
+#if (defined OFFLINE)
+    real(r8), intent(in) :: flfall(1)        ! fraction of liquid water within falling precipitation
+#endif
+    logical , intent(in) :: do_capsnow(1)     ! true => do snow capping
+    real(r8), intent(in) :: t_grnd(1)          ! ground temperature (Kelvin)
+    real(r8), intent(in) :: qflx_evap_soi(1)   ! soil evaporation (mm H2O/s) (+ = to atm)
+    real(r8), intent(in) :: qflx_snomelt(1)     !snow melt (mm H2O /s)
+    integer,  intent(in) :: imelt(1,-nlevsnow+1:nlevsoil)        !flag for melting (=1), freezing (=2), Not=0
+
+!inout:
+
+    real(r8), intent(inout) :: begwb(1)         ! water mass begining of the time step
+
+! inout: 
+
+    
+    real(r8), intent(inout) :: z(1,-nlevsnow+1:nlevsoil)           ! layer depth  (m)
+    real(r8), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil)          ! layer thickness depth (m)
+    real(r8), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil)          ! interface depth (m)
+    integer , intent(inout) :: snl(1)           ! number of snow layers
+    real(r8), intent(inout) :: h2osno(1)        ! snow water (mm H2O)
+    real(r8), intent(inout) :: snowdp(1)        ! snow height (m)
+    real(r8), intent(inout) :: lake_icefrac(1,nlevlake)  ! mass fraction of lake layer that is frozen
+    real(r8), intent(inout) :: t_lake(1,nlevlake)        ! lake temperature (Kelvin)
+
+    real(r8), intent(inout) :: frac_iceold(1,-nlevsnow+1:nlevsoil)      ! fraction of ice relative to the tot water
+! out: 
+
+
+    real(r8), intent(out) :: endwb(1)         ! water mass end of the time step
+    real(r8), intent(out) :: snowage(1)       ! non dimensional snow age [-]
+    real(r8), intent(out) :: snowice(1)       ! average snow ice lens
+    real(r8), intent(out) :: snowliq(1)       ! average snow liquid water
+    real(r8), intent(out) :: t_snow(1)        ! vertically averaged snow temperature
+    real(r8), intent(out) :: t_soisno(1,-nlevsnow+1:nlevsoil)    ! snow temperature (Kelvin)
+    real(r8), intent(out) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil)  ! ice lens (kg/m2)
+    real(r8), intent(out) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil)  ! liquid water (kg/m2)
+    real(r8), intent(out) :: h2osoi_vol(1,-nlevsnow+1:nlevsoil)  ! volumetric soil water (0<=h2osoi_vol<=watsat)[m3/m3]
+    real(r8), intent(out) :: qflx_drain(1)    ! sub-surface runoff (mm H2O /s)
+    real(r8), intent(out) :: qflx_surf(1)     ! surface runoff (mm H2O /s)
+    real(r8), intent(out) :: qflx_infl(1)     ! infiltration (mm H2O /s)
+    real(r8), intent(out) :: qflx_qrgwl(1)    ! qflx_surf at glaciers, wetlands, lakes
+    real(r8), intent(out) :: qcharge(1)       ! aquifer recharge rate (mm/s)
+    real(r8), intent(out) :: qflx_prec_grnd(1)     ! water onto ground including canopy runoff [kg/(m2 s)]
+    real(r8), intent(out) :: qflx_snowcap(1)       ! excess precipitation due to snow capping (mm H2O /s) [+]
+    real(r8), intent(out) :: qflx_snowcap_col(1)   ! excess precipitation due to snow capping (mm H2O /s) [+]
+    real(r8), intent(out) :: qflx_snow_grnd_pft(1) ! snow on ground after interception (mm H2O/s) [+]
+    real(r8), intent(out) :: qflx_snow_grnd_col(1) ! snow on ground after interception (mm H2O/s) [+]
+    real(r8), intent(out) :: qflx_rain_grnd(1)     ! rain on ground after interception (mm H2O/s) [+]
+    real(r8), intent(out) :: qflx_evap_tot_col(1) !pft quantity averaged to the column (assuming one pft)
+    real(r8) ,intent(out) :: soilalpha(1)     !factor that reduces ground saturated specific humidity (-)
+    real(r8), intent(out) :: zwt(1)           !water table depth
+    real(r8), intent(out) :: fcov(1)          !fractional area with water table at surface
+    real(r8), intent(out) :: rootr_column(1,1:nlevsoil) !effective fraction of roots in each soil layer
+    real(r8), intent(out) :: qflx_evap_grnd(1)  ! ground surface evaporation rate (mm H2O/s) [+]
+    real(r8), intent(out) :: qflx_sub_snow(1)   ! sublimation rate from snow pack (mm H2O /s) [+]
+    real(r8), intent(out) :: qflx_dew_snow(1)   ! surface dew added to snow pack (mm H2O /s) [+]
+    real(r8), intent(out) :: qflx_dew_grnd(1)   ! ground surface dew formation (mm H2O /s) [+]
+    real(r8), intent(out) :: qflx_rain_grnd_col(1)   !rain on ground after interception (mm H2O/s) [+]
+
+! Block of biogeochem currently not used.
+#ifndef SHLAKE
+    real(r8), pointer :: sucsat(:,:)      ! minimum soil suction (mm)
+    real(r8), pointer :: bsw(:,:)         ! Clapp and Hornberger "b"
+    real(r8), pointer :: bsw2(:,:)        ! Clapp and Hornberger "b" for CN code
+    real(r8), pointer :: psisat(:,:)      ! soil water potential at saturation for CN code (MPa)
+    real(r8), pointer :: vwcsat(:,:)      ! volumetric water content at saturation for CN code (m3/m3)
+    real(r8), pointer :: wf(:)            ! soil water as frac. of whc for top 0.5 m
+    real(r8), pointer :: soilpsi(:,:)     ! soil water potential in each soil layer (MPa)
+    real(r8) :: psi,vwc,fsat               ! temporary variables for soilpsi calculation
+#if (defined DGVM) || (defined CN)
+    real(r8) :: watdry                     ! temporary
+    real(r8) :: rwat(lbc:ubc)              ! soil water wgted by depth to maximum depth of 0.5 m
+    real(r8) :: swat(lbc:ubc)              ! same as rwat but at saturation
+    real(r8) :: rz(lbc:ubc)                ! thickness of soil layers contributing to rwat (m)
+    real(r8) :: tsw                        ! volumetric soil water to 0.5 m
+    real(r8) :: stsw                       ! volumetric soil water to 0.5 m at saturation
+#endif
+#endif
+
+
+! OTHER LOCAL VARIABLES:
+
+    integer  :: p,fp,g,l,c,j,fc,jtop             ! indices
+    integer  :: num_shlakesnowc                  ! number of column snow points
+    integer  :: filter_shlakesnowc(ubc-lbc+1)    ! column filter for snow points
+    integer  :: num_shlakenosnowc                ! number of column non-snow points
+    integer  :: filter_shlakenosnowc(ubc-lbc+1)  ! column filter for non-snow points
+!    real(r8) :: dtime                      ! land model time step (sec)
+    integer  :: newnode                      ! flag when new snow node is set, (1=yes, 0=no)
+    real(r8) :: dz_snowf                     ! layer thickness rate change due to precipitation [mm/s]
+    real(r8) :: bifall                       ! bulk density of newly fallen dry snow [kg/m3]
+    real(r8) :: fracsnow(lbp:ubp)            ! frac of precipitation that is snow
+    real(r8) :: fracrain(lbp:ubp)            ! frac of precipitation that is rain
+    real(r8) :: qflx_prec_grnd_snow(lbp:ubp) ! snow precipitation incident on ground [mm/s]
+    real(r8) :: qflx_prec_grnd_rain(lbp:ubp) ! rain precipitation incident on ground [mm/s]
+    real(r8) :: qflx_evap_soi_lim            ! temporary evap_soi limited by top snow layer content [mm/s]
+    real(r8) :: h2osno_temp                  ! temporary h2osno [kg/m^2]
+    real(r8), parameter :: snow_bd = 250._r8  !constant snow bulk density (only used in special case here) [kg/m^3]
+    real(r8) :: sumsnowice(lbc:ubc)             ! sum of snow ice if snow layers found above unfrozen lake [kg/m&2]
+    logical  :: unfrozen(lbc:ubc)            ! true if top lake layer is unfrozen with snow layers above
+    real(r8) :: heatrem                      ! used in case above [J/m^2]
+    real(r8) :: heatsum(lbc:ubc)             ! used in case above [J/m^2]
+    real(r8) :: qflx_top_soil(1)     !net water input into soil from top (mm/s)
+    character*256 :: message 
+
+#if (defined LAKEDEBUG)
+    real(r8) :: snow_water(lbc:ubc)           ! temporary sum of snow water for Bal Check [kg/m^2]
+#endif
+!-----------------------------------------------------------------------
+
+
+    ! Determine step size
+
+!    dtime = get_step_size()
+
+    ! Add soil water to water balance.
+    do j = 1, nlevsoil
+!dir$ concurrent
+!cdir nodep
+      do fc = 1, num_shlakec
+         c = filter_shlakec(fc)
+         begwb(c) = begwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j)
+      end do
+    end do
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+    ! Do precipitation onto ground, etc., from Hydrology1.
+
+!dir$ concurrent
+!cdir nodep
+    do fp = 1, num_shlakep
+       p = filter_shlakep(fp)
+       g = pgridcell(p)
+!       l = plandunit(p)
+       c = pcolumn(p)
+
+       ! Precipitation onto ground (kg/(m2 s))
+!       ! PET, 1/18/2005: Added new terms for mass balance correction
+!       ! due to dynamic pft weight shifting (column-level h2ocan_loss)
+!       ! Because the fractionation between rain and snow is indeterminate if
+!       ! rain + snow = 0, I am adding this very small flux only to the rain
+!       ! components.
+       ! Not relevant unless PFTs are added to lake later.
+!       if (frac_veg_nosno(p) == 0) then
+          qflx_prec_grnd_snow(p) = forc_snow(g)
+          qflx_prec_grnd_rain(p) = forc_rain(g) !+ h2ocan_loss(c)
+!       else
+!          qflx_prec_grnd_snow(p) = qflx_through_snow(p) + (qflx_candrip(p) * fracsnow(p))
+!          qflx_prec_grnd_rain(p) = qflx_through_rain(p) + (qflx_candrip(p) * fracrain(p)) + h2ocan_loss(c)
+!       end if
+       qflx_prec_grnd(p) = qflx_prec_grnd_snow(p) + qflx_prec_grnd_rain(p)
+
+       if (do_capsnow(c)) then
+          qflx_snowcap(p) = qflx_prec_grnd_snow(p) + qflx_prec_grnd_rain(p)
+          qflx_snow_grnd_pft(p) = 0._r8
+          qflx_rain_grnd(p) = 0._r8
+       else
+          qflx_snowcap(p) = 0._r8
+#if (defined OFFLINE)
+          qflx_snow_grnd_pft(p) = qflx_prec_grnd(p)*(1._r8-flfall(g)) ! ice onto ground (mm/s)
+          qflx_rain_grnd(p)     = qflx_prec_grnd(p)*flfall(g)      ! liquid water onto ground (mm/s)
+#else
+          qflx_snow_grnd_pft(p) = qflx_prec_grnd_snow(p)           ! ice onto ground (mm/s)
+          qflx_rain_grnd(p)     = qflx_prec_grnd_rain(p)           ! liquid water onto ground (mm/s)
+#endif
+       end if
+       ! Assuming one PFT; needed for below
+       qflx_snow_grnd_col(c) = qflx_snow_grnd_pft(p)
+       qflx_rain_grnd_col(c) = qflx_rain_grnd(p)
+
+    end do ! (end pft loop)
+
+    ! Determine snow height and snow water
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_shlakec
+       c = filter_shlakec(fc)
+!       l = clandunit(c)
+       g = cgridcell(c)
+
+       ! Use Alta relationship, Anderson(1976); LaChapelle(1961),
+       ! U.S.Department of Agriculture Forest Service, Project F,
+       ! Progress Rep. 1, Alta Avalanche Study Center:Snow Layer Densification.
+
+       if (do_capsnow(c)) then
+          dz_snowf = 0._r8
+       else
+          if (forc_t(g) > tfrz + 2._r8) then
+             bifall=50._r8 + 1.7_r8*(17.0_r8)**1.5_r8
+          else if (forc_t(g) > tfrz - 15._r8) then
+             bifall=50._r8 + 1.7_r8*(forc_t(g) - tfrz + 15._r8)**1.5_r8
+          else
+             bifall=50._r8
+          end if
+          dz_snowf = qflx_snow_grnd_col(c)/bifall
+          snowdp(c) = snowdp(c) + dz_snowf*dtime
+          h2osno(c) = h2osno(c) + qflx_snow_grnd_col(c)*dtime  ! snow water equivalent (mm)
+       end if
+
+!       if (itype(l)==istwet .and. t_grnd(c)>tfrz) then
+!          h2osno(c)=0._r8
+!          snowdp(c)=0._r8
+!          snowage(c)=0._r8
+!       end if
+       ! Take care of this later in function.
+
+       ! When the snow accumulation exceeds 10 mm, initialize snow layer
+       ! Currently, the water temperature for the precipitation is simply set
+       ! as the surface air temperature
+
+       newnode = 0    ! flag for when snow node will be initialized
+       if (snl(c) == 0 .and. qflx_snow_grnd_col(c) > 0.0_r8 .and. snowdp(c) >= 0.01_r8) then
+          newnode = 1
+          snl(c) = -1
+          dz(c,0) = snowdp(c)                       ! meter
+          z(c,0) = -0.5_r8*dz(c,0)
+          zi(c,-1) = -dz(c,0)
+          snowage(c) = 0._r8                        ! snow age
+          t_soisno(c,0) = min(tfrz, forc_t(g))      ! K
+          h2osoi_ice(c,0) = h2osno(c)               ! kg/m2
+          h2osoi_liq(c,0) = 0._r8                   ! kg/m2
+          frac_iceold(c,0) = 1._r8
+       end if
+
+       ! The change of ice partial density of surface node due to precipitation.
+       ! Only ice part of snowfall is added here, the liquid part will be added
+       ! later.
+
+       if (snl(c) < 0 .and. newnode == 0) then
+          h2osoi_ice(c,snl(c)+1) = h2osoi_ice(c,snl(c)+1)+dtime*qflx_snow_grnd_col(c)
+          dz(c,snl(c)+1) = dz(c,snl(c)+1)+dz_snowf*dtime
+       end if
+
+    end do
+
+    ! Calculate sublimation and dew, adapted from HydrologyLake and Biogeophysics2.
+
+!dir$ concurrent
+!cdir nodep
+    do fp = 1,num_shlakep
+       p = filter_shlakep(fp)
+       c = pcolumn(p)
+       jtop = snl(c)+1
+
+       ! Use column variables here
+       qflx_evap_grnd(c) = 0._r8
+       qflx_sub_snow(c) = 0._r8
+       qflx_dew_snow(c) = 0._r8
+       qflx_dew_grnd(c) = 0._r8
+
+       if (jtop <= 0) then ! snow layers
+          j = jtop
+          ! Assign ground evaporation to sublimation from soil ice or to dew
+          ! on snow or ground
+
+          if (qflx_evap_soi(p) >= 0._r8) then
+          ! for evaporation partitioning between liquid evap and ice sublimation, 
+          ! use the ratio of liquid to (liquid+ice) in the top layer to determine split
+          ! Since we're not limiting evap over lakes, but still can't remove more from top
+          ! snow layer than there is there, create temp. limited evap_soi.
+             qflx_evap_soi_lim = min(qflx_evap_soi(p), (h2osoi_liq(c,j)+h2osoi_ice(c,j))/dtime)
+             if ((h2osoi_liq(c,j)+h2osoi_ice(c,j)) > 0._r8) then
+                qflx_evap_grnd(c) = max(qflx_evap_soi_lim*(h2osoi_liq(c,j)/(h2osoi_liq(c,j)+h2osoi_ice(c,j))), 0._r8)
+             else
+                qflx_evap_grnd(c) = 0._r8
+             end if
+             qflx_sub_snow(c) = qflx_evap_soi_lim - qflx_evap_grnd(c)     
+          else
+             if (t_grnd(c) < tfrz) then
+                qflx_dew_snow(c) = abs(qflx_evap_soi(p))
+             else
+                qflx_dew_grnd(c) = abs(qflx_evap_soi(p))
+             end if
+          end if
+          ! Update the pft-level qflx_snowcap
+          ! This was moved in from Hydrology2 to keep all pft-level
+          ! calculations out of Hydrology2
+          if (do_capsnow(c)) qflx_snowcap(p) = qflx_snowcap(p) + qflx_dew_snow(c) + qflx_dew_grnd(c)
+
+       else ! No snow layers: do as in HydrologyLake but with actual clmtype variables
+          if (qflx_evap_soi(p) >= 0._r8) then
+             ! Sublimation: do not allow for more sublimation than there is snow
+             ! after melt.  Remaining surface evaporation used for infiltration.
+             qflx_sub_snow(c) = min(qflx_evap_soi(p), h2osno(c)/dtime)
+             qflx_evap_grnd(c) = qflx_evap_soi(p) - qflx_sub_snow(c)
+          else
+             if (t_grnd(c) < tfrz-0.1_r8) then
+                qflx_dew_snow(c) = abs(qflx_evap_soi(p))
+             else
+                qflx_dew_grnd(c) = abs(qflx_evap_soi(p))
+             end if
+          end if
+
+          ! Update snow pack for dew & sub.
+          h2osno_temp = h2osno(c)
+          if (do_capsnow(c)) then
+             h2osno(c) = h2osno(c) - qflx_sub_snow(c)*dtime
+             qflx_snowcap(p) = qflx_snowcap(p) + qflx_dew_snow(c) + qflx_dew_grnd(c)
+          else
+             h2osno(c) = h2osno(c) + (-qflx_sub_snow(c)+qflx_dew_snow(c))*dtime
+          end if
+          if (h2osno_temp > 0._r8) then
+             snowdp(c) = snowdp(c) * h2osno(c) / h2osno_temp
+          else
+             snowdp(c) = h2osno(c)/snow_bd !Assume a constant snow bulk density = 250.
+          end if
+
+#if (defined PERGRO)
+          if (abs(h2osno(c)) < 1.e-10_r8) h2osno(c) = 0._r8
+#else
+          h2osno(c) = max(h2osno(c), 0._r8)
+#endif
+
+       end if
+
+    qflx_snowcap_col(c) = qflx_snowcap(p)
+
+    end do
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! Determine initial snow/no-snow filters (will be modified possibly by
+    ! routines CombineSnowLayers and DivideSnowLayers below
+
+    call BuildSnowFilter(lbc, ubc, num_shlakec, filter_shlakec,snl,       &            !i
+         num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) !o
+
+    ! Determine the change of snow mass and the snow water onto soil
+
+    call SnowWater(lbc, ubc, num_shlakesnowc, filter_shlakesnowc,         & !i 
+                   num_shlakenosnowc, filter_shlakenosnowc,               & !i 
+                   snl,do_capsnow,qflx_snomelt,qflx_rain_grnd,            & !i 
+                   qflx_sub_snow,qflx_evap_grnd,                          & !i   
+                   qflx_dew_snow,qflx_dew_grnd,dz,                        & !i   
+                   h2osoi_ice,h2osoi_liq,                                 & !i&o 
+                   qflx_top_soil)                                           !o                        
+
+
+    ! Determine soil hydrology
+    ! Here this consists only of making sure that soil is saturated even as it melts and 10%
+    ! of pore space opens up. Conversely, if excess ice is melting and the liquid water exceeds the
+    ! saturation value, then remove water.
+
+    do j = 1,nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          if (h2osoi_vol(c,j) < watsat(c,j)) then
+             h2osoi_liq(c,j) = (watsat(c,j)*dz(c,j) - h2osoi_ice(c,j)/denice)*denh2o
+          ! h2osoi_vol will be updated below, and this water addition will come from qflx_qrgwl
+          else if (h2osoi_liq(c,j) > watsat(c,j)*denh2o*dz(c,j)) then
+             h2osoi_liq(c,j) = watsat(c,j)*denh2o*dz(c,j)
+          end if
+
+       end do
+    end do
+!!!!!!!!!!
+
+!    if (.not. is_perpetual()) then
+    if (1==1) then
+
+       ! Natural compaction and metamorphosis.
+
+       call SnowCompaction(lbc, ubc, num_shlakesnowc, filter_shlakesnowc,   &!i
+                           snl,imelt,frac_iceold,t_soisno,                  &!i
+                           h2osoi_ice,h2osoi_liq,                           &!i
+                           dz)                                               !&o
+
+       ! Combine thin snow elements
+
+       call CombineSnowLayers(lbc, ubc,                            & !i
+                              num_shlakesnowc, filter_shlakesnowc, & !i&o
+                              snl,h2osno,snowdp,dz,zi,             & !i&o
+                              t_soisno,h2osoi_ice,h2osoi_liq,      & !i&o
+                              z)  !o                              
+
+
+       ! Divide thick snow elements
+
+       call DivideSnowLayers(lbc, ubc,                             & !i
+                             num_shlakesnowc, filter_shlakesnowc,  & !i&o
+                             snl,dz,zi,t_soisno,                   & !i&o
+                             h2osoi_ice,h2osoi_liq,                & !i&o
+                             z)  !o
+
+
+    else
+
+       do fc = 1, num_shlakesnowc
+          c = filter_shlakesnowc(fc)
+          h2osno(c) = 0._r8
+       end do
+       do j = -nlevsnow+1,0
+          do fc = 1, num_shlakesnowc
+             c = filter_shlakesnowc(fc)
+             if (j >= snl(c)+1) then
+                h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j)
+             end if
+          end do
+       end do
+
+    end if
+
+    ! Check for snow layers above lake with unfrozen top layer.  Mechanically,
+    ! the snow will fall into the lake and melt or turn to ice.  If the top layer has
+    ! sufficient heat to melt the snow without freezing, then that will be done.
+    ! Otherwise, the top layer will undergo freezing, but only if the top layer will
+    ! not freeze completely.  Otherwise, let the snow layers persist and melt by diffusion.
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          if (t_lake(c,1) > tfrz .and. lake_icefrac(c,1) == 0._r8 .and. snl(c) < 0) then
+             unfrozen(c) = .true.
+          else
+             unfrozen(c) = .false.
+          end if
+       end do
+
+    do j = -nlevsnow+1,0
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          if (unfrozen(c)) then
+             if (j == -nlevsnow+1) then
+                sumsnowice(c) = 0._r8
+                heatsum(c) = 0._r8
+             end if
+             if (j >= snl(c)+1) then
+                sumsnowice(c) = sumsnowice(c) + h2osoi_ice(c,j)
+                heatsum(c) = heatsum(c) + h2osoi_ice(c,j)*cpice*(tfrz - t_soisno(c,j)) &
+                           + h2osoi_liq(c,j)*cpliq*(tfrz - t_soisno(c,j))
+             end if
+          end if
+       end do
+    end do
+
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+
+          if (unfrozen(c)) then
+             heatsum(c) = heatsum(c) + sumsnowice(c)*hfus
+             heatrem = (t_lake(c,1) - tfrz)*cpliq*denh2o*dz_lake(c,1) - heatsum(c)
+
+             if (heatrem + denh2o*dz_lake(c,1)*hfus > 0._r8) then            
+                ! Remove snow and subtract the latent heat from the top layer.
+                h2osno(c) = 0._r8
+                snl(c) = 0
+                ! The rest of the bookkeeping for the removed snow will be done below.
+#if (defined LAKEDEBUG)
+                write(message,*)'Snow layers removed above unfrozen lake for column, snowice:', &
+                          c, sumsnowice(c)
+                CALL wrf_message(message)
+#endif
+                if (heatrem > 0._r8) then ! simply subtract the heat from the layer
+                   t_lake(c,1) = t_lake(c,1) - heatrem/(cpliq*denh2o*dz_lake(c,1))
+                else !freeze part of the layer
+                   t_lake(c,1) = tfrz
+                   lake_icefrac(c,1) = -heatrem/(denh2o*dz_lake(c,1)*hfus)
+                end if
+             end if
+          end if
+       end do
+!!!!!!!!!!!!
+
+    ! Set snow age to zero if no snow
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_shlakesnowc
+       c = filter_shlakesnowc(fc)
+       if (snl(c) == 0) then
+          snowage(c) = 0._r8
+       end if
+    end do
+
+    ! Set empty snow layers to zero
+
+    do j = -nlevsnow+1,0
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakesnowc
+          c = filter_shlakesnowc(fc)
+          if (j <= snl(c) .and. snl(c) > -nlevsnow) then
+             h2osoi_ice(c,j) = 0._r8
+             h2osoi_liq(c,j) = 0._r8
+             t_soisno(c,j) = 0._r8
+             dz(c,j) = 0._r8
+             z(c,j) = 0._r8
+             zi(c,j-1) = 0._r8
+          end if
+       end do
+    end do
+
+    ! Build new snow filter
+
+    call BuildSnowFilter(lbc, ubc, num_shlakec, filter_shlakec, snl,&   !i
+         num_shlakesnowc, filter_shlakesnowc, num_shlakenosnowc, filter_shlakenosnowc) !o
+
+    ! Vertically average t_soisno and sum of h2osoi_liq and h2osoi_ice
+    ! over all snow layers for history output
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_shlakesnowc
+       c = filter_shlakesnowc(fc)
+       t_snow(c)  = 0._r8
+       snowice(c) = 0._r8
+       snowliq(c) = 0._r8
+    end do
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_shlakenosnowc
+       c = filter_shlakenosnowc(fc)
+       t_snow(c)  = spval
+       snowice(c) = spval
+       snowliq(c) = spval
+    end do
+
+    do j = -nlevsnow+1, 0
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakesnowc
+          c = filter_shlakesnowc(fc)
+          if (j >= snl(c)+1) then
+             t_snow(c)  = t_snow(c) + t_soisno(c,j)
+             snowice(c) = snowice(c) + h2osoi_ice(c,j)
+             snowliq(c) = snowliq(c) + h2osoi_liq(c,j)
+          end if
+       end do
+    end do
+
+    ! Determine ending water balance and volumetric soil water
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_shlakec
+       
+       c = filter_shlakec(fc)
+       if (snl(c) < 0) t_snow(c) = t_snow(c)/abs(snl(c))
+       endwb(c) = h2osno(c)
+    end do
+
+    do j = 1, nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_shlakec
+          c = filter_shlakec(fc)
+          endwb(c) = endwb(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j)
+          h2osoi_vol(c,j) = h2osoi_liq(c,j)/(dz(c,j)*denh2o) + h2osoi_ice(c,j)/(dz(c,j)*denice)
+       end do
+    end do
+
+#if (defined LAKEDEBUG)
+    ! Check to make sure snow water adds up correctly.
+    do j = -nlevsnow+1,0
+!dir$ concurrent
+!cdir nodep
+      do fc = 1, num_shlakec
+         c = filter_shlakec(fc)
+ 
+         jtop = snl(c)+1
+         if(j == jtop) snow_water(c) = 0._r8
+         if(j >= jtop) then
+            snow_water(c) = snow_water(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j)
+            if(j == 0 .and. abs(snow_water(c)-h2osno(c))>1.e-7_r8) then
+               write(message,*)'h2osno does not equal sum of snow layers in ShalLakeHydrology:', &
+                         'column, h2osno, sum of snow layers =', c, h2osno(c), snow_water(c)
+               CALL wrf_error_fatal ( message )
+            end if
+         end if
+      end do
+    end do
+#endif
+
+!!!!!!!!!!!!!
+    ! Do history variables and set special landunit runoff (adapted from end of HydrologyLake)
+!dir$ concurrent
+!cdir nodep
+    do fp = 1,num_shlakep
+       p = filter_shlakep(fp)
+       c = pcolumn(p)
+       g = pgridcell(p)
+
+       qflx_infl(c)      = 0._r8
+       qflx_surf(c)      = 0._r8
+       qflx_drain(c)     = 0._r8
+       rootr_column(c,:) = spval
+       soilalpha(c)      = spval
+       zwt(c)            = spval
+       fcov(c)           = spval
+       qcharge(c)        = spval
+!       h2osoi_vol(c,:)   = spval
+
+       ! Insure water balance using qflx_qrgwl
+       qflx_qrgwl(c)     = forc_rain(g) + forc_snow(g) - qflx_evap_tot(p) - (endwb(c)-begwb(c))/dtime
+#if (defined LAKEDEBUG)
+    write(message,*)'c, rain, snow, evap, endwb, begwb, qflx_qrgwl:', &
+       c, forc_rain(g), forc_snow(g), qflx_evap_tot(p), endwb(c), begwb(c), qflx_qrgwl(c)
+    CALL wrf_message(message)
+#endif
+
+       ! The pft average must be done here for output to history tape
+       qflx_evap_tot_col(c) = qflx_evap_tot(p)
+    end do
+
+!!!!!!!!!!!!!
+!For now, bracket off the remaining biogeochem code.  May need to bring it back
+!to do soil carbon and methane beneath lakes.
+#if (defined CN)
+#ifndef SHLAKE
+    do j = 1, nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_soilc
+          c = filter_soilc(fc)
+          
+          if (h2osoi_liq(c,j) > 0._r8) then
+             vwc = h2osoi_liq(c,j)/(dz(c,j)*denh2o)
+            
+             ! the following limit set to catch very small values of 
+             ! fractional saturation that can crash the calculation of psi
+           
+             fsat = max(vwc/vwcsat(c,j), 0.001_r8)
+             psi = psisat(c,j) * (fsat)**bsw2(c,j)
+             soilpsi(c,j) = min(max(psi,-15.0_r8),0._r8)
+          else 
+             soilpsi(c,j) = -15.0_r8
+          end if
+       end do
+    end do
+#endif
+#endif
+
+#if (defined DGVM) || (defined CN)
+#ifndef SHLAKE
+    ! Available soil water up to a depth of 0.5 m.
+    ! Potentially available soil water (=whc) up to a depth of 0.5 m.
+    ! Water content as fraction of whc up to a depth of 0.5 m.
+
+!dir$ concurrent
+!cdir nodep
+    do c = lbc,ubc
+       l = clandunit(c)
+       if (ityplun(l) == istsoil) then
+          rwat(c) = 0._r8
+          swat(c) = 0._r8
+          rz(c)   = 0._r8
+       end if
+    end do
+
+    do j = 1, nlevsoil
+!dir$ concurrent
+!cdir nodep
+       do c = lbc,ubc
+          l = clandunit(c)
+          if (ityplun(l) == istsoil) then
+             if (z(c,j)+0.5_r8*dz(c,j) <= 0.5_r8) then
+                watdry = watsat(c,j) * (316230._r8/sucsat(c,j)) ** (-1._r8/bsw(c,j))
+                rwat(c) = rwat(c) + (h2osoi_vol(c,j)-watdry) * dz(c,j)
+                swat(c) = swat(c) + (watsat(c,j)    -watdry) * dz(c,j)
+                rz(c) = rz(c) + dz(c,j)
+             end if
+          end if
+       end do
+    end do
+
+!dir$ concurrent
+!cdir nodep
+    do c = lbc,ubc
+       l = clandunit(c)
+       if (ityplun(l) == istsoil) then
+          if (rz(c) /= 0._r8) then
+             tsw  = rwat(c)/rz(c)
+             stsw = swat(c)/rz(c)
+          else
+             watdry = watsat(c,1) * (316230._r8/sucsat(c,1)) ** (-1._r8/bsw(c,1))
+             tsw = h2osoi_vol(c,1) - watdry
+             stsw = watsat(c,1) - watdry
+          end if
+          wf(c) = tsw/stsw
+       else
+          wf(c) = 1.0_r8
+       end if
+    end do
+
+#endif
+#endif
+
+  end subroutine ShalLakeHydrology
+
+  subroutine QSat (T, p, es, esdT, qs, qsdT)
+!
+! !DESCRIPTION:
+! Computes saturation mixing ratio and the change in saturation
+! mixing ratio with respect to temperature.
+! Reference:  Polynomial approximations from:
+!             Piotr J. Flatau, et al.,1992:  Polynomial fits to saturation
+!             vapor pressure.  Journal of Applied Meteorology, 31, 1507-1513.
+!
+! !USES:
+!
+! !ARGUMENTS:
+    implicit none
+    real(r8), intent(in)  :: T        ! temperature (K)
+    real(r8), intent(in)  :: p        ! surface atmospheric pressure (pa)
+    real(r8), intent(out) :: es       ! vapor pressure (pa)
+    real(r8), intent(out) :: esdT     ! d(es)/d(T)
+    real(r8), intent(out) :: qs       ! humidity (kg/kg)
+    real(r8), intent(out) :: qsdT     ! d(qs)/d(T)
+!
+! !CALLED FROM:
+! subroutine Biogeophysics1 in module Biogeophysics1Mod
+! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod
+! subroutine CanopyFluxesMod CanopyFluxesMod
+!
+! !REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+!
+!EOP
+!
+! !LOCAL VARIABLES:
+!
+    real(r8) :: T_limit
+    real(r8) :: td,vp,vp1,vp2
+!
+! For water vapor (temperature range 0C-100C)
+!
+    real(r8), parameter :: a0 =  6.11213476
+    real(r8), parameter :: a1 =  0.444007856
+    real(r8), parameter :: a2 =  0.143064234e-01
+    real(r8), parameter :: a3 =  0.264461437e-03
+    real(r8), parameter :: a4 =  0.305903558e-05
+    real(r8), parameter :: a5 =  0.196237241e-07
+    real(r8), parameter :: a6 =  0.892344772e-10
+    real(r8), parameter :: a7 = -0.373208410e-12
+    real(r8), parameter :: a8 =  0.209339997e-15
+!
+! For derivative:water vapor
+!
+    real(r8), parameter :: b0 =  0.444017302
+    real(r8), parameter :: b1 =  0.286064092e-01
+    real(r8), parameter :: b2 =  0.794683137e-03
+    real(r8), parameter :: b3 =  0.121211669e-04
+    real(r8), parameter :: b4 =  0.103354611e-06
+    real(r8), parameter :: b5 =  0.404125005e-09
+    real(r8), parameter :: b6 = -0.788037859e-12
+    real(r8), parameter :: b7 = -0.114596802e-13
+    real(r8), parameter :: b8 =  0.381294516e-16
+!
+! For ice (temperature range -75C-0C)
+!
+    real(r8), parameter :: c0 =  6.11123516
+    real(r8), parameter :: c1 =  0.503109514
+    real(r8), parameter :: c2 =  0.188369801e-01
+    real(r8), parameter :: c3 =  0.420547422e-03
+    real(r8), parameter :: c4 =  0.614396778e-05
+    real(r8), parameter :: c5 =  0.602780717e-07
+    real(r8), parameter :: c6 =  0.387940929e-09
+    real(r8), parameter :: c7 =  0.149436277e-11
+    real(r8), parameter :: c8 =  0.262655803e-14
+!
+! For derivative:ice
+!
+    real(r8), parameter :: d0 =  0.503277922
+    real(r8), parameter :: d1 =  0.377289173e-01
+    real(r8), parameter :: d2 =  0.126801703e-02
+    real(r8), parameter :: d3 =  0.249468427e-04
+    real(r8), parameter :: d4 =  0.313703411e-06
+    real(r8), parameter :: d5 =  0.257180651e-08
+    real(r8), parameter :: d6 =  0.133268878e-10
+    real(r8), parameter :: d7 =  0.394116744e-13
+    real(r8), parameter :: d8 =  0.498070196e-16
+!-----------------------------------------------------------------------
+
+    T_limit = T - tfrz
+    if (T_limit > 100.0) T_limit=100.0
+    if (T_limit < -75.0) T_limit=-75.0
+
+    td       = T_limit
+    if (td >= 0.0) then
+       es   = a0 + td*(a1 + td*(a2 + td*(a3 + td*(a4 &
+            + td*(a5 + td*(a6 + td*(a7 + td*a8)))))))
+       esdT = b0 + td*(b1 + td*(b2 + td*(b3 + td*(b4 &
+            + td*(b5 + td*(b6 + td*(b7 + td*b8)))))))
+    else
+       es   = c0 + td*(c1 + td*(c2 + td*(c3 + td*(c4 &
+            + td*(c5 + td*(c6 + td*(c7 + td*c8)))))))
+       esdT = d0 + td*(d1 + td*(d2 + td*(d3 + td*(d4 &
+            + td*(d5 + td*(d6 + td*(d7 + td*d8)))))))
+    endif
+
+    es    = es    * 100.            ! pa
+    esdT  = esdT  * 100.            ! pa/K
+
+    vp    = 1.0   / (p - 0.378*es)
+    vp1   = 0.622 * vp
+    vp2   = vp1   * vp
+
+    qs    = es    * vp1             ! kg/kg
+    qsdT  = esdT  * vp2 * p         ! 1 / K
+
+  end subroutine QSat
+
+
+  subroutine Tridiagonal (lbc, ubc, lbj, ubj, jtop, numf, filter, &
+                          a, b, c, r, u)
+!
+! !DESCRIPTION:
+! Tridiagonal matrix solution
+!
+! !USES:
+  !  use shr_kind_mod, only: r8 => shr_kind_r8
+!
+! !ARGUMENTS:
+    implicit none
+    integer , intent(in)    :: lbc, ubc               ! lbinning and ubing column indices
+    integer , intent(in)    :: lbj, ubj               ! lbinning and ubing level indices
+    integer , intent(in)    :: jtop(lbc:ubc)          ! top level for each column
+    integer , intent(in)    :: numf                   ! filter dimension
+    integer , intent(in)    :: filter(1:numf)         ! filter
+    real(r8), intent(in)    :: a(lbc:ubc, lbj:ubj)    ! "a" left off diagonal of tridiagonal matrix
+    real(r8), intent(in)    :: b(lbc:ubc, lbj:ubj)    ! "b" diagonal column for tridiagonal matrix
+    real(r8), intent(in)    :: c(lbc:ubc, lbj:ubj)    ! "c" right off diagonal tridiagonal matrix
+    real(r8), intent(in)    :: r(lbc:ubc, lbj:ubj)    ! "r" forcing term of tridiagonal matrix
+    real(r8), intent(inout) :: u(lbc:ubc, lbj:ubj)    ! solution
+!
+! !CALLED FROM:
+! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod
+! subroutine SoilTemperature in module SoilTemperatureMod
+! subroutine SoilWater in module HydrologyMod
+!
+! !REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+!  1 July 2003: Mariana Vertenstein; modified for vectorization
+!
+!EOP
+!
+! !OTHER LOCAL VARIABLES:
+!
+    integer  :: j,ci,fc                   !indices
+    real(r8) :: gam(lbc:ubc,lbj:ubj)      !temporary
+    real(r8) :: bet(lbc:ubc)              !temporary
+!-----------------------------------------------------------------------
+
+    ! Solve the matrix
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1,numf
+       ci = filter(fc)
+       bet(ci) = b(ci,jtop(ci))
+    end do
+
+    do j = lbj, ubj
+!dir$ prefervector
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,numf
+          ci = filter(fc)
+          if (j >= jtop(ci)) then
+             if (j == jtop(ci)) then
+                u(ci,j) = r(ci,j) / bet(ci)
+             else
+                gam(ci,j) = c(ci,j-1) / bet(ci)
+                bet(ci) = b(ci,j) - a(ci,j) * gam(ci,j)
+                u(ci,j) = (r(ci,j) - a(ci,j)*u(ci,j-1)) / bet(ci)
+             end if
+          end if
+       end do
+    end do
+
+!Cray X1 unroll directive used here as work-around for compiler issue 2003/10/20
+!dir$ unroll 0
+    do j = ubj-1,lbj,-1
+!dir$ prefervector
+!dir$ concurrent
+!cdir nodep
+       do fc = 1,numf
+          ci = filter(fc)
+          if (j >= jtop(ci)) then
+             u(ci,j) = u(ci,j) - gam(ci,j+1) * u(ci,j+1)
+          end if
+       end do
+    end do
+
+  end subroutine Tridiagonal
+
+
+  subroutine SnowWater(lbc, ubc, num_snowc, filter_snowc,         & !i
+                   num_nosnowc, filter_nosnowc,               & !i 
+                   snl,do_capsnow,qflx_snomelt,qflx_rain_grnd,            & !i
+                   qflx_sub_snow,qflx_evap_grnd,                          & !i   
+                   qflx_dew_snow,qflx_dew_grnd,dz,                        & !i   
+                   h2osoi_ice,h2osoi_liq,                                 & !i&o 
+                   qflx_top_soil)                                           !o                        
+!===============================================================================
+! !DESCRIPTION:
+! Evaluate the change of snow mass and the snow water onto soil.
+! Water flow within snow is computed by an explicit and non-physical
+! based scheme, which permits a part of liquid water over the holding
+! capacity (a tentative value is used, i.e. equal to 0.033*porosity) to
+! percolate into the underlying layer.  Except for cases where the
+! porosity of one of the two neighboring layers is less than 0.05, zero
+! flow is assumed. The water flow out of the bottom of the snow pack will
+! participate as the input of the soil water and runoff.  This subroutine
+! uses a filter for columns containing snow which must be constructed prior
+! to being called.
+!
+! !REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+! 15 November 2000: Mariana Vertenstein
+! 2/26/02, Peter Thornton: Migrated to new data structures.
+!=============================================================================
+! !USES:
+  !  use clmtype
+
+    implicit none
+
+!in:
+    integer, intent(in) :: lbc, ubc                    ! column bounds
+    integer, intent(in) :: num_snowc                   ! number of snow points in column filter
+    integer, intent(in) :: filter_snowc(ubc-lbc+1)     ! column filter for snow points
+    integer, intent(in) :: num_nosnowc                 ! number of non-snow points in column filter
+    integer, intent(in) :: filter_nosnowc(ubc-lbc+1)   ! column filter for non-snow points
+
+    integer , intent(in) :: snl(1)              !number of snow layers
+    logical , intent(in) :: do_capsnow(1)       !true => do snow capping
+    real(r8), intent(in) :: qflx_snomelt(1)     !snow melt (mm H2O /s)
+    real(r8), intent(in) :: qflx_rain_grnd(1)   !rain on ground after interception (mm H2O/s) [+]
+    real(r8), intent(in) :: qflx_sub_snow(1)    !sublimation rate from snow pack (mm H2O /s) [+]
+    real(r8), intent(in) :: qflx_evap_grnd(1)   !ground surface evaporation rate (mm H2O/s) [+]
+    real(r8), intent(in) :: qflx_dew_snow(1)    !surface dew added to snow pack (mm H2O /s) [+]
+    real(r8), intent(in) :: qflx_dew_grnd(1)    !ground surface dew formation (mm H2O /s) [+]
+    real(r8), intent(in) :: dz(1,-nlevsnow+1:nlevsoil)             !layer depth (m)
+
+
+!inout: 
+
+    real(r8), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil)     !ice lens (kg/m2)
+    real(r8), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil)     !liquid water (kg/m2)
+
+!out:
+
+    real(r8), intent(out) :: qflx_top_soil(1)     !net water input into soil from top (mm/s)
+
+
+! OTHER LOCAL VARIABLES:
+
+    integer  :: c, j, fc                           !do loop/array indices
+    real(r8) :: qin(lbc:ubc)                       !water flow into the elmement (mm/s)
+    real(r8) :: qout(lbc:ubc)                      !water flow out of the elmement (mm/s)
+    real(r8) :: wgdif                              !ice mass after minus sublimation
+    real(r8) :: vol_liq(lbc:ubc,-nlevsnow+1:0)      !partial volume of liquid water in layer
+    real(r8) :: vol_ice(lbc:ubc,-nlevsnow+1:0)      !partial volume of ice lens in layer
+    real(r8) :: eff_porosity(lbc:ubc,-nlevsnow+1:0) !effective porosity = porosity - vol_ice
+!-----------------------------------------------------------------------
+    ! Renew the mass of ice lens (h2osoi_ice) and liquid (h2osoi_liq) in the
+    ! surface snow layer resulting from sublimation (frost) / evaporation (condense)
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1,num_snowc
+       c = filter_snowc(fc)
+       if (do_capsnow(c)) then
+          wgdif = h2osoi_ice(c,snl(c)+1) - qflx_sub_snow(c)*dtime
+          h2osoi_ice(c,snl(c)+1) = wgdif
+          if (wgdif < 0.) then
+             h2osoi_ice(c,snl(c)+1) = 0.
+             h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif
+          end if
+          h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) - qflx_evap_grnd(c) * dtime
+       else
+          wgdif = h2osoi_ice(c,snl(c)+1) + (qflx_dew_snow(c) - qflx_sub_snow(c)) * dtime
+          h2osoi_ice(c,snl(c)+1) = wgdif
+          if (wgdif < 0.) then
+             h2osoi_ice(c,snl(c)+1) = 0.
+             h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) + wgdif
+          end if
+          h2osoi_liq(c,snl(c)+1) = h2osoi_liq(c,snl(c)+1) +  &
+               (qflx_rain_grnd(c) + qflx_dew_grnd(c) - qflx_evap_grnd(c)) * dtime
+       end if
+       h2osoi_liq(c,snl(c)+1) = max(0._r8, h2osoi_liq(c,snl(c)+1))
+    end do
+
+    ! Porosity and partial volume
+
+    do j = -nlevsnow+1, 0
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_snowc
+          c = filter_snowc(fc)
+          if (j >= snl(c)+1) then
+             vol_ice(c,j) = min(1._r8, h2osoi_ice(c,j)/(dz(c,j)*denice))
+             eff_porosity(c,j) = 1. - vol_ice(c,j)
+             vol_liq(c,j) = min(eff_porosity(c,j),h2osoi_liq(c,j)/(dz(c,j)*denh2o))
+          end if
+       end do
+    end do
+
+    ! Capillary forces within snow are usually two or more orders of magnitude
+    ! less than those of gravity. Only gravity terms are considered.
+    ! the genernal expression for water flow is "K * ss**3", however,
+    ! no effective parameterization for "K".  Thus, a very simple consideration
+    ! (not physically based) is introduced:
+    ! when the liquid water of layer exceeds the layer's holding
+    ! capacity, the excess meltwater adds to the underlying neighbor layer.
+
+    qin(:) = 0._r8
+
+    do j = -nlevsnow+1, 0
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_snowc
+          c = filter_snowc(fc)
+          if (j >= snl(c)+1) then
+             h2osoi_liq(c,j) = h2osoi_liq(c,j) + qin(c)
+             if (j <= -1) then
+                ! No runoff over snow surface, just ponding on surface
+                if (eff_porosity(c,j) < wimp .OR. eff_porosity(c,j+1) < wimp) then
+                   qout(c) = 0._r8
+                else
+                   qout(c) = max(0._r8,(vol_liq(c,j)-ssi*eff_porosity(c,j))*dz(c,j))
+                   qout(c) = min(qout(c),(1.-vol_ice(c,j+1)-vol_liq(c,j+1))*dz(c,j+1))
+                end if
+             else
+                qout(c) = max(0._r8,(vol_liq(c,j) - ssi*eff_porosity(c,j))*dz(c,j))
+             end if
+             qout(c) = qout(c)*1000.
+             h2osoi_liq(c,j) = h2osoi_liq(c,j) - qout(c)
+             qin(c) = qout(c)
+          end if
+       end do
+    end do
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_snowc
+       c = filter_snowc(fc)
+       ! Qout from snow bottom
+       qflx_top_soil(c) = qout(c) / dtime
+    end do
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_nosnowc
+       c = filter_nosnowc(fc)
+       qflx_top_soil(c) = qflx_rain_grnd(c) + qflx_snomelt(c)
+    end do
+
+  end subroutine SnowWater
+
+  subroutine SnowCompaction(lbc, ubc, num_snowc, filter_snowc,   &!i  
+                           snl,imelt,frac_iceold,t_soisno,                  &!i  
+                           h2osoi_ice,h2osoi_liq,                           &!i  
+                           dz)                                               !i&o   
+
+
+!================================================================================
+! !DESCRIPTION:
+! Determine the change in snow layer thickness due to compaction and
+! settling.
+! Three metamorphisms of changing snow characteristics are implemented,
+! i.e., destructive, overburden, and melt. The treatments of the former
+! two are from SNTHERM.89 and SNTHERM.99 (1991, 1999). The contribution
+! due to melt metamorphism is simply taken as a ratio of snow ice
+! fraction after the melting versus before the melting.
+!
+! CALLED FROM:
+! subroutine Hydrology2 in module Hydrology2Mod
+!
+! REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+! 2/28/02, Peter Thornton: Migrated to new data structures
+!==============================================================================
+! USES:
+  !  use clmtype
+!
+! !ARGUMENTS:
+    implicit none
+
+!in:
+    integer, intent(in) :: lbc, ubc                ! column bounds
+    integer, intent(in) :: num_snowc               ! number of column snow points in column filter
+    integer, intent(in) :: filter_snowc(ubc-lbc+1) ! column filter for snow points
+    integer,  intent(in) :: snl(1)             !number of snow layers
+    integer,  intent(in) :: imelt(1,-nlevsnow+1:nlevsoil)        !flag for melting (=1), freezing (=2), Not=0
+    real(r8), intent(in) :: frac_iceold(1,-nlevsnow+1:nlevsoil)  !fraction of ice relative to the tot water
+    real(r8), intent(in) :: t_soisno(1,-nlevsnow+1:nlevsoil)     !soil temperature (Kelvin)
+    real(r8), intent(in) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil)   !ice lens (kg/m2)
+    real(r8), intent(in) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil)   !liquid water (kg/m2)
+
+!inout:
+
+    real(r8), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil)           !layer depth (m)
+
+! OTHER LOCAL VARIABLES:
+
+    integer :: j, c, fc                   ! indices
+    real(r8), parameter :: c2 = 23.e-3    ! [m3/kg]
+    real(r8), parameter :: c3 = 2.777e-6  ! [1/s]
+    real(r8), parameter :: c4 = 0.04      ! [1/K]
+    real(r8), parameter :: c5 = 2.0       !
+    real(r8), parameter :: dm = 100.0     ! Upper Limit on Destructive Metamorphism Compaction [kg/m3]
+    real(r8), parameter :: eta0 = 9.e+5   ! The Viscosity Coefficient Eta0 [kg-s/m2]
+    real(r8) :: burden(lbc:ubc) ! pressure of overlying snow [kg/m2]
+    real(r8) :: ddz1   ! Rate of settling of snowpack due to destructive metamorphism.
+    real(r8) :: ddz2   ! Rate of compaction of snowpack due to overburden.
+    real(r8) :: ddz3   ! Rate of compaction of snowpack due to melt [1/s]
+    real(r8) :: dexpf  ! expf=exp(-c4*(273.15-t_soisno)).
+    real(r8) :: fi     ! Fraction of ice relative to the total water content at current time step
+    real(r8) :: td     ! t_soisno - tfrz [K]
+    real(r8) :: pdzdtc ! Nodal rate of change in fractional-thickness due to compaction [fraction/s]
+    real(r8) :: void   ! void (1 - vol_ice - vol_liq)
+    real(r8) :: wx     ! water mass (ice+liquid) [kg/m2]
+    real(r8) :: bi     ! partial density of ice [kg/m3]
+
+!-----------------------------------------------------------------------
+
+
+    ! Begin calculation - note that the following column loops are only invoked if snl(c) < 0
+
+    burden(:) = 0._r8
+
+    do j = -nlevsnow+1, 0
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_snowc
+          c = filter_snowc(fc)
+          if (j >= snl(c)+1) then
+
+             wx = h2osoi_ice(c,j) + h2osoi_liq(c,j)
+             void = 1. - (h2osoi_ice(c,j)/denice + h2osoi_liq(c,j)/denh2o) / dz(c,j)
+
+             ! Allow compaction only for non-saturated node and higher ice lens node.
+             if (void > 0.001 .and. h2osoi_ice(c,j) > .1) then
+                bi = h2osoi_ice(c,j) / dz(c,j)
+                fi = h2osoi_ice(c,j) / wx
+                td = tfrz-t_soisno(c,j)
+                dexpf = exp(-c4*td)
+
+                ! Settling as a result of destructive metamorphism
+
+                ddz1 = -c3*dexpf
+                if (bi > dm) ddz1 = ddz1*exp(-46.0e-3*(bi-dm))
+
+                ! Liquid water term
+
+                if (h2osoi_liq(c,j) > 0.01*dz(c,j)) ddz1=ddz1*c5
+
+                ! Compaction due to overburden
+
+                ddz2 = -burden(c)*exp(-0.08*td - c2*bi)/eta0
+
+                ! Compaction occurring during melt
+
+                if (imelt(c,j) == 1) then
+                   ddz3 = - 1./dtime * max(0._r8,(frac_iceold(c,j) - fi)/frac_iceold(c,j))
+                else
+                   ddz3 = 0._r8
+                end if
+
+                ! Time rate of fractional change in dz (units of s-1)
+
+                pdzdtc = ddz1 + ddz2 + ddz3
+
+                ! The change in dz due to compaction
+
+                dz(c,j) = dz(c,j) * (1.+pdzdtc*dtime)
+             end if
+
+             ! Pressure of overlying snow
+
+             burden(c) = burden(c) + wx
+
+          end if
+       end do
+    end do
+
+  end subroutine SnowCompaction
+
+  subroutine CombineSnowLayers(lbc, ubc,                            & !i
+                              num_snowc, filter_snowc, & !i&o
+                              snl,h2osno,snowdp,dz,zi,             & !i&o
+                              t_soisno,h2osoi_ice,h2osoi_liq,      & !i&o
+                              z)  !o
+!==========================================================================
+! !DESCRIPTION:
+! Combine snow layers that are less than a minimum thickness or mass
+! If the snow element thickness or mass is less than a prescribed minimum,
+! then it is combined with a neighboring element.  The subroutine
+! clm\_combo.f90 then executes the combination of mass and energy.
+! !CALLED FROM:
+! subroutine Hydrology2 in module Hydrology2Mod
+!
+! !REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+! 2/28/02, Peter Thornton: Migrated to new data structures.
+!=========================================================================
+! !USES:
+  !  use clmtype
+!
+! !ARGUMENTS:
+    implicit none
+!in:
+    integer, intent(in)    :: lbc, ubc                    ! column bounds
+   ! integer, intent(in) :: clandunit(1)       !landunit index for each column
+   ! integer, intent(in) :: ityplun(1)         !landunit type
+
+!inout:
+    integer, intent(inout) :: num_snowc                   ! number of column snow points in column filter
+    integer, intent(inout) :: filter_snowc(ubc-lbc+1)     ! column filter for snow points
+    integer , intent(inout) :: snl(1)            !number of snow layers
+    real(r8), intent(inout) :: h2osno(1)         !snow water (mm H2O)
+    real(r8), intent(inout) :: snowdp(1)         !snow height (m)
+    real(r8), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil)           !layer depth (m)
+    real(r8), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil)           !interface level below a "z" level (m)
+    real(r8), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil)     !soil temperature (Kelvin)
+    real(r8), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil)   !ice lens (kg/m2)
+    real(r8), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil)   !liquid water (kg/m2)
+
+!out:
+
+    real(r8), intent(out) :: z(1,-nlevsnow+1:nlevsoil)            !layer thickness (m)
+!
+!EOP
+!
+! !OTHER LOCAL VARIABLES:
+!
+    integer :: c, fc                 ! column indices
+    integer :: i,k                   ! loop indices
+    integer :: j,l                   ! node indices
+    integer :: msn_old(lbc:ubc)      ! number of top snow layer
+    integer :: mssi(lbc:ubc)         ! node index
+    integer :: neibor                ! adjacent node selected for combination
+    real(r8):: zwice(lbc:ubc)        ! total ice mass in snow
+    real(r8):: zwliq (lbc:ubc)       ! total liquid water in snow
+    real(r8):: dzmin(5)              ! minimum of top snow layer
+
+    data dzmin /0.010, 0.015, 0.025, 0.055, 0.115/
+!-----------------------------------------------------------------------
+
+    ! Check the mass of ice lens of snow, when the total is less than a small value,
+    ! combine it with the underlying neighbor.
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_snowc
+       c = filter_snowc(fc)
+       msn_old(c) = snl(c)
+    end do
+
+    ! The following loop is NOT VECTORIZED
+
+    do fc = 1, num_snowc
+       c = filter_snowc(fc)
+   !    l = clandunit(c)                                                    
+       do j = msn_old(c)+1,0
+          if (h2osoi_ice(c,j) <= .1) then
+           !  if (ityplun(l) == istsoil) then                                
+           !     h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j)        
+           !     h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j)       
+           !  else if (ityplun(l) /= istsoil .and. j /= 0) then               
+             h2osoi_liq(c,j+1) = h2osoi_liq(c,j+1) + h2osoi_liq(c,j)
+             h2osoi_ice(c,j+1) = h2osoi_ice(c,j+1) + h2osoi_ice(c,j)
+           !  end if 
+
+             ! shift all elements above this down one.
+             if (j > snl(c)+1 .and. snl(c) < -1) then
+                do i = j, snl(c)+2, -1
+                   t_soisno(c,i)   = t_soisno(c,i-1)
+                   h2osoi_liq(c,i) = h2osoi_liq(c,i-1)
+                   h2osoi_ice(c,i) = h2osoi_ice(c,i-1)
+                   dz(c,i)         = dz(c,i-1)
+                end do
+             end if
+             snl(c) = snl(c) + 1
+          end if
+       end do
+    end do
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_snowc
+       c = filter_snowc(fc)
+       h2osno(c) = 0._r8
+       snowdp(c) = 0._r8
+       zwice(c)  = 0._r8
+       zwliq(c)  = 0._r8
+    end do
+
+    do j = -nlevsnow+1,0
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_snowc
+          c = filter_snowc(fc)
+          if (j >= snl(c)+1) then
+             h2osno(c) = h2osno(c) + h2osoi_ice(c,j) + h2osoi_liq(c,j)
+             snowdp(c) = snowdp(c) + dz(c,j)
+             zwice(c)  = zwice(c) + h2osoi_ice(c,j)
+             zwliq(c)  = zwliq(c) + h2osoi_liq(c,j)
+          end if
+       end do
+    end do
+
+    ! Check the snow depth - all snow gone
+    ! The liquid water assumes ponding on soil surface.
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_snowc
+       c = filter_snowc(fc)
+      ! l = clandunit(c)                                         
+       if (snowdp(c) < 0.01 .and. snowdp(c) > 0.) then
+          snl(c) = 0
+          h2osno(c) = zwice(c)
+          if (h2osno(c) <= 0.) snowdp(c) = 0._r8
+      !    if (ityplun(l) == istsoil) h2osoi_liq(c,1) = h2osoi_liq(c,1) + zwliq(c)    !change by guhp
+       end if
+    end do
+
+    ! Check the snow depth - snow layers combined
+    ! The following loop IS NOT VECTORIZED
+
+    do fc = 1, num_snowc
+       c = filter_snowc(fc)
+
+       ! Two or more layers
+
+       if (snl(c) < -1) then
+
+          msn_old(c) = snl(c)
+          mssi(c) = 1
+
+          do i = msn_old(c)+1,0
+             if (dz(c,i) < dzmin(mssi(c))) then
+
+                if (i == snl(c)+1) then
+                   ! If top node is removed, combine with bottom neighbor.
+                   neibor = i + 1
+                else if (i == 0) then
+                   ! If the bottom neighbor is not snow, combine with the top neighbor.
+                   neibor = i - 1
+                else
+                   ! If none of the above special cases apply, combine with the thinnest neighbor
+                   neibor = i + 1
+                   if ((dz(c,i-1)+dz(c,i)) < (dz(c,i+1)+dz(c,i))) neibor = i-1
+                end if
+
+                ! Node l and j are combined and stored as node j.
+                if (neibor > i) then
+                   j = neibor
+                   l = i
+                else
+                   j = i
+                   l = neibor
+                end if
+
+                call Combo (dz(c,j), h2osoi_liq(c,j), h2osoi_ice(c,j), &
+                   t_soisno(c,j), dz(c,l), h2osoi_liq(c,l), h2osoi_ice(c,l), t_soisno(c,l) )
+
+                ! Now shift all elements above this down one.
+                if (j-1 > snl(c)+1) then
+                   do k = j-1, snl(c)+2, -1
+                      t_soisno(c,k) = t_soisno(c,k-1)
+                      h2osoi_ice(c,k) = h2osoi_ice(c,k-1)
+                      h2osoi_liq(c,k) = h2osoi_liq(c,k-1)
+                      dz(c,k) = dz(c,k-1)
+                   end do
+                end if
+
+                ! Decrease the number of snow layers
+                snl(c) = snl(c) + 1
+                if (snl(c) >= -1) EXIT
+
+             else
+
+                ! The layer thickness is greater than the prescribed minimum value
+                mssi(c) = mssi(c) + 1
+
+             end if
+          end do
+
+       end if
+
+    end do
+
+    ! Reset the node depth and the depth of layer interface
+
+    do j = 0, -nlevsnow+1, -1
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_snowc
+          c = filter_snowc(fc)
+          if (j >= snl(c) + 1) then
+             z(c,j) = zi(c,j) - 0.5*dz(c,j)
+             zi(c,j-1) = zi(c,j) - dz(c,j)
+          end if
+       end do
+    end do
+
+  end subroutine CombineSnowLayers
+
+  subroutine DivideSnowLayers(lbc, ubc,                             & !i
+                             num_snowc, filter_snowc,  & !i&o
+                             snl,dz,zi,t_soisno,                   & !i&o
+                             h2osoi_ice,h2osoi_liq,                & !i&o
+                             z)  !o
+
+
+!============================================================================
+! !DESCRIPTION:
+! Subdivides snow layers if they exceed their prescribed maximum thickness.
+! !CALLED FROM:
+! subroutine Hydrology2 in module Hydrology2Mod
+!
+! !REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+! 2/28/02, Peter Thornton: Migrated to new data structures.
+!============================================================================
+! !USES:
+ !   use clmtype
+!
+! !ARGUMENTS:
+    implicit none
+
+!in:
+    integer, intent(in)    :: lbc, ubc                    ! column bounds
+
+!inout:
+
+    integer, intent(inout) :: num_snowc                   ! number of column snow points in column filter
+    integer, intent(inout) :: filter_snowc(ubc-lbc+1)     ! column filter for snow points
+    integer , intent(inout) :: snl(1)            !number of snow layers
+    real(r8), intent(inout) :: dz(1,-nlevsnow+1:nlevsoil)           !layer depth (m)
+    real(r8), intent(inout) :: zi(1,-nlevsnow+0:nlevsoil)           !interface level below a "z" level (m)
+    real(r8), intent(inout) :: t_soisno(1,-nlevsnow+1:nlevsoil)     !soil temperature (Kelvin)
+    real(r8), intent(inout) :: h2osoi_ice(1,-nlevsnow+1:nlevsoil)   !ice lens (kg/m2)
+    real(r8), intent(inout) :: h2osoi_liq(1,-nlevsnow+1:nlevsoil)   !liquid water (kg/m2)
+
+!out: 
+
+    real(r8), intent(out) :: z(1,-nlevsnow+1:nlevsoil)            !layer thickness (m)
+
+
+
+! OTHER LOCAL VARIABLES:
+
+    integer  :: j, c, fc               ! indices
+    real(r8) :: drr                    ! thickness of the combined [m]
+    integer  :: msno                   ! number of snow layer 1 (top) to msno (bottom)
+    real(r8) :: dzsno(lbc:ubc,nlevsnow) ! Snow layer thickness [m]
+    real(r8) :: swice(lbc:ubc,nlevsnow) ! Partial volume of ice [m3/m3]
+    real(r8) :: swliq(lbc:ubc,nlevsnow) ! Partial volume of liquid water [m3/m3]
+    real(r8) :: tsno(lbc:ubc ,nlevsnow) ! Nodel temperature [K]
+    real(r8) :: zwice                  ! temporary
+    real(r8) :: zwliq                  ! temporary
+    real(r8) :: propor                 ! temporary
+!-----------------------------------------------------------------------
+
+    ! Begin calculation - note that the following column loops are only invoked
+    ! for snow-covered columns
+
+    do j = 1,nlevsnow
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_snowc
+          c = filter_snowc(fc)
+          if (j <= abs(snl(c))) then
+             dzsno(c,j) = dz(c,j+snl(c))
+             swice(c,j) = h2osoi_ice(c,j+snl(c))
+             swliq(c,j) = h2osoi_liq(c,j+snl(c))
+             tsno(c,j)  = t_soisno(c,j+snl(c))
+          end if
+       end do
+    end do
+
+!dir$ concurrent
+!cdir nodep
+    do fc = 1, num_snowc
+       c = filter_snowc(fc)
+
+       msno = abs(snl(c))
+
+       if (msno == 1) then
+          ! Specify a new snow layer
+          if (dzsno(c,1) > 0.03) then
+             msno = 2
+             dzsno(c,1) = dzsno(c,1)/2.
+             swice(c,1) = swice(c,1)/2.
+             swliq(c,1) = swliq(c,1)/2.
+             dzsno(c,2) = dzsno(c,1)
+             swice(c,2) = swice(c,1)
+             swliq(c,2) = swliq(c,1)
+             tsno(c,2)  = tsno(c,1)
+          end if
+       end if
+
+       if (msno > 1) then
+          if (dzsno(c,1) > 0.02) then
+             drr = dzsno(c,1) - 0.02
+             propor = drr/dzsno(c,1)
+             zwice = propor*swice(c,1)
+             zwliq = propor*swliq(c,1)
+             propor = 0.02/dzsno(c,1)
+             swice(c,1) = propor*swice(c,1)
+             swliq(c,1) = propor*swliq(c,1)
+             dzsno(c,1) = 0.02
+
+             call Combo (dzsno(c,2), swliq(c,2), swice(c,2), tsno(c,2), drr, &
+                  zwliq, zwice, tsno(c,1))
+
+             ! Subdivide a new layer
+             if (msno <= 2 .and. dzsno(c,2) > 0.07) then
+                msno = 3
+                dzsno(c,2) = dzsno(c,2)/2.
+                swice(c,2) = swice(c,2)/2.
+                swliq(c,2) = swliq(c,2)/2.
+                dzsno(c,3) = dzsno(c,2)
+                swice(c,3) = swice(c,2)
+                swliq(c,3) = swliq(c,2)
+                tsno(c,3)  = tsno(c,2)
+             end if
+          end if
+       end if
+
+       if (msno > 2) then
+          if (dzsno(c,2) > 0.05) then
+             drr = dzsno(c,2) - 0.05
+             propor = drr/dzsno(c,2)
+             zwice = propor*swice(c,2)
+             zwliq = propor*swliq(c,2)
+             propor = 0.05/dzsno(c,2)
+             swice(c,2) = propor*swice(c,2)
+             swliq(c,2) = propor*swliq(c,2)
+             dzsno(c,2) = 0.05
+
+             call Combo (dzsno(c,3), swliq(c,3), swice(c,3), tsno(c,3), drr, &
+                  zwliq, zwice, tsno(c,2))
+
+             ! Subdivided a new layer
+             if (msno <= 3 .and. dzsno(c,3) > 0.18) then
+                msno =  4
+                dzsno(c,3) = dzsno(c,3)/2.
+                swice(c,3) = swice(c,3)/2.
+                swliq(c,3) = swliq(c,3)/2.
+                dzsno(c,4) = dzsno(c,3)
+                swice(c,4) = swice(c,3)
+                swliq(c,4) = swliq(c,3)
+                tsno(c,4)  = tsno(c,3)
+             end if
+          end if
+       end if
+
+       if (msno > 3) then
+          if (dzsno(c,3) > 0.11) then
+             drr = dzsno(c,3) - 0.11
+             propor = drr/dzsno(c,3)
+             zwice = propor*swice(c,3)
+             zwliq = propor*swliq(c,3)
+             propor = 0.11/dzsno(c,3)
+             swice(c,3) = propor*swice(c,3)
+             swliq(c,3) = propor*swliq(c,3)
+             dzsno(c,3) = 0.11
+
+             call Combo (dzsno(c,4), swliq(c,4), swice(c,4), tsno(c,4), drr, &
+                  zwliq, zwice, tsno(c,3))
+
+             ! Subdivided a new layer
+             if (msno <= 4 .and. dzsno(c,4) > 0.41) then
+                msno = 5
+                dzsno(c,4) = dzsno(c,4)/2.
+                swice(c,4) = swice(c,4)/2.
+                swliq(c,4) = swliq(c,4)/2.
+                dzsno(c,5) = dzsno(c,4)
+                swice(c,5) = swice(c,4)
+                swliq(c,5) = swliq(c,4)
+                tsno(c,5)  = tsno(c,4)
+             end if
+          end if
+       end if
+
+       if (msno > 4) then
+          if (dzsno(c,4) > 0.23) then
+             drr = dzsno(c,4) - 0.23
+             propor = drr/dzsno(c,4)
+             zwice = propor*swice(c,4)
+             zwliq = propor*swliq(c,4)
+             propor = 0.23/dzsno(c,4)
+             swice(c,4) = propor*swice(c,4)
+             swliq(c,4) = propor*swliq(c,4)
+             dzsno(c,4) = 0.23
+
+             call Combo (dzsno(c,5), swliq(c,5), swice(c,5), tsno(c,5), drr, &
+                  zwliq, zwice, tsno(c,4))
+          end if
+       end if
+
+       snl(c) = -msno
+
+    end do
+
+    do j = -nlevsnow+1,0
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_snowc
+          c = filter_snowc(fc)
+          if (j >= snl(c)+1) then
+             dz(c,j)         = dzsno(c,j-snl(c))
+             h2osoi_ice(c,j) = swice(c,j-snl(c))
+             h2osoi_liq(c,j) = swliq(c,j-snl(c))
+             t_soisno(c,j)   = tsno(c,j-snl(c))
+          end if
+       end do
+    end do
+
+    do j = 0, -nlevsnow+1, -1
+!dir$ concurrent
+!cdir nodep
+       do fc = 1, num_snowc
+          c = filter_snowc(fc)
+          if (j >= snl(c)+1) then
+             z(c,j)    = zi(c,j) - 0.5*dz(c,j)
+             zi(c,j-1) = zi(c,j) - dz(c,j)
+          end if
+       end do
+    end do
+
+  end subroutine DivideSnowLayers
+
+  subroutine Combo(dz,  wliq,  wice, t, dz2, wliq2, wice2, t2)
+!
+! !DESCRIPTION:
+! Combines two elements and returns the following combined
+! variables: dz, t, wliq, wice.
+! The combined temperature is based on the equation:
+! the sum of the enthalpies of the two elements =
+! that of the combined element.
+!
+! !USES:
+!
+! !ARGUMENTS:
+    implicit none
+    real(r8), intent(in)    :: dz2   ! nodal thickness of 2 elements being combined [m]
+    real(r8), intent(in)    :: wliq2 ! liquid water of element 2 [kg/m2]
+    real(r8), intent(in)    :: wice2 ! ice of element 2 [kg/m2]
+    real(r8), intent(in)    :: t2    ! nodal temperature of element 2 [K]
+    real(r8), intent(inout) :: dz    ! nodal thickness of 1 elements being combined [m]
+    real(r8), intent(inout) :: wliq  ! liquid water of element 1
+    real(r8), intent(inout) :: wice  ! ice of element 1 [kg/m2]
+    real(r8), intent(inout) :: t     ! nodel temperature of elment 1 [K]
+!
+! !CALLED FROM:
+! subroutine CombineSnowLayers in this module
+! subroutine DivideSnowLayers in this module
+!
+! !REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+!
+!EOP
+!
+! !LOCAL VARIABLES:
+!
+    real(r8) :: dzc   ! Total thickness of nodes 1 and 2 (dzc=dz+dz2).
+    real(r8) :: wliqc ! Combined liquid water [kg/m2]
+    real(r8) :: wicec ! Combined ice [kg/m2]
+    real(r8) :: tc    ! Combined node temperature [K]
+    real(r8) :: h     ! enthalpy of element 1 [J/m2]
+    real(r8) :: h2    ! enthalpy of element 2 [J/m2]
+    real(r8) :: hc    ! temporary
+!-----------------------------------------------------------------------
+
+    dzc = dz+dz2
+    wicec = (wice+wice2)
+    wliqc = (wliq+wliq2)
+    h = (cpice*wice+cpliq*wliq) * (t-tfrz)+hfus*wliq
+    h2= (cpice*wice2+cpliq*wliq2) * (t2-tfrz)+hfus*wliq2
+
+    hc = h + h2
+    if(hc < 0.)then
+       tc = tfrz + hc/(cpice*wicec + cpliq*wliqc)
+    else if (hc.le.hfus*wliqc) then
+       tc = tfrz
+    else
+       tc = tfrz + (hc - hfus*wliqc) / (cpice*wicec + cpliq*wliqc)
+    end if
+
+    dz = dzc
+    wice = wicec
+    wliq = wliqc
+    t = tc
+
+  end subroutine Combo
+
+  subroutine BuildSnowFilter(lbc, ubc, num_nolakec, filter_nolakec,snl, & !i
+                             num_snowc, filter_snowc, &                   !o
+                             num_nosnowc, filter_nosnowc)                 !o
+!
+! !DESCRIPTION:
+! Constructs snow filter for use in vectorized loops for snow hydrology.
+!
+! !USES:
+!    use clmtype
+!
+! !ARGUMENTS:
+    implicit none
+    integer, intent(in)  :: lbc, ubc                    ! column bounds
+    integer, intent(in)  :: num_nolakec                 ! number of column non-lake points in column filter
+    integer, intent(in)  :: filter_nolakec(ubc-lbc+1)   ! column filter for non-lake points
+    integer, intent(in)  :: snl(1)                        ! number of snow layers
+    integer, intent(out) :: num_snowc                   ! number of column snow points in column filter
+    integer, intent(out) :: filter_snowc(ubc-lbc+1)     ! column filter for snow points
+    integer, intent(out) :: num_nosnowc                 ! number of column non-snow points in column filter
+    integer, intent(out) :: filter_nosnowc(ubc-lbc+1)   ! column filter for non-snow points
+!
+! !CALLED FROM:
+! subroutine Hydrology2 in Hydrology2Mod
+! subroutine CombineSnowLayers in this module
+!
+! !REVISION HISTORY:
+! 2003 July 31: Forrest Hoffman
+!
+! !LOCAL VARIABLES:
+! local pointers to implicit in arguments
+!
+!EOP
+!
+! !OTHER LOCAL VARIABLES:
+    integer  :: fc, c
+!-----------------------------------------------------------------------
+
+
+    ! Build snow/no-snow filters for other subroutines
+
+    num_snowc = 0
+    num_nosnowc = 0
+    do fc = 1, num_nolakec
+       c = filter_nolakec(fc)
+       if (snl(c) < 0) then
+          num_snowc = num_snowc + 1
+          filter_snowc(num_snowc) = c
+       else
+          num_nosnowc = num_nosnowc + 1
+          filter_nosnowc(num_nosnowc) = c
+       end if
+    end do
+
+  end subroutine BuildSnowFilter
+
+
+
+subroutine FrictionVelocity(pgridcell,forc_hgt,forc_hgt_u,        & !i 
+                             forc_hgt_t,forc_hgt_q,                  & !i 
+                             lbp, ubp, fn, filterp,                  & !i 
+                             displa, z0m, z0h, z0q,                  & !i 
+                             obu, iter, ur, um,                      & !i 
+                             ustar,temp1, temp2, temp12m, temp22m,   & !o 
+                             u10,fv,                                 & !o 
+                             fm)  !i&o 
+
+!=============================================================================
+! !DESCRIPTION:
+! Calculation of the friction velocity, relation for potential
+! temperature and humidity profiles of surface boundary layer.
+! The scheme is based on the work of Zeng et al. (1998):
+! Intercomparison of bulk aerodynamic algorithms for the computation
+! of sea surface fluxes using TOGA CORE and TAO data. J. Climate,
+! Vol. 11, 2628-2644.
+!
+! !REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+! 12/19/01, Peter Thornton
+! Added arguments to eliminate passing clm derived type into this function.
+! Created by Mariana Vertenstein
+!============================================================================
+! !USES:
+  ! use clmtype
+   !!use clm_atmlnd, only : clm_a2l
+!
+! !ARGUMENTS:
+   implicit none
+
+!in:
+
+   integer , intent(in) :: pgridcell(1)   ! pft's gridcell index
+   real(r8), intent(in) :: forc_hgt(1)    ! atmospheric reference height (m)
+   real(r8), intent(in) :: forc_hgt_u(1)  ! observational height of wind [m]
+   real(r8), intent(in) :: forc_hgt_t(1)  ! observational height of temperature [m]
+   real(r8), intent(in) :: forc_hgt_q(1)  ! observational height of humidity [m]
+   integer , intent(in)  :: lbp, ubp         ! pft array bounds
+   integer , intent(in)  :: fn               ! number of filtered pft elements
+   integer , intent(in)  :: filterp(fn)      ! pft filter
+   real(r8), intent(in)  :: displa(lbp:ubp)  ! displacement height (m)
+   real(r8), intent(in)  :: z0m(lbp:ubp)     ! roughness length over vegetation, momentum [m]
+   real(r8), intent(in)  :: z0h(lbp:ubp)     ! roughness length over vegetation, sensible heat [m]
+   real(r8), intent(in)  :: z0q(lbp:ubp)     ! roughness length over vegetation, latent heat [m]
+   real(r8), intent(in)  :: obu(lbp:ubp)     ! monin-obukhov length (m)
+   integer,  intent(in)  :: iter             ! iteration number
+   real(r8), intent(in)  :: ur(lbp:ubp)      ! wind speed at reference height [m/s]
+   real(r8), intent(in)  :: um(lbp:ubp)      ! wind speed including the stablity effect [m/s]
+
+!out:
+
+   real(r8), intent(out) :: ustar(lbp:ubp)   ! friction velocity [m/s]
+   real(r8), intent(out) :: temp1(lbp:ubp)   ! relation for potential temperature profile
+   real(r8), intent(out) :: temp12m(lbp:ubp) ! relation for potential temperature profile applied at 2-m
+   real(r8), intent(out) :: temp2(lbp:ubp)   ! relation for specific humidity profile
+   real(r8), intent(out) :: temp22m(lbp:ubp) ! relation for specific humidity profile applied at 2-m
+   real(r8), intent(out) :: u10(1)         ! 10-m wind (m/s) (for dust model)
+   real(r8), intent(out) :: fv(1)          ! friction velocity (m/s) (for dust model)
+
+!inout:
+   real(r8), intent(inout) :: fm(lbp:ubp)    ! needed for DGVM only to diagnose 10m wind
+
+! OTHER LOCAL VARIABLES:
+
+   real(r8), parameter :: zetam = 1.574_r8 ! transition point of flux-gradient relation (wind profile)
+   real(r8), parameter :: zetat = 0.465_r8 ! transition point of flux-gradient relation (temp. profile)
+   integer :: f                         ! pft-filter index
+   integer :: p                         ! pft index
+   integer :: g                         ! gridcell index
+   real(r8):: zldis(lbp:ubp)            ! reference height "minus" zero displacement heght [m]
+   real(r8):: zeta(lbp:ubp)             ! dimensionless height used in Monin-Obukhov theory
+#if (defined DGVM) || (defined DUST)
+   real(r8) :: tmp1,tmp2,tmp3,tmp4      ! Used to diagnose the 10 meter wind
+   real(r8) :: fmnew                    ! Used to diagnose the 10 meter wind
+   real(r8) :: fm10                     ! Used to diagnose the 10 meter wind
+   real(r8) :: zeta10                   ! Used to diagnose the 10 meter wind
+#endif
+!------------------------------------------------------------------------------
+
+
+   ! Adjustment factors for unstable (moz < 0) or stable (moz > 0) conditions.
+
+#if (!defined PERGRO)
+
+!dir$ concurrent
+!cdir nodep
+   do f = 1, fn
+      p = filterp(f)
+      g = pgridcell(p)
+
+      ! Wind profile
+
+      zldis(p) = forc_hgt_u(g)-displa(p)
+      zeta(p) = zldis(p)/obu(p)
+      if (zeta(p) < -zetam) then
+         ustar(p) = vkc*um(p)/(log(-zetam*obu(p)/z0m(p))&
+              - StabilityFunc1(-zetam) &
+              + StabilityFunc1(z0m(p)/obu(p)) &
+              + 1.14_r8*((-zeta(p))**0.333_r8-(zetam)**0.333_r8))
+      else if (zeta(p) < 0._r8) then
+         ustar(p) = vkc*um(p)/(log(zldis(p)/z0m(p))&
+              - StabilityFunc1(zeta(p))&
+              + StabilityFunc1(z0m(p)/obu(p)))
+      else if (zeta(p) <=  1._r8) then
+         ustar(p) = vkc*um(p)/(log(zldis(p)/z0m(p)) + 5._r8*zeta(p) -5._r8*z0m(p)/obu(p))
+      else
+         ustar(p) = vkc*um(p)/(log(obu(p)/z0m(p))+5._r8-5._r8*z0m(p)/obu(p) &
+              +(5._r8*log(zeta(p))+zeta(p)-1._r8))
+      end if
+
+      ! Temperature profile
+
+      zldis(p) = forc_hgt_t(g)-displa(p)
+      zeta(p) = zldis(p)/obu(p)
+      if (zeta(p) < -zetat) then
+         temp1(p) = vkc/(log(-zetat*obu(p)/z0h(p))&
+              - StabilityFunc2(-zetat) &
+              + StabilityFunc2(z0h(p)/obu(p)) &
+              + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(p))**(-0.333_r8)))
+      else if (zeta(p) < 0._r8) then
+         temp1(p) = vkc/(log(zldis(p)/z0h(p)) &
+              - StabilityFunc2(zeta(p)) &
+              + StabilityFunc2(z0h(p)/obu(p)))
+      else if (zeta(p) <=  1._r8) then
+         temp1(p) = vkc/(log(zldis(p)/z0h(p)) + 5._r8*zeta(p) - 5._r8*z0h(p)/obu(p))
+      else
+         temp1(p) = vkc/(log(obu(p)/z0h(p)) + 5._r8 - 5._r8*z0h(p)/obu(p) &
+              + (5._r8*log(zeta(p))+zeta(p)-1._r8))
+      end if
+
+      ! Humidity profile
+
+      if (forc_hgt_q(g) == forc_hgt_t(g) .and. z0q(p) == z0h(p)) then
+         temp2(p) = temp1(p)
+      else
+         zldis(p) = forc_hgt_q(g)-displa(p)
+         zeta(p) = zldis(p)/obu(p)
+         if (zeta(p) < -zetat) then
+            temp2(p) = vkc/(log(-zetat*obu(p)/z0q(p)) &
+                 - StabilityFunc2(-zetat) &
+                 + StabilityFunc2(z0q(p)/obu(p)) &
+                 + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(p))**(-0.333_r8)))
+         else if (zeta(p) < 0._r8) then
+            temp2(p) = vkc/(log(zldis(p)/z0q(p)) &
+                 - StabilityFunc2(zeta(p)) &
+                 + StabilityFunc2(z0q(p)/obu(p)))
+         else if (zeta(p) <=  1._r8) then
+            temp2(p) = vkc/(log(zldis(p)/z0q(p)) + 5._r8*zeta(p)-5._r8*z0q(p)/obu(p))
+         else
+            temp2(p) = vkc/(log(obu(p)/z0q(p)) + 5._r8 - 5._r8*z0q(p)/obu(p) &
+                 + (5._r8*log(zeta(p))+zeta(p)-1._r8))
+         end if
+      endif
+
+      ! Temperature profile applied at 2-m
+
+      zldis(p) = 2.0_r8 + z0h(p)
+      zeta(p) = zldis(p)/obu(p)
+      if (zeta(p) < -zetat) then
+         temp12m(p) = vkc/(log(-zetat*obu(p)/z0h(p))&
+              - StabilityFunc2(-zetat) &
+              + StabilityFunc2(z0h(p)/obu(p)) &
+              + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(p))**(-0.333_r8)))
+      else if (zeta(p) < 0._r8) then
+         temp12m(p) = vkc/(log(zldis(p)/z0h(p)) &
+              - StabilityFunc2(zeta(p))  &
+              + StabilityFunc2(z0h(p)/obu(p)))
+      else if (zeta(p) <=  1._r8) then
+         temp12m(p) = vkc/(log(zldis(p)/z0h(p)) + 5._r8*zeta(p) - 5._r8*z0h(p)/obu(p))
+      else
+         temp12m(p) = vkc/(log(obu(p)/z0h(p)) + 5._r8 - 5._r8*z0h(p)/obu(p) &
+              + (5._r8*log(zeta(p))+zeta(p)-1._r8))
+      end if
+
+      ! Humidity profile applied at 2-m
+
+      if (z0q(p) == z0h(p)) then
+         temp22m(p) = temp12m(p)
+      else
+         zldis(p) = 2.0_r8 + z0q(p)
+         zeta(p) = zldis(p)/obu(p)
+         if (zeta(p) < -zetat) then
+            temp22m(p) = vkc/(log(-zetat*obu(p)/z0q(p)) - &
+                 StabilityFunc2(-zetat) + StabilityFunc2(z0q(p)/obu(p)) &
+                 + 0.8_r8*((zetat)**(-0.333_r8)-(-zeta(p))**(-0.333_r8)))
+         else if (zeta(p) < 0._r8) then
+            temp22m(p) = vkc/(log(zldis(p)/z0q(p)) - &
+                 StabilityFunc2(zeta(p))+StabilityFunc2(z0q(p)/obu(p)))
+         else if (zeta(p) <=  1._r8) then
+            temp22m(p) = vkc/(log(zldis(p)/z0q(p)) + 5._r8*zeta(p)-5._r8*z0q(p)/obu(p))
+         else
+            temp22m(p) = vkc/(log(obu(p)/z0q(p)) + 5._r8 - 5._r8*z0q(p)/obu(p) &
+                 + (5._r8*log(zeta(p))+zeta(p)-1._r8))
+         end if
+      end if
+
+#if (defined DGVM) || (defined DUST)
+      ! diagnose 10-m wind for dust model (dstmbl.F)
+      ! Notes from C. Zender's dst.F:
+      ! According to Bon96 p. 62, the displacement height d (here displa) is
+      ! 0.0 <= d <= 0.34 m in dust source regions (i.e., regions w/o trees).
+      ! Therefore d <= 0.034*z1 and may safely be neglected.
+      ! Code from LSM routine SurfaceTemperature was used to obtain u10
+
+      zldis(p) = forc_hgt_u(g)-displa(p)
+      zeta(p) = zldis(p)/obu(p)
+      if (min(zeta(p), 1._r8) < 0._r8) then
+         tmp1 = (1._r8 - 16._r8*min(zeta(p),1._r8))**0.25_r8
+         tmp2 = log((1._r8+tmp1*tmp1)/2._r8)
+         tmp3 = log((1._r8+tmp1)/2._r8)
+         fmnew = 2._r8*tmp3 + tmp2 - 2._r8*atan(tmp1) + 1.5707963_r8
+      else
+         fmnew = -5._r8*min(zeta(p),1._r8)
+      endif
+      if (iter == 1) then
+         fm(p) = fmnew
+      else
+         fm(p) = 0.5_r8 * (fm(p)+fmnew)
+      end if
+      zeta10 = min(10._r8/obu(p), 1._r8)
+      if (zeta(p) == 0._r8) zeta10 = 0._r8
+      if (zeta10 < 0._r8) then
+         tmp1 = (1.0_r8 - 16.0_r8 * zeta10)**0.25_r8
+         tmp2 = log((1.0_r8 + tmp1*tmp1)/2.0_r8)
+         tmp3 = log((1.0_r8 + tmp1)/2.0_r8)
+         fm10 = 2.0_r8*tmp3 + tmp2 - 2.0_r8*atan(tmp1) + 1.5707963_r8
+      else                ! not stable
+         fm10 = -5.0_r8 * zeta10
+      end if
+      tmp4 = log(forc_hgt(g) / 10._r8)
+      u10(p) = ur(p) - ustar(p)/vkc * (tmp4 - fm(p) + fm10)
+      fv(p)  = ustar(p)
+#endif
+
+   end do
+#endif
+
+
+#if (defined PERGRO)
+
+   !===============================================================================
+   ! The following only applies when PERGRO is defined
+   !===============================================================================
+
+!dir$ concurrent
+!cdir nodep
+   do f = 1, fn
+      p = filterp(f)
+      g = pgridcell(p)
+
+      zldis(p) = forc_hgt_u(g)-displa(p)
+      zeta(p) = zldis(p)/obu(p)
+      if (zeta(p) < -zetam) then           ! zeta < -1
+         ustar(p) = vkc * um(p) / log(-zetam*obu(p)/z0m(p))
+      else if (zeta(p) < 0._r8) then         ! -1 <= zeta < 0
+         ustar(p) = vkc * um(p) / log(zldis(p)/z0m(p))
+      else if (zeta(p) <= 1._r8) then        !  0 <= ztea <= 1
+         ustar(p)=vkc * um(p)/log(zldis(p)/z0m(p))
+      else                             !  1 < zeta, phi=5+zeta
+         ustar(p)=vkc * um(p)/log(obu(p)/z0m(p))
+      endif
+
+      zldis(p) = forc_hgt_t(g)-displa(p)
+      zeta(p) = zldis(p)/obu(p)
+      if (zeta(p) < -zetat) then
+         temp1(p)=vkc/log(-zetat*obu(p)/z0h(p))
+      else if (zeta(p) < 0._r8) then
+         temp1(p)=vkc/log(zldis(p)/z0h(p))
+      else if (zeta(p) <= 1._r8) then
+         temp1(p)=vkc/log(zldis(p)/z0h(p))
+      else
+         temp1(p)=vkc/log(obu(p)/z0h(p))
+      end if
+
+      zldis(p) = forc_hgt_q(g)-displa(p)
+      zeta(p) = zldis(p)/obu(p)
+      if (zeta(p) < -zetat) then
+         temp2(p)=vkc/log(-zetat*obu(p)/z0q(p))
+      else if (zeta(p) < 0._r8) then
+         temp2(p)=vkc/log(zldis(p)/z0q(p))
+      else if (zeta(p) <= 1._r8) then
+         temp2(p)=vkc/log(zldis(p)/z0q(p))
+      else
+         temp2(p)=vkc/log(obu(p)/z0q(p))
+      end if
+
+      zldis(p) = 2.0_r8 + z0h(p)
+      zeta(p) = zldis(p)/obu(p)
+      if (zeta(p) < -zetat) then
+         temp12m(p)=vkc/log(-zetat*obu(p)/z0h(p))
+      else if (zeta(p) < 0._r8) then
+         temp12m(p)=vkc/log(zldis(p)/z0h(p))
+      else if (zeta(p) <= 1._r8) then
+         temp12m(p)=vkc/log(zldis(p)/z0h(p))
+      else
+         temp12m(p)=vkc/log(obu(p)/z0h(p))
+      end if
+
+      zldis(p) = 2.0_r8 + z0q(p)
+      zeta(p) = zldis(p)/obu(p)
+      if (zeta(p) < -zetat) then
+         temp22m(p)=vkc/log(-zetat*obu(p)/z0q(p))
+      else if (zeta(p) < 0._r8) then
+         temp22m(p)=vkc/log(zldis(p)/z0q(p))
+      else if (zeta(p) <= 1._r8) then
+         temp22m(p)=vkc/log(zldis(p)/z0q(p))
+      else
+         temp22m(p)=vkc/log(obu(p)/z0q(p))
+      end if
+#if (defined DGVM) || (defined DUST)
+      ! diagnose 10-m wind for dust model (dstmbl.F)
+      ! Notes from C. Zender's dst.F:
+      ! According to Bon96 p. 62, the displacement height d (here displa) is
+      ! 0.0 <= d <= 0.34 m in dust source regions (i.e., regions w/o trees).
+      ! Therefore d <= 0.034*z1 and may safely be neglected.
+      ! Code from LSM routine SurfaceTemperature was used to obtain u10
+
+      zldis(p) = forc_hgt_u(g)-displa(p)
+      zeta(p) = zldis(p)/obu(p)
+      if (min(zeta(p), 1._r8) < 0._r8) then
+         tmp1 = (1._r8 - 16._r8*min(zeta(p),1._r8))**0.25_r8
+         tmp2 = log((1._r8+tmp1*tmp1)/2._r8)
+         tmp3 = log((1._r8+tmp1)/2._r8)
+         fmnew = 2._r8*tmp3 + tmp2 - 2._r8*atan(tmp1) + 1.5707963_r8
+      else
+         fmnew = -5._r8*min(zeta(p),1._r8)
+      endif
+      if (iter == 1) then
+         fm(p) = fmnew
+      else
+         fm(p) = 0.5_r8 * (fm(p)+fmnew)
+      end if
+      zeta10 = min(10._r8/obu(p), 1._r8)
+      if (zeta(p) == 0._r8) zeta10 = 0._r8
+      if (zeta10 < 0._r8) then
+         tmp1 = (1.0_r8 - 16.0_r8 * zeta10)**0.25_r8
+         tmp2 = log((1.0_r8 + tmp1*tmp1)/2.0_r8)
+         tmp3 = log((1.0_r8 + tmp1)/2.0_r8)
+         fm10 = 2.0_r8*tmp3 + tmp2 - 2.0_r8*atan(tmp1) + 1.5707963_r8
+      else                ! not stable
+         fm10 = -5.0_r8 * zeta10
+      end if
+      tmp4 = log(forc_hgt(g) / 10._r8)
+      u10(p) = ur(p) - ustar(p)/vkc * (tmp4 - fm(p) + fm10)
+      fv(p)  = ustar(p)
+#endif
+   end do
+
+#endif
+
+   end subroutine FrictionVelocity
+
+! !IROUTINE: StabilityFunc
+!
+! !INTERFACE:
+   real(r8) function StabilityFunc1(zeta)
+!
+! !DESCRIPTION:
+! Stability function for rib < 0.
+!
+! !USES:
+!      use shr_const_mod, only: SHR_CONST_PI
+!Zack Subin, 7/8/08
+!
+! !ARGUMENTS:
+      implicit none
+      real(r8), intent(in) :: zeta  ! dimensionless height used in Monin-Obukhov theory
+!
+! !CALLED FROM:
+! subroutine FrictionVelocity in this module
+!
+! !REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+!
+!EOP
+!
+! !LOCAL VARIABLES:
+      real(r8) :: chik, chik2
+!------------------------------------------------------------------------------
+
+      chik2 = sqrt(1._r8-16._r8*zeta)
+      chik = sqrt(chik2)
+      StabilityFunc1 = 2._r8*log((1._r8+chik)*0.5_r8) &
+!Changed to pie, Zack Subin, 7/9/08
+           + log((1._r8+chik2)*0.5_r8)-2._r8*atan(chik)+pie*0.5_r8
+
+    end function StabilityFunc1
+
+!------------------------------------------------------------------------------
+!BOP
+!
+! !IROUTINE: StabilityFunc2
+!
+! !INTERFACE:
+   real(r8) function StabilityFunc2(zeta)
+!
+! !DESCRIPTION:
+! Stability function for rib < 0.
+!
+! !USES:
+!Removed by Zack Subin, 7/9/08
+!     use shr_const_mod, only: SHR_CONST_PI
+!
+! !ARGUMENTS:
+     implicit none
+     real(r8), intent(in) :: zeta  ! dimensionless height used in Monin-Obukhov theory
+!
+! !CALLED FROM:
+! subroutine FrictionVelocity in this module
+!
+! !REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+!
+!EOP
+!
+! !LOCAL VARIABLES:
+     real(r8) :: chik2
+!------------------------------------------------------------------------------
+
+     chik2 = sqrt(1._r8-16._r8*zeta)
+     StabilityFunc2 = 2._r8*log((1._r8+chik2)*0.5_r8)
+
+   end function StabilityFunc2
+
+!-----------------------------------------------------------------------
+!BOP
+!
+! !IROUTINE: MoninObukIni
+!
+! !INTERFACE:
+  subroutine MoninObukIni (ur, thv, dthv, zldis, z0m, um, obu)
+!
+! !DESCRIPTION:
+! Initialization of the Monin-Obukhov length.
+! The scheme is based on the work of Zeng et al. (1998):
+! Intercomparison of bulk aerodynamic algorithms for the computation
+! of sea surface fluxes using TOGA CORE and TAO data. J. Climate,
+! Vol. 11, 2628-2644.
+!
+! !USES:
+!
+! !ARGUMENTS:
+    implicit none
+    real(r8), intent(in)  :: ur    ! wind speed at reference height [m/s]
+    real(r8), intent(in)  :: thv   ! virtual potential temperature (kelvin)
+    real(r8), intent(in)  :: dthv  ! diff of vir. poten. temp. between ref. height and surface
+    real(r8), intent(in)  :: zldis ! reference height "minus" zero displacement heght [m]
+    real(r8), intent(in)  :: z0m   ! roughness length, momentum [m]
+    real(r8), intent(out) :: um    ! wind speed including the stability effect [m/s]
+    real(r8), intent(out) :: obu   ! monin-obukhov length (m)
+!
+! !CALLED FROM:
+! subroutine BareGroundFluxes in module BareGroundFluxesMod.F90
+! subroutine BiogeophysicsLake in module BiogeophysicsLakeMod.F90
+! subroutine CanopyFluxes in module CanopyFluxesMod.F90
+!
+! !REVISION HISTORY:
+! 15 September 1999: Yongjiu Dai; Initial code
+! 15 December 1999:  Paul Houser and Jon Radakovich; F90 Revision
+!
+!EOP
+!
+! !LOCAL VARIABLES:
+!
+    real(r8) :: wc    ! convective velocity [m/s]
+    real(r8) :: rib   ! bulk Richardson number
+    real(r8) :: zeta  ! dimensionless height used in Monin-Obukhov theory
+    real(r8) :: ustar ! friction velocity [m/s]
+!-----------------------------------------------------------------------
+
+    ! Initial values of u* and convective velocity
+
+    ustar=0.06_r8
+    wc=0.5_r8
+    if (dthv >= 0._r8) then
+       um=max(ur,0.1_r8)
+    else
+       um=sqrt(ur*ur+wc*wc)
+    endif
+
+    rib=grav*zldis*dthv/(thv*um*um)
+#if (defined PERGRO)
+    rib = 0._r8
+#endif
+
+    if (rib >= 0._r8) then      ! neutral or stable
+       zeta = rib*log(zldis/z0m)/(1._r8-5._r8*min(rib,0.19_r8))
+       zeta = min(2._r8,max(zeta,0.01_r8 ))
+    else                     ! unstable
+       zeta=rib*log(zldis/z0m)
+       zeta = max(-100._r8,min(zeta,-0.01_r8 ))
+    endif
+
+    obu=zldis/zeta
+
+  end subroutine MoninObukIni
+
+subroutine LakeDebug( str ) 
+ 
+  IMPLICIT NONE
+  CHARACTER*(*), str
+ 
+  print*, TRIM(str)
+  call flush(6)
+ 
+end subroutine LakeDebug
+
+ SUBROUTINE lakeini(IVGTYP,         ISLTYP,          HT,              SNOW,           & !i
+                    lake_min_elev,     restart,        lakedepth_default, lake_depth,     &
+                    lakedepth2d,    savedtke12d,     snowdp2d,        h2osno2d,       & !o
+                    snl2d,          t_grnd2d,        t_lake3d,        lake_icefrac3d, &
+                    z_lake3d,       dz_lake3d,       t_soisno3d,      h2osoi_ice3d,   &
+                    h2osoi_liq3d,   h2osoi_vol3d,    z3d,             dz3d,           &
+                    zi3d,           watsat3d,        csol3d,          tkmg3d,         &
+                    iswater,        xice,            xice_threshold,  xland,   tsk,   &
+#if (EM_CORE == 1)
+                    lakemask,       lakeflag,                                         &
+#endif
+                    lake_depth_flag, use_lakedepth,                                   &
+                    tkdry3d,        tksatu3d,        lake,            its, ite, jts, jte, &
+                    ims,ime, jms,jme)
+
+!==============================================================================
+! This subroutine was first edited by Hongping Gu for coupling
+! 07/20/2010
+!==============================================================================
+
+  USE module_wrf_error
+  implicit none
+
+  INTEGER , INTENT (IN) :: iswater
+  REAL,     INTENT(IN)  :: xice_threshold
+  REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   XICE
+  REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)::      TSK
+  REAL, DIMENSION( ims:ime, jms:jme )  ,INTENT(INOUT)  :: XLAND
+
+#if (EM_CORE == 1)
+  REAL, DIMENSION( ims:ime , jms:jme ) ::   LAKEMASK
+  INTEGER , INTENT (IN) :: lakeflag
+#endif
+  INTEGER , INTENT (INOUT) :: lake_depth_flag
+  INTEGER , INTENT (IN) ::   use_lakedepth
+
+  LOGICAL , INTENT(IN)      ::     restart
+  INTEGER,  INTENT(IN   )   ::     ims,ime, jms,jme
+  INTEGER,  INTENT(IN   )   ::     its,ite, jts,jte
+  INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)       :: IVGTYP,       &
+                                                              ISLTYP
+  REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(IN)       :: HT
+  REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)    :: SNOW
+  real,    intent(in)                                      :: lakedepth_default,lake_min_elev
+
+  real,    dimension(ims:ime,jms:jme ),intent(out)                        :: lakedepth2d,    &
+                                                                             savedtke12d
+  real,    dimension(ims:ime,jms:jme ),intent(out)                        :: snowdp2d,       &
+                                                                             h2osno2d,       &
+                                                                             snl2d,          &
+                                                                             t_grnd2d
+                                                                              
+  real,    dimension( ims:ime,1:nlevlake, jms:jme ),INTENT(out)            :: t_lake3d,       &
+                                                                             lake_icefrac3d, &
+                                                                             z_lake3d,       &
+                                                                             dz_lake3d
+  real,    dimension( ims:ime,-nlevsnow+1:nlevsoil, jms:jme ),INTENT(out)   :: t_soisno3d,     &
+                                                                             h2osoi_ice3d,   &
+                                                                             h2osoi_liq3d,   &
+                                                                             h2osoi_vol3d,   &
+                                                                             z3d,            &
+                                                                             dz3d
+  real,    dimension( ims:ime,1:nlevsoil, jms:jme ),INTENT(out)            :: watsat3d,       &
+                                                                             csol3d,         &
+                                                                             tkmg3d,         &
+                                                                             tkdry3d,        &
+                                                                             tksatu3d
+  real,    dimension( ims:ime,-nlevsnow+0:nlevsoil, jms:jme ),INTENT(out)   :: zi3d            
+
+  LOGICAL, DIMENSION( ims:ime, jms:jme ),intent(out)                      :: lake
+  REAL, OPTIONAL,    DIMENSION( ims:ime, jms:jme ), INTENT(IN)    ::  lake_depth
+
+  real,    dimension( ims:ime,1:nlevsoil, jms:jme )   :: bsw3d,    &
+                                                        bsw23d,   &
+                                                        psisat3d, &
+                                                        vwcsat3d, &
+                                                        watdry3d, &
+                                                        watopt3d, &
+                                                        hksat3d,  &
+                                                        sucsat3d, &
+                                                        clay3d,   &
+                                                        sand3d   
+  integer  :: n,i,j,k,ib,lev,bottom      ! indices
+  real(r8),dimension(ims:ime,jms:jme )    :: bd2d               ! bulk density of dry soil material [kg/m^3]
+  real(r8),dimension(ims:ime,jms:jme )    :: tkm2d              ! mineral conductivity
+  real(r8),dimension(ims:ime,jms:jme )    :: xksat2d            ! maximum hydraulic conductivity of soil [mm/s]
+  real(r8),dimension(ims:ime,jms:jme )    :: depthratio2d       ! ratio of lake depth to standard deep lake depth 
+  real(r8),dimension(ims:ime,jms:jme )    :: clay2d             ! temporary
+  real(r8),dimension(ims:ime,jms:jme )    :: sand2d             ! temporary
+
+  real(r8)                 :: scalez  = 0.025_r8   ! Soil layer thickness discretization (m)
+  logical,parameter        :: arbinit = .true.
+  real,parameter           :: defval  = -999.0
+  integer                  :: isl
+  integer                  :: numb_lak    ! for debug
+  character*256 :: message
+
+  IF ( RESTART ) RETURN 
+
+  DO j = jts,jte
+  DO i = its,ite
+        snowdp2d(i,j)         = snow(i,j)*0.005               ! SNOW in kg/m^2 and snowdp in m
+	h2osno2d(i,j)         = snow(i,j) ! mm 
+  ENDDO
+  ENDDO
+
+! initialize all the grid with default value 
+  DO j = jts,jte
+  DO i = its,ite
+
+    lakedepth2d(i,j)             = defval
+    snl2d(i,j)                   = defval
+    do k = -nlevsnow+1,nlevsoil
+        h2osoi_liq3d(i,k,j)      = defval
+        h2osoi_ice3d(i,k,j)      = defval
+	t_soisno3d(i,k,j)        = defval
+        z3d(i,k,j)               = defval 
+        dz3d(i,k,j)              = defval                           
+    enddo
+    do k = 1,nlevlake 
+	t_lake3d(i,k,j)          = defval
+        lake_icefrac3d(i,k,j)    = defval
+        z_lake3d(i,k,j)          = defval
+        dz_lake3d(i,k,j)         = defval
+    enddo
+
+  ENDDO
+  ENDDO
+
+! judge whether the grid is lake grid
+   numb_lak = 0
+       do i=its,ite
+         do j=jts,jte
+#if (EM_CORE==1)
+         IF (lakeflag.eq.0) THEN    
+            if(ht(i,j)>=lake_min_elev) then 
+              if ( xice(i,j).gt.xice_threshold) then   !mchen
+                   ivgtyp(i,j) = iswater
+                   xland(i,j) = 2. 
+                   lake_icefrac3d(i,1,j) = xice(i,j)
+                   xice(i,j)=0.0
+               endif
+            endif
+
+            if(ivgtyp(i,j)==iswater.and.ht(i,j)>=lake_min_elev) then 
+                lake(i,j)  = .true.
+                lakemask(i,j) = 1
+                numb_lak   = numb_lak + 1
+            else 
+                lake(i,j)  = .false.
+                lakemask(i,j) = 0
+            end if
+          ELSE
+            if(lakemask(i,j).eq.1) then 
+                lake(i,j)  = .true.
+                numb_lak   = numb_lak + 1
+                if ( xice(i,j).gt.xice_threshold) then   !mchen
+                   ivgtyp(i,j) = iswater
+                   xland(i,j) = 2. 
+                   lake_icefrac3d(i,1,j) = xice(i,j)
+                   xice(i,j)=0.0
+                endif
+             else  
+                lake(i,j)  = .false.
+             endif
+         ENDIF   ! end if lakeflag=0
+#else
+            if(ht(i,j)>=lake_min_elev) then 
+              if ( xice(i,j).gt.xice_threshold) then   !mchen
+                   ivgtyp(i,j) = iswater
+                   xland(i,j) = 2. 
+                   lake_icefrac3d(i,1,j) = xice(i,j)
+                   xice(i,j)=0.0
+               endif
+            endif
+            if(ivgtyp(i,j)==iswater.and.ht(i,j)>=lake_min_elev) then 
+                lake(i,j)  = .true.
+                numb_lak   = numb_lak + 1
+            else 
+                lake(i,j)  = .false.
+            end if
+
+#endif
+        end do
+       end do
+    write(message,*) "the total number of lake grid is :", numb_lak
+    CALL wrf_message(message)
+!    CALL LakeDebug(msg)
+! initialize lake grid 
+
+  DO j = jts,jte
+  DO i = its,ite
+
+     if ( lake(i,j) ) then
+
+!	t_soisno3d(i,:,j)      = tsk(i,j)
+!        t_lake3d(i,:,j)        = tsk(i,j)
+!        t_grnd2d(i,j)          = tsk(i,j)
+
+        z3d(i,:,j)             = 0.0
+        dz3d(i,:,j)            = 0.0
+        zi3d(i,:,j)            = 0.0
+        h2osoi_liq3d(i,:,j)    = 0.0
+        h2osoi_ice3d(i,:,j)    = 0.0
+        lake_icefrac3d(i,:,j)  = 0.0
+        h2osoi_vol3d(i,:,j)    = 0.0
+        snl2d(i,j)             = 0.0
+          if ( use_lakedepth.eq.1 .and.lake_depth_flag.eq.0 ) then !mchen
+          call wrf_error_fatal ( 'STOP: You need lake-depth information. Rerun WPS or set use_lakedepth = 0')
+          end if
+          if ( use_lakedepth.eq.0 .and.lake_depth_flag.eq.1 ) then !mchen
+          lake_depth_flag = 0 
+          end if
+        if ( lake_depth_flag.eq.1 ) then
+
+          if (lake_depth(i,j) > 0.0) then 
+            lakedepth2d(i,j)   = lake_depth(i,j)
+          else
+            if ( lakedepth_default  > 0.0 ) then
+               lakedepth2d(i,j)   = lakedepth_default
+            else 
+               lakedepth2d(i,j)   = spval
+            endif
+          endif
+
+        else
+          if ( lakedepth_default  > 0.0 ) then
+             lakedepth2d(i,j)   = lakedepth_default
+          else 
+             lakedepth2d(i,j)   = spval
+          endif
+        endif
+     endif
+
+  ENDDO
+  ENDDO 
+
+  
+#ifndef EXTRALAKELAYERS   
+!  dzlak(1) = 0.1_r8
+!  dzlak(2) = 1._r8
+!  dzlak(3) = 2._r8
+!  dzlak(4) = 3._r8
+!  dzlak(5) = 4._r8
+!  dzlak(6) = 5._r8
+!  dzlak(7) = 7._r8
+!  dzlak(8) = 7._r8
+!  dzlak(9) = 10.45_r8
+!  dzlak(10)= 10.45_r8
+!
+!  zlak(1) =  0.05_r8
+!  zlak(2) =  0.6_r8
+!  zlak(3) =  2.1_r8
+!  zlak(4) =  4.6_r8
+!  zlak(5) =  8.1_r8
+!  zlak(6) = 12.6_r8
+!  zlak(7) = 18.6_r8
+!  zlak(8) = 25.6_r8
+!  zlak(9) = 34.325_r8
+!  zlak(10)= 44.775_r8
+  dzlak(1) = 0.1_r8
+  dzlak(2) = 0.1_r8
+  dzlak(3) = 0.1_r8
+  dzlak(4) = 0.1_r8
+  dzlak(5) = 0.1_r8
+  dzlak(6) = 0.1_r8
+  dzlak(7) = 0.1_r8
+  dzlak(8) = 0.1_r8
+  dzlak(9) = 0.1_r8
+  dzlak(10)= 0.1_r8
+ 
+  zlak(1) =  0.05_r8
+  zlak(2) =  0.15_r8
+  zlak(3) =  0.25_r8
+  zlak(4) =  0.35_r8
+  zlak(5) =  0.45_r8
+  zlak(6) = 0.55_r8
+  zlak(7) = 0.65_r8
+  zlak(8) = 0.75_r8
+  zlak(9) = 0.85_r8
+  zlak(10)= 0.95_r8
+#else
+  dzlak(1) =0.1_r8
+  dzlak(2) =0.25_r8
+  dzlak(3) =0.25_r8
+  dzlak(4) =0.25_r8
+  dzlak(5) =0.25_r8
+  dzlak(6) =0.5_r8
+  dzlak(7) =0.5_r8
+  dzlak(8) =0.5_r8
+  dzlak(9) =0.5_r8
+  dzlak(10) =0.75_r8
+  dzlak(11) =0.75_r8
+  dzlak(12) =0.75_r8
+  dzlak(13) =0.75_r8
+  dzlak(14) =2_r8
+  dzlak(15) =2_r8
+  dzlak(16) =2.5_r8
+  dzlak(17) =2.5_r8
+  dzlak(18) =3.5_r8
+  dzlak(19) =3.5_r8
+  dzlak(20) =3.5_r8
+  dzlak(21) =3.5_r8
+  dzlak(22) =5.225_r8
+  dzlak(23) =5.225_r8
+  dzlak(24) =5.225_r8
+  dzlak(25) =5.225_r8
+
+  zlak(1) = dzlak(1)/2._r8
+  do k = 2,nlevlake
+     zlak(k) = zlak(k-1) + (dzlak(k-1)+dzlak(k))/2._r8
+  end do
+#endif
+
+   ! "0" refers to soil surface and "nlevsoil" refers to the bottom of model soil
+
+   do j = 1, nlevsoil
+      zsoi(j) = scalez*(exp(0.5_r8*(j-0.5_r8))-1._r8)    !node depths
+   enddo
+
+   dzsoi(1) = 0.5_r8*(zsoi(1)+zsoi(2))             !thickness b/n two interfaces
+   do j = 2,nlevsoil-1
+      dzsoi(j)= 0.5_r8*(zsoi(j+1)-zsoi(j-1))
+   enddo
+   dzsoi(nlevsoil) = zsoi(nlevsoil)-zsoi(nlevsoil-1)
+
+   zisoi(0) = 0._r8
+   do j = 1, nlevsoil-1
+      zisoi(j) = 0.5_r8*(zsoi(j)+zsoi(j+1))         !interface depths
+   enddo
+   zisoi(nlevsoil) = zsoi(nlevsoil) + 0.5_r8*dzsoi(nlevsoil)
+
+
+!!!!!!!!!!!!!!!!!!begin to initialize lake variables!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+  DO j = jts,jte
+  DO i = its,ite
+      
+     if ( lake(i,j) ) then
+
+                             ! Soil hydraulic and thermal properties
+         isl = ISLTYP(i,j)   
+         if (isl == 14 ) isl = isl + 1 
+         do k = 1,nlevsoil
+            sand3d(i,k,j)  = sand(isl)
+            clay3d(i,k,j)  = clay(isl)
+         enddo
+
+         do k = 1,nlevsoil
+            clay2d(i,j) = clay3d(i,k,j)
+            sand2d(i,j) = sand3d(i,k,j)
+            watsat3d(i,k,j) = 0.489_r8 - 0.00126_r8*sand2d(i,j)
+            bd2d(i,j)    = (1._r8-watsat3d(i,k,j))*2.7e3_r8
+            xksat2d(i,j) = 0.0070556_r8 *( 10._r8**(-0.884_r8+0.0153_r8*sand2d(i,j)) ) ! mm/s
+            tkm2d(i,j) = (8.80_r8*sand2d(i,j)+2.92_r8*clay2d(i,j))/(sand2d(i,j)+clay2d(i,j))          ! W/(m K)
+
+            bsw3d(i,k,j) = 2.91_r8 + 0.159_r8*clay2d(i,j)
+            bsw23d(i,k,j) = -(3.10_r8 + 0.157_r8*clay2d(i,j) - 0.003_r8*sand2d(i,j))
+            psisat3d(i,k,j) = -(exp((1.54_r8 - 0.0095_r8*sand2d(i,j) + 0.0063_r8*(100.0_r8-sand2d(i,j)  &
+                              -clay2d(i,j)))*log(10.0_r8))*9.8e-5_r8)
+            vwcsat3d(i,k,j) = (50.5_r8 - 0.142_r8*sand2d(i,j) - 0.037_r8*clay2d(i,j))/100.0_r8
+            hksat3d(i,k,j) = xksat2d(i,j)
+            sucsat3d(i,k,j) = 10._r8 * ( 10._r8**(1.88_r8-0.0131_r8*sand2d(i,j)) )
+            tkmg3d(i,k,j) = tkm2d(i,j) ** (1._r8- watsat3d(i,k,j))
+            tksatu3d(i,k,j) = tkmg3d(i,k,j)*0.57_r8**watsat3d(i,k,j)
+            tkdry3d(i,k,j) = (0.135_r8*bd2d(i,j) + 64.7_r8) / (2.7e3_r8 - 0.947_r8*bd2d(i,j))
+            csol3d(i,k,j) = (2.128_r8*sand2d(i,j)+2.385_r8*clay2d(i,j)) / (sand2d(i,j)+clay2d(i,j))*1.e6_r8  ! J/(m3 K)
+            watdry3d(i,k,j) = watsat3d(i,k,j) * (316230._r8/sucsat3d(i,k,j)) ** (-1._r8/bsw3d(i,k,j))
+            watopt3d(i,k,j) = watsat3d(i,k,j) * (158490._r8/sucsat3d(i,k,j)) ** (-1._r8/bsw3d(i,k,j))
+         end do
+         if (lakedepth2d(i,j) == spval) then
+            lakedepth2d(i,j) = zlak(nlevlake) + 0.5_r8*dzlak(nlevlake)
+            z_lake3d(i,1:nlevlake,j) = zlak(1:nlevlake)
+            dz_lake3d(i,1:nlevlake,j) = dzlak(1:nlevlake)
+         else
+            depthratio2d(i,j) = lakedepth2d(i,j) / (zlak(nlevlake) + 0.5_r8*dzlak(nlevlake)) 
+            z_lake3d(i,1,j) = zlak(1)
+            dz_lake3d(i,1,j) = dzlak(1)
+            dz_lake3d(i,2:nlevlake,j) = dzlak(2:nlevlake)*depthratio2d(i,j)
+            z_lake3d(i,2:nlevlake,j) = zlak(2:nlevlake)*depthratio2d(i,j) + dz_lake3d(i,1,j)*(1._r8 - depthratio2d(i,j))
+         end if
+! initial t_lake3d here
+	t_soisno3d(i,1,j)      = tsk(i,j)
+        t_lake3d(i,1,j)        = tsk(i,j)
+        t_grnd2d(i,j)          = 277.0
+        do k = 2, nlevlake
+        if(z_lake3d(i,k,j).le.depth_c) then 
+         t_soisno3d(i,k,j)=tsk(i,j)+(277.0-tsk(i,j))/depth_c*z_lake3d(i,k,j)
+         t_lake3d(i,k,j)=tsk(i,j)+(277.0-tsk(i,j))/depth_c*z_lake3d(i,k,j)
+        else
+	t_soisno3d(i,k,j)      = 277.0
+        t_lake3d(i,k,j)        = 277.0
+        end if 
+        enddo
+!end initial t_lake3d here
+         z3d(i,1:nlevsoil,j) = zsoi(1:nlevsoil)
+         zi3d(i,0:nlevsoil,j) = zisoi(0:nlevsoil)
+         dz3d(i,1:nlevsoil,j) = dzsoi(1:nlevsoil)
+         savedtke12d(i,j) = tkwat ! Initialize for first timestep.
+   
+
+        if (snowdp2d(i,j) < 0.01_r8) then
+           snl2d(i,j) = 0
+           dz3d(i,-nlevsnow+1:0,j) = 0._r8
+           z3d (i,-nlevsnow+1:0,j) = 0._r8
+           zi3d(i,-nlevsnow+0:0,j) = 0._r8
+        else
+           if ((snowdp2d(i,j) >= 0.01_r8) .and. (snowdp2d(i,j) <= 0.03_r8)) then
+              snl2d(i,j) = -1
+              dz3d(i,0,j)  = snowdp2d(i,j)
+           else if ((snowdp2d(i,j) > 0.03_r8) .and. (snowdp2d(i,j) <= 0.04_r8)) then
+              snl2d(i,j) = -2
+              dz3d(i,-1,j) = snowdp2d(i,j)/2._r8
+              dz3d(i, 0,j) = dz3d(i,-1,j)
+           else if ((snowdp2d(i,j) > 0.04_r8) .and. (snowdp2d(i,j) <= 0.07_r8)) then
+              snl2d(i,j) = -2
+              dz3d(i,-1,j) = 0.02_r8
+              dz3d(i, 0,j) = snowdp2d(i,j) - dz3d(i,-1,j)
+           else if ((snowdp2d(i,j) > 0.07_r8) .and. (snowdp2d(i,j) <= 0.12_r8)) then
+              snl2d(i,j) = -3
+              dz3d(i,-2,j) = 0.02_r8
+              dz3d(i,-1,j) = (snowdp2d(i,j) - 0.02_r8)/2._r8
+              dz3d(i, 0,j) = dz3d(i,-1,j)
+           else if ((snowdp2d(i,j) > 0.12_r8) .and. (snowdp2d(i,j) <= 0.18_r8)) then
+              snl2d(i,j) = -3
+              dz3d(i,-2,j) = 0.02_r8
+              dz3d(i,-1,j) = 0.05_r8
+              dz3d(i, 0,j) = snowdp2d(i,j) - dz3d(i,-2,j) - dz3d(i,-1,j)
+           else if ((snowdp2d(i,j) > 0.18_r8) .and. (snowdp2d(i,j) <= 0.29_r8)) then
+              snl2d(i,j) = -4
+              dz3d(i,-3,j) = 0.02_r8
+              dz3d(i,-2,j) = 0.05_r8
+              dz3d(i,-1,j) = (snowdp2d(i,j) - dz3d(i,-3,j) - dz3d(i,-2,j))/2._r8
+              dz3d(i, 0,j) = dz3d(i,-1,j)
+           else if ((snowdp2d(i,j) > 0.29_r8) .and. (snowdp2d(i,j) <= 0.41_r8)) then
+              snl2d(i,j) = -4
+              dz3d(i,-3,j) = 0.02_r8
+              dz3d(i,-2,j) = 0.05_r8
+              dz3d(i,-1,j) = 0.11_r8
+              dz3d(i, 0,j) = snowdp2d(i,j) - dz3d(i,-3,j) - dz3d(i,-2,j) - dz3d(i,-1,j)
+           else if ((snowdp2d(i,j) > 0.41_r8) .and. (snowdp2d(i,j) <= 0.64_r8)) then
+              snl2d(i,j) = -5
+              dz3d(i,-4,j) = 0.02_r8
+              dz3d(i,-3,j) = 0.05_r8
+              dz3d(i,-2,j) = 0.11_r8
+              dz3d(i,-1,j) = (snowdp2d(i,j) - dz3d(i,-4,j) - dz3d(i,-3,j) - dz3d(i,-2,j))/2._r8
+              dz3d(i, 0,j) = dz3d(i,-1,j)
+           else if (snowdp2d(i,j) > 0.64_r8) then
+              snl2d(i,j) = -5
+              dz3d(i,-4,j) = 0.02_r8
+              dz3d(i,-3,j) = 0.05_r8
+              dz3d(i,-2,j) = 0.11_r8
+              dz3d(i,-1,j) = 0.23_r8
+              dz3d(i, 0,j)=snowdp2d(i,j)-dz3d(i,-4,j)-dz3d(i,-3,j)-dz3d(i,-2,j)-dz3d(i,-1,j)
+           endif
+        end if
+ 
+        do k = 0, snl2d(i,j)+1, -1
+           z3d(i,k,j)    = zi3d(i,k,j) - 0.5_r8*dz3d(i,k,j)
+           zi3d(i,k-1,j) = zi3d(i,k,j) - dz3d(i,k,j)
+        end do
+
+! 3:subroutine makearbinit
+
+        if (snl2d(i,j) < 0) then
+           do k = snl2d(i,j)+1, 0
+                ! Be careful because there may be new snow layers with bad temperatures like 0 even if
+                ! coming from init. con. file.
+              if(arbinit .or. t_soisno3d(i,k,j) > 300 .or. t_soisno3d(i,k,j) < 200) t_soisno3d(i,k,j) = 250._r8
+           enddo
+        end if
+
+        do k = 1, nlevsoil
+           if(arbinit .or. t_soisno3d(i,k,j) > 1000 .or. t_soisno3d(i,k,j) < 0) t_soisno3d(i,k,j) = t_lake3d(i,nlevlake,j)
+        end do
+
+        do k = 1, nlevlake
+           if(arbinit .or. lake_icefrac3d(i,k,j) > 1._r8 .or. lake_icefrac3d(i,k,j) < 0._r8) then
+              if(t_lake3d(i,k,j) >= tfrz) then
+                 lake_icefrac3d(i,k,j) = 0._r8
+              else
+                 lake_icefrac3d(i,k,j) = 1._r8
+              end if
+           end if
+        end do
+        
+        do k = 1,nlevsoil
+           if (arbinit .or. h2osoi_vol3d(i,k,j) > 10._r8 .or. h2osoi_vol3d(i,k,j) < 0._r8) h2osoi_vol3d(i,k,j) = 1.0_r8
+           h2osoi_vol3d(i,k,j) = min(h2osoi_vol3d(i,k,j),watsat3d(i,k,j))
+
+             ! soil layers
+           if (t_soisno3d(i,k,j) <= tfrz) then
+              h2osoi_ice3d(i,k,j)  = dz3d(i,k,j)*denice*h2osoi_vol3d(i,k,j)
+              h2osoi_liq3d(i,k,j) = 0._r8
+           else
+              h2osoi_ice3d(i,k,j) = 0._r8
+              h2osoi_liq3d(i,k,j) = dz3d(i,k,j)*denh2o*h2osoi_vol3d(i,k,j)
+           endif
+        enddo
+
+        do k = -nlevsnow+1, 0
+           if (k > snl2d(i,j)) then
+              h2osoi_ice3d(i,k,j) = dz3d(i,k,j)*bdsno
+              h2osoi_liq3d(i,k,j) = 0._r8
+           end if
+        end do
+
+    end if   !lake(i,j)
+  ENDDO
+  ENDDO
+
+  END SUBROUTINE lakeini
+
+END MODULE module_sf_lake
diff --git a/wrfv2_fire/phys/module_sf_mynn.F b/wrfv2_fire/phys/module_sf_mynn.F
index 330e8670..3b585ebd 100644
--- a/wrfv2_fire/phys/module_sf_mynn.F
+++ b/wrfv2_fire/phys/module_sf_mynn.F
@@ -16,10 +16,11 @@ MODULE module_sf_mynn
 !
 !   LAND only:
 !1) iz0tlnd option is now available with the following options:
-!   (default) =0: Zilitinkevich (1995) with Czil=0.1, 
+!   (default) =0: Zilitinkevich (1995) 
 !             =1: Czil_new (modified according to Chen & Zhang 2008)
 !             =2: Modified Yang et al (2002, 2008) - generalized for all landuse
 !             =3: constant zt = z0/7.4 (original form; Garratt 1992)
+!             =4: Pan et al. (1994) with RUC mods for z_q, zili for z_t
 !2) Relaxed u* minimum from 0.1 to 0.01
 !
 !   WATER only:
@@ -43,7 +44,7 @@ MODULE module_sf_mynn
 
   USE module_sf_sfclay, ONLY: sfclayinit
   USE module_bl_mynn,   only: tv0, mym_condensation
-  
+!  USE module_wrf_error
 !-------------------------------------------------------------------
   IMPLICIT NONE
 !-------------------------------------------------------------------
@@ -51,15 +52,10 @@ MODULE module_sf_mynn
   REAL, PARAMETER :: xlvcp=xlv/cp, ep_3=1.-ep_2
  
   REAL, PARAMETER :: wmin=0.1    ! Minimum wind speed
-  REAL, PARAMETER :: zm2h=7.4    ! = z_0m/z_0h
-
-  REAL, PARAMETER :: charnock=0.016, bvisc=1.5e-5, z0hsea=5.e-5
-
   REAL, PARAMETER :: VCONVC=1.0
   REAL, PARAMETER :: SNOWZ0=0.012
-  
-  REAL, DIMENSION(0:1000 ),SAVE          :: PSIMTB,PSIHTB
 
+  REAL, DIMENSION(0:1000 ),SAVE          :: PSIMTB,PSIHTB
 
 CONTAINS
 
@@ -76,41 +72,40 @@ SUBROUTINE mynn_sf_init_driver(allowed_to_read)
 
   END SUBROUTINE mynn_sf_init_driver
 
-
 !-------------------------------------------------------------------
    SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
-                     CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM,      &
+                     CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM,    &
                      ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, &
                      XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, &
-                     U10,V10,TH2,T2,Q2,                            &
+                     U10,V10,TH2,T2,Q2,SNOWH,                      &
                      GZ1OZ0,WSPD,BR,ISFFLX,DX,                     &
                      SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
-                     KARMAN,EOMEG,STBOLT,                          &
-                     itimestep,ch,th3d,pi3d,qc3d,                  &
-                     tsq,qsq,cov,qcg,                              &
+                     KARMAN,itimestep,ch,th3d,pi3d,qc3d,rho3d,     &
+                     tsq,qsq,cov,sh3d,el_pbl,qcg,                  &
 !JOE-add output
 !                     z0zt_ratio,BulkRi,wstar,qstar,resist,logres,  &
-!                     Rreynolds,niters,psixrat,psitrat,             &
 !JOE-end 
                      ids,ide, jds,jde, kds,kde,                    &
                      ims,ime, jms,jme, kms,kme,                    &
                      its,ite, jts,jte, kts,kte,                    &
-                     ustm,ck,cka,cd,cda,isftcflx,iz0tlnd           )
+                     ustm,ck,cka,cd,cda,isftcflx,iz0tlnd,          &
+                     bl_mynn_cloudpdf)
 !-------------------------------------------------------------------
       IMPLICIT NONE
 !-------------------------------------------------------------------
 !-- U3D         3D u-velocity interpolated to theta points (m/s)
 !-- V3D         3D v-velocity interpolated to theta points (m/s)
-!-- T3D         temperature (K)
+!-- T3D         3D temperature (K)
 !-- QV3D        3D water vapor mixing ratio (Kg/Kg)
 !-- P3D         3D pressure (Pa)
-!-- dz8w        dz between full levels (m)
+!-- RHO3D       3D density (kg/m3) 
+!-- dz8w        3D dz between full levels (m)
 !-- CP          heat capacity at constant pressure for dry air (J/kg/K)
 !-- G           acceleration due to gravity (m/s^2)
 !-- ROVCP       R/CP
 !-- R           gas constant for dry air (J/kg/K)
 !-- XLV         latent heat of vaporization for water (J/kg)
-!-- PSFC        surface pressure (Pa)
+!-- PSFCPA      surface pressure (Pa)
 !-- ZNT         roughness length (m)
 !-- UST         u* in similarity theory (m/s)
 !-- USTM        u* in similarity theory (m/s) w* added to WSPD. This is                                                                         
@@ -120,6 +115,7 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
 !-- MAVAIL      surface moisture availability (between 0 and 1)
 !-- ZOL         z/L height over Monin-Obukhov length
 !-- MOL         T* (similarity theory) (K)
+!-- RMOL        Reciprocal of M-O length (/m)
 !-- REGIME      flag indicating PBL regime (stable, unstable, etc.)
 !-- PSIM        similarity stability function for momentum
 !-- PSIH        similarity stability function for heat
@@ -132,12 +128,15 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
 !-- FLQC        exchange coefficient for moisture (kg/m^2/s)
 !-- CHS         heat/moisture exchange coefficient for LSM (m/s)
 !-- QGH         lowest-level saturated mixing ratio
+!-- QSFC        qv (specific humidity) at the surface
+!-- QSFCMR      qv (mixing ratio) at the surface
 !-- U10         diagnostic 10m u wind
 !-- V10         diagnostic 10m v wind
 !-- TH2         diagnostic 2m theta (K)
 !-- T2          diagnostic 2m temperature (K)
 !-- Q2          diagnostic 2m mixing ratio (kg/kg)
-!-- GZ1OZ0      log(z/z0) where z0 is roughness length
+!-- SNOWH       Snow height (m)
+!-- GZ1OZ0      log((z1+ZNT)/ZNT) where ZNT is roughness length 
 !-- WSPD        wind speed at lowest model level (m/s)
 !-- BR          bulk Richardson number in surface layer
 !-- ISFFLX      isfflx=1 for surface heat and moisture fluxes
@@ -150,8 +149,6 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
 !-- EP2         constant for spec. hum. calc (Rd/Rv = 0.622) (dimensionless)
 !-- EP3         constant for spec. hum. calc (1 - Rd/Rv = 0.378 ) (dimensionless)
 !-- KARMAN      Von Karman constant
-!-- EOMEG       angular velocity of earth's rotation (rad/s)
-!-- STBOLT      Stefan-Boltzmann constant (W/m^2/K^4)
 !-- ck          enthalpy exchange coeff at 10 meters                                                                                           
 !-- cd          momentum exchange coeff at 10 meters                                                                                           
 !-- cka         enthalpy exchange coeff at the lowest model level                                                                              
@@ -161,10 +158,19 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
 !    only)      =2: z0 from Davis et al (2008), zt & zq from Garratt (1992)
 !               =3: z0 from Taylor and Yelland (2004), zt and zq from COARE3.0                                                                 
 !               =4: z0 from Zilitinkevich (2001), zt & zq from COARE3.0
-!-- iz0tlnd     =0: Zilitinkevich (1995) with Czil=0.1, 
+!-- iz0tlnd     =0: Zilitinkevich (1995) with Czil=0.14, 
 !   (land       =1: Czil_new (modified according to Chen & Zhang 2008)
 !    only)      =2: Modified Yang et al (2002, 2008) - generalized for all landuse
 !               =3: constant zt = z0/7.4 (Garratt 1992)
+!               =4: Pan et al (1994) for zq; ZIlitintevich for zt
+!-- bl_mynn_cloudpdf =0: Mellor & Yamada
+!                    =1: Kuwano et al.
+!-- el_pbl      = mixing length from PBL scheme (meters)
+!-- Sh3d        = Stability finction for heat (unitless)
+!-- cov         = T'q' from PBL scheme
+!-- tsq         = T'T' from PBL scheme
+!-- qsq         = q'q' from PBL scheme
+!
 !-- ids         start index for i in domain
 !-- ide         end index for i in domain
 !-- jds         start index for j in domain
@@ -183,125 +189,106 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
 !-- jte         end index for j in tile
 !-- kts         start index for k in tile
 !-- kte         end index for k in tile
-!-------------------------------------------------------------------
-      INTEGER,  INTENT(IN )   ::        ids,ide, jds,jde, kds,kde, &
-                                        ims,ime, jms,jme, kms,kme, &
-                                        its,ite, jts,jte, kts,kte
-!                                                               
-      INTEGER,  INTENT(IN )   ::        ISFFLX
-      REAL,     INTENT(IN )   ::        SVP1,SVP2,SVP3,SVPT0
-      REAL,     INTENT(IN )   ::        EP1,EP2,KARMAN,EOMEG,STBOLT
-!
+!=================================================================
+! SCALARS
+!===================================
+      INTEGER,  INTENT(IN)   ::        ids,ide, jds,jde, kds,kde, &
+                                       ims,ime, jms,jme, kms,kme, &
+                                       its,ite, jts,jte, kts,kte
+      INTEGER,  INTENT(IN)   ::        itimestep
+      REAL,     INTENT(IN)   ::        SVP1,SVP2,SVP3,SVPT0
+      REAL,     INTENT(IN)   ::        EP1,EP2,KARMAN
+      REAL,     INTENT(IN)   ::        CP,G,ROVCP,R,XLV,DX
+!NAMELIST OPTIONS:
+      INTEGER,  INTENT(IN)   ::        ISFFLX
+      INTEGER,  OPTIONAL,  INTENT(IN)   ::     ISFTCFLX, IZ0TLND,&
+                                                bl_mynn_cloudpdf
+!===================================
+! 3D VARIABLES
+!===================================
       REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
-                INTENT(IN   )   ::                           dz8w
-                                        
-      REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
-                INTENT(IN   )   ::                           QV3D, &
+                INTENT(IN   )   ::                           dz8w, &
+                                                             QV3D, &
                                                               P3D, &
                                                               T3D, &
-                                                             QC3D,&
-                                            th3d,pi3d,tsq,qsq,cov
-
-      INTEGER, INTENT(in) :: itimestep
-
-      REAL,     DIMENSION( ims:ime, jms:jme ), INTENT(IN) ::&
-           &    qcg
-      
-      REAL,     DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) ::&
-           & ch
-
+                                                             QC3D, &
+                                                          U3D,V3D, &
+                             RHO3D,th3d,pi3d,tsq,qsq,cov,sh3d,el_pbl
+!===================================
+! 2D VARIABLES
+!===================================
       REAL,     DIMENSION( ims:ime, jms:jme )                    , &
                 INTENT(IN   )               ::             MAVAIL, &
                                                              PBLH, &
                                                             XLAND, &
-                                                              TSK
+                                                              TSK, &
+                                                              QCG, &
+                                                           PSFCPA , &
+                                                            SNOWH
+
       REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-                INTENT(OUT  )               ::                U10, &
-                                                              V10, &
-                                                              TH2, &
-                                                               T2, &
-!JOE-use value from LSM                                        Q2, &
-                                                               Q2
-!JOE-moved down below                                          QSFC
+                INTENT(OUT  )               ::            U10,V10, &
+                                                        TH2,T2,Q2
 
+      REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme )              , &
+                INTENT(OUT)     ::              ck,cka,cd,cda,ustm
 !
       REAL,     DIMENSION( ims:ime, jms:jme )                    , &
                 INTENT(INOUT)               ::             REGIME, &
                                                               HFX, &
                                                               QFX, &
                                                                LH, &
-                                                    MOL,RMOL,QSFC
-!m the following 5 are change to memory size
-!
-      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-                INTENT(INOUT)   ::                 GZ1OZ0,WSPD,BR, &
-                                                        PSIM,PSIH
-
-      REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
-                INTENT(IN   )   ::                            U3D, &
-                                                              V3D
-                                        
-      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-                INTENT(IN   )               ::               PSFC
-
-      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-                INTENT(INOUT)   ::                            ZNT, &
+                                                         MOL,RMOL, &
+                                                        QSFC, QGH, &
+                                                              ZNT, &
                                                               ZOL, &
                                                               UST, &
                                                               CPM, &
                                                              CHS2, &
                                                              CQS2, &
-                                                              CHS
-
-      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-                INTENT(INOUT)   ::                      FLHC,FLQC
-
-      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-                INTENT(INOUT)   ::                            QGH
+                                                              CHS, &
+                                                               CH, &
+                                                        FLHC,FLQC, &
+                                                   GZ1OZ0,WSPD,BR, &
+                                                        PSIM,PSIH
 
+!ADDITIONAL OUTPUT
 !JOE-begin
-!      REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-!                INTENT(OUT)               ::           z0zt_ratio, &
-!                                 BulkRi,wstar,qstar,resist,logres, &
-!                                 Rreynolds,niters,psixrat,psitrat
+      REAL,     DIMENSION( ims:ime, jms:jme )    ::    z0zt_ratio, &
+                                 BulkRi,wstar,qstar,resist,logres
 !JOE-end 
-                                    
-      REAL,     INTENT(IN   )               ::   CP,G,ROVCP,R,XLV,DX
-
-      REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme )              , &
-                INTENT(OUT)     ::              ck,cka,cd,cda,ustm
-
-      INTEGER,  OPTIONAL,  INTENT(IN )   ::     ISFTCFLX, IZ0TLND
-
-!----------- LOCAL VARS -----------------------------------
-
+!===================================
+! 1D LOCAL ARRAYS
+!===================================
       REAL,     DIMENSION( its:ite ) ::                       U1D, &
                                                               V1D, &
                                                              QV1D, &
                                                               P1D, &
-                                                         T1D,qc1d
-
-      REAL,     DIMENSION( its:ite ) ::                    dz8w1d
+                                                         T1D,QC1D, &
+                                                            RHO1D, &
+                                                           dz8w1d
 
       REAL,     DIMENSION( its:ite ) ::  vt1,vq1
       REAL,     DIMENSION(kts:kts+1) ::  thl, qw, vt, vq
       REAL                           ::  ql
 
-      INTEGER ::  I,J,K
+      INTEGER ::  I,J,K,itf,jtf,ktf
 !-----------------------------------------------------------
 
+      itf=MIN0(ite,ide-1)
+      jtf=MIN0(jte,jde-1)
+      ktf=MIN0(kte,kde-1)
+
       DO J=jts,jte
         DO i=its,ite
-          dz8w1d(I) = dz8w(i,kts,j)
-        ENDDO
-   
-        DO i=its,ite
+           dz8w1d(I) = dz8w(i,kts,j)
            U1D(i) =U3D(i,kts,j)
            V1D(i) =V3D(i,kts,j)
            QV1D(i)=QV3D(i,kts,j)
            QC1D(i)=QC3D(i,kts,j)
            P1D(i) =P3D(i,kts,j)
            T1D(i) =T3D(i,kts,j)
+           RHO1D(i)=RHO3D(i,kts,j)
         ENDDO
 
         IF (itimestep==1) THEN
@@ -310,7 +297,8 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
               vq1(i)=0.
               UST(i,j)=MAX(0.025*SQRT(U1D(i)*U1D(i) + V1D(i)*V1D(i)),0.001)
               MOL(i,j)=0.     ! Tstar
-              !qstar(i,j)=0.0  
+              QSFC(i,j)=QV3D(i,kts,j)/(1.+QV3D(i,kts,j))
+              qstar(i,j)=0.0
            ENDDO
         ELSE
            DO i=its,ite
@@ -320,39 +308,39 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
                 thl(k) = th3d(i,k,j)-xlvcp*ql/pi3d(i,k,j)
               end do
 
-! NOTE: The last grid number is kts+1 instead of kte.
+              ! NOTE: The last grid number is kts+1 instead of kte.
               CALL mym_condensation (kts,kts+1, &
                    &            dz8w(i,kts:kts+1,j), &
                    &            thl(kts:kts+1), qw(kts:kts+1), &
-                   &            p3d(i,kts:kts+1,j),&
-                   &            pi3d(i,kts:kts+1,j), &
-                   &            tsq(i,kts:kts+1,j), &
-                   &            qsq(i,kts:kts+1,j), &
-                   &            cov(i,kts:kts+1,j), &
+                   &            p3d(i,kts:kts+1,j),     &
+                   &            pi3d(i,kts:kts+1,j),    &
+                   &            tsq(i,kts:kts+1,j),     &
+                   &            qsq(i,kts:kts+1,j),     &
+                   &            cov(i,kts:kts+1,j),     &
+                   &            Sh3d(i,kts:kts+1,j),    & !JOE - cloud PDF testing
+                   &            el_pbl(i,kts:kts+1,j),  & !JOE - cloud PDF testing
+                   &            bl_mynn_cloudpdf,       & !JOE - cloud PDF testing
                    &            vt(kts:kts+1), vq(kts:kts+1))
-
               vt1(i) = vt(kts)
               vq1(i) = vq(kts)
            ENDDO
         ENDIF
 
-        CALL SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,          &
-                CP,G,ROVCP,R,XLV,PSFC(ims,j),CHS(ims,j),CHS2(ims,j),&
+        CALL SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,    &
+                CP,G,ROVCP,R,XLV,PSFCPA(ims,j),CHS(ims,j),CHS2(ims,j),&
                 CQS2(ims,j),CPM(ims,j),PBLH(ims,j), RMOL(ims,j),   &
                 ZNT(ims,j),UST(ims,j),MAVAIL(ims,j),ZOL(ims,j),    &
                 MOL(ims,j),REGIME(ims,j),PSIM(ims,j),PSIH(ims,j),  &
                 XLAND(ims,j),HFX(ims,j),QFX(ims,j),TSK(ims,j),     &
                 U10(ims,j),V10(ims,j),TH2(ims,j),T2(ims,j),        &
-                Q2(ims,j),FLHC(ims,j),FLQC(ims,j),QGH(ims,j),      &
-                QSFC(ims,j),LH(ims,j),                             &
+                Q2(ims,j),FLHC(ims,j),FLQC(ims,j),SNOWH(ims,j),    &
+                QGH(ims,j),QSFC(ims,j),LH(ims,j),                  &
                 GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX,     &
-                SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT,  &
-                ch(ims,j),vt1,vq1,qc1d,qcg(ims,j),&
-                itimestep,&
-!JOE-begin 
-!                z0zt_ratio(ims,j),BulkRi(ims,j),wstar(ims,j),qstar(ims,j),  &
-!                resist(ims,j),logres(ims,j),Rreynolds(ims,j),niters(ims,j), &
-!                psixrat(ims,j),psitrat(ims,j),                     &
+                SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,               &
+                ch(ims,j),vt1,vq1,qc1d,qcg(ims,j),itimestep,       &
+!JOE-begin additional output
+                z0zt_ratio(ims,j),BulkRi(ims,j),wstar(ims,j),      &
+                qstar(ims,j),resist(ims,j),logres(ims,j),          &
 !JOE-end
                 ids,ide, jds,jde, kds,kde,                         &
                 ims,ime, jms,jme, kms,kme,                         &
@@ -364,280 +352,235 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
 
       ENDDO
 
-
     END SUBROUTINE SFCLAY_MYNN
 
 !-------------------------------------------------------------------
-   SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
-                     CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM,PBLH,RMOL, &
-                     ZNT,UST,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH,      &
-                     XLAND,HFX,QFX,TSK,                            &
-                     U10,V10,TH2,T2,Q2,FLHC,FLQC,QGH,              &
+   SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
+                     CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM,    &
+                     PBLH,RMOL,ZNT,UST,MAVAIL,ZOL,MOL,REGIME,      &
+                     PSIM,PSIH,XLAND,HFX,QFX,TSK,                  &
+                     U10,V10,TH2,T2,Q2,FLHC,FLQC,SNOWH,QGH,        &
                      QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX,             &
                      SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
-                     KARMAN,EOMEG,STBOLT,                          &
-                     ch,vt1,vq1,qc1d,qcg,                          &
-                     itimestep,                                    &
-!JOE-add
-!                     zratio,BRi,wstar,qstar,resist,logres,         &
-!                     Rreynolds,niters,psixrat,psitrat,             &
+                     KARMAN,ch,vt1,vq1,qc1d,qcg,itimestep,         &
+!JOE-additional output
+                     zratio,BRi,wstar,qstar,resist,logres,         &
 !JOE-end
                      ids,ide, jds,jde, kds,kde,                    &
                      ims,ime, jms,jme, kms,kme,                    &
-                     its,ite, jts,jte, kts,kte,                    &
-                     isftcflx, iz0tlnd,                            &
-                     ustm,ck,cka,cd,cda                            )
+                     its,ite, jts,jte, kts,kte                     &
+                     ,isftcflx, iz0tlnd,                           &
+                     ustm,ck,cka,cd,cda                            &
+                     )
 
 !-------------------------------------------------------------------
       IMPLICIT NONE
 !-------------------------------------------------------------------
+! SCALARS
+!-----------------------------
+      INTEGER,  INTENT(IN) ::        ids,ide, jds,jde, kds,kde, &
+                                     ims,ime, jms,jme, kms,kme, &
+                                     its,ite, jts,jte, kts,kte, &
+                                     J, itimestep
+
       REAL,     PARAMETER  :: XKA=2.4E-5   !molecular diffusivity
       REAL,     PARAMETER  :: PRT=1.       !prandlt number
+      REAL,     INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0,EP1,EP2
+      REAL,     INTENT(IN) :: KARMAN,CP,G,ROVCP,R,XLV,DX
 
-      INTEGER,  INTENT(IN )   ::        ids,ide, jds,jde, kds,kde, &
-                                        ims,ime, jms,jme, kms,kme, &
-                                        its,ite, jts,jte, kts,kte, &
-                                        J
-!                                                               
-      INTEGER,  INTENT(in)    :: itimestep
-      INTEGER,  INTENT(IN )   ::        ISFFLX
-      REAL,     INTENT(IN )   ::        SVP1,SVP2,SVP3,SVPT0
-      REAL,     INTENT(IN )   ::        EP1,EP2,KARMAN,EOMEG,STBOLT
+!-----------------------------
+! NAMELIST OPTIONS
+!-----------------------------
+      INTEGER,  INTENT(IN) :: ISFFLX
+      INTEGER,  OPTIONAL,  INTENT(IN )   ::     ISFTCFLX, IZ0TLND
 
-!
-      REAL,     DIMENSION( ims:ime )                             , &
-                INTENT(IN   )               ::             MAVAIL, &
+!-----------------------------
+! 1D ARRAYS
+!-----------------------------
+      REAL,     DIMENSION( ims:ime ), INTENT(IN)    ::     MAVAIL, &
                                                              PBLH, &
                                                             XLAND, &
-                                                              TSK
-!
-      REAL,     DIMENSION( ims:ime )                             , &
-                INTENT(IN   )               ::             PSFCPA
-
-      REAL,     DIMENSION( ims:ime )                             , &
-                INTENT(INOUT)               ::             REGIME, &
-                                                              HFX, &
-                                                              QFX, &
-                                                         MOL,RMOL
-!m the following 5 are changed to memory size---
-!
-      REAL,     DIMENSION( ims:ime )                             , &
-                INTENT(INOUT)   ::                 GZ1OZ0,WSPD,BR, &
-                                                        PSIM,PSIH
-
-      REAL,     DIMENSION( ims:ime )                             , &
-                INTENT(INOUT)   ::                            ZNT, &
+                                                              TSK, &
+                                                           PSFCPA, &
+                                                              QCG, &
+                                                            SNOWH
+
+      REAL,     DIMENSION( its:ite ), INTENT(IN)   ::     U1D,V1D, &
+                                                         QV1D,P1D, &
+                                                         T1D,QC1d, &
+                                                           dz8w1d, &
+                                                            RHO1D, &
+                                                          vt1,vq1
+
+      REAL,     DIMENSION( ims:ime ), INTENT(INOUT) ::     REGIME, &
+                                                       HFX,QFX,LH, &
+                                                         MOL,RMOL, &
+                                                         QGH,QSFC, &
+                                                              ZNT, &
                                                               ZOL, &
                                                               UST, &
                                                               CPM, &
-                                                             CHS2, &
-                                                             CQS2, &
-                                                              CHS
-!JOE-add
-      REAL,     DIMENSION( its:ite )     :: zratio,BRi,wstar,qstar,&
-                                          resist,logres,Rreynolds, &
-                                         niters,psixrat,psitrat
-!      REAL,     DIMENSION( ims:ime )                             , &
-!                INTENT(OUT)     ::         zratio,BRi,wstar,qstar, &
-!                                          resist,logres,Rreynolds, &
-!                                         niters,psixrat,psitrat 
-!JOE-end
-
-      REAL,     DIMENSION( ims:ime )                             , &
-                INTENT(INOUT)   ::                      FLHC,FLQC
-
-      REAL,     DIMENSION( ims:ime )                             , &
-                INTENT(INOUT)   ::                       QGH,QSFC
-
-      REAL,     DIMENSION( ims:ime )                             , &
-                INTENT(OUT)     ::                        U10,V10, &
-!JOE-make qsfc inout (moved up)                   TH2,T2,Q2,QSFC,LH
-                                                TH2,T2,Q2,LH
-                                    
-      REAL,     INTENT(IN)               ::   CP,G,ROVCP,R,XLV,DX
-
-! MODULE-LOCAL VARIABLES, DEFINED IN SUBROUTINE SFCLAY
-      REAL,     DIMENSION( its:ite ),  INTENT(IN   )   ::  dz8w1d
-
-      REAL,     DIMENSION( its:ite ),  INTENT(IN   )   ::      UX, &
-                                                               VX, &
-                                                             QV1D, &
-                                                              P1D, &
-                                                         T1D,qc1d
- 
-      REAL,     DIMENSION( ims:ime ), INTENT(IN)    :: qcg
-      REAL,     DIMENSION( ims:ime ), INTENT(INOUT) :: ch
+                                                        CHS2,CQS2, &
+                                                           CHS,CH, &
+                                                        FLHC,FLQC, &
+                                                           GZ1OZ0, &
+                                                             WSPD, &
+                                                               BR, &
+                                                        PSIM,PSIH
 
-      REAL,     DIMENSION( its:ite ), INTENT(IN)    :: vt1,vq1
+      ! DIAGNOSTIC OUTPUT
+      REAL,     DIMENSION( ims:ime ), INTENT(OUT)   ::    U10,V10, &
+                                                        TH2,T2,Q2
 
       REAL, OPTIONAL, DIMENSION( ims:ime )                       , &
                 INTENT(OUT)     ::              ck,cka,cd,cda,ustm
-
-      INTEGER,  OPTIONAL,  INTENT(IN )   ::     ISFTCFLX, IZ0TLND
-
-
+!--------------------------------------------
+!JOE-additinal output
+      REAL,     DIMENSION( ims:ime ) ::    zratio,BRi,wstar,qstar, &
+                                                    resist,logres
+!JOE-end
+!----------------------------------------------------------------
 ! LOCAL VARS
-
-      REAL,     DIMENSION( its:ite ) :: z_t,z_q
-
+!----------------------------------------------------------------
       REAL :: thl1,sqv1,sqc1,exner1,sqvg,sqcg,vv,ww
 
-      REAL,     DIMENSION( its:ite )        ::                 ZA, &
-                                                        THVX,ZQKL, &
-                                                           THX,QX, &
-                                                            PSIH2, &
-                                                            PSIM2, &
-                                                           PSIH10, &
-                                                           PSIM10, &
-                                                           GZ2OZ0, &
-                                                          GZ10OZ0, &
-                                                            WSPDI
-!
-      REAL,     DIMENSION( its:ite )        ::        RHOX,GOVRTH
-!
-      REAL,     DIMENSION( its:ite)         ::          SCR4
-      REAL,     DIMENSION( its:ite )        ::         THGB, PSFC, QSFCMR
-
-      REAL,     DIMENSION( its:ite )        :: GZ2OZt,GZ10OZt,GZ1OZt
-
-!
-      INTEGER ::  N,I,K,KK,L,NZOL,NK,NZOL2,NZOL10, ITER
+      REAL, DIMENSION(its:ite) :: &
+                 ZA, &    !Height of lowest 1/2 sigma level(m)
+              THV1D, &    !Theta-v at lowest 1/2 sigma (K)
+               TH1D, &    !Theta at lowest 1/2 sigma (K)
+               TC1D, &    !T at lowest 1/2 sigma (Celsius)
+               TV1D, &    !Tv at lowest 1/2 sigma (K)
+               QVSH, &    !qv at lowest 1/2 sigma (spec humidity)
+        PSIH2,PSIM2, &    !M-O stability functions at z=2 m
+      PSIH10,PSIM10, &    !M-O stability functions at z=10 m
+              WSPDI, & 
+            z_t,z_q, &    !thermal & moisture roughness lengths
+             GOVRTH, &    !g/theta
+               THGB, &    !theta at ground
+              THVGB, &    !theta-v at ground
+               PSFC, &    !press at surface (Pa/1000)
+             QSFCMR, &    !qv at surface (mixing ratio, kg/kg)
+             GZ2OZ0, &    !LOG((2.0+ZNT(I))/ZNT(I))
+            GZ10OZ0, &    !LOG((10.+ZNT(I))/ZNT(I))
+             GZ2OZt, &    !LOG((2.0+z_t(i))/z_t(i))
+            GZ10OZt, &    !LOG((10.+z_t(i))/z_t(i))
+             GZ1OZt       !LOG((ZA(I)+z_t(i))/z_t(i))
+
+      INTEGER ::  N,I,K,L,NZOL,NK,NZOL2,NZOL10, ITER
       INTEGER, PARAMETER :: ITMAX=5
 
       REAL    ::  PL,THCON,TVCON,E1
-      REAL    ::  ZL,TSKV,DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10
+      REAL    ::  DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10
       REAL    ::  DTG,PSIX,DTTHX,DTHDZ,PSIX10,PSIT,PSIT2,PSIT10, &
                   PSIQ,PSIQ2,PSIQ10
       REAL    ::  FLUXC,VSGD
-      real    ::  restar,VISC,psilim,DQG,OLDUST,OLDTST
+      REAL    ::  restar,VISC,DQG,OLDUST,OLDTST
+      REAL, PARAMETER :: psilim = -10.  ! ONLY AFFECTS z/L > 2.0
 !-------------------------------------------------------------------
 
-!----CONVERT GROUND TEMPERATURE TO POTENTIAL TEMPERATURE:  
       DO I=its,ite
-         ! PSFC cmb (or kPa)
+         ! CONVERT GROUND & LOWEST LAYER TEMPERATURE TO POTENTIAL TEMPERATURE:
+         ! PSFC cmb
          PSFC(I)=PSFCPA(I)/1000.
-         THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP                
-      ENDDO                                              
-!                                                                                   
-!     SCR4(I,K) STORES EITHER TEMPERATURE OR VIRTUAL TEMPERATURE,
-!     DEPENDING ON IFDRY (CURRENTLY NOT USED, SO SCR4 == TVX).                                       
-                                                                                 
-      DO 30 I=its,ite
+         THGB(I)=TSK(I)*(100./PSFC(I))**ROVCP   !(K)              
          ! PL cmb
          PL=P1D(I)/1000.                                                   
          THCON=(100./PL)**ROVCP                                                 
-         THX(I)=T1D(I)*THCON                                               
-         SCR4(I)=T1D(I)                                                    
-         THVX(I)=THX(I)                                                     
-         QX(I)=0.                                                             
-   30 CONTINUE                                                                 
-
-      ! INITIALIZE SOME VARIABLES HERE:
-      DO I=its,ite
-         niters(I)=0.                                                                
-         QGH(I)=0.                                                                
-         CPM(I)=CP                                                             
-         IF (itimestep .LE. 1) THEN
-           qstar(I)=0.0 
-         ENDIF 
+         TH1D(I)=T1D(I)*THCON                   !(Theta, K)
+         TC1D(I)=T1D(I)-273.15                  !(T, Celsius)    
+
+         ! CONVERT TO VIRTUAL TEMPERATURE
+         QVSH(I)=QV1D(I)/(1.+QV1D(I))        !CONVERT TO SPEC HUM (kg/kg)
+         TVCON=(1.+EP1*QVSH(I))
+         THV1D(I)=TH1D(I)*TVCON                 !(K)
+         TV1D(I)=T1D(I)*TVCON                   !(K)
+
+         !RHO1D(I)=PSFCPA(I)/(R*TV1D(I)) !now using value calculated in sfc driver
+         ZA(I)=0.5*dz8w1d(I)             !height of first half-sigma level 
+         GOVRTH(I)=G/TH1D(I)
       ENDDO
-                                                                                
-!     IF(IDRY.EQ.1)GOTO 80                                                   
-      DO 50 I=its,ite
-         QX(I)=QV1D(I)/(1.+QV1D(I))        !CONVERT TO SPEC HUM
-         TVCON=(1.+EP1*QX(I))                                      
-         THVX(I)=THX(I)*TVCON                                               
-         SCR4(I)=T1D(I)*TVCON                                              
-   50 CONTINUE                                                                 
-!                                                                                
-      DO 60 I=its,ite
-        IF (TSK(I) .LT. 273.15) THEN
-           !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb)
-           E1=SVP1*EXP(4648*(1./273.15 - 1./TSK(I)) - &
-                  11.64*LOG(273.15/TSK(I)) + 0.02265*(273.15 - TSK(I)))
-        ELSE
-           !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980)
-           E1=SVP1*EXP(SVP2*(TSK(I)-SVPT0)/(TSK(I)-SVP3))
-        ENDIF
-        QSFC(I)=EP2*E1/(PSFC(I)-ep_3*E1)   !specific humidity
-        QSFCMR(I)=EP2*E1/(PSFC(I)-E1)      !mixing ratio                                           
-        !FOR LAND POINTS, QSFC can come from previous time step (in LSM)
-        !if(xland(i).gt.1.5 .or. QSFC(i).le.0.0) QSFC(I)=EP2*E1/(PSFC(I)-ep_3*E1)     
-  
-        ! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE
-        ! Q2SAT = QGH IN LSM
-        IF (TSK(I) .LT. 273.15) THEN
-           !SATURATION VAPOR PRESSURE WRT ICE
-           E1=SVP1*EXP(4648*(1./273.15 - 1./T1D(I)) - &
-                  11.64*LOG(273.15/T1D(I)) + 0.02265*(273.15 - T1D(I)))
-        ELSE
-           !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980)
-           E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3))
-        ENDIF
-        PL=P1D(I)/1000.
-        QGH(I)=EP2*E1/(PL-ep_3*E1)    !specific humidity
-        !QGH(I)=EP2*E1/(PL-E1)        !mixing ratio
-        CPM(I)=CP*(1.+0.84*QX(I)/(1.-qx(i)))
-
-   60 CONTINUE                                                                   
-   80 CONTINUE
-                                                                                 
-!-----COMPUTE THE HEIGHT OF FULL- AND HALF-SIGMA LEVELS ABOVE GROUND             
-!     LEVEL, AND THE LAYER THICKNESSES.                                          
-                                                                                 
+
       DO I=its,ite
-         RHOX(I)=PSFC(I)*1000./(R*SCR4(I))                                       
-         ZQKL(I)=dz8w1d(I)            !first full-sigma level
-         ZA(I)=0.5*ZQKL(I)            !first half-sigma level                            
-         GOVRTH(I)=G/THX(I)                                                    
+         IF (TSK(I) .LT. 273.15) THEN
+            !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb)
+            E1=SVP1*EXP(4648*(1./273.15 - 1./TSK(I)) - &
+            & 11.64*LOG(273.15/TSK(I)) + 0.02265*(273.15 - TSK(I)))
+         ELSE
+            !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980)
+            E1=SVP1*EXP(SVP2*(TSK(I)-SVPT0)/(TSK(I)-SVP3))
+         ENDIF
+         !FOR LAND POINTS, QSFC can come from LSM, ONLY RECOMPUTE OVER WATER
+         IF (xland(i).gt.1.5 .or. QSFC(i).le.0.0) THEN   !WATER
+            QSFC(I)=EP2*E1/(PSFC(I)-ep_3*E1)             !specific humidity    
+            QSFCMR(I)=EP2*E1/(PSFC(I)-E1)                !mixing ratio 
+         ELSE                                            !LAND 
+            QSFCMR(I)=QSFC(I)/(1.-QSFC(I))
+         ENDIF
+
+         ! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE
+         ! Q2SAT = QGH IN LSM
+         IF (TSK(I) .LT. 273.15) THEN
+            !SATURATION VAPOR PRESSURE WRT ICE
+            E1=SVP1*EXP(4648*(1./273.15 - 1./T1D(I)) - &
+            &  11.64*LOG(273.15/T1D(I)) + 0.02265*(273.15 - T1D(I)))
+         ELSE
+            !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980)
+            E1=SVP1*EXP(SVP2*(T1D(I)-SVPT0)/(T1D(I)-SVP3))
+         ENDIF
+         PL=P1D(I)/1000.
+         !QGH(I)=EP2*E1/(PL-ep_3*E1)    !specific humidity
+         QGH(I)=EP2*E1/(PL-E1)          !mixing ratio
+         CPM(I)=CP*(1.+0.84*QV1D(I))
       ENDDO
-                                                                                 
+
       DO I=its,ite
-         WSPD(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I))                        
+         WSPD(I)=SQRT(U1D(I)*U1D(I)+V1D(I)*V1D(I))     
 
          !account for partial condensation
-         exner1=(p1d(i)/p1000mb)**ROVCP
-         sqc1=qc1d(i)/(1.+qc1d(i))         !convert to spec hum.
-         sqv1=qx(i)
-         thl1=THX(I)-xlvcp/exner1*sqc1
-         sqvg=qsfc(i)
-         sqcg=qcg(i)/(1.+qcg(i))           !convert to spec hum.
+         exner1=(p1d(I)/p1000mb)**ROVCP
+         sqc1=qc1d(I)/(1.+qc1d(I))         !lowest mod level cloud water spec hum
+         sqv1=QVSH(I)                      !lowest mod level water vapor spec hum
+         thl1=TH1D(I)-xlvcp/exner1*sqc1
+         sqvg=qsfc(I)                      !sfc water vapor spec hum
+         sqcg=qcg(I)/(1.+qcg(I))           !sfc cloud water spec hum
 
          vv = thl1-THGB(I)
-         ww = mavail(i)*(sqv1-sqvg) + (sqc1-sqcg)
+         !TGS:ww = mavail(I)*(sqv1-sqvg) + (sqc1-sqcg)
+         ww = (sqv1-sqvg) + (sqc1-sqcg)
 
-         TSKV=THGB(I)*(1.+EP1*QSFC(I)*MAVAIL(I)) 
+         !TGS:THVGB(I)=THGB(I)*(1.+EP1*QSFC(I)*MAVAIL(I)) 
+         THVGB(I)=THGB(I)*(1.+EP1*QSFC(I))
 
-         DTHDZ=(THX(I)-THGB(I))
-         !DTHVDZ=(THVX(I)-TSKV)
-         DTHVDZ= (vt1(i) + 1.0)*vv + (vq1(i) + tv0)*ww
+         DTHDZ=(TH1D(I)-THGB(I))
+         DTHVDZ=(THV1D(I)-THVGB(I))
+         !DTHVDZ= (vt1(i) + 1.0)*vv + (vq1(i) + tv0)*ww
 
          !--------------------------------------------------------
          !  Calculate the convective velocity scale (WSTAR) and 
          !  subgrid-scale velocity (VSGD) following Beljaars (1995, QJRMS) 
          !  and Mahrt and Sun (1995, MWR), respectively
          !-------------------------------------------------------
-         !       VCONV = 0.25*sqrt(g/tskv*pblh(i)*dthvm)
+         !       VCONV = 0.25*sqrt(g/THVGB(I)*pblh(i)*dthvm)
          !  Use Beljaars over land, old MM5 (Wyngaard) formula over water
          IF (xland(i).lt.1.5) then     !LAND (xland == 1)
 
-            fluxc = max(hfx(i)/rhox(i)/cp                    &
-                + ep1*tskv*qfx(i)/rhox(i),0.)
+            fluxc = max(hfx(i)/RHO1D(i)/cp                    &
+            &    + ep1*THVGB(I)*qfx(i)/RHO1D(i),0.)
             WSTAR(I) = vconvc*(g/TSK(i)*pblh(i)*fluxc)**.33
 
          ELSE                          !WATER (xland == 2)
 
-            IF(-DTHVDZ.GE.0)THEN
-               DTHVM=-DTHVDZ
-            ELSE
-               DTHVM=0.
-            ENDIF
             !JOE-the Wyngaard formula is ~3 times larger than the Beljaars 
             !formula, so switch to Beljaars for water, but use VCONVC = 1.25,
             !as in the COARE3.0 bulk parameterizations.
+            !IF(-DTHVDZ.GE.0)THEN
+            !   DTHVM=-DTHVDZ
+            !ELSE
+            !   DTHVM=0.
+            !ENDIF
             !WSTAR(I) = 2.*SQRT(DTHVM)
-            fluxc = max(hfx(i)/rhox(i)/cp                    &
-                 + ep1*tskv*qfx(i)/rhox(i),0.)
+            fluxc = max(hfx(i)/RHO1D(i)/cp                    &
+            &     + ep1*THVGB(I)*qfx(i)/RHO1D(i),0.)
             WSTAR(I) = 1.25*(g/TSK(i)*pblh(i)*fluxc)**.33
 
          ENDIF
@@ -656,8 +599,9 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
          !--------------------------------------------------------
          BR(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD(I)*WSPD(I))
          !SET LIMITS ACCORDING TO Li et al. (2010) Boundary-Layer Meteorol (p.158)
-         BR(I)=MAX(BR(I),-2.0)
-         BR(I)=MIN(BR(I),1.0)
+         !JOE: defying limits: BR(I)=MAX(BR(I),-2.0)
+         BR(I)=MAX(BR(I),-20.0)
+         BR(I)=MIN(BR(I),2.0)
          BRi(I)=BR(I)  !new variable for output - BR is not a "state" variable.
                
          ! IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 (STABLE)
@@ -681,24 +625,21 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
 !--------------------------------------------------------------------
 !--------------------------------------------------------------------
 
-DO I=its,ite
+ DO I=its,ite
 
    ITER = 1
    DO WHILE (ITER .LE. ITMAX)
-      niters(I)=ITER
 
-      !COMPUTE KINEMATIC VISCOSITY
-      VISC=(1.32+0.009*(T1D(I)-273.15))*1.E-5
+      !COMPUTE KINEMATIC VISCOSITY (m2/s) Andreas (1989) CRREL Rep. 89-11
+      !valid between -173 and 277 degrees C.
+      VISC=1.326e-5*(1. + 6.542e-3*TC1D(I) + 8.301e-6*TC1D(I)*TC1D(I) &
+                        - 4.84e-9*TC1D(I)*TC1D(I)*TC1D(I))
 
       IF((XLAND(I)-1.5).GE.0)THEN
           !--------------------------------------
           ! WATER
           !--------------------------------------
-
-          !COMPUTE KINEMATIC VISCOSITY
-          VISC=(1.32+0.009*(T1D(I)-273.15))*1.E-5
-          !--------------------------------------
-          !CALCULATE z0 (znt)
+          ! CALCULATE z0 (znt)
           !--------------------------------------
           IF ( PRESENT(ISFTCFLX) ) THEN
              IF ( ISFTCFLX .EQ. 0 ) THEN
@@ -750,18 +691,20 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
           ! LAND
           !--------------------------------------
           !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING DEFAULT ZNT
-          VISC=(1.32+0.009*(T1D(I)-273.15))*1.E-5
           restar=MAX(ust(i)*ZNT(i)/visc, 0.1)
 
           !--------------------------------------
           !GET z_t and z_q
           !--------------------------------------
           !CHECK FOR SNOW/ICE POINTS OVER LAND
-          IF ( ZNT(i) .LE. SNOWZ0  .AND.  TSK(I) .LE. 273.15 ) THEN
+          !IF ( ZNT(i) .LE. SNOWZ0  .AND.  TSK(I) .LE. 273.15 ) THEN
+          IF ( SNOWH(i) .GE. 0.1) THEN
              CALL Andreas_2002(ZNT(i),restar,z_t(i),z_q(i))
           ELSE
              IF ( PRESENT(IZ0TLND) ) THEN
-                IF ( IZ0TLND .LE. 1 ) THEN
+                IF ( IZ0TLND .LE. 1 .OR. IZ0TLND .EQ. 4) THEN
+                   !IF IZ0TLND==4, THEN PSIQ WILL BE RECALCULATED USING
+                   !PAN ET AL (1994), but PSIT FROM ZILI WILL BE USED.
                    CALL zilitinkevich_1995(ZNT(i),z_t(i),z_q(i),restar,&
                                   UST(I),KARMAN,XLAND(I),IZ0TLND)
                 ELSEIF ( IZ0TLND .EQ. 2 ) THEN
@@ -772,7 +715,7 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
                    CALL garratt_1992(z_t(i),z_q(i),ZNT(i),restar,XLAND(I))
                 ENDIF
              ELSE
-                !DEFAULT TO ZILITINKEVICH WITH CZIL = 0.1
+                !DEFAULT TO ZILITINKEVICH
                 CALL zilitinkevich_1995(ZNT(i),z_t(i),z_q(i),restar,&
                                         UST(I),KARMAN,XLAND(I),0)
              ENDIF
@@ -780,7 +723,6 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
 
        ENDIF
        zratio(i)=znt(i)/z_t(i)
-       Rreynolds(I)=restar
 
        !ADD RESISTANCE (SOMEWHAT FOLLOWING JIMENEZ ET AL. (2012)) TO PROTECT AGAINST
        !EXCESSIVE FLUXES WHEN USING A LOW FIRST MODEL LEVEL (ZA < 10 m).        
@@ -795,7 +737,7 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
      !--------------------------------------------------------------------      
      !--- DIAGNOSE BASIC PARAMETERS FOR THE APPROPRIATE STABILITY CLASS:
      !                                                                                
-     !    THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.).                              
+     !    THE STABILITY CLASSES ARE DETERMINED BY BR (BULK RICHARDSON NO.).
      !                                                                                
      !    CRITERIA FOR THE CLASSES ARE AS FOLLOWS:                                   
      !                                                                                
@@ -813,66 +755,23 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
      !               REPRESENTS FREE CONVECTION CONDITIONS (REGIME=4).                
      !                                                                                
      !--------------------------------------------------------------------
-     IF (BR(I) .GT. 0.2) THEN                                           
-        !===================================================
-        !---CLASS 1; STABLE (NIGHTTIME) CONDITIONS:                                    
-        !===================================================
-        REGIME(I)=1.
-
-        !COMPUTE z/L
-        !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I))
-        IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN
-           CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I))
+     IF (BR(I) .GT. 0.0) THEN
+        IF (BR(I) .GT. 0.2) THEN        
+            !---CLASS 1; STABLE (NIGHTTIME) CONDITIONS:                                    
+            REGIME(I)=1.
         ELSE
-           ZOL(I)=ZA(I)*KARMAN*9.81*MOL(I)/(THX(I)*MAX(UST(I),0.001)**2)
-           ZOL(I)=MAX(ZOL(I),0.0)
-           ZOL(I)=MIN(ZOL(I),20.0)
+            !---CLASS 2; DAMPED MECHANICAL TURBULENCE:
+            REGIME(I)=2.
         ENDIF
- 
-        !COMPUTE PSIM and PSIH
-        IF((XLAND(I)-1.5).GE.0)THEN                                            
-           ! WATER
-           !CALL PSI_Suselj_Sood_2010(PSIM(I),PSIH(I),ZOL(I)) !produces neg TKE
-           !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I))
-           !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I))
-           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I))
-        ELSE           
-           ! LAND  
-           !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I))
-           !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I))
-           !CALL PSI_Zilitinkevich_Esau_2007(PSIM(I),PSIH(I),ZOL(I))
-           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I))
-        ENDIF     
- 
-        !LOWER LIMIT ON PSI IN STABLE CONDITIONS 
-        psilim = -10.   !JOE: this limit will be hit for z/L > 2, but
-                        !     appears to be necessary to control "runaway cooling"
-                        !     in the polar regions..
 
-        PSIM(I)=MAX(PSIM(I),psilim)
-        PSIH(I)=MAX(PSIH(I),psilim)
-        PSIM10(I)=10./ZA(I)*PSIM(I)
-        PSIM10(I)=MAX(PSIM10(I),psilim)
-        PSIH10(I)=PSIM10(I)
-        PSIM2(I)=2./ZA(I)*PSIM(I)
-        PSIM2(I)=MAX(PSIM2(I),psilim)
-        PSIH2(I)=PSIM2(I)    
-        RMOL(I) = ZOL(I)/ZA(I) !1.0/L                                     
-
-     ELSEIF(BR(I) .GT. 0. .AND. BR(I) .LE. 0.2) THEN         
-        !========================================================
-        !---CLASS 2; DAMPED MECHANICAL TURBULENCE:                                     
-        !========================================================
-        REGIME(I)=2.    
-                                                       
         !COMPUTE z/L
         !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I))
         IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN
            CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I))
         ELSE
-           ZOL(I)=ZA(I)*KARMAN*9.81*MOL(I)/(THX(I)*MAX(UST(I),0.001)**2)
+           ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I),0.001)**2)
            ZOL(I)=MAX(ZOL(I),0.0)
-           ZOL(I)=MIN(ZOL(I),5.0)
+           ZOL(I)=MIN(ZOL(I),2.)
         ENDIF
  
         !COMPUTE PSIM and PSIH
@@ -881,27 +780,22 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
            !CALL PSI_Suselj_Sood_2010(PSIM(I),PSIH(I),ZOL(I))
            !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I))
            !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I))
-           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I))
-        ELSE           
+           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I))
+        ELSE
            ! LAND  
            !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I))
            !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I))
            !CALL PSI_Zilitinkevich_Esau_2007(PSIM(I),PSIH(I),ZOL(I))
-           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I))
+           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I))
         ENDIF              
 
-       !LOWER LIMIT ON PSI IN WEAKLY STABLE CONDITIONS
-        psilim = -10.   !JOE: this limit is never hit in this regime.
-  
-        ! LOWER LIMIT ON PSI IN STABLE CONDITIONS                                     
+        ! LOWER LIMIT ON PSI IN STABLE CONDITIONS
         PSIM(I)=MAX(PSIM(I),psilim)
-        PSIH(I)=MAX(PSIH(I),psilim)
-        PSIM10(I)=10./ZA(I)*PSIM(I)
-        PSIM10(I)=MAX(PSIM10(I),psilim)                               
-        PSIH10(I)=PSIM10(I)                                          
-        PSIM2(I)=2./ZA(I)*PSIM(I)
-        PSIM2(I)=MAX(PSIM2(I),psilim)                              
-        PSIH2(I)=PSIM2(I)
+        PSIH(I)=MAX(PSIH(I),psilim)                                     
+        PSIM10(I)=MAX(10./ZA(I)*PSIM(I), psilim)
+        PSIH10(I)=MAX(10./ZA(I)*PSIH(I), psilim)
+        PSIM2(I)=MAX(2./ZA(I)*PSIM(I), psilim)
+        PSIH2(I)=MAX(2./ZA(I)*PSIH(I), psilim)
         ! 1.0 over Monin-Obukhov length
         RMOL(I)= ZOL(I)/ZA(I)
 
@@ -937,8 +831,8 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
         IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN
            CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I))
         ELSE
-           ZOL(I)=ZA(I)*KARMAN*9.81*MOL(I)/(THX(I)*MAX(UST(I),0.001)**2)
-           ZOL(I)=MAX(ZOL(I),-10.0)
+           ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I),0.001)**2)
+           ZOL(I)=MAX(ZOL(I),-9.999)
            ZOL(I)=MIN(ZOL(I),0.0)
         ENDIF
 
@@ -963,32 +857,40 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
            !CALL PSI_Suselj_Sood_2010(PSIM(I),PSIH(I),ZOL(I))
            !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I))
            !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I))
-           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I))
+           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I))
         ELSE           
            ! LAND  
            !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I))
            !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I))
-           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I))
+           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I))
         ENDIF              
 
-        PSIM10(I)=PSIMTB(NZOL10)+RZOL10*(PSIMTB(NZOL10+1)-PSIMTB(NZOL10))
-        PSIH10(I)=PSIHTB(NZOL10)+RZOL10*(PSIHTB(NZOL10+1)-PSIHTB(NZOL10))
-        PSIM2(I)=PSIMTB(NZOL2)+RZOL2*(PSIMTB(NZOL2+1)-PSIMTB(NZOL2))
-        PSIH2(I)=PSIHTB(NZOL2)+RZOL2*(PSIHTB(NZOL2+1)-PSIHTB(NZOL2))
+!!!!!JOE-test:avoid using psi tables in entirety
+!        PSIM10(I)=PSIMTB(NZOL10)+RZOL10*(PSIMTB(NZOL10+1)-PSIMTB(NZOL10))
+!        PSIH10(I)=PSIHTB(NZOL10)+RZOL10*(PSIHTB(NZOL10+1)-PSIHTB(NZOL10))
+!        PSIM2(I)=PSIMTB(NZOL2)+RZOL2*(PSIMTB(NZOL2+1)-PSIMTB(NZOL2))
+!        PSIH2(I)=PSIHTB(NZOL2)+RZOL2*(PSIHTB(NZOL2+1)-PSIHTB(NZOL2))
+        PSIM10(I)=10./ZA(I)*PSIM(I)
+        PSIH10(I)=10./ZA(I)*PSIH(I)
+        PSIM2(I)=2./ZA(I)*PSIM(I)
+        PSIH2(I)=2./ZA(I)*PSIH(I)
 
         !---LIMIT PSIH AND PSIM IN THE CASE OF THIN LAYERS AND
         !---HIGH ROUGHNESS.  THIS PREVENTS DENOMINATOR IN FLUXES
         !---FROM GETTING TOO SMALL
+        !PSIH(I)=MIN(PSIH(I),0.9*GZ1OZt(I))    !JOE: less restricitive over forest/urban.
         PSIH(I)=MIN(PSIH(I),0.9*GZ1OZ0(I))
         PSIM(I)=MIN(PSIM(I),0.9*GZ1OZ0(I))
+        !PSIH2(I)=MIN(PSIH2(I),0.9*GZ2OZt(I))  !JOE: less restricitive over forest/urban.
         PSIH2(I)=MIN(PSIH2(I),0.9*GZ2OZ0(I))
+        PSIM2(I)=MIN(PSIM2(I),0.9*GZ2OZ0(I))
         PSIM10(I)=MIN(PSIM10(I),0.9*GZ10OZ0(I))
+        PSIH10(I)=MIN(PSIH10(I),0.9*GZ10OZ0(I))
 
         RMOL(I) = ZOL(I)/ZA(I)  
 
      ENDIF
 
-
      !------------------------------------------------------------
      !-----COMPUTE THE FRICTIONAL VELOCITY:                                           
      !------------------------------------------------------------
@@ -1003,16 +905,15 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
       !NON-AVERAGED: UST(I)=KARMAN*WSPD(I)/PSIX
      
       ! Compute u* without vconv for use in HFX calc when isftcflx > 0           
-      WSPDI(I)=SQRT(UX(I)*UX(I)+VX(I)*VX(I))
+      WSPDI(I)=MAX(SQRT(U1D(I)*U1D(I)+V1D(I)*V1D(I)), wmin)
       IF ( PRESENT(USTM) ) THEN
          USTM(I)=0.5*USTM(I)+0.5*KARMAN*WSPDI(I)/PSIX
       ENDIF
 
       IF ((XLAND(I)-1.5).LT.0.) THEN        !LAND
-          !JOE: UST(I)=MAX(UST(I),0.1)
-          UST(I)=MAX(UST(I),0.01)  !Relaxing this limit
-          !Keep ustm = ust over land.
-          USTM(I)=UST(I)
+         UST(I)=MAX(UST(I),0.01)  !JOE:Relaxing this limit
+         !Keep ustm = ust over land.
+         IF ( PRESENT(USTM) ) USTM(I)=UST(I)
       ENDIF
 
      !------------------------------------------------------------
@@ -1031,26 +932,25 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
 
       PSIQ=MAX(LOG((za(i)+z_q(i))/z_q(I))-PSIH(I) ,2.0)   
       PSIQ2=MAX(LOG((2.0+z_q(i))/z_q(I))-PSIH2(I) ,2.0) 
-      !CARLSON AND BOLAND (1978):
-      IF((XLAND(I)-1.5).GE.0)THEN                                            
-         ZL=ZNT(I)                                                            
-      ELSE           
-         ZL=0.01
-         !PSIQ =MAX(LOG(KARMAN*UST(I)*ZA(I)/XKA + ZA(I)/ZL)-PSIH(I),2.0)   
-         !PSIQ2=MAX(LOG(KARMAN*UST(I)*2./XKA + 2./ZL)-PSIH2(I)     ,2.0)                                  
-      ENDIF                                                                    
+
+      IF((XLAND(I)-1.5).LT.0)THEN    !Land only
+         IF ( IZ0TLND .EQ. 4 ) THEN
+            CALL Pan_etal_1994(PSIQ,PSIQ2,UST(I),PSIH(I),PSIH2(I),&
+                       & KARMAN,ZA(I))
+         ENDIF
+      ENDIF
 
       !----------------------------------------------------
       !COMPUTE THE TEMPERATURE SCALE (or FRICTION TEMPERATURE, T*)
       !----------------------------------------------------
-      DTG=THX(I)-THGB(I)                                                   
+      DTG=TH1D(I)-THGB(I)                                                   
       OLDTST=MOL(I)
       MOL(I)=KARMAN*DTG/PSIT/PRT
-      !t_star(I) = -HFX(I)/(UST(I)*CPM(I)*RHOX(I))
+      !t_star(I) = -HFX(I)/(UST(I)*CPM(I)*RHO1D(I))
       !t_star(I) = MOL(I)
       !----------------------------------------------------
       !COMPUTE THE MOISTURE SCALE (or q*)
-      DQG=(QX(i)-qsfc(i))*1000.   !(kg/kg -> g/kg)
+      DQG=(QVSH(i)-qsfc(i))*1000.   !(kg/kg -> g/kg)
       qstar(I)=KARMAN*DQG/PSIQ/PRT
 
       !-----------------------------------------------------
@@ -1061,14 +961,12 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
       ! If the lowest model level is close to 10-m, use it 
       ! instead of the flux-based diagnostic formula.
       if (ZA(i) .gt. 7.0 .and. ZA(i) .lt. 13.0) then
-         U10(I)=UX(I)                                   
-         V10(I)=VX(I)
+         U10(I)=U1D(I)
+         V10(I)=V1D(I)
       else                                 
-         U10(I)=UX(I)*PSIX10/PSIX                                    
-         V10(I)=VX(I)*PSIX10/PSIX     
-      endif                              
-      psixrat(I)=PSIX10/PSIX
-      psitrat(I)=PSIT2/PSIT
+         U10(I)=U1D(I)*PSIX10/PSIX                                    
+         V10(I)=V1D(I)*PSIX10/PSIX     
+      endif
 
       !-----------------------------------------------------
       !COMPUTE 2m T, TH, AND Q
@@ -1077,39 +975,46 @@ SUBROUTINE SFCLAY1D_mynn(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
       TH2(I)=THGB(I)+DTG*PSIT2/PSIT
       !***  BE CERTAIN THAT THE 2-M THETA IS BRACKETED BY
       !***  THE VALUES AT THE SURFACE AND LOWEST MODEL LEVEL.
-      !
-      !IF (THX(I)>THGB(I) .AND. (TH2(I)THX(I)) .OR. &
-      !    THX(I)THGB(I) .OR. TH2(I)THGB(I) .AND. (TH2(I)TH1D(I))) .OR. &
+          (TH1D(I)THGB(I) .OR. TH2(I)QSFCMR(I) .AND. (Q2(I)QV1D(I))) .OR. &
+          (QV1D(I)QSFCMR(I) .OR. Q2(I) 1200. .OR. HFX(I) < -500. .OR. &
+!      &LH(I)  > 1200. .OR. LH(I)  < -500. .OR. &
+!      &UST(I) < 0.0 .OR. UST(I) > 4.0 .OR. &
+!      &WSTAR(I)<0.0 .OR. WSTAR(I) > 6.0 .OR. &
+!      &RHO1D(I)<0.0 .OR. RHO1D(I) > 1.6 .OR. &
+!      &QSFC(I)*1000. <0.0 .OR. QSFC(I)*1000. >38. .OR. &
+!      &PBLH(I)>6000.) THEN
+!      print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",&
+!            ITER-ITMAX," ITERATIONS",I,J
+!      write(*,1000)"HFX: ",HFX(I)," LH:",LH(I)," CH:",CH(I),&
+!            " PBLH:",PBLH(I)
+!      write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I),&
+!            " Tstar:",MOL(I)
+!      write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I),&
+!            " DTHV:",THV1D(I)-THVGB(I)
+!      write(*,1003)"CPM:",CPM(I)," RHO1D:",RHO1D(I)," L:",&
+!            ZOL(I)/ZA(I)," DTH:",TH1D(I)-THGB(I)
+!      write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNT(I)," Zt:",z_t(I),&
+!            " za:",za(I)
+!      write(*,1005)"Re:",restar," MAVAIL:",MAVAIL(I)," QSFC(I):",&
+!            QSFC(I)," QVSH(I):",QVSH(I)
+!      print*,"PSIX=",PSIX," Z0:",ZNT(I)," T1D(i):",T1D(i)
+!      write(*,*)"============================================="
+!   ENDIF
+!   ENDIF
+
+ ENDDO !end i-loop
 
 END SUBROUTINE SFCLAY1D_mynn
-
 !-------------------------------------------------------------------          
-   SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,landsea,IZ0TLND)
+   SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,&
+       & landsea,IZ0TLND2)
 
        ! This subroutine returns the thermal and moisture roughness lengths
        ! from Zilitinkevich (1995) and Zilitinkevich et al. (2001) over
@@ -1245,7 +1172,7 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,landsea,IZ0TLND)
 
        IMPLICIT NONE
        REAL, INTENT(IN) :: Z_0,restar,ustar,KARMAN,landsea
-       INTEGER, OPTIONAL, INTENT(IN)::  IZ0TLND
+       INTEGER, OPTIONAL, INTENT(IN)::  IZ0TLND2
        REAL, INTENT(OUT) :: Zt,Zq
        REAL :: CZIL  !=0.100 in Chen et al. (1997)
                      !=0.075 in Zilitinkevich (1995)
@@ -1274,17 +1201,17 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,landsea,IZ0TLND)
        ELSE                             !LAND
 
           !Option to modify CZIL according to Chen & Zhang, 2009
-          IF ( IZ0TLND .EQ. 1 ) THEN
+          IF ( IZ0TLND2 .EQ. 1 ) THEN
              CZIL = 10.0 ** ( -0.40 * ( Z_0 / 0.07 ) )
           ELSE
              CZIL = 0.10
           END IF
 
           Zt = Z_0*EXP(-KARMAN*CZIL*SQRT(restar))
-          Zt = MIN( Zt, Z_0)
+          Zt = MIN( Zt, Z_0/2.)
 
           Zq = Z_0*EXP(-KARMAN*CZIL*SQRT(restar))
-          Zq = MIN( Zq, Z_0)
+          Zq = MIN( Zq, Z_0/2.)
 
           !Zq = Zt
        ENDIF
@@ -1293,6 +1220,41 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,landsea,IZ0TLND)
 
    END SUBROUTINE zilitinkevich_1995
 !--------------------------------------------------------------------
+   SUBROUTINE Pan_etal_1994(PSIQ,PSIQ2,ustar,psih,psih2,KARMAN,Z1)
+
+       ! This subroutine returns the resistance (PSIQ) for moisture
+       ! exchange. This is a modified form originating from Pan et al. 
+       ! (1994) but modified according to tests in both the RUC model 
+       ! and WRF-ARW. Note that it is very similar to Carlson and
+       ! Boland (1978) model (include below in comments) but has an
+       ! extra molecular layer (a third layer) instead of two layers. 
+
+       IMPLICIT NONE
+       REAL, INTENT(IN) :: Z1,ustar,KARMAN,psih,psih2
+       REAL, INTENT(OUT) :: psiq,psiq2
+       REAL, PARAMETER :: Cpan=1.0 !was 20.8 in Pan et al 1994
+       REAL, PARAMETER :: ZL=0.01  
+       REAL, PARAMETER :: ZMUs=0.2E-3
+       REAL, PARAMETER :: XKA = 2.4E-5
+
+         !PAN et al. (1994): 3-layer model, as in paper:
+         !ZMU = Cpan*XKA/(KARMAN*UST(I)) 
+         !PSIQ =MAX(KARMAN*ustar*ZMU/XKA + LOG((KARMAN*ustar*ZL + XKA)/XKA + &
+         !     & Z1/ZL) - PSIH,2.0)
+         !PSIQ2=MAX(KARMAN*ustar*ZMU/XKA + LOG((KARMAN*ustar*ZL + XKA)/XKA + &
+         !     & 2./ZL) - PSIH2,2.0)                                       
+         !MODIFIED FORM:
+         PSIQ =MAX(KARMAN*ustar*ZMUs/XKA + LOG((KARMAN*ustar*Z1)/XKA + &
+              & Z1/ZL) - PSIH,2.0)
+         PSIQ2=MAX(KARMAN*ustar*ZMUs/XKA + LOG((KARMAN*ustar*2.0)/XKA + &
+              & 2./ZL) - PSIH2,2.0)
+
+         !CARLSON AND BOLAND (1978): 2-layer model
+         !PSIQ =MAX(LOG(KARMAN*ustar*Z1/XKA + Z1/ZL)-PSIH  ,2.0)
+         !PSIQ2=MAX(LOG(KARMAN*ustar*2./XKA + 2./ZL)-PSIH2 ,2.0)
+
+    END SUBROUTINE Pan_etal_1994
+!--------------------------------------------------------------
    SUBROUTINE davis_etal_2008(Z_0,ustar)
 
     !This formulation for roughness length was designed to match 
@@ -1427,8 +1389,9 @@ SUBROUTINE fairall_2001(Zt,Zq,Ren,ustar,visc)
        IF (Ren .le. 2.) then
 
           Zt = (5.5e-5)*(Ren**(-0.60))
+          Zq = Zt
           !FOR SMOOTH SEAS, USE GARRATT
-          Zq = 0.2*visc/MAX(ustar,0.1)
+          !Zq = 0.2*visc/MAX(ustar,0.1)
           !Zq = 0.3*visc/MAX(ustar,0.1)
 
        ELSE
@@ -1564,8 +1527,9 @@ SUBROUTINE PSI_Hogstrom_1996(psi_m, psi_h, zL, Zt, Z_0, Za)
           y = (1.-11.6*zL)**0.5
           y0= (1.-11.6*zhL)**0.5
 
-          psi_m = 2.*LOG((1.+x)/(1.+x0)) + LOG((1.+x**2.)/(1.+x0**2.)) - &
-                  2.*ATAN(x) + 2*ATAN(x0)
+          psi_m = 2.*LOG((1.+x)/(1.+x0)) + &
+                    &LOG((1.+x**2.)/(1.+x0**2.)) - &
+                    &2.0*ATAN(x) + 2.0*ATAN(x0)
           psi_h = 2.*LOG((1.+y)/(1.+y0))
 
        ENDIF
@@ -1602,8 +1566,9 @@ SUBROUTINE PSI_DyerHicks(psi_m, psi_h, zL, Zt, Z_0, Za)
           y = (1.-16.*zL)**0.5
           y0= (1.-16.*zhL)**0.5
 
-          psi_m = 2.*LOG((1.+x)/(1.+x0)) + LOG((1.+x**2.)/(1.+x0**2.)) - & 
-                  2.*ATAN(x) + 2*ATAN(x0)
+          psi_m = 2.*LOG((1.+x)/(1.+x0)) + &
+                    &LOG((1.+x**2.)/(1.+x0**2.)) - & 
+                    &2.0*ATAN(x) + 2.0*ATAN(x0)
           psi_h = 2.*LOG((1.+y)/(1.+y0))
 
        ENDIF
@@ -1690,8 +1655,9 @@ SUBROUTINE PSI_Businger_1971(psi_m, psi_h, zL)
           x = (1. - 15.0*zL)**0.25
           y = (1. - 9.0*zL)**0.5
 
-          psi_m = LOG(((1.+x)/2.)**2.) + LOG((1.+x**2.)/2.) - &
-                           2.*ATAN(x) + Pi180*90.
+          psi_m = LOG(((1.+x)/2.)**2.) + &
+                 &LOG((1.+x**2.)/2.) - &
+                 &2.0*ATAN(x) + Pi180*90.
           psi_h = 2.*LOG((1.+y)/2.)
 
        ELSE                 !STABLE
@@ -1749,13 +1715,13 @@ SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt)
        REAL, INTENT(IN) :: Rib, zaz0, z0zt
        REAL :: alfa, beta, zaz02, z0zt2
        REAL, PARAMETER  :: au11=0.045, bu11=0.003, bu12=0.0059, &
-                           bu21=-0.0828, bu22=0.8845, bu31=0.1739, &
-                           bu32=-0.9213, bu33=-0.1057
+                          &bu21=-0.0828, bu22=0.8845, bu31=0.1739, &
+                          &bu32=-0.9213, bu33=-0.1057
        REAL, PARAMETER  :: aw11=0.5738, aw12=-0.4399, aw21=-4.901,&
-                           aw22=52.50, bw11=-0.0539, bw12=1.540, &
-                           bw21=-0.669, bw22=-3.282
+                          &aw22=52.50, bw11=-0.0539, bw12=1.540, &
+                          &bw21=-0.669, bw22=-3.282
        REAL, PARAMETER  :: as11=0.7529, as21=14.94, bs11=0.1569,&
-                           bs21=-0.3091, bs22=-1.303
+                          &bs21=-0.3091, bs22=-1.303
           
        !set limits according to Li et al (2010), p 157.
        zaz02=zaz0
@@ -1772,23 +1738,23 @@ SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt)
 
        IF (Rib .le. 0.0) THEN
           zL = au11*alfa*Rib**2 + (                   &
-                  (bu11*beta + bu12)*alfa**2 +        &
-                  (bu21*beta + bu22)*alfa    +        &
-                  (bu31*beta**2 + bu32*beta + bu33))*Rib
+               &  (bu11*beta + bu12)*alfa**2 +        &
+               &  (bu21*beta + bu22)*alfa    +        &
+               &  (bu31*beta**2 + bu32*beta + bu33))*Rib
           !if(zL .LT. -15 .OR. zl .GT. 0.)print*,"VIOLATION Rib<0:",zL
           zL = MAX(zL,-15.) !LIMITS SET ACCORDING TO Li et al (2010)
           zL = MIN(zL,0.)   !Figure 1.
        ELSEIF (Rib .gt. 0.0 .AND. Rib .le. 0.2) THEN
           zL = ((aw11*beta + aw12)*alfa +             &
-                (aw21*beta + aw22))*Rib**2 +          &
-               ((bw11*beta + bw12)*alfa +             &
-                (bw21*beta + bw22))*Rib
+             &  (aw21*beta + aw22))*Rib**2 +          &
+             & ((bw11*beta + bw12)*alfa +             &
+             &  (bw21*beta + bw22))*Rib
           !if(zL .LT. 0 .OR. zl .GT. 4)print*,"VIOLATION 00.2:",zL
           zL = MIN(zL,20.) !LIMITS ACCORDING TO Li et al (2010), THIER
                            !FIGUE 1C.
@@ -1800,5 +1766,4 @@ SUBROUTINE Li_etal_2010(zL, Rib, zaz0, z0zt)
     END SUBROUTINE Li_etal_2010
 !--------------------------------------------------------------------
 
-
 END MODULE module_sf_mynn
diff --git a/wrfv2_fire/phys/module_sf_noahdrv.F b/wrfv2_fire/phys/module_sf_noahdrv.F
index 59132b98..5864f094 100644
--- a/wrfv2_fire/phys/module_sf_noahdrv.F
+++ b/wrfv2_fire/phys/module_sf_noahdrv.F
@@ -593,6 +593,13 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK,                      &
   real, intent(in) :: xice_threshold
   character(len=80) :: message_text
 
+
+  FLX4  = 0.0 !BSINGH - Initialized to 0.0
+  FVB   = 0.0 !BSINGH - Initialized to 0.0
+  FBUR  = 0.0 !BSINGH - Initialized to 0.0
+  FGSN  = 0.0 !BSINGH - Initialized to 0.0
+  SOILW = 0.0 !BSINGH - Initialized to 0.0
+
 ! MEK MAY 2007
       FDTLIW=DT/ROWLIW
 ! MEK JUL2007
@@ -1012,9 +1019,10 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK,                      &
 !      prevent diagnostic ground q (q1) from being greater than qsat(tsk)
 !      as happens over snow cover where the cqs2 value also becomes irrelevant
 !      by setting cqs2=chs in this situation the 2m q should become just qv(k=1)
-          IF (Q1 .GT. QSFC(I,J)) THEN
-            CQS2(I,J) = CHS(I,J)
-          ENDIF
+! ww: comment out this change to avoid Q2 drop due to change of radiative flux
+!         IF (Q1 .GT. QSFC(I,J)) THEN
+!           CQS2(I,J) = CHS(I,J)
+!         ENDIF
 !          QSFC(I,J)=Q1
 ! Convert QSFC back to mixing ratio
            QSFC(I,J)= Q1/(1.0-Q1)
@@ -1958,4 +1966,2674 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL)
       END SUBROUTINE SOIL_VEG_GEN_PARM
 !-----------------------------------------------------------------
 
+!===========================================================================
+!
+! subroutine lsm_mosaic: a tiling approach for Noah LSM
+!
+!=========================================================================== 
+
+SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK,                      &
+                  HFX,QFX,LH,GRDFLX, QGH,GSW,SWDOWN,GLW,SMSTAV,SMSTOT, &
+                  SFCRUNOFF, UDRUNOFF,IVGTYP,ISLTYP,ISURBAN,ISICE,VEGFRA,    &
+                  ALBEDO,ALBBCK,ZNT,Z0,TMN,XLAND,XICE,EMISS,EMBCK,   &
+                  SNOWC,QSFC,RAINBL,MMINLU,                     &
+                  num_soil_layers,DT,DZS,ITIMESTEP,             &
+                  SMOIS,TSLB,SNOW,CANWAT,                       &
+                  CHS,CHS2,CQS2,CPM,ROVCP,SR,chklowq,lai,qz0,   & !H
+                  myj,frpcpn,                                   &
+                  SH2O,SNOWH,                                   & !H
+                  U_PHY,V_PHY,                                  & !I
+                  SNOALB,SHDMIN,SHDMAX,                         & !I
+                  SNOTIME,                                      & !?
+                  ACSNOM,ACSNOW,                                & !O
+                  SNOPCX,                                       & !O
+                  POTEVP,                                       & !O
+                  SMCREL,                                       & !O
+                  XICE_THRESHOLD,                               &
+                  RDLAI2D,USEMONALB,                            &
+                  RIB,                                          & !?
+                  NOAHRES,                                      &
+                 NLCAT,landusef,landusef2,                       & ! danli mosaic
+                 sf_surface_mosaic,mosaic_cat,mosaic_cat_index,  & ! danli mosaic 
+                 TSK_mosaic,QSFC_mosaic,                         & ! danli mosaic 
+                 TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic,           & ! danli mosaic 
+                 CANWAT_mosaic,SNOW_mosaic,                      & ! danli mosaic
+                 SNOWH_mosaic,SNOWC_mosaic,                      & ! danli mosaic 
+                 ALBEDO_mosaic,ALBBCK_mosaic,                    & ! danli mosaic
+                 EMISS_mosaic, EMBCK_mosaic,                     & ! danli mosaic
+                 ZNT_mosaic, Z0_mosaic,                          & ! danli mosaic 
+                 HFX_mosaic,QFX_mosaic,                          & ! danli mosaic
+                 LH_mosaic, GRDFLX_mosaic, SNOTIME_mosaic,       & ! danli mosaic                   
+! Noah UA changes
+                  ua_phys,flx4_2d,fvb_2d,fbur_2d,fgsn_2d,       &
+                  ids,ide, jds,jde, kds,kde,                    &
+                  ims,ime, jms,jme, kms,kme,                    &
+                  its,ite, jts,jte, kts,kte,                    &
+                  sf_urban_physics,                             &
+                  CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF,  &
+!Optional Urban
+                  TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !H urban
+                  UC_URB2D,                                     & !H urban
+                  XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D,  & !H urban
+                  TRL_URB3D,TBL_URB3D,TGL_URB3D,                & !H urban
+                  SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D,TS_URB2D,  & !H urban
+                  TR_URB2D_mosaic,TB_URB2D_mosaic,              & !H urban  danli mosaic
+                  TG_URB2D_mosaic,TC_URB2D_mosaic,              & !H urban  danli mosaic
+                  QC_URB2D_mosaic,UC_URB2D_mosaic,              & !H urban  danli mosaic                  
+                  TRL_URB3D_mosaic,TBL_URB3D_mosaic,            & !H urban  danli mosaic
+                  TGL_URB3D_mosaic,                             & !H urban  danli mosaic
+                  SH_URB2D_mosaic,LH_URB2D_mosaic,              & !H urban  danli mosaic
+                  G_URB2D_mosaic,RN_URB2D_mosaic,               & !H urban  danli mosaic
+                  TS_URB2D_mosaic,                              & !H urban  danli mosaic
+                  TS_RUL2D_mosaic,                              & !H urban  danli mosaic                  
+                  PSIM_URB2D,PSIH_URB2D,U10_URB2D,V10_URB2D,    & !O urban
+                  GZ1OZ0_URB2D,  AKMS_URB2D,                    & !O urban
+                  TH2_URB2D,Q2_URB2D, UST_URB2D,                & !O urban
+                  DECLIN_URB,COSZ_URB2D,OMG_URB2D,              & !I urban
+                  XLAT_URB2D,                                   & !I urban
+                  num_roof_layers, num_wall_layers,             & !I urban
+                  num_road_layers, DZR, DZB, DZG,               & !I urban
+                  FRC_URB2D,UTYPE_URB2D,                        & !O
+                  num_urban_layers,                             & !I multi-layer urban
+                  num_urban_hi,                                 & !I multi-layer urban
+                  trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,      & !H multi-layer urban
+                  tlev_urb3d,qlev_urb3d,                        & !H multi-layer urban
+                  tw1lev_urb3d,tw2lev_urb3d,                    & !H multi-layer urban
+                  tglev_urb3d,tflev_urb3d,                      & !H multi-layer urban
+                  sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,          & !H multi-layer urban
+                  sfvent_urb3d,lfvent_urb3d,                    & !H multi-layer urban
+                  sfwin1_urb3d,sfwin2_urb3d,                    & !H multi-layer urban
+                  sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,    & !H multi-layer urban
+                  lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d,         & !H multi-layer urban
+                  mh_urb2d,stdh_urb2d,lf_urb2d,                 & !SLUCM
+                  th_phy,rho,p_phy,ust,                         & !I multi-layer urban
+                  gmt,julday,xlong,xlat,                        & !I multi-layer urban
+                  a_u_bep,a_v_bep,a_t_bep,a_q_bep,              & !O multi-layer urban
+                  a_e_bep,b_u_bep,b_v_bep,                      & !O multi-layer urban
+                  b_t_bep,b_q_bep,b_e_bep,dlg_bep,              & !O multi-layer urban
+                  dl_u_bep,sf_bep,vl_bep,sfcheadrt,INFXSRT, soldrain      )   !O multi-layer urban         
+
+!----------------------------------------------------------------
+    IMPLICIT NONE
+!----------------------------------------------------------------
+!----------------------------------------------------------------
+! --- atmospheric (WRF generic) variables
+!-- DT          time step (seconds)
+!-- DZ8W        thickness of layers (m)
+!-- T3D         temperature (K)
+!-- QV3D        3D water vapor mixing ratio (Kg/Kg)
+!-- P3D         3D pressure (Pa)
+!-- FLHC        exchange coefficient for heat (m/s)
+!-- FLQC        exchange coefficient for moisture (m/s)
+!-- PSFC        surface pressure (Pa)
+!-- XLAND       land mask (1 for land, 2 for water)
+!-- QGH         saturated mixing ratio at 2 meter
+!-- GSW         downward short wave flux at ground surface (W/m^2)
+!-- GLW         downward long wave flux at ground surface (W/m^2)
+!-- History variables
+!-- CANWAT      canopy moisture content (mm)
+!-- TSK         surface temperature (K)
+!-- TSLB        soil temp (k)
+!-- SMOIS       total soil moisture content (volumetric fraction)
+!-- SH2O        unfrozen soil moisture content (volumetric fraction)
+!                note: frozen soil moisture (i.e., soil ice) = SMOIS - SH2O
+!-- SNOWH       actual snow depth (m)
+!-- SNOW        liquid water-equivalent snow depth (m)
+!-- ALBEDO      time-varying surface albedo including snow effect (unitless fraction)
+!-- ALBBCK      background surface albedo (unitless fraction)
+!-- CHS          surface exchange coefficient for heat and moisture (m s-1);
+!-- CHS2        2m surface exchange coefficient for heat  (m s-1);
+!-- CQS2        2m surface exchange coefficient for moisture (m s-1);
+! --- soil variables
+!-- num_soil_layers   the number of soil layers
+!-- ZS          depths of centers of soil layers   (m)
+!-- DZS         thicknesses of soil layers (m)
+!-- SLDPTH      thickness of each soil layer (m, same as DZS)
+!-- TMN         soil temperature at lower boundary (K)
+!-- SMCWLT      wilting point (volumetric)
+!-- SMCDRY      dry soil moisture threshold where direct evap from
+!               top soil layer ends (volumetric)
+!-- SMCREF      soil moisture threshold below which transpiration begins to
+!                   stress (volumetric)
+!-- SMCMAX      porosity, i.e. saturated value of soil moisture (volumetric)
+!-- NROOT       number of root layers, a function of veg type, determined
+!               in subroutine redprm.
+!-- SMSTAV      Soil moisture availability for evapotranspiration (
+!                   fraction between SMCWLT and SMCMXA)
+!-- SMSTOT      Total soil moisture content frozen+unfrozen) in the soil column (mm)
+! --- snow variables
+!-- SNOWC       fraction snow coverage (0-1.0)
+! --- vegetation variables
+!-- SNOALB      upper bound on maximum albedo over deep snow
+!-- SHDMIN      minimum areal fractional coverage of annual green vegetation
+!-- SHDMAX      maximum areal fractional coverage of annual green vegetation
+!-- XLAI        leaf area index (dimensionless)
+!-- Z0BRD       Background fixed roughness length (M)
+!-- Z0          Background vroughness length (M) as function
+!-- ZNT         Time varying roughness length (M) as function
+!-- ALBD(IVGTPK,ISN) background albedo reading from a table
+! --- LSM output
+!-- HFX         upward heat flux at the surface (W/m^2)
+!-- QFX         upward moisture flux at the surface (kg/m^2/s)
+!-- LH          upward moisture flux at the surface (W m-2)
+!-- GRDFLX(I,J) ground heat flux (W m-2)
+!-- FDOWN       radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN
+!----------------------------------------------------------------------------
+!-- EC          canopy water evaporation ((W m-2)
+!-- EDIR        direct soil evaporation (W m-2)
+!-- ET          plant transpiration from a particular root layer (W m-2)
+!-- ETT         total plant transpiration (W m-2)
+!-- ESNOW       sublimation from (or deposition to if <0) snowpack (W m-2)
+!-- DRIP        through-fall of precip and/or dew in excess of canopy
+!                 water-holding capacity (m)
+!-- DEW         dewfall (or frostfall for t<273.15) (M)
+!-- SMAV        Soil Moisture Availability for each layer, as a fraction
+!                 between SMCWLT and SMCMAX (dimensionless fraction)
+! ----------------------------------------------------------------------
+!-- BETA        ratio of actual/potential evap (dimensionless)
+!-- ETP         potential evaporation (W m-2)
+! ----------------------------------------------------------------------
+!-- FLX1        precip-snow sfc (W m-2)
+!-- FLX2        freezing rain latent heat flux (W m-2)
+!-- FLX3        phase-change heat flux from snowmelt (W m-2)
+! ----------------------------------------------------------------------
+!-- ACSNOM      snow melt (mm) (water equivalent)
+!-- ACSNOW      accumulated snow fall (mm) (water equivalent)
+!-- SNOPCX      snow phase change heat flux (W/m^2)
+!-- POTEVP      accumulated potential evaporation (m)
+!-- RIB         Documentation needed!!!
+! ----------------------------------------------------------------------
+!-- RUNOFF1     surface runoff (m s-1), not infiltrating the surface
+!-- RUNOFF2     subsurface runoff (m s-1), drainage out bottom of last
+!                  soil layer (baseflow)
+!  important note: here RUNOFF2 is actually the sum of RUNOFF2 and RUNOFF3
+!-- RUNOFF3     numerical trunctation in excess of porosity (smcmax)
+!                  for a given soil layer at the end of a time step (m s-1).
+!SFCRUNOFF     Surface Runoff (mm)
+!UDRUNOFF      Total Underground Runoff (mm), which is the sum of RUNOFF2 and RUNOFF3
+! ----------------------------------------------------------------------
+!-- RC          canopy resistance (s m-1)
+!-- PC          plant coefficient (unitless fraction, 0-1) where PC*ETP = actual transp
+!-- RSMIN       minimum canopy resistance (s m-1)
+!-- RCS         incoming solar rc factor (dimensionless)
+!-- RCT         air temperature rc factor (dimensionless)
+!-- RCQ         atmos vapor pressure deficit rc factor (dimensionless)
+!-- RCSOIL      soil moisture rc factor (dimensionless)
+
+!-- EMISS       surface emissivity (between 0 and 1)
+!-- EMBCK       Background surface emissivity (between 0 and 1)
+
+!-- ROVCP       R/CP
+!               (R_d/R_v) (dimensionless)
+!-- ids         start index for i in domain
+!-- ide         end index for i in domain
+!-- jds         start index for j in domain
+!-- jde         end index for j in domain
+!-- kds         start index for k in domain
+!-- kde         end index for k in domain
+!-- ims         start index for i in memory
+!-- ime         end index for i in memory
+!-- jms         start index for j in memory
+!-- jme         end index for j in memory
+!-- kms         start index for k in memory
+!-- kme         end index for k in memory
+!-- its         start index for i in tile
+!-- ite         end index for i in tile
+!-- jts         start index for j in tile
+!-- jte         end index for j in tile
+!-- kts         start index for k in tile
+!-- kte         end index for k in tile
+!
+!-- SR          fraction of frozen precip (0.0 to 1.0)
+!----------------------------------------------------------------
+
+! IN only
+
+   INTEGER,  INTENT(IN   )   ::     ids,ide, jds,jde, kds,kde,  &
+                                    ims,ime, jms,jme, kms,kme,  &
+                                    its,ite, jts,jte, kts,kte
+
+   INTEGER,  INTENT(IN   )   ::  sf_urban_physics               !urban
+   INTEGER,  INTENT(IN   )   ::  isurban
+   INTEGER,  INTENT(IN   )   ::  isice
+
+!added by Wei Yu  for routing
+    REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+             INTENT(INOUT)  :: sfcheadrt,INFXSRT,soldrain 
+    real :: etpnd1
+!end added
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(IN   )    ::                            TMN, &
+                                                         XLAND, &
+                                                          XICE, &
+                                                        VEGFRA, &
+                                                        SHDMIN, &
+                                                        SHDMAX, &
+                                                        SNOALB, &
+                                                           GSW, &
+                                                        SWDOWN, & !added 10 jan 2007
+                                                           GLW, &
+                                                        RAINBL, &
+                                                        SR
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(INOUT)    ::                         ALBBCK, &
+                                                            Z0, &
+                                                         EMBCK                  ! danli mosaic
+                                                         
+   CHARACTER(LEN=*), INTENT(IN   )    ::                 MMINLU
+
+   REAL,    DIMENSION( ims:ime, kms:kme, jms:jme )            , &
+            INTENT(IN   )    ::                           QV3D, &
+                                                         p8w3D, &
+                                                          DZ8W, &
+                                                          T3D
+   REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+             INTENT(IN   )               ::               QGH,  &
+                                                          CPM
+
+   INTEGER, DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(IN   )    ::                          ISLTYP
+                                                        
+   INTEGER, DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(INOUT   )    ::                         IVGTYP                   ! for mosaic danli
+
+   INTEGER, INTENT(IN)       ::     num_soil_layers,ITIMESTEP
+
+   REAL,     INTENT(IN   )   ::     DT,ROVCP
+
+   REAL,     DIMENSION(1:num_soil_layers), INTENT(IN)::DZS
+
+! IN and OUT
+
+   REAL,     DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), &
+             INTENT(INOUT)   ::                          SMOIS, & ! total soil moisture
+                                                         SH2O,  & ! new soil liquid
+                                                         TSLB     ! TSLB     STEMP
+
+   REAL,     DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), &
+             INTENT(OUT)     ::                         SMCREL
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(INOUT)    ::                            TSK, & !was TGB (temperature)
+                                                           HFX, &
+                                                           QFX, &
+                                                            LH, &
+                                                        GRDFLX, &
+                                                          QSFC,&
+                                                          CQS2,&
+                                                          CHS,   &
+                                                          CHS2,&
+                                                          SNOW, &
+                                                         SNOWC, &
+                                                         SNOWH, & !new
+                                                        CANWAT, &
+                                                        SMSTAV, &
+                                                        SMSTOT, &
+                                                     SFCRUNOFF, &
+                                                      UDRUNOFF, &
+                                                        ACSNOM, &
+                                                        ACSNOW, &
+                                                       SNOTIME, &
+                                                        SNOPCX, &
+                                                        EMISS,  &
+                                                          RIB,  &
+                                                        POTEVP, &
+                                                        ALBEDO, &
+                                                           ZNT
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(OUT)      ::                         NOAHRES
+
+! Noah UA changes
+   LOGICAL,                                INTENT(IN)  :: UA_PHYS
+   REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: FLX4_2D,FVB_2D,FBUR_2D,FGSN_2D
+   REAL                                                :: FLX4,FVB,FBUR,FGSN
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+               INTENT(OUT)    ::                        CHKLOWQ
+   REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LAI
+   REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) ::        QZ0
+
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF
+! Local variables (moved here from driver to make routine thread safe, 20031007 jm)
+
+      REAL, DIMENSION(1:num_soil_layers) ::  ET
+
+      REAL, DIMENSION(1:num_soil_layers) ::  SMAV
+
+      REAL  ::  BETA, ETP, SSOIL,EC, EDIR, ESNOW, ETT,        &
+                FLX1,FLX2,FLX3, DRIP,DEW,FDOWN,RC,PC,RSMIN,XLAI,  &
+!                RCS,RCT,RCQ,RCSOIL
+                RCS,RCT,RCQ,RCSOIL,FFROZP
+
+    LOGICAL,    INTENT(IN   )    ::     myj,frpcpn
+
+! DECLARATIONS - LOGICAL
+! ----------------------------------------------------------------------
+      LOGICAL, PARAMETER :: LOCAL=.false.
+      LOGICAL :: FRZGRA, SNOWNG
+
+      LOGICAL :: IPRINT
+
+! ----------------------------------------------------------------------
+! DECLARATIONS - INTEGER
+! ----------------------------------------------------------------------
+      INTEGER :: I,J, ICE,NSOIL,SLOPETYP,SOILTYP,VEGTYP
+      INTEGER :: NROOT
+      INTEGER :: KZ ,K
+      INTEGER :: NS
+! ----------------------------------------------------------------------
+! DECLARATIONS - REAL
+! ----------------------------------------------------------------------
+
+      REAL  :: SHMIN,SHMAX,DQSDT2,LWDN,PRCP,PRCPRAIN,                    &
+               Q2SAT,Q2SATI,SFCPRS,SFCSPD,SFCTMP,SHDFAC,SNOALB1,         &
+               SOLDN,TBOT,ZLVL, Q2K,ALBBRD, ALBEDOK, ETA, ETA_KINEMATIC, &
+               EMBRD,                                                    &
+               Z0K,RUNOFF1,RUNOFF2,RUNOFF3,SHEAT,SOLNET,E2SAT,SFCTSNO,   &
+! mek, WRF testing, expanded diagnostics
+               SOLUP,LWUP,RNET,RES,Q1SFC,TAIRV,SATFLG
+! MEK MAY 2007
+      REAL ::  FDTLIW
+! MEK JUL2007 for pot. evap.
+      REAL :: RIBB
+      REAL ::  FDTW
+
+      REAL  :: EMISSI
+
+      REAL  :: SNCOVR,SNEQV,SNOWHK,CMC, CHK,TH2
+
+      REAL  :: SMCDRY,SMCMAX,SMCREF,SMCWLT,SNOMLT,SOILM,SOILW,Q1,T1
+      REAL  :: SNOTIME1    ! LSTSNW1 INITIAL NUMBER OF TIMESTEPS SINCE LAST SNOWFALL
+
+      REAL  :: DUMMY,Z0BRD
+!
+      REAL  :: COSZ, SOLARDIRECT
+!
+      REAL, DIMENSION(1:num_soil_layers)::  SLDPTH, STC,SMC,SWC
+!
+      REAL, DIMENSION(1:num_soil_layers) ::     ZSOIL, RTDIS
+      REAL, PARAMETER  :: TRESH=.95E0, A2=17.67,A3=273.15,A4=29.65,   &
+                          T0=273.16E0, ELWV=2.50E6,  A23M4=A2*(A3-A4)
+! MEK MAY 2007
+      REAL, PARAMETER  :: ROW=1.E3,ELIW=XLF,ROWLIW=ROW*ELIW
+
+! ----------------------------------------------------------------------
+! DECLARATIONS START - urban
+! ----------------------------------------------------------------------
+
+! input variables surface_driver --> lsm
+     INTEGER, INTENT(IN) :: num_roof_layers
+     INTEGER, INTENT(IN) :: num_wall_layers
+     INTEGER, INTENT(IN) :: num_road_layers
+     REAL, OPTIONAL, DIMENSION(1:num_roof_layers), INTENT(IN) :: DZR
+     REAL, OPTIONAL, DIMENSION(1:num_wall_layers), INTENT(IN) :: DZB
+     REAL, OPTIONAL, DIMENSION(1:num_road_layers), INTENT(IN) :: DZG
+     REAL, OPTIONAL, INTENT(IN) :: DECLIN_URB
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: COSZ_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: OMG_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: XLAT_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: U_PHY
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: V_PHY
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: TH_PHY
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: P_PHY
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: RHO
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UST
+
+     LOGICAL, intent(in) :: rdlai2d
+     LOGICAL, intent(in) :: USEMONALB
+
+! input variables lsm --> urban
+     INTEGER :: UTYPE_URB ! urban type [urban=1, suburban=2, rural=3]
+     REAL :: TA_URB       ! potential temp at 1st atmospheric level [K]
+     REAL :: QA_URB       ! mixing ratio at 1st atmospheric level  [kg/kg]
+     REAL :: UA_URB       ! wind speed at 1st atmospheric level    [m/s]
+     REAL :: U1_URB       ! u at 1st atmospheric level             [m/s]
+     REAL :: V1_URB       ! v at 1st atmospheric level             [m/s]
+     REAL :: SSG_URB      ! downward total short wave radiation    [W/m/m]
+     REAL :: LLG_URB      ! downward long wave radiation           [W/m/m]
+     REAL :: RAIN_URB     ! precipitation                          [mm/h]
+     REAL :: RHOO_URB     ! air density                            [kg/m^3]
+     REAL :: ZA_URB       ! first atmospheric level                [m]
+     REAL :: DELT_URB     ! time step                              [s]
+     REAL :: SSGD_URB     ! downward direct short wave radiation   [W/m/m]
+     REAL :: SSGQ_URB     ! downward diffuse short wave radiation  [W/m/m]
+     REAL :: XLAT_URB     ! latitude                               [deg]
+     REAL :: COSZ_URB     ! cosz
+     REAL :: OMG_URB      ! hour angle
+     REAL :: ZNT_URB      ! roughness length                       [m]
+     REAL :: TR_URB
+     REAL :: TB_URB
+     REAL :: TG_URB
+     REAL :: TC_URB
+     REAL :: QC_URB
+     REAL :: UC_URB
+     REAL :: XXXR_URB
+     REAL :: XXXB_URB
+     REAL :: XXXG_URB
+     REAL :: XXXC_URB
+     REAL, DIMENSION(1:num_roof_layers) :: TRL_URB  ! roof layer temp [K]
+     REAL, DIMENSION(1:num_wall_layers) :: TBL_URB  ! wall layer temp [K]
+     REAL, DIMENSION(1:num_road_layers) :: TGL_URB  ! road layer temp [K]
+     LOGICAL  :: LSOLAR_URB
+! state variable surface_driver <--> lsm <--> urban
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UC_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D
+!
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D
+
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D
+
+! output variable lsm --> surface_driver
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIM_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIH_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: GZ1OZ0_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: U10_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: V10_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: TH2_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: Q2_URB2D
+!
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: AKMS_URB2D
+!
+     REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: UST_URB2D
+     REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FRC_URB2D                ! change this to inout, danli mosaic
+     INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: UTYPE_URB2D
+
+! output variables urban --> lsm
+     REAL :: TS_URB     ! surface radiative temperature    [K]
+     REAL :: QS_URB     ! surface humidity                 [-]
+     REAL :: SH_URB     ! sensible heat flux               [W/m/m]
+     REAL :: LH_URB     ! latent heat flux                 [W/m/m]
+     REAL :: LH_KINEMATIC_URB ! latent heat flux, kinetic  [kg/m/m/s]
+     REAL :: SW_URB     ! upward short wave radiation flux [W/m/m]
+     REAL :: ALB_URB    ! time-varying albedo            [fraction]
+     REAL :: LW_URB     ! upward long wave radiation flux  [W/m/m]
+     REAL :: G_URB      ! heat flux into the ground        [W/m/m]
+     REAL :: RN_URB     ! net radiation                    [W/m/m]
+     REAL :: PSIM_URB   ! shear f for momentum             [-]
+     REAL :: PSIH_URB   ! shear f for heat                 [-]
+     REAL :: GZ1OZ0_URB   ! shear f for heat                 [-]
+     REAL :: U10_URB    ! wind u component at 10 m         [m/s]
+     REAL :: V10_URB    ! wind v component at 10 m         [m/s]
+     REAL :: TH2_URB    ! potential temperature at 2 m     [K]
+     REAL :: Q2_URB     ! humidity at 2 m                  [-]
+     REAL :: CHS_URB
+     REAL :: CHS2_URB
+     REAL :: UST_URB
+! NUDAPT Parameters urban --> lam
+     REAL :: mh_urb
+     REAL :: stdh_urb
+     REAL :: lp_urb
+     REAL :: hgt_urb
+     REAL, DIMENSION(4) :: lf_urb
+! Variables for multi-layer UCM (Martilli et al. 2002)
+   REAL, OPTIONAL, INTENT(IN  )   ::                                   GMT 
+   INTEGER, OPTIONAL, INTENT(IN  ) ::                               JULDAY
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN   )        ::XLAT, XLONG
+   INTEGER, INTENT(IN  ) ::                               NUM_URBAN_LAYERS
+   INTEGER, INTENT(IN  ) ::                               NUM_URBAN_HI
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lf_ac_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sf_ac_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: cm_ac_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfvent_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: lfvent_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ), INTENT(IN) :: hi_urb2d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lp_urb2d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: lb_urb2d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: hgt_urb2d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: mh_urb2d
+   REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: stdh_urb2d
+   REAL, OPTIONAL, DIMENSION( ims:ime, 4, jms:jme ), INTENT(IN) :: lf_urb2d
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_u_bep   !Implicit momemtum component X-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_v_bep   !Implicit momemtum component Y-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_t_bep   !Implicit component pot. temperature
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_q_bep   !Implicit momemtum component X-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_e_bep   !Implicit component TKE
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_u_bep   !Explicit momentum component X-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_v_bep   !Explicit momentum component Y-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_t_bep   !Explicit component pot. temperature
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_q_bep   !Implicit momemtum component Y-direction
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::b_e_bep   !Explicit component TKE
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::vl_bep    !Fraction air volume in grid cell
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dlg_bep   !Height above ground
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::sf_bep  !Fraction air at the face of grid cell
+   REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::dl_u_bep  !Length scale
+
+! Local variables for multi-layer UCM (Martilli et al. 2002)
+   REAL,    DIMENSION( its:ite, jts:jte ) :: HFX_RURAL,LH_RURAL,GRDFLX_RURAL ! ,RN_RURAL
+   REAL,    DIMENSION( its:ite, jts:jte ) :: QFX_RURAL ! ,QSFC_RURAL,UMOM_RURAL,VMOM_RURAL
+   REAL,    DIMENSION( its:ite, jts:jte ) :: ALB_RURAL,EMISS_RURAL,TSK_RURAL ! ,UST_RURAL
+!   REAL,    DIMENSION( ims:ime, jms:jme ) :: QSFC_URB
+   REAL,    DIMENSION( its:ite, jts:jte ) :: HFX_URB,UMOM_URB,VMOM_URB
+   REAL,    DIMENSION( its:ite, jts:jte ) :: QFX_URB
+!   REAL,    DIMENSION( ims:ime, jms:jme ) :: ALBEDO_URB,EMISS_URB,UMOM,VMOM,UST
+   REAL, DIMENSION(its:ite,jts:jte) ::EMISS_URB
+   REAL, DIMENSION(its:ite,jts:jte) :: RL_UP_URB
+   REAL, DIMENSION(its:ite,jts:jte) ::RS_ABS_URB
+   REAL, DIMENSION(its:ite,jts:jte) ::GRDFLX_URB
+   REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM
+   REAL :: r1,r2,r3
+   REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB
+   REAL :: frc_urb,lb_urb
+   REAL :: check 
+! ----------------------------------------------------------------------
+! DECLARATIONS END - urban
+! ----------------------------------------------------------------------
+!-------------------------------------------------
+! Noah-mosaic related variables are added to declaration  (danli)
+!-------------------------------------------------
+  
+  INTEGER, INTENT(IN) :: sf_surface_mosaic    
+  INTEGER, INTENT(IN) :: mosaic_cat, NLCAT
+  REAL, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(IN) :: landusef 
+  REAL, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(INOUT) ::landusef2 
+  INTEGER, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(INOUT) :: mosaic_cat_index 
+
+  REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT)::   &
+        TSK_mosaic, QSFC_mosaic, CANWAT_mosaic, SNOW_mosaic,SNOWH_mosaic, SNOWC_mosaic 
+  REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT)::   &
+        ALBEDO_mosaic,ALBBCK_mosaic, EMISS_mosaic, EMBCK_mosaic, ZNT_mosaic, Z0_mosaic,   &
+        HFX_mosaic,QFX_mosaic, LH_mosaic, GRDFLX_mosaic,SNOTIME_mosaic    
+  REAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), OPTIONAL, INTENT(INOUT)::   &
+        TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic
+  REAL, DIMENSION( ims:ime, jms:jme ) :: TSK_mosaic_avg, QSFC_mosaic_avg, CANWAT_mosaic_avg,SNOW_mosaic_avg,SNOWH_mosaic_avg, &
+                                         SNOWC_mosaic_avg, HFX_mosaic_avg, QFX_mosaic_avg, LH_mosaic_avg, GRDFLX_mosaic_avg,  &
+                                         ALBEDO_mosaic_avg, ALBBCK_mosaic_avg, EMISS_mosaic_avg, EMBCK_mosaic_avg,            &
+                                         ZNT_mosaic_avg, Z0_mosaic_avg, SNOTIME_mosaic_avg, FAREA_mosaic_avg  
+  REAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme )                     ::   &
+        TSLB_mosaic_avg,SMOIS_mosaic_avg,SH2O_mosaic_avg
+  
+  REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT)::   &
+        TR_URB2D_mosaic, TB_URB2D_mosaic, TG_URB2D_mosaic, TC_URB2D_mosaic,QC_URB2D_mosaic, UC_URB2D_mosaic, &
+        SH_URB2D_mosaic,LH_URB2D_mosaic,G_URB2D_mosaic,RN_URB2D_mosaic,TS_URB2D_mosaic, TS_RUL2D_mosaic  
+                  
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TRL_URB3D_mosaic
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TBL_URB3D_mosaic
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TGL_URB3D_mosaic
+
+  INTEGER, DIMENSION( ims:ime, jms:jme ) ::    IVGTYP_dominant
+  INTEGER ::  mosaic_i, URBAN_METHOD, zo_avg_option
+  REAL :: FAREA
+  LOGICAL :: IPRINT_mosaic, Noah_call
+!-------------------------------------------------
+! Noah-mosaic related variables declaration end (danli)
+!-------------------------------------------------
+
+  REAL, PARAMETER  :: CAPA=R_D/CP
+  REAL :: APELM,APES,SFCTH2,PSFC
+  real, intent(in) :: xice_threshold
+  character(len=80) :: message_text
+
+! MEK MAY 2007
+      FDTLIW=DT/ROWLIW
+! MEK JUL2007
+      FDTW=DT/(XLV*RHOWATER)
+! debug printout
+      IPRINT=.false.
+      IPRINT_mosaic=.false.
+
+!      SLOPETYP=2
+      SLOPETYP=1
+!      SHDMIN=0.00
+
+      NSOIL=num_soil_layers
+
+     DO NS=1,NSOIL
+     SLDPTH(NS)=DZS(NS)
+     ENDDO
+
+     JLOOP : DO J=jts,jte
+
+      IF(ITIMESTEP.EQ.1)THEN
+        DO 50 I=its,ite
+!*** initialize soil conditions for IHOP 31 May case
+!         IF((XLAND(I,J)-1.5) < 0.)THEN
+!            if (I==108.and.j==85) then
+!                  DO NS=1,NSOIL
+!                      SMOIS(I,NS,J)=0.10
+!                      SH2O(I,NS,J)=0.10
+!                  enddo
+!             endif
+!         ENDIF
+
+!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS
+          IF((XLAND(I,J)-1.5).GE.0.)THEN
+! check sea-ice point
+#if 0
+            IF( XICE(I,J).GE. XICE_THRESHOLD .and. IPRINT ) PRINT*, ' sea-ice at water point, I=',I,'J=',J
+#endif
+!***   Open Water Case
+            SMSTAV(I,J)=1.0
+            SMSTOT(I,J)=1.0
+            DO NS=1,NSOIL
+              SMOIS(I,NS,J)=1.0
+              TSLB(I,NS,J)=273.16                                          !STEMP
+              SMCREL(I,NS,J)=1.0
+            ENDDO
+          ELSE
+            IF ( XICE(I,J) .GE. XICE_THRESHOLD ) THEN
+!***        SEA-ICE CASE
+              SMSTAV(I,J)=1.0
+              SMSTOT(I,J)=1.0
+              DO NS=1,NSOIL
+                SMOIS(I,NS,J)=1.0
+                SMCREL(I,NS,J)=1.0
+              ENDDO
+            ENDIF
+          ENDIF
+!
+   50   CONTINUE
+      ENDIF                                                               ! end of initialization over ocean
+
+!-----------------------------------------------------------------------
+      ILOOP : DO I=its,ite
+      
+         IF (((XLAND(I,J)-1.5).LT.0.) .AND. (XICE(I,J) < XICE_THRESHOLD) ) THEN
+               
+               IVGTYP_dominant(I,J)=IVGTYP(I,J)                                   ! save this
+      
+            ! INITIALIZE THE AREA-AVERAGED FLUXES 
+               
+                 TSK_mosaic_avg(i,j)= 0                              ! from 3D to 2D
+                 QSFC_mosaic_avg(i,j)= 0
+                 CANWAT_mosaic_avg(i,j)= 0
+                 SNOW_mosaic_avg(i,j)= 0
+                 SNOWH_mosaic_avg(i,j)= 0
+                 SNOWC_mosaic_avg(i,j)= 0
+            
+                          DO NS=1,NSOIL
+            
+                     TSLB_mosaic_avg(i,NS,j)=0
+                     SMOIS_mosaic_avg(i,NS,j)=0
+                     SH2O_mosaic_avg(i,NS,j)=0
+            
+                         ENDDO
+            
+                 HFX_mosaic_avg(i,j)= 0
+                 QFX_mosaic_avg(i,j)= 0  
+                 LH_mosaic_avg(i,j)=  0 
+                 GRDFLX_mosaic_avg(i,j)= 0
+                 ALBEDO_mosaic_avg(i,j)=0
+                 ALBBCK_mosaic_avg(i,j)=0
+                 EMISS_mosaic_avg(i,j)=0
+                 EMBCK_mosaic_avg(i,j)=0
+                 ZNT_mosaic_avg(i,j)=0
+                 Z0_mosaic_avg(i,j)=0  
+                 FAREA_mosaic_avg(i,j)=0  
+            
+            ! add a new loop for the mosaic_cat
+            
+               DO mosaic_i = mosaic_cat, 1, -1
+               
+            !   if (mosaic_cat_index(I,mosaic_i,J) .EQ. 16 ) then
+            !   PRINT*, 'you still have water tiles at','i=',i,'j=',j, 'mosaic_i',mosaic_i
+            !   PRINT*, 'xland',xland(i,j),'xice',xice(i,j)
+            !   endif
+               
+               IVGTYP(I,J)=mosaic_cat_index(I,mosaic_i,J)                         ! replace it with the mosaic one          
+               TSK(I,J)=TSK_mosaic(I,mosaic_i,J)                                  ! from 3D to 2D
+               QSFC(i,j)=QSFC_mosaic(I,mosaic_i,J)
+               CANWAT(i,j)=CANWAT_mosaic(i,mosaic_i,j) 
+               SNOW(i,j)=SNOW_mosaic(i,mosaic_i,j) 
+               SNOWH(i,j)=SNOWH_mosaic(i,mosaic_i,j)  
+               SNOWC(i,j)=SNOWC_mosaic(i,mosaic_i,j)
+            
+                ALBEDO(i,j) = ALBEDO_mosaic(i,mosaic_i,j)
+                ALBBCK(i,j)= ALBBCK_mosaic(i,mosaic_i,j) 
+                EMISS(i,j)= EMISS_mosaic(i,mosaic_i,j) 
+                EMBCK(i,j)= EMBCK_mosaic(i,mosaic_i,j) 
+                ZNT(i,j)= ZNT_mosaic(i,mosaic_i,j) 
+                Z0(i,j)= Z0_mosaic(i,mosaic_i,j)    
+            
+                 SNOTIME(i,j)= SNOTIME_mosaic(i,mosaic_i,j)          
+              
+                          DO NS=1,NSOIL
+            
+                     TSLB(i,NS,j)=TSLB_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)
+                     SMOIS(i,NS,j)=SMOIS_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)
+                     SH2O(i,NS,j)=SH2O_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)
+            
+                          ENDDO
+            
+                       IF(IPRINT_mosaic) THEN
+            
+                   print*, 'BEFORE SFLX, in Noahdrv.F'
+                   print*, 'mosaic_cat', mosaic_cat, 'IVGTYP',IVGTYP(i,j), 'TSK',TSK(i,j),'HFX',HFX(i,j), 'QSFC', QSFC(i,j),   &
+                   'CANWAT', CANWAT(i,j), 'SNOW',SNOW(i,j), 'ALBEDO',ALBEDO(i,j), 'TSLB',TSLB(i,1,j),'CHS',CHS(i,j),'ZNT',ZNT(i,j)
+            
+                       ENDIF
+            
+            !-----------------------------------------------------------------------
+            ! insert the NOAH model here for the non-urban one and the urban one  DANLI
+            !-----------------------------------------------------------------------
+            
+      ! surface pressure
+              PSFC=P8w3D(i,1,j)
+      ! pressure in middle of lowest layer
+              SFCPRS=(P8W3D(I,KTS+1,j)+P8W3D(i,KTS,j))*0.5
+      ! convert from mixing ratio to specific humidity
+               Q2K=QV3D(i,1,j)/(1.0+QV3D(i,1,j))
+      !
+      !         Q2SAT=QGH(I,j)
+               Q2SAT=QGH(I,J)/(1.0+QGH(I,J))        ! Q2SAT is sp humidity
+      ! add check on myj=.true.
+      !        IF((Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
+              IF((myj).AND.(Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
+                SATFLG=0.
+                CHKLOWQ(I,J)=0.
+              ELSE
+                SATFLG=1.0
+                CHKLOWQ(I,J)=1.
+              ENDIF
+      
+              SFCTMP=T3D(i,1,j)
+              ZLVL=0.5*DZ8W(i,1,j)
+      
+      !        TH2=SFCTMP+(0.0097545*ZLVL)
+      ! calculate SFCTH2 via Exner function vs lapse-rate (above)
+               APES=(1.E5/PSFC)**CAPA
+               APELM=(1.E5/SFCPRS)**CAPA
+               SFCTH2=SFCTMP*APELM
+               TH2=SFCTH2/APES
+      !
+               EMISSI = EMISS(I,J)
+               LWDN=GLW(I,J)*EMISSI
+      ! SOLDN is total incoming solar
+              SOLDN=SWDOWN(I,J)
+      ! GSW is net downward solar
+      !        SOLNET=GSW(I,J)
+      ! use mid-day albedo to determine net downward solar (no solar zenith angle correction)
+              SOLNET=SOLDN*(1.-ALBEDO(I,J))
+              PRCP=RAINBL(i,j)/DT
+              VEGTYP=IVGTYP(I,J)
+              SOILTYP=ISLTYP(I,J)
+              SHDFAC=VEGFRA(I,J)/100.
+              T1=TSK(I,J)
+              CHK=CHS(I,J)
+              SHMIN=SHDMIN(I,J)/100. !NEW
+              SHMAX=SHDMAX(I,J)/100. !NEW
+      ! convert snow water equivalent from mm to meter
+              SNEQV=SNOW(I,J)*0.001
+      ! snow depth in meters
+              SNOWHK=SNOWH(I,J)
+              SNCOVR=SNOWC(I,J)
+      
+      ! if "SR" present, set frac of frozen precip ("FFROZP") = snow-ratio ("SR", range:0-1)
+      ! SR from e.g. Ferrier microphysics
+      ! otherwise define from 1st atmos level temperature
+             IF(FRPCPN) THEN
+                FFROZP=SR(I,J)
+              ELSE
+                IF (SFCTMP <=  273.15) THEN
+                  FFROZP = 1.0
+      	  ELSE
+      	    FFROZP = 0.0
+      	  ENDIF
+              ENDIF
+      !***
+              IF((XLAND(I,J)-1.5).GE.0.)THEN                                  ! begining of land/sea if block
+      ! Open water points
+                TSK_RURAL(I,J)=TSK(I,J)
+                HFX_RURAL(I,J)=HFX(I,J)
+                QFX_RURAL(I,J)=QFX(I,J)
+                LH_RURAL(I,J)=LH(I,J)
+                EMISS_RURAL(I,J)=EMISS(I,J)
+                GRDFLX_RURAL(I,J)=GRDFLX(I,J)
+              ELSE
+      ! Land or sea-ice case
+      
+                IF (XICE(I,J) >= XICE_THRESHOLD) THEN
+                   ! Sea-ice point
+                   ICE = 1
+                ELSE IF ( VEGTYP == ISICE ) THEN
+                   ! Land-ice point
+                   ICE = -1
+                ELSE
+                   ! Neither sea ice or land ice.
+                   ICE=0
+                ENDIF
+                DQSDT2=Q2SAT*A23M4/(SFCTMP-A4)**2
+      
+                IF(SNOW(I,J).GT.0.0)THEN
+      ! snow on surface (use ice saturation properties)
+                  SFCTSNO=SFCTMP
+                  E2SAT=611.2*EXP(6174.*(1./273.15 - 1./SFCTSNO))
+                  Q2SATI=0.622*E2SAT/(SFCPRS-E2SAT)
+                  Q2SATI=Q2SATI/(1.0+Q2SATI)    ! spec. hum.
+                  IF (T1 .GT. 273.14) THEN
+      ! warm ground temps, weight the saturation between ice and water according to SNOWC
+                    Q2SAT=Q2SAT*(1.-SNOWC(I,J)) + Q2SATI*SNOWC(I,J)
+                    DQSDT2=DQSDT2*(1.-SNOWC(I,J)) + Q2SATI*6174./(SFCTSNO**2)*SNOWC(I,J)
+                  ELSE
+      ! cold ground temps, use ice saturation only
+                    Q2SAT=Q2SATI
+                    DQSDT2=Q2SATI*6174./(SFCTSNO**2)
+                  ENDIF
+      ! for snow cover fraction at 0 C, ground temp will not change, so DQSDT2 effectively zero
+                  IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0.)DQSDT2=DQSDT2*(1.-SNOWC(I,J))
+                ENDIF
+      
+                ! Land-ice or land points use the usual deep-soil temperature.
+                TBOT=TMN(I,J)
+      
+                IF(VEGTYP.EQ.25) SHDFAC=0.0000
+                IF(VEGTYP.EQ.26) SHDFAC=0.0000
+                IF(VEGTYP.EQ.27) SHDFAC=0.0000
+                IF(SOILTYP.EQ.14.AND.XICE(I,J).EQ.0.)THEN
+#if 0
+               IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT'
+               IF(IPRINT)PRINT*,i,j,'RESET SOIL in surfce.F'
+#endif
+                  SOILTYP=7
+                ENDIF
+                SNOALB1 = SNOALB(I,J)
+                CMC=CANWAT(I,J)
+      
+      !-------------------------------------------
+      !*** convert snow depth from mm to meter
+      !
+      !          IF(RDMAXALB) THEN
+      !           SNOALB=ALBMAX(I,J)*0.01
+      !         ELSE
+      !           SNOALB=MAXALB(IVGTPK)*0.01
+      !         ENDIF
+      
+      !        SNOALB1=0.80
+      !        SHMIN=0.00
+              ALBBRD=ALBBCK(I,J)
+              Z0BRD=Z0(I,J)
+              EMBRD=EMBCK(I,J)
+              SNOTIME1 = SNOTIME(I,J)
+              RIBB=RIB(I,J)
+      !FEI: temporaray arrays above need to be changed later by using SI
+      
+                DO NS=1,NSOIL
+                  SMC(NS)=SMOIS(I,NS,J)
+                  STC(NS)=TSLB(I,NS,J)                                          !STEMP
+                  SWC(NS)=SH2O(I,NS,J)
+                ENDDO
+      !
+                if ( (SNEQV.ne.0..AND.SNOWHK.eq.0.).or.(SNOWHK.le.SNEQV) )THEN
+                  SNOWHK= 5.*SNEQV
+                endif
+      !
+      
+      !Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as
+      ! the "NATURAL" category in the VEGPARM.TBL
+      	
+      	!   IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN
+                       
+      
+           !           IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+           !            IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN
+           !	 VEGTYP = NATURAL
+           !            SHDFAC = SHDTBL(NATURAL)
+           !            ALBEDOK =0.2         !  0.2
+           !            ALBBRD  =0.2         !0.2
+           !            EMISSI = 0.98                                 !for VEGTYP=5
+           !	 IF ( FRC_URB2D(I,J) < 0.99 ) THEN
+          !               if(sf_urban_physics.eq.1)then
+          !       T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J))
+          !               elseif((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then
+          !            r1= (tsk(i,j)**4.)
+          !            r2= frc_urb2d(i,j)*(ts_urb2d(i,j)**4.)
+          !            r3= (1.-frc_urb2d(i,j))
+         !             t1= ((r1-r2)/r3)**.25
+         !                endif
+         !	         ELSE
+         !		 T1 = TSK(I,J)
+         !              ENDIF
+         !             ENDIF
+          !       ELSE
+           !            IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+          !              IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN
+           !             VEGTYP = ISURBAN
+           !      	 ENDIF
+           !      ENDIF
+      
+            Noah_call=.TRUE.
+      
+            If ( SF_URBAN_PHYSICS == 0 ) THEN   ! ONLY NOAH
+      
+                 IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+                       IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN
+                       Noah_call = .TRUE.                 
+                       VEGTYP = ISURBAN
+                 ENDIF
+      
+            ENDIF
+            
+            IF(SF_URBAN_PHYSICS == 1) THEN
+      
+                 IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+                       IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN   
+              	
+                       Noah_call = .TRUE.                       
+              	       VEGTYP = NATURAL                                              
+                       SHDFAC = SHDTBL(NATURAL)
+                       ALBEDOK =0.2         !  0.2
+                       ALBBRD  =0.2         !  0.2
+                       EMISSI = 0.98        !  for VEGTYP=5       
+                       
+      		      T1= TS_RUL2D_mosaic(I,mosaic_i,J)
+                       
+                 ENDIF
+      
+            ENDIF 
+            
+            IF( SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN
+!             print*, 'MOSAIC is not designed to work with SF_URBAN_PHYSICS=2 or SF_URBAN_PHYSICS=3'
+            ENDIF
+      
+         IF (Noah_call) THEN
+#if 0
+                IF(IPRINT) THEN
+      !
+             print*, 'BEFORE SFLX, in Noahlsm_driver'
+             print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL,   &
+             'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
+              LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN,      &
+              'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K,   &
+               'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
+               'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
+               'SHMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB1',SNOALB1,'TBOT',&
+                TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
+                STC, 'SMC',SMC, 'SWC',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
+                'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT,      &
+                'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC,   &
+                'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
+                'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
+                'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
+                'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
+                'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS,  &
+                'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW,     &
+                'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
+                'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
+                 endif
+#endif
+      
+                IF (rdlai2d) THEN
+                   xlai = lai(i,j)
+                endif
+      
+          IF ( ICE == 1 ) THEN
+      
+             ! Sea-ice case
+      
+             DO NS = 1, NSOIL
+                SH2O(I,NS,J) = 1.0
+             ENDDO
+             LAI(I,J) = 0.01
+      
+             CYCLE ILOOP
+      
+          ELSEIF (ICE == 0) THEN
+      
+             ! Non-glacial land
+      
+             CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH,      &    !C
+                       LOCAL,                                           &    !L
+                       LUTYPE, SLTYPE,                                  &    !CL
+                       LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY,         &    !F
+                       DUMMY,DUMMY, DUMMY,                              &    !F PRCPRAIN not used
+                       TH2,Q2SAT,DQSDT2,                                &    !I
+                       VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX,      &    !I
+                       ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, &    !S
+                       CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,&    !H
+                       ETA,SHEAT, ETA_KINEMATIC,FDOWN,                  &    !O
+                       EC,EDIR,ET,ETT,ESNOW,DRIP,DEW,                   &    !O
+                       BETA,ETP,SSOIL,                                  &    !O
+                       FLX1,FLX2,FLX3,                                  &    !O
+      		 FLX4,FVB,FBUR,FGSN,UA_PHYS,                      &    !UA 
+                       SNOMLT,SNCOVR,                                   &    !O
+                       RUNOFF1,RUNOFF2,RUNOFF3,                         &    !O
+                       RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL,             &    !O
+                       SOILW,SOILM,Q1,SMAV,                             &    !D
+                       RDLAI2D,USEMONALB,                               &
+                       SNOTIME1,                                        &
+                       RIBB,                                            &
+                       SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT,               &
+                       sfcheadrt(i,j),                                   &    !I
+                       INFXSRT(i,j),ETPND1                          &    !O
+                       )
+      
+#ifdef WRF_HYDRO
+                       soldrain(i,j) = RUNOFF2*DT*1000.0
+#endif
+          ELSEIF (ICE == -1) THEN
+      
+             !
+             ! Set values that the LSM is expected to update,
+             ! but don't get updated for glacial points.
+             !
+             SOILM = 0.0 !BSINGH(PNNL)- SOILM is undefined for this case, it is used for diagnostics so setting it to zero
+             XLAI = 0.01 ! KWM Should this be Zero over land ice?  Does this value matter?
+             RUNOFF2 = 0.0
+             RUNOFF3 = 0.0
+             DO NS = 1, NSOIL
+                SWC(NS) = 1.0
+                SMC(NS) = 1.0
+                SMAV(NS) = 1.0
+             ENDDO
+             CALL SFLX_GLACIAL(I,J,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH,   &    !C
+                  &    LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,              &    !F
+                  &    TH2,Q2SAT,DQSDT2,                                &    !I
+                  &    ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, &    !S
+                  &    T1,STC(1:NSOIL),SNOWHK,SNEQV,ALBEDOK,CHK,        &    !H
+                  &    ETA,SHEAT,ETA_KINEMATIC,FDOWN,                   &    !O
+                  &    ESNOW,DEW,                                       &    !O
+                  &    ETP,SSOIL,                                       &    !O
+                  &    FLX1,FLX2,FLX3,                                  &    !O
+                  &    SNOMLT,SNCOVR,                                   &    !O
+                  &    RUNOFF1,                                         &    !O
+                  &    Q1,                                              &    !D
+                  &    SNOTIME1,                                        &
+                  &    RIBB)
+      
+          ENDIF
+      
+             lai(i,j) = xlai
+      
+#if 0
+                IF(IPRINT) THEN
+      
+             print*, 'AFTER SFLX, in Noahlsm_driver'
+             print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL,   &
+             'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
+              LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN,      &
+              'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K,   &
+               'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
+                'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
+               'SHDMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB',SNOALB1,'TBOT',&
+                TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
+                STC, 'SMC',SMC, 'SWc',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
+                'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT,      &
+                'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC,   &
+                'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
+                'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
+                'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
+                'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
+                'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS,  &
+                'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW,     &
+                'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
+                'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
+                 endif
+#endif
+      
+      !***  UPDATE STATE VARIABLES
+                CANWAT(I,J)=CMC
+                SNOW(I,J)=SNEQV*1000.
+      !          SNOWH(I,J)=SNOWHK*1000.
+                SNOWH(I,J)=SNOWHK                   ! SNOWHK in meters
+                ALBEDO(I,J)=ALBEDOK
+                ALB_RURAL(I,J)=ALBEDOK
+                ALBBCK(I,J)=ALBBRD
+                Z0(I,J)=Z0BRD
+                EMISS(I,J) = EMISSI
+                EMISS_RURAL(I,J) = EMISSI
+      ! Noah: activate time-varying roughness length (V3.3 Feb 2011)
+                ZNT(I,J)=Z0K
+                TSK(I,J)=T1
+                TSK_RURAL(I,J)=T1
+                HFX(I,J)=SHEAT
+                HFX_RURAL(I,J)=SHEAT
+      ! MEk Jul07 add potential evap accum
+              POTEVP(I,J)=POTEVP(I,J)+ETP*FDTW
+                QFX(I,J)=ETA_KINEMATIC
+                QFX_RURAL(I,J)=ETA_KINEMATIC
+      
+#ifdef WRF_HYDRO
+      !added by Wei Yu
+      !         QFX(I,J) = QFX(I,J) + ETPND1
+      !         ETA = ETA + ETPND1/2.501E6*dt
+      !end added by Wei Yu
+#endif
+      
+                LH(I,J)=ETA
+                LH_RURAL(I,J)=ETA
+                GRDFLX(I,J)=SSOIL
+                GRDFLX_RURAL(I,J)=SSOIL
+                SNOWC(I,J)=SNCOVR
+                CHS2(I,J)=CQS2(I,J)
+                SNOTIME(I,J) = SNOTIME1
+      !      prevent diagnostic ground q (q1) from being greater than qsat(tsk)
+      !      as happens over snow cover where the cqs2 value also becomes irrelevant
+      !      by setting cqs2=chs in this situation the 2m q should become just qv(k=1)
+                IF (Q1 .GT. QSFC(I,J)) THEN
+                  CQS2(I,J) = CHS(I,J)
+                ENDIF
+      !          QSFC(I,J)=Q1
+      ! Convert QSFC back to mixing ratio
+                 QSFC(I,J)= Q1/(1.0-Q1)
+      !
+                 ! QSFC_RURAL(I,J)= Q1/(1.0-Q1)
+      ! Calculate momentum flux from rural surface for use with multi-layer UCM (Martilli et al. 2002)
+      
+                DO 81 NS=1,NSOIL
+                 SMOIS(I,NS,J)=SMC(NS)
+                 TSLB(I,NS,J)=STC(NS)                                        !  STEMP
+                 SH2O(I,NS,J)=SWC(NS)
+         81     CONTINUE
+      !       ENDIF
+      
+              FLX4_2D(I,J)  = FLX4
+      	FVB_2D(I,J)   = FVB
+      	FBUR_2D(I,J)  = FBUR
+      	FGSN_2D(I,J)  = FGSN
+      
+           !
+           ! Residual of surface energy balance equation terms
+           !
+      
+           IF ( UA_PHYS ) THEN
+               noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta &
+                    - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 - flx4
+      
+           ELSE
+               noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta &
+                    - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3
+           ENDIF
+      
+               ENDIF   !ENDIF FOR Noah_call
+               
+              IF (SF_URBAN_PHYSICS == 1 ) THEN                                              ! Beginning of UCM CALL if block
+      !--------------------------------------
+      ! URBAN CANOPY MODEL START - urban
+      !--------------------------------------
+      ! Input variables lsm --> urban
+      
+                IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+                    IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN            
+      
+                !  UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial)
+                !  this need to be changed in the mosaic danli
+      
+                IF(IVGTYP(I,J)==ISURBAN) UTYPE_URB=2
+                IF(IVGTYP(I,J)==31) UTYPE_URB=3
+                IF(IVGTYP(I,J)==32) UTYPE_URB=2
+                IF(IVGTYP(I,J)==33) UTYPE_URB=1
+                        
+                IF(UTYPE_URB==3) FRC_URB2D(I,J)=0.5
+                IF(UTYPE_URB==2) FRC_URB2D(I,J)=0.9
+                IF(UTYPE_URB==1) FRC_URB2D(I,J)=0.95
+      
+                  TA_URB    = SFCTMP           ! [K]
+                  QA_URB    = Q2K              ! [kg/kg]
+                  UA_URB    = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.)
+                  U1_URB    = U_PHY(I,1,J)
+                  V1_URB    = V_PHY(I,1,J)
+                  IF(UA_URB < 1.) UA_URB=1.    ! [m/s]
+                  SSG_URB   = SOLDN            ! [W/m/m]
+                  SSGD_URB  = 0.8*SOLDN        ! [W/m/m]
+                  SSGQ_URB  = SSG_URB-SSGD_URB ! [W/m/m]
+                  LLG_URB   = GLW(I,J)         ! [W/m/m]
+                  RAIN_URB  = RAINBL(I,J)      ! [mm]
+                  RHOO_URB  = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m]
+                  ZA_URB    = ZLVL             ! [m]
+                  DELT_URB  = DT               ! [sec]
+                  XLAT_URB  = XLAT_URB2D(I,J)  ! [deg]
+                  COSZ_URB  = COSZ_URB2D(I,J)  !
+                  OMG_URB   = OMG_URB2D(I,J)   !
+                  ZNT_URB   = ZNT(I,J)
+      
+                  LSOLAR_URB = .FALSE.
+                  
+      ! mosaic 3D to 2D
+      
+         TR_URB2D(I,J)=TR_URB2D_mosaic(I,mosaic_i,J)                         ! replace it with the mosaic one          
+         TB_URB2D(I,J)=TB_URB2D_mosaic(I,mosaic_i,J)                         ! replace it with the mosaic one          
+         TG_URB2D(I,J)=TG_URB2D_mosaic(I,mosaic_i,J)                         ! replace it with the mosaic one          
+         TC_URB2D(I,J)=TC_URB2D_mosaic(I,mosaic_i,J)                         ! replace it with the mosaic one          
+         QC_URB2D(I,J)=QC_URB2D_mosaic(I,mosaic_i,J)                         ! replace it with the mosaic one          
+         UC_URB2D(I,J)=UC_URB2D_mosaic(I,mosaic_i,J)                         ! replace it with the mosaic one          
+         TS_URB2D(I,J)=TS_URB2D_mosaic(I,mosaic_i,J)                         ! replace it with the mosaic one          
+      
+                  DO K = 1,num_roof_layers
+                    TRL_URB3D(I,K,J) = TRL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)
+                  END DO
+                  DO K = 1,num_wall_layers
+                    TBL_URB3D(I,K,J) = TBL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)
+                  END DO
+                  DO K = 1,num_road_layers
+                    TGL_URB3D(I,K,J) = TGL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)
+                  END DO
+      
+      ! mosaic 2D to 1D            
+      
+                  TR_URB = TR_URB2D(I,J)
+                  TB_URB = TB_URB2D(I,J)
+                  TG_URB = TG_URB2D(I,J)
+                  TC_URB = TC_URB2D(I,J)
+                  QC_URB = QC_URB2D(I,J)
+                  UC_URB = UC_URB2D(I,J)
+      
+                  DO K = 1,num_roof_layers
+                    TRL_URB(K) = TRL_URB3D(I,K,J)
+                  END DO
+                  DO K = 1,num_wall_layers
+                    TBL_URB(K) = TBL_URB3D(I,K,J)
+                  END DO
+                  DO K = 1,num_road_layers
+                    TGL_URB(K) = TGL_URB3D(I,K,J)
+                  END DO
+      
+                  XXXR_URB = XXXR_URB2D(I,J)
+                  XXXB_URB = XXXB_URB2D(I,J)
+                  XXXG_URB = XXXG_URB2D(I,J)
+                  XXXC_URB = XXXC_URB2D(I,J)
+      !
+      !      Limits to avoid dividing by small number
+                  if (CHS(I,J) < 1.0E-02) then
+                     CHS(I,J)  = 1.0E-02
+                  endif
+                  if (CHS2(I,J) < 1.0E-02) then
+                     CHS2(I,J)  = 1.0E-02
+                  endif
+                  if (CQS2(I,J) < 1.0E-02) then
+                     CQS2(I,J)  = 1.0E-02
+                  endif
+      !
+                  CHS_URB  = CHS(I,J)
+                  CHS2_URB = CHS2(I,J)
+                  IF (PRESENT(CMR_SFCDIF)) THEN
+                     CMR_URB = CMR_SFCDIF(I,J)
+                     CHR_URB = CHR_SFCDIF(I,J)
+                     CMC_URB = CMC_SFCDIF(I,J)
+                     CHC_URB = CHC_SFCDIF(I,J)
+                  ENDIF
+      
+      ! NUDAPT for SLUCM
+                  mh_urb = mh_urb2d(I,J)
+                  stdh_urb = stdh_urb2d(I,J)
+                  lp_urb = lp_urb2d(I,J)
+                  hgt_urb = hgt_urb2d(I,J)
+                  lf_urb = 0.0
+                  DO K = 1,4
+                    lf_urb(K)=lf_urb2d(I,K,J)
+                  ENDDO
+                  frc_urb = frc_urb2d(I,J)
+                  lb_urb = lb_urb2d(I,J)
+                  check = 0
+                  if (I.eq.73.and.J.eq.125)THEN
+                     check = 1
+                  end if
+      !
+      ! Call urban
+      
+                  CALL urban(LSOLAR_URB,                                      & ! I
+                             num_roof_layers,num_wall_layers,num_road_layers, & ! C
+                             DZR,DZB,DZG,                                     & ! C
+                             UTYPE_URB,TA_URB,QA_URB,UA_URB,U1_URB,V1_URB,SSG_URB, & ! I
+                             SSGD_URB,SSGQ_URB,LLG_URB,RAIN_URB,RHOO_URB,     & ! I
+                             ZA_URB,DECLIN_URB,COSZ_URB,OMG_URB,              & ! I
+                             XLAT_URB,DELT_URB,ZNT_URB,                       & ! I
+                             CHS_URB, CHS2_URB,                               & ! I
+                             TR_URB, TB_URB, TG_URB, TC_URB, QC_URB,UC_URB,   & ! H
+                             TRL_URB,TBL_URB,TGL_URB,                         & ! H
+                             XXXR_URB, XXXB_URB, XXXG_URB, XXXC_URB,          & ! H
+                             TS_URB,QS_URB,SH_URB,LH_URB,LH_KINEMATIC_URB,    & ! O
+                             SW_URB,ALB_URB,LW_URB,G_URB,RN_URB,PSIM_URB,PSIH_URB, & ! O
+                             GZ1OZ0_URB,                                      & !O
+                             CMR_URB, CHR_URB, CMC_URB, CHC_URB,              &
+                             U10_URB, V10_URB, TH2_URB, Q2_URB,               & ! O
+                             UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb,        & ! 0
+                             hgt_urb,frc_urb,lb_urb, check)                            !O
+      
+#if 0
+                IF(IPRINT) THEN
+      
+             print*, 'AFTER CALL URBAN'
+             print*,'num_roof_layers',num_roof_layers, 'num_wall_layers',  &
+              num_wall_layers,                                             &
+             'DZR',DZR,'DZB',DZB,'DZG',DZG,'UTYPE_URB',UTYPE_URB,'TA_URB', &
+              TA_URB,                                                      &
+              'QA_URB',QA_URB,'UA_URB',UA_URB,'U1_URB',U1_URB,'V1_URB',    &
+               V1_URB,                                                     &
+               'SSG_URB',SSG_URB,'SSGD_URB',SSGD_URB,'SSGQ_URB',SSGQ_URB,  &
+              'LLG_URB',LLG_URB,'RAIN_URB',RAIN_URB,'RHOO_URB',RHOO_URB,   &
+              'ZA_URB',ZA_URB, 'DECLIN_URB',DECLIN_URB,'COSZ_URB',COSZ_URB,&
+              'OMG_URB',OMG_URB,'XLAT_URB',XLAT_URB,'DELT_URB',DELT_URB,   &
+               'ZNT_URB',ZNT_URB,'TR_URB',TR_URB, 'TB_URB',TB_URB,'TG_URB',&
+               TG_URB,'TC_URB',TC_URB,'QC_URB',QC_URB,'TRL_URB',TRL_URB,   &
+                'TBL_URB',TBL_URB,'TGL_URB',TGL_URB,'XXXR_URB',XXXR_URB,   &
+               'XXXB_URB',XXXB_URB,'XXXG_URB',XXXG_URB,'XXXC_URB',XXXC_URB,&
+               'TS_URB',TS_URB,'QS_URB',QS_URB,'SH_URB',SH_URB,'LH_URB',   &
+               LH_URB, 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'SW_URB',SW_URB,&
+               'ALB_URB',ALB_URB,'LW_URB',LW_URB,'G_URB',G_URB,'RN_URB',   &
+                RN_URB, 'PSIM_URB',PSIM_URB,'PSIH_URB',PSIH_URB,          &
+               'U10_URB',U10_URB,'V10_URB',V10_URB,'TH2_URB',TH2_URB,      &
+                'Q2_URB',Q2_URB,'CHS_URB',CHS_URB,'CHS2_URB',CHS2_URB
+                 endif
+#endif
+      
+                  TS_URB2D(I,J) = TS_URB
+      
+                  ALBEDO(I,J) = FRC_URB2D(I,J)*ALB_URB+(1-FRC_URB2D(I,J))*ALBEDOK   ![-]
+                  HFX(I,J) = FRC_URB2D(I,J)*SH_URB+(1-FRC_URB2D(I,J))*SHEAT         ![W/m/m]
+                  QFX(I,J) = FRC_URB2D(I,J)*LH_KINEMATIC_URB &
+                           + (1-FRC_URB2D(I,J))*ETA_KINEMATIC                ![kg/m/m/s]
+                  LH(I,J) = FRC_URB2D(I,J)*LH_URB+(1-FRC_URB2D(I,J))*ETA            ![W/m/m]
+                  GRDFLX(I,J) = FRC_URB2D(I,J)*G_URB+(1-FRC_URB2D(I,J))*SSOIL       ![W/m/m]
+                  TSK(I,J) = FRC_URB2D(I,J)*TS_URB+(1-FRC_URB2D(I,J))*T1            ![K]
+                  Q1 = FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*Q1            ![-]
+      ! Convert QSFC back to mixing ratio
+                  QSFC(I,J)= Q1/(1.0-Q1)
+                  UST(I,J)= FRC_URB2D(I,J)*UST_URB+(1-FRC_URB2D(I,J))*UST(I,J)      ![m/s]
+                  ZNT(I,J)= EXP(FRC_URB2D(I,J)*ALOG(ZNT_URB)+(1-FRC_URB2D(I,J))* ALOG(ZNT(I,J)))   ! ADD BY DAN
+
+#if 0
+          IF(IPRINT)THEN
+      
+          print*, ' FRC_URB2D', FRC_URB2D,                        &
+          'ALB_URB',ALB_URB, 'ALBEDOK',ALBEDOK, &
+          'ALBEDO(I,J)',  ALBEDO(I,J),                  &
+          'SH_URB',SH_URB,'SHEAT',SHEAT, 'HFX(I,J)',HFX(I,J),  &
+          'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'ETA_KINEMATIC',  &
+           ETA_KINEMATIC, 'QFX(I,J)',QFX(I,J),                  &
+          'LH_URB',LH_URB, 'ETA',ETA, 'LH(I,J)',LH(I,J),        &
+          'G_URB',G_URB,'SSOIL',SSOIL,'GRDFLX(I,J)', GRDFLX(I,J),&
+          'TS_URB',TS_URB,'T1',T1,'TSK(I,J)',TSK(I,J),          &
+          'QS_URB',QS_URB,'Q1',Q1,'QSFC(I,J)',QSFC(I,J)
+           endif
+#endif
+      
+      ! Renew Urban State Varialbes
+      
+                  TR_URB2D(I,J) = TR_URB
+                  TB_URB2D(I,J) = TB_URB
+                  TG_URB2D(I,J) = TG_URB
+                  TC_URB2D(I,J) = TC_URB
+                  QC_URB2D(I,J) = QC_URB
+                  UC_URB2D(I,J) = UC_URB
+      
+                  DO K = 1,num_roof_layers
+                    TRL_URB3D(I,K,J) = TRL_URB(K)
+                  END DO
+                  DO K = 1,num_wall_layers
+                    TBL_URB3D(I,K,J) = TBL_URB(K)
+                  END DO
+                  DO K = 1,num_road_layers
+                    TGL_URB3D(I,K,J) = TGL_URB(K)
+                  END DO
+                  XXXR_URB2D(I,J) = XXXR_URB
+                  XXXB_URB2D(I,J) = XXXB_URB
+                  XXXG_URB2D(I,J) = XXXG_URB
+                  XXXC_URB2D(I,J) = XXXC_URB
+      
+                  SH_URB2D(I,J)    = SH_URB
+                  LH_URB2D(I,J)    = LH_URB
+                  G_URB2D(I,J)     = G_URB
+                  RN_URB2D(I,J)    = RN_URB
+                  PSIM_URB2D(I,J)  = PSIM_URB
+                  PSIH_URB2D(I,J)  = PSIH_URB
+                  GZ1OZ0_URB2D(I,J)= GZ1OZ0_URB
+                  U10_URB2D(I,J)   = U10_URB
+                  V10_URB2D(I,J)   = V10_URB
+                  TH2_URB2D(I,J)   = TH2_URB
+                  Q2_URB2D(I,J)    = Q2_URB
+                  UST_URB2D(I,J)   = UST_URB
+                  AKMS_URB2D(I,J)  = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J))
+                  IF (PRESENT(CMR_SFCDIF)) THEN
+                     CMR_SFCDIF(I,J) = CMR_URB
+                     CHR_SFCDIF(I,J) = CHR_URB
+                     CMC_SFCDIF(I,J) = CMC_URB
+                     CHC_SFCDIF(I,J) = CHC_URB
+                  ENDIF
+                  
+                     ! 2D to 3D  mosaic danli
+      	    	              
+      	    	                       TR_URB2D_mosaic(I,mosaic_i,J)=TR_URB2D(I,J)                               
+      	    	    	               TB_URB2D_mosaic(I,mosaic_i,J)=TB_URB2D(I,J)                                   
+      	    	    	               TG_URB2D_mosaic(I,mosaic_i,J)=TG_URB2D(I,J)                                   
+      	    	    	               TC_URB2D_mosaic(I,mosaic_i,J)=TC_URB2D(I,J)                                  
+      	    	    	               QC_URB2D_mosaic(I,mosaic_i,J)=QC_URB2D(I,J)                                   
+      	    	    	               UC_URB2D_mosaic(I,mosaic_i,J)=UC_URB2D(I,J)                                   
+      	    	    	               TS_URB2D_mosaic(I,mosaic_i,J)=TS_URB2D(I,J)                                   
+      	    	    	               TS_RUL2D_mosaic(I,mosaic_i,J)=T1                                
+      	    	    	  	  
+      	    	    	  	              DO K = 1,num_roof_layers
+      	    	    	  	                TRL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)=TRL_URB3D(I,K,J) 
+      	    	    	  	              END DO
+      	    	    	  	              DO K = 1,num_wall_layers
+      	    	    	  	                TBL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)=TBL_URB3D(I,K,J) 
+      	    	    	  	              END DO
+      	    	    	  	              DO K = 1,num_road_layers
+      	    	    	  	                TGL_URB3D_mosaic(I,K+(mosaic_i-1)*num_roof_layers,J)=TGL_URB3D(I,K,J) 
+      	    	    	                        END DO
+      	    	    	            
+      	    	    	              SH_URB2D_mosaic(I,mosaic_i,J) = SH_URB2D(I,J)
+      	    	    	  	      LH_URB2D_mosaic(I,mosaic_i,J) = LH_URB2D(I,J)
+      	    	    	              G_URB2D_mosaic(I,mosaic_i,J)  = G_URB2D(I,J)
+                                    RN_URB2D_mosaic(I,mosaic_i,J) = RN_URB2D(I,J)
+                                    
+                END IF
+      
+               ENDIF                                   ! end of UCM CALL if block
+      !--------------------------------------
+      ! Urban Part End - urban
+      !--------------------------------------
+      
+      !***  DIAGNOSTICS
+                SMSTAV(I,J)=SOILW
+                SMSTOT(I,J)=SOILM*1000.
+                DO NS=1,NSOIL
+                SMCREL(I,NS,J)=SMAV(NS)
+                ENDDO
+      
+      !         Convert the water unit into mm
+                SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RUNOFF1*DT*1000.0
+                UDRUNOFF(I,J)=UDRUNOFF(I,J)+RUNOFF2*DT*1000.0
+      ! snow defined when fraction of frozen precip (FFROZP) > 0.5,
+                IF(FFROZP.GT.0.5)THEN
+                  ACSNOW(I,J)=ACSNOW(I,J)+PRCP*DT
+                ENDIF
+                IF(SNOW(I,J).GT.0.)THEN
+                  ACSNOM(I,J)=ACSNOM(I,J)+SNOMLT*1000.
+      ! accumulated snow-melt energy
+                  SNOPCX(I,J)=SNOPCX(I,J)-SNOMLT/FDTLIW
+                ENDIF
+      
+              ENDIF                                                           ! endif of land-sea test
+      
+      !-----------------------------------------------------------------------
+      ! Done with the Noah-UCM MOSAIC  DANLI
+      !-----------------------------------------------------------------------
+      
+                  TSK_mosaic(i,mosaic_i,j)=TSK(i,j)                           ! from 2D to 3D
+                  QSFC_mosaic(i,mosaic_i,j)=QSFC(i,j)
+                  CANWAT_mosaic(i,mosaic_i,j)=CANWAT(i,j) 
+                  SNOW_mosaic(i,mosaic_i,j)=SNOW(i,j) 
+                  SNOWH_mosaic(i,mosaic_i,j)=SNOWH(i,j)  
+                  SNOWC_mosaic(i,mosaic_i,j)=SNOWC(i,j) 
+      
+                  ALBEDO_mosaic(i,mosaic_i,j)=ALBEDO(i,j) 
+                  ALBBCK_mosaic(i,mosaic_i,j)=ALBBCK(i,j)  
+                  EMISS_mosaic(i,mosaic_i,j)=EMISS(i,j) 
+                  EMBCK_mosaic(i,mosaic_i,j)=EMBCK(i,j)  
+                  ZNT_mosaic(i,mosaic_i,j)=ZNT(i,j)  
+                  Z0_mosaic(i,mosaic_i,j)=Z0(i,j)    
+                                                                                       
+                  HFX_mosaic(i,mosaic_i,j)=HFX(i,j) 
+                  QFX_mosaic(i,mosaic_i,j)=QFX(i,j)  
+                  LH_mosaic(i,mosaic_i,j)=LH(i,j)  
+                  GRDFLX_mosaic(i,mosaic_i,j)=GRDFLX(i,j) 
+                  SNOTIME_mosaic(i,mosaic_i,j)=SNOTIME(i,j) 
+       
+                  DO NS=1,NSOIL
+        
+                  TSLB_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)=TSLB(i,NS,j)
+                  SMOIS_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)=SMOIS(i,NS,j)
+                  SH2O_mosaic(i,NSOIL*(mosaic_i-1)+NS,j)=SH2O(i,NS,j)  
+      
+                  ENDDO
+                  
+#if 0
+            IF(TSK_mosaic(i,mosaic_i,j) > 350 .OR. TSK_mosaic(i,mosaic_i,j) < 250 .OR. abs(HFX_mosaic(i,mosaic_i,j)) > 700 ) THEN
+                  print*, 'I', I, 'J', J, 'MOSAIC_I', MOSAIC_I
+                  print*, 'mosaic_cat_index',mosaic_cat_index(I,mosaic_i,J), 'landusef2',landusef2(i,mosaic_i,j)
+                  print*, 'TSK_mosaic', TSK_mosaic(i,mosaic_i,j), 'HFX_mosaic', HFX_mosaic(i,mosaic_i,j), &
+                          'LH_mosaic',LH_mosaic(i,mosaic_i,j),'GRDFLX_mosaic',GRDFLX_mosaic(i,mosaic_i,j)
+                  print*, 'ZNT_mosaic', ZNT_mosaic(i, mosaic_i,j), 'Z0_mosaic', Z0_mosaic(i,mosaic_i,j) 
+                  print*, 'FRC_URB2D',FRC_URB2D(I,J)
+                  print*, 'TS_URB',TS_URB2D(I,J),'T1',T1
+                  print*, 'SH_URB2D',SH_URB2D(I,J),'SHEAT',SHEAT
+                  print*, 'LH_URB',LH_URB2D(I,J),'ETA',ETA
+                  print*, 'TS_RUL2D',TS_RUL2D_mosaic(I,mosaic_i,J)
+                  
+            ENDIF
+#endif
+                  
+      !-----------------------------------------------------------------------
+      ! Now let's do the grid-averaging
+      !-----------------------------------------------------------------------
+      
+                  FAREA  = landusef2(i,mosaic_i,j)
+      
+                  TSK_mosaic_avg(i,j) = TSK_mosaic_avg(i,j) + (EMISS_mosaic(i,mosaic_i,j)*TSK_mosaic(i,mosaic_i,j)**4)*FAREA    ! conserve the longwave radiation
+                  
+                  QSFC_mosaic_avg(i,j) = QSFC_mosaic_avg(i,j) + QSFC_mosaic(i,mosaic_i,j)*FAREA
+                  CANWAT_mosaic_avg(i,j) = CANWAT_mosaic_avg(i,j) + CANWAT_mosaic(i,mosaic_i,j)*FAREA
+                  SNOW_mosaic_avg(i,j) = SNOW_mosaic_avg(i,j) + SNOW_mosaic(i,mosaic_i,j)*FAREA
+                  SNOWH_mosaic_avg(i,j) = SNOWH_mosaic_avg(i,j) + SNOWH_mosaic(i,mosaic_i,j)*FAREA
+                  SNOWC_mosaic_avg(i,j) = SNOWC_mosaic_avg(i,j) + SNOWC_mosaic(i,mosaic_i,j)*FAREA
+      
+                   DO NS=1,NSOIL
+      
+                 TSLB_mosaic_avg(i,NS,j)=TSLB_mosaic_avg(i,NS,j) + TSLB_mosaic(i,NS*mosaic_i,j)*FAREA
+                 SMOIS_mosaic_avg(i,NS,j)=SMOIS_mosaic_avg(i,NS,j) + SMOIS_mosaic(i,NS*mosaic_i,j)*FAREA
+                 SH2O_mosaic_avg(i,NS,j)=SH2O_mosaic_avg(i,NS,j) + SH2O_mosaic(i,NS*mosaic_i,j)*FAREA
+      
+                   ENDDO
+      
+                  FAREA_mosaic_avg(i,j)=FAREA_mosaic_avg(i,j)+FAREA
+                  HFX_mosaic_avg(i,j) = HFX_mosaic_avg(i,j) + HFX_mosaic(i,mosaic_i,j)*FAREA
+                  QFX_mosaic_avg(i,j) = QFX_mosaic_avg(i,j) + QFX_mosaic(i,mosaic_i,j)*FAREA
+                  LH_mosaic_avg(i,j) = LH_mosaic_avg(i,j) + LH_mosaic(i,mosaic_i,j)*FAREA
+                  GRDFLX_mosaic_avg(i,j)=GRDFLX_mosaic_avg(i,j)+GRDFLX_mosaic(i,mosaic_i,j)*FAREA
+                  
+                  ALBEDO_mosaic_avg(i,j)=ALBEDO_mosaic_avg(i,j)+ALBEDO_mosaic(i,mosaic_i,j)*FAREA
+                  ALBBCK_mosaic_avg(i,j)=ALBBCK_mosaic_avg(i,j)+ALBBCK_mosaic(i,mosaic_i,j)*FAREA
+                  EMISS_mosaic_avg(i,j)=EMISS_mosaic_avg(i,j)+EMISS_mosaic(i,mosaic_i,j)*FAREA
+                  EMBCK_mosaic_avg(i,j)=EMBCK_mosaic_avg(i,j)+EMBCK_mosaic(i,mosaic_i,j)*FAREA
+                  ZNT_mosaic_avg(i,j)=ZNT_mosaic_avg(i,j)+ALOG(ZNT_mosaic(i,mosaic_i,j))*FAREA
+                  Z0_mosaic_avg(i,j)=Z0_mosaic_avg(i,j)+ALOG(Z0_mosaic(i,mosaic_i,j))*FAREA
+       
+         ENDDO                     ! ENDDO FOR mosaic_i = 1, mosaic_cat
+      
+      !-----------------------------------------------------------------------
+      ! Now let's send the 3D values to the 2D variables that might be needed in other routines
+      !-----------------------------------------------------------------------
+      
+          IVGTYP(I,J)=IVGTYP_dominant(I,J)                                 ! the dominant vege category 
+          ALBEDO(i,j)=ALBEDO_mosaic_avg(i,j)
+          ALBBCK(i,j)=ALBBCK_mosaic_avg(i,j) 
+          EMISS(i,j)= EMISS_mosaic_avg(i,j) 
+          EMBCK(i,j)= EMBCK_mosaic_avg(i,j)  
+          ZNT(i,j)= EXP(ZNT_mosaic_avg(i,j)/FAREA_mosaic_avg(i,j))
+          Z0(i,j)= EXP(Z0_mosaic_avg(i,j)/FAREA_mosaic_avg(i,j))
+                                                                                       
+          TSK(i,j)=(TSK_mosaic_avg(I,J)/EMISS_mosaic_avg(I,J))**(0.25)                                  ! from 3D to 2D
+          QSFC(i,j)=QSFC_mosaic_avg(I,J)
+          CANWAT(i,j) = CANWAT_mosaic_avg(i,j)
+          SNOW(i,j) = SNOW_mosaic_avg(i,j)
+          SNOWH(i,j) = SNOWH_mosaic_avg(i,j)  
+          SNOWC(i,j) = SNOWC_mosaic_avg(i,j)    
+          
+          HFX(i,j) = HFX_mosaic_avg(i,j) 
+          QFX(i,j) = QFX_mosaic_avg(i,j) 
+          LH(i,j) = LH_mosaic_avg(i,j) 
+          GRDFLX(i,j)=GRDFLX_mosaic_avg(i,j)
+        
+                    DO NS=1,NSOIL
+      
+               TSLB(i,NS,j)=TSLB_mosaic_avg(i,NS,j)
+               SMOIS(i,NS,j)=SMOIS_mosaic_avg(i,NS,j)
+               SH2O(i,NS,j)=SH2O_mosaic_avg(i,NS,j)
+      
+                    ENDDO
+      
+      ELSE    ! This corresponds to IF ((sf_surface_mosaic == 1) .AND. ((XLAND(I,J)-1.5).LT.0.) .AND. (XICE(I,J) < XICE_THRESHOLD) ) THEN
+      
+      ! surface pressure
+              PSFC=P8w3D(i,1,j)
+      ! pressure in middle of lowest layer
+              SFCPRS=(P8W3D(I,KTS+1,j)+P8W3D(i,KTS,j))*0.5
+      ! convert from mixing ratio to specific humidity
+               Q2K=QV3D(i,1,j)/(1.0+QV3D(i,1,j))
+      !
+      !         Q2SAT=QGH(I,j)
+               Q2SAT=QGH(I,J)/(1.0+QGH(I,J))        ! Q2SAT is sp humidity
+      ! add check on myj=.true.
+      !        IF((Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
+              IF((myj).AND.(Q2K.GE.Q2SAT*TRESH).AND.Q2K.LT.QZ0(I,J))THEN
+                SATFLG=0.
+                CHKLOWQ(I,J)=0.
+              ELSE
+                SATFLG=1.0
+                CHKLOWQ(I,J)=1.
+              ENDIF
+      
+              SFCTMP=T3D(i,1,j)
+              ZLVL=0.5*DZ8W(i,1,j)
+      
+      !        TH2=SFCTMP+(0.0097545*ZLVL)
+      ! calculate SFCTH2 via Exner function vs lapse-rate (above)
+               APES=(1.E5/PSFC)**CAPA
+               APELM=(1.E5/SFCPRS)**CAPA
+               SFCTH2=SFCTMP*APELM
+               TH2=SFCTH2/APES
+      !
+               EMISSI = EMISS(I,J)
+               LWDN=GLW(I,J)*EMISSI
+      ! SOLDN is total incoming solar
+              SOLDN=SWDOWN(I,J)
+      ! GSW is net downward solar
+      !        SOLNET=GSW(I,J)
+      ! use mid-day albedo to determine net downward solar (no solar zenith angle correction)
+              SOLNET=SOLDN*(1.-ALBEDO(I,J))
+              PRCP=RAINBL(i,j)/DT
+              VEGTYP=IVGTYP(I,J)
+              SOILTYP=ISLTYP(I,J)
+              SHDFAC=VEGFRA(I,J)/100.
+              T1=TSK(I,J)
+              CHK=CHS(I,J)
+              SHMIN=SHDMIN(I,J)/100. !NEW
+              SHMAX=SHDMAX(I,J)/100. !NEW
+      ! convert snow water equivalent from mm to meter
+              SNEQV=SNOW(I,J)*0.001
+      ! snow depth in meters
+              SNOWHK=SNOWH(I,J)
+              SNCOVR=SNOWC(I,J)
+      
+      ! if "SR" present, set frac of frozen precip ("FFROZP") = snow-ratio ("SR", range:0-1)
+      ! SR from e.g. Ferrier microphysics
+      ! otherwise define from 1st atmos level temperature
+             IF(FRPCPN) THEN
+                FFROZP=SR(I,J)
+              ELSE
+                IF (SFCTMP <=  273.15) THEN
+                  FFROZP = 1.0
+      	  ELSE
+      	    FFROZP = 0.0
+      	  ENDIF
+              ENDIF
+      !***
+              IF((XLAND(I,J)-1.5).GE.0.)THEN                                  ! begining of land/sea if block
+      ! Open water points
+                TSK_RURAL(I,J)=TSK(I,J)
+                HFX_RURAL(I,J)=HFX(I,J)
+                QFX_RURAL(I,J)=QFX(I,J)
+                LH_RURAL(I,J)=LH(I,J)
+                EMISS_RURAL(I,J)=EMISS(I,J)
+                GRDFLX_RURAL(I,J)=GRDFLX(I,J)
+              ELSE
+      ! Land or sea-ice case
+      
+                IF (XICE(I,J) >= XICE_THRESHOLD) THEN
+                   ! Sea-ice point
+                   ICE = 1
+                ELSE IF ( VEGTYP == ISICE ) THEN
+                   ! Land-ice point
+                   ICE = -1
+                ELSE
+                   ! Neither sea ice or land ice.
+                   ICE=0
+                ENDIF
+                DQSDT2=Q2SAT*A23M4/(SFCTMP-A4)**2
+      
+                IF(SNOW(I,J).GT.0.0)THEN
+      ! snow on surface (use ice saturation properties)
+                  SFCTSNO=SFCTMP
+                  E2SAT=611.2*EXP(6174.*(1./273.15 - 1./SFCTSNO))
+                  Q2SATI=0.622*E2SAT/(SFCPRS-E2SAT)
+                  Q2SATI=Q2SATI/(1.0+Q2SATI)    ! spec. hum.
+                  IF (T1 .GT. 273.14) THEN
+      ! warm ground temps, weight the saturation between ice and water according to SNOWC
+                    Q2SAT=Q2SAT*(1.-SNOWC(I,J)) + Q2SATI*SNOWC(I,J)
+                    DQSDT2=DQSDT2*(1.-SNOWC(I,J)) + Q2SATI*6174./(SFCTSNO**2)*SNOWC(I,J)
+                  ELSE
+      ! cold ground temps, use ice saturation only
+                    Q2SAT=Q2SATI
+                    DQSDT2=Q2SATI*6174./(SFCTSNO**2)
+                  ENDIF
+      ! for snow cover fraction at 0 C, ground temp will not change, so DQSDT2 effectively zero
+                  IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0.)DQSDT2=DQSDT2*(1.-SNOWC(I,J))
+                ENDIF
+      
+                ! Land-ice or land points use the usual deep-soil temperature.
+                TBOT=TMN(I,J)
+      
+                IF(VEGTYP.EQ.25) SHDFAC=0.0000
+                IF(VEGTYP.EQ.26) SHDFAC=0.0000
+                IF(VEGTYP.EQ.27) SHDFAC=0.0000
+                IF(SOILTYP.EQ.14.AND.XICE(I,J).EQ.0.)THEN
+#if 0
+               IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT'
+               IF(IPRINT)PRINT*,i,j,'RESET SOIL in surfce.F'
+#endif
+                  SOILTYP=7
+                ENDIF
+                SNOALB1 = SNOALB(I,J)
+                CMC=CANWAT(I,J)
+      
+      !-------------------------------------------
+      !*** convert snow depth from mm to meter
+      !
+      !          IF(RDMAXALB) THEN
+      !           SNOALB=ALBMAX(I,J)*0.01
+      !         ELSE
+      !           SNOALB=MAXALB(IVGTPK)*0.01
+      !         ENDIF
+      
+      !        SNOALB1=0.80
+      !        SHMIN=0.00
+              ALBBRD=ALBBCK(I,J)
+              Z0BRD=Z0(I,J)
+              EMBRD=EMBCK(I,J)
+              SNOTIME1 = SNOTIME(I,J)
+              RIBB=RIB(I,J)
+      !FEI: temporaray arrays above need to be changed later by using SI
+      
+                DO NS=1,NSOIL
+                  SMC(NS)=SMOIS(I,NS,J)
+                  STC(NS)=TSLB(I,NS,J)                                          !STEMP
+                  SWC(NS)=SH2O(I,NS,J)
+                ENDDO
+      !
+                if ( (SNEQV.ne.0..AND.SNOWHK.eq.0.).or.(SNOWHK.le.SNEQV) )THEN
+                  SNOWHK= 5.*SNEQV
+                endif
+      !
+      
+      !Fei: urban. for urban surface, if calling UCM, redefine the natural surface in cities as
+      ! the "NATURAL" category in the VEGPARM.TBL
+      	
+      	   IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN
+                      IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+                        IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN
+      		 VEGTYP = NATURAL
+                       SHDFAC = SHDTBL(NATURAL)
+                       ALBEDOK =0.2         !  0.2
+                       ALBBRD  =0.2         !0.2
+                       EMISSI = 0.98                                 !for VEGTYP=5
+      		 IF ( FRC_URB2D(I,J) < 0.99 ) THEN
+                         if(sf_urban_physics.eq.1)then
+                 T1= ( TSK(I,J) -FRC_URB2D(I,J) * TS_URB2D (I,J) )/ (1-FRC_URB2D(I,J))
+                         elseif((sf_urban_physics.eq.2).OR.(sf_urban_physics.eq.3))then
+                      r1= (tsk(i,j)**4.)
+                      r2= frc_urb2d(i,j)*(ts_urb2d(i,j)**4.)
+                      r3= (1.-frc_urb2d(i,j))
+                      t1= ((r1-r2)/r3)**.25
+                         endif
+      	         ELSE
+      		 T1 = TSK(I,J)
+                       ENDIF
+                      ENDIF
+                 ELSE
+                       IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+                        IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN
+                        VEGTYP = ISURBAN
+                 	 ENDIF
+                 ENDIF
+#if 0
+                IF(IPRINT) THEN
+      !
+             print*, 'BEFORE SFLX, in Noahlsm_driver'
+             print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL,   &
+             'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
+              LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN,      &
+              'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K,   &
+               'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
+               'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
+               'SHMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB1',SNOALB1,'TBOT',&
+                TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
+                STC, 'SMC',SMC, 'SWC',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
+                'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT,      &
+                'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC,   &
+                'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
+                'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
+                'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
+                'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
+                'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS,  &
+                'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW,     &
+                'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
+                'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
+                 endif
+#endif
+      
+                IF (rdlai2d) THEN
+                   xlai = lai(i,j)
+                endif
+      
+          IF ( ICE == 1 ) THEN
+      
+             ! Sea-ice case
+      
+             DO NS = 1, NSOIL
+                SH2O(I,NS,J) = 1.0
+             ENDDO
+             LAI(I,J) = 0.01
+      
+             CYCLE ILOOP
+      
+          ELSEIF (ICE == 0) THEN
+      
+             ! Non-glacial land
+      
+             CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH,      &    !C
+                       LOCAL,                                           &    !L
+                       LUTYPE, SLTYPE,                                  &    !CL
+                       LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY,         &    !F
+                       DUMMY,DUMMY, DUMMY,                              &    !F PRCPRAIN not used
+                       TH2,Q2SAT,DQSDT2,                                &    !I
+                       VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX,      &    !I
+                       ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, &    !S
+                       CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,&    !H
+                       ETA,SHEAT, ETA_KINEMATIC,FDOWN,                  &    !O
+                       EC,EDIR,ET,ETT,ESNOW,DRIP,DEW,                   &    !O
+                       BETA,ETP,SSOIL,                                  &    !O
+                       FLX1,FLX2,FLX3,                                  &    !O
+      		 FLX4,FVB,FBUR,FGSN,UA_PHYS,                      &    !UA 
+                       SNOMLT,SNCOVR,                                   &    !O
+                       RUNOFF1,RUNOFF2,RUNOFF3,                         &    !O
+                       RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL,             &    !O
+                       SOILW,SOILM,Q1,SMAV,                             &    !D
+                       RDLAI2D,USEMONALB,                               &
+                       SNOTIME1,                                        &
+                       RIBB,                                            &
+                       SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT,               &
+                       sfcheadrt(i,j),                                   &    !I
+                       INFXSRT(i,j),ETPND1                          &    !O
+                       )
+      
+#ifdef WRF_HYDRO
+                       soldrain(i,j) = RUNOFF2*DT*1000.0
+#endif
+          ELSEIF (ICE == -1) THEN
+      
+             !
+             ! Set values that the LSM is expected to update,
+             ! but don't get updated for glacial points.
+             !
+             SOILM = 0.0 !BSINGH(PNNL)- SOILM is undefined for this case, it is used for diagnostics so setting it to zero
+             XLAI = 0.01 ! KWM Should this be Zero over land ice?  Does this value matter?
+             RUNOFF2 = 0.0
+             RUNOFF3 = 0.0
+             DO NS = 1, NSOIL
+                SWC(NS) = 1.0
+                SMC(NS) = 1.0
+                SMAV(NS) = 1.0
+             ENDDO
+             CALL SFLX_GLACIAL(I,J,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH,   &    !C
+                  &    LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,              &    !F
+                  &    TH2,Q2SAT,DQSDT2,                                &    !I
+                  &    ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, &    !S
+                  &    T1,STC(1:NSOIL),SNOWHK,SNEQV,ALBEDOK,CHK,        &    !H
+                  &    ETA,SHEAT,ETA_KINEMATIC,FDOWN,                   &    !O
+                  &    ESNOW,DEW,                                       &    !O
+                  &    ETP,SSOIL,                                       &    !O
+                  &    FLX1,FLX2,FLX3,                                  &    !O
+                  &    SNOMLT,SNCOVR,                                   &    !O
+                  &    RUNOFF1,                                         &    !O
+                  &    Q1,                                              &    !D
+                  &    SNOTIME1,                                        &
+                  &    RIBB)
+      
+          ENDIF
+      
+             lai(i,j) = xlai
+      
+#if 0
+                IF(IPRINT) THEN
+      
+             print*, 'AFTER SFLX, in Noahlsm_driver'
+             print*, 'ICE', ICE, 'DT',DT, 'ZLVL',ZLVL, 'NSOIL', NSOIL,   &
+             'SLDPTH', SLDPTH, 'LOCAL',LOCAL, 'LUTYPE',&
+              LUTYPE, 'SLTYPE',SLTYPE, 'LWDN',LWDN, 'SOLDN',SOLDN,      &
+              'SFCPRS',SFCPRS, 'PRCP',PRCP,'SFCTMP',SFCTMP,'Q2K',Q2K,   &
+               'TH2',TH2,'Q2SAT',Q2SAT,'DQSDT2',DQSDT2,'VEGTYP', VEGTYP,&
+                'SOILTYP',SOILTYP, 'SLOPETYP',SLOPETYP, 'SHDFAC',SHDFAC,&
+               'SHDMIN',SHMIN, 'ALBBRD',ALBBRD,'SNOALB',SNOALB1,'TBOT',&
+                TBOT, 'Z0BRD',Z0BRD, 'Z0K',Z0K, 'CMC',CMC, 'T1',T1,'STC',&
+                STC, 'SMC',SMC, 'SWc',SWC,'SNOWHK',SNOWHK,'SNEQV',SNEQV,&
+                'ALBEDOK',ALBEDOK,'CHK',CHK,'ETA',ETA,'SHEAT',SHEAT,      &
+                'ETA_KINEMATIC',ETA_KINEMATIC, 'FDOWN',FDOWN,'EC',EC,   &
+                'EDIR',EDIR,'ET',ET,'ETT',ETT,'ESNOW',ESNOW,'DRIP',DRIP,&
+                'DEW',DEW,'BETA',BETA,'ETP',ETP,'SSOIL',SSOIL,'FLX1',FLX1,&
+                'FLX2',FLX2,'FLX3',FLX3,'SNOMLT',SNOMLT,'SNCOVR',SNCOVR,&
+                'RUNOFF1',RUNOFF1,'RUNOFF2',RUNOFF2,'RUNOFF3',RUNOFF3, &
+                'RC',RC, 'PC',PC,'RSMIN',RSMIN,'XLAI',XLAI,'RCS',RCS,  &
+                'RCT',RCT,'RCQ',RCQ,'RCSOIL',RCSOIL,'SOILW',SOILW,     &
+                'SOILM',SOILM,'Q1',Q1,'SMCWLT',SMCWLT,'SMCDRY',SMCDRY,&
+                'SMCREF',SMCREF,'SMCMAX',SMCMAX,'NROOT',NROOT
+                 endif
+#endif
+      
+      !***  UPDATE STATE VARIABLES
+                CANWAT(I,J)=CMC
+                SNOW(I,J)=SNEQV*1000.
+      !          SNOWH(I,J)=SNOWHK*1000.
+                SNOWH(I,J)=SNOWHK                   ! SNOWHK in meters
+                ALBEDO(I,J)=ALBEDOK
+                ALB_RURAL(I,J)=ALBEDOK
+                ALBBCK(I,J)=ALBBRD
+                Z0(I,J)=Z0BRD
+                EMISS(I,J) = EMISSI
+                EMISS_RURAL(I,J) = EMISSI
+      ! Noah: activate time-varying roughness length (V3.3 Feb 2011)
+                ZNT(I,J)=Z0K
+                TSK(I,J)=T1
+                TSK_RURAL(I,J)=T1
+                HFX(I,J)=SHEAT
+                HFX_RURAL(I,J)=SHEAT
+      ! MEk Jul07 add potential evap accum
+              POTEVP(I,J)=POTEVP(I,J)+ETP*FDTW
+                QFX(I,J)=ETA_KINEMATIC
+                QFX_RURAL(I,J)=ETA_KINEMATIC
+      
+#ifdef WRF_HYDRO
+      !added by Wei Yu
+      !         QFX(I,J) = QFX(I,J) + ETPND1
+      !         ETA = ETA + ETPND1/2.501E6*dt
+      !end added by Wei Yu
+#endif
+      
+                LH(I,J)=ETA
+                LH_RURAL(I,J)=ETA
+                GRDFLX(I,J)=SSOIL
+                GRDFLX_RURAL(I,J)=SSOIL
+                SNOWC(I,J)=SNCOVR
+                CHS2(I,J)=CQS2(I,J)
+                SNOTIME(I,J) = SNOTIME1
+      !      prevent diagnostic ground q (q1) from being greater than qsat(tsk)
+      !      as happens over snow cover where the cqs2 value also becomes irrelevant
+      !      by setting cqs2=chs in this situation the 2m q should become just qv(k=1)
+                IF (Q1 .GT. QSFC(I,J)) THEN
+                  CQS2(I,J) = CHS(I,J)
+                ENDIF
+      !          QSFC(I,J)=Q1
+      ! Convert QSFC back to mixing ratio
+                 QSFC(I,J)= Q1/(1.0-Q1)
+      !
+                 ! QSFC_RURAL(I,J)= Q1/(1.0-Q1)
+      ! Calculate momentum flux from rural surface for use with multi-layer UCM (Martilli et al. 2002)
+      
+                DO 80 NS=1,NSOIL
+                 SMOIS(I,NS,J)=SMC(NS)
+                 TSLB(I,NS,J)=STC(NS)                                        !  STEMP
+                 SH2O(I,NS,J)=SWC(NS)
+         80     CONTINUE
+      !       ENDIF
+      
+              FLX4_2D(I,J)  = FLX4
+      	FVB_2D(I,J)   = FVB
+      	FBUR_2D(I,J)  = FBUR
+      	FGSN_2D(I,J)  = FGSN
+           !
+           ! Residual of surface energy balance equation terms
+           !
+      
+           IF ( UA_PHYS ) THEN
+               noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta &
+                    - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3 - flx4
+      
+           ELSE
+               noahres(i,j) = ( solnet + lwdn ) - sheat + ssoil - eta &
+                    - ( emissi * STBOLT * (t1**4) ) - flx1 - flx2 - flx3
+           ENDIF
+      
+              IF (SF_URBAN_PHYSICS == 1 ) THEN                                              ! Beginning of UCM CALL if block
+      !--------------------------------------
+      ! URBAN CANOPY MODEL START - urban
+      !--------------------------------------
+      ! Input variables lsm --> urban
+      
+                IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. &
+                    IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN
+      
+      ! Call urban
+      !
+                  UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial)
+      
+                  TA_URB    = SFCTMP           ! [K]
+                  QA_URB    = Q2K              ! [kg/kg]
+                  UA_URB    = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.)
+                  U1_URB    = U_PHY(I,1,J)
+                  V1_URB    = V_PHY(I,1,J)
+                  IF(UA_URB < 1.) UA_URB=1.    ! [m/s]
+                  SSG_URB   = SOLDN            ! [W/m/m]
+                  SSGD_URB  = 0.8*SOLDN        ! [W/m/m]
+                  SSGQ_URB  = SSG_URB-SSGD_URB ! [W/m/m]
+                  LLG_URB   = GLW(I,J)         ! [W/m/m]
+                  RAIN_URB  = RAINBL(I,J)      ! [mm]
+                  RHOO_URB  = SFCPRS / (287.04 * SFCTMP * (1.0+ 0.61 * Q2K)) ![kg/m/m/m]
+                  ZA_URB    = ZLVL             ! [m]
+                  DELT_URB  = DT               ! [sec]
+                  XLAT_URB  = XLAT_URB2D(I,J)  ! [deg]
+                  COSZ_URB  = COSZ_URB2D(I,J)  !
+                  OMG_URB   = OMG_URB2D(I,J)   !
+                  ZNT_URB   = ZNT(I,J)
+      
+                  LSOLAR_URB = .FALSE.
+      
+                  TR_URB = TR_URB2D(I,J)
+                  TB_URB = TB_URB2D(I,J)
+                  TG_URB = TG_URB2D(I,J)
+                  TC_URB = TC_URB2D(I,J)
+                  QC_URB = QC_URB2D(I,J)
+                  UC_URB = UC_URB2D(I,J)
+      
+                  DO K = 1,num_roof_layers
+                    TRL_URB(K) = TRL_URB3D(I,K,J)
+                  END DO
+                  DO K = 1,num_wall_layers
+                    TBL_URB(K) = TBL_URB3D(I,K,J)
+                  END DO
+                  DO K = 1,num_road_layers
+                    TGL_URB(K) = TGL_URB3D(I,K,J)
+                  END DO
+      
+                  XXXR_URB = XXXR_URB2D(I,J)
+                  XXXB_URB = XXXB_URB2D(I,J)
+                  XXXG_URB = XXXG_URB2D(I,J)
+                  XXXC_URB = XXXC_URB2D(I,J)
+      !
+      !      Limits to avoid dividing by small number
+                  if (CHS(I,J) < 1.0E-02) then
+                     CHS(I,J)  = 1.0E-02
+                  endif
+                  if (CHS2(I,J) < 1.0E-02) then
+                     CHS2(I,J)  = 1.0E-02
+                  endif
+                  if (CQS2(I,J) < 1.0E-02) then
+                     CQS2(I,J)  = 1.0E-02
+                  endif
+      !
+                  CHS_URB  = CHS(I,J)
+                  CHS2_URB = CHS2(I,J)
+                  IF (PRESENT(CMR_SFCDIF)) THEN
+                     CMR_URB = CMR_SFCDIF(I,J)
+                     CHR_URB = CHR_SFCDIF(I,J)
+                     CMC_URB = CMC_SFCDIF(I,J)
+                     CHC_URB = CHC_SFCDIF(I,J)
+                  ENDIF
+      
+      ! NUDAPT for SLUCM
+                  mh_urb = mh_urb2d(I,J)
+                  stdh_urb = stdh_urb2d(I,J)
+                  lp_urb = lp_urb2d(I,J)
+                  hgt_urb = hgt_urb2d(I,J)
+                  lf_urb = 0.0
+                  DO K = 1,4
+                    lf_urb(K)=lf_urb2d(I,K,J)
+                  ENDDO
+                  frc_urb = frc_urb2d(I,J)
+                  lb_urb = lb_urb2d(I,J)
+                  check = 0
+                  if (I.eq.73.and.J.eq.125)THEN
+                     check = 1
+                  end if
+      !
+      ! Call urban
+      
+                  CALL urban(LSOLAR_URB,                                      & ! I
+                             num_roof_layers,num_wall_layers,num_road_layers, & ! C
+                             DZR,DZB,DZG,                                     & ! C
+                             UTYPE_URB,TA_URB,QA_URB,UA_URB,U1_URB,V1_URB,SSG_URB, & ! I
+                             SSGD_URB,SSGQ_URB,LLG_URB,RAIN_URB,RHOO_URB,     & ! I
+                             ZA_URB,DECLIN_URB,COSZ_URB,OMG_URB,              & ! I
+                             XLAT_URB,DELT_URB,ZNT_URB,                       & ! I
+                             CHS_URB, CHS2_URB,                               & ! I
+                             TR_URB, TB_URB, TG_URB, TC_URB, QC_URB,UC_URB,   & ! H
+                             TRL_URB,TBL_URB,TGL_URB,                         & ! H
+                             XXXR_URB, XXXB_URB, XXXG_URB, XXXC_URB,          & ! H
+                             TS_URB,QS_URB,SH_URB,LH_URB,LH_KINEMATIC_URB,    & ! O
+                             SW_URB,ALB_URB,LW_URB,G_URB,RN_URB,PSIM_URB,PSIH_URB, & ! O
+                             GZ1OZ0_URB,                                      & !O
+                             CMR_URB, CHR_URB, CMC_URB, CHC_URB,              &
+                             U10_URB, V10_URB, TH2_URB, Q2_URB,               & ! O
+                             UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb,        & ! 0
+                             hgt_urb,frc_urb,lb_urb, check)                            !O
+      
+#if 0
+                IF(IPRINT) THEN
+      
+             print*, 'AFTER CALL URBAN'
+             print*,'num_roof_layers',num_roof_layers, 'num_wall_layers',  &
+              num_wall_layers,                                             &
+             'DZR',DZR,'DZB',DZB,'DZG',DZG,'UTYPE_URB',UTYPE_URB,'TA_URB', &
+              TA_URB,                                                      &
+              'QA_URB',QA_URB,'UA_URB',UA_URB,'U1_URB',U1_URB,'V1_URB',    &
+               V1_URB,                                                     &
+               'SSG_URB',SSG_URB,'SSGD_URB',SSGD_URB,'SSGQ_URB',SSGQ_URB,  &
+              'LLG_URB',LLG_URB,'RAIN_URB',RAIN_URB,'RHOO_URB',RHOO_URB,   &
+              'ZA_URB',ZA_URB, 'DECLIN_URB',DECLIN_URB,'COSZ_URB',COSZ_URB,&
+              'OMG_URB',OMG_URB,'XLAT_URB',XLAT_URB,'DELT_URB',DELT_URB,   &
+               'ZNT_URB',ZNT_URB,'TR_URB',TR_URB, 'TB_URB',TB_URB,'TG_URB',&
+               TG_URB,'TC_URB',TC_URB,'QC_URB',QC_URB,'TRL_URB',TRL_URB,   &
+                'TBL_URB',TBL_URB,'TGL_URB',TGL_URB,'XXXR_URB',XXXR_URB,   &
+               'XXXB_URB',XXXB_URB,'XXXG_URB',XXXG_URB,'XXXC_URB',XXXC_URB,&
+               'TS_URB',TS_URB,'QS_URB',QS_URB,'SH_URB',SH_URB,'LH_URB',   &
+               LH_URB, 'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'SW_URB',SW_URB,&
+               'ALB_URB',ALB_URB,'LW_URB',LW_URB,'G_URB',G_URB,'RN_URB',   &
+                RN_URB, 'PSIM_URB',PSIM_URB,'PSIH_URB',PSIH_URB,          &
+               'U10_URB',U10_URB,'V10_URB',V10_URB,'TH2_URB',TH2_URB,      &
+                'Q2_URB',Q2_URB,'CHS_URB',CHS_URB,'CHS2_URB',CHS2_URB
+                 endif
+#endif
+      
+                  TS_URB2D(I,J) = TS_URB
+      
+                  ALBEDO(I,J) = FRC_URB2D(I,J)*ALB_URB+(1-FRC_URB2D(I,J))*ALBEDOK   ![-]
+                  HFX(I,J) = FRC_URB2D(I,J)*SH_URB+(1-FRC_URB2D(I,J))*SHEAT         ![W/m/m]
+                  QFX(I,J) = FRC_URB2D(I,J)*LH_KINEMATIC_URB &
+                           + (1-FRC_URB2D(I,J))*ETA_KINEMATIC                ![kg/m/m/s]
+                  LH(I,J) = FRC_URB2D(I,J)*LH_URB+(1-FRC_URB2D(I,J))*ETA            ![W/m/m]
+                  GRDFLX(I,J) = FRC_URB2D(I,J)*G_URB+(1-FRC_URB2D(I,J))*SSOIL       ![W/m/m]
+                  TSK(I,J) = FRC_URB2D(I,J)*TS_URB+(1-FRC_URB2D(I,J))*T1            ![K]
+                  Q1 = FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*Q1            ![-]
+      ! Convert QSFC back to mixing ratio
+                  QSFC(I,J)= Q1/(1.0-Q1)
+                  UST(I,J)= FRC_URB2D(I,J)*UST_URB+(1-FRC_URB2D(I,J))*UST(I,J)      ![m/s]
+      
+#if 0
+          IF(IPRINT)THEN
+      
+          print*, ' FRC_URB2D', FRC_URB2D,                        &
+          'ALB_URB',ALB_URB, 'ALBEDOK',ALBEDOK, &
+          'ALBEDO(I,J)',  ALBEDO(I,J),                  &
+          'SH_URB',SH_URB,'SHEAT',SHEAT, 'HFX(I,J)',HFX(I,J),  &
+          'LH_KINEMATIC_URB',LH_KINEMATIC_URB,'ETA_KINEMATIC',  &
+           ETA_KINEMATIC, 'QFX(I,J)',QFX(I,J),                  &
+          'LH_URB',LH_URB, 'ETA',ETA, 'LH(I,J)',LH(I,J),        &
+          'G_URB',G_URB,'SSOIL',SSOIL,'GRDFLX(I,J)', GRDFLX(I,J),&
+          'TS_URB',TS_URB,'T1',T1,'TSK(I,J)',TSK(I,J),          &
+          'QS_URB',QS_URB,'Q1',Q1,'QSFC(I,J)',QSFC(I,J)
+           endif
+#endif
+      
+      ! Renew Urban State Varialbes
+      
+                  TR_URB2D(I,J) = TR_URB
+                  TB_URB2D(I,J) = TB_URB
+                  TG_URB2D(I,J) = TG_URB
+                  TC_URB2D(I,J) = TC_URB
+                  QC_URB2D(I,J) = QC_URB
+                  UC_URB2D(I,J) = UC_URB
+      
+                  DO K = 1,num_roof_layers
+                    TRL_URB3D(I,K,J) = TRL_URB(K)
+                  END DO
+                  DO K = 1,num_wall_layers
+                    TBL_URB3D(I,K,J) = TBL_URB(K)
+                  END DO
+                  DO K = 1,num_road_layers
+                    TGL_URB3D(I,K,J) = TGL_URB(K)
+                  END DO
+                  XXXR_URB2D(I,J) = XXXR_URB
+                  XXXB_URB2D(I,J) = XXXB_URB
+                  XXXG_URB2D(I,J) = XXXG_URB
+                  XXXC_URB2D(I,J) = XXXC_URB
+      
+                  SH_URB2D(I,J)    = SH_URB
+                  LH_URB2D(I,J)    = LH_URB
+                  G_URB2D(I,J)     = G_URB
+                  RN_URB2D(I,J)    = RN_URB
+                  PSIM_URB2D(I,J)  = PSIM_URB
+                  PSIH_URB2D(I,J)  = PSIH_URB
+                  GZ1OZ0_URB2D(I,J)= GZ1OZ0_URB
+                  U10_URB2D(I,J)   = U10_URB
+                  V10_URB2D(I,J)   = V10_URB
+                  TH2_URB2D(I,J)   = TH2_URB
+                  Q2_URB2D(I,J)    = Q2_URB
+                  UST_URB2D(I,J)   = UST_URB
+                  AKMS_URB2D(I,J)  = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J))
+                  IF (PRESENT(CMR_SFCDIF)) THEN
+                     CMR_SFCDIF(I,J) = CMR_URB
+                     CHR_SFCDIF(I,J) = CHR_URB
+                     CMC_SFCDIF(I,J) = CMC_URB
+                     CHC_SFCDIF(I,J) = CHC_URB
+                  ENDIF
+                END IF
+      
+               ENDIF                                   ! end of UCM CALL if block
+      !--------------------------------------
+      ! Urban Part End - urban
+      !--------------------------------------
+      
+      !***  DIAGNOSTICS
+                SMSTAV(I,J)=SOILW
+                SMSTOT(I,J)=SOILM*1000.
+                DO NS=1,NSOIL
+                SMCREL(I,NS,J)=SMAV(NS)
+                ENDDO
+      
+      !         Convert the water unit into mm
+                SFCRUNOFF(I,J)=SFCRUNOFF(I,J)+RUNOFF1*DT*1000.0
+                UDRUNOFF(I,J)=UDRUNOFF(I,J)+RUNOFF2*DT*1000.0
+      ! snow defined when fraction of frozen precip (FFROZP) > 0.5,
+                IF(FFROZP.GT.0.5)THEN
+                  ACSNOW(I,J)=ACSNOW(I,J)+PRCP*DT
+                ENDIF
+                IF(SNOW(I,J).GT.0.)THEN
+                  ACSNOM(I,J)=ACSNOM(I,J)+SNOMLT*1000.
+      ! accumulated snow-melt energy
+                  SNOPCX(I,J)=SNOPCX(I,J)-SNOMLT/FDTLIW
+                ENDIF
+      
+              ENDIF                                                           ! endif of land-sea test
+
+      ENDIF                                           ! ENDIF FOR MOSAIC DANLI  ! This corresponds to IF ((sf_surface_mosaic == 1) .AND. ((XLAND(I,J)-1.5).LT.0.) .AND. (XICE(I,J) < XICE_THRESHOLD) ) THEN
+
+      ENDDO ILOOP                                                       ! of I loop
+   ENDDO JLOOP                                                          ! of J loop   
+       
+!------------------------------------------------------
+   END SUBROUTINE lsm_mosaic
+!------------------------------------------------------
+!===========================================================================
+!
+! subroutine lsm_mosaic_init: initialization of mosaic state variables
+!
+!===========================================================================   
+  
+   SUBROUTINE lsm_mosaic_init(IVGTYP,ISWATER,ISURBAN,ISICE, XLAND, XICE,fractional_seaice, &
+                  TSK,TSLB,SMOIS,SH2O,SNOW,SNOWC,SNOWH,CANWAT,    &
+                  ids,ide, jds,jde, kds,kde,                      &
+                  ims,ime, jms,jme, kms,kme,                      &
+                  its,ite, jts,jte, kts,kte, restart,             &
+                  landusef,landusef2,NLCAT,num_soil_layers        & 
+                  ,sf_surface_mosaic, mosaic_cat                  & 
+                  ,mosaic_cat_index                               &   
+                  ,TSK_mosaic,TSLB_mosaic                         &
+                  ,SMOIS_mosaic,SH2O_mosaic                       & 
+                  ,CANWAT_mosaic,SNOW_mosaic                      &
+                  ,SNOWH_mosaic,SNOWC_mosaic                      &
+                  ,ALBEDO,ALBBCK, EMISS, EMBCK,Z0                 &  !danli  
+                  ,ALBEDO_mosaic,ALBBCK_mosaic, EMISS_mosaic      &  !danli
+                  ,EMBCK_mosaic, ZNT_mosaic, Z0_mosaic            &  !danli
+                  ,TR_URB2D_mosaic,TB_URB2D_mosaic                &  !danli mosaic 
+                  ,TG_URB2D_mosaic,TC_URB2D_mosaic                &  !danli mosaic 
+                  ,QC_URB2D_mosaic                                &  !danli mosaic                  
+                  ,TRL_URB3D_mosaic,TBL_URB3D_mosaic              &  !danli mosaic 
+                  ,TGL_URB3D_mosaic                               &  !danli mosaic 
+                  ,SH_URB2D_mosaic,LH_URB2D_mosaic                &  !danli mosaic 
+                  ,G_URB2D_mosaic,RN_URB2D_mosaic                 &  !danli mosaic 
+                  ,TS_URB2D_mosaic                                &  !danli mosaic 
+                  ,TS_RUL2D_mosaic                                &  !danli mosaic                    
+                   ) 
+  
+    INTEGER,  INTENT(IN)   ::       ids,ide, jds,jde, kds,kde,  &
+                                    ims,ime, jms,jme, kms,kme,  &
+                                    its,ite, jts,jte, kts,kte 
+
+   INTEGER, INTENT(IN)       ::     NLCAT, num_soil_layers, ISWATER,ISURBAN, ISICE, fractional_seaice
+
+   LOGICAL , INTENT(IN) :: restart 
+
+!   REAL,    DIMENSION( num_soil_layers), INTENT(INOUT) :: ZS, DZS
+
+   REAL,    DIMENSION( ims:ime, num_soil_layers, jms:jme )    , &
+            INTENT(IN)    ::                             SMOIS, &  !Total soil moisture
+                                                         SH2O,  &  !liquid soil moisture       
+                                                         TSLB      !STEMP
+
+   REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+            INTENT(IN)    ::                           SNOW, &
+                                                         SNOWH, &
+                                                         SNOWC, &
+                                                        CANWAT, &
+                                                        TSK, XICE, XLAND         
+  
+  INTEGER, INTENT(IN) :: sf_surface_mosaic  
+  INTEGER, INTENT(IN) :: mosaic_cat
+  INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(IN) :: IVGTYP
+  REAL, DIMENSION( ims:ime, NLCAT, jms:jme ) , INTENT(IN)::   LANDUSEF
+  REAL, DIMENSION( ims:ime, NLCAT, jms:jme ) , INTENT(INOUT)::   LANDUSEF2
+  
+  INTEGER, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(INOUT) :: mosaic_cat_index 
+
+  REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT)::   &
+        TSK_mosaic, CANWAT_mosaic, SNOW_mosaic,SNOWH_mosaic, SNOWC_mosaic 
+  REAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), OPTIONAL, INTENT(INOUT)::   &
+        TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic
+  
+  REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(IN)::   ALBEDO, ALBBCK, EMISS, EMBCK, Z0 
+  REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT)::   &
+        ALBEDO_mosaic,ALBBCK_mosaic, EMISS_mosaic, EMBCK_mosaic, ZNT_mosaic, Z0_mosaic
+
+  REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT)::   &
+        TR_URB2D_mosaic, TB_URB2D_mosaic, TG_URB2D_mosaic, TC_URB2D_mosaic,QC_URB2D_mosaic,  &
+        SH_URB2D_mosaic,LH_URB2D_mosaic,G_URB2D_mosaic,RN_URB2D_mosaic,TS_URB2D_mosaic, TS_RUL2D_mosaic  
+                    
+  REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TRL_URB3D_mosaic
+  REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TBL_URB3D_mosaic
+  REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TGL_URB3D_mosaic    
+
+  INTEGER :: ij,i,j,mosaic_i,LastSwap,NumPairs,soil_k, Temp2,Temp5,Temp7, ICE,temp_index
+  REAL :: Temp, Temp3,Temp4,Temp6,xice_threshold
+  LOGICAL :: IPRINT
+  CHARACTER(len=256) :: message_text
+
+  IPRINT=.false.
+
+  if ( fractional_seaice == 0 ) then
+     xice_threshold = 0.5
+  else if ( fractional_seaice == 1 ) then
+     xice_threshold = 0.02
+  endif
+
+    IF(.not.restart)THEN
+  !===========================================================================   
+  ! CHOOSE THE TILES
+  !===========================================================================  
+  
+  itf=min0(ite,ide-1)
+  jtf=min0(jte,jde-1)
+
+  ! simple test
+   
+  DO i = its,itf
+     DO j = jts,jtf 
+        IF ((xland(i,j).LT. 1.5 ) .AND. (IVGTYP(i,j) .EQ. ISWATER)) THEN
+           PRINT*, 'BEFORE MOSAIC_INIT'
+           CALL wrf_message("BEFORE MOSAIC_INIT")
+           WRITE(message_text,fmt='(a,2I6,2F8.2,2I6)') 'I,J,xland,xice,mosaic_cat_index,ivgtyp = ', &
+                 I,J,xland(i,j),xice(i,j),mosaic_cat_index(I,1,J),IVGTYP(i,j)
+           CALL wrf_message(message_text)
+        ENDIF
+     ENDDO
+  ENDDO
+
+     DO i = its,itf
+        DO j = jts,jtf
+           DO mosaic_i=1,NLCAT
+              LANDUSEF2(i,mosaic_i,j)=LANDUSEF(i,mosaic_i,j)
+              mosaic_cat_index(i,mosaic_i,j)=mosaic_i
+           ENDDO
+        ENDDO
+     ENDDO
+
+     DO i = its,itf
+        DO j = jts,jtf
+          
+          NumPairs=NLCAT-1
+          
+          DO 
+               IF (NumPairs == 0) EXIT
+                   LastSwap = 1
+          DO  mosaic_i=1, NumPairs
+            IF(LANDUSEF2(i,mosaic_i, j) < LANDUSEF2(i,mosaic_i+1, j)  ) THEN
+               Temp = LANDUSEF2(i,mosaic_i, j)
+               LANDUSEF2(i,mosaic_i, j)=LANDUSEF2(i,mosaic_i+1, j)
+               LANDUSEF2(i,mosaic_i+1, j)=Temp            
+               LastSwap = mosaic_i 
+            
+               Temp2 =  mosaic_cat_index(i,mosaic_i,j)
+               mosaic_cat_index(i,mosaic_i,j)=mosaic_cat_index(i,mosaic_i+1,j)
+               mosaic_cat_index(i,mosaic_i+1,j)=Temp2
+            ENDIF
+          ENDDO
+               NumPairs = LastSwap - 1
+          ENDDO
+          
+        ENDDO
+      ENDDO
+
+  !===========================================================================   
+  ! For non-seaice grids, eliminate the seaice-tiles
+  !=========================================================================== 
+
+     DO i = its,itf
+        DO j = jts,jtf
+        
+         IF   (XLAND(I,J).LT.1.5)  THEN
+
+             ICE = 0
+                 IF( XICE(I,J).GE. XICE_THRESHOLD ) THEN
+                   WRITE (message_text,fmt='(a,2I5)') 'sea-ice at point, I and J = ', i,j
+                   CALL wrf_message(message_text)
+                 ICE = 1
+                 ENDIF   
+           
+          IF (ICE == 1)   Then         ! sea-ice case , eliminate sea-ice if they are not the dominant ones
+
+          IF (IVGTYP(i,j) == isice)  THEN    ! if this grid cell is dominanted by ice, then do nothing
+
+          ELSE
+
+                DO mosaic_i=2,mosaic_cat
+                   IF (mosaic_cat_index(i,mosaic_i,j) == isice ) THEN
+                       Temp4=LANDUSEF2(i,mosaic_i,j)
+                       Temp5=mosaic_cat_index(i,mosaic_i,j)
+
+                       LANDUSEF2(i,mosaic_i:NLCAT-1,j)=LANDUSEF2(i,mosaic_i+1:NLCAT,j)                       
+                       mosaic_cat_index(i,mosaic_i:NLCAT-1,j)=mosaic_cat_index(i,mosaic_i+1:NLCAT,j)
+
+                       LANDUSEF2(i,NLCAT,j)=Temp4
+                       mosaic_cat_index(i,NLCAT,j)=Temp5
+                   ENDIF 
+                 ENDDO
+
+          ENDIF   ! for (IVGTYP(i,j) == isice )
+          
+          ELSEIF (ICE ==0)  THEN
+          
+          IF ((mosaic_cat_index(I,1,J) .EQ. ISWATER)) THEN    
+          
+          ! xland < 1.5 but the dominant land use category based on our calculation is water
+	             
+           IF (IVGTYP(i,j) .EQ. ISWATER) THEN  
+           
+           ! xland < 1.5 but the dominant land use category based on the geogrid calculation is water, this must be wrong
+           
+              CALL wrf_message("IN MOSAIC_INIT")
+              WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j) 
+              CALL wrf_message(message_text)
+              CALL wrf_message("xland < 1.5 but the dominant land use category based on our calculation is water."//&
+                   "In addition, the dominant land use category based on the geogrid calculation is water, this must be wrong")
+           
+           ENDIF  ! for (IVGTYP(i,j) .EQ. ISWATER)
+           
+           IF (IVGTYP(i,j) .NE. ISWATER) THEN 
+           
+           ! xland < 1.5,   the dominant land use category based on our calculation is water, but based on the geogrid calculation is not water, which might be due to the inconsistence between land use data and land-sea mask
+           
+	       Temp4=LANDUSEF2(i,1,j)
+	       Temp5=mosaic_cat_index(i,1,j)
+	  
+	       LANDUSEF2(i,1:NLCAT-1,j)=LANDUSEF2(i,2:NLCAT,j)                       
+	       mosaic_cat_index(i,1:NLCAT-1,j)=mosaic_cat_index(i,2:NLCAT,j)
+	  
+	       LANDUSEF2(i,NLCAT,j)=Temp4
+	       mosaic_cat_index(i,NLCAT,j)=Temp5
+	             
+              CALL wrf_message("IN MOSAIC_INIT")
+              WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j) 
+              CALL wrf_message(message_text)
+              CALL wrf_message("xland < 1.5 but the dominant land use category based on our calculation is water."//&
+                   "this is fine as long as we change our calculation so that the dominant land use category is"//&
+                   "stwiched back to not water.")
+              WRITE(message_text,fmt='(a,2I6)') 'land use category has been switched, before and after values are ', &
+                   temp5,mosaic_cat_index(i,1,j)
+              CALL wrf_message(message_text)
+              WRITE(message_text,fmt='(a,2I6)') 'new dominant and second dominant cat are ', mosaic_cat_index(i,1,j),mosaic_cat_index(i,2,j)
+              CALL wrf_message(message_text)
+	             
+           ENDIF  ! for (IVGTYP(i,j) .NE. ISWATER)
+          
+           ELSE    !  for (mosaic_cat_index(I,1,J) .EQ. ISWATER)
+           
+                     DO mosaic_i=2,mosaic_cat
+	                IF (mosaic_cat_index(i,mosaic_i,j) == iswater ) THEN
+	                   Temp4=LANDUSEF2(i,mosaic_i,j)
+	                   Temp5=mosaic_cat_index(i,mosaic_i,j)
+	   
+	                   LANDUSEF2(i,mosaic_i:NLCAT-1,j)=LANDUSEF2(i,mosaic_i+1:NLCAT,j)                       
+	                   mosaic_cat_index(i,mosaic_i:NLCAT-1,j)=mosaic_cat_index(i,mosaic_i+1:NLCAT,j)
+	  
+	                   LANDUSEF2(i,NLCAT,j)=Temp4
+	                   mosaic_cat_index(i,NLCAT,j)=Temp5
+	                ENDIF 
+	              ENDDO
+             
+           ENDIF !  for (mosaic_cat_index(I,1,J) .EQ. ISWATER)
+             
+          ENDIF  !  for ICE == 1
+          
+      ELSE  ! FOR (XLAND(I,J).LT.1.5)
+      
+                 ICE = 0
+      
+                     IF( XICE(I,J).GE. XICE_THRESHOLD ) THEN
+                       WRITE (message_text,fmt='(a,2I6)') 'sea-ice at water point, I and J = ', i,j
+                       CALL wrf_message(message_text)
+                       ICE = 1
+                     ENDIF  
+      
+           IF ((mosaic_cat_index(I,1,J) .NE. ISWATER)) THEN    
+                
+                ! xland > 1.5 and the dominant land use category based on our calculation is not water
+      	             
+                 IF (IVGTYP(i,j) .NE. ISWATER) THEN  
+                 
+                 ! xland > 1.5 but the dominant land use category based on the geogrid calculation is not water, this must be wrong
+                 CALL wrf_message("IN MOSAIC_INIT")
+                 WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j)
+                 CALL wrf_message(message_text)
+                 CALL wrf_message("xland > 1.5 but the dominant land use category based on our calculation is not water."// &
+                      "in addition, the dominant land use category based on the geogrid calculation is not water,"//  &
+                      "this must be wrong.")
+                 ENDIF  ! for (IVGTYP(i,j) .NE. ISWATER)
+                 
+                 IF (IVGTYP(i,j) .EQ. ISWATER) THEN 
+                 
+                 ! xland > 1.5,   the dominant land use category based on our calculation is not water, but based on the geogrid calculation is water, which might be due to the inconsistence between land use data and land-sea mask
+
+                 CALL wrf_message("IN MOSAIC_INIT")
+                 WRITE(message_text,fmt='(a,3I6,2F8.2)') 'I,J,IVGTYP,XLAND,XICE = ',I,J,IVGTYP(I,J),xland(i,j),xice(i,j)
+                 CALL wrf_message(message_text)
+                 CALL wrf_message("xland > 1.5 but the dominant land use category based on our calculation is not water."// &
+                      "however, the dominant land use category based on the geogrid calculation is water")
+                 CALL wrf_message("This is fine. We do not need to do anyting because in the noaddrv, "//&
+                      "we use xland as a criterion for whether using"// &
+                      "mosaic or not when xland > 1.5, no mosaic will be used anyway")
+      	             
+                 ENDIF  ! for (IVGTYP(i,j) .NE. ISWATER)
+                
+           ENDIF !  for (mosaic_cat_index(I,1,J) .NE. ISWATER)
+      
+        ENDIF  ! FOR (XLAND(I,J).LT.1.5)
+
+          ENDDO
+      ENDDO
+      
+  !===========================================================================   
+  ! normalize
+  !=========================================================================== 
+
+     DO i = its,itf
+        DO j = jts,jtf
+
+          Temp6=0
+
+            DO mosaic_i=1,mosaic_cat
+               Temp6=Temp6+LANDUSEF2(i,mosaic_i,j)
+            ENDDO
+            
+            if (Temp6 .LT. 1e-5)  then
+            
+            Temp6 = 1e-5
+            WRITE (message_text,fmt='(a,e8.1)') 'the total land surface fraction is less than ', temp6
+            CALL wrf_message(message_text)
+            WRITE (message_text,fmt='(a,2I6,4F8.2)') 'some landusef values at i,j are ', &
+                 i,j,landusef2(i,1,j),landusef2(i,2,j),landusef2(i,3,j),landusef2(i,4,j)
+            CALL wrf_message(message_text)
+            WRITE (message_text,fmt='(a,2I6,3I6)') 'some mosaic cat values at i,j are ', &
+                 i,j,mosaic_cat_index(i,1,j),mosaic_cat_index(i,2,j),mosaic_cat_index(i,3,j) 
+            CALL wrf_message(message_text)
+            
+            endif
+
+            LANDUSEF2(i,1:mosaic_cat, j)=LANDUSEF2(i,1:mosaic_cat,j)*(1/Temp6)
+
+          ENDDO
+      ENDDO
+      
+  !===========================================================================   
+  ! initilize the variables
+  !===========================================================================   
+
+     DO i = its,itf
+        DO j = jts,jtf
+    
+             DO mosaic_i=1,mosaic_cat
+        
+            TSK_mosaic(i,mosaic_i,j)=TSK(i,j)          
+            CANWAT_mosaic(i,mosaic_i,j)=CANWAT(i,j) 
+            SNOW_mosaic(i,mosaic_i,j)=SNOW(i,j) 
+            SNOWH_mosaic(i,mosaic_i,j)=SNOWH(i,j)  
+            SNOWC_mosaic(i,mosaic_i,j)=SNOWC(i,j) 
+
+            ALBEDO_mosaic(i,mosaic_i,j)=ALBEDO(i,j)
+            ALBBCK_mosaic(i,mosaic_i,j)=ALBBCK(i,j)
+            EMISS_mosaic(i,mosaic_i,j)=EMISS(i,j) 
+            EMBCK_mosaic(i,mosaic_i,j)=EMBCK(i,j) 
+            ZNT_mosaic(i,mosaic_i,j)=Z0(i,j)
+            Z0_mosaic(i,mosaic_i,j)=Z0(i,j)              
+  
+              DO soil_k=1,num_soil_layers 
+  
+            TSLB_mosaic(i,num_soil_layers*(mosaic_i-1)+soil_k,j)=TSLB(i,soil_k,j)
+            SMOIS_mosaic(i,num_soil_layers*(mosaic_i-1)+soil_k,j)=SMOIS(i,soil_k,j)
+            SH2O_mosaic(i,num_soil_layers*(mosaic_i-1)+soil_k,j)=SH2O(i,soil_k,j)  
+          
+              ENDDO
+           
+           TR_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j)   
+           TB_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j)   
+           TG_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j)   
+           TC_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j)   
+           TS_URB2D_mosaic(i,mosaic_i,j)=TSK(i,j)   
+           TS_RUL2D_mosaic(i,mosaic_i,j)=TSK(i,j)   
+           QC_URB2D_mosaic(i,mosaic_i,j)=0.01
+           SH_URB2D_mosaic(i,mosaic_i,j)=0
+           LH_URB2D_mosaic(i,mosaic_i,j)=0
+           G_URB2D_mosaic(i,mosaic_i,j)=0
+           RN_URB2D_mosaic(i,mosaic_i,j)=0
+          
+          TRL_URB3D_mosaic(I,4*(mosaic_i-1)+1,J)=TSLB(I,1,J)+0.
+          TRL_URB3D_mosaic(I,4*(mosaic_i-1)+2,J)=0.5*(TSLB(I,1,J)+TSLB(I,2,J))
+          TRL_URB3D_mosaic(I,4*(mosaic_i-1)+3,J)=TSLB(I,2,J)+0.
+          TRL_URB3D_mosaic(I,4*(mosaic_i-1)+4,J)=TSLB(I,2,J)+(TSLB(I,3,J)-TSLB(I,2,J))*0.29
+
+          TBL_URB3D_mosaic(I,4*(mosaic_i-1)+1,J)=TSLB(I,1,J)+0.
+          TBL_URB3D_mosaic(I,4*(mosaic_i-1)+2,J)=0.5*(TSLB(I,1,J)+TSLB(I,2,J))
+          TBL_URB3D_mosaic(I,4*(mosaic_i-1)+3,J)=TSLB(I,2,J)+0.
+          TBL_URB3D_mosaic(I,4*(mosaic_i-1)+4,J)=TSLB(I,2,J)+(TSLB(I,3,J)-TSLB(I,2,J))*0.29           
+                    
+          TGL_URB3D_mosaic(I,4*(mosaic_i-1)+1,J)=TSLB(I,1,J)
+          TGL_URB3D_mosaic(I,4*(mosaic_i-1)+2,J)=TSLB(I,2,J)
+          TGL_URB3D_mosaic(I,4*(mosaic_i-1)+3,J)=TSLB(I,3,J)
+          TGL_URB3D_mosaic(I,4*(mosaic_i-1)+4,J)=TSLB(I,4,J)
+           
+            ENDDO
+          ENDDO
+      ENDDO
+
+   ! simple test
+   
+       DO i = its,itf
+        DO j = jts,jtf 
+   
+           IF ((xland(i,j).LT. 1.5 ) .AND. (mosaic_cat_index(I,1,J) .EQ. ISWATER)) THEN
+             CALL wrf_message("After MOSAIC_INIT")
+             WRITE (message_text,fmt='(a,2I6,2F8.2,2I6)') 'weird xland,xice,mosaic_cat_index and ivgtyp at I,J = ', &
+                i,j,xland(i,j),xice(i,j),mosaic_cat_index(I,1,J),IVGTYP(i,j)
+             CALL wrf_message(message_text)
+           ENDIF
+           
+        ENDDO
+      ENDDO
+      
+ ENDIF      !  for not restart
+      
+!--------------------------------      
+  END SUBROUTINE lsm_mosaic_init  
+!--------------------------------  
+
 END MODULE module_sf_noahdrv
diff --git a/wrfv2_fire/phys/module_sf_noahlsm.F b/wrfv2_fire/phys/module_sf_noahlsm.F
index 9d6d9e50..d490f920 100644
--- a/wrfv2_fire/phys/module_sf_noahlsm.F
+++ b/wrfv2_fire/phys/module_sf_noahlsm.F
@@ -197,7 +197,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, &    !C
 !   ETA        ACTUAL LATENT HEAT FLUX (W m-2: NEGATIVE, IF UP FROM
 !              SURFACE)
 !  ETA_KINEMATIC atctual latent heat flux in Kg m-2 s-1
-!   SHEAT      SENSIBLE HEAT FLUX (W M-2: NEGATIVE, IF UPWARD FROM
+!   SHEAT      SENSIBLE HEAT FLUX (W M-2: POSITIVE, IF UPWARD FROM
 !              SURFACE)
 !   FDOWN      Radiation forcing at the surface (W m-2) = SOLDN*(1-alb)+LWDN
 ! ----------------------------------------------------------------------
diff --git a/wrfv2_fire/phys/module_sf_noahmp_glacier.F b/wrfv2_fire/phys/module_sf_noahmp_glacier.F
index af68dded..c8b12a82 100644
--- a/wrfv2_fire/phys/module_sf_noahmp_glacier.F
+++ b/wrfv2_fire/phys/module_sf_noahmp_glacier.F
@@ -251,6 +251,8 @@ SUBROUTINE NOAHMP_GLACIER (&
   REAL                                           :: BEG_WB !beginning water for error check
   REAL                                           :: ZBOT = -8.0 
 
+  CHARACTER*256 message
+
 ! --------------------------------------------------------------------------------------------------
 ! re-process atmospheric forcing
 
@@ -297,12 +299,22 @@ SUBROUTINE NOAHMP_GLACIER (&
                          DZSNSO ,SH2O   ,SICE   ,PONDING,ZSNSO  ,         & !inout
                          RUNSRF ,RUNSUB ,QSNOW  ,PONDING1       ,PONDING2,QSNBOT,FPICE)  !out
 
+     IF(MAXVAL(SICE) < 0.0001) THEN
+       WRITE(message,*) "GLACIER HAS MELTED AT:",ILOC,JLOC," ARE YOU SURE THIS SHOULD BE A GLACIER POINT?"
+       CALL wrf_debug(10,TRIM(message))
+     END IF
+     
 ! water and energy balance check
 
      CALL ERROR_GLACIER (ILOC   ,JLOC   ,SWDOWN ,FSA    ,FSR    ,FIRA   , &
                          FSH    ,FGEV   ,SSOIL  ,SAG    ,PRCP   ,EDIR   , &
 		         RUNSRF ,RUNSUB ,SNEQV  ,DT     ,BEG_WB )
 
+    IF(SNOWH <= 1.E-6 .OR. SNEQV <= 1.E-3) THEN
+     SNOWH = 0.0
+     SNEQV = 0.0
+    END IF
+
     IF(SWDOWN.NE.0.) THEN
       ALBEDO = FSR / SWDOWN
     ELSE
@@ -345,7 +357,8 @@ SUBROUTINE ATM_GLACIER (SFCPRS ,SFCTMP ,Q2     ,SOLDN  ,COSZ   ,THAIR  , &
 
        PAIR   = SFCPRS                   ! atm bottom level pressure (pa)
        THAIR  = SFCTMP * (SFCPRS/PAIR)**(RAIR/CPAIR) 
-       QAIR   = Q2 / (1.0+Q2)           ! mixing ratio to specific humidity [kg/kg]
+!       QAIR   = Q2 / (1.0+Q2)           ! mixing ratio to specific humidity [kg/kg]
+       QAIR   = Q2                       ! In WRF, driver converts to specific humidity
 
        EAIR   = QAIR*SFCPRS / (0.622+0.378*QAIR)
        RHOAIR = (SFCPRS-0.378*EAIR) / (RAIR*SFCTMP)
@@ -495,19 +508,15 @@ SUBROUTINE ENERGY_GLACIER (NSNOW  ,NSOIL  ,ISNOW  ,DT     ,QSNOW  ,RHOAIR , & !i
 
 ! set psychrometric constant
 
-     IF (SFCTMP .GT. TFRZ) THEN
-        LATHEA = HVAP
-     ELSE
-        LATHEA = HSUB
-     END IF
+     LATHEA = HSUB
      GAMMA = CPAIR*SFCPRS/(0.622*LATHEA)
 
 ! Surface temperatures of the ground and energy fluxes
 
     CALL GLACIER_FLUX (NSOIL   ,NSNOW   ,EMG     ,ISNOW   ,DF      ,DZSNSO  ,Z0MG    , & !in
                        ZLVL    ,ZPD     ,QAIR    ,SFCTMP  ,RHOAIR  ,SFCPRS  , & !in
-		       UR      ,GAMMA   ,RSURF   ,LWDN    ,RHSUR   , & !in
-		       EAIR    ,STC     ,SAG     ,SNOWH   ,LATHEA  , & !in
+		       UR      ,GAMMA   ,RSURF   ,LWDN    ,RHSUR   ,SMC     , & !in
+		       EAIR    ,STC     ,SAG     ,SNOWH   ,LATHEA  ,SH2O    , & !in
 		       CM      ,CH      ,TG      ,QSFC    ,          & !inout
 		       FIRA    ,FSH     ,FGEV    ,SSOIL   ,          & !out
 		       T2M     ,Q2E     ,CH2B)                         !out 
@@ -601,7 +610,7 @@ SUBROUTINE THERMOPROP_GLACIER (NSOIL   ,NSNOW   ,ISNOW   ,DZSNSO  , & !in
        DO IZ2 = 1, IZ-1
          ZMID = ZMID + DZSNSO(IZ2)
        END DO
-       HCPCT(IZ) = 1.E6 * ( 0.8194 - 0.1309*ZMID )
+       HCPCT(IZ) = 1.E6 * ( 0.8194 + 0.1309*ZMID )
        DF(IZ)    = 0.32333 + ( 0.10073 * ZMID )
     END DO
        
@@ -805,7 +814,7 @@ SUBROUTINE SNOW_AGE_GLACIER (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE)
    ELSE IF (SNEQV.GT.800.) THEN
           TAUSS = 0.
    ELSE
-          TAUSS = 0.
+!          TAUSS = 0.
           DELA0 = 1.E-6*DT
           ARG   = 5.E3*(1./TFRZ-1./TG)
           AGE1  = EXP(ARG)
@@ -919,8 +928,8 @@ END SUBROUTINE SNOWALB_CLASS_GLACIER
 ! ==================================================================================================
   SUBROUTINE GLACIER_FLUX (NSOIL   ,NSNOW   ,EMG     ,ISNOW   ,DF      ,DZSNSO  ,Z0M     , & !in
                            ZLVL    ,ZPD     ,QAIR    ,SFCTMP  ,RHOAIR  ,SFCPRS  , & !in
-			   UR      ,GAMMA   ,RSURF   ,LWDN    ,RHSUR   , & !in
-			   EAIR    ,STC     ,SAG     ,SNOWH   ,LATHEA  , & !in
+			   UR      ,GAMMA   ,RSURF   ,LWDN    ,RHSUR   ,SMC     , & !in
+			   EAIR    ,STC     ,SAG     ,SNOWH   ,LATHEA  ,SH2O    , & !in
                            CM      ,CH      ,TGB     ,QSFC    ,          & !inout
                            IRB     ,SHB     ,EVB     ,GHB     ,          & !out
                            T2MB    ,Q2B     ,EHB2)                         !out 
@@ -957,6 +966,8 @@ SUBROUTINE GLACIER_FLUX (NSOIL   ,NSNOW   ,EMG     ,ISNOW   ,DF      ,DZSNSO  ,Z
   REAL,                            INTENT(IN) :: RHSUR  !raltive humidity in surface soil/snow air space (-)
   REAL,                            INTENT(IN) :: EAIR   !vapor pressure air at height (pa)
   REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC    !soil/snow temperature (k)
+  REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: SMC    !soil moisture
+  REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: SH2O   !soil liquid water
   REAL,                            INTENT(IN) :: SAG    !solar radiation absorbed by ground (w/m2)
   REAL,                            INTENT(IN) :: SNOWH  !actual snow depth [m]
   REAL,                            INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg)
@@ -984,6 +995,9 @@ SUBROUTINE GLACIER_FLUX (NSOIL   ,NSNOW   ,EMG     ,ISNOW   ,DF      ,DZSNSO  ,Z
   REAL    :: DTG        !change in tg, last iteration (k)
   INTEGER :: MOZSGN  !number of times MOZ changes sign
   REAL    :: MOZOLD     !Monin-Obukhov stability parameter from prior iteration
+  REAL    :: FM2          !Monin-Obukhov momentum adjustment at 2m
+  REAL    :: FH2          !Monin-Obukhov heat adjustment at 2m
+  REAL    :: CH2          !Surface exchange at 2m
   REAL    :: H          !temporary sensible heat flux (w/m2)
   REAL    :: FV         !friction velocity (m/s)
   REAL    :: CIR        !coefficients for ir as function of ts**4
@@ -1008,6 +1022,7 @@ SUBROUTINE GLACIER_FLUX (NSOIL   ,NSNOW   ,EMG     ,ISNOW   ,DF      ,DZSNSO  ,Z
   REAL    :: A          !temporary calculation
   REAL    :: B          !temporary calculation
   REAL    :: T, TDC     !Kelvin to degree Celsius with limit -50 to +50
+  REAL, DIMENSION(       1:NSOIL) :: SICE   !soil ice
 
   TDC(T)   = MIN( 50., MAX(-50.,(T-TFRZ)) )
 
@@ -1034,8 +1049,8 @@ SUBROUTINE GLACIER_FLUX (NSOIL   ,NSNOW   ,EMG     ,ISNOW   ,DF      ,DZSNSO  ,Z
 
         CALL SFCDIF1_GLACIER(ITER   ,ZLVL   ,ZPD    ,Z0H    ,Z0M    , & !in
                      QAIR   ,SFCTMP ,H      ,RHOAIR ,MPE    ,UR     , & !in
-       &             MOZ    ,MOZSGN ,FM     ,FH     ,                 & !inout
-       &             FV     ,CM     ,CH     )                           !out
+       &             MOZ    ,MOZSGN ,FM     ,FH     ,FM2    ,FH2    , & !inout
+       &             FV     ,CM     ,CH     ,CH2)                       !out
 
         RAMB = MAX(1.,1./(CM*UR))
         RAHB = MAX(1.,1./(CH*UR))
@@ -1092,8 +1107,9 @@ SUBROUTINE GLACIER_FLUX (NSOIL   ,NSNOW   ,EMG     ,ISNOW   ,DF      ,DZSNSO  ,Z
 
 ! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes.
 
+     SICE = SMC - SH2O
      IF(OPT_STC == 1) THEN
-     IF (SNOWH > 0.05 .AND. TGB > TFRZ) THEN
+     IF ((MAXVAL(SICE) > 0.0 .OR. SNOWH > 0.0) .AND. TGB > TFRZ) THEN
           TGB = TFRZ
           IRB = CIR * TGB**4 - EMG*LWDN
           SHB = CSH * (TGB        - SFCTMP)
@@ -1103,13 +1119,13 @@ SUBROUTINE GLACIER_FLUX (NSOIL   ,NSNOW   ,EMG     ,ISNOW   ,DF      ,DZSNSO  ,Z
      END IF
 
 ! 2m air temperature
-     EHB2  = FV*VKC/LOG((2.+Z0H)/Z0H)
+     EHB2  = FV*VKC/(LOG((2.+Z0H)/Z0H)-FH2)
      CQ2B  = EHB2
      IF (EHB2.lt.1.E-5 ) THEN
        T2MB  = TGB
        Q2B   = QSFC
      ELSE
-       T2MB  = TGB - SHB/(RHOAIR*CPAIR*FV) * 1./VKC * LOG((2.+Z0H)/Z0H)
+       T2MB  = TGB - SHB/(RHOAIR*CPAIR) * 1./EHB2
        Q2B   = QSFC - EVB/(LATHEA*RHOAIR)*(1./CQ2B + RSURF)
      ENDIF
 
@@ -1172,8 +1188,8 @@ END SUBROUTINE ESAT
 
   SUBROUTINE SFCDIF1_GLACIER(ITER   ,ZLVL   ,ZPD    ,Z0H    ,Z0M    , & !in
                      QAIR   ,SFCTMP ,H      ,RHOAIR ,MPE    ,UR     , & !in
-       &             MOZ    ,MOZSGN ,FM     ,FH     ,                 & !inout
-       &             FV     ,CM     ,CH     )                           !out
+       &             MOZ    ,MOZSGN ,FM     ,FH     ,FM2    ,FH2    , & !inout
+       &             FV     ,CM     ,CH     ,CH2     )                  !out
 ! -------------------------------------------------------------------------------------------------
 ! computing surface drag coefficient CM for momentum and CH for heat
 ! -------------------------------------------------------------------------------------------------
@@ -1197,11 +1213,14 @@ SUBROUTINE SFCDIF1_GLACIER(ITER   ,ZLVL   ,ZPD    ,Z0H    ,Z0M    , & !in
     INTEGER,           INTENT(INOUT) :: MOZSGN !number of times moz changes sign
     REAL,              INTENT(INOUT) :: FM     !momentum stability correction, weighted by prior iters
     REAL,              INTENT(INOUT) :: FH     !sen heat stability correction, weighted by prior iters
+    REAL,              INTENT(INOUT) :: FM2    !sen heat stability correction, weighted by prior iters
+    REAL,              INTENT(INOUT) :: FH2    !sen heat stability correction, weighted by prior iters
 
 ! outputs
     REAL,                INTENT(OUT) :: FV     !friction velocity (m/s)
     REAL,                INTENT(OUT) :: CM     !drag coefficient for momentum
     REAL,                INTENT(OUT) :: CH     !drag coefficient for heat
+    REAL,                INTENT(OUT) :: CH2    !drag coefficient for heat
 
 ! locals
     REAL    :: MOZOLD                   !Monin-Obukhov stability parameter from prior iteration
@@ -1212,7 +1231,14 @@ SUBROUTINE SFCDIF1_GLACIER(ITER   ,ZLVL   ,ZPD    ,Z0H    ,Z0M    , & !in
     REAL    :: TMP1,TMP2,TMP3           !temporary calculation
     REAL    :: FMNEW                    !stability correction factor, momentum, for current moz
     REAL    :: FHNEW                    !stability correction factor, sen heat, for current moz
-    REAL    :: CMFM, CHFH
+    REAL    :: MOZ2                     !2/L
+    REAL    :: TMPCM2                   !temporary calculation for CM2
+    REAL    :: TMPCH2                   !temporary calculation for CH2
+    REAL    :: FM2NEW                   !stability correction factor, momentum, for current moz
+    REAL    :: FH2NEW                   !stability correction factor, sen heat, for current moz
+    REAL    :: TMP12,TMP22,TMP32        !temporary calculation
+
+    REAL    :: CMFM, CHFH, CM2FM2, CH2FH2
 
 
 ! -------------------------------------------------------------------------------------------------
@@ -1221,23 +1247,27 @@ SUBROUTINE SFCDIF1_GLACIER(ITER   ,ZLVL   ,ZPD    ,Z0H    ,Z0M    , & !in
     MOZOLD = MOZ
   
     IF(ZLVL <= ZPD) THEN
-       write(*,*) 'critical problem: ZLVL <= ZPD; model stops'
-       call wrf_error_fatal("STOP in Noah-MP")
+       write(*,*) 'critical glacier problem: ZLVL <= ZPD; model stops', zlvl, zpd
+       call wrf_error_fatal("STOP in Noah-MP glacier")
     ENDIF
 
     TMPCM = LOG((ZLVL-ZPD) / Z0M)
     TMPCH = LOG((ZLVL-ZPD) / Z0H)
+    TMPCM2 = LOG((2.0 + Z0M) / Z0M)
+    TMPCH2 = LOG((2.0 + Z0H) / Z0H)
 
     IF(ITER == 1) THEN
        FV   = 0.0
        MOZ  = 0.0
        MOL  = 0.0
+       MOZ2 = 0.0
     ELSE
        TVIR = (1. + 0.61*QAIR) * SFCTMP
        TMP1 = VKC * (GRAV/TVIR) * H/(RHOAIR*CPAIR)
        IF (ABS(TMP1) .LE. MPE) TMP1 = MPE
        MOL  = -1. * FV**3 / TMP1
        MOZ  = MIN( (ZLVL-ZPD)/MOL, 1.)
+       MOZ2  = MIN( (2.0 + Z0H)/MOL, 1.)
     ENDIF
 
 ! accumulate number of times moz changes sign.
@@ -1247,6 +1277,9 @@ SUBROUTINE SFCDIF1_GLACIER(ITER   ,ZLVL   ,ZPD    ,Z0H    ,Z0M    , & !in
        MOZ = 0.
        FM = 0.
        FH = 0.
+       MOZ2 = 0.
+       FM2 = 0.
+       FH2 = 0.
     ENDIF
 
 ! evaluate stability-dependent variables using moz from prior iteration
@@ -1256,9 +1289,18 @@ SUBROUTINE SFCDIF1_GLACIER(ITER   ,ZLVL   ,ZPD    ,Z0H    ,Z0M    , & !in
        TMP3 = LOG((1.+TMP1)/2.)
        FMNEW = 2.*TMP3 + TMP2 - 2.*ATAN(TMP1) + 1.5707963
        FHNEW = 2*TMP2
+
+! 2-meter
+       TMP12 = (1. - 16.*MOZ2)**0.25
+       TMP22 = LOG((1.+TMP12*TMP12)/2.)
+       TMP32 = LOG((1.+TMP12)/2.)
+       FM2NEW = 2.*TMP32 + TMP22 - 2.*ATAN(TMP12) + 1.5707963
+       FH2NEW = 2*TMP22
     ELSE
        FMNEW = -5.*MOZ
        FHNEW = FMNEW
+       FM2NEW = -5.*MOZ2
+       FH2NEW = FM2NEW
     ENDIF
 
 ! except for first iteration, weight stability factors for previous
@@ -1267,23 +1309,38 @@ SUBROUTINE SFCDIF1_GLACIER(ITER   ,ZLVL   ,ZPD    ,Z0H    ,Z0M    , & !in
     IF (ITER == 1) THEN
        FM = FMNEW
        FH = FHNEW
+       FM2 = FM2NEW
+       FH2 = FH2NEW
     ELSE
        FM = 0.5 * (FM+FMNEW)
        FH = 0.5 * (FH+FHNEW)
+       FM2 = 0.5 * (FM2+FM2NEW)
+       FH2 = 0.5 * (FH2+FH2NEW)
     ENDIF
 
 ! exchange coefficients
 
+    FH = MIN(FH,0.9*TMPCH)
+    FM = MIN(FM,0.9*TMPCM)
+    FH2 = MIN(FH2,0.9*TMPCH2)
+    FM2 = MIN(FM2,0.9*TMPCM2)
+
     CMFM = TMPCM-FM
     CHFH = TMPCH-FH
+    CM2FM2 = TMPCM2-FM2
+    CH2FH2 = TMPCH2-FH2
     IF(ABS(CMFM) <= MPE) CMFM = MPE
     IF(ABS(CHFH) <= MPE) CHFH = MPE
+    IF(ABS(CM2FM2) <= MPE) CM2FM2 = MPE
+    IF(ABS(CH2FH2) <= MPE) CH2FH2 = MPE
     CM  = VKC*VKC/(CMFM*CMFM)
     CH  = VKC*VKC/(CMFM*CHFH)
+    CH2  = VKC*VKC/(CM2FM2*CH2FH2)
         
 ! friction velocity
 
     FV = UR * SQRT(CM)
+    CH2  = VKC*FV/CH2FH2
 
   END SUBROUTINE SFCDIF1_GLACIER
 ! ==================================================================================================
@@ -1598,7 +1655,7 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW   ,NSOIL   ,ISNOW   ,DT      ,FACT    , &
 
 ! local
 
-  INTEGER                         :: J         !do loop index
+  INTEGER                         :: J,K         !do loop index
   REAL, DIMENSION(-NSNOW+1:NSOIL) :: HM        !energy residual [w/m2]
   REAL, DIMENSION(-NSNOW+1:NSOIL) :: XM        !melting or freezing water [kg/m2]
   REAL, DIMENSION(-NSNOW+1:NSOIL) :: WMASS0
@@ -1606,7 +1663,7 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW   ,NSOIL   ,ISNOW   ,DT      ,FACT    , &
   REAL, DIMENSION(-NSNOW+1:NSOIL) :: WLIQ0 
   REAL, DIMENSION(-NSNOW+1:NSOIL) :: MICE      !soil/snow ice mass [mm]
   REAL, DIMENSION(-NSNOW+1:NSOIL) :: MLIQ      !soil/snow liquid water mass [mm]
-  REAL                            :: HEATR     !energy residual or loss after melting/freezing
+  REAL, DIMENSION(-NSNOW+1:NSOIL) :: HEATR     !energy residual or loss after melting/freezing
   REAL                            :: TEMP1     !temporary variables [kg/m2]
   REAL                            :: PROPOR
   REAL                            :: XMF       !total latent heat of phase change
@@ -1636,8 +1693,7 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW   ,NSOIL   ,ISNOW   ,DT      ,FACT    , &
          WLIQ0(J)    = MLIQ(J)
          WMASS0(J)   = MICE(J) + MLIQ(J)
     ENDDO
-
-
+    
     DO J = ISNOW+1,NSOIL
          IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN  ! melting 
              IMELT(J) = 1
@@ -1680,13 +1736,15 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW   ,NSOIL   ,ISNOW   ,DT      ,FACT    , &
         SNEQV  = MAX(0.,TEMP1-XM(1))  
         PROPOR = SNEQV/TEMP1
         SNOWH  = MAX(0.,PROPOR * SNOWH)
-        HEATR  = HM(1) - HFUS*(TEMP1-SNEQV)/DT  
-        IF (HEATR > 0.) THEN
-              XM(1) = HEATR*DT/HFUS             
-              HM(1) = HEATR                    
+        HEATR(1)  = HM(1) - HFUS*(TEMP1-SNEQV)/DT  
+        IF (HEATR(1) > 0.) THEN
+              XM(1) = HEATR(1)*DT/HFUS             
+              HM(1) = HEATR(1) 
+	      IMELT(1) = 1                   
         ELSE
               XM(1) = 0.
               HM(1) = 0.
+	      IMELT(1) = 0                   
         ENDIF
         QMELT   = MAX(0.,(TEMP1-SNEQV))/DT
         XMF     = HFUS*QMELT
@@ -1698,31 +1756,143 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW   ,NSOIL   ,ISNOW   ,DT      ,FACT    , &
     DO J = ISNOW+1,NSOIL
       IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN
 
-         HEATR = 0.
+         HEATR(J) = 0.
          IF (XM(J) > 0.) THEN                            
             MICE(J) = MAX(0., WICE0(J)-XM(J))
-            HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT
+            HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT
          ELSE IF (XM(J) < 0.) THEN                      
             MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J))  
-            HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT
+            HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT
          ENDIF
 
          MLIQ(J) = MAX(0.,WMASS0(J)-MICE(J))
 
-         IF (ABS(HEATR) > 0.) THEN
-            STC(J) = STC(J) + FACT(J)*HEATR
+         IF (ABS(HEATR(J)) > 0.) THEN
+            STC(J) = STC(J) + FACT(J)*HEATR(J)
             IF (J <= 0) THEN                             ! snow
                IF (MLIQ(J)*MICE(J)>0.) STC(J) = TFRZ
             END IF
          ENDIF
 
-         XMF = XMF + HFUS * (WICE0(J)-MICE(J))/DT
+         IF (J > 0) XMF = XMF + HFUS * (WICE0(J)-MICE(J))/DT
 
          IF (J < 1) THEN
             QMELT = QMELT + MAX(0.,(WICE0(J)-MICE(J)))/DT
          ENDIF
       ENDIF
     ENDDO
+    HEATR = 0.0
+    XM = 0.0
+
+! Deal with residuals in ice/soil
+
+! FIRST REMOVE EXCESS HEAT BY REDUCING TEMPERATURE OF LAYERS
+
+    IF (ANY(STC(1:4) > TFRZ) .AND. ANY(STC(1:4) < TFRZ)) THEN
+      DO J = 1,NSOIL
+        IF ( STC(J) > TFRZ ) THEN                                       
+	  HEATR(J) = (STC(J)-TFRZ)/FACT(J)
+          DO K = 1,NSOIL
+	    IF (J .NE. K .AND. STC(K) < TFRZ .AND. HEATR(J) > 0.1) THEN
+	      HEATR(K) = (STC(K)-TFRZ)/FACT(K)
+	      IF (ABS(HEATR(K)) > HEATR(J)) THEN  ! LAYER ABSORBS ALL
+	        HEATR(K) = HEATR(K) + HEATR(J)
+		STC(K) = TFRZ + HEATR(K)*FACT(K)
+		HEATR(J) = 0.0
+              ELSE
+	        HEATR(J) = HEATR(J) + HEATR(K)
+		HEATR(K) = 0.0
+		STC(K) = TFRZ
+              END IF
+	    END IF
+	  END DO
+          STC(J) = TFRZ + HEATR(J)*FACT(J)
+        END IF
+      END DO
+    END IF
+
+! NOW REMOVE EXCESS COLD BY INCREASING TEMPERATURE OF LAYERS (MAY NOT BE NECESSARY WITH ABOVE LOOP)
+
+    IF (ANY(STC(1:4) > TFRZ) .AND. ANY(STC(1:4) < TFRZ)) THEN
+      DO J = 1,NSOIL
+        IF ( STC(J) < TFRZ ) THEN                                       
+	  HEATR(J) = (STC(J)-TFRZ)/FACT(J)
+          DO K = 1,NSOIL
+	    IF (J .NE. K .AND. STC(K) > TFRZ .AND. HEATR(J) < -0.1) THEN
+	      HEATR(K) = (STC(K)-TFRZ)/FACT(K)
+	      IF (HEATR(K) > ABS(HEATR(J))) THEN  ! LAYER ABSORBS ALL
+	        HEATR(K) = HEATR(K) + HEATR(J)
+		STC(K) = TFRZ + HEATR(K)*FACT(K)
+		HEATR(J) = 0.0
+              ELSE
+	        HEATR(J) = HEATR(J) + HEATR(K)
+		HEATR(K) = 0.0
+		STC(K) = TFRZ
+              END IF
+	    END IF
+	  END DO
+          STC(J) = TFRZ + HEATR(J)*FACT(J)
+        END IF
+      END DO
+    END IF
+
+! NOW REMOVE EXCESS HEAT BY MELTING ICE
+
+    IF (ANY(STC(1:4) > TFRZ) .AND. ANY(MICE(1:4) > 0.)) THEN
+      DO J = 1,NSOIL
+        IF ( STC(J) > TFRZ ) THEN                                       
+	  HEATR(J) = (STC(J)-TFRZ)/FACT(J)
+          XM(J) = HEATR(J)*DT/HFUS                           
+          DO K = 1,NSOIL
+	    IF (J .NE. K .AND. MICE(K) > 0. .AND. XM(J) > 0.1) THEN
+	      IF (MICE(K) > XM(J)) THEN  ! LAYER ABSORBS ALL
+	        MICE(K) = MICE(K) - XM(J)
+		XMF = XMF + HFUS * XM(J)/DT
+		STC(K) = TFRZ
+		XM(J) = 0.0
+              ELSE
+	        XM(J) = XM(J) - MICE(K)
+		XMF = XMF + HFUS * MICE(K)/DT
+		MICE(K) = 0.0
+		STC(K) = TFRZ
+              END IF
+              MLIQ(K) = MAX(0.,WMASS0(K)-MICE(K))
+	    END IF
+	  END DO
+	  HEATR(J) = XM(J)*HFUS/DT
+          STC(J) = TFRZ + HEATR(J)*FACT(J)
+        END IF
+      END DO
+    END IF
+
+! NOW REMOVE EXCESS COLD BY FREEZING LIQUID OF LAYERS (MAY NOT BE NECESSARY WITH ABOVE LOOP)
+
+    IF (ANY(STC(1:4) < TFRZ) .AND. ANY(MLIQ(1:4) > 0.)) THEN
+      DO J = 1,NSOIL
+        IF ( STC(J) < TFRZ ) THEN                                       
+	  HEATR(J) = (STC(J)-TFRZ)/FACT(J)
+          XM(J) = HEATR(J)*DT/HFUS                           
+          DO K = 1,NSOIL
+	    IF (J .NE. K .AND. MLIQ(K) > 0. .AND. XM(J) < -0.1) THEN
+	      IF (MLIQ(K) > ABS(XM(J))) THEN  ! LAYER ABSORBS ALL
+	        MICE(K) = MICE(K) - XM(J)
+		XMF = XMF + HFUS * XM(J)/DT
+		STC(K) = TFRZ
+		XM(J) = 0.0
+              ELSE
+	        XM(J) = XM(J) + MLIQ(K)
+		XMF = XMF - HFUS * MLIQ(K)/DT
+		MICE(K) = WMASS0(K)
+		STC(K) = TFRZ
+              END IF
+              MLIQ(K) = MAX(0.,WMASS0(K)-MICE(K))
+	    END IF
+	  END DO
+	  HEATR(J) = XM(J)*HFUS/DT
+          STC(J) = TFRZ + HEATR(J)*FACT(J)
+        END IF
+      END DO
+    END IF
 
     DO J = ISNOW+1,0             ! snow
        SNLIQ(J) = MLIQ(J)
@@ -1731,7 +1901,9 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW   ,NSOIL   ,ISNOW   ,DT      ,FACT    , &
 
     DO J = 1, NSOIL              ! soil
        SH2O(J) =  MLIQ(J)            / (1000. * DZSNSO(J))
-       SMC(J)  = (MLIQ(J) + MICE(J)) / (1000. * DZSNSO(J))
+       SH2O(J) =  MAX(0.0,MIN(1.0,SH2O(J)))
+!       SMC(J)  = (MLIQ(J) + MICE(J)) / (1000. * DZSNSO(J))
+       SMC(J)  = 1.0 
     END DO
    
   END SUBROUTINE PHASECHANGE_GLACIER
@@ -1790,6 +1962,10 @@ SUBROUTINE WATER_GLACIER (NSNOW  ,NSOIL  ,IMELT  ,DT     ,PRCP   ,SFCTMP , & !in
   REAL                                           :: SNOWHIN !snow depth increasing rate (m/s)
   REAL                                           :: SNOFLOW !glacier flow [mm/s]
   REAL                                           :: BDFALL  !density of new snow (mm water/m snow)
+  REAL                                           :: REPLACE !replacement water due to sublimation of glacier
+  REAL, DIMENSION(       1:NSOIL)                :: SICE_SAVE  !soil ice content [m3/m3]
+  REAL, DIMENSION(       1:NSOIL)                :: SH2O_SAVE  !soil liquid water content [m3/m3]
+  INTEGER :: ILEV
 
 ! ----------------------------------------------------------------------
 ! initialize
@@ -1797,6 +1973,8 @@ SUBROUTINE WATER_GLACIER (NSNOW  ,NSOIL  ,IMELT  ,DT     ,PRCP   ,SFCTMP , & !in
    SNOFLOW         = 0.
    RUNSUB          = 0.
    RUNSRF          = 0.
+   SICE_SAVE       = SICE
+   SH2O_SAVE       = SH2O
 
 ! --------------------------------------------------------------------
 ! partition precipitation into rain and snow (from CANWATER)
@@ -1837,7 +2015,7 @@ SUBROUTINE WATER_GLACIER (NSNOW  ,NSOIL  ,IMELT  ,DT     ,PRCP   ,SFCTMP , & !in
 ! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625
 ! fresh snow density
 
-     BDFALL = MAX(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59))
+     BDFALL = MIN(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59))
 
      QRAIN   = PRCP * (1.-FPICE)
      QSNOW   = PRCP * FPICE
@@ -1846,42 +2024,61 @@ SUBROUTINE WATER_GLACIER (NSNOW  ,NSOIL  ,IMELT  ,DT     ,PRCP   ,SFCTMP , & !in
 
 ! sublimation, frost, evaporation, and dew
 
-     QSNSUB = 0.
-     IF (SNEQV > 0.) THEN
-       QSNSUB = MIN(QVAP, SNEQV/DT)
-     ENDIF
-     QSEVA = QVAP-QSNSUB
+!     QSNSUB = 0.
+!     IF (SNEQV > 0.) THEN
+!       QSNSUB = MIN(QVAP, SNEQV/DT)
+!     ENDIF
+!     QSEVA = QVAP-QSNSUB
+
+!     QSNFRO = 0.
+!     IF (SNEQV > 0.) THEN
+!        QSNFRO = QDEW
+!     ENDIF
+!     QSDEW = QDEW - QSNFRO
+
+     QSNSUB = QVAP  ! send total sublimation/frost to SNOWWATER and deal with it there
+     QSNFRO = QDEW
 
-     QSNFRO = 0.
-     IF (SNEQV > 0.) THEN
-        QSNFRO = QDEW
-     ENDIF
-     QSDEW = QDEW - QSNFRO
 !     print *, 'qvap',qvap,qvap*dt
 !     print *, 'qsnsub',qsnsub,qsnsub*dt
 !     print *, 'qseva',qseva,qseva*dt
 !     print *, 'qsnfro',qsnfro,qsnfro*dt
 !     print *, 'qdew',qdew,qdew*dt
 !     print *, 'qsdew',qsdew,qsdew*dt
-
+!print *, 'before snowwater', sneqv,snowh,snice,snliq,sh2o,sice
      CALL SNOWWATER_GLACIER (NSNOW  ,NSOIL  ,IMELT  ,DT     ,SFCTMP , & !in
                              SNOWHIN,QSNOW  ,QSNFRO ,QSNSUB ,QRAIN  , & !in
                              FICEOLD,ZSOIL  ,                         & !in
                              ISNOW  ,SNOWH  ,SNEQV  ,SNICE  ,SNLIQ  , & !inout
                              SH2O   ,SICE   ,STC    ,DZSNSO ,ZSNSO  , & !inout
                              QSNBOT ,SNOFLOW,PONDING1       ,PONDING2)  !out
+!print *, 'after snowwater', sneqv,snowh,snice,snliq,sh2o,sice
+!print *, 'ponding', PONDING,PONDING1,PONDING2
 
     !PONDING: melting water from snow when there is no layer
     
     RUNSRF = (PONDING+PONDING1+PONDING2)/DT
 
     IF(ISNOW == 0) THEN
-      RUNSRF = RUNSRF+(QSNBOT + QSDEW + QRAIN)
+      RUNSRF = RUNSRF + QSNBOT + QRAIN
     ELSE
-      RUNSRF = RUNSRF+(QSNBOT + QSDEW)
+      RUNSRF = RUNSRF + QSNBOT
     ENDIF
+    
+    REPLACE = 0.0
+    DO ILEV = 1,NSOIL
+       REPLACE = REPLACE + DZSNSO(ILEV)*(SICE(ILEV) - SICE_SAVE(ILEV) + SH2O(ILEV) - SH2O_SAVE(ILEV))
+    END DO
+    REPLACE = REPLACE * 1000.0 / DT     ! convert to [mm/s]
+    
+    SICE = MIN(1.0,SICE_SAVE)
+    SH2O = 1.0 - SICE
+!print *, 'replace', replace
+    
+    ! use RUNSUB as a water balancer, SNOFLOW is snow that disappears, REPLACE is
+    !   water from below that replaces glacier loss
 
-    RUNSUB       = SNOFLOW   !mm/s allow excess snow to disappear as runsub
+    RUNSUB       = SNOFLOW + REPLACE
 
   END SUBROUTINE WATER_GLACIER
 ! ==================================================================================================
@@ -2212,6 +2409,7 @@ SUBROUTINE COMBINE_GLACIER (NSNOW  ,NSOIL  ,                         & !in
     REAL    :: ZWLIQ                 ! total liquid water in snow
     REAL    :: DZMIN(3)              ! minimum of top snow layer
     DATA DZMIN /0.045, 0.05, 0.2/
+!    DATA DZMIN /0.025, 0.025, 0.1/  ! MB: change limit
 !-----------------------------------------------------------------------
 
        ISNOW_OLD = ISNOW
@@ -2257,6 +2455,8 @@ SUBROUTINE COMBINE_GLACIER (NSNOW  ,NSOIL  ,                         & !in
           SICE(1) = 0.
        END IF
 
+       IF(ISNOW ==0) RETURN   ! MB: get out if no longer multi-layer
+
        SNEQV  = 0.
        SNOWH  = 0.
        ZWICE  = 0.
@@ -2272,6 +2472,7 @@ SUBROUTINE COMBINE_GLACIER (NSNOW  ,NSOIL  ,                         & !in
 ! check the snow depth - all snow gone
 ! the liquid water assumes ponding on soil surface.
 
+!       IF (SNOWH < 0.025 .AND. ISNOW < 0 ) THEN ! MB: change limit
        IF (SNOWH < 0.05 .AND. ISNOW < 0 ) THEN
           ISNOW  = 0
           SNEQV = ZWICE
@@ -2468,6 +2669,7 @@ SUBROUTINE DIVIDE_GLACIER (NSNOW  ,NSOIL  ,                         & !in
                   ZWLIQ, ZWICE, TSNO(1))
 
              ! subdivide a new layer
+!             IF (MSNO <= 2 .AND. DZ(2) > 0.20) THEN  ! MB: change limit
              IF (MSNO <= 2 .AND. DZ(2) > 0.10) THEN
                 MSNO = 3
                 DTDZ = (TSNO(1) - TSNO(2))/((DZ(1)+DZ(2))/2.)
@@ -2573,7 +2775,7 @@ SUBROUTINE SNOWH2O_GLACIER (NSNOW  ,NSOIL  ,DT     ,QSNFRO ,QSNSUB , & !in
 !for the case when SNEQV becomes '0' after 'COMBINE'
 
    IF(SNEQV == 0.) THEN
-      SH2O(1) =  SH2O(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.)
+      SICE(1) =  SICE(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.)
    END IF
 
 ! for shallow snow without a layer
@@ -2590,6 +2792,7 @@ SUBROUTINE SNOWH2O_GLACIER (NSNOW  ,NSOIL  ,DT     ,QSNFRO ,QSNSUB , & !in
       IF(SNEQV < 0.) THEN
          SICE(1) = SICE(1) + SNEQV/(DZSNSO(1)*1000.)
          SNEQV   = 0.
+         SNOWH   = 0.
       END IF
       IF(SICE(1) < 0.) THEN
          SH2O(1) = SH2O(1) + SICE(1)
@@ -2597,8 +2800,10 @@ SUBROUTINE SNOWH2O_GLACIER (NSNOW  ,NSOIL  ,DT     ,QSNFRO ,QSNSUB , & !in
       END IF
    END IF
 
-   IF(SNOWH <= 1.E-8) SNOWH = 0.0
-   IF(SNEQV <= 1.E-6) SNEQV = 0.0
+   IF(SNOWH <= 1.E-8 .OR. SNEQV <= 1.E-6) THEN
+     SNOWH = 0.0
+     SNEQV = 0.0
+   END IF
 
 ! for deep snow
 
diff --git a/wrfv2_fire/phys/module_sf_noahmp_groundwater.F b/wrfv2_fire/phys/module_sf_noahmp_groundwater.F
new file mode 100644
index 00000000..0f1f6f86
--- /dev/null
+++ b/wrfv2_fire/phys/module_sf_noahmp_groundwater.F
@@ -0,0 +1,610 @@
+MODULE module_sf_noahmp_groundwater
+!===============================================================================
+! Module to calculate lateral groundwater flow and the flux between groundwater and rivers
+! plus the routine to update soil moisture and water table due to those two fluxes
+! according to the Miguez-Macho & Fan groundwater scheme (Miguez-Macho et al., JGR 2007).
+! Module written by Gonzalo Miguez-Macho , U. de Santiago de Compostela, Galicia, Spain
+! November 2012 
+!===============================================================================
+
+  USE module_sf_noahlsm,  only: MAXSMC,BB,SATPSI,SATDK,WLTSMC
+
+CONTAINS
+
+  SUBROUTINE WTABLE_mmf_noahmp (NSOIL     ,XLAND    ,XICE    ,XICE_THRESHOLD  ,ISICE ,& !in
+                                ISLTYP    ,SMOISEQ  ,DZS     ,WTDDT                  ,& !in
+                                FDEPTH    ,AREA     ,TOPO    ,ISURBAN ,IVGTYP        ,& !in
+                                RIVERCOND ,RIVERBED ,EQWTD   ,PEXP                   ,& !in
+                                SMOIS     ,SH2OXY   ,SMCWTD  ,WTD  ,QRF              ,& !inout
+                                DEEPRECH  ,QSPRING  ,QSLAT   ,QRFS ,QSPRINGS  ,RECH  ,& !inout
+                                ids,ide, jds,jde, kds,kde,                    &
+                                ims,ime, jms,jme, kms,kme,                    &
+                                its,ite, jts,jte, kts,kte                     )
+
+! ----------------------------------------------------------------------
+  IMPLICIT NONE
+! ----------------------------------------------------------------------
+! IN only
+
+  INTEGER,  INTENT(IN   )   ::     ids,ide, jds,jde, kds,kde,  &
+       &                           ims,ime, jms,jme, kms,kme,  &
+       &                           its,ite, jts,jte, kts,kte
+    REAL,   INTENT(IN)        ::     WTDDT
+    REAL,   INTENT(IN)        ::     XICE_THRESHOLD
+    INTEGER,  INTENT(IN   )   ::     ISICE
+    REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+         &   INTENT(IN   )    ::                          XLAND, &
+                                                           XICE
+    INTEGER, DIMENSION( ims:ime, jms:jme )                     , &
+             INTENT(IN   )    ::                         ISLTYP, &
+                                                         IVGTYP
+    INTEGER, INTENT(IN)       ::     nsoil
+    INTEGER, INTENT(IN)       ::     ISURBAN
+    REAL,     DIMENSION( ims:ime , 1:nsoil, jms:jme ), &
+         &    INTENT(IN)      ::                        SMOISEQ
+    REAL,     DIMENSION(1:nsoil), INTENT(IN)     ::         DZS
+    REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+         &   INTENT(IN)       ::                         FDEPTH, &
+                                                           AREA, &
+                                                           TOPO, &
+                                                          EQWTD, &
+                                                           PEXP, &
+                                                       RIVERBED, &
+                                                      RIVERCOND
+
+! IN and OUT 
+
+    REAL,     DIMENSION( ims:ime , 1:nsoil, jms:jme ), &
+         &    INTENT(INOUT)   ::                          SMOIS, &
+         &                                                SH2OXY 
+
+
+    REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+         &   INTENT(INOUT)    ::                            WTD, &
+                                                         SMCWTD, &
+                                                       DEEPRECH, &
+                                                          QSLAT, &
+                                                           QRFS, &
+                                                       QSPRINGS, &
+                                                           RECH
+
+!OUT
+
+    REAL,    DIMENSION( ims:ime, jms:jme )                     , &
+         &   INTENT(OUT)      ::                            QRF, &  !groundwater - river water flux
+                                                        QSPRING     !water springing at the surface from groundwater convergence in the column
+
+!LOCAL  
+  
+  INTEGER                          :: I,J,K  
+  REAL, DIMENSION(       0:NSOIL)  :: ZSOIL !depth of soil layer-bottom [m]
+  REAL,  DIMENSION(      1:NSOIL)  :: SMCEQ  !equilibrium soil water  content [m3/m3]
+  REAL,  DIMENSION(      1:NSOIL)  :: SMC,SH2O
+  REAL                                        :: DELTAT,RCOND,TOTWATER,SMCMAX, PSISAT, BEXP, SMCWLT ,DKSAT,PSI &
+                                                ,WFLUXDEEP,WCNDDEEP,DDZ,SMCWTDMID &
+                                                ,WPLUS,WMINUS
+  REAL,      DIMENSION( ims:ime, jms:jme )    :: QLAT
+  INTEGER,   DIMENSION( ims:ime, jms:jme )    :: LANDMASK !-1 for water (ice or no ice) and glacial areas, 1 for land where the LSM does its soil moisture calculations.
+
+    DELTAT = WTDDT * 60. !timestep in seconds for this calculation
+
+    ZSOIL(0) = 0.
+    ZSOIL(1) = -DZS(1)
+    DO K = 2, NSOIL
+       ZSOIL(K)         = -DZS(K) + ZSOIL(K-1)
+    END DO
+
+    WHERE(XLAND-1.5.LT.0..AND.XICE.LT. XICE_THRESHOLD.AND.IVGTYP.NE.ISICE)
+         LANDMASK=1
+    ELSEWHERE
+         LANDMASK=-1
+    ENDWHERE
+
+!Calculate lateral flow
+
+    QLAT = 0.
+CALL LATERALFLOW(ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA       &
+                        ,ids,ide,jds,jde,kds,kde                      &
+                        ,ims,ime,jms,jme,kms,kme                      &
+                        ,its,ite,jts,jte,kts,kte                      )
+
+
+!compute flux from grounwater to rivers in the cell
+
+    DO J=jts,jte
+       DO I=its,ite
+          IF(LANDMASK(I,J).GT.0)THEN
+             IF(WTD(I,J) .GT. RIVERBED(I,J) .AND.  EQWTD(I,J) .GT. RIVERBED(I,J)) THEN
+               RCOND = RIVERCOND(I,J) * EXP(PEXP(I,J)*(WTD(I,J)-EQWTD(I,J)))
+             ELSE    
+               RCOND = RIVERCOND(I,J)       
+             ENDIF
+             QRF(I,J) = RCOND * (WTD(I,J)-RIVERBED(I,J)) * DELTAT/AREA(I,J)
+!for now, dont allow it to go from river to groundwater
+             QRF(I,J) = MAX(QRF(I,J),0.)
+          ELSE
+             QRF(I,J) = 0.
+          ENDIF
+       ENDDO
+    ENDDO
+
+
+    DO J=jts,jte
+       DO I=its,ite
+          IF(LANDMASK(I,J).GT.0)THEN
+
+             BEXP = BB(ISLTYP(I,J))
+             DKSAT = SATDK (ISLTYP(I,J))
+             SMCMAX = MAXSMC(ISLTYP(I,J))
+             PSISAT = -SATPSI(ISLTYP(I,J))
+             SMCWLT = WLTSMC (ISLTYP(I,J))
+             IF(IVGTYP(I,J)==ISURBAN)THEN
+                 SMCMAX = 0.45
+                 SMCWLT = 0.40
+             ENDIF
+
+!for deep water table calculate recharge
+             IF(WTD(I,J) < ZSOIL(NSOIL)-DZS(NSOIL))THEN
+!assume all liquid if the wtd is deep
+                DDZ = ZSOIL(NSOIL)-WTD(I,J)
+                SMCWTDMID = 0.5 * (SMCWTD(I,J) + SMCMAX )
+                PSI = PSISAT * ( SMCMAX / SMCWTD(I,J) ) ** BEXP
+                WCNDDEEP = DKSAT * ( SMCWTDMID / SMCMAX ) ** (2.0*BEXP + 3.0)
+                WFLUXDEEP =  - DELTAT * WCNDDEEP * ( (PSISAT-PSI) / DDZ - 1.)
+!update deep soil moisture
+                SMCWTD(I,J) = SMCWTD(I,J)  + (DEEPRECH(I,J) -  WFLUXDEEP)  / DDZ
+                WPLUS       = MAX((SMCWTD(I,J)-SMCMAX), 0.0) * DDZ
+                WMINUS       = MAX((1.E-4-SMCWTD(I,J)), 0.0) * DDZ
+                SMCWTD(I,J) = MAX( MIN(SMCWTD(I,J),SMCMAX) , 1.E-4)
+                WFLUXDEEP = WFLUXDEEP + WPLUS - WMINUS
+                DEEPRECH(I,J) = WFLUXDEEP
+              ENDIF
+
+
+!Total water flux to or from groundwater in the cell
+             TOTWATER = QLAT(I,J) - QRF(I,J) + DEEPRECH(I,J)
+
+             SMC(1:NSOIL) = SMOIS(I,1:NSOIL,J)
+             SH2O(1:NSOIL) = SH2OXY(I,1:NSOIL,J)
+             SMCEQ(1:NSOIL) = SMOISEQ(I,1:NSOIL,J)
+
+!Update the water table depth and soil moisture
+             CALL UPDATEWTD ( NSOIL, DZS , ZSOIL, SMCEQ, SMCMAX, SMCWLT, PSISAT, BEXP ,I , J , &!in
+                              TOTWATER, WTD(I,J), SMC, SH2O, SMCWTD(I,J)      , &!inout
+                              QSPRING(I,J) ) !out
+
+!now update soil moisture
+             SMOIS(I,1:NSOIL,J) = SMC(1:NSOIL)
+             SH2OXY(I,1:NSOIL,J) = SH2O(1:NSOIL)
+
+           ENDIF
+       ENDDO
+    ENDDO
+
+!accumulate fluxes for output
+
+    DO J=jts,jte
+       DO I=its,ite
+           QSLAT(I,J) = QSLAT(I,J) + QLAT(I,J)*1.E3
+           QRFS(I,J) = QRFS(I,J) + QRF(I,J)*1.E3
+           QSPRINGS(I,J) = QSPRINGS(I,J) + QSPRING(I,J)*1.E3
+           RECH(I,J) = RECH(I,J) + DEEPRECH(I,J)*1.E3
+!zero out DEEPRECH
+           DEEPRECH(I,J) =0.
+       ENDDO
+    ENDDO
+
+
+END  SUBROUTINE WTABLE_mmf_noahmp
+! ==================================================================================================
+! ----------------------------------------------------------------------
+  SUBROUTINE LATERALFLOW  (ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA &
+                           ,ids,ide,jds,jde,kds,kde                      &
+                           ,ims,ime,jms,jme,kms,kme                      &
+                           ,its,ite,jts,jte,kts,kte                      )
+! ----------------------------------------------------------------------
+  IMPLICIT NONE
+! ----------------------------------------------------------------------
+! input
+  INTEGER,  INTENT(IN   )   ::     ids,ide, jds,jde, kds,kde,  &
+       &                           ims,ime, jms,jme, kms,kme,  &
+       &                           its,ite, jts,jte, kts,kte
+  REAL                                  , INTENT(IN) :: DELTAT                                 
+  INTEGER, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: ISLTYP, LANDMASK
+  REAL,    DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: FDEPTH,WTD,TOPO,AREA
+
+!output
+  REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: QLAT
+
+!local
+  INTEGER                              :: I, J, itsh,iteh,jtsh,jteh
+  REAL                                 :: Q,KLAT
+  REAL, DIMENSION( ims:ime , jms:jme ) :: KCELL, HEAD
+
+  REAL, DIMENSION(19)      :: KLATFACTOR
+  DATA KLATFACTOR /2.,3.,4.,10.,10.,12.,14.,20.,24.,28.,40.,48.,2.,0.,10.,0.,20.,2.,2./
+
+  REAL,    PARAMETER :: PI = 3.14159265 
+! REAL,    PARAMETER :: FANGLE = SQRT(TAN(PI/8.))/(2.*SQRT(2.))
+  REAL,    PARAMETER :: FANGLE = 0.45508986056   ! f95 does not permit real intrinsics in init expressions
+
+itsh=max(its-1,ids)
+iteh=min(ite+1,ide-1)
+jtsh=max(jts-1,jds)
+jteh=min(jte+1,jde-1)
+
+
+    DO J=jtsh,jteh
+       DO I=itsh,iteh
+           IF(FDEPTH(I,J).GT.0.)THEN
+                 KLAT = SATDK(ISLTYP(I,J)) * KLATFACTOR(ISLTYP(I,J))
+                 IF(WTD(I,J) < -1.5)THEN
+                     KCELL(I,J) = FDEPTH(I,J) * KLAT * EXP( (WTD(I,J) + 1.5) / FDEPTH(I,J) )
+                 ELSE
+                     KCELL(I,J) = KLAT * ( WTD(I,J) + 1.5 + FDEPTH(I,J) )  
+                 ENDIF
+           ELSE
+                 KCELL(i,J) = 0.
+           ENDIF
+
+           HEAD(I,J) = TOPO(I,J) + WTD(I,J)
+       ENDDO
+    ENDDO
+
+itsh=max(its,ids+1)
+iteh=min(ite,ide-2)
+jtsh=max(jts,jds+1)
+jteh=min(jte,jde-2)
+
+    DO J=jtsh,jteh
+       DO I=itsh,iteh
+          IF(LANDMASK(I,J).GT.0)THEN
+                 Q=0.
+                             
+                 Q  = Q + (KCELL(I-1,J+1)+KCELL(I,J)) &
+                        * (HEAD(I-1,J+1)-HEAD(I,J))/SQRT(2.)
+                             
+                 Q  = Q +  (KCELL(I-1,J)+KCELL(I,J)) &
+                        *  (HEAD(I-1,J)-HEAD(I,J))
+
+                 Q  = Q +  (KCELL(I-1,J-1)+KCELL(I,J)) &
+                        * (HEAD(I-1,J-1)-HEAD(I,J))/SQRT(2.)
+
+                 Q  = Q +  (KCELL(I,J+1)+KCELL(I,J)) &
+                        * (HEAD(I,J+1)-HEAD(I,J))
+
+                 Q  = Q +  (KCELL(I,J-1)+KCELL(I,J)) &
+                        * (HEAD(I,J-1)-HEAD(I,J))
+
+                 Q  = Q +  (KCELL(I+1,J+1)+KCELL(I,J)) &
+                        * (HEAD(I+1,J+1)-HEAD(I,J))/SQRT(2.)
+  
+                 Q  = Q +  (KCELL(I+1,J)+KCELL(I,J)) &
+                        * (HEAD(I+1,J)-HEAD(I,J))
+
+                 Q  = Q +  (KCELL(I+1,J-1)+KCELL(I,J)) &
+                        * (HEAD(I+1,J-1)-HEAD(I,J))/SQRT(2.)
+
+
+                 QLAT(I,J) = FANGLE* Q * DELTAT / AREA(I,J)
+          ENDIF
+       ENDDO
+    ENDDO
+
+
+END  SUBROUTINE LATERALFLOW
+! ==================================================================================================
+! ----------------------------------------------------------------------
+  SUBROUTINE UPDATEWTD  (NSOIL,  DZS,  ZSOIL ,SMCEQ                ,& !in
+                         SMCMAX, SMCWLT, PSISAT, BEXP ,ILOC ,JLOC  ,& !in
+                         TOTWATER, WTD ,SMC, SH2O ,SMCWTD          ,& !inout
+                         QSPRING                                 )  !out
+! ----------------------------------------------------------------------
+  IMPLICIT NONE
+! ----------------------------------------------------------------------
+! input
+  INTEGER,                         INTENT(IN) :: NSOIL !no. of soil layers
+  INTEGER,                         INTENT(IN) :: ILOC, JLOC
+  REAL,                         INTENT(IN)    :: SMCMAX
+  REAL,                         INTENT(IN)    :: SMCWLT
+  REAL,                         INTENT(IN)    :: PSISAT
+  REAL,                         INTENT(IN)    :: BEXP
+  REAL,  DIMENSION(       0:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m]
+  REAL,  DIMENSION(       1:NSOIL), INTENT(IN) :: SMCEQ  !equilibrium soil water  content [m3/m3]
+  REAL,  DIMENSION(       1:NSOIL), INTENT(IN) :: DZS ! soil layer thickness [m]
+! input-output
+  REAL                           , INTENT(INOUT) :: TOTWATER
+  REAL                           , INTENT(INOUT) :: WTD
+  REAL                           , INTENT(INOUT) :: SMCWTD
+  REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SMC
+  REAL, DIMENSION(       1:NSOIL), INTENT(INOUT) :: SH2O
+! output
+  REAL                           , INTENT(OUT) :: QSPRING
+!local
+  INTEGER                                     :: K
+  INTEGER                                     :: K1
+  INTEGER                                     :: IWTD
+  INTEGER                                     :: KWTD
+  REAL                                        :: MAXWATUP, MAXWATDW ,WTDOLD
+  REAL                                        :: WGPMID
+  REAL                                        :: SYIELDDW
+  REAL                                        :: DZUP
+  REAL                                        :: SMCEQDEEP
+  REAL, DIMENSION(       1:NSOIL)             :: SICE
+! -------------------------------------------------------------
+
+
+
+  QSPRING=0.
+
+  SICE = SMC - SH2O
+
+iwtd=1
+
+!case 1: totwater > 0 (water table going up):
+IF(totwater.gt.0.)then
+
+
+         if(wtd.ge.zsoil(nsoil))then
+
+            do k=nsoil-1,1,-1
+              if(wtd.lt.zsoil(k))exit
+            enddo
+            iwtd=k
+            kwtd=iwtd+1
+
+!max water that fits in the layer
+            maxwatup=dzs(kwtd)*(smcmax-smc(kwtd))
+
+            if(totwater.le.maxwatup)then
+               smc(kwtd) = smc(kwtd) + totwater / dzs(kwtd)
+               smc(kwtd) = min(smc(kwtd),smcmax)
+               if(smc(kwtd).gt.smceq(kwtd))wtd = min ( ( smc(kwtd)*dzs(kwtd) &
+                 - smceq(kwtd)*zsoil(iwtd) + smcmax*zsoil(kwtd) ) / &
+                     ( smcmax-smceq(kwtd) ) , zsoil(iwtd) )
+               totwater=0.
+            else   !water enough to saturate the layer
+              smc(kwtd) = smcmax
+              totwater=totwater-maxwatup
+              k1=iwtd
+              do k=k1,0,-1
+                 wtd = zsoil(k)
+                 iwtd=k-1
+                 if(k.eq.0)exit
+                 maxwatup=dzs(k)*(smcmax-smc(k))
+                 if(totwater.le.maxwatup)then
+                   smc(k) = smc(k) + totwater / dzs(k)
+                   smc(k) = min(smc(k),smcmax)
+                   if(smc(k).gt.smceq(k))wtd = min ( ( smc(k)*dzs(k) &
+                     - smceq(k)*zsoil(iwtd) + smcmax*zsoil(k) ) / &
+                     ( smcmax-smceq(k) ) , zsoil(iwtd) )
+                   totwater=0.
+                   exit
+                 else
+                    smc(k) = smcmax
+                    totwater=totwater-maxwatup
+                 endif
+
+              enddo
+
+            endif
+
+         elseif(wtd.ge.zsoil(nsoil)-dzs(nsoil))then ! wtd below bottom of soil model
+
+            !gmmequilibrium soil moisture content
+               smceqdeep = smcmax * ( psisat / &
+                           (psisat - dzs(nsoil)) ) ** (1./bexp)
+!               smceqdeep = max(smceqdeep,smcwlt)
+               smceqdeep = max(smceqdeep,1.E-4)
+
+            maxwatup=(smcmax-smcwtd)*dzs(nsoil)
+
+            if(totwater.le.maxwatup)then
+                smcwtd = smcwtd + totwater / dzs(nsoil)
+                smcwtd = min(smcwtd,smcmax)
+                if(smcwtd.gt.smceqdeep)wtd = min( ( smcwtd*dzs(nsoil) &
+                 - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / &
+                     ( smcmax-smceqdeep ) , zsoil(nsoil) )
+                totwater=0.
+            else
+                smcwtd=smcmax
+                totwater=totwater-maxwatup
+                do k=nsoil,0,-1
+                    wtd=zsoil(k)
+                    iwtd=k-1
+                    if(k.eq.0)exit
+                    maxwatup=dzs(k)*(smcmax-smc(k))
+                    if(totwater.le.maxwatup)then
+                     smc(k) = min(smc(k) + totwater / dzs(k),smcmax)
+                     if(smc(k).gt.smceq(k))wtd = min ( ( smc(k)*dzs(k) &
+                        - smceq(k)*zsoil(iwtd) + smcmax*zsoil(k) ) / &
+                           ( smcmax-smceq(k) ) , zsoil(iwtd) )
+                     totwater=0.
+                     exit
+                    else
+                     smc(k) = smcmax
+                     totwater=totwater-maxwatup
+                    endif
+                enddo
+             endif
+
+!deep water table
+       else
+
+            maxwatup=(smcmax-smcwtd)*(zsoil(nsoil)-dzs(nsoil)-wtd)
+            if(totwater.le.maxwatup)then
+               wtd = wtd + totwater/(smcmax-smcwtd)
+               totwater=0.
+            else
+               totwater=totwater-maxwatup
+               wtd=zsoil(nsoil)-dzs(nsoil)
+               maxwatup=(smcmax-smcwtd)*dzs(nsoil)
+              if(totwater.le.maxwatup)then
+
+            !gmmequilibrium soil moisture content
+               smceqdeep = smcmax * ( psisat / &
+                           (psisat - dzs(nsoil)) ) ** (1./bexp)
+!               smceqdeep = max(smceqdeep,smcwlt)
+               smceqdeep = max(smceqdeep,1.E-4)
+
+                smcwtd = smcwtd + totwater / dzs(nsoil)
+                smcwtd = min(smcwtd,smcmax)
+                wtd = ( smcwtd*dzs(nsoil) &
+                 - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / &
+                     ( smcmax-smceqdeep )
+                totwater=0.
+              else
+                smcwtd=smcmax
+                totwater=totwater-maxwatup
+                do k=nsoil,0,-1
+                    wtd=zsoil(k)
+                    iwtd=k-1
+                    if(k.eq.0)exit
+                    maxwatup=dzs(k)*(smcmax-smc(k))
+
+                    if(totwater.le.maxwatup)then
+                     smc(k) = smc(k) + totwater / dzs(k)
+                     smc(k) = min(smc(k),smcmax)
+                     if(smc(k).gt.smceq(k))wtd = ( smc(k)*dzs(k) &
+                        - smceq(k)*zsoil(iwtd) + smcmax*zsoil(k) ) / &
+                           ( smcmax-smceq(k) )
+                     totwater=0.
+                     exit
+                    else
+                     smc(k) = smcmax
+                     totwater=totwater-maxwatup
+                    endif
+                   enddo
+               endif
+             endif
+         endif
+
+!water springing at the surface
+        qspring=totwater
+
+!case 2: totwater < 0 (water table going down):
+ELSEIF(totwater.lt.0.)then
+
+
+         if(wtd.ge.zsoil(nsoil))then !wtd in the resolved layers
+
+            do k=nsoil-1,1,-1
+               if(wtd.lt.zsoil(k))exit
+            enddo
+            iwtd=k
+
+               k1=iwtd+1
+               do kwtd=k1,nsoil
+
+!max water that the layer can yield
+                  maxwatdw=dzs(kwtd)*(smc(kwtd)-max(smceq(kwtd),sice(kwtd)))
+
+                  if(-totwater.le.maxwatdw)then
+                        smc(kwtd) = smc(kwtd) + totwater / dzs(kwtd)
+                        if(smc(kwtd).gt.smceq(kwtd))then
+                              wtd = ( smc(kwtd)*dzs(kwtd) &
+                                 - smceq(kwtd)*zsoil(iwtd) + smcmax*zsoil(kwtd) ) / &
+                                 ( smcmax-smceq(kwtd) )
+                         else
+                              wtd=zsoil(kwtd)
+                              iwtd=iwtd+1
+                         endif
+                         totwater=0.
+                         exit
+                   else
+                         wtd = zsoil(kwtd)
+                         iwtd=iwtd+1
+                         if(maxwatdw.ge.0.)then
+                            smc(kwtd) = smc(kwtd) + maxwatdw / dzs(kwtd)
+                            totwater = totwater + maxwatdw
+                         endif
+                   endif
+
+                enddo
+
+               if(iwtd.eq.nsoil.and.totwater.lt.0.)then
+            !gmmequilibrium soil moisture content
+               smceqdeep = smcmax * ( psisat / &
+                           (psisat - dzs(nsoil)) ) ** (1./bexp)
+!               smceqdeep = max(smceqdeep,smcwlt)
+               smceqdeep = max(smceqdeep,1.E-4)
+
+                  maxwatdw=dzs(nsoil)*(smcwtd-smceqdeep)
+
+                  if(-totwater.le.maxwatdw)then
+
+                       smcwtd = smcwtd + totwater / dzs(nsoil)
+                       wtd = max( ( smcwtd*dzs(nsoil) &
+                           - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / &
+                            ( smcmax-smceqdeep ) , zsoil(nsoil)-dzs(nsoil) )
+
+                  else
+
+                       wtd=zsoil(nsoil)-dzs(nsoil)
+                       smcwtd = smcwtd + totwater / dzs(nsoil)
+!and now even further down
+                       dzup=(smceqdeep-smcwtd)*dzs(nsoil)/(smcmax-smceqdeep)
+                       wtd=wtd-dzup
+                       smcwtd=smceqdeep
+
+                  endif
+
+                endif
+
+
+
+        elseif(wtd.ge.zsoil(nsoil)-dzs(nsoil))then
+
+!if wtd was already below the bottom of the resolved soil crust
+            !gmmequilibrium soil moisture content
+               smceqdeep = smcmax * ( psisat / &
+                           (psisat - dzs(nsoil)) ) ** (1./bexp)
+!               smceqdeep = max(smceqdeep,smcwlt)
+               smceqdeep = max(smceqdeep,1.E-4)
+
+            maxwatdw=dzs(nsoil)*(smcwtd-smceqdeep)
+
+            if(-totwater.le.maxwatdw)then
+
+               smcwtd = smcwtd + totwater / dzs(nsoil)
+               wtd = max( ( smcwtd*dzs(nsoil) &
+                    - smceqdeep*zsoil(nsoil) + smcmax*(zsoil(nsoil)-dzs(nsoil)) ) / &
+                    ( smcmax-smceqdeep ) , zsoil(nsoil)-dzs(nsoil) )
+
+            else
+
+               wtd=zsoil(nsoil)-dzs(nsoil)
+               smcwtd = smcwtd + totwater / dzs(nsoil)
+!and now even further down
+               dzup=(smceqdeep-smcwtd)*dzs(nsoil)/(smcmax-smceqdeep)
+               wtd=wtd-dzup
+               smcwtd=smceqdeep
+
+             endif
+
+         else
+!gmmequilibrium soil moisture content
+               wgpmid = smcmax * ( psisat / &
+                    (psisat - (zsoil(nsoil)-wtd)) ) ** (1./bexp)
+!               wgpmid=max(wgpmid,smcwlt)
+               wgpmid=max(wgpmid,1.E-4)
+               syielddw=smcmax-wgpmid
+               wtdold=wtd
+               wtd = wtdold + totwater/syielddw
+!update wtdwgp
+               smcwtd = (smcwtd*(zsoil(nsoil)-wtdold)+wgpmid*(wtdold-wtd) ) / (zsoil(nsoil)-wtd)
+
+          endif
+
+          qspring=0.
+
+ENDIF
+
+         SH2O = SMC - SICE
+
+
+END  SUBROUTINE UPDATEWTD
+
+! ----------------------------------------------------------------------
+
+END MODULE module_sf_noahmp_groundwater
diff --git a/wrfv2_fire/phys/module_sf_noahmpdrv.F b/wrfv2_fire/phys/module_sf_noahmpdrv.F
index 97b7cc52..f1334be0 100644
--- a/wrfv2_fire/phys/module_sf_noahmpdrv.F
+++ b/wrfv2_fire/phys/module_sf_noahmpdrv.F
@@ -7,6 +7,7 @@ MODULE module_sf_noahmpdrv
   USE module_sf_noah_seaice
   USE module_sf_noahmp_glacier
   USE MODULE_RA_GFDLETA, ONLY: CAL_MON_DAY
+  USE module_sf_noahmp_groundwater, ONLY : LATERALFLOW
 #ifdef WRF_CHEM
   USE module_data_gocart_dust
 #endif
@@ -33,6 +34,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
                QSNOWXY, WSLAKEXY,    ZWTXY,      WAXY,     WTXY,    TSNOXY, & ! IN/OUT Noah MP only
 	       ZSNSOXY,  SNICEXY,  SNLIQXY,  LFMASSXY, RTMASSXY,  STMASSXY, & ! IN/OUT Noah MP only
 	        WOODXY, STBLCPXY, FASTCPXY,    XLAIXY,   XSAIXY,   TAUSSXY, & ! IN/OUT Noah MP only
+	       SMOISEQ, SMCWTDXY,DEEPRECHXY,   RECHXY,                      & ! IN/OUT Noah MP only
 	        T2MVXY,   T2MBXY,    Q2MVXY,   Q2MBXY,                      & ! OUT Noah MP only
 	        TRADXY,    NEEXY,    GPPXY,     NPPXY,   FVEGXY,   RUNSFXY, & ! OUT Noah MP only
 	       RUNSBXY,   ECANXY,   EDIRXY,   ETRANXY,    FSAXY,    FIRAXY, & ! OUT Noah MP only
@@ -41,6 +43,9 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
 		 SHGXY,    SHCXY,    SHBXY,     EVGXY,    EVBXY,     GHVXY, & ! OUT Noah MP only
 		 GHBXY,    IRGXY,    IRCXY,     IRBXY,     TRXY,     EVCXY, & ! OUT Noah MP only
               CHLEAFXY,   CHUCXY,   CHV2XY,    CHB2XY,                      & ! OUT Noah MP only
+#ifdef WRF_HYDRO
+               sfcheadrt,INFXSRT,soldrain,                                  &
+#endif
                ids,ide,  jds,jde,  kds,kde,                    &
                ims,ime,  jms,jme,  kms,kme,                    &
                its,ite,  jts,jte,  kts,kte                     )
@@ -91,6 +96,9 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  GLW       ! longwave down at surface [W m-2]
     REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::  P8W3D     ! 3D pressure, valid at interface [Pa]
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  RAINBL    ! precipitation entering land model [mm]
+#ifdef WRF_HYDRO
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  sfcheadrt,INFXSRT,soldrain   ! for WRF-Hydro
+#endif
 
 ! INOUT (with generic LSM equivalent)
 
@@ -148,6 +156,10 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  XLAIXY    ! leaf area index
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  XSAIXY    ! stem area index
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  TAUSSXY   ! snow age factor
+    REAL,    DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(INOUT) ::  SMOISEQ   ! eq volumetric soil moisture [m3/m3]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  SMCWTDXY  ! soil moisture content in the layer to the water table when deep
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  DEEPRECHXY ! recharge to the water table when deep
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  RECHXY    ! recharge to the water table (diagnostic) 
 
 ! OUT (with no Noah LSM equivalent)
 
@@ -228,6 +240,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     REAL                                :: SSOIL        ! soil heat heat (w/m2) 
     REAL                                :: SALB         ! surface albedo (-)
     REAL                                :: FSNO         ! snow cover fraction (-)
+    REAL,   DIMENSION( 1:NSOIL)         :: SMCEQ        ! eq vol. soil moisture (m3/m3)
     REAL,   DIMENSION( 1:NSOIL)         :: SMC          ! vol. soil moisture (m3/m3)
     REAL,   DIMENSION( 1:NSOIL)         :: SMH2O        ! vol. soil liquid water (m3/m3)
     REAL,   DIMENSION(-2:NSOIL)         :: STC          ! snow/soil tmperatures
@@ -255,6 +268,9 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     REAL                                :: ZWT          ! water table depth [m]
     REAL                                :: WA           ! water in the "aquifer" [mm]
     REAL                                :: WT           ! groundwater storage [mm]
+    REAL                                :: SMCWTD       ! soil moisture content in the layer to the water table when deep
+    REAL                                :: DEEPRECH     ! recharge to the water table when deep
+    REAL                                :: RECH         ! recharge to the water table (diagnostic)  
     REAL, DIMENSION(-2:NSOIL)           :: ZSNSO        ! snow layer depth [m]
     REAL, DIMENSION(-2:              0) :: SNICE        ! snow layer ice [mm]
     REAL, DIMENSION(-2:              0) :: SNLIQ        ! snow layer liquid water [mm]
@@ -491,6 +507,10 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
        PLAI                  = XLAIXY  (I,J)                ! leaf area index [-] (no snow effects)
        PSAI                  = XSAIXY  (I,J)                ! stem area index [-] (no snow effects)
        TAUSS                 = TAUSSXY (I,J)                ! non-dimensional snow age
+       SMCEQ(       1:NSOIL) = SMOISEQ (I,       1:NSOIL,J)
+       SMCWTD                = SMCWTDXY(I,J)
+       RECH                  = 0.
+       DEEPRECH              = 0.
 
 ! Initialized local
 
@@ -530,12 +550,16 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     IF ( ICE == -1 ) THEN
 
 
-       CALL NOAHMP_GLACIER(       I,       J,    COSZ,   NSNOW,   NSOIL,      DT, & ! IN : Time/Space/Model-related
+      CALL NOAHMP_OPTIONS_GLACIER(IDVEG  ,IOPT_CRS  ,IOPT_BTR  ,IOPT_RUN  ,IOPT_SFC  ,IOPT_FRZ , &
+                      IOPT_INF  ,IOPT_RAD  ,IOPT_ALB  ,IOPT_SNF  ,IOPT_TBOT, IOPT_STC )
+      
+      TBOT = MIN(TBOT,263.15)                      ! set deep temp to at most -10C
+      CALL NOAHMP_GLACIER(       I,       J,    COSZ,   NSNOW,   NSOIL,      DT, & ! IN : Time/Space/Model-related
                                T_ML,    P_ML,    U_ML,    V_ML,    Q_ML,    SWDN, & ! IN : Forcing
                                PRCP,    LWDN,    TBOT,    Z_ML, FICEOLD,   ZSOIL, & ! IN : Forcing
                               QSNOW,  SNEQVO,  ALBOLD,      CM,      CH,   ISNOW, & ! IN/OUT :
                                 SWE,     SMC,   ZSNSO,  SNDPTH,   SNICE,   SNLIQ, & ! IN/OUT :
-                                TGB,     STC,   SMH2O,   TAUSS,  QSFC1D,          & ! IN/OUT :
+                                 TG,     STC,   SMH2O,   TAUSS,  QSFC1D,          & ! IN/OUT :
                                 FSA,     FSR,    FIRA,     FSH,    FGEV,   SSOIL, & ! OUT : 
                                TRAD,   ESOIL,   RUNSF,   RUNSB,     SAG,    SALB, & ! OUT :
                               QSNBOT,PONDING,PONDING1,PONDING2,    T2MB,    Q2MB, & ! OUT :
@@ -543,7 +567,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
 
        FSNO   = 1.0       
        TV     = undefined_value     ! Output from standard Noah-MP undefined for glacier points
-       TG     = TGB 
+       TGB    = TG 
        CANICE = undefined_value 
        CANLIQ = undefined_value 
        EAH    = undefined_value 
@@ -598,6 +622,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
        FCTR   = undefined_value        
        
        QFX(I,J) = ESOIL
+       LH (I,J) = FGEV
 
 
     ELSE
@@ -654,7 +679,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
             I       , J       , LAT     , YEARLEN , JULIAN  , COSZ    , & ! IN : Time/Space-related
             DT      , DX      , DZ8W1D  , NSOIL   , ZSOIL   , NSNOW   , & ! IN : Model configuration 
             FVEG    , FVGMAX  , VEGTYP  , ISURBAN , ICE     , IST     , & ! IN : Vegetation/Soil characteristics
-            ISC     ,                                                   & ! IN : Vegetation/Soil characteristics
+            ISC     , SMCEQ   ,                                         & ! IN : Vegetation/Soil characteristics
             IZ0TLND ,                                                   & ! IN : User options
             T_ML    , P_ML    , PSFC    , U_ML    , V_ML    , Q_ML    , & ! IN : Forcing
             QC      , SWDN    , LWDN    , PRCP    , TBOT    , CO2PP   , & ! IN : Forcing
@@ -666,6 +691,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
             ZWT     , WA      , WT      , WSLAKE  , LFMASS  , RTMASS  , & ! IN/OUT : 
             STMASS  , WOOD    , STBLCP  , FASTCP  , PLAI    , PSAI    , & ! IN/OUT : 
             CM      , CH      , TAUSS   ,                               & ! IN/OUT : 
+            SMCWTD  ,DEEPRECH , RECH    ,                               & ! IN/OUT :
             FSA     , FSR     , FIRA    , FSH     , SSOIL   , FCEV    , & ! OUT : 
             FGEV    , FCTR    , ECAN    , ETRAN   , ESOIL   , TRAD    , & ! OUT : 
             TGB     , TGV     , T2MV    , T2MB    , Q2MV    , Q2MB    , & ! OUT : 
@@ -675,9 +701,19 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
             BGAP    , WGAP    , CHV     , CHB     , EMISSI  ,           & ! OUT : 
             SHG     , SHC     , SHB     , EVG     , EVB     , GHV     , & ! OUT :
 	    GHB     , IRG     , IRC     , IRB     , TR      , EVC     , & ! OUT :
-	    CHLEAF  , CHUC    , CHV2    , CHB2    , FPICE    )            ! OUT :
+	    CHLEAF  , CHUC    , CHV2    , CHB2    , FPICE               &
+#ifdef WRF_HYDRO
+            , sfcheadrt(i,j)                               &
+#endif
+            )            ! OUT :
                   
             QFX(I,J) = ECAN + ESOIL + ETRAN
+            LH       (I,J)                = FCEV + FGEV + FCTR
+
+#ifdef WRF_HYDRO
+            soldrain(i,j) = RUNSB*dt        !mm , underground runoff
+            INFXSRT(i,j) = RUNSF*dt        !mm , surface runoff
+#endif
 
    ENDIF ! glacial split ends 
 
@@ -685,7 +721,6 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
 
              TSK      (I,J)                = TRAD
              HFX      (I,J)                = FSH
-             LH       (I,J)                = FCEV + FGEV + FCTR
              GRDFLX   (I,J)                = SSOIL
 	     SMSTAV   (I,J)                = 0.0  ! [maintained as Noah consistency]
              SMSTOT   (I,J)                = 0.0  ! [maintained as Noah consistency]
@@ -783,6 +818,9 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
              CHUCXY   (I,J)                = CHUC
              CHV2XY   (I,J)                = CHV2
              CHB2XY   (I,J)                = CHB2
+             RECHXY   (I,J)                = RECHXY(I,J) + RECH*1.E3 !RECHARGE TO THE WATER TABLE
+             DEEPRECHXY(I,J)               = DEEPRECHXY(I,J) + DEEPRECH
+             SMCWTDXY(I,J)                 = SMCWTD
 
           ENDIF                                                         ! endif of land-sea test
 
@@ -793,9 +831,9 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
   END SUBROUTINE noahmplsm
 !------------------------------------------------------
 
-  SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,           &
-       TSLB , SMOIS , SH2O , DZS , FNDSOILW , FNDSNOWH ,                      &
-       TSK, isnowxy , tvxy     ,tgxy     ,canicexy ,                          &
+  SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, ISURBAN, &
+       TSLB , SMOIS , SH2O , DZS , FNDSOILW , FNDSNOWH ,   ISICE,iswater  ,             &
+       TSK, isnowxy , tvxy     ,tgxy     ,canicexy ,         TMN,     XICE,   &
        canliqxy ,eahxy    ,tahxy    ,cmxy     ,chxy     ,                     &
        fwetxy   ,sneqvoxy ,alboldxy ,qsnowxy  ,wslakexy ,zwtxy    ,waxy     , &
        wtxy     ,tsnoxy   ,zsnsoxy  ,snicexy  ,snliqxy  ,lfmassxy ,rtmassxy , &
@@ -804,10 +842,13 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,           &
        t2mvxy   ,t2mbxy   ,chstarxy,            &
 !jref:end       
        NSOIL, restart,                 &
-       allowed_to_read ,                         &
+       allowed_to_read , iopt_run,                         &
        ids,ide, jds,jde, kds,kde,                &
        ims,ime, jms,jme, kms,kme,                &
-       its,ite, jts,jte, kts,kte                 )
+       its,ite, jts,jte, kts,kte,                &
+       smoiseq  ,smcwtdxy ,rechxy   ,deeprechxy, areaxy, dx, dy, msftx, msfty,&     ! Optional groundwater
+       wtddt    ,stepwtd  ,dt       ,qrfsxy     ,qspringsxy  , qslatxy    ,  &      ! Optional groundwater
+       fdepthxy ,ht     ,riverbedxy ,eqzwt     ,rivercondxy ,pexpxy            )    ! Optional groundwater
 
 ! Initializing Canopy air temperature to 287 K seems dangerous to me [KWM].
 
@@ -815,12 +856,14 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,           &
          &                           ims,ime, jms,jme, kms,kme,  &
          &                           its,ite, jts,jte, kts,kte
 
-    INTEGER, INTENT(IN)       ::     NSOIL
+    INTEGER, INTENT(IN)       ::     NSOIL, ISICE, ISWATER, ISURBAN,iopt_run
 
     LOGICAL, INTENT(IN)       ::     restart,                    &
          &                           allowed_to_read
 
     REAL,    DIMENSION( NSOIL), INTENT(IN)    ::     DZS  ! Thickness of the soil layers [m]
+    REAL,    INTENT(IN) , OPTIONAL ::     DX, DY
+    REAL,    DIMENSION( ims:ime, jms:jme ) ,  INTENT(IN) , OPTIONAL :: MSFTX,MSFTY
 
     REAL,    DIMENSION( ims:ime, NSOIL, jms:jme ) ,    &
          &   INTENT(INOUT)    ::     SMOIS,                      &
@@ -833,12 +876,15 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,           &
          &                           CANWAT
 
     INTEGER, DIMENSION( ims:ime, jms:jme ),                      &
-         &   INTENT(IN)       ::     ISLTYP
+         &   INTENT(IN)       ::     ISLTYP,  &
+                                     IVGTYP
 
     LOGICAL, INTENT(IN)       ::     FNDSOILW,                   &
          &                           FNDSNOWH
 
     REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: TSK         !skin temperature (k)
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: TMN         !deep soil temperature (k)
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: XICE         !sea ice fraction
     INTEGER, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: isnowxy     !actual no. of snow layers
     REAL, DIMENSION(ims:ime,-2:NSOIL,jms:jme), INTENT(INOUT) :: zsnsoxy  !snow layer depth [m]
     REAL, DIMENSION(ims:ime,-2:              0,jms:jme), INTENT(INOUT) :: tsnoxy   !snow temperature [K]
@@ -868,6 +914,26 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,           &
     REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fastcpxy    !short-lived carbon, shallow soil [g/m2]
     REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: xsaixy      !stem area index
 
+! IOPT_RUN = 5 option
+
+    REAL, DIMENSION(ims:ime,1:nsoil,jms:jme), INTENT(INOUT) , OPTIONAL :: smoiseq !equilibrium soil moisture content [m3m-3]
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: smcwtdxy    !deep soil moisture content [m3m-3]
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: deeprechxy  !deep recharge [m]
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: rechxy      !accumulated recharge [mm]
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: qrfsxy      !accumulated flux from groundwater to rivers [mm]
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: qspringsxy  !accumulated seeping water [mm]
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: qslatxy     !accumulated lateral flow [mm]
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: areaxy      !grid cell area [m2]
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: FDEPTHXY    !efolding depth for transmissivity (m)
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: HT          !terrain height (m)
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: RIVERBEDXY  !riverbed depth (m)
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: EQZWT       !equilibrium water table depth (m)
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: RIVERCONDXY !river conductance
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: PEXPXY      !factor for river conductance
+
+    INTEGER,  INTENT(OUT) , OPTIONAL :: STEPWTD
+    REAL, INTENT(IN) , OPTIONAL :: DT, WTDDT
+
 !jref:start
     REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: t2mvxy        !2m temperature vegetation part (k)
     REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: t2mbxy        !2m temperature bare ground part (k)
@@ -879,13 +945,14 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,           &
     !                                                   the surface (negative)
 
     REAL                      :: BX, SMCMAX, PSISAT
+    REAL                      :: FK
 
     REAL, PARAMETER           :: BLIM  = 5.5
     REAL, PARAMETER           :: HLICE = 3.335E5
     REAL, PARAMETER           :: GRAV = 9.81
     REAL, PARAMETER           :: T0 = 273.15
 
-    INTEGER                   :: errflag
+    INTEGER                   :: errflag, i,j,itf,jtf,ns
 
     character(len=80) :: err_message
     character(len=4)  :: MMINSL
@@ -907,6 +974,19 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,           &
        itf=min0(ite,ide-1)
        jtf=min0(jte,jde-1)
 
+       !
+       ! initialize physical snow height SNOWH
+       !
+       IF(.NOT.FNDSNOWH)THEN
+          ! If no SNOWH do the following
+          CALL wrf_message( 'SNOW HEIGHT NOT FOUND - VALUE DEFINED IN LSMINIT' )
+          DO J = jts,jtf
+             DO I = its,itf
+                SNOWH(I,J)=SNOW(I,J)*0.005               ! SNOW in mm and SNOWH in m
+             ENDDO
+          ENDDO
+       ENDIF
+
        errflag = 0
        DO j = jts,jtf
           DO i = its,itf
@@ -934,10 +1014,24 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,           &
 
        DO J = jts , jtf
           DO I = its , itf
-             BX = BB(ISLTYP(I,J))
-             SMCMAX = MAXSMC(ISLTYP(I,J))
-             PSISAT = SATPSI(ISLTYP(I,J))
-             IF ( ( BX > 0.0 ) .AND. ( SMCMAX > 0.0 ) .AND. ( PSISAT > 0.0 ) ) THEN
+	    IF(IVGTYP(I,J)==ISICE .AND. XICE(I,J) <= 0.0) THEN
+              DO NS=1, NSOIL
+	        SMOIS(I,NS,J) = 1.0                     ! glacier starts all frozen
+	        SH2O(I,NS,J) = 0.0
+	        TSLB(I,NS,J) = MIN(TSLB(I,NS,J),263.15) ! set glacier temp to at most -10C
+              END DO
+	        !TMN(I,J) = MIN(TMN(I,J),263.15)         ! set deep temp to at most -10C
+		SNOW(I,J) = MAX(SNOW(I,J), 10.0)        ! set SWE to at least 10mm
+                SNOWH(I,J)=SNOW(I,J)*0.01               ! SNOW in mm and SNOWH in m
+	    ELSE
+	      
+              BX = BB(ISLTYP(I,J))
+              SMCMAX = MAXSMC(ISLTYP(I,J))
+              DO NS=1, NSOIL
+	        IF ( SMOIS(I,NS,J) > SMCMAX )  SMOIS(I,NS,J) = SMCMAX
+              END DO
+              PSISAT = SATPSI(ISLTYP(I,J))
+              IF ( ( BX > 0.0 ) .AND. ( SMCMAX > 0.0 ) .AND. ( PSISAT > 0.0 ) ) THEN
                 DO NS=1, NSOIL
                    IF ( TSLB(I,NS,J) < 273.149 ) THEN    ! Use explicit as initial soil ice
                       FK=(( (HLICE/(GRAV*(-PSISAT))) *                              &
@@ -948,42 +1042,35 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,           &
                       SH2O(I,NS,J)=SMOIS(I,NS,J)
                    ENDIF
                 END DO
-             ELSE
+              ELSE
                 DO NS=1, NSOIL
                    SH2O(I,NS,J)=SMOIS(I,NS,J)
                 END DO
-             ENDIF
+              ENDIF
+            ENDIF
           ENDDO
        ENDDO
 !  ENDIF
 
 
-       !
-       ! initialize physical snow height SNOWH
-       !
-       IF(.NOT.FNDSNOWH)THEN
-          ! If no SNOWH do the following
-          CALL wrf_message( 'SNOW HEIGHT NOT FOUND - VALUE DEFINED IN LSMINIT' )
-          DO J = jts,jtf
-             DO I = its,itf
-                SNOWH(I,J)=SNOW(I,J)*0.005               ! SNOW in mm and SNOWH in m
-             ENDDO
-          ENDDO
-       ENDIF
-
        DO J = jts,jtf
           DO I = its,itf
              tvxy       (I,J) = TSK(I,J)
+	       if(snow(i,j) > 0.0 .and. tsk(i,j) > 273.15) tvxy(I,J) = 273.15
              tgxy       (I,J) = TSK(I,J)
+	       if(snow(i,j) > 0.0 .and. tsk(i,j) > 273.15) tgxy(I,J) = 273.15
              CANWAT     (I,J) = 0.0
              canliqxy   (I,J) = CANWAT(I,J)
              canicexy   (I,J) = 0.
              eahxy      (I,J) = 2000. 
              tahxy      (I,J) = TSK(I,J)
+	       if(snow(i,j) > 0.0 .and. tsk(i,j) > 273.15) tahxy(I,J) = 273.15
 !             tahxy      (I,J) = 287.
 !jref:start
              t2mvxy     (I,J) = TSK(I,J)
+	       if(snow(i,j) > 0.0 .and. tsk(i,j) > 273.15) t2mvxy(I,J) = 273.15
              t2mbxy     (I,J) = TSK(I,J)
+	       if(snow(i,j) > 0.0 .and. tsk(i,j) > 273.15) t2mbxy(I,J) = 273.15
              chstarxy     (I,J) = 0.1
 !jref:end
 
@@ -995,9 +1082,15 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,           &
              qsnowxy    (I,J) = 0.0
              wslakexy   (I,J) = 0.0
 
-             waxy       (I,J) = 4900.                                       !???
-             wtxy       (I,J) = waxy(i,j)                                   !???
-             zwtxy      (I,J) = (25. + 2.0) - waxy(i,j)/1000/0.2            !???
+             if(iopt_run.ne.5) then 
+                   waxy       (I,J) = 4900.                                       !???
+                   wtxy       (I,J) = waxy(i,j)                                   !???
+                   zwtxy      (I,J) = (25. + 2.0) - waxy(i,j)/1000/0.2            !???
+             else
+                   waxy       (I,J) = 0.
+                   wtxy       (I,J) = 0.
+                   areaxy     (I,J) = (DX * DY) / ( MSFTX(I,J) * MSFTY(I,J) )
+             endif
 
              lfmassxy   (I,J) = 50.         !
              stmassxy   (I,J) = 50.0        !
@@ -1023,6 +1116,47 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,           &
             &           NSOIL , zsoil , snow , tgxy , snowh ,     &
             &           zsnsoxy , tsnoxy , snicexy , snliqxy , isnowxy )
 
+       !initialize arrays for groundwater dynamics iopt_run=5
+
+       if(iopt_run.eq.5) then
+          IF ( PRESENT(smoiseq)     .AND. &
+            PRESENT(smcwtdxy)    .AND. &
+            PRESENT(rechxy)      .AND. &
+            PRESENT(deeprechxy)  .AND. &
+            PRESENT(areaxy)      .AND. &
+            PRESENT(dx)          .AND. &
+            PRESENT(dy)          .AND. &
+            PRESENT(msftx)       .AND. &
+            PRESENT(msfty)       .AND. &
+            PRESENT(wtddt)       .AND. &
+            PRESENT(stepwtd)     .AND. &
+            PRESENT(dt)          .AND. &
+            PRESENT(qrfsxy)      .AND. &
+            PRESENT(qspringsxy)  .AND. &
+            PRESENT(qslatxy)     .AND. &
+            PRESENT(fdepthxy)    .AND. &
+            PRESENT(ht)          .AND. &
+            PRESENT(riverbedxy)  .AND. &
+            PRESENT(eqzwt)       .AND. &
+            PRESENT(rivercondxy) .AND. &
+            PRESENT(pexpxy)            ) THEN
+
+             STEPWTD = nint(WTDDT*60./DT)
+             STEPWTD = max(STEPWTD,1)
+
+              CALL groundwater_init ( & 
+      &       nsoil, zsoil , dzs  ,isltyp, ivgtyp, isurban, isice ,iswater ,wtddt , &
+      &       fdepthxy, ht, riverbedxy, eqzwt, rivercondxy, pexpxy , areaxy, zwtxy,   &
+      &       smois,sh2o, smoiseq, smcwtdxy, deeprechxy, rechxy, qslatxy, qrfsxy, qspringsxy, &
+      &       ids,ide, jds,jde, kds,kde,                    &
+      &       ims,ime, jms,jme, kms,kme,                    &
+      &       its,ite, jts,jte, kts,kte                     )
+
+          ELSE
+             CALL wrf_error_fatal ('Not enough fields to use groundwater option in Noah-MP')
+          END IF
+       endif
+
     ENDIF
   END SUBROUTINE NOAHMP_INIT
 
@@ -1130,6 +1264,242 @@ SUBROUTINE SNOW_INIT ( ims , ime , jms , jme , its , itf , jts , jtf ,
     END DO
 
   END SUBROUTINE SNOW_INIT
+! ==================================================================================================
+! ----------------------------------------------------------------------
+    SUBROUTINE GROUNDWATER_INIT (   &
+            &            NSOIL , ZSOIL , DZS, ISLTYP, IVGTYP, ISURBAN, ISICE ,ISWATER , WTDDT , &
+            &            FDEPTH, TOPO, RIVERBED, EQWTD, RIVERCOND, PEXP , AREA ,WTD ,  &
+            &            SMOIS,SH2O, SMOISEQ, SMCWTDXY, DEEPRECHXY, RECHXY ,  &
+            &            QSLATXY, QRFSXY, QSPRINGSXY,                  &
+            &            ids,ide, jds,jde, kds,kde,                    &
+            &            ims,ime, jms,jme, kms,kme,                    &
+            &            its,ite, jts,jte, kts,kte                     )
+
+
+! ----------------------------------------------------------------------
+  IMPLICIT NONE
+! ----------------------------------------------------------------------
+
+    INTEGER,  INTENT(IN   )   ::     ids,ide, jds,jde, kds,kde,  &
+         &                           ims,ime, jms,jme, kms,kme,  &
+         &                           its,ite, jts,jte, kts,kte
+    INTEGER, INTENT(IN)                              :: NSOIL, ISURBAN, ISWATER ,ISICE
+    REAL,   INTENT(IN)                               ::     WTDDT
+    REAL,    INTENT(IN), DIMENSION(1:NSOIL)          :: ZSOIL,DZS
+    INTEGER, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: ISLTYP, IVGTYP
+    REAL,    INTENT(IN), DIMENSION(ims:ime, jms:jme) :: FDEPTH, TOPO, RIVERBED, EQWTD, RIVERCOND, PEXP , AREA
+    REAL,    INTENT(INOUT), DIMENSION(ims:ime, jms:jme) :: WTD
+    REAL,     DIMENSION( ims:ime , 1:nsoil, jms:jme ), &
+         &    INTENT(INOUT)   ::                          SMOIS, &
+         &                                                 SH2O, &
+         &                                                 SMOISEQ
+    REAL,    INTENT(INOUT), DIMENSION(ims:ime, jms:jme) ::  &
+                                                           SMCWTDXY, &
+                                                           DEEPRECHXY, &
+                                                           RECHXY, &
+                                                           QSLATXY, &
+                                                           QRFSXY, &
+                                                           QSPRINGSXY  
+! local
+    INTEGER  :: I,J,K,ITER,itf,jtf
+    REAL :: BX,SMCMAX,PSISAT,SMCWLT,DWSAT,DKSAT
+    REAL :: FRLIQ,SMCEQDEEP
+    REAL :: DELTAT,RCOND
+    REAL :: AA,BBB,CC,DD,DX,FUNC,DFUNC,DDZ,EXPON,SMC,FLUX
+    REAL, DIMENSION(1:NSOIL) :: SMCEQ
+    REAL,      DIMENSION( ims:ime, jms:jme )    :: QLAT, QRF
+    INTEGER,   DIMENSION( ims:ime, jms:jme )    :: LANDMASK !-1 for water (ice or no ice) and glacial areas, 1 for land where the LSM does its soil moisture calculations
+
+
+       itf=min0(ite,ide-1)
+       jtf=min0(jte,jde-1)
+
+!first compute lateral flow and flow to rivers to initialize deep soil moisture
+
+    DELTAT = WTDDT * 60. !timestep in seconds for this calculation
+
+    WHERE(IVGTYP.NE.ISWATER.AND.IVGTYP.NE.ISICE)
+         LANDMASK=1
+    ELSEWHERE
+         LANDMASK=-1
+    ENDWHERE
+    
+!Calculate lateral flow
+
+    QLAT = 0.
+CALL LATERALFLOW(ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA       &
+                        ,ids,ide,jds,jde,kds,kde                      & 
+                        ,ims,ime,jms,jme,kms,kme                      &
+                        ,its,ite,jts,jte,kts,kte                      )
+                        
+
+!compute flux from grounwater to rivers in the cell
+
+    DO J=jts,jtf
+       DO I=its,itf
+          IF(LANDMASK(I,J).GT.0)THEN
+             IF(WTD(I,J) .GT. RIVERBED(I,J) .AND.  EQWTD(I,J) .GT. RIVERBED(I,J)) THEN
+               RCOND = RIVERCOND(I,J) * EXP(PEXP(I,J)*(WTD(I,J)-EQWTD(I,J)))
+             ELSE    
+               RCOND = RIVERCOND(I,J)
+             ENDIF
+             QRF(I,J) = RCOND * (WTD(I,J)-RIVERBED(I,J)) * DELTAT/AREA(I,J)
+!for now, dont allow it to go from river to groundwater
+             QRF(I,J) = MAX(QRF(I,J),0.) 
+          ELSE
+             QRF(I,J) = 0.
+          ENDIF
+       ENDDO
+    ENDDO
+
+!now compute eq. soil moisture, change soil moisture to be compatible with the water table and compute deep soil moisture
+
+       DO J = jts,jtf
+          DO I = its,itf
+             BX = BB(ISLTYP(I,J))
+             SMCMAX = MAXSMC(ISLTYP(I,J))
+             SMCWLT = WLTSMC (ISLTYP(I,J))
+             IF(IVGTYP(I,J)==ISURBAN)THEN
+                 SMCMAX = 0.45         
+                 SMCWLT = 0.40         
+             ENDIF 
+             DWSAT  = SATDW (ISLTYP(I,J))
+             DKSAT  = SATDK (ISLTYP(I,J))
+             PSISAT = -SATPSI(ISLTYP(I,J))
+           IF ( ( bx > 0.0 ) .AND. ( smcmax > 0.0 ) .AND. ( -psisat > 0.0 ) ) THEN
+             !initialize equilibrium soil moisture for water table diagnostic
+                    CALL EQSMOISTURE(NSOIL ,  ZSOIL , SMCMAX , SMCWLT ,DWSAT, DKSAT  ,BX  , & !in
+                                     SMCEQ                          )  !out
+
+             SMOISEQ (I,1:NSOIL,J) = SMCEQ (1:NSOIL)
+
+
+              !make sure that below the water table the layers are saturated and initialize the deep soil moisture
+             IF(WTD(I,J) < ZSOIL(NSOIL)-DZS(NSOIL)) THEN
+
+!initialize deep soil moisture so that the flux compensates qlat+qrf
+!use Newton-Raphson method to find soil moisture
+
+                         EXPON = 2. * BX + 3.
+                         DDZ = ZSOIL(NSOIL) - WTD(I,J)
+                         CC = PSISAT/DDZ
+                         FLUX = (QLAT(I,J)-QRF(I,J))/DELTAT
+
+                         SMC = 0.5 * SMCMAX
+
+                         DO ITER = 1, 100
+                           DD = (SMC+SMCMAX)/(2.*SMCMAX)
+                           AA = -DKSAT * DD  ** EXPON
+                           BBB = CC * ( (SMCMAX/SMC)**BX - 1. ) + 1. 
+                           FUNC =  AA * BBB - FLUX
+                           DFUNC = -DKSAT * (EXPON/(2.*SMCMAX)) * DD ** (EXPON - 1.) * BBB &
+                                   + AA * CC * (-BX) * SMCMAX ** BX * SMC ** (-BX-1.)
+
+                           DX = FUNC/DFUNC
+                           SMC = SMC - DX
+                           IF ( ABS (DX) < 1.E-6)EXIT
+                         ENDDO
+
+                  SMCWTDXY(I,J) = MAX(SMC,1.E-4)
+
+             ELSEIF(WTD(I,J) < ZSOIL(NSOIL))THEN
+                  SMCEQDEEP = SMCMAX * ( PSISAT / ( PSISAT - DZS(NSOIL) ) ) ** (1./BX)
+!                  SMCEQDEEP = MAX(SMCEQDEEP,SMCWLT)
+                  SMCEQDEEP = MAX(SMCEQDEEP,1.E-4)
+                  SMCWTDXY(I,J) = SMCMAX * ( WTD(I,J) -  (ZSOIL(NSOIL)-DZS(NSOIL))) + &
+                                  SMCEQDEEP * (ZSOIL(NSOIL) - WTD(I,J))
+
+             ELSE !water table within the resolved layers
+                  SMCWTDXY(I,J) = SMCMAX
+                  DO K=NSOIL,2,-1
+                     IF(WTD(I,J) .GE. ZSOIL(K-1))THEN
+                          FRLIQ = SH2O(I,K,J) / SMOIS(I,K,J)
+                          SMOIS(I,K,J) = SMCMAX
+                          SH2O(I,K,J) = SMCMAX * FRLIQ
+                     ELSE
+                          IF(SMOIS(I,K,J).LT.SMCEQ(K))THEN
+                              WTD(I,J) = ZSOIL(K)
+                          ELSE
+                              WTD(I,J) = ( SMOIS(I,K,J)*DZS(K) - SMCEQ(K)*ZSOIL(K-1) + SMCMAX*ZSOIL(K) ) / &
+                                         (SMCMAX - SMCEQ(K))   
+                          ENDIF
+                          EXIT
+                     ENDIF
+                  ENDDO
+             ENDIF
+            ELSE
+              SMOISEQ (I,1:NSOIL,J) = SMCMAX
+              SMCWTDXY(I,J) = SMCMAX
+              WTD(I,J) = 0.
+            ENDIF
+
+!zero out some arrays
+
+             DEEPRECHXY(I,J) = 0.
+             RECHXY(I,J) = 0.
+             QSLATXY(I,J) = 0.
+             QRFSXY(I,J) = 0.
+             QSPRINGSXY(I,J) = 0.
+
+          ENDDO
+       ENDDO
+
+
+
+
+    END  SUBROUTINE GROUNDWATER_INIT
+! ==================================================================================================
+! ----------------------------------------------------------------------
+  SUBROUTINE EQSMOISTURE(NSOIL  ,  ZSOIL , SMCMAX , SMCWLT, DWSAT , DKSAT ,BEXP , & !in
+                         SMCEQ                          )  !out
+! ----------------------------------------------------------------------
+  IMPLICIT NONE
+! ----------------------------------------------------------------------
+! input
+  INTEGER,                         INTENT(IN) :: NSOIL !no. of soil layers
+  REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m]
+  REAL,                            INTENT(IN) :: SMCMAX , SMCWLT, BEXP , DWSAT, DKSAT
+!output
+  REAL,  DIMENSION(      1:NSOIL), INTENT(OUT) :: SMCEQ  !equilibrium soil water  content [m3/m3]
+!local
+  INTEGER                                     :: K , ITER
+  REAL                                        :: DDZ , SMC, FUNC, DFUNC , AA, BB , EXPON, DX
+
+!gmmcompute equilibrium soil moisture content for the layer when wtd=zsoil(k)
+
+
+   DO K=1,NSOIL
+
+            IF ( K == 1 )THEN
+                DDZ = -ZSOIL(K+1) * 0.5
+            ELSEIF ( K < NSOIL ) THEN
+                DDZ = ( ZSOIL(K-1) - ZSOIL(K+1) ) * 0.5
+            ELSE
+                DDZ = ZSOIL(K-1) - ZSOIL(K)
+            ENDIF
+
+!use Newton-Raphson method to find eq soil moisture
+
+            EXPON = BEXP +1.
+            AA = DWSAT/DDZ
+            BB = DKSAT / SMCMAX ** EXPON
+
+            SMC = 0.5 * SMCMAX
+
+         DO ITER = 1, 100
+            FUNC = (SMC - SMCMAX) * AA +  BB * SMC ** EXPON
+            DFUNC = AA + BB * EXPON * SMC ** BEXP 
+
+            DX = FUNC/DFUNC
+            SMC = SMC - DX
+            IF ( ABS (DX) < 1.E-6)EXIT
+         ENDDO
+
+!             SMCEQ(K) = MIN(MAX(SMC,SMCWLT),SMCMAX*0.99)
+             SMCEQ(K) = MIN(MAX(SMC,1.E-4),SMCMAX*0.99)
+   ENDDO
+
+END  SUBROUTINE EQSMOISTURE
 !
 !------------------------------------------------------------------------------------------
 !------------------------------------------------------------------------------------------
diff --git a/wrfv2_fire/phys/module_sf_noahmplsm.F b/wrfv2_fire/phys/module_sf_noahmplsm.F
index 483de019..1af9c19f 100644
--- a/wrfv2_fire/phys/module_sf_noahmplsm.F
+++ b/wrfv2_fire/phys/module_sf_noahmplsm.F
@@ -152,6 +152,7 @@ module noahmp_globals
 ! 2 -> TOPMODEL with an equilibrium water table (Niu et al. 2005 JGR) ;
 ! 3 -> original surface and subsurface runoff (free drainage)
 ! 4 -> BATS surface and subsurface runoff (free drainage)
+! 5 -> Miguez-Macho&Fan groundwater scheme (Miguez-Macho et al. 2007 JGR, lateral flow: Fan et al. 2007 JGR)
 
   INTEGER :: OPT_RUN != 1    !(suggested 1)
 
@@ -205,7 +206,7 @@ module noahmp_globals
 
 ! adjustable parameters for snow processes
 
-  REAL, PARAMETER :: M      = 1.0 ! 2.50   !melting factor (-) 
+  REAL, PARAMETER :: M      = 2.50   !melting factor (-) 
   REAL, PARAMETER :: Z0SNO  = 0.002  !snow surface roughness length (m) (0.002)
   REAL, PARAMETER :: SSI    = 0.03   !liquid water holding capacity for snowpack (m3/m3) (0.03)
   REAL, PARAMETER :: SWEMX  = 1.00   !new snow mass to fully cover old snow (mm)
@@ -314,14 +315,14 @@ subroutine read_mp_veg_parameters(DATASET_IDENTIFIER)
     NAMELIST / noah_mp_usgs_veg_categories / VEG_DATASET_DESCRIPTION, NVEG
     NAMELIST / noah_mp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISSNOW, EBLFOREST, &
          CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, RHOL,  RHOS, TAUL, TAUS, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, &
-         LTOVRC,  DILEFC,  DILEFW,  RMF25 ,  SLA   ,  FRAGR ,  TMIN  ,  VCMX25,  TDLEF ,  BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP,   &
-         SAIM,  LAIM,  SLAREA, EPS
+         LTOVRC,  DILEFC,  DILEFW,  RMF25 ,  SLA   ,  FRAGR ,  TMIN  ,  VCMX25,  TDLEF ,  BP, MP, QE25, RMS25, RMR25, ARM, &
+         FOLNMX, WDPOOL, WRRAT, MRP, SAIM,  LAIM,  SLAREA, EPS
 
     NAMELIST / noah_mp_modis_veg_categories / VEG_DATASET_DESCRIPTION, NVEG
     NAMELIST / noah_mp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISSNOW, EBLFOREST, &
          CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, RHOL,  RHOS, TAUL, TAUS, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, &
-         LTOVRC,  DILEFC,  DILEFW,  RMF25 ,  SLA   ,  FRAGR ,  TMIN  ,  VCMX25,  TDLEF ,  BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP,   &
-         SAIM,  LAIM,  SLAREA, EPS
+         LTOVRC,  DILEFC,  DILEFW,  RMF25 ,  SLA   ,  FRAGR ,  TMIN  ,  VCMX25,  TDLEF ,  BP, MP, QE25, RMS25, RMR25, ARM, &
+         FOLNMX, WDPOOL, WRRAT, MRP, SAIM,  LAIM,  SLAREA, EPS
 
     ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything.
     CH2OP  = -1.E36
@@ -525,6 +526,7 @@ MODULE NOAHMP_ROUTINES
 !  private ::                         INFIL       
   private ::               SSTEP
   private ::       GROUNDWATER
+  private ::       SHALLOWWATERTABLE
 
   private :: CARBON
   private ::       CO2FLUX
@@ -541,7 +543,7 @@ SUBROUTINE NOAHMP_SFLX (&
                    ILOC    , JLOC    , LAT     , YEARLEN , JULIAN  , COSZ    , & ! IN : Time/Space-related
                    DT      , DX      , DZ8W    , NSOIL   , ZSOIL   , NSNOW   , & ! IN : Model configuration 
                    SHDFAC  , SHDMAX  , VEGTYP  , ISURBAN , ICE     , IST     , & ! IN : Vegetation/Soil characteristics
-                   ISC     ,                                                   & ! IN : Vegetation/Soil characteristics
+                   ISC     , SMCEQ   ,                                         & ! IN : Vegetation/Soil characteristics
                    IZ0TLND ,                                                   & ! IN : User options
                    SFCTMP  , SFCPRS  , PSFC    , UU      , VV      , Q2      , & ! IN : Forcing
                    QC      , SOLDN   , LWDN    , PRCP    , TBOT    , CO2AIR  , & ! IN : Forcing
@@ -553,6 +555,7 @@ SUBROUTINE NOAHMP_SFLX (&
                    ZWT     , WA      , WT      , WSLAKE  , LFMASS  , RTMASS  , & ! IN/OUT : 
                    STMASS  , WOOD    , STBLCP  , FASTCP  , LAI     , SAI     , & ! IN/OUT : 
                    CM      , CH      , TAUSS   ,                               & ! IN/OUT : 
+                   SMCWTD  ,DEEPRECH , RECH    ,                               & ! IN/OUT :
                    FSA     , FSR     , FIRA    , FSH     , SSOIL   , FCEV    , & ! OUT : 
                    FGEV    , FCTR    , ECAN    , ETRAN   , EDIR    , TRAD    , & ! OUT :
                    TGB     , TGV     , T2MV    , T2MB    , Q2V     , Q2B     , & ! OUT :
@@ -562,7 +565,11 @@ SUBROUTINE NOAHMP_SFLX (&
                    BGAP    , WGAP    , CHV     , CHB     , EMISSI  ,           & ! OUT :
 		   SHG     , SHC     , SHB     , EVG     , EVB     , GHV     , & ! OUT :
 		   GHB     , IRG     , IRC     , IRB     , TR      , EVC     , & ! OUT :
-		   CHLEAF  , CHUC    , CHV2    , CHB2    , FPICE    )            ! OUT :
+		   CHLEAF  , CHUC    , CHV2    , CHB2    , FPICE               &
+#ifdef WRF_HYDRO
+                   ,SFCHEADRT                                                  & ! IN/OUT :
+#endif
+                   )
 
 ! --------------------------------------------------------------------------------------------------
 ! Initial code: Guo-Yue Niu, Oct. 2007
@@ -600,6 +607,7 @@ SUBROUTINE NOAHMP_SFLX (&
   REAL                           , INTENT(IN)    :: JULIAN !Julian day of year (floating point)
   REAL                           , INTENT(IN)    :: LAT    !latitude (radians)
   REAL, DIMENSION(-NSNOW+1:    0), INTENT(IN)    :: FICEOLD!ice fraction at last timestep
+  REAL, DIMENSION(       1:NSOIL), INTENT(IN)    :: SMCEQ  !equilibrium soil water  content [m3/m3]
 
 !jref:start; in 
   INTEGER                        , INTENT(IN)    :: ISURBAN
@@ -613,6 +621,10 @@ SUBROUTINE NOAHMP_SFLX (&
   REAL                           , INTENT(IN)    :: SHDMAX  !yearly max vegetation fraction
 !jref:end
 
+#ifdef WRF_HYDRO
+  REAL                           , INTENT(INOUT)    :: sfcheadrt
+#endif
+
 ! input/output : need arbitary intial values
   REAL                           , INTENT(INOUT) :: QSNOW  !snowfall [mm/s]
   REAL                           , INTENT(INOUT) :: FWET   !wetted or snowed fraction of canopy (-)
@@ -642,6 +654,9 @@ SUBROUTINE NOAHMP_SFLX (&
   REAL                           , INTENT(INOUT) :: WA     !water storage in aquifer [mm]
   REAL                           , INTENT(INOUT) :: WT     !water in aquifer&saturated soil [mm]
   REAL                           , INTENT(INOUT) :: WSLAKE !lake water storage (can be neg.) (mm)
+  REAL,                            INTENT(INOUT) :: SMCWTD !soil water content between bottom of the soil and water table [m3/m3]
+  REAL,                            INTENT(INOUT) :: DEEPRECH !recharge to or from the water table when deep [m]
+  REAL,                            INTENT(INOUT) :: RECH !recharge to or from the water table when shallow [m] (diagnostic)
 
 ! output
   REAL                           , INTENT(OUT)   :: FSA    !total absorbed solar radiation (w/m2)
@@ -774,6 +789,10 @@ SUBROUTINE NOAHMP_SFLX (&
   REAL                                           :: AUTORS !net ecosystem respiration (g/m2/s C)
   REAL                                           :: HETERS !organic respiration (g/m2/s C)
   REAL                                           :: TROOT  !root-zone averaged temperature (k)
+  REAL                                 :: LATHEAV !latent heat vap./sublimation (j/kg)
+  REAL                                 :: LATHEAG !latent heat vap./sublimation (j/kg)
+  LOGICAL                             :: FROZEN_GROUND ! used to define latent heat pathway
+  LOGICAL                             :: FROZEN_CANOPY ! used to define latent heat pathway
 
   ! INTENT (OUT) variables need to be assigned a value.  These normally get assigned values
   ! only if DVEG == 2.
@@ -867,7 +886,7 @@ SUBROUTINE NOAHMP_SFLX (&
                  SAV    ,SAG    ,QMELT  ,FSA    ,FSR    ,TAUX   , & !out
                  TAUY   ,FIRA   ,FSH    ,FCEV   ,FGEV   ,FCTR   , & !out
                  TRAD   ,PSN    ,APAR   ,SSOIL  ,BTRANI ,BTRAN  , & !out
-                 PONDING,TS     ,LATHEA ,                         & !out
+                 PONDING,TS     ,LATHEAV , LATHEAG , frozen_canopy,frozen_ground,                         & !out
                  TV     ,TG     ,STC    ,SNOWH  ,EAH    ,TAH    , & !inout
                  SNEQVO ,SNEQV  ,SH2O   ,SMC    ,SNICE  ,SNLIQ  , & !inout
                  ALBOLD ,CM     ,CH     ,DX     ,DZ8W   ,Q2     , & !inout
@@ -879,13 +898,13 @@ SUBROUTINE NOAHMP_SFLX (&
                  Q1     ,Q2V    ,Q2B    ,Q2E    ,CHV   ,CHB     , & !out
                  EMISSI,&
 		     SHG,SHC,SHB,EVG,EVB,GHV,GHB,IRG,IRC,IRB,TR,EVC,CHLEAF,CHUC,CHV2,CHB2 )                                            !out
-!jref:end                            
+!jref:end
 
     SICE(:) = MAX(0.0, SMC(:) - SH2O(:))   
     SNEQVO  = SNEQV
 
-    QVAP = MAX( FGEV/LATHEA, 0.)       ! positive part of fgev
-    QDEW = ABS( MIN(FGEV/LATHEA, 0.))  ! negative part of fgev
+    QVAP = MAX( FGEV/LATHEAG, 0.)       ! positive part of fgev; Barlage change to ground v3.6
+    QDEW = ABS( MIN(FGEV/LATHEAG, 0.))  ! negative part of fgev
     EDIR = QVAP - QDEW
 
 ! compute water budgets (water storages, ET components, and runoff)
@@ -893,13 +912,19 @@ SUBROUTINE NOAHMP_SFLX (&
      CALL WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
                  VV     ,FCEV   ,FCTR   ,QPRECC ,QPRECL ,ELAI   , & !in
                  ESAI   ,SFCTMP ,QVAP   ,QDEW   ,ZSOIL  ,BTRANI , & !in
-                 FICEOLD,PONDING,TG     ,IST    ,FVEG   ,iloc,jloc , & !in
+                 FICEOLD,PONDING,TG     ,IST    ,FVEG   ,iloc,jloc , SMCEQ , & !in
+		 LATHEAV , LATHEAG , frozen_canopy,frozen_ground,                        & !in  MB
                  ISNOW  ,CANLIQ ,CANICE ,TV     ,SNOWH  ,SNEQV  , & !inout
                  SNICE  ,SNLIQ  ,STC    ,ZSNSO  ,SH2O   ,SMC    , & !inout
                  SICE   ,ZWT    ,WA     ,WT     ,DZSNSO ,WSLAKE , & !inout
+                 SMCWTD ,DEEPRECH,RECH                          , & !inout
                  CMC    ,ECAN   ,ETRAN  ,FWET   ,RUNSRF ,RUNSUB , & !out
                  QIN    ,QDIS   ,QSNOW  ,PONDING1       ,PONDING2,&
-                 ISURBAN,QSNBOT,FPICE)  !out
+                 ISURBAN,QSNBOT,FPICE                             &
+#ifdef WRF_HYDRO
+                        ,sfcheadrt                     &
+#endif
+                 )  !out
 
 !     write(*,'(a20,10F15.5)') 'SFLX:RUNOFF=',RUNSRF*DT,RUNSUB*DT,EDIR*DT
 
@@ -922,7 +947,7 @@ SUBROUTINE NOAHMP_SFLX (&
                  SNEQV  ,WA     ,SMC    ,DZSNSO ,PRCP   ,ECAN   , & !in
                  ETRAN  ,EDIR   ,RUNSRF ,RUNSUB ,DT     ,NSOIL  , & !in
                  NSNOW  ,IST    ,ERRWAT ,ILOC   , JLOC  ,FVEG   , &
-                 SAV    ,SAG    ,FSRV   ,FSRG)   !in ( Except ERRWAT, which is out )
+                 SAV    ,SAG    ,FSRV   ,FSRG   ,ZWT  )   !in ( Except ERRWAT, which is out )
 
 ! urban - jref
     QFX = ETRAN + ECAN + EDIR
@@ -931,6 +956,11 @@ SUBROUTINE NOAHMP_SFLX (&
        Q2B = QSFC
     END IF
 
+    IF(SNOWH <= 1.E-6 .OR. SNEQV <= 1.E-3) THEN
+     SNOWH = 0.0
+     SNEQV = 0.0
+    END IF
+
     IF(SWDOWN.NE.0.) THEN
       ALBEDO = FSR / SWDOWN
     ELSE
@@ -1064,8 +1094,8 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH  , TV     , LAT   , YEARLEN , JULI
      LAI = WT1*LAIM(VEGTYP,IT1) + WT2*LAIM(VEGTYP,IT2)
      SAI = WT1*SAIM(VEGTYP,IT1) + WT2*SAIM(VEGTYP,IT2)
   ENDIF
-  IF (SAI < 0.1) SAI = 0.0  ! MB: SAI CHECK
-  IF (LAI < 0.1 .OR. SAI == 0.0) LAI = 0.0  ! MB: LAI CHECK
+  IF (SAI < 0.05) SAI = 0.0                  ! MB: SAI CHECK, change to 0.05 v3.6
+  IF (LAI < 0.05 .OR. SAI == 0.0) LAI = 0.0  ! MB: LAI CHECK
 
   IF ( ( VEGTYP == ISWATER ) .OR. ( VEGTYP == ISBARREN ) .OR. ( VEGTYP == ISSNOW ) .or. ( VEGTYP == ISURBAN) ) THEN
      LAI  = 0.
@@ -1077,15 +1107,15 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH  , TV     , LAT   , YEARLEN , JULI
      DB = MIN( MAX(SNOWH - HVB(VEGTYP),0.), HVT(VEGTYP)-HVB(VEGTYP) )
      FB = DB / MAX(1.E-06,HVT(VEGTYP)-HVB(VEGTYP))
 
-     IF(HVT(VEGTYP)> 0. .AND. HVT(VEGTYP) <= 0.5) THEN
-       SNOWHC = HVT(VEGTYP)*EXP(-SNOWH/0.1)
+     IF(HVT(VEGTYP)> 0. .AND. HVT(VEGTYP) <= 1.0) THEN  !MB: change to 1.0 and 0.2 to reflect
+       SNOWHC = HVT(VEGTYP)*EXP(-SNOWH/0.2)             !      changes to HVT in MPTABLE
        FB     = MIN(SNOWH,SNOWHC)/SNOWHC
      ENDIF
 
      ELAI =  LAI*(1.-FB)
      ESAI =  SAI*(1.-FB)
-     IF (ESAI < 0.1) ESAI = 0.0  ! MB: ESAI CHECK
-     IF (ELAI < 0.1 .OR. ESAI == 0.0) ELAI = 0.0  ! MB: LAI CHECK
+     IF (ESAI < 0.05) ESAI = 0.0                   ! MB: ESAI CHECK, change to 0.05 v3.6
+     IF (ELAI < 0.05 .OR. ESAI == 0.0) ELAI = 0.0  ! MB: LAI CHECK
 
      IF (TV .GT. TMIN(VEGTYP)) THEN
          IGS = 1.
@@ -1102,7 +1132,7 @@ SUBROUTINE ERROR (SWDOWN ,FSA    ,FSR    ,FIRA   ,FSH    ,FCEV   , &
                     SNEQV  ,WA     ,SMC    ,DZSNSO ,PRCP   ,ECAN   , &
                     ETRAN  ,EDIR   ,RUNSRF ,RUNSUB ,DT     ,NSOIL  , &
                     NSNOW  ,IST    ,ERRWAT, ILOC   ,JLOC   ,FVEG   , &
-                    SAV    ,SAG    ,FSRV   ,FSRG)
+                    SAV    ,SAG    ,FSRV   ,FSRG   ,ZWT)
 ! --------------------------------------------------------------------------------------------------
 ! check surface energy balance and water balance
 ! --------------------------------------------------------------------------------------------------
@@ -1128,6 +1158,7 @@ SUBROUTINE ERROR (SWDOWN ,FSA    ,FSR    ,FIRA   ,FSH    ,FCEV   , &
   REAL                           , INTENT(IN) :: SAG
   REAL                           , INTENT(IN) :: FSRV
   REAL                           , INTENT(IN) :: FSRG
+  REAL                           , INTENT(IN) :: ZWT
 
   REAL                           , INTENT(IN) :: PRCP   !precipitation rate (kg m-2 s-1)
   REAL                           , INTENT(IN) :: ECAN   !evaporation of intercepted water (mm/s)
@@ -1196,6 +1227,7 @@ SUBROUTINE ERROR (SWDOWN ,FSA    ,FSR    ,FIRA   ,FSH    ,FCEV   , &
         END DO
         ERRWAT = END_WB-BEG_WB-(PRCP-ECAN-ETRAN-EDIR-RUNSRF-RUNSUB)*DT
 
+#ifndef WRF_HYDRO
         IF(ABS(ERRWAT) > 0.1) THEN
            if (ERRWAT > 0) then
               call wrf_message ('The model is gaining water (ERRWAT is positive)')
@@ -1204,13 +1236,15 @@ SUBROUTINE ERROR (SWDOWN ,FSA    ,FSR    ,FIRA   ,FSH    ,FCEV   , &
            endif
            write(message, *) 'ERRWAT =',ERRWAT, "kg m{-2} timestep{-1}"
            call wrf_message(trim(message))
-           WRITE(message,'("    I      J     END_WB     BEG_WB       PRCP       ECAN       EDIR      ETRAN      RUNSRF     RUNSUB")')
+           WRITE(message, &
+           '("    I      J     END_WB     BEG_WB       PRCP       ECAN       EDIR      ETRAN      RUNSRF     RUNSUB")')
            call wrf_message(trim(message))
-           WRITE(message,'(i6,1x,i6,1x,2f15.3,8f11.5)')ILOC,JLOC,END_WB,BEG_WB,PRCP*DT,ECAN*DT,&
-                EDIR*DT,ETRAN*DT,RUNSRF*DT,RUNSUB*DT
+           WRITE(message,'(i6,1x,i6,1x,2f15.3,9f11.5)')ILOC,JLOC,END_WB,BEG_WB,PRCP*DT,ECAN*DT,&
+                EDIR*DT,ETRAN*DT,RUNSRF*DT,RUNSUB*DT,ZWT
            call wrf_message(trim(message))
            call wrf_error_fatal("Water budget problem in NOAHMP LSM")
         END IF
+#endif
    ELSE                 !KWM
       ERRWAT = 0.0      !KWM
    ENDIF
@@ -1230,7 +1264,7 @@ SUBROUTINE ENERGY (ICE    ,VEGTYP ,IST    ,ISC    ,NSNOW  ,NSOIL  , & !in
                      SAV    ,SAG    ,QMELT  ,FSA    ,FSR    ,TAUX   , & !out
                      TAUY   ,FIRA   ,FSH    ,FCEV   ,FGEV   ,FCTR   , & !out
                      TRAD   ,PSN    ,APAR   ,SSOIL  ,BTRANI ,BTRAN  , & !out
-                     PONDING,TS     ,LATHEA ,                         & !out
+                     PONDING,TS     ,LATHEAV , LATHEAG , frozen_canopy,frozen_ground,                       & !out
                      TV     ,TG     ,STC    ,SNOWH  ,EAH    ,TAH    , & !inout
                      SNEQVO ,SNEQV  ,SH2O   ,SMC    ,SNICE  ,SNLIQ  , & !inout
                      ALBOLD ,CM     ,CH     ,DX     ,DZ8W   ,Q2     , &   !inout
@@ -1366,7 +1400,11 @@ SUBROUTINE ENERGY (ICE    ,VEGTYP ,IST    ,ISC    ,NSNOW  ,NSOIL  , & !in
   REAL                              , INTENT(OUT)   :: SSOIL  !ground heat flux (w/m2)   [+ to soil]
   REAL   , DIMENSION(       1:NSOIL), INTENT(OUT)   :: BTRANI !soil water transpiration factor (0-1)
   REAL                              , INTENT(OUT)   :: BTRAN  !soil water transpiration factor (0-1)
-  REAL                              , INTENT(OUT)   :: LATHEA !latent heat vap./sublimation (j/kg)
+!  REAL                              , INTENT(OUT)   :: LATHEA !latent heat vap./sublimation (j/kg)
+  REAL                              , INTENT(OUT)   :: LATHEAV !latent heat vap./sublimation (j/kg)
+  REAL                              , INTENT(OUT)   :: LATHEAG !latent heat vap./sublimation (j/kg)
+  LOGICAL                           , INTENT(OUT)   :: FROZEN_GROUND ! used to define latent heat pathway
+  LOGICAL                           , INTENT(OUT)   :: FROZEN_CANOPY ! used to define latent heat pathway
 
 !jref:start  
   REAL                              , INTENT(OUT)   :: FSRV    !veg. reflected solar radiation (w/m2)
@@ -1444,7 +1482,9 @@ SUBROUTINE ENERGY (ICE    ,VEGTYP ,IST    ,ISC    ,NSNOW  ,NSOIL  , & !in
   REAL                                              :: FMELT  !melting factor for snow cover frac
   REAL                                              :: GX     !temporary variable
   REAL, DIMENSION(-NSNOW+1:NSOIL)                   :: PHI    !light through water (w/m2)
-  REAL                                              :: GAMMA  !psychrometric constant (pa/k)
+!  REAL                                              :: GAMMA  !psychrometric constant (pa/k)
+  REAL                                              :: GAMMAV  !psychrometric constant (pa/k)
+  REAL                                              :: GAMMAG  !psychrometric constant (pa/k)
   REAL                                              :: PSI    !surface layer soil matrix potential (m)
   REAL                                              :: RHSUR  !raltive humidity in surface soil/snow air space (-)
 
@@ -1654,12 +1694,30 @@ SUBROUTINE ENERGY (ICE    ,VEGTYP ,IST    ,ISC    ,NSNOW  ,NSOIL  , & !in
 
 ! set psychrometric constant
 
-     IF (SFCTMP .GT. TFRZ) THEN
-        LATHEA = HVAP
+     IF (TV .GT. TFRZ) THEN           ! Barlage: add distinction between ground and 
+        LATHEAV = HVAP                ! vegetation in v3.6
+	frozen_canopy = .false.
      ELSE
-        LATHEA = HSUB
+        LATHEAV = HSUB
+	frozen_canopy = .true.
      END IF
-     GAMMA = CPAIR*SFCPRS/(0.622*LATHEA)
+     GAMMAV = CPAIR*SFCPRS/(0.622*LATHEAV)
+
+     IF (TG .GT. TFRZ) THEN
+        LATHEAG = HVAP
+	frozen_ground = .false.
+     ELSE
+        LATHEAG = HSUB
+	frozen_ground = .true.
+     END IF
+     GAMMAG = CPAIR*SFCPRS/(0.622*LATHEAG)
+
+!     IF (SFCTMP .GT. TFRZ) THEN
+!        LATHEA = HVAP
+!     ELSE
+!        LATHEA = HSUB
+!     END IF
+!     GAMMA = CPAIR*SFCPRS/(0.622*LATHEA)
 
 ! Surface temperatures of the ground and canopy and energy fluxes
 
@@ -1670,12 +1728,12 @@ SUBROUTINE ENERGY (ICE    ,VEGTYP ,IST    ,ISC    ,NSNOW  ,NSOIL  , & !in
     CALL VEGE_FLUX (NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , & !in
                     DT      ,SAV     ,SAG     ,LWDN    ,UR      , & !in
                     UU      ,VV      ,SFCTMP  ,THAIR   ,QAIR    , & !in
-                    EAIR    ,RHOAIR  ,SNOWH   ,VAI     ,GAMMA   , & !in
+                    EAIR    ,RHOAIR  ,SNOWH   ,VAI     ,GAMMAV   ,GAMMAG   , & !in
                     FWET    ,LAISUN  ,LAISHA  ,CWP     ,DZSNSO  , & !in
                     HTOP    ,ZLVL    ,ZPD     ,Z0M     ,FVEG    , & !in
                     Z0MG    ,EMV     ,EMG     ,CANLIQ           , & !in
                     CANICE  ,STC     ,DF      ,RSSUN   ,RSSHA   , & !in
-                    RSURF   ,LATHEA  ,PARSUN  ,PARSHA  ,IGS     , & !in
+                    RSURF   ,LATHEAV ,LATHEAG ,PARSUN  ,PARSHA  ,IGS     , & !in
                     FOLN    ,CO2AIR  ,O2AIR   ,BTRAN   ,SFCPRS  , & !in
                     RHSUR   ,ILOC    ,JLOC    ,Q2      , & !in
                     EAH     ,TAH     ,TV      ,TGV     ,CMV     , & !inout
@@ -1696,8 +1754,8 @@ SUBROUTINE ENERGY (ICE    ,VEGTYP ,IST    ,ISC    ,NSNOW  ,NSOIL  , & !in
                     LWDN    ,UR      ,UU      ,VV      ,SFCTMP  , & !in
                     THAIR   ,QAIR    ,EAIR    ,RHOAIR  ,SNOWH   , & !in
                     DZSNSO  ,ZLVL    ,ZPDG    ,Z0MG    ,          & !in
-                    EMG     ,STC     ,DF      ,RSURF   ,LATHEA  , & !in
-                    GAMMA   ,RHSUR   ,ILOC    ,JLOC    ,Q2      , & !in
+                    EMG     ,STC     ,DF      ,RSURF   ,LATHEAG  , & !in
+                    GAMMAG   ,RHSUR   ,ILOC    ,JLOC    ,Q2      , & !in
                     TGB     ,CMB     ,CHB     ,                   & !inout
                     TAUXB   ,TAUYB   ,IRB     ,SHB     ,EVB     , & !out
                     GHB     ,T2MB    ,DX      ,DZ8W    ,VEGTYP  , & !out
@@ -2986,12 +3044,12 @@ END SUBROUTINE TWOSTREAM
   SUBROUTINE VEGE_FLUX(NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , & !in
                        DT      ,SAV     ,SAG     ,LWDN    ,UR      , & !in
                        UU      ,VV      ,SFCTMP  ,THAIR   ,QAIR    , & !in
-                       EAIR    ,RHOAIR  ,SNOWH   ,VAI     ,GAMMA   , & !in
+                       EAIR    ,RHOAIR  ,SNOWH   ,VAI     ,GAMMAV   ,GAMMAG,  & !in
                        FWET    ,LAISUN  ,LAISHA  ,CWP     ,DZSNSO  , & !in
                        HTOP    ,ZLVL    ,ZPD     ,Z0M     ,FVEG    , & !in
                        Z0MG    ,EMV     ,EMG     ,CANLIQ  ,          & !in
                        CANICE  ,STC     ,DF      ,RSSUN   ,RSSHA   , & !in
-                       RSURF   ,LATHEA  ,PARSUN  ,PARSHA  ,IGS     , & !in
+                       RSURF   ,LATHEAV ,LATHEAG  ,PARSUN  ,PARSHA  ,IGS     , & !in
                        FOLN    ,CO2AIR  ,O2AIR   ,BTRAN   ,SFCPRS  , & !in
                        RHSUR   ,ILOC    ,JLOC    ,Q2      , & !in
                        EAH     ,TAH     ,TV      ,TG      ,CM      , & !inout
@@ -3058,8 +3116,12 @@ SUBROUTINE VEGE_FLUX(NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , & !in
   REAL,                            INTENT(IN) :: CANLIQ !intercepted liquid water (mm)
   REAL,                            INTENT(IN) :: CANICE !intercepted ice mass (mm)
   REAL,                            INTENT(IN) :: RSURF  !ground surface resistance (s/m)
-  REAL,                            INTENT(IN) :: GAMMA  !psychrometric constant (pa/K)
-  REAL,                            INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg)
+!  REAL,                            INTENT(IN) :: GAMMA  !psychrometric constant (pa/K)
+!  REAL,                            INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg)
+  REAL,                            INTENT(IN) :: GAMMAV  !psychrometric constant (pa/K)
+  REAL,                            INTENT(IN) :: LATHEAV !latent heat of vaporization/subli (j/kg)
+  REAL,                            INTENT(IN) :: GAMMAG  !psychrometric constant (pa/K)
+  REAL,                            INTENT(IN) :: LATHEAG !latent heat of vaporization/subli (j/kg)
   REAL,                            INTENT(IN) :: PARSUN !par absorbed per unit sunlit lai (w/m2)
   REAL,                            INTENT(IN) :: PARSHA !par absorbed per unit shaded lai (w/m2)
   REAL,                            INTENT(IN) :: FOLN   !foliage nitrogen (%)
@@ -3402,8 +3464,8 @@ SUBROUTINE VEGE_FLUX(NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , & !in
         COND = CAW + CEW + CTW + CGW
         AEA  = (EAIR*CAW + ESTG*CGW) / COND
         BEA  = (CEW+CTW)/COND
-        CEV  = (1.-BEA)*CEW*RHOAIR*CPAIR/GAMMA
-        CTR  = (1.-BEA)*CTW*RHOAIR*CPAIR/GAMMA
+        CEV  = (1.-BEA)*CEW*RHOAIR*CPAIR/GAMMAV   ! Barlage: change to vegetation v3.6
+        CTR  = (1.-BEA)*CTW*RHOAIR*CPAIR/GAMMAV
 
 ! evaluate surface fluxes with current temperature and solve for dts
 
@@ -3412,9 +3474,13 @@ SUBROUTINE VEGE_FLUX(NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , & !in
 
         IRC = FVEG*(AIR + CIR*TV**4)
         SHC = FVEG*RHOAIR*CPAIR*CVH * (  TV-TAH)
-        EVC = FVEG*RHOAIR*CPAIR*CEW * (ESTV-EAH) / GAMMA
-        TR  = FVEG*RHOAIR*CPAIR*CTW * (ESTV-EAH) / GAMMA
-        EVC = MIN(CANLIQ*LATHEA/DT,EVC)
+        EVC = FVEG*RHOAIR*CPAIR*CEW * (ESTV-EAH) / GAMMAV ! Barlage: change to v in v3.6
+        TR  = FVEG*RHOAIR*CPAIR*CTW * (ESTV-EAH) / GAMMAV
+	IF (TV > TFRZ) THEN
+          EVC = MIN(CANLIQ*LATHEAV/DT,EVC)    ! Barlage: add if block for canice in v3.6
+	ELSE
+          EVC = MIN(CANICE*LATHEAV/DT,EVC)
+	END IF
 
         B   = SAV-IRC-SHC-EVC-TR                          !additional w/m2
         A   = FVEG*(4.*CIR*TV**3 + CSH + (CEV+CTR)*DESTV) !volumetric heat capacity
@@ -3438,7 +3504,7 @@ SUBROUTINE VEGE_FLUX(NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , & !in
 
 ! added moisture flux for sfcdif4
         IF ( OPT_SFC == 4 ) THEN
-           QFX = (QSFC-QAIR)*RHOAIR*CAW !*CPAIR/GAMMA
+           QFX = (QSFC-QAIR)*RHOAIR*CAW !*CPAIR/GAMMAV
         ENDIF
 
         IF (LITER == 1) THEN
@@ -3455,7 +3521,7 @@ SUBROUTINE VEGE_FLUX(NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , & !in
         AIR = - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4
         CIR = EMG*SB
         CSH = RHOAIR*CPAIR/RAHG
-        CEV = RHOAIR*CPAIR / (GAMMA*(RAWG+RSURF))
+        CEV = RHOAIR*CPAIR / (GAMMAG*(RAWG+RSURF))  ! Barlage: change to ground v3.6
         CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1)
 
      loop2: DO ITER = 1, NITERG
@@ -3510,8 +3576,8 @@ SUBROUTINE VEGE_FLUX(NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , & !in
 ! calculation.
 !     TAH = SFCTMP + (SHG+SHC)/(RHOAIR*CPAIR*CAH) 
 !     TAH = SFCTMP + (SHG*FVEG+SHC)/(RHOAIR*CPAIR*CAH) ! ground flux need fveg
-!     EAH = EAIR + (EVC+FVEG*(TR+EVG))/(RHOAIR*CAW*CPAIR/GAMMA )
-!     QFX = (QSFC-QAIR)*RHOAIR*CAW !*CPAIR/GAMMA
+!     EAH = EAIR + (EVC+FVEG*(TR+EVG))/(RHOAIR*CAW*CPAIR/GAMMAG )
+!     QFX = (QSFC-QAIR)*RHOAIR*CAW !*CPAIR/GAMMAG
 
 ! 2m temperature over vegetation ( corrected for low CQ2V values )
    IF (OPT_SFC == 1 .OR. OPT_SFC == 2) THEN
@@ -3526,7 +3592,7 @@ SUBROUTINE VEGE_FLUX(NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , & !in
       ELSE
          T2MV = TAH - (SHG+SHC/FVEG)/(RHOAIR*CPAIR) * 1./CAH2
 !         Q2V = (EAH*0.622/(SFCPRS - 0.378*EAH))- QFX/(RHOAIR*FV)* 1./VKC * LOG((2.+Z0H)/Z0H)
-         Q2V = QSFC - ((EVC+TR)/FVEG+EVG)/(LATHEA*RHOAIR) * 1./CQ2V
+         Q2V = QSFC - ((EVC+TR)/FVEG+EVG)/(LATHEAV*RHOAIR) * 1./CQ2V
       ENDIF
    ENDIF
 
@@ -6200,13 +6266,19 @@ END SUBROUTINE FRH2O
   SUBROUTINE WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
                     VV     ,FCEV   ,FCTR   ,QPRECC ,QPRECL ,ELAI   , & !in
                     ESAI   ,SFCTMP ,QVAP   ,QDEW   ,ZSOIL  ,BTRANI , & !in
-                    FICEOLD,PONDING,TG     ,IST    ,FVEG   ,ILOC   ,JLOC , & !in
+                    FICEOLD,PONDING,TG     ,IST    ,FVEG   ,ILOC   ,JLOC ,SMCEQ , & !in
+		    LATHEAV , LATHEAG , frozen_canopy,frozen_ground,                       & !in  MB
                     ISNOW  ,CANLIQ ,CANICE ,TV     ,SNOWH  ,SNEQV  , & !inout
                     SNICE  ,SNLIQ  ,STC    ,ZSNSO  ,SH2O   ,SMC    , & !inout
                     SICE   ,ZWT    ,WA     ,WT     ,DZSNSO ,WSLAKE , & !inout
+                    SMCWTD ,DEEPRECH,RECH                          , & !inout
                     CMC    ,ECAN   ,ETRAN  ,FWET   ,RUNSRF ,RUNSUB , & !out
                     QIN    ,QDIS   ,QSNOW  ,PONDING1       ,PONDING2,&
-                    ISURBAN,QSNBOT,FPICE)  !out
+                    ISURBAN,QSNBOT,FPICE                             &
+#ifdef WRF_HYDRO
+                        ,sfcheadrt                     &
+#endif
+                    )  !out
 ! ----------------------------------------------------------------------  
 ! Code history:
 ! Initial code: Guo-Yue Niu, Oct. 2007
@@ -6239,6 +6311,7 @@ SUBROUTINE WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
 !  REAL                           , INTENT(IN)    :: PONDING ![mm]
   REAL                           , INTENT(IN)    :: TG      !ground temperature (k)
   REAL                           , INTENT(IN)    :: FVEG    !greeness vegetation fraction (-)
+  REAL, DIMENSION(       1:NSOIL), INTENT(IN)    :: SMCEQ   !equilibrium soil water content [m3/m3] (used in m-m&f groundwater dynamics)
 
 ! input/output
   INTEGER,                         INTENT(INOUT) :: ISNOW   !actual no. of snow layers
@@ -6261,6 +6334,9 @@ SUBROUTINE WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
                                                             !+ stuarated soil [mm]
   REAL,                            INTENT(INOUT) :: WSLAKE  !water storage in lake (can be -) (mm)
   REAL                           , INTENT(INOUT) :: PONDING ![mm]
+  REAL,                            INTENT(INOUT) :: SMCWTD !soil water content between bottom of the soil and water table [m3/m3]
+  REAL,                            INTENT(INOUT) :: DEEPRECH !recharge to or from the water table when deep [m]
+  REAL,                            INTENT(INOUT) :: RECH !recharge to or from the water table when shallow [m] (diagnostic)
 
 ! output
   REAL,                            INTENT(OUT)   :: CMC     !intercepted water per ground area (mm)
@@ -6276,6 +6352,10 @@ SUBROUTINE WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
   REAL,                            INTENT(OUT)   :: PONDING2
   REAL,                            INTENT(OUT)   :: QSNBOT  !melting water out of snow bottom [mm/s]
   REAL,                            INTENT(OUT)   :: FPICE   !snow fraction in precipitation
+  REAL                              , INTENT(IN)   :: LATHEAV !latent heat vap./sublimation (j/kg)
+  REAL                              , INTENT(IN)   :: LATHEAG !latent heat vap./sublimation (j/kg)
+  LOGICAL                           , INTENT(IN)   :: FROZEN_GROUND ! used to define latent heat pathway
+  LOGICAL                           , INTENT(IN)   :: FROZEN_CANOPY ! used to define latent heat pathway
 
   INTEGER,                         INTENT(IN)    :: ISURBAN
 
@@ -6295,6 +6375,11 @@ SUBROUTINE WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
   REAL                                           :: FCRMAX !maximum of FCR (-)
 
   REAL, PARAMETER ::  WSLMAX = 5000.      !maximum lake water storage (mm)
+
+#ifdef WRF_HYDRO
+  REAL                           , INTENT(INOUT)    :: sfcheadrt
+#endif
+
 ! ----------------------------------------------------------------------
 ! initialize
 
@@ -6308,6 +6393,7 @@ SUBROUTINE WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
    CALL CANWATER (VEGTYP ,DT     ,SFCTMP ,UU     ,VV     , & !in
                   FCEV   ,FCTR   ,QPRECC ,QPRECL ,ELAI   , & !in
                   ESAI   ,IST    ,TG     ,FVEG   ,ILOC   , JLOC, & !in
+                  FROZEN_CANOPY,                                 & !in     
                   CANLIQ ,CANICE ,TV     ,                 & !inout
                   CMC    ,ECAN   ,ETRAN  ,QRAIN  ,QSNOW  , & !out
                   SNOWHIN,FWET   ,FPICE   )                           !out
@@ -6333,6 +6419,16 @@ SUBROUTINE WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
           &          SH2O   ,SICE   ,STC    ,ZSNSO  ,DZSNSO , & !inout
           &          QSNBOT ,SNOFLOW,PONDING1       ,PONDING2)  !out
 
+   IF(FROZEN_GROUND) THEN
+      SICE(1) =  SICE(1) + (QSDEW-QSEVA)*DT/(DZSNSO(1)*1000.)
+      QSDEW = 0.0
+      QSEVA = 0.0
+      IF(SICE(1) < 0.) THEN
+         SH2O(1) = SH2O(1) + SICE(1)
+         SICE(1) = 0.
+      END IF
+   END IF
+
 ! convert units (mm/s -> m/s)
 
     !PONDING: melting water from snow when there is no layer
@@ -6351,6 +6447,10 @@ SUBROUTINE WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
        ETRANI(IZ) = ETRAN * BTRANI(IZ) * 0.001
     ENDDO
 
+#ifdef WRF_HYDRO
+       QINSUR = QINSUR+sfcheadrt/DT*0.001  !sfcheadrt units (m)
+#endif
+
 ! lake/soil water balances
 
     IF (IST == 2) THEN                                        ! lake
@@ -6361,6 +6461,7 @@ SUBROUTINE WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
        CALL      SOILWATER (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
                             QINSUR ,QSEVA  ,ETRANI ,SICE   ,ILOC   , JLOC , & !in
                             SH2O   ,SMC    ,ZWT    ,VEGTYP ,ISURBAN, & !inout
+                           SMCWTD, DEEPRECH                       , & !inout
                             RUNSRF ,QDRAIN ,RUNSUB ,WCND   ,FCRMAX )   !out
  
        IF(OPT_RUN == 1) THEN 
@@ -6378,6 +6479,17 @@ SUBROUTINE WATER (VEGTYP ,NSNOW  ,NSOIL  ,IMELT  ,DT     ,UU     , & !in
        DO IZ = 1,NSOIL
            SMC(IZ) = SH2O(IZ) + SICE(IZ)
        ENDDO
+ 
+       IF(OPT_RUN == 5) THEN
+          CALL SHALLOWWATERTABLE (NSNOW  ,NSOIL, ZSOIL, DT       , & !in
+                         DZSNSO ,SMCEQ   ,ILOC , JLOC        , & !in
+                         SMC    ,ZWT    ,SMCWTD ,RECH, QDRAIN  ) !inout
+
+          SH2O(NSOIL) = SMC(NSOIL) - SICE(NSOIL)
+          RUNSUB = RUNSUB + QDRAIN !it really comes from subroutine watertable, which is not called with the same frequency as the soil routines here
+          WA = 0.
+       ENDIF
+
     ENDIF
 
     RUNSUB       = RUNSUB + SNOFLOW         !mm/s
@@ -6387,6 +6499,7 @@ END SUBROUTINE WATER
   SUBROUTINE CANWATER (VEGTYP ,DT     ,SFCTMP ,UU     ,VV     , & !in
                        FCEV   ,FCTR   ,QPRECC ,QPRECL ,ELAI   , & !in
                        ESAI   ,IST    ,TG     ,FVEG   ,ILOC   , JLOC , & !in
+                       FROZEN_CANOPY,                                 & !in      
                        CANLIQ ,CANICE ,TV     ,                 & !inout
                        CMC    ,ECAN   ,ETRAN  ,QRAIN  ,QSNOW  , & !out
                        SNOWHIN,FWET   ,FPICE   )                           !out
@@ -6415,6 +6528,7 @@ SUBROUTINE CANWATER (VEGTYP ,DT     ,SFCTMP ,UU     ,VV     , & !in
   INTEGER,INTENT(IN)  :: IST     !surface type 1-soil; 2-lake
   REAL,   INTENT(IN)  :: TG      !ground temperature (k)
   REAL,   INTENT(IN)  :: FVEG    !greeness vegetation fraction (-)
+  LOGICAL                           , INTENT(IN)   :: FROZEN_CANOPY ! used to define latent heat pathway
 
 ! input & output
   REAL, INTENT(INOUT) :: CANLIQ  !intercepted liquid water (mm)
@@ -6509,7 +6623,7 @@ SUBROUTINE CANWATER (VEGTYP ,DT     ,SFCTMP ,UU     ,VV     , & !in
 ! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625
 ! fresh snow density
 
-     BDFALL = MAX(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59))
+     BDFALL = MIN(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59))   ! Barlage: change to MIN in v3.6
 
      RAIN   = (QPRECC + QPRECL) * (1.-FPICE)
      SNOW   = (QPRECC + QPRECL) * FPICE
@@ -6540,7 +6654,7 @@ SUBROUTINE CANWATER (VEGTYP ,DT     ,SFCTMP ,UU     ,VV     , & !in
 
 ! evaporation, transpiration, and dew
 
-      IF (TV .GT. TFRZ) THEN
+      IF (.NOT.FROZEN_CANOPY) THEN             ! Barlage: change to frozen_canopy
         ETRAN = MAX( FCTR/HVAP, 0. )
         QEVAC = MAX( FCEV/HVAP, 0. )
         QDEWC = ABS( MIN( FCEV/HVAP, 0. ) )
@@ -6886,12 +7000,22 @@ SUBROUTINE COMBINE (NSNOW  ,NSOIL  ,ILOC   ,JLOC   ,         & !in
                 SNLIQ(J-1) = SNLIQ(J-1) + SNLIQ(J)
                 SNICE(J-1) = SNICE(J-1) + SNICE(J)
                ELSE
-                PONDING1 = SNLIQ(J)       ! ISNOW WILL GET SET TO ZERO BELOW
-                SNEQV = SNICE(J)          ! PONDING1 WILL GET ADDED TO PONDING FROM
-                SNOWH = DZSNSO(J)         ! PHASECHANGE WHICH SHOULD BE ZERO HERE
-                SNLIQ(J) = 0.0            ! BECAUSE THERE IT WAS ONLY CALCULATED
-                SNICE(J) = 0.0            ! FOR THIN SNOW
-                DZSNSO(J) = 0.0
+	         IF(SNICE(J) >= 0.) THEN
+                  PONDING1 = SNLIQ(J)    ! ISNOW WILL GET SET TO ZERO BELOW; PONDING1 WILL GET 
+                  SNEQV = SNICE(J)       ! ADDED TO PONDING FROM PHASECHANGE PONDING SHOULD BE
+                  SNOWH = DZSNSO(J)      ! ZERO HERE BECAUSE IT WAS CALCULATED FOR THIN SNOW
+		 ELSE   ! SNICE OVER-SUBLIMATED EARLIER
+		  PONDING1 = SNLIQ(J) + SNICE(J)
+		  IF(PONDING1 < 0.) THEN  ! IF SNICE AND SNLIQ SUBLIMATES REMOVE FROM SOIL
+		   SICE(1) = MAX(0.0,SICE(1)+PONDING1/(DZSNSO(1)*1000.))
+                   PONDING1 = 0.0
+		  END IF
+                  SNEQV = 0.0
+                  SNOWH = 0.0
+		 END IF
+                 SNLIQ(J) = 0.0
+                 SNICE(J) = 0.0
+                 DZSNSO(J) = 0.0
                ENDIF
 !                SH2O(1) = SH2O(1)+SNLIQ(J)/(DZSNSO(1)*1000.)
 !                SICE(1) = SICE(1)+SNICE(J)/(DZSNSO(1)*1000.)
@@ -7341,7 +7465,11 @@ SUBROUTINE SNOWH2O (NSNOW  ,NSOIL  ,DT     ,QSNFRO ,QSNSUB , & !in
 !for the case when SNEQV becomes '0' after 'COMBINE'
 
    IF(SNEQV == 0.) THEN
-      SH2O(1) =  SH2O(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.)
+      SICE(1) =  SICE(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.)  ! Barlage: SH2O->SICE v3.6
+      IF(SICE(1) < 0.) THEN
+         SH2O(1) = SH2O(1) + SICE(1)
+         SICE(1) = 0.
+      END IF
    END IF
 
 ! for shallow snow without a layer
@@ -7358,6 +7486,7 @@ SUBROUTINE SNOWH2O (NSNOW  ,NSOIL  ,DT     ,QSNFRO ,QSNSUB , & !in
       IF(SNEQV < 0.) THEN
          SICE(1) = SICE(1) + SNEQV/(DZSNSO(1)*1000.)
          SNEQV   = 0.
+         SNOWH   = 0.
       END IF
       IF(SICE(1) < 0.) THEN
          SH2O(1) = SH2O(1) + SICE(1)
@@ -7365,8 +7494,10 @@ SUBROUTINE SNOWH2O (NSNOW  ,NSOIL  ,DT     ,QSNFRO ,QSNSUB , & !in
       END IF
    END IF
 
-   IF(SNOWH <= 1.E-8) SNOWH = 0.0
-   IF(SNEQV <= 1.E-6) SNEQV = 0.0
+   IF(SNOWH <= 1.E-8 .OR. SNEQV <= 1.E-6) THEN
+     SNOWH = 0.0
+     SNEQV = 0.0
+   END IF
 
 ! for deep snow
 
@@ -7433,6 +7564,7 @@ END SUBROUTINE SNOWH2O
   SUBROUTINE SOILWATER (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
                         QINSUR ,QSEVA  ,ETRANI ,SICE   ,ILOC   , JLOC, & !in
                         SH2O   ,SMC    ,ZWT    ,ISURBAN,VEGTYP ,& !inout
+                        SMCWTD, DEEPRECH                       ,& !inout
                         RUNSRF ,QDRAIN ,RUNSUB ,WCND   ,FCRMAX )   !out
 
 ! ----------------------------------------------------------------------
@@ -7461,6 +7593,8 @@ SUBROUTINE SOILWATER (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
   REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O   !soil liquid water content [m3/m3]
   REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC    !total soil water content [m3/m3]
   REAL, INTENT(INOUT)                     :: ZWT    !water table depth [m]
+  REAL,                     INTENT(INOUT) :: SMCWTD !soil moisture between bottom of the soil and the water table [m3/m3]
+  REAL                    , INTENT(INOUT) :: DEEPRECH
 
 ! output
   REAL, INTENT(OUT)                       :: QDRAIN !soil-bottom free drainage [mm/s] 
@@ -7492,6 +7626,7 @@ SUBROUTINE SOILWATER (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
   REAL, DIMENSION(1:NSOIL)                :: MLIQ   !
   REAL                                    :: XS     !
   REAL                                    :: WATMIN !
+  REAL                                    :: QDRAIN_SAVE !
   REAL                                    :: EPORE  !effective porosity [m3/m3]
   REAL, DIMENSION(1:NSOIL)                :: FCR    !impermeable fraction due to frozen soil
   INTEGER                                 :: NITER  !iteration times soil moisture (-)
@@ -7553,6 +7688,15 @@ SUBROUTINE SOILWATER (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
        END IF
     END IF
 
+    IF(OPT_RUN == 5) THEN
+       FFF = 6.0
+       FSAT   = FSATMX*EXP(-0.5*FFF*MAX(-2.0-ZWT,0.))
+       IF(QINSUR > 0.) THEN
+         RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) )
+         PDDUM  = QINSUR - RUNSRF                          ! m/s
+       END IF
+    END IF
+
     IF(OPT_RUN == 2) THEN
        FFF   = 2.0
        FSAT   = FSATMX*EXP(-0.5*FFF*ZWT)
@@ -7600,24 +7744,31 @@ SUBROUTINE SOILWATER (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
 
 ! solve soil moisture
 
+    QDRAIN_SAVE = 0.0
     DO ITER = 1, NITER
        CALL SRT   (NSOIL  ,ZSOIL  ,DTFINE ,PDDUM  ,ETRANI , & !in
                    QSEVA  ,SH2O   ,SMC    ,ZWT    ,FCR    , & !in
-                   SICEMAX,FCRMAX ,ILOC   ,JLOC   ,         & !in
+                   SICEMAX,FCRMAX ,ILOC   ,JLOC   ,SMCWTD ,         & !in
                    RHSTT  ,AI     ,BI     ,CI     ,QDRAIN , & !out
                    WCND   )                                   !out
   
        CALL SSTEP (NSOIL  ,NSNOW  ,DTFINE ,ZSOIL  ,DZSNSO , & !in
-                   SICE   ,ILOC   ,JLOC   ,                 & !in
+                   SICE   ,ILOC   ,JLOC   ,ZWT            ,                 & !in
                    SH2O   ,SMC    ,AI     ,BI     ,CI     , & !inout
-                   RHSTT  ,                                 & !inout
+                   RHSTT  ,SMCWTD ,QDRAIN ,DEEPRECH,                                 & !inout
                    WPLUS)                                     !out
        RSAT =  RSAT + WPLUS
+       QDRAIN_SAVE = QDRAIN_SAVE + QDRAIN
     END DO
 
+    QDRAIN = QDRAIN_SAVE/NITER
+
     RUNSRF = RUNSRF * 1000. + RSAT * 1000./DT  ! m/s -> mm/s
     QDRAIN = QDRAIN * 1000.
 
+!WRF_HYDRO_DJG...
+!yw    INFXSRT = RUNSRF * DT   !mm/s -> mm
+
 ! removal of soil water due to groundwater flow (option 2)
 
     IF(OPT_RUN == 2) THEN
@@ -7659,6 +7810,7 @@ SUBROUTINE SOILWATER (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
         END IF
         MLIQ(IZ) = MLIQ(IZ) + XS
         RUNSUB   = RUNSUB - XS/DT
+        IF(OPT_RUN == 5)DEEPRECH = DEEPRECH - XS*1.E-3
 
       DO IZ = 1, NSOIL
         SH2O(IZ)     = MLIQ(IZ) / (DZSNSO(IZ)*1000.)
@@ -7820,7 +7972,7 @@ END SUBROUTINE INFIL
 ! ==================================================================================================
   SUBROUTINE SRT (NSOIL  ,ZSOIL  ,DT     ,PDDUM  ,ETRANI , & !in
                   QSEVA  ,SH2O   ,SMC    ,ZWT    ,FCR    , & !in
-                  SICEMAX,FCRMAX ,ILOC   ,JLOC   ,         & !in
+                  SICEMAX,FCRMAX ,ILOC   ,JLOC   ,SMCWTD ,         & !in
                   RHSTT  ,AI     ,BI     ,CI     ,QDRAIN , & !out
                   WCND   )                                   !out
 ! ----------------------------------------------------------------------
@@ -7846,6 +7998,7 @@ SUBROUTINE SRT (NSOIL  ,ZSOIL  ,DT     ,PDDUM  ,ETRANI , & !in
     REAL, DIMENSION(1:NSOIL), INTENT(IN)  :: FCR
     REAL, INTENT(IN)                      :: FCRMAX !maximum of FCR (-)
     REAL,                     INTENT(IN)  :: SICEMAX!maximum soil ice content (m3/m3)
+    REAL,                     INTENT(IN)  :: SMCWTD !soil moisture between bottom of the soil and the water table
 
 ! output
 
@@ -7865,6 +8018,8 @@ SUBROUTINE SRT (NSOIL  ,ZSOIL  ,DT     ,PDDUM  ,ETRANI , & !in
     REAL, DIMENSION(1:NSOIL)              :: WDF
     REAL, DIMENSION(1:NSOIL)              :: SMX
     REAL                                  :: TEMP1
+    REAL                                  :: SMXWTD !soil moisture between bottom of the soil and water table
+    REAL                                  :: SMXBOT  !soil moisture below bottom to calculate flux
 
 ! Niu and Yang (2006), J. of Hydrometeorology
 ! ----------------------------------------------------------------------
@@ -7874,6 +8029,7 @@ SUBROUTINE SRT (NSOIL  ,ZSOIL  ,DT     ,PDDUM  ,ETRANI , & !in
         CALL WDFCND1 (WDF(K),WCND(K),SMC(K),FCR(K))
         SMX(K) = SMC(K)
       END DO
+        IF(OPT_RUN == 5)SMXWTD=SMCWTD
     END IF
 
     IF(OPT_INF == 2) THEN
@@ -7881,6 +8037,7 @@ SUBROUTINE SRT (NSOIL  ,ZSOIL  ,DT     ,PDDUM  ,ETRANI , & !in
         CALL WDFCND2 (WDF(K),WCND(K),SH2O(K),SICEMAX)
         SMX(K) = SH2O(K)
       END DO
+          IF(OPT_RUN == 5)SMXWTD=SMCWTD*SH2O(NSOIL)/SMC(NSOIL)  !same liquid fraction as in the bottom layer
     END IF
 
     DO K = 1, NSOIL
@@ -7908,6 +8065,17 @@ SUBROUTINE SRT (NSOIL  ,ZSOIL  ,DT     ,PDDUM  ,ETRANI , & !in
           IF(OPT_RUN == 4) THEN
              QDRAIN   = (1.0-FCRMAX)*WCND(K)
           END IF
+          IF(OPT_RUN == 5) THEN   !gmm new m-m&f water table dynamics formulation
+             TEMP1    = 2.0 * DENOM(K)
+             IF(ZWT < ZSOIL(NSOIL)-DENOM(NSOIL))THEN
+!gmm interpolate from below, midway to the water table, to the middle of the auxiliary layer below the soil bottom
+                SMXBOT = SMX(K) - (SMX(K)-SMXWTD) *  DENOM(K) * 2./ (DENOM(K) + ZSOIL(K) - ZWT)
+             ELSE
+                SMXBOT = SMXWTD
+             ENDIF
+             DSMDZ(K) = 2.0 * (SMX(K) - SMXBOT) / TEMP1
+             QDRAIN   = WDF(K  ) * DSMDZ(K  ) + WCND(K  )
+          END IF   
           WFLUX(K) = -(WDF(K-1)*DSMDZ(K-1))-WCND(K-1)+ETRANI(K) + QDRAIN
        END IF
     END DO
@@ -7934,9 +8102,9 @@ END SUBROUTINE SRT
 ! ----------------------------------------------------------------------
 ! ==================================================================================================
   SUBROUTINE SSTEP (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
-                    SICE   ,ILOC   ,JLOC   ,                 & !in
+                    SICE   ,ILOC   ,JLOC   ,ZWT            ,                 & !in
                     SH2O   ,SMC    ,AI     ,BI     ,CI     , & !inout
-                    RHSTT  ,                                 & !inout
+                    RHSTT  ,SMCWTD ,QDRAIN ,DEEPRECH,                                 & !inout
                     WPLUS  )                                   !out
 
 ! ----------------------------------------------------------------------
@@ -7951,6 +8119,7 @@ SUBROUTINE SSTEP (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
     INTEGER,                         INTENT(IN) :: NSOIL  !
     INTEGER,                         INTENT(IN) :: NSNOW  !
     REAL, INTENT(IN)                            :: DT
+    REAL, INTENT(IN)                            :: ZWT
     REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: ZSOIL
     REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: SICE
     REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO ! snow/soil layer thickness [m]
@@ -7962,6 +8131,9 @@ SUBROUTINE SSTEP (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
     REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: BI
     REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: CI
     REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT
+    REAL                    , INTENT(INOUT) :: SMCWTD
+    REAL                    , INTENT(INOUT) :: QDRAIN
+    REAL                    , INTENT(INOUT) :: DEEPRECH
 
 !output
     REAL, INTENT(OUT)                       :: WPLUS     !saturation excess water (m)
@@ -7972,6 +8144,7 @@ SUBROUTINE SSTEP (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
     REAL, DIMENSION(1:NSOIL)                :: CIIN
     REAL                                    :: STOT
     REAL                                    :: EPORE
+    REAL                                    :: WMINUS
 ! ----------------------------------------------------------------------
     WPLUS = 0.0
 
@@ -8000,6 +8173,29 @@ SUBROUTINE SSTEP (NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
 !  excessive water above saturation in a layer is moved to
 !  its unsaturated layer like in a bucket
 
+!gmmwith opt_run=5 there is soil moisture below nsoil, to the water table
+  IF(OPT_RUN == 5) THEN
+
+!update smcwtd
+
+     IF(ZWT < ZSOIL(NSOIL)-DZSNSO(NSOIL))THEN
+!accumulate qdrain to update deep water table and soil moisture later
+        DEEPRECH =  DEEPRECH + DT * QDRAIN
+     ELSE
+        SMCWTD = SMCWTD + DT * QDRAIN  / DZSNSO(NSOIL)
+        WPLUS        = MAX((SMCWTD-SMCMAX), 0.0) * DZSNSO(NSOIL)
+        WMINUS       = MAX((1.E-4-SMCWTD), 0.0) * DZSNSO(NSOIL)
+
+        SMCWTD = MAX( MIN(SMCWTD,SMCMAX) , 1.E-4)
+        SH2O(NSOIL)    = SH2O(NSOIL) + WPLUS/DZSNSO(NSOIL)
+
+!reduce fluxes at the bottom boundaries accordingly
+        QDRAIN = QDRAIN - WPLUS/DT
+        DEEPRECH = DEEPRECH - WMINUS
+     ENDIF
+
+  ENDIF
+
     DO K = NSOIL,2,-1
       EPORE        = MAX ( 1.E-4 , ( SMCMAX - SICE(K) ) )
       WPLUS        = MAX((SH2O(K)-EPORE), 0.0) * DZSNSO(K)
@@ -8270,6 +8466,140 @@ SUBROUTINE GROUNDWATER(NSNOW  ,NSOIL  ,DT     ,SICE   ,ZSOIL  , & !in
       END DO
 
   END SUBROUTINE GROUNDWATER
+! ==================================================================================================
+! ----------------------------------------------------------------------
+  SUBROUTINE SHALLOWWATERTABLE (NSNOW  ,NSOIL  ,ZSOIL, DT    , & !in
+                         DZSNSO ,SMCEQ ,ILOC   ,JLOC         , & !in
+                         SMC    ,WTD   ,SMCWTD ,RECH, QDRAIN  )  !inout
+! ----------------------------------------------------------------------
+!Diagnoses water table depth and computes recharge when the water table is within the resolved soil layers,
+!according to the Miguez-Macho&Fan scheme
+! ----------------------------------------------------------------------
+  IMPLICIT NONE
+! ----------------------------------------------------------------------
+! input
+  INTEGER,                         INTENT(IN) :: NSNOW !maximum no. of snow layers
+  INTEGER,                         INTENT(IN) :: NSOIL !no. of soil layers
+  INTEGER,                         INTENT(IN) :: ILOC,JLOC
+  REAL,                            INTENT(IN) :: DT
+  REAL, DIMENSION(       1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m]
+  REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO ! snow/soil layer thickness [m]
+  REAL,  DIMENSION(      1:NSOIL), INTENT(IN) :: SMCEQ  !equilibrium soil water  content [m3/m3]
+
+! input and output
+  REAL,  DIMENSION(      1:NSOIL), INTENT(INOUT) :: SMC   !total soil water  content [m3/m3]
+  REAL,                         INTENT(INOUT) :: WTD   !the depth to water table [m]
+  REAL,                         INTENT(INOUT) :: SMCWTD   !soil moisture between bottom of the soil and the water table [m3/m3]
+  REAL,                         INTENT(OUT) :: RECH ! groundwater recharge (net vertical flux across the water table), positive up
+  REAL,                         INTENT(INOUT) :: QDRAIN
+    
+! local
+  INTEGER                                     :: IZ    !do-loop index
+  INTEGER                                     :: IWTD   !layer index above water table layer
+  INTEGER                                     :: KWTD   !layer index where the water table layer is
+  REAL                                        :: WTDOLD
+  REAL                                        :: DZUP
+  REAL                                        :: SMCEQDEEP
+  REAL,  DIMENSION(       0:NSOIL)            :: ZSOIL0
+! -------------------------------------------------------------
+
+
+ZSOIL0(1:NSOIL) = ZSOIL(1:NSOIL)
+ZSOIL0(0) = 0.         
+ 
+!find the layer where the water table is
+     DO IZ=NSOIL,1,-1
+        IF(WTD + 1.E-6 < ZSOIL0(IZ)) EXIT
+     ENDDO
+        IWTD=IZ
+
+        
+        KWTD=IWTD+1  !layer where the water table is
+        IF(KWTD.LE.NSOIL)THEN    !wtd in the resolved layers
+           WTDOLD=WTD
+           IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN
+        
+               IF(SMC(KWTD).EQ.SMCMAX)THEN !wtd went to the layer above
+                      WTD=ZSOIL0(IWTD)
+                      RECH=-(WTDOLD-WTD) * (SMCMAX-SMCEQ(KWTD))
+                      IWTD=IWTD-1
+                      KWTD=KWTD-1
+                   IF(KWTD.GE.1)THEN
+                      IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN
+                      WTDOLD=WTD
+                      WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) &
+                        - SMCEQ(KWTD)*ZSOIL0(IWTD) + SMCMAX*ZSOIL0(KWTD) ) / &
+                        ( SMCMAX-SMCEQ(KWTD) ), ZSOIL0(IWTD))
+                      RECH=RECH-(WTDOLD-WTD) * (SMCMAX-SMCEQ(KWTD))
+                      ENDIF
+                   ENDIF
+               ELSE  !wtd stays in the layer
+                      WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) &
+                        - SMCEQ(KWTD)*ZSOIL0(IWTD) + SMCMAX*ZSOIL0(KWTD) ) / &
+                        ( SMCMAX-SMCEQ(KWTD) ), ZSOIL0(IWTD))
+                      RECH=-(WTDOLD-WTD) * (SMCMAX-SMCEQ(KWTD))
+               ENDIF
+           
+           ELSE    !wtd has gone down to the layer below
+               WTD=ZSOIL0(KWTD)
+               RECH=-(WTDOLD-WTD) * (SMCMAX-SMCEQ(KWTD))
+               KWTD=KWTD+1
+               IWTD=IWTD+1
+!wtd crossed to the layer below. Now adjust it there
+               IF(KWTD.LE.NSOIL)THEN
+                   WTDOLD=WTD
+                   IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN
+                   WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) &
+                   - SMCEQ(KWTD)*ZSOIL0(IWTD) + SMCMAX*ZSOIL0(KWTD) ) / &
+                       ( SMCMAX-SMCEQ(KWTD) ) , ZSOIL0(IWTD) )
+                   ELSE
+                   WTD=ZSOIL0(KWTD)
+                   ENDIF
+                   RECH = RECH - (WTDOLD-WTD) * &
+                                 (SMCMAX-SMCEQ(KWTD))
+
+                ELSE
+                   WTDOLD=WTD
+!restore smoi to equilibrium value with water from the ficticious layer below
+!                   SMCWTD=SMCWTD-(SMCEQ(NSOIL)-SMC(NSOIL))
+!                   QDRAIN = QDRAIN - 1000 * (SMCEQ(NSOIL)-SMC(NSOIL)) * DZSNSO(NSOIL) / DT
+!                   SMC(NSOIL)=SMCEQ(NSOIL)
+!adjust wtd in the ficticious layer below
+                   SMCEQDEEP = SMCMAX * ( -PSISAT / ( -PSISAT - DZSNSO(NSOIL) ) ) ** (1./BEXP)
+                   WTD = MIN( ( SMCWTD*DZSNSO(NSOIL) &
+                   - SMCEQDEEP*ZSOIL0(NSOIL) + SMCMAX*(ZSOIL0(NSOIL)-DZSNSO(NSOIL)) ) / &
+                       ( SMCMAX-SMCEQDEEP ) , ZSOIL0(NSOIL) )
+                   RECH = RECH - (WTDOLD-WTD) * &
+                                 (SMCMAX-SMCEQDEEP)
+                ENDIF
+            
+            ENDIF
+        ELSEIF(WTD.GE.ZSOIL0(NSOIL)-DZSNSO(NSOIL))THEN
+!if wtd was already below the bottom of the resolved soil crust
+           WTDOLD=WTD
+           SMCEQDEEP = SMCMAX * ( -PSISAT / ( -PSISAT - DZSNSO(NSOIL) ) ) ** (1./BEXP)
+           IF(SMCWTD.GT.SMCEQDEEP)THEN
+               WTD = MIN( ( SMCWTD*DZSNSO(NSOIL) &
+                 - SMCEQDEEP*ZSOIL0(NSOIL) + SMCMAX*(ZSOIL0(NSOIL)-DZSNSO(NSOIL)) ) / &
+                     ( SMCMAX-SMCEQDEEP ) , ZSOIL0(NSOIL) )
+               RECH = -(WTDOLD-WTD) * (SMCMAX-SMCEQDEEP)
+           ELSE
+               RECH = -(WTDOLD-(ZSOIL0(NSOIL)-DZSNSO(NSOIL))) * (SMCMAX-SMCEQDEEP)
+               WTDOLD=ZSOIL0(NSOIL)-DZSNSO(NSOIL)
+!and now even further down
+               DZUP=(SMCEQDEEP-SMCWTD)*DZSNSO(NSOIL)/(SMCMAX-SMCEQDEEP)
+               WTD=WTDOLD-DZUP
+               RECH = RECH - (SMCMAX-SMCEQDEEP)*DZUP
+               SMCWTD=SMCEQDEEP
+           ENDIF
+
+         
+         ENDIF
+
+IF(IWTD.LT.NSOIL)SMCWTD=SMCMAX
+
+END  SUBROUTINE SHALLOWWATERTABLE
+
 ! ==================================================================================================
 ! ********************* end of water subroutines ******************************************
 ! ==================================================================================================
diff --git a/wrfv2_fire/phys/module_sf_pxlsm.F b/wrfv2_fire/phys/module_sf_pxlsm.F
index 79360333..6d5b0ceb 100755
--- a/wrfv2_fire/phys/module_sf_pxlsm.F
+++ b/wrfv2_fire/phys/module_sf_pxlsm.F
@@ -315,6 +315,8 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO,         &
          LAND_USE_TYPE = 'MODIS'
       ELSE IF (NLCAT == 24) THEN
          LAND_USE_TYPE = 'USGS'
+      ELSE IF (NLCAT == 28) THEN
+         LAND_USE_TYPE = 'USGS'
       ELSE
          call wrf_error_fatal("Error: Unknown Land Use Category")
       END IF 
diff --git a/wrfv2_fire/phys/module_sf_qnsesfc.F b/wrfv2_fire/phys/module_sf_qnsesfc.F
index dd743de3..6f3e4c13 100755
--- a/wrfv2_fire/phys/module_sf_qnsesfc.F
+++ b/wrfv2_fire/phys/module_sf_qnsesfc.F
@@ -74,7 +74,7 @@ SUBROUTINE QNSESFC(ITIMESTEP,HT,DZ                                &
      &                 ,RIB                                            &
      &                 ,CHS,CHS2,CQS2,HFX,QFX,FLX_LH,FLHC,FLQC         &
      &                 ,QGH,CPM,CT                                     &
-     &                 ,U10,V10,TSHLTR,TH10,QSHLTR,Q10,PSHLTR          &
+     &                 ,U10,V10,T02,TH02,TSHLTR,TH10,Q02,QSHLTR,Q10,PSHLTR          &
      &                 ,IDS,IDE,JDS,JDE,KDS,KDE                        &
      &                 ,IMS,IME,JMS,JME,KMS,KME                        &
      &                 ,ITS,ITE,JTS,JTE,KTS,KTE,SCM_FORCE_FLUX  )
@@ -101,8 +101,8 @@ SUBROUTINE QNSESFC(ITIMESTEP,HT,DZ                                &
      &                                                     ,U,V   
 !
       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: PSHLTR,Q10,QSHLTR &
-     &                                              ,TH10,TSHLTR       &
-     &                                              ,U10,V10
+     &                                              ,TH10,TSHLTR,T02   &
+     &                                              ,U10,V10,TH02,Q02
       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: FLX_LH,HFX,QFX 
 !
       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: AKHS,AKMS       &
@@ -308,13 +308,19 @@ SUBROUTINE QNSESFC(ITIMESTEP,HT,DZ                                &
           RAPA=APESFC
           TH02P=TSHLTR(I,J)
           TH10P=TH10(I,J)
+          TH02(I,J)=TSHLTR(I,J)    !emt
+         IF (SEAMASK.EQ.1.AND.I.EQ.170.AND.J.EQ.20) THEN
+          print*,'HFX_SEA_point',HFX(I,J)
+         END IF
 !
           RAPA02=RAPA-GOCP02/TH02P
           RAPA10=RAPA-GOCP10/TH10P
 !
           T02P=TH02P*RAPA02
           T10P=TH10P*RAPA10
+           T02(I,J) = TH02(I,J)*APESFC  !emt
 !
+
           P02P=(RAPA02**RCAP)*1.E5
           P10P=(RAPA10**RCAP)*1.E5
 !
@@ -323,6 +329,7 @@ SUBROUTINE QNSESFC(ITIMESTEP,HT,DZ                                &
 !
           IF(QSHLTR(I,J)>QS02)QSHLTR(I,J)=QS02
           IF(Q10   (I,J)>QS10)Q10   (I,J)=QS10
+           Q02(I,J)=QSHLTR(I,J)/(1.-QSHLTR(I,J))  !emt
 !----------------------------------------------------------------------
 !
         ENDDO
@@ -454,7 +461,7 @@ SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC                       &
                 THZ0=((WGHTT*THLOW+THS)/(WGHTT+1.)+THZ0)*0.5
                 QZ0=((WGHTQ*QLOW+QS)/(WGHTQ+1.)+QZ0)*0.5
               ELSE
-                THZ0=(WGHTT*THLOW+THS)/(WGHTT+1.)
+                THZ0=(WGHTT*THLOW+THS)/(WGHTT+1.)            
                 QZ0=(WGHTQ*QLOW+QS)/(WGHTQ+1.)
               ENDIF
 !
@@ -959,6 +966,11 @@ SUBROUTINE SFCDIF(NTSD,SEAMASK,THS,QS,PSFC                       &
       CHS=AKHS
       CHS2=AKHS02
       CQS2=AKHS02
+     ! IF(SEAMASK.EQ.1) THEN
+     !  print*,'HSFLX=',HSFLX
+     !  print*,'RLOW=',RLOW
+     !  print*,'********'
+     ! END IF
       IF ( PRESENT(SCM_FORCE_FLUX) ) THEN              
          IF (SCM_FORCE_FLUX.EQ.0) THEN              
            HFX=-RLOW*CP*HSFLX
diff --git a/wrfv2_fire/phys/module_sf_ruclsm.F b/wrfv2_fire/phys/module_sf_ruclsm.F
index c82e595f..1dde23ce 100644
--- a/wrfv2_fire/phys/module_sf_ruclsm.F
+++ b/wrfv2_fire/phys/module_sf_ruclsm.F
@@ -54,7 +54,7 @@ SUBROUTINE LSMRUC(                                           &
                    SFCRUNOFF,UDRUNOFF,SFCEXC,                    &
                    SFCEVP,GRDFLX,ACSNOW,SNOM,                    &
                    SMFR3D,KEEPFR3DFLAG,                          &
-                   myj,shdmin,shdmax,                            &
+                   myj,shdmin,shdmax,rdlai2d,                    &
                    ids,ide, jds,jde, kds,kde,                    &
                    ims,ime, jms,jme, kms,kme,                    &
                    its,ite, jts,jte, kts,kte                     )
@@ -163,12 +163,12 @@ SUBROUTINE LSMRUC(                                           &
                                                           EMISS, &
                                                            XICE, &
                                                           XLAND, &
-                                                         ALBBCK, &
                                                          VEGFRA, &
                                                            TBOT
 
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN )::   SHDMAX
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN )::   SHDMIN
+   LOGICAL, intent(in) :: rdlai2d
 
    REAL,       DIMENSION( 1:nsl), INTENT(IN   )      ::      ZS
 
@@ -180,6 +180,7 @@ SUBROUTINE LSMRUC(                                           &
                                                          CANWAT, & ! new
                                                          SNOALB, &
                                                             ALB, &
+                                                         ALBBCK, &
                                                             LAI, &
                                                          MAVAIL, & 
                                                          SFCEXC, &
@@ -365,11 +366,14 @@ SUBROUTINE LSMRUC(                                           &
 !       sh2o    (i,k,j)=soilmois(i,k,j)-smfr3d(i,k,j)/1.e3*900.
        keepfr3dflag(i,k,j)=0.
             enddo
-!--- initializing to zero snow fraction
-           snowc(i,j) = min(1.,snowh(i,j)/0.05)
+!--- initializing snow fraction, thereshold = 32 mm of snow water 
+!    or ~100 mm of snow height
+!
+           snowc(i,j) = min(1.,snow(i,j)/32.)
+          if(snow(i,j).le.32.) soilt1(i,j)=tso(i,1,j)
 !--- initializing inside snow temp if it is not defined
         IF((soilt1(i,j) .LT. 170.) .or. (soilt1(i,j) .GT.400.)) THEN
-            IF(snowc(i,j).gt.0.1) THEN
+            IF(snow(i,j).gt.32.) THEN
            soilt1(i,j)=0.5*(soilt(i,j)+tso(i,1,j))
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
         WRITE ( message , FMT='(A,F8.3,2I6)' ) &
@@ -377,7 +381,7 @@ SUBROUTINE LSMRUC(                                           &
         CALL wrf_debug ( 0 , message )
     ENDIF
             ELSE
-           soilt1(i,j) = soilt(i,j)
+           soilt1(i,j) = tso(i,1,j)
             ENDIF
         ENDIF
            tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273.
@@ -570,7 +574,7 @@ SUBROUTINE LSMRUC(                                           &
 !--- initializing soil and surface properties
      CALL SOILVEGIN  ( mosaic_lu, mosaic_soil,soilfrac,nscat,shdmin(i,j),shdmax(i,j),&
                        NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J),     &
-                       EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),                        &
+                       EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),RDLAI2D,                &
                        QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j )
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
       if(ktau.eq.1 .and.(i.eq.358.and.j.eq.260)) &
@@ -630,7 +634,7 @@ SUBROUTINE LSMRUC(                                           &
 !         print *,'NROOT, iforest, ivgtyp, i,j ', nroot,iforest(ivgtyp(i,j)),ivgtyp(I,J),I,J
     ENDIF
 
-!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS
+!!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS
 
         IF((XLAND(I,J)-1.5).GE.0.)THEN
 !-- Water 
@@ -682,7 +686,8 @@ SUBROUTINE LSMRUC(                                           &
             ILAND = isice
             ISOIL = 16
             ZNT(I,J) = 0.011
-            snoalb(i,j) = 0.75
+            snoalb(i,j) = 0.8
+            albbck(i,j) = 0.7
             dqm = 1.
             ref = 1.
             qmin = 0.
@@ -713,9 +718,9 @@ SUBROUTINE LSMRUC(                                           &
               keepfr  (k) = keepfr3dflag(i,k,j)
            enddo
 
-!              LMAVAIL(I,J)=max(0.00001,min(1.,soilmois(i,1,j)/(REF-QMIN)))
+              LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/(REF-QMIN)))
 !              LMAVAIL(I,J)=max(0.00001,min(1.,soilmois(i,1,j)/dqm))
-              LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/dqm))
+!              LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/dqm))
 
 #if ( NMM_CORE == 1 )
      if(ktau+1.gt.1) then
@@ -724,7 +729,7 @@ SUBROUTINE LSMRUC(                                           &
 #endif
 
 ! extract dew from the cloud water at the surface
-              QCG(I,J)=QCG(I,J)-DEW(I,J)/QKMS
+!30july13              QCG(I,J)=QCG(I,J)-DEW(I,J)/QKMS
      endif
 
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
@@ -807,7 +812,7 @@ SUBROUTINE LSMRUC(                                           &
         enddo
 
 !tgs add together dew and cloud at the ground surface
-        qcg(i,j)=qcg(i,j)+dew(i,j)/qkms
+!30july13        qcg(i,j)=qcg(i,j)+dew(i,j)/qkms
 
         Z0       (I,J) = ZNT (I,J)
         SFCEXC   (I,J) = TKMS
@@ -1041,7 +1046,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
    REAL    ::  BSN, XSN                                        , &
                RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS             , &
                T3, UPFLUX, XINET
-   REAL    ::  snhei_crit, keep_snow_albedo
+   REAL    ::  snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn
 
    REAL    ::  RNET,GSWNEW,EMISSN,ZNTSN
    REAL    ::  VEGFRAC
@@ -1056,6 +1061,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
     ENDIF
 
         NEWSN=0.
+        snowfracnewsn=0.
         RAINF = 0.
         RSM=0.
         INFILTR=0.
@@ -1073,6 +1079,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
 
         GSWnew=GSW
         ALBice=ALB_SNOW_FREE
+        ALBsn=alb_snow
 !--- sea ice properties
 !--- N.N Zubov "Arctic Ice"
 !--- no salinity dependence because we consider the ice pack
@@ -1089,10 +1096,8 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
 !-- below critical value of -10C - no change to albedo.
 !-- If temperature is higher that -10C then albedo is decreasing.
 !-- The minimum albedo at t=0C for ice is 0.1 less.
-         GSWNEW=GSW/(1.-ALB)
        ALBice = MIN(ALB_SNOW_FREE,MAX(ALB_SNOW_FREE - 0.05,   &
                ALB_SNOW_FREE - 0.1*(tice(1)+10.)/10. ))
-         GSWNEW=GSW*(1.-ALBice)
        endif
 
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
@@ -1106,6 +1111,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
          T3      = STBOLT*SOILT*SOILT*SOILT
          UPFLUX  = T3 *SOILT
          XINET   = EMISS*(GLW-UPFLUX)
+! - at this point GSWnew=GSW
          RNET    = GSWnew + XINET
 
 !Calculate the amount (m) of fresh snow
@@ -1179,22 +1185,27 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
          ILAND=ISICE
 
          SNHEI_CRIT=0.01601*1.e3/rhosn
+         SNHEI_CRIT_newsn=0.0005*1.e3/rhosn
 !         SNOWFRAC=MIN(1.,SNHEI/SNHEI_CRIT)
          SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT))
-!--- low limit on snow fraction
-!       if(SNOWFRAC.lt.0.01) snowfrac=0.
+         if(newsn > 0. ) SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn)
 !---        EMISS = 0.98 for snow
+        if(newsn > 0. .and. SNOWFRACnewsn > 0.99) then
+         EMISS = 0.98
+        else
          EMISS = EMISS*(1.-snowfrac)+0.98*snowfrac
+        endif
 
 !-- Set znt for snow from VEGPARM table (snow/ice landuse), except for
 !-- land-use types with higher roughness (forests, urban).
 !5mar12      IF(znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland)
+       IF(znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland)
 
          KEEP_SNOW_ALBEDO = 0.
-      IF (NEWSN.GT.0.) KEEP_SNOW_ALBEDO = 1.
+      IF (NEWSN > 0. .and. snowfracnewsn > 0.99) KEEP_SNOW_ALBEDO = 1.
 
-!---  GSW in-coming solar
-         GSWNEW=GSW/(1.-ALB)
+!---  GSWNEW in-coming solar for snow on land or on ice
+         GSWNEW=GSWnew/(1.-ALB)
 
     IF(SEAICE .LT. 0.5) THEN
 !----- SNOW on soil
@@ -1211,7 +1222,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
 !-- If temperature is higher that -10C then albedo is decreasing.
 !-- The minimum albedo at t=0C for snow on land is 15% less than
 !-- albedo of temperatures below -10C.
-     if(albsn.lt.0.5) then
+     if(albsn.lt.0.4) then
         ALB=ALBsn
       else
 !-- change albedo when no fresh snow and snow albedo is higher than 0.5
@@ -1240,11 +1251,11 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
 !--- for new value of albedo
          gswnew=gswnew*(1.-alb)
 
-        XINET   = EMISS*(GLW-UPFLUX)
+! Recompute RNET with current GSWnew
         RNET    = GSWnew + XINET
 
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
-        print *,'I,J,GSW,GSWnew,GLW,UPFLUX,ALB',&
+        print *,'SNOW - I,J,GSW,GSWnew,GLW,UPFLUX,ALB',&
                  i,j,GSW,GSWnew,GLW,UPFLUX,ALB
     ENDIF
 
@@ -1344,6 +1355,12 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
             infiltr)
         else
 ! SEA ICE
+! If current ice albedo is not the same as from the previous time step, then
+! update GSW, ALB and RNET for surface energy budget
+         if(ALB.ne.ALBice) GSWnew=GSW/(1.-ALB)*(1.-ALBice)
+         alb=albice
+         RNET    = GSWnew + XINET
+
           CALL SICE(                                            &
 !--- input variables
             i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
@@ -1912,8 +1929,8 @@ SUBROUTINE SOIL (                                    &
                   (QVATM-QVG)
           EC1 = Q1 * WETCAN
           CMC2MS=CST/DELT
-         if(EC1.gt.CMC2MS) cst=0.
-          EC1=MIN(CMC2MS,EC1)
+         if(EC1.gt.CMC2MS*RAS) cst=0.
+          EC1=MIN(CMC2MS*RAS,EC1)
 !-- moisture flux for coupling with MYJ PBL
           EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3
 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
@@ -1921,6 +1938,7 @@ SUBROUTINE SOIL (                                    &
 !-- actual moisture flux from RUC LSM
           EETA = (EDIR1 + EC1 + ETT1)*1.E3
         ENDIF
+
           EVAPL=EETA
           S=THDIF(1)*CAP(1)*DZSTOP*(TSO(1)-TSO(2))
           HFX=HFT
@@ -2155,7 +2173,7 @@ SUBROUTINE SICE (                                       &
 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
           QFX= XLS * EETA
 !-- actual moisture flux from RUC LSM
-          EETA = Q1*1.E3
+!          EETA = Q1*1.E3
         ENDIF
           EVAPL=EETA
           S=THDIFICE(1)*CAPICE(1)*DZSTOP*(TSO(1)-TSO(2))
@@ -2421,7 +2439,8 @@ SUBROUTINE SNOWSOIL (                                  &
 !--- the top soil layer. SNTH is computed using snwe=0.016 m, and
 !--- equals 4 cm for snow density 400 kg/m^3.
 
-           DELTSN=0.0301*1.e3/rhosn
+! increase thinkness of top snow layer from 3 cm SWE to 5 cm SWE
+           DELTSN=0.05*1.e3/rhosn
            snth=0.01601*1.e3/rhosn
 
 ! when the snow depth is marginally higher than DELTSN,
@@ -2620,7 +2639,7 @@ SUBROUTINE SNOWSOIL (                                  &
 !  check if all snow can evaporate during DT
          BETA=1.
          EPDT = EPOT * RAS *DELT*UMVEG
-         IF(SNWEPR.LE.EPDT) THEN 
+         IF(EPDT.gt.0. .and. SNWEPR.LE.EPDT) THEN 
             BETA=SNWEPR/max(1.e-8,EPDT)
             SNWE=0.
             SNHEI=0.
@@ -2801,8 +2820,8 @@ SUBROUTINE SNOWSOIL (                                  &
         EDIR1 = Q1*UMVEG *BETA
         EC1 = Q1 * WETCAN
         CMC2MS=CST/DELT
-       if(EC1.gt.CMC2MS) cst=0.
-        EC1=MIN(CMC2MS,EC1)
+       if(EC1.gt.CMC2MS*RAS) cst=0.
+        EC1=MIN(CMC2MS*RAS,EC1)
 !-- moisture flux for coupling with MYJ PBL
         EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3
 !        EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
@@ -2811,9 +2830,13 @@ SUBROUTINE SNOWSOIL (                                  &
 !-- actual moisture flux from RUC LSM
         EETA = (EDIR1 + EC1 + ETT1)*1.E3
        ENDIF
+      if(snhei.gt.0.)then
+        s=snflx
+      else
         s=THDIF(1)*CAP(1)*dzstop*(tso(1)-tso(2))
+      endif
         HFX=HFT
-        FLTOT=RNET-HFT-QFX-S
+        FLTOT=RNET-HFT-QFX-S-SNOH
 
  222     CONTINUE
 
@@ -2984,7 +3007,8 @@ SUBROUTINE SNOWSEAICE(                               &
 !--- the top sea ice layer. SNTH is computed using snwe=0.016 m, and
 !--- equals 4 cm for snow density 400 kg/m^3.
 
-           DELTSN=0.0301*1.e3/rhosn
+! increase thickness of top snow layer from 3 cm SWE to 5 cm SWE
+           DELTSN=0.05*1.e3/rhosn
            snth=0.01601*1.e3/rhosn
 
 ! when the snow depth is marginlly higher than DELTSN,
@@ -3143,6 +3167,10 @@ SUBROUTINE SNOWSEAICE(                               &
          rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom
          tsnav=0.5*(soilt+tso(1))                                    &
                      -273.15
+         cotso(nzs)=cotso(NZS1)
+         rhtso(nzs)=rhtso(nzs1)
+         cotsn=cotso(NZS)
+         rhtsn=rhtso(NZS)
        ENDIF
 
 !************************************************************************
@@ -3354,9 +3382,21 @@ SUBROUTINE SNOWSEAICE(                               &
                     (SMELT+BETA*EPOT*RAS)*DELT                        &
                                          ) )
 
+!--- If there is no snow melting then just evaporation
+!--- or condensation cxhanges SNWE
+      ELSE
+               EPOT=-QKMS*(QVATM-QSG)
+               SNWE = AMAX1(0.,(SNWEPR-                               &
+                    BETA*EPOT*RAS*DELT))
+
+      ENDIF
+
+      if(nmelt.eq.1) goto 212  ! second iteration
+ 220  continue
 !--- If all snow melts, then 13% of snow melt we kept in the
 !--- snow pack should be added back to snow melt and infiltrate
 !--- into soil.
+       if(rsm.gt.0.) then
         if(snwe.le.rsm) then
            smelt=smelt+rsm/delt
            snwe=0.
@@ -3367,29 +3407,14 @@ SUBROUTINE SNOWSEAICE(                               &
 !*** remains in the pack and changes its density.
 !*** Eq. 9 (with my correction) in Koren et al. (1999)
 
-          if(snwe.gt.0.) then
          xsn=(rhosn*(snwe-rsm)+917.*rsm)/                            &
              snwe
          rhosn=MIN(XSN,400.)
 
         RHOCSN=2090.* RHOSN
         thdifsn = 0.265/RHOCSN
-          endif
-
         endif
-
-!--- If there is no snow melting then just evaporation
-!--- or condensation cxhanges SNWE
-      ELSE
-               EPOT=-QKMS*(QVATM-QSG)
-               SNWE = AMAX1(0.,(SNWEPR-                               &
-                    BETA*EPOT*RAS*DELT))
-
-      ENDIF
-!*** Correct snow density on effect of snow melt, melted
-!*** from the top of the snow. 13% of melted water
-!*** remains in the pack and changes its density.
-!*** Eq. 9 (with my correction) in Koren et al. (1999)
+      endif
 
         SNHEI=SNWE *1.E3 / RHOSN
 
@@ -3400,8 +3425,6 @@ SUBROUTINE SNOWSEAICE(                               &
 ! 4 Nov 07                    +VEGFRAC*cst
         snheiprint=snweprint*1.E3 / RHOSN
 
-      if(nmelt.eq.1) goto 212
- 220  continue
 
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
 print *, 'snweprint : ',snweprint
@@ -3465,14 +3488,18 @@ SUBROUTINE SNOWSEAICE(                               &
 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
           QFX= XLVm * EETA
 !-- actual moisture flux from RUC LSM
-          EETA = Q1*1.E3
+!          EETA = Q1*1.E3
           sublim = EETA
         ENDIF
 
+      if(snhei.gt.0.) then
+        s=D9SN*(SOILT-TSOB)
+      else
         s=THDIFICE(1)*CAPICE(1)*dzstop*(tso(1)-tso(2))
+      endif
 !        s=D9SN*(SOILT-TSOB)
         HFX=HFT
-        FLTOT=RNET-HFT-QFX-S
+        FLTOT=RNET-HFT-QFX-S-SNOH
 !------------------------------------------------------------------------
 !------------------------------------------------------------------------
    END SUBROUTINE SNOWSEAICE
@@ -4080,6 +4107,11 @@ SUBROUTINE SNOWTEMP(                                    &
          rhtso(nzs1)=(FT+X2*rhtso(NZS-2))/denom
          tsnav=0.5*(soilt+tso(1))                                    &
                      -273.15
+         cotso(NZS)=cotso(nzs1)
+         rhtso(NZS)=rhtso(nzs1)
+         cotsn=cotso(NZS)
+         rhtsn=rhtso(NZS)
+
        ENDIF
 
 !************************************************************************
@@ -4092,7 +4124,7 @@ SUBROUTINE SNOWTEMP(                                    &
         ETT1=0.
         EPOT=-QKMS*(QVATM-QSG)
         RHCS=CAP(1)
-        H=MAVAIL
+        H=1.
         IF(DEW.NE.0.)THEN
           DRYCAN=0.
           WETCAN=1.
@@ -4262,10 +4294,10 @@ SUBROUTINE SNOWTEMP(                                    &
           enddo
 
         EDIR1 = Q1*UMVEG * BETA
-        EC1 = Q1 * WETCAN *VEGFRAC
+        EC1 = Q1 * WETCAN
         CMC2MS=CST/DELT
-       if(EC1.gt.CMC2MS) cst=0.
-        EC1=MIN(CMC2MS,EC1)
+       if(EC1.gt.CMC2MS*RAS) cst=0.
+        EC1=MIN(CMC2MS*RAS,EC1)
         EETA = (EDIR1 + EC1 + ETT1)*1.E3
 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ 
         QFX= - XLVM * EETA
@@ -4321,7 +4353,21 @@ SUBROUTINE SNOWTEMP(                                    &
                     (SMELT+BETA*EPOT*RAS)*DELT                        &
 !                    (SMELT+BETA*EPOT*RAS*UMVEG)*DELT                 &
                                          ) )
+!--- If there is no snow melting then just evaporation
+!--- or condensation cxhanges SNWE
+      ELSE
+               EPOT=-QKMS*(QVATM-QSG)
+               SNWE = AMAX1(0.,(SNWEPR-                               &
+                    BETA*EPOT*RAS*DELT))
+!                    BETA*EPOT*RAS*UMVEG*DELT))
 
+      ENDIF
+!18apr08 - if snow melt occurred then go into iteration for energy budget 
+!         solution 
+     if(nmelt.eq.1) goto 212  ! second interation
+ 220  continue
+
+      if(rsm.gt.0.) then
        if(snwe.le.rsm) then
            smelt=smelt+rsm/delt
            snwe=0.
@@ -4331,36 +4377,17 @@ SUBROUTINE SNOWTEMP(                                    &
 !*** from the top of the snow. 13% of melted water
 !*** remains in the pack and changes its density.
 !*** Eq. 9 (with my correction) in Koren et al. (1999)
-          if(snwe.gt.0.) then
           xsn=(rhosn*(snwe-rsm)+917.*rsm)/                            &
               snwe
           rhosn=MIN(XSN,400.)
 
           RHOCSN=2090.* RHOSN
           thdifsn = 0.265/RHOCSN
-          endif  
         endif  
-
-!--- If there is no snow melting then just evaporation
-!--- or condensation cxhanges SNWE
-      ELSE
-               EPOT=-QKMS*(QVATM-QSG)
-               SNWE = AMAX1(0.,(SNWEPR-                               &
-                    BETA*EPOT*RAS*DELT))
-!                    BETA*EPOT*RAS*UMVEG*DELT))
-
-      ENDIF
-!*** Correct snow density on effect of snow melt, melted
-!*** from the top of the snow. 13% of melted water
-!*** remains in the pack and changes its density.
-!*** Eq. 9 (with my correction) in Koren et al. (1999)
+       endif
 
         SNHEI=SNWE *1.E3 / RHOSN
 
-!18apr08 - if snow melt occurred then go into iteration for energy budget 
-!         solution 
-     if(nmelt.eq.1) goto 212
- 220  continue
 !--  Snow melt from the top is done. But if ground surface temperature
 !--  is above freezing snow can melt from the bottom. The following
 !--  piece of code will check if bottom melting is possible.
@@ -4594,8 +4621,8 @@ SUBROUTINE SOILMOIST (                                  &
 
   191   format (f23.19)
 
-!        TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT
-        TOTLIQ=UMVEG*PRCP-DRIP/DELT-SMELT
+        TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT
+!30july13        TOTLIQ=UMVEG*PRCP-DRIP/DELT-SMELT
 
         FLX=TOTLIQ
         INFILTRP=TOTLIQ
@@ -4724,8 +4751,8 @@ SUBROUTINE SOILMOIST (                                  &
             SOILMOIS(K)=min(dqm,max(1.e-8,QQ))
            END IF
           END DO
-!           MAVAIL=min(1.,SOILMOIS(1)/(REF-QMIN))
-           MAVAIL=max(.00001,min(1.,SOILMOIS(1)/DQM))
+           MAVAIL=max(.00001,min(1.,SOILMOIS(1)/(REF-QMIN)))
+!           MAVAIL=max(.00001,min(1.,SOILMOIS(1)/DQM))
 
 !        RETURN
 !        END
@@ -5102,10 +5129,11 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil)
        TS=T1-.05*RN
        QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP
        GOTO 20
+!   1   PRINT *,'Crash in surface energy budget - STOP'
    1   PRINT *,'     AVOST IN VILKA      '
-!       WRITE(12,*)'AVOST',TN,D1,D2,PP,NSTEP
-       PRINT *,TN,D1,D2,PP,NSTEP,I,TT(i),ii,j,iland,isoil
-       CALL wrf_error_fatal ('     AVOST IN VILKA      ' )
+!       PRINT *,TN,D1,D2,PP,NSTEP,I,TT(i),ii,j,iland,isoil
+       print *,'I,J=',ii,j,'LU_index = ',iland, 'Psfc[hPa] = ',pp, 'Tsfc = ',tn
+       CALL wrf_error_fatal ('  Crash in surface energy budget  ' )
    20  CONTINUE
 !       RETURN
 !       END
@@ -5116,8 +5144,8 @@ END SUBROUTINE VILKA
      SUBROUTINE SOILVEGIN  ( mosaic_lu,mosaic_soil,soilfrac,nscat,   &
                      shdmin, shdmax,                                 &
                      NLCAT,IVGTYP,ISLTYP,iswater,MYJ,                &
-                     IFOREST,lufrac,vegfrac,EMISS,PC,ZNT,LAI,QWRTZ,  &
-                     RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J      )
+                     IFOREST,lufrac,vegfrac,EMISS,PC,ZNT,LAI,RDLAI2D,&
+                     QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,I,J)
 
 !************************************************************************
 !  Set-up soil and vegetation Parameters in the case when
@@ -5364,6 +5392,7 @@ SUBROUTINE SOILVEGIN  ( mosaic_lu,mosaic_soil,soilfrac,nscat,   &
             INTENT (INOUT   )         ::                  emiss, &
                                                             lai, &
                                                             znt
+  LOGICAL, intent(in) :: rdlai2d
 !--- soil properties
    REAL                                                        , &
             INTENT(  OUT)    ::                           RHOCS, &
@@ -5451,7 +5480,7 @@ SUBROUTINE SOILVEGIN  ( mosaic_lu,mosaic_soil,soilfrac,nscat,   &
         ZNT   = 0.
         ZNT1  = 0.
         PC    = 0.
-        LAI   = 0.
+        if(.not.rdlai2d) LAI = 0.
         AREA  = 0.
 !-- mosaic approach to landuse in the grid box
 ! Use  Mason (1988) Eq.(15) to compute effective ZNT;
@@ -5465,7 +5494,7 @@ SUBROUTINE SOILVEGIN  ( mosaic_lu,mosaic_soil,soilfrac,nscat,   &
         ZNT   = ZNT  + lufrac(k)/ALOG(LB/ZNTtoday(K))**2.
 ! ZNT1 - weighted average in the grid box, not used, computed for comparison
         ZNT1  = ZNT1 + lufrac(k)*ZNTtoday(K)
-        LAI   = LAI  + LAItoday(K)*lufrac(k)
+        if(.not.rdlai2d) LAI = LAI  + LAItoday(K)*lufrac(k)
         PC    = PC   + PCTBL(K)*lufrac(k)
       enddo
 
@@ -5484,7 +5513,7 @@ SUBROUTINE SOILVEGIN  ( mosaic_lu,mosaic_soil,soilfrac,nscat,   &
         EMISS = EMISS/AREA
         ZNT1   = ZNT1/AREA
         ZNT = LB/EXP(SQRT(1./ZNT))
-        LAI   = LAI/AREA
+        if(.not.rdlai2d) LAI = LAI/AREA
         PC    = PC /AREA
 
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
@@ -5498,7 +5527,7 @@ SUBROUTINE SOILVEGIN  ( mosaic_lu,mosaic_soil,soilfrac,nscat,   &
         EMISS = LEMITBL(IVGTYP)
         ZNT   = ZNTtoday(IVGTYP)
         PC    = PCTBL(IVGTYP)
-        LAI   = LAItoday(IVGTYP)
+        if(.not.rdlai2d) LAI = LAItoday(IVGTYP)
      endif
 
 ! parameters from SOILPARM.TBL
@@ -5644,7 +5673,8 @@ SUBROUTINE RUCLSMINIT( SH2O,SMFR3D,TSLB,SMOIS,ISLTYP,IVGTYP,     &
      CALL wrf_message( 'INITIALIZE THREE LSM RELATED TABLES' )
       if(mminlu == 'USGS') then
         MMINLURUC='USGS-RUC'
-      elseif(mminlu == 'MODIFIED_IGBP_MODIS_NOAH') then
+      elseif(mminlu == 'MODIS' .OR. &
+        &    mminlu == 'MODIFIED_IGBP_MODIS_NOAH') then
         MMINLURUC='MODI-RUC'
       endif
         MMINSL='STAS-RUC'
@@ -5713,8 +5743,8 @@ SUBROUTINE RUCLSMINIT( SH2O,SMFR3D,TSLB,SMOIS,ISLTYP,IVGTYP,     &
     ELSE
        if(isltyp(i,j).ne.14 ) then
 !-- land
-           mavail(i,j) = max(0.00001,min(1.,(smois(i,1,j)-qmin)/dqm))
-!           mavail(i,j) = max(0.00001,min(1.,smois(i,1,j)/(ref-qmin)))
+!           mavail(i,j) = max(0.00001,min(1.,(smois(i,1,j)-qmin)/dqm))
+           mavail(i,j) = max(0.00001,min(1.,smois(i,1,j)/(ref-qmin)))
          DO L=1,NZS
 !-- for land points initialize soil ice
          tln=log(TSLB(i,l,j)/273.15)
diff --git a/wrfv2_fire/phys/module_sf_sfclay.F b/wrfv2_fire/phys/module_sf_sfclay.F
index 1b463115..bc46a34e 100644
--- a/wrfv2_fire/phys/module_sf_sfclay.F
+++ b/wrfv2_fire/phys/module_sf_sfclay.F
@@ -361,7 +361,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
       REAL    ::  PL,THCON,TVCON,E1
       REAL    ::  ZL,TSKV,DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10
       REAL    ::  DTG,PSIX,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2,PSIQ10
-      REAL    ::  FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,RESTAR2
+      REAL    ::  FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,GZ0OZQ,GZ0OZT
       REAL    ::  ZW, ZN1, ZN2
 !-------------------------------------------------------------------
       KL=kte
@@ -703,16 +703,19 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
            IF ( ISFTCFLX.EQ.2 .AND. (XLAND(I)-1.5).GE.0. ) THEN
 ! AHW: Garratt formula: Calculate roughness Reynolds number
 !        Kinematic viscosity of air (linear approc to
-!                 temp dependence at sea levle)
+!                 temp dependence at sea level)
+! GZ0OZT and GZ0OZQ are based off formulas from Brutsaert (1975), which
+! Garratt (1992) used with values of k = 0.40, Pr = 0.71, and Sc = 0.60
               VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5
 !!            VISC=1.5E-5
               RESTAR=UST(I)*ZNT(I)/VISC
-              RESTAR2=2.48*SQRT(SQRT(RESTAR))-2.
-              PSIT=GZ1OZ0(I)-PSIH(I)+RESTAR2
-              PSIQ=GZ1OZ0(I)-PSIH(I)+2.28*SQRT(SQRT(RESTAR))-2.
-              PSIT2=GZ2OZ0(I)-PSIH2(I)+RESTAR2
-              PSIQ2=GZ2OZ0(I)-PSIH2(I)+2.28*SQRT(SQRT(RESTAR))-2.
-              PSIQ10=GZ10OZ0(I)-PSIH(I)+2.28*SQRT(SQRT(RESTAR))-2.
+              GZ0OZT=0.40*(7.3*SQRT(SQRT(RESTAR))*SQRT(0.71)-5.)
+              GZ0OZQ=0.40*(7.3*SQRT(SQRT(RESTAR))*SQRT(0.60)-5.)
+              PSIT=GZ1OZ0(I)-PSIH(I)+GZ0OZT
+              PSIQ=GZ1OZ0(I)-PSIH(I)+GZ0OZQ
+              PSIT2=GZ2OZ0(I)-PSIH2(I)+GZ0OZT
+              PSIQ2=GZ2OZ0(I)-PSIH2(I)+GZ0OZQ
+              PSIQ10=GZ10OZ0(I)-PSIH(I)+GZ0OZQ
            ENDIF
         ENDIF
         IF(PRESENT(ck) .and. PRESENT(cd) .and. PRESENT(cka) .and. PRESENT(cda)) THEN
diff --git a/wrfv2_fire/phys/module_sf_sfclayrev.F b/wrfv2_fire/phys/module_sf_sfclayrev.F
index 9f4ae687..931e6229 100644
--- a/wrfv2_fire/phys/module_sf_sfclayrev.F
+++ b/wrfv2_fire/phys/module_sf_sfclayrev.F
@@ -24,7 +24,7 @@ SUBROUTINE SFCLAYREV(U3D,V3D,T3D,QV3D,P3D,dz8w,                    &
                      ids,ide, jds,jde, kds,kde,                    &
                      ims,ime, jms,jme, kms,kme,                    &
                      its,ite, jts,jte, kts,kte,                    &
-                     ustm,ck,cka,cd,cda,isftcflx,iz0tlnd           )
+                     ustm,ck,cka,cd,cda,isftcflx,iz0tlnd,scm_force_flux           )
 !-------------------------------------------------------------------
       IMPLICIT NONE
 !-------------------------------------------------------------------
@@ -182,6 +182,7 @@ SUBROUTINE SFCLAYREV(U3D,V3D,T3D,QV3D,P3D,dz8w,                    &
                 INTENT(OUT)     ::              ck,cka,cd,cda,ustm
 
       INTEGER,  OPTIONAL,  INTENT(IN )   ::     ISFTCFLX, IZ0TLND
+      INTEGER,  OPTIONAL,  INTENT(IN )   ::     SCM_FORCE_FLUX
 ! LOCAL VARS
 
       REAL,     DIMENSION( its:ite ) ::                       U1D, &
@@ -227,7 +228,7 @@ SUBROUTINE SFCLAYREV(U3D,V3D,T3D,QV3D,P3D,dz8w,                    &
                 ims,ime, jms,jme, kms,kme,                         &
                 its,ite, jts,jte, kts,kte                          &
 #if ( EM_CORE == 1 )
-                ,isftcflx,iz0tlnd,                                 &
+                ,isftcflx,iz0tlnd,scm_force_flux,                               &
                 USTM(ims,j),CK(ims,j),CKA(ims,j),                  &
                 CD(ims,j),CDA(ims,j)                               &
 #endif
@@ -251,7 +252,7 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
                      ids,ide, jds,jde, kds,kde,                    &
                      ims,ime, jms,jme, kms,kme,                    &
                      its,ite, jts,jte, kts,kte,                    &
-                     isftcflx, iz0tlnd,                            &
+                     isftcflx, iz0tlnd,scm_force_flux,                            &
                      ustm,ck,cka,cd,cda                            )
 !-------------------------------------------------------------------
       IMPLICIT NONE
@@ -326,6 +327,7 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
                 INTENT(OUT)     ::              ck,cka,cd,cda,ustm
 
       INTEGER,  OPTIONAL,  INTENT(IN )   ::     ISFTCFLX, IZ0TLND
+      INTEGER,  OPTIONAL,  INTENT(IN )   ::     SCM_FORCE_FLUX
 
 ! LOCAL VARS
 
@@ -358,7 +360,8 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
       REAL    ::  PL,THCON,TVCON,E1
       REAL    ::  ZL,TSKV,DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10
       REAL    ::  DTG,PSIX,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2,PSIQ10
-      REAL    ::  FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,RESTAR2
+      REAL    ::  FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,GZ0OZQ,GZ0OZT
+      REAL    ::  ZW, ZN1, ZN2
 !
 ! .... paj ...
 !
@@ -722,15 +725,17 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
           IF ( ISFTCFLX.EQ.2 .AND. (XLAND(I)-1.5).GE.0. ) THEN
 ! AHW: Garratt formula: Calculate roughness Reynolds number
 !        Kinematic viscosity of air (linear approc to
-!                 temp dependence at sea levle)
+!                 temp dependence at sea level)
+! GZ0OZT and GZ0OZQ are based off formulas from Brutsaert (1975), which
+! Garratt (1992) used with values of k = 0.40, Pr = 0.71, and Sc = 0.60
               VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5
 !!            VISC=1.5E-5
               RESTAR=UST(I)*ZNT(I)/VISC
-              RESTAR2=2.48*SQRT(SQRT(RESTAR))-2.
+              GZ0OZT=0.40*(7.3*SQRT(SQRT(RESTAR))*SQRT(0.71)-5.)
 !
 ! ... paj: compute psih for z0t for temperature ...
 !
-              z0t=znt(I)/exp(RESTAR2)
+              z0t=znt(I)/exp(GZ0OZT)
 !
            zolzz=zol(I)*(za(I)+z0t)/za(I)    ! (z+z0t)/L
            zol10=zol(I)*(10.+z0t)/za(I)   ! (10+z0t)/L
@@ -758,12 +763,13 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
               PSIT=ALOG((ZA(I)+z0t)/Z0t)-PSIH(I)
               PSIT2=ALOG((2.+z0t)/Z0t)-PSIH2(I)
 !
-              z0t=znt(I)/exp(2.28*SQRT(SQRT(RESTAR))-2.)
+              GZ0OZQ=0.40*(7.3*SQRT(SQRT(RESTAR))*SQRT(0.60)-5.)
+              z0q=znt(I)/exp(GZ0OZQ)
 !
-           zolzz=zol(I)*(za(I)+z0t)/za(I)    ! (z+z0t)/L
-           zol10=zol(I)*(10.+z0t)/za(I)   ! (10+z0t)/L
-           zol2=zol(I)*(2.+z0t)/za(I)     ! (2+z0t)/L
-           zol0=zol(I)*z0t/za(I)          ! z0t/L
+           zolzz=zol(I)*(za(I)+z0q)/za(I)    ! (z+z0q)/L
+           zol10=zol(I)*(10.+z0q)/za(I)   ! (10+z0q)/L
+           zol2=zol(I)*(2.+z0q)/za(I)     ! (2+z0q)/L
+           zol0=zol(I)*z0q/za(I)          ! z0q/L
 !
               if (zol(I).gt.0.) then
               psih(I)=psih_stable(zolzz)-psih_stable(zol0)
@@ -781,9 +787,9 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
                 endif
               endif
 !
-              PSIQ=ALOG((ZA(I)+z0t)/Z0t)-PSIH(I)
-              PSIQ2=ALOG((2.+z0t)/Z0t)-PSIH2(I)
-              PSIQ10=ALOG((10.+z0t)/Z0t)-PSIH10(I)
+              PSIQ=ALOG((ZA(I)+z0q)/Z0q)-PSIH(I)
+              PSIQ2=ALOG((2.+z0q)/Z0q)-PSIH2(I)
+              PSIQ10=ALOG((10.+z0q)/Z0q)-PSIH10(I)
 !              PSIQ=GZ1OZ0(I)-PSIH(I)+2.28*SQRT(SQRT(RESTAR))-2.
 !              PSIQ2=GZ2OZ0(I)-PSIH2(I)+2.28*SQRT(SQRT(RESTAR))-2.
 !              PSIQ10=GZ10OZ0(I)-PSIH(I)+2.28*SQRT(SQRT(RESTAR))-2.
@@ -870,11 +876,14 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
   335 CONTINUE                                                                   
                                                                                   
 !-----COMPUTE THE SURFACE SENSIBLE AND LATENT HEAT FLUXES:                       
-                                                                                 
+      IF ( PRESENT(SCM_FORCE_FLUX) ) THEN
+         IF (SCM_FORCE_FLUX.EQ.1) GOTO 350
+      ENDIF
       DO i=its,ite
         QFX(i)=0.                                                              
         HFX(i)=0.                                                              
       ENDDO
+  350 CONTINUE                                                                   
 
       IF (ISFFLX.EQ.0) GOTO 410                                                
                                                                                  
@@ -887,8 +896,16 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
           IF ( PRESENT(ISFTCFLX) ) THEN
              IF ( ISFTCFLX.NE.0 ) THEN
 !               ZNT(I)=10.*exp(-9.*UST(I)**(-.3333))
-                ZNT(I)=10.*exp(-9.5*UST(I)**(-.3333))
-                ZNT(I)=ZNT(I) + 0.11*1.5E-5/AMAX1(UST(I),0.01)
+!               ZNT(I)=10.*exp(-9.5*UST(I)**(-.3333))
+!               ZNT(I)=ZNT(I) + 0.11*1.5E-5/AMAX1(UST(I),0.01)
+!               ZNT(I)=0.011*UST(I)*UST(I)/G+OZO
+!               ZNT(I)=MAX(ZNT(I),3.50e-5)
+! AHW 2012:
+                ZW  = MIN((UST(I)/1.06)**(0.3),1.0)
+                ZN1 = 0.011*UST(I)*UST(I)/G + OZO
+                ZN2 = 10.*exp(-9.5*UST(I)**(-.3333)) + &
+                       0.11*1.5E-5/AMAX1(UST(I),0.01)
+                ZNT(I)=(1.0-ZW) * ZN1 + ZW * ZN2
                 ZNT(I)=MIN(ZNT(I),2.85e-3)
                 ZNT(I)=MAX(ZNT(I),1.27e-7)
              ENDIF
@@ -915,6 +932,10 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
 !                                                                                
 !     IF(IDRY.EQ.1)GOTO 390                                                
 !                                                                                
+     IF ( PRESENT(SCM_FORCE_FLUX) ) THEN
+        IF (SCM_FORCE_FLUX.EQ.1) GOTO 405
+     ENDIF
+
       DO 370 I=its,ite
         QFX(I)=FLQC(I)*(QSFC(I)-QX(I))                                     
         QFX(I)=AMAX1(QFX(I),0.)                                            
@@ -938,6 +959,8 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
           HFX(I)=AMAX1(HFX(I),-250.)                                       
         ENDIF                                                                  
   400 CONTINUE                                                                 
+
+  405 CONTINUE                                                                 
          
       DO I=its,ite
          IF((XLAND(I)-1.5).GE.0)THEN
diff --git a/wrfv2_fire/phys/module_sf_ssib.F b/wrfv2_fire/phys/module_sf_ssib.F
index 60ad9a45..70d117ef 100755
--- a/wrfv2_fire/phys/module_sf_ssib.F
+++ b/wrfv2_fire/phys/module_sf_ssib.F
@@ -882,7 +882,7 @@ MODULE module_sf_ssib
 !
 !-----------------------------------------------------------------------
 !**********************************************
-      SUBROUTINE SSIB( II, JJ, DDTT, ITIME, ZLAT, SUNANGLE,      &
+      SUBROUTINE SSIB( IX, JX, DDTT, ITIME, ZLAT, SUNANGLE,      &
                           PPL, PPC, RLWDOWN, ZWIND2,             &
                           WWW1, WWW2, WWW3,                      &
                           TC, TGS, TD,                           &
@@ -903,7 +903,7 @@ SUBROUTINE SSIB( II, JJ, DDTT, ITIME, ZLAT, SUNANGLE,      &
    DZO2,WO2,TSSN2,TSSNO2,BWO2,BTO2,CTO2,FIO2,FLO2,BIO2,BLO2,HO2, & ! snow
    DZO3,WO3,TSSN3,TSSNO3,BWO3,BTO3,CTO3,FIO3,FLO3,BIO3,BLO3,HO3, & ! snow
    DZO4,WO4,TSSN4,TSSNO4,BWO4,BTO4,CTO4,FIO4,FLO4,BIO4,BLO4,HO4, & ! snow
-                          DAY, CLOUD, Q2M, TA, BEDO,             &
+                          DAY, CLOUD, Q2M, TA, BEDO, UV10,       & ! add uv10 (01/2014)
                           sw_physics, MMINLU                     &
                                                    )
 !**********************************************
@@ -1234,7 +1234,7 @@ SUBROUTINE SSIB( II, JJ, DDTT, ITIME, ZLAT, SUNANGLE,      &
             DZ,DZO,W,WO,WF,TSSN,TSSNO,BW,BWO,CT,CTO,FI,FIO,FL,FLO,         &
             BL,BLO,BI,BIO,BT,BTO,DMLT,DMLTO,H,HO,S,SO,SS,SSO,DSOL,DHP,     &
             DICEVOL,DLIQVOL,THK,QK,SWE,SNOWDEN,SNOWDEPTH,TKAIR,SNROFF,     &
-            DZSOIL,BPS,rib,CU,XCT,flup,ii,jj)
+            DZSOIL,BPS,rib,CU,XCT,flup,UV10)
 !
       CALL OLD(TSSN,BW,BL,BI,H,FL,FI,W,DZ,SS,CT,BT,DMLT,                   &
                  TSSNO,BWO,BLO,BIO,HO,FLO,FIO,WO,DZO,SSO,CTO,BTO,DMLTO)
@@ -1248,7 +1248,7 @@ SUBROUTINE SSIB( II, JJ, DDTT, ITIME, ZLAT, SUNANGLE,      &
          ZLT,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP,PH1,PH2,     &
          ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF,ALBEDO,ZLWUP,     &
          THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, ISNOW,SNOWDEN,          &
-         BPS,rib,CU,XCT,flup,ii,jj)
+         BPS,rib,CU,XCT,flup,UV10)
 !
       SWE=CAPAC(2)
       SNOWDEPTH=SWE*SNOWDEN
@@ -1366,7 +1366,7 @@ END SUBROUTINE SSIB
 !-----------------------------------------------------------------------
 !**********************************************
       SUBROUTINE SSIB_SEAICE                                  &
-                     ( II, JJ, DDTT, ITIME, ZLAT, SUNANGLE,   &
+                     ( IX, JX, DDTT, ITIME, ZLAT, SUNANGLE,   &
                        PPL, PPC, RLWDOWN, ZWIND2,             &
                        WWW1, WWW2, WWW3,                      &
                        TC, TGS, TD,                           &
@@ -1382,7 +1382,7 @@ SUBROUTINE SSIB_SEAICE                                  &
                                    XSDN, XSUP, XLDN, XLUP,    & ! output
                        XWAT,                         XXZ0,    & ! output
                        XVEG,                                  & ! output
-                       DAY, CLOUD, Q2M, TA, BEDO,             &
+                       DAY, CLOUD, Q2M, TA, BEDO, UV10,       &
                        sw_physics,ice_threshold               &
                                                    )
 !**********************************************
@@ -1646,7 +1646,7 @@ SUBROUTINE SSIB_SEAICE                                  &
          ZLT,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP,PH1,PH2,     &
          ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF,ALBEDO,ZLWUP,     &
          THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, ISNOW,SNOWDEN,          &
-         BPS,rib,CU,XCT,flup,ii,jj)
+         BPS,rib,CU,XCT,flup,UV10)
 !
       CALL UPDAT1_ICE(DTT ,TC,TGS,TD,CAPAC,DTC,DTG,ECT,ECI,EGT,EGI,           &
          EGS,EG,HC,HG,HFLUX,ETMASS,FILTR,SOILDIF,SOILDRA,ROFF,            &
@@ -1673,7 +1673,7 @@ SUBROUTINE SSIB_SEAICE                                  &
       CH=1/(UM*RA)
 !
       FM=VKC/CU
-!      FH=VKC/CT   !fds corrected (02/2012)
+!     FH=VKC/CT   !fds corrected (02/2012)
       FH=VKC/XCT
 !
 !
@@ -2881,12 +2881,12 @@ SUBROUTINE NEWTON(A1,Y,FINC,NOX,NONPOS,IWOLK,L,ZINC,A2,Y1,ITER)
 ! ** CONTROL VALUES: FINC,ERTOL,NOX,NONPOS,L:MUST BE SET BY USER
 !-----------------------------------------------------------------------
 !
-!cfds Changes according to Jack (Feb/2008)
+!fds Changes according to Jack (Feb/2008)
  REAL, DIMENSION (3) ::  IWALK, NEX, ITER
  REAL, DIMENSION (3) :: ZINC, A2, Y1
 
-!cfds  DIMENSION  IWALK(3), NEX(3)
-!cfds  DIMENSION  ZINC(3), A2(3), Y1(3),ITER3(3)
+!fds  DIMENSION  IWALK(3), NEX(3)
+!fds  DIMENSION  ZINC(3), A2(3), Y1(3),ITER3(3)
        DATA CONS/1.0/
 !
        ERTOL = 0.05 * FINC
@@ -3762,8 +3762,8 @@ SUBROUTINE RADAB_ICE(TRAN,REF,GREEN,VCOVER,CHIL,ZLT,Z2,Z1,SOREF, &
          if (bedo.gt.1.) then
             sibsu =  0.
             bedo = .1
- print*,'albebo incorrect',ii,jj,bedo,sibsu,swdown, &
-            radn(1,1),radn(1,2),radn(2,1),radn(2,2)
+! print*,'albebo incorrect',ix,jx,bedo,sibsu,swdown, &
+!           radn(1,1),radn(1,2),radn(2,1),radn(2,2)
          endif
       else
          sibsu = 0.0
@@ -3870,8 +3870,7 @@ END SUBROUTINE RADAB_ICE
 !=======================================================================
 !                                                                       
       SUBROUTINE RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZZWIND,UMM1,        &
-                 RHOA,TMM,U2,USTAR,DRAG,TA,bps,rib,CU,CT,iii,jjj)
-!cxx             RHOA,TMM,U2,USTAR,DRAG,TA,bps0,bps1,rib,CU,CT)
+                 RHOA,TMM,U2,USTAR,DRAG,TA,bps,rib,CU,CT,UV10)
 !                                                      2001,1,11
 !=======================================================================
 !
@@ -3978,6 +3977,10 @@ SUBROUTINE RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZZWIND,UMM1,        &
       DRAG = RHOA * UEST*UEST
       Z2 = Z22
 !
+!fds Calculate 10m wind intensity (Jan/2014)
+     CUNI10 = ALOG((z2+10-D)/Z0)/VKC
+     UV10 = USTAR * (CUNI10+FVV)
+!
 !------------------------------------------------------
       END SUBROUTINE RASIT5
 !------------------------------------------------------
@@ -4498,8 +4501,7 @@ SUBROUTINE TEMRS1                                                 &
          ZLAI,DEFAC,TU,TL,TOPT,RSTFAC,NROOT,ROOTD,PHSOIL,ROOTP,PH1,PH2, &
          ECT,ECI,EGT,EGI,EGS,HC,HG,EC,EG,EA,RADT,CHF,SHF,ALBEDO,ZLWUP,  &
          THERMK,RHOAIR,ZWIND,UM,USTAR,DRAG,CCX,CG, ISNOW,SNOWDEN,       &
-         BPS,rib,CU,XCT,flup,iii,jjj)
-!cxx     BPS,BPS0,BPS1,rib,CU,XCT,flup)
+         BPS,rib,CU,XCT,flup,UV10)
 !
 !=======================================================================
 ! ------------------------------------------------------------------7272
@@ -4605,7 +4607,7 @@ SUBROUTINE TEMRS1                                                 &
 1000  CONTINUE
       ICOUNT = ICOUNT + 1
       CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM,                  &
-                  RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,iii,jjj)
+                  RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,UV10)
 !cl    ------------IF ( IFIRST .EQ. 1 ) CALL RBRD1 ------------
         IF ( IFIRST .EQ. 1 ) THEN
 !cl      TCTA = TC - TA
@@ -4687,7 +4689,7 @@ SUBROUTINE TEMRS1                                                 &
                    Y1(LX)   = 0.
 2000  CONTINUE
       CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM,                 &
-                  RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,iii,jjj)
+                  RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,UV10)
 !======================================================================
 !cl    CALL DELHF ( HCDTC, HCDTG, HGDTG, HGDTC )
 !     PARTIAL DERIVATIVES OF SENSIBLE HEAT FLUXES
@@ -4914,7 +4916,7 @@ SUBROUTINE TEMRS2                                                 &
             DZ,DZO,W,WO,WF,TSSN,TSSNO,BW,BWO,CT,CTO,FI,FIO,FL,FLO,      &
             BL,BLO,BI,BIO,BT,BTO,DMLT,DMLTO,H,HO,S,SO,SS,SSO,DSOL,DHP,  &
             DICEVOL,DLIQVOL,THK,QK,SWE,SNOWDEN,SNOWDEPTH,TKAIR,SNROFF,  &
-            DZSOIL,BPS,rib,CU,XCT,flup,iii,jjj)
+            DZSOIL,BPS,rib,CU,XCT,flup,UV10)
 !
 !=======================================================================
 ! ------------------------------------------------------------------7272
@@ -5047,7 +5049,7 @@ SUBROUTINE TEMRS2                                                 &
 1000  CONTINUE
       ICOUNT = ICOUNT + 1
       CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM,                 &
-                  RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,iii,jjj)
+                  RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,UV10)
 !cl    ------------IF ( IFIRST .EQ. 1 ) CALL RBRD1 ------------
         IF ( IFIRST .EQ. 1 ) THEN
 !cl      TCTA = TC - TA
@@ -5242,7 +5244,7 @@ SUBROUTINE TEMRS2                                                 &
 2000  CONTINUE
 !
       CALL RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZWIND,UM,                 &
-                  RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,iii,jjj)
+                  RHOAIR,TM,U2,USTAR,DRAG,TA,bps,rib,CU,XCT,UV10)
 !----------------------------------------------------------------------
 !cl    CALL DELHF ( HCDTC, HCDTG, HGDTG, HGDTC )
 !     PARTIAL DERIVATIVES OF SENSIBLE HEAT FLUXES
diff --git a/wrfv2_fire/phys/module_sf_temfsfclay.F b/wrfv2_fire/phys/module_sf_temfsfclay.F
index fd280ed7..85ed333d 100644
--- a/wrfv2_fire/phys/module_sf_temfsfclay.F
+++ b/wrfv2_fire/phys/module_sf_temfsfclay.F
@@ -323,22 +323,21 @@ SUBROUTINE temfsfclay1d(j,u1d,v1d,th1d,qv1d,p1d, &
       kh(i) = max(kh(i),conduc_temf)
 
       ! Surface fluxes
-      ust(i) = sqrt(ftau(i)/ftau0) * sqrt(u1d(i)**2. + v1d(i)**2.) * leps(i) / log(zm(i)/znt(i)) / zt(i)
+      ! WA TEST 11/7/13 use w* as a component of the mean wind inside the
+      ! u* calculation instead of in the velocity scale below (Felix)
+      ! ust(i) = sqrt(ftau(i)/ftau0) * sqrt(u1d(i)**2. + v1d(i)**2.) * leps(i) / log(zm(i)/znt(i)) / zt(i)
+      ust(i) = sqrt(ftau(i)/ftau0) * sqrt(u1d(i)**2. + v1d(i)**2. + (0.5*wstr(i))**2.) * leps(i) / log(zm(i)/znt(i)) / zt(i)
       ang(i) = atan2(v1d(i),u1d(i))
 
+      ! WA TEST 11/7/13 back to wm = u* but with "whole" wind in u* above
+      wm(i) = ust(i)
       ! Calculate mixed scaling velocity (Moeng & Sullivan 1994 JAS p.1021)
-      ! Replaces ust everywhere (WA need to reconsider?)
-      ! WA wm is too large, makes surface flux too big and cools sfc too much
-      ! wm(i) = (1./5. * (wstr(i)**3. + 5. * ust(i)**3.)) ** (1./3.) 
-      ! WA TEST (R2,R11) 7/23/10 reduce velocity scale to fix excessive fluxes
-      wm(i) = 0.5 * (1./5. * (wstr(i)**3. + 5. * ust(i)**3.)) ** (1./3.) 
-      ! WA TEST 2/14/11 limit contribution of w*
-      ! wm(i) = 0.5 * (1./5. * (min(0.8,wstr(i))**3. + 5. * ust(i)**3.)) ** (1./3.) 
+      ! wm(i) = 0.5 * (1./5. * (wstr(i)**3. + 5. * ust(i)**3.)) ** (1./3.) 
+
       ! WA TEST 2/22/11 average with previous value to reduce instability
       wm(i) = (wm(i) + wm_temfx(i)) / 2.0
-      wm_temfx(i) = wm(i)
-      ! WA TEST (R3-R10) 7/23/10 wm = u*
-      ! wm(i) = ust(i)
+      ! WA TEST 11/26/13 set min value
+      wm_temfx(i) = max(wm(i),1e-2)
 
       ! Populate surface exchange coefficient variables to go back out
       ! for next time step of surface scheme
diff --git a/wrfv2_fire/phys/module_sf_urban.F b/wrfv2_fire/phys/module_sf_urban.F
index e4e80bd1..186efc17 100644
--- a/wrfv2_fire/phys/module_sf_urban.F
+++ b/wrfv2_fire/phys/module_sf_urban.F
@@ -337,7 +337,6 @@ SUBROUTINE urban(LSOLAR,                                           & ! L
 
    REAL, INTENT(IN)    :: XLAT ! latitude                               [deg]
    REAL, INTENT(IN)    :: DELT ! time step                              [s]
-   REAL, INTENT(IN)    :: ZNT  ! roughness length                       [m]
    REAL, INTENT(IN)    :: CHS,CHS2 ! CH*U at za and 2 m             [m/s]
 
    REAL, INTENT(INOUT) :: SSGD ! downward direct short wave radiation   [W/m/m]
@@ -346,6 +345,7 @@ SUBROUTINE urban(LSOLAR,                                           & ! L
    REAL, INTENT(INOUT) :: CHR_URB
    REAL, INTENT(INOUT) :: CMC_URB
    REAL, INTENT(INOUT) :: CHC_URB
+   REAL, INTENT(INOUT) :: ZNT  ! roughness length                       [m]    ! modified by danli
 !-------------------------------------------------------------------------------
 ! I: NUDAPT Input Parameters
 !-------------------------------------------------------------------------------
@@ -1180,6 +1180,7 @@ SUBROUTINE urban(LSOLAR,                                           & ! L
    Z0 = Z0C 
    Z0H = Z0HC
    Z = ZA - ZDC
+   ZNT = Z0   ! add by Dan Li
 
    XXX = 0.4*9.81*Z*TST/TA/UST/UST
 
diff --git a/wrfv2_fire/phys/module_shcu_camuwshcu.F b/wrfv2_fire/phys/module_shcu_camuwshcu.F
index 167efee0..65c32426 100644
--- a/wrfv2_fire/phys/module_shcu_camuwshcu.F
+++ b/wrfv2_fire/phys/module_shcu_camuwshcu.F
@@ -6,7 +6,12 @@ module uwshcu
   use cam_history,    only: outfld, addfld, phys_decomp
 #else
   use module_cam_support, only: outfld, addfld, phys_decomp
+#if ( NMM_CORE == 1 )
   use module_state_description, only: CAMUWPBLSCHEME, MYJPBLSCHEME
+#else
+  use module_state_description, only: CAMUWPBLSCHEME, MYJPBLSCHEME, &
+      MYNNPBLSCHEME2, MYNNPBLSCHEME3
+#endif
 #endif
   use error_function, only: erfc
 #ifndef WRF_PORT
@@ -182,10 +187,14 @@ subroutine init_uwshcu( kind, xlv_in, cp_in, xlf_in, zvir_in, r_in, g_in, ep2_in
 ! i.e. tke & tke_pbl.
 !
   select case(bl_pbl_physics)
+#if ( NMM_CORE == 1 )
   case (CAMUWPBLSCHEME, MYJPBLSCHEME)
+#else
+  case (CAMUWPBLSCHEME, MYJPBLSCHEME, MYNNPBLSCHEME2, MYNNPBLSCHEME3)
+#endif
      !These are acceptable PBL schemes.
   case default
-     call wrf_error_fatal("The CAMUWSHCU scheme requires either CAMUWPBLSCHEME or MYJPBLSCHEME.")
+     call wrf_error_fatal("The CAMUWSHCU scheme requires CAMUWPBLSCHEME, MYJPBLSCHEME or MYNN.")
   end select
 !
 ! Initialize module_cam_support variables...
@@ -2961,9 +2970,11 @@ subroutine compute_uwshcu( mix      , mkx       , iend         , ncnst    , dt
            qtu_top  =  qtu(kpen-1) + (  qt0(kpen) +  ssqt0(kpen) * (-ppen) / 2._r8  - qtu(kpen-1) ) * fer(kpen) * (-ppen)
        else
            thlu_top = ( thl0(kpen) + ssthl0(kpen) / fer(kpen) - ssthl0(kpen) * (-ppen) / 2._r8 ) - &
-                      ( thl0(kpen) + ssthl0(kpen) * (-ppen) / 2._r8 - thlu(kpen-1) + ssthl0(kpen) / fer(kpen) ) * exp(-fer(kpen) * (-ppen))
+                      ( thl0(kpen) + ssthl0(kpen) * (-ppen) / 2._r8 - thlu(kpen-1) + ssthl0(kpen) / fer(kpen) ) * &
+                        exp(-fer(kpen) * (-ppen))
            qtu_top  = ( qt0(kpen)  +  ssqt0(kpen) / fer(kpen) -  ssqt0(kpen) * (-ppen) / 2._r8 ) - &  
-                      ( qt0(kpen)  +  ssqt0(kpen) * (-ppen) / 2._r8 -  qtu(kpen-1) +  ssqt0(kpen) / fer(kpen) ) * exp(-fer(kpen) * (-ppen))
+                      ( qt0(kpen)  +  ssqt0(kpen) * (-ppen) / 2._r8 -  qtu(kpen-1) +  ssqt0(kpen) / fer(kpen) ) * &
+                        exp(-fer(kpen) * (-ppen))
        end if
 
        call conden(ps0(kpen-1)+ppen,thlu_top,qtu_top,thj,qvj,qlj,qij,qse,id_check,qsat)
@@ -4038,7 +4049,8 @@ subroutine compute_uwshcu( mix      , mkx       , iend         , ncnst    , dt
         ql0_star(:mkx) = ql0(:mkx) + qlten(:mkx) * dt
         qi0_star(:mkx) = qi0(:mkx) + qiten(:mkx) * dt
         s0_star(:mkx)  =  s0(:mkx) +  sten(:mkx) * dt
-        call positive_moisture_single( xlv, xls, mkx, dt, qmin(1), qmin(2), qmin(3), dp0, qv0_star, ql0_star, qi0_star, s0_star, qvten, qlten, qiten, sten )
+        call positive_moisture_single( xlv, xls, mkx, dt, qmin(1), qmin(2), qmin(3), dp0, &
+                                       qv0_star, ql0_star, qi0_star, s0_star, qvten, qlten, qiten, sten )
         qtten(:mkx)    = qvten(:mkx) + qlten(:mkx) + qiten(:mkx)
         slten(:mkx)    = sten(:mkx)  - xlv * qlten(:mkx) - xls * qiten(:mkx)
 
diff --git a/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F b/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F
index 6fb3ae7e..7eb5cff1 100644
--- a/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F
+++ b/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F
@@ -325,19 +325,19 @@ SUBROUTINE camuwshcu_driver(                                  &
 
            moist8(1,kflip,1:ncnst) = 0.
 
-           moist8(1,kflip,1) = max(0.0_r8,qv(i,k,j)/(1. + qv(i,k,j)))
+           moist8(1,kflip,1) = max(0.0,qv(i,k,j)/(1. + qv(i,k,j)))
 
            call cnst_get_ind( 'CLDLIQ', m )
-           moist8(1,kflip,m) = max(0.0_r8,qc(i,k,j)/(1. + qv(i,k,j)))
+           moist8(1,kflip,m) = max(0.0,qc(i,k,j)/(1. + qv(i,k,j)))
 
            call cnst_get_ind( 'CLDICE', m )
-           moist8(1,kflip,m) = max(0.0_r8,qi(i,k,j)/(1. + qv(i,k,j)))
+           moist8(1,kflip,m) = max(0.0,qi(i,k,j)/(1. + qv(i,k,j)))
 
            call cnst_get_ind( 'NUMLIQ', m )
-           moist8(1,kflip,m) = max(0.0_r8,qnc(i,k,j)/(1. + qv(i,k,j)))
+           moist8(1,kflip,m) = max(0.0,qnc(i,k,j)/(1. + qv(i,k,j)))
 
            call cnst_get_ind( 'NUMICE', m )
-           moist8(1,kflip,m) = max(0.0_r8,qni(i,k,j)/(1. + qv(i,k,j)))
+           moist8(1,kflip,m) = max(0.0,qni(i,k,j)/(1. + qv(i,k,j)))
 
 #ifdef WRF_CHEM
            !Following Do-Loop is obtained from chem/module_cam_mam_aerchem_driver.F 
diff --git a/wrfv2_fire/phys/module_shcu_grims.F b/wrfv2_fire/phys/module_shcu_grims.F
index a5a61aba..8845d5a7 100644
--- a/wrfv2_fire/phys/module_shcu_grims.F
+++ b/wrfv2_fire/phys/module_shcu_grims.F
@@ -10,43 +10,43 @@ module module_shcu_grims
    integer,parameter :: nxma = 151,nyma = 121
    integer,parameter :: nxsvp = 7501
 !
-   real,parameter :: t0c = 2.7315e+2
-   real,parameter :: psat = 6.1078e+2
-   real,parameter :: rd = 2.8705e+2
-   real,parameter :: rv = 4.6150e+2
-   real,parameter :: cp = 1.0046e+3
-   real,parameter :: hvap = 2.5000e+6
-   real,parameter :: cvap = 1.8460e+3
-   real,parameter :: cliq = 4.1855e+3
-   real,parameter :: cice = 2.1060E+3
-   real,parameter :: hsub = 2.8340E+6
-   real,parameter :: terrm = 1.e-4
-!
-   real,parameter :: rocp=rd/cp
-   real,parameter :: cpor=cp/rd
-   real,parameter :: eps=rd/rv
-   real,parameter :: ttp=t0c+0.01
-   real,parameter :: psatk=psat*1.e-3
-   real,parameter :: psatb=psatk*1.e-2
-   real,parameter :: dldt=cvap-cliq,xa=-dldt/rv,xb=xa+hvap/(rv*ttp)
-   real,parameter :: dldti=cvap-cice,xai=-dldti/rv,xbi=xai+hsub/(rv*ttp)
-!
-   real,save :: c1xma,c2xma,c1yma,c2yma,c1xpvs,c2xpvs
-   real,save :: c1xtdp,c2xtdp,c1xthe,c2xthe,c1ythe,c2ythe
-   real,save :: tbtdp(nxtdp)
-   real,save :: tbthe(nxthe,nythe)
-   real,save :: tbtma(nxma,nyma), tbqma(nxma,nyma)
-   real,save :: tbpvs(nxsvp)
+   real,parameter    :: t0c = 2.7315e+2
+   real,parameter    :: psat = 6.1078e+2
+   real,parameter    :: rd = 2.8705e+2
+   real,parameter    :: rv = 4.6150e+2
+   real,parameter    :: cp = 1.0046e+3
+   real,parameter    :: hvap = 2.5000e+6
+   real,parameter    :: cvap = 1.8460e+3
+   real,parameter    :: cliq = 4.1855e+3
+   real,parameter    :: cice = 2.1060E+3
+   real,parameter    :: hsub = 2.8340E+6
+   real,parameter    :: terrm = 1.e-4
+!
+   real,parameter    :: rocp=rd/cp
+   real,parameter    :: cpor=cp/rd
+   real,parameter    :: eps=rd/rv
+   real,parameter    :: ttp=t0c+0.01
+   real,parameter    :: psatk=psat*1.e-3
+   real,parameter    :: psatb=psatk*1.e-2
+   real,parameter    :: dldt=cvap-cliq,xa=-dldt/rv,xb=xa+hvap/(rv*ttp)
+   real,parameter    :: dldti=cvap-cice,xai=-dldti/rv,xbi=xai+hsub/(rv*ttp)
+!
+   real,save         :: c1xma,c2xma,c1yma,c2yma,c1xpvs,c2xpvs
+   real,save         :: c1xtdp,c2xtdp,c1xthe,c2xthe,c1ythe,c2ythe
+   real,save         :: tbtdp(nxtdp)
+   real,save         :: tbthe(nxthe,nythe)
+   real,save         :: tbtma(nxma,nyma), tbqma(nxma,nyma)
+   real,save         :: tbpvs(nxsvp)
 contains
 !
 !-------------------------------------------------------------------------------
-   subroutine grims(qv3d,t3d,p3di,p3d,pi3d,z3di, &
-                    wstar,hpbl,delta, &
-                    rthshten,rqvshten, &
-                    dt,g,xlv,rd,rv,rcp,p1000mb, &
-                    kpbl2d,znu,raincv, &
-                    ids,ide, jds,jde, kds,kde, &
-                    ims,ime, jms,jme, kms,kme, &
+   subroutine grims(qv3d,t3d,p3di,p3d,pi3d,z3di,                               &
+                    wstar,hpbl,delta,                                          &
+                    rthshten,rqvshten,                                         &
+                    dt,g,xlv,rd,rv,rcp,p1000mb,                                &
+                    kpbl2d,znu,raincv,                                         &
+                    ids,ide, jds,jde, kds,kde,                                 &
+                    ims,ime, jms,jme, kms,kme,                                 &
                     its,ite, jts,jte, kts,kte)
 !-------------------------------------------------------------------------------
    implicit none
@@ -54,98 +54,98 @@ subroutine grims(qv3d,t3d,p3di,p3d,pi3d,z3di, &
 !
 ! input argument
 !
-!-- qv3d 3d specific humidity (kgkg-1)
-!-- t3d 3d temperature (k)
-!-- p3di 3d pressure (pa) at interface level
-!-- p3d 3d pressure (pa)
-!-- pi3d 3d exner function (dimensionless)
-!-- z3di 3d z at interface level (m)
-!-- wstar convective velocity scale (ms-1) from pbl
-!-- hpbl pbl height (m)
-!-- delta entrainment layer depth (m)
-!-- rthshten computed theta tendency due to shallow convection scheme
-!-- rqvshten computed q_v tendency due to shallow convection scheme
-!-- dt time step (s)
-!-- g acceleration due to gravity (m/s^2)
-!-- xlv latent heat of vaporization (j/kg)
-!-- rd gas constant for dry air (j/kg/k)
-!-- rv gas constant for water vapor (j/kg/k)
-!-- kpbl2d k-index for pbl top
-!-- raincv time-step precipitation from cumulus convection scheme
-!-- znu eta values (sigma values)
-!-- ids start index for i in domain
-!-- ide end index for i in domain
-!-- jds start index for j in domain
-!-- jde end index for j in domain
-!-- kds start index for k in domain
-!-- kde end index for k in domain
-!-- ims start index for i in memory
-!-- ime end index for i in memory
-!-- jms start index for j in memory
-!-- jme end index for j in memory
-!-- kms start index for k in memory
-!-- kme end index for k in memory
-!-- its start index for i in tile
-!-- ite end index for i in tile
-!-- jts start index for j in tile
-!-- jte end index for j in tile
-!-- kts start index for k in tile
-!-- kte end index for k in tile
+!-- qv3d        3d specific humidity (kgkg-1)
+!-- t3d         3d temperature (k)
+!-- p3di        3d pressure (pa) at interface level
+!-- p3d         3d pressure (pa)
+!-- pi3d        3d exner function (dimensionless)
+!-- z3di        3d z at interface level (m)
+!-- wstar       convective velocity scale (ms-1) from pbl
+!-- hpbl        pbl height (m)
+!-- delta       entrainment layer depth (m)
+!-- rthshten    computed theta tendency due to shallow convection scheme
+!-- rqvshten    computed q_v tendency due to shallow convection scheme
+!-- dt          time step (s)
+!-- g           acceleration due to gravity (m/s^2)
+!-- xlv         latent heat of vaporization (j/kg)
+!-- rd          gas constant for dry air (j/kg/k)
+!-- rv          gas constant for water vapor (j/kg/k)
+!-- kpbl2d      k-index for pbl top
+!-- raincv      time-step precipitation from cumulus convection scheme
+!-- znu         eta values (sigma values)
+!-- ids         start index for i in domain
+!-- ide         end index for i in domain
+!-- jds         start index for j in domain
+!-- jde         end index for j in domain
+!-- kds         start index for k in domain
+!-- kde         end index for k in domain
+!-- ims         start index for i in memory
+!-- ime         end index for i in memory
+!-- jms         start index for j in memory
+!-- jme         end index for j in memory
+!-- kms         start index for k in memory
+!-- kme         end index for k in memory
+!-- its         start index for i in tile
+!-- ite         end index for i in tile
+!-- jts         start index for j in tile
+!-- jte         end index for j in tile
+!-- kts         start index for k in tile
+!-- kte         end index for k in tile
 !
 ! output argument
-!-- rthshten computed theta tendency due to shallow convection scheme
-!-- rqvshten computed q_v tendency due to shallow convection scheme
+!-- rthshten    computed theta tendency due to shallow convection scheme
+!-- rqvshten    computed q_v tendency due to shallow convection scheme
 !-------------------------------------------------------------------------------
 !
-! local
+! local 
 !
-!-- icps cps index, =1 for deep convection
-!-- pi2di 2d exner function at interface level (dimensionless)
-!-- delp2di 2d pressuer depth (pa) between interface levels
-!-- zl 2d z (m)
-!-- t1 2d temperature (k) will be changed by shallow convection
-!-- q1 2d specific humidity (kgkg-1) will be changed by shallow convection
-!-- levshc maximum k-level for shallow convection
+!-- icps        cps index, =1 for deep convection
+!-- pi2di       2d exner function at interface level (dimensionless)
+!-- delp2di     2d pressuer depth (pa) between interface levels
+!-- zl          2d z (m)
+!-- t1          2d temperature (k) will be changed by shallow convection
+!-- q1          2d specific humidity (kgkg-1) will be changed by shallow convection
+!-- levshc      maximum k-level for shallow convection
 !
-   integer, intent(in ) :: ids,ide, jds,jde, kds,kde, &
-                                     ims,ime, jms,jme, kms,kme, &
+   integer,  intent(in   )   ::      ids,ide, jds,jde, kds,kde,                &
+                                     ims,ime, jms,jme, kms,kme,                &
                                      its,ite, jts,jte, kts,kte
 !
-   real, intent(in ) :: dt,g,xlv,rd,rv,rcp,p1000mb
+   real,     intent(in   )   ::      dt,g,xlv,rd,rv,rcp,p1000mb
 !
-   integer, dimension( ims:ime, jms:jme ) , &
-             intent(in ) :: kpbl2d
+   integer,  dimension( ims:ime, jms:jme )                                   , &
+             intent(in   )   ::                                        kpbl2d
 !
-   real, dimension( ims:ime, kms:kme, jms:jme ) , &
-             intent(in ) :: qv3d, &
+   real,     dimension( ims:ime, kms:kme, jms:jme )                          , &
+             intent(in   )   ::                                          qv3d, &
                                                                           t3d, &
                                                                          p3di, &
                                                                           p3d, &
                                                                          pi3d, &
                                                                          z3di
 !
-   real, dimension( ims:ime, jms:jme ) , &
-             intent(in ) :: hpbl, &
+   real,     dimension( ims:ime, jms:jme )                                   , &
+             intent(in   )   ::                                          hpbl, &
                                                                         wstar, &
                                                                         delta, &
                                                                        raincv
 !
-   real, dimension( kms:kme ) , &
-             intent(in ) :: znu
+   real,     dimension( kms:kme )                                            , &
+             intent(in   )   ::                                           znu
 !
-   real, dimension( ims:ime, kms:kme, jms:jme ) , &
-             optional , &
-             intent(inout) :: rthshten, &
+   real,     dimension( ims:ime, kms:kme, jms:jme )                          , &
+             optional                                                        , &
+             intent(inout)   ::                                      rthshten, &
                                                                      rqvshten
 !
-! local variables
+!  local variables
 !
-   integer :: i,j,k,levshc
-   real :: sigshc,rdelt
+   integer         ::  i,j,k,levshc
+   real            ::  sigshc,rdelt
 !
-   integer, dimension( its:ite ) :: icps
-   real, dimension( its:ite, kts:kte+1 ) :: pi2di
-   real, dimension( its:ite, kts:kte ) :: delp2di, &
+   integer,  dimension( its:ite )            ::                          icps
+   real,     dimension( its:ite, kts:kte+1 ) ::                         pi2di
+   real,     dimension( its:ite, kts:kte )   ::                       delp2di, &
                                                                            zl, &
                                                                            t1, &
                                                                            q1
@@ -188,15 +188,15 @@ subroutine grims(qv3d,t3d,p3di,p3d,pi3d,z3di, &
        if(raincv(i,j) .gt. 1.e-30) icps(i)=1
      enddo
 !
-     call grims2d(q=q1(its,kts),t=t1(its,kts),prsi=p3di(ims,kms,j), &
-              prsik=pi2di(its,kts),delprsi=delp2di(its,kts), &
-              prsl=p3d(ims,kms,j),prslk=pi3d(ims,kms,j),zl=zl(its,kts), &
-              wstar=wstar(ims,j),hpbl=hpbl(ims,j),delta=delta(ims,j), &
-              dt=dt,cp=cp,g=g,xlv=xlv,rd=rd,rv=rv, &
-              icps=icps(its),kpbl=kpbl2d(ims,j),levshc=levshc, &
-              ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde, &
-              ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme, &
-              its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte )
+     call grims2d(q=q1(its,kts),t=t1(its,kts),prsi=p3di(ims,kms,j),            &
+              prsik=pi2di(its,kts),delprsi=delp2di(its,kts),                   &
+              prsl=p3d(ims,kms,j),prslk=pi3d(ims,kms,j),zl=zl(its,kts),        &
+              wstar=wstar(ims,j),hpbl=hpbl(ims,j),delta=delta(ims,j),          &
+              dt=dt,cp=cp,g=g,xlv=xlv,rd=rd,rv=rv,                             &
+              icps=icps(its),kpbl=kpbl2d(ims,j),levshc=levshc,                 &
+              ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde,               &
+              ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme,               &
+              its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte   )
 !
      if(present(rthshten).and.present(rqvshten)) then
        do k = kts,kte
@@ -213,126 +213,127 @@ end subroutine grims
 !-------------------------------------------------------------------------------
 !
 !-------------------------------------------------------------------------------
-   subroutine grims2d(q,t,prsi,prsik,delprsi,prsl,prslk,zl, &
-                       wstar,hpbl,delta, &
-                       dt,cp,g,xlv,rd,rv, &
-                       icps,kpbl,levshc, &
-                       ids,ide, jds,jde, kds,kde, &
-                       ims,ime, jms,jme, kms,kme, &
+   subroutine grims2d(q,t,prsi,prsik,delprsi,prsl,prslk,zl,                    &
+                       wstar,hpbl,delta,                                       &
+                       dt,cp,g,xlv,rd,rv,                                      &
+                       icps,kpbl,levshc,                                       &
+                       ids,ide, jds,jde, kds,kde,                              &
+                       ims,ime, jms,jme, kms,kme,                              &
                        its,ite, jts,jte, kts,kte)
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
 !
+!
 !   this scheme applies an eddy-diffusion approach within the shallow convective 
 !   layer defined by the moist static energy profile and is coupled to the 
 !   ysu pbl properties. this scheme names after the grims
 !   shallow convection scheme since it was developed/evaluated in grims.
 !
 !   coded by song-you hong (yonsei university; ysu) and
-!   implemented by jihyeon jang, junhong lee (ysu), and wei wang (ncar)
-!       winter 2012
+!   implemented into wrf by jihyeon jang, hyeyum hailey shin, junhong lee (ysu), 
+!       and wei wang (ncar) winter 2012
 !
 ! references:
 !   hong et al. (2013, manuscript in preparation)
 !   hong et al. (2013, asia-pacific j. atmos. sci.) the global/regional 
-!       integrated model system (grims)        
+!       integrated model system (grims) 
 !
 !-------------------------------------------------------------------------------
 !
-   integer, intent(in ) :: levshc, &
-                                  ids,ide, jds,jde, kds,kde, &
-                                  ims,ime, jms,jme, kms,kme, &
+   integer,  intent(in   ) ::     levshc,                                      &
+                                  ids,ide, jds,jde, kds,kde,                   &
+                                  ims,ime, jms,jme, kms,kme,                   &
                                   its,ite, jts,jte, kts,kte
 !
-   real, intent(in ) :: dt,cp,g,xlv,rd,rv
+   real,     intent(in   ) ::     dt,cp,g,xlv,rd,rv
 !
-   integer, dimension( ims:ime ) , &
-             intent(in ) :: kpbl
+   integer,  dimension( ims:ime )                                            , &
+             intent(in   ) ::                                            kpbl
 !
-   real, dimension( ims:ime, kms:kme ) , &
-             intent(in ) :: prsi
+   real,     dimension( ims:ime, kms:kme )                                   , &
+             intent(in   ) ::                                            prsi
 !
-   real, dimension( its:ite, kts:kte+1 ) , &
-             intent(in ) :: prsik
+   real,     dimension( its:ite, kts:kte+1 )                                 , &
+             intent(in   ) ::                                           prsik 
 !
-   real, dimension( its:ite, kts:kte ) , &
-             intent(in ) :: delprsi, &
+   real,     dimension( its:ite, kts:kte )                                   , &
+             intent(in   ) ::                                         delprsi, &
                                                                            zl
 !
-   real, dimension( ims:ime, kms:kme ) , &
-             intent(in ) :: prsl, &
+   real,     dimension( ims:ime, kms:kme )                                   , &
+             intent(in   ) ::                                            prsl, &
                                                                         prslk
 !
-   integer, dimension( its:ite ) , &
-             intent(in ) :: icps
+   integer,     dimension( its:ite )                                         , &
+             intent(in   ) ::                                            icps
 !
-   real, dimension( its:ite, kts:kte ) , &
-             intent(inout) :: q, &
+   real,     dimension( its:ite, kts:kte )                                   , &
+             intent(inout) ::                                               q, &
                                                                             t
 !
-   real, dimension( ims:ime ) , &
-             intent(in ) :: hpbl, &
+   real,     dimension( ims:ime )                                            , &
+             intent(in   ) ::                                            hpbl, &
                                                                         wstar, &
                                                                         delta
 !
-! profile shape parameter
+!  profile shape parameter
 !
-   real,parameter :: pfac = 3.
+   real,parameter    ::  pfac = 3.
 !
-! maximum and minimum diffusivity
+!  maximum and minimum diffusivity 
 !
-   real,parameter :: xkzmax = 50., xkzmin = 0.001
+   real,parameter    ::  xkzmax = 50., xkzmin = 0.001
 !
-! maxium distance of a parcel to lcl (m)
+!  maxium distance of a parcel to lcl (m)
 !
-   real,parameter :: zdiffcr1 = 1500., zdiffcr2 = 1500.
+   real,parameter    ::  zdiffcr1 = 1000., zdiffcr2 = 1000.
 !
-! bounds of parcel origin
+!  bounds of parcel origin
 !
-   integer,parameter :: kliftl=2,kliftu=2
+   integer,parameter    ::  kliftl=2,kliftu=2
 !
-! scale factor for wstar
+!  scale factor for wstar
 !
-   real,parameter :: wsfac = 1.47
+   real,parameter       ::  wsfac = 1.47
 !
-! local variables and arrays
+!  local variables and arrays
 !
-   logical :: lshc(its:ite),flg(ite-its+1)
-   integer :: i,ik,ik1,iku,k,k1,k2,kt,n2
-   integer :: index2(ite-its+1)
-   integer :: klcl(ite-its+1),kbot(ite-its+1)
-   integer :: ktop(ite-its+1)
-   integer :: lmin(ite-its+1)
-   integer :: kb(ite-its+1),kbcon(ite-its+1)
-   real :: eps,epsm1
-   real :: eldq,xkzh,cpdt,rtdls
-   real :: dmse,dtodsu,dtodsl,dsig,dsdz1,dsdz2
-   real :: q2((ite-its+1)*kte)
-   real :: t2((ite-its+1)*kte)
-   real :: al((ite-its+1)*(kte-1))
-   real :: ad((ite-its+1)*kte)
-   real :: au((ite-its+1)*(kte-1))
-   real :: delprsi2((ite-its+1)*kte)
-   real :: prsi2((ite-its+1)*kte),prsik2((ite-its+1)*kte)
-   real :: prsl2((ite-its+1)*kte),prslk2((ite-its+1)*kte)
-   real :: qeso2((ite-its+1)*kte),rh2(ite-its+1)
-   real :: depth(ite-its+1),zdiff1(ite-its+1),zdiff2(ite-its+1)
-   real :: hmin(ite-its+1),hmax(ite-its+1)
-   real :: z(1:(ite-its+1),kts:kte)
-   real :: heo(1:(ite-its+1),kts:kte)
-   real :: heso(1:(ite-its+1),kts:kte)
-   real :: pik,height,xkzfac
+   logical              ::  lshc(its:ite),flg(ite-its+1)
+   integer              ::  i,ik,ik1,iku,k,k1,k2,kt,n2
+   integer              ::  index2(ite-its+1)
+   integer              ::  klcl(ite-its+1),kbot(ite-its+1)
+   integer              ::  ktop(ite-its+1)
+   integer              ::  lmin(ite-its+1)
+   integer              ::  kb(ite-its+1),kbcon(ite-its+1)
+   real                 ::  eps,epsm1
+   real                 ::  eldq,xkzh,cpdt,rtdls
+   real                 ::  dmse,dtodsu,dtodsl,dsig,dsdz1,dsdz2
+   real                 ::  q2((ite-its+1)*kte)
+   real                 ::  t2((ite-its+1)*kte)
+   real                 ::  al((ite-its+1)*(kte-1))
+   real                 ::  ad((ite-its+1)*kte)
+   real                 ::  au((ite-its+1)*(kte-1))
+   real                 ::  delprsi2((ite-its+1)*kte)
+   real                 ::  prsi2((ite-its+1)*kte),prsik2((ite-its+1)*kte)
+   real                 ::  prsl2((ite-its+1)*kte),prslk2((ite-its+1)*kte)
+   real                 ::  qeso2((ite-its+1)*kte),rh2(ite-its+1)
+   real                 ::  depth(ite-its+1),zdiff1(ite-its+1),zdiff2(ite-its+1)
+   real                 ::  hmin(ite-its+1),hmax(ite-its+1)
+   real                 ::  z(1:(ite-its+1),kts:kte)
+   real                 ::  heo(1:(ite-its+1),kts:kte)
+   real                 ::  heso(1:(ite-its+1),kts:kte)
+   real                 ::  pik,height,xkzfac
 !-------------------------------------------------------------------------------
 !
-   eps = rd/rv
+   eps   = rd/rv
    epsm1 = eps-1
 !
    do i = its,ite
      lshc(i)=.false.
    enddo
 !
-! check for moist static instability to trigger convection
+!  check for moist static instability to trigger convection
 !
    do k = kts,levshc-1
      do i = its,ite
@@ -349,7 +350,7 @@ subroutine grims2d(q,t,prsi,prsik,delprsi,prsl,prslk,zl, &
      if(wstar(i).lt.0.001) lshc(i)=.false.
    enddo
 !
-! reset i-dimension for active clouds
+!  reset i-dimension for active clouds
 !
    n2 = 0
    do i = its,ite
@@ -361,13 +362,13 @@ subroutine grims2d(q,t,prsi,prsik,delprsi,prsl,prslk,zl, &
 !
    if(n2.eq.0) return
 !
-! prepare the variables
+!  prepare the variables 
 !
    do k = kts,levshc
      do i = 1,n2
        if(lshc(index2(i))) then
          ik = (k-1)*n2+i
-         pik = prsl(index2(i),k)
+         pik = prsl(index2(i),k) 
          q2(ik) = q(index2(i),k)
          t2(ik) = t(index2(i),k)
          delprsi2(ik) = delprsi(index2(i),k)
@@ -376,10 +377,10 @@ subroutine grims2d(q,t,prsi,prsik,delprsi,prsl,prslk,zl, &
          prsik2(ik)= prsik(index2(i),k)
          prslk2(ik)= prslk(index2(i),k)
          z(i,k) = zl(index2(i),k)
-         qeso2(ik) = fpvs_pa(t2(ik))
+         qeso2(ik) = fpvs_pa(t2(ik)) 
          qeso2(ik) = eps * qeso2(ik) / (pik + epsm1 * qeso2(ik))
          qeso2(ik) = max(qeso2(ik),1.E-8)
-         heo(i,k) = g * z(i,k) + cp* t2(ik) + xlv * q2(ik)
+         heo(i,k)  = g * z(i,k) + cp* t2(ik) + xlv * q2(ik)
          heso(i,k) = g * z(i,k) + cp* t2(ik) + xlv * qeso2(ik)
        endif
      enddo
@@ -431,13 +432,13 @@ subroutine grims2d(q,t,prsi,prsik,delprsi,prsl,prslk,zl, &
      endif
    enddo
 !
-! compute moist adiabat and determine cloud top
+!  compute moist adiabat and determine cloud top
 !
-   call phys_moist_adiabat_pa(n2,levshc-1,kliftl,kliftu, &
-                           prsl2,prsik2,prslk2,t2,q2, &
-                           klcl,kbot,ktop,al,au,rd,rv, &
-                            ids,ide, jds,jde, kds,kde, &
-                            ims,ime, jms,jme, kms,kme, &
+   call phys_moist_adiabat_pa(n2,levshc-1,kliftl,kliftu,                       &
+                           prsl2,prsik2,prslk2,t2,q2,                          &
+                           klcl,kbot,ktop,al,au,rd,rv,                         &
+                            ids,ide, jds,jde, kds,kde,                         &
+                            ims,ime, jms,jme, kms,kme,                         &
                             its,ite, jts,jte, kts,kte)
 !
    do i = 1,n2
@@ -448,7 +449,7 @@ subroutine grims2d(q,t,prsi,prsik,delprsi,prsl,prslk,zl, &
      endif
    enddo
 !
-! revise the cloud top below minimum moist static energy
+!  revise the cloud top below minimum moist static energy
 !
    do i = 1,n2
      if(lshc(index2(i))) then
@@ -482,7 +483,7 @@ subroutine grims2d(q,t,prsi,prsik,delprsi,prsl,prslk,zl, &
      endif
    enddo
 !
-! compute diffusion properties
+!  compute diffusion properties
 !
    do i = 1,n2
      if(lshc(index2(i))) then
@@ -507,7 +508,7 @@ subroutine grims2d(q,t,prsi,prsik,delprsi,prsl,prslk,zl, &
    kt = k2-k1+1
    if(kt.lt.2) return
 !
-! set eddy viscosity coefficient xkzh at sigma interfaces
+!  set eddy viscosity coefficient xkzh at sigma interfaces
 !
    do i = 1,n2
      ik = (k1-1)*n2+i
@@ -535,7 +536,8 @@ subroutine grims2d(q,t,prsi,prsik,delprsi,prsl,prslk,zl, &
        if(k.ge.kbot(i).and.k.lt.ktop(i)) then
          height = z(i,k)-z(i,kbot(i))
          xkzfac = rh2(i)*wsfac*wstar(index2(i))*delta(index2(i))
-         xkzh = min(max(xkzfac*(1.-height/depth(i))**pfac,xkzmin),xkzmax)
+         xkzh = min(max(xkzfac*(1.-(height+hpbl(index2(i)))                    &
+                /(depth(i)+hpbl(index2(i))))**pfac,xkzmin),xkzmax)
        else
          xkzh = 0.
        endif
@@ -550,13 +552,13 @@ subroutine grims2d(q,t,prsi,prsik,delprsi,prsl,prslk,zl, &
      enddo
    enddo
 !
-! solve tri-diagonal matrix
+!  solve tri-diagonal matrix
 !
    ik1 = (k1-1)*n2+1
-   call scv_tri_diagonal_grims(n2,n2,kt,al(ik1),ad(ik1),au(ik1), &
+   call scv_tri_diagonal_grims(n2,n2,kt,al(ik1),ad(ik1),au(ik1),               &
                                 q2(ik1),t2(ik1),au(ik1),q2(ik1),t2(ik1))
 !
-! feedback to large-scale variables
+!  feedback to large-scale variables  
 !
    do k = k1,k2
      do i = 1,n2
@@ -576,182 +578,182 @@ end subroutine grims2d
    subroutine scv_tri_diagonal_grims(lons2,l,n,cl,cm,cu,r1,r2,au,a1,a2)
 !-------------------------------------------------------------------------------
 !
-! subprogram: scv_tri_diagonal
-!
-! abstract: this routine solves multiple tridiagonal matrix problems
-! with 2 right-hand-side and solution vectors for every matrix.
-! the solutions are found by eliminating off-diagonal coefficients,
-! marching first foreward then backward along the matrix diagonal.
-! the computations are vectorized around the number of matrices.
-! no checks are made for zeroes on the diagonal or singularity.
-!
-! program history log:
-! 1991-05-07 iredell
-! 2009-03-01 jung-eun kim fortran 90 and modules
-!
-! usage: call scv_tri_diagonal(l,n,cl,cm,cu,r1,r2,au,a1,a2)
-!
-! input argument list:
-! l - integer number of tridiagonal matrices
-! n - integer order of the matrices
-! cl - real (l,2:n) lower diagonal matrix elements
-! cm - real (l,n) main diagonal matrix elements
-! cu - real (l,n-1) upper diagonal matrix elements
-! (may be equivalent to au if no longer needed)
-! r1 - real (l,n) 1st right-hand-side vector elements
-! (may be equivalent to a1 if no longer needed)
-! r2 - real (l,n) 2nd right-hand-side vector elements
-! (may be equivalent to a2 if no longer needed)
-!
-! output argument list:
-! au - real (l,n-1) work array
-! a1 - real (l,n) 1st solution vector elements
-! a2 - real (l,n) 2nd solution vector elements
-!
-! remarks: this routine can be easily modified to solve a different
-! number of right-hand-sides and solutions per matrix besides 2.
-!
+! subprogram:  scv_tri_diagonal    
+!                                                                               
+! abstract: this routine solves multiple tridiagonal matrix problems            
+!   with 2 right-hand-side and solution vectors for every matrix.               
+!   the solutions are found by eliminating off-diagonal coefficients,           
+!   marching first foreward then backward along the matrix diagonal.            
+!   the computations are vectorized around the number of matrices.              
+!   no checks are made for zeroes on the diagonal or singularity.               
+!                                                                               
+! program history log:                                                          
+!   1991-05-07  iredell                                                           
+!   2009-03-01  jung-eun kim         fortran 90 and modules
+!                                                                               
+! usage:    call scv_tri_diagonal(l,n,cl,cm,cu,r1,r2,au,a1,a2)      
+!                                                                               
+!   input argument list:                                                        
+!     l        - integer number of tridiagonal matrices                         
+!     n        - integer order of the matrices                                  
+!     cl       - real (l,2:n) lower diagonal matrix elements                    
+!     cm       - real (l,n) main diagonal matrix elements                       
+!     cu       - real (l,n-1) upper diagonal matrix elements                    
+!                (may be equivalent to au if no longer needed)                  
+!     r1       - real (l,n) 1st right-hand-side vector elements                 
+!                (may be equivalent to a1 if no longer needed)                  
+!     r2       - real (l,n) 2nd right-hand-side vector elements                 
+!                (may be equivalent to a2 if no longer needed)                  
+!                                                                               
+!   output argument list:                                                       
+!     au       - real (l,n-1) work array                                        
+!     a1       - real (l,n) 1st solution vector elements                        
+!     a2       - real (l,n) 2nd solution vector elements                        
+!                                                                               
+! remarks: this routine can be easily modified to solve a different             
+!   number of right-hand-sides and solutions per matrix besides 2.              
+!                                                                               
 !-------------------------------------------------------------------------------
    implicit none
-   integer :: lons2,l,n,i,k
-   real :: fk
-   real :: cl(l,2:n),cm(l,n),cu(l,n-1),r1(l,n),r2(l,n), &
+   integer              ::  lons2,l,n,i,k
+   real                 ::  fk
+   real                 ::  cl(l,2:n),cm(l,n),cu(l,n-1),r1(l,n),r2(l,n),       &
                             au(l,n-1),a1(l,n),a2(l,n)
 !-------------------------------------------------------------------------------
    do i = 1,lons2
-     fk = 1./cm(i,1)
-     au(i,1)= fk*cu(i,1)
-     a1(i,1)= fk*r1(i,1)
-     a2(i,1)= fk*r2(i,1)
-   enddo
+     fk = 1./cm(i,1)                                                           
+     au(i,1)= fk*cu(i,1)                                                      
+     a1(i,1)= fk*r1(i,1)                                                      
+     a2(i,1)= fk*r2(i,1)                                                      
+   enddo                                                                     
 !
-   do k = 2,n-1
+   do k = 2,n-1                                                                
      do i = 1,lons2
-       fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1))
-       au(i,k) = fk*cu(i,k)
-       a1(i,k) = fk*(r1(i,k)-cl(i,k)*a1(i,k-1))
-       a2(i,k) = fk*(r2(i,k)-cl(i,k)*a2(i,k-1))
-     enddo
-   enddo
+       fk = 1./(cm(i,k)-cl(i,k)*au(i,k-1))                                     
+       au(i,k) = fk*cu(i,k)                                                    
+       a1(i,k) = fk*(r1(i,k)-cl(i,k)*a1(i,k-1))                                
+       a2(i,k) = fk*(r2(i,k)-cl(i,k)*a2(i,k-1))                                
+     enddo                                                                   
+   enddo                                                                     
 !
    do i = 1,lons2
-     fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1))
-     a1(i,n) = fk*(r1(i,n)-cl(i,n)*a1(i,n-1))
-     a2(i,n) = fk*(r2(i,n)-cl(i,n)*a2(i,n-1))
-   enddo
-   do k = n-1,1,-1
+     fk = 1./(cm(i,n)-cl(i,n)*au(i,n-1))                                       
+     a1(i,n) = fk*(r1(i,n)-cl(i,n)*a1(i,n-1))                                  
+     a2(i,n) = fk*(r2(i,n)-cl(i,n)*a2(i,n-1))                                  
+   enddo                                                                     
+   do k = n-1,1,-1                                                             
      do i = 1,lons2
-       a1(i,k) = a1(i,k)-au(i,k)*a1(i,k+1)
-       a2(i,k) = a2(i,k)-au(i,k)*a2(i,k+1)
-     enddo
-   enddo
+       a1(i,k) = a1(i,k)-au(i,k)*a1(i,k+1)                                     
+       a2(i,k) = a2(i,k)-au(i,k)*a2(i,k+1)                                     
+     enddo                                                                   
+   enddo                                                                     
 !
-   return
+   return                                                                    
    end subroutine scv_tri_diagonal_grims
 !-------------------------------------------------------------------------------
 !
 !-------------------------------------------------------------------------------
-   subroutine phys_moist_adiabat_pa(ilev,klev,k1,k2, &
-                                 prsl,prsik,prslk,tenv,qenv, &
-                                 klcl,kbot,ktop,tcld,qcld,rd,rv, &
-                                      ids,ide, jds,jde, kds,kde, &
-                                      ims,ime, jms,jme, kms,kme, &
+   subroutine phys_moist_adiabat_pa(ilev,klev,k1,k2,                           &
+                                 prsl,prsik,prslk,tenv,qenv,                   &
+                                 klcl,kbot,ktop,tcld,qcld,rd,rv,               &
+                                      ids,ide, jds,jde, kds,kde,               &
+                                      ims,ime, jms,jme, kms,kme,               &
                                       its,ite, jts,jte, kts,kte)
 !-------------------------------------------------------------------------------
 !
 ! subprogram: phys_moist_adiabat_pa
 !
-! abstract:
+! abstract: 
 ! - compute moist adiabatic cloud soundings
 ! - atmospheric columns of temperature and specific humidity
-! are examined by this routine for conditional instability.
-! the test parcel is chosen from the layer between layers k1 and k2
-! that has the warmest potential wet-bulb temperature.
-! excess cloud temperatures and specific humidities are returned
-! where the lifted parcel is found to be buoyant.
-! fast inlinable functions are invoked to compute
-! dewpoint and lifting condensation level temperatures,
-! equivalent potential temperature at the lcl, and
-! temperature and specific humidity of the ascending parcel.
+!   are examined by this routine for conditional instability.
+!   the test parcel is chosen from the layer between layers k1 and k2
+!   that has the warmest potential wet-bulb temperature.
+!   excess cloud temperatures and specific humidities are returned
+!   where the lifted parcel is found to be buoyant.
+!   fast inlinable functions are invoked to compute
+!   dewpoint and lifting condensation level temperatures,
+!   equivalent potential temperature at the lcl, and
+!   temperature and specific humidity of the ascending parcel.
 !
 ! program history log:
-! 1983-11-01 phillips
-! 1991-05-07 iredell arguments changed, code tidied
-! 2000-01-01 song-you hong physcis options
-! 2009-10-01 jung-eun kim f90 format with standard physics modules
-! 2010-07-01 myung-seo koo dimension allocatable with namelist input
-!
-! usage: call phys_moist_adiabat_pa(ilev,klev,k1,k2, &
-! prsl,prslk,prsik,tenv,qenv, &
-! klcl,kbot,ktop,tcld,qcld,rd,rv, &
-! ids,ide, jds,jde, kds,kde, &
-! ims,ime, jms,jme, kms,kme, &
-! its,ite, jts,jte, kts,kte)
-!
-! input argument list:
-! ilev - integer number of atmospheric columns
-! klev - integer number of sigma levels in a column
-! k1 - integer lowest level from which a parcel can originate
-! k2 - integer highest level from which a parcel can originate
-! prsl - real (ilev,klev) pressure values
-! prslk,prsik - real (ilev,klev) pressure values to the kappa
-! tenv - real (ilev,klev) environment temperatures
-! qenv - real (ilev,klev) environment specific humidities
-!
-! output argument list:
-! klcl - integer (ilev) level just above lcl (klev+1 if no lcl)
-! kbot - integer (ilev) level just above cloud bottom
-! ktop - integer (ilev) level just below cloud top
-! - note that kbot(i) gt ktop(i) if no cloud.
-! tcld - real (ilev,klev) of excess cloud temperatures.
-! (parcel t minus environ t, or 0. where no cloud)
-! qcld - real (ilev,klev) of excess cloud specific humidities.
-! (parcel q minus environ q, or 0. where no cloud)
+!   1983-11-01  phillips
+!   1991-05-07  iredell                arguments changed, code tidied
+!   2000-01-01  song-you hong          physcis options
+!   2009-10-01  jung-eun kim           f90 format with standard physics modules
+!   2010-07-01  myung-seo koo          dimension allocatable with namelist input
+!
+! usage:  call phys_moist_adiabat_pa(ilev,klev,k1,k2,                          &
+!                                 prsl,prslk,prsik,tenv,qenv,                  &
+!                                 klcl,kbot,ktop,tcld,qcld,rd,rv,              &
+!                                      ids,ide, jds,jde, kds,kde,              &
+!                                      ims,ime, jms,jme, kms,kme,              &
+!                                      its,ite, jts,jte, kts,kte)
+!
+!   input argument list:
+!     ilev         - integer number of atmospheric columns
+!     klev         - integer number of sigma levels in a column
+!     k1           - integer lowest level from which a parcel can originate
+!     k2           - integer highest level from which a parcel can originate
+!     prsl         - real (ilev,klev) pressure values
+!     prslk,prsik  - real (ilev,klev) pressure values to the kappa
+!     tenv         - real (ilev,klev) environment temperatures
+!     qenv         - real (ilev,klev) environment specific humidities
+!
+!   output argument list:
+!     klcl     - integer (ilev) level just above lcl (klev+1 if no lcl)
+!     kbot     - integer (ilev) level just above cloud bottom
+!     ktop     - integer (ilev) level just below cloud top
+!              - note that kbot(i) gt ktop(i) if no cloud.
+!     tcld     - real (ilev,klev) of excess cloud temperatures.
+!                (parcel t minus environ t, or 0. where no cloud)
+!     qcld     - real (ilev,klev) of excess cloud specific humidities.
+!                (parcel q minus environ q, or 0. where no cloud)
 !
 ! subprograms called:
-! ftdp - function to compute dewpoint temperature
-! ftlcl - function to compute lcl temperature
-! fthe - function to compute equivalent potential temperature
-! ftma - function to compute parcel temperature and humidity
+!     ftdp     - function to compute dewpoint temperature
+!     ftlcl    - function to compute lcl temperature
+!     fthe     - function to compute equivalent potential temperature
+!     ftma     - function to compute parcel temperature and humidity
 !
 ! remarks: all functions are inlined by fpp.
-! nonstandard automatic arrays are used.
+!          nonstandard automatic arrays are used.
 !
 !-------------------------------------------------------------------------------
    implicit none
 !
-   integer,parameter :: nx=151,ny=121
-   integer :: ilev,klev,k1,k2
-   real :: prsl(ilev,klev),prslk(ilev,klev),prsik(ilev,klev)
-   real :: tenv(ilev,klev),qenv(ilev,klev)
-   integer :: klcl(ilev),kbot(ilev),ktop(ilev)
-   real :: tcld(ilev,klev),qcld(ilev,klev)
-   real :: rd,rv
-   integer :: ids,ide, jds,jde, kds,kde, &
-                            ims,ime, jms,jme, kms,kme, &
+   integer,parameter    ::  nx=151,ny=121
+   integer              ::  ilev,klev,k1,k2
+   real                 ::  prsl(ilev,klev),prslk(ilev,klev),prsik(ilev,klev)
+   real                 ::  tenv(ilev,klev),qenv(ilev,klev)
+   integer              ::  klcl(ilev),kbot(ilev),ktop(ilev)
+   real                 ::  tcld(ilev,klev),qcld(ilev,klev)
+   real                 ::  rd,rv
+   integer              ::  ids,ide, jds,jde, kds,kde,                         &
+                            ims,ime, jms,jme, kms,kme,                         &
                             its,ite, jts,jte, kts,kte
 !
-! local arrays
+!  local arrays
 !
-   real :: slkma(ilev)
-   real :: thema(ilev)
-   real :: pv,tdpd
-   real :: slklcl,thelcl,tlcl
-   real :: xj,yj
-   real :: ftx1,ftx2,ftma1,qx1,qx2,qma,tma,tvcld,tvenv
-   real :: eps,epsm1,ftv
-   integer :: i,k,jx,jy
+   real                 ::  slkma(ilev)
+   real                 ::  thema(ilev)
+   real                 ::  pv,tdpd
+   real                 ::  slklcl,thelcl,tlcl
+   real                 ::  xj,yj
+   real                 ::  ftx1,ftx2,ftma1,qx1,qx2,qma,tma,tvcld,tvenv
+   real                 ::  eps,epsm1,ftv
+   integer              ::  i,k,jx,jy
 !-------------------------------------------------------------------------------
 !
-! compute parameters
-!
+!  compute parameters
+!   
    eps=rd/rv
    epsm1=rd/rv-1.
    ftv=rv/rd-1.
 !
-! determine warmest potential wet-bulb temperature between k1 and k2.
-! compute its lifting condensation level.
-!
+!  determine warmest potential wet-bulb temperature between k1 and k2.
+!  compute its lifting condensation level.
+!  
    do i = 1,ilev
      slkma(i)=0.
      thema(i)=0.
@@ -776,9 +778,9 @@ subroutine phys_moist_adiabat_pa(ilev,klev,k1,k2, &
      enddo
    enddo
 !
-! set cloud temperatures and humidities wherever the parcel lifted up
-! the moist adiabat is buoyant with respect to the environment.
-!
+!  set cloud temperatures and humidities wherever the parcel lifted up
+!  the moist adiabat is buoyant with respect to the environment.
+!  
    do i = 1,ilev
      klcl(i)=klev+1
      kbot(i)=klev+1
@@ -797,7 +799,7 @@ subroutine phys_moist_adiabat_pa(ilev,klev,k1,k2, &
        if(prslk(i,k)/prsik(i,1).le.slkma(i)) then
          klcl(i)=min(klcl(i),k)
 !
-! insert ftma tma=ftma(thema(i),prslk(i,k),qma)
+! insert ftma   tma=ftma(thema(i),prslk(i,k),qma)
 !
          xj=min(max(c1xma+c2xma*thema(i),1.),float(nx))
          yj=min(max(c1yma+c2yma*prslk(i,k),1.),float(ny))
@@ -832,12 +834,12 @@ function ftdp(pv)
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   real :: ftdp
+   real             :: ftdp
 !
-   integer :: jx
-   real :: xj
-   real :: xmax,xmin,xinc
-   real :: pv
+   integer          :: jx
+   real             :: xj
+   real             :: xmax,xmin,xinc
+   real             :: pv
 !
    xmin= 0.001
    xmax=10.001
@@ -858,11 +860,11 @@ function ftlcl(t,tdpd)
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   real :: ftlcl
+   real             :: ftlcl
 !
-   real,parameter :: clcl1=0.954442e+0, clcl2=0.967772e-3, &
+   real,parameter   :: clcl1=0.954442e+0, clcl2=0.967772e-3,           &
                        clcl3=-0.710321e-3,clcl4=-0.270742e-5
-   real :: t,tdpd
+   real             ::  t,tdpd
 !
    ftlcl=t-tdpd*(clcl1+clcl2*t+tdpd*(clcl3+clcl4*t))
 !
@@ -875,13 +877,13 @@ function fthe(t,pk)
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   real :: fthe
+   real             :: fthe
 !
-   integer :: jx,jy
-   real :: xmin,xmax,xinc,ymin,ymax,yinc
-   real :: xj,yj
-   real :: ftx1,ftx2
-   real :: t,pk
+   integer          :: jx,jy
+   real             :: xmin,xmax,xinc,ymin,ymax,yinc
+   real             :: xj,yj
+   real             :: ftx1,ftx2
+   real             :: t,pk
 !
    xmin=ttp-90.
    xmax=ttp+30.
@@ -915,12 +917,12 @@ function fpvs_pa(t)
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   real :: fpvs_pa
+   real                 :: fpvs_pa
 !
-   integer :: jx
-   real :: xmax,xmin,xinc
-   real :: xj
-   real :: t
+   integer              :: jx
+   real                 :: xmax,xmin,xinc
+   real                 :: xj
+   real                 :: t
 !
    xmin=180.0
    xmax=330.0
@@ -935,19 +937,19 @@ function fpvs_pa(t)
 !-------------------------------------------------------------------------------
 !
 !-------------------------------------------------------------------------------
-   subroutine grimsinit(rthshten,rqvshten, &
-                        restart, &
-                        ids,ide, jds,jde, kds,kde, &
-                        ims,ime, jms,jme, kms,kme, &
-                        its,ite, jts,jte, kts,kte )
+   subroutine grimsinit(rthshten,rqvshten,                                     &
+                        restart,                                               &
+                        ids,ide, jds,jde, kds,kde,                             &
+                        ims,ime, jms,jme, kms,kme,                             &
+                        its,ite, jts,jte, kts,kte                  )
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   logical , intent(in) :: restart
-   integer , intent(in) :: ids, ide, jds, jde, kds, kde, &
-                                      ims, ime, jms, jme, kms, kme, &
+   logical , intent(in)           ::  restart
+   integer , intent(in)           ::  ids, ide, jds, jde, kds, kde,            &
+                                      ims, ime, jms, jme, kms, kme,            &
                                       its, ite, jts, jte, kts, kte
-   real, dimension( ims:ime , kms:kme , jms:jme ) , intent(out) :: &
+   real,     dimension( ims:ime , kms:kme , jms:jme ) , intent(out) ::         &
                                                                      rthshten, &
                                                                      rqvshten
    integer :: i, j, k, itf, jtf, ktf
@@ -979,8 +981,8 @@ subroutine funct_dew_point_temp_init
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   integer :: jx
-   real :: xmax,xmin,xinc,pv,x,t
+   integer          :: jx
+   real             :: xmax,xmin,xinc,pv,x,t
 !
    xmin= 0.001
    xmax=10.001
@@ -1004,9 +1006,9 @@ subroutine funct_pot_temp_init
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   integer :: jx,jy
-   real :: xmin,xmax,xinc,ymin,ymax,yinc
-   real :: x,y,t,pk
+   integer          :: jx,jy
+   real             :: xmin,xmax,xinc,ymin,ymax,yinc
+   real             :: x,y,t,pk
 !
    xmin=ttp-90.
    xmax=ttp+30.
@@ -1038,9 +1040,9 @@ subroutine funct_moist_adiabat_init
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   integer :: jx,jy
-   real :: xmin,xmax,xinc,ymin,ymax,yinc
-   real :: y,pk,t,x,the,q
+   integer          :: jx,jy
+   real             :: xmin,xmax,xinc,ymin,ymax,yinc
+   real             :: y,pk,t,x,the,q
 !
    xmin=200.
    xmax=500.
@@ -1075,9 +1077,9 @@ subroutine funct_svp_init
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   integer :: jx
-   real :: xmin,xmax,xinc
-   real :: t,x
+   integer          :: jx
+   real             :: xmin,xmax,xinc
+   real             :: t,x
 !
    xmin=180.0
    xmax=330.0
@@ -1099,10 +1101,10 @@ function ftdpxg(tg,pv)
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   real :: ftdpxg
+   real             :: ftdpxg
 !
-   real :: tg,pv
-   real :: t,tr,pvt,el,dpvt,terr
+   real             :: tg,pv
+   real             :: t,tr,pvt,el,dpvt,terr
 !
    t=tg
    tr=ttp/t
@@ -1131,10 +1133,10 @@ function fthex(t,pk)
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   real :: fthex
+   real             :: fthex
 !
-   real :: t,pk,p
-   real :: tr, pv, pd, el, expo
+   real             :: t,pk,p
+   real             :: tr, pv, pd, el, expo
 !
    p=pk**cpor
    tr=ttp/t
@@ -1158,8 +1160,8 @@ function ftmaxg(tg,the,pk,qma)
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   real :: ftmaxg
-   real :: tg,the,pk,t,p,tr,pv,pd,el,expo,thet,dthet,terr,qma
+   real             :: ftmaxg
+   real             :: tg,the,pk,t,p,tr,pv,pd,el,expo,thet,dthet,terr,qma
 !
    t=tg
    p=pk**cpor
@@ -1189,7 +1191,7 @@ function ftmaxg(tg,the,pk,qma)
    pv=psatb*(tr**xa)*exp(xb*(1.-tr))
    pd=p-pv
    qma=eps*pv/(pd+eps*pv)
-!
+!  
    return
    end function
 !-------------------------------------------------------------------------------
@@ -1199,10 +1201,10 @@ function fpvsx(t)
 !-------------------------------------------------------------------------------
    implicit none
 !-------------------------------------------------------------------------------
-   real :: fpvsx
+   real             :: fpvsx
 !
-   real :: t
-   real :: tr
+   real             :: t
+   real             :: tr
 !
    tr=ttp/t
    if(t.ge.ttp) then
diff --git a/wrfv2_fire/phys/module_surface_driver.F b/wrfv2_fire/phys/module_surface_driver.F
index 1efbafb1..ac4365da 100644
--- a/wrfv2_fire/phys/module_surface_driver.F
+++ b/wrfv2_fire/phys/module_surface_driver.F
@@ -28,7 +28,13 @@ SUBROUTINE surface_driver(                                         &
      &          ,th10,th2,thz0,th_phy,tmn,tshltr,tsk,tslb             &
      &          ,tyr,tyra,tdly,tlag,lagday,nyear,nday,tmn_update,yr   &
      &          ,t_phy,u10,udrunoff,ust,uz0,u_frame,u_phy,v10,vegfra  &
-     &          ,vz0,v_frame,v_phy,warm_rain,wspd,xice,xland,z,znt,zs &
+     &          ,uoce,voce                                            &
+     &          ,vz0,v_frame,v_phy,warm_rain,wspd,xice,xland,z,znt    &
+     &          ,max_edom,cplmask                                     &
+#if (HWRF==1)
+     &          ,mznt                                                 &
+#endif
+     &          ,zs                                                   & 
      &          ,albsi, icedepth,snowsi                               &
 #if (NMM_CORE==1)
      &          ,xicem,isice,iswater,ct,tke_pbl,sfenth                &
@@ -36,7 +42,7 @@ SUBROUTINE surface_driver(                                         &
      &          ,xicem,isice,iswater,ct,tke_pbl                       &
 #endif
      &          ,albbck,embck,lh,sh2o,shdmax,shdmin,z0                &
-     &          ,flqc,flhc,psfc,sst,sstsk,dtw,sst_update,sst_skin     &
+     &          ,flqc,flhc,psfc,sst,sst_input,sstsk,dtw,sst_update,sst_skin     &
      &          ,scm_force_skintemp,scm_force_flux,t2,emiss           &
      &          ,sf_sfclay_physics,sf_surface_physics,ra_lw_physics   & 
      &          ,mosaic_lu,mosaic_soil                                &
@@ -58,10 +64,25 @@ SUBROUTINE surface_driver(                                         &
      &          ,shgxy    ,shcxy     ,shbxy     ,evgxy     ,evbxy     ,ghvxy        &
      &          ,ghbxy    ,irgxy     ,ircxy     ,irbxy     ,trxy      ,evcxy        &
      &          ,chleafxy ,chucxy    ,chv2xy    ,chb2xy    ,chstarxy                &                      
+           ! Noah-MP ground water
+     &          ,smcwtdxy ,rechxy   ,deeprechxy,fdepthxy,areaxy   ,rivercondxy, riverbedxy &
+     &          ,eqzwt    ,pexpxy   ,qrfxy    ,qspringxy,qslatxy  ,qrfsxy   ,qspringsxy &
+     &          ,smoiseq  ,wtddt    ,stepwtd                                            &
            ! Noah UA changes
      &          ,ua_phys,flx4,fvb,fbur,fgsn                                  &
 #if (EM_CORE==1)
-     &          ,ch,tsq,qsq,cov                                       & ! MYNN
+     &          ,ch,tsq,qsq,cov,Sh3d,el_pbl,bl_mynn_cloudpdf          & ! MYNN
+     &          ,fgdp,dfgdp,vdfg,grav_settling                        & ! Katata - fog dep
+#endif
+     &          ,lakedepth2d,  savedtke12d,  snowdp2d,   h2osno2d       & !lake
+     &          ,snl2d,        t_grnd2d,     t_lake3d,   lake_icefrac3d & !lake
+     &          ,z_lake3d,     dz_lake3d,    t_soisno3d, h2osoi_ice3d   & !lake
+     &          ,h2osoi_liq3d, h2osoi_vol3d, z3d,        dz3d           & !lake
+     &          ,zi3d,         watsat3d,     csol3d,     tkmg3d         & !lake
+     &          ,tkdry3d,      tksatu3d,     LakeModel,  lake_min_elev     & !lake
+#if (EM_CORE==1)
+ !    &          ,lakemask,  lakeflag                                  & !lake
+     &          ,lakemask                                  & !lake
 #endif
             !  cyl ocean variable
                 ,OM_TMP,OM_S,OM_U,OM_V,OM_DEPTH,OM_ML,OM_LON          &
@@ -164,6 +185,7 @@ SUBROUTINE surface_driver(                                         &
 !------------------------------------------------------------------------------
      &          , ids,ide,jds,jde,kds,kde                             &
      &          , ims,ime,jms,jme,kms,kme                             &
+     &          , ips,ipe,jps,jpe,kps,kpe                             &
      &          , i_start,i_end,j_start,j_end,kts,kte,num_tiles       &
              !  Optional moisture tracers
      &           ,qv_curr, qc_curr, qr_curr                           &
@@ -221,6 +243,20 @@ SUBROUTINE surface_driver(                                         &
      &          ,dl_u_bep                                             &                          
      &          ,tsk_save                                             & !for fractional seaice
      &          ,cldfra                                               & !ssib
+     &          ,sf_surface_mosaic,mosaic_cat,mosaic_cat_index                                    & !danli mosaic
+     &          ,landusef2,TSK_mosaic,QSFC_mosaic,TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic            & !danli mosaic
+     &          ,CANWAT_mosaic,SNOW_mosaic,SNOWH_mosaic,SNOWC_mosaic                              & !danli mosaic
+     &          ,ALBEDO_mosaic,ALBBCK_mosaic, EMISS_mosaic, EMBCK_mosaic, ZNT_mosaic, Z0_mosaic   & !danli mosaic
+     &          ,HFX_mosaic,QFX_mosaic, LH_mosaic, GRDFLX_mosaic,SNOTIME_mosaic                   & !danli mosaic
+     &          ,TR_URB2D_mosaic,TB_URB2D_mosaic                      &  !danli mosaic 
+     &          ,TG_URB2D_mosaic,TC_URB2D_mosaic                      &  !danli mosaic 
+     &          ,QC_URB2D_mosaic,UC_URB2D_mosaic                      &  !danli mosaic                  
+     &          ,TRL_URB3D_mosaic,TBL_URB3D_mosaic                    &  !danli mosaic 
+     &          ,TGL_URB3D_mosaic                                     &  !danli mosaic 
+     &          ,SH_URB2D_mosaic,LH_URB2D_mosaic                      &  !danli mosaic 
+     &          ,G_URB2D_mosaic,RN_URB2D_mosaic                       &  !danli mosaic 
+     &          ,TS_URB2D_mosaic                                      &  !danli mosaic 
+     &          ,TS_RUL2D_mosaic                                      &  !danli mosaic     
      &                                                             )
               
 #if ( ! NMM_CORE == 1 )
@@ -269,8 +305,9 @@ SUBROUTINE surface_driver(                                         &
    USE module_sf_myjsfc
    USE module_sf_qnsesfc
    USE module_sf_gfs
-   USE module_sf_noahdrv, only : lsm
+   USE module_sf_noahdrv                           ! danli mosaic, the " ,only : lsm " needs to be deleted 
    USE module_sf_noahmpdrv, only : noahmplsm
+   USE module_sf_noahmp_groundwater
    USE module_sf_noah_seaice_drv
 #ifdef WRF_USE_CLM
    USE module_sf_clm
@@ -284,6 +321,7 @@ SUBROUTINE surface_driver(                                         &
    USE module_sf_noah_seaice_drv
 #if ( EM_CORE==1)
    USE module_sf_mynn
+   USE module_sf_fogdes    ! Katata - fog deposition module
    USE module_sf_ocean_driver
    USE module_sf_idealscmsfclay
 #endif
@@ -300,6 +338,8 @@ SUBROUTINE surface_driver(                                         &
    USE module_sf_sfcdiags_ruclsm
    USE module_sf_sstskin
    USE module_sf_tmnupdate
+   USE module_sf_lake
+   USE module_cpl, ONLY : coupler_on, cpl_rcv
 !
 !  This driver calls subroutines for the surface parameterizations.
 !
@@ -370,7 +410,10 @@ SUBROUTINE surface_driver(                                         &
 !-- TLAG          mean surface temperature of previous 140 days (K)
 !-- TDLY          accumulated daily mean surface temperature of the current day (K)
 !-- XLAND         land mask (1 for land, 2 for water)
-!-- ZNT           time-varying roughness length (m)
+!-- MAX_EDOM      number of external model domains
+!-- CPLMASK       coupling mask (0 for data read in wrflowinput, 1 data received from the coupler)
+!-- ZNT           thermal time-varying roughness length (m)
+!-- MZNT          momentum time-varying roughness length (m)
 !-- Z0            background roughness length (m)
 !-- MAVAIL        surface moisture availability (between 0 and 1)
 !-- UST           u* in similarity theory (m/s)
@@ -398,6 +441,8 @@ SUBROUTINE surface_driver(                                         &
 !-- tratx         ratio of t over th2 (Added for obs-nudging)
 !-- u10           diagnostic 10-m u component from surface layer
 !-- v10           diagnostic 10-m v component from surface layer
+!-- UOCE          sea surface zonal currents (m s-1)
+!-- VOCE          sea surface meridional currents (m s-1)
 !-- th2           diagnostic 2-m theta from surface layer and lsm
 !-- t2            diagnostic 2-m temperature from surface layer and lsm
 !-- q2            diagnostic 2-m mixing ratio from surface layer and lsm
@@ -422,6 +467,7 @@ SUBROUTINE surface_driver(                                         &
 !-- DT            time step (second)
 !-- PSFC          pressure at the surface (Pa)
 !-- SST           sea-surface temperature (K)
+!-- SST_INPUT     sea-surface temperature read in wrflowinput (K) (= SST if no coupling)
 !-- SSTSK         skin sea-surface temperature (K)
 !-- DTW           warm layer temp diff (K)
 !-- TSLB
@@ -461,6 +507,12 @@ SUBROUTINE surface_driver(                                         &
 !-- jme           end index for j in memory
 !-- kms           start index for k in memory
 !-- kme           end index for k in memory
+!-- ips           start index for i in patch
+!-- ipe           end index for i in patch
+!-- jps           start index for j in patch
+!-- jpe           end index for j in patch
+!-- kps           start index for k in patch
+!-- kpe           end index for k in patch
 !-- its           start index for i in tile
 !-- ite           end index for i in tile
 !-- jts           start index for j in tile
@@ -474,6 +526,7 @@ SUBROUTINE surface_driver(                                         &
    INTEGER, INTENT(IN) ::                                             &
      &           ids,ide,jds,jde,kds,kde                              &
      &          ,ims,ime,jms,jme,kms,kme                              &
+     &          ,ips,ipe,jps,jpe,kps,kpe                              &
      &          ,kts,kte,num_tiles
 
    INTEGER, INTENT(IN)::   FRACTIONAL_SEAICE
@@ -490,6 +543,8 @@ SUBROUTINE surface_driver(                                         &
 
    INTEGER, INTENT(IN)::   NLCAT, mosaic_lu, mosaic_soil
    INTEGER, INTENT(IN)::   NSCAT
+   INTEGER,  INTENT(IN )  :: LakeModel
+   REAL,     INTENT(IN)   :: lake_min_elev
 
    INTEGER, INTENT(IN)::   history_interval
 
@@ -540,6 +595,7 @@ SUBROUTINE surface_driver(                                         &
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN )::   RAINCV
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   SST
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ),OPTIONAL ::   SSTSK
+   REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN    ),OPTIONAL ::   SST_INPUT
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ),OPTIONAL ::   DTW
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   TMN
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ),OPTIONAL ::   TYR
@@ -554,6 +610,8 @@ SUBROUTINE surface_driver(                                         &
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   ICEDEPTH
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   SNOWSI
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   XLAND
+   INTEGER,                                          INTENT(IN   ) ::   MAX_EDOM
+   REAL, DIMENSION( ims:ime , 1:max_edom, jms:jme ), INTENT(IN   ), OPTIONAL ::   CPLMASK
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   XICEM
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   MAVAIL
    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT)::   SNOALB
@@ -591,6 +649,9 @@ SUBROUTINE surface_driver(                                         &
    REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   VZ0
    REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   WSPD
    REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   ZNT
+#if (HWRF==1)
+   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   MZNT
+#endif
 !-----fds (06/2010)---------------------------------------------
    REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(OUT)::   SSIB_LHF ! SSiB output
    REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(OUT)::   SSIB_SHF ! SSiB output
@@ -692,6 +753,8 @@ SUBROUTINE surface_driver(                                         &
    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT)::   TSHLTR
    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT)::   U10
    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT)::   V10
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT)::   UOCE
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT)::   VOCE
    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT)::   PSFC
    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)::   ACSNOM
    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT)::   SFCEVP
@@ -744,6 +807,12 @@ SUBROUTINE surface_driver(                                         &
    REAL, OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) ::  rssunxy, rsshaxy, bgapxy,wgapxy, &
         tgvxy ,tgbxy, chvxy, chbxy,SHGXY,SHCXY,SHBXY,EVGXY,EVBXY,GHVXY,GHBXY,IRGXY,IRCXY,IRBXY,TRXY,EVCXY,CHLEAFXY,CHUCXY,CHV2XY,CHB2XY,chstarxy                         
 
+   REAL, OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) ::  smcwtdxy   ,rechxy   ,deeprechxy,  fdepthxy, areaxy,  &
+       rivercondxy,riverbedxy,eqzwt,pexpxy,qrfxy,qspringxy,qslatxy,qrfsxy,qspringsxy                         
+   REAL, OPTIONAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT)::  smoiseq
+   REAL, OPTIONAL, INTENT(IN) :: wtddt
+   INTEGER, OPTIONAL, INTENT(IN )  :: stepwtd
+
 ! Noah UA changes
    LOGICAL, INTENT(IN) :: ua_phys
    REAL, DIMENSION(ims:ime , jms:jme), INTENT(OUT) ::  flx4,fvb,fbur,fgsn
@@ -807,9 +876,15 @@ SUBROUTINE surface_driver(                                         &
 #if ( EM_CORE==1)
    REAL, DIMENSION( ims:ime , jms:jme ), &
         &OPTIONAL, INTENT(INOUT   ):: ch
-   
+
+!Katata-added - extra in-output                                                                                                                                                              
+   REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT):: fgdp,dfgdp,vdfg                                                                                                           
+   INTEGER, OPTIONAL, INTENT(IN)                                :: grav_settling                                                                                                             
+!Katata-end
+
    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), &
-        &OPTIONAL, INTENT(IN   ):: tsq,qsq,cov
+        &OPTIONAL, INTENT(IN   ):: tsq,qsq,cov,Sh3d,el_pbl
+   INTEGER, OPTIONAL, INTENT(IN)                                :: bl_mynn_cloudpdf
 #endif
 
 
@@ -1059,10 +1134,40 @@ SUBROUTINE surface_driver(                                         &
      REAL,  DIMENSION( ims:ime, jms:jme )  :: TH2_URB2D   !urban local var
      REAL,  DIMENSION( ims:ime, jms:jme )  :: Q2_URB2D    !urban local var
      REAL,  DIMENSION( ims:ime, jms:jme )  :: UST_URB2D  !urban local var
+     
+!-------------------------------------------------
+! Noah-mosaic related variables are added to declaration  (danli)
+!-------------------------------------------------
+  
+  INTEGER, INTENT(IN) :: sf_surface_mosaic
+  INTEGER, INTENT(IN) :: mosaic_cat
+  INTEGER, DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(INOUT), OPTIONAL :: mosaic_cat_index
+  REAL,    DIMENSION( ims:ime, NLCAT, jms:jme ), INTENT(INOUT), OPTIONAL :: landusef2
+
+  REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT)::   &
+        TSK_mosaic, QSFC_mosaic, CANWAT_mosaic, SNOW_mosaic,SNOWH_mosaic, SNOWC_mosaic
+  REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT)::   &
+        ALBEDO_mosaic,ALBBCK_mosaic, EMISS_mosaic, EMBCK_mosaic, ZNT_mosaic, Z0_mosaic,   &
+        HFX_mosaic,QFX_mosaic, LH_mosaic, GRDFLX_mosaic,SNOTIME_mosaic    
+  REAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), OPTIONAL, INTENT(INOUT)::   &
+        TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic
+
+   REAL, DIMENSION( ims:ime, 1:mosaic_cat, jms:jme ) , OPTIONAL, INTENT(INOUT)::  &
+         TR_URB2D_mosaic, TB_URB2D_mosaic, TG_URB2D_mosaic, TC_URB2D_mosaic,QC_URB2D_mosaic, UC_URB2D_mosaic, &
+         SH_URB2D_mosaic,LH_URB2D_mosaic,G_URB2D_mosaic,RN_URB2D_mosaic,TS_URB2D_mosaic, TS_RUL2D_mosaic  
+                  
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TRL_URB3D_mosaic
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TBL_URB3D_mosaic
+   REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers*mosaic_cat, jms:jme ), INTENT(INOUT) :: TGL_URB3D_mosaic
+     
+!-------------------------------------------------
+! End of Noah-mosaic related variables 
+!-------------------------------------------------     
+     
 !--------fds (06/2010)---------------------------------------------
      REAL,  DIMENSION( ims:ime, kms:kme, jms:jme ),               &
             OPTIONAL, INTENT(IN) ::                                 CLDFRA
-     REAL             ::                            DAY, CLOUDFRAC
+     REAL   :: DAY, CLOUDFRAC, UV10
 !------------------------------------------------------------------
 !
      REAL, DIMENSION( ims:ime, jms:jme ) :: HFX_SEA
@@ -1086,6 +1191,37 @@ SUBROUTINE surface_driver(                                         &
      REAL, DIMENSION( ims:ime, jms:jme ) :: UST_SEA
      REAL, DIMENSION( ims:ime, jms:jme ) :: QZ0_SEA
      REAL, DIMENSION( ims:ime, jms:jme ) :: TSK_LOCAL
+    ! lake varibles ,inout(14)
+    real,    dimension(ims:ime,jms:jme ),intent(inout)                      :: savedtke12d
+    real,    dimension(ims:ime,jms:jme ),intent(inout)                      :: snowdp2d,       &
+                                                                               h2osno2d,       &
+                                                                               snl2d,          &
+                                                                               t_grnd2d
+ 
+    real,    dimension( ims:ime,1:nlevlake, jms:jme ),INTENT(inout)          :: t_lake3d,       &
+                                                                               lake_icefrac3d
+    real,    dimension( ims:ime,-nlevsnow+1:nlevsoil, jms:jme ),INTENT(inout) :: t_soisno3d,     &
+                                                                               h2osoi_ice3d,   &
+                                                                               h2osoi_liq3d,   &
+                                                                               h2osoi_vol3d,   &
+                                                                               z3d,            &
+                                                                               dz3d
+    real,    dimension( ims:ime,-nlevsnow+0:nlevsoil, jms:jme ),INTENT(inout) :: zi3d
+    ! in(8)
+    real,    dimension( ims:ime,1:nlevlake, jms:jme ),INTENT(in)             :: z_lake3d,       &
+                                                                               dz_lake3d
+    real,    dimension( ims:ime,1:nlevsoil, jms:jme ),INTENT(in)             :: watsat3d,       &
+                                                                               csol3d,         &
+                                                                               tkmg3d,         &
+                                                                               tkdry3d,        &
+                                                                               tksatu3d
+    real,    dimension(ims:ime,jms:jme ),intent(in)                         :: lakedepth2d
+#if (EM_CORE==1)
+    real ,    dimension(ims:ime,jms:jme )  ::  lakemask       
+!    INTEGER  :: lakeflag
+#endif
+!    logical, dimension(ims:ime,jms:jme ),intent(in)                         :: lake 
+ 
 !
    REAL   :: xice_threshold
 
@@ -1109,8 +1245,12 @@ SUBROUTINE surface_driver(                                         &
 !
 !
 !------------------------------------------------------------------
+! Initialize local variables
+  q_ref2m = 0.0
+!------------------------------------------------------------------
 !
 ! stop run if using ssib and fractional seaice=0  (fds 12/2010)
+
   if(sf_surface_physics .eq. SSIBSCHEME .and. fractional_seaice .eq. 0) then
     WRITE( message,* ) 'Please activate fractional seaice option when using SSiB model'
     CALL wrf_error_fatal ( message )
@@ -1136,6 +1276,28 @@ SUBROUTINE surface_driver(                                         &
       call wrf_error_fatal("Field SNOWSI not found in input.  Field SNOWSI is required if SEAICE_SNOWDEPTH_OPT=1")
   endif
 
+  IF ( coupler_on .and. present(cplmask) .and. present(sst_input) ) THEN
+     
+     CALL cpl_rcv( id, 'SST',            &
+        &              ids, ide, jds, jde, kds, kde, &
+        &              ims, ime, jms, jme, kms, kme, &
+        &              ips, ipe, jps, jpe, kps, kpe, &
+        &              max_edom, cplmask, SST, SST_INPUT )
+     
+     CALL cpl_rcv( id, 'UOCE',            &
+        &              ids, ide, jds, jde, kds, kde, &
+        &              ims, ime, jms, jme, kms, kme, &
+        &              ips, ipe, jps, jpe, kps, kpe, &
+        &              max_edom, cplmask, UOCE )
+     
+     CALL cpl_rcv( id, 'VOCE',            &
+        &              ids, ide, jds, jde, kds, kde, &
+        &              ims, ime, jms, jme, kms, kme, &
+        &              ips, ipe, jps, jpe, kps, kpe, &
+        &              max_edom, cplmask, VOCE )
+     
+  END IF
+  
 !$OMP PARALLEL DO &
 !$OMP PRIVATE (ij, i, j, k)
   DO ij = 1,num_tiles
@@ -1195,7 +1357,25 @@ SUBROUTINE surface_driver(                                         &
     DO ij = 1 , num_tiles
       DO j=j_start(ij),j_end(ij)
       DO i=i_start(ij),i_end(ij)
-
+ ! check for lake model 
+#if (EM_CORE==1)
+          if ( lakemodel==1) then
+            if(lakemask(i,j).eq.1.) then
+              if ( xice(i,j).gt.xice_threshold) then   !mchen
+                   xice(i,j)=0.0
+               endif
+             endif
+          endif 
+#else
+          if ( lakemodel==1) then
+            if(ht(i,j)>=lake_min_elev) then
+              if ( xice(i,j).gt.xice_threshold) then   !mchen
+                   xice(i,j)=0.0
+               endif
+             endif
+          endif 
+#endif
+! end check lake model    
          XICE_save(I,J) = XICEM(I,J) 
 
          IF ( FRACTIONAL_SEAICE == 1 ) then
@@ -1256,12 +1436,45 @@ SUBROUTINE surface_driver(                                         &
             SH2O(I,NK,J) = 0.0
           ENDDO
         ENDIF
-        IF(XLAND(i,j) .GT. 1.5) THEN
-          IF ( SST(i,j) .LT. 350. .and. SST(i,j) .GT. 250.) THEN
+     IF (lakemodel.ne.1) then
+         IF(XLAND(i,j) .GT. 1.5) THEN
+           IF ( SST(i,j) .LT. 350. .and. SST(i,j) .GT. 250.) THEN
             TSK(i,j)   =SST(i,j)
             TSLB(i,1,j)=SST(i,j)
+           ENDIF
           ENDIF
-        ENDIF
+     ELSE
+#if (EM_CORE==1)
+!       if(lakeflag.eq.1) then
+!         IF(XLAND(i,j) .GT. 1.5.AND.LAKEMASK(I,J).NE.1) THEN
+!           IF ( SST(i,j) .LT. 350. .and. SST(i,j) .GT. 250.) THEN
+!            TSK(i,j)   =SST(i,j)
+!            TSLB(i,1,j)=SST(i,j)
+!           ENDIF
+!          ENDIF
+!       else
+!         if(XLAND(i,j) .GT. 1.5.and.ht(i,j).lt.lake_min_elev) then
+!           IF ( SST(i,j) .LT. 350. .and. SST(i,j) .GT. 250.) THEN
+!            TSK(i,j)   =SST(i,j)
+!            TSLB(i,1,j)=SST(i,j)
+!           ENDIF
+!          ENDIF
+!       endif   ! (lakeflag=1)
+         IF(XLAND(i,j) .GT. 1.5.AND.LAKEMASK(I,J).NE.1) THEN
+           IF ( SST(i,j) .LT. 350. .and. SST(i,j) .GT. 250.) THEN
+            TSK(i,j)   =SST(i,j)
+            TSLB(i,1,j)=SST(i,j)
+           ENDIF
+          ENDIF
+#else
+       IF(XLAND(i,j) .GT. 1.5.and.ht(i,j).lt.lake_min_elev) then
+           IF ( SST(i,j) .LT. 350. .and. SST(i,j) .GT. 250.) THEN
+            TSK(i,j)   =SST(i,j)
+            TSLB(i,1,j)=SST(i,j)
+           ENDIF
+       ENDIF
+#endif
+     ENDIF  ! (lakemodel=1)
         IF ( XLAND(i,j) .LT. 1.5 .AND. XICEM(I,J) .GE. XICE_THRESHOLD .AND. XICE(I,J) .LT. XICE_THRESHOLD ) THEN
 ! sea-ice point turns to water point
           XICEM(I,J) = XICE(I,J)
@@ -1405,6 +1618,7 @@ SUBROUTINE surface_driver(                                         &
             (sf_sfclay_physics .EQ. SFCLAYSCHEME ) .OR. &
             (sf_sfclay_physics .EQ. PXSFCSCHEME  ) .OR. &
             (sf_sfclay_physics .EQ. MYJSFCSCHEME ) .OR. &
+            (sf_sfclay_physics .EQ. QNSESFCSCHEME ) .OR. &  !emt
 #if (EM_CORE==1)
             (sf_sfclay_physics .EQ. MYNNSFCSCHEME ) .OR. &
 #endif
@@ -1486,6 +1700,9 @@ SUBROUTINE surface_driver(                                         &
             v_phytmp(i,k,j)=v_phy(i,k,j)+v_frame
             u_phytmp(i,k,j)=u_phy(i,k,j)+u_frame
           ENDDO
+! remove surface currents for atmospheric low-level winds
+          u_phytmp(i,kts,j)=u_phytmp(i,kts,j)-uoce(i,j)
+          v_phytmp(i,kts,j)=v_phytmp(i,kts,j)-voce(i,j)
        ENDDO
        ENDDO
      ENDDO
@@ -1586,28 +1803,25 @@ SUBROUTINE surface_driver(                                         &
            PRESENT(mol)        .AND.  PRESENT(regime)  .AND.    &
                                                       .TRUE. ) THEN
          CALL wrf_debug( 100, 'in SFCLAY' )
-!         IF ( FRACTIONAL_SEAICE == 1 ) THEN
-!            CALL SFCLAY_SEAICE_WRAPPER(u_phytmp,v_phytmp,t_phy,qv_curr,&
-!                 p_phy,dz8w,cp,g,rcp,r_d,xlv,psfc,chs,chs2,cqs2,cpm, &
-!                 znt,ust,pblh,mavail,zol,mol,regime,psim,psih,       &
-!                 xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol,       &
-!                 u10,v10,th2,t2,q2,                                  &
-!                 gz1oz0,wspd,br,isfflx,dx,                           &
-!                 svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, &
-!                 P1000mb,                                            &
-!                 XICE,SST,TSK_SEA,
-!&
-!                 CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA,
-!&
-!                 HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA,
-!&
-!                 ITIMESTEP,TICE2TSK_IF2COLD,XICE_THRESHOLD,
-!&
-!                 ids,ide, jds,jde, kds,kde,                          &
-!                 ims,ime, jms,jme, kms,kme,                          &
-!                 i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte,    &
-!                 ustm,ck,cka,cd,cda,isftcflx,iz0tlnd                 )
-!         ELSE
+         IF ( FRACTIONAL_SEAICE == 1 ) THEN
+            CALL SFCLAYREV_SEAICE_WRAPPER(u_phytmp,v_phytmp,t_phy,qv_curr,&
+                 p_phy,dz8w,cp,g,rcp,r_d,xlv,psfc,chs,chs2,cqs2,cpm, &
+                 znt,ust,pblh,mavail,zol,mol,regime,psim,psih,fm,fhh, &
+                 xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol,       &
+                 u10,v10,th2,t2,q2,                                  &
+                 gz1oz0,wspd,br,isfflx,dx,                           &
+                 svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, &
+                 P1000mb,                                            &
+                 XICE,SST,TSK_SEA,                                                  &
+                 CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA,               &
+                 HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA,                   &
+                 ITIMESTEP,TICE2TSK_IF2COLD,XICE_THRESHOLD,                         &
+                 ids,ide, jds,jde, kds,kde,                          &
+                 ims,ime, jms,jme, kms,kme,                          &
+                 i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte,    &
+                 ustm,ck,cka,cd,cda,isftcflx,iz0tlnd,                &
+                 sf_surface_physics  )
+         ELSE
          CALL SFCLAYREV(u_phytmp,v_phytmp,t_phy,qv_curr,&
                p_phy,dz8w,cp,g,rcp,r_d,xlv,psfc,chs,chs2,cqs2,cpm, &
                znt,ust,pblh,mavail,zol,mol,regime,psim,psih,fm,fhh, &
@@ -1628,7 +1842,7 @@ SUBROUTINE surface_driver(                                         &
            end do
            end do
 #endif
-!         ENDIF
+         ENDIF
        ELSE
          CALL wrf_error_fatal('Lacking arguments for SFCLAY in surface driver')
        ENDIF
@@ -1762,6 +1976,30 @@ SUBROUTINE surface_driver(                                         &
        IF (PRESENT(qv_curr)    .AND.  PRESENT(qc_curr) .AND.    &
                                                       .TRUE. ) THEN
             CALL wrf_debug(100,'in QNSESFC')
+             IF ( FRACTIONAL_SEAICE == 1 ) THEN
+           CALL QNSESFC_SEAICE_WRAPPER(itimestep,ht,dz8w,             &
+                p_phy,p8w,th_phy,t_phy,                              &
+                qv_curr,qc_curr,                                     &
+                u_phy,v_phy,tke_pbl,                                 &
+                tsk,qsfc,thz0,qz0,uz0,vz0,                           &
+                lowlyr,                                              &
+                xland,                                               &
+                TICE2TSK_IF2COLD,                                    & ! Extra for wrapper.
+                XICE_THRESHOLD,                                      & ! Extra for wrapper.
+                XICE, SST,                                           & ! Extra for wrapper.
+                CHS_SEA, CHS2_SEA, CQS2_SEA, CPM_SEA,            &
+                FLHC_SEA, FLQC_SEA, QSFC_SEA, &
+                QGH_SEA, QZ0_SEA, HFX_SEA, QFX_SEA, LH_SEA,         &
+                TSK_SEA,                                             &
+                ust,znt,z0,pblh,mavail,rmol,                         &
+                akhs,akms,                                           &
+                br,                                                 &
+                chs,chs2,cqs2,hfx,qfx,lh,flhc,flqc,qgh,cpm,ct,       &
+                u10,v10,t2,th2,tshltr,th10,q2,qshltr,q10,pshltr,               &
+                ids,ide, jds,jde, kds,kde,                           &
+                ims,ime, jms,jme, kms,kme,                           &
+                i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte,SCM_FORCE_FLUX    )
+           ELSE
             CALL QNSESFC(itimestep,ht,dz8w,                         &
               p_phy,p8w,th_phy,t_phy,                              &
               qv_curr,qc_curr,                                     &
@@ -1773,12 +2011,23 @@ SUBROUTINE surface_driver(                                         &
               akhs,akms,                                           &
               br,                                                 &
               chs,chs2,cqs2,hfx,qfx,lh,flhc,flqc,qgh,cpm,ct,       &
-              u10,v10,tshltr,th10,qshltr,q10,pshltr,               &
+              u10,v10,t2,th2,tshltr,th10,q2,qshltr,q10,pshltr,               &
               ids,ide, jds,jde, kds,kde,                           &
               ims,ime, jms,jme, kms,kme,                           &
               i_start(ij),i_end(ij), j_start(ij),j_end(ij),     &
               kts,kte,scm_force_flux    )
-       ELSE
+#if ( EM_CORE==1)
+         DO j = j_start(ij),j_end(ij)
+            DO i = i_start(ij),i_end(ij)
+               wspd(i,j) = MAX(SQRT(u_phy(i,kts,j)**2+v_phy(i,kts,j)**2),0.001)
+               ch(i,j) = chs (i,j)
+!!           ch(i,j) = flhc(i,j)/( cpm(i,j)*rho(i,kts,j) )
+            END DO
+         END DO
+#endif         
+
+        ENDIF
+        ELSE
          CALL wrf_error_fatal('Lacking arguments for QNSESFC in surface driver')
        ENDIF
 
@@ -1828,37 +2077,37 @@ SUBROUTINE surface_driver(                                         &
           CALL wrf_debug(100,'in MYNNSFC')          
 
          IF (FRACTIONAL_SEAICE == 1) THEN
-          CALL MYNN_SEAICE_WRAPPER(u_phytmp,v_phytmp,t_phy,qv_curr, &
+          CALL MYNN_SEAICE_WRAPPER(u_phytmp,v_phytmp,t_phy,qv_curr,&
                p_phy,dz8w,cp,g,rcp,r_d,xlv,psfc,chs,chs2,cqs2,cpm, &
-               znt,ust,pblh,mavail,zol,mol,regime,psim,psih, &
+               znt,ust,pblh,mavail,zol,mol,regime,psim,psih,       &
                xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol,       &
-               u10,v10,th2,t2,q2,                                  &
+               u10,v10,th2,t2,q2,SNOWH,                            &
                gz1oz0,wspd,br,isfflx,dx,                           &
-               svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, &
-               &itimestep,ch,th_phy,pi_phy,qc_curr,&
-               &tsq,qsq,cov,qcg,&
+               svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,              &
+               &itimestep,ch,th_phy,pi_phy,qc_curr,rho,            &
+               &tsq,qsq,cov,Sh3d,el_pbl,qcg,                       &
                XICE,SST,TSK_SEA,                                   &
-               CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, &
+               CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA,&
                HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA,    &
                TICE2TSK_IF2COLD,XICE_THRESHOLD,                    &
                ids,ide, jds,jde, kds,kde,                          &
                ims,ime, jms,jme, kms,kme,                          &
                i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, &   
-               ustm,ck,cka,cd,cda,isftcflx,iz0tlnd                 )
+               ustm,ck,cka,cd,cda,isftcflx,iz0tlnd,bl_mynn_cloudpdf)
          ELSE
           CALL SFCLAY_mynn(u_phytmp,v_phytmp,t_phy,qv_curr,        &
                p_phy,dz8w,cp,g,rcp,r_d,xlv,psfc,chs,chs2,cqs2,cpm, &
                znt,ust,pblh,mavail,zol,mol,regime,psim,psih,       &
                xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol,       &
-               u10,v10,th2,t2,q2,                                  &
+               u10,v10,th2,t2,q2,SNOWH,                            &
                gz1oz0,wspd,br,isfflx,dx,                           &
-               svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,eomeg,stbolt, &
-               &itimestep,ch,th_phy,pi_phy,qc_curr,                &
-               &tsq,qsq,cov,qcg,                                   &
+               svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,              &
+               &itimestep,ch,th_phy,pi_phy,qc_curr,rho,            &
+               &tsq,qsq,cov,Sh3D,el_pbl,qcg,                       &
                ids,ide, jds,jde, kds,kde,                          &
                ims,ime, jms,jme, kms,kme,                          &
                i_start(ij),i_end(ij),j_start(ij),j_end(ij),kts,kte,&
-               ustm,ck,cka,cd,cda,isftcflx,iz0tlnd                 )
+               ustm,ck,cka,cd,cda,isftcflx,iz0tlnd,bl_mynn_cloudpdf)
          ENDIF
        ELSE
           CALL wrf_error_fatal('Lacking arguments for SFCLAY_mynn in surface driver')
@@ -1936,7 +2185,11 @@ SUBROUTINE surface_driver(                                         &
 
       CALL SF_GFDL(u_phytmp,v_phytmp,t_phy,qv_curr,p_phy, &
                    CP,RCP,R_d,XLV,PSFC,CHS,CHS2,CQS2,CPM,                 &
-                   DTBL, SMOIS,num_soil_layers,ISLTYP,ZNT,UST,PSIM,PSIH,                          &  !DT & MAVAIL
+                   DTBL, SMOIS,num_soil_layers,ISLTYP,ZNT,                &
+#if (HWRF==1)
+                   MZNT,                                                  &
+#endif
+                   UST,PSIM,PSIH,                                         &  
                    XLAND,HFX,QFX,TAUX,TAUY,LH,GSW,GLW,TSK,FLHC,FLQC,  & ! gopal's doing for Ocean coupling
                    QGH,QSFC,U10,V10,                              &
                    GZ1OZ0,WSPD,BR,ISFFLX,                         &
@@ -1980,6 +2233,47 @@ SUBROUTINE surface_driver(                                         &
         ENDDO
      ENDIF
 
+#if ( EM_CORE==1)
+!Katata-added - fog (cloud) water deposition calculation
+     IF ( grav_settling .EQ. 0 ) THEN
+        !vdfg = 0.
+        DO j=j_start(ij),j_end(ij)
+        DO i=i_start(ij),i_end(ij)
+           vdfg(i,j)=0.
+        ENDDO
+        ENDDO
+     ELSE
+        IF ( PRESENT(dfgdp) .AND. PRESENT(fgdp) .AND. &
+           & PRESENT(rainbl) .AND. PRESENT(vdfg)) THEN
+           DO j=j_start(ij),j_end(ij)
+           DO i=i_start(ij),i_end(ij)
+              dfgdp(i,j)=0.
+           ENDDO
+           ENDDO
+
+           CALL sf_fogdes(                                  &
+                vdfg,fgdp,dfgdp,ivgtyp,lai,wspd,qc_curr,    &
+                dtbl,rho,dz8w,grav_settling,nlcat,          &
+                ids,ide, jds,jde, kds,kde,                  &
+                ims,ime, jms,jme, kms,kme,                  &
+                i_start(ij),i_end(ij),                      &
+                j_start(ij),j_end(ij),kts,kte               )
+
+           !Add fog dep to RAINBL in mm (Accumulation between PBL calls).
+           DO j=j_start(ij),j_end(ij)
+           DO i=i_start(ij),i_end(ij)
+              RAINBL(i,j) = RAINBL(i,j) + dfgdp(i,j)
+              RAINBL(i,j) = MAX(RAINBL(i,j), 0.0)
+           ENDDO
+           ENDDO
+
+        ELSE
+          CALL wrf_error_fatal('Missing args for FGDP in surface driver')
+        ENDIF
+     ENDIF
+!Katata/Joe-END
+#endif
+
      ENDDO
      !$OMP END PARALLEL DO
 
@@ -2100,7 +2394,99 @@ SUBROUTINE surface_driver(                                         &
 #endif
 
          CALL wrf_debug(100,'in NOAH DRV')
-         CALL lsm(dz8w,qv_curr,p8w,t_phy,tsk,                 &
+                
+         IF (sf_surface_mosaic == 1) THEN
+          
+           IF ( PRESENT( TSK_mosaic ) .AND. PRESENT( HFX_mosaic ) ) THEN
+             CALL lsm_mosaic(dz8w,qv_curr,p8w,t_phy,tsk,                 &
+                hfx,qfx,lh,grdflx,qgh,gsw,swdown,glw,smstav,smstot,    &
+                sfcrunoff,udrunoff,ivgtyp,isltyp,isurban,isice,vegfra,        &
+                albedo,albbck,znt,z0, tmn,xland,xice,emiss, embck,    &
+                snowc,qsfc,rainbl,                              &
+                mminlu,                                         &
+                num_soil_layers,dtbl,dzs,itimestep,             &
+                smois,tslb,snow,canwat,                         &
+                chs, chs2, cqs2, cpm,rcp,SR,chklowq,lai,qz0,    &
+                myj,frpcpn,                                     &
+		sh2o,snowh,                                     & !h
+                u_phy,v_phy,                                    & !I
+                snoalb,shdmin,shdmax,                           & !i
+                snotime,                                        & !o
+                acsnom,acsnow,                                  & !o
+                snopcx,                                         & !o
+                potevp,                                         & !o
+                smcrel,                                         & !o
+                xice_threshold,                                 &
+                rdlai2d,usemonalb,                              &
+                br,                                             & !?
+                NOAHRES,                                        &
+                NLCAT,landusef,landusef2,                       & ! danli mosaic
+                sf_surface_mosaic,mosaic_cat,mosaic_cat_index,  & ! danli mosaic 
+                TSK_mosaic,QSFC_mosaic,                         & ! danli mosaic 
+                TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic,           & ! danli mosaic 
+                CANWAT_mosaic,SNOW_mosaic,                      & ! danli mosaic
+                SNOWH_mosaic,SNOWC_mosaic,                      & ! danli mosaic 
+                ALBEDO_mosaic,ALBBCK_mosaic,                    & ! danli mosaic
+                EMISS_mosaic, EMBCK_mosaic,                     & ! danli mosaic
+                ZNT_mosaic, Z0_mosaic,                          & ! danli mosaic 
+                HFX_mosaic,QFX_mosaic,                          & ! danli mosaic
+                LH_mosaic, GRDFLX_mosaic, SNOTIME_mosaic,       & ! danli mosaic          
+                ua_phys,flx4,fvb,fbur,fgsn,                     &
+                ids,ide, jds,jde, kds,kde,                      &
+                ims,ime, jms,jme, kms,kme,                      &
+                i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte,    &
+                sf_urban_physics                                &
+!Optional urban
+                ,cmr_sfcdif,chr_sfcdif,cmc_sfcdif,chc_sfcdif    &
+                ,tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d,  & !H urban
+                uc_urb2d,                                       & !H urban
+                xxxr_urb2d,xxxb_urb2d,xxxg_urb2d,xxxc_urb2d,    & !H urban
+                trl_urb3d,tbl_urb3d,tgl_urb3d,                  & !H urban
+                sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d,ts_urb2d,    & !H urban
+                TR_URB2D_mosaic,TB_URB2D_mosaic,                & !H urban  danli mosaic
+                TG_URB2D_mosaic,TC_URB2D_mosaic,                & !H urban  danli mosaic
+                QC_URB2D_mosaic,UC_URB2D_mosaic,                & !H urban  danli mosaic                  
+                TRL_URB3D_mosaic,TBL_URB3D_mosaic,              & !H urban  danli mosaic
+                TGL_URB3D_mosaic,                               & !H urban  danli mosaic
+                SH_URB2D_mosaic,LH_URB2D_mosaic,                & !H urban  danli mosaic
+                G_URB2D_mosaic,RN_URB2D_mosaic,                 & !H urban  danli mosaic
+                TS_URB2D_mosaic,                                & !H urban  danli mosaic
+                TS_RUL2D_mosaic,                                & !H urban  danli mosaic                
+                psim_urb2d,psih_urb2d,u10_urb2d,v10_urb2d,      & !O urban
+                GZ1OZ0_urb2d, AKMS_URB2D,                       & !O urban
+                th2_urb2d,q2_urb2d,ust_urb2d,                   & !O urban
+                declin,coszen,hrang,                            & !I solar
+                xlat_urb2d,                                     & !I urban
+                num_roof_layers, num_wall_layers,               & !I urban
+                num_road_layers, DZR, DZB, DZG,                 & !I urban
+                FRC_URB2D, UTYPE_URB2D,                         & !I urban
+                num_urban_layers,                               & !I multi-layer urban
+                num_urban_hi,                                   & !I multi-layer urban
+                trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,        & !H multi-layer urban
+                tlev_urb3d,qlev_urb3d,                          & !H multi-layer urban
+                tw1lev_urb3d,tw2lev_urb3d,                      & !H multi-layer urban
+                tglev_urb3d,tflev_urb3d,                        & !H multi-layer urban
+                sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,            & !H multi-layer urban
+                sfvent_urb3d,lfvent_urb3d,                      & !H multi-layer urban
+                sfwin1_urb3d,sfwin2_urb3d,                      & !H multi-layer urban
+                sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,      & !H multi-layer urban
+                lp_urb2d,hi_urb2d,lb_urb2d,hgt_urb2d,           & !H multi-layer urban
+                mh_urb2d,stdh_urb2D,lf_urb2d,                   & !SLUCM
+                th_phy,rho,p_phy,ust,                           & !I multi-layer urban
+                gmt,julday,xlong,xlat,                          & !I multi-layer urban
+                a_u_bep,a_v_bep,a_t_bep,a_q_bep,                & !O multi-layer urban
+                a_e_bep,b_u_bep,b_v_bep,                        & !O multi-layer urban
+                b_t_bep,b_q_bep,b_e_bep,dlg_bep,                & !O multi-layer urban
+                dl_u_bep,sf_bep,vl_bep                          & !O multi-layer urban
+                ,sfcheadrt,INFXSRT, soldrain)
+
+           ELSE
+               CALL wrf_error_fatal('Lack arguments to call lsm_mosaic')
+           ENDIF
+
+	  ELSEIF (sf_surface_mosaic == 0) THEN
+	                  
+               CALL lsm(dz8w,qv_curr,p8w,t_phy,tsk,                 &
                 hfx,qfx,lh,grdflx,qgh,gsw,swdown,glw,smstav,smstot,    &
                 sfcrunoff,udrunoff,ivgtyp,isltyp,isurban,isice,vegfra,        &
                 albedo,albbck,znt,z0, tmn,xland,xice,emiss, embck,    &
@@ -2162,6 +2548,8 @@ SUBROUTINE surface_driver(                                         &
                 dl_u_bep,sf_bep,vl_bep                          & !O multi-layer urban
                 ,sfcheadrt,INFXSRT, soldrain)
 
+         ENDIF
+
          call seaice_noah( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THICKNESS_OPT, &
               &            SEAICE_THICKNESS_DEFAULT, SEAICE_SNOWDEPTH_OPT,             &
               &            SEAICE_SNOWDEPTH_MAX, SEAICE_SNOWDEPTH_MIN,                 &
@@ -2205,6 +2593,9 @@ SUBROUTINE surface_driver(                                         &
                         qsfc(i,j) = ( qsfc(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * qsfc_sea(i,j) )
                         qgh(i,j)  = ( qgh(i,j)  * XICE(i,j) ) + ( (1.0-XICE(i,j)) * qgh_sea(i,j)  )
                         qz0(i,j)  = ( qz0(i,j)  * XICE(i,j) ) + ( (1.0-XICE(i,j)) * qz0_sea(i,j)  )
+                                                            !  print *,'hfx =',hfx_sea(170,20)
+                                                            !   print *,'XICE =',XICE(170,20)
+                                                            !    print *,'QSFC =',QSFC(170,20)
                         hfx(i,j)  = ( hfx(i,j)  * XICE(i,j) ) + ( (1.0-XICE(i,j)) * hfx_sea(i,j)  )
                         qfx(i,j)  = ( qfx(i,j)  * XICE(i,j) ) + ( (1.0-XICE(i,j)) * qfx_sea(i,j)  )
                         lh(i,j)   = ( lh(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * lh_sea(i,j)   )
@@ -2299,6 +2690,25 @@ SUBROUTINE surface_driver(                                         &
 !          PRESENT(g_urb2d)   .AND. PRESENT(rn_urb2d) .AND.           &
 !          PRESENT(ts_urb2d)                          .AND.           &
 !          PRESENT(frc_urb2d) .AND. PRESENT(utype_urb2d)   .AND.      &
+#if (EM_CORE==1)
+           PRESENT(smcwtdxy)       .AND.                              &
+           PRESENT(rechxy)         .AND.                              &   
+           PRESENT(deeprechxy)     .AND.                              &
+           PRESENT(fdepthxy)       .AND.                              &
+           PRESENT(areaxy)         .AND.                              &   
+           PRESENT(rivercondxy)    .AND.                              &
+           PRESENT(riverbedxy)     .AND.                              & 
+           PRESENT(eqzwt)          .AND.                              &    
+           PRESENT(pexpxy)         .AND.                              &   
+           PRESENT(qrfxy)          .AND.                              &    
+           PRESENT(qspringxy)      .AND.                              &
+           PRESENT(qslatxy)        .AND.                              &  
+           PRESENT(qrfsxy)         .AND.                              &   
+           PRESENT(qspringsxy)     .AND.                              & 
+           PRESENT(smoiseq)        .AND.                              &  
+           PRESENT(wtddt)          .AND.                              &    
+           PRESENT(stepwtd)        .AND.                              &
+#endif
                                                       .TRUE. ) THEN
 !------------------------------------------------------------------
          IF( PRESENT(sr) ) THEN
@@ -2341,6 +2751,10 @@ SUBROUTINE surface_driver(                                         &
             ENDIF
          ENDIF
 
+!added for WRF_HYDRO
+#ifdef WRF_HYDRO
+         if(HYDRO_dt .ge. 0) HYDRO_dt = dtbl
+#endif
          CALL wrf_debug(100,'in NOAHMP DRV')
          CALL noahmplsm(ITIMESTEP,       YR, JULIAN_IN,   COSZEN, XLAT_URB2D, &
 	           DZ8W,     DTBL,      DZS,     NUM_SOIL_LAYERS,         DX, &
@@ -2360,6 +2774,7 @@ SUBROUTINE surface_driver(                                         &
 		QSNOWXY, WSLAKEXY,    ZWTXY,     WAXY,      WTXY,     TSNOXY, &
 		ZSNSOXY,  SNICEXY,  SNLIQXY, LFMASSXY,  RTMASSXY,   STMASSXY, &
 		 WOODXY, STBLCPXY, FASTCPXY,      LAI,    XSAIXY,    TAUSSXY, &
+	        SMOISEQ, SMCWTDXY,DEEPRECHXY,  RECHXY,                        & ! IN/OUT Noah MP only
 	         T2MVXY,   T2MBXY,   Q2MVXY,   Q2MBXY,                        &
                  TRADXY,    NEEXY,    GPPXY,    NPPXY,    FVEGXY,    RUNSFXY, &
 	        RUNSBXY,   ECANXY,   EDIRXY,  ETRANXY,     FSAXY,     FIRAXY, &
@@ -2368,10 +2783,30 @@ SUBROUTINE surface_driver(                                         &
 		  SHGXY,    SHCXY,    SHBXY,    EVGXY,     EVBXY,      GHVXY, &
 		  GHBXY,    IRGXY,    IRCXY,    IRBXY,      TRXY,      EVCXY, &
 	       CHLEAFXY,   CHUCXY,   CHV2XY,   CHB2XY,                        &                          
+#ifdef WRF_HYDRO
+                 sfcheadrt,INFXSRT,soldrain,                          &    !O
+#endif
                 ids,ide, jds,jde, kds,kde,                      &
                 ims,ime, jms,jme, kms,kme,                      &
                 i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte )
 
+  if(iopt_run.eq.5.and.mod(itimestep,STEPWTD).eq.0)then
+           CALL wrf_debug( 100, 'calling WTABLE' )
+
+!gmm update wtable from lateral flow and shed water to rivers
+
+           CALL WTABLE_mmf_noahmp(num_soil_layers,xland,xice, xice_threshold, isice,        &
+                                  isltyp,smoiseq,dzs,wtddt,                                 &
+                                  fdepthxy,areaxy,ht,isurban,ivgtyp,                         &
+                                  rivercondxy,riverbedxy,eqzwt,pexpxy,                      &
+                                  smois,sh2o,smcwtdxy,zwtxy,qrfxy,deeprechxy,qspringxy,     &
+                                  qslatxy,qrfsxy,qspringsxy,rechxy,                        &
+                                  ids,ide, jds,jde, kds,kde,                             &
+                                  ims,ime, jms,jme, kms,kme,                             &
+                                  i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte )
+
+  endif
+
          call seaice_noah( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THICKNESS_OPT, &
               &            SEAICE_THICKNESS_DEFAULT, SEAICE_SNOWDEPTH_OPT,             &
               &            SEAICE_SNOWDEPTH_MAX, SEAICE_SNOWDEPTH_MIN,                 &
@@ -2437,7 +2872,7 @@ SUBROUTINE surface_driver(                                         &
          ENDIF
            DO j=j_start(ij),j_end(ij)
            DO i=i_start(ij),i_end(ij)
-!              CHKLOWQ(I,J)= 1.0
+              CHKLOWQ(I,J)= 1.0
                SFCEVP(I,J)= SFCEVP(I,J) + QFX(I,J)*DTBL
                SFCEXC(I,J)= CHS(I,J)
                IF(PRESENT(ACHFX))ACHFX(I,J)=ACHFX(I,J) + HFX(I,J)*DT
@@ -2454,7 +2889,8 @@ SUBROUTINE surface_driver(                                         &
 !jref: sfc diagnostics
            DO j=j_start(ij),j_end(ij)
            DO i=i_start(ij),i_end(ij)
-              IF (IVGTYP(I,J) == ISWATER .OR. XICE(I,J) .GE. XICE_THRESHOLD) THEN
+!             IF (IVGTYP(I,J) == ISWATER .OR. XICE(I,J) .GE. XICE_THRESHOLD) THEN
+              IF (IVGTYP(I,J) == ISWATER .OR. (IVGTYP(I,J) == ISICE .AND. XICE(I,J) .GE. XICE_THRESHOLD)) THEN
                  IF(CQS2(I,J).lt.1.E-5) then
                    Q2(I,J)=QSFC(I,J)
                  ELSE
@@ -2466,7 +2902,8 @@ SUBROUTINE surface_driver(                                         &
                    T2(I,J) = TSK(I,J) - HFX(I,J)/(PSFC(I,J)/(R_d * TSK(I,J))*CP*CHS2(I,J))
                  ENDIF
                    TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**ROVCP
-              ELSEIF (IVGTYP(I,J) == ISURBAN .OR. IVGTYP(I,J) == ISICE .OR. FVEGXY(I,J) == 0.0 ) THEN
+!             ELSEIF (IVGTYP(I,J) == ISURBAN .OR. IVGTYP(I,J) == ISICE .OR. FVEGXY(I,J) == 0.0 ) THEN
+              ELSEIF (IVGTYP(I,J) == ISURBAN  .OR. (IVGTYP(I,J) == ISICE .AND. XICE(I,J) .LT. XICE_THRESHOLD)) THEN
                    Q2(I,J)  = Q2MBXY(I,J)
                    T2(I,J)  = T2MBXY(I,J)
                    TH2(I,J) = T2(i,j)*(1.E5/PSFC(i,j))**RCP
@@ -2508,6 +2945,13 @@ SUBROUTINE surface_driver(                                         &
                SR = 1.
            ENDIF
            CALL wrf_debug(100,'in RUC LSM')
+           DO j = j_start(ij) , j_end(ij)
+              DO i = i_start(ij) , i_end(ij)
+                 IF ( ( XICE(I,J) .GE. XICE_THRESHOLD ) .AND. ( XICE(i,j) .LE. 1. ) ) THEN
+                    ALBBCK(I,J) = SEAICE_ALBEDO_DEFAULT
+                 ENDIF
+              ENDDO
+           ENDDO
            IF ( FRACTIONAL_SEAICE == 1 ) THEN
               ! The fields passed to LSMRUC need to represent the full ice values, not
               ! the fractional values.  Convert ALBEDO and EMISS from the blended value 
@@ -2561,7 +3005,7 @@ SUBROUTINE surface_driver(                                         &
                 sfcrunoff,udrunoff,sfcexc,                      &
                 sfcevp,grdflx,acsnow,acsnom,                    &
                 smfr3d,keepfr3dflag,                            &
-                myj,shdmin,shdmax,                              &
+                myj,shdmin,shdmax,rdlai2d,                      &
                 ids,ide, jds,jde, kds,kde,                      &
                 ims,ime, jms,jme, kms,kme,                      &
                 i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte    )
@@ -2802,7 +3246,7 @@ SUBROUTINE surface_driver(                                         &
                 sfcrunoff,udrunoff,ivgtyp,isltyp,vegfra,        &
                 albedo,znt,z0, tmn,xland,xice, emiss,           &
                 snowc,qsfc,rainbl,maxpatch,                     &
-                num_soil_layers,dtbl,dzs,itimestep,             &
+                num_soil_layers,dtbl,xtime, dt,dzs,             &
                 smois,tslb,snow,canwat,                         &
                 chs,chs2,sh2o,snowh,                            &
                 u_phy,v_phy,                                    &
@@ -2812,7 +3256,7 @@ SUBROUTINE surface_driver(                                         &
                 ids,ide, jds,jde, kds,kde,                      &
                 ims,ime, jms,jme, kms,kme,                      &
                 i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, &
-                inest,sf_urban_physics                          &
+                inest,sf_urban_physics, nlcat                   &
 !Optional urban
                ,cmr_sfcdif,chr_sfcdif,cmc_sfcdif,chc_sfcdif    &
                ,tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d,  & !H urban
@@ -2954,6 +3398,10 @@ SUBROUTINE surface_driver(                                         &
 ! update land variables from CLM
               IF(XLAND(I,J).LT.1.5) then
                   Q2(I,J) = sum(q_ref2m(i,1:nump(i,j),j)*wtp(i,1:nump(i,j),j))
+
+! convert specific humidty to mixing ratio unit: kg/kg)
+                  Q2(I,J) = Q2(I,J)/(1.0-Q2(I,J))
+
                   T2(I,J) = sum(t_ref2m(i,1:nump(i,j),j)*wtp(i,1:nump(i,j),j))
                   TH2(I,J)= T2(I,J)*(1.E5/PSFC(I,J))**RCP
               END IF
@@ -3062,7 +3510,7 @@ SUBROUTINE surface_driver(                                         &
                       ssib_sdn(i,j), ssib_sup(i,j), ssib_ldn(i,j), ssib_lup(i,j),  &
                       ssib_wat(i,j),                                               &
                                      ssib_z00(i,j), ssib_veg(i,j),                 &
-                      day, cloudfrac, q2(i,j), t2(i,j), albedo(i,j),               &
+                      day, cloudfrac, q2(i,j), t2(i,j), albedo(i,j), uv10,         &
                       ra_sw_physics,xice_threshold                                 &
                                                                                    )
          ELSE  !land points only (including land ice)
@@ -3093,7 +3541,7 @@ SUBROUTINE surface_driver(                                         &
                      cto3(i,j), fio3(i,j),    flo3(i,j),   bio3(i,j), blo3(i,j),  ho3(i,j),  &
                      dzo4(i,j),  wo4(i,j),   tssn4(i,j), tssno4(i,j), bwo4(i,j), bto4(i,j),  &
                      cto4(i,j), fio4(i,j),    flo4(i,j),   bio4(i,j), blo4(i,j),  ho4(i,j),  &
-                     day, cloudfrac, q2(i,j), t2(i,j), albedo(i,j),               &
+                     day, cloudfrac, q2(i,j), t2(i,j), albedo(i,j), uv10,          &
                      ra_sw_physics, mminlu                                        &
                                                                                   )
          ENDIF
@@ -3112,8 +3560,8 @@ SUBROUTINE surface_driver(                                         &
          ELSE
            snowh(i,j) = snowdepth(i,j)
          ENDIF
-!mchen         U10(i,j) = 0.0
-!mchen         V10(i,j) = 0.0
+         U10(i,j) = UV10*u_phytmp(i,1,j)/SQRT(u_phytmp(i,1,j)**2+v_phytmp(i,1,j)**2)
+         V10(i,j) = UV10*v_phytmp(i,1,j)/SQRT(u_phytmp(i,1,j)**2+v_phytmp(i,1,j)**2)
 !        Overwrite WSPD to remove convective velocity (wspd=wspd1 in YSU)
          WSPD(I,J)=sqrt( u_phytmp(i,1,j)*u_phytmp(i,1,j) +      &
                          v_phytmp(i,1,j)*v_phytmp(i,1,j) ) + 1.e-9
@@ -3205,6 +3653,40 @@ SUBROUTINE surface_driver(                                         &
      !$OMP END PARALLEL DO
    ENDIF
 #endif
+! adding a lake model -- 07/02/2010
+   IF ( LakeModel == 1 ) THEN
+ 
+      CALL wrf_debug( 100, 'Call LakeModel' )
+ 
+      DO ij = 1 , num_tiles
+ 
+         CALL Lake(  t_phy        ,p8w            ,dz8w         ,qv_curr         ,&  !i
+                     u_phy        ,v_phy          , glw         ,emiss           ,&
+                     rainbl       ,dtbl           ,swdown       ,albedo          ,&
+                     xlat_urb2d   ,z_lake3d       ,dz_lake3d    ,lakedepth2d     ,&
+                     watsat3d     ,csol3d         ,tkmg3d       ,tkdry3d         ,&
+                     tksatu3d     ,ivgtyp         ,ht           ,xland           ,&
+                     iswater      ,xice           ,xice_threshold, lake_min_elev    ,&
+                     ids          ,ide            ,jds          ,jde             ,&
+                     kds          ,kde            ,ims          ,ime             ,&
+                     jms          ,jme            ,kms          ,kme             ,&
+                     i_start(ij)  ,i_end(ij)      ,j_start(ij)  ,j_end(ij)       ,&
+                     kts          ,kte                                           ,&
+                     h2osno2d     ,snowdp2d       ,snl2d        ,z3d             ,&  !h
+                     dz3d         ,zi3d           ,h2osoi_vol3d ,h2osoi_liq3d    ,&
+                     h2osoi_ice3d ,t_grnd2d       ,t_soisno3d   ,t_lake3d        ,&
+                     savedtke12d  ,lake_icefrac3d                                ,&
+#if ( EM_CORE==1)
+  !                   lakemask  ,lakeflag                                         ,&
+                     lakemask                                           ,&
+#endif
+                     hfx          ,lh             ,grdflx       ,tsk             ,&  !o
+                     qfx          ,t2             ,th2          ,q2 )
+ 
+ 
+      ENDDO
+ 
+   ENDIF
 
 ! Reset RAINBL in mm (Accumulation between PBL calls)
 
@@ -3616,673 +4098,1446 @@ subroutine myjsfc_seaice_wrapper(ITIMESTEP,HT,DZ,      &
 
    END SUBROUTINE myjsfc_seaice_wrapper
 
-!-------------------------------------------------------------------------
-
-   SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w,     &
-                     CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM,      &
-                     ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, &
-                     XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, &
-                     U10,V10,TH2,T2,Q2,                            &
-                     GZ1OZ0,WSPD,BR,ISFFLX,DX,                     &
-                     SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
-                     KARMAN,EOMEG,STBOLT,                          &
-               &itimestep,ch,th3d,pi3d,qc3d,                       &
-               &tsq,qsq,cov,qcg,                                   &
-XICE,SST,TSK_SEA,                                                  &
-CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA,               &
-HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA,                   &
-TICE2TSK_IF2COLD,XICE_THRESHOLD,                                   &
-                     ids,ide, jds,jde, kds,kde,                    &
-                     ims,ime, jms,jme, kms,kme,                    &
-                     its,ite, jts,jte, kts,kte,                    &
-               ustm,ck,cka,cd,cda,isftcflx,iz0tlnd                 )
-
-     USE module_sf_mynn, ONLY: sfclay_mynn
-     implicit none
-
-     INTEGER,  INTENT(IN )   ::        ids,ide, jds,jde, kds,kde,  &
-                                       ims,ime, jms,jme, kms,kme,  &
-                                       its,ite, jts,jte, kts,kte
-
-     INTEGER,  INTENT(IN )   ::        ISFFLX
-     REAL,     INTENT(IN )   ::        SVP1,SVP2,SVP3,SVPT0
-     REAL,     INTENT(IN )   ::        EP1,EP2,KARMAN,EOMEG,STBOLT
-
-     REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
-               INTENT(IN   )   ::                           dz8w
+!------------------------------------------------------------------------
 
-     REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
-               INTENT(IN   )   ::                           QV3D, &
-                                                             P3D, &
-                                                             T3D
+ subroutine qnsesfc_seaice_wrapper(ITIMESTEP,HT,DZ,      &
+        &     PMID,PINT,TH,T,QV,QC,U,V,Q2,                &
+        &     TSK,QSFC,THZ0,QZ0,UZ0,VZ0,                  &
+        &     LOWLYR,XLAND,       &
+        &     TICE2TSK_IF2COLD,                           &  ! Extra for wrapper
+        &     XICE_THRESHOLD,                             &  ! Extra for wrapper
+        &     XICE,SST,                                   &  ! Extra for wrapper
+        &     CHS_SEA, CHS2_SEA, CQS2_SEA, CPM_SEA,       &  ! Extra for wrapper
+        &     FLHC_SEA, FLQC_SEA, QSFC_SEA,               &  ! Extra for wrapper
+        &     QGH_SEA, QZ0_SEA, HFX_SEA, QFX_SEA,         &  ! Extra for wrapper
+        &     FLX_LH_SEA, TSK_SEA,                        &  ! Extra for wrapper
+        &     USTAR,ZNT,Z0BASE,PBLH,MAVAIL,RMOL,          &
+        &     AKHS,AKMS,                                  &
+        &     BR,                                         &
+        &     CHS,CHS2,CQS2,HFX,QFX,FLX_LH,FLHC,FLQC,     &
+        &     QGH,CPM,CT,                                 &
+        &     U10,V10,T02,TH02,TSHLTR,TH10,Q02,QSHLTR,Q10,PSHLTR,          &
+        &     IDS,IDE,JDS,JDE,KDS,KDE,                        &
+        &     IMS,IME,JMS,JME,KMS,KME,                        &
+        &     ITS,ITE,JTS,JTE,KTS,KTE,SCM_FORCE_FLUX )
+!     USE module_model_constants
+     USE module_sf_qnsesfc
 
-     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-               INTENT(IN   )               ::             MAVAIL, &
-                                                            PBLH, &
-                                                           XLAND
+     IMPLICIT NONE
 
-     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-               INTENT(OUT  )               ::                U10, &
-                                                             V10, &
-                                                             TH2, &
-                                                              T2, &
-                                                              Q2, &
-                                                            QSFC
-     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-               INTENT(INOUT)               ::             REGIME, &
-                                                             HFX, &
-                                                             QFX, &
-                                                              LH, &
-                                                         MOL,RMOL,TSK
+     INTEGER,                                INTENT(IN)    :: ITIMESTEP
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(IN)    :: HT
+     REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN)    :: DZ
+     REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN)    :: PMID
+     REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN)    :: PINT
+     REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN)    :: TH
+     REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN)    :: T
+     REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN)    :: QV
+     REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN)    :: QC
+     REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN)    :: U
+     REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN)    :: V
+     REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN)    :: Q2   ! Q2 is TKE?
 
-     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-               INTENT(INOUT)   ::                 GZ1OZ0,WSPD,BR, &
-                                                        PSIM,PSIH
+     ! REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(IN)    :: TSK
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT)    :: TSK
 
-     REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
-               INTENT(IN   )   ::                            U3D, &
-                                                             V3D
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: QSFC
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: THZ0
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: QZ0
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: UZ0
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: VZ0
+     INTEGER,DIMENSION(IMS:IME,JMS:JME),     INTENT(IN)    :: LOWLYR
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(IN)    :: XLAND
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(IN)    :: XICE       ! Extra for wrapper
+     ! REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(IN)    :: SST        ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: SST        ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: BR
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: CHS_SEA    ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: CHS2_SEA   ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: CQS2_SEA   ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: CPM_SEA    ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: QZ0_SEA   ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: QSFC_SEA   ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: QGH_SEA   ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: FLHC_SEA  ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: FLQC_SEA  ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: HFX_SEA    ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: QFX_SEA    ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: FLX_LH_SEA ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: TSK_SEA    ! Extra for wrapper
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: USTAR
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: ZNT
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(IN)    :: Z0BASE
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: PBLH
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(IN)    :: MAVAIL
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: RMOL
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: AKHS
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(INOUT) :: AKMS
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: CHS
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: CHS2
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: CQS2
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: HFX
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: QFX
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: FLX_LH
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: FLHC
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: FLQC
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: QGH
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: CPM
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: CT
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: U10
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: V10
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: T02
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: TH02
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: TSHLTR
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: TH10
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: Q02
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: QSHLTR
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: Q10
+     REAL,DIMENSION(IMS:IME,JMS:JME),        INTENT(OUT)   :: PSHLTR
+     REAL,                                   INTENT(IN)    :: XICE_THRESHOLD
+     LOGICAL,                                INTENT(IN)    :: TICE2TSK_IF2COLD
+     INTEGER,                                INTENT(IN)    :: SCM_FORCE_FLUX
+     INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE,       &
+          &                IMS,IME,JMS,JME,KMS,KME,       &
+          &                ITS,ITE,JTS,JTE,KTS,KTE
 
-     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-               INTENT(IN   )               ::               PSFC
 
-     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-               INTENT(INOUT)   ::                            ZNT, &
-                                                             ZOL, &
-                                                             UST, &
-                                                             CPM, &
-                                                            CHS2, &
-                                                            CQS2, &
-                                                             CHS
+     ! Local
+     INTEGER :: i
+     INTEGER :: j
+     REAL, DIMENSION( ims:ime, jms:jme ) :: ct_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: u10_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: v10_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: t02_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: th02_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: tshltr_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: pshltr_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: qshltr_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: th10_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: q02_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: q10_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: thz0_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: uz0_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: vz0_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: ustar_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: pblh_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: rmol_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: akhs_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: akms_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: xland_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: mavail_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: znt_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: z0base_sea
+     REAL, DIMENSION( ims:ime, jms:jme ) :: br_sea
 
-     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-               INTENT(INOUT)   ::                      FLHC,FLQC
+     REAL, DIMENSION( ims:ime, jms:jme ) :: QSFC_HOLD
+     REAL, DIMENSION( ims:ime, jms:jme ) :: QZ0_HOLD
+     REAL, DIMENSION( ims:ime, jms:jme ) :: THZ0_HOLD
+     REAL, DIMENSION( ims:ime, jms:jme ) :: UZ0_HOLD
+     REAL, DIMENSION( ims:ime, jms:jme ) :: VZ0_HOLD
+     REAL, DIMENSION( ims:ime, jms:jme ) :: USTAR_HOLD
+     REAL, DIMENSION( ims:ime, jms:jme ) :: ZNT_HOLD
+     REAL, DIMENSION( ims:ime, jms:jme ) :: PBLH_HOLD
+     REAL, DIMENSION( ims:ime, jms:jme ) :: RMOL_HOLD
+     REAL, DIMENSION( ims:ime, jms:jme ) :: AKHS_HOLD
+     REAL, DIMENSION( ims:ime, jms:jme ) :: AKMS_HOLD
+     REAL, DIMENSION( ims:ime, jms:jme ) :: TSK_LOCAL
+     REAL :: PSFC
 
-     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
-               INTENT(INOUT)   ::                                 &
-                                                              QGH
+     ! Set things up for the frozen-surface call to qnsesfc
 
-     REAL,     INTENT(IN   )               ::   CP,G,ROVCP,R,XLV,DX
-! from mynn subroutine
-     INTEGER, INTENT(in) :: itimestep
-     REAL,     DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: qcg
-     REAL,     DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ch
-     REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::     &
-                                                             &QC3D,&
-                                              &th3d,pi3d,tsq,qsq,cov
+     ! We want a TSK valid for the ice-covered regions of the grid cell.
 
-     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme )              , &
-               INTENT(OUT)     ::              ck,cka,cd,cda,ustm
-     INTEGER,  OPTIONAL,  INTENT(IN )   ::     ISFTCFLX,IZ0TLND
+     CALL get_local_ice_tsk( ims, ime, jms, jme, its, ite, jts, jte,  &
+                             itimestep, .true., tice2tsk_if2cold,     &
+                             XICE, XICE_THRESHOLD,                    &
+                             SST, TSK, TSK_SEA, TSK_LOCAL )
+     DO j = JTS , JTE
+        DO i = ITS , ITE
+           TSK(i,j) = TSK_LOCAL(i,j)
+           IF ( ( XICE(I,J) .GE. XICE_THRESHOLD ) .and. ( XICE(i,j) .LE. 1.0 ) ) THEN
 
-!--------------------------------------------------------------------
-!    New for wrapper
-!--------------------------------------------------------------------
-     LOGICAL,  INTENT(IN)               ::      TICE2TSK_IF2COLD
-     REAL,     INTENT(IN)               ::      XICE_THRESHOLD
-     REAL,     DIMENSION( ims:ime, jms:jme ),                     &
-               INTENT(IN)               ::      XICE
-     REAL,     DIMENSION( ims:ime, jms:jme ),                     &
-               INTENT(INOUT)            ::      SST
-     REAL,     DIMENSION( ims:ime, jms:jme ),                     &
-               INTENT(OUT)              ::      TSK_SEA,          &
-                                                CHS2_SEA,         &
-                                                CHS_SEA,          &
-                                                CPM_SEA,          &
-                                                CQS2_SEA,         &
-                                                FLHC_SEA,         &
-                                                FLQC_SEA,         &
-                                                HFX_SEA,          &
-                                                LH_SEA,           &
-                                                QFX_SEA,          &
-                                                QGH_SEA,          &
-                                                QSFC_SEA,         &
-                                                ZNT_SEA
+              ! Over fractional sea-ice points, back out an ice portion of QSFC as well.
+              ! QSFC_SEA calculation as done in qnsesfc for open water points
+              PSFC = PINT(I,LOWLYR(I,J),J)
+              QSFC_SEA(i,j) = PQ0SEA/PSFC*EXP(A2S*(TSK(i,j)-A3S)/(TSK(i,j)-A4S))
+              QSFC(i,j) = QSFC(i,j) - (1.0-XICE(i,j)) * QSFC_SEA(i,j) / XICE(i,j)
+!
+              HFX_SEA(i,j)  = HFX(i,j)
+              QFX_SEA(i,j)  = QFX(i,j)
+              FLX_LH_SEA(i,j)   = FLX_LH(i,j)
+           ENDIF
+        ENDDO
+     ENDDO
 
-!--------------------------------------------------------------------
-!    Local
-!--------------------------------------------------------------------
-     INTEGER :: I, J
-     REAL,     DIMENSION( ims:ime, jms:jme ) :: XLAND_SEA,        &
-                                                MAVAIL_sea,       &
-                                                TSK_LOCAL,        &
-                                                BR_HOLD,          &
-                                                CHS2_HOLD,        &
-                                                CHS_HOLD,         &
-                                                CPM_HOLD,         &
-                                                CQS2_HOLD,        &
-                                                FLHC_HOLD,        &
-                                                FLQC_HOLD,        &
-                                                GZ1OZ0_HOLD,      &
-                                                HFX_HOLD,         &
-                                                LH_HOLD,          &
-                                                MOL_HOLD,         &
-                                                PSIH_HOLD,        &
-                                                PSIM_HOLD,        &
-                                                QFX_HOLD,         &
-                                                QGH_HOLD,         &
-                                                REGIME_HOLD,      &
-                                                RMOL_HOLD,        &
-                                                UST_HOLD,         &
-                                                WSPD_HOLD,        &
-                                                ZNT_HOLD,         &
-                                                CH_HOLD,          & ! new
-                                                ZOL_HOLD,         &
-                                                Q2_SEA,           &
-                                                T2_SEA,           &
-                                                TH2_SEA,          &
-                                                U10_SEA,          &
-                                                V10_SEA,          &
-                                                CD_SEA,           &
-                                                CDA_SEA,          &
-                                                CK_SEA,           &
-                                                CKA_SEA,          &
-                                                USTM_SEA
+!
+! frozen ocean call for sea ice points
+!
 
-     REAL,     DIMENSION( ims:ime, jms:jme ) ::                   &
-                                                BR_SEA,           &
-                                                GZ1OZ0_SEA,       &
-                                                MOL_SEA,          &
-                                                PSIH_SEA,         &
-                                                PSIM_SEA,         &
-                                                REGIME_SEA,       &
-                                                RMOL_SEA,         &
-                                                UST_SEA,          &
-                                                WSPD_SEA,         &
-                                                CH_SEA,           & ! new
-                                                ZOL_SEA
-! INTENT(IN) to SFCLAY; unchanged by the call
-      ! ISFFLX
-      ! SVP1,SVP2,SVP3,SVPT0
-      ! EP1,EP2,KARMAN,EOMEG,STBOLT
-      ! CP,G,ROVCP,R,XLV,DX
-      ! dz8w
-      ! QV3D
-      ! P3D
-      ! T3D
-      ! MAVAIL
-      ! PBLH
-      ! XLAND
-      ! TSK
-      ! U3D
-      ! V3D
-      ! PSFC
+! Strictly INTENT(IN) to QNSESFC, should be unchanged by call.
 
-    CALL get_local_ice_tsk( ims, ime, jms, jme, its, ite, jts, jte,  &
-                             itimestep, .true., tice2tsk_if2cold,     &
-                             XICE, XICE_THRESHOLD,                    &
-                             SST, TSK, TSK_SEA, TSK_LOCAL )
+     ! DZ
+     ! HT
+     ! LOWLYR
+     ! MAVAIL
+     ! PINT
+     ! PMID
+     ! QC
+     ! QV
+     ! Q2
+     ! T
+     ! TH
+     ! TSK
+     ! U
+     ! V
+     ! XLAND
+     ! Z0BASE
 
-! DFS 8/25/10 Set TSK to ice value
-    DO j = JTS , JTE
-        DO i = ITS , ITE
-            TSK(i,j) = TSK_LOCAL(i,j)
-        ENDDO
-    ENDDO
+! INTENT (INOUT),  updated by QNSESFC.  Values will need to be saved before the first call to QNSESFC, so that
+! the second call to QNSESFC does not double-count the effect.
 
-! INTENT (INOUT) to SFCLAY:  Save the variables before the first call
-! (for land/frozen water) to SFCLAY, to keep from double-counting the
-! effects of that routine
-     BR_HOLD   = BR
-     CHS2_HOLD = CHS2
-     CHS_HOLD  = CHS
-     CPM_HOLD  = CPM
-     CQS2_HOLD = CQS2
-     FLHC_HOLD = FLHC
-     FLQC_HOLD = FLQC
-     GZ1OZ0_HOLD = GZ1OZ0
-     HFX_HOLD  = HFX
-     LH_HOLD   = LH
-     MOL_HOLD  = MOL
-     PSIH_HOLD = PSIH
-     PSIM_HOLD = PSIM
-     QFX_HOLD  = QFX
-     QGH_HOLD  = QGH
-     REGIME_HOLD = REGIME
-     RMOL_HOLD = RMOL
-     UST_HOLD  = UST
-     WSPD_HOLD = WSPD
-     ZNT_HOLD  = ZNT
-     ZOL_HOLD  = ZOL
-     CH_HOLD   = CH
+     ! Save INTENT(INOUT) variables before the frozen-water/true-land call to QNSESFC:
+     QSFC_HOLD  = QSFC
+     QZ0_HOLD   = QZ0
+     THZ0_HOLD  = THZ0
+     UZ0_HOLD   = UZ0
+     VZ0_HOLD   = VZ0
+     USTAR_HOLD = USTAR
+     ZNT_HOLD   = ZNT
+     PBLH_HOLD  = PBLH
+     RMOL_HOLD  = RMOL
+     AKHS_HOLD  = AKHS
+     AKMS_HOLD  = AKMS
 
-! INTENT(OUT) from SFCLAY.  Input shouldn't matter, but we'll want to
-! keep things around for weighting after the second call to SFCLAY.
-     ! Q2
-     ! QSFC
-     ! T2
-     ! TH2
+! Strictly INTENT(OUT):  Set by QNSESFC
+
+     ! CHS
+     ! CHS2
+     ! CPM
+     ! CQS2
+     ! CT
+     ! FLHC
+     ! FLQC
+     ! FLX_LH
+     ! HFX
+     ! PSHLTR
+     ! QFX
+     ! QGH
+     ! QSHLTR
+     ! Q02
+     ! Q10
+     ! TH02
+     ! TH10
+     ! TSHLTR
+     ! T02
      ! U10
      ! V10
 
-     ! land/frozen-water call
-!     call sfclay(U3D,V3D,T3D,QV3D,P3D,dz8w,                    & ! I
-!                 CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM,      & !
-!                 I,I,I,I,I,I,IO,IO,IO,IO,
-!                 ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, &
-!                 XLAND,HFX,QFX,LH,TSK_LOCAL,FLHC,FLQC,QGH,QSFC,RMOL, &
-!                 U10,V10,TH2,T2,Q2,                            &
-!                 GZ1OZ0,WSPD,BR,ISFFLX,DX,                     &
-!                 SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
-!                 KARMAN,EOMEG,STBOLT,                          &
-!                 P1000,                                      &
-!                 ids,ide, jds,jde, kds,kde,                    &
-!                 ims,ime, jms,jme, kms,kme,                    &
-!                 its,ite, jts,jte, kts,kte,                    &
-!                 ustm,ck,cka,cd,cda,isftcflx,iz0tlnd           )
+     ! Frozen-water/true-land call.
+     CALL QNSESFC ( ITIMESTEP, HT, DZ,                              &  ! I,I,I,
+          &        PMID, PINT, TH, T, QV, QC, U, V, Q2,            &  ! I,I,I,I,I,I,I,I,I,
+          &        TSK, QSFC, THZ0, QZ0, UZ0, VZ0,                 &  ! I,IO,IO,IO,IO,IO,
+          &        LOWLYR, XLAND,      &  ! I,I
+          &        USTAR, ZNT, Z0BASE, PBLH, MAVAIL, RMOL,         &  ! IO,IO,I,IO,I,IO,
+          &        AKHS, AKMS,                                     &  ! IO,IO,
+          &        BR,                                             &  ! O
+          &        CHS, CHS2, CQS2, HFX, QFX, FLX_LH, FLHC, FLQC,  &  ! O,O,O,0,0,0,0,0,
+          &        QGH, CPM, CT, U10, V10,T02,TH02,                    &  ! 0,0,0,0,0,0,0
+          &        TSHLTR, TH10, Q02,                    &  ! 0,0,0
+          &        QSHLTR, Q10, PSHLTR,                            &  ! 0,0,0,
+          &        ids,ide, jds,jde, kds,kde,                      &
+          &        ims,ime, jms,jme, kms,kme,                      &
+          &        its,ite, jts,jte, kts,kte, SCM_FORCE_FLUX    )
 
-          CALL SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,              &
-               CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM,            &
-               ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH,       &
-               XLAND,HFX,QFX,LH,TSK_LOCAL,FLHC,FLQC,QGH,QSFC,RMOL, &
-               U10,V10,TH2,T2,Q2,                                  &
-               GZ1OZ0,WSPD,BR,ISFFLX,DX,                           &
-               SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT,   &
-               &itimestep,ch,th3d,pi3d,qc3d,                       &
-               &tsq,qsq,cov,qcg,                                   &
-               ids,ide, jds,jde, kds,kde,                          &
-               ims,ime, jms,jme, kms,kme,                          &
-               its,ite, jts,jte, kts,kte,                          &
-               ustm,ck,cka,cd,cda,isftcflx,iz0tlnd                 )
+     ! Set up things for the open ocean call.
+     DO j = JTS, JTE
+        DO i = ITS, ITE
+           IF ( ( XICE(I,J) .GE. XICE_THRESHOLD ) .AND. ( XICE(i,j) .LE. 1.0 ) ) THEN
+              XLAND_SEA(i,j)=2.
+              MAVAIL_SEA(I,J)  = 1.
+              ZNT_SEA(I,J) = 0.0001
+              Z0BASE_SEA(I,J) = ZNT_SEA(I,J)
+              IF ( SST(i,j) .LT. 271.4 ) THEN
+                 SST(i,j) = 271.4
+              ENDIF
+              TSK_SEA(i,j) = SST(i,j)
+              PSFC = PINT(I,LOWLYR(I,J),J)
+              QSFC_SEA(I,J) = PQ0SEA/PSFC*EXP(A2S*(TSK_SEA(i,j)-A3S)/(TSK_SEA(i,j)-A4S))
+           ELSE
+              ! This should be a land point or a true open water point
+              XLAND_SEA(i,j)=xland(i,j)
+              MAVAIL_SEA(i,j) = mavail(i,j)
+              ZNT_SEA(I,J)    = ZNT_HOLD(I,J)
+              Z0BASE_SEA(I,J) = Z0BASE(I,J)
+              TSK_SEA(i,j)  = TSK(i,j)
+              QSFC_SEA(i,j) = QSFC_HOLD(i,j)
+           ENDIF
+        ENDDO
+     ENDDO
+
+     QZ0_SEA  = QZ0_HOLD
+     THZ0_SEA = THZ0_HOLD
+     UZ0_SEA  = UZ0_HOLD
+     VZ0_SEA  = VZ0_HOLD
+     USTAR_SEA = USTAR_HOLD
+     PBLH_SEA = PBLH_HOLD
+     RMOL_SEA = RMOL_HOLD
+     AKHS_SEA = AKHS_HOLD
+     AKMS_SEA = AKMS_HOLD
+
+!
+! open water call
+!
+     CALL QNSESFC ( ITIMESTEP, HT, DZ,                                                          & ! I,I,I,
+          &        PMID, PINT, TH, T, QV, QC, U, V, Q2,                                        & ! I,I,I,I,I,I,I,I,I,
+          &        TSK_SEA, QSFC_SEA, THZ0_SEA, QZ0_SEA, UZ0_SEA, VZ0_SEA,                     & ! I,IO,IO,IO,IO,IO,
+          &        LOWLYR, XLAND_SEA,                             & ! I,I,
+          &        USTAR_SEA, ZNT_SEA, Z0BASE_SEA, PBLH_SEA, MAVAIL_SEA, RMOL_SEA,             & ! IO,IO,I,IO,I,IO,
+          &        AKHS_SEA, AKMS_SEA,                                                         & ! IO,IO,
+          &        BR_SEA,                                                                     & ! dummy space holder
+          &        CHS_SEA, CHS2_SEA, CQS2_SEA, HFX_SEA, QFX_SEA, FLX_LH_SEA, FLHC_SEA,        & ! 0,0,0,0,0,0,0,
+          &        FLQC_SEA, QGH_SEA, CPM_SEA, CT_SEA, U10_SEA, V10_SEA,T02_SEA,TH02_SEA,   & ! 0,0,0,0,0,0,0,0
+          &        TSHLTR_SEA, TH10_SEA, Q02_SEA, QSHLTR_SEA, Q10_SEA, PSHLTR_SEA,             & ! 0,0,0,0,0,0
+          &        ids,ide, jds,jde, kds,kde,                                                  &
+          &        ims,ime, jms,jme, kms,kme,                                                  &
+          &        its,ite, jts,jte, kts,kte, SCM_FORCE_FLUX    )
+
+!
+! Scale the appropriate terms between open-water values and ice-covered values
+         
+
+     DO j = JTS, JTE
+        DO i = ITS, ITE
+           IF ( ( XICE(I,J) .GE. XICE_THRESHOLD ) .and. ( XICE(i,j) .LE. 1.0 ) ) THEN
+              ! Over sea-ice points, blend the results.
+
+              ! INTENT(OUT) from QNSESFC
+              ! CHS  wait
+              ! CHS2 wait
+              ! CPM  wait
+              ! CQS2 wait
+              CT(i,j)     = CT(i,j)     * XICE(i,j) + (1.0-XICE(i,j)) * CT_SEA (i,j)
+              ! FLHC(i,j)   = FLHC(i,j)   * XICE(i,j) + (1.0-XICE(i,j)) * FLHC_SEA (i,j)
+              ! FLQC(i,j)   = FLQC(i,j)   * XICE(i,j) + (1.0-XICE(i,j)) * FLQC_SEA (i,j)
+              ! FLX_LH wait
+              ! HFX  wait
+              PSHLTR(i,j) = PSHLTR(i,j) * XICE(i,j) + (1.0-XICE(i,j)) * PSHLTR_SEA(i,j)
+              ! QFX  wait
+              ! QGH  wait
+              QSHLTR(i,j) = QSHLTR(i,j) * XICE(i,j) + (1.0-XICE(i,j)) * QSHLTR_SEA(i,j)
+              Q10(i,j)    = Q10(i,j)    * XICE(i,j) + (1.0-XICE(i,j)) * Q10_SEA(i,j)
+              Q02(i,j)    = Q02(i,j)    * XICE(i,j) + (1.0-XICE(i,j)) * Q02_SEA(i,j)
+              TH10(i,j)   = TH10(i,j)   * XICE(i,j) + (1.0-XICE(i,j)) * TH10_SEA(i,j)
+               TH02(i,j)   = TH02(i,j)   * XICE(i,j) + (1.0-XICE(i,j)) * TH02_SEA(i,j)
+              TSHLTR(i,j) = TSHLTR(i,j) * XICE(i,j) + (1.0-XICE(i,j)) * TSHLTR_SEA(i,j)
+              T02(i,j)    = T02(i,j)    * XICE(i,j) + (1.0-XICE(i,j)) * T02_SEA(i,j)
+              U10(i,j)    = U10(i,j)    * XICE(i,j) + (1.0-XICE(i,j)) * U10_SEA(i,j)
+              V10(i,j)    = V10(i,j)    * XICE(i,j) + (1.0-XICE(i,j)) * V10_SEA(i,j)
+
+              ! INTENT(INOUT):  updated by QNSESFC
+              ! QSFC:  wait
+              THZ0(i,j)   = THZ0(i,j)   * XICE(i,j) + (1.0-XICE(i,j)) * THZ0_SEA(i,j)
+              ! qz0 wait
+              UZ0(i,j)    = UZ0(i,j)    * XICE(i,j) + (1.0-XICE(i,j)) * UZ0_SEA(i,j)
+              VZ0(i,j)    = VZ0(i,j)    * XICE(i,j) + (1.0-XICE(i,j)) * VZ0_SEA(i,j)
+              USTAR(i,j)  = USTAR(i,j)  * XICE(i,j) + (1.0-XICE(i,j)) * USTAR_SEA(i,j)
+              ! ZNT wait
+              PBLH(i,j)   = PBLH(i,j)   * XICE(i,j) + (1.0-XICE(i,j)) * PBLH_SEA(i,j)
+              RMOL(i,j)   = RMOL(i,j)   * XICE(i,j) + (1.0-XICE(i,j)) * RMOL_SEA(i,j)
+              AKHS(i,j)   = AKHS(i,j)   * XICE(i,j) + (1.0-XICE(i,j)) * AKHS_SEA(i,j)
+              AKMS(i,j)   = AKMS(i,j)   * XICE(i,j) + (1.0-XICE(i,j)) * AKMS_SEA(i,j)
+
+              !         tsk(i,j) = tsk(i,j)*XICE(i,j) + (1.0-XICE(i,j))*TSK_SEA(i,j)
+           ELSE
+              ! We're not over sea ice.  Take the results from the first call.
+           ENDIF
+        ENDDO
+     ENDDO
+
+   END SUBROUTINE qnsesfc_seaice_wrapper
+
+
+!-------------------------------------------------------------------------
+
+   SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w,     &
+                     CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM,      &
+                     ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, &
+                     XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, &
+                     U10,V10,TH2,T2,Q2,SNOWH,                      &
+                     GZ1OZ0,WSPD,BR,ISFFLX,DX,                     &
+                     SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,          &
+               &itimestep,ch,th3d,pi3d,qc3d,rho,                   &
+               &tsq,qsq,cov,Sh3d,el_pbl,qcg,                       &
+XICE,SST,TSK_SEA,                                                  &
+CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA,               &
+HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA,                   &
+TICE2TSK_IF2COLD,XICE_THRESHOLD,                                   &
+                     ids,ide, jds,jde, kds,kde,                    &
+                     ims,ime, jms,jme, kms,kme,                    &
+                     its,ite, jts,jte, kts,kte,                    &
+               ustm,ck,cka,cd,cda,isftcflx,iz0tlnd,bl_mynn_cloudpdf)
+
+     USE module_sf_mynn, ONLY: sfclay_mynn
+     implicit none
+
+     INTEGER,  INTENT(IN )   ::        ids,ide, jds,jde, kds,kde,  &
+                                       ims,ime, jms,jme, kms,kme,  &
+                                       its,ite, jts,jte, kts,kte
+
+     INTEGER,  INTENT(IN )   ::        ISFFLX,bl_mynn_cloudpdf
+     REAL,     INTENT(IN )   ::        SVP1,SVP2,SVP3,SVPT0
+     REAL,     INTENT(IN )   ::        EP1,EP2,KARMAN
+
+     REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
+               INTENT(IN   )   ::                           dz8w
+
+     REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
+               INTENT(IN   )   ::                           QV3D, &
+                                                             P3D, &
+                                                             T3D,rho
+
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(IN   )               ::             MAVAIL, &
+                                                            PBLH, &
+                                                           XLAND
+
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(OUT  )               ::                U10, &
+                                                             V10, &
+                                                             TH2, &
+                                                              T2, &
+                                                              Q2, &
+                                                            QSFC,SNOWH
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(INOUT)               ::             REGIME, &
+                                                             HFX, &
+                                                             QFX, &
+                                                              LH, &
+                                                         MOL,RMOL,TSK
+
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(INOUT)   ::                 GZ1OZ0,WSPD,BR, &
+                                                        PSIM,PSIH
+
+     REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
+               INTENT(IN   )   ::                            U3D, &
+                                                             V3D
+
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(IN   )               ::               PSFC
+
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(INOUT)   ::                            ZNT, &
+                                                             ZOL, &
+                                                             UST, &
+                                                             CPM, &
+                                                            CHS2, &
+                                                            CQS2, &
+                                                             CHS
+
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(INOUT)   ::                      FLHC,FLQC
+
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(INOUT)   ::                                 &
+                                                              QGH
+
+     REAL,     INTENT(IN   )               ::   CP,G,ROVCP,R,XLV,DX
+! from mynn subroutine
+     INTEGER, INTENT(in) :: itimestep
+     REAL,     DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: qcg
+     REAL,     DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ch
+     REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::     &
+                                                             &QC3D,&
+                            &th3d,pi3d,tsq,qsq,cov,Sh3d,el_pbl
+
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme )              , &
+               INTENT(OUT)     ::              ck,cka,cd,cda,ustm
+     INTEGER,  OPTIONAL,  INTENT(IN )   ::     ISFTCFLX,IZ0TLND
+
+!--------------------------------------------------------------------
+!    New for wrapper
+!--------------------------------------------------------------------
+     LOGICAL,  INTENT(IN)               ::      TICE2TSK_IF2COLD
+     REAL,     INTENT(IN)               ::      XICE_THRESHOLD
+     REAL,     DIMENSION( ims:ime, jms:jme ),                     &
+               INTENT(IN)               ::      XICE
+     REAL,     DIMENSION( ims:ime, jms:jme ),                     &
+               INTENT(INOUT)            ::      SST
+     REAL,     DIMENSION( ims:ime, jms:jme ),                     &
+               INTENT(OUT)              ::      TSK_SEA,          &
+                                                CHS2_SEA,         &
+                                                CHS_SEA,          &
+                                                CPM_SEA,          &
+                                                CQS2_SEA,         &
+                                                FLHC_SEA,         &
+                                                FLQC_SEA,         &
+                                                HFX_SEA,          &
+                                                LH_SEA,           &
+                                                QFX_SEA,          &
+                                                QGH_SEA,          &
+                                                QSFC_SEA,         &
+                                                ZNT_SEA
+
+!--------------------------------------------------------------------
+!    Local
+!--------------------------------------------------------------------
+     INTEGER :: I, J
+     REAL,     DIMENSION( ims:ime, jms:jme ) :: XLAND_SEA,        &
+                                                MAVAIL_sea,       &
+                                                TSK_LOCAL,        &
+                                                BR_HOLD,          &
+                                                CHS2_HOLD,        &
+                                                CHS_HOLD,         &
+                                                CPM_HOLD,         &
+                                                CQS2_HOLD,        &
+                                                FLHC_HOLD,        &
+                                                FLQC_HOLD,        &
+                                                GZ1OZ0_HOLD,      &
+                                                HFX_HOLD,         &
+                                                LH_HOLD,          &
+                                                MOL_HOLD,         &
+                                                PSIH_HOLD,        &
+                                                PSIM_HOLD,        &
+                                                QFX_HOLD,         &
+                                                QGH_HOLD,         &
+                                                REGIME_HOLD,      &
+                                                RMOL_HOLD,        &
+                                                UST_HOLD,         &
+                                                WSPD_HOLD,        &
+                                                ZNT_HOLD,         &
+                                                CH_HOLD,          & ! new
+                                                ZOL_HOLD,         &
+                                                Q2_SEA,           &
+                                                T2_SEA,           &
+                                                TH2_SEA,          &
+                                                U10_SEA,          &
+                                                V10_SEA,          &
+                                                CD_SEA,           &
+                                                CDA_SEA,          &
+                                                CK_SEA,           &
+                                                CKA_SEA,          &
+                                                USTM_SEA
+
+     REAL,     DIMENSION( ims:ime, jms:jme ) ::                   &
+                                                BR_SEA,           &
+                                                GZ1OZ0_SEA,       &
+                                                MOL_SEA,          &
+                                                PSIH_SEA,         &
+                                                PSIM_SEA,         &
+                                                REGIME_SEA,       &
+                                                RMOL_SEA,         &
+                                                UST_SEA,          &
+                                                WSPD_SEA,         &
+                                                CH_SEA,           & ! new
+                                                ZOL_SEA
+! INTENT(IN) to SFCLAY; unchanged by the call
+      ! ISFFLX
+      ! SVP1,SVP2,SVP3,SVPT0
+      ! EP1,EP2,KARMAN,EOMEG,STBOLT
+      ! CP,G,ROVCP,R,XLV,DX
+      ! dz8w
+      ! QV3D
+      ! P3D
+      ! T3D
+      ! MAVAIL
+      ! PBLH
+      ! XLAND
+      ! TSK
+      ! U3D
+      ! V3D
+      ! PSFC
+
+    CALL get_local_ice_tsk( ims, ime, jms, jme, its, ite, jts, jte,  &
+                             itimestep, .true., tice2tsk_if2cold,     &
+                             XICE, XICE_THRESHOLD,                    &
+                             SST, TSK, TSK_SEA, TSK_LOCAL )
+
+! DFS 8/25/10 Set TSK to ice value
+    DO j = JTS , JTE
+        DO i = ITS , ITE
+            TSK(i,j) = TSK_LOCAL(i,j)
+        ENDDO
+    ENDDO
+
+! INTENT (INOUT) to SFCLAY:  Save the variables before the first call
+! (for land/frozen water) to SFCLAY, to keep from double-counting the
+! effects of that routine
+     BR_HOLD   = BR
+     CHS2_HOLD = CHS2
+     CHS_HOLD  = CHS
+     CPM_HOLD  = CPM
+     CQS2_HOLD = CQS2
+     FLHC_HOLD = FLHC
+     FLQC_HOLD = FLQC
+     GZ1OZ0_HOLD = GZ1OZ0
+     HFX_HOLD  = HFX
+     LH_HOLD   = LH
+     MOL_HOLD  = MOL
+     PSIH_HOLD = PSIH
+     PSIM_HOLD = PSIM
+     QFX_HOLD  = QFX
+     QGH_HOLD  = QGH
+     REGIME_HOLD = REGIME
+     RMOL_HOLD = RMOL
+     UST_HOLD  = UST
+     WSPD_HOLD = WSPD
+     ZNT_HOLD  = ZNT
+     ZOL_HOLD  = ZOL
+     CH_HOLD   = CH
+
+! INTENT(OUT) from SFCLAY.  Input shouldn't matter, but we'll want to
+! keep things around for weighting after the second call to SFCLAY.
+     ! Q2
+     ! QSFC
+     ! T2
+     ! TH2
+     ! U10
+     ! V10
+
+     ! land/frozen-water call
+!     call sfclay(U3D,V3D,T3D,QV3D,P3D,dz8w,                    & ! I
+!                 CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM,      & !
+!                 I,I,I,I,I,I,IO,IO,IO,IO,
+!                 ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, &
+!                 XLAND,HFX,QFX,LH,TSK_LOCAL,FLHC,FLQC,QGH,QSFC,RMOL, &
+!                 U10,V10,TH2,T2,Q2,                            &
+!                 GZ1OZ0,WSPD,BR,ISFFLX,DX,                     &
+!                 SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
+!                 KARMAN,EOMEG,STBOLT,                          &
+!                 P1000,                                      &
+!                 ids,ide, jds,jde, kds,kde,                    &
+!                 ims,ime, jms,jme, kms,kme,                    &
+!                 its,ite, jts,jte, kts,kte,                    &
+!                 ustm,ck,cka,cd,cda,isftcflx,iz0tlnd           )
+
+          CALL SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,              &
+               CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM,            &
+               ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH,       &
+               XLAND,HFX,QFX,LH,TSK_LOCAL,FLHC,FLQC,QGH,QSFC,RMOL, &
+               U10,V10,TH2,T2,Q2,SNOWH,                            &
+               GZ1OZ0,WSPD,BR,ISFFLX,DX,                           &
+               SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,                &
+               &itimestep,ch,th3d,pi3d,qc3d,rho,                   &
+               &tsq,qsq,cov,sh3d,el_pbl,qcg,                       &
+               ids,ide, jds,jde, kds,kde,                          &
+               ims,ime, jms,jme, kms,kme,                          &
+               its,ite, jts,jte, kts,kte,                          &
+               ustm,ck,cka,cd,cda,isftcflx,iz0tlnd,bl_mynn_cloudpdf)
+
+     ! Set up for open-water call
+     DO j = JTS , JTE
+        DO i = ITS , ITE
+           IF ( ( XICE(I,J) .GE. XICE_THRESHOLD ) .and. ( XICE(i,j) .LE. 1.0 ) ) THEN
+              XLAND_SEA(i,j)=2.
+              MAVAIL_SEA(I,J)  =1.
+              ZNT_SEA(I,J) = 0.0001
+              TSK_SEA(i,j) = SST(i,j)
+              IF ( SST(i,j) .LT. 271.4 ) THEN
+                 SST(i,j) = 271.4
+                 TSK_SEA(i,j) = SST(i,j)
+              ENDIF
+           ELSE
+              XLAND_SEA(i,j) = XLAND(i,j)
+              MAVAIL_SEA(i,j) = MAVAIL(i,j)
+              ZNT_SEA(i,j)  = ZNT_HOLD(i,j)
+              TSK_SEA(i,j) = TSK_LOCAL(i,j)
+           ENDIF
+        ENDDO
+     ENDDO
+
+     ! Restore the values from before the land/frozen-water call
+     BR_SEA   = BR_HOLD
+     CHS2_SEA = CHS2_HOLD
+     CHS_SEA  = CHS_HOLD
+     CPM_SEA  = CPM_HOLD
+     CQS2_SEA = CQS2_HOLD
+     FLHC_SEA = FLHC_HOLD
+     FLQC_SEA = FLQC_HOLD
+     GZ1OZ0_SEA = GZ1OZ0_HOLD
+     HFX_SEA  = HFX_HOLD
+     LH_SEA   = LH_HOLD
+     MOL_SEA  = MOL_HOLD
+     PSIH_SEA = PSIH_HOLD
+     PSIM_SEA = PSIM_HOLD
+     QFX_SEA  = QFX_HOLD
+     QGH_SEA  = QGH_HOLD
+     REGIME_SEA = REGIME_HOLD
+     RMOL_SEA = RMOL_HOLD
+     UST_SEA  = UST_HOLD
+     WSPD_SEA = WSPD_HOLD
+     ZOL_SEA  = ZOL_HOLD
+     CH_SEA   = CH_HOLD
+
+     ! open-water call
+!     call sfclay(U3D,V3D,T3D,QV3D,P3D,dz8w,                    & ! I
+!                 CP,G,ROVCP,R,XLV,PSFC,                        & ! I
+!                 CHS_SEA,CHS2_SEA,CQS2_SEA,CPM_SEA,            & ! I/O
+!                 ZNT_SEA,UST_SEA,                              & ! I/O
+!                 PBLH,MAVAIL_SEA,                              & ! I
+!                 ZOL_SEA,MOL_SEA,REGIME_SEA,PSIM_SEA,PSIH_SEA, & ! I/O
+!                 XLAND_SEA,                              & ! I
+!                 HFX_SEA,QFX_SEA,LH_SEA,                       & ! I/O
+!                 TSK_SEA,                                      & ! I
+!                 FLHC_SEA,FLQC_SEA,QGH_SEA,QSFC_sea,RMOL_SEA,  & ! I/O
+!                 U10_sea,V10_sea,TH2_sea,T2_sea,Q2_sea,        & ! O
+!                 GZ1OZ0_SEA,WSPD_SEA,BR_SEA,                   & ! I/O
+!                 ISFFLX,DX,                                    &
+!                 SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
+!                 KARMAN,EOMEG,STBOLT,
+!                 P1000,                                      &
+!                 ids,ide, jds,jde, kds,kde,                    &
+!                 ims,ime, jms,jme, kms,kme,                    &
+!                 its,ite, jts,jte, kts,kte,                    & ! 0
+!                 ustm_sea,ck_sea,cka_sea,cd_sea,cda_sea,isftcflx,iz0tlnd )
+          CALL SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,              &
+               CP,G,ROVCP,R,XLV,PSFC,                              &
+               CHS_SEA,CHS2_SEA,CQS2_SEA,CPM_SEA,                  &
+               ZNT_SEA,UST_SEA,                                    &
+               PBLH,MAVAIL_SEA,                                    &
+               ZOL_SEA,MOL_SEA,REGIME_SEA,PSIM_SEA,PSIH_SEA,       &
+               XLAND_SEA,                                          &
+               HFX_SEA,QFX_SEA,LH_SEA,                             &
+               TSK_SEA,                                            &
+               FLHC_SEA,FLQC_SEA,QGH_SEA,QSFC_sea,RMOL_SEA,        &
+               U10_sea,V10_sea,TH2_sea,T2_sea,Q2_sea,SNOWH,        &
+               GZ1OZ0_SEA,WSPD_SEA,BR_SEA,                         &
+               ISFFLX,DX,                                          &
+               SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,                &
+               &itimestep,CH_SEA,th3d,pi3d,qc3d,rho,               &
+               &tsq,qsq,cov,sh3d,el_pbl,qcg,                       &
+               ids,ide, jds,jde, kds,kde,                          &
+               ims,ime, jms,jme, kms,kme,                          &
+               its,ite, jts,jte, kts,kte,                          &
+               ustm_sea,ck_sea,cka_sea,cd_sea,cda_sea,isftcflx,    &
+               iz0tlnd,bl_mynn_cloudpdf )
+
+     DO j = JTS , JTE
+        DO i = ITS, ITE
+           IF ( ( XICE(I,J) .GE. XICE_THRESHOLD )  .and.( XICE(i,j) .LE. 1.0 ) ) THEN
+              ! weighted average for sea ice points
+              br(i,j)     = ( br(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * br_sea(i,j)     )
+              ! CHS2 -- wait
+              ! CHS  -- wait
+              ! CPM  -- wait
+              ! CQS2 -- wait
+              ! FLHC -- wait
+              ! FLQC -- wait
+              gz1oz0(i,j) = ( gz1oz0(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * gz1oz0_sea(i,j) )
+              ! HFX  -- wait
+              ! LH   -- wait
+              mol(i,j)    = ( mol(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * mol_sea(i,j)    )
+              psih(i,j)   = ( psih(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * psih_sea(i,j)   )
+              psim(i,j)   = ( psim(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * psim_sea(i,j)   )
+              ! QFX  -- wait
+              ! QGH  -- wait
+              if ( XICE(i,j).GE. 0.5 ) regime(i,j) = regime_hold(i,j)
+              rmol(i,j)   = ( rmol(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * rmol_sea(i,j)   )
+              ust(i,j)    = ( ust(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * ust_sea(i,j)    )
+              wspd(i,j)   = ( wspd(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * wspd_sea(i,j)   )
+              zol(i,j)    = ( zol(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * zol_sea(i,j)    )
+              ch(i,j)     = ( ch(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * ch_sea(i,j)    )
+              ! INTENT(OUT)
+              ! --------------------------------------------------------------------
+              IF ( PRESENT ( CD ) ) THEN
+                 CD(i,j)  = ( CD(i,j)  * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CD_sea(i,j)    )
+              ENDIF
+              IF ( PRESENT ( CDA ) ) THEN
+                 CDA(i,j) = ( CDA(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CDA_sea(i,j)   )
+              ENDIF
+              IF ( PRESENT ( CK ) ) THEN
+                 CK(i,j)  = ( CK(i,j)  * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CK_sea(i,j)    )
+              ENDIF
+              IF ( PRESENT ( CKA ) ) THEN
+                 CKA(i,j) = ( CKA(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CKA_sea(i,j)   )
+              ENDIF
+              q2(i,j)     = ( q2(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * q2_sea(i,j)     )
+              ! QSFC -- wait
+              t2(i,j)     = ( t2(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * t2_sea(i,j)     )
+              th2(i,j)    = ( th2(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * th2_sea(i,j)    )
+              u10(i,j)    = ( u10(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * u10_sea(i,j)    )
+              IF ( PRESENT ( USTM ) ) THEN
+                 USTM(i,j) = ( USTM(i,j)  * XICE(i,j) ) + ( (1.0-XICE(i,j)) * USTM_sea(i,j)   )
+              ENDIF
+              v10(i,j)    = ( v10(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * v10_sea(i,j)    )
+           ENDIF
+        END DO
+     END DO
+!
+!         tsk(i,j) = tsk(i,j)*XICE(i,j) + (1.0-XICE(i,j))*TSK_SEA(i,j)
+!
+   END SUBROUTINE mynn_seaice_wrapper
+
+!-------------------------------------------------------------------------
+
+   SUBROUTINE sf_gfs_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,        &
+		 CP,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM,          &
+                     ZNT,UST,PSIM,PSIH,                          &
+                     XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,             &
+                     QGH,QSFC,U10,V10,                           &
+                     GZ1OZ0,WSPD,BR,ISFFLX,                      &
+                     EP1,EP2,KARMAN,itimestep,                   &
+                     TICE2TSK_IF2COLD,                           &
+                     XICE_THRESHOLD,                             &
+                     CHS_SEA, CHS2_SEA, CPM_SEA, CQS2_SEA,       &
+                     FLHC_SEA, FLQC_SEA,                         &
+                     HFX_SEA, LH_SEA, QFX_SEA, QGH_SEA, QSFC_SEA,&
+                     UST_SEA, ZNT_SEA, SST, XICE,                &
+                     ids,ide, jds,jde, kds,kde,                  &
+                     ims,ime, jms,jme, kms,kme,                  &
+                     its,ite, jts,jte, kts,kte                   )
+     USE module_sf_gfs
+     implicit none
+
+     INTEGER, INTENT(IN) ::             ids,ide, jds,jde, kds,kde,      &
+                                        ims,ime, jms,jme, kms,kme,      &
+                                        its,ite, jts,jte, kts,kte,      &
+                                        ISFFLX,itimestep
+
+      REAL,    INTENT(IN) ::                                            &
+                                        CP,                             &
+                                        EP1,                            &
+                                        EP2,                            &
+                                        KARMAN,                         &
+                                        R,                              &
+                                        ROVCP,                          &
+                                        XLV
+
+      REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::      &
+                                        P3D,                            &
+                                        QV3D,                           &
+                                        T3D,                            &
+                                        U3D,                            &
+                                        V3D
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
+                                        TSK,                            &
+                                        PSFC,                           &
+                                        XLAND
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            &
+                                        UST,                            &
+                                        ZNT
+
+      REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::                 &
+                                        BR,                             &
+                                        CHS,                            &
+                                        CHS2,                           &
+                                        CPM,                            &
+                                        CQS2,                           &
+                                        FLHC,                           &
+                                        FLQC,                           &
+                                        GZ1OZ0,                         &
+                                        HFX,                            &
+                                        LH,                             &
+                                        PSIM,                           &
+                                        PSIH,                           &
+                                        QFX,                            &
+                                        QGH,                            &
+                                        QSFC,                           &
+                                        U10,                            &
+                                        V10,                            &
+                                        WSPD
+
+      REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) ::                  &
+                                        XICE
+      REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::                 &
+                                        CHS_SEA,                        &
+                                        CHS2_SEA,                       &
+                                        CPM_SEA,                        &
+                                        CQS2_SEA,                       &
+                                        FLHC_SEA,                       &
+                                        FLQC_SEA,                       &
+                                        HFX_SEA,                        &
+                                        LH_SEA,                         &
+                                        QFX_SEA,                        &
+                                        QGH_SEA,                        &
+                                        QSFC_SEA,                       &
+                                        UST_SEA,                        &
+                                        ZNT_SEA
+      REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::               &
+                                        SST
+
+      REAL,                              INTENT(IN)    ::               &
+                                        XICE_THRESHOLD
+      LOGICAL,                          INTENT(IN)     :: TICE2TSK_IF2COLD
+
+!-------------------------------------------------------------------------
+!   Local
+!-------------------------------------------------------------------------
+      INTEGER :: I
+      INTEGER :: J
+      REAL, DIMENSION(ims:ime, jms:jme) ::                              &
+                                        BR_SEA,                         &
+                                        GZ1OZ0_SEA,                     &
+                                        PSIM_SEA,                       &
+                                        PSIH_SEA,                       &
+                                        U10_SEA,                        &
+                                        V10_SEA,                        &
+                                        WSPD_SEA,                       &
+                                        XLAND_SEA,                &
+                                        TSK_SEA,                        &
+                                        UST_HOLD,                       &
+                                        ZNT_HOLD,                       &
+                                        TSK_LOCAL
+
+      CALL get_local_ice_tsk( ims, ime, jms, jme, its, ite, jts, jte,  &
+                              itimestep, .true., tice2tsk_if2cold,     &
+                              XICE, XICE_THRESHOLD,                    &
+                              SST, TSK, TSK_SEA, TSK_LOCAL )
+
+!
+! Set up for frozen ocean call for sea ice points
+!
+
+! Strictly INTENT(IN), Should be unchanged by SF_GFS:
+!     CP
+!     EP1
+!     EP2
+!     KARMAN
+!     R
+!     ROVCP
+!     XLV
+!     P3D
+!     QV3D
+!     T3D
+!     U3D
+!     V3D
+!     TSK
+!     PSFC
+!     XLAND
+!     ISFFLX
+!     ITIMESTEP
+
+
+! Intent (INOUT), original value is used and changed by SF_GFS.
+!     UST
+!     ZNT
+
+     ZNT_HOLD = ZNT
+     UST_HOLD = UST
+
+! Strictly INTENT (OUT), set by SF_GFS:
+!     BR
+!     CHS     -- used by LSM routines
+!     CHS2    -- used by LSM routines
+!     CPM     -- used by LSM routines
+!     CQS2    -- used by LSM routines
+!     FLHC
+!     FLQC
+!     GZ1OZ0
+!     HFX     -- used by LSM routines
+!     LH      -- used by LSM routines
+!     PSIM
+!     PSIH
+!     QFX     -- used by LSM routines
+!     QGH     -- used by LSM routines
+!     QSFC    -- used by LSM routines
+!     U10
+!     V10
+!     WSPD
+
+!
+! Frozen ocean / true land call.
+!
+     CALL SF_GFS(U3D,V3D,T3D,QV3D,P3D,                  &
+          CP,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM_SEA,    &
+          ZNT,UST,PSIM,PSIH,                            &
+          XLAND,HFX,QFX,LH,TSK_LOCAL,FLHC,FLQC,         &
+          QGH,QSFC,U10,V10,                             &
+          GZ1OZ0,WSPD,BR,ISFFLX,                        &
+          EP1,EP2,KARMAN,ITIMESTEP,                     &
+          ids,ide, jds,jde, kds,kde,                    &
+          ims,ime, jms,jme, kms,kme,                    &
+          its,ite, jts,jte, kts,kte                     )
+
+! Set up for open-water call
 
-     ! Set up for open-water call
      DO j = JTS , JTE
         DO i = ITS , ITE
            IF ( ( XICE(I,J) .GE. XICE_THRESHOLD ) .and. ( XICE(i,j) .LE. 1.0 ) ) THEN
+              ! Sets up things for open ocean fraction of sea-ice points
               XLAND_SEA(i,j)=2.
-              MAVAIL_SEA(I,J)  =1.
               ZNT_SEA(I,J) = 0.0001
-              TSK_SEA(i,j) = SST(i,j)
               IF ( SST(i,j) .LT. 271.4 ) THEN
                  SST(i,j) = 271.4
-                 TSK_SEA(i,j) = SST(i,j)
               ENDIF
+              TSK_SEA(i,j) = SST(i,j)
            ELSE
-              XLAND_SEA(i,j) = XLAND(i,j)
-              MAVAIL_SEA(i,j) = MAVAIL(i,j)
-              ZNT_SEA(i,j)  = ZNT_HOLD(i,j)
-              TSK_SEA(i,j) = TSK_LOCAL(i,j)
+              ! Fully open ocean or true land points
+              XLAND_SEA(i,j)=xland(i,j)
+              ZNT_SEA(I,J) = ZNT_HOLD(I,J)
+              UST_SEA(i,j) = UST_HOLD(i,j)
+              TSK_SEA(i,j) = TSK(i,j)
            ENDIF
         ENDDO
      ENDDO
 
-     ! Restore the values from before the land/frozen-water call
-     BR_SEA   = BR_HOLD
-     CHS2_SEA = CHS2_HOLD
-     CHS_SEA  = CHS_HOLD
-     CPM_SEA  = CPM_HOLD
-     CQS2_SEA = CQS2_HOLD
-     FLHC_SEA = FLHC_HOLD
-     FLQC_SEA = FLQC_HOLD
-     GZ1OZ0_SEA = GZ1OZ0_HOLD
-     HFX_SEA  = HFX_HOLD
-     LH_SEA   = LH_HOLD
-     MOL_SEA  = MOL_HOLD
-     PSIH_SEA = PSIH_HOLD
-     PSIM_SEA = PSIM_HOLD
-     QFX_SEA  = QFX_HOLD
-     QGH_SEA  = QGH_HOLD
-     REGIME_SEA = REGIME_HOLD
-     RMOL_SEA = RMOL_HOLD
-     UST_SEA  = UST_HOLD
-     WSPD_SEA = WSPD_HOLD
-     ZOL_SEA  = ZOL_HOLD
-     CH_SEA   = CH_HOLD
+     ! Open-water call
+     ! _SEA variables are held for later use as the result of the open-water call.
+     CALL SF_GFS(U3D,V3D,T3D,QV3D,P3D,                  &
+          CP,ROVCP,R,XLV,PSFC,CHS_SEA,CHS2_SEA,CQS2_SEA,CPM,        &
+          ZNT_SEA,UST_SEA,PSIM_SEA,PSIH_SEA,                        &
+          XLAND,HFX_SEA,QFX_SEA,LH_SEA,TSK_SEA,FLHC_SEA,FLQC_SEA,   &
+          QGH_SEA,QSFC_SEA,U10_SEA,V10_SEA,                         &
+          GZ1OZ0_SEA,WSPD_SEA,BR_SEA,ISFFLX,                        &
+          EP1,EP2,KARMAN,ITIMESTEP,                     &
+          ids,ide, jds,jde, kds,kde,                    &
+          ims,ime, jms,jme, kms,kme,                    &
+          its,ite, jts,jte, kts,kte                     )
 
-     ! open-water call
-!     call sfclay(U3D,V3D,T3D,QV3D,P3D,dz8w,                    & ! I
-!                 CP,G,ROVCP,R,XLV,PSFC,                        & ! I
-!                 CHS_SEA,CHS2_SEA,CQS2_SEA,CPM_SEA,            & ! I/O
-!                 ZNT_SEA,UST_SEA,                              & ! I/O
-!                 PBLH,MAVAIL_SEA,                              & ! I
-!                 ZOL_SEA,MOL_SEA,REGIME_SEA,PSIM_SEA,PSIH_SEA, & ! I/O
-!                 XLAND_SEA,                              & ! I
-!                 HFX_SEA,QFX_SEA,LH_SEA,                       & ! I/O
-!                 TSK_SEA,                                      & ! I
-!                 FLHC_SEA,FLQC_SEA,QGH_SEA,QSFC_sea,RMOL_SEA,  & ! I/O
-!                 U10_sea,V10_sea,TH2_sea,T2_sea,Q2_sea,        & ! O
-!                 GZ1OZ0_SEA,WSPD_SEA,BR_SEA,                   & ! I/O
-!                 ISFFLX,DX,                                    &
-!                 SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
-!                 KARMAN,EOMEG,STBOLT,
-!                 P1000,                                      &
-!                 ids,ide, jds,jde, kds,kde,                    &
-!                 ims,ime, jms,jme, kms,kme,                    &
-!                 its,ite, jts,jte, kts,kte,                    & ! 0
-!                 ustm_sea,ck_sea,cka_sea,cd_sea,cda_sea,isftcflx,iz0tlnd )
-          CALL SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,              &
-               CP,G,ROVCP,R,XLV,PSFC,                              &
-               CHS_SEA,CHS2_SEA,CQS2_SEA,CPM_SEA,                  &
-               ZNT_SEA,UST_SEA,                                    &
-               PBLH,MAVAIL_SEA,                                    &
-               ZOL_SEA,MOL_SEA,REGIME_SEA,PSIM_SEA,PSIH_SEA,       &
-               XLAND_SEA,                                          &
-               HFX_SEA,QFX_SEA,LH_SEA,                             &
-               TSK_SEA,                                            &
-               FLHC_SEA,FLQC_SEA,QGH_SEA,QSFC_sea,RMOL_SEA,        &
-               U10_sea,V10_sea,TH2_sea,T2_sea,Q2_sea,              &
-               GZ1OZ0_SEA,WSPD_SEA,BR_SEA,                         &
-               ISFFLX,DX,                                          &
-               SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,EOMEG,STBOLT,   &
-               &itimestep,CH_SEA,th3d,pi3d,qc3d,                   &
-               &tsq,qsq,cov,qcg,                                   &
-               ids,ide, jds,jde, kds,kde,                          &
-               ims,ime, jms,jme, kms,kme,                          &
-               its,ite, jts,jte, kts,kte,                          &
-               ustm_sea,ck_sea,cka_sea,cd_sea,cda_sea,isftcflx,iz0tlnd )
+! Weighting, after our two calls to SF_GFS
 
      DO j = JTS , JTE
-        DO i = ITS, ITE
-           IF ( ( XICE(I,J) .GE. XICE_THRESHOLD )  .and.( XICE(i,j) .LE. 1.0 ) ) THEN
-              ! weighted average for sea ice points
-              br(i,j)     = ( br(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * br_sea(i,j)     )
-              ! CHS2 -- wait
-              ! CHS  -- wait
-              ! CPM  -- wait
-              ! CQS2 -- wait
-              ! FLHC -- wait
-              ! FLQC -- wait
-              gz1oz0(i,j) = ( gz1oz0(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * gz1oz0_sea(i,j) )
-              ! HFX  -- wait
-              ! LH   -- wait
-              mol(i,j)    = ( mol(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * mol_sea(i,j)    )
-              psih(i,j)   = ( psih(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * psih_sea(i,j)   )
-              psim(i,j)   = ( psim(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * psim_sea(i,j)   )
-              ! QFX  -- wait
-              ! QGH  -- wait
-              if ( XICE(i,j).GE. 0.5 ) regime(i,j) = regime_hold(i,j)
-              rmol(i,j)   = ( rmol(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * rmol_sea(i,j)   )
-              ust(i,j)    = ( ust(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * ust_sea(i,j)    )
-              wspd(i,j)   = ( wspd(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * wspd_sea(i,j)   )
-              zol(i,j)    = ( zol(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * zol_sea(i,j)    )
-              ch(i,j)     = ( ch(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * ch_sea(i,j)    )
-              ! INTENT(OUT)
-              ! --------------------------------------------------------------------
-              IF ( PRESENT ( CD ) ) THEN
-                 CD(i,j)  = ( CD(i,j)  * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CD_sea(i,j)    )
-              ENDIF
-              IF ( PRESENT ( CDA ) ) THEN
-                 CDA(i,j) = ( CDA(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CDA_sea(i,j)   )
-              ENDIF
-              IF ( PRESENT ( CK ) ) THEN
-                 CK(i,j)  = ( CK(i,j)  * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CK_sea(i,j)    )
-              ENDIF
-              IF ( PRESENT ( CKA ) ) THEN
-                 CKA(i,j) = ( CKA(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CKA_sea(i,j)   )
-              ENDIF
-              q2(i,j)     = ( q2(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * q2_sea(i,j)     )
-              ! QSFC -- wait
-              t2(i,j)     = ( t2(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * t2_sea(i,j)     )
-              th2(i,j)    = ( th2(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * th2_sea(i,j)    )
-              u10(i,j)    = ( u10(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * u10_sea(i,j)    )
-              IF ( PRESENT ( USTM ) ) THEN
-                 USTM(i,j) = ( USTM(i,j)  * XICE(i,j) ) + ( (1.0-XICE(i,j)) * USTM_sea(i,j)   )
-              ENDIF
-              v10(i,j)    = ( v10(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * v10_sea(i,j)    )
+        DO i = ITS , ITE
+           ! Over sea-ice points, weight the results.  Otherwise, just take the results from the
+           ! first call to SF_GFS_
+           IF ( ( XICE(I,J) .GE. XICE_THRESHOLD ) .and. ( XICE(i,j) .LE. 1.0 ) ) THEN
+              ! Weight a number of fields (between open-water results
+              ! and full ice results) by sea-ice fraction.
+
+              BR(i,j)     = ( BR(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * BR_SEA(i,j)     )
+              ! CHS, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
+              ! CHS2, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
+              ! CPM, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
+              ! CQS2, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
+              ! FLHC(i,j) = ( FLHC(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * FLHC_SEA(i,j) )
+              ! FLQC(i,j) = ( FLQC(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * FLQC_SEA(i,j) )
+              GZ1OZ0(i,j) = ( GZ1OZ0(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * GZ1OZ0_SEA(i,j) )
+              ! HFX, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
+              ! LH, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
+              PSIM(i,j)   = ( PSIM(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * PSIM_SEA(i,j)   )
+              PSIH(i,j)   = ( PSIH(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * PSIH_SEA(i,j)   )
+              ! QFX, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
+              ! QGH, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
+              ! QSFC, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
+              U10(i,j)    = ( U10(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * U10_SEA(i,j)    )
+              V10(i,j)    = ( V10(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * V10_SEA(i,j)    )
+              WSPD(i,j)   = ( WSPD(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * WSPD_SEA(i,j)   )
+              ! UST, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
+              ! ZNT, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
+
            ENDIF
-        END DO
-     END DO
-!
-!         tsk(i,j) = tsk(i,j)*XICE(i,j) + (1.0-XICE(i,j))*TSK_SEA(i,j)
-!
-   END SUBROUTINE mynn_seaice_wrapper
+        ENDDO
+     ENDDO
+
+   END SUBROUTINE sf_gfs_seaice_wrapper
 
 !-------------------------------------------------------------------------
 
-   SUBROUTINE sf_gfs_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,        &
-		 CP,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM,          &
-                     ZNT,UST,PSIM,PSIH,                          &
-                     XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,             &
-                     QGH,QSFC,U10,V10,                           &
-                     GZ1OZ0,WSPD,BR,ISFFLX,                      &
-                     EP1,EP2,KARMAN,itimestep,                   &
-                     TICE2TSK_IF2COLD,                           &
-                     XICE_THRESHOLD,                             &
-                     CHS_SEA, CHS2_SEA, CPM_SEA, CQS2_SEA,       &
-                     FLHC_SEA, FLQC_SEA,                         &
-                     HFX_SEA, LH_SEA, QFX_SEA, QGH_SEA, QSFC_SEA,&
-                     UST_SEA, ZNT_SEA, SST, XICE,                &
-                     ids,ide, jds,jde, kds,kde,                  &
-                     ims,ime, jms,jme, kms,kme,                  &
-                     its,ite, jts,jte, kts,kte                   )
-     USE module_sf_gfs
+!-------------------------------------------------------------------------
+
+   SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w,     &
+                     CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM,      &
+                     ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, &
+                     FM,FH,                                        &
+                     XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, &
+                     U10,V10,TH2,T2,Q2,                            &
+                     GZ1OZ0,WSPD,BR,ISFFLX,DX,                     &
+                     SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
+                     KARMAN,EOMEG,STBOLT,                          &
+                     P1000,                                      &
+XICE,SST,TSK_SEA,                                                  &
+CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA,               &
+HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA,                   &
+ITIMESTEP,TICE2TSK_IF2COLD,XICE_THRESHOLD,                         &
+                     ids,ide, jds,jde, kds,kde,                    &
+                     ims,ime, jms,jme, kms,kme,                    &
+                     its,ite, jts,jte, kts,kte,                    &
+                     ustm,ck,cka,cd,cda,isftcflx,iz0tlnd,          &
+                     sf_surface_physics                             )
+
+     USE module_sf_sfclay
      implicit none
 
-     INTEGER, INTENT(IN) ::             ids,ide, jds,jde, kds,kde,      &
-                                        ims,ime, jms,jme, kms,kme,      &
-                                        its,ite, jts,jte, kts,kte,      &
-                                        ISFFLX,itimestep
+     INTEGER,  INTENT(IN )   ::        ids,ide, jds,jde, kds,kde,  &
+                                       ims,ime, jms,jme, kms,kme,  &
+                                       its,ite, jts,jte, kts,kte
+
+     INTEGER,  INTENT(IN )   ::        ISFFLX
+     REAL,     INTENT(IN )   ::        SVP1,SVP2,SVP3,SVPT0
+     REAL,     INTENT(IN )   ::        EP1,EP2,KARMAN,EOMEG,STBOLT
+     REAL,     INTENT(IN )   ::        P1000
+
+     REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
+               INTENT(IN   )   ::                           dz8w
+
+     REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
+               INTENT(IN   )   ::                           QV3D, &
+                                                             P3D, &
+                                                             T3D
+
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(IN   )               ::             MAVAIL, &
+                                                            PBLH, &
+                                                           XLAND, &
+                                                             TSK
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(OUT  )               ::                U10, &
+                                                             V10, &
+                                                             TH2, &
+                                                              T2, &
+                                                              Q2, &
+                                                            QSFC
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(INOUT)               ::             REGIME, &
+                                                             HFX, &
+                                                             QFX, &
+                                                              LH, &
+                                                         MOL,RMOL
+
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(INOUT)   ::                 GZ1OZ0,WSPD,BR, &
+                                                 PSIM,PSIH,FM,FH
 
-      REAL,    INTENT(IN) ::                                            &
-                                        CP,                             &
-                                        EP1,                            &
-                                        EP2,                            &
-                                        KARMAN,                         &
-                                        R,                              &
-                                        ROVCP,                          &
-                                        XLV
+     REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
+               INTENT(IN   )   ::                            U3D, &
+                                                             V3D
 
-      REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::      &
-                                        P3D,                            &
-                                        QV3D,                           &
-                                        T3D,                            &
-                                        U3D,                            &
-                                        V3D
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(IN   )               ::               PSFC
 
-      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
-                                        TSK,                            &
-                                        PSFC,                           &
-                                        XLAND
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(INOUT)   ::                            ZNT, &
+                                                             ZOL, &
+                                                             UST, &
+                                                             CPM, &
+                                                            CHS2, &
+                                                            CQS2, &
+                                                             CHS
 
-      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            &
-                                        UST,                            &
-                                        ZNT
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(INOUT)   ::                      FLHC,FLQC
 
-      REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::                 &
-                                        BR,                             &
-                                        CHS,                            &
-                                        CHS2,                           &
-                                        CPM,                            &
-                                        CQS2,                           &
-                                        FLHC,                           &
-                                        FLQC,                           &
-                                        GZ1OZ0,                         &
-                                        HFX,                            &
-                                        LH,                             &
-                                        PSIM,                           &
-                                        PSIH,                           &
-                                        QFX,                            &
-                                        QGH,                            &
-                                        QSFC,                           &
-                                        U10,                            &
-                                        V10,                            &
-                                        WSPD
+     REAL,     DIMENSION( ims:ime, jms:jme )                    , &
+               INTENT(INOUT)   ::                                 &
+                                                              QGH
 
-      REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) ::                  &
-                                        XICE
-      REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::                 &
-                                        CHS_SEA,                        &
-                                        CHS2_SEA,                       &
-                                        CPM_SEA,                        &
-                                        CQS2_SEA,                       &
-                                        FLHC_SEA,                       &
-                                        FLQC_SEA,                       &
-                                        HFX_SEA,                        &
-                                        LH_SEA,                         &
-                                        QFX_SEA,                        &
-                                        QGH_SEA,                        &
-                                        QSFC_SEA,                       &
-                                        UST_SEA,                        &
-                                        ZNT_SEA
-      REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::               &
-                                        SST
+     REAL,     INTENT(IN   )               ::   CP,G,ROVCP,R,XLV,DX
 
-      REAL,                              INTENT(IN)    ::               &
-                                        XICE_THRESHOLD
-      LOGICAL,                          INTENT(IN)     :: TICE2TSK_IF2COLD
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme )              , &
+               INTENT(OUT)     ::              ck,cka,cd,cda,ustm
 
-!-------------------------------------------------------------------------
-!   Local
-!-------------------------------------------------------------------------
-      INTEGER :: I
-      INTEGER :: J
-      REAL, DIMENSION(ims:ime, jms:jme) ::                              &
-                                        BR_SEA,                         &
-                                        GZ1OZ0_SEA,                     &
-                                        PSIM_SEA,                       &
-                                        PSIH_SEA,                       &
-                                        U10_SEA,                        &
-                                        V10_SEA,                        &
-                                        WSPD_SEA,                       &
-                                        XLAND_SEA,                &
-                                        TSK_SEA,                        &
-                                        UST_HOLD,                       &
-                                        ZNT_HOLD,                       &
-                                        TSK_LOCAL
+     INTEGER,  OPTIONAL,  INTENT(IN )   ::     ISFTCFLX,IZ0TLND
 
-      CALL get_local_ice_tsk( ims, ime, jms, jme, its, ite, jts, jte,  &
-                              itimestep, .true., tice2tsk_if2cold,     &
-                              XICE, XICE_THRESHOLD,                    &
-                              SST, TSK, TSK_SEA, TSK_LOCAL )
+!--------------------------------------------------------------------
+!    New for wrapper
+!--------------------------------------------------------------------
+     INTEGER,  INTENT(IN)          ::    ITIMESTEP, sf_surface_physics
+     LOGICAL,  INTENT(IN)               ::      TICE2TSK_IF2COLD
+     REAL,     INTENT(IN)               ::      XICE_THRESHOLD
+     REAL,     DIMENSION( ims:ime, jms:jme ),                     &
+               INTENT(IN)               ::      XICE
+     REAL,     DIMENSION( ims:ime, jms:jme ),                     &
+               INTENT(INOUT)            ::      SST
+     REAL,     DIMENSION( ims:ime, jms:jme ),                     &
+               INTENT(OUT)              ::      TSK_SEA,          &
+                                                CHS2_SEA,         &
+                                                CHS_SEA,          &
+                                                CPM_SEA,          &
+                                                CQS2_SEA,         &
+                                                FLHC_SEA,         &
+                                                FLQC_SEA,         &
+                                                HFX_SEA,          &
+                                                LH_SEA,           &
+                                                QFX_SEA,          &
+                                                QGH_SEA,          &
+                                                QSFC_SEA,         &
+                                                ZNT_SEA
 
-!
-! Set up for frozen ocean call for sea ice points
-!
+!--------------------------------------------------------------------
+!    Local
+!--------------------------------------------------------------------
+     INTEGER :: I, J
+     REAL,     DIMENSION( ims:ime, jms:jme ) :: XLAND_SEA,        &
+                                                MAVAIL_sea,       &
+                                                TSK_LOCAL,        &
+                                                BR_HOLD,          &
+                                                CHS2_HOLD,        &
+                                                CHS_HOLD,         &
+                                                CPM_HOLD,         &
+                                                CQS2_HOLD,        &
+                                                FLHC_HOLD,        &
+                                                FLQC_HOLD,        &
+                                                GZ1OZ0_HOLD,      &
+                                                HFX_HOLD,         &
+                                                LH_HOLD,          &
+                                                MOL_HOLD,         &
+                                                PSIH_HOLD,        &
+                                                PSIM_HOLD,        &
+                                                FH_HOLD,          &
+                                                FM_HOLD,          &
+                                                QFX_HOLD,         &
+                                                QGH_HOLD,         &
+                                                REGIME_HOLD,      &
+                                                RMOL_HOLD,        &
+                                                UST_HOLD,         &
+                                                WSPD_HOLD,        &
+                                                ZNT_HOLD,         &
+                                                ZOL_HOLD,         &
+                                                TH2_HOLD,         & !ssib
+                                                T2_HOLD,          & !ssib
+                                                Q2_HOLD,          & !ssib
+                                                TSK_HOLD,         & !ssib
+                                                CD_SEA,           &
+                                                CDA_SEA,          &
+                                                CK_SEA,           &
+                                                CKA_SEA,          &
+                                                Q2_SEA,           &
+                                                T2_SEA,           &
+                                                TH2_SEA,          &
+                                                U10_SEA,          &
+                                                USTM_SEA,         &
+                                                V10_SEA
 
-! Strictly INTENT(IN), Should be unchanged by SF_GFS:
-!     CP
-!     EP1
-!     EP2
-!     KARMAN
-!     R
-!     ROVCP
-!     XLV
-!     P3D
-!     QV3D
-!     T3D
-!     U3D
-!     V3D
-!     TSK
-!     PSFC
-!     XLAND
-!     ISFFLX
-!     ITIMESTEP
+     REAL,     DIMENSION( ims:ime, jms:jme ) ::                   &
+                                                BR_SEA,           &
+                                                GZ1OZ0_SEA,       &
+                                                MOL_SEA,          &
+                                                PSIH_SEA,         &
+                                                PSIM_SEA,         &
+                                                FH_SEA,           &
+                                                FM_SEA,           &
+                                                REGIME_SEA,       &
+                                                RMOL_SEA,         &
+                                                UST_SEA,          &
+                                                WSPD_SEA,         &
+                                                ZOL_SEA
+
+! INTENT(IN) to SFCLAY; unchanged by the call
+      ! ISFFLX
+      ! SVP1,SVP2,SVP3,SVPT0
+      ! EP1,EP2,KARMAN,EOMEG,STBOLT
+      ! CP,G,ROVCP,R,XLV,DX
+      ! ISFTCFLX,IZ0TLND
+      ! P1000
+      ! dz8w
+      ! QV3D
+      ! P3D
+      ! T3D
+      ! MAVAIL
+      ! PBLH
+      ! XLAND
+      ! TSK
+      ! U3D
+      ! V3D
+      ! PSFC
 
+     CALL get_local_ice_tsk( ims, ime, jms, jme, its, ite, jts, jte,  &
+                             itimestep, .true., tice2tsk_if2cold,     &
+                             XICE, XICE_THRESHOLD,                    &
+                             SST, TSK, TSK_SEA, TSK_LOCAL )
 
-! Intent (INOUT), original value is used and changed by SF_GFS.
-!     UST
-!     ZNT
 
-     ZNT_HOLD = ZNT
-     UST_HOLD = UST
+! INTENT (INOUT) to SFCLAY:  Save the variables before the first call
+! (for land/frozen water) to SFCLAY, to keep from double-counting the
+! effects of that routine
+     BR_HOLD   = BR
+     CHS2_HOLD = CHS2
+     CHS_HOLD  = CHS
+     CPM_HOLD  = CPM
+     CQS2_HOLD = CQS2
+     FLHC_HOLD = FLHC
+     FLQC_HOLD = FLQC
+     GZ1OZ0_HOLD = GZ1OZ0
+     HFX_HOLD  = HFX
+     LH_HOLD   = LH
+     MOL_HOLD  = MOL
+     PSIH_HOLD = PSIH
+     PSIM_HOLD = PSIM
+     FH_HOLD   = FH
+     FM_HOLD   = FM
+     QFX_HOLD  = QFX
+     QGH_HOLD  = QGH
+     REGIME_HOLD = REGIME
+     RMOL_HOLD = RMOL
+     UST_HOLD  = UST
+     WSPD_HOLD = WSPD
+     ZNT_HOLD  = ZNT
+     ZOL_HOLD  = ZOL
+!also save these variables for SSIB (fds 12/2010)
+     TH2_HOLD = TH2
+     T2_HOLD = T2
+     Q2_HOLD = Q2
+     TSK_HOLD = TSK
+     
+! INTENT(OUT) from SFCLAY.  Input shouldn't matter, but we'll want to
+! keep things around for weighting after the second call to SFCLAY.
+     ! CD
+     ! CDA
+     ! CK
+     ! CKA
+     ! Q2
+     ! QSFC
+     ! T2
+     ! TH2
+     ! U10
+     ! USTM
+     ! V10
 
-! Strictly INTENT (OUT), set by SF_GFS:
-!     BR
-!     CHS     -- used by LSM routines
-!     CHS2    -- used by LSM routines
-!     CPM     -- used by LSM routines
-!     CQS2    -- used by LSM routines
-!     FLHC
-!     FLQC
-!     GZ1OZ0
-!     HFX     -- used by LSM routines
-!     LH      -- used by LSM routines
-!     PSIM
-!     PSIH
-!     QFX     -- used by LSM routines
-!     QGH     -- used by LSM routines
-!     QSFC    -- used by LSM routines
-!     U10
-!     V10
-!     WSPD
 
+     ! land/frozen-water call
+     call sfclay(U3D,V3D,T3D,QV3D,P3D,dz8w,                    & ! I
+                 CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM,      & ! I,I,I,I,I,I,IO,IO,IO,IO,
+                 ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, &
+                 FM,FH,                                        &
+                 XLAND,HFX,QFX,LH,TSK_LOCAL,FLHC,FLQC,QGH,QSFC,RMOL, &
+                 U10,V10,TH2,T2,Q2,                            &
+                 GZ1OZ0,WSPD,BR,ISFFLX,DX,                     &
+                 SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
+                 KARMAN,EOMEG,STBOLT,                          &
+                 P1000,                                      &
+                 ids,ide, jds,jde, kds,kde,                    &
+                 ims,ime, jms,jme, kms,kme,                    &
+                 its,ite, jts,jte, kts,kte,                    &
+                 ustm,ck,cka,cd,cda,isftcflx,iz0tlnd           )
 !
-! Frozen ocean / true land call.
+!Restore land-point values calculated by SSiB (fds 12/2010)
+     IF (itimestep .gt. 1 .and. sf_surface_physics .EQ. 8) then
+     DO j = JTS , JTE
+        DO i = ITS, ITE
+           IF ( XLAND(I,J) .LT. 1.5 ) THEN
+              BR(I,J) = BR_HOLD(I,J)
+              TH2(I,J) = TH2_HOLD(I,J)
+              T2(I,J) = T2_HOLD(I,J)
+              Q2(I,J) = Q2_HOLD(I,J)
+              HFX(I,J) = HFX_HOLD(I,J)
+              QFX(I,J) = QFX_HOLD(I,J)
+              LH(I,J) = LH_HOLD(I,J)
+              GZ1OZ0(I,J) = GZ1OZ0_HOLD(I,J)
+              WSPD(I,J) = WSPD_HOLD(I,J)
+              ZNT(I,J) = ZNT_HOLD(I,J)
+              UST(I,J) = UST_HOLD(I,J)
+!             TSK(I,J) = TSK_HOLD(I,J)
+           ENDIF
+        ENDDO
+     ENDDO
+     ENDIF
 !
-     CALL SF_GFS(U3D,V3D,T3D,QV3D,P3D,                  &
-          CP,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM_SEA,    &
-          ZNT,UST,PSIM,PSIH,                            &
-          XLAND,HFX,QFX,LH,TSK_LOCAL,FLHC,FLQC,         &
-          QGH,QSFC,U10,V10,                             &
-          GZ1OZ0,WSPD,BR,ISFFLX,                        &
-          EP1,EP2,KARMAN,ITIMESTEP,                     &
-          ids,ide, jds,jde, kds,kde,                    &
-          ims,ime, jms,jme, kms,kme,                    &
-          its,ite, jts,jte, kts,kte                     )
-
-! Set up for open-water call
-
+     ! Set up for open-water call
      DO j = JTS , JTE
         DO i = ITS , ITE
            IF ( ( XICE(I,J) .GE. XICE_THRESHOLD ) .and. ( XICE(i,j) .LE. 1.0 ) ) THEN
-              ! Sets up things for open ocean fraction of sea-ice points
               XLAND_SEA(i,j)=2.
+              MAVAIL_SEA(I,J)  =1.
               ZNT_SEA(I,J) = 0.0001
+              TSK_SEA(i,j) = SST(i,j)
               IF ( SST(i,j) .LT. 271.4 ) THEN
                  SST(i,j) = 271.4
+                 TSK_SEA(i,j) = SST(i,j)
               ENDIF
-              TSK_SEA(i,j) = SST(i,j)
            ELSE
-              ! Fully open ocean or true land points
-              XLAND_SEA(i,j)=xland(i,j)
-              ZNT_SEA(I,J) = ZNT_HOLD(I,J)
-              UST_SEA(i,j) = UST_HOLD(i,j)
-              TSK_SEA(i,j) = TSK(i,j)
+              XLAND_SEA(i,j) = XLAND(i,j)
+              MAVAIL_SEA(i,j) = MAVAIL(i,j)
+              ZNT_SEA(i,j)  = ZNT_HOLD(i,j)
+              TSK_SEA(i,j) = TSK_LOCAL(i,j)
            ENDIF
         ENDDO
      ENDDO
 
-     ! Open-water call
-     ! _SEA variables are held for later use as the result of the open-water call.
-     CALL SF_GFS(U3D,V3D,T3D,QV3D,P3D,                  &
-          CP,ROVCP,R,XLV,PSFC,CHS_SEA,CHS2_SEA,CQS2_SEA,CPM,        &
-          ZNT_SEA,UST_SEA,PSIM_SEA,PSIH_SEA,                        &
-          XLAND,HFX_SEA,QFX_SEA,LH_SEA,TSK_SEA,FLHC_SEA,FLQC_SEA,   &
-          QGH_SEA,QSFC_SEA,U10_SEA,V10_SEA,                         &
-          GZ1OZ0_SEA,WSPD_SEA,BR_SEA,ISFFLX,                        &
-          EP1,EP2,KARMAN,ITIMESTEP,                     &
-          ids,ide, jds,jde, kds,kde,                    &
-          ims,ime, jms,jme, kms,kme,                    &
-          its,ite, jts,jte, kts,kte                     )
-
-! Weighting, after our two calls to SF_GFS
-
+     ! Restore the values from before the land/frozen-water call
+     BR_SEA   = BR_HOLD
+     CHS2_SEA = CHS2_HOLD
+     CHS_SEA  = CHS_HOLD
+     CPM_SEA  = CPM_HOLD
+     CQS2_SEA = CQS2_HOLD
+     FLHC_SEA = FLHC_HOLD
+     FLQC_SEA = FLQC_HOLD
+     GZ1OZ0_SEA = GZ1OZ0_HOLD
+     HFX_SEA  = HFX_HOLD
+     LH_SEA   = LH_HOLD
+     MOL_SEA  = MOL_HOLD
+     PSIH_SEA = PSIH_HOLD
+     PSIM_SEA = PSIM_HOLD
+     FH_SEA   = FH_HOLD
+     FM_SEA   = FM_HOLD
+     QFX_SEA  = QFX_HOLD
+     QGH_SEA  = QGH_HOLD
+     REGIME_SEA = REGIME_HOLD
+     RMOL_SEA = RMOL_HOLD
+     UST_SEA  = UST_HOLD
+     WSPD_SEA = WSPD_HOLD
+     ZOL_SEA  = ZOL_HOLD
+!
+     ! open-water call
+     call sfclay(U3D,V3D,T3D,QV3D,P3D,dz8w,                    & ! I
+                 CP,G,ROVCP,R,XLV,PSFC,                        & ! I
+                 CHS_SEA,CHS2_SEA,CQS2_SEA,CPM_SEA,            & ! I/O
+                 ZNT_SEA,UST_SEA,                              & ! I/O
+                 PBLH,MAVAIL_SEA,                              & ! I
+                 ZOL_SEA,MOL_SEA,REGIME_SEA,PSIM_SEA,PSIH_SEA, & ! I/O
+                 FM_SEA,FH_SEA,                                &
+                 XLAND_SEA,                              & ! I
+                 HFX_SEA,QFX_SEA,LH_SEA,                       & ! I/O
+                 TSK_SEA,                                      & ! I
+                 FLHC_SEA,FLQC_SEA,QGH_SEA,QSFC_sea,RMOL_SEA,  & ! I/O
+                 U10_sea,V10_sea,TH2_sea,T2_sea,Q2_sea,        & ! O
+                 GZ1OZ0_SEA,WSPD_SEA,BR_SEA,                   & ! I/O
+                 ISFFLX,DX,                                    &
+                 SVP1,SVP2,SVP3,SVPT0,EP1,EP2,                 &
+                 KARMAN,EOMEG,STBOLT,                          &
+                 P1000,                                      &
+                 ids,ide, jds,jde, kds,kde,                    &
+                 ims,ime, jms,jme, kms,kme,                    &
+                 its,ite, jts,jte, kts,kte,                    & ! 0
+                 ustm_sea,ck_sea,cka_sea,cd_sea,cda_sea,isftcflx,iz0tlnd )
+!
      DO j = JTS , JTE
-        DO i = ITS , ITE
-           ! Over sea-ice points, weight the results.  Otherwise, just take the results from the
-           ! first call to SF_GFS_
-           IF ( ( XICE(I,J) .GE. XICE_THRESHOLD ) .and. ( XICE(i,j) .LE. 1.0 ) ) THEN
-              ! Weight a number of fields (between open-water results
-              ! and full ice results) by sea-ice fraction.
-
-              BR(i,j)     = ( BR(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * BR_SEA(i,j)     )
-              ! CHS, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
-              ! CHS2, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
-              ! CPM, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
-              ! CQS2, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
-              ! FLHC(i,j) = ( FLHC(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * FLHC_SEA(i,j) )
-              ! FLQC(i,j) = ( FLQC(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * FLQC_SEA(i,j) )
-              GZ1OZ0(i,j) = ( GZ1OZ0(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * GZ1OZ0_SEA(i,j) )
-              ! HFX, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
-              ! LH, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
-              PSIM(i,j)   = ( PSIM(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * PSIM_SEA(i,j)   )
-              PSIH(i,j)   = ( PSIH(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * PSIH_SEA(i,j)   )
-              ! QFX, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
-              ! QGH, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
-              ! QSFC, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
-              U10(i,j)    = ( U10(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * U10_SEA(i,j)    )
-              V10(i,j)    = ( V10(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * V10_SEA(i,j)    )
-              WSPD(i,j)   = ( WSPD(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * WSPD_SEA(i,j)   )
-              ! UST, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
-              ! ZNT, used by the LSM routines, is not updated yet.  Return results from both calls in separate variables
-
+        DO i = ITS, ITE
+           IF ( ( XICE(I,J) .GE. XICE_THRESHOLD )  .and.( XICE(i,j) .LE. 1.0 ) ) THEN
+              ! weighted average for sea ice points
+              br(i,j)     = ( br(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * br_sea(i,j)     )
+              ! CHS2 -- wait
+              ! CHS  -- wait
+              ! CPM  -- wait
+              ! CQS2 -- wait
+              ! FLHC -- wait
+              ! FLQC -- wait
+              gz1oz0(i,j) = ( gz1oz0(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * gz1oz0_sea(i,j) )
+              ! HFX  -- wait
+              ! LH   -- wait
+              mol(i,j)    = ( mol(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * mol_sea(i,j)    )
+              psih(i,j)   = ( psih(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * psih_sea(i,j)   )
+              psim(i,j)   = ( psim(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * psim_sea(i,j)   )
+              fh(i,j)    = ( fh(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * fh_sea(i,j)   )
+              fm(i,j)    = ( fm(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * fm_sea(i,j)   )
+              ! QFX  -- wait
+              ! QGH  -- wait
+              if ( XICE(i,j).GE. 0.5 ) regime(i,j) = regime_hold(i,j)
+              rmol(i,j)   = ( rmol(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * rmol_sea(i,j)   )
+              ust(i,j)    = ( ust(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * ust_sea(i,j)    )
+              wspd(i,j)   = ( wspd(i,j)   * XICE(i,j) ) + ( (1.0-XICE(i,j)) * wspd_sea(i,j)   )
+              zol(i,j)    = ( zol(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * zol_sea(i,j)    )
+              ! INTENT(OUT) --------------------------------------------------------------------
+              IF ( PRESENT ( CD ) ) THEN
+                 CD(i,j)     = ( CD(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CD_sea(i,j)     )
+              ENDIF
+              IF ( PRESENT ( CDA ) ) THEN
+                 CDA(i,j)     = ( CDA(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CDA_sea(i,j)     )
+              ENDIF
+              IF ( PRESENT ( CK ) ) THEN
+                 CK(i,j)     = ( CK(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CK_sea(i,j)     )
+              ENDIF
+              IF ( PRESENT ( CKA ) ) THEN
+                 CKA(i,j)     = ( CKA(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * CKA_sea(i,j)     )
+              ENDIF
+              q2(i,j)     = ( q2(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * q2_sea(i,j)     )
+              ! QSFC -- wait
+              t2(i,j)     = ( t2(i,j)     * XICE(i,j) ) + ( (1.0-XICE(i,j)) * t2_sea(i,j)     )
+              th2(i,j)    = ( th2(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * th2_sea(i,j)    )
+              u10(i,j)    = ( u10(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * u10_sea(i,j)    )
+              IF ( PRESENT ( USTM ) ) THEN
+                 USTM(i,j)    = ( USTM(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * USTM_sea(i,j)    )
+              ENDIF
+              v10(i,j)    = ( v10(i,j)    * XICE(i,j) ) + ( (1.0-XICE(i,j)) * v10_sea(i,j)    )
            ENDIF
-        ENDDO
-     ENDDO
-
-   END SUBROUTINE sf_gfs_seaice_wrapper
+        END DO
+     END DO
+!
+!         tsk(i,j) = tsk(i,j)*XICE(i,j) + (1.0-XICE(i,j))*TSK_SEA(i,j)
+!
+   END SUBROUTINE sfclayrev_seaice_wrapper
 
-!-------------------------------------------------------------------------
 !-------------------------------------------------------------------------
 
    SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w,     &
@@ -4437,6 +5692,8 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w,     &
                                                 T2_HOLD,          & !ssib
                                                 Q2_HOLD,          & !ssib
                                                 TSK_HOLD,         & !ssib
+                                                U10_HOLD,         & !ssib
+                                                V10_HOLD,         & !ssib
                                                 CD_SEA,           &
                                                 CDA_SEA,          &
                                                 CK_SEA,           &
@@ -4518,6 +5775,8 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w,     &
      T2_HOLD = T2
      Q2_HOLD = Q2
      TSK_HOLD = TSK
+     U10_HOLD = U10 !fds (01/2014)
+     V10_HOLD = V10 !fds (01/2014)
      
 ! INTENT(OUT) from SFCLAY.  Input shouldn't matter, but we'll want to
 ! keep things around for weighting after the second call to SFCLAY.
@@ -4567,6 +5826,8 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w,     &
               ZNT(I,J) = ZNT_HOLD(I,J)
               UST(I,J) = UST_HOLD(I,J)
 !             TSK(I,J) = TSK_HOLD(I,J)
+              U10(I,J) = U10_HOLD(I,J) !fds (01/2014)
+              V10(I,J) = V10_HOLD(I,J) !fds (01/2014)
            ENDIF
         ENDDO
      ENDDO
diff --git a/wrfv2_fire/phys/module_wind_fitch.F b/wrfv2_fire/phys/module_wind_fitch.F
index 274e562a..3cb2dec5 100644
--- a/wrfv2_fire/phys/module_wind_fitch.F
+++ b/wrfv2_fire/phys/module_wind_fitch.F
@@ -1,212 +1,130 @@
 !WRF:MODEL_LAYER:PHYSICS
 
 MODULE module_wind_fitch
-
-! Represents kinetic energy extracted by wind turbines and turbulence
-! (TKE) they produce at model levels within the rotor area. The thrust and
-! power coefficient curves included to calculate momentum sink and source of TKE are 
-! generic and an approximation to a real turbine. These coefficients should be
-! obtained from the turbine manufacturer for the turbines of interest and incorporated
-! into the code in subroutine dragcof (we could not include real curves since they
-! are proprietary).
+!
+!Represents kinetic energy extracted by wind turbines and turbulence
+! (TKE) they produce at model levels within the rotor area.
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! NOTICE
+!! The following paper should be cited whenever presenting results using this scheme
+!! (using either the original version or any modified versions of the scheme):
+!! Fitch, A. C. et al. 2012: Local and Mesoscale Impacts of Wind Farms as Parameterized in a
+!! Mesoscale NWP Model. Monthly Weather Review, doi:http://dx.doi.org/10.1175/MWR-D-11-00352.1
+!!
+!! Anna C. Fitch, National Center for Atmospheric Research (formerly University of Bergen)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! History of changes:
+!
+! WRFV3.5.1: 
+! WRFV3.6:   Modified by Pedro A. Jimenez to include:
+!             - Initialize the wind turbines in this module.
+!             - Introduce z_at_walls to avoid instabilities due to neglecting
+!                the perturbation of the geopotential height.
+!             - User friendly interface to introduce the technical characteritics of
+!                the wind turbines.
+!             - Only uses one set of turbine coefficients using the wind speed at hub height
+!             - Two standing coefficients.
+!             - Calculates the power produced by the wind turbines.
 !
 ! References:
+!
 ! Fitch, A. C. et al. 2012: Local and Mesoscale Impacts of Wind Farms as Parameterized in a
-! Mesoscale NWP Model. Monthly Weather Review, doi:10.1175/MWR-D-11-00352.1
-! Fitch, A. C. et al. 2012: Mesoscale Influences of Wind Farms Throughout a Diurnal Cycle.
-! Monthly Weather Review, submitted.
-!
-! Output:
-!   du, dv: horizontal velocity tendencies
-!   qke: TKE
-! Input: 
-!   u, v: horizontal velocities
-!   dz = dz between full levels (m)
-!   !not yet:  z_at_w = height above sea level at layer interfaces (m)
-!   !not yet:  ht = terrain height
-!   phb = geopotential height
-!   %hubheight = hub height (m)
-!   %diameter = turbine diameter (m)
-!   %stdthrcoef = standing thrust coeff. (thrust coeff of turbine when not operating)
-!   %power = turbine power (MW)
-!   %cutinspeed = cut-in speed (m/s)
-!   %cutoutspeed = cut-out speed (m/s)
-!   ewfx = x-extent of rectangular wind farm in grid cells
-!   ewfy = y-extent of rectangular wind farm in grid cells
-!   pwfx = x-coord of grid cell in SW corner of farm
-!   pwfy = y-coord of grid cell in SW corner of farm
-!   turbpercell = no. of turbines per grid cell
-
-  USE module_wind_generic
+!    Mesoscale NWP Model. Monthly Weather Review, doi:http://dx.doi.org/10.1175/MWR-D-11-00352.1
+! Fitch, A. C. et al. 2013: Mesoscale Influences of Wind Farms Throughout a Diurnal Cycle.
+!    Monthly Weather Review, doi:http://dx.doi.org/10.1175/MWR-D-12-00185.1
+! Fitch, A. C. et al. 2013: Parameterization of Wind Farms in Climate Models.
+!    Journal of Climate, doi:http://dx.doi.org/10.1175/JCLI-D-12-00376.1
+! Jimenez, P.A., J. Navarro, A.M. Palomares and J. Dudhia:  Mesoscale modeling of offshore wind turbines
+!    wakes at the wind farm resolving scale: a composite-based analysis with the WRF model over Horns Rev. 
+!    Wind Energy, (In Press.).
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
   USE module_driver_constants, ONLY : max_domains
   USE module_model_constants, ONLY :  piconst
-  USE module_model_constants, ONLY :  g
+!
+  USE module_llxy
+  USE module_dm, ONLY : wrf_dm_min_real
+  USE module_configure, ONLY : grid_config_rec_type
 
   IMPLICIT NONE
 
-  LOGICAL, DIMENSION(max_domains) :: inited
-
-  PUBLIC  turbine_drag
-  PRIVATE dragcof, turbine_area, inited
-
+  INTEGER, PARAMETER :: MAXVALS  = 100   
+  INTEGER, PARAMETER :: MAXVALS2 = 100     
+!
+  INTEGER           :: nt
+  INTEGER, DIMENSION(:), ALLOCATABLE :: NKIND
+  INTEGER, DIMENSION(:,:), ALLOCATABLE :: ival,jval
+  REAL, DIMENSION(:), ALLOCATABLE :: hubheight,diameter,stc,stc2,cutin,cutout,npower
+!
+  REAL :: turbws(maxvals,maxvals2),turbtc(maxvals,maxvals2),turbpw(maxvals,maxvals2)
+!
 CONTAINS
 
-  SUBROUTINE  turbine_drag(                      &
+  SUBROUTINE  dragforce(                      &
        & id                                      &
-       &,phb,u,v,xlat_u,xlong_u                  &
-       &,xlat_v,xlong_v                          &
+       &,z_at_w,u,v                 &
        &,dx,dz,dt,qke                            &
-       &,qke_adv,bl_mynn_tkeadvect               &
        &,du,dv                                   &
+       &,windfarm_opt,power                      &
        &,ids,ide,jds,jde,kds,kde                 &
        &,ims,ime,jms,jme,kms,kme                 &
        &,its,ite,jts,jte,kts,kte                 &
        &)  
-
-  INTEGER, INTENT(IN) :: id  ! grid id
+!
+!
+!
+  INTEGER, INTENT(IN) :: id,windfarm_opt 
   INTEGER, INTENT(IN) :: its,ite,jts,jte,kts,kte
   INTEGER, INTENT(IN) :: ims,ime,jms,jme,kms,kme
   INTEGER, INTENT(IN) :: ids,ide,jds,jde,kds,kde
-  LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect
   REAL, INTENT(IN) :: dx,dt
-  REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: dz,u,v,phb
-  REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN)         :: xlat_u, xlong_u
-  REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN)         :: xlat_v, xlong_v
-  REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: du,dv,qke,qke_adv
+  REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: dz,u,v,z_at_w
+  REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: du,dv,qke
+  REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: power
+!
 ! Local
-  TYPE(windturbine_specs), POINTER :: p
-  INTEGER  turbgridid
-  REAL     hubheight,diameter,power,cutinspeed,cutoutspeed,stdthrcoef,turbpercell
-  INTEGER  ewfx,ewfy,pwfx,pwfy
+!
   REAL     blade_l_point,blade_u_point,zheightl,zheightu,z1,z2,tarea
   REAL     speed,tkecof,powcof,thrcof,wfdensity
   INTEGER  itf,jtf,ktf
-  INTEGER  i,j,k,swfindx,ewfindx,swfindy,ewfindy,n,n1,n2,iturbine
+  INTEGER  i,j,k,n
   INTEGER  k_turbine_bot, k_turbine_top
 
   LOGICAL :: kfound
-  INTEGER :: allzero
+!
+! ... PAJ: more variables ...
+!
+  REAL :: speedhub,speed1,speed2
+  real :: power1,power2,area,ec
+  INTEGER :: kbot,ktop,kt
 
   itf=MIN0(ite,ide-1)
   jtf=MIN0(jte,jde-1)
   ktf=MIN0(kte,kde-1)
 
-!QKE should already == QKE_ADV coming out of PBL scheme
-!ACF copy qke_adv into qke if using advection
-!    IF (BL_MYNN_TKEADVECT) THEN
-!       qke=qke_adv
-!    ENDIF
-!ACF-end
-
-  CALL nl_get_td_turbpercell(1,turbpercell)
-  CALL nl_get_td_turbgridid(1,turbgridid)
-  IF ( .NOT. inited(id) ) THEN
-    IF ( windspec .EQ. WIND_TURBINES_FROMLIST ) THEN 
-! first check and see if xlat and xlong are all zero, if so, then use i,j directly
-! (just check the u variables)
-      allzero=1
-      DO j=jts,jtf
-        DO i=its,itf
-          IF (xlat_u(i,j).NE.0. .OR. xlong_u(i,j).NE.0.)allzero=0
-        ENDDO
-      ENDDO
-      CALL wrf_dm_bcast_integer(allzero,1)
-      IF ( allzero .NE. 1 ) THEN
-! if there are actual lats and lons available, find i and j based on lat and lon
-! otherwise, it is an idealized case and the user has specified i and j in the
-! turbines file read in by read_windturbines_in in module_wind_generic
-        DO iturbine = 1,nwindturbines   ! nwindturbines defined in module_wind_generic
-          p => windturbines(iturbine)
-          IF ( id .EQ. p%id ) THEN
-            DO j=jts,jtf
-              DO i=its,itf
-                IF (xlat_v(i,j) .LE. p%lat .AND. p%lat .LT. xlat_v(i,j+1) .AND. &
-                    xlong_u(i,j).LE. p%lon .AND. p%lon .LT. xlong_u(i+1,j)) THEN
-                  p%i=i
-                  p%j=j
-                ENDIF
-              ENDDO
-            ENDDO
-          ENDIF
-        ENDDO
-      ENDIF
-    ELSE IF ( windspec .EQ. WIND_TURBINES_IDEAL .AND. id .EQ. turbgridid ) THEN
-      CALL nl_get_td_ewfx(1,ewfx)
-      CALL nl_get_td_ewfy(1,ewfy)
-      CALL nl_get_td_pwfx(1,pwfx)
-      CALL nl_get_td_pwfy(1,pwfy)
-      CALL nl_get_td_hubheight(1,hubheight)
-      CALL nl_get_td_diameter(1,diameter)
-      CALL nl_get_td_power(1,power)
-      CALL nl_get_td_cutinspeed(1,cutinspeed)
-      CALL nl_get_td_cutoutspeed(1,cutoutspeed)
-      CALL nl_get_td_stdthrcoef(1,stdthrcoef)
-! count the turbines
-      n = 0
-      DO j = jts,jtf
-        IF ( pwfy .LE. j .AND. j .LE. (pwfy+ewfy-1) ) THEN
-          DO i = its,itf
-            IF ( pwfx .LE. i .AND. i .LE. (pwfx+ewfx-1) ) THEN
-              n = n + 1
-            ENDIF
-          ENDDO
-        ENDIF
-      ENDDO
-      nwindturbines = n
-      ALLOCATE(windturbines(nwindturbines))
-! set the turbines
-      n = 0
-      DO j = jts,jtf
-        IF ( pwfy .LE. j .AND. j .LE. (pwfy+ewfy-1) ) THEN
-          DO i = its,itf
-            IF ( pwfx .LE. i .AND. i .LE. (pwfx+ewfx-1) ) THEN
-              n = n + 1
-              IF ( n .GT. nwindturbines ) THEN
-                CALL wrf_error_fatal('would overrun windturbines array')
-              ENDIF
-              windturbines(n)%id = id
-              windturbines(n)%lat = 0.0
-              windturbines(n)%lon = 0.0
-              windturbines(n)%i = i
-              windturbines(n)%j = j
-              windturbines(n)%hubheight = hubheight
-              windturbines(n)%diameter = diameter
-              windturbines(n)%stdthrcoef = stdthrcoef
-              windturbines(n)%power = power
-              windturbines(n)%cutinspeed = cutinspeed
-              windturbines(n)%cutoutspeed = cutoutspeed
-            ENDIF
-          ENDDO
-        ENDIF
-      ENDDO
-    ENDIF
-    inited(id) = .TRUE.
-  ENDIF
-
-  IF ( windspec .EQ.  WIND_TURBINES_FROMLIST ) THEN
     wfdensity = 1.0/(dx*dx)   !  per turbine, so numerator is 1
-  ELSE
-    wfdensity = turbpercell/(dx*dx)
-  ENDIF
+    power=0.
 
-  IF (inited(id) .AND.                                              &
-      ((windspec .EQ. WIND_TURBINES_FROMLIST) .OR.       &
-       (windspec .EQ. WIND_TURBINES_IDEAL .AND. id .EQ. turbgridid ))) THEN
-    DO iturbine = 1,nwindturbines   ! nwindturbines defined in module_wind_generic
-      p => windturbines(iturbine)
-      IF ( id .EQ. p%id ) THEN
+    DO kt = 1,nt  
+      IF ( windfarm_opt .eq. 1 ) THEN
+!
 ! vertical layers cut by turbine blades
+!
         k_turbine_bot=0      !bottom level
         k_turbine_top=-1     !top level
-        i = p%i
-        j = p%j
-
+        i = ival(kt,id)
+        j = jval(kt,id)
+!
+         if (i.ne.-9999.and.j.ne.-9999) then
         IF (( its .LE. i .AND. i .LE. itf ) .AND. &
             ( jts .LE. j .AND. j .LE. jtf )  ) THEN
-
-          blade_l_point=p%hubheight-p%diameter/2. ! height of lower blade tip above ground (m)
-          blade_u_point=p%hubheight+p%diameter/2. ! height of upper blade tip above ground (m)
-
+!
+          blade_l_point=hubheight(kt)-diameter(kt)/2. ! height of lower blade tip above ground (m)
+          blade_u_point=hubheight(kt)+diameter(kt)/2. ! height of upper blade tip above ground (m)
+!
           kfound = .false.
           zheightl=0.0
           ! find vertical levels cut by turbine blades
@@ -227,47 +145,99 @@ SUBROUTINE  turbine_drag(                      &
             ENDIF
           ENDDO
           IF ( kfound ) THEN
+!
+! ... PAJ: Changes introduced to compute only one set of turbine coefficients ...
+!          First computes the wind speed at the hub height.
+!
+          kfound = .false.
+          zheightl=0.
+          ! find vertical levels (half levels) within the hub height
+          DO k=kts,ktf
+            IF(.NOT. kfound) THEN
+              z2 = zheightl + 0.5*dz(i,k,j) 
+!
+              IF(hubheight(kt) .GE. z2 ) THEN
+                kbot=k 
+              ELSE
+                ktop=k
+                kfound = .TRUE.
+              ENDIF
+!
+              if (.NOT. kfound) z1=z2
+              zheightl = z2 + 0.5*dz(i,k,j)
+            ENDIF
+          ENDDO
+!
+          speed1=0.
+          speed2=0.
+          if (ktop.eq.1) then
+           speedhub=sqrt(u(i,1,j)**2.+v(i,1,j)**2.)*hubheight(kt)/z1
+          else
+           speed1=sqrt(u(i,kbot,j)**2.+v(i,kbot,j)**2.)
+           speed2=sqrt(u(i,ktop,j)**2.+v(i,ktop,j)**2.)
+           speedhub=speed1+((speed2-speed1)/(z2-z1))*(hubheight(kt)-z1)
+          endif
+!
+! ... calculate TKE, power and thrust coeffs
+!
+              CALL dragcof(tkecof,powcof,thrcof,               &
+                           speedhub,cutin(kt),cutout(kt),   &
+                           npower(kt),diameter(kt),stc(kt),stc2(kt),nkind(kt))
+!
+! ... PAJ: Computation of power generated by the wind turbine ...
+!
+          area=piconst/4.*diameter(kt)**2.          ! area swept by turbine blades
+          power1=0.5*1.23*speedhub**3.*area*powcof
+          power(i,j)=power1+power(i,j)
+          power2=0.
+!
             DO k=k_turbine_bot,k_turbine_top ! loop over turbine blade levels
-
-              z1=phb(i,k,j)/g-blade_l_point-phb(i,1,j)/g  ! distance between k level and lower blade tip
-              z2=phb(i,k+1,j)/g-blade_l_point-phb(i,1,j)/g ! distance between k+1 level and lower blade tip
-
+              z1=z_at_w(i,k,j)-blade_l_point-z_at_w(i,1,j)  ! distance between k level and lower blade tip
+              z2=z_at_w(i,k+1,j)-blade_l_point-z_at_w(i,1,j) ! distance between k+1 level and lower blade tip
               IF(z1 .LT. 0.) z1=0.0 ! k level lower than lower blade tip
-              IF(z2 .GT. p%diameter) z2=p%diameter ! k+1 level higher than turbine upper blade tip
-
-              ! horizontal wind speed
+              IF(z2 .GT. diameter(kt)) z2=diameter(kt) ! k+1 level higher than turbine upper blade tip
+              CALL turbine_area(z1,z2,diameter(kt),wfdensity,tarea)
+!
               speed=sqrt(u(i,k,j)**2.+v(i,k,j)**2.)
-
-              ! calculate TKE, power and thrust coeffs
-              CALL dragcof(tkecof,powcof,thrcof,               &
-                           speed,p%cutinspeed,p%cutoutspeed,   &
-                           p%power,p%diameter,p%stdthrcoef)
-
-              CALL turbine_area(z1,z2,p%diameter,wfdensity,tarea)
-
+              power2=power2+0.5*powcof*1.23*(speed**3.)*tarea/wfdensity
+            ENDDO
+!
+! ... PAJ: Computes the tendencies of TKE and momentum ...
+!
+            DO k=k_turbine_bot,k_turbine_top ! loop over turbine blade levels
+              z1=z_at_w(i,k,j)-blade_l_point-z_at_w(i,1,j)  ! distance between k lev and lower blade tip
+              z2=z_at_w(i,k+1,j)-blade_l_point-z_at_w(i,1,j) !distance between k+1 lev and lower blade tip
+              IF(z1 .LT. 0.) z1=0.0 ! k level lower than lower blade tip
+              IF(z2 .GT. diameter(kt)) z2=diameter(kt) ! k+1 level higher than turbine upper blade tip
+!
+              CALL turbine_area(z1,z2,diameter(kt),wfdensity,tarea)
+!
+              speed=sqrt(u(i,k,j)**2.+v(i,k,j)**2.)
+!`
+! ... PAJ: normalization introduced to conserve energy ...
+!
+              if (power1.eq.0.or.power2.eq.0) then
+              ec=1.
+              else
+              ec=power1/power2
+              endif
+!
               ! output TKE
-              qke(i,k,j) = qke(i,k,j)+speed**3.*tarea*tkecof*dt/dz(i,k,j)
+              qke(i,k,j) = qke(i,k,j)+speed**3.*tarea*tkecof*dt/dz(i,k,j)*ec
               ! output u tendency
-              du(i,k,j) = du(i,k,j)-.5*u(i,k,j)*thrcof*speed*tarea/dz(i,k,j)
+              du(i,k,j) = du(i,k,j)-.5*u(i,k,j)*thrcof*speed*tarea/dz(i,k,j)*ec
               ! output v tendency
-              dv(i,k,j) = dv(i,k,j)-.5*v(i,k,j)*thrcof*speed*tarea/dz(i,k,j)
-
+              dv(i,k,j) = dv(i,k,j)-.5*v(i,k,j)*thrcof*speed*tarea/dz(i,k,j)*ec
             ENDDO
           ENDIF
         ENDIF
+        endif
       ENDIF
     ENDDO
-  ENDIF
-
-!ACF copy qke into qke_adv if using advection
-   IF (BL_MYNN_TKEADVECT) THEN
-      qke_adv=qke
-   ENDIF
-!ACF-end
 
-  END SUBROUTINE turbine_drag
+  END SUBROUTINE dragforce
 
-! calculates area of turbine between two vertical levels
+! This subroutine calculates area of turbine between two vertical levels
 ! Input variables : 
 !            z1 = distance between k level and lower blade tip
 !            z2 = distance between k+1 level and lower blade tip
@@ -302,69 +272,256 @@ SUBROUTINE turbine_area(z1,z2,tdiameter,wfdensity,tarea)
 
   END SUBROUTINE turbine_area
 
-! Caculates tke, power and thrust coefficients as function of horiz wind speed
-! from fit to turbine power curve - needs to be changed for particular turbine used
-
-! tkecof = tke coefficient
-! powcof = power coefficient
-! thrcof = thrust coefficient
-! cispeed = cut-in speed in m/s
-! cospeed = cut-out speed in m/s
-! tpower = turbine power in MW
-! speed = horiz wind speed in m/s
-! tdiameter = turbine diameter in m 
-! stdthrcoef = standing thrust coefficient
 
   SUBROUTINE dragcof(tkecof,powcof,thrcof,speed,cispeed,cospeed, &
-                     tpower,tdiameter,stdthrcoef)
+                     tpower,tdiameter,stdthrcoef,stdthrcoef2,nkind)
 
-!  DISCLAIMER: The following power curve, power coefficients, and thrust
-!  coefficients are meant for testing purposes only, and were formulated as 
-!  an approximation to a real curve.  The user is strongly encouraged to 
-!  incorporate their own curves for the particular turbine of interest 
-!  to them.
 
-  REAL, INTENT(IN):: speed, cispeed, cospeed, tpower,tdiameter,stdthrcoef
+  REAL, INTENT(IN):: speed, cispeed, cospeed, tpower,tdiameter,stdthrcoef,stdthrcoef2
   REAL, INTENT(OUT):: tkecof,powcof,thrcof
   REAL :: power,area,mspeed,hspeed
+!
+! ... PAJ ...
+!
+   INTEGER :: nkind,k,nu,nb
+   LOGICAL :: vfound
+   REAL :: fac1,fac2
 
   area=piconst/4.*tdiameter**2.          ! area swept by turbine blades
 
-  ! GENERIC POWER CURVE - USE AT YOUR OWN RISK
-  mspeed=0.5*(cospeed+cispeed)  !average of cispeed & cospeed
-  hspeed=0.5*(cospeed-mspeed)   !this regulates the transition to full power
-  power =tpower*(.5*tanh((speed - (mspeed-hspeed))/(hspeed*0.60)) + .5)*.8
-  
-  ! GENERIC power coefficient calculation - USE AT YOUR OWN RISK
+      vfound=.false.
+      DO k=1,maxvals2
+            IF(.NOT. vfound) THEN
+              IF(turbws(nkind,k).GT.speed) THEN
+                nu=k 
+                nb=k-1
+                vfound=.true.
+              ENDIF
+            ENDIF
+      ENDDO
+!
+  IF (speed .LE. cispeed) THEN
+     thrcof = stdthrcoef
+  ELSE
+    IF (speed .GE. cospeed) THEN
+     thrcof = stdthrcoef2
+     ELSE
+     thrcof = turbtc(nkind,nb)+(turbtc(nkind,nu)-turbtc(nkind,nb))/(turbws(nkind,nu)-turbws(nkind,nb))*(speed-turbws(nkind,nb))
+    ENDIF
+  ENDIF
+!
+! ... power coeficient ...
+!
   IF(speed .LE. cispeed .OR. speed .GE. cospeed) THEN
      power=0.
      powcof=0.
-  ELSE 
-     powcof = power * 2.e+6 / (speed**3.*area)
-     IF (speed .LT. cispeed*2.) THEN ! dampen artificial max near cispeed
-        powcof = powcof * exp(-((speed-cispeed*2.)**2./(cispeed*2.)))
-     end if
-     powcof = MIN(powcof,.55)
-  ENDIF
-
-  ! GENERIC Thrust coefficient calculation - USE AT YOUR OWN RISK
-  IF (speed .LE. cispeed .OR. speed .GE. cospeed) THEN
-     thrcof = stdthrcoef
   ELSE
-     !thrcof= stdthrcoef+2.3/speed**.8
-     thrcof = powcof + powcof*0.75
-     thrcof = MIN(thrcof,.9)
-     thrcof = MAX(thrcof,stdthrcoef)
+      fac1=1000./(0.5*1.23*turbws(nkind,nb)**3.*area)
+      fac2=1000./(0.5*1.23*turbws(nkind,nu)**3.*area)
+      power = turbpw(nkind,nb)+(turbpw(nkind,nu)-turbpw(nkind,nb))/(turbws(nkind,nu)-turbws(nkind,nb)) &
+                               *(speed-turbws(nkind,nb))
+      powcof = turbpw(nkind,nb)*fac1+(turbpw(nkind,nu)*fac2-turbpw(nkind,nb)*fac1)/(turbws(nkind,nu)-turbws(nkind,nb)) &
+                                     *(speed-turbws(nkind,nb))
   ENDIF
-
+!
   ! tke coefficient calculation 
+
   tkecof=thrcof-powcof
   IF(tkecof .LT. 0.) tkecof=0.
-
+!
   END SUBROUTINE dragcof
+!
+  SUBROUTINE init_module_wind_fitch(id,config_flags,xlong,xlat,windfarm_initialized,&
+                                            ims,ime,jms,jme,its,ite,jts,jte,ids,ide,jds,jde)
+!
+  IMPLICIT NONE
+!
+   integer ims,ime,jms,jme,ids,ide,jds,jde
+   integer its,ite,jts,jte
+   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: xlong,xlat
+   TYPE (grid_config_rec_type) :: config_flags
+   TYPE (PROJ_INFO) :: ts_proj
+   logical :: windfarm_initialized
+! 
+   CHARACTER*256 num,input,message_wind
+   real lat,lon,ts_rx,ts_ry
+   REAL :: known_lat, known_lon
+   INTEGER i,j,nval,k,id
+
+   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
+!
+      IF ( wrf_dm_on_monitor() ) THEN
+!
+! ... PAJ: Opens the file with the location of the wind turbines ...
+!
+        if ( config_flags%windfarm_ij .eq. 1 ) then
+          open(70,file='windturbines-ij.txt',form='formatted',status='old')
+        else
+          open(70,file='windturbines.txt',form='formatted',status='old')
+        end if
+!
+! ... PAJ: Counts the turbines ...
+!
+       nt=0
+ 10    read(70,*,end=100) 
+       nt=nt+1
+       goto 10
+!
+ 100   continue
+       rewind (70)
+     END IF
+!
+     CALL wrf_dm_bcast_integer(nt,1)
+!
+! ... PAJ: Initializes the configuration of the wind farm(s) ...
+!
+     if (.not. windfarm_initialized) then
+       allocate (nkind(nt),ival(nt,max_domains),jval(nt,max_domains))
+       allocate (hubheight(nt),stc(nt),stc2(nt),cutin(nt),cutout(nt),diameter(nt),npower(nt))
+       ival=-9999
+       jval=-9999
+       windfarm_initialized=.true.
+     endif
+!
+     IF ( wrf_dm_on_monitor() ) THEN
+     do k=1,nt
+       if ( config_flags%windfarm_ij .eq. 1 ) then
+         read(70,*) ival(k,id), jval(k,id), nkind(k)
+         write(message_wind,*)'WINDFARM Turbine #',k,': I, J = ',ival(k,id), jval(k,id),'; Type = ',nkind(k)
+         CALL wrf_message(message_wind)
+
+       else
+
+         read(70,*)lat,lon,nkind(k)
+         write(message_wind,*)'WINDFARM Turbine #',k,': Lat, lon = ',lat,lon,'; Type = ',nkind(k)
+         CALL wrf_message(message_wind)
+
+         CALL map_init(ts_proj)
+
+         known_lat = xlat(its,jts)
+         known_lon = xlong(its,jts)
+
+      ! Mercator
+      IF (config_flags%map_proj == PROJ_MERC) THEN
+         CALL map_set(PROJ_MERC, ts_proj,               &
+                      truelat1 = config_flags%truelat1, &
+                      lat1     = known_lat,             &
+                      lon1     = known_lon,             &
+                      knowni   = REAL(its),             &
+                      knownj   = REAL(jts),             &
+                      dx       = config_flags%dx)
+
+      ! Lambert conformal
+      ELSE IF (config_flags%map_proj == PROJ_LC) THEN
+         CALL map_set(PROJ_LC, ts_proj,                  &
+                      truelat1 = config_flags%truelat1,  &
+                      truelat2 = config_flags%truelat2,  &
+                      stdlon   = config_flags%stand_lon, &
+                      lat1     = known_lat,              &
+                      lon1     = known_lon,              &
+                      knowni   = REAL(its),              &
+                      knownj   = REAL(jts),              &
+                      dx       = config_flags%dx)
+!      ! Polar stereographic
+      ELSE IF (config_flags%map_proj == PROJ_PS) THEN
+         CALL map_set(PROJ_PS, ts_proj,                  &
+                      truelat1 = config_flags%truelat1,  &
+                      stdlon   = config_flags%stand_lon, &
+                      lat1     = known_lat,              &
+                      lon1     = known_lon,              &
+                      knowni   = REAL(its),              &
+                      knownj   = REAL(jts),              &
+                      dx       = config_flags%dx)
+!#if (EM_CORE == 1)
+!      ! Cassini (global ARW)
+!      ELSE IF (config_flags%map_proj == PROJ_CASSINI) THEN
+!         CALL map_set(PROJ_CASSINI, ts_proj,                            &
+!                      latinc   = grid%dy*360.0/(2.0*EARTH_RADIUS_M*PI), &
+!                      loninc   = grid%dx*360.0/(2.0*EARTH_RADIUS_M*PI), &
+!                      lat1     = known_lat,                             &
+!                      lon1     = known_lon,                             &
+!                      lat0     = config_flags%pole_lat,                 &
+!                      lon0     = config_flags%pole_lon,                 &
+!                      knowni   = 1.,                                    &
+!                      knownj   = 1.,                                    &
+!                      stdlon   = config_flags%stand_lon)
+!#endif
+!
+!      ! Rotated latitude-longitude
+!      ELSE IF (config_flags%map_proj == PROJ_ROTLL) THEN
+!         CALL map_set(PROJ_ROTLL, ts_proj,                      &
+!! I have no idea how this should work for NMM nested domains
+!                      ixdim    = grid%e_we-1,                   &
+!                      jydim    = grid%e_sn-1,                   &
+!                      phi      = real(grid%e_sn-2)*grid%dy/2.0, &
+!                      lambda   = real(grid%e_we-2)*grid%dx,     &
+!                      lat1     = config_flags%cen_lat,          &
+!                      lon1     = config_flags%cen_lon,          &
+!                      latinc   = grid%dy,                       &
+!                      loninc   = grid%dx,                       &
+!                      stagger  = HH)
+!
+      END IF
+!
+         CALL latlon_to_ij(ts_proj, lat, lon, ts_rx, ts_ry)
+!
+          ival(k,id)=nint(ts_rx)
+          jval(k,id)=nint(ts_ry)
+          if (ival(k,id).lt.ids.and.ival(k,id).gt.ide) then
+            ival(k,id)=-9999
+            jval(k,id)=-9999
+          endif
+!
+!         write(73,*) k,id,ival(k,id),jval(k,id)
+          write(message_wind,*)'WINDFARM Turbine #',k,': Lat, lon = ',lat,lon, &
+                               ', (i,j) = (',ival(k,id),',',jval(k,id),'); Type = ',nkind(k)
+          CALL wrf_debug(0,message_wind)
+!
+     end if
+!
+     enddo
+      close(70)
+!
+! ... PAJ: Read the tables with the turbine's characteristics ...
+!
+         turbws=0.
+         turbtc=0.
+         turbpw=0.
+         DO i=1,nt
+          write(num,*) nkind(i)
+          num=adjustl(num)
+          input="wind-turbine-"//trim(num)//".tbl"
+          OPEN(file=TRIM(input),unit=19,FORM='FORMATTED',STATUS='OLD')
+          READ (19,*,ERR=132)nval
+          READ(19,*,ERR=132)hubheight(i),diameter(i),stc(i),npower(i)
+            DO k=1,nval
+              READ(19,*,ERR=132)turbws(nkind(i),k),turbtc(nkind(i),k),turbpw(nkind(i),k)
+            ENDDO
+          cutin(i)  = turbws(nkind(i),1)
+          cutout(i) = turbws(nkind(i),nval)
+          stc2(i) = turbtc(nkind(i),nval)
+          close (19)
+         ENDDO
+
+ 132   continue
+!
+! ... ...
+!
+      endif
+
+        CALL wrf_dm_bcast_integer(ival,nt*max_domains)
+        CALL wrf_dm_bcast_integer(jval,nt*max_domains)
+        CALL wrf_dm_bcast_real(hubheight,nt)
+        CALL wrf_dm_bcast_real(diameter,nt)
+        CALL wrf_dm_bcast_real(stc,nt)
+        CALL wrf_dm_bcast_real(npower,nt)
+        CALL wrf_dm_bcast_real(cutin,nt)
+        CALL wrf_dm_bcast_real(cutout,nt)
+        CALL wrf_dm_bcast_integer(nkind,nt) 
+        CALL wrf_dm_bcast_real(turbws,maxvals*maxvals2) 
+        CALL wrf_dm_bcast_real(turbtc,maxvals*maxvals2) 
+        CALL wrf_dm_bcast_real(turbpw,maxvals*maxvals2) 
 
-  SUBROUTINE init_module_wind_fitch
-    inited = .FALSE.
   END SUBROUTINE init_module_wind_fitch
   
 END MODULE module_wind_fitch
diff --git a/wrfv2_fire/phys/module_wind_generic.F b/wrfv2_fire/phys/module_wind_generic.F
deleted file mode 100644
index 4be3f01e..00000000
--- a/wrfv2_fire/phys/module_wind_generic.F
+++ /dev/null
@@ -1,140 +0,0 @@
-MODULE module_wind_generic
-
-  IMPLICIT NONE
-
-  TYPE windturbine_specs
-     INTEGER id             ! grid id
-     REAL    lat, lon       ! lat/lon of the individual turbine
-     REAL    i, j           ! x and y coords of turbines (set by packages themselves)
-     REAL    hubheight      ! hieght of the turbine hub
-     REAL    diameter       ! diameter of the rotor
-     REAL    stdthrcoef     ! standing thrust coefficient
-     REAL    power          ! turbine power in MW
-     REAL    cutinspeed     ! cut-in speed
-     REAL    cutoutspeed    ! cut-out speed
-  END TYPE windturbine_specs
-
-  TYPE(windturbine_specs), TARGET, ALLOCATABLE, DIMENSION(:) :: windturbines
-  INTEGER :: nwindturbines
-
-  INTEGER, PARAMETER :: WIND_TURBINES_OFF      = 0
-  INTEGER, PARAMETER :: WIND_TURBINES_IDEAL    = 1
-  INTEGER, PARAMETER :: WIND_TURBINES_FROMLIST = 2
-
-  INTEGER windspec
-
-  LOGICAL , EXTERNAL      :: wrf_dm_on_monitor
-
-CONTAINS
-
-  SUBROUTINE read_windturbines_in
-! Check the namelist variable nl_get_windturbines_spec.  If it is set to none,
-! which is the default value, then do nothing.  If it is set to ideal, then
-! a wind scheme is active but no extra information beyond what is in the namelist
-! is needed.  If it is set to the name of a file, read the file to get position
-! and characteristics of each turbine and store that in a datastructure here 
-! (the array turbinespec) that the parameterizations can refer to when initializing
-! themselves.
-
-    IMPLICIT NONE
-! Local
-    CHARACTER*256  fname, message
-    CHARACTER*512 inline
-    INTEGER i,istat
-    INTEGER id
-    INTEGER n,lineno,ig,jg
-    REAL  lat,lon,hubheight,diameter,stdthrcoef,power,cutinspeed,cutoutspeed
-!
-    CALL nl_get_windturbines_spec( 1, fname )
-    windspec = WIND_TURBINES_OFF
-    IF ( TRIM(fname) .EQ. "none" ) THEN
-      RETURN
-    ELSE IF ( TRIM(fname) .EQ. "ideal" ) THEN
-     ! get the turbine specs from the namelist and initialize in 
-     ! the specific turbine parameterization
-      windspec = WIND_TURBINES_IDEAL
-    ELSE
-      !info is contained in a file named by fname
-      !read in and distributed between processors here (if dmpar or dm+sm) but
-      !the parameterizations themselves must initialize themselves
-      IF ( wrf_dm_on_monitor() ) THEN
-        OPEN(file=TRIM(fname),unit=19,FORM='FORMATTED',STATUS='OLD',IOSTAT=istat)
-        IF ( istat .EQ. 0 ) THEN
-          ! first time count things up
-          n = 0
-          DO WHILE (.true.)
-            READ(19,'(A256)',END=30)inline
-            IF ( index(inline,'!') .EQ. 0 ) n = n + 1
-          ENDDO
- 30       CONTINUE
-          nwindturbines = n
-          IF ( .NOT. ALLOCATED(windturbines) ) ALLOCATE(windturbines(nwindturbines))
-          REWIND(19)
-          i = 1 
-          lineno = 0
-          DO WHILE (.true.)
-            lineno = lineno + 1
-            READ(19,'(A256)',END=120)inline
-            IF ( i .LE. nwindturbines .AND. index(inline,'!') .EQ. 0 ) THEN
-              READ(inline,*,ERR=130)id,lat,lon,hubheight,diameter,stdthrcoef,power,cutinspeed,cutoutspeed
-              windturbines(i)%id = id
-              windturbines(i)%lat = lat
-              windturbines(i)%lon = lon
-              windturbines(i)%i = -999   ! set to invalid
-              windturbines(i)%j = -999   ! set to invalid
-              windturbines(i)%hubheight = hubheight
-              windturbines(i)%diameter = diameter
-              windturbines(i)%stdthrcoef = stdthrcoef
-              windturbines(i)%power = power
-              windturbines(i)%cutinspeed = cutinspeed
-              windturbines(i)%cutoutspeed = cutoutspeed
-              i = i + 1
-            ENDIF
-          ENDDO
- 120      CONTINUE
-          CLOSE(19)
-          GOTO 150
- 130      CONTINUE
-          CLOSE(19)   ! in case of error, close the unit
-          istat = 150150
-          GOTO 150
-        ENDIF
-      ENDIF
- 150  CONTINUE
-      CALL wrf_dm_bcast_integer(istat,1) 
-      IF ( istat .NE. 0 ) THEN
-        WRITE(message,*)'Unable to open or read ',TRIM(fname),'. Proceeding without wind-turbine parameterization.'
-        CALL wrf_message(message)
-        IF ( istat .EQ. 150150 ) THEN
-          WRITE(message,*)'Perhaps bad syntax at line ',lineno,' of ',TRIM(fname)
-          CALL wrf_message(message)
-        ENDIF
-        IF ( ALLOCATED(windturbines) ) DEALLOCATE(windturbines)
-        RETURN
-      ENDIF
-      CALL wrf_dm_bcast_integer(nwindturbines,1) 
-      IF ( .NOT. wrf_dm_on_monitor() ) THEN
-        IF ( .NOT. ALLOCATED(windturbines) ) ALLOCATE(windturbines(nwindturbines))
-      ENDIF
-      DO i = 1, nwindturbines 
-        CALL wrf_dm_bcast_integer(windturbines(i)%id,1) 
-        CALL wrf_dm_bcast_real(windturbines(i)%lat,1) 
-        CALL wrf_dm_bcast_real(windturbines(i)%lon,1) 
-        CALL wrf_dm_bcast_real(windturbines(i)%hubheight,1) 
-        CALL wrf_dm_bcast_real(windturbines(i)%diameter,1) 
-        CALL wrf_dm_bcast_real(windturbines(i)%stdthrcoef,1) 
-        CALL wrf_dm_bcast_real(windturbines(i)%power,1) 
-        CALL wrf_dm_bcast_real(windturbines(i)%cutinspeed,1) 
-        CALL wrf_dm_bcast_real(windturbines(i)%cutoutspeed,1) 
-      ENDDO
-      windspec = WIND_TURBINES_FROMLIST
-      RETURN
-    ENDIF
-  END SUBROUTINE read_windturbines_in
-
-  SUBROUTINE init_module_wind_generic
-    IMPLICIT NONE
-    CALL read_windturbines_in 
-  END SUBROUTINE init_module_wind_generic
-
-END MODULE module_wind_generic
diff --git a/wrfv2_fire/run/CCN_ACTIVATE.BIN b/wrfv2_fire/run/CCN_ACTIVATE.BIN
new file mode 100644
index 0000000000000000000000000000000000000000..9026e073ef0e701939c75ca4a22390a77425b3a5
GIT binary patch
literal 35288
zcmbuIUC3_NRfUfVf`6cbw4soT7L~RTQ(8Rf`T5=^HneIK#8jn8qY2oA#wJKf#iq%j
z_DGGrP}&Py6e$%5+b%r+
z=|8{x)z_T6{E>J3*X7s0@a0QSUjOP#w>^LJ#h2f8k!#LA@R5H$`+>**=<;7a`m>ks
z{Hr%!{{BzA&exp%$E)6V_6Ik-|Li9|`+_IqRA%=z~({%zrY&-L#B_k~B#zc=Q*$BnM3IZxd1oWOO2o5QuAd5h;f
zb91=k?ROP7&-~p@XTN*XOS}jE4j=mZcOTyOZ@<0A&Ed+It_yA+xZxM#8I7A2`^3!~
zKYl)9?sz_O*OiOkb^mvO`@#)h__K()xjFy2@45KQFTQwDxVffc4mbbv#Oq2oy2de&
zcz*K1*M@FVTSLr$=uIzN{>Q)nLu;#Wp&P~Q?2eE9j^A@IE_CyKum7zxb0cjXuH5o)
zaD#4s=3hT^5U#_w-Sq@9Sg=2R>!6#P{`)>+5HSZ=)B1%6zjo_|Z$1BeJs(2raMSa_
zxOzV5n$Rh@G9Q8)w59iimW|8#ko<*~J1*yg-V<6*T$K-KOYhm>A|Jkd`;)8YGv@a{
z{-1};2Vy|H3RjEyTmSU#rz+2?yf{NgQ#U;T@3>9`{A^qwWp|K<&cU%&RI!#%J4`r(~Fdd_|l{*`l%
zJkOX1cI$oeKy)#CfjtmikjKY-@~9U`7vGc@G@m@`1>)~;<;lAa5BqHJ`N?M-8WrG3O)PRNl549(5kia^7}s&@Y}veV(~V&p%vAuckhCZsg}HK6#qC
zLEmr}wcogThH5r=o^u
z-w}QUH}p5jU-T~4?z?~GQuQ~wX2F-Z@HF}WYJ&Qk5j)(-7pa%xW{9WieDyfJhEIJP
z+zc_#zRmtH)Nt1+u2FwjxLm^w=y(bvncxFA#r24aZO1zsOI98t$A)&#Au6o<_{^J^Gi29=P4{
zDnH4-H}F0D(&wwcp@zes^tWPv?5Xg3`r^!)-oI4Lv#+f=w|+jZ!3T+#eX{F9{B69T
z=^}KPJ=frqc-HI%^gyYL^6DL3EMAbkdiMhPu
z()5dAp2UYbN8VG%@GSC@I;A-T7ia)KvzNFB6^_t}cqnbQ9*P(6`o?h*IfWJ-uB3$$VS;M#3)!%1-6IyP4
zbM2%6J=n9hh8K{__+0L74Y<%VH9U1QctQ5_;rG%_t;5l(b-{bY
zP3Yb60+;K&Vz78Y)^Ov>HSHSP(F;O<8|>)?dQag(&-Aq&JMjXSb>SL79ka)|PN9qB
z=FoA`zusjp=19o(gUW#8ZPkIe-
z%Flueure3s0JrEnz24)|UwV&-S_nq*#CUj#`(~ce#+MkaIR_WvhkE}SKlGV6G{2<=
zShM~u92vXuK97Itx~QoGc8@)GW6YCz;peV%i97D=dql)nx-9JWS-3HG%Gr1(d#c38
z+?c!YGv1FM<(h&%gYf}-<3{6azOQrl+6F(~$Nu!KXmfu|&p{XNFRks4-MT}UszKl?
z>}{b%mdy?-F&4IoS)cH;Fk!PfJXi-q9@F3^_gNf;ntrn>8GMH)FhGS!b^NDW0?G
z>%f-19e%Ql9nX;;<41~b_zimj)NOvG)95dmqvjWR?{UVwZshsAA75a+^qKo4^dTOv
zG3J+Z#V`B6?U?ST4l(y#e5zy77x-P{@8A>NY2F*`%#*yOKGQ$o#m3H<
z*A(ayZrb=V7sZD<26u^#``3BGjr7m`N3kofsRKNJ4
z-Mi0!C(RV@Iqu{lHDpH@wGM~d4fgbE{2pC3T`Y4+uZA1A%kgoZdIq}j{hn|AmS5qC
zr?8*wZN#r~?I?EiOg`;lXWr!U4mZ(P_?&^cHEtGsxellP!rd-*yi?zGInZ>Vo>q+{F!ZSTUfB>`lzw
z2A^^UFW#;1U>CpWc5~m#ozMDWuZlfNtxtUxANv}tO}(~n=j@v^MXiBjpObw|#j*ND
zuM=4Rv#*H8%_nu8^te4H*vq3=Il@it
zYv5m<8}YZqHtR~~hFmM$6E}KBoxQd*8Gm=;{rT9_VDH`6j9IUb?9IOb7uL$8(l9)YXJ+~@Fo
zU*MQGt;ZR=u8Ej~t7+YPKAU`CFDuVF2VBkv-a|f6&s=xN2k!}K9TB;0T;zlLt2G~1
zEe9^IGpdiw9u|Mdd>{tSbM|HZ?Z7wutx@K1>|2{Z&M8yNd%B34VO*>Yoiox!)HC7*
zF4hQ57q!P}T+SKR0bU-tmiw>8y+7IO-L>gmq!RP)>waoyYe7d{4!cex&On)-qWy-H)V~hW>Id
zs(dZKDT!}R(o4Kw<#QLfu$RObo8KI{WOLx8i0uAK;jM
zedC(*A!@j^%(~7oC-?Op@^-<#Xt~x{>rLGEF8H*zaZl@<*=Sz5Nfqhbb9yPpswSBVs
zm#pFFf*NjJRNN;okS<(XOYbi)-;~t1MyYrAWzpAC$M)(J{0V#H@vL{WLk(~q@AWUP
zzs80CC&xn#H!kX-IF7ixhWnh7_YC_zlP=^JHBWIHxler2zi`+~qE1QQQ4gfsz+f+N
z531Y`-z2B$z55){L5|PgO++6HhN@%KB5Bip&U#Gx8}l~z-xXul3gcMTGI0^}thl?z
zEx+m8LYt1EVr<-jJ=X(~bL1o%NN&6ysQ%pCk<+XxIycm@ktG_4_LHS>kjG^YnLAPUVrKB;07<(HPO$b)zn3B!#LP8URCGG
z8P45Zs8Z=-}
zToJR0o5IDs@wvv$W}VV&K(D{n1=^yo^E%vmw=VRK1z+~8);s;*P{-V}s?M+vN^iHp
zjxO@sMYzS&hz)(3a751{4=B%qd*;{1!%LV0@c{!o(c^|^c@D}sdaR5c#NgWG{jjR^0jf_9NXh*WvHl__j8#_r`sA30`en9lQ64&?UHh4e#?hlDvhx#?6qo
zaKl;_edzvWo{byc!Tl9m&o5&vU5{SpaXmxv+plrUHF)(gUZSrcX7pHKZn%RN`)tHnF4@de7bX$pA5GC@Y$6FZVne6}2U%>(6eJtLoIdZ?prJ->y%1PEdJfC-N<|$9y
z?O#&Y)OTw1=03(Bdurb&mV0B28bo}J4g6qWo_Gm!>)bFF^TdzjX`Z|9?-nUc-&!3imaZv7z_${qq=q20QQH8{_Zb_1GAFy>rpI?%%|nTqU3O
zbm86v?q+Uct)!UYS2K4t7kM?@bna>l?DBhKJEnQ=KNVZ@X?SLG8h@wfcfA_7yrD2F~(KLeE()FF`mS(-lk)ku~WnQ
zy!$wuqYJp3ukpDM+>on%JmyLLl`dv(1`P6e{Kni3V_*}%zJD{8+?>RI?=`VMnR^by
znd1C?L9Wf?8veZrdO2z~dlEjk$@P8Ibk+d5zGXcX*RX!KchNJ^@6lJ$GqQdsj%W=X
z6BBxie9!XlvFF(Yd5qo^3)Y{diFW2fE^YTQvo?t{_SqSa{YUmJICpq?J%^7u_r3Ra
z-WqdO9}{~PKD)^CjXvk#hHsGbn(7734gFy9S8HyxGI3LD`nm`U&H|iteJ+bypTlE1>`
zd@z5x&lhWmo)7RxKA>e{4leS6wI97U`9QpktLH;#p8j5amSgUG(7r@rkNq$`1COF^
z>OHX^-($Y_y$ySG&WHT=!aCi{nacAi=CRM$akZGU&sp`3Joi3OUbFe$rsYh1e@1`p
zejs(RV3#j?Zyf*2+7f$@#zoBAw-<%0<#~N;)bt+wwQF|00RA|m?RvK^@Pd9;XI$xl
z_~ie|3zSz2_S^%SbP;=#*1PiDdXN9Ek^R5xBCo0aO}qeH?V7>=t#`as*Tg=>tarU9
zya25_kF9sKqnrq>x({mpA7@#PY36a&ncC;e{@c1BujGT_S@4hFXr2*6xZu2z^)2(n
zi;1((q@)ng-eDap_M(e8QrD7Nu=nI$wo&{FszJ-6^kT%b*C})(Zpvrj#`>ln>KS`}WPeyN2vt9A_SxRQBsW9-buGj9@N#J_aP^$Y
zbDOB)&U5=Y9P1g;(^A9jY4{0V5H-AcwQ*(6EZDuzmo?n{4cM~}V9!JE={;BU>iC?n
z$9EUjvb}(wHMyyt%RWh+B4@-+d4YR%u7N-5nCtKClYDQ(oc4TD>xRfR(*v$@S!>dhxDz_yc>cQwF`mF*Ur`
zU+W$1NEg-5TNlkQ7JR9T?xn-p*Sg3$Ll0^G_58r8oW;{(p6Ml#+v47Jkn!>?xTW5L
z6Yb+??8h(%#}H4;@#UON>(^fExF4^p7@^Jeyl|{>c$WHi{9Nyd+EMq}&-kr1D)ZbO
zd+tW!S)N6G&e(uEu)`bN;73`X{tOYExg)wiKndP}g&
zv!Xw9KA=}}Kl46#am@SoHp$HpbNE9ya7S89!3~=5{(^G`zk)mZI@j=?
zGs%tTRJAT^!rIp{@2uhWlZ}_VhUcEzF7`!RvF=Ep?J*DRXcfJqSNeUpnZ3a4Y;yzl
zzNSDIjho@D&io}e{rm6mN!NtR>E;F2#o*;|(|nQ`Y_O+Ks_z~8m!|i??p~Z+rq(6y
z(0ta`&~y4&c|qoJ)OmE_8h{UaodPcR{K-w#aB!JFawht^RjY%SZhCffp*lmaz%w@3
z(M8r7=74sIFLPj?>_O5`;920{{lun?*EeqDEj*yx9ADm-+9W3#PafB~Fo*P`tR?Fh
zIQ4_4aqls|#;c?6$?GSa%i8eB7$Wc#p4hl4KSDS7
z71)xS1$+7t&w#reUwHvTazlNuzO`f1GpHHTtpW)Q=j23$Cr1v{*(EkJ8`qlD?JTvj>es5Xq~?CI%C%}=&z1qm*-ip
z#-1^cJfi2KH$kr+H+HWnlxIGquBMm4SF=LhCAX;{UsMCy~mjQGIFNrJ;wSvW#VS2zdWOHv&^&g
ztY}Mf*!o%Og1ByKTxy;gaZ>Z*hWHU*aPotOc%CrFx{>=m?lI-bGEeD_`H>skOAKm^
zIml1ApK#PwyvY7|6C>u2-yVxCKFPE9VvFZ6r@b-$PI`~}FI^4Td6(iDJp!@m
z*gfX|MzZJLdGq_2dmrCmkeB=Un=!c4IM|P2pszjU<)_BLgqIsTvEhe#5PNbGZs+mP
znPQ61x-U2O!XTez4etKTb4L?q=+PFMW0%FYL-mxS6@DIVi8G&waech`D~?j&Wi%kMU=)Grl**-;vM9#^`IU
z=RNFr3Hh{#otWXXd*ksw=@s3~+|*o@>-2S9cQuyS;m+gp7=PyZr{exfUgwz4*oi;)
z8uvU-OyCCYe2p~|-`gnH_qZtx%9)v)8UwrPSRWt8k{h0XDyRQH*wKt}&De0s7
z`m1#cUNq~XFeqo7bACsSflWCBHgb~jVT^J43EVTj8B1j{e}MHr`GD3u{dk`;p`?u|mgah@O*v
zTF>td}?o=y?6c{
z==}Dg=B&M#;ToM?R6Nnm#9ysl%#F3hUKcTUJn0wVCinOw=HxH6f?nI}2wfANPY$^z
z(ofQp>Y4=~bw|1(577-dI`mSF8+s0L!yZh;JmVSXQTgq~(R|>1+PE^F?DIrEh`-P&
zeX_OAHOXJ$az3Cf=Y#v4y?j8+#zj8RYv=lM>F@Kb&iUZpwBnv?V()dyr((|1Y5Y6B
zE#~pxpKo)HZwssoynubIoOAJ~^C-@*BVL)q#b0vleV9$ou%AV(CSKs0awhf*GG4KM
z%9zL6$$S2IpL-$r(>04GSQD!zd(Q!F={=$4oO8rnxHylB|9?)`vUK5ZtTtZYn9p9o
z{^g{L!3(-B@Pe*)>msiyFQBeWx_D(T$hD8XAboPsJ9*x}HDb@%xQO}7`RyHN^FD{$
z@rzjZbzL;Sh?tVc_`kgrj@jR3PUNxu-+3j!7{0f$m*N+?refN35q=@0|J+{>E)-vTNuOt(wNh8p&r84T<${4dROWzZfmL}K&%n=O
zeZ(HB`ZfGKa{!)KzgADw&NpJuxN@30mup}>gEQmxzO4Ci?bZ1IDwJpC8GGo!-<(W2
z7u@)p6Xv|b4cvLogErBD^graSYdG&Aev!B8nPzS(ewnwO8`jzbcE#A-Y-(KNM!ry9
z?A%sA5ZcDi*pujc>?td)|hg^Sg@hvz`z3e1CJ&V{Xq%ZmMtdxeom0
znN_T<>}mFM_!Bn~uU^B=pSW4HocRDQ@*(@f6?@AEa-a7M*xR0vv{iM=euP(3>-grR
z$K1L|Zd_Z3oZ%Vtb*{fHXW~70xofy%Zr>xPUBg}L?C0X9dRlsXds^nqiZA=No-+e>
z^*5|D$QkiB*I$2AviaV|o)0(pV8d1YA2nRuRQOEynM#xypq>e{p~)9cBH>L
zx9_-87Ylalz4_#34b*g@yb5ntJce54p4M8n-oKIWZSYp&)%8xUztZ%x99#9g{z{Rw~Q&-2V06umhyMxV)l__^wF=oTI{-p|LQj^PdD
zG+vIbn1elwcjWjo&o&4A7Vn4}XFo!l>ch~cVi#U8VBk9Wxwwim{mmHTS8tAa?vCl3
z6V0>gRMwz4LpSzZ4@3-AgCch1J=o!`a|3tuxM24>(teKL)61Z1*5&xDx#1ajp6(y=
z*74E0gnF}%fh)ODkGig9%$tAf-}&4<)5vknzdS2zP<(qq4iIccQhBbDs$%6mFo_<8{O@AY9nB$0D>k@y@#F}ptTh{5S3FvM!me@63
zeOuO`0ekb==s(eeHIXron00Qz-quRdJK~FQLr#+qUQ^^Ag>|*ev*F5`Fk(+!&i##_
zfh|4l=(!BFPT28T#U#8s<8A!ak2;qVcWA;rF}cb!tQ+#d`wQd@y|=mX_cqjU=Zv&v
z-K;%ruEWV0J%jNze%YHiXL!dDTjBEe#Pk8fnDb%LmizgrK^?p5QF(#%ICE3|eAb{C
zPhC{~MUUh%+}H=Z7kEvU+zjXT=oMX%Gqpd#+|h-++Wb-D2Yl!veUcaqW5&Mpy|w?6
z{d~k+xT(d%I)(b&xQRUo_hqgD#_qipVu~*4+j2cy>lE*;po`Q^Y1OrkyrPbYn+1bw
zxOCyX!jlGkO&9b)!x-3`E|>#(O&x`Q=D}R)rI-Ua7$;}jc&(XvKJz2~IljCva}Ms?
z_&OJIPVwRXT$8S2j*nuTe!CshHJTgq-5nF=WqssljlYR`>@ib=n76Sd{@5d;M$OZ|>A**k{4(A8S5)@2+R(MAdNlRdCmIG1PFqKXN|Dm$~S@)H=9nx*F%1`>x6D
zIL7?-40N+w-xJ@d`VM!_b>q&MN51pk^w~id#NBI(tU-M|wCWl@akF5^8qPDccVli=
zeCgHHu^eB=95;D2+S~ZN$MuY(HI8ePQ})?C?A|}?dQWcRx#(hto7y)aXW#}OB<{Mm
z_LRI{rC%rKG``}?zLz@2_+H+UGw^#f?#h{?H4f~m@#Jd9o!BDoz5e!Vh`ZM*e%DSD=kr5~-lFz?g_+-z!`<1THT)O>P-ClF(>(j$6L
zfSwrcJnk{&$ubu`A6=0f+{=A6#vBws-_N}pUlRA!xYXB(Pxs^V$=_xS4+9(8+w(K{
zKibpkUi=eX8n>~F>)?|;KgPk%7(a|zXRgm42cO4cKJqKDd3=+b;?ConF}TzHyr1Xp
z;lnGb6MJL)-Kn^P8Qx~>jxRaMv*+=cr(y;-j2j#G!HwsFmlHRS_c5+PSDjnm=iiKT
zKkxV7_1~_M{qOoepYl31!MtW{#(8VxXTC8Z0BZ}r+SY*K8z(d
zyr28`#`wEaaVK_;w|^TOzwzi}*va){ITPnX;uYP@x~O?7XWZAB+ZqF#a)#c<_YY%<
Tow%ODek$Lk`E%zUdG>z+)|tMw

literal 0
HcmV?d00001

diff --git a/wrfv2_fire/run/MPTABLE.TBL b/wrfv2_fire/run/MPTABLE.TBL
index 7759e75f..97990c7e 100644
--- a/wrfv2_fire/run/MPTABLE.TBL
+++ b/wrfv2_fire/run/MPTABLE.TBL
@@ -43,9 +43,9 @@
  !---------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
  CH2OP =   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,   0.1,
  DLEAF =  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,  0.04,
- Z0MVT =  1.00,  0.06,  0.06,  0.06,  0.06,  0.15,  0.06,  0.06,  0.06,  0.86,  0.80,  0.85,  1.10,  1.09,  0.80,  0.00,  0.06,  0.05,  0.00,  0.04,  0.06,  0.06,  0.03,  0.00,  0.01,  0.00,  0.00,
- HVT   =  15.0,  0.50,  0.50,  0.50,  0.50,  1.25,  0.50,  0.50,  0.50,  16.0,  16.0,  18.0,  20.0,  20.0,  16.0,  0.00,  0.50,  0.80,  0.00,  0.50,  0.80,  0.80,  0.50,  0.00,  0.10,  0.00,  0.00,
- HVB   =  1.00,  0.10,  0.10,  0.10,  0.10,  0.15,  0.05,  0.10,  0.10,  5.00,  11.5,  7.00,  8.00,  8.50,  10.0,  0.00,  0.05,  0.10,  0.00,  0.10,  0.10,  0.10,  0.10,  0.00,  0.10,  0.00,  0.00,
+ Z0MVT =  1.00,  0.15,  0.15,  0.15,  0.14,  0.50,  0.12,  0.06,  0.09,  0.50,  0.80,  0.85,  1.10,  1.09,  0.80,  0.00,  0.12,  0.50,  0.00,  0.10,  0.30,  0.20,  0.03,  0.00,  0.01,  0.00,  0.00,
+ HVT   =  15.0,  2.00,  2.00,  2.00,  1.50,  8.00,  1.00,  1.10,  1.10,  10.0,  16.0,  18.0,  20.0,  20.0,  16.0,  0.00,  0.50,  10.0,  0.00,  0.50,  4.00,  2.00,  0.50,  0.00,  0.10,  0.00,  0.00,
+ HVB   =  1.00,  0.10,  0.10,  0.10,  0.10,  0.15,  0.05,  0.10,  0.10,  0.10,  11.5,  7.00,  8.00,  8.50,  10.0,  0.00,  0.05,  0.10,  0.00,  0.10,  0.10,  0.10,  0.10,  0.00,  0.10,  0.00,  0.00,
  DEN   =  0.01,  25.0,  25.0,  25.0,  25.0,  25.0,  100.,  10.0,  10.0,  0.02,  0.10,  0.28,  0.02,  0.28,  0.10,  0.01,  10.0,  0.10,  0.01,  1.00,  1.00,  1.00,  1.00,  0.00,  0.01,  0.01,  0.01,
  RC    =  1.00,  0.08,  0.08,  0.08,  0.08,  0.08,  0.03,  0.12,  0.12,  3.00,  1.40,  1.20,  3.60,  1.20,  1.40,  0.01,  0.10,  1.40,  0.01,  0.30,  0.30,  0.30,  0.30,  0.00,  0.01,  0.01,  0.01,
 
@@ -80,7 +80,7 @@
  AVCMX =   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,   2.4,
  AQE   =   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,   1.0,
 
- LTOVRC=   0.0,   1.6,   1.8,   1.2,   1.2,  1.30,  0.50,  0.65,  0.70,  0.65,  0.55,   0.2,  0.55,   0.5,   0.5,   0.0,   1.4,   1.4,   0.0,   1.2,   1.3,   1.4,   1.0,   0.0,   1.0,   0.0,   0.0,
+ LTOVRC=   0.0,   1.2,   1.2,   1.2,   1.2,  1.30,  0.50,  0.65,  0.70,  0.65,  0.55,   0.2,  0.55,   0.5,   0.5,   0.0,   1.4,   1.4,   0.0,   1.2,   1.3,   1.4,   1.0,   0.0,   1.0,   0.0,   0.0,
  DILEFC=  0.00,  0.50,  0.50,  0.50,  0.35,  0.20,  0.20,  0.20,  0.50,  0.50,  0.60,  1.80,  0.50,  1.20,  0.80,  0.00,  0.40,  0.40,  0.00,  0.40,  0.30,  0.40,  0.30,  0.00,  0.30,  0.00,  0.00,
  DILEFW=  0.00,  0.20,  0.20,  0.20,  0.20,  0.20,  0.10,  0.20,  0.20,  0.50,  0.20,  0.20,  4.00,  0.20,  0.20,  0.00,  0.20,  0.20,  0.00,  0.20,  0.20,  0.20,  0.20,  0.00,  0.20,  0.00,  0.00,
  RMF25 =  0.00,  1.00,  1.40,  1.45,  1.45,  1.45,  1.80,  0.26,  0.26,  0.80,  3.00,  4.00,  0.65,  3.00,  3.00,  0.00,  3.20,  3.20,  0.00,  3.20,  3.00,  3.00,  3.00,  0.00,  3.00,  0.00,  0.00,
@@ -101,31 +101,31 @@
  MRP   =  0.00,  0.23,  0.23,  0.23,  0.23,  0.23,  0.17,  0.19,  0.19,  0.40,  0.40,  0.37,  0.23,  0.37,  0.30,  0.00,  0.17,  0.40,  0.00,  0.17,  0.23,  0.20,  0.00,  0.00,  0.20,  0.00,  0.00,
 
 ! Monthly values, one row for each month:
- SAIM  =   0.0,   0.0,   0.0,   0.0,   0.0,   0.1,   0.3,   0.1,   0.2,   0.1,   0.4,   0.3,   0.5,   0.4,   0.2,   0.0,   0.1,   0.1,   0.0,   0.1,   0.1,   0.1,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.0,   0.0,   0.0,   0.1,   0.3,   0.1,   0.2,   0.1,   0.4,   0.3,   0.5,   0.4,   0.2,   0.0,   0.1,   0.1,   0.0,   0.1,   0.1,   0.1,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.0,   0.0,   0.0,   0.1,   0.3,   0.1,   0.2,   0.1,   0.4,   0.3,   0.5,   0.4,   0.2,   0.0,   0.1,   0.1,   0.0,   0.1,   0.1,   0.1,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.0,   0.0,   0.0,   0.1,   0.3,   0.1,   0.2,   0.1,   0.4,   0.4,   0.5,   0.3,   0.2,   0.0,   0.1,   0.1,   0.0,   0.1,   0.1,   0.1,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.0,   0.0,   0.1,   0.2,   0.3,   0.1,   0.2,   0.1,   0.4,   0.4,   0.5,   0.4,   0.2,   0.0,   0.1,   0.1,   0.0,   0.1,   0.1,   0.1,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.0,   0.0,   0.2,   0.2,   0.4,   0.2,   0.3,   0.1,   0.4,   0.7,   0.5,   0.5,   0.4,   0.0,   0.2,   0.2,   0.0,   0.2,   0.2,   0.2,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.0,   0.0,   0.3,   0.3,   0.8,   0.2,   0.5,   0.1,   0.9,   1.3,   0.5,   0.5,   0.4,   0.0,   0.4,   0.4,   0.0,   0.2,   0.2,   0.2,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.0,   0.0,   0.5,   0.2,   1.3,   0.1,   0.8,   0.1,   1.2,   1.2,   0.5,   0.6,   0.5,   0.0,   0.6,   0.6,   0.0,   0.3,   0.3,   0.3,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.0,   0.0,   0.4,   0.1,   1.1,   0.1,   0.5,   0.1,   1.6,   1.0,   0.5,   0.6,   0.5,   0.0,   0.5,   0.5,   0.0,   0.3,   0.3,   0.3,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.0,   0.0,   0.1,   0.1,   0.4,   0.1,   0.2,   0.1,   1.4,   0.8,   0.5,   0.7,   0.6,   0.0,   0.2,   0.2,   0.0,   0.2,   0.2,   0.2,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.0,   0.0,   0.0,   0.1,   0.4,   0.1,   0.2,   0.1,   0.6,   0.6,   0.5,   0.6,   0.5,   0.0,   0.2,   0.2,   0.0,   0.2,   0.2,   0.2,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.0,   0.0,   0.0,   0.1,   0.4,   0.1,   0.2,   0.1,   0.4,   0.5,   0.5,   0.5,   0.3,   0.0,   0.1,   0.1,   0.0,   0.1,   0.1,   0.1,   0.0,   0.0,   0.0,   0.0,   0.0,
+ SAIM  =   0.0,   0.3,   0.3,   0.3,   0.3,   0.3,   0.3,   0.2,   0.2,   0.3,   0.4,   0.3,   0.5,   0.4,   0.4,   0.0,   0.2,   0.3,   0.0,   0.1,   0.2,   0.1,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.3,   0.3,   0.3,   0.3,   0.3,   0.3,   0.2,   0.2,   0.3,   0.4,   0.3,   0.5,   0.4,   0.4,   0.0,   0.2,   0.3,   0.0,   0.1,   0.2,   0.1,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.3,   0.3,   0.3,   0.3,   0.3,   0.3,   0.2,   0.2,   0.3,   0.4,   0.3,   0.5,   0.4,   0.4,   0.0,   0.2,   0.3,   0.0,   0.1,   0.2,   0.1,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.3,   0.3,   0.3,   0.3,   0.3,   0.3,   0.2,   0.2,   0.3,   0.4,   0.4,   0.5,   0.3,   0.4,   0.0,   0.2,   0.3,   0.0,   0.1,   0.2,   0.1,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.2,   0.2,   0.2,   0.3,   0.3,   0.3,   0.2,   0.2,   0.3,   0.4,   0.4,   0.5,   0.4,   0.4,   0.0,   0.3,   0.3,   0.0,   0.1,   0.2,   0.1,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.3,   0.3,   0.3,   0.4,   0.4,   0.4,   0.2,   0.3,   0.4,   0.4,   0.7,   0.5,   0.5,   0.4,   0.0,   0.4,   0.4,   0.0,   0.2,   0.2,   0.2,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.4,   0.4,   0.4,   0.6,   0.6,   0.8,   0.4,   0.6,   0.8,   0.9,   1.3,   0.5,   0.5,   0.7,   0.0,   0.6,   0.6,   0.0,   0.4,   0.4,   0.4,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.5,   0.5,   0.5,   0.9,   0.9,   1.3,   0.6,   0.9,   1.2,   1.2,   1.2,   0.5,   0.6,   0.8,   0.0,   0.9,   0.9,   0.0,   0.6,   0.6,   0.6,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.4,   0.4,   0.4,   0.7,   1.0,   1.1,   0.8,   1.0,   1.3,   1.6,   1.0,   0.5,   0.6,   1.0,   0.0,   0.7,   1.0,   0.0,   0.7,   0.8,   0.7,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.3,   0.3,   0.3,   0.3,   0.8,   0.4,   0.7,   0.6,   0.7,   1.4,   0.8,   0.5,   0.7,   1.0,   0.0,   0.3,   0.8,   0.0,   0.5,   0.7,   0.5,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.3,   0.3,   0.3,   0.3,   0.4,   0.4,   0.3,   0.3,   0.4,   0.6,   0.6,   0.5,   0.6,   0.5,   0.0,   0.3,   0.4,   0.0,   0.3,   0.3,   0.3,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.3,   0.3,   0.3,   0.3,   0.3,   0.4,   0.2,   0.3,   0.4,   0.4,   0.5,   0.5,   0.5,   0.4,   0.0,   0.3,   0.4,   0.0,   0.2,   0.2,   0.2,   0.0,   0.0,   0.0,   0.0,   0.0,
 
- LAIM  =   0.0,   0.0,   0.4,   0.4,   0.4,   0.0,   0.4,   1.0,   1.0,   1.0,   0.0,   0.0,   4.5,   1.6,   1.0,   0.0,   0.4,   0.2,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.5,   0.5,   0.5,   0.0,   0.5,   1.0,   1.0,   1.0,   0.0,   0.0,   4.5,   1.6,   1.0,   0.0,   0.5,   0.4,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.6,   0.6,   0.6,   0.0,   0.6,   1.0,   1.0,   1.0,   0.3,   0.0,   4.5,   1.6,   1.0,   0.0,   0.6,   0.4,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.7,   0.7,   0.7,   0.5,   0.7,   1.0,   1.5,   1.0,   1.2,   0.6,   4.5,   1.6,   1.0,   0.0,   0.7,   0.4,   0.0,   0.2,   0.2,   0.2,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   1.0,   1.2,   1.2,   1.2,   1.5,   1.2,   1.0,   2.0,   1.0,   3.0,   1.2,   4.5,   5.3,   2.3,   0.0,   1.2,   0.5,   0.0,   0.5,   0.5,   0.5,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   2.0,   3.0,   3.0,   3.0,   2.5,   3.0,   1.0,   2.5,   1.0,   4.7,   2.0,   4.5,   5.5,   3.5,   0.0,   3.0,   0.7,   0.0,   1.0,   1.0,   1.0,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   3.0,   3.5,   3.5,   3.5,   3.5,   3.5,   1.0,   3.0,   1.0,   4.5,   2.6,   4.5,   5.3,   4.3,   0.0,   3.5,   1.7,   0.0,   2.0,   2.0,   2.0,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   3.0,   1.5,   1.5,   1.5,   3.5,   1.5,   1.0,   2.5,   1.0,   3.4,   1.7,   4.5,   5.3,   3.3,   0.0,   1.5,   3.0,   0.0,   1.0,   1.0,   1.0,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   1.5,   0.7,   0.7,   0.7,   2.0,   0.7,   1.0,   1.5,   1.0,   1.2,   1.0,   4.5,   4.2,   2.2,   0.0,   0.7,   2.5,   0.0,   0.5,   0.5,   0.5,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.6,   0.6,   0.6,   1.0,   0.6,   1.0,   1.0,   1.0,   0.3,   0.5,   4.5,   2.2,   1.2,   0.0,   0.6,   1.6,   0.0,   0.2,   0.2,   0.2,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.5,   0.5,   0.5,   0.0,   0.5,   1.0,   1.0,   1.0,   0.0,   0.2,   4.5,   2.2,   1.2,   0.0,   0.5,   0.8,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,
-           0.0,   0.0,   0.4,   0.4,   0.4,   0.0,   0.4,   1.0,   1.0,   1.0,   0.0,   0.0,   4.5,   2.2,   1.2,   0.0,   0.4,   0.4,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,   0.0,
+ LAIM  =   0.0,   0.0,   0.0,   0.0,   0.2,   0.0,   0.4,   0.0,   0.2,   0.3,   0.0,   0.0,   4.5,   4.0,   2.0,   0.0,   0.2,   0.2,   0.0,   0.2,   1.0,   0.6,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.0,   0.0,   0.0,   0.3,   0.0,   0.5,   0.0,   0.3,   0.3,   0.0,   0.0,   4.5,   4.0,   2.0,   0.0,   0.3,   0.3,   0.0,   0.3,   1.0,   0.6,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.0,   0.0,   0.0,   0.3,   0.2,   0.6,   0.2,   0.4,   0.5,   0.3,   0.0,   4.5,   4.0,   2.2,   0.0,   0.3,   0.3,   0.0,   0.3,   1.1,   0.7,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.0,   0.0,   0.0,   0.4,   0.6,   0.7,   0.6,   0.7,   0.8,   1.2,   0.6,   4.5,   4.0,   2.6,   0.0,   0.4,   0.6,   0.0,   0.4,   1.3,   0.8,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   1.0,   1.0,   1.0,   1.1,   2.0,   1.2,   1.5,   1.4,   1.8,   3.0,   1.2,   4.5,   4.0,   3.5,   0.0,   1.1,   2.0,   0.0,   0.6,   1.7,   1.2,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   2.0,   2.0,   2.0,   2.5,   3.3,   3.0,   2.3,   2.6,   3.6,   4.7,   2.0,   4.5,   4.0,   4.3,   0.0,   2.5,   3.3,   0.0,   1.5,   2.1,   1.8,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   3.0,   3.0,   3.0,   3.2,   3.7,   3.5,   2.3,   2.9,   3.8,   4.5,   2.6,   4.5,   4.0,   4.3,   0.0,   3.2,   3.7,   0.0,   1.7,   2.1,   1.8,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   3.0,   3.0,   3.0,   2.2,   3.2,   1.5,   1.7,   1.6,   2.1,   3.4,   1.7,   4.5,   4.0,   3.7,   0.0,   2.2,   3.2,   0.0,   0.8,   1.8,   1.3,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   1.5,   1.5,   1.5,   1.1,   1.3,   0.7,   0.6,   0.7,   0.9,   1.2,   1.0,   4.5,   4.0,   2.6,   0.0,   1.1,   1.3,   0.0,   0.4,   1.3,   0.8,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.0,   0.0,   0.0,   0.3,   0.2,   0.6,   0.2,   0.4,   0.5,   0.3,   0.5,   4.5,   4.0,   2.2,   0.0,   0.3,   0.3,   0.0,   0.3,   1.1,   0.7,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.0,   0.0,   0.0,   0.3,   0.0,   0.5,   0.0,   0.3,   0.3,   0.0,   0.2,   4.5,   4.0,   2.0,   0.0,   0.3,   0.3,   0.0,   0.2,   1.0,   0.6,   0.0,   0.0,   0.0,   0.0,   0.0,
+           0.0,   0.0,   0.0,   0.0,   0.2,   0.0,   0.4,   0.0,   0.2,   0.3,   0.0,   0.0,   4.5,   4.0,   2.0,   0.0,   0.2,   0.2,   0.0,   0.2,   1.0,   0.6,   0.0,   0.0,   0.0,   0.0,   0.0,
 
  SLAREA=0.0228,0.0200,0.0200,0.0295,0.0223,0.0277,0.0060,0.0227,0.0188,0.0236,0.0258,0.0200,0.0200,0.0090,0.0223,0.0422,0.0390,  0.02,  0.02,  0.02,  0.02,  0.02,  0.02,  0.02,  0.02,  0.02,  0.02,
 
@@ -142,6 +142,11 @@
  NVEG = 20
 /
 
+&noah_mp_modis_veg_categories
+ VEG_DATASET_DESCRIPTION = "modified igbp modis noah"
+ NVEG = 20
+/
+
 &noah_mp_modis_parameters
 ! 1          'Evergreen Needleleaf Forest'                       -> USGS 14
 ! 2,         'Evergreen Broadleaf Forest'                        -> USGS 13
@@ -175,17 +180,16 @@
  !---------------------------------------------------------------------------------------------------------------------------------------------------------------------
  CH2OP =   0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,    0.1,
  DLEAF =  0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,   0.04,
- Z0MVT =  1.09,   1.10,   0.85,   0.80,   0.80,   0.06,   0.06,   0.06,   0.86,   0.06,  0.055,   0.06,   1.00,   0.06,   0.00,   0.00,   0.00,   0.06,   0.06,   0.03,
-! Z0MVT =  0.50,   0.50,   0.50,   0.50,   0.50,   0.05,   0.06,   0.05,   0.15,   0.12,  0.30,   0.15,   0.80,   0.14,   0.00,   0.01,   0.00,   0.30,   0.15,   0.10,
- HVT   =  20.0,   20.0,   18.0,   16.0,   16.0,   0.50,   0.50,   0.50,   16.0,   0.50,   0.65,   0.50,   15.0,   0.50,   0.00,   0.00,   0.00,   0.80,   0.80,   0.50,
- HVB   =  8.50,   8.00,   7.00,   11.5,   10.0,   0.10,   0.10,   0.10,   5.00,   0.05,  0.075,   0.10,   1.00,   0.10,   0.00,   0.00,   0.00,   0.10,   0.10,   0.10,
+ Z0MVT =  1.09,   1.10,   0.85,   0.80,   0.80,   0.20,   0.06,   0.60,   0.50,   0.12,   0.30,   0.15,   1.00,   0.14,   0.00,   0.00,   0.00,   0.30,   0.20,   0.03,
+ HVT   =  20.0,   20.0,   18.0,   16.0,   16.0,   1.10,   1.10,   13.0,   10.0,   1.00,   5.00,   2.00,   15.0,   1.50,   0.00,   0.00,   0.00,   4.00,   2.00,   0.50,
+ HVB   =  8.50,   8.00,   7.00,   11.5,   10.0,   0.10,   0.10,   0.10,   0.10,   0.05,   0.10,   0.10,   1.00,   0.10,   0.00,   0.00,   0.00,   0.30,   0.20,   0.10,
  DEN   =  0.28,   0.02,   0.28,   0.10,   0.10,   10.0,   10.0,   10.0,   0.02,   100.,   5.05,   25.0,   0.01,   25.0,   0.00,   0.01,   0.01,   1.00,   1.00,   1.00,
  RC    =  1.20,   3.60,   1.20,   1.40,   1.40,   0.12,   0.12,   0.12,   3.00,   0.03,   0.75,   0.08,   1.00,   0.08,   0.00,   0.01,   0.01,   0.30,   0.30,   0.30,
 
  ! Row 1:  Vis
  ! Row 2:  Near IR
- RHOL  =  0.07,   0.10,   0.07,   0.10,   0.10,   0.07,   0.10,   0.07,   0.10,   0.11,  0.105,   0.11,   0.00,   0.11,   0.00,   0.00,   0.00,   0.10,   0.10,   0.10,
-          0.35,   0.45,   0.35,   0.45,   0.45,   0.35,   0.45,   0.35,   0.45,   0.58,  0.515,   0.58,   0.00,   0.58,   0.00,   0.00,   0.00,   0.45,   0.45,   0.45,
+ RHOL  =  0.07,   0.10,   0.07,   0.10,   0.10,   0.07,   0.07,   0.07,   0.10,   0.11,  0.105,   0.11,   0.00,   0.11,   0.00,   0.00,   0.00,   0.10,   0.10,   0.10,
+          0.35,   0.45,   0.35,   0.45,   0.45,   0.35,   0.35,   0.35,   0.45,   0.58,  0.515,   0.58,   0.00,   0.58,   0.00,   0.00,   0.00,   0.45,   0.45,   0.45,
 
  ! Row 1:  Vis
  ! Row 2:  Near IR
@@ -202,7 +206,7 @@
  TAUS  = 0.001,  0.001,  0.001,  0.001,  0.001,  0.001,  0.001,  0.001,  0.001,  0.220, 0.1105,  0.220,  0.000,  0.220,  0.000,  0.000,  0.000,  0.001,  0.001,  0.001,
          0.001,  0.001,  0.001,  0.001,  0.001,  0.001,  0.001,  0.001,  0.001,  0.380, 0.1905,  0.380,  0.000,  0.380,  0.000,  0.000,  0.000,  0.001,  0.001,  0.001,
 
- XL    = 0.010,  0.010,  0.010,  0.250,  0.250,  0.010,  0.250,  0.010,  0.010,  -0.30, -0.025,  -0.30,  0.000,  -0.30,  0.000,  0.000,  0.000,  0.250,  0.250,  0.250,
+ XL    = 0.010,  0.010,  0.010,  0.250,  0.250,  0.010,  0.010,  0.010,  0.010,  -0.30, -0.025,  -0.30,  0.000,  -0.30,  0.000,  0.000,  0.000,  0.250,  0.250,  0.250,
 ! CWPVT =   3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,    3.0,
  CWPVT =  0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,   0.18,
  C3PSN =   1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,
@@ -213,8 +217,8 @@
  AVCMX =   2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,    2.4,
  AQE   =   1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,    1.0,
 
- LTOVRC=   0.5,   0.55,    0.2,   0.55,    0.5,   0.65,   0.70,   0.65,   0.65,   0.50,    1.4,    1.6,    0.0,    1.2,    0.0,    0.0,    0.0,    1.3,    1.4,    1.0,
- DILEFC=  1.20,   0.50,   1.80,   0.60,   0.80,   0.20,   0.50,   0.20,   0.50,   0.20,    0.4,   0.50,   0.00,   0.35,   0.00,   0.00,   0.00,   0.30,   0.40,   0.30,
+ LTOVRC=   0.5,   0.55,    0.2,   0.55,    0.5,   0.65,   0.65,   0.65,   0.65,   0.50,    1.4,    1.6,    0.0,    1.2,    0.0,    0.0,    0.0,    1.3,    1.4,    1.0,
+ DILEFC=  1.20,   0.50,   1.80,   0.60,   0.80,   0.20,   0.20,   0.20,   0.50,   0.20,    0.4,   0.50,   0.00,   0.35,   0.00,   0.00,   0.00,   0.30,   0.40,   0.30,
  DILEFW=  0.20,   4.00,   0.20,   0.20,   0.20,   0.20,   0.20,   0.20,   0.50,   0.10,    0.2,   0.20,   0.00,   0.20,   0.00,   0.00,   0.00,   0.20,   0.20,   0.20,
  RMF25 =  3.00,   0.65,   4.00,   3.00,   3.00,   0.26,   0.26,   0.26,   0.80,   1.80,    3.2,   1.00,   0.00,   1.45,   0.00,   0.00,   0.00,   3.00,   3.00,   3.00,
  SLA   =    80,     80,     80,     80,     80,     60,     60,     60,     50,     60,     80,     80,     60,     80,      0,      0,      0,     80,     80,     80,
@@ -234,31 +238,31 @@
  MRP   =  0.37,   0.23,   0.37,   0.40,   0.30,   0.19,   0.19,   0.19,   0.40,   0.17,  0.285,   0.23,   0.00,   0.23,   0.00,   0.00,   0.00,   0.23,   0.20,   0.00,
 
 ! Monthly values, one row for each month:
- SAIM  =   0.4,    0.5,    0.3,    0.4,    0.2,    0.1,    0.2,    0.1,    0.1,    0.3,    0.1,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.1,    0.1,    0.0,
-           0.4,    0.5,    0.3,    0.4,    0.2,    0.1,    0.2,    0.1,    0.1,    0.3,    0.1,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.1,    0.1,    0.0,
-           0.4,    0.5,    0.3,    0.4,    0.2,    0.1,    0.2,    0.1,    0.1,    0.3,    0.1,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.1,    0.1,    0.0,
-           0.3,    0.5,    0.4,    0.4,    0.2,    0.1,    0.2,    0.1,    0.1,    0.3,    0.1,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.1,    0.1,    0.0,
-           0.4,    0.5,    0.4,    0.4,    0.2,    0.1,    0.2,    0.1,    0.1,    0.3,    0.1,    0.0,    0.0,    0.1,    0.0,    0.0,    0.0,    0.1,    0.1,    0.0,
-           0.5,    0.5,    0.7,    0.4,    0.4,    0.2,    0.3,    0.2,    0.1,    0.4,    0.2,    0.0,    0.0,    0.2,    0.0,    0.0,    0.0,    0.2,    0.2,    0.0,
-           0.5,    0.5,    1.3,    0.9,    0.4,    0.2,    0.5,    0.2,    0.1,    0.8,    0.4,    0.0,    0.0,    0.3,    0.0,    0.0,    0.0,    0.2,    0.2,    0.0,
-           0.6,    0.5,    1.2,    1.2,    0.5,    0.1,    0.8,    0.1,    0.1,    1.3,    0.6,    0.0,    0.0,    0.5,    0.0,    0.0,    0.0,    0.3,    0.3,    0.0,
-           0.6,    0.5,    1.0,    1.6,    0.5,    0.1,    0.5,    0.1,    0.1,    1.1,    0.5,    0.0,    0.0,    0.4,    0.0,    0.0,    0.0,    0.3,    0.3,    0.0,
-           0.7,    0.5,    0.8,    1.4,    0.6,    0.1,    0.2,    0.1,    0.1,    0.4,    0.2,    0.0,    0.0,    0.1,    0.0,    0.0,    0.0,    0.2,    0.2,    0.0,
-           0.6,    0.5,    0.6,    0.6,    0.5,    0.1,    0.2,    0.1,    0.1,    0.4,    0.2,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.2,    0.2,    0.0,
-           0.5,    0.5,    0.5,    0.4,    0.3,    0.1,    0.2,    0.1,    0.1,    0.4,    0.1,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,    0.1,    0.1,    0.0,
+ SAIM  =   0.4,    0.5,    0.3,    0.4,    0.4,    0.3,    0.2,    0.4,    0.3,    0.3,    0.3,    0.3,    0.0,    0.3,    0.0,    0.0,    0.0,    0.2,    0.1,    0.0,
+           0.4,    0.5,    0.3,    0.4,    0.4,    0.3,    0.2,    0.4,    0.3,    0.3,    0.3,    0.3,    0.0,    0.3,    0.0,    0.0,    0.0,    0.2,    0.1,    0.0,
+           0.4,    0.5,    0.3,    0.4,    0.4,    0.3,    0.2,    0.4,    0.3,    0.3,    0.3,    0.3,    0.0,    0.3,    0.0,    0.0,    0.0,    0.2,    0.1,    0.0,
+           0.3,    0.5,    0.4,    0.4,    0.4,    0.3,    0.2,    0.4,    0.3,    0.3,    0.3,    0.3,    0.0,    0.3,    0.0,    0.0,    0.0,    0.2,    0.1,    0.0,
+           0.4,    0.5,    0.4,    0.4,    0.4,    0.3,    0.2,    0.4,    0.3,    0.3,    0.3,    0.3,    0.0,    0.3,    0.0,    0.0,    0.0,    0.2,    0.1,    0.0,
+           0.5,    0.5,    0.7,    0.4,    0.4,    0.3,    0.2,    0.4,    0.4,    0.4,    0.4,    0.3,    0.0,    0.4,    0.0,    0.0,    0.0,    0.2,    0.2,    0.0,
+           0.5,    0.5,    1.3,    0.9,    0.7,    0.6,    0.4,    0.7,    0.8,    0.8,    0.6,    0.4,    0.0,    0.6,    0.0,    0.0,    0.0,    0.4,    0.4,    0.0,
+           0.6,    0.5,    1.2,    1.2,    0.8,    0.9,    0.6,    1.2,    1.2,    1.3,    0.9,    0.5,    0.0,    0.9,    0.0,    0.0,    0.0,    0.6,    0.6,    0.0,
+           0.6,    0.5,    1.0,    1.6,    1.0,    1.2,    0.8,    1.4,    1.3,    1.1,    0.9,    0.4,    0.0,    0.7,    0.0,    0.0,    0.0,    0.8,    0.7,    0.0,
+           0.7,    0.5,    0.8,    1.4,    1.0,    0.9,    0.7,    1.1,    0.7,    0.4,    0.6,    0.3,    0.0,    0.3,    0.0,    0.0,    0.0,    0.7,    0.5,    0.0,
+           0.6,    0.5,    0.6,    0.6,    0.5,    0.4,    0.3,    0.5,    0.4,    0.4,    0.4,    0.3,    0.0,    0.3,    0.0,    0.0,    0.0,    0.3,    0.3,    0.0,
+           0.5,    0.5,    0.5,    0.4,    0.4,    0.3,    0.2,    0.4,    0.4,    0.4,    0.3,    0.3,    0.0,    0.3,    0.0,    0.0,    0.0,    0.2,    0.2,    0.0,
 
- LAIM  =   1.6,    4.5,    0.0,    0.0,    1.0,    1.0,    1.0,    1.0,    1.0,    0.4,    0.3,    0.0,    0.0,    0.4,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
-           1.6,    4.5,    0.0,    0.0,    1.0,    1.0,    1.0,    1.0,    1.0,    0.5,   0.45,    0.0,    0.0,    0.5,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
-           1.6,    4.5,    0.0,    0.3,    1.0,    1.0,    1.0,    1.0,    1.0,    0.6,    0.5,    0.0,    0.0,    0.6,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
-           1.6,    4.5,    0.6,    1.2,    1.0,    1.0,    1.5,    1.0,    1.0,    0.7,   0.55,    0.0,    0.0,    0.7,    0.0,    0.0,    0.0,    0.2,    0.2,    0.0,
-           5.3,    4.5,    1.2,    3.0,    2.3,    1.0,    2.0,    1.0,    1.0,    1.2,   0.85,    1.0,    0.0,    1.2,    0.0,    0.0,    0.0,    0.5,    0.5,    0.0,
-           5.5,    4.5,    2.0,    4.7,    3.5,    1.0,    2.5,    1.0,    1.0,    3.0,   1.85,    2.0,    0.0,    3.0,    0.0,    0.0,    0.0,    1.0,    1.0,    0.0,
-           5.3,    4.5,    2.6,    4.5,    4.3,    1.0,    3.0,    1.0,    1.0,    3.5,    2.6,    3.0,    0.0,    3.5,    0.0,    0.0,    0.0,    2.0,    2.0,    0.0,
-           5.3,    4.5,    1.7,    3.4,    3.3,    1.0,    2.5,    1.0,    1.0,    1.5,   2.25,    3.0,    0.0,    1.5,    0.0,    0.0,    0.0,    1.0,    1.0,    0.0,
-           4.2,    4.5,    1.0,    1.2,    2.2,    1.0,    1.5,    1.0,    1.0,    0.7,    1.6,    1.5,    0.0,    0.7,    0.0,    0.0,    0.0,    0.5,    0.5,    0.0,
-           2.2,    4.5,    0.5,    0.3,    1.2,    1.0,    1.0,    1.0,    1.0,    0.6,    1.1,    0.0,    0.0,    0.6,    0.0,    0.0,    0.0,    0.2,    0.2,    0.0,
-           2.2,    4.5,    0.2,    0.0,    1.2,    1.0,    1.0,    1.0,    1.0,    0.5,   0.65,    0.0,    0.0,    0.5,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
-           2.2,    4.5,    0.0,    0.0,    1.2,    1.0,    1.0,    1.0,    1.0,    0.4,    0.4,    0.0,    0.0,    0.4,    0.0,    0.0,    0.0,    0.0,    0.0,    0.0,
+ LAIM  =   4.0,    4.5,    0.0,    0.0,    2.0,    0.0,    0.0,    0.2,    0.3,    0.4,    0.2,    0.0,    0.0,    0.2,    0.0,    0.0,    0.0,    1.0,    0.6,    0.0,
+           4.0,    4.5,    0.0,    0.0,    2.0,    0.0,    0.0,    0.2,    0.3,    0.5,    0.3,    0.0,    0.0,    0.3,    0.0,    0.0,    0.0,    1.0,    0.6,    0.0,
+           4.0,    4.5,    0.0,    0.3,    2.2,    0.3,    0.2,    0.4,    0.5,    0.6,    0.3,    0.0,    0.0,    0.3,    0.0,    0.0,    0.0,    1.1,    0.7,    0.0,
+           4.0,    4.5,    0.6,    1.2,    2.6,    0.9,    0.6,    1.0,    0.8,    0.7,    0.5,    0.0,    0.0,    0.4,    0.0,    0.0,    0.0,    1.3,    0.8,    0.0,
+           4.0,    4.5,    1.2,    3.0,    3.5,    2.2,    1.5,    2.4,    1.8,    1.2,    1.5,    1.0,    0.0,    1.1,    0.0,    0.0,    0.0,    1.7,    1.2,    0.0,
+           4.0,    4.5,    2.0,    4.7,    4.3,    3.5,    2.3,    4.1,    3.6,    3.0,    2.9,    2.0,    0.0,    2.5,    0.0,    0.0,    0.0,    2.1,    1.8,    0.0,
+           4.0,    4.5,    2.6,    4.5,    4.3,    3.5,    2.3,    4.1,    3.8,    3.5,    3.5,    3.0,    0.0,    3.2,    0.0,    0.0,    0.0,    2.1,    1.8,    0.0,
+           4.0,    4.5,    1.7,    3.4,    3.7,    2.5,    1.7,    2.7,    2.1,    1.5,    2.7,    3.0,    0.0,    2.2,    0.0,    0.0,    0.0,    1.8,    1.3,    0.0,
+           4.0,    4.5,    1.0,    1.2,    2.6,    0.9,    0.6,    1.0,    0.9,    0.7,    1.2,    1.5,    0.0,    1.1,    0.0,    0.0,    0.0,    1.3,    0.8,    0.0,
+           4.0,    4.5,    0.5,    0.3,    2.2,    0.3,    0.2,    0.4,    0.5,    0.6,    0.3,    0.0,    0.0,    0.3,    0.0,    0.0,    0.0,    1.1,    0.7,    0.0,
+           4.0,    4.5,    0.2,    0.0,    2.0,    0.0,    0.0,    0.2,    0.3,    0.5,    0.3,    0.0,    0.0,    0.3,    0.0,    0.0,    0.0,    1.0,    0.6,    0.0,
+           4.0,    4.5,    0.0,    0.0,    2.0,    0.0,    0.0,    0.2,    0.3,    0.4,    0.2,    0.0,    0.0,    0.2,    0.0,    0.0,    0.0,    1.0,    0.6,    0.0,
 
 !  LAIM  =   5.1,    3.3,    0.0,    1.9,    3.0,    1.0,    0.8,    0.5,    0.5,    0.7,    0.3,    1.8,    0.0,    2.4,    0.0,    0.0,    0.0,    0.6,    0.7,    0.0,
 !            5.0,    3.6,    0.0,    1.9,    2.9,    1.0,    0.6,    1.0,    1.0,    0.7,   0.45,    1.9,    0.0,    2.6,    0.0,    0.0,    0.0,    0.4,    0.4,    0.0,
diff --git a/wrfv2_fire/run/README.namelist b/wrfv2_fire/run/README.namelist
index 52113e27..d7125532 100644
--- a/wrfv2_fire/run/README.namelist
+++ b/wrfv2_fire/run/README.namelist
@@ -1,4 +1,5 @@
 Description of namelist variables
+
 ---------------------------------
  
 For WRF-NMM users, please see Chapter 5 of the WRF-NMM User's Guide for 
@@ -63,6 +64,7 @@ information on NMM specific settings (http://www.dtcenter.org/wrf-nmm/users)
                                      = 5,       ; GRIB1 format
                                      = 10,      ; GRIB2 format
                                      = 11,      ; pnetCDF format
+ ncd_nofill                          = .true.,  ; only a single write, not the write/read/write sequence, new in 3.6
  frames_per_emissfile                = 12,      ; number of times in each chemistry emission file.
  io_style_emiss                      = 1,       ; style to use for the chemistry emission files.
                                                 ; 0 = Do not read emissions from files.
@@ -147,6 +149,11 @@ Additional settings when running WRFVAR:
  inputout_end_s                      = 0        ; the above shows that the input-formatted data are output
                                                   starting from hour 3 to hour 12 in 180 min interval.
 
+For automatic moving nests: requires special input data, and environment variable TERRAIN_AND_LANDUSE set at compile time
+                                     (This option will overwrite input_from_file for nest domains)
+ input_from_hires (max_dom)          = .true., 
+ rsmas_data_path                     = "path-to-terrain-and-landuse-dataset"
+
  &domains
  time_step                           = 60,	; time step for integration in integer seconds
                                                   recommend 6*dx (in km) for typical real-data cases
@@ -207,6 +214,7 @@ Namelist variables specifically for the WPS input for real:
  lagrange_order                      = 1        ; vertical interpolation order
                                                 ; 1 = linear
                                                 ; 2 = quadratic
+                                                ; 9 = cubic spline
  zap_close_levels                    = 500      ; ignore isobaric level above surface if delta p (Pa) < zap_close_levels
  lowest_lev_from_sfc                 = .false.  ; place the surface value into the lowest eta location
                                                 ; T = use surface value as lowest eta (u,v,t,q)
@@ -423,6 +431,14 @@ Namelist variables for controlling the adaptive time step option:
                                        nssl_rho_qh  = 500.  ! graupel density
                                        nssl_rho_qhl = 900.  ! hail density
                                        nssl_rho_qs  = 100.  ! snow density
+                                     = 28, aerosol-aware Thompson scheme with water- and ice-friendly aerosol climatology 
+                                           (new for V3.6)
+                                       This option has two climatogical aerosol input options:
+                                       use_aero_icbc = .F. : use constant values
+                                       use_aero_icbc = .T. : use input from WPS
+                                     = 30, HUJI (Hebrew University of Jerusalem, Israel) spectral bin microphysics,
+                                           fast version
+                                     = 32, HUJI spectral bin microphysics, full version
                                      = 95, Ferrier (old Eta) microphysics, operational NAM (WRF NMM) version
 
  For non-zero mp_physics options, to keep Qv .GE. 0, and to set the other moisture
@@ -496,7 +512,10 @@ Namelist variables for controlling the adaptive time step option:
 
  ra_call_offset                      radiation call offset
                                      = 0 (no offset), =-1 (old offset)
-
+ swint_opt                           Interpolation of short-wave radiation based on the updated solar zenith angle 
+                                       between SW call
+                                     = 0, no interpolation
+                                     = 1, use interpolation
  cam_abs_freq_s                      = 21600 default CAM clearsky longwave absorption calculation frequency
                                             (recommended minimum value to speed scheme up)
  levsiz                              = 59 for CAM radiation input ozone levels, set automatically
@@ -510,20 +529,42 @@ Namelist variables for controlling the adaptive time step option:
  aer_opt                             = aerosol input option for radiation (currently rrtmg only)
                                      = 0, none
                                      = 1, using Tegen (1997) data, 
+                                     = 2, using J. A. Ruiz-Arias method (see other aer_* options) 
  alevsiz                             = 12 for Tegen aerosol input levels, set automatically
  no_src_types                        = 6 for Tegen aerosols: organic and black carbon, sea salt, sulfalte, dust,
                                        and stratospheric aerosol (volcanic ashes - currently 0), set automatically
 
+ The following aerosol options allow RRTMG and new Goddard radiation schemes to see it, but the aerosols are
+     constant during the model integration.
+ aer_aod550_opt                      = [1,2] :
+                                       1 = input constant value for AOD at 550 nm from namelist.
+                                           In this case, the value is read from aer_aod550_val;
+                                       2 = input value from auxiliary input 5. It is a time-varying 2D grid in netcdf 
+                                           wrf-compatible format. The default is aer_aod550_opt=1 and aer_aod550_val=0.12
+ aer_aod550_val                      = 0.12
+ aer_angexp_opt                      = [1,2,3] :
+                                       1 = input constant value for Angstrom exponent from namelist. In this case, 
+                                           the value is read from aer_angexp_val;
+                                       2 = input value from auxiliary input 5, as in aer_aod550_opt;
+                                       3 = Angstrom exponent value estimated from the aerosol type defined in aer_type, and modulated
+                                           with the RH in WRF. Default operation is aer_angexp_opt = 1, and aer_angexp_val=1.3.
+ aer_angexp_val                      = 1.3   
+ aer_ssa_opt                         = [1,2,3] similar to aer_angexp_opt.
+ aer_ssa_val                         = 0.85
+ aer_asy_opt                         = [1,2,3] similar to aer_angexp_opt.
+ aer_asy_val                         = 0.9
+ aer_type                            = [1,2,3] : 1 for rural, 2 is urban and 3 is maritime.
+
  sf_sfclay_physics (max_dom)         surface-layer option (old bl_sfclay_physics option)
                                      = 0, no surface-layer
-                                     = 1, MM5 Monin-Obukhov scheme
+                                     = 1, Revised MM5 Monin-Obukhov scheme (Jimenez, renamed in v3.6)
                                      = 2, Monin-Obukhov (Janjic) scheme
                                      = 3, NCEP Global Forecast System scheme (NMM only)
                                      = 4, QNSE surface layer
                                      = 5, MYNN surface layer
                                      = 7, Pleim-Xiu surface layer (ARW only)
                                      = 10, TEMF surface layer (ARW only)
-                                     = 11, Revised MM5 scheme (Jimenez)
+                                     = 91, Old MM5 scheme (previously option 1)
 
  sf_surface_physics (max_dom)        land-surface option (old bl_surface_physics option)
                                      = 0, no surface temp prediction
@@ -565,7 +606,12 @@ Namelist variables for controlling the adaptive time step option:
 
  bldt (max_dom)                      = 0,       ; minutes between boundary-layer physics calls
 
- grav_settling                       = 0, ; MYNN PBL only; gravitational settling of fog/cloud droplets (1=yes)
+ grav_settling (max_dom)             gravitational settling of fog/cloud droplets (Now works for any PBL scheme)
+ 				     = 0, No settling of cloud droplets
+				     = 1, Settling from Dyunkerke 1991 (in atmos and at surface)
+				     = 2, Fogdes (vegetation & wind speed dependent; Katata et al. 2008) at surface 
+                                          and Dyunkerke in the atmos.
+
  nphs (max_dom)                      = FOR NMM: number of fundamental timesteps between
                                                 calls to turbulence and microphysics;
                                                 the value is set in Registry.NMM but is
@@ -573,10 +619,17 @@ Namelist variables for controlling the adaptive time step option:
                                                 be computed from this.
  mfshconv (max_dom)                  = 1,; whether to turn on new day-time EDMF QNSE (0=no)
  topo_wind (max_dom)                 = 0, turn off, 
-                                     =1, turn on topographic surface wind correction from Jimenez 
+                                     = 1, turn on topographic surface wind correction from Jimenez 
                                        (YSU PBL only, and require extra input from geogrid)
-                                     =2, turn on topographic surface wind correction from Mass (YSU PBL only)
- bl_mynn_tkebudget                   = 0 default off, = 1 adds MYNN tke budget terms to output
+                                     = 2, turn on topographic surface wind correction from Mass (YSU PBL only)
+ bl_mynn_tkebudget (max_dom)         = 0, default off; = 1 adds MYNN tke budget terms to output
+ bl_mynn_tkeadvect (max_dom)         = .false., default off; = .true. do MYNN tke advection
+ scalar_pblmix (max_dom)             = 1 ; mix scalar fields consistent with PBL option (exch_h)
+ tracer_pblmix (max_dom)             = 1 ; mix tracer fields consistent with PBL option (exch_h)
+ sf_surface_mosaic                   option to mosaic landuse categories for Noah LSM            
+                                     = 0 ; default; use dominant category only
+                                     = 1 ; use mosaic landuse categories
+ mosaic_cat                          = 3 ; number of mosaic landuse categories in a grid cell
 
  cu_physics (max_dom)                cumulus option
                                      = 0, no cumulus
@@ -642,8 +695,14 @@ Namelist variables for controlling the adaptive time step option:
                                                   0 = without snow-cover effect
  icloud                              = 1,	; cloud effect to the optical depth in radiation
                                                   (only works for ra_sw_physics = 1,4 and ra_lw_physics = 1,4)
-                                                  1 = with cloud effect
+                                                  Since 3.6, this also controls the cloud fraction options
+                                                  1 = with cloud effect, and use cloud fraction option 1
+                                                      (Xu-Randall method) 
                                                   0 = without cloud effect
+                                                  2 = with cloud effect, and use cloud fraction option 2
+ cu_rad_feedback (max_dom)           = .false.  ; sub-grid cloud effect to the optical depth in radiation
+                                                  currently it works only for GF, G3, GD and KF scheme
+                                                  One also needs to set cu_diag = 1 for GF, G3 and GD schemes
  swrad_scat                          = 1.       ; scattering tuning parameter (default 1. is 1.e-5 m2/kg)
                                                   (works for ra_sw_physics = 1 option only)
  surface_input_source                = 1,	; where landuse and soil category data come from:
@@ -677,10 +736,12 @@ Namelist variables for controlling the adaptive time step option:
  ensdim                              = 144      ; G-D only
                                                   These are recommended numbers. If you would like to use
                                                   any other number, consult the code, know what you are doing.
- seaice_threshold                    = 271      ; tsk < seaice_threshold, if water point and 5-layer slab
+ seaice_threshold                    = 100.     ; tsk < seaice_threshold, if water point and 5-layer slab
                                                 ; scheme, set to land point and permanent ice; if water point
                                                 ; and Noah scheme, set to land point, permanent ice, set temps
-                                                ; from 3 m to surface, and set smois and sh2o
+                                                ; from 2 m to surface, and set smois and sh2o. The default value has changed
+                                                ; from 271 to 100 K in v3.5.1 to avoid mixed-up use with fractional seaice input
+                                                ; Used by land model option 1,2,3,4 and 8
  sst_update                          = 0        ; time-varying sea-surface temp (0=no, 1=yes). If selected real 
                                                 ; puts SST, XICE, ALBEDO and VEGFRA in wrflowinp_d01 file, and wrf updates 
                                                 ; these from it at same interval as boundary file. Also requires
@@ -691,6 +752,7 @@ Namelist variables for controlling the adaptive time step option:
                                                 ; (must be used for NMM and recommended for sst_update=1)
  rdmaxalb                            = .true.   ; use snow albedo from geogrid; false means using values from table
  rdlai2d                             = .false.  ; use LAI from input; false means using values from table
+                                                  if sst_update=1, LAI will also be in wrflowinp file
  bucket_mm                           = -1.      ; bucket reset value for water accumulations (value in mm, -1.=inactive)
  bucket_J                            = -1.      ; bucket reset value for energy accumulations (value in J, -1.=inactive)
  tmn_update                          = 0        ; update deep soil temperature (1, yes; 0, no)
@@ -720,6 +782,7 @@ Namelist variables for controlling the adaptive time step option:
                                                 ;             =2: z0 from Davis et al (2008), zt & zq from Garratt (1992)
  fractional_seaice                   = 0        ; treat sea-ice as fractional field (1) or ice/no-ice flag (0)
                                                   works for sf_sfclay_physics=1,2,5,or 7.
+                                                  If fractional_seaice = 1, also set seaice_threshold = 0.
  seaice_albedo_opt                   = 0        ; option to set albedo over sea ice
                                                 ; 0 = seaice albedo is a constant value from namelist option seaice_albedo_default
                                                 ; 1 = seaice albedo is f(Tair,Tskin,Snow) follwing Mills (2011) for Arctic Ocean
@@ -748,9 +811,17 @@ Namelist variables for controlling the adaptive time step option:
  do_radar_ref			     = 0, 	; 1 = allows radar reflectivity to be computed using mp-scheme-specific
  						  parameters.  Currently works for mp_physics = 2,4,6,7,8,10,14,16
 				
-
-Options for lightning parameterization:
-
+Namelist variables for lake module: 
+
+ sf_lake_physics(max_dom)            = 1,       ; lake model on/off 
+ lakedepth_default(max_dom)          = 50,      ; default lake depth (If there is no lake_depth information in the input data, then lake depth 
+                                                  is assumed to be 50m)  
+ lake_min_elev(max_dom)              = 5,       ; minimum elevation of lakes. May be used to determine whether a water point is a lake in the absence of lake
+                                                  category. If the landuse type includes 'lake' (i.e. Modis_lake and USGS_LAKE), this variable is of no effects. 
+ use_lakedepth                       = 1,       ; option to use lake depth data. Lake depth data is available from 3.6 geogrid program. If one didn't process
+                                                  the lake depth data, but this switch is set to 1, the program will stop and tell one to go back to geogrid
+                                                  program. 
+                                                  = 0, do not use lake depth data.
  lightning_option (max_dom)                     ; Lightning parameterization option to allow flash rate prediction without chemistry
                                      = 0        ; off
                                      = 1        ; PR92 based on maximum w, redistributes flashes within dBZ > 20 (for convection resolved runs; must also use 
@@ -781,18 +852,11 @@ Options for lightning parameterization:
 
 Options for wind turbine drag parameterization:
 
- td_turbgridid                      = -1        ; which grid id has turbines in it
- td_hubheight                       = 100.      ; hub height (m)
- td_diameter                        = 60.       ; turbine diameter (m)
- td_stdthrcoef                      = .158      ; standing thrust coefficient
- td_cutinspeed                      = 4.        ; cut-in speed (m/s)
- td_cutoutspeed                     = 27.       ; cut-out speed (m/s)
- td_power                           = 2.        ; turbine power (MW)
- td_turbpercell                     = 1.        ; number of turbines per cell
- td_ewfx                            = 0         ; extent of wind farm in x-cells
- td_ewfy                            = 0         ; extent of wind farm in y-cells
- td_pwfx                            = 1         ; southwest corner of wind farm in x-cells
- td_pwfy                            = 1         ; southwest corner of wind farm in y-cells
+ windfarm_opt                       = 0         ; 1 = Simulates the effects of wind turbines in the atmospheric evolution
+ windfarm_ij                        = 0         ; whether to use lat-lon or i-j coordinate as wind turbine locations    
+                                                ; 0 = The coordinate of the turbines are defined in terms of lat-lon
+                                                ; 1 = The coordinate of the turbines are defined in terms of grid points
+
 
 Options for stochastic kinetic-energy backscatter scheme:
 
@@ -806,6 +870,20 @@ Options for stochastic kinetic-energy backscatter scheme:
                                                   change the run. When running an ensemble, this can be
                                                   ensemble member number, so that each ensemble member gets a
                                                   different random number stream, hence a different perturbed run.
+ ztau_psi                           = 10800.0   ; decorr. time of noise for psi perturb
+ ztau_t                             = 10800.0   ; decorr. time of noise for theta perturb
+ rexponent_psi                      = -1.83     ; spectral slope of forcing for psi
+ rexponent_t                        = -1.83     ; spectral slope of forcing for theta
+ zsigma2_eps                        = 0.0833    ; variance of noise for psi perturb
+ zsigma2_eta                        = 0.0833    ; variance of noise for theta perturb
+ kminforc                           = 1         ; min. forcing wavenumber in lon. for psi perturb
+ lminforc                           = 1         ; min. forcing wavenumber in lat. for psi perturb
+ kminforct                          = 1         ; min. forcing wavenumber in lon. for theta perturb
+ lminforct                          = 1         ; min. forcing wavenumber in lat. for theta perturb
+ kmaxforc                           = 1000000   ; max. forcing wavenumber in lon. for psi perturb
+ lmaxforc                           = 1000000   ; max. forcing wavenumber in lat. for psi perturb
+ kmaxforct                          = 1000000   ; max. forcing wavenumber in lon. for theta perturb
+ lmaxforct                          = 1000000   ; max. forcing wavenumber in lat. for theta perturb
 
 Options for use with the Noah-MP Land Surface Model:
 
@@ -965,6 +1043,8 @@ The following are for observation nudging:
  obs_sfcfact                         = 1.0      ; Scale factor applied to time window for surface obs
  obs_sfcfacr                         = 1.0      ; Scale factor applied to horiz radius of influence for surface obs
  obs_dpsmx                           = 7.5      ; Max pressure change (cb) allowed within horiz radius of influence
+
+ obs_scl_neg_qv_innov                = 0        ; 1 = prevent to nudge toward negative QV 
  /
 
  &scm
@@ -994,7 +1074,7 @@ The following are for observation nudging:
  rk_ord                              = 3,	; time-integration scheme option:
                                                   2 = Runge-Kutta 2nd order
                                                   3 = Runge-Kutta 3rd order
- diff_opt                            = 0,	; turbulence and mixing option:
+ diff_opt(max_dom)                   = 0,	; turbulence and mixing option:
                                                   0 = no turbulence or explicit
                                                       spatial numerical filters (km_opt IS IGNORED).
                                                   1 = evaluates 2nd order
@@ -1006,7 +1086,7 @@ The following are for observation nudging:
                                                       physical space (stress form) (x,y,z).
                                                       turbulence parameterization is chosen
                                                       by specifying km_opt.
- km_opt                              = 1,	; eddy coefficient option
+ km_opt(max_dom)                     = 1,	; eddy coefficient option
                                                   1 = constant (use khdif kvdif)
                                                   2 = 1.5 order TKE closure (3D)
                                                   3 = Smagorinsky first order closure (3D)
@@ -1037,6 +1117,7 @@ The following are for observation nudging:
  base_lapse                          = 50.,     ; real-data, em ONLY, lapse rate (K), DO NOT CHANGE
  iso_temp                            = 0.,      ; real-data, em ONLY, reference temp in stratosphere
  use_baseparam_fr_nml                = .f.,     ; whether to use base state parameters from the namelist
+ use_input_w                         = .f.,     ; whether to use vertical velocity from input file
  khdif (max_dom)                     = 0,	; horizontal diffusion constant (m^2/s)
  kvdif (max_dom)                     = 0,	; vertical diffusion constant (m^2/s)
  smdiv (max_dom)                     = 0.1,	; divergence damping (0.1 is typical)
@@ -1116,9 +1197,13 @@ The following are for observation nudging:
  nested (max_dom)                    = .false., ; nested boundary conditions (must be used for nests)
  polar                               = .false., ; polar boundary condition
                                                   (v=0 at polarward-most v-point)
- perturb_bdy                        = 0         ; No boundary perturbations
-                                      1         ; Use SKEBS pattern for boundary perturbations
-                                      2         ; Use other user-provided pattern for boundary perturbations
+ perturb_bdy                         = 0        ; No boundary perturbations
+                                       1        ; Use SKEBS pattern for boundary perturbations
+                                       2        ; Use other user-provided pattern for boundary perturbations
+ have_bcs_moist                      = .false., ; model run after ndown only: do not use microphysics variables in bdy file
+                                     = .true. , ; use microphysics variables in bdy file
+ have_bcs_scalar                     = .false., ; model run after ndown only: do not use scalar variables in bdy file
+                                     = .true. , ; use scalar variables in bdy file
 
  euler_adv                           = .false., ; conservative Eulerian passive advection (NMM only)
  idtadt                              = 1,       ; fundamental timesteps between calls to Euler advection, dynamics (NMM only)
@@ -1175,3 +1260,17 @@ The following are for observation nudging:
                                                   packages.
  /
 
+AFWA diagnostics:
+&afwa
+afwa_diag_opt (max_dom)              = 0,       ; AFWA Diagnostic option, 1: on
+afwa_ptype_opt (max_dom)             = 0,       ; Precip type option, 1: on
+afwa_vil_opt (max_dom)               = 0,       ; Vert Int Liquid option, 1: on
+afwa_radar_opt (max_dom)             = 0,       ; Radar option, 1: on
+afwa_severe_opt (max_dom)            = 0,       ; Severe Wx option, 1: on
+afwa_icing_opt (max_dom)             = 0,       ; Icing option, 1: on
+afwa_vis_opt (max_dom)               = 0,       ; Visibility option, 1: on
+afwa_cloud_opt (max_dom)             = 0,       ; Cloud option, 1: on
+afwa_ptype_ccn_tmp                   = 264.15,  ; CCN temperature for precipitation type calculation
+afwa_ptype_tot_melt                  = 50,      ; Total melting energy for precipitation type calculation
+afwa_ccn_conc                        = 1.0E8,   ; CCN concentration
+afwa_hail_opt                        = 0,       ; Hail/Graupel switch, 1:hail, 0:graupel
diff --git a/wrfv2_fire/run/bulkdens.asc_s_0_03_0_9 b/wrfv2_fire/run/bulkdens.asc_s_0_03_0_9
new file mode 100644
index 00000000..58171599
--- /dev/null
+++ b/wrfv2_fire/run/bulkdens.asc_s_0_03_0_9
@@ -0,0 +1,39 @@
+  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01
+  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01
+  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01
+  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01
+  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01
+  0.10000E+01  0.10000E+01  0.10000E+01  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.87368E+00  0.87072E+00  0.86777E+00
+  0.86483E+00  0.86189E+00  0.85897E+00  0.85606E+00  0.85316E+00  0.85026E+00
+  0.84738E+00  0.84451E+00  0.84164E+00  0.83879E+00  0.83595E+00  0.83311E+00
+  0.83029E+00  0.82747E+00  0.82467E+00  0.82187E+00  0.81908E+00  0.81631E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.61183E+00  0.61183E+00  0.61183E+00
+  0.61183E+00  0.61183E+00  0.61183E+00  0.61183E+00  0.61183E+00  0.61183E+00
+  0.61183E+00  0.61183E+00  0.61183E+00  0.61183E+00  0.61183E+00  0.61183E+00
+  0.61183E+00  0.61183E+00  0.61183E+00  0.61183E+00  0.61183E+00  0.51790E+00
+  0.45557E+00  0.40075E+00  0.35252E+00  0.31010E+00  0.27278E+00  0.23995E+00
+  0.21108E+00  0.18567E+00  0.16333E+00  0.14367E+00  0.12638E+00  0.11118E+00
+  0.90000E+00  0.89500E+00  0.88500E+00  0.88200E+00  0.87500E+00  0.86500E+00
+  0.85500E+00  0.84200E+00  0.83000E+00  0.81500E+00  0.80500E+00  0.78600E+00
+  0.76500E+00  0.73000E+00  0.69500E+00  0.61183E+00  0.54000E+00  0.46000E+00
+  0.40000E+00  0.33000E+00  0.28000E+00  0.24000E+00  0.20000E+00  0.16000E+00
+  0.13500E+00  0.11000E+00  0.90000E-01  0.75000E-01  0.60000E-01  0.50000E-01
+  0.40000E-01  0.37500E-01  0.35000E-01  0.40000E+00  0.40000E+00  0.40000E+00
+  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00
+  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00
+  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00
+  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00
+  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00  0.40000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00  0.90000E+00
+  0.90000E+00  0.90000E+00  0.90000E+00
diff --git a/wrfv2_fire/run/bulkradii.asc_s_0_03_0_9 b/wrfv2_fire/run/bulkradii.asc_s_0_03_0_9
new file mode 100644
index 00000000..85032be0
--- /dev/null
+++ b/wrfv2_fire/run/bulkradii.asc_s_0_03_0_9
@@ -0,0 +1,39 @@
+  0.20000E-03  0.25198E-03  0.31748E-03  0.40000E-03  0.50397E-03  0.63496E-03
+  0.80000E-03  0.10079E-02  0.12699E-02  0.16000E-02  0.20159E-02  0.25398E-02
+  0.32000E-02  0.40317E-02  0.50797E-02  0.64000E-02  0.80635E-02  0.10159E-01
+  0.12800E-01  0.16127E-01  0.20319E-01  0.25600E-01  0.32254E-01  0.40637E-01
+  0.51200E-01  0.64508E-01  0.81275E-01  0.10240E+00  0.12902E+00  0.16255E+00
+  0.20480E+00  0.25803E+00  0.32510E+00  0.57452E-03  0.72384E-03  0.91199E-03
+  0.11490E-02  0.14477E-02  0.18240E-02  0.22981E-02  0.28954E-02  0.36479E-02
+  0.45961E-02  0.57908E-02  0.72959E-02  0.11572E-01  0.14770E-01  0.18851E-01
+  0.24060E-01  0.30709E-01  0.39194E-01  0.50025E-01  0.63848E-01  0.81491E-01
+  0.10401E+00  0.13275E+00  0.16943E+00  0.21625E+00  0.27601E+00  0.35228E+00
+  0.44962E+00  0.57387E+00  0.73244E+00  0.93484E+00  0.11932E+01  0.15229E+01
+  0.20715E-03  0.26099E-03  0.32912E-03  0.43555E-03  0.57638E-03  0.76276E-03
+  0.10094E-02  0.13358E-02  0.17677E-02  0.23394E-02  0.30958E-02  0.40969E-02
+  0.54216E-02  0.71748E-02  0.94948E-02  0.12565E-01  0.16628E-01  0.22005E-01
+  0.29120E-01  0.38537E-01  0.50998E-01  0.67488E-01  0.89311E-01  0.11819E+00
+  0.15641E+00  0.20698E+00  0.27391E+00  0.36249E+00  0.47970E+00  0.63481E+00
+  0.84009E+00  0.11117E+01  0.14712E+01  0.23559E-03  0.29682E-03  0.37397E-03
+  0.47118E-03  0.59365E-03  0.74795E-03  0.95894E-03  0.12777E-02  0.17025E-02
+  0.22685E-02  0.30227E-02  0.40275E-02  0.53665E-02  0.71506E-02  0.95278E-02
+  0.12695E-01  0.16916E-01  0.22539E-01  0.30032E-01  0.40017E-01  0.70019E-01
+  0.98384E-01  0.13824E+00  0.19424E+00  0.27293E+00  0.38350E+00  0.53885E+00
+  0.75714E+00  0.10639E+01  0.14948E+01  0.21004E+01  0.29513E+01  0.41469E+01
+  0.20715E-03  0.26148E-03  0.33067E-03  0.41710E-03  0.52691E-03  0.66640E-03
+  0.84289E-03  0.10674E-02  0.13513E-02  0.17129E-02  0.21670E-02  0.27521E-02
+  0.34989E-02  0.44777E-02  0.57347E-02  0.75389E-02  0.99020E-02  0.13161E-01
+  0.17372E-01  0.23337E-01  0.31058E-01  0.41194E-01  0.55153E-01  0.74854E-01
+  0.99806E-01  0.13463E+00  0.18136E+00  0.24282E+00  0.32955E+00  0.44123E+00
+  0.59884E+00  0.77090E+00  0.99387E+00  0.27144E-03  0.34200E-03  0.43089E-03
+  0.54288E-03  0.68399E-03  0.86177E-03  0.10858E-02  0.13680E-02  0.17235E-02
+  0.21715E-02  0.27360E-02  0.34471E-02  0.43431E-02  0.54719E-02  0.68942E-02
+  0.86861E-02  0.10944E-01  0.13788E-01  0.17372E-01  0.21888E-01  0.27577E-01
+  0.34745E-01  0.43775E-01  0.55154E-01  0.69489E-01  0.87551E-01  0.11031E+00
+  0.13898E+00  0.17510E+00  0.22061E+00  0.27796E+00  0.35020E+00  0.44123E+00
+  0.20715E-03  0.26099E-03  0.32883E-03  0.41430E-03  0.52198E-03  0.65766E-03
+  0.82860E-03  0.10440E-02  0.13153E-02  0.16572E-02  0.20879E-02  0.26306E-02
+  0.33144E-02  0.41759E-02  0.52613E-02  0.66288E-02  0.83517E-02  0.10523E-01
+  0.13258E-01  0.16703E-01  0.21045E-01  0.26515E-01  0.33407E-01  0.42090E-01
+  0.53030E-01  0.66814E-01  0.84180E-01  0.10606E+00  0.13363E+00  0.16836E+00
+  0.21212E+00  0.26725E+00  0.33672E+00
diff --git a/wrfv2_fire/run/capacity.asc b/wrfv2_fire/run/capacity.asc
new file mode 100644
index 00000000..168dcb14
--- /dev/null
+++ b/wrfv2_fire/run/capacity.asc
@@ -0,0 +1,39 @@
+  0.20000E-03  0.25198E-03  0.31748E-03  0.40000E-03  0.50397E-03  0.63496E-03
+  0.80000E-03  0.10079E-02  0.12699E-02  0.16000E-02  0.20159E-02  0.25398E-02
+  0.32000E-02  0.40317E-02  0.50797E-02  0.64000E-02  0.80635E-02  0.10159E-01
+  0.12800E-01  0.16127E-01  0.20319E-01  0.25600E-01  0.32254E-01  0.40637E-01
+  0.51200E-01  0.64508E-01  0.81275E-01  0.10240E+00  0.12902E+00  0.16255E+00
+  0.20480E+00  0.25803E+00  0.32510E+00  0.31936E-03  0.40397E-03  0.51099E-03
+  0.64638E-03  0.81764E-03  0.10343E-02  0.13084E-02  0.16551E-02  0.20937E-02
+  0.26486E-02  0.33506E-02  0.42387E-02  0.64360E-02  0.81426E-02  0.10302E-01
+  0.13035E-01  0.16494E-01  0.20872E-01  0.26412E-01  0.33426E-01  0.42304E-01
+  0.53543E-01  0.67770E-01  0.85783E-01  0.10859E+00  0.13746E+00  0.17403E+00
+  0.22032E+00  0.27895E+00  0.35319E+00  0.44722E+00  0.56630E+00  0.71712E+00
+  0.13188E-03  0.16615E-03  0.20953E-03  0.27728E-03  0.36694E-03  0.48559E-03
+  0.64261E-03  0.85040E-03  0.11254E-02  0.14893E-02  0.19709E-02  0.26082E-02
+  0.34515E-02  0.45676E-02  0.60446E-02  0.79991E-02  0.10586E-01  0.14009E-01
+  0.18539E-01  0.24533E-01  0.32466E-01  0.42964E-01  0.56857E-01  0.75242E-01
+  0.99573E-01  0.13177E+00  0.17438E+00  0.23077E+00  0.30539E+00  0.40414E+00
+  0.53482E+00  0.70775E+00  0.93661E+00  0.14998E-03  0.18896E-03  0.23808E-03
+  0.29996E-03  0.37793E-03  0.47616E-03  0.61048E-03  0.81343E-03  0.10839E-02
+  0.14442E-02  0.19243E-02  0.25640E-02  0.34164E-02  0.45522E-02  0.60656E-02
+  0.80820E-02  0.10769E-01  0.14349E-01  0.19119E-01  0.25475E-01  0.44576E-01
+  0.62633E-01  0.88006E-01  0.12366E+00  0.17375E+00  0.24414E+00  0.34304E+00
+  0.48201E+00  0.67728E+00  0.95164E+00  0.13372E+01  0.18788E+01  0.26400E+01
+  0.92832E-03  0.11696E-02  0.14736E-02  0.18566E-02  0.23392E-02  0.29472E-02
+  0.37133E-02  0.46784E-02  0.58944E-02  0.74265E-02  0.93569E-02  0.11789E-01
+  0.14853E-01  0.18714E-01  0.23578E-01  0.29706E-01  0.37427E-01  0.47156E-01
+  0.59412E-01  0.74855E-01  0.94311E-01  0.11882E+00  0.14971E+00  0.18862E+00
+  0.23765E+00  0.29942E+00  0.37724E+00  0.47530E+00  0.59884E+00  0.75449E+00
+  0.95060E+00  0.11977E+01  0.15090E+01  0.27144E-03  0.34200E-03  0.43089E-03
+  0.54288E-03  0.68399E-03  0.86177E-03  0.10858E-02  0.13680E-02  0.17235E-02
+  0.21715E-02  0.27360E-02  0.34471E-02  0.43431E-02  0.54719E-02  0.68942E-02
+  0.86861E-02  0.10944E-01  0.13788E-01  0.17372E-01  0.21888E-01  0.27577E-01
+  0.34745E-01  0.43775E-01  0.55154E-01  0.69489E-01  0.87551E-01  0.11031E+00
+  0.13898E+00  0.17510E+00  0.22061E+00  0.27796E+00  0.35020E+00  0.44123E+00
+  0.20715E-03  0.26099E-03  0.32883E-03  0.41430E-03  0.52198E-03  0.65766E-03
+  0.82860E-03  0.10440E-02  0.13153E-02  0.16572E-02  0.20879E-02  0.26306E-02
+  0.33144E-02  0.41759E-02  0.52613E-02  0.66288E-02  0.83517E-02  0.10523E-01
+  0.13258E-01  0.16703E-01  0.21045E-01  0.26515E-01  0.33407E-01  0.42090E-01
+  0.53030E-01  0.66814E-01  0.84180E-01  0.10606E+00  0.13363E+00  0.16836E+00
+  0.21212E+00  0.26725E+00  0.33672E+00
diff --git a/wrfv2_fire/run/coeff_p.asc b/wrfv2_fire/run/coeff_p.asc
new file mode 100644
index 00000000..3041cd12
--- /dev/null
+++ b/wrfv2_fire/run/coeff_p.asc
@@ -0,0 +1,3080 @@
+     1     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     1     7     1  0.11047003E-17  0.10307805E-17  0.10717125E+01
+     1     7     2  0.20305159E-18  0.19335881E-18  0.10501284E+01
+     1     7     3  0.22336779E-19  0.21895637E-19  0.10201475E+01
+     1     7     4  0.53877433E-19  0.54466284E-19  0.98918871E+00
+     1     7     5  0.10267976E-18  0.10666196E-18  0.96266528E+00
+     1     7     6  0.10539327E-18  0.11363814E-18  0.92744630E+00
+     1     7     7  0.22952905E-19  0.25917971E-19  0.88559810E+00
+     1     8     1  0.42579908E-17  0.39830377E-17  0.10690310E+01
+     1     8     2  0.78736353E-18  0.73962352E-18  0.10645464E+01
+     1     8     3  0.84169334E-19  0.80705885E-19  0.10429145E+01
+     1     8     4  0.20171583E-18  0.19913722E-18  0.10129489E+01
+     1     8     5  0.42344403E-18  0.43133287E-18  0.98171053E+00
+     1     8     6  0.64943211E-18  0.68310509E-18  0.95070600E+00
+     1     8     7  0.45809677E-18  0.49923098E-18  0.91760486E+00
+     1     8     8  0.40035419E-18  0.41176407E-18  0.97229026E+00
+     1     9     1  0.16701938E-16  0.15248833E-16  0.10952929E+01
+     1     9     2  0.29880862E-17  0.28106930E-17  0.10631137E+01
+     1     9     3  0.31331301E-18  0.29590490E-18  0.10588301E+01
+     1     9     4  0.72844791E-18  0.70243626E-18  0.10370306E+01
+     1     9     5  0.15232363E-17  0.15145838E-17  0.10057128E+01
+     1     9     6  0.26451296E-17  0.27144561E-17  0.97446026E+00
+     1     9     7  0.28563333E-17  0.30392675E-17  0.93980978E+00
+     1     9     8  0.69908159E-17  0.71204711E-17  0.98179121E+00
+     1     9     9  0.19622678E-35  0.19725004E-35  0.99481238E+00
+     1    10     1  0.63516613E-16  0.59072763E-16  0.10752267E+01
+     1    10     2  0.11934319E-16  0.10937587E-16  0.10911291E+01
+     1    10     3  0.12479908E-17  0.11797182E-17  0.10578720E+01
+     1    10     4  0.30273545E-17  0.28735122E-17  0.10535381E+01
+     1    10     5  0.64589377E-17  0.62605124E-17  0.10316947E+01
+     1    10     6  0.11019624E-16  0.11000577E-16  0.10017315E+01
+     1    10     7  0.12361610E-16  0.12799918E-16  0.96575697E+00
+     1    10     8  0.51043805E-16  0.52303324E-16  0.97591894E+00
+     1    10     9  0.22154424E-34  0.22249205E-34  0.99574004E+00
+     1    10    10  0.00000000E+00  0.00000000E+00  0.99449213E+00
+     1    11     1  0.28564705E-15  0.26894579E-15  0.10620990E+01
+     1    11     2  0.54852568E-16  0.51244508E-16  0.10704087E+01
+     1    11     3  0.63864068E-17  0.58735185E-17  0.10873222E+01
+     1    11     4  0.15159802E-16  0.14401090E-16  0.10526843E+01
+     1    11     5  0.31201399E-16  0.29765957E-16  0.10482243E+01
+     1    11     6  0.48247015E-16  0.47036552E-16  0.10257345E+01
+     1    11     7  0.49406151E-16  0.49808935E-16  0.99191343E+00
+     1    11     8  0.37668809E-15  0.38902233E-15  0.96829426E+00
+     1    11     9  0.10642375E-33  0.10674586E-33  0.99698253E+00
+     1    11    10  0.00000000E+00  0.00000000E+00  0.99512340E+00
+     1    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+     1    12     1  0.12028450E-14  0.11427086E-14  0.10526262E+01
+     1    12     2  0.22952698E-15  0.21713845E-15  0.10570536E+01
+     1    12     3  0.25685426E-16  0.24094237E-16  0.10660402E+01
+     1    12     4  0.61196602E-16  0.56434463E-16  0.10843835E+01
+     1    12     5  0.11537757E-15  0.11016952E-15  0.10472730E+01
+     1    12     6  0.17369910E-15  0.16652690E-15  0.10430693E+01
+     1    12     7  0.17914172E-15  0.17576154E-15  0.10192317E+01
+     1    12     8  0.32932771E-14  0.34386689E-14  0.95771860E+00
+     1    12     9  0.10920862E-14  0.11111316E-14  0.98285946E+00
+     1    12    10  0.00000000E+00  0.00000000E+00  0.99640426E+00
+     1    12    11  0.00000000E+00  0.00000000E+00  0.99485003E+00
+     1    12    12  0.00000000E+00  0.00000000E+00  0.99376764E+00
+     1    13     1  0.41655628E-14  0.39855761E-14  0.10451595E+01
+     1    13     2  0.78666976E-15  0.75097947E-15  0.10475250E+01
+     1    13     3  0.85898755E-16  0.81631267E-16  0.10522776E+01
+     1    13     4  0.20063906E-15  0.18894806E-15  0.10618742E+01
+     1    13     5  0.39654275E-15  0.36667859E-15  0.10814451E+01
+     1    13     6  0.57978208E-15  0.55625756E-15  0.10422907E+01
+     1    13     7  0.62039256E-15  0.59782392E-15  0.10377513E+01
+     1    13     8  0.62527155E-14  0.61967083E-14  0.10090382E+01
+     1    13     9  0.17656496E-13  0.18887562E-13  0.93482132E+00
+     1    13    10  0.00000000E+00  0.00000000E+00  0.82119350E+00
+     1    13    11  0.00000000E+00  0.00000000E+00  0.93556432E+00
+     1    13    12  0.00000000E+00  0.00000000E+00  0.99557497E+00
+     1    13    13  0.00000000E+00  0.00000000E+00  0.99300243E+00
+     1    14     1  0.14040771E-13  0.13515076E-13  0.10388970E+01
+     1    14     2  0.26320729E-14  0.25304688E-14  0.10401523E+01
+     1    14     3  0.28247363E-15  0.27091343E-15  0.10426712E+01
+     1    14     4  0.65076845E-15  0.62109689E-15  0.10477728E+01
+     1    14     5  0.12669000E-14  0.11974439E-14  0.10580036E+01
+     1    14     6  0.19607542E-14  0.18174611E-14  0.10788424E+01
+     1    14     7  0.20554044E-14  0.19813783E-14  0.10373609E+01
+     1    14     8  0.21635627E-13  0.22121467E-13  0.97803764E+00
+     1    14     9  0.96687087E-14  0.10193347E-13  0.94853134E+00
+     1    14    10  0.00000000E+00  0.00000000E+00  0.70985829E+00
+     1    14    11  0.00000000E+00  0.00000000E+00  0.52643605E+00
+     1    14    12  0.00000000E+00  0.00000000E+00  0.86933926E+00
+     1    14    13  0.00000000E+00  0.00000000E+00  0.10090678E+01
+     1    14    14  0.00000000E+00  0.00000000E+00  0.99218681E+00
+     1    15     1  0.46541247E-13  0.45039767E-13  0.10333368E+01
+     1    15     2  0.86669749E-14  0.83819638E-14  0.10340029E+01
+     1    15     3  0.91502209E-15  0.88379020E-15  0.10353386E+01
+     1    15     4  0.20811648E-14  0.20049317E-14  0.10380228E+01
+     1    15     5  0.39981024E-14  0.38317408E-14  0.10434167E+01
+     1    15     6  0.61108476E-14  0.57960017E-14  0.10543212E+01
+     1    15     7  0.66093050E-14  0.61350205E-14  0.10773077E+01
+     1    15     8  0.22891717E-13  0.22956174E-13  0.99719217E+00
+     1    15     9  0.44862149E-13  0.46113731E-13  0.97285881E+00
+     1    15    10  0.00000000E+00  0.00000000E+00  0.63977360E+00
+     1    15    11  0.00000000E+00  0.00000000E+00  0.43915858E+00
+     1    15    12  0.00000000E+00  0.00000000E+00  0.89587341E+00
+     1    15    13  0.00000000E+00  0.00000000E+00  0.92805872E+00
+     1    15    14  0.00000000E+00  0.00000000E+00  0.95347945E+00
+     1    15    15  0.00000000E+00  0.00000000E+00  0.10003488E+01
+     1    16     1  0.15133542E-12  0.14718401E-12  0.10282055E+01
+     1    16     2  0.28014913E-13  0.27237079E-13  0.10285579E+01
+     1    16     3  0.29123582E-14  0.28295478E-14  0.10292663E+01
+     1    16     4  0.65422256E-14  0.63474338E-14  0.10306883E+01
+     1    16     5  0.12398905E-13  0.11996472E-13  0.10335459E+01
+     1    16     6  0.18685768E-13  0.17979284E-13  0.10392943E+01
+     1    16     7  0.18277416E-13  0.17454038E-13  0.10471741E+01
+     1    16     8  0.58003820E-13  0.54159018E-13  0.10709910E+01
+     1    16     9  0.26577737E-12  0.26593639E-12  0.99940203E+00
+     1    16    10  0.00000000E+00  0.00000000E+00  0.68548151E+00
+     1    16    11  0.00000000E+00  0.00000000E+00  0.45779332E+00
+     1    16    12  0.00000000E+00  0.00000000E+00  0.90358367E+00
+     1    16    13  0.00000000E+00  0.00000000E+00  0.85241134E+00
+     1    16    14  0.00000000E+00  0.00000000E+00  0.64492282E+00
+     1    16    15  0.00000000E+00  0.00000000E+00  0.88262484E+00
+     1    16    16  0.00000000E+00  0.00000000E+00  0.96504988E+00
+     1    17     1  0.48272780E-12  0.47170734E-12  0.10233629E+01
+     1    17     2  0.88890004E-13  0.86844967E-13  0.10235481E+01
+     1    17     3  0.91090225E-14  0.88962035E-14  0.10239225E+01
+     1    17     4  0.20215861E-13  0.19729033E-13  0.10246757E+01
+     1    17     5  0.37762644E-13  0.36798980E-13  0.10261872E+01
+     1    17     6  0.55873782E-13  0.54289011E-13  0.10291914E+01
+     1    17     7  0.51763568E-13  0.50460568E-13  0.10258221E+01
+     1    17     8  0.47577702E-12  0.46981261E-12  0.10126953E+01
+     1    17     9  0.54954369E-12  0.51338856E-12  0.10704245E+01
+     1    17    10  0.00000000E+00  0.00000000E+00  0.64318717E+00
+     1    17    11  0.00000000E+00  0.00000000E+00  0.43613131E+00
+     1    17    12  0.00000000E+00  0.00000000E+00  0.82081966E+00
+     1    17    13  0.00000000E+00  0.00000000E+00  0.83349376E+00
+     1    17    14  0.00000000E+00  0.00000000E+00  0.63756211E+00
+     1    17    15  0.00000000E+00  0.00000000E+00  0.65785445E+00
+     1    17    16  0.00000000E+00  0.00000000E+00  0.10677681E+01
+     1    17    17  0.00000000E+00  0.00000000E+00  0.99050797E+00
+     1    18     1  0.15153244E-11  0.14874629E-11  0.10187308E+01
+     1    18     2  0.27773983E-12  0.27260728E-12  0.10188277E+01
+     1    18     3  0.28093502E-13  0.27568998E-13  0.10190251E+01
+     1    18     4  0.61643057E-13  0.60468484E-13  0.10194245E+01
+     1    18     5  0.11349789E-12  0.11124775E-12  0.10202264E+01
+     1    18     6  0.16444054E-12  0.16095301E-12  0.10216680E+01
+     1    18     7  0.30688184E-12  0.30565368E-12  0.10040181E+01
+     1    18     8  0.26088089E-11  0.25786177E-11  0.10117083E+01
+     1    18     9  0.15191835E-12  0.14492302E-12  0.10482693E+01
+     1    18    10  0.00000000E+00  0.00000000E+00  0.33281721E+00
+     1    18    11  0.00000000E+00  0.00000000E+00  0.23695460E+00
+     1    18    12  0.00000000E+00  0.00000000E+00  0.50359715E+00
+     1    18    13  0.00000000E+00  0.00000000E+00  0.67458613E+00
+     1    18    14  0.00000000E+00  0.00000000E+00  0.61393011E+00
+     1    18    15  0.00000000E+00  0.00000000E+00  0.59434079E+00
+     1    18    16  0.00000000E+00  0.00000000E+00  0.11042773E+01
+     1    18    17  0.00000000E+00  0.00000000E+00  0.10195210E+01
+     1    18    18  0.00000000E+00  0.00000000E+00  0.10596630E+01
+     2     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     2     7     1  0.21430840E-18  0.19996818E-18  0.10717125E+01
+     2     7     2  0.44882079E-17  0.42739609E-17  0.10501284E+01
+     2     7     3  0.12075258E-17  0.11836776E-17  0.10201475E+01
+     2     7     4  0.99433850E-18  0.10052061E-17  0.98918871E+00
+     2     7     5  0.24258901E-17  0.25199726E-17  0.96266528E+00
+     2     7     6  0.33428674E-17  0.36043784E-17  0.92744630E+00
+     2     7     7  0.98727937E-18  0.11148165E-17  0.88559810E+00
+     2     8     1  0.82263163E-18  0.76951147E-18  0.10690310E+01
+     2     8     2  0.17234955E-16  0.16189953E-16  0.10645464E+01
+     2     8     3  0.45919343E-17  0.44029827E-17  0.10429145E+01
+     2     8     4  0.37241900E-17  0.36765823E-17  0.10129489E+01
+     2     8     5  0.10050203E-16  0.10237440E-16  0.98171053E+00
+     2     8     6  0.21029275E-16  0.22119641E-16  0.95070600E+00
+     2     8     7  0.21158106E-16  0.23057971E-16  0.91760486E+00
+     2     8     8  0.20086616E-17  0.20659073E-17  0.97229026E+00
+     2     9     1  0.32169878E-17  0.29371028E-17  0.10952929E+01
+     2     9     2  0.64893105E-16  0.61040605E-16  0.10631137E+01
+     2     9     3  0.17270480E-16  0.16310908E-16  0.10588301E+01
+     2     9     4  0.13440218E-16  0.12960290E-16  0.10370306E+01
+     2     9     5  0.36183923E-16  0.35978385E-16  0.10057128E+01
+     2     9     6  0.86226920E-16  0.88486852E-16  0.97446026E+00
+     2     9     7  0.13681021E-15  0.14557223E-15  0.93980978E+00
+     2     9     8  0.36277858E-16  0.36950685E-16  0.98179121E+00
+     2     9     9  0.43120180E-35  0.43345037E-35  0.99481238E+00
+     2    10     1  0.12255191E-16  0.11397774E-16  0.10752267E+01
+     2    10     2  0.26056724E-15  0.23880515E-15  0.10911291E+01
+     2    10     3  0.68317149E-16  0.64579789E-16  0.10578720E+01
+     2    10     4  0.55880907E-16  0.53041184E-16  0.10535381E+01
+     2    10     5  0.15340855E-15  0.14869568E-15  0.10316947E+01
+     2    10     6  0.35896418E-15  0.35834370E-15  0.10017315E+01
+     2    10     7  0.59752704E-15  0.61871367E-15  0.96575697E+00
+     2    10     8  0.31600503E-15  0.32380254E-15  0.97591894E+00
+     2    10     9  0.56522620E-34  0.56764434E-34  0.99574004E+00
+     2    10    10  0.00000000E+00  0.00000000E+00  0.99449213E+00
+     2    11     1  0.55845762E-16  0.52580562E-16  0.10620990E+01
+     2    11     2  0.12229570E-14  0.11425141E-14  0.10704087E+01
+     2    11     3  0.34603390E-15  0.31824413E-15  0.10873222E+01
+     2    11     4  0.27974061E-15  0.26574026E-15  0.10526843E+01
+     2    11     5  0.73964904E-15  0.70562098E-15  0.10482243E+01
+     2    11     6  0.15660217E-14  0.15267320E-14  0.10257345E+01
+     2    11     7  0.23832259E-14  0.24026551E-14  0.99191343E+00
+     2    11     8  0.24171740E-14  0.24963218E-14  0.96829426E+00
+     2    11     9  0.27983246E-33  0.28067940E-33  0.99698253E+00
+     2    11    10  0.00000000E+00  0.00000000E+00  0.99512340E+00
+     2    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+     2    12     1  0.23504408E-15  0.22329301E-15  0.10526262E+01
+     2    12     2  0.50867569E-14  0.48122034E-14  0.10570536E+01
+     2    12     3  0.14061161E-14  0.13190084E-14  0.10660402E+01
+     2    12     4  0.11281558E-14  0.10403661E-14  0.10843835E+01
+     2    12     5  0.27314824E-14  0.26081855E-14  0.10472730E+01
+     2    12     6  0.56332524E-14  0.54006501E-14  0.10430693E+01
+     2    12     7  0.86491832E-14  0.84859837E-14  0.10192317E+01
+     2    12     8  0.19681356E-13  0.20550249E-13  0.95771860E+00
+     2    12     9  0.28455569E-14  0.28951819E-14  0.98285946E+00
+     2    12    10  0.00000000E+00  0.00000000E+00  0.99640426E+00
+     2    12    11  0.00000000E+00  0.00000000E+00  0.99485003E+00
+     2    12    12  0.00000000E+00  0.00000000E+00  0.99376764E+00
+     2    13     1  0.81083036E-15  0.77579579E-15  0.10451595E+01
+     2    13     2  0.17323860E-13  0.16537897E-13  0.10475250E+01
+     2    13     3  0.47226608E-14  0.44880369E-14  0.10522776E+01
+     2    13     4  0.36981181E-14  0.34826331E-14  0.10618742E+01
+     2    13     5  0.93874341E-14  0.86804539E-14  0.10814451E+01
+     2    13     6  0.18808405E-13  0.18045258E-13  0.10422907E+01
+     2    13     7  0.29986717E-13  0.28895860E-13  0.10377513E+01
+     2    13     8  0.64608765E-13  0.64030048E-13  0.10090382E+01
+     2    13     9  0.93177040E-13  0.99673636E-13  0.93482132E+00
+     2    13    10  0.00000000E+00  0.00000000E+00  0.82119350E+00
+     2    13    11  0.00000000E+00  0.00000000E+00  0.93556432E+00
+     2    13    12  0.00000000E+00  0.00000000E+00  0.99557497E+00
+     2    13    13  0.00000000E+00  0.00000000E+00  0.99300243E+00
+     2    14     1  0.27250125E-14  0.26229862E-14  0.10388970E+01
+     2    14     2  0.57694068E-13  0.55466944E-13  0.10401523E+01
+     2    14     3  0.15580258E-13  0.14942638E-13  0.10426712E+01
+     2    14     4  0.11992892E-13  0.11446080E-13  0.10477728E+01
+     2    14     5  0.29988667E-13  0.28344580E-13  0.10580036E+01
+     2    14     6  0.63619257E-13  0.58969924E-13  0.10788424E+01
+     2    14     7  0.99436686E-13  0.95855436E-13  0.10373609E+01
+     2    14     8  0.13565260E-12  0.13869875E-12  0.97803764E+00
+     2    14     9  0.49910406E-13  0.52618616E-13  0.94853134E+00
+     2    14    10  0.00000000E+00  0.00000000E+00  0.70985829E+00
+     2    14    11  0.00000000E+00  0.00000000E+00  0.52643605E+00
+     2    14    12  0.00000000E+00  0.00000000E+00  0.86933926E+00
+     2    14    13  0.00000000E+00  0.00000000E+00  0.10090678E+01
+     2    14    14  0.00000000E+00  0.00000000E+00  0.99218681E+00
+     2    15     1  0.90074410E-14  0.87168496E-14  0.10333368E+01
+     2    15     2  0.18911495E-12  0.18289596E-12  0.10340029E+01
+     2    15     3  0.50638120E-13  0.48909720E-13  0.10353386E+01
+     2    15     4  0.38346399E-13  0.36941771E-13  0.10380228E+01
+     2    15     5  0.94623095E-13  0.90685816E-13  0.10434167E+01
+     2    15     6  0.19828095E-12  0.18806502E-12  0.10543212E+01
+     2    15     7  0.31803679E-12  0.29521443E-12  0.10773077E+01
+     2    15     8  0.33244009E-12  0.33337615E-12  0.99719217E+00
+     2    15     9  0.31583813E-12  0.32464951E-12  0.97285881E+00
+     2    15    10  0.00000000E+00  0.00000000E+00  0.63977360E+00
+     2    15    11  0.00000000E+00  0.00000000E+00  0.43915858E+00
+     2    15    12  0.00000000E+00  0.00000000E+00  0.89587341E+00
+     2    15    13  0.00000000E+00  0.00000000E+00  0.92805872E+00
+     2    15    14  0.00000000E+00  0.00000000E+00  0.95347945E+00
+     2    15    15  0.00000000E+00  0.00000000E+00  0.10003488E+01
+     2    16     1  0.29213321E-13  0.28411946E-13  0.10282055E+01
+     2    16     2  0.60865691E-12  0.59175754E-12  0.10285579E+01
+     2    16     3  0.16171251E-12  0.15711435E-12  0.10292663E+01
+     2    16     4  0.12051867E-12  0.11693028E-12  0.10306883E+01
+     2    16     5  0.29337164E-12  0.28384965E-12  0.10335459E+01
+     2    16     6  0.60617199E-12  0.58325344E-12  0.10392943E+01
+     2    16     7  0.87314783E-12  0.83381345E-12  0.10471741E+01
+     2    16     8  0.84910111E-12  0.79281817E-12  0.10709910E+01
+     2    16     9  0.19277732E-11  0.19289267E-11  0.99940203E+00
+     2    16    10  0.00000000E+00  0.00000000E+00  0.68548151E+00
+     2    16    11  0.00000000E+00  0.00000000E+00  0.45779332E+00
+     2    16    12  0.00000000E+00  0.00000000E+00  0.90358367E+00
+     2    16    13  0.00000000E+00  0.00000000E+00  0.85241134E+00
+     2    16    14  0.00000000E+00  0.00000000E+00  0.64492282E+00
+     2    16    15  0.00000000E+00  0.00000000E+00  0.88262484E+00
+     2    16    16  0.00000000E+00  0.00000000E+00  0.96504988E+00
+     2    17     1  0.92966481E-13  0.90844099E-13  0.10233629E+01
+     2    17     2  0.19235404E-11  0.18792867E-11  0.10235481E+01
+     2    17     3  0.50743506E-12  0.49557958E-12  0.10239225E+01
+     2    17     4  0.37232756E-12  0.36336136E-12  0.10246757E+01
+     2    17     5  0.89321072E-12  0.87041690E-12  0.10261872E+01
+     2    17     6  0.18115486E-11  0.17601669E-11  0.10291914E+01
+     2    17     7  0.23793584E-11  0.23194649E-11  0.10258221E+01
+     2    17     8  0.30894326E-11  0.30507031E-11  0.10126953E+01
+     2    17     9  0.36461603E-11  0.34062751E-11  0.10704245E+01
+     2    17    10  0.00000000E+00  0.00000000E+00  0.64318717E+00
+     2    17    11  0.00000000E+00  0.00000000E+00  0.43613131E+00
+     2    17    12  0.00000000E+00  0.00000000E+00  0.82081966E+00
+     2    17    13  0.00000000E+00  0.00000000E+00  0.83349376E+00
+     2    17    14  0.00000000E+00  0.00000000E+00  0.63756211E+00
+     2    17    15  0.00000000E+00  0.00000000E+00  0.65785445E+00
+     2    17    16  0.00000000E+00  0.00000000E+00  0.10677681E+01
+     2    17    17  0.00000000E+00  0.00000000E+00  0.99050797E+00
+     2    18     1  0.29122561E-12  0.28587101E-12  0.10187308E+01
+     2    18     2  0.59885859E-11  0.58779185E-11  0.10188277E+01
+     2    18     3  0.15697385E-11  0.15404316E-11  0.10190251E+01
+     2    18     4  0.11350688E-11  0.11134407E-11  0.10194245E+01
+     2    18     5  0.26836258E-11  0.26304218E-11  0.10202264E+01
+     2    18     6  0.53268874E-11  0.52139123E-11  0.10216680E+01
+     2    18     7  0.69745347E-11  0.69466223E-11  0.10040181E+01
+     2    18     8  0.16641029E-10  0.16448446E-10  0.10117083E+01
+     2    18     9  0.38832073E-11  0.37043984E-11  0.10482693E+01
+     2    18    10  0.00000000E+00  0.00000000E+00  0.33281721E+00
+     2    18    11  0.00000000E+00  0.00000000E+00  0.23695460E+00
+     2    18    12  0.00000000E+00  0.00000000E+00  0.50359715E+00
+     2    18    13  0.00000000E+00  0.00000000E+00  0.67458613E+00
+     2    18    14  0.00000000E+00  0.00000000E+00  0.61393011E+00
+     2    18    15  0.00000000E+00  0.00000000E+00  0.59434079E+00
+     2    18    16  0.00000000E+00  0.00000000E+00  0.11042773E+01
+     2    18    17  0.00000000E+00  0.00000000E+00  0.10195210E+01
+     2    18    18  0.00000000E+00  0.00000000E+00  0.10596630E+01
+     3     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     3     7     1  0.66844712E-19  0.62371869E-19  0.10717125E+01
+     3     7     2  0.10975811E-17  0.10451875E-17  0.10501284E+01
+     3     7     3  0.20329996E-16  0.19928487E-16  0.10201475E+01
+     3     7     4  0.92140247E-17  0.93147289E-17  0.98918871E+00
+     3     7     5  0.17340474E-16  0.18012983E-16  0.96266528E+00
+     3     7     6  0.33848522E-16  0.36496476E-16  0.92744630E+00
+     3     7     7  0.13834839E-16  0.15622029E-16  0.88559810E+00
+     3     8     1  0.25743372E-18  0.24081034E-18  0.10690310E+01
+     3     8     2  0.41922006E-17  0.39380159E-17  0.10645464E+01
+     3     8     3  0.76568133E-16  0.73417463E-16  0.10429145E+01
+     3     8     4  0.34440274E-16  0.34000011E-16  0.10129489E+01
+     3     8     5  0.72243097E-16  0.73589001E-16  0.98171053E+00
+     3     8     6  0.21793482E-15  0.22923471E-15  0.95070600E+00
+     3     8     7  0.32075428E-15  0.34955600E-15  0.91760486E+00
+     3     8     8  0.13537919E-16  0.13923742E-16  0.97229026E+00
+     3     9     1  0.10091640E-17  0.92136455E-18  0.10952929E+01
+     3     9     2  0.15708676E-16  0.14776102E-16  0.10631137E+01
+     3     9     3  0.28488408E-15  0.26905552E-15  0.10588301E+01
+     3     9     4  0.12515358E-15  0.12068456E-15  0.10370306E+01
+     3     9     5  0.26037339E-15  0.25889437E-15  0.10057128E+01
+     3     9     6  0.90021751E-15  0.92381142E-15  0.97446026E+00
+     3     9     7  0.21619709E-14  0.23004346E-14  0.93980978E+00
+     3     9     8  0.25040606E-15  0.25505022E-15  0.98179121E+00
+     3     9     9  0.86305040E-35  0.86755092E-35  0.99481238E+00
+     3    10     1  0.38391200E-17  0.35705214E-17  0.10752267E+01
+     3    10     2  0.63283327E-16  0.57998021E-16  0.10911291E+01
+     3    10     3  0.11351179E-14  0.10730201E-14  0.10578720E+01
+     3    10     4  0.51795028E-15  0.49162938E-15  0.10535381E+01
+     3    10     5  0.11037074E-14  0.10698004E-14  0.10316947E+01
+     3    10     6  0.37447399E-14  0.37382670E-14  0.10017315E+01
+     3    10     7  0.95397666E-14  0.98780199E-14  0.96575697E+00
+     3    10     8  0.28779463E-14  0.29489604E-14  0.97591894E+00
+     3    10     9  0.13237484E-33  0.13294116E-33  0.99574004E+00
+     3    10    10  0.00000000E+00  0.00000000E+00  0.99449213E+00
+     3    11     1  0.17312069E-16  0.16299864E-16  0.10620990E+01
+     3    11     2  0.30021087E-15  0.28046377E-15  0.10704087E+01
+     3    11     3  0.58126587E-14  0.53458477E-14  0.10873222E+01
+     3    11     4  0.25982721E-14  0.24682348E-14  0.10526843E+01
+     3    11     5  0.53089795E-14  0.50647362E-14  0.10482243E+01
+     3    11     6  0.16273315E-13  0.15865036E-13  0.10257345E+01
+     3    11     7  0.37971987E-13  0.38281553E-13  0.99191343E+00
+     3    11     8  0.23666210E-13  0.24441134E-13  0.96829426E+00
+     3    11     9  0.70927805E-33  0.71142476E-33  0.99698253E+00
+     3    11    10  0.00000000E+00  0.00000000E+00  0.99512340E+00
+     3    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+     3    12     1  0.72894042E-16  0.69249693E-16  0.10526262E+01
+     3    12     2  0.12436732E-14  0.11765469E-14  0.10570536E+01
+     3    12     3  0.23367650E-13  0.21920045E-13  0.10660402E+01
+     3    12     4  0.10577686E-13  0.97545619E-14  0.10843835E+01
+     3    12     5  0.19574371E-13  0.18690800E-13  0.10472730E+01
+     3    12     6  0.58485193E-13  0.56070284E-13  0.10430693E+01
+     3    12     7  0.13793971E-12  0.13533696E-12  0.10192317E+01
+     3    12     8  0.17376867E-12  0.18144021E-12  0.95771860E+00
+     3    12     9  0.74178500E-14  0.75472133E-14  0.98285946E+00
+     3    12    10  0.00000000E+00  0.00000000E+00  0.99640426E+00
+     3    12    11  0.00000000E+00  0.00000000E+00  0.99485003E+00
+     3    12    12  0.00000000E+00  0.00000000E+00  0.99376764E+00
+     3    13     1  0.25223752E-15  0.24133878E-15  0.10451595E+01
+     3    13     2  0.42214554E-14  0.40299329E-14  0.10475250E+01
+     3    13     3  0.78129207E-13  0.74247714E-13  0.10522776E+01
+     3    13     4  0.34738611E-13  0.32714433E-13  0.10618742E+01
+     3    13     5  0.67268673E-13  0.62202580E-13  0.10814451E+01
+     3    13     6  0.19533404E-12  0.18740841E-12  0.10422907E+01
+     3    13     7  0.47878756E-12  0.46137023E-12  0.10377513E+01
+     3    13     8  0.88600177E-12  0.87806563E-12  0.10090382E+01
+     3    13     9  0.61896421E-12  0.66212034E-12  0.93482132E+00
+     3    13    10  0.00000000E+00  0.00000000E+00  0.82119350E+00
+     3    13    11  0.00000000E+00  0.00000000E+00  0.93556432E+00
+     3    13    12  0.00000000E+00  0.00000000E+00  0.99557497E+00
+     3    13    13  0.00000000E+00  0.00000000E+00  0.99300243E+00
+     3    14     1  0.84969667E-15  0.81788347E-15  0.10388970E+01
+     3    14     2  0.14024531E-13  0.13483151E-13  0.10401523E+01
+     3    14     3  0.25687924E-12  0.24636649E-12  0.10426712E+01
+     3    14     4  0.11283821E-12  0.10769339E-12  0.10477728E+01
+     3    14     5  0.21486850E-12  0.20308863E-12  0.10580036E+01
+     3    14     6  0.66084891E-12  0.61255367E-12  0.10788424E+01
+     3    14     7  0.15891145E-11  0.15318819E-11  0.10373609E+01
+     3    14     8  0.22835911E-11  0.23348704E-11  0.97803764E+00
+     3    14     9  0.75594658E-12  0.79696531E-12  0.94853134E+00
+     3    14    10  0.00000000E+00  0.00000000E+00  0.70985829E+00
+     3    14    11  0.00000000E+00  0.00000000E+00  0.52643605E+00
+     3    14    12  0.00000000E+00  0.00000000E+00  0.86933926E+00
+     3    14    13  0.00000000E+00  0.00000000E+00  0.10090678E+01
+     3    14    14  0.00000000E+00  0.00000000E+00  0.99218681E+00
+     3    15     1  0.28148930E-14  0.27240810E-14  0.10333368E+01
+     3    15     2  0.45859817E-13  0.44351730E-13  0.10340029E+01
+     3    15     3  0.83196539E-12  0.80356842E-12  0.10353386E+01
+     3    15     4  0.36146271E-12  0.34822233E-12  0.10380228E+01
+     3    15     5  0.67783857E-12  0.64963362E-12  0.10434167E+01
+     3    15     6  0.20597375E-11  0.19536148E-11  0.10543212E+01
+     3    15     7  0.50534338E-11  0.46907988E-11  0.10773077E+01
+     3    15     8  0.68815225E-11  0.69008991E-11  0.99719217E+00
+     3    15     9  0.32808034E-11  0.33723325E-11  0.97285881E+00
+     3    15    10  0.00000000E+00  0.00000000E+00  0.63977360E+00
+     3    15    11  0.00000000E+00  0.00000000E+00  0.43915858E+00
+     3    15    12  0.00000000E+00  0.00000000E+00  0.89587341E+00
+     3    15    13  0.00000000E+00  0.00000000E+00  0.92805872E+00
+     3    15    14  0.00000000E+00  0.00000000E+00  0.95347945E+00
+     3    15    15  0.00000000E+00  0.00000000E+00  0.10003488E+01
+     3    16     1  0.91481785E-14  0.88972274E-14  0.10282055E+01
+     3    16     2  0.14725487E-12  0.14316634E-12  0.10285579E+01
+     3    16     3  0.26475346E-11  0.25722542E-11  0.10292663E+01
+     3    16     4  0.11383827E-11  0.11044879E-11  0.10306883E+01
+     3    16     5  0.21009498E-11  0.20327590E-11  0.10335459E+01
+     3    16     6  0.62954178E-11  0.60573965E-11  0.10392943E+01
+     3    16     7  0.13784245E-10  0.13163279E-10  0.10471741E+01
+     3    16     8  0.20018252E-10  0.18691335E-10  0.10709910E+01
+     3    16     9  0.22084973E-10  0.22098187E-10  0.99940203E+00
+     3    16    10  0.00000000E+00  0.00000000E+00  0.68548151E+00
+     3    16    11  0.00000000E+00  0.00000000E+00  0.45779332E+00
+     3    16    12  0.00000000E+00  0.00000000E+00  0.90358367E+00
+     3    16    13  0.00000000E+00  0.00000000E+00  0.85241134E+00
+     3    16    14  0.00000000E+00  0.00000000E+00  0.64492282E+00
+     3    16    15  0.00000000E+00  0.00000000E+00  0.88262484E+00
+     3    16    16  0.00000000E+00  0.00000000E+00  0.96504988E+00
+     3    17     1  0.29166803E-13  0.28500939E-13  0.10233629E+01
+     3    17     2  0.46436005E-12  0.45367681E-12  0.10235481E+01
+     3    17     3  0.82793201E-11  0.80858859E-11  0.10239225E+01
+     3    17     4  0.35245863E-11  0.34397091E-11  0.10246757E+01
+     3    17     5  0.63940657E-11  0.62308957E-11  0.10261872E+01
+     3    17     6  0.18802272E-10  0.18268976E-10  0.10291914E+01
+     3    17     7  0.37435215E-10  0.36492891E-10  0.10258221E+01
+     3    17     8  0.53765481E-10  0.53091470E-10  0.10126953E+01
+     3    17     9  0.63402421E-10  0.59231101E-10  0.10704245E+01
+     3    17    10  0.00000000E+00  0.00000000E+00  0.64318717E+00
+     3    17    11  0.00000000E+00  0.00000000E+00  0.43613131E+00
+     3    17    12  0.00000000E+00  0.00000000E+00  0.82081966E+00
+     3    17    13  0.00000000E+00  0.00000000E+00  0.83349376E+00
+     3    17    14  0.00000000E+00  0.00000000E+00  0.63756211E+00
+     3    17    15  0.00000000E+00  0.00000000E+00  0.65785445E+00
+     3    17    16  0.00000000E+00  0.00000000E+00  0.10677681E+01
+     3    17    17  0.00000000E+00  0.00000000E+00  0.99050797E+00
+     3    18     1  0.91518455E-13  0.89835755E-13  0.10187308E+01
+     3    18     2  0.14428507E-11  0.14161872E-11  0.10188277E+01
+     3    18     3  0.25530546E-10  0.25053892E-10  0.10190251E+01
+     3    18     4  0.10768091E-10  0.10562911E-10  0.10194245E+01
+     3    18     5  0.19202300E-10  0.18821606E-10  0.10202264E+01
+     3    18     6  0.55237117E-10  0.54065623E-10  0.10216680E+01
+     3    18     7  0.10454088E-09  0.10412251E-09  0.10040181E+01
+     3    18     8  0.19283101E-09  0.19059941E-09  0.10117083E+01
+     3    18     9  0.18337387E-09  0.17493011E-09  0.10482693E+01
+     3    18    10  0.00000000E+00  0.00000000E+00  0.33281721E+00
+     3    18    11  0.00000000E+00  0.00000000E+00  0.23695460E+00
+     3    18    12  0.00000000E+00  0.00000000E+00  0.50359715E+00
+     3    18    13  0.00000000E+00  0.00000000E+00  0.67458613E+00
+     3    18    14  0.00000000E+00  0.00000000E+00  0.61393011E+00
+     3    18    15  0.00000000E+00  0.00000000E+00  0.59434079E+00
+     3    18    16  0.00000000E+00  0.00000000E+00  0.11042773E+01
+     3    18    17  0.00000000E+00  0.00000000E+00  0.10195210E+01
+     3    18    18  0.00000000E+00  0.00000000E+00  0.10596630E+01
+     4     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     4     7     1  0.25057989E-19  0.23381260E-19  0.10717125E+01
+     4     7     2  0.18386470E-18  0.17508782E-18  0.10501284E+01
+     4     7     3  0.49412173E-17  0.48436302E-17  0.10201475E+01
+     4     7     4  0.94027254E-16  0.95054920E-16  0.98918871E+00
+     4     7     5  0.58190224E-16  0.60446995E-16  0.96266528E+00
+     4     7     6  0.11238727E-15  0.12117928E-15  0.92744630E+00
+     4     7     7  0.64638283E-16  0.72988281E-16  0.88559810E+00
+     4     8     1  0.96451480E-19  0.90223276E-19  0.10690310E+01
+     4     8     2  0.70497898E-18  0.66223417E-18  0.10645464E+01
+     4     8     3  0.18490729E-16  0.17729862E-16  0.10429145E+01
+     4     8     4  0.35205541E-15  0.34755496E-15  0.10129489E+01
+     4     8     5  0.23741803E-15  0.24184117E-15  0.98171053E+00
+     4     8     6  0.74210087E-15  0.78057871E-15  0.95070600E+00
+     4     8     7  0.16301863E-14  0.17765668E-14  0.91760486E+00
+     4     8     8  0.92227281E-16  0.94855708E-16  0.97229026E+00
+     4     9     1  0.37794711E-18  0.34506488E-18  0.10952929E+01
+     4     9     2  0.26507915E-17  0.24934224E-17  0.10631137E+01
+     4     9     3  0.68207410E-16  0.64417711E-16  0.10588301E+01
+     4     9     4  0.12698279E-14  0.12244845E-14  0.10370306E+01
+     4     9     5  0.85313996E-15  0.84829380E-15  0.10057128E+01
+     4     9     6  0.30895488E-14  0.31705232E-14  0.97446026E+00
+     4     9     7  0.11519929E-13  0.12257724E-13  0.93980978E+00
+     4     9     8  0.17921947E-14  0.18254337E-14  0.98179121E+00
+     4     9     9  0.17269755E-34  0.17359811E-34  0.99481238E+00
+     4    10     1  0.14381267E-17  0.13375102E-17  0.10752267E+01
+     4    10     2  0.10653667E-16  0.97638928E-17  0.10911291E+01
+     4    10     3  0.27333482E-15  0.25838176E-15  0.10578720E+01
+     4    10     4  0.52815030E-14  0.50131106E-14  0.10535381E+01
+     4    10     5  0.36172455E-14  0.35061200E-14  0.10316947E+01
+     4    10     6  0.12841764E-13  0.12819567E-13  0.10017315E+01
+     4    10     7  0.51427784E-13  0.53251269E-13  0.96575697E+00
+     4    10     8  0.20309955E-13  0.20811109E-13  0.97591894E+00
+     4    10     9  0.27509546E-33  0.27627237E-33  0.99574004E+00
+     4    10    10  0.25498146E-41  0.25639364E-41  0.99449213E+00
+     4    11     1  0.64967720E-17  0.61169175E-17  0.10620990E+01
+     4    11     2  0.50154176E-16  0.46855164E-16  0.10704087E+01
+     4    11     3  0.14085176E-14  0.12954004E-14  0.10873222E+01
+     4    11     4  0.26443426E-13  0.25119995E-13  0.10526843E+01
+     4    11     5  0.17562583E-13  0.16754604E-13  0.10482243E+01
+     4    11     6  0.55578292E-13  0.54183896E-13  0.10257345E+01
+     4    11     7  0.20430775E-12  0.20597337E-12  0.99191343E+00
+     4    11     8  0.16907948E-12  0.17461580E-12  0.96829426E+00
+     4    11     9  0.17083667E-32  0.17135372E-32  0.99698253E+00
+     4    11    10  0.86566620E-34  0.86990840E-34  0.99512340E+00
+     4    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+     4    12     1  0.27354268E-16  0.25986688E-16  0.10526262E+01
+     4    12     2  0.20837262E-15  0.19712588E-15  0.10570536E+01
+     4    12     3  0.56127457E-14  0.52650412E-14  0.10660402E+01
+     4    12     4  0.10658373E-12  0.98289699E-13  0.10843835E+01
+     4    12     5  0.65215468E-13  0.62271695E-13  0.10472730E+01
+     4    12     6  0.19955938E-12  0.19131938E-12  0.10430693E+01
+     4    12     7  0.74291224E-12  0.72889440E-12  0.10192317E+01
+     4    12     8  0.12066189E-11  0.12598888E-11  0.95771860E+00
+     4    12     9  0.31356642E-13  0.31903485E-13  0.98285946E+00
+     4    12    10  0.46366047E-33  0.46533368E-33  0.99640426E+00
+     4    12    11  0.00000000E+00  0.00000000E+00  0.99485003E+00
+     4    12    12  0.00000000E+00  0.00000000E+00  0.99376764E+00
+     4    13     1  0.94604616E-16  0.90516916E-16  0.10451595E+01
+     4    13     2  0.70898054E-15  0.67681492E-15  0.10475250E+01
+     4    13     3  0.18706637E-13  0.17777283E-13  0.10522776E+01
+     4    13     4  0.34933043E-12  0.32897535E-12  0.10618742E+01
+     4    13     5  0.22419816E-12  0.20731350E-12  0.10814451E+01
+     4    13     6  0.66673533E-12  0.63968271E-12  0.10422907E+01
+     4    13     7  0.25816206E-11  0.24877064E-11  0.10377513E+01
+     4    13     8  0.64236762E-11  0.63661377E-11  0.10090382E+01
+     4    13     9  0.43739681E-11  0.46789349E-11  0.93482132E+00
+     4    13    10  0.17132698E-12  0.20863168E-12  0.82119350E+00
+     4    13    11  0.00000000E+00  0.00000000E+00  0.93556432E+00
+     4    13    12  0.00000000E+00  0.00000000E+00  0.99557497E+00
+     4    13    13  0.00000000E+00  0.00000000E+00  0.99300243E+00
+     4    14     1  0.31855960E-15  0.30663252E-15  0.10388970E+01
+     4    14     2  0.23595064E-14  0.22684240E-14  0.10401523E+01
+     4    14     3  0.61356668E-13  0.58845655E-13  0.10426712E+01
+     4    14     4  0.11327300E-11  0.10810836E-11  0.10477728E+01
+     4    14     5  0.71655398E-12  0.67726989E-12  0.10580036E+01
+     4    14     6  0.22561743E-11  0.20912917E-11  0.10788424E+01
+     4    14     7  0.85762016E-11  0.82673264E-11  0.10373609E+01
+     4    14     8  0.19334326E-10  0.19768488E-10  0.97803764E+00
+     4    14     9  0.16364992E-10  0.17252980E-10  0.94853134E+00
+     4    14    10  0.66013887E-12  0.92995867E-12  0.70985829E+00
+     4    14    11  0.00000000E+00  0.00000000E+00  0.52643605E+00
+     4    14    12  0.00000000E+00  0.00000000E+00  0.86933926E+00
+     4    14    13  0.00000000E+00  0.00000000E+00  0.10090678E+01
+     4    14    14  0.00000000E+00  0.00000000E+00  0.99218681E+00
+     4    15     1  0.10549262E-14  0.10208930E-14  0.10333368E+01
+     4    15     2  0.77289316E-14  0.74747678E-14  0.10340029E+01
+     4    15     3  0.19821208E-12  0.19144663E-12  0.10353386E+01
+     4    15     4  0.36213342E-11  0.34886847E-11  0.10380228E+01
+     4    15     5  0.22626002E-11  0.21684531E-11  0.10434167E+01
+     4    15     6  0.70323898E-11  0.66700637E-11  0.10543212E+01
+     4    15     7  0.27109244E-10  0.25163882E-10  0.10773077E+01
+     4    15     8  0.59513882E-10  0.59681458E-10  0.99719217E+00
+     4    15     9  0.61953316E-10  0.63681714E-10  0.97285881E+00
+     4    15    10  0.19656530E-11  0.30724197E-11  0.63977360E+00
+     4    15    11  0.00000000E+00  0.00000000E+00  0.43915858E+00
+     4    15    12  0.00000000E+00  0.00000000E+00  0.89587341E+00
+     4    15    13  0.00000000E+00  0.00000000E+00  0.92805872E+00
+     4    15    14  0.00000000E+00  0.00000000E+00  0.95347945E+00
+     4    15    15  0.00000000E+00  0.00000000E+00  0.10003488E+01
+     4    16     1  0.34272127E-14  0.33331980E-14  0.10282055E+01
+     4    16     2  0.24858901E-13  0.24168694E-13  0.10285579E+01
+     4    16     3  0.62912560E-12  0.61123695E-12  0.10292663E+01
+     4    16     4  0.11379847E-10  0.11041017E-10  0.10306883E+01
+     4    16     5  0.70223520E-11  0.67944269E-11  0.10335459E+01
+     4    16     6  0.21488659E-10  0.20676202E-10  0.10392943E+01
+     4    16     7  0.73487881E-10  0.70177331E-10  0.10471741E+01
+     4    16     8  0.17811027E-09  0.16630417E-09  0.10709910E+01
+     4    16     9  0.27972357E-09  0.27989093E-09  0.99940203E+00
+     4    16    10  0.10481137E-10  0.15290182E-10  0.68548151E+00
+     4    16    11  0.00000000E+00  0.00000000E+00  0.45779332E+00
+     4    16    12  0.00000000E+00  0.00000000E+00  0.90358367E+00
+     4    16    13  0.00000000E+00  0.00000000E+00  0.85241134E+00
+     4    16    14  0.00000000E+00  0.00000000E+00  0.64492282E+00
+     4    16    15  0.00000000E+00  0.00000000E+00  0.88262484E+00
+     4    16    16  0.00000000E+00  0.00000000E+00  0.96504988E+00
+     4    17     1  0.10923363E-13  0.10673987E-13  0.10233629E+01
+     4    17     2  0.78513694E-13  0.76707378E-13  0.10235481E+01
+     4    17     3  0.19623584E-11  0.19165107E-11  0.10239225E+01
+     4    17     4  0.35151520E-10  0.34305019E-10  0.10246757E+01
+     4    17     5  0.21409014E-10  0.20862677E-10  0.10261872E+01
+     4    17     6  0.64136969E-10  0.62317825E-10  0.10291914E+01
+     4    17     7  0.19918508E-09  0.19417117E-09  0.10258221E+01
+     4    17     8  0.46254363E-09  0.45674512E-09  0.10126953E+01
+     4    17     9  0.93048061E-09  0.86926319E-09  0.10704245E+01
+     4    17    10  0.52899770E-10  0.82246309E-10  0.64318717E+00
+     4    17    11  0.00000000E+00  0.00000000E+00  0.43613131E+00
+     4    17    12  0.00000000E+00  0.00000000E+00  0.82081966E+00
+     4    17    13  0.00000000E+00  0.00000000E+00  0.83349376E+00
+     4    17    14  0.00000000E+00  0.00000000E+00  0.63756211E+00
+     4    17    15  0.00000000E+00  0.00000000E+00  0.65785445E+00
+     4    17    16  0.00000000E+00  0.00000000E+00  0.10677681E+01
+     4    17    17  0.00000000E+00  0.00000000E+00  0.99050797E+00
+     4    18     1  0.34265205E-13  0.33635190E-13  0.10187308E+01
+     4    18     2  0.24430254E-12  0.23978790E-12  0.10188277E+01
+     4    18     3  0.60366734E-11  0.59239691E-11  0.10190251E+01
+     4    18     4  0.10714700E-09  0.10510538E-09  0.10194245E+01
+     4    18     5  0.64415549E-10  0.63138484E-10  0.10202264E+01
+     4    18     6  0.18823223E-09  0.18424011E-09  0.10216680E+01
+     4    18     7  0.55289042E-09  0.55067772E-09  0.10040181E+01
+     4    18     8  0.14351155E-08  0.14185072E-08  0.10117083E+01
+     4    18     9  0.42642036E-08  0.40678511E-08  0.10482693E+01
+     4    18    10  0.16996857E-09  0.51069646E-09  0.33281721E+00
+     4    18    11  0.00000000E+00  0.00000000E+00  0.23695460E+00
+     4    18    12  0.00000000E+00  0.00000000E+00  0.50359715E+00
+     4    18    13  0.00000000E+00  0.00000000E+00  0.67458613E+00
+     4    18    14  0.00000000E+00  0.00000000E+00  0.61393011E+00
+     4    18    15  0.00000000E+00  0.00000000E+00  0.59434079E+00
+     4    18    16  0.00000000E+00  0.00000000E+00  0.11042773E+01
+     4    18    17  0.00000000E+00  0.00000000E+00  0.10195210E+01
+     4    18    18  0.00000000E+00  0.00000000E+00  0.10596630E+01
+     5     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     5     7     1  0.17231039E-20  0.16078042E-20  0.10717125E+01
+     5     7     2  0.25597340E-19  0.24375437E-19  0.10501284E+01
+     5     7     3  0.31447559E-18  0.30826483E-18  0.10201475E+01
+     5     7     4  0.20991376E-16  0.21220800E-16  0.98918871E+00
+     5     7     5  0.39780536E-15  0.41323331E-15  0.96266528E+00
+     5     7     6  0.19918994E-15  0.21477248E-15  0.92744630E+00
+     5     7     7  0.10261410E-15  0.11586983E-15  0.88559810E+00
+     5     8     1  0.66277560E-20  0.61997789E-20  0.10690310E+01
+     5     8     2  0.98046410E-19  0.92101586E-19  0.10645464E+01
+     5     8     3  0.11813109E-17  0.11327016E-17  0.10429145E+01
+     5     8     4  0.79211506E-16  0.78198915E-16  0.10129489E+01
+     5     8     5  0.16536978E-14  0.16845065E-14  0.98171053E+00
+     5     8     6  0.12194693E-14  0.12826986E-14  0.95070600E+00
+     5     8     7  0.28370968E-14  0.30918502E-14  0.91760486E+00
+     5     8     8  0.24537139E-15  0.25236434E-15  0.97229026E+00
+     5     9     1  0.25957421E-19  0.23699069E-19  0.10952929E+01
+     5     9     2  0.36833805E-18  0.34647098E-18  0.10631137E+01
+     5     9     3  0.43802615E-17  0.41368880E-17  0.10588301E+01
+     5     9     4  0.28327095E-15  0.27315582E-15  0.10370306E+01
+     5     9     5  0.59547734E-14  0.59209480E-14  0.10057128E+01
+     5     9     6  0.49648817E-14  0.50950069E-14  0.97446026E+00
+     5     9     7  0.21076944E-13  0.22426819E-13  0.93980978E+00
+     5     9     8  0.50393488E-14  0.51328111E-14  0.98179121E+00
+     5     9     9  0.14937472E-30  0.15015366E-30  0.99481238E+00
+     5    10     1  0.98799400E-19  0.91887039E-19  0.10752267E+01
+     5    10     2  0.14812632E-17  0.13575508E-17  0.10911291E+01
+     5    10     3  0.17492857E-16  0.16535893E-16  0.10578720E+01
+     5    10     4  0.11851531E-14  0.11249267E-14  0.10535381E+01
+     5    10     5  0.25248637E-13  0.24472972E-13  0.10316947E+01
+     5    10     6  0.20694275E-13  0.20658504E-13  0.10017315E+01
+     5    10     7  0.95283136E-13  0.98661608E-13  0.96575697E+00
+     5    10     8  0.56217377E-13  0.57604555E-13  0.97591894E+00
+     5    10     9  0.12275462E-29  0.12327979E-29  0.99574004E+00
+     5    10    10  0.69000842E-35  0.69382995E-35  0.99449213E+00
+     5    11     1  0.44736715E-18  0.42121040E-18  0.10620990E+01
+     5    11     2  0.69878068E-17  0.65281669E-17  0.10704087E+01
+     5    11     3  0.89808773E-16  0.82596286E-16  0.10873222E+01
+     5    11     4  0.58973493E-14  0.56022011E-14  0.10526843E+01
+     5    11     5  0.12153239E-12  0.11594121E-12  0.10482243E+01
+     5    11     6  0.90753294E-13  0.88476396E-13  0.10257345E+01
+     5    11     7  0.37785590E-12  0.38093637E-12  0.99191343E+00
+     5    11     8  0.48351596E-12  0.49934816E-12  0.96829426E+00
+     5    11     9  0.55064953E-29  0.55231612E-29  0.99698253E+00
+     5    11    10  0.74602824E-33  0.74968415E-33  0.99512340E+00
+     5    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+     5    12     1  0.18835005E-17  0.17893346E-17  0.10526262E+01
+     5    12     2  0.29011030E-16  0.27445184E-16  0.10570536E+01
+     5    12     3  0.35978542E-15  0.33749704E-15  0.10660402E+01
+     5    12     4  0.23436917E-13  0.21613125E-13  0.10843835E+01
+     5    12     5  0.44814387E-12  0.42791503E-12  0.10472730E+01
+     5    12     6  0.32703036E-12  0.31352697E-12  0.10430693E+01
+     5    12     7  0.13753299E-11  0.13493791E-11  0.10192317E+01
+     5    12     8  0.36831034E-11  0.38457052E-11  0.95771860E+00
+     5    12     9  0.13481832E-12  0.13716948E-12  0.98285946E+00
+     5    12    10  0.55886770E-32  0.56088449E-32  0.99640426E+00
+     5    12    11  0.00000000E+00  0.00000000E+00  0.99485003E+00
+     5    12    12  0.00000000E+00  0.00000000E+00  0.99376764E+00
+     5    13     1  0.65096304E-17  0.62283606E-17  0.10451595E+01
+     5    13     2  0.98645889E-16  0.94170441E-16  0.10475250E+01
+     5    13     3  0.12014049E-14  0.11417186E-14  0.10522776E+01
+     5    13     4  0.76634552E-13  0.72169146E-13  0.10618742E+01
+     5    13     5  0.15399975E-11  0.14240183E-11  0.10814451E+01
+     5    13     6  0.10915872E-11  0.10472963E-11  0.10422907E+01
+     5    13     7  0.47846917E-11  0.46106342E-11  0.10377513E+01
+     5    13     8  0.18893269E-10  0.18724037E-10  0.10090382E+01
+     5    13     9  0.18270477E-10  0.19544352E-10  0.93482132E+00
+     5    13    10  0.32419847E-11  0.39478937E-11  0.82119350E+00
+     5    13    11  0.00000000E+00  0.00000000E+00  0.93556432E+00
+     5    13    12  0.00000000E+00  0.00000000E+00  0.99557497E+00
+     5    13    13  0.00000000E+00  0.00000000E+00  0.99300243E+00
+     5    14     1  0.21908291E-16  0.21088031E-16  0.10388970E+01
+     5    14     2  0.32814209E-15  0.31547505E-15  0.10401523E+01
+     5    14     3  0.39462575E-14  0.37847575E-14  0.10426712E+01
+     5    14     4  0.24795905E-12  0.23665344E-12  0.10477728E+01
+     5    14     5  0.49188958E-11  0.46492242E-11  0.10580036E+01
+     5    14     6  0.36918470E-11  0.34220447E-11  0.10788424E+01
+     5    14     7  0.15908652E-10  0.15335696E-10  0.10373609E+01
+     5    14     8  0.58641734E-10  0.59958566E-10  0.97803764E+00
+     5    14     9  0.11109903E-09  0.11712742E-09  0.94853134E+00
+     5    14    10  0.23232812E-10  0.32728803E-10  0.70985829E+00
+     5    14    11  0.00000000E+00  0.00000000E+00  0.52643605E+00
+     5    14    12  0.00000000E+00  0.00000000E+00  0.86933926E+00
+     5    14    13  0.00000000E+00  0.00000000E+00  0.10090678E+01
+     5    14    14  0.00000000E+00  0.00000000E+00  0.99218681E+00
+     5    15     1  0.72514592E-16  0.70175179E-16  0.10333368E+01
+     5    15     2  0.10743820E-14  0.10390512E-14  0.10340029E+01
+     5    15     3  0.12767914E-13  0.12332115E-13  0.10353386E+01
+     5    15     4  0.79069490E-12  0.76173175E-12  0.10380228E+01
+     5    15     5  0.15517314E-10  0.14871637E-10  0.10434167E+01
+     5    15     6  0.11507250E-10  0.10914368E-10  0.10543212E+01
+     5    15     7  0.49979743E-10  0.46393191E-10  0.10773077E+01
+     5    15     8  0.18252934E-09  0.18304329E-09  0.99719217E+00
+     5    15     9  0.52011937E-09  0.53462986E-09  0.97285881E+00
+     5    15    10  0.10924760E-09  0.17075978E-09  0.63977360E+00
+     5    15    11  0.00000000E+00  0.00000000E+00  0.43915858E+00
+     5    15    12  0.00000000E+00  0.00000000E+00  0.89587341E+00
+     5    15    13  0.00000000E+00  0.00000000E+00  0.92805872E+00
+     5    15    14  0.00000000E+00  0.00000000E+00  0.95347945E+00
+     5    15    15  0.00000000E+00  0.00000000E+00  0.10003488E+01
+     5    16     1  0.23547573E-15  0.22901620E-15  0.10282055E+01
+     5    16     2  0.34540452E-14  0.33581437E-14  0.10285579E+01
+     5    16     3  0.40588908E-13  0.39434797E-13  0.10292663E+01
+     5    16     4  0.24774246E-11  0.24036604E-11  0.10306883E+01
+     5    16     5  0.48096507E-10  0.46535435E-10  0.10335459E+01
+     5    16     6  0.35193103E-10  0.33862499E-10  0.10392943E+01
+     5    16     7  0.13469861E-09  0.12863058E-09  0.10471741E+01
+     5    16     8  0.55062451E-09  0.51412618E-09  0.10709910E+01
+     5    16     9  0.20743127E-08  0.20755538E-08  0.99940203E+00
+     5    16    10  0.57480753E-09  0.83854564E-09  0.68548151E+00
+     5    16    11  0.00000000E+00  0.00000000E+00  0.45779332E+00
+     5    16    12  0.00000000E+00  0.00000000E+00  0.90358367E+00
+     5    16    13  0.00000000E+00  0.00000000E+00  0.85241134E+00
+     5    16    14  0.00000000E+00  0.00000000E+00  0.64492282E+00
+     5    16    15  0.00000000E+00  0.00000000E+00  0.88262484E+00
+     5    16    16  0.00000000E+00  0.00000000E+00  0.96504988E+00
+     5    17     1  0.75020890E-15  0.73308197E-15  0.10233629E+01
+     5    17     2  0.10904638E-13  0.10653762E-13  0.10235481E+01
+     5    17     3  0.12680002E-12  0.12383752E-12  0.10239225E+01
+     5    17     4  0.76281227E-11  0.74444263E-11  0.10246757E+01
+     5    17     5  0.14638464E-09  0.14264906E-09  0.10261872E+01
+     5    17     6  0.10524645E-09  0.10226130E-09  0.10291914E+01
+     5    17     7  0.36447503E-09  0.35530042E-09  0.10258221E+01
+     5    17     8  0.14256175E-08  0.14077457E-08  0.10126953E+01
+     5    17     9  0.64075730E-08  0.59860112E-08  0.10704245E+01
+     5    17    10  0.24642982E-08  0.38313859E-08  0.64318717E+00
+     5    17    11  0.00000000E+00  0.00000000E+00  0.43613131E+00
+     5    17    12  0.00000000E+00  0.00000000E+00  0.82081966E+00
+     5    17    13  0.00000000E+00  0.00000000E+00  0.83349376E+00
+     5    17    14  0.00000000E+00  0.00000000E+00  0.63756211E+00
+     5    17    15  0.00000000E+00  0.00000000E+00  0.65785445E+00
+     5    17    16  0.00000000E+00  0.00000000E+00  0.10677681E+01
+     5    17    17  0.00000000E+00  0.00000000E+00  0.99050797E+00
+     5    18     1  0.23524506E-14  0.23091974E-14  0.10187308E+01
+     5    18     2  0.33918015E-13  0.33291219E-13  0.10188277E+01
+     5    18     3  0.39063455E-12  0.38334142E-12  0.10190251E+01
+     5    18     4  0.23177371E-10  0.22735740E-10  0.10194245E+01
+     5    18     5  0.43964143E-09  0.43092536E-09  0.10202264E+01
+     5    18     6  0.30972218E-09  0.30315345E-09  0.10216680E+01
+     5    18     7  0.10111241E-08  0.10070776E-08  0.10040181E+01
+     5    18     8  0.42130128E-08  0.41642564E-08  0.10117083E+01
+     5    18     9  0.20511616E-07  0.19567124E-07  0.10482693E+01
+     5    18    10  0.56496603E-08  0.16975265E-07  0.33281721E+00
+     5    18    11  0.00000000E+00  0.00000000E+00  0.23695460E+00
+     5    18    12  0.00000000E+00  0.00000000E+00  0.50359715E+00
+     5    18    13  0.00000000E+00  0.00000000E+00  0.67458613E+00
+     5    18    14  0.00000000E+00  0.00000000E+00  0.61393011E+00
+     5    18    15  0.00000000E+00  0.00000000E+00  0.59434079E+00
+     5    18    16  0.00000000E+00  0.00000000E+00  0.11042773E+01
+     5    18    17  0.00000000E+00  0.00000000E+00  0.10195210E+01
+     5    18    18  0.00000000E+00  0.00000000E+00  0.10596630E+01
+     6     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     6     7     1  0.26551378E-17  0.24774720E-17  0.10717125E+01
+     6     7     2  0.39640041E-17  0.37747803E-17  0.10501284E+01
+     6     7     3  0.51355848E-17  0.50341591E-17  0.10201475E+01
+     6     7     4  0.94729677E-17  0.95765021E-17  0.98918871E+00
+     6     7     5  0.98113069E-16  0.10191816E-15  0.96266528E+00
+     6     7     6  0.11176151E-14  0.12050456E-14  0.92744630E+00
+     6     7     7  0.17003896E-15  0.19200466E-15  0.88559810E+00
+     6     8     1  0.79577903E-22  0.74439283E-22  0.10690310E+01
+     6     8     2  0.29744475E-20  0.27940985E-20  0.10645464E+01
+     6     8     3  0.77620760E-19  0.74426775E-19  0.10429145E+01
+     6     8     4  0.15780501E-17  0.15578773E-17  0.10129489E+01
+     6     8     5  0.36057734E-15  0.36729497E-15  0.98171053E+00
+     6     8     6  0.71541012E-14  0.75250405E-14  0.95070600E+00
+     6     8     7  0.31776812E-14  0.34630170E-14  0.91760486E+00
+     6     8     8  0.23798623E-15  0.24476871E-15  0.97229026E+00
+     6     9     1  0.31147493E-21  0.28437592E-21  0.10952929E+01
+     6     9     2  0.11163184E-19  0.10500461E-19  0.10631137E+01
+     6     9     3  0.28737005E-18  0.27140337E-18  0.10588301E+01
+     6     9     4  0.56685563E-17  0.54661417E-17  0.10370306E+01
+     6     9     5  0.13162061E-14  0.13087295E-14  0.10057128E+01
+     6     9     6  0.29567924E-13  0.30342873E-13  0.97446026E+00
+     6     9     7  0.20742006E-13  0.22070430E-13  0.93980978E+00
+     6     9     8  0.49235130E-14  0.50148270E-14  0.98179121E+00
+     6     9     9  0.29387091E-23  0.29540335E-23  0.99481238E+00
+     6    10     1  0.11859275E-20  0.11029557E-20  0.10752267E+01
+     6    10     2  0.44923050E-19  0.41171160E-19  0.10911291E+01
+     6    10     3  0.11488165E-17  0.10859693E-17  0.10578720E+01
+     6    10     4  0.23643155E-16  0.22441671E-16  0.10535381E+01
+     6    10     5  0.55652917E-14  0.53943201E-14  0.10316947E+01
+     6    10     6  0.12295554E-12  0.12274301E-12  0.10017315E+01
+     6    10     7  0.91782396E-13  0.95036742E-13  0.96575697E+00
+     6    10     8  0.53350265E-13  0.54666697E-13  0.97591894E+00
+     6    10     9  0.24038102E-22  0.24140941E-22  0.99574004E+00
+     6    10    10  0.36114764E-28  0.36314781E-28  0.99449213E+00
+     6    11     1  0.53835502E-20  0.50687838E-20  0.10620990E+01
+     6    11     2  0.21240812E-18  0.19843646E-18  0.10704087E+01
+     6    11     3  0.59052613E-17  0.54310134E-17  0.10873222E+01
+     6    11     4  0.11805667E-15  0.11214821E-15  0.10526843E+01
+     6    11     5  0.26145863E-13  0.24943004E-13  0.10482243E+01
+     6    11     6  0.53374077E-12  0.52034982E-12  0.10257345E+01
+     6    11     7  0.36698173E-12  0.36997355E-12  0.99191343E+00
+     6    11     8  0.47549596E-12  0.49106556E-12  0.96829426E+00
+     6    11     9  0.10783269E-21  0.10815906E-21  0.99698253E+00
+     6    11    10  0.28561079E-27  0.28701042E-27  0.99512340E+00
+     6    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+     6    12     1  0.22663819E-19  0.21530738E-19  0.10526262E+01
+     6    12     2  0.88112886E-18  0.83357066E-18  0.10570536E+01
+     6    12     3  0.23620137E-16  0.22156891E-16  0.10660402E+01
+     6    12     4  0.47273427E-15  0.43594749E-15  0.10843835E+01
+     6    12     5  0.94953391E-13  0.90667273E-13  0.10472730E+01
+     6    12     6  0.19171954E-11  0.18380326E-11  0.10430693E+01
+     6    12     7  0.13321678E-11  0.13070314E-11  0.10192317E+01
+     6    12     8  0.40935528E-11  0.42742751E-11  0.95771860E+00
+     6    12     9  0.16256530E-12  0.16540035E-12  0.98285946E+00
+     6    12    10  0.12991367E-26  0.13038249E-26  0.99640426E+00
+     6    12    11  0.00000000E+00  0.00000000E+00  0.99485003E+00
+     6    12    12  0.00000000E+00  0.00000000E+00  0.99376764E+00
+     6    13     1  0.78270945E-19  0.74888994E-19  0.10451595E+01
+     6    13     2  0.29939723E-17  0.28581392E-17  0.10475250E+01
+     6    13     3  0.78826692E-16  0.74910548E-16  0.10522776E+01
+     6    13     4  0.15476725E-14  0.14574914E-14  0.10618742E+01
+     6    13     5  0.32621387E-12  0.30164627E-12  0.10814451E+01
+     6    13     6  0.64032920E-11  0.61434799E-11  0.10422907E+01
+     6    13     7  0.46177730E-11  0.44497877E-11  0.10377513E+01
+     6    13     8  0.22467730E-10  0.22266481E-10  0.10090382E+01
+     6    13     9  0.32809798E-10  0.35097400E-10  0.93482132E+00
+     6    13    10  0.17206993E-10  0.20953640E-10  0.82119350E+00
+     6    13    11  0.00000000E+00  0.00000000E+00  0.93556432E+00
+     6    13    12  0.00000000E+00  0.00000000E+00  0.99557497E+00
+     6    13    13  0.00000000E+00  0.00000000E+00  0.99300243E+00
+     6    14     1  0.26327325E-18  0.25341613E-18  0.10388970E+01
+     6    14     2  0.99541691E-17  0.95699153E-17  0.10401523E+01
+     6    14     3  0.25880680E-15  0.24821516E-15  0.10426712E+01
+     6    14     4  0.50133759E-14  0.47847927E-14  0.10477728E+01
+     6    14     5  0.10409782E-11  0.98390799E-12  0.10580036E+01
+     6    14     6  0.21662918E-10  0.20079779E-10  0.10788424E+01
+     6    14     7  0.15308060E-10  0.14756734E-10  0.10373609E+01
+     6    14     8  0.62287932E-10  0.63686641E-10  0.97803764E+00
+     6    14     9  0.18747937E-09  0.19765226E-09  0.94853134E+00
+     6    14    10  0.13612843E-09  0.19176846E-09  0.70985829E+00
+     6    14    11  0.00000000E+00  0.00000000E+00  0.52643605E+00
+     6    14    12  0.00000000E+00  0.00000000E+00  0.86933926E+00
+     6    14    13  0.00000000E+00  0.00000000E+00  0.10090678E+01
+     6    14    14  0.00000000E+00  0.00000000E+00  0.99218681E+00
+     6    15     1  0.87094346E-18  0.84284572E-18  0.10333368E+01
+     6    15     2  0.32574543E-16  0.31503338E-16  0.10340029E+01
+     6    15     3  0.83696326E-15  0.80839570E-15  0.10353386E+01
+     6    15     4  0.16008570E-13  0.15422176E-13  0.10380228E+01
+     6    15     5  0.32780069E-11  0.31416087E-11  0.10434167E+01
+     6    15     6  0.67515010E-10  0.64036470E-10  0.10543212E+01
+     6    15     7  0.48785796E-10  0.45284921E-10  0.10773077E+01
+     6    15     8  0.20122390E-09  0.20179049E-09  0.99719217E+00
+     6    15     9  0.91440036E-09  0.93991066E-09  0.97285881E+00
+     6    15    10  0.69612395E-09  0.10880786E-08  0.63977360E+00
+     6    15    11  0.00000000E+00  0.00000000E+00  0.43915858E+00
+     6    15    12  0.00000000E+00  0.00000000E+00  0.89587341E+00
+     6    15    13  0.00000000E+00  0.00000000E+00  0.92805872E+00
+     6    15    14  0.00000000E+00  0.00000000E+00  0.95347945E+00
+     6    15    15  0.00000000E+00  0.00000000E+00  0.10003488E+01
+     6    16     1  0.28267960E-17  0.27492518E-17  0.10282055E+01
+     6    16     2  0.10467263E-15  0.10176639E-15  0.10285579E+01
+     6    16     3  0.26594181E-14  0.25837998E-14  0.10292663E+01
+     6    16     4  0.50237418E-13  0.48741622E-13  0.10306883E+01
+     6    16     5  0.10130842E-10  0.98020245E-11  0.10335459E+01
+     6    16     6  0.20633192E-09  0.19853078E-09  0.10392943E+01
+     6    16     7  0.13497627E-09  0.12889573E-09  0.10471741E+01
+     6    16     8  0.59451736E-09  0.55510958E-09  0.10709910E+01
+     6    16     9  0.42058539E-08  0.42083703E-08  0.99940203E+00
+     6    16    10  0.39871752E-08  0.58166051E-08  0.68548151E+00
+     6    16    11  0.00000000E+00  0.00000000E+00  0.45779332E+00
+     6    16    12  0.00000000E+00  0.00000000E+00  0.90358367E+00
+     6    16    13  0.00000000E+00  0.00000000E+00  0.85241134E+00
+     6    16    14  0.00000000E+00  0.00000000E+00  0.64492282E+00
+     6    16    15  0.00000000E+00  0.00000000E+00  0.88262484E+00
+     6    16    16  0.00000000E+00  0.00000000E+00  0.96504988E+00
+     6    17     1  0.90019123E-17  0.87964028E-17  0.10233629E+01
+     6    17     2  0.33030558E-15  0.32270645E-15  0.10235481E+01
+     6    17     3  0.83041458E-14  0.81101315E-14  0.10239225E+01
+     6    17     4  0.15495007E-12  0.15121865E-12  0.10246757E+01
+     6    17     5  0.30711389E-10  0.29927666E-10  0.10261872E+01
+     6    17     6  0.61621229E-09  0.59873441E-09  0.10291914E+01
+     6    17     7  0.36865390E-09  0.35937410E-09  0.10258221E+01
+     6    17     8  0.15615604E-08  0.15419845E-08  0.10126953E+01
+     6    17     9  0.12964617E-07  0.12111659E-07  0.10704245E+01
+     6    17    10  0.19443646E-07  0.30230152E-07  0.64318717E+00
+     6    17    11  0.00000000E+00  0.00000000E+00  0.43613131E+00
+     6    17    12  0.00000000E+00  0.00000000E+00  0.82081966E+00
+     6    17    13  0.00000000E+00  0.00000000E+00  0.83349376E+00
+     6    17    14  0.00000000E+00  0.00000000E+00  0.63756211E+00
+     6    17    15  0.00000000E+00  0.00000000E+00  0.65785445E+00
+     6    17    16  0.00000000E+00  0.00000000E+00  0.10677681E+01
+     6    17    17  0.00000000E+00  0.00000000E+00  0.99050797E+00
+     6    18     1  0.28216272E-16  0.27697475E-16  0.10187308E+01
+     6    18     2  0.10269592E-14  0.10079812E-14  0.10188277E+01
+     6    18     3  0.25571429E-13  0.25094012E-13  0.10190251E+01
+     6    18     4  0.47161424E-12  0.46262791E-12  0.10194245E+01
+     6    18     5  0.91827247E-10  0.90006734E-10  0.10202264E+01
+     6    18     6  0.18104590E-08  0.17720619E-08  0.10216680E+01
+     6    18     7  0.10327986E-08  0.10286653E-08  0.10040181E+01
+     6    18     8  0.46691383E-08  0.46151033E-08  0.10117083E+01
+     6    18     9  0.31497890E-07  0.30047516E-07  0.10482693E+01
+     6    18    10  0.36311332E-07  0.10910293E-06  0.33281721E+00
+     6    18    11  0.00000000E+00  0.00000000E+00  0.23695460E+00
+     6    18    12  0.00000000E+00  0.00000000E+00  0.50359715E+00
+     6    18    13  0.00000000E+00  0.00000000E+00  0.67458613E+00
+     6    18    14  0.00000000E+00  0.00000000E+00  0.61393011E+00
+     6    18    15  0.00000000E+00  0.00000000E+00  0.59434079E+00
+     6    18    16  0.00000000E+00  0.00000000E+00  0.11042773E+01
+     6    18    17  0.00000000E+00  0.00000000E+00  0.10195210E+01
+     6    18    18  0.00000000E+00  0.00000000E+00  0.10596630E+01
+     7     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     7     7     1  0.75383870E-16  0.70339638E-16  0.10717125E+01
+     7     7     2  0.16274591E-15  0.15497715E-15  0.10501284E+01
+     7     7     3  0.36301927E-15  0.35584978E-15  0.10201475E+01
+     7     7     4  0.82414327E-15  0.83315071E-15  0.98918871E+00
+     7     7     5  0.17808650E-14  0.18499317E-14  0.96266528E+00
+     7     7     6  0.28506406E-14  0.30736449E-14  0.92744630E+00
+     7     7     7  0.17164454E-14  0.19381765E-14  0.88559810E+00
+     7     8     1  0.22748232E-16  0.21279300E-16  0.10690310E+01
+     7     8     2  0.40307285E-16  0.37863343E-16  0.10645464E+01
+     7     8     3  0.60472617E-16  0.57984254E-16  0.10429145E+01
+     7     8     4  0.82973365E-16  0.81912686E-16  0.10129489E+01
+     7     8     5  0.16300374E-15  0.16604053E-15  0.98171053E+00
+     7     8     6  0.18160098E-14  0.19101697E-14  0.95070600E+00
+     7     8     7  0.20466700E-13  0.22304481E-13  0.91760486E+00
+     7     8     8  0.26689652E-14  0.27450292E-14  0.97229026E+00
+     7     9     1  0.63576607E-24  0.58045302E-24  0.10952929E+01
+     7     9     2  0.71590998E-22  0.67340865E-22  0.10631137E+01
+     7     9     3  0.47401652E-20  0.44767950E-20  0.10588301E+01
+     7     9     4  0.20578107E-18  0.19843297E-18  0.10370306E+01
+     7     9     5  0.67632039E-17  0.67247864E-17  0.10057128E+01
+     7     9     6  0.67082957E-14  0.68841141E-14  0.97446026E+00
+     7     9     7  0.13047221E-12  0.13882832E-12  0.93980978E+00
+     7     9     8  0.34478589E-13  0.35118046E-13  0.98179121E+00
+     7     9     9  0.67268355E-17  0.67619137E-17  0.99481238E+00
+     7    10     1  0.24012144E-23  0.22332169E-23  0.10752267E+01
+     7    10     2  0.28828563E-21  0.26420855E-21  0.10911291E+01
+     7    10     3  0.18969555E-19  0.17931806E-19  0.10578720E+01
+     7    10     4  0.85908998E-18  0.81543325E-18  0.10535381E+01
+     7    10     5  0.28638160E-16  0.27758366E-16  0.10316947E+01
+     7    10     6  0.27736962E-13  0.27689018E-13  0.10017315E+01
+     7    10     7  0.55710565E-12  0.57685905E-12  0.96575697E+00
+     7    10     8  0.17671875E-12  0.18107934E-12  0.97591894E+00
+     7    10     9  0.56091060E-16  0.56331028E-16  0.99574004E+00
+     7    10    10  0.21455656E-21  0.21574486E-21  0.99449213E+00
+     7    11     1  0.10925936E-22  0.10287117E-22  0.10620990E+01
+     7    11     2  0.13661061E-20  0.12762471E-20  0.10704087E+01
+     7    11     3  0.97624768E-19  0.89784583E-19  0.10873222E+01
+     7    11     4  0.42859262E-17  0.40714258E-17  0.10526843E+01
+     7    11     5  0.13612708E-15  0.12986446E-15  0.10482243E+01
+     7    11     6  0.11650221E-12  0.11357930E-12  0.10257345E+01
+     7    11     7  0.22125337E-11  0.22305714E-11  0.99191343E+00
+     7    11     8  0.84573876E-12  0.87343155E-12  0.96829426E+00
+     7    11     9  0.25272243E-15  0.25348732E-15  0.99698253E+00
+     7    11    10  0.16891179E-20  0.16973955E-20  0.99512340E+00
+     7    11    11  0.25296856E-26  0.25449571E-26  0.99399930E+00
+     7    12     1  0.45991491E-22  0.43692139E-22  0.10526262E+01
+     7    12     2  0.56623534E-20  0.53567326E-20  0.10570536E+01
+     7    12     3  0.38986074E-18  0.36570922E-18  0.10660402E+01
+     7    12     4  0.17125173E-16  0.15792543E-16  0.10843835E+01
+     7    12     5  0.49795785E-15  0.47548044E-15  0.10472730E+01
+     7    12     6  0.41582072E-12  0.39865109E-12  0.10430693E+01
+     7    12     7  0.80405433E-11  0.78888281E-11  0.10192317E+01
+     7    12     8  0.48235026E-11  0.50364508E-11  0.95771860E+00
+     7    12     9  0.25110966E-12  0.25548888E-12  0.98285946E+00
+     7    12    10  0.76757058E-20  0.77034052E-20  0.99640426E+00
+     7    12    11  0.20042018E-25  0.20145768E-25  0.99485003E+00
+     7    12    12  0.55411859E-30  0.55759371E-30  0.99376764E+00
+     7    13     1  0.15872551E-21  0.15186726E-21  0.10451595E+01
+     7    13     2  0.19226789E-19  0.18354492E-19  0.10475250E+01
+     7    13     3  0.13003068E-17  0.12357070E-17  0.10522776E+01
+     7    13     4  0.56044923E-16  0.52779251E-16  0.10618742E+01
+     7    13     5  0.17108926E-14  0.15820430E-14  0.10814451E+01
+     7    13     6  0.13932382E-11  0.13367079E-11  0.10422907E+01
+     7    13     7  0.27927705E-10  0.26911751E-10  0.10377513E+01
+     7    13     8  0.20132943E-10  0.19952607E-10  0.10090382E+01
+     7    13     9  0.41740711E-10  0.44651005E-10  0.93482132E+00
+     7    13    10  0.57573205E-10  0.70109183E-10  0.82119350E+00
+     7    13    11  0.94618918E-12  0.10113566E-11  0.93556432E+00
+     7    13    12  0.32557344E-18  0.32702051E-18  0.99557497E+00
+     7    13    13  0.18416244E-32  0.18546021E-32  0.99300243E+00
+     7    14     1  0.53361294E-21  0.51363412E-21  0.10388970E+01
+     7    14     2  0.63891763E-19  0.61425394E-19  0.10401523E+01
+     7    14     3  0.42673120E-17  0.40926728E-17  0.10426712E+01
+     7    14     4  0.18148539E-15  0.17321063E-15  0.10477728E+01
+     7    14     5  0.54619414E-14  0.51624980E-14  0.10580036E+01
+     7    14     6  0.47236288E-11  0.43784232E-11  0.10788424E+01
+     7    14     7  0.92754263E-10  0.89413683E-10  0.10373609E+01
+     7    14     8  0.49370788E-10  0.50479436E-10  0.97803764E+00
+     7    14     9  0.12673080E-09  0.13360740E-09  0.94853134E+00
+     7    14    10  0.42080339E-09  0.59279915E-09  0.70985829E+00
+     7    14    11  0.29757345E-10  0.56526041E-10  0.52643605E+00
+     7    14    12  0.87043229E-11  0.10012573E-10  0.86933926E+00
+     7    14    13  0.79772007E-15  0.79055147E-15  0.10090678E+01
+     7    14    14  0.16740399E-24  0.16872225E-24  0.99218681E+00
+     7    15     1  0.17643878E-20  0.17074664E-20  0.10333368E+01
+     7    15     2  0.20897811E-18  0.20210593E-18  0.10340029E+01
+     7    15     3  0.13793694E-16  0.13322882E-16  0.10353386E+01
+     7    15     4  0.57928338E-15  0.55806423E-15  0.10380228E+01
+     7    15     5  0.17213981E-13  0.16497705E-13  0.10434167E+01
+     7    15     6  0.14732172E-10  0.13973134E-10  0.10543212E+01
+     7    15     7  0.29454309E-09  0.27340664E-09  0.10773077E+01
+     7    15     8  0.16091325E-09  0.16136634E-09  0.99719217E+00
+     7    15     9  0.71975699E-09  0.73983705E-09  0.97285881E+00
+     7    15    10  0.23518637E-08  0.36760875E-08  0.63977360E+00
+     7    15    11  0.20681185E-09  0.47092750E-09  0.43915858E+00
+     7    15    12  0.43997396E-09  0.49111175E-09  0.89587341E+00
+     7    15    13  0.19594302E-09  0.21113214E-09  0.92805872E+00
+     7    15    14  0.12735286E-10  0.13356644E-10  0.95347945E+00
+     7    15    15  0.13042227E-22  0.13037680E-22  0.10003488E+01
+     7    16     1  0.57239891E-20  0.55669697E-20  0.10282055E+01
+     7    16     2  0.67119165E-18  0.65255601E-18  0.10285579E+01
+     7    16     3  0.43807898E-16  0.42562258E-16  0.10292663E+01
+     7    16     4  0.18170565E-14  0.17629545E-14  0.10306883E+01
+     7    16     5  0.53274420E-13  0.51545287E-13  0.10335459E+01
+     7    16     6  0.44940692E-10  0.43241544E-10  0.10392943E+01
+     7    16     7  0.79755588E-09  0.76162684E-09  0.10471741E+01
+     7    16     8  0.40611352E-09  0.37919415E-09  0.10709910E+01
+     7    16     9  0.47805855E-08  0.47834459E-08  0.99940203E+00
+     7    16    10  0.14921406E-07  0.21767773E-07  0.68548151E+00
+     7    16    11  0.13942051E-08  0.30454903E-08  0.45779332E+00
+     7    16    12  0.33026033E-08  0.36550055E-08  0.90358367E+00
+     7    16    13  0.27559936E-08  0.32331733E-08  0.85241134E+00
+     7    16    14  0.11991608E-08  0.18593865E-08  0.64492282E+00
+     7    16    15  0.36716069E-09  0.41598726E-09  0.88262484E+00
+     7    16    16  0.44687342E-10  0.46305733E-10  0.96504988E+00
+     7    17     1  0.18220406E-19  0.17804443E-19  0.10233629E+01
+     7    17     2  0.21170626E-17  0.20683566E-17  0.10235481E+01
+     7    17     3  0.13672739E-15  0.13353295E-15  0.10239225E+01
+     7    17     4  0.56016830E-14  0.54667862E-14  0.10246757E+01
+     7    17     5  0.16180989E-12  0.15768067E-12  0.10261872E+01
+     7    17     6  0.13340506E-09  0.12962124E-09  0.10291914E+01
+     7    17     7  0.21602857E-08  0.21059067E-08  0.10258221E+01
+     7    17     8  0.11375825E-08  0.11233216E-08  0.10126953E+01
+     7    17     9  0.11068187E-07  0.10339998E-07  0.10704245E+01
+     7    17    10  0.72234161E-07  0.11230660E-06  0.64318717E+00
+     7    17    11  0.64803810E-08  0.14858784E-07  0.43613131E+00
+     7    17    12  0.17123209E-07  0.20861109E-07  0.82081966E+00
+     7    17    13  0.17706103E-07  0.21243234E-07  0.83349376E+00
+     7    17    14  0.95794113E-08  0.15025064E-07  0.63756211E+00
+     7    17    15  0.37196547E-08  0.56542214E-08  0.65785445E+00
+     7    17    16  0.23480814E-09  0.21990555E-09  0.10677681E+01
+     7    17    17  0.28379701E-11  0.28651663E-11  0.99050797E+00
+     7    18     1  0.57090300E-19  0.56040612E-19  0.10187308E+01
+     7    18     2  0.65795044E-17  0.64579170E-17  0.10188277E+01
+     7    18     3  0.42084525E-15  0.41298809E-15  0.10190251E+01
+     7    18     4  0.17041181E-13  0.16716472E-13  0.10194245E+01
+     7    18     5  0.48485518E-12  0.47524272E-12  0.10202264E+01
+     7    18     6  0.38803491E-09  0.37980529E-09  0.10216680E+01
+     7    18     7  0.59983677E-08  0.59743620E-08  0.10040181E+01
+     7    18     8  0.36072901E-08  0.35655437E-08  0.10117083E+01
+     7    18     9  0.15725344E-07  0.15001244E-07  0.10482693E+01
+     7    18    10  0.12635167E-06  0.37964284E-06  0.33281721E+00
+     7    18    11  0.11900170E-07  0.50221310E-07  0.23695460E+00
+     7    18    12  0.39685736E-07  0.78804529E-07  0.50359715E+00
+     7    18    13  0.53140610E-07  0.78775129E-07  0.67458613E+00
+     7    18    14  0.41009674E-07  0.66798603E-07  0.61393011E+00
+     7    18    15  0.55545340E-07  0.93457055E-07  0.59434079E+00
+     7    18    16  0.24200250E-07  0.21915011E-07  0.11042773E+01
+     7    18    17  0.14144387E-13  0.13873562E-13  0.10195210E+01
+     7    18    18  0.21446181E-32  0.20238681E-32  0.10596630E+01
+     8     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     8     7     1  0.12591650E-18  0.11749093E-18  0.10717125E+01
+     8     7     2  0.10412657E-17  0.99156035E-18  0.10501284E+01
+     8     7     3  0.82850920E-17  0.81214648E-17  0.10201475E+01
+     8     7     4  0.47157023E-16  0.47672424E-16  0.98918871E+00
+     8     7     5  0.14322439E-15  0.14877901E-15  0.96266528E+00
+     8     7     6  0.26156054E-15  0.28202230E-15  0.92744630E+00
+     8     7     7  0.18365599E-15  0.20738075E-15  0.88559810E+00
+     8     8     1  0.57762478E-15  0.54032556E-15  0.10690310E+01
+     8     8     2  0.12229597E-14  0.11488083E-14  0.10645464E+01
+     8     8     3  0.26863034E-14  0.25757658E-14  0.10429145E+01
+     8     8     4  0.61855206E-14  0.61064488E-14  0.10129489E+01
+     8     8     5  0.14715410E-13  0.14989562E-13  0.98171053E+00
+     8     8     6  0.33098779E-13  0.34814947E-13  0.95070600E+00
+     8     8     7  0.54178502E-13  0.59043391E-13  0.91760486E+00
+     8     8     8  0.37362544E-13  0.38427356E-13  0.97229026E+00
+     8     9     1  0.18022212E-15  0.16454240E-15  0.10952929E+01
+     8     9     2  0.33423695E-15  0.31439436E-15  0.10631137E+01
+     8     9     3  0.59271553E-15  0.55978343E-15  0.10588301E+01
+     8     9     4  0.89225425E-15  0.86039335E-15  0.10370306E+01
+     8     9     5  0.12840154E-14  0.12767218E-14  0.10057128E+01
+     8     9     6  0.27683382E-14  0.28408939E-14  0.97446026E+00
+     8     9     7  0.34178376E-13  0.36367334E-13  0.93980978E+00
+     8     9     8  0.39601946E-12  0.40336424E-12  0.98179121E+00
+     8     9     9  0.50596069E-13  0.50859911E-13  0.99481238E+00
+     8    10     1  0.63311094E-26  0.58881623E-26  0.10752267E+01
+     8    10     2  0.38649232E-24  0.35421320E-24  0.10911291E+01
+     8    10     3  0.77098548E-22  0.72880792E-22  0.10578720E+01
+     8    10     4  0.87455706E-20  0.83011433E-20  0.10535381E+01
+     8    10     5  0.62731409E-18  0.60804235E-18  0.10316947E+01
+     8    10     6  0.30892548E-16  0.30839149E-16  0.10017315E+01
+     8    10     7  0.12678429E-12  0.13127971E-12  0.96575697E+00
+     8    10     8  0.21503729E-11  0.22034339E-11  0.97591894E+00
+     8    10     9  0.47908039E-12  0.48112998E-12  0.99574004E+00
+     8    10    10  0.17911376E-15  0.18010575E-15  0.99449213E+00
+     8    11     1  0.36641897E-26  0.34499511E-26  0.10620990E+01
+     8    11     2  0.18169960E-23  0.16974787E-23  0.10704087E+01
+     8    11     3  0.39718544E-21  0.36528772E-21  0.10873222E+01
+     8    11     4  0.43592213E-19  0.41410527E-19  0.10526843E+01
+     8    11     5  0.29727378E-17  0.28359750E-17  0.10482243E+01
+     8    11     6  0.13154101E-15  0.12824079E-15  0.10257345E+01
+     8    11     7  0.49849330E-12  0.50255727E-12  0.99191343E+00
+     8    11     8  0.88315129E-11  0.91206911E-11  0.96829426E+00
+     8    11     9  0.22254039E-11  0.22321393E-11  0.99698253E+00
+     8    11    10  0.14377637E-14  0.14448094E-14  0.99512340E+00
+     8    11    11  0.13156643E-19  0.13236069E-19  0.99399930E+00
+     8    12     1  0.15422302E-25  0.14651262E-25  0.10526262E+01
+     8    12     2  0.75256790E-23  0.71194867E-23  0.10570536E+01
+     8    12     3  0.15837932E-20  0.14856786E-20  0.10660402E+01
+     8    12     4  0.17382426E-18  0.16029777E-18  0.10843835E+01
+     8    12     5  0.10853160E-16  0.10363257E-16  0.10472730E+01
+     8    12     6  0.47067412E-15  0.45123954E-15  0.10430693E+01
+     8    12     7  0.18270927E-11  0.17926177E-11  0.10192317E+01
+     8    12     8  0.34289457E-10  0.35803270E-10  0.95771860E+00
+     8    12     9  0.92140976E-11  0.93747865E-11  0.98285946E+00
+     8    12    10  0.65613203E-14  0.65849982E-14  0.99640426E+00
+     8    12    11  0.10370958E-18  0.10424645E-18  0.99485003E+00
+     8    12    12  0.99513607E-24  0.10013770E-23  0.99376764E+00
+     8    13     1  0.53195662E-25  0.50897170E-25  0.10451595E+01
+     8    13     2  0.25538594E-22  0.24379938E-22  0.10475250E+01
+     8    13     3  0.52796363E-20  0.50173417E-20  0.10522776E+01
+     8    13     4  0.56867324E-18  0.53553732E-18  0.10618742E+01
+     8    13     5  0.37288083E-16  0.34479868E-16  0.10814451E+01
+     8    13     6  0.15748471E-14  0.15109481E-14  0.10422907E+01
+     8    13     7  0.64031708E-11  0.61702363E-11  0.10377513E+01
+     8    13     8  0.12032879E-09  0.11925097E-09  0.10090382E+01
+     8    13     9  0.75952389E-10  0.81248028E-10  0.93482132E+00
+     8    13    10  0.14438965E-09  0.17582903E-09  0.82119350E+00
+     8    13    11  0.55222581E-10  0.59025959E-10  0.93556432E+00
+     8    13    12  0.11130414E-13  0.11179885E-13  0.99557497E+00
+     8    13    13  0.50009301E-27  0.50361711E-27  0.99300243E+00
+     8    14     1  0.17876083E-24  0.17206791E-24  0.10388970E+01
+     8    14     2  0.84829208E-22  0.81554605E-22  0.10401523E+01
+     8    14     3  0.17319537E-19  0.16610737E-19  0.10426712E+01
+     8    14     4  0.18409072E-17  0.17569717E-17  0.10477728E+01
+     8    14     5  0.11902564E-15  0.11250023E-15  0.10580036E+01
+     8    14     6  0.53342676E-14  0.49444362E-14  0.10788424E+01
+     8    14     7  0.21399846E-10  0.20629123E-10  0.10373609E+01
+     8    14     8  0.31218422E-09  0.31919448E-09  0.97803764E+00
+     8    14     9  0.20930233E-09  0.22065937E-09  0.94853134E+00
+     8    14    10  0.11359364E-08  0.16002299E-08  0.70985829E+00
+     8    14    11  0.16873696E-08  0.32052699E-08  0.52643605E+00
+     8    14    12  0.51444904E-09  0.59177017E-09  0.86933926E+00
+     8    14    13  0.25412515E-11  0.25184149E-11  0.10090678E+01
+     8    14    14  0.79980159E-23  0.80609980E-23  0.99218681E+00
+     8    15     1  0.59083362E-24  0.57177258E-24  0.10333368E+01
+     8    15     2  0.27734018E-21  0.26821993E-21  0.10340029E+01
+     8    15     3  0.55959772E-19  0.54049731E-19  0.10353386E+01
+     8    15     4  0.58737962E-17  0.56586390E-17  0.10380228E+01
+     8    15     5  0.37503657E-15  0.35943125E-15  0.10434167E+01
+     8    15     6  0.16630994E-13  0.15774124E-13  0.10543212E+01
+     8    15     7  0.64199373E-10  0.59592418E-10  0.10773077E+01
+     8    15     8  0.98325153E-09  0.98602011E-09  0.99719217E+00
+     8    15     9  0.15516593E-08  0.15949481E-08  0.97285881E+00
+     8    15    10  0.69864929E-08  0.10920258E-07  0.63977360E+00
+     8    15    11  0.12547427E-07  0.28571518E-07  0.43915858E+00
+     8    15    12  0.22069907E-07  0.24635073E-07  0.89587341E+00
+     8    15    13  0.16181826E-07  0.17436209E-07  0.92805872E+00
+     8    15    14  0.26741150E-08  0.28045858E-08  0.95347945E+00
+     8    15    15  0.61502221E-21  0.61480779E-21  0.10003488E+01
+     8    16     1  0.19160537E-23  0.18634929E-23  0.10282055E+01
+     8    16     2  0.89038304E-21  0.86566155E-21  0.10285579E+01
+     8    16     3  0.17764671E-18  0.17259548E-18  0.10292663E+01
+     8    16     4  0.18416618E-16  0.17868271E-16  0.10306883E+01
+     8    16     5  0.11602426E-14  0.11225845E-14  0.10335459E+01
+     8    16     6  0.50770676E-13  0.48851105E-13  0.10392943E+01
+     8    16     7  0.16811919E-09  0.16054560E-09  0.10471741E+01
+     8    16     8  0.27833403E-08  0.25988457E-08  0.10709910E+01
+     8    16     9  0.92010609E-08  0.92065661E-08  0.99940203E+00
+     8    16    10  0.40761048E-07  0.59463380E-07  0.68548151E+00
+     8    16    11  0.76101821E-07  0.16623620E-06  0.45779332E+00
+     8    16    12  0.19442841E-06  0.21517477E-06  0.90358367E+00
+     8    16    13  0.19020953E-06  0.22314289E-06  0.85241134E+00
+     8    16    14  0.10409145E-06  0.16140141E-06  0.64492282E+00
+     8    16    15  0.39115313E-07  0.44317032E-07  0.88262484E+00
+     8    16    16  0.67171843E-08  0.69604530E-08  0.96504988E+00
+     8    17     1  0.60970488E-23  0.59578559E-23  0.10233629E+01
+     8    17     2  0.28073318E-20  0.27427453E-20  0.10235481E+01
+     8    17     3  0.55420719E-18  0.54125895E-18  0.10239225E+01
+     8    17     4  0.56748807E-16  0.55382213E-16  0.10246757E+01
+     8    17     5  0.35221975E-14  0.34323146E-14  0.10261872E+01
+     8    17     6  0.15110918E-12  0.14682320E-12  0.10291914E+01
+     8    17     7  0.45134188E-09  0.43998064E-09  0.10258221E+01
+     8    17     8  0.73400720E-08  0.72480559E-08  0.10126953E+01
+     8    17     9  0.13791477E-07  0.12884120E-07  0.10704245E+01
+     8    17    10  0.16951923E-06  0.26356128E-06  0.64318717E+00
+     8    17    11  0.32025435E-06  0.73430716E-06  0.43613131E+00
+     8    17    12  0.88249114E-06  0.10751340E-05  0.82081966E+00
+     8    17    13  0.10339522E-05  0.12405038E-05  0.83349376E+00
+     8    17    14  0.62690075E-06  0.98327793E-06  0.63756211E+00
+     8    17    15  0.26852968E-06  0.40819011E-06  0.65785445E+00
+     8    17    16  0.25142494E-07  0.23546773E-07  0.10677681E+01
+     8    17    17  0.22821010E-09  0.23039703E-09  0.99050797E+00
+     8    18     1  0.19098233E-22  0.18747084E-22  0.10187308E+01
+     8    18     2  0.87216433E-20  0.85604696E-20  0.10188277E+01
+     8    18     3  0.17051467E-17  0.16733117E-17  0.10190251E+01
+     8    18     4  0.17255781E-15  0.16926982E-15  0.10194245E+01
+     8    18     5  0.10548080E-13  0.10338960E-13  0.10202264E+01
+     8    18     6  0.44244011E-12  0.43305664E-12  0.10216680E+01
+     8    18     7  0.12818379E-08  0.12767079E-08  0.10040181E+01
+     8    18     8  0.20515271E-07  0.20277852E-07  0.10117083E+01
+     8    18     9  0.94845373E-08  0.90478057E-08  0.10482693E+01
+     8    18    10  0.31028058E-06  0.93228526E-06  0.33281721E+00
+     8    18    11  0.57185191E-06  0.24133396E-05  0.23695460E+00
+     8    18    12  0.18926217E-05  0.37582059E-05  0.50359715E+00
+     8    18    13  0.27636254E-05  0.40967717E-05  0.67458613E+00
+     8    18    14  0.21861065E-05  0.35608394E-05  0.61393011E+00
+     8    18    15  0.29846407E-05  0.50217665E-05  0.59434079E+00
+     8    18    16  0.16192264E-05  0.14663223E-05  0.11042773E+01
+     8    18    17  0.33820762E-09  0.33173189E-09  0.10195210E+01
+     8    18    18  0.79159535E-30  0.74702558E-30  0.10596630E+01
+     9     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+     9     7     1  0.00000000E+00  0.00000000E+00  0.10717125E+01
+     9     7     2  0.00000000E+00  0.00000000E+00  0.10501284E+01
+     9     7     3  0.00000000E+00  0.00000000E+00  0.10201475E+01
+     9     7     4  0.00000000E+00  0.00000000E+00  0.98918871E+00
+     9     7     5  0.00000000E+00  0.00000000E+00  0.96266528E+00
+     9     7     6  0.00000000E+00  0.00000000E+00  0.92744630E+00
+     9     7     7  0.00000000E+00  0.00000000E+00  0.88559810E+00
+     9     8     1  0.17170630E-18  0.16061863E-18  0.10690310E+01
+     9     8     2  0.21484891E-17  0.20182203E-17  0.10645464E+01
+     9     8     3  0.18003150E-16  0.17262346E-16  0.10429145E+01
+     9     8     4  0.14518486E-15  0.14332891E-15  0.10129489E+01
+     9     8     5  0.81753094E-15  0.83276170E-15  0.98171053E+00
+     9     8     6  0.24778065E-14  0.26062805E-14  0.95070600E+00
+     9     8     7  0.46611955E-14  0.50797415E-14  0.91760486E+00
+     9     8     8  0.40666721E-14  0.41825700E-14  0.97229026E+00
+     9     9     1  0.44196733E-14  0.40351520E-14  0.10952929E+01
+     9     9     2  0.92244209E-14  0.86767960E-14  0.10631137E+01
+     9     9     3  0.19714590E-13  0.18619220E-13  0.10588301E+01
+     9     9     4  0.44261020E-13  0.42680533E-13  0.10370306E+01
+     9     9     5  0.10723288E-12  0.10662376E-12  0.10057128E+01
+     9     9     6  0.27313233E-12  0.28029089E-12  0.97446026E+00
+     9     9     7  0.62720522E-12  0.66737464E-12  0.93980978E+00
+     9     9     8  0.10797531E-11  0.10997787E-11  0.98179121E+00
+     9     9     9  0.78021563E-12  0.78428420E-12  0.99481238E+00
+     9    10     1  0.13133572E-14  0.12214701E-14  0.10752267E+01
+     9    10     2  0.26274898E-14  0.24080468E-14  0.10911291E+01
+     9    10     3  0.48723831E-14  0.46058343E-14  0.10578720E+01
+     9    10     4  0.87717159E-14  0.83259599E-14  0.10535381E+01
+     9    10     5  0.13873948E-13  0.13447726E-13  0.10316947E+01
+     9    10     6  0.22526481E-13  0.22487544E-13  0.10017315E+01
+     9    10     7  0.48862597E-13  0.50595127E-13  0.96575697E+00
+     9    10     8  0.60888967E-12  0.62391418E-12  0.97591894E+00
+     9    10     9  0.59375069E-11  0.59629087E-11  0.99574004E+00
+     9    10    10  0.80073445E-12  0.80516922E-12  0.99449213E+00
+     9    11     1  0.31571445E-26  0.29725520E-26  0.10620990E+01
+     9    11     2  0.39918992E-26  0.37293223E-26  0.10704087E+01
+     9    11     3  0.39288552E-24  0.36133313E-24  0.10873222E+01
+     9    11     4  0.12204372E-21  0.11593572E-21  0.10526843E+01
+     9    11     5  0.19623178E-19  0.18720400E-19  0.10482243E+01
+     9    11     6  0.17739411E-17  0.17294350E-17  0.10257345E+01
+     9    11     7  0.10138267E-15  0.10220919E-15  0.99191343E+00
+     9    11     8  0.23833593E-11  0.24613998E-11  0.96829426E+00
+     9    11     9  0.31608532E-10  0.31704199E-10  0.99698253E+00
+     9    11    10  0.73190806E-11  0.73549478E-11  0.99512340E+00
+     9    11    11  0.43144964E-14  0.43405426E-14  0.99399930E+00
+     9    12     1  0.84050482E-30  0.79848365E-30  0.10526262E+01
+     9    12     2  0.20397872E-26  0.19296914E-26  0.10570536E+01
+     9    12     3  0.15564345E-23  0.14600148E-23  0.10660402E+01
+     9    12     4  0.48576196E-21  0.44796140E-21  0.10843835E+01
+     9    12     5  0.71515789E-19  0.68287626E-19  0.10472730E+01
+     9    12     6  0.63431216E-17  0.60812081E-17  0.10430693E+01
+     9    12     7  0.37041516E-15  0.36342588E-15  0.10192317E+01
+     9    12     8  0.11148810E-10  0.11641008E-10  0.95771860E+00
+     9    12     9  0.13047129E-09  0.13274664E-09  0.98285946E+00
+     9    12    10  0.34386293E-10  0.34510384E-10  0.99640426E+00
+     9    12    11  0.34706463E-13  0.34886126E-13  0.99485003E+00
+     9    12    12  0.69969610E-18  0.70408420E-18  0.99376764E+00
+     9    13     1  0.28978996E-29  0.27726864E-29  0.10451595E+01
+     9    13     2  0.69187780E-26  0.66048812E-26  0.10475250E+01
+     9    13     3  0.51861184E-23  0.49284698E-23  0.10522776E+01
+     9    13     4  0.15887187E-20  0.14961459E-20  0.10618742E+01
+     9    13     5  0.24569972E-18  0.22719574E-18  0.10814451E+01
+     9    13     6  0.21230907E-16  0.20369468E-16  0.10422907E+01
+     9    13     7  0.12939744E-14  0.12469022E-14  0.10377513E+01
+     9    13     8  0.29546637E-10  0.29281980E-10  0.10090382E+01
+     9    13     9  0.40921821E-09  0.43775019E-09  0.93482132E+00
+     9    13    10  0.38603171E-09  0.47008617E-09  0.82119350E+00
+     9    13    11  0.26671002E-09  0.28507929E-09  0.93556432E+00
+     9    13    12  0.40287958E-11  0.40467026E-11  0.99557497E+00
+     9    13    13  0.11814854E-21  0.11898112E-21  0.99300243E+00
+     9    14     1  0.97351052E-29  0.93706165E-29  0.10388970E+01
+     9    14     2  0.22973448E-25  0.22086620E-25  0.10401523E+01
+     9    14     3  0.17006937E-22  0.16310930E-22  0.10426712E+01
+     9    14     4  0.51415837E-20  0.49071549E-20  0.10477728E+01
+     9    14     5  0.78420352E-18  0.74121064E-18  0.10580036E+01
+     9    14     6  0.71929125E-16  0.66672502E-16  0.10788424E+01
+     9    14     7  0.43150728E-14  0.41596638E-14  0.10373609E+01
+     9    14     8  0.89321786E-10  0.91327555E-10  0.97803764E+00
+     9    14     9  0.12316440E-08  0.12984747E-08  0.94853134E+00
+     9    14    10  0.26773158E-08  0.37716202E-08  0.70985829E+00
+     9    14    11  0.55570811E-08  0.10556042E-07  0.52643605E+00
+     9    14    12  0.34963586E-08  0.40218574E-08  0.86933926E+00
+     9    14    13  0.28841871E-09  0.28582688E-09  0.10090678E+01
+     9    14    14  0.17905845E-22  0.18046848E-22  0.99218681E+00
+     9    15     1  0.32166291E-28  0.31128566E-28  0.10333368E+01
+     9    15     2  0.75083157E-25  0.72614068E-25  0.10340029E+01
+     9    15     3  0.54929802E-22  0.53054916E-22  0.10353386E+01
+     9    15     4  0.16399892E-19  0.15799164E-19  0.10380228E+01
+     9    15     5  0.24704255E-17  0.23676307E-17  0.10434167E+01
+     9    15     6  0.22427503E-15  0.21271983E-15  0.10543212E+01
+     9    15     7  0.13246754E-13  0.12296166E-13  0.10773077E+01
+     9    15     8  0.34128105E-09  0.34224201E-09  0.99719217E+00
+     9    15     9  0.57082312E-08  0.58674817E-08  0.97285881E+00
+     9    15    10  0.15108227E-07  0.23614959E-07  0.63977360E+00
+     9    15    11  0.35273338E-07  0.80320274E-07  0.43915858E+00
+     9    15    12  0.69184134E-07  0.77225346E-07  0.89587341E+00
+     9    15    13  0.43914185E-07  0.47318326E-07  0.92805872E+00
+     9    15    14  0.11948527E-07  0.12531499E-07  0.95347945E+00
+     9    15    15  0.13366098E-20  0.13361438E-20  0.10003488E+01
+     9    16     1  0.10428464E-27  0.10142392E-27  0.10282055E+01
+     9    16     2  0.24096880E-24  0.23427830E-24  0.10285579E+01
+     9    16     3  0.17431215E-21  0.16935574E-21  0.10292663E+01
+     9    16     4  0.51400476E-19  0.49870050E-19  0.10306883E+01
+     9    16     5  0.76401174E-17  0.73921413E-17  0.10335459E+01
+     9    16     6  0.68452773E-15  0.65864665E-15  0.10392943E+01
+     9    16     7  0.38879156E-13  0.37127691E-13  0.10471741E+01
+     9    16     8  0.64847389E-09  0.60548959E-09  0.10709910E+01
+     9    16     9  0.23437747E-07  0.23451770E-07  0.99940203E+00
+     9    16    10  0.76226749E-07  0.11120176E-06  0.68548151E+00
+     9    16    11  0.17548271E-06  0.38332301E-06  0.45779332E+00
+     9    16    12  0.49178310E-06  0.54425850E-06  0.90358367E+00
+     9    16    13  0.56701894E-06  0.66519404E-06  0.85241134E+00
+     9    16    14  0.37855595E-06  0.58697868E-06  0.64492282E+00
+     9    16    15  0.24050374E-06  0.27248694E-06  0.88262484E+00
+     9    16    16  0.58604384E-07  0.60726793E-07  0.96504988E+00
+     9    17     1  0.33175728E-27  0.32418341E-27  0.10233629E+01
+     9    17     2  0.75952279E-24  0.74204892E-24  0.10235481E+01
+     9    17     3  0.54360408E-21  0.53090357E-21  0.10239225E+01
+     9    17     4  0.15831914E-18  0.15450658E-18  0.10246757E+01
+     9    17     5  0.23182621E-16  0.22591025E-16  0.10261872E+01
+     9    17     6  0.20367961E-14  0.19790256E-14  0.10291914E+01
+     9    17     7  0.61229877E-12  0.59688590E-12  0.10258221E+01
+     9    17     8  0.21250817E-08  0.20984414E-08  0.10126953E+01
+     9    17     9  0.40682966E-07  0.38006386E-07  0.10704245E+01
+     9    17    10  0.27876841E-06  0.43341725E-06  0.64318717E+00
+     9    17    11  0.65589155E-06  0.15038855E-05  0.43613131E+00
+     9    17    12  0.18143987E-05  0.22104718E-05  0.82081966E+00
+     9    17    13  0.25453834E-05  0.30538722E-05  0.83349376E+00
+     9    17    14  0.18826841E-05  0.29529422E-05  0.63756211E+00
+     9    17    15  0.11125666E-05  0.16912048E-05  0.65785445E+00
+     9    17    16  0.14621141E-06  0.13693180E-06  0.10677681E+01
+     9    17    17  0.96953249E-09  0.97882351E-09  0.99050797E+00
+     9    18     1  0.10389498E-26  0.10198472E-26  0.10187308E+01
+     9    18     2  0.23589608E-23  0.23153679E-23  0.10188277E+01
+     9    18     3  0.16719424E-20  0.16407273E-20  0.10190251E+01
+     9    18     4  0.48120506E-18  0.47203597E-18  0.10194245E+01
+     9    18     5  0.69389762E-16  0.68014081E-16  0.10202264E+01
+     9    18     6  0.77629324E-14  0.75982926E-14  0.10216680E+01
+     9    18     7  0.10091706E-09  0.10051319E-09  0.10040181E+01
+     9    18     8  0.61854988E-08  0.61139153E-08  0.10117083E+01
+     9    18     9  0.72467842E-07  0.69130938E-07  0.10482693E+01
+     9    18    10  0.60953438E-06  0.18314389E-05  0.33281721E+00
+     9    18    11  0.12257077E-05  0.51727534E-05  0.23695460E+00
+     9    18    12  0.37764343E-05  0.74989192E-05  0.50359715E+00
+     9    18    13  0.61965657E-05  0.91857294E-05  0.67458613E+00
+     9    18    14  0.54488576E-05  0.88753711E-05  0.61393011E+00
+     9    18    15  0.75251885E-05  0.12661403E-04  0.59434079E+00
+     9    18    16  0.38437191E-05  0.34807552E-05  0.11042773E+01
+     9    18    17  0.75989497E-08  0.74534511E-08  0.10195210E+01
+     9    18    18  0.60172969E-28  0.56785007E-28  0.10596630E+01
+    10     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    10     7     1  0.00000000E+00  0.00000000E+00  0.10717125E+01
+    10     7     2  0.00000000E+00  0.00000000E+00  0.10501284E+01
+    10     7     3  0.00000000E+00  0.00000000E+00  0.10201475E+01
+    10     7     4  0.00000000E+00  0.00000000E+00  0.98918871E+00
+    10     7     5  0.00000000E+00  0.00000000E+00  0.96266528E+00
+    10     7     6  0.00000000E+00  0.00000000E+00  0.92744630E+00
+    10     7     7  0.00000000E+00  0.00000000E+00  0.88559810E+00
+    10     8     1  0.00000000E+00  0.00000000E+00  0.10690310E+01
+    10     8     2  0.00000000E+00  0.00000000E+00  0.10645464E+01
+    10     8     3  0.00000000E+00  0.00000000E+00  0.10429145E+01
+    10     8     4  0.00000000E+00  0.00000000E+00  0.10129489E+01
+    10     8     5  0.00000000E+00  0.00000000E+00  0.98171053E+00
+    10     8     6  0.00000000E+00  0.00000000E+00  0.95070600E+00
+    10     8     7  0.00000000E+00  0.00000000E+00  0.91760486E+00
+    10     8     8  0.00000000E+00  0.00000000E+00  0.97229026E+00
+    10     9     1  0.71854053E-18  0.65602593E-18  0.10952929E+01
+    10     9     2  0.28863993E-17  0.27150429E-17  0.10631137E+01
+    10     9     3  0.36409529E-16  0.34386564E-16  0.10588301E+01
+    10     9     4  0.31224691E-15  0.30109709E-15  0.10370306E+01
+    10     9     5  0.26473252E-14  0.26322874E-14  0.10057128E+01
+    10     9     6  0.15138079E-13  0.15534834E-13  0.97446026E+00
+    10     9     7  0.44011491E-13  0.46830212E-13  0.93980978E+00
+    10     9     8  0.83021346E-13  0.84561102E-13  0.98179121E+00
+    10     9     9  0.76555099E-13  0.76954309E-13  0.99481238E+00
+    10    10     1  0.34441750E-13  0.32032081E-13  0.10752267E+01
+    10    10     2  0.72623710E-13  0.66558313E-13  0.10911291E+01
+    10    10     3  0.15918068E-12  0.15047254E-12  0.10578720E+01
+    10    10     4  0.36916025E-12  0.35040048E-12  0.10535381E+01
+    10    10     5  0.91649380E-12  0.88833815E-12  0.10316947E+01
+    10    10     6  0.23170937E-11  0.23130886E-11  0.10017315E+01
+    10    10     7  0.53616119E-11  0.55517196E-11  0.96575697E+00
+    10    10     8  0.10640822E-10  0.10903387E-10  0.97591894E+00
+    10    10     9  0.16438095E-10  0.16508420E-10  0.99574004E+00
+    10    10    10  0.11957886E-10  0.12024114E-10  0.99449213E+00
+    10    11     1  0.10116734E-13  0.95252265E-14  0.10620990E+01
+    10    11     2  0.21456194E-13  0.20044861E-13  0.10704087E+01
+    10    11     3  0.46352483E-13  0.42629944E-13  0.10873222E+01
+    10    11     4  0.94516138E-13  0.89785831E-13  0.10526843E+01
+    10    11     5  0.18354125E-12  0.17509731E-12  0.10482243E+01
+    10    11     6  0.28419513E-12  0.27706499E-12  0.10257345E+01
+    10    11     7  0.40915018E-12  0.41248577E-12  0.99191343E+00
+    10    11     8  0.12851888E-11  0.13272709E-11  0.96829426E+00
+    10    11     9  0.86486929E-11  0.86748691E-11  0.99698253E+00
+    10    11    10  0.85870348E-10  0.86291156E-10  0.99512340E+00
+    10    11    11  0.11851106E-10  0.11922650E-10  0.99399930E+00
+    10    12     1  0.11914414E-26  0.11318751E-26  0.10526262E+01
+    10    12     2  0.17776731E-26  0.16817247E-26  0.10570536E+01
+    10    12     3  0.21738445E-26  0.20391768E-26  0.10660402E+01
+    10    12     4  0.37023840E-24  0.34142754E-24  0.10843835E+01
+    10    12     5  0.14032631E-21  0.13399210E-21  0.10472730E+01
+    10    12     6  0.27077949E-19  0.25959875E-19  0.10430693E+01
+    10    12     7  0.29839224E-17  0.29276194E-17  0.10192317E+01
+    10    12     8  0.50844898E-11  0.53089601E-11  0.95771860E+00
+    10    12     9  0.34554266E-10  0.35156874E-10  0.98285946E+00
+    10    12    10  0.45769781E-09  0.45934951E-09  0.99640426E+00
+    10    12    11  0.10873694E-09  0.10929983E-09  0.99485003E+00
+    10    12    12  0.96672572E-13  0.97278848E-13  0.99376764E+00
+    10    13     1  0.27817840E-34  0.26615880E-34  0.10451595E+01
+    10    13     2  0.37742651E-30  0.36030311E-30  0.10475250E+01
+    10    13     3  0.12199494E-26  0.11593418E-26  0.10522776E+01
+    10    13     4  0.12078392E-23  0.11374599E-23  0.10618742E+01
+    10    13     5  0.48209794E-21  0.44579050E-21  0.10814451E+01
+    10    13     6  0.90660365E-19  0.86981843E-19  0.10422907E+01
+    10    13     7  0.10431275E-16  0.10051806E-16  0.10377513E+01
+    10    13     8  0.29206635E-11  0.28945024E-11  0.10090382E+01
+    10    13     9  0.18961700E-09  0.20283770E-09  0.93482132E+00
+    10    13    10  0.16611580E-08  0.20228582E-08  0.82119350E+00
+    10    13    11  0.12838446E-08  0.13722676E-08  0.93556432E+00
+    10    13    12  0.66980990E-10  0.67278701E-10  0.99557497E+00
+    10    13    13  0.32200286E-16  0.32427198E-16  0.99300243E+00
+    10    14     1  0.93428489E-34  0.89930465E-34  0.10388970E+01
+    10    14     2  0.12528880E-29  0.12045237E-29  0.10401523E+01
+    10    14     3  0.39995042E-26  0.38358251E-26  0.10426712E+01
+    10    14     4  0.39080479E-23  0.37298618E-23  0.10477728E+01
+    10    14     5  0.15385849E-20  0.14542341E-20  0.10580036E+01
+    10    14     6  0.30721846E-18  0.28476675E-18  0.10788424E+01
+    10    14     7  0.34815263E-16  0.33561378E-16  0.10373609E+01
+    10    14     8  0.73853763E-10  0.75512190E-10  0.97803764E+00
+    10    14     9  0.87805126E-09  0.92569557E-09  0.94853134E+00
+    10    14    10  0.71398166E-08  0.10058087E-07  0.70985829E+00
+    10    14    11  0.13363995E-07  0.25385791E-07  0.52643605E+00
+    10    14    12  0.21804531E-07  0.25081728E-07  0.86933926E+00
+    10    14    13  0.51295620E-08  0.50834659E-08  0.10090678E+01
+    10    14    14  0.11162212E-19  0.11250112E-19  0.99218681E+00
+    10    15     1  0.30863331E-33  0.29867641E-33  0.10333368E+01
+    10    15     2  0.40936616E-29  0.39590426E-29  0.10340029E+01
+    10    15     3  0.12914009E-25  0.12473223E-25  0.10353386E+01
+    10    15     4  0.12461903E-22  0.12005423E-22  0.10380228E+01
+    10    15     5  0.48460478E-20  0.46444031E-20  0.10434167E+01
+    10    15     6  0.95798008E-18  0.90862258E-18  0.10543212E+01
+    10    15     7  0.14150504E-15  0.13135062E-15  0.10773077E+01
+    10    15     8  0.31047013E-09  0.31134433E-09  0.99719217E+00
+    10    15     9  0.55988602E-08  0.57550594E-08  0.97285881E+00
+    10    15    10  0.32288088E-07  0.50467990E-07  0.63977360E+00
+    10    15    11  0.68248406E-07  0.15540720E-06  0.43915858E+00
+    10    15    12  0.17727189E-06  0.19787605E-06  0.89587341E+00
+    10    15    13  0.19608660E-06  0.21128684E-06  0.92805872E+00
+    10    15    14  0.45334057E-07  0.47545919E-07  0.95347945E+00
+    10    15    15  0.29595514E-20  0.29585196E-20  0.10003488E+01
+    10    16     1  0.10003962E-32  0.97295347E-33  0.10282055E+01
+    10    16     2  0.13134617E-28  0.12769934E-28  0.10285579E+01
+    10    16     3  0.40968513E-25  0.39803608E-25  0.10292663E+01
+    10    16     4  0.39045564E-22  0.37883000E-22  0.10306883E+01
+    10    16     5  0.14982644E-19  0.14496351E-19  0.10335459E+01
+    10    16     6  0.29234317E-17  0.28129007E-17  0.10392943E+01
+    10    16     7  0.80123522E-14  0.76514043E-14  0.10471741E+01
+    10    16     8  0.29810615E-10  0.27834608E-10  0.10709910E+01
+    10    16     9  0.21752875E-07  0.21765890E-07  0.99940203E+00
+    10    16    10  0.14232931E-06  0.20763407E-06  0.68548151E+00
+    10    16    11  0.32122138E-06  0.70167337E-06  0.45779332E+00
+    10    16    12  0.88323195E-06  0.97747666E-06  0.90358367E+00
+    10    16    13  0.13397318E-05  0.15716963E-05  0.85241134E+00
+    10    16    14  0.87125873E-06  0.13509504E-05  0.64492282E+00
+    10    16    15  0.61578183E-06  0.69767108E-06  0.88262484E+00
+    10    16    16  0.28397765E-06  0.29426215E-06  0.96504988E+00
+    10    17     1  0.31819268E-32  0.31092849E-32  0.10233629E+01
+    10    17     2  0.41389611E-28  0.40437386E-28  0.10235481E+01
+    10    17     3  0.12772495E-24  0.12474085E-24  0.10239225E+01
+    10    17     4  0.12022235E-21  0.11732722E-21  0.10246757E+01
+    10    17     5  0.45443689E-19  0.44284012E-19  0.10261872E+01
+    10    17     6  0.10303237E-16  0.10011002E-16  0.10291914E+01
+    10    17     7  0.10368783E-11  0.10107778E-11  0.10258221E+01
+    10    17     8  0.10653303E-08  0.10519752E-08  0.10126953E+01
+    10    17     9  0.19103681E-07  0.17846827E-07  0.10704245E+01
+    10    17    10  0.48390378E-06  0.75235298E-06  0.64318717E+00
+    10    17    11  0.11675613E-05  0.26770866E-05  0.43613131E+00
+    10    17    12  0.29381503E-05  0.35795321E-05  0.82081966E+00
+    10    17    13  0.50478561E-05  0.60562614E-05  0.83349376E+00
+    10    17    14  0.43001676E-05  0.67447039E-05  0.63756211E+00
+    10    17    15  0.37322233E-05  0.56733268E-05  0.65785445E+00
+    10    17    16  0.63628861E-06  0.59590524E-06  0.10677681E+01
+    10    17    17  0.33516007E-08  0.33837190E-08  0.99050797E+00
+    10    18     1  0.99630303E-32  0.97798456E-32  0.10187308E+01
+    10    18     2  0.12852114E-27  0.12614611E-27  0.10188277E+01
+    10    18     3  0.39272804E-24  0.38539583E-24  0.10190251E+01
+    10    18     4  0.36528209E-21  0.35832186E-21  0.10194245E+01
+    10    18     5  0.13595863E-18  0.13326319E-18  0.10202264E+01
+    10    18     6  0.36586844E-14  0.35810894E-14  0.10216680E+01
+    10    18     7  0.21529822E-09  0.21443658E-09  0.10040181E+01
+    10    18     8  0.29198530E-08  0.28860621E-08  0.10117083E+01
+    10    18     9  0.17888639E-07  0.17064926E-07  0.10482693E+01
+    10    18    10  0.12812778E-05  0.38497943E-05  0.33281721E+00
+    10    18    11  0.25306046E-05  0.10679703E-04  0.23695460E+00
+    10    18    12  0.68890687E-05  0.13679721E-04  0.50359715E+00
+    10    18    13  0.12422099E-04  0.18414401E-04  0.67458613E+00
+    10    18    14  0.12477810E-04  0.20324479E-04  0.61393011E+00
+    10    18    15  0.17094228E-04  0.28761660E-04  0.59434079E+00
+    10    18    16  0.65930072E-05  0.59704269E-05  0.11042773E+01
+    10    18    17  0.14670518E-07  0.14389618E-07  0.10195210E+01
+    10    18    18  0.10131238E-25  0.95608116E-26  0.10596630E+01
+    11     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    11     7     1  0.00000000E+00  0.00000000E+00  0.10717125E+01
+    11     7     2  0.00000000E+00  0.00000000E+00  0.10501284E+01
+    11     7     3  0.00000000E+00  0.00000000E+00  0.10201475E+01
+    11     7     4  0.00000000E+00  0.00000000E+00  0.98918871E+00
+    11     7     5  0.00000000E+00  0.00000000E+00  0.96266528E+00
+    11     7     6  0.00000000E+00  0.00000000E+00  0.92744630E+00
+    11     7     7  0.00000000E+00  0.00000000E+00  0.88559810E+00
+    11     8     1  0.00000000E+00  0.00000000E+00  0.10690310E+01
+    11     8     2  0.00000000E+00  0.00000000E+00  0.10645464E+01
+    11     8     3  0.00000000E+00  0.00000000E+00  0.10429145E+01
+    11     8     4  0.00000000E+00  0.00000000E+00  0.10129489E+01
+    11     8     5  0.00000000E+00  0.00000000E+00  0.98171053E+00
+    11     8     6  0.00000000E+00  0.00000000E+00  0.95070600E+00
+    11     8     7  0.00000000E+00  0.00000000E+00  0.91760486E+00
+    11     8     8  0.00000000E+00  0.00000000E+00  0.97229026E+00
+    11     9     1  0.00000000E+00  0.00000000E+00  0.10952929E+01
+    11     9     2  0.00000000E+00  0.00000000E+00  0.10631137E+01
+    11     9     3  0.00000000E+00  0.00000000E+00  0.10588301E+01
+    11     9     4  0.00000000E+00  0.00000000E+00  0.10370306E+01
+    11     9     5  0.00000000E+00  0.00000000E+00  0.10057128E+01
+    11     9     6  0.00000000E+00  0.00000000E+00  0.97446026E+00
+    11     9     7  0.00000000E+00  0.00000000E+00  0.93980978E+00
+    11     9     8  0.00000000E+00  0.00000000E+00  0.98179121E+00
+    11     9     9  0.00000000E+00  0.00000000E+00  0.99481238E+00
+    11    10     1  0.30287629E-17  0.28168598E-17  0.10752267E+01
+    11    10     2  0.13192032E-16  0.12090258E-16  0.10911291E+01
+    11    10     3  0.56983947E-16  0.53866581E-16  0.10578720E+01
+    11    10     4  0.80590895E-15  0.76495474E-15  0.10535381E+01
+    11    10     5  0.75833131E-14  0.73503458E-14  0.10316947E+01
+    11    10     6  0.62812702E-13  0.62704129E-13  0.10017315E+01
+    11    10     7  0.29201040E-12  0.30236427E-12  0.96575697E+00
+    11    10     8  0.69073480E-12  0.70777886E-12  0.97591894E+00
+    11    10     9  0.11318648E-11  0.11367071E-11  0.99574004E+00
+    11    10    10  0.11057087E-11  0.11118325E-11  0.99449213E+00
+    11    11     1  0.31826098E-12  0.29965284E-12  0.10620990E+01
+    11    11     2  0.70351643E-12  0.65724093E-12  0.10704087E+01
+    11    11     3  0.15955085E-11  0.14673742E-11  0.10873222E+01
+    11    11     4  0.37081895E-11  0.35226035E-11  0.10526843E+01
+    11    11     5  0.87055885E-11  0.83050819E-11  0.10482243E+01
+    11    11     6  0.20046833E-10  0.19543880E-10  0.10257345E+01
+    11    11     7  0.43222321E-10  0.43574691E-10  0.99191343E+00
+    11    11     8  0.86255702E-10  0.89080051E-10  0.96829426E+00
+    11    11     9  0.16096249E-09  0.16144966E-09  0.99698253E+00
+    11    11    10  0.24228496E-09  0.24347227E-09  0.99512340E+00
+    11    11    11  0.17196156E-09  0.17299967E-09  0.99399930E+00
+    11    12     1  0.89560560E-13  0.85082967E-13  0.10526262E+01
+    11    12     2  0.19689064E-12  0.18626364E-12  0.10570536E+01
+    11    12     3  0.43530271E-12  0.40833610E-12  0.10660402E+01
+    11    12     4  0.95118548E-12  0.87716704E-12  0.10843835E+01
+    11    12     5  0.18513621E-11  0.17677931E-11  0.10472730E+01
+    11    12     6  0.32163373E-11  0.30835317E-11  0.10430693E+01
+    11    12     7  0.43247361E-11  0.42431336E-11  0.10192317E+01
+    11    12     8  0.13274856E-10  0.13860915E-10  0.95771860E+00
+    11    12     9  0.16383227E-10  0.16668942E-10  0.98285946E+00
+    11    12    10  0.12861185E-09  0.12907597E-09  0.99640426E+00
+    11    12    11  0.12005558E-08  0.12067706E-08  0.99485003E+00
+    11    12    12  0.16837329E-09  0.16942923E-09  0.99376764E+00
+    11    13     1  0.20475315E-27  0.19590613E-27  0.10451595E+01
+    11    13     2  0.34981426E-27  0.33394360E-27  0.10475250E+01
+    11    13     3  0.47465239E-27  0.45107145E-27  0.10522776E+01
+    11    13     4  0.64911827E-27  0.61129491E-27  0.10618742E+01
+    11    13     5  0.27919646E-24  0.25816980E-24  0.10814451E+01
+    11    13     6  0.12084798E-21  0.11594460E-21  0.10422907E+01
+    11    13     7  0.27399617E-19  0.26402874E-19  0.10377513E+01
+    11    13     8  0.36627333E-11  0.36299253E-11  0.10090382E+01
+    11    13     9  0.18538146E-09  0.19830684E-09  0.93482132E+00
+    11    13    10  0.12043124E-08  0.14665391E-08  0.82119350E+00
+    11    13    11  0.56754344E-08  0.60663219E-08  0.93556432E+00
+    11    13    12  0.16187312E-08  0.16259260E-08  0.99557497E+00
+    11    13    13  0.19977383E-11  0.20118161E-11  0.99300243E+00
+    11    14     1  0.13595350E-39  0.13086331E-39  0.10388970E+01
+    11    14     2  0.14871261E-34  0.14297196E-34  0.10401523E+01
+    11    14     3  0.22405539E-30  0.21488596E-30  0.10426712E+01
+    11    14     4  0.80025008E-27  0.76376295E-27  0.10477728E+01
+    11    14     5  0.89054461E-24  0.84172173E-24  0.10580036E+01
+    11    14     6  0.40959461E-21  0.37966119E-21  0.10788424E+01
+    11    14     7  0.11527561E-18  0.11112392E-18  0.10373609E+01
+    11    14     8  0.16337801E-09  0.16704676E-09  0.97803764E+00
+    11    14     9  0.11298352E-08  0.11911416E-08  0.94853134E+00
+    11    14    10  0.74181725E-08  0.10450216E-07  0.70985829E+00
+    11    14    11  0.24654177E-07  0.46832235E-07  0.52643605E+00
+    11    14    12  0.33530935E-07  0.38570598E-07  0.86933926E+00
+    11    14    13  0.14780426E-07  0.14647604E-07  0.10090678E+01
+    11    14    14  0.12617070E-14  0.12716426E-14  0.99218681E+00
+    11    15     1  0.44902584E-39  0.43453970E-39  0.10333368E+01
+    11    15     2  0.48580178E-34  0.46982632E-34  0.10340029E+01
+    11    15     3  0.71979698E-30  0.69522859E-30  0.10353386E+01
+    11    15     4  0.25512491E-26  0.24577969E-26  0.10380228E+01
+    11    15     5  0.28045205E-23  0.26878240E-23  0.10434167E+01
+    11    15     6  0.12773073E-20  0.12114973E-20  0.10543212E+01
+    11    15     7  0.70870806E-16  0.65785109E-16  0.10773077E+01
+    11    15     8  0.58180086E-09  0.58343906E-09  0.99719217E+00
+    11    15     9  0.69501338E-08  0.71440314E-08  0.97285881E+00
+    11    15    10  0.39129441E-07  0.61161387E-07  0.63977360E+00
+    11    15    11  0.11614973E-06  0.26448243E-06  0.43915858E+00
+    11    15    12  0.20320992E-06  0.22682884E-06  0.89587341E+00
+    11    15    13  0.44903080E-06  0.48383878E-06  0.92805872E+00
+    11    15    14  0.13609058E-06  0.14273049E-06  0.95347945E+00
+    11    15    15  0.78028235E-18  0.78001031E-18  0.10003488E+01
+    11    16     1  0.14552034E-38  0.14152845E-38  0.10282055E+01
+    11    16     2  0.15584012E-33  0.15151322E-33  0.10285579E+01
+    11    16     3  0.22829466E-29  0.22180330E-29  0.10292663E+01
+    11    16     4  0.79914684E-26  0.77535261E-26  0.10306883E+01
+    11    16     5  0.86686609E-23  0.83873013E-23  0.10335459E+01
+    11    16     6  0.38973535E-20  0.37499998E-20  0.10392943E+01
+    11    16     7  0.15464792E-13  0.14768119E-13  0.10471741E+01
+    11    16     8  0.57824257E-10  0.53991357E-10  0.10709910E+01
+    11    16     9  0.21272340E-07  0.21285067E-07  0.99940203E+00
+    11    16    10  0.17631995E-06  0.25722057E-06  0.68548151E+00
+    11    16    11  0.54121446E-06  0.11822244E-05  0.45779332E+00
+    11    16    12  0.10927739E-05  0.12093777E-05  0.90358367E+00
+    11    16    13  0.24411355E-05  0.28637998E-05  0.85241134E+00
+    11    16    14  0.19611775E-05  0.30409491E-05  0.64492282E+00
+    11    16    15  0.75444647E-06  0.85477593E-06  0.88262484E+00
+    11    16    16  0.49706127E-06  0.51506277E-06  0.96504988E+00
+    11    17     1  0.46277718E-38  0.45221219E-38  0.10233629E+01
+    11    17     2  0.49099035E-33  0.47969444E-33  0.10235481E+01
+    11    17     3  0.71157144E-29  0.69494662E-29  0.10239225E+01
+    11    17     4  0.24598829E-25  0.24006453E-25  0.10246757E+01
+    11    17     5  0.26283686E-22  0.25612953E-22  0.10261872E+01
+    11    17     6  0.32348016E-17  0.31430516E-17  0.10291914E+01
+    11    17     7  0.20722507E-11  0.20200877E-11  0.10258221E+01
+    11    17     8  0.21901007E-08  0.21626453E-08  0.10126953E+01
+    11    17     9  0.99183641E-08  0.92658232E-08  0.10704245E+01
+    11    17    10  0.65939699E-06  0.10252024E-05  0.64318717E+00
+    11    17    11  0.20187075E-05  0.46286690E-05  0.43613131E+00
+    11    17    12  0.39262501E-05  0.47833285E-05  0.82081966E+00
+    11    17    13  0.85201404E-05  0.10222201E-04  0.83349376E+00
+    11    17    14  0.87954956E-05  0.13795512E-04  0.63756211E+00
+    11    17    15  0.98487244E-05  0.14970978E-04  0.65785445E+00
+    11    17    16  0.24726877E-05  0.23157535E-05  0.10677681E+01
+    11    17    17  0.91990590E-08  0.92872135E-08  0.99050797E+00
+    11    18     1  0.14488084E-37  0.14221700E-37  0.10187308E+01
+    11    18     2  0.15243439E-32  0.14961744E-32  0.10188277E+01
+    11    18     3  0.21874460E-28  0.21466065E-28  0.10190251E+01
+    11    18     4  0.74718983E-25  0.73295256E-25  0.10194245E+01
+    11    18     5  0.78604772E-22  0.77046400E-22  0.10202264E+01
+    11    18     6  0.72666836E-14  0.71125685E-14  0.10216680E+01
+    11    18     7  0.45969023E-09  0.45785053E-09  0.10040181E+01
+    11    18     8  0.47480668E-08  0.46931184E-08  0.10117083E+01
+    11    18     9  0.21780748E-09  0.20777816E-09  0.10482693E+01
+    11    18    10  0.22797938E-05  0.68499878E-05  0.33281721E+00
+    11    18    11  0.51805850E-05  0.21863197E-04  0.23695460E+00
+    11    18    12  0.11933967E-04  0.23697448E-04  0.50359715E+00
+    11    18    13  0.22245583E-04  0.32976639E-04  0.67458613E+00
+    11    18    14  0.26233862E-04  0.42731023E-04  0.61393011E+00
+    11    18    15  0.34429368E-04  0.57928664E-04  0.59434079E+00
+    11    18    16  0.70769199E-05  0.64086436E-05  0.11042773E+01
+    11    18    17  0.12799162E-07  0.12554094E-07  0.10195210E+01
+    11    18    18  0.42113441E-23  0.39742298E-23  0.10596630E+01
+    12     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    12     7     1  0.00000000E+00  0.00000000E+00  0.10717125E+01
+    12     7     2  0.00000000E+00  0.00000000E+00  0.10501284E+01
+    12     7     3  0.00000000E+00  0.00000000E+00  0.10201475E+01
+    12     7     4  0.00000000E+00  0.00000000E+00  0.98918871E+00
+    12     7     5  0.00000000E+00  0.00000000E+00  0.96266528E+00
+    12     7     6  0.00000000E+00  0.00000000E+00  0.92744630E+00
+    12     7     7  0.00000000E+00  0.00000000E+00  0.88559810E+00
+    12     8     1  0.00000000E+00  0.00000000E+00  0.10690310E+01
+    12     8     2  0.00000000E+00  0.00000000E+00  0.10645464E+01
+    12     8     3  0.00000000E+00  0.00000000E+00  0.10429145E+01
+    12     8     4  0.00000000E+00  0.00000000E+00  0.10129489E+01
+    12     8     5  0.00000000E+00  0.00000000E+00  0.98171053E+00
+    12     8     6  0.00000000E+00  0.00000000E+00  0.95070600E+00
+    12     8     7  0.00000000E+00  0.00000000E+00  0.91760486E+00
+    12     8     8  0.00000000E+00  0.00000000E+00  0.97229026E+00
+    12     9     1  0.00000000E+00  0.00000000E+00  0.10952929E+01
+    12     9     2  0.00000000E+00  0.00000000E+00  0.10631137E+01
+    12     9     3  0.00000000E+00  0.00000000E+00  0.10588301E+01
+    12     9     4  0.00000000E+00  0.00000000E+00  0.10370306E+01
+    12     9     5  0.00000000E+00  0.00000000E+00  0.10057128E+01
+    12     9     6  0.00000000E+00  0.00000000E+00  0.97446026E+00
+    12     9     7  0.00000000E+00  0.00000000E+00  0.93980978E+00
+    12     9     8  0.00000000E+00  0.00000000E+00  0.98179121E+00
+    12     9     9  0.00000000E+00  0.00000000E+00  0.99481238E+00
+    12    10     1  0.00000000E+00  0.00000000E+00  0.10752267E+01
+    12    10     2  0.00000000E+00  0.00000000E+00  0.10911291E+01
+    12    10     3  0.00000000E+00  0.00000000E+00  0.10578720E+01
+    12    10     4  0.00000000E+00  0.00000000E+00  0.10535381E+01
+    12    10     5  0.00000000E+00  0.00000000E+00  0.10316947E+01
+    12    10     6  0.00000000E+00  0.00000000E+00  0.10017315E+01
+    12    10     7  0.00000000E+00  0.00000000E+00  0.96575697E+00
+    12    10     8  0.00000000E+00  0.00000000E+00  0.97591894E+00
+    12    10     9  0.00000000E+00  0.00000000E+00  0.99574004E+00
+    12    10    10  0.00000000E+00  0.00000000E+00  0.99449213E+00
+    12    11     1  0.15201479E-16  0.14312676E-16  0.10620990E+01
+    12    11     2  0.67997090E-16  0.63524417E-16  0.10704087E+01
+    12    11     3  0.31203056E-15  0.28697158E-15  0.10873222E+01
+    12    11     4  0.13784659E-14  0.13094770E-14  0.10526843E+01
+    12    11     5  0.18810064E-13  0.17944694E-13  0.10482243E+01
+    12    11     6  0.15892899E-12  0.15494165E-12  0.10257345E+01
+    12    11     7  0.11157110E-11  0.11248069E-11  0.99191343E+00
+    12    11     8  0.44550907E-11  0.46009678E-11  0.96829426E+00
+    12    11     9  0.98707464E-11  0.99006212E-11  0.99698253E+00
+    12    11    10  0.15520534E-10  0.15596593E-10  0.99512340E+00
+    12    11    11  0.15450444E-10  0.15543717E-10  0.99399930E+00
+    12    12     1  0.26660265E-11  0.25327381E-11  0.10526262E+01
+    12    12     2  0.58203110E-11  0.55061646E-11  0.10570536E+01
+    12    12     3  0.12817270E-10  0.12023252E-10  0.10660402E+01
+    12    12     4  0.28369663E-10  0.26162020E-10  0.10843835E+01
+    12    12     5  0.63217211E-10  0.60363638E-10  0.10472730E+01
+    12    12     6  0.14086263E-09  0.13504628E-09  0.10430693E+01
+    12    12     7  0.31144485E-09  0.30556827E-09  0.10192317E+01
+    12    12     8  0.64425743E-09  0.67270013E-09  0.95771860E+00
+    12    12     9  0.13279275E-08  0.13510858E-08  0.98285946E+00
+    12    12    10  0.23711606E-08  0.23797174E-08  0.99640426E+00
+    12    12    11  0.34530866E-08  0.34709620E-08  0.99485003E+00
+    12    12    12  0.23712209E-08  0.23860919E-08  0.99376764E+00
+    12    13     1  0.62441760E-12  0.59743761E-12  0.10451595E+01
+    12    13     2  0.13469306E-11  0.12858219E-11  0.10475250E+01
+    12    13     3  0.29163898E-11  0.27715023E-11  0.10522776E+01
+    12    13     4  0.62916446E-11  0.59250378E-11  0.10618742E+01
+    12    13     5  0.13382970E-10  0.12375080E-10  0.10814451E+01
+    12    13     6  0.25393549E-10  0.24363212E-10  0.10422907E+01
+    12    13     7  0.43707073E-10  0.42117097E-10  0.10377513E+01
+    12    13     8  0.63695290E-10  0.63124755E-10  0.10090382E+01
+    12    13     9  0.39675305E-09  0.42441592E-09  0.93482132E+00
+    12    13    10  0.14748522E-08  0.17959863E-08  0.82119350E+00
+    12    13    11  0.24060744E-08  0.25717894E-08  0.93556432E+00
+    12    13    12  0.16016334E-07  0.16087522E-07  0.99557497E+00
+    12    13    13  0.22704662E-08  0.22864659E-08  0.99300243E+00
+    12    14     1  0.17681281E-28  0.17019282E-28  0.10388970E+01
+    12    14     2  0.32858726E-28  0.31590304E-28  0.10401523E+01
+    12    14     3  0.53333275E-28  0.51150618E-28  0.10426712E+01
+    12    14     4  0.65462897E-28  0.62478138E-28  0.10477728E+01
+    12    14     5  0.19655128E-27  0.18577562E-27  0.10580036E+01
+    12    14     6  0.16918138E-24  0.15681750E-24  0.10788424E+01
+    12    14     7  0.47552042E-19  0.45839437E-19  0.10373609E+01
+    12    14     8  0.34802211E-09  0.35583713E-09  0.97803764E+00
+    12    14     9  0.17182010E-08  0.18114330E-08  0.94853134E+00
+    12    14    10  0.10129097E-07  0.14269182E-07  0.70985829E+00
+    12    14    11  0.30154915E-07  0.57281250E-07  0.52643605E+00
+    12    14    12  0.59937474E-07  0.68946011E-07  0.86933926E+00
+    12    14    13  0.34508405E-07  0.34198300E-07  0.10090678E+01
+    12    14    14  0.44904560E-10  0.45258170E-10  0.99218681E+00
+    12    15     1  0.10371899E-45  0.10037288E-45  0.10333368E+01
+    12    15     2  0.10891548E-39  0.10533382E-39  0.10340029E+01
+    12    15     3  0.10251262E-34  0.99013618E-35  0.10353386E+01
+    12    15     4  0.14033797E-30  0.13519739E-30  0.10380228E+01
+    12    15     5  0.47473703E-27  0.45498317E-27  0.10434167E+01
+    12    15     6  0.52758913E-24  0.50040643E-24  0.10543212E+01
+    12    15     7  0.14118588E-15  0.13105437E-15  0.10773077E+01
+    12    15     8  0.10034426E-08  0.10062680E-08  0.99719217E+00
+    12    15     9  0.83365945E-08  0.85691721E-08  0.97285881E+00
+    12    15    10  0.56145818E-07  0.87758884E-07  0.63977360E+00
+    12    15    11  0.16302401E-06  0.37121900E-06  0.43915858E+00
+    12    15    12  0.22704118E-06  0.25342999E-06  0.89587341E+00
+    12    15    13  0.52297813E-06  0.56351836E-06  0.92805872E+00
+    12    15    14  0.33123653E-06  0.34739766E-06  0.95347945E+00
+    12    15    15  0.38986858E-13  0.38973266E-13  0.10003488E+01
+    12    16     1  0.33608738E-45  0.32686789E-45  0.10282055E+01
+    12    16     2  0.34932867E-39  0.33962956E-39  0.10285579E+01
+    12    16     3  0.32507374E-34  0.31583055E-34  0.10292663E+01
+    12    16     4  0.43739799E-30  0.42437466E-30  0.10306883E+01
+    12    16     5  0.14670926E-26  0.14194750E-26  0.10335459E+01
+    12    16     6  0.16096033E-23  0.15487464E-23  0.10392943E+01
+    12    16     7  0.30928120E-13  0.29534841E-13  0.10471741E+01
+    12    16     8  0.11131564E-09  0.10393705E-09  0.10709910E+01
+    12    16     9  0.19286372E-07  0.19297912E-07  0.99940203E+00
+    12    16    10  0.24876905E-06  0.36291140E-06  0.68548151E+00
+    12    16    11  0.75057718E-06  0.16395547E-05  0.45779332E+00
+    12    16    12  0.11960741E-05  0.13237004E-05  0.90358367E+00
+    12    16    13  0.32117518E-05  0.37678427E-05  0.85241134E+00
+    12    16    14  0.38088202E-05  0.59058543E-05  0.64492282E+00
+    12    16    15  0.17838370E-05  0.20210591E-05  0.88262484E+00
+    12    16    16  0.45451259E-06  0.47097316E-06  0.96504988E+00
+    12    17     1  0.10686789E-44  0.10442814E-44  0.10233629E+01
+    12    17     2  0.11004153E-38  0.10750988E-38  0.10235481E+01
+    12    17     3  0.10130348E-33  0.98936675E-34  0.10239225E+01
+    12    17     4  0.13460537E-29  0.13136387E-29  0.10246757E+01
+    12    17     5  0.44469827E-26  0.43335002E-26  0.10261872E+01
+    12    17     6  0.64464285E-17  0.62635858E-17  0.10291914E+01
+    12    17     7  0.41444973E-11  0.40401715E-11  0.10258221E+01
+    12    17     8  0.44437065E-08  0.43879996E-08  0.10126953E+01
+    12    17     9  0.82263160E-08  0.76850970E-08  0.10704245E+01
+    12    17    10  0.10161159E-05  0.15798136E-05  0.64318717E+00
+    12    17    11  0.30540042E-05  0.70024878E-05  0.43613131E+00
+    12    17    12  0.51123515E-05  0.62283492E-05  0.82081966E+00
+    12    17    13  0.12220668E-04  0.14661979E-04  0.83349376E+00
+    12    17    14  0.16186298E-04  0.25387798E-04  0.63756211E+00
+    12    17    15  0.16352352E-04  0.24857097E-04  0.65785445E+00
+    12    17    16  0.43322382E-05  0.40572838E-05  0.10677681E+01
+    12    17    17  0.19766578E-07  0.19956001E-07  0.99050797E+00
+    12    18     1  0.33453296E-44  0.32838208E-44  0.10187308E+01
+    12    18     2  0.34158717E-38  0.33527474E-38  0.10188277E+01
+    12    18     3  0.31136318E-33  0.30555005E-33  0.10190251E+01
+    12    18     4  0.40876677E-29  0.40097796E-29  0.10194245E+01
+    12    18     5  0.13294888E-25  0.13031312E-25  0.10202264E+01
+    12    18     6  0.14533299E-13  0.14225071E-13  0.10216680E+01
+    12    18     7  0.98731237E-09  0.98336110E-09  0.10040181E+01
+    12    18     8  0.78697980E-08  0.77787225E-08  0.10117083E+01
+    12    18     9  0.83387837E-10  0.79548103E-10  0.10482693E+01
+    12    18    10  0.42179892E-05  0.12673591E-04  0.33281721E+00
+    12    18    11  0.94996088E-05  0.40090418E-04  0.23695460E+00
+    12    18    12  0.21009391E-04  0.41718645E-04  0.50359715E+00
+    12    18    13  0.36573417E-04  0.54216082E-04  0.67458613E+00
+    12    18    14  0.50577411E-04  0.82383010E-04  0.61393011E+00
+    12    18    15  0.63353210E-04  0.10659408E-03  0.59434079E+00
+    12    18    16  0.53485568E-05  0.48434904E-05  0.11042773E+01
+    12    18    17  0.18638672E-08  0.18281793E-08  0.10195210E+01
+    12    18    18  0.45876283E-20  0.43293277E-20  0.10596630E+01
+    13     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    13     7     1  0.00000000E+00  0.00000000E+00  0.10717125E+01
+    13     7     2  0.00000000E+00  0.00000000E+00  0.10501284E+01
+    13     7     3  0.00000000E+00  0.00000000E+00  0.10201475E+01
+    13     7     4  0.00000000E+00  0.00000000E+00  0.98918871E+00
+    13     7     5  0.00000000E+00  0.00000000E+00  0.96266528E+00
+    13     7     6  0.00000000E+00  0.00000000E+00  0.92744630E+00
+    13     7     7  0.00000000E+00  0.00000000E+00  0.88559810E+00
+    13     8     1  0.00000000E+00  0.00000000E+00  0.10690310E+01
+    13     8     2  0.00000000E+00  0.00000000E+00  0.10645464E+01
+    13     8     3  0.00000000E+00  0.00000000E+00  0.10429145E+01
+    13     8     4  0.00000000E+00  0.00000000E+00  0.10129489E+01
+    13     8     5  0.00000000E+00  0.00000000E+00  0.98171053E+00
+    13     8     6  0.00000000E+00  0.00000000E+00  0.95070600E+00
+    13     8     7  0.00000000E+00  0.00000000E+00  0.91760486E+00
+    13     8     8  0.00000000E+00  0.00000000E+00  0.97229026E+00
+    13     9     1  0.00000000E+00  0.00000000E+00  0.10952929E+01
+    13     9     2  0.00000000E+00  0.00000000E+00  0.10631137E+01
+    13     9     3  0.00000000E+00  0.00000000E+00  0.10588301E+01
+    13     9     4  0.00000000E+00  0.00000000E+00  0.10370306E+01
+    13     9     5  0.00000000E+00  0.00000000E+00  0.10057128E+01
+    13     9     6  0.00000000E+00  0.00000000E+00  0.97446026E+00
+    13     9     7  0.00000000E+00  0.00000000E+00  0.93980978E+00
+    13     9     8  0.00000000E+00  0.00000000E+00  0.98179121E+00
+    13     9     9  0.00000000E+00  0.00000000E+00  0.99481238E+00
+    13    10     1  0.00000000E+00  0.00000000E+00  0.10752267E+01
+    13    10     2  0.00000000E+00  0.00000000E+00  0.10911291E+01
+    13    10     3  0.00000000E+00  0.00000000E+00  0.10578720E+01
+    13    10     4  0.00000000E+00  0.00000000E+00  0.10535381E+01
+    13    10     5  0.00000000E+00  0.00000000E+00  0.10316947E+01
+    13    10     6  0.00000000E+00  0.00000000E+00  0.10017315E+01
+    13    10     7  0.00000000E+00  0.00000000E+00  0.96575697E+00
+    13    10     8  0.00000000E+00  0.00000000E+00  0.97591894E+00
+    13    10     9  0.00000000E+00  0.00000000E+00  0.99574004E+00
+    13    10    10  0.00000000E+00  0.00000000E+00  0.99449213E+00
+    13    11     1  0.00000000E+00  0.00000000E+00  0.10620990E+01
+    13    11     2  0.00000000E+00  0.00000000E+00  0.10704087E+01
+    13    11     3  0.00000000E+00  0.00000000E+00  0.10873222E+01
+    13    11     4  0.00000000E+00  0.00000000E+00  0.10526843E+01
+    13    11     5  0.00000000E+00  0.00000000E+00  0.10482243E+01
+    13    11     6  0.00000000E+00  0.00000000E+00  0.10257345E+01
+    13    11     7  0.00000000E+00  0.00000000E+00  0.99191343E+00
+    13    11     8  0.00000000E+00  0.00000000E+00  0.96829426E+00
+    13    11     9  0.00000000E+00  0.00000000E+00  0.99698253E+00
+    13    11    10  0.00000000E+00  0.00000000E+00  0.99512340E+00
+    13    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+    13    12     1  0.61366469E-16  0.58298443E-16  0.10526262E+01
+    13    12     2  0.26736633E-15  0.25293545E-15  0.10570536E+01
+    13    12     3  0.11798064E-14  0.11067184E-14  0.10660402E+01
+    13    12     4  0.52838664E-14  0.48726915E-14  0.10843835E+01
+    13    12     5  0.22604119E-13  0.21583788E-13  0.10472730E+01
+    13    12     6  0.30104446E-12  0.28861405E-12  0.10430693E+01
+    13    12     7  0.25399284E-11  0.24920031E-11  0.10192317E+01
+    13    12     8  0.16881313E-10  0.17626590E-10  0.95771860E+00
+    13    12     9  0.67322916E-10  0.68496991E-10  0.98285946E+00
+    13    12    10  0.13677640E-09  0.13726999E-09  0.99640426E+00
+    13    12    11  0.20622718E-09  0.20729474E-09  0.99485003E+00
+    13    12    12  0.20752323E-09  0.20882470E-09  0.99376764E+00
+    13    13     1  0.18518618E-10  0.17718461E-10  0.10451595E+01
+    13    13     2  0.39889714E-10  0.38079964E-10  0.10475250E+01
+    13    13     3  0.86704635E-10  0.82397111E-10  0.10522776E+01
+    13    13     4  0.18988739E-09  0.17882288E-09  0.10618742E+01
+    13    13     5  0.41973215E-09  0.38812156E-09  0.10814451E+01
+    13    13     6  0.94047566E-09  0.90231609E-09  0.10422907E+01
+    13    13     7  0.21304596E-08  0.20529577E-08  0.10377513E+01
+    13    13     8  0.47826770E-08  0.47398374E-08  0.10090382E+01
+    13    13     9  0.99207062E-08  0.10612409E-07  0.93482132E+00
+    13    13    10  0.18300282E-07  0.22284982E-07  0.82119350E+00
+    13    13    11  0.32972696E-07  0.35243644E-07  0.93556432E+00
+    13    13    12  0.47611449E-07  0.47823067E-07  0.99557497E+00
+    13    13    13  0.31001929E-07  0.31220396E-07  0.99300243E+00
+    13    14     1  0.39747212E-11  0.38259051E-11  0.10388970E+01
+    13    14     2  0.85014239E-11  0.81732494E-11  0.10401523E+01
+    13    14     3  0.18300421E-10  0.17551479E-10  0.10426712E+01
+    13    14     4  0.39453764E-10  0.37654883E-10  0.10477728E+01
+    13    14     5  0.85113563E-10  0.80447329E-10  0.10580036E+01
+    13    14     6  0.18223665E-09  0.16891869E-09  0.10788424E+01
+    13    14     7  0.35002803E-09  0.33742164E-09  0.10373609E+01
+    13    14     8  0.14754356E-08  0.15085673E-08  0.97803764E+00
+    13    14     9  0.39889701E-08  0.42054173E-08  0.94853134E+00
+    13    14    10  0.18104490E-07  0.25504372E-07  0.70985829E+00
+    13    14    11  0.52155140E-07  0.99072129E-07  0.52643605E+00
+    13    14    12  0.38489236E-07  0.44274126E-07  0.86933926E+00
+    13    14    13  0.17229964E-06  0.17075129E-06  0.10090678E+01
+    13    14    14  0.28709841E-07  0.28935922E-07  0.99218681E+00
+    13    15     1  0.79945204E-30  0.77366071E-30  0.10333368E+01
+    13    15     2  0.15559839E-29  0.15048158E-29  0.10340029E+01
+    13    15     3  0.28008666E-29  0.27052663E-29  0.10353386E+01
+    13    15     4  0.42717536E-29  0.41152793E-29  0.10380228E+01
+    13    15     5  0.46910542E-29  0.44958588E-29  0.10434167E+01
+    13    15     6  0.69615088E-28  0.66028347E-28  0.10543212E+01
+    13    15     7  0.28237159E-15  0.26210857E-15  0.10773077E+01
+    13    15     8  0.16004905E-08  0.16049971E-08  0.99719217E+00
+    13    15     9  0.86687993E-08  0.89106448E-08  0.97285881E+00
+    13    15    10  0.89601961E-07  0.14005261E-06  0.63977360E+00
+    13    15    11  0.27580906E-06  0.62803979E-06  0.43915858E+00
+    13    15    12  0.12126605E-06  0.13536070E-06  0.89587341E+00
+    13    15    13  0.68885546E-06  0.74225418E-06  0.92805872E+00
+    13    15    14  0.66318838E-06  0.69554555E-06  0.95347945E+00
+    13    15    15  0.22975358E-07  0.22967348E-07  0.10003488E+01
+    13    16     1  0.12284103E-52  0.11947128E-52  0.10282055E+01
+    13    16     2  0.15495582E-45  0.15065347E-45  0.10285579E+01
+    13    16     3  0.10334550E-39  0.10040696E-39  0.10292663E+01
+    13    16     4  0.68900644E-35  0.66849158E-35  0.10306883E+01
+    13    16     5  0.72539857E-31  0.70185424E-31  0.10335459E+01
+    13    16     6  0.20437664E-27  0.19664943E-27  0.10392943E+01
+    13    16     7  0.61856239E-13  0.59069682E-13  0.10471741E+01
+    13    16     8  0.21448207E-09  0.20026505E-09  0.10709910E+01
+    13    16     9  0.15729564E-07  0.15738975E-07  0.99940203E+00
+    13    16    10  0.37463381E-06  0.54652651E-06  0.68548151E+00
+    13    16    11  0.11706120E-05  0.25570753E-05  0.45779332E+00
+    13    16    12  0.65043720E-06  0.71984169E-06  0.90358367E+00
+    13    16    13  0.37994260E-05  0.44572683E-05  0.85241134E+00
+    13    16    14  0.60708238E-05  0.94132562E-05  0.64492282E+00
+    13    16    15  0.28520097E-05  0.32312820E-05  0.88262484E+00
+    13    16    16  0.29616557E-06  0.30689147E-06  0.96504988E+00
+    13    17     1  0.39056569E-52  0.38164925E-52  0.10233629E+01
+    13    17     2  0.48806241E-45  0.47683386E-45  0.10235481E+01
+    13    17     3  0.32200381E-39  0.31448066E-39  0.10239225E+01
+    13    17     4  0.21199263E-34  0.20688754E-34  0.10246757E+01
+    13    17     5  0.21982623E-30  0.21421649E-30  0.10261872E+01
+    13    17     6  0.12892859E-16  0.12527173E-16  0.10291914E+01
+    13    17     7  0.82889945E-11  0.80803428E-11  0.10258221E+01
+    13    17     8  0.89623151E-08  0.88499624E-08  0.10126953E+01
+    13    17     9  0.88195244E-08  0.82392775E-08  0.10704245E+01
+    13    17    10  0.16682930E-05  0.25937909E-05  0.64318717E+00
+    13    17    11  0.49310626E-05  0.11306371E-04  0.43613131E+00
+    13    17    12  0.47128453E-05  0.57416331E-05  0.82081966E+00
+    13    17    13  0.16422118E-04  0.19702748E-04  0.83349376E+00
+    13    17    14  0.26964267E-04  0.42292769E-04  0.63756211E+00
+    13    17    15  0.18786877E-04  0.28557801E-04  0.65785445E+00
+    13    17    16  0.41963897E-05  0.39300571E-05  0.10677681E+01
+    13    17    17  0.33965304E-07  0.34290793E-07  0.99050797E+00
+    13    18     1  0.12224926E-51  0.12000153E-51  0.10187308E+01
+    13    18     2  0.15148516E-44  0.14868575E-44  0.10188277E+01
+    13    18     3  0.98954230E-39  0.97106761E-39  0.10190251E+01
+    13    18     4  0.64364891E-34  0.63138455E-34  0.10194245E+01
+    13    18     5  0.65380225E-30  0.64084034E-30  0.10202264E+01
+    13    18     6  0.29066598E-13  0.28450141E-13  0.10216680E+01
+    13    18     7  0.20754363E-08  0.20671303E-08  0.10040181E+01
+    13    18     8  0.13271463E-07  0.13117875E-07  0.10117083E+01
+    13    18     9  0.35706815E-10  0.34062634E-10  0.10482693E+01
+    13    18    10  0.76929633E-05  0.23114680E-04  0.33281721E+00
+    13    18    11  0.17399771E-04  0.73430824E-04  0.23695460E+00
+    13    18    12  0.32534181E-04  0.64603585E-04  0.50359715E+00
+    13    18    13  0.60108433E-04  0.89104163E-04  0.67458613E+00
+    13    18    14  0.91228979E-04  0.14859831E-03  0.61393011E+00
+    13    18    15  0.11062190E-03  0.18612538E-03  0.59434079E+00
+    13    18    16  0.50929435E-05  0.46120148E-05  0.11042773E+01
+    13    18    17  0.45701879E-13  0.44826816E-13  0.10195210E+01
+    13    18    18  0.12551412E-16  0.11844721E-16  0.10596630E+01
+    14     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    14     7     1  0.00000000E+00  0.00000000E+00  0.10717125E+01
+    14     7     2  0.00000000E+00  0.00000000E+00  0.10501284E+01
+    14     7     3  0.00000000E+00  0.00000000E+00  0.10201475E+01
+    14     7     4  0.00000000E+00  0.00000000E+00  0.98918871E+00
+    14     7     5  0.00000000E+00  0.00000000E+00  0.96266528E+00
+    14     7     6  0.00000000E+00  0.00000000E+00  0.92744630E+00
+    14     7     7  0.00000000E+00  0.00000000E+00  0.88559810E+00
+    14     8     1  0.00000000E+00  0.00000000E+00  0.10690310E+01
+    14     8     2  0.00000000E+00  0.00000000E+00  0.10645464E+01
+    14     8     3  0.00000000E+00  0.00000000E+00  0.10429145E+01
+    14     8     4  0.00000000E+00  0.00000000E+00  0.10129489E+01
+    14     8     5  0.00000000E+00  0.00000000E+00  0.98171053E+00
+    14     8     6  0.00000000E+00  0.00000000E+00  0.95070600E+00
+    14     8     7  0.00000000E+00  0.00000000E+00  0.91760486E+00
+    14     8     8  0.00000000E+00  0.00000000E+00  0.97229026E+00
+    14     9     1  0.00000000E+00  0.00000000E+00  0.10952929E+01
+    14     9     2  0.00000000E+00  0.00000000E+00  0.10631137E+01
+    14     9     3  0.00000000E+00  0.00000000E+00  0.10588301E+01
+    14     9     4  0.00000000E+00  0.00000000E+00  0.10370306E+01
+    14     9     5  0.00000000E+00  0.00000000E+00  0.10057128E+01
+    14     9     6  0.00000000E+00  0.00000000E+00  0.97446026E+00
+    14     9     7  0.00000000E+00  0.00000000E+00  0.93980978E+00
+    14     9     8  0.00000000E+00  0.00000000E+00  0.98179121E+00
+    14     9     9  0.00000000E+00  0.00000000E+00  0.99481238E+00
+    14    10     1  0.00000000E+00  0.00000000E+00  0.10752267E+01
+    14    10     2  0.00000000E+00  0.00000000E+00  0.10911291E+01
+    14    10     3  0.00000000E+00  0.00000000E+00  0.10578720E+01
+    14    10     4  0.00000000E+00  0.00000000E+00  0.10535381E+01
+    14    10     5  0.00000000E+00  0.00000000E+00  0.10316947E+01
+    14    10     6  0.00000000E+00  0.00000000E+00  0.10017315E+01
+    14    10     7  0.00000000E+00  0.00000000E+00  0.96575697E+00
+    14    10     8  0.00000000E+00  0.00000000E+00  0.97591894E+00
+    14    10     9  0.00000000E+00  0.00000000E+00  0.99574004E+00
+    14    10    10  0.00000000E+00  0.00000000E+00  0.99449213E+00
+    14    11     1  0.00000000E+00  0.00000000E+00  0.10620990E+01
+    14    11     2  0.00000000E+00  0.00000000E+00  0.10704087E+01
+    14    11     3  0.00000000E+00  0.00000000E+00  0.10873222E+01
+    14    11     4  0.00000000E+00  0.00000000E+00  0.10526843E+01
+    14    11     5  0.00000000E+00  0.00000000E+00  0.10482243E+01
+    14    11     6  0.00000000E+00  0.00000000E+00  0.10257345E+01
+    14    11     7  0.00000000E+00  0.00000000E+00  0.99191343E+00
+    14    11     8  0.00000000E+00  0.00000000E+00  0.96829426E+00
+    14    11     9  0.00000000E+00  0.00000000E+00  0.99698253E+00
+    14    11    10  0.00000000E+00  0.00000000E+00  0.99512340E+00
+    14    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+    14    12     1  0.00000000E+00  0.00000000E+00  0.10526262E+01
+    14    12     2  0.00000000E+00  0.00000000E+00  0.10570536E+01
+    14    12     3  0.00000000E+00  0.00000000E+00  0.10660402E+01
+    14    12     4  0.00000000E+00  0.00000000E+00  0.10843835E+01
+    14    12     5  0.00000000E+00  0.00000000E+00  0.10472730E+01
+    14    12     6  0.00000000E+00  0.00000000E+00  0.10430693E+01
+    14    12     7  0.00000000E+00  0.00000000E+00  0.10192317E+01
+    14    12     8  0.00000000E+00  0.00000000E+00  0.95771860E+00
+    14    12     9  0.00000000E+00  0.00000000E+00  0.98285946E+00
+    14    12    10  0.00000000E+00  0.00000000E+00  0.99640426E+00
+    14    12    11  0.00000000E+00  0.00000000E+00  0.99485003E+00
+    14    12    12  0.00000000E+00  0.00000000E+00  0.99376764E+00
+    14    13     1  0.22253109E-15  0.21291591E-15  0.10451595E+01
+    14    13     2  0.95728965E-15  0.91385854E-15  0.10475250E+01
+    14    13     3  0.41647290E-14  0.39578234E-14  0.10522776E+01
+    14    13     4  0.18342986E-13  0.17274161E-13  0.10618742E+01
+    14    13     5  0.82350414E-13  0.76148494E-13  0.10814451E+01
+    14    13     6  0.35445180E-12  0.34007000E-12  0.10422907E+01
+    14    13     7  0.48287578E-11  0.46530973E-11  0.10377513E+01
+    14    13     8  0.37569419E-10  0.37232900E-10  0.10090382E+01
+    14    13     9  0.22511486E-09  0.24081058E-09  0.93482132E+00
+    14    13    10  0.94339615E-09  0.11488110E-08  0.82119350E+00
+    14    13    11  0.27248360E-08  0.29125052E-08  0.93556432E+00
+    14    13    12  0.27374846E-08  0.27496519E-08  0.99557497E+00
+    14    13    13  0.26490760E-08  0.26677437E-08  0.99300243E+00
+    14    14     1  0.12575785E-09  0.12104939E-09  0.10388970E+01
+    14    14     2  0.26798380E-09  0.25763901E-09  0.10401523E+01
+    14    14     3  0.57621569E-09  0.55263415E-09  0.10426712E+01
+    14    14     4  0.12495057E-08  0.11925349E-08  0.10477728E+01
+    14    14     5  0.27427271E-08  0.25923608E-08  0.10580036E+01
+    14    14     6  0.61313479E-08  0.56832653E-08  0.10788424E+01
+    14    14     7  0.14149006E-07  0.13639424E-07  0.10373609E+01
+    14    14     8  0.32085982E-07  0.32806490E-07  0.97803764E+00
+    14    14     9  0.72405929E-07  0.76334778E-07  0.94853134E+00
+    14    14    10  0.13366678E-06  0.18830065E-06  0.70985829E+00
+    14    14    11  0.23088794E-06  0.43858688E-06  0.52643605E+00
+    14    14    12  0.45767771E-06  0.52646616E-06  0.86933926E+00
+    14    14    13  0.62565044E-06  0.62002812E-06  0.10090678E+01
+    14    14    14  0.37845124E-06  0.38143143E-06  0.99218681E+00
+    14    15     1  0.24893549E-10  0.24090452E-10  0.10333368E+01
+    14    15     2  0.52747882E-10  0.51013282E-10  0.10340029E+01
+    14    15     3  0.11259956E-09  0.10875627E-09  0.10353386E+01
+    14    15     4  0.24174100E-09  0.23288603E-09  0.10380228E+01
+    14    15     5  0.52285777E-09  0.50110159E-09  0.10434167E+01
+    14    15     6  0.11411827E-08  0.10823861E-08  0.10543212E+01
+    14    15     7  0.25031685E-08  0.23235409E-08  0.10773077E+01
+    14    15     8  0.76435633E-08  0.76650856E-08  0.99719217E+00
+    14    15     9  0.21715286E-07  0.22321108E-07  0.97285881E+00
+    14    15    10  0.15930599E-06  0.24900369E-06  0.63977360E+00
+    14    15    11  0.48033336E-06  0.10937584E-05  0.43915858E+00
+    14    15    12  0.18189735E-06  0.20303912E-06  0.89587341E+00
+    14    15    13  0.27343138E-06  0.29462724E-06  0.92805872E+00
+    14    15    14  0.18222530E-05  0.19111613E-05  0.95347945E+00
+    14    15    15  0.31651973E-06  0.31640938E-06  0.10003488E+01
+    14    16     1  0.18419279E-31  0.17914005E-31  0.10282055E+01
+    14    16     2  0.36732513E-31  0.35712634E-31  0.10285579E+01
+    14    16     3  0.67287267E-31  0.65374011E-31  0.10292663E+01
+    14    16     4  0.11649738E-30  0.11302872E-30  0.10306883E+01
+    14    16     5  0.16577030E-30  0.16038988E-30  0.10335459E+01
+    14    16     6  0.16731208E-30  0.16098623E-30  0.10392943E+01
+    14    16     7  0.12371248E-12  0.11813937E-12  0.10471741E+01
+    14    16     8  0.41791512E-09  0.39021348E-09  0.10709910E+01
+    14    16     9  0.13469781E-07  0.13477841E-07  0.99940203E+00
+    14    16    10  0.57725986E-06  0.84212317E-06  0.68548151E+00
+    14    16    11  0.18907949E-05  0.41302369E-05  0.45779332E+00
+    14    16    12  0.39297184E-06  0.43490365E-06  0.90358367E+00
+    14    16    13  0.22338453E-05  0.26206189E-05  0.85241134E+00
+    14    16    14  0.10636283E-04  0.16492334E-04  0.64492282E+00
+    14    16    15  0.41072368E-05  0.46534344E-05  0.88262484E+00
+    14    16    16  0.23129514E-06  0.23967170E-06  0.96504988E+00
+    14    17     1  0.22503872E-60  0.21990119E-60  0.10233629E+01
+    14    17     2  0.42758387E-52  0.41774671E-52  0.10235481E+01
+    14    17     3  0.23940930E-45  0.23381585E-45  0.10239225E+01
+    14    17     4  0.84222919E-40  0.82194707E-40  0.10246757E+01
+    14    17     5  0.33697794E-35  0.32837861E-35  0.10261872E+01
+    14    17     6  0.25785746E-16  0.25054374E-16  0.10291914E+01
+    14    17     7  0.16577989E-10  0.16160685E-10  0.10258221E+01
+    14    17     8  0.18042149E-07  0.17815971E-07  0.10126953E+01
+    14    17     9  0.12165170E-07  0.11364809E-07  0.10704245E+01
+    14    17    10  0.26791267E-05  0.41653921E-05  0.64318717E+00
+    14    17    11  0.80342015E-05  0.18421519E-04  0.43613131E+00
+    14    17    12  0.49226591E-05  0.59972481E-05  0.82081966E+00
+    14    17    13  0.14284579E-04  0.17138196E-04  0.83349376E+00
+    14    17    14  0.44890939E-04  0.70410299E-04  0.63756211E+00
+    14    17    15  0.32807689E-04  0.49870741E-04  0.65785445E+00
+    14    17    16  0.14146915E-05  0.13249052E-05  0.10677681E+01
+    14    17    17  0.48125192E-07  0.48586375E-07  0.99050797E+00
+    14    18     1  0.70432887E-60  0.69137876E-60  0.10187308E+01
+    14    18     2  0.13270080E-51  0.13024852E-51  0.10188277E+01
+    14    18     3  0.73563105E-45  0.72189686E-45  0.10190251E+01
+    14    18     4  0.25567196E-39  0.25080028E-39  0.10194245E+01
+    14    18     5  0.10069362E-34  0.98697327E-35  0.10202264E+01
+    14    18     6  0.58133196E-13  0.56900281E-13  0.10216680E+01
+    14    18     7  0.43511970E-08  0.43337834E-08  0.10040181E+01
+    14    18     8  0.22900482E-07  0.22635459E-07  0.10117083E+01
+    14    18     9  0.16935093E-10  0.16155288E-10  0.10482693E+01
+    14    18    10  0.13718022E-04  0.41217887E-04  0.33281721E+00
+    14    18    11  0.31071100E-04  0.13112681E-03  0.23695460E+00
+    14    18    12  0.52030104E-04  0.10331692E-03  0.50359715E+00
+    14    18    13  0.80113008E-04  0.11875875E-03  0.67458613E+00
+    14    18    14  0.16425037E-03  0.26753919E-03  0.61393011E+00
+    14    18    15  0.19334660E-03  0.32531269E-03  0.59434079E+00
+    14    18    16  0.66442747E-05  0.60168532E-05  0.11042773E+01
+    14    18    17  0.15705469E-09  0.15404754E-09  0.10195210E+01
+    14    18    18  0.68544951E-13  0.64685615E-13  0.10596630E+01
+    15     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    15     7     1  0.00000000E+00  0.00000000E+00  0.10717125E+01
+    15     7     2  0.00000000E+00  0.00000000E+00  0.10501284E+01
+    15     7     3  0.00000000E+00  0.00000000E+00  0.10201475E+01
+    15     7     4  0.00000000E+00  0.00000000E+00  0.98918871E+00
+    15     7     5  0.00000000E+00  0.00000000E+00  0.96266528E+00
+    15     7     6  0.00000000E+00  0.00000000E+00  0.92744630E+00
+    15     7     7  0.00000000E+00  0.00000000E+00  0.88559810E+00
+    15     8     1  0.00000000E+00  0.00000000E+00  0.10690310E+01
+    15     8     2  0.00000000E+00  0.00000000E+00  0.10645464E+01
+    15     8     3  0.00000000E+00  0.00000000E+00  0.10429145E+01
+    15     8     4  0.00000000E+00  0.00000000E+00  0.10129489E+01
+    15     8     5  0.00000000E+00  0.00000000E+00  0.98171053E+00
+    15     8     6  0.00000000E+00  0.00000000E+00  0.95070600E+00
+    15     8     7  0.00000000E+00  0.00000000E+00  0.91760486E+00
+    15     8     8  0.00000000E+00  0.00000000E+00  0.97229026E+00
+    15     9     1  0.00000000E+00  0.00000000E+00  0.10952929E+01
+    15     9     2  0.00000000E+00  0.00000000E+00  0.10631137E+01
+    15     9     3  0.00000000E+00  0.00000000E+00  0.10588301E+01
+    15     9     4  0.00000000E+00  0.00000000E+00  0.10370306E+01
+    15     9     5  0.00000000E+00  0.00000000E+00  0.10057128E+01
+    15     9     6  0.00000000E+00  0.00000000E+00  0.97446026E+00
+    15     9     7  0.00000000E+00  0.00000000E+00  0.93980978E+00
+    15     9     8  0.00000000E+00  0.00000000E+00  0.98179121E+00
+    15     9     9  0.00000000E+00  0.00000000E+00  0.99481238E+00
+    15    10     1  0.00000000E+00  0.00000000E+00  0.10752267E+01
+    15    10     2  0.00000000E+00  0.00000000E+00  0.10911291E+01
+    15    10     3  0.00000000E+00  0.00000000E+00  0.10578720E+01
+    15    10     4  0.00000000E+00  0.00000000E+00  0.10535381E+01
+    15    10     5  0.00000000E+00  0.00000000E+00  0.10316947E+01
+    15    10     6  0.00000000E+00  0.00000000E+00  0.10017315E+01
+    15    10     7  0.00000000E+00  0.00000000E+00  0.96575697E+00
+    15    10     8  0.00000000E+00  0.00000000E+00  0.97591894E+00
+    15    10     9  0.00000000E+00  0.00000000E+00  0.99574004E+00
+    15    10    10  0.00000000E+00  0.00000000E+00  0.99449213E+00
+    15    11     1  0.00000000E+00  0.00000000E+00  0.10620990E+01
+    15    11     2  0.00000000E+00  0.00000000E+00  0.10704087E+01
+    15    11     3  0.00000000E+00  0.00000000E+00  0.10873222E+01
+    15    11     4  0.00000000E+00  0.00000000E+00  0.10526843E+01
+    15    11     5  0.00000000E+00  0.00000000E+00  0.10482243E+01
+    15    11     6  0.00000000E+00  0.00000000E+00  0.10257345E+01
+    15    11     7  0.00000000E+00  0.00000000E+00  0.99191343E+00
+    15    11     8  0.00000000E+00  0.00000000E+00  0.96829426E+00
+    15    11     9  0.00000000E+00  0.00000000E+00  0.99698253E+00
+    15    11    10  0.00000000E+00  0.00000000E+00  0.99512340E+00
+    15    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+    15    12     1  0.00000000E+00  0.00000000E+00  0.10526262E+01
+    15    12     2  0.00000000E+00  0.00000000E+00  0.10570536E+01
+    15    12     3  0.00000000E+00  0.00000000E+00  0.10660402E+01
+    15    12     4  0.00000000E+00  0.00000000E+00  0.10843835E+01
+    15    12     5  0.00000000E+00  0.00000000E+00  0.10472730E+01
+    15    12     6  0.00000000E+00  0.00000000E+00  0.10430693E+01
+    15    12     7  0.00000000E+00  0.00000000E+00  0.10192317E+01
+    15    12     8  0.00000000E+00  0.00000000E+00  0.95771860E+00
+    15    12     9  0.00000000E+00  0.00000000E+00  0.98285946E+00
+    15    12    10  0.00000000E+00  0.00000000E+00  0.99640426E+00
+    15    12    11  0.00000000E+00  0.00000000E+00  0.99485003E+00
+    15    12    12  0.00000000E+00  0.00000000E+00  0.99376764E+00
+    15    13     1  0.00000000E+00  0.00000000E+00  0.10451595E+01
+    15    13     2  0.00000000E+00  0.00000000E+00  0.10475250E+01
+    15    13     3  0.00000000E+00  0.00000000E+00  0.10522776E+01
+    15    13     4  0.00000000E+00  0.00000000E+00  0.10618742E+01
+    15    13     5  0.00000000E+00  0.00000000E+00  0.10814451E+01
+    15    13     6  0.00000000E+00  0.00000000E+00  0.10422907E+01
+    15    13     7  0.00000000E+00  0.00000000E+00  0.10377513E+01
+    15    13     8  0.00000000E+00  0.00000000E+00  0.10090382E+01
+    15    13     9  0.00000000E+00  0.00000000E+00  0.93482132E+00
+    15    13    10  0.00000000E+00  0.00000000E+00  0.82119350E+00
+    15    13    11  0.00000000E+00  0.00000000E+00  0.93556432E+00
+    15    13    12  0.00000000E+00  0.00000000E+00  0.99557497E+00
+    15    13    13  0.00000000E+00  0.00000000E+00  0.99300243E+00
+    15    14     1  0.79545458E-15  0.76567224E-15  0.10388970E+01
+    15    14     2  0.33821213E-14  0.32515636E-14  0.10401523E+01
+    15    14     3  0.14524943E-13  0.13930512E-13  0.10426712E+01
+    15    14     4  0.63065467E-13  0.60190019E-13  0.10477728E+01
+    15    14     5  0.27866942E-12  0.26339175E-12  0.10580036E+01
+    15    14     6  0.12690674E-11  0.11763232E-11  0.10788424E+01
+    15    14     7  0.56814858E-11  0.54768649E-11  0.10373609E+01
+    15    14     8  0.72966466E-10  0.74604968E-10  0.97803764E+00
+    15    14     9  0.53452246E-09  0.56352641E-09  0.94853134E+00
+    15    14    10  0.29339276E-08  0.41331174E-08  0.70985829E+00
+    15    14    11  0.10910976E-07  0.20726119E-07  0.52643605E+00
+    15    14    12  0.39748147E-07  0.45722249E-07  0.86933926E+00
+    15    14    13  0.43004542E-07  0.42618088E-07  0.10090678E+01
+    15    14    14  0.31536926E-07  0.31785270E-07  0.99218681E+00
+    15    15     1  0.83900099E-09  0.81193375E-09  0.10333368E+01
+    15    15     2  0.17694650E-08  0.17112767E-08  0.10340029E+01
+    15    15     3  0.37633956E-08  0.36349419E-08  0.10353386E+01
+    15    15     4  0.80727607E-08  0.77770555E-08  0.10380228E+01
+    15    15     5  0.17558501E-07  0.16827889E-07  0.10434167E+01
+    15    15     6  0.39109496E-07  0.37094478E-07  0.10543212E+01
+    15    15     7  0.90936973E-07  0.84411326E-07  0.10773077E+01
+    15    15     8  0.21639821E-06  0.21700753E-06  0.99719217E+00
+    15    15     9  0.50700221E-06  0.52114676E-06  0.97285881E+00
+    15    15    10  0.90790620E-06  0.14191054E-05  0.63977360E+00
+    15    15    11  0.15831934E-05  0.36050609E-05  0.43915858E+00
+    15    15    12  0.40095504E-05  0.44755769E-05  0.89587341E+00
+    15    15    13  0.60401673E-05  0.65083892E-05  0.92805872E+00
+    15    15    14  0.72717056E-05  0.76264943E-05  0.95347945E+00
+    15    15    15  0.42010447E-05  0.41995800E-05  0.10003488E+01
+    15    16     1  0.15305650E-09  0.14885788E-09  0.10282055E+01
+    15    16     2  0.32127567E-09  0.31235545E-09  0.10285579E+01
+    15    16     3  0.67933541E-09  0.66001909E-09  0.10292663E+01
+    15    16     4  0.14462911E-08  0.14032284E-08  0.10306883E+01
+    15    16     5  0.31133008E-08  0.30122521E-08  0.10335459E+01
+    15    16     6  0.68298898E-08  0.65716608E-08  0.10392943E+01
+    15    16     7  0.14493079E-07  0.13840181E-07  0.10471741E+01
+    15    16     8  0.32734504E-07  0.30564686E-07  0.10709910E+01
+    15    16     9  0.11126542E-06  0.11133199E-06  0.99940203E+00
+    15    16    10  0.10063840E-05  0.14681417E-05  0.68548151E+00
+    15    16    11  0.31375705E-05  0.68536834E-05  0.45779332E+00
+    15    16    12  0.15697128E-05  0.17372080E-05  0.90358367E+00
+    15    16    13  0.29190981E-05  0.34245181E-05  0.85241134E+00
+    15    16    14  0.11529950E-04  0.17878031E-04  0.64492282E+00
+    15    16    15  0.18154132E-04  0.20568345E-04  0.88262484E+00
+    15    16    16  0.30616644E-05  0.31725452E-05  0.96504988E+00
+    15    17     1  0.49420746E-33  0.48292493E-33  0.10233629E+01
+    15    17     2  0.99723483E-33  0.97429207E-33  0.10235481E+01
+    15    17     3  0.19640230E-32  0.19181365E-32  0.10239225E+01
+    15    17     4  0.36603637E-32  0.35722167E-32  0.10246757E+01
+    15    17     5  0.60902685E-32  0.59348511E-32  0.10261872E+01
+    15    17     6  0.51571564E-16  0.50108819E-16  0.10291914E+01
+    15    17     7  0.33155977E-10  0.32321370E-10  0.10258221E+01
+    15    17     8  0.36319300E-07  0.35863996E-07  0.10126953E+01
+    15    17     9  0.18923611E-07  0.17678605E-07  0.10704245E+01
+    15    17    10  0.41336281E-05  0.64267888E-05  0.64318717E+00
+    15    17    11  0.12660431E-04  0.29028942E-04  0.43613131E+00
+    15    17    12  0.61208164E-05  0.74569564E-05  0.82081966E+00
+    15    17    13  0.11655114E-04  0.13983445E-04  0.83349376E+00
+    15    17    14  0.53054629E-04  0.83214841E-04  0.63756211E+00
+    15    17    15  0.82786904E-04  0.12584380E-03  0.65785445E+00
+    15    17    16  0.17155904E-04  0.16067069E-04  0.10677681E+01
+    15    17    17  0.16071858E-06  0.16225875E-06  0.99050797E+00
+    15    18     1  0.63800241E-69  0.62627181E-69  0.10187308E+01
+    15    18     2  0.22892262E-59  0.22469219E-59  0.10188277E+01
+    15    18     3  0.12777302E-51  0.12538750E-51  0.10190251E+01
+    15    18     4  0.26869452E-45  0.26357470E-45  0.10194245E+01
+    15    18     5  0.42523745E-40  0.41680694E-40  0.10202264E+01
+    15    18     6  0.11626639E-12  0.11380056E-12  0.10216680E+01
+    15    18     7  0.91049388E-08  0.90685004E-08  0.10040181E+01
+    15    18     8  0.40735027E-07  0.40263609E-07  0.10117083E+01
+    15    18     9  0.80759874E-11  0.77041149E-11  0.10482693E+01
+    15    18    10  0.23883303E-04  0.71761022E-04  0.33281721E+00
+    15    18    11  0.54176010E-04  0.22863456E-03  0.23695460E+00
+    15    18    12  0.81780071E-04  0.16239185E-03  0.50359715E+00
+    15    18    13  0.11067276E-03  0.16406023E-03  0.67458613E+00
+    15    18    14  0.22859760E-03  0.37235118E-03  0.61393011E+00
+    15    18    15  0.37520403E-03  0.63129443E-03  0.59434079E+00
+    15    18    16  0.62001990E-04  0.56147118E-04  0.11042773E+01
+    15    18    17  0.70250802E-06  0.68905696E-06  0.10195210E+01
+    15    18    18  0.43131630E-09  0.40703159E-09  0.10596630E+01
+    16     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    16     7     1  0.00000000E+00  0.00000000E+00  0.10717125E+01
+    16     7     2  0.00000000E+00  0.00000000E+00  0.10501284E+01
+    16     7     3  0.00000000E+00  0.00000000E+00  0.10201475E+01
+    16     7     4  0.00000000E+00  0.00000000E+00  0.98918871E+00
+    16     7     5  0.00000000E+00  0.00000000E+00  0.96266528E+00
+    16     7     6  0.00000000E+00  0.00000000E+00  0.92744630E+00
+    16     7     7  0.00000000E+00  0.00000000E+00  0.88559810E+00
+    16     8     1  0.00000000E+00  0.00000000E+00  0.10690310E+01
+    16     8     2  0.00000000E+00  0.00000000E+00  0.10645464E+01
+    16     8     3  0.00000000E+00  0.00000000E+00  0.10429145E+01
+    16     8     4  0.00000000E+00  0.00000000E+00  0.10129489E+01
+    16     8     5  0.00000000E+00  0.00000000E+00  0.98171053E+00
+    16     8     6  0.00000000E+00  0.00000000E+00  0.95070600E+00
+    16     8     7  0.00000000E+00  0.00000000E+00  0.91760486E+00
+    16     8     8  0.00000000E+00  0.00000000E+00  0.97229026E+00
+    16     9     1  0.00000000E+00  0.00000000E+00  0.10952929E+01
+    16     9     2  0.00000000E+00  0.00000000E+00  0.10631137E+01
+    16     9     3  0.00000000E+00  0.00000000E+00  0.10588301E+01
+    16     9     4  0.00000000E+00  0.00000000E+00  0.10370306E+01
+    16     9     5  0.00000000E+00  0.00000000E+00  0.10057128E+01
+    16     9     6  0.00000000E+00  0.00000000E+00  0.97446026E+00
+    16     9     7  0.00000000E+00  0.00000000E+00  0.93980978E+00
+    16     9     8  0.00000000E+00  0.00000000E+00  0.98179121E+00
+    16     9     9  0.00000000E+00  0.00000000E+00  0.99481238E+00
+    16    10     1  0.00000000E+00  0.00000000E+00  0.10752267E+01
+    16    10     2  0.00000000E+00  0.00000000E+00  0.10911291E+01
+    16    10     3  0.00000000E+00  0.00000000E+00  0.10578720E+01
+    16    10     4  0.00000000E+00  0.00000000E+00  0.10535381E+01
+    16    10     5  0.00000000E+00  0.00000000E+00  0.10316947E+01
+    16    10     6  0.00000000E+00  0.00000000E+00  0.10017315E+01
+    16    10     7  0.00000000E+00  0.00000000E+00  0.96575697E+00
+    16    10     8  0.00000000E+00  0.00000000E+00  0.97591894E+00
+    16    10     9  0.00000000E+00  0.00000000E+00  0.99574004E+00
+    16    10    10  0.00000000E+00  0.00000000E+00  0.99449213E+00
+    16    11     1  0.00000000E+00  0.00000000E+00  0.10620990E+01
+    16    11     2  0.00000000E+00  0.00000000E+00  0.10704087E+01
+    16    11     3  0.00000000E+00  0.00000000E+00  0.10873222E+01
+    16    11     4  0.00000000E+00  0.00000000E+00  0.10526843E+01
+    16    11     5  0.00000000E+00  0.00000000E+00  0.10482243E+01
+    16    11     6  0.00000000E+00  0.00000000E+00  0.10257345E+01
+    16    11     7  0.00000000E+00  0.00000000E+00  0.99191343E+00
+    16    11     8  0.00000000E+00  0.00000000E+00  0.96829426E+00
+    16    11     9  0.00000000E+00  0.00000000E+00  0.99698253E+00
+    16    11    10  0.00000000E+00  0.00000000E+00  0.99512340E+00
+    16    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+    16    12     1  0.00000000E+00  0.00000000E+00  0.10526262E+01
+    16    12     2  0.00000000E+00  0.00000000E+00  0.10570536E+01
+    16    12     3  0.00000000E+00  0.00000000E+00  0.10660402E+01
+    16    12     4  0.00000000E+00  0.00000000E+00  0.10843835E+01
+    16    12     5  0.00000000E+00  0.00000000E+00  0.10472730E+01
+    16    12     6  0.00000000E+00  0.00000000E+00  0.10430693E+01
+    16    12     7  0.00000000E+00  0.00000000E+00  0.10192317E+01
+    16    12     8  0.00000000E+00  0.00000000E+00  0.95771860E+00
+    16    12     9  0.00000000E+00  0.00000000E+00  0.98285946E+00
+    16    12    10  0.00000000E+00  0.00000000E+00  0.99640426E+00
+    16    12    11  0.00000000E+00  0.00000000E+00  0.99485003E+00
+    16    12    12  0.00000000E+00  0.00000000E+00  0.99376764E+00
+    16    13     1  0.00000000E+00  0.00000000E+00  0.10451595E+01
+    16    13     2  0.00000000E+00  0.00000000E+00  0.10475250E+01
+    16    13     3  0.00000000E+00  0.00000000E+00  0.10522776E+01
+    16    13     4  0.00000000E+00  0.00000000E+00  0.10618742E+01
+    16    13     5  0.00000000E+00  0.00000000E+00  0.10814451E+01
+    16    13     6  0.00000000E+00  0.00000000E+00  0.10422907E+01
+    16    13     7  0.00000000E+00  0.00000000E+00  0.10377513E+01
+    16    13     8  0.00000000E+00  0.00000000E+00  0.10090382E+01
+    16    13     9  0.00000000E+00  0.00000000E+00  0.93482132E+00
+    16    13    10  0.00000000E+00  0.00000000E+00  0.82119350E+00
+    16    13    11  0.00000000E+00  0.00000000E+00  0.93556432E+00
+    16    13    12  0.00000000E+00  0.00000000E+00  0.99557497E+00
+    16    13    13  0.00000000E+00  0.00000000E+00  0.99300243E+00
+    16    14     1  0.00000000E+00  0.00000000E+00  0.10388970E+01
+    16    14     2  0.00000000E+00  0.00000000E+00  0.10401523E+01
+    16    14     3  0.00000000E+00  0.00000000E+00  0.10426712E+01
+    16    14     4  0.00000000E+00  0.00000000E+00  0.10477728E+01
+    16    14     5  0.00000000E+00  0.00000000E+00  0.10580036E+01
+    16    14     6  0.00000000E+00  0.00000000E+00  0.10788424E+01
+    16    14     7  0.00000000E+00  0.00000000E+00  0.10373609E+01
+    16    14     8  0.00000000E+00  0.00000000E+00  0.97803764E+00
+    16    14     9  0.00000000E+00  0.00000000E+00  0.94853134E+00
+    16    14    10  0.00000000E+00  0.00000000E+00  0.70985829E+00
+    16    14    11  0.00000000E+00  0.00000000E+00  0.52643605E+00
+    16    14    12  0.00000000E+00  0.00000000E+00  0.86933926E+00
+    16    14    13  0.00000000E+00  0.00000000E+00  0.10090678E+01
+    16    14    14  0.00000000E+00  0.00000000E+00  0.99218681E+00
+    16    15     1  0.27928512E-14  0.27027503E-14  0.10333368E+01
+    16    15     2  0.11748158E-13  0.11361823E-13  0.10340029E+01
+    16    15     3  0.49853662E-13  0.48152037E-13  0.10353386E+01
+    16    15     4  0.21360498E-12  0.20578063E-12  0.10380228E+01
+    16    15     5  0.93054595E-12  0.89182581E-12  0.10434167E+01
+    16    15     6  0.41771284E-11  0.39619125E-11  0.10543212E+01
+    16    15     7  0.22363149E-10  0.20758367E-10  0.10773077E+01
+    16    15     8  0.10365229E-09  0.10394415E-09  0.99719217E+00
+    16    15     9  0.10836828E-08  0.11139158E-08  0.97285881E+00
+    16    15    10  0.62488359E-08  0.97672613E-08  0.63977360E+00
+    16    15    11  0.29532857E-07  0.67248731E-07  0.43915858E+00
+    16    15    12  0.20005731E-06  0.22330980E-06  0.89587341E+00
+    16    15    13  0.48484210E-06  0.52242610E-06  0.92805872E+00
+    16    15    14  0.56443832E-06  0.59197744E-06  0.95347945E+00
+    16    15    15  0.33662516E-06  0.33650780E-06  0.10003488E+01
+    16    16     1  0.54875205E-08  0.53369879E-08  0.10282055E+01
+    16    16     2  0.11461770E-07  0.11143534E-07  0.10285579E+01
+    16    16     3  0.24118830E-07  0.23433031E-07  0.10292663E+01
+    16    16     4  0.51148925E-07  0.49625989E-07  0.10306883E+01
+    16    16     5  0.10996999E-06  0.10640069E-06  0.10335459E+01
+    16    16     6  0.24252672E-06  0.23335710E-06  0.10392943E+01
+    16    16     7  0.56313158E-06  0.53776311E-06  0.10471741E+01
+    16    16     8  0.13914240E-05  0.12991930E-05  0.10709910E+01
+    16    16     9  0.33967136E-05  0.33987459E-05  0.99940203E+00
+    16    16    10  0.63972705E-05  0.93325209E-05  0.68548151E+00
+    16    16    11  0.10571617E-04  0.23092553E-04  0.45779332E+00
+    16    16    12  0.27360234E-04  0.30279690E-04  0.90358367E+00
+    16    16    13  0.42170469E-04  0.49471971E-04  0.85241134E+00
+    16    16    14  0.58598498E-04  0.90861256E-04  0.64492282E+00
+    16    16    15  0.78526359E-04  0.88969124E-04  0.88262484E+00
+    16    16    16  0.39534258E-04  0.40966025E-04  0.96504988E+00
+    16    17     1  0.92263198E-09  0.90156871E-09  0.10233629E+01
+    16    17     2  0.19193157E-08  0.18751592E-08  0.10235481E+01
+    16    17     3  0.40189098E-08  0.39250138E-08  0.10239225E+01
+    16    17     4  0.84698278E-08  0.82658618E-08  0.10246757E+01
+    16    17     5  0.18057286E-07  0.17596482E-07  0.10261872E+01
+    16    17     6  0.39338909E-07  0.38223123E-07  0.10291914E+01
+    16    17     7  0.79058249E-07  0.77068184E-07  0.10258221E+01
+    16    17     8  0.25699182E-06  0.25377014E-06  0.10126953E+01
+    16    17     9  0.62075568E-06  0.57991543E-06  0.10704245E+01
+    16    17    10  0.70360680E-05  0.10939379E-04  0.64318717E+00
+    16    17    11  0.20276287E-04  0.46491242E-04  0.43613131E+00
+    16    17    12  0.14112466E-04  0.17193138E-04  0.82081966E+00
+    16    17    13  0.20809964E-04  0.24967151E-04  0.83349376E+00
+    16    17    14  0.69785851E-04  0.10945734E-03  0.63756211E+00
+    16    17    15  0.11815447E-03  0.17960580E-03  0.65785445E+00
+    16    17    16  0.16911184E-03  0.15837880E-03  0.10677681E+01
+    16    17    17  0.28212070E-04  0.28482427E-04  0.99050797E+00
+    16    18     1  0.74537611E-35  0.73167129E-35  0.10187308E+01
+    16    18     2  0.77420310E-35  0.75989604E-35  0.10188277E+01
+    16    18     3  0.10062801E-34  0.98749286E-35  0.10190251E+01
+    16    18     4  0.17525884E-34  0.17191938E-34  0.10194245E+01
+    16    18     5  0.31779246E-34  0.31149209E-34  0.10202264E+01
+    16    18     6  0.23253278E-12  0.22760112E-12  0.10216680E+01
+    16    18     7  0.19038602E-07  0.18962409E-07  0.10040181E+01
+    16    18     8  0.74465495E-07  0.73603722E-07  0.10117083E+01
+    16    18     9  0.36061175E-11  0.34400678E-11  0.10482693E+01
+    16    18    10  0.41754288E-04  0.12545712E-03  0.33281721E+00
+    16    18    11  0.92748509E-04  0.39141891E-03  0.23695460E+00
+    16    18    12  0.12354224E-03  0.24531958E-03  0.50359715E+00
+    16    18    13  0.15393179E-03  0.22818701E-03  0.67458613E+00
+    16    18    14  0.31683586E-03  0.51607806E-03  0.61393011E+00
+    16    18    15  0.51295413E-03  0.86306399E-03  0.59434079E+00
+    16    18    16  0.57119064E-03  0.51725288E-03  0.11042773E+01
+    16    18    17  0.21368747E-03  0.20959595E-03  0.10195210E+01
+    16    18    18  0.10886445E-05  0.10273497E-05  0.10596630E+01
+    17     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    17     7     1  0.00000000E+00  0.00000000E+00  0.10717125E+01
+    17     7     2  0.00000000E+00  0.00000000E+00  0.10501284E+01
+    17     7     3  0.00000000E+00  0.00000000E+00  0.10201475E+01
+    17     7     4  0.00000000E+00  0.00000000E+00  0.98918871E+00
+    17     7     5  0.00000000E+00  0.00000000E+00  0.96266528E+00
+    17     7     6  0.00000000E+00  0.00000000E+00  0.92744630E+00
+    17     7     7  0.00000000E+00  0.00000000E+00  0.88559810E+00
+    17     8     1  0.00000000E+00  0.00000000E+00  0.10690310E+01
+    17     8     2  0.00000000E+00  0.00000000E+00  0.10645464E+01
+    17     8     3  0.00000000E+00  0.00000000E+00  0.10429145E+01
+    17     8     4  0.00000000E+00  0.00000000E+00  0.10129489E+01
+    17     8     5  0.00000000E+00  0.00000000E+00  0.98171053E+00
+    17     8     6  0.00000000E+00  0.00000000E+00  0.95070600E+00
+    17     8     7  0.00000000E+00  0.00000000E+00  0.91760486E+00
+    17     8     8  0.00000000E+00  0.00000000E+00  0.97229026E+00
+    17     9     1  0.00000000E+00  0.00000000E+00  0.10952929E+01
+    17     9     2  0.00000000E+00  0.00000000E+00  0.10631137E+01
+    17     9     3  0.00000000E+00  0.00000000E+00  0.10588301E+01
+    17     9     4  0.00000000E+00  0.00000000E+00  0.10370306E+01
+    17     9     5  0.00000000E+00  0.00000000E+00  0.10057128E+01
+    17     9     6  0.00000000E+00  0.00000000E+00  0.97446026E+00
+    17     9     7  0.00000000E+00  0.00000000E+00  0.93980978E+00
+    17     9     8  0.00000000E+00  0.00000000E+00  0.98179121E+00
+    17     9     9  0.00000000E+00  0.00000000E+00  0.99481238E+00
+    17    10     1  0.00000000E+00  0.00000000E+00  0.10752267E+01
+    17    10     2  0.00000000E+00  0.00000000E+00  0.10911291E+01
+    17    10     3  0.00000000E+00  0.00000000E+00  0.10578720E+01
+    17    10     4  0.00000000E+00  0.00000000E+00  0.10535381E+01
+    17    10     5  0.00000000E+00  0.00000000E+00  0.10316947E+01
+    17    10     6  0.00000000E+00  0.00000000E+00  0.10017315E+01
+    17    10     7  0.00000000E+00  0.00000000E+00  0.96575697E+00
+    17    10     8  0.00000000E+00  0.00000000E+00  0.97591894E+00
+    17    10     9  0.00000000E+00  0.00000000E+00  0.99574004E+00
+    17    10    10  0.00000000E+00  0.00000000E+00  0.99449213E+00
+    17    11     1  0.00000000E+00  0.00000000E+00  0.10620990E+01
+    17    11     2  0.00000000E+00  0.00000000E+00  0.10704087E+01
+    17    11     3  0.00000000E+00  0.00000000E+00  0.10873222E+01
+    17    11     4  0.00000000E+00  0.00000000E+00  0.10526843E+01
+    17    11     5  0.00000000E+00  0.00000000E+00  0.10482243E+01
+    17    11     6  0.00000000E+00  0.00000000E+00  0.10257345E+01
+    17    11     7  0.00000000E+00  0.00000000E+00  0.99191343E+00
+    17    11     8  0.00000000E+00  0.00000000E+00  0.96829426E+00
+    17    11     9  0.00000000E+00  0.00000000E+00  0.99698253E+00
+    17    11    10  0.00000000E+00  0.00000000E+00  0.99512340E+00
+    17    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+    17    12     1  0.00000000E+00  0.00000000E+00  0.10526262E+01
+    17    12     2  0.00000000E+00  0.00000000E+00  0.10570536E+01
+    17    12     3  0.00000000E+00  0.00000000E+00  0.10660402E+01
+    17    12     4  0.00000000E+00  0.00000000E+00  0.10843835E+01
+    17    12     5  0.00000000E+00  0.00000000E+00  0.10472730E+01
+    17    12     6  0.00000000E+00  0.00000000E+00  0.10430693E+01
+    17    12     7  0.00000000E+00  0.00000000E+00  0.10192317E+01
+    17    12     8  0.00000000E+00  0.00000000E+00  0.95771860E+00
+    17    12     9  0.00000000E+00  0.00000000E+00  0.98285946E+00
+    17    12    10  0.00000000E+00  0.00000000E+00  0.99640426E+00
+    17    12    11  0.00000000E+00  0.00000000E+00  0.99485003E+00
+    17    12    12  0.00000000E+00  0.00000000E+00  0.99376764E+00
+    17    13     1  0.00000000E+00  0.00000000E+00  0.10451595E+01
+    17    13     2  0.00000000E+00  0.00000000E+00  0.10475250E+01
+    17    13     3  0.00000000E+00  0.00000000E+00  0.10522776E+01
+    17    13     4  0.00000000E+00  0.00000000E+00  0.10618742E+01
+    17    13     5  0.00000000E+00  0.00000000E+00  0.10814451E+01
+    17    13     6  0.00000000E+00  0.00000000E+00  0.10422907E+01
+    17    13     7  0.00000000E+00  0.00000000E+00  0.10377513E+01
+    17    13     8  0.00000000E+00  0.00000000E+00  0.10090382E+01
+    17    13     9  0.00000000E+00  0.00000000E+00  0.93482132E+00
+    17    13    10  0.00000000E+00  0.00000000E+00  0.82119350E+00
+    17    13    11  0.00000000E+00  0.00000000E+00  0.93556432E+00
+    17    13    12  0.00000000E+00  0.00000000E+00  0.99557497E+00
+    17    13    13  0.00000000E+00  0.00000000E+00  0.99300243E+00
+    17    14     1  0.00000000E+00  0.00000000E+00  0.10388970E+01
+    17    14     2  0.00000000E+00  0.00000000E+00  0.10401523E+01
+    17    14     3  0.00000000E+00  0.00000000E+00  0.10426712E+01
+    17    14     4  0.00000000E+00  0.00000000E+00  0.10477728E+01
+    17    14     5  0.00000000E+00  0.00000000E+00  0.10580036E+01
+    17    14     6  0.00000000E+00  0.00000000E+00  0.10788424E+01
+    17    14     7  0.00000000E+00  0.00000000E+00  0.10373609E+01
+    17    14     8  0.00000000E+00  0.00000000E+00  0.97803764E+00
+    17    14     9  0.00000000E+00  0.00000000E+00  0.94853134E+00
+    17    14    10  0.00000000E+00  0.00000000E+00  0.70985829E+00
+    17    14    11  0.00000000E+00  0.00000000E+00  0.52643605E+00
+    17    14    12  0.00000000E+00  0.00000000E+00  0.86933926E+00
+    17    14    13  0.00000000E+00  0.00000000E+00  0.10090678E+01
+    17    14    14  0.00000000E+00  0.00000000E+00  0.99218681E+00
+    17    15     1  0.00000000E+00  0.00000000E+00  0.10333368E+01
+    17    15     2  0.00000000E+00  0.00000000E+00  0.10340029E+01
+    17    15     3  0.00000000E+00  0.00000000E+00  0.10353386E+01
+    17    15     4  0.00000000E+00  0.00000000E+00  0.10380228E+01
+    17    15     5  0.00000000E+00  0.00000000E+00  0.10434167E+01
+    17    15     6  0.00000000E+00  0.00000000E+00  0.10543212E+01
+    17    15     7  0.00000000E+00  0.00000000E+00  0.10773077E+01
+    17    15     8  0.00000000E+00  0.00000000E+00  0.99719217E+00
+    17    15     9  0.00000000E+00  0.00000000E+00  0.97285881E+00
+    17    15    10  0.00000000E+00  0.00000000E+00  0.63977360E+00
+    17    15    11  0.00000000E+00  0.00000000E+00  0.43915858E+00
+    17    15    12  0.00000000E+00  0.00000000E+00  0.89587341E+00
+    17    15    13  0.00000000E+00  0.00000000E+00  0.92805872E+00
+    17    15    14  0.00000000E+00  0.00000000E+00  0.95347945E+00
+    17    15    15  0.00000000E+00  0.00000000E+00  0.10003488E+01
+    17    16     1  0.96149489E-14  0.93511934E-14  0.10282055E+01
+    17    16     2  0.40053751E-13  0.38941658E-13  0.10285579E+01
+    17    16     3  0.16808774E-12  0.16330831E-12  0.10292663E+01
+    17    16     4  0.71106874E-12  0.68989699E-12  0.10306883E+01
+    17    16     5  0.30523617E-11  0.29532909E-11  0.10335459E+01
+    17    16     6  0.13470531E-10  0.12961228E-10  0.10392943E+01
+    17    16     7  0.78270426E-10  0.74744427E-10  0.10471741E+01
+    17    16     8  0.36570675E-09  0.34146575E-09  0.10709910E+01
+    17    16     9  0.13662138E-08  0.13670312E-08  0.99940203E+00
+    17    16    10  0.13586430E-07  0.19820272E-07  0.68548151E+00
+    17    16    11  0.64118463E-07  0.14005985E-06  0.45779332E+00
+    17    16    12  0.61427675E-06  0.67982276E-06  0.90358367E+00
+    17    16    13  0.20064402E-05  0.23538403E-05  0.85241134E+00
+    17    16    14  0.45676953E-05  0.70825457E-05  0.64492282E+00
+    17    16    15  0.73177717E-05  0.82909198E-05  0.88262484E+00
+    17    16    16  0.31079782E-05  0.32205363E-05  0.96504988E+00
+    17    17     1  0.35198654E-07  0.34395085E-07  0.10233629E+01
+    17    17     2  0.72871802E-07  0.71195285E-07  0.10235481E+01
+    17    17     3  0.15179675E-06  0.14825024E-06  0.10239225E+01
+    17    17     4  0.31819747E-06  0.31053480E-06  0.10246757E+01
+    17    17     5  0.67489318E-06  0.65767060E-06  0.10261872E+01
+    17    17     6  0.14642214E-05  0.14226911E-05  0.10291914E+01
+    17    17     7  0.33404009E-05  0.32563159E-05  0.10258221E+01
+    17    17     8  0.79928575E-05  0.78926580E-05  0.10126953E+01
+    17    17     9  0.20578979E-04  0.19225063E-04  0.10704245E+01
+    17    17    10  0.41605939E-04  0.64687141E-04  0.64318717E+00
+    17    17    11  0.64333436E-04  0.14750933E-03  0.43613131E+00
+    17    17    12  0.16904984E-03  0.20595247E-03  0.82081966E+00
+    17    17    13  0.28010763E-03  0.33606446E-03  0.83349376E+00
+    17    17    14  0.39056433E-03  0.61259025E-03  0.63756211E+00
+    17    17    15  0.63161984E-03  0.96012095E-03  0.65785445E+00
+    17    17    16  0.74443307E-03  0.69718609E-03  0.10677681E+01
+    17    17    17  0.33779950E-03  0.34103663E-03  0.99050797E+00
+    17    18     1  0.54596875E-08  0.53593032E-08  0.10187308E+01
+    17    18     2  0.11263921E-07  0.11055767E-07  0.10188277E+01
+    17    18     3  0.23363983E-07  0.22927778E-07  0.10190251E+01
+    17    18     4  0.48712596E-07  0.47784406E-07  0.10194245E+01
+    17    18     5  0.10256353E-06  0.10053017E-06  0.10202264E+01
+    17    18     6  0.21981263E-06  0.21515074E-06  0.10216680E+01
+    17    18     7  0.45664495E-06  0.45481744E-06  0.10040181E+01
+    17    18     8  0.11147004E-05  0.11018002E-05  0.10117083E+01
+    17    18     9  0.33660366E-05  0.32110418E-05  0.10482693E+01
+    17    18    10  0.76668877E-04  0.23036332E-03  0.33281721E+00
+    17    18    11  0.16214839E-03  0.68430152E-03  0.23695460E+00
+    17    18    12  0.19908969E-03  0.39533522E-03  0.50359715E+00
+    17    18    13  0.25598545E-03  0.37947037E-03  0.67458613E+00
+    17    18    14  0.47330513E-03  0.77094300E-03  0.61393011E+00
+    17    18    15  0.78843316E-03  0.13265675E-02  0.59434079E+00
+    17    18    16  0.26492783E-03  0.23991059E-03  0.11042773E+01
+    17    18    17  0.15873422E-02  0.15569490E-02  0.10195210E+01
+    17    18    18  0.21172817E-03  0.19980709E-03  0.10596630E+01
+    18     1     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     2     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     2     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     3     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     3     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     3     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     4     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     4     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     4     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     4     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     5     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     5     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     5     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     5     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     5     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     6     1  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     6     2  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     6     3  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     6     4  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     6     5  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     6     6  0.00000000E+00  0.00000000E+00  0.10000000E+01
+    18     7     1  0.00000000E+00  0.00000000E+00  0.10717125E+01
+    18     7     2  0.00000000E+00  0.00000000E+00  0.10501284E+01
+    18     7     3  0.00000000E+00  0.00000000E+00  0.10201475E+01
+    18     7     4  0.00000000E+00  0.00000000E+00  0.98918871E+00
+    18     7     5  0.00000000E+00  0.00000000E+00  0.96266528E+00
+    18     7     6  0.00000000E+00  0.00000000E+00  0.92744630E+00
+    18     7     7  0.00000000E+00  0.00000000E+00  0.88559810E+00
+    18     8     1  0.00000000E+00  0.00000000E+00  0.10690310E+01
+    18     8     2  0.00000000E+00  0.00000000E+00  0.10645464E+01
+    18     8     3  0.00000000E+00  0.00000000E+00  0.10429145E+01
+    18     8     4  0.00000000E+00  0.00000000E+00  0.10129489E+01
+    18     8     5  0.00000000E+00  0.00000000E+00  0.98171053E+00
+    18     8     6  0.00000000E+00  0.00000000E+00  0.95070600E+00
+    18     8     7  0.00000000E+00  0.00000000E+00  0.91760486E+00
+    18     8     8  0.00000000E+00  0.00000000E+00  0.97229026E+00
+    18     9     1  0.00000000E+00  0.00000000E+00  0.10952929E+01
+    18     9     2  0.00000000E+00  0.00000000E+00  0.10631137E+01
+    18     9     3  0.00000000E+00  0.00000000E+00  0.10588301E+01
+    18     9     4  0.00000000E+00  0.00000000E+00  0.10370306E+01
+    18     9     5  0.00000000E+00  0.00000000E+00  0.10057128E+01
+    18     9     6  0.00000000E+00  0.00000000E+00  0.97446026E+00
+    18     9     7  0.00000000E+00  0.00000000E+00  0.93980978E+00
+    18     9     8  0.00000000E+00  0.00000000E+00  0.98179121E+00
+    18     9     9  0.00000000E+00  0.00000000E+00  0.99481238E+00
+    18    10     1  0.00000000E+00  0.00000000E+00  0.10752267E+01
+    18    10     2  0.00000000E+00  0.00000000E+00  0.10911291E+01
+    18    10     3  0.00000000E+00  0.00000000E+00  0.10578720E+01
+    18    10     4  0.00000000E+00  0.00000000E+00  0.10535381E+01
+    18    10     5  0.00000000E+00  0.00000000E+00  0.10316947E+01
+    18    10     6  0.00000000E+00  0.00000000E+00  0.10017315E+01
+    18    10     7  0.00000000E+00  0.00000000E+00  0.96575697E+00
+    18    10     8  0.00000000E+00  0.00000000E+00  0.97591894E+00
+    18    10     9  0.00000000E+00  0.00000000E+00  0.99574004E+00
+    18    10    10  0.00000000E+00  0.00000000E+00  0.99449213E+00
+    18    11     1  0.00000000E+00  0.00000000E+00  0.10620990E+01
+    18    11     2  0.00000000E+00  0.00000000E+00  0.10704087E+01
+    18    11     3  0.00000000E+00  0.00000000E+00  0.10873222E+01
+    18    11     4  0.00000000E+00  0.00000000E+00  0.10526843E+01
+    18    11     5  0.00000000E+00  0.00000000E+00  0.10482243E+01
+    18    11     6  0.00000000E+00  0.00000000E+00  0.10257345E+01
+    18    11     7  0.00000000E+00  0.00000000E+00  0.99191343E+00
+    18    11     8  0.00000000E+00  0.00000000E+00  0.96829426E+00
+    18    11     9  0.00000000E+00  0.00000000E+00  0.99698253E+00
+    18    11    10  0.00000000E+00  0.00000000E+00  0.99512340E+00
+    18    11    11  0.00000000E+00  0.00000000E+00  0.99399930E+00
+    18    12     1  0.00000000E+00  0.00000000E+00  0.10526262E+01
+    18    12     2  0.00000000E+00  0.00000000E+00  0.10570536E+01
+    18    12     3  0.00000000E+00  0.00000000E+00  0.10660402E+01
+    18    12     4  0.00000000E+00  0.00000000E+00  0.10843835E+01
+    18    12     5  0.00000000E+00  0.00000000E+00  0.10472730E+01
+    18    12     6  0.00000000E+00  0.00000000E+00  0.10430693E+01
+    18    12     7  0.00000000E+00  0.00000000E+00  0.10192317E+01
+    18    12     8  0.00000000E+00  0.00000000E+00  0.95771860E+00
+    18    12     9  0.00000000E+00  0.00000000E+00  0.98285946E+00
+    18    12    10  0.00000000E+00  0.00000000E+00  0.99640426E+00
+    18    12    11  0.00000000E+00  0.00000000E+00  0.99485003E+00
+    18    12    12  0.00000000E+00  0.00000000E+00  0.99376764E+00
+    18    13     1  0.00000000E+00  0.00000000E+00  0.10451595E+01
+    18    13     2  0.00000000E+00  0.00000000E+00  0.10475250E+01
+    18    13     3  0.00000000E+00  0.00000000E+00  0.10522776E+01
+    18    13     4  0.00000000E+00  0.00000000E+00  0.10618742E+01
+    18    13     5  0.00000000E+00  0.00000000E+00  0.10814451E+01
+    18    13     6  0.00000000E+00  0.00000000E+00  0.10422907E+01
+    18    13     7  0.00000000E+00  0.00000000E+00  0.10377513E+01
+    18    13     8  0.00000000E+00  0.00000000E+00  0.10090382E+01
+    18    13     9  0.00000000E+00  0.00000000E+00  0.93482132E+00
+    18    13    10  0.00000000E+00  0.00000000E+00  0.82119350E+00
+    18    13    11  0.00000000E+00  0.00000000E+00  0.93556432E+00
+    18    13    12  0.00000000E+00  0.00000000E+00  0.99557497E+00
+    18    13    13  0.00000000E+00  0.00000000E+00  0.99300243E+00
+    18    14     1  0.00000000E+00  0.00000000E+00  0.10388970E+01
+    18    14     2  0.00000000E+00  0.00000000E+00  0.10401523E+01
+    18    14     3  0.00000000E+00  0.00000000E+00  0.10426712E+01
+    18    14     4  0.00000000E+00  0.00000000E+00  0.10477728E+01
+    18    14     5  0.00000000E+00  0.00000000E+00  0.10580036E+01
+    18    14     6  0.00000000E+00  0.00000000E+00  0.10788424E+01
+    18    14     7  0.00000000E+00  0.00000000E+00  0.10373609E+01
+    18    14     8  0.00000000E+00  0.00000000E+00  0.97803764E+00
+    18    14     9  0.00000000E+00  0.00000000E+00  0.94853134E+00
+    18    14    10  0.00000000E+00  0.00000000E+00  0.70985829E+00
+    18    14    11  0.00000000E+00  0.00000000E+00  0.52643605E+00
+    18    14    12  0.00000000E+00  0.00000000E+00  0.86933926E+00
+    18    14    13  0.00000000E+00  0.00000000E+00  0.10090678E+01
+    18    14    14  0.00000000E+00  0.00000000E+00  0.99218681E+00
+    18    15     1  0.00000000E+00  0.00000000E+00  0.10333368E+01
+    18    15     2  0.00000000E+00  0.00000000E+00  0.10340029E+01
+    18    15     3  0.00000000E+00  0.00000000E+00  0.10353386E+01
+    18    15     4  0.00000000E+00  0.00000000E+00  0.10380228E+01
+    18    15     5  0.00000000E+00  0.00000000E+00  0.10434167E+01
+    18    15     6  0.00000000E+00  0.00000000E+00  0.10543212E+01
+    18    15     7  0.00000000E+00  0.00000000E+00  0.10773077E+01
+    18    15     8  0.00000000E+00  0.00000000E+00  0.99719217E+00
+    18    15     9  0.00000000E+00  0.00000000E+00  0.97285881E+00
+    18    15    10  0.00000000E+00  0.00000000E+00  0.63977360E+00
+    18    15    11  0.00000000E+00  0.00000000E+00  0.43915858E+00
+    18    15    12  0.00000000E+00  0.00000000E+00  0.89587341E+00
+    18    15    13  0.00000000E+00  0.00000000E+00  0.92805872E+00
+    18    15    14  0.00000000E+00  0.00000000E+00  0.95347945E+00
+    18    15    15  0.00000000E+00  0.00000000E+00  0.10003488E+01
+    18    16     1  0.00000000E+00  0.00000000E+00  0.10282055E+01
+    18    16     2  0.00000000E+00  0.00000000E+00  0.10285579E+01
+    18    16     3  0.00000000E+00  0.00000000E+00  0.10292663E+01
+    18    16     4  0.00000000E+00  0.00000000E+00  0.10306883E+01
+    18    16     5  0.00000000E+00  0.00000000E+00  0.10335459E+01
+    18    16     6  0.00000000E+00  0.00000000E+00  0.10392943E+01
+    18    16     7  0.00000000E+00  0.00000000E+00  0.10471741E+01
+    18    16     8  0.00000000E+00  0.00000000E+00  0.10709910E+01
+    18    16     9  0.00000000E+00  0.00000000E+00  0.99940203E+00
+    18    16    10  0.00000000E+00  0.00000000E+00  0.68548151E+00
+    18    16    11  0.00000000E+00  0.00000000E+00  0.45779332E+00
+    18    16    12  0.00000000E+00  0.00000000E+00  0.90358367E+00
+    18    16    13  0.00000000E+00  0.00000000E+00  0.85241134E+00
+    18    16    14  0.00000000E+00  0.00000000E+00  0.64492282E+00
+    18    16    15  0.00000000E+00  0.00000000E+00  0.88262484E+00
+    18    16    16  0.00000000E+00  0.00000000E+00  0.96504988E+00
+    18    17     1  0.32496764E-13  0.31754878E-13  0.10233629E+01
+    18    17     2  0.13420018E-12  0.13111272E-12  0.10235481E+01
+    18    17     3  0.55745026E-12  0.54442624E-12  0.10239225E+01
+    18    17     4  0.23296056E-11  0.22735053E-11  0.10246757E+01
+    18    17     5  0.98484542E-11  0.95971317E-11  0.10261872E+01
+    18    17     6  0.42735864E-10  0.41523730E-10  0.10291914E+01
+    18    17     7  0.25998146E-09  0.25343717E-09  0.10258221E+01
+    18    17     8  0.11075727E-08  0.10936881E-08  0.10126953E+01
+    18    17     9  0.43570005E-08  0.40703483E-08  0.10704245E+01
+    18    17    10  0.15141699E-07  0.23541669E-07  0.64318717E+00
+    18    17    11  0.11504812E-06  0.26379239E-06  0.43613131E+00
+    18    17    12  0.12915041E-05  0.15734322E-05  0.82081966E+00
+    18    17    13  0.62963405E-05  0.75541543E-05  0.83349376E+00
+    18    17    14  0.17225428E-04  0.27017647E-04  0.63756211E+00
+    18    17    15  0.43849561E-04  0.66655414E-04  0.65785445E+00
+    18    17    16  0.29587463E-04  0.27709634E-04  0.10677681E+01
+    18    17    17  0.26449813E-04  0.26703281E-04  0.99050797E+00
+    18    18     1  0.22218998E-06  0.21810469E-06  0.10187308E+01
+    18    18     2  0.45638467E-06  0.44795081E-06  0.10188277E+01
+    18    18     3  0.94188695E-06  0.92430198E-06  0.10190251E+01
+    18    18     4  0.19525652E-05  0.19153602E-05  0.10194245E+01
+    18    18     5  0.40837217E-05  0.40027602E-05  0.10202264E+01
+    18    18     6  0.86896029E-05  0.85053099E-05  0.10216680E+01
+    18    18     7  0.19200909E-04  0.19124066E-04  0.10040181E+01
+    18    18     8  0.44950858E-04  0.44430651E-04  0.10117083E+01
+    18    18     9  0.11242017E-03  0.10724360E-03  0.10482693E+01
+    18    18    10  0.20017722E-03  0.60146296E-03  0.33281721E+00
+    18    18    11  0.34519914E-03  0.14568155E-02  0.23695460E+00
+    18    18    12  0.76951976E-03  0.15280463E-02  0.50359715E+00
+    18    18    13  0.15307121E-02  0.22691130E-02  0.67458613E+00
+    18    18    14  0.23983580E-02  0.39065652E-02  0.61393011E+00
+    18    18    15  0.37411016E-02  0.62945394E-02  0.59434079E+00
+    18    18    16  0.60664474E-02  0.54935904E-02  0.11042773E+01
+    18    18    17  0.50988270E-02  0.50011987E-02  0.10195210E+01
+    18    18    18  0.24543008E-02  0.23161145E-02  0.10596630E+01
+
+
diff --git a/wrfv2_fire/run/coeff_q.asc b/wrfv2_fire/run/coeff_q.asc
new file mode 100644
index 00000000..618c4e4b
--- /dev/null
+++ b/wrfv2_fire/run/coeff_q.asc
@@ -0,0 +1,326 @@
+     1     1  0.00000000E+00
+     1     2  0.00000000E+00
+     1     3  0.00000000E+00
+     1     4  0.00000000E+00
+     1     5  0.00000000E+00
+     1     6  0.00000000E+00
+     1     7  0.12242701E-17
+     1     8  0.46975654E-17
+     1     9  0.17984227E-16
+     1    10  0.69862154E-16
+     1    11  0.32074017E-15
+     1    12  0.13456264E-14
+     1    13  0.46738072E-14
+     1    14  0.15836851E-13
+     1    15  0.52728521E-13
+     1    16  0.17213769E-12
+     1    17  0.55116858E-12
+     1    18  0.17368306E-11
+     2     1  0.00000000E+00
+     2     2  0.00000000E+00
+     2     3  0.00000000E+00
+     2     4  0.00000000E+00
+     2     5  0.00000000E+00
+     2     6  0.00000000E+00
+     2     7  0.52651358E-17
+     2     8  0.19822092E-16
+     2     9  0.74791973E-16
+     2    10  0.29421151E-15
+     2    11  0.14165224E-14
+     2    12  0.58773339E-14
+     2    13  0.20137015E-13
+     2    14  0.67504432E-13
+     2    15  0.22244320E-12
+     2    16  0.71918817E-12
+     2    17  0.22824565E-11
+     2    18  0.71357643E-11
+     3     1  0.00000000E+00
+     3     2  0.00000000E+00
+     3     3  0.00000000E+00
+     3     4  0.00000000E+00
+     3     5  0.00000000E+00
+     3     6  0.00000000E+00
+     3     7  0.23720911E-16
+     3     8  0.86841608E-16
+     3     9  0.31875481E-15
+     3    10  0.12837731E-14
+     3    11  0.64196204E-14
+     3    12  0.25895806E-13
+     3    13  0.87539625E-13
+     3    14  0.29032159E-12
+     3    15  0.94633644E-12
+     3    16  0.30271961E-11
+     3    17  0.95103516E-11
+     3    18  0.29457247E-10
+     4     1  0.00000000E+00
+     4     2  0.00000000E+00
+     4     3  0.00000000E+00
+     4     4  0.00000000E+00
+     4     5  0.00000000E+00
+     4     6  0.00000000E+00
+     4     7  0.11178379E-15
+     4     8  0.40499353E-15
+     4     9  0.14292066E-14
+     4    10  0.59354753E-14
+     4    11  0.29763104E-13
+     4    12  0.11466307E-12
+     4    13  0.38335982E-12
+     4    14  0.12590575E-11
+     4    15  0.40602957E-11
+     4    16  0.12841372E-10
+     4    17  0.39877515E-10
+     4    18  0.12214956E-09
+     5     1  0.00000000E+00
+     5     2  0.00000000E+00
+     5     3  0.00000000E+00
+     5     4  0.00000000E+00
+     5     5  0.00000000E+00
+     5     6  0.00000000E+00
+     5     7  0.49961342E-15
+     5     8  0.20033728E-14
+     5     9  0.70348931E-14
+     5    10  0.29505305E-13
+     5    11  0.13968307E-12
+     5    12  0.50947612E-12
+     5    13  0.16940338E-11
+     5    14  0.55264083E-11
+     5    15  0.17662576E-10
+     5    16  0.55224040E-10
+     5    17  0.16918875E-09
+     5    18  0.51103425E-09
+     6     1  0.00000000E+00
+     6     2  0.00000000E+00
+     6     3  0.00000000E+00
+     6     4  0.00000000E+00
+     6     5  0.00000000E+00
+     6     6  0.00000000E+00
+     6     7  0.15262301E-14
+     6     8  0.93495761E-14
+     6     9  0.37373165E-13
+     6    10  0.15240041E-12
+     6    11  0.64559249E-12
+     6    12  0.22662213E-11
+     6    13  0.75658514E-11
+     6    14  0.24700078E-10
+     6    15  0.78670416E-10
+     6    16  0.24359512E-09
+     6    17  0.73428153E-09
+     6    18  0.21752926E-08
+     7     1  0.78353289E-16
+     7     2  0.16848435E-15
+     7     3  0.37953458E-15
+     7     4  0.89427034E-15
+     7     5  0.19984537E-14
+     7     6  0.30524601E-14
+     7     7  0.22504295E-14
+     7     8  0.29097911E-13
+     7     9  0.17830156E-12
+     7    10  0.73722420E-12
+     7    11  0.28498742E-11
+     7    12  0.10053779E-10
+     7    13  0.34243401E-10
+     7    14  0.11364618E-09
+     7    15  0.36557398E-09
+     7    16  0.11287071E-08
+     7    17  0.33398720E-08
+     7    18  0.96163377E-08
+     8     1  0.60128837E-15
+     8     2  0.12686139E-14
+     8     3  0.27789315E-14
+     8     4  0.64798965E-14
+     8     5  0.16026982E-13
+     8     6  0.37398305E-13
+     8     7  0.58195821E-13
+     8     8  0.44960083E-13
+     8     9  0.53510708E-12
+     8    10  0.28801321E-11
+     8    11  0.11690127E-10
+     8    12  0.43467051E-10
+     8    13  0.15482652E-09
+     8    14  0.53558800E-09
+     8    15  0.17796712E-08
+     8    16  0.55662944E-08
+     8    17  0.16249687E-07
+     8    18  0.45144689E-07
+     9     1  0.46039621E-14
+     9     2  0.95733725E-14
+     9     3  0.20400308E-13
+     9     4  0.45734610E-13
+     9     5  0.11255829E-12
+     9     6  0.29898532E-12
+     9     7  0.71320625E-12
+     9     8  0.10702142E-11
+     9     9  0.90689380E-12
+     9    10  0.79955344E-11
+     9    11  0.42663224E-10
+     9    12  0.17627383E-09
+     9    13  0.67650988E-09
+     9    14  0.25011802E-08
+     9    15  0.87513128E-08
+     9    16  0.28254727E-07
+     9    17  0.83140704E-07
+     9    18  0.22604016E-06
+    10     1  0.35769423E-13
+    10     2  0.75318146E-13
+    10     3  0.16432296E-12
+    10     4  0.37987042E-12
+    10     5  0.94416977E-12
+    10     6  0.24384066E-11
+    10     7  0.58977936E-11
+    10     8  0.11520529E-10
+    10     9  0.15991069E-10
+    10    10  0.13857522E-10
+    10    11  0.11699879E-09
+    10    12  0.62572790E-09
+    10    13  0.26880684E-08
+    10    14  0.10810962E-07
+    10    15  0.39875159E-07
+    10    16  0.13958515E-06
+    10    17  0.46387671E-06
+    10    18  0.14504359E-05
+    11     1  0.32843793E-12
+    11     2  0.72525948E-12
+    11     3  0.16434228E-11
+    11     4  0.38096774E-11
+    11     5  0.89397165E-11
+    11     6  0.20658960E-10
+    11     7  0.45597987E-10
+    11     8  0.93521017E-10
+    11     9  0.17065290E-09
+    11    10  0.23399757E-09
+    11    11  0.19917293E-09
+    11    12  0.16562138E-08
+    11    13  0.90771527E-08
+    11    14  0.41044595E-07
+    11    15  0.16260697E-06
+    11    16  0.56668801E-06
+    11    17  0.18088210E-05
+    11    18  0.55950634E-05
+    12     1  0.27558429E-11
+    12     2  0.60183899E-11
+    12     3  0.13258653E-10
+    12     4  0.29353747E-10
+    12     5  0.65212944E-10
+    12     6  0.14503817E-09
+    12     7  0.32172093E-09
+    12     8  0.69547282E-09
+    12     9  0.14101906E-08
+    12    10  0.25029116E-08
+    12    11  0.33124275E-08
+    12    12  0.27468823E-08
+    12    13  0.22685007E-07
+    12    14  0.13104151E-06
+    12    15  0.57910979E-06
+    12    16  0.20264251E-05
+    12    17  0.65121483E-05
+    12    18  0.20062111E-04
+    13     1  0.19143914E-10
+    13     2  0.41240607E-10
+    13     3  0.89640576E-10
+    13     4  0.19628023E-09
+    13     5  0.43367264E-09
+    13     6  0.96842898E-09
+    13     7  0.21915777E-08
+    13     8  0.49544485E-08
+    13     9  0.10824158E-07
+    13    10  0.21504547E-07
+    13    11  0.36308611E-07
+    13    12  0.45370013E-07
+    13    13  0.35907281E-07
+    13    14  0.29855466E-06
+    13    15  0.17431367E-05
+    13    16  0.67646536E-05
+    13    17  0.22291850E-04
+    13    18  0.68841758E-04
+    14     1  0.12973549E-09
+    14     2  0.27649815E-09
+    14     3  0.59457863E-09
+    14     4  0.12892749E-08
+    14     5  0.28295210E-08
+    14     6  0.63232199E-08
+    14     7  0.14546711E-07
+    14     8  0.34277632E-07
+    14     9  0.80037765E-07
+    14    10  0.17297540E-06
+    14    11  0.32835676E-06
+    14    12  0.52416603E-06
+    14    13  0.59710932E-06
+    14    14  0.43853382E-06
+    14    15  0.36162939E-05
+    14    16  0.19705671E-04
+    14    17  0.70476286E-04
+    14    18  0.22173771E-03
+    15     1  0.86390409E-09
+    15     2  0.18222547E-08
+    15     3  0.38761940E-08
+    15     4  0.83154855E-08
+    15     5  0.18086478E-07
+    15     6  0.40279253E-07
+    15     7  0.93586940E-07
+    15     8  0.22779791E-06
+    15     9  0.56008402E-06
+    15    10  0.12760051E-05
+    15    11  0.26017115E-05
+    15    12  0.46328783E-05
+    15    13  0.69725470E-05
+    15    14  0.72325879E-05
+    15    15  0.48797947E-05
+    15    16  0.38130520E-04
+    15    17  0.19186469E-03
+    15    18  0.64967817E-03
+    16     1  0.56406079E-08
+    16     2  0.11783179E-07
+    16     3  0.24798791E-07
+    16     4  0.52598261E-07
+    16     5  0.11309883E-06
+    16     6  0.24944141E-06
+    16     7  0.57789802E-06
+    16     8  0.14249714E-05
+    16     9  0.36166050E-05
+    16    10  0.89334494E-05
+    16    11  0.18134016E-04
+    16    12  0.32422801E-04
+    16    13  0.54117229E-04
+    16    14  0.78822682E-04
+    16    15  0.76261041E-04
+    16    16  0.47503136E-04
+    16    17  0.32450405E-03
+    16    18  0.14001621E-02
+    17     1  0.36121384E-07
+    17     2  0.74791536E-07
+    17     3  0.15581760E-06
+    17     4  0.32667660E-06
+    17     5  0.69299712E-06
+    17     6  0.15038086E-05
+    17     7  0.34200290E-05
+    17     8  0.83198399E-05
+    17     9  0.21284020E-04
+    17    10  0.59376219E-04
+    17    11  0.11576454E-03
+    17    12  0.20838874E-03
+    17    13  0.35666960E-03
+    17    14  0.56381028E-03
+    17    15  0.76745877E-03
+    17    16  0.64900811E-03
+    17    17  0.39254443E-03
+    17    18  0.23001989E-02
+    18     1  0.22764986E-06
+    18     2  0.46764945E-06
+    18     3  0.96525506E-06
+    18     4  0.20012984E-05
+    18     5  0.41863926E-05
+    18     6  0.89099984E-05
+    18     7  0.19694260E-04
+    18     8  0.46228162E-04
+    18     9  0.11573256E-03
+    18    10  0.37131160E-03
+    18    11  0.71616812E-03
+    18    12  0.12839751E-02
+    18    13  0.22029363E-02
+    18    14  0.35478033E-02
+    18    15  0.51974254E-02
+    18    16  0.56006486E-02
+    18    17  0.46003977E-02
+    18    18  0.26656377E-02
+
+
diff --git a/wrfv2_fire/run/constants.asc b/wrfv2_fire/run/constants.asc
new file mode 100644
index 00000000..4601066f
--- /dev/null
+++ b/wrfv2_fire/run/constants.asc
@@ -0,0 +1,50 @@
+  0.00000E+00  0.10958E-01  0.61258E-02  0.30701E-02  0.15228E-02  0.75685E-03
+  0.37712E-03  0.18821E-03  0.94016E-04  0.46986E-04  0.23487E-04  0.11742E-04
+  0.58707E-05  0.29353E-05  0.14676E-05  0.73380E-06  0.36690E-06  0.18345E-06
+  0.91724E-07  0.45862E-07  0.22931E-07  0.11466E-07  0.57328E-08  0.28664E-08
+  0.14332E-08  0.71659E-09  0.35830E-09  0.17915E-09  0.89574E-10  0.44787E-10
+  0.22394E-10  0.11197E-10  0.55984E-11  0.00000E+00 -0.89361E-01 -0.47576E-01
+ -0.23400E-01 -0.11510E-01 -0.56981E-02 -0.28337E-02 -0.14129E-02 -0.70545E-03
+ -0.35247E-03 -0.17617E-03 -0.88071E-04 -0.44032E-04 -0.22015E-04 -0.11007E-04
+ -0.55035E-05 -0.27517E-05 -0.13759E-05 -0.68793E-06 -0.34397E-06 -0.17198E-06
+ -0.85991E-07 -0.42996E-07 -0.21498E-07 -0.10749E-07 -0.53745E-08 -0.26872E-08
+ -0.13436E-08 -0.67181E-09 -0.33590E-09 -0.16795E-09 -0.83976E-10 -0.41988E-10
+  0.00000E+00  0.48425E+00  0.21301E+00  0.98406E-01  0.47146E-01  0.23057E-01
+  0.11400E-01  0.56677E-02  0.28258E-02  0.14109E-02  0.70494E-03  0.35235E-03
+  0.17614E-03  0.88063E-04  0.44030E-04  0.22014E-04  0.11007E-04  0.55035E-05
+  0.27517E-05  0.13759E-05  0.68793E-06  0.34397E-06  0.17198E-06  0.85991E-07
+  0.42996E-07  0.21498E-07  0.10749E-07  0.53745E-08  0.26872E-08  0.13436E-08
+  0.67181E-09  0.33590E-09  0.16795E-09  0.00000E+00  0.68251E+00  0.89270E+00
+  0.95848E+00  0.98215E+00  0.99179E+00  0.99607E+00  0.99808E+00  0.99905E+00
+  0.99953E+00  0.99976E+00  0.99988E+00  0.99994E+00  0.99997E+00  0.99999E+00
+  0.99999E+00  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01
+  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01
+  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01
+  0.00000E+00 -0.10009E+00 -0.72098E-01 -0.40821E-01 -0.21508E-01 -0.11016E-01
+ -0.55724E-02 -0.28020E-02 -0.14050E-02 -0.70346E-03 -0.35198E-03 -0.17605E-03
+ -0.88040E-04 -0.44024E-04 -0.22013E-04 -0.11007E-04 -0.55034E-05 -0.27517E-05
+ -0.13759E-05 -0.68793E-06 -0.34397E-06 -0.17198E-06 -0.85991E-07 -0.42996E-07
+ -0.21498E-07 -0.10749E-07 -0.53745E-08 -0.26872E-08 -0.13436E-08 -0.67181E-09
+ -0.33590E-09 -0.16795E-09 -0.83976E-10  0.00000E+00  0.11729E-01  0.78432E-02
+  0.42637E-02  0.21989E-02  0.11140E-02  0.56037E-03  0.28099E-03  0.14069E-03
+  0.70396E-04  0.35210E-04  0.17608E-04  0.88048E-05  0.44026E-05  0.22013E-05
+  0.11007E-05  0.55034E-06  0.27517E-06  0.13759E-06  0.68793E-07  0.34397E-07
+  0.17198E-07  0.85991E-08  0.42996E-08  0.21498E-08  0.10749E-08  0.53745E-09
+  0.26872E-09  0.13436E-09  0.67181E-10  0.33590E-10  0.16795E-10  0.83976E-11
+  0.00000E+00  0.58496E+00  0.80735E+00  0.90689E+00  0.95420E+00  0.97728E+00
+  0.98868E+00  0.99435E+00  0.99718E+00  0.99859E+00  0.99930E+00  0.99965E+00
+  0.99982E+00  0.99991E+00  0.99996E+00  0.99998E+00  0.99999E+00  0.99999E+00
+  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01
+  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01  0.10000E+01
+  0.10000E+01  0.10000E+01  0.10000E+01  0.00000E+00  0.41504E+00  0.19265E+00
+  0.93109E-01  0.45804E-01  0.22720E-01  0.11315E-01  0.56466E-02  0.28205E-02
+  0.14096E-02  0.70461E-03  0.35226E-03  0.17612E-03  0.88058E-04  0.44028E-04
+  0.22014E-04  0.11007E-04  0.55035E-05  0.27517E-05  0.13759E-05  0.68793E-06
+  0.34397E-06  0.17198E-06  0.85991E-07  0.42996E-07  0.21498E-07  0.10749E-07
+  0.53745E-08  0.26872E-08  0.13436E-08  0.67181E-09  0.33590E-09  0.16795E-09
+  0.20000E+01  0.40000E+01  0.20000E+01  0.40000E+01  0.20000E+01  0.40000E+01
+  0.20000E+01  0.40000E+01  0.20000E+01  0.40000E+01  0.20000E+01  0.40000E+01
+  0.20000E+01  0.40000E+01  0.20000E+01  0.40000E+01  0.20000E+01  0.40000E+01
+  0.20000E+01  0.40000E+01  0.20000E+01  0.40000E+01  0.20000E+01  0.40000E+01
+  0.20000E+01  0.40000E+01  0.20000E+01  0.40000E+01  0.20000E+01  0.40000E+01
+  0.20000E+01  0.40000E+01  0.20000E+01  0.93303E+00 -0.95910E-01  0.16288E+00
diff --git a/wrfv2_fire/run/kernels.asc_s_0_03_0_9 b/wrfv2_fire/run/kernels.asc_s_0_03_0_9
new file mode 100644
index 00000000..d16182b7
--- /dev/null
+++ b/wrfv2_fire/run/kernels.asc_s_0_03_0_9
@@ -0,0 +1,8894 @@
+  0.00000E+00  0.66489E-09  0.21789E-08  0.63335E-08  0.10878E-07  0.27467E-07
+  0.38453E-07  0.73059E-07  0.14073E-06  0.31228E-06  0.65713E-06  0.13649E-05
+  0.39767E-05  0.12167E-04  0.17230E-03  0.34953E-03  0.16992E-02  0.48043E-02
+  0.10185E-01  0.19822E-01  0.36538E-01  0.63894E-01  0.10422E+00  0.16661E+00
+  0.26099E+00  0.38566E+00  0.57873E+00  0.84795E+00  0.12212E+01  0.16952E+01
+  0.23149E+01  0.30206E+01  0.38660E+01  0.66489E-09  0.00000E+00  0.15832E-08
+  0.55340E-08  0.16660E-07  0.27363E-07  0.68572E-07  0.95384E-07  0.19112E-06
+  0.40896E-06  0.91070E-06  0.17787E-05  0.62141E-05  0.29027E-04  0.22054E-03
+  0.44567E-03  0.21638E-02  0.61051E-02  0.12918E-01  0.25101E-01  0.46203E-01
+  0.80697E-01  0.13149E+00  0.20998E+00  0.32857E+00  0.48500E+00  0.72695E+00
+  0.10637E+01  0.15296E+01  0.21193E+01  0.28878E+01  0.37581E+01  0.47946E+01
+  0.21789E-08  0.15832E-08  0.00000E+00  0.41886E-08  0.14903E-07  0.42178E-07
+  0.68529E-07  0.14501E-06  0.26237E-06  0.50292E-06  0.12072E-05  0.19415E-05
+  0.91973E-05  0.51881E-04  0.40880E-03  0.57061E-03  0.27642E-02  0.77781E-02
+  0.16419E-01  0.31842E-01  0.58515E-01  0.10206E+00  0.16609E+00  0.26492E+00
+  0.41411E+00  0.61061E+00  0.91421E+00  0.13361E+01  0.19187E+01  0.26545E+01
+  0.36103E+01  0.46879E+01  0.59654E+01  0.63335E-08  0.55340E-08  0.41886E-08
+  0.00000E+00  0.11398E-07  0.37353E-07  0.10495E-06  0.17031E-06  0.37935E-06
+  0.72035E-06  0.13859E-05  0.27469E-05  0.20686E-04  0.82351E-04  0.66261E-03
+  0.10962E-02  0.35438E-02  0.99385E-02  0.20919E-01  0.40471E-01  0.74226E-01
+  0.12924E+00  0.21004E+00  0.33460E+00  0.52245E+00  0.76950E+00  0.11509E+01
+  0.16802E+01  0.24101E+01  0.33298E+01  0.45218E+01  0.58607E+01  0.74412E+01
+  0.10878E-07  0.16660E-07  0.14903E-07  0.11398E-07  0.00000E+00  0.27141E-07
+  0.90917E-07  0.21131E-06  0.53164E-06  0.10480E-05  0.20787E-05  0.65436E-05
+  0.38420E-04  0.19989E-03  0.10004E-02  0.18046E-02  0.46888E-02  0.12741E-01
+  0.26725E-01  0.51555E-01  0.94333E-01  0.16393E+00  0.26598E+00  0.42311E+00
+  0.65980E+00  0.97076E+00  0.14503E+01  0.21151E+01  0.30306E+01  0.41822E+01
+  0.56717E+01  0.73399E+01  0.93022E+01  0.27467E-07  0.27363E-07  0.42178E-07
+  0.37353E-07  0.27141E-07  0.00000E+00  0.67018E-07  0.22501E-06  0.56514E-06
+  0.16576E-05  0.35007E-05  0.13825E-04  0.70708E-04  0.36433E-03  0.13159E-02
+  0.27475E-02  0.62013E-02  0.14971E-01  0.34258E-01  0.65856E-01  0.12016E+00
+  0.20832E+00  0.33733E+00  0.53573E+00  0.83424E+00  0.12259E+01  0.18295E+01
+  0.26652E+01  0.38149E+01  0.52587E+01  0.71233E+01  0.92060E+01  0.11649E+02
+  0.38453E-07  0.68572E-07  0.68529E-07  0.10495E-06  0.90917E-07  0.67018E-07
+  0.00000E+00  0.16411E-06  0.75818E-06  0.17433E-05  0.56234E-05  0.21703E-04
+  0.10490E-03  0.59462E-03  0.16949E-02  0.34635E-02  0.82055E-02  0.17832E-01
+  0.38219E-01  0.84390E-01  0.15346E+00  0.26531E+00  0.42859E+00  0.67933E+00
+  0.10562E+01  0.15497E+01  0.23100E+01  0.33617E+01  0.48067E+01  0.66188E+01
+  0.89559E+01  0.11561E+02  0.14609E+02  0.73059E-07  0.95384E-07  0.14501E-06
+  0.17031E-06  0.21131E-06  0.22501E-06  0.16411E-06  0.00000E+00  0.48764E-06
+  0.24923E-05  0.75973E-05  0.51776E-04  0.17246E-03  0.78799E-03  0.20279E-02
+  0.43269E-02  0.95945E-02  0.21601E-01  0.43137E-01  0.90797E-01  0.19657E+00
+  0.33873E+00  0.54565E+00  0.86289E+00  0.13390E+01  0.19615E+01  0.29197E+01
+  0.42437E+01  0.60614E+01  0.83381E+01  0.11270E+02  0.14533E+02  0.18342E+02
+  0.14073E-06  0.19112E-06  0.26237E-06  0.37935E-06  0.53164E-06  0.56514E-06
+  0.75818E-06  0.48764E-06  0.00000E+00  0.14162E-05  0.86023E-05  0.66377E-04
+  0.26785E-03  0.93659E-03  0.23955E-02  0.51532E-02  0.11209E-01  0.24193E-01
+  0.49544E-01  0.98305E-01  0.20724E+00  0.43364E+00  0.69624E+00  0.10981E+01
+  0.17002E+01  0.24858E+01  0.36945E+01  0.53626E+01  0.76501E+01  0.10512E+02
+  0.14194E+02  0.18284E+02  0.23052E+02  0.31228E-06  0.40896E-06  0.50292E-06
+  0.72035E-06  0.10480E-05  0.16576E-05  0.17433E-05  0.24923E-05  0.14162E-05
+  0.00000E+00  0.47584E-05  0.74244E-04  0.34744E-03  0.10890E-02  0.27144E-02
+  0.58517E-02  0.12603E-01  0.27108E-01  0.53709E-01  0.10794E+00  0.21892E+00
+  0.45231E+00  0.89052E+00  0.14003E+01  0.21624E+01  0.31545E+01  0.46799E+01
+  0.67824E+01  0.96628E+01  0.13262E+02  0.17889E+02  0.23017E+02  0.28989E+02
+  0.65713E-06  0.91070E-06  0.12072E-05  0.13859E-05  0.20787E-05  0.35007E-05
+  0.56234E-05  0.75973E-05  0.86023E-05  0.47584E-05  0.00000E+00  0.45653E-04
+  0.32961E-03  0.11259E-02  0.29522E-02  0.63623E-02  0.13631E-01  0.29268E-01
+  0.58207E-01  0.11371E+00  0.23347E+00  0.47120E+00  0.92039E+00  0.17887E+01
+  0.27544E+01  0.40078E+01  0.59336E+01  0.85844E+01  0.12213E+02  0.16739E+02
+  0.22552E+02  0.28986E+02  0.36464E+02  0.13649E-05  0.17787E-05  0.19415E-05
+  0.27469E-05  0.65436E-05  0.13825E-04  0.21703E-04  0.51776E-04  0.66377E-04
+  0.74244E-04  0.45653E-04  0.00000E+00  0.20419E-03  0.10130E-02  0.30559E-02
+  0.68010E-02  0.14602E-01  0.30661E-01  0.61499E-01  0.11992E+00  0.24323E+00
+  0.49468E+00  0.94845E+00  0.18469E+01  0.35152E+01  0.50994E+01  0.75318E+01
+  0.10875E+02  0.15445E+02  0.21138E+02  0.28442E+02  0.36510E+02  0.45876E+02
+  0.39767E-05  0.62141E-05  0.91973E-05  0.20686E-04  0.38420E-04  0.70708E-04
+  0.10490E-03  0.17246E-03  0.26785E-03  0.34744E-03  0.32961E-03  0.20419E-03
+  0.00000E+00  0.76276E-03  0.28922E-02  0.69707E-02  0.15695E-01  0.32499E-01
+  0.65284E-01  0.12492E+00  0.25466E+00  0.51170E+00  0.98282E+00  0.19013E+01
+  0.36261E+01  0.65005E+01  0.95749E+01  0.13793E+02  0.19550E+02  0.26709E+02
+  0.35884E+02  0.45997E+02  0.57723E+02  0.12167E-04  0.29027E-04  0.51881E-04
+  0.82351E-04  0.19989E-03  0.36433E-03  0.59462E-03  0.78799E-03  0.93659E-03
+  0.10890E-02  0.11259E-02  0.10130E-02  0.76276E-03  0.00000E+00  0.20971E-02
+  0.63314E-02  0.15567E-01  0.34163E-01  0.67476E-01  0.13150E+00  0.26622E+00
+  0.52840E+00  0.10051E+01  0.19611E+01  0.37183E+01  0.66793E+01  0.12167E+02
+  0.17483E+02  0.24728E+02  0.33719E+02  0.45228E+02  0.57879E+02  0.72524E+02
+  0.17230E-03  0.22054E-03  0.40880E-03  0.66261E-03  0.10004E-02  0.13159E-02
+  0.16949E-02  0.20279E-02  0.23955E-02  0.27144E-02  0.29522E-02  0.30559E-02
+  0.28922E-02  0.20971E-02  0.00000E+00  0.44037E-02  0.13654E-01  0.32829E-01
+  0.68293E-01  0.13281E+00  0.27157E+00  0.54394E+00  0.10246E+01  0.19961E+01
+  0.38193E+01  0.68186E+01  0.12458E+02  0.22143E+02  0.31250E+02  0.42520E+02
+  0.56927E+02  0.72709E+02  0.90942E+02  0.34953E-03  0.44567E-03  0.57061E-03
+  0.10962E-02  0.18046E-02  0.27475E-02  0.34635E-02  0.43269E-02  0.51532E-02
+  0.58517E-02  0.63623E-02  0.68010E-02  0.69707E-02  0.63314E-02  0.44037E-02
+  0.00000E+00  0.98339E-02  0.29288E-01  0.66013E-01  0.13232E+00  0.27586E+00
+  0.55654E+00  0.10468E+01  0.20366E+01  0.38878E+01  0.69942E+01  0.12707E+02
+  0.22647E+02  0.39531E+02  0.53647E+02  0.71662E+02  0.91317E+02  0.11397E+03
+  0.16992E-02  0.21638E-02  0.27642E-02  0.35438E-02  0.46888E-02  0.62013E-02
+  0.82055E-02  0.95945E-02  0.11209E-01  0.12603E-01  0.13631E-01  0.14602E-01
+  0.15695E-01  0.15567E-01  0.13654E-01  0.98339E-02  0.00000E+00  0.19821E-01
+  0.57435E-01  0.12501E+00  0.27332E+00  0.56250E+00  0.10622E+01  0.20714E+01
+  0.39501E+01  0.70815E+01  0.12982E+02  0.23010E+02  0.40280E+02  0.67590E+02
+  0.90053E+02  0.11443E+03  0.14244E+03  0.48043E-02  0.61051E-02  0.77781E-02
+  0.99385E-02  0.12741E-01  0.14971E-01  0.17832E-01  0.21601E-01  0.24193E-01
+  0.27108E-01  0.29268E-01  0.30661E-01  0.32499E-01  0.34163E-01  0.32829E-01
+  0.29288E-01  0.19821E-01  0.00000E+00  0.38088E-01  0.10636E+00  0.25972E+00
+  0.55839E+00  0.10681E+01  0.20995E+01  0.40096E+01  0.71636E+01  0.13106E+02
+  0.23433E+02  0.40793E+02  0.68609E+02  0.11302E+03  0.14312E+03  0.17757E+03
+  0.10185E-01  0.12918E-01  0.16419E-01  0.20919E-01  0.26725E-01  0.34258E-01
+  0.38219E-01  0.43137E-01  0.49544E-01  0.53709E-01  0.58207E-01  0.61499E-01
+  0.65284E-01  0.67476E-01  0.68293E-01  0.66013E-01  0.57435E-01  0.38088E-01
+  0.00000E+00  0.68349E-01  0.22743E+00  0.53737E+00  0.10586E+01  0.21171E+01
+  0.40663E+01  0.72475E+01  0.13234E+02  0.23598E+02  0.41431E+02  0.69235E+02
+  0.11429E+03  0.17874E+03  0.22089E+03  0.19822E-01  0.25101E-01  0.31842E-01
+  0.40471E-01  0.51555E-01  0.65856E-01  0.84390E-01  0.90797E-01  0.98305E-01
+  0.10794E+00  0.11371E+00  0.11992E+00  0.12492E+00  0.13150E+00  0.13281E+00
+  0.13232E+00  0.12501E+00  0.10636E+00  0.68349E-01  0.00000E+00  0.16692E+00
+  0.49230E+00  0.10295E+01  0.21258E+01  0.41298E+01  0.73536E+01  0.13412E+02
+  0.23833E+02  0.41697E+02  0.70175E+02  0.11505E+03  0.18004E+03  0.27458E+03
+  0.36538E-01  0.46203E-01  0.58515E-01  0.74226E-01  0.94333E-01  0.12016E+00
+  0.15346E+00  0.19657E+00  0.20724E+00  0.21892E+00  0.23347E+00  0.24323E+00
+  0.25466E+00  0.26622E+00  0.27157E+00  0.27586E+00  0.27332E+00  0.25972E+00
+  0.22743E+00  0.16692E+00  0.00000E+00  0.33121E+00  0.86831E+00  0.19844E+01
+  0.40173E+01  0.72338E+01  0.13294E+02  0.23656E+02  0.41338E+02  0.69338E+02
+  0.11458E+03  0.17782E+03  0.27114E+03  0.63894E-01  0.80697E-01  0.10206E+00
+  0.12924E+00  0.16393E+00  0.20832E+00  0.26531E+00  0.33873E+00  0.43364E+00
+  0.45231E+00  0.47120E+00  0.49468E+00  0.51170E+00  0.52840E+00  0.54394E+00
+  0.55654E+00  0.56250E+00  0.55839E+00  0.53737E+00  0.49230E+00  0.33121E+00
+  0.00000E+00  0.52576E+00  0.16540E+01  0.37060E+01  0.68872E+01  0.12918E+02
+  0.23162E+02  0.40558E+02  0.67840E+02  0.11174E+03  0.17430E+03  0.26321E+03
+  0.10422E+00  0.13149E+00  0.16609E+00  0.21004E+00  0.26598E+00  0.33733E+00
+  0.42859E+00  0.54565E+00  0.69624E+00  0.89052E+00  0.92039E+00  0.94845E+00
+  0.98282E+00  0.10051E+01  0.10246E+01  0.10468E+01  0.10622E+01  0.10681E+01
+  0.10586E+01  0.10295E+01  0.86831E+00  0.52576E+00  0.00000E+00  0.11684E+01
+  0.32820E+01  0.64712E+01  0.12552E+02  0.22785E+02  0.40038E+02  0.66763E+02
+  0.10946E+03  0.16942E+03  0.25664E+03  0.16661E+00  0.20998E+00  0.26492E+00
+  0.33460E+00  0.42311E+00  0.53573E+00  0.67933E+00  0.86289E+00  0.10981E+01
+  0.14003E+01  0.17887E+01  0.18469E+01  0.19013E+01  0.19611E+01  0.19961E+01
+  0.20366E+01  0.20714E+01  0.20995E+01  0.21171E+01  0.21258E+01  0.19844E+01
+  0.16540E+01  0.11684E+01  0.00000E+00  0.21197E+01  0.52098E+01  0.11206E+02
+  0.21211E+02  0.37979E+02  0.63553E+02  0.10409E+03  0.15973E+03  0.23953E+03
+  0.26099E+00  0.32857E+00  0.41411E+00  0.52245E+00  0.65980E+00  0.83424E+00
+  0.10562E+01  0.13390E+01  0.17002E+01  0.21624E+01  0.27544E+01  0.35152E+01
+  0.36261E+01  0.37183E+01  0.38193E+01  0.38878E+01  0.39501E+01  0.40096E+01
+  0.40663E+01  0.41298E+01  0.40173E+01  0.37060E+01  0.32820E+01  0.21197E+01
+  0.00000E+00  0.29443E+01  0.88214E+01  0.18530E+02  0.34692E+02  0.58850E+02
+  0.96767E+02  0.14720E+03  0.21798E+03  0.38566E+00  0.48500E+00  0.61061E+00
+  0.76950E+00  0.97076E+00  0.12259E+01  0.15497E+01  0.19615E+01  0.24858E+01
+  0.31545E+01  0.40078E+01  0.50994E+01  0.65005E+01  0.66793E+01  0.68186E+01
+  0.69942E+01  0.70815E+01  0.71636E+01  0.72475E+01  0.73536E+01  0.72338E+01
+  0.68872E+01  0.64712E+01  0.52098E+01  0.29443E+01  0.00000E+00  0.60091E+01
+  0.15753E+02  0.31769E+02  0.55068E+02  0.91140E+02  0.13727E+03  0.20029E+03
+  0.57873E+00  0.72695E+00  0.91421E+00  0.11509E+01  0.14503E+01  0.18295E+01
+  0.23100E+01  0.29197E+01  0.36945E+01  0.46799E+01  0.59336E+01  0.75318E+01
+  0.95749E+01  0.12167E+02  0.12458E+02  0.12707E+02  0.12982E+02  0.13106E+02
+  0.13234E+02  0.13412E+02  0.13294E+02  0.12918E+02  0.12552E+02  0.11206E+02
+  0.88214E+01  0.60091E+01  0.00000E+00  0.95388E+01  0.25008E+02  0.46692E+02
+  0.79702E+02  0.11936E+03  0.17121E+03  0.84795E+00  0.10637E+01  0.13361E+01
+  0.16802E+01  0.21151E+01  0.26652E+01  0.33617E+01  0.42437E+01  0.53626E+01
+  0.67824E+01  0.85844E+01  0.10875E+02  0.13793E+02  0.17483E+02  0.22143E+02
+  0.22647E+02  0.23010E+02  0.23433E+02  0.23598E+02  0.23833E+02  0.23656E+02
+  0.23162E+02  0.22785E+02  0.21211E+02  0.18530E+02  0.15753E+02  0.95388E+01
+  0.00000E+00  0.15142E+02  0.35286E+02  0.65225E+02  0.97950E+02  0.13779E+03
+  0.12212E+01  0.15296E+01  0.19187E+01  0.24101E+01  0.30306E+01  0.38149E+01
+  0.48067E+01  0.60614E+01  0.76501E+01  0.96628E+01  0.12213E+02  0.15445E+02
+  0.19550E+02  0.24728E+02  0.31250E+02  0.39531E+02  0.40280E+02  0.40793E+02
+  0.41431E+02  0.41697E+02  0.41338E+02  0.40558E+02  0.40038E+02  0.37979E+02
+  0.34692E+02  0.31769E+02  0.25008E+02  0.15142E+02  0.00000E+00  0.18695E+02
+  0.45511E+02  0.70595E+02  0.97181E+02  0.16952E+01  0.21193E+01  0.26545E+01
+  0.33298E+01  0.41822E+01  0.52587E+01  0.66188E+01  0.83381E+01  0.10512E+02
+  0.13262E+02  0.16739E+02  0.21138E+02  0.26709E+02  0.33719E+02  0.42520E+02
+  0.53647E+02  0.67590E+02  0.68609E+02  0.69235E+02  0.70175E+02  0.69338E+02
+  0.67840E+02  0.66763E+02  0.63553E+02  0.58850E+02  0.55068E+02  0.46692E+02
+  0.35286E+02  0.18695E+02  0.00000E+00  0.25437E+02  0.44457E+02  0.59766E+02
+  0.23149E+01  0.28878E+01  0.36103E+01  0.45218E+01  0.56717E+01  0.71233E+01
+  0.89559E+01  0.11270E+02  0.14194E+02  0.17889E+02  0.22552E+02  0.28442E+02
+  0.35884E+02  0.45228E+02  0.56927E+02  0.71662E+02  0.90053E+02  0.11302E+03
+  0.11429E+03  0.11505E+03  0.11458E+03  0.11174E+03  0.10946E+03  0.10409E+03
+  0.96767E+02  0.91140E+02  0.79702E+02  0.65225E+02  0.45511E+02  0.25437E+02
+  0.00000E+00  0.13459E+02  0.17643E+02  0.30206E+01  0.37581E+01  0.46879E+01
+  0.58607E+01  0.73399E+01  0.92060E+01  0.11561E+02  0.14533E+02  0.18284E+02
+  0.23017E+02  0.28986E+02  0.36510E+02  0.45997E+02  0.57879E+02  0.72709E+02
+  0.91317E+02  0.11443E+03  0.14312E+03  0.17874E+03  0.18004E+03  0.17782E+03
+  0.17430E+03  0.16942E+03  0.15973E+03  0.14720E+03  0.13727E+03  0.11936E+03
+  0.97950E+02  0.70595E+02  0.44457E+02  0.13459E+02  0.00000E+00  0.00000E+00
+  0.38660E+01  0.47946E+01  0.59654E+01  0.74412E+01  0.93022E+01  0.11649E+02
+  0.14609E+02  0.18342E+02  0.23052E+02  0.28989E+02  0.36464E+02  0.45876E+02
+  0.57723E+02  0.72524E+02  0.90942E+02  0.11397E+03  0.14244E+03  0.17757E+03
+  0.22089E+03  0.27458E+03  0.27114E+03  0.26321E+03  0.25664E+03  0.23953E+03
+  0.21798E+03  0.20029E+03  0.17121E+03  0.13779E+03  0.97181E+02  0.59766E+02
+  0.17643E+02  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.12617E-04  0.18801E-03
+  0.51939E-03  0.12110E-02  0.34218E-02  0.76457E-02  0.16706E-01  0.38413E-01
+  0.79575E-01  0.15958E+00  0.35277E+00  0.87409E+00  0.20420E+01  0.49167E+01
+  0.13118E+02  0.23637E+02  0.40984E+02  0.69768E+02  0.11320E+03  0.17961E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.65068E-08  0.68242E-04  0.24152E-03  0.63715E-03  0.16960E-02  0.49512E-02
+  0.10801E-01  0.22775E-01  0.49574E-01  0.10671E+00  0.21048E+00  0.44118E+00
+  0.10478E+01  0.23639E+01  0.60431E+01  0.14284E+02  0.26781E+02  0.47858E+02
+  0.81455E+02  0.13214E+03  0.20964E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.32155E-04  0.11058E-03  0.37459E-03
+  0.87279E-03  0.22070E-02  0.65449E-02  0.14064E-01  0.29480E-01  0.65196E-01
+  0.13935E+00  0.28156E+00  0.58095E+00  0.12536E+01  0.28322E+01  0.72525E+01
+  0.15459E+02  0.29940E+02  0.54755E+02  0.93171E+02  0.15112E+03  0.23972E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.34278E-04  0.11655E-03  0.41726E-03  0.96101E-03  0.25163E-02  0.82522E-02
+  0.17805E-01  0.37315E-01  0.81413E-01  0.17251E+00  0.34576E+00  0.71091E+00
+  0.15765E+01  0.33705E+01  0.84769E+01  0.17647E+02  0.32812E+02  0.58273E+02
+  0.99127E+02  0.16074E+03  0.25493E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.57942E-04  0.18383E-03  0.66857E-03
+  0.15885E-02  0.41098E-02  0.12697E-01  0.27109E-01  0.56106E-01  0.12042E+00
+  0.25703E+00  0.51912E+00  0.10696E+01  0.22903E+01  0.47701E+01  0.97080E+01
+  0.19842E+02  0.35691E+02  0.61799E+02  0.10509E+03  0.17036E+03  0.27011E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.63398E-04  0.21118E-03  0.81864E-03  0.19665E-02  0.52666E-02  0.14618E-01
+  0.30874E-01  0.63466E-01  0.13651E+00  0.29220E+00  0.58608E+00  0.11994E+01
+  0.24799E+01  0.49247E+01  0.10163E+02  0.19913E+02  0.35793E+02  0.61938E+02
+  0.10527E+03  0.17060E+03  0.27041E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.71661E-04  0.24674E-03  0.93539E-03
+  0.22934E-02  0.60748E-02  0.16211E-01  0.33932E-01  0.69340E-01  0.14928E+00
+  0.31880E+00  0.63595E+00  0.12952E+01  0.26340E+01  0.51124E+01  0.10565E+02
+  0.19991E+02  0.35902E+02  0.62084E+02  0.10546E+03  0.17082E+03  0.27067E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.86802E-04  0.30105E-03  0.10390E-02  0.26177E-02  0.66252E-02  0.17689E-01
+  0.36666E-01  0.74433E-01  0.16015E+00  0.33969E+00  0.67398E+00  0.13669E+01
+  0.27679E+01  0.53503E+01  0.10953E+02  0.20094E+02  0.36048E+02  0.62280E+02
+  0.10572E+03  0.17114E+03  0.27105E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.81615E-06  0.16561E-05
+  0.00000E+00  0.00000E+00  0.00000E+00  0.11133E-03  0.36768E-03  0.12452E-02
+  0.30219E-02  0.75168E-02  0.20031E-01  0.40857E-01  0.81854E-01  0.17423E+00
+  0.36636E+00  0.72690E+00  0.14643E+01  0.29314E+01  0.56937E+01  0.11125E+02
+  0.20265E+02  0.36295E+02  0.62628E+02  0.10620E+03  0.17179E+03  0.27191E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.26031E-05  0.52663E-05  0.78252E-05  0.00000E+00  0.00000E+00
+  0.13271E-03  0.42835E-03  0.14862E-02  0.37190E-02  0.88572E-02  0.22941E-01
+  0.46072E-01  0.91043E-01  0.19145E+00  0.39872E+00  0.78750E+00  0.15757E+01
+  0.31266E+01  0.59943E+01  0.11251E+02  0.20448E+02  0.36556E+02  0.62986E+02
+  0.10669E+03  0.17241E+03  0.27269E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.68573E-05  0.14641E-04
+  0.23033E-04  0.00000E+00  0.00000E+00  0.17063E-03  0.54801E-03  0.18404E-02
+  0.44707E-02  0.10555E-01  0.26946E-01  0.53172E-01  0.10366E+00  0.21656E+00
+  0.44546E+00  0.87241E+00  0.17419E+01  0.33613E+01  0.61608E+01  0.11410E+02
+  0.20677E+02  0.36882E+02  0.63431E+02  0.10728E+03  0.17317E+03  0.27364E+03
+  0.15863E-05  0.21723E-05  0.29651E-05  0.40417E-05  0.61455E-05  0.21228E-04
+  0.55020E-04  0.74260E-04  0.78718E-04  0.51150E-04  0.30907E-04  0.47903E-04
+  0.27463E-03  0.87581E-03  0.23376E-02  0.56070E-02  0.12996E-01  0.30069E-01
+  0.59176E-01  0.11436E+00  0.23671E+00  0.48241E+00  0.94311E+00  0.18699E+01
+  0.35765E+01  0.64795E+01  0.11970E+02  0.21644E+02  0.38535E+02  0.66165E+02
+  0.11175E+03  0.18015E+03  0.28433E+03  0.59904E-05  0.93467E-05  0.14027E-04
+  0.21076E-04  0.71659E-04  0.18203E-03  0.29374E-03  0.39909E-03  0.45692E-03
+  0.47028E-03  0.39568E-03  0.19902E-03  0.44054E-04  0.12296E-02  0.42966E-02
+  0.10328E-01  0.23264E-01  0.48722E-01  0.91159E-01  0.16594E+00  0.32114E+00
+  0.61894E+00  0.11365E+01  0.21665E+01  0.40808E+01  0.72960E+01  0.13335E+02
+  0.23900E+02  0.42247E+02  0.72109E+02  0.12121E+03  0.19460E+03  0.30612E+03
+  0.14755E-05  0.21259E-05  0.34480E-05  0.67799E-05  0.16577E-04  0.36115E-04
+  0.41867E-04  0.21865E-04  0.58257E-04  0.24555E-03  0.59205E-03  0.11038E-02
+  0.14884E-02  0.30854E-02  0.81983E-02  0.17915E-01  0.35451E-01  0.67204E-01
+  0.11840E+00  0.20580E+00  0.38218E+00  0.71267E+00  0.12760E+01  0.23799E+01
+  0.44047E+01  0.77697E+01  0.14039E+02  0.24934E+02  0.43752E+02  0.74256E+02
+  0.12426E+03  0.19885E+03  0.31204E+03  0.37062E-04  0.48849E-04  0.88465E-04
+  0.22665E-03  0.58414E-03  0.11972E-02  0.17565E-02  0.21319E-02  0.24705E-02
+  0.26746E-02  0.26994E-02  0.24534E-02  0.17295E-02  0.62835E-03  0.25319E-02
+  0.11457E-01  0.29214E-01  0.61453E-01  0.11484E+00  0.20512E+00  0.38913E+00
+  0.73227E+00  0.13098E+01  0.24408E+01  0.45032E+01  0.78993E+01  0.14215E+02
+  0.25143E+02  0.43957E+02  0.74332E+02  0.12399E+03  0.19776E+03  0.30938E+03
+  0.85154E-04  0.10410E-03  0.20525E-03  0.60804E-03  0.15174E-02  0.26302E-02
+  0.35988E-02  0.42926E-02  0.49569E-02  0.53784E-02  0.55106E-02  0.52914E-02
+  0.45791E-02  0.23731E-02  0.53712E-03  0.11080E-01  0.33098E-01  0.71151E-01
+  0.13364E+00  0.23662E+00  0.44382E+00  0.82298E+00  0.14478E+01  0.26578E+01
+  0.48357E+01  0.83737E+01  0.14906E+02  0.26122E+02  0.45314E+02  0.76121E+02
+  0.12629E+03  0.20048E+03  0.31243E+03  0.16101E-03  0.30454E-03  0.62480E-03
+  0.15153E-02  0.32675E-02  0.52574E-02  0.69361E-02  0.81839E-02  0.93511E-02
+  0.10099E-01  0.10442E-01  0.10260E-01  0.93883E-02  0.62612E-02  0.26826E-02
+  0.68425E-02  0.34849E-01  0.81799E-01  0.15689E+00  0.27711E+00  0.51574E+00
+  0.94321E+00  0.16306E+01  0.29449E+01  0.52740E+01  0.89967E+01  0.15811E+02
+  0.27400E+02  0.47083E+02  0.78451E+02  0.12927E+03  0.20404E+03  0.31644E+03
+  0.30122E-03  0.82618E-03  0.17303E-02  0.37011E-02  0.70663E-02  0.10545E-01
+  0.13362E-01  0.15573E-01  0.17565E-01  0.18821E-01  0.19534E-01  0.19424E-01
+  0.18322E-01  0.14173E-01  0.87197E-02  0.00000E+00  0.34581E-01  0.94575E-01
+  0.18795E+00  0.33277E+00  0.61567E+00  0.11102E+01  0.18835E+01  0.33397E+01
+  0.58734E+01  0.98446E+01  0.17038E+02  0.29130E+02  0.49474E+02  0.81612E+02
+  0.13336E+03  0.20897E+03  0.32213E+03  0.52371E-03  0.20047E-02  0.42494E-02
+  0.83508E-02  0.14417E-01  0.19984E-01  0.24247E-01  0.27897E-01  0.31009E-01
+  0.32895E-01  0.34157E-01  0.34114E-01  0.32654E-01  0.27858E-01  0.18185E-01
+  0.35474E-02  0.36063E-01  0.11659E+00  0.23807E+00  0.42004E+00  0.76824E+00
+  0.13600E+01  0.22563E+01  0.39130E+01  0.67333E+01  0.11052E+02  0.18775E+02
+  0.31569E+02  0.52847E+02  0.86095E+02  0.13921E+03  0.21620E+03  0.33079E+03
+  0.96380E-03  0.36814E-02  0.79040E-02  0.15935E-01  0.26272E-01  0.35630E-01
+  0.43267E-01  0.49386E-01  0.54255E-01  0.57311E-01  0.59217E-01  0.59229E-01
+  0.57108E-01  0.50313E-01  0.35937E-01  0.12495E-01  0.27741E-01  0.13909E+00
+  0.30163E+00  0.53677E+00  0.97749E+00  0.17049E+01  0.27691E+01  0.46976E+01
+  0.79014E+01  0.12679E+02  0.21094E+02  0.34804E+02  0.57289E+02  0.91963E+02
+  0.14683E+03  0.22556E+03  0.34198E+03  0.17806E-02  0.64513E-02  0.14086E-01
+  0.29706E-01  0.46807E-01  0.62403E-01  0.76529E-01  0.86729E-01  0.94133E-01
+  0.99178E-01  0.10186E+00  0.10200E+00  0.98850E-01  0.88559E-01  0.67735E-01
+  0.33488E-01  0.65380E-02  0.16281E+00  0.38732E+00  0.70114E+00  0.12769E+01
+  0.21987E+01  0.34989E+01  0.58052E+01  0.95347E+01  0.14931E+02  0.24276E+02
+  0.39203E+02  0.63289E+02  0.99846E+02  0.15702E+03  0.23809E+03  0.35699E+03
+  0.33438E-02  0.11382E-01  0.25386E-01  0.56392E-01  0.84422E-01  0.11033E+00
+  0.13705E+00  0.15413E+00  0.16499E+00  0.17340E+00  0.17679E+00  0.17707E+00
+  0.17207E+00  0.15552E+00  0.12449E+00  0.77801E-01  0.14187E-01  0.19424E+00
+  0.51455E+00  0.94791E+00  0.17255E+01  0.29327E+01  0.45723E+01  0.74148E+01
+  0.11879E+02  0.18125E+02  0.28740E+02  0.45314E+02  0.71550E+02  0.11063E+03
+  0.17093E+03  0.25517E+03  0.37751E+03  0.58029E-02  0.20503E-01  0.45087E-01
+  0.96931E-01  0.14601E+00  0.18974E+00  0.23194E+00  0.25929E+00  0.27715E+00
+  0.28980E+00  0.29502E+00  0.29461E+00  0.28610E+00  0.26042E+00  0.21319E+00
+  0.14491E+00  0.47982E-01  0.22082E+00  0.68928E+00  0.13044E+01  0.23848E+01
+  0.40130E+01  0.61426E+01  0.97495E+01  0.15244E+02  0.22657E+02  0.34998E+02
+  0.53782E+02  0.82881E+02  0.12529E+03  0.18967E+03  0.27805E+03  0.40491E+03
+  0.10194E-01  0.38115E-01  0.82126E-01  0.16794E+00  0.25712E+00  0.33277E+00
+  0.39735E+00  0.44135E+00  0.47204E+00  0.49054E+00  0.49893E+00  0.49598E+00
+  0.48034E+00  0.43879E+00  0.36292E+00  0.25740E+00  0.10507E+00  0.25450E+00
+  0.95597E+00  0.18529E+01  0.33965E+01  0.56582E+01  0.85105E+01  0.13230E+02
+  0.20196E+02  0.29241E+02  0.43972E+02  0.65776E+02  0.98739E+02  0.14559E+03
+  0.21540E+03  0.30927E+03  0.44215E+03  0.17135E-01  0.68302E-01  0.14401E+00
+  0.27793E+00  0.43422E+00  0.55969E+00  0.65018E+00  0.71726E+00  0.76884E+00
+  0.79406E+00  0.80807E+00  0.80000E+00  0.77309E+00  0.70878E+00  0.58989E+00
+  0.43140E+00  0.19232E+00  0.30768E+00  0.13782E+01  0.27161E+01  0.49756E+01
+  0.82022E+01  0.12134E+02  0.18493E+02  0.27593E+02  0.38949E+02  0.57024E+02
+  0.82986E+02  0.12120E+03  0.17401E+03  0.25103E+03  0.35212E+03  0.49293E+03
+  0.29773E-01  0.12278E+00  0.25594E+00  0.47843E+00  0.75653E+00  0.97206E+00
+  0.11123E+01  0.12211E+01  0.13103E+01  0.13482E+01  0.13717E+01  0.13543E+01
+  0.13071E+01  0.12026E+01  0.10098E+01  0.76128E+00  0.37707E+00  0.27586E+00
+  0.19291E+01  0.39556E+01  0.73236E+01  0.12025E+02  0.17576E+02  0.26368E+02
+  0.38575E+02  0.53212E+02  0.75983E+02  0.10767E+03  0.15299E+03  0.21369E+03
+  0.30015E+03  0.41045E+03  0.56125E+03  0.47468E-01  0.19569E+00  0.40776E+00
+  0.76185E+00  0.12067E+01  0.15473E+01  0.17728E+01  0.19421E+01  0.20819E+01
+  0.21404E+01  0.21724E+01  0.21396E+01  0.20590E+01  0.18891E+01  0.15849E+01
+  0.11977E+01  0.60962E+00  0.32711E+00  0.29159E+01  0.60390E+01  0.11155E+02
+  0.18156E+02  0.26195E+02  0.38679E+02  0.55530E+02  0.74957E+02  0.10450E+03
+  0.14429E+03  0.19952E+03  0.27100E+03  0.37019E+03  0.49271E+03  0.65670E+03
+  0.78375E-01  0.32302E+00  0.67283E+00  0.12565E+01  0.19948E+01  0.25519E+01
+  0.29297E+01  0.32021E+01  0.34305E+01  0.35255E+01  0.35698E+01  0.35081E+01
+  0.33668E+01  0.30810E+01  0.25836E+01  0.19575E+01  0.10225E+01  0.34690E+00
+  0.44342E+01  0.93009E+01  0.17178E+02  0.27776E+02  0.39652E+02  0.57776E+02
+  0.81612E+02  0.10808E+03  0.14746E+03  0.19879E+03  0.26785E+03  0.35401E+03
+  0.47024E+03  0.60864E+03  0.78947E+03  0.12480E+00  0.51428E+00  0.10709E+01
+  0.19994E+01  0.31845E+01  0.40635E+01  0.46792E+01  0.51026E+01  0.54662E+01
+  0.56199E+01  0.56799E+01  0.55732E+01  0.53390E+01  0.48781E+01  0.40945E+01
+  0.31148E+01  0.16710E+01  0.27729E+00  0.67739E+01  0.14427E+02  0.26692E+02
+  0.42961E+02  0.60813E+02  0.87647E+02  0.12213E+03  0.15909E+03  0.21297E+03
+  0.28096E+03  0.36962E+03  0.47604E+03  0.61531E+03  0.77440E+03  0.97674E+03
+  0.20607E+00  0.84897E+00  0.17675E+01  0.32990E+01  0.52771E+01  0.67128E+01
+  0.77613E+01  0.84416E+01  0.90452E+01  0.93077E+01  0.93895E+01  0.91999E+01
+  0.87978E+01  0.80261E+01  0.67455E+01  0.51532E+01  0.28384E+01  0.00000E+00
+  0.10380E+02  0.22504E+02  0.41776E+02  0.67041E+02  0.94278E+02  0.13469E+03
+  0.18557E+03  0.23839E+03  0.31393E+03  0.40636E+03  0.52318E+03  0.65791E+03
+  0.82871E+03  0.10149E+04  0.12447E+04  0.32537E+00  0.13403E+01  0.27901E+01
+  0.52065E+01  0.83754E+01  0.10615E+02  0.12340E+02  0.13382E+02  0.14348E+02
+  0.14788E+02  0.14889E+02  0.14570E+02  0.13910E+02  0.12666E+02  0.10651E+02
+  0.81520E+01  0.45662E+01  0.12578E+00  0.16301E+02  0.35626E+02  0.66141E+02
+  0.10576E+03  0.14785E+03  0.20962E+03  0.28603E+03  0.36312E+03  0.47150E+03
+  0.60030E+03  0.75829E+03  0.93321E+03  0.11478E+04  0.13698E+04  0.16348E+04
+  0.53168E+00  0.21900E+01  0.45580E+01  0.85041E+01  0.13780E+02  0.17386E+02
+  0.20350E+02  0.21990E+02  0.23603E+02  0.24378E+02  0.24492E+02  0.23933E+02
+  0.22803E+02  0.20715E+02  0.17422E+02  0.13343E+02  0.75745E+01  0.30085E+00
+  0.25959E+02  0.56909E+02  0.10552E+03  0.16814E+03  0.23388E+03  0.32945E+03
+  0.44593E+03  0.56056E+03  0.71928E+03  0.90296E+03  0.11219E+04  0.13547E+04
+  0.16308E+04  0.19005E+04  0.22105E+04  0.83544E+00  0.34408E+01  0.71607E+01
+  0.13358E+02  0.21847E+02  0.27412E+02  0.32374E+02  0.34834E+02  0.37449E+02
+  0.38798E+02  0.38892E+02  0.37961E+02  0.36105E+02  0.32730E+02  0.27558E+02
+  0.21145E+02  0.12208E+02  0.61890E+00  0.41432E+02  0.91175E+02  0.16896E+03
+  0.26856E+03  0.37207E+03  0.52145E+03  0.70125E+03  0.87443E+03  0.11111E+04
+  0.13785E+04  0.16890E+04  0.20063E+04  0.23700E+04  0.27036E+04  0.30710E+04
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.63259E-11  0.49739E-09
+  0.24927E-08  0.98347E-08  0.35611E-07  0.11213E-06  0.33795E-06  0.95174E-06
+  0.20009E-05  0.40830E-05  0.87749E-05  0.18693E-04  0.37885E-04  0.79527E-04
+  0.16442E-03  0.30731E-03  0.57810E-03  0.10608E-02  0.19112E-02  0.33133E-02
+  0.56396E-02  0.91497E-02  0.14517E-01  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.61127E-08  0.47375E-06  0.23446E-05  0.91534E-05  0.32852E-04
+  0.10268E-03  0.30762E-03  0.86211E-03  0.18053E-02  0.36720E-02  0.78714E-02
+  0.16734E-01  0.33858E-01  0.70980E-01  0.14659E+00  0.27377E+00  0.51464E+00
+  0.94388E+00  0.16998E+01  0.29458E+01  0.50128E+01  0.81311E+01  0.12898E+02
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.15802E-07  0.12032E-05
+  0.58626E-05  0.22586E-04  0.80158E-04  0.24820E-03  0.73779E-03  0.20546E-02
+  0.42801E-02  0.86695E-02  0.18522E-01  0.39269E-01  0.79281E-01  0.16592E+00
+  0.34219E+00  0.63834E+00  0.11989E+01  0.21974E+01  0.39549E+01  0.68510E+01
+  0.11654E+02  0.18898E+02  0.29972E+02  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.54188E-07  0.40426E-05  0.19337E-04  0.74353E-04  0.25660E-03
+  0.78524E-03  0.23114E-02  0.63855E-02  0.13243E-01  0.26725E-01  0.56842E-01
+  0.12008E+00  0.24150E+00  0.50284E+00  0.10351E+01  0.19282E+01  0.36174E+01
+  0.66237E+01  0.11913E+02  0.20624E+02  0.35067E+02  0.56843E+02  0.90125E+02
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.99015E-07  0.74240E-05
+  0.35327E-04  0.13480E-03  0.46075E-03  0.13951E-02  0.40674E-02  0.11142E-01
+  0.22950E-01  0.46038E-01  0.97371E-01  0.20469E+00  0.41018E+00  0.85269E+00
+  0.17516E+01  0.32569E+01  0.61013E+01  0.11159E+02  0.20052E+02  0.34689E+02
+  0.58947E+02  0.95506E+02  0.15136E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.14169E-06  0.10612E-04  0.49940E-04  0.18805E-03  0.63348E-03
+  0.18903E-02  0.54392E-02  0.14730E-01  0.30040E-01  0.59760E-01  0.12556E+00
+  0.26254E+00  0.52374E+00  0.10845E+01  0.22211E+01  0.41201E+01  0.77037E+01
+  0.14068E+02  0.25247E+02  0.43635E+02  0.74089E+02  0.11996E+03  0.19002E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.18306E-06  0.14600E-04
+  0.69963E-04  0.26448E-03  0.88552E-03  0.26116E-02  0.74236E-02  0.19868E-01
+  0.40083E-01  0.78988E-01  0.16471E+00  0.34222E+00  0.67895E+00  0.13995E+01
+  0.28558E+01  0.52814E+01  0.98516E+01  0.17956E+02  0.32175E+02  0.55537E+02
+  0.94204E+02  0.15240E+03  0.24125E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.23959E-06  0.19237E-04  0.91233E-04  0.33707E-03  0.11050E-02
+  0.31832E-02  0.88623E-02  0.23272E-01  0.46207E-01  0.89824E-01  0.18520E+00
+  0.38116E+00  0.75030E+00  0.15366E+01  0.31197E+01  0.57451E+01  0.10680E+02
+  0.19413E+02  0.34711E+02  0.59809E+02  0.10131E+03  0.16371E+03  0.25891E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.32880E-06  0.26704E-04
+  0.12546E-03  0.45229E-03  0.14486E-02  0.40633E-02  0.11041E-01  0.28349E-01
+  0.55210E-01  0.10554E+00  0.21454E+00  0.43632E+00  0.85034E+00  0.17271E+01
+  0.34834E+01  0.63799E+01  0.11808E+02  0.21386E+02  0.38129E+02  0.65547E+02
+  0.11082E+03  0.17882E+03  0.28248E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.31693E-06  0.31348E-04  0.15452E-03  0.56712E-03  0.18036E-02
+  0.49784E-02  0.13266E-01  0.33384E-01  0.63674E-01  0.11938E+00  0.23856E+00
+  0.47779E+00  0.91833E+00  0.18422E+01  0.36747E+01  0.66992E+01  0.12419E+02
+  0.22481E+02  0.39936E+02  0.68453E+02  0.11546E+03  0.18595E+03  0.29328E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.63847E-06  0.94641E-06  0.52043E-06  0.60874E-06  0.38658E-04
+  0.20106E-03  0.75159E-03  0.23665E-02  0.64079E-02  0.16682E-01  0.40995E-01
+  0.76305E-01  0.13977E+00  0.27350E+00  0.53737E+00  0.10148E+01  0.20036E+01
+  0.39389E+01  0.71369E+01  0.13249E+02  0.23959E+02  0.42360E+02  0.72329E+02
+  0.12162E+03  0.19537E+03  0.30751E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.11532E-03  0.18283E-03
+  0.13356E-03  0.12245E-04  0.22083E-03  0.74359E-03  0.20356E-02  0.51026E-02
+  0.11622E-01  0.26429E-01  0.58459E-01  0.10528E+00  0.18616E+00  0.35041E+00
+  0.66118E+00  0.11999E+01  0.22865E+01  0.42848E+01  0.76114E+01  0.13849E+02
+  0.24707E+02  0.43414E+02  0.73756E+02  0.12352E+03  0.19776E+03  0.31043E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.69676E-03  0.97647E-03  0.91251E-03  0.58593E-03  0.10346E-03
+  0.76167E-03  0.29328E-02  0.76991E-02  0.16860E-01  0.36507E-01  0.76451E-01
+  0.13429E+00  0.23099E+00  0.42445E+00  0.78160E+00  0.13799E+01  0.25423E+01
+  0.46524E+01  0.81206E+01  0.14547E+02  0.25646E+02  0.44725E+02  0.75507E+02
+  0.12580E+03  0.20056E+03  0.31373E+03  0.17614E-04  0.20790E-04  0.24831E-04
+  0.29958E-04  0.44851E-04  0.14310E-03  0.26746E-03  0.28622E-02  0.34968E-02
+  0.36472E-02  0.32368E-02  0.14772E-02  0.88752E-03  0.21468E-02  0.86599E-02
+  0.20754E-01  0.45664E-01  0.94091E-01  0.16372E+00  0.27673E+00  0.49939E+00
+  0.90146E+00  0.15587E+01  0.28188E+01  0.50711E+01  0.87151E+01  0.15409E+02
+  0.26865E+02  0.46414E+02  0.77745E+02  0.12869E+03  0.20404E+03  0.31772E+03
+  0.19158E-03  0.22583E-03  0.26934E-03  0.32451E-03  0.48545E-03  0.15487E-02
+  0.28993E-02  0.81978E-02  0.99147E-02  0.10681E-01  0.10352E-01  0.70249E-02
+  0.65334E-02  0.17687E-02  0.72984E-02  0.23472E-01  0.55908E-01  0.11722E+00
+  0.20405E+00  0.34043E+00  0.60468E+00  0.10700E+01  0.18091E+01  0.32040E+01
+  0.56513E+01  0.95341E+01  0.16592E+02  0.28530E+02  0.48717E+02  0.80789E+02
+  0.13262E+03  0.20879E+03  0.32321E+03  0.91994E-03  0.10832E-02  0.12903E-02
+  0.15525E-02  0.23198E-02  0.73937E-02  0.13837E-01  0.22301E-01  0.26466E-01
+  0.28996E-01  0.29552E-01  0.25768E-01  0.23474E-01  0.13638E-01  0.00000E+00
+  0.22467E-01  0.66173E-01  0.14625E+00  0.25879E+00  0.42939E+00  0.75410E+00
+  0.13100E+01  0.21643E+01  0.37476E+01  0.64649E+01  0.10675E+02  0.18230E+02
+  0.30826E+02  0.51878E+02  0.84961E+02  0.13801E+03  0.21532E+03  0.33081E+03
+  0.32129E-02  0.36712E-02  0.45257E-02  0.65596E-02  0.11251E-01  0.25086E-01
+  0.41505E-01  0.53760E-01  0.62292E-01  0.67759E-01  0.69788E-01  0.67656E-01
+  0.60763E-01  0.41710E-01  0.16736E-01  0.15534E-01  0.77978E-01  0.18903E+00
+  0.34228E+00  0.56599E+00  0.98288E+00  0.16744E+01  0.26981E+01  0.45556E+01
+  0.76611E+01  0.12338E+02  0.20598E+02  0.34127E+02  0.56410E+02  0.90946E+02
+  0.14577E+03  0.22485E+03  0.34215E+03  0.93662E-02  0.10316E-01  0.13160E-01
+  0.22459E-01  0.41414E-01  0.68652E-01  0.96775E-01  0.12032E+00  0.13634E+00
+  0.14525E+00  0.14858E+00  0.14626E+00  0.13646E+00  0.11015E+00  0.57754E-01
+  0.43586E-02  0.84610E-01  0.24584E+00  0.46366E+00  0.76978E+00  0.13277E+01
+  0.22228E+01  0.34951E+01  0.57504E+01  0.94110E+01  0.14744E+02  0.23992E+02
+  0.38814E+02  0.62799E+02  0.99340E+02  0.15663E+03  0.23818E+03  0.35809E+03
+  0.24154E-01  0.26202E-01  0.33020E-01  0.56312E-01  0.97153E-01  0.15578E+00
+  0.21528E+00  0.26292E+00  0.29618E+00  0.31548E+00  0.33014E+00  0.32875E+00
+  0.31227E+00  0.27072E+00  0.19406E+00  0.68867E-01  0.39820E-01  0.28200E+00
+  0.60098E+00  0.10333E+01  0.18056E+01  0.30045E+01  0.46379E+01  0.74655E+01
+  0.11911E+02  0.18149E+02  0.28747E+02  0.45316E+02  0.71571E+02  0.11074E+03
+  0.17123E+03  0.25591E+03  0.37905E+03  0.55365E-01  0.63013E-01  0.81193E-01
+  0.13367E+00  0.21687E+00  0.33313E+00  0.44826E+00  0.54340E+00  0.61521E+00
+  0.65664E+00  0.68568E+00  0.68712E+00  0.66021E+00  0.58641E+00  0.46244E+00
+  0.29013E+00  0.25223E-01  0.29067E+00  0.77513E+00  0.14277E+01  0.25433E+01
+  0.42196E+01  0.64071E+01  0.10100E+02  0.15711E+02  0.23263E+02  0.35805E+02
+  0.54857E+02  0.84313E+02  0.12718E+03  0.19216E+03  0.28129E+03  0.40915E+03
+  0.11444E+00  0.14004E+00  0.19236E+00  0.32773E+00  0.49833E+00  0.71316E+00
+  0.95032E+00  0.11333E+01  0.12816E+01  0.13683E+01  0.14209E+01  0.14305E+01
+  0.14083E+01  0.12876E+01  0.10698E+01  0.78969E+00  0.36023E+00  0.18650E+00
+  0.94993E+00  0.19209E+01  0.35870E+01  0.60151E+01  0.90532E+01  0.14058E+02
+  0.21399E+02  0.30847E+02  0.46167E+02  0.68701E+02  0.10258E+03  0.15046E+03
+  0.22148E+03  0.31648E+03  0.45050E+03  0.22486E+00  0.27508E+00  0.37776E+00
+  0.64338E+00  0.97794E+00  0.13990E+01  0.18634E+01  0.22215E+01  0.25117E+01
+  0.26823E+01  0.27887E+01  0.28146E+01  0.27841E+01  0.25755E+01  0.21988E+01
+  0.17205E+01  0.97825E+00  0.10351E+00  0.11320E+01  0.26638E+01  0.52435E+01
+  0.88987E+01  0.13297E+02  0.20367E+02  0.30378E+02  0.42679E+02  0.62121E+02
+  0.89735E+02  0.12998E+03  0.18496E+03  0.26449E+03  0.36774E+03  0.51054E+03
+  0.41505E+00  0.50766E+00  0.69698E+00  0.11867E+01  0.18032E+01  0.25785E+01
+  0.34329E+01  0.40904E+01  0.46222E+01  0.49337E+01  0.51282E+01  0.51762E+01
+  0.51237E+01  0.47551E+01  0.40948E+01  0.32644E+01  0.19764E+01  0.52299E+00
+  0.15292E+01  0.40215E+01  0.81441E+01  0.13842E+02  0.20463E+02  0.30861E+02
+  0.45091E+02  0.61790E+02  0.87498E+02  0.12268E+03  0.17225E+03  0.23747E+03
+  0.32914E+03  0.44409E+03  0.59946E+03  0.74524E+00  0.91139E+00  0.12510E+01
+  0.21296E+01  0.32350E+01  0.46243E+01  0.61540E+01  0.73289E+01  0.82771E+01
+  0.88293E+01  0.91719E+01  0.92523E+01  0.91541E+01  0.84993E+01  0.73378E+01
+  0.58875E+01  0.36489E+01  0.11850E+01  0.22762E+01  0.64115E+01  0.13147E+02
+  0.22262E+02  0.32544E+02  0.48349E+02  0.69314E+02  0.92853E+02  0.12817E+03
+  0.17471E+03  0.23799E+03  0.31788E+03  0.42669E+03  0.55772E+03  0.73021E+03
+  0.13210E+01  0.16154E+01  0.22170E+01  0.37733E+01  0.57306E+01  0.81893E+01
+  0.10895E+02  0.12969E+02  0.14640E+02  0.15608E+02  0.16202E+02  0.16333E+02
+  0.16146E+02  0.14984E+02  0.12940E+02  0.10402E+02  0.65061E+01  0.22816E+01
+  0.36155E+01  0.10571E+02  0.21758E+02  0.36637E+02  0.53007E+02  0.77707E+02
+  0.10958E+03  0.14392E+03  0.19420E+03  0.25803E+03  0.34173E+03  0.44286E+03
+  0.57595E+03  0.72894E+03  0.92434E+03  0.23417E+01  0.28632E+01  0.39292E+01
+  0.66864E+01  0.10153E+02  0.14506E+02  0.19294E+02  0.22961E+02  0.25910E+02
+  0.27611E+02  0.28651E+02  0.28868E+02  0.28526E+02  0.26470E+02  0.22878E+02
+  0.18434E+02  0.11637E+02  0.43626E+01  0.57521E+01  0.17564E+02  0.36370E+02
+  0.61039E+02  0.87626E+02  0.12713E+03  0.17689E+03  0.22855E+03  0.30253E+03
+  0.39312E+03  0.50774E+03  0.64000E+03  0.80781E+03  0.99071E+03  0.12164E+04
+  0.40998E+01  0.50125E+01  0.68781E+01  0.11703E+02  0.17769E+02  0.25383E+02
+  0.33752E+02  0.40156E+02  0.45297E+02  0.48250E+02  0.50039E+02  0.50384E+02
+  0.49743E+02  0.46107E+02  0.39795E+02  0.32010E+02  0.20163E+02  0.75386E+01
+  0.99062E+01  0.30121E+02  0.62051E+02  0.10348E+03  0.14739E+03  0.21180E+03
+  0.29132E+03  0.37124E+03  0.48344E+03  0.61634E+03  0.77877E+03  0.95764E+03
+  0.11761E+04  0.14003E+04  0.16665E+04  0.72670E+01  0.88844E+01  0.12190E+02
+  0.20741E+02  0.31487E+02  0.44974E+02  0.59797E+02  0.71131E+02  0.80225E+02
+  0.85442E+02  0.88600E+02  0.89203E+02  0.88071E+02  0.81673E+02  0.70595E+02
+  0.56963E+02  0.36234E+02  0.14375E+02  0.15811E+02  0.50584E+02  0.10517E+03
+  0.17538E+03  0.24883E+03  0.35545E+03  0.48494E+03  0.61148E+03  0.78614E+03
+  0.98687E+03  0.12244E+04  0.14741E+04  0.17673E+04  0.20486E+04  0.23679E+04
+  0.12725E+02  0.15556E+02  0.21344E+02  0.36312E+02  0.55122E+02  0.78726E+02
+  0.10466E+03  0.12448E+03  0.14036E+03  0.14945E+03  0.15493E+03  0.15592E+03
+  0.15386E+03  0.14259E+03  0.12315E+03  0.99273E+02  0.63069E+02  0.24982E+02
+  0.27423E+02  0.87519E+02  0.18141E+03  0.30136E+03  0.42554E+03  0.60434E+03
+  0.81858E+03  0.10232E+04  0.13015E+04  0.16130E+04  0.19709E+04  0.23308E+04
+  0.27371E+04  0.30989E+04  0.34890E+04  0.22281E+02  0.27237E+02  0.37369E+02
+  0.63573E+02  0.96498E+02  0.13781E+03  0.18319E+03  0.21785E+03  0.24561E+03
+  0.26147E+03  0.27098E+03  0.27263E+03  0.26894E+03  0.24912E+03  0.21503E+03
+  0.17320E+03  0.10993E+03  0.43493E+02  0.47671E+02  0.15185E+03  0.31402E+03
+  0.52013E+03  0.73179E+03  0.10346E+04  0.13935E+04  0.17298E+04  0.21819E+04
+  0.26766E+04  0.32305E+04  0.37646E+04  0.43450E+04  0.48214E+04  0.53051E+04
+  0.39017E+02  0.47696E+02  0.65437E+02  0.11132E+03  0.16896E+03  0.24128E+03
+  0.32071E+03  0.38136E+03  0.42991E+03  0.45760E+03  0.47416E+03  0.47694E+03
+  0.47034E+03  0.43552E+03  0.37575E+03  0.30248E+03  0.19185E+03  0.75834E+02
+  0.83023E+02  0.26409E+03  0.54513E+03  0.90092E+03  0.12640E+04  0.17808E+04
+  0.23883E+04  0.29488E+04  0.36950E+04  0.44964E+04  0.53739E+04  0.61884E+04
+  0.70421E+04  0.76844E+04  0.82920E+04  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.64197E-08  0.49522E-06
+  0.24409E-05  0.96318E-05  0.33984E-04  0.10597E-03  0.31682E-03  0.88644E-03
+  0.18538E-02  0.37735E-02  0.81290E-02  0.17196E-01  0.34657E-01  0.72645E-01
+  0.15029E+00  0.27994E+00  0.52612E+00  0.96476E+00  0.17371E+01  0.30102E+01
+  0.51220E+01  0.83074E+01  0.13178E+02  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.15907E-07  0.12089E-05  0.58806E-05  0.22943E-04  0.80179E-04
+  0.24799E-03  0.73650E-03  0.20494E-02  0.42668E-02  0.86539E-02  0.18588E-01
+  0.39230E-01  0.78916E-01  0.16516E+00  0.34128E+00  0.63508E+00  0.11927E+01
+  0.21857E+01  0.39337E+01  0.68138E+01  0.11590E+02  0.18794E+02  0.29806E+02
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.53447E-07  0.39970E-05
+  0.19157E-04  0.73781E-04  0.25496E-03  0.78102E-03  0.23010E-02  0.63612E-02
+  0.13200E-01  0.26651E-01  0.56705E-01  0.11982E+00  0.24105E+00  0.50200E+00
+  0.10339E+01  0.19255E+01  0.36126E+01  0.66153E+01  0.11898E+02  0.20600E+02
+  0.35028E+02  0.56781E+02  0.90028E+02  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.92830E-07  0.70578E-05  0.33907E-04  0.13035E-03  0.44805E-03
+  0.13624E-02  0.39852E-02  0.10945E-01  0.22592E-01  0.45386E-01  0.96070E-01
+  0.20226E+00  0.40579E+00  0.84415E+00  0.17348E+01  0.32274E+01  0.60483E+01
+  0.11065E+02  0.19887E+02  0.34410E+02  0.58481E+02  0.94760E+02  0.15020E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.13284E-06  0.10098E-04
+  0.47989E-04  0.18209E-03  0.61697E-03  0.18491E-02  0.53393E-02  0.14499E-01
+  0.29637E-01  0.59056E-01  0.12421E+00  0.26012E+00  0.51953E+00  0.10767E+01
+  0.22064E+01  0.40947E+01  0.76592E+01  0.13991E+02  0.25116E+02  0.43415E+02
+  0.73728E+02  0.11939E+03  0.18914E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.17128E-06  0.13917E-04  0.67412E-04  0.25689E-03  0.86517E-03
+  0.25627E-02  0.73108E-02  0.19622E-01  0.39681E-01  0.78337E-01  0.16356E+00
+  0.34035E+00  0.67608E+00  0.13947E+01  0.28482E+01  0.52698E+01  0.98342E+01
+  0.17930E+02  0.32138E+02  0.55485E+02  0.94131E+02  0.15230E+03  0.24112E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.21640E-06  0.18013E-04
+  0.86971E-04  0.32526E-03  0.10750E-02  0.31138E-02  0.87064E-02  0.22940E-01
+  0.45673E-01  0.88968E-01  0.18371E+00  0.37876E+00  0.74660E+00  0.15305E+01
+  0.31097E+01  0.57301E+01  0.10658E+02  0.19380E+02  0.34661E+02  0.59738E+02
+  0.10121E+03  0.16357E+03  0.25872E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.26250E-06  0.23616E-04  0.11581E-03  0.42847E-03  0.13938E-02
+  0.39455E-02  0.10793E-01  0.27846E-01  0.54430E-01  0.10433E+00  0.21253E+00
+  0.43316E+00  0.84555E+00  0.17195E+01  0.34711E+01  0.63622E+01  0.11782E+02
+  0.21350E+02  0.38078E+02  0.65478E+02  0.11073E+03  0.17870E+03  0.28232E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.76032E-06  0.48954E-04
+  0.20117E-03  0.66157E-03  0.19782E-02  0.52896E-02  0.13811E-01  0.34322E-01
+  0.64948E-01  0.12116E+00  0.24095E+00  0.48132E+00  0.92391E+00  0.18508E+01
+  0.36880E+01  0.67326E+01  0.12445E+02  0.22433E+02  0.39841E+02  0.68285E+02
+  0.11517E+03  0.18550E+03  0.29260E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.54447E-07  0.25441E-04  0.16599E-03  0.67652E-03  0.22171E-02
+  0.61242E-02  0.16148E-01  0.40015E-01  0.74853E-01  0.13757E+00  0.26995E+00
+  0.53198E+00  0.10068E+01  0.19911E+01  0.39198E+01  0.71373E+01  0.13191E+02
+  0.23659E+02  0.41846E+02  0.71471E+02  0.12020E+03  0.19312E+03  0.30399E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.46699E-05  0.43742E-05  0.37050E-05  0.28039E-05  0.63698E-05
+  0.16156E-03  0.84590E-03  0.30385E-02  0.86141E-02  0.22780E-01  0.52857E-01
+  0.96158E-01  0.17157E+00  0.32707E+00  0.62574E+00  0.11491E+01  0.22054E+01
+  0.42120E+01  0.75347E+01  0.13745E+02  0.24469E+02  0.43016E+02  0.73102E+02
+  0.12245E+03  0.19607E+03  0.30779E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.24428E-04  0.23356E-04
+  0.20962E-04  0.16076E-04  0.39513E-04  0.12214E-03  0.10699E-02  0.43692E-02
+  0.12825E-01  0.34102E-01  0.73956E-01  0.13056E+00  0.22540E+00  0.41571E+00
+  0.76820E+00  0.13609E+01  0.25175E+01  0.46283E+01  0.80938E+01  0.14517E+02
+  0.25595E+02  0.44640E+02  0.75366E+02  0.12557E+03  0.20018E+03  0.31312E+03
+  0.14261E-06  0.15205E-06  0.16208E-06  0.16995E-06  0.18885E-06  0.21834E-06
+  0.21171E-05  0.12947E-04  0.20864E-03  0.62917E-03  0.13039E-02  0.26273E-03
+  0.42235E-02  0.84440E-02  0.16779E-01  0.32101E-01  0.62469E-01  0.11470E+00
+  0.18970E+00  0.31030E+00  0.54409E+00  0.96244E+00  0.16433E+01  0.29389E+01
+  0.52445E+01  0.89673E+01  0.15782E+02  0.27421E+02  0.47250E+02  0.79008E+02
+  0.13061E+03  0.20698E+03  0.32223E+03  0.75596E-04  0.82479E-04  0.91183E-04
+  0.10213E-03  0.12909E-03  0.18985E-03  0.48888E-03  0.30574E-02  0.55473E-02
+  0.63226E-02  0.57092E-02  0.13755E-02  0.18424E-02  0.25906E-02  0.12745E-01
+  0.31179E-01  0.67906E-01  0.13127E+00  0.22193E+00  0.36359E+00  0.63592E+00
+  0.11130E+01  0.18685E+01  0.32883E+01  0.57722E+01  0.97060E+01  0.16841E+02
+  0.28892E+02  0.49244E+02  0.81555E+02  0.13374E+03  0.21042E+03  0.32559E+03
+  0.26091E-05  0.21836E-05  0.13135E-05  0.59006E-06  0.52513E-05  0.17822E-04
+  0.74404E-04  0.46567E-03  0.14233E-02  0.28876E-02  0.52165E-02  0.47504E-02
+  0.92553E-02  0.24487E-01  0.44893E-01  0.78607E-01  0.14004E+00  0.23791E+00
+  0.36813E+00  0.56283E+00  0.92230E+00  0.15276E+01  0.24507E+01  0.41357E+01
+  0.70008E+01  0.11422E+02  0.19293E+02  0.32358E+02  0.54110E+02  0.88234E+02
+  0.14286E+03  0.22253E+03  0.34164E+03  0.14062E-02  0.15312E-02  0.16889E-02
+  0.18871E-02  0.23800E-02  0.34933E-02  0.71949E-02  0.17383E-01  0.28787E-01
+  0.33328E-01  0.34133E-01  0.24573E-01  0.10895E-01  0.10140E-01  0.14729E-01
+  0.55678E-01  0.13106E+00  0.25373E+00  0.42074E+00  0.66267E+00  0.11071E+01
+  0.18376E+01  0.29129E+01  0.48480E+01  0.80641E+01  0.12888E+02  0.21368E+02
+  0.35208E+02  0.57937E+02  0.93095E+02  0.14882E+03  0.22915E+03  0.34827E+03
+  0.44393E-02  0.47758E-02  0.52369E-02  0.59446E-02  0.81901E-02  0.13117E-01
+  0.24113E-01  0.44283E-01  0.64782E-01  0.75022E-01  0.79663E-01  0.71916E-01
+  0.35923E-01  0.34603E-01  0.48764E-02  0.68497E-01  0.18167E+00  0.36383E+00
+  0.60471E+00  0.94076E+00  0.15440E+01  0.25024E+01  0.38561E+01  0.62331E+01
+  0.10064E+02  0.15617E+02  0.25189E+02  0.40462E+02  0.65081E+02  0.10248E+03
+  0.16099E+03  0.24419E+03  0.36646E+03  0.22271E-01  0.23572E-01  0.25640E-01
+  0.29733E-01  0.45546E-01  0.80934E-01  0.13680E+00  0.21597E+00  0.27036E+00
+  0.31029E+00  0.33352E+00  0.32713E+00  0.28790E+00  0.19332E+00  0.43172E-01
+  0.76873E-01  0.36209E+00  0.78763E+00  0.13360E+01  0.20516E+01  0.32817E+01
+  0.51128E+01  0.74922E+01  0.11463E+02  0.17450E+02  0.25471E+02  0.38688E+02
+  0.58652E+02  0.89362E+02  0.13390E+03  0.20121E+03  0.29346E+03  0.42572E+03
+  0.79237E-01  0.85092E-01  0.92525E-01  0.10207E+00  0.12297E+00  0.20787E+00
+  0.32755E+00  0.51282E+00  0.64576E+00  0.73612E+00  0.79352E+00  0.79658E+00
+  0.74204E+00  0.58382E+00  0.28037E+00  0.26071E-01  0.44240E+00  0.12214E+01
+  0.21748E+01  0.33780E+01  0.54005E+01  0.83063E+01  0.11903E+02  0.17729E+02
+  0.26149E+02  0.36844E+02  0.53946E+02  0.78777E+02  0.11567E+03  0.16727E+03
+  0.24315E+03  0.34401E+03  0.48566E+03  0.20860E+00  0.22703E+00  0.24967E+00
+  0.27621E+00  0.39741E+00  0.53980E+00  0.77298E+00  0.11956E+01  0.15255E+01
+  0.17295E+01  0.18402E+01  0.18896E+01  0.17836E+01  0.15053E+01  0.96875E+00
+  0.11746E+00  0.45444E+00  0.18680E+01  0.35835E+01  0.56895E+01  0.91620E+01
+  0.13999E+02  0.19725E+02  0.28749E+02  0.41264E+02  0.56305E+02  0.79628E+02
+  0.11206E+03  0.15842E+03  0.22057E+03  0.30906E+03  0.42229E+03  0.57733E+03
+  0.52326E+00  0.53835E+00  0.56745E+00  0.63902E+00  0.93742E+00  0.12384E+01
+  0.17292E+01  0.26560E+01  0.34386E+01  0.38521E+01  0.40775E+01  0.42104E+01
+  0.40022E+01  0.34778E+01  0.23942E+01  0.45529E+00  0.32006E+00  0.28876E+01
+  0.60600E+01  0.98711E+01  0.16053E+02  0.24445E+02  0.34005E+02  0.48701E+02
+  0.68320E+02  0.90653E+02  0.12424E+03  0.16891E+03  0.23013E+03  0.30834E+03
+  0.41570E+03  0.54686E+03  0.72108E+03  0.11169E+01  0.11489E+01  0.12109E+01
+  0.13634E+01  0.19999E+01  0.26417E+01  0.36884E+01  0.56657E+01  0.73380E+01
+  0.82278E+01  0.87271E+01  0.90444E+01  0.86522E+01  0.76344E+01  0.54678E+01
+  0.11766E+01  0.20582E+00  0.45318E+01  0.10516E+02  0.17587E+02  0.28907E+02
+  0.43957E+02  0.60568E+02  0.85564E+02  0.11783E+03  0.15274E+03  0.20377E+03
+  0.26864E+03  0.35377E+03  0.45696E+03  0.59295E+03  0.75017E+03  0.95165E+03
+  0.22874E+01  0.23529E+01  0.24795E+01  0.27915E+01  0.40940E+01  0.54071E+01
+  0.75483E+01  0.11593E+02  0.15015E+02  0.16838E+02  0.17870E+02  0.18541E+02
+  0.17777E+02  0.15777E+02  0.11473E+02  0.25790E+01  0.11990E+01  0.77895E+01
+  0.19243E+02  0.32612E+02  0.53791E+02  0.81497E+02  0.11132E+03  0.15542E+03
+  0.21075E+03  0.26798E+03  0.34950E+03  0.44874E+03  0.57353E+03  0.71660E+03
+  0.89702E+03  0.10925E+04  0.13329E+04  0.47611E+01  0.48971E+01  0.51603E+01
+  0.58093E+01  0.85195E+01  0.11252E+02  0.15708E+02  0.24128E+02  0.31258E+02
+  0.35076E+02  0.37275E+02  0.38765E+02  0.37310E+02  0.33406E+02  0.24806E+02
+  0.58841E+01  0.46783E+01  0.12310E+02  0.34418E+02  0.59992E+02  0.10019E+03
+  0.15214E+03  0.20698E+03  0.28695E+03  0.38501E+03  0.48263E+03  0.61856E+03
+  0.77768E+03  0.96971E+03  0.11777E+04  0.14281E+04  0.16798E+04  0.19744E+04
+  0.95600E+01  0.98328E+01  0.10361E+02  0.11663E+02  0.17102E+02  0.22586E+02
+  0.31527E+02  0.48424E+02  0.62729E+02  0.70390E+02  0.74814E+02  0.77836E+02
+  0.74973E+02  0.67274E+02  0.50234E+02  0.12088E+02  0.10685E+02  0.22195E+02
+  0.65183E+02  0.11459E+03  0.19179E+03  0.29064E+03  0.39349E+03  0.54185E+03
+  0.72052E+03  0.89290E+03  0.11285E+04  0.13949E+04  0.17047E+04  0.20222E+04
+  0.23867E+04  0.27228E+04  0.30945E+04  0.19513E+02  0.20070E+02  0.21146E+02
+  0.23804E+02  0.34906E+02  0.46097E+02  0.64349E+02  0.98843E+02  0.12807E+03
+  0.14377E+03  0.15293E+03  0.15933E+03  0.15383E+03  0.13873E+03  0.10479E+03
+  0.25912E+02  0.26959E+02  0.36242E+02  0.12019E+03  0.21621E+03  0.36561E+03
+  0.55564E+03  0.75118E+03  0.10310E+04  0.13633E+04  0.16761E+04  0.20971E+04
+  0.25597E+04  0.30803E+04  0.35867E+04  0.41414E+04  0.46061E+04  0.50853E+04
+  0.39149E+02  0.40264E+02  0.42423E+02  0.47753E+02  0.70023E+02  0.92471E+02
+  0.12908E+03  0.19828E+03  0.25692E+03  0.28846E+03  0.30694E+03  0.31996E+03
+  0.30920E+03  0.27948E+03  0.21220E+03  0.53099E+02  0.58876E+02  0.64039E+02
+  0.22849E+03  0.41597E+03  0.70676E+03  0.10748E+04  0.14505E+04  0.19849E+04
+  0.26131E+04  0.31929E+04  0.39643E+04  0.47926E+04  0.56992E+04  0.65411E+04
+  0.74233E+04  0.80886E+04  0.87194E+04  0.78537E+02  0.80773E+02  0.85103E+02
+  0.95795E+02  0.14047E+03  0.18550E+03  0.25894E+03  0.39777E+03  0.51546E+03
+  0.57883E+03  0.61615E+03  0.64268E+03  0.62170E+03  0.56320E+03  0.42976E+03
+  0.10877E+03  0.12748E+03  0.11195E+03  0.43490E+03  0.80218E+03  0.13705E+04
+  0.20873E+04  0.28149E+04  0.38451E+04  0.50466E+04  0.61400E+04  0.75812E+04
+  0.91007E+04  0.10727E+05  0.12179E+05  0.13639E+05  0.14626E+05  0.15470E+05
+  0.15751E+03  0.16200E+03  0.17068E+03  0.19212E+03  0.28172E+03  0.37203E+03
+  0.51935E+03  0.79782E+03  0.10340E+04  0.11613E+04  0.12367E+04  0.12908E+04
+  0.12499E+04  0.11349E+04  0.87022E+03  0.22261E+03  0.27396E+03  0.19287E+03
+  0.82805E+03  0.15492E+04  0.26632E+04  0.40647E+04  0.54812E+04  0.74806E+04
+  0.97992E+04  0.11886E+05  0.14619E+05  0.17460E+05  0.20449E+05  0.23029E+05
+  0.25535E+05  0.27051E+05  0.28194E+05  0.31584E+03  0.32482E+03  0.34223E+03
+  0.38523E+03  0.56488E+03  0.74599E+03  0.10414E+04  0.15999E+04  0.20738E+04
+  0.23297E+04  0.24819E+04  0.25922E+04  0.25128E+04  0.22865E+04  0.17616E+04
+  0.45521E+03  0.58503E+03  0.32574E+03  0.15764E+04  0.29945E+04  0.51828E+04
+  0.79307E+04  0.10699E+05  0.14599E+05  0.19102E+05  0.23123E+05  0.28363E+05
+  0.33752E+05  0.39346E+05  0.44049E+05  0.48487E+05  0.50900E+05  0.52461E+05
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.88178E-10  0.69307E-08
+  0.34725E-07  0.13697E-06  0.49591E-06  0.15613E-05  0.47050E-05  0.13250E-04
+  0.27855E-04  0.56836E-04  0.12214E-03  0.26019E-03  0.52731E-03  0.11069E-02
+  0.22884E-02  0.42772E-02  0.80458E-02  0.14764E-01  0.26599E-01  0.46113E-01
+  0.78490E-01  0.12734E+00  0.20204E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.49711E-08  0.38650E-06  0.19178E-05  0.75030E-05  0.26974E-04
+  0.84429E-04  0.25322E-03  0.71026E-03  0.14884E-02  0.30292E-02  0.64965E-02
+  0.13816E-01  0.27963E-01  0.58636E-01  0.12112E+00  0.22623E+00  0.42533E+00
+  0.78014E+00  0.14050E+01  0.24351E+01  0.41440E+01  0.67220E+01  0.10664E+02
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.12087E-07  0.92843E-06
+  0.45556E-05  0.17652E-04  0.62937E-04  0.19560E-03  0.58317E-03  0.16279E-02
+  0.33978E-02  0.68931E-02  0.14745E-01  0.31293E-01  0.63229E-01  0.13241E+00
+  0.27322E+00  0.50988E+00  0.95798E+00  0.17562E+01  0.31615E+01  0.54775E+01
+  0.93188E+01  0.15113E+02  0.23970E+02  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.32583E-07  0.24719E-05  0.11981E-04  0.46403E-04  0.16215E-03
+  0.49968E-03  0.14792E-02  0.41052E-02  0.85409E-02  0.17279E-01  0.36842E-01
+  0.77981E-01  0.15712E+00  0.32778E+00  0.67547E+00  0.12592E+01  0.23639E+01
+  0.43305E+01  0.77916E+01  0.13494E+02  0.22949E+02  0.37207E+02  0.59000E+02
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.67548E-07  0.50658E-05
+  0.24243E-04  0.93131E-04  0.32071E-03  0.97857E-03  0.28724E-02  0.79156E-02
+  0.16384E-01  0.33004E-01  0.70069E-01  0.14777E+00  0.29686E+00  0.61791E+00
+  0.12712E+01  0.23666E+01  0.44378E+01  0.81229E+01  0.14605E+02  0.25279E+02
+  0.42974E+02  0.69649E+02  0.11041E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.10798E-06  0.80371E-05  0.38014E-04  0.14431E-03  0.49108E-03
+  0.14816E-02  0.43067E-02  0.11768E-01  0.24190E-01  0.48443E-01  0.10232E+00
+  0.21487E+00  0.43019E+00  0.89361E+00  0.18346E+01  0.34097E+01  0.63853E+01
+  0.11675E+02  0.20974E+02  0.36278E+02  0.61638E+02  0.99853E+02  0.15824E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.14582E-06  0.10865E-04
+  0.50963E-04  0.19142E-03  0.64365E-03  0.19182E-02  0.55140E-02  0.14920E-01
+  0.30408E-01  0.60461E-01  0.12698E+00  0.26542E+00  0.52933E+00  0.10959E+01
+  0.22440E+01  0.41619E+01  0.77811E+01  0.14208E+02  0.25497E+02  0.44064E+02
+  0.74815E+02  0.12113E+03  0.19188E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.19469E-06  0.14806E-04  0.69435E-04  0.25914E-03  0.86203E-03
+  0.25362E-02  0.72018E-02  0.19270E-01  0.38887E-01  0.76668E-01  0.15992E+00
+  0.33238E+00  0.65971E+00  0.13602E+01  0.27766E+01  0.51362E+01  0.95827E+01
+  0.17469E+02  0.31306E+02  0.54045E+02  0.91682E+02  0.14834E+03  0.23483E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.21037E-06  0.17265E-04
+  0.83007E-04  0.31072E-03  0.10287E-02  0.29895E-02  0.83843E-02  0.22157E-01
+  0.44225E-01  0.86349E-01  0.17869E+00  0.36889E+00  0.72797E+00  0.14939E+01
+  0.30380E+01  0.56020E+01  0.10425E+02  0.18966E+02  0.33935E+02  0.58504E+02
+  0.99140E+02  0.16026E+03  0.25353E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.17863E-06  0.18547E-04  0.96002E-04  0.36858E-03  0.12269E-02
+  0.35328E-02  0.97945E-02  0.25552E-01  0.50389E-01  0.97300E-01  0.19951E+00
+  0.40859E+00  0.80070E+00  0.16338E+01  0.33072E+01  0.60746E+01  0.11270E+02
+  0.20450E+02  0.36514E+02  0.62844E+02  0.10635E+03  0.17173E+03  0.27142E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.14996E-04
+  0.99111E-04  0.41617E-03  0.14268E-02  0.41156E-02  0.11338E-01  0.29267E-01
+  0.57012E-01  0.10875E+00  0.22066E+00  0.44759E+00  0.86932E+00  0.17603E+01
+  0.35394E+01  0.64760E+01  0.12003E+02  0.21748E+02  0.38734E+02  0.66528E+02
+  0.11239E+03  0.18123E+03  0.28610E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.54588E-06  0.80783E-06  0.75698E-04  0.42679E-03  0.15915E-02
+  0.46931E-02  0.12965E-01  0.33259E-01  0.64021E-01  0.12048E+00  0.24155E+00
+  0.48428E+00  0.92978E+00  0.18632E+01  0.37107E+01  0.67634E+01  0.12562E+02
+  0.22758E+02  0.40404E+02  0.69213E+02  0.11668E+03  0.18779E+03  0.29601E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.38081E-04  0.69636E-04  0.70395E-04  0.52420E-04  0.79239E-04
+  0.00000E+00  0.44218E-03  0.19125E-02  0.57171E-02  0.15630E-01  0.39360E-01
+  0.74904E-01  0.13877E+00  0.27385E+00  0.53983E+00  0.10185E+01  0.20095E+01
+  0.39321E+01  0.71167E+01  0.13194E+02  0.23841E+02  0.42158E+02  0.71976E+02
+  0.12101E+03  0.19431E+03  0.30568E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.58557E-03  0.10880E-02
+  0.11285E-02  0.88983E-03  0.99308E-03  0.74699E-03  0.20000E-03  0.27945E-02
+  0.85099E-02  0.22103E-01  0.52258E-01  0.98190E-01  0.17780E+00  0.34168E+00
+  0.65275E+00  0.11890E+01  0.22637E+01  0.42427E+01  0.75355E+01  0.13708E+02
+  0.24453E+02  0.43002E+02  0.73073E+02  0.12238E+03  0.19586E+03  0.30729E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.23662E-02  0.34069E-02  0.36771E-02  0.33852E-02  0.24200E-02
+  0.27506E-02  0.14055E-02  0.22857E-02  0.98665E-02  0.27043E-01  0.63216E-01
+  0.11820E+00  0.21072E+00  0.39883E+00  0.74837E+00  0.13343E+01  0.24795E+01
+  0.45626E+01  0.79841E+01  0.14338E+02  0.25318E+02  0.44200E+02  0.74651E+02
+  0.12440E+03  0.19824E+03  0.30991E+03  0.28628E-03  0.33815E-03  0.40434E-03
+  0.48889E-03  0.67198E-03  0.68013E-03  0.89145E-03  0.66753E-02  0.83814E-02
+  0.92501E-02  0.92388E-02  0.56321E-02  0.73411E-02  0.52317E-02  0.00000E+00
+  0.10153E-01  0.32274E-01  0.76881E-01  0.14398E+00  0.25331E+00  0.47187E+00
+  0.86848E+00  0.15162E+01  0.27641E+01  0.49972E+01  0.86040E+01  0.15241E+02
+  0.26599E+02  0.45980E+02  0.77014E+02  0.12746E+03  0.20194E+03  0.31417E+03
+  0.21337E-02  0.25162E-02  0.30029E-02  0.36225E-02  0.49670E-02  0.50131E-02
+  0.65517E-02  0.16741E-01  0.20527E-01  0.22810E-01  0.23504E-01  0.18334E-01
+  0.20740E-01  0.16312E-01  0.89764E-02  0.41858E-02  0.32419E-01  0.88104E-01
+  0.17160E+00  0.30319E+00  0.56234E+00  0.10210E+01  0.17485E+01  0.31292E+01
+  0.55543E+01  0.93938E+01  0.16386E+02  0.28212E+02  0.48206E+02  0.79936E+02
+  0.13119E+03  0.20635E+03  0.31909E+03  0.91724E-02  0.10802E-01  0.12870E-01
+  0.15495E-01  0.21196E-01  0.21335E-01  0.27798E-01  0.41321E-01  0.49268E-01
+  0.54949E-01  0.58049E-01  0.55369E-01  0.54063E-01  0.40913E-01  0.28259E-01
+  0.90174E-02  0.30629E-01  0.10574E+00  0.21744E+00  0.38653E+00  0.71250E+00
+  0.12715E+01  0.21262E+01  0.37158E+01  0.64405E+01  0.10643E+02  0.18187E+02
+  0.30744E+02  0.51704E+02  0.84564E+02  0.13718E+03  0.21364E+03  0.32764E+03
+  0.30749E-01  0.34750E-01  0.40539E-01  0.50377E-01  0.56804E-01  0.57065E-01
+  0.75228E-01  0.96794E-01  0.11230E+00  0.12289E+00  0.12881E+00  0.12985E+00
+  0.12509E+00  0.10359E+00  0.71877E-01  0.40484E-01  0.12907E-01  0.11742E+00
+  0.27193E+00  0.49661E+00  0.92047E+00  0.16237E+01  0.26571E+01  0.45377E+01
+  0.76739E+01  0.12366E+02  0.20654E+02  0.34189E+02  0.56433E+02  0.90793E+02
+  0.14523E+03  0.22343E+03  0.33913E+03  0.83771E-01  0.91924E-01  0.10517E+00
+  0.13213E+00  0.13251E+00  0.13292E+00  0.16801E+00  0.20850E+00  0.23702E+00
+  0.25476E+00  0.26660E+00  0.27011E+00  0.26401E+00  0.23862E+00  0.17550E+00
+  0.93206E-01  0.33690E-01  0.11599E+00  0.33888E+00  0.65031E+00  0.12244E+01
+  0.21445E+01  0.34404E+01  0.57431E+01  0.94670E+01  0.14848E+02  0.24172E+02
+  0.39061E+02  0.63077E+02  0.99505E+02  0.15646E+03  0.23712E+03  0.35533E+03
+  0.20417E+00  0.22074E+00  0.24649E+00  0.29572E+00  0.29628E+00  0.29685E+00
+  0.35081E+00  0.42892E+00  0.48594E+00  0.52111E+00  0.55111E+00  0.55871E+00
+  0.54625E+00  0.50339E+00  0.42055E+00  0.25443E+00  0.89971E-01  0.80406E-01
+  0.42069E+00  0.87791E+00  0.17000E+01  0.29705E+01  0.46803E+01  0.76390E+01
+  0.12259E+02  0.18668E+02  0.29529E+02  0.46400E+02  0.72995E+02  0.11242E+03
+  0.17302E+03  0.25730E+03  0.37930E+03  0.45185E+00  0.54567E+00  0.63286E+00
+  0.63460E+00  0.63530E+00  0.63594E+00  0.74015E+00  0.89325E+00  0.10134E+01
+  0.10861E+01  0.11381E+01  0.11566E+01  0.11356E+01  0.10514E+01  0.90944E+00
+  0.71653E+00  0.33856E+00  0.41063E-01  0.48483E+00  0.12222E+01  0.24757E+01
+  0.43432E+01  0.67396E+01  0.10769E+02  0.16823E+02  0.24833E+02  0.38060E+02
+  0.57940E+02  0.88402E+02  0.13227E+03  0.19827E+03  0.28790E+03  0.41560E+03
+  0.89020E+00  0.10893E+01  0.12736E+01  0.12746E+01  0.12753E+01  0.12758E+01
+  0.14797E+01  0.17661E+01  0.20004E+01  0.21419E+01  0.22357E+01  0.22694E+01
+  0.22633E+01  0.21245E+01  0.18628E+01  0.15280E+01  0.98614E+00  0.37989E+00
+  0.51786E+00  0.16468E+01  0.35813E+01  0.63735E+01  0.98072E+01  0.15429E+02
+  0.23569E+02  0.33843E+02  0.50374E+02  0.74373E+02  0.11005E+03  0.15980E+03
+  0.23290E+03  0.32946E+03  0.46454E+03  0.17380E+01  0.21262E+01  0.24852E+01
+  0.24863E+01  0.24867E+01  0.24863E+01  0.28818E+01  0.34374E+01  0.38906E+01
+  0.41629E+01  0.43435E+01  0.44087E+01  0.43997E+01  0.41437E+01  0.36657E+01
+  0.30617E+01  0.20827E+01  0.10538E+01  0.47799E+00  0.23562E+01  0.55062E+01
+  0.99207E+01  0.15136E+02  0.23451E+02  0.35042E+02  0.48961E+02  0.70733E+02
+  0.10114E+03  0.14478E+03  0.20337E+03  0.28703E+03  0.39380E+03  0.53982E+03
+  0.33691E+01  0.41207E+01  0.48155E+01  0.48163E+01  0.48156E+01  0.48131E+01
+  0.55764E+01  0.66485E+01  0.75217E+01  0.80450E+01  0.83933E+01  0.85216E+01
+  0.85116E+01  0.80421E+01  0.71701E+01  0.60781E+01  0.42993E+01  0.25351E+01
+  0.11843E+00  0.33082E+01  0.85614E+01  0.15744E+02  0.23940E+02  0.36694E+02
+  0.53862E+02  0.73496E+02  0.10336E+03  0.14343E+03  0.19884E+03  0.27013E+03
+  0.36869E+03  0.48947E+03  0.65030E+03  0.64257E+01  0.78583E+01  0.91819E+01
+  0.91816E+01  0.91783E+01  0.91714E+01  0.10623E+02  0.12662E+02  0.14321E+02
+  0.15315E+02  0.15980E+02  0.16233E+02  0.16231E+02  0.15384E+02  0.13812E+02
+  0.11856E+02  0.86454E+01  0.56296E+01  0.10264E+01  0.44238E+01  0.13269E+02
+  0.25125E+02  0.38271E+02  0.58309E+02  0.84463E+02  0.11305E+03  0.15542E+03
+  0.21004E+03  0.28278E+03  0.37221E+03  0.49161E+03  0.63124E+03  0.81163E+03
+  0.13146E+02  0.16075E+02  0.18781E+02  0.18778E+02  0.18770E+02  0.18754E+02
+  0.21720E+02  0.25889E+02  0.29286E+02  0.31333E+02  0.32729E+02  0.33308E+02
+  0.33404E+02  0.31861E+02  0.28959E+02  0.25366E+02  0.19320E+02  0.14139E+02
+  0.58913E+01  0.37540E+01  0.19228E+02  0.39625E+02  0.61686E+02  0.94714E+02
+  0.13663E+03  0.18050E+03  0.24391E+03  0.32239E+03  0.42281E+03  0.54015E+03
+  0.69070E+03  0.85686E+03  0.10636E+04  0.23558E+02  0.28805E+02  0.33651E+02
+  0.33642E+02  0.33621E+02  0.33586E+02  0.38889E+02  0.46337E+02  0.52397E+02
+  0.56031E+02  0.58490E+02  0.59477E+02  0.59589E+02  0.56766E+02  0.51514E+02
+  0.45034E+02  0.34216E+02  0.24964E+02  0.10362E+02  0.65714E+01  0.33462E+02
+  0.68465E+02  0.10565E+03  0.16048E+03  0.22854E+03  0.29731E+03  0.39454E+03
+  0.51065E+03  0.65382E+03  0.81314E+03  0.10096E+04  0.12135E+04  0.14575E+04
+  0.47329E+02  0.57869E+02  0.67600E+02  0.67579E+02  0.67535E+02  0.67463E+02
+  0.78117E+02  0.93086E+02  0.10528E+03  0.11264E+03  0.11770E+03  0.11987E+03
+  0.12039E+03  0.11526E+03  0.10555E+03  0.93607E+02  0.73197E+02  0.57093E+02
+  0.30557E+02  0.00000E+00  0.48174E+02  0.11025E+03  0.17517E+03  0.26979E+03
+  0.38497E+03  0.49766E+03  0.65392E+03  0.83421E+03  0.10485E+04  0.12749E+04
+  0.15420E+04  0.17992E+04  0.20919E+04  0.84960E+02  0.10388E+03  0.12134E+03
+  0.12130E+03  0.12122E+03  0.12110E+03  0.14023E+03  0.16712E+03  0.18907E+03
+  0.20238E+03  0.21166E+03  0.21589E+03  0.21730E+03  0.20892E+03  0.19280E+03
+  0.17300E+03  0.13832E+03  0.11308E+03  0.69463E+02  0.19459E+02  0.59002E+02
+  0.15945E+03  0.26345E+03  0.41381E+03  0.59451E+03  0.76739E+03  0.10038E+04
+  0.12699E+04  0.15774E+04  0.18888E+04  0.22431E+04  0.25610E+04  0.29058E+04
+  0.15206E+03  0.18592E+03  0.21718E+03  0.21710E+03  0.21696E+03  0.21674E+03
+  0.25100E+03  0.29917E+03  0.33854E+03  0.36253E+03  0.37946E+03  0.38753E+03
+  0.39081E+03  0.37710E+03  0.35024E+03  0.31728E+03  0.25817E+03  0.21852E+03
+  0.14645E+03  0.64094E+02  0.64628E+02  0.22856E+03  0.39695E+03  0.63881E+03
+  0.92641E+03  0.11965E+04  0.15615E+04  0.19633E+04  0.24163E+04  0.28569E+04
+  0.33403E+04  0.37420E+04  0.41537E+04  0.28418E-09  0.12097E-08  0.32125E-08
+  0.79130E-08  0.18500E-07  0.33348E-07  0.68730E-07  0.11773E-06  0.21754E-06
+  0.44379E-06  0.10218E-05  0.18475E-05  0.71143E-05  0.35797E-04  0.27341E-03
+  0.48301E-03  0.23427E-02  0.66030E-02  0.13959E-01  0.27104E-01  0.49862E-01
+  0.87046E-01  0.14178E+00  0.22630E+00  0.35397E+00  0.52232E+00  0.78259E+00
+  0.11446E+01  0.16452E+01  0.22783E+01  0.31025E+01  0.40344E+01  0.51426E+01
+  0.40303E-09  0.65617E-09  0.28558E-08  0.80588E-08  0.20631E-07  0.46378E-07
+  0.83107E-07  0.16232E-06  0.30427E-06  0.57889E-06  0.12803E-05  0.20202E-05
+  0.12448E-04  0.61020E-04  0.48430E-03  0.71800E-03  0.29976E-02  0.84230E-02
+  0.17760E-01  0.34412E-01  0.63190E-01  0.11014E+00  0.17916E+00  0.28564E+00
+  0.44631E+00  0.65787E+00  0.98459E+00  0.14384E+01  0.20648E+01  0.28553E+01
+  0.38813E+01  0.50368E+01  0.64041E+01  0.19295E-08  0.10129E-08  0.14973E-08
+  0.72687E-08  0.21287E-07  0.51896E-07  0.11577E-06  0.20724E-06  0.47884E-06
+  0.81965E-06  0.16192E-05  0.39045E-05  0.25583E-04  0.11558E-03  0.76459E-03
+  0.13074E-02  0.38859E-02  0.10781E-01  0.22659E-01  0.43786E-01  0.80227E-01
+  0.13959E+00  0.22671E+00  0.36094E+00  0.56332E+00  0.82939E+00  0.12401E+01
+  0.18096E+01  0.25947E+01  0.35834E+01  0.48639E+01  0.63009E+01  0.79949E+01
+  0.44620E-08  0.46919E-08  0.25389E-08  0.41336E-08  0.19850E-07  0.53938E-07
+  0.12996E-06  0.27609E-06  0.66585E-06  0.14198E-05  0.25796E-05  0.88430E-05
+  0.48645E-04  0.25011E-03  0.11039E-02  0.20908E-02  0.51515E-02  0.13466E-01
+  0.29003E-01  0.55863E-01  0.10208E+00  0.17722E+00  0.28730E+00  0.45671E+00
+  0.71183E+00  0.10468E+01  0.15633E+01  0.22789E+01  0.32642E+01  0.45028E+01
+  0.61040E+01  0.78957E+01  0.10001E+02  0.13072E-07  0.11474E-07  0.12414E-07
+  0.67170E-08  0.11483E-07  0.49236E-07  0.13347E-06  0.32108E-06  0.86355E-06
+  0.21168E-05  0.44928E-05  0.15656E-04  0.83324E-04  0.43922E-03  0.14559E-02
+  0.29943E-02  0.68285E-02  0.15882E-01  0.35675E-01  0.71498E-01  0.13023E+00
+  0.22548E+00  0.36475E+00  0.57877E+00  0.90064E+00  0.13227E+01  0.19731E+01
+  0.28732E+01  0.41108E+01  0.56646E+01  0.76701E+01  0.99089E+01  0.12533E+02
+  0.18612E-07  0.31131E-07  0.29233E-07  0.30619E-07  0.14928E-07  0.28644E-07
+  0.11965E-06  0.32403E-06  0.94489E-06  0.27943E-05  0.73555E-05  0.32298E-04
+  0.13184E-03  0.67390E-03  0.18282E-02  0.37884E-02  0.87249E-02  0.19070E-01
+  0.39879E-01  0.87035E-01  0.16666E+00  0.28763E+00  0.46404E+00  0.73470E+00
+  0.11412E+01  0.16734E+01  0.24929E+01  0.36260E+01  0.51824E+01  0.71331E+01
+  0.96485E+01  0.12450E+02  0.15727E+02  0.36939E-07  0.48803E-07  0.68878E-07
+  0.80832E-07  0.78927E-07  0.45120E-07  0.69849E-07  0.27399E-06  0.87043E-06
+  0.29640E-05  0.10501E-04  0.68872E-04  0.20952E-03  0.87399E-03  0.22055E-02
+  0.46691E-02  0.10271E-01  0.22666E-01  0.45397E-01  0.93627E-01  0.20172E+00
+  0.36805E+00  0.59185E+00  0.93460E+00  0.14486E+01  0.21202E+01  0.31537E+01
+  0.45811E+01  0.65397E+01  0.89917E+01  0.12150E+02  0.15661E+02  0.19759E+02
+  0.76924E-07  0.99048E-07  0.13198E-06  0.16653E-06  0.24598E-06  0.24082E-06
+  0.15058E-06  0.19535E-06  0.68283E-06  0.23892E-05  0.11491E-04  0.93327E-04
+  0.34369E-03  0.10743E-02  0.26276E-02  0.55610E-02  0.11912E-01  0.25608E-01
+  0.51558E-01  0.10222E+00  0.21237E+00  0.44412E+00  0.75709E+00  0.11918E+01
+  0.18423E+01  0.26907E+01  0.39950E+01  0.57942E+01  0.82609E+01  0.11345E+02
+  0.15312E+02  0.19717E+02  0.24850E+02  0.16883E-06  0.22610E-06  0.26696E-06
+  0.35152E-06  0.47530E-06  0.73112E-06  0.78188E-06  0.48766E-06  0.65358E-06
+  0.17882E-05  0.76323E-05  0.97770E-04  0.44748E-03  0.12809E-02  0.30499E-02
+  0.63738E-02  0.13465E-01  0.28582E-01  0.56424E-01  0.11170E+00  0.22610E+00
+  0.46239E+00  0.91135E+00  0.15240E+01  0.23485E+01  0.34210E+01  0.50686E+01
+  0.73384E+01  0.10447E+02  0.14328E+02  0.19316E+02  0.24845E+02  0.31278E+02
+  0.35944E-06  0.45449E-06  0.57624E-06  0.84600E-06  0.14069E-05  0.19466E-05
+  0.37917E-05  0.48615E-05  0.28415E-05  0.35164E-05  0.83884E-05  0.83019E-04
+  0.46660E-03  0.14176E-02  0.34779E-02  0.71694E-02  0.14851E-01  0.31158E-01
+  0.61311E-01  0.11893E+00  0.24141E+00  0.48554E+00  0.94029E+00  0.18334E+01
+  0.30018E+01  0.43588E+01  0.64417E+01  0.93069E+01  0.13226E+02  0.18113E+02
+  0.24387E+02  0.31330E+02  0.39400E+02  0.74234E-06  0.96146E-06  0.12411E-05
+  0.16017E-05  0.40119E-05  0.78501E-05  0.14259E-04  0.26588E-04  0.35746E-04
+  0.20326E-04  0.26706E-04  0.87819E-04  0.42290E-03  0.14589E-02  0.38377E-02
+  0.80222E-02  0.16633E-01  0.33405E-01  0.66059E-01  0.12652E+00  0.25423E+00
+  0.51161E+00  0.97644E+00  0.18901E+01  0.36086E+01  0.55671E+01  0.82030E+01
+  0.11822E+02  0.16765E+02  0.22921E+02  0.30814E+02  0.39533E+02  0.49657E+02
+  0.30292E-05  0.54119E-05  0.85601E-05  0.18883E-04  0.36543E-04  0.64216E-04
+  0.92224E-04  0.12285E-03  0.15066E-03  0.15926E-03  0.82394E-04  0.92142E-04
+  0.44128E-03  0.15048E-02  0.40308E-02  0.87164E-02  0.18433E-01  0.37355E-01
+  0.71290E-01  0.13479E+00  0.26988E+00  0.53426E+00  0.10167E+01  0.19595E+01
+  0.37150E+01  0.66830E+01  0.10465E+02  0.15038E+02  0.21275E+02  0.29027E+02
+  0.38957E+02  0.49901E+02  0.62594E+02  0.23363E-04  0.40239E-04  0.68986E-04
+  0.10690E-03  0.17107E-03  0.26532E-03  0.37577E-03  0.48116E-03  0.55092E-03
+  0.58103E-03  0.50874E-03  0.27018E-03  0.20171E-03  0.16000E-02  0.42767E-02
+  0.92337E-02  0.19841E-01  0.40568E-01  0.77557E-01  0.14533E+00  0.28738E+00
+  0.56146E+00  0.10536E+01  0.20365E+01  0.38453E+01  0.68682E+01  0.12545E+02
+  0.19160E+02  0.27030E+02  0.36790E+02  0.49276E+02  0.63007E+02  0.78905E+02
+  0.84797E-04  0.10820E-03  0.20459E-03  0.37290E-03  0.59462E-03  0.81572E-03
+  0.10610E-02  0.12687E-02  0.14615E-02  0.15888E-02  0.15806E-02  0.13865E-02
+  0.85497E-03  0.51207E-03  0.49452E-02  0.98445E-02  0.20608E-01  0.42984E-01
+  0.82860E-01  0.15389E+00  0.30301E+00  0.59145E+00  0.10955E+01  0.21039E+01
+  0.39855E+01  0.70889E+01  0.12863E+02  0.22920E+02  0.34371E+02  0.46650E+02
+  0.62334E+02  0.79531E+02  0.99409E+02  0.38917E-03  0.49598E-03  0.63425E-03
+  0.93441E-03  0.14033E-02  0.20208E-02  0.25634E-02  0.31009E-02  0.35470E-02
+  0.39000E-02  0.40564E-02  0.40294E-02  0.36330E-02  0.21281E-02  0.12983E-02
+  0.13348E-01  0.20832E-01  0.43853E-01  0.86514E-01  0.16150E+00  0.31874E+00
+  0.62030E+00  0.11411E+01  0.21789E+01  0.41032E+01  0.73196E+01  0.13237E+02
+  0.23436E+02  0.41012E+02  0.59162E+02  0.78835E+02  0.10032E+03  0.12511E+03
+  0.13074E-02  0.16630E-02  0.21212E-02  0.27135E-02  0.34319E-02  0.43371E-02
+  0.55206E-02  0.65415E-02  0.75135E-02  0.82113E-02  0.86076E-02  0.86592E-02
+  0.85945E-02  0.69580E-02  0.29114E-02  0.42237E-02  0.32459E-01  0.45610E-01
+  0.91370E-01  0.17215E+00  0.34095E+00  0.66106E+00  0.12058E+01  0.22852E+01
+  0.42701E+01  0.75570E+01  0.13704E+02  0.24163E+02  0.41994E+02  0.70650E+02
+  0.10004E+03  0.12689E+03  0.15780E+03  0.30698E-02  0.38972E-02  0.49584E-02
+  0.63236E-02  0.80848E-02  0.96276E-02  0.11158E-01  0.13138E-01  0.14780E-01
+  0.16254E-01  0.17027E-01  0.17281E-01  0.16884E-01  0.15501E-01  0.10486E-01
+  0.18901E-02  0.14755E-01  0.78455E-01  0.99557E-01  0.18648E+00  0.37153E+00
+  0.71743E+00  0.12956E+01  0.24323E+01  0.45011E+01  0.78873E+01  0.14187E+02
+  0.25063E+02  0.43359E+02  0.72406E+02  0.11954E+03  0.16105E+03  0.19958E+03
+  0.61716E-02  0.78209E-02  0.99298E-02  0.12631E-01  0.16101E-01  0.20574E-01
+  0.23709E-01  0.26071E-01  0.29048E-01  0.31315E-01  0.32981E-01  0.33521E-01
+  0.33754E-01  0.31536E-01  0.25723E-01  0.15364E-01  0.45002E-02  0.39635E-01
+  0.17532E+00  0.20400E+00  0.40566E+00  0.78470E+00  0.14052E+01  0.26149E+01
+  0.47899E+01  0.83005E+01  0.14791E+02  0.25913E+02  0.44913E+02  0.74631E+02
+  0.12229E+03  0.19201E+03  0.25267E+03  0.10807E-01  0.13675E-01  0.17331E-01
+  0.21998E-01  0.27969E-01  0.35632E-01  0.45486E-01  0.51391E-01  0.54611E-01
+  0.58523E-01  0.61062E-01  0.62500E-01  0.62620E-01  0.60106E-01  0.52259E-01
+  0.39057E-01  0.14227E-01  0.28574E-01  0.10010E+00  0.37720E+00  0.46068E+00
+  0.87599E+00  0.15551E+01  0.28649E+01  0.51850E+01  0.88672E+01  0.15622E+02
+  0.27085E+02  0.46522E+02  0.77393E+02  0.12615E+03  0.19646E+03  0.30122E+03
+  0.17003E-01  0.21487E-01  0.27189E-01  0.34448E-01  0.43702E-01  0.55531E-01
+  0.70672E-01  0.90067E-01  0.10040E+00  0.10423E+00  0.10836E+00  0.11051E+00
+  0.11074E+00  0.10709E+00  0.95959E-01  0.77932E-01  0.45093E-01  0.96793E-02
+  0.98284E-01  0.23608E+00  0.90290E+00  0.10282E+01  0.17682E+01  0.32178E+01
+  0.57394E+01  0.96613E+01  0.16784E+02  0.28730E+02  0.48793E+02  0.80365E+02
+  0.13109E+03  0.20294E+03  0.30854E+03  0.26417E-01  0.33344E-01  0.42137E-01
+  0.53306E-01  0.67509E-01  0.85605E-01  0.10868E+00  0.13812E+00  0.17558E+00
+  0.19369E+00  0.19727E+00  0.20061E+00  0.20071E+00  0.19359E+00  0.17730E+00
+  0.15232E+00  0.10775E+00  0.35789E-01  0.76826E-01  0.24602E+00  0.58376E+00
+  0.20406E+01  0.20355E+01  0.36692E+01  0.64532E+01  0.10682E+02  0.18277E+02
+  0.30836E+02  0.51694E+02  0.84150E+02  0.13588E+03  0.21039E+03  0.31789E+03
+  0.37979E-01  0.47887E-01  0.60442E-01  0.76363E-01  0.96560E-01  0.12222E+00
+  0.15484E+00  0.19631E+00  0.24886E+00  0.31515E+00  0.34432E+00  0.34632E+00
+  0.34665E+00  0.33539E+00  0.30892E+00  0.27124E+00  0.20726E+00  0.10769E+00
+  0.42610E-01  0.26017E+00  0.68583E+00  0.13957E+01  0.24256E+01  0.43202E+01
+  0.74722E+01  0.12132E+02  0.20383E+02  0.33799E+02  0.55776E+02  0.89514E+02
+  0.14277E+03  0.21866E+03  0.33032E+03  0.54373E-01  0.68491E-01  0.86351E-01
+  0.10897E+00  0.13762E+00  0.17394E+00  0.21999E+00  0.27839E+00  0.35219E+00
+  0.44506E+00  0.56031E+00  0.60830E+00  0.60703E+00  0.59312E+00  0.55487E+00
+  0.49827E+00  0.40522E+00  0.26502E+00  0.60332E-01  0.22546E+00  0.77435E+00
+  0.16632E+01  0.29056E+01  0.51486E+01  0.87848E+01  0.13998E+02  0.23090E+02
+  0.37591E+02  0.60971E+02  0.96291E+02  0.15141E+03  0.22892E+03  0.34198E+03
+  0.75437E-01  0.94923E-01  0.11956E+00  0.15071E+00  0.19010E+00  0.23997E+00
+  0.30308E+00  0.38290E+00  0.48353E+00  0.60981E+00  0.76623E+00  0.95855E+00
+  0.10324E+01  0.10069E+01  0.95289E+00  0.86893E+00  0.72820E+00  0.52265E+00
+  0.23211E+00  0.15962E+00  0.89475E+00  0.20487E+01  0.36003E+01  0.63419E+01
+  0.10661E+02  0.16644E+02  0.26898E+02  0.42892E+02  0.68200E+02  0.10572E+03
+  0.16347E+03  0.24343E+03  0.35886E+03  0.11258E+00  0.14150E+00  0.17804E+00
+  0.22421E+00  0.28254E+00  0.35631E+00  0.44952E+00  0.56730E+00  0.71564E+00
+  0.90176E+00  0.11327E+01  0.14174E+01  0.17649E+01  0.18705E+01  0.17874E+01
+  0.16747E+01  0.14738E+01  0.11758E+01  0.76584E+00  0.23028E+00  0.76015E+00
+  0.22725E+01  0.42277E+01  0.76201E+01  0.12813E+02  0.19743E+02  0.31419E+02
+  0.49195E+02  0.76754E+02  0.11671E+03  0.17727E+03  0.25949E+03  0.37664E+03
+  0.16422E+00  0.20616E+00  0.25912E+00  0.32599E+00  0.41043E+00  0.51705E+00
+  0.65173E+00  0.82163E+00  0.10355E+01  0.13036E+01  0.16366E+01  0.20478E+01
+  0.25511E+01  0.31311E+01  0.32584E+01  0.30829E+01  0.28013E+01  0.23695E+01
+  0.17717E+01  0.10131E+01  0.36555E+00  0.24133E+01  0.49601E+01  0.92922E+01
+  0.15725E+02  0.23971E+02  0.37608E+02  0.57810E+02  0.88410E+02  0.13166E+03
+  0.19601E+03  0.28139E+03  0.40121E+03  0.23563E+00  0.29541E+00  0.37084E+00
+  0.46604E+00  0.58616E+00  0.73774E+00  0.92906E+00  0.11702E+01  0.14734E+01
+  0.18536E+01  0.23257E+01  0.29093E+01  0.36247E+01  0.44575E+01  0.53816E+01
+  0.55480E+01  0.51106E+01  0.44923E+01  0.36187E+01  0.25111E+01  0.53608E+00
+  0.23212E+01  0.57466E+01  0.11453E+02  0.19668E+02  0.29763E+02  0.46125E+02
+  0.69650E+02  0.10437E+03  0.15203E+03  0.22148E+03  0.31115E+03  0.43478E+03
+  0.35153E+00  0.43999E+00  0.55160E+00  0.69239E+00  0.86996E+00  0.10940E+01
+  0.13765E+01  0.17324E+01  0.21800E+01  0.27411E+01  0.34392E+01  0.43039E+01
+  0.53680E+01  0.66223E+01  0.80471E+01  0.96697E+01  0.97999E+01  0.88686E+01
+  0.76352E+01  0.60465E+01  0.31889E+01  0.85095E+00  0.55269E+01  0.13176E+02
+  0.23862E+02  0.36424E+02  0.56390E+02  0.84200E+02  0.12410E+03  0.17709E+03
+  0.25248E+03  0.34662E+03  0.47362E+03  0.51361E+00  0.64163E+00  0.80311E+00
+  0.10067E+01  0.12634E+01  0.15871E+01  0.19952E+01  0.25090E+01  0.31553E+01
+  0.39654E+01  0.49741E+01  0.62253E+01  0.77684E+01  0.96030E+01  0.11718E+02
+  0.14168E+02  0.16762E+02  0.16712E+02  0.14841E+02  0.12577E+02  0.83981E+01
+  0.25309E+01  0.40522E+01  0.14622E+02  0.28960E+02  0.45091E+02  0.70207E+02
+  0.10403E+03  0.15109E+03  0.21132E+03  0.29471E+03  0.39488E+03  0.52664E+03
+  0.73938E+00  0.92156E+00  0.11513E+01  0.14408E+01  0.18058E+01  0.22659E+01
+  0.28457E+01  0.35756E+01  0.44932E+01  0.56435E+01  0.70765E+01  0.88560E+01
+  0.11054E+02  0.13683E+02  0.16747E+02  0.20334E+02  0.24239E+02  0.28251E+02
+  0.27696E+02  0.24252E+02  0.18149E+02  0.95221E+01  0.00000E+00  0.15009E+02
+  0.34815E+02  0.56185E+02  0.88755E+02  0.13111E+03  0.18818E+03  0.25828E+03
+  0.35250E+03  0.46063E+03  0.59876E+03  0.10896E+01  0.13542E+01  0.16878E+01
+  0.21083E+01  0.26383E+01  0.33062E+01  0.41476E+01  0.52067E+01  0.65381E+01
+  0.82081E+01  0.10290E+02  0.12880E+02  0.16085E+02  0.19944E+02  0.24492E+02
+  0.29879E+02  0.35898E+02  0.42361E+02  0.48882E+02  0.47675E+02  0.38500E+02
+  0.25931E+02  0.12093E+02  0.95665E+01  0.37442E+02  0.66323E+02  0.10946E+03
+  0.16362E+03  0.23416E+03  0.31700E+03  0.42466E+03  0.54152E+03  0.68552E+03
+  0.16290E+01  0.20178E+01  0.25077E+01  0.31253E+01  0.39036E+01  0.48842E+01
+  0.61194E+01  0.76741E+01  0.96288E+01  0.12081E+02  0.15143E+02  0.18956E+02
+  0.23688E+02  0.29419E+02  0.36246E+02  0.44411E+02  0.53741E+02  0.64104E+02
+  0.75173E+02  0.86635E+02  0.79881E+02  0.61112E+02  0.41161E+02  0.95978E+01
+  0.30371E+02  0.70239E+02  0.12867E+03  0.19950E+03  0.28859E+03  0.38820E+03
+  0.51288E+03  0.63922E+03  0.78796E+03  0.23956E+01  0.29552E+01  0.36604E+01
+  0.45489E+01  0.56687E+01  0.70793E+01  0.88561E+01  0.11092E+02  0.13904E+02
+  0.17432E+02  0.21842E+02  0.27338E+02  0.34168E+02  0.42481E+02  0.52451E+02
+  0.64463E+02  0.78384E+02  0.94180E+02  0.11161E+03  0.13052E+03  0.14351E+03
+  0.12681E+03  0.97011E+02  0.50820E+02  0.76180E+01  0.64282E+02  0.14581E+03
+  0.24140E+03  0.35756E+03  0.48101E+03  0.62936E+03  0.76806E+03  0.92247E+03
+  0.48655E-10  0.60526E-09  0.21435E-08  0.60628E-08  0.11294E-07  0.26653E-07
+  0.44152E-07  0.76346E-07  0.14745E-06  0.32633E-06  0.68926E-06  0.14205E-05
+  0.42778E-05  0.14080E-04  0.17884E-03  0.36260E-03  0.17626E-02  0.49818E-02
+  0.10559E-01  0.20545E-01  0.37862E-01  0.66199E-01  0.10797E+00  0.17256E+00
+  0.27027E+00  0.39931E+00  0.59910E+00  0.87760E+00  0.12636E+01  0.17535E+01
+  0.23936E+01  0.31220E+01  0.39940E+01  0.83987E-09  0.15447E-09  0.13836E-08
+  0.53833E-08  0.15876E-07  0.28322E-07  0.66415E-07  0.10322E-06  0.20043E-06
+  0.42139E-06  0.95665E-06  0.18109E-05  0.66132E-05  0.32097E-04  0.24258E-03
+  0.46260E-03  0.22453E-02  0.63328E-02  0.13396E-01  0.26023E-01  0.47888E-01
+  0.83627E-01  0.13624E+00  0.21752E+00  0.34032E+00  0.50225E+00  0.75267E+00
+  0.11011E+01  0.15830E+01  0.21928E+01  0.29870E+01  0.38858E+01  0.49555E+01
+  0.26006E-08  0.20390E-08  0.40868E-09  0.36606E-08  0.14511E-07  0.40144E-07
+  0.70871E-07  0.14777E-06  0.27557E-06  0.52913E-06  0.12310E-05  0.19676E-05
+  0.10529E-04  0.55958E-04  0.44291E-03  0.63191E-03  0.28697E-02  0.80716E-02
+  0.17032E-01  0.33019E-01  0.60661E-01  0.10578E+00  0.17212E+00  0.27447E+00
+  0.42898E+00  0.63242E+00  0.94671E+00  0.13834E+01  0.19862E+01  0.27473E+01
+  0.37356E+01  0.48493E+01  0.61681E+01  0.69326E-08  0.68114E-08  0.56022E-08
+  0.12975E-08  0.96847E-08  0.35832E-07  0.99129E-07  0.17541E-06  0.40856E-06
+  0.74836E-06  0.14640E-05  0.32452E-05  0.22791E-04  0.95964E-04  0.70775E-03
+  0.11913E-02  0.36948E-02  0.10318E-01  0.21707E-01  0.41980E-01  0.76969E-01
+  0.13399E+00  0.21769E+00  0.34672E+00  0.54127E+00  0.79713E+00  0.11920E+01
+  0.17400E+01  0.24953E+01  0.34469E+01  0.46798E+01  0.60640E+01  0.76969E+01
+  0.12071E-07  0.17332E-07  0.17202E-07  0.13833E-07  0.20594E-08  0.24597E-07
+  0.89383E-07  0.21666E-06  0.55677E-06  0.11721E-05  0.22566E-05  0.74517E-05
+  0.42694E-04  0.22158E-03  0.10463E-02  0.19311E-02  0.48928E-02  0.13082E-01
+  0.27748E-01  0.53501E-01  0.97852E-01  0.16999E+00  0.27573E+00  0.43852E+00
+  0.68371E+00  0.10057E+01  0.15024E+01  0.21907E+01  0.31383E+01  0.43300E+01
+  0.58711E+01  0.75964E+01  0.96246E+01  0.32137E-07  0.30248E-07  0.43672E-07
+  0.42910E-07  0.32939E-07  0.49041E-08  0.61009E-07  0.22133E-06  0.62764E-06
+  0.17539E-05  0.38134E-05  0.14350E-04  0.75542E-04  0.39492E-03  0.13721E-02
+  0.28583E-02  0.64711E-02  0.15358E-01  0.34954E-01  0.68374E-01  0.12469E+00
+  0.21610E+00  0.34980E+00  0.55537E+00  0.86462E+00  0.12703E+01  0.18954E+01
+  0.27609E+01  0.39511E+01  0.54455E+01  0.73752E+01  0.95297E+01  0.12056E+02
+  0.42184E-07  0.78395E-07  0.76044E-07  0.10723E-06  0.10527E-06  0.82165E-07
+  0.12975E-07  0.14772E-06  0.73069E-06  0.19848E-05  0.60318E-05  0.25509E-04
+  0.11442E-03  0.62373E-03  0.17399E-02  0.35893E-02  0.84270E-02  0.18341E-01
+  0.38887E-01  0.85739E-01  0.15931E+00  0.27531E+00  0.44457E+00  0.70442E+00
+  0.10949E+01  0.16061E+01  0.23936E+01  0.34827E+01  0.49787E+01  0.68550E+01
+  0.92741E+01  0.11969E+02  0.15123E+02  0.80674E-07  0.10778E-06  0.16492E-06
+  0.19930E-06  0.24378E-06  0.28098E-06  0.21615E-06  0.41201E-07  0.41379E-06
+  0.23592E-05  0.80145E-05  0.56084E-04  0.18206E-03  0.80784E-03  0.20786E-02
+  0.44370E-02  0.98321E-02  0.22012E-01  0.44000E-01  0.91813E-01  0.19924E+00
+  0.35162E+00  0.56616E+00  0.89502E+00  0.13884E+01  0.20334E+01  0.30260E+01
+  0.43975E+01  0.62796E+01  0.86367E+01  0.11673E+02  0.15049E+02  0.18991E+02
+  0.16335E-06  0.21847E-06  0.30110E-06  0.41480E-06  0.63466E-06  0.71789E-06
+  0.98262E-06  0.69331E-06  0.13077E-06  0.11160E-05  0.81304E-05  0.69777E-04
+  0.28191E-03  0.95788E-03  0.24363E-02  0.52499E-02  0.11386E-01  0.24614E-01
+  0.50192E-01  0.99566E-01  0.20876E+00  0.43888E+00  0.72249E+00  0.11391E+01
+  0.17630E+01  0.25769E+01  0.38290E+01  0.55567E+01  0.79256E+01  0.10889E+02
+  0.14701E+02  0.18933E+02  0.23866E+02  0.36023E-06  0.48111E-06  0.58102E-06
+  0.81507E-06  0.11502E-05  0.19432E-05  0.23361E-05  0.31846E-05  0.20566E-05
+  0.31139E-06  0.37518E-05  0.70583E-04  0.34732E-03  0.10971E-02  0.27463E-02
+  0.59153E-02  0.12749E-01  0.27382E-01  0.54358E-01  0.10885E+00  0.22082E+00
+  0.45477E+00  0.90034E+00  0.14528E+01  0.22428E+01  0.32707E+01  0.48509E+01
+  0.70287E+01  0.10012E+02  0.13738E+02  0.18528E+02  0.23836E+02  0.30015E+02
+  0.74732E-06  0.98866E-06  0.13204E-05  0.17273E-05  0.27780E-05  0.42789E-05
+  0.82845E-05  0.11767E-04  0.13828E-04  0.90693E-05  0.99281E-06  0.38525E-04
+  0.31402E-03  0.11150E-02  0.29738E-02  0.64236E-02  0.13744E-01  0.29477E-01
+  0.58633E-01  0.11460E+00  0.23497E+00  0.47430E+00  0.92408E+00  0.18083E+01
+  0.28575E+01  0.41562E+01  0.61513E+01  0.88971E+01  0.12654E+02  0.17341E+02
+  0.23360E+02  0.30018E+02  0.37755E+02  0.15597E-05  0.20309E-05  0.24447E-05
+  0.31546E-05  0.81803E-05  0.16743E-04  0.28482E-04  0.65028E-04  0.96058E-04
+  0.10758E-03  0.72922E-04  0.14519E-04  0.16143E-03  0.94893E-03  0.29946E-02
+  0.67751E-02  0.14695E-01  0.30710E-01  0.61809E-01  0.12030E+00  0.24431E+00
+  0.49661E+00  0.95201E+00  0.18526E+01  0.35511E+01  0.52869E+01  0.78066E+01
+  0.11269E+02  0.16000E+02  0.21894E+02  0.29453E+02  0.37801E+02  0.47491E+02
+  0.56193E-05  0.93845E-05  0.14403E-04  0.32767E-04  0.61445E-04  0.11160E-03
+  0.16406E-03  0.24682E-03  0.35557E-03  0.46797E-03  0.47435E-03  0.35409E-03
+  0.18007E-03  0.52794E-03  0.25645E-02  0.65888E-02  0.15270E-01  0.32317E-01
+  0.64625E-01  0.12443E+00  0.25426E+00  0.51100E+00  0.98169E+00  0.19025E+01
+  0.36281E+01  0.65517E+01  0.99081E+01  0.14272E+02  0.20227E+02  0.27631E+02
+  0.37118E+02  0.47570E+02  0.59683E+02  0.29745E-04  0.57639E-04  0.99666E-04
+  0.15565E-03  0.29019E-03  0.48864E-03  0.75040E-03  0.99770E-03  0.11988E-02
+  0.13992E-02  0.14968E-02  0.14273E-02  0.12151E-02  0.74962E-03  0.14674E-02
+  0.55333E-02  0.14574E-01  0.32924E-01  0.66296E-01  0.12950E+00  0.26389E+00
+  0.52578E+00  0.10006E+01  0.19558E+01  0.37156E+01  0.66731E+01  0.12249E+02
+  0.18072E+02  0.25562E+02  0.34852E+02  0.46742E+02  0.59804E+02  0.74918E+02
+  0.17372E-03  0.22214E-03  0.41792E-03  0.71119E-03  0.11011E-02  0.14773E-02
+  0.19325E-02  0.23167E-02  0.27363E-02  0.31158E-02  0.33942E-02  0.35549E-02
+  0.34466E-02  0.26775E-02  0.11681E-02  0.37941E-02  0.12955E-01  0.32122E-01
+  0.67638E-01  0.13222E+00  0.27135E+00  0.54457E+00  0.10258E+01  0.19987E+01
+  0.38257E+01  0.68358E+01  0.12481E+02  0.22342E+02  0.32364E+02  0.44022E+02
+  0.58921E+02  0.75233E+02  0.94072E+02  0.46075E-03  0.58752E-03  0.75208E-03
+  0.12390E-02  0.19517E-02  0.28978E-02  0.36696E-02  0.45489E-02  0.53225E-02
+  0.60114E-02  0.65229E-02  0.69462E-02  0.70953E-02  0.63437E-02  0.41506E-02
+  0.13640E-02  0.10946E-01  0.30989E-01  0.68781E-01  0.13665E+00  0.28289E+00
+  0.56779E+00  0.10639E+01  0.20634E+01  0.39293E+01  0.70586E+01  0.12820E+02
+  0.22810E+02  0.40070E+02  0.55784E+02  0.74469E+02  0.94847E+02  0.11833E+03
+  0.17002E-02  0.21641E-02  0.27629E-02  0.35394E-02  0.45634E-02  0.59103E-02
+  0.76883E-02  0.90698E-02  0.10579E-01  0.11749E-01  0.12629E-01  0.13310E-01
+  0.14135E-01  0.13587E-01  0.11024E-01  0.60845E-02  0.14357E-01  0.27148E-01
+  0.67465E-01  0.13930E+00  0.29440E+00  0.59390E+00  0.11085E+01  0.21412E+01
+  0.40555E+01  0.72379E+01  0.13224E+02  0.23399E+02  0.40853E+02  0.68949E+02
+  0.94198E+02  0.11961E+03  0.14882E+03  0.40709E-02  0.51706E-02  0.65839E-02
+  0.84060E-02  0.10765E-01  0.12710E-01  0.14951E-01  0.17885E-01  0.20110E-01
+  0.22458E-01  0.23925E-01  0.24873E-01  0.25529E-01  0.25955E-01  0.22944E-01
+  0.17095E-01  0.43412E-02  0.56921E-01  0.65510E-01  0.14280E+00  0.31079E+00
+  0.63130E+00  0.11727E+01  0.22530E+01  0.42369E+01  0.74989E+01  0.13608E+02
+  0.24196E+02  0.41985E+02  0.70374E+02  0.11652E+03  0.15133E+03  0.18766E+03
+  0.77953E-02  0.98830E-02  0.12555E-01  0.15985E-01  0.20400E-01  0.26113E-01
+  0.29540E-01  0.32931E-01  0.37291E-01  0.40361E-01  0.43293E-01  0.44892E-01
+  0.46662E-01  0.46206E-01  0.43314E-01  0.36421E-01  0.21423E-01  0.68908E-02
+  0.16274E+00  0.14504E+00  0.32939E+00  0.67834E+00  0.12559E+01  0.24000E+01
+  0.44771E+01  0.78466E+01  0.14122E+02  0.24920E+02  0.43436E+02  0.72309E+02
+  0.11888E+03  0.18698E+03  0.23709E+03  0.13873E-01  0.17561E-01  0.22266E-01
+  0.28283E-01  0.35996E-01  0.45921E-01  0.58736E-01  0.64624E-01  0.69345E-01
+  0.75264E-01  0.78969E-01  0.82233E-01  0.84072E-01  0.84801E-01  0.80495E-01
+  0.72103E-01  0.53956E-01  0.20402E-01  0.38283E-01  0.38296E+00  0.34751E+00
+  0.73086E+00  0.13554E+01  0.25823E+01  0.47802E+01  0.82878E+01  0.14778E+02
+  0.25848E+02  0.44697E+02  0.74699E+02  0.12195E+03  0.19033E+03  0.29219E+03
+  0.23117E-01  0.29223E-01  0.36993E-01  0.46900E-01  0.59554E-01  0.75770E-01
+  0.96604E-01  0.12344E+00  0.13356E+00  0.13993E+00  0.14744E+00  0.15213E+00
+  0.15609E+00  0.15757E+00  0.15223E+00  0.14198E+00  0.11978E+00  0.79532E-01
+  0.10796E-01  0.99841E-01  0.95736E+00  0.77919E+00  0.14547E+01  0.27850E+01
+  0.51323E+01  0.88068E+01  0.15557E+02  0.26953E+02  0.46198E+02  0.76561E+02
+  0.12547E+03  0.19430E+03  0.29586E+03  0.38168E-01  0.48196E-01  0.60929E-01
+  0.77124E-01  0.97753E-01  0.12410E+00  0.15782E+00  0.20107E+00  0.25658E+00
+  0.27476E+00  0.28330E+00  0.29318E+00  0.29902E+00  0.29992E+00  0.29444E+00
+  0.28250E+00  0.25543E+00  0.20704E+00  0.12625E+00  0.00000E+00  0.27563E+00
+  0.21707E+01  0.15191E+01  0.29750E+01  0.55025E+01  0.93703E+01  0.16426E+02
+  0.28194E+02  0.47879E+02  0.78609E+02  0.12775E+03  0.19840E+03  0.29961E+03
+  0.58109E-01  0.73297E-01  0.92553E-01  0.11699E+00  0.14805E+00  0.18760E+00
+  0.23804E+00  0.30249E+00  0.38486E+00  0.49010E+00  0.52028E+00  0.53055E+00
+  0.54171E+00  0.54162E+00  0.53049E+00  0.51275E+00  0.47546E+00  0.41143E+00
+  0.30855E+00  0.15417E+00  0.18136E+00  0.76569E+00  0.16253E+01  0.32725E+01
+  0.60719E+01  0.10241E+02  0.17767E+02  0.30130E+02  0.50559E+02  0.82031E+02
+  0.13191E+03  0.20279E+03  0.30687E+03  0.88887E-01  0.11200E+00  0.14126E+00
+  0.17835E+00  0.22540E+00  0.28517E+00  0.36122E+00  0.45810E+00  0.58155E+00
+  0.73878E+00  0.93813E+00  0.99326E+00  0.10099E+01  0.10199E+01  0.10066E+01
+  0.98244E+00  0.93247E+00  0.84907E+00  0.71937E+00  0.53238E+00  0.12236E+00
+  0.57578E+00  0.15627E+01  0.34400E+01  0.65619E+01  0.11066E+02  0.19125E+02
+  0.32138E+02  0.53349E+02  0.85515E+02  0.13596E+03  0.20657E+03  0.30921E+03
+  0.13187E+00  0.16598E+00  0.20913E+00  0.26375E+00  0.33293E+00  0.42067E+00
+  0.53205E+00  0.67358E+00  0.85343E+00  0.10819E+01  0.13708E+01  0.17361E+01
+  0.18327E+01  0.18450E+01  0.18412E+01  0.18086E+01  0.17354E+01  0.16182E+01
+  0.14431E+01  0.12020E+01  0.67608E+00  0.19423E+00  0.13710E+01  0.35832E+01
+  0.71673E+01  0.12152E+02  0.20967E+02  0.34912E+02  0.57266E+02  0.90523E+02
+  0.14201E+03  0.21278E+03  0.31443E+03  0.19978E+00  0.25118E+00  0.31615E+00
+  0.39829E+00  0.50224E+00  0.63390E+00  0.80073E+00  0.10123E+01  0.12807E+01
+  0.16208E+01  0.20504E+01  0.25928E+01  0.32769E+01  0.34326E+01  0.34250E+01
+  0.34098E+01  0.33114E+01  0.31457E+01  0.29072E+01  0.25934E+01  0.19081E+01
+  0.80491E+00  0.61666E+00  0.32645E+01  0.74382E+01  0.13003E+02  0.22736E+02
+  0.37781E+02  0.61446E+02  0.95858E+02  0.14833E+03  0.21880E+03  0.31848E+03
+  0.30511E+00  0.38316E+00  0.48175E+00  0.60631E+00  0.76374E+00  0.96296E+00
+  0.12151E+01  0.15344E+01  0.19387E+01  0.24504E+01  0.30961E+01  0.39106E+01
+  0.49370E+01  0.62010E+01  0.64507E+01  0.64275E+01  0.63460E+01  0.61232E+01
+  0.57912E+01  0.53735E+01  0.44598E+01  0.30289E+01  0.12777E+01  0.19578E+01
+  0.69094E+01  0.13196E+02  0.24081E+02  0.40465E+02  0.65687E+02  0.10136E+03
+  0.15479E+03  0.22442E+03  0.32101E+03  0.46607E+00  0.58449E+00  0.73402E+00
+  0.92283E+00  0.11613E+01  0.14627E+01  0.18439E+01  0.23260E+01  0.29358E+01
+  0.37067E+01  0.46787E+01  0.59038E+01  0.74468E+01  0.93537E+01  0.11683E+02
+  0.12140E+02  0.12018E+02  0.11809E+02  0.11362E+02  0.10788E+02  0.95335E+01
+  0.76240E+01  0.54091E+01  0.13521E+01  0.46616E+01  0.11882E+02  0.24256E+02
+  0.42321E+02  0.69445E+02  0.10653E+03  0.16090E+03  0.22905E+03  0.32121E+03
+  0.70900E+00  0.88778E+00  0.11134E+01  0.13981E+01  0.17576E+01  0.22116E+01
+  0.27852E+01  0.35100E+01  0.44261E+01  0.55829E+01  0.70408E+01  0.88770E+01
+  0.11189E+02  0.14053E+02  0.17569E+02  0.21922E+02  0.22659E+02  0.22342E+02
+  0.21904E+02  0.21137E+02  0.19359E+02  0.16727E+02  0.13832E+02  0.85866E+01
+  0.10732E+01  0.74001E+01  0.21764E+02  0.42004E+02  0.71519E+02  0.11024E+03
+  0.16552E+03  0.23132E+03  0.31733E+03  0.10934E+01  0.13666E+01  0.17111E+01
+  0.21459E+01  0.26945E+01  0.33870E+01  0.42614E+01  0.53656E+01  0.67601E+01
+  0.85201E+01  0.10737E+02  0.13529E+02  0.17042E+02  0.21408E+02  0.26791E+02
+  0.33480E+02  0.41613E+02  0.42906E+02  0.42274E+02  0.41595E+02  0.39144E+02
+  0.35456E+02  0.31609E+02  0.24700E+02  0.15145E+02  0.51108E+01  0.11747E+02
+  0.34547E+02  0.66678E+02  0.10664E+03  0.16186E+03  0.22276E+03  0.29834E+03
+  0.16649E+01  0.20760E+01  0.25946E+01  0.32486E+01  0.40737E+01  0.51148E+01
+  0.64288E+01  0.80870E+01  0.10180E+02  0.12820E+02  0.16144E+02  0.20329E+02
+  0.25594E+02  0.32148E+02  0.40256E+02  0.50348E+02  0.62696E+02  0.77737E+02
+  0.80057E+02  0.79043E+02  0.76187E+02  0.71014E+02  0.65664E+02  0.56197E+02
+  0.43566E+02  0.31253E+02  0.10817E+02  0.15539E+02  0.51185E+02  0.92612E+02
+  0.14744E+03  0.20138E+03  0.26294E+03  0.25778E+01  0.32058E+01  0.39975E+01
+  0.49961E+01  0.62551E+01  0.78434E+01  0.98471E+01  0.12375E+02  0.15564E+02
+  0.19586E+02  0.24649E+02  0.31021E+02  0.39039E+02  0.49038E+02  0.61445E+02
+  0.76921E+02  0.95962E+02  0.11931E+03  0.14790E+03  0.15269E+03  0.14852E+03
+  0.14243E+03  0.13527E+03  0.12210E+03  0.10513E+03  0.89901E+02  0.64873E+02
+  0.34342E+02  0.49332E+01  0.46427E+02  0.98006E+02  0.13869E+03  0.17637E+03
+  0.39706E+01  0.49216E+01  0.61205E+01  0.76318E+01  0.95375E+01  0.11941E+02
+  0.14972E+02  0.18794E+02  0.23614E+02  0.29691E+02  0.37343E+02  0.46971E+02
+  0.59086E+02  0.74215E+02  0.93027E+02  0.11653E+03  0.14556E+03  0.18133E+03
+  0.22537E+03  0.27985E+03  0.28540E+03  0.27641E+03  0.26877E+03  0.25052E+03
+  0.22692E+03  0.20736E+03  0.17565E+03  0.13933E+03  0.95404E+02  0.54817E+02
+  0.92125E+01  0.11113E+02  0.13760E+02  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.15863E-05  0.59904E-05  0.14755E-05  0.37062E-04
+  0.85154E-04  0.16101E-03  0.30122E-03  0.52371E-03  0.96380E-03  0.17806E-02
+  0.33438E-02  0.58029E-02  0.10194E-01  0.17135E-01  0.29773E-01  0.47468E-01
+  0.78375E-01  0.12480E+00  0.20607E+00  0.32537E+00  0.53168E+00  0.83544E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.21723E-05
+  0.93467E-05  0.21259E-05  0.48849E-04  0.10410E-03  0.30454E-03  0.82618E-03
+  0.20047E-02  0.36814E-02  0.64513E-02  0.11382E-01  0.20503E-01  0.38115E-01
+  0.68302E-01  0.12278E+00  0.19569E+00  0.32302E+00  0.51428E+00  0.84897E+00
+  0.13403E+01  0.21900E+01  0.34408E+01  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.29651E-05  0.14027E-04  0.34480E-05  0.88465E-04
+  0.20525E-03  0.62480E-03  0.17303E-02  0.42494E-02  0.79040E-02  0.14086E-01
+  0.25386E-01  0.45087E-01  0.82126E-01  0.14401E+00  0.25594E+00  0.40776E+00
+  0.67283E+00  0.10709E+01  0.17675E+01  0.27901E+01  0.45580E+01  0.71607E+01
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.40417E-05
+  0.21076E-04  0.67799E-05  0.22665E-03  0.60804E-03  0.15153E-02  0.37011E-02
+  0.83508E-02  0.15935E-01  0.29706E-01  0.56392E-01  0.96931E-01  0.16794E+00
+  0.27793E+00  0.47843E+00  0.76185E+00  0.12565E+01  0.19994E+01  0.32990E+01
+  0.52065E+01  0.85041E+01  0.13358E+02  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.61455E-05  0.71659E-04  0.16577E-04  0.58414E-03
+  0.15174E-02  0.32675E-02  0.70663E-02  0.14417E-01  0.26272E-01  0.46807E-01
+  0.84422E-01  0.14601E+00  0.25712E+00  0.43422E+00  0.75653E+00  0.12067E+01
+  0.19948E+01  0.31845E+01  0.52771E+01  0.83754E+01  0.13780E+02  0.21847E+02
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.21228E-04
+  0.18203E-03  0.36115E-04  0.11972E-02  0.26302E-02  0.52574E-02  0.10545E-01
+  0.19984E-01  0.35630E-01  0.62403E-01  0.11033E+00  0.18974E+00  0.33277E+00
+  0.55969E+00  0.97206E+00  0.15473E+01  0.25519E+01  0.40635E+01  0.67128E+01
+  0.10615E+02  0.17386E+02  0.27412E+02  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.55020E-04  0.29374E-03  0.41867E-04  0.17565E-02
+  0.35988E-02  0.69361E-02  0.13362E-01  0.24247E-01  0.43267E-01  0.76529E-01
+  0.13705E+00  0.23194E+00  0.39735E+00  0.65018E+00  0.11123E+01  0.17728E+01
+  0.29297E+01  0.46792E+01  0.77613E+01  0.12340E+02  0.20350E+02  0.32374E+02
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.81615E-06  0.26031E-05  0.68573E-05  0.74260E-04
+  0.39909E-03  0.21865E-04  0.21319E-02  0.42926E-02  0.81839E-02  0.15573E-01
+  0.27897E-01  0.49386E-01  0.86729E-01  0.15413E+00  0.25929E+00  0.44135E+00
+  0.71726E+00  0.12211E+01  0.19421E+01  0.32021E+01  0.51026E+01  0.84416E+01
+  0.13382E+02  0.21990E+02  0.34834E+02  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.16561E-05
+  0.52663E-05  0.14641E-04  0.78718E-04  0.45692E-03  0.58257E-04  0.24705E-02
+  0.49569E-02  0.93511E-02  0.17565E-01  0.31009E-01  0.54255E-01  0.94133E-01
+  0.16499E+00  0.27715E+00  0.47204E+00  0.76884E+00  0.13103E+01  0.20819E+01
+  0.34305E+01  0.54662E+01  0.90452E+01  0.14348E+02  0.23603E+02  0.37449E+02
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.78252E-05  0.23033E-04  0.51150E-04
+  0.47028E-03  0.24555E-03  0.26746E-02  0.53784E-02  0.10099E-01  0.18821E-01
+  0.32895E-01  0.57311E-01  0.99178E-01  0.17340E+00  0.28980E+00  0.49054E+00
+  0.79406E+00  0.13482E+01  0.21404E+01  0.35255E+01  0.56199E+01  0.93077E+01
+  0.14788E+02  0.24378E+02  0.38798E+02  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.30907E-04  0.39568E-03  0.59205E-03  0.26994E-02
+  0.55106E-02  0.10442E-01  0.19534E-01  0.34157E-01  0.59217E-01  0.10186E+00
+  0.17679E+00  0.29502E+00  0.49893E+00  0.80807E+00  0.13717E+01  0.21724E+01
+  0.35698E+01  0.56799E+01  0.93895E+01  0.14889E+02  0.24492E+02  0.38892E+02
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.47903E-04
+  0.19902E-03  0.11038E-02  0.24534E-02  0.52914E-02  0.10260E-01  0.19424E-01
+  0.34114E-01  0.59229E-01  0.10200E+00  0.17707E+00  0.29461E+00  0.49598E+00
+  0.80000E+00  0.13543E+01  0.21396E+01  0.35081E+01  0.55732E+01  0.91999E+01
+  0.14570E+02  0.23933E+02  0.37961E+02  0.00000E+00  0.65068E-08  0.32155E-04
+  0.34278E-04  0.57942E-04  0.63398E-04  0.71661E-04  0.86802E-04  0.11133E-03
+  0.13271E-03  0.17063E-03  0.27463E-03  0.44054E-04  0.14884E-02  0.17295E-02
+  0.45791E-02  0.93883E-02  0.18322E-01  0.32654E-01  0.57108E-01  0.98850E-01
+  0.17207E+00  0.28610E+00  0.48034E+00  0.77309E+00  0.13071E+01  0.20590E+01
+  0.33668E+01  0.53390E+01  0.87978E+01  0.13910E+02  0.22803E+02  0.36105E+02
+  0.12617E-04  0.68242E-04  0.11058E-03  0.11655E-03  0.18383E-03  0.21118E-03
+  0.24674E-03  0.30105E-03  0.36768E-03  0.42835E-03  0.54801E-03  0.87581E-03
+  0.12296E-02  0.30854E-02  0.62835E-03  0.23731E-02  0.62612E-02  0.14173E-01
+  0.27858E-01  0.50313E-01  0.88559E-01  0.15552E+00  0.26042E+00  0.43879E+00
+  0.70878E+00  0.12026E+01  0.18891E+01  0.30810E+01  0.48781E+01  0.80261E+01
+  0.12666E+02  0.20715E+02  0.32730E+02  0.18801E-03  0.24152E-03  0.37459E-03
+  0.41726E-03  0.66857E-03  0.81864E-03  0.93539E-03  0.10390E-02  0.12452E-02
+  0.14862E-02  0.18404E-02  0.23376E-02  0.42966E-02  0.81983E-02  0.25319E-02
+  0.53712E-03  0.26826E-02  0.87197E-02  0.18185E-01  0.35937E-01  0.67735E-01
+  0.12449E+00  0.21319E+00  0.36292E+00  0.58989E+00  0.10098E+01  0.15849E+01
+  0.25836E+01  0.40945E+01  0.67455E+01  0.10651E+02  0.17422E+02  0.27558E+02
+  0.51939E-03  0.63715E-03  0.87279E-03  0.96101E-03  0.15885E-02  0.19665E-02
+  0.22934E-02  0.26177E-02  0.30219E-02  0.37190E-02  0.44707E-02  0.56070E-02
+  0.10328E-01  0.17915E-01  0.11457E-01  0.11080E-01  0.68425E-02  0.00000E+00
+  0.35474E-02  0.12495E-01  0.33488E-01  0.77801E-01  0.14491E+00  0.25740E+00
+  0.43140E+00  0.76128E+00  0.11977E+01  0.19575E+01  0.31148E+01  0.51532E+01
+  0.81520E+01  0.13343E+02  0.21145E+02  0.12110E-02  0.16960E-02  0.22070E-02
+  0.25163E-02  0.41098E-02  0.52666E-02  0.60748E-02  0.66252E-02  0.75168E-02
+  0.88572E-02  0.10555E-01  0.12996E-01  0.23264E-01  0.35451E-01  0.29214E-01
+  0.33098E-01  0.34849E-01  0.34581E-01  0.36063E-01  0.27741E-01  0.65380E-02
+  0.14187E-01  0.47982E-01  0.10507E+00  0.19232E+00  0.37707E+00  0.60962E+00
+  0.10225E+01  0.16710E+01  0.28384E+01  0.45662E+01  0.75745E+01  0.12208E+02
+  0.34218E-02  0.49512E-02  0.65449E-02  0.82522E-02  0.12697E-01  0.14618E-01
+  0.16211E-01  0.17689E-01  0.20031E-01  0.22941E-01  0.26946E-01  0.30069E-01
+  0.48722E-01  0.67204E-01  0.61453E-01  0.71151E-01  0.81799E-01  0.94575E-01
+  0.11659E+00  0.13909E+00  0.16281E+00  0.19424E+00  0.22082E+00  0.25450E+00
+  0.30768E+00  0.27586E+00  0.32711E+00  0.34690E+00  0.27729E+00  0.00000E+00
+  0.12578E+00  0.30085E+00  0.61890E+00  0.76457E-02  0.10801E-01  0.14064E-01
+  0.17805E-01  0.27109E-01  0.30874E-01  0.33932E-01  0.36666E-01  0.40857E-01
+  0.46072E-01  0.53172E-01  0.59176E-01  0.91159E-01  0.11840E+00  0.11484E+00
+  0.13364E+00  0.15689E+00  0.18795E+00  0.23807E+00  0.30163E+00  0.38732E+00
+  0.51455E+00  0.68928E+00  0.95597E+00  0.13782E+01  0.19291E+01  0.29159E+01
+  0.44342E+01  0.67739E+01  0.10380E+02  0.16301E+02  0.25959E+02  0.41432E+02
+  0.16706E-01  0.22775E-01  0.29480E-01  0.37315E-01  0.56106E-01  0.63466E-01
+  0.69340E-01  0.74433E-01  0.81854E-01  0.91043E-01  0.10366E+00  0.11436E+00
+  0.16594E+00  0.20580E+00  0.20512E+00  0.23662E+00  0.27711E+00  0.33277E+00
+  0.42004E+00  0.53677E+00  0.70114E+00  0.94791E+00  0.13044E+01  0.18529E+01
+  0.27161E+01  0.39556E+01  0.60390E+01  0.93009E+01  0.14427E+02  0.22504E+02
+  0.35626E+02  0.56909E+02  0.91175E+02  0.38413E-01  0.49574E-01  0.65196E-01
+  0.81413E-01  0.12042E+00  0.13651E+00  0.14928E+00  0.16015E+00  0.17423E+00
+  0.19145E+00  0.21656E+00  0.23671E+00  0.32114E+00  0.38218E+00  0.38913E+00
+  0.44382E+00  0.51574E+00  0.61567E+00  0.76824E+00  0.97749E+00  0.12769E+01
+  0.17255E+01  0.23848E+01  0.33965E+01  0.49756E+01  0.73236E+01  0.11155E+02
+  0.17178E+02  0.26692E+02  0.41776E+02  0.66141E+02  0.10552E+03  0.16896E+03
+  0.79575E-01  0.10671E+00  0.13935E+00  0.17251E+00  0.25703E+00  0.29220E+00
+  0.31880E+00  0.33969E+00  0.36636E+00  0.39872E+00  0.44546E+00  0.48241E+00
+  0.61894E+00  0.71267E+00  0.73227E+00  0.82298E+00  0.94321E+00  0.11102E+01
+  0.13600E+01  0.17049E+01  0.21987E+01  0.29327E+01  0.40130E+01  0.56582E+01
+  0.82022E+01  0.12025E+02  0.18156E+02  0.27776E+02  0.42961E+02  0.67041E+02
+  0.10576E+03  0.16814E+03  0.26856E+03  0.15958E+00  0.21048E+00  0.28156E+00
+  0.34576E+00  0.51912E+00  0.58608E+00  0.63595E+00  0.67398E+00  0.72690E+00
+  0.78750E+00  0.87241E+00  0.94311E+00  0.11365E+01  0.12760E+01  0.13098E+01
+  0.14478E+01  0.16306E+01  0.18835E+01  0.22563E+01  0.27691E+01  0.34989E+01
+  0.45723E+01  0.61426E+01  0.85105E+01  0.12134E+02  0.17576E+02  0.26195E+02
+  0.39652E+02  0.60813E+02  0.94278E+02  0.14785E+03  0.23388E+03  0.37207E+03
+  0.35277E+00  0.44118E+00  0.58095E+00  0.71091E+00  0.10696E+01  0.11994E+01
+  0.12952E+01  0.13669E+01  0.14643E+01  0.15757E+01  0.17419E+01  0.18699E+01
+  0.21665E+01  0.23799E+01  0.24408E+01  0.26578E+01  0.29449E+01  0.33397E+01
+  0.39130E+01  0.46976E+01  0.58052E+01  0.74148E+01  0.97495E+01  0.13230E+02
+  0.18493E+02  0.26368E+02  0.38679E+02  0.57776E+02  0.87647E+02  0.13469E+03
+  0.20962E+03  0.32945E+03  0.52145E+03  0.87409E+00  0.10478E+01  0.12536E+01
+  0.15765E+01  0.22903E+01  0.24799E+01  0.26340E+01  0.27679E+01  0.29314E+01
+  0.31266E+01  0.33613E+01  0.35765E+01  0.40808E+01  0.44047E+01  0.45032E+01
+  0.48357E+01  0.52740E+01  0.58734E+01  0.67333E+01  0.79014E+01  0.95347E+01
+  0.11879E+02  0.15244E+02  0.20196E+02  0.27593E+02  0.38575E+02  0.55530E+02
+  0.81612E+02  0.12213E+03  0.18557E+03  0.28603E+03  0.44593E+03  0.70125E+03
+  0.20420E+01  0.23639E+01  0.28322E+01  0.33705E+01  0.47701E+01  0.49247E+01
+  0.51124E+01  0.53503E+01  0.56937E+01  0.59943E+01  0.61608E+01  0.64795E+01
+  0.72960E+01  0.77697E+01  0.78993E+01  0.83737E+01  0.89967E+01  0.98446E+01
+  0.11052E+02  0.12679E+02  0.14931E+02  0.18125E+02  0.22657E+02  0.29241E+02
+  0.38949E+02  0.53212E+02  0.74957E+02  0.10808E+03  0.15909E+03  0.23839E+03
+  0.36312E+03  0.56056E+03  0.87443E+03  0.49167E+01  0.60431E+01  0.72525E+01
+  0.84769E+01  0.97080E+01  0.10163E+02  0.10565E+02  0.10953E+02  0.11125E+02
+  0.11251E+02  0.11410E+02  0.11970E+02  0.13335E+02  0.14039E+02  0.14215E+02
+  0.14906E+02  0.15811E+02  0.17038E+02  0.18775E+02  0.21094E+02  0.24276E+02
+  0.28740E+02  0.34998E+02  0.43972E+02  0.57024E+02  0.75983E+02  0.10450E+03
+  0.14746E+03  0.21297E+03  0.31393E+03  0.47150E+03  0.71928E+03  0.11111E+04
+  0.13118E+02  0.14284E+02  0.15459E+02  0.17647E+02  0.19842E+02  0.19913E+02
+  0.19991E+02  0.20094E+02  0.20265E+02  0.20448E+02  0.20677E+02  0.21644E+02
+  0.23900E+02  0.24934E+02  0.25143E+02  0.26122E+02  0.27400E+02  0.29130E+02
+  0.31569E+02  0.34804E+02  0.39203E+02  0.45314E+02  0.53782E+02  0.65776E+02
+  0.82986E+02  0.10767E+03  0.14429E+03  0.19879E+03  0.28096E+03  0.40636E+03
+  0.60030E+03  0.90296E+03  0.13785E+04  0.23637E+02  0.26781E+02  0.29940E+02
+  0.32812E+02  0.35691E+02  0.35793E+02  0.35902E+02  0.36048E+02  0.36295E+02
+  0.36556E+02  0.36882E+02  0.38535E+02  0.42247E+02  0.43752E+02  0.43957E+02
+  0.45314E+02  0.47083E+02  0.49474E+02  0.52847E+02  0.57289E+02  0.63289E+02
+  0.71550E+02  0.82881E+02  0.98739E+02  0.12120E+03  0.15299E+03  0.19952E+03
+  0.26785E+03  0.36962E+03  0.52318E+03  0.75829E+03  0.11219E+04  0.16890E+04
+  0.40984E+02  0.47858E+02  0.54755E+02  0.58273E+02  0.61799E+02  0.61938E+02
+  0.62084E+02  0.62280E+02  0.62628E+02  0.62986E+02  0.63431E+02  0.66165E+02
+  0.72109E+02  0.74256E+02  0.74332E+02  0.76121E+02  0.78451E+02  0.81612E+02
+  0.86095E+02  0.91963E+02  0.99846E+02  0.11063E+03  0.12529E+03  0.14559E+03
+  0.17401E+03  0.21369E+03  0.27100E+03  0.35401E+03  0.47604E+03  0.65791E+03
+  0.93321E+03  0.13547E+04  0.20063E+04  0.69768E+02  0.81455E+02  0.93171E+02
+  0.99127E+02  0.10509E+03  0.10527E+03  0.10546E+03  0.10572E+03  0.10620E+03
+  0.10669E+03  0.10728E+03  0.11175E+03  0.12121E+03  0.12426E+03  0.12399E+03
+  0.12629E+03  0.12927E+03  0.13336E+03  0.13921E+03  0.14683E+03  0.15702E+03
+  0.17093E+03  0.18967E+03  0.21540E+03  0.25103E+03  0.30015E+03  0.37019E+03
+  0.47024E+03  0.61531E+03  0.82871E+03  0.11478E+04  0.16308E+04  0.23700E+04
+  0.11320E+03  0.13214E+03  0.15112E+03  0.16074E+03  0.17036E+03  0.17060E+03
+  0.17082E+03  0.17114E+03  0.17179E+03  0.17241E+03  0.17317E+03  0.18015E+03
+  0.19460E+03  0.19885E+03  0.19776E+03  0.20048E+03  0.20404E+03  0.20897E+03
+  0.21620E+03  0.22556E+03  0.23809E+03  0.25517E+03  0.27805E+03  0.30927E+03
+  0.35212E+03  0.41045E+03  0.49271E+03  0.60864E+03  0.77440E+03  0.10149E+04
+  0.13698E+04  0.19005E+04  0.27036E+04  0.17961E+03  0.20964E+03  0.23972E+03
+  0.25493E+03  0.27011E+03  0.27041E+03  0.27067E+03  0.27105E+03  0.27191E+03
+  0.27269E+03  0.27364E+03  0.28433E+03  0.30612E+03  0.31204E+03  0.30938E+03
+  0.31243E+03  0.31644E+03  0.32213E+03  0.33079E+03  0.34198E+03  0.35699E+03
+  0.37751E+03  0.40491E+03  0.44215E+03  0.49293E+03  0.56125E+03  0.65670E+03
+  0.78947E+03  0.97674E+03  0.12447E+04  0.16348E+04  0.22105E+04  0.30710E+04
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.17614E-04  0.19158E-03  0.91994E-03
+  0.32129E-02  0.93662E-02  0.24154E-01  0.55365E-01  0.11444E+00  0.22486E+00
+  0.41505E+00  0.74524E+00  0.13210E+01  0.23417E+01  0.40998E+01  0.72670E+01
+  0.12725E+02  0.22281E+02  0.39017E+02  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.20790E-04  0.22583E-03  0.10832E-02  0.36712E-02  0.10316E-01  0.26202E-01
+  0.63013E-01  0.14004E+00  0.27508E+00  0.50766E+00  0.91139E+00  0.16154E+01
+  0.28632E+01  0.50125E+01  0.88844E+01  0.15556E+02  0.27237E+02  0.47696E+02
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.24831E-04  0.26934E-03  0.12903E-02
+  0.45257E-02  0.13160E-01  0.33020E-01  0.81193E-01  0.19236E+00  0.37776E+00
+  0.69698E+00  0.12510E+01  0.22170E+01  0.39292E+01  0.68781E+01  0.12190E+02
+  0.21344E+02  0.37369E+02  0.65437E+02  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.29958E-04  0.32451E-03  0.15525E-02  0.65596E-02  0.22459E-01  0.56312E-01
+  0.13367E+00  0.32773E+00  0.64338E+00  0.11867E+01  0.21296E+01  0.37733E+01
+  0.66864E+01  0.11703E+02  0.20741E+02  0.36312E+02  0.63573E+02  0.11132E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.44851E-04  0.48545E-03  0.23198E-02
+  0.11251E-01  0.41414E-01  0.97153E-01  0.21687E+00  0.49833E+00  0.97794E+00
+  0.18032E+01  0.32350E+01  0.57306E+01  0.10153E+02  0.17769E+02  0.31487E+02
+  0.55122E+02  0.96498E+02  0.16896E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.14310E-03  0.15487E-02  0.73937E-02  0.25086E-01  0.68652E-01  0.15578E+00
+  0.33313E+00  0.71316E+00  0.13990E+01  0.25785E+01  0.46243E+01  0.81893E+01
+  0.14506E+02  0.25383E+02  0.44974E+02  0.78726E+02  0.13781E+03  0.24128E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.26746E-03  0.28993E-02  0.13837E-01
+  0.41505E-01  0.96775E-01  0.21528E+00  0.44826E+00  0.95032E+00  0.18634E+01
+  0.34329E+01  0.61540E+01  0.10895E+02  0.19294E+02  0.33752E+02  0.59797E+02
+  0.10466E+03  0.18319E+03  0.32071E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.63847E-06  0.11532E-03  0.69676E-03
+  0.28622E-02  0.81978E-02  0.22301E-01  0.53760E-01  0.12032E+00  0.26292E+00
+  0.54340E+00  0.11333E+01  0.22215E+01  0.40904E+01  0.73289E+01  0.12969E+02
+  0.22961E+02  0.40156E+02  0.71131E+02  0.12448E+03  0.21785E+03  0.38136E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.94641E-06  0.18283E-03  0.97647E-03  0.34968E-02  0.99147E-02  0.26466E-01
+  0.62292E-01  0.13634E+00  0.29618E+00  0.61521E+00  0.12816E+01  0.25117E+01
+  0.46222E+01  0.82771E+01  0.14640E+02  0.25910E+02  0.45297E+02  0.80225E+02
+  0.14036E+03  0.24561E+03  0.42991E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.52043E-06  0.13356E-03  0.91251E-03
+  0.36472E-02  0.10681E-01  0.28996E-01  0.67759E-01  0.14525E+00  0.31548E+00
+  0.65664E+00  0.13683E+01  0.26823E+01  0.49337E+01  0.88293E+01  0.15608E+02
+  0.27611E+02  0.48250E+02  0.85442E+02  0.14945E+03  0.26147E+03  0.45760E+03
+  0.00000E+00  0.00000E+00  0.63259E-11  0.61127E-08  0.15802E-07  0.54188E-07
+  0.99015E-07  0.14169E-06  0.18306E-06  0.23959E-06  0.32880E-06  0.31693E-06
+  0.60874E-06  0.12245E-04  0.58593E-03  0.32368E-02  0.10352E-01  0.29552E-01
+  0.69788E-01  0.14858E+00  0.33014E+00  0.68568E+00  0.14209E+01  0.27887E+01
+  0.51282E+01  0.91719E+01  0.16202E+02  0.28651E+02  0.50039E+02  0.88600E+02
+  0.15493E+03  0.27098E+03  0.47416E+03  0.00000E+00  0.00000E+00  0.49739E-09
+  0.47375E-06  0.12032E-05  0.40426E-05  0.74240E-05  0.10612E-04  0.14600E-04
+  0.19237E-04  0.26704E-04  0.31348E-04  0.38658E-04  0.22083E-03  0.10346E-03
+  0.14772E-02  0.70249E-02  0.25768E-01  0.67656E-01  0.14626E+00  0.32875E+00
+  0.68712E+00  0.14305E+01  0.28146E+01  0.51762E+01  0.92523E+01  0.16333E+02
+  0.28868E+02  0.50384E+02  0.89203E+02  0.15592E+03  0.27263E+03  0.47694E+03
+  0.00000E+00  0.00000E+00  0.24927E-08  0.23446E-05  0.58626E-05  0.19337E-04
+  0.35327E-04  0.49940E-04  0.69963E-04  0.91233E-04  0.12546E-03  0.15452E-03
+  0.20106E-03  0.74359E-03  0.76167E-03  0.88752E-03  0.65334E-02  0.23474E-01
+  0.60763E-01  0.13646E+00  0.31227E+00  0.66021E+00  0.14083E+01  0.27841E+01
+  0.51237E+01  0.91541E+01  0.16146E+02  0.28526E+02  0.49743E+02  0.88071E+02
+  0.15386E+03  0.26894E+03  0.47034E+03  0.00000E+00  0.00000E+00  0.98347E-08
+  0.91534E-05  0.22586E-04  0.74353E-04  0.13480E-03  0.18805E-03  0.26448E-03
+  0.33707E-03  0.45229E-03  0.56712E-03  0.75159E-03  0.20356E-02  0.29328E-02
+  0.21468E-02  0.17687E-02  0.13638E-01  0.41710E-01  0.11015E+00  0.27072E+00
+  0.58641E+00  0.12876E+01  0.25755E+01  0.47551E+01  0.84993E+01  0.14984E+02
+  0.26470E+02  0.46107E+02  0.81673E+02  0.14259E+03  0.24912E+03  0.43552E+03
+  0.00000E+00  0.00000E+00  0.35611E-07  0.32852E-04  0.80158E-04  0.25660E-03
+  0.46075E-03  0.63348E-03  0.88552E-03  0.11050E-02  0.14486E-02  0.18036E-02
+  0.23665E-02  0.51026E-02  0.76991E-02  0.86599E-02  0.72984E-02  0.00000E+00
+  0.16736E-01  0.57754E-01  0.19406E+00  0.46244E+00  0.10698E+01  0.21988E+01
+  0.40948E+01  0.73378E+01  0.12940E+02  0.22878E+02  0.39795E+02  0.70595E+02
+  0.12315E+03  0.21503E+03  0.37575E+03  0.00000E+00  0.00000E+00  0.11213E-06
+  0.10268E-03  0.24820E-03  0.78524E-03  0.13951E-02  0.18903E-02  0.26116E-02
+  0.31832E-02  0.40633E-02  0.49784E-02  0.64079E-02  0.11622E-01  0.16860E-01
+  0.20754E-01  0.23472E-01  0.22467E-01  0.15534E-01  0.43586E-02  0.68867E-01
+  0.29013E+00  0.78969E+00  0.17205E+01  0.32644E+01  0.58875E+01  0.10402E+02
+  0.18434E+02  0.32010E+02  0.56963E+02  0.99273E+02  0.17320E+03  0.30248E+03
+  0.00000E+00  0.00000E+00  0.33795E-06  0.30762E-03  0.73779E-03  0.23114E-02
+  0.40674E-02  0.54392E-02  0.74236E-02  0.88623E-02  0.11041E-01  0.13266E-01
+  0.16682E-01  0.26429E-01  0.36507E-01  0.45664E-01  0.55908E-01  0.66173E-01
+  0.77978E-01  0.84610E-01  0.39820E-01  0.25223E-01  0.36023E+00  0.97825E+00
+  0.19764E+01  0.36489E+01  0.65061E+01  0.11637E+02  0.20163E+02  0.36234E+02
+  0.63069E+02  0.10993E+03  0.19185E+03  0.00000E+00  0.00000E+00  0.95174E-06
+  0.86211E-03  0.20546E-02  0.63855E-02  0.11142E-01  0.14730E-01  0.19868E-01
+  0.23272E-01  0.28349E-01  0.33384E-01  0.40995E-01  0.58459E-01  0.76451E-01
+  0.94091E-01  0.11722E+00  0.14625E+00  0.18903E+00  0.24584E+00  0.28200E+00
+  0.29067E+00  0.18650E+00  0.10351E+00  0.52299E+00  0.11850E+01  0.22816E+01
+  0.43626E+01  0.75386E+01  0.14375E+02  0.24982E+02  0.43493E+02  0.75834E+02
+  0.00000E+00  0.00000E+00  0.20009E-05  0.18053E-02  0.42801E-02  0.13243E-01
+  0.22950E-01  0.30040E-01  0.40083E-01  0.46207E-01  0.55210E-01  0.63674E-01
+  0.76305E-01  0.10528E+00  0.13429E+00  0.16372E+00  0.20405E+00  0.25879E+00
+  0.34228E+00  0.46366E+00  0.60098E+00  0.77513E+00  0.94993E+00  0.11320E+01
+  0.15292E+01  0.22762E+01  0.36155E+01  0.57521E+01  0.99062E+01  0.15811E+02
+  0.27423E+02  0.47671E+02  0.83023E+02  0.00000E+00  0.00000E+00  0.40830E-05
+  0.36720E-02  0.86695E-02  0.26725E-01  0.46038E-01  0.59760E-01  0.78988E-01
+  0.89824E-01  0.10554E+00  0.11938E+00  0.13977E+00  0.18616E+00  0.23099E+00
+  0.27673E+00  0.34043E+00  0.42939E+00  0.56599E+00  0.76978E+00  0.10333E+01
+  0.14277E+01  0.19209E+01  0.26638E+01  0.40215E+01  0.64115E+01  0.10571E+02
+  0.17564E+02  0.30121E+02  0.50584E+02  0.87519E+02  0.15185E+03  0.26409E+03
+  0.00000E+00  0.00000E+00  0.87749E-05  0.78714E-02  0.18522E-01  0.56842E-01
+  0.97371E-01  0.12556E+00  0.16471E+00  0.18520E+00  0.21454E+00  0.23856E+00
+  0.27350E+00  0.35041E+00  0.42445E+00  0.49939E+00  0.60468E+00  0.75410E+00
+  0.98288E+00  0.13277E+01  0.18056E+01  0.25433E+01  0.35870E+01  0.52435E+01
+  0.81441E+01  0.13147E+02  0.21758E+02  0.36370E+02  0.62051E+02  0.10517E+03
+  0.18141E+03  0.31402E+03  0.54513E+03  0.00000E+00  0.00000E+00  0.18693E-04
+  0.16734E-01  0.39269E-01  0.12008E+00  0.20469E+00  0.26254E+00  0.34222E+00
+  0.38116E+00  0.43632E+00  0.47779E+00  0.53737E+00  0.66118E+00  0.78160E+00
+  0.90146E+00  0.10700E+01  0.13100E+01  0.16744E+01  0.22228E+01  0.30045E+01
+  0.42196E+01  0.60151E+01  0.88987E+01  0.13842E+02  0.22262E+02  0.36637E+02
+  0.61039E+02  0.10348E+03  0.17538E+03  0.30136E+03  0.52013E+03  0.90092E+03
+  0.00000E+00  0.00000E+00  0.37885E-04  0.33858E-01  0.79281E-01  0.24150E+00
+  0.41018E+00  0.52374E+00  0.67895E+00  0.75030E+00  0.85034E+00  0.91833E+00
+  0.10148E+01  0.11999E+01  0.13799E+01  0.15587E+01  0.18091E+01  0.21643E+01
+  0.26981E+01  0.34951E+01  0.46379E+01  0.64071E+01  0.90532E+01  0.13297E+02
+  0.20463E+02  0.32544E+02  0.53007E+02  0.87626E+02  0.14739E+03  0.24883E+03
+  0.42554E+03  0.73179E+03  0.12640E+04  0.00000E+00  0.00000E+00  0.79527E-04
+  0.70980E-01  0.16592E+00  0.50284E+00  0.85269E+00  0.10845E+01  0.13995E+01
+  0.15366E+01  0.17271E+01  0.18422E+01  0.20036E+01  0.22865E+01  0.25423E+01
+  0.28188E+01  0.32040E+01  0.37476E+01  0.45556E+01  0.57504E+01  0.74655E+01
+  0.10100E+02  0.14058E+02  0.20367E+02  0.30861E+02  0.48349E+02  0.77707E+02
+  0.12713E+03  0.21180E+03  0.35545E+03  0.60434E+03  0.10346E+04  0.17808E+04
+  0.00000E+00  0.00000E+00  0.16442E-03  0.14659E+00  0.34219E+00  0.10351E+01
+  0.17516E+01  0.22211E+01  0.28558E+01  0.31197E+01  0.34834E+01  0.36747E+01
+  0.39389E+01  0.42848E+01  0.46524E+01  0.50711E+01  0.56513E+01  0.64649E+01
+  0.76611E+01  0.94110E+01  0.11911E+02  0.15711E+02  0.21399E+02  0.30378E+02
+  0.45091E+02  0.69314E+02  0.10958E+03  0.17689E+03  0.29132E+03  0.48494E+03
+  0.81858E+03  0.13935E+04  0.23883E+04  0.00000E+00  0.00000E+00  0.30731E-03
+  0.27377E+00  0.63834E+00  0.19282E+01  0.32569E+01  0.41201E+01  0.52814E+01
+  0.57451E+01  0.63799E+01  0.66992E+01  0.71369E+01  0.76114E+01  0.81206E+01
+  0.87151E+01  0.95341E+01  0.10675E+02  0.12338E+02  0.14744E+02  0.18149E+02
+  0.23263E+02  0.30847E+02  0.42679E+02  0.61790E+02  0.92853E+02  0.14392E+03
+  0.22855E+03  0.37124E+03  0.61148E+03  0.10232E+04  0.17298E+04  0.29488E+04
+  0.00000E+00  0.00000E+00  0.57810E-03  0.51464E+00  0.11989E+01  0.36174E+01
+  0.61013E+01  0.77037E+01  0.98516E+01  0.10680E+02  0.11808E+02  0.12419E+02
+  0.13249E+02  0.13849E+02  0.14547E+02  0.15409E+02  0.16592E+02  0.18230E+02
+  0.20598E+02  0.23992E+02  0.28747E+02  0.35805E+02  0.46167E+02  0.62121E+02
+  0.87498E+02  0.12817E+03  0.19420E+03  0.30253E+03  0.48344E+03  0.78614E+03
+  0.13015E+04  0.21819E+04  0.36950E+04  0.00000E+00  0.00000E+00  0.10608E-02
+  0.94388E+00  0.21974E+01  0.66237E+01  0.11159E+02  0.14068E+02  0.17956E+02
+  0.19413E+02  0.21386E+02  0.22481E+02  0.23959E+02  0.24707E+02  0.25646E+02
+  0.26865E+02  0.28530E+02  0.30826E+02  0.34127E+02  0.38814E+02  0.45316E+02
+  0.54857E+02  0.68701E+02  0.89735E+02  0.12268E+03  0.17471E+03  0.25803E+03
+  0.39312E+03  0.61634E+03  0.98687E+03  0.16130E+04  0.26766E+04  0.44964E+04
+  0.00000E+00  0.00000E+00  0.19112E-02  0.16998E+01  0.39549E+01  0.11913E+02
+  0.20052E+02  0.25247E+02  0.32175E+02  0.34711E+02  0.38129E+02  0.39936E+02
+  0.42360E+02  0.43414E+02  0.44725E+02  0.46414E+02  0.48717E+02  0.51878E+02
+  0.56410E+02  0.62799E+02  0.71571E+02  0.84313E+02  0.10258E+03  0.12998E+03
+  0.17225E+03  0.23799E+03  0.34173E+03  0.50774E+03  0.77877E+03  0.12244E+04
+  0.19709E+04  0.32305E+04  0.53739E+04  0.00000E+00  0.00000E+00  0.33133E-02
+  0.29458E+01  0.68510E+01  0.20624E+02  0.34689E+02  0.43635E+02  0.55537E+02
+  0.59809E+02  0.65547E+02  0.68453E+02  0.72329E+02  0.73756E+02  0.75507E+02
+  0.77745E+02  0.80789E+02  0.84961E+02  0.90946E+02  0.99340E+02  0.11074E+03
+  0.12718E+03  0.15046E+03  0.18496E+03  0.23747E+03  0.31788E+03  0.44286E+03
+  0.64000E+03  0.95764E+03  0.14741E+04  0.23308E+04  0.37646E+04  0.61884E+04
+  0.00000E+00  0.00000E+00  0.56396E-02  0.50128E+01  0.11654E+02  0.35067E+02
+  0.58947E+02  0.74089E+02  0.94204E+02  0.10131E+03  0.11082E+03  0.11546E+03
+  0.12162E+03  0.12352E+03  0.12580E+03  0.12869E+03  0.13262E+03  0.13801E+03
+  0.14577E+03  0.15663E+03  0.17123E+03  0.19216E+03  0.22148E+03  0.26449E+03
+  0.32914E+03  0.42669E+03  0.57595E+03  0.80781E+03  0.11761E+04  0.17673E+04
+  0.27371E+04  0.43450E+04  0.70421E+04  0.00000E+00  0.00000E+00  0.91497E-02
+  0.81311E+01  0.18898E+02  0.56843E+02  0.95506E+02  0.11996E+03  0.15240E+03
+  0.16371E+03  0.17882E+03  0.18595E+03  0.19537E+03  0.19776E+03  0.20056E+03
+  0.20404E+03  0.20879E+03  0.21532E+03  0.22485E+03  0.23818E+03  0.25591E+03
+  0.28129E+03  0.31648E+03  0.36774E+03  0.44409E+03  0.55772E+03  0.72894E+03
+  0.99071E+03  0.14003E+04  0.20486E+04  0.30989E+04  0.48214E+04  0.76844E+04
+  0.00000E+00  0.00000E+00  0.14517E-01  0.12898E+02  0.29972E+02  0.90125E+02
+  0.15136E+03  0.19002E+03  0.24125E+03  0.25891E+03  0.28248E+03  0.29328E+03
+  0.30751E+03  0.31043E+03  0.31373E+03  0.31772E+03  0.32321E+03  0.33081E+03
+  0.34215E+03  0.35809E+03  0.37905E+03  0.40915E+03  0.45050E+03  0.51054E+03
+  0.59946E+03  0.73021E+03  0.92434E+03  0.12164E+04  0.16665E+04  0.23679E+04
+  0.34890E+04  0.53051E+04  0.82920E+04  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.14261E-06  0.75596E-04  0.26091E-05  0.14062E-02  0.44393E-02  0.22271E-01
+  0.79237E-01  0.20860E+00  0.52326E+00  0.11169E+01  0.22874E+01  0.47611E+01
+  0.95600E+01  0.19513E+02  0.39149E+02  0.78537E+02  0.15751E+03  0.31584E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.15205E-06  0.82479E-04  0.21836E-05
+  0.15312E-02  0.47758E-02  0.23572E-01  0.85092E-01  0.22703E+00  0.53835E+00
+  0.11489E+01  0.23529E+01  0.48971E+01  0.98328E+01  0.20070E+02  0.40264E+02
+  0.80773E+02  0.16200E+03  0.32482E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.16208E-06  0.91183E-04  0.13135E-05  0.16889E-02  0.52369E-02  0.25640E-01
+  0.92525E-01  0.24967E+00  0.56745E+00  0.12109E+01  0.24795E+01  0.51603E+01
+  0.10361E+02  0.21146E+02  0.42423E+02  0.85103E+02  0.17068E+03  0.34223E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.16995E-06  0.10213E-03  0.59006E-06
+  0.18871E-02  0.59446E-02  0.29733E-01  0.10207E+00  0.27621E+00  0.63902E+00
+  0.13634E+01  0.27915E+01  0.58093E+01  0.11663E+02  0.23804E+02  0.47753E+02
+  0.95795E+02  0.19212E+03  0.38523E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.18885E-06  0.12909E-03  0.52513E-05  0.23800E-02  0.81901E-02  0.45546E-01
+  0.12297E+00  0.39741E+00  0.93742E+00  0.19999E+01  0.40940E+01  0.85195E+01
+  0.17102E+02  0.34906E+02  0.70023E+02  0.14047E+03  0.28172E+03  0.56488E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.21834E-06  0.18985E-03  0.17822E-04
+  0.34933E-02  0.13117E-01  0.80934E-01  0.20787E+00  0.53980E+00  0.12384E+01
+  0.26417E+01  0.54071E+01  0.11252E+02  0.22586E+02  0.46097E+02  0.92471E+02
+  0.18550E+03  0.37203E+03  0.74599E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.21171E-05  0.48888E-03  0.74404E-04  0.71949E-02  0.24113E-01  0.13680E+00
+  0.32755E+00  0.77298E+00  0.17292E+01  0.36884E+01  0.75483E+01  0.15708E+02
+  0.31527E+02  0.64349E+02  0.12908E+03  0.25894E+03  0.51935E+03  0.10414E+04
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.46699E-05  0.24428E-04  0.12947E-04  0.30574E-02  0.46567E-03
+  0.17383E-01  0.44283E-01  0.21597E+00  0.51282E+00  0.11956E+01  0.26560E+01
+  0.56657E+01  0.11593E+02  0.24128E+02  0.48424E+02  0.98843E+02  0.19828E+03
+  0.39777E+03  0.79782E+03  0.15999E+04  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.43742E-05  0.23356E-04
+  0.20864E-03  0.55473E-02  0.14233E-02  0.28787E-01  0.64782E-01  0.27036E+00
+  0.64576E+00  0.15255E+01  0.34386E+01  0.73380E+01  0.15015E+02  0.31258E+02
+  0.62729E+02  0.12807E+03  0.25692E+03  0.51546E+03  0.10340E+04  0.20738E+04
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.37050E-05  0.20962E-04  0.62917E-03  0.63226E-02  0.28876E-02
+  0.33328E-01  0.75022E-01  0.31029E+00  0.73612E+00  0.17295E+01  0.38521E+01
+  0.82278E+01  0.16838E+02  0.35076E+02  0.70390E+02  0.14377E+03  0.28846E+03
+  0.57883E+03  0.11613E+04  0.23297E+04  0.00000E+00  0.00000E+00  0.00000E+00
+  0.64197E-08  0.15907E-07  0.53447E-07  0.92830E-07  0.13284E-06  0.17128E-06
+  0.21640E-06  0.26250E-06  0.76032E-06  0.54447E-07  0.28039E-05  0.16076E-04
+  0.13039E-02  0.57092E-02  0.52165E-02  0.34133E-01  0.79663E-01  0.33352E+00
+  0.79352E+00  0.18402E+01  0.40775E+01  0.87271E+01  0.17870E+02  0.37275E+02
+  0.74814E+02  0.15293E+03  0.30694E+03  0.61615E+03  0.12367E+04  0.24819E+04
+  0.00000E+00  0.00000E+00  0.00000E+00  0.49522E-06  0.12089E-05  0.39970E-05
+  0.70578E-05  0.10098E-04  0.13917E-04  0.18013E-04  0.23616E-04  0.48954E-04
+  0.25441E-04  0.63698E-05  0.39513E-04  0.26273E-03  0.13755E-02  0.47504E-02
+  0.24573E-01  0.71916E-01  0.32713E+00  0.79658E+00  0.18896E+01  0.42104E+01
+  0.90444E+01  0.18541E+02  0.38765E+02  0.77836E+02  0.15933E+03  0.31996E+03
+  0.64268E+03  0.12908E+04  0.25922E+04  0.00000E+00  0.00000E+00  0.00000E+00
+  0.24409E-05  0.58806E-05  0.19157E-04  0.33907E-04  0.47989E-04  0.67412E-04
+  0.86971E-04  0.11581E-03  0.20117E-03  0.16599E-03  0.16156E-03  0.12214E-03
+  0.42235E-02  0.18424E-02  0.92553E-02  0.10895E-01  0.35923E-01  0.28790E+00
+  0.74204E+00  0.17836E+01  0.40022E+01  0.86522E+01  0.17777E+02  0.37310E+02
+  0.74973E+02  0.15383E+03  0.30920E+03  0.62170E+03  0.12499E+04  0.25128E+04
+  0.00000E+00  0.00000E+00  0.00000E+00  0.96318E-05  0.22943E-04  0.73781E-04
+  0.13035E-03  0.18209E-03  0.25689E-03  0.32526E-03  0.42847E-03  0.66157E-03
+  0.67652E-03  0.84590E-03  0.10699E-02  0.84440E-02  0.25906E-02  0.24487E-01
+  0.10140E-01  0.34603E-01  0.19332E+00  0.58382E+00  0.15053E+01  0.34778E+01
+  0.76344E+01  0.15777E+02  0.33406E+02  0.67274E+02  0.13873E+03  0.27948E+03
+  0.56320E+03  0.11349E+04  0.22865E+04  0.00000E+00  0.00000E+00  0.00000E+00
+  0.33984E-04  0.80179E-04  0.25496E-03  0.44805E-03  0.61697E-03  0.86517E-03
+  0.10750E-02  0.13938E-02  0.19782E-02  0.22171E-02  0.30385E-02  0.43692E-02
+  0.16779E-01  0.12745E-01  0.44893E-01  0.14729E-01  0.48764E-02  0.43172E-01
+  0.28037E+00  0.96875E+00  0.23942E+01  0.54678E+01  0.11473E+02  0.24806E+02
+  0.50234E+02  0.10479E+03  0.21220E+03  0.42976E+03  0.87022E+03  0.17616E+04
+  0.00000E+00  0.00000E+00  0.00000E+00  0.10597E-03  0.24799E-03  0.78102E-03
+  0.13624E-02  0.18491E-02  0.25627E-02  0.31138E-02  0.39455E-02  0.52896E-02
+  0.61242E-02  0.86141E-02  0.12825E-01  0.32101E-01  0.31179E-01  0.78607E-01
+  0.55678E-01  0.68497E-01  0.76873E-01  0.26071E-01  0.11746E+00  0.45529E+00
+  0.11766E+01  0.25790E+01  0.58841E+01  0.12088E+02  0.25912E+02  0.53099E+02
+  0.10877E+03  0.22261E+03  0.45521E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.31682E-03  0.73650E-03  0.23010E-02  0.39852E-02  0.53393E-02  0.73108E-02
+  0.87064E-02  0.10793E-01  0.13811E-01  0.16148E-01  0.22780E-01  0.34102E-01
+  0.62469E-01  0.67906E-01  0.14004E+00  0.13106E+00  0.18167E+00  0.36209E+00
+  0.44240E+00  0.45444E+00  0.32006E+00  0.20582E+00  0.11990E+01  0.46783E+01
+  0.10685E+02  0.26959E+02  0.58876E+02  0.12748E+03  0.27396E+03  0.58503E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.88644E-03  0.20494E-02  0.63612E-02
+  0.10945E-01  0.14499E-01  0.19622E-01  0.22940E-01  0.27846E-01  0.34322E-01
+  0.40015E-01  0.52857E-01  0.73956E-01  0.11470E+00  0.13127E+00  0.23791E+00
+  0.25373E+00  0.36383E+00  0.78763E+00  0.12214E+01  0.18680E+01  0.28876E+01
+  0.45318E+01  0.77895E+01  0.12310E+02  0.22195E+02  0.36242E+02  0.64039E+02
+  0.11195E+03  0.19287E+03  0.32574E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.18538E-02  0.42668E-02  0.13200E-01  0.22592E-01  0.29637E-01  0.39681E-01
+  0.45673E-01  0.54430E-01  0.64948E-01  0.74853E-01  0.96158E-01  0.13056E+00
+  0.18970E+00  0.22193E+00  0.36813E+00  0.42074E+00  0.60471E+00  0.13360E+01
+  0.21748E+01  0.35835E+01  0.60600E+01  0.10516E+02  0.19243E+02  0.34418E+02
+  0.65183E+02  0.12019E+03  0.22849E+03  0.43490E+03  0.82805E+03  0.15764E+04
+  0.00000E+00  0.00000E+00  0.00000E+00  0.37735E-02  0.86539E-02  0.26651E-01
+  0.45386E-01  0.59056E-01  0.78337E-01  0.88968E-01  0.10433E+00  0.12116E+00
+  0.13757E+00  0.17157E+00  0.22540E+00  0.31030E+00  0.36359E+00  0.56283E+00
+  0.66267E+00  0.94076E+00  0.20516E+01  0.33780E+01  0.56895E+01  0.98711E+01
+  0.17587E+02  0.32612E+02  0.59992E+02  0.11459E+03  0.21621E+03  0.41597E+03
+  0.80218E+03  0.15492E+04  0.29945E+04  0.00000E+00  0.00000E+00  0.00000E+00
+  0.81290E-02  0.18588E-01  0.56705E-01  0.96070E-01  0.12421E+00  0.16356E+00
+  0.18371E+00  0.21253E+00  0.24095E+00  0.26995E+00  0.32707E+00  0.41571E+00
+  0.54409E+00  0.63592E+00  0.92230E+00  0.11071E+01  0.15440E+01  0.32817E+01
+  0.54005E+01  0.91620E+01  0.16053E+02  0.28907E+02  0.53791E+02  0.10019E+03
+  0.19179E+03  0.36561E+03  0.70676E+03  0.13705E+04  0.26632E+04  0.51828E+04
+  0.00000E+00  0.00000E+00  0.00000E+00  0.17196E-01  0.39230E-01  0.11982E+00
+  0.20226E+00  0.26012E+00  0.34035E+00  0.37876E+00  0.43316E+00  0.48132E+00
+  0.53198E+00  0.62574E+00  0.76820E+00  0.96244E+00  0.11130E+01  0.15276E+01
+  0.18376E+01  0.25024E+01  0.51128E+01  0.83063E+01  0.13999E+02  0.24445E+02
+  0.43957E+02  0.81497E+02  0.15214E+03  0.29064E+03  0.55564E+03  0.10748E+04
+  0.20873E+04  0.40647E+04  0.79307E+04  0.00000E+00  0.00000E+00  0.00000E+00
+  0.34657E-01  0.78916E-01  0.24105E+00  0.40579E+00  0.51953E+00  0.67608E+00
+  0.74660E+00  0.84555E+00  0.92391E+00  0.10068E+01  0.11491E+01  0.13609E+01
+  0.16433E+01  0.18685E+01  0.24507E+01  0.29129E+01  0.38561E+01  0.74922E+01
+  0.11903E+02  0.19725E+02  0.34005E+02  0.60568E+02  0.11132E+03  0.20698E+03
+  0.39349E+03  0.75118E+03  0.14505E+04  0.28149E+04  0.54812E+04  0.10699E+05
+  0.00000E+00  0.00000E+00  0.00000E+00  0.72645E-01  0.16516E+00  0.50200E+00
+  0.84415E+00  0.10767E+01  0.13947E+01  0.15305E+01  0.17195E+01  0.18508E+01
+  0.19911E+01  0.22054E+01  0.25175E+01  0.29389E+01  0.32883E+01  0.41357E+01
+  0.48480E+01  0.62331E+01  0.11463E+02  0.17729E+02  0.28749E+02  0.48701E+02
+  0.85564E+02  0.15542E+03  0.28695E+03  0.54185E+03  0.10310E+04  0.19849E+04
+  0.38451E+04  0.74806E+04  0.14599E+05  0.00000E+00  0.00000E+00  0.00000E+00
+  0.15029E+00  0.34128E+00  0.10339E+01  0.17348E+01  0.22064E+01  0.28482E+01
+  0.31097E+01  0.34711E+01  0.36880E+01  0.39198E+01  0.42120E+01  0.46283E+01
+  0.52445E+01  0.57722E+01  0.70008E+01  0.80641E+01  0.10064E+02  0.17450E+02
+  0.26149E+02  0.41264E+02  0.68320E+02  0.11783E+03  0.21075E+03  0.38501E+03
+  0.72052E+03  0.13633E+04  0.26131E+04  0.50466E+04  0.97992E+04  0.19102E+05
+  0.00000E+00  0.00000E+00  0.00000E+00  0.27994E+00  0.63508E+00  0.19255E+01
+  0.32274E+01  0.40947E+01  0.52698E+01  0.57301E+01  0.63622E+01  0.67326E+01
+  0.71373E+01  0.75347E+01  0.80938E+01  0.89673E+01  0.97060E+01  0.11422E+02
+  0.12888E+02  0.15617E+02  0.25471E+02  0.36844E+02  0.56305E+02  0.90653E+02
+  0.15274E+03  0.26798E+03  0.48263E+03  0.89290E+03  0.16761E+04  0.31929E+04
+  0.61400E+04  0.11886E+05  0.23123E+05  0.00000E+00  0.00000E+00  0.00000E+00
+  0.52612E+00  0.11927E+01  0.36126E+01  0.60483E+01  0.76592E+01  0.98342E+01
+  0.10658E+02  0.11782E+02  0.12445E+02  0.13191E+02  0.13745E+02  0.14517E+02
+  0.15782E+02  0.16841E+02  0.19293E+02  0.21368E+02  0.25189E+02  0.38688E+02
+  0.53946E+02  0.79628E+02  0.12424E+03  0.20377E+03  0.34950E+03  0.61856E+03
+  0.11285E+04  0.20971E+04  0.39643E+04  0.75812E+04  0.14619E+05  0.28363E+05
+  0.00000E+00  0.00000E+00  0.00000E+00  0.96476E+00  0.21857E+01  0.66153E+01
+  0.11065E+02  0.13991E+02  0.17930E+02  0.19380E+02  0.21350E+02  0.22433E+02
+  0.23659E+02  0.24469E+02  0.25595E+02  0.27421E+02  0.28892E+02  0.32358E+02
+  0.35208E+02  0.40462E+02  0.58652E+02  0.78777E+02  0.11206E+03  0.16891E+03
+  0.26864E+03  0.44874E+03  0.77768E+03  0.13949E+04  0.25597E+04  0.47926E+04
+  0.91007E+04  0.17460E+05  0.33752E+05  0.00000E+00  0.00000E+00  0.00000E+00
+  0.17371E+01  0.39337E+01  0.11898E+02  0.19887E+02  0.25116E+02  0.32138E+02
+  0.34661E+02  0.38078E+02  0.39841E+02  0.41846E+02  0.43016E+02  0.44640E+02
+  0.47250E+02  0.49244E+02  0.54110E+02  0.57937E+02  0.65081E+02  0.89362E+02
+  0.11567E+03  0.15842E+03  0.23013E+03  0.35377E+03  0.57353E+03  0.96971E+03
+  0.17047E+04  0.30803E+04  0.56992E+04  0.10727E+05  0.20449E+05  0.39346E+05
+  0.00000E+00  0.00000E+00  0.00000E+00  0.30102E+01  0.68138E+01  0.20600E+02
+  0.34410E+02  0.43415E+02  0.55485E+02  0.59738E+02  0.65478E+02  0.68285E+02
+  0.71471E+02  0.73102E+02  0.75366E+02  0.79008E+02  0.81555E+02  0.88234E+02
+  0.93095E+02  0.10248E+03  0.13390E+03  0.16727E+03  0.22057E+03  0.30834E+03
+  0.45696E+03  0.71660E+03  0.11777E+04  0.20222E+04  0.35867E+04  0.65411E+04
+  0.12179E+05  0.23029E+05  0.44049E+05  0.00000E+00  0.00000E+00  0.00000E+00
+  0.51220E+01  0.11590E+02  0.35028E+02  0.58481E+02  0.73728E+02  0.94131E+02
+  0.10121E+03  0.11073E+03  0.11517E+03  0.12020E+03  0.12245E+03  0.12557E+03
+  0.13061E+03  0.13374E+03  0.14286E+03  0.14882E+03  0.16099E+03  0.20121E+03
+  0.24315E+03  0.30906E+03  0.41570E+03  0.59295E+03  0.89702E+03  0.14281E+04
+  0.23867E+04  0.41414E+04  0.74233E+04  0.13639E+05  0.25535E+05  0.48487E+05
+  0.00000E+00  0.00000E+00  0.00000E+00  0.83074E+01  0.18794E+02  0.56781E+02
+  0.94760E+02  0.11939E+03  0.15230E+03  0.16357E+03  0.17870E+03  0.18550E+03
+  0.19312E+03  0.19607E+03  0.20018E+03  0.20698E+03  0.21042E+03  0.22253E+03
+  0.22915E+03  0.24419E+03  0.29346E+03  0.34401E+03  0.42229E+03  0.54686E+03
+  0.75017E+03  0.10925E+04  0.16798E+04  0.27228E+04  0.46061E+04  0.80886E+04
+  0.14626E+05  0.27051E+05  0.50900E+05  0.00000E+00  0.00000E+00  0.00000E+00
+  0.13178E+02  0.29806E+02  0.90028E+02  0.15020E+03  0.18914E+03  0.24112E+03
+  0.25872E+03  0.28232E+03  0.29260E+03  0.30399E+03  0.30779E+03  0.31312E+03
+  0.32223E+03  0.32559E+03  0.34164E+03  0.34827E+03  0.36646E+03  0.42572E+03
+  0.48566E+03  0.57733E+03  0.72108E+03  0.95165E+03  0.13329E+04  0.19744E+04
+  0.30945E+04  0.50853E+04  0.87194E+04  0.15470E+05  0.28194E+05  0.52461E+05
+  0.16412E-09  0.43496E-09  0.13350E-08  0.26869E-08  0.65809E-08  0.11503E-07
+  0.10655E-06  0.30406E-06  0.30455E-06  0.10004E-05  0.28107E-05  0.71416E-04
+  0.35165E-03  0.81566E-04  0.15109E-02  0.24851E-02  0.39197E-02  0.57452E-02
+  0.78286E-02  0.10812E-01  0.14765E-01  0.20269E-01  0.26833E-01  0.35998E-01
+  0.45939E-01  0.61590E-01  0.77441E-01  0.10102E+00  0.12738E+00  0.16701E+00
+  0.21012E+00  0.27475E+00  0.34731E+00  0.43496E-09  0.34736E-09  0.11903E-08
+  0.33325E-08  0.63873E-08  0.17700E-07  0.16591E-06  0.57577E-06  0.49822E-06
+  0.13647E-05  0.36491E-05  0.10025E-03  0.40401E-03  0.10464E-03  0.19411E-02
+  0.31802E-02  0.50013E-02  0.73106E-02  0.99390E-02  0.13700E-01  0.18678E-01
+  0.25597E-01  0.33841E-01  0.45335E-01  0.57774E-01  0.77336E-01  0.97079E-01
+  0.12638E+00  0.15899E+00  0.20785E+00  0.26062E+00  0.33938E+00  0.42679E+00
+  0.13350E-08  0.11903E-08  0.82713E-09  0.23579E-08  0.88371E-08  0.20360E-07
+  0.39535E-06  0.13208E-05  0.61626E-06  0.16685E-05  0.45429E-05  0.12139E-03
+  0.47147E-03  0.11424E-03  0.25053E-02  0.40852E-02  0.64019E-02  0.93273E-02
+  0.12646E-01  0.17391E-01  0.23665E-01  0.32373E-01  0.42735E-01  0.57166E-01
+  0.72750E-01  0.97241E-01  0.12188E+00  0.15840E+00  0.19887E+00  0.25937E+00
+  0.32427E+00  0.42080E+00  0.52699E+00  0.26869E-08  0.33325E-08  0.23579E-08
+  0.17365E-08  0.61732E-08  0.24757E-07  0.55062E-06  0.26945E-05  0.71906E-06
+  0.19146E-05  0.53618E-05  0.14761E-03  0.56242E-03  0.12492E-03  0.27424E-02
+  0.52742E-02  0.82293E-02  0.11941E-01  0.16136E-01  0.22130E-01  0.30044E-01
+  0.41011E-01  0.54048E-01  0.72181E-01  0.91730E-01  0.12244E+00  0.15324E+00
+  0.19884E+00  0.24921E+00  0.32436E+00  0.40458E+00  0.52346E+00  0.65328E+00
+  0.65809E-08  0.63873E-08  0.88371E-08  0.61732E-08  0.37905E-08  0.15511E-07
+  0.74594E-06  0.42057E-05  0.76195E-06  0.19399E-05  0.59007E-05  0.17377E-03
+  0.63071E-03  0.13836E-03  0.29567E-02  0.57758E-02  0.10630E-01  0.15351E-01
+  0.20659E-01  0.28239E-01  0.38232E-01  0.52056E-01  0.68471E-01  0.91269E-01
+  0.11582E+00  0.15436E+00  0.19293E+00  0.24996E+00  0.31280E+00  0.40641E+00
+  0.50589E+00  0.65295E+00  0.81248E+00  0.11503E-07  0.17700E-07  0.20360E-07
+  0.24757E-07  0.15511E-07  0.82053E-08  0.70356E-06  0.51670E-05  0.69005E-06
+  0.17705E-05  0.60000E-05  0.19924E-03  0.71317E-03  0.14661E-03  0.32399E-02
+  0.61293E-02  0.11698E-01  0.19831E-01  0.26557E-01  0.36153E-01  0.48784E-01
+  0.66219E-01  0.86901E-01  0.11560E+00  0.14643E+00  0.19484E+00  0.24318E+00
+  0.31462E+00  0.39316E+00  0.50999E+00  0.63371E+00  0.81620E+00  0.10132E+01
+  0.10655E-06  0.16591E-06  0.39535E-06  0.55062E-06  0.74594E-06  0.70356E-06
+  0.16352E-06  0.26310E-05  0.51140E-05  0.71370E-05  0.62734E-05  0.21263E-03
+  0.75860E-03  0.10763E-03  0.34191E-02  0.64867E-02  0.12111E-01  0.21858E-01
+  0.33973E-01  0.46072E-01  0.61969E-01  0.83854E-01  0.10980E+00  0.14572E+00
+  0.18428E+00  0.24482E+00  0.30515E+00  0.39421E+00  0.49195E+00  0.63725E+00
+  0.79062E+00  0.10165E+01  0.12592E+01  0.30406E-06  0.57577E-06  0.13208E-05
+  0.26945E-05  0.42057E-05  0.51670E-05  0.26310E-05  0.21968E-05  0.11935E-04
+  0.17999E-04  0.20249E-04  0.23416E-03  0.81231E-03  0.72055E-04  0.36496E-02
+  0.68396E-02  0.12700E-01  0.22716E-01  0.38015E-01  0.59082E-01  0.79135E-01
+  0.10665E+00  0.13925E+00  0.18430E+00  0.23257E+00  0.30838E+00  0.38372E+00
+  0.49495E+00  0.61687E+00  0.79792E+00  0.98857E+00  0.12689E+01  0.15691E+01
+  0.30455E-06  0.49822E-06  0.61626E-06  0.71906E-06  0.76195E-06  0.69005E-06
+  0.51140E-05  0.11935E-04  0.17099E-05  0.22027E-05  0.81598E-05  0.32227E-03
+  0.10081E-02  0.19258E-03  0.41936E-02  0.76450E-02  0.13890E-01  0.24681E-01
+  0.40753E-01  0.68833E-01  0.10405E+00  0.13928E+00  0.18091E+00  0.23838E+00
+  0.29985E+00  0.39635E+00  0.49212E+00  0.63347E+00  0.78813E+00  0.10177E+01
+  0.12590E+01  0.16135E+01  0.19919E+01  0.10004E-05  0.13647E-05  0.16685E-05
+  0.19146E-05  0.19399E-05  0.17705E-05  0.71370E-05  0.17999E-04  0.22027E-05
+  0.59765E-05  0.81784E-05  0.38409E-03  0.11826E-02  0.20929E-03  0.46687E-02
+  0.83895E-02  0.14909E-01  0.26284E-01  0.43271E-01  0.72280E-01  0.12052E+00
+  0.18003E+00  0.23267E+00  0.30518E+00  0.38260E+00  0.50415E+00  0.62455E+00
+  0.80216E+00  0.99632E+00  0.12844E+01  0.15867E+01  0.20303E+01  0.25029E+01
+  0.28107E-05  0.36491E-05  0.45429E-05  0.53618E-05  0.59007E-05  0.60000E-05
+  0.62734E-05  0.20249E-04  0.81598E-05  0.81784E-05  0.22181E-04  0.48116E-03
+  0.13708E-02  0.21242E-03  0.52309E-02  0.92547E-02  0.16187E-01  0.28155E-01
+  0.46026E-01  0.76607E-01  0.12635E+00  0.21069E+00  0.30033E+00  0.39178E+00
+  0.48916E+00  0.64222E+00  0.79338E+00  0.10164E+01  0.12600E+01  0.16213E+01
+  0.19998E+01  0.25549E+01  0.31451E+01  0.71416E-04  0.10025E-03  0.12139E-03
+  0.14761E-03  0.17377E-03  0.19924E-03  0.21263E-03  0.23416E-03  0.32227E-03
+  0.38409E-03  0.48116E-03  0.73404E-03  0.71965E-03  0.10231E-02  0.43030E-02
+  0.80655E-02  0.14671E-01  0.26028E-01  0.42694E-01  0.71825E-01  0.11952E+00
+  0.19870E+00  0.32287E+00  0.46074E+00  0.57420E+00  0.75366E+00  0.92917E+00
+  0.11882E+01  0.14715E+01  0.18916E+01  0.23305E+01  0.29733E+01  0.36559E+01
+  0.35165E-03  0.40401E-03  0.47147E-03  0.56242E-03  0.63071E-03  0.71317E-03
+  0.75860E-03  0.81231E-03  0.10081E-02  0.11826E-02  0.13708E-02  0.71965E-03
+  0.30251E-02  0.28780E-02  0.44044E-02  0.86464E-02  0.16072E-01  0.28444E-01
+  0.45837E-01  0.76006E-01  0.12548E+00  0.20752E+00  0.33355E+00  0.54066E+00
+  0.84295E+00  0.11713E+01  0.14326E+01  0.18186E+01  0.22407E+01  0.28669E+01
+  0.35189E+01  0.44721E+01  0.54822E+01  0.81566E-04  0.10464E-03  0.11424E-03
+  0.12492E-03  0.13836E-03  0.14661E-03  0.10763E-03  0.72055E-04  0.19258E-03
+  0.20929E-03  0.21242E-03  0.10231E-02  0.28780E-02  0.73280E-03  0.10100E-01
+  0.16498E-01  0.26905E-01  0.43551E-01  0.66580E-01  0.10506E+00  0.16651E+00
+  0.26673E+00  0.42097E+00  0.67086E+00  0.10285E+01  0.16657E+01  0.21568E+01
+  0.27159E+01  0.33248E+01  0.42282E+01  0.51692E+01  0.65481E+01  0.80065E+01
+  0.15109E-02  0.19411E-02  0.25053E-02  0.27424E-02  0.29567E-02  0.32399E-02
+  0.34191E-02  0.36496E-02  0.41936E-02  0.46687E-02  0.52309E-02  0.43030E-02
+  0.44044E-02  0.10100E-01  0.15776E-01  0.66090E-02  0.13280E-01  0.25373E-01
+  0.41624E-01  0.70305E-01  0.11695E+00  0.19192E+00  0.30924E+00  0.50099E+00
+  0.77316E+00  0.12600E+01  0.19284E+01  0.25889E+01  0.31698E+01  0.40325E+01
+  0.49251E+01  0.62258E+01  0.76028E+01  0.24851E-02  0.31802E-02  0.40852E-02
+  0.52742E-02  0.57758E-02  0.61293E-02  0.64867E-02  0.68396E-02  0.76450E-02
+  0.83895E-02  0.92547E-02  0.80655E-02  0.86464E-02  0.16498E-01  0.66090E-02
+  0.31840E-01  0.12976E-01  0.24117E-01  0.39568E-01  0.67483E-01  0.11301E+00
+  0.18495E+00  0.29741E+00  0.47850E+00  0.73879E+00  0.12030E+01  0.18240E+01
+  0.28810E+01  0.37505E+01  0.47525E+01  0.57846E+01  0.72858E+01  0.88752E+01
+  0.39197E-02  0.50013E-02  0.64019E-02  0.82293E-02  0.10630E-01  0.11698E-01
+  0.12111E-01  0.12700E-01  0.13890E-01  0.14909E-01  0.16187E-01  0.14671E-01
+  0.16072E-01  0.26905E-01  0.13280E-01  0.12976E-01  0.15793E-01  0.24190E-01
+  0.37682E-01  0.63251E-01  0.10602E+00  0.17306E+00  0.27827E+00  0.44502E+00
+  0.68216E+00  0.11153E+01  0.16841E+01  0.26344E+01  0.40417E+01  0.54448E+01
+  0.66012E+01  0.82783E+01  0.10054E+02  0.57452E-02  0.73106E-02  0.93273E-02
+  0.11941E-01  0.15351E-01  0.19831E-01  0.21858E-01  0.22716E-01  0.24681E-01
+  0.26284E-01  0.28155E-01  0.26028E-01  0.28444E-01  0.43551E-01  0.25373E-01
+  0.24117E-01  0.24190E-01  0.30425E-01  0.41545E-01  0.63875E-01  0.10306E+00
+  0.16504E+00  0.26291E+00  0.41595E+00  0.63116E+00  0.10254E+01  0.15452E+01
+  0.24039E+01  0.36566E+01  0.57996E+01  0.74704E+01  0.93174E+01  0.11274E+02
+  0.78286E-02  0.99390E-02  0.12646E-01  0.16136E-01  0.20659E-01  0.26557E-01
+  0.33973E-01  0.38015E-01  0.40753E-01  0.43271E-01  0.46026E-01  0.42694E-01
+  0.45837E-01  0.66580E-01  0.41624E-01  0.39568E-01  0.37682E-01  0.41545E-01
+  0.54419E-01  0.75415E-01  0.11394E+00  0.17551E+00  0.27264E+00  0.42233E+00
+  0.63012E+00  0.10091E+01  0.15002E+01  0.23216E+01  0.35112E+01  0.55064E+01
+  0.83397E+01  0.11029E+02  0.13277E+02  0.10812E-01  0.13700E-01  0.17391E-01
+  0.22130E-01  0.28239E-01  0.36153E-01  0.46072E-01  0.59082E-01  0.68833E-01
+  0.72280E-01  0.76607E-01  0.71825E-01  0.76006E-01  0.10506E+00  0.70305E-01
+  0.67483E-01  0.63251E-01  0.63875E-01  0.75415E-01  0.98538E-01  0.13417E+00
+  0.19370E+00  0.28792E+00  0.43218E+00  0.63022E+00  0.98844E+00  0.14452E+01
+  0.22009E+01  0.33140E+01  0.51572E+01  0.77232E+01  0.11989E+02  0.15314E+02
+  0.14765E-01  0.18678E-01  0.23665E-01  0.30044E-01  0.38232E-01  0.48784E-01
+  0.61969E-01  0.79135E-01  0.10405E+00  0.12052E+00  0.12635E+00  0.11952E+00
+  0.12548E+00  0.16651E+00  0.11695E+00  0.11301E+00  0.10602E+00  0.10306E+00
+  0.11394E+00  0.13417E+00  0.17630E+00  0.23443E+00  0.32694E+00  0.46906E+00
+  0.66271E+00  0.10071E+01  0.14417E+01  0.21507E+01  0.31863E+01  0.49201E+01
+  0.73107E+01  0.11197E+02  0.16800E+02  0.20269E-01  0.25597E-01  0.32373E-01
+  0.41011E-01  0.52056E-01  0.66219E-01  0.83854E-01  0.10665E+00  0.13928E+00
+  0.18003E+00  0.21069E+00  0.19870E+00  0.20752E+00  0.26673E+00  0.19192E+00
+  0.18495E+00  0.17306E+00  0.16504E+00  0.17551E+00  0.19370E+00  0.23443E+00
+  0.30973E+00  0.40493E+00  0.55265E+00  0.75295E+00  0.11007E+01  0.15371E+01
+  0.22374E+01  0.32488E+01  0.49200E+01  0.72621E+01  0.11016E+02  0.16321E+02
+  0.26833E-01  0.33841E-01  0.42735E-01  0.54048E-01  0.68471E-01  0.86901E-01
+  0.10980E+00  0.13925E+00  0.18091E+00  0.23267E+00  0.30033E+00  0.32287E+00
+  0.33355E+00  0.42097E+00  0.30924E+00  0.29741E+00  0.27827E+00  0.26291E+00
+  0.27264E+00  0.28792E+00  0.32694E+00  0.40493E+00  0.53614E+00  0.69348E+00
+  0.90743E+00  0.12677E+01  0.17208E+01  0.24348E+01  0.34521E+01  0.51069E+01
+  0.74090E+01  0.11145E+02  0.16371E+02  0.35998E-01  0.45335E-01  0.57166E-01
+  0.72181E-01  0.91269E-01  0.11560E+00  0.14572E+00  0.18430E+00  0.23838E+00
+  0.30518E+00  0.39178E+00  0.46074E+00  0.54066E+00  0.67086E+00  0.50099E+00
+  0.47850E+00  0.44502E+00  0.41595E+00  0.42233E+00  0.43218E+00  0.46906E+00
+  0.55265E+00  0.69348E+00  0.91776E+00  0.11565E+01  0.15468E+01  0.20395E+01
+  0.28014E+01  0.38716E+01  0.55826E+01  0.79436E+01  0.11732E+02  0.17119E+02
+  0.45939E-01  0.57774E-01  0.72750E-01  0.91730E-01  0.11582E+00  0.14643E+00
+  0.18428E+00  0.23257E+00  0.29985E+00  0.38260E+00  0.48916E+00  0.57420E+00
+  0.84295E+00  0.10285E+01  0.77316E+00  0.73879E+00  0.68216E+00  0.63116E+00
+  0.63012E+00  0.63022E+00  0.66271E+00  0.75295E+00  0.90743E+00  0.11565E+01
+  0.15286E+01  0.19672E+01  0.25212E+01  0.33622E+01  0.45270E+01  0.63568E+01
+  0.88578E+01  0.12819E+02  0.18403E+02  0.61590E-01  0.77336E-01  0.97241E-01
+  0.12244E+00  0.15436E+00  0.19484E+00  0.24482E+00  0.30838E+00  0.39635E+00
+  0.50415E+00  0.64222E+00  0.75366E+00  0.11713E+01  0.16657E+01  0.12600E+01
+  0.12030E+01  0.11153E+01  0.10254E+01  0.10091E+01  0.98844E+00  0.10071E+01
+  0.11007E+01  0.12677E+01  0.15468E+01  0.19672E+01  0.26069E+01  0.32409E+01
+  0.41855E+01  0.54742E+01  0.74604E+01  0.10153E+02  0.14360E+02  0.20233E+02
+  0.77441E-01  0.97079E-01  0.12188E+00  0.15324E+00  0.19293E+00  0.24318E+00
+  0.30515E+00  0.38372E+00  0.49212E+00  0.62455E+00  0.79338E+00  0.92917E+00
+  0.14326E+01  0.21568E+01  0.19284E+01  0.18240E+01  0.16841E+01  0.15452E+01
+  0.15002E+01  0.14452E+01  0.14417E+01  0.15371E+01  0.17208E+01  0.20395E+01
+  0.25212E+01  0.32409E+01  0.42686E+01  0.53575E+01  0.68245E+01  0.90457E+01
+  0.12024E+02  0.16603E+02  0.22932E+02  0.10102E+00  0.12638E+00  0.15840E+00
+  0.19884E+00  0.24996E+00  0.31462E+00  0.39421E+00  0.49495E+00  0.63347E+00
+  0.80216E+00  0.10164E+01  0.11882E+01  0.18186E+01  0.27159E+01  0.25889E+01
+  0.28810E+01  0.26344E+01  0.24039E+01  0.23216E+01  0.22009E+01  0.21507E+01
+  0.22374E+01  0.24348E+01  0.28014E+01  0.33622E+01  0.41855E+01  0.53575E+01
+  0.70558E+01  0.87525E+01  0.11277E+02  0.14624E+02  0.19686E+02  0.26609E+02
+  0.12738E+00  0.15899E+00  0.19887E+00  0.24921E+00  0.31280E+00  0.39316E+00
+  0.49195E+00  0.61687E+00  0.78813E+00  0.99632E+00  0.12600E+01  0.14715E+01
+  0.22407E+01  0.33248E+01  0.31698E+01  0.37505E+01  0.40417E+01  0.36566E+01
+  0.35112E+01  0.33140E+01  0.31863E+01  0.32488E+01  0.34521E+01  0.38716E+01
+  0.45270E+01  0.54742E+01  0.68245E+01  0.87525E+01  0.11548E+02  0.14463E+02
+  0.18287E+02  0.23974E+02  0.31667E+02  0.16701E+00  0.20785E+00  0.25937E+00
+  0.32436E+00  0.40641E+00  0.50999E+00  0.63725E+00  0.79792E+00  0.10177E+01
+  0.12844E+01  0.16213E+01  0.18916E+01  0.28669E+01  0.42282E+01  0.40325E+01
+  0.47525E+01  0.54448E+01  0.57996E+01  0.55064E+01  0.51572E+01  0.49201E+01
+  0.49200E+01  0.51069E+01  0.55826E+01  0.63568E+01  0.74604E+01  0.90457E+01
+  0.11277E+02  0.14463E+02  0.19080E+02  0.23519E+02  0.30014E+02  0.38700E+02
+  0.21012E+00  0.26062E+00  0.32427E+00  0.40458E+00  0.50589E+00  0.63371E+00
+  0.79062E+00  0.98857E+00  0.12590E+01  0.15867E+01  0.19998E+01  0.23305E+01
+  0.35189E+01  0.51692E+01  0.49251E+01  0.57846E+01  0.66012E+01  0.74704E+01
+  0.83397E+01  0.77232E+01  0.73107E+01  0.72621E+01  0.74090E+01  0.79436E+01
+  0.88578E+01  0.10153E+02  0.12024E+02  0.14624E+02  0.18287E+02  0.23519E+02
+  0.30993E+02  0.38510E+02  0.48456E+02  0.27475E+00  0.33938E+00  0.42080E+00
+  0.52346E+00  0.65295E+00  0.81620E+00  0.10165E+01  0.12689E+01  0.16135E+01
+  0.20303E+01  0.25549E+01  0.29733E+01  0.44721E+01  0.65481E+01  0.62258E+01
+  0.72858E+01  0.82783E+01  0.93174E+01  0.11029E+02  0.11989E+02  0.11197E+02
+  0.11016E+02  0.11145E+02  0.11732E+02  0.12819E+02  0.14360E+02  0.16603E+02
+  0.19686E+02  0.23974E+02  0.30014E+02  0.38510E+02  0.50668E+02  0.62212E+02
+  0.34731E+00  0.42679E+00  0.52699E+00  0.65328E+00  0.81248E+00  0.10132E+01
+  0.12592E+01  0.15691E+01  0.19919E+01  0.25029E+01  0.31451E+01  0.36559E+01
+  0.54822E+01  0.80065E+01  0.76028E+01  0.88752E+01  0.10054E+02  0.11274E+02
+  0.13277E+02  0.15314E+02  0.16800E+02  0.16321E+02  0.16371E+02  0.17119E+02
+  0.18403E+02  0.20233E+02  0.22932E+02  0.26609E+02  0.31667E+02  0.38700E+02
+  0.48456E+02  0.62212E+02  0.82005E+02  0.14847E-09  0.37413E-09  0.89594E-09
+  0.24356E-08  0.38515E-08  0.11534E-07  0.89817E-07  0.24950E-06  0.69886E-06
+  0.17581E-05  0.60663E-05  0.48454E-04  0.17764E-03  0.38505E-03  0.12306E-02
+  0.39306E-02  0.94621E-02  0.18863E-01  0.32995E-01  0.52128E-01  0.85124E-01
+  0.13167E+00  0.20592E+00  0.30636E+00  0.42860E+00  0.58399E+00  0.78670E+00
+  0.10618E+01  0.14189E+01  0.19256E+01  0.25923E+01  0.35074E+01  0.47775E+01
+  0.29957E-09  0.31425E-09  0.69705E-09  0.22845E-08  0.51354E-08  0.10540E-07
+  0.10095E-06  0.31904E-06  0.10727E-05  0.24902E-05  0.98936E-05  0.78053E-04
+  0.22867E-03  0.52682E-03  0.14811E-02  0.45754E-02  0.12016E-01  0.23905E-01
+  0.41747E-01  0.65865E-01  0.10744E+00  0.16602E+00  0.25940E+00  0.38558E+00
+  0.53889E+00  0.73344E+00  0.98667E+00  0.13294E+01  0.17727E+01  0.23994E+01
+  0.32189E+01  0.43367E+01  0.58741E+01  0.54650E-09  0.74427E-09  0.77469E-09
+  0.16591E-08  0.41136E-08  0.10256E-07  0.10337E-06  0.32911E-06  0.13908E-05
+  0.60750E-05  0.18113E-04  0.10949E-03  0.28132E-03  0.61706E-03  0.18044E-02
+  0.50960E-02  0.14169E-01  0.30338E-01  0.52878E-01  0.83297E-01  0.13570E+00
+  0.20947E+00  0.32699E+00  0.48559E+00  0.67805E+00  0.92191E+00  0.12388E+01
+  0.16667E+01  0.22186E+01  0.29963E+01  0.40083E+01  0.53807E+01  0.72555E+01
+  0.96042E-09  0.11901E-08  0.15421E-08  0.19422E-08  0.36006E-08  0.10517E-07
+  0.11870E-06  0.31973E-06  0.18523E-05  0.85214E-05  0.29769E-04  0.13441E-03
+  0.33101E-03  0.72120E-03  0.20399E-02  0.57715E-02  0.15039E-01  0.37094E-01
+  0.67090E-01  0.10548E+00  0.17158E+00  0.26452E+00  0.41250E+00  0.61203E+00
+  0.85381E+00  0.11597E+01  0.15567E+01  0.20920E+01  0.27807E+01  0.37485E+01
+  0.50028E+01  0.66958E+01  0.89954E+01  0.18684E-08  0.23155E-08  0.30400E-08
+  0.35275E-08  0.60381E-08  0.10465E-07  0.15282E-06  0.30451E-06  0.14426E-05
+  0.11107E-04  0.47185E-04  0.15913E-03  0.37821E-03  0.81252E-03  0.22918E-02
+  0.63349E-02  0.16157E-01  0.38433E-01  0.85280E-01  0.13377E+00  0.21719E+00
+  0.33435E+00  0.52078E+00  0.77188E+00  0.10758E+01  0.14600E+01  0.19579E+01
+  0.26283E+01  0.34891E+01  0.46964E+01  0.62561E+01  0.83529E+01  0.11187E+02
+  0.35433E-08  0.48270E-08  0.57729E-08  0.76636E-08  0.12352E-07  0.18803E-07
+  0.28764E-06  0.64158E-06  0.10044E-05  0.10374E-04  0.56634E-04  0.18146E-03
+  0.42000E-03  0.88250E-03  0.24674E-02  0.68421E-02  0.17240E-01  0.40149E-01
+  0.87549E-01  0.16993E+00  0.27531E+00  0.42307E+00  0.65806E+00  0.97425E+00
+  0.13564E+01  0.18392E+01  0.24640E+01  0.33046E+01  0.43821E+01  0.58908E+01
+  0.78346E+01  0.10440E+02  0.13946E+02  0.20386E-07  0.26316E-07  0.33479E-07
+  0.72169E-07  0.17762E-06  0.37916E-06  0.39281E-06  0.10240E-05  0.46690E-05
+  0.42570E-05  0.42714E-04  0.16719E-03  0.41318E-03  0.87322E-03  0.24682E-02
+  0.69867E-02  0.17635E-01  0.41472E-01  0.88718E-01  0.18057E+00  0.34657E+00
+  0.53213E+00  0.82726E+00  0.12239E+01  0.17026E+01  0.23065E+01  0.30875E+01
+  0.41369E+01  0.54806E+01  0.73596E+01  0.97752E+01  0.13004E+02  0.17337E+02
+  0.40773E-07  0.55679E-07  0.82900E-07  0.14241E-06  0.49128E-06  0.12689E-05
+  0.20025E-05  0.30761E-05  0.10888E-04  0.16113E-04  0.33148E-04  0.14932E-03
+  0.40214E-03  0.88211E-03  0.24911E-02  0.71776E-02  0.18040E-01  0.42254E-01
+  0.90642E-01  0.18307E+00  0.38718E+00  0.67110E+00  0.10422E+01  0.15403E+01
+  0.21404E+01  0.28966E+01  0.38739E+01  0.51863E+01  0.68639E+01  0.92088E+01
+  0.12217E+02  0.16231E+02  0.21601E+02  0.19527E-07  0.37168E-07  0.60797E-07
+  0.15214E-06  0.31634E-06  0.49557E-06  0.36103E-05  0.11249E-04  0.40087E-04
+  0.61411E-04  0.91821E-04  0.24914E-03  0.56262E-03  0.11636E-02  0.31043E-02
+  0.81229E-02  0.19860E-01  0.45520E-01  0.95408E-01  0.19283E+00  0.40322E+00
+  0.80428E+00  0.13401E+01  0.19737E+01  0.27365E+01  0.36973E+01  0.49386E+01
+  0.66044E+01  0.87332E+01  0.11704E+02  0.15511E+02  0.20582E+02  0.27352E+02
+  0.15436E-06  0.24941E-06  0.42650E-06  0.69892E-06  0.10823E-05  0.14731E-05
+  0.56999E-05  0.17327E-04  0.58257E-04  0.90021E-04  0.13385E-03  0.32194E-03
+  0.66836E-03  0.12760E-02  0.33575E-02  0.88486E-02  0.21099E-01  0.47780E-01
+  0.98313E-01  0.19776E+00  0.41470E+00  0.82163E+00  0.16574E+01  0.25039E+01
+  0.34647E+01  0.46738E+01  0.62348E+01  0.83287E+01  0.11002E+02  0.14731E+02
+  0.19506E+02  0.25855E+02  0.34318E+02  0.29033E-06  0.37372E-06  0.78253E-06
+  0.18004E-05  0.32960E-05  0.45711E-05  0.49768E-05  0.18166E-04  0.70824E-04
+  0.10808E-03  0.16381E-03  0.36454E-03  0.11374E-02  0.14696E-02  0.36345E-02
+  0.94615E-02  0.22273E-01  0.49866E-01  0.10175E+00  0.20278E+00  0.42521E+00
+  0.84249E+00  0.16891E+01  0.31786E+01  0.43881E+01  0.59083E+01  0.78697E+01
+  0.10500E+02  0.13856E+02  0.18535E+02  0.24518E+02  0.32468E+02  0.43050E+02
+  0.20945E-04  0.27495E-04  0.36511E-04  0.57477E-04  0.93669E-04  0.14659E-03
+  0.18940E-03  0.24440E-03  0.27721E-03  0.35613E-03  0.47467E-03  0.50450E-03
+  0.54194E-03  0.22544E-02  0.13892E-02  0.58095E-02  0.16793E-01  0.41348E-01
+  0.87705E-01  0.17890E+00  0.38464E+00  0.77898E+00  0.15841E+01  0.30528E+01
+  0.51714E+01  0.69605E+01  0.92631E+01  0.12352E+02  0.16281E+02  0.21776E+02
+  0.28778E+02  0.38075E+02  0.50433E+02  0.12658E-03  0.16403E-03  0.21433E-03
+  0.29937E-03  0.42479E-03  0.52895E-03  0.66121E-03  0.82587E-03  0.96392E-03
+  0.11866E-02  0.14850E-02  0.17743E-02  0.20839E-02  0.24840E-02  0.21859E-02
+  0.67378E-02  0.14420E-01  0.38862E-01  0.84224E-01  0.17281E+00  0.37480E+00
+  0.75904E+00  0.15626E+01  0.30382E+01  0.54509E+01  0.95535E+01  0.14103E+02
+  0.18747E+02  0.24631E+02  0.32885E+02  0.43366E+02  0.57264E+02  0.75714E+02
+  0.29387E-04  0.37643E-04  0.48559E-04  0.66332E-04  0.91803E-04  0.12502E-03
+  0.10692E-03  0.93366E-04  0.10945E-03  0.15012E-03  0.21593E-03  0.62593E-03
+  0.12892E-02  0.23311E-02  0.58183E-02  0.14671E-01  0.32821E-01  0.66484E-01
+  0.12769E+00  0.24182E+00  0.48723E+00  0.94222E+00  0.18653E+01  0.35421E+01
+  0.63423E+01  0.10996E+02  0.18974E+02  0.27016E+02  0.35417E+02  0.47134E+02
+  0.62070E+02  0.81865E+02  0.10812E+03  0.54499E-03  0.69915E-03  0.90235E-03
+  0.12378E-02  0.17168E-02  0.24133E-02  0.31932E-02  0.36223E-02  0.41420E-02
+  0.48936E-02  0.59121E-02  0.70289E-02  0.85551E-02  0.10714E-01  0.11893E-01
+  0.10805E-01  0.12026E-01  0.25775E-01  0.59540E-01  0.13206E+00  0.31046E+00
+  0.65087E+00  0.13784E+01  0.27117E+01  0.49248E+01  0.86341E+01  0.14849E+02
+  0.25744E+02  0.34964E+02  0.46605E+02  0.61270E+02  0.80699E+02  0.10646E+03
+  0.89747E-03  0.11469E-02  0.14731E-02  0.20065E-02  0.27585E-02  0.38349E-02
+  0.53325E-02  0.68721E-02  0.75608E-02  0.88070E-02  0.10324E-01  0.12045E-01
+  0.14473E-01  0.17862E-01  0.20416E-01  0.20364E-01  0.19113E-01  0.36878E-01
+  0.52874E-01  0.11444E+00  0.27911E+00  0.59855E+00  0.12919E+01  0.25580E+01
+  0.46359E+01  0.81385E+01  0.14026E+02  0.24182E+02  0.41272E+02  0.55114E+02
+  0.72307E+02  0.95081E+02  0.12527E+03  0.14173E-02  0.18058E-02  0.23110E-02
+  0.31309E-02  0.42751E-02  0.58932E-02  0.81309E-02  0.11418E-01  0.14014E-01
+  0.15713E-01  0.18128E-01  0.20633E-01  0.24224E-01  0.29403E-01  0.33993E-01
+  0.36140E-01  0.35589E-01  0.36624E-01  0.55148E-01  0.10234E+00  0.24296E+00
+  0.53135E+00  0.11779E+01  0.23589E+01  0.42702E+01  0.74634E+01  0.12895E+02
+  0.22242E+02  0.37703E+02  0.63619E+02  0.83251E+02  0.10925E+03  0.14371E+03
+  0.20810E-02  0.26436E-02  0.33718E-02  0.45449E-02  0.61666E-02  0.84341E-02
+  0.11544E-01  0.16038E-01  0.22318E-01  0.27133E-01  0.30613E-01  0.34672E-01
+  0.39909E-01  0.47419E-01  0.54527E-01  0.59394E-01  0.61497E-01  0.61114E-01
+  0.73033E-01  0.11204E+00  0.22447E+00  0.47818E+00  0.10738E+01  0.21709E+01
+  0.39203E+01  0.68121E+01  0.11697E+02  0.20273E+02  0.34238E+02  0.59396E+02
+  0.94963E+02  0.12431E+03  0.16320E+03  0.28414E-02  0.36003E-02  0.45783E-02
+  0.61450E-02  0.82935E-02  0.11268E-01  0.15310E-01  0.21067E-01  0.29009E-01
+  0.41222E-01  0.48630E-01  0.54055E-01  0.61599E-01  0.71513E-01  0.80846E-01
+  0.87636E-01  0.91649E-01  0.91418E-01  0.10209E+00  0.13483E+00  0.24037E+00
+  0.47784E+00  0.10524E+01  0.21154E+01  0.37847E+01  0.65118E+01  0.11081E+02
+  0.19076E+02  0.32361E+02  0.55910E+02  0.94985E+02  0.14674E+03  0.19218E+03
+  0.39336E-02  0.49727E-02  0.63073E-02  0.84346E-02  0.11333E-01  0.15313E-01
+  0.20682E-01  0.28234E-01  0.38545E-01  0.54083E-01  0.77178E-01  0.86768E-01
+  0.97221E-01  0.11151E+00  0.12409E+00  0.13379E+00  0.14103E+00  0.14283E+00
+  0.15484E+00  0.18464E+00  0.28240E+00  0.49410E+00  0.10304E+01  0.20402E+01
+  0.36045E+01  0.61253E+01  0.10308E+02  0.17594E+02  0.29605E+02  0.51574E+02
+  0.86952E+02  0.14786E+03  0.22073E+03  0.53879E-02  0.67963E-02  0.86001E-02
+  0.11464E-01  0.15345E-01  0.20638E-01  0.27733E-01  0.37610E-01  0.50971E-01
+  0.70748E-01  0.99630E-01  0.13973E+00  0.15354E+00  0.17338E+00  0.19120E+00
+  0.20417E+00  0.21504E+00  0.21987E+00  0.23611E+00  0.26762E+00  0.32948E+00
+  0.55962E+00  0.10571E+01  0.20198E+01  0.34965E+01  0.58414E+01  0.96884E+01
+  0.16350E+02  0.27236E+02  0.47136E+02  0.79990E+02  0.13498E+03  0.22978E+03
+  0.74230E-02  0.93422E-02  0.11794E-01  0.15673E-01  0.20904E-01  0.27992E-01
+  0.37435E-01  0.50450E-01  0.67882E-01  0.93274E-01  0.12971E+00  0.18034E+00
+  0.24513E+00  0.27060E+00  0.29463E+00  0.31119E+00  0.32379E+00  0.32933E+00
+  0.34946E+00  0.38471E+00  0.43364E+00  0.61681E+00  0.11702E+01  0.21218E+01
+  0.35680E+01  0.58282E+01  0.94894E+01  0.15775E+02  0.25959E+02  0.44504E+02
+  0.75083E+02  0.12727E+03  0.21505E+03  0.98721E-02  0.12397E-01  0.15616E-01
+  0.20696E-01  0.27522E-01  0.36730E-01  0.48943E-01  0.65651E-01  0.87873E-01
+  0.11983E+00  0.16507E+00  0.22706E+00  0.31712E+00  0.41847E+00  0.44737E+00
+  0.47022E+00  0.48537E+00  0.49066E+00  0.51556E+00  0.55658E+00  0.59236E+00
+  0.76307E+00  0.13735E+01  0.23248E+01  0.37655E+01  0.59816E+01  0.95211E+01
+  0.15533E+02  0.25183E+02  0.42640E+02  0.71262E+02  0.12037E+03  0.20383E+03
+  0.13319E-01  0.16683E-01  0.20966E-01  0.27711E-01  0.36741E-01  0.48875E-01
+  0.64895E-01  0.86661E-01  0.11541E+00  0.15626E+00  0.21337E+00  0.29048E+00
+  0.40053E+00  0.56102E+00  0.69164E+00  0.71293E+00  0.73211E+00  0.73033E+00
+  0.75454E+00  0.79729E+00  0.81595E+00  0.98051E+00  0.17103E+01  0.27026E+01
+  0.41995E+01  0.64614E+01  0.10017E+02  0.15979E+02  0.25452E+02  0.42434E+02
+  0.70100E+02  0.11732E+03  0.19842E+03  0.17117E-01  0.21383E-01  0.26806E-01
+  0.35332E-01  0.46723E-01  0.61981E-01  0.82057E-01  0.10920E+00  0.14484E+00
+  0.19508E+00  0.26460E+00  0.35740E+00  0.48797E+00  0.67520E+00  0.91691E+00
+  0.10542E+01  0.10627E+01  0.10572E+01  0.10729E+01  0.11101E+01  0.11029E+01
+  0.12626E+01  0.22187E+01  0.33015E+01  0.49213E+01  0.73180E+01  0.11018E+02
+  0.17130E+02  0.26726E+02  0.43749E+02  0.71265E+02  0.11794E+03  0.19770E+03
+  0.23153E-01  0.28829E-01  0.36039E-01  0.47356E-01  0.62444E-01  0.82601E-01
+  0.10905E+00  0.14465E+00  0.19118E+00  0.25623E+00  0.34542E+00  0.46328E+00
+  0.62690E+00  0.85776E+00  0.11509E+01  0.15106E+01  0.16419E+01  0.16097E+01
+  0.16286E+01  0.16543E+01  0.15996E+01  0.17385E+01  0.21859E+01  0.41674E+01
+  0.59160E+01  0.84630E+01  0.12327E+02  0.18602E+02  0.28334E+02  0.45353E+02
+  0.72647E+02  0.11860E+03  0.19664E+03  0.29435E-01  0.36514E-01  0.45498E-01
+  0.59587E-01  0.78341E-01  0.10335E+00  0.13608E+00  0.18000E+00  0.23717E+00
+  0.31666E+00  0.42488E+00  0.56667E+00  0.76142E+00  0.10327E+01  0.13713E+01
+  0.17785E+01  0.22819E+01  0.23231E+01  0.23079E+01  0.23199E+01  0.21889E+01
+  0.23019E+01  0.27690E+01  0.54909E+01  0.74942E+01  0.10340E+02  0.14563E+02
+  0.21303E+02  0.31584E+02  0.49340E+02  0.77480E+02  0.12443E+03  0.20360E+03
+  0.38925E-01  0.48067E-01  0.59666E-01  0.77837E-01  0.10199E+00  0.13414E+00
+  0.17613E+00  0.23230E+00  0.30515E+00  0.40596E+00  0.54230E+00  0.71951E+00
+  0.96048E+00  0.12920E+01  0.16991E+01  0.21786E+01  0.27579E+01  0.34271E+01
+  0.34045E+01  0.33584E+01  0.31179E+01  0.31715E+01  0.36474E+01  0.74562E+01
+  0.97928E+01  0.13030E+02  0.17723E+02  0.25075E+02  0.36082E+02  0.54838E+02
+  0.84156E+02  0.13256E+03  0.21346E+03  0.49915E-01  0.61310E-01  0.75760E-01
+  0.98378E-01  0.12842E+00  0.16835E+00  0.22044E+00  0.28996E+00  0.37990E+00
+  0.50388E+00  0.67087E+00  0.88663E+00  0.11778E+01  0.15748E+01  0.20564E+01
+  0.26151E+01  0.32782E+01  0.40279E+01  0.49923E+01  0.48309E+01  0.44166E+01
+  0.43967E+01  0.48572E+01  0.10417E+02  0.13190E+02  0.16937E+02  0.22241E+02
+  0.30394E+02  0.42355E+02  0.62442E+02  0.93352E+02  0.14377E+03  0.22718E+03
+  0.66801E-01  0.81530E-01  0.10019E+00  0.12939E+00  0.16815E+00  0.21960E+00
+  0.28662E+00  0.37592E+00  0.49117E+00  0.64950E+00  0.86184E+00  0.11347E+01
+  0.15006E+01  0.19951E+01  0.25881E+01  0.32657E+01  0.40562E+01  0.49302E+01
+  0.61152E+01  0.72577E+01  0.64878E+01  0.63236E+01  0.67435E+01  0.14940E+02
+  0.18280E+02  0.22693E+02  0.28790E+02  0.37984E+02  0.51186E+02  0.73026E+02
+  0.10605E+03  0.15918E+03  0.24604E+03  0.86163E-01  0.10437E+00  0.12744E+00
+  0.16351E+00  0.21137E+00  0.27485E+00  0.35743E+00  0.46732E+00  0.60891E+00
+  0.80300E+00  0.10625E+01  0.13947E+01  0.18378E+01  0.24330E+01  0.31399E+01
+  0.39381E+01  0.48552E+01  0.58489E+01  0.71741E+01  0.88236E+01  0.93377E+01
+  0.88810E+01  0.92876E+01  0.21881E+02  0.26024E+02  0.31348E+02  0.38510E+02
+  0.49108E+02  0.63959E+02  0.88207E+02  0.12412E+03  0.18104E+03  0.27286E+03
+  0.11607E+00  0.13936E+00  0.16887E+00  0.21500E+00  0.27615E+00  0.35721E+00
+  0.46255E+00  0.60256E+00  0.78262E+00  0.10290E+01  0.13575E+01  0.17764E+01
+  0.23326E+01  0.30749E+01  0.39487E+01  0.49228E+01  0.60239E+01  0.71908E+01
+  0.87201E+01  0.10576E+02  0.11973E+02  0.12954E+02  0.13158E+02  0.32620E+02
+  0.37908E+02  0.44467E+02  0.53037E+02  0.65488E+02  0.82473E+02  0.10990E+03
+  0.14960E+03  0.21151E+03  0.30989E+03  0.15194E+00  0.18061E+00  0.21691E+00
+  0.27365E+00  0.34883E+00  0.44847E+00  0.57777E+00  0.74956E+00  0.97018E+00
+  0.12717E+01  0.16730E+01  0.21832E+01  0.28584E+01  0.37559E+01  0.48055E+01
+  0.59643E+01  0.72591E+01  0.86085E+01  0.10353E+02  0.12428E+02  0.13892E+02
+  0.16654E+02  0.18571E+02  0.48829E+02  0.56313E+02  0.64531E+02  0.74943E+02
+  0.89809E+02  0.10952E+03  0.14106E+03  0.18558E+03  0.25387E+03  0.36067E+03
+  0.23612E-09  0.68213E-09  0.12966E-08  0.29805E-08  0.48921E-08  0.12457E-07
+  0.10280E-06  0.26377E-06  0.74005E-06  0.17293E-05  0.52055E-05  0.52808E-05
+  0.21947E-03  0.53658E-03  0.13993E-02  0.33107E-03  0.71358E-02  0.10472E-03
+  0.22513E-01  0.35583E-01  0.79443E-01  0.13259E+00  0.21615E+00  0.33953E+00
+  0.51918E+00  0.76393E+00  0.11468E+01  0.16693E+01  0.24870E+01  0.36766E+01
+  0.55007E+01  0.83559E+01  0.12936E+02  0.30758E-09  0.47311E-09  0.11926E-08
+  0.28715E-08  0.57872E-08  0.10752E-07  0.11357E-06  0.34636E-06  0.10980E-05
+  0.27263E-05  0.91189E-05  0.85948E-05  0.28281E-03  0.73384E-03  0.16815E-02
+  0.38401E-03  0.90587E-02  0.12326E-03  0.28474E-01  0.44946E-01  0.10014E+00
+  0.16696E+00  0.27188E+00  0.42650E+00  0.65113E+00  0.95608E+00  0.14312E+01
+  0.20755E+01  0.30770E+01  0.45190E+01  0.67028E+01  0.10072E+02  0.15384E+02
+  0.61780E-09  0.78550E-09  0.91657E-09  0.21733E-08  0.47899E-08  0.11724E-07
+  0.11166E-06  0.32445E-06  0.14493E-05  0.60074E-05  0.19785E-04  0.11486E-04
+  0.34668E-03  0.86136E-03  0.20461E-02  0.41905E-03  0.10821E-01  0.13250E-03
+  0.36048E-01  0.56814E-01  0.12630E+00  0.21035E+00  0.34215E+00  0.53614E+00
+  0.81740E+00  0.11981E+01  0.17894E+01  0.25872E+01  0.38200E+01  0.55792E+01
+  0.82164E+01  0.12232E+02  0.18466E+02  0.11089E-08  0.13622E-08  0.18306E-08
+  0.22074E-08  0.42738E-08  0.12684E-07  0.14775E-06  0.30020E-06  0.16219E-05
+  0.80209E-05  0.35195E-04  0.13304E-04  0.40763E-03  0.10077E-02  0.23154E-02
+  0.46477E-03  0.11452E-01  0.13627E-03  0.45710E-01  0.71907E-01  0.15943E+00
+  0.26520E+00  0.43093E+00  0.67451E+00  0.10271E+01  0.15033E+01  0.22409E+01
+  0.32318E+01  0.47557E+01  0.69151E+01  0.10123E+02  0.14952E+02  0.22347E+02
+  0.21248E-08  0.26633E-08  0.35732E-08  0.44666E-08  0.62243E-08  0.10667E-07
+  0.23269E-06  0.35849E-06  0.13049E-05  0.10261E-04  0.56396E-04  0.14377E-04
+  0.46661E-03  0.11373E-02  0.26026E-02  0.49677E-03  0.12262E-01  0.10133E-03
+  0.58057E-01  0.91126E-01  0.20141E+00  0.33459E+00  0.54305E+00  0.84911E+00
+  0.12916E+01  0.18879E+01  0.28098E+01  0.40439E+01  0.59344E+01  0.85969E+01
+  0.12524E+02  0.18376E+02  0.27233E+02  0.42285E-08  0.54294E-08  0.65090E-08
+  0.86528E-08  0.12770E-07  0.16768E-07  0.31680E-06  0.71195E-06  0.11486E-05
+  0.93731E-05  0.67851E-04  0.14171E-04  0.51994E-03  0.12387E-02  0.28014E-02
+  0.51535E-03  0.13090E-01  0.77506E-04  0.61243E-01  0.11565E+00  0.25466E+00
+  0.42242E+00  0.68476E+00  0.10695E+01  0.16251E+01  0.23726E+01  0.35265E+01
+  0.50664E+01  0.74184E+01  0.10714E+02  0.15545E+02  0.22687E+02  0.33383E+02
+  0.23937E-07  0.29979E-07  0.46579E-07  0.91832E-07  0.18353E-06  0.33737E-06
+  0.32641E-06  0.12590E-05  0.49676E-05  0.43735E-05  0.53175E-04  0.17741E-04
+  0.52611E-03  0.12627E-02  0.28214E-02  0.29301E-03  0.13253E-01  0.91331E-03
+  0.61433E-01  0.12658E+00  0.31830E+00  0.52810E+00  0.85611E+00  0.13368E+01
+  0.20303E+01  0.29617E+01  0.43987E+01  0.63110E+01  0.92257E+01  0.13293E+02
+  0.19224E+02  0.27937E+02  0.40869E+02  0.48428E-07  0.67716E-07  0.10609E-06
+  0.22100E-06  0.54173E-06  0.11445E-05  0.14153E-05  0.25658E-05  0.11903E-04
+  0.19498E-04  0.46233E-04  0.49076E-04  0.52728E-03  0.13155E-02  0.28630E-02
+  0.18596E-03  0.13457E-01  0.18096E-02  0.62131E-01  0.12748E+00  0.39912E+00
+  0.66190E+00  0.10726E+01  0.16739E+01  0.25407E+01  0.37035E+01  0.54956E+01
+  0.78759E+01  0.11498E+02  0.16534E+02  0.23848E+02  0.34535E+02  0.50278E+02
+  0.28848E-07  0.49568E-07  0.85140E-07  0.19333E-06  0.33005E-06  0.43503E-06
+  0.44388E-05  0.12162E-04  0.41036E-04  0.67123E-04  0.11390E-03  0.16016E-04
+  0.69837E-03  0.16389E-02  0.35250E-02  0.58228E-03  0.15032E-01  0.12877E-03
+  0.66312E-01  0.13567E+00  0.50082E+00  0.85807E+00  0.13832E+01  0.21509E+01
+  0.32561E+01  0.47375E+01  0.70175E+01  0.10042E+02  0.14633E+02  0.21002E+02
+  0.30218E+02  0.43619E+02  0.63239E+02  0.18679E-06  0.34196E-06  0.55150E-06
+  0.79599E-06  0.11108E-05  0.13259E-05  0.74319E-05  0.19469E-04  0.60001E-04
+  0.98552E-04  0.16810E-03  0.16005E-04  0.83988E-03  0.18033E-02  0.38141E-02
+  0.60027E-03  0.15947E-01  0.21069E-03  0.68137E-01  0.13922E+00  0.51089E+00
+  0.10896E+01  0.17519E+01  0.27188E+01  0.41094E+01  0.59717E+01  0.88354E+01
+  0.12629E+02  0.18381E+02  0.26344E+02  0.37834E+02  0.54478E+02  0.78722E+02
+  0.33422E-06  0.48640E-06  0.12154E-05  0.21658E-05  0.33982E-05  0.42746E-05
+  0.69243E-05  0.21555E-04  0.74040E-04  0.11981E-03  0.20979E-03  0.14710E-04
+  0.13233E-02  0.21007E-02  0.41370E-02  0.53485E-03  0.16769E-01  0.55791E-03
+  0.70167E-01  0.14231E+00  0.52231E+00  0.11818E+01  0.22177E+01  0.34342E+01
+  0.51820E+01  0.75201E+01  0.11114E+02  0.15869E+02  0.23072E+02  0.33024E+02
+  0.47356E+02  0.68052E+02  0.98078E+02  0.24346E-04  0.32137E-04  0.43556E-04
+  0.66068E-04  0.98482E-04  0.14333E-03  0.17463E-03  0.22828E-03  0.26045E-03
+  0.32747E-03  0.40430E-03  0.91605E-03  0.41907E-03  0.24248E-02  0.18051E-02
+  0.45573E-02  0.10656E-01  0.14700E-01  0.53457E-01  0.11381E+00  0.44327E+00
+  0.10303E+01  0.23353E+01  0.38561E+01  0.58627E+01  0.85298E+01  0.12664E+02
+  0.18094E+02  0.26367E+02  0.37761E+02  0.54159E+02  0.77816E+02  0.11207E+03
+  0.14612E-03  0.19008E-03  0.24927E-03  0.32971E-03  0.43468E-03  0.51965E-03
+  0.62149E-03  0.78854E-03  0.92219E-03  0.11270E-02  0.13621E-02  0.23916E-02
+  0.17301E-02  0.17036E-02  0.20366E-02  0.13142E-01  0.76972E-02  0.27680E-01
+  0.44624E-01  0.99006E-01  0.39722E+00  0.95456E+00  0.21941E+01  0.47833E+01
+  0.86334E+01  0.12550E+02  0.18661E+02  0.26629E+02  0.38829E+02  0.55557E+02
+  0.79601E+02  0.11421E+03  0.16412E+03  0.33722E-04  0.43334E-04  0.56059E-04
+  0.72593E-04  0.94889E-04  0.12284E-03  0.93212E-04  0.79386E-04  0.11580E-03
+  0.18183E-03  0.34558E-03  0.35237E-03  0.17881E-02  0.36507E-02  0.67397E-02
+  0.63262E-03  0.23870E-01  0.40466E-02  0.85767E-01  0.16589E+00  0.57409E+00
+  0.12828E+01  0.28315E+01  0.59792E+01  0.12363E+02  0.19194E+02  0.28186E+02
+  0.40023E+02  0.57932E+02  0.82558E+02  0.11784E+03  0.16842E+03  0.24109E+03
+  0.62573E-03  0.80490E-03  0.10412E-02  0.13552E-02  0.17781E-02  0.23538E-02
+  0.31060E-02  0.35156E-02  0.40140E-02  0.47440E-02  0.56449E-02  0.79935E-02
+  0.79418E-02  0.92548E-02  0.10977E-01  0.27220E-01  0.15609E-01  0.67187E-01
+  0.28401E-01  0.57670E-01  0.25292E+00  0.66723E+00  0.16513E+01  0.37789E+01
+  0.81189E+01  0.16199E+02  0.24376E+02  0.34823E+02  0.51115E+02  0.73280E+02
+  0.10521E+03  0.15123E+03  0.21762E+03  0.10283E-02  0.13170E-02  0.16946E-02
+  0.21918E-02  0.28540E-02  0.37441E-02  0.49796E-02  0.67222E-02  0.73863E-02
+  0.85631E-02  0.99462E-02  0.13304E-01  0.13663E-01  0.16023E-01  0.19298E-01
+  0.40528E-01  0.27907E-01  0.18227E+00  0.41835E-01  0.64949E-01  0.20803E+00
+  0.54562E+00  0.13866E+01  0.32455E+01  0.71348E+01  0.14478E+02  0.27332E+02
+  0.39075E+02  0.57616E+02  0.82722E+02  0.11896E+03  0.17126E+03  0.24682E+03
+  0.16214E-02  0.20696E-02  0.26523E-02  0.34140E-02  0.44196E-02  0.57579E-02
+  0.76152E-02  0.10754E-01  0.13768E-01  0.15378E-01  0.17575E-01  0.22318E-01
+  0.23146E-01  0.27060E-01  0.32632E-01  0.60617E-01  0.49116E-01  0.13044E+00
+  0.72105E-01  0.92927E-01  0.20322E+00  0.45585E+00  0.11256E+01  0.26570E+01
+  0.59538E+01  0.12170E+02  0.25818E+02  0.41932E+02  0.62215E+02  0.89524E+02
+  0.12906E+03  0.18630E+03  0.26918E+03  0.23768E-02  0.30244E-02  0.38610E-02
+  0.49478E-02  0.63705E-02  0.82459E-02  0.10839E-01  0.15146E-01  0.21205E-01
+  0.26650E-01  0.29819E-01  0.36995E-01  0.38438E-01  0.44338E-01  0.52814E-01
+  0.89765E-01  0.79277E-01  0.18127E+00  0.11987E+00  0.14950E+00  0.28790E+00
+  0.46148E+00  0.99250E+00  0.22428E+01  0.49721E+01  0.10245E+02  0.21745E+02
+  0.43114E+02  0.66402E+02  0.95662E+02  0.13816E+03  0.19985E+03  0.28944E+03
+  0.32408E-02  0.41123E-02  0.52333E-02  0.66807E-02  0.85623E-02  0.11023E-01
+  0.14403E-01  0.19936E-01  0.27621E-01  0.39401E-01  0.47530E-01  0.57272E-01
+  0.59584E-01  0.67383E-01  0.78617E-01  0.12607E+00  0.11402E+00  0.23914E+00
+  0.17063E+00  0.21123E+00  0.37534E+00  0.59667E+00  0.10182E+01  0.21405E+01
+  0.45893E+01  0.93198E+01  0.19831E+02  0.38979E+02  0.75726E+02  0.10888E+03
+  0.15709E+03  0.22716E+03  0.32904E+03  0.44808E-02  0.56719E-02  0.71978E-02
+  0.91593E-02  0.11694E-01  0.14987E-01  0.19490E-01  0.26767E-01  0.36770E-01
+  0.51806E-01  0.73937E-01  0.91372E-01  0.94383E-01  0.10586E+00  0.12112E+00
+  0.18360E+00  0.16963E+00  0.32703E+00  0.25049E+00  0.30958E+00  0.52742E+00
+  0.76064E+00  0.12860E+01  0.21756E+01  0.43718E+01  0.86282E+01  0.17977E+02
+  0.35212E+02  0.71669E+02  0.12227E+03  0.17575E+03  0.25349E+03  0.36653E+03
+  0.61300E-02  0.77420E-02  0.98008E-02  0.12436E-01  0.15827E-01  0.20206E-01
+  0.26171E-01  0.35709E-01  0.48699E-01  0.67894E-01  0.95680E-01  0.14480E+00
+  0.14957E+00  0.16553E+00  0.18715E+00  0.27015E+00  0.25216E+00  0.45253E+00
+  0.36303E+00  0.44589E+00  0.74101E+00  0.10189E+01  0.15616E+01  0.27455E+01
+  0.45370E+01  0.85981E+01  0.17181E+02  0.33413E+02  0.66730E+02  0.13095E+03
+  0.20301E+03  0.29093E+03  0.41849E+03  0.84349E-02  0.10628E-01  0.13422E-01
+  0.16986E-01  0.21551E-01  0.27415E-01  0.35370E-01  0.47962E-01  0.64947E-01
+  0.89651E-01  0.12482E+00  0.18535E+00  0.23940E+00  0.25937E+00  0.28894E+00
+  0.40197E+00  0.37343E+00  0.63206E+00  0.51543E+00  0.62264E+00  0.10008E+01
+  0.13386E+01  0.19406E+01  0.31811E+01  0.57239E+01  0.10745E+02  0.17583E+02
+  0.33538E+02  0.66255E+02  0.12793E+03  0.24811E+03  0.35244E+03  0.50322E+03
+  0.11203E-01  0.14086E-01  0.17750E-01  0.22413E-01  0.28366E-01  0.35984E-01
+  0.46286E-01  0.62478E-01  0.84165E-01  0.11532E+00  0.15909E+00  0.23276E+00
+  0.30729E+00  0.40243E+00  0.43935E+00  0.59556E+00  0.55215E+00  0.88822E+00
+  0.73225E+00  0.86922E+00  0.13506E+01  0.17691E+01  0.24672E+01  0.38315E+01
+  0.65268E+01  0.11837E+02  0.22233E+02  0.42380E+02  0.67873E+02  0.13037E+03
+  0.25109E+03  0.44208E+03  0.62508E+03  0.15094E-01  0.18932E-01  0.23801E-01
+  0.29984E-01  0.37856E-01  0.47894E-01  0.61426E-01  0.82548E-01  0.11064E+00
+  0.15053E+00  0.20590E+00  0.29732E+00  0.38870E+00  0.53897E+00  0.67980E+00
+  0.89070E+00  0.82592E+00  0.12720E+01  0.10438E+01  0.12098E+01  0.17948E+01
+  0.22928E+01  0.30964E+01  0.46177E+01  0.75429E+01  0.13276E+02  0.24112E+02
+  0.45173E+02  0.86466E+02  0.16711E+03  0.26030E+03  0.50085E+03  0.80174E+03
+  0.19369E-01  0.24232E-01  0.30393E-01  0.38203E-01  0.48126E-01  0.60749E-01
+  0.77720E-01  0.10409E+00  0.13896E+00  0.18807E+00  0.25558E+00  0.36551E+00
+  0.47403E+00  0.64958E+00  0.90465E+00  0.13059E+01  0.11914E+01  0.17980E+01
+  0.14591E+01  0.16514E+01  0.23344E+01  0.29016E+01  0.38021E+01  0.54813E+01
+  0.86541E+01  0.14835E+02  0.26218E+02  0.48322E+02  0.90875E+02  0.17368E+03
+  0.33591E+03  0.64504E+03  0.10009E+04  0.26150E-01  0.32617E-01  0.40801E-01
+  0.51162E-01  0.64301E-01  0.80977E-01  0.10335E+00  0.13797E+00  0.18353E+00
+  0.24721E+00  0.33397E+00  0.47313E+00  0.60972E+00  0.82674E+00  0.11363E+01
+  0.18688E+01  0.18266E+01  0.26553E+01  0.21663E+01  0.23956E+01  0.32262E+01
+  0.39026E+01  0.49583E+01  0.68902E+01  0.10464E+02  0.17380E+02  0.29709E+02
+  0.53641E+02  0.98605E+02  0.18573E+03  0.35478E+03  0.68239E+03  0.13072E+04
+  0.33173E-01  0.41235E-01  0.51428E-01  0.64320E-01  0.80648E-01  0.10133E+00
+  0.12904E+00  0.17176E+00  0.22779E+00  0.30567E+00  0.41103E+00  0.57861E+00
+  0.74096E+00  0.99600E+00  0.13541E+01  0.21917E+01  0.25731E+01  0.37899E+01
+  0.30489E+01  0.33237E+01  0.42551E+01  0.49875E+01  0.61342E+01  0.82461E+01
+  0.12128E+02  0.19593E+02  0.32651E+02  0.57848E+02  0.10456E+03  0.19455E+03
+  0.36806E+03  0.70528E+03  0.13526E+04  0.43755E-01  0.54165E-01  0.67317E-01
+  0.83934E-01  0.10496E+00  0.13155E+00  0.16711E+00  0.22179E+00  0.29323E+00
+  0.39204E+00  0.52490E+00  0.73450E+00  0.93513E+00  0.12469E+01  0.16780E+01
+  0.26748E+01  0.31009E+01  0.56474E+01  0.44593E+01  0.47703E+01  0.58321E+01
+  0.66088E+01  0.78464E+01  0.10170E+02  0.14434E+02  0.22591E+02  0.36567E+02
+  0.63343E+02  0.11223E+03  0.20576E+03  0.38475E+03  0.73051E+03  0.14036E+04
+  0.55932E-01  0.68906E-01  0.85284E-01  0.10597E+00  0.13211E+00  0.16514E+00
+  0.20926E+00  0.27696E+00  0.36521E+00  0.48682E+00  0.64959E+00  0.90478E+00
+  0.11473E+01  0.15207E+01  0.20312E+01  0.31996E+01  0.36765E+01  0.65890E+01
+  0.64884E+01  0.67924E+01  0.80393E+01  0.88438E+01  0.10168E+02  0.12733E+02
+  0.17451E+02  0.26447E+02  0.41530E+02  0.70205E+02  0.12171E+03  0.21946E+03
+  0.40496E+03  0.76084E+03  0.14498E+04  0.74579E-01  0.91342E-01  0.11250E+00
+  0.13919E+00  0.17291E+00  0.21547E+00  0.27225E+00  0.35924E+00  0.47236E+00
+  0.62775E+00  0.83487E+00  0.11578E+01  0.14623E+01  0.19276E+01  0.25568E+01
+  0.39824E+01  0.45376E+01  0.79889E+01  0.81290E+01  0.10104E+02  0.11511E+02
+  0.12309E+02  0.13678E+02  0.16508E+02  0.21780E+02  0.31845E+02  0.48329E+02
+  0.79408E+02  0.13420E+03  0.23721E+03  0.43073E+03  0.79902E+03  0.15073E+04
+  0.95780E-01  0.11650E+00  0.14264E+00  0.17561E+00  0.21723E+00  0.26975E+00
+  0.33973E+00  0.44681E+00  0.58581E+00  0.77636E+00  0.10296E+01  0.14228E+01
+  0.17913E+01  0.23513E+01  0.31022E+01  0.47941E+01  0.54238E+01  0.94306E+01
+  0.94978E+01  0.12670E+02  0.16082E+02  0.16948E+02  0.18266E+02  0.21322E+02
+  0.27168E+02  0.38388E+02  0.56374E+02  0.89975E+02  0.14817E+03  0.25640E+03
+  0.45758E+03  0.83724E+03  0.15626E+04  0.12837E+00  0.15488E+00  0.18831E+00
+  0.23046E+00  0.28364E+00  0.35069E+00  0.43995E+00  0.57641E+00  0.75325E+00
+  0.99519E+00  0.13158E+01  0.18123E+01  0.22740E+01  0.29723E+01  0.39013E+01
+  0.59867E+01  0.67230E+01  0.11561E+02  0.11513E+02  0.15128E+02  0.23358E+02
+  0.23910E+02  0.25218E+02  0.28414E+02  0.34884E+02  0.47496E+02  0.67287E+02
+  0.10392E+03  0.16618E+03  0.28047E+03  0.49036E+03  0.88255E+03  0.16261E+04
+  0.16708E+00  0.19969E+00  0.24082E+00  0.29266E+00  0.35804E+00  0.44045E+00
+  0.55003E+00  0.71751E+00  0.93422E+00  0.12303E+01  0.16220E+01  0.22275E+01
+  0.27872E+01  0.36311E+01  0.47477E+01  0.72466E+01  0.80951E+01  0.13804E+02
+  0.13637E+02  0.17719E+02  0.31012E+02  0.33561E+02  0.34653E+02  0.38092E+02
+  0.45251E+02  0.59542E+02  0.81506E+02  0.12186E+03  0.18905E+03  0.31075E+03
+  0.53119E+03  0.93853E+03  0.17039E+04  0.14847E-09  0.29957E-09  0.54650E-09
+  0.96042E-09  0.18684E-08  0.35433E-08  0.20386E-07  0.40773E-07  0.19527E-07
+  0.15436E-06  0.29033E-06  0.20945E-04  0.12658E-03  0.29387E-04  0.54499E-03
+  0.89747E-03  0.14173E-02  0.20810E-02  0.28414E-02  0.39336E-02  0.53879E-02
+  0.74230E-02  0.98721E-02  0.13319E-01  0.17117E-01  0.23153E-01  0.29435E-01
+  0.38925E-01  0.49915E-01  0.66801E-01  0.86163E-01  0.11607E+00  0.15194E+00
+  0.37413E-09  0.31425E-09  0.74427E-09  0.11901E-08  0.23155E-08  0.48270E-08
+  0.26316E-07  0.55679E-07  0.37168E-07  0.24941E-06  0.37372E-06  0.27495E-04
+  0.16403E-03  0.37643E-04  0.69915E-03  0.11469E-02  0.18058E-02  0.26436E-02
+  0.36003E-02  0.49727E-02  0.67963E-02  0.93422E-02  0.12397E-01  0.16683E-01
+  0.21383E-01  0.28829E-01  0.36514E-01  0.48067E-01  0.61310E-01  0.81530E-01
+  0.10437E+00  0.13936E+00  0.18061E+00  0.89594E-09  0.69705E-09  0.77469E-09
+  0.15421E-08  0.30400E-08  0.57729E-08  0.33479E-07  0.82900E-07  0.60797E-07
+  0.42650E-06  0.78253E-06  0.36511E-04  0.21433E-03  0.48559E-04  0.90235E-03
+  0.14731E-02  0.23110E-02  0.33718E-02  0.45783E-02  0.63073E-02  0.86001E-02
+  0.11794E-01  0.15616E-01  0.20966E-01  0.26806E-01  0.36039E-01  0.45498E-01
+  0.59666E-01  0.75760E-01  0.10019E+00  0.12744E+00  0.16887E+00  0.21691E+00
+  0.24356E-08  0.22845E-08  0.16591E-08  0.19422E-08  0.35275E-08  0.76636E-08
+  0.72169E-07  0.14241E-06  0.15214E-06  0.69892E-06  0.18004E-05  0.57477E-04
+  0.29937E-03  0.66332E-04  0.12378E-02  0.20065E-02  0.31309E-02  0.45449E-02
+  0.61450E-02  0.84346E-02  0.11464E-01  0.15673E-01  0.20696E-01  0.27711E-01
+  0.35332E-01  0.47356E-01  0.59587E-01  0.77837E-01  0.98378E-01  0.12939E+00
+  0.16351E+00  0.21500E+00  0.27365E+00  0.38515E-08  0.51354E-08  0.41136E-08
+  0.36006E-08  0.60381E-08  0.12352E-07  0.17762E-06  0.49128E-06  0.31634E-06
+  0.10823E-05  0.32960E-05  0.93669E-04  0.42479E-03  0.91803E-04  0.17168E-02
+  0.27585E-02  0.42751E-02  0.61666E-02  0.82935E-02  0.11333E-01  0.15345E-01
+  0.20904E-01  0.27522E-01  0.36741E-01  0.46723E-01  0.62444E-01  0.78341E-01
+  0.10199E+00  0.12842E+00  0.16815E+00  0.21137E+00  0.27615E+00  0.34883E+00
+  0.11534E-07  0.10540E-07  0.10256E-07  0.10517E-07  0.10465E-07  0.18803E-07
+  0.37916E-06  0.12689E-05  0.49557E-06  0.14731E-05  0.45711E-05  0.14659E-03
+  0.52895E-03  0.12502E-03  0.24133E-02  0.38349E-02  0.58932E-02  0.84341E-02
+  0.11268E-01  0.15313E-01  0.20638E-01  0.27992E-01  0.36730E-01  0.48875E-01
+  0.61981E-01  0.82601E-01  0.10335E+00  0.13414E+00  0.16835E+00  0.21960E+00
+  0.27485E+00  0.35721E+00  0.44847E+00  0.89817E-07  0.10095E-06  0.10337E-06
+  0.11870E-06  0.15282E-06  0.28764E-06  0.39281E-06  0.20025E-05  0.36103E-05
+  0.56999E-05  0.49768E-05  0.18940E-03  0.66121E-03  0.10692E-03  0.31932E-02
+  0.53325E-02  0.81309E-02  0.11544E-01  0.15310E-01  0.20682E-01  0.27733E-01
+  0.37435E-01  0.48943E-01  0.64895E-01  0.82057E-01  0.10905E+00  0.13608E+00
+  0.17613E+00  0.22044E+00  0.28662E+00  0.35743E+00  0.46255E+00  0.57777E+00
+  0.24950E-06  0.31904E-06  0.32911E-06  0.31973E-06  0.30451E-06  0.64158E-06
+  0.10240E-05  0.30761E-05  0.11249E-04  0.17327E-04  0.18166E-04  0.24440E-03
+  0.82587E-03  0.93366E-04  0.36223E-02  0.68721E-02  0.11418E-01  0.16038E-01
+  0.21067E-01  0.28234E-01  0.37610E-01  0.50450E-01  0.65651E-01  0.86661E-01
+  0.10920E+00  0.14465E+00  0.18000E+00  0.23230E+00  0.28996E+00  0.37592E+00
+  0.46732E+00  0.60256E+00  0.74956E+00  0.69886E-06  0.10727E-05  0.13908E-05
+  0.18523E-05  0.14426E-05  0.10044E-05  0.46690E-05  0.10888E-04  0.40087E-04
+  0.58257E-04  0.70824E-04  0.27721E-03  0.96392E-03  0.10945E-03  0.41420E-02
+  0.75608E-02  0.14014E-01  0.22318E-01  0.29009E-01  0.38545E-01  0.50971E-01
+  0.67882E-01  0.87873E-01  0.11541E+00  0.14484E+00  0.19118E+00  0.23717E+00
+  0.30515E+00  0.37990E+00  0.49117E+00  0.60891E+00  0.78262E+00  0.97018E+00
+  0.17581E-05  0.24902E-05  0.60750E-05  0.85214E-05  0.11107E-04  0.10374E-04
+  0.42570E-05  0.16113E-04  0.61411E-04  0.90021E-04  0.10808E-03  0.35613E-03
+  0.11866E-02  0.15012E-03  0.48936E-02  0.88070E-02  0.15713E-01  0.27133E-01
+  0.41222E-01  0.54083E-01  0.70748E-01  0.93274E-01  0.11983E+00  0.15626E+00
+  0.19508E+00  0.25623E+00  0.31666E+00  0.40596E+00  0.50388E+00  0.64950E+00
+  0.80300E+00  0.10290E+01  0.12717E+01  0.60663E-05  0.98936E-05  0.18113E-04
+  0.29769E-04  0.47185E-04  0.56634E-04  0.42714E-04  0.33148E-04  0.91821E-04
+  0.13385E-03  0.16381E-03  0.47467E-03  0.14850E-02  0.21593E-03  0.59121E-02
+  0.10324E-01  0.18128E-01  0.30613E-01  0.48630E-01  0.77178E-01  0.99630E-01
+  0.12971E+00  0.16507E+00  0.21337E+00  0.26460E+00  0.34542E+00  0.42488E+00
+  0.54230E+00  0.67087E+00  0.86184E+00  0.10625E+01  0.13575E+01  0.16730E+01
+  0.48454E-04  0.78053E-04  0.10949E-03  0.13441E-03  0.15913E-03  0.18146E-03
+  0.16719E-03  0.14932E-03  0.24914E-03  0.32194E-03  0.36454E-03  0.50450E-03
+  0.17743E-02  0.62593E-03  0.70289E-02  0.12045E-01  0.20633E-01  0.34672E-01
+  0.54055E-01  0.86768E-01  0.13973E+00  0.18034E+00  0.22706E+00  0.29048E+00
+  0.35740E+00  0.46328E+00  0.56667E+00  0.71951E+00  0.88663E+00  0.11347E+01
+  0.13947E+01  0.17764E+01  0.21832E+01  0.17764E-03  0.22867E-03  0.28132E-03
+  0.33101E-03  0.37821E-03  0.42000E-03  0.41318E-03  0.40214E-03  0.56262E-03
+  0.66836E-03  0.11374E-02  0.54194E-03  0.20839E-02  0.12892E-02  0.85551E-02
+  0.14473E-01  0.24224E-01  0.39909E-01  0.61599E-01  0.97221E-01  0.15354E+00
+  0.24513E+00  0.31712E+00  0.40053E+00  0.48797E+00  0.62690E+00  0.76142E+00
+  0.96048E+00  0.11778E+01  0.15006E+01  0.18378E+01  0.23326E+01  0.28584E+01
+  0.38505E-03  0.52682E-03  0.61706E-03  0.72120E-03  0.81252E-03  0.88250E-03
+  0.87322E-03  0.88211E-03  0.11636E-02  0.12760E-02  0.14696E-02  0.22544E-02
+  0.24840E-02  0.23311E-02  0.10714E-01  0.17862E-01  0.29403E-01  0.47419E-01
+  0.71513E-01  0.11151E+00  0.17338E+00  0.27060E+00  0.41847E+00  0.56102E+00
+  0.67520E+00  0.85776E+00  0.10327E+01  0.12920E+01  0.15748E+01  0.19951E+01
+  0.24330E+01  0.30749E+01  0.37559E+01  0.12306E-02  0.14811E-02  0.18044E-02
+  0.20399E-02  0.22918E-02  0.24674E-02  0.24682E-02  0.24911E-02  0.31043E-02
+  0.33575E-02  0.36345E-02  0.13892E-02  0.21859E-02  0.58183E-02  0.11893E-01
+  0.20416E-01  0.33993E-01  0.54527E-01  0.80846E-01  0.12409E+00  0.19120E+00
+  0.29463E+00  0.44737E+00  0.69164E+00  0.91691E+00  0.11509E+01  0.13713E+01
+  0.16991E+01  0.20564E+01  0.25881E+01  0.31399E+01  0.39487E+01  0.48055E+01
+  0.39306E-02  0.45754E-02  0.50960E-02  0.57715E-02  0.63349E-02  0.68421E-02
+  0.69867E-02  0.71776E-02  0.81229E-02  0.88486E-02  0.94615E-02  0.58095E-02
+  0.67378E-02  0.14671E-01  0.10805E-01  0.20364E-01  0.36140E-01  0.59394E-01
+  0.87636E-01  0.13379E+00  0.20417E+00  0.31119E+00  0.47022E+00  0.71293E+00
+  0.10542E+01  0.15106E+01  0.17785E+01  0.21786E+01  0.26151E+01  0.32657E+01
+  0.39381E+01  0.49228E+01  0.59643E+01  0.94621E-02  0.12016E-01  0.14169E-01
+  0.15039E-01  0.16157E-01  0.17240E-01  0.17635E-01  0.18040E-01  0.19860E-01
+  0.21099E-01  0.22273E-01  0.16793E-01  0.14420E-01  0.32821E-01  0.12026E-01
+  0.19113E-01  0.35589E-01  0.61497E-01  0.91649E-01  0.14103E+00  0.21504E+00
+  0.32379E+00  0.48537E+00  0.73211E+00  0.10627E+01  0.16419E+01  0.22819E+01
+  0.27579E+01  0.32782E+01  0.40562E+01  0.48552E+01  0.60239E+01  0.72591E+01
+  0.18863E-01  0.23905E-01  0.30338E-01  0.37094E-01  0.38433E-01  0.40149E-01
+  0.41472E-01  0.42254E-01  0.45520E-01  0.47780E-01  0.49866E-01  0.41348E-01
+  0.38862E-01  0.66484E-01  0.25775E-01  0.36878E-01  0.36624E-01  0.61114E-01
+  0.91418E-01  0.14283E+00  0.21987E+00  0.32933E+00  0.49066E+00  0.73033E+00
+  0.10572E+01  0.16097E+01  0.23231E+01  0.34271E+01  0.40279E+01  0.49302E+01
+  0.58489E+01  0.71908E+01  0.86085E+01  0.32995E-01  0.41747E-01  0.52878E-01
+  0.67090E-01  0.85280E-01  0.87549E-01  0.88718E-01  0.90642E-01  0.95408E-01
+  0.98313E-01  0.10175E+00  0.87705E-01  0.84224E-01  0.12769E+00  0.59540E-01
+  0.52874E-01  0.55148E-01  0.73033E-01  0.10209E+00  0.15484E+00  0.23611E+00
+  0.34946E+00  0.51556E+00  0.75454E+00  0.10729E+01  0.16286E+01  0.23079E+01
+  0.34045E+01  0.49923E+01  0.61152E+01  0.71741E+01  0.87201E+01  0.10353E+02
+  0.52128E-01  0.65865E-01  0.83297E-01  0.10548E+00  0.13377E+00  0.16993E+00
+  0.18057E+00  0.18307E+00  0.19283E+00  0.19776E+00  0.20278E+00  0.17890E+00
+  0.17281E+00  0.24182E+00  0.13206E+00  0.11444E+00  0.10234E+00  0.11204E+00
+  0.13483E+00  0.18464E+00  0.26762E+00  0.38471E+00  0.55658E+00  0.79729E+00
+  0.11101E+01  0.16543E+01  0.23199E+01  0.33584E+01  0.48309E+01  0.72577E+01
+  0.88236E+01  0.10576E+02  0.12428E+02  0.85124E-01  0.10744E+00  0.13570E+00
+  0.17158E+00  0.21719E+00  0.27531E+00  0.34657E+00  0.38718E+00  0.40322E+00
+  0.41470E+00  0.42521E+00  0.38464E+00  0.37480E+00  0.48723E+00  0.31046E+00
+  0.27911E+00  0.24296E+00  0.22447E+00  0.24037E+00  0.28240E+00  0.32948E+00
+  0.43364E+00  0.59236E+00  0.81595E+00  0.11029E+01  0.15996E+01  0.21889E+01
+  0.31179E+01  0.44166E+01  0.64878E+01  0.93377E+01  0.11973E+02  0.13892E+02
+  0.13167E+00  0.16602E+00  0.20947E+00  0.26452E+00  0.33435E+00  0.42307E+00
+  0.53213E+00  0.67110E+00  0.80428E+00  0.82163E+00  0.84249E+00  0.77898E+00
+  0.75904E+00  0.94222E+00  0.65087E+00  0.59855E+00  0.53135E+00  0.47818E+00
+  0.47784E+00  0.49410E+00  0.55962E+00  0.61681E+00  0.76307E+00  0.98051E+00
+  0.12626E+01  0.17385E+01  0.23019E+01  0.31715E+01  0.43967E+01  0.63236E+01
+  0.88810E+01  0.12954E+02  0.16654E+02  0.20592E+00  0.25940E+00  0.32699E+00
+  0.41250E+00  0.52078E+00  0.65806E+00  0.82726E+00  0.10422E+01  0.13401E+01
+  0.16574E+01  0.16891E+01  0.15841E+01  0.15626E+01  0.18653E+01  0.13784E+01
+  0.12919E+01  0.11779E+01  0.10738E+01  0.10524E+01  0.10304E+01  0.10571E+01
+  0.11702E+01  0.13735E+01  0.17103E+01  0.22187E+01  0.21859E+01  0.27690E+01
+  0.36474E+01  0.48572E+01  0.67435E+01  0.92876E+01  0.13158E+02  0.18571E+02
+  0.30636E+00  0.38558E+00  0.48559E+00  0.61203E+00  0.77188E+00  0.97425E+00
+  0.12239E+01  0.15403E+01  0.19737E+01  0.25039E+01  0.31786E+01  0.30528E+01
+  0.30382E+01  0.35421E+01  0.27117E+01  0.25580E+01  0.23589E+01  0.21709E+01
+  0.21154E+01  0.20402E+01  0.20198E+01  0.21218E+01  0.23248E+01  0.27026E+01
+  0.33015E+01  0.41674E+01  0.54909E+01  0.74562E+01  0.10417E+02  0.14940E+02
+  0.21881E+02  0.32620E+02  0.48829E+02  0.42860E+00  0.53889E+00  0.67805E+00
+  0.85381E+00  0.10758E+01  0.13564E+01  0.17026E+01  0.21404E+01  0.27365E+01
+  0.34647E+01  0.43881E+01  0.51714E+01  0.54509E+01  0.63423E+01  0.49248E+01
+  0.46359E+01  0.42702E+01  0.39203E+01  0.37847E+01  0.36045E+01  0.34965E+01
+  0.35680E+01  0.37655E+01  0.41995E+01  0.49213E+01  0.59160E+01  0.74942E+01
+  0.97928E+01  0.13190E+02  0.18280E+02  0.26024E+02  0.37908E+02  0.56313E+02
+  0.58399E+00  0.73344E+00  0.92191E+00  0.11597E+01  0.14600E+01  0.18392E+01
+  0.23065E+01  0.28966E+01  0.36973E+01  0.46738E+01  0.59083E+01  0.69605E+01
+  0.95535E+01  0.10996E+02  0.86341E+01  0.81385E+01  0.74634E+01  0.68121E+01
+  0.65118E+01  0.61253E+01  0.58414E+01  0.58282E+01  0.59816E+01  0.64614E+01
+  0.73180E+01  0.84630E+01  0.10340E+02  0.13030E+02  0.16937E+02  0.22693E+02
+  0.31348E+02  0.44467E+02  0.64531E+02  0.78670E+00  0.98667E+00  0.12388E+01
+  0.15567E+01  0.19579E+01  0.24640E+01  0.30875E+01  0.38739E+01  0.49386E+01
+  0.62348E+01  0.78697E+01  0.92631E+01  0.14103E+02  0.18974E+02  0.14849E+02
+  0.14026E+02  0.12895E+02  0.11697E+02  0.11081E+02  0.10308E+02  0.96884E+01
+  0.94894E+01  0.95211E+01  0.10017E+02  0.11018E+02  0.12327E+02  0.14563E+02
+  0.17723E+02  0.22241E+02  0.28790E+02  0.38510E+02  0.53037E+02  0.74943E+02
+  0.10618E+01  0.13294E+01  0.16667E+01  0.20920E+01  0.26283E+01  0.33046E+01
+  0.41369E+01  0.51863E+01  0.66044E+01  0.83287E+01  0.10500E+02  0.12352E+02
+  0.18747E+02  0.27016E+02  0.25744E+02  0.24182E+02  0.22242E+02  0.20273E+02
+  0.19076E+02  0.17594E+02  0.16350E+02  0.15775E+02  0.15533E+02  0.15979E+02
+  0.17130E+02  0.18602E+02  0.21303E+02  0.25075E+02  0.30394E+02  0.37984E+02
+  0.49108E+02  0.65488E+02  0.89809E+02  0.14189E+01  0.17727E+01  0.22186E+01
+  0.27807E+01  0.34891E+01  0.43821E+01  0.54806E+01  0.68639E+01  0.87332E+01
+  0.11002E+02  0.13856E+02  0.16281E+02  0.24631E+02  0.35417E+02  0.34964E+02
+  0.41272E+02  0.37703E+02  0.34238E+02  0.32361E+02  0.29605E+02  0.27236E+02
+  0.25959E+02  0.25183E+02  0.25452E+02  0.26726E+02  0.28334E+02  0.31584E+02
+  0.36082E+02  0.42355E+02  0.51186E+02  0.63959E+02  0.82473E+02  0.10952E+03
+  0.19256E+01  0.23994E+01  0.29963E+01  0.37485E+01  0.46964E+01  0.58908E+01
+  0.73596E+01  0.92088E+01  0.11704E+02  0.14731E+02  0.18535E+02  0.21776E+02
+  0.32885E+02  0.47134E+02  0.46605E+02  0.55114E+02  0.63619E+02  0.59396E+02
+  0.55910E+02  0.51574E+02  0.47136E+02  0.44504E+02  0.42640E+02  0.42434E+02
+  0.43749E+02  0.45353E+02  0.49340E+02  0.54838E+02  0.62442E+02  0.73026E+02
+  0.88207E+02  0.10990E+03  0.14106E+03  0.25923E+01  0.32189E+01  0.40083E+01
+  0.50028E+01  0.62561E+01  0.78346E+01  0.97752E+01  0.12217E+02  0.15511E+02
+  0.19506E+02  0.24518E+02  0.28778E+02  0.43366E+02  0.62070E+02  0.61270E+02
+  0.72307E+02  0.83251E+02  0.94963E+02  0.94985E+02  0.86952E+02  0.79990E+02
+  0.75083E+02  0.71262E+02  0.70100E+02  0.71265E+02  0.72647E+02  0.77480E+02
+  0.84156E+02  0.93352E+02  0.10605E+03  0.12412E+03  0.14960E+03  0.18558E+03
+  0.35074E+01  0.43367E+01  0.53807E+01  0.66958E+01  0.83529E+01  0.10440E+02
+  0.13004E+02  0.16231E+02  0.20582E+02  0.25855E+02  0.32468E+02  0.38075E+02
+  0.57264E+02  0.81865E+02  0.80699E+02  0.95081E+02  0.10925E+03  0.12431E+03
+  0.14674E+03  0.14786E+03  0.13498E+03  0.12727E+03  0.12037E+03  0.11732E+03
+  0.11794E+03  0.11860E+03  0.12443E+03  0.13256E+03  0.14377E+03  0.15918E+03
+  0.18104E+03  0.21151E+03  0.25387E+03  0.47775E+01  0.58741E+01  0.72555E+01
+  0.89954E+01  0.11187E+02  0.13946E+02  0.17337E+02  0.21601E+02  0.27352E+02
+  0.34318E+02  0.43050E+02  0.50433E+02  0.75714E+02  0.10812E+03  0.10646E+03
+  0.12527E+03  0.14371E+03  0.16320E+03  0.19218E+03  0.22073E+03  0.22978E+03
+  0.21505E+03  0.20383E+03  0.19842E+03  0.19770E+03  0.19664E+03  0.20360E+03
+  0.21346E+03  0.22718E+03  0.24604E+03  0.27286E+03  0.30989E+03  0.36067E+03
+  0.12257E-09  0.32711E-09  0.69869E-09  0.18279E-08  0.29373E-08  0.60142E-08
+  0.31328E-07  0.65572E-07  0.19771E-06  0.31038E-06  0.60446E-06  0.33978E-05
+  0.23924E-04  0.10721E-03  0.46356E-03  0.14038E-02  0.33903E-02  0.67783E-02
+  0.11887E-01  0.18832E-01  0.30844E-01  0.47868E-01  0.75157E-01  0.11237E+00
+  0.15817E+00  0.21721E+00  0.29557E+00  0.40406E+00  0.54888E+00  0.76054E+00
+  0.10508E+01  0.14681E+01  0.20789E+01  0.32711E-09  0.25942E-09  0.60792E-09
+  0.17413E-08  0.33784E-08  0.67933E-08  0.42539E-07  0.87262E-07  0.26961E-06
+  0.37852E-06  0.86896E-06  0.73360E-05  0.30540E-04  0.13655E-03  0.58918E-03
+  0.17806E-02  0.42920E-02  0.85674E-02  0.15005E-01  0.23741E-01  0.38833E-01
+  0.60188E-01  0.94365E-01  0.14084E+00  0.19785E+00  0.27100E+00  0.36757E+00
+  0.50046E+00  0.67638E+00  0.93127E+00  0.12766E+01  0.17669E+01  0.24742E+01
+  0.69869E-09  0.60792E-09  0.51568E-09  0.16156E-08  0.37808E-08  0.75898E-08
+  0.62336E-07  0.12214E-06  0.32118E-06  0.44032E-06  0.13962E-05  0.12569E-04
+  0.61710E-04  0.17479E-03  0.75182E-03  0.22657E-02  0.54490E-02  0.10855E-01
+  0.18981E-01  0.29988E-01  0.48988E-01  0.75832E-01  0.11873E+00  0.17695E+00
+  0.24813E+00  0.33914E+00  0.45876E+00  0.62254E+00  0.83781E+00  0.11474E+01
+  0.15625E+01  0.21450E+01  0.29745E+01  0.18279E-08  0.17413E-08  0.16156E-08
+  0.12644E-08  0.33077E-08  0.83729E-08  0.82305E-07  0.19953E-06  0.48234E-06
+  0.90658E-06  0.29851E-05  0.24274E-04  0.11919E-03  0.26706E-03  0.10133E-02
+  0.30412E-02  0.72885E-02  0.14478E-01  0.25257E-01  0.39825E-01  0.64947E-01
+  0.10037E+00  0.15692E+00  0.23349E+00  0.32681E+00  0.44572E+00  0.60133E+00
+  0.81330E+00  0.10900E+01  0.14850E+01  0.20090E+01  0.27355E+01  0.37557E+01
+  0.29373E-08  0.33784E-08  0.37808E-08  0.33077E-08  0.28468E-08  0.80301E-08
+  0.11744E-06  0.32062E-06  0.88139E-06  0.21092E-05  0.69855E-05  0.54321E-04
+  0.19375E-03  0.41226E-03  0.12976E-02  0.41036E-02  0.97889E-02  0.19373E-01
+  0.33693E-01  0.52995E-01  0.86251E-01  0.13307E+00  0.20772E+00  0.30859E+00
+  0.43121E+00  0.58704E+00  0.79026E+00  0.10660E+01  0.14239E+01  0.19319E+01
+  0.25999E+01  0.35172E+01  0.47896E+01  0.60142E-08  0.67933E-08  0.75898E-08
+  0.83729E-08  0.80301E-08  0.66475E-08  0.13974E-06  0.47684E-06  0.15637E-05
+  0.39746E-05  0.12871E-04  0.98673E-04  0.26985E-03  0.59243E-03  0.16530E-02
+  0.49330E-02  0.13210E-01  0.26018E-01  0.45077E-01  0.70687E-01  0.11477E+00
+  0.17672E+00  0.27536E+00  0.40843E+00  0.56986E+00  0.77450E+00  0.10407E+01
+  0.14008E+01  0.18662E+01  0.25236E+01  0.33821E+01  0.45514E+01  0.61575E+01
+  0.31328E-07  0.42539E-07  0.62336E-07  0.82305E-07  0.11744E-06  0.13974E-06
+  0.48506E-07  0.25729E-06  0.18630E-05  0.80732E-05  0.22392E-04  0.12842E-03
+  0.31759E-03  0.68955E-03  0.20040E-02  0.56006E-02  0.15041E-01  0.34651E-01
+  0.59891E-01  0.93711E-01  0.15196E+00  0.23366E+00  0.36372E+00  0.53886E+00
+  0.75083E+00  0.10190E+01  0.13670E+01  0.18367E+01  0.24416E+01  0.32932E+01
+  0.43990E+01  0.58954E+01  0.79340E+01  0.65572E-07  0.87262E-07  0.12214E-06
+  0.19953E-06  0.32062E-06  0.47684E-06  0.25729E-06  0.13592E-06  0.14462E-05
+  0.94812E-05  0.36669E-04  0.14775E-03  0.36716E-03  0.78591E-03  0.22796E-02
+  0.64566E-02  0.16344E-01  0.39108E-01  0.80182E-01  0.12500E+00  0.20219E+00
+  0.31019E+00  0.48203E+00  0.71304E+00  0.99188E+00  0.13440E+01  0.18004E+01
+  0.24152E+01  0.32047E+01  0.43131E+01  0.57462E+01  0.76753E+01  0.10286E+02
+  0.19771E-06  0.26961E-06  0.32118E-06  0.48234E-06  0.88139E-06  0.15637E-05
+  0.18630E-05  0.14462E-05  0.47604E-06  0.50864E-05  0.26967E-04  0.12342E-03
+  0.33575E-03  0.75297E-03  0.23415E-02  0.68133E-02  0.17462E-01  0.40607E-01
+  0.88269E-01  0.16532E+00  0.26715E+00  0.40926E+00  0.63542E+00  0.93883E+00
+  0.13040E+01  0.17643E+01  0.23598E+01  0.31610E+01  0.41873E+01  0.56260E+01
+  0.74790E+01  0.99634E+01  0.13309E+02  0.31038E-06  0.37852E-06  0.44032E-06
+  0.90658E-06  0.21092E-05  0.39746E-05  0.80732E-05  0.94812E-05  0.50864E-05
+  0.32489E-05  0.27512E-04  0.13091E-03  0.37550E-03  0.83245E-03  0.25580E-02
+  0.74636E-02  0.18799E-01  0.43707E-01  0.92265E-01  0.18554E+00  0.35954E+00
+  0.54827E+00  0.84829E+00  0.12498E+01  0.17317E+01  0.23382E+01  0.31219E+01
+  0.41751E+01  0.55220E+01  0.74073E+01  0.98288E+01  0.13065E+02  0.17406E+02
+  0.60446E-06  0.86896E-06  0.13962E-05  0.29851E-05  0.69855E-05  0.12871E-04
+  0.22392E-04  0.36669E-04  0.26967E-04  0.27512E-04  0.40848E-04  0.14045E-03
+  0.41622E-03  0.94527E-03  0.28835E-02  0.82598E-02  0.20319E-01  0.46604E-01
+  0.97493E-01  0.19372E+00  0.40392E+00  0.73829E+00  0.11370E+01  0.16689E+01
+  0.23055E+01  0.31052E+01  0.41374E+01  0.55233E+01  0.72932E+01  0.97680E+01
+  0.12940E+02  0.17169E+02  0.22824E+02  0.33978E-05  0.73360E-05  0.12569E-04
+  0.24274E-04  0.54321E-04  0.98673E-04  0.12842E-03  0.14775E-03  0.12342E-03
+  0.13091E-03  0.14045E-03  0.26408E-03  0.32993E-03  0.79496E-03  0.28779E-02
+  0.86200E-02  0.21559E-01  0.49012E-01  0.10031E+00  0.19986E+00  0.41464E+00
+  0.81740E+00  0.15125E+01  0.22125E+01  0.30463E+01  0.40912E+01  0.54381E+01
+  0.72457E+01  0.95507E+01  0.12772E+02  0.16893E+02  0.22377E+02  0.29692E+02
+  0.23924E-04  0.30540E-04  0.61710E-04  0.11919E-03  0.19375E-03  0.26985E-03
+  0.31759E-03  0.36716E-03  0.33575E-03  0.37550E-03  0.41622E-03  0.32993E-03
+  0.10760E-02  0.72988E-03  0.27998E-02  0.91484E-02  0.22911E-01  0.51990E-01
+  0.10490E+00  0.20640E+00  0.43001E+00  0.84166E+00  0.16793E+01  0.29479E+01
+  0.40407E+01  0.54068E+01  0.71649E+01  0.95238E+01  0.12526E+02  0.16726E+02
+  0.22085E+02  0.29208E+02  0.38693E+02  0.10721E-03  0.13655E-03  0.17479E-03
+  0.26706E-03  0.41226E-03  0.59243E-03  0.68955E-03  0.78591E-03  0.75297E-03
+  0.83245E-03  0.94527E-03  0.79496E-03  0.72988E-03  0.36307E-02  0.27714E-02
+  0.98033E-02  0.24920E-01  0.56174E-01  0.11174E+00  0.21663E+00  0.44652E+00
+  0.87565E+00  0.17341E+01  0.32783E+01  0.53871E+01  0.71733E+01  0.94688E+01
+  0.12548E+02  0.16462E+02  0.21938E+02  0.28916E+02  0.38181E+02  0.50498E+02
+  0.46356E-03  0.58918E-03  0.75182E-03  0.10133E-02  0.12976E-02  0.16530E-02
+  0.20040E-02  0.22796E-02  0.23415E-02  0.25580E-02  0.28835E-02  0.28779E-02
+  0.27998E-02  0.27714E-02  0.10173E-01  0.80680E-02  0.23636E-01  0.56117E-01
+  0.11243E+00  0.21743E+00  0.44835E+00  0.87505E+00  0.17482E+01  0.32899E+01
+  0.58258E+01  0.93030E+01  0.12223E+02  0.16141E+02  0.21107E+02  0.28071E+02
+  0.36923E+02  0.48664E+02  0.64258E+02  0.14038E-02  0.17806E-02  0.22657E-02
+  0.30412E-02  0.41036E-02  0.49330E-02  0.56006E-02  0.64566E-02  0.68133E-02
+  0.74636E-02  0.82598E-02  0.86200E-02  0.91484E-02  0.98033E-02  0.80680E-02
+  0.28951E-01  0.18187E-01  0.49289E-01  0.10389E+00  0.20517E+00  0.43157E+00
+  0.84558E+00  0.16955E+01  0.32227E+01  0.56731E+01  0.97584E+01  0.15374E+02
+  0.20217E+02  0.26330E+02  0.34939E+02  0.45838E+02  0.60289E+02  0.79469E+02
+  0.33903E-02  0.42920E-02  0.54490E-02  0.72885E-02  0.97889E-02  0.13210E-01
+  0.15041E-01  0.16344E-01  0.17462E-01  0.18799E-01  0.20319E-01  0.21559E-01
+  0.22911E-01  0.24920E-01  0.23636E-01  0.18187E-01  0.74102E-01  0.40306E-01
+  0.89007E-01  0.18344E+00  0.40293E+00  0.80053E+00  0.16220E+01  0.30835E+01
+  0.54559E+01  0.93137E+01  0.15795E+02  0.24916E+02  0.32282E+02  0.42721E+02
+  0.55868E+02  0.73293E+02  0.96405E+02  0.67783E-02  0.85674E-02  0.10855E-01
+  0.14478E-01  0.19373E-01  0.26018E-01  0.34651E-01  0.39108E-01  0.40607E-01
+  0.43707E-01  0.46604E-01  0.49012E-01  0.51990E-01  0.56174E-01  0.56117E-01
+  0.49289E-01  0.40306E-01  0.17759E+00  0.77831E-01  0.15644E+00  0.35969E+00
+  0.73414E+00  0.15204E+01  0.29036E+01  0.51017E+01  0.87326E+01  0.14683E+02
+  0.24947E+02  0.38716E+02  0.51071E+02  0.66516E+02  0.86983E+02  0.11412E+03
+  0.11887E-01  0.15005E-01  0.18981E-01  0.25257E-01  0.33693E-01  0.45077E-01
+  0.59891E-01  0.80182E-01  0.88269E-01  0.92265E-01  0.97493E-01  0.10031E+00
+  0.10490E+00  0.11174E+00  0.11243E+00  0.10389E+00  0.89007E-01  0.77831E-01
+  0.38276E+00  0.15734E+00  0.34087E+00  0.69795E+00  0.14667E+01  0.28041E+01
+  0.48761E+01  0.82441E+01  0.13867E+02  0.23360E+02  0.38965E+02  0.61697E+02
+  0.79936E+02  0.10411E+03  0.13615E+03  0.18832E-01  0.23741E-01  0.29988E-01
+  0.39825E-01  0.52995E-01  0.70687E-01  0.93711E-01  0.12500E+00  0.16532E+00
+  0.18554E+00  0.19372E+00  0.19986E+00  0.20640E+00  0.21663E+00  0.21743E+00
+  0.20517E+00  0.18344E+00  0.15644E+00  0.15734E+00  0.19901E+00  0.35213E+00
+  0.68632E+00  0.14369E+01  0.27382E+01  0.46974E+01  0.78193E+01  0.12963E+02
+  0.21850E+02  0.36058E+02  0.61512E+02  0.95466E+02  0.12368E+03  0.16109E+03
+  0.30844E-01  0.38833E-01  0.48988E-01  0.64947E-01  0.86251E-01  0.11477E+00
+  0.15196E+00  0.20219E+00  0.26715E+00  0.35954E+00  0.40392E+00  0.41464E+00
+  0.43001E+00  0.44652E+00  0.44835E+00  0.43157E+00  0.40293E+00  0.35969E+00
+  0.34087E+00  0.35213E+00  0.43106E+00  0.69160E+00  0.13456E+01  0.25259E+01
+  0.42647E+01  0.69717E+01  0.11359E+02  0.18886E+02  0.31111E+02  0.52684E+02
+  0.87883E+02  0.13639E+03  0.17670E+03  0.47868E-01  0.60188E-01  0.75832E-01
+  0.10037E+00  0.13307E+00  0.17672E+00  0.23366E+00  0.31019E+00  0.40926E+00
+  0.54827E+00  0.73829E+00  0.81740E+00  0.84166E+00  0.87565E+00  0.87505E+00
+  0.84558E+00  0.80053E+00  0.73414E+00  0.69795E+00  0.68632E+00  0.69160E+00
+  0.88339E+00  0.14407E+01  0.25254E+01  0.41178E+01  0.65459E+01  0.10412E+02
+  0.16976E+02  0.27493E+02  0.46533E+02  0.76795E+02  0.12809E+03  0.19880E+03
+  0.75157E-01  0.94365E-01  0.11873E+00  0.15692E+00  0.20772E+00  0.27536E+00
+  0.36372E+00  0.48203E+00  0.63542E+00  0.84829E+00  0.11370E+01  0.15125E+01
+  0.16793E+01  0.17341E+01  0.17482E+01  0.16955E+01  0.16220E+01  0.15204E+01
+  0.14667E+01  0.14369E+01  0.13456E+01  0.14407E+01  0.18284E+01  0.27569E+01
+  0.41981E+01  0.63854E+01  0.98213E+01  0.15558E+02  0.24677E+02  0.40929E+02
+  0.67424E+02  0.11126E+03  0.18560E+03  0.11237E+00  0.14084E+00  0.17695E+00
+  0.23349E+00  0.30859E+00  0.40843E+00  0.53886E+00  0.71304E+00  0.93883E+00
+  0.12498E+01  0.16689E+01  0.22125E+01  0.29479E+01  0.32783E+01  0.32899E+01
+  0.32227E+01  0.30835E+01  0.29036E+01  0.28041E+01  0.27382E+01  0.25259E+01
+  0.25254E+01  0.27569E+01  0.35960E+01  0.50417E+01  0.72580E+01  0.10710E+02
+  0.16348E+02  0.25293E+02  0.40785E+02  0.66053E+02  0.10880E+03  0.17956E+03
+  0.15817E+00  0.19785E+00  0.24813E+00  0.32681E+00  0.43121E+00  0.56986E+00
+  0.75083E+00  0.99188E+00  0.13040E+01  0.17317E+01  0.23055E+01  0.30463E+01
+  0.40407E+01  0.53871E+01  0.58258E+01  0.56731E+01  0.54559E+01  0.51017E+01
+  0.48761E+01  0.46974E+01  0.42647E+01  0.41178E+01  0.41981E+01  0.50417E+01
+  0.66429E+01  0.91042E+01  0.12889E+02  0.18942E+02  0.28466E+02  0.44560E+02
+  0.70681E+02  0.11446E+03  0.18856E+03  0.21721E+00  0.27100E+00  0.33914E+00
+  0.44572E+00  0.58704E+00  0.77450E+00  0.10190E+01  0.13440E+01  0.17643E+01
+  0.23382E+01  0.31052E+01  0.40912E+01  0.54068E+01  0.71733E+01  0.93030E+01
+  0.97584E+01  0.93137E+01  0.87326E+01  0.82441E+01  0.78193E+01  0.69717E+01
+  0.65459E+01  0.63854E+01  0.72580E+01  0.91042E+01  0.11935E+02  0.16218E+02
+  0.22929E+02  0.33338E+02  0.50565E+02  0.78234E+02  0.12409E+03  0.20097E+03
+  0.29557E+00  0.36757E+00  0.45876E+00  0.60133E+00  0.79026E+00  0.10407E+01
+  0.13670E+01  0.18004E+01  0.23598E+01  0.31219E+01  0.41374E+01  0.54381E+01
+  0.71649E+01  0.94688E+01  0.12223E+02  0.15374E+02  0.15795E+02  0.14683E+02
+  0.13867E+02  0.12963E+02  0.11359E+02  0.10412E+02  0.98213E+01  0.10710E+02
+  0.12889E+02  0.16218E+02  0.21166E+02  0.28761E+02  0.40330E+02  0.59111E+02
+  0.88833E+02  0.13743E+03  0.21800E+03  0.40406E+00  0.50046E+00  0.62254E+00
+  0.81330E+00  0.10660E+01  0.14008E+01  0.18367E+01  0.24152E+01  0.31610E+01
+  0.41751E+01  0.55233E+01  0.72457E+01  0.95238E+01  0.12548E+02  0.16141E+02
+  0.20217E+02  0.24916E+02  0.24947E+02  0.23360E+02  0.21850E+02  0.18886E+02
+  0.16976E+02  0.15558E+02  0.16348E+02  0.18942E+02  0.22929E+02  0.28761E+02
+  0.37533E+02  0.50650E+02  0.71506E+02  0.10397E+03  0.15624E+03  0.24174E+03
+  0.54888E+00  0.67638E+00  0.83781E+00  0.10900E+01  0.14239E+01  0.18662E+01
+  0.24416E+01  0.32047E+01  0.41873E+01  0.55220E+01  0.72932E+01  0.95507E+01
+  0.12526E+02  0.16462E+02  0.21107E+02  0.26330E+02  0.32282E+02  0.38716E+02
+  0.38965E+02  0.36058E+02  0.31111E+02  0.27493E+02  0.24677E+02  0.25293E+02
+  0.28466E+02  0.33338E+02  0.40330E+02  0.50650E+02  0.65730E+02  0.89302E+02
+  0.12523E+03  0.18208E+03  0.27363E+03  0.76054E+00  0.93127E+00  0.11474E+01
+  0.14850E+01  0.19319E+01  0.25236E+01  0.32932E+01  0.43131E+01  0.56260E+01
+  0.74073E+01  0.97680E+01  0.12772E+02  0.16726E+02  0.21938E+02  0.28071E+02
+  0.34939E+02  0.42721E+02  0.51071E+02  0.61697E+02  0.61512E+02  0.52684E+02
+  0.46533E+02  0.40929E+02  0.40785E+02  0.44560E+02  0.50565E+02  0.59111E+02
+  0.71506E+02  0.89302E+02  0.11653E+03  0.15726E+03  0.22051E+03  0.32064E+03
+  0.10508E+01  0.12766E+01  0.15625E+01  0.20090E+01  0.25999E+01  0.33821E+01
+  0.43990E+01  0.57462E+01  0.74790E+01  0.98288E+01  0.12940E+02  0.16893E+02
+  0.22085E+02  0.28916E+02  0.36923E+02  0.45838E+02  0.55868E+02  0.66516E+02
+  0.79936E+02  0.95466E+02  0.87883E+02  0.76795E+02  0.67424E+02  0.66053E+02
+  0.70681E+02  0.78234E+02  0.88833E+02  0.10397E+03  0.12523E+03  0.15726E+03
+  0.20408E+03  0.27540E+03  0.38619E+03  0.14681E+01  0.17669E+01  0.21450E+01
+  0.27355E+01  0.35172E+01  0.45514E+01  0.58954E+01  0.76753E+01  0.99634E+01
+  0.13065E+02  0.17169E+02  0.22377E+02  0.29208E+02  0.38181E+02  0.48664E+02
+  0.60289E+02  0.73293E+02  0.86983E+02  0.10411E+03  0.12368E+03  0.13639E+03
+  0.12809E+03  0.11126E+03  0.10880E+03  0.11446E+03  0.12409E+03  0.13743E+03
+  0.15624E+03  0.18208E+03  0.22051E+03  0.27540E+03  0.35738E+03  0.48229E+03
+  0.20789E+01  0.24742E+01  0.29745E+01  0.37557E+01  0.47896E+01  0.61575E+01
+  0.79340E+01  0.10286E+02  0.13309E+02  0.17406E+02  0.22824E+02  0.29692E+02
+  0.38693E+02  0.50498E+02  0.64258E+02  0.79469E+02  0.96405E+02  0.11412E+03
+  0.13615E+03  0.16109E+03  0.17670E+03  0.19880E+03  0.18560E+03  0.17956E+03
+  0.18856E+03  0.20097E+03  0.21800E+03  0.24174E+03  0.27363E+03  0.32064E+03
+  0.38619E+03  0.48229E+03  0.62589E+03  0.23517E-09  0.49015E-09  0.95154E-09
+  0.19138E-08  0.32882E-08  0.68806E-08  0.36429E-07  0.69963E-07  0.20070E-06
+  0.33186E-06  0.60140E-06  0.28364E-06  0.30695E-04  0.14820E-03  0.52731E-03
+  0.11826E-03  0.25573E-02  0.37638E-04  0.81132E-02  0.12860E-01  0.28895E-01
+  0.48472E-01  0.79541E-01  0.12604E+00  0.19502E+00  0.29158E+00  0.44719E+00
+  0.66968E+00  0.10353E+01  0.16038E+01  0.25413E+01  0.41322E+01  0.69088E+01
+  0.34545E-09  0.47122E-09  0.85695E-09  0.21074E-08  0.37161E-08  0.72269E-08
+  0.54064E-07  0.95348E-07  0.26859E-06  0.40867E-06  0.80459E-06  0.63237E-06
+  0.39216E-04  0.18889E-03  0.67029E-03  0.14869E-03  0.32365E-02  0.44188E-04
+  0.10237E-01  0.16207E-01  0.36320E-01  0.60820E-01  0.99578E-01  0.15734E+00
+  0.24254E+00  0.36080E+00  0.54970E+00  0.81610E+00  0.12479E+01  0.19073E+01
+  0.29747E+01  0.47505E+01  0.77910E+01  0.64468E-09  0.68033E-09  0.91000E-09
+  0.20600E-08  0.42987E-08  0.85813E-08  0.71757E-07  0.13311E-06  0.32333E-06
+  0.49778E-06  0.12059E-05  0.10768E-05  0.78844E-04  0.24192E-03  0.85539E-03
+  0.18755E-03  0.41075E-02  0.51696E-04  0.12946E-01  0.20465E-01  0.45747E-01
+  0.76479E-01  0.12498E+00  0.19699E+00  0.30271E+00  0.44843E+00  0.67941E+00
+  0.10014E+01  0.15170E+01  0.22915E+01  0.35230E+01  0.55331E+01  0.89075E+01
+  0.17960E-08  0.16823E-08  0.16160E-08  0.19586E-08  0.38307E-08  0.97581E-08
+  0.98343E-07  0.22663E-06  0.50143E-06  0.96316E-06  0.22080E-05  0.21965E-05
+  0.14959E-03  0.37212E-03  0.11531E-02  0.24729E-03  0.54908E-02  0.57594E-04
+  0.17217E-01  0.27162E-01  0.60523E-01  0.10100E+00  0.16471E+00  0.25899E+00
+  0.39673E+00  0.58532E+00  0.88206E+00  0.12908E+01  0.19372E+01  0.28913E+01
+  0.43791E+01  0.67547E+01  0.10650E+02  0.31390E-08  0.41912E-08  0.38669E-08
+  0.32994E-08  0.34431E-08  0.93417E-08  0.13974E-06  0.34420E-06  0.94319E-06
+  0.20820E-05  0.60584E-05  0.50189E-05  0.24033E-03  0.57665E-03  0.14764E-02
+  0.32764E-03  0.73697E-02  0.62545E-04  0.22952E-01  0.36125E-01  0.80202E-01
+  0.13359E+00  0.21745E+00  0.34120E+00  0.52133E+00  0.76664E+00  0.11503E+01
+  0.16738E+01  0.24933E+01  0.36850E+01  0.55120E+01  0.83712E+01  0.12956E+02
+  0.77491E-08  0.70333E-08  0.10089E-07  0.84660E-08  0.77856E-08  0.75622E-08
+  0.16539E-06  0.51620E-06  0.16148E-05  0.42475E-05  0.12477E-04  0.86140E-05
+  0.33556E-03  0.82955E-03  0.18778E-02  0.38468E-03  0.99359E-02  0.60553E-04
+  0.30681E-01  0.48146E-01  0.10644E+00  0.17693E+00  0.28748E+00  0.45023E+00
+  0.68644E+00  0.10068E+01  0.15054E+01  0.21808E+01  0.32289E+01  0.47348E+01
+  0.70100E+01  0.10509E+02  0.16006E+02  0.36338E-07  0.56439E-07  0.69672E-07
+  0.91450E-07  0.12089E-06  0.13370E-06  0.69921E-07  0.29012E-06  0.19225E-05
+  0.81327E-05  0.26382E-04  0.78823E-05  0.40185E-03  0.99045E-03  0.22894E-02
+  0.27569E-03  0.11367E-01  0.46127E-03  0.40484E-01  0.63461E-01  0.13998E+00
+  0.23257E+00  0.37763E+00  0.59079E+00  0.89950E+00  0.13166E+01  0.19640E+01
+  0.28350E+01  0.41787E+01  0.60897E+01  0.89429E+01  0.13264E+02  0.19932E+02
+  0.76809E-07  0.10495E-06  0.14503E-06  0.24222E-06  0.33626E-06  0.45236E-06
+  0.17983E-06  0.17384E-06  0.13971E-05  0.94850E-05  0.49818E-04  0.27563E-04
+  0.47437E-03  0.11537E-02  0.26139E-02  0.19757E-03  0.12232E-01  0.10258E-02
+  0.53887E-01  0.84236E-01  0.18502E+00  0.30695E+00  0.49778E+00  0.77775E+00
+  0.11824E+01  0.17275E+01  0.25716E+01  0.37017E+01  0.54366E+01  0.78840E+01
+  0.11502E+02  0.16914E+02  0.25137E+02  0.23500E-06  0.29769E-06  0.37435E-06
+  0.55597E-06  0.95532E-06  0.14876E-05  0.15359E-05  0.12473E-05  0.55846E-06
+  0.49980E-05  0.41313E-04  0.10276E-03  0.46770E-03  0.11893E-02  0.27254E-02
+  0.34600E-03  0.12843E-01  0.24894E-02  0.60110E-01  0.11001E+00  0.24129E+00
+  0.40055E+00  0.64969E+00  0.10147E+01  0.15416E+01  0.22493E+01  0.33441E+01
+  0.48031E+01  0.70359E+01  0.10165E+02  0.14755E+02  0.21554E+02  0.31748E+02
+  0.35685E-06  0.41057E-06  0.57902E-06  0.11187E-05  0.22182E-05  0.35986E-05
+  0.65618E-05  0.81942E-05  0.49107E-05  0.34224E-05  0.38479E-04  0.14300E-03
+  0.53702E-03  0.13450E-02  0.29893E-02  0.49956E-03  0.13731E-01  0.30784E-02
+  0.62370E-01  0.12750E+00  0.32214E+00  0.53283E+00  0.86188E+00  0.13432E+01
+  0.20368E+01  0.29664E+01  0.44026E+01  0.63103E+01  0.92218E+01  0.13281E+02
+  0.19200E+02  0.27893E+02  0.40790E+02  0.74260E-06  0.10534E-05  0.20508E-05
+  0.36492E-05  0.75532E-05  0.12309E-04  0.18763E-04  0.30522E-04  0.24875E-04
+  0.27598E-04  0.49686E-04  0.19965E-03  0.61079E-03  0.15656E-02  0.33807E-02
+  0.70243E-03  0.14779E-01  0.37073E-02  0.65507E-01  0.13248E+00  0.43221E+00
+  0.71142E+00  0.11465E+01  0.17818E+01  0.26956E+01  0.39179E+01  0.58048E+01
+  0.83046E+01  0.12111E+02  0.17398E+02  0.25068E+02  0.36262E+02  0.52725E+02
+  0.54581E-05  0.10054E-04  0.16174E-04  0.31586E-04  0.58169E-04  0.94543E-04
+  0.11535E-03  0.13496E-03  0.11240E-03  0.11389E-03  0.10790E-03  0.71535E-03
+  0.53041E-03  0.15182E-02  0.34703E-02  0.16630E-02  0.15215E-01  0.62734E-02
+  0.65867E-01  0.13450E+00  0.48801E+00  0.93310E+00  0.15014E+01  0.23294E+01
+  0.35189E+01  0.51058E+01  0.75564E+01  0.10793E+02  0.15718E+02  0.22536E+02
+  0.32392E+02  0.46705E+02  0.67614E+02  0.27395E-04  0.44941E-04  0.85584E-04
+  0.13927E-03  0.20039E-03  0.26271E-03  0.29457E-03  0.34249E-03  0.31399E-03
+  0.33555E-03  0.32298E-03  0.91435E-03  0.12993E-02  0.14980E-02  0.34955E-02
+  0.29903E-02  0.15676E-01  0.94068E-02  0.67130E-01  0.13621E+00  0.49385E+00
+  0.11200E+01  0.19738E+01  0.30542E+01  0.46035E+01  0.66642E+01  0.98494E+01
+  0.14044E+02  0.20427E+02  0.29236E+02  0.41939E+02  0.60314E+02  0.87022E+02
+  0.12263E-03  0.15652E-03  0.20661E-03  0.30296E-03  0.43045E-03  0.58239E-03
+  0.64445E-03  0.74377E-03  0.71471E-03  0.76589E-03  0.78148E-03  0.17356E-02
+  0.67320E-03  0.59540E-02  0.35733E-02  0.48373E-02  0.16418E-01  0.13397E-01
+  0.69585E-01  0.13993E+00  0.50545E+00  0.11364E+01  0.25160E+01  0.40199E+01
+  0.60394E+01  0.87167E+01  0.12860E+02  0.18299E+02  0.26581E+02  0.37982E+02
+  0.54390E+02  0.78057E+02  0.11232E+03  0.52965E-03  0.67425E-03  0.86122E-03
+  0.11032E-02  0.13293E-02  0.16215E-02  0.19237E-02  0.21832E-02  0.22618E-02
+  0.24433E-02  0.25943E-02  0.43366E-02  0.21940E-02  0.19498E-02  0.11097E-01
+  0.10673E-01  0.13544E-01  0.25242E-01  0.63869E-01  0.13095E+00  0.47671E+00
+  0.10945E+01  0.24220E+01  0.50702E+01  0.76138E+01  0.10965E+02  0.16176E+02
+  0.22979E+02  0.33373E+02  0.47641E+02  0.68156E+02  0.97700E+02  0.14036E+03
+  0.16021E-02  0.20346E-02  0.25905E-02  0.33062E-02  0.42358E-02  0.48805E-02
+  0.53868E-02  0.62970E-02  0.66329E-02  0.72440E-02  0.77966E-02  0.10759E-01
+  0.80895E-02  0.74615E-02  0.70264E-02  0.87111E-01  0.10567E-01  0.49670E-01
+  0.48259E-01  0.10566E+00  0.40777E+00  0.96714E+00  0.22029E+01  0.47346E+01
+  0.91488E+01  0.13163E+02  0.19469E+02  0.27622E+02  0.40169E+02  0.57327E+02
+  0.82003E+02  0.11754E+03  0.16879E+03  0.38653E-02  0.48985E-02  0.62203E-02
+  0.79142E-02  0.10099E-01  0.12925E-01  0.14725E-01  0.15974E-01  0.17191E-01
+  0.18387E-01  0.19564E-01  0.24879E-01  0.21277E-01  0.21331E-01  0.21626E-01
+  0.48353E-01  0.75249E-01  0.90749E-01  0.39893E-01  0.79732E-01  0.31929E+00
+  0.79735E+00  0.18890E+01  0.41592E+01  0.87505E+01  0.15239E+02  0.22652E+02
+  0.32104E+02  0.46823E+02  0.66844E+02  0.95676E+02  0.13723E+03  0.19719E+03
+  0.77216E-02  0.97674E-02  0.12376E-01  0.15706E-01  0.19979E-01  0.25471E-01
+  0.32649E-01  0.38583E-01  0.40021E-01  0.43048E-01  0.45318E-01  0.54250E-01
+  0.49427E-01  0.50741E-01  0.53125E-01  0.94191E-01  0.58157E-01  0.51435E+00
+  0.65859E-01  0.87003E-01  0.25217E+00  0.61860E+00  0.15098E+01  0.34337E+01
+  0.73539E+01  0.14687E+02  0.25156E+02  0.35631E+02  0.52234E+02  0.74657E+02
+  0.10704E+03  0.15382E+03  0.22144E+03  0.13532E-01  0.17092E-01  0.21617E-01
+  0.27377E-01  0.34734E-01  0.44147E-01  0.56530E-01  0.76162E-01  0.87464E-01
+  0.91082E-01  0.95425E-01  0.10891E+00  0.10083E+00  0.10332E+00  0.10793E+00
+  0.16974E+00  0.12022E+00  0.26686E+00  0.13227E+00  0.14770E+00  0.27728E+00
+  0.55879E+00  0.12872E+01  0.29049E+01  0.63045E+01  0.12548E+02  0.26199E+02
+  0.39901E+02  0.58699E+02  0.83919E+02  0.12044E+03  0.17334E+03  0.25000E+03
+  0.21423E-01  0.27022E-01  0.34125E-01  0.43139E-01  0.54618E-01  0.69247E-01
+  0.88571E-01  0.11890E+00  0.15828E+00  0.18367E+00  0.19014E+00  0.21412E+00
+  0.19983E+00  0.20329E+00  0.21048E+00  0.30427E+00  0.23201E+00  0.44333E+00
+  0.25683E+00  0.27617E+00  0.40505E+00  0.62806E+00  0.12238E+01  0.25832E+01
+  0.54606E+01  0.10875E+02  0.22496E+02  0.43803E+02  0.65521E+02  0.93509E+02
+  0.13415E+03  0.19317E+03  0.27889E+03  0.35060E-01  0.44169E-01  0.55701E-01
+  0.70318E-01  0.88877E-01  0.11246E+00  0.14379E+00  0.19257E+00  0.25612E+00
+  0.34619E+00  0.39800E+00  0.43786E+00  0.41919E+00  0.42490E+00  0.43734E+00
+  0.58499E+00  0.47821E+00  0.79558E+00  0.53834E+00  0.58202E+00  0.77773E+00
+  0.98020E+00  0.14611E+01  0.25624E+01  0.48858E+01  0.93003E+01  0.18761E+02
+  0.35791E+02  0.69071E+02  0.97781E+02  0.13950E+03  0.20012E+03  0.28827E+03
+  0.54372E-01  0.68408E-01  0.86163E-01  0.10863E+00  0.13709E+00  0.17319E+00
+  0.22128E+00  0.29569E+00  0.39271E+00  0.52860E+00  0.71260E+00  0.85638E+00
+  0.82350E+00  0.84008E+00  0.85717E+00  0.10887E+01  0.91763E+00  0.13961E+01
+  0.10168E+01  0.10940E+01  0.14140E+01  0.16798E+01  0.21966E+01  0.33040E+01
+  0.55467E+01  0.98621E+01  0.18516E+02  0.34606E+02  0.66701E+02  0.11644E+03
+  0.16340E+03  0.23123E+03  0.32930E+03  0.85300E-01  0.10717E+00  0.13481E+00
+  0.16974E+00  0.21396E+00  0.26992E+00  0.34469E+00  0.45982E+00  0.61020E+00
+  0.81876E+00  0.10997E+01  0.15475E+01  0.16492E+01  0.16752E+01  0.17187E+01
+  0.20888E+01  0.18080E+01  0.25480E+01  0.19692E+01  0.21040E+01  0.26546E+01
+  0.30969E+01  0.38295E+01  0.52409E+01  0.79125E+01  0.13100E+02  0.22479E+02
+  0.40601E+02  0.74313E+02  0.13829E+03  0.22407E+03  0.30914E+03  0.43025E+03
+  0.12740E+00  0.15983E+00  0.20076E+00  0.25246E+00  0.31781E+00  0.40040E+00
+  0.51096E+00  0.68055E+00  0.90205E+00  0.12071E+01  0.16161E+01  0.22539E+01
+  0.28731E+01  0.31802E+01  0.32415E+01  0.38695E+01  0.33834E+01  0.45313E+01
+  0.35893E+01  0.37757E+01  0.45773E+01  0.52287E+01  0.62710E+01  0.81911E+01
+  0.11687E+02  0.18437E+02  0.29932E+02  0.52291E+02  0.92787E+02  0.16865E+03
+  0.31153E+03  0.47196E+03  0.64453E+03  0.17913E+00  0.22429E+00  0.28128E+00
+  0.35319E+00  0.44402E+00  0.55873E+00  0.71221E+00  0.94705E+00  0.12535E+01
+  0.16735E+01  0.22341E+01  0.30981E+01  0.39423E+01  0.52183E+01  0.57444E+01
+  0.67417E+01  0.59459E+01  0.77293E+01  0.61156E+01  0.63045E+01  0.72629E+01
+  0.80243E+01  0.92717E+01  0.11605E+02  0.15828E+02  0.23945E+02  0.37359E+02
+  0.63317E+02  0.10921E+03  0.19693E+03  0.35721E+03  0.66004E+03  0.94246E+03
+  0.24562E+00  0.30683E+00  0.38406E+00  0.48144E+00  0.60437E+00  0.75946E+00
+  0.96687E+00  0.12837E+01  0.16964E+01  0.22603E+01  0.30103E+01  0.41580E+01
+  0.52778E+01  0.69544E+01  0.92066E+01  0.11536E+02  0.10124E+02  0.13046E+02
+  0.10236E+02  0.10351E+02  0.11348E+02  0.12096E+02  0.13423E+02  0.16069E+02
+  0.20928E+02  0.30297E+02  0.45401E+02  0.74408E+02  0.12470E+03  0.21992E+03
+  0.39773E+03  0.72198E+03  0.13351E+04  0.33360E+00  0.41552E+00  0.51885E+00
+  0.64909E+00  0.81343E+00  0.10206E+01  0.12975E+01  0.17200E+01  0.22696E+01
+  0.30185E+01  0.40121E+01  0.55255E+01  0.69962E+01  0.91838E+01  0.12098E+02
+  0.18309E+02  0.17135E+02  0.21806E+02  0.17124E+02  0.17031E+02  0.17863E+02
+  0.18405E+02  0.19633E+02  0.22483E+02  0.27939E+02  0.38610E+02  0.55398E+02
+  0.87410E+02  0.14181E+03  0.24366E+03  0.43205E+03  0.78188E+03  0.14253E+04
+  0.45497E+00  0.56466E+00  0.70295E+00  0.87721E+00  0.10970E+01  0.13740E+01
+  0.17439E+01  0.23080E+01  0.30407E+01  0.40378E+01  0.53573E+01  0.73600E+01
+  0.93020E+01  0.12175E+02  0.15978E+02  0.24017E+02  0.27433E+02  0.36791E+02
+  0.28744E+02  0.28506E+02  0.28834E+02  0.28858E+02  0.29721E+02  0.32661E+02
+  0.38772E+02  0.51099E+02  0.69996E+02  0.10587E+03  0.16545E+03  0.27561E+03
+  0.47661E+03  0.84935E+03  0.15382E+04  0.61623E+00  0.76128E+00  0.94406E+00
+  0.11745E+01  0.14649E+01  0.18307E+01  0.23191E+01  0.30632E+01  0.40288E+01
+  0.53413E+01  0.70753E+01  0.97022E+01  0.12236E+02  0.15974E+02  0.20894E+02
+  0.31274E+02  0.35529E+02  0.58390E+02  0.47878E+02  0.47053E+02  0.46579E+02
+  0.45403E+02  0.45263E+02  0.47861E+02  0.54395E+02  0.68417E+02  0.89384E+02
+  0.12919E+03  0.19376E+03  0.31149E+03  0.52305E+03  0.91050E+03  0.16315E+04
+  0.85073E+00  0.10450E+01  0.12897E+01  0.15981E+01  0.19866E+01  0.24762E+01
+  0.31294E+01  0.41242E+01  0.54144E+01  0.71664E+01  0.94780E+01  0.12971E+02
+  0.16341E+02  0.21294E+02  0.27790E+02  0.41404E+02  0.46951E+02  0.76547E+02
+  0.77748E+02  0.79748E+02  0.78126E+02  0.74693E+02  0.72615E+02  0.74361E+02
+  0.81295E+02  0.97832E+02  0.12191E+03  0.16804E+03  0.24083E+03  0.37172E+03
+  0.60273E+03  0.10193E+04  0.17847E+04  0.11701E+01  0.14269E+01  0.17507E+01
+  0.21585E+01  0.26724E+01  0.33194E+01  0.41826E+01  0.54965E+01  0.71996E+01
+  0.95109E+01  0.12557E+02  0.17158E+02  0.21579E+02  0.28069E+02  0.36553E+02
+  0.54315E+02  0.61384E+02  0.99657E+02  0.10067E+03  0.12820E+03  0.12896E+03
+  0.12237E+03  0.11630E+03  0.11574E+03  0.12222E+03  0.14125E+03  0.16828E+03
+  0.22125E+03  0.30255E+03  0.44684E+03  0.69660E+03  0.11394E+04  0.19413E+04
+  0.16259E+01  0.19657E+01  0.23940E+01  0.29333E+01  0.36129E+01  0.44686E+01
+  0.56090E+01  0.73454E+01  0.95943E+01  0.12645E+02  0.16664E+02  0.22730E+02
+  0.28541E+02  0.37061E+02  0.48177E+02  0.71432E+02  0.80516E+02  0.13028E+03
+  0.13104E+03  0.16596E+03  0.21474E+03  0.20205E+03  0.18984E+03  0.18451E+03
+  0.18915E+03  0.21092E+03  0.24110E+03  0.30290E+03  0.39502E+03  0.55685E+03
+  0.83123E+03  0.13084E+04  0.21585E+04  0.22877E+01  0.27373E+01  0.33038E+01
+  0.40173E+01  0.49162E+01  0.60480E+01  0.75552E+01  0.98502E+01  0.12821E+02
+  0.16852E+02  0.22156E+02  0.30164E+02  0.37811E+02  0.49020E+02  0.63613E+02
+  0.94147E+02  0.10589E+03  0.17088E+03  0.17130E+03  0.21601E+03  0.34492E+03
+  0.33550E+03  0.31361E+03  0.30008E+03  0.30012E+03  0.32454E+03  0.35757E+03
+  0.43064E+03  0.53636E+03  0.72104E+03  0.10277E+04  0.15502E+04  0.24637E+04
+  0.23612E-09  0.30758E-09  0.61780E-09  0.11089E-08  0.21248E-08  0.42285E-08
+  0.23937E-07  0.48428E-07  0.28848E-07  0.18679E-06  0.33422E-06  0.24346E-04
+  0.14612E-03  0.33722E-04  0.62573E-03  0.10283E-02  0.16214E-02  0.23768E-02
+  0.32408E-02  0.44808E-02  0.61300E-02  0.84349E-02  0.11203E-01  0.15094E-01
+  0.19369E-01  0.26150E-01  0.33173E-01  0.43755E-01  0.55932E-01  0.74579E-01
+  0.95780E-01  0.12837E+00  0.16708E+00  0.68213E-09  0.47311E-09  0.78550E-09
+  0.13622E-08  0.26633E-08  0.54294E-08  0.29979E-07  0.67716E-07  0.49568E-07
+  0.34196E-06  0.48640E-06  0.32137E-04  0.19008E-03  0.43334E-04  0.80490E-03
+  0.13170E-02  0.20696E-02  0.30244E-02  0.41123E-02  0.56719E-02  0.77420E-02
+  0.10628E-01  0.14086E-01  0.18932E-01  0.24232E-01  0.32617E-01  0.41235E-01
+  0.54165E-01  0.68906E-01  0.91342E-01  0.11650E+00  0.15488E+00  0.19969E+00
+  0.12966E-08  0.11926E-08  0.91657E-09  0.18306E-08  0.35732E-08  0.65090E-08
+  0.46579E-07  0.10609E-06  0.85140E-07  0.55150E-06  0.12154E-05  0.43556E-04
+  0.24927E-03  0.56059E-04  0.10412E-02  0.16946E-02  0.26523E-02  0.38610E-02
+  0.52333E-02  0.71978E-02  0.98008E-02  0.13422E-01  0.17750E-01  0.23801E-01
+  0.30393E-01  0.40801E-01  0.51428E-01  0.67317E-01  0.85284E-01  0.11250E+00
+  0.14264E+00  0.18831E+00  0.24082E+00  0.29805E-08  0.28715E-08  0.21733E-08
+  0.22074E-08  0.44666E-08  0.86528E-08  0.91832E-07  0.22100E-06  0.19333E-06
+  0.79599E-06  0.21658E-05  0.66068E-04  0.32971E-03  0.72593E-04  0.13552E-02
+  0.21918E-02  0.34140E-02  0.49478E-02  0.66807E-02  0.91593E-02  0.12436E-01
+  0.16986E-01  0.22413E-01  0.29984E-01  0.38203E-01  0.51162E-01  0.64320E-01
+  0.83934E-01  0.10597E+00  0.13919E+00  0.17561E+00  0.23046E+00  0.29266E+00
+  0.48921E-08  0.57872E-08  0.47899E-08  0.42738E-08  0.62243E-08  0.12770E-07
+  0.18353E-06  0.54173E-06  0.33005E-06  0.11108E-05  0.33982E-05  0.98482E-04
+  0.43468E-03  0.94889E-04  0.17781E-02  0.28540E-02  0.44196E-02  0.63705E-02
+  0.85623E-02  0.11694E-01  0.15827E-01  0.21551E-01  0.28366E-01  0.37856E-01
+  0.48126E-01  0.64301E-01  0.80648E-01  0.10496E+00  0.13211E+00  0.17291E+00
+  0.21723E+00  0.28364E+00  0.35804E+00  0.12457E-07  0.10752E-07  0.11724E-07
+  0.12684E-07  0.10667E-07  0.16768E-07  0.33737E-06  0.11445E-05  0.43503E-06
+  0.13259E-05  0.42746E-05  0.14333E-03  0.51965E-03  0.12284E-03  0.23538E-02
+  0.37441E-02  0.57579E-02  0.82459E-02  0.11023E-01  0.14987E-01  0.20206E-01
+  0.27415E-01  0.35984E-01  0.47894E-01  0.60749E-01  0.80977E-01  0.10133E+00
+  0.13155E+00  0.16514E+00  0.21547E+00  0.26975E+00  0.35069E+00  0.44045E+00
+  0.10280E-06  0.11357E-06  0.11166E-06  0.14775E-06  0.23269E-06  0.31680E-06
+  0.32641E-06  0.14153E-05  0.44388E-05  0.74319E-05  0.69243E-05  0.17463E-03
+  0.62149E-03  0.93212E-04  0.31060E-02  0.49796E-02  0.76152E-02  0.10839E-01
+  0.14403E-01  0.19490E-01  0.26171E-01  0.35370E-01  0.46286E-01  0.61426E-01
+  0.77720E-01  0.10335E+00  0.12904E+00  0.16711E+00  0.20926E+00  0.27225E+00
+  0.33973E+00  0.43995E+00  0.55003E+00  0.26377E-06  0.34636E-06  0.32445E-06
+  0.30020E-06  0.35849E-06  0.71195E-06  0.12590E-05  0.25658E-05  0.12162E-04
+  0.19469E-04  0.21555E-04  0.22828E-03  0.78854E-03  0.79386E-04  0.35156E-02
+  0.67222E-02  0.10754E-01  0.15146E-01  0.19936E-01  0.26767E-01  0.35709E-01
+  0.47962E-01  0.62478E-01  0.82548E-01  0.10409E+00  0.13797E+00  0.17176E+00
+  0.22179E+00  0.27696E+00  0.35924E+00  0.44681E+00  0.57641E+00  0.71751E+00
+  0.74005E-06  0.10980E-05  0.14493E-05  0.16219E-05  0.13049E-05  0.11486E-05
+  0.49676E-05  0.11903E-04  0.41036E-04  0.60001E-04  0.74040E-04  0.26045E-03
+  0.92219E-03  0.11580E-03  0.40140E-02  0.73863E-02  0.13768E-01  0.21205E-01
+  0.27621E-01  0.36770E-01  0.48699E-01  0.64947E-01  0.84165E-01  0.11064E+00
+  0.13896E+00  0.18353E+00  0.22779E+00  0.29323E+00  0.36521E+00  0.47236E+00
+  0.58581E+00  0.75325E+00  0.93422E+00  0.17293E-05  0.27263E-05  0.60074E-05
+  0.80209E-05  0.10261E-04  0.93731E-05  0.43735E-05  0.19498E-04  0.67123E-04
+  0.98552E-04  0.11981E-03  0.32747E-03  0.11270E-02  0.18183E-03  0.47440E-02
+  0.85631E-02  0.15378E-01  0.26650E-01  0.39401E-01  0.51806E-01  0.67894E-01
+  0.89651E-01  0.11532E+00  0.15053E+00  0.18807E+00  0.24721E+00  0.30567E+00
+  0.39204E+00  0.48682E+00  0.62775E+00  0.77636E+00  0.99519E+00  0.12303E+01
+  0.52055E-05  0.91189E-05  0.19785E-04  0.35195E-04  0.56396E-04  0.67851E-04
+  0.53175E-04  0.46233E-04  0.11390E-03  0.16810E-03  0.20979E-03  0.40430E-03
+  0.13621E-02  0.34558E-03  0.56449E-02  0.99462E-02  0.17575E-01  0.29819E-01
+  0.47530E-01  0.73937E-01  0.95680E-01  0.12482E+00  0.15909E+00  0.20590E+00
+  0.25558E+00  0.33397E+00  0.41103E+00  0.52490E+00  0.64959E+00  0.83487E+00
+  0.10296E+01  0.13158E+01  0.16220E+01  0.52808E-05  0.85948E-05  0.11486E-04
+  0.13304E-04  0.14377E-04  0.14171E-04  0.17741E-04  0.49076E-04  0.16016E-04
+  0.16005E-04  0.14710E-04  0.91605E-03  0.23916E-02  0.35237E-03  0.79935E-02
+  0.13304E-01  0.22318E-01  0.36995E-01  0.57272E-01  0.91372E-01  0.14480E+00
+  0.18535E+00  0.23276E+00  0.29732E+00  0.36551E+00  0.47313E+00  0.57861E+00
+  0.73450E+00  0.90478E+00  0.11578E+01  0.14228E+01  0.18123E+01  0.22275E+01
+  0.21947E-03  0.28281E-03  0.34668E-03  0.40763E-03  0.46661E-03  0.51994E-03
+  0.52611E-03  0.52728E-03  0.69837E-03  0.83988E-03  0.13233E-02  0.41907E-03
+  0.17301E-02  0.17881E-02  0.79418E-02  0.13663E-01  0.23146E-01  0.38438E-01
+  0.59584E-01  0.94383E-01  0.14957E+00  0.23940E+00  0.30729E+00  0.38870E+00
+  0.47403E+00  0.60972E+00  0.74096E+00  0.93513E+00  0.11473E+01  0.14623E+01
+  0.17913E+01  0.22740E+01  0.27872E+01  0.53658E-03  0.73384E-03  0.86136E-03
+  0.10077E-02  0.11373E-02  0.12387E-02  0.12627E-02  0.13155E-02  0.16389E-02
+  0.18033E-02  0.21007E-02  0.24248E-02  0.17036E-02  0.36507E-02  0.92548E-02
+  0.16023E-01  0.27060E-01  0.44338E-01  0.67383E-01  0.10586E+00  0.16553E+00
+  0.25937E+00  0.40243E+00  0.53897E+00  0.64958E+00  0.82674E+00  0.99600E+00
+  0.12469E+01  0.15207E+01  0.19276E+01  0.23513E+01  0.29723E+01  0.36311E+01
+  0.13993E-02  0.16815E-02  0.20461E-02  0.23154E-02  0.26026E-02  0.28014E-02
+  0.28214E-02  0.28630E-02  0.35250E-02  0.38141E-02  0.41370E-02  0.18051E-02
+  0.20366E-02  0.67397E-02  0.10977E-01  0.19298E-01  0.32632E-01  0.52814E-01
+  0.78617E-01  0.12112E+00  0.18715E+00  0.28894E+00  0.43935E+00  0.67980E+00
+  0.90465E+00  0.11363E+01  0.13541E+01  0.16780E+01  0.20312E+01  0.25568E+01
+  0.31022E+01  0.39013E+01  0.47477E+01  0.33107E-03  0.38401E-03  0.41905E-03
+  0.46477E-03  0.49677E-03  0.51535E-03  0.29301E-03  0.18596E-03  0.58228E-03
+  0.60027E-03  0.53485E-03  0.45573E-02  0.13142E-01  0.63262E-03  0.27220E-01
+  0.40528E-01  0.60617E-01  0.89765E-01  0.12607E+00  0.18360E+00  0.27015E+00
+  0.40197E+00  0.59556E+00  0.89070E+00  0.13059E+01  0.18688E+01  0.21917E+01
+  0.26748E+01  0.31996E+01  0.39824E+01  0.47941E+01  0.59867E+01  0.72466E+01
+  0.71358E-02  0.90587E-02  0.10821E-01  0.11452E-01  0.12262E-01  0.13090E-01
+  0.13253E-01  0.13457E-01  0.15032E-01  0.15947E-01  0.16769E-01  0.10656E-01
+  0.76972E-02  0.23870E-01  0.15609E-01  0.27907E-01  0.49116E-01  0.79277E-01
+  0.11402E+00  0.16963E+00  0.25216E+00  0.37343E+00  0.55215E+00  0.82592E+00
+  0.11914E+01  0.18266E+01  0.25731E+01  0.31009E+01  0.36765E+01  0.45376E+01
+  0.54238E+01  0.67230E+01  0.80951E+01  0.10472E-03  0.12326E-03  0.13250E-03
+  0.13627E-03  0.10133E-03  0.77506E-04  0.91331E-03  0.18096E-02  0.12877E-03
+  0.21069E-03  0.55791E-03  0.14700E-01  0.27680E-01  0.40466E-02  0.67187E-01
+  0.18227E+00  0.13044E+00  0.18127E+00  0.23914E+00  0.32703E+00  0.45253E+00
+  0.63206E+00  0.88822E+00  0.12720E+01  0.17980E+01  0.26553E+01  0.37899E+01
+  0.56474E+01  0.65890E+01  0.79889E+01  0.94306E+01  0.11561E+02  0.13804E+02
+  0.22513E-01  0.28474E-01  0.36048E-01  0.45710E-01  0.58057E-01  0.61243E-01
+  0.61433E-01  0.62131E-01  0.66312E-01  0.68137E-01  0.70167E-01  0.53457E-01
+  0.44624E-01  0.85767E-01  0.28401E-01  0.41835E-01  0.72105E-01  0.11987E+00
+  0.17063E+00  0.25049E+00  0.36303E+00  0.51543E+00  0.73225E+00  0.10438E+01
+  0.14591E+01  0.21663E+01  0.30489E+01  0.44593E+01  0.64884E+01  0.81290E+01
+  0.94978E+01  0.11513E+02  0.13637E+02  0.35583E-01  0.44946E-01  0.56814E-01
+  0.71907E-01  0.91126E-01  0.11565E+00  0.12658E+00  0.12748E+00  0.13567E+00
+  0.13922E+00  0.14231E+00  0.11381E+00  0.99006E-01  0.16589E+00  0.57670E-01
+  0.64949E-01  0.92927E-01  0.14950E+00  0.21123E+00  0.30958E+00  0.44589E+00
+  0.62264E+00  0.86922E+00  0.12098E+01  0.16514E+01  0.23956E+01  0.33237E+01
+  0.47703E+01  0.67924E+01  0.10104E+02  0.12670E+02  0.15128E+02  0.17719E+02
+  0.79443E-01  0.10014E+00  0.12630E+00  0.15943E+00  0.20141E+00  0.25466E+00
+  0.31830E+00  0.39912E+00  0.50082E+00  0.51089E+00  0.52231E+00  0.44327E+00
+  0.39722E+00  0.57409E+00  0.25292E+00  0.20803E+00  0.20322E+00  0.28790E+00
+  0.37534E+00  0.52742E+00  0.74101E+00  0.10008E+01  0.13506E+01  0.17948E+01
+  0.23344E+01  0.32262E+01  0.42551E+01  0.58321E+01  0.80393E+01  0.11511E+02
+  0.16082E+02  0.23358E+02  0.31012E+02  0.13259E+00  0.16696E+00  0.21035E+00
+  0.26520E+00  0.33459E+00  0.42242E+00  0.52810E+00  0.66190E+00  0.85807E+00
+  0.10896E+01  0.11818E+01  0.10303E+01  0.95456E+00  0.12828E+01  0.66723E+00
+  0.54562E+00  0.45585E+00  0.46148E+00  0.59667E+00  0.76064E+00  0.10189E+01
+  0.13386E+01  0.17691E+01  0.22928E+01  0.29016E+01  0.39026E+01  0.49875E+01
+  0.66088E+01  0.88438E+01  0.12309E+02  0.16948E+02  0.23910E+02  0.33561E+02
+  0.21615E+00  0.27188E+00  0.34215E+00  0.43093E+00  0.54305E+00  0.68476E+00
+  0.85611E+00  0.10726E+01  0.13832E+01  0.17519E+01  0.22177E+01  0.23353E+01
+  0.21941E+01  0.28315E+01  0.16513E+01  0.13866E+01  0.11256E+01  0.99250E+00
+  0.10182E+01  0.12860E+01  0.15616E+01  0.19406E+01  0.24672E+01  0.30964E+01
+  0.38021E+01  0.49583E+01  0.61342E+01  0.78464E+01  0.10168E+02  0.13678E+02
+  0.18266E+02  0.25218E+02  0.34653E+02  0.33953E+00  0.42650E+00  0.53614E+00
+  0.67451E+00  0.84911E+00  0.10695E+01  0.13368E+01  0.16739E+01  0.21509E+01
+  0.27188E+01  0.34342E+01  0.38561E+01  0.47833E+01  0.59792E+01  0.37789E+01
+  0.32455E+01  0.26570E+01  0.22428E+01  0.21405E+01  0.21756E+01  0.27455E+01
+  0.31811E+01  0.38315E+01  0.46177E+01  0.54813E+01  0.68902E+01  0.82461E+01
+  0.10170E+02  0.12733E+02  0.16508E+02  0.21322E+02  0.28414E+02  0.38092E+02
+  0.51918E+00  0.65113E+00  0.81740E+00  0.10271E+01  0.12916E+01  0.16251E+01
+  0.20303E+01  0.25407E+01  0.32561E+01  0.41094E+01  0.51820E+01  0.58627E+01
+  0.86334E+01  0.12363E+02  0.81189E+01  0.71348E+01  0.59538E+01  0.49721E+01
+  0.45893E+01  0.43718E+01  0.45370E+01  0.57239E+01  0.65268E+01  0.75429E+01
+  0.86541E+01  0.10464E+02  0.12128E+02  0.14434E+02  0.17451E+02  0.21780E+02
+  0.27168E+02  0.34884E+02  0.45251E+02  0.76393E+00  0.95608E+00  0.11981E+01
+  0.15033E+01  0.18879E+01  0.23726E+01  0.29617E+01  0.37035E+01  0.47375E+01
+  0.59717E+01  0.75201E+01  0.85298E+01  0.12550E+02  0.19194E+02  0.16199E+02
+  0.14478E+02  0.12170E+02  0.10245E+02  0.93198E+01  0.86282E+01  0.85981E+01
+  0.10745E+02  0.11837E+02  0.13276E+02  0.14835E+02  0.17380E+02  0.19593E+02
+  0.22591E+02  0.26447E+02  0.31845E+02  0.38388E+02  0.47496E+02  0.59542E+02
+  0.11468E+01  0.14312E+01  0.17894E+01  0.22409E+01  0.28098E+01  0.35265E+01
+  0.43987E+01  0.54956E+01  0.70175E+01  0.88354E+01  0.11114E+02  0.12664E+02
+  0.18661E+02  0.28186E+02  0.24376E+02  0.27332E+02  0.25818E+02  0.21745E+02
+  0.19831E+02  0.17977E+02  0.17181E+02  0.17583E+02  0.22233E+02  0.24112E+02
+  0.26218E+02  0.29709E+02  0.32651E+02  0.36567E+02  0.41530E+02  0.48329E+02
+  0.56374E+02  0.67287E+02  0.81506E+02  0.16693E+01  0.20755E+01  0.25872E+01
+  0.32318E+01  0.40439E+01  0.50664E+01  0.63110E+01  0.78759E+01  0.10042E+02
+  0.12629E+02  0.15869E+02  0.18094E+02  0.26629E+02  0.40023E+02  0.34823E+02
+  0.39075E+02  0.41932E+02  0.43114E+02  0.38979E+02  0.35212E+02  0.33413E+02
+  0.33538E+02  0.42380E+02  0.45173E+02  0.48322E+02  0.53641E+02  0.57848E+02
+  0.63343E+02  0.70205E+02  0.79408E+02  0.89975E+02  0.10392E+03  0.12186E+03
+  0.24870E+01  0.30770E+01  0.38200E+01  0.47557E+01  0.59344E+01  0.74184E+01
+  0.92257E+01  0.11498E+02  0.14633E+02  0.18381E+02  0.23072E+02  0.26367E+02
+  0.38829E+02  0.57932E+02  0.51115E+02  0.57616E+02  0.62215E+02  0.66402E+02
+  0.75726E+02  0.71669E+02  0.66730E+02  0.66255E+02  0.67873E+02  0.86466E+02
+  0.90875E+02  0.98605E+02  0.10456E+03  0.11223E+03  0.12171E+03  0.13420E+03
+  0.14817E+03  0.16618E+03  0.18905E+03  0.36766E+01  0.45190E+01  0.55792E+01
+  0.69151E+01  0.85969E+01  0.10714E+02  0.13293E+02  0.16534E+02  0.21002E+02
+  0.26344E+02  0.33024E+02  0.37761E+02  0.55557E+02  0.82558E+02  0.73280E+02
+  0.82722E+02  0.89524E+02  0.95662E+02  0.10888E+03  0.12227E+03  0.13095E+03
+  0.12793E+03  0.13037E+03  0.16711E+03  0.17368E+03  0.18573E+03  0.19455E+03
+  0.20576E+03  0.21946E+03  0.23721E+03  0.25640E+03  0.28047E+03  0.31075E+03
+  0.55007E+01  0.67028E+01  0.82164E+01  0.10123E+02  0.12524E+02  0.15545E+02
+  0.19224E+02  0.23848E+02  0.30218E+02  0.37834E+02  0.47356E+02  0.54159E+02
+  0.79601E+02  0.11784E+03  0.10521E+03  0.11896E+03  0.12906E+03  0.13816E+03
+  0.15709E+03  0.17575E+03  0.20301E+03  0.24811E+03  0.25109E+03  0.26030E+03
+  0.33591E+03  0.35478E+03  0.36806E+03  0.38475E+03  0.40496E+03  0.43073E+03
+  0.45758E+03  0.49036E+03  0.53119E+03  0.83559E+01  0.10072E+02  0.12232E+02
+  0.14952E+02  0.18376E+02  0.22687E+02  0.27937E+02  0.34535E+02  0.43619E+02
+  0.54478E+02  0.68052E+02  0.77816E+02  0.11421E+03  0.16842E+03  0.15123E+03
+  0.17126E+03  0.18630E+03  0.19985E+03  0.22716E+03  0.25349E+03  0.29093E+03
+  0.35244E+03  0.44208E+03  0.50085E+03  0.64504E+03  0.68239E+03  0.70528E+03
+  0.73051E+03  0.76084E+03  0.79902E+03  0.83724E+03  0.88255E+03  0.93853E+03
+  0.12936E+02  0.15384E+02  0.18466E+02  0.22347E+02  0.27233E+02  0.33383E+02
+  0.40869E+02  0.50278E+02  0.63239E+02  0.78722E+02  0.98078E+02  0.11207E+03
+  0.16412E+03  0.24109E+03  0.21762E+03  0.24682E+03  0.26918E+03  0.28944E+03
+  0.32904E+03  0.36653E+03  0.41849E+03  0.50322E+03  0.62508E+03  0.80174E+03
+  0.10009E+04  0.13072E+04  0.13526E+04  0.14036E+04  0.14498E+04  0.15073E+04
+  0.15626E+04  0.16261E+04  0.17039E+04  0.23517E-09  0.34545E-09  0.64468E-09
+  0.17960E-08  0.31390E-08  0.77491E-08  0.36338E-07  0.76809E-07  0.23500E-06
+  0.35685E-06  0.74260E-06  0.54581E-05  0.27395E-04  0.12263E-03  0.52965E-03
+  0.16021E-02  0.38653E-02  0.77216E-02  0.13532E-01  0.21423E-01  0.35060E-01
+  0.54372E-01  0.85300E-01  0.12740E+00  0.17913E+00  0.24562E+00  0.33360E+00
+  0.45497E+00  0.61623E+00  0.85073E+00  0.11701E+01  0.16259E+01  0.22877E+01
+  0.49015E-09  0.47122E-09  0.68033E-09  0.16823E-08  0.41912E-08  0.70333E-08
+  0.56439E-07  0.10495E-06  0.29769E-06  0.41057E-06  0.10534E-05  0.10054E-04
+  0.44941E-04  0.15652E-03  0.67425E-03  0.20346E-02  0.48985E-02  0.97674E-02
+  0.17092E-01  0.27022E-01  0.44169E-01  0.68408E-01  0.10717E+00  0.15983E+00
+  0.22429E+00  0.30683E+00  0.41552E+00  0.56466E+00  0.76128E+00  0.10450E+01
+  0.14269E+01  0.19657E+01  0.27373E+01  0.95154E-09  0.85695E-09  0.91000E-09
+  0.16160E-08  0.38669E-08  0.10089E-07  0.69672E-07  0.14503E-06  0.37435E-06
+  0.57902E-06  0.20508E-05  0.16174E-04  0.85584E-04  0.20661E-03  0.86122E-03
+  0.25905E-02  0.62203E-02  0.12376E-01  0.21617E-01  0.34125E-01  0.55701E-01
+  0.86163E-01  0.13481E+00  0.20076E+00  0.28128E+00  0.38406E+00  0.51885E+00
+  0.70295E+00  0.94406E+00  0.12897E+01  0.17507E+01  0.23940E+01  0.33038E+01
+  0.19138E-08  0.21074E-08  0.20600E-08  0.19586E-08  0.32994E-08  0.84660E-08
+  0.91450E-07  0.24222E-06  0.55597E-06  0.11187E-05  0.36492E-05  0.31586E-04
+  0.13927E-03  0.30296E-03  0.11032E-02  0.33062E-02  0.79142E-02  0.15706E-01
+  0.27377E-01  0.43139E-01  0.70318E-01  0.10863E+00  0.16974E+00  0.25246E+00
+  0.35319E+00  0.48144E+00  0.64909E+00  0.87721E+00  0.11745E+01  0.15981E+01
+  0.21585E+01  0.29333E+01  0.40173E+01  0.32882E-08  0.37161E-08  0.42987E-08
+  0.38307E-08  0.34431E-08  0.77856E-08  0.12089E-06  0.33626E-06  0.95532E-06
+  0.22182E-05  0.75532E-05  0.58169E-04  0.20039E-03  0.43045E-03  0.13293E-02
+  0.42358E-02  0.10099E-01  0.19979E-01  0.34734E-01  0.54618E-01  0.88877E-01
+  0.13709E+00  0.21396E+00  0.31781E+00  0.44402E+00  0.60437E+00  0.81343E+00
+  0.10970E+01  0.14649E+01  0.19866E+01  0.26724E+01  0.36129E+01  0.49162E+01
+  0.68806E-08  0.72269E-08  0.85813E-08  0.97581E-08  0.93417E-08  0.75622E-08
+  0.13370E-06  0.45236E-06  0.14876E-05  0.35986E-05  0.12309E-04  0.94543E-04
+  0.26271E-03  0.58239E-03  0.16215E-02  0.48805E-02  0.12925E-01  0.25471E-01
+  0.44147E-01  0.69247E-01  0.11246E+00  0.17319E+00  0.26992E+00  0.40040E+00
+  0.55873E+00  0.75946E+00  0.10206E+01  0.13740E+01  0.18307E+01  0.24762E+01
+  0.33194E+01  0.44686E+01  0.60480E+01  0.36429E-07  0.54064E-07  0.71757E-07
+  0.98343E-07  0.13974E-06  0.16539E-06  0.69921E-07  0.17983E-06  0.15359E-05
+  0.65618E-05  0.18763E-04  0.11535E-03  0.29457E-03  0.64445E-03  0.19237E-02
+  0.53868E-02  0.14725E-01  0.32649E-01  0.56530E-01  0.88571E-01  0.14379E+00
+  0.22128E+00  0.34469E+00  0.51096E+00  0.71221E+00  0.96687E+00  0.12975E+01
+  0.17439E+01  0.23191E+01  0.31294E+01  0.41826E+01  0.56090E+01  0.75552E+01
+  0.69963E-07  0.95348E-07  0.13311E-06  0.22663E-06  0.34420E-06  0.51620E-06
+  0.29012E-06  0.17384E-06  0.12473E-05  0.81942E-05  0.30522E-04  0.13496E-03
+  0.34249E-03  0.74377E-03  0.21832E-02  0.62970E-02  0.15974E-01  0.38583E-01
+  0.76162E-01  0.11890E+00  0.19257E+00  0.29569E+00  0.45982E+00  0.68055E+00
+  0.94705E+00  0.12837E+01  0.17200E+01  0.23080E+01  0.30632E+01  0.41242E+01
+  0.54965E+01  0.73454E+01  0.98502E+01  0.20070E-06  0.26859E-06  0.32333E-06
+  0.50143E-06  0.94319E-06  0.16148E-05  0.19225E-05  0.13971E-05  0.55846E-06
+  0.49107E-05  0.24875E-04  0.11240E-03  0.31399E-03  0.71471E-03  0.22618E-02
+  0.66329E-02  0.17191E-01  0.40021E-01  0.87464E-01  0.15828E+00  0.25612E+00
+  0.39271E+00  0.61020E+00  0.90205E+00  0.12535E+01  0.16964E+01  0.22696E+01
+  0.30407E+01  0.40288E+01  0.54144E+01  0.71996E+01  0.95943E+01  0.12821E+02
+  0.33186E-06  0.40867E-06  0.49778E-06  0.96316E-06  0.20820E-05  0.42475E-05
+  0.81327E-05  0.94850E-05  0.49980E-05  0.34224E-05  0.27598E-04  0.11389E-03
+  0.33555E-03  0.76589E-03  0.24433E-02  0.72440E-02  0.18387E-01  0.43048E-01
+  0.91082E-01  0.18367E+00  0.34619E+00  0.52860E+00  0.81876E+00  0.12071E+01
+  0.16735E+01  0.22603E+01  0.30185E+01  0.40378E+01  0.53413E+01  0.71664E+01
+  0.95109E+01  0.12645E+02  0.16852E+02  0.60140E-06  0.80459E-06  0.12059E-05
+  0.22080E-05  0.60584E-05  0.12477E-04  0.26382E-04  0.49818E-04  0.41313E-04
+  0.38479E-04  0.49686E-04  0.10790E-03  0.32298E-03  0.78148E-03  0.25943E-02
+  0.77966E-02  0.19564E-01  0.45318E-01  0.95425E-01  0.19014E+00  0.39800E+00
+  0.71260E+00  0.10997E+01  0.16161E+01  0.22341E+01  0.30103E+01  0.40121E+01
+  0.53573E+01  0.70753E+01  0.94780E+01  0.12557E+02  0.16664E+02  0.22156E+02
+  0.28364E-06  0.63237E-06  0.10768E-05  0.21965E-05  0.50189E-05  0.86140E-05
+  0.78823E-05  0.27563E-04  0.10276E-03  0.14300E-03  0.19965E-03  0.71535E-03
+  0.91435E-03  0.17356E-02  0.43366E-02  0.10759E-01  0.24879E-01  0.54250E-01
+  0.10891E+00  0.21412E+00  0.43786E+00  0.85638E+00  0.15475E+01  0.22539E+01
+  0.30981E+01  0.41580E+01  0.55255E+01  0.73600E+01  0.97022E+01  0.12971E+02
+  0.17158E+02  0.22730E+02  0.30164E+02  0.30695E-04  0.39216E-04  0.78844E-04
+  0.14959E-03  0.24033E-03  0.33556E-03  0.40185E-03  0.47437E-03  0.46770E-03
+  0.53702E-03  0.61079E-03  0.53041E-03  0.12993E-02  0.67320E-03  0.21940E-02
+  0.80895E-02  0.21277E-01  0.49427E-01  0.10083E+00  0.19983E+00  0.41919E+00
+  0.82350E+00  0.16492E+01  0.28731E+01  0.39423E+01  0.52778E+01  0.69962E+01
+  0.93020E+01  0.12236E+02  0.16341E+02  0.21579E+02  0.28541E+02  0.37811E+02
+  0.14820E-03  0.18889E-03  0.24192E-03  0.37212E-03  0.57665E-03  0.82955E-03
+  0.99045E-03  0.11537E-02  0.11893E-02  0.13450E-02  0.15656E-02  0.15182E-02
+  0.14980E-02  0.59540E-02  0.19498E-02  0.74615E-02  0.21331E-01  0.50741E-01
+  0.10332E+00  0.20329E+00  0.42490E+00  0.84008E+00  0.16752E+01  0.31802E+01
+  0.52183E+01  0.69544E+01  0.91838E+01  0.12175E+02  0.15974E+02  0.21294E+02
+  0.28069E+02  0.37061E+02  0.49020E+02  0.52731E-03  0.67029E-03  0.85539E-03
+  0.11531E-02  0.14764E-02  0.18778E-02  0.22894E-02  0.26139E-02  0.27254E-02
+  0.29893E-02  0.33807E-02  0.34703E-02  0.34955E-02  0.35733E-02  0.11097E-01
+  0.70264E-02  0.21626E-01  0.53125E-01  0.10793E+00  0.21048E+00  0.43734E+00
+  0.85717E+00  0.17187E+01  0.32415E+01  0.57444E+01  0.92066E+01  0.12098E+02
+  0.15978E+02  0.20894E+02  0.27790E+02  0.36553E+02  0.48177E+02  0.63613E+02
+  0.11826E-03  0.14869E-03  0.18755E-03  0.24729E-03  0.32764E-03  0.38468E-03
+  0.27569E-03  0.19757E-03  0.34600E-03  0.49956E-03  0.70243E-03  0.16630E-02
+  0.29903E-02  0.48373E-02  0.10673E-01  0.87111E-01  0.48353E-01  0.94191E-01
+  0.16974E+00  0.30427E+00  0.58499E+00  0.10887E+01  0.20888E+01  0.38695E+01
+  0.67417E+01  0.11536E+02  0.18309E+02  0.24017E+02  0.31274E+02  0.41404E+02
+  0.54315E+02  0.71432E+02  0.94147E+02  0.25573E-02  0.32365E-02  0.41075E-02
+  0.54908E-02  0.73697E-02  0.99359E-02  0.11367E-01  0.12232E-01  0.12843E-01
+  0.13731E-01  0.14779E-01  0.15215E-01  0.15676E-01  0.16418E-01  0.13544E-01
+  0.10567E-01  0.75249E-01  0.58157E-01  0.12022E+00  0.23201E+00  0.47821E+00
+  0.91763E+00  0.18080E+01  0.33834E+01  0.59459E+01  0.10124E+02  0.17135E+02
+  0.27433E+02  0.35529E+02  0.46951E+02  0.61384E+02  0.80516E+02  0.10589E+03
+  0.37638E-04  0.44188E-04  0.51696E-04  0.57594E-04  0.62545E-04  0.60553E-04
+  0.46127E-03  0.10258E-02  0.24894E-02  0.30784E-02  0.37073E-02  0.62734E-02
+  0.94068E-02  0.13397E-01  0.25242E-01  0.49670E-01  0.90749E-01  0.51435E+00
+  0.26686E+00  0.44333E+00  0.79558E+00  0.13961E+01  0.25480E+01  0.45313E+01
+  0.77293E+01  0.13046E+02  0.21806E+02  0.36791E+02  0.58390E+02  0.76547E+02
+  0.99657E+02  0.13028E+03  0.17088E+03  0.81132E-02  0.10237E-01  0.12946E-01
+  0.17217E-01  0.22952E-01  0.30681E-01  0.40484E-01  0.53887E-01  0.60110E-01
+  0.62370E-01  0.65507E-01  0.65867E-01  0.67130E-01  0.69585E-01  0.63869E-01
+  0.48259E-01  0.39893E-01  0.65859E-01  0.13227E+00  0.25683E+00  0.53834E+00
+  0.10168E+01  0.19692E+01  0.35893E+01  0.61156E+01  0.10236E+02  0.17124E+02
+  0.28744E+02  0.47878E+02  0.77748E+02  0.10067E+03  0.13104E+03  0.17130E+03
+  0.12860E-01  0.16207E-01  0.20465E-01  0.27162E-01  0.36125E-01  0.48146E-01
+  0.63461E-01  0.84236E-01  0.11001E+00  0.12750E+00  0.13248E+00  0.13450E+00
+  0.13621E+00  0.13993E+00  0.13095E+00  0.10566E+00  0.79732E-01  0.87003E-01
+  0.14770E+00  0.27617E+00  0.58202E+00  0.10940E+01  0.21040E+01  0.37757E+01
+  0.63045E+01  0.10351E+02  0.17031E+02  0.28506E+02  0.47053E+02  0.79748E+02
+  0.12820E+03  0.16596E+03  0.21601E+03  0.28895E-01  0.36320E-01  0.45747E-01
+  0.60523E-01  0.80202E-01  0.10644E+00  0.13998E+00  0.18502E+00  0.24129E+00
+  0.32214E+00  0.43221E+00  0.48801E+00  0.49385E+00  0.50545E+00  0.47671E+00
+  0.40777E+00  0.31929E+00  0.25217E+00  0.27728E+00  0.40505E+00  0.77773E+00
+  0.14140E+01  0.26546E+01  0.45773E+01  0.72629E+01  0.11348E+02  0.17863E+02
+  0.28834E+02  0.46579E+02  0.78126E+02  0.12896E+03  0.21474E+03  0.34492E+03
+  0.48472E-01  0.60820E-01  0.76479E-01  0.10100E+00  0.13359E+00  0.17693E+00
+  0.23257E+00  0.30695E+00  0.40055E+00  0.53283E+00  0.71142E+00  0.93310E+00
+  0.11200E+01  0.11364E+01  0.10945E+01  0.96714E+00  0.79735E+00  0.61860E+00
+  0.55879E+00  0.62806E+00  0.98020E+00  0.16798E+01  0.30969E+01  0.52287E+01
+  0.80243E+01  0.12096E+02  0.18405E+02  0.28858E+02  0.45403E+02  0.74693E+02
+  0.12237E+03  0.20205E+03  0.33550E+03  0.79541E-01  0.99578E-01  0.12498E+00
+  0.16471E+00  0.21745E+00  0.28748E+00  0.37763E+00  0.49778E+00  0.64969E+00
+  0.86188E+00  0.11465E+01  0.15014E+01  0.19738E+01  0.25160E+01  0.24220E+01
+  0.22029E+01  0.18890E+01  0.15098E+01  0.12872E+01  0.12238E+01  0.14611E+01
+  0.21966E+01  0.38295E+01  0.62710E+01  0.92717E+01  0.13423E+02  0.19633E+02
+  0.29721E+02  0.45263E+02  0.72615E+02  0.11630E+03  0.18984E+03  0.31361E+03
+  0.12604E+00  0.15734E+00  0.19699E+00  0.25899E+00  0.34120E+00  0.45023E+00
+  0.59079E+00  0.77775E+00  0.10147E+01  0.13432E+01  0.17818E+01  0.23294E+01
+  0.30542E+01  0.40199E+01  0.50702E+01  0.47346E+01  0.41592E+01  0.34337E+01
+  0.29049E+01  0.25832E+01  0.25624E+01  0.33040E+01  0.52409E+01  0.81911E+01
+  0.11605E+02  0.16069E+02  0.22483E+02  0.32661E+02  0.47861E+02  0.74361E+02
+  0.11574E+03  0.18451E+03  0.30008E+03  0.19502E+00  0.24254E+00  0.30271E+00
+  0.39673E+00  0.52133E+00  0.68644E+00  0.89950E+00  0.11824E+01  0.15416E+01
+  0.20368E+01  0.26956E+01  0.35189E+01  0.46035E+01  0.60394E+01  0.76138E+01
+  0.91488E+01  0.87505E+01  0.73539E+01  0.63045E+01  0.54606E+01  0.48858E+01
+  0.55467E+01  0.79125E+01  0.11687E+02  0.15828E+02  0.20928E+02  0.27939E+02
+  0.38772E+02  0.54395E+02  0.81295E+02  0.12222E+03  0.18915E+03  0.30012E+03
+  0.29158E+00  0.36080E+00  0.44843E+00  0.58532E+00  0.76664E+00  0.10068E+01
+  0.13166E+01  0.17275E+01  0.22493E+01  0.29664E+01  0.39179E+01  0.51058E+01
+  0.66642E+01  0.87167E+01  0.10965E+02  0.13163E+02  0.15239E+02  0.14687E+02
+  0.12548E+02  0.10875E+02  0.93003E+01  0.98621E+01  0.13100E+02  0.18437E+02
+  0.23945E+02  0.30297E+02  0.38610E+02  0.51099E+02  0.68417E+02  0.97832E+02
+  0.14125E+03  0.21092E+03  0.32454E+03  0.44719E+00  0.54970E+00  0.67941E+00
+  0.88206E+00  0.11503E+01  0.15054E+01  0.19640E+01  0.25716E+01  0.33441E+01
+  0.44026E+01  0.58048E+01  0.75564E+01  0.98494E+01  0.12860E+02  0.16176E+02
+  0.19469E+02  0.22652E+02  0.25156E+02  0.26199E+02  0.22496E+02  0.18761E+02
+  0.18516E+02  0.22479E+02  0.29932E+02  0.37359E+02  0.45401E+02  0.55398E+02
+  0.69996E+02  0.89384E+02  0.12191E+03  0.16828E+03  0.24110E+03  0.35757E+03
+  0.66968E+00  0.81610E+00  0.10014E+01  0.12908E+01  0.16738E+01  0.21808E+01
+  0.28350E+01  0.37017E+01  0.48031E+01  0.63103E+01  0.83046E+01  0.10793E+02
+  0.14044E+02  0.18299E+02  0.22979E+02  0.27622E+02  0.32104E+02  0.35631E+02
+  0.39901E+02  0.43803E+02  0.35791E+02  0.34606E+02  0.40601E+02  0.52291E+02
+  0.63317E+02  0.74408E+02  0.87410E+02  0.10587E+03  0.12919E+03  0.16804E+03
+  0.22125E+03  0.30290E+03  0.43064E+03  0.10353E+01  0.12479E+01  0.15170E+01
+  0.19372E+01  0.24933E+01  0.32289E+01  0.41787E+01  0.54366E+01  0.70359E+01
+  0.92218E+01  0.12111E+02  0.15718E+02  0.20427E+02  0.26581E+02  0.33373E+02
+  0.40169E+02  0.46823E+02  0.52234E+02  0.58699E+02  0.65521E+02  0.69071E+02
+  0.66701E+02  0.74313E+02  0.92787E+02  0.10921E+03  0.12470E+03  0.14181E+03
+  0.16545E+03  0.19376E+03  0.24083E+03  0.30255E+03  0.39502E+03  0.53636E+03
+  0.16038E+01  0.19073E+01  0.22915E+01  0.28913E+01  0.36850E+01  0.47348E+01
+  0.60897E+01  0.78840E+01  0.10165E+02  0.13281E+02  0.17398E+02  0.22536E+02
+  0.29236E+02  0.37982E+02  0.47641E+02  0.57327E+02  0.66844E+02  0.74657E+02
+  0.83919E+02  0.93509E+02  0.97781E+02  0.11644E+03  0.13829E+03  0.16865E+03
+  0.19693E+03  0.21992E+03  0.24366E+03  0.27561E+03  0.31149E+03  0.37172E+03
+  0.44684E+03  0.55685E+03  0.72104E+03  0.25413E+01  0.29747E+01  0.35230E+01
+  0.43791E+01  0.55120E+01  0.70100E+01  0.89429E+01  0.11502E+02  0.14755E+02
+  0.19200E+02  0.25068E+02  0.32392E+02  0.41939E+02  0.54390E+02  0.68156E+02
+  0.82003E+02  0.95676E+02  0.10704E+03  0.12044E+03  0.13415E+03  0.13950E+03
+  0.16340E+03  0.22407E+03  0.31153E+03  0.35721E+03  0.39773E+03  0.43205E+03
+  0.47661E+03  0.52305E+03  0.60273E+03  0.69660E+03  0.83123E+03  0.10277E+04
+  0.41322E+01  0.47505E+01  0.55331E+01  0.67547E+01  0.83712E+01  0.10509E+02
+  0.13264E+02  0.16914E+02  0.21554E+02  0.27893E+02  0.36262E+02  0.46705E+02
+  0.60314E+02  0.78057E+02  0.97700E+02  0.11754E+03  0.13723E+03  0.15382E+03
+  0.17334E+03  0.19317E+03  0.20012E+03  0.23123E+03  0.30914E+03  0.47196E+03
+  0.66004E+03  0.72198E+03  0.78188E+03  0.84935E+03  0.91050E+03  0.10193E+04
+  0.11394E+04  0.13084E+04  0.15502E+04  0.69088E+01  0.77910E+01  0.89075E+01
+  0.10650E+02  0.12956E+02  0.16006E+02  0.19932E+02  0.25137E+02  0.31748E+02
+  0.40790E+02  0.52725E+02  0.67614E+02  0.87022E+02  0.11232E+03  0.14036E+03
+  0.16879E+03  0.19719E+03  0.22144E+03  0.25000E+03  0.27889E+03  0.28827E+03
+  0.32930E+03  0.43025E+03  0.64453E+03  0.94246E+03  0.13351E+04  0.14253E+04
+  0.15382E+04  0.16315E+04  0.17847E+04  0.19413E+04  0.21585E+04  0.24637E+04
+  0.18496E-09  0.45782E-09  0.92686E-09  0.25247E-08  0.34858E-08  0.82290E-08
+  0.42401E-07  0.83023E-07  0.23768E-06  0.37746E-06  0.70747E-06  0.46863E-06
+  0.35164E-04  0.16957E-03  0.60251E-03  0.13438E-03  0.29151E-02  0.41350E-04
+  0.92337E-02  0.14625E-01  0.32815E-01  0.54992E-01  0.90124E-01  0.14257E+00
+  0.22013E+00  0.32814E+00  0.50133E+00  0.74702E+00  0.11476E+01  0.17641E+01
+  0.27702E+01  0.44588E+01  0.73748E+01  0.45782E-09  0.37749E-09  0.84700E-09
+  0.21495E-08  0.50130E-08  0.78364E-08  0.69255E-07  0.11462E-06  0.29680E-06
+  0.45475E-06  0.94650E-06  0.86674E-06  0.58240E-04  0.21657E-03  0.76710E-03
+  0.16916E-03  0.36931E-02  0.48447E-04  0.11659E-01  0.18443E-01  0.41274E-01
+  0.69052E-01  0.11293E+00  0.17819E+00  0.27417E+00  0.40689E+00  0.61789E+00
+  0.91356E+00  0.13895E+01  0.21094E+01  0.32631E+01  0.51621E+01  0.83780E+01
+  0.92686E-09  0.84700E-09  0.73238E-09  0.20505E-08  0.44994E-08  0.11891E-07
+  0.80912E-07  0.16129E-06  0.39062E-06  0.66744E-06  0.16182E-05  0.13758E-05
+  0.10819E-03  0.28701E-03  0.97989E-03  0.21348E-03  0.46880E-02  0.56497E-04
+  0.14742E-01  0.23283E-01  0.51972E-01  0.86810E-01  0.14172E+00  0.22312E+00
+  0.34235E+00  0.50613E+00  0.76484E+00  0.11234E+01  0.16942E+01  0.25444E+01
+  0.38841E+01  0.60482E+01  0.96425E+01  0.25247E-08  0.21495E-08  0.20505E-08
+  0.15854E-08  0.38088E-08  0.98117E-08  0.11358E-06  0.25587E-06  0.56959E-06
+  0.11997E-05  0.28911E-05  0.29154E-05  0.17434E-03  0.42264E-03  0.12554E-02
+  0.26763E-03  0.59611E-02  0.59451E-04  0.18659E-01  0.29420E-01  0.65489E-01
+  0.10923E+00  0.17804E+00  0.27977E+00  0.42824E+00  0.63119E+00  0.94990E+00
+  0.13877E+01  0.20779E+01  0.30921E+01  0.46658E+01  0.71636E+01  0.11234E+02
+  0.34858E-08  0.50130E-08  0.44994E-08  0.38088E-08  0.31878E-08  0.89924E-08
+  0.14150E-06  0.33838E-06  0.10235E-05  0.21444E-05  0.66017E-05  0.53134E-05
+  0.24866E-03  0.60241E-03  0.15122E-02  0.33664E-03  0.76024E-02  0.61019E-04
+  0.23659E-01  0.37227E-01  0.82618E-01  0.13759E+00  0.22392E+00  0.35128E+00
+  0.53660E+00  0.78886E+00  0.11832E+01  0.17207E+01  0.25615E+01  0.37821E+01
+  0.56506E+01  0.85690E+01  0.13238E+02  0.82290E-08  0.78364E-08  0.11891E-07
+  0.98117E-08  0.89924E-08  0.69245E-08  0.15917E-06  0.49122E-06  0.15388E-05
+  0.38934E-05  0.11610E-04  0.79476E-05  0.32683E-03  0.81590E-03  0.18424E-02
+  0.37709E-03  0.97198E-02  0.54124E-04  0.30043E-01  0.47161E-01  0.10430E+00
+  0.17342E+00  0.28184E+00  0.44145E+00  0.67316E+00  0.98743E+00  0.14769E+01
+  0.21400E+01  0.31700E+01  0.46504E+01  0.68897E+01  0.10337E+02  0.15760E+02
+  0.42401E-07  0.69255E-07  0.80912E-07  0.11358E-06  0.14150E-06  0.15917E-06
+  0.52534E-07  0.23640E-06  0.16199E-05  0.66986E-05  0.22234E-04  0.10963E-04
+  0.37518E-03  0.93193E-03  0.22015E-02  0.22647E-03  0.11112E-01  0.56844E-03
+  0.38152E-01  0.59901E-01  0.13240E+00  0.22020E+00  0.35779E+00  0.56011E+00
+  0.85321E+00  0.12494E+01  0.18648E+01  0.26935E+01  0.39737E+01  0.57971E+01
+  0.85248E+01  0.12668E+02  0.19080E+02  0.83023E-07  0.11462E-06  0.16129E-06
+  0.25587E-06  0.33838E-06  0.49122E-06  0.23640E-06  0.13990E-06  0.13155E-05
+  0.84068E-05  0.42153E-04  0.32469E-04  0.44568E-03  0.11002E-02  0.25081E-02
+  0.17212E-03  0.11938E-01  0.11778E-02  0.51101E-01  0.80019E-01  0.17613E+00
+  0.29253E+00  0.47473E+00  0.74217E+00  0.11289E+01  0.16499E+01  0.24572E+01
+  0.35385E+01  0.52003E+01  0.75465E+01  0.11021E+02  0.16228E+02  0.24156E+02
+  0.23768E-06  0.29680E-06  0.39062E-06  0.56959E-06  0.10235E-05  0.15388E-05
+  0.16199E-05  0.13155E-05  0.46916E-06  0.46835E-05  0.37107E-04  0.10781E-03
+  0.44244E-03  0.11412E-02  0.26387E-02  0.38866E-03  0.12617E-01  0.26370E-02
+  0.59475E-01  0.10517E+00  0.23123E+00  0.38425E+00  0.62377E+00  0.97478E+00
+  0.14816E+01  0.21625E+01  0.32162E+01  0.46209E+01  0.67721E+01  0.97887E+01
+  0.14219E+02  0.20788E+02  0.30654E+02  0.37746E-06  0.45475E-06  0.66744E-06
+  0.11997E-05  0.21444E-05  0.38934E-05  0.66986E-05  0.84068E-05  0.46835E-05
+  0.28900E-05  0.34062E-04  0.16091E-03  0.49229E-03  0.12682E-02  0.28688E-02
+  0.61650E-03  0.13369E-01  0.34332E-02  0.61362E-01  0.12584E+00  0.30972E+00
+  0.51315E+00  0.83104E+00  0.12962E+01  0.19667E+01  0.28654E+01  0.42544E+01
+  0.60997E+01  0.89172E+01  0.12847E+02  0.18581E+02  0.27010E+02  0.39532E+02
+  0.70747E-06  0.94650E-06  0.16182E-05  0.28911E-05  0.66017E-05  0.11610E-04
+  0.22234E-04  0.42153E-04  0.37107E-04  0.34062E-04  0.43496E-04  0.25591E-03
+  0.50443E-03  0.13868E-02  0.30807E-02  0.10608E-02  0.14050E-01  0.46888E-02
+  0.63502E-01  0.12902E+00  0.41416E+00  0.68401E+00  0.11051E+01  0.17201E+01
+  0.26051E+01  0.37886E+01  0.56167E+01  0.80382E+01  0.11728E+02  0.16854E+02
+  0.24294E+02  0.35158E+02  0.51149E+02  0.46863E-06  0.86674E-06  0.13758E-05
+  0.29154E-05  0.53134E-05  0.79476E-05  0.10963E-04  0.32469E-04  0.10781E-03
+  0.16091E-03  0.25591E-03  0.30968E-04  0.11508E-02  0.24752E-02  0.49325E-02
+  0.62323E-03  0.18686E-01  0.46444E-03  0.75148E-01  0.15004E+00  0.53077E+00
+  0.98464E+00  0.15688E+01  0.24188E+01  0.36390E+01  0.52706E+01  0.77810E+01
+  0.11106E+02  0.16152E+02  0.23143E+02  0.33247E+02  0.47913E+02  0.69335E+02
+  0.35164E-04  0.58240E-04  0.10819E-03  0.17434E-03  0.24866E-03  0.32683E-03
+  0.37518E-03  0.44568E-03  0.44244E-03  0.49229E-03  0.50443E-03  0.11508E-02
+  0.12982E-02  0.11370E-02  0.28317E-02  0.39969E-02  0.14046E-01  0.11816E-01
+  0.62986E-01  0.12941E+00  0.47529E+00  0.10855E+01  0.19035E+01  0.29544E+01
+  0.44621E+01  0.64654E+01  0.95674E+01  0.13647E+02  0.19864E+02  0.28442E+02
+  0.40816E+02  0.58721E+02  0.84758E+02  0.16957E-03  0.21657E-03  0.28701E-03
+  0.42264E-03  0.60241E-03  0.81590E-03  0.93193E-03  0.11002E-02  0.11412E-02
+  0.12682E-02  0.13868E-02  0.24752E-02  0.11370E-02  0.50487E-02  0.24172E-02
+  0.73001E-02  0.12863E-01  0.18914E-01  0.60824E-01  0.12581E+00  0.46772E+00
+  0.10669E+01  0.23860E+01  0.38233E+01  0.57673E+01  0.83387E+01  0.12331E+02
+  0.17561E+02  0.25544E+02  0.36525E+02  0.52338E+02  0.75160E+02  0.10822E+03
+  0.60251E-03  0.76710E-03  0.97989E-03  0.12554E-02  0.15122E-02  0.18424E-02
+  0.22015E-02  0.25081E-02  0.26387E-02  0.28688E-02  0.30807E-02  0.49325E-02
+  0.28317E-02  0.24172E-02  0.11525E-01  0.12257E-01  0.11855E-01  0.28525E-01
+  0.59155E-01  0.12346E+00  0.45724E+00  0.10589E+01  0.23561E+01  0.49653E+01
+  0.74721E+01  0.10770E+02  0.15909E+02  0.22609E+02  0.32858E+02  0.46923E+02
+  0.67148E+02  0.96285E+02  0.13837E+03  0.13438E-03  0.16916E-03  0.21348E-03
+  0.26763E-03  0.33664E-03  0.37709E-03  0.22647E-03  0.17212E-03  0.38866E-03
+  0.61650E-03  0.10608E-02  0.62323E-03  0.39969E-02  0.73001E-02  0.12257E-01
+  0.25007E-02  0.35534E-01  0.36271E-02  0.11413E+00  0.20863E+00  0.66415E+00
+  0.14303E+01  0.30553E+01  0.63100E+01  0.12004E+02  0.17079E+02  0.24882E+02
+  0.35138E+02  0.50657E+02  0.71997E+02  0.10257E+03  0.14646E+03  0.20954E+03
+  0.29151E-02  0.36931E-02  0.46880E-02  0.59611E-02  0.76024E-02  0.97198E-02
+  0.11112E-01  0.11938E-01  0.12617E-01  0.13369E-01  0.14050E-01  0.18686E-01
+  0.14046E-01  0.12863E-01  0.11855E-01  0.35534E-01  0.56510E-01  0.67636E-01
+  0.53648E-01  0.11487E+00  0.42873E+00  0.10031E+01  0.22693E+01  0.48649E+01
+  0.10059E+02  0.17675E+02  0.26019E+02  0.36761E+02  0.53322E+02  0.75925E+02
+  0.10840E+03  0.15511E+03  0.22238E+03  0.41350E-04  0.48447E-04  0.56497E-04
+  0.59451E-04  0.61019E-04  0.54124E-04  0.56844E-03  0.11778E-02  0.26370E-02
+  0.34332E-02  0.46888E-02  0.46444E-03  0.11816E-01  0.18914E-01  0.28525E-01
+  0.36271E-02  0.67636E-01  0.12182E-02  0.18086E+00  0.30526E+00  0.85667E+00
+  0.17378E+01  0.35594E+01  0.72089E+01  0.14338E+02  0.27696E+02  0.46472E+02
+  0.64930E+02  0.92837E+02  0.13113E+03  0.18589E+03  0.26424E+03  0.37648E+03
+  0.92337E-02  0.11659E-01  0.14742E-01  0.18659E-01  0.23659E-01  0.30043E-01
+  0.38152E-01  0.51101E-01  0.59475E-01  0.61362E-01  0.63502E-01  0.75148E-01
+  0.62986E-01  0.60824E-01  0.59155E-01  0.11413E+00  0.53648E-01  0.18086E+00
+  0.66792E-01  0.11116E+00  0.37841E+00  0.90080E+00  0.20596E+01  0.44362E+01
+  0.92397E+01  0.18046E+02  0.36641E+02  0.56967E+02  0.82448E+02  0.11695E+03
+  0.16659E+03  0.23805E+03  0.34096E+03  0.14625E-01  0.18443E-01  0.23283E-01
+  0.29420E-01  0.37227E-01  0.47161E-01  0.59901E-01  0.80019E-01  0.10517E+00
+  0.12584E+00  0.12902E+00  0.15004E+00  0.12941E+00  0.12581E+00  0.12346E+00
+  0.20863E+00  0.11487E+00  0.30526E+00  0.11116E+00  0.14118E+00  0.37414E+00
+  0.85727E+00  0.19512E+01  0.41859E+01  0.86667E+01  0.16979E+02  0.34298E+02
+  0.66114E+02  0.10079E+03  0.14256E+03  0.20276E+03  0.28953E+03  0.41460E+03
+  0.32815E-01  0.41274E-01  0.51972E-01  0.65489E-01  0.82618E-01  0.10430E+00
+  0.13240E+00  0.17613E+00  0.23123E+00  0.30972E+00  0.41416E+00  0.53077E+00
+  0.47529E+00  0.46772E+00  0.45724E+00  0.66415E+00  0.42873E+00  0.85667E+00
+  0.37841E+00  0.37414E+00  0.55325E+00  0.97477E+00  0.19932E+01  0.40661E+01
+  0.81275E+01  0.15381E+02  0.30962E+02  0.58900E+02  0.11643E+03  0.21243E+03
+  0.30019E+03  0.42703E+03  0.61032E+03  0.54992E-01  0.69052E-01  0.86810E-01
+  0.10923E+00  0.13759E+00  0.17342E+00  0.22020E+00  0.29253E+00  0.38425E+00
+  0.51315E+00  0.68401E+00  0.98464E+00  0.10855E+01  0.10669E+01  0.10589E+01
+  0.14303E+01  0.10031E+01  0.17378E+01  0.90080E+00  0.85727E+00  0.97477E+00
+  0.12971E+01  0.21926E+01  0.40823E+01  0.77607E+01  0.14177E+02  0.27878E+02
+  0.52177E+02  0.10313E+03  0.19751E+03  0.36131E+03  0.51187E+03  0.73002E+03
+  0.90124E-01  0.11293E+00  0.14172E+00  0.17804E+00  0.22392E+00  0.28184E+00
+  0.35779E+00  0.47473E+00  0.62377E+00  0.83104E+00  0.11051E+01  0.15688E+01
+  0.19035E+01  0.23860E+01  0.23561E+01  0.30553E+01  0.22693E+01  0.35594E+01
+  0.20596E+01  0.19512E+01  0.19932E+01  0.21926E+01  0.29652E+01  0.47369E+01
+  0.81910E+01  0.14128E+02  0.26482E+02  0.48006E+02  0.92963E+02  0.17694E+03
+  0.33886E+03  0.61995E+03  0.87873E+03  0.14257E+00  0.17819E+00  0.22312E+00
+  0.27977E+00  0.35128E+00  0.44145E+00  0.56011E+00  0.74217E+00  0.97478E+00
+  0.12962E+01  0.17201E+01  0.24188E+01  0.29544E+01  0.38233E+01  0.49653E+01
+  0.63100E+01  0.48649E+01  0.72089E+01  0.44362E+01  0.41859E+01  0.40661E+01
+  0.40823E+01  0.47369E+01  0.65195E+01  0.10050E+02  0.16099E+02  0.28131E+02
+  0.48803E+02  0.90773E+02  0.16886E+03  0.32033E+03  0.61165E+03  0.11163E+04
+  0.22013E+00  0.27417E+00  0.34235E+00  0.42824E+00  0.53660E+00  0.67316E+00
+  0.85321E+00  0.11289E+01  0.14816E+01  0.19667E+01  0.26051E+01  0.36390E+01
+  0.44621E+01  0.57673E+01  0.74721E+01  0.12004E+02  0.10059E+02  0.14338E+02
+  0.92397E+01  0.86667E+01  0.81275E+01  0.77607E+01  0.81910E+01  0.10050E+02
+  0.13922E+02  0.20625E+02  0.33271E+02  0.54739E+02  0.96702E+02  0.17350E+03
+  0.32121E+03  0.60664E+03  0.11538E+04  0.32814E+00  0.40689E+00  0.50613E+00
+  0.63119E+00  0.78886E+00  0.98743E+00  0.12494E+01  0.16499E+01  0.21625E+01
+  0.28654E+01  0.37886E+01  0.52706E+01  0.64654E+01  0.83387E+01  0.10770E+02
+  0.17079E+02  0.17675E+02  0.27696E+02  0.18046E+02  0.16979E+02  0.15381E+02
+  0.14177E+02  0.14128E+02  0.16099E+02  0.20625E+02  0.28525E+02  0.42846E+02
+  0.66647E+02  0.11162E+03  0.19214E+03  0.34394E+03  0.63529E+03  0.11973E+04
+  0.50133E+00  0.61789E+00  0.76484E+00  0.94990E+00  0.11832E+01  0.14769E+01
+  0.18648E+01  0.24572E+01  0.32162E+01  0.42544E+01  0.56167E+01  0.77810E+01
+  0.95674E+01  0.12331E+02  0.15909E+02  0.24882E+02  0.26019E+02  0.46472E+02
+  0.36641E+02  0.34298E+02  0.30962E+02  0.27878E+02  0.26482E+02  0.28131E+02
+  0.33271E+02  0.42846E+02  0.59388E+02  0.86724E+02  0.13610E+03  0.22259E+03
+  0.38150E+03  0.67993E+03  0.12508E+04  0.74702E+00  0.91356E+00  0.11234E+01
+  0.13877E+01  0.17207E+01  0.21400E+01  0.26935E+01  0.35385E+01  0.46209E+01
+  0.60997E+01  0.80382E+01  0.11106E+02  0.13647E+02  0.17561E+02  0.22609E+02
+  0.35138E+02  0.36761E+02  0.64930E+02  0.56967E+02  0.66114E+02  0.58900E+02
+  0.52177E+02  0.48006E+02  0.48803E+02  0.54739E+02  0.66647E+02  0.86724E+02
+  0.11927E+03  0.17618E+03  0.27311E+03  0.44656E+03  0.76501E+03  0.13628E+04
+  0.11476E+01  0.13895E+01  0.16942E+01  0.20779E+01  0.25615E+01  0.31700E+01
+  0.39737E+01  0.52003E+01  0.67721E+01  0.89172E+01  0.11728E+02  0.16152E+02
+  0.19864E+02  0.25544E+02  0.32858E+02  0.50657E+02  0.53322E+02  0.92837E+02
+  0.82448E+02  0.10079E+03  0.11643E+03  0.10313E+03  0.92963E+02  0.90773E+02
+  0.96702E+02  0.11162E+03  0.13610E+03  0.17618E+03  0.24348E+03  0.35534E+03
+  0.54954E+03  0.89638E+03  0.15320E+04  0.17641E+01  0.21094E+01  0.25444E+01
+  0.30921E+01  0.37821E+01  0.46504E+01  0.57971E+01  0.75465E+01  0.97887E+01
+  0.12847E+02  0.16854E+02  0.23143E+02  0.28442E+02  0.36525E+02  0.46923E+02
+  0.71997E+02  0.75925E+02  0.13113E+03  0.11695E+03  0.14256E+03  0.21243E+03
+  0.19751E+03  0.17694E+03  0.16886E+03  0.17350E+03  0.19214E+03  0.22259E+03
+  0.27311E+03  0.35534E+03  0.48854E+03  0.71292E+03  0.11023E+04  0.17975E+04
+  0.27702E+01  0.32631E+01  0.38841E+01  0.46658E+01  0.56506E+01  0.68897E+01
+  0.85248E+01  0.11021E+02  0.14219E+02  0.18581E+02  0.24294E+02  0.33247E+02
+  0.40816E+02  0.52338E+02  0.67148E+02  0.10257E+03  0.10840E+03  0.18589E+03
+  0.16659E+03  0.20276E+03  0.30019E+03  0.36131E+03  0.33886E+03  0.32033E+03
+  0.32121E+03  0.34394E+03  0.38150E+03  0.44656E+03  0.54954E+03  0.71292E+03
+  0.98013E+03  0.14301E+04  0.22106E+04  0.44588E+01  0.51621E+01  0.60482E+01
+  0.71636E+01  0.85690E+01  0.10337E+02  0.12668E+02  0.16228E+02  0.20788E+02
+  0.27010E+02  0.35158E+02  0.47913E+02  0.58721E+02  0.75160E+02  0.96285E+02
+  0.14646E+03  0.15511E+03  0.26424E+03  0.23805E+03  0.28953E+03  0.42703E+03
+  0.51187E+03  0.61995E+03  0.61165E+03  0.60664E+03  0.63529E+03  0.67993E+03
+  0.76501E+03  0.89638E+03  0.11023E+04  0.14301E+04  0.19658E+04  0.28678E+04
+  0.73748E+01  0.83780E+01  0.96425E+01  0.11234E+02  0.13238E+02  0.15760E+02
+  0.19080E+02  0.24156E+02  0.30654E+02  0.39532E+02  0.51149E+02  0.69335E+02
+  0.84758E+02  0.10822E+03  0.13837E+03  0.20954E+03  0.22238E+03  0.37648E+03
+  0.34096E+03  0.41460E+03  0.61032E+03  0.73002E+03  0.87873E+03  0.11163E+04
+  0.11538E+04  0.11973E+04  0.12508E+04  0.13628E+04  0.15320E+04  0.17975E+04
+  0.22106E+04  0.28678E+04  0.39418E+04  0.17636E-09  0.46658E-09  0.72155E-09
+  0.11516E-08  0.21019E-08  0.38385E-08  0.20744E-07  0.41193E-07  0.20675E-07
+  0.16138E-06  0.29817E-06  0.20980E-04  0.12671E-03  0.29586E-04  0.54527E-03
+  0.89783E-03  0.14178E-02  0.20816E-02  0.28421E-02  0.39345E-02  0.53890E-02
+  0.74244E-02  0.98737E-02  0.13321E-01  0.17120E-01  0.23157E-01  0.29439E-01
+  0.38931E-01  0.49922E-01  0.66811E-01  0.86175E-01  0.11608E+00  0.15196E+00
+  0.29350E-10  0.25270E-09  0.98093E-09  0.14485E-08  0.26190E-08  0.52387E-08
+  0.26790E-07  0.56352E-07  0.39452E-07  0.26148E-06  0.38396E-06  0.27599E-04
+  0.16453E-03  0.37954E-04  0.70090E-03  0.11496E-02  0.18099E-02  0.26494E-02
+  0.36081E-02  0.49832E-02  0.68105E-02  0.93613E-02  0.12422E-01  0.16716E-01
+  0.21425E-01  0.28885E-01  0.36583E-01  0.48160E-01  0.61422E-01  0.81674E-01
+  0.10455E+00  0.13959E+00  0.18089E+00  0.82101E-09  0.42539E-09  0.49316E-09
+  0.15156E-08  0.31068E-08  0.58593E-08  0.33729E-07  0.83769E-07  0.61847E-07
+  0.43327E-06  0.79977E-06  0.36733E-04  0.21554E-03  0.48854E-04  0.90713E-03
+  0.14808E-02  0.23228E-02  0.33885E-02  0.46009E-02  0.63381E-02  0.86416E-02
+  0.11850E-01  0.15690E-01  0.21064E-01  0.26930E-01  0.36204E-01  0.45703E-01
+  0.59932E-01  0.76088E-01  0.10062E+00  0.12797E+00  0.16954E+00  0.21774E+00
+  0.27104E-08  0.25430E-08  0.12578E-08  0.24069E-09  0.25117E-08  0.63330E-08
+  0.62791E-07  0.12821E-06  0.12134E-06  0.61492E-06  0.15685E-05  0.53090E-04
+  0.28375E-03  0.62717E-04  0.11774E-02  0.19111E-02  0.29852E-02  0.43372E-02
+  0.58687E-02  0.80601E-02  0.10961E-01  0.14993E-01  0.19808E-01  0.26532E-01
+  0.33844E-01  0.45383E-01  0.57131E-01  0.74668E-01  0.94438E-01  0.12431E+00
+  0.15723E+00  0.20697E+00  0.26377E+00  0.70475E-08  0.73465E-08  0.65758E-08
+  0.53227E-08  0.17648E-08  0.45200E-08  0.12576E-06  0.34252E-06  0.17533E-06
+  0.73762E-06  0.24333E-05  0.79765E-04  0.37764E-03  0.80472E-04  0.15411E-02
+  0.24846E-02  0.38609E-02  0.55824E-02  0.75224E-02  0.10296E-01  0.13960E-01
+  0.19041E-01  0.25096E-01  0.33536E-01  0.42683E-01  0.57099E-01  0.71700E-01
+  0.93439E-01  0.11779E+00  0.15444E+00  0.19444E+00  0.25452E+00  0.32224E+00
+  0.16901E-07  0.18492E-07  0.19036E-07  0.22910E-07  0.21101E-07  0.13387E-07
+  0.17710E-06  0.70656E-06  0.43083E-07  0.53746E-06  0.27818E-05  0.11825E-03
+  0.46995E-03  0.10230E-03  0.20354E-02  0.32554E-02  0.50277E-02  0.72275E-02
+  0.96912E-02  0.13210E-01  0.17849E-01  0.24266E-01  0.31899E-01  0.42517E-01
+  0.53994E-01  0.72061E-01  0.90279E-01  0.11735E+00  0.14750E+00  0.19275E+00
+  0.24171E+00  0.31491E+00  0.39645E+00  0.40086E-07  0.43292E-07  0.44731E-07
+  0.56088E-07  0.83638E-07  0.83869E-07  0.36695E-06  0.15339E-05  0.89848E-06
+  0.88317E-06  0.19143E-05  0.15855E-03  0.56737E-03  0.11484E-03  0.27122E-02
+  0.42979E-02  0.65902E-02  0.94092E-02  0.12542E-01  0.17013E-01  0.22893E-01
+  0.31003E-01  0.40636E-01  0.54010E-01  0.68427E-01  0.91105E-01  0.11388E+00
+  0.14767E+00  0.18514E+00  0.24122E+00  0.30149E+00  0.39119E+00  0.49017E+00
+  0.95261E-07  0.10917E-06  0.11215E-06  0.11379E-06  0.17876E-06  0.29918E-06
+  0.29908E-06  0.26016E-05  0.36772E-05  0.55751E-05  0.28282E-05  0.20395E-03
+  0.70195E-03  0.11320E-03  0.32798E-02  0.57284E-02  0.87119E-02  0.12340E-01
+  0.16333E-01  0.22027E-01  0.29498E-01  0.39767E-01  0.51943E-01  0.68809E-01
+  0.86949E-01  0.11547E+00  0.14402E+00  0.18629E+00  0.23303E+00  0.30281E+00
+  0.37736E+00  0.48797E+00  0.60897E+00  0.24050E-06  0.30045E-06  0.33410E-06
+  0.31832E-06  0.29079E-06  0.60824E-06  0.64647E-06  0.25124E-05  0.10710E-04
+  0.16280E-04  0.16388E-04  0.24947E-03  0.83725E-03  0.97967E-04  0.36537E-02
+  0.69162E-02  0.11603E-01  0.16285E-01  0.21379E-01  0.28638E-01  0.38131E-01
+  0.51132E-01  0.66518E-01  0.87788E-01  0.11060E+00  0.14647E+00  0.18224E+00
+  0.23516E+00  0.29350E+00  0.38045E+00  0.47291E+00  0.60967E+00  0.75827E+00
+  0.51862E-06  0.77237E-06  0.10098E-05  0.11616E-05  0.91909E-06  0.77253E-06
+  0.27235E-05  0.33009E-05  0.27559E-04  0.39577E-04  0.45835E-04  0.29257E-03
+  0.98344E-03  0.47011E-04  0.41409E-02  0.75679E-02  0.14035E-01  0.21674E-01
+  0.28183E-01  0.37455E-01  0.49541E-01  0.66007E-01  0.85467E-01  0.11229E+00
+  0.14098E+00  0.18612E+00  0.23095E+00  0.29725E+00  0.37015E+00  0.47867E+00
+  0.59358E+00  0.76317E+00  0.94641E+00  0.13060E-05  0.23343E-05  0.44436E-05
+  0.60150E-05  0.67725E-05  0.57796E-05  0.37761E-05  0.16859E-04  0.60756E-04
+  0.88836E-04  0.10743E-03  0.31885E-03  0.10962E-02  0.11057E-03  0.46341E-02
+  0.83622E-02  0.15108E-01  0.26258E-01  0.37234E-01  0.49055E-01  0.64398E-01
+  0.85176E-01  0.10970E+00  0.14337E+00  0.17928E+00  0.23585E+00  0.29178E+00
+  0.37448E+00  0.46524E+00  0.60023E+00  0.74265E+00  0.95242E+00  0.11781E+01
+  0.44185E-05  0.84357E-05  0.16625E-04  0.33212E-04  0.45754E-04  0.51208E-04
+  0.40964E-04  0.43995E-04  0.12486E-03  0.18767E-03  0.23653E-03  0.30853E-03
+  0.11669E-02  0.46903E-03  0.51176E-02  0.91795E-02  0.16377E-01  0.28106E-01
+  0.45195E-01  0.64686E-01  0.84214E-01  0.11044E+00  0.14136E+00  0.18361E+00
+  0.22851E+00  0.29938E+00  0.36910E+00  0.47213E+00  0.58509E+00  0.75294E+00
+  0.92948E+00  0.11891E+01  0.14672E+01  0.40080E-04  0.64756E-04  0.87688E-04
+  0.11721E-03  0.15925E-03  0.19359E-03  0.19138E-03  0.18313E-03  0.34295E-03
+  0.40202E-03  0.51303E-03  0.16481E-03  0.10860E-02  0.12161E-02  0.55009E-02
+  0.98458E-02  0.17532E-01  0.30034E-01  0.47647E-01  0.77890E-01  0.10987E+00
+  0.14278E+00  0.18151E+00  0.23414E+00  0.28982E+00  0.37794E+00  0.46411E+00
+  0.59141E+00  0.73083E+00  0.93794E+00  0.11551E+01  0.14741E+01  0.18147E+01
+  0.18320E-03  0.25842E-03  0.34304E-03  0.41872E-03  0.48552E-03  0.55721E-03
+  0.58182E-03  0.59365E-03  0.75869E-03  0.16059E-02  0.11251E-02  0.29712E-03
+  0.69712E-03  0.26469E-02  0.55929E-02  0.10284E-01  0.18366E-01  0.31649E-01
+  0.49996E-01  0.80893E-01  0.13099E+00  0.18466E+00  0.23306E+00  0.29827E+00
+  0.36684E+00  0.47594E+00  0.58158E+00  0.73779E+00  0.90880E+00  0.11628E+01
+  0.14283E+01  0.18176E+01  0.22324E+01  0.52841E-03  0.67929E-03  0.85805E-03
+  0.10269E-02  0.11785E-02  0.13065E-02  0.13855E-02  0.14705E-02  0.17552E-02
+  0.20383E-02  0.64828E-02  0.13724E-02  0.41697E-03  0.51371E-02  0.50846E-02
+  0.10133E-01  0.18742E-01  0.32662E-01  0.51614E-01  0.83580E-01  0.13415E+00
+  0.21613E+00  0.29763E+00  0.37759E+00  0.46103E+00  0.59469E+00  0.72251E+00
+  0.91170E+00  0.11187E+01  0.14264E+01  0.17471E+01  0.22164E+01  0.27156E+01
+  0.13662E-02  0.18426E-02  0.21934E-02  0.25767E-02  0.28862E-02  0.31554E-02
+  0.33284E-02  0.35985E-02  0.41728E-02  0.45916E-02  0.52521E-02  0.11418E-01
+  0.33468E-02  0.10146E-01  0.30185E-02  0.84467E-02  0.17737E-01  0.32372E-01
+  0.51409E-01  0.84078E-01  0.13573E+00  0.21615E+00  0.33995E+00  0.48292E+00
+  0.58444E+00  0.74890E+00  0.90310E+00  0.11317E+01  0.13820E+01  0.17543E+01
+  0.21406E+01  0.27052E+01  0.33045E+01  0.36742E-02  0.43393E-02  0.52007E-02
+  0.59306E-02  0.66359E-02  0.71487E-02  0.74140E-02  0.76750E-02  0.89635E-02
+  0.96869E-02  0.10582E-01  0.86421E-02  0.86947E-02  0.18307E-01  0.11735E-02
+  0.50367E-02  0.15433E-01  0.31274E-01  0.50713E-01  0.84144E-01  0.13695E+00
+  0.21847E+00  0.34040E+00  0.53435E+00  0.74410E+00  0.94599E+00  0.11304E+01
+  0.14045E+01  0.17050E+01  0.21521E+01  0.26141E+01  0.32879E+01  0.40024E+01
+  0.86422E-02  0.10313E-01  0.11346E-01  0.12686E-01  0.13993E-01  0.14991E-01
+  0.15608E-01  0.16263E-01  0.17866E-01  0.19327E-01  0.20734E-01  0.17753E-01
+  0.18617E-01  0.33674E-01  0.96161E-02  0.19936E-02  0.10571E-01  0.28573E-01
+  0.49049E-01  0.84315E-01  0.13904E+00  0.22135E+00  0.34705E+00  0.53641E+00
+  0.80143E+00  0.12197E+01  0.14407E+01  0.17703E+01  0.21324E+01  0.26720E+01
+  0.32260E+01  0.40326E+01  0.48872E+01  0.18005E-01  0.22862E-01  0.27917E-01
+  0.29460E-01  0.31446E-01  0.33677E-01  0.34696E-01  0.35908E-01  0.38634E-01
+  0.41024E-01  0.43360E-01  0.38866E-01  0.40436E-01  0.63837E-01  0.49994E-01
+  0.24443E-01  0.10094E-01  0.10663E-01  0.30412E-01  0.65278E-01  0.11857E+00
+  0.19519E+00  0.31225E+00  0.48921E+00  0.72517E+00  0.11509E+01  0.16791E+01
+  0.20419E+01  0.24424E+01  0.30402E+01  0.36478E+01  0.45281E+01  0.54611E+01
+  0.31988E-01  0.40528E-01  0.51425E-01  0.65385E-01  0.68435E-01  0.71144E-01
+  0.73906E-01  0.75630E-01  0.80201E-01  0.84061E-01  0.87771E-01  0.80068E-01
+  0.82601E-01  0.11712E+00  0.71034E-01  0.18726E+00  0.47031E-01  0.23164E-01
+  0.00000E+00  0.37083E-01  0.92197E-01  0.16648E+00  0.27936E+00  0.44249E+00
+  0.66149E+00  0.10533E+01  0.15336E+01  0.23288E+01  0.28631E+01  0.35336E+01
+  0.42049E+01  0.51714E+01  0.61968E+01  0.54340E-01  0.68736E-01  0.87048E-01
+  0.11041E+00  0.14030E+00  0.15297E+00  0.15526E+00  0.15869E+00  0.16576E+00
+  0.17040E+00  0.17602E+00  0.16271E+00  0.16632E+00  0.22054E+00  0.14932E+00
+  0.13998E+00  0.12181E+00  0.96733E-01  0.79015E-01  0.37386E-01  0.25096E-01
+  0.94053E-01  0.19865E+00  0.33998E+00  0.52122E+00  0.86522E+00  0.12567E+01
+  0.18885E+01  0.28192E+01  0.37376E+01  0.44144E+01  0.53748E+01  0.63969E+01
+  0.83548E-01  0.10554E+00  0.13345E+00  0.16895E+00  0.21420E+00  0.27203E+00
+  0.30925E+00  0.31419E+00  0.32795E+00  0.33724E+00  0.34565E+00  0.32217E+00
+  0.32589E+00  0.41147E+00  0.29784E+00  0.28478E+00  0.26120E+00  0.23220E+00
+  0.22033E+00  0.18475E+00  0.12656E+00  0.54576E-01  0.52585E-01  0.16773E+00
+  0.30333E+00  0.58215E+00  0.86555E+00  0.13230E+01  0.19905E+01  0.31119E+01
+  0.41042E+01  0.49499E+01  0.58570E+01  0.12728E+00  0.16060E+00  0.20281E+00
+  0.25636E+00  0.32442E+00  0.41108E+00  0.51853E+00  0.62577E+00  0.64745E+00
+  0.66469E+00  0.68385E+00  0.64087E+00  0.64166E+00  0.78021E+00  0.58957E+00
+  0.56719E+00  0.53101E+00  0.49151E+00  0.48455E+00  0.45260E+00  0.40448E+00
+  0.36074E+00  0.27839E+00  0.18438E+00  0.83754E-01  0.14707E+00  0.28996E+00
+  0.52902E+00  0.90527E+00  0.15346E+01  0.23415E+01  0.33183E+01  0.39456E+01
+  0.19383E+00  0.24432E+00  0.30817E+00  0.38903E+00  0.49157E+00  0.62174E+00
+  0.78305E+00  0.98850E+00  0.12714E+01  0.13289E+01  0.13600E+01  0.12952E+01
+  0.12870E+01  0.15192E+01  0.11827E+01  0.11383E+01  0.10737E+01  0.10089E+01
+  0.10026E+01  0.96711E+00  0.92360E+00  0.91005E+00  0.87725E+00  0.87991E+00
+  0.94666E+00  0.85405E+00  0.98957E+00  0.11284E+01  0.12336E+01  0.12224E+01
+  0.13692E+01  0.17309E+01  0.20952E+01  0.28686E+00  0.36123E+00  0.45522E+00
+  0.57407E+00  0.72452E+00  0.91515E+00  0.11513E+01  0.14512E+01  0.18598E+01
+  0.23629E+01  0.26035E+01  0.24811E+01  0.24870E+01  0.28697E+01  0.22865E+01
+  0.22004E+01  0.20832E+01  0.19708E+01  0.19578E+01  0.19080E+01  0.18618E+01
+  0.18825E+01  0.19087E+01  0.20323E+01  0.23091E+01  0.24874E+01  0.31099E+01
+  0.39726E+01  0.51687E+01  0.68229E+01  0.96025E+01  0.13955E+02  0.20539E+02
+  0.41628E+00  0.52372E+00  0.65930E+00  0.83063E+00  0.10472E+01  0.13211E+01
+  0.16604E+01  0.20902E+01  0.26713E+01  0.33858E+01  0.42944E+01  0.47319E+01
+  0.47293E+01  0.54173E+01  0.43680E+01  0.41895E+01  0.39576E+01  0.37363E+01
+  0.36830E+01  0.35731E+01  0.34785E+01  0.35018E+01  0.35540E+01  0.37787E+01
+  0.42581E+01  0.46703E+01  0.57648E+01  0.73059E+01  0.94913E+01  0.12609E+02
+  0.17650E+02  0.25617E+02  0.37575E+02  0.60129E+00  0.75560E+00  0.95029E+00
+  0.11960E+01  0.15064E+01  0.18986E+01  0.23841E+01  0.29981E+01  0.38233E+01
+  0.48370E+01  0.61214E+01  0.73029E+01  0.89341E+01  0.10126E+02  0.83476E+01
+  0.79896E+01  0.75373E+01  0.71047E+01  0.69576E+01  0.67168E+01  0.65091E+01
+  0.65014E+01  0.65555E+01  0.68948E+01  0.76348E+01  0.83310E+01  0.10038E+02
+  0.12439E+02  0.15846E+02  0.20724E+02  0.28430E+02  0.40404E+02  0.58643E+02
+  0.86099E+00  0.10805E+01  0.13574E+01  0.17067E+01  0.21475E+01  0.27041E+01
+  0.33933E+01  0.42635E+01  0.54273E+01  0.68560E+01  0.86625E+01  0.10353E+02
+  0.15978E+02  0.18725E+02  0.15580E+02  0.15091E+02  0.14239E+02  0.13413E+02
+  0.13071E+02  0.12568E+02  0.12125E+02  0.12015E+02  0.12014E+02  0.12470E+02
+  0.13542E+02  0.14580E+02  0.17095E+02  0.20610E+02  0.25568E+02  0.32629E+02
+  0.43581E+02  0.60322E+02  0.85549E+02  0.13075E+01  0.16381E+01  0.20549E+01
+  0.25806E+01  0.32437E+01  0.40800E+01  0.51174E+01  0.64255E+01  0.81635E+01
+  0.10300E+02  0.12997E+02  0.15599E+02  0.24076E+02  0.33650E+02  0.31654E+02
+  0.30652E+02  0.29403E+02  0.27957E+02  0.27251E+02  0.26271E+02  0.25416E+02
+  0.25155E+02  0.25116E+02  0.25879E+02  0.27683E+02  0.29531E+02  0.33742E+02
+  0.39584E+02  0.47759E+02  0.59312E+02  0.76824E+02  0.10307E+03  0.14210E+03
+  0.17668E+01  0.22091E+01  0.27664E+01  0.34691E+01  0.43552E+01  0.54724E+01
+  0.68565E+01  0.86008E+01  0.10917E+02  0.13760E+02  0.17342E+02  0.20787E+02
+  0.31970E+02  0.44572E+02  0.47603E+02  0.53364E+02  0.50795E+02  0.48376E+02
+  0.47122E+02  0.45013E+02  0.43058E+02  0.42036E+02  0.41283E+02  0.41713E+02
+  0.43613E+02  0.45324E+02  0.50291E+02  0.57139E+02  0.66630E+02  0.79881E+02
+  0.99863E+02  0.12943E+03  0.17268E+03  0.26507E+01  0.33050E+01  0.41295E+01
+  0.51688E+01  0.64788E+01  0.81300E+01  0.10178E+02  0.12758E+02  0.16167E+02
+  0.20357E+02  0.25633E+02  0.30825E+02  0.47438E+02  0.65535E+02  0.71028E+02
+  0.86829E+02  0.10239E+03  0.97661E+02  0.95638E+02  0.92494E+02  0.88674E+02
+  0.86500E+02  0.84802E+02  0.85138E+02  0.87929E+02  0.90402E+02  0.98115E+02
+  0.10869E+03  0.12324E+03  0.14337E+03  0.17323E+03  0.21662E+03  0.27903E+03
+  0.37501E+01  0.46623E+01  0.58115E+01  0.72598E+01  0.90853E+01  0.11386E+02
+  0.14241E+02  0.17838E+02  0.22573E+02  0.28400E+02  0.35734E+02  0.43098E+02
+  0.66385E+02  0.91041E+02  0.99930E+02  0.12251E+03  0.14863E+03  0.17719E+03
+  0.17339E+03  0.16833E+03  0.16350E+03  0.15956E+03  0.15637E+03  0.15639E+03
+  0.16021E+03  0.16350E+03  0.17469E+03  0.19000E+03  0.21093E+03  0.23967E+03
+  0.28182E+03  0.34222E+03  0.42785E+03  0.53035E+01  0.65696E+01  0.81642E+01
+  0.10174E+02  0.12707E+02  0.15899E+02  0.19863E+02  0.24857E+02  0.31408E+02
+  0.39482E+02  0.49639E+02  0.60014E+02  0.92502E+02  0.12607E+03  0.13987E+03
+  0.17187E+03  0.20920E+03  0.25434E+03  0.31325E+03  0.30408E+03  0.29606E+03
+  0.29210E+03  0.28605E+03  0.28507E+03  0.28995E+03  0.29381E+03  0.30964E+03
+  0.33127E+03  0.36076E+03  0.40099E+03  0.45953E+03  0.54238E+03  0.65822E+03
+  0.14559E-09  0.50949E-09  0.10029E-08  0.22788E-08  0.34260E-08  0.66824E-08
+  0.31995E-07  0.66423E-07  0.19897E-06  0.31213E-06  0.60753E-06  0.34093E-05
+  0.23984E-04  0.10742E-03  0.46414E-03  0.14049E-02  0.33921E-02  0.67809E-02
+  0.11891E-01  0.18837E-01  0.30850E-01  0.47877E-01  0.75169E-01  0.11238E+00
+  0.15819E+00  0.21724E+00  0.29561E+00  0.40411E+00  0.54895E+00  0.76064E+00
+  0.10509E+01  0.14683E+01  0.20792E+01  0.25528E-10  0.21013E-09  0.77036E-09
+  0.22025E-08  0.39989E-08  0.75439E-08  0.43564E-07  0.88516E-07  0.27187E-06
+  0.38094E-06  0.87550E-06  0.73952E-05  0.30671E-04  0.13707E-03  0.59103E-03
+  0.17852E-02  0.43025E-02  0.85869E-02  0.15037E-01  0.23792E-01  0.38915E-01
+  0.60310E-01  0.94554E-01  0.14112E+00  0.19823E+00  0.27153E+00  0.36828E+00
+  0.50142E+00  0.67763E+00  0.93294E+00  0.12788E+01  0.17698E+01  0.24781E+01
+  0.63882E-09  0.36622E-09  0.37694E-10  0.14331E-08  0.38095E-08  0.77366E-08
+  0.62716E-07  0.12319E-06  0.32260E-06  0.44210E-06  0.14192E-05  0.12697E-04
+  0.62543E-04  0.17571E-03  0.75570E-03  0.22771E-02  0.54758E-02  0.10908E-01
+  0.19073E-01  0.30131E-01  0.49221E-01  0.76190E-01  0.11929E+00  0.17778E+00
+  0.24928E+00  0.34070E+00  0.46085E+00  0.62533E+00  0.84146E+00  0.11523E+01
+  0.15690E+01  0.21536E+01  0.29859E+01  0.22630E-08  0.19776E-08  0.17476E-08
+  0.51294E-09  0.14915E-08  0.66415E-08  0.75871E-07  0.17476E-06  0.44572E-06
+  0.80079E-06  0.26841E-05  0.20496E-04  0.10869E-03  0.24821E-03  0.96601E-03
+  0.29029E-02  0.69628E-02  0.13840E-01  0.24155E-01  0.38102E-01  0.62155E-01
+  0.96096E-01  0.15027E+00  0.22364E+00  0.31311E+00  0.42717E+00  0.57652E+00
+  0.78013E+00  0.10461E+01  0.14263E+01  0.19313E+01  0.26328E+01  0.36198E+01
+  0.40718E-08  0.60948E-08  0.59625E-08  0.53064E-08  0.43613E-08  0.00000E+00
+  0.96049E-07  0.26210E-06  0.66373E-06  0.15937E-05  0.52737E-05  0.42864E-04
+  0.16988E-03  0.35753E-03  0.12009E-02  0.37152E-02  0.88848E-02  0.17616E-01
+  0.30677E-01  0.48301E-01  0.78680E-01  0.12148E+00  0.18974E+00  0.28203E+00
+  0.39431E+00  0.53711E+00  0.72353E+00  0.97674E+00  0.13060E+01  0.17741E+01
+  0.23912E+01  0.32410E+01  0.44244E+01  0.11091E-07  0.10807E-07  0.16902E-07
+  0.16938E-07  0.18047E-07  0.17021E-07  0.10218E-06  0.27514E-06  0.11378E-05
+  0.23297E-05  0.93925E-05  0.72862E-04  0.22458E-03  0.50067E-03  0.14508E-02
+  0.45941E-02  0.11373E-01  0.22484E-01  0.39055E-01  0.61364E-01  0.99796E-01
+  0.15386E+00  0.24002E+00  0.35632E+00  0.49755E+00  0.67678E+00  0.91019E+00
+  0.12264E+01  0.16358E+01  0.22153E+01  0.29746E+01  0.40124E+01  0.54445E+01
+  0.15662E-07  0.27867E-07  0.28717E-07  0.44083E-07  0.49170E-07  0.55900E-07
+  0.78542E-07  0.39485E-06  0.15241E-05  0.53659E-05  0.15961E-04  0.11026E-03
+  0.28702E-03  0.61758E-03  0.17737E-02  0.51269E-02  0.14425E-01  0.28749E-01
+  0.49789E-01  0.78038E-01  0.12669E+00  0.19501E+00  0.30381E+00  0.45049E+00
+  0.62827E+00  0.85345E+00  0.11461E+01  0.15417E+01  0.20522E+01  0.27723E+01
+  0.37109E+01  0.49858E+01  0.67314E+01  0.31173E-07  0.41577E-07  0.63728E-07
+  0.85313E-07  0.12204E-06  0.14384E-06  0.89837E-08  0.25418E-06  0.20520E-05
+  0.91240E-05  0.25478E-04  0.13681E-03  0.33641E-03  0.72852E-03  0.20730E-02
+  0.58083E-02  0.15331E-01  0.36854E-01  0.63611E-01  0.99429E-01  0.16110E+00
+  0.24755E+00  0.38514E+00  0.57038E+00  0.79444E+00  0.10778E+01  0.14455E+01
+  0.19415E+01  0.25798E+01  0.34779E+01  0.46432E+01  0.62181E+01  0.83607E+01
+  0.63192E-07  0.83547E-07  0.11678E-06  0.18769E-06  0.30675E-06  0.45511E-06
+  0.21428E-06  0.25747E-07  0.14842E-05  0.99137E-05  0.38814E-04  0.15219E-03
+  0.37548E-03  0.79992E-03  0.23100E-02  0.65066E-02  0.16455E-01  0.39270E-01
+  0.81298E-01  0.12668E+00  0.20483E+00  0.31415E+00  0.48807E+00  0.72185E+00
+  0.10040E+01  0.13605E+01  0.18222E+01  0.24442E+01  0.32430E+01  0.43644E+01
+  0.58138E+01  0.77647E+01  0.10405E+02  0.14170E-06  0.18997E-06  0.22730E-06
+  0.34926E-06  0.64959E-06  0.11100E-05  0.11308E-05  0.63224E-06  0.46767E-06
+  0.59473E-05  0.34960E-04  0.15211E-03  0.38286E-03  0.82568E-03  0.24486E-02
+  0.69464E-02  0.17716E-01  0.40912E-01  0.88991E-01  0.16153E+00  0.26063E+00
+  0.39893E+00  0.61891E+00  0.91408E+00  0.12696E+01  0.17179E+01  0.22980E+01
+  0.30786E+01  0.40788E+01  0.54810E+01  0.72878E+01  0.97114E+01  0.12977E+02
+  0.29643E-06  0.37778E-06  0.49270E-06  0.81595E-06  0.15849E-05  0.35148E-05
+  0.55874E-05  0.64038E-05  0.17140E-05  0.57540E-06  0.48822E-05  0.10979E-03
+  0.33750E-03  0.76815E-03  0.24375E-02  0.71863E-02  0.18220E-01  0.42718E-01
+  0.90568E-01  0.18297E+00  0.33019E+00  0.50447E+00  0.78171E+00  0.11530E+01
+  0.15989E+01  0.21604E+01  0.28859E+01  0.38615E+01  0.51092E+01  0.68567E+01
+  0.91024E+01  0.12107E+02  0.16140E+02  0.61502E-06  0.80062E-06  0.10536E-05
+  0.18718E-05  0.52401E-05  0.12082E-04  0.26028E-04  0.45088E-04  0.39263E-04
+  0.34298E-04  0.52251E-04  0.00000E+00  0.18978E-03  0.58035E-03  0.22167E-02
+  0.71209E-02  0.18412E-01  0.43226E-01  0.91865E-01  0.18424E+00  0.38833E+00
+  0.63777E+00  0.98753E+00  0.14548E+01  0.20141E+01  0.27169E+01  0.36239E+01
+  0.48426E+01  0.63989E+01  0.85770E+01  0.11370E+02  0.15097E+02  0.20087E+02
+  0.27716E-05  0.49574E-05  0.78903E-05  0.21551E-04  0.46190E-04  0.82319E-04
+  0.11561E-03  0.16407E-03  0.18858E-03  0.21378E-03  0.23763E-03  0.25938E-03
+  0.17979E-03  0.68212E-04  0.16766E-02  0.64857E-02  0.17782E-01  0.42753E-01
+  0.90664E-01  0.18328E+00  0.38632E+00  0.77175E+00  0.12385E+01  0.18235E+01
+  0.25203E+01  0.33935E+01  0.45190E+01  0.60303E+01  0.79569E+01  0.10654E+02
+  0.14104E+02  0.18699E+02  0.24838E+02  0.25293E-04  0.43121E-04  0.73049E-04
+  0.12290E-03  0.20547E-03  0.31776E-03  0.42829E-03  0.53339E-03  0.59616E-03
+  0.70551E-03  0.81174E-03  0.99943E-03  0.10077E-02  0.10162E-02  0.30409E-03
+  0.50187E-02  0.16093E-01  0.40761E-01  0.86741E-01  0.17729E+00  0.37911E+00
+  0.75725E+00  0.15414E+01  0.22765E+01  0.31413E+01  0.42211E+01  0.56099E+01
+  0.74750E+01  0.98464E+01  0.13171E+02  0.17412E+02  0.23053E+02  0.30572E+02
+  0.55950E-04  0.71387E-04  0.14711E-03  0.32613E-03  0.57903E-03  0.80652E-03
+  0.10396E-02  0.12804E-02  0.14347E-02  0.16896E-02  0.20005E-02  0.22143E-02
+  0.42192E-02  0.31401E-02  0.21676E-02  0.21041E-02  0.12569E-01  0.36261E-01
+  0.80139E-01  0.16625E+00  0.36402E+00  0.73444E+00  0.14996E+01  0.28158E+01
+  0.38789E+01  0.51999E+01  0.68951E+01  0.91719E+01  0.12058E+02  0.16114E+02
+  0.21270E+02  0.28122E+02  0.37242E+02  0.42139E-03  0.53718E-03  0.68802E-03
+  0.98804E-03  0.14694E-02  0.21369E-02  0.25864E-02  0.30945E-02  0.34574E-02
+  0.39797E-02  0.47381E-02  0.53027E-02  0.61126E-02  0.17641E-01  0.72877E-02
+  0.38092E-02  0.55044E-02  0.27421E-01  0.67551E-01  0.14673E+00  0.33371E+00
+  0.68968E+00  0.14304E+01  0.27692E+01  0.48168E+01  0.64382E+01  0.85113E+01
+  0.11297E+02  0.14814E+02  0.19776E+02  0.26057E+02  0.34395E+02  0.45480E+02
+  0.13847E-02  0.17607E-02  0.22473E-02  0.30311E-02  0.38825E-02  0.48388E-02
+  0.60411E-02  0.69568E-02  0.77066E-02  0.85630E-02  0.96885E-02  0.11061E-01
+  0.12520E-01  0.14639E-01  0.39979E-01  0.12686E-01  0.44224E-02  0.15992E-01
+  0.52621E-01  0.12531E+00  0.30294E+00  0.63973E+00  0.13606E+01  0.26543E+01
+  0.47590E+01  0.79551E+01  0.10475E+02  0.13865E+02  0.18121E+02  0.24159E+02
+  0.31766E+02  0.41856E+02  0.55256E+02  0.30884E-02  0.39171E-02  0.49840E-02
+  0.66903E-02  0.90259E-02  0.11093E-01  0.12574E-01  0.14651E-01  0.15822E-01
+  0.17464E-01  0.19448E-01  0.21214E-01  0.23866E-01  0.27283E-01  0.29026E-01
+  0.66501E-01  0.19515E-01  0.00000E+00  0.33697E-01  0.10076E+00  0.27157E+00
+  0.59258E+00  0.12865E+01  0.25475E+01  0.45632E+01  0.78928E+01  0.13032E+02
+  0.17181E+02  0.22359E+02  0.29753E+02  0.39015E+02  0.51295E+02  0.67591E+02
+  0.64544E-02  0.81709E-02  0.10372E-01  0.13872E-01  0.18627E-01  0.25131E-01
+  0.29798E-01  0.32329E-01  0.35248E-01  0.37944E-01  0.41277E-01  0.44687E-01
+  0.48966E-01  0.54896E-01  0.58960E-01  0.59127E-01  0.13858E+00  0.38970E-01
+  0.13581E-01  0.39280E-01  0.19091E+00  0.47509E+00  0.11084E+01  0.22516E+01
+  0.40797E+01  0.70472E+01  0.11992E+02  0.19810E+02  0.25641E+02  0.34081E+02
+  0.44543E+02  0.58409E+02  0.76799E+02  0.11501E-01  0.14534E-01  0.18411E-01
+  0.24549E-01  0.32833E-01  0.44074E-01  0.58947E-01  0.70230E-01  0.73284E-01
+  0.79031E-01  0.84069E-01  0.89262E-01  0.96136E-01  0.10529E+00  0.11175E+00
+  0.11338E+00  0.11039E+00  0.20555E+00  0.77850E-01  0.36082E-01  0.10416E+00
+  0.36282E+00  0.95677E+00  0.20136E+01  0.36541E+01  0.63327E+01  0.10729E+02
+  0.18307E+02  0.30012E+02  0.39806E+02  0.51792E+02  0.67676E+02  0.88734E+02
+  0.19589E-01  0.24722E-01  0.31265E-01  0.41589E-01  0.55458E-01  0.74162E-01
+  0.98844E-01  0.13261E+00  0.15631E+00  0.16294E+00  0.17220E+00  0.17860E+00
+  0.18813E+00  0.20206E+00  0.21182E+00  0.21522E+00  0.21432E+00  0.20345E+00
+  0.19341E+00  0.16738E+00  0.42306E-01  0.18305E+00  0.72828E+00  0.16795E+01
+  0.30914E+01  0.53403E+01  0.90577E+01  0.15436E+02  0.25671E+02  0.43629E+02
+  0.56449E+02  0.73437E+02  0.95954E+02  0.30204E-01  0.38065E-01  0.48073E-01
+  0.63822E-01  0.84898E-01  0.11320E+00  0.15045E+00  0.20101E+00  0.26747E+00
+  0.32013E+00  0.33388E+00  0.34787E+00  0.36182E+00  0.38219E+00  0.39552E+00
+  0.39949E+00  0.39913E+00  0.38898E+00  0.38831E+00  0.37945E+00  0.26702E+00
+  0.74216E-01  0.42805E+00  0.12769E+01  0.24534E+01  0.42568E+01  0.71744E+01
+  0.12287E+02  0.20284E+02  0.35135E+02  0.58028E+02  0.75072E+02  0.97665E+02
+  0.46159E-01  0.58097E-01  0.73269E-01  0.97102E-01  0.12890E+00  0.17144E+00
+  0.22734E+00  0.30273E+00  0.40149E+00  0.54014E+00  0.65385E+00  0.67323E+00
+  0.70245E+00  0.73226E+00  0.74840E+00  0.74914E+00  0.74461E+00  0.72942E+00
+  0.73628E+00  0.74456E+00  0.63719E+00  0.47252E+00  0.00000E+00  0.75518E+00
+  0.16874E+01  0.30222E+01  0.51027E+01  0.87676E+01  0.14379E+02  0.25224E+02
+  0.41921E+02  0.69987E+02  0.90523E+02  0.70562E-01  0.88681E-01  0.11168E+00
+  0.14776E+00  0.19579E+00  0.25984E+00  0.34389E+00  0.45668E+00  0.60401E+00
+  0.80863E+00  0.10877E+01  0.13335E+01  0.13738E+01  0.14339E+01  0.14529E+01
+  0.14405E+01  0.14198E+01  0.13852E+01  0.13925E+01  0.14138E+01  0.12937E+01
+  0.11457E+01  0.67733E+00  0.00000E+00  0.67209E+00  0.14972E+01  0.26749E+01
+  0.48071E+01  0.77291E+01  0.14240E+02  0.23514E+02  0.39028E+02  0.65592E+02
+  0.10489E+00  0.13162E+00  0.16551E+00  0.21862E+00  0.28923E+00  0.38320E+00
+  0.50637E+00  0.67111E+00  0.88595E+00  0.11819E+01  0.15824E+01  0.21072E+01
+  0.26051E+01  0.26865E+01  0.27318E+01  0.26975E+01  0.26406E+01  0.25638E+01
+  0.25587E+01  0.25854E+01  0.24292E+01  0.22860E+01  0.17978E+01  0.11944E+01
+  0.82494E+00  0.59136E+00  0.43877E+00  0.00000E+00  0.00000E+00  0.16954E+01
+  0.27753E+01  0.45828E+01  0.76040E+01  0.15309E+00  0.19173E+00  0.24069E+00
+  0.31734E+00  0.41912E+00  0.55437E+00  0.73145E+00  0.96767E+00  0.12751E+01
+  0.16961E+01  0.22623E+01  0.30002E+01  0.39967E+01  0.50350E+01  0.50642E+01
+  0.50168E+01  0.48876E+01  0.47017E+01  0.46331E+01  0.46161E+01  0.43301E+01
+  0.41069E+01  0.34661E+01  0.28113E+01  0.26611E+01  0.29329E+01  0.36704E+01
+  0.46583E+01  0.71138E+01  0.92997E+01  0.14924E+02  0.24400E+02  0.40300E+02
+  0.22277E+00  0.27830E+00  0.34866E+00  0.45873E+00  0.60474E+00  0.79854E+00
+  0.10521E+01  0.13897E+01  0.18286E+01  0.24267E+01  0.32275E+01  0.42671E+01
+  0.56611E+01  0.75440E+01  0.94488E+01  0.92775E+01  0.90675E+01  0.87052E+01
+  0.84899E+01  0.83551E+01  0.78023E+01  0.73927E+01  0.64445E+01  0.56379E+01
+  0.57347E+01  0.66329E+01  0.84651E+01  0.11150E+02  0.16475E+02  0.23020E+02
+  0.36056E+02  0.57780E+02  0.94375E+02  0.32197E+00  0.40102E+00  0.50115E+00
+  0.65770E+00  0.86524E+00  0.11405E+01  0.15005E+01  0.19790E+01  0.26008E+01
+  0.34451E+01  0.45718E+01  0.60307E+01  0.79767E+01  0.10587E+02  0.13810E+02
+  0.17111E+02  0.16598E+02  0.15993E+02  0.15566E+02  0.15170E+02  0.14103E+02
+  0.13310E+02  0.11783E+02  0.10645E+02  0.11016E+02  0.12712E+02  0.15938E+02
+  0.20719E+02  0.29520E+02  0.41136E+02  0.62630E+02  0.97987E+02  0.15690E+03
+  0.49522E+00  0.61430E+00  0.76511E+00  0.10008E+01  0.13131E+01  0.17271E+01
+  0.22689E+01  0.29881E+01  0.39233E+01  0.51884E+01  0.68728E+01  0.90531E+01
+  0.11951E+02  0.15818E+02  0.20605E+02  0.26391E+02  0.33242E+02  0.31965E+02
+  0.31303E+02  0.30647E+02  0.28662E+02  0.27238E+02  0.24803E+02  0.23303E+02
+  0.24483E+02  0.28035E+02  0.34322E+02  0.43633E+02  0.59664E+02  0.81806E+02
+  0.12034E+03  0.18272E+03  0.28524E+03  0.67989E+00  0.83917E+00  0.10409E+01
+  0.13562E+01  0.17737E+01  0.23267E+01  0.30502E+01  0.40096E+01  0.52558E+01
+  0.69389E+01  0.91756E+01  0.12063E+02  0.15886E+02  0.20968E+02  0.27214E+02
+  0.34696E+02  0.43831E+02  0.54789E+02  0.53105E+02  0.51669E+02  0.47954E+02
+  0.44716E+02  0.39792E+02  0.36377E+02  0.37029E+02  0.40921E+02  0.48201E+02
+  0.58851E+02  0.77268E+02  0.10185E+03  0.14442E+03  0.21213E+03  0.32172E+03
+  0.10420E+01  0.12778E+01  0.15762E+01  0.20426E+01  0.26601E+01  0.34778E+01
+  0.45479E+01  0.59662E+01  0.78101E+01  0.10295E+02  0.13592E+02  0.17851E+02
+  0.23480E+02  0.30940E+02  0.40142E+02  0.51223E+02  0.64799E+02  0.81174E+02
+  0.10285E+03  0.10242E+03  0.95984E+02  0.90665E+02  0.81824E+02  0.75914E+02
+  0.77055E+02  0.83639E+02  0.95717E+02  0.11323E+03  0.14252E+03  0.18168E+03
+  0.24718E+03  0.34930E+03  0.51155E+03  0.15071E+01  0.18358E+01  0.22519E+01
+  0.29019E+01  0.37626E+01  0.49019E+01  0.63938E+01  0.83705E+01  0.10943E+02
+  0.14403E+02  0.18989E+02  0.24920E+02  0.32755E+02  0.43119E+02  0.55948E+02
+  0.71494E+02  0.90623E+02  0.11384E+03  0.14445E+03  0.18365E+03  0.17256E+03
+  0.16438E+03  0.15110E+03  0.14155E+03  0.14318E+03  0.15321E+03  0.17147E+03
+  0.19774E+03  0.24076E+03  0.29798E+03  0.39136E+03  0.53445E+03  0.75806E+03
+  0.21898E+01  0.26461E+01  0.32236E+01  0.41258E+01  0.53199E+01  0.69007E+01
+  0.89718E+01  0.11715E+02  0.15288E+02  0.20086E+02  0.26444E+02  0.34673E+02
+  0.45532E+02  0.59887E+02  0.77711E+02  0.99421E+02  0.12624E+03  0.15896E+03
+  0.20198E+03  0.25700E+03  0.30966E+03  0.29502E+03  0.27477E+03  0.26030E+03
+  0.26188E+03  0.27635E+03  0.30296E+03  0.34100E+03  0.40248E+03  0.48334E+03
+  0.61285E+03  0.80783E+03  0.11072E+04  0.35418E-09  0.73808E-09  0.13055E-08
+  0.23357E-08  0.37935E-08  0.75686E-08  0.37068E-07  0.70767E-07  0.20190E-06
+  0.33354E-06  0.60384E-06  0.29174E-06  0.30757E-04  0.14841E-03  0.52790E-03
+  0.11937E-03  0.25591E-02  0.40327E-04  0.81170E-02  0.12865E-01  0.28904E-01
+  0.48485E-01  0.79559E-01  0.12606E+00  0.19506E+00  0.29164E+00  0.44727E+00
+  0.66980E+00  0.10355E+01  0.16040E+01  0.25417E+01  0.41328E+01  0.69098E+01
+  0.12377E-09  0.52746E-09  0.11265E-08  0.26117E-08  0.43267E-08  0.79355E-08
+  0.55200E-07  0.96614E-07  0.27044E-06  0.41118E-06  0.80947E-06  0.65253E-06
+  0.39367E-04  0.18950E-03  0.67227E-03  0.15025E-03  0.32447E-02  0.47337E-04
+  0.10261E-01  0.16242E-01  0.36399E-01  0.60947E-01  0.99782E-01  0.15766E+00
+  0.24301E+00  0.36150E+00  0.55068E+00  0.81755E+00  0.12501E+01  0.19104E+01
+  0.29790E+01  0.47568E+01  0.78001E+01  0.52181E-09  0.19698E-09  0.36254E-09
+  0.19432E-08  0.43559E-08  0.87413E-08  0.72040E-07  0.13424E-06  0.32487E-06
+  0.50020E-06  0.12204E-05  0.10910E-05  0.79862E-04  0.24320E-03  0.85978E-03
+  0.18866E-03  0.41278E-02  0.52375E-04  0.13009E-01  0.20563E-01  0.45963E-01
+  0.76838E-01  0.12556E+00  0.19790E+00  0.30408E+00  0.45043E+00  0.68239E+00
+  0.10056E+01  0.15232E+01  0.23002E+01  0.35355E+01  0.55510E+01  0.89329E+01
+  0.20007E-08  0.18958E-08  0.17183E-08  0.19245E-09  0.21375E-08  0.79793E-08
+  0.90527E-07  0.20228E-06  0.46431E-06  0.86722E-06  0.20183E-05  0.17680E-05
+  0.13672E-03  0.34580E-03  0.10994E-02  0.23457E-03  0.52449E-02  0.51122E-04
+  0.16464E-01  0.25986E-01  0.57941E-01  0.96717E-01  0.15778E+00  0.24819E+00
+  0.38035E+00  0.56149E+00  0.84675E+00  0.12404E+01  0.18641E+01  0.27868E+01
+  0.42300E+01  0.65418E+01  0.10347E+02  0.46308E-08  0.56808E-08  0.61320E-08
+  0.55684E-08  0.38467E-08  0.18892E-08  0.11650E-06  0.28341E-06  0.70256E-06
+  0.16481E-05  0.44601E-05  0.35306E-05  0.21248E-03  0.50062E-03  0.13680E-02
+  0.28851E-03  0.66858E-02  0.35032E-04  0.20890E-01  0.32915E-01  0.73191E-01
+  0.12200E+00  0.19874E+00  0.31207E+00  0.47721E+00  0.70246E+00  0.10554E+01
+  0.15383E+01  0.22966E+01  0.34042E+01  0.51110E+01  0.77989E+01  0.12139E+02
+  0.99602E-08  0.12563E-07  0.16272E-07  0.17299E-07  0.18607E-07  0.14810E-07
+  0.12590E-06  0.33651E-06  0.11667E-05  0.23215E-05  0.86027E-05  0.46794E-05
+  0.28020E-03  0.70521E-03  0.16513E-02  0.33507E-03  0.85446E-02  0.17928E-04
+  0.26557E-01  0.41763E-01  0.92598E-01  0.15415E+00  0.25075E+00  0.39314E+00
+  0.60007E+00  0.88121E+00  0.13199E+01  0.19159E+01  0.28447E+01  0.41863E+01
+  0.62271E+01  0.93912E+01  0.14410E+02  0.23154E-07  0.26104E-07  0.33760E-07
+  0.43160E-07  0.49175E-07  0.51615E-07  0.11020E-06  0.40456E-06  0.14242E-05
+  0.55699E-05  0.17453E-04  0.31453E-05  0.35886E-03  0.87478E-03  0.20188E-02
+  0.33056E-03  0.10934E-01  0.14959E-03  0.33781E-01  0.53014E-01  0.11717E+00
+  0.19479E+00  0.31648E+00  0.49549E+00  0.75511E+00  0.11067E+01  0.16534E+01
+  0.23919E+01  0.35355E+01  0.51720E+01  0.76335E+01  0.11397E+02  0.17271E+02
+  0.36763E-07  0.53301E-07  0.73505E-07  0.95433E-07  0.12690E-06  0.13611E-06
+  0.53864E-07  0.29224E-06  0.20297E-05  0.86320E-05  0.30646E-04  0.52383E-05
+  0.42511E-03  0.10453E-02  0.23669E-02  0.29345E-03  0.11583E-01  0.46029E-03
+  0.43009E-01  0.67345E-01  0.14834E+00  0.24629E+00  0.39969E+00  0.62505E+00
+  0.95124E+00  0.13917E+01  0.20750E+01  0.29933E+01  0.44085E+01  0.64174E+01
+  0.94103E+01  0.13931E+02  0.20885E+02  0.73749E-07  0.10027E-06  0.13827E-06
+  0.23203E-06  0.32167E-06  0.43120E-06  0.11080E-06  0.10048E-06  0.14302E-05
+  0.98810E-05  0.52398E-04  0.25081E-04  0.48303E-03  0.11708E-02  0.26469E-02
+  0.18448E-03  0.12324E-01  0.96298E-03  0.54673E-01  0.85417E-01  0.18748E+00
+  0.31093E+00  0.50409E+00  0.78744E+00  0.11970E+01  0.17487E+01  0.26028E+01
+  0.37461E+01  0.55009E+01  0.79759E+01  0.11633E+02  0.17101E+02  0.25404E+02
+  0.16769E-06  0.20925E-06  0.27280E-06  0.39726E-06  0.70383E-06  0.10545E-05
+  0.89162E-06  0.49016E-06  0.50809E-06  0.65655E-05  0.53863E-04  0.67305E-04
+  0.51141E-03  0.12534E-02  0.28279E-02  0.59944E-04  0.13150E-01  0.17781E-02
+  0.61069E-01  0.10814E+00  0.23654E+00  0.39200E+00  0.63505E+00  0.99119E+00
+  0.15053E+01  0.21961E+01  0.32644E+01  0.46892E+01  0.68696E+01  0.99278E+01
+  0.14417E+02  0.21072E+02  0.31064E+02  0.33926E-06  0.43474E-06  0.62299E-06
+  0.10201E-05  0.16510E-05  0.32671E-05  0.48859E-05  0.56312E-05  0.11606E-05
+  0.48969E-06  0.27169E-04  0.14709E-03  0.49113E-03  0.12572E-02  0.28558E-02
+  0.52736E-03  0.13285E-01  0.31993E-02  0.61172E-01  0.12559E+00  0.29604E+00
+  0.49060E+00  0.79471E+00  0.12398E+01  0.18815E+01  0.27420E+01  0.40721E+01
+  0.58400E+01  0.85405E+01  0.12310E+02  0.17816E+02  0.25918E+02  0.37972E+02
+  0.71177E-06  0.93133E-06  0.12313E-05  0.26543E-05  0.57348E-05  0.11328E-04
+  0.20604E-04  0.40908E-04  0.35608E-04  0.28611E-04  0.24231E-04  0.29003E-03
+  0.37424E-03  0.11550E-02  0.26760E-02  0.13762E-02  0.13044E-01  0.55546E-02
+  0.60473E-01  0.12406E+00  0.36799E+00  0.61084E+00  0.99045E+00  0.15455E+01
+  0.23449E+01  0.34141E+01  0.50675E+01  0.72578E+01  0.10600E+02  0.15248E+02
+  0.22006E+02  0.31894E+02  0.46493E+02  0.39124E-05  0.64767E-05  0.12307E-04
+  0.27149E-04  0.49705E-04  0.79784E-04  0.10435E-03  0.14825E-03  0.17601E-03
+  0.19754E-03  0.19154E-03  0.62017E-03  0.44307E-04  0.74662E-03  0.22133E-02
+  0.29780E-02  0.11853E-01  0.97297E-02  0.57221E-01  0.11926E+00  0.44774E+00
+  0.74727E+00  0.12160E+01  0.19009E+01  0.28863E+01  0.42000E+01  0.62356E+01
+  0.89215E+01  0.13022E+02  0.18703E+02  0.26938E+02  0.38932E+02  0.56530E+02
+  0.32366E-04  0.58670E-04  0.93632E-04  0.14231E-03  0.21620E-03  0.30873E-03
+  0.39987E-03  0.50514E-03  0.56771E-03  0.66667E-03  0.72665E-03  0.14475E-02
+  0.71367E-03  0.20231E-03  0.91708E-03  0.59293E-02  0.93462E-02  0.16801E-01
+  0.50509E-01  0.10884E+00  0.41792E+00  0.89523E+00  0.14685E+01  0.23052E+01
+  0.35085E+01  0.51053E+01  0.75890E+01  0.10850E+02  0.15840E+02  0.22728E+02
+  0.32688E+02  0.47147E+02  0.68259E+02  0.64044E-04  0.95009E-04  0.22123E-03
+  0.38869E-03  0.59906E-03  0.78674E-03  0.98287E-03  0.12241E-02  0.13852E-02
+  0.16183E-02  0.18582E-02  0.28926E-02  0.33269E-02  0.20881E-02  0.14521E-02
+  0.10564E-01  0.48354E-02  0.27198E-01  0.40189E-01  0.92065E-01  0.37449E+00
+  0.89652E+00  0.17298E+01  0.27363E+01  0.41826E+01  0.60900E+01  0.90756E+01
+  0.12970E+02  0.18953E+02  0.27183E+02  0.39068E+02  0.56282E+02  0.81327E+02
+  0.48220E-03  0.61591E-03  0.79005E-03  0.11070E-02  0.15303E-02  0.20953E-02
+  0.24642E-02  0.29880E-02  0.33637E-02  0.38473E-02  0.44987E-02  0.62956E-02
+  0.55418E-02  0.13801E-01  0.64001E-02  0.19164E-01  0.37576E-02  0.44991E-01
+  0.22173E-01  0.63944E-01  0.30236E+00  0.76458E+00  0.18184E+01  0.31792E+01
+  0.49039E+01  0.71562E+01  0.10720E+02  0.15322E+02  0.22450E+02  0.32206E+02
+  0.46294E+02  0.66676E+02  0.96264E+02  0.15824E-02  0.20151E-02  0.25744E-02
+  0.33003E-02  0.39683E-02  0.47579E-02  0.57806E-02  0.67383E-02  0.75367E-02
+  0.83743E-02  0.92576E-02  0.12545E-01  0.11699E-01  0.12773E-01  0.38641E-01
+  0.31923E-01  0.15816E-01  0.68870E-01  0.00000E+00  0.31314E-01  0.22073E+00
+  0.62624E+00  0.15588E+01  0.35580E+01  0.56624E+01  0.82885E+01  0.12501E+02
+  0.17872E+02  0.26280E+02  0.37731E+02  0.54274E+02  0.78207E+02  0.11292E+03
+  0.35246E-02  0.44757E-02  0.56979E-02  0.72730E-02  0.93174E-02  0.10992E-01
+  0.12182E-01  0.14243E-01  0.15504E-01  0.17133E-01  0.18832E-01  0.23395E-01
+  0.22647E-01  0.24626E-01  0.27493E-01  0.14623E+00  0.34104E-01  0.10342E+00
+  0.29305E-01  0.88841E-02  0.13042E+00  0.46906E+00  0.12925E+01  0.30480E+01
+  0.64950E+01  0.95482E+01  0.14531E+02  0.20784E+02  0.30708E+02  0.44139E+02
+  0.63572E+02  0.91717E+02  0.13254E+03  0.73586E-02  0.93245E-02  0.11838E-01
+  0.15062E-01  0.19218E-01  0.24597E-01  0.29287E-01  0.31725E-01  0.34674E-01
+  0.37341E-01  0.40310E-01  0.48090E-01  0.47105E-01  0.51009E-01  0.56831E-01
+  0.93439E-01  0.22955E+00  0.16929E+00  0.91775E-01  0.93121E-01  0.47986E-01
+  0.16838E+00  0.76074E+00  0.20968E+01  0.49207E+01  0.93178E+01  0.14598E+02
+  0.20997E+02  0.31482E+02  0.45505E+02  0.65904E+02  0.95578E+02  0.13880E+03
+  0.13100E-01  0.16568E-01  0.20988E-01  0.26628E-01  0.33859E-01  0.43156E-01
+  0.55635E-01  0.69460E-01  0.72416E-01  0.77876E-01  0.82463E-01  0.94859E-01
+  0.93180E-01  0.99283E-01  0.10858E+00  0.16274E+00  0.13744E+00  0.76599E+00
+  0.17896E+00  0.20175E+00  0.24642E+00  0.13964E+00  0.24605E+00  0.11898E+01
+  0.32802E+01  0.71088E+01  0.14184E+02  0.20611E+02  0.31648E+02  0.46157E+02
+  0.67436E+02  0.98615E+02  0.14432E+03  0.22297E-01  0.28155E-01  0.35601E-01
+  0.45076E-01  0.57171E-01  0.72643E-01  0.93422E-01  0.12613E+00  0.15516E+00
+  0.16134E+00  0.16940E+00  0.18803E+00  0.18340E+00  0.19263E+00  0.20699E+00
+  0.28807E+00  0.25306E+00  0.44067E+00  0.32828E+00  0.38089E+00  0.54564E+00
+  0.57902E+00  0.45022E+00  0.00000E+00  0.11612E+01  0.32025E+01  0.89499E+01
+  0.15535E+02  0.25616E+02  0.38384E+02  0.57461E+02  0.85903E+02  0.12823E+03
+  0.34351E-01  0.43321E-01  0.54695E-01  0.69129E-01  0.87499E-01  0.11091E+00
+  0.14235E+00  0.19142E+00  0.25637E+00  0.31759E+00  0.32940E+00  0.36327E+00
+  0.35415E+00  0.36713E+00  0.38795E+00  0.50999E+00  0.45616E+00  0.72520E+00
+  0.57376E+00  0.66302E+00  0.97141E+00  0.11629E+01  0.13149E+01  0.13931E+01
+  0.12400E+01  0.11333E+01  0.10421E+01  0.38949E+01  0.11531E+02  0.19830E+02
+  0.32946E+02  0.53467E+02  0.85305E+02  0.52460E-01  0.66068E-01  0.83296E-01
+  0.10512E+00  0.13282E+00  0.16801E+00  0.21528E+00  0.28855E+00  0.38521E+00
+  0.52084E+00  0.64651E+00  0.69950E+00  0.68927E+00  0.70730E+00  0.73602E+00
+  0.92411E+00  0.83218E+00  0.12294E+01  0.10031E+01  0.11382E+01  0.16243E+01
+  0.19996E+01  0.24675E+01  0.31264E+01  0.40579E+01  0.60449E+01  0.77593E+01
+  0.12235E+02  0.15282E+02  0.16213E+02  0.14886E+02  0.10313E+02  0.00000E+00
+  0.80127E-01  0.10077E+00  0.12686E+00  0.15987E+00  0.20169E+00  0.25469E+00
+  0.32587E+00  0.43560E+00  0.57998E+00  0.78052E+00  0.10526E+01  0.13802E+01
+  0.13514E+01  0.13906E+01  0.14316E+01  0.17313E+01  0.15610E+01  0.21703E+01
+  0.17972E+01  0.19898E+01  0.27034E+01  0.32999E+01  0.41370E+01  0.54597E+01
+  0.75997E+01  0.11880E+02  0.17748E+02  0.30424E+02  0.48017E+02  0.82593E+02
+  0.10282E+03  0.12753E+03  0.15715E+03  0.11900E+00  0.14943E+00  0.18788E+00
+  0.23645E+00  0.29789E+00  0.37564E+00  0.48010E+00  0.64050E+00  0.85120E+00
+  0.11416E+01  0.15331E+01  0.21382E+01  0.25677E+01  0.26142E+01  0.26966E+01
+  0.31769E+01  0.28677E+01  0.38010E+01  0.31776E+01  0.34395E+01  0.44397E+01
+  0.53062E+01  0.65868E+01  0.86922E+01  0.12221E+02  0.19080E+02  0.29472E+02
+  0.50755E+02  0.84772E+02  0.14875E+03  0.25236E+03  0.32634E+03  0.42373E+03
+  0.17349E+00  0.21747E+00  0.27298E+00  0.34306E+00  0.43161E+00  0.54353E+00
+  0.69383E+00  0.92395E+00  0.12257E+01  0.16392E+01  0.21937E+01  0.30384E+01
+  0.39054E+01  0.49100E+01  0.50031E+01  0.58372E+01  0.52670E+01  0.67383E+01
+  0.56219E+01  0.59411E+01  0.72366E+01  0.83581E+01  0.10058E+02  0.12912E+02
+  0.17742E+02  0.26988E+02  0.41324E+02  0.69954E+02  0.11733E+03  0.20728E+03
+  0.36853E+03  0.60901E+03  0.79843E+03  0.25210E+00  0.31529E+00  0.39503E+00
+  0.49563E+00  0.62265E+00  0.78301E+00  0.99839E+00  0.13274E+01  0.17583E+01
+  0.23464E+01  0.31317E+01  0.43140E+01  0.55374E+01  0.73459E+01  0.93419E+01
+  0.10676E+02  0.97176E+01  0.12125E+02  0.10108E+02  0.10469E+02  0.12110E+02
+  0.13522E+02  0.15724E+02  0.19501E+02  0.25934E+02  0.38090E+02  0.57034E+02
+  0.94080E+02  0.15589E+03  0.27362E+03  0.48668E+03  0.87340E+03  0.13984E+04
+  0.36373E+00  0.45367E+00  0.56710E+00  0.71017E+00  0.89070E+00  0.11184E+01
+  0.14244E+01  0.18910E+01  0.25017E+01  0.33324E+01  0.44387E+01  0.60873E+01
+  0.78092E+01  0.10325E+02  0.13709E+02  0.19505E+02  0.17687E+02  0.21769E+02
+  0.18243E+02  0.18597E+02  0.20600E+02  0.22310E+02  0.25090E+02  0.30006E+02
+  0.38440E+02  0.54224E+02  0.78701E+02  0.12565E+03  0.20384E+03  0.35096E+03
+  0.62098E+03  0.11099E+04  0.20071E+04  0.55810E+00  0.69359E+00  0.86443E+00
+  0.10798E+01  0.13515E+01  0.16940E+01  0.21547E+01  0.28561E+01  0.37751E+01
+  0.50208E+01  0.66773E+01  0.91146E+01  0.11714E+02  0.15463E+02  0.20477E+02
+  0.29957E+02  0.35146E+02  0.41963E+02  0.35960E+02  0.36472E+02  0.39123E+02
+  0.41422E+02  0.45373E+02  0.52577E+02  0.65000E+02  0.87852E+02  0.12319E+03
+  0.18920E+03  0.29890E+03  0.50189E+03  0.87185E+03  0.15555E+04  0.27980E+04
+  0.76404E+00  0.94526E+00  0.11738E+01  0.14617E+01  0.18249E+01  0.22825E+01
+  0.28977E+01  0.38336E+01  0.50582E+01  0.67163E+01  0.89161E+01  0.12146E+02
+  0.15574E+02  0.20497E+02  0.27045E+02  0.39377E+02  0.47098E+02  0.72034E+02
+  0.60906E+02  0.61500E+02  0.64049E+02  0.65864E+02  0.69623E+02  0.77387E+02
+  0.91330E+02  0.11753E+03  0.15692E+03  0.23009E+03  0.34873E+03  0.56522E+03
+  0.95383E+03  0.16632E+04  0.29760E+04  0.11665E+01  0.14347E+01  0.17728E+01
+  0.21988E+01  0.27358E+01  0.34125E+01  0.43229E+01  0.57067E+01  0.75190E+01
+  0.99676E+01  0.13214E+02  0.17939E+02  0.23038E+02  0.30298E+02  0.39925E+02
+  0.57531E+02  0.69248E+02  0.10617E+03  0.11932E+03  0.11938E+03  0.12368E+03
+  0.12523E+03  0.12972E+03  0.14030E+03  0.15997E+03  0.19705E+03  0.25211E+03
+  0.35236E+03  0.51245E+03  0.79870E+03  0.13047E+04  0.22173E+04  0.38915E+04
+  0.16808E+01  0.20547E+01  0.25258E+01  0.31196E+01  0.38681E+01  0.48109E+01
+  0.60807E+01  0.80097E+01  0.10538E+02  0.13949E+02  0.18471E+02  0.25004E+02
+  0.32161E+02  0.42284E+02  0.55687E+02  0.79605E+02  0.96412E+02  0.14575E+03
+  0.16607E+03  0.21066E+03  0.21652E+03  0.21840E+03  0.22331E+03  0.23704E+03
+  0.26357E+03  0.31400E+03  0.38802E+03  0.52081E+03  0.72975E+03  0.10966E+04
+  0.17353E+04  0.28727E+04  0.49386E+04  0.24308E+01  0.29498E+01  0.36038E+01
+  0.44280E+01  0.54664E+01  0.67748E+01  0.85380E+01  0.11215E+02  0.14727E+02
+  0.19460E+02  0.25732E+02  0.34739E+02  0.44735E+02  0.58796E+02  0.77396E+02
+  0.10989E+03  0.13380E+03  0.19991E+03  0.22991E+03  0.30173E+03  0.37722E+03
+  0.38206E+03  0.38654E+03  0.40356E+03  0.43862E+03  0.50661E+03  0.60519E+03
+  0.78021E+03  0.10509E+04  0.15177E+04  0.23161E+04  0.37162E+04  0.62268E+04
+  0.30443E-09  0.29799E-10  0.79908E-09  0.12967E-08  0.24942E-08  0.52158E-08
+  0.27477E-07  0.58970E-07  0.41382E-07  0.27937E-06  0.39349E-06  0.28837E-04
+  0.17158E-03  0.39356E-04  0.72982E-03  0.11963E-02  0.18824E-02  0.27543E-02
+  0.37494E-02  0.51763E-02  0.70718E-02  0.97171E-02  0.12889E-01  0.17339E-01
+  0.22214E-01  0.29934E-01  0.37892E-01  0.49848E-01  0.63529E-01  0.84394E-01
+  0.10791E+00  0.14389E+00  0.18618E+00  0.14653E-08  0.11814E-08  0.10403E-09
+  0.95227E-09  0.26186E-08  0.53006E-08  0.34297E-07  0.88331E-07  0.60888E-07
+  0.43732E-06  0.87718E-06  0.38241E-04  0.22398E-03  0.50320E-04  0.94130E-03
+  0.15356E-02  0.24075E-02  0.35105E-02  0.47642E-02  0.65607E-02  0.89420E-02
+  0.12258E-01  0.16224E-01  0.21775E-01  0.27831E-01  0.37399E-01  0.47191E-01
+  0.61852E-01  0.78483E-01  0.10371E+00  0.13178E+00  0.17443E+00  0.22374E+00
+  0.40166E-08  0.41432E-08  0.29928E-08  0.15967E-08  0.10420E-08  0.49332E-08
+  0.66407E-07  0.13363E-06  0.11565E-06  0.58123E-06  0.16067E-05  0.56118E-04
+  0.29465E-03  0.64256E-04  0.12209E-02  0.19803E-02  0.30915E-02  0.44893E-02
+  0.60714E-02  0.83355E-02  0.11331E-01  0.15494E-01  0.20463E-01  0.27401E-01
+  0.34943E-01  0.46840E-01  0.58945E-01  0.77009E-01  0.97343E-01  0.12806E+00
+  0.16187E+00  0.21289E+00  0.27106E+00  0.87578E-08  0.10468E-07  0.10385E-07
+  0.95201E-08  0.74091E-08  0.00000E+00  0.13020E-06  0.37065E-06  0.11952E-06
+  0.60157E-06  0.23256E-05  0.83585E-04  0.39104E-03  0.81649E-04  0.15940E-02
+  0.25681E-02  0.39883E-02  0.57635E-02  0.77626E-02  0.10620E-01  0.14395E-01
+  0.19625E-01  0.25860E-01  0.34546E-01  0.43958E-01  0.58787E-01  0.73797E-01
+  0.96144E-01  0.12115E+00  0.15877E+00  0.19978E+00  0.26135E+00  0.33064E+00
+  0.22530E-07  0.23168E-07  0.27191E-07  0.35125E-07  0.33463E-07  0.31800E-07
+  0.16188E-06  0.71791E-06  0.24181E-06  0.94212E-07  0.22053E-05  0.12261E-03
+  0.47734E-03  0.10171E-03  0.20960E-02  0.33505E-02  0.51724E-02  0.74319E-02
+  0.99601E-02  0.13571E-01  0.18331E-01  0.24913E-01  0.32739E-01  0.43628E-01
+  0.55391E-01  0.73909E-01  0.92571E-01  0.12029E+00  0.15116E+00  0.19746E+00
+  0.24754E+00  0.32232E+00  0.40558E+00  0.53713E-07  0.57902E-07  0.58353E-07
+  0.80624E-07  0.12534E-06  0.13094E-06  0.29398E-06  0.14784E-05  0.16790E-05
+  0.23736E-05  0.39686E-06  0.16030E-03  0.57427E-03  0.10856E-03  0.27785E-02
+  0.44018E-02  0.67482E-02  0.96314E-02  0.12833E-01  0.17402E-01  0.23410E-01
+  0.31694E-01  0.41533E-01  0.55187E-01  0.69905E-01  0.93056E-01  0.11630E+00
+  0.15077E+00  0.18899E+00  0.24617E+00  0.30759E+00  0.39898E+00  0.49975E+00
+  0.12521E-06  0.14961E-06  0.15349E-06  0.15211E-06  0.25941E-06  0.42996E-06
+  0.27136E-07  0.20904E-05  0.55346E-05  0.89216E-05  0.75753E-05  0.20357E-03
+  0.70496E-03  0.99940E-04  0.32844E-02  0.58236E-02  0.88592E-02  0.12548E-01
+  0.16605E-01  0.22391E-01  0.29980E-01  0.40410E-01  0.52774E-01  0.69904E-01
+  0.88317E-01  0.11728E+00  0.14624E+00  0.18915E+00  0.23656E+00  0.30736E+00
+  0.38296E+00  0.49509E+00  0.61773E+00  0.31173E-06  0.38030E-06  0.46346E-06
+  0.42991E-06  0.38585E-06  0.81645E-06  0.14753E-05  0.42869E-06  0.14848E-04
+  0.22989E-04  0.25825E-04  0.24329E-03  0.82740E-03  0.72210E-04  0.36412E-02
+  0.68943E-02  0.11709E-01  0.16443E-01  0.21586E-01  0.28919E-01  0.38508E-01
+  0.51635E-01  0.67174E-01  0.88648E-01  0.11167E+00  0.14789E+00  0.18399E+00
+  0.23740E+00  0.29627E+00  0.38402E+00  0.47728E+00  0.61521E+00  0.76508E+00
+  0.65187E-06  0.97853E-06  0.12792E-05  0.15240E-05  0.12043E-05  0.98577E-06
+  0.41088E-05  0.83168E-05  0.36094E-04  0.52433E-04  0.63405E-04  0.27605E-03
+  0.95555E-03  0.00000E+00  0.40921E-02  0.74958E-02  0.13926E-01  0.21663E-01
+  0.28184E-01  0.37480E-01  0.49596E-01  0.66097E-01  0.85604E-01  0.11248E+00
+  0.14123E+00  0.18648E+00  0.23139E+00  0.29780E+00  0.37084E+00  0.47957E+00
+  0.59468E+00  0.76452E+00  0.94805E+00  0.16722E-05  0.29817E-05  0.57233E-05
+  0.77602E-05  0.88269E-05  0.75938E-05  0.52460E-05  0.26249E-04  0.78776E-04
+  0.11599E-03  0.14353E-03  0.28059E-03  0.10304E-02  0.24909E-03  0.45119E-02
+  0.81914E-02  0.14863E-01  0.25904E-01  0.36856E-01  0.48623E-01  0.63901E-01
+  0.84577E-01  0.10899E+00  0.14250E+00  0.17824E+00  0.23455E+00  0.29021E+00
+  0.37249E+00  0.46281E+00  0.59713E+00  0.73884E+00  0.94757E+00  0.11720E+01
+  0.55311E-05  0.10535E-04  0.20721E-04  0.41470E-04  0.56888E-04  0.63107E-04
+  0.52698E-04  0.60789E-04  0.15955E-03  0.24088E-03  0.30754E-03  0.22465E-03
+  0.10281E-02  0.71687E-03  0.48558E-02  0.88149E-02  0.15858E-01  0.27371E-01
+  0.44145E-01  0.63005E-01  0.82210E-01  0.10799E+00  0.13839E+00  0.17993E+00
+  0.22407E+00  0.29377E+00  0.36231E+00  0.46357E+00  0.57461E+00  0.73964E+00
+  0.91320E+00  0.11684E+01  0.14419E+01  0.46913E-04  0.75092E-04  0.10303E-03
+  0.14018E-03  0.19497E-03  0.23849E-03  0.23947E-03  0.23413E-03  0.39645E-03
+  0.50686E-03  0.65402E-03  0.15102E-04  0.80142E-03  0.16756E-02  0.49694E-02
+  0.91169E-02  0.16519E-01  0.28588E-01  0.45621E-01  0.75000E-01  0.10474E+00
+  0.13654E+00  0.17402E+00  0.22490E+00  0.27872E+00  0.36403E+00  0.44730E+00
+  0.57034E+00  0.70516E+00  0.90548E+00  0.11155E+01  0.14239E+01  0.17533E+01
+  0.20408E-03  0.29878E-03  0.40715E-03  0.50004E-03  0.58525E-03  0.67418E-03
+  0.71155E-03  0.73190E-03  0.92618E-03  0.14700E-02  0.13925E-02  0.68965E-03
+  0.10790E-03  0.34921E-02  0.45269E-02  0.88286E-02  0.16384E-01  0.28878E-01
+  0.46079E-01  0.75402E-01  0.12319E+00  0.16967E+00  0.21524E+00  0.27650E+00
+  0.34092E+00  0.44362E+00  0.54283E+00  0.68951E+00  0.85022E+00  0.10890E+01
+  0.13385E+01  0.17043E+01  0.20941E+01  0.67794E-03  0.87388E-03  0.10835E-02
+  0.12819E-02  0.14727E-02  0.16460E-02  0.17760E-02  0.19053E-02  0.22256E-02
+  0.26572E-02  0.49980E-02  0.22880E-02  0.19908E-02  0.70106E-02  0.26975E-02
+  0.69469E-02  0.14456E-01  0.26770E-01  0.43517E-01  0.72121E-01  0.11811E+00
+  0.19293E+00  0.25674E+00  0.32830E+00  0.40292E+00  0.52299E+00  0.63715E+00
+  0.80608E+00  0.99133E+00  0.12666E+01  0.15533E+01  0.19725E+01  0.24187E+01
+  0.16281E-02  0.22085E-02  0.26345E-02  0.30918E-02  0.35107E-02  0.38578E-02
+  0.41436E-02  0.45198E-02  0.51490E-02  0.57138E-02  0.68942E-02  0.12895E-01
+  0.65667E-02  0.13772E-01  0.25101E-02  0.17176E-02  0.87345E-02  0.20112E-01
+  0.34800E-01  0.61104E-01  0.10322E+00  0.17001E+00  0.27467E+00  0.36457E+00
+  0.44652E+00  0.58038E+00  0.70427E+00  0.88779E+00  0.10897E+01  0.13898E+01
+  0.17007E+01  0.21540E+01  0.26359E+01  0.37210E-02  0.46838E-02  0.57858E-02
+  0.65780E-02  0.73948E-02  0.80831E-02  0.85167E-02  0.92207E-02  0.10426E-01
+  0.11400E-01  0.12612E-01  0.12139E-01  0.13818E-01  0.23937E-01  0.11336E-01
+  0.80894E-02  0.00000E+00  0.10419E-01  0.22834E-01  0.46056E-01  0.84299E-01
+  0.14311E+00  0.23544E+00  0.38340E+00  0.48124E+00  0.62853E+00  0.75979E+00
+  0.95440E+00  0.11695E+01  0.14894E+01  0.18186E+01  0.22962E+01  0.28041E+01
+  0.87135E-02  0.99608E-02  0.11573E-01  0.13414E-01  0.14706E-01  0.15992E-01
+  0.16847E-01  0.17588E-01  0.19602E-01  0.21347E-01  0.23226E-01  0.22074E-01
+  0.55906E-01  0.39578E-01  0.24766E-01  0.23214E-01  0.17382E-01  0.58607E-02
+  0.55224E-02  0.25398E-01  0.58492E-01  0.10904E+00  0.18885E+00  0.31318E+00
+  0.48874E+00  0.65418E+00  0.78869E+00  0.98818E+00  0.12103E+01  0.15406E+01
+  0.18773E+01  0.23624E+01  0.28790E+01  0.17900E-01  0.21992E-01  0.23907E-01
+  0.26384E-01  0.29176E-01  0.30988E-01  0.32524E-01  0.33943E-01  0.36914E-01
+  0.39470E-01  0.42497E-01  0.41069E-01  0.47680E-01  0.12607E+00  0.49094E-01
+  0.50258E-01  0.48026E-01  0.42018E-01  0.37837E-01  0.19694E-01  0.11526E-01
+  0.47228E-01  0.10806E+00  0.19856E+00  0.32304E+00  0.56993E+00  0.69186E+00
+  0.87195E+00  0.10757E+01  0.13783E+01  0.16810E+01  0.21104E+01  0.25693E+01
+  0.31256E-01  0.39692E-01  0.48481E-01  0.51174E-01  0.54644E-01  0.58549E-01
+  0.60666E-01  0.63111E-01  0.67210E-01  0.71412E-01  0.75621E-01  0.73568E-01
+  0.82556E-01  0.11294E+00  0.13927E+00  0.92338E-01  0.94212E-01  0.94460E-01
+  0.10159E+00  0.99247E-01  0.84889E-01  0.60484E-01  0.00000E+00  0.52415E-01
+  0.12086E+00  0.27902E+00  0.44448E+00  0.58339E+00  0.74628E+00  0.98601E+00
+  0.12159E+01  0.15294E+01  0.18683E+01  0.49047E-01  0.62176E-01  0.78950E-01
+  0.96121E-01  0.99703E-01  0.10431E+00  0.10891E+00  0.11210E+00  0.11846E+00
+  0.12451E+00  0.13044E+00  0.12701E+00  0.13955E+00  0.17902E+00  0.15148E+00
+  0.19972E+00  0.16122E+00  0.16761E+00  0.18658E+00  0.20014E+00  0.20951E+00
+  0.22300E+00  0.22027E+00  0.21421E+00  0.21241E+00  0.79320E-01  0.00000E+00
+  0.79063E-01  0.18170E+00  0.32631E+00  0.44678E+00  0.58543E+00  0.74364E+00
+  0.76018E-01  0.96229E-01  0.12198E+00  0.15489E+00  0.18818E+00  0.19304E+00
+  0.19826E+00  0.20453E+00  0.21259E+00  0.22010E+00  0.22929E+00  0.22360E+00
+  0.24128E+00  0.29761E+00  0.25378E+00  0.27384E+00  0.27794E+00  0.29363E+00
+  0.33017E+00  0.36704E+00  0.41062E+00  0.47752E+00  0.55462E+00  0.67344E+00
+  0.86779E+00  0.10336E+01  0.14155E+01  0.19547E+01  0.26075E+01  0.28478E+01
+  0.33063E+01  0.39835E+01  0.48184E+01  0.10903E+00  0.13785E+00  0.17448E+00
+  0.22117E+00  0.28084E+00  0.34090E+00  0.34657E+00  0.35444E+00  0.36887E+00
+  0.37828E+00  0.38991E+00  0.37972E+00  0.40255E+00  0.48234E+00  0.41680E+00
+  0.43303E+00  0.44946E+00  0.47314E+00  0.52727E+00  0.58647E+00  0.66242E+00
+  0.78019E+00  0.93158E+00  0.11657E+01  0.15390E+01  0.19688E+01  0.27920E+01
+  0.39665E+01  0.57130E+01  0.79024E+01  0.94284E+01  0.11504E+02  0.14121E+02
+  0.15570E+00  0.19666E+00  0.24862E+00  0.31469E+00  0.39889E+00  0.50647E+00
+  0.61226E+00  0.62314E+00  0.64539E+00  0.66521E+00  0.68154E+00  0.66413E+00
+  0.69450E+00  0.80993E+00  0.71133E+00  0.73377E+00  0.75789E+00  0.79485E+00
+  0.87704E+00  0.97213E+00  0.10997E+01  0.12969E+01  0.15628E+01  0.19709E+01
+  0.26096E+01  0.34258E+01  0.48619E+01  0.70144E+01  0.10161E+02  0.14945E+02
+  0.21256E+02  0.25913E+02  0.31830E+02  0.21543E+00  0.27186E+00  0.34334E+00
+  0.43407E+00  0.54941E+00  0.69635E+00  0.88088E+00  0.10658E+01  0.10971E+01
+  0.11267E+01  0.11603E+01  0.11297E+01  0.11667E+01  0.13332E+01  0.11792E+01
+  0.12053E+01  0.12338E+01  0.12815E+01  0.13931E+01  0.15246E+01  0.17046E+01
+  0.19841E+01  0.23664E+01  0.29501E+01  0.38527E+01  0.50402E+01  0.70588E+01
+  0.10096E+02  0.14672E+02  0.21432E+02  0.32217E+02  0.45777E+02  0.55954E+02
+  0.32052E+00  0.40413E+00  0.50997E+00  0.64406E+00  0.81423E+00  0.10305E+01
+  0.13021E+01  0.16488E+01  0.20147E+01  0.20579E+01  0.21119E+01  0.20837E+01
+  0.21362E+01  0.23857E+01  0.21521E+01  0.21921E+01  0.22388E+01  0.23187E+01
+  0.24970E+01  0.27140E+01  0.30159E+01  0.34779E+01  0.41173E+01  0.50798E+01
+  0.65411E+01  0.85212E+01  0.11752E+02  0.16598E+02  0.23946E+02  0.35080E+02
+  0.52164E+02  0.79157E+02  0.11138E+03  0.46592E+00  0.58705E+00  0.74019E+00
+  0.93397E+00  0.11796E+01  0.14911E+01  0.18822E+01  0.23800E+01  0.30393E+01
+  0.36897E+01  0.37666E+01  0.37250E+01  0.38316E+01  0.42047E+01  0.38408E+01
+  0.38942E+01  0.39589E+01  0.40756E+01  0.43388E+01  0.46638E+01  0.51193E+01
+  0.58126E+01  0.67735E+01  0.82041E+01  0.10345E+02  0.13266E+02  0.17912E+02
+  0.24828E+02  0.35246E+02  0.51103E+02  0.75666E+02  0.11323E+03  0.17212E+03
+  0.66582E+00  0.83822E+00  0.10560E+01  0.13315E+01  0.16801E+01  0.21218E+01
+  0.26760E+01  0.33798E+01  0.43055E+01  0.54672E+01  0.66337E+01  0.65549E+01
+  0.67749E+01  0.73327E+01  0.67560E+01  0.68180E+01  0.68959E+01  0.70513E+01
+  0.74213E+01  0.78809E+01  0.85304E+01  0.95184E+01  0.10886E+02  0.12905E+02
+  0.15889E+02  0.19952E+02  0.26293E+02  0.35635E+02  0.49575E+02  0.70626E+02
+  0.10328E+03  0.15355E+03  0.23011E+03  0.98835E+00  0.12434E+01  0.15653E+01
+  0.19720E+01  0.24864E+01  0.31374E+01  0.39542E+01  0.49899E+01  0.63427E+01
+  0.80400E+01  0.10205E+02  0.12045E+02  0.12384E+02  0.13359E+02  0.12454E+02
+  0.12537E+02  0.12646E+02  0.12877E+02  0.13434E+02  0.14131E+02  0.15120E+02
+  0.16616E+02  0.18680E+02  0.21694E+02  0.26089E+02  0.32056E+02  0.41179E+02
+  0.54466E+02  0.74087E+02  0.10343E+03  0.14845E+03  0.21801E+03  0.32432E+03
+  0.14354E+01  0.18041E+01  0.22696E+01  0.28571E+01  0.35997E+01  0.45386E+01
+  0.57165E+01  0.72084E+01  0.91466E+01  0.11577E+02  0.14670E+02  0.18179E+02
+  0.22154E+02  0.23681E+02  0.22464E+02  0.22552E+02  0.22677E+02  0.22984E+02
+  0.23777E+02  0.24775E+02  0.26199E+02  0.28356E+02  0.31325E+02  0.35628E+02
+  0.41833E+02  0.50202E+02  0.62787E+02  0.80891E+02  0.10730E+03  0.14637E+03
+  0.20557E+03  0.29607E+03  0.43538E+03  0.20512E+01  0.25756E+01  0.32372E+01
+  0.40723E+01  0.51269E+01  0.64588E+01  0.81306E+01  0.10245E+02  0.12981E+02
+  0.16412E+02  0.20766E+02  0.25761E+02  0.39107E+02  0.41377E+02  0.39550E+02
+  0.39956E+02  0.40057E+02  0.40423E+02  0.41508E+02  0.42875E+02  0.44850E+02
+  0.47863E+02  0.52007E+02  0.57988E+02  0.66542E+02  0.77977E+02  0.94948E+02
+  0.11905E+03  0.15376E+03  0.20447E+03  0.28033E+03  0.39496E+03  0.56962E+03
+  0.29956E+01  0.37570E+01  0.47175E+01  0.59292E+01  0.74590E+01  0.93897E+01
+  0.11814E+02  0.14877E+02  0.18825E+02  0.23776E+02  0.30050E+02  0.37333E+02
+  0.59255E+02  0.74207E+02  0.71247E+02  0.72067E+02  0.72706E+02  0.73155E+02
+  0.74689E+02  0.76627E+02  0.79456E+02  0.83801E+02  0.89770E+02  0.98347E+02
+  0.11052E+03  0.12665E+03  0.15029E+03  0.18344E+03  0.23058E+03  0.29854E+03
+  0.39883E+03  0.54845E+03  0.77385E+03  0.44291E+01  0.55473E+01  0.69575E+01
+  0.87359E+01  0.10980E+02  0.13812E+02  0.17369E+02  0.21859E+02  0.27627E+02
+  0.34862E+02  0.44018E+02  0.54768E+02  0.86819E+02  0.11457E+03  0.13037E+03
+  0.13145E+03  0.13293E+03  0.13447E+03  0.13667E+03  0.13945E+03  0.14357E+03
+  0.14992E+03  0.15865E+03  0.17114E+03  0.18874E+03  0.21190E+03  0.24543E+03
+  0.29188E+03  0.35708E+03  0.44987E+03  0.58490E+03  0.78361E+03  0.10793E+04
+  0.64259E+01  0.80351E+01  0.10064E+02  0.12622E+02  0.15849E+02  0.19919E+02
+  0.25032E+02  0.31484E+02  0.39751E+02  0.50119E+02  0.63230E+02  0.78751E+02
+  0.12468E+03  0.16371E+03  0.20099E+03  0.23543E+03  0.23726E+03  0.24055E+03
+  0.24517E+03  0.24898E+03  0.25470E+03  0.26368E+03  0.27603E+03  0.29373E+03
+  0.31856E+03  0.35100E+03  0.39754E+03  0.46129E+03  0.54970E+03  0.67387E+03
+  0.85208E+03  0.11107E+04  0.14905E+04  0.23962E-09  0.28160E-10  0.45500E-09
+  0.18011E-08  0.39373E-08  0.68683E-08  0.46733E-07  0.92329E-07  0.28024E-06
+  0.38831E-06  0.92330E-06  0.81276E-05  0.32008E-04  0.14241E-03  0.61409E-03
+  0.18547E-02  0.44691E-02  0.89178E-02  0.15614E-01  0.24699E-01  0.40389E-01
+  0.62586E-01  0.98103E-01  0.14638E+00  0.20556E+00  0.28147E+00  0.38156E+00
+  0.51920E+00  0.70114E+00  0.96444E+00  0.13205E+01  0.18249E+01  0.25510E+01
+  0.11217E-08  0.92981E-09  0.53519E-09  0.56221E-09  0.27253E-08  0.66499E-08
+  0.62644E-07  0.12697E-06  0.32869E-06  0.44985E-06  0.15726E-05  0.13543E-04
+  0.68316E-04  0.18177E-03  0.78203E-03  0.23567E-02  0.56666E-02  0.11286E-01
+  0.19730E-01  0.31166E-01  0.50905E-01  0.78780E-01  0.12333E+00  0.18376E+00
+  0.25761E+00  0.35199E+00  0.47596E+00  0.64556E+00  0.86820E+00  0.11881E+01
+  0.16163E+01  0.22162E+01  0.30686E+01  0.30976E-08  0.31717E-08  0.31556E-08
+  0.18011E-08  0.82555E-09  0.36647E-08  0.75894E-07  0.18646E-06  0.46516E-06
+  0.86669E-06  0.28703E-05  0.23111E-04  0.11577E-03  0.26094E-03  0.99813E-03
+  0.30003E-02  0.71964E-02  0.14303E-01  0.24958E-01  0.39362E-01  0.64204E-01
+  0.99251E-01  0.15518E+00  0.23092E+00  0.32324E+00  0.44089E+00  0.59487E+00
+  0.80467E+00  0.10786E+01  0.14697E+01  0.19887E+01  0.27088E+01  0.37202E+01
+  0.55697E-08  0.80728E-08  0.88386E-08  0.88912E-08  0.80610E-08  0.59446E-08
+  0.92244E-07  0.26278E-06  0.70812E-06  0.17137E-05  0.56898E-05  0.45853E-04
+  0.17779E-03  0.37195E-03  0.12257E-02  0.38279E-02  0.91561E-02  0.18153E-01
+  0.31609E-01  0.49761E-01  0.81052E-01  0.12512E+00  0.19541E+00  0.29044E+00
+  0.40601E+00  0.55293E+00  0.74468E+00  0.10051E+01  0.13434E+01  0.18241E+01
+  0.24575E+01  0.33286E+01  0.45400E+01  0.15568E-07  0.14736E-07  0.22200E-07
+  0.24767E-07  0.27059E-07  0.31356E-07  0.87214E-07  0.27816E-06  0.11474E-05
+  0.23146E-05  0.96460E-05  0.75640E-04  0.22875E-03  0.51466E-03  0.14750E-02
+  0.46324E-02  0.11666E-01  0.23067E-01  0.40068E-01  0.62951E-01  0.10238E+00
+  0.15784E+00  0.24621E+00  0.36552E+00  0.51031E+00  0.69404E+00  0.93324E+00
+  0.12572E+01  0.16764E+01  0.22698E+01  0.30466E+01  0.41077E+01  0.55702E+01
+  0.20633E-07  0.37657E-07  0.38634E-07  0.61517E-07  0.69720E-07  0.81320E-07
+  0.47554E-07  0.33503E-06  0.14369E-05  0.55123E-05  0.16291E-04  0.10998E-03
+  0.28602E-03  0.61817E-03  0.17929E-02  0.51570E-02  0.14450E-01  0.29349E-01
+  0.50837E-01  0.79690E-01  0.12939E+00  0.19918E+00  0.31033E+00  0.46016E+00
+  0.64170E+00  0.87159E+00  0.11704E+01  0.15741E+01  0.20949E+01  0.28296E+01
+  0.37863E+01  0.50856E+01  0.68633E+01  0.40552E-07  0.54798E-07  0.84030E-07
+  0.11510E-06  0.16525E-06  0.19874E-06  0.51086E-07  0.14971E-06  0.18269E-05
+  0.82764E-05  0.24191E-04  0.13175E-03  0.32919E-03  0.71679E-03  0.20572E-02
+  0.58110E-02  0.15310E-01  0.37357E-01  0.64517E-01  0.10088E+00  0.16352E+00
+  0.25133E+00  0.39112E+00  0.57927E+00  0.80685E+00  0.10946E+01  0.14678E+01
+  0.19714E+01  0.26193E+01  0.35307E+01  0.47127E+01  0.63097E+01  0.84817E+01
+  0.81979E-07  0.10803E-06  0.15123E-06  0.24023E-06  0.40407E-06  0.60601E-06
+  0.37634E-06  0.10960E-06  0.11143E-05  0.80850E-05  0.33447E-04  0.14035E-03
+  0.35539E-03  0.76893E-03  0.22649E-02  0.64311E-02  0.16356E-01  0.39065E-01
+  0.81865E-01  0.12766E+00  0.20659E+00  0.31701E+00  0.49273E+00  0.72892E+00
+  0.10139E+01  0.13738E+01  0.18401E+01  0.24681E+01  0.32744E+01  0.44063E+01
+  0.58691E+01  0.78376E+01  0.10501E+02  0.17942E-06  0.24207E-06  0.28916E-06
+  0.44388E-06  0.82442E-06  0.14264E-05  0.16295E-05  0.11337E-05  0.11488E-06
+  0.29855E-05  0.21964E-04  0.12739E-03  0.34326E-03  0.76329E-03  0.23478E-02
+  0.67897E-02  0.17445E-01  0.40486E-01  0.88208E-01  0.16128E+00  0.26062E+00
+  0.39927E+00  0.61995E+00  0.91604E+00  0.12725E+01  0.17220E+01  0.23034E+01
+  0.30859E+01  0.40885E+01  0.54939E+01  0.73047E+01  0.97333E+01  0.13006E+02
+  0.37674E-06  0.47971E-06  0.62415E-06  0.10431E-05  0.20425E-05  0.45387E-05
+  0.77040E-05  0.94573E-05  0.46647E-05  0.34630E-05  0.19536E-04  0.59970E-04
+  0.25752E-03  0.64507E-03  0.22396E-02  0.68678E-02  0.17699E-01  0.41861E-01
+  0.89099E-01  0.18049E+00  0.32726E+00  0.50082E+00  0.77719E+00  0.11473E+01
+  0.15917E+01  0.21509E+01  0.28735E+01  0.38451E+01  0.50875E+01  0.68279E+01
+  0.90641E+01  0.12055E+02  0.16071E+02  0.77676E-06  0.10121E-05  0.13189E-05
+  0.23730E-05  0.65943E-05  0.15095E-04  0.33931E-04  0.59692E-04  0.59895E-04
+  0.54389E-04  0.93878E-04  0.91298E-04  0.37808E-04  0.34677E-03  0.18569E-02
+  0.65347E-02  0.17460E-01  0.41658E-01  0.89205E-01  0.17984E+00  0.38096E+00
+  0.62401E+00  0.96877E+00  0.14294E+01  0.19803E+01  0.26722E+01  0.35649E+01
+  0.47647E+01  0.62962E+01  0.84406E+01  0.11189E+02  0.14858E+02  0.19770E+02
+  0.33636E-05  0.58776E-05  0.92555E-05  0.25481E-04  0.54318E-04  0.96211E-04
+  0.14075E-03  0.20853E-03  0.25605E-03  0.29388E-03  0.33210E-03  0.43870E-03
+  0.46705E-03  0.37153E-03  0.98718E-03  0.54224E-02  0.16050E-01  0.39938E-01
+  0.86052E-01  0.17553E+00  0.37348E+00  0.75032E+00  0.11925E+01  0.17608E+01
+  0.24368E+01  0.32833E+01  0.43736E+01  0.58384E+01  0.77041E+01  0.10320E+02
+  0.13662E+02  0.18115E+02  0.24064E+02  0.24303E-04  0.44319E-04  0.74840E-04
+  0.12607E-03  0.23020E-03  0.37380E-03  0.52215E-03  0.65887E-03  0.76687E-03
+  0.91296E-03  0.10608E-02  0.15401E-02  0.15368E-02  0.18269E-02  0.95442E-03
+  0.30472E-02  0.12987E-01  0.35738E-01  0.78660E-01  0.16405E+00  0.35664E+00
+  0.72018E+00  0.14402E+01  0.21327E+01  0.29500E+01  0.39691E+01  0.52791E+01
+  0.70390E+01  0.92739E+01  0.12413E+02  0.16412E+02  0.21733E+02  0.28827E+02
+  0.88113E-04  0.11265E-03  0.22910E-03  0.45233E-03  0.74710E-03  0.10457E-02
+  0.13349E-02  0.16529E-02  0.18987E-02  0.22718E-02  0.27123E-02  0.31186E-02
+  0.99262E-02  0.49186E-02  0.48846E-02  0.20441E-02  0.61375E-02  0.26090E-01
+  0.63879E-01  0.13995E+00  0.32058E+00  0.66133E+00  0.13784E+01  0.25029E+01
+  0.34658E+01  0.46587E+01  0.61867E+01  0.82410E+01  0.10839E+02  0.14501E+02
+  0.19147E+02  0.25322E+02  0.33543E+02  0.40412E-03  0.51571E-03  0.66153E-03
+  0.11002E-02  0.17655E-02  0.25336E-02  0.32051E-02  0.38775E-02  0.44312E-02
+  0.51819E-02  0.62258E-02  0.71787E-02  0.89346E-02  0.29889E-01  0.12573E-01
+  0.11896E-01  0.69529E-02  0.78712E-02  0.36672E-01  0.97263E-01  0.25270E+00
+  0.55621E+00  0.12045E+01  0.23962E+01  0.38692E+01  0.52028E+01  0.69017E+01
+  0.91887E+01  0.12060E+02  0.16141E+02  0.21280E+02  0.28105E+02  0.37182E+02
+  0.13569E-02  0.17278E-02  0.22094E-02  0.29878E-02  0.39687E-02  0.53505E-02
+  0.67016E-02  0.80485E-02  0.91150E-02  0.10290E-01  0.12218E-01  0.14059E-01
+  0.16512E-01  0.20762E-01  0.33763E-01  0.25538E-01  0.24158E-01  0.14796E-01
+  0.44903E-02  0.49041E-01  0.17906E+00  0.43750E+00  0.10241E+01  0.20902E+01
+  0.38339E+01  0.57114E+01  0.75676E+01  0.10072E+02  0.13185E+02  0.17660E+02
+  0.23245E+02  0.30655E+02  0.40500E+02  0.31848E-02  0.40463E-02  0.51595E-02
+  0.69488E-02  0.91684E-02  0.10974E-01  0.13397E-01  0.15612E-01  0.17634E-01
+  0.19700E-01  0.21983E-01  0.25586E-01  0.29450E-01  0.35066E-01  0.41782E-01
+  0.46425E-01  0.47766E-01  0.44338E-01  0.35299E-01  0.76918E-02  0.96430E-01
+  0.30921E+00  0.82099E+00  0.17733E+01  0.32833E+01  0.57991E+01  0.81033E+01
+  0.10785E+02  0.14076E+02  0.18877E+02  0.24799E+02  0.32652E+02  0.43077E+02
+  0.64001E-02  0.81164E-02  0.10325E-01  0.13854E-01  0.18681E-01  0.23569E-01
+  0.26472E-01  0.30622E-01  0.33496E-01  0.36997E-01  0.41093E-01  0.45665E-01
+  0.52167E-01  0.60744E-01  0.69824E-01  0.10405E+00  0.88212E-01  0.92571E-01
+  0.98328E-01  0.94615E-01  0.26372E-01  0.12452E+00  0.53429E+00  0.13133E+01
+  0.25300E+01  0.45015E+01  0.78207E+01  0.10507E+02  0.13662E+02  0.18402E+02
+  0.24118E+02  0.31696E+02  0.41752E+02  0.11204E-01  0.14186E-01  0.18009E-01
+  0.24093E-01  0.32360E-01  0.43676E-01  0.52036E-01  0.56673E-01  0.62446E-01
+  0.67404E-01  0.73525E-01  0.80726E-01  0.89771E-01  0.10222E+00  0.11565E+00
+  0.12952E+00  0.36955E+00  0.16075E+00  0.18335E+00  0.20622E+00  0.17622E+00
+  0.90493E-01  0.21453E+00  0.80827E+00  0.17078E+01  0.31321E+01  0.54747E+01
+  0.92726E+01  0.12002E+02  0.16330E+02  0.21343E+02  0.27988E+02  0.36800E+02
+  0.17624E-01  0.22282E-01  0.28240E-01  0.37686E-01  0.50453E-01  0.67815E-01
+  0.91159E-01  0.10319E+00  0.10941E+00  0.11838E+00  0.12696E+00  0.13731E+00
+  0.14995E+00  0.16717E+00  0.18565E+00  0.20510E+00  0.22836E+00  0.97087E+00
+  0.29426E+00  0.34412E+00  0.35048E+00  0.32624E+00  0.11654E+00  0.30822E+00
+  0.89885E+00  0.18101E+01  0.32588E+01  0.58906E+01  0.90964E+01  0.12693E+02
+  0.16533E+02  0.21622E+02  0.28369E+02  0.27375E-01  0.34570E-01  0.43751E-01
+  0.58263E-01  0.77797E-01  0.10422E+00  0.13959E+00  0.18817E+00  0.20066E+00
+  0.21203E+00  0.22565E+00  0.23834E+00  0.25648E+00  0.28076E+00  0.30655E+00
+  0.33411E+00  0.36834E+00  0.40933E+00  0.10559E+01  0.56302E+00  0.62068E+00
+  0.68140E+00  0.60092E+00  0.40052E+00  0.21269E+00  0.00000E+00  0.28555E+00
+  0.94228E+00  0.15756E+01  0.34855E+01  0.45210E+01  0.58931E+01  0.77120E+01
+  0.39347E-01  0.49632E-01  0.62740E-01  0.83402E-01  0.11112E+00  0.14844E+00
+  0.19820E+00  0.26608E+00  0.35120E+00  0.36513E+00  0.38434E+00  0.40287E+00
+  0.42575E+00  0.45821E+00  0.49189E+00  0.52737E+00  0.57210E+00  0.62730E+00
+  0.71757E+00  0.84356E+00  0.94696E+00  0.10835E+01  0.11120E+01  0.11022E+01
+  0.12627E+01  0.16521E+01  0.23943E+01  0.34615E+01  0.57238E+01  0.82208E+01
+  0.11577E+02  0.15031E+02  0.19608E+02  0.56324E-01  0.70975E-01  0.89609E-01
+  0.11894E+00  0.15816E+00  0.21081E+00  0.28079E+00  0.37568E+00  0.50243E+00
+  0.63772E+00  0.66448E+00  0.69568E+00  0.72995E+00  0.77474E+00  0.82016E+00
+  0.86757E+00  0.92844E+00  0.10059E+01  0.11352E+01  0.13197E+01  0.14955E+01
+  0.17501E+01  0.19475E+01  0.22251E+01  0.28956E+01  0.41483E+01  0.63412E+01
+  0.98520E+01  0.16271E+02  0.25554E+02  0.42907E+02  0.57691E+02  0.74971E+02
+  0.78130E-01  0.98345E-01  0.12404E+00  0.16439E+00  0.21827E+00  0.29036E+00
+  0.38595E+00  0.51493E+00  0.68646E+00  0.92475E+00  0.11209E+01  0.11619E+01
+  0.12207E+01  0.12815E+01  0.13393E+01  0.13975E+01  0.14731E+01  0.15711E+01
+  0.17403E+01  0.19855E+01  0.22302E+01  0.25989E+01  0.29504E+01  0.34928E+01
+  0.46403E+01  0.66920E+01  0.10205E+02  0.15891E+02  0.26063E+02  0.41546E+02
+  0.69047E+02  0.11528E+03  0.14910E+03  0.11657E+00  0.14657E+00  0.18465E+00
+  0.24443E+00  0.32407E+00  0.43040E+00  0.57123E+00  0.76056E+00  0.10118E+01
+  0.13578E+01  0.18313E+01  0.21072E+01  0.21920E+01  0.23080E+01  0.23910E+01
+  0.24748E+01  0.25861E+01  0.27351E+01  0.29937E+01  0.33728E+01  0.37854E+01
+  0.44209E+01  0.51495E+01  0.63075E+01  0.84968E+01  0.12247E+02  0.18523E+02
+  0.28726E+02  0.46429E+02  0.74801E+02  0.12347E+03  0.20566E+03  0.32801E+03
+  0.17001E+00  0.21350E+00  0.26869E+00  0.35521E+00  0.47034E+00  0.62372E+00
+  0.82674E+00  0.10987E+01  0.14591E+01  0.19519E+01  0.26219E+01  0.35216E+01
+  0.38742E+01  0.40432E+01  0.42014E+01  0.43140E+01  0.44666E+01  0.46757E+01
+  0.50461E+01  0.55939E+01  0.62115E+01  0.71739E+01  0.83529E+01  0.10240E+02
+  0.13649E+02  0.19350E+02  0.28732E+02  0.43904E+02  0.69751E+02  0.11147E+03
+  0.18383E+03  0.30332E+03  0.50645E+03  0.24388E+00  0.30585E+00  0.38444E+00
+  0.50756E+00  0.67117E+00  0.88894E+00  0.11768E+01  0.15616E+01  0.20705E+01
+  0.27627E+01  0.36986E+01  0.49496E+01  0.66601E+01  0.70048E+01  0.72438E+01
+  0.74469E+01  0.76438E+01  0.79201E+01  0.84283E+01  0.91876E+01  0.10055E+02
+  0.11421E+02  0.13145E+02  0.15911E+02  0.20785E+02  0.28781E+02  0.41740E+02
+  0.62502E+02  0.97333E+02  0.15349E+03  0.24972E+03  0.41265E+03  0.68110E+03
+  0.36373E+00  0.45544E+00  0.57167E+00  0.75367E+00  0.99532E+00  0.13165E+01
+  0.17412E+01  0.23074E+01  0.30560E+01  0.40691E+01  0.54329E+01  0.72506E+01
+  0.97197E+01  0.12706E+02  0.13044E+02  0.13414E+02  0.13769E+02  0.14167E+02
+  0.14914E+02  0.16038E+02  0.17348E+02  0.19419E+02  0.22104E+02  0.26387E+02
+  0.33717E+02  0.45497E+02  0.64269E+02  0.94013E+02  0.14310E+03  0.22196E+03
+  0.35535E+03  0.57986E+03  0.95794E+03  0.53126E+00  0.66395E+00  0.83209E+00
+  0.10952E+01  0.14443E+01  0.19080E+01  0.25206E+01  0.33365E+01  0.44140E+01
+  0.58669E+01  0.78160E+01  0.10407E+02  0.13907E+02  0.18673E+02  0.23113E+02
+  0.23602E+02  0.24293E+02  0.24899E+02  0.25942E+02  0.27530E+02  0.29390E+02
+  0.32354E+02  0.36240E+02  0.42427E+02  0.52824E+02  0.69253E+02  0.95006E+02
+  0.13528E+03  0.20070E+03  0.30499E+03  0.47919E+03  0.76990E+03  0.12602E+04
+  0.76453E+00  0.95328E+00  0.11924E+01  0.15665E+01  0.20626E+01  0.27209E+01
+  0.35906E+01  0.47473E+01  0.62742E+01  0.83264E+01  0.11072E+02  0.14713E+02
+  0.19611E+02  0.26240E+02  0.35005E+02  0.41100E+02  0.41983E+02  0.43265E+02
+  0.44671E+02  0.46838E+02  0.49364E+02  0.53454E+02  0.58842E+02  0.67434E+02
+  0.81720E+02  0.10396E+03  0.13829E+03  0.19120E+03  0.27579E+03  0.40919E+03
+  0.62915E+03  0.99261E+03  0.16006E+04  0.11261E+01  0.14003E+01  0.17476E+01
+  0.22908E+01  0.30107E+01  0.39654E+01  0.52267E+01  0.69023E+01  0.91141E+01
+  0.12079E+02  0.16037E+02  0.21278E+02  0.28303E+02  0.37767E+02  0.50256E+02
+  0.66746E+02  0.74763E+02  0.76485E+02  0.79394E+02  0.82450E+02  0.86010E+02
+  0.91850E+02  0.99584E+02  0.11192E+03  0.13218E+03  0.16327E+03  0.21050E+03
+  0.28220E+03  0.39495E+03  0.57060E+03  0.85611E+03  0.13226E+04  0.20954E+04
+  0.16826E+01  0.20854E+01  0.25954E+01  0.33929E+01  0.44496E+01  0.58504E+01
+  0.77008E+01  0.10157E+02  0.13400E+02  0.17737E+02  0.23515E+02  0.31161E+02
+  0.41382E+02  0.55100E+02  0.73180E+02  0.97018E+02  0.12890E+03  0.13787E+03
+  0.14229E+03  0.14812E+03  0.15322E+03  0.16169E+03  0.17296E+03  0.19092E+03
+  0.22012E+03  0.26431E+03  0.33040E+03  0.42924E+03  0.58204E+03  0.81689E+03
+  0.11929E+04  0.17994E+04  0.27932E+04  0.24728E+01  0.30523E+01  0.37864E+01
+  0.49339E+01  0.64535E+01  0.84675E+01  0.11128E+02  0.14658E+02  0.19316E+02
+  0.25537E+02  0.33814E+02  0.44757E+02  0.59349E+02  0.78880E+02  0.10459E+03
+  0.13843E+03  0.18351E+03  0.24394E+03  0.25055E+03  0.25978E+03  0.26869E+03
+  0.28049E+03  0.29623E+03  0.32149E+03  0.36244E+03  0.42373E+03  0.51414E+03
+  0.64737E+03  0.84995E+03  0.11567E+04  0.16402E+04  0.24092E+04  0.36538E+04
+  0.12093E-09  0.23113E-09  0.77472E-09  0.22481E-08  0.41405E-08  0.75803E-08
+  0.59879E-07  0.10113E-06  0.27709E-06  0.42244E-06  0.84627E-06  0.70575E-06
+  0.42356E-04  0.19699E-03  0.69858E-03  0.15502E-03  0.33699E-02  0.46345E-04
+  0.10653E-01  0.16860E-01  0.37768E-01  0.63224E-01  0.10348E+00  0.16343E+00
+  0.25177E+00  0.37426E+00  0.56958E+00  0.84456E+00  0.12893E+01  0.19663E+01
+  0.30589E+01  0.48707E+01  0.79624E+01  0.10470E-08  0.81583E-09  0.42801E-09
+  0.99924E-09  0.32713E-08  0.79816E-08  0.72274E-07  0.13922E-06  0.33340E-06
+  0.51801E-06  0.13166E-05  0.11250E-05  0.87001E-04  0.25177E-03  0.88988E-03
+  0.19303E-03  0.42703E-02  0.48391E-04  0.13454E-01  0.21264E-01  0.47517E-01
+  0.79422E-01  0.12975E+00  0.20445E+00  0.31402E+00  0.46492E+00  0.70380E+00
+  0.10363E+01  0.15677E+01  0.23637E+01  0.36261E+01  0.56801E+01  0.91171E+01
+  0.30563E-08  0.32009E-08  0.31995E-08  0.21355E-08  0.24403E-09  0.51929E-08
+  0.91450E-07  0.21365E-06  0.48440E-06  0.92637E-06  0.21372E-05  0.19153E-05
+  0.14557E-03  0.36411E-03  0.11363E-02  0.23807E-03  0.54188E-02  0.41500E-04
+  0.17006E-01  0.26838E-01  0.59822E-01  0.99850E-01  0.16287E+00  0.25612E+00
+  0.39241E+00  0.57904E+00  0.87274E+00  0.12775E+01  0.19180E+01  0.28637E+01
+  0.43397E+01  0.66983E+01  0.10569E+02  0.63577E-08  0.82162E-08  0.92826E-08
+  0.90699E-08  0.84752E-08  0.38736E-08  0.11366E-06  0.28754E-06  0.75802E-06
+  0.17625E-05  0.48809E-05  0.33963E-05  0.22120E-03  0.52188E-03  0.13964E-02
+  0.28883E-03  0.68857E-02  0.14456E-04  0.21513E-01  0.33894E-01  0.75357E-01
+  0.12561E+00  0.20459E+00  0.32120E+00  0.49108E+00  0.72264E+00  0.10853E+01
+  0.15810E+01  0.23585E+01  0.34925E+01  0.52371E+01  0.79786E+01  0.12396E+02
+  0.13919E-07  0.17112E-07  0.22980E-07  0.25593E-07  0.27836E-07  0.26906E-07
+  0.11295E-06  0.34242E-06  0.11802E-05  0.23797E-05  0.89717E-05  0.36587E-05
+  0.28622E-03  0.72727E-03  0.16798E-02  0.32043E-03  0.87556E-02  0.64499E-04
+  0.27221E-01  0.42813E-01  0.94927E-01  0.15802E+00  0.25707E+00  0.40302E+00
+  0.61508E+00  0.90306E+00  0.13522E+01  0.19621E+01  0.29119E+01  0.42820E+01
+  0.63635E+01  0.95856E+01  0.14687E+02  0.28990E-07  0.35814E-07  0.45273E-07
+  0.59899E-07  0.70173E-07  0.75055E-07  0.82541E-07  0.33358E-06  0.14024E-05
+  0.57189E-05  0.18227E-04  0.00000E+00  0.35929E-03  0.88022E-03  0.20428E-02
+  0.30106E-03  0.10965E-01  0.24744E-03  0.34445E-01  0.54072E-01  0.11954E+00
+  0.19877E+00  0.32299E+00  0.50573E+00  0.77068E+00  0.11293E+01  0.16870E+01
+  0.24398E+01  0.36052E+01  0.52715E+01  0.77752E+01  0.11599E+02  0.17559E+02
+  0.48280E-07  0.69170E-07  0.98560E-07  0.12930E-06  0.17397E-06  0.19479E-06
+  0.46571E-08  0.20024E-06  0.18260E-05  0.79531E-05  0.30494E-04  0.12238E-04
+  0.41869E-03  0.10367E-02  0.23535E-02  0.23440E-03  0.11534E-01  0.66560E-03
+  0.43524E-01  0.68201E-01  0.15034E+00  0.24974E+00  0.40543E+00  0.63411E+00
+  0.96516E+00  0.14120E+01  0.21052E+01  0.30364E+01  0.44712E+01  0.65067E+01
+  0.95372E+01  0.14113E+02  0.21142E+02  0.95464E-07  0.12950E-06  0.17910E-06
+  0.30019E-06  0.42461E-06  0.57000E-06  0.24558E-06  0.43764E-07  0.11087E-05
+  0.83665E-05  0.47505E-04  0.38779E-04  0.46406E-03  0.11433E-02  0.26040E-02
+  0.76318E-04  0.12196E-01  0.12928E-02  0.54860E-01  0.85826E-01  0.18866E+00
+  0.31317E+00  0.50805E+00  0.79396E+00  0.12072E+01  0.17636E+01  0.26253E+01
+  0.37783E+01  0.55479E+01  0.80427E+01  0.11728E+02  0.17237E+02  0.25596E+02
+  0.21264E-06  0.26637E-06  0.34545E-06  0.50677E-06  0.89398E-06  0.13575E-05
+  0.13508E-05  0.98934E-06  0.20990E-06  0.41146E-05  0.41666E-04  0.92391E-04
+  0.47302E-03  0.11929E-02  0.27274E-02  0.24046E-03  0.12862E-01  0.22997E-02
+  0.60197E-01  0.10749E+00  0.23575E+00  0.39128E+00  0.63459E+00  0.99115E+00
+  0.15058E+01  0.21973E+01  0.32671E+01  0.46932E+01  0.68763E+01  0.99373E+01
+  0.14430E+02  0.21091E+02  0.31089E+02  0.43101E-06  0.55155E-06  0.79358E-06
+  0.13077E-05  0.21276E-05  0.42209E-05  0.68488E-05  0.85715E-05  0.41354E-05
+  0.19631E-05  0.45286E-05  0.19576E-03  0.41254E-03  0.11354E-02  0.26569E-02
+  0.85759E-03  0.12744E-01  0.41267E-02  0.59592E-01  0.12290E+00  0.29176E+00
+  0.48486E+00  0.78695E+00  0.12293E+01  0.18670E+01  0.27219E+01  0.40441E+01
+  0.58008E+01  0.84855E+01  0.12232E+02  0.17705E+02  0.25759E+02  0.37742E+02
+  0.89935E-06  0.11720E-05  0.15320E-05  0.33463E-05  0.72198E-05  0.14196E-04
+  0.27044E-04  0.54926E-04  0.55822E-04  0.49800E-04  0.62317E-04  0.37719E-03
+  0.22366E-03  0.92015E-03  0.23128E-02  0.19507E-02  0.12074E-01  0.71142E-02
+  0.57710E-01  0.11943E+00  0.35559E+00  0.59320E+00  0.96523E+00  0.15095E+01
+  0.22937E+01  0.33416E+01  0.49645E+01  0.71126E+01  0.10394E+02  0.14955E+02
+  0.21590E+02  0.31301E+02  0.45641E+02  0.46752E-05  0.76268E-05  0.14891E-04
+  0.31902E-04  0.58457E-04  0.93227E-04  0.12706E-03  0.18863E-03  0.24135E-03
+  0.27799E-03  0.28644E-03  0.78841E-03  0.24114E-03  0.30247E-03  0.15156E-02
+  0.39986E-02  0.10115E-01  0.12404E-01  0.52467E-01  0.11124E+00  0.41944E+00
+  0.70668E+00  0.11575E+01  0.18167E+01  0.27660E+01  0.40299E+01  0.59928E+01
+  0.85788E+01  0.12534E+02  0.18012E+02  0.25956E+02  0.37536E+02  0.54536E+02
+  0.33365E-04  0.60165E-04  0.95860E-04  0.15140E-03  0.24365E-03  0.36184E-03
+  0.48709E-03  0.62595E-03  0.73385E-03  0.87077E-03  0.97054E-03  0.19835E-02
+  0.12520E-02  0.10278E-02  0.35982E-03  0.77237E-02  0.62473E-02  0.21362E-01
+  0.42320E-01  0.95204E-01  0.38027E+00  0.80645E+00  0.13399E+01  0.21201E+01
+  0.32431E+01  0.47303E+01  0.70527E+01  0.10094E+02  0.14763E+02  0.21202E+02
+  0.30524E+02  0.44071E+02  0.63876E+02  0.10097E-03  0.16429E-03  0.32142E-03
+  0.53048E-03  0.77338E-03  0.10200E-02  0.12657E-02  0.15811E-02  0.18378E-02
+  0.21873E-02  0.25637E-02  0.37397E-02  0.80843E-02  0.39250E-02  0.42076E-02
+  0.14412E-01  0.15746E-02  0.36555E-01  0.23760E-01  0.65007E-01  0.30037E+00
+  0.75861E+00  0.14453E+01  0.23302E+01  0.36044E+01  0.52764E+01  0.79169E+01
+  0.11340E+02  0.16638E+02  0.23910E+02  0.34432E+02  0.49703E+02  0.71968E+02
+  0.46269E-03  0.59178E-03  0.82400E-03  0.12641E-02  0.18501E-02  0.24913E-02
+  0.30395E-02  0.37321E-02  0.43179E-02  0.50317E-02  0.59756E-02  0.80169E-02
+  0.83494E-02  0.27573E-01  0.11786E-01  0.26401E-01  0.16029E-01  0.62134E-01
+  0.85674E-02  0.13827E-01  0.16711E+00  0.51292E+00  0.13445E+01  0.22763E+01
+  0.36201E+01  0.53534E+01  0.81528E+01  0.11717E+02  0.17326E+02  0.24973E+02
+  0.36056E+02  0.52155E+02  0.75627E+02  0.15518E-02  0.19794E-02  0.25340E-02
+  0.32309E-02  0.40924E-02  0.52351E-02  0.64638E-02  0.78078E-02  0.89098E-02
+  0.10073E-01  0.11827E-01  0.15208E-01  0.15777E-01  0.19086E-01  0.30582E-01
+  0.42942E-01  0.35007E-01  0.94435E-01  0.47095E-01  0.44711E-01  0.19461E-01
+  0.25033E+00  0.86198E+00  0.20204E+01  0.33863E+01  0.51021E+01  0.79696E+01
+  0.11522E+02  0.17265E+02  0.25011E+02  0.36287E+02  0.52718E+02  0.76721E+02
+  0.36381E-02  0.46287E-02  0.59065E-02  0.75621E-02  0.93311E-02  0.10823E-01
+  0.12831E-01  0.15225E-01  0.17335E-01  0.19371E-01  0.21461E-01  0.27195E-01
+  0.28416E-01  0.32915E-01  0.40613E-01  0.68185E-01  0.60961E-01  0.13676E+00
+  0.94947E-01  0.11422E+00  0.14415E+00  0.37550E-01  0.34522E+00  0.12880E+01
+  0.27578E+01  0.43330E+01  0.71199E+01  0.10421E+02  0.15998E+02  0.23409E+02
+  0.34276E+02  0.50217E+02  0.73633E+02  0.73037E-02  0.92725E-02  0.11801E-01
+  0.15059E-01  0.19284E-01  0.23383E-01  0.25774E-01  0.29770E-01  0.32945E-01
+  0.36479E-01  0.40205E-01  0.47892E-01  0.50716E-01  0.57849E-01  0.68314E-01
+  0.16489E+00  0.10428E+00  0.20244E+00  0.16891E+00  0.21828E+00  0.37511E+00
+  0.43482E+00  0.36299E+00  0.00000E+00  0.10024E+01  0.20760E+01  0.42908E+01
+  0.66082E+01  0.11041E+02  0.16708E+02  0.25207E+02  0.37925E+02  0.56940E+02
+  0.12775E-01  0.16190E-01  0.20557E-01  0.26162E-01  0.33389E-01  0.42752E-01
+  0.51208E-01  0.55686E-01  0.61511E-01  0.66514E-01  0.72302E-01  0.83851E-01
+  0.87714E-01  0.98240E-01  0.11366E+00  0.16444E+00  0.51649E+00  0.29440E+00
+  0.26826E+00  0.35179E+00  0.64781E+00  0.88401E+00  0.11411E+01  0.13979E+01
+  0.15539E+01  0.17748E+01  0.60824E+00  0.00000E+00  0.23320E+01  0.48756E+01
+  0.90902E+01  0.15930E+02  0.26864E+02  0.20079E-01  0.25407E-01  0.32202E-01
+  0.40888E-01  0.52037E-01  0.66404E-01  0.86098E-01  0.10205E+00  0.10810E+00
+  0.11721E+00  0.12513E+00  0.14193E+00  0.14702E+00  0.16160E+00  0.18294E+00
+  0.25136E+00  0.25544E+00  0.12694E+01  0.39803E+00  0.51769E+00  0.95532E+00
+  0.13633E+01  0.19333E+01  0.27882E+01  0.40472E+01  0.65388E+01  0.77860E+01
+  0.96306E+01  0.10363E+02  0.12348E+02  0.14359E+02  0.16077E+02  0.16918E+02
+  0.31168E-01  0.39388E-01  0.49843E-01  0.63171E-01  0.80214E-01  0.10208E+00
+  0.13198E+00  0.17905E+00  0.19907E+00  0.20998E+00  0.22306E+00  0.24542E+00
+  0.25217E+00  0.27279E+00  0.30277E+00  0.39691E+00  0.40425E+00  0.62630E+00
+  0.60473E+00  0.77510E+00  0.14064E+01  0.20436E+01  0.30233E+01  0.46373E+01
+  0.73762E+01  0.12526E+02  0.20547E+02  0.27349E+02  0.33909E+02  0.44378E+02
+  0.58145E+02  0.76143E+02  0.99546E+02  0.44775E-01  0.56514E-01  0.71419E-01
+  0.90373E-01  0.11454E+00  0.14543E+00  0.18757E+00  0.25341E+00  0.34238E+00
+  0.36243E+00  0.38015E+00  0.41381E+00  0.41953E+00  0.44665E+00  0.48646E+00
+  0.61441E+00  0.62045E+00  0.90544E+00  0.88321E+00  0.11062E+01  0.19309E+01
+  0.27840E+01  0.41364E+01  0.64243E+01  0.10409E+02  0.18033E+02  0.30348E+02
+  0.50866E+02  0.64902E+02  0.86273E+02  0.11515E+03  0.15406E+03  0.20643E+03
+  0.64053E-01  0.80760E-01  0.10193E+00  0.12882E+00  0.16300E+00  0.20657E+00
+  0.26592E+00  0.35809E+00  0.48205E+00  0.63383E+00  0.65836E+00  0.71172E+00
+  0.72073E+00  0.75771E+00  0.81225E+00  0.99079E+00  0.99517E+00  0.13792E+01
+  0.13520E+01  0.16543E+01  0.27663E+01  0.39363E+01  0.58284E+01  0.90767E+01
+  0.14810E+02  0.25809E+02  0.44285E+02  0.80533E+02  0.12002E+03  0.16067E+03
+  0.21638E+03  0.29264E+03  0.39698E+03  0.88800E-01  0.11184E+00  0.14102E+00
+  0.17798E+00  0.22491E+00  0.28456E+00  0.36572E+00  0.49113E+00  0.65906E+00
+  0.89290E+00  0.11120E+01  0.11867E+01  0.12063E+01  0.12561E+01  0.13275E+01
+  0.15749E+01  0.15665E+01  0.20827E+01  0.20290E+01  0.24187E+01  0.38394E+01
+  0.53323E+01  0.77550E+01  0.11919E+02  0.19275E+02  0.33247E+02  0.57641E+02
+  0.10400E+03  0.18720E+03  0.25941E+03  0.34982E+03  0.47438E+03  0.64593E+03
+  0.13240E+00  0.16658E+00  0.20981E+00  0.26452E+00  0.33386E+00  0.42187E+00
+  0.54159E+00  0.72580E+00  0.97202E+00  0.13121E+01  0.17776E+01  0.21454E+01
+  0.21704E+01  0.22697E+01  0.23734E+01  0.27351E+01  0.27207E+01  0.34543E+01
+  0.33916E+01  0.39556E+01  0.59920E+01  0.81452E+01  0.11658E+02  0.17699E+02
+  0.28363E+02  0.48349E+02  0.83709E+02  0.15166E+03  0.27266E+03  0.47148E+03
+  0.63642E+03  0.86526E+03  0.11826E+04  0.19297E+00  0.24250E+00  0.30511E+00
+  0.38427E+00  0.48448E+00  0.61143E+00  0.78418E+00  0.10490E+01  0.14024E+01
+  0.18873E+01  0.25473E+01  0.35184E+01  0.38416E+01  0.39847E+01  0.41746E+01
+  0.47009E+01  0.46628E+01  0.57049E+01  0.56031E+01  0.63906E+01  0.92041E+01
+  0.12164E+02  0.16977E+02  0.25196E+02  0.39599E+02  0.66223E+02  0.11341E+03
+  0.20398E+03  0.36677E+03  0.67500E+03  0.10583E+04  0.14369E+04  0.19639E+04
+  0.27660E+00  0.34716E+00  0.43628E+00  0.54888E+00  0.69132E+00  0.87147E+00
+  0.11166E+01  0.14915E+01  0.19909E+01  0.26726E+01  0.35961E+01  0.49362E+01
+  0.65466E+01  0.69160E+01  0.72044E+01  0.80283E+01  0.79328E+01  0.94163E+01
+  0.92196E+01  0.10294E+02  0.14098E+02  0.18061E+02  0.24454E+02  0.35258E+02
+  0.53986E+02  0.88098E+02  0.14828E+03  0.26240E+03  0.47214E+03  0.86040E+03
+  0.15960E+04  0.22642E+04  0.30880E+04  0.41216E+00  0.51654E+00  0.64832E+00
+  0.81472E+00  0.10250E+01  0.12909E+01  0.16527E+01  0.22047E+01  0.29394E+01
+  0.39382E+01  0.52861E+01  0.72157E+01  0.95647E+01  0.12570E+02  0.12984E+02
+  0.14301E+02  0.14201E+02  0.16378E+02  0.16063E+02  0.17615E+02  0.23054E+02
+  0.28674E+02  0.37664E+02  0.52673E+02  0.78356E+02  0.12435E+03  0.20497E+03
+  0.35571E+03  0.63184E+03  0.11523E+04  0.21146E+04  0.37278E+04  0.50678E+04
+  0.60134E+00  0.75235E+00  0.94292E+00  0.11834E+01  0.14872E+01  0.18710E+01
+  0.23934E+01  0.31888E+01  0.42470E+01  0.56804E+01  0.76090E+01  0.10341E+02
+  0.13697E+02  0.18440E+02  0.23019E+02  0.24942E+02  0.24968E+02  0.28203E+02
+  0.27629E+02  0.29803E+02  0.37374E+02  0.45114E+02  0.57371E+02  0.77568E+02
+  0.11162E+03  0.17155E+03  0.27543E+03  0.46688E+03  0.81504E+03  0.14718E+04
+  0.26895E+04  0.49730E+04  0.79333E+04  0.86422E+00  0.10790E+01  0.13500E+01
+  0.16919E+01  0.21235E+01  0.26684E+01  0.34102E+01  0.45382E+01  0.60383E+01
+  0.80639E+01  0.10784E+02  0.14603E+02  0.19327E+02  0.25941E+02  0.34998E+02
+  0.43144E+02  0.42992E+02  0.48260E+02  0.47169E+02  0.50148E+02  0.60501E+02
+  0.70969E+02  0.87384E+02  0.11408E+03  0.15840E+03  0.23504E+03  0.36603E+03
+  0.60367E+03  0.10315E+04  0.18304E+04  0.33340E+04  0.61012E+04  0.11358E+05
+  0.12709E+01  0.15829E+01  0.19764E+01  0.24728E+01  0.30990E+01  0.38893E+01
+  0.49655E+01  0.66003E+01  0.87734E+01  0.11701E+02  0.15625E+02  0.21093E+02
+  0.27910E+02  0.37379E+02  0.50269E+02  0.70295E+02  0.76291E+02  0.84092E+02
+  0.83144E+02  0.87352E+02  0.10195E+03  0.11658E+03  0.13931E+03  0.17582E+03
+  0.23549E+03  0.33676E+03  0.50723E+03  0.81121E+03  0.13520E+04  0.23498E+04
+  0.42117E+04  0.77046E+04  0.14169E+05  0.18954E+01  0.23536E+01  0.29314E+01
+  0.36601E+01  0.45792E+01  0.57387E+01  0.73185E+01  0.97154E+01  0.12902E+02
+  0.17187E+02  0.22921E+02  0.30855E+02  0.40832E+02  0.54589E+02  0.73233E+02
+  0.10156E+03  0.13332E+03  0.14943E+03  0.14815E+03  0.15547E+03  0.17641E+03
+  0.19724E+03  0.22935E+03  0.28030E+03  0.36230E+03  0.49889E+03  0.72508E+03
+  0.11210E+04  0.18155E+04  0.30799E+04  0.54147E+04  0.97935E+04  0.17939E+05
+  0.27790E+01  0.34383E+01  0.42699E+01  0.53180E+01  0.66401E+01  0.83072E+01
+  0.10579E+02  0.14024E+02  0.18603E+02  0.24751E+02  0.32969E+02  0.44279E+02
+  0.58586E+02  0.78207E+02  0.10470E+03  0.14424E+03  0.18937E+03  0.26224E+03
+  0.25937E+03  0.27132E+03  0.30218E+03  0.33115E+03  0.37554E+03  0.44529E+03
+  0.55599E+03  0.73721E+03  0.10320E+04  0.15385E+04  0.24127E+04  0.39801E+04
+  0.68392E+04  0.12149E+05  0.22155E+05  0.44902E-09  0.34926E-09  0.12627E-09
+  0.51820E-09  0.13312E-08  0.28641E-08  0.19564E-07  0.39806E-07  0.16885E-07
+  0.13822E-06  0.27228E-06  0.20864E-04  0.12629E-03  0.28927E-04  0.54437E-03
+  0.89664E-03  0.14163E-02  0.20797E-02  0.28398E-02  0.39316E-02  0.53855E-02
+  0.74199E-02  0.98682E-02  0.13314E-01  0.17111E-01  0.23145E-01  0.29425E-01
+  0.38912E-01  0.49898E-01  0.66780E-01  0.86135E-01  0.11603E+00  0.15189E+00
+  0.15734E-08  0.13636E-08  0.92927E-09  0.14254E-09  0.85950E-09  0.28961E-08
+  0.24248E-07  0.53127E-07  0.26947E-07  0.19715E-06  0.32805E-06  0.27292E-04
+  0.16331E-03  0.36509E-04  0.69761E-03  0.11449E-02  0.18032E-02  0.26404E-02
+  0.35965E-02  0.49680E-02  0.67905E-02  0.93348E-02  0.12387E-01  0.16672E-01
+  0.21369E-01  0.28810E-01  0.36490E-01  0.48036E-01  0.61272E-01  0.81479E-01
+  0.10431E+00  0.13928E+00  0.18050E+00  0.42802E-08  0.41628E-08  0.34437E-08
+  0.28048E-08  0.12182E-08  0.11532E-08  0.28580E-07  0.75785E-07  0.28316E-07
+  0.25538E-06  0.60148E-06  0.35979E-04  0.21239E-03  0.45833E-04  0.89785E-03
+  0.14670E-02  0.23029E-02  0.33612E-02  0.45652E-02  0.62905E-02  0.85789E-02
+  0.11766E-01  0.15581E-01  0.20921E-01  0.26749E-01  0.35965E-01  0.45406E-01
+  0.59549E-01  0.75611E-01  0.10000E+00  0.12720E+00  0.16856E+00  0.21651E+00
+  0.10298E-07  0.11551E-07  0.10894E-07  0.11511E-07  0.87545E-08  0.62051E-08
+  0.45897E-07  0.10831E-06  0.13655E-07  0.14023E-06  0.90568E-06  0.51266E-04
+  0.27766E-03  0.56406E-04  0.11606E-02  0.18868E-02  0.29504E-02  0.42905E-02
+  0.58079E-02  0.79805E-02  0.10857E-01  0.14855E-01  0.19629E-01  0.26297E-01
+  0.33549E-01  0.44994E-01  0.56648E-01  0.74049E-01  0.93661E-01  0.12331E+00
+  0.15599E+00  0.20537E+00  0.26179E+00  0.23949E-07  0.26336E-07  0.29120E-07
+  0.33041E-07  0.38243E-07  0.30806E-07  0.68524E-07  0.25133E-06  0.38023E-06
+  0.64376E-06  0.59529E-06  0.75667E-04  0.36523E-03  0.67449E-04  0.15080E-02
+  0.24372E-02  0.37944E-02  0.54937E-02  0.74085E-02  0.10147E-01  0.13767E-01
+  0.18785E-01  0.24767E-01  0.33106E-01  0.42145E-01  0.56393E-01  0.70824E-01
+  0.92312E-01  0.11639E+00  0.15263E+00  0.19220E+00  0.25164E+00  0.31868E+00
+  0.52075E-07  0.60823E-07  0.66315E-07  0.89238E-07  0.10935E-06  0.12047E-06
+  0.33864E-07  0.40188E-06  0.17541E-05  0.32795E-05  0.22851E-05  0.10903E-03
+  0.44947E-03  0.75261E-04  0.19695E-02  0.31625E-02  0.48989E-02  0.70576E-02
+  0.94746E-02  0.12930E-01  0.17486E-01  0.23789E-01  0.31291E-01  0.41724E-01
+  0.53004E-01  0.70764E-01  0.88673E-01  0.11528E+00  0.14494E+00  0.18944E+00
+  0.23763E+00  0.30967E+00  0.38998E+00  0.11434E-06  0.13041E-06  0.14374E-06
+  0.18114E-06  0.29999E-06  0.36947E-06  0.28234E-06  0.36888E-06  0.54124E-05
+  0.98150E-05  0.11032E-04  0.14135E-03  0.52868E-03  0.64449E-04  0.25839E-02
+  0.41204E-02  0.63487E-02  0.90952E-02  0.12147E-01  0.16507E-01  0.22246E-01
+  0.30158E-01  0.39565E-01  0.52618E-01  0.66694E-01  0.88848E-01  0.11109E+00
+  0.14409E+00  0.18071E+00  0.23551E+00  0.29445E+00  0.38217E+00  0.47906E+00
+  0.26004E-06  0.29400E-06  0.31313E-06  0.34299E-06  0.52282E-06  0.10025E-05
+  0.18458E-05  0.15538E-05  0.13943E-04  0.24738E-04  0.31003E-04  0.16883E-03
+  0.62684E-03  0.21863E-04  0.31097E-02  0.53830E-02  0.82503E-02  0.11749E-01
+  0.15599E-01  0.21099E-01  0.28321E-01  0.38246E-01  0.50025E-01  0.66343E-01
+  0.83886E-01  0.11150E+00  0.13912E+00  0.18003E+00  0.22528E+00  0.29287E+00
+  0.36509E+00  0.47227E+00  0.58963E+00  0.65572E-06  0.86739E-06  0.82665E-06
+  0.83709E-06  0.86235E-06  0.18988E-05  0.58765E-05  0.11896E-04  0.34686E-04
+  0.57252E-04  0.75230E-04  0.18019E-03  0.70042E-03  0.12659E-03  0.33479E-02
+  0.64620E-02  0.10713E-01  0.15171E-01  0.20015E-01  0.26938E-01  0.36005E-01
+  0.48412E-01  0.63126E-01  0.83446E-01  0.10525E+00  0.13957E+00  0.17375E+00
+  0.22434E+00  0.28015E+00  0.36335E+00  0.45184E+00  0.58274E+00  0.72511E+00
+  0.14501E-05  0.20910E-05  0.28446E-05  0.27023E-05  0.22607E-05  0.24012E-05
+  0.11888E-04  0.36422E-04  0.82128E-04  0.12254E-03  0.16092E-03  0.15906E-03
+  0.72568E-03  0.43194E-03  0.35971E-02  0.67880E-02  0.12887E-01  0.19557E-01
+  0.25631E-01  0.34323E-01  0.45674E-01  0.61119E-01  0.79425E-01  0.10462E+00
+  0.13157E+00  0.17407E+00  0.21619E+00  0.27849E+00  0.34707E+00  0.44919E+00
+  0.55732E+00  0.71688E+00  0.88946E+00  0.30243E-05  0.55358E-05  0.95894E-05
+  0.13238E-04  0.13557E-04  0.95787E-05  0.12591E-04  0.77410E-04  0.17266E-03
+  0.25715E-03  0.33189E-03  0.59797E-04  0.62930E-03  0.10010E-02  0.37036E-02
+  0.70109E-02  0.13174E-01  0.23461E-01  0.32504E-01  0.43350E-01  0.57466E-01
+  0.76529E-01  0.99124E-01  0.13008E+00  0.16308E+00  0.21524E+00  0.26666E+00
+  0.34267E+00  0.42622E+00  0.55051E+00  0.68162E+00  0.87467E+00  0.10825E+01
+  0.10890E-04  0.19361E-04  0.39476E-04  0.78257E-04  0.10460E-03  0.10507E-03
+  0.84955E-04  0.14381E-03  0.33953E-03  0.51933E-03  0.67937E-03  0.25384E-03
+  0.28811E-03  0.20444E-02  0.34381E-02  0.68266E-02  0.13017E-01  0.23328E-01
+  0.38353E-01  0.53659E-01  0.71015E-01  0.94201E-01  0.12171E+00  0.15915E+00
+  0.19891E+00  0.26200E+00  0.32371E+00  0.41493E+00  0.51511E+00  0.66406E+00
+  0.82063E+00  0.10507E+01  0.12974E+01  0.77609E-04  0.12233E-03  0.17769E-03
+  0.25371E-03  0.37942E-03  0.46812E-03  0.47591E-03  0.48088E-03  0.73182E-03
+  0.10513E-02  0.13859E-02  0.10180E-02  0.75378E-03  0.40658E-02  0.24247E-02
+  0.56349E-02  0.11679E-01  0.21742E-01  0.35959E-01  0.61119E-01  0.84280E-01
+  0.11173E+00  0.14441E+00  0.18841E+00  0.23490E+00  0.30917E+00  0.38098E+00
+  0.48710E+00  0.60375E+00  0.77710E+00  0.95863E+00  0.12247E+01  0.15093E+01
+  0.35562E-03  0.55409E-03  0.77513E-03  0.95669E-03  0.11363E-02  0.13113E-02
+  0.14127E-02  0.14770E-02  0.18271E-02  0.25013E-02  0.28172E-02  0.25709E-02
+  0.31177E-02  0.77501E-02  0.00000E+00  0.27786E-02  0.82067E-02  0.17522E-01
+  0.30174E-01  0.52910E-01  0.90881E-01  0.12438E+00  0.16189E+00  0.21151E+00
+  0.26353E+00  0.34758E+00  0.42732E+00  0.54524E+00  0.67513E+00  0.86817E+00
+  0.10694E+01  0.13634E+01  0.16773E+01  0.12041E-02  0.15557E-02  0.18959E-02
+  0.22307E-02  0.25681E-02  0.28876E-02  0.31765E-02  0.34461E-02  0.39068E-02
+  0.48619E-02  0.65009E-02  0.52805E-02  0.69014E-02  0.13314E-01  0.54212E-02
+  0.28179E-02  0.26311E-02  0.10671E-01  0.21276E-01  0.41000E-01  0.74122E-01
+  0.12833E+00  0.17198E+00  0.22628E+00  0.28250E+00  0.37488E+00  0.46010E+00
+  0.58622E+00  0.72568E+00  0.93296E+00  0.11478E+01  0.14604E+01  0.17938E+01
+  0.22864E-02  0.30825E-02  0.37589E-02  0.44389E-02  0.50765E-02  0.56172E-02
+  0.61057E-02  0.66883E-02  0.75147E-02  0.83984E-02  0.10387E-01  0.12500E-01
+  0.12589E-01  0.21285E-01  0.12955E-01  0.12031E-01  0.75911E-02  0.13944E-02
+  0.94183E-02  0.25976E-01  0.54133E-01  0.99173E-01  0.17269E+00  0.23111E+00
+  0.29051E+00  0.39025E+00  0.47861E+00  0.60943E+00  0.75502E+00  0.97145E+00
+  0.11941E+01  0.15162E+01  0.18597E+01  0.49875E-02  0.64037E-02  0.78568E-02
+  0.90283E-02  0.10136E-01  0.11096E-01  0.11807E-01  0.12949E-01  0.14468E-01
+  0.15853E-01  0.17624E-01  0.18626E-01  0.22605E-01  0.34621E-01  0.25814E-01
+  0.27406E-01  0.26483E-01  0.22086E-01  0.17486E-01  0.00000E+00  0.20604E-01
+  0.52548E-01  0.10739E+00  0.19233E+00  0.24958E+00  0.34933E+00  0.43112E+00
+  0.55209E+00  0.68861E+00  0.89160E+00  0.10976E+01  0.13919E+01  0.17067E+01
+  0.11377E-01  0.13166E-01  0.15484E-01  0.17853E-01  0.19734E-01  0.21405E-01
+  0.22603E-01  0.23652E-01  0.26644E-01  0.28790E-01  0.31450E-01  0.31544E-01
+  0.49032E-01  0.54909E-01  0.45006E-01  0.49536E-01  0.52594E-01  0.54152E-01
+  0.59507E-01  0.56604E-01  0.41288E-01  0.12283E-01  0.27736E-01  0.80276E-01
+  0.15011E+00  0.24439E+00  0.31093E+00  0.40869E+00  0.52237E+00  0.69103E+00
+  0.85754E+00  0.10891E+01  0.13390E+01  0.22619E-01  0.27113E-01  0.29785E-01
+  0.33246E-01  0.36714E-01  0.39311E-01  0.41376E-01  0.43505E-01  0.46904E-01
+  0.50687E-01  0.54595E-01  0.54772E-01  0.66834E-01  0.91116E-01  0.75975E-01
+  0.84378E-01  0.92590E-01  0.10174E+00  0.11963E+00  0.13468E+00  0.14659E+00
+  0.16057E+00  0.15936E+00  0.14881E+00  0.13564E+00  0.00000E+00  0.34625E-01
+  0.83084E-01  0.14666E+00  0.23953E+00  0.32170E+00  0.42208E+00  0.53545E+00
+  0.40137E-01  0.50990E-01  0.60381E-01  0.64099E-01  0.68899E-01  0.73660E-01
+  0.76727E-01  0.79850E-01  0.84976E-01  0.90456E-01  0.96052E-01  0.96283E-01
+  0.11122E+00  0.14792E+00  0.13311E+00  0.14265E+00  0.15820E+00  0.17800E+00
+  0.21321E+00  0.25257E+00  0.30068E+00  0.37077E+00  0.45535E+00  0.58114E+00
+  0.77254E+00  0.95435E+00  0.12896E+01  0.14532E+01  0.16367E+01  0.18364E+01
+  0.21734E+01  0.26545E+01  0.32500E+01  0.66705E-01  0.84587E-01  0.10745E+00
+  0.12640E+00  0.13154E+00  0.13816E+00  0.14433E+00  0.14917E+00  0.15753E+00
+  0.16562E+00  0.17394E+00  0.17432E+00  0.19676E+00  0.24250E+00  0.23320E+00
+  0.25485E+00  0.27472E+00  0.31135E+00  0.37320E+00  0.44954E+00  0.55176E+00
+  0.70411E+00  0.91234E+00  0.12299E+01  0.17270E+01  0.23502E+01  0.34568E+01
+  0.48284E+01  0.57261E+01  0.68336E+01  0.83583E+01  0.10374E+02  0.12927E+02
+  0.10988E+00  0.13912E+00  0.17641E+00  0.22411E+00  0.26264E+00  0.27028E+00
+  0.27917E+00  0.28862E+00  0.29963E+00  0.31116E+00  0.32500E+00  0.32584E+00
+  0.36056E+00  0.42783E+00  0.40581E+00  0.54398E+00  0.49016E+00  0.55444E+00
+  0.65895E+00  0.79394E+00  0.98066E+00  0.12590E+01  0.16536E+01  0.22544E+01
+  0.31892E+01  0.44961E+01  0.66096E+01  0.98711E+01  0.13835E+02  0.16681E+02
+  0.20471E+02  0.25405E+02  0.31686E+02  0.16689E+00  0.21105E+00  0.26722E+00
+  0.33885E+00  0.43047E+00  0.50337E+00  0.51316E+00  0.52626E+00  0.54514E+00
+  0.55971E+00  0.57797E+00  0.57803E+00  0.62735E+00  0.72402E+00  0.69164E+00
+  0.74588E+00  0.81420E+00  0.90908E+00  0.10615E+01  0.12604E+01  0.15374E+01
+  0.19481E+01  0.25336E+01  0.34191E+01  0.47827E+01  0.67384E+01  0.99014E+01
+  0.14643E+02  0.22001E+02  0.30635E+02  0.37436E+02  0.46262E+02  0.57515E+02
+  0.25463E+00  0.32167E+00  0.40678E+00  0.51504E+00  0.65311E+00  0.82968E+00
+  0.96788E+00  0.98754E+00  0.10205E+01  0.10507E+01  0.10782E+01  0.10778E+01
+  0.11521E+01  0.12958E+01  0.12506E+01  0.13342E+01  0.14410E+01  0.15900E+01
+  0.18248E+01  0.21340E+01  0.25653E+01  0.31988E+01  0.41025E+01  0.54556E+01
+  0.75142E+01  0.10495E+02  0.15261E+02  0.22517E+02  0.33466E+02  0.50529E+02
+  0.70175E+02  0.86202E+02  0.10668E+03  0.37675E+00  0.47551E+00  0.60069E+00
+  0.75962E+00  0.96182E+00  0.12196E+01  0.15462E+01  0.18049E+01  0.18533E+01
+  0.19056E+01  0.19612E+01  0.19579E+01  0.20649E+01  0.22761E+01  0.22058E+01
+  0.23271E+01  0.24829E+01  0.27011E+01  0.30424E+01  0.34917E+01  0.41164E+01
+  0.50256E+01  0.63156E+01  0.82258E+01  0.11096E+02  0.15249E+02  0.21779E+02
+  0.31770E+02  0.46987E+02  0.70054E+02  0.10651E+03  0.14662E+03  0.18029E+03
+  0.56904E+00  0.71766E+00  0.90575E+00  0.11442E+01  0.14470E+01  0.18320E+01
+  0.23191E+01  0.29418E+01  0.34525E+01  0.35302E+01  0.36285E+01  0.36499E+01
+  0.38085E+01  0.41251E+01  0.40173E+01  0.41988E+01  0.44331E+01  0.47619E+01
+  0.52716E+01  0.59418E+01  0.68692E+01  0.82053E+01  0.10087E+02  0.12840E+02
+  0.16921E+02  0.22800E+02  0.31895E+02  0.45687E+02  0.66833E+02  0.99034E+02
+  0.14850E+03  0.22649E+03  0.30822E+03  0.86619E+00  0.10915E+01  0.13765E+01
+  0.17372E+01  0.21946E+01  0.27752E+01  0.35089E+01  0.44441E+01  0.56622E+01
+  0.66220E+01  0.67691E+01  0.68272E+01  0.71198E+01  0.75990E+01  0.74322E+01
+  0.77061E+01  0.80611E+01  0.85600E+01  0.93268E+01  0.10333E+02  0.11718E+02
+  0.13692E+02  0.16449E+02  0.20432E+02  0.26257E+02  0.34585E+02  0.47263E+02
+  0.66287E+02  0.95190E+02  0.13957E+03  0.20761E+03  0.31216E+03  0.47660E+03
+  0.13178E+01  0.16593E+01  0.20910E+01  0.26369E+01  0.33282E+01  0.42043E+01
+  0.53105E+01  0.67172E+01  0.85385E+01  0.10848E+02  0.12683E+02  0.12764E+02
+  0.13362E+02  0.14090E+02  0.13827E+02  0.14238E+02  0.14773E+02  0.15526E+02
+  0.16678E+02  0.18184E+02  0.20244E+02  0.23155E+02  0.27183E+02  0.32930E+02
+  0.41219E+02  0.52960E+02  0.70553E+02  0.96643E+02  0.13586E+03  0.19550E+03
+  0.28775E+03  0.42872E+03  0.64530E+03  0.19952E+01  0.25104E+01  0.31608E+01
+  0.39832E+01  0.50233E+01  0.63398E+01  0.80010E+01  0.10109E+02  0.12826E+02
+  0.16265E+02  0.20659E+02  0.23843E+02  0.24834E+02  0.26144E+02  0.25717E+02
+  0.26329E+02  0.27126E+02  0.28250E+02  0.29966E+02  0.32203E+02  0.35249E+02
+  0.39515E+02  0.45367E+02  0.53619E+02  0.65366E+02  0.81827E+02  0.10611E+03
+  0.14167E+03  0.19448E+03  0.27394E+03  0.39552E+03  0.58339E+03  0.86946E+03
+  0.30591E+01  0.38457E+01  0.48386E+01  0.60924E+01  0.76778E+01  0.96819E+01
+  0.12210E+02  0.15414E+02  0.19524E+02  0.24722E+02  0.31345E+02  0.39390E+02
+  0.46744E+02  0.48978E+02  0.48656E+02  0.49581E+02  0.50789E+02  0.52496E+02
+  0.55095E+02  0.58474E+02  0.63051E+02  0.69414E+02  0.78070E+02  0.90142E+02
+  0.10711E+03  0.13063E+03  0.16480E+03  0.21417E+03  0.28654E+03  0.39413E+03
+  0.55684E+03  0.80566E+03  0.11896E+04  0.46246E+01  0.58080E+01  0.73014E+01
+  0.91867E+01  0.11568E+02  0.14577E+02  0.18370E+02  0.23171E+02  0.29312E+02
+  0.37070E+02  0.46932E+02  0.58974E+02  0.87063E+02  0.90430E+02  0.90368E+02
+  0.92339E+02  0.94123E+02  0.96654E+02  0.10052E+03  0.10553E+03  0.11229E+03
+  0.12164E+03  0.13426E+03  0.15169E+03  0.17592E+03  0.20912E+03  0.25668E+03
+  0.32447E+03  0.42251E+03  0.56638E+03  0.78121E+03  0.11059E+04  0.16020E+04
+  0.70986E+01  0.89052E+01  0.11184E+02  0.14060E+02  0.17690E+02  0.22275E+02
+  0.28054E+02  0.35361E+02  0.44681E+02  0.56446E+02  0.71376E+02  0.89700E+02
+  0.14364E+03  0.17029E+03  0.17009E+03  0.17415E+03  0.17789E+03  0.18172E+03
+  0.18757E+03  0.19514E+03  0.20533E+03  0.21934E+03  0.23813E+03  0.26386E+03
+  0.29925E+03  0.34723E+03  0.41504E+03  0.51040E+03  0.64645E+03  0.84339E+03
+  0.11335E+04  0.15666E+04  0.22208E+04  0.10818E+02  0.13553E+02  0.17002E+02
+  0.21352E+02  0.26843E+02  0.33774E+02  0.42509E+02  0.53545E+02  0.67588E+02
+  0.85306E+02  0.10776E+03  0.13543E+03  0.21633E+03  0.28130E+03  0.31883E+03
+  0.32486E+03  0.33275E+03  0.34023E+03  0.34901E+03  0.36034E+03  0.37555E+03
+  0.39639E+03  0.42420E+03  0.46200E+03  0.51351E+03  0.58269E+03  0.67923E+03
+  0.81328E+03  0.10020E+04  0.12714E+04  0.16628E+04  0.22392E+04  0.30991E+04
+  0.33487E-09  0.33117E-09  0.10029E-09  0.77479E-09  0.18109E-08  0.44772E-08
+  0.29795E-07  0.63613E-07  0.19481E-06  0.30634E-06  0.59741E-06  0.33715E-05
+  0.23785E-04  0.10671E-03  0.46223E-03  0.14013E-02  0.33862E-02  0.67723E-02
+  0.11879E-01  0.18821E-01  0.30828E-01  0.47848E-01  0.75131E-01  0.11233E+00
+  0.15812E+00  0.21715E+00  0.29548E+00  0.40395E+00  0.54872E+00  0.76033E+00
+  0.10505E+01  0.14677E+01  0.20783E+01  0.13756E-08  0.10169E-08  0.13762E-08
+  0.78887E-09  0.40394E-09  0.30561E-08  0.38470E-07  0.82210E-07  0.26201E-06
+  0.36906E-06  0.84945E-06  0.72270E-05  0.30200E-04  0.13534E-03  0.58593E-03
+  0.17745E-02  0.42821E-02  0.85529E-02  0.14984E-01  0.23713E-01  0.38796E-01
+  0.60139E-01  0.94301E-01  0.14076E+00  0.19773E+00  0.27085E+00  0.36737E+00
+  0.50018E+00  0.67601E+00  0.93077E+00  0.12759E+01  0.17659E+01  0.24729E+01
+  0.33392E-08  0.36394E-08  0.29491E-08  0.40749E-08  0.36884E-08  0.10806E-08
+  0.51218E-07  0.10896E-06  0.30440E-06  0.41991E-06  0.13349E-05  0.12206E-04
+  0.60313E-04  0.17180E-03  0.74357E-03  0.22497E-02  0.54210E-02  0.10812E-01
+  0.18917E-01  0.29899E-01  0.48861E-01  0.75655E-01  0.11848E+00  0.17660E+00
+  0.24766E+00  0.33851E+00  0.45792E+00  0.62139E+00  0.83628E+00  0.11454E+01
+  0.15597E+01  0.21413E+01  0.29695E+01  0.87356E-08  0.90112E-08  0.10279E-07
+  0.10437E-07  0.13690E-07  0.13979E-07  0.51498E-07  0.13984E-06  0.40212E-06
+  0.72486E-06  0.24580E-05  0.19029E-04  0.10350E-03  0.23879E-03  0.94289E-03
+  0.28525E-02  0.68653E-02  0.13674E-01  0.23889E-01  0.37709E-01  0.61560E-01
+  0.95212E-01  0.14896E+00  0.22175E+00  0.31050E+00  0.42365E+00  0.57182E+00
+  0.77383E+00  0.10378E+01  0.14151E+01  0.19163E+01  0.26130E+01  0.35934E+01
+  0.13465E-07  0.22341E-07  0.23576E-07  0.27194E-07  0.35668E-07  0.40290E-07
+  0.42412E-07  0.17894E-06  0.55979E-06  0.13541E-05  0.45467E-05  0.38754E-04
+  0.15795E-03  0.33723E-03  0.11601E-02  0.36177E-02  0.86990E-02  0.17302E-01
+  0.30180E-01  0.47574E-01  0.77585E-01  0.11987E+00  0.18735E+00  0.27859E+00
+  0.38959E+00  0.53074E+00  0.71502E+00  0.96540E+00  0.12909E+01  0.17539E+01
+  0.23645E+01  0.32057E+01  0.43769E+01  0.32814E-07  0.34200E-07  0.57447E-07
+  0.62513E-07  0.78406E-07  0.93751E-07  0.65343E-08  0.12782E-06  0.85204E-06
+  0.18291E-05  0.74682E-05  0.62503E-04  0.20189E-03  0.45740E-03  0.13735E-02
+  0.44486E-02  0.11016E-01  0.21889E-01  0.38121E-01  0.60005E-01  0.97766E-01
+  0.15090E+00  0.23564E+00  0.35006E+00  0.48894E+00  0.66519E+00  0.89473E+00
+  0.12057E+01  0.16084E+01  0.21788E+01  0.29261E+01  0.39480E+01  0.53587E+01
+  0.45262E-07  0.81169E-07  0.87178E-07  0.13912E-06  0.16750E-06  0.20440E-06
+  0.12477E-06  0.15672E-07  0.91118E-06  0.32840E-05  0.10492E-04  0.87165E-04
+  0.24324E-03  0.54169E-03  0.16273E-02  0.48717E-02  0.13921E-01  0.27655E-01
+  0.48097E-01  0.75606E-01  0.12309E+00  0.18981E+00  0.29620E+00  0.43965E+00
+  0.61343E+00  0.83350E+00  0.11195E+01  0.15062E+01  0.20053E+01  0.27096E+01
+  0.36277E+01  0.48754E+01  0.65845E+01  0.87038E-07  0.11637E-06  0.18124E-06
+  0.24782E-06  0.36792E-06  0.45918E-06  0.32827E-06  0.39993E-06  0.53493E-06
+  0.33705E-05  0.11208E-04  0.90505E-04  0.25274E-03  0.58442E-03  0.18239E-02
+  0.53527E-02  0.14546E-01  0.34818E-01  0.60506E-01  0.95015E-01  0.15466E+00
+  0.23834E+00  0.37175E+00  0.55141E+00  0.76859E+00  0.10431E+01  0.13994E+01
+  0.18800E+01  0.24986E+01  0.33695E+01  0.44994E+01  0.60272E+01  0.81071E+01
+  0.17262E-06  0.23337E-06  0.32930E-06  0.55653E-06  0.89071E-06  0.13617E-05
+  0.12322E-05  0.82789E-06  0.89481E-06  0.28004E-05  0.29483E-05  0.59513E-04
+  0.21513E-03  0.53677E-03  0.18489E-02  0.57345E-02  0.15084E-01  0.36966E-01
+  0.75562E-01  0.11866E+00  0.19334E+00  0.29793E+00  0.46483E+00  0.68924E+00
+  0.95984E+00  0.13013E+01  0.17437E+01  0.23398E+01  0.31049E+01  0.41803E+01
+  0.55699E+01  0.74409E+01  0.99743E+01  0.37953E-06  0.50111E-06  0.61425E-06
+  0.96824E-06  0.18930E-05  0.29952E-05  0.42486E-05  0.34746E-05  0.21261E-05
+  0.14554E-04  0.54721E-04  0.24699E-04  0.93644E-04  0.36234E-03  0.16652E-02
+  0.56226E-02  0.15482E-01  0.37115E-01  0.82509E-01  0.14695E+00  0.24009E+00
+  0.37032E+00  0.57842E+00  0.85780E+00  0.11937E+01  0.16167E+01  0.21637E+01
+  0.29002E+01  0.38433E+01  0.51672E+01  0.68724E+01  0.91605E+01  0.12245E+02
+  0.77939E-06  0.10419E-05  0.13973E-05  0.20751E-05  0.37786E-05  0.83442E-05
+  0.13843E-04  0.18998E-04  0.13573E-04  0.21205E-04  0.15669E-03  0.21406E-03
+  0.18788E-03  0.48491E-04  0.11024E-02  0.49829E-02  0.14532E-01  0.36415E-01
+  0.80074E-01  0.16539E+00  0.29400E+00  0.45484E+00  0.71260E+00  0.10580E+01
+  0.14716E+01  0.19912E+01  0.26623E+01  0.35650E+01  0.47179E+01  0.63362E+01
+  0.84136E+01  0.11193E+02  0.14928E+02  0.16276E-05  0.21266E-05  0.25372E-05
+  0.49145E-05  0.13180E-04  0.27038E-04  0.71904E-04  0.11995E-03  0.13965E-03
+  0.10929E-03  0.31922E-03  0.57908E-03  0.77357E-03  0.89980E-03  0.86839E-04
+  0.33536E-02  0.12261E-01  0.33066E-01  0.74596E-01  0.15564E+00  0.34039E+00
+  0.54679E+00  0.86256E+00  0.12848E+01  0.17874E+01  0.24169E+01  0.32278E+01
+  0.43186E+01  0.57081E+01  0.76599E+01  0.10157E+02  0.13490E+02  0.17955E+02
+  0.61370E-05  0.10090E-04  0.15421E-04  0.42641E-04  0.90819E-04  0.15982E-03
+  0.26210E-03  0.43430E-03  0.59414E-03  0.68287E-03  0.85268E-03  0.13525E-02
+  0.19483E-02  0.26350E-02  0.25404E-02  0.00000E+00  0.73441E-02  0.25768E-01
+  0.62603E-01  0.13641E+00  0.30846E+00  0.63021E+00  0.10094E+01  0.15152E+01
+  0.21116E+01  0.28548E+01  0.38096E+01  0.50941E+01  0.67234E+01  0.90194E+01
+  0.11944E+02  0.15841E+02  0.21048E+02  0.30897E-04  0.63429E-04  0.10778E-03
+  0.19434E-03  0.40460E-03  0.71015E-03  0.10368E-02  0.13343E-02  0.16478E-02
+  0.19762E-02  0.23560E-02  0.49396E-02  0.41987E-02  0.57855E-02  0.69838E-02
+  0.61102E-02  0.13597E-02  0.12878E-01  0.41711E-01  0.10317E+00  0.25541E+00
+  0.55179E+00  0.11208E+01  0.17096E+01  0.23940E+01  0.32396E+01  0.43214E+01
+  0.57779E+01  0.76147E+01  0.10219E+02  0.13513E+02  0.17898E+02  0.23747E+02
+  0.18044E-03  0.23106E-03  0.45969E-03  0.84673E-03  0.13343E-02  0.18756E-02
+  0.23805E-02  0.29721E-02  0.35247E-02  0.42831E-02  0.51491E-02  0.61924E-02
+  0.16599E-01  0.10789E-01  0.13566E-01  0.14975E-01  0.13547E-01  0.46712E-02
+  0.14844E-01  0.60265E-01  0.18893E+00  0.44299E+00  0.10140E+01  0.18609E+01
+  0.26270E+01  0.35627E+01  0.47522E+01  0.63567E+01  0.83630E+01  0.11233E+02
+  0.14835E+02  0.19624E+02  0.26001E+02  0.47830E-03  0.61059E-03  0.78364E-03
+  0.14853E-02  0.24900E-02  0.35721E-02  0.46454E-02  0.57211E-02  0.66520E-02
+  0.78621E-02  0.94461E-02  0.11153E-01  0.14490E-01  0.30475E-01  0.22676E-01
+  0.26619E-01  0.28887E-01  0.25758E-01  0.16060E-01  0.12817E-01  0.11476E+00
+  0.32755E+00  0.82561E+00  0.17633E+01  0.28156E+01  0.38319E+01  0.51132E+01
+  0.68456E+01  0.89881E+01  0.12092E+02  0.15947E+02  0.21067E+02  0.27875E+02
+  0.17643E-02  0.22477E-02  0.28760E-02  0.38970E-02  0.53373E-02  0.73730E-02
+  0.92211E-02  0.11134E-01  0.12780E-01  0.14573E-01  0.17401E-01  0.20359E-01
+  0.24343E-01  0.31784E-01  0.39232E-01  0.45358E-01  0.52928E-01  0.57901E-01
+  0.61757E-01  0.55256E-01  0.11066E-01  0.16262E+00  0.56711E+00  0.13343E+01
+  0.25699E+01  0.37639E+01  0.50372E+01  0.67670E+01  0.88632E+01  0.11975E+02
+  0.15767E+02  0.20799E+02  0.27486E+02  0.42227E-02  0.53674E-02  0.68477E-02
+  0.92306E-02  0.12002E-01  0.14591E-01  0.18136E-01  0.21090E-01  0.23988E-01
+  0.26860E-01  0.30056E-01  0.35589E-01  0.41532E-01  0.50183E-01  0.66330E-01
+  0.73090E-01  0.85689E-01  0.99721E-01  0.11849E+00  0.13611E+00  0.10701E+00
+  0.19119E-01  0.28181E+00  0.87898E+00  0.18024E+01  0.33174E+01  0.45477E+01
+  0.61590E+01  0.80430E+01  0.10962E+02  0.14406E+02  0.18973E+02  0.25038E+02
+  0.80836E-02  0.10255E-01  0.13050E-01  0.17524E-01  0.23649E-01  0.29196E-01
+  0.33309E-01  0.39078E-01  0.42976E-01  0.47662E-01  0.53310E-01  0.59694E-01
+  0.69060E-01  0.81320E-01  0.95956E-01  0.25372E+00  0.13469E+00  0.16017E+00
+  0.19747E+00  0.24441E+00  0.25942E+00  0.24580E+00  0.66102E-01  0.32569E+00
+  0.89611E+00  0.17891E+01  0.31627E+01  0.44078E+01  0.57355E+01  0.80305E+01
+  0.10530E+02  0.13843E+02  0.18240E+02  0.14382E-01  0.18214E-01  0.23132E-01
+  0.30964E-01  0.41618E-01  0.56224E-01  0.65229E-01  0.71708E-01  0.79332E-01
+  0.86127E-01  0.93963E-01  0.10446E+00  0.11687E+00  0.13434E+00  0.15524E+00
+  0.18031E+00  0.81909E+00  0.25418E+00  0.31663E+00  0.40263E+00  0.47518E+00
+  0.55670E+00  0.52962E+00  0.40015E+00  0.28244E+00  0.15537E+00  0.00000E+00
+  0.40384E+00  0.52317E+00  0.13626E+01  0.17819E+01  0.23375E+01  0.30745E+01
+  0.23959E-01  0.30300E-01  0.38414E-01  0.51288E-01  0.68705E-01  0.92420E-01
+  0.12455E+00  0.13670E+00  0.14621E+00  0.15834E+00  0.17063E+00  0.18631E+00
+  0.20466E+00  0.23017E+00  0.26078E+00  0.29810E+00  0.34778E+00  0.10404E+01
+  0.51388E+00  0.65801E+00  0.81527E+00  0.10342E+01  0.12243E+01  0.14617E+01
+  0.19786E+01  0.29403E+01  0.45817E+01  0.72079E+01  0.10729E+02  0.13043E+02
+  0.17000E+02  0.22243E+02  0.29195E+02  0.39552E-01  0.49959E-01  0.63244E-01
+  0.84260E-01  0.11256E+00  0.15089E+00  0.20257E+00  0.27175E+00  0.28329E+00
+  0.30115E+00  0.32127E+00  0.34226E+00  0.37169E+00  0.41006E+00  0.45626E+00
+  0.51338E+00  0.59060E+00  0.70356E+00  0.11173E+01  0.10901E+01  0.13779E+01
+  0.18045E+01  0.23181E+01  0.30918E+01  0.45203E+01  0.70225E+01  0.11320E+02
+  0.18242E+02  0.30554E+02  0.42316E+02  0.54929E+02  0.71644E+02  0.93801E+02
+  0.60204E-01  0.75958E-01  0.96041E-01  0.12772E+00  0.17024E+00  0.22755E+00
+  0.30449E+00  0.40958E+00  0.52276E+00  0.54481E+00  0.57513E+00  0.60537E+00
+  0.64416E+00  0.69847E+00  0.76326E+00  0.84322E+00  0.95166E+00  0.10997E+01
+  0.13265E+01  0.16586E+01  0.20815E+01  0.27184E+01  0.35484E+01  0.48373E+01
+  0.71312E+01  0.11074E+02  0.17802E+02  0.28915E+02  0.47911E+02  0.79048E+02
+  0.10728E+03  0.13939E+03  0.18194E+03  0.92074E-01  0.11604E+00  0.14655E+00
+  0.19458E+00  0.25886E+00  0.34518E+00  0.46072E+00  0.61755E+00  0.82928E+00
+  0.10153E+01  0.10605E+01  0.11174E+01  0.11772E+01  0.12581E+01  0.13543E+01
+  0.14734E+01  0.16356E+01  0.18585E+01  0.21984E+01  0.26958E+01  0.33484E+01
+  0.43380E+01  0.56956E+01  0.78285E+01  0.11512E+02  0.17735E+02  0.28234E+02
+  0.45767E+02  0.75566E+02  0.12411E+03  0.20871E+03  0.27041E+03  0.35166E+03
+  0.13657E+00  0.17194E+00  0.21691E+00  0.28758E+00  0.38196E+00  0.50832E+00
+  0.67700E+00  0.90480E+00  0.12110E+01  0.16339E+01  0.19105E+01  0.19922E+01
+  0.21038E+01  0.22205E+01  0.23581E+01  0.25277E+01  0.27591E+01  0.30777E+01
+  0.35618E+01  0.42672E+01  0.52017E+01  0.66164E+01  0.85930E+01  0.11697E+02
+  0.16950E+02  0.25699E+02  0.40296E+02  0.64548E+02  0.10610E+03  0.17366E+03
+  0.28916E+03  0.46541E+03  0.60250E+03  0.20686E+00  0.26015E+00  0.32782E+00
+  0.43409E+00  0.57566E+00  0.76486E+00  0.10168E+01  0.13558E+01  0.18097E+01
+  0.24319E+01  0.32851E+01  0.36570E+01  0.38249E+01  0.40416E+01  0.42441E+01
+  0.44935E+01  0.48341E+01  0.53037E+01  0.60139E+01  0.70433E+01  0.84156E+01
+  0.10483E+02  0.13401E+02  0.17957E+02  0.25516E+02  0.37916E+02  0.58355E+02
+  0.92061E+02  0.14919E+03  0.24435E+03  0.40324E+03  0.67290E+03  0.10346E+04
+  0.31586E+00  0.39676E+00  0.49943E+00  0.66043E+00  0.87470E+00  0.11604E+01
+  0.15405E+01  0.20499E+01  0.27304E+01  0.36570E+01  0.49188E+01  0.66342E+01
+  0.70594E+01  0.74061E+01  0.77740E+01  0.81449E+01  0.86519E+01  0.93515E+01
+  0.10405E+02  0.11922E+02  0.13950E+02  0.16983E+02  0.21276E+02  0.27919E+02
+  0.38733E+02  0.56195E+02  0.84597E+02  0.13100E+03  0.20877E+03  0.33780E+03
+  0.55823E+03  0.92090E+03  0.15403E+04  0.48238E+00  0.60513E+00  0.76080E+00
+  0.10048E+01  0.13290E+01  0.17608E+01  0.23342E+01  0.31012E+01  0.41233E+01
+  0.55075E+01  0.73819E+01  0.99160E+01  0.13113E+02  0.13628E+02  0.14256E+02
+  0.14898E+02  0.15652E+02  0.16694E+02  0.18256E+02  0.20494E+02  0.23481E+02
+  0.27913E+02  0.34176E+02  0.43762E+02  0.59084E+02  0.83429E+02  0.12247E+03
+  0.18553E+03  0.28996E+03  0.46213E+03  0.75371E+03  0.12451E+04  0.20595E+04
+  0.73362E+00  0.91889E+00  0.11537E+01  0.15215E+01  0.20099E+01  0.26593E+01
+  0.35212E+01  0.46714E+01  0.62016E+01  0.82652E+01  0.11046E+02  0.14790E+02
+  0.19894E+02  0.25130E+02  0.26054E+02  0.27230E+02  0.28443E+02  0.29982E+02
+  0.32287E+02  0.35572E+02  0.39944E+02  0.46381E+02  0.55432E+02  0.69129E+02
+  0.90648E+02  0.12429E+03  0.17741E+03  0.26213E+03  0.40063E+03  0.62703E+03
+  0.10068E+04  0.16468E+04  0.27198E+04  0.11310E+01  0.14141E+01  0.17727E+01
+  0.23340E+01  0.30790E+01  0.40686E+01  0.53809E+01  0.71292E+01  0.94527E+01
+  0.12574E+02  0.16766E+02  0.22388E+02  0.30008E+02  0.40422E+02  0.48582E+02
+  0.50332E+02  0.52747E+02  0.55102E+02  0.58563E+02  0.63475E+02  0.69990E+02
+  0.79511E+02  0.92820E+02  0.11273E+03  0.14348E+03  0.19076E+03  0.26424E+03
+  0.37980E+03  0.56603E+03  0.86738E+03  0.13674E+04  0.22032E+04  0.36145E+04
+  0.17214E+01  0.21474E+01  0.26872E+01  0.35315E+01  0.46514E+01  0.61379E+01
+  0.81083E+01  0.10729E+02  0.14209E+02  0.18871E+02  0.25112E+02  0.33459E+02
+  0.44718E+02  0.60007E+02  0.80668E+02  0.92367E+02  0.95892E+02  0.10057E+03
+  0.10568E+03  0.11290E+03  0.12245E+03  0.13631E+03  0.15557E+03  0.18406E+03
+  0.22742E+03  0.29301E+03  0.39333E+03  0.54872E+03  0.79541E+03  0.11898E+04
+  0.18365E+04  0.29070E+04  0.47002E+04  0.26643E+01  0.33148E+01  0.41389E+01
+  0.54276E+01  0.71359E+01  0.94022E+01  0.12405E+02  0.16395E+02  0.21689E+02
+  0.28761E+02  0.38211E+02  0.50818E+02  0.67759E+02  0.90649E+02  0.12144E+03
+  0.16312E+03  0.17840E+03  0.18569E+03  0.19537E+03  0.20622E+03  0.22050E+03
+  0.24113E+03  0.26960E+03  0.31131E+03  0.37385E+03  0.46701E+03  0.60722E+03
+  0.82103E+03  0.11551E+04  0.16821E+04  0.25348E+04  0.39307E+04  0.62474E+04
+  0.41017E+01  0.50865E+01  0.63342E+01  0.82846E+01  0.10870E+02  0.14297E+02
+  0.18836E+02  0.24864E+02  0.32854E+02  0.43511E+02  0.57722E+02  0.76647E+02
+  0.10200E+03  0.13611E+03  0.18184E+03  0.24342E+03  0.32730E+03  0.34203E+03
+  0.35784E+03  0.37692E+03  0.39812E+03  0.42859E+03  0.47042E+03  0.53116E+03
+  0.62110E+03  0.75316E+03  0.94884E+03  0.12425E+04  0.16940E+04  0.23959E+04
+  0.35154E+04  0.53254E+04  0.82970E+04  0.42502E-09  0.23618E-09  0.74597E-10
+  0.93428E-09  0.21243E-08  0.52980E-08  0.34959E-07  0.68113E-07  0.19794E-06
+  0.32798E-06  0.59580E-06  0.26500E-06  0.30553E-04  0.14771E-03  0.52596E-03
+  0.11572E-03  0.25531E-02  0.31455E-04  0.81043E-02  0.12848E-01  0.28874E-01
+  0.48443E-01  0.79499E-01  0.12598E+00  0.19494E+00  0.29146E+00  0.44702E+00
+  0.66942E+00  0.10349E+01  0.16032E+01  0.25404E+01  0.41307E+01  0.69063E+01
+  0.15042E-08  0.14618E-08  0.13591E-08  0.53286E-09  0.74153E-09  0.36933E-08
+  0.49816E-07  0.90470E-07  0.26147E-06  0.39950E-06  0.79020E-06  0.55053E-06
+  0.38868E-04  0.18769E-03  0.66699E-03  0.14252E-03  0.32263E-02  0.29232E-04
+  0.10216E-01  0.16178E-01  0.36270E-01  0.60750E-01  0.99478E-01  0.15720E+00
+  0.24234E+00  0.36051E+00  0.54928E+00  0.81549E+00  0.12470E+01  0.19059E+01
+  0.29726E+01  0.47472E+01  0.77857E+01  0.35179E-08  0.41422E-08  0.44624E-08
+  0.40917E-08  0.32895E-08  0.00000E+00  0.61297E-07  0.12042E-06  0.30742E-06
+  0.47697E-06  0.11639E-05  0.81423E-06  0.77383E-04  0.23892E-03  0.84694E-03
+  0.17311E-03  0.40801E-02  0.17215E-04  0.12885E-01  0.20381E-01  0.45592E-01
+  0.76251E-01  0.12464E+00  0.19650E+00  0.30199E+00  0.44740E+00  0.67794E+00
+  0.99926E+00  0.15139E+01  0.22869E+01  0.35163E+01  0.55228E+01  0.88916E+01
+  0.83003E-08  0.96989E-08  0.11990E-07  0.12751E-07  0.13581E-07  0.11936E-07
+  0.66825E-07  0.16679E-06  0.42140E-06  0.79435E-06  0.18816E-05  0.95996E-06
+  0.13117E-03  0.33532E-03  0.10752E-02  0.20262E-03  0.51584E-02  0.21835E-04
+  0.16247E-01  0.25671E-01  0.57308E-01  0.95732E-01  0.15626E+00  0.24588E+00
+  0.37692E+00  0.55652E+00  0.83952E+00  0.12301E+01  0.18490E+01  0.27651E+01
+  0.41986E+01  0.64961E+01  0.10280E+02  0.16099E-07  0.21457E-07  0.25660E-07
+  0.31311E-07  0.35232E-07  0.37492E-07  0.64991E-07  0.20364E-06  0.59073E-06
+  0.14253E-05  0.39321E-05  0.66081E-06  0.19992E-03  0.47834E-03  0.13257E-02
+  0.22440E-03  0.65195E-02  0.11101E-03  0.20480E-01  0.32325E-01  0.72020E-01
+  0.12019E+00  0.19595E+00  0.30786E+00  0.47097E+00  0.69345E+00  0.10422E+01
+  0.15195E+01  0.22692E+01  0.33649E+01  0.50544E+01  0.77167E+01  0.12020E+02
+  0.30793E-07  0.41145E-07  0.55573E-07  0.65914E-07  0.82842E-07  0.92818E-07
+  0.24302E-07  0.17183E-06  0.89223E-06  0.18695E-05  0.71351E-05  0.33444E-05
+  0.25683E-03  0.65815E-03  0.15713E-02  0.21229E-03  0.82231E-02  0.30940E-03
+  0.25779E-01  0.40652E-01  0.90419E-01  0.15079E+00  0.24560E+00  0.38540E+00
+  0.58863E+00  0.86472E+00  0.12958E+01  0.18815E+01  0.27950E+01  0.41150E+01
+  0.61245E+01  0.92428E+01  0.14195E+02  0.70759E-07  0.78109E-07  0.10510E-06
+  0.14134E-06  0.17047E-06  0.20986E-06  0.79519E-07  0.55536E-07  0.89809E-06
+  0.36437E-05  0.12496E-04  0.16922E-04  0.31471E-03  0.79572E-03  0.18678E-02
+  0.11466E-03  0.10324E-01  0.73438E-03  0.32345E-01  0.50984E-01  0.11325E+00
+  0.18881E+00  0.30738E+00  0.48192E+00  0.73512E+00  0.10779E+01  0.16115E+01
+  0.23321E+01  0.34494E+01  0.50488E+01  0.74564E+01  0.11142E+02  0.16901E+02
+  0.10228E-06  0.15428E-06  0.20702E-06  0.27871E-06  0.38244E-06  0.44461E-06
+  0.30127E-06  0.28079E-06  0.65947E-06  0.39371E-05  0.17097E-04  0.47235E-04
+  0.34084E-03  0.89542E-03  0.21127E-02  0.93378E-04  0.10804E-01  0.16379E-02
+  0.40326E-01  0.63595E-01  0.14123E+00  0.23554E+00  0.38350E+00  0.60097E+00
+  0.91598E+00  0.13411E+01  0.20015E+01  0.28888E+01  0.42579E+01  0.62019E+01
+  0.91018E+01  0.13487E+02  0.20242E+02  0.20393E-06  0.28218E-06  0.39477E-06
+  0.65932E-06  0.93149E-06  0.13050E-05  0.10616E-05  0.77133E-06  0.62834E-06
+  0.77931E-06  0.11295E-04  0.11038E-03  0.32317E-03  0.90186E-03  0.21772E-02
+  0.53712E-03  0.10963E-01  0.31324E-02  0.49581E-01  0.78411E-01  0.17449E+00
+  0.29158E+00  0.47527E+00  0.74506E+00  0.11353E+01  0.16604E+01  0.24752E+01
+  0.35648E+01  0.52406E+01  0.76042E+01  0.11101E+02  0.16338E+02  0.24302E+02
+  0.44899E-06  0.55927E-06  0.75883E-06  0.10890E-05  0.19954E-05  0.30069E-05
+  0.38221E-05  0.35042E-05  0.17131E-05  0.10493E-04  0.32144E-04  0.23341E-03
+  0.22376E-03  0.78421E-03  0.20335E-02  0.12990E-02  0.10855E-01  0.53572E-02
+  0.54339E-01  0.95141E-01  0.21293E+00  0.35725E+00  0.58387E+00  0.91647E+00
+  0.13970E+01  0.20419E+01  0.30425E+01  0.43745E+01  0.64190E+01  0.92860E+01
+  0.13501E+02  0.19758E+02  0.29173E+02  0.91498E-06  0.12291E-05  0.16309E-05
+  0.24998E-05  0.39880E-05  0.78830E-05  0.13011E-04  0.18082E-04  0.13832E-04
+  0.15049E-04  0.12235E-03  0.45460E-03  0.30856E-04  0.43412E-03  0.15062E-02
+  0.26676E-02  0.95515E-02  0.91922E-02  0.50273E-01  0.10711E+00  0.25342E+00
+  0.42885E+00  0.70497E+00  0.11102E+01  0.16953E+01  0.24775E+01  0.36933E+01
+  0.53042E+01  0.77754E+01  0.11223E+02  0.16266E+02  0.23702E+02  0.34791E+02
+  0.18872E-05  0.23427E-05  0.28189E-05  0.67044E-05  0.14448E-04  0.25870E-04
+  0.58904E-04  0.11187E-03  0.14029E-03  0.12616E-03  0.26853E-03  0.84149E-03
+  0.58100E-03  0.33572E-03  0.34947E-03  0.50457E-02  0.67855E-02  0.15584E-01
+  0.42581E-01  0.94021E-01  0.28773E+00  0.49597E+00  0.82533E+00  0.13088E+01
+  0.20069E+01  0.29361E+01  0.43858E+01  0.62953E+01  0.92301E+01  0.13305E+02
+  0.19242E+02  0.27952E+02  0.40846E+02  0.81980E-05  0.12848E-04  0.26317E-04
+  0.52556E-04  0.97821E-04  0.15465E-03  0.23636E-03  0.39277E-03  0.56668E-03
+  0.66639E-03  0.75806E-03  0.16630E-02  0.17073E-02  0.19663E-02  0.20424E-02
+  0.93609E-02  0.12612E-02  0.26515E-01  0.27947E-01  0.70054E-01  0.29480E+00
+  0.53115E+00  0.90869E+00  0.14641E+01  0.22665E+01  0.33264E+01  0.49949E+01
+  0.71734E+01  0.10541E+02  0.15192E+02  0.21954E+02  0.31840E+02  0.46397E+02
+  0.47543E-04  0.86440E-04  0.13839E-03  0.24534E-03  0.43194E-03  0.68420E-03
+  0.96762E-03  0.12723E-02  0.15906E-02  0.19201E-02  0.22365E-02  0.48519E-02
+  0.38877E-02  0.49906E-02  0.64361E-02  0.16736E-01  0.83758E-02  0.44266E-01
+  0.36762E-02  0.30678E-01  0.20250E+00  0.48987E+00  0.89678E+00  0.14980E+01
+  0.23685E+01  0.35039E+01  0.53223E+01  0.76617E+01  0.11324E+02  0.16348E+02
+  0.23652E+02  0.34316E+02  0.49978E+02  0.20695E-03  0.34757E-03  0.61954E-03
+  0.98252E-03  0.13819E-02  0.18297E-02  0.22649E-02  0.28562E-02  0.34193E-02
+  0.41498E-02  0.49622E-02  0.67154E-02  0.17314E-01  0.98191E-02  0.12953E-01
+  0.27248E-01  0.21632E-01  0.67571E-01  0.27393E-01  0.19322E-01  0.70153E-01
+  0.32806E+00  0.76451E+00  0.13810E+01  0.22768E+01  0.34213E+01  0.53079E+01
+  0.76800E+01  0.11476E+02  0.16635E+02  0.24154E+02  0.35144E+02  0.51279E+02
+  0.54767E-03  0.70080E-03  0.10692E-02  0.17326E-02  0.26181E-02  0.35061E-02
+  0.44144E-02  0.55064E-02  0.64951E-02  0.76587E-02  0.91678E-02  0.11883E-01
+  0.13837E-01  0.29772E-01  0.21968E-01  0.40941E-01  0.38314E-01  0.95764E-01
+  0.63335E-01  0.75191E-01  0.73590E-01  0.67933E-01  0.49070E+00  0.10915E+01
+  0.19688E+01  0.30523E+01  0.49235E+01  0.71938E+01  0.10959E+02  0.16009E+02
+  0.23409E+02  0.34271E+02  0.50263E+02  0.20182E-02  0.25758E-02  0.32999E-02
+  0.42536E-02  0.55195E-02  0.72038E-02  0.88816E-02  0.10853E-01  0.12539E-01
+  0.14286E-01  0.16950E-01  0.21360E-01  0.23574E-01  0.30107E-01  0.38296E-01
+  0.62483E-01  0.64185E-01  0.13739E+00  0.11571E+00  0.15435E+00  0.27014E+00
+  0.28373E+00  0.13181E+00  0.32272E+00  0.10336E+01  0.18367E+01  0.34019E+01
+  0.51398E+01  0.82965E+01  0.12411E+02  0.18539E+02  0.27661E+02  0.41257E+02
+  0.48247E-02  0.61417E-02  0.78419E-02  0.10048E-01  0.12235E-01  0.14376E-01
+  0.17337E-01  0.20549E-01  0.23577E-01  0.26455E-01  0.29459E-01  0.36994E-01
+  0.40452E-01  0.48083E-01  0.69852E-01  0.94055E-01  0.99343E-01  0.19172E+00
+  0.18085E+00  0.24876E+00  0.48911E+00  0.67071E+00  0.82234E+00  0.89670E+00
+  0.56657E+00  0.25986E+00  0.71958E+00  0.15015E+01  0.34941E+01  0.58701E+01
+  0.96125E+01  0.15455E+02  0.24522E+02  0.92265E-02  0.11718E-01  0.14920E-01
+  0.19051E-01  0.24416E-01  0.28941E-01  0.32365E-01  0.38011E-01  0.42232E-01
+  0.47012E-01  0.52313E-01  0.61528E-01  0.67563E-01  0.78510E-01  0.94603E-01
+  0.35646E+00  0.15160E+00  0.26904E+00  0.27082E+00  0.37450E+00  0.76255E+00
+  0.11355E+01  0.16543E+01  0.23883E+01  0.33949E+01  0.39820E+01  0.41183E+01
+  0.50770E+01  0.53038E+01  0.61763E+01  0.69239E+01  0.72941E+01  0.68464E+01
+  0.16401E-01  0.20791E-01  0.26411E-01  0.33629E-01  0.42946E-01  0.55034E-01
+  0.64136E-01  0.70396E-01  0.78456E-01  0.85020E-01  0.92617E-01  0.10712E+00
+  0.11476E+00  0.13049E+00  0.15347E+00  0.21422E+00  0.83707E+00  0.38621E+00
+  0.40484E+00  0.55589E+00  0.11341E+01  0.17476E+01  0.27152E+01  0.42971E+01
+  0.69499E+01  0.10630E+02  0.12836E+02  0.16930E+02  0.21277E+02  0.28106E+02
+  0.37132E+02  0.49008E+02  0.64585E+02  0.27301E-01  0.34556E-01  0.43812E-01
+  0.55654E-01  0.70868E-01  0.90496E-01  0.11767E+00  0.13515E+00  0.14442E+00
+  0.15686E+00  0.16850E+00  0.19023E+00  0.20162E+00  0.22478E+00  0.25841E+00
+  0.34297E+00  0.37632E+00  0.10919E+01  0.62289E+00  0.84338E+00  0.16934E+01
+  0.26438E+01  0.42245E+01  0.69891E+01  0.11782E+02  0.21009E+02  0.29109E+02
+  0.39015E+02  0.51169E+02  0.69190E+02  0.93827E+02  0.12749E+03  0.17351E+03
+  0.45039E-01  0.56931E-01  0.72065E-01  0.91366E-01  0.11607E+00  0.14779E+00
+  0.19160E+00  0.26049E+00  0.28101E+00  0.29833E+00  0.31820E+00  0.34821E+00
+  0.36722E+00  0.40235E+00  0.45301E+00  0.57428E+00  0.62814E+00  0.92398E+00
+  0.99450E+00  0.13211E+01  0.25763E+01  0.40187E+01  0.64810E+01  0.10870E+02
+  0.18842E+02  0.33693E+02  0.59433E+02  0.79991E+02  0.10667E+03  0.14539E+03
+  0.19899E+03  0.27318E+03  0.37592E+03  0.68515E-01  0.86501E-01  0.10935E+00
+  0.13841E+00  0.17550E+00  0.22293E+00  0.28824E+00  0.39020E+00  0.51982E+00
+  0.54116E+00  0.57000E+00  0.61467E+00  0.63761E+00  0.68730E+00  0.75865E+00
+  0.92745E+00  0.10024E+01  0.13750E+01  0.15046E+01  0.19477E+01  0.36294E+01
+  0.55657E+01  0.88857E+01  0.14815E+02  0.25649E+02  0.46055E+02  0.82438E+02
+  0.13615E+03  0.18215E+03  0.24844E+03  0.34060E+03  0.46873E+03  0.64693E+03
+  0.10472E+00  0.13206E+00  0.16673E+00  0.21076E+00  0.26679E+00  0.33825E+00
+  0.43646E+00  0.58880E+00  0.79588E+00  0.10098E+01  0.10528E+01  0.11304E+01
+  0.11674E+01  0.12416E+01  0.13476E+01  0.15926E+01  0.17063E+01  0.22285E+01
+  0.24348E+01  0.30710E+01  0.54489E+01  0.81831E+01  0.12872E+02  0.21231E+02
+  0.36476E+02  0.65438E+02  0.11719E+03  0.21681E+03  0.32157E+03  0.43813E+03
+  0.60079E+03  0.82770E+03  0.11444E+04  0.15524E+00  0.19555E+00  0.24663E+00
+  0.31136E+00  0.39359E+00  0.49819E+00  0.64172E+00  0.86325E+00  0.11630E+01
+  0.15788E+01  0.18991E+01  0.20122E+01  0.20891E+01  0.21959E+01  0.23483E+01
+  0.26993E+01  0.28588E+01  0.35851E+01  0.38798E+01  0.47598E+01  0.79913E+01
+  0.11668E+02  0.17930E+02  0.29005E+02  0.49068E+02  0.86805E+02  0.15613E+03
+  0.28552E+03  0.52679E+03  0.71515E+03  0.97857E+03  0.13468E+04  0.18615E+04
+  0.23499E+00  0.29570E+00  0.37251E+00  0.46979E+00  0.59310E+00  0.74970E+00
+  0.96433E+00  0.12942E+01  0.17391E+01  0.23515E+01  0.31942E+01  0.36879E+01
+  0.38010E+01  0.40045E+01  0.42295E+01  0.47446E+01  0.49776E+01  0.60155E+01
+  0.64529E+01  0.77087E+01  0.12235E+02  0.17319E+02  0.25891E+02  0.40893E+02
+  0.67810E+02  0.11786E+03  0.20974E+03  0.38332E+03  0.70292E+03  0.11827E+04
+  0.16127E+04  0.22148E+04  0.30578E+04  0.35857E+00  0.45071E+00  0.56719E+00
+  0.71456E+00  0.90109E+00  0.11376E+01  0.14615E+01  0.19577E+01  0.26251E+01
+  0.35381E+01  0.47864E+01  0.65711E+01  0.70233E+01  0.73490E+01  0.77519E+01
+  0.85177E+01  0.88619E+01  0.10370E+02  0.11024E+02  0.12842E+02  0.19272E+02
+  0.26386E+02  0.38232E+02  0.58691E+02  0.94952E+02  0.16148E+03  0.28291E+03
+  0.51367E+03  0.93638E+03  0.17390E+04  0.26469E+04  0.36229E+04  0.49908E+04
+  0.54719E+00  0.68695E+00  0.86349E+00  0.10866E+01  0.13689E+01  0.17262E+01
+  0.22154E+01  0.29627E+01  0.39657E+01  0.53310E+01  0.71879E+01  0.98095E+01
+  0.13058E+02  0.13541E+02  0.14226E+02  0.15458E+02  0.15964E+02  0.18175E+02
+  0.19143E+02  0.21787E+02  0.30974E+02  0.40969E+02  0.57374E+02  0.85276E+02
+  0.13402E+03  0.22212E+03  0.38153E+03  0.68119E+03  0.12425E+04  0.22783E+04
+  0.42592E+04  0.58576E+04  0.80433E+04  0.83145E+00  0.10423E+01  0.13086E+01
+  0.16449E+01  0.20699E+01  0.26074E+01  0.33430E+01  0.44643E+01  0.59667E+01
+  0.80031E+01  0.10762E+02  0.14616E+02  0.19629E+02  0.24998E+02  0.26006E+02
+  0.28093E+02  0.28908E+02  0.32167E+02  0.33575E+02  0.37418E+02  0.50553E+02
+  0.64601E+02  0.87309E+02  0.12529E+03  0.19057E+03  0.30665E+03  0.51430E+03
+  0.89989E+03  0.16174E+04  0.29635E+04  0.54753E+04  0.93503E+04  0.12782E+05
+  0.12805E+01  0.16026E+01  0.20091E+01  0.25223E+01  0.31705E+01  0.39897E+01
+  0.51101E+01  0.68154E+01  0.90972E+01  0.12180E+02  0.16341E+02  0.22105E+02
+  0.29627E+02  0.40115E+02  0.48509E+02  0.51635E+02  0.53490E+02  0.58369E+02
+  0.60465E+02  0.66159E+02  0.85332E+02  0.10551E+03  0.13762E+03  0.19042E+03
+  0.27959E+03  0.43533E+03  0.71021E+03  0.12136E+04  0.21419E+04  0.38931E+04
+  0.71422E+04  0.13285E+05  0.20509E+05  0.19464E+01  0.24311E+01  0.30428E+01
+  0.38146E+01  0.47890E+01  0.60195E+01  0.77024E+01  0.10259E+02  0.13678E+02
+  0.18284E+02  0.24484E+02  0.33014E+02  0.44169E+02  0.59594E+02  0.80838E+02
+  0.94353E+02  0.97027E+02  0.10550E+03  0.10850E+03  0.11684E+03  0.14455E+03
+  0.17325E+03  0.21827E+03  0.29103E+03  0.41170E+03  0.61856E+03  0.97799E+03
+  0.16262E+04  0.28083E+04  0.50160E+04  0.91898E+04  0.16876E+05  0.31579E+05
+  0.30079E+01  0.37480E+01  0.46817E+01  0.58594E+01  0.73456E+01  0.92218E+01
+  0.11787E+02  0.15680E+02  0.20882E+02  0.27873E+02  0.37268E+02  0.50112E+02
+  0.66955E+02  0.90083E+02  0.12173E+03  0.16766E+03  0.18012E+03  0.19335E+03
+  0.19963E+03  0.21207E+03  0.25301E+03  0.29484E+03  0.35952E+03  0.46233E+03
+  0.62977E+03  0.91132E+03  0.13922E+04  0.22451E+04  0.37798E+04  0.66133E+04
+  0.11923E+05  0.21875E+05  0.40437E+05  0.46217E+01  0.57427E+01  0.71558E+01
+  0.89383E+01  0.11187E+02  0.14024E+02  0.17903E+02  0.23785E+02  0.31638E+02
+  0.42175E+02  0.56310E+02  0.75544E+02  0.10082E+03  0.13532E+03  0.18229E+03
+  0.24946E+03  0.33389E+03  0.35365E+03  0.36483E+03  0.38569E+03  0.44593E+03
+  0.50673E+03  0.59956E+03  0.74485E+03  0.97732E+03  0.13607E+04  0.20038E+04
+  0.31237E+04  0.51091E+04  0.87258E+04  0.15432E+05  0.28054E+05  0.51515E+05
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.28628E-03
+  0.21337E-02  0.91724E-02  0.30749E-01  0.83771E-01  0.20417E+00  0.45185E+00
+  0.89020E+00  0.17380E+01  0.33691E+01  0.64257E+01  0.13146E+02  0.23558E+02
+  0.47329E+02  0.84960E+02  0.15206E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.33815E-03  0.25162E-02  0.10802E-01  0.34750E-01
+  0.91924E-01  0.22074E+00  0.54567E+00  0.10893E+01  0.21262E+01  0.41207E+01
+  0.78583E+01  0.16075E+02  0.28805E+02  0.57869E+02  0.10388E+03  0.18592E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.40434E-03
+  0.30029E-02  0.12870E-01  0.40539E-01  0.10517E+00  0.24649E+00  0.63286E+00
+  0.12736E+01  0.24852E+01  0.48155E+01  0.91819E+01  0.18781E+02  0.33651E+02
+  0.67600E+02  0.12134E+03  0.21718E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.48889E-03  0.36225E-02  0.15495E-01  0.50377E-01
+  0.13213E+00  0.29572E+00  0.63460E+00  0.12746E+01  0.24863E+01  0.48163E+01
+  0.91816E+01  0.18778E+02  0.33642E+02  0.67579E+02  0.12130E+03  0.21710E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.67198E-03
+  0.49670E-02  0.21196E-01  0.56804E-01  0.13251E+00  0.29628E+00  0.63530E+00
+  0.12753E+01  0.24867E+01  0.48156E+01  0.91783E+01  0.18770E+02  0.33621E+02
+  0.67535E+02  0.12122E+03  0.21696E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.68013E-03  0.50131E-02  0.21335E-01  0.57065E-01
+  0.13292E+00  0.29685E+00  0.63594E+00  0.12758E+01  0.24863E+01  0.48131E+01
+  0.91714E+01  0.18754E+02  0.33586E+02  0.67463E+02  0.12110E+03  0.21674E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.89145E-03
+  0.65517E-02  0.27798E-01  0.75228E-01  0.16801E+00  0.35081E+00  0.74015E+00
+  0.14797E+01  0.28818E+01  0.55764E+01  0.10623E+02  0.21720E+02  0.38889E+02
+  0.78117E+02  0.14023E+03  0.25100E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.38081E-04
+  0.58557E-03  0.23662E-02  0.66753E-02  0.16741E-01  0.41321E-01  0.96794E-01
+  0.20850E+00  0.42892E+00  0.89325E+00  0.17661E+01  0.34374E+01  0.66485E+01
+  0.12662E+02  0.25889E+02  0.46337E+02  0.93086E+02  0.16712E+03  0.29917E+03
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.69636E-04  0.10880E-02  0.34069E-02  0.83814E-02
+  0.20527E-01  0.49268E-01  0.11230E+00  0.23702E+00  0.48594E+00  0.10134E+01
+  0.20004E+01  0.38906E+01  0.75217E+01  0.14321E+02  0.29286E+02  0.52397E+02
+  0.10528E+03  0.18907E+03  0.33854E+03  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00
+  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.00000E+00  0.70395E-04
+  0.11285E-02  0.36771E-02  0.92501E-02  0.22810E-01  0.54949E-01  0.12289E+00
+  0.25476E+00  0.52111E+00  0.10861E+01  0.21419E+01  0.41629E+01  0.80450E+01
+  0.15315E+02  0.31333E+02  0.56031E+02  0.11264E+03  0.20238E+03  0.36253E+03
+  0.00000E+00  0.00000E+00  0.88178E-10  0.49711E-08  0.12087E-07  0.32583E-07
+  0.67548E-07  0.10798E-06  0.14582E-06  0.19469E-06  0.21037E-06  0.17863E-06
+  0.00000E+00  0.54588E-06  0.52420E-04  0.88983E-03  0.33852E-02  0.92388E-02
+  0.23504E-01  0.58049E-01  0.12881E+00  0.26660E+00  0.55111E+00  0.11381E+01
+  0.22357E+01  0.43435E+01  0.83933E+01  0.15980E+02  0.32729E+02  0.58490E+02
+  0.11770E+03  0.21166E+03  0.37946E+03  0.00000E+00  0.00000E+00  0.69307E-08
+  0.38650E-06  0.92843E-06  0.24719E-05  0.50658E-05  0.80371E-05  0.10865E-04
+  0.14806E-04  0.17265E-04  0.18547E-04  0.14996E-04  0.80783E-06  0.79239E-04
+  0.99308E-03  0.24200E-02  0.56321E-02  0.18334E-01  0.55369E-01  0.12985E+00
+  0.27011E+00  0.55871E+00  0.11566E+01  0.22694E+01  0.44087E+01  0.85216E+01
+  0.16233E+02  0.33308E+02  0.59477E+02  0.11987E+03  0.21589E+03  0.38753E+03
+  0.00000E+00  0.00000E+00  0.34725E-07  0.19178E-05  0.45556E-05  0.11981E-04
+  0.24243E-04  0.38014E-04  0.50963E-04  0.69435E-04  0.83007E-04  0.96002E-04
+  0.99111E-04  0.75698E-04  0.00000E+00  0.74699E-03  0.27506E-02  0.73411E-02
+  0.20740E-01  0.54063E-01  0.12509E+00  0.26401E+00  0.54625E+00  0.11356E+01
+  0.22633E+01  0.43997E+01  0.85116E+01  0.16231E+02  0.33404E+02  0.59589E+02
+  0.12039E+03  0.21730E+03  0.39081E+03  0.00000E+00  0.00000E+00  0.13697E-06
+  0.75030E-05  0.17652E-04  0.46403E-04  0.93131E-04  0.14431E-03  0.19142E-03
+  0.25914E-03  0.31072E-03  0.36858E-03  0.41617E-03  0.42679E-03  0.44218E-03
+  0.20000E-03  0.14055E-02  0.52317E-02  0.16312E-01  0.40913E-01  0.10359E+00
+  0.23862E+00  0.50339E+00  0.10514E+01  0.21245E+01  0.41437E+01  0.80421E+01
+  0.15384E+02  0.31861E+02  0.56766E+02  0.11526E+03  0.20892E+03  0.37710E+03
+  0.00000E+00  0.00000E+00  0.49591E-06  0.26974E-04  0.62937E-04  0.16215E-03
+  0.32071E-03  0.49108E-03  0.64365E-03  0.86203E-03  0.10287E-02  0.12269E-02
+  0.14268E-02  0.15915E-02  0.19125E-02  0.27945E-02  0.22857E-02  0.00000E+00
+  0.89764E-02  0.28259E-01  0.71877E-01  0.17550E+00  0.42055E+00  0.90944E+00
+  0.18628E+01  0.36657E+01  0.71701E+01  0.13812E+02  0.28959E+02  0.51514E+02
+  0.10555E+03  0.19280E+03  0.35024E+03  0.00000E+00  0.00000E+00  0.15613E-05
+  0.84429E-04  0.19560E-03  0.49968E-03  0.97857E-03  0.14816E-02  0.19182E-02
+  0.25362E-02  0.29895E-02  0.35328E-02  0.41156E-02  0.46931E-02  0.57171E-02
+  0.85099E-02  0.98665E-02  0.10153E-01  0.41858E-02  0.90174E-02  0.40484E-01
+  0.93206E-01  0.25443E+00  0.71653E+00  0.15280E+01  0.30617E+01  0.60781E+01
+  0.11856E+02  0.25366E+02  0.45034E+02  0.93607E+02  0.17300E+03  0.31728E+03
+  0.00000E+00  0.00000E+00  0.47050E-05  0.25322E-03  0.58317E-03  0.14792E-02
+  0.28724E-02  0.43067E-02  0.55140E-02  0.72018E-02  0.83843E-02  0.97945E-02
+  0.11338E-01  0.12965E-01  0.15630E-01  0.22103E-01  0.27043E-01  0.32274E-01
+  0.32419E-01  0.30629E-01  0.12907E-01  0.33690E-01  0.89971E-01  0.33856E+00
+  0.98614E+00  0.20827E+01  0.42993E+01  0.86454E+01  0.19320E+02  0.34216E+02
+  0.73197E+02  0.13832E+03  0.25817E+03  0.00000E+00  0.00000E+00  0.13250E-04
+  0.71026E-03  0.16279E-02  0.41052E-02  0.79156E-02  0.11768E-01  0.14920E-01
+  0.19270E-01  0.22157E-01  0.25552E-01  0.29267E-01  0.33259E-01  0.39360E-01
+  0.52258E-01  0.63216E-01  0.76881E-01  0.88104E-01  0.10574E+00  0.11742E+00
+  0.11599E+00  0.80406E-01  0.41063E-01  0.37989E+00  0.10538E+01  0.25351E+01
+  0.56296E+01  0.14139E+02  0.24964E+02  0.57093E+02  0.11308E+03  0.21852E+03
+  0.00000E+00  0.00000E+00  0.27855E-04  0.14884E-02  0.33978E-02  0.85409E-02
+  0.16384E-01  0.24190E-01  0.30408E-01  0.38887E-01  0.44225E-01  0.50389E-01
+  0.57012E-01  0.64021E-01  0.74904E-01  0.98190E-01  0.11820E+00  0.14398E+00
+  0.17160E+00  0.21744E+00  0.27193E+00  0.33888E+00  0.42069E+00  0.48483E+00
+  0.51786E+00  0.47799E+00  0.11843E+00  0.10264E+01  0.58913E+01  0.10362E+02
+  0.30557E+02  0.69463E+02  0.14645E+03  0.00000E+00  0.00000E+00  0.56836E-04
+  0.30292E-02  0.68931E-02  0.17279E-01  0.33004E-01  0.48443E-01  0.60461E-01
+  0.76668E-01  0.86349E-01  0.97300E-01  0.10875E+00  0.12048E+00  0.13877E+00
+  0.17780E+00  0.21072E+00  0.25331E+00  0.30319E+00  0.38653E+00  0.49661E+00
+  0.65031E+00  0.87791E+00  0.12222E+01  0.16468E+01  0.23562E+01  0.33082E+01
+  0.44238E+01  0.37540E+01  0.65714E+01  0.00000E+00  0.19459E+02  0.64094E+02
+  0.00000E+00  0.00000E+00  0.12214E-03  0.64965E-02  0.14745E-01  0.36842E-01
+  0.70069E-01  0.10232E+00  0.12698E+00  0.15992E+00  0.17869E+00  0.19951E+00
+  0.22066E+00  0.24155E+00  0.27385E+00  0.34168E+00  0.39883E+00  0.47187E+00
+  0.56234E+00  0.71250E+00  0.92047E+00  0.12244E+01  0.17000E+01  0.24757E+01
+  0.35813E+01  0.55062E+01  0.85614E+01  0.13269E+02  0.19228E+02  0.33462E+02
+  0.48174E+02  0.59002E+02  0.64628E+02  0.00000E+00  0.00000E+00  0.26019E-03
+  0.13816E-01  0.31293E-01  0.77981E-01  0.14777E+00  0.21487E+00  0.26542E+00
+  0.33238E+00  0.36889E+00  0.40859E+00  0.44759E+00  0.48428E+00  0.53983E+00
+  0.65275E+00  0.74837E+00  0.86848E+00  0.10210E+01  0.12715E+01  0.16237E+01
+  0.21445E+01  0.29705E+01  0.43432E+01  0.63735E+01  0.99207E+01  0.15744E+02
+  0.25125E+02  0.39625E+02  0.68465E+02  0.11025E+03  0.15945E+03  0.22856E+03
+  0.00000E+00  0.00000E+00  0.52731E-03  0.27963E-01  0.63229E-01  0.15712E+00
+  0.29686E+00  0.43019E+00  0.52933E+00  0.65971E+00  0.72797E+00  0.80070E+00
+  0.86932E+00  0.92978E+00  0.10185E+01  0.11890E+01  0.13343E+01  0.15162E+01
+  0.17485E+01  0.21262E+01  0.26571E+01  0.34404E+01  0.46803E+01  0.67396E+01
+  0.98072E+01  0.15136E+02  0.23940E+02  0.38271E+02  0.61686E+02  0.10565E+03
+  0.17517E+03  0.26345E+03  0.39695E+03  0.00000E+00  0.00000E+00  0.11069E-02
+  0.58636E-01  0.13241E+00  0.32778E+00  0.61791E+00  0.89361E+00  0.10959E+01
+  0.13602E+01  0.14939E+01  0.16338E+01  0.17603E+01  0.18632E+01  0.20095E+01
+  0.22637E+01  0.24795E+01  0.27641E+01  0.31292E+01  0.37158E+01  0.45377E+01
+  0.57431E+01  0.76390E+01  0.10769E+02  0.15429E+02  0.23451E+02  0.36694E+02
+  0.58309E+02  0.94714E+02  0.16048E+03  0.26979E+03  0.41381E+03  0.63881E+03
+  0.00000E+00  0.00000E+00  0.22884E-02  0.12112E+00  0.27322E+00  0.67547E+00
+  0.12712E+01  0.18346E+01  0.22440E+01  0.27766E+01  0.30380E+01  0.33072E+01
+  0.35394E+01  0.37107E+01  0.39321E+01  0.42427E+01  0.45626E+01  0.49972E+01
+  0.55543E+01  0.64405E+01  0.76739E+01  0.94670E+01  0.12259E+02  0.16823E+02
+  0.23569E+02  0.35042E+02  0.53862E+02  0.84463E+02  0.13663E+03  0.22854E+03
+  0.38497E+03  0.59451E+03  0.92641E+03  0.00000E+00  0.00000E+00  0.42772E-02
+  0.22623E+00  0.50988E+00  0.12592E+01  0.23666E+01  0.34097E+01  0.41619E+01
+  0.51362E+01  0.56020E+01  0.60746E+01  0.64760E+01  0.67634E+01  0.71167E+01
+  0.75355E+01  0.79841E+01  0.86040E+01  0.93938E+01  0.10643E+02  0.12366E+02
+  0.14848E+02  0.18668E+02  0.24833E+02  0.33843E+02  0.48961E+02  0.73496E+02
+  0.11305E+03  0.18050E+03  0.29731E+03  0.49766E+03  0.76739E+03  0.11965E+04
+  0.00000E+00  0.00000E+00  0.80458E-02  0.42533E+00  0.95798E+00  0.23639E+01
+  0.44378E+01  0.63853E+01  0.77811E+01  0.95827E+01  0.10425E+02  0.11270E+02
+  0.12003E+02  0.12562E+02  0.13194E+02  0.13708E+02  0.14338E+02  0.15241E+02
+  0.16386E+02  0.18187E+02  0.20654E+02  0.24172E+02  0.29529E+02  0.38060E+02
+  0.50374E+02  0.70733E+02  0.10336E+03  0.15542E+03  0.24391E+03  0.39454E+03
+  0.65392E+03  0.10038E+04  0.15615E+04  0.00000E+00  0.00000E+00  0.14764E-01
+  0.78014E+00  0.17562E+01  0.43305E+01  0.81229E+01  0.11675E+02  0.14208E+02
+  0.17469E+02  0.18966E+02  0.20450E+02  0.21748E+02  0.22758E+02  0.23841E+02
+  0.24453E+02  0.25318E+02  0.26599E+02  0.28212E+02  0.30744E+02  0.34189E+02
+  0.39061E+02  0.46400E+02  0.57940E+02  0.74373E+02  0.10114E+03  0.14343E+03
+  0.21004E+03  0.32239E+03  0.51065E+03  0.83421E+03  0.12699E+04  0.19633E+04
+  0.00000E+00  0.00000E+00  0.26599E-01  0.14050E+01  0.31615E+01  0.77916E+01
+  0.14605E+02  0.20974E+02  0.25497E+02  0.31306E+02  0.33935E+02  0.36514E+02
+  0.38734E+02  0.40404E+02  0.42158E+02  0.43002E+02  0.44200E+02  0.45980E+02
+  0.48206E+02  0.51704E+02  0.56433E+02  0.63077E+02  0.72995E+02  0.88402E+02
+  0.11005E+03  0.14478E+03  0.19884E+03  0.28278E+03  0.42281E+03  0.65382E+03
+  0.10485E+04  0.15774E+04  0.24163E+04  0.00000E+00  0.00000E+00  0.46113E-01
+  0.24351E+01  0.54775E+01  0.13494E+02  0.25279E+02  0.36278E+02  0.44064E+02
+  0.54045E+02  0.58504E+02  0.62844E+02  0.66528E+02  0.69213E+02  0.71976E+02
+  0.73073E+02  0.74651E+02  0.77014E+02  0.79936E+02  0.84564E+02  0.90793E+02
+  0.99505E+02  0.11242E+03  0.13227E+03  0.15980E+03  0.20337E+03  0.27013E+03
+  0.37221E+03  0.54015E+03  0.81314E+03  0.12749E+04  0.18888E+04  0.28569E+04
+  0.00000E+00  0.00000E+00  0.78490E-01  0.41440E+01  0.93188E+01  0.22949E+02
+  0.42974E+02  0.61638E+02  0.74815E+02  0.91682E+02  0.99140E+02  0.10635E+03
+  0.11239E+03  0.11668E+03  0.12101E+03  0.12238E+03  0.12440E+03  0.12746E+03
+  0.13119E+03  0.13718E+03  0.14523E+03  0.15646E+03  0.17302E+03  0.19827E+03
+  0.23290E+03  0.28703E+03  0.36869E+03  0.49161E+03  0.69070E+03  0.10096E+04
+  0.15420E+04  0.22431E+04  0.33403E+04  0.00000E+00  0.00000E+00  0.12734E+00
+  0.67220E+01  0.15113E+02  0.37207E+02  0.69649E+02  0.99853E+02  0.12113E+03
+  0.14834E+03  0.16026E+03  0.17173E+03  0.18123E+03  0.18779E+03  0.19431E+03
+  0.19586E+03  0.19824E+03  0.20194E+03  0.20635E+03  0.21364E+03  0.22343E+03
+  0.23712E+03  0.25730E+03  0.28790E+03  0.32946E+03  0.39380E+03  0.48947E+03
+  0.63124E+03  0.85686E+03  0.12135E+04  0.17992E+04  0.25610E+04  0.37420E+04
+  0.00000E+00  0.00000E+00  0.20204E+00  0.10664E+02  0.23970E+02  0.59000E+02
+  0.11041E+03  0.15824E+03  0.19188E+03  0.23483E+03  0.25353E+03  0.27142E+03
+  0.28610E+03  0.29601E+03  0.30568E+03  0.30729E+03  0.30991E+03  0.31417E+03
+  0.31909E+03  0.32764E+03  0.33913E+03  0.35533E+03  0.37930E+03  0.41560E+03
+  0.46454E+03  0.53982E+03  0.65030E+03  0.81163E+03  0.10636E+04  0.14575E+04
+  0.20919E+04  0.29058E+04  0.41537E+04  0.17636E-09  0.29350E-10  0.82101E-09
+  0.27104E-08  0.70475E-08  0.16901E-07  0.40086E-07  0.95261E-07  0.24050E-06
+  0.51862E-06  0.13060E-05  0.44185E-05  0.40080E-04  0.18320E-03  0.52841E-03
+  0.13662E-02  0.36742E-02  0.86422E-02  0.18005E-01  0.31988E-01  0.54340E-01
+  0.83548E-01  0.12728E+00  0.19383E+00  0.28686E+00  0.41628E+00  0.60129E+00
+  0.86099E+00  0.13075E+01  0.17668E+01  0.26507E+01  0.37501E+01  0.53035E+01
+  0.46658E-09  0.25270E-09  0.42539E-09  0.25430E-08  0.73465E-08  0.18492E-07
+  0.43292E-07  0.10917E-06  0.30045E-06  0.77237E-06  0.23343E-05  0.84357E-05
+  0.64756E-04  0.25842E-03  0.67929E-03  0.18426E-02  0.43393E-02  0.10313E-01
+  0.22862E-01  0.40528E-01  0.68736E-01  0.10554E+00  0.16060E+00  0.24432E+00
+  0.36123E+00  0.52372E+00  0.75560E+00  0.10805E+01  0.16381E+01  0.22091E+01
+  0.33050E+01  0.46623E+01  0.65696E+01  0.72155E-09  0.98093E-09  0.49316E-09
+  0.12578E-08  0.65758E-08  0.19036E-07  0.44731E-07  0.11215E-06  0.33410E-06
+  0.10098E-05  0.44436E-05  0.16625E-04  0.87688E-04  0.34304E-03  0.85805E-03
+  0.21934E-02  0.52007E-02  0.11346E-01  0.27917E-01  0.51425E-01  0.87048E-01
+  0.13345E+00  0.20281E+00  0.30817E+00  0.45522E+00  0.65930E+00  0.95029E+00
+  0.13574E+01  0.20549E+01  0.27664E+01  0.41295E+01  0.58115E+01  0.81642E+01
+  0.11516E-08  0.14485E-08  0.15156E-08  0.24069E-09  0.53227E-08  0.22910E-07
+  0.56088E-07  0.11379E-06  0.31832E-06  0.11616E-05  0.60150E-05  0.33212E-04
+  0.11721E-03  0.41872E-03  0.10269E-02  0.25767E-02  0.59306E-02  0.12686E-01
+  0.29460E-01  0.65385E-01  0.11041E+00  0.16895E+00  0.25636E+00  0.38903E+00
+  0.57407E+00  0.83063E+00  0.11960E+01  0.17067E+01  0.25806E+01  0.34691E+01
+  0.51688E+01  0.72598E+01  0.10174E+02  0.21019E-08  0.26190E-08  0.31068E-08
+  0.25117E-08  0.17648E-08  0.21101E-07  0.83638E-07  0.17876E-06  0.29079E-06
+  0.91909E-06  0.67725E-05  0.45754E-04  0.15925E-03  0.48552E-03  0.11785E-02
+  0.28862E-02  0.66359E-02  0.13993E-01  0.31446E-01  0.68435E-01  0.14030E+00
+  0.21420E+00  0.32442E+00  0.49157E+00  0.72452E+00  0.10472E+01  0.15064E+01
+  0.21475E+01  0.32437E+01  0.43552E+01  0.64788E+01  0.90853E+01  0.12707E+02
+  0.38385E-08  0.52387E-08  0.58593E-08  0.63330E-08  0.45200E-08  0.13387E-07
+  0.83869E-07  0.29918E-06  0.60824E-06  0.77253E-06  0.57796E-05  0.51208E-04
+  0.19359E-03  0.55721E-03  0.13065E-02  0.31554E-02  0.71487E-02  0.14991E-01
+  0.33677E-01  0.71144E-01  0.15297E+00  0.27203E+00  0.41108E+00  0.62174E+00
+  0.91515E+00  0.13211E+01  0.18986E+01  0.27041E+01  0.40800E+01  0.54724E+01
+  0.81300E+01  0.11386E+02  0.15899E+02  0.20744E-07  0.26790E-07  0.33729E-07
+  0.62791E-07  0.12576E-06  0.17710E-06  0.36695E-06  0.29908E-06  0.64647E-06
+  0.27235E-05  0.37761E-05  0.40964E-04  0.19138E-03  0.58182E-03  0.13855E-02
+  0.33284E-02  0.74140E-02  0.15608E-01  0.34696E-01  0.73906E-01  0.15526E+00
+  0.30925E+00  0.51853E+00  0.78305E+00  0.11513E+01  0.16604E+01  0.23841E+01
+  0.33933E+01  0.51174E+01  0.68565E+01  0.10178E+02  0.14241E+02  0.19863E+02
+  0.41193E-07  0.56352E-07  0.83769E-07  0.12821E-06  0.34252E-06  0.70656E-06
+  0.15339E-05  0.26016E-05  0.25124E-05  0.33009E-05  0.16859E-04  0.43995E-04
+  0.18313E-03  0.59365E-03  0.14705E-02  0.35985E-02  0.76750E-02  0.16263E-01
+  0.35908E-01  0.75630E-01  0.15869E+00  0.31419E+00  0.62577E+00  0.98850E+00
+  0.14512E+01  0.20902E+01  0.29981E+01  0.42635E+01  0.64255E+01  0.86008E+01
+  0.12758E+02  0.17838E+02  0.24857E+02  0.20675E-07  0.39452E-07  0.61847E-07
+  0.12134E-06  0.17533E-06  0.43083E-07  0.89848E-06  0.36772E-05  0.10710E-04
+  0.27559E-04  0.60756E-04  0.12486E-03  0.34295E-03  0.75869E-03  0.17552E-02
+  0.41728E-02  0.89635E-02  0.17866E-01  0.38634E-01  0.80201E-01  0.16576E+00
+  0.32795E+00  0.64745E+00  0.12714E+01  0.18598E+01  0.26713E+01  0.38233E+01
+  0.54273E+01  0.81635E+01  0.10917E+02  0.16167E+02  0.22573E+02  0.31408E+02
+  0.16138E-06  0.26148E-06  0.43327E-06  0.61492E-06  0.73762E-06  0.53746E-06
+  0.88317E-06  0.55751E-05  0.16280E-04  0.39577E-04  0.88836E-04  0.18767E-03
+  0.40202E-03  0.16059E-02  0.20383E-02  0.45916E-02  0.96869E-02  0.19327E-01
+  0.41024E-01  0.84061E-01  0.17040E+00  0.33724E+00  0.66469E+00  0.13289E+01
+  0.23629E+01  0.33858E+01  0.48370E+01  0.68560E+01  0.10300E+02  0.13760E+02
+  0.20357E+02  0.28400E+02  0.39482E+02  0.29817E-06  0.38396E-06  0.79977E-06
+  0.15685E-05  0.24333E-05  0.27818E-05  0.19143E-05  0.28282E-05  0.16388E-04
+  0.45835E-04  0.10743E-03  0.23653E-03  0.51303E-03  0.11251E-02  0.64828E-02
+  0.52521E-02  0.10582E-01  0.20734E-01  0.43360E-01  0.87771E-01  0.17602E+00
+  0.34565E+00  0.68385E+00  0.13600E+01  0.26035E+01  0.42944E+01  0.61214E+01
+  0.86625E+01  0.12997E+02  0.17342E+02  0.25633E+02  0.35734E+02  0.49639E+02
+  0.20980E-04  0.27599E-04  0.36733E-04  0.53090E-04  0.79765E-04  0.11825E-03
+  0.15855E-03  0.20395E-03  0.24947E-03  0.29257E-03  0.31885E-03  0.30853E-03
+  0.16481E-03  0.29712E-03  0.13724E-02  0.11418E-01  0.86421E-02  0.17753E-01
+  0.38866E-01  0.80068E-01  0.16271E+00  0.32217E+00  0.64087E+00  0.12952E+01
+  0.24811E+01  0.47319E+01  0.73029E+01  0.10353E+02  0.15599E+02  0.20787E+02
+  0.30825E+02  0.43098E+02  0.60014E+02  0.12671E-03  0.16453E-03  0.21554E-03
+  0.28375E-03  0.37764E-03  0.46995E-03  0.56737E-03  0.70195E-03  0.83725E-03
+  0.98344E-03  0.10962E-02  0.11669E-02  0.10860E-02  0.69712E-03  0.41697E-03
+  0.33468E-02  0.86947E-02  0.18617E-01  0.40436E-01  0.82601E-01  0.16632E+00
+  0.32589E+00  0.64166E+00  0.12870E+01  0.24870E+01  0.47293E+01  0.89341E+01
+  0.15978E+02  0.24076E+02  0.31970E+02  0.47438E+02  0.66385E+02  0.92502E+02
+  0.29586E-04  0.37954E-04  0.48854E-04  0.62717E-04  0.80472E-04  0.10230E-03
+  0.11484E-03  0.11320E-03  0.97967E-04  0.47011E-04  0.11057E-03  0.46903E-03
+  0.12161E-02  0.26469E-02  0.51371E-02  0.10146E-01  0.18307E-01  0.33674E-01
+  0.63837E-01  0.11712E+00  0.22054E+00  0.41147E+00  0.78021E+00  0.15192E+01
+  0.28697E+01  0.54173E+01  0.10126E+02  0.18725E+02  0.33650E+02  0.44572E+02
+  0.65535E+02  0.91041E+02  0.12607E+03  0.54527E-03  0.70090E-03  0.90713E-03
+  0.11774E-02  0.15411E-02  0.20354E-02  0.27122E-02  0.32798E-02  0.36537E-02
+  0.41409E-02  0.46341E-02  0.51176E-02  0.55009E-02  0.55929E-02  0.50846E-02
+  0.30185E-02  0.11735E-02  0.96161E-02  0.49994E-01  0.71034E-01  0.14932E+00
+  0.29784E+00  0.58957E+00  0.11827E+01  0.22865E+01  0.43680E+01  0.83476E+01
+  0.15580E+02  0.31654E+02  0.47603E+02  0.71028E+02  0.99930E+02  0.13987E+03
+  0.89783E-03  0.11496E-02  0.14808E-02  0.19111E-02  0.24846E-02  0.32554E-02
+  0.42979E-02  0.57284E-02  0.69162E-02  0.75679E-02  0.83622E-02  0.91795E-02
+  0.98458E-02  0.10284E-01  0.10133E-01  0.84467E-02  0.50367E-02  0.19936E-02
+  0.24443E-01  0.18726E+00  0.13998E+00  0.28478E+00  0.56719E+00  0.11383E+01
+  0.22004E+01  0.41895E+01  0.79896E+01  0.15091E+02  0.30652E+02  0.53364E+02
+  0.86829E+02  0.12251E+03  0.17187E+03  0.14178E-02  0.18099E-02  0.23228E-02
+  0.29852E-02  0.38609E-02  0.50277E-02  0.65902E-02  0.87119E-02  0.11603E-01
+  0.14035E-01  0.15108E-01  0.16377E-01  0.17532E-01  0.18366E-01  0.18742E-01
+  0.17737E-01  0.15433E-01  0.10571E-01  0.10094E-01  0.47031E-01  0.12181E+00
+  0.26120E+00  0.53101E+00  0.10737E+01  0.20832E+01  0.39576E+01  0.75373E+01
+  0.14239E+02  0.29403E+02  0.50795E+02  0.10239E+03  0.14863E+03  0.20920E+03
+  0.20816E-02  0.26494E-02  0.33885E-02  0.43372E-02  0.55824E-02  0.72275E-02
+  0.94092E-02  0.12340E-01  0.16285E-01  0.21674E-01  0.26258E-01  0.28106E-01
+  0.30034E-01  0.31649E-01  0.32662E-01  0.32372E-01  0.31274E-01  0.28573E-01
+  0.10663E-01  0.23164E-01  0.96733E-01  0.23220E+00  0.49151E+00  0.10089E+01
+  0.19708E+01  0.37363E+01  0.71047E+01  0.13413E+02  0.27957E+02  0.48376E+02
+  0.97661E+02  0.17719E+03  0.25434E+03  0.28421E-02  0.36081E-02  0.46009E-02
+  0.58687E-02  0.75224E-02  0.96912E-02  0.12542E-01  0.16333E-01  0.21379E-01
+  0.28183E-01  0.37234E-01  0.45195E-01  0.47647E-01  0.49996E-01  0.51614E-01
+  0.51409E-01  0.50713E-01  0.49049E-01  0.30412E-01  0.00000E+00  0.79015E-01
+  0.22033E+00  0.48455E+00  0.10026E+01  0.19578E+01  0.36830E+01  0.69576E+01
+  0.13071E+02  0.27251E+02  0.47122E+02  0.95638E+02  0.17339E+03  0.31325E+03
+  0.39345E-02  0.49832E-02  0.63381E-02  0.80601E-02  0.10296E-01  0.13210E-01
+  0.17013E-01  0.22027E-01  0.28638E-01  0.37455E-01  0.49055E-01  0.64686E-01
+  0.77890E-01  0.80893E-01  0.83580E-01  0.84078E-01  0.84144E-01  0.84315E-01
+  0.65278E-01  0.37083E-01  0.37386E-01  0.18475E+00  0.45260E+00  0.96711E+00
+  0.19080E+01  0.35731E+01  0.67168E+01  0.12568E+02  0.26271E+02  0.45013E+02
+  0.92494E+02  0.16833E+03  0.30408E+03  0.53890E-02  0.68105E-02  0.86416E-02
+  0.10961E-01  0.13960E-01  0.17849E-01  0.22893E-01  0.29498E-01  0.38131E-01
+  0.49541E-01  0.64398E-01  0.84214E-01  0.10987E+00  0.13099E+00  0.13415E+00
+  0.13573E+00  0.13695E+00  0.13904E+00  0.11857E+00  0.92197E-01  0.25096E-01
+  0.12656E+00  0.40448E+00  0.92360E+00  0.18618E+01  0.34785E+01  0.65091E+01
+  0.12125E+02  0.25416E+02  0.43058E+02  0.88674E+02  0.16350E+03  0.29606E+03
+  0.74244E-02  0.93613E-02  0.11850E-01  0.14993E-01  0.19041E-01  0.24266E-01
+  0.31003E-01  0.39767E-01  0.51132E-01  0.66007E-01  0.85176E-01  0.11044E+00
+  0.14278E+00  0.18466E+00  0.21613E+00  0.21615E+00  0.21847E+00  0.22135E+00
+  0.19519E+00  0.16648E+00  0.94053E-01  0.54576E-01  0.36074E+00  0.91005E+00
+  0.18825E+01  0.35018E+01  0.65014E+01  0.12015E+02  0.25155E+02  0.42036E+02
+  0.86500E+02  0.15956E+03  0.29210E+03  0.98737E-02  0.12422E-01  0.15690E-01
+  0.19808E-01  0.25096E-01  0.31899E-01  0.40636E-01  0.51943E-01  0.66518E-01
+  0.85467E-01  0.10970E+00  0.14136E+00  0.18151E+00  0.23306E+00  0.29763E+00
+  0.33995E+00  0.34040E+00  0.34705E+00  0.31225E+00  0.27936E+00  0.19865E+00
+  0.52585E-01  0.27839E+00  0.87725E+00  0.19087E+01  0.35540E+01  0.65555E+01
+  0.12014E+02  0.25116E+02  0.41283E+02  0.84802E+02  0.15637E+03  0.28605E+03
+  0.13321E-01  0.16716E-01  0.21064E-01  0.26532E-01  0.33536E-01  0.42517E-01
+  0.54010E-01  0.68809E-01  0.87788E-01  0.11229E+00  0.14337E+00  0.18361E+00
+  0.23414E+00  0.29827E+00  0.37759E+00  0.48292E+00  0.53435E+00  0.53641E+00
+  0.48921E+00  0.44249E+00  0.33998E+00  0.16773E+00  0.18438E+00  0.87991E+00
+  0.20323E+01  0.37787E+01  0.68948E+01  0.12470E+02  0.25879E+02  0.41713E+02
+  0.85138E+02  0.15639E+03  0.28507E+03  0.17120E-01  0.21425E-01  0.26930E-01
+  0.33844E-01  0.42683E-01  0.53994E-01  0.68427E-01  0.86949E-01  0.11060E+00
+  0.14098E+00  0.17928E+00  0.22851E+00  0.28982E+00  0.36684E+00  0.46103E+00
+  0.58444E+00  0.74410E+00  0.80143E+00  0.72517E+00  0.66149E+00  0.52122E+00
+  0.30333E+00  0.83754E-01  0.94666E+00  0.23091E+01  0.42581E+01  0.76348E+01
+  0.13542E+02  0.27683E+02  0.43613E+02  0.87929E+02  0.16021E+03  0.28995E+03
+  0.23157E-01  0.28885E-01  0.36204E-01  0.45383E-01  0.57099E-01  0.72061E-01
+  0.91105E-01  0.11547E+00  0.14647E+00  0.18612E+00  0.23585E+00  0.29938E+00
+  0.37794E+00  0.47594E+00  0.59469E+00  0.74890E+00  0.94599E+00  0.12197E+01
+  0.11509E+01  0.10533E+01  0.86522E+00  0.58215E+00  0.14707E+00  0.85405E+00
+  0.24874E+01  0.46703E+01  0.83310E+01  0.14580E+02  0.29531E+02  0.45324E+02
+  0.90402E+02  0.16350E+03  0.29381E+03  0.29439E-01  0.36583E-01  0.45703E-01
+  0.57131E-01  0.71700E-01  0.90279E-01  0.11388E+00  0.14402E+00  0.18224E+00
+  0.23095E+00  0.29178E+00  0.36910E+00  0.46411E+00  0.58158E+00  0.72251E+00
+  0.90310E+00  0.11304E+01  0.14407E+01  0.16791E+01  0.15336E+01  0.12567E+01
+  0.86555E+00  0.28996E+00  0.98957E+00  0.31099E+01  0.57648E+01  0.10038E+02
+  0.17095E+02  0.33742E+02  0.50291E+02  0.98115E+02  0.17469E+03  0.30964E+03
+  0.38931E-01  0.48160E-01  0.59932E-01  0.74668E-01  0.93439E-01  0.11735E+00
+  0.14767E+00  0.18629E+00  0.23516E+00  0.29725E+00  0.37448E+00  0.47213E+00
+  0.59141E+00  0.73779E+00  0.91170E+00  0.11317E+01  0.14045E+01  0.17703E+01
+  0.20419E+01  0.23288E+01  0.18885E+01  0.13230E+01  0.52902E+00  0.11284E+01
+  0.39726E+01  0.73059E+01  0.12439E+02  0.20610E+02  0.39584E+02  0.57139E+02
+  0.10869E+03  0.19000E+03  0.33127E+03  0.49922E-01  0.61422E-01  0.76088E-01
+  0.94438E-01  0.11779E+00  0.14750E+00  0.18514E+00  0.23303E+00  0.29350E+00
+  0.37015E+00  0.46524E+00  0.58509E+00  0.73083E+00  0.90880E+00  0.11187E+01
+  0.13820E+01  0.17050E+01  0.21324E+01  0.24424E+01  0.28631E+01  0.28192E+01
+  0.19905E+01  0.90527E+00  0.12336E+01  0.51687E+01  0.94913E+01  0.15846E+02
+  0.25568E+02  0.47759E+02  0.66630E+02  0.12324E+03  0.21093E+03  0.36076E+03
+  0.66811E-01  0.81674E-01  0.10062E+00  0.12431E+00  0.15444E+00  0.19275E+00
+  0.24122E+00  0.30281E+00  0.38045E+00  0.47867E+00  0.60023E+00  0.75294E+00
+  0.93794E+00  0.11628E+01  0.14264E+01  0.17543E+01  0.21521E+01  0.26720E+01
+  0.30402E+01  0.35336E+01  0.37376E+01  0.31119E+01  0.15346E+01  0.12224E+01
+  0.68229E+01  0.12609E+02  0.20724E+02  0.32629E+02  0.59312E+02  0.79881E+02
+  0.14337E+03  0.23967E+03  0.40099E+03  0.86175E-01  0.10455E+00  0.12797E+00
+  0.15723E+00  0.19444E+00  0.24171E+00  0.30149E+00  0.37736E+00  0.47291E+00
+  0.59358E+00  0.74265E+00  0.92948E+00  0.11551E+01  0.14283E+01  0.17471E+01
+  0.21406E+01  0.26141E+01  0.32260E+01  0.36478E+01  0.42049E+01  0.44144E+01
+  0.41042E+01  0.23415E+01  0.13692E+01  0.96025E+01  0.17650E+02  0.28430E+02
+  0.43581E+02  0.76824E+02  0.99863E+02  0.17323E+03  0.28182E+03  0.45953E+03
+  0.11608E+00  0.13959E+00  0.16954E+00  0.20697E+00  0.25452E+00  0.31491E+00
+  0.39119E+00  0.48797E+00  0.60967E+00  0.76317E+00  0.95242E+00  0.11891E+01
+  0.14741E+01  0.18176E+01  0.22164E+01  0.27052E+01  0.32879E+01  0.40326E+01
+  0.45281E+01  0.51714E+01  0.53748E+01  0.49499E+01  0.33183E+01  0.17309E+01
+  0.13955E+02  0.25617E+02  0.40404E+02  0.60322E+02  0.10307E+03  0.12943E+03
+  0.21662E+03  0.34222E+03  0.54238E+03  0.15196E+00  0.18089E+00  0.21774E+00
+  0.26377E+00  0.32224E+00  0.39645E+00  0.49017E+00  0.60897E+00  0.75827E+00
+  0.94641E+00  0.11781E+01  0.14672E+01  0.18147E+01  0.22324E+01  0.27156E+01
+  0.33045E+01  0.40024E+01  0.48872E+01  0.54611E+01  0.61968E+01  0.63969E+01
+  0.58570E+01  0.39456E+01  0.20952E+01  0.20539E+02  0.37575E+02  0.58643E+02
+  0.85549E+02  0.14210E+03  0.17268E+03  0.27903E+03  0.42785E+03  0.65822E+03
+  0.14559E-09  0.25528E-10  0.63882E-09  0.22630E-08  0.40718E-08  0.11091E-07
+  0.15662E-07  0.31173E-07  0.63192E-07  0.14170E-06  0.29643E-06  0.61502E-06
+  0.27716E-05  0.25293E-04  0.55950E-04  0.42139E-03  0.13847E-02  0.30884E-02
+  0.64544E-02  0.11501E-01  0.19589E-01  0.30204E-01  0.46159E-01  0.70562E-01
+  0.10489E+00  0.15309E+00  0.22277E+00  0.32197E+00  0.49522E+00  0.67989E+00
+  0.10420E+01  0.15071E+01  0.21898E+01  0.50949E-09  0.21013E-09  0.36622E-09
+  0.19776E-08  0.60948E-08  0.10807E-07  0.27867E-07  0.41577E-07  0.83547E-07
+  0.18997E-06  0.37778E-06  0.80062E-06  0.49574E-05  0.43121E-04  0.71387E-04
+  0.53718E-03  0.17607E-02  0.39171E-02  0.81709E-02  0.14534E-01  0.24722E-01
+  0.38065E-01  0.58097E-01  0.88681E-01  0.13162E+00  0.19173E+00  0.27830E+00
+  0.40102E+00  0.61430E+00  0.83917E+00  0.12778E+01  0.18358E+01  0.26461E+01
+  0.10029E-08  0.77036E-09  0.37694E-10  0.17476E-08  0.59625E-08  0.16902E-07
+  0.28717E-07  0.63728E-07  0.11678E-06  0.22730E-06  0.49270E-06  0.10536E-05
+  0.78903E-05  0.73049E-04  0.14711E-03  0.68802E-03  0.22473E-02  0.49840E-02
+  0.10372E-01  0.18411E-01  0.31265E-01  0.48073E-01  0.73269E-01  0.11168E+00
+  0.16551E+00  0.24069E+00  0.34866E+00  0.50115E+00  0.76511E+00  0.10409E+01
+  0.15762E+01  0.22519E+01  0.32236E+01  0.22788E-08  0.22025E-08  0.14331E-08
+  0.51294E-09  0.53064E-08  0.16938E-07  0.44083E-07  0.85313E-07  0.18769E-06
+  0.34926E-06  0.81595E-06  0.18718E-05  0.21551E-04  0.12290E-03  0.32613E-03
+  0.98804E-03  0.30311E-02  0.66903E-02  0.13872E-01  0.24549E-01  0.41589E-01
+  0.63822E-01  0.97102E-01  0.14776E+00  0.21862E+00  0.31734E+00  0.45873E+00
+  0.65770E+00  0.10008E+01  0.13562E+01  0.20426E+01  0.29019E+01  0.41258E+01
+  0.34260E-08  0.39989E-08  0.38095E-08  0.14915E-08  0.43613E-08  0.18047E-07
+  0.49170E-07  0.12204E-06  0.30675E-06  0.64959E-06  0.15849E-05  0.52401E-05
+  0.46190E-04  0.20547E-03  0.57903E-03  0.14694E-02  0.38825E-02  0.90259E-02
+  0.18627E-01  0.32833E-01  0.55458E-01  0.84898E-01  0.12890E+00  0.19579E+00
+  0.28923E+00  0.41912E+00  0.60474E+00  0.86524E+00  0.13131E+01  0.17737E+01
+  0.26601E+01  0.37626E+01  0.53199E+01  0.66824E-08  0.75439E-08  0.77366E-08
+  0.66415E-08  0.00000E+00  0.17021E-07  0.55900E-07  0.14384E-06  0.45511E-06
+  0.11100E-05  0.35148E-05  0.12082E-04  0.82319E-04  0.31776E-03  0.80652E-03
+  0.21369E-02  0.48388E-02  0.11093E-01  0.25131E-01  0.44074E-01  0.74162E-01
+  0.11320E+00  0.17144E+00  0.25984E+00  0.38320E+00  0.55437E+00  0.79854E+00
+  0.11405E+01  0.17271E+01  0.23267E+01  0.34778E+01  0.49019E+01  0.69007E+01
+  0.31995E-07  0.43564E-07  0.62716E-07  0.75871E-07  0.96049E-07  0.10218E-06
+  0.78542E-07  0.89837E-08  0.21428E-06  0.11308E-05  0.55874E-05  0.26028E-04
+  0.11561E-03  0.42829E-03  0.10396E-02  0.25864E-02  0.60411E-02  0.12574E-01
+  0.29798E-01  0.58947E-01  0.98844E-01  0.15045E+00  0.22734E+00  0.34389E+00
+  0.50637E+00  0.73145E+00  0.10521E+01  0.15005E+01  0.22689E+01  0.30502E+01
+  0.45479E+01  0.63938E+01  0.89718E+01  0.66423E-07  0.88516E-07  0.12319E-06
+  0.17476E-06  0.26210E-06  0.27514E-06  0.39485E-06  0.25418E-06  0.25747E-07
+  0.63224E-06  0.64038E-05  0.45088E-04  0.16407E-03  0.53339E-03  0.12804E-02
+  0.30945E-02  0.69568E-02  0.14651E-01  0.32329E-01  0.70230E-01  0.13261E+00
+  0.20101E+00  0.30273E+00  0.45668E+00  0.67111E+00  0.96767E+00  0.13897E+01
+  0.19790E+01  0.29881E+01  0.40096E+01  0.59662E+01  0.83705E+01  0.11715E+02
+  0.19897E-06  0.27187E-06  0.32260E-06  0.44572E-06  0.66373E-06  0.11378E-05
+  0.15241E-05  0.20520E-05  0.14842E-05  0.46767E-06  0.17140E-05  0.39263E-04
+  0.18858E-03  0.59616E-03  0.14347E-02  0.34574E-02  0.77066E-02  0.15822E-01
+  0.35248E-01  0.73284E-01  0.15631E+00  0.26747E+00  0.40149E+00  0.60401E+00
+  0.88595E+00  0.12751E+01  0.18286E+01  0.26008E+01  0.39233E+01  0.52558E+01
+  0.78101E+01  0.10943E+02  0.15288E+02  0.31213E-06  0.38094E-06  0.44210E-06
+  0.80079E-06  0.15937E-05  0.23297E-05  0.53659E-05  0.91240E-05  0.99137E-05
+  0.59473E-05  0.57540E-06  0.34298E-04  0.21378E-03  0.70551E-03  0.16896E-02
+  0.39797E-02  0.85630E-02  0.17464E-01  0.37944E-01  0.79031E-01  0.16294E+00
+  0.32013E+00  0.54014E+00  0.80863E+00  0.11819E+01  0.16961E+01  0.24267E+01
+  0.34451E+01  0.51884E+01  0.69389E+01  0.10295E+02  0.14403E+02  0.20086E+02
+  0.60753E-06  0.87550E-06  0.14192E-05  0.26841E-05  0.52737E-05  0.93925E-05
+  0.15961E-04  0.25478E-04  0.38814E-04  0.34960E-04  0.48822E-05  0.52251E-04
+  0.23763E-03  0.81174E-03  0.20005E-02  0.47381E-02  0.96885E-02  0.19448E-01
+  0.41277E-01  0.84069E-01  0.17220E+00  0.33388E+00  0.65385E+00  0.10877E+01
+  0.15824E+01  0.22623E+01  0.32275E+01  0.45718E+01  0.68728E+01  0.91756E+01
+  0.13592E+02  0.18989E+02  0.26444E+02  0.34093E-05  0.73952E-05  0.12697E-04
+  0.20496E-04  0.42864E-04  0.72862E-04  0.11026E-03  0.13681E-03  0.15219E-03
+  0.15211E-03  0.10979E-03  0.00000E+00  0.25938E-03  0.99943E-03  0.22143E-02
+  0.53027E-02  0.11061E-01  0.21214E-01  0.44687E-01  0.89262E-01  0.17860E+00
+  0.34787E+00  0.67323E+00  0.13335E+01  0.21072E+01  0.30002E+01  0.42671E+01
+  0.60307E+01  0.90531E+01  0.12063E+02  0.17851E+02  0.24920E+02  0.34673E+02
+  0.23984E-04  0.30671E-04  0.62543E-04  0.10869E-03  0.16988E-03  0.22458E-03
+  0.28702E-03  0.33641E-03  0.37548E-03  0.38286E-03  0.33750E-03  0.18978E-03
+  0.17979E-03  0.10077E-02  0.42192E-02  0.61126E-02  0.12520E-01  0.23866E-01
+  0.48966E-01  0.96136E-01  0.18813E+00  0.36182E+00  0.70245E+00  0.13738E+01
+  0.26051E+01  0.39967E+01  0.56611E+01  0.79767E+01  0.11951E+02  0.15886E+02
+  0.23480E+02  0.32755E+02  0.45532E+02  0.10742E-03  0.13707E-03  0.17571E-03
+  0.24821E-03  0.35753E-03  0.50067E-03  0.61758E-03  0.72852E-03  0.79992E-03
+  0.82568E-03  0.76815E-03  0.58035E-03  0.68212E-04  0.10162E-02  0.31401E-02
+  0.17641E-01  0.14639E-01  0.27283E-01  0.54896E-01  0.10529E+00  0.20206E+00
+  0.38219E+00  0.73226E+00  0.14339E+01  0.26865E+01  0.50350E+01  0.75440E+01
+  0.10587E+02  0.15818E+02  0.20968E+02  0.30940E+02  0.43119E+02  0.59887E+02
+  0.46414E-03  0.59103E-03  0.75570E-03  0.96601E-03  0.12009E-02  0.14508E-02
+  0.17737E-02  0.20730E-02  0.23100E-02  0.24486E-02  0.24375E-02  0.22167E-02
+  0.16766E-02  0.30409E-03  0.21676E-02  0.72877E-02  0.39979E-01  0.29026E-01
+  0.58960E-01  0.11175E+00  0.21182E+00  0.39552E+00  0.74840E+00  0.14529E+01
+  0.27318E+01  0.50642E+01  0.94488E+01  0.13810E+02  0.20605E+02  0.27214E+02
+  0.40142E+02  0.55948E+02  0.77711E+02  0.14049E-02  0.17852E-02  0.22771E-02
+  0.29029E-02  0.37152E-02  0.45941E-02  0.51269E-02  0.58083E-02  0.65066E-02
+  0.69464E-02  0.71863E-02  0.71209E-02  0.64857E-02  0.50187E-02  0.21041E-02
+  0.38092E-02  0.12686E-01  0.66501E-01  0.59127E-01  0.11338E+00  0.21522E+00
+  0.39949E+00  0.74914E+00  0.14405E+01  0.26975E+01  0.50168E+01  0.92775E+01
+  0.17111E+02  0.26391E+02  0.34696E+02  0.51223E+02  0.71494E+02  0.99421E+02
+  0.33921E-02  0.43025E-02  0.54758E-02  0.69628E-02  0.88848E-02  0.11373E-01
+  0.14425E-01  0.15331E-01  0.16455E-01  0.17716E-01  0.18220E-01  0.18412E-01
+  0.17782E-01  0.16093E-01  0.12569E-01  0.55044E-02  0.44224E-02  0.19515E-01
+  0.13858E+00  0.11039E+00  0.21432E+00  0.39913E+00  0.74461E+00  0.14198E+01
+  0.26406E+01  0.48876E+01  0.90675E+01  0.16598E+02  0.33242E+02  0.43831E+02
+  0.64799E+02  0.90623E+02  0.12624E+03  0.67809E-02  0.85869E-02  0.10908E-01
+  0.13840E-01  0.17616E-01  0.22484E-01  0.28749E-01  0.36854E-01  0.39270E-01
+  0.40912E-01  0.42718E-01  0.43226E-01  0.42753E-01  0.40761E-01  0.36261E-01
+  0.27421E-01  0.15992E-01  0.00000E+00  0.38970E-01  0.20555E+00  0.20345E+00
+  0.38898E+00  0.72942E+00  0.13852E+01  0.25638E+01  0.47017E+01  0.87052E+01
+  0.15993E+02  0.31965E+02  0.54789E+02  0.81174E+02  0.11384E+03  0.15896E+03
+  0.11891E-01  0.15037E-01  0.19073E-01  0.24155E-01  0.30677E-01  0.39055E-01
+  0.49789E-01  0.63611E-01  0.81298E-01  0.88991E-01  0.90568E-01  0.91865E-01
+  0.90664E-01  0.86741E-01  0.80139E-01  0.67551E-01  0.52621E-01  0.33697E-01
+  0.13581E-01  0.77850E-01  0.19341E+00  0.38831E+00  0.73628E+00  0.13925E+01
+  0.25587E+01  0.46331E+01  0.84899E+01  0.15566E+02  0.31303E+02  0.53105E+02
+  0.10285E+03  0.14445E+03  0.20198E+03  0.18837E-01  0.23792E-01  0.30131E-01
+  0.38102E-01  0.48301E-01  0.61364E-01  0.78038E-01  0.99429E-01  0.12668E+00
+  0.16153E+00  0.18297E+00  0.18424E+00  0.18328E+00  0.17729E+00  0.16625E+00
+  0.14673E+00  0.12531E+00  0.10076E+00  0.39280E-01  0.36082E-01  0.16738E+00
+  0.37945E+00  0.74456E+00  0.14138E+01  0.25854E+01  0.46161E+01  0.83551E+01
+  0.15170E+02  0.30647E+02  0.51669E+02  0.10242E+03  0.18365E+03  0.25700E+03
+  0.30850E-01  0.38915E-01  0.49221E-01  0.62155E-01  0.78680E-01  0.99796E-01
+  0.12669E+00  0.16110E+00  0.20483E+00  0.26063E+00  0.33019E+00  0.38833E+00
+  0.38632E+00  0.37911E+00  0.36402E+00  0.33371E+00  0.30294E+00  0.27157E+00
+  0.19091E+00  0.10416E+00  0.42306E-01  0.26702E+00  0.63719E+00  0.12937E+01
+  0.24292E+01  0.43301E+01  0.78023E+01  0.14103E+02  0.28662E+02  0.47954E+02
+  0.95984E+02  0.17256E+03  0.30966E+03  0.47877E-01  0.60310E-01  0.76190E-01
+  0.96096E-01  0.12148E+00  0.15386E+00  0.19501E+00  0.24755E+00  0.31415E+00
+  0.39893E+00  0.50447E+00  0.63777E+00  0.77175E+00  0.75725E+00  0.73444E+00
+  0.68968E+00  0.63973E+00  0.59258E+00  0.47509E+00  0.36282E+00  0.18305E+00
+  0.74216E-01  0.47252E+00  0.11457E+01  0.22860E+01  0.41069E+01  0.73927E+01
+  0.13310E+02  0.27238E+02  0.44716E+02  0.90665E+02  0.16438E+03  0.29502E+03
+  0.75169E-01  0.94554E-01  0.11929E+00  0.15027E+00  0.18974E+00  0.24002E+00
+  0.30381E+00  0.38514E+00  0.48807E+00  0.61891E+00  0.78171E+00  0.98753E+00
+  0.12385E+01  0.15414E+01  0.14996E+01  0.14304E+01  0.13606E+01  0.12865E+01
+  0.11084E+01  0.95677E+00  0.72828E+00  0.42805E+00  0.00000E+00  0.67733E+00
+  0.17978E+01  0.34661E+01  0.64445E+01  0.11783E+02  0.24803E+02  0.39792E+02
+  0.81824E+02  0.15110E+03  0.27477E+03  0.11238E+00  0.14112E+00  0.17778E+00
+  0.22364E+00  0.28203E+00  0.35632E+00  0.45049E+00  0.57038E+00  0.72185E+00
+  0.91408E+00  0.11530E+01  0.14548E+01  0.18235E+01  0.22765E+01  0.28158E+01
+  0.27692E+01  0.26543E+01  0.25475E+01  0.22516E+01  0.20136E+01  0.16795E+01
+  0.12769E+01  0.75518E+00  0.00000E+00  0.11944E+01  0.28113E+01  0.56379E+01
+  0.10645E+02  0.23303E+02  0.36377E+02  0.75914E+02  0.14155E+03  0.26030E+03
+  0.15819E+00  0.19823E+00  0.24928E+00  0.31311E+00  0.39431E+00  0.49755E+00
+  0.62827E+00  0.79444E+00  0.10040E+01  0.12696E+01  0.15989E+01  0.20141E+01
+  0.25203E+01  0.31413E+01  0.38789E+01  0.48168E+01  0.47590E+01  0.45632E+01
+  0.40797E+01  0.36541E+01  0.30914E+01  0.24534E+01  0.16874E+01  0.67209E+00
+  0.82494E+00  0.26611E+01  0.57347E+01  0.11016E+02  0.24483E+02  0.37029E+02
+  0.77055E+02  0.14318E+03  0.26188E+03  0.21724E+00  0.27153E+00  0.34070E+00
+  0.42717E+00  0.53711E+00  0.67678E+00  0.85345E+00  0.10778E+01  0.13605E+01
+  0.17179E+01  0.21604E+01  0.27169E+01  0.33935E+01  0.42211E+01  0.51999E+01
+  0.64382E+01  0.79551E+01  0.78928E+01  0.70472E+01  0.63327E+01  0.53403E+01
+  0.42568E+01  0.30222E+01  0.14972E+01  0.59136E+00  0.29329E+01  0.66329E+01
+  0.12712E+02  0.28035E+02  0.40921E+02  0.83639E+02  0.15321E+03  0.27635E+03
+  0.29561E+00  0.36828E+00  0.46085E+00  0.57652E+00  0.72353E+00  0.91019E+00
+  0.11461E+01  0.14455E+01  0.18222E+01  0.22980E+01  0.28859E+01  0.36239E+01
+  0.45190E+01  0.56099E+01  0.68951E+01  0.85113E+01  0.10475E+02  0.13032E+02
+  0.11992E+02  0.10729E+02  0.90577E+01  0.71744E+01  0.51027E+01  0.26749E+01
+  0.43877E+00  0.36704E+01  0.84651E+01  0.15938E+02  0.34322E+02  0.48201E+02
+  0.95717E+02  0.17147E+03  0.30296E+03  0.40411E+00  0.50142E+00  0.62533E+00
+  0.78013E+00  0.97674E+00  0.12264E+01  0.15417E+01  0.19415E+01  0.24442E+01
+  0.30786E+01  0.38615E+01  0.48426E+01  0.60303E+01  0.74750E+01  0.91719E+01
+  0.11297E+02  0.13865E+02  0.17181E+02  0.19810E+02  0.18307E+02  0.15436E+02
+  0.12287E+02  0.87676E+01  0.48071E+01  0.00000E+00  0.46583E+01  0.11150E+02
+  0.20719E+02  0.43633E+02  0.58851E+02  0.11323E+03  0.19774E+03  0.34100E+03
+  0.54895E+00  0.67763E+00  0.84146E+00  0.10461E+01  0.13060E+01  0.16358E+01
+  0.20522E+01  0.25798E+01  0.32430E+01  0.40788E+01  0.51092E+01  0.63989E+01
+  0.79569E+01  0.98464E+01  0.12058E+02  0.14814E+02  0.18121E+02  0.22359E+02
+  0.25641E+02  0.30012E+02  0.25671E+02  0.20284E+02  0.14379E+02  0.77291E+01
+  0.00000E+00  0.71138E+01  0.16475E+02  0.29520E+02  0.59664E+02  0.77268E+02
+  0.14252E+03  0.24076E+03  0.40248E+03  0.76064E+00  0.93294E+00  0.11523E+01
+  0.14263E+01  0.17741E+01  0.22153E+01  0.27723E+01  0.34779E+01  0.43644E+01
+  0.54810E+01  0.68567E+01  0.85770E+01  0.10654E+02  0.13171E+02  0.16114E+02
+  0.19776E+02  0.24159E+02  0.29753E+02  0.34081E+02  0.39806E+02  0.43629E+02
+  0.35135E+02  0.25224E+02  0.14240E+02  0.16954E+01  0.92997E+01  0.23020E+02
+  0.41136E+02  0.81806E+02  0.10185E+03  0.18168E+03  0.29798E+03  0.48334E+03
+  0.10509E+01  0.12788E+01  0.15690E+01  0.19313E+01  0.23912E+01  0.29746E+01
+  0.37109E+01  0.46432E+01  0.58138E+01  0.72878E+01  0.91024E+01  0.11370E+02
+  0.14104E+02  0.17412E+02  0.21270E+02  0.26057E+02  0.31766E+02  0.39015E+02
+  0.44543E+02  0.51792E+02  0.56449E+02  0.58028E+02  0.41921E+02  0.23514E+02
+  0.27753E+01  0.14924E+02  0.36056E+02  0.62630E+02  0.12034E+03  0.14442E+03
+  0.24718E+03  0.39136E+03  0.61285E+03  0.14683E+01  0.17698E+01  0.21536E+01
+  0.26328E+01  0.32410E+01  0.40124E+01  0.49858E+01  0.62181E+01  0.77647E+01
+  0.97114E+01  0.12107E+02  0.15097E+02  0.18699E+02  0.23053E+02  0.28122E+02
+  0.34395E+02  0.41856E+02  0.51295E+02  0.58409E+02  0.67676E+02  0.73437E+02
+  0.75072E+02  0.69987E+02  0.39028E+02  0.45828E+01  0.24400E+02  0.57780E+02
+  0.97987E+02  0.18272E+03  0.21213E+03  0.34930E+03  0.53445E+03  0.80783E+03
+  0.20792E+01  0.24781E+01  0.29859E+01  0.36198E+01  0.44244E+01  0.54445E+01
+  0.67314E+01  0.83607E+01  0.10405E+02  0.12977E+02  0.16140E+02  0.20087E+02
+  0.24838E+02  0.30572E+02  0.37242E+02  0.45480E+02  0.55256E+02  0.67591E+02
+  0.76799E+02  0.88734E+02  0.95954E+02  0.97665E+02  0.90523E+02  0.65592E+02
+  0.76040E+01  0.40300E+02  0.94375E+02  0.15690E+03  0.28524E+03  0.32172E+03
+  0.51155E+03  0.75806E+03  0.11072E+04  0.35418E-09  0.12377E-09  0.52181E-09
+  0.20007E-08  0.46308E-08  0.99602E-08  0.23154E-07  0.36763E-07  0.73749E-07
+  0.16769E-06  0.33926E-06  0.71177E-06  0.39124E-05  0.32366E-04  0.64044E-04
+  0.48220E-03  0.15824E-02  0.35246E-02  0.73586E-02  0.13100E-01  0.22297E-01
+  0.34351E-01  0.52460E-01  0.80127E-01  0.11900E+00  0.17349E+00  0.25210E+00
+  0.36373E+00  0.55810E+00  0.76404E+00  0.11665E+01  0.16808E+01  0.24308E+01
+  0.73808E-09  0.52746E-09  0.19698E-09  0.18958E-08  0.56808E-08  0.12563E-07
+  0.26104E-07  0.53301E-07  0.10027E-06  0.20925E-06  0.43474E-06  0.93133E-06
+  0.64767E-05  0.58670E-04  0.95009E-04  0.61591E-03  0.20151E-02  0.44757E-02
+  0.93245E-02  0.16568E-01  0.28155E-01  0.43321E-01  0.66068E-01  0.10077E+00
+  0.14943E+00  0.21747E+00  0.31529E+00  0.45367E+00  0.69359E+00  0.94526E+00
+  0.14347E+01  0.20547E+01  0.29498E+01  0.13055E-08  0.11265E-08  0.36254E-09
+  0.17183E-08  0.61320E-08  0.16272E-07  0.33760E-07  0.73505E-07  0.13827E-06
+  0.27280E-06  0.62299E-06  0.12313E-05  0.12307E-04  0.93632E-04  0.22123E-03
+  0.79005E-03  0.25744E-02  0.56979E-02  0.11838E-01  0.20988E-01  0.35601E-01
+  0.54695E-01  0.83296E-01  0.12686E+00  0.18788E+00  0.27298E+00  0.39503E+00
+  0.56710E+00  0.86443E+00  0.11738E+01  0.17728E+01  0.25258E+01  0.36038E+01
+  0.23357E-08  0.26117E-08  0.19432E-08  0.19245E-09  0.55684E-08  0.17299E-07
+  0.43160E-07  0.95433E-07  0.23203E-06  0.39726E-06  0.10201E-05  0.26543E-05
+  0.27149E-04  0.14231E-03  0.38869E-03  0.11070E-02  0.33003E-02  0.72730E-02
+  0.15062E-01  0.26628E-01  0.45076E-01  0.69129E-01  0.10512E+00  0.15987E+00
+  0.23645E+00  0.34306E+00  0.49563E+00  0.71017E+00  0.10798E+01  0.14617E+01
+  0.21988E+01  0.31196E+01  0.44280E+01  0.37935E-08  0.43267E-08  0.43559E-08
+  0.21375E-08  0.38467E-08  0.18607E-07  0.49175E-07  0.12690E-06  0.32167E-06
+  0.70383E-06  0.16510E-05  0.57348E-05  0.49705E-04  0.21620E-03  0.59906E-03
+  0.15303E-02  0.39683E-02  0.93174E-02  0.19218E-01  0.33859E-01  0.57171E-01
+  0.87499E-01  0.13282E+00  0.20169E+00  0.29789E+00  0.43161E+00  0.62265E+00
+  0.89070E+00  0.13515E+01  0.18249E+01  0.27358E+01  0.38681E+01  0.54664E+01
+  0.75686E-08  0.79355E-08  0.87413E-08  0.79793E-08  0.18892E-08  0.14810E-07
+  0.51615E-07  0.13611E-06  0.43120E-06  0.10545E-05  0.32671E-05  0.11328E-04
+  0.79784E-04  0.30873E-03  0.78674E-03  0.20953E-02  0.47579E-02  0.10992E-01
+  0.24597E-01  0.43156E-01  0.72643E-01  0.11091E+00  0.16801E+00  0.25469E+00
+  0.37564E+00  0.54353E+00  0.78301E+00  0.11184E+01  0.16940E+01  0.22825E+01
+  0.34125E+01  0.48109E+01  0.67748E+01  0.37068E-07  0.55200E-07  0.72040E-07
+  0.90527E-07  0.11650E-06  0.12590E-06  0.11020E-06  0.53864E-07  0.11080E-06
+  0.89162E-06  0.48859E-05  0.20604E-04  0.10435E-03  0.39987E-03  0.98287E-03
+  0.24642E-02  0.57806E-02  0.12182E-01  0.29287E-01  0.55635E-01  0.93422E-01
+  0.14235E+00  0.21528E+00  0.32587E+00  0.48010E+00  0.69383E+00  0.99839E+00
+  0.14244E+01  0.21547E+01  0.28977E+01  0.43229E+01  0.60807E+01  0.85380E+01
+  0.70767E-07  0.96614E-07  0.13424E-06  0.20228E-06  0.28341E-06  0.33651E-06
+  0.40456E-06  0.29224E-06  0.10048E-06  0.49016E-06  0.56312E-05  0.40908E-04
+  0.14825E-03  0.50514E-03  0.12241E-02  0.29880E-02  0.67383E-02  0.14243E-01
+  0.31725E-01  0.69460E-01  0.12613E+00  0.19142E+00  0.28855E+00  0.43560E+00
+  0.64050E+00  0.92395E+00  0.13274E+01  0.18910E+01  0.28561E+01  0.38336E+01
+  0.57067E+01  0.80097E+01  0.11215E+02  0.20190E-06  0.27044E-06  0.32487E-06
+  0.46431E-06  0.70256E-06  0.11667E-05  0.14242E-05  0.20297E-05  0.14302E-05
+  0.50809E-06  0.11606E-05  0.35608E-04  0.17601E-03  0.56771E-03  0.13852E-02
+  0.33637E-02  0.75367E-02  0.15504E-01  0.34674E-01  0.72416E-01  0.15516E+00
+  0.25637E+00  0.38521E+00  0.57998E+00  0.85120E+00  0.12257E+01  0.17583E+01
+  0.25017E+01  0.37751E+01  0.50582E+01  0.75190E+01  0.10538E+02  0.14727E+02
+  0.33354E-06  0.41118E-06  0.50020E-06  0.86722E-06  0.16481E-05  0.23215E-05
+  0.55699E-05  0.86320E-05  0.98810E-05  0.65655E-05  0.48969E-06  0.28611E-04
+  0.19754E-03  0.66667E-03  0.16183E-02  0.38473E-02  0.83743E-02  0.17133E-01
+  0.37341E-01  0.77876E-01  0.16134E+00  0.31759E+00  0.52084E+00  0.78052E+00
+  0.11416E+01  0.16392E+01  0.23464E+01  0.33324E+01  0.50208E+01  0.67163E+01
+  0.99676E+01  0.13949E+02  0.19460E+02  0.60384E-06  0.80947E-06  0.12204E-05
+  0.20183E-05  0.44601E-05  0.86027E-05  0.17453E-04  0.30646E-04  0.52398E-04
+  0.53863E-04  0.27169E-04  0.24231E-04  0.19154E-03  0.72665E-03  0.18582E-02
+  0.44987E-02  0.92576E-02  0.18832E-01  0.40310E-01  0.82463E-01  0.16940E+00
+  0.32940E+00  0.64651E+00  0.10526E+01  0.15331E+01  0.21937E+01  0.31317E+01
+  0.44387E+01  0.66773E+01  0.89161E+01  0.13214E+02  0.18471E+02  0.25732E+02
+  0.29174E-06  0.65253E-06  0.10910E-05  0.17680E-05  0.35306E-05  0.46794E-05
+  0.31453E-05  0.52383E-05  0.25081E-04  0.67305E-04  0.14709E-03  0.29003E-03
+  0.62017E-03  0.14475E-02  0.28926E-02  0.62956E-02  0.12545E-01  0.23395E-01
+  0.48090E-01  0.94859E-01  0.18803E+00  0.36327E+00  0.69950E+00  0.13802E+01
+  0.21382E+01  0.30384E+01  0.43140E+01  0.60873E+01  0.91146E+01  0.12146E+02
+  0.17939E+02  0.25004E+02  0.34739E+02  0.30757E-04  0.39367E-04  0.79862E-04
+  0.13672E-03  0.21248E-03  0.28020E-03  0.35886E-03  0.42511E-03  0.48303E-03
+  0.51141E-03  0.49113E-03  0.37424E-03  0.44307E-04  0.71367E-03  0.33269E-02
+  0.55418E-02  0.11699E-01  0.22647E-01  0.47105E-01  0.93180E-01  0.18340E+00
+  0.35415E+00  0.68927E+00  0.13514E+01  0.25677E+01  0.39054E+01  0.55374E+01
+  0.78092E+01  0.11714E+02  0.15574E+02  0.23038E+02  0.32161E+02  0.44735E+02
+  0.14841E-03  0.18950E-03  0.24320E-03  0.34580E-03  0.50062E-03  0.70521E-03
+  0.87478E-03  0.10453E-02  0.11708E-02  0.12534E-02  0.12572E-02  0.11550E-02
+  0.74662E-03  0.20231E-03  0.20881E-02  0.13801E-01  0.12773E-01  0.24626E-01
+  0.51009E-01  0.99283E-01  0.19263E+00  0.36713E+00  0.70730E+00  0.13906E+01
+  0.26142E+01  0.49100E+01  0.73459E+01  0.10325E+02  0.15463E+02  0.20497E+02
+  0.30298E+02  0.42284E+02  0.58796E+02  0.52790E-03  0.67227E-03  0.85978E-03
+  0.10994E-02  0.13680E-02  0.16513E-02  0.20188E-02  0.23669E-02  0.26469E-02
+  0.28279E-02  0.28558E-02  0.26760E-02  0.22133E-02  0.91708E-03  0.14521E-02
+  0.64001E-02  0.38641E-01  0.27493E-01  0.56831E-01  0.10858E+00  0.20699E+00
+  0.38795E+00  0.73602E+00  0.14316E+01  0.26966E+01  0.50031E+01  0.93419E+01
+  0.13709E+02  0.20477E+02  0.27045E+02  0.39925E+02  0.55687E+02  0.77396E+02
+  0.11937E-03  0.15025E-03  0.18866E-03  0.23457E-03  0.28851E-03  0.33507E-03
+  0.33056E-03  0.29345E-03  0.18448E-03  0.59944E-04  0.52736E-03  0.13762E-02
+  0.29780E-02  0.59293E-02  0.10564E-01  0.19164E-01  0.31923E-01  0.14623E+00
+  0.93439E-01  0.16274E+00  0.28807E+00  0.50999E+00  0.92411E+00  0.17313E+01
+  0.31769E+01  0.58372E+01  0.10676E+02  0.19505E+02  0.29957E+02  0.39377E+02
+  0.57531E+02  0.79605E+02  0.10989E+03  0.25591E-02  0.32447E-02  0.41278E-02
+  0.52449E-02  0.66858E-02  0.85446E-02  0.10934E-01  0.11583E-01  0.12324E-01
+  0.13150E-01  0.13285E-01  0.13044E-01  0.11853E-01  0.93462E-02  0.48354E-02
+  0.37576E-02  0.15816E-01  0.34104E-01  0.22955E+00  0.13744E+00  0.25306E+00
+  0.45616E+00  0.83218E+00  0.15610E+01  0.28677E+01  0.52670E+01  0.97176E+01
+  0.17687E+02  0.35146E+02  0.47098E+02  0.69248E+02  0.96412E+02  0.13380E+03
+  0.40327E-04  0.47337E-04  0.52375E-04  0.51122E-04  0.35032E-04  0.17928E-04
+  0.14959E-03  0.46029E-03  0.96298E-03  0.17781E-02  0.31993E-02  0.55546E-02
+  0.97297E-02  0.16801E-01  0.27198E-01  0.44991E-01  0.68870E-01  0.10342E+00
+  0.16929E+00  0.76599E+00  0.44067E+00  0.72520E+00  0.12294E+01  0.21703E+01
+  0.38010E+01  0.67383E+01  0.12125E+02  0.21769E+02  0.41963E+02  0.72034E+02
+  0.10617E+03  0.14575E+03  0.19991E+03  0.81170E-02  0.10261E-01  0.13009E-01
+  0.16464E-01  0.20890E-01  0.26557E-01  0.33781E-01  0.43009E-01  0.54673E-01
+  0.61069E-01  0.61172E-01  0.60473E-01  0.57221E-01  0.50509E-01  0.40189E-01
+  0.22173E-01  0.00000E+00  0.29305E-01  0.91775E-01  0.17896E+00  0.32828E+00
+  0.57376E+00  0.10031E+01  0.17972E+01  0.31776E+01  0.56219E+01  0.10108E+02
+  0.18243E+02  0.35960E+02  0.60906E+02  0.11932E+03  0.16607E+03  0.22991E+03
+  0.12865E-01  0.16242E-01  0.20563E-01  0.25986E-01  0.32915E-01  0.41763E-01
+  0.53014E-01  0.67345E-01  0.85417E-01  0.10814E+00  0.12559E+00  0.12406E+00
+  0.11926E+00  0.10884E+00  0.92065E-01  0.63944E-01  0.31314E-01  0.88841E-02
+  0.93121E-01  0.20175E+00  0.38089E+00  0.66302E+00  0.11382E+01  0.19898E+01
+  0.34395E+01  0.59411E+01  0.10469E+02  0.18597E+02  0.36472E+02  0.61500E+02
+  0.11938E+03  0.21066E+03  0.30173E+03  0.28904E-01  0.36399E-01  0.45963E-01
+  0.57941E-01  0.73191E-01  0.92598E-01  0.11717E+00  0.14834E+00  0.18748E+00
+  0.23654E+00  0.29604E+00  0.36799E+00  0.44774E+00  0.41792E+00  0.37449E+00
+  0.30236E+00  0.22073E+00  0.13042E+00  0.47986E-01  0.24642E+00  0.54564E+00
+  0.97141E+00  0.16243E+01  0.27034E+01  0.44397E+01  0.72366E+01  0.12110E+02
+  0.20600E+02  0.39123E+02  0.64049E+02  0.12368E+03  0.21652E+03  0.37722E+03
+  0.48485E-01  0.60947E-01  0.76838E-01  0.96717E-01  0.12200E+00  0.15415E+00
+  0.19479E+00  0.24629E+00  0.31093E+00  0.39200E+00  0.49060E+00  0.61084E+00
+  0.74727E+00  0.89523E+00  0.89652E+00  0.76458E+00  0.62624E+00  0.46906E+00
+  0.16838E+00  0.13964E+00  0.57902E+00  0.11629E+01  0.19996E+01  0.32999E+01
+  0.53062E+01  0.83581E+01  0.13522E+02  0.22310E+02  0.41422E+02  0.65864E+02
+  0.12523E+03  0.21840E+03  0.38206E+03  0.79559E-01  0.99782E-01  0.12556E+00
+  0.15778E+00  0.19874E+00  0.25075E+00  0.31648E+00  0.39969E+00  0.50409E+00
+  0.63505E+00  0.79471E+00  0.99045E+00  0.12160E+01  0.14685E+01  0.17298E+01
+  0.18184E+01  0.15588E+01  0.12925E+01  0.76074E+00  0.24605E+00  0.45022E+00
+  0.13149E+01  0.24675E+01  0.41370E+01  0.65868E+01  0.10058E+02  0.15724E+02
+  0.25090E+02  0.45373E+02  0.69623E+02  0.12972E+03  0.22331E+03  0.38654E+03
+  0.12606E+00  0.15766E+00  0.19790E+00  0.24819E+00  0.31207E+00  0.39314E+00
+  0.49549E+00  0.62505E+00  0.78744E+00  0.99119E+00  0.12398E+01  0.15455E+01
+  0.19009E+01  0.23052E+01  0.27363E+01  0.31792E+01  0.35580E+01  0.30480E+01
+  0.20968E+01  0.11898E+01  0.00000E+00  0.13931E+01  0.31264E+01  0.54597E+01
+  0.86922E+01  0.12912E+02  0.19501E+02  0.30006E+02  0.52577E+02  0.77387E+02
+  0.14030E+03  0.23704E+03  0.40356E+03  0.19506E+00  0.24301E+00  0.30408E+00
+  0.38035E+00  0.47721E+00  0.60007E+00  0.75511E+00  0.95124E+00  0.11970E+01
+  0.15053E+01  0.18815E+01  0.23449E+01  0.28863E+01  0.35085E+01  0.41826E+01
+  0.49039E+01  0.56624E+01  0.64950E+01  0.49207E+01  0.32802E+01  0.11612E+01
+  0.12400E+01  0.40579E+01  0.75997E+01  0.12221E+02  0.17742E+02  0.25934E+02
+  0.38440E+02  0.65000E+02  0.91330E+02  0.15997E+03  0.26357E+03  0.43862E+03
+  0.29164E+00  0.36150E+00  0.45043E+00  0.56149E+00  0.70246E+00  0.88121E+00
+  0.11067E+01  0.13917E+01  0.17487E+01  0.21961E+01  0.27420E+01  0.34141E+01
+  0.42000E+01  0.51053E+01  0.60900E+01  0.71562E+01  0.82885E+01  0.95482E+01
+  0.93178E+01  0.71088E+01  0.32025E+01  0.11333E+01  0.60449E+01  0.11880E+02
+  0.19080E+02  0.26988E+02  0.38090E+02  0.54224E+02  0.87852E+02  0.11753E+03
+  0.19705E+03  0.31400E+03  0.50661E+03  0.44727E+00  0.55068E+00  0.68239E+00
+  0.84675E+00  0.10554E+01  0.13199E+01  0.16534E+01  0.20750E+01  0.26028E+01
+  0.32644E+01  0.40721E+01  0.50675E+01  0.62356E+01  0.75890E+01  0.90756E+01
+  0.10720E+02  0.12501E+02  0.14531E+02  0.14598E+02  0.14184E+02  0.89499E+01
+  0.10421E+01  0.77593E+01  0.17748E+02  0.29472E+02  0.41324E+02  0.57034E+02
+  0.78701E+02  0.12319E+03  0.15692E+03  0.25211E+03  0.38802E+03  0.60519E+03
+  0.66980E+00  0.81755E+00  0.10056E+01  0.12404E+01  0.15383E+01  0.19159E+01
+  0.23919E+01  0.29933E+01  0.37461E+01  0.46892E+01  0.58400E+01  0.72578E+01
+  0.89215E+01  0.10850E+02  0.12970E+02  0.15322E+02  0.17872E+02  0.20784E+02
+  0.20997E+02  0.20611E+02  0.15535E+02  0.38949E+01  0.12235E+02  0.30424E+02
+  0.50755E+02  0.69954E+02  0.94080E+02  0.12565E+03  0.18920E+03  0.23009E+03
+  0.35236E+03  0.52081E+03  0.78021E+03  0.10355E+01  0.12501E+01  0.15232E+01
+  0.18641E+01  0.22966E+01  0.28447E+01  0.35355E+01  0.44085E+01  0.55009E+01
+  0.68696E+01  0.85405E+01  0.10600E+02  0.13022E+02  0.15840E+02  0.18953E+02
+  0.22450E+02  0.26280E+02  0.30708E+02  0.31482E+02  0.31648E+02  0.25616E+02
+  0.11531E+02  0.15282E+02  0.48017E+02  0.84772E+02  0.11733E+03  0.15589E+03
+  0.20384E+03  0.29890E+03  0.34873E+03  0.51245E+03  0.72975E+03  0.10509E+04
+  0.16040E+01  0.19104E+01  0.23002E+01  0.27868E+01  0.34042E+01  0.41863E+01
+  0.51720E+01  0.64174E+01  0.79759E+01  0.99278E+01  0.12310E+02  0.15248E+02
+  0.18703E+02  0.22728E+02  0.27183E+02  0.32206E+02  0.37731E+02  0.44139E+02
+  0.45505E+02  0.46157E+02  0.38384E+02  0.19830E+02  0.16213E+02  0.82593E+02
+  0.14875E+03  0.20728E+03  0.27362E+03  0.35096E+03  0.50189E+03  0.56522E+03
+  0.79870E+03  0.10966E+04  0.15177E+04  0.25417E+01  0.29790E+01  0.35355E+01
+  0.42300E+01  0.51110E+01  0.62271E+01  0.76335E+01  0.94103E+01  0.11633E+02
+  0.14417E+02  0.17816E+02  0.22006E+02  0.26938E+02  0.32688E+02  0.39068E+02
+  0.46294E+02  0.54274E+02  0.63572E+02  0.65904E+02  0.67436E+02  0.57461E+02
+  0.32946E+02  0.14886E+02  0.10282E+03  0.25236E+03  0.36853E+03  0.48668E+03
+  0.62098E+03  0.87185E+03  0.95383E+03  0.13047E+04  0.17353E+04  0.23161E+04
+  0.41328E+01  0.47568E+01  0.55510E+01  0.65418E+01  0.77989E+01  0.93912E+01
+  0.11397E+02  0.13931E+02  0.17101E+02  0.21072E+02  0.25918E+02  0.31894E+02
+  0.38932E+02  0.47147E+02  0.56282E+02  0.66676E+02  0.78207E+02  0.91717E+02
+  0.95578E+02  0.98615E+02  0.85903E+02  0.53467E+02  0.10313E+02  0.12753E+03
+  0.32634E+03  0.60901E+03  0.87340E+03  0.11099E+04  0.15555E+04  0.16632E+04
+  0.22173E+04  0.28727E+04  0.37162E+04  0.69098E+01  0.78001E+01  0.89329E+01
+  0.10347E+02  0.12139E+02  0.14410E+02  0.17271E+02  0.20885E+02  0.25404E+02
+  0.31064E+02  0.37972E+02  0.46493E+02  0.56530E+02  0.68259E+02  0.81327E+02
+  0.96264E+02  0.11292E+03  0.13254E+03  0.13880E+03  0.14432E+03  0.12823E+03
+  0.85305E+02  0.00000E+00  0.15715E+03  0.42373E+03  0.79843E+03  0.13984E+04
+  0.20071E+04  0.27980E+04  0.29760E+04  0.38915E+04  0.49386E+04  0.62268E+04
+  0.00000E+00  0.28080E-09  0.97504E-09  0.27444E-08  0.45243E-08  0.11784E-07
+  0.16242E-07  0.31866E-07  0.64058E-07  0.14291E-06  0.29802E-06  0.61709E-06
+  0.27774E-05  0.25327E-04  0.56001E-04  0.42165E-03  0.13854E-02  0.30896E-02
+  0.64563E-02  0.11504E-01  0.19593E-01  0.30209E-01  0.46166E-01  0.70572E-01
+  0.10490E+00  0.15311E+00  0.22279E+00  0.32201E+00  0.49526E+00  0.67995E+00
+  0.10421E+01  0.15072E+01  0.21899E+01  0.28080E-09  0.00000E+00  0.73365E-09
+  0.24621E-08  0.68212E-08  0.11480E-07  0.28812E-07  0.42533E-07  0.84798E-07
+  0.19171E-06  0.38042E-06  0.80482E-06  0.49871E-05  0.43383E-04  0.71590E-04
+  0.53856E-03  0.17649E-02  0.39261E-02  0.81888E-02  0.14565E-01  0.24772E-01
+  0.38146E-01  0.58214E-01  0.88857E-01  0.13187E+00  0.19210E+00  0.27884E+00
+  0.40177E+00  0.61544E+00  0.84072E+00  0.12800E+01  0.18390E+01  0.26504E+01
+  0.97504E-09  0.73365E-09  0.00000E+00  0.18199E-08  0.60696E-08  0.17281E-07
+  0.28988E-07  0.64230E-07  0.11779E-06  0.22843E-06  0.49739E-06  0.10601E-05
+  0.79612E-05  0.73761E-04  0.14965E-03  0.69156E-03  0.22586E-02  0.50088E-02
+  0.10422E-01  0.18501E-01  0.31415E-01  0.48303E-01  0.73613E-01  0.11221E+00
+  0.16629E+00  0.24181E+00  0.35026E+00  0.50344E+00  0.76855E+00  0.10455E+01
+  0.15830E+01  0.22614E+01  0.32367E+01  0.27444E-08  0.24621E-08  0.18199E-08
+  0.00000E+00  0.44542E-08  0.15420E-07  0.41845E-07  0.79051E-07  0.16340E-06
+  0.32248E-06  0.74846E-06  0.14738E-05  0.18683E-04  0.11382E-03  0.29399E-03
+  0.92664E-03  0.28916E-02  0.63884E-02  0.13256E-01  0.23472E-01  0.39782E-01
+  0.61070E-01  0.92939E-01  0.14147E+00  0.20937E+00  0.30401E+00  0.43958E+00
+  0.63048E+00  0.95987E+00  0.13014E+01  0.19615E+01  0.27891E+01  0.39691E+01
+  0.45243E-08  0.68212E-08  0.60696E-08  0.44542E-08  0.00000E+00  0.11587E-07
+  0.39259E-07  0.95959E-07  0.25143E-06  0.47992E-06  0.13300E-05  0.38899E-05
+  0.36041E-04  0.17431E-03  0.48752E-03  0.12938E-02  0.36316E-02  0.81837E-02
+  0.16922E-01  0.29875E-01  0.50522E-01  0.77415E-01  0.11763E+00  0.17878E+00
+  0.26425E+00  0.38316E+00  0.55318E+00  0.79200E+00  0.12030E+01  0.16264E+01
+  0.24423E+01  0.34592E+01  0.48990E+01  0.11784E-07  0.11480E-07  0.17281E-07
+  0.15420E-07  0.11587E-07  0.00000E+00  0.29127E-07  0.11020E-06  0.26718E-06
+  0.78617E-06  0.20071E-05  0.77023E-05  0.64011E-04  0.26012E-03  0.68078E-03
+  0.17833E-02  0.43195E-02  0.10439E-01  0.21683E-01  0.38142E-01  0.64329E-01
+  0.98359E-01  0.14919E+00  0.22638E+00  0.33418E+00  0.48388E+00  0.69762E+00
+  0.99723E+00  0.15118E+01  0.20391E+01  0.30527E+01  0.43100E+01  0.60795E+01
+  0.16242E-07  0.28812E-07  0.28988E-07  0.41845E-07  0.39259E-07  0.29127E-07
+  0.00000E+00  0.79421E-07  0.37499E-06  0.93894E-06  0.43238E-05  0.15374E-04
+  0.91914E-04  0.35684E-03  0.89714E-03  0.22722E-02  0.52254E-02  0.11544E-01
+  0.27865E-01  0.48804E-01  0.82047E-01  0.12513E+00  0.18940E+00  0.28691E+00
+  0.42292E+00  0.61151E+00  0.88048E+00  0.12569E+01  0.19024E+01  0.25608E+01
+  0.38242E+01  0.53851E+01  0.75716E+01  0.31866E-07  0.42533E-07  0.64230E-07
+  0.79051E-07  0.95959E-07  0.11020E-06  0.79421E-07  0.00000E+00  0.23021E-06
+  0.12168E-05  0.58593E-05  0.31932E-04  0.12623E-03  0.45637E-03  0.10973E-02
+  0.27145E-02  0.62220E-02  0.12984E-01  0.30308E-01  0.62658E-01  0.10494E+00
+  0.15957E+00  0.24094E+00  0.36422E+00  0.53606E+00  0.77403E+00  0.11130E+01
+  0.15868E+01  0.23984E+01  0.32229E+01  0.48031E+01  0.67493E+01  0.94648E+01
+  0.64058E-07  0.84798E-07  0.11779E-06  0.16340E-06  0.25143E-06  0.26718E-06
+  0.37499E-06  0.23021E-06  0.00000E+00  0.68582E-06  0.66871E-05  0.46527E-04
+  0.16903E-03  0.54194E-03  0.12974E-02  0.31261E-02  0.70204E-02  0.14733E-01
+  0.32504E-01  0.70460E-01  0.13438E+00  0.20364E+00  0.30660E+00  0.46241E+00
+  0.67941E+00  0.97951E+00  0.14066E+01  0.20029E+01  0.30238E+01  0.40571E+01
+  0.60363E+01  0.84678E+01  0.11850E+02  0.14291E-06  0.19171E-06  0.22843E-06
+  0.32248E-06  0.47992E-06  0.78617E-06  0.93894E-06  0.12168E-05  0.68582E-06
+  0.00000E+00  0.40629E-05  0.49491E-04  0.20567E-03  0.61980E-03  0.14660E-02
+  0.34928E-02  0.77531E-02  0.15864E-01  0.35306E-01  0.73447E-01  0.15693E+00
+  0.26039E+00  0.39076E+00  0.58777E+00  0.86196E+00  0.12405E+01  0.17789E+01
+  0.25300E+01  0.38157E+01  0.51124E+01  0.75964E+01  0.10643E+02  0.14868E+02
+  0.29802E-06  0.38042E-06  0.49739E-06  0.74846E-06  0.13300E-05  0.20071E-05
+  0.43238E-05  0.58593E-05  0.66871E-05  0.40629E-05  0.00000E+00  0.31237E-04
+  0.19915E-03  0.65852E-03  0.15870E-02  0.37759E-02  0.82762E-02  0.16939E-01
+  0.36934E-01  0.76971E-01  0.16038E+00  0.31621E+00  0.49660E+00  0.74474E+00
+  0.10899E+01  0.15656E+01  0.22418E+01  0.31848E+01  0.47997E+01  0.64216E+01
+  0.95326E+01  0.13343E+02  0.18618E+02  0.61709E-06  0.80482E-06  0.10601E-05
+  0.14738E-05  0.38899E-05  0.77023E-05  0.15374E-04  0.31932E-04  0.46527E-04
+  0.49491E-04  0.31237E-04  0.00000E+00  0.13974E-03  0.61658E-03  0.16425E-02
+  0.40627E-02  0.85848E-02  0.17677E-01  0.38508E-01  0.79478E-01  0.16407E+00
+  0.32111E+00  0.63223E+00  0.94504E+00  0.13799E+01  0.19782E+01  0.28282E+01
+  0.40131E+01  0.60445E+01  0.80760E+01  0.11981E+02  0.16761E+02  0.23369E+02
+  0.27774E-05  0.49871E-05  0.79612E-05  0.18683E-04  0.36041E-04  0.64011E-04
+  0.91914E-04  0.12623E-03  0.16903E-03  0.20567E-03  0.19915E-03  0.13974E-03
+  0.00000E+00  0.44555E-03  0.15059E-02  0.41110E-02  0.91162E-02  0.18146E-01
+  0.39347E-01  0.80809E-01  0.16582E+00  0.32460E+00  0.63632E+00  0.11929E+01
+  0.17382E+01  0.24866E+01  0.35498E+01  0.50320E+01  0.75796E+01  0.10111E+02
+  0.14999E+02  0.20984E+02  0.29249E+02  0.25327E-04  0.43383E-04  0.73761E-04
+  0.11382E-03  0.17431E-03  0.26012E-03  0.35684E-03  0.45637E-03  0.54194E-03
+  0.61980E-03  0.65852E-03  0.61658E-03  0.44555E-03  0.00000E+00  0.10635E-02
+  0.36978E-02  0.87554E-02  0.18017E-01  0.39745E-01  0.81246E-01  0.16464E+00
+  0.32438E+00  0.63508E+00  0.12638E+01  0.21858E+01  0.31201E+01  0.44479E+01
+  0.63002E+01  0.94966E+01  0.12645E+02  0.18771E+02  0.26277E+02  0.36640E+02
+  0.56001E-04  0.71590E-04  0.14965E-03  0.29399E-03  0.48752E-03  0.68078E-03
+  0.89714E-03  0.10973E-02  0.12974E-02  0.14660E-02  0.15870E-02  0.16425E-02
+  0.15059E-02  0.10635E-02  0.00000E+00  0.27140E-02  0.76689E-02  0.16825E-01
+  0.38579E-01  0.79655E-01  0.16161E+00  0.31826E+00  0.62893E+00  0.12473E+01
+  0.23870E+01  0.38880E+01  0.55350E+01  0.78344E+01  0.11826E+02  0.15713E+02
+  0.23354E+02  0.32735E+02  0.45686E+02  0.42165E-03  0.53856E-03  0.69156E-03
+  0.92664E-03  0.12938E-02  0.17833E-02  0.22722E-02  0.27145E-02  0.31261E-02
+  0.34928E-02  0.37759E-02  0.40627E-02  0.41110E-02  0.36978E-02  0.27140E-02
+  0.00000E+00  0.47745E-02  0.13461E-01  0.35091E-01  0.74874E-01  0.15444E+00
+  0.30590E+00  0.60502E+00  0.12156E+01  0.23185E+01  0.43893E+01  0.69624E+01
+  0.98504E+01  0.14910E+02  0.19753E+02  0.29431E+02  0.41347E+02  0.57821E+02
+  0.13854E-02  0.17649E-02  0.22586E-02  0.28916E-02  0.36316E-02  0.43195E-02
+  0.52254E-02  0.62220E-02  0.70204E-02  0.77531E-02  0.82762E-02  0.85848E-02
+  0.91162E-02  0.87554E-02  0.76689E-02  0.47745E-02  0.00000E+00  0.83551E-02
+  0.30380E-01  0.69419E-01  0.14758E+00  0.29527E+00  0.58501E+00  0.11735E+01
+  0.22676E+01  0.42626E+01  0.80491E+01  0.12384E+02  0.18793E+02  0.24806E+02
+  0.37048E+02  0.52177E+02  0.73105E+02  0.30896E-02  0.39261E-02  0.50088E-02
+  0.63884E-02  0.81837E-02  0.10439E-01  0.11544E-01  0.12984E-01  0.14733E-01
+  0.15864E-01  0.16939E-01  0.17677E-01  0.18146E-01  0.18017E-01  0.16825E-01
+  0.13461E-01  0.83551E-02  0.00000E+00  0.23430E-01  0.62774E-01  0.14128E+00
+  0.28773E+00  0.57179E+00  0.11438E+01  0.22050E+01  0.41801E+01  0.78334E+01
+  0.14615E+02  0.24020E+02  0.31551E+02  0.47220E+02  0.66656E+02  0.93570E+02
+  0.64563E-02  0.81888E-02  0.10422E-01  0.13256E-01  0.16922E-01  0.21683E-01
+  0.27865E-01  0.30308E-01  0.32504E-01  0.35306E-01  0.36934E-01  0.38508E-01
+  0.39347E-01  0.39745E-01  0.38579E-01  0.35091E-01  0.30380E-01  0.23430E-01
+  0.00000E+00  0.36444E-01  0.11053E+00  0.24784E+00  0.51226E+00  0.10421E+01
+  0.20274E+01  0.38470E+01  0.73019E+01  0.13589E+02  0.27921E+02  0.38365E+02
+  0.57779E+02  0.82029E+02  0.11570E+03  0.11504E-01  0.14565E-01  0.18501E-01
+  0.23472E-01  0.29875E-01  0.38142E-01  0.48804E-01  0.62658E-01  0.70460E-01
+  0.73447E-01  0.76971E-01  0.79478E-01  0.80809E-01  0.81246E-01  0.79655E-01
+  0.74874E-01  0.69419E-01  0.62774E-01  0.36444E-01  0.00000E+00  0.74363E-01
+  0.20932E+00  0.46450E+00  0.96927E+00  0.19056E+01  0.36061E+01  0.68450E+01
+  0.12878E+02  0.26522E+02  0.45461E+02  0.72656E+02  0.10365E+03  0.14677E+03
+  0.19593E-01  0.24772E-01  0.31415E-01  0.39782E-01  0.50522E-01  0.64329E-01
+  0.82047E-01  0.10494E+00  0.13438E+00  0.15693E+00  0.16038E+00  0.16407E+00
+  0.16582E+00  0.16464E+00  0.16161E+00  0.15444E+00  0.14758E+00  0.14128E+00
+  0.11053E+00  0.74363E-01  0.00000E+00  0.13120E+00  0.37359E+00  0.84577E+00
+  0.17216E+01  0.32773E+01  0.62371E+01  0.11782E+02  0.24834E+02  0.41986E+02
+  0.85945E+02  0.12794E+03  0.18218E+03  0.30209E-01  0.38146E-01  0.48303E-01
+  0.61070E-01  0.77415E-01  0.98359E-01  0.12513E+00  0.15957E+00  0.20364E+00
+  0.26039E+00  0.31621E+00  0.32111E+00  0.32460E+00  0.32438E+00  0.31826E+00
+  0.30590E+00  0.29527E+00  0.28773E+00  0.24784E+00  0.20932E+00  0.13120E+00
+  0.00000E+00  0.23330E+00  0.67693E+00  0.14990E+01  0.29136E+01  0.56017E+01
+  0.10643E+02  0.22886E+02  0.38597E+02  0.79558E+02  0.14702E+03  0.22468E+03
+  0.46166E-01  0.58214E-01  0.73613E-01  0.92939E-01  0.11763E+00  0.14919E+00
+  0.18940E+00  0.24094E+00  0.30660E+00  0.39076E+00  0.49660E+00  0.63223E+00
+  0.63632E+00  0.63508E+00  0.62893E+00  0.60502E+00  0.58501E+00  0.57179E+00
+  0.51226E+00  0.46450E+00  0.37359E+00  0.23330E+00  0.00000E+00  0.42479E+00
+  0.12070E+01  0.24894E+01  0.49206E+01  0.94838E+01  0.20923E+02  0.34833E+02
+  0.73552E+02  0.13696E+03  0.25236E+03  0.70572E-01  0.88857E-01  0.11221E+00
+  0.14147E+00  0.17878E+00  0.22638E+00  0.28691E+00  0.36422E+00  0.46241E+00
+  0.58777E+00  0.74474E+00  0.94504E+00  0.11929E+01  0.12638E+01  0.12473E+01
+  0.12156E+01  0.11735E+01  0.11438E+01  0.10421E+01  0.96927E+00  0.84577E+00
+  0.67693E+00  0.42479E+00  0.00000E+00  0.76670E+00  0.19301E+01  0.41246E+01
+  0.82430E+01  0.19010E+02  0.30959E+02  0.67015E+02  0.12787E+03  0.23685E+03
+  0.10490E+00  0.13187E+00  0.16629E+00  0.20937E+00  0.26425E+00  0.33418E+00
+  0.42292E+00  0.53606E+00  0.67941E+00  0.86196E+00  0.10899E+01  0.13799E+01
+  0.17382E+01  0.21858E+01  0.23870E+01  0.23185E+01  0.22676E+01  0.22050E+01
+  0.20274E+01  0.19056E+01  0.17216E+01  0.14990E+01  0.12070E+01  0.76670E+00
+  0.00000E+00  0.10360E+01  0.29803E+01  0.66384E+01  0.16795E+02  0.26669E+02
+  0.59804E+02  0.11670E+03  0.22171E+03  0.15311E+00  0.19210E+00  0.24181E+00
+  0.30401E+00  0.38316E+00  0.48388E+00  0.61151E+00  0.77403E+00  0.97951E+00
+  0.12405E+01  0.15656E+01  0.19782E+01  0.24866E+01  0.31201E+01  0.38880E+01
+  0.43893E+01  0.42626E+01  0.41801E+01  0.38470E+01  0.36061E+01  0.32773E+01
+  0.29136E+01  0.24894E+01  0.19301E+01  0.10360E+01  0.00000E+00  0.18821E+01
+  0.53709E+01  0.15569E+02  0.23961E+02  0.55774E+02  0.11077E+03  0.21205E+03
+  0.22279E+00  0.27884E+00  0.35026E+00  0.43958E+00  0.55318E+00  0.69762E+00
+  0.88048E+00  0.11130E+01  0.14066E+01  0.17789E+01  0.22418E+01  0.28282E+01
+  0.35498E+01  0.44479E+01  0.55350E+01  0.69624E+01  0.80491E+01  0.78334E+01
+  0.73019E+01  0.68450E+01  0.62371E+01  0.56017E+01  0.49206E+01  0.41246E+01
+  0.29803E+01  0.18821E+01  0.00000E+00  0.33916E+01  0.13941E+02  0.20702E+02
+  0.51633E+02  0.10541E+03  0.20394E+03  0.32201E+00  0.40177E+00  0.50344E+00
+  0.63048E+00  0.79200E+00  0.99723E+00  0.12569E+01  0.15868E+01  0.20029E+01
+  0.25300E+01  0.31848E+01  0.40131E+01  0.50320E+01  0.63002E+01  0.78344E+01
+  0.98504E+01  0.12384E+02  0.14615E+02  0.13589E+02  0.12878E+02  0.11782E+02
+  0.10643E+02  0.94838E+01  0.82430E+01  0.66384E+01  0.53709E+01  0.33916E+01
+  0.00000E+00  0.11321E+02  0.16170E+02  0.46735E+02  0.10008E+03  0.19700E+03
+  0.49526E+00  0.61544E+00  0.76855E+00  0.95987E+00  0.12030E+01  0.15118E+01
+  0.19024E+01  0.23984E+01  0.30238E+01  0.38157E+01  0.47997E+01  0.60445E+01
+  0.75796E+01  0.94966E+01  0.11826E+02  0.14910E+02  0.18793E+02  0.24020E+02
+  0.27921E+02  0.26522E+02  0.24834E+02  0.22886E+02  0.20923E+02  0.19010E+02
+  0.16795E+02  0.15569E+02  0.13941E+02  0.11321E+02  0.00000E+00  0.00000E+00
+  0.27078E+02  0.76089E+02  0.16507E+03  0.67995E+00  0.84072E+00  0.10455E+01
+  0.13014E+01  0.16264E+01  0.20391E+01  0.25608E+01  0.32229E+01  0.40571E+01
+  0.51124E+01  0.64216E+01  0.80760E+01  0.10111E+02  0.12645E+02  0.15713E+02
+  0.19753E+02  0.24806E+02  0.31551E+02  0.38365E+02  0.45461E+02  0.41986E+02
+  0.38597E+02  0.34833E+02  0.30959E+02  0.26669E+02  0.23961E+02  0.20702E+02
+  0.16170E+02  0.00000E+00  0.00000E+00  0.33984E+02  0.92316E+02  0.19410E+03
+  0.10421E+01  0.12800E+01  0.15830E+01  0.19615E+01  0.24423E+01  0.30527E+01
+  0.38242E+01  0.48031E+01  0.60363E+01  0.75964E+01  0.95326E+01  0.11981E+02
+  0.14999E+02  0.18771E+02  0.23354E+02  0.29431E+02  0.37048E+02  0.47220E+02
+  0.57779E+02  0.72656E+02  0.85945E+02  0.79558E+02  0.73552E+02  0.67015E+02
+  0.59804E+02  0.55774E+02  0.51633E+02  0.46735E+02  0.27078E+02  0.33984E+02
+  0.00000E+00  0.58942E+02  0.15939E+03  0.15072E+01  0.18390E+01  0.22614E+01
+  0.27891E+01  0.34592E+01  0.43100E+01  0.53851E+01  0.67493E+01  0.84678E+01
+  0.10643E+02  0.13343E+02  0.16761E+02  0.20984E+02  0.26277E+02  0.32735E+02
+  0.41347E+02  0.52177E+02  0.66656E+02  0.82029E+02  0.10365E+03  0.12794E+03
+  0.14702E+03  0.13696E+03  0.12787E+03  0.11670E+03  0.11077E+03  0.10541E+03
+  0.10008E+03  0.76089E+02  0.92316E+02  0.58942E+02  0.00000E+00  0.97842E+02
+  0.21899E+01  0.26504E+01  0.32367E+01  0.39691E+01  0.48990E+01  0.60795E+01
+  0.75716E+01  0.94648E+01  0.11850E+02  0.14868E+02  0.18618E+02  0.23369E+02
+  0.29249E+02  0.36640E+02  0.45686E+02  0.57821E+02  0.73105E+02  0.93570E+02
+  0.11570E+03  0.14677E+03  0.18218E+03  0.22468E+03  0.25236E+03  0.23685E+03
+  0.22171E+03  0.21205E+03  0.20394E+03  0.19700E+03  0.16507E+03  0.19410E+03
+  0.15939E+03  0.97842E+02  0.00000E+00  0.50586E-09  0.22415E-09  0.41665E-09
+  0.20941E-08  0.62418E-08  0.11449E-07  0.27569E-07  0.44572E-07  0.88157E-07
+  0.19591E-06  0.39467E-06  0.83874E-06  0.53978E-05  0.47627E-04  0.74462E-04
+  0.56010E-03  0.18348E-02  0.40798E-02  0.85070E-02  0.15127E-01  0.25723E-01
+  0.39598E-01  0.60422E-01  0.92207E-01  0.13681E+00  0.19924E+00  0.28910E+00
+  0.41638E+00  0.63745E+00  0.87013E+00  0.13236E+01  0.18997E+01  0.27347E+01
+  0.14723E-08  0.13123E-08  0.57241E-09  0.99388E-09  0.50901E-08  0.15816E-07
+  0.28705E-07  0.64832E-07  0.12149E-06  0.23265E-06  0.52630E-06  0.10999E-05
+  0.84478E-05  0.78778E-04  0.16803E-03  0.71666E-03  0.23395E-02  0.51860E-02
+  0.10788E-01  0.19144E-01  0.32501E-01  0.49963E-01  0.76129E-01  0.11602E+00
+  0.17191E+00  0.24993E+00  0.36193E+00  0.52003E+00  0.79354E+00  0.10790E+01
+  0.16325E+01  0.23304E+01  0.33325E+01  0.35600E-08  0.36777E-08  0.32359E-08
+  0.13934E-08  0.24291E-08  0.13016E-07  0.39026E-07  0.78367E-07  0.17478E-06
+  0.33475E-06  0.78391E-06  0.17550E-05  0.20709E-04  0.12018E-03  0.31724E-03
+  0.97093E-03  0.29922E-02  0.66074E-02  0.13706E-01  0.24262E-01  0.41111E-01
+  0.63099E-01  0.96012E-01  0.14612E+00  0.21622E+00  0.31389E+00  0.45377E+00
+  0.65065E+00  0.99027E+00  0.13420E+01  0.20217E+01  0.28728E+01  0.40855E+01
+  0.60339E-08  0.87877E-08  0.89588E-08  0.78199E-08  0.32930E-08  0.67455E-08
+  0.33483E-07  0.92083E-07  0.24985E-06  0.51308E-06  0.14037E-05  0.42264E-05
+  0.38923E-04  0.18323E-03  0.51551E-03  0.13466E-02  0.37050E-02  0.84413E-02
+  0.17450E-01  0.30797E-01  0.52068E-01  0.79770E-01  0.12119E+00  0.18416E+00
+  0.27217E+00  0.39458E+00  0.56958E+00  0.81529E+00  0.12381E+01  0.16734E+01
+  0.25118E+01  0.35561E+01  0.50336E+01  0.16309E-07  0.15431E-07  0.22665E-07
+  0.22971E-07  0.20453E-07  0.86179E-08  0.16159E-07  0.92857E-07  0.25340E-06
+  0.78015E-06  0.21794E-05  0.81018E-05  0.67124E-04  0.26849E-03  0.69908E-03
+  0.18421E-02  0.43995E-02  0.10531E-01  0.22265E-01  0.39157E-01  0.66029E-01
+  0.10094E+00  0.15308E+00  0.23228E+00  0.34283E+00  0.49637E+00  0.71553E+00
+  0.10227E+01  0.15502E+01  0.20904E+01  0.31287E+01  0.44158E+01  0.62266E+01
+  0.21222E-07  0.38639E-07  0.38958E-07  0.55003E-07  0.58281E-07  0.51576E-07
+  0.21639E-07  0.44572E-07  0.31284E-06  0.87319E-06  0.43836E-05  0.16092E-04
+  0.93343E-04  0.36413E-03  0.91469E-03  0.22988E-02  0.53074E-02  0.11633E-01
+  0.28479E-01  0.49876E-01  0.83842E-01  0.12787E+00  0.19352E+00  0.29313E+00
+  0.43208E+00  0.62471E+00  0.89939E+00  0.12838E+01  0.19430E+01  0.26150E+01
+  0.39044E+01  0.54970E+01  0.77273E+01  0.41252E-07  0.55803E-07  0.84690E-07
+  0.10775E-06  0.13396E-06  0.16689E-06  0.14173E-06  0.54975E-07  0.12247E-06
+  0.10041E-05  0.54012E-05  0.32059E-04  0.12531E-03  0.45645E-03  0.11015E-02
+  0.27315E-02  0.62383E-02  0.13046E-01  0.30347E-01  0.63628E-01  0.10658E+00
+  0.16208E+00  0.24475E+00  0.37000E+00  0.54459E+00  0.78633E+00  0.11307E+01
+  0.16119E+01  0.24364E+01  0.32737E+01  0.48785E+01  0.68548E+01  0.96120E+01
+  0.82860E-07  0.10935E-06  0.15250E-06  0.20829E-06  0.33674E-06  0.37679E-06
+  0.55667E-06  0.40975E-06  0.13225E-06  0.36822E-06  0.55590E-05  0.42986E-04
+  0.16409E-03  0.53127E-03  0.12848E-02  0.31102E-02  0.70045E-02  0.14679E-01
+  0.32455E-01  0.70281E-01  0.13562E+00  0.20557E+00  0.30960E+00  0.46702E+00
+  0.68628E+00  0.98948E+00  0.14210E+01  0.20235E+01  0.30554E+01  0.40992E+01
+  0.60992E+01  0.85566E+01  0.11974E+02  0.18064E-06  0.24390E-06  0.29052E-06
+  0.41016E-06  0.61297E-06  0.10272E-05  0.12831E-05  0.17513E-05  0.11820E-05
+  0.30871E-06  0.23220E-05  0.41402E-04  0.18973E-03  0.59335E-03  0.14271E-02
+  0.34334E-02  0.76569E-02  0.15714E-01  0.35079E-01  0.73005E-01  0.15608E+00
+  0.26072E+00  0.39147E+00  0.58909E+00  0.86417E+00  0.12440E+01  0.17842E+01
+  0.25381E+01  0.38286E+01  0.51298E+01  0.76236E+01  0.10682E+02  0.14925E+02
+  0.37833E-06  0.48249E-06  0.63014E-06  0.95902E-06  0.17181E-05  0.25999E-05
+  0.57356E-05  0.80444E-05  0.97674E-05  0.70915E-05  0.17944E-05  0.17054E-04
+  0.16502E-03  0.60053E-03  0.15019E-02  0.36462E-02  0.80656E-02  0.16599E-01
+  0.36382E-01  0.76035E-01  0.15874E+00  0.31342E+00  0.49376E+00  0.74113E+00
+  0.10853E+01  0.15598E+01  0.22342E+01  0.31751E+01  0.47873E+01  0.64052E+01
+  0.95117E+01  0.13318E+02  0.18588E+02  0.77882E-06  0.10167E-05  0.13264E-05
+  0.18794E-05  0.48980E-05  0.97696E-05  0.19473E-04  0.41491E-04  0.61280E-04
+  0.69379E-04  0.52343E-04  0.24288E-04  0.77344E-04  0.50515E-03  0.14726E-02
+  0.37980E-02  0.81822E-02  0.17020E-01  0.37447E-01  0.77694E-01  0.16101E+00
+  0.31604E+00  0.62008E+00  0.92840E+00  0.13574E+01  0.19474E+01  0.27862E+01
+  0.39561E+01  0.59641E+01  0.79684E+01  0.11830E+02  0.16559E+02  0.23098E+02
+  0.33691E-05  0.59099E-05  0.93370E-05  0.22203E-04  0.42466E-04  0.75598E-04
+  0.10872E-03  0.15374E-03  0.21459E-03  0.27054E-03  0.27831E-03  0.23038E-03
+  0.17441E-03  0.22773E-03  0.11775E-02  0.35998E-02  0.83043E-02  0.16927E-01
+  0.37380E-01  0.77559E-01  0.16046E+00  0.31555E+00  0.62112E+00  0.11513E+01
+  0.16817E+01  0.24092E+01  0.34439E+01  0.48874E+01  0.73736E+01  0.98371E+01
+  0.14610E+02  0.20459E+02  0.28542E+02  0.24329E-04  0.44574E-04  0.75566E-04
+  0.11656E-03  0.19164E-03  0.29830E-03  0.43015E-03  0.55851E-03  0.66868E-03
+  0.78453E-03  0.85535E-03  0.85012E-03  0.75400E-03  0.71936E-03  0.41064E-03
+  0.27222E-02  0.72551E-02  0.15670E-01  0.36146E-01  0.75302E-01  0.15512E+00
+  0.30879E+00  0.60822E+00  0.12178E+01  0.20543E+01  0.29408E+01  0.42024E+01
+  0.59645E+01  0.90164E+01  0.12008E+02  0.17862E+02  0.25047E+02  0.34978E+02
+  0.88172E-04  0.11295E-03  0.23225E-03  0.41226E-03  0.65459E-03  0.88243E-03
+  0.11567E-02  0.14079E-02  0.16740E-02  0.19145E-02  0.21331E-02  0.23068E-02
+  0.23223E-02  0.21756E-02  0.26763E-02  0.51451E-03  0.44480E-02  0.11998E-01
+  0.31149E-01  0.67792E-01  0.14254E+00  0.28734E+00  0.57706E+00  0.11567E+01
+  0.22358E+01  0.35016E+01  0.50100E+01  0.71212E+01  0.10813E+02  0.14373E+02
+  0.21452E+02  0.30173E+02  0.42238E+02  0.40430E-03  0.51694E-03  0.66493E-03
+  0.10160E-02  0.15240E-02  0.22069E-02  0.27394E-02  0.33520E-02  0.39193E-02
+  0.44365E-02  0.49122E-02  0.54692E-02  0.58411E-02  0.59557E-02  0.60697E-02
+  0.64364E-02  0.17697E-02  0.37908E-02  0.20349E-01  0.51681E-01  0.11765E+00
+  0.24701E+00  0.50798E+00  0.10448E+01  0.20360E+01  0.39092E+01  0.57494E+01
+  0.82071E+01  0.12574E+02  0.16675E+02  0.25058E+02  0.35450E+02  0.49856E+02
+  0.13574E-02  0.17318E-02  0.22206E-02  0.28503E-02  0.36137E-02  0.46112E-02
+  0.59422E-02  0.69593E-02  0.81052E-02  0.90949E-02  0.98979E-02  0.10824E-01
+  0.11903E-01  0.12513E-01  0.12780E-01  0.12743E-01  0.11190E-01  0.74973E-02
+  0.63997E-02  0.32216E-01  0.89324E-01  0.20323E+00  0.43531E+00  0.92085E+00
+  0.18345E+01  0.35366E+01  0.65368E+01  0.93816E+01  0.14532E+02  0.19217E+02
+  0.29112E+02  0.41464E+02  0.58639E+02  0.31856E-02  0.40553E-02  0.51853E-02
+  0.66324E-02  0.85275E-02  0.10006E-01  0.11730E-01  0.14025E-01  0.15722E-01
+  0.17608E-01  0.19083E-01  0.20355E-01  0.21862E-01  0.23536E-01  0.24470E-01
+  0.24684E-01  0.28523E-01  0.24030E-01  0.12595E-01  0.73839E-02  0.55423E-01
+  0.15372E+00  0.35685E+00  0.78629E+00  0.16184E+01  0.31598E+01  0.61244E+01
+  0.10615E+02  0.16669E+02  0.21968E+02  0.33607E+02  0.48255E+02  0.68686E+02
+  0.64014E-02  0.81336E-02  0.10375E-01  0.13232E-01  0.16952E-01  0.21820E-01
+  0.24471E-01  0.27233E-01  0.30859E-01  0.33371E-01  0.36042E-01  0.38154E-01
+  0.40993E-01  0.43232E-01  0.45500E-01  0.47154E-01  0.49367E-01  0.12877E+00
+  0.45755E-01  0.34640E-01  0.00000E+00  0.75977E-01  0.23890E+00  0.59243E+00
+  0.12972E+01  0.26297E+01  0.51885E+01  0.10075E+02  0.18340E+02  0.24068E+02
+  0.37439E+02  0.54467E+02  0.78335E+02  0.11206E-01  0.14215E-01  0.18097E-01
+  0.23025E-01  0.29410E-01  0.37716E-01  0.48536E-01  0.52912E-01  0.56951E-01
+  0.62216E-01  0.65699E-01  0.69562E-01  0.73034E-01  0.77241E-01  0.80513E-01
+  0.83830E-01  0.88804E-01  0.96650E-01  0.37924E+00  0.93714E-01  0.73685E-01
+  0.21551E-01  0.99146E-01  0.37410E+00  0.94900E+00  0.20324E+01  0.42079E+01
+  0.83622E+01  0.18736E+02  0.25745E+02  0.40983E+02  0.60668E+02  0.88411E+02
+  0.17626E-01  0.22328E-01  0.28377E-01  0.36031E-01  0.45909E-01  0.58698E-01
+  0.75258E-01  0.96908E-01  0.10351E+00  0.10910E+00  0.11607E+00  0.12099E+00
+  0.12630E+00  0.13212E+00  0.13663E+00  0.14146E+00  0.14922E+00  0.16209E+00
+  0.16464E+00  0.34616E+00  0.16733E+00  0.13752E+00  0.55939E-01  0.14701E+00
+  0.60483E+00  0.14623E+01  0.32445E+01  0.67837E+01  0.15968E+02  0.27235E+02
+  0.44649E+02  0.67485E+02  0.99842E+02  0.27379E-01  0.34638E-01  0.43961E-01
+  0.55725E-01  0.70859E-01  0.90378E-01  0.11553E+00  0.14823E+00  0.19066E+00
+  0.20058E+00  0.20813E+00  0.21746E+00  0.22352E+00  0.22996E+00  0.23706E+00
+  0.24406E+00  0.25595E+00  0.27633E+00  0.28563E+00  0.31519E+00  0.32403E+00
+  0.32688E+00  0.30103E+00  0.19777E+00  0.10195E+00  0.66127E+00  0.19200E+01
+  0.45939E+01  0.12299E+02  0.20923E+02  0.45158E+02  0.70921E+02  0.10772E+03
+  0.39351E-01  0.49734E-01  0.63039E-01  0.79794E-01  0.10129E+00  0.12893E+00
+  0.16440E+00  0.21030E+00  0.26951E+00  0.34666E+00  0.36022E+00  0.37078E+00
+  0.38229E+00  0.38906E+00  0.39638E+00  0.40442E+00  0.41957E+00  0.44701E+00
+  0.46079E+00  0.49812E+00  0.53053E+00  0.56162E+00  0.58395E+00  0.56605E+00
+  0.39813E+00  0.90126E-01  0.73358E+00  0.26624E+01  0.91723E+01  0.15459E+02
+  0.39340E+02  0.74891E+02  0.11728E+03  0.56330E-01  0.71111E-01  0.90031E-01
+  0.11382E+00  0.14427E+00  0.18333E+00  0.23330E+00  0.29772E+00  0.38046E+00
+  0.48767E+00  0.62471E+00  0.64498E+00  0.66034E+00  0.67660E+00  0.68536E+00
+  0.69486E+00  0.71508E+00  0.75363E+00  0.77525E+00  0.83484E+00  0.89724E+00
+  0.97530E+00  0.10761E+01  0.11937E+01  0.12305E+01  0.12999E+01  0.11146E+01
+  0.25804E+00  0.43785E+01  0.73865E+01  0.25528E+02  0.60930E+02  0.11563E+03
+  0.78138E-01  0.98537E-01  0.12462E+00  0.15736E+00  0.19923E+00  0.25278E+00
+  0.32114E+00  0.40898E+00  0.52138E+00  0.66639E+00  0.85076E+00  0.10911E+01
+  0.11120E+01  0.11321E+01  0.11531E+01  0.11607E+01  0.11834E+01  0.12316E+01
+  0.12559E+01  0.13355E+01  0.14243E+01  0.15457E+01  0.17202E+01  0.19647E+01
+  0.21877E+01  0.26025E+01  0.29875E+01  0.30683E+01  0.00000E+00  0.00000E+00
+  0.13373E+02  0.42142E+02  0.10095E+03  0.11658E+00  0.14685E+00  0.18553E+00
+  0.23403E+00  0.29594E+00  0.37504E+00  0.47583E+00  0.60503E+00  0.76993E+00
+  0.98204E+00  0.12509E+01  0.16003E+01  0.20329E+01  0.20606E+01  0.20933E+01
+  0.21250E+01  0.21583E+01  0.22319E+01  0.22755E+01  0.24092E+01  0.25726E+01
+  0.28095E+01  0.31724E+01  0.37309E+01  0.44120E+01  0.56284E+01  0.73144E+01
+  0.94991E+01  0.10005E+02  0.16389E+02  0.14032E+02  0.00000E+00  0.34882E+02
+  0.17002E+00  0.21391E+00  0.26995E+00  0.34016E+00  0.42972E+00  0.54394E+00
+  0.68929E+00  0.87530E+00  0.11121E+01  0.14160E+01  0.18002E+01  0.22980E+01
+  0.29326E+01  0.36804E+01  0.37214E+01  0.37748E+01  0.38488E+01  0.39512E+01
+  0.40119E+01  0.42106E+01  0.44638E+01  0.48428E+01  0.54380E+01  0.63803E+01
+  0.76092E+01  0.97702E+01  0.12949E+02  0.17487E+02  0.21862E+02  0.35137E+02
+  0.44403E+02  0.46303E+02  0.36477E+02  0.24390E+00  0.30644E+00  0.38623E+00
+  0.48616E+00  0.61348E+00  0.77580E+00  0.98196E+00  0.12455E+01  0.15805E+01
+  0.20093E+01  0.25502E+01  0.32494E+01  0.41389E+01  0.52983E+01  0.65328E+01
+  0.65917E+01  0.67229E+01  0.68967E+01  0.69654E+01  0.72387E+01  0.75969E+01
+  0.81485E+01  0.90311E+01  0.10448E+02  0.12344E+02  0.15644E+02  0.20579E+02
+  0.27815E+02  0.36470E+02  0.57340E+02  0.78994E+02  0.97582E+02  0.11491E+03
+  0.36375E+00  0.45629E+00  0.57432E+00  0.72204E+00  0.91017E+00  0.11498E+01
+  0.14539E+01  0.18421E+01  0.23350E+01  0.29652E+01  0.37591E+01  0.47836E+01
+  0.60863E+01  0.77836E+01  0.99561E+01  0.12069E+02  0.12250E+02  0.12613E+02
+  0.12749E+02  0.13161E+02  0.13716E+02  0.14584E+02  0.15984E+02  0.18243E+02
+  0.21316E+02  0.26576E+02  0.34495E+02  0.46253E+02  0.62068E+02  0.95184E+02
+  0.13682E+03  0.18206E+03  0.24191E+03  0.53128E+00  0.66520E+00  0.83591E+00
+  0.10495E+01  0.13214E+01  0.16674E+01  0.21063E+01  0.26661E+01  0.33760E+01
+  0.42826E+01  0.54232E+01  0.68936E+01  0.87619E+01  0.11194E+02  0.14303E+02
+  0.18735E+02  0.21887E+02  0.22376E+02  0.22800E+02  0.23381E+02  0.24167E+02
+  0.25426E+02  0.27482E+02  0.30816E+02  0.35376E+02  0.43098E+02  0.54688E+02
+  0.71880E+02  0.96009E+02  0.14320E+03  0.20699E+03  0.28115E+03  0.38637E+03
+  0.76456E+00  0.95503E+00  0.11979E+01  0.15016E+01  0.18880E+01  0.23795E+01
+  0.30027E+01  0.37969E+01  0.48033E+01  0.60871E+01  0.77011E+01  0.97787E+01
+  0.12417E+02  0.15849E+02  0.20230E+02  0.26465E+02  0.34744E+02  0.39202E+02
+  0.39698E+02  0.40944E+02  0.41984E+02  0.43712E+02  0.46586E+02  0.51286E+02
+  0.57734E+02  0.68587E+02  0.84772E+02  0.10863E+03  0.14263E+03  0.20642E+03
+  0.29534E+03  0.40150E+03  0.55605E+03  0.11261E+01  0.14028E+01  0.17555E+01
+  0.21964E+01  0.27572E+01  0.34705E+01  0.43742E+01  0.55254E+01  0.69832E+01
+  0.88423E+01  0.11177E+02  0.14181E+02  0.17996E+02  0.22958E+02  0.29290E+02
+  0.38299E+02  0.50216E+02  0.67016E+02  0.71247E+02  0.73154E+02  0.75299E+02
+  0.77760E+02  0.81922E+02  0.88770E+02  0.98184E+02  0.11391E+03  0.13720E+03
+  0.17126E+03  0.22030E+03  0.30874E+03  0.43473E+03  0.58754E+03  0.81307E+03
+  0.16827E+01  0.20891E+01  0.26070E+01  0.32545E+01  0.40778E+01  0.51245E+01
+  0.64503E+01  0.81387E+01  0.10276E+02  0.12999E+02  0.16419E+02  0.20819E+02
+  0.26406E+02  0.33677E+02  0.42955E+02  0.56158E+02  0.73578E+02  0.98016E+02
+  0.12908E+03  0.13274E+03  0.13652E+03  0.14101E+03  0.14712E+03  0.15722E+03
+  0.17113E+03  0.19422E+03  0.22813E+03  0.27731E+03  0.34839E+03  0.47227E+03
+  0.65080E+03  0.86868E+03  0.11918E+04  0.24729E+01  0.30578E+01  0.38031E+01
+  0.47346E+01  0.59189E+01  0.74243E+01  0.93305E+01  0.11757E+02  0.14828E+02
+  0.18739E+02  0.23649E+02  0.29964E+02  0.37983E+02  0.48421E+02  0.61739E+02
+  0.80693E+02  0.10563E+03  0.14048E+03  0.18476E+03  0.23653E+03  0.24159E+03
+  0.24979E+03  0.25932E+03  0.27361E+03  0.29335E+03  0.32608E+03  0.37385E+03
+  0.44248E+03  0.54126E+03  0.70948E+03  0.95155E+03  0.12463E+04  0.16822E+04
+  0.48046E-09  0.56161E-09  0.13449E-09  0.11556E-08  0.30313E-08  0.94966E-08
+  0.14327E-07  0.29580E-07  0.61201E-07  0.13891E-06  0.29279E-06  0.61026E-06
+  0.27582E-05  0.25215E-04  0.55832E-04  0.42078E-03  0.13832E-02  0.30857E-02
+  0.64500E-02  0.11495E-01  0.19580E-01  0.30191E-01  0.46142E-01  0.70540E-01
+  0.10486E+00  0.15305E+00  0.22271E+00  0.32190E+00  0.49511E+00  0.67975E+00
+  0.10418E+01  0.15068E+01  0.21894E+01  0.16304E-08  0.12374E-08  0.14242E-08
+  0.37413E-09  0.27427E-08  0.76373E-08  0.23151E-07  0.37419E-07  0.78442E-07
+  0.18276E-06  0.36885E-06  0.78872E-06  0.49115E-05  0.42867E-04  0.71100E-04
+  0.53570E-03  0.17570E-02  0.39105E-02  0.81603E-02  0.14519E-01  0.24700E-01
+  0.38035E-01  0.58057E-01  0.88627E-01  0.13154E+00  0.19163E+00  0.27817E+00
+  0.40084E+00  0.61405E+00  0.83884E+00  0.12773E+01  0.18352E+01  0.26452E+01
+  0.36732E-08  0.40100E-08  0.30623E-08  0.34279E-08  0.85121E-09  0.72231E-08
+  0.19508E-07  0.51818E-07  0.10348E-06  0.21133E-06  0.47059E-06  0.10240E-05
+  0.77446E-05  0.72138E-04  0.14557E-03  0.68394E-03  0.22366E-02  0.49642E-02
+  0.10338E-01  0.18359E-01  0.31186E-01  0.47962E-01  0.73115E-01  0.11146E+00
+  0.16521E+00  0.24026E+00  0.34806E+00  0.50032E+00  0.76392E+00  0.10393E+01
+  0.15739E+01  0.22488E+01  0.32193E+01  0.92210E-08  0.95020E-08  0.10386E-07
+  0.80308E-08  0.92676E-08  0.27151E-08  0.16561E-07  0.52541E-07  0.12890E-06
+  0.28103E-06  0.68563E-06  0.13504E-05  0.17743E-04  0.11046E-03  0.28566E-03
+  0.90979E-03  0.28524E-02  0.63105E-02  0.13111E-01  0.23233E-01  0.39401E-01
+  0.60512E-01  0.92124E-01  0.14025E+00  0.20763E+00  0.30153E+00  0.43606E+00
+  0.62551E+00  0.95250E+00  0.12915E+01  0.19471E+01  0.27690E+01  0.39416E+01
+  0.13914E-07  0.23009E-07  0.23747E-07  0.25934E-07  0.20412E-07  0.22982E-07
+  0.64961E-08  0.39599E-07  0.16686E-06  0.37491E-06  0.11460E-05  0.34985E-05
+  0.33584E-04  0.16648E-03  0.46926E-03  0.12599E-02  0.35710E-02  0.80358E-02
+  0.16651E-01  0.29433E-01  0.49819E-01  0.76392E-01  0.11614E+00  0.17659E+00
+  0.26112E+00  0.37868E+00  0.54683E+00  0.78305E+00  0.11898E+01  0.16087E+01
+  0.24166E+01  0.34235E+01  0.48499E+01  0.33484E-07  0.34917E-07  0.57410E-07
+  0.59481E-07  0.65201E-07  0.51934E-07  0.57580E-07  0.15064E-07  0.11394E-06
+  0.51792E-06  0.15260E-05  0.65614E-05  0.57672E-04  0.24291E-03  0.64969E-03
+  0.17148E-02  0.42069E-02  0.10246E-01  0.21170E-01  0.37311E-01  0.63024E-01
+  0.96470E-01  0.14644E+00  0.22237E+00  0.32842E+00  0.47573E+00  0.68608E+00
+  0.98103E+00  0.14879E+01  0.20071E+01  0.30062E+01  0.42457E+01  0.59914E+01
+  0.45835E-07  0.82035E-07  0.87769E-07  0.14028E-06  0.14950E-06  0.16330E-06
+  0.13252E-06  0.14848E-06  0.48543E-07  0.39722E-06  0.27730E-05  0.11685E-04
+  0.79229E-04  0.32316E-03  0.83559E-03  0.21691E-02  0.50189E-02  0.11217E-01
+  0.26928E-01  0.47309E-01  0.79725E-01  0.12181E+00  0.18461E+00  0.27994E+00
+  0.41298E+00  0.59753E+00  0.86073E+00  0.12292E+01  0.18617E+01  0.25064E+01
+  0.37452E+01  0.52765E+01  0.74225E+01  0.87724E-07  0.11771E-06  0.18227E-06
+  0.23067E-06  0.30805E-06  0.39853E-06  0.42147E-06  0.34029E-06  0.44727E-06
+  0.16747E-06  0.24428E-05  0.19966E-04  0.99139E-04  0.39340E-03  0.99087E-03
+  0.25231E-02  0.59052E-02  0.12410E-01  0.29372E-01  0.59931E-01  0.10076E+00
+  0.15364E+00  0.23248E+00  0.35203E+00  0.51879E+00  0.74973E+00  0.10789E+01
+  0.15392E+01  0.23287E+01  0.31298E+01  0.46682E+01  0.65645E+01  0.92121E+01
+  0.17345E-06  0.23499E-06  0.33168E-06  0.49377E-06  0.74443E-06  0.87498E-06
+  0.13627E-05  0.12278E-05  0.90393E-06  0.14477E-05  0.11527E-05  0.18119E-04
+  0.10785E-03  0.42400E-03  0.11035E-02  0.28017E-02  0.64477E-02  0.13819E-01
+  0.30890E-01  0.67754E-01  0.12689E+00  0.19317E+00  0.29185E+00  0.44136E+00
+  0.64988E+00  0.93824E+00  0.13489E+01  0.19229E+01  0.29074E+01  0.39017E+01
+  0.58122E+01  0.81624E+01  0.11434E+02  0.38069E-06  0.50328E-06  0.61717E-06
+  0.90536E-06  0.14217E-05  0.23283E-05  0.29143E-05  0.43750E-05  0.34823E-05
+  0.23155E-05  0.81149E-05  0.80814E-05  0.82874E-04  0.40203E-03  0.11256E-02
+  0.29448E-02  0.68297E-02  0.14320E-01  0.32569E-01  0.69016E-01  0.14936E+00
+  0.24182E+00  0.36492E+00  0.55127E+00  0.81116E+00  0.11700E+01  0.16810E+01
+  0.23946E+01  0.36204E+01  0.48517E+01  0.72224E+01  0.10135E+02  0.14180E+02
+  0.78089E-06  0.10462E-05  0.14055E-05  0.18624E-05  0.31739E-05  0.54130E-05
+  0.10499E-04  0.15095E-04  0.19305E-04  0.15697E-04  0.11484E-04  0.61419E-04
+  0.26872E-04  0.26406E-03  0.98746E-03  0.28344E-02  0.67553E-02  0.14442E-01
+  0.32774E-01  0.69694E-01  0.14820E+00  0.29583E+00  0.45222E+00  0.68290E+00
+  0.10048E+01  0.14485E+01  0.20803E+01  0.29630E+01  0.44822E+01  0.59986E+01
+  0.89304E+01  0.12531E+02  0.17522E+02  0.16296E-05  0.21336E-05  0.25471E-05
+  0.40128E-05  0.96250E-05  0.19773E-04  0.37738E-04  0.86071E-04  0.12349E-03
+  0.15136E-03  0.13811E-03  0.14165E-03  0.25658E-03  0.93331E-04  0.55853E-03
+  0.23665E-02  0.59871E-02  0.13424E-01  0.31619E-01  0.67868E-01  0.14414E+00
+  0.28806E+00  0.55134E+00  0.83365E+00  0.12283E+01  0.17709E+01  0.25441E+01
+  0.36253E+01  0.54946E+01  0.73429E+01  0.10944E+02  0.15370E+02  0.21502E+02
+  0.61417E-05  0.10135E-04  0.15547E-04  0.37612E-04  0.71099E-04  0.12737E-03
+  0.18689E-03  0.28727E-03  0.44450E-03  0.59542E-03  0.66783E-03  0.66090E-03
+  0.84255E-03  0.86187E-03  0.46684E-03  0.10628E-02  0.43128E-02  0.10882E-01
+  0.27737E-01  0.61516E-01  0.13362E+00  0.27062E+00  0.54508E+00  0.98949E+00
+  0.14643E+01  0.21150E+01  0.30443E+01  0.43462E+01  0.66147E+01  0.88273E+01
+  0.13195E+02  0.18578E+02  0.26038E+02  0.30912E-04  0.63768E-04  0.10883E-03
+  0.16876E-03  0.32747E-03  0.54637E-03  0.84078E-03  0.11037E-02  0.13521E-02
+  0.16419E-02  0.18704E-02  0.20233E-02  0.22540E-02  0.30581E-02  0.25370E-02
+  0.16538E-02  0.62149E-03  0.55974E-02  0.20360E-01  0.49659E-01  0.11310E+00
+  0.23927E+00  0.49037E+00  0.10124E+01  0.16822E+01  0.24419E+01  0.35307E+01
+  0.50615E+01  0.77645E+01  0.10345E+02  0.15552E+02  0.22002E+02  0.30953E+02
+  0.18050E-03  0.23160E-03  0.46515E-03  0.77740E-03  0.11986E-02  0.15837E-02
+  0.20508E-02  0.25027E-02  0.30003E-02  0.34992E-02  0.40239E-02  0.45522E-02
+  0.49992E-02  0.57571E-02  0.78995E-02  0.59234E-02  0.50481E-02  0.21324E-02
+  0.96560E-02  0.33402E-01  0.87025E-01  0.19662E+00  0.42309E+00  0.89121E+00
+  0.17859E+01  0.27508E+01  0.40056E+01  0.57782E+01  0.89637E+01  0.11919E+02
+  0.18065E+02  0.25727E+02  0.36386E+02  0.47843E-03  0.61196E-03  0.78767E-03
+  0.13588E-02  0.21265E-02  0.31510E-02  0.39114E-02  0.48401E-02  0.57668E-02
+  0.66119E-02  0.74562E-02  0.84682E-02  0.94017E-02  0.10349E-01  0.12242E-01
+  0.13012E-01  0.12856E-01  0.12304E-01  0.36194E-02  0.14105E-01  0.58006E-01
+  0.15088E+00  0.34775E+00  0.76646E+00  0.15692E+01  0.30539E+01  0.44890E+01
+  0.65280E+01  0.10268E+02  0.13623E+02  0.20851E+02  0.29929E+02  0.42602E+02
+  0.17647E-02  0.22526E-02  0.28906E-02  0.37138E-02  0.48180E-02  0.62902E-02
+  0.82214E-02  0.95996E-02  0.11213E-01  0.12714E-01  0.14005E-01  0.15695E-01
+  0.17616E-01  0.19361E-01  0.21219E-01  0.26357E-01  0.26625E-01  0.29078E-01
+  0.24946E-01  0.15774E-01  0.14638E-01  0.84831E-01  0.24072E+00  0.58725E+00
+  0.12737E+01  0.25733E+01  0.47480E+01  0.70124E+01  0.11298E+02  0.14948E+02
+  0.23252E+02  0.33805E+02  0.48602E+02  0.42234E-02  0.53788E-02  0.68821E-02
+  0.88098E-02  0.11331E-01  0.13213E-01  0.15702E-01  0.18929E-01  0.21241E-01
+  0.23853E-01  0.26069E-01  0.28029E-01  0.31130E-01  0.34286E-01  0.37366E-01
+  0.40996E-01  0.95087E-01  0.52867E-01  0.53781E-01  0.54028E-01  0.38022E-01
+  0.84027E-02  0.12196E+00  0.38930E+00  0.95603E+00  0.20251E+01  0.41720E+01
+  0.72905E+01  0.12161E+02  0.16037E+02  0.25500E+02  0.37695E+02  0.54891E+02
+  0.80848E-02  0.10276E-01  0.13115E-01  0.16736E-01  0.21459E-01  0.27552E-01
+  0.30485E-01  0.34360E-01  0.39255E-01  0.42664E-01  0.46366E-01  0.49785E-01
+  0.53913E-01  0.58547E-01  0.63462E-01  0.69297E-01  0.77515E-01  0.33724E+00
+  0.97265E-01  0.10939E+00  0.11106E+00  0.93149E-01  0.29406E-01  0.14634E+00
+  0.56225E+00  0.13729E+01  0.30438E+01  0.64128E+01  0.12393E+02  0.16277E+02
+  0.26829E+02  0.40685E+02  0.60369E+02  0.14384E-01  0.18251E-01  0.23245E-01
+  0.29589E-01  0.37820E-01  0.48548E-01  0.62077E-01  0.66419E-01  0.72073E-01
+  0.79081E-01  0.83868E-01  0.89310E-01  0.94871E-01  0.10218E+00  0.10913E+00
+  0.11816E+00  0.13120E+00  0.15130E+00  0.45149E+00  0.19643E+00  0.22216E+00
+  0.24221E+00  0.24331E+00  0.18434E+00  0.42645E-01  0.50363E+00  0.15945E+01
+  0.39450E+01  0.10965E+02  0.14519E+02  0.25785E+02  0.41012E+02  0.62891E+02
+  0.23961E-01  0.30361E-01  0.38601E-01  0.49033E-01  0.62514E-01  0.79992E-01
+  0.10267E+00  0.13072E+00  0.13713E+00  0.14544E+00  0.15538E+00  0.16309E+00
+  0.17238E+00  0.18316E+00  0.19376E+00  0.20791E+00  0.22867E+00  0.26098E+00
+  0.29508E+00  0.37599E+00  0.40937E+00  0.48678E+00  0.58370E+00  0.69341E+00
+  0.73413E+00  0.76136E+00  0.51482E+00  0.43397E+00  0.49112E+01  0.80761E+01
+  0.18938E+02  0.34465E+02  0.57241E+02  0.39555E-01  0.50057E-01  0.63550E-01
+  0.80587E-01  0.10252E+00  0.13086E+00  0.16744E+00  0.21514E+00  0.27231E+00
+  0.28252E+00  0.29529E+00  0.31062E+00  0.32293E+00  0.33801E+00  0.35615E+00
+  0.37889E+00  0.41247E+00  0.46487E+00  0.52038E+00  0.63660E+00  0.73934E+00
+  0.90737E+00  0.11524E+01  0.15173E+01  0.19551E+01  0.26921E+01  0.36654E+01
+  0.47858E+01  0.39363E+01  0.67088E+01  0.00000E+00  0.13336E+02  0.33889E+02
+  0.60208E-01  0.76110E-01  0.96501E-01  0.12219E+00  0.15518E+00  0.19765E+00
+  0.25226E+00  0.32309E+00  0.41481E+00  0.52210E+00  0.53747E+00  0.55679E+00
+  0.57852E+00  0.59744E+00  0.62090E+00  0.65312E+00  0.70122E+00  0.77666E+00
+  0.85867E+00  0.10014E+01  0.11881E+01  0.14512E+01  0.18479E+01  0.24670E+01
+  0.32892E+01  0.47015E+01  0.68106E+01  0.98280E+01  0.12416E+02  0.20923E+02
+  0.24450E+02  0.17088E+02  0.00000E+00  0.92079E-01  0.11627E+00  0.14724E+00
+  0.18621E+00  0.23613E+00  0.30022E+00  0.38236E+00  0.48851E+00  0.62530E+00
+  0.80350E+00  0.10043E+01  0.10331E+01  0.10677E+01  0.11071E+01  0.11425E+01
+  0.11916E+01  0.12653E+01  0.13810E+01  0.15107E+01  0.17348E+01  0.20339E+01
+  0.24624E+01  0.31193E+01  0.41675E+01  0.56296E+01  0.81433E+01  0.12078E+02
+  0.18106E+02  0.26034E+02  0.43911E+02  0.63376E+02  0.80795E+02  0.83117E+02
+  0.13658E+00  0.17227E+00  0.21792E+00  0.27528E+00  0.34863E+00  0.44260E+00
+  0.56271E+00  0.71741E+00  0.91599E+00  0.11735E+01  0.15035E+01  0.18702E+01
+  0.19196E+01  0.19813E+01  0.20504E+01  0.21206E+01  0.22271E+01  0.23950E+01
+  0.25848E+01  0.29131E+01  0.33542E+01  0.39885E+01  0.49637E+01  0.65251E+01
+  0.87327E+01  0.12502E+02  0.18468E+02  0.27772E+02  0.41384E+02  0.69072E+02
+  0.10606E+03  0.14649E+03  0.20081E+03  0.20687E+00  0.26064E+00  0.32937E+00
+  0.41558E+00  0.52571E+00  0.66657E+00  0.84621E+00  0.10770E+01  0.13723E+01
+  0.17539E+01  0.22408E+01  0.28800E+01  0.35487E+01  0.36389E+01  0.37544E+01
+  0.38904E+01  0.40492E+01  0.43000E+01  0.45867E+01  0.50809E+01  0.57478E+01
+  0.67068E+01  0.81785E+01  0.10530E+02  0.13868E+02  0.19505E+02  0.28443E+02
+  0.42468E+02  0.64163E+02  0.10541E+03  0.16704E+03  0.24057E+03  0.34650E+03
+  0.31587E+00  0.39751E+00  0.50177E+00  0.63245E+00  0.79922E+00  0.10121E+01
+  0.12833E+01  0.16309E+01  0.20747E+01  0.26463E+01  0.33734E+01  0.43240E+01
+  0.55553E+01  0.67800E+01  0.69507E+01  0.71959E+01  0.74802E+01  0.78586E+01
+  0.82941E+01  0.90428E+01  0.10054E+02  0.11506E+02  0.13723E+02  0.17242E+02
+  0.22226E+02  0.30534E+02  0.43639E+02  0.64162E+02  0.96796E+02  0.15611E+03
+  0.24915E+03  0.36752E+03  0.54264E+03  0.48240E+00  0.60625E+00  0.76434E+00
+  0.96236E+00  0.12148E+01  0.15368E+01  0.19463E+01  0.24704E+01  0.31382E+01
+  0.39963E+01  0.50849E+01  0.65037E+01  0.83354E+01  0.10770E+02  0.12944E+02
+  0.13306E+02  0.13843E+02  0.14468E+02  0.15125E+02  0.16254E+02  0.17779E+02
+  0.19960E+02  0.23270E+02  0.28482E+02  0.35816E+02  0.47865E+02  0.66699E+02
+  0.95979E+02  0.14307E+03  0.22584E+03  0.35903E+03  0.53154E+03  0.79818E+03
+  0.73364E+00  0.92059E+00  0.11591E+01  0.14576E+01  0.18379E+01  0.23227E+01
+  0.29384E+01  0.37255E+01  0.47270E+01  0.60112E+01  0.76365E+01  0.97499E+01
+  0.12471E+02  0.16076E+02  0.20781E+02  0.24632E+02  0.25423E+02  0.26647E+02
+  0.27650E+02  0.29336E+02  0.31612E+02  0.34854E+02  0.39747E+02  0.47383E+02
+  0.58034E+02  0.75285E+02  0.10193E+03  0.14291E+03  0.20894E+03  0.32184E+03
+  0.50565E+03  0.74541E+03  0.11183E+04  0.11311E+01  0.14167E+01  0.17809E+01
+  0.22366E+01  0.28169E+01  0.35559E+01  0.44938E+01  0.56917E+01  0.72135E+01
+  0.91623E+01  0.11625E+02  0.14821E+02  0.18927E+02  0.24354E+02  0.31412E+02
+  0.41718E+02  0.47611E+02  0.49445E+02  0.51586E+02  0.54144E+02  0.57594E+02
+  0.62494E+02  0.69842E+02  0.81210E+02  0.96920E+02  0.12200E+03  0.16022E+03
+  0.21830E+03  0.31154E+03  0.46697E+03  0.72116E+03  0.10532E+04  0.15701E+04
+  0.17215E+01  0.21514E+01  0.26994E+01  0.33850E+01  0.42574E+01  0.53681E+01
+  0.67767E+01  0.85741E+01  0.10855E+02  0.13774E+02  0.17455E+02  0.22226E+02
+  0.28345E+02  0.36417E+02  0.46884E+02  0.62108E+02  0.82610E+02  0.90993E+02
+  0.94268E+02  0.99103E+02  0.10422E+03  0.11148E+03  0.12231E+03  0.13893E+03
+  0.16170E+03  0.19755E+03  0.25147E+03  0.33226E+03  0.46088E+03  0.67052E+03
+  0.10124E+04  0.14572E+04  0.21475E+04  0.26644E+01  0.33209E+01  0.41575E+01
+  0.52040E+01  0.65351E+01  0.82288E+01  0.10376E+02  0.13114E+02  0.16586E+02
+  0.21023E+02  0.26617E+02  0.33855E+02  0.43129E+02  0.55342E+02  0.71145E+02
+  0.94064E+02  0.12476E+03  0.16851E+03  0.17590E+03  0.18402E+03  0.19318E+03
+  0.20414E+03  0.22042E+03  0.24524E+03  0.27893E+03  0.33133E+03  0.40906E+03
+  0.52392E+03  0.70493E+03  0.99345E+03  0.14611E+04  0.20654E+04  0.29979E+04
+  0.41017E+01  0.50958E+01  0.63625E+01  0.79462E+01  0.99605E+01  0.12523E+02
+  0.15770E+02  0.19907E+02  0.25152E+02  0.31849E+02  0.40283E+02  0.51188E+02
+  0.65144E+02  0.83504E+02  0.10721E+03  0.14152E+03  0.18726E+03  0.25203E+03
+  0.32738E+03  0.33941E+03  0.35570E+03  0.37375E+03  0.39801E+03  0.43478E+03
+  0.48430E+03  0.56047E+03  0.67205E+03  0.83463E+03  0.10878E+04  0.14830E+04
+  0.21173E+04  0.29292E+04  0.41716E+04  0.28418E-09  0.40303E-09  0.19295E-08
+  0.44620E-08  0.13072E-07  0.18612E-07  0.36939E-07  0.76924E-07  0.16883E-06
+  0.35944E-06  0.74234E-06  0.30292E-05  0.23363E-04  0.84797E-04  0.38917E-03
+  0.13074E-02  0.30698E-02  0.61716E-02  0.10807E-01  0.17003E-01  0.26417E-01
+  0.37979E-01  0.54373E-01  0.75437E-01  0.11258E+00  0.16422E+00  0.23563E+00
+  0.35153E+00  0.51361E+00  0.73938E+00  0.10896E+01  0.16290E+01  0.23956E+01
+  0.12097E-08  0.65617E-09  0.10129E-08  0.46919E-08  0.11474E-07  0.31131E-07
+  0.48803E-07  0.99048E-07  0.22610E-06  0.45449E-06  0.96146E-06  0.54119E-05
+  0.40239E-04  0.10820E-03  0.49598E-03  0.16630E-02  0.38972E-02  0.78209E-02
+  0.13675E-01  0.21487E-01  0.33344E-01  0.47887E-01  0.68491E-01  0.94923E-01
+  0.14150E+00  0.20616E+00  0.29541E+00  0.43999E+00  0.64163E+00  0.92156E+00
+  0.13542E+01  0.20178E+01  0.29552E+01  0.32125E-08  0.28558E-08  0.14973E-08
+  0.25389E-08  0.12414E-07  0.29233E-07  0.68878E-07  0.13198E-06  0.26696E-06
+  0.57624E-06  0.12411E-05  0.85601E-05  0.68986E-04  0.20459E-03  0.63425E-03
+  0.21212E-02  0.49584E-02  0.99298E-02  0.17331E-01  0.27189E-01  0.42137E-01
+  0.60442E-01  0.86351E-01  0.11956E+00  0.17804E+00  0.25912E+00  0.37084E+00
+  0.55160E+00  0.80311E+00  0.11513E+01  0.16878E+01  0.25077E+01  0.36604E+01
+  0.79130E-08  0.80588E-08  0.72687E-08  0.41336E-08  0.67170E-08  0.30619E-07
+  0.80832E-07  0.16653E-06  0.35152E-06  0.84600E-06  0.16017E-05  0.18883E-04
+  0.10690E-03  0.37290E-03  0.93441E-03  0.27135E-02  0.63236E-02  0.12631E-01
+  0.21998E-01  0.34448E-01  0.53306E-01  0.76363E-01  0.10897E+00  0.15071E+00
+  0.22421E+00  0.32599E+00  0.46604E+00  0.69239E+00  0.10067E+01  0.14408E+01
+  0.21083E+01  0.31253E+01  0.45489E+01  0.18500E-07  0.20631E-07  0.21287E-07
+  0.19850E-07  0.11483E-07  0.14928E-07  0.78927E-07  0.24598E-06  0.47530E-06
+  0.14069E-05  0.40119E-05  0.36543E-04  0.17107E-03  0.59462E-03  0.14033E-02
+  0.34319E-02  0.80848E-02  0.16101E-01  0.27969E-01  0.43702E-01  0.67509E-01
+  0.96560E-01  0.13762E+00  0.19010E+00  0.28254E+00  0.41043E+00  0.58616E+00
+  0.86996E+00  0.12634E+01  0.18058E+01  0.26383E+01  0.39036E+01  0.56687E+01
+  0.33348E-07  0.46378E-07  0.51896E-07  0.53938E-07  0.49236E-07  0.28644E-07
+  0.45120E-07  0.24082E-06  0.73112E-06  0.19466E-05  0.78501E-05  0.64216E-04
+  0.26532E-03  0.81572E-03  0.20208E-02  0.43371E-02  0.96276E-02  0.20574E-01
+  0.35632E-01  0.55531E-01  0.85605E-01  0.12222E+00  0.17394E+00  0.23997E+00
+  0.35631E+00  0.51705E+00  0.73774E+00  0.10940E+01  0.15871E+01  0.22659E+01
+  0.33062E+01  0.48842E+01  0.70793E+01  0.68730E-07  0.83107E-07  0.11577E-06
+  0.12996E-06  0.13347E-06  0.11965E-06  0.69849E-07  0.15058E-06  0.78188E-06
+  0.37917E-05  0.14259E-04  0.92224E-04  0.37577E-03  0.10610E-02  0.25634E-02
+  0.55206E-02  0.11158E-01  0.23709E-01  0.45486E-01  0.70672E-01  0.10868E+00
+  0.15484E+00  0.21999E+00  0.30308E+00  0.44952E+00  0.65173E+00  0.92906E+00
+  0.13765E+01  0.19952E+01  0.28457E+01  0.41476E+01  0.61194E+01  0.88561E+01
+  0.11773E-06  0.16232E-06  0.20724E-06  0.27609E-06  0.32108E-06  0.32403E-06
+  0.27399E-06  0.19535E-06  0.48766E-06  0.48615E-05  0.26588E-04  0.12285E-03
+  0.48116E-03  0.12687E-02  0.31009E-02  0.65415E-02  0.13138E-01  0.26071E-01
+  0.51391E-01  0.90067E-01  0.13812E+00  0.19631E+00  0.27839E+00  0.38290E+00
+  0.56730E+00  0.82163E+00  0.11702E+01  0.17324E+01  0.25090E+01  0.35756E+01
+  0.52067E+01  0.76741E+01  0.11092E+02  0.21754E-06  0.30427E-06  0.47884E-06
+  0.66585E-06  0.86355E-06  0.94489E-06  0.87043E-06  0.68283E-06  0.65358E-06
+  0.28415E-05  0.35746E-04  0.15066E-03  0.55092E-03  0.14615E-02  0.35470E-02
+  0.75135E-02  0.14780E-01  0.29048E-01  0.54611E-01  0.10040E+00  0.17558E+00
+  0.24886E+00  0.35219E+00  0.48353E+00  0.71564E+00  0.10355E+01  0.14734E+01
+  0.21800E+01  0.31553E+01  0.44932E+01  0.65381E+01  0.96288E+01  0.13904E+02
+  0.44379E-06  0.57889E-06  0.81965E-06  0.14198E-05  0.21168E-05  0.27943E-05
+  0.29640E-05  0.23892E-05  0.17882E-05  0.35164E-05  0.20326E-04  0.15926E-03
+  0.58103E-03  0.15888E-02  0.39000E-02  0.82113E-02  0.16254E-01  0.31315E-01
+  0.58523E-01  0.10423E+00  0.19369E+00  0.31515E+00  0.44506E+00  0.60981E+00
+  0.90176E+00  0.13036E+01  0.18536E+01  0.27411E+01  0.39654E+01  0.56435E+01
+  0.82081E+01  0.12081E+02  0.17432E+02  0.10218E-05  0.12803E-05  0.16192E-05
+  0.25796E-05  0.44928E-05  0.73555E-05  0.10501E-04  0.11491E-04  0.76323E-05
+  0.83884E-05  0.26706E-04  0.82394E-04  0.50874E-03  0.15806E-02  0.40564E-02
+  0.86076E-02  0.17027E-01  0.32981E-01  0.61062E-01  0.10836E+00  0.19727E+00
+  0.34432E+00  0.56031E+00  0.76623E+00  0.11327E+01  0.16366E+01  0.23257E+01
+  0.34392E+01  0.49741E+01  0.70765E+01  0.10290E+02  0.15143E+02  0.21842E+02
+  0.18475E-05  0.20202E-05  0.39045E-05  0.88430E-05  0.15656E-04  0.32298E-04
+  0.68872E-04  0.93327E-04  0.97770E-04  0.83019E-04  0.87819E-04  0.92142E-04
+  0.27018E-03  0.13865E-02  0.40294E-02  0.86592E-02  0.17281E-01  0.33521E-01
+  0.62500E-01  0.11051E+00  0.20061E+00  0.34632E+00  0.60830E+00  0.95855E+00
+  0.14174E+01  0.20478E+01  0.29093E+01  0.43039E+01  0.62253E+01  0.88560E+01
+  0.12880E+02  0.18956E+02  0.27338E+02  0.71143E-05  0.12448E-04  0.25583E-04
+  0.48645E-04  0.83324E-04  0.13184E-03  0.20952E-03  0.34369E-03  0.44748E-03
+  0.46660E-03  0.42290E-03  0.44128E-03  0.20171E-03  0.85497E-03  0.36330E-02
+  0.85945E-02  0.16884E-01  0.33754E-01  0.62620E-01  0.11074E+00  0.20071E+00
+  0.34665E+00  0.60703E+00  0.10324E+01  0.17649E+01  0.25511E+01  0.36247E+01
+  0.53680E+01  0.77684E+01  0.11054E+02  0.16085E+02  0.23688E+02  0.34168E+02
+  0.35797E-04  0.61020E-04  0.11558E-03  0.25011E-03  0.43922E-03  0.67390E-03
+  0.87399E-03  0.10743E-02  0.12809E-02  0.14176E-02  0.14589E-02  0.15048E-02
+  0.16000E-02  0.51207E-03  0.21281E-02  0.69580E-02  0.15501E-01  0.31536E-01
+  0.60106E-01  0.10709E+00  0.19359E+00  0.33539E+00  0.59312E+00  0.10069E+01
+  0.18705E+01  0.31311E+01  0.44575E+01  0.66223E+01  0.96030E+01  0.13683E+02
+  0.19944E+02  0.29419E+02  0.42481E+02  0.27341E-03  0.48430E-03  0.76459E-03
+  0.11039E-02  0.14559E-02  0.18282E-02  0.22055E-02  0.26276E-02  0.30499E-02
+  0.34779E-02  0.38377E-02  0.40308E-02  0.42767E-02  0.49452E-02  0.12983E-02
+  0.29114E-02  0.10486E-01  0.25723E-01  0.52259E-01  0.95959E-01  0.17730E+00
+  0.30892E+00  0.55487E+00  0.95289E+00  0.17874E+01  0.32584E+01  0.53816E+01
+  0.80471E+01  0.11718E+02  0.16747E+02  0.24492E+02  0.36246E+02  0.52451E+02
+  0.48301E-03  0.71800E-03  0.13074E-02  0.20908E-02  0.29943E-02  0.37884E-02
+  0.46691E-02  0.55610E-02  0.63738E-02  0.71694E-02  0.80222E-02  0.87164E-02
+  0.92337E-02  0.98445E-02  0.13348E-01  0.42237E-02  0.18901E-02  0.15364E-01
+  0.39057E-01  0.77932E-01  0.15232E+00  0.27124E+00  0.49827E+00  0.86893E+00
+  0.16747E+01  0.30829E+01  0.55480E+01  0.96697E+01  0.14168E+02  0.20334E+02
+  0.29879E+02  0.44411E+02  0.64463E+02  0.23427E-02  0.29976E-02  0.38859E-02
+  0.51515E-02  0.68285E-02  0.87249E-02  0.10271E-01  0.11912E-01  0.13465E-01
+  0.14851E-01  0.16633E-01  0.18433E-01  0.19841E-01  0.20608E-01  0.20832E-01
+  0.32459E-01  0.14755E-01  0.45002E-02  0.14227E-01  0.45093E-01  0.10775E+00
+  0.20726E+00  0.40522E+00  0.72820E+00  0.14738E+01  0.28013E+01  0.51106E+01
+  0.97999E+01  0.16762E+02  0.24239E+02  0.35898E+02  0.53741E+02  0.78384E+02
+  0.66030E-02  0.84230E-02  0.10781E-01  0.13466E-01  0.15882E-01  0.19070E-01
+  0.22666E-01  0.25608E-01  0.28582E-01  0.31158E-01  0.33405E-01  0.37355E-01
+  0.40568E-01  0.42984E-01  0.43853E-01  0.45610E-01  0.78455E-01  0.39635E-01
+  0.28574E-01  0.96793E-02  0.35789E-01  0.10769E+00  0.26502E+00  0.52265E+00
+  0.11758E+01  0.23695E+01  0.44923E+01  0.88686E+01  0.16712E+02  0.28251E+02
+  0.42361E+02  0.64104E+02  0.94180E+02  0.13959E-01  0.17760E-01  0.22659E-01
+  0.29003E-01  0.35675E-01  0.39879E-01  0.45397E-01  0.51558E-01  0.56424E-01
+  0.61311E-01  0.66059E-01  0.71290E-01  0.77557E-01  0.82860E-01  0.86514E-01
+  0.91370E-01  0.99557E-01  0.17532E+00  0.10010E+00  0.98284E-01  0.76826E-01
+  0.42610E-01  0.60332E-01  0.23211E+00  0.76584E+00  0.17717E+01  0.36187E+01
+  0.76352E+01  0.14841E+02  0.27696E+02  0.48882E+02  0.75173E+02  0.11161E+03
+  0.27104E-01  0.34412E-01  0.43786E-01  0.55863E-01  0.71498E-01  0.87035E-01
+  0.93627E-01  0.10222E+00  0.11170E+00  0.11893E+00  0.12652E+00  0.13479E+00
+  0.14533E+00  0.15389E+00  0.16150E+00  0.17215E+00  0.18648E+00  0.20400E+00
+  0.37720E+00  0.23608E+00  0.24602E+00  0.26017E+00  0.22546E+00  0.15962E+00
+  0.23028E+00  0.10131E+01  0.25111E+01  0.60465E+01  0.12577E+02  0.24252E+02
+  0.47675E+02  0.86635E+02  0.13052E+03  0.49862E-01  0.63190E-01  0.80227E-01
+  0.10208E+00  0.13023E+00  0.16666E+00  0.20172E+00  0.21237E+00  0.22610E+00
+  0.24141E+00  0.25423E+00  0.26988E+00  0.28738E+00  0.30301E+00  0.31874E+00
+  0.34095E+00  0.37153E+00  0.40566E+00  0.46068E+00  0.90290E+00  0.58376E+00
+  0.68583E+00  0.77435E+00  0.89475E+00  0.76015E+00  0.36555E+00  0.53608E+00
+  0.31889E+01  0.83981E+01  0.18149E+02  0.38500E+02  0.79881E+02  0.14351E+03
+  0.87046E-01  0.11014E+00  0.13959E+00  0.17722E+00  0.22548E+00  0.28763E+00
+  0.36805E+00  0.44412E+00  0.46239E+00  0.48554E+00  0.51161E+00  0.53426E+00
+  0.56146E+00  0.59145E+00  0.62030E+00  0.66106E+00  0.71743E+00  0.78470E+00
+  0.87599E+00  0.10282E+01  0.20406E+01  0.13957E+01  0.16632E+01  0.20487E+01
+  0.22725E+01  0.24133E+01  0.23212E+01  0.85095E+00  0.25309E+01  0.95221E+01
+  0.25931E+02  0.61112E+02  0.12681E+03  0.14178E+00  0.17916E+00  0.22671E+00
+  0.28730E+00  0.36475E+00  0.46404E+00  0.59185E+00  0.75709E+00  0.91135E+00
+  0.94029E+00  0.97644E+00  0.10167E+01  0.10536E+01  0.10955E+01  0.11411E+01
+  0.12058E+01  0.12956E+01  0.14052E+01  0.15551E+01  0.17682E+01  0.20355E+01
+  0.24256E+01  0.29056E+01  0.36003E+01  0.42277E+01  0.49601E+01  0.57466E+01
+  0.55269E+01  0.40522E+01  0.00000E+00  0.12093E+02  0.41161E+02  0.97011E+02
+  0.22630E+00  0.28564E+00  0.36094E+00  0.45671E+00  0.57877E+00  0.73470E+00
+  0.93460E+00  0.11918E+01  0.15240E+01  0.18334E+01  0.18901E+01  0.19595E+01
+  0.20365E+01  0.21039E+01  0.21789E+01  0.22852E+01  0.24323E+01  0.26149E+01
+  0.28649E+01  0.32178E+01  0.36692E+01  0.43202E+01  0.51486E+01  0.63419E+01
+  0.76201E+01  0.92922E+01  0.11453E+02  0.13176E+02  0.14622E+02  0.15009E+02
+  0.95665E+01  0.95978E+01  0.50820E+02  0.35397E+00  0.44631E+00  0.56332E+00
+  0.71183E+00  0.90064E+00  0.11412E+01  0.14486E+01  0.18423E+01  0.23485E+01
+  0.30018E+01  0.36086E+01  0.37150E+01  0.38453E+01  0.39855E+01  0.41032E+01
+  0.42701E+01  0.45011E+01  0.47899E+01  0.51850E+01  0.57394E+01  0.64532E+01
+  0.74722E+01  0.87848E+01  0.10661E+02  0.12813E+02  0.15725E+02  0.19668E+02
+  0.23862E+02  0.28960E+02  0.34815E+02  0.37442E+02  0.30371E+02  0.76180E+01
+  0.52232E+00  0.65787E+00  0.82939E+00  0.10468E+01  0.13227E+01  0.16734E+01
+  0.21202E+01  0.26907E+01  0.34210E+01  0.43588E+01  0.55671E+01  0.66830E+01
+  0.68682E+01  0.70889E+01  0.73196E+01  0.75570E+01  0.78873E+01  0.83005E+01
+  0.88672E+01  0.96613E+01  0.10682E+02  0.12132E+02  0.13998E+02  0.16644E+02
+  0.19743E+02  0.23971E+02  0.29763E+02  0.36424E+02  0.45091E+02  0.56185E+02
+  0.66323E+02  0.70239E+02  0.64282E+02  0.78259E+00  0.98459E+00  0.12401E+01
+  0.15633E+01  0.19731E+01  0.24929E+01  0.31537E+01  0.39950E+01  0.50686E+01
+  0.64417E+01  0.82030E+01  0.10465E+02  0.12545E+02  0.12863E+02  0.13237E+02
+  0.13704E+02  0.14187E+02  0.14791E+02  0.15622E+02  0.16784E+02  0.18277E+02
+  0.20383E+02  0.23090E+02  0.26898E+02  0.31419E+02  0.37608E+02  0.46125E+02
+  0.56390E+02  0.70207E+02  0.88755E+02  0.10946E+03  0.12867E+03  0.14581E+03
+  0.11446E+01  0.14384E+01  0.18096E+01  0.22789E+01  0.28732E+01  0.36260E+01
+  0.45811E+01  0.57942E+01  0.73384E+01  0.93069E+01  0.11822E+02  0.15038E+02
+  0.19160E+02  0.22920E+02  0.23436E+02  0.24163E+02  0.25063E+02  0.25913E+02
+  0.27085E+02  0.28730E+02  0.30836E+02  0.33799E+02  0.37591E+02  0.42892E+02
+  0.49195E+02  0.57810E+02  0.69650E+02  0.84200E+02  0.10403E+03  0.13111E+03
+  0.16362E+03  0.19950E+03  0.24140E+03  0.16452E+01  0.20648E+01  0.25947E+01
+  0.32642E+01  0.41108E+01  0.51824E+01  0.65397E+01  0.82609E+01  0.10447E+02
+  0.13226E+02  0.16765E+02  0.21275E+02  0.27030E+02  0.34371E+02  0.41012E+02
+  0.41994E+02  0.43359E+02  0.44913E+02  0.46522E+02  0.48793E+02  0.51694E+02
+  0.55776E+02  0.60971E+02  0.68200E+02  0.76754E+02  0.88410E+02  0.10437E+03
+  0.12410E+03  0.15109E+03  0.18818E+03  0.23416E+03  0.28859E+03  0.35756E+03
+  0.22783E+01  0.28553E+01  0.35834E+01  0.45028E+01  0.56646E+01  0.71331E+01
+  0.89917E+01  0.11345E+02  0.14328E+02  0.18113E+02  0.22921E+02  0.29027E+02
+  0.36790E+02  0.46650E+02  0.59162E+02  0.70650E+02  0.72406E+02  0.74631E+02
+  0.77393E+02  0.80365E+02  0.84150E+02  0.89514E+02  0.96291E+02  0.10572E+03
+  0.11671E+03  0.13166E+03  0.15203E+03  0.17709E+03  0.21132E+03  0.25828E+03
+  0.31700E+03  0.38820E+03  0.48101E+03  0.31025E+01  0.38813E+01  0.48639E+01
+  0.61040E+01  0.76701E+01  0.96485E+01  0.12150E+02  0.15312E+02  0.19316E+02
+  0.24387E+02  0.30814E+02  0.38957E+02  0.49276E+02  0.62334E+02  0.78835E+02
+  0.10004E+03  0.11954E+03  0.12229E+03  0.12615E+03  0.13109E+03  0.13588E+03
+  0.14277E+03  0.15141E+03  0.16347E+03  0.17727E+03  0.19601E+03  0.22148E+03
+  0.25248E+03  0.29471E+03  0.35250E+03  0.42466E+03  0.51288E+03  0.62936E+03
+  0.40344E+01  0.50368E+01  0.63009E+01  0.78957E+01  0.99089E+01  0.12450E+02
+  0.15661E+02  0.19717E+02  0.24845E+02  0.31330E+02  0.39533E+02  0.49901E+02
+  0.63007E+02  0.79531E+02  0.10032E+03  0.12689E+03  0.16105E+03  0.19201E+03
+  0.19646E+03  0.20294E+03  0.21039E+03  0.21866E+03  0.22892E+03  0.24343E+03
+  0.25949E+03  0.28139E+03  0.31115E+03  0.34662E+03  0.39488E+03  0.46063E+03
+  0.54152E+03  0.63922E+03  0.76806E+03  0.51426E+01  0.64041E+01  0.79949E+01
+  0.10001E+02  0.12533E+02  0.15727E+02  0.19759E+02  0.24850E+02  0.31278E+02
+  0.39400E+02  0.49657E+02  0.62594E+02  0.78905E+02  0.99409E+02  0.12511E+03
+  0.15780E+03  0.19958E+03  0.25267E+03  0.30122E+03  0.30854E+03  0.31789E+03
+  0.33032E+03  0.34198E+03  0.35886E+03  0.37664E+03  0.40121E+03  0.43478E+03
+  0.47362E+03  0.52664E+03  0.59876E+03  0.68552E+03  0.78796E+03  0.92247E+03
+  0.30443E-09  0.14653E-08  0.40166E-08  0.87578E-08  0.22530E-07  0.53713E-07
+  0.12521E-06  0.31173E-06  0.65187E-06  0.16722E-05  0.55311E-05  0.46913E-04
+  0.20408E-03  0.67794E-03  0.16281E-02  0.37210E-02  0.87135E-02  0.17900E-01
+  0.31256E-01  0.49047E-01  0.76018E-01  0.10903E+00  0.15570E+00  0.21543E+00
+  0.32052E+00  0.46592E+00  0.66582E+00  0.98835E+00  0.14354E+01  0.20512E+01
+  0.29956E+01  0.44291E+01  0.64259E+01  0.29799E-10  0.11814E-08  0.41432E-08
+  0.10468E-07  0.23168E-07  0.57902E-07  0.14961E-06  0.38030E-06  0.97853E-06
+  0.29817E-05  0.10535E-04  0.75092E-04  0.29878E-03  0.87388E-03  0.22085E-02
+  0.46838E-02  0.99608E-02  0.21992E-01  0.39692E-01  0.62176E-01  0.96229E-01
+  0.13785E+00  0.19666E+00  0.27186E+00  0.40413E+00  0.58705E+00  0.83822E+00
+  0.12434E+01  0.18041E+01  0.25756E+01  0.37570E+01  0.55473E+01  0.80351E+01
+  0.79908E-09  0.10403E-09  0.29928E-08  0.10385E-07  0.27191E-07  0.58353E-07
+  0.15349E-06  0.46346E-06  0.12792E-05  0.57233E-05  0.20721E-04  0.10303E-03
+  0.40715E-03  0.10835E-02  0.26345E-02  0.57858E-02  0.11573E-01  0.23907E-01
+  0.48481E-01  0.78950E-01  0.12198E+00  0.17448E+00  0.24862E+00  0.34334E+00
+  0.50997E+00  0.74019E+00  0.10560E+01  0.15653E+01  0.22696E+01  0.32372E+01
+  0.47175E+01  0.69575E+01  0.10064E+02  0.12967E-08  0.95227E-09  0.15967E-08
+  0.95201E-08  0.35125E-07  0.80624E-07  0.15211E-06  0.42991E-06  0.15240E-05
+  0.77602E-05  0.41470E-04  0.14018E-03  0.50004E-03  0.12819E-02  0.30918E-02
+  0.65780E-02  0.13414E-01  0.26384E-01  0.51174E-01  0.96121E-01  0.15489E+00
+  0.22117E+00  0.31469E+00  0.43407E+00  0.64406E+00  0.93397E+00  0.13315E+01
+  0.19720E+01  0.28571E+01  0.40723E+01  0.59292E+01  0.87359E+01  0.12622E+02
+  0.24942E-08  0.26186E-08  0.10420E-08  0.74091E-08  0.33463E-07  0.12534E-06
+  0.25941E-06  0.38585E-06  0.12043E-05  0.88269E-05  0.56888E-04  0.19497E-03
+  0.58525E-03  0.14727E-02  0.35107E-02  0.73948E-02  0.14706E-01  0.29176E-01
+  0.54644E-01  0.99703E-01  0.18818E+00  0.28084E+00  0.39889E+00  0.54941E+00
+  0.81423E+00  0.11796E+01  0.16801E+01  0.24864E+01  0.35997E+01  0.51269E+01
+  0.74590E+01  0.10980E+02  0.15849E+02  0.52158E-08  0.53006E-08  0.49332E-08
+  0.00000E+00  0.31800E-07  0.13094E-06  0.42996E-06  0.81645E-06  0.98577E-06
+  0.75938E-05  0.63107E-04  0.23849E-03  0.67418E-03  0.16460E-02  0.38578E-02
+  0.80831E-02  0.15992E-01  0.30988E-01  0.58549E-01  0.10431E+00  0.19304E+00
+  0.34090E+00  0.50647E+00  0.69635E+00  0.10305E+01  0.14911E+01  0.21218E+01
+  0.31374E+01  0.45386E+01  0.64588E+01  0.93897E+01  0.13812E+02  0.19919E+02
+  0.27477E-07  0.34297E-07  0.66407E-07  0.13020E-06  0.16188E-06  0.29398E-06
+  0.27136E-07  0.14753E-05  0.41088E-05  0.52460E-05  0.52698E-04  0.23947E-03
+  0.71155E-03  0.17760E-02  0.41436E-02  0.85167E-02  0.16847E-01  0.32524E-01
+  0.60666E-01  0.10891E+00  0.19826E+00  0.34657E+00  0.61226E+00  0.88088E+00
+  0.13021E+01  0.18822E+01  0.26760E+01  0.39542E+01  0.57165E+01  0.81306E+01
+  0.11814E+02  0.17369E+02  0.25032E+02  0.58970E-07  0.88331E-07  0.13363E-06
+  0.37065E-06  0.71791E-06  0.14784E-05  0.20904E-05  0.42869E-06  0.83168E-05
+  0.26249E-04  0.60789E-04  0.23413E-03  0.73190E-03  0.19053E-02  0.45198E-02
+  0.92207E-02  0.17588E-01  0.33943E-01  0.63111E-01  0.11210E+00  0.20453E+00
+  0.35444E+00  0.62314E+00  0.10658E+01  0.16488E+01  0.23800E+01  0.33798E+01
+  0.49899E+01  0.72084E+01  0.10245E+02  0.14877E+02  0.21859E+02  0.31484E+02
+  0.41382E-07  0.60888E-07  0.11565E-06  0.11952E-06  0.24181E-06  0.16790E-05
+  0.55346E-05  0.14848E-04  0.36094E-04  0.78776E-04  0.15955E-03  0.39645E-03
+  0.92618E-03  0.22256E-02  0.51490E-02  0.10426E-01  0.19602E-01  0.36914E-01
+  0.67210E-01  0.11846E+00  0.21259E+00  0.36887E+00  0.64539E+00  0.10971E+01
+  0.20147E+01  0.30393E+01  0.43055E+01  0.63427E+01  0.91466E+01  0.12981E+02
+  0.18825E+02  0.27627E+02  0.39751E+02  0.27937E-06  0.43732E-06  0.58123E-06
+  0.60157E-06  0.94212E-07  0.23736E-05  0.89216E-05  0.22989E-04  0.52433E-04
+  0.11599E-03  0.24088E-03  0.50686E-03  0.14700E-02  0.26572E-02  0.57138E-02
+  0.11400E-01  0.21347E-01  0.39470E-01  0.71412E-01  0.12451E+00  0.22010E+00
+  0.37828E+00  0.66521E+00  0.11267E+01  0.20579E+01  0.36897E+01  0.54672E+01
+  0.80400E+01  0.11577E+02  0.16412E+02  0.23776E+02  0.34862E+02  0.50119E+02
+  0.39349E-06  0.87718E-06  0.16067E-05  0.23256E-05  0.22053E-05  0.39686E-06
+  0.75753E-05  0.25825E-04  0.63405E-04  0.14353E-03  0.30754E-03  0.65402E-03
+  0.13925E-02  0.49980E-02  0.68942E-02  0.12612E-01  0.23226E-01  0.42497E-01
+  0.75621E-01  0.13044E+00  0.22929E+00  0.38991E+00  0.68154E+00  0.11603E+01
+  0.21119E+01  0.37666E+01  0.66337E+01  0.10205E+02  0.14670E+02  0.20766E+02
+  0.30050E+02  0.44018E+02  0.63230E+02  0.28837E-04  0.38241E-04  0.56118E-04
+  0.83585E-04  0.12261E-03  0.16030E-03  0.20357E-03  0.24329E-03  0.27605E-03
+  0.28059E-03  0.22465E-03  0.15102E-04  0.68965E-03  0.22880E-02  0.12895E-01
+  0.12139E-01  0.22074E-01  0.41069E-01  0.73568E-01  0.12701E+00  0.22360E+00
+  0.37972E+00  0.66413E+00  0.11297E+01  0.20837E+01  0.37250E+01  0.65549E+01
+  0.12045E+02  0.18179E+02  0.25761E+02  0.37333E+02  0.54768E+02  0.78751E+02
+  0.17158E-03  0.22398E-03  0.29465E-03  0.39104E-03  0.47734E-03  0.57427E-03
+  0.70496E-03  0.82740E-03  0.95555E-03  0.10304E-02  0.10281E-02  0.80142E-03
+  0.10790E-03  0.19908E-02  0.65667E-02  0.13818E-01  0.55906E-01  0.47680E-01
+  0.82556E-01  0.13955E+00  0.24128E+00  0.40255E+00  0.69450E+00  0.11667E+01
+  0.21362E+01  0.38316E+01  0.67749E+01  0.12384E+02  0.22154E+02  0.39107E+02
+  0.59255E+02  0.86819E+02  0.12468E+03  0.39356E-04  0.50320E-04  0.64256E-04
+  0.81649E-04  0.10171E-03  0.10856E-03  0.99940E-04  0.72210E-04  0.00000E+00
+  0.24909E-03  0.71687E-03  0.16756E-02  0.34921E-02  0.70106E-02  0.13772E-01
+  0.23937E-01  0.39578E-01  0.12607E+00  0.11294E+00  0.17902E+00  0.29761E+00
+  0.48234E+00  0.80993E+00  0.13332E+01  0.23857E+01  0.42047E+01  0.73327E+01
+  0.13359E+02  0.23681E+02  0.41377E+02  0.74207E+02  0.11457E+03  0.16371E+03
+  0.72982E-03  0.94130E-03  0.12209E-02  0.15940E-02  0.20960E-02  0.27785E-02
+  0.32844E-02  0.36412E-02  0.40921E-02  0.45119E-02  0.48558E-02  0.49694E-02
+  0.45269E-02  0.26975E-02  0.25101E-02  0.11336E-01  0.24766E-01  0.49094E-01
+  0.13927E+00  0.15148E+00  0.25378E+00  0.41680E+00  0.71133E+00  0.11792E+01
+  0.21521E+01  0.38408E+01  0.67560E+01  0.12454E+02  0.22464E+02  0.39550E+02
+  0.71247E+02  0.13037E+03  0.20099E+03  0.11963E-02  0.15356E-02  0.19803E-02
+  0.25681E-02  0.33505E-02  0.44018E-02  0.58236E-02  0.68943E-02  0.74958E-02
+  0.81914E-02  0.88149E-02  0.91169E-02  0.88286E-02  0.69469E-02  0.17176E-02
+  0.80894E-02  0.23214E-01  0.50258E-01  0.92338E-01  0.19972E+00  0.27384E+00
+  0.43303E+00  0.73377E+00  0.12053E+01  0.21921E+01  0.38942E+01  0.68180E+01
+  0.12537E+02  0.22552E+02  0.39956E+02  0.72067E+02  0.13145E+03  0.23543E+03
+  0.18824E-02  0.24075E-02  0.30915E-02  0.39883E-02  0.51724E-02  0.67482E-02
+  0.88592E-02  0.11709E-01  0.13926E-01  0.14863E-01  0.15858E-01  0.16519E-01
+  0.16384E-01  0.14456E-01  0.87345E-02  0.00000E+00  0.17382E-01  0.48026E-01
+  0.94212E-01  0.16122E+00  0.27794E+00  0.44946E+00  0.75789E+00  0.12338E+01
+  0.22388E+01  0.39589E+01  0.68959E+01  0.12646E+02  0.22677E+02  0.40057E+02
+  0.72706E+02  0.13293E+03  0.23726E+03  0.27543E-02  0.35105E-02  0.44893E-02
+  0.57635E-02  0.74319E-02  0.96314E-02  0.12548E-01  0.16443E-01  0.21663E-01
+  0.25904E-01  0.27371E-01  0.28588E-01  0.28878E-01  0.26770E-01  0.20112E-01
+  0.10419E-01  0.58607E-02  0.42018E-01  0.94460E-01  0.16761E+00  0.29363E+00
+  0.47314E+00  0.79485E+00  0.12815E+01  0.23187E+01  0.40756E+01  0.70513E+01
+  0.12877E+02  0.22984E+02  0.40423E+02  0.73155E+02  0.13447E+03  0.24055E+03
+  0.37494E-02  0.47642E-02  0.60714E-02  0.77626E-02  0.99601E-02  0.12833E-01
+  0.16605E-01  0.21586E-01  0.28184E-01  0.36856E-01  0.44145E-01  0.45621E-01
+  0.46079E-01  0.43517E-01  0.34800E-01  0.22834E-01  0.55224E-02  0.37837E-01
+  0.10159E+00  0.18658E+00  0.33017E+00  0.52727E+00  0.87704E+00  0.13931E+01
+  0.24970E+01  0.43388E+01  0.74213E+01  0.13434E+02  0.23777E+02  0.41508E+02
+  0.74689E+02  0.13667E+03  0.24517E+03  0.51763E-02  0.65607E-02  0.83355E-02
+  0.10620E-01  0.13571E-01  0.17402E-01  0.22391E-01  0.28919E-01  0.37480E-01
+  0.48623E-01  0.63005E-01  0.75000E-01  0.75402E-01  0.72121E-01  0.61104E-01
+  0.46056E-01  0.25398E-01  0.19694E-01  0.99247E-01  0.20014E+00  0.36704E+00
+  0.58647E+00  0.97213E+00  0.15246E+01  0.27140E+01  0.46638E+01  0.78809E+01
+  0.14131E+02  0.24775E+02  0.42875E+02  0.76627E+02  0.13945E+03  0.24898E+03
+  0.70718E-02  0.89420E-02  0.11331E-01  0.14395E-01  0.18331E-01  0.23410E-01
+  0.29980E-01  0.38508E-01  0.49596E-01  0.63901E-01  0.82210E-01  0.10474E+00
+  0.12319E+00  0.11811E+00  0.10322E+00  0.84299E-01  0.58492E-01  0.11526E-01
+  0.84889E-01  0.20951E+00  0.41062E+00  0.66242E+00  0.10997E+01  0.17046E+01
+  0.30159E+01  0.51193E+01  0.85304E+01  0.15120E+02  0.26199E+02  0.44850E+02
+  0.79456E+02  0.14357E+03  0.25470E+03  0.97171E-02  0.12258E-01  0.15494E-01
+  0.19625E-01  0.24913E-01  0.31694E-01  0.40410E-01  0.51635E-01  0.66097E-01
+  0.84577E-01  0.10799E+00  0.13654E+00  0.16967E+00  0.19293E+00  0.17001E+00
+  0.14311E+00  0.10904E+00  0.47228E-01  0.60484E-01  0.22300E+00  0.47752E+00
+  0.78019E+00  0.12969E+01  0.19841E+01  0.34779E+01  0.58126E+01  0.95184E+01
+  0.16616E+02  0.28356E+02  0.47863E+02  0.83801E+02  0.14992E+03  0.26368E+03
+  0.12889E-01  0.16224E-01  0.20463E-01  0.25860E-01  0.32739E-01  0.41533E-01
+  0.52774E-01  0.67174E-01  0.85604E-01  0.10899E+00  0.13839E+00  0.17402E+00
+  0.21524E+00  0.25674E+00  0.27467E+00  0.23544E+00  0.18885E+00  0.10806E+00
+  0.00000E+00  0.22027E+00  0.55462E+00  0.93158E+00  0.15628E+01  0.23664E+01
+  0.41173E+01  0.67735E+01  0.10886E+02  0.18680E+02  0.31325E+02  0.52007E+02
+  0.89770E+02  0.15865E+03  0.27603E+03  0.17339E-01  0.21775E-01  0.27401E-01
+  0.34546E-01  0.43628E-01  0.55187E-01  0.69904E-01  0.88648E-01  0.11248E+00
+  0.14250E+00  0.17993E+00  0.22490E+00  0.27650E+00  0.32830E+00  0.36457E+00
+  0.38340E+00  0.31318E+00  0.19856E+00  0.52415E-01  0.21421E+00  0.67344E+00
+  0.11657E+01  0.19709E+01  0.29501E+01  0.50798E+01  0.82041E+01  0.12905E+02
+  0.21694E+02  0.35628E+02  0.57988E+02  0.98347E+02  0.17114E+03  0.29373E+03
+  0.22214E-01  0.27831E-01  0.34943E-01  0.43958E-01  0.55391E-01  0.69905E-01
+  0.88317E-01  0.11167E+00  0.14123E+00  0.17824E+00  0.22407E+00  0.27872E+00
+  0.34092E+00  0.40292E+00  0.44652E+00  0.48124E+00  0.48874E+00  0.32304E+00
+  0.12086E+00  0.21241E+00  0.86779E+00  0.15390E+01  0.26096E+01  0.38527E+01
+  0.65411E+01  0.10345E+02  0.15889E+02  0.26089E+02  0.41833E+02  0.66542E+02
+  0.11052E+03  0.18874E+03  0.31856E+03  0.29934E-01  0.37399E-01  0.46840E-01
+  0.58787E-01  0.73909E-01  0.93056E-01  0.11728E+00  0.14789E+00  0.18648E+00
+  0.23455E+00  0.29377E+00  0.36403E+00  0.44362E+00  0.52299E+00  0.58038E+00
+  0.62853E+00  0.65418E+00  0.56993E+00  0.27902E+00  0.79320E-01  0.10336E+01
+  0.19688E+01  0.34258E+01  0.50402E+01  0.85212E+01  0.13266E+02  0.19952E+02
+  0.32056E+02  0.50202E+02  0.77977E+02  0.12665E+03  0.21190E+03  0.35100E+03
+  0.37892E-01  0.47191E-01  0.58945E-01  0.73797E-01  0.92571E-01  0.11630E+00
+  0.14624E+00  0.18399E+00  0.23139E+00  0.29021E+00  0.36231E+00  0.44730E+00
+  0.54283E+00  0.63715E+00  0.70427E+00  0.75979E+00  0.78869E+00  0.69186E+00
+  0.44448E+00  0.00000E+00  0.14155E+01  0.27920E+01  0.48619E+01  0.70588E+01
+  0.11752E+02  0.17912E+02  0.26293E+02  0.41179E+02  0.62787E+02  0.94948E+02
+  0.15029E+03  0.24543E+03  0.39754E+03  0.49848E-01  0.61852E-01  0.77009E-01
+  0.96144E-01  0.12029E+00  0.15077E+00  0.18915E+00  0.23740E+00  0.29780E+00
+  0.37249E+00  0.46357E+00  0.57034E+00  0.68951E+00  0.80608E+00  0.88779E+00
+  0.95440E+00  0.98818E+00  0.87195E+00  0.58339E+00  0.79063E-01  0.19547E+01
+  0.39665E+01  0.70144E+01  0.10096E+02  0.16598E+02  0.24828E+02  0.35635E+02
+  0.54466E+02  0.80891E+02  0.11905E+03  0.18344E+03  0.29188E+03  0.46129E+03
+  0.63529E-01  0.78483E-01  0.97343E-01  0.12115E+00  0.15116E+00  0.18899E+00
+  0.23656E+00  0.29627E+00  0.37084E+00  0.46281E+00  0.57461E+00  0.70516E+00
+  0.85022E+00  0.99133E+00  0.10897E+01  0.11695E+01  0.12103E+01  0.10757E+01
+  0.74628E+00  0.18170E+00  0.26075E+01  0.57130E+01  0.10161E+02  0.14672E+02
+  0.23946E+02  0.35246E+02  0.49575E+02  0.74087E+02  0.10730E+03  0.15376E+03
+  0.23058E+03  0.35708E+03  0.54970E+03  0.84394E-01  0.10371E+00  0.12806E+00
+  0.15877E+00  0.19746E+00  0.24617E+00  0.30736E+00  0.38402E+00  0.47957E+00
+  0.59713E+00  0.73964E+00  0.90548E+00  0.10890E+01  0.12666E+01  0.13898E+01
+  0.14894E+01  0.15406E+01  0.13783E+01  0.98601E+00  0.32631E+00  0.28478E+01
+  0.79024E+01  0.14945E+02  0.21432E+02  0.35080E+02  0.51103E+02  0.70626E+02
+  0.10343E+03  0.14637E+03  0.20447E+03  0.29854E+03  0.44987E+03  0.67387E+03
+  0.10791E+00  0.13178E+00  0.16187E+00  0.19978E+00  0.24754E+00  0.30759E+00
+  0.38296E+00  0.47728E+00  0.59468E+00  0.73884E+00  0.91320E+00  0.11155E+01
+  0.13385E+01  0.15533E+01  0.17007E+01  0.18186E+01  0.18773E+01  0.16810E+01
+  0.12159E+01  0.44678E+00  0.33063E+01  0.94284E+01  0.21256E+02  0.32217E+02
+  0.52164E+02  0.75666E+02  0.10328E+03  0.14845E+03  0.20557E+03  0.28033E+03
+  0.39883E+03  0.58490E+03  0.85208E+03  0.14389E+00  0.17443E+00  0.21289E+00
+  0.26135E+00  0.32232E+00  0.39898E+00  0.49509E+00  0.61521E+00  0.76452E+00
+  0.94757E+00  0.11684E+01  0.14239E+01  0.17043E+01  0.19725E+01  0.21540E+01
+  0.22962E+01  0.23624E+01  0.21104E+01  0.15294E+01  0.58543E+00  0.39835E+01
+  0.11504E+02  0.25913E+02  0.45777E+02  0.79157E+02  0.11323E+03  0.15355E+03
+  0.21801E+03  0.29607E+03  0.39496E+03  0.54845E+03  0.78361E+03  0.11107E+04
+  0.18618E+00  0.22374E+00  0.27106E+00  0.33064E+00  0.40558E+00  0.49975E+00
+  0.61773E+00  0.76508E+00  0.94805E+00  0.11720E+01  0.14419E+01  0.17533E+01
+  0.20941E+01  0.24187E+01  0.26359E+01  0.28041E+01  0.28790E+01  0.25693E+01
+  0.18683E+01  0.74364E+00  0.48184E+01  0.14121E+02  0.31830E+02  0.55954E+02
+  0.11138E+03  0.17212E+03  0.23011E+03  0.32432E+03  0.43538E+03  0.56962E+03
+  0.77385E+03  0.10793E+04  0.14905E+04  0.23962E-09  0.11217E-08  0.30976E-08
+  0.55697E-08  0.15568E-07  0.20633E-07  0.40552E-07  0.81979E-07  0.17942E-06
+  0.37674E-06  0.77676E-06  0.33636E-05  0.24303E-04  0.88113E-04  0.40412E-03
+  0.13569E-02  0.31848E-02  0.64001E-02  0.11204E-01  0.17624E-01  0.27375E-01
+  0.39347E-01  0.56324E-01  0.78130E-01  0.11657E+00  0.17001E+00  0.24388E+00
+  0.36373E+00  0.53126E+00  0.76453E+00  0.11261E+01  0.16826E+01  0.24728E+01
+  0.28160E-10  0.92981E-09  0.31717E-08  0.80728E-08  0.14736E-07  0.37657E-07
+  0.54798E-07  0.10803E-06  0.24207E-06  0.47971E-06  0.10121E-05  0.58776E-05
+  0.44319E-04  0.11265E-03  0.51571E-03  0.17278E-02  0.40463E-02  0.81164E-02
+  0.14186E-01  0.22282E-01  0.34570E-01  0.49632E-01  0.70975E-01  0.98345E-01
+  0.14657E+00  0.21350E+00  0.30585E+00  0.45544E+00  0.66395E+00  0.95328E+00
+  0.14003E+01  0.20854E+01  0.30523E+01  0.45500E-09  0.53519E-09  0.31556E-08
+  0.88386E-08  0.22200E-07  0.38634E-07  0.84030E-07  0.15123E-06  0.28916E-06
+  0.62415E-06  0.13189E-05  0.92555E-05  0.74840E-04  0.22910E-03  0.66153E-03
+  0.22094E-02  0.51595E-02  0.10325E-01  0.18009E-01  0.28240E-01  0.43751E-01
+  0.62740E-01  0.89609E-01  0.12404E+00  0.18465E+00  0.26869E+00  0.38444E+00
+  0.57167E+00  0.83209E+00  0.11924E+01  0.17476E+01  0.25954E+01  0.37864E+01
+  0.18011E-08  0.56221E-09  0.18011E-08  0.88912E-08  0.24767E-07  0.61517E-07
+  0.11510E-06  0.24023E-06  0.44388E-06  0.10431E-05  0.23730E-05  0.25481E-04
+  0.12607E-03  0.45233E-03  0.11002E-02  0.29878E-02  0.69488E-02  0.13854E-01
+  0.24093E-01  0.37686E-01  0.58263E-01  0.83402E-01  0.11894E+00  0.16439E+00
+  0.24443E+00  0.35521E+00  0.50756E+00  0.75367E+00  0.10952E+01  0.15665E+01
+  0.22908E+01  0.33929E+01  0.49339E+01  0.39373E-08  0.27253E-08  0.82555E-09
+  0.80610E-08  0.27059E-07  0.69720E-07  0.16525E-06  0.40407E-06  0.82442E-06
+  0.20425E-05  0.65943E-05  0.54318E-04  0.23020E-03  0.74710E-03  0.17655E-02
+  0.39687E-02  0.91684E-02  0.18681E-01  0.32360E-01  0.50453E-01  0.77797E-01
+  0.11112E+00  0.15816E+00  0.21827E+00  0.32407E+00  0.47034E+00  0.67117E+00
+  0.99532E+00  0.14443E+01  0.20626E+01  0.30107E+01  0.44496E+01  0.64535E+01
+  0.68683E-08  0.66499E-08  0.36647E-08  0.59446E-08  0.31356E-07  0.81320E-07
+  0.19874E-06  0.60601E-06  0.14264E-05  0.45387E-05  0.15095E-04  0.96211E-04
+  0.37380E-03  0.10457E-02  0.25336E-02  0.53505E-02  0.10974E-01  0.23569E-01
+  0.43676E-01  0.67815E-01  0.10422E+00  0.14844E+00  0.21081E+00  0.29036E+00
+  0.43040E+00  0.62372E+00  0.88894E+00  0.13165E+01  0.19080E+01  0.27209E+01
+  0.39654E+01  0.58504E+01  0.84675E+01  0.46733E-07  0.62644E-07  0.75894E-07
+  0.92244E-07  0.87214E-07  0.47554E-07  0.51086E-07  0.37634E-06  0.16295E-05
+  0.77040E-05  0.33931E-04  0.14075E-03  0.52215E-03  0.13349E-02  0.32051E-02
+  0.67016E-02  0.13397E-01  0.26472E-01  0.52036E-01  0.91159E-01  0.13959E+00
+  0.19820E+00  0.28079E+00  0.38595E+00  0.57123E+00  0.82674E+00  0.11768E+01
+  0.17412E+01  0.25206E+01  0.35906E+01  0.52267E+01  0.77008E+01  0.11128E+02
+  0.92329E-07  0.12697E-06  0.18646E-06  0.26278E-06  0.27816E-06  0.33503E-06
+  0.14971E-06  0.10960E-06  0.11337E-05  0.94573E-05  0.59692E-04  0.20853E-03
+  0.65887E-03  0.16529E-02  0.38775E-02  0.80485E-02  0.15612E-01  0.30622E-01
+  0.56673E-01  0.10319E+00  0.18817E+00  0.26608E+00  0.37568E+00  0.51493E+00
+  0.76056E+00  0.10987E+01  0.15616E+01  0.23074E+01  0.33365E+01  0.47473E+01
+  0.69023E+01  0.10157E+02  0.14658E+02  0.28024E-06  0.32869E-06  0.46516E-06
+  0.70812E-06  0.11474E-05  0.14369E-05  0.18269E-05  0.11143E-05  0.11488E-06
+  0.46647E-05  0.59895E-04  0.25605E-03  0.76687E-03  0.18987E-02  0.44312E-02
+  0.91150E-02  0.17634E-01  0.33496E-01  0.62446E-01  0.10941E+00  0.20066E+00
+  0.35120E+00  0.50243E+00  0.68646E+00  0.10118E+01  0.14591E+01  0.20705E+01
+  0.30560E+01  0.44140E+01  0.62742E+01  0.91141E+01  0.13400E+02  0.19316E+02
+  0.38831E-06  0.44985E-06  0.86669E-06  0.17137E-05  0.23146E-05  0.55123E-05
+  0.82764E-05  0.80850E-05  0.29855E-05  0.34630E-05  0.54389E-04  0.29388E-03
+  0.91296E-03  0.22718E-02  0.51819E-02  0.10290E-01  0.19700E-01  0.36997E-01
+  0.67404E-01  0.11838E+00  0.21203E+00  0.36513E+00  0.63772E+00  0.92475E+00
+  0.13578E+01  0.19519E+01  0.27627E+01  0.40691E+01  0.58669E+01  0.83264E+01
+  0.12079E+02  0.17737E+02  0.25537E+02  0.92330E-06  0.15726E-05  0.28703E-05
+  0.56898E-05  0.96460E-05  0.16291E-04  0.24191E-04  0.33447E-04  0.21964E-04
+  0.19536E-04  0.93878E-04  0.33210E-03  0.10608E-02  0.27123E-02  0.62258E-02
+  0.12218E-01  0.21983E-01  0.41093E-01  0.73525E-01  0.12696E+00  0.22565E+00
+  0.38434E+00  0.66448E+00  0.11209E+01  0.18313E+01  0.26219E+01  0.36986E+01
+  0.54329E+01  0.78160E+01  0.11072E+02  0.16037E+02  0.23515E+02  0.33814E+02
+  0.81276E-05  0.13543E-04  0.23111E-04  0.45853E-04  0.75640E-04  0.10998E-03
+  0.13175E-03  0.14035E-03  0.12739E-03  0.59970E-04  0.91298E-04  0.43870E-03
+  0.15401E-02  0.31186E-02  0.71787E-02  0.14059E-01  0.25586E-01  0.45665E-01
+  0.80726E-01  0.13731E+00  0.23834E+00  0.40287E+00  0.69568E+00  0.11619E+01
+  0.21072E+01  0.35216E+01  0.49496E+01  0.72506E+01  0.10407E+02  0.14713E+02
+  0.21278E+02  0.31161E+02  0.44757E+02  0.32008E-04  0.68316E-04  0.11577E-03
+  0.17779E-03  0.22875E-03  0.28602E-03  0.32919E-03  0.35539E-03  0.34326E-03
+  0.25752E-03  0.37808E-04  0.46705E-03  0.15368E-02  0.99262E-02  0.89346E-02
+  0.16512E-01  0.29450E-01  0.52167E-01  0.89771E-01  0.14995E+00  0.25648E+00
+  0.42575E+00  0.72995E+00  0.12207E+01  0.21920E+01  0.38742E+01  0.66601E+01
+  0.97197E+01  0.13907E+02  0.19611E+02  0.28303E+02  0.41382E+02  0.59349E+02
+  0.14241E-03  0.18177E-03  0.26094E-03  0.37195E-03  0.51466E-03  0.61817E-03
+  0.71679E-03  0.76893E-03  0.76329E-03  0.64507E-03  0.34677E-03  0.37153E-03
+  0.18269E-02  0.49186E-02  0.29889E-01  0.20762E-01  0.35066E-01  0.60744E-01
+  0.10222E+00  0.16717E+00  0.28076E+00  0.45821E+00  0.77474E+00  0.12815E+01
+  0.23080E+01  0.40432E+01  0.70048E+01  0.12706E+02  0.18673E+02  0.26240E+02
+  0.37767E+02  0.55100E+02  0.78880E+02  0.61409E-03  0.78203E-03  0.99813E-03
+  0.12257E-02  0.14750E-02  0.17929E-02  0.20572E-02  0.22649E-02  0.23478E-02
+  0.22396E-02  0.18569E-02  0.98718E-03  0.95442E-03  0.48846E-02  0.12573E-01
+  0.33763E-01  0.41782E-01  0.69824E-01  0.11565E+00  0.18565E+00  0.30655E+00
+  0.49189E+00  0.82016E+00  0.13393E+01  0.23910E+01  0.42014E+01  0.72438E+01
+  0.13044E+02  0.23113E+02  0.35005E+02  0.50256E+02  0.73180E+02  0.10459E+03
+  0.18547E-02  0.23567E-02  0.30003E-02  0.38279E-02  0.46324E-02  0.51570E-02
+  0.58110E-02  0.64311E-02  0.67897E-02  0.68678E-02  0.65347E-02  0.54224E-02
+  0.30472E-02  0.20441E-02  0.11896E-01  0.25538E-01  0.46425E-01  0.10405E+00
+  0.12952E+00  0.20510E+00  0.33411E+00  0.52737E+00  0.86757E+00  0.13975E+01
+  0.24748E+01  0.43140E+01  0.74469E+01  0.13414E+02  0.23602E+02  0.41100E+02
+  0.66746E+02  0.97018E+02  0.13843E+03  0.44691E-02  0.56666E-02  0.71964E-02
+  0.91561E-02  0.11666E-01  0.14450E-01  0.15310E-01  0.16356E-01  0.17445E-01
+  0.17699E-01  0.17460E-01  0.16050E-01  0.12987E-01  0.61375E-02  0.69529E-02
+  0.24158E-01  0.47766E-01  0.88212E-01  0.36955E+00  0.22836E+00  0.36834E+00
+  0.57210E+00  0.92844E+00  0.14731E+01  0.25861E+01  0.44666E+01  0.76438E+01
+  0.13769E+02  0.24293E+02  0.41983E+02  0.74763E+02  0.12890E+03  0.18351E+03
+  0.89178E-02  0.11286E-01  0.14303E-01  0.18153E-01  0.23067E-01  0.29349E-01
+  0.37357E-01  0.39065E-01  0.40486E-01  0.41861E-01  0.41658E-01  0.39938E-01
+  0.35738E-01  0.26090E-01  0.78712E-02  0.14796E-01  0.44338E-01  0.92571E-01
+  0.16075E+00  0.97087E+00  0.40933E+00  0.62730E+00  0.10059E+01  0.15711E+01
+  0.27351E+01  0.46757E+01  0.79201E+01  0.14167E+02  0.24899E+02  0.43265E+02
+  0.76485E+02  0.13787E+03  0.24394E+03  0.15614E-01  0.19730E-01  0.24958E-01
+  0.31609E-01  0.40068E-01  0.50837E-01  0.64517E-01  0.81865E-01  0.88208E-01
+  0.89099E-01  0.89205E-01  0.86052E-01  0.78660E-01  0.63879E-01  0.36672E-01
+  0.44903E-02  0.35299E-01  0.98328E-01  0.18335E+00  0.29426E+00  0.10559E+01
+  0.71757E+00  0.11352E+01  0.17403E+01  0.29937E+01  0.50461E+01  0.84283E+01
+  0.14914E+02  0.25942E+02  0.44671E+02  0.79394E+02  0.14229E+03  0.25055E+03
+  0.24699E-01  0.31166E-01  0.39362E-01  0.49761E-01  0.62951E-01  0.79690E-01
+  0.10088E+00  0.12766E+00  0.16128E+00  0.18049E+00  0.17984E+00  0.17553E+00
+  0.16405E+00  0.13995E+00  0.97263E-01  0.49041E-01  0.76918E-02  0.94615E-01
+  0.20622E+00  0.34412E+00  0.56302E+00  0.84356E+00  0.13197E+01  0.19855E+01
+  0.33728E+01  0.55939E+01  0.91876E+01  0.16038E+02  0.27530E+02  0.46838E+02
+  0.82450E+02  0.14812E+03  0.25978E+03  0.40389E-01  0.50905E-01  0.64204E-01
+  0.81052E-01  0.10238E+00  0.12939E+00  0.16352E+00  0.20659E+00  0.26062E+00
+  0.32726E+00  0.38096E+00  0.37348E+00  0.35664E+00  0.32058E+00  0.25270E+00
+  0.17906E+00  0.96430E-01  0.26372E-01  0.17622E+00  0.35048E+00  0.62068E+00
+  0.94696E+00  0.14955E+01  0.22302E+01  0.37854E+01  0.62115E+01  0.10055E+02
+  0.17348E+02  0.29390E+02  0.49364E+02  0.86010E+02  0.15322E+03  0.26869E+03
+  0.62586E-01  0.78780E-01  0.99251E-01  0.12512E+00  0.15784E+00  0.19918E+00
+  0.25133E+00  0.31701E+00  0.39927E+00  0.50082E+00  0.62401E+00  0.75032E+00
+  0.72018E+00  0.66133E+00  0.55621E+00  0.43750E+00  0.30921E+00  0.12452E+00
+  0.90493E-01  0.32624E+00  0.68140E+00  0.10835E+01  0.17501E+01  0.25989E+01
+  0.44209E+01  0.71739E+01  0.11421E+02  0.19419E+02  0.32354E+02  0.53454E+02
+  0.91850E+02  0.16169E+03  0.28049E+03  0.98103E-01  0.12333E+00  0.15518E+00
+  0.19541E+00  0.24621E+00  0.31033E+00  0.39112E+00  0.49273E+00  0.61995E+00
+  0.77719E+00  0.96877E+00  0.11925E+01  0.14402E+01  0.13784E+01  0.12045E+01
+  0.10241E+01  0.82099E+00  0.53429E+00  0.21453E+00  0.11654E+00  0.60092E+00
+  0.11120E+01  0.19475E+01  0.29504E+01  0.51495E+01  0.83529E+01  0.13145E+02
+  0.22104E+02  0.36240E+02  0.58842E+02  0.99584E+02  0.17296E+03  0.29623E+03
+  0.14638E+00  0.18376E+00  0.23092E+00  0.29044E+00  0.36552E+00  0.46016E+00
+  0.57927E+00  0.72892E+00  0.91604E+00  0.11473E+01  0.14294E+01  0.17608E+01
+  0.21327E+01  0.25029E+01  0.23962E+01  0.20902E+01  0.17733E+01  0.13133E+01
+  0.80827E+00  0.30822E+00  0.40052E+00  0.11022E+01  0.22251E+01  0.34928E+01
+  0.63075E+01  0.10240E+02  0.15911E+02  0.26387E+02  0.42427E+02  0.67434E+02
+  0.11192E+03  0.19092E+03  0.32149E+03  0.20556E+00  0.25761E+00  0.32324E+00
+  0.40601E+00  0.51031E+00  0.64170E+00  0.80685E+00  0.10139E+01  0.12725E+01
+  0.15917E+01  0.19803E+01  0.24368E+01  0.29500E+01  0.34658E+01  0.38692E+01
+  0.38339E+01  0.32833E+01  0.25300E+01  0.17078E+01  0.89885E+00  0.21269E+00
+  0.12627E+01  0.28956E+01  0.46403E+01  0.84968E+01  0.13649E+02  0.20785E+02
+  0.33717E+02  0.52824E+02  0.81720E+02  0.13218E+03  0.22012E+03  0.36244E+03
+  0.28147E+00  0.35199E+00  0.44089E+00  0.55293E+00  0.69404E+00  0.87159E+00
+  0.10946E+01  0.13738E+01  0.17220E+01  0.21509E+01  0.26722E+01  0.32833E+01
+  0.39691E+01  0.46587E+01  0.52028E+01  0.57114E+01  0.57991E+01  0.45015E+01
+  0.31321E+01  0.18101E+01  0.00000E+00  0.16521E+01  0.41483E+01  0.66920E+01
+  0.12247E+02  0.19350E+02  0.28781E+02  0.45497E+02  0.69253E+02  0.10396E+03
+  0.16327E+03  0.26431E+03  0.42373E+03  0.38156E+00  0.47596E+00  0.59487E+00
+  0.74468E+00  0.93324E+00  0.11704E+01  0.14678E+01  0.18401E+01  0.23034E+01
+  0.28735E+01  0.35649E+01  0.43736E+01  0.52791E+01  0.61867E+01  0.69017E+01
+  0.75676E+01  0.81033E+01  0.78207E+01  0.54747E+01  0.32588E+01  0.28555E+00
+  0.23943E+01  0.63412E+01  0.10205E+02  0.18523E+02  0.28732E+02  0.41740E+02
+  0.64269E+02  0.95006E+02  0.13829E+03  0.21050E+03  0.33040E+03  0.51414E+03
+  0.51920E+00  0.64556E+00  0.80467E+00  0.10051E+01  0.12572E+01  0.15741E+01
+  0.19714E+01  0.24681E+01  0.30859E+01  0.38451E+01  0.47647E+01  0.58384E+01
+  0.70390E+01  0.82410E+01  0.91887E+01  0.10072E+02  0.10785E+02  0.10507E+02
+  0.92726E+01  0.58906E+01  0.94228E+00  0.34615E+01  0.98520E+01  0.15891E+02
+  0.28726E+02  0.43904E+02  0.62502E+02  0.94013E+02  0.13528E+03  0.19120E+03
+  0.28220E+03  0.42924E+03  0.64737E+03  0.70114E+00  0.86820E+00  0.10786E+01
+  0.13434E+01  0.16764E+01  0.20949E+01  0.26193E+01  0.32744E+01  0.40885E+01
+  0.50875E+01  0.62962E+01  0.77041E+01  0.92739E+01  0.10839E+02  0.12060E+02
+  0.13185E+02  0.14076E+02  0.13662E+02  0.12002E+02  0.90964E+01  0.15756E+01
+  0.57238E+01  0.16271E+02  0.26063E+02  0.46429E+02  0.69751E+02  0.97333E+02
+  0.14310E+03  0.20070E+03  0.27579E+03  0.39495E+03  0.58204E+03  0.84995E+03
+  0.96444E+00  0.11881E+01  0.14697E+01  0.18241E+01  0.22698E+01  0.28296E+01
+  0.35307E+01  0.44063E+01  0.54939E+01  0.68279E+01  0.84406E+01  0.10320E+02
+  0.12413E+02  0.14501E+02  0.16141E+02  0.17660E+02  0.18877E+02  0.18402E+02
+  0.16330E+02  0.12693E+02  0.34855E+01  0.82208E+01  0.25554E+02  0.41546E+02
+  0.74801E+02  0.11147E+03  0.15349E+03  0.22196E+03  0.30499E+03  0.40919E+03
+  0.57060E+03  0.81689E+03  0.11567E+04  0.13205E+01  0.16163E+01  0.19887E+01
+  0.24575E+01  0.30466E+01  0.37863E+01  0.47127E+01  0.58691E+01  0.73047E+01
+  0.90641E+01  0.11189E+02  0.13662E+02  0.16412E+02  0.19147E+02  0.21280E+02
+  0.23245E+02  0.24799E+02  0.24118E+02  0.21343E+02  0.16533E+02  0.45210E+01
+  0.11577E+02  0.42907E+02  0.69047E+02  0.12347E+03  0.18383E+03  0.24972E+03
+  0.35535E+03  0.47919E+03  0.62915E+03  0.85611E+03  0.11929E+04  0.16402E+04
+  0.18249E+01  0.22162E+01  0.27088E+01  0.33286E+01  0.41077E+01  0.50856E+01
+  0.63097E+01  0.78376E+01  0.97333E+01  0.12055E+02  0.14858E+02  0.18115E+02
+  0.21733E+02  0.25322E+02  0.28105E+02  0.30655E+02  0.32652E+02  0.31696E+02
+  0.27988E+02  0.21622E+02  0.58931E+01  0.15031E+02  0.57691E+02  0.11528E+03
+  0.20566E+03  0.30332E+03  0.41265E+03  0.57986E+03  0.76990E+03  0.99261E+03
+  0.13226E+04  0.17994E+04  0.24092E+04  0.25510E+01  0.30686E+01  0.37202E+01
+  0.45400E+01  0.55702E+01  0.68633E+01  0.84817E+01  0.10501E+02  0.13006E+02
+  0.16071E+02  0.19770E+02  0.24064E+02  0.28827E+02  0.33543E+02  0.37182E+02
+  0.40500E+02  0.43077E+02  0.41752E+02  0.36800E+02  0.28369E+02  0.77120E+01
+  0.19608E+02  0.74971E+02  0.14910E+03  0.32801E+03  0.50645E+03  0.68110E+03
+  0.95794E+03  0.12602E+04  0.16006E+04  0.20954E+04  0.27932E+04  0.36538E+04
+  0.12093E-09  0.10470E-08  0.30563E-08  0.63577E-08  0.13919E-07  0.28990E-07
+  0.48280E-07  0.95464E-07  0.21264E-06  0.43101E-06  0.89935E-06  0.46752E-05
+  0.33365E-04  0.10097E-03  0.46269E-03  0.15518E-02  0.36381E-02  0.73037E-02
+  0.12775E-01  0.20079E-01  0.31168E-01  0.44775E-01  0.64053E-01  0.88800E-01
+  0.13240E+00  0.19297E+00  0.27660E+00  0.41216E+00  0.60134E+00  0.86422E+00
+  0.12709E+01  0.18954E+01  0.27790E+01  0.23113E-09  0.81583E-09  0.32009E-08
+  0.82162E-08  0.17112E-07  0.35814E-07  0.69170E-07  0.12950E-06  0.26637E-06
+  0.55155E-06  0.11720E-05  0.76268E-05  0.60165E-04  0.16429E-03  0.59178E-03
+  0.19794E-02  0.46287E-02  0.92725E-02  0.16190E-01  0.25407E-01  0.39388E-01
+  0.56514E-01  0.80760E-01  0.11184E+00  0.16658E+00  0.24250E+00  0.34716E+00
+  0.51654E+00  0.75235E+00  0.10790E+01  0.15829E+01  0.23536E+01  0.34383E+01
+  0.77472E-09  0.42801E-09  0.31995E-08  0.92826E-08  0.22980E-07  0.45273E-07
+  0.98560E-07  0.17910E-06  0.34545E-06  0.79358E-06  0.15320E-05  0.14891E-04
+  0.95860E-04  0.32142E-03  0.82400E-03  0.25340E-02  0.59065E-02  0.11801E-01
+  0.20557E-01  0.32202E-01  0.49843E-01  0.71419E-01  0.10193E+00  0.14102E+00
+  0.20981E+00  0.30511E+00  0.43628E+00  0.64832E+00  0.94292E+00  0.13500E+01
+  0.19764E+01  0.29314E+01  0.42699E+01  0.22481E-08  0.99924E-09  0.21355E-08
+  0.90699E-08  0.25593E-07  0.59899E-07  0.12930E-06  0.30019E-06  0.50677E-06
+  0.13077E-05  0.33463E-05  0.31902E-04  0.15140E-03  0.53048E-03  0.12641E-02
+  0.32309E-02  0.75621E-02  0.15059E-01  0.26162E-01  0.40888E-01  0.63171E-01
+  0.90373E-01  0.12882E+00  0.17798E+00  0.26452E+00  0.38427E+00  0.54888E+00
+  0.81472E+00  0.11834E+01  0.16919E+01  0.24728E+01  0.36601E+01  0.53180E+01
+  0.41405E-08  0.32713E-08  0.24403E-09  0.84752E-08  0.27836E-07  0.70173E-07
+  0.17397E-06  0.42461E-06  0.89398E-06  0.21276E-05  0.72198E-05  0.58457E-04
+  0.24365E-03  0.77338E-03  0.18501E-02  0.40924E-02  0.93311E-02  0.19284E-01
+  0.33389E-01  0.52037E-01  0.80214E-01  0.11454E+00  0.16300E+00  0.22491E+00
+  0.33386E+00  0.48448E+00  0.69132E+00  0.10250E+01  0.14872E+01  0.21235E+01
+  0.30990E+01  0.45792E+01  0.66401E+01  0.75803E-08  0.79816E-08  0.51929E-08
+  0.38736E-08  0.26906E-07  0.75055E-07  0.19479E-06  0.57000E-06  0.13575E-05
+  0.42209E-05  0.14196E-04  0.93227E-04  0.36184E-03  0.10200E-02  0.24913E-02
+  0.52351E-02  0.10823E-01  0.23383E-01  0.42752E-01  0.66404E-01  0.10208E+00
+  0.14543E+00  0.20657E+00  0.28456E+00  0.42187E+00  0.61143E+00  0.87147E+00
+  0.12909E+01  0.18710E+01  0.26684E+01  0.38893E+01  0.57387E+01  0.83072E+01
+  0.59879E-07  0.72274E-07  0.91450E-07  0.11366E-06  0.11295E-06  0.82541E-07
+  0.46571E-08  0.24558E-06  0.13508E-05  0.68488E-05  0.27044E-04  0.12706E-03
+  0.48709E-03  0.12657E-02  0.30395E-02  0.64638E-02  0.12831E-01  0.25774E-01
+  0.51208E-01  0.86098E-01  0.13198E+00  0.18757E+00  0.26592E+00  0.36572E+00
+  0.54159E+00  0.78418E+00  0.11166E+01  0.16527E+01  0.23934E+01  0.34102E+01
+  0.49655E+01  0.73185E+01  0.10579E+02  0.10113E-06  0.13922E-06  0.21365E-06
+  0.28754E-06  0.34242E-06  0.33358E-06  0.20024E-06  0.43764E-07  0.98934E-06
+  0.85715E-05  0.54926E-04  0.18863E-03  0.62595E-03  0.15811E-02  0.37321E-02
+  0.78078E-02  0.15225E-01  0.29770E-01  0.55686E-01  0.10205E+00  0.17905E+00
+  0.25341E+00  0.35809E+00  0.49113E+00  0.72580E+00  0.10490E+01  0.14915E+01
+  0.22047E+01  0.31888E+01  0.45382E+01  0.66003E+01  0.97154E+01  0.14024E+02
+  0.27709E-06  0.33340E-06  0.48440E-06  0.75802E-06  0.11802E-05  0.14024E-05
+  0.18260E-05  0.11087E-05  0.20990E-06  0.41354E-05  0.55822E-04  0.24135E-03
+  0.73385E-03  0.18378E-02  0.43179E-02  0.89098E-02  0.17335E-01  0.32945E-01
+  0.61511E-01  0.10810E+00  0.19907E+00  0.34238E+00  0.48205E+00  0.65906E+00
+  0.97202E+00  0.14024E+01  0.19909E+01  0.29394E+01  0.42470E+01  0.60383E+01
+  0.87734E+01  0.12902E+02  0.18603E+02  0.42244E-06  0.51801E-06  0.92637E-06
+  0.17625E-05  0.23797E-05  0.57189E-05  0.79531E-05  0.83665E-05  0.41146E-05
+  0.19631E-05  0.49800E-04  0.27799E-03  0.87077E-03  0.21873E-02  0.50317E-02
+  0.10073E-01  0.19371E-01  0.36479E-01  0.66514E-01  0.11721E+00  0.20998E+00
+  0.36243E+00  0.63383E+00  0.89290E+00  0.13121E+01  0.18873E+01  0.26726E+01
+  0.39382E+01  0.56804E+01  0.80639E+01  0.11701E+02  0.17187E+02  0.24751E+02
+  0.84627E-06  0.13166E-05  0.21372E-05  0.48809E-05  0.89717E-05  0.18227E-04
+  0.30494E-04  0.47505E-04  0.41666E-04  0.45286E-05  0.62317E-04  0.28644E-03
+  0.97054E-03  0.25637E-02  0.59756E-02  0.11827E-01  0.21461E-01  0.40205E-01
+  0.72302E-01  0.12513E+00  0.22306E+00  0.38015E+00  0.65836E+00  0.11120E+01
+  0.17776E+01  0.25473E+01  0.35961E+01  0.52861E+01  0.76090E+01  0.10784E+02
+  0.15625E+02  0.22921E+02  0.32969E+02  0.70575E-06  0.11250E-05  0.19153E-05
+  0.33963E-05  0.36587E-05  0.00000E+00  0.12238E-04  0.38779E-04  0.92391E-04
+  0.19576E-03  0.37719E-03  0.78841E-03  0.19835E-02  0.37397E-02  0.80169E-02
+  0.15208E-01  0.27195E-01  0.47892E-01  0.83851E-01  0.14193E+00  0.24542E+00
+  0.41381E+00  0.71172E+00  0.11867E+01  0.21454E+01  0.35184E+01  0.49362E+01
+  0.72157E+01  0.10341E+02  0.14603E+02  0.21093E+02  0.30855E+02  0.44279E+02
+  0.42356E-04  0.87001E-04  0.14557E-03  0.22120E-03  0.28622E-03  0.35929E-03
+  0.41869E-03  0.46406E-03  0.47302E-03  0.41254E-03  0.22366E-03  0.24114E-03
+  0.12520E-02  0.80843E-02  0.83494E-02  0.15777E-01  0.28416E-01  0.50716E-01
+  0.87714E-01  0.14702E+00  0.25217E+00  0.41953E+00  0.72073E+00  0.12063E+01
+  0.21704E+01  0.38416E+01  0.65466E+01  0.95647E+01  0.13697E+02  0.19327E+02
+  0.27910E+02  0.40832E+02  0.58586E+02  0.19699E-03  0.25177E-03  0.36411E-03
+  0.52188E-03  0.72727E-03  0.88022E-03  0.10367E-02  0.11433E-02  0.11929E-02
+  0.11354E-02  0.92015E-03  0.30247E-03  0.10278E-02  0.39250E-02  0.27573E-01
+  0.19086E-01  0.32915E-01  0.57849E-01  0.98240E-01  0.16160E+00  0.27279E+00
+  0.44665E+00  0.75771E+00  0.12561E+01  0.22697E+01  0.39847E+01  0.69160E+01
+  0.12570E+02  0.18440E+02  0.25941E+02  0.37379E+02  0.54589E+02  0.78207E+02
+  0.69858E-03  0.88988E-03  0.11363E-02  0.13964E-02  0.16798E-02  0.20428E-02
+  0.23535E-02  0.26040E-02  0.27274E-02  0.26569E-02  0.23128E-02  0.15156E-02
+  0.35982E-03  0.42076E-02  0.11786E-01  0.30582E-01  0.40613E-01  0.68314E-01
+  0.11366E+00  0.18294E+00  0.30277E+00  0.48646E+00  0.81225E+00  0.13275E+01
+  0.23734E+01  0.41746E+01  0.72044E+01  0.12984E+02  0.23019E+02  0.34998E+02
+  0.50269E+02  0.73233E+02  0.10470E+03  0.15502E-03  0.19303E-03  0.23807E-03
+  0.28883E-03  0.32043E-03  0.30106E-03  0.23440E-03  0.76318E-04  0.24046E-03
+  0.85759E-03  0.19507E-02  0.39986E-02  0.77237E-02  0.14412E-01  0.26401E-01
+  0.42942E-01  0.68185E-01  0.16489E+00  0.16444E+00  0.25136E+00  0.39691E+00
+  0.61441E+00  0.99079E+00  0.15749E+01  0.27351E+01  0.47009E+01  0.80283E+01
+  0.14301E+02  0.24942E+02  0.43144E+02  0.70295E+02  0.10156E+03  0.14424E+03
+  0.33699E-02  0.42703E-02  0.54188E-02  0.68857E-02  0.87556E-02  0.10965E-01
+  0.11534E-01  0.12196E-01  0.12862E-01  0.12744E-01  0.12074E-01  0.10115E-01
+  0.62473E-02  0.15746E-02  0.16029E-01  0.35007E-01  0.60961E-01  0.10428E+00
+  0.51649E+00  0.25544E+00  0.40425E+00  0.62045E+00  0.99517E+00  0.15665E+01
+  0.27207E+01  0.46628E+01  0.79328E+01  0.14201E+02  0.24968E+02  0.42992E+02
+  0.76291E+02  0.13332E+03  0.18937E+03  0.46345E-04  0.48391E-04  0.41500E-04
+  0.14456E-04  0.64499E-04  0.24744E-03  0.66560E-03  0.12928E-02  0.22997E-02
+  0.41267E-02  0.71142E-02  0.12404E-01  0.21362E-01  0.36555E-01  0.62134E-01
+  0.94435E-01  0.13676E+00  0.20244E+00  0.29440E+00  0.12694E+01  0.62630E+00
+  0.90544E+00  0.13792E+01  0.20827E+01  0.34543E+01  0.57049E+01  0.94163E+01
+  0.16378E+02  0.28203E+02  0.48260E+02  0.84092E+02  0.14943E+03  0.26224E+03
+  0.10653E-01  0.13454E-01  0.17006E-01  0.21513E-01  0.27221E-01  0.34445E-01
+  0.43524E-01  0.54860E-01  0.60197E-01  0.59592E-01  0.57710E-01  0.52467E-01
+  0.42320E-01  0.23760E-01  0.85674E-02  0.47095E-01  0.94947E-01  0.16891E+00
+  0.26826E+00  0.39803E+00  0.60473E+00  0.88321E+00  0.13520E+01  0.20290E+01
+  0.33916E+01  0.56031E+01  0.92196E+01  0.16063E+02  0.27629E+02  0.47169E+02
+  0.83144E+02  0.14815E+03  0.25937E+03  0.16860E-01  0.21264E-01  0.26838E-01
+  0.33894E-01  0.42813E-01  0.54072E-01  0.68201E-01  0.85826E-01  0.10749E+00
+  0.12290E+00  0.11943E+00  0.11124E+00  0.95204E-01  0.65007E-01  0.13827E-01
+  0.44711E-01  0.11422E+00  0.21828E+00  0.35179E+00  0.51769E+00  0.77510E+00
+  0.11062E+01  0.16543E+01  0.24187E+01  0.39556E+01  0.63906E+01  0.10294E+02
+  0.17615E+02  0.29803E+02  0.50148E+02  0.87352E+02  0.15547E+03  0.27132E+03
+  0.37768E-01  0.47517E-01  0.59822E-01  0.75357E-01  0.94927E-01  0.11954E+00
+  0.15034E+00  0.18866E+00  0.23575E+00  0.29176E+00  0.35559E+00  0.41944E+00
+  0.38027E+00  0.30037E+00  0.16711E+00  0.19461E-01  0.14415E+00  0.37511E+00
+  0.64781E+00  0.95532E+00  0.14064E+01  0.19309E+01  0.27663E+01  0.38394E+01
+  0.59920E+01  0.92041E+01  0.14098E+02  0.23054E+02  0.37374E+02  0.60501E+02
+  0.10195E+03  0.17641E+03  0.30218E+03  0.63224E-01  0.79422E-01  0.99850E-01
+  0.12561E+00  0.15802E+00  0.19877E+00  0.24974E+00  0.31317E+00  0.39128E+00
+  0.48486E+00  0.59320E+00  0.70668E+00  0.80645E+00  0.75861E+00  0.51292E+00
+  0.25033E+00  0.37550E-01  0.43482E+00  0.88401E+00  0.13633E+01  0.20436E+01
+  0.27840E+01  0.39363E+01  0.53323E+01  0.81452E+01  0.12164E+02  0.18061E+02
+  0.28674E+02  0.45114E+02  0.70969E+02  0.11658E+03  0.19724E+03  0.33115E+03
+  0.10348E+00  0.12975E+00  0.16287E+00  0.20459E+00  0.25707E+00  0.32299E+00
+  0.40543E+00  0.50805E+00  0.63459E+00  0.78695E+00  0.96523E+00  0.11575E+01
+  0.13399E+01  0.14453E+01  0.13445E+01  0.86198E+00  0.34522E+00  0.36299E+00
+  0.11411E+01  0.19333E+01  0.30233E+01  0.41364E+01  0.58284E+01  0.77550E+01
+  0.11658E+02  0.16977E+02  0.24454E+02  0.37664E+02  0.57371E+02  0.87384E+02
+  0.13931E+03  0.22935E+03  0.37554E+03  0.16343E+00  0.20445E+00  0.25612E+00
+  0.32120E+00  0.40302E+00  0.50573E+00  0.63411E+00  0.79396E+00  0.99115E+00
+  0.12293E+01  0.15095E+01  0.18167E+01  0.21201E+01  0.23302E+01  0.22763E+01
+  0.20204E+01  0.12880E+01  0.00000E+00  0.13979E+01  0.27882E+01  0.46373E+01
+  0.64243E+01  0.90767E+01  0.11919E+02  0.17699E+02  0.25196E+02  0.35258E+02
+  0.52673E+02  0.77568E+02  0.11408E+03  0.17582E+03  0.28030E+03  0.44529E+03
+  0.25177E+00  0.31402E+00  0.39241E+00  0.49108E+00  0.61508E+00  0.77068E+00
+  0.96516E+00  0.12072E+01  0.15058E+01  0.18670E+01  0.22937E+01  0.27660E+01
+  0.32431E+01  0.36044E+01  0.36201E+01  0.33863E+01  0.27578E+01  0.10024E+01
+  0.15539E+01  0.40472E+01  0.73762E+01  0.10409E+02  0.14810E+02  0.19275E+02
+  0.28363E+02  0.39599E+02  0.53986E+02  0.78356E+02  0.11162E+03  0.15840E+03
+  0.23549E+03  0.36230E+03  0.55599E+03  0.37426E+00  0.46492E+00  0.57904E+00
+  0.72264E+00  0.90306E+00  0.11293E+01  0.14120E+01  0.17636E+01  0.21973E+01
+  0.27219E+01  0.33416E+01  0.40299E+01  0.47303E+01  0.52764E+01  0.53534E+01
+  0.51021E+01  0.43330E+01  0.20760E+01  0.17748E+01  0.65388E+01  0.12526E+02
+  0.18033E+02  0.25809E+02  0.33247E+02  0.48349E+02  0.66223E+02  0.88098E+02
+  0.12435E+03  0.17155E+03  0.23504E+03  0.33676E+03  0.49889E+03  0.73721E+03
+  0.56958E+00  0.70380E+00  0.87274E+00  0.10853E+01  0.13522E+01  0.16870E+01
+  0.21052E+01  0.26253E+01  0.32671E+01  0.40441E+01  0.49645E+01  0.59928E+01
+  0.70527E+01  0.79169E+01  0.81528E+01  0.79696E+01  0.71199E+01  0.42908E+01
+  0.60824E+00  0.77860E+01  0.20547E+02  0.30348E+02  0.44285E+02  0.57641E+02
+  0.83709E+02  0.11341E+03  0.14828E+03  0.20497E+03  0.27543E+03  0.36603E+03
+  0.50723E+03  0.72508E+03  0.10320E+04  0.84456E+00  0.10363E+01  0.12775E+01
+  0.15810E+01  0.19621E+01  0.24398E+01  0.30364E+01  0.37783E+01  0.46932E+01
+  0.58008E+01  0.71126E+01  0.85788E+01  0.10094E+02  0.11340E+02  0.11717E+02
+  0.11522E+02  0.10421E+02  0.66082E+01  0.00000E+00  0.96306E+01  0.27349E+02
+  0.50866E+02  0.80533E+02  0.10400E+03  0.15166E+03  0.20398E+03  0.26240E+03
+  0.35571E+03  0.46688E+03  0.60367E+03  0.81121E+03  0.11210E+04  0.15385E+04
+  0.12893E+01  0.15677E+01  0.19180E+01  0.23585E+01  0.29119E+01  0.36052E+01
+  0.44712E+01  0.55479E+01  0.68763E+01  0.84855E+01  0.10394E+02  0.12534E+02
+  0.14763E+02  0.16638E+02  0.17326E+02  0.17265E+02  0.15998E+02  0.11041E+02
+  0.23320E+01  0.10363E+02  0.33909E+02  0.64902E+02  0.12002E+03  0.18720E+03
+  0.27266E+03  0.36677E+03  0.47214E+03  0.63184E+03  0.81504E+03  0.10315E+04
+  0.13520E+04  0.18155E+04  0.24127E+04  0.19663E+01  0.23637E+01  0.28637E+01
+  0.34925E+01  0.42820E+01  0.52715E+01  0.65067E+01  0.80427E+01  0.99373E+01
+  0.12232E+02  0.14955E+02  0.18012E+02  0.21202E+02  0.23910E+02  0.24973E+02
+  0.25011E+02  0.23409E+02  0.16708E+02  0.48756E+01  0.12348E+02  0.44378E+02
+  0.86273E+02  0.16067E+03  0.25941E+03  0.47148E+03  0.67500E+03  0.86040E+03
+  0.11523E+04  0.14718E+04  0.18304E+04  0.23498E+04  0.30799E+04  0.39801E+04
+  0.30589E+01  0.36261E+01  0.43397E+01  0.52371E+01  0.63635E+01  0.77752E+01
+  0.95372E+01  0.11728E+02  0.14430E+02  0.17705E+02  0.21590E+02  0.25956E+02
+  0.30524E+02  0.34432E+02  0.36056E+02  0.36287E+02  0.34276E+02  0.25207E+02
+  0.90902E+01  0.14359E+02  0.58145E+02  0.11515E+03  0.21638E+03  0.34982E+03
+  0.63642E+03  0.10583E+04  0.15960E+04  0.21146E+04  0.26895E+04  0.33340E+04
+  0.42117E+04  0.54147E+04  0.68392E+04  0.48707E+01  0.56801E+01  0.66983E+01
+  0.79786E+01  0.95856E+01  0.11599E+02  0.14113E+02  0.17237E+02  0.21091E+02
+  0.25759E+02  0.31301E+02  0.37536E+02  0.44071E+02  0.49703E+02  0.52155E+02
+  0.52718E+02  0.50217E+02  0.37925E+02  0.15930E+02  0.16077E+02  0.76143E+02
+  0.15406E+03  0.29264E+03  0.47438E+03  0.86526E+03  0.14369E+04  0.22642E+04
+  0.37278E+04  0.49730E+04  0.61012E+04  0.77046E+04  0.97935E+04  0.12149E+05
+  0.79624E+01  0.91171E+01  0.10569E+02  0.12396E+02  0.14687E+02  0.17559E+02
+  0.21142E+02  0.25596E+02  0.31089E+02  0.37742E+02  0.45641E+02  0.54536E+02
+  0.63876E+02  0.71968E+02  0.75627E+02  0.76721E+02  0.73633E+02  0.56940E+02
+  0.26864E+02  0.16918E+02  0.99546E+02  0.20643E+03  0.39698E+03  0.64593E+03
+  0.11826E+04  0.19639E+04  0.30880E+04  0.50678E+04  0.79333E+04  0.11358E+05
+  0.14169E+05  0.17939E+05  0.22155E+05  0.50586E-09  0.14723E-08  0.35600E-08
+  0.60339E-08  0.16309E-07  0.21222E-07  0.41252E-07  0.82860E-07  0.18064E-06
+  0.37833E-06  0.77882E-06  0.33691E-05  0.24329E-04  0.88172E-04  0.40430E-03
+  0.13574E-02  0.31856E-02  0.64014E-02  0.11206E-01  0.17626E-01  0.27379E-01
+  0.39351E-01  0.56330E-01  0.78138E-01  0.11658E+00  0.17002E+00  0.24390E+00
+  0.36375E+00  0.53128E+00  0.76456E+00  0.11261E+01  0.16827E+01  0.24729E+01
+  0.22415E-09  0.13123E-08  0.36777E-08  0.87877E-08  0.15431E-07  0.38639E-07
+  0.55803E-07  0.10935E-06  0.24390E-06  0.48249E-06  0.10167E-05  0.59099E-05
+  0.44574E-04  0.11295E-03  0.51694E-03  0.17318E-02  0.40553E-02  0.81336E-02
+  0.14215E-01  0.22328E-01  0.34638E-01  0.49734E-01  0.71111E-01  0.98537E-01
+  0.14685E+00  0.21391E+00  0.30644E+00  0.45629E+00  0.66520E+00  0.95503E+00
+  0.14028E+01  0.20891E+01  0.30578E+01  0.41665E-09  0.57241E-09  0.32359E-08
+  0.89588E-08  0.22665E-07  0.38958E-07  0.84690E-07  0.15250E-06  0.29052E-06
+  0.63014E-06  0.13264E-05  0.93370E-05  0.75566E-04  0.23225E-03  0.66493E-03
+  0.22206E-02  0.51853E-02  0.10375E-01  0.18097E-01  0.28377E-01  0.43961E-01
+  0.63039E-01  0.90031E-01  0.12462E+00  0.18553E+00  0.26995E+00  0.38623E+00
+  0.57432E+00  0.83591E+00  0.11979E+01  0.17555E+01  0.26070E+01  0.38031E+01
+  0.20941E-08  0.99388E-09  0.13934E-08  0.78199E-08  0.22971E-07  0.55003E-07
+  0.10775E-06  0.20829E-06  0.41016E-06  0.95902E-06  0.18794E-05  0.22203E-04
+  0.11656E-03  0.41226E-03  0.10160E-02  0.28503E-02  0.66324E-02  0.13232E-01
+  0.23025E-01  0.36031E-01  0.55725E-01  0.79794E-01  0.11382E+00  0.15736E+00
+  0.23403E+00  0.34016E+00  0.48616E+00  0.72204E+00  0.10495E+01  0.15016E+01
+  0.21964E+01  0.32545E+01  0.47346E+01  0.62418E-08  0.50901E-08  0.24291E-08
+  0.32930E-08  0.20453E-07  0.58281E-07  0.13396E-06  0.33674E-06  0.61297E-06
+  0.17181E-05  0.48980E-05  0.42466E-04  0.19164E-03  0.65459E-03  0.15240E-02
+  0.36137E-02  0.85275E-02  0.16952E-01  0.29410E-01  0.45909E-01  0.70859E-01
+  0.10129E+00  0.14427E+00  0.19923E+00  0.29594E+00  0.42972E+00  0.61348E+00
+  0.91017E+00  0.13214E+01  0.18880E+01  0.27572E+01  0.40778E+01  0.59189E+01
+  0.11449E-07  0.15816E-07  0.13016E-07  0.67455E-08  0.86179E-08  0.51576E-07
+  0.16689E-06  0.37679E-06  0.10272E-05  0.25999E-05  0.97696E-05  0.75598E-04
+  0.29830E-03  0.88243E-03  0.22069E-02  0.46112E-02  0.10006E-01  0.21820E-01
+  0.37716E-01  0.58698E-01  0.90378E-01  0.12893E+00  0.18333E+00  0.25278E+00
+  0.37504E+00  0.54394E+00  0.77580E+00  0.11498E+01  0.16674E+01  0.23795E+01
+  0.34705E+01  0.51245E+01  0.74243E+01  0.27569E-07  0.28705E-07  0.39026E-07
+  0.33483E-07  0.16159E-07  0.21639E-07  0.14173E-06  0.55667E-06  0.12831E-05
+  0.57356E-05  0.19473E-04  0.10872E-03  0.43015E-03  0.11567E-02  0.27394E-02
+  0.59422E-02  0.11730E-01  0.24471E-01  0.48536E-01  0.75258E-01  0.11553E+00
+  0.16440E+00  0.23330E+00  0.32114E+00  0.47583E+00  0.68929E+00  0.98196E+00
+  0.14539E+01  0.21063E+01  0.30027E+01  0.43742E+01  0.64503E+01  0.93305E+01
+  0.44572E-07  0.64832E-07  0.78367E-07  0.92083E-07  0.92857E-07  0.44572E-07
+  0.54975E-07  0.40975E-06  0.17513E-05  0.80444E-05  0.41491E-04  0.15374E-03
+  0.55851E-03  0.14079E-02  0.33520E-02  0.69593E-02  0.14025E-01  0.27233E-01
+  0.52912E-01  0.96908E-01  0.14823E+00  0.21030E+00  0.29772E+00  0.40898E+00
+  0.60503E+00  0.87530E+00  0.12455E+01  0.18421E+01  0.26661E+01  0.37969E+01
+  0.55254E+01  0.81387E+01  0.11757E+02  0.88157E-07  0.12149E-06  0.17478E-06
+  0.24985E-06  0.25340E-06  0.31284E-06  0.12247E-06  0.13225E-06  0.11820E-05
+  0.97674E-05  0.61280E-04  0.21459E-03  0.66868E-03  0.16740E-02  0.39193E-02
+  0.81052E-02  0.15722E-01  0.30859E-01  0.56951E-01  0.10351E+00  0.19066E+00
+  0.26951E+00  0.38046E+00  0.52138E+00  0.76993E+00  0.11121E+01  0.15805E+01
+  0.23350E+01  0.33760E+01  0.48033E+01  0.69832E+01  0.10276E+02  0.14828E+02
+  0.19591E-06  0.23265E-06  0.33475E-06  0.51308E-06  0.78015E-06  0.87319E-06
+  0.10041E-05  0.36822E-06  0.30871E-06  0.70915E-05  0.69379E-04  0.27054E-03
+  0.78453E-03  0.19145E-02  0.44365E-02  0.90949E-02  0.17608E-01  0.33371E-01
+  0.62216E-01  0.10910E+00  0.20058E+00  0.34666E+00  0.48767E+00  0.66639E+00
+  0.98204E+00  0.14160E+01  0.20093E+01  0.29652E+01  0.42826E+01  0.60871E+01
+  0.88423E+01  0.12999E+02  0.18739E+02  0.39467E-06  0.52630E-06  0.78391E-06
+  0.14037E-05  0.21794E-05  0.43836E-05  0.54012E-05  0.55590E-05  0.23220E-05
+  0.17944E-05  0.52343E-04  0.27831E-03  0.85535E-03  0.21331E-02  0.49122E-02
+  0.98979E-02  0.19083E-01  0.36042E-01  0.65699E-01  0.11607E+00  0.20813E+00
+  0.36022E+00  0.62471E+00  0.85076E+00  0.12509E+01  0.18002E+01  0.25502E+01
+  0.37591E+01  0.54232E+01  0.77011E+01  0.11177E+02  0.16419E+02  0.23649E+02
+  0.83874E-06  0.10999E-05  0.17550E-05  0.42264E-05  0.81018E-05  0.16092E-04
+  0.32059E-04  0.42986E-04  0.41402E-04  0.17054E-04  0.24288E-04  0.23038E-03
+  0.85012E-03  0.23068E-02  0.54692E-02  0.10824E-01  0.20355E-01  0.38154E-01
+  0.69562E-01  0.12099E+00  0.21746E+00  0.37078E+00  0.64498E+00  0.10911E+01
+  0.16003E+01  0.22980E+01  0.32494E+01  0.47836E+01  0.68936E+01  0.97787E+01
+  0.14181E+02  0.20819E+02  0.29964E+02  0.53978E-05  0.84478E-05  0.20709E-04
+  0.38923E-04  0.67124E-04  0.93343E-04  0.12531E-03  0.16409E-03  0.18973E-03
+  0.16502E-03  0.77344E-04  0.17441E-03  0.75400E-03  0.23223E-02  0.58411E-02
+  0.11903E-01  0.21862E-01  0.40993E-01  0.73034E-01  0.12630E+00  0.22352E+00
+  0.38229E+00  0.66034E+00  0.11120E+01  0.20329E+01  0.29326E+01  0.41389E+01
+  0.60863E+01  0.87619E+01  0.12417E+02  0.17996E+02  0.26406E+02  0.37983E+02
+  0.47627E-04  0.78778E-04  0.12018E-03  0.18323E-03  0.26849E-03  0.36413E-03
+  0.45645E-03  0.53127E-03  0.59335E-03  0.60053E-03  0.50515E-03  0.22773E-03
+  0.71936E-03  0.21756E-02  0.59557E-02  0.12513E-01  0.23536E-01  0.43232E-01
+  0.77241E-01  0.13212E+00  0.22996E+00  0.38906E+00  0.67660E+00  0.11321E+01
+  0.20606E+01  0.36804E+01  0.52983E+01  0.77836E+01  0.11194E+02  0.15849E+02
+  0.22958E+02  0.33677E+02  0.48421E+02  0.74462E-04  0.16803E-03  0.31724E-03
+  0.51551E-03  0.69908E-03  0.91469E-03  0.11015E-02  0.12848E-02  0.14271E-02
+  0.15019E-02  0.14726E-02  0.11775E-02  0.41064E-03  0.26763E-02  0.60697E-02
+  0.12780E-01  0.24470E-01  0.45500E-01  0.80513E-01  0.13663E+00  0.23706E+00
+  0.39638E+00  0.68536E+00  0.11531E+01  0.20933E+01  0.37214E+01  0.65328E+01
+  0.99561E+01  0.14303E+02  0.20230E+02  0.29290E+02  0.42955E+02  0.61739E+02
+  0.56010E-03  0.71666E-03  0.97093E-03  0.13466E-02  0.18421E-02  0.22988E-02
+  0.27315E-02  0.31102E-02  0.34334E-02  0.36462E-02  0.37980E-02  0.35998E-02
+  0.27222E-02  0.51451E-03  0.64364E-02  0.12743E-01  0.24684E-01  0.47154E-01
+  0.83830E-01  0.14146E+00  0.24406E+00  0.40442E+00  0.69486E+00  0.11607E+01
+  0.21250E+01  0.37748E+01  0.65917E+01  0.12069E+02  0.18735E+02  0.26465E+02
+  0.38299E+02  0.56158E+02  0.80693E+02  0.18348E-02  0.23395E-02  0.29922E-02
+  0.37050E-02  0.43995E-02  0.53074E-02  0.62383E-02  0.70045E-02  0.76569E-02
+  0.80656E-02  0.81822E-02  0.83043E-02  0.72551E-02  0.44480E-02  0.17697E-02
+  0.11190E-01  0.28523E-01  0.49367E-01  0.88804E-01  0.14922E+00  0.25595E+00
+  0.41957E+00  0.71508E+00  0.11834E+01  0.21583E+01  0.38488E+01  0.67229E+01
+  0.12250E+02  0.21887E+02  0.34744E+02  0.50216E+02  0.73578E+02  0.10563E+03
+  0.40798E-02  0.51860E-02  0.66074E-02  0.84413E-02  0.10531E-01  0.11633E-01
+  0.13046E-01  0.14679E-01  0.15714E-01  0.16599E-01  0.17020E-01  0.16927E-01
+  0.15670E-01  0.11998E-01  0.37908E-02  0.74973E-02  0.24030E-01  0.12877E+00
+  0.96650E-01  0.16209E+00  0.27633E+00  0.44701E+00  0.75363E+00  0.12316E+01
+  0.22319E+01  0.39512E+01  0.68967E+01  0.12613E+02  0.22376E+02  0.39202E+02
+  0.67016E+02  0.98016E+02  0.14048E+03  0.85070E-02  0.10788E-01  0.13706E-01
+  0.17450E-01  0.22265E-01  0.28479E-01  0.30347E-01  0.32455E-01  0.35079E-01
+  0.36382E-01  0.37447E-01  0.37380E-01  0.36146E-01  0.31149E-01  0.20349E-01
+  0.63997E-02  0.12595E-01  0.45755E-01  0.37924E+00  0.16464E+00  0.28563E+00
+  0.46079E+00  0.77525E+00  0.12559E+01  0.22755E+01  0.40119E+01  0.69654E+01
+  0.12749E+02  0.22800E+02  0.39698E+02  0.71247E+02  0.12908E+03  0.18476E+03
+  0.15127E-01  0.19144E-01  0.24262E-01  0.30797E-01  0.39157E-01  0.49876E-01
+  0.63628E-01  0.70281E-01  0.73005E-01  0.76035E-01  0.77694E-01  0.77559E-01
+  0.75302E-01  0.67792E-01  0.51681E-01  0.32216E-01  0.73839E-02  0.34640E-01
+  0.93714E-01  0.34616E+00  0.31519E+00  0.49812E+00  0.83484E+00  0.13355E+01
+  0.24092E+01  0.42106E+01  0.72387E+01  0.13161E+02  0.23381E+02  0.40944E+02
+  0.73154E+02  0.13274E+03  0.23653E+03  0.25723E-01  0.32501E-01  0.41111E-01
+  0.52068E-01  0.66029E-01  0.83842E-01  0.10658E+00  0.13562E+00  0.15608E+00
+  0.15874E+00  0.16101E+00  0.16046E+00  0.15512E+00  0.14254E+00  0.11765E+00
+  0.89324E-01  0.55423E-01  0.00000E+00  0.73685E-01  0.16733E+00  0.32403E+00
+  0.53053E+00  0.89724E+00  0.14243E+01  0.25726E+01  0.44638E+01  0.75969E+01
+  0.13716E+02  0.24167E+02  0.41984E+02  0.75299E+02  0.13652E+03  0.24159E+03
+  0.39598E-01  0.49963E-01  0.63099E-01  0.79770E-01  0.10094E+00  0.12787E+00
+  0.16208E+00  0.20557E+00  0.26072E+00  0.31342E+00  0.31604E+00  0.31555E+00
+  0.30879E+00  0.28734E+00  0.24701E+00  0.20323E+00  0.15372E+00  0.75977E-01
+  0.21551E-01  0.13752E+00  0.32688E+00  0.56162E+00  0.97530E+00  0.15457E+01
+  0.28095E+01  0.48428E+01  0.81485E+01  0.14584E+02  0.25426E+02  0.43712E+02
+  0.77760E+02  0.14101E+03  0.24979E+03  0.60422E-01  0.76129E-01  0.96012E-01
+  0.12119E+00  0.15308E+00  0.19352E+00  0.24475E+00  0.30960E+00  0.39147E+00
+  0.49376E+00  0.62008E+00  0.62112E+00  0.60822E+00  0.57706E+00  0.50798E+00
+  0.43531E+00  0.35685E+00  0.23890E+00  0.99146E-01  0.55939E-01  0.30103E+00
+  0.58395E+00  0.10761E+01  0.17202E+01  0.31724E+01  0.54380E+01  0.90311E+01
+  0.15984E+02  0.27482E+02  0.46586E+02  0.81922E+02  0.14712E+03  0.25932E+03
+  0.92207E-01  0.11602E+00  0.14612E+00  0.18416E+00  0.23228E+00  0.29313E+00
+  0.37000E+00  0.46702E+00  0.58909E+00  0.74113E+00  0.92840E+00  0.11513E+01
+  0.12178E+01  0.11567E+01  0.10448E+01  0.92085E+00  0.78629E+00  0.59243E+00
+  0.37410E+00  0.14701E+00  0.19777E+00  0.56605E+00  0.11937E+01  0.19647E+01
+  0.37309E+01  0.63803E+01  0.10448E+02  0.18243E+02  0.30816E+02  0.51286E+02
+  0.88770E+02  0.15722E+03  0.27361E+03  0.13681E+00  0.17191E+00  0.21622E+00
+  0.27217E+00  0.34283E+00  0.43208E+00  0.54459E+00  0.68628E+00  0.86417E+00
+  0.10853E+01  0.13574E+01  0.16817E+01  0.20543E+01  0.22358E+01  0.20360E+01
+  0.18345E+01  0.16184E+01  0.12972E+01  0.94900E+00  0.60483E+00  0.10195E+00
+  0.39813E+00  0.12305E+01  0.21877E+01  0.44120E+01  0.76092E+01  0.12344E+02
+  0.21316E+02  0.35376E+02  0.57734E+02  0.98184E+02  0.17113E+03  0.29335E+03
+  0.19924E+00  0.24993E+00  0.31389E+00  0.39458E+00  0.49637E+00  0.62471E+00
+  0.78633E+00  0.98948E+00  0.12440E+01  0.15598E+01  0.19474E+01  0.24092E+01
+  0.29408E+01  0.35016E+01  0.39092E+01  0.35366E+01  0.31598E+01  0.26297E+01
+  0.20324E+01  0.14623E+01  0.66127E+00  0.90126E-01  0.12999E+01  0.26025E+01
+  0.56284E+01  0.97702E+01  0.15644E+02  0.26576E+02  0.43098E+02  0.68587E+02
+  0.11391E+03  0.19422E+03  0.32608E+03  0.28910E+00  0.36193E+00  0.45377E+00
+  0.56958E+00  0.71553E+00  0.89939E+00  0.11307E+01  0.14210E+01  0.17842E+01
+  0.22342E+01  0.27862E+01  0.34439E+01  0.42024E+01  0.50100E+01  0.57494E+01
+  0.65368E+01  0.61244E+01  0.51885E+01  0.42079E+01  0.32445E+01  0.19200E+01
+  0.73358E+00  0.11146E+01  0.29875E+01  0.73144E+01  0.12949E+02  0.20579E+02
+  0.34495E+02  0.54688E+02  0.84772E+02  0.13720E+03  0.22813E+03  0.37385E+03
+  0.41638E+00  0.52003E+00  0.65065E+00  0.81529E+00  0.10227E+01  0.12838E+01
+  0.16119E+01  0.20235E+01  0.25381E+01  0.31751E+01  0.39561E+01  0.48874E+01
+  0.59645E+01  0.71212E+01  0.82071E+01  0.93816E+01  0.10615E+02  0.10075E+02
+  0.83622E+01  0.67837E+01  0.45939E+01  0.26624E+01  0.25804E+00  0.30683E+01
+  0.94991E+01  0.17487E+02  0.27815E+02  0.46253E+02  0.71880E+02  0.10863E+03
+  0.17126E+03  0.27731E+03  0.44248E+03  0.63745E+00  0.79354E+00  0.99027E+00
+  0.12381E+01  0.15502E+01  0.19430E+01  0.24364E+01  0.30554E+01  0.38286E+01
+  0.47873E+01  0.59641E+01  0.73736E+01  0.90164E+01  0.10813E+02  0.12574E+02
+  0.14532E+02  0.16669E+02  0.18340E+02  0.18736E+02  0.15968E+02  0.12299E+02
+  0.91723E+01  0.43785E+01  0.00000E+00  0.10005E+02  0.21862E+02  0.36470E+02
+  0.62068E+02  0.96009E+02  0.14263E+03  0.22030E+03  0.34839E+03  0.54126E+03
+  0.87013E+00  0.10790E+01  0.13420E+01  0.16734E+01  0.20904E+01  0.26150E+01
+  0.32737E+01  0.40992E+01  0.51298E+01  0.64052E+01  0.79684E+01  0.98371E+01
+  0.12008E+02  0.14373E+02  0.16675E+02  0.19217E+02  0.21968E+02  0.24068E+02
+  0.25745E+02  0.27235E+02  0.20923E+02  0.15459E+02  0.73865E+01  0.00000E+00
+  0.16389E+02  0.35137E+02  0.57340E+02  0.95184E+02  0.14320E+03  0.20642E+03
+  0.30874E+03  0.47227E+03  0.70948E+03  0.13236E+01  0.16325E+01  0.20217E+01
+  0.25118E+01  0.31287E+01  0.39044E+01  0.48785E+01  0.60992E+01  0.76236E+01
+  0.95117E+01  0.11830E+02  0.14610E+02  0.17862E+02  0.21452E+02  0.25058E+02
+  0.29112E+02  0.33607E+02  0.37439E+02  0.40983E+02  0.44649E+02  0.45158E+02
+  0.39340E+02  0.25528E+02  0.13373E+02  0.14032E+02  0.44403E+02  0.78994E+02
+  0.13682E+03  0.20699E+03  0.29534E+03  0.43473E+03  0.65080E+03  0.95155E+03
+  0.18997E+01  0.23304E+01  0.28728E+01  0.35561E+01  0.44158E+01  0.54970E+01
+  0.68548E+01  0.85566E+01  0.10682E+02  0.13318E+02  0.16559E+02  0.20459E+02
+  0.25047E+02  0.30173E+02  0.35450E+02  0.41464E+02  0.48255E+02  0.54467E+02
+  0.60668E+02  0.67485E+02  0.70921E+02  0.74891E+02  0.60930E+02  0.42142E+02
+  0.00000E+00  0.46303E+02  0.97582E+02  0.18206E+03  0.28115E+03  0.40150E+03
+  0.58754E+03  0.86868E+03  0.12463E+04  0.27347E+01  0.33325E+01  0.40855E+01
+  0.50336E+01  0.62266E+01  0.77273E+01  0.96120E+01  0.11974E+02  0.14925E+02
+  0.18588E+02  0.23098E+02  0.28542E+02  0.34978E+02  0.42238E+02  0.49856E+02
+  0.58639E+02  0.68686E+02  0.78335E+02  0.88411E+02  0.99842E+02  0.10772E+03
+  0.11728E+03  0.11563E+03  0.10095E+03  0.34882E+02  0.36477E+02  0.11491E+03
+  0.24191E+03  0.38637E+03  0.55605E+03  0.81307E+03  0.11918E+04  0.16822E+04
+  0.00000E+00  0.10061E-08  0.33255E-08  0.92496E-08  0.15491E-07  0.37425E-07
+  0.57874E-07  0.11374E-06  0.24947E-06  0.50083E-06  0.10602E-05  0.63841E-05
+  0.48906E-04  0.11754E-03  0.53780E-03  0.18010E-02  0.42158E-02  0.84527E-02
+  0.14769E-01  0.23193E-01  0.35973E-01  0.51638E-01  0.73824E-01  0.10228E+00
+  0.15240E+00  0.22196E+00  0.31790E+00  0.47326E+00  0.68974E+00  0.98996E+00
+  0.14535E+01  0.21635E+01  0.31649E+01  0.10061E-08  0.00000E+00  0.24303E-08
+  0.80095E-08  0.23545E-07  0.38904E-07  0.86422E-07  0.15845E-06  0.29644E-06
+  0.66877E-06  0.13751E-05  0.99026E-05  0.80710E-04  0.25515E-03  0.68935E-03
+  0.23012E-02  0.53715E-02  0.10744E-01  0.18735E-01  0.29370E-01  0.45490E-01
+  0.65219E-01  0.93134E-01  0.12889E+00  0.19186E+00  0.27912E+00  0.39929E+00
+  0.59364E+00  0.86386E+00  0.12376E+01  0.18132E+01  0.26918E+01  0.39252E+01
+  0.33255E-08  0.24303E-08  0.00000E+00  0.58417E-08  0.20661E-07  0.56213E-07
+  0.10782E-06  0.22542E-06  0.42746E-06  0.10077E-05  0.22320E-05  0.24543E-04
+  0.12314E-03  0.44142E-03  0.10776E-02  0.29512E-02  0.68643E-02  0.13690E-01
+  0.23812E-01  0.37254E-01  0.57603E-01  0.82466E-01  0.11761E+00  0.16259E+00
+  0.24175E+00  0.35134E+00  0.50208E+00  0.74559E+00  0.10836E+01  0.15500E+01
+  0.22668E+01  0.33577E+01  0.48832E+01  0.92496E-08  0.80095E-08  0.58417E-08
+  0.00000E+00  0.15747E-07  0.52749E-07  0.12913E-06  0.33775E-06  0.65929E-06
+  0.18246E-05  0.53294E-05  0.45914E-04  0.20305E-03  0.69003E-03  0.15985E-02
+  0.37226E-02  0.88032E-02  0.17493E-01  0.30338E-01  0.47344E-01  0.73055E-01
+  0.10441E+00  0.14869E+00  0.20529E+00  0.30493E+00  0.44268E+00  0.63195E+00
+  0.93746E+00  0.13608E+01  0.19440E+01  0.28387E+01  0.41973E+01  0.60909E+01
+  0.15491E-07  0.23545E-07  0.20661E-07  0.15747E-07  0.00000E+00  0.38883E-07
+  0.14958E-06  0.34235E-06  0.10318E-05  0.28465E-05  0.10318E-04  0.79465E-04
+  0.30957E-03  0.90762E-03  0.22919E-02  0.47342E-02  0.10164E-01  0.22427E-01
+  0.38753E-01  0.60294E-01  0.92814E-01  0.13238E+00  0.18821E+00  0.25947E+00
+  0.38494E+00  0.55827E+00  0.79612E+00  0.11798E+01  0.17108E+01  0.24412E+01
+  0.35600E+01  0.52561E+01  0.76136E+01  0.37425E-07  0.38904E-07  0.56213E-07
+  0.52749E-07  0.38883E-07  0.00000E+00  0.10641E-06  0.49390E-06  0.11961E-05
+  0.58902E-05  0.20552E-04  0.11093E-03  0.44177E-03  0.11718E-02  0.27839E-02
+  0.60758E-02  0.11898E-01  0.24666E-01  0.49657E-01  0.76979E-01  0.11815E+00
+  0.16810E+00  0.23853E+00  0.32829E+00  0.48639E+00  0.70458E+00  0.10037E+01
+  0.14860E+01  0.21527E+01  0.30686E+01  0.44700E+01  0.65910E+01  0.95329E+01
+  0.57874E-07  0.86422E-07  0.10782E-06  0.12913E-06  0.14958E-06  0.10641E-06
+  0.00000E+00  0.29675E-06  0.15389E-05  0.75780E-05  0.42189E-04  0.15389E-03
+  0.56179E-03  0.14181E-02  0.33706E-02  0.70107E-02  0.14177E-01  0.27399E-01
+  0.53068E-01  0.98544E-01  0.15073E+00  0.21382E+00  0.30269E+00  0.41580E+00
+  0.61513E+00  0.88991E+00  0.12663E+01  0.18730E+01  0.27108E+01  0.38604E+01
+  0.56177E+01  0.82744E+01  0.11953E+02  0.11374E-06  0.15845E-06  0.22542E-06
+  0.33775E-06  0.34235E-06  0.49390E-06  0.29675E-06  0.00000E+00  0.84923E-06
+  0.86464E-05  0.58054E-04  0.21125E-03  0.66077E-03  0.16680E-02  0.39214E-02
+  0.81011E-02  0.15740E-01  0.30960E-01  0.57013E-01  0.10349E+00  0.19274E+00
+  0.27247E+00  0.38466E+00  0.52716E+00  0.77858E+00  0.11248E+01  0.15985E+01
+  0.23619E+01  0.34151E+01  0.48592E+01  0.70647E+01  0.10396E+02  0.15001E+02
+  0.24947E-06  0.29644E-06  0.42746E-06  0.65929E-06  0.10318E-05  0.11961E-05
+  0.15389E-05  0.84923E-06  0.00000E+00  0.53203E-05  0.61613E-04  0.25568E-03
+  0.76067E-03  0.18806E-02  0.43929E-02  0.90369E-02  0.17509E-01  0.33239E-01
+  0.62064E-01  0.10880E+00  0.20002E+00  0.34780E+00  0.48943E+00  0.66890E+00
+  0.98609E+00  0.14222E+01  0.20185E+01  0.29794E+01  0.43040E+01  0.61179E+01
+  0.88884E+01  0.13069E+02  0.18841E+02  0.50083E-06  0.66877E-06  0.10077E-05
+  0.18246E-05  0.28465E-05  0.58902E-05  0.75780E-05  0.86464E-05  0.53203E-05
+  0.00000E+00  0.38606E-04  0.24548E-03  0.80091E-03  0.20546E-02  0.48020E-02
+  0.97378E-02  0.18844E-01  0.35682E-01  0.65165E-01  0.11528E+00  0.20687E+00
+  0.35825E+00  0.62293E+00  0.84872E+00  0.12488E+01  0.17980E+01  0.25481E+01
+  0.37575E+01  0.54229E+01  0.77022E+01  0.11181E+02  0.16430E+02  0.23668E+02
+  0.10602E-05  0.13751E-05  0.22320E-05  0.53294E-05  0.10318E-04  0.20552E-04
+  0.42189E-04  0.58054E-04  0.61613E-04  0.38606E-04  0.00000E+00  0.17033E-03
+  0.74437E-03  0.21446E-02  0.52280E-02  0.10470E-01  0.19856E-01  0.37409E-01
+  0.68447E-01  0.11932E+00  0.21483E+00  0.36687E+00  0.63908E+00  0.10760E+01
+  0.15802E+01  0.22713E+01  0.32140E+01  0.47352E+01  0.68281E+01  0.96902E+01
+  0.14059E+02  0.20648E+02  0.29728E+02  0.63841E-05  0.99026E-05  0.24543E-04
+  0.45914E-04  0.79465E-04  0.11093E-03  0.15389E-03  0.21125E-03  0.25568E-03
+  0.24548E-03  0.17033E-03  0.00000E+00  0.54100E-03  0.20052E-02  0.53700E-02
+  0.11207E-01  0.20798E-01  0.39549E-01  0.70875E-01  0.12310E+00  0.21883E+00
+  0.37513E+00  0.64943E+00  0.10957E+01  0.19927E+01  0.28602E+01  0.40420E+01
+  0.59521E+01  0.85776E+01  0.12166E+02  0.17646E+02  0.25911E+02  0.37294E+02
+  0.48906E-04  0.80710E-04  0.12314E-03  0.20305E-03  0.30957E-03  0.44177E-03
+  0.56179E-03  0.66077E-03  0.76067E-03  0.80091E-03  0.74437E-03  0.54100E-03
+  0.00000E+00  0.14977E-02  0.50276E-02  0.11163E-01  0.21585E-01  0.40345E-01
+  0.73181E-01  0.12618E+00  0.22123E+00  0.37632E+00  0.65725E+00  0.11023E+01
+  0.20155E+01  0.35845E+01  0.50609E+01  0.74536E+01  0.10739E+02  0.15228E+02
+  0.22089E+02  0.32443E+02  0.46693E+02  0.11754E-03  0.25515E-03  0.44142E-03
+  0.69003E-03  0.90762E-03  0.11718E-02  0.14181E-02  0.16680E-02  0.18806E-02
+  0.20546E-02  0.21446E-02  0.20052E-02  0.14977E-02  0.00000E+00  0.38090E-02
+  0.98550E-02  0.20318E-01  0.39622E-01  0.72135E-01  0.12464E+00  0.21957E+00
+  0.37093E+00  0.64763E+00  0.10964E+01  0.20042E+01  0.35874E+01  0.62819E+01
+  0.92657E+01  0.13360E+02  0.18950E+02  0.27513E+02  0.40448E+02  0.58247E+02
+  0.53780E-03  0.68935E-03  0.10776E-02  0.15985E-02  0.22919E-02  0.27839E-02
+  0.33706E-02  0.39214E-02  0.43929E-02  0.48020E-02  0.52280E-02  0.53700E-02
+  0.50276E-02  0.38090E-02  0.00000E+00  0.60908E-02  0.15995E-01  0.34940E-01
+  0.66597E-01  0.11711E+00  0.20905E+00  0.35405E+00  0.62105E+00  0.10523E+01
+  0.19603E+01  0.35135E+01  0.62011E+01  0.11387E+02  0.16457E+02  0.23378E+02
+  0.34012E+02  0.50109E+02  0.72259E+02  0.18010E-02  0.23012E-02  0.29512E-02
+  0.37226E-02  0.47342E-02  0.60758E-02  0.70107E-02  0.81011E-02  0.90369E-02
+  0.97378E-02  0.10470E-01  0.11207E-01  0.11163E-01  0.98550E-02  0.60908E-02
+  0.00000E+00  0.96847E-02  0.28562E-01  0.59730E-01  0.10866E+00  0.19830E+00
+  0.33777E+00  0.59659E+00  0.10115E+01  0.19007E+01  0.34608E+01  0.61046E+01
+  0.11317E+02  0.20322E+02  0.28900E+02  0.42122E+02  0.62176E+02  0.89762E+02
+  0.42158E-02  0.53715E-02  0.68643E-02  0.88032E-02  0.10164E-01  0.11898E-01
+  0.14177E-01  0.15740E-01  0.17509E-01  0.18844E-01  0.19856E-01  0.20798E-01
+  0.21585E-01  0.20318E-01  0.15995E-01  0.96847E-02  0.00000E+00  0.19216E-01
+  0.50378E-01  0.98207E-01  0.18647E+00  0.32134E+00  0.57379E+00  0.97451E+00
+  0.18495E+01  0.33830E+01  0.60480E+01  0.11224E+02  0.20302E+02  0.35826E+02
+  0.52289E+02  0.77304E+02  0.11170E+03  0.84527E-02  0.10744E-01  0.13690E-01
+  0.17493E-01  0.22427E-01  0.24666E-01  0.27399E-01  0.30960E-01  0.33239E-01
+  0.35682E-01  0.37409E-01  0.39549E-01  0.40345E-01  0.39622E-01  0.34940E-01
+  0.28562E-01  0.19216E-01  0.00000E+00  0.30503E-01  0.75972E-01  0.16126E+00
+  0.28860E+00  0.53089E+00  0.91085E+00  0.17648E+01  0.32586E+01  0.58542E+01
+  0.11066E+02  0.20029E+02  0.35601E+02  0.64590E+02  0.95720E+02  0.13849E+03
+  0.14769E-01  0.18735E-01  0.23812E-01  0.30338E-01  0.38753E-01  0.49657E-01
+  0.53068E-01  0.57013E-01  0.62064E-01  0.65165E-01  0.68447E-01  0.70875E-01
+  0.73181E-01  0.72135E-01  0.66597E-01  0.59730E-01  0.50378E-01  0.30503E-01
+  0.00000E+00  0.43581E-01  0.12695E+00  0.24746E+00  0.48160E+00  0.84277E+00
+  0.16829E+01  0.31473E+01  0.56850E+01  0.10829E+02  0.19892E+02  0.35307E+02
+  0.64551E+02  0.11887E+03  0.17214E+03  0.23193E-01  0.29370E-01  0.37254E-01
+  0.47344E-01  0.60294E-01  0.76979E-01  0.98544E-01  0.10349E+00  0.10880E+00
+  0.11528E+00  0.11932E+00  0.12310E+00  0.12618E+00  0.12464E+00  0.11711E+00
+  0.10866E+00  0.98207E-01  0.75972E-01  0.43581E-01  0.00000E+00  0.84555E-01
+  0.20152E+00  0.43345E+00  0.78317E+00  0.16264E+01  0.30854E+01  0.56002E+01
+  0.10732E+02  0.19749E+02  0.35454E+02  0.64694E+02  0.11990E+03  0.21529E+03
+  0.35973E-01  0.45490E-01  0.57603E-01  0.73055E-01  0.92814E-01  0.11815E+00
+  0.15073E+00  0.19274E+00  0.20002E+00  0.20687E+00  0.21483E+00  0.21883E+00
+  0.22123E+00  0.21957E+00  0.20905E+00  0.19830E+00  0.18647E+00  0.16126E+00
+  0.12695E+00  0.84555E-01  0.00000E+00  0.10982E+00  0.33588E+00  0.66657E+00
+  0.15096E+01  0.29564E+01  0.54355E+01  0.10545E+02  0.19487E+02  0.35026E+02
+  0.64784E+02  0.11995E+03  0.21665E+03  0.51638E-01  0.65219E-01  0.82466E-01
+  0.10441E+00  0.13238E+00  0.16810E+00  0.21382E+00  0.27247E+00  0.34780E+00
+  0.35825E+00  0.36687E+00  0.37513E+00  0.37632E+00  0.37093E+00  0.35405E+00
+  0.33777E+00  0.32134E+00  0.28860E+00  0.24746E+00  0.20152E+00  0.10982E+00
+  0.00000E+00  0.23243E+00  0.55858E+00  0.14336E+01  0.29132E+01  0.54204E+01
+  0.10619E+02  0.19644E+02  0.35234E+02  0.65126E+02  0.12191E+03  0.21923E+03
+  0.73824E-01  0.93134E-01  0.11761E+00  0.14869E+00  0.18821E+00  0.23853E+00
+  0.30269E+00  0.38466E+00  0.48943E+00  0.62293E+00  0.63908E+00  0.64943E+00
+  0.65725E+00  0.64763E+00  0.62105E+00  0.59659E+00  0.57379E+00  0.53089E+00
+  0.48160E+00  0.43345E+00  0.33588E+00  0.23243E+00  0.00000E+00  0.30747E+00
+  0.12091E+01  0.27091E+01  0.52212E+01  0.10493E+02  0.19565E+02  0.35135E+02
+  0.65039E+02  0.12191E+03  0.22159E+03  0.10228E+00  0.12889E+00  0.16259E+00
+  0.20529E+00  0.25947E+00  0.32829E+00  0.41580E+00  0.52716E+00  0.66890E+00
+  0.84872E+00  0.10760E+01  0.10957E+01  0.11023E+01  0.10964E+01  0.10523E+01
+  0.10115E+01  0.97451E+00  0.91085E+00  0.84277E+00  0.78317E+00  0.66657E+00
+  0.55858E+00  0.30747E+00  0.00000E+00  0.97615E+00  0.25591E+01  0.51607E+01
+  0.10656E+02  0.19987E+02  0.35836E+02  0.66235E+02  0.12389E+03  0.22448E+03
+  0.15240E+00  0.19186E+00  0.24175E+00  0.30493E+00  0.38494E+00  0.48639E+00
+  0.61513E+00  0.77858E+00  0.98609E+00  0.12488E+01  0.15802E+01  0.19927E+01
+  0.20155E+01  0.20042E+01  0.19603E+01  0.19007E+01  0.18495E+01  0.17648E+01
+  0.16829E+01  0.16264E+01  0.15096E+01  0.14336E+01  0.12091E+01  0.97615E+00
+  0.00000E+00  0.15495E+01  0.40624E+01  0.95572E+01  0.18794E+02  0.34370E+02
+  0.64473E+02  0.12174E+03  0.22125E+03  0.22196E+00  0.27912E+00  0.35134E+00
+  0.44268E+00  0.55827E+00  0.70458E+00  0.88991E+00  0.11248E+01  0.14222E+01
+  0.17980E+01  0.22713E+01  0.28602E+01  0.35845E+01  0.35874E+01  0.35135E+01
+  0.34608E+01  0.33830E+01  0.32586E+01  0.31473E+01  0.30854E+01  0.29564E+01
+  0.29132E+01  0.27091E+01  0.25591E+01  0.15495E+01  0.00000E+00  0.24598E+01
+  0.80607E+01  0.17338E+02  0.32817E+02  0.62957E+02  0.12040E+03  0.21960E+03
+  0.31790E+00  0.39929E+00  0.50208E+00  0.63195E+00  0.79612E+00  0.10037E+01
+  0.12663E+01  0.15985E+01  0.20185E+01  0.25481E+01  0.32140E+01  0.40420E+01
+  0.50609E+01  0.62819E+01  0.62011E+01  0.61046E+01  0.60480E+01  0.58542E+01
+  0.56850E+01  0.56002E+01  0.54355E+01  0.54204E+01  0.52212E+01  0.51607E+01
+  0.40624E+01  0.24598E+01  0.00000E+00  0.58571E+01  0.15355E+02  0.30963E+02
+  0.61569E+02  0.11992E+03  0.21980E+03  0.47326E+00  0.59364E+00  0.74559E+00
+  0.93746E+00  0.11798E+01  0.14860E+01  0.18730E+01  0.23619E+01  0.29794E+01
+  0.37575E+01  0.47352E+01  0.59521E+01  0.74536E+01  0.92657E+01  0.11387E+02
+  0.11317E+02  0.11224E+02  0.11066E+02  0.10829E+02  0.10732E+02  0.10545E+02
+  0.10619E+02  0.10493E+02  0.10656E+02  0.95572E+01  0.80607E+01  0.58571E+01
+  0.00000E+00  0.92972E+01  0.24373E+02  0.54613E+02  0.11277E+03  0.21152E+03
+  0.68974E+00  0.86386E+00  0.10836E+01  0.13608E+01  0.17108E+01  0.21527E+01
+  0.27108E+01  0.34151E+01  0.43040E+01  0.54229E+01  0.68281E+01  0.85776E+01
+  0.10739E+02  0.13360E+02  0.16457E+02  0.20322E+02  0.20302E+02  0.20029E+02
+  0.19892E+02  0.19749E+02  0.19487E+02  0.19644E+02  0.19565E+02  0.19987E+02
+  0.18794E+02  0.17338E+02  0.15355E+02  0.92972E+01  0.00000E+00  0.14758E+02
+  0.45140E+02  0.10403E+03  0.20287E+03  0.98996E+00  0.12376E+01  0.15500E+01
+  0.19440E+01  0.24412E+01  0.30686E+01  0.38604E+01  0.48592E+01  0.61179E+01
+  0.77022E+01  0.96902E+01  0.12166E+02  0.15228E+02  0.18950E+02  0.23378E+02
+  0.28900E+02  0.35826E+02  0.35601E+02  0.35307E+02  0.35454E+02  0.35026E+02
+  0.35234E+02  0.35135E+02  0.35836E+02  0.34370E+02  0.32817E+02  0.30963E+02
+  0.24373E+02  0.14758E+02  0.00000E+00  0.31236E+02  0.92125E+02  0.19266E+03
+  0.14535E+01  0.18132E+01  0.22668E+01  0.28387E+01  0.35600E+01  0.44700E+01
+  0.56177E+01  0.70647E+01  0.88884E+01  0.11181E+02  0.14059E+02  0.17646E+02
+  0.22089E+02  0.27513E+02  0.34012E+02  0.42122E+02  0.52289E+02  0.64590E+02
+  0.64551E+02  0.64694E+02  0.64784E+02  0.65126E+02  0.65039E+02  0.66235E+02
+  0.64473E+02  0.62957E+02  0.61569E+02  0.54613E+02  0.45140E+02  0.31236E+02
+  0.00000E+00  0.61981E+02  0.16249E+03  0.21635E+01  0.26918E+01  0.33577E+01
+  0.41973E+01  0.52561E+01  0.65910E+01  0.82744E+01  0.10396E+02  0.13069E+02
+  0.16430E+02  0.20648E+02  0.25911E+02  0.32443E+02  0.40448E+02  0.50109E+02
+  0.62176E+02  0.77304E+02  0.95720E+02  0.11887E+03  0.11990E+03  0.11995E+03
+  0.12191E+03  0.12191E+03  0.12389E+03  0.12174E+03  0.12040E+03  0.11992E+03
+  0.11277E+03  0.10403E+03  0.92125E+02  0.61981E+02  0.00000E+00  0.98389E+02
+  0.31649E+01  0.39252E+01  0.48832E+01  0.60909E+01  0.76136E+01  0.95329E+01
+  0.11953E+02  0.15001E+02  0.18841E+02  0.23668E+02  0.29728E+02  0.37294E+02
+  0.46693E+02  0.58247E+02  0.72259E+02  0.89762E+02  0.11170E+03  0.13849E+03
+  0.17214E+03  0.21529E+03  0.21665E+03  0.21923E+03  0.22159E+03  0.22448E+03
+  0.22125E+03  0.21960E+03  0.21980E+03  0.21152E+03  0.20287E+03  0.19266E+03
+  0.16249E+03  0.98389E+02  0.00000E+00  0.37274E-09  0.31548E-09  0.20343E-08
+  0.45022E-08  0.13863E-07  0.19277E-07  0.38944E-07  0.79951E-07  0.17661E-06
+  0.37308E-06  0.77202E-06  0.33509E-05  0.24245E-04  0.87978E-04  0.40372E-03
+  0.13559E-02  0.31829E-02  0.63971E-02  0.11200E-01  0.17618E-01  0.27367E-01
+  0.39336E-01  0.56311E-01  0.78114E-01  0.11655E+00  0.16998E+00  0.24385E+00
+  0.36369E+00  0.53121E+00  0.76446E+00  0.11260E+01  0.16825E+01  0.24727E+01
+  0.12672E-08  0.92981E-09  0.72336E-09  0.48437E-08  0.11494E-07  0.32784E-07
+  0.50568E-07  0.10287E-06  0.23477E-06  0.47077E-06  0.10002E-05  0.58349E-05
+  0.44115E-04  0.11232E-03  0.51472E-03  0.17253E-02  0.40417E-02  0.81091E-02
+  0.14175E-01  0.22268E-01  0.34550E-01  0.49608E-01  0.70944E-01  0.98306E-01
+  0.14652E+00  0.21344E+00  0.30577E+00  0.45534E+00  0.66382E+00  0.95312E+00
+  0.14001E+01  0.20851E+01  0.30520E+01  0.37590E-08  0.30399E-08  0.22140E-08
+  0.17666E-08  0.12815E-07  0.29239E-07  0.71945E-07  0.13774E-06  0.27300E-06
+  0.60187E-06  0.12894E-05  0.91186E-05  0.74080E-04  0.22728E-03  0.65857E-03
+  0.22016E-02  0.51442E-02  0.10298E-01  0.17968E-01  0.28182E-01  0.43667E-01
+  0.62624E-01  0.89457E-01  0.12383E+00  0.18438E+00  0.26831E+00  0.38392E+00
+  0.57095E+00  0.83109E+00  0.11911E+01  0.17457E+01  0.25926E+01  0.37825E+01
+  0.93469E-08  0.97045E-08  0.80186E-08  0.63898E-08  0.42064E-08  0.30282E-07
+  0.80217E-07  0.17313E-06  0.36758E-06  0.89324E-06  0.17415E-05  0.21236E-04
+  0.11358E-03  0.40263E-03  0.99753E-03  0.28173E-02  0.65622E-02  0.13103E-01
+  0.22812E-01  0.35711E-01  0.55248E-01  0.79128E-01  0.11290E+00  0.15611E+00
+  0.23222E+00  0.33758E+00  0.48253E+00  0.71678E+00  0.10420E+01  0.14910E+01
+  0.21812E+01  0.32322E+01  0.47028E+01  0.21868E-07  0.23254E-07  0.24252E-07
+  0.20275E-07  0.15215E-07  0.11129E-07  0.75924E-07  0.24948E-06  0.50400E-06
+  0.15236E-05  0.44819E-05  0.39888E-04  0.18378E-03  0.63422E-03  0.14867E-02
+  0.35547E-02  0.83951E-02  0.16710E-01  0.29015E-01  0.45320E-01  0.69986E-01
+  0.10008E+00  0.14260E+00  0.19695E+00  0.29268E+00  0.42505E+00  0.60700E+00
+  0.90075E+00  0.13079E+01  0.18691E+01  0.27302E+01  0.40383E+01  0.58627E+01
+  0.36216E-07  0.54635E-07  0.58262E-07  0.61135E-07  0.50065E-07  0.37570E-07
+  0.35453E-07  0.21822E-06  0.75181E-06  0.20818E-05  0.85678E-05  0.69269E-04
+  0.28170E-03  0.84913E-03  0.21311E-02  0.44979E-02  0.98370E-02  0.21363E-01
+  0.36978E-01  0.57603E-01  0.88766E-01  0.12670E+00  0.18026E+00  0.24865E+00
+  0.36913E+00  0.53559E+00  0.76408E+00  0.11328E+01  0.16433E+01  0.23457E+01
+  0.34220E+01  0.50541E+01  0.73238E+01  0.79740E-07  0.90601E-07  0.13475E-06
+  0.14649E-06  0.15212E-06  0.12489E-06  0.95141E-07  0.11721E-06  0.72765E-06
+  0.40986E-05  0.15592E-04  0.96406E-04  0.39518E-03  0.11002E-02  0.26368E-02
+  0.57310E-02  0.11429E-01  0.24034E-01  0.47217E-01  0.73324E-01  0.11271E+00
+  0.16053E+00  0.22802E+00  0.31405E+00  0.46573E+00  0.67511E+00  0.96222E+00
+  0.14254E+01  0.20660E+01  0.29462E+01  0.42934E+01  0.63334E+01  0.91639E+01
+  0.12734E-06  0.18684E-06  0.23839E-06  0.31583E-06  0.38631E-06  0.39042E-06
+  0.31091E-06  0.29251E-06  0.34028E-06  0.45485E-05  0.28973E-04  0.12725E-03
+  0.49524E-03  0.13011E-02  0.31835E-02  0.66723E-02  0.13480E-01  0.26474E-01
+  0.51828E-01  0.93444E-01  0.14324E+00  0.20350E+00  0.28851E+00  0.39672E+00
+  0.58767E+00  0.85105E+00  0.12119E+01  0.17940E+01  0.25981E+01  0.37020E+01
+  0.53902E+01  0.79435E+01  0.11480E+02  0.24737E-06  0.34577E-06  0.53371E-06
+  0.77428E-06  0.94278E-06  0.12872E-05  0.11202E-05  0.81545E-06  0.98869E-06
+  0.17553E-05  0.33245E-04  0.15300E-03  0.55395E-03  0.14820E-02  0.36075E-02
+  0.76440E-02  0.14962E-01  0.29524E-01  0.55099E-01  0.10085E+00  0.18195E+00
+  0.25780E+00  0.36475E+00  0.50065E+00  0.74095E+00  0.10720E+01  0.15253E+01
+  0.22567E+01  0.32662E+01  0.46508E+01  0.67670E+01  0.99650E+01  0.14388E+02
+  0.51814E-06  0.65019E-06  0.94473E-06  0.15495E-05  0.24216E-05  0.30891E-05
+  0.41183E-05  0.31590E-05  0.20433E-05  0.53069E-05  0.13068E-04  0.14923E-03
+  0.57156E-03  0.15885E-02  0.39259E-02  0.82898E-02  0.16424E-01  0.31511E-01
+  0.59091E-01  0.10472E+00  0.19405E+00  0.32628E+00  0.46068E+00  0.63108E+00
+  0.93321E+00  0.13491E+01  0.19181E+01  0.28367E+01  0.41036E+01  0.58398E+01
+  0.84932E+01  0.12501E+02  0.18038E+02  0.10960E-05  0.14600E-05  0.20102E-05
+  0.33381E-05  0.58517E-05  0.10906E-04  0.15309E-04  0.18416E-04  0.14414E-04
+  0.99049E-05  0.37893E-04  0.58367E-04  0.47697E-03  0.15551E-02  0.40512E-02
+  0.86180E-02  0.17092E-01  0.33146E-01  0.61224E-01  0.10891E+00  0.19764E+00
+  0.34445E+00  0.57968E+00  0.79254E+00  0.11717E+01  0.16930E+01  0.24058E+01
+  0.35580E+01  0.51460E+01  0.73213E+01  0.10646E+02  0.15667E+02  0.22598E+02
+  0.21951E-05  0.26134E-05  0.46700E-05  0.10695E-04  0.20873E-04  0.40709E-04
+  0.88370E-04  0.12325E-03  0.14430E-03  0.12711E-03  0.11578E-03  0.15191E-03
+  0.17540E-03  0.12689E-02  0.39177E-02  0.85330E-02  0.17088E-01  0.33287E-01
+  0.62258E-01  0.11001E+00  0.20016E+00  0.34511E+00  0.60619E+00  0.98815E+00
+  0.14621E+01  0.21133E+01  0.30030E+01  0.44445E+01  0.64305E+01  0.91497E+01
+  0.13310E+02  0.19594E+02  0.28261E+02  0.10886E-04  0.18208E-04  0.41281E-04
+  0.77116E-04  0.13243E-03  0.19429E-03  0.29228E-03  0.44662E-03  0.58394E-03
+  0.63797E-03  0.60588E-03  0.73064E-03  0.50647E-03  0.43855E-03  0.30965E-02
+  0.79034E-02  0.15971E-01  0.32535E-01  0.60758E-01  0.10802E+00  0.19633E+00
+  0.34036E+00  0.59723E+00  0.10168E+01  0.18028E+01  0.26107E+01  0.37144E+01
+  0.55094E+01  0.79823E+01  0.11368E+02  0.16556E+02  0.24401E+02  0.35218E+02
+  0.70077E-04  0.11640E-03  0.18752E-03  0.35131E-03  0.57351E-03  0.85967E-03
+  0.11128E-02  0.13542E-02  0.16236E-02  0.18213E-02  0.19210E-02  0.20250E-02
+  0.28857E-02  0.13268E-02  0.10923E-02  0.55917E-02  0.13646E-01  0.29064E-01
+  0.56716E-01  0.10213E+00  0.18600E+00  0.32361E+00  0.57628E+00  0.98077E+00
+  0.18304E+01  0.31798E+01  0.45376E+01  0.67599E+01  0.98214E+01  0.14014E+02
+  0.20456E+02  0.30217E+02  0.43677E+02  0.26123E-03  0.50493E-03  0.82839E-03
+  0.12401E-02  0.16320E-02  0.20827E-02  0.25242E-02  0.30040E-02  0.34750E-02
+  0.39529E-02  0.43889E-02  0.46683E-02  0.49250E-02  0.82411E-02  0.22592E-02
+  0.17933E-02  0.90752E-02  0.23940E-01  0.49889E-01  0.92625E-01  0.17262E+00
+  0.30169E+00  0.54390E+00  0.93769E+00  0.17644E+01  0.32225E+01  0.55137E+01
+  0.82593E+01  0.12042E+02  0.17223E+02  0.25213E+02  0.37343E+02  0.54072E+02
+  0.63678E-03  0.85820E-03  0.14523E-02  0.22403E-02  0.32207E-02  0.39885E-02
+  0.48840E-02  0.57762E-02  0.65773E-02  0.73566E-02  0.82302E-02  0.89181E-02
+  0.93407E-02  0.96342E-02  0.19552E-01  0.36486E-02  0.29104E-02  0.17024E-01
+  0.41623E-01  0.81753E-01  0.15806E+00  0.27964E+00  0.51081E+00  0.88739E+00
+  0.17063E+01  0.31304E+01  0.56189E+01  0.10108E+02  0.14787E+02  0.21197E+02
+  0.31112E+02  0.46202E+02  0.67010E+02  0.23430E-02  0.29961E-02  0.38486E-02
+  0.49801E-02  0.64757E-02  0.83217E-02  0.96922E-02  0.11238E-01  0.12664E-01
+  0.13860E-01  0.15337E-01  0.16899E-01  0.17923E-01  0.18099E-01  0.16966E-01
+  0.36813E-01  0.81878E-02  0.46197E-02  0.27025E-01  0.63202E-01  0.13383E+00
+  0.24507E+00  0.46096E+00  0.81088E+00  0.15990E+01  0.29967E+01  0.54053E+01
+  0.10250E+02  0.18002E+02  0.25893E+02  0.38155E+02  0.56869E+02  0.82683E+02
+  0.55924E-02  0.71303E-02  0.91199E-02  0.11538E-01  0.13446E-01  0.15957E-01
+  0.19036E-01  0.21311E-01  0.23782E-01  0.25847E-01  0.27539E-01  0.29981E-01
+  0.32215E-01  0.32953E-01  0.31450E-01  0.29276E-01  0.66257E-01  0.12997E-01
+  0.73337E-02  0.39602E-01  0.10489E+00  0.20601E+00  0.40754E+00  0.73176E+00
+  0.14883E+01  0.28404E+01  0.52147E+01  0.99641E+01  0.18384E+02  0.31684E+02
+  0.46869E+02  0.70108E+02  0.10216E+03  0.10680E-01  0.13583E-01  0.17318E-01
+  0.22149E-01  0.27822E-01  0.30774E-01  0.34626E-01  0.39302E-01  0.42580E-01
+  0.46042E-01  0.49039E-01  0.52461E-01  0.55429E-01  0.57309E-01  0.56137E-01
+  0.54461E-01  0.52050E-01  0.11140E+00  0.23579E-01  0.38806E-02  0.62863E-01
+  0.15202E+00  0.33722E+00  0.63224E+00  0.13552E+01  0.26499E+01  0.49408E+01
+  0.96571E+01  0.17903E+02  0.32369E+02  0.57446E+02  0.86289E+02  0.12605E+03
+  0.18964E-01  0.24067E-01  0.30607E-01  0.39022E-01  0.49897E-01  0.62385E-01
+  0.66684E-01  0.72244E-01  0.78906E-01  0.83387E-01  0.88224E-01  0.92638E-01
+  0.97964E-01  0.10041E+00  0.99712E-01  0.99229E-01  0.98453E-01  0.91467E-01
+  0.20611E+00  0.56144E-01  0.61598E-02  0.66524E-01  0.22981E+00  0.48664E+00
+  0.11670E+01  0.23902E+01  0.45613E+01  0.91372E+01  0.17288E+02  0.31383E+02
+  0.58573E+02  0.10566E+03  0.15487E+03  0.31539E-01  0.39956E-01  0.50705E-01
+  0.64480E-01  0.82192E-01  0.10507E+00  0.13098E+00  0.13725E+00  0.14525E+00
+  0.15463E+00  0.16144E+00  0.16908E+00  0.17698E+00  0.18114E+00  0.18147E+00
+  0.18328E+00  0.18646E+00  0.18297E+00  0.17799E+00  0.45182E+00  0.13369E+00
+  0.88005E-01  0.39599E-01  0.23713E+00  0.84974E+00  0.19636E+01  0.39570E+01
+  0.82863E+01  0.16075E+02  0.29821E+02  0.56186E+02  0.10692E+03  0.18823E+03
+  0.51989E-01  0.65766E-01  0.83312E-01  0.10572E+00  0.13442E+00  0.17131E+00
+  0.21889E+00  0.27237E+00  0.28214E+00  0.29419E+00  0.30813E+00  0.31810E+00
+  0.32859E+00  0.33751E+00  0.34014E+00  0.34646E+00  0.35707E+00  0.36231E+00
+  0.36911E+00  0.38664E+00  0.10140E+01  0.37727E+00  0.31043E+00  0.20954E+00
+  0.28955E+00  0.12263E+01  0.29407E+01  0.68835E+01  0.14047E+02  0.26860E+02
+  0.52278E+02  0.10105E+03  0.18785E+03  0.79033E-01  0.99846E-01  0.12630E+00
+  0.15999E+00  0.20299E+00  0.25803E+00  0.32869E+00  0.41973E+00  0.52139E+00
+  0.53571E+00  0.55288E+00  0.57135E+00  0.58380E+00  0.59359E+00  0.59700E+00
+  0.60673E+00  0.62413E+00  0.63677E+00  0.65615E+00  0.69160E+00  0.71271E+00
+  0.75877E+00  0.74859E+00  0.73919E+00  0.33262E+00  0.45964E+00  0.19466E+01
+  0.56016E+01  0.12292E+02  0.24325E+02  0.48732E+02  0.96815E+02  0.18133E+03
+  0.12071E+00  0.15233E+00  0.19243E+00  0.24339E+00  0.30828E+00  0.39107E+00
+  0.49695E+00  0.63274E+00  0.80742E+00  0.10016E+01  0.10271E+01  0.10561E+01
+  0.10864E+01  0.11015E+01  0.11081E+01  0.11259E+01  0.11575E+01  0.11869E+01
+  0.12330E+01  0.13116E+01  0.13875E+01  0.15208E+01  0.16214E+01  0.17825E+01
+  0.15645E+01  0.10560E+01  0.00000E+00  0.30900E+01  0.88916E+01  0.19512E+02
+  0.41834E+02  0.87024E+02  0.16832E+03  0.17883E+00  0.22543E+00  0.28444E+00
+  0.35931E+00  0.45442E+00  0.57544E+00  0.72976E+00  0.92692E+00  0.11794E+01
+  0.15031E+01  0.18612E+01  0.19022E+01  0.19476E+01  0.19891E+01  0.19968E+01
+  0.20222E+01  0.20701E+01  0.21179E+01  0.21955E+01  0.23275E+01  0.24699E+01
+  0.27109E+01  0.29441E+01  0.33092E+01  0.33011E+01  0.31044E+01  0.25145E+01
+  0.00000E+00  0.49050E+01  0.14114E+02  0.34418E+02  0.76621E+02  0.15349E+03
+  0.27051E+00  0.34063E+00  0.42934E+00  0.54175E+00  0.68428E+00  0.86525E+00
+  0.10955E+01  0.13888E+01  0.17630E+01  0.22410E+01  0.28522E+01  0.35222E+01
+  0.35880E+01  0.36534E+01  0.37037E+01  0.37428E+01  0.38180E+01  0.38983E+01
+  0.40300E+01  0.42515E+01  0.45065E+01  0.49253E+01  0.53790E+01  0.60755E+01
+  0.64203E+01  0.67374E+01  0.68993E+01  0.53220E+01  0.18385E+01  0.51907E+01
+  0.22406E+02  0.60096E+02  0.12974E+03  0.41249E+00  0.51886E+00  0.65332E+00
+  0.82343E+00  0.10389E+01  0.13121E+01  0.16588E+01  0.20996E+01  0.26605E+01
+  0.33748E+01  0.42851E+01  0.54417E+01  0.67026E+01  0.67980E+01  0.68819E+01
+  0.70172E+01  0.71352E+01  0.72667E+01  0.74841E+01  0.78464E+01  0.82791E+01
+  0.89753E+01  0.97728E+01  0.10978E+02  0.11870E+02  0.12971E+02  0.14260E+02
+  0.14081E+02  0.12672E+02  0.87553E+01  0.41201E+01  0.35566E+02  0.95398E+02
+  0.62898E+00  0.79025E+00  0.99397E+00  0.12515E+01  0.15773E+01  0.19899E+01
+  0.25127E+01  0.31760E+01  0.40184E+01  0.50885E+01  0.64489E+01  0.81736E+01
+  0.10357E+02  0.12711E+02  0.12832E+02  0.13052E+02  0.13376E+02  0.13582E+02
+  0.13928E+02  0.14503E+02  0.15205E+02  0.16319E+02  0.17633E+02  0.19596E+02
+  0.21299E+02  0.23553E+02  0.26474E+02  0.28295E+02  0.29802E+02  0.30172E+02
+  0.23165E+02  0.00000E+00  0.47049E+02  0.95487E+00  0.11981E+01  0.15053E+01
+  0.18932E+01  0.23838E+01  0.30040E+01  0.37892E+01  0.47839E+01  0.60447E+01
+  0.76438E+01  0.96720E+01  0.12239E+02  0.15484E+02  0.19562E+02  0.23914E+02
+  0.24232E+02  0.24746E+02  0.25329E+02  0.25860E+02  0.26746E+02  0.27840E+02
+  0.29569E+02  0.31640E+02  0.34709E+02  0.37588E+02  0.41496E+02  0.46736E+02
+  0.51364E+02  0.56893E+02  0.63076E+02  0.63865E+02  0.51479E+02  0.20764E+02
+  0.14691E+01  0.18405E+01  0.23093E+01  0.29012E+01  0.36489E+01  0.45938E+01
+  0.57889E+01  0.73006E+01  0.92144E+01  0.11638E+02  0.14708E+02  0.18588E+02
+  0.23488E+02  0.29645E+02  0.37339E+02  0.45799E+02  0.46573E+02  0.47529E+02
+  0.48876E+02  0.50259E+02  0.51983E+02  0.54689E+02  0.57964E+02  0.62780E+02
+  0.67536E+02  0.74068E+02  0.82949E+02  0.91992E+02  0.10377E+03  0.11883E+03
+  0.13142E+03  0.13517E+03  0.12842E+03  0.22302E+01  0.27892E+01  0.34944E+01
+  0.43843E+01  0.55079E+01  0.69269E+01  0.87199E+01  0.10987E+02  0.13852E+02
+  0.17478E+02  0.22064E+02  0.27854E+02  0.35158E+02  0.44333E+02  0.55806E+02
+  0.70468E+02  0.86666E+02  0.88056E+02  0.90177E+02  0.93242E+02  0.95845E+02
+  0.99940E+02  0.10492E+03  0.11221E+03  0.11959E+03  0.12978E+03  0.14371E+03
+  0.15878E+03  0.17900E+03  0.20590E+03  0.23391E+03  0.25828E+03  0.28162E+03
+  0.34412E+01  0.42947E+01  0.53709E+01  0.67287E+01  0.84420E+01  0.10605E+02
+  0.13337E+02  0.16786E+02  0.21146E+02  0.26655E+02  0.33617E+02  0.42401E+02
+  0.53477E+02  0.67390E+02  0.84803E+02  0.10699E+03  0.13543E+03  0.16648E+03
+  0.16967E+03  0.17458E+03  0.18050E+03  0.18681E+03  0.19450E+03  0.20573E+03
+  0.21730E+03  0.23333E+03  0.25527E+03  0.27995E+03  0.31351E+03  0.35891E+03
+  0.41089E+03  0.46711E+03  0.53615E+03  0.52780E+01  0.65700E+01  0.81990E+01
+  0.10254E+02  0.12845E+02  0.16116E+02  0.20244E+02  0.25456E+02  0.32037E+02
+  0.40345E+02  0.50839E+02  0.64071E+02  0.80746E+02  0.10170E+03  0.12793E+03
+  0.16128E+03  0.20387E+03  0.25791E+03  0.31782E+03  0.32512E+03  0.33446E+03
+  0.34766E+03  0.35931E+03  0.37630E+03  0.39397E+03  0.41847E+03  0.45202E+03
+  0.49053E+03  0.54316E+03  0.61477E+03  0.70033E+03  0.80049E+03  0.93164E+03
+  0.48655E-10  0.83987E-09  0.26006E-08  0.69326E-08  0.12071E-07  0.32137E-07
+  0.42184E-07  0.80674E-07  0.16335E-06  0.36023E-06  0.74732E-06  0.15597E-05
+  0.56193E-05  0.29745E-04  0.17372E-03  0.46075E-03  0.17002E-02  0.40709E-02
+  0.77953E-02  0.13873E-01  0.23117E-01  0.38168E-01  0.58109E-01  0.88887E-01
+  0.13187E+00  0.19978E+00  0.30511E+00  0.46607E+00  0.70900E+00  0.10934E+01
+  0.16649E+01  0.25778E+01  0.39706E+01  0.60526E-09  0.15447E-09  0.20390E-08
+  0.68114E-08  0.17332E-07  0.30248E-07  0.78395E-07  0.10778E-06  0.21847E-06
+  0.48111E-06  0.98866E-06  0.20309E-05  0.93845E-05  0.57639E-04  0.22214E-03
+  0.58752E-03  0.21641E-02  0.51706E-02  0.98830E-02  0.17561E-01  0.29223E-01
+  0.48196E-01  0.73297E-01  0.11200E+00  0.16598E+00  0.25118E+00  0.38316E+00
+  0.58449E+00  0.88778E+00  0.13666E+01  0.20760E+01  0.32058E+01  0.49216E+01
+  0.21435E-08  0.13836E-08  0.40868E-09  0.56022E-08  0.17202E-07  0.43672E-07
+  0.76044E-07  0.16492E-06  0.30110E-06  0.58102E-06  0.13204E-05  0.24447E-05
+  0.14403E-04  0.99666E-04  0.41792E-03  0.75208E-03  0.27629E-02  0.65839E-02
+  0.12555E-01  0.22266E-01  0.36993E-01  0.60929E-01  0.92553E-01  0.14126E+00
+  0.20913E+00  0.31615E+00  0.48175E+00  0.73402E+00  0.11134E+01  0.17111E+01
+  0.25946E+01  0.39975E+01  0.61205E+01  0.60628E-08  0.53833E-08  0.36606E-08
+  0.12975E-08  0.13833E-07  0.42910E-07  0.10723E-06  0.19930E-06  0.41480E-06
+  0.81507E-06  0.17273E-05  0.31546E-05  0.32767E-04  0.15565E-03  0.71119E-03
+  0.12390E-02  0.35394E-02  0.84060E-02  0.15985E-01  0.28283E-01  0.46900E-01
+  0.77124E-01  0.11699E+00  0.17835E+00  0.26375E+00  0.39829E+00  0.60631E+00
+  0.92283E+00  0.13981E+01  0.21459E+01  0.32486E+01  0.49961E+01  0.76318E+01
+  0.11294E-07  0.15876E-07  0.14511E-07  0.96847E-08  0.20594E-08  0.32939E-07
+  0.10527E-06  0.24378E-06  0.63466E-06  0.11502E-05  0.27780E-05  0.81803E-05
+  0.61445E-04  0.29019E-03  0.11011E-02  0.19517E-02  0.45634E-02  0.10765E-01
+  0.20400E-01  0.35996E-01  0.59554E-01  0.97753E-01  0.14805E+00  0.22540E+00
+  0.33293E+00  0.50224E+00  0.76374E+00  0.11613E+01  0.17576E+01  0.26945E+01
+  0.40737E+01  0.62551E+01  0.95375E+01  0.26653E-07  0.28322E-07  0.40144E-07
+  0.35832E-07  0.24597E-07  0.49041E-08  0.82165E-07  0.28098E-06  0.71789E-06
+  0.19432E-05  0.42789E-05  0.16743E-04  0.11160E-03  0.48864E-03  0.14773E-02
+  0.28978E-02  0.59103E-02  0.12710E-01  0.26113E-01  0.45921E-01  0.75770E-01
+  0.12410E+00  0.18760E+00  0.28517E+00  0.42067E+00  0.63390E+00  0.96296E+00
+  0.14627E+01  0.22116E+01  0.33870E+01  0.51148E+01  0.78434E+01  0.11941E+02
+  0.44152E-07  0.66415E-07  0.70871E-07  0.99129E-07  0.89383E-07  0.61009E-07
+  0.12975E-07  0.21615E-06  0.98262E-06  0.23361E-05  0.82845E-05  0.28482E-04
+  0.16406E-03  0.75040E-03  0.19325E-02  0.36696E-02  0.76883E-02  0.14951E-01
+  0.29540E-01  0.58736E-01  0.96604E-01  0.15782E+00  0.23804E+00  0.36122E+00
+  0.53205E+00  0.80073E+00  0.12151E+01  0.18439E+01  0.27852E+01  0.42614E+01
+  0.64288E+01  0.98471E+01  0.14972E+02  0.76346E-07  0.10322E-06  0.14777E-06
+  0.17541E-06  0.21666E-06  0.22133E-06  0.14772E-06  0.41201E-07  0.69331E-06
+  0.31846E-05  0.11767E-04  0.65028E-04  0.24682E-03  0.99770E-03  0.23167E-02
+  0.45489E-02  0.90698E-02  0.17885E-01  0.32931E-01  0.64624E-01  0.12344E+00
+  0.20107E+00  0.30249E+00  0.45810E+00  0.67358E+00  0.10123E+01  0.15344E+01
+  0.23260E+01  0.35100E+01  0.53656E+01  0.80870E+01  0.12375E+02  0.18794E+02
+  0.14745E-06  0.20043E-06  0.27557E-06  0.40856E-06  0.55677E-06  0.62764E-06
+  0.73069E-06  0.41379E-06  0.13077E-06  0.20566E-05  0.13828E-04  0.96058E-04
+  0.35557E-03  0.11988E-02  0.27363E-02  0.53225E-02  0.10579E-01  0.20110E-01
+  0.37291E-01  0.69345E-01  0.13356E+00  0.25658E+00  0.38486E+00  0.58155E+00
+  0.85343E+00  0.12807E+01  0.19387E+01  0.29358E+01  0.44261E+01  0.67601E+01
+  0.10180E+02  0.15564E+02  0.23614E+02  0.32633E-06  0.42139E-06  0.52913E-06
+  0.74836E-06  0.11721E-05  0.17539E-05  0.19848E-05  0.23592E-05  0.11160E-05
+  0.31139E-06  0.90693E-05  0.10758E-03  0.46797E-03  0.13992E-02  0.31158E-02
+  0.60114E-02  0.11749E-01  0.22458E-01  0.40361E-01  0.75264E-01  0.13993E+00
+  0.27476E+00  0.49010E+00  0.73878E+00  0.10819E+01  0.16208E+01  0.24504E+01
+  0.37067E+01  0.55829E+01  0.85201E+01  0.12820E+02  0.19586E+02  0.29691E+02
+  0.68926E-06  0.95665E-06  0.12310E-05  0.14640E-05  0.22566E-05  0.38134E-05
+  0.60318E-05  0.80145E-05  0.81304E-05  0.37518E-05  0.99281E-06  0.72922E-04
+  0.47435E-03  0.14968E-02  0.33942E-02  0.65229E-02  0.12629E-01  0.23925E-01
+  0.43293E-01  0.78969E-01  0.14744E+00  0.28330E+00  0.52028E+00  0.93813E+00
+  0.13708E+01  0.20504E+01  0.30961E+01  0.46787E+01  0.70408E+01  0.10737E+02
+  0.16144E+02  0.24649E+02  0.37343E+02  0.14205E-05  0.18109E-05  0.19676E-05
+  0.32452E-05  0.74517E-05  0.14350E-04  0.25509E-04  0.56084E-04  0.69777E-04
+  0.70583E-04  0.38525E-04  0.14519E-04  0.35409E-03  0.14273E-02  0.35549E-02
+  0.69462E-02  0.13310E-01  0.24873E-01  0.44892E-01  0.82233E-01  0.15213E+00
+  0.29318E+00  0.53055E+00  0.99326E+00  0.17361E+01  0.25928E+01  0.39106E+01
+  0.59038E+01  0.88770E+01  0.13529E+02  0.20329E+02  0.31021E+02  0.46971E+02
+  0.42778E-05  0.66132E-05  0.10529E-04  0.22791E-04  0.42694E-04  0.75542E-04
+  0.11442E-03  0.18206E-03  0.28191E-03  0.34732E-03  0.31402E-03  0.16143E-03
+  0.18007E-03  0.12151E-02  0.34466E-02  0.70953E-02  0.14135E-01  0.25529E-01
+  0.46662E-01  0.84072E-01  0.15609E+00  0.29902E+00  0.54171E+00  0.10099E+01
+  0.18327E+01  0.32769E+01  0.49370E+01  0.74468E+01  0.11189E+02  0.17042E+02
+  0.25594E+02  0.39039E+02  0.59086E+02  0.14080E-04  0.32097E-04  0.55958E-04
+  0.95964E-04  0.22158E-03  0.39492E-03  0.62373E-03  0.80784E-03  0.95788E-03
+  0.10971E-02  0.11150E-02  0.94893E-03  0.52794E-03  0.74962E-03  0.26775E-02
+  0.63437E-02  0.13587E-01  0.25955E-01  0.46206E-01  0.84801E-01  0.15757E+00
+  0.29992E+00  0.54162E+00  0.10199E+01  0.18450E+01  0.34326E+01  0.62010E+01
+  0.93537E+01  0.14053E+02  0.21408E+02  0.32148E+02  0.49038E+02  0.74215E+02
+  0.17884E-03  0.24258E-03  0.44291E-03  0.70775E-03  0.10463E-02  0.13721E-02
+  0.17399E-02  0.20786E-02  0.24363E-02  0.27463E-02  0.29738E-02  0.29946E-02
+  0.25645E-02  0.14674E-02  0.11681E-02  0.41506E-02  0.11024E-01  0.22944E-01
+  0.43314E-01  0.80495E-01  0.15223E+00  0.29444E+00  0.53049E+00  0.10066E+01
+  0.18412E+01  0.34250E+01  0.64507E+01  0.11683E+02  0.17569E+02  0.26791E+02
+  0.40256E+02  0.61445E+02  0.93027E+02  0.36260E-03  0.46260E-03  0.63191E-03
+  0.11913E-02  0.19311E-02  0.28583E-02  0.35893E-02  0.44370E-02  0.52499E-02
+  0.59153E-02  0.64236E-02  0.67751E-02  0.65888E-02  0.55333E-02  0.37941E-02
+  0.13640E-02  0.60845E-02  0.17095E-01  0.36421E-01  0.72103E-01  0.14198E+00
+  0.28250E+00  0.51275E+00  0.98244E+00  0.18086E+01  0.34098E+01  0.64275E+01
+  0.12140E+02  0.21922E+02  0.33480E+02  0.50348E+02  0.76921E+02  0.11653E+03
+  0.17626E-02  0.22453E-02  0.28697E-02  0.36948E-02  0.48928E-02  0.64711E-02
+  0.84270E-02  0.98321E-02  0.11386E-01  0.12749E-01  0.13744E-01  0.14695E-01
+  0.15270E-01  0.14574E-01  0.12955E-01  0.10946E-01  0.14357E-01  0.43412E-02
+  0.21423E-01  0.53956E-01  0.11978E+00  0.25543E+00  0.47546E+00  0.93247E+00
+  0.17354E+01  0.33114E+01  0.63460E+01  0.12018E+02  0.22659E+02  0.41613E+02
+  0.62696E+02  0.95962E+02  0.14556E+03  0.49818E-02  0.63328E-02  0.80716E-02
+  0.10318E-01  0.13082E-01  0.15358E-01  0.18341E-01  0.22012E-01  0.24614E-01
+  0.27382E-01  0.29477E-01  0.30710E-01  0.32317E-01  0.32924E-01  0.32122E-01
+  0.30989E-01  0.27148E-01  0.56921E-01  0.68908E-02  0.20402E-01  0.79532E-01
+  0.20704E+00  0.41143E+00  0.84907E+00  0.16182E+01  0.31457E+01  0.61232E+01
+  0.11809E+02  0.22342E+02  0.42906E+02  0.77737E+02  0.11931E+03  0.18133E+03
+  0.10559E-01  0.13396E-01  0.17032E-01  0.21707E-01  0.27748E-01  0.34954E-01
+  0.38887E-01  0.44000E-01  0.50192E-01  0.54358E-01  0.58633E-01  0.61809E-01
+  0.64625E-01  0.66296E-01  0.67638E-01  0.68781E-01  0.67465E-01  0.65510E-01
+  0.16274E+00  0.38283E-01  0.10796E-01  0.12625E+00  0.30855E+00  0.71937E+00
+  0.14431E+01  0.29072E+01  0.57912E+01  0.11362E+02  0.21904E+02  0.42274E+02
+  0.80057E+02  0.14790E+03  0.22537E+03  0.20545E-01  0.26023E-01  0.33019E-01
+  0.41980E-01  0.53501E-01  0.68374E-01  0.85739E-01  0.91813E-01  0.99566E-01
+  0.10885E+00  0.11460E+00  0.12030E+00  0.12443E+00  0.12950E+00  0.13222E+00
+  0.13665E+00  0.13930E+00  0.14280E+00  0.14504E+00  0.38296E+00  0.99841E-01
+  0.00000E+00  0.15417E+00  0.53238E+00  0.12020E+01  0.25934E+01  0.53735E+01
+  0.10788E+02  0.21137E+02  0.41595E+02  0.79043E+02  0.15269E+03  0.27985E+03
+  0.37862E-01  0.47888E-01  0.60661E-01  0.76969E-01  0.97852E-01  0.12469E+00
+  0.15931E+00  0.19924E+00  0.20876E+00  0.22082E+00  0.23497E+00  0.24431E+00
+  0.25426E+00  0.26389E+00  0.27135E+00  0.28289E+00  0.29440E+00  0.31079E+00
+  0.32939E+00  0.34751E+00  0.95736E+00  0.27563E+00  0.18136E+00  0.12236E+00
+  0.67608E+00  0.19081E+01  0.44598E+01  0.95335E+01  0.19359E+02  0.39144E+02
+  0.76187E+02  0.14852E+03  0.28540E+03  0.66199E-01  0.83627E-01  0.10578E+00
+  0.13399E+00  0.16999E+00  0.21610E+00  0.27531E+00  0.35162E+00  0.43888E+00
+  0.45477E+00  0.47430E+00  0.49661E+00  0.51100E+00  0.52578E+00  0.54457E+00
+  0.56779E+00  0.59390E+00  0.63130E+00  0.67834E+00  0.73086E+00  0.77919E+00
+  0.21707E+01  0.76569E+00  0.57578E+00  0.19423E+00  0.80491E+00  0.30289E+01
+  0.76240E+01  0.16727E+02  0.35456E+02  0.71014E+02  0.14243E+03  0.27641E+03
+  0.10797E+00  0.13624E+00  0.17212E+00  0.21769E+00  0.27573E+00  0.34980E+00
+  0.44457E+00  0.56616E+00  0.72249E+00  0.90034E+00  0.92408E+00  0.95201E+00
+  0.98169E+00  0.10006E+01  0.10258E+01  0.10639E+01  0.11085E+01  0.11727E+01
+  0.12559E+01  0.13554E+01  0.14547E+01  0.15191E+01  0.16253E+01  0.15627E+01
+  0.13710E+01  0.61666E+00  0.12777E+01  0.54091E+01  0.13832E+02  0.31609E+02
+  0.65664E+02  0.13527E+03  0.26877E+03  0.17256E+00  0.21752E+00  0.27447E+00
+  0.34672E+00  0.43852E+00  0.55537E+00  0.70442E+00  0.89502E+00  0.11391E+01
+  0.14528E+01  0.18083E+01  0.18526E+01  0.19025E+01  0.19558E+01  0.19987E+01
+  0.20634E+01  0.21412E+01  0.22530E+01  0.24000E+01  0.25823E+01  0.27850E+01
+  0.29750E+01  0.32725E+01  0.34400E+01  0.35832E+01  0.32645E+01  0.19578E+01
+  0.13521E+01  0.85866E+01  0.24700E+02  0.56197E+02  0.12210E+03  0.25052E+03
+  0.27027E+00  0.34032E+00  0.42898E+00  0.54127E+00  0.68371E+00  0.86462E+00
+  0.10949E+01  0.13884E+01  0.17630E+01  0.22428E+01  0.28575E+01  0.35511E+01
+  0.36281E+01  0.37156E+01  0.38257E+01  0.39293E+01  0.40555E+01  0.42369E+01
+  0.44771E+01  0.47802E+01  0.51323E+01  0.55025E+01  0.60719E+01  0.65619E+01
+  0.71673E+01  0.74382E+01  0.69094E+01  0.46616E+01  0.10732E+01  0.15145E+02
+  0.43566E+02  0.10513E+03  0.22692E+03  0.39931E+00  0.50225E+00  0.63242E+00
+  0.79713E+00  0.10057E+01  0.12703E+01  0.16061E+01  0.20334E+01  0.25769E+01
+  0.32707E+01  0.41562E+01  0.52869E+01  0.65517E+01  0.66731E+01  0.68358E+01
+  0.70586E+01  0.72379E+01  0.74989E+01  0.78466E+01  0.82878E+01  0.88068E+01
+  0.93703E+01  0.10241E+02  0.11066E+02  0.12152E+02  0.13003E+02  0.13196E+02
+  0.11882E+02  0.74001E+01  0.51108E+01  0.31253E+02  0.89901E+02  0.20736E+03
+  0.59910E+00  0.75267E+00  0.94671E+00  0.11920E+01  0.15024E+01  0.18954E+01
+  0.23936E+01  0.30260E+01  0.38290E+01  0.48509E+01  0.61513E+01  0.78066E+01
+  0.99081E+01  0.12249E+02  0.12481E+02  0.12820E+02  0.13224E+02  0.13608E+02
+  0.14122E+02  0.14778E+02  0.15557E+02  0.16426E+02  0.17767E+02  0.19125E+02
+  0.20967E+02  0.22736E+02  0.24081E+02  0.24256E+02  0.21764E+02  0.11747E+02
+  0.10817E+02  0.64873E+02  0.17565E+03  0.87760E+00  0.11011E+01  0.13834E+01
+  0.17400E+01  0.21907E+01  0.27609E+01  0.34827E+01  0.43975E+01  0.55567E+01
+  0.70287E+01  0.88971E+01  0.11269E+02  0.14272E+02  0.18072E+02  0.22342E+02
+  0.22810E+02  0.23399E+02  0.24196E+02  0.24920E+02  0.25848E+02  0.26953E+02
+  0.28194E+02  0.30130E+02  0.32138E+02  0.34912E+02  0.37781E+02  0.40465E+02
+  0.42321E+02  0.42004E+02  0.34547E+02  0.15539E+02  0.34342E+02  0.13933E+03
+  0.12636E+01  0.15830E+01  0.19862E+01  0.24953E+01  0.31383E+01  0.39511E+01
+  0.49787E+01  0.62796E+01  0.79256E+01  0.10012E+02  0.12654E+02  0.16000E+02
+  0.20227E+02  0.25562E+02  0.32364E+02  0.40070E+02  0.40853E+02  0.41985E+02
+  0.43436E+02  0.44697E+02  0.46198E+02  0.47879E+02  0.50559E+02  0.53349E+02
+  0.57266E+02  0.61446E+02  0.65687E+02  0.69445E+02  0.71519E+02  0.66678E+02
+  0.51185E+02  0.49332E+01  0.95404E+02  0.17535E+01  0.21928E+01  0.27473E+01
+  0.34469E+01  0.43300E+01  0.54455E+01  0.68550E+01  0.86367E+01  0.10889E+02
+  0.13738E+02  0.17341E+02  0.21894E+02  0.27631E+02  0.34852E+02  0.44022E+02
+  0.55784E+02  0.68949E+02  0.70374E+02  0.72309E+02  0.74699E+02  0.76561E+02
+  0.78609E+02  0.82031E+02  0.85515E+02  0.90523E+02  0.95858E+02  0.10136E+03
+  0.10653E+03  0.11024E+03  0.10664E+03  0.92612E+02  0.46427E+02  0.54817E+02
+  0.23936E+01  0.29870E+01  0.37356E+01  0.46798E+01  0.58711E+01  0.73752E+01
+  0.92741E+01  0.11673E+02  0.14701E+02  0.18528E+02  0.23360E+02  0.29453E+02
+  0.37118E+02  0.46742E+02  0.58921E+02  0.74469E+02  0.94198E+02  0.11652E+03
+  0.11888E+03  0.12195E+03  0.12547E+03  0.12775E+03  0.13191E+03  0.13596E+03
+  0.14201E+03  0.14833E+03  0.15479E+03  0.16090E+03  0.16552E+03  0.16186E+03
+  0.14744E+03  0.98006E+02  0.92125E+01  0.31220E+01  0.38858E+01  0.48493E+01
+  0.60640E+01  0.75964E+01  0.95297E+01  0.11969E+02  0.15049E+02  0.18933E+02
+  0.23836E+02  0.30018E+02  0.37801E+02  0.47570E+02  0.59804E+02  0.75233E+02
+  0.94847E+02  0.11961E+03  0.15133E+03  0.18698E+03  0.19033E+03  0.19430E+03
+  0.19840E+03  0.20279E+03  0.20657E+03  0.21278E+03  0.21880E+03  0.22442E+03
+  0.22905E+03  0.23132E+03  0.22276E+03  0.20138E+03  0.13869E+03  0.11113E+02
+  0.39940E+01  0.49555E+01  0.61681E+01  0.76969E+01  0.96246E+01  0.12056E+02
+  0.15123E+02  0.18991E+02  0.23866E+02  0.30015E+02  0.37755E+02  0.47491E+02
+  0.59683E+02  0.74918E+02  0.94072E+02  0.11833E+03  0.14882E+03  0.18766E+03
+  0.23709E+03  0.29219E+03  0.29586E+03  0.29961E+03  0.30687E+03  0.30921E+03
+  0.31443E+03  0.31848E+03  0.32101E+03  0.32121E+03  0.31733E+03  0.29834E+03
+  0.26294E+03  0.17637E+03  0.13760E+02  0.44902E-09  0.15734E-08  0.42802E-08
+  0.10298E-07  0.23949E-07  0.52075E-07  0.11434E-06  0.26004E-06  0.65572E-06
+  0.14501E-05  0.30243E-05  0.10890E-04  0.77609E-04  0.35562E-03  0.12041E-02
+  0.22864E-02  0.49875E-02  0.11377E-01  0.22619E-01  0.40137E-01  0.66705E-01
+  0.10988E+00  0.16689E+00  0.25463E+00  0.37675E+00  0.56904E+00  0.86619E+00
+  0.13178E+01  0.19952E+01  0.30591E+01  0.46246E+01  0.70986E+01  0.10818E+02
+  0.34926E-09  0.13636E-08  0.41628E-08  0.11551E-07  0.26336E-07  0.60823E-07
+  0.13041E-06  0.29400E-06  0.86739E-06  0.20910E-05  0.55358E-05  0.19361E-04
+  0.12233E-03  0.55409E-03  0.15557E-02  0.30825E-02  0.64037E-02  0.13166E-01
+  0.27113E-01  0.50990E-01  0.84587E-01  0.13912E+00  0.21105E+00  0.32167E+00
+  0.47551E+00  0.71766E+00  0.10915E+01  0.16593E+01  0.25104E+01  0.38457E+01
+  0.58080E+01  0.89052E+01  0.13553E+02  0.12627E-09  0.92927E-09  0.34437E-08
+  0.10894E-07  0.29120E-07  0.66315E-07  0.14374E-06  0.31313E-06  0.82665E-06
+  0.28446E-05  0.95894E-05  0.39476E-04  0.17769E-03  0.77513E-03  0.18959E-02
+  0.37589E-02  0.78568E-02  0.15484E-01  0.29785E-01  0.60381E-01  0.10745E+00
+  0.17641E+00  0.26722E+00  0.40678E+00  0.60069E+00  0.90575E+00  0.13765E+01
+  0.20910E+01  0.31608E+01  0.48386E+01  0.73014E+01  0.11184E+02  0.17002E+02
+  0.51820E-09  0.14254E-09  0.28048E-08  0.11511E-07  0.33041E-07  0.89238E-07
+  0.18114E-06  0.34299E-06  0.83709E-06  0.27023E-05  0.13238E-04  0.78257E-04
+  0.25371E-03  0.95669E-03  0.22307E-02  0.44389E-02  0.90283E-02  0.17853E-01
+  0.33246E-01  0.64099E-01  0.12640E+00  0.22411E+00  0.33885E+00  0.51504E+00
+  0.75962E+00  0.11442E+01  0.17372E+01  0.26369E+01  0.39832E+01  0.60924E+01
+  0.91867E+01  0.14060E+02  0.21352E+02  0.13312E-08  0.85950E-09  0.12182E-08
+  0.87545E-08  0.38243E-07  0.10935E-06  0.29999E-06  0.52282E-06  0.86235E-06
+  0.22607E-05  0.13557E-04  0.10460E-03  0.37942E-03  0.11363E-02  0.25681E-02
+  0.50765E-02  0.10136E-01  0.19734E-01  0.36714E-01  0.68899E-01  0.13154E+00
+  0.26264E+00  0.43047E+00  0.65311E+00  0.96182E+00  0.14470E+01  0.21946E+01
+  0.33282E+01  0.50233E+01  0.76778E+01  0.11568E+02  0.17690E+02  0.26843E+02
+  0.28641E-08  0.28961E-08  0.11532E-08  0.62051E-08  0.30806E-07  0.12047E-06
+  0.36947E-06  0.10025E-05  0.18988E-05  0.24012E-05  0.95787E-05  0.10507E-03
+  0.46812E-03  0.13113E-02  0.28876E-02  0.56172E-02  0.11096E-01  0.21405E-01
+  0.39311E-01  0.73660E-01  0.13816E+00  0.27028E+00  0.50337E+00  0.82968E+00
+  0.12196E+01  0.18320E+01  0.27752E+01  0.42043E+01  0.63398E+01  0.96819E+01
+  0.14577E+02  0.22275E+02  0.33774E+02  0.19564E-07  0.24248E-07  0.28580E-07
+  0.45897E-07  0.68524E-07  0.33864E-07  0.28234E-06  0.18458E-05  0.58765E-05
+  0.11888E-04  0.12591E-04  0.84955E-04  0.47591E-03  0.14127E-02  0.31765E-02
+  0.61057E-02  0.11807E-01  0.22603E-01  0.41376E-01  0.76727E-01  0.14433E+00
+  0.27917E+00  0.51316E+00  0.96788E+00  0.15462E+01  0.23191E+01  0.35089E+01
+  0.53105E+01  0.80010E+01  0.12210E+02  0.18370E+02  0.28054E+02  0.42509E+02
+  0.39806E-07  0.53127E-07  0.75785E-07  0.10831E-06  0.25133E-06  0.40188E-06
+  0.36888E-06  0.15538E-05  0.11896E-04  0.36422E-04  0.77410E-04  0.14381E-03
+  0.48088E-03  0.14770E-02  0.34461E-02  0.66883E-02  0.12949E-01  0.23652E-01
+  0.43505E-01  0.79850E-01  0.14917E+00  0.28862E+00  0.52626E+00  0.98754E+00
+  0.18049E+01  0.29418E+01  0.44441E+01  0.67172E+01  0.10109E+02  0.15414E+02
+  0.23171E+02  0.35361E+02  0.53545E+02  0.16885E-07  0.26947E-07  0.28316E-07
+  0.13655E-07  0.38023E-06  0.17541E-05  0.54124E-05  0.13943E-04  0.34686E-04
+  0.82128E-04  0.17266E-03  0.33953E-03  0.73182E-03  0.18271E-02  0.39068E-02
+  0.75147E-02  0.14468E-01  0.26644E-01  0.46904E-01  0.84976E-01  0.15753E+00
+  0.29963E+00  0.54514E+00  0.10205E+01  0.18533E+01  0.34525E+01  0.56622E+01
+  0.85385E+01  0.12826E+02  0.19524E+02  0.29312E+02  0.44681E+02  0.67588E+02
+  0.13822E-06  0.19715E-06  0.25538E-06  0.14023E-06  0.64376E-06  0.32795E-05
+  0.98150E-05  0.24738E-04  0.57252E-04  0.12254E-03  0.25715E-03  0.51933E-03
+  0.10513E-02  0.25013E-02  0.48619E-02  0.83984E-02  0.15853E-01  0.28790E-01
+  0.50687E-01  0.90456E-01  0.16562E+00  0.31116E+00  0.55971E+00  0.10507E+01
+  0.19056E+01  0.35302E+01  0.66220E+01  0.10848E+02  0.16265E+02  0.24722E+02
+  0.37070E+02  0.56446E+02  0.85306E+02  0.27228E-06  0.32805E-06  0.60148E-06
+  0.90568E-06  0.59529E-06  0.22851E-05  0.11032E-04  0.31003E-04  0.75230E-04
+  0.16092E-03  0.33189E-03  0.67937E-03  0.13859E-02  0.28172E-02  0.65009E-02
+  0.10387E-01  0.17624E-01  0.31450E-01  0.54595E-01  0.96052E-01  0.17394E+00
+  0.32500E+00  0.57797E+00  0.10782E+01  0.19612E+01  0.36285E+01  0.67691E+01
+  0.12683E+02  0.20659E+02  0.31345E+02  0.46932E+02  0.71376E+02  0.10776E+03
+  0.20864E-04  0.27292E-04  0.35979E-04  0.51266E-04  0.75667E-04  0.10903E-03
+  0.14135E-03  0.16883E-03  0.18019E-03  0.15906E-03  0.59797E-04  0.25384E-03
+  0.10180E-02  0.25709E-02  0.52805E-02  0.12500E-01  0.18626E-01  0.31544E-01
+  0.54772E-01  0.96283E-01  0.17432E+00  0.32584E+00  0.57803E+00  0.10778E+01
+  0.19579E+01  0.36499E+01  0.68272E+01  0.12764E+02  0.23843E+02  0.39390E+02
+  0.58974E+02  0.89700E+02  0.13543E+03  0.12629E-03  0.16331E-03  0.21239E-03
+  0.27766E-03  0.36523E-03  0.44947E-03  0.52868E-03  0.62684E-03  0.70042E-03
+  0.72568E-03  0.62930E-03  0.28811E-03  0.75378E-03  0.31177E-02  0.69014E-02
+  0.12589E-01  0.22605E-01  0.49032E-01  0.66834E-01  0.11122E+00  0.19676E+00
+  0.36056E+00  0.62735E+00  0.11521E+01  0.20649E+01  0.38085E+01  0.71198E+01
+  0.13362E+02  0.24834E+02  0.46744E+02  0.87063E+02  0.14364E+03  0.21633E+03
+  0.28927E-04  0.36509E-04  0.45833E-04  0.56406E-04  0.67449E-04  0.75261E-04
+  0.64449E-04  0.21863E-04  0.12659E-03  0.43194E-03  0.10010E-02  0.20444E-02
+  0.40658E-02  0.77501E-02  0.13314E-01  0.21285E-01  0.34621E-01  0.54909E-01
+  0.91116E-01  0.14792E+00  0.24250E+00  0.42783E+00  0.72402E+00  0.12958E+01
+  0.22761E+01  0.41251E+01  0.75990E+01  0.14090E+02  0.26144E+02  0.48978E+02
+  0.90430E+02  0.17029E+03  0.28130E+03  0.54437E-03  0.69761E-03  0.89785E-03
+  0.11606E-02  0.15080E-02  0.19695E-02  0.25839E-02  0.31097E-02  0.33479E-02
+  0.35971E-02  0.37036E-02  0.34381E-02  0.24247E-02  0.00000E+00  0.54212E-02
+  0.12955E-01  0.25814E-01  0.45006E-01  0.75975E-01  0.13311E+00  0.23320E+00
+  0.40581E+00  0.69164E+00  0.12506E+01  0.22058E+01  0.40173E+01  0.74322E+01
+  0.13827E+02  0.25717E+02  0.48656E+02  0.90368E+02  0.17009E+03  0.31883E+03
+  0.89664E-03  0.11449E-02  0.14670E-02  0.18868E-02  0.24372E-02  0.31625E-02
+  0.41204E-02  0.53830E-02  0.64620E-02  0.67880E-02  0.70109E-02  0.68266E-02
+  0.56349E-02  0.27786E-02  0.28179E-02  0.12031E-01  0.27406E-01  0.49536E-01
+  0.84378E-01  0.14265E+00  0.25485E+00  0.54398E+00  0.74588E+00  0.13342E+01
+  0.23271E+01  0.41988E+01  0.77061E+01  0.14238E+02  0.26329E+02  0.49581E+02
+  0.92339E+02  0.17415E+03  0.32486E+03  0.14163E-02  0.18032E-02  0.23029E-02
+  0.29504E-02  0.37944E-02  0.48989E-02  0.63487E-02  0.82503E-02  0.10713E-01
+  0.12887E-01  0.13174E-01  0.13017E-01  0.11679E-01  0.82067E-02  0.26311E-02
+  0.75911E-02  0.26483E-01  0.52594E-01  0.92590E-01  0.15820E+00  0.27472E+00
+  0.49016E+00  0.81420E+00  0.14410E+01  0.24829E+01  0.44331E+01  0.80611E+01
+  0.14773E+02  0.27126E+02  0.50789E+02  0.94123E+02  0.17789E+03  0.33275E+03
+  0.20797E-02  0.26404E-02  0.33612E-02  0.42905E-02  0.54937E-02  0.70576E-02
+  0.90952E-02  0.11749E-01  0.15171E-01  0.19557E-01  0.23461E-01  0.23328E-01
+  0.21742E-01  0.17522E-01  0.10671E-01  0.13944E-02  0.22086E-01  0.54152E-01
+  0.10174E+00  0.17800E+00  0.31135E+00  0.55444E+00  0.90908E+00  0.15900E+01
+  0.27011E+01  0.47619E+01  0.85600E+01  0.15526E+02  0.28250E+02  0.52496E+02
+  0.96654E+02  0.18172E+03  0.34023E+03  0.28398E-02  0.35965E-02  0.45652E-02
+  0.58079E-02  0.74085E-02  0.94746E-02  0.12147E-01  0.15599E-01  0.20015E-01
+  0.25631E-01  0.32504E-01  0.38353E-01  0.35959E-01  0.30174E-01  0.21276E-01
+  0.94183E-02  0.17486E-01  0.59507E-01  0.11963E+00  0.21321E+00  0.37320E+00
+  0.65895E+00  0.10615E+01  0.18248E+01  0.30424E+01  0.52716E+01  0.93268E+01
+  0.16678E+02  0.29966E+02  0.55095E+02  0.10052E+03  0.18757E+03  0.34901E+03
+  0.39316E-02  0.49680E-02  0.62905E-02  0.79805E-02  0.10147E-01  0.12930E-01
+  0.16507E-01  0.21099E-01  0.26938E-01  0.34323E-01  0.43350E-01  0.53659E-01
+  0.61119E-01  0.52910E-01  0.41000E-01  0.25976E-01  0.00000E+00  0.56604E-01
+  0.13468E+00  0.25257E+00  0.44954E+00  0.79394E+00  0.12604E+01  0.21340E+01
+  0.34917E+01  0.59418E+01  0.10333E+02  0.18184E+02  0.32203E+02  0.58474E+02
+  0.10553E+03  0.19514E+03  0.36034E+03  0.53855E-02  0.67905E-02  0.85789E-02
+  0.10857E-01  0.13767E-01  0.17486E-01  0.22246E-01  0.28321E-01  0.36005E-01
+  0.45674E-01  0.57466E-01  0.71015E-01  0.84280E-01  0.90881E-01  0.74122E-01
+  0.54133E-01  0.20604E-01  0.41288E-01  0.14659E+00  0.30068E+00  0.55176E+00
+  0.98066E+00  0.15374E+01  0.25653E+01  0.41164E+01  0.68692E+01  0.11718E+02
+  0.20244E+02  0.35249E+02  0.63051E+02  0.11229E+03  0.20533E+03  0.37555E+03
+  0.74199E-02  0.93348E-02  0.11766E-01  0.14855E-01  0.18785E-01  0.23789E-01
+  0.30158E-01  0.38246E-01  0.48412E-01  0.61119E-01  0.76529E-01  0.94201E-01
+  0.11173E+00  0.12438E+00  0.12833E+00  0.99173E-01  0.52548E-01  0.12283E-01
+  0.16057E+00  0.37077E+00  0.70411E+00  0.12590E+01  0.19481E+01  0.31988E+01
+  0.50256E+01  0.82053E+01  0.13692E+02  0.23155E+02  0.39515E+02  0.69414E+02
+  0.12164E+03  0.21934E+03  0.39639E+03  0.98682E-02  0.12387E-01  0.15581E-01
+  0.19629E-01  0.24767E-01  0.31291E-01  0.39565E-01  0.50025E-01  0.63126E-01
+  0.79425E-01  0.99124E-01  0.12171E+00  0.14441E+00  0.16189E+00  0.17198E+00
+  0.17269E+00  0.10739E+00  0.27736E-01  0.15936E+00  0.45535E+00  0.91234E+00
+  0.16536E+01  0.25336E+01  0.41025E+01  0.63156E+01  0.10087E+02  0.16449E+02
+  0.27183E+02  0.45367E+02  0.78070E+02  0.13426E+03  0.23813E+03  0.42420E+03
+  0.13314E-01  0.16672E-01  0.20921E-01  0.26297E-01  0.33106E-01  0.41724E-01
+  0.52618E-01  0.66343E-01  0.83446E-01  0.10462E+00  0.13008E+00  0.15915E+00
+  0.18841E+00  0.21151E+00  0.22628E+00  0.23111E+00  0.19233E+00  0.80276E-01
+  0.14881E+00  0.58114E+00  0.12299E+01  0.22544E+01  0.34191E+01  0.54556E+01
+  0.82258E+01  0.12840E+02  0.20432E+02  0.32930E+02  0.53619E+02  0.90142E+02
+  0.15169E+03  0.26386E+03  0.46200E+03  0.17111E-01  0.21369E-01  0.26749E-01
+  0.33549E-01  0.42145E-01  0.53004E-01  0.66694E-01  0.83886E-01  0.10525E+00
+  0.13157E+00  0.16308E+00  0.19891E+00  0.23490E+00  0.26353E+00  0.28250E+00
+  0.29051E+00  0.24958E+00  0.15011E+00  0.13564E+00  0.77254E+00  0.17270E+01
+  0.31892E+01  0.47827E+01  0.75142E+01  0.11096E+02  0.16921E+02  0.26257E+02
+  0.41219E+02  0.65366E+02  0.10711E+03  0.17592E+03  0.29925E+03  0.51351E+03
+  0.23145E-01  0.28810E-01  0.35965E-01  0.44994E-01  0.56393E-01  0.70764E-01
+  0.88848E-01  0.11150E+00  0.13957E+00  0.17407E+00  0.21524E+00  0.26200E+00
+  0.30917E+00  0.34758E+00  0.37488E+00  0.39025E+00  0.34933E+00  0.24439E+00
+  0.00000E+00  0.95435E+00  0.23502E+01  0.44961E+01  0.67384E+01  0.10495E+02
+  0.15249E+02  0.22800E+02  0.34585E+02  0.52960E+02  0.81827E+02  0.13063E+03
+  0.20912E+03  0.34723E+03  0.58269E+03  0.29425E-01  0.36490E-01  0.45406E-01
+  0.56648E-01  0.70824E-01  0.88673E-01  0.11109E+00  0.13912E+00  0.17375E+00
+  0.21619E+00  0.26666E+00  0.32371E+00  0.38098E+00  0.42732E+00  0.46010E+00
+  0.47861E+00  0.43112E+00  0.31093E+00  0.34625E-01  0.12896E+01  0.34568E+01
+  0.66096E+01  0.99014E+01  0.15261E+02  0.21779E+02  0.31895E+02  0.47263E+02
+  0.70553E+02  0.10611E+03  0.16480E+03  0.25668E+03  0.41504E+03  0.67923E+03
+  0.38912E-01  0.48036E-01  0.59549E-01  0.74049E-01  0.92312E-01  0.11528E+00
+  0.14409E+00  0.18003E+00  0.22434E+00  0.27849E+00  0.34267E+00  0.41493E+00
+  0.48710E+00  0.54524E+00  0.58622E+00  0.60943E+00  0.55209E+00  0.40869E+00
+  0.83084E-01  0.14532E+01  0.48284E+01  0.98711E+01  0.14643E+02  0.22517E+02
+  0.31770E+02  0.45687E+02  0.66287E+02  0.96643E+02  0.14167E+03  0.21417E+03
+  0.32447E+03  0.51040E+03  0.81328E+03  0.49898E-01  0.61272E-01  0.75611E-01
+  0.93661E-01  0.11639E+00  0.14494E+00  0.18071E+00  0.22528E+00  0.28015E+00
+  0.34707E+00  0.42622E+00  0.51511E+00  0.60375E+00  0.67513E+00  0.72568E+00
+  0.75502E+00  0.68861E+00  0.52237E+00  0.14666E+00  0.16367E+01  0.57261E+01
+  0.13835E+02  0.22001E+02  0.33466E+02  0.46987E+02  0.66833E+02  0.95190E+02
+  0.13586E+03  0.19448E+03  0.28654E+03  0.42251E+03  0.64645E+03  0.10020E+04
+  0.66780E-01  0.81479E-01  0.10000E+00  0.12331E+00  0.15263E+00  0.18944E+00
+  0.23551E+00  0.29287E+00  0.36335E+00  0.44919E+00  0.55051E+00  0.66406E+00
+  0.77710E+00  0.86817E+00  0.93296E+00  0.97145E+00  0.89160E+00  0.69103E+00
+  0.23953E+00  0.18364E+01  0.68336E+01  0.16681E+02  0.30635E+02  0.50529E+02
+  0.70054E+02  0.99034E+02  0.13957E+03  0.19550E+03  0.27394E+03  0.39413E+03
+  0.56638E+03  0.84339E+03  0.12714E+04  0.86135E-01  0.10431E+00  0.12720E+00
+  0.15599E+00  0.19220E+00  0.23763E+00  0.29445E+00  0.36509E+00  0.45184E+00
+  0.55732E+00  0.68162E+00  0.82063E+00  0.95863E+00  0.10694E+01  0.11478E+01
+  0.11941E+01  0.10976E+01  0.85754E+00  0.32170E+00  0.21734E+01  0.83583E+01
+  0.20471E+02  0.37436E+02  0.70175E+02  0.10651E+03  0.14850E+03  0.20761E+03
+  0.28775E+03  0.39552E+03  0.55684E+03  0.78121E+03  0.11335E+04  0.16628E+04
+  0.11603E+00  0.13928E+00  0.16856E+00  0.20537E+00  0.25164E+00  0.30967E+00
+  0.38217E+00  0.47227E+00  0.58274E+00  0.71688E+00  0.87467E+00  0.10507E+01
+  0.12247E+01  0.13634E+01  0.14604E+01  0.15162E+01  0.13919E+01  0.10891E+01
+  0.42208E+00  0.26545E+01  0.10374E+02  0.25405E+02  0.46262E+02  0.86202E+02
+  0.14662E+03  0.22649E+03  0.31216E+03  0.42872E+03  0.58339E+03  0.80566E+03
+  0.11059E+04  0.15666E+04  0.22392E+04  0.15189E+00  0.18050E+00  0.21651E+00
+  0.26179E+00  0.31868E+00  0.38998E+00  0.47906E+00  0.58963E+00  0.72511E+00
+  0.88946E+00  0.10825E+01  0.12974E+01  0.15093E+01  0.16773E+01  0.17938E+01
+  0.18597E+01  0.17067E+01  0.13390E+01  0.53545E+00  0.32500E+01  0.12927E+02
+  0.31686E+02  0.57515E+02  0.10668E+03  0.18029E+03  0.30822E+03  0.47660E+03
+  0.64530E+03  0.86946E+03  0.11896E+04  0.16020E+04  0.22208E+04  0.30991E+04
+  0.33487E-09  0.13756E-08  0.33392E-08  0.87356E-08  0.13465E-07  0.32814E-07
+  0.45262E-07  0.87038E-07  0.17262E-06  0.37953E-06  0.77939E-06  0.16276E-05
+  0.61370E-05  0.30897E-04  0.18044E-03  0.47830E-03  0.17643E-02  0.42227E-02
+  0.80836E-02  0.14382E-01  0.23959E-01  0.39552E-01  0.60204E-01  0.92074E-01
+  0.13657E+00  0.20686E+00  0.31586E+00  0.48238E+00  0.73362E+00  0.11310E+01
+  0.17214E+01  0.26643E+01  0.41017E+01  0.33117E-09  0.10169E-08  0.36394E-08
+  0.90112E-08  0.22341E-07  0.34200E-07  0.81169E-07  0.11637E-06  0.23337E-06
+  0.50111E-06  0.10419E-05  0.21266E-05  0.10090E-04  0.63429E-04  0.23106E-03
+  0.61059E-03  0.22477E-02  0.53674E-02  0.10255E-01  0.18214E-01  0.30300E-01
+  0.49959E-01  0.75958E-01  0.11604E+00  0.17194E+00  0.26015E+00  0.39676E+00
+  0.60513E+00  0.91889E+00  0.14141E+01  0.21474E+01  0.33148E+01  0.50865E+01
+  0.10029E-09  0.13762E-08  0.29491E-08  0.10279E-07  0.23576E-07  0.57447E-07
+  0.87178E-07  0.18124E-06  0.32930E-06  0.61425E-06  0.13973E-05  0.25372E-05
+  0.15421E-04  0.10778E-03  0.45969E-03  0.78364E-03  0.28760E-02  0.68477E-02
+  0.13050E-01  0.23132E-01  0.38414E-01  0.63244E-01  0.96041E-01  0.14655E+00
+  0.21691E+00  0.32782E+00  0.49943E+00  0.76080E+00  0.11537E+01  0.17727E+01
+  0.26872E+01  0.41389E+01  0.63342E+01  0.77479E-09  0.78887E-09  0.40749E-08
+  0.10437E-07  0.27194E-07  0.62513E-07  0.13912E-06  0.24782E-06  0.55653E-06
+  0.96824E-06  0.20751E-05  0.49145E-05  0.42641E-04  0.19434E-03  0.84673E-03
+  0.14853E-02  0.38970E-02  0.92306E-02  0.17524E-01  0.30964E-01  0.51288E-01
+  0.84260E-01  0.12772E+00  0.19458E+00  0.28758E+00  0.43409E+00  0.66043E+00
+  0.10048E+01  0.15215E+01  0.23340E+01  0.35315E+01  0.54276E+01  0.82846E+01
+  0.18109E-08  0.40394E-09  0.36884E-08  0.13690E-07  0.35668E-07  0.78406E-07
+  0.16750E-06  0.36792E-06  0.89071E-06  0.18930E-05  0.37786E-05  0.13180E-04
+  0.90819E-04  0.40460E-03  0.13343E-02  0.24900E-02  0.53373E-02  0.12002E-01
+  0.23649E-01  0.41618E-01  0.68705E-01  0.11256E+00  0.17024E+00  0.25886E+00
+  0.38196E+00  0.57566E+00  0.87470E+00  0.13290E+01  0.20099E+01  0.30790E+01
+  0.46514E+01  0.71359E+01  0.10870E+02  0.44772E-08  0.30561E-08  0.10806E-08
+  0.13979E-07  0.40290E-07  0.93751E-07  0.20440E-06  0.45918E-06  0.13617E-05
+  0.29952E-05  0.83442E-05  0.27038E-04  0.15982E-03  0.71015E-03  0.18756E-02
+  0.35721E-02  0.73730E-02  0.14591E-01  0.29196E-01  0.56224E-01  0.92420E-01
+  0.15089E+00  0.22755E+00  0.34518E+00  0.50832E+00  0.76486E+00  0.11604E+01
+  0.17608E+01  0.26593E+01  0.40686E+01  0.61379E+01  0.94022E+01  0.14297E+02
+  0.29795E-07  0.38470E-07  0.51218E-07  0.51498E-07  0.42412E-07  0.65343E-08
+  0.12477E-06  0.32827E-06  0.12322E-05  0.42486E-05  0.13843E-04  0.71904E-04
+  0.26210E-03  0.10368E-02  0.23805E-02  0.46454E-02  0.92211E-02  0.18136E-01
+  0.33309E-01  0.65229E-01  0.12455E+00  0.20257E+00  0.30449E+00  0.46072E+00
+  0.67700E+00  0.10168E+01  0.15405E+01  0.23342E+01  0.35212E+01  0.53809E+01
+  0.81083E+01  0.12405E+02  0.18836E+02  0.63613E-07  0.82210E-07  0.10896E-06
+  0.13984E-06  0.17894E-06  0.12782E-06  0.15672E-07  0.39993E-06  0.82789E-06
+  0.34746E-05  0.18998E-04  0.11995E-03  0.43430E-03  0.13343E-02  0.29721E-02
+  0.57211E-02  0.11134E-01  0.21090E-01  0.39078E-01  0.71708E-01  0.13670E+00
+  0.27175E+00  0.40958E+00  0.61755E+00  0.90480E+00  0.13558E+01  0.20499E+01
+  0.31012E+01  0.46714E+01  0.71292E+01  0.10729E+02  0.16395E+02  0.24864E+02
+  0.19481E-06  0.26201E-06  0.30440E-06  0.40212E-06  0.55979E-06  0.85204E-06
+  0.91118E-06  0.53493E-06  0.89481E-06  0.21261E-05  0.13573E-04  0.13965E-03
+  0.59414E-03  0.16478E-02  0.35247E-02  0.66520E-02  0.12780E-01  0.23988E-01
+  0.42976E-01  0.79332E-01  0.14621E+00  0.28329E+00  0.52276E+00  0.82928E+00
+  0.12110E+01  0.18097E+01  0.27304E+01  0.41233E+01  0.62016E+01  0.94527E+01
+  0.14209E+02  0.21689E+02  0.32854E+02  0.30634E-06  0.36906E-06  0.41991E-06
+  0.72486E-06  0.13541E-05  0.18291E-05  0.32840E-05  0.33705E-05  0.28004E-05
+  0.14554E-04  0.21205E-04  0.10929E-03  0.68287E-03  0.19762E-02  0.42831E-02
+  0.78621E-02  0.14573E-01  0.26860E-01  0.47662E-01  0.86127E-01  0.15834E+00
+  0.30115E+00  0.54481E+00  0.10153E+01  0.16339E+01  0.24319E+01  0.36570E+01
+  0.55075E+01  0.82652E+01  0.12574E+02  0.18871E+02  0.28761E+02  0.43511E+02
+  0.59741E-06  0.84945E-06  0.13349E-05  0.24580E-05  0.45467E-05  0.74682E-05
+  0.10492E-04  0.11208E-04  0.29483E-05  0.54721E-04  0.15669E-03  0.31922E-03
+  0.85268E-03  0.23560E-02  0.51491E-02  0.94461E-02  0.17401E-01  0.30056E-01
+  0.53310E-01  0.93963E-01  0.17063E+00  0.32127E+00  0.57513E+00  0.10605E+01
+  0.19105E+01  0.32851E+01  0.49188E+01  0.73819E+01  0.11046E+02  0.16766E+02
+  0.25112E+02  0.38211E+02  0.57722E+02  0.33715E-05  0.72270E-05  0.12206E-04
+  0.19029E-04  0.38754E-04  0.62503E-04  0.87165E-04  0.90505E-04  0.59513E-04
+  0.24699E-04  0.21406E-03  0.57908E-03  0.13525E-02  0.49396E-02  0.61924E-02
+  0.11153E-01  0.20359E-01  0.35589E-01  0.59694E-01  0.10446E+00  0.18631E+00
+  0.34226E+00  0.60537E+00  0.11174E+01  0.19922E+01  0.36570E+01  0.66342E+01
+  0.99160E+01  0.14790E+02  0.22388E+02  0.33459E+02  0.50818E+02  0.76647E+02
+  0.23785E-04  0.30200E-04  0.60313E-04  0.10350E-03  0.15795E-03  0.20189E-03
+  0.24324E-03  0.25274E-03  0.21513E-03  0.93644E-04  0.18788E-03  0.77357E-03
+  0.19483E-02  0.41987E-02  0.16599E-01  0.14490E-01  0.24343E-01  0.41532E-01
+  0.69060E-01  0.11687E+00  0.20466E+00  0.37169E+00  0.64416E+00  0.11772E+01
+  0.21038E+01  0.38249E+01  0.70594E+01  0.13113E+02  0.19894E+02  0.30008E+02
+  0.44718E+02  0.67759E+02  0.10200E+03  0.10671E-03  0.13534E-03  0.17180E-03
+  0.23879E-03  0.33723E-03  0.45740E-03  0.54169E-03  0.58442E-03  0.53677E-03
+  0.36234E-03  0.48491E-04  0.89980E-03  0.26350E-02  0.57855E-02  0.10789E-01
+  0.30475E-01  0.31784E-01  0.50183E-01  0.81320E-01  0.13434E+00  0.23017E+00
+  0.41006E+00  0.69847E+00  0.12581E+01  0.22205E+01  0.40416E+01  0.74061E+01
+  0.13628E+02  0.25130E+02  0.40422E+02  0.60007E+02  0.90649E+02  0.13611E+03
+  0.46223E-03  0.58593E-03  0.74357E-03  0.94289E-03  0.11601E-02  0.13735E-02
+  0.16273E-02  0.18239E-02  0.18489E-02  0.16652E-02  0.11024E-02  0.86839E-04
+  0.25404E-02  0.69838E-02  0.13566E-01  0.22676E-01  0.39232E-01  0.66330E-01
+  0.95956E-01  0.15524E+00  0.26078E+00  0.45626E+00  0.76326E+00  0.13543E+01
+  0.23581E+01  0.42441E+01  0.77740E+01  0.14256E+02  0.26054E+02  0.48582E+02
+  0.80668E+02  0.12144E+03  0.18184E+03  0.14013E-02  0.17745E-02  0.22497E-02
+  0.28525E-02  0.36177E-02  0.44486E-02  0.48717E-02  0.53527E-02  0.57345E-02
+  0.56226E-02  0.49829E-02  0.33536E-02  0.00000E+00  0.61102E-02  0.14975E-01
+  0.26619E-01  0.45358E-01  0.73090E-01  0.25372E+00  0.18031E+00  0.29810E+00
+  0.51338E+00  0.84322E+00  0.14734E+01  0.25277E+01  0.44935E+01  0.81449E+01
+  0.14898E+02  0.27230E+02  0.50332E+02  0.92367E+02  0.16312E+03  0.24342E+03
+  0.33862E-02  0.42821E-02  0.54210E-02  0.68653E-02  0.86990E-02  0.11016E-01
+  0.13921E-01  0.14546E-01  0.15084E-01  0.15482E-01  0.14532E-01  0.12261E-01
+  0.73441E-02  0.13597E-02  0.13547E-01  0.28887E-01  0.52928E-01  0.85689E-01
+  0.13469E+00  0.81909E+00  0.34778E+00  0.59060E+00  0.95166E+00  0.16356E+01
+  0.27591E+01  0.48341E+01  0.86519E+01  0.15652E+02  0.28443E+02  0.52747E+02
+  0.95892E+02  0.17840E+03  0.32730E+03  0.67723E-02  0.85529E-02  0.10812E-01
+  0.13674E-01  0.17302E-01  0.21889E-01  0.27655E-01  0.34818E-01  0.36966E-01
+  0.37115E-01  0.36415E-01  0.33066E-01  0.25768E-01  0.12878E-01  0.46712E-02
+  0.25758E-01  0.57901E-01  0.99721E-01  0.16017E+00  0.25418E+00  0.10404E+01
+  0.70356E+00  0.10997E+01  0.18585E+01  0.30777E+01  0.53037E+01  0.93515E+01
+  0.16694E+02  0.29982E+02  0.55102E+02  0.10057E+03  0.18569E+03  0.34203E+03
+  0.11879E-01  0.14984E-01  0.18917E-01  0.23889E-01  0.30180E-01  0.38121E-01
+  0.48097E-01  0.60506E-01  0.75562E-01  0.82509E-01  0.80074E-01  0.74596E-01
+  0.62603E-01  0.41711E-01  0.14844E-01  0.16060E-01  0.61757E-01  0.11849E+00
+  0.19747E+00  0.31663E+00  0.51388E+00  0.11173E+01  0.13265E+01  0.21984E+01
+  0.35618E+01  0.60139E+01  0.10405E+02  0.18256E+02  0.32287E+02  0.58563E+02
+  0.10568E+03  0.19537E+03  0.35784E+03  0.18821E-01  0.23713E-01  0.29899E-01
+  0.37709E-01  0.47574E-01  0.60005E-01  0.75606E-01  0.95015E-01  0.11866E+00
+  0.14695E+00  0.16539E+00  0.15564E+00  0.13641E+00  0.10317E+00  0.60265E-01
+  0.12817E-01  0.55256E-01  0.13611E+00  0.24441E+00  0.40263E+00  0.65801E+00
+  0.10901E+01  0.16586E+01  0.26958E+01  0.42672E+01  0.70433E+01  0.11922E+02
+  0.20494E+02  0.35572E+02  0.63475E+02  0.11290E+03  0.20622E+03  0.37692E+03
+  0.30828E-01  0.38796E-01  0.48861E-01  0.61560E-01  0.77585E-01  0.97766E-01
+  0.12309E+00  0.15466E+00  0.19334E+00  0.24009E+00  0.29400E+00  0.34039E+00
+  0.30846E+00  0.25541E+00  0.18893E+00  0.11476E+00  0.11066E-01  0.10701E+00
+  0.25942E+00  0.47518E+00  0.81527E+00  0.13779E+01  0.20815E+01  0.33484E+01
+  0.52017E+01  0.84156E+01  0.13950E+02  0.23481E+02  0.39944E+02  0.69990E+02
+  0.12245E+03  0.22050E+03  0.39812E+03  0.47848E-01  0.60139E-01  0.75655E-01
+  0.95212E-01  0.11987E+00  0.15090E+00  0.18981E+00  0.23834E+00  0.29793E+00
+  0.37032E+00  0.45484E+00  0.54679E+00  0.63021E+00  0.55179E+00  0.44299E+00
+  0.32755E+00  0.16262E+00  0.19119E-01  0.24580E+00  0.55670E+00  0.10342E+01
+  0.18045E+01  0.27184E+01  0.43380E+01  0.66164E+01  0.10483E+02  0.16983E+02
+  0.27913E+02  0.46381E+02  0.79511E+02  0.13631E+03  0.24113E+03  0.42859E+03
+  0.75131E-01  0.94301E-01  0.11848E+00  0.14896E+00  0.18735E+00  0.23564E+00
+  0.29620E+00  0.37175E+00  0.46483E+00  0.57842E+00  0.71260E+00  0.86256E+00
+  0.10094E+01  0.11208E+01  0.10140E+01  0.82561E+00  0.56711E+00  0.28181E+00
+  0.66102E-01  0.52962E+00  0.12243E+01  0.23181E+01  0.35484E+01  0.56956E+01
+  0.85930E+01  0.13401E+02  0.21276E+02  0.34176E+02  0.55432E+02  0.92820E+02
+  0.15557E+03  0.26960E+03  0.47042E+03  0.11233E+00  0.14076E+00  0.17660E+00
+  0.22175E+00  0.27859E+00  0.35006E+00  0.43965E+00  0.55141E+00  0.68924E+00
+  0.85780E+00  0.10580E+01  0.12848E+01  0.15152E+01  0.17096E+01  0.18609E+01
+  0.17633E+01  0.13343E+01  0.87898E+00  0.32569E+00  0.40015E+00  0.14617E+01
+  0.30918E+01  0.48373E+01  0.78285E+01  0.11697E+02  0.17957E+02  0.27919E+02
+  0.43762E+02  0.69129E+02  0.11273E+03  0.18406E+03  0.31131E+03  0.53116E+03
+  0.15812E+00  0.19773E+00  0.24766E+00  0.31050E+00  0.38959E+00  0.48894E+00
+  0.61343E+00  0.76859E+00  0.95984E+00  0.11937E+01  0.14716E+01  0.17874E+01
+  0.21116E+01  0.23940E+01  0.26270E+01  0.28156E+01  0.25699E+01  0.18024E+01
+  0.89611E+00  0.28244E+00  0.19786E+01  0.45203E+01  0.71312E+01  0.11512E+02
+  0.16950E+02  0.25516E+02  0.38733E+02  0.59084E+02  0.90648E+02  0.14348E+03
+  0.22742E+03  0.37385E+03  0.62110E+03  0.21715E+00  0.27085E+00  0.33851E+00
+  0.42365E+00  0.53074E+00  0.66519E+00  0.83350E+00  0.10431E+01  0.13013E+01
+  0.16167E+01  0.19912E+01  0.24169E+01  0.28548E+01  0.32396E+01  0.35627E+01
+  0.38319E+01  0.37639E+01  0.33174E+01  0.17891E+01  0.15537E+00  0.29403E+01
+  0.70225E+01  0.11074E+02  0.17735E+02  0.25699E+02  0.37916E+02  0.56195E+02
+  0.83429E+02  0.12429E+03  0.19076E+03  0.29301E+03  0.46701E+03  0.75316E+03
+  0.29548E+00  0.36737E+00  0.45792E+00  0.57182E+00  0.71502E+00  0.89473E+00
+  0.11195E+01  0.13994E+01  0.17437E+01  0.21637E+01  0.26623E+01  0.32278E+01
+  0.38096E+01  0.43214E+01  0.47522E+01  0.51132E+01  0.50372E+01  0.45477E+01
+  0.31627E+01  0.00000E+00  0.45817E+01  0.11320E+02  0.17802E+02  0.28234E+02
+  0.40296E+02  0.58355E+02  0.84597E+02  0.12247E+03  0.17741E+03  0.26424E+03
+  0.39333E+03  0.60722E+03  0.94884E+03  0.40395E+00  0.50018E+00  0.62139E+00
+  0.77383E+00  0.96540E+00  0.12057E+01  0.15062E+01  0.18800E+01  0.23398E+01
+  0.29002E+01  0.35650E+01  0.43186E+01  0.50941E+01  0.57779E+01  0.63567E+01
+  0.68456E+01  0.67670E+01  0.61590E+01  0.44078E+01  0.40384E+00  0.72079E+01
+  0.18242E+02  0.28915E+02  0.45767E+02  0.64548E+02  0.92061E+02  0.13100E+03
+  0.18553E+03  0.26213E+03  0.37980E+03  0.54872E+03  0.82103E+03  0.12425E+04
+  0.54872E+00  0.67601E+00  0.83628E+00  0.10378E+01  0.12909E+01  0.16084E+01
+  0.20053E+01  0.24986E+01  0.31049E+01  0.38433E+01  0.47179E+01  0.57081E+01
+  0.67234E+01  0.76147E+01  0.83630E+01  0.89881E+01  0.88632E+01  0.80430E+01
+  0.57355E+01  0.52317E+00  0.10729E+02  0.30554E+02  0.47911E+02  0.75566E+02
+  0.10610E+03  0.14919E+03  0.20877E+03  0.28996E+03  0.40063E+03  0.56603E+03
+  0.79541E+03  0.11551E+04  0.16940E+04  0.76033E+00  0.93077E+00  0.11454E+01
+  0.14151E+01  0.17539E+01  0.21788E+01  0.27096E+01  0.33695E+01  0.41803E+01
+  0.51672E+01  0.63362E+01  0.76599E+01  0.90194E+01  0.10219E+02  0.11233E+02
+  0.12092E+02  0.11975E+02  0.10962E+02  0.80305E+01  0.13626E+01  0.13043E+02
+  0.42316E+02  0.79048E+02  0.12411E+03  0.17366E+03  0.24435E+03  0.33780E+03
+  0.46213E+03  0.62703E+03  0.86738E+03  0.11898E+04  0.16821E+04  0.23959E+04
+  0.10505E+01  0.12759E+01  0.15597E+01  0.19163E+01  0.23645E+01  0.29261E+01
+  0.36277E+01  0.44994E+01  0.55699E+01  0.68724E+01  0.84136E+01  0.10157E+02
+  0.11944E+02  0.13513E+02  0.14835E+02  0.15947E+02  0.15767E+02  0.14406E+02
+  0.10530E+02  0.17819E+01  0.17000E+02  0.54929E+02  0.10728E+03  0.20871E+03
+  0.28916E+03  0.40324E+03  0.55823E+03  0.75371E+03  0.10068E+04  0.13674E+04
+  0.18365E+04  0.25348E+04  0.35154E+04  0.14677E+01  0.17659E+01  0.21413E+01
+  0.26130E+01  0.32057E+01  0.39480E+01  0.48754E+01  0.60272E+01  0.74409E+01
+  0.91605E+01  0.11193E+02  0.13490E+02  0.15841E+02  0.17898E+02  0.19624E+02
+  0.21067E+02  0.20799E+02  0.18973E+02  0.13843E+02  0.23375E+01  0.22243E+02
+  0.71644E+02  0.13939E+03  0.27041E+03  0.46541E+03  0.67290E+03  0.92090E+03
+  0.12451E+04  0.16468E+04  0.22032E+04  0.29070E+04  0.39307E+04  0.53254E+04
+  0.20783E+01  0.24729E+01  0.29695E+01  0.35934E+01  0.43769E+01  0.53587E+01
+  0.65845E+01  0.81071E+01  0.99743E+01  0.12245E+02  0.14928E+02  0.17955E+02
+  0.21048E+02  0.23747E+02  0.26001E+02  0.27875E+02  0.27486E+02  0.25038E+02
+  0.18240E+02  0.30745E+01  0.29195E+02  0.93801E+02  0.18194E+03  0.35166E+03
+  0.60250E+03  0.10346E+04  0.15403E+04  0.20595E+04  0.27198E+04  0.36145E+04
+  0.47002E+04  0.62474E+04  0.82970E+04  0.42502E-09  0.15042E-08  0.35179E-08
+  0.83003E-08  0.16099E-07  0.30793E-07  0.70759E-07  0.10228E-06  0.20393E-06
+  0.44899E-06  0.91498E-06  0.18872E-05  0.81980E-05  0.47543E-04  0.20695E-03
+  0.54767E-03  0.20182E-02  0.48247E-02  0.92265E-02  0.16401E-01  0.27301E-01
+  0.45039E-01  0.68515E-01  0.10472E+00  0.15524E+00  0.23499E+00  0.35857E+00
+  0.54719E+00  0.83145E+00  0.12805E+01  0.19464E+01  0.30079E+01  0.46217E+01
+  0.23618E-09  0.14618E-08  0.41422E-08  0.96989E-08  0.21457E-07  0.41145E-07
+  0.78109E-07  0.15428E-06  0.28218E-06  0.55927E-06  0.12291E-05  0.23427E-05
+  0.12848E-04  0.86440E-04  0.34757E-03  0.70080E-03  0.25758E-02  0.61417E-02
+  0.11718E-01  0.20791E-01  0.34556E-01  0.56931E-01  0.86501E-01  0.13206E+00
+  0.19555E+00  0.29570E+00  0.45071E+00  0.68695E+00  0.10423E+01  0.16026E+01
+  0.24311E+01  0.37480E+01  0.57427E+01  0.74597E-10  0.13591E-08  0.44624E-08
+  0.11990E-07  0.25660E-07  0.55573E-07  0.10510E-06  0.20702E-06  0.39477E-06
+  0.75883E-06  0.16309E-05  0.28189E-05  0.26317E-04  0.13839E-03  0.61954E-03
+  0.10692E-02  0.32999E-02  0.78419E-02  0.14920E-01  0.26411E-01  0.43812E-01
+  0.72065E-01  0.10935E+00  0.16673E+00  0.24663E+00  0.37251E+00  0.56719E+00
+  0.86349E+00  0.13086E+01  0.20091E+01  0.30428E+01  0.46817E+01  0.71558E+01
+  0.93428E-09  0.53286E-09  0.40917E-08  0.12751E-07  0.31311E-07  0.65914E-07
+  0.14134E-06  0.27871E-06  0.65932E-06  0.10890E-05  0.24998E-05  0.67044E-05
+  0.52556E-04  0.24534E-03  0.98252E-03  0.17326E-02  0.42536E-02  0.10048E-01
+  0.19051E-01  0.33629E-01  0.55654E-01  0.91366E-01  0.13841E+00  0.21076E+00
+  0.31136E+00  0.46979E+00  0.71456E+00  0.10866E+01  0.16449E+01  0.25223E+01
+  0.38146E+01  0.58594E+01  0.89383E+01  0.21243E-08  0.74153E-09  0.32895E-08
+  0.13581E-07  0.35232E-07  0.82842E-07  0.17047E-06  0.38244E-06  0.93149E-06
+  0.19954E-05  0.39880E-05  0.14448E-04  0.97821E-04  0.43194E-03  0.13819E-02
+  0.26181E-02  0.55195E-02  0.12235E-01  0.24416E-01  0.42946E-01  0.70868E-01
+  0.11607E+00  0.17550E+00  0.26679E+00  0.39359E+00  0.59310E+00  0.90109E+00
+  0.13689E+01  0.20699E+01  0.31705E+01  0.47890E+01  0.73456E+01  0.11187E+02
+  0.52980E-08  0.36933E-08  0.00000E+00  0.11936E-07  0.37492E-07  0.92818E-07
+  0.20986E-06  0.44461E-06  0.13050E-05  0.30069E-05  0.78830E-05  0.25870E-04
+  0.15465E-03  0.68420E-03  0.18297E-02  0.35061E-02  0.72038E-02  0.14376E-01
+  0.28941E-01  0.55034E-01  0.90496E-01  0.14779E+00  0.22293E+00  0.33825E+00
+  0.49819E+00  0.74970E+00  0.11376E+01  0.17262E+01  0.26074E+01  0.39897E+01
+  0.60195E+01  0.92218E+01  0.14024E+02  0.34959E-07  0.49816E-07  0.61297E-07
+  0.66825E-07  0.64991E-07  0.24302E-07  0.79519E-07  0.30127E-06  0.10616E-05
+  0.38221E-05  0.13011E-04  0.58904E-04  0.23636E-03  0.96762E-03  0.22649E-02
+  0.44144E-02  0.88816E-02  0.17337E-01  0.32365E-01  0.64136E-01  0.11767E+00
+  0.19160E+00  0.28824E+00  0.43646E+00  0.64172E+00  0.96433E+00  0.14615E+01
+  0.22154E+01  0.33430E+01  0.51101E+01  0.77024E+01  0.11787E+02  0.17903E+02
+  0.68113E-07  0.90470E-07  0.12042E-06  0.16679E-06  0.20364E-06  0.17183E-06
+  0.55536E-07  0.28079E-06  0.77133E-06  0.35042E-05  0.18082E-04  0.11187E-03
+  0.39277E-03  0.12723E-02  0.28562E-02  0.55064E-02  0.10853E-01  0.20549E-01
+  0.38011E-01  0.70396E-01  0.13515E+00  0.26049E+00  0.39020E+00  0.58880E+00
+  0.86325E+00  0.12942E+01  0.19577E+01  0.29627E+01  0.44643E+01  0.68154E+01
+  0.10259E+02  0.15680E+02  0.23785E+02  0.19794E-06  0.26147E-06  0.30742E-06
+  0.42140E-06  0.59073E-06  0.89223E-06  0.89809E-06  0.65947E-06  0.62834E-06
+  0.17131E-05  0.13832E-04  0.14029E-03  0.56668E-03  0.15906E-02  0.34193E-02
+  0.64951E-02  0.12539E-01  0.23577E-01  0.42232E-01  0.78456E-01  0.14442E+00
+  0.28101E+00  0.51982E+00  0.79588E+00  0.11630E+01  0.17391E+01  0.26251E+01
+  0.39657E+01  0.59667E+01  0.90972E+01  0.13678E+02  0.20882E+02  0.31638E+02
+  0.32798E-06  0.39950E-06  0.47697E-06  0.79435E-06  0.14253E-05  0.18695E-05
+  0.36437E-05  0.39371E-05  0.77931E-06  0.10493E-04  0.15049E-04  0.12616E-03
+  0.66639E-03  0.19201E-02  0.41498E-02  0.76587E-02  0.14286E-01  0.26455E-01
+  0.47012E-01  0.85020E-01  0.15686E+00  0.29833E+00  0.54116E+00  0.10098E+01
+  0.15788E+01  0.23515E+01  0.35381E+01  0.53310E+01  0.80031E+01  0.12180E+02
+  0.18284E+02  0.27873E+02  0.42175E+02  0.59580E-06  0.79020E-06  0.11639E-05
+  0.18816E-05  0.39321E-05  0.71351E-05  0.12496E-04  0.17097E-04  0.11295E-04
+  0.32144E-04  0.12235E-03  0.26853E-03  0.75806E-03  0.22365E-02  0.49622E-02
+  0.91678E-02  0.16950E-01  0.29459E-01  0.52313E-01  0.92617E-01  0.16850E+00
+  0.31820E+00  0.57000E+00  0.10528E+01  0.18991E+01  0.31942E+01  0.47864E+01
+  0.71879E+01  0.10762E+02  0.16341E+02  0.24484E+02  0.37268E+02  0.56310E+02
+  0.26500E-06  0.55053E-06  0.81423E-06  0.95996E-06  0.66081E-06  0.33444E-05
+  0.16922E-04  0.47235E-04  0.11038E-03  0.23341E-03  0.45460E-03  0.84149E-03
+  0.16630E-02  0.48519E-02  0.67154E-02  0.11883E-01  0.21360E-01  0.36994E-01
+  0.61528E-01  0.10712E+00  0.19023E+00  0.34821E+00  0.61467E+00  0.11304E+01
+  0.20122E+01  0.36879E+01  0.65711E+01  0.98095E+01  0.14616E+02  0.22105E+02
+  0.33014E+02  0.50112E+02  0.75544E+02  0.30553E-04  0.38868E-04  0.77383E-04
+  0.13117E-03  0.19992E-03  0.25683E-03  0.31471E-03  0.34084E-03  0.32317E-03
+  0.22376E-03  0.30856E-04  0.58100E-03  0.17073E-02  0.38877E-02  0.17314E-01
+  0.13837E-01  0.23574E-01  0.40452E-01  0.67563E-01  0.11476E+00  0.20162E+00
+  0.36722E+00  0.63761E+00  0.11674E+01  0.20891E+01  0.38010E+01  0.70233E+01
+  0.13058E+02  0.19629E+02  0.29627E+02  0.44169E+02  0.66955E+02  0.10082E+03
+  0.14771E-03  0.18769E-03  0.23892E-03  0.33532E-03  0.47834E-03  0.65815E-03
+  0.79572E-03  0.89542E-03  0.90186E-03  0.78421E-03  0.43412E-03  0.33572E-03
+  0.19663E-02  0.49906E-02  0.98191E-02  0.29772E-01  0.30107E-01  0.48083E-01
+  0.78510E-01  0.13049E+00  0.22478E+00  0.40235E+00  0.68730E+00  0.12416E+01
+  0.21959E+01  0.40045E+01  0.73490E+01  0.13541E+02  0.24998E+02  0.40115E+02
+  0.59594E+02  0.90083E+02  0.13532E+03  0.52596E-03  0.66699E-03  0.84694E-03
+  0.10752E-02  0.13257E-02  0.15713E-02  0.18678E-02  0.21127E-02  0.21772E-02
+  0.20335E-02  0.15062E-02  0.34947E-03  0.20424E-02  0.64361E-02  0.12953E-01
+  0.21968E-01  0.38296E-01  0.69852E-01  0.94603E-01  0.15347E+00  0.25841E+00
+  0.45301E+00  0.75865E+00  0.13476E+01  0.23483E+01  0.42295E+01  0.77519E+01
+  0.14226E+02  0.26006E+02  0.48509E+02  0.80838E+02  0.12173E+03  0.18229E+03
+  0.11572E-03  0.14252E-03  0.17311E-03  0.20262E-03  0.22440E-03  0.21229E-03
+  0.11466E-03  0.93378E-04  0.53712E-03  0.12990E-02  0.26676E-02  0.50457E-02
+  0.93609E-02  0.16736E-01  0.27248E-01  0.40941E-01  0.62483E-01  0.94055E-01
+  0.35646E+00  0.21422E+00  0.34297E+00  0.57428E+00  0.92745E+00  0.15926E+01
+  0.26993E+01  0.47446E+01  0.85177E+01  0.15458E+02  0.28093E+02  0.51635E+02
+  0.94353E+02  0.16766E+03  0.24946E+03  0.25531E-02  0.32263E-02  0.40801E-02
+  0.51584E-02  0.65195E-02  0.82231E-02  0.10324E-01  0.10804E-01  0.10963E-01
+  0.10855E-01  0.95515E-02  0.67855E-02  0.12612E-02  0.83758E-02  0.21632E-01
+  0.38314E-01  0.64185E-01  0.99343E-01  0.15160E+00  0.83707E+00  0.37632E+00
+  0.62814E+00  0.10024E+01  0.17063E+01  0.28588E+01  0.49776E+01  0.88619E+01
+  0.15964E+02  0.28908E+02  0.53490E+02  0.97027E+02  0.18012E+03  0.33389E+03
+  0.31455E-04  0.29232E-04  0.17215E-04  0.21835E-04  0.11101E-03  0.30940E-03
+  0.73438E-03  0.16379E-02  0.31324E-02  0.53572E-02  0.91922E-02  0.15584E-01
+  0.26515E-01  0.44266E-01  0.67571E-01  0.95764E-01  0.13739E+00  0.19172E+00
+  0.26904E+00  0.38621E+00  0.10919E+01  0.92398E+00  0.13750E+01  0.22285E+01
+  0.35851E+01  0.60155E+01  0.10370E+02  0.18175E+02  0.32167E+02  0.58369E+02
+  0.10550E+03  0.19335E+03  0.35365E+03  0.81043E-02  0.10216E-01  0.12885E-01
+  0.16247E-01  0.20480E-01  0.25779E-01  0.32345E-01  0.40326E-01  0.49581E-01
+  0.54339E-01  0.50273E-01  0.42581E-01  0.27947E-01  0.36762E-02  0.27393E-01
+  0.63335E-01  0.11571E+00  0.18085E+00  0.27082E+00  0.40484E+00  0.62289E+00
+  0.99450E+00  0.15046E+01  0.24348E+01  0.38798E+01  0.64529E+01  0.11024E+02
+  0.19143E+02  0.33575E+02  0.60465E+02  0.10850E+03  0.19963E+03  0.36483E+03
+  0.12848E-01  0.16178E-01  0.20381E-01  0.25671E-01  0.32325E-01  0.40652E-01
+  0.50984E-01  0.63595E-01  0.78411E-01  0.95141E-01  0.10711E+00  0.94021E-01
+  0.70054E-01  0.30678E-01  0.19322E-01  0.75191E-01  0.15435E+00  0.24876E+00
+  0.37450E+00  0.55589E+00  0.84338E+00  0.13211E+01  0.19477E+01  0.30710E+01
+  0.47598E+01  0.77087E+01  0.12842E+02  0.21787E+02  0.37418E+02  0.66159E+02
+  0.11684E+03  0.21207E+03  0.38569E+03  0.28874E-01  0.36270E-01  0.45592E-01
+  0.57308E-01  0.72020E-01  0.90419E-01  0.11325E+00  0.14123E+00  0.17449E+00
+  0.21293E+00  0.25342E+00  0.28773E+00  0.29480E+00  0.20250E+00  0.70153E-01
+  0.73590E-01  0.27014E+00  0.48911E+00  0.76255E+00  0.11341E+01  0.16934E+01
+  0.25763E+01  0.36294E+01  0.54489E+01  0.79913E+01  0.12235E+02  0.19272E+02
+  0.30974E+02  0.50553E+02  0.85332E+02  0.14455E+03  0.25301E+03  0.44593E+03
+  0.48443E-01  0.60750E-01  0.76251E-01  0.95732E-01  0.12019E+00  0.15079E+00
+  0.18881E+00  0.23554E+00  0.29158E+00  0.35725E+00  0.42885E+00  0.49597E+00
+  0.53115E+00  0.48987E+00  0.32806E+00  0.67933E-01  0.28373E+00  0.67071E+00
+  0.11355E+01  0.17476E+01  0.26438E+01  0.40187E+01  0.55657E+01  0.81831E+01
+  0.11668E+02  0.17319E+02  0.26386E+02  0.40969E+02  0.64601E+02  0.10551E+03
+  0.17325E+03  0.29484E+03  0.50673E+03  0.79499E-01  0.99478E-01  0.12464E+00
+  0.15626E+00  0.19595E+00  0.24560E+00  0.30738E+00  0.38350E+00  0.47527E+00
+  0.58387E+00  0.70497E+00  0.82533E+00  0.90869E+00  0.89678E+00  0.76451E+00
+  0.49070E+00  0.13181E+00  0.82234E+00  0.16543E+01  0.27152E+01  0.42245E+01
+  0.64810E+01  0.88857E+01  0.12872E+02  0.17930E+02  0.25891E+02  0.38232E+02
+  0.57374E+02  0.87309E+02  0.13762E+03  0.21827E+03  0.35952E+03  0.59956E+03
+  0.12598E+00  0.15720E+00  0.19650E+00  0.24588E+00  0.30786E+00  0.38540E+00
+  0.48192E+00  0.60097E+00  0.74506E+00  0.91647E+00  0.11102E+01  0.13088E+01
+  0.14641E+01  0.14980E+01  0.13810E+01  0.10915E+01  0.32272E+00  0.89670E+00
+  0.23883E+01  0.42971E+01  0.69891E+01  0.10870E+02  0.14815E+02  0.21231E+02
+  0.29005E+02  0.40893E+02  0.58691E+02  0.85276E+02  0.12529E+03  0.19042E+03
+  0.29103E+03  0.46233E+03  0.74485E+03  0.19494E+00  0.24234E+00  0.30199E+00
+  0.37692E+00  0.47097E+00  0.58863E+00  0.73512E+00  0.91598E+00  0.11353E+01
+  0.13970E+01  0.16953E+01  0.20069E+01  0.22665E+01  0.23685E+01  0.22768E+01
+  0.19688E+01  0.10336E+01  0.56657E+00  0.33949E+01  0.69499E+01  0.11782E+02
+  0.18842E+02  0.25649E+02  0.36476E+02  0.49068E+02  0.67810E+02  0.94952E+02
+  0.13402E+03  0.19057E+03  0.27959E+03  0.41170E+03  0.62977E+03  0.97732E+03
+  0.29146E+00  0.36051E+00  0.44740E+00  0.55652E+00  0.69345E+00  0.86472E+00
+  0.10779E+01  0.13411E+01  0.16604E+01  0.20419E+01  0.24775E+01  0.29361E+01
+  0.33264E+01  0.35039E+01  0.34213E+01  0.30523E+01  0.18367E+01  0.25986E+00
+  0.39820E+01  0.10630E+02  0.21009E+02  0.33693E+02  0.46055E+02  0.65438E+02
+  0.86805E+02  0.11786E+03  0.16148E+03  0.22212E+03  0.30665E+03  0.43533E+03
+  0.61856E+03  0.91132E+03  0.13607E+04  0.44702E+00  0.54928E+00  0.67794E+00
+  0.83952E+00  0.10422E+01  0.12958E+01  0.16115E+01  0.20015E+01  0.24752E+01
+  0.30425E+01  0.36933E+01  0.43858E+01  0.49949E+01  0.53223E+01  0.53079E+01
+  0.49235E+01  0.34019E+01  0.71958E+00  0.41183E+01  0.12836E+02  0.29109E+02
+  0.59433E+02  0.82438E+02  0.11719E+03  0.15613E+03  0.20974E+03  0.28291E+03
+  0.38153E+03  0.51430E+03  0.71021E+03  0.97799E+03  0.13922E+04  0.20038E+04
+  0.66942E+00  0.81549E+00  0.99926E+00  0.12301E+01  0.15195E+01  0.18815E+01
+  0.23321E+01  0.28888E+01  0.35648E+01  0.43745E+01  0.53042E+01  0.62953E+01
+  0.71734E+01  0.76617E+01  0.76800E+01  0.71938E+01  0.51398E+01  0.15015E+01
+  0.50770E+01  0.16930E+02  0.39015E+02  0.79991E+02  0.13615E+03  0.21681E+03
+  0.28552E+03  0.38332E+03  0.51367E+03  0.68119E+03  0.89989E+03  0.12136E+04
+  0.16262E+04  0.22451E+04  0.31237E+04  0.10349E+01  0.12470E+01  0.15139E+01
+  0.18490E+01  0.22692E+01  0.27950E+01  0.34494E+01  0.42579E+01  0.52406E+01
+  0.64190E+01  0.77754E+01  0.92301E+01  0.10541E+02  0.11324E+02  0.11476E+02
+  0.10959E+02  0.82965E+01  0.34941E+01  0.53038E+01  0.21277E+02  0.51169E+02
+  0.10667E+03  0.18215E+03  0.32157E+03  0.52679E+03  0.70292E+03  0.93638E+03
+  0.12425E+04  0.16174E+04  0.21419E+04  0.28083E+04  0.37798E+04  0.51091E+04
+  0.16032E+01  0.19059E+01  0.22869E+01  0.27651E+01  0.33649E+01  0.41150E+01
+  0.50488E+01  0.62019E+01  0.76042E+01  0.92860E+01  0.11223E+02  0.13305E+02
+  0.15192E+02  0.16348E+02  0.16635E+02  0.16009E+02  0.12411E+02  0.58701E+01
+  0.61763E+01  0.28106E+02  0.69190E+02  0.14539E+03  0.24844E+03  0.43813E+03
+  0.71515E+03  0.11827E+04  0.17390E+04  0.22783E+04  0.29635E+04  0.38931E+04
+  0.50160E+04  0.66133E+04  0.87258E+04  0.25404E+01  0.29726E+01  0.35163E+01
+  0.41986E+01  0.50544E+01  0.61245E+01  0.74564E+01  0.91018E+01  0.11101E+02
+  0.13501E+02  0.16266E+02  0.19242E+02  0.21954E+02  0.23652E+02  0.24154E+02
+  0.23409E+02  0.18539E+02  0.96125E+01  0.69239E+01  0.37132E+02  0.93827E+02
+  0.19899E+03  0.34060E+03  0.60079E+03  0.97857E+03  0.16127E+04  0.26469E+04
+  0.42592E+04  0.54753E+04  0.71422E+04  0.91898E+04  0.11923E+05  0.15432E+05
+  0.41307E+01  0.47472E+01  0.55228E+01  0.64961E+01  0.77167E+01  0.92428E+01
+  0.11142E+02  0.13487E+02  0.16338E+02  0.19758E+02  0.23702E+02  0.27952E+02
+  0.31840E+02  0.34316E+02  0.35144E+02  0.34271E+02  0.27661E+02  0.15455E+02
+  0.72941E+01  0.49008E+02  0.12749E+03  0.27318E+03  0.46873E+03  0.82770E+03
+  0.13468E+04  0.22148E+04  0.36229E+04  0.58576E+04  0.93503E+04  0.13285E+05
+  0.16876E+05  0.21875E+05  0.28054E+05  0.69063E+01  0.77857E+01  0.88916E+01
+  0.10280E+02  0.12020E+02  0.14195E+02  0.16901E+02  0.20242E+02  0.24302E+02
+  0.29173E+02  0.34791E+02  0.40846E+02  0.46397E+02  0.49978E+02  0.51279E+02
+  0.50263E+02  0.41257E+02  0.24522E+02  0.68464E+01  0.64585E+02  0.17351E+03
+  0.37592E+03  0.64693E+03  0.11444E+04  0.18615E+04  0.30578E+04  0.49908E+04
+  0.80433E+04  0.12782E+05  0.20509E+05  0.31579E+05  0.40437E+05  0.51515E+05
+  0.48046E-09  0.16304E-08  0.36732E-08  0.92210E-08  0.13914E-07  0.33484E-07
+  0.45835E-07  0.87724E-07  0.17345E-06  0.38069E-06  0.78089E-06  0.16296E-05
+  0.61417E-05  0.30912E-04  0.18050E-03  0.47843E-03  0.17647E-02  0.42234E-02
+  0.80848E-02  0.14384E-01  0.23961E-01  0.39555E-01  0.60208E-01  0.92079E-01
+  0.13658E+00  0.20687E+00  0.31587E+00  0.48240E+00  0.73364E+00  0.11311E+01
+  0.17215E+01  0.26644E+01  0.41017E+01  0.56161E-09  0.12374E-08  0.40100E-08
+  0.95020E-08  0.23009E-07  0.34917E-07  0.82035E-07  0.11771E-06  0.23499E-06
+  0.50328E-06  0.10462E-05  0.21336E-05  0.10135E-04  0.63768E-04  0.23160E-03
+  0.61196E-03  0.22526E-02  0.53788E-02  0.10276E-01  0.18251E-01  0.30361E-01
+  0.50057E-01  0.76110E-01  0.11627E+00  0.17227E+00  0.26064E+00  0.39751E+00
+  0.60625E+00  0.92059E+00  0.14167E+01  0.21514E+01  0.33209E+01  0.50958E+01
+  0.13449E-09  0.14242E-08  0.30623E-08  0.10386E-07  0.23747E-07  0.57410E-07
+  0.87769E-07  0.18227E-06  0.33168E-06  0.61717E-06  0.14055E-05  0.25471E-05
+  0.15547E-04  0.10883E-03  0.46515E-03  0.78767E-03  0.28906E-02  0.68821E-02
+  0.13115E-01  0.23245E-01  0.38601E-01  0.63550E-01  0.96501E-01  0.14724E+00
+  0.21792E+00  0.32937E+00  0.50177E+00  0.76434E+00  0.11591E+01  0.17809E+01
+  0.26994E+01  0.41575E+01  0.63625E+01  0.11556E-08  0.37413E-09  0.34279E-08
+  0.80308E-08  0.25934E-07  0.59481E-07  0.14028E-06  0.23067E-06  0.49377E-06
+  0.90536E-06  0.18624E-05  0.40128E-05  0.37612E-04  0.16876E-03  0.77740E-03
+  0.13588E-02  0.37138E-02  0.88098E-02  0.16736E-01  0.29589E-01  0.49033E-01
+  0.80587E-01  0.12219E+00  0.18621E+00  0.27528E+00  0.41558E+00  0.63245E+00
+  0.96236E+00  0.14576E+01  0.22366E+01  0.33850E+01  0.52040E+01  0.79462E+01
+  0.30313E-08  0.27427E-08  0.85121E-09  0.92676E-08  0.20412E-07  0.65201E-07
+  0.14950E-06  0.30805E-06  0.74443E-06  0.14217E-05  0.31739E-05  0.96250E-05
+  0.71099E-04  0.32747E-03  0.11986E-02  0.21265E-02  0.48180E-02  0.11331E-01
+  0.21459E-01  0.37820E-01  0.62514E-01  0.10252E+00  0.15518E+00  0.23613E+00
+  0.34863E+00  0.52571E+00  0.79922E+00  0.12148E+01  0.18379E+01  0.28169E+01
+  0.42574E+01  0.65351E+01  0.99605E+01  0.94966E-08  0.76373E-08  0.72231E-08
+  0.27151E-08  0.22982E-07  0.51934E-07  0.16330E-06  0.39853E-06  0.87498E-06
+  0.23283E-05  0.54130E-05  0.19773E-04  0.12737E-03  0.54637E-03  0.15837E-02
+  0.31510E-02  0.62902E-02  0.13213E-01  0.27552E-01  0.48548E-01  0.79992E-01
+  0.13086E+00  0.19765E+00  0.30022E+00  0.44260E+00  0.66657E+00  0.10121E+01
+  0.15368E+01  0.23227E+01  0.35559E+01  0.53681E+01  0.82288E+01  0.12523E+02
+  0.14327E-07  0.23151E-07  0.19508E-07  0.16561E-07  0.64961E-08  0.57580E-07
+  0.13252E-06  0.42147E-06  0.13627E-05  0.29143E-05  0.10499E-04  0.37738E-04
+  0.18689E-03  0.84078E-03  0.20508E-02  0.39114E-02  0.82214E-02  0.15702E-01
+  0.30485E-01  0.62077E-01  0.10267E+00  0.16744E+00  0.25226E+00  0.38236E+00
+  0.56271E+00  0.84621E+00  0.12833E+01  0.19463E+01  0.29384E+01  0.44938E+01
+  0.67767E+01  0.10376E+02  0.15770E+02  0.29580E-07  0.37419E-07  0.51818E-07
+  0.52541E-07  0.39599E-07  0.15064E-07  0.14848E-06  0.34029E-06  0.12278E-05
+  0.43750E-05  0.15095E-04  0.86071E-04  0.28727E-03  0.11037E-02  0.25027E-02
+  0.48401E-02  0.95996E-02  0.18929E-01  0.34360E-01  0.66419E-01  0.13072E+00
+  0.21514E+00  0.32309E+00  0.48851E+00  0.71741E+00  0.10770E+01  0.16309E+01
+  0.24704E+01  0.37255E+01  0.56917E+01  0.85741E+01  0.13114E+02  0.19907E+02
+  0.61201E-07  0.78442E-07  0.10348E-06  0.12890E-06  0.16686E-06  0.11394E-06
+  0.48543E-07  0.44727E-06  0.90393E-06  0.34823E-05  0.19305E-04  0.12349E-03
+  0.44450E-03  0.13521E-02  0.30003E-02  0.57668E-02  0.11213E-01  0.21241E-01
+  0.39255E-01  0.72073E-01  0.13713E+00  0.27231E+00  0.41481E+00  0.62530E+00
+  0.91599E+00  0.13723E+01  0.20747E+01  0.31382E+01  0.47270E+01  0.72135E+01
+  0.10855E+02  0.16586E+02  0.25152E+02  0.13891E-06  0.18276E-06  0.21133E-06
+  0.28103E-06  0.37491E-06  0.51792E-06  0.39722E-06  0.16747E-06  0.14477E-05
+  0.23155E-05  0.15697E-04  0.15136E-03  0.59542E-03  0.16419E-02  0.34992E-02
+  0.66119E-02  0.12714E-01  0.23853E-01  0.42664E-01  0.79081E-01  0.14544E+00
+  0.28252E+00  0.52210E+00  0.80350E+00  0.11735E+01  0.17539E+01  0.26463E+01
+  0.39963E+01  0.60112E+01  0.91623E+01  0.13774E+02  0.21023E+02  0.31849E+02
+  0.29279E-06  0.36885E-06  0.47059E-06  0.68563E-06  0.11460E-05  0.15260E-05
+  0.27730E-05  0.24428E-05  0.11527E-05  0.81149E-05  0.11484E-04  0.13811E-03
+  0.66783E-03  0.18704E-02  0.40239E-02  0.74562E-02  0.14005E-01  0.26069E-01
+  0.46366E-01  0.83868E-01  0.15538E+00  0.29529E+00  0.53747E+00  0.10043E+01
+  0.15035E+01  0.22408E+01  0.33734E+01  0.50849E+01  0.76365E+01  0.11625E+02
+  0.17455E+02  0.26617E+02  0.40283E+02  0.61026E-06  0.78872E-06  0.10240E-05
+  0.13504E-05  0.34985E-05  0.65614E-05  0.11685E-04  0.19966E-04  0.18119E-04
+  0.80814E-05  0.61419E-04  0.14165E-03  0.66090E-03  0.20233E-02  0.45522E-02
+  0.84682E-02  0.15695E-01  0.28029E-01  0.49785E-01  0.89310E-01  0.16309E+00
+  0.31062E+00  0.55679E+00  0.10331E+01  0.18702E+01  0.28800E+01  0.43240E+01
+  0.65037E+01  0.97499E+01  0.14821E+02  0.22226E+02  0.33855E+02  0.51188E+02
+  0.27582E-05  0.49115E-05  0.77446E-05  0.17743E-04  0.33584E-04  0.57672E-04
+  0.79229E-04  0.99139E-04  0.10785E-03  0.82874E-04  0.26872E-04  0.25658E-03
+  0.84255E-03  0.22540E-02  0.49992E-02  0.94017E-02  0.17616E-01  0.31130E-01
+  0.53913E-01  0.94871E-01  0.17238E+00  0.32293E+00  0.57852E+00  0.10677E+01
+  0.19196E+01  0.35487E+01  0.55553E+01  0.83354E+01  0.12471E+02  0.18927E+02
+  0.28345E+02  0.43129E+02  0.65144E+02  0.25215E-04  0.42867E-04  0.72138E-04
+  0.11046E-03  0.16648E-03  0.24291E-03  0.32316E-03  0.39340E-03  0.42400E-03
+  0.40203E-03  0.26406E-03  0.93331E-04  0.86187E-03  0.30581E-02  0.57571E-02
+  0.10349E-01  0.19361E-01  0.34286E-01  0.58547E-01  0.10218E+00  0.18316E+00
+  0.33801E+00  0.59744E+00  0.11071E+01  0.19813E+01  0.36389E+01  0.67800E+01
+  0.10770E+02  0.16076E+02  0.24354E+02  0.36417E+02  0.55342E+02  0.83504E+02
+  0.55832E-04  0.71100E-04  0.14557E-03  0.28566E-03  0.46926E-03  0.64969E-03
+  0.83559E-03  0.99087E-03  0.11035E-02  0.11256E-02  0.98746E-03  0.55853E-03
+  0.46684E-03  0.25370E-02  0.78995E-02  0.12242E-01  0.21219E-01  0.37366E-01
+  0.63462E-01  0.10913E+00  0.19376E+00  0.35615E+00  0.62090E+00  0.11425E+01
+  0.20504E+01  0.37544E+01  0.69507E+01  0.12944E+02  0.20781E+02  0.31412E+02
+  0.46884E+02  0.71145E+02  0.10721E+03  0.42078E-03  0.53570E-03  0.68394E-03
+  0.90979E-03  0.12599E-02  0.17148E-02  0.21691E-02  0.25231E-02  0.28017E-02
+  0.29448E-02  0.28344E-02  0.23665E-02  0.10628E-02  0.16538E-02  0.59234E-02
+  0.13012E-01  0.26357E-01  0.40996E-01  0.69297E-01  0.11816E+00  0.20791E+00
+  0.37889E+00  0.65312E+00  0.11916E+01  0.21206E+01  0.38904E+01  0.71959E+01
+  0.13306E+02  0.24632E+02  0.41718E+02  0.62108E+02  0.94064E+02  0.14152E+03
+  0.13832E-02  0.17570E-02  0.22366E-02  0.28524E-02  0.35710E-02  0.42069E-02
+  0.50189E-02  0.59052E-02  0.64477E-02  0.68297E-02  0.67553E-02  0.59871E-02
+  0.43128E-02  0.62149E-03  0.50481E-02  0.12856E-01  0.26625E-01  0.95087E-01
+  0.77515E-01  0.13120E+00  0.22867E+00  0.41247E+00  0.70122E+00  0.12653E+01
+  0.22271E+01  0.40492E+01  0.74802E+01  0.13843E+02  0.25423E+02  0.47611E+02
+  0.82610E+02  0.12476E+03  0.18726E+03  0.30857E-02  0.39105E-02  0.49642E-02
+  0.63105E-02  0.80358E-02  0.10246E-01  0.11217E-01  0.12410E-01  0.13819E-01
+  0.14320E-01  0.14442E-01  0.13424E-01  0.10882E-01  0.55974E-02  0.21324E-02
+  0.12304E-01  0.29078E-01  0.52867E-01  0.33724E+00  0.15130E+00  0.26098E+00
+  0.46487E+00  0.77666E+00  0.13810E+01  0.23950E+01  0.43000E+01  0.78586E+01
+  0.14468E+02  0.26647E+02  0.49445E+02  0.90993E+02  0.16851E+03  0.25203E+03
+  0.64500E-02  0.81603E-02  0.10338E-01  0.13111E-01  0.16651E-01  0.21170E-01
+  0.26928E-01  0.29372E-01  0.30890E-01  0.32569E-01  0.32774E-01  0.31619E-01
+  0.27737E-01  0.20360E-01  0.96560E-02  0.36194E-02  0.24946E-01  0.53781E-01
+  0.97265E-01  0.45149E+00  0.29508E+00  0.52038E+00  0.85867E+00  0.15107E+01
+  0.25848E+01  0.45867E+01  0.82941E+01  0.15125E+02  0.27650E+02  0.51586E+02
+  0.94268E+02  0.17590E+03  0.32738E+03  0.11495E-01  0.14519E-01  0.18359E-01
+  0.23233E-01  0.29433E-01  0.37311E-01  0.47309E-01  0.59931E-01  0.67754E-01
+  0.69016E-01  0.69694E-01  0.67868E-01  0.61516E-01  0.49659E-01  0.33402E-01
+  0.14105E-01  0.15774E-01  0.54028E-01  0.10939E+00  0.19643E+00  0.37599E+00
+  0.63660E+00  0.10014E+01  0.17348E+01  0.29131E+01  0.50809E+01  0.90428E+01
+  0.16254E+02  0.29336E+02  0.54144E+02  0.99103E+02  0.18402E+03  0.33941E+03
+  0.19580E-01  0.24700E-01  0.31186E-01  0.39401E-01  0.49819E-01  0.63024E-01
+  0.79725E-01  0.10076E+00  0.12689E+00  0.14936E+00  0.14820E+00  0.14414E+00
+  0.13362E+00  0.11310E+00  0.87025E-01  0.58006E-01  0.14638E-01  0.38022E-01
+  0.11106E+00  0.22216E+00  0.40937E+00  0.73934E+00  0.11881E+01  0.20339E+01
+  0.33542E+01  0.57478E+01  0.10054E+02  0.17779E+02  0.31612E+02  0.57594E+02
+  0.10422E+03  0.19318E+03  0.35570E+03  0.30191E-01  0.38035E-01  0.47962E-01
+  0.60512E-01  0.76392E-01  0.96470E-01  0.12181E+00  0.15364E+00  0.19317E+00
+  0.24182E+00  0.29583E+00  0.28806E+00  0.27062E+00  0.23927E+00  0.19662E+00
+  0.15088E+00  0.84831E-01  0.84027E-02  0.93149E-01  0.24221E+00  0.48678E+00
+  0.90737E+00  0.14512E+01  0.24624E+01  0.39885E+01  0.67068E+01  0.11506E+02
+  0.19960E+02  0.34854E+02  0.62494E+02  0.11148E+03  0.20414E+03  0.37375E+03
+  0.46142E-01  0.58057E-01  0.73115E-01  0.92124E-01  0.11614E+00  0.14644E+00
+  0.18461E+00  0.23248E+00  0.29185E+00  0.36492E+00  0.45222E+00  0.55134E+00
+  0.54508E+00  0.49037E+00  0.42309E+00  0.34775E+00  0.24072E+00  0.12196E+00
+  0.29406E-01  0.24331E+00  0.58370E+00  0.11524E+01  0.18479E+01  0.31193E+01
+  0.49637E+01  0.81785E+01  0.13723E+02  0.23270E+02  0.39747E+02  0.69842E+02
+  0.12231E+03  0.22042E+03  0.39801E+03  0.70540E-01  0.88627E-01  0.11146E+00
+  0.14025E+00  0.17659E+00  0.22237E+00  0.27994E+00  0.35203E+00  0.44136E+00
+  0.55127E+00  0.68290E+00  0.83365E+00  0.98949E+00  0.10124E+01  0.89121E+00
+  0.76646E+00  0.58725E+00  0.38930E+00  0.14634E+00  0.18434E+00  0.69341E+00
+  0.15173E+01  0.24670E+01  0.41675E+01  0.65251E+01  0.10530E+02  0.17242E+02
+  0.28482E+02  0.47383E+02  0.81210E+02  0.13893E+03  0.24524E+03  0.43478E+03
+  0.10486E+00  0.13154E+00  0.16521E+00  0.20763E+00  0.26112E+00  0.32842E+00
+  0.41298E+00  0.51879E+00  0.64988E+00  0.81116E+00  0.10048E+01  0.12283E+01
+  0.14643E+01  0.16822E+01  0.17859E+01  0.15692E+01  0.12737E+01  0.95603E+00
+  0.56225E+00  0.42645E-01  0.73413E+00  0.19551E+01  0.32892E+01  0.56296E+01
+  0.87327E+01  0.13868E+02  0.22226E+02  0.35816E+02  0.58034E+02  0.96920E+02
+  0.16170E+03  0.27893E+03  0.48430E+03  0.15305E+00  0.19163E+00  0.24026E+00
+  0.30153E+00  0.37868E+00  0.47573E+00  0.59753E+00  0.74973E+00  0.93824E+00
+  0.11700E+01  0.14485E+01  0.17709E+01  0.21150E+01  0.24419E+01  0.27508E+01
+  0.30539E+01  0.25733E+01  0.20251E+01  0.13729E+01  0.50363E+00  0.76136E+00
+  0.26921E+01  0.47015E+01  0.81433E+01  0.12502E+02  0.19505E+02  0.30534E+02
+  0.47865E+02  0.75285E+02  0.12200E+03  0.19755E+03  0.33133E+03  0.56047E+03
+  0.22271E+00  0.27817E+00  0.34806E+00  0.43606E+00  0.54683E+00  0.68608E+00
+  0.86073E+00  0.10789E+01  0.13489E+01  0.16810E+01  0.20803E+01  0.25441E+01
+  0.30443E+01  0.35307E+01  0.40056E+01  0.44890E+01  0.47480E+01  0.41720E+01
+  0.30438E+01  0.15945E+01  0.51482E+00  0.36654E+01  0.68106E+01  0.12078E+02
+  0.18468E+02  0.28443E+02  0.43639E+02  0.66699E+02  0.10193E+03  0.16022E+03
+  0.25147E+03  0.40906E+03  0.67205E+03  0.32190E+00  0.40084E+00  0.50032E+00
+  0.62551E+00  0.78305E+00  0.98103E+00  0.12292E+01  0.15392E+01  0.19229E+01
+  0.23946E+01  0.29630E+01  0.36253E+01  0.43462E+01  0.50615E+01  0.57782E+01
+  0.65280E+01  0.70124E+01  0.72905E+01  0.64128E+01  0.39450E+01  0.43397E+00
+  0.47858E+01  0.98280E+01  0.18106E+02  0.27772E+02  0.42468E+02  0.64162E+02
+  0.95979E+02  0.14291E+03  0.21830E+03  0.33226E+03  0.52392E+03  0.83463E+03
+  0.49511E+00  0.61405E+00  0.76392E+00  0.95250E+00  0.11898E+01  0.14879E+01
+  0.18617E+01  0.23287E+01  0.29074E+01  0.36204E+01  0.44822E+01  0.54946E+01
+  0.66147E+01  0.77645E+01  0.89637E+01  0.10268E+02  0.11298E+02  0.12161E+02
+  0.12393E+02  0.10965E+02  0.49112E+01  0.39363E+01  0.12416E+02  0.26034E+02
+  0.41384E+02  0.64163E+02  0.96796E+02  0.14307E+03  0.20894E+03  0.31154E+03
+  0.46088E+03  0.70493E+03  0.10878E+04  0.67975E+00  0.83884E+00  0.10393E+01
+  0.12915E+01  0.16087E+01  0.20071E+01  0.25064E+01  0.31298E+01  0.39017E+01
+  0.48517E+01  0.59986E+01  0.73429E+01  0.88273E+01  0.10345E+02  0.11919E+02
+  0.13623E+02  0.14948E+02  0.16037E+02  0.16277E+02  0.14519E+02  0.80761E+01
+  0.67088E+01  0.20923E+02  0.43911E+02  0.69072E+02  0.10541E+03  0.15611E+03
+  0.22584E+03  0.32184E+03  0.46697E+03  0.67052E+03  0.99345E+03  0.14830E+04
+  0.10418E+01  0.12773E+01  0.15739E+01  0.19471E+01  0.24166E+01  0.30062E+01
+  0.37452E+01  0.46682E+01  0.58122E+01  0.72224E+01  0.89304E+01  0.10944E+02
+  0.13195E+02  0.15552E+02  0.18065E+02  0.20851E+02  0.23252E+02  0.25500E+02
+  0.26829E+02  0.25785E+02  0.18938E+02  0.00000E+00  0.24450E+02  0.63376E+02
+  0.10606E+03  0.16704E+03  0.24915E+03  0.35903E+03  0.50565E+03  0.72116E+03
+  0.10124E+04  0.14611E+04  0.21173E+04  0.15068E+01  0.18352E+01  0.22488E+01
+  0.27690E+01  0.34235E+01  0.42457E+01  0.52765E+01  0.65645E+01  0.81624E+01
+  0.10135E+02  0.12531E+02  0.15370E+02  0.18578E+02  0.22002E+02  0.25727E+02
+  0.29929E+02  0.33805E+02  0.37695E+02  0.40685E+02  0.41012E+02  0.34465E+02
+  0.13336E+02  0.17088E+02  0.80795E+02  0.14649E+03  0.24057E+03  0.36752E+03
+  0.53154E+03  0.74541E+03  0.10532E+04  0.14572E+04  0.20654E+04  0.29292E+04
+  0.21894E+01  0.26452E+01  0.32193E+01  0.39416E+01  0.48499E+01  0.59914E+01
+  0.74225E+01  0.92121E+01  0.11434E+02  0.14180E+02  0.17522E+02  0.21502E+02
+  0.26038E+02  0.30953E+02  0.36386E+02  0.42602E+02  0.48602E+02  0.54891E+02
+  0.60369E+02  0.62891E+02  0.57241E+02  0.33889E+02  0.00000E+00  0.83117E+02
+  0.20081E+03  0.34650E+03  0.54264E+03  0.79818E+03  0.11183E+04  0.15701E+04
+  0.21475E+04  0.29979E+04  0.41716E+04  0.37274E-09  0.12672E-08  0.37590E-08
+  0.93469E-08  0.21868E-07  0.36216E-07  0.79740E-07  0.12734E-06  0.24737E-06
+  0.51814E-06  0.10960E-05  0.21951E-05  0.10886E-04  0.70077E-04  0.26123E-03
+  0.63678E-03  0.23430E-02  0.55924E-02  0.10680E-01  0.18964E-01  0.31539E-01
+  0.51989E-01  0.79033E-01  0.12071E+00  0.17883E+00  0.27051E+00  0.41249E+00
+  0.62898E+00  0.95487E+00  0.14691E+01  0.22302E+01  0.34412E+01  0.52780E+01
+  0.31548E-09  0.92981E-09  0.30399E-08  0.97045E-08  0.23254E-07  0.54635E-07
+  0.90601E-07  0.18684E-06  0.34577E-06  0.65019E-06  0.14600E-05  0.26134E-05
+  0.18208E-04  0.11640E-03  0.50493E-03  0.85820E-03  0.29961E-02  0.71303E-02
+  0.13583E-01  0.24067E-01  0.39956E-01  0.65766E-01  0.99846E-01  0.15233E+00
+  0.22543E+00  0.34063E+00  0.51886E+00  0.79025E+00  0.11981E+01  0.18405E+01
+  0.27892E+01  0.42947E+01  0.65700E+01  0.20343E-08  0.72336E-09  0.22140E-08
+  0.80186E-08  0.24252E-07  0.58262E-07  0.13475E-06  0.23839E-06  0.53371E-06
+  0.94473E-06  0.20102E-05  0.46700E-05  0.41281E-04  0.18752E-03  0.82839E-03
+  0.14523E-02  0.38486E-02  0.91199E-02  0.17318E-01  0.30607E-01  0.50705E-01
+  0.83312E-01  0.12630E+00  0.19243E+00  0.28444E+00  0.42934E+00  0.65332E+00
+  0.99397E+00  0.15053E+01  0.23093E+01  0.34944E+01  0.53709E+01  0.81990E+01
+  0.45022E-08  0.48437E-08  0.17666E-08  0.63898E-08  0.20275E-07  0.61135E-07
+  0.14649E-06  0.31583E-06  0.77428E-06  0.15495E-05  0.33381E-05  0.10695E-04
+  0.77116E-04  0.35131E-03  0.12401E-02  0.22403E-02  0.49801E-02  0.11538E-01
+  0.22149E-01  0.39022E-01  0.64480E-01  0.10572E+00  0.15999E+00  0.24339E+00
+  0.35931E+00  0.54175E+00  0.82343E+00  0.12515E+01  0.18932E+01  0.29012E+01
+  0.43843E+01  0.67287E+01  0.10254E+02  0.13863E-07  0.11494E-07  0.12815E-07
+  0.42064E-08  0.15215E-07  0.50065E-07  0.15212E-06  0.38631E-06  0.94278E-06
+  0.24216E-05  0.58517E-05  0.20873E-04  0.13243E-03  0.57351E-03  0.16320E-02
+  0.32207E-02  0.64757E-02  0.13446E-01  0.27822E-01  0.49897E-01  0.82192E-01
+  0.13442E+00  0.20299E+00  0.30828E+00  0.45442E+00  0.68428E+00  0.10389E+01
+  0.15773E+01  0.23838E+01  0.36489E+01  0.55079E+01  0.84420E+01  0.12845E+02
+  0.19277E-07  0.32784E-07  0.29239E-07  0.30282E-07  0.11129E-07  0.37570E-07
+  0.12489E-06  0.39042E-06  0.12872E-05  0.30891E-05  0.10906E-04  0.40709E-04
+  0.19429E-03  0.85967E-03  0.20827E-02  0.39885E-02  0.83217E-02  0.15957E-01
+  0.30774E-01  0.62385E-01  0.10507E+00  0.17131E+00  0.25803E+00  0.39107E+00
+  0.57544E+00  0.86525E+00  0.13121E+01  0.19899E+01  0.30040E+01  0.45938E+01
+  0.69269E+01  0.10605E+02  0.16116E+02  0.38944E-07  0.50568E-07  0.71945E-07
+  0.80217E-07  0.75924E-07  0.35453E-07  0.95141E-07  0.31091E-06  0.11202E-05
+  0.41183E-05  0.15309E-04  0.88370E-04  0.29228E-03  0.11128E-02  0.25242E-02
+  0.48840E-02  0.96922E-02  0.19036E-01  0.34626E-01  0.66684E-01  0.13098E+00
+  0.21889E+00  0.32869E+00  0.49695E+00  0.72976E+00  0.10955E+01  0.16588E+01
+  0.25127E+01  0.37892E+01  0.57889E+01  0.87199E+01  0.13337E+02  0.20244E+02
+  0.79951E-07  0.10287E-06  0.13774E-06  0.17313E-06  0.24948E-06  0.21822E-06
+  0.11721E-06  0.29251E-06  0.81545E-06  0.31590E-05  0.18416E-04  0.12325E-03
+  0.44662E-03  0.13542E-02  0.30040E-02  0.57762E-02  0.11238E-01  0.21311E-01
+  0.39302E-01  0.72244E-01  0.13725E+00  0.27237E+00  0.41973E+00  0.63274E+00
+  0.92692E+00  0.13888E+01  0.20996E+01  0.31760E+01  0.47839E+01  0.73006E+01
+  0.10987E+02  0.16786E+02  0.25456E+02  0.17661E-06  0.23477E-06  0.27300E-06
+  0.36758E-06  0.50400E-06  0.75181E-06  0.72765E-06  0.34028E-06  0.98869E-06
+  0.20433E-05  0.14414E-04  0.14430E-03  0.58394E-03  0.16236E-02  0.34750E-02
+  0.65773E-02  0.12664E-01  0.23782E-01  0.42580E-01  0.78906E-01  0.14525E+00
+  0.28214E+00  0.52139E+00  0.80742E+00  0.11794E+01  0.17630E+01  0.26605E+01
+  0.40184E+01  0.60447E+01  0.92144E+01  0.13852E+02  0.21146E+02  0.32037E+02
+  0.37308E-06  0.47077E-06  0.60187E-06  0.89324E-06  0.15236E-05  0.20818E-05
+  0.40986E-05  0.45485E-05  0.17553E-05  0.53069E-05  0.99049E-05  0.12711E-03
+  0.63797E-03  0.18213E-02  0.39529E-02  0.73566E-02  0.13860E-01  0.25847E-01
+  0.46042E-01  0.83387E-01  0.15463E+00  0.29419E+00  0.53571E+00  0.10016E+01
+  0.15031E+01  0.22410E+01  0.33748E+01  0.50885E+01  0.76438E+01  0.11638E+02
+  0.17478E+02  0.26655E+02  0.40345E+02  0.77202E-06  0.10002E-05  0.12894E-05
+  0.17415E-05  0.44819E-05  0.85678E-05  0.15592E-04  0.28973E-04  0.33245E-04
+  0.13068E-04  0.37893E-04  0.11578E-03  0.60588E-03  0.19210E-02  0.43889E-02
+  0.82302E-02  0.15337E-01  0.27539E-01  0.49039E-01  0.88224E-01  0.16144E+00
+  0.30813E+00  0.55288E+00  0.10271E+01  0.18612E+01  0.28522E+01  0.42851E+01
+  0.64489E+01  0.96720E+01  0.14708E+02  0.22064E+02  0.33617E+02  0.50839E+02
+  0.33509E-05  0.58349E-05  0.91186E-05  0.21236E-04  0.39888E-04  0.69269E-04
+  0.96406E-04  0.12725E-03  0.15300E-03  0.14923E-03  0.58367E-04  0.15191E-03
+  0.73064E-03  0.20250E-02  0.46683E-02  0.89181E-02  0.16899E-01  0.29981E-01
+  0.52461E-01  0.92638E-01  0.16908E+00  0.31810E+00  0.57135E+00  0.10561E+01
+  0.19022E+01  0.35222E+01  0.54417E+01  0.81736E+01  0.12239E+02  0.18588E+02
+  0.27854E+02  0.42401E+02  0.64071E+02  0.24245E-04  0.44115E-04  0.74080E-04
+  0.11358E-03  0.18378E-03  0.28170E-03  0.39518E-03  0.49524E-03  0.55395E-03
+  0.57156E-03  0.47697E-03  0.17540E-03  0.50647E-03  0.28857E-02  0.49250E-02
+  0.93407E-02  0.17923E-01  0.32215E-01  0.55429E-01  0.97964E-01  0.17698E+00
+  0.32859E+00  0.58380E+00  0.10864E+01  0.19476E+01  0.35880E+01  0.67026E+01
+  0.10357E+02  0.15484E+02  0.23488E+02  0.35158E+02  0.53477E+02  0.80746E+02
+  0.87978E-04  0.11232E-03  0.22728E-03  0.40263E-03  0.63422E-03  0.84913E-03
+  0.11002E-02  0.13011E-02  0.14820E-02  0.15885E-02  0.15551E-02  0.12689E-02
+  0.43855E-03  0.13268E-02  0.82411E-02  0.96342E-02  0.18099E-01  0.32953E-01
+  0.57309E-01  0.10041E+00  0.18114E+00  0.33751E+00  0.59359E+00  0.11015E+01
+  0.19891E+01  0.36534E+01  0.67980E+01  0.12711E+02  0.19562E+02  0.29645E+02
+  0.44333E+02  0.67390E+02  0.10170E+03  0.40372E-03  0.51472E-03  0.65857E-03
+  0.99753E-03  0.14867E-02  0.21311E-02  0.26368E-02  0.31835E-02  0.36075E-02
+  0.39259E-02  0.40512E-02  0.39177E-02  0.30965E-02  0.10923E-02  0.22592E-02
+  0.19552E-01  0.16966E-01  0.31450E-01  0.56137E-01  0.99712E-01  0.18147E+00
+  0.34014E+00  0.59700E+00  0.11081E+01  0.19968E+01  0.37037E+01  0.68819E+01
+  0.12832E+02  0.23914E+02  0.37339E+02  0.55806E+02  0.84803E+02  0.12793E+03
+  0.13559E-02  0.17253E-02  0.22016E-02  0.28173E-02  0.35547E-02  0.44979E-02
+  0.57310E-02  0.66723E-02  0.76440E-02  0.82898E-02  0.86180E-02  0.85330E-02
+  0.79034E-02  0.55917E-02  0.17933E-02  0.36486E-02  0.36813E-01  0.29276E-01
+  0.54461E-01  0.99229E-01  0.18328E+00  0.34646E+00  0.60673E+00  0.11259E+01
+  0.20222E+01  0.37428E+01  0.70172E+01  0.13052E+02  0.24232E+02  0.45799E+02
+  0.70468E+02  0.10699E+03  0.16128E+03  0.31829E-02  0.40417E-02  0.51442E-02
+  0.65622E-02  0.83951E-02  0.98370E-02  0.11429E-01  0.13480E-01  0.14962E-01
+  0.16424E-01  0.17092E-01  0.17088E-01  0.15971E-01  0.13646E-01  0.90752E-02
+  0.29104E-02  0.81878E-02  0.66257E-01  0.52050E-01  0.98453E-01  0.18646E+00
+  0.35707E+00  0.62413E+00  0.11575E+01  0.20701E+01  0.38180E+01  0.71352E+01
+  0.13376E+02  0.24746E+02  0.46573E+02  0.86666E+02  0.13543E+03  0.20387E+03
+  0.63971E-02  0.81091E-02  0.10298E-01  0.13103E-01  0.16710E-01  0.21363E-01
+  0.24034E-01  0.26474E-01  0.29524E-01  0.31511E-01  0.33146E-01  0.33287E-01
+  0.32535E-01  0.29064E-01  0.23940E-01  0.17024E-01  0.46197E-02  0.12997E-01
+  0.11140E+00  0.91467E-01  0.18297E+00  0.36231E+00  0.63677E+00  0.11869E+01
+  0.21179E+01  0.38983E+01  0.72667E+01  0.13582E+02  0.25329E+02  0.47529E+02
+  0.88056E+02  0.16648E+03  0.25791E+03  0.11200E-01  0.14175E-01  0.17968E-01
+  0.22812E-01  0.29015E-01  0.36978E-01  0.47217E-01  0.51828E-01  0.55099E-01
+  0.59091E-01  0.61224E-01  0.62258E-01  0.60758E-01  0.56716E-01  0.49889E-01
+  0.41623E-01  0.27025E-01  0.73337E-02  0.23579E-01  0.20611E+00  0.17799E+00
+  0.36911E+00  0.65615E+00  0.12330E+01  0.21955E+01  0.40300E+01  0.74841E+01
+  0.13928E+02  0.25860E+02  0.48876E+02  0.90177E+02  0.16967E+03  0.31782E+03
+  0.17618E-01  0.22268E-01  0.28182E-01  0.35711E-01  0.45320E-01  0.57603E-01
+  0.73324E-01  0.93444E-01  0.10085E+00  0.10472E+00  0.10891E+00  0.11001E+00
+  0.10802E+00  0.10213E+00  0.92625E-01  0.81753E-01  0.63202E-01  0.39602E-01
+  0.38806E-02  0.56144E-01  0.45182E+00  0.38664E+00  0.69160E+00  0.13116E+01
+  0.23275E+01  0.42515E+01  0.78464E+01  0.14503E+02  0.26746E+02  0.50259E+02
+  0.93242E+02  0.17458E+03  0.32512E+03  0.27367E-01  0.34550E-01  0.43667E-01
+  0.55248E-01  0.69986E-01  0.88766E-01  0.11271E+00  0.14324E+00  0.18195E+00
+  0.19405E+00  0.19764E+00  0.20016E+00  0.19633E+00  0.18600E+00  0.17262E+00
+  0.15806E+00  0.13383E+00  0.10489E+00  0.62863E-01  0.61598E-02  0.13369E+00
+  0.10140E+01  0.71271E+00  0.13875E+01  0.24699E+01  0.45065E+01  0.82791E+01
+  0.15205E+02  0.27840E+02  0.51983E+02  0.95845E+02  0.18050E+03  0.33446E+03
+  0.39336E-01  0.49608E-01  0.62624E-01  0.79128E-01  0.10008E+00  0.12670E+00
+  0.16053E+00  0.20350E+00  0.25780E+00  0.32628E+00  0.34445E+00  0.34511E+00
+  0.34036E+00  0.32361E+00  0.30169E+00  0.27964E+00  0.24507E+00  0.20601E+00
+  0.15202E+00  0.66524E-01  0.88005E-01  0.37727E+00  0.75877E+00  0.15208E+01
+  0.27109E+01  0.49253E+01  0.89753E+01  0.16319E+02  0.29569E+02  0.54689E+02
+  0.99940E+02  0.18681E+03  0.34766E+03  0.56311E-01  0.70944E-01  0.89457E-01
+  0.11290E+00  0.14260E+00  0.18026E+00  0.22802E+00  0.28851E+00  0.36475E+00
+  0.46068E+00  0.57968E+00  0.60619E+00  0.59723E+00  0.57628E+00  0.54390E+00
+  0.51081E+00  0.46096E+00  0.40754E+00  0.33722E+00  0.22981E+00  0.39599E-01
+  0.31043E+00  0.74859E+00  0.16214E+01  0.29441E+01  0.53790E+01  0.97728E+01
+  0.17633E+02  0.31640E+02  0.57964E+02  0.10492E+03  0.19450E+03  0.35931E+03
+  0.78114E-01  0.98306E-01  0.12383E+00  0.15611E+00  0.19695E+00  0.24865E+00
+  0.31405E+00  0.39672E+00  0.50065E+00  0.63108E+00  0.79254E+00  0.98815E+00
+  0.10168E+01  0.98077E+00  0.93769E+00  0.88739E+00  0.81088E+00  0.73176E+00
+  0.63224E+00  0.48664E+00  0.23713E+00  0.20954E+00  0.73919E+00  0.17825E+01
+  0.33092E+01  0.60755E+01  0.10978E+02  0.19596E+02  0.34709E+02  0.62780E+02
+  0.11221E+03  0.20573E+03  0.37630E+03  0.11655E+00  0.14652E+00  0.18438E+00
+  0.23222E+00  0.29268E+00  0.36913E+00  0.46573E+00  0.58767E+00  0.74095E+00
+  0.93321E+00  0.11717E+01  0.14621E+01  0.18028E+01  0.18304E+01  0.17644E+01
+  0.17063E+01  0.15990E+01  0.14883E+01  0.13552E+01  0.11670E+01  0.84974E+00
+  0.28955E+00  0.33262E+00  0.15645E+01  0.33011E+01  0.64203E+01  0.11870E+02
+  0.21299E+02  0.37588E+02  0.67536E+02  0.11959E+03  0.21730E+03  0.39397E+03
+  0.16998E+00  0.21344E+00  0.26831E+00  0.33758E+00  0.42505E+00  0.53559E+00
+  0.67511E+00  0.85105E+00  0.10720E+01  0.13491E+01  0.16930E+01  0.21133E+01
+  0.26107E+01  0.31798E+01  0.32225E+01  0.31304E+01  0.29967E+01  0.28404E+01
+  0.26499E+01  0.23902E+01  0.19636E+01  0.12263E+01  0.45964E+00  0.10560E+01
+  0.31044E+01  0.67374E+01  0.12971E+02  0.23553E+02  0.41496E+02  0.74068E+02
+  0.12978E+03  0.23333E+03  0.41847E+03  0.24385E+00  0.30577E+00  0.38392E+00
+  0.48253E+00  0.60700E+00  0.76408E+00  0.96222E+00  0.12119E+01  0.15253E+01
+  0.19181E+01  0.24058E+01  0.30030E+01  0.37144E+01  0.45376E+01  0.55137E+01
+  0.56189E+01  0.54053E+01  0.52147E+01  0.49408E+01  0.45613E+01  0.39570E+01
+  0.29407E+01  0.19466E+01  0.00000E+00  0.25145E+01  0.68993E+01  0.14260E+02
+  0.26474E+02  0.46736E+02  0.82949E+02  0.14371E+03  0.25527E+03  0.45202E+03
+  0.36369E+00  0.45534E+00  0.57095E+00  0.71678E+00  0.90075E+00  0.11328E+01
+  0.14254E+01  0.17940E+01  0.22567E+01  0.28367E+01  0.35580E+01  0.44445E+01
+  0.55094E+01  0.67599E+01  0.82593E+01  0.10108E+02  0.10250E+02  0.99641E+01
+  0.96571E+01  0.91372E+01  0.82863E+01  0.68835E+01  0.56016E+01  0.30900E+01
+  0.00000E+00  0.53220E+01  0.14081E+02  0.28295E+02  0.51364E+02  0.91992E+02
+  0.15878E+03  0.27995E+03  0.49053E+03  0.53121E+00  0.66382E+00  0.83109E+00
+  0.10420E+01  0.13079E+01  0.16433E+01  0.20660E+01  0.25981E+01  0.32662E+01
+  0.41036E+01  0.51460E+01  0.64305E+01  0.79823E+01  0.98214E+01  0.12042E+02
+  0.14787E+02  0.18002E+02  0.18384E+02  0.17903E+02  0.17288E+02  0.16075E+02
+  0.14047E+02  0.12292E+02  0.88916E+01  0.49050E+01  0.18385E+01  0.12672E+02
+  0.29802E+02  0.56893E+02  0.10377E+03  0.17900E+03  0.31351E+03  0.54316E+03
+  0.76446E+00  0.95312E+00  0.11911E+01  0.14910E+01  0.18691E+01  0.23457E+01
+  0.29462E+01  0.37020E+01  0.46508E+01  0.58398E+01  0.73213E+01  0.91497E+01
+  0.11368E+02  0.14014E+02  0.17223E+02  0.21197E+02  0.25893E+02  0.31684E+02
+  0.32369E+02  0.31383E+02  0.29821E+02  0.26860E+02  0.24325E+02  0.19512E+02
+  0.14114E+02  0.51907E+01  0.87553E+01  0.30172E+02  0.63076E+02  0.11883E+03
+  0.20590E+03  0.35891E+03  0.61477E+03  0.11260E+01  0.14001E+01  0.17457E+01
+  0.21812E+01  0.27302E+01  0.34220E+01  0.42934E+01  0.53902E+01  0.67670E+01
+  0.84932E+01  0.10646E+02  0.13310E+02  0.16556E+02  0.20456E+02  0.25213E+02
+  0.31112E+02  0.38155E+02  0.46869E+02  0.57446E+02  0.58573E+02  0.56186E+02
+  0.52278E+02  0.48732E+02  0.41834E+02  0.34418E+02  0.22406E+02  0.41201E+01
+  0.23165E+02  0.63865E+02  0.13142E+03  0.23391E+03  0.41089E+03  0.70033E+03
+  0.16825E+01  0.20851E+01  0.25926E+01  0.32322E+01  0.40383E+01  0.50541E+01
+  0.63334E+01  0.79435E+01  0.99650E+01  0.12501E+02  0.15667E+02  0.19594E+02
+  0.24401E+02  0.30217E+02  0.37343E+02  0.46202E+02  0.56869E+02  0.70108E+02
+  0.86289E+02  0.10566E+03  0.10692E+03  0.10105E+03  0.96815E+02  0.87024E+02
+  0.76621E+02  0.60096E+02  0.35566E+02  0.00000E+00  0.51479E+02  0.13517E+03
+  0.25828E+03  0.46711E+03  0.80049E+03  0.24727E+01  0.30520E+01  0.37825E+01
+  0.47028E+01  0.58627E+01  0.73238E+01  0.91639E+01  0.11480E+02  0.14388E+02
+  0.18038E+02  0.22598E+02  0.28261E+02  0.35218E+02  0.43677E+02  0.54072E+02
+  0.67010E+02  0.82683E+02  0.10216E+03  0.12605E+03  0.15487E+03  0.18823E+03
+  0.18785E+03  0.18133E+03  0.16832E+03  0.15349E+03  0.12974E+03  0.95398E+02
+  0.47049E+02  0.20764E+02  0.12842E+03  0.28162E+03  0.53615E+03  0.93164E+03
+  0.00000E+00  0.78970E-09  0.25712E-08  0.76194E-08  0.12433E-07  0.31274E-07
+  0.43944E-07  0.85462E-07  0.17070E-06  0.37686E-06  0.77592E-06  0.16230E-05
+  0.61261E-05  0.30861E-04  0.18029E-03  0.47799E-03  0.17634E-02  0.42210E-02
+  0.80808E-02  0.14378E-01  0.23953E-01  0.39544E-01  0.60194E-01  0.92061E-01
+  0.13656E+00  0.20684E+00  0.31584E+00  0.48235E+00  0.73358E+00  0.11310E+01
+  0.17214E+01  0.26643E+01  0.41016E+01  0.78970E-09  0.00000E+00  0.18602E-08
+  0.66789E-08  0.18951E-07  0.31065E-07  0.76590E-07  0.11231E-06  0.22839E-06
+  0.49435E-06  0.10330E-05  0.21151E-05  0.10056E-04  0.63289E-04  0.23069E-03
+  0.60985E-03  0.22455E-02  0.53632E-02  0.10248E-01  0.18204E-01  0.30287E-01
+  0.49941E-01  0.75934E-01  0.11601E+00  0.17191E+00  0.26010E+00  0.39670E+00
+  0.60505E+00  0.91879E+00  0.14140E+01  0.21473E+01  0.33146E+01  0.50863E+01
+  0.25712E-08  0.18602E-08  0.00000E+00  0.51354E-08  0.16829E-07  0.47694E-07
+  0.78041E-07  0.16949E-06  0.31606E-06  0.59864E-06  0.13741E-05  0.25104E-05
+  0.15302E-04  0.10716E-03  0.45737E-03  0.78112E-03  0.28682E-02  0.68315E-02
+  0.13023E-01  0.23087E-01  0.38348E-01  0.63146E-01  0.95899E-01  0.14635E+00
+  0.21662E+00  0.32743E+00  0.49886E+00  0.75996E+00  0.11525E+01  0.17709E+01
+  0.26845E+01  0.41349E+01  0.63282E+01  0.76194E-08  0.66789E-08  0.51354E-08
+  0.00000E+00  0.12228E-07  0.41407E-07  0.11545E-06  0.20395E-06  0.45285E-06
+  0.85932E-06  0.17986E-05  0.38148E-05  0.36482E-04  0.16563E-03  0.76332E-03
+  0.13348E-02  0.36759E-02  0.87254E-02  0.16584E-01  0.29333E-01  0.48626E-01
+  0.79941E-01  0.12124E+00  0.18479E+00  0.27324E+00  0.41255E+00  0.62792E+00
+  0.95558E+00  0.14475E+01  0.22212E+01  0.33620E+01  0.51691E+01  0.78937E+01
+  0.12433E-07  0.18951E-07  0.16829E-07  0.12228E-07  0.00000E+00  0.30733E-07
+  0.10389E-06  0.24923E-06  0.65683E-06  0.12874E-05  0.29889E-05  0.91023E-05
+  0.68079E-04  0.31663E-03  0.11711E-02  0.20788E-02  0.47454E-02  0.11181E-01
+  0.21177E-01  0.37347E-01  0.61768E-01  0.10135E+00  0.15346E+00  0.23359E+00
+  0.34496E+00  0.52029E+00  0.79111E+00  0.12027E+01  0.18199E+01  0.27896E+01
+  0.42168E+01  0.64734E+01  0.98679E+01  0.31274E-07  0.31065E-07  0.47694E-07
+  0.41407E-07  0.30733E-07  0.00000E+00  0.77030E-07  0.27740E-06  0.68638E-06
+  0.20321E-05  0.48293E-05  0.18379E-04  0.12080E-03  0.52342E-03  0.15399E-02
+  0.30675E-02  0.61503E-02  0.13015E-01  0.27121E-01  0.47666E-01  0.78613E-01
+  0.12871E+00  0.19450E+00  0.29559E+00  0.43594E+00  0.65678E+00  0.99761E+00
+  0.15151E+01  0.22904E+01  0.35072E+01  0.52955E+01  0.81189E+01  0.12358E+02
+  0.43944E-07  0.76590E-07  0.78041E-07  0.11545E-06  0.10389E-06  0.77030E-07
+  0.00000E+00  0.20060E-06  0.96127E-06  0.22505E-05  0.89865E-05  0.32898E-04
+  0.17306E-03  0.79818E-03  0.19843E-02  0.37907E-02  0.80060E-02  0.15349E-01
+  0.30004E-01  0.60993E-01  0.10026E+00  0.16372E+00  0.24686E+00  0.37449E+00
+  0.55145E+00  0.82974E+00  0.12589E+01  0.19102E+01  0.28848E+01  0.44132E+01
+  0.66568E+01  0.10195E+02  0.15497E+02  0.85462E-07  0.11231E-06  0.16949E-06
+  0.20395E-06  0.24923E-06  0.27740E-06  0.20060E-06  0.00000E+00  0.61136E-06
+  0.30757E-05  0.11807E-04  0.72258E-04  0.25900E-03  0.10375E-02  0.23841E-02
+  0.46521E-02  0.92775E-02  0.18400E-01  0.33520E-01  0.65264E-01  0.12814E+00
+  0.20863E+00  0.31373E+00  0.47499E+00  0.69822E+00  0.10491E+01  0.15899E+01
+  0.24099E+01  0.36361E+01  0.55576E+01  0.83749E+01  0.12814E+02  0.19458E+02
+  0.17070E-06  0.22839E-06  0.31606E-06  0.45285E-06  0.65683E-06  0.68638E-06
+  0.96127E-06  0.61136E-06  0.00000E+00  0.16979E-05  0.13262E-04  0.95772E-04
+  0.37657E-03  0.12256E-02  0.28002E-02  0.54488E-02  0.10726E-01  0.20419E-01
+  0.38018E-01  0.70105E-01  0.13436E+00  0.26616E+00  0.39906E+00  0.60284E+00
+  0.88446E+00  0.13270E+01  0.20085E+01  0.30412E+01  0.45843E+01  0.70008E+01
+  0.10542E+02  0.16115E+02  0.24448E+02  0.37686E-06  0.49435E-06  0.59864E-06
+  0.85932E-06  0.12874E-05  0.20321E-05  0.22505E-05  0.30757E-05  0.16979E-05
+  0.00000E+00  0.76993E-05  0.10381E-03  0.47347E-03  0.14197E-02  0.31521E-02
+  0.61021E-02  0.11926E-01  0.22638E-01  0.40742E-01  0.76197E-01  0.14088E+00
+  0.27581E+00  0.50815E+00  0.76578E+00  0.11211E+01  0.16793E+01  0.25385E+01
+  0.38395E+01  0.57825E+01  0.88236E+01  0.13276E+02  0.20279E+02  0.30741E+02
+  0.77592E-06  0.10330E-05  0.13741E-05  0.17986E-05  0.29889E-05  0.48293E-05
+  0.89865E-05  0.11807E-04  0.13262E-04  0.76993E-05  0.00000E+00  0.65752E-04
+  0.46038E-03  0.14915E-02  0.34204E-02  0.65789E-02  0.12734E-01  0.24136E-01
+  0.43490E-01  0.79391E-01  0.14860E+00  0.28456E+00  0.52154E+00  0.97242E+00
+  0.14205E+01  0.21243E+01  0.32074E+01  0.48463E+01  0.72921E+01  0.11119E+02
+  0.16718E+02  0.25523E+02  0.38663E+02  0.16230E-05  0.21151E-05  0.25104E-05
+  0.38148E-05  0.91023E-05  0.18379E-04  0.32898E-04  0.72258E-04  0.95772E-04
+  0.10381E-03  0.65752E-04  0.00000E+00  0.30899E-03  0.13656E-02  0.34969E-02
+  0.69197E-02  0.13357E-01  0.24818E-01  0.44889E-01  0.82158E-01  0.15217E+00
+  0.29396E+00  0.53089E+00  0.99371E+00  0.17965E+01  0.26832E+01  0.40472E+01
+  0.61103E+01  0.91880E+01  0.14003E+02  0.21043E+02  0.32110E+02  0.48619E+02
+  0.61261E-05  0.10056E-04  0.15302E-04  0.36482E-04  0.68079E-04  0.12080E-03
+  0.17306E-03  0.25900E-03  0.37657E-03  0.47347E-03  0.46038E-03  0.30899E-03
+  0.00000E+00  0.97580E-03  0.31128E-02  0.66805E-02  0.13635E-01  0.25054E-01
+  0.45781E-01  0.82654E-01  0.15420E+00  0.29598E+00  0.53776E+00  0.10039E+01
+  0.18231E+01  0.33752E+01  0.50899E+01  0.76831E+01  0.11550E+02  0.17602E+02
+  0.26446E+02  0.40353E+02  0.61088E+02  0.30861E-04  0.63289E-04  0.10716E-03
+  0.16563E-03  0.31663E-03  0.52342E-03  0.79818E-03  0.10375E-02  0.12256E-02
+  0.14197E-02  0.14915E-02  0.13656E-02  0.97580E-03  0.00000E+00  0.20237E-02
+  0.54875E-02  0.12467E-01  0.24436E-01  0.44331E-01  0.82171E-01  0.15379E+00
+  0.29416E+00  0.53249E+00  0.10082E+01  0.18270E+01  0.34047E+01  0.63728E+01
+  0.96257E+01  0.14476E+02  0.22074E+02  0.33171E+02  0.50629E+02  0.76655E+02
+  0.18029E-03  0.23069E-03  0.45737E-03  0.76332E-03  0.11711E-02  0.15399E-02
+  0.19843E-02  0.23841E-02  0.28002E-02  0.31521E-02  0.34204E-02  0.34969E-02
+  0.31128E-02  0.20237E-02  0.00000E+00  0.34754E-02  0.10191E-01  0.21916E-01
+  0.42021E-01  0.78811E-01  0.15001E+00  0.29178E+00  0.52611E+00  0.10002E+01
+  0.18352E+01  0.34157E+01  0.64364E+01  0.12064E+02  0.18151E+02  0.27690E+02
+  0.41618E+02  0.63543E+02  0.96223E+02  0.47799E-03  0.60985E-03  0.78112E-03
+  0.13348E-02  0.20788E-02  0.30675E-02  0.37907E-02  0.46521E-02  0.54488E-02
+  0.61021E-02  0.65789E-02  0.69197E-02  0.66805E-02  0.54875E-02  0.34754E-02
+  0.00000E+00  0.70356E-02  0.18484E-01  0.38516E-01  0.75249E-01  0.14676E+00
+  0.28989E+00  0.52370E+00  0.99919E+00  0.18338E+01  0.34552E+01  0.64963E+01
+  0.12245E+02  0.22839E+02  0.34839E+02  0.52345E+02  0.79913E+02  0.12099E+03
+  0.17634E-02  0.22455E-02  0.28682E-02  0.36759E-02  0.47454E-02  0.61503E-02
+  0.80060E-02  0.92775E-02  0.10726E-01  0.11926E-01  0.12734E-01  0.13357E-01
+  0.13635E-01  0.12467E-01  0.10191E-01  0.70356E-02  0.00000E+00  0.11192E-01
+  0.30808E-01  0.67051E-01  0.13846E+00  0.28262E+00  0.51496E+00  0.99118E+00
+  0.18228E+01  0.34434E+01  0.65602E+01  0.12342E+02  0.23153E+02  0.43807E+02
+  0.65804E+02  0.10046E+03  0.15208E+03  0.42210E-02  0.53632E-02  0.68315E-02
+  0.87254E-02  0.11181E-01  0.13015E-01  0.15349E-01  0.18400E-01  0.20419E-01
+  0.22638E-01  0.24136E-01  0.24818E-01  0.25054E-01  0.24436E-01  0.21916E-01
+  0.18484E-01  0.11192E-01  0.00000E+00  0.19544E-01  0.55889E-01  0.12836E+00
+  0.27582E+00  0.50927E+00  0.99138E+00  0.18272E+01  0.34573E+01  0.65932E+01
+  0.12548E+02  0.23460E+02  0.44613E+02  0.83031E+02  0.12669E+03  0.19166E+03
+  0.80808E-02  0.10248E-01  0.13023E-01  0.16584E-01  0.21177E-01  0.27121E-01
+  0.30004E-01  0.33520E-01  0.38018E-01  0.40742E-01  0.43490E-01  0.44889E-01
+  0.45781E-01  0.44331E-01  0.42021E-01  0.38516E-01  0.30808E-01  0.19544E-01
+  0.00000E+00  0.36661E-01  0.11090E+00  0.26339E+00  0.49941E+00  0.99127E+00
+  0.18360E+01  0.34846E+01  0.66514E+01  0.12658E+02  0.23916E+02  0.45321E+02
+  0.84701E+02  0.16011E+03  0.24197E+03  0.14378E-01  0.18204E-01  0.23087E-01
+  0.29333E-01  0.37347E-01  0.47666E-01  0.60993E-01  0.65264E-01  0.70105E-01
+  0.76197E-01  0.79391E-01  0.82158E-01  0.82654E-01  0.82171E-01  0.78811E-01
+  0.75249E-01  0.67051E-01  0.55889E-01  0.36661E-01  0.00000E+00  0.76100E-01
+  0.23471E+00  0.47331E+00  0.97734E+00  0.18332E+01  0.35061E+01  0.67144E+01
+  0.12783E+02  0.24140E+02  0.46244E+02  0.86070E+02  0.16342E+03  0.30588E+03
+  0.23953E-01  0.30287E-01  0.38348E-01  0.48626E-01  0.61768E-01  0.78613E-01
+  0.10026E+00  0.12814E+00  0.13436E+00  0.14088E+00  0.14860E+00  0.15217E+00
+  0.15420E+00  0.15379E+00  0.15001E+00  0.14676E+00  0.13846E+00  0.12836E+00
+  0.11090E+00  0.76100E-01  0.00000E+00  0.16344E+00  0.40054E+00  0.91414E+00
+  0.17755E+01  0.34678E+01  0.67134E+01  0.12841E+02  0.24277E+02  0.46546E+02
+  0.87577E+02  0.16575E+03  0.31170E+03  0.39544E-01  0.49941E-01  0.63146E-01
+  0.79941E-01  0.10135E+00  0.12871E+00  0.16372E+00  0.20863E+00  0.26616E+00
+  0.27581E+00  0.28456E+00  0.29396E+00  0.29598E+00  0.29416E+00  0.29178E+00
+  0.28989E+00  0.28262E+00  0.27582E+00  0.26339E+00  0.23471E+00  0.16344E+00
+  0.00000E+00  0.22561E+00  0.73932E+00  0.15903E+01  0.32837E+01  0.65442E+01
+  0.12700E+02  0.24171E+02  0.46529E+02  0.87663E+02  0.16801E+03  0.31510E+03
+  0.60194E-01  0.75934E-01  0.95899E-01  0.12124E+00  0.15346E+00  0.19450E+00
+  0.24686E+00  0.31373E+00  0.39906E+00  0.50815E+00  0.52154E+00  0.53089E+00
+  0.53776E+00  0.53249E+00  0.52611E+00  0.52370E+00  0.51496E+00  0.50927E+00
+  0.49941E+00  0.47331E+00  0.40054E+00  0.22561E+00  0.00000E+00  0.53719E+00
+  0.14083E+01  0.31555E+01  0.65157E+01  0.12833E+02  0.24543E+02  0.47321E+02
+  0.89012E+02  0.17039E+03  0.32263E+03  0.92061E-01  0.11601E+00  0.14635E+00
+  0.18479E+00  0.23359E+00  0.29559E+00  0.37449E+00  0.47499E+00  0.60284E+00
+  0.76578E+00  0.97242E+00  0.99371E+00  0.10039E+01  0.10082E+01  0.10002E+01
+  0.99919E+00  0.99118E+00  0.99138E+00  0.99127E+00  0.97734E+00  0.91414E+00
+  0.73932E+00  0.53719E+00  0.00000E+00  0.85274E+00  0.26082E+01  0.60108E+01
+  0.12412E+02  0.24251E+02  0.47307E+02  0.89328E+02  0.17136E+03  0.32458E+03
+  0.13656E+00  0.17191E+00  0.21662E+00  0.27324E+00  0.34496E+00  0.43594E+00
+  0.55145E+00  0.69822E+00  0.88446E+00  0.11211E+01  0.14205E+01  0.17965E+01
+  0.18231E+01  0.18270E+01  0.18352E+01  0.18338E+01  0.18228E+01  0.18272E+01
+  0.18360E+01  0.18332E+01  0.17755E+01  0.15903E+01  0.14083E+01  0.85274E+00
+  0.00000E+00  0.18049E+01  0.53231E+01  0.11927E+02  0.24081E+02  0.47734E+02
+  0.90556E+02  0.17402E+03  0.32928E+03  0.20684E+00  0.26010E+00  0.32743E+00
+  0.41255E+00  0.52029E+00  0.65678E+00  0.82974E+00  0.10491E+01  0.13270E+01
+  0.16793E+01  0.21243E+01  0.26832E+01  0.33752E+01  0.34047E+01  0.34157E+01
+  0.34552E+01  0.34434E+01  0.34573E+01  0.34846E+01  0.35061E+01  0.34678E+01
+  0.32837E+01  0.31555E+01  0.26082E+01  0.18049E+01  0.00000E+00  0.35813E+01
+  0.10328E+02  0.22720E+02  0.46913E+02  0.90439E+02  0.17530E+03  0.33252E+03
+  0.31584E+00  0.39670E+00  0.49886E+00  0.62792E+00  0.79111E+00  0.99761E+00
+  0.12589E+01  0.15899E+01  0.20085E+01  0.25385E+01  0.32074E+01  0.40472E+01
+  0.50899E+01  0.63728E+01  0.64364E+01  0.64963E+01  0.65602E+01  0.65932E+01
+  0.66514E+01  0.67144E+01  0.67134E+01  0.65442E+01  0.65157E+01  0.60108E+01
+  0.53231E+01  0.35813E+01  0.00000E+00  0.68219E+01  0.19375E+02  0.44079E+02
+  0.88260E+02  0.17460E+03  0.33393E+03  0.48235E+00  0.60505E+00  0.75996E+00
+  0.95558E+00  0.12027E+01  0.15151E+01  0.19102E+01  0.24099E+01  0.30412E+01
+  0.38395E+01  0.48463E+01  0.61103E+01  0.76831E+01  0.96257E+01  0.12064E+02
+  0.12245E+02  0.12342E+02  0.12548E+02  0.12658E+02  0.12783E+02  0.12841E+02
+  0.12700E+02  0.12833E+02  0.12412E+02  0.11927E+02  0.10328E+02  0.68219E+01
+  0.00000E+00  0.12634E+02  0.37853E+02  0.82693E+02  0.17075E+03  0.33260E+03
+  0.73358E+00  0.91879E+00  0.11525E+01  0.14475E+01  0.18199E+01  0.22904E+01
+  0.28848E+01  0.36361E+01  0.45843E+01  0.57825E+01  0.72921E+01  0.91880E+01
+  0.11550E+02  0.14476E+02  0.18151E+02  0.22839E+02  0.23153E+02  0.23460E+02
+  0.23916E+02  0.24140E+02  0.24277E+02  0.24171E+02  0.24543E+02  0.24251E+02
+  0.24081E+02  0.22720E+02  0.19375E+02  0.12634E+02  0.00000E+00  0.25786E+02
+  0.71356E+02  0.16156E+03  0.32666E+03  0.11310E+01  0.14140E+01  0.17709E+01
+  0.22212E+01  0.27896E+01  0.35072E+01  0.44132E+01  0.55576E+01  0.70008E+01
+  0.88236E+01  0.11119E+02  0.14003E+02  0.17602E+02  0.22074E+02  0.27690E+02
+  0.34839E+02  0.43807E+02  0.44613E+02  0.45321E+02  0.46244E+02  0.46546E+02
+  0.46529E+02  0.47321E+02  0.47307E+02  0.47734E+02  0.46913E+02  0.44079E+02
+  0.37853E+02  0.25786E+02  0.00000E+00  0.45479E+02  0.13711E+03  0.30455E+03
+  0.17214E+01  0.21473E+01  0.26845E+01  0.33620E+01  0.42168E+01  0.52955E+01
+  0.66568E+01  0.83749E+01  0.10542E+02  0.13276E+02  0.16718E+02  0.21043E+02
+  0.26446E+02  0.33171E+02  0.41618E+02  0.52345E+02  0.65804E+02  0.83031E+02
+  0.84701E+02  0.86070E+02  0.87577E+02  0.87663E+02  0.89012E+02  0.89328E+02
+  0.90556E+02  0.90439E+02  0.88260E+02  0.82693E+02  0.71356E+02  0.45479E+02
+  0.00000E+00  0.93850E+02  0.26497E+03  0.26643E+01  0.33146E+01  0.41349E+01
+  0.51691E+01  0.64734E+01  0.81189E+01  0.10195E+02  0.12814E+02  0.16115E+02
+  0.20279E+02  0.25523E+02  0.32110E+02  0.40353E+02  0.50629E+02  0.63543E+02
+  0.79913E+02  0.10046E+03  0.12669E+03  0.16011E+03  0.16342E+03  0.16575E+03
+  0.16801E+03  0.17039E+03  0.17136E+03  0.17402E+03  0.17530E+03  0.17460E+03
+  0.17075E+03  0.16156E+03  0.13711E+03  0.93850E+02  0.00000E+00  0.17190E+03
+  0.41016E+01  0.50863E+01  0.63282E+01  0.78937E+01  0.98679E+01  0.12358E+02
+  0.15497E+02  0.19458E+02  0.24448E+02  0.30741E+02  0.38663E+02  0.48619E+02
+  0.61088E+02  0.76655E+02  0.96223E+02  0.12099E+03  0.15208E+03  0.19166E+03
+  0.24197E+03  0.30588E+03  0.31170E+03  0.31510E+03  0.32263E+03  0.32458E+03
+  0.32928E+03  0.33252E+03  0.33393E+03  0.33260E+03  0.32666E+03  0.30455E+03
+  0.26497E+03  0.17190E+03  0.00000E+00
diff --git a/wrfv2_fire/run/kernels_z.asc b/wrfv2_fire/run/kernels_z.asc
new file mode 100644
index 00000000..4d6615f7
--- /dev/null
+++ b/wrfv2_fire/run/kernels_z.asc
@@ -0,0 +1,545 @@
+  0.00000E+00  0.27000E-09  0.17200E-08  0.40100E-08  0.80800E-08  0.15400E-07
+  0.27400E-07  0.46500E-07  0.75100E-07  0.12300E-06  0.19000E-06  0.35900E-06
+  0.85600E-06  0.24000E-05  0.64100E-05  0.13100E-04  0.25200E-04  0.45800E-04
+  0.96800E-04  0.26700E-03  0.20000E-02  0.47500E+00  0.95600E+00  0.19100E+01
+  0.37400E+01  0.70600E+01  0.13100E+02  0.24000E+02  0.43300E+02  0.76000E+02
+  0.12900E+03  0.21000E+03  0.33300E+03  0.27000E-09  0.00000E+00  0.74200E-09
+  0.43500E-08  0.98900E-08  0.20100E-07  0.37200E-07  0.64400E-07  0.10700E-06
+  0.17800E-06  0.29400E-06  0.55700E-06  0.14400E-05  0.50900E-05  0.19700E-04
+  0.90900E-04  0.40000E-03  0.13500E-02  0.39500E-02  0.10800E-01  0.29800E-01
+  0.47700E+00  0.95900E+00  0.19100E+01  0.37500E+01  0.70700E+01  0.13100E+02
+  0.24000E+02  0.43300E+02  0.76000E+02  0.12900E+03  0.21000E+03  0.33300E+03
+  0.17200E-08  0.74200E-09  0.00000E+00  0.29700E-08  0.11100E-07  0.25200E-07
+  0.49400E-07  0.88100E-07  0.15100E-06  0.25500E-06  0.44700E-06  0.89500E-06
+  0.26300E-05  0.14100E-04  0.79400E-04  0.32700E-03  0.11700E-02  0.34900E-02
+  0.95200E-02  0.24700E-01  0.64000E-01  0.47900E+00  0.96300E+00  0.19200E+01
+  0.37600E+01  0.70800E+01  0.13100E+02  0.24100E+02  0.43400E+02  0.76100E+02
+  0.12900E+03  0.21000E+03  0.33400E+03  0.40100E-08  0.43500E-08  0.29700E-08
+  0.00000E+00  0.94300E-08  0.28100E-07  0.62100E-07  0.11700E-06  0.21000E-06
+  0.37000E-06  0.70600E-06  0.16100E-05  0.57600E-05  0.45600E-04  0.30900E-03
+  0.11200E-02  0.31500E-02  0.79300E-02  0.18900E-01  0.44000E-01  0.10300E+00
+  0.48200E+00  0.96700E+00  0.19300E+01  0.37700E+01  0.71000E+01  0.13200E+02
+  0.24100E+02  0.43400E+02  0.76200E+02  0.12900E+03  0.21000E+03  0.33400E+03
+  0.80800E-08  0.98900E-08  0.11100E-07  0.94300E-08  0.00000E+00  0.22500E-07
+  0.67200E-07  0.14300E-06  0.28000E-06  0.57200E-06  0.13300E-05  0.43100E-05
+  0.27300E-04  0.17800E-03  0.71800E-03  0.21000E-02  0.53100E-02  0.12500E-01
+  0.28200E-01  0.62500E-01  0.13900E+00  0.48500E+00  0.97300E+00  0.19400E+01
+  0.37900E+01  0.71200E+01  0.13200E+02  0.24100E+02  0.43500E+02  0.76300E+02
+  0.12900E+03  0.21000E+03  0.33400E+03  0.15400E-07  0.20100E-07  0.25200E-07
+  0.28100E-07  0.22500E-07  0.00000E+00  0.57300E-07  0.15500E-06  0.35700E-06
+  0.88400E-06  0.29600E-05  0.15900E-04  0.86200E-04  0.36100E-03  0.11700E-02
+  0.30900E-02  0.74000E-02  0.16700E-01  0.36600E-01  0.78900E-01  0.16900E+00
+  0.49000E+00  0.98000E+00  0.19500E+01  0.38000E+01  0.71500E+01  0.13200E+02
+  0.24200E+02  0.43600E+02  0.76400E+02  0.12900E+03  0.21000E+03  0.33400E+03
+  0.27400E-07  0.37200E-07  0.49400E-07  0.62100E-07  0.67200E-07  0.57300E-07
+  0.00000E+00  0.12600E-06  0.38900E-06  0.12700E-05  0.68300E-05  0.39500E-04
+  0.16600E-03  0.57100E-03  0.16400E-02  0.40700E-02  0.93500E-02  0.20600E-01
+  0.44100E-01  0.92900E-01  0.19600E+00  0.49500E+00  0.98900E+00  0.19600E+01
+  0.38300E+01  0.71800E+01  0.13300E+02  0.24300E+02  0.43700E+02  0.76500E+02
+  0.12900E+03  0.21000E+03  0.33400E+03  0.46500E-07  0.64400E-07  0.88100E-07
+  0.11700E-06  0.14300E-06  0.15500E-06  0.12600E-06  0.00000E+00  0.30600E-06
+  0.14100E-05  0.11800E-04  0.67300E-04  0.25200E-03  0.77900E-03  0.20800E-02
+  0.49500E-02  0.11100E-01  0.23900E-01  0.50300E-01  0.10500E+00  0.21600E+00
+  0.50200E+00  0.10000E+01  0.19800E+01  0.38500E+01  0.72200E+01  0.13300E+02
+  0.24400E+02  0.43800E+02  0.76600E+02  0.12900E+03  0.21100E+03  0.33500E+03
+  0.75100E-07  0.10700E-06  0.15100E-06  0.21000E-06  0.28000E-06  0.35700E-06
+  0.38900E-06  0.30600E-06  0.00000E+00  0.91900E-06  0.12900E-04  0.89000E-04
+  0.33100E-03  0.97500E-03  0.24800E-02  0.57400E-02  0.12600E-01  0.26700E-01
+  0.55600E-01  0.11400E+00  0.23200E+00  0.51000E+00  0.10100E+01  0.20000E+01
+  0.38800E+01  0.72600E+01  0.13400E+02  0.24500E+02  0.43900E+02  0.76800E+02
+  0.13000E+03  0.21100E+03  0.33500E+03  0.12300E-06  0.17800E-06  0.25500E-06
+  0.37000E-06  0.57200E-06  0.88400E-06  0.12700E-05  0.14100E-05  0.91900E-06
+  0.00000E+00  0.58200E-05  0.90300E-04  0.38600E-03  0.11400E-02  0.28400E-02
+  0.64500E-02  0.14000E-01  0.29200E-01  0.60100E-01  0.12200E+00  0.24600E+00
+  0.52000E+00  0.10300E+01  0.20200E+01  0.39200E+01  0.73200E+01  0.13500E+02
+  0.24600E+02  0.44100E+02  0.77000E+02  0.13000E+03  0.21100E+03  0.33500E+03
+  0.19000E-06  0.29400E-06  0.44700E-06  0.70600E-06  0.13300E-05  0.29600E-05
+  0.68300E-05  0.11800E-04  0.12900E-04  0.58200E-05  0.00000E+00  0.50100E-04
+  0.37800E-03  0.12300E-02  0.31200E-02  0.70600E-02  0.15200E-01  0.31600E-01
+  0.64300E-01  0.12900E+00  0.25900E+00  0.53200E+00  0.10500E+01  0.20500E+01
+  0.39700E+01  0.73900E+01  0.13600E+02  0.24700E+02  0.44300E+02  0.77300E+02
+  0.13000E+03  0.21200E+03  0.33500E+03  0.35900E-06  0.55700E-06  0.89500E-06
+  0.16100E-05  0.43100E-05  0.15900E-04  0.39500E-04  0.67300E-04  0.89000E-04
+  0.90300E-04  0.50100E-04  0.00000E+00  0.24600E-03  0.11700E-02  0.32300E-02
+  0.75100E-02  0.16200E-01  0.33600E-01  0.68100E-01  0.13600E+00  0.27000E+00
+  0.54500E+00  0.10700E+01  0.20900E+01  0.40200E+01  0.74600E+01  0.13700E+02
+  0.24800E+02  0.44500E+02  0.77500E+02  0.13000E+03  0.21200E+03  0.33500E+03
+  0.85600E-06  0.14400E-05  0.26300E-05  0.57600E-05  0.27300E-04  0.86200E-04
+  0.16600E-03  0.25200E-03  0.33100E-03  0.38600E-03  0.37800E-03  0.24600E-03
+  0.00000E+00  0.10400E-02  0.32900E-02  0.79800E-02  0.17500E-01  0.36300E-01
+  0.73400E-01  0.14600E+00  0.28600E+00  0.56000E+00  0.10900E+01  0.21300E+01
+  0.40800E+01  0.75500E+01  0.13800E+02  0.25000E+02  0.44700E+02  0.77800E+02
+  0.13100E+03  0.21200E+03  0.33500E+03  0.24000E-05  0.50900E-05  0.14100E-04
+  0.45600E-04  0.17800E-03  0.36100E-03  0.57100E-03  0.77900E-03  0.97500E-03
+  0.11400E-02  0.12300E-02  0.11700E-02  0.10400E-02  0.00000E+00  0.23400E-02
+  0.72700E-02  0.17300E-01  0.37000E-01  0.75600E-01  0.15000E+00  0.29500E+00
+  0.57500E+00  0.11200E+01  0.21700E+01  0.41500E+01  0.76400E+01  0.13900E+02
+  0.25200E+02  0.44900E+02  0.78000E+02  0.13100E+03  0.21200E+03  0.33500E+03
+  0.64100E-05  0.19700E-04  0.79400E-04  0.30900E-03  0.71800E-03  0.11700E-02
+  0.16400E-02  0.20800E-02  0.24800E-02  0.28400E-02  0.31200E-02  0.32300E-02
+  0.32900E-02  0.23400E-02  0.00000E+00  0.50900E-02  0.15500E-01  0.36100E-01
+  0.76300E-01  0.15400E+00  0.30300E+00  0.59000E+00  0.11400E+01  0.22100E+01
+  0.42200E+01  0.77400E+01  0.14100E+02  0.25400E+02  0.45100E+02  0.78200E+02
+  0.13100E+03  0.21200E+03  0.33400E+03  0.13100E-04  0.90900E-04  0.32700E-03
+  0.11200E-02  0.21000E-02  0.30900E-02  0.40700E-02  0.49500E-02  0.57400E-02
+  0.64500E-02  0.70600E-02  0.75100E-02  0.79800E-02  0.72700E-02  0.50900E-02
+  0.60000E-03  0.10700E-01  0.32100E-01  0.73700E-01  0.15400E+00  0.30700E+00
+  0.60200E+00  0.11700E+01  0.22500E+01  0.42900E+01  0.78500E+01  0.14200E+02
+  0.25500E+02  0.45300E+02  0.78300E+02  0.13100E+03  0.21100E+03  0.33200E+03
+  0.25200E-04  0.40000E-03  0.11700E-02  0.31500E-02  0.53100E-02  0.74000E-02
+  0.93500E-02  0.11100E-01  0.12600E-01  0.14000E-01  0.15200E-01  0.16200E-01
+  0.17500E-01  0.17300E-01  0.15500E-01  0.10700E-01  0.13000E-02  0.21900E-01
+  0.64800E-01  0.14700E+00  0.30600E+00  0.60900E+00  0.11900E+01  0.23000E+01
+  0.43600E+01  0.79500E+01  0.14300E+02  0.25700E+02  0.45400E+02  0.78400E+02
+  0.13100E+03  0.21000E+03  0.33000E+03  0.45800E-04  0.13500E-02  0.34900E-02
+  0.79300E-02  0.12500E-01  0.16700E-01  0.20600E-01  0.23900E-01  0.26700E-01
+  0.29200E-01  0.31600E-01  0.33600E-01  0.36300E-01  0.37000E-01  0.36100E-01
+  0.32100E-01  0.21900E-01  0.20000E-02  0.43700E-01  0.12900E+00  0.29100E+00
+  0.60300E+00  0.12000E+01  0.23300E+01  0.44300E+01  0.80500E+01  0.14500E+02
+  0.25800E+02  0.45600E+02  0.78400E+02  0.13000E+03  0.20900E+03  0.32700E+03
+  0.96800E-04  0.39500E-02  0.95200E-02  0.18900E-01  0.28200E-01  0.36600E-01
+  0.44100E-01  0.50300E-01  0.55600E-01  0.60100E-01  0.64300E-01  0.68100E-01
+  0.73400E-01  0.75600E-01  0.76300E-01  0.73700E-01  0.64800E-01  0.43700E-01
+  0.60000E-02  0.86300E-01  0.25300E+00  0.57300E+00  0.11800E+01  0.23400E+01
+  0.44700E+01  0.81300E+01  0.14600E+02  0.26000E+02  0.45600E+02  0.78200E+02
+  0.12900E+03  0.20700E+03  0.32300E+03  0.26700E-03  0.10800E-01  0.24700E-01
+  0.44000E-01  0.62500E-01  0.78900E-01  0.92900E-01  0.10500E+00  0.11400E+00
+  0.12200E+00  0.12900E+00  0.13600E+00  0.14600E+00  0.15000E+00  0.15400E+00
+  0.15400E+00  0.14700E+00  0.12900E+00  0.86300E-01  0.10000E-01  0.16900E+00
+  0.49700E+00  0.11200E+01  0.23100E+01  0.44800E+01  0.81700E+01  0.14600E+02
+  0.26000E+02  0.45600E+02  0.77900E+02  0.12800E+03  0.20400E+03  0.31700E+03
+  0.20000E-02  0.29800E-01  0.64000E-01  0.10300E+00  0.13900E+00  0.16900E+00
+  0.19600E+00  0.21600E+00  0.23200E+00  0.24600E+00  0.25900E+00  0.27000E+00
+  0.28600E+00  0.29500E+00  0.30300E+00  0.30700E+00  0.30600E+00  0.29100E+00
+  0.25300E+00  0.16900E+00  0.25000E-01  0.33200E+00  0.97300E+00  0.21900E+01
+  0.44100E+01  0.81300E+01  0.14600E+02  0.26000E+02  0.45500E+02  0.77400E+02
+  0.12700E+03  0.20000E+03  0.31000E+03  0.47500E+00  0.47700E+00  0.47900E+00
+  0.48200E+00  0.48500E+00  0.49000E+00  0.49500E+00  0.50200E+00  0.51000E+00
+  0.52000E+00  0.53200E+00  0.54500E+00  0.56000E+00  0.57500E+00  0.59000E+00
+  0.60200E+00  0.60900E+00  0.60300E+00  0.57300E+00  0.49700E+00  0.33200E+00
+  0.55000E-01  0.65100E+00  0.18900E+01  0.41500E+01  0.78900E+01  0.14400E+02
+  0.25700E+02  0.45000E+02  0.76300E+02  0.12500E+03  0.19500E+03  0.30000E+03
+  0.95600E+00  0.95900E+00  0.96300E+00  0.96700E+00  0.97300E+00  0.98000E+00
+  0.98900E+00  0.10000E+01  0.10100E+01  0.10300E+01  0.10500E+01  0.10700E+01
+  0.10900E+01  0.11200E+01  0.11400E+01  0.11700E+01  0.11900E+01  0.12000E+01
+  0.11800E+01  0.11200E+01  0.97300E+00  0.65100E+00  0.14000E+00  0.12600E+01
+  0.35500E+01  0.72800E+01  0.13700E+02  0.24900E+02  0.43900E+02  0.74400E+02
+  0.12100E+03  0.18800E+03  0.28600E+03  0.19100E+01  0.19100E+01  0.19200E+01
+  0.19300E+01  0.19400E+01  0.19500E+01  0.19600E+01  0.19800E+01  0.20000E+01
+  0.20200E+01  0.20500E+01  0.20900E+01  0.21300E+01  0.21700E+01  0.22100E+01
+  0.22500E+01  0.23000E+01  0.23300E+01  0.23400E+01  0.23100E+01  0.21900E+01
+  0.18900E+01  0.12600E+01  0.40000E+00  0.23000E+01  0.59800E+01  0.12300E+02
+  0.23300E+02  0.41700E+02  0.71200E+02  0.11500E+03  0.17800E+03  0.26800E+03
+  0.37400E+01  0.37500E+01  0.37600E+01  0.37700E+01  0.37900E+01  0.38000E+01
+  0.38300E+01  0.38500E+01  0.38800E+01  0.39200E+01  0.39700E+01  0.40200E+01
+  0.40800E+01  0.41500E+01  0.42200E+01  0.42900E+01  0.43600E+01  0.44300E+01
+  0.44700E+01  0.44800E+01  0.44100E+01  0.41500E+01  0.35500E+01  0.23000E+01
+  0.20000E+01  0.35900E+01  0.97300E+01  0.20400E+02  0.38200E+02  0.66300E+02
+  0.10800E+03  0.16500E+03  0.24500E+03  0.70600E+01  0.70700E+01  0.70800E+01
+  0.71000E+01  0.71200E+01  0.71500E+01  0.71800E+01  0.72200E+01  0.72600E+01
+  0.73200E+01  0.73900E+01  0.74600E+01  0.75500E+01  0.76400E+01  0.77400E+01
+  0.78500E+01  0.79500E+01  0.80500E+01  0.81300E+01  0.81700E+01  0.81300E+01
+  0.78900E+01  0.72800E+01  0.59800E+01  0.35900E+01  0.40000E+01  0.60900E+01
+  0.16600E+02  0.34000E+02  0.61000E+02  0.99700E+02  0.15200E+03  0.22200E+03
+  0.13100E+02  0.13100E+02  0.13100E+02  0.13200E+02  0.13200E+02  0.13200E+02
+  0.13300E+02  0.13300E+02  0.13400E+02  0.13500E+02  0.13600E+02  0.13700E+02
+  0.13800E+02  0.13900E+02  0.14100E+02  0.14200E+02  0.14300E+02  0.14500E+02
+  0.14600E+02  0.14600E+02  0.14600E+02  0.14400E+02  0.13700E+02  0.12300E+02
+  0.97300E+01  0.60900E+01  0.55000E+01  0.10400E+02  0.27500E+02  0.53300E+02
+  0.89000E+02  0.13500E+03  0.19500E+03  0.24000E+02  0.24000E+02  0.24100E+02
+  0.24100E+02  0.24100E+02  0.24200E+02  0.24300E+02  0.24400E+02  0.24500E+02
+  0.24600E+02  0.24700E+02  0.24800E+02  0.25000E+02  0.25200E+02  0.25400E+02
+  0.25500E+02  0.25700E+02  0.25800E+02  0.26000E+02  0.26000E+02  0.26000E+02
+  0.25700E+02  0.24900E+02  0.23300E+02  0.20400E+02  0.16600E+02  0.10400E+02
+  0.80000E+01  0.16700E+02  0.41200E+02  0.73500E+02  0.11200E+03  0.15900E+03
+  0.43300E+02  0.43300E+02  0.43400E+02  0.43400E+02  0.43500E+02  0.43600E+02
+  0.43700E+02  0.43800E+02  0.43900E+02  0.44100E+02  0.44300E+02  0.44500E+02
+  0.44700E+02  0.44900E+02  0.45100E+02  0.45300E+02  0.45400E+02  0.45600E+02
+  0.45600E+02  0.45600E+02  0.45500E+02  0.45000E+02  0.43900E+02  0.41700E+02
+  0.38200E+02  0.34000E+02  0.27500E+02  0.16700E+02  0.12000E+02  0.23400E+02
+  0.51900E+02  0.82300E+02  0.11500E+03  0.76000E+02  0.76000E+02  0.76100E+02
+  0.76200E+02  0.76300E+02  0.76400E+02  0.76500E+02  0.76600E+02  0.76800E+02
+  0.77000E+02  0.77300E+02  0.77500E+02  0.77800E+02  0.78000E+02  0.78200E+02
+  0.78300E+02  0.78400E+02  0.78400E+02  0.78200E+02  0.77900E+02  0.77400E+02
+  0.76300E+02  0.74400E+02  0.71200E+02  0.66300E+02  0.61000E+02  0.53300E+02
+  0.41200E+02  0.23400E+02  0.14000E+02  0.25800E+02  0.48600E+02  0.66800E+02
+  0.12900E+03  0.12900E+03  0.12900E+03  0.12900E+03  0.12900E+03  0.12900E+03
+  0.12900E+03  0.12900E+03  0.13000E+03  0.13000E+03  0.13000E+03  0.13000E+03
+  0.13100E+03  0.13100E+03  0.13100E+03  0.13100E+03  0.13100E+03  0.13000E+03
+  0.12900E+03  0.12800E+03  0.12700E+03  0.12500E+03  0.12100E+03  0.11500E+03
+  0.10800E+03  0.99700E+02  0.89000E+02  0.73500E+02  0.51900E+02  0.25800E+02
+  0.15000E+02  0.17900E+02  0.25300E+02  0.21000E+03  0.21000E+03  0.21000E+03
+  0.21000E+03  0.21000E+03  0.21000E+03  0.21000E+03  0.21100E+03  0.21100E+03
+  0.21100E+03  0.21200E+03  0.21200E+03  0.21200E+03  0.21200E+03  0.21200E+03
+  0.21100E+03  0.21000E+03  0.20900E+03  0.20700E+03  0.20400E+03  0.20000E+03
+  0.19500E+03  0.18800E+03  0.17800E+03  0.16500E+03  0.15200E+03  0.13500E+03
+  0.11200E+03  0.82300E+02  0.48600E+02  0.17900E+02  0.16000E+02  0.22000E+01
+  0.33300E+03  0.33300E+03  0.33400E+03  0.33400E+03  0.33400E+03  0.33400E+03
+  0.33400E+03  0.33500E+03  0.33500E+03  0.33500E+03  0.33500E+03  0.33500E+03
+  0.33500E+03  0.33500E+03  0.33400E+03  0.33200E+03  0.33000E+03  0.32700E+03
+  0.32300E+03  0.31700E+03  0.31000E+03  0.30000E+03  0.28600E+03  0.26800E+03
+  0.24500E+03  0.22200E+03  0.19500E+03  0.15900E+03  0.11500E+03  0.66800E+02
+  0.25300E+02  0.22000E+01  0.17000E+02  0.00000E+00  0.27000E-09  0.17100E-08
+  0.39100E-08  0.80800E-08  0.15200E-07  0.26400E-07  0.44700E-07  0.72500E-07
+  0.11500E-06  0.19000E-06  0.32800E-06  0.78100E-06  0.24000E-05  0.64500E-05
+  0.14100E-04  0.27500E-04  0.55500E-04  0.13400E-03  0.54300E-03  0.66900E-02
+  0.47500E+00  0.95600E+00  0.19100E+01  0.37400E+01  0.70600E+01  0.13100E+02
+  0.24000E+02  0.43300E+02  0.76000E+02  0.12900E+03  0.21000E+03  0.33300E+03
+  0.27000E-09  0.00000E+00  0.74000E-09  0.43000E-08  0.98900E-08  0.19900E-07
+  0.36000E-07  0.63500E-07  0.10300E-06  0.16800E-06  0.28400E-06  0.54100E-06
+  0.14000E-05  0.53400E-05  0.26600E-04  0.16200E-03  0.64400E-03  0.19500E-02
+  0.52700E-02  0.13600E-01  0.37400E-01  0.47700E+00  0.95900E+00  0.19100E+01
+  0.37500E+01  0.70700E+01  0.13100E+02  0.24000E+02  0.43300E+02  0.76000E+02
+  0.12900E+03  0.21000E+03  0.33300E+03  0.17100E-08  0.74000E-09  0.00000E+00
+  0.29700E-08  0.11100E-07  0.24900E-07  0.48000E-07  0.87600E-07  0.14600E-06
+  0.24800E-06  0.43700E-06  0.91900E-06  0.28100E-05  0.17600E-04  0.10500E-03
+  0.48200E-03  0.16600E-02  0.46700E-02  0.12100E-01  0.29900E-01  0.74200E-01
+  0.47900E+00  0.96300E+00  0.19200E+01  0.37600E+01  0.70800E+01  0.13100E+02
+  0.24100E+02  0.43400E+02  0.76100E+02  0.12900E+03  0.21000E+03  0.33400E+03
+  0.39100E-08  0.43000E-08  0.29700E-08  0.00000E+00  0.92200E-08  0.27600E-07
+  0.60400E-07  0.11400E-06  0.20800E-06  0.38500E-06  0.73800E-06  0.17600E-05
+  0.68500E-05  0.64100E-04  0.39400E-03  0.13600E-02  0.37400E-02  0.92200E-02
+  0.21600E-01  0.49400E-01  0.11300E+00  0.48200E+00  0.96700E+00  0.19300E+01
+  0.37700E+01  0.71000E+01  0.13200E+02  0.24100E+02  0.43400E+02  0.76200E+02
+  0.12900E+03  0.21000E+03  0.33400E+03  0.80800E-08  0.98900E-08  0.11100E-07
+  0.92200E-08  0.00000E+00  0.22500E-07  0.67100E-07  0.14300E-06  0.28600E-06
+  0.61100E-06  0.15200E-05  0.55300E-05  0.36800E-04  0.21300E-03  0.81300E-03
+  0.23500E-02  0.59000E-02  0.13700E-01  0.30600E-01  0.67200E-01  0.14800E+00
+  0.48500E+00  0.97300E+00  0.19400E+01  0.37900E+01  0.71200E+01  0.13200E+02
+  0.24100E+02  0.43500E+02  0.76300E+02  0.12900E+03  0.21000E+03  0.33400E+03
+  0.15200E-07  0.19900E-07  0.24900E-07  0.27600E-07  0.22500E-07  0.00000E+00
+  0.56400E-07  0.15500E-06  0.36800E-06  0.97600E-06  0.38300E-05  0.21200E-04
+  0.10300E-03  0.40200E-03  0.12600E-02  0.33200E-02  0.79000E-02  0.17700E-01
+  0.38600E-01  0.82800E-01  0.17600E+00  0.49000E+00  0.98000E+00  0.19500E+01
+  0.38000E+01  0.71500E+01  0.13200E+02  0.24200E+02  0.43600E+02  0.76400E+02
+  0.12900E+03  0.21000E+03  0.33400E+03  0.26400E-07  0.36000E-07  0.48000E-07
+  0.60400E-07  0.67100E-07  0.56400E-07  0.00000E+00  0.12600E-06  0.39600E-06
+  0.14600E-05  0.91300E-05  0.47900E-04  0.18600E-03  0.61200E-03  0.17300E-02
+  0.42700E-02  0.97900E-02  0.21400E-01  0.45700E-01  0.96200E-01  0.20100E+00
+  0.49500E+00  0.98900E+00  0.19600E+01  0.38300E+01  0.71800E+01  0.13300E+02
+  0.24300E+02  0.43700E+02  0.76500E+02  0.12900E+03  0.21000E+03  0.33400E+03
+  0.44700E-07  0.63500E-07  0.87600E-07  0.11400E-06  0.14300E-06  0.15500E-06
+  0.12600E-06  0.00000E+00  0.30300E-06  0.16200E-05  0.15100E-04  0.77500E-04
+  0.27300E-03  0.81600E-03  0.21500E-02  0.51100E-02  0.11400E-01  0.24500E-01
+  0.51500E-01  0.10700E+00  0.22000E+00  0.50200E+00  0.10000E+01  0.19800E+01
+  0.38500E+01  0.72200E+01  0.13300E+02  0.24400E+02  0.43800E+02  0.76600E+02
+  0.12900E+03  0.21100E+03  0.33500E+03  0.72500E-07  0.10300E-06  0.14600E-06
+  0.20800E-06  0.28600E-06  0.36800E-06  0.39600E-06  0.30300E-06  0.00000E+00
+  0.99600E-06  0.16200E-04  0.10000E-03  0.35300E-03  0.10100E-02  0.25500E-02
+  0.58600E-02  0.12800E-01  0.27200E-01  0.56400E-01  0.11600E+00  0.23500E+00
+  0.51000E+00  0.10100E+01  0.20000E+01  0.38800E+01  0.72600E+01  0.13400E+02
+  0.24500E+02  0.43900E+02  0.76800E+02  0.13000E+03  0.21100E+03  0.33500E+03
+  0.11500E-06  0.16800E-06  0.24800E-06  0.38500E-06  0.61100E-06  0.97600E-06
+  0.14600E-05  0.16200E-05  0.99600E-06  0.00000E+00  0.72700E-05  0.10100E-03
+  0.40500E-03  0.11700E-02  0.29000E-02  0.65500E-02  0.14100E-01  0.29600E-01
+  0.60900E-01  0.12300E+00  0.24800E+00  0.52000E+00  0.10300E+01  0.20200E+01
+  0.39200E+01  0.73200E+01  0.13500E+02  0.24600E+02  0.44100E+02  0.77000E+02
+  0.13000E+03  0.21100E+03  0.33500E+03  0.19000E-06  0.28400E-06  0.43700E-06
+  0.73800E-06  0.15200E-05  0.38300E-05  0.91300E-05  0.15100E-04  0.16200E-04
+  0.72700E-05  0.00000E+00  0.56900E-04  0.39600E-03  0.12500E-02  0.31500E-02
+  0.71400E-02  0.15300E-01  0.31800E-01  0.64800E-01  0.13000E+00  0.26000E+00
+  0.53200E+00  0.10500E+01  0.20500E+01  0.39700E+01  0.73900E+01  0.13600E+02
+  0.24700E+02  0.44300E+02  0.77300E+02  0.13000E+03  0.21200E+03  0.33500E+03
+  0.32800E-06  0.54100E-06  0.91900E-06  0.17600E-05  0.55300E-05  0.21200E-04
+  0.47900E-04  0.77500E-04  0.10000E-03  0.10100E-03  0.56900E-04  0.00000E+00
+  0.25900E-03  0.11900E-02  0.32700E-02  0.75500E-02  0.16300E-01  0.33800E-01
+  0.68400E-01  0.13700E+00  0.27100E+00  0.54500E+00  0.10700E+01  0.20900E+01
+  0.40200E+01  0.74600E+01  0.13700E+02  0.24800E+02  0.44500E+02  0.77500E+02
+  0.13000E+03  0.21200E+03  0.33500E+03  0.78100E-06  0.14000E-05  0.28100E-05
+  0.68500E-05  0.36800E-04  0.10300E-03  0.18600E-03  0.27300E-03  0.35300E-03
+  0.40500E-03  0.39600E-03  0.25900E-03  0.00000E+00  0.10400E-02  0.32900E-02
+  0.79800E-02  0.17500E-01  0.36300E-01  0.73400E-01  0.14600E+00  0.28600E+00
+  0.56000E+00  0.10900E+01  0.21300E+01  0.40800E+01  0.75500E+01  0.13800E+02
+  0.25000E+02  0.44700E+02  0.77800E+02  0.13100E+03  0.21200E+03  0.33500E+03
+  0.24000E-05  0.53400E-05  0.17600E-04  0.64100E-04  0.21300E-03  0.40200E-03
+  0.61200E-03  0.81600E-03  0.10100E-02  0.11700E-02  0.12500E-02  0.11900E-02
+  0.10400E-02  0.00000E+00  0.23400E-02  0.72700E-02  0.17300E-01  0.37000E-01
+  0.75600E-01  0.15000E+00  0.29500E+00  0.57500E+00  0.11200E+01  0.21700E+01
+  0.41500E+01  0.76400E+01  0.13900E+02  0.25200E+02  0.44900E+02  0.78000E+02
+  0.13100E+03  0.21200E+03  0.33500E+03  0.64500E-05  0.26600E-04  0.10500E-03
+  0.39400E-03  0.81300E-03  0.12600E-02  0.17300E-02  0.21500E-02  0.25500E-02
+  0.29000E-02  0.31500E-02  0.32700E-02  0.32900E-02  0.23400E-02  0.00000E+00
+  0.50900E-02  0.15500E-01  0.36100E-01  0.76300E-01  0.15400E+00  0.30300E+00
+  0.59000E+00  0.11400E+01  0.22100E+01  0.42200E+01  0.77400E+01  0.14100E+02
+  0.25400E+02  0.45100E+02  0.78200E+02  0.13100E+03  0.21200E+03  0.33400E+03
+  0.14100E-04  0.16200E-03  0.48200E-03  0.13600E-02  0.23500E-02  0.33200E-02
+  0.42700E-02  0.51100E-02  0.58600E-02  0.65500E-02  0.71400E-02  0.75500E-02
+  0.79800E-02  0.72700E-02  0.50900E-02  0.60000E-03  0.10700E-01  0.32100E-01
+  0.73700E-01  0.15400E+00  0.30700E+00  0.60200E+00  0.11700E+01  0.22500E+01
+  0.42900E+01  0.78500E+01  0.14200E+02  0.25500E+02  0.45300E+02  0.78300E+02
+  0.13100E+03  0.21100E+03  0.33200E+03  0.27500E-04  0.64400E-03  0.16600E-02
+  0.37400E-02  0.59000E-02  0.79000E-02  0.97900E-02  0.11400E-01  0.12800E-01
+  0.14100E-01  0.15300E-01  0.16300E-01  0.17500E-01  0.17300E-01  0.15500E-01
+  0.10700E-01  0.13000E-02  0.21900E-01  0.64800E-01  0.14700E+00  0.30600E+00
+  0.60900E+00  0.11900E+01  0.23000E+01  0.43600E+01  0.79500E+01  0.14300E+02
+  0.25700E+02  0.45400E+02  0.78400E+02  0.13100E+03  0.21000E+03  0.33000E+03
+  0.55500E-04  0.19500E-02  0.46700E-02  0.92200E-02  0.13700E-01  0.17700E-01
+  0.21400E-01  0.24500E-01  0.27200E-01  0.29600E-01  0.31800E-01  0.33800E-01
+  0.36300E-01  0.37000E-01  0.36100E-01  0.32100E-01  0.21900E-01  0.20000E-02
+  0.43700E-01  0.12900E+00  0.29100E+00  0.60300E+00  0.12000E+01  0.23300E+01
+  0.44300E+01  0.80500E+01  0.14500E+02  0.25800E+02  0.45600E+02  0.78400E+02
+  0.13000E+03  0.20900E+03  0.32700E+03  0.13400E-03  0.52700E-02  0.12100E-01
+  0.21600E-01  0.30600E-01  0.38600E-01  0.45700E-01  0.51500E-01  0.56400E-01
+  0.60900E-01  0.64800E-01  0.68400E-01  0.73400E-01  0.75600E-01  0.76300E-01
+  0.73700E-01  0.64800E-01  0.43700E-01  0.60000E-02  0.86300E-01  0.25300E+00
+  0.57300E+00  0.11800E+01  0.23400E+01  0.44700E+01  0.81300E+01  0.14600E+02
+  0.26000E+02  0.45600E+02  0.78200E+02  0.12900E+03  0.20700E+03  0.32300E+03
+  0.54300E-03  0.13600E-01  0.29900E-01  0.49400E-01  0.67200E-01  0.82800E-01
+  0.96200E-01  0.10700E+00  0.11600E+00  0.12300E+00  0.13000E+00  0.13700E+00
+  0.14600E+00  0.15000E+00  0.15400E+00  0.15400E+00  0.14700E+00  0.12900E+00
+  0.86300E-01  0.10000E-01  0.16900E+00  0.49700E+00  0.11200E+01  0.23100E+01
+  0.44800E+01  0.81700E+01  0.14600E+02  0.26000E+02  0.45600E+02  0.77900E+02
+  0.12800E+03  0.20400E+03  0.31700E+03  0.66900E-02  0.37400E-01  0.74200E-01
+  0.11300E+00  0.14800E+00  0.17600E+00  0.20100E+00  0.22000E+00  0.23500E+00
+  0.24800E+00  0.26000E+00  0.27100E+00  0.28600E+00  0.29500E+00  0.30300E+00
+  0.30700E+00  0.30600E+00  0.29100E+00  0.25300E+00  0.16900E+00  0.25000E-01
+  0.33200E+00  0.97300E+00  0.21900E+01  0.44100E+01  0.81300E+01  0.14600E+02
+  0.26000E+02  0.45500E+02  0.77400E+02  0.12700E+03  0.20000E+03  0.31000E+03
+  0.47500E+00  0.47700E+00  0.47900E+00  0.48200E+00  0.48500E+00  0.49000E+00
+  0.49500E+00  0.50200E+00  0.51000E+00  0.52000E+00  0.53200E+00  0.54500E+00
+  0.56000E+00  0.57500E+00  0.59000E+00  0.60200E+00  0.60900E+00  0.60300E+00
+  0.57300E+00  0.49700E+00  0.33200E+00  0.55000E-01  0.65100E+00  0.18900E+01
+  0.41500E+01  0.78900E+01  0.14400E+02  0.25700E+02  0.45000E+02  0.76300E+02
+  0.12500E+03  0.19500E+03  0.30000E+03  0.95600E+00  0.95900E+00  0.96300E+00
+  0.96700E+00  0.97300E+00  0.98000E+00  0.98900E+00  0.10000E+01  0.10100E+01
+  0.10300E+01  0.10500E+01  0.10700E+01  0.10900E+01  0.11200E+01  0.11400E+01
+  0.11700E+01  0.11900E+01  0.12000E+01  0.11800E+01  0.11200E+01  0.97300E+00
+  0.65100E+00  0.14000E+00  0.12600E+01  0.35500E+01  0.72800E+01  0.13700E+02
+  0.24900E+02  0.43900E+02  0.74400E+02  0.12100E+03  0.18800E+03  0.28600E+03
+  0.19100E+01  0.19100E+01  0.19200E+01  0.19300E+01  0.19400E+01  0.19500E+01
+  0.19600E+01  0.19800E+01  0.20000E+01  0.20200E+01  0.20500E+01  0.20900E+01
+  0.21300E+01  0.21700E+01  0.22100E+01  0.22500E+01  0.23000E+01  0.23300E+01
+  0.23400E+01  0.23100E+01  0.21900E+01  0.18900E+01  0.12600E+01  0.40000E+00
+  0.23000E+01  0.59800E+01  0.12300E+02  0.23300E+02  0.41700E+02  0.71200E+02
+  0.11500E+03  0.17800E+03  0.26800E+03  0.37400E+01  0.37500E+01  0.37600E+01
+  0.37700E+01  0.37900E+01  0.38000E+01  0.38300E+01  0.38500E+01  0.38800E+01
+  0.39200E+01  0.39700E+01  0.40200E+01  0.40800E+01  0.41500E+01  0.42200E+01
+  0.42900E+01  0.43600E+01  0.44300E+01  0.44700E+01  0.44800E+01  0.44100E+01
+  0.41500E+01  0.35500E+01  0.23000E+01  0.20000E+01  0.35900E+01  0.97300E+01
+  0.20400E+02  0.38200E+02  0.66300E+02  0.10800E+03  0.16500E+03  0.24500E+03
+  0.70600E+01  0.70700E+01  0.70800E+01  0.71000E+01  0.71200E+01  0.71500E+01
+  0.71800E+01  0.72200E+01  0.72600E+01  0.73200E+01  0.73900E+01  0.74600E+01
+  0.75500E+01  0.76400E+01  0.77400E+01  0.78500E+01  0.79500E+01  0.80500E+01
+  0.81300E+01  0.81700E+01  0.81300E+01  0.78900E+01  0.72800E+01  0.59800E+01
+  0.35900E+01  0.40000E+01  0.60900E+01  0.16600E+02  0.34000E+02  0.61000E+02
+  0.99700E+02  0.15200E+03  0.22200E+03  0.13100E+02  0.13100E+02  0.13100E+02
+  0.13200E+02  0.13200E+02  0.13200E+02  0.13300E+02  0.13300E+02  0.13400E+02
+  0.13500E+02  0.13600E+02  0.13700E+02  0.13800E+02  0.13900E+02  0.14100E+02
+  0.14200E+02  0.14300E+02  0.14500E+02  0.14600E+02  0.14600E+02  0.14600E+02
+  0.14400E+02  0.13700E+02  0.12300E+02  0.97300E+01  0.60900E+01  0.55000E+01
+  0.10400E+02  0.27500E+02  0.53300E+02  0.89000E+02  0.13500E+03  0.19500E+03
+  0.24000E+02  0.24000E+02  0.24100E+02  0.24100E+02  0.24100E+02  0.24200E+02
+  0.24300E+02  0.24400E+02  0.24500E+02  0.24600E+02  0.24700E+02  0.24800E+02
+  0.25000E+02  0.25200E+02  0.25400E+02  0.25500E+02  0.25700E+02  0.25800E+02
+  0.26000E+02  0.26000E+02  0.26000E+02  0.25700E+02  0.24900E+02  0.23300E+02
+  0.20400E+02  0.16600E+02  0.10400E+02  0.80000E+01  0.16700E+02  0.41200E+02
+  0.73500E+02  0.11200E+03  0.15900E+03  0.43300E+02  0.43300E+02  0.43400E+02
+  0.43400E+02  0.43500E+02  0.43600E+02  0.43700E+02  0.43800E+02  0.43900E+02
+  0.44100E+02  0.44300E+02  0.44500E+02  0.44700E+02  0.44900E+02  0.45100E+02
+  0.45300E+02  0.45400E+02  0.45600E+02  0.45600E+02  0.45600E+02  0.45500E+02
+  0.45000E+02  0.43900E+02  0.41700E+02  0.38200E+02  0.34000E+02  0.27500E+02
+  0.16700E+02  0.12000E+02  0.23400E+02  0.51900E+02  0.82300E+02  0.11500E+03
+  0.76000E+02  0.76000E+02  0.76100E+02  0.76200E+02  0.76300E+02  0.76400E+02
+  0.76500E+02  0.76600E+02  0.76800E+02  0.77000E+02  0.77300E+02  0.77500E+02
+  0.77800E+02  0.78000E+02  0.78200E+02  0.78300E+02  0.78400E+02  0.78400E+02
+  0.78200E+02  0.77900E+02  0.77400E+02  0.76300E+02  0.74400E+02  0.71200E+02
+  0.66300E+02  0.61000E+02  0.53300E+02  0.41200E+02  0.23400E+02  0.14000E+02
+  0.25800E+02  0.48600E+02  0.66800E+02  0.12900E+03  0.12900E+03  0.12900E+03
+  0.12900E+03  0.12900E+03  0.12900E+03  0.12900E+03  0.12900E+03  0.13000E+03
+  0.13000E+03  0.13000E+03  0.13000E+03  0.13100E+03  0.13100E+03  0.13100E+03
+  0.13100E+03  0.13100E+03  0.13000E+03  0.12900E+03  0.12800E+03  0.12700E+03
+  0.12500E+03  0.12100E+03  0.11500E+03  0.10800E+03  0.99700E+02  0.89000E+02
+  0.73500E+02  0.51900E+02  0.25800E+02  0.15000E+02  0.17900E+02  0.25300E+02
+  0.21000E+03  0.21000E+03  0.21000E+03  0.21000E+03  0.21000E+03  0.21000E+03
+  0.21000E+03  0.21100E+03  0.21100E+03  0.21100E+03  0.21200E+03  0.21200E+03
+  0.21200E+03  0.21200E+03  0.21200E+03  0.21100E+03  0.21000E+03  0.20900E+03
+  0.20700E+03  0.20400E+03  0.20000E+03  0.19500E+03  0.18800E+03  0.17800E+03
+  0.16500E+03  0.15200E+03  0.13500E+03  0.11200E+03  0.82300E+02  0.48600E+02
+  0.17900E+02  0.16000E+02  0.22000E+01  0.33300E+03  0.33300E+03  0.33400E+03
+  0.33400E+03  0.33400E+03  0.33400E+03  0.33400E+03  0.33500E+03  0.33500E+03
+  0.33500E+03  0.33500E+03  0.33500E+03  0.33500E+03  0.33500E+03  0.33400E+03
+  0.33200E+03  0.33000E+03  0.32700E+03  0.32300E+03  0.31700E+03  0.31000E+03
+  0.30000E+03  0.28600E+03  0.26800E+03  0.24500E+03  0.22200E+03  0.19500E+03
+  0.15900E+03  0.11500E+03  0.66800E+02  0.25300E+02  0.22000E+01  0.17000E+02
+  0.00000E+00  0.26400E-09  0.16800E-08  0.39100E-08  0.78500E-08  0.14900E-07
+  0.26400E-07  0.44500E-07  0.71200E-07  0.11500E-06  0.17500E-06  0.29800E-06
+  0.64300E-06  0.20300E-05  0.60100E-05  0.15000E-04  0.34900E-04  0.87100E-04
+  0.29500E-03  0.24100E-02  0.15000E-01  0.47500E+00  0.95600E+00  0.19100E+01
+  0.37400E+01  0.70600E+01  0.13100E+02  0.24000E+02  0.43300E+02  0.76000E+02
+  0.12900E+03  0.21000E+03  0.33300E+03  0.26400E-09  0.00000E+00  0.72400E-09
+  0.42500E-08  0.96300E-08  0.19500E-07  0.36000E-07  0.62000E-07  0.10300E-06
+  0.16800E-06  0.27700E-06  0.51700E-06  0.12700E-05  0.53300E-05  0.40900E-04
+  0.26700E-03  0.95800E-03  0.26800E-02  0.69000E-02  0.17700E-01  0.47400E-01
+  0.47700E+00  0.95900E+00  0.19100E+01  0.37500E+01  0.70700E+01  0.13100E+02
+  0.24000E+02  0.43300E+02  0.76000E+02  0.12900E+03  0.21000E+03  0.33300E+03
+  0.16800E-08  0.72400E-09  0.00000E+00  0.29000E-08  0.10900E-07  0.24500E-07
+  0.47700E-07  0.85200E-07  0.14600E-06  0.24800E-06  0.44700E-06  0.94300E-06
+  0.30000E-05  0.21700E-04  0.14400E-03  0.69900E-03  0.22700E-02  0.60800E-02
+  0.15100E-01  0.36000E-01  0.85700E-01  0.47900E+00  0.96300E+00  0.19200E+01
+  0.37600E+01  0.70800E+01  0.13100E+02  0.24100E+02  0.43400E+02  0.76100E+02
+  0.12900E+03  0.21000E+03  0.33400E+03  0.39100E-08  0.42500E-08  0.29000E-08
+  0.00000E+00  0.92200E-08  0.27400E-07  0.58900E-07  0.11400E-06  0.20800E-06
+  0.38500E-06  0.79700E-06  0.19900E-05  0.85200E-05  0.86800E-04  0.48200E-03
+  0.16300E-02  0.44100E-02  0.10700E-01  0.24700E-01  0.55500E-01  0.12400E+00
+  0.48200E+00  0.96700E+00  0.19300E+01  0.37700E+01  0.71000E+01  0.13200E+02
+  0.24100E+02  0.43400E+02  0.76200E+02  0.12900E+03  0.21000E+03  0.33400E+03
+  0.78500E-08  0.96300E-08  0.10900E-07  0.92200E-08  0.00000E+00  0.22000E-07
+  0.65500E-07  0.14300E-06  0.29200E-06  0.65300E-06  0.18000E-05  0.79700E-05
+  0.49400E-04  0.24700E-03  0.91300E-03  0.26100E-02  0.65200E-02  0.15100E-01
+  0.33500E-01  0.72500E-01  0.15700E+00  0.48500E+00  0.97300E+00  0.19400E+01
+  0.37900E+01  0.71200E+01  0.13200E+02  0.24100E+02  0.43500E+02  0.76300E+02
+  0.12900E+03  0.21000E+03  0.33400E+03  0.14900E-07  0.19500E-07  0.24500E-07
+  0.27400E-07  0.22000E-07  0.00000E+00  0.55200E-07  0.15600E-06  0.38200E-06
+  0.11400E-05  0.53100E-05  0.28200E-04  0.12100E-03  0.43900E-03  0.13600E-02
+  0.35700E-02  0.84600E-02  0.18900E-01  0.40900E-01  0.87100E-01  0.18400E+00
+  0.49000E+00  0.98000E+00  0.19500E+01  0.38000E+01  0.71500E+01  0.13200E+02
+  0.24200E+02  0.43600E+02  0.76400E+02  0.12900E+03  0.21000E+03  0.33400E+03
+  0.26400E-07  0.36000E-07  0.47700E-07  0.58900E-07  0.65500E-07  0.55200E-07
+  0.00000E+00  0.13000E-06  0.42300E-06  0.18200E-05  0.12300E-04  0.58000E-04
+  0.20700E-03  0.65000E-03  0.18100E-02  0.44700E-02  0.10200E-01  0.22300E-01
+  0.47500E-01  0.99600E-01  0.20600E+00  0.49500E+00  0.98900E+00  0.19600E+01
+  0.38300E+01  0.71800E+01  0.13300E+02  0.24300E+02  0.43700E+02  0.76500E+02
+  0.12900E+03  0.21000E+03  0.33400E+03  0.44500E-07  0.62000E-07  0.85200E-07
+  0.11400E-06  0.14300E-06  0.15600E-06  0.13000E-06  0.00000E+00  0.30700E-06
+  0.20200E-05  0.19100E-04  0.88800E-04  0.29600E-03  0.85300E-03  0.22200E-02
+  0.52600E-02  0.11800E-01  0.25200E-01  0.52900E-01  0.10900E+00  0.22400E+00
+  0.50200E+00  0.10000E+01  0.19800E+01  0.38500E+01  0.72200E+01  0.13300E+02
+  0.24400E+02  0.43800E+02  0.76600E+02  0.12900E+03  0.21100E+03  0.33500E+03
+  0.71200E-07  0.10300E-06  0.14600E-06  0.20800E-06  0.29200E-06  0.38200E-06
+  0.42300E-06  0.30700E-06  0.00000E+00  0.11100E-05  0.20200E-04  0.11200E-03
+  0.37400E-03  0.10400E-02  0.26000E-02  0.59900E-02  0.13100E-01  0.27700E-01
+  0.57300E-01  0.11700E+00  0.23700E+00  0.51000E+00  0.10100E+01  0.20000E+01
+  0.38800E+01  0.72600E+01  0.13400E+02  0.24500E+02  0.43900E+02  0.76800E+02
+  0.13000E+03  0.21100E+03  0.33500E+03  0.11500E-06  0.16800E-06  0.24800E-06
+  0.38500E-06  0.65300E-06  0.11400E-05  0.18200E-05  0.20200E-05  0.11100E-05
+  0.00000E+00  0.93600E-05  0.11200E-03  0.42800E-03  0.12000E-02  0.29400E-02
+  0.66400E-02  0.14300E-01  0.29900E-01  0.61400E-01  0.12500E+00  0.25000E+00
+  0.52000E+00  0.10300E+01  0.20200E+01  0.39200E+01  0.73200E+01  0.13500E+02
+  0.24600E+02  0.44100E+02  0.77000E+02  0.13000E+03  0.21100E+03  0.33500E+03
+  0.17500E-06  0.27700E-06  0.44700E-06  0.79700E-06  0.18000E-05  0.53100E-05
+  0.12300E-04  0.19100E-04  0.20200E-04  0.93600E-05  0.00000E+00  0.64600E-04
+  0.41500E-03  0.12800E-02  0.31900E-02  0.72000E-02  0.15500E-01  0.32100E-01
+  0.65100E-01  0.13100E+00  0.26100E+00  0.53200E+00  0.10500E+01  0.20500E+01
+  0.39700E+01  0.73900E+01  0.13600E+02  0.24700E+02  0.44300E+02  0.77300E+02
+  0.13000E+03  0.21200E+03  0.33500E+03  0.29800E-06  0.51700E-06  0.94300E-06
+  0.19900E-05  0.79700E-05  0.28200E-04  0.58000E-04  0.88800E-04  0.11200E-03
+  0.11200E-03  0.64600E-04  0.00000E+00  0.27200E-03  0.12100E-02  0.32900E-02
+  0.76100E-02  0.16400E-01  0.34000E-01  0.68800E-01  0.13700E+00  0.27200E+00
+  0.54500E+00  0.10700E+01  0.20900E+01  0.40200E+01  0.74600E+01  0.13700E+02
+  0.24800E+02  0.44500E+02  0.77500E+02  0.13000E+03  0.21200E+03  0.33500E+03
+  0.64300E-06  0.12700E-05  0.30000E-05  0.85200E-05  0.49400E-04  0.12100E-03
+  0.20700E-03  0.29600E-03  0.37400E-03  0.42800E-03  0.41500E-03  0.27200E-03
+  0.00000E+00  0.10400E-02  0.32900E-02  0.79800E-02  0.17500E-01  0.36300E-01
+  0.73400E-01  0.14600E+00  0.28600E+00  0.56000E+00  0.10900E+01  0.21300E+01
+  0.40800E+01  0.75500E+01  0.13800E+02  0.25000E+02  0.44700E+02  0.77800E+02
+  0.13100E+03  0.21200E+03  0.33500E+03  0.20300E-05  0.53300E-05  0.21700E-04
+  0.86800E-04  0.24700E-03  0.43900E-03  0.65000E-03  0.85300E-03  0.10400E-02
+  0.12000E-02  0.12800E-02  0.12100E-02  0.10400E-02  0.00000E+00  0.23400E-02
+  0.72700E-02  0.17300E-01  0.37000E-01  0.75600E-01  0.15000E+00  0.29500E+00
+  0.57500E+00  0.11200E+01  0.21700E+01  0.41500E+01  0.76400E+01  0.13900E+02
+  0.25200E+02  0.44900E+02  0.78000E+02  0.13100E+03  0.21200E+03  0.33500E+03
+  0.60100E-05  0.40900E-04  0.14400E-03  0.48200E-03  0.91300E-03  0.13600E-02
+  0.18100E-02  0.22200E-02  0.26000E-02  0.29400E-02  0.31900E-02  0.32900E-02
+  0.32900E-02  0.23400E-02  0.00000E+00  0.50900E-02  0.15500E-01  0.36100E-01
+  0.76300E-01  0.15400E+00  0.30300E+00  0.59000E+00  0.11400E+01  0.22100E+01
+  0.42200E+01  0.77400E+01  0.14100E+02  0.25400E+02  0.45100E+02  0.78200E+02
+  0.13100E+03  0.21200E+03  0.33400E+03  0.15000E-04  0.26700E-03  0.69900E-03
+  0.16300E-02  0.26100E-02  0.35700E-02  0.44700E-02  0.52600E-02  0.59900E-02
+  0.66400E-02  0.72000E-02  0.76100E-02  0.79800E-02  0.72700E-02  0.50900E-02
+  0.60000E-03  0.10700E-01  0.32100E-01  0.73700E-01  0.15400E+00  0.30700E+00
+  0.60200E+00  0.11700E+01  0.22500E+01  0.42900E+01  0.78500E+01  0.14200E+02
+  0.25500E+02  0.45300E+02  0.78300E+02  0.13100E+03  0.21100E+03  0.33200E+03
+  0.34900E-04  0.95800E-03  0.22700E-02  0.44100E-02  0.65200E-02  0.84600E-02
+  0.10200E-01  0.11800E-01  0.13100E-01  0.14300E-01  0.15500E-01  0.16400E-01
+  0.17500E-01  0.17300E-01  0.15500E-01  0.10700E-01  0.13000E-02  0.21900E-01
+  0.64800E-01  0.14700E+00  0.30600E+00  0.60900E+00  0.11900E+01  0.23000E+01
+  0.43600E+01  0.79500E+01  0.14300E+02  0.25700E+02  0.45400E+02  0.78400E+02
+  0.13100E+03  0.21000E+03  0.33000E+03  0.87100E-04  0.26800E-02  0.60800E-02
+  0.10700E-01  0.15100E-01  0.18900E-01  0.22300E-01  0.25200E-01  0.27700E-01
+  0.29900E-01  0.32100E-01  0.34000E-01  0.36300E-01  0.37000E-01  0.36100E-01
+  0.32100E-01  0.21900E-01  0.20000E-02  0.43700E-01  0.12900E+00  0.29100E+00
+  0.60300E+00  0.12000E+01  0.23300E+01  0.44300E+01  0.80500E+01  0.14500E+02
+  0.25800E+02  0.45600E+02  0.78400E+02  0.13000E+03  0.20900E+03  0.32700E+03
+  0.29500E-03  0.69000E-02  0.15100E-01  0.24700E-01  0.33500E-01  0.40900E-01
+  0.47500E-01  0.52900E-01  0.57300E-01  0.61400E-01  0.65100E-01  0.68800E-01
+  0.73400E-01  0.75600E-01  0.76300E-01  0.73700E-01  0.64800E-01  0.43700E-01
+  0.60000E-02  0.86300E-01  0.25300E+00  0.57300E+00  0.11800E+01  0.23400E+01
+  0.44700E+01  0.81300E+01  0.14600E+02  0.26000E+02  0.45600E+02  0.78200E+02
+  0.12900E+03  0.20700E+03  0.32300E+03  0.24100E-02  0.17700E-01  0.36000E-01
+  0.55500E-01  0.72500E-01  0.87100E-01  0.99600E-01  0.10900E+00  0.11700E+00
+  0.12500E+00  0.13100E+00  0.13700E+00  0.14600E+00  0.15000E+00  0.15400E+00
+  0.15400E+00  0.14700E+00  0.12900E+00  0.86300E-01  0.10000E-01  0.16900E+00
+  0.49700E+00  0.11200E+01  0.23100E+01  0.44800E+01  0.81700E+01  0.14600E+02
+  0.26000E+02  0.45600E+02  0.77900E+02  0.12800E+03  0.20400E+03  0.31700E+03
+  0.15000E-01  0.47400E-01  0.85700E-01  0.12400E+00  0.15700E+00  0.18400E+00
+  0.20600E+00  0.22400E+00  0.23700E+00  0.25000E+00  0.26100E+00  0.27200E+00
+  0.28600E+00  0.29500E+00  0.30300E+00  0.30700E+00  0.30600E+00  0.29100E+00
+  0.25300E+00  0.16900E+00  0.25000E-01  0.33200E+00  0.97300E+00  0.21900E+01
+  0.44100E+01  0.81300E+01  0.14600E+02  0.26000E+02  0.45500E+02  0.77400E+02
+  0.12700E+03  0.20000E+03  0.31000E+03  0.47500E+00  0.47700E+00  0.47900E+00
+  0.48200E+00  0.48500E+00  0.49000E+00  0.49500E+00  0.50200E+00  0.51000E+00
+  0.52000E+00  0.53200E+00  0.54500E+00  0.56000E+00  0.57500E+00  0.59000E+00
+  0.60200E+00  0.60900E+00  0.60300E+00  0.57300E+00  0.49700E+00  0.33200E+00
+  0.55000E-01  0.65100E+00  0.18900E+01  0.41500E+01  0.78900E+01  0.14400E+02
+  0.25700E+02  0.45000E+02  0.76300E+02  0.12500E+03  0.19500E+03  0.30000E+03
+  0.95600E+00  0.95900E+00  0.96300E+00  0.96700E+00  0.97300E+00  0.98000E+00
+  0.98900E+00  0.10000E+01  0.10100E+01  0.10300E+01  0.10500E+01  0.10700E+01
+  0.10900E+01  0.11200E+01  0.11400E+01  0.11700E+01  0.11900E+01  0.12000E+01
+  0.11800E+01  0.11200E+01  0.97300E+00  0.65100E+00  0.14000E+00  0.12600E+01
+  0.35500E+01  0.72800E+01  0.13700E+02  0.24900E+02  0.43900E+02  0.74400E+02
+  0.12100E+03  0.18800E+03  0.28600E+03  0.19100E+01  0.19100E+01  0.19200E+01
+  0.19300E+01  0.19400E+01  0.19500E+01  0.19600E+01  0.19800E+01  0.20000E+01
+  0.20200E+01  0.20500E+01  0.20900E+01  0.21300E+01  0.21700E+01  0.22100E+01
+  0.22500E+01  0.23000E+01  0.23300E+01  0.23400E+01  0.23100E+01  0.21900E+01
+  0.18900E+01  0.12600E+01  0.40000E+00  0.23000E+01  0.59800E+01  0.12300E+02
+  0.23300E+02  0.41700E+02  0.71200E+02  0.11500E+03  0.17800E+03  0.26800E+03
+  0.37400E+01  0.37500E+01  0.37600E+01  0.37700E+01  0.37900E+01  0.38000E+01
+  0.38300E+01  0.38500E+01  0.38800E+01  0.39200E+01  0.39700E+01  0.40200E+01
+  0.40800E+01  0.41500E+01  0.42200E+01  0.42900E+01  0.43600E+01  0.44300E+01
+  0.44700E+01  0.44800E+01  0.44100E+01  0.41500E+01  0.35500E+01  0.23000E+01
+  0.20000E+01  0.35900E+01  0.97300E+01  0.20400E+02  0.38200E+02  0.66300E+02
+  0.10800E+03  0.16500E+03  0.24500E+03  0.70600E+01  0.70700E+01  0.70800E+01
+  0.71000E+01  0.71200E+01  0.71500E+01  0.71800E+01  0.72200E+01  0.72600E+01
+  0.73200E+01  0.73900E+01  0.74600E+01  0.75500E+01  0.76400E+01  0.77400E+01
+  0.78500E+01  0.79500E+01  0.80500E+01  0.81300E+01  0.81700E+01  0.81300E+01
+  0.78900E+01  0.72800E+01  0.59800E+01  0.35900E+01  0.40000E+01  0.60900E+01
+  0.16600E+02  0.34000E+02  0.61000E+02  0.99700E+02  0.15200E+03  0.22200E+03
+  0.13100E+02  0.13100E+02  0.13100E+02  0.13200E+02  0.13200E+02  0.13200E+02
+  0.13300E+02  0.13300E+02  0.13400E+02  0.13500E+02  0.13600E+02  0.13700E+02
+  0.13800E+02  0.13900E+02  0.14100E+02  0.14200E+02  0.14300E+02  0.14500E+02
+  0.14600E+02  0.14600E+02  0.14600E+02  0.14400E+02  0.13700E+02  0.12300E+02
+  0.97300E+01  0.60900E+01  0.55000E+01  0.10400E+02  0.27500E+02  0.53300E+02
+  0.89000E+02  0.13500E+03  0.19500E+03  0.24000E+02  0.24000E+02  0.24100E+02
+  0.24100E+02  0.24100E+02  0.24200E+02  0.24300E+02  0.24400E+02  0.24500E+02
+  0.24600E+02  0.24700E+02  0.24800E+02  0.25000E+02  0.25200E+02  0.25400E+02
+  0.25500E+02  0.25700E+02  0.25800E+02  0.26000E+02  0.26000E+02  0.26000E+02
+  0.25700E+02  0.24900E+02  0.23300E+02  0.20400E+02  0.16600E+02  0.10400E+02
+  0.80000E+01  0.16700E+02  0.41200E+02  0.73500E+02  0.11200E+03  0.15900E+03
+  0.43300E+02  0.43300E+02  0.43400E+02  0.43400E+02  0.43500E+02  0.43600E+02
+  0.43700E+02  0.43800E+02  0.43900E+02  0.44100E+02  0.44300E+02  0.44500E+02
+  0.44700E+02  0.44900E+02  0.45100E+02  0.45300E+02  0.45400E+02  0.45600E+02
+  0.45600E+02  0.45600E+02  0.45500E+02  0.45000E+02  0.43900E+02  0.41700E+02
+  0.38200E+02  0.34000E+02  0.27500E+02  0.16700E+02  0.12000E+02  0.23400E+02
+  0.51900E+02  0.82300E+02  0.11500E+03  0.76000E+02  0.76000E+02  0.76100E+02
+  0.76200E+02  0.76300E+02  0.76400E+02  0.76500E+02  0.76600E+02  0.76800E+02
+  0.77000E+02  0.77300E+02  0.77500E+02  0.77800E+02  0.78000E+02  0.78200E+02
+  0.78300E+02  0.78400E+02  0.78400E+02  0.78200E+02  0.77900E+02  0.77400E+02
+  0.76300E+02  0.74400E+02  0.71200E+02  0.66300E+02  0.61000E+02  0.53300E+02
+  0.41200E+02  0.23400E+02  0.14000E+02  0.25800E+02  0.48600E+02  0.66800E+02
+  0.12900E+03  0.12900E+03  0.12900E+03  0.12900E+03  0.12900E+03  0.12900E+03
+  0.12900E+03  0.12900E+03  0.13000E+03  0.13000E+03  0.13000E+03  0.13000E+03
+  0.13100E+03  0.13100E+03  0.13100E+03  0.13100E+03  0.13100E+03  0.13000E+03
+  0.12900E+03  0.12800E+03  0.12700E+03  0.12500E+03  0.12100E+03  0.11500E+03
+  0.10800E+03  0.99700E+02  0.89000E+02  0.73500E+02  0.51900E+02  0.25800E+02
+  0.15000E+02  0.17900E+02  0.25300E+02  0.21000E+03  0.21000E+03  0.21000E+03
+  0.21000E+03  0.21000E+03  0.21000E+03  0.21000E+03  0.21100E+03  0.21100E+03
+  0.21100E+03  0.21200E+03  0.21200E+03  0.21200E+03  0.21200E+03  0.21200E+03
+  0.21100E+03  0.21000E+03  0.20900E+03  0.20700E+03  0.20400E+03  0.20000E+03
+  0.19500E+03  0.18800E+03  0.17800E+03  0.16500E+03  0.15200E+03  0.13500E+03
+  0.11200E+03  0.82300E+02  0.48600E+02  0.17900E+02  0.16000E+02  0.22000E+01
+  0.33300E+03  0.33300E+03  0.33400E+03  0.33400E+03  0.33400E+03  0.33400E+03
+  0.33400E+03  0.33500E+03  0.33500E+03  0.33500E+03  0.33500E+03  0.33500E+03
+  0.33500E+03  0.33500E+03  0.33400E+03  0.33200E+03  0.33000E+03  0.32700E+03
+  0.32300E+03  0.31700E+03  0.31000E+03  0.30000E+03  0.28600E+03  0.26800E+03
+  0.24500E+03  0.22200E+03  0.19500E+03  0.15900E+03  0.11500E+03  0.66800E+02
+  0.25300E+02  0.22000E+01  0.17000E+02
diff --git a/wrfv2_fire/run/masses.asc b/wrfv2_fire/run/masses.asc
new file mode 100644
index 00000000..8efd96a3
--- /dev/null
+++ b/wrfv2_fire/run/masses.asc
@@ -0,0 +1,39 @@
+  0.33510E-10  0.67021E-10  0.13404E-09  0.26808E-09  0.53617E-09  0.10723E-08
+  0.21447E-08  0.42893E-08  0.85786E-08  0.17157E-07  0.34315E-07  0.68629E-07
+  0.13726E-06  0.27452E-06  0.54903E-06  0.10981E-05  0.21961E-05  0.43923E-05
+  0.87845E-05  0.17569E-04  0.35138E-04  0.70276E-04  0.14055E-03  0.28110E-03
+  0.56221E-03  0.11244E-02  0.22488E-02  0.44977E-02  0.89954E-02  0.17991E-01
+  0.35981E-01  0.71963E-01  0.14393E+00  0.33510E-10  0.67021E-10  0.13404E-09
+  0.26808E-09  0.53617E-09  0.10723E-08  0.21447E-08  0.42893E-08  0.85786E-08
+  0.17157E-07  0.34315E-07  0.68629E-07  0.13726E-06  0.27452E-06  0.54903E-06
+  0.10981E-05  0.21961E-05  0.43923E-05  0.87845E-05  0.17569E-04  0.35138E-04
+  0.70276E-04  0.14055E-03  0.28110E-03  0.56221E-03  0.11244E-02  0.22488E-02
+  0.44977E-02  0.89954E-02  0.17991E-01  0.35981E-01  0.71963E-01  0.14393E+00
+  0.33510E-10  0.67021E-10  0.13404E-09  0.26808E-09  0.53617E-09  0.10723E-08
+  0.21447E-08  0.42893E-08  0.85786E-08  0.17157E-07  0.34315E-07  0.68629E-07
+  0.13726E-06  0.27452E-06  0.54903E-06  0.10981E-05  0.21961E-05  0.43923E-05
+  0.87845E-05  0.17569E-04  0.35138E-04  0.70276E-04  0.14055E-03  0.28110E-03
+  0.56221E-03  0.11244E-02  0.22488E-02  0.44977E-02  0.89954E-02  0.17991E-01
+  0.35981E-01  0.71963E-01  0.14393E+00  0.33510E-10  0.67021E-10  0.13404E-09
+  0.26808E-09  0.53617E-09  0.10723E-08  0.21447E-08  0.42893E-08  0.85786E-08
+  0.17157E-07  0.34315E-07  0.68629E-07  0.13726E-06  0.27452E-06  0.54903E-06
+  0.10981E-05  0.21961E-05  0.43923E-05  0.87845E-05  0.17569E-04  0.35138E-04
+  0.70276E-04  0.14055E-03  0.28110E-03  0.56221E-03  0.11244E-02  0.22488E-02
+  0.44977E-02  0.89954E-02  0.17991E-01  0.35981E-01  0.71963E-01  0.14393E+00
+  0.33510E-10  0.67021E-10  0.13404E-09  0.26808E-09  0.53617E-09  0.10723E-08
+  0.21447E-08  0.42893E-08  0.85786E-08  0.17157E-07  0.34315E-07  0.68629E-07
+  0.13726E-06  0.27452E-06  0.54903E-06  0.10981E-05  0.21961E-05  0.43923E-05
+  0.87845E-05  0.17569E-04  0.35138E-04  0.70276E-04  0.14055E-03  0.28110E-03
+  0.56221E-03  0.11244E-02  0.22488E-02  0.44977E-02  0.89954E-02  0.17991E-01
+  0.35981E-01  0.71963E-01  0.14393E+00  0.33510E-10  0.67021E-10  0.13404E-09
+  0.26808E-09  0.53617E-09  0.10723E-08  0.21447E-08  0.42893E-08  0.85786E-08
+  0.17157E-07  0.34315E-07  0.68629E-07  0.13726E-06  0.27452E-06  0.54903E-06
+  0.10981E-05  0.21961E-05  0.43923E-05  0.87845E-05  0.17569E-04  0.35138E-04
+  0.70276E-04  0.14055E-03  0.28110E-03  0.56221E-03  0.11244E-02  0.22488E-02
+  0.44977E-02  0.89954E-02  0.17991E-01  0.35981E-01  0.71963E-01  0.14393E+00
+  0.33510E-10  0.67021E-10  0.13404E-09  0.26808E-09  0.53617E-09  0.10723E-08
+  0.21447E-08  0.42893E-08  0.85786E-08  0.17157E-07  0.34315E-07  0.68629E-07
+  0.13726E-06  0.27452E-06  0.54903E-06  0.10981E-05  0.21961E-05  0.43923E-05
+  0.87845E-05  0.17569E-04  0.35138E-04  0.70276E-04  0.14055E-03  0.28110E-03
+  0.56221E-03  0.11244E-02  0.22488E-02  0.44977E-02  0.89954E-02  0.17991E-01
+  0.35981E-01  0.71963E-01  0.14393E+00
diff --git a/wrfv2_fire/run/termvels.asc b/wrfv2_fire/run/termvels.asc
new file mode 100644
index 00000000..30fd3a8a
--- /dev/null
+++ b/wrfv2_fire/run/termvels.asc
@@ -0,0 +1,40 @@
+  0.50000E-01  0.78000E-01  0.12000E+00  0.19000E+00  0.31000E+00  0.49000E+00
+  0.77000E+00  0.12000E+01  0.19000E+01  0.30000E+01  0.48000E+01  0.74000E+01
+  0.11000E+02  0.17000E+02  0.26000E+02  0.37000E+02  0.52000E+02  0.71000E+02
+  0.94000E+02  0.12000E+03  0.16000E+03  0.21000E+03  0.26000E+03  0.33000E+03
+  0.41000E+03  0.48000E+03  0.57000E+03  0.66000E+03  0.75000E+03  0.82000E+03
+  0.88000E+03  0.90000E+03  0.90000E+03  0.30000E-01  0.40000E-01  0.60000E-01
+  0.80000E-01  0.11000E+00  0.15000E+00  0.60000E+00  0.10000E+01  0.20000E+00
+  0.25000E+00  0.40000E+00  0.60000E+01  0.10000E+02  0.15000E+01  0.20000E+02
+  0.25000E+02  0.31000E+02  0.37000E+02  0.41000E+02  0.46000E+02  0.51000E+02
+  0.55000E+02  0.59000E+02  0.62000E+02  0.64000E+02  0.67000E+02  0.68000E+02
+  0.69000E+02  0.70000E+02  0.71000E+02  0.71500E+02  0.71750E+02  0.72000E+02
+  0.30000E-01  0.40000E-01  0.50000E-01  0.70000E-01  0.90000E-01  0.12000E+00
+  0.50000E+00  0.80000E+00  0.16000E+01  0.18000E+01  0.20000E+01  0.30000E+01
+  0.40000E+01  0.50000E+01  0.80000E+01  0.13000E+02  0.19000E+02  0.26000E+02
+  0.32000E+02  0.38000E+02  0.47000E+02  0.55000E+02  0.65000E+02  0.73000E+02
+  0.77000E+02  0.79000E+02  0.80000E+02  0.81000E+02  0.81000E+02  0.82000E+02
+  0.82000E+02  0.82000E+02  0.82000E+02  0.35000E-01  0.45000E-01  0.55000E-01
+  0.75000E-01  0.95000E-01  0.13000E+00  0.60000E+00  0.90000E+00  0.17000E+01
+  0.20000E+01  0.25000E+01  0.38000E+00  0.50000E+01  0.70000E+01  0.90000E+01
+  0.11000E+01  0.14000E+02  0.17000E+00  0.21000E+02  0.25000E+02  0.32000E+02
+  0.38000E+02  0.44000E+02  0.49000E+02  0.53000E+02  0.55000E+02  0.58000E+02
+  0.59000E+02  0.61000E+02  0.62000E+02  0.63000E+02  0.64000E+02  0.65000E+02
+  0.20000E-01  0.31000E-01  0.49000E-01  0.77000E-01  0.12000E+00  0.19000E+00
+  0.30000E+00  0.48000E+00  0.76000E+00  0.12000E+01  0.19000E+01  0.30000E+01
+  0.48000E+01  0.75000E+01  0.11000E+02  0.16000E+02  0.21000E+02  0.26000E+02
+  0.34000E+02  0.41000E+02  0.49000E+02  0.57000E+02  0.65000E+02  0.73000E+02
+  0.81000E+02  0.87000E+02  0.93000E+02  0.99000E+02  0.11000E+03  0.11000E+03
+  0.12000E+03  0.13000E+03  0.14000E+03  0.39000E-01  0.62000E-01  0.97000E-01
+  0.15000E+00  0.24000E+00  0.38000E+00  0.61000E+00  0.96000E+00  0.15000E+01
+  0.24000E+01  0.38000E+01  0.61000E+01  0.96000E+01  0.15000E+02  0.23000E+02
+  0.31000E+02  0.39000E+02  0.49000E+02  0.59000E+02  0.68000E+02  0.79000E+02
+  0.88000E+02  0.10000E+03  0.11000E+03  0.13000E+03  0.15000E+03  0.17000E+03
+  0.20000E+03  0.23000E+03  0.26000E+03  0.30000E+03  0.35000E+03  0.40000E+03
+  0.53000E-01  0.84000E-01  0.13000E+00  0.21000E+00  0.33000E+00  0.52000E+00
+  0.82000E+00  0.13000E+01  0.21000E+01  0.33000E+01  0.52000E+01  0.82000E+01
+  0.13000E+02  0.20000E+02  0.28000E+02  0.36000E+02  0.46000E+02  0.56000E+02
+  0.67000E+02  0.80000E+02  0.97000E+02  0.12000E+03  0.14000E+03  0.17000E+03
+  0.20000E+03  0.24000E+03  0.29000E+03  0.35000E+03  0.42000E+03  0.51000E+03
+  0.61000E+03  0.74000E+03  0.89000E+03
+
diff --git a/wrfv2_fire/run/wind-turbine-1.tbl b/wrfv2_fire/run/wind-turbine-1.tbl
new file mode 100644
index 00000000..6d678c3d
--- /dev/null
+++ b/wrfv2_fire/run/wind-turbine-1.tbl
@@ -0,0 +1,24 @@
+22
+75. 85. 0.130 2.0
+4.   0.805    50.0 
+5.   0.805   150.0  
+6.   0.805   280.0   
+7.   0.805   460.0   
+8.   0.805   700.0  
+9.   0.805   990.0   
+10.  0.790  1300.0  
+11.  0.740  1600.0   
+12.  0.700  1850.0   
+13.  0.400  1950.0  
+14.  0.300  1990.0  
+15.  0.250  1995.0   
+16.  0.200  2000.0   
+17.  0.160  2000.0 
+18.  0.140  2000.0  
+19.  0.120  2000.0  
+20.  0.100  2000.0   
+21.  0.080  2000.0 
+22.  0.070  2000.0  
+23.  0.060  2000.0
+24.  0.055  2000.0 
+25.  0.050  2000.0  
diff --git a/wrfv2_fire/share/dfi.F b/wrfv2_fire/share/dfi.F
index 06d95b76..2d86d05a 100644
--- a/wrfv2_fire/share/dfi.F
+++ b/wrfv2_fire/share/dfi.F
@@ -156,6 +156,7 @@ END SUBROUTINE rebalance_driver_dfi
       CALL nl_set_sf_urban_physics( grid%id, 0 )
       CALL nl_set_bl_pbl_physics( grid%id, 0 )
       CALL nl_set_cu_physics( grid%id, 0 )
+      CALL nl_set_cu_diag( grid%id, 0 )
       CALL nl_set_damp_opt( grid%id, 0 )
       CALL nl_set_sst_update( grid%id, 0 )
       CALL nl_set_fractional_seaice( grid%id, 0 )
@@ -173,14 +174,21 @@ END SUBROUTINE rebalance_driver_dfi
       CALL nl_set_chem_opt (grid%id, 0)
       CALL nl_set_aer_ra_feedback (grid%id, 0)
       CALL nl_set_io_form_auxinput5 (grid%id, 0)
+      CALL nl_set_io_form_auxinput6 (grid%id, 0)
       CALL nl_set_io_form_auxinput7 (grid%id, 0)
       CALL nl_set_io_form_auxinput8 (grid%id, 0)
+      CALL nl_set_io_form_auxinput13 (grid%id, 0)
+      CALL nl_set_io_form_auxinput14 (grid%id, 0)
+      CALL nl_set_io_form_auxinput15 (grid%id, 0)
 #endif
 
       ! set diffusion to zero for backward integration
 
 #if (EM_CORE == 1)
-      CALL nl_set_km_opt( grid%id, grid%km_opt_dfi)
+      grid%km_opt_dfi = grid%km_opt
+      grid%diff_opt_dfi = grid%diff_opt
+      CALL nl_set_km_opt( grid%id, 1) 
+      CALL nl_set_diff_opt( grid%id, 0) 
       CALL nl_set_moist_adv_dfi_opt( grid%id, grid%moist_adv_dfi_opt)
       IF ( grid%moist_adv_opt == 2 ) THEN
          CALL nl_set_moist_adv_opt( grid%id, 0)
@@ -327,6 +335,7 @@ END SUBROUTINE start_domain
       CALL nl_set_sf_urban_physics( grid%id, grid%sf_urban_physics)
       CALL nl_set_bl_pbl_physics( grid%id, grid%bl_pbl_physics)
       CALL nl_set_cu_physics( grid%id, grid%cu_physics)
+      CALL nl_set_cu_diag( grid%id, grid%cu_diag )
       CALL nl_set_damp_opt( grid%id, grid%damp_opt)
       CALL nl_set_sst_update( grid%id, 0)
       CALL nl_set_fractional_seaice( grid%id, grid%fractional_seaice)
@@ -380,7 +389,10 @@ END SUBROUTINE start_domain
 
 #if (EM_CORE == 1)
       ! reset km_opt to normal
-      CALL nl_set_km_opt( grid%id, grid%km_opt)
+      grid%km_opt = grid%km_opt_dfi
+      grid%diff_opt = grid%diff_opt_dfi
+      CALL nl_set_km_opt( grid%id, grid%km_opt_dfi)
+      CALL nl_set_diff_opt( grid%id, grid%diff_opt_dfi)
       CALL nl_set_moist_adv_opt( grid%id, grid%moist_adv_opt)
 #endif
 
@@ -470,8 +482,26 @@ END SUBROUTINE start_domain
       CALL nl_set_chem_opt( grid%id, grid%chem_opt)
       CALL nl_set_aer_ra_feedback (grid%id, grid%aer_ra_feedback)
       CALL nl_set_io_form_auxinput5 (grid%id, grid%io_form_auxinput5)
+      CALL nl_set_io_form_auxinput6 (grid%id, grid%io_form_auxinput6)
       CALL nl_set_io_form_auxinput7 (grid%id, grid%io_form_auxinput7)
       CALL nl_set_io_form_auxinput8 (grid%id, grid%io_form_auxinput8)
+      CALL nl_set_io_form_auxinput13(grid%id, grid%io_form_auxinput13)
+      CALL nl_set_io_form_auxinput14(grid%id, grid%io_form_auxinput14)
+      CALL nl_set_io_form_auxinput15(grid%id, grid%io_form_auxinput15)
+
+      ! This resets the open file handles associated with the chemistry
+      ! auxinputs.  It may be a good idea to do this with other auxinputs as well.
+      ! A better fix than the below may be to never assign the file handles to begin
+      ! with when running DFI.
+
+      grid%auxinput5_oid = 0
+      grid%auxinput6_oid = 0
+      grid%auxinput7_oid = 0
+      grid%auxinput8_oid = 0
+      grid%auxinput12_oid = 0
+      grid%auxinput13_oid = 0
+      grid%auxinput14_oid = 0
+      grid%auxinput15_oid = 0
 #endif
     
 #if (EM_CORE == 1)
@@ -2785,6 +2815,7 @@ END SUBROUTINE Setup_Timekeeping
       CALL nl_set_sf_urban_physics( grid%id, 0 )
       CALL nl_set_bl_pbl_physics( grid%id, 0 )
       CALL nl_set_cu_physics( grid%id, 0 )
+      CALL nl_set_cu_diag( grid%id, 0 )
       CALL nl_set_damp_opt( grid%id, 0 )
       CALL nl_set_sst_update( grid%id, 0 )
       CALL nl_set_gwd_opt( grid%id, 0 )
@@ -2803,13 +2834,20 @@ END SUBROUTINE Setup_Timekeeping
       CALL nl_set_chem_opt (grid%id, 0)
       CALL nl_set_aer_ra_feedback (grid%id, 0)
       CALL nl_set_io_form_auxinput5 (grid%id, 0)
+      CALL nl_set_io_form_auxinput6 (grid%id, 0)
       CALL nl_set_io_form_auxinput7 (grid%id, 0)
       CALL nl_set_io_form_auxinput8 (grid%id, 0)
+      CALL nl_set_io_form_auxinput13 (grid%id, 0)
+      CALL nl_set_io_form_auxinput14 (grid%id, 0)
+      CALL nl_set_io_form_auxinput15 (grid%id, 0)
 #endif
 
 #if (EM_CORE == 1)
       ! set diffusion to zero for backward integration
+      grid%km_opt_dfi = grid%km_opt
+      grid%diff_opt_dfi = grid%diff_opt
       CALL nl_set_km_opt( grid%id, grid%km_opt_dfi)
+      CALL nl_set_diff_opt( grid%id, grid%diff_opt_dfi)
       CALL nl_set_moist_adv_dfi_opt( grid%id, grid%moist_adv_dfi_opt)
       IF ( grid%moist_adv_opt == 2 ) THEN
          CALL nl_set_moist_adv_opt( grid%id, 0)
@@ -3354,9 +3392,9 @@ SUBROUTINE rebalance_dfi ( grid  &
 
                   grid%ph_2(i,1,j) = grid%phb(i,1,j)
                   DO k = 2,kte
-                     pfu = grid%mu0(i,j)*grid%znw(k)   + grid%p_top
-                     pfd = grid%mu0(i,j)*grid%znw(k-1) + grid%p_top
-                     phm = grid%mu0(i,j)*grid%znu(k-1) + grid%p_top
+                     pfu = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k)   + grid%p_top
+                     pfd = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k-1) + grid%p_top
+                     phm = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k-1) + grid%p_top
                      grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu)
                   END DO
 
diff --git a/wrfv2_fire/share/input_wrf.F b/wrfv2_fire/share/input_wrf.F
index b520cca2..e7a848e8 100644
--- a/wrfv2_fire/share/input_wrf.F
+++ b/wrfv2_fire/share/input_wrf.F
@@ -95,6 +95,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
     LOGICAL :: this_is_an_ideal_run
     INTEGER :: loop, hypsometric_opt
 
+    CHARACTER (LEN=256) :: a_message
+
 
 !
 !
@@ -156,13 +158,11 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
       END IF
 #endif
 
-! simulation start time is a Singleton maintained by head_grid
-    IF ( ( switch .EQ.     input_only  ) .OR. &
-         ( switch .EQ.          restart_only ) ) THEN
-
       ! INPUT ONLY (KK)
+
       IF ( switch .EQ. restart_only ) THEN
-        ! recover the restart alarms from input if avialable
+
+        ! recover the restart alarms from input if available
  
         CALL wrf_get_dom_ti_integer( fid , 'MAX_WRF_ALARMS', max_wrf_alarms_compare, 1, icnt, ierr )
         IF ( max_wrf_alarms_compare .NE. MAX_WRF_ALARMS ) THEN
@@ -184,6 +184,17 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
                 ! Get and set interval so that we are sure to have both the
                 ! interval and first ring time set correctly
                 CALL WRFU_AlarmGet( grid%alarms(i), ringinterval=interval2 )
+
+                IF (config_flags%override_restart_timers) THEN
+                   IF (i .EQ. restart_only) THEN
+                      seconds = grid%restart_interval_d * 86400 + &
+                                grid%restart_interval_h *  3600 + &
+                                grid%restart_interval_m *    60 + &
+                                grid%restart_interval   *    60 + &
+                                grid%restart_interval_s
+                   ENDIF
+                ENDIF
+
                 CALL WRFU_TimeIntervalSet(interval,S=seconds)
                 ringTime = curtime + interval
                 CALL WRFU_AlarmSet( grid%alarms(i), RingInterval=interval2, RingTime=ringTime )
@@ -199,11 +210,12 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
           ENDDO
         ENDIF
 
-      ENDIF
      
      !OUTPUT ONLY (KK)
+
       IF ( switch .EQ. restart_only .AND. .NOT. config_flags%override_restart_timers ) THEN
-        ! recover the restart alarms from input if avialable
+
+        ! recover the restart alarms from input if available
  
         CALL wrf_get_dom_ti_integer( fid , 'MAX_WRF_ALARMS', max_wrf_alarms_compare, 1, icnt, ierr )
         IF ( max_wrf_alarms_compare .NE. MAX_WRF_ALARMS ) THEN
@@ -225,9 +237,20 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
                 ! Get and set interval so that we are sure to have both the
                 ! interval and first ring time set correctly
                 CALL WRFU_AlarmGet( grid%alarms(i), ringinterval=interval2 )
+
+                IF (config_flags%override_restart_timers) THEN
+                   IF (i .EQ. history_only) THEN
+                      seconds = grid%history_interval_d * 86400 + &
+                                grid%history_interval_h *  3600 + &
+                                grid%history_interval_m *    60 + &
+                                grid%history_interval   *    60 + &
+                                grid%history_interval_s
+                   ENDIF
+                ENDIF
+
                 CALL WRFU_TimeIntervalSet(interval,S=seconds)
                 ringTime = curtime + interval
-                CALL WRFU_AlarmSet( grid%alarms(i), RingInterval=interval2, RingTime=ringTime )
+                CALL WRFU_AlarmSet( grid%alarms(i), RingInterval=interval, RingTime=ringTime )
 
               ENDIF
 
@@ -375,9 +398,16 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
     END IF
 
 #if (EM_CORE == 1)
-    IF ( switch .EQ. auxinput2_only ) THEN
+    IF ( ( switch .EQ. input_only ) .OR. ( switch .EQ. auxinput2_only ) .OR. ( switch .EQ. auxinput1_only ) ) THEN
        ierr = 0
-       CALL wrf_get_dom_ti_integer ( fid , 'I_PARENT_START' ,    itmp , 1 , icnt , ierr3 )
+       IF      ( ( switch .EQ. input_only ) .OR. ( switch .EQ. auxinput2_only ) ) THEN
+          CALL wrf_get_dom_ti_integer ( fid , 'I_PARENT_START' ,    itmp , 1 , icnt , ierr3 )
+       ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .GE. 2 ) ) THEN
+          CALL wrf_get_dom_ti_integer ( fid , 'i_parent_start' ,    itmp , 1 , icnt , ierr3 )
+       ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .EQ. 1 ) ) THEN
+          itmp  = config_flags%i_parent_start
+          ierr3 = 0 
+       END IF
        ierr = max( ierr, ierr3 )
        IF ( itmp .NE. config_flags%i_parent_start ) THEN
           ierr = 1
@@ -386,7 +416,14 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
           WRITE(wrf_err_message,*)'i_parent_start from gridded input file  = ',itmp
           CALL wrf_message(wrf_err_message)
        END IF
-       CALL wrf_get_dom_ti_integer ( fid , 'J_PARENT_START' ,    itmp , 1 , icnt , ierr3 )
+       IF      ( ( switch .EQ. input_only ) .OR. ( switch .EQ. auxinput2_only ) ) THEN
+          CALL wrf_get_dom_ti_integer ( fid , 'J_PARENT_START' ,    itmp , 1 , icnt , ierr3 )
+       ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .GE. 2 ) ) THEN
+          CALL wrf_get_dom_ti_integer ( fid , 'j_parent_start' ,    itmp , 1 , icnt , ierr3 )
+       ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .EQ. 1 ) ) THEN
+          itmp  = config_flags%j_parent_start
+          ierr3 = 0 
+       END IF
        ierr = max( ierr, ierr3 )
        IF ( itmp .NE. config_flags%j_parent_start ) THEN
           ierr = 1
@@ -498,9 +535,19 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
 
     CALL wrf_get_dom_ti_char ( fid , 'MMINLU', mminlu , ierr )
     IF ( ierr .NE. 0 ) THEN
-       WRITE(wrf_err_message,*)'MMINLU error on input'
-       CALL wrf_debug ( 0 , wrf_err_message )
-       mminlu = " "
+#ifdef WRF_CHEM
+      IF ( config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then
+        WRITE(wrf_err_message,*)'MMINLU error on input - will set mminlu to MODIFIED_IGBP_MODIS_NOAH in share/input_wrf.F'
+        mminlu = "MODIFIED_IGBP_MODIS_NOAH"
+      ELSE
+        WRITE(wrf_err_message,*)'MMINLU error on input'
+        mminlu = " "
+      ENDIF
+#else
+      WRITE(wrf_err_message,*)'MMINLU error on input'
+      mminlu = " "
+#endif
+      CALL wrf_debug ( 0 , wrf_err_message )
     ELSE IF ( ( ( mminlu(1:1) .GE. "A" ) .AND. ( mminlu(1:1) .LE. "Z" ) ) .OR. &
               ( ( mminlu(1:1) .GE. "a" ) .AND. ( mminlu(1:1) .LE. "z" ) ) .OR. &
               ( ( mminlu(1:1) .GE. "0" ) .AND. ( mminlu(1:1) .LE. "9" ) ) ) THEN
@@ -520,20 +567,26 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
     ! The default is set to 24 somewhere, from the number of categories
     ! in the traditional USGS dataset
 
-    call wrf_get_dom_ti_integer(fid, "NUM_LAND_CAT", num_land_cat_compare, 1, icnt, ierr)
-    if ( (ierr .NE. 0) .OR. ( num_land_cat_compare .LT. 1 ) .OR. ( num_land_cat_compare .GT. 1000 ) ) then
-       call wrf_debug( 1 , "Must be old WPS data, assuming 24 levels for NUM_LAND_CAT")
-       num_land_cat_compare = 24
-!      call wrf_error_fatal("Error trying to find global attribute 'NUM_LAND_CAT'")
-    endif
-    if ( config_flags%num_land_cat /= num_land_cat_compare ) then
-       call wrf_message("----------------- ERROR -------------------")
-       WRITE(wrf_err_message,'("namelist    : NUM_LAND_CAT = ",I10)') config_flags%num_land_cat
-       call wrf_message(wrf_err_message)
-       WRITE(wrf_err_message,'("input files : NUM_LAND_CAT = ",I10, " (from geogrid selections).")') num_land_cat_compare
-       call wrf_message(wrf_err_message)
-       call wrf_error_fatal("Mismatch between namelist and wrf input files for dimension NUM_LAND_CAT")
-    endif
+    IF ( switch .EQ. input_only ) THEN
+      call wrf_get_dom_ti_integer(fid, "NUM_LAND_CAT", num_land_cat_compare, 1, icnt, ierr)
+      if ( (ierr .NE. 0) .OR. ( num_land_cat_compare .LT. 1 ) .OR. ( num_land_cat_compare .GT. 1000 ) ) then
+        IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
+          call wrf_debug( 1 , "Must be old WPS data, assuming 20 levels for NUM_LAND_CAT")
+          num_land_cat_compare = 20
+        ELSE
+          call wrf_debug( 1 , "Must be old WPS data, assuming 24 levels for NUM_LAND_CAT")
+          num_land_cat_compare = 24
+        END IF
+      endif
+      if ( config_flags%num_land_cat /= num_land_cat_compare ) then
+        call wrf_message("----------------- ERROR -------------------")
+        WRITE(wrf_err_message,'("namelist    : NUM_LAND_CAT = ",I10)') config_flags%num_land_cat
+        call wrf_message(wrf_err_message)
+        WRITE(wrf_err_message,'("input files : NUM_LAND_CAT = ",I10, " (from geogrid selections).")') num_land_cat_compare
+        call wrf_message(wrf_err_message)
+        call wrf_error_fatal("Mismatch between namelist and wrf input files for dimension NUM_LAND_CAT")
+      endif
+    ENDIF
 
     ! Test here to check that config_flags%num_metgrid_soil_levels in namelist
     ! is equal to what is in the global attributes of the met_em files.  Note that
@@ -542,14 +595,14 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
     IF ( ( switch .EQ. auxinput1_only ) .AND. &
          ( first_date_nml .EQ. first_date_input ) )  THEN
        CALL wrf_get_dom_ti_integer ( fid, 'NUM_METGRID_SOIL_LEVELS', itmp, 1, icnt, ierr )
+   
+       IF ( ierr .EQ. 0 ) THEN
 
 #if (EM_CORE == 1)
-       IF ( itmp .EQ. 1 ) THEN
+          IF ( itmp .EQ. 1 ) THEN
              call wrf_error_fatal("NUM_METGRID_SOIL_LEVELS must be greater than 1")
-       END IF
+          END IF
 #endif
-   
-       IF ( ierr .EQ. 0 ) THEN
           WRITE(wrf_err_message,*)'input_wrf: global attribute NUM_METGRID_SOIL_LEVELS returns ', itmp
           CALL wrf_debug ( 300 , wrf_err_message )
           IF ( config_flags%num_metgrid_soil_levels /= itmp ) THEN
@@ -620,6 +673,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
     IF ( ierr .NE. 0 ) THEN
          IF (mminlu == 'UMD') THEN
               config_flags%iswater = 14
+         ELSE IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
+              config_flags%iswater = 17
          ELSE
               config_flags%iswater = 16
          ENDIF
@@ -642,6 +697,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
     IF ( ierr .NE.  0 ) THEN
          IF (mminlu == 'UMD') THEN
               config_flags%isice = 14
+         ELSE IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
+              config_flags%isice = 15
          ELSE
               config_flags%isice = 24
          ENDIF
@@ -655,6 +712,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
     IF ( ierr .NE. 0 ) THEN
          IF (mminlu == 'UMD') THEN
               config_flags%isurban = 13
+         ELSE IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN
+              config_flags%isurban = 13
          ELSE
               config_flags%isurban = 1
          ENDIF
@@ -865,7 +924,10 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
         CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time )
 #if (DA_CORE != 1)
         IF( currentTime .GE. grid%next_bdy_time ) THEN
-          IF ( wrf_dm_on_monitor() ) write(0,*) 'THIS TIME ',this_datestr(1:19),'NEXT TIME ',next_datestr(1:19)
+          IF ( wrf_dm_on_monitor() ) THEN
+             write(a_message,*) 'THIS TIME ',this_datestr(1:19),'NEXT TIME ',next_datestr(1:19)
+             CALL wrf_message ( a_message ) 
+          END IF
           RETURN
         ENDIF
 #endif
diff --git a/wrfv2_fire/share/interp_fcn.F b/wrfv2_fire/share/interp_fcn.F
index f0a2eaa3..3715101d 100644
--- a/wrfv2_fire/share/interp_fcn.F
+++ b/wrfv2_fire/share/interp_fcn.F
@@ -46,7 +46,7 @@ SUBROUTINE interp_fcn ( cfld,                                 &  ! CD field
 !logical first
 
      INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, nioff, njoff
-#ifdef MM5_SINT
+#if (( DA_CORE == 1 ) || ( defined( MM5_SINT ) ) )
      INTEGER nfx, ior
      PARAMETER (ior=2)
      INTEGER nf
@@ -59,7 +59,7 @@ SUBROUTINE interp_fcn ( cfld,                                 &  ! CD field
      ! Iterate over the ND tile and compute the values
      ! from the CD tile. 
 
-#ifdef MM5_SINT
+#if ( ( DA_CORE == 1 ) || ( defined( MM5_SINT ) ) )
 
      ioff  = 0 ; joff  = 0
      nioff = 0 ; njoff = 0
@@ -393,32 +393,44 @@ SUBROUTINE interp_fcn_bl ( cfld,                                 &  ! CD field
 
               IF      ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN
                  cprs(:) =   cpb(ci  ,:,cj  )
-                 cfld_ll = v_interp_col ( cfld(ci  ,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj  , cfld_max_p(ci  ,cj  ) , cmax_p(ci  ,cj  ) , cfld_min_p(ci  ,cj  ) , cmin_p(ci  ,cj  ) )
+                 cfld_ll = v_interp_col ( cfld(ci  ,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj  , &
+                                          cfld_max_p(ci  ,cj  ) , cmax_p(ci  ,cj  ) , cfld_min_p(ci  ,cj  ) , cmin_p(ci  ,cj  ) )
                  cprs(:) =   cpb(ci+1,:,cj  )
-                 cfld_lr = v_interp_col ( cfld(ci+1,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj  , cfld_max_p(ci+1,cj  ) , cmax_p(ci+1,cj  ) , cfld_min_p(ci+1,cj  ) , cmin_p(ci+1,cj  ) )
+                 cfld_lr = v_interp_col ( cfld(ci+1,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj  , &
+                                          cfld_max_p(ci+1,cj  ) , cmax_p(ci+1,cj  ) , cfld_min_p(ci+1,cj  ) , cmin_p(ci+1,cj  ) )
                  cprs(:) =   cpb(ci  ,:,cj+1)
-                 cfld_ul = v_interp_col ( cfld(ci  ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj+1, cfld_max_p(ci  ,cj+1) , cmax_p(ci  ,cj+1) , cfld_min_p(ci  ,cj+1) , cmin_p(ci  ,cj+1) )
+                 cfld_ul = v_interp_col ( cfld(ci  ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj+1, &
+                                          cfld_max_p(ci  ,cj+1) , cmax_p(ci  ,cj+1) , cfld_min_p(ci  ,cj+1) , cmin_p(ci  ,cj+1) )
                  cprs(:) =   cpb(ci+1,:,cj+1)
-                 cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) )
+                 cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, &
+                                          cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) )
 
               ELSE IF ( xstag ) THEN
                  cprs(:) = ( cpb(ci  ,:,cj  ) + cpb(ci-1,:,cj  ) )*0.5 
-                 cfld_ll = v_interp_col ( cfld(ci  ,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj  , cfld_max_p(ci  ,cj  ) , cmax_p(ci  ,cj  ) , cfld_min_p(ci  ,cj  ) , cmin_p(ci  ,cj  ) )
+                 cfld_ll = v_interp_col ( cfld(ci  ,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj  , &
+                                          cfld_max_p(ci  ,cj  ) , cmax_p(ci  ,cj  ) , cfld_min_p(ci  ,cj  ) , cmin_p(ci  ,cj  ) )
                  cprs(:) = ( cpb(ci+1,:,cj  ) + cpb(ci  ,:,cj  ) )*0.5
-                 cfld_lr = v_interp_col ( cfld(ci+1,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj  , cfld_max_p(ci+1,cj  ) , cmax_p(ci+1,cj  ) , cfld_min_p(ci+1,cj  ) , cmin_p(ci+1,cj  ) )
+                 cfld_lr = v_interp_col ( cfld(ci+1,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj  , &
+                                          cfld_max_p(ci+1,cj  ) , cmax_p(ci+1,cj  ) , cfld_min_p(ci+1,cj  ) , cmin_p(ci+1,cj  ) )
                  cprs(:) = ( cpb(ci  ,:,cj+1) + cpb(ci-1,:,cj+1) )*0.5
-                 cfld_ul = v_interp_col ( cfld(ci  ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj+1, cfld_max_p(ci  ,cj+1) , cmax_p(ci  ,cj+1) , cfld_min_p(ci  ,cj+1) , cmin_p(ci  ,cj+1) )
+                 cfld_ul = v_interp_col ( cfld(ci  ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj+1, &
+                                          cfld_max_p(ci  ,cj+1) , cmax_p(ci  ,cj+1) , cfld_min_p(ci  ,cj+1) , cmin_p(ci  ,cj+1) )
                  cprs(:) = ( cpb(ci+1,:,cj+1) + cpb(ci  ,:,cj+1) )*0.5
-                 cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) )
+                 cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, &
+                                          cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) )
               ELSE IF ( ystag ) THEN
                  cprs(:) = ( cpb(ci  ,:,cj  ) + cpb(ci  ,:,cj-1) )*0.5
-                 cfld_ll = v_interp_col ( cfld(ci  ,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj  , cfld_max_p(ci  ,cj  ) , cmax_p(ci  ,cj  ) , cfld_min_p(ci  ,cj  ) , cmin_p(ci  ,cj  ) )
+                 cfld_ll = v_interp_col ( cfld(ci  ,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj  , &
+                                          cfld_max_p(ci  ,cj  ) , cmax_p(ci  ,cj  ) , cfld_min_p(ci  ,cj  ) , cmin_p(ci  ,cj  ) )
                  cprs(:) = ( cpb(ci+1,:,cj  ) + cpb(ci+1,:,cj-1) )*0.5
-                 cfld_lr = v_interp_col ( cfld(ci+1,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj  , cfld_max_p(ci+1,cj  ) , cmax_p(ci+1,cj  ) , cfld_min_p(ci+1,cj  ) , cmin_p(ci+1,cj  ) )
+                 cfld_lr = v_interp_col ( cfld(ci+1,:,cj  ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj  , &
+                                          cfld_max_p(ci+1,cj  ) , cmax_p(ci+1,cj  ) , cfld_min_p(ci+1,cj  ) , cmin_p(ci+1,cj  ) )
                  cprs(:) = ( cpb(ci  ,:,cj+1) + cpb(ci  ,:,cj  ) )*0.5
-                 cfld_ul = v_interp_col ( cfld(ci  ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj+1, cfld_max_p(ci  ,cj+1) , cmax_p(ci  ,cj+1) , cfld_min_p(ci  ,cj+1) , cmin_p(ci  ,cj+1) )
+                 cfld_ul = v_interp_col ( cfld(ci  ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci  , cj+1, &
+                                          cfld_max_p(ci  ,cj+1) , cmax_p(ci  ,cj+1) , cfld_min_p(ci  ,cj+1) , cmin_p(ci  ,cj+1) )
                  cprs(:) = ( cpb(ci+1,:,cj+1) + cpb(ci+1,:,cj  ) )*0.5
-                 cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) )
+                 cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, &
+                                          cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) )
               END IF
 
               !  Bilinear interpolation in horizontal with vertically corrected CG field values.
@@ -444,7 +456,8 @@ END SUBROUTINE interp_fcn_bl
 
 !==================================
 
-   FUNCTION v_interp_col ( cfld_orig , cprs_orig , ckms , ckme , ckte , nprs, ni, nj, nk, ci, cj, cfld_max_p , cmax_p , cfld_min_p , cmin_p ) RESULT ( cfld_interp )
+   FUNCTION v_interp_col ( cfld_orig , cprs_orig , ckms , ckme , ckte , nprs, ni, nj, nk, ci, cj, &
+                           cfld_max_p , cmax_p , cfld_min_p , cmin_p ) RESULT ( cfld_interp )
 
       IMPLICIT NONE
 
@@ -1299,10 +1312,10 @@ SUBROUTINE bdy_interp1( cfld,                                 &  ! CD field
 
      ioff  = 0 ; joff  = 0
      IF ( xstag ) THEN 
-       ioff = (nri-1)/2
+       ioff = MAX((nri-1)/2,1)
      ENDIF
      IF ( ystag ) THEN
-       joff = (nrj-1)/2
+       joff = MAX((nrj-1)/2,1)
      ENDIF
 
      ! Iterate over the ND tile and compute the values
@@ -1473,6 +1486,7 @@ SUBROUTINE interp_fcni( cfld,                                 &  ! CD field
         DO nk = nkts, nkte
            ck = nk
            DO ni = nits, nite
+              if ( imask(ni,nj) .NE. 1 ) cycle
               ci = ipos + (ni-1) / nri      ! j coord of CD point 
               ip = mod ( ni , nri )  ! coord of ND w/i CD point
               ! This is a trivial implementation of the interp_fcn; just copies
@@ -1547,6 +1561,213 @@ SUBROUTINE interp_fcnm( cfld,                                 &  ! CD field
 
    END SUBROUTINE interp_fcnm
 
+   SUBROUTINE interp_fcnm_lu( cfld,                              &  ! CD field
+                           cids, cide, ckds, ckde, cjds, cjde,   &
+                           cims, cime, ckms, ckme, cjms, cjme,   &
+                           cits, cite, ckts, ckte, cjts, cjte,   &
+                           nfld,                                 &  ! ND field
+                           nids, nide, nkds, nkde, njds, njde,   &
+                           nims, nime, nkms, nkme, njms, njme,   &
+                           nits, nite, nkts, nkte, njts, njte,   &
+                           shw,                                  &  ! stencil half width
+                           imask,                                &  ! interpolation mask
+                           xstag, ystag,                         &  ! staggering of field
+                           ipos, jpos,                           &  ! Position of lower left of nest in CD
+                           nri, nrj,                             &  ! nest ratios
+                           cxlat,    nxlat,                      &
+                           cxlong,   nxlong,                     &
+                           cdx, ndx,                             &
+                           cid, nid                            ) 
+     USE module_configure
+
+     IMPLICIT NONE
+
+
+     INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
+                            cims, cime, ckms, ckme, cjms, cjme,   &
+                            cits, cite, ckts, ckte, cjts, cjte,   &
+                            nids, nide, nkds, nkde, njds, njde,   &
+                            nims, nime, nkms, nkme, njms, njme,   &
+                            nits, nite, nkts, nkte, njts, njte,   &
+                            shw,                                  &
+                            ipos, jpos,                           &
+                            nri, nrj,                             &
+                            cid, nid
+     LOGICAL, INTENT(IN) :: xstag, ystag 
+
+     REAL,    INTENT(IN) :: cdx, ndx
+
+     REAL,    INTENT(IN),  DIMENSION ( cims:cime, cjms:cjme ) :: cxlat, cxlong
+     REAL,    INTENT(IN),  DIMENSION ( nims:nime, njms:njme ) :: nxlat, nxlong
+
+
+     REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
+     REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
+     INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
+
+     ! Local
+
+     INTEGER i, ci, cj, ck, ni, nj, nk, ip, jp, ierr
+
+#ifdef TERRAIN_AND_LANDUSE
+     INTEGER, DIMENSION(256) :: ipath  ! array for integer coded ascii for passing path down to get_landuse
+
+     REAL , ALLOCATABLE, DIMENSION(:,:) :: xlat_g, xlon_g, landuse_g
+     CHARACTER*256 :: message 
+     CHARACTER*256 :: rsmas_data_path
+
+     LOGICAL :: input_from_hires, input_from_file
+
+     INTEGER, EXTERNAL :: get_landuse
+     LOGICAL, EXTERNAL :: wrf_dm_on_monitor
+
+     CALL nl_get_input_from_hires( nid , input_from_hires)
+     CALL nl_get_input_from_file ( nid , input_from_file )
+
+     IF ( input_from_file .AND. input_from_hires ) THEN
+       Write(message, '(a,i3,a)') & 
+          "Warning : input_from_file turned on for domain ", nid, ", input_from_hires disabled"
+       CALL wrf_message(message)
+     END IF
+
+     IF ( .NOT. input_from_file .AND. input_from_hires ) THEN
+
+       allocate(xlat_g(nids:nide,njds:njde))
+       allocate(xlon_g(nids:nide,njds:njde))
+       allocate(landuse_g(nids:nide,njds:njde))
+
+       CALL nl_get_rsmas_data_path(1,rsmas_data_path)
+
+       DO i = 1, LEN(TRIM(rsmas_data_path))
+          ipath(i) = ICHAR(rsmas_data_path(i:i))
+       ENDDO
+
+#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
+       CALL wrf_patch_to_global_real ( nxlat, xlat_g , nid, ' ' , 'xy' ,   &
+                                       nids, nide-1 , njds , njde-1 , 1 , 1 ,             &
+                                       nims, nime   , njms , njme   , 1 , 1 ,             &
+                                       nits, nite   , njts , njte   , 1 , 1   )
+       CALL wrf_patch_to_global_real ( nxlong, xlon_g, nid, ' ' , 'xy' ,   &
+                                       nids, nide-1 , njds , njde-1 , 1 , 1 ,             &
+                                       nims, nime   , njms , njme   , 1 , 1 ,             &
+                                       nits, nite   , njts , njte   , 1 , 1   )
+       IF ( wrf_dm_on_monitor() ) THEN
+         ierr = get_landuse ( ndx/1000., xlat_g, xlon_g, &
+                              landuse_g,                                        &
+                              nide-nids+1,njde-njds+1,nide-nids+1,njde-njds+1,  &
+                              ipath, LEN(TRIM(rsmas_data_path)) )
+         IF ( ierr == 1 ) THEN
+            WRITE(message,fmt='(a)') 'get_landuse : aborted!'
+            CALL wrf_error_fatal(TRIM(message))
+         ENDIF
+       ENDIF
+
+       CALL wrf_global_to_patch_real ( landuse_g , nfld(:,1,:), nid, ' ' , 'xy' ,  &
+                                      nids, nide-1 , njds , njde-1 , 1 , 1 ,    &
+                                      nims, nime   , njms , njme   , 1 , 1 ,    &
+                                      nits, nite   , njts , njte   , 1 , 1   )
+
+#else
+       ierr = get_landuse ( ndx/1000., nxlat(nids:nide,njds:njde), nxlong(nids:nide,njds:njde),  &
+                            nfld(nids:nide,1,njds:njde),                                         &
+                            nide-nids+1,njde-njds+1,nide-nids+1,njde-njds+1,                     &
+                            ipath, LEN(TRIM(rsmas_data_path)) )
+#endif
+       deallocate(xlat_g)
+       deallocate(xlon_g)
+       deallocate(landuse_g)
+     ELSE
+#endif
+   ! Iterate over the ND tile and compute the values
+   ! from the CD tile.
+     DO nj = njts, njte
+        cj = jpos + (nj-1) / nrj     ! j coord of CD point
+        jp = mod ( nj , nrj )  ! coord of ND w/i CD point
+        DO nk = nkts, nkte
+           ck = nk
+           DO ni = nits, nite
+              ci = ipos + (ni-1) / nri      ! j coord of CD point
+              ip = mod ( ni , nri )  ! coord of ND w/i CD point
+              ! This is a trivial implementation of the interp_fcn; just copies
+              ! the values from the CD into the ND
+              if ( imask(ni,nj) .eq. 1 ) then
+               nfld( ni, nk, nj ) = cfld( ci , ck , cj )
+              endif
+           ENDDO
+        ENDDO
+     ENDDO
+#ifdef TERRAIN_AND_LANDUSE
+     END IF
+#endif
+     RETURN
+
+   END SUBROUTINE interp_fcnm_lu
+
+
+   SUBROUTINE interp_fcnm_imask( cfld,                           &  ! CD field
+                           cids, cide, ckds, ckde, cjds, cjde,   &
+                           cims, cime, ckms, ckme, cjms, cjme,   &
+                           cits, cite, ckts, ckte, cjts, cjte,   &
+                           nfld,                                 &  ! ND field
+                           nids, nide, nkds, nkde, njds, njde,   &
+                           nims, nime, nkms, nkme, njms, njme,   &
+                           nits, nite, nkts, nkte, njts, njte,   &
+                           shw,                                  &  ! stencil half width
+                           imask,                                &  ! interpolation mask
+                           xstag, ystag,                         &  ! staggering of field
+                           ipos, jpos,                           &  ! Position of lower left of nest in CD
+                           nri, nrj                             )   ! nest ratios
+     USE module_configure
+     IMPLICIT NONE
+
+
+     INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
+                            cims, cime, ckms, ckme, cjms, cjme,   &
+                            cits, cite, ckts, ckte, cjts, cjte,   &
+                            nids, nide, nkds, nkde, njds, njde,   &
+                            nims, nime, nkms, nkme, njms, njme,   &
+                            nits, nite, nkts, nkte, njts, njte,   &
+                            shw,                                  &
+                            ipos, jpos,                           &
+                            nri, nrj
+     LOGICAL, INTENT(IN) :: xstag, ystag
+
+     REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
+     REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
+     INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
+
+     ! Local
+
+     INTEGER ci, cj, ck, ni, nj, nk, ip, jp
+
+     ! Iterate over the ND tile and compute the values
+     ! from the CD tile. 
+
+!write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte,cjts,cjte
+!write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte,njts,njte
+
+     DO nj = njts, njte
+        cj = jpos + (nj-1) / nrj     ! j coord of CD point 
+        jp = mod ( nj , nrj )  ! coord of ND w/i CD point
+        DO nk = nkts, nkte
+           ck = nk
+           DO ni = nits, nite
+              ci = ipos + (ni-1) / nri      ! j coord of CD point 
+              ip = mod ( ni , nri )  ! coord of ND w/i CD point
+              ! This is a trivial implementation of the interp_fcn; just copies
+              ! the values from the CD into the ND
+              if ( imask(ni,nj) .eq. 1 ) then
+               nfld( ni, nk, nj ) = cfld( ci , ck , cj )
+              endif
+           ENDDO
+        ENDDO
+     ENDDO
+
+     RETURN
+
+   END SUBROUTINE interp_fcnm_imask
+
+
    SUBROUTINE interp_mask_land_field ( enable,                   &  ! says whether to allow interpolation or just the bcasts
                                        cfld,                     &  ! CD field
                            cids, cide, ckds, ckde, cjds, cjde,   &
@@ -1565,6 +1786,7 @@ SUBROUTINE interp_mask_land_field ( enable,                   &  ! says whether
 
       USE module_configure
       USE module_wrf_error
+      USE module_dm, only : wrf_dm_sum_reals, wrf_dm_sum_integers
 
       IMPLICIT NONE
    
@@ -1591,10 +1813,12 @@ SUBROUTINE interp_mask_land_field ( enable,                   &  ! says whether
       ! Local
    
       INTEGER ci, cj, ck, ni, nj, nk, ip, jp
-      INTEGER :: icount , ii , jj , ist , ien , jst , jen , iswater
+      INTEGER :: icount , ii , jj , ist , ien , jst , jen , iswater, ierr
       REAL :: avg , sum , dx , dy
       INTEGER , PARAMETER :: max_search = 5
-      CHARACTER*120 message
+      CHARACTER(LEN=255) :: message
+      INTEGER :: icount_n(nkts:nkte), idummy(nkts:nkte)
+      REAL :: avg_n(nkts:nkte), sum_n(nkts:nkte), dummy(nkts:nkte)
    
       !  Find out what the water value is.
    
@@ -1617,6 +1841,7 @@ SUBROUTINE interp_mask_land_field ( enable,                   &  ! says whether
             DO nk = nkts, nkte
                ck = nk
                DO ni = nits, nite
+                  IF ( imask(ni, nj) .NE. 1 ) cycle
                   IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
                      ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
                   ELSE
@@ -1712,27 +1937,33 @@ SUBROUTINE interp_mask_land_field ( enable,                   &  ! says whether
 
          !  Get an average of the whole domain for problem locations.
 
-         sum = 0
-         icount = 0 
+         sum_n     = 0
+         icount_n  = 0
          DO nj = njts, njte
             DO nk = nkts, nkte
                DO ni = nits, nite
                   IF ( nfld(ni,nk,nj) .NE. -1 ) THEN
-                     icount = icount + 1
-                     sum = sum + nfld(ni,nk,nj)
+                     IF ( NINT(nlu(ni,nj)) .NE. iswater ) THEN
+                       icount_n(nk)  = icount_n(nk) + 1
+                       sum_n(nk) = sum_n(nk) + nfld(ni,nk,nj)
+                     END IF
                   END IF
                END DO
             END DO
          END DO
-       ELSE
-         sum = 0.
-         icount = 0
+
+         CALL wrf_dm_sum_reals(      sum_n(nkts:nkte),  dummy(nkts:nkte))
+         sum_n    = dummy
+         CALL wrf_dm_sum_integers(icount_n(nkts:nkte), idummy(nkts:nkte))
+         icount_n = idummy
+         DO nk = nkts, nkte
+            IF ( icount_n(nk) .GT. 0 )  &
+              avg_n(nk)  = sum_n(nk) / icount_n(nk)
+         END DO
        ENDIF
-       CALL wrf_dm_bcast_real( sum, 1 )
-       CALL wrf_dm_bcast_integer( icount, 1 )
+
        IF ( enable ) THEN
-         IF ( icount .GT. 0 ) THEN
-           avg = sum / REAL ( icount ) 
+         IF ( ANY(nfld .EQ. -1) ) THEN
 
          !  OK, if there were any of those island situations, we try to search a bit broader
          !  of an area in the coarse grid.
@@ -1740,6 +1971,7 @@ SUBROUTINE interp_mask_land_field ( enable,                   &  ! says whether
            DO nj = njts, njte
               DO nk = nkts, nkte
                  DO ni = nits, nite
+                    IF ( imask(ni, nj) .NE. 1 ) cycle
                     IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN
                        IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
                           cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
@@ -1768,10 +2000,10 @@ SUBROUTINE interp_mask_land_field ( enable,                   &  ! says whether
                        IF ( icount .GT. 0 ) THEN
                           nfld(ni,nk,nj) = sum / REAL ( icount ) 
                        ELSE
-!                         CALL wrf_error_fatal ( "horizontal interp error - island" )
-                          write(message,*) 'horizontal interp error - island, using average ', avg
+                          Write(message,fmt='(a,i4,a,i4,a,f10.4)') &
+                            'horizontal interp error - island (', ni, ',', nj, '), using average ', avg_n(nk)
                           CALL wrf_message ( message )
-                          nfld(ni,nk,nj) = avg
+                          nfld(ni,nk,nj) = avg_n(nk)
                        END IF        
                     END IF
                  END DO
@@ -1803,6 +2035,7 @@ SUBROUTINE interp_mask_water_field ( enable,                  &  ! says whether
 
       USE module_configure
       USE module_wrf_error
+      USE module_dm, only : wrf_dm_sum_reals, wrf_dm_sum_integers
 
       IMPLICIT NONE
    
@@ -1829,9 +2062,12 @@ SUBROUTINE interp_mask_water_field ( enable,                  &  ! says whether
       ! Local
    
       INTEGER ci, cj, ck, ni, nj, nk, ip, jp
-      INTEGER :: icount , ii , jj , ist , ien , jst , jen
+      INTEGER :: icount , ii , jj , ist , ien , jst , jen, ierr
       REAL :: avg , sum , dx , dy
       INTEGER , PARAMETER :: max_search = 5
+      INTEGER :: icount_n(nkts:nkte), idummy(nkts:nkte)
+      REAL :: avg_n(nkts:nkte), sum_n(nkts:nkte), dummy(nkts:nkte)
+      CHARACTER(LEN=255) :: message
 
       !  Right now, only mass point locations permitted.
    
@@ -1849,6 +2085,7 @@ SUBROUTINE interp_mask_water_field ( enable,                  &  ! says whether
             DO nk = nkts, nkte
                ck = nk
                DO ni = nits, nite
+!dave             IF ( imask(ni, nj) .NE. 1 ) cycle
                   IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
                      ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point
                   ELSE
@@ -1943,28 +2180,33 @@ SUBROUTINE interp_mask_water_field ( enable,                  &  ! says whether
 
          !  Get an average of the whole domain for problem locations.
 
-         sum = 0
-         icount = 0 
+         sum_n     = 0
+         icount_n  = 0
          DO nj = njts, njte
             DO nk = nkts, nkte
                DO ni = nits, nite
                   IF ( nfld(ni,nk,nj) .NE. -1 ) THEN
-                     icount = icount + 1
-                     sum = sum + nfld(ni,nk,nj)
+                     IF ( NINT(nlu(ni,nj)) .EQ. nflag ) THEN
+                       icount_n(nk)  = icount_n(nk) + 1
+                       sum_n(nk) = sum_n(nk) + nfld(ni,nk,nj)
+                     END IF
                   END IF
                END DO
             END DO
          END DO
-       ELSE
-         sum = 0.
-         icount = 0
+
+         CALL wrf_dm_sum_reals(      sum_n(nkts:nkte),  dummy(nkts:nkte))
+         sum_n    = dummy
+         CALL wrf_dm_sum_integers(icount_n(nkts:nkte), idummy(nkts:nkte))
+         icount_n = idummy
+         DO nk = nkts, nkte
+            IF ( icount_n(nk) .GT. 0 )  &
+              avg_n(nk)  = sum_n(nk) / icount_n(nk)
+         END DO
        ENDIF
-       CALL wrf_dm_bcast_real( sum, 1 )
-       CALL wrf_dm_bcast_integer( icount, 1 )
-       IF ( enable ) THEN
-         IF ( icount .NE. 0 ) THEN
-           avg = sum / REAL ( icount ) 
 
+       IF ( enable ) THEN
+         IF ( ANY(nfld .EQ. -1) ) THEN
 
            !  OK, if there were any of those lake situations, we try to search a bit broader
            !  of an area in the coarse grid.
@@ -1972,6 +2214,7 @@ SUBROUTINE interp_mask_water_field ( enable,                  &  ! says whether
            DO nj = njts, njte
               DO nk = nkts, nkte
                  DO ni = nits, nite
+!dave               IF ( imask(ni, nj) .NE. 1 ) cycle
                     IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN
                        IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
                           cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point
@@ -2000,9 +2243,10 @@ SUBROUTINE interp_mask_water_field ( enable,                  &  ! says whether
                        IF ( icount .GT. 0 ) THEN
                           nfld(ni,nk,nj) = sum / REAL ( icount ) 
                        ELSE
-  !                       CALL wrf_error_fatal ( "horizontal interp error - lake" )
-                          print *,'horizontal interp error - lake, using average ',avg
-                          nfld(ni,nk,nj) = avg
+                         Write(message,fmt='(a,i4,a,i4,a,f10.4)') &
+                            'horizontal interp error - lake (', ni, ',', nj, '), using average ', avg_n(nk)
+                         CALL wrf_message ( message )                         
+                          nfld(ni,nk,nj) = avg_n(nk)
                        END IF        
                     END IF
                  END DO
@@ -2543,6 +2787,7 @@ SUBROUTINE interp_mass_nmm (cfld,                                 &  ! CD field
    REAL                                                       :: dlnpdz,tvout,pmo
    REAL,DIMENSION(nims:nime,njms:njme)                        :: ZS,DUM2d
    REAL,DIMENSION(JTB)                                        :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2
+   CHARACTER (LEN=256) :: a_message
 !-----------------------------------------------------------------------------------------------------
 !
 !*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION
@@ -2637,7 +2882,8 @@ SUBROUTINE interp_mass_nmm (cfld,                                 &  ! CD field
             ENDDO
           ENDIF
           IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN
-             WRITE(0,*)'I=',I,'J=',J,'K=',KZMAX,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
+             WRITE(a_message,*)'I=',I,'J=',J,'K=',KZMAX,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
+             CALL wrf_message ( a_message )                
              CALL wrf_error_fatal3 ( "interp_fcn.b" , 176 , "MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
           ENDIF
 !       
@@ -2750,6 +2996,7 @@ SUBROUTINE nmm_bdymass_hinterp ( cfld,                              &  ! CD fiel
   INTEGER,PARAMETER                                                :: JTB=134
   INTEGER                                                          :: ii,jj
   REAL, DIMENSION (nims:nime,njms:njme)                            :: CWK1,CWK2,CWK3,CWK4
+  CHARACTER (LEN=256) :: a_message
 
      nijds = min(nids, njds)
      nijde = max(nide, njde)
@@ -2803,7 +3050,8 @@ SUBROUTINE nmm_bdymass_hinterp ( cfld,                              &  ! CD fiel
               ENDDO
             ENDIF
             IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN
-               WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
+               WRITE(a_message,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
+               CALL wrf_message ( a_message )              
                CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
             ENDIF
           ELSE
@@ -2858,7 +3106,8 @@ SUBROUTINE nmm_bdymass_hinterp ( cfld,                              &  ! CD fiel
               ENDDO
             ENDIF
             IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN
-               WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
+               WRITE(a_message,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
+               CALL wrf_message ( a_message )              
                CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
             ENDIF
           ELSE
@@ -2910,7 +3159,8 @@ SUBROUTINE nmm_bdymass_hinterp ( cfld,                              &  ! CD fiel
               ENDDO
           ENDIF
           IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN
-             WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
+             WRITE(a_message,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
+             CALL wrf_message ( a_message )                
              CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
           ENDIF
         ENDDO
@@ -2960,7 +3210,8 @@ SUBROUTINE nmm_bdymass_hinterp ( cfld,                              &  ! CD fiel
               ENDDO
           ENDIF
           IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN
-             WRITE(0,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
+             WRITE(a_message,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX)
+             CALL wrf_message ( a_message )                
              CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH")
           ENDIF
         ENDDO
@@ -3052,6 +3303,7 @@ SUBROUTINE interp_scalar_nmm (cfld,                               &  ! CD field
    INTEGER,PARAMETER                                         :: JTB=134
    INTEGER                                                   :: I,J,K
    REAL,DIMENSION(JTB)                                       :: PIN,CIN,Y2,PIO,PTMP,COUT,DUM1,DUM2
+   CHARACTER (LEN=256) :: a_message
 
 !-----------------------------------------------------------------------------------------------------
 !
@@ -3131,8 +3383,10 @@ SUBROUTINE interp_scalar_nmm (cfld,                               &  ! CD field
 
          IF(PTMP(1) .GE. PSTD(1))THEN           ! if lower boundary is higher than PMSL(1) re-set lower boundary
            PIN(NKDE-1) = PIO(1)                 ! be consistent with target. This may not happen at all
-           WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
-           WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
+           WRITE(a_message,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
+           CALL wrf_message ( a_message )                  
+           WRITE(a_message,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
+           CALL wrf_message ( a_message )                  
          ENDIF
 
          CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2)  ! interpolate
@@ -3233,6 +3487,7 @@ SUBROUTINE  nmm_bdy_scalar (cfld,                               &  ! CD field
    INTEGER                                                 :: I,J,K,II,JJ
    REAL,DIMENSION(JTB)                                     :: PIN,CIN,Y2,PIO,PTMP,COUT,DUM1,DUM2
    REAL, DIMENSION (nims:nime,njms:njme,nkms:nkme)         :: CWK1,CWK2,CWK3,CWK4
+   CHARACTER (LEN=256) :: a_message
 !-----------------------------------------------------------------------------------------------------
 !
 !
@@ -3279,8 +3534,10 @@ SUBROUTINE  nmm_bdy_scalar (cfld,                               &  ! CD field
          ENDDO
          IF(PTMP(1) .GE. PSTD(1))THEN           ! if lower boundary is higher than PMSL(1) re-set lower boundary
            PIN(NKDE-1) = PIO(1)                 ! be consistent with target. This may not happen at all
-           WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
-           WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
+           WRITE(a_message,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
+           CALL wrf_message ( a_message )                  
+           WRITE(a_message,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
+           CALL wrf_message ( a_message )                  
          ENDIF
 
          CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2)  ! interpolate
@@ -3343,8 +3600,10 @@ SUBROUTINE  nmm_bdy_scalar (cfld,                               &  ! CD field
          ENDDO
          IF(PTMP(1) .GE. PSTD(1))THEN           ! if lower boundary is higher than PMSL(1) re-set lower boundary
            PIN(NKDE-1) = PIO(1)                 ! be consistent with target. This may not happen at all
-           WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
-           WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
+           WRITE(a_message,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
+           CALL wrf_message ( a_message )                  
+           WRITE(a_message,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
+           CALL wrf_message ( a_message )                  
          ENDIF
 
          CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2)  ! interpolate
@@ -3406,8 +3665,10 @@ SUBROUTINE  nmm_bdy_scalar (cfld,                               &  ! CD field
          ENDDO
          IF(PTMP(1) .GE. PSTD(1))THEN           ! if lower boundary is higher than PMSL(1) re-set lower boundary
            PIN(NKDE-1) = PIO(1)                 ! be consistent with target. This may not happen at all
-           WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
-           WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
+           WRITE(a_message,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
+           CALL wrf_message ( a_message )                  
+           WRITE(a_message,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
+           CALL wrf_message ( a_message )                  
          ENDIF
 
          CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2)  ! interpolate
@@ -3464,8 +3725,10 @@ SUBROUTINE  nmm_bdy_scalar (cfld,                               &  ! CD field
          ENDDO
          IF(PTMP(1) .GE. PSTD(1))THEN           ! if lower boundary is higher than PMSL(1) re-set lower boundary
            PIN(NKDE-1) = PIO(1)                 ! be consistent with target. This may not happen at all
-           WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
-           WRITE(0,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
+           WRITE(a_message,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
+           CALL wrf_message ( a_message )                  
+           WRITE(a_message,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1)
+           CALL wrf_message ( a_message )                  
          ENDIF
 
          CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2)  ! interpolate
@@ -3523,6 +3786,7 @@ SUBROUTINE SPLINE2(I,J,JTBX,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q)
       INTEGER :: II,JJ,K,K1,K2,KOLD,NOLDM1
       REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR                 &
              ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1
+      CHARACTER (LEN=256) :: a_message
 !---------------------------------------------------------------------
 
 !     debug
@@ -3530,11 +3794,13 @@ SUBROUTINE SPLINE2(I,J,JTBX,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q)
       II=9999
       JJ=9999
       IF(I.eq.II.and.J.eq.JJ)THEN
-        WRITE(0,*)'DEBUG in SPLINE2: I,J',I,J
-        WRITE(0,*)'DEBUG in SPLINE2:HSO= ',xnew(1:nold)
+        WRITE(a_message,*)'DEBUG in SPLINE2: I,J',I,J
+        CALL wrf_message ( a_message )                     
+        WRITE(a_message,*)'DEBUG in SPLINE2:HSO= ',xnew(1:nold)
+        CALL wrf_message ( a_message )                     
         DO K=1,NOLD
-         WRITE(0,*)'DEBUG in SPLINE2:L,ZETAI,PINTI= ' &
-                        ,K,YOLD(K),XOLD(K)
+         WRITE(a_message,*)'DEBUG in SPLINE2:L,ZETAI,PINTI= ',K,YOLD(K),XOLD(K)
+         CALL wrf_message ( a_message )                    
         ENDDO
       ENDIF
 !
@@ -3611,7 +3877,8 @@ SUBROUTINE SPLINE2(I,J,JTBX,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q)
 !  debug
 
       IF(I.eq.II.and.J.eq.JJ)THEN
-        WRITE(0,*) 'DEBUG:: k1,xnew(k1),ynew(k1): ', K1,XNEW(k1),YNEW(k1)
+        WRITE(a_message,*) 'DEBUG:: k1,xnew(k1),ynew(k1): ', K1,XNEW(k1),YNEW(k1)
+        CALL wrf_message ( a_message )                     
       ENDIF 
 
 !
@@ -4743,6 +5010,7 @@ SUBROUTINE test_nmm (cfld,                                 &  ! CD field
      INTEGER i,j,k
      REAL,PARAMETER                                :: error=0.0001,error1=1.0
      REAL                                          :: diff
+     CHARACTER (LEN=256) :: a_message
 !
 !*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION
 !
@@ -4779,10 +5047,12 @@ SUBROUTINE test_nmm (cfld,                                 &  ! CD field
              DIFF=ABS(NFLD(I,J,K)-CFLD(IIH(I,J),JJH(I,J),K))
              IF(DIFF .GT. ERROR)THEN
               CALL wrf_debug(1,"dyn_nmm: NON-COINCIDENT, NESTED MASS POINT") 
-              WRITE(0,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,J,K),CFLD(IIH(I,J),JJH(I,J),K),DIFF 
+              WRITE(a_message,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,J,K),CFLD(IIH(I,J),JJH(I,J),K),DIFF 
+              CALL wrf_message ( a_message )               
              ENDIF
              IF(DIFF .GT. ERROR1)THEN
-              WRITE(0,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,J,K),CFLD(IIH(I,J),JJH(I,J),K),DIFF
+              WRITE(a_message,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,J,K),CFLD(IIH(I,J),JJH(I,J),K),DIFF
+              CALL wrf_message ( a_message )               
               CALL wrf_error_fatal ('dyn_nmm: NON-COINCIDENT, NESTED MASS POINT')
              ENDIF
           ENDIF
@@ -5034,6 +5304,7 @@ SUBROUTINE nmm_smoother ( cfld , &
       INTEGER :: ci, cj, ck
       INTEGER :: is, npass
       REAL    :: AVGH
+      CHARACTER (LEN=256) :: a_message
 
       RETURN
       !  If there is no feedback, there can be no smoothing.
@@ -5041,7 +5312,8 @@ SUBROUTINE nmm_smoother ( cfld , &
       CALL nl_get_feedback       ( 1, feedback  )
       IF ( feedback == 0 ) RETURN
 
-      WRITE(0,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR HEIGHT'
+      WRITE(a_message,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR HEIGHT'
+      CALL wrf_message ( a_message )                       
 
       DO npass = 1, smooth_passes
 
@@ -5117,6 +5389,7 @@ SUBROUTINE nmm_vsmoother ( cfld , &
       INTEGER :: ci, cj, ck
       INTEGER :: is, npass
       REAL    :: AVGV
+      CHARACTER (LEN=256) :: a_message
 
       RETURN
       !  If there is no feedback, there can be no smoothing.
@@ -5124,7 +5397,8 @@ SUBROUTINE nmm_vsmoother ( cfld , &
       CALL nl_get_feedback       ( 1, feedback  )
       IF ( feedback == 0 ) RETURN
 
-      WRITE(0,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR VELOCITY'
+      WRITE(a_message,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR VELOCITY'
+      CALL wrf_message ( a_message )                       
 
       DO npass = 1, smooth_passes
 
@@ -5209,6 +5483,62 @@ subroutine NoInterpMany(cfld,                                 &  ! CD field
 
    end subroutine NoInterpMany
 
+   subroutine DownAged2D(junk,                &
+        cids, cide, ckds, ckde, cjds, cjde,   &
+        cims, cime, ckms, ckme, cjms, cjme,   &
+        cits, cite, ckts, ckte, cjts, cjte,   &
+        nfld,                                 &  ! ND field
+        nids, nide, nkds, nkde, njds, njde,   &
+        nims, nime, nkms, nkme, njms, njme,   &
+        nits, nite, nkts, nkte, njts, njte,   &
+        shw,                                  &  ! stencil half width for interp
+        imask,                                &  ! interpolation mask
+        xstag, ystag,                         &  ! staggering of field
+        ipos, jpos,                           &  ! Position of lower left of nest in CD
+        nri, nrj, &
+        c_age,n_age, cfld)
+
+     use module_interp_nmm, only: c2n_copy2d_nomask
+     use module_interp_store
+     implicit none
+     LOGICAL,INTENT(IN) :: xstag, ystag
+     INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
+          cims, cime, ckms, ckme, cjms, cjme,   &
+          cits, cite, ckts, ckte, cjts, cjte,   &
+          nids, nide, nkds, nkde, njds, njde,   &
+          nims, nime, nkms, nkme, njms, njme,   &
+          nits, nite, nkts, nkte, njts, njte,   &
+          shw,ipos,jpos,nri,nrj
+
+     integer, intent(in) :: c_age
+     integer, intent(inout) :: n_age
+
+     INTEGER,DIMENSION(nims:nime,njms:njme),          INTENT(IN)           :: IMASK
+     REAL,DIMENSION(cims:cime,cjms:cjme),   INTENT(IN)           :: CFLD,junk
+     REAL,DIMENSION(nims:nime,njms:njme),   INTENT(INOUT)        :: nfld
+
+     logical bad
+     integer i,j
+     ! Skip if the nest is up-to-date with the parent.  Special age
+     ! of 0 means the values are invalid (parent just moved, nest
+     ! just moved or one was initialized).
+     if(n_age==c_age .and. n_age/=0 .and. c_age/=0) then
+        !write(0,*) 'Grid ',grid_id,' not storing pdyn in DownAged2D'
+        !write(0,*) '  reason: n_age=',n_age,' c_age=',c_age
+        return
+     end if
+     n_age=c_age
+     !write(0,*) 'Storing grid ',parent_grid_id,' pdyn_smooth in grid ',grid_id,' pdyn_parent'
+
+     call c2n_copy2d_nomask(IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,  &
+          cfld,nfld,                &
+          cims, cime, cjms, cjme,   &
+          nids, nide, njds, njde,   &
+          nims, nime, njms, njme,   &
+          nits, nite, njts, njte, .true.)
+
+   end subroutine DownAged2D
+
    subroutine ForceNearSST   (cfld,                                 &  ! CD field
         cids, cide, ckds, ckde, cjds, cjde,   &
         cims, cime, ckms, ckme, cjms, cjme,   &
@@ -6238,3 +6568,411 @@ END SUBROUTINE BdyINear
 !--------------------------------------------------------------------------------------
 
 #endif
+
+
+   SUBROUTINE interp_mask_field ( enable,                  &  ! says whether to allow interpolation or just the bcasts
+                                       cfld,                     &  ! CD field
+                           cids, cide, ckds, ckde, cjds, cjde,   &
+                           cims, cime, ckms, ckme, cjms, cjme,   &
+                           cits, cite, ckts, ckte, cjts, cjte,   &
+                           nfld,                                 &  ! ND field
+                           nids, nide, nkds, nkde, njds, njde,   &
+                           nims, nime, nkms, nkme, njms, njme,   &
+                           nits, nite, nkts, nkte, njts, njte,   &
+                           shw,                                  &  ! stencil half width
+                           imask,                                &  ! interpolation mask
+                           xstag, ystag,                         &  ! staggering of field
+                           ipos, jpos,                           &  ! Position of lower left of nest in CD
+                           nri, nrj,                             &  ! nest ratios
+                           clu, nlu, cflag, nflag ) 
+
+      USE module_configure
+      USE module_wrf_error
+      USE module_dm , only :  wrf_dm_sum_reals, wrf_dm_sum_integers
+
+      IMPLICIT NONE
+
+
+      LOGICAL, INTENT(IN) :: enable
+      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
+                             cims, cime, ckms, ckme, cjms, cjme,   &
+                             cits, cite, ckts, ckte, cjts, cjte,   &
+                             nids, nide, nkds, nkde, njds, njde,   &
+                             nims, nime, nkms, nkme, njms, njme,   &
+                             nits, nite, nkts, nkte, njts, njte,   &
+                             shw,                                  &  ! stencil half width
+                             ipos, jpos,                           &
+                             nri, nrj, cflag, nflag
+      LOGICAL, INTENT(IN) :: xstag, ystag
+
+      REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
+      REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
+      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
+
+      REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
+      REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
+
+      ! Local
+
+      INTEGER ci, cj, ck, ni, nj, nk, ip, jp
+      INTEGER :: icount, ii , jj , ist , ien , jst , jen , iswater, ierr
+      REAL :: avg, sum, dx , dy
+      INTEGER :: icount_water(nkts:nkte), icount_land(nkts:nkte), idummy(nkts:nkte)
+      REAL :: avg_water(nkts:nkte), avg_land(nkts:nkte), sum_water(nkts:nkte), sum_land(nkts:nkte), dummy(nkts:nkte)
+      CHARACTER (len=256) :: message
+      CHARACTER (len=256) :: a_mess
+
+      !  Find out what the water value is.
+
+      !CALL nl_get_iswater(1,iswater)
+      iswater = nflag
+
+      !  Right now, only mass point locations permitted.
+
+      IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
+
+        !  Loop over each i,k,j in the nested domain.
+
+        IF ( enable ) THEN
+          DO nj = njts, njte
+            ! first coarse position equal to or below nest point
+            IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
+               cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1
+            ELSE
+               cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1
+            END IF
+            DO nk = nkts, nkte
+               ck = nk
+               DO ni = nits, nite
+                  IF ( imask(ni, nj) .NE. 1 ) cycle
+                  ! first coarse position equal to or to the left of nest point
+                  IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
+                     ci = ( ni + (nri/2)-1 ) / nri + ipos -1
+                  ELSE
+                     ci = ( ni + (nri-1)/2 ) / nri + ipos -1
+                  END IF
+
+                  !
+                  !                    (ci,cj+1)     (ci+1,cj+1)
+                  !               -        -------------
+                  !         1-dy  |        |           |
+                  !               |        |           |
+                  !               -        |  *        |
+                  !          dy   |        | (ni,nj)   |
+                  !               |        |           |
+                  !               -        -------------
+                  !                    (ci,cj)       (ci+1,cj)
+                  !
+                  !                        |--|--------|
+                  !                         dx  1-dx
+
+                  !  For odd ratios, at (nri+1)/2, we are on the coarse grid point, so dx = 0
+
+                  IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN
+                     dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri )
+                  ELSE
+                     dx =   REAL ( MOD ( ni+(nri-1)/2 , nri ) )         / REAL ( nri )
+                  END IF
+                  IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN
+                     dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj )
+                  ELSE
+                     dy =   REAL ( MOD ( nj+(nrj-1)/2 , nrj ) )         / REAL ( nrj )
+                  END IF
+
+                  ! Nested cell is a water cell.
+                  IF ( ( NINT(nlu(ni, nj)) .EQ. iswater ) ) THEN
+
+                     ! If the surrounding coarse values are all WATER points,
+                     ! i.e. open water, this is a simple 4-pt interpolation. 
+                     ! If the surrounding coarse values are all LAND points,
+                     ! i.e. this is a 1-cell lake, we have no better way to 
+                     ! come up with the value than to do a simple 4-pt interpolation.
+
+                     IF ( ALL( clu(ci:ci+1,cj:cj+1) == iswater ) .OR. &
+                          ALL( clu(ci:ci+1,cj:cj+1) /= iswater ) ) THEN
+
+                       nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci  ,ck,cj  )   + &
+                                                               dy   * cfld(ci  ,ck,cj+1) ) + &
+                                               dx   * ( ( 1. - dy ) * cfld(ci+1,ck,cj  )   + &
+                                                               dy   * cfld(ci+1,ck,cj+1) )
+
+                     !  If there are some land points and some water points, take an average.
+                     ELSE
+                       icount = 0
+                       sum = 0
+                       IF ( NINT(clu(ci  ,cj  )) .EQ. iswater ) THEN
+                          icount = icount + 1
+                          sum = sum + cfld(ci  ,ck,cj  )
+                       END IF
+                       IF ( NINT(clu(ci+1,cj  )) .EQ. iswater ) THEN
+                          icount = icount + 1
+                          sum = sum + cfld(ci+1,ck,cj  )
+                       END IF
+                       IF ( NINT(clu(ci  ,cj+1)) .EQ. iswater ) THEN
+                          icount = icount + 1
+                          sum = sum + cfld(ci  ,ck,cj+1)
+                       END IF
+                       IF ( NINT(clu(ci+1,cj+1)) .EQ. iswater ) THEN
+                          icount = icount + 1
+                          sum = sum + cfld(ci+1,ck,cj+1)
+                       END IF
+                       nfld(ni,nk,nj) = sum / REAL ( icount )
+                     END IF
+
+                  ! Nested cell is a land cell.
+                   ELSE IF ( ( NINT(nlu(ni, nj)) .NE. iswater ) ) THEN
+
+                     ! If the surrounding coarse values are all LAND points,
+                     ! this is a simple 4-pt interpolation. 
+                     ! If the surrounding coarse values are all WATER points,
+                     ! i.e. this is a 1-cell island, we have no better way to 
+                     ! come up with the value than to do a simple 4-pt interpolation.
+
+                     IF ( ALL( clu(ci:ci+1,cj:cj+1) == iswater ) .OR. &
+                          ALL( clu(ci:ci+1,cj:cj+1) /= iswater ) ) THEN
+
+                       nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci  ,ck,cj  )   + &
+                                                               dy   * cfld(ci  ,ck,cj+1) ) + &
+                                               dx   * ( ( 1. - dy ) * cfld(ci+1,ck,cj  )   + &
+                                                               dy   * cfld(ci+1,ck,cj+1) )
+
+                    !  If there are some water points and some land points, take an average.                  
+                    ELSE
+                      icount = 0
+                      sum = 0
+                      IF ( NINT(clu(ci  ,cj  )) .NE. iswater ) THEN
+                         icount = icount + 1
+                         sum = sum + cfld(ci  ,ck,cj  )
+                      END IF
+                      IF ( NINT(clu(ci+1,cj  )) .NE. iswater ) THEN
+                         icount = icount + 1
+                         sum = sum + cfld(ci+1,ck,cj  )
+                      END IF
+                      IF ( NINT(clu(ci  ,cj+1)) .NE. iswater ) THEN
+                         icount = icount + 1
+                         sum = sum + cfld(ci  ,ck,cj+1)
+                      END IF
+                      IF ( NINT(clu(ci+1,cj+1)) .NE. iswater ) THEN
+                         icount = icount + 1
+                         sum = sum + cfld(ci+1,ck,cj+1)
+                      END IF
+                      nfld(ni,nk,nj) = sum / REAL ( icount )
+
+                    END IF
+                  END IF
+
+               END DO
+            END DO
+          END DO
+
+        END IF
+      ELSE
+         CALL wrf_error_fatal ( "only unstaggered fields right now" )
+      END IF
+
+   END SUBROUTINE interp_mask_field
+
+
+   SUBROUTINE interp_mask_soil ( enable,                  &  ! says whether to allow interpolation or just the bcasts
+                                       cfld,                     &  ! CD field
+                           cids, cide, ckds, ckde, cjds, cjde,   &
+                           cims, cime, ckms, ckme, cjms, cjme,   &
+                           cits, cite, ckts, ckte, cjts, cjte,   &
+                           nfld,                                 &  ! ND field
+                           nids, nide, nkds, nkde, njds, njde,   &
+                           nims, nime, nkms, nkme, njms, njme,   &
+                           nits, nite, nkts, nkte, njts, njte,   &
+                           shw,                                  &  ! stencil half width
+                           imask,                                &  ! interpolation mask
+                           xstag, ystag,                         &  ! staggering of field
+                           ipos, jpos,                           &  ! Position of lower left of nest in CD
+                           nri, nrj,                             &  ! nest ratios
+                           clu, nlu )
+
+      USE module_configure
+      USE module_wrf_error
+      USE module_dm , only : wrf_dm_sum_real, wrf_dm_sum_integer
+
+      IMPLICIT NONE
+
+
+      LOGICAL, INTENT(IN) :: enable
+      INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
+                             cims, cime, ckms, ckme, cjms, cjme,   &
+                             cits, cite, ckts, ckte, cjts, cjte,   &
+                             nids, nide, nkds, nkde, njds, njde,   &
+                             nims, nime, nkms, nkme, njms, njme,   &
+                             nits, nite, nkts, nkte, njts, njte,   &
+                             shw,                                  &  ! stencil half width
+                             ipos, jpos,                           &
+                             nri, nrj
+      LOGICAL, INTENT(IN) :: xstag, ystag
+
+      INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld
+      INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
+      INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
+
+      REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu
+      REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu
+
+      ! Local
+
+      INTEGER ci, cj, ck, ni, nj, nk, ip, jp
+      INTEGER :: icount, ii , jj , ist , ien , jst , jen , iswater, num_soil_cat, ierr
+      REAL :: avg, sum, dx , dy
+      INTEGER , ALLOCATABLE :: icount_water(:,: ), icount_land(:,:)
+      INTEGER , PARAMETER :: max_search = 5
+      CHARACTER*120 message
+      INTEGER, PARAMETER :: isoilwater = 14
+
+      CALL nl_get_iswater(1,iswater)
+      CALL nl_get_num_soil_cat(1,num_soil_cat)
+
+      allocate (icount_water(nkms:nkme,1:num_soil_cat))
+      allocate ( icount_land(nkms:nkme,1:num_soil_cat))
+
+      !  Right now, only mass point locations permitted.
+
+      IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN
+
+        !  Loop over each i,k,j in the nested domain.
+
+        IF ( enable ) THEN
+
+          DO nj = njts, njte
+             cj = jpos + (nj-1) / nrj     ! j coord of CD point 
+            DO nk = nkts, nkte
+               ck = nk
+               DO ni = nits, nite
+                  ci = ipos + (ni-1) / nri      ! j coord of CD point 
+
+                  IF ( imask(ni, nj) .NE. 1 ) cycle
+
+                  IF ( ( NINT(nlu(ni, nj)) .EQ. iswater ) ) then
+
+                     IF ( ( NINT(clu(ci  ,cj  )) .EQ. iswater ) ) then 
+                       nfld(ni,nk,nj) = cfld(ci,ck,cj)
+                     ELSE 
+                       nfld(ni,nk,nj) = -1
+                     ENDIF
+
+                  ELSE IF ( ( NINT(nlu(ni, nj)) .NE. iswater ) ) THEN
+
+                      IF ( ( NINT(clu(ci  ,cj  )) .NE. iswater ) ) THEN 
+                         nfld(ni,nk,nj) = cfld(ci,ck,cj)
+                      ELSE 
+                         nfld(ni,nk,nj) = -1
+                      ENDIF
+
+                  END IF
+               END DO
+            END DO
+          END DO
+
+          DO nj = njts, njte
+             DO nk = nkts, nkte
+                DO ni = nits, nite
+                  IF ( imask(ni, nj) .NE. 1 ) cycle
+                  IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN
+                     IF ( NINT(nlu(ni,nj)) .EQ. iswater ) THEN 
+                        nfld(ni,nk,nj) = isoilwater
+                     END IF
+                  END IF
+               END DO
+             END DO
+          END DO
+#if 0
+          IF ( ANY(nfld .EQ. -1) ) THEN
+
+            !  Get an average of the whole domain for problem locations.
+
+            sum_water    = 0
+            icount_water = 0
+            sum_land     = 0
+            icount_land  = 0
+            avg_water    = 0
+            avg_land     = 0
+           
+            DO nj = njts, njte
+               cj = jpos + (nj-1) / nrj     ! j coord of CD point 
+               DO nk = nkts, nkte
+                  DO ni = nits, nite
+                     ci = ipos + (ni-1) / nri      ! j coord of CD point 
+                     IF ( imask(ni, nj) .NE. 1 ) cycle
+                     IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN
+                        ist = MAX (ci-max_search,cits)
+                        ien = MIN (ci+max_search,cite,cide-1)
+                        jst = MAX (cj-max_search,cjts)
+                        jen = MIN (cj+max_search,cjte,cjde-1)
+                        DO jj = jst,jen
+                           DO ii = ist,ien
+                              IF ( NINT(clu(ii,jj)) .NE. iswater ) THEN
+                                 icount_land(nk,cfld(ii,nk,jj)) = icount_land(nk,cfld(ii,nk,jj)) +1
+                              END IF
+                           END DO
+                        END DO
+                        IF ( maxval(icount_land(nk,:)) .GT. 0 .and. maxloc(icount_land(nk,:)) .ne. isoilwater ) then
+                            nfld(ni,nk,nj) = maxloc(icount_land(nk,:))
+                        END IF
+                     END IF
+                  END DO
+               END DO
+            END DO
+
+          END IF ! nfld = -1
+
+
+          IF ( ANY(nfld .EQ. -1) ) THEN
+            sum_water    = 0
+            icount_water = 0
+            sum_land     = 0
+            icount_land  = 0
+            avg_water    = 0
+            avg_land     = 0
+
+            DO nj = njts, njte
+               DO nk = nkts, nkte
+                  DO ni = nits, nite
+                     IF ( nlu(ni,nj ) .NE. iswater ) THEN
+                        icount_land(nk,nfld(ni,nk,nj)) = icount_land(nk,nfld(ni,nk,nj)) +1
+                     END IF
+                  ENDDO
+               ENDDO
+            ENDDO
+
+            DO nj = njts, njte
+               DO nk = nkts, nkte
+                  DO ni = nits, nite
+                     IF ( imask(ni, nj) .NE. 1 ) cycle
+                     IF ( nfld(ni,nk,nj) .EQ. -1 .and. maxloc(icount_land(nk,:)) .ne. isoilwater) THEN
+                        nfld(ni,nk,nj) = MAXLOC(icount_land(nk,:))
+                     END IF
+                  ENDDO
+               ENDDO
+            ENDDO
+          END IF ! nfld = -1
+#endif
+
+          IF ( ANY(nfld .EQ. -1) ) THEN
+            DO nj = njts, njte
+               DO nk = nkts, nkte
+                  DO ni = nits, nite
+                     IF ( imask(ni, nj) .NE. 1 ) cycle
+                     IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN
+                        nfld(ni,nk,nj) = 8
+                     END IF
+                  ENDDO
+               ENDDO
+            ENDDO
+          END IF ! nfld = -1
+
+        END IF  ! enable
+      ELSE
+         CALL wrf_error_fatal ( "only unstaggered fields right now" )
+      END IF
+
+
+      deallocate (icount_water)
+      deallocate (icount_land)
+
+   END SUBROUTINE interp_mask_soil
diff --git a/wrfv2_fire/share/landread.c b/wrfv2_fire/share/landread.c
index c8c2f939..f8075c0f 100644
--- a/wrfv2_fire/share/landread.c
+++ b/wrfv2_fire/share/landread.c
@@ -1,15 +1,22 @@
 #ifndef CRAY
 # ifdef NOUNDERSCORE
 #      define GET_TERRAIN get_terrain
+#      define GET_LANDUSE get_landuse
 # else
 #   ifdef F2CSTYLE
 #      define GET_TERRAIN get_terrain__
+#      define GET_LANDUSE get_landuse__
 #   else
 #      define GET_TERRAIN get_terrain_
+#      define GET_LANDUSE get_landuse_
 #   endif
 # endif
 #endif
-#include 
+
+#ifdef LANDREAD_STUB
+#ifndef MS_SUA
+# include 
+#endif
 
 int GET_TERRAIN (        float *adx,
                          float *xlat,
@@ -22,10 +29,880 @@ int GET_TERRAIN (        float *adx,
                          int   *ipath , int * ipathlen)  /* integer coded ASCII string from Funtran and len */
 
 {
+#ifndef MS_SUA
+ fprintf(stderr, "***************************************************************\n" ) ;
+ fprintf(stderr, "Access to RSMAS Topo Ingest Code is by Special Arrangement Only\n" ) ;
+ fprintf(stderr, "in WRF.  Please contact wrfhelp@ucar.edu.                      \n" ) ;
+ fprintf(stderr, "***************************************************************\n" ) ;
+#endif
+ return(0) ;
+}
+
+int GET_LANDUSE (        float *adx,
+                         float *xlat,
+                         float *xlon,
+                         float       *landuse,
+                         int   *mix,
+                         int   *mjx,
+                         int   *iyyn,
+                         int   *jxxn,
+                         int   *ipath , int * ipathlen ) /* integer coded ASCII string from Funtran and len */
+
+{
+#ifndef MS_SUA
  fprintf(stderr, "***************************************************************\n" ) ;
  fprintf(stderr, "Access to RSMAS Topo Ingest Code is by Special Arrangement Only\n" ) ;
- fprintf(stderr, "in WRF 2.1 .  Please contact wrfhelp@ucar.edu .                \n" ) ;
+ fprintf(stderr, "in WRF.  Please contact wrfhelp@ucar.edu.                      \n" ) ;
  fprintf(stderr, "***************************************************************\n" ) ;
+#endif
  return(0) ;
 }
+#else
+
+#ifdef FSEEKO_OK
+#  define _FILE_OFFSET_BITS 64
+#endif
+#ifndef MS_SUA
+# include 
+#endif
+#include 
+#include 
+#include 
+#ifndef MACOS
+# include 
+#else
+# include 
+#endif
+#include 
+#include 
+#define MAXTOPOFILES  100
+#define MAXLEN        4096
+
+
+typedef struct
+{
+  /* Filenames. */
+  char  fn[MAXTOPOFILES][MAXLEN];
+
+  /* Grid spacings in km. */
+  float dx[MAXTOPOFILES];
+
+  /* Number of entries. */
+  int num;
+} TsFileInfo;
+
+static TsFileInfo tsfTopo;
+static TsFileInfo tsfOcean;
+static TsFileInfo tsfLU;
+
+static int   tsFileInfo_initialized = 0 ; 
+//static float last_adx = 0.0 ;
+
+static char tsfTopo_fn[MAXLEN];
+static char tsfLU_fn[MAXLEN];
+static char tsfOcean_fn[MAXLEN];
+
+static float vmiss;
+
+static int    numHeaderBytes;
+static int    globalNx;
+static int    globalNy;
+static int    tileNx;
+static int    tileNy;
+static int    extraNx;
+static int    extraNy;
+static int    numTilesX;
+static int    numTilesY;
+static double dlat;
+static double dlon;
+static double lat0;
+static double lon0;
+static int    ntiles;
+static int    wrapx;
+static int    wrapy;
+
+/* File information. */
+static XDR  *xdrs;
+static FILE *fp;
+
+int nint(double x)
+{
+  if ( x > 0.0 ) { return( (int)(x + 0.5) ) ; }
+  return((int)(x - 0.5));
+}
+
+double aint(double x)
+{
+  int ix = (int)(x);
+  return((double)(ix));
+}
+
+double anint(double x)
+{
+  if (x > 0.0) return((double)((int)(x + 0.5)));
+  return((double)((int)(x - 0.5)));
+}
+
+static double normalizeAngle(double ang)
+{
+  for (;;)
+    {
+      if (ang >= 360.0)
+        {
+          ang -= 360.0;
+        }
+      else if (ang < 0.0)
+        {
+          ang += 360.0;
+        }
+      else
+        {
+          break;
+        }
+    }
+  
+  return(ang);
+}
+
+static double lonDistNowrap(double lon1, double lon2)
+{
+  double lon11 = normalizeAngle(lon1);
+  double lon22 = normalizeAngle(lon2);
+  if (lon22 < lon11) lon22 += 360.0;
+  return(fabs(lon22 - lon11));
+}
+
+int tsLatLonToGridpoint(double  lat,
+			double  lon,
+			double       *ix,
+			double       *iy)
+{
+  *ix = lonDistNowrap(lon0, lon) / dlon;
+  *iy = (lat - lat0) / dlat;
+  return(0);
+}
+
+static int areEqual(double v1, double v2)
+{
+  if (fabs(v1-v2) < 0.001) return(1);
+  return(0);
+}
+
+static int setWrapAroundFlags(void)
+{
+  /* Compute the end gridpoint location in x. */
+  double lon1  = lon0 + dlon*(globalNx);
+  double lon2  = lon0 + dlon*(globalNx-1);
+  double lat1  = lat0 + dlat*(globalNy);
+  double lon0n = normalizeAngle(lon0);
+  double lon1n = normalizeAngle(lon1);
+  double lon2n = normalizeAngle(lon2);
+
+  wrapx = 0;
+  if (areEqual(lon0n, lon1n))
+    {
+      /* Here the first and last indices in x are one grid interval
+         apart. */
+      wrapx = 1;
+    }
+  else if (areEqual(lon0n, lon2n))
+    {
+      /* Here the first and last indices in x are coincident. */
+      wrapx = 2;
+    }
+
+  wrapy = 0;
+  if (areEqual(lat0, -90.0))
+    {
+      /* Here the first and last indices in x are one grid interval
+         apart. */
+      wrapy += 1;
+    }
+  if (areEqual(lat1, 90.0))
+    {
+      /* Here the first and last indices in x are coincident. */
+      wrapy += 2;
+    }
+
+  return(0);
+}
+
+static int isMissing(float v)
+{
+  if (fabs(vmiss - v) < 0.1) return(1);
+  return(0);
+}
+
+float tsGetValueInt(int aix, int aiy)
+{
+  float f = vmiss;
+  
+  int iy = aiy;
+  int ix = aix;
+
+  /* Perform bounds checking. */
+  if (iy < 0)
+    {
+      return(f);
+    }
+  else if (iy > globalNy - 1)
+    {
+      return(f);
+    }
+
+  if (aix < 0)
+    {
+      if (wrapx == 1)
+	{
+	  int n  = -(aix - (globalNx - 1)) / globalNx;
+	  ix += n*globalNx;
+	}
+      else if (wrapx == 2)
+	{
+	  int nx = globalNx - 1;
+	  int n  = -(aix - (nx - 1)) / nx;
+	  ix += n*nx;
+	}
+      else
+	{
+	  return(f);
+	}
+    }
+
+  if (ix > globalNx-1)
+    {
+      if (wrapx == 1)
+	{
+	  int n  = aix / globalNx;
+	  ix -= n*globalNx;
+	}
+      else if (wrapx == 2)
+	{
+	  int nx = globalNx - 1;
+	  int n  = aix / nx;
+	  ix -= n*nx;
+	}
+      else
+	{
+	  return(f);
+	}
+    }
+
+  int tx  = ix / tileNx;
+  int ty  = iy / tileNy;
+  int tn  = tx + ty*numTilesX;
+  int txg = ix - tx*tileNx;
+  int tyg = iy - ty*tileNy;
+  int gn  = txg + tyg*tileNx;
+
+  long long ll_gn = gn;
+  long long ll_numHeaderBytes  = numHeaderBytes;
+  long long ll_tileNx = tileNx;
+  long long ll_tileNy = tileNy;
+
+#ifdef FSEEKO64_OK 
+  /* This is used on machines that support fseeko64. Tested for in ./configure script */
+  long long loc = ll_numHeaderBytes + ll_tileNx*ll_tileNy*sizeof(float)*tn +
+    ll_gn*sizeof(float);
+
+  /* Seek to the proper location in the file and get the data value. */
+  fseeko64(fp, loc, SEEK_SET);
+#else
+#  ifdef FSEEKO_OK
+  /* This is used on machines that support _FILE_OFFSET_BITS=64 which makes
+     off_t be 64 bits, and for which fseeko can handle 64 bit offsets.  This
+     is tested in the ./configure script */
+  off_t loc = ll_numHeaderBytes + ll_tileNx*ll_tileNy*sizeof(float)*tn +
+    ll_gn*sizeof(float);
+
+  fseeko(fp, loc, SEEK_SET);
+#  else
+  /* Note, this will not work correctly for very high resolution terrain input
+     because the offset is only 32 bits.   */
+  off_t loc = ll_numHeaderBytes + ll_tileNx*ll_tileNy*sizeof(float)*tn +
+    ll_gn*sizeof(float);
+
+  fseek(fp, loc, SEEK_SET);
+#  endif
+#endif
+  xdr_float(xdrs, (float *) &f);
+
+  return(f);
+}
+
+float tsGetValue(double ix, double iy)
+{
+  int i0 = (int)(floor(ix));
+  int j0 = (int)(floor(iy));
+  int i1 = (int)(ceil(ix));
+  int j1 = (int)(ceil(iy));
+  
+  /* Interpolate linearly to (oiloc, ojloc). */
+  float v0 = tsGetValueInt(i0,j0);
+  float v1 = tsGetValueInt(i0,j1);
+  float v2 = tsGetValueInt(i1,j0);
+  float v3 = tsGetValueInt(i1,j1);
+  
+  if (isMissing(v0)) return(vmiss);
+  if (isMissing(v1)) return(vmiss);
+  if (isMissing(v2)) return(vmiss);
+  if (isMissing(v3)) return(vmiss);
+
+  double w0 = ix - i0;
+  double w1 = iy - j0;
+
+  float v4 = v2*w0 + v0*(1.0-w0);
+  float v5 = v3*w0 + v1*(1.0-w0);
+  float v6 = w1*v5 + (1.0-w1)*v4;
+  float val = v6;
+
+  return(val);
+}
+
+float tsGetValueLatLon(double lat, double lon)
+{
+  double ix, iy;
+  tsLatLonToGridpoint(lat,lon,&ix,&iy);
+  return(tsGetValue(ix,iy));
+}
+
+int tsCloseTileSet(void)
+{
+  if (xdrs)
+    {
+      xdr_destroy(xdrs);
+      free(xdrs);
+      xdrs = NULL;
+    }
+  
+  if (fp)
+    {
+      fclose(fp);
+      fp = NULL;
+    }
+
+  return(0);
+}
+
+int tsInitTileSet(char *fn)
+{
+  vmiss = -100000000.00;
+
+  xdrs = NULL;
+  fp   = NULL;
+
+# if 0
+  fprintf(stderr,"Open %s\n", fn) ;
+# endif
+
+  /* fp = (FILE *) fopen64(fn, "r"); */
+  if (( fp = fopen(fn, "r")) == NULL ) {
+#ifndef MS_SUA
+    fprintf(stderr,"tsInitTileSet: can not open %s\n",fn) ;
+#endif
+    return(1) ;
+  }
+  xdrs = (XDR *) malloc(sizeof(XDR));
+  xdrstdio_create(xdrs, fp, XDR_DECODE);
+
+  numHeaderBytes = 5000;
+
+  xdr_int(xdrs,    (int *)    &globalNx);
+  xdr_int(xdrs,    (int *)    &globalNy);
+  xdr_int(xdrs,    (int *)    &tileNx);
+  xdr_int(xdrs,    (int *)    &tileNy);
+  xdr_int(xdrs,    (int *)    &extraNx);
+  xdr_int(xdrs,    (int *)    &extraNy);
+  xdr_int(xdrs,    (int *)    &numTilesX);
+  xdr_int(xdrs,    (int *)    &numTilesY);
+  xdr_double(xdrs, (double *) &dlat);
+  xdr_double(xdrs, (double *) &dlon);
+  xdr_double(xdrs, (double *) &lat0);
+  xdr_double(xdrs, (double *) &lon0);
+  xdr_int(xdrs,    (int *)    &ntiles);
+
+  setWrapAroundFlags();
+
+  return(0);
+}
+
+int tsPrintTileSetInfo()
+{
+  return(0);
+}
+
+int tsInitFileInfo (char path[])
+{
+  int i, n;
+  char type[MAXLEN];
+  char  res[MAXLEN];
+  char   fn[MAXLEN];
+  char buff[MAXLEN];
+  float dx;
+
+  tsfTopo.num  = 0;
+  tsfOcean.num = 0;
+  tsfLU.num    = 0;
+
+  tsfLU.dx[0] = 0.;
+  tsfTopo.dx[0] = 0.;
+  tsfOcean.dx[0] = 0. ;
+
+  if (access("RSMAS_Topo_Land.TBL", F_OK) == 0 ) {
+  /* Read in the list of topography/land use filenames. */
+    fp = fopen("RSMAS_Topo_Land.TBL", "r");
+    if ( fp == NULL ) {
+#ifndef MS_SUA
+      fprintf(stderr, "tsInitFileInfo : can not open RSMAS_Topo_Land.TBL\n");
+#endif
+      return(-1);
+    }
+
+    //skipps header
+    fgets(buff, MAXLEN, fp);
+
+    while (fscanf(fp, "%s %s %s", type, res, fn) != EOF) {
+        sscanf(res, "%f", &dx);
+        if (strcmp(type, "landuse") == 0)
+          {
+            if ( tsfLU.num >= MAXTOPOFILES ) {continue;}
+            n = tsfLU.num ;
+            for ( i = 0 ; i < tsfLU.num ; i++ ) {
+              if ( tsfLU.dx[i] > dx ) {
+                n = i ;
+                break;
+              }
+            }
+            for ( i = tsfLU.num ; i > n ; i-- ) {
+               tsfLU.dx[i]=tsfLU.dx[i-1];
+               strcpy(tsfLU.fn[i], tsfLU.fn[i-1]);
+            }
+            tsfLU.dx[n] = dx;
+            strcpy(tsfLU.fn[n], fn);
+            tsfLU.num++;
+          }
+        else if (strcmp(type, "topography") == 0)
+          {
+            if ( tsfTopo.num >= MAXTOPOFILES ) {continue;}
+            n = tsfTopo.num;
+            for ( i = 0 ; i < tsfTopo.num ; i++ ) {
+              if ( tsfTopo.dx[i] > dx ) {
+                n = i ;
+                break;
+              }
+            }
+            for ( i = tsfTopo.num ; i > n ; i-- ) {
+               tsfTopo.dx[i]=tsfTopo.dx[i-1];
+               strcpy(tsfTopo.fn[i], tsfTopo.fn[i-1]);
+            }
+            tsfTopo.dx[n] = dx;
+            strcpy(tsfTopo.fn[n], fn);
+            tsfTopo.num++;
+          }
+        else if (strcmp(type, "bathymetry") == 0)
+          {
+            if ( tsfOcean.num >= MAXTOPOFILES ) {continue;}
+            n = tsfOcean.num;
+            for ( i = 0 ; i < tsfOcean.num ; i++ ) {
+              if ( tsfOcean.dx[i] > dx ) {
+                n = i ;
+                break;
+              }
+            }
+            for ( i = tsfOcean.num ; i > n ; i-- ) {
+               tsfOcean.dx[i]=tsfOcean.dx[i-1];
+               strcpy(tsfOcean.fn[i], tsfOcean.fn[i-1]);
+            }
+            tsfOcean.dx[n] = dx;
+            strcpy(tsfOcean.fn[n], fn);
+            tsfOcean.num++;
+          }
+    }
+
+    fclose(fp);
+
+  } else {
+
+    for ( i = 1; i < 10 ; i++ ) {
+      sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, i);
+      if (access(tsfTopo.fn[tsfTopo.num], F_OK) == 0) { tsfTopo.dx[tsfTopo.num] = i; tsfTopo.num++ ; }
+    }
+    for ( i = 10; i<=40 ; i += 10 ) {
+      sprintf(tsfTopo.fn[tsfTopo.num], "%s/topo.%02dkm.ts", path, i);
+      if (access(tsfTopo.fn[tsfTopo.num], F_OK) == 0) { tsfTopo.dx[tsfTopo.num] = i; tsfTopo.num++ ; }
+    }
+
+    for ( i = 1; i < 10 ; i++ ) {
+      sprintf(tsfLU.fn[tsfLU.num], "%s/glcc.usgs20.%02dkm.ts", path, i);
+      if (access(tsfLU.fn[tsfLU.num], F_OK) == 0) { tsfLU.dx[tsfLU.num] = i; tsfLU.num++ ; }
+    }
+    for ( i = 10; i<=40 ; i += 10 ) {
+      sprintf(tsfLU.fn[tsfLU.num], "%s/glcc.usgs20.%02dkm.ts", path, i);
+      if (access(tsfLU.fn[tsfLU.num], F_OK) == 0) { tsfLU.dx[tsfLU.num] = i; tsfLU.num++ ; }
+    }
+
+    for ( i = 1; i < 10 ; i++ ) {
+      sprintf(tsfOcean.fn[tsfOcean.num], "%s/tbase.%02dkm.ts", path, i);
+      if (access(tsfOcean.fn[tsfOcean.num], F_OK) == 0) { tsfOcean.dx[tsfLU.num] = i; tsfOcean.num++ ; }
+    }
+    for ( i = 10; i<=40 ; i += 10 ) {
+      sprintf(tsfOcean.fn[tsfOcean.num], "%s/tbase.%02dkm.ts", path, i);
+      if (access(tsfOcean.fn[tsfOcean.num], F_OK) == 0) { tsfOcean.dx[tsfOcean.num] = i; tsfOcean.num++ ; }
+    }
+  }
+# if 0
+  for ( i = 0 ; i < tsfTopo.num ; i++ ) {
+    fprintf(stderr,"%02d. %s\n",i, tsfTopo.fn[i]) ;
+  }
+  for ( i =0 ; i < tsfLU.num ; i++ ) {
+    fprintf(stderr,"%02d. %s\n",i, tsfLU.fn[i]) ;
+  }
+  for ( i =0 ; i < tsfOcean.num ; i++ ) {
+    fprintf(stderr,"%02d. %s\n",i, tsfOcean.fn[i]) ;
+  }
+# endif
+
+  return(1);
+
+}
+
+int GET_LANDUSE (        float *adx,
+			 float *xlat,
+			 float *xlon,
+			 float       *landuse,
+			 int   *mix,
+			 int   *mjx,
+			 int   *iyyn,
+			 int   *jxxn,
+                         int   *ipath , int * ipathlen ) /* integer coded ASCII string from Funtran and len */
+{
+  int i, j ;
+  char path[256];
+  int ix,iy, offset ;
+  float lat, lon, tv;
+  double fix, fiy;
+
+  static float last_adx = 0.0 ;
+
+  if ( tsFileInfo_initialized == 0 ) {
+     for (i = 0 ; i < *ipathlen ; i++ ) {
+       path[i] = ipath[i] ;
+     }
+     path[*ipathlen] = '\0' ;
+     tsFileInfo_initialized = tsInitFileInfo(path);
+     if ( tsFileInfo_initialized == -1 ) { return(1); }
+  }
+
+//if ( fabs(last_adx - *adx)  > 1.0E-6 ) {
+//  last_adx = *adx;
+    if ( tsfLU.num > 0 ) {
+      strcpy(tsfLU_fn, tsfLU.fn[tsfLU.num-1]);
+      for ( i = 0; i < tsfLU.num; i++) {
+# if 0
+          fprintf(stderr,"%d fn %s dx %f adx %f\n",i,tsfLU.fn[i],tsfLU.dx[i],*adx) ;
+# endif
+          if (tsfLU.dx[i] > *adx) {
+              strcpy(tsfLU_fn, tsfLU.fn[i-1]);
+              break;
+            }
+        }
+    } else {
+# ifndef MS_SUA
+        fprintf(stderr, "Not found LANDUSE datasets!\n");
+# endif
+        return(1);
+    }
+//}
+
+  /* Get the land use. */
+  if (tsInitTileSet(tsfLU_fn)) { return(1); }
+
+  for ( j = 0; j < *jxxn; j++) {
+    offset = *mix*j;
+    for ( i = 0; i < *iyyn; i++) {
+      lat = xlat[offset + i];
+      lon = xlon[offset + i];
+
+      tsLatLonToGridpoint(lat,lon,&fix,&fiy);
+      ix = nint(fix);
+      iy = nint(fiy);
+      tv = tsGetValueInt(ix, iy);
+
+      /* Set out-of-range values to water. */
+      if (tv < 0.9 || tv > 24.1) tv = 16.0;
+
+      landuse[offset + i] = tv;
+    }
+  }
+  tsCloseTileSet();
+}
+
+int GET_TERRAIN (        float *adx,
+                         float *xlat,
+                         float *xlon,
+                         float       *terrain,
+                         int   *mix,
+                         int   *mjx,
+                         int   *iyyn,
+                         int   *jxxn, 
+                         int   *ipath , int * ipathlen)  /* integer coded ASCII string from Funtran and len */
+{
+  int i, j ;
+  char path[256];
+  int ix, iy, offset ;
+  float lon, lat, tv;
+  double fix, fiy;
+
+  static float last_adx = 0.0 ;
+
+  if ( tsFileInfo_initialized == 0 ) { 
+     for (i = 0 ; i < *ipathlen ; i++ ) {
+       path[i] = ipath[i] ;
+     }
+     path[*ipathlen] = '\0' ;
+     tsFileInfo_initialized = tsInitFileInfo(path); 
+     if ( tsFileInfo_initialized == -1 ) { return(1); }
+  }
+
+  /* Use the data with the largest spacing less than the grid
+     spacing specified in the argument list. */
+//if ( fabs(last_adx - *adx)  > 1.0E-6 ) {
+//  last_adx = *adx;
+    if ( tsfTopo.num > 0 ) {
+      strcpy(tsfTopo_fn, tsfTopo.fn[tsfTopo.num-1]);
+      for (i = 0; i < tsfTopo.num; i++) {
+#if 0
+fprintf(stderr,"%d fn %s dx %f adx %f\n",i,tsfTopo.fn[i],tsfTopo.dx[i],*adx ) ;
+#endif
+	  if ( tsfTopo.dx[i] > *adx) {
+	      strcpy(tsfTopo_fn, tsfTopo.fn[i-1]);
+              break;
+	    }
+        }
+    } else {
+#ifndef MS_SUA
+      fprintf(stderr,"Not found GTOPO datasets\n");
+#endif
+      return(1);
+    }
+
+#ifdef TERRAIN_TBASE
+    if ( tsfOcean.num > 0 ) {
+      strcpy(tsfOcean_fn, tsfOcean.fn[tsfOcean.num-1]);
+      for ( i = 0; i < tsfOcean.num; i++) {
+          if (tsfOcean.dx[i] > *adx) {
+            strcpy(tsfOcean_fn, tsfOcean.fn[i-1]);
+            break;
+          }
+      }
+    } else {
+# ifndef MS_SUA
+        fprintf(stderr, "Not found TBASE datasets!\n");
+# endif
+        return(1);
+    }
+#endif
+//}
+
+  /* First get the terrain from GTOPO30. */
+    if (tsInitTileSet(tsfTopo_fn)) { return(1); }
+
+    for ( j = 0; j < *jxxn; j++)
+      { offset = *mix*j;
+	for ( i = 0; i < *iyyn; i++)
+	  {
+	    lat = xlat[offset + i];
+	    lon = xlon[offset + i];
+	    
+	    tsLatLonToGridpoint(lat,lon,&fix,&fiy);
+	    tv = tsGetValue(fix, fiy);
+	    terrain[offset + i] = tv;
+	  }
+      }
+    tsCloseTileSet();
+
+#ifdef TERRAIN_TBASE
+  /* Next get the terrain from TBASE. */
+    if (tsInitTileSet(tsfOcean_fn)) { return(1); }
+
+    for ( j = 0; j < *jxxn; j++)
+      { offset = *mix*j;
+	for ( i = 0; i < *iyyn; i++)
+	  {
+	    lat = xlat[offset + i];
+	    lon = xlon[offset + i];
+	    
+	    tsLatLonToGridpoint(lat,lon,&fix,&fiy);
+	    tv = tsGetValue(fix, fiy);
+	    if (isMissing(terrain[offset+i]))
+	      {
+		if (tv < 0.0) tv = 0.0;
+		terrain[offset + i] = tv;
+	      }
+	  }
+      }
+    tsCloseTileSet();
+#endif
+  return(0);
+}
+
+#ifdef BATHYMETRY
+int get_bathymetry_(float *tadx,
+		    float *xlat,
+		    float *xlon,
+		    float       *depth,
+		    int   *mix,
+		    int   *mjx,
+		    int   *iyyn,
+		    int   *jxxn,
+		    float *mindepth,
+		    float *zlimww3,
+                    int   *ipath , int * ipathlen)  /* integer coded ASCII string from Funtran and len */
+{
+  int i, j;
+  char fn[MAXLEN];
+  char path[1024];
+  float maxdx, tv;
+  double fix, fiy, lat, lon;
+  int ix,iy,nx,ny;
+  int offset;
+
+  nx=*mix;
+  ny=*mjx;
+
+  /* Set grid resolution to .1 km to get highest resolution data possible. */
+  float adx = 0.1;
+
+  if ( tsFileInfo_initialized == 0 ) {
+     for (i = 0 ; i < *ipathlen ; i++ ) {
+       path[i] = ipath[i] ;
+     }
+     path[*ipathlen] = '\0' ;
+     tsFileInfo_initialized = tsInitFileInfo(path);
+     if ( tsFileInfo_initialized == -1 ) { return(1); }
+  }
+
+  /* Get the water depth from TBASE. */
+  if ( tsfOcean.num > 0 ) {
+    /* Use the data with highest resolution possible. */
+    maxdx = 0.0;
+    strcpy(fn, tsfOcean.fn[tsfOcean.num-1]);
+    for ( i = 0; i < tsfOcean.num; i++)
+      {
+	if (tsfOcean.dx[i] < maxdx) continue;
+	if ( tsfOcean.dx[i] < adx)
+	  {
+	    maxdx = tsfOcean.dx[i];
+	    strcpy(fn, tsfOcean.fn[i]);
+	  }
+      }
+
+    if (tsInitTileSet(fn))
+      {
+	return(1);
+      }
+
+    for ( i = 0; i < nx*ny; i++)
+      {
+	depth[i] = vmiss;
+      }
+    
+    for ( j = 0; j < *jxxn; j++)
+      { offset = nx * j;
+	for ( i = 0; i < *iyyn; i++)
+	  {
+	    lat = xlat[offset + i];
+	    lon = xlon[offset + i];
+	    
+	    tsLatLonToGridpoint(lat,lon,&fix,&fiy);
+	    tv = tsGetValue(fix, fiy);
+	    if (isMissing(depth[offset+i]))
+	      {
+		depth[offset + i] = -tv;
+	      }
+	  }
+      }
+    tsCloseTileSet();
+  } else {
+# ifndef MS_SUA
+        fprintf(stderr, "Not found TBASE datasets!\n");
+# endif
+        return(1);
+  }
+
+  /* Next get the land use. */
+  if ( tsfLU.num > 0 ) {
+    /* Use the data with the largest spacing less than the grid
+       spacing specified in the argument list. */
+    maxdx = 0.0;
+    strcpy(fn, tsfLU.fn[tsfLU.num-1]);
+    for ( i = 0; i < tsfLU.num; i++)
+      {
+	if (tsfLU.dx[i] < maxdx) continue;
+	if (tsfLU.dx[i] < adx)
+	  {
+	    maxdx = tsfLU.dx[i];
+	    strcpy(fn, tsfLU.fn[i]);
+	  }
+      }
+
+    if (tsInitTileSet(fn))
+      {
+	return(1);
+      }
+
+    for ( j = 0; j < *jxxn; j++)
+      { offset = nx*j;
+	for ( i = 0; i < *iyyn; i++)
+	  {
+	    lat = xlat[offset + i];
+	    lon = xlon[offset + i];
+	    
+	    tsLatLonToGridpoint(lat,lon,&fix,&fiy);
+	    ix = nint(fix);
+	    iy = nint(fiy);
+	    tv = tsGetValueInt(ix, iy);
+
+            /* Set out-of-range values to water. */
+            if (tv < 0.9 || tv > 24.1) tv = 16.0;
+
+	    if (fabs(tv - 16.0) < 0.1)
+	      {
+		/* Water. */
+		if (1)
+		  {
+		    if (depth[offset + i] < *mindepth) depth[offset + i] = *mindepth;
+		  }
+		else
+		  {
+		    if (depth[offset + i] < -(*zlimww3) )
+		      {
+			/* Water depth below zlimww3, so turn this point 
+			   into land. */
+			depth[offset + i] = -0.1;		    
+		      }
+		    else if (depth[offset + i] < *mindepth)
+		      {
+			depth[offset + i] = *mindepth;
+		      }
+		  }
+	      }
+	    else
+	      {
+		/* Land. Set depth to 0.0. */
+		depth[offset + i] = 0.0;
+	      }
+	  }
+      }
+    tsCloseTileSet();
+  } else {
+# ifndef MS_SUA
+        fprintf(stderr, "Not found LANDUSE datasets!\n");
+# endif
+        return(1);
+  }
+  return(0);
+}
+#endif
 
+#endif 
diff --git a/wrfv2_fire/share/landread.c.dist b/wrfv2_fire/share/landread.c.dist
new file mode 100644
index 00000000..38d2eb97
--- /dev/null
+++ b/wrfv2_fire/share/landread.c.dist
@@ -0,0 +1,58 @@
+#ifndef CRAY
+# ifdef NOUNDERSCORE
+#      define GET_TERRAIN get_terrain
+#      define GET_LANDUSE get_landuse
+# else
+#   ifdef F2CSTYLE
+#      define GET_TERRAIN get_terrain__
+#      define GET_LANDUSE get_landuse__
+#   else
+#      define GET_TERRAIN get_terrain_
+#      define GET_LANDUSE get_landuse_
+#   endif
+# endif
+#endif
+
+#ifndef MS_SUA
+# include 
+#endif
+
+int GET_TERRAIN (        float *adx,
+                         float *xlat,
+                         float *xlon,
+                         float       *terrain,
+                         int   *mix,
+                         int   *mjx,
+                         int   *iyyn,
+                         int   *jxxn,
+                         int   *ipath , int * ipathlen)  /* integer coded ASCII string from Funtran and len */
+
+{
+#ifndef MS_SUA
+ fprintf(stderr, "***************************************************************\n" ) ;
+ fprintf(stderr, "Access to RSMAS Topo Ingest Code is by Special Arrangement Only\n" ) ;
+ fprintf(stderr, "in WRF.  Please contact wrfhelp@ucar.edu.                      \n" ) ;
+ fprintf(stderr, "***************************************************************\n" ) ;
+#endif
+ return(0) ;
+}
+
+int GET_LANDUSE (        float *adx,
+                         float *xlat,
+                         float *xlon,
+                         float       *landuse,
+                         int   *mix,
+                         int   *mjx,
+                         int   *iyyn,
+                         int   *jxxn,
+                         int   *ipath , int * ipathlen ) /* integer coded ASCII string from Funtran and len */
+
+{
+#ifndef MS_SUA
+ fprintf(stderr, "***************************************************************\n" ) ;
+ fprintf(stderr, "Access to RSMAS Topo Ingest Code is by Special Arrangement Only\n" ) ;
+ fprintf(stderr, "in WRF.  Please contact wrfhelp@ucar.edu.                      \n" ) ;
+ fprintf(stderr, "***************************************************************\n" ) ;
+#endif
+ return(0) ;
+}
diff --git a/wrfv2_fire/share/mediation_feedback_domain.F b/wrfv2_fire/share/mediation_feedback_domain.F
index 5b6689fa..8ce8e52f 100644
--- a/wrfv2_fire/share/mediation_feedback_domain.F
+++ b/wrfv2_fire/share/mediation_feedback_domain.F
@@ -126,7 +126,7 @@ END SUBROUTINE feedback_domain_nmm_part2
    CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
    parent_grid%ht_coarse = parent_grid%ht
    grid => nested_grid%intermediate_grid
-#  if defined(MOVE_NESTS) || (!defined(SGIALTIX))
+#  if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10))))
    CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. ,     &
                             grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
                             grid%sm31,  grid%em31,  grid%sm32,  grid%em32,  grid%sm33,  grid%em33, &
@@ -158,7 +158,7 @@ END SUBROUTINE feedback_domain_nmm_part2
 !
                                    )
    grid => nested_grid%intermediate_grid
-#  if defined(MOVE_NESTS) || (!defined(SGIALTIX))
+#  if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10))))
    CALL dealloc_space_field ( grid )
 #  endif
 # endif
@@ -178,7 +178,7 @@ END SUBROUTINE feedback_domain_nmm_part2
    CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
    grid => nested_grid%intermediate_grid
 !dusan orig     CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. ,     &
-#if defined(MOVE_NESTS) || (!defined(SGIALTIX))
+#  if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10))))
    CALL ensure_space_field &
                           ( grid, grid%id , 1 , 3 , .FALSE. ,     &
                             grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
@@ -191,6 +191,10 @@ END SUBROUTINE feedback_domain_nmm_part2
        )
 # endif
    nested_grid%intermediate_grid%interp_mp=parent_grid%interp_mp .or. nested_grid%interp_mp
+#if (HWRF == 1)
+  nested_grid%intermediate_grid%pdyn_parent_age=parent_grid%pdyn_parent_age
+  nested_grid%intermediate_grid%pdyn_smooth_age=parent_grid%pdyn_smooth_age
+#endif
 
    ! NOTE: the intermediate grid is a grid with the spatial extent and
    ! processor decomposition of the nest, at the resolution of the
diff --git a/wrfv2_fire/share/mediation_force_domain.F b/wrfv2_fire/share/mediation_force_domain.F
index d6037cf0..61fb3895 100644
--- a/wrfv2_fire/share/mediation_force_domain.F
+++ b/wrfv2_fire/share/mediation_force_domain.F
@@ -144,7 +144,7 @@ END SUBROUTINE force_domain_nmm_part2
    CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
 
    grid => nested_grid%intermediate_grid
-#  if defined(MOVE_NESTS) || (!defined(SGIALTIX))
+#  if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10))))
    CALL alloc_space_field ( grid, grid%id , 1 , 2 ,  .TRUE. ,    &
                             grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
                             grid%sm31,  grid%em31,  grid%sm32,  grid%em32,  grid%sm33,  grid%em33, &
@@ -223,7 +223,7 @@ END SUBROUTINE force_domain_nmm_part2
    nested_grid%dtbc = 0.
 !
    grid => nested_grid%intermediate_grid
-#  if defined(MOVE_NESTS) || (!defined(SGIALTIX))
+#  if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10))))
    CALL dealloc_space_field ( grid )
 #  endif
 # endif
@@ -244,7 +244,7 @@ END SUBROUTINE force_domain_nmm_part2
 
    grid => nested_grid%intermediate_grid
 !dusan orig    CALL alloc_space_field ( grid, grid%id , 1 , 2 ,  .TRUE. ,    &
-#if defined(MOVE_NESTS) || (!defined(SGIALTIX))
+#  if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10))))
    CALL ensure_space_field &
                           ( grid, grid%id , 1 , 3 ,  .FALSE. ,    &
                             grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
@@ -257,6 +257,10 @@ END SUBROUTINE force_domain_nmm_part2
       )
 #endif
    nested_grid%intermediate_grid%interp_mp=parent_grid%interp_mp .or. nested_grid%interp_mp
+#if (HWRF == 1)
+  nested_grid%intermediate_grid%pdyn_parent_age=parent_grid%pdyn_parent_age
+  nested_grid%intermediate_grid%pdyn_smooth_age=parent_grid%pdyn_smooth_age
+#endif
 
 
     ! couple parent domain
diff --git a/wrfv2_fire/share/mediation_integrate.F b/wrfv2_fire/share/mediation_integrate.F
index c8576b96..352f1ca1 100644
--- a/wrfv2_fire/share/mediation_integrate.F
+++ b/wrfv2_fire/share/mediation_integrate.F
@@ -120,6 +120,22 @@ SUBROUTINE med_before_solve_io ( grid , config_flags )
            CALL WRFU_AlarmRingerOff( grid%alarms( ialarm ), rc=rc )
          ENDIF
        ENDIF
+     ELSE IF( ialarm .EQ. AUXINPUT7_ALARM .AND. config_flags%chem_opt > 0 ) THEN
+       IF( config_flags%biomass_burn_opt /= 0 ) THEN
+         IF( WRFU_AlarmIsRinging( grid%alarms( ialarm ), rc=rc ) .OR.  &
+         ((config_flags%restart) .AND. ( currTime .EQ. startTime ))) THEN
+           CALL med_auxinput_in ( grid, ialarm, config_flags )
+           WRITE ( message , FMT='(A,i3,A,i3)') 'Input data processed for aux input ',&
+                  ialarm - first_auxinput + 1, ' for domain ',grid%id
+           CALL wrf_debug ( 15 , message )
+           CALL WRFU_AlarmRingerOff( grid%alarms( ialarm ), rc=rc )
+         ENDIF
+       ELSE
+        IF( WRFU_AlarmIsRinging( grid%alarms( ialarm ), rc=rc ) ) THEN
+          CALL med_auxinput_in ( grid, ialarm, config_flags )
+          CALL WRFU_AlarmRingerOff( grid%alarms( ialarm ), rc=rc )
+        ENDIF
+       ENDIF
      ELSE IF( ialarm .EQ. AUXINPUT13_ALARM .AND. config_flags%chem_opt > 0 ) THEN
        IF( config_flags%emiss_opt_vol /= 0 ) THEN
          IF( WRFU_AlarmIsRinging( grid%alarms( ialarm ), rc=rc ) ) THEN
@@ -1751,6 +1767,9 @@ SUBROUTINE med_latbound_in ( grid , config_flags )
    Type (WRFU_Time )                      :: startTime, stopTime, currentTime
    Type (WRFU_TimeInterval )              :: stepTime
 integer myproc,i,j,k
+#ifdef _MULTI_BDY_FILES_
+   CHARACTER(LEN=80)                      :: timestr
+#endif
 
 #include 
 
@@ -1786,8 +1805,14 @@ SUBROUTINE med_latbound_in ( grid , config_flags )
        CALL WRFU_AlarmRingerOff( grid%alarms( BOUNDARY_ALARM ), rc=rc )
        IF ( wrf_dm_on_monitor() ) CALL start_timing
 
+#ifdef _MULTI_BDY_FILES_
+       ! Possibility to have a  as part of the bdy_inname.
+       CALL domain_clock_get( grid, current_timestr=timestr )
+       CALL construct_filename2a ( bdyname , config_flags%bdy_inname , grid%id , 2 , timestr )
+#else
 ! typically a  wouldn't be part of the bdy_inname, so just pass a dummy
-       CALL construct_filename2a ( bdyname , config_flags%bdy_inname , grid%id , 2 , 'dummydate' )
+       CALL construct_filename2a ( bdyname , config_flags%bdy_inname , grid%id , 2 , " " )
+#endif
 
        CALL wrf_inquire_opened(grid%lbc_fid , TRIM(bdyname) , open_status , ierr ) 
        IF ( open_status .EQ. WRF_FILE_OPENED_FOR_READ ) THEN
@@ -1796,17 +1821,21 @@ SUBROUTINE med_latbound_in ( grid , config_flags )
          lbc_opened = .FALSE.
        ENDIF
        CALL wrf_dm_bcast_bytes ( lbc_opened , LWORDSIZE )
-       CALL construct_filename2a ( bdyname , grid%bdy_inname , grid%id , 2 , " " )
        IF ( .NOT. lbc_opened ) THEN
-         WRITE(message,*)'Opening: ',TRIM(bdyname)
-         CALL wrf_debug(100,TRIM(message))
-         CALL open_r_dataset ( grid%lbc_fid, TRIM(bdyname) , grid , config_flags , "DATASET=BOUNDARY", ierr )
+#ifdef _MULTI_BDY_FILES_
+         CALL construct_filename2a ( bdyname , config_flags%bdy_inname , grid%id , 2 , timestr )
+#else
+         CALL construct_filename2a ( bdyname , config_flags%bdy_inname , grid%id , 2 , " " )
+#endif
+          WRITE(message,*)'Opening: ',TRIM(bdyname)
+          CALL wrf_debug(100,TRIM(message))
+          CALL open_r_dataset ( grid%lbc_fid, TRIM(bdyname) , grid , config_flags , "DATASET=BOUNDARY", ierr )
           IF ( ierr .NE. 0 ) THEN
             WRITE( message, * ) 'med_latbound_in: error opening ',TRIM(bdyname), ' for reading. IERR = ',ierr
             CALL WRF_ERROR_FATAL( message )
           ENDIF
        ELSE
-         CALL wrf_debug( 100 , bdyname // 'already opened' )
+         CALL wrf_debug( 100 , bdyname // ' is already opened' )
        ENDIF
        CALL wrf_debug( 100 , 'med_latbound_in: calling input_boundary ' )
        CALL input_boundary ( grid%lbc_fid, grid , config_flags , ierr )
@@ -1823,6 +1852,10 @@ SUBROUTINE med_latbound_in ( grid , config_flags )
          CALL wrf_debug( 100 , 'med_latbound_in: calling input_boundary ' )
          CALL input_boundary ( grid%lbc_fid, grid , config_flags , ierr )
        ENDDO
+#ifdef _MULTI_BDY_FILES_
+       ! Close the bdy file so that next time around, we'll open it again.
+       CALL close_dataset ( grid%lbc_fid , config_flags , "DATASET=BOUNDARY" )
+#endif
        CALL WRFU_AlarmSet( grid%alarms( BOUNDARY_ALARM ), RingTime=grid%next_bdy_time, rc=rc )
 
        IF ( ierr .NE. 0 .and. ierr .NE. WRF_WARN_NETCDF ) THEN
diff --git a/wrfv2_fire/share/mediation_interp_domain.F b/wrfv2_fire/share/mediation_interp_domain.F
index 349bec02..72984cea 100644
--- a/wrfv2_fire/share/mediation_interp_domain.F
+++ b/wrfv2_fire/share/mediation_interp_domain.F
@@ -111,7 +111,7 @@ END SUBROUTINE interp_domain_nmm_part2
 #if (EM_CORE == 1 && defined( DM_PARALLEL ))
   CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
   grid => nested_grid%intermediate_grid
-# if defined(MOVE_NESTS) || (!defined(SGIALTIX))
+#  if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10))))
 
   CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. ,   &
                            grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
@@ -142,7 +142,7 @@ END SUBROUTINE interp_domain_nmm_part2
 
   grid => nested_grid%intermediate_grid
   CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
-# if defined(MOVE_NESTS) || (!defined(SGIALTIX))
+#  if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10))))
   CALL dealloc_space_field ( grid )
 # endif
 #endif
@@ -160,7 +160,7 @@ END SUBROUTINE interp_domain_nmm_part2
 !
   CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
   grid => nested_grid%intermediate_grid
-#if defined(MOVE_NESTS) || (!defined(SGIALTIX))
+#  if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10))))
   CALL ensure_space_field &
                          ( grid, grid%id , 1 , 2 , .TRUE. ,   &
                            grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
@@ -173,6 +173,10 @@ END SUBROUTINE interp_domain_nmm_part2
       )
 #endif
   nested_grid%intermediate_grid%interp_mp=parent_grid%interp_mp .or. nested_grid%interp_mp
+#if (HWRF == 1)
+  nested_grid%intermediate_grid%pdyn_parent_age=parent_grid%pdyn_parent_age
+  nested_grid%intermediate_grid%pdyn_smooth_age=parent_grid%pdyn_smooth_age
+#endif
 
   grid => parent_grid
 
@@ -265,7 +269,7 @@ END SUBROUTINE interp_domain_em_small_part2
 #if (EM_CORE == 1 && defined( DM_PARALLEL ))
   CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags )
   grid => nested_grid%intermediate_grid
-# if defined(MOVE_NESTS) || (!defined(SGIALTIX))
+#  if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10))))
 
   CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. ,   &
                            grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, &
@@ -296,7 +300,7 @@ END SUBROUTINE interp_domain_em_small_part2
 
   grid => nested_grid%intermediate_grid
   CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
-# if defined(MOVE_NESTS) || (!defined(SGIALTIX))
+#  if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10))))
   CALL dealloc_space_field ( grid )
 # endif
 #endif
diff --git a/wrfv2_fire/share/mediation_nest_move.F b/wrfv2_fire/share/mediation_nest_move.F
index 99e7ee3c..389662ea 100644
--- a/wrfv2_fire/share/mediation_nest_move.F
+++ b/wrfv2_fire/share/mediation_nest_move.F
@@ -1385,7 +1385,7 @@ LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y )
             endif
          endif
       endif nest_following
-      revised_nest_motion: if(grid%vortex_tracker==4) then
+      revised_nest_motion: if(grid%vortex_tracker>3) then
          if((grid%XLOC_1-grid%XLOC_2) .GE. 3) then
             move_cd_x=-1
          elseif((grid%XLOC_2-grid%XLOC_1) .GE. 3) then
diff --git a/wrfv2_fire/share/mediation_wrfmain.F b/wrfv2_fire/share/mediation_wrfmain.F
index 02ad36ac..5353dab3 100644
--- a/wrfv2_fire/share/mediation_wrfmain.F
+++ b/wrfv2_fire/share/mediation_wrfmain.F
@@ -77,6 +77,36 @@ END SUBROUTINE start_domain
           WRITE ( message , FMT = '("processing wrfinput file (stream 0) for domain ",I8)' ) grid%id
           CALL end_timing ( TRIM(message) )
         ENDIF
+
+!gmm add input for noamp hydro model here
+     IF ( config_flags%opt_run.eq.5 ) THEN
+
+        CALL construct_filename2a ( inpname , config_flags%auxinput7_inname &
+                                 ,grid%id , 2 , timestr)
+
+     if( grid%auxinput7_oid .NE. 0 ) then
+       CALL close_dataset ( grid%auxinput7_oid , config_flags , "DATASET=AUXINPUT7" )
+     endif
+        
+        CALL open_r_dataset ( grid%auxinput7_oid, TRIM(inpname) , grid , config_flags , "DATASET=AUXINPUT7", ierr )
+
+!        call set_first_operation(grid%auxinput6_oid)
+
+        
+        IF ( ierr .NE. 0 ) THEN
+          WRITE( wrf_err_message , * ) 'program wrf: error opening ',TRIM(inpname),' for reading ierr=',ierr
+          CALL WRF_ERROR_FATAL ( wrf_err_message )
+        ENDIF
+           
+           CALL wrf_debug              (   0 , 'med_initialdata_input: calling input_aux_model_input7' )
+           CALL input_auxinput7 ( grid%auxinput7_oid ,   grid , config_flags , ierr )
+           CALL wrf_debug              ( 100 , 'med_initialdata_input: back from input_aux_model_input7' )
+        
+        CALL close_dataset ( grid%auxinput7_oid , config_flags , "DATASET=AUXINPUT7" )
+       
+       ENDIF
+!gmm
+
 #ifdef MOVE_NESTS
 #if ( EM_CORE == 1 )
         grid%nest_pos = grid%ht
diff --git a/wrfv2_fire/share/module_bc.F b/wrfv2_fire/share/module_bc.F
index c4697a0f..74c23c2c 100644
--- a/wrfv2_fire/share/module_bc.F
+++ b/wrfv2_fire/share/module_bc.F
@@ -230,7 +230,7 @@ SUBROUTINE set_physical_bc2d( dat, variable_in,  &
       REAL,  DIMENSION( ims:ime , jms:jme ) :: dat
       TYPE( grid_config_rec_type ) config_flags
 
-      INTEGER  :: i, j, istag, jstag, itime
+      INTEGER  :: i, j, istag, jstag, itime, istart, iend
 
       LOGICAL  :: debug, open_bc_copy
 
@@ -431,15 +431,30 @@ SUBROUTINE set_physical_bc2d( dat, variable_in,  &
 
 !  same procedure in y
 
+!  Set the starting and ending loop indexes in the 'i' direction, so that
+!  halo cells on the edge of the domain are also updated.  Begin with a default 
+!  start and end index for inner tiles, and then modify if the tile is on the
+!  edge of the domain.  
+
+        istart = MAX(ids, its-1)
+        iend = MIN(ite+1, ide+istag)
+        IF ( its .eq. ids) THEN
+          istart = ims
+        END IF
+        IF ( ite .eq. ide) THEN
+          iend = ime
+        END IF
+
       periodicity_y:  IF( ( config_flags%periodic_y ) ) THEN
         IF ( ( jds == jps ) .and. ( jde == jpe ) )  THEN    ! test of both north and south on processor
 
           IF( jts == jds ) then
 
             DO j = 0, -(bdyzone-1), -1
-            DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
-              dat(i,jds+j-1) = dat(i,jde+j-1)
-            ENDDO
+              !DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+              DO i = istart, iend
+                dat(i,jds+j-1) = dat(i,jde+j-1)
+              ENDDO
             ENDDO
 
           END IF
@@ -447,9 +462,10 @@ SUBROUTINE set_physical_bc2d( dat, variable_in,  &
           IF( jte == jde ) then
 
             DO j = -jstag, bdyzone
-            DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
-              dat(i,jde+j+jstag) = dat(i,jds+j+jstag)
-            ENDDO
+              !DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+              DO i = istart, iend
+                dat(i,jde+j+jstag) = dat(i,jds+j+jstag)
+              ENDDO
             ENDDO
 
           END IF
@@ -464,9 +480,10 @@ SUBROUTINE set_physical_bc2d( dat, variable_in,  &
           IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
 
             DO j = 1, bdyzone
-            DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
-              dat(i,jds-j) = dat(i,jds+j-1) 
-            ENDDO
+              !DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+              DO i = istart, iend
+                dat(i,jds-j) = dat(i,jds+j-1) 
+              ENDDO
             ENDDO
 
           ELSE
@@ -474,17 +491,19 @@ SUBROUTINE set_physical_bc2d( dat, variable_in,  &
             IF (variable == 'v') THEN
 
               DO j = 1, bdyzone
-              DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
-                dat(i,jds-j) = - dat(i,jds+j) 
-              ENDDO              
+                !DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+                DO i = istart, iend
+                  dat(i,jds-j) = - dat(i,jds+j) 
+                ENDDO              
               ENDDO
 
             ELSE
 
               DO j = 1, bdyzone
-              DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
-                dat(i,jds-j) = dat(i,jds+j) 
-              ENDDO              
+                !DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+                DO i = istart, iend
+                  dat(i,jds-j) = dat(i,jds+j) 
+                ENDDO              
               ENDDO
 
             END IF
@@ -501,9 +520,10 @@ SUBROUTINE set_physical_bc2d( dat, variable_in,  &
           IF ( (variable /= 'v') .and. (variable /= 'y') ) THEN
 
             DO j = 1, bdyzone
-            DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
-              dat(i,jde+j-1) = dat(i,jde-j) 
-            ENDDO                               
+              !DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+              DO i = istart, iend
+                dat(i,jde+j-1) = dat(i,jde-j) 
+              ENDDO                               
             ENDDO
 
           ELSE
@@ -511,17 +531,19 @@ SUBROUTINE set_physical_bc2d( dat, variable_in,  &
             IF (variable == 'v' ) THEN
 
               DO j = 1, bdyzone
-              DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
-                dat(i,jde+j) = - dat(i,jde-j)    ! bugfix: changed jds on rhs to jde , JM 20020410
-              ENDDO                               
+                !DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+                DO i = istart, iend
+                  dat(i,jde+j) = - dat(i,jde-j)    ! bugfix: changed jds on rhs to jde , JM 20020410
+                ENDDO                               
               ENDDO
 
             ELSE
 
               DO j = 1, bdyzone
-              DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
-                dat(i,jde+j) = dat(i,jde-j)
-              ENDDO                               
+                !DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+                DO i = istart, iend
+                  dat(i,jde+j) = dat(i,jde-j)
+                ENDDO                               
               ENDDO
 
             END IF
@@ -538,7 +560,8 @@ SUBROUTINE set_physical_bc2d( dat, variable_in,  &
                        config_flags%nested            ) .and.  &
                          ( jts == jds) .and. open_bc_copy )  THEN
 
-            DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+            !DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+            DO i = istart, iend
               dat(i,jds-1) = dat(i,jds) 
               dat(i,jds-2) = dat(i,jds) 
               dat(i,jds-3) = dat(i,jds) 
@@ -556,7 +579,8 @@ SUBROUTINE set_physical_bc2d( dat, variable_in,  &
 
           IF  (variable /= 'v' .and. variable /= 'y' ) THEN
 
-            DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+            !DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+            DO i = istart, iend
               dat(i,jde  ) = dat(i,jde-1) 
               dat(i,jde+1) = dat(i,jde-1) 
               dat(i,jde+2) = dat(i,jde-1) 
@@ -564,7 +588,8 @@ SUBROUTINE set_physical_bc2d( dat, variable_in,  &
 
           ELSE
 
-            DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+            !DO i = MAX(ids,its-1), MIN(ite+1,ide+istag)
+            DO i = istart, iend
               dat(i,jde+1) = dat(i,jde) 
               dat(i,jde+2) = dat(i,jde) 
               dat(i,jde+3) = dat(i,jde) 
@@ -1635,13 +1660,16 @@ SUBROUTINE spec_bdytend_perturb   ( field_tend,                   &
           DO k = kts, ktf
             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
             IF (variable == 't') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j)) 
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j)) 
             ENDIF
             IF (variable == 'u') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j)
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j)
             ENDIF
             IF (variable == 'v') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j)
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j)
             ENDIF
             ENDDO
           ENDDO
@@ -1658,13 +1686,16 @@ SUBROUTINE spec_bdytend_perturb   ( field_tend,                   &
           DO k = kts, ktf 
             DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit)
             IF (variable == 't') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j))
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j))
             ENDIF
             IF (variable == 'u') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j)
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j)
             ENDIF
             IF (variable == 'v') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j)
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j)
             ENDIF
 	    ENDDO
           ENDDO
@@ -1679,13 +1710,16 @@ SUBROUTINE spec_bdytend_perturb   ( field_tend,                   &
           DO k = kts, ktf
             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
             IF (variable == 't') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j))
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j))
             ENDIF
             IF (variable == 'u') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j)
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j)
             ENDIF
             IF (variable == 'v') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j)
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j)
             ENDIF
             ENDDO
           ENDDO
@@ -1699,13 +1733,16 @@ SUBROUTINE spec_bdytend_perturb   ( field_tend,                   &
           DO k = kts, ktf
             DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1)
             IF (variable == 't') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j))
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j))
             ENDIF
             IF (variable == 'u') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j)
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j)
             ENDIF
             IF (variable == 'v') THEN
-            field_tend(i,k,j) = field_tend(i,k,j) + field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j)
+              field_tend(i,k,j) = field_tend(i,k,j) + &
+                                  field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j)
             ENDIF
             ENDDO
           ENDDO
diff --git a/wrfv2_fire/share/module_check_a_mundo.F b/wrfv2_fire/share/module_check_a_mundo.F
index 8d879ef1..dbafb736 100644
--- a/wrfv2_fire/share/module_check_a_mundo.F
+++ b/wrfv2_fire/share/module_check_a_mundo.F
@@ -44,6 +44,7 @@ SUBROUTINE  check_nml_consistency
       LOGICAL :: exists
       LOGICAL , EXTERNAL :: wrf_dm_on_monitor
       INTEGER :: i, oops
+      LOGICAL :: km_opt_already_done , diff_opt_already_done
 
 !-----------------------------------------------------------------------
 ! Set up the WRF Hydro namelist option to allow dynamic allocation of
@@ -56,13 +57,58 @@ SUBROUTINE  check_nml_consistency
 #endif
 
 
+#if (EM_CORE == 1)
+!-----------------------------------------------------------------------
+! Check that all values of diff_opt and km_opt are filled in.  A flag
+! value of "-1" from the nml file means that this column (domain) is not
+! filled as a max_doamins variable.  Since we changed these two variables 
+! from being single entries to max_domain entries, we need to do special 
+! checking.  If there are missing values (if we find any -1 entries), we 
+! fill those columns with the value from the entry from column (domain) #1.
+!-----------------------------------------------------------------------
+
+      km_opt_already_done = .FALSE.
+      diff_opt_already_done = .FALSE.
+      DO i = 2, model_config_rec % max_dom
+         IF ( model_config_rec % km_opt(i) .EQ. -1 ) THEN
+            model_config_rec % km_opt(i) = model_config_rec % km_opt(1)
+            IF ( .NOT. km_opt_already_done ) THEN
+               CALL wrf_message ( "Setting blank km_opt entries to domain #1 values.")
+               CALL wrf_message ( " --> The km_opt entry in the namelist.input is now max_domains." )
+            END IF
+            km_opt_already_done = .TRUE.
+         END IF
+         IF ( model_config_rec % diff_opt(i) .EQ. -1 ) THEN
+            model_config_rec % diff_opt(i) = model_config_rec % diff_opt(1)
+            IF ( .NOT. diff_opt_already_done ) THEN
+               CALL wrf_message ( "Setting blank diff_opt entries to domain #1 values.")
+               CALL wrf_message ( " --> The diff_opt entry in the namelist.input is now max_domains." )
+            END IF
+            diff_opt_already_done = .TRUE.
+         END IF
+      ENDDO
+
+
+!-----------------------------------------------------------------------
+! Check that km_opt and diff_opt are not -1.  If the first column is set
+! to -1, that means this entry is NOT in the namelist file at all.
+!-----------------------------------------------------------------------
+
+      IF ( ( model_config_rec %   km_opt(1) .EQ. -1 ) .OR. &
+           ( model_config_rec % diff_opt(1) .EQ. -1 ) ) THEN
+            wrf_err_message = 'Both km_opt and diff_opt need to be set in the namelist.input file.'
+         CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
+      END IF
+#endif
+
+
 !-----------------------------------------------------------------------
 ! Check that all values of sf_surface_physics are the same for all domains
 !-----------------------------------------------------------------------
 
       DO i = 2, model_config_rec % max_dom
          IF ( model_config_rec % sf_surface_physics(i)     .NE. &
-              model_config_rec % sf_surface_physics(i-1) ) THEN
+              model_config_rec % sf_surface_physics(1) ) THEN
             wrf_err_message = '--- ERROR: sf_surface_physics must be equal for all domains '
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Fix sf_surface_physics in namelist.input '
@@ -70,6 +116,92 @@ SUBROUTINE  check_nml_consistency
          END IF
       ENDDO
 
+
+!-----------------------------------------------------------------------
+! Check that all values of sf_sfclay_physics are the same for all domains
+!-----------------------------------------------------------------------
+
+      DO i = 2, model_config_rec % max_dom
+         IF ( model_config_rec % sf_sfclay_physics(i)     .NE. &
+              model_config_rec % sf_sfclay_physics(1) ) THEN
+            wrf_err_message = '--- ERROR: sf_sfclay_physics must be equal for all domains '
+            CALL wrf_message ( wrf_err_message )
+            wrf_err_message = '--- Fix sf_sfclay_physics in namelist.input '
+            CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
+         END IF
+      ENDDO
+
+
+!-----------------------------------------------------------------------
+! Check that all values of mp_physics are the same for all domains
+!-----------------------------------------------------------------------
+
+      DO i = 2, model_config_rec % max_dom
+         IF ( model_config_rec % mp_physics(i)     .NE. &
+              model_config_rec % mp_physics(1) ) THEN
+            wrf_err_message = '--- ERROR: mp_physics must be equal for all domains '
+            CALL wrf_message ( wrf_err_message )
+            wrf_err_message = '--- Fix mp_physics in namelist.input '
+            CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
+         END IF
+      ENDDO
+
+
+!-----------------------------------------------------------------------
+! Check that all values of ra_physics are the same for all domains
+!-----------------------------------------------------------------------
+
+      DO i = 2, model_config_rec % max_dom
+         IF ( model_config_rec % ra_lw_physics(i)     .NE. &
+              model_config_rec % ra_lw_physics(1) ) THEN
+            wrf_err_message = '--- ERROR: ra_lw_physics must be equal for all domains '
+            CALL wrf_message ( wrf_err_message )
+            wrf_err_message = '--- Fix ra_lw_physics in namelist.input '
+            CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
+         END IF
+      ENDDO
+
+      DO i = 2, model_config_rec % max_dom
+         IF ( model_config_rec % ra_sw_physics(i)     .NE. &
+              model_config_rec % ra_sw_physics(1) ) THEN
+            wrf_err_message = '--- ERROR: ra_sw_physics must be equal for all domains '
+            CALL wrf_message ( wrf_err_message )
+            wrf_err_message = '--- Fix ra_sw_physics in namelist.input '
+            CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
+         END IF
+      ENDDO
+
+
+!-----------------------------------------------------------------------
+! Check that all values of bl_pbl_physics are the same for all domains
+!-----------------------------------------------------------------------
+
+      DO i = 2, model_config_rec % max_dom
+         IF ( ( model_config_rec % bl_pbl_physics(i) .NE. model_config_rec % bl_pbl_physics(1) ) .AND. &
+              ( model_config_rec % bl_pbl_physics(i) .NE. 0                                    ) ) THEN
+            wrf_err_message = '--- ERROR: bl_pbl_physics must be equal for all domains (or = zero)'
+            CALL wrf_message ( wrf_err_message )
+            wrf_err_message = '--- Fix bl_pbl_physics in namelist.input '
+            CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
+         END IF
+      ENDDO
+
+
+!-----------------------------------------------------------------------
+! Check that all values of cu_physics are the same for all domains
+! Note that a zero option is OK.
+!-----------------------------------------------------------------------
+
+      DO i = 2, model_config_rec % max_dom
+         IF ( ( model_config_rec % cu_physics(i) .NE. model_config_rec % cu_physics(1) ) .AND. &
+              ( model_config_rec % cu_physics(i) .NE. 0                                ) ) THEN
+            wrf_err_message = '--- ERROR: cu_physics must be equal for all domains (or = zero)'
+            CALL wrf_message ( wrf_err_message )
+            wrf_err_message = '--- Fix cu_physics in namelist.input '
+            CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
+         END IF
+      ENDDO
+
 !-----------------------------------------------------------------------
 ! If fractional_seaice = 0, and tice2tsk_if2cold = .true, nothing will happen
 !-----------------------------------------------------------------------
@@ -127,7 +259,8 @@ SUBROUTINE  check_nml_consistency
 
                write (wrf_err_message, '(" --- ERROR:   seaice_albedo_opt == 1 works only with ")')
                CALL wrf_message ( TRIM ( wrf_err_message ) )
-               write (wrf_err_message, '("              sf_surface_physics == ", I2, " (Noah) or ", I2, " (Noah-MP).")') LSMSCHEME, NOAHMPSCHEME
+               write (wrf_err_message, '("              sf_surface_physics == ", I2, " (Noah) or ", I2, " (Noah-MP).")') &
+               LSMSCHEME, NOAHMPSCHEME
                call wrf_error_fatal ( TRIM ( wrf_err_message ) )
 
             END IF
@@ -141,14 +274,14 @@ SUBROUTINE  check_nml_consistency
 
 #if (EM_CORE == 1)
 !-----------------------------------------------------------------------
-! Check that if stochastic perturbations are turned on in any domain, 
+! Check that if any stochastic perturbation scheme is turned on in any domain, 
 ! if so, set grid%stoch_force_global_opt=1 
 !-----------------------------------------------------------------------
 
    model_config_rec % stoch_force_global_opt=0  !also set in registry.stoch
  ! check if stochastic perturbations are turned on in any domain
    DO i = 1, model_config_rec % max_dom
-         IF ( model_config_rec % stoch_force_opt(i) .EQ. 1)  then 
+         IF ( model_config_rec % stoch_force_opt(i) .NE. 0)  then 
            model_config_rec % stoch_force_global_opt=1 
          endif
    ENDDO 
@@ -184,7 +317,7 @@ SUBROUTINE  check_nml_consistency
 !-----------------------------------------------------------------------
 ! In program real, if hypsometric_opt = 2, adjust_heights cannot be set to .true. 
 !-----------------------------------------------------------------------
-      IF ( model_config_rec%hypsometric_opt .EQ. 2 \
+      IF ( model_config_rec%hypsometric_opt .EQ. 2 &
            .AND. model_config_rec%adjust_heights ) THEN
            WRITE (wrf_err_message, FMT='(A,A)') '--- NOTE: hypsometric_opt is 2, ', &
                   'setting adjust_heights = F'
@@ -323,24 +456,29 @@ SUBROUTINE  check_nml_consistency
       END IF
 
 !-----------------------------------------------------------------------
-!  shcu_physics = 3 (grimsshcuscheme) only works with YSU PBL.     
+!  shcu_physics = 3 (grimsshcuscheme) only works with YSU & MYNN PBL.
 !-----------------------------------------------------------------------
 
       oops = 0
       DO i = 1, model_config_rec % max_dom
-         IF ( ( model_config_rec%bl_pbl_physics(i) .NE. YSUSCHEME ) .AND. &
-              ( model_config_rec%shcu_physics(i) .EQ. GRIMSSHCUSCHEME ) ) THEN
-            model_config_rec%shcu_physics(i) = 0
-            oops = oops + 1
+         IF ( model_config_rec%shcu_physics(i) .EQ. GRIMSSHCUSCHEME ) THEN
+            IF ( (model_config_rec%bl_pbl_physics(i) .EQ. YSUSCHEME) .OR. &
+                 (model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME2) .OR. &
+                 (model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME3) ) THEN
+               !NO PROBLEM
+            ELSE
+               model_config_rec%shcu_physics(i) = 0
+               oops = oops + 1
+            END IF
          END IF
       ENDDO      ! Loop over domains
       IF ( oops .GT. 0 ) THEN
-         wrf_err_message = 'bl_pbl_physics /= 1, implies shcu_physics cannot be 3, resetting'
+         wrf_err_message = 'bl_pbl_physics /= 1,5,6 implies shcu_physics cannot be 3, resetting'
          CALL wrf_message ( wrf_err_message )
       END IF
 
 !-----------------------------------------------------------------------
-!  shcu_physics = 3 (grimsshcuscheme) only works with YSU PBL.
+!  gwd_opt = 1 only works with YSU PBL.
 !-----------------------------------------------------------------------
 
       oops = 0
@@ -352,7 +490,7 @@ SUBROUTINE  check_nml_consistency
          END IF
       ENDDO      ! Loop over domains
       IF ( oops .GT. 0 ) THEN
-         wrf_err_message = 'bl_pbl_physics /= 1, implies shcu_physics cannot be 3, resetting'
+         wrf_err_message = 'bl_pbl_physics /= 1, implies gwd_opt cannot be 1, resetting'
          CALL wrf_message ( wrf_err_message )
       END IF
 
@@ -445,6 +583,7 @@ SUBROUTINE  check_nml_consistency
 
       IF ( model_config_rec%use_adaptive_time_step ) THEN
          IF ( ( model_config_rec%cu_physics(1) .EQ. BMJSCHEME     ) .OR. &
+              ( model_config_rec%cu_physics(1) .EQ. MESO_SAS     ) .OR. &
               ( model_config_rec%cu_physics(1) .EQ. SASSCHEME     ) .OR. &
               ( model_config_rec%cu_physics(1) .EQ. OSASSCHEME    ) .OR. &
               ( model_config_rec%cu_physics(1) .EQ. NSASSCHEME    ) .OR. &
@@ -469,11 +608,15 @@ SUBROUTINE  check_nml_consistency
       DO i = 1, model_config_rec % max_dom
          IF ( ( model_config_rec%cu_rad_feedback(i) .EQV. .TRUE. )  .OR. &
               ( model_config_rec%cu_rad_feedback(i) .EQV. .true. ) ) THEN
-            wrf_err_message = '--- WARNING: Turning on cu_rad_feedback also requires setting cu_diag== 1'
-            CALL wrf_message ( wrf_err_message )
-            model_config_rec%cu_diag(i) = 1
-         ELSE
-            model_config_rec%cu_diag(i) = 0
+            IF ( ( model_config_rec%cu_physics(1) .EQ. GFSCHEME     ) .OR. &
+                 ( model_config_rec%cu_physics(1) .EQ. G3SCHEME     ) .OR. &
+                 ( model_config_rec%cu_physics(1) .EQ. GDSCHEME     ) ) THEN
+               wrf_err_message = '--- WARNING: Turning on cu_rad_feedback also requires setting cu_diag== 1'
+               CALL wrf_message ( wrf_err_message )
+               model_config_rec%cu_diag(i) = 1
+            ELSE
+               model_config_rec%cu_diag(i) = 0
+            END IF
          END IF
       END DO
 
@@ -544,6 +687,18 @@ SUBROUTINE  check_nml_consistency
          END IF
       ENDDO      ! Loop over domains
 
+!-----------------------------------------------------------------------
+!  Do not allow digital filtering to be run with TEMF.
+!-----------------------------------------------------------------------
+
+      DO i = 1, model_config_rec % max_dom
+         IF ( ( model_config_rec%bl_pbl_physics(i) .EQ. TEMFPBLSCHEME ) .AND. &
+              (model_config_rec%dfi_opt .NE. DFI_NODFI) )  THEN
+            wrf_err_message = '--- ERROR: DFI not available for bl_pbl_physics=10 '
+            CALL wrf_error_fatal ( TRIM(wrf_err_message) )
+         END IF
+      ENDDO      ! Loop over domains
+
 !-----------------------------------------------------------------------
 !  The CLM scheme may not even be compiled, so make sure it is not allowed
 !  to be run if the code is not available.
@@ -566,7 +721,42 @@ SUBROUTINE  check_nml_consistency
       END IF
 #endif
 
+!-----------------------------------------------------------------------
+!  grav_settling = 1 must be turned off for mp_physics=28.
+!-----------------------------------------------------------------------
+      oops = 0
+      DO i = 1, model_config_rec % max_dom
+         IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO ) THEN
+            IF ( model_config_rec%grav_settling(i) .NE. FOGSETTLING0 ) THEN
+                model_config_rec%grav_settling(i) = 0
+                oops = oops + 1
+            END IF
+         END IF
+      ENDDO      ! Loop over domains
+      IF ( oops .GT. 0 ) THEN
+         wrf_err_message = 'mp_physics == 28, already has gravitational fog settling; resetting grav_settling to 0'
+         CALL wrf_message ( wrf_err_message )
+      END IF
  
+!-----------------------------------------------------------------------
+!  scalar_pblmix = 1 should be turned on for mp_physics=28.
+!-----------------------------------------------------------------------
+      oops = 0
+      DO i = 1, model_config_rec % max_dom
+         IF ( model_config_rec%mp_physics(i) .EQ. THOMPSONAERO ) THEN
+            IF ( model_config_rec%use_aero_icbc .AND. model_config_rec%scalar_pblmix(i) .NE. 1 ) THEN
+                model_config_rec%scalar_pblmix(i) = 1
+                oops = oops + 1
+            END IF
+         END IF
+      ENDDO      ! Loop over domains
+      IF ( oops .GT. 0 ) THEN
+         wrf_err_message = 'For mp_physics == 28 and use_aero_icbc is true, recommend to turn on scalar_pblmix'
+         CALL wrf_message ( wrf_err_message )
+         wrf_err_message = 'resetting scalar_pblmix = 1'
+         CALL wrf_message ( wrf_err_message )
+      END IF
+
 !-----------------------------------------------------------------------
 !  Remapping namelist variables for gridded and surface fdda to aux streams 9 and 10.
 !  Relocated here so that the remappings are after checking the namelist for inconsistencies.
@@ -593,6 +783,24 @@ SUBROUTINE set_physics_rconfigs
 
       IMPLICIT NONE
 
+!-----------------------------------------------------------------------
+! Set the namelist mosaic_cat_soil parameter for the Noah-mosaic  scheme if sf_surface_mosaic == 1.  
+!-----------------------------------------------------------------------
+      INTEGER :: numsoiltemp , nummosaictemp
+
+      IF ( model_config_rec % sf_surface_mosaic .EQ. 1 ) THEN
+      
+      numsoiltemp = model_config_rec % num_soil_layers
+      nummosaictemp = model_config_rec % mosaic_cat
+      
+         model_config_rec % mosaic_cat_soil = numsoiltemp * nummosaictemp
+
+         wrf_err_message = '--- NOTE: Noah-mosaic is in use, setting:  ' // &
+                           'mosaic_cat_soil = mosaic_cat * num_soil_layers'
+         CALL wrf_message ( wrf_err_message )
+
+      END IF     
+      
 !-----------------------------------------------------------------------
 ! Set the namelist parameters for the CAM radiation scheme if either 
 ! ra_lw_physics = CAMLWSCHEME or ra_sw_physics = CAMSWSCHEME.  
@@ -641,7 +849,8 @@ SUBROUTINE set_physics_rconfigs
            model_config_rec % num_soil_layers = 4
       IF ( model_config_rec % sf_surface_physics(1) .EQ. NOAHMPSCHEME   ) &
            model_config_rec % num_soil_layers = 4
-      IF ( model_config_rec % sf_surface_physics(1) .EQ. RUCLSMSCHEME) &
+      IF ( model_config_rec % sf_surface_physics(1) .EQ. RUCLSMSCHEME .AND. &
+           (model_config_rec % num_soil_layers .NE. 6 .AND. model_config_rec % num_soil_layers .NE. 9) ) &
            model_config_rec % num_soil_layers = 6
       IF ( model_config_rec % sf_surface_physics(1) .EQ. PXLSMSCHEME ) &
            model_config_rec % num_soil_layers = 2
diff --git a/wrfv2_fire/share/module_compute_geop.F b/wrfv2_fire/share/module_compute_geop.F
index 9835073f..d7dc0c26 100644
--- a/wrfv2_fire/share/module_compute_geop.F
+++ b/wrfv2_fire/share/module_compute_geop.F
@@ -41,7 +41,7 @@ SUBROUTINE compute_500mb_height  ( ph, phb, p, pb,                  &
    do j = jts, min(jde-1,jte)
    do i = its, min(ide-1,ite)
 
-      do k=kds,kde
+      do k=kds,kde-1
         pressure(k) = p(i,k,j) + pb(i,k,j)
         geopotential(k) = 0.5*( ph(i,k  ,j)+phb(i,k  ,j)  &
                                +ph(i,k+1,j)+phb(i,k+1,j) )
@@ -88,7 +88,8 @@ subroutine interp_p(a,p,p_loc,a_interp,ks,ke,kms,kme,i,j)
 
       if(kp .gt. ke) then
         write(mess,*) ' interp too high: pressure, p(ke), i, j = ',pressure,p(ke),i,j
-        write(0,*)'p: ',p
+        call wrf_message ( mess )
+        write(mess,*)'p: ',p
         call wrf_error_fatal( mess )
       end if
  
diff --git a/wrfv2_fire/share/module_interp_nmm.F b/wrfv2_fire/share/module_interp_nmm.F
index 2b8f73b8..a077c792 100644
--- a/wrfv2_fire/share/module_interp_nmm.F
+++ b/wrfv2_fire/share/module_interp_nmm.F
@@ -38,49 +38,49 @@
   + W4(i,j)*C(II(i,j)+a,JJ(i,j)+1))
 
 ! Copying from N array to C array:
-#define UPCOPY(C,N,i,j,k,ni,nj) \
-  C(k,i-istart+1)=(            N(ni,nj+2,k)                               \
-    +             N(ni-a  ,nj+1,k)         + N(ni+1-a,nj+1,k)             \
-    + N(ni-1,nj  ,k)         + N(ni,nj  ,k)           + N(ni+1,nj  ,k)    \
-    +             N(ni-a  ,nj-1,k)         + N(ni+1-a,nj-1,k)             \
-    +                          N(ni,nj-2,k)                               \
-  ) / 9
-
-! Average to C points from N points without assignment:
-#define NGRAB(N,ni,nj,nk) \
-                  (            N(ni,nj+2,nk)                               \
-    +             N(ni-a  ,nj+1,nk)         + N(ni+1-a,nj+1,nk)            \
-    + N(ni-1,nj  ,nk)        + N(ni,nj  ,nk)           + N(ni+1,nj  ,nk)   \
-    +             N(ni-a  ,nj-1,nk)         + N(ni+1-a,nj-1,nk)            \
-    +                          N(ni,nj-2,nk)                               \
-  ) / 9
-
-! Average to C points from N points without assignment on an IKJ grid:
-#define NGRABIKJ(N,ni,nk,nj) \
-                  (            N(ni,nk,nj+2)                               \
-    +             N(ni-a  ,nk,nj+1)         + N(ni+1-a,nk,nj+1)            \
-    + N(ni-1,nk,nj  )        + N(ni,nk,nj  )           + N(ni+1,nk,nj  )   \
-    +             N(ni-a  ,nk,nj-1)         + N(ni+1-a,nk,nj-1)            \
-    +                          N(ni,nk,nj-2)                               \
-  ) / 9
-
-! Average to C points from N points without assignment, no vertical levels:
-#define NGRAB2D(N,ni,nj) \
-                  (            N(ni,nj+2)                            \
-    +             N(ni-a  ,nj+1)         + N(ni+1-a,nj+1)            \
-    + N(ni-1,nj  )           + N(ni,nj  )           + N(ni+1,nj  )   \
-    +             N(ni-a  ,nj-1)         + N(ni+1-a,nj-1)            \
-    +                          N(ni,nj-2)                            \
-  ) / 9
-
-! Copying from N array to I array:
-#define N2ICOPY(C,N,i,j,k,ni,nj) \
-  C(i,j,k)=(                   N(ni,nj+2,k)                               \
-    +             N(ni-a  ,nj+1,k)         + N(ni+1-a,nj+1,k)             \
-    + N(ni-1,nj  ,k)         + N(ni,nj  ,k)           + N(ni+1,nj  ,k)    \
-    +             N(ni-a  ,nj-1,k)         + N(ni+1-a,nj-1,k)             \
-    +                          N(ni,nj-2,k)                               \
-  ) / 9
+#define UPCOPY(C,N,i,j,k,ni,nj)\
+  C(k,i-istart+1)=(N(ni,nj+2,k)\
+  +N(ni-a,nj+1,k)+N(ni+1-a,nj+1,k)\
+  +N(ni-1,nj,k)+N(ni,nj,k)+N(ni+1,nj,k)\
+  +N(ni-a,nj-1,k)+N(ni+1-a,nj-1,k)\
+  +N(ni,nj-2,k)\
+  )/9
+
+!AveragetoCpointsfromNpointswithoutassignment:
+#define NGRAB(N,ni,nj,nk)\
+  (N(ni,nj+2,nk)\
+  +N(ni-a,nj+1,nk)+N(ni+1-a,nj+1,nk)\
+  +N(ni-1,nj,nk)+N(ni,nj,nk)+N(ni+1,nj,nk)\
+  +N(ni-a,nj-1,nk)+N(ni+1-a,nj-1,nk)\
+  +N(ni,nj-2,nk)\
+  )/9
+
+!AveragetoCpointsfromNpointswithoutassignmentonanIKJgrid:
+#define NGRABIKJ(N,ni,nk,nj)\
+  (N(ni,nk,nj+2)\
+  +N(ni-a,nk,nj+1)+N(ni+1-a,nk,nj+1)\
+  +N(ni-1,nk,nj)+N(ni,nk,nj)+N(ni+1,nk,nj)\
+  +N(ni-a,nk,nj-1)+N(ni+1-a,nk,nj-1)\
+  +N(ni,nk,nj-2)\
+  )/9
+
+!AveragetoCpointsfromNpointswithoutassignment,noverticallevels:
+#define NGRAB2D(N,ni,nj)\
+  (N(ni,nj+2)\
+  +N(ni-a,nj+1)+N(ni+1-a,nj+1)\
+  +N(ni-1,nj)+N(ni,nj)+N(ni+1,nj)\
+  +N(ni-a,nj-1)+N(ni+1-a,nj-1)\
+  +N(ni,nj-2)\
+  )/9
+
+!CopyingfromNarraytoIarray:
+#define N2ICOPY(C,N,i,j,k,ni,nj)\
+  C(i,j,k)=(N(ni,nj+2,k)\
+  +N(ni-a,nj+1,k)+N(ni+1-a,nj+1,k)\
+  +N(ni-1,nj,k)+N(ni,nj,k)+N(ni+1,nj,k)\
+  +N(ni-a,nj-1,k)+N(ni+1-a,nj-1,k)\
+  +N(ni,nj-2,k)\
+  )/9
 
 module module_interp_nmm
   use module_model_constants, only: g, R_D, p608
@@ -97,7 +97,7 @@ module module_interp_nmm
   public :: c2n_massikj, n2c_massikj
   public :: c2b_copy3d, c2n_copy3d, n2c_copy3d
 
-  public :: c2b_copy2d, c2n_copy2d, n2c_copy2d
+  public :: c2b_copy2d, c2n_copy2d, n2c_copy2d, c2n_copy2d_nomask
   public :: c2b_near2d, c2n_near2d, n2c_near2d
   public :: c2b_inear2d, c2n_inear2d, n2c_inear2d
 
@@ -655,6 +655,41 @@ subroutine c2n_copy2d (II,JJ,W1,W2,W3,W4,    &
     end do bigj
   end subroutine c2n_copy2d
 
+    subroutine c2n_copy2d_nomask (II,JJ,W1,W2,W3,W4,    &
+       cfield,nfield,     &
+       cims, cime, cjms, cjme,   &
+       nids, nide, njds, njde,   &
+       nims, nime, njms, njme,   &
+       nits, nite, njts, njte, hgrid)
+    implicit none
+    logical, intent(in) :: hgrid
+    real, intent(in), dimension(nims:nime,njms:njme) :: &
+         W1,W2,W3,W4
+    integer, intent(in), dimension(nims:nime,njms:njme) :: II,JJ
+
+    integer, intent(in):: cims, cime, cjms, cjme,   &
+         nids, nide, njds, njde,   &
+         nims, nime, njms, njme,   &
+         nits, nite, njts, njte
+    real, intent(in) :: cfield(cims:cime,cjms:cjme)
+    real, intent(out) :: nfield(nims:nime,njms:njme)
+
+    integer :: j,i,a,nx
+
+    nx=min(nide-1,nite)-max(nids,nits)+1
+
+    bigj: do j=max(njds,njts),min(njde-1,njte)
+       interploop: do i=max(nids,nits),min(nide-1,nite)
+          if(hgrid) then
+             a=1-mod(JJ(i,j),2)
+          else
+             a=mod(JJ(i,j),2)
+          endif
+          nfield(i,j)=ICOPY2D(cfield,i,j)
+       enddo interploop
+    end do bigj
+  end subroutine c2n_copy2d_nomask
+
 
   ! ********************************************************************
   ! subs *_COPY3D -- horizontally interpolate but do not vertically
@@ -1703,11 +1738,11 @@ subroutine c2n_fulldom  (II,JJ,W1,W2,W3,W4,&
           a=1-mod(JJ(i,j),2)
           nPD(i,j,1)=inPD(1,used)
           pdcheck=npd(i,j,1)+ptop+pdtop
-          if(pdcheck<50000.0 .or. pdcheck>105000.0) then
- 3131         format('Invalid output nest PD in C2N interpolation: PD(',I0,',',I0,') = ',F0.7,' which is ',F0.7,' Pa')
-              write(0,3131) i,j,nPD(i,j,1),pdcheck
-              call wrf_error_fatal('Invalid output nest PD')
-          endif
+ !          if(pdcheck<50000.0 .or. pdcheck>105000.0) then
+ ! 3131         format('Invalid output nest PD in C2N interpolation: PD(',I0,',',I0,') = ',F0.7,' which is ',F0.7,' Pa')
+ !              write(0,3131) i,j,nPD(i,j,1),pdcheck
+ !              call wrf_error_fatal('Invalid output nest PD')
+ !          endif
        enddo iloop2
     enddo bigj
 
diff --git a/wrfv2_fire/share/module_llxy.F b/wrfv2_fire/share/module_llxy.F
index e9abb74c..df71e4a5 100644
--- a/wrfv2_fire/share/module_llxy.F
+++ b/wrfv2_fire/share/module_llxy.F
@@ -227,6 +227,7 @@ SUBROUTINE map_init(proj)
       IMPLICIT NONE
       TYPE(proj_info), INTENT(INOUT)  :: proj
   
+      proj%code     = -999
       proj%lat1     = -999.9
       proj%lon1     = -999.9
       proj%lat0     = -999.9
diff --git a/wrfv2_fire/share/module_optional_input.F b/wrfv2_fire/share/module_optional_input.F
index fa03be5f..8f94b89c 100644
--- a/wrfv2_fire/share/module_optional_input.F
+++ b/wrfv2_fire/share/module_optional_input.F
@@ -4,7 +4,7 @@ MODULE module_optional_input
               flag_snow     , flag_snowh    , flag_tsk      , flag_pinterp
 
    INTEGER :: flag_qv       , flag_qc       , flag_qr       , flag_qi       , flag_qs       , &
-              flag_qg       , flag_qh       , flag_qni      , flag_qnr      , flag_sh
+              flag_qg       , flag_qh       , flag_qni      , flag_qnr      , flag_qnwfa    , flag_qnifa    , flag_sh
 
    INTEGER :: flag_soil_levels, flag_soil_layers
 
@@ -25,6 +25,8 @@ MODULE module_optional_input
 
    INTEGER :: flag_ptheta
 
+   INTEGER :: flag_lake_depth
+
    INTEGER :: flag_excluded_middle
 
    INTEGER                  :: num_soil_levels_input
@@ -195,6 +197,10 @@ SUBROUTINE optional_input ( grid , fid, config_flags )
                                  ids, ide, jds, jde, kds, kde, &
                                  ims, ime, jms, jme, kms, kme, &
                                  its, ite, jts, jte, kts, kte  )
+      CALL optional_lake       ( grid , fid , &
+                                 ids, ide, jds, jde, kds, kde, &
+                                 ims, ime, jms, jme, kms, kme, &
+                                 its, ite, jts, jte, kts, kte  )
 
       CALL optional_ptheta     ( grid , fid , &
                                  ids, ide, jds, jde, kds, kde, &
@@ -294,6 +300,8 @@ SUBROUTINE optional_moist ( grid , fid , &
       flag_qh       = 0
       flag_qni      = 0
       flag_qnr      = 0
+      flag_qnwfa    = 0
+      flag_qnifa    = 0
       flag_sh       = 0
 
       flag_name(1:8) = 'QV      '
@@ -341,6 +349,16 @@ SUBROUTINE optional_moist ( grid , fid , &
       IF ( ierr .EQ. 0 ) THEN
          flag_qnr       = itmp
       END IF
+      flag_name(1:8) = 'QNWFA    '
+      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
+      IF ( ierr .EQ. 0 ) THEN
+         flag_qnwfa     = itmp
+      END IF
+      flag_name(1:8) = 'QNIFA    '
+      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr )
+      IF ( ierr .EQ. 0 ) THEN
+         flag_qnifa     = itmp
+      END IF
       flag_name(1:8) = 'SH      '
       CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) 
       IF ( ierr .EQ. 0 ) THEN
@@ -437,6 +455,41 @@ SUBROUTINE optional_sst ( grid , fid , &
     
    END SUBROUTINE optional_sst
 
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+   SUBROUTINE optional_lake ( grid , fid , &
+                             ids, ide, jds, jde, kds, kde, &
+                             ims, ime, jms, jme, kms, kme, &
+                             its, ite, jts, jte, kts, kte  )
+
+      USE module_io_wrf
+      USE module_domain	, ONLY : domain
+USE module_configure , ONLY : grid_config_rec_type
+USE module_io_domain
+
+      IMPLICIT NONE 
+
+      TYPE ( domain ) :: grid
+      INTEGER , INTENT(IN) :: fid
+
+      INTEGER :: ids, ide, jds, jde, kds, kde, &
+                 ims, ime, jms, jme, kms, kme, &
+                 its, ite, jts, jte, kts, kte
+
+      INTEGER :: itmp , icnt , ierr
+
+      flag_name = '                                                                                '
+
+      flag_lake_depth      = 0 
+
+      flag_name(1:10) = 'LAKE_DEPTH'
+      CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) 
+      IF ( ierr .EQ. 0 ) THEN
+         flag_lake_depth      = itmp
+      END IF
+    
+   END SUBROUTINE optional_lake
+
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
    SUBROUTINE optional_tsk     ( grid , fid , &
diff --git a/wrfv2_fire/share/module_soil_pre.F b/wrfv2_fire/share/module_soil_pre.F
index e66cf23c..f8487c56 100644
--- a/wrfv2_fire/share/module_soil_pre.F
+++ b/wrfv2_fire/share/module_soil_pre.F
@@ -218,6 +218,7 @@ SUBROUTINE adjust_for_seaice_post ( xice , landmask , tsk_old , tsk , ivgtyp , v
       ELSEIF ( FRACTIONAL_SEAICE == 1 ) THEN
          xice_threshold = 0.02
       ENDIF
+
       num_seaice_changes = 0
       fix_seaice : SELECT CASE ( scheme )
 
@@ -355,10 +356,10 @@ SUBROUTINE adjust_for_seaice_post ( xice , landmask , tsk_old , tsk , ivgtyp , v
 
 !tgs - compute blended sea ice/water skin temperature
                    if(flag_sst.eq.1) then
-                     tsk(i,j) = xice(i,j)*(min(seaice_threshold,tsk(i,j)))  &
+                     tsk(i,j) = xice(i,j)*(min(271.4,tsk(i,j)))  &
                                 +(1-xice(i,j))*sst(i,j)
                    else
-                     tsk(i,j) = xice(i,j)*(min(seaice_threshold,tsk(i,j)))  &
+                     tsk(i,j) = xice(i,j)*(min(271.4,tsk(i,j)))  &
                                 +(1-xice(i,j))*tsk(i,j)
                    endif
                      tsk_old(i,j) = tsk(i,j)
@@ -1166,12 +1167,10 @@ SUBROUTINE init_soil_depth_3 ( zs , dzs , num_soil_layers )
 
      IF ( num_soil_layers .EQ. 6) THEN
       zs  = (/ 0.00 , 0.05 , 0.20 , 0.40 , 1.60 , 3.00 /)
-!      dzs = (/ 0.00 , 0.125, 0.175 , 0.70 , 1.30 , 1.40 /)
      ELSEIF ( num_soil_layers .EQ. 9) THEN
       zs  = (/ 0.00 , 0.01 , 0.04 , 0.10 , 0.30, 0.60, 1.00 , 1.60, 3.00 /)
 !test3 in ppt      zs  = (/ 0.00 , 0.005 , 0.02 , 0.10 , 0.30, 0.60, 1.00 , 1.60, 3.00 /)
 !      zs  = (/ 0.00 , 0.05 , 0.20 , 0.40 , 0.60, 1.00, 1.60 , 2.20, 3.00 /)
-!      dzs = (/ 0.00 , 0.125, 0.175 , 0.70 , 1.30 , 1.40 /)
      ENDIF
 
       IF ( num_soil_layers .EQ. 4 .OR. num_soil_layers .EQ. 5 ) THEN
diff --git a/wrfv2_fire/share/output_wrf.F b/wrfv2_fire/share/output_wrf.F
index 762183c7..8d3995c2 100644
--- a/wrfv2_fire/share/output_wrf.F
+++ b/wrfv2_fire/share/output_wrf.F
@@ -38,8 +38,11 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
     REAL    gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 , moad_cen_lat , stand_lon
     INTEGER km_opt, diff_opt, damp_opt,  &
             mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, &
-            sf_surface_physics, bl_pbl_physics, cu_physics, hypsometric_opt
-    REAL    khdif, kvdif, swrad_scat, dampcoef
+            sf_surface_physics, bl_pbl_physics, cu_physics, hypsometric_opt, sf_lake_physics
+    INTEGER swint_opt, aer_type,aer_aod550_opt,aer_angexp_opt,aer_ssa_opt,aer_asy_opt, aer_opt
+    REAL    aer_aod550_val,aer_angexp_val,aer_ssa_val,aer_asy_val
+    REAL    khdif, kvdif, swrad_scat, dampcoef,radt,bldt,cudt
+    REAL    dt, adapt_dt_start, adapt_dt_min, adapt_dt_max
     INTEGER sf_urban_physics, w_damping, smooth_option, feedback, surface_input_source, sst_update
     INTEGER stoch_force_opt, stoch_vertstruc_opt, nens
     REAL    tot_backscat_psi, tot_backscat_t
@@ -55,6 +58,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
     REAL    guv_sfc, gt_sfc, gq_sfc, rinblw
     INTEGER moist_adv_opt, scalar_adv_opt, tke_adv_opt
     INTEGER save_topo_orig
+    INTEGER scalar_pblmix, tracer_pblmix, grav_settling
 #endif
     CHARACTER (len=19) simulation_start_date
     CHARACTER (len=len_current_date) current_date_save
@@ -116,8 +120,8 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
                               ims, ime, jms, jme, kms, kme,    &
                               ips, ipe, jps, jpe, kps, kpe    )
 
-    call nl_get_diff_opt           ( 1, diff_opt                  )
-    call nl_get_km_opt             ( 1, km_opt                    )
+    call nl_get_diff_opt           ( grid%id , diff_opt           )
+    call nl_get_km_opt             ( grid%id,  km_opt             )
     call nl_get_damp_opt           ( 1, damp_opt                  )
     call nl_get_dampcoef           ( grid%id,  dampcoef           )
     call nl_get_khdif              ( grid%id,  khdif              )
@@ -129,6 +133,28 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
     call nl_get_sf_surface_physics ( grid%id,  sf_surface_physics )
     call nl_get_bl_pbl_physics     ( grid%id,  bl_pbl_physics     )
     call nl_get_cu_physics         ( grid%id,  cu_physics         )
+    call nl_get_radt               ( grid%id,  radt               )
+    call nl_get_bldt               ( grid%id,  bldt               )
+    call nl_get_cudt               ( grid%id,  cudt               )
+    call nl_get_aer_opt            ( grid%id,  aer_opt            )
+    call nl_get_swint_opt          ( grid%id,  swint_opt          )
+    call nl_get_aer_type           ( grid%id,  aer_type           )
+    call nl_get_aer_aod550_opt     ( grid%id,  aer_aod550_opt     )
+    call nl_get_aer_angexp_opt     ( grid%id,  aer_angexp_opt     )
+    call nl_get_aer_ssa_opt        ( grid%id,  aer_ssa_opt        )
+    call nl_get_aer_asy_opt        ( grid%id,  aer_asy_opt        )
+    call nl_get_aer_aod550_val     ( grid%id,  aer_aod550_val     )
+    call nl_get_aer_angexp_val     ( grid%id,  aer_angexp_val     )
+    call nl_get_aer_ssa_opt        ( grid%id,  aer_ssa_val        )
+    call nl_get_aer_asy_opt        ( grid%id,  aer_asy_val        )
+    call nl_get_sf_lake_physics    ( grid%id,  sf_lake_physics    )
+
+#if (EM_CORE == 1)
+    dt = grid%dt
+    adapt_dt_min = grid%min_time_step
+    adapt_dt_max = grid%max_time_step
+    adapt_dt_start = grid%starting_time_step
+#endif
 
 ! add nml variables in 2.2
     call nl_get_surface_input_source ( 1      ,  surface_input_source )
@@ -152,6 +178,9 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
     CALL nl_get_grid_sfdda  ( grid%id , grid_sfdda )
     CALL nl_get_auxinput9_end_h( grid%id , sgfdda_end_h )
     CALL nl_get_auxinput9_interval_m ( grid%id , sgfdda_interval_m )
+    CALL nl_get_scalar_pblmix  ( grid%id , scalar_pblmix )
+    CALL nl_get_tracer_pblmix  ( grid%id , tracer_pblmix )
+    CALL nl_get_grav_settling  ( grid%id , grav_settling )
 
     IF ( grid_fdda == 1 ) THEN
     CALL nl_get_fgdt       ( grid%id , fgdt )
@@ -377,6 +406,11 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
     END IF
 #endif
 
+#if (NMM_CORE == 1)
+    CALL wrf_put_dom_ti_real ( fid , 'WBD0' , grid%wbd0 , 1 , ierr )
+    CALL wrf_put_dom_ti_real ( fid , 'SBD0' , grid%sbd0 , 1 , ierr )
+#endif
+
 #if (EM_CORE == 1)
 !added the following for tc bogusing
     if( ((config_flags%insert_bogus_storm) .or. (config_flags%remove_storm)) .and. &
@@ -497,6 +531,8 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
     CALL wrf_put_dom_ti_integer ( fid , 'BL_PBL_PHYSICS' ,  ibuf , 1 , ierr )
     ibuf(1) = cu_physics
     CALL wrf_put_dom_ti_integer ( fid , 'CU_PHYSICS' ,  ibuf , 1 , ierr )
+    ibuf(1) = sf_lake_physics
+    CALL wrf_put_dom_ti_integer ( fid , 'SF_LAKE_PHYSICS' ,  ibuf , 1 , ierr )
 
     ! added netcdf-specific metadata:
     IF ( ( use_package( io_form ) == IO_NETCDF ) .OR. &
@@ -523,6 +559,30 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
       CALL wrf_put_dom_ti_real    ( fid, 'SWRAD_SCAT', swrad_scat , 1 , ierr )
       CALL wrf_put_dom_ti_integer ( fid, 'W_DAMPING', w_damping , 1 , ierr )
 
+#if (EM_CORE == 1)
+      CALL wrf_put_dom_ti_real    ( fid, 'DT'  , dt, 1 , ierr)
+      IF ( grid%use_adaptive_time_step ) THEN
+         CALL wrf_put_dom_ti_real    ( fid, 'ADAPT_DT_START' , adapt_dt_start, 1 , ierr)
+         CALL wrf_put_dom_ti_real    ( fid, 'ADAPT_DT_MAX'   , adapt_dt_max  , 1 , ierr)
+         CALL wrf_put_dom_ti_real    ( fid, 'ADAPT_DT_MIN'   , adapt_dt_min  , 1 , ierr)
+      END IF
+#endif
+
+      call wrf_put_dom_ti_real    ( fid, 'RADT', radt, 1 , ierr)
+      call wrf_put_dom_ti_real    ( fid, 'BLDT', bldt, 1 , ierr)
+      call wrf_put_dom_ti_real    ( fid, 'CUDT', cudt, 1 , ierr)
+      call wrf_put_dom_ti_integer ( fid, 'AER_OPT'        , aer_opt        , 1 , ierr)
+      call wrf_put_dom_ti_integer ( fid, 'SWINT_OPT'      , swint_opt      , 1 , ierr)
+      call wrf_put_dom_ti_integer ( fid, 'AER_TYPE'       , aer_type       , 1 , ierr )
+      call wrf_put_dom_ti_integer ( fid, 'AER_AOD550_OPT' , aer_aod550_opt , 1 , ierr )
+      call wrf_put_dom_ti_integer ( fid, 'AER_ANGEXP_OPT' , aer_angexp_opt , 1 , ierr )
+      call wrf_put_dom_ti_integer ( fid, 'AER_SSA_OPT'    , aer_ssa_opt    , 1 , ierr )
+      call wrf_put_dom_ti_integer ( fid, 'AER_ASY_OPT'    , aer_asy_opt    , 1 , ierr )
+      call wrf_put_dom_ti_real    ( fid, 'AER_AOD550_VAL' , aer_aod550_val , 1 , ierr )
+      call wrf_put_dom_ti_real    ( fid, 'AER_ANGEXP_VAL' , aer_angexp_val , 1 , ierr )
+      call wrf_put_dom_ti_real    ( fid, 'AER_SSA_VAL'    , aer_ssa_val    , 1 , ierr )
+      call wrf_put_dom_ti_real    ( fid, 'AER_ASY_VAL'    , aer_asy_val    , 1 , ierr )
+
 #if (EM_CORE == 1)
       CALL wrf_put_dom_ti_integer ( fid, 'MOIST_ADV_OPT', moist_adv_opt , 1 , ierr )
       CALL wrf_put_dom_ti_integer ( fid, 'SCALAR_ADV_OPT', scalar_adv_opt , 1 , ierr )
@@ -580,8 +640,15 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
       CALL wrf_put_dom_ti_integer   ( fid, 'SF_OCEAN_PHYSICS',     config_flags%sf_ocean_physics     , 1 , ierr ) 
       CALL wrf_put_dom_ti_integer   ( fid, 'ISFTCFLX',    config_flags%isftcflx    , 1 , ierr ) 
       CALL wrf_put_dom_ti_integer   ( fid, 'ISHALLOW',    config_flags%ishallow    , 1 , ierr ) 
+      CALL wrf_put_dom_ti_integer   ( fid, 'ISFFLX',      config_flags%isfflx      , 1 , ierr ) 
+      CALL wrf_put_dom_ti_integer   ( fid, 'ICLOUD',      config_flags%icloud      , 1 , ierr ) 
+      CALL wrf_put_dom_ti_integer   ( fid, 'ICLOUD_CU',   config_flags%icloud_cu   , 1 , ierr ) 
+      CALL wrf_put_dom_ti_integer   ( fid, 'TRACER_PBLMIX', tracer_pblmix , 1 , ierr )
+      CALL wrf_put_dom_ti_integer   ( fid, 'SCALAR_PBLMIX', scalar_pblmix , 1 , ierr )
+      CALL wrf_put_dom_ti_integer   ( fid, 'GRAV_SETTLING', grav_settling , 1 , ierr )
 
 #endif
+
       IF ( sf_surface_physics == 4 ) THEN
         CALL wrf_put_dom_ti_integer   ( fid, 'OPT_SFC',     config_flags%opt_sfc     , 1 , ierr )
         CALL wrf_put_dom_ti_integer   ( fid, 'DVEG',        config_flags%dveg        , 1 , ierr )
@@ -737,7 +804,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
 #if defined (HWRF)
     CALL wrf_put_dom_ti_integer ( fid , 'I_PARENT_START' ,  grid%i_parent_start  , 1 , ierr )
     CALL wrf_put_dom_ti_integer ( fid , 'J_PARENT_START' ,  grid%j_parent_start  , 1 , ierr )
-#elseif ! defined(EM_CORE)
+#elif ! defined(EM_CORE)
     CALL wrf_put_dom_ti_integer ( fid , 'I_PARENT_START' ,  config_flags%i_parent_start  , 1 , ierr )
     CALL wrf_put_dom_ti_integer ( fid , 'J_PARENT_START' ,  config_flags%j_parent_start  , 1 , ierr )
 #endif
diff --git a/wrfv2_fire/share/wrf_fddaobs_in.F b/wrfv2_fire/share/wrf_fddaobs_in.F
index e2ab7e32..4e8e0192 100644
--- a/wrfv2_fire/share/wrf_fddaobs_in.F
+++ b/wrfv2_fire/share/wrf_fddaobs_in.F
@@ -69,8 +69,8 @@ SUBROUTINE wrf_fddaobs_in (grid ,config_flags)
     infreq = grid%obs_ionf*(grid%parent_grid_ratio**nstlev)
     iprt_in4dob = grid%obs_ipf_in4dob
 
-    IF( (ktau.GT.krest.AND.MOD(ktau,infreq).EQ.0)                            &
-                                         .OR.(ktau.EQ.krest) .AND. grid%xtime <= grid%fdda_end ) then
+    IF( ((ktau.GT.krest.AND.MOD(ktau,infreq).EQ.0)                            &
+                                         .OR.(ktau.EQ.krest)) .AND. grid%xtime <= grid%fdda_end ) then
 ! Calculate forecast time.
       dtmin = grid%dt/60.
       xtime = grid%xtime
diff --git a/wrfv2_fire/test/em_b_wave/namelist.input b/wrfv2_fire/test/em_b_wave/namelist.input
index 605f46ca..7bd35440 100644
--- a/wrfv2_fire/test/em_b_wave/namelist.input
+++ b/wrfv2_fire/test/em_b_wave/namelist.input
@@ -69,8 +69,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 1,
- km_opt                              = 1,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 1,      1,      1,
  damp_opt                            = 0,
  zdamp                               = 4000.,  4000.,  4000.,
  dampcoef                            = 0.01,   0.01,   0.01
diff --git a/wrfv2_fire/test/em_b_wave/namelist.input.backwards b/wrfv2_fire/test/em_b_wave/namelist.input.backwards
index d610c97c..6ccca91c 100644
--- a/wrfv2_fire/test/em_b_wave/namelist.input.backwards
+++ b/wrfv2_fire/test/em_b_wave/namelist.input.backwards
@@ -69,8 +69,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 1,
- km_opt                              = 1,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 1,      1,      1,
  damp_opt                            = 0,
  zdamp                               = 4000.,  4000.,  4000.,
  dampcoef                            = 0.01,   0.01,   0.01
diff --git a/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.ESMFSST b/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.ESMFSST
index e0929c64..df4abd43 100644
--- a/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.ESMFSST
+++ b/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.ESMFSST
@@ -89,8 +89,8 @@
 
  &dynamics
  w_damping                           = 0,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.NETCDFSST b/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.NETCDFSST
index 18818698..b8135797 100644
--- a/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.NETCDFSST
+++ b/wrfv2_fire/test/em_esmf_exp/namelist.input.jan00.NETCDFSST
@@ -89,8 +89,8 @@
 
  &dynamics
  w_damping                           = 0,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_fire/hill_simple/namelist.input b/wrfv2_fire/test/em_fire/hill_simple/namelist.input
index fe4661db..00c0d749 100644
--- a/wrfv2_fire/test/em_fire/hill_simple/namelist.input
+++ b/wrfv2_fire/test/em_fire/hill_simple/namelist.input
@@ -74,8 +74,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 2,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
  damp_opt                            = 0,
  zdamp                               = 800.,  5000.,  5000.,
  dampcoef                            = 0.2,    0.2,    0.2
diff --git a/wrfv2_fire/test/em_fire/two_fires/namelist.input b/wrfv2_fire/test/em_fire/two_fires/namelist.input
index 65f2e412..94e6c6e3 100644
--- a/wrfv2_fire/test/em_fire/two_fires/namelist.input
+++ b/wrfv2_fire/test/em_fire/two_fires/namelist.input
@@ -75,8 +75,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 2,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
  damp_opt                            = 2 ,
  zdamp                               = 800.,  5000.,  5000.,
  dampcoef                            = 0.2,    0.2,    0.2
diff --git a/wrfv2_fire/test/em_grav2d_x/namelist.input b/wrfv2_fire/test/em_grav2d_x/namelist.input
index fd6fcbe7..c31a80e9 100644
--- a/wrfv2_fire/test/em_grav2d_x/namelist.input
+++ b/wrfv2_fire/test/em_grav2d_x/namelist.input
@@ -61,8 +61,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 1,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 1,      1,      1,
  damp_opt                            = 0,
  zdamp                               = 15000.,
  dampcoef                            = 0.025,
diff --git a/wrfv2_fire/test/em_grav2d_x/namelist.input.100m b/wrfv2_fire/test/em_grav2d_x/namelist.input.100m
index fd6fcbe7..c31a80e9 100644
--- a/wrfv2_fire/test/em_grav2d_x/namelist.input.100m
+++ b/wrfv2_fire/test/em_grav2d_x/namelist.input.100m
@@ -61,8 +61,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 1,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 1,      1,      1,
  damp_opt                            = 0,
  zdamp                               = 15000.,
  dampcoef                            = 0.025,
diff --git a/wrfv2_fire/test/em_grav2d_x/namelist.input.200m b/wrfv2_fire/test/em_grav2d_x/namelist.input.200m
index 820db7bf..d9db4924 100644
--- a/wrfv2_fire/test/em_grav2d_x/namelist.input.200m
+++ b/wrfv2_fire/test/em_grav2d_x/namelist.input.200m
@@ -61,8 +61,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 1,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 1,      1,      1,
  damp_opt                            = 0,
  zdamp                               = 15000.,
  dampcoef                            = 0.025,
diff --git a/wrfv2_fire/test/em_grav2d_x/namelist.input.400m b/wrfv2_fire/test/em_grav2d_x/namelist.input.400m
index e026708e..b02a6a3c 100644
--- a/wrfv2_fire/test/em_grav2d_x/namelist.input.400m
+++ b/wrfv2_fire/test/em_grav2d_x/namelist.input.400m
@@ -61,8 +61,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 1,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 1,      1,      1,
  damp_opt                            = 0,
  zdamp                               = 15000.,
  dampcoef                            = 0.025,
diff --git a/wrfv2_fire/test/em_heldsuarez/namelist.input b/wrfv2_fire/test/em_heldsuarez/namelist.input
index 7b565a23..9278aece 100644
--- a/wrfv2_fire/test/em_heldsuarez/namelist.input
+++ b/wrfv2_fire/test/em_heldsuarez/namelist.input
@@ -69,8 +69,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 1,
- km_opt                              = 1,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 1,      1,      1,
  damp_opt                            = 0,
  zdamp                               = 4000.,  4000.,  4000.,
  dampcoef                            = 0.2,    0.2,    0.2
diff --git a/wrfv2_fire/test/em_hill2d_x/namelist.input b/wrfv2_fire/test/em_hill2d_x/namelist.input
index 844dadc9..7c1a1b24 100644
--- a/wrfv2_fire/test/em_hill2d_x/namelist.input
+++ b/wrfv2_fire/test/em_hill2d_x/namelist.input
@@ -61,8 +61,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 1,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 1,      1,      1,
  damp_opt                            = 3,
  zdamp                               = 20000.,
  dampcoef                            = .1,
diff --git a/wrfv2_fire/test/em_les/namelist.input b/wrfv2_fire/test/em_les/namelist.input
index e7e6bdb0..1256a068 100644
--- a/wrfv2_fire/test/em_les/namelist.input
+++ b/wrfv2_fire/test/em_les/namelist.input
@@ -71,8 +71,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 2,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
  damp_opt                            = 0,
  zdamp                               = 15000.,  5000.,  5000.,
  dampcoef                            = 0.1,    0.2,    0.2
diff --git a/wrfv2_fire/test/em_quarter_ss/input_sounding b/wrfv2_fire/test/em_quarter_ss/input_sounding
index 0f91581b..8832d595 100644
--- a/wrfv2_fire/test/em_quarter_ss/input_sounding
+++ b/wrfv2_fire/test/em_quarter_ss/input_sounding
@@ -1,48 +1,223 @@
- 1000.00      300.00      14.00
-   250.00     300.45      14.00      -7.88      -3.58
-   750.00     301.25      14.00      -6.94      -0.89
-  1250.00     302.47      13.50      -5.17       1.33
-  1750.00     303.93      11.10      -2.76       2.84
-  2250.00     305.31       9.06       0.01       3.47
-  2750.00     306.81       7.36       2.87       3.49
-  3250.00     308.46       5.95       5.73       3.49
-  3750.00     310.03       4.78       8.58       3.49
-  4250.00     311.74       3.82      11.44       3.49
-  4750.00     313.48       3.01      14.30       3.49
-  5250.00     315.24       2.36      17.15       3.49
-  5750.00     317.18       1.80      20.01       3.49
-  6250.00     319.02       1.41      22.87       3.49
-  6750.00     320.88       1.07      25.73       3.49
-  7250.00     322.80       0.80      27.15       3.49
-  7750.00     324.87       0.60      27.15       3.49
-  8250.00     326.86       0.43      27.15       3.49
-  8750.00     328.89       0.32      27.15       3.49
-  9250.00     330.39       0.24      27.15       3.49
-  9750.00     332.80       0.17      27.15       3.49
- 10250.00     335.23       0.10      27.15       3.49
- 10750.00     337.31       0.08      27.15       3.49
- 11250.00     339.55       0.05      27.15       3.49
- 11750.00     342.82       0.03      27.15       3.49
- 12250.00     349.88       0.04      27.15       3.49
- 12750.00     357.34       0.04      27.15       3.49
- 13250.00     364.91       0.04      27.15       3.49
- 13750.00     373.22       0.04      27.15       3.49
- 14250.00     381.67       0.04      27.15       3.49
- 14750.00     390.29       0.04      27.15       3.49
- 15250.00     398.91       0.04      27.15       3.49
- 15750.00     407.53       0.04      27.15       3.49
- 16250.00     416.15       0.04      27.15       3.49
- 16750.00     424.77       0.04      27.15       3.49
- 17250.00     433.39       0.04      27.15       3.49
- 17750.00     442.01       0.04      27.15       3.49
- 18250.00     450.63       0.04      27.15       3.49
- 18750.00     459.25       0.04      27.15       3.49
- 19250.00     467.87       0.04      27.15       3.49
- 19750.00     476.49       0.04      27.15       3.49
- 20250.00     485.11       0.04      27.15       3.49
- 20750.00     493.73       0.04      27.15       3.49
- 21250.00     502.35       0.04      27.15       3.49
- 21750.00     510.97       0.04      27.15       3.49
- 22250.00     519.59       0.04      27.15       3.49
- 22750.00     528.21       0.04      27.15       3.49
-
+    1000.0000     300.0000   14.000000
+      10.0000     300.0061   14.000000      -8.0998      -4.9419
+      35.0000     300.0291   14.000000      -8.0976      -4.7968
+     100.0000     300.1083   14.000000      -8.0802      -4.4199
+     200.0000     300.2575   14.000000      -8.0208      -3.8426
+     300.0000     300.4275   14.000000      -7.9222      -3.2706
+     400.0000     300.6125   14.000000      -7.7848      -2.7067
+     500.0000     300.8095   14.000000      -7.6092      -2.1535
+     600.0000     301.0167   14.000000      -7.3963      -1.6136
+     700.0000     301.2327   14.000000      -7.1470      -1.0894
+     800.0000     301.4566   14.000000      -6.8626      -0.5835
+     900.0000     301.6877   14.000000      -6.5442      -0.0982
+    1000.0000     301.9253   14.000000      -6.1935       0.3642
+    1100.0000     302.1689   14.000000      -5.8121       0.8017
+    1200.0000     302.4181   14.000000      -5.4017       1.2121
+    1300.0000     302.6725   13.538230      -4.9642       1.5935
+    1400.0000     302.9319   13.012494      -4.5018       1.9442
+    1500.0000     303.1960   12.506029      -4.0165       2.2626
+    1600.0000     303.4645   12.018045      -3.5106       2.5470
+    1700.0000     303.7372   11.547747      -2.9864       2.7963
+    1800.0000     304.0140   11.094458      -2.4465       3.0092
+    1900.0000     304.2947   10.657535      -1.8933       3.1848
+    2000.0000     304.5791   10.236333      -1.3294       3.3222
+    2100.0000     304.8671    9.830262      -0.7574       3.4208
+    2200.0000     305.1584    9.438754      -0.1801       3.4802
+    2300.0000     305.4532    9.061300       0.4000       3.5000
+    2400.0000     305.7512    8.697392       0.9691       3.5000
+    2500.0000     306.0522    8.346541       1.5383       3.5000
+    2600.0000     306.3564    8.008314       2.1074       3.5000
+    2700.0000     306.6634    7.682274       2.6766       3.5000
+    2800.0000     306.9733    7.367979       3.2457       3.5000
+    2900.0000     307.2860    7.065029       3.8149       3.5000
+    3000.0000     307.6014    6.773075       4.3840       3.5000
+    3100.0000     307.9194    6.491694       4.9532       3.5000
+    3200.0000     308.2401    6.220579       5.5223       3.5000
+    3300.0000     308.5632    5.959360       6.0915       3.5000
+    3400.0000     308.8887    5.707712       6.6606       3.5000
+    3500.0000     309.2167    5.465350       7.2298       3.5000
+    3600.0000     309.5471    5.231919       7.7989       3.5000
+    3700.0000     309.8797    5.007156       8.3681       3.5000
+    3800.0000     310.2146    4.790772       8.9372       3.5000
+    3900.0000     310.5517    4.582475       9.5064       3.5000
+    4000.0000     310.8910    4.382025      10.0755       3.5000
+    4100.0000     311.2324    4.189150      10.6447       3.5000
+    4200.0000     311.5759    4.003582      11.2138       3.5000
+    4300.0000     311.9214    3.825114      11.7830       3.5000
+    4400.0000     312.2690    3.653495      12.3521       3.5000
+    4500.0000     312.6185    3.488501      12.9213       3.5000
+    4600.0000     312.9700    3.329912      13.4904       3.5000
+    4700.0000     313.3234    3.177519      14.0596       3.5000
+    4800.0000     313.6786    3.031107      14.6287       3.5000
+    4900.0000     314.0358    2.890485      15.1979       3.5000
+    5000.0000     314.3947    2.755452      15.7670       3.5000
+    5100.0000     314.7555    2.625825      16.3362       3.5000
+    5200.0000     315.1181    2.501423      16.9053       3.5000
+    5300.0000     315.4823    2.382055      17.4745       3.5000
+    5400.0000     315.8484    2.267572      18.0436       3.5000
+    5500.0000     316.2161    2.157790      18.6128       3.5000
+    5600.0000     316.5854    2.052551      19.1819       3.5000
+    5700.0000     316.9565    1.951697      19.7511       3.5000
+    5800.0000     317.3291    1.855075      20.3202       3.5000
+    5900.0000     317.7034    1.762540      20.8894       3.5000
+    6000.0000     318.0793    1.673951      21.4585       3.5000
+    6100.0000     318.4567    1.589160      22.0277       3.5000
+    6200.0000     318.8357    1.508036      22.5968       3.5000
+    6300.0000     319.2162    1.430447      23.1660       3.5000
+    6400.0000     319.5982    1.356266      23.7351       3.5000
+    6500.0000     319.9818    1.285369      24.3043       3.5000
+    6600.0000     320.3668    1.217633      24.8734       3.5000
+    6700.0000     320.7532    1.152943      25.4426       3.5000
+    6800.0000     321.1411    1.091186      26.0117       3.5000
+    6900.0000     321.5305    1.032253      26.5809       3.5000
+    7000.0000     321.9212    0.976036      27.1500       3.5000
+    7100.0000     322.3134    0.922432      27.1500       3.5000
+    7200.0000     322.7069    0.871341      27.1500       3.5000
+    7300.0000     323.1018    0.822666      27.1500       3.5000
+    7400.0000     323.4980    0.776311      27.1500       3.5000
+    7500.0000     323.8956    0.732186      27.1500       3.5000
+    7600.0000     324.2946    0.690203      27.1500       3.5000
+    7700.0000     324.6948    0.650276      27.1500       3.5000
+    7800.0000     325.0963    0.612320      27.1500       3.5000
+    7900.0000     325.4991    0.576257      27.1500       3.5000
+    8000.0000     325.9033    0.542009      27.1500       3.5000
+    8100.0000     326.3086    0.509499      27.1500       3.5000
+    8200.0000     326.7152    0.478655      27.1500       3.5000
+    8300.0000     327.1231    0.449407      27.1500       3.5000
+    8400.0000     327.5322    0.421687      27.1500       3.5000
+    8500.0000     327.9425    0.395429      27.1500       3.5000
+    8600.0000     328.3540    0.370568      27.1500       3.5000
+    8700.0000     328.7668    0.347044      27.1500       3.5000
+    8800.0000     329.1807    0.324797      27.1500       3.5000
+    8900.0000     329.5958    0.303770      27.1500       3.5000
+    9000.0000     330.0120    0.283907      27.1500       3.5000
+    9100.0000     330.4294    0.265156      27.1500       3.5000
+    9200.0000     330.8480    0.247464      27.1500       3.5000
+    9300.0000     331.2677    0.230782      27.1500       3.5000
+    9400.0000     331.6885    0.215062      27.1500       3.5000
+    9500.0000     332.1104    0.200260      27.1500       3.5000
+    9600.0000     332.5335    0.186329      27.1500       3.5000
+    9700.0000     332.9577    0.173227      27.1500       3.5000
+    9800.0000     333.3829    0.160914      27.1500       3.5000
+    9900.0000     333.8093    0.149350      27.1500       3.5000
+   10000.0000     334.2367    0.138497      27.1500       3.5000
+   10100.0000     334.6652    0.128319      27.1500       3.5000
+   10200.0000     335.0948    0.118781      27.1500       3.5000
+   10300.0000     335.5254    0.109850      27.1500       3.5000
+   10400.0000     335.9570    0.101493      27.1500       3.5000
+   10500.0000     336.3897    0.093680      27.1500       3.5000
+   10600.0000     336.8234    0.086381      27.1500       3.5000
+   10700.0000     337.2582    0.079568      27.1500       3.5000
+   10800.0000     337.6939    0.073214      27.1500       3.5000
+   10900.0000     338.1307    0.067294      27.1500       3.5000
+   11000.0000     338.5685    0.061782      27.1500       3.5000
+   11100.0000     339.0073    0.056656      27.1500       3.5000
+   11200.0000     339.4471    0.051892      27.1500       3.5000
+   11300.0000     339.8878    0.047470      27.1500       3.5000
+   11400.0000     340.3295    0.043368      27.1500       3.5000
+   11500.0000     340.7722    0.039568      27.1500       3.5000
+   11600.0000     341.2159    0.036051      27.1500       3.5000
+   11700.0000     341.6605    0.032799      27.1500       3.5000
+   11800.0000     342.1060    0.029796      27.1500       3.5000
+   11900.0000     342.5526    0.027026      27.1500       3.5000
+   12000.0000     343.0000    0.024473      27.1500       3.5000
+   12100.0000     344.5744    0.024922      27.1500       3.5000
+   12200.0000     346.1560    0.025378      27.1500       3.5000
+   12300.0000     347.7448    0.025843      27.1500       3.5000
+   12400.0000     349.3410    0.026317      27.1500       3.5000
+   12500.0000     350.9445    0.026800      27.1500       3.5000
+   12600.0000     352.5553    0.027292      27.1500       3.5000
+   12700.0000     354.1736    0.027793      27.1500       3.5000
+   12800.0000     355.7993    0.028304      27.1500       3.5000
+   12900.0000     357.4324    0.028825      27.1500       3.5000
+   13000.0000     359.0730    0.029355      27.1500       3.5000
+   13100.0000     360.7212    0.029895      27.1500       3.5000
+   13200.0000     362.3769    0.030446      27.1500       3.5000
+   13300.0000     364.0402    0.031007      27.1500       3.5000
+   13400.0000     365.7112    0.031578      27.1500       3.5000
+   13500.0000     367.3898    0.032161      27.1500       3.5000
+   13600.0000     369.0761    0.032754      27.1500       3.5000
+   13700.0000     370.7702    0.033359      27.1500       3.5000
+   13800.0000     372.4721    0.033976      27.1500       3.5000
+   13900.0000     374.1817    0.034604      27.1500       3.5000
+   14000.0000     375.8992    0.035244      27.1500       3.5000
+   14100.0000     377.6246    0.035896      27.1500       3.5000
+   14200.0000     379.3579    0.036561      27.1500       3.5000
+   14300.0000     381.0992    0.037238      27.1500       3.5000
+   14400.0000     382.8484    0.037928      27.1500       3.5000
+   14500.0000     384.6057    0.038632      27.1500       3.5000
+   14600.0000     386.3711    0.039349      27.1500       3.5000
+   14700.0000     388.1445    0.040079      27.1500       3.5000
+   14800.0000     389.9261    0.040824      27.1500       3.5000
+   14900.0000     391.7159    0.041583      27.1500       3.5000
+   15000.0000     393.5139    0.042356      27.1500       3.5000
+   15100.0000     395.3202    0.043145      27.1500       3.5000
+   15200.0000     397.1347    0.043948      27.1500       3.5000
+   15300.0000     398.9575    0.044767      27.1500       3.5000
+   15400.0000     400.7887    0.045601      27.1500       3.5000
+   15500.0000     402.6284    0.046452      27.1500       3.5000
+   15600.0000     404.4764    0.047319      27.1500       3.5000
+   15700.0000     406.3330    0.048203      27.1500       3.5000
+   15800.0000     408.1981    0.049104      27.1500       3.5000
+   15900.0000     410.0717    0.050022      27.1500       3.5000
+   16000.0000     411.9540    0.050957      27.1500       3.5000
+   16100.0000     413.8449    0.051911      27.1500       3.5000
+   16200.0000     415.7444    0.052884      27.1500       3.5000
+   16300.0000     417.6527    0.053875      27.1500       3.5000
+   16400.0000     419.5698    0.054885      27.1500       3.5000
+   16500.0000     421.4956    0.055915      27.1500       3.5000
+   16600.0000     423.4303    0.056965      27.1500       3.5000
+   16700.0000     425.3738    0.058035      27.1500       3.5000
+   16800.0000     427.3263    0.059126      27.1500       3.5000
+   16900.0000     429.2878    0.060238      27.1500       3.5000
+   17000.0000     431.2582    0.061372      27.1500       3.5000
+   17100.0000     433.2377    0.062528      27.1500       3.5000
+   17200.0000     435.2263    0.063706      27.1500       3.5000
+   17300.0000     437.2240    0.064908      27.1500       3.5000
+   17400.0000     439.2308    0.066132      27.1500       3.5000
+   17500.0000     441.2469    0.067381      27.1500       3.5000
+   17600.0000     443.2723    0.068654      27.1500       3.5000
+   17700.0000     445.3069    0.069952      27.1500       3.5000
+   17800.0000     447.3509    0.071275      27.1500       3.5000
+   17900.0000     449.4042    0.072624      27.1500       3.5000
+   18000.0000     451.4670    0.073999      27.1500       3.5000
+   18100.0000     453.5393    0.075402      27.1500       3.5000
+   18200.0000     455.6210    0.076832      27.1500       3.5000
+   18300.0000     457.7123    0.078290      27.1500       3.5000
+   18400.0000     459.8133    0.079777      27.1500       3.5000
+   18500.0000     461.9238    0.081292      27.1500       3.5000
+   18600.0000     464.0441    0.082838      27.1500       3.5000
+   18700.0000     466.1740    0.084414      27.1500       3.5000
+   18800.0000     468.3138    0.086021      27.1500       3.5000
+   18900.0000     470.4633    0.087660      27.1500       3.5000
+   19000.0000     472.6228    0.089331      27.1500       3.5000
+   19100.0000     474.7922    0.091035      27.1500       3.5000
+   19200.0000     476.9715    0.092773      27.1500       3.5000
+   19300.0000     479.1608    0.094545      27.1500       3.5000
+   19400.0000     481.3601    0.096352      27.1500       3.5000
+   19500.0000     483.5696    0.098195      27.1500       3.5000
+   19600.0000     485.7892    0.100075      27.1500       3.5000
+   19700.0000     488.0190    0.101991      27.1500       3.5000
+   19800.0000     490.2590    0.103946      27.1500       3.5000
+   19900.0000     492.5093    0.105940      27.1500       3.5000
+   20000.0000     494.7699    0.107973      27.1500       3.5000
+   20500.0000     506.2297    0.118763      27.1500       3.5000
+   21000.0000     517.9549    0.130674      27.1500       3.5000
+   21500.0000     529.9517    0.143829      27.1500       3.5000
+   22000.0000     542.2263    0.158363      27.1500       3.5000
+   22500.0000     554.7853    0.174427      27.1500       3.5000
+   23000.0000     567.6351    0.192191      27.1500       3.5000
+   23500.0000     580.7826    0.211843      27.1500       3.5000
+   24000.0000     594.2346    0.233593      27.1500       3.5000
+   24500.0000     607.9981    0.257676      27.1500       3.5000
+   25000.0000     622.0805    0.284356      27.1500       3.5000
+   25500.0000     636.4890    0.313926      27.1500       3.5000
+   26000.0000     651.2312    0.346716      27.1500       3.5000
+   26500.0000     666.3149    0.383097      27.1500       3.5000
+   27000.0000     681.7480    0.423482      27.1500       3.5000
+   27500.0000     697.5385    0.468337      27.1500       3.5000
+   28000.0000     713.6947    0.518183      27.1500       3.5000
+   28500.0000     730.2252    0.573610      27.1500       3.5000
+   29000.0000     747.1385    0.635280      27.1500       3.5000
+   29500.0000     764.4437    0.703938      27.1500       3.5000
+   30000.0000     782.1495    0.780421      27.1500       3.5000
diff --git a/wrfv2_fire/test/em_quarter_ss/input_sounding_preWRFV3.6 b/wrfv2_fire/test/em_quarter_ss/input_sounding_preWRFV3.6
new file mode 100644
index 00000000..0f91581b
--- /dev/null
+++ b/wrfv2_fire/test/em_quarter_ss/input_sounding_preWRFV3.6
@@ -0,0 +1,48 @@
+ 1000.00      300.00      14.00
+   250.00     300.45      14.00      -7.88      -3.58
+   750.00     301.25      14.00      -6.94      -0.89
+  1250.00     302.47      13.50      -5.17       1.33
+  1750.00     303.93      11.10      -2.76       2.84
+  2250.00     305.31       9.06       0.01       3.47
+  2750.00     306.81       7.36       2.87       3.49
+  3250.00     308.46       5.95       5.73       3.49
+  3750.00     310.03       4.78       8.58       3.49
+  4250.00     311.74       3.82      11.44       3.49
+  4750.00     313.48       3.01      14.30       3.49
+  5250.00     315.24       2.36      17.15       3.49
+  5750.00     317.18       1.80      20.01       3.49
+  6250.00     319.02       1.41      22.87       3.49
+  6750.00     320.88       1.07      25.73       3.49
+  7250.00     322.80       0.80      27.15       3.49
+  7750.00     324.87       0.60      27.15       3.49
+  8250.00     326.86       0.43      27.15       3.49
+  8750.00     328.89       0.32      27.15       3.49
+  9250.00     330.39       0.24      27.15       3.49
+  9750.00     332.80       0.17      27.15       3.49
+ 10250.00     335.23       0.10      27.15       3.49
+ 10750.00     337.31       0.08      27.15       3.49
+ 11250.00     339.55       0.05      27.15       3.49
+ 11750.00     342.82       0.03      27.15       3.49
+ 12250.00     349.88       0.04      27.15       3.49
+ 12750.00     357.34       0.04      27.15       3.49
+ 13250.00     364.91       0.04      27.15       3.49
+ 13750.00     373.22       0.04      27.15       3.49
+ 14250.00     381.67       0.04      27.15       3.49
+ 14750.00     390.29       0.04      27.15       3.49
+ 15250.00     398.91       0.04      27.15       3.49
+ 15750.00     407.53       0.04      27.15       3.49
+ 16250.00     416.15       0.04      27.15       3.49
+ 16750.00     424.77       0.04      27.15       3.49
+ 17250.00     433.39       0.04      27.15       3.49
+ 17750.00     442.01       0.04      27.15       3.49
+ 18250.00     450.63       0.04      27.15       3.49
+ 18750.00     459.25       0.04      27.15       3.49
+ 19250.00     467.87       0.04      27.15       3.49
+ 19750.00     476.49       0.04      27.15       3.49
+ 20250.00     485.11       0.04      27.15       3.49
+ 20750.00     493.73       0.04      27.15       3.49
+ 21250.00     502.35       0.04      27.15       3.49
+ 21750.00     510.97       0.04      27.15       3.49
+ 22250.00     519.59       0.04      27.15       3.49
+ 22750.00     528.21       0.04      27.15       3.49
+
diff --git a/wrfv2_fire/test/em_quarter_ss/namelist.input b/wrfv2_fire/test/em_quarter_ss/namelist.input
index 1dd7726a..61aad71c 100644
--- a/wrfv2_fire/test/em_quarter_ss/namelist.input
+++ b/wrfv2_fire/test/em_quarter_ss/namelist.input
@@ -69,8 +69,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 2,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
  damp_opt                            = 2,
  zdamp                               = 5000.,  5000.,  5000.,
  dampcoef                            = 0.003,  0.003,  0.003
diff --git a/wrfv2_fire/test/em_quarter_ss/namelist.input_2to1 b/wrfv2_fire/test/em_quarter_ss/namelist.input_2to1
new file mode 100644
index 00000000..898d4707
--- /dev/null
+++ b/wrfv2_fire/test/em_quarter_ss/namelist.input_2to1
@@ -0,0 +1,116 @@
+ &time_control
+ run_days                            = 0,
+ run_hours                           = 1,
+ run_minutes                         = 0,
+ run_seconds                         = 0, 
+ start_year                          = 0001, 0001, 0001,
+ start_month                         = 01,   01,   01,
+ start_day                           = 01,   01,   01,
+ start_hour                          = 00,   00,   00,
+ start_minute                        = 00,   00,   00,
+ start_second                        = 00,   00,   00,
+ end_year                            = 0001, 0001, 0001,
+ end_month                           = 01,   01,   01,
+ end_day                             = 01,   01,   01,
+ end_hour                            = 00,   00,   00,
+ end_minute                          = 120,  120,  120,
+ end_second                          = 00,   00,   00,
+ history_interval                    = 10,   10,   10,
+ frames_per_outfile                  = 1000, 1000, 1000,
+ restart                             = .false.,
+ restart_interval                    = 120,
+ io_form_history                     = 2
+ io_form_restart                     = 2
+ io_form_input                       = 2
+ io_form_boundary                    = 2
+ debug_level                         = 0
+ /
+
+ &domains
+ time_step                           = 12,
+ time_step_fract_num                 = 0,
+ time_step_fract_den                 = 1,
+ max_dom                             = 2,
+ s_we                                = 1,     1,     1,
+ s_sn                                = 1,     1,     1,
+ s_vert                              = 1,     1,     1,
+ e_vert                              = 41,    41,    41,
+ ztop                                = 20000, 20000, 20000,
+ grid_id                             = 1,     2,     3,
+ parent_id                           = 0,     1,     2,
+ i_parent_start                      = 0,     16,    15,
+ j_parent_start                      = 0,     16,    15,
+ feedback                            = 1,
+ smooth_option                       = 0
+
+ e_we                                = 61,    61,
+ e_sn                                = 61,    61,
+ dx                                  = 2000,  1000,
+ dy                                  = 2000,  1000,                       
+ parent_grid_ratio                   = 1,     2,
+ parent_time_step_ratio              = 1,     2,
+ /
+
+ &physics
+ mp_physics                          = 1,     1,     1,
+ ra_lw_physics                       = 0,     0,     0,
+ ra_sw_physics                       = 0,     0,     0,
+ radt                                = 30,    30,    30,
+ sf_sfclay_physics                   = 0,     0,     0,
+ sf_surface_physics                  = 0,     0,     0,
+ bl_pbl_physics                      = 0,     0,     0,
+ bldt                                = 0,     0,     0,
+ cu_physics                          = 0,     0,     0,
+ cudt                                = 5,     5,     5,
+ num_soil_layers                     = 5,
+ /
+
+ &fdda
+ /
+
+ &dynamics
+ rk_ord                              = 3,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
+ damp_opt                            = 2,
+ zdamp                               = 5000.,  5000.,  5000.,
+ dampcoef                            = 0.003,  0.003,  0.003
+ khdif                               = 500,    500,    500,
+ kvdif                               = 500,    500,    500,
+ smdiv                               = 0.1,    0.1,    0.1,
+ emdiv                               = 0.01,   0.01,   0.01,
+ epssm                               = 0.1,    0.1,    0.1
+ time_step_sound                     = 6,      6,      6,
+ h_mom_adv_order                     = 5,      5,      5,
+ v_mom_adv_order                     = 3,      3,      3,
+ h_sca_adv_order                     = 5,      5,      5,
+ v_sca_adv_order                     = 3,      3,      3,
+ moist_adv_opt                       = 1,      1,      1,     
+ scalar_adv_opt                      = 1,      1,      1,     
+ chem_adv_opt                        = 1,      1,      1,     
+ tke_adv_opt                         = 1,      1,      1,     
+ non_hydrostatic                     = .true., .true., .true.,
+ mix_full_fields                     = .true., .true., .true.,
+ /
+
+ &bdy_control
+ periodic_x                          = .false.,.false.,.false.,
+ symmetric_xs                        = .false.,.false.,.false.,
+ symmetric_xe                        = .false.,.false.,.false.,
+ open_xs                             = .true., .false.,.false.,
+ open_xe                             = .true., .false.,.false.,
+ periodic_y                          = .false.,.false.,.false.,
+ symmetric_ys                        = .false.,.false.,.false.,
+ symmetric_ye                        = .false.,.false.,.false.,
+ open_ys                             = .true., .false.,.false.,
+ open_ye                             = .true., .false.,.false.,
+ nested                              = .false., .true., .true.,
+ /
+
+ &grib2
+ /
+
+ &namelist_quilt
+ nio_tasks_per_group = 0,
+ nio_groups = 1,
+ /
diff --git a/wrfv2_fire/test/em_quarter_ss/namelist.input_3to1 b/wrfv2_fire/test/em_quarter_ss/namelist.input_3to1
new file mode 100644
index 00000000..eacaf4bb
--- /dev/null
+++ b/wrfv2_fire/test/em_quarter_ss/namelist.input_3to1
@@ -0,0 +1,116 @@
+ &time_control
+ run_days                            = 0,
+ run_hours                           = 1,
+ run_minutes                         = 0,
+ run_seconds                         = 0, 
+ start_year                          = 0001, 0001, 0001,
+ start_month                         = 01,   01,   01,
+ start_day                           = 01,   01,   01,
+ start_hour                          = 00,   00,   00,
+ start_minute                        = 00,   00,   00,
+ start_second                        = 00,   00,   00,
+ end_year                            = 0001, 0001, 0001,
+ end_month                           = 01,   01,   01,
+ end_day                             = 01,   01,   01,
+ end_hour                            = 00,   00,   00,
+ end_minute                          = 120,  120,  120,
+ end_second                          = 00,   00,   00,
+ history_interval                    = 10,   10,   10,
+ frames_per_outfile                  = 1000, 1000, 1000,
+ restart                             = .false.,
+ restart_interval                    = 120,
+ io_form_history                     = 2
+ io_form_restart                     = 2
+ io_form_input                       = 2
+ io_form_boundary                    = 2
+ debug_level                         = 0
+ /
+
+ &domains
+ time_step                           = 12,
+ time_step_fract_num                 = 0,
+ time_step_fract_den                 = 1,
+ max_dom                             = 2,
+ s_we                                = 1,     1,     1,
+ s_sn                                = 1,     1,     1,
+ s_vert                              = 1,     1,     1,
+ e_vert                              = 41,    41,    41,
+ ztop                                = 20000, 20000, 20000,
+ grid_id                             = 1,     2,     3,
+ parent_id                           = 0,     1,     2,
+ i_parent_start                      = 0,     16,    15,
+ j_parent_start                      = 0,     16,    15,
+ feedback                            = 1,
+ smooth_option                       = 0
+
+ e_we                                = 61,    91,
+ e_sn                                = 61,    91,
+ dx                                  = 2000,  666.6667
+ dy                                  = 2000,  666.6667
+ parent_grid_ratio                   = 1,     3,
+ parent_time_step_ratio              = 1,     3,
+ /
+
+ &physics
+ mp_physics                          = 1,     1,     1,
+ ra_lw_physics                       = 0,     0,     0,
+ ra_sw_physics                       = 0,     0,     0,
+ radt                                = 30,    30,    30,
+ sf_sfclay_physics                   = 0,     0,     0,
+ sf_surface_physics                  = 0,     0,     0,
+ bl_pbl_physics                      = 0,     0,     0,
+ bldt                                = 0,     0,     0,
+ cu_physics                          = 0,     0,     0,
+ cudt                                = 5,     5,     5,
+ num_soil_layers                     = 5,
+ /
+
+ &fdda
+ /
+
+ &dynamics
+ rk_ord                              = 3,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
+ damp_opt                            = 2,
+ zdamp                               = 5000.,  5000.,  5000.,
+ dampcoef                            = 0.003,  0.003,  0.003
+ khdif                               = 500,    500,    500,
+ kvdif                               = 500,    500,    500,
+ smdiv                               = 0.1,    0.1,    0.1,
+ emdiv                               = 0.01,   0.01,   0.01,
+ epssm                               = 0.1,    0.1,    0.1
+ time_step_sound                     = 6,      6,      6,
+ h_mom_adv_order                     = 5,      5,      5,
+ v_mom_adv_order                     = 3,      3,      3,
+ h_sca_adv_order                     = 5,      5,      5,
+ v_sca_adv_order                     = 3,      3,      3,
+ moist_adv_opt                       = 1,      1,      1,     
+ scalar_adv_opt                      = 1,      1,      1,     
+ chem_adv_opt                        = 1,      1,      1,     
+ tke_adv_opt                         = 1,      1,      1,     
+ non_hydrostatic                     = .true., .true., .true.,
+ mix_full_fields                     = .true., .true., .true.,
+ /
+
+ &bdy_control
+ periodic_x                          = .false.,.false.,.false.,
+ symmetric_xs                        = .false.,.false.,.false.,
+ symmetric_xe                        = .false.,.false.,.false.,
+ open_xs                             = .true., .false.,.false.,
+ open_xe                             = .true., .false.,.false.,
+ periodic_y                          = .false.,.false.,.false.,
+ symmetric_ys                        = .false.,.false.,.false.,
+ symmetric_ye                        = .false.,.false.,.false.,
+ open_ys                             = .true., .false.,.false.,
+ open_ye                             = .true., .false.,.false.,
+ nested                              = .false., .true., .true.,
+ /
+
+ &grib2
+ /
+
+ &namelist_quilt
+ nio_tasks_per_group = 0,
+ nio_groups = 1,
+ /
diff --git a/wrfv2_fire/test/em_quarter_ss/namelist.input_4to1 b/wrfv2_fire/test/em_quarter_ss/namelist.input_4to1
new file mode 100644
index 00000000..eb90a8a2
--- /dev/null
+++ b/wrfv2_fire/test/em_quarter_ss/namelist.input_4to1
@@ -0,0 +1,116 @@
+ &time_control
+ run_days                            = 0,
+ run_hours                           = 1,
+ run_minutes                         = 0,
+ run_seconds                         = 0, 
+ start_year                          = 0001, 0001, 0001,
+ start_month                         = 01,   01,   01,
+ start_day                           = 01,   01,   01,
+ start_hour                          = 00,   00,   00,
+ start_minute                        = 00,   00,   00,
+ start_second                        = 00,   00,   00,
+ end_year                            = 0001, 0001, 0001,
+ end_month                           = 01,   01,   01,
+ end_day                             = 01,   01,   01,
+ end_hour                            = 00,   00,   00,
+ end_minute                          = 120,  120,  120,
+ end_second                          = 00,   00,   00,
+ history_interval                    = 10,   10,   10,
+ frames_per_outfile                  = 1000, 1000, 1000,
+ restart                             = .false.,
+ restart_interval                    = 120,
+ io_form_history                     = 2
+ io_form_restart                     = 2
+ io_form_input                       = 2
+ io_form_boundary                    = 2
+ debug_level                         = 0
+ /
+
+ &domains
+ time_step                           = 12,
+ time_step_fract_num                 = 0,
+ time_step_fract_den                 = 1,
+ max_dom                             = 2,
+ s_we                                = 1,     1,     1,
+ s_sn                                = 1,     1,     1,
+ s_vert                              = 1,     1,     1,
+ e_vert                              = 41,    41,    41,
+ ztop                                = 20000, 20000, 20000,
+ grid_id                             = 1,     2,     3,
+ parent_id                           = 0,     1,     2,
+ i_parent_start                      = 0,     16,    15,
+ j_parent_start                      = 0,     16,    15,
+ feedback                            = 1,
+ smooth_option                       = 0
+
+ e_we                                = 61,    121,
+ e_sn                                = 61,    121,
+ dx                                  = 2000,  500       
+ dy                                  = 2000,  500      
+ parent_grid_ratio                   = 1,     4,
+ parent_time_step_ratio              = 1,     4,
+ /
+
+ &physics
+ mp_physics                          = 1,     1,     1,
+ ra_lw_physics                       = 0,     0,     0,
+ ra_sw_physics                       = 0,     0,     0,
+ radt                                = 30,    30,    30,
+ sf_sfclay_physics                   = 0,     0,     0,
+ sf_surface_physics                  = 0,     0,     0,
+ bl_pbl_physics                      = 0,     0,     0,
+ bldt                                = 0,     0,     0,
+ cu_physics                          = 0,     0,     0,
+ cudt                                = 5,     5,     5,
+ num_soil_layers                     = 5,
+ /
+
+ &fdda
+ /
+
+ &dynamics
+ rk_ord                              = 3,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
+ damp_opt                            = 2,
+ zdamp                               = 5000.,  5000.,  5000.,
+ dampcoef                            = 0.003,  0.003,  0.003
+ khdif                               = 500,    500,    500,
+ kvdif                               = 500,    500,    500,
+ smdiv                               = 0.1,    0.1,    0.1,
+ emdiv                               = 0.01,   0.01,   0.01,
+ epssm                               = 0.1,    0.1,    0.1
+ time_step_sound                     = 6,      6,      6,
+ h_mom_adv_order                     = 5,      5,      5,
+ v_mom_adv_order                     = 3,      3,      3,
+ h_sca_adv_order                     = 5,      5,      5,
+ v_sca_adv_order                     = 3,      3,      3,
+ moist_adv_opt                       = 1,      1,      1,     
+ scalar_adv_opt                      = 1,      1,      1,     
+ chem_adv_opt                        = 1,      1,      1,     
+ tke_adv_opt                         = 1,      1,      1,     
+ non_hydrostatic                     = .true., .true., .true.,
+ mix_full_fields                     = .true., .true., .true.,
+ /
+
+ &bdy_control
+ periodic_x                          = .false.,.false.,.false.,
+ symmetric_xs                        = .false.,.false.,.false.,
+ symmetric_xe                        = .false.,.false.,.false.,
+ open_xs                             = .true., .false.,.false.,
+ open_xe                             = .true., .false.,.false.,
+ periodic_y                          = .false.,.false.,.false.,
+ symmetric_ys                        = .false.,.false.,.false.,
+ symmetric_ye                        = .false.,.false.,.false.,
+ open_ys                             = .true., .false.,.false.,
+ open_ye                             = .true., .false.,.false.,
+ nested                              = .false., .true., .true.,
+ /
+
+ &grib2
+ /
+
+ &namelist_quilt
+ nio_tasks_per_group = 0,
+ nio_groups = 1,
+ /
diff --git a/wrfv2_fire/test/em_quarter_ss/namelist.input_5to1 b/wrfv2_fire/test/em_quarter_ss/namelist.input_5to1
new file mode 100644
index 00000000..aa232d0c
--- /dev/null
+++ b/wrfv2_fire/test/em_quarter_ss/namelist.input_5to1
@@ -0,0 +1,116 @@
+ &time_control
+ run_days                            = 0,
+ run_hours                           = 1,
+ run_minutes                         = 0,
+ run_seconds                         = 0, 
+ start_year                          = 0001, 0001, 0001,
+ start_month                         = 01,   01,   01,
+ start_day                           = 01,   01,   01,
+ start_hour                          = 00,   00,   00,
+ start_minute                        = 00,   00,   00,
+ start_second                        = 00,   00,   00,
+ end_year                            = 0001, 0001, 0001,
+ end_month                           = 01,   01,   01,
+ end_day                             = 01,   01,   01,
+ end_hour                            = 00,   00,   00,
+ end_minute                          = 120,  120,  120,
+ end_second                          = 00,   00,   00,
+ history_interval                    = 10,   10,   10,
+ frames_per_outfile                  = 1000, 1000, 1000,
+ restart                             = .false.,
+ restart_interval                    = 120,
+ io_form_history                     = 2
+ io_form_restart                     = 2
+ io_form_input                       = 2
+ io_form_boundary                    = 2
+ debug_level                         = 0
+ /
+
+ &domains
+ time_step                           = 12,
+ time_step_fract_num                 = 0,
+ time_step_fract_den                 = 1,
+ max_dom                             = 2,
+ s_we                                = 1,     1,     1,
+ s_sn                                = 1,     1,     1,
+ s_vert                              = 1,     1,     1,
+ e_vert                              = 41,    41,    41,
+ ztop                                = 20000, 20000, 20000,
+ grid_id                             = 1,     2,     3,
+ parent_id                           = 0,     1,     2,
+ i_parent_start                      = 0,     16,    15,
+ j_parent_start                      = 0,     16,    15,
+ feedback                            = 1,
+ smooth_option                       = 0
+
+ e_we                                = 61,    151,
+ e_sn                                = 61,    151,
+ dx                                  = 2000,  400       
+ dy                                  = 2000,  400      
+ parent_grid_ratio                   = 1,     5,
+ parent_time_step_ratio              = 1,     5,
+ /
+
+ &physics
+ mp_physics                          = 1,     1,     1,
+ ra_lw_physics                       = 0,     0,     0,
+ ra_sw_physics                       = 0,     0,     0,
+ radt                                = 30,    30,    30,
+ sf_sfclay_physics                   = 0,     0,     0,
+ sf_surface_physics                  = 0,     0,     0,
+ bl_pbl_physics                      = 0,     0,     0,
+ bldt                                = 0,     0,     0,
+ cu_physics                          = 0,     0,     0,
+ cudt                                = 5,     5,     5,
+ num_soil_layers                     = 5,
+ /
+
+ &fdda
+ /
+
+ &dynamics
+ rk_ord                              = 3,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
+ damp_opt                            = 2,
+ zdamp                               = 5000.,  5000.,  5000.,
+ dampcoef                            = 0.003,  0.003,  0.003
+ khdif                               = 500,    500,    500,
+ kvdif                               = 500,    500,    500,
+ smdiv                               = 0.1,    0.1,    0.1,
+ emdiv                               = 0.01,   0.01,   0.01,
+ epssm                               = 0.1,    0.1,    0.1
+ time_step_sound                     = 6,      6,      6,
+ h_mom_adv_order                     = 5,      5,      5,
+ v_mom_adv_order                     = 3,      3,      3,
+ h_sca_adv_order                     = 5,      5,      5,
+ v_sca_adv_order                     = 3,      3,      3,
+ moist_adv_opt                       = 1,      1,      1,     
+ scalar_adv_opt                      = 1,      1,      1,     
+ chem_adv_opt                        = 1,      1,      1,     
+ tke_adv_opt                         = 1,      1,      1,     
+ non_hydrostatic                     = .true., .true., .true.,
+ mix_full_fields                     = .true., .true., .true.,
+ /
+
+ &bdy_control
+ periodic_x                          = .false.,.false.,.false.,
+ symmetric_xs                        = .false.,.false.,.false.,
+ symmetric_xe                        = .false.,.false.,.false.,
+ open_xs                             = .true., .false.,.false.,
+ open_xe                             = .true., .false.,.false.,
+ periodic_y                          = .false.,.false.,.false.,
+ symmetric_ys                        = .false.,.false.,.false.,
+ symmetric_ye                        = .false.,.false.,.false.,
+ open_ys                             = .true., .false.,.false.,
+ open_ye                             = .true., .false.,.false.,
+ nested                              = .false., .true., .true.,
+ /
+
+ &grib2
+ /
+
+ &namelist_quilt
+ nio_tasks_per_group = 0,
+ nio_groups = 1,
+ /
diff --git a/wrfv2_fire/test/em_real/examples.namelist b/wrfv2_fire/test/em_real/examples.namelist
index 12d8f496..4552681c 100755
--- a/wrfv2_fire/test/em_real/examples.namelist
+++ b/wrfv2_fire/test/em_real/examples.namelist
@@ -44,31 +44,51 @@ Note, this is not a namelist.input file. Find what interests you, and cut and pa
 &noah_mp
  dveg                               = 4,
  opt_crs                            = 1,
- opt_btr                            = 1,
+ opt_btr                            = 2,
  opt_sfc                            = 1,
  opt_run                            = 1,
  opt_frz                            = 1,
  opt_inf                            = 1,
- opt_rad                            = 1,
+ opt_rad                            = 3,
  opt_alb                            = 2,
  opt_snf                            = 1,
- opt_tbot                           = 2,
+ opt_tbot                           = 1,
  opt_stc                            = 1,
  /
 
 
-** Using stochastic backscatter scheme
-
+** Using lake model
 &physics
- stoch_force_opt                     = 1,      1,      1,
- stoch_vertstruc_opt                 = 0,      0,      0,
- tot_backscat_t                      = 1.0E-6, 1.0E-6, 1.0E-6
- tot_backscat_psi                    = 1.0E-5, 1.0E-5, 1.0E-5
+ sf_lake_physics                     = 1,      1,     1,
+ lakedepth_default                   = 50.,    50.,   50.,
+ lake_min_elev                       = 5.,     5.,    5.,
+
+ 
+** Using stochastic backscatter scheme (new namelist record since v3.6)
+
+&stoch
+ stoch_force_opt                     = 1,        1,        1,
+ stoch_vertstruc_opt                 = 0,        0,        0,
+ tot_backscat_psi                    = 1.E-05,   1.E-05,   1.E-05,
+ tot_backscat_t                      = 1.E-06,   1.E-06,   1.E-06,
  nens                                = 1,
-
-&bdy_control
+ ztau_psi                            = 10800.0,
+ ztau_t                              = 10800.0,
+ rexponent_psi                       =-1.83,
+ rexponent_t                         =-1.83,
+ zsigma2_eps                         = 0.0833,
+ zsigma2_eta                         = 0.0833,
+ kminforc                            = 1,
+ kminforc                            = 1,
+ kminforct                           = 1,
+ lminforct                           = 1,
+ kmaxforc                            = 1000000,
+ lmaxforc                            = 1000000,
+ kmaxforct                           = 1000000,
+ lmaxforct                           = 1000000,
  perturb_bdy                         = 0,
 
+
 ** Using DFI options (note this is a separate namelist record):
 
  &dfi_control
@@ -225,8 +245,8 @@ Note, this is not a namelist.input file. Find what interests you, and cut and pa
  guv                                 = 0.0003,     0.0003,     0.0003,
  gt                                  = 0.0003,     0.0003,     0.0003,
  gph                                 = 0.0003,     0.0003,     0.0003,
- xwavenum                            = 3
- ywavenum                            = 3
+ xwavenum                            = 3,
+ ywavenum                            = 3,
  if_ramping                          = 1,
  dtramp_min                          = 60.0,
  io_form_gfdda                       = 2,
@@ -390,8 +410,36 @@ Price, J. F., T. B. Sanford, and G. Z. Forristal, 1994: Forced stage response to
 
 ** Using U. Miami Forward Lagrangian trajectory calculation 
   (add it in namelist record &physics):
- trajcall                            = 1,
- num_traj                            = 50
+&domain
+ num_traj                            = 25,
+
+&physics
+ traj_opt                            = 1,
+
+
+** Using aerosol option aer_opt = 2:
+
+&physics
+ aer_opt            = 2,
+ aer_type           = 1,
+ aer_aod550_opt     = 1,
+ aer_aod550_val     = 0.12,
+ aer_angexp_opt     = 1,
+ aer_angexp_val     = 1.3,
+ aer_ssa_opt        = 1,
+ aer_ssa_val        = 0.85,
+ aer_asy_opt        = 1,
+ aer_asy_val        = 0.90,
+
+
+** Using Jimenez wind-farm scheme
+
+In the &physics namelist record, set the MAX_DOM value:
+ windfarm                            = 1,    1,    1
 
+Also in the directory with namelist.input, is the file defining the
+specifics of the wind turbine type: wind-turbine-1.tbl
 
+The location of wind turbines are specified as lat lon, and 
+the turbine type: windturbines.txt
 
diff --git a/wrfv2_fire/test/em_real/namelist.input b/wrfv2_fire/test/em_real/namelist.input
index 1b612ec6..af0853b7 100755
--- a/wrfv2_fire/test/em_real/namelist.input
+++ b/wrfv2_fire/test/em_real/namelist.input
@@ -75,8 +75,8 @@
 
  &dynamics
  w_damping                           = 0,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_real/namelist.input.4km b/wrfv2_fire/test/em_real/namelist.input.4km
index d6abda46..dd1af61d 100755
--- a/wrfv2_fire/test/em_real/namelist.input.4km
+++ b/wrfv2_fire/test/em_real/namelist.input.4km
@@ -53,15 +53,15 @@
 
  &physics
  mp_physics                          = 6,     6,     6,
- ra_lw_physics                       = 1,     1,     1,
- ra_sw_physics                       = 1,     1,     1,
+ ra_lw_physics                       = 4,     4,     4,
+ ra_sw_physics                       = 4,     4,     4,
  radt                                = 10,    10,    10,
  sf_sfclay_physics                   = 1,     1,     1,
  sf_surface_physics                  = 2,     2,     2,
  bl_pbl_physics                      = 1,     1,     1,
  bldt                                = 0,     0,     0,
  cu_physics                          = 0,     0,     0,
- cudt                                = 5,     5,     5,
+ cudt                                = 0,     0,     0,
  isfflx                              = 1,
  ifsnow                              = 0,
  icloud                              = 1,
@@ -75,8 +75,8 @@
 
  &dynamics
  w_damping                           = 0,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_real/namelist.input.chem b/wrfv2_fire/test/em_real/namelist.input.chem
index c8c3dddd..920fa0a6 100644
--- a/wrfv2_fire/test/em_real/namelist.input.chem
+++ b/wrfv2_fire/test/em_real/namelist.input.chem
@@ -86,8 +86,8 @@
 
  &dynamics
  w_damping                           = 1,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_real/namelist.input.diags b/wrfv2_fire/test/em_real/namelist.input.diags
index e6740482..b7ab6f7a 100755
--- a/wrfv2_fire/test/em_real/namelist.input.diags
+++ b/wrfv2_fire/test/em_real/namelist.input.diags
@@ -91,8 +91,8 @@
 
  &dynamics
  w_damping                           = 0,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_real/namelist.input.fire b/wrfv2_fire/test/em_real/namelist.input.fire
index 76b3c289..751ae09c 100644
--- a/wrfv2_fire/test/em_real/namelist.input.fire
+++ b/wrfv2_fire/test/em_real/namelist.input.fire
@@ -77,8 +77,8 @@
  &dynamics
  rk_ord                              = 3,
  w_damping                           = 0,
- diff_opt                            = 2,
- km_opt                              = 2,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
  damp_opt                            = 0,
  base_temp                           = 290.
  zdamp                               = 5000.,
diff --git a/wrfv2_fire/test/em_real/namelist.input.global b/wrfv2_fire/test/em_real/namelist.input.global
index 96d22735..d575279e 100755
--- a/wrfv2_fire/test/em_real/namelist.input.global
+++ b/wrfv2_fire/test/em_real/namelist.input.global
@@ -75,8 +75,8 @@
  /
 
  &dynamics
- diff_opt                            = 0,
- km_opt                              = 0,
+ diff_opt                            = 0,      0,      0,
+ km_opt                              = 0,      0,      0,
  damp_opt                            = 3,
  base_temp                           = 290.
  zdamp                               = 5000.,  5000.,  5000.,
diff --git a/wrfv2_fire/test/em_real/namelist.input.jan00 b/wrfv2_fire/test/em_real/namelist.input.jan00
index 6f66ef58..17aaae1a 100755
--- a/wrfv2_fire/test/em_real/namelist.input.jan00
+++ b/wrfv2_fire/test/em_real/namelist.input.jan00
@@ -53,8 +53,8 @@
 
  &physics
  mp_physics                          = 3,     3,     3,
- ra_lw_physics                       = 1,     1,     1,
- ra_sw_physics                       = 1,     1,     1,
+ ra_lw_physics                       = 4,     4,     4,
+ ra_sw_physics                       = 4,     4,     4,
  radt                                = 30,    30,    30,
  sf_sfclay_physics                   = 1,     1,     1,
  sf_surface_physics                  = 2,     2,     2,
@@ -80,8 +80,8 @@
 
  &dynamics
  w_damping                           = 0,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_real/namelist.input.jun01 b/wrfv2_fire/test/em_real/namelist.input.jun01
index 8f3a0723..10f519ab 100755
--- a/wrfv2_fire/test/em_real/namelist.input.jun01
+++ b/wrfv2_fire/test/em_real/namelist.input.jun01
@@ -53,14 +53,14 @@
 
  &physics
  mp_physics                          = 6,     6,     6,
- ra_lw_physics                       = 1,     1,     1,
- ra_sw_physics                       = 1,     1,     1,
+ ra_lw_physics                       = 4,     4,     4,
+ ra_sw_physics                       = 4,     4,     4,
  radt                                = 10,    10,    10,
  sf_sfclay_physics                   = 1,     1,     1,
  sf_surface_physics                  = 2,     2,     2,
  bl_pbl_physics                      = 1,     1,     1,
  bldt                                = 0,     0,     0,
- cu_physics                          = 1,     1,     0,
+ cu_physics                          = 1,     0,     0,
  cudt                                = 5,     5,     5,
  isfflx                              = 1,
  ifsnow                              = 0,
@@ -75,8 +75,8 @@
 
  &dynamics
  w_damping                           = 0,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_real/namelist.input.ndown_1 b/wrfv2_fire/test/em_real/namelist.input.ndown_1
index 33d4ef89..cbc93556 100755
--- a/wrfv2_fire/test/em_real/namelist.input.ndown_1
+++ b/wrfv2_fire/test/em_real/namelist.input.ndown_1
@@ -91,8 +91,8 @@
 
  &dynamics
  w_damping                           = 0,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_real/namelist.input.ndown_2 b/wrfv2_fire/test/em_real/namelist.input.ndown_2
index 28563cdd..a1e2c89c 100755
--- a/wrfv2_fire/test/em_real/namelist.input.ndown_2
+++ b/wrfv2_fire/test/em_real/namelist.input.ndown_2
@@ -93,8 +93,8 @@
 
  &dynamics
  w_damping                           = 0,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_real/namelist.input.ndown_3 b/wrfv2_fire/test/em_real/namelist.input.ndown_3
index 67b43bb5..331e266c 100755
--- a/wrfv2_fire/test/em_real/namelist.input.ndown_3
+++ b/wrfv2_fire/test/em_real/namelist.input.ndown_3
@@ -93,8 +93,8 @@
 
  &dynamics
  w_damping                           = 0,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_real/namelist.input.volc b/wrfv2_fire/test/em_real/namelist.input.volc
index ec30b13c..31ba573e 100755
--- a/wrfv2_fire/test/em_real/namelist.input.volc
+++ b/wrfv2_fire/test/em_real/namelist.input.volc
@@ -80,8 +80,8 @@
 
  &dynamics
  w_damping                           = 0,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
diff --git a/wrfv2_fire/test/em_real/wind-turbine-1.tbl b/wrfv2_fire/test/em_real/wind-turbine-1.tbl
new file mode 100644
index 00000000..277ef990
--- /dev/null
+++ b/wrfv2_fire/test/em_real/wind-turbine-1.tbl
@@ -0,0 +1,23 @@
+21
+80. 90. 0.140 2.0
+4.   0.80    50.0 
+5.   0.80   150.0  
+6.   0.80   300.0   
+7.   0.80   450.0   
+8.   0.80   700.0  
+9.   0.80  1000.0   
+10.  0.79  1300.0  
+11.  0.74  1700.0   
+12.  0.70  1900.0   
+13.  0.40  1950.0  
+14.  0.30  1990.0  
+15.  0.25  1998.0   
+16.  0.20  1999.0   
+17.  0.15  2000.0 
+18.  0.13  2000.0  
+19.  0.11  2000.0  
+20.  0.10  2000.0   
+21.  0.08  2000.0 
+22.  0.06  2000.0  
+23.  0.05  2000.0
+24.  0.05  2000.0 
diff --git a/wrfv2_fire/test/em_real/windturbines.txt b/wrfv2_fire/test/em_real/windturbines.txt
new file mode 100644
index 00000000..68a6d49d
--- /dev/null
+++ b/wrfv2_fire/test/em_real/windturbines.txt
@@ -0,0 +1,3 @@
+ 55.574051 6.883480 1
+ 55.569066 6.884697 1 
+ 30.000000 -77.000000 1
diff --git a/wrfv2_fire/test/em_scm_xy/namelist.input b/wrfv2_fire/test/em_scm_xy/namelist.input
index d1c1e315..50571a30 100644
--- a/wrfv2_fire/test/em_scm_xy/namelist.input
+++ b/wrfv2_fire/test/em_scm_xy/namelist.input
@@ -76,8 +76,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 2,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
  damp_opt                            = 2,
  dampcoef                            = .003,
  zdamp                               = 5000.,
diff --git a/wrfv2_fire/test/em_seabreeze2d_x/README.seabreeze b/wrfv2_fire/test/em_seabreeze2d_x/README.seabreeze
index f1cd59fb..499dca43 100644
--- a/wrfv2_fire/test/em_seabreeze2d_x/README.seabreeze
+++ b/wrfv2_fire/test/em_seabreeze2d_x/README.seabreeze
@@ -1,10 +1,12 @@
 
 The purpose of this case is to demonstrate how one can set up all land variables
-in order to use a full-physics ste-up in an idealized case. 
+in order to use a full-physics set-up in an idealized case. 
 
 This test case is an attempt to produce a two dimensional sea breeze simulation.
 Configuration needs tuning to produce desirable results, as the current
-settings give a very shallow sea breeze. 
+settings give a very shallow sea breeze. As of V3.6 the eta_levels are listed
+in the namelist and used instead of the idealized eta levels. This gives
+more levels in the sea breeeze layer.
 
 The input sounding has no wind.
 
@@ -16,8 +18,10 @@ is the local time as well as the UTC time (5Z  in the namelist).
 For other longitudes the start_hour refers to UTC time.
 The land-surface fields are filled so that the slab, Noah or RUC LSMs can be used.
 
-This setup is for a 2D case with 202 grid points in x. The land occupies 50 grid
+This setup is for a 2D case with 202 grid points in x and 35 eta levels. The land occupies 50 grid
 points in the middle of the domain. The width of the land can be changed
 by modifying variable lm (half width for land points) in 
 dyn_em/module_initialize_seabreeze2d_x.F.
 
+As of V3.6 an example of 8 tracers are initialized in this case and mixed with
+the PBL option. These are set up in the initialize module.
diff --git a/wrfv2_fire/test/em_seabreeze2d_x/namelist.input b/wrfv2_fire/test/em_seabreeze2d_x/namelist.input
index 0b4ecdf9..98050dba 100644
--- a/wrfv2_fire/test/em_seabreeze2d_x/namelist.input
+++ b/wrfv2_fire/test/em_seabreeze2d_x/namelist.input
@@ -40,10 +40,18 @@
  dx                                  = 2000,
  dy                                  = 2000,
  ztop                                = 20000.,
+ eta_levels                          = 1.000, 0.993, 0.983, 0.970, 0.954,
+                                       0.934, 0.909, 0.880, 0.845, 0.807,
+                                       0.765, 0.719, 0.672, 0.622, 0.571,
+                                       0.520, 0.468, 0.420, 0.376, 0.335,
+                                       0.298, 0.263, 0.231, 0.202, 0.175,
+                                       0.150, 0.127, 0.106, 0.088, 0.070,
+                                       0.055, 0.040, 0.026, 0.013, 0.000
+
  /
 
  &physics
- mp_physics                          = 2,
+ mp_physics                          = 14,
  ra_lw_physics                       = 1,
  ra_sw_physics                       = 1,
  radt                                = 5,
@@ -51,6 +59,7 @@
  sf_surface_physics                  = 1,
  bl_pbl_physics                      = 1,
  bldt                                = 0,
+ tracer_pblmix                       = 1
  cu_physics                          = 0,
  cudt                                = 0,
  num_soil_layers                     = 5,
@@ -61,8 +70,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 1,
- km_opt                              = 4,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  damp_opt                            = 2,
  dampcoef                            = .003,
  zdamp                               = 5000.,
@@ -76,6 +85,7 @@
  v_mom_adv_order                     = 3,
  h_sca_adv_order                     = 5,
  v_sca_adv_order                     = 3,
+ tracer_opt                          = 2,
  mix_full_fields                     = .true.,
  non_hydrostatic                     = .true.,
  /
diff --git a/wrfv2_fire/test/em_seabreeze2d_x/namelist.input.ideal b/wrfv2_fire/test/em_seabreeze2d_x/namelist.input.windfarm
similarity index 50%
rename from wrfv2_fire/test/em_seabreeze2d_x/namelist.input.ideal
rename to wrfv2_fire/test/em_seabreeze2d_x/namelist.input.windfarm
index a5a4212d..5c2feb84 100644
--- a/wrfv2_fire/test/em_seabreeze2d_x/namelist.input.ideal
+++ b/wrfv2_fire/test/em_seabreeze2d_x/namelist.input.windfarm
@@ -1,22 +1,22 @@
  &time_control
  run_days                            = 0,
- run_hours                           = 0,
- run_minutes                         = 360,
+ run_hours                           = 12,
+ run_minutes                         = 0,
  run_seconds                         = 0,
- start_year                          = 0001,
- start_month                         = 01,
- start_day                           = 01,
- start_hour                          = 00,
+ start_year                          = 2007,
+ start_month                         = 06,
+ start_day                           = 1,
+ start_hour                          = 5,
  start_minute                        = 00,
  start_second                        = 00,
- end_year                            = 0001,
- end_month                           = 01,
- end_day                             = 16,
- end_hour                            = 00,
+ end_year                            = 2007,
+ end_month                           = 06,
+ end_day                             = 2,
+ end_hour                            = 5,
  end_minute                          = 00,
  end_second                          = 00,
  history_interval                    = 30,
- frames_per_outfile                  = 1,
+ frames_per_outfile                  = 1000,
  restart                             = .false.,
  restart_interval                    = 360,
  io_form_history                     = 2
@@ -27,47 +27,45 @@
  /
 
  &domains
- time_step                           = 3,
+ time_step                           = 15,
  time_step_fract_num                 = 0,
  time_step_fract_den                 = 1,
  max_dom                             = 1,
  s_we                                = 1,
- e_we                                = 101,
+ e_we                                = 202,
  s_sn                                = 1,
- e_sn                                = 101,
+ e_sn                                = 202,
  s_vert                              = 1,
- e_vert                              = 81,
- dx                                  = 1000,
- dy                                  = 1000,
+ e_vert                              = 35,
+ dx                                  = 2000,
+ dy                                  = 2000,
  ztop                                = 20000.,
+ eta_levels                          = 1.000, 0.993, 0.983, 0.970, 0.954,
+                                       0.934, 0.909, 0.880, 0.845, 0.807,
+                                       0.765, 0.719, 0.672, 0.622, 0.571,
+                                       0.520, 0.468, 0.420, 0.376, 0.335,
+                                       0.298, 0.263, 0.231, 0.202, 0.175,
+                                       0.150, 0.127, 0.106, 0.088, 0.070,
+                                       0.055, 0.040, 0.026, 0.013, 0.000
+
  /
 
  &physics
- mp_physics                          = 0,
- ra_lw_physics                       = 0,
- ra_sw_physics                       = 0,
- radt                                = 0,
+ mp_physics                          = 14,
+ ra_lw_physics                       = 1,
+ ra_sw_physics                       = 1,
+ radt                                = 5,
  sf_sfclay_physics                   = 5,
- sf_surface_physics                  = 0,
+ sf_surface_physics                  = 1,
  bl_pbl_physics                      = 5,
  bldt                                = 0,
+ bl_mynn_tkeadvect                   = .true.,
+ tracer_pblmix                       = 1
  cu_physics                          = 0,
  cudt                                = 0,
- isfflx                              = 0,
  num_soil_layers                     = 5,
- windturbines_spec = "ideal"
- td_turbgridid   =      1,
- td_hubheight    =   100.,
- td_diameter     =   100.,
- td_stdthrcoef   =   .158,
- td_cutinspeed   =    3.5,
- td_cutoutspeed  =    30.,
- td_power        =    5.0,
- td_turbpercell  =    1.0,
- td_ewfx         =     10,
- td_ewfy         =     10,
- td_pwfx         =     45,
- td_pwfy         =     45,
+ windfarm_opt                        = 1,
+ windfarm_ij                         = 1,
  /
 
  &fdda
@@ -75,14 +73,12 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 1,
- km_opt                              = 4,
- diff_6th_opt                        = 2,
- diff_6th_factor                     = 0.12,
+ diff_opt                            = 1,      1,      1,
+ km_opt                              = 4,      4,      4,
  damp_opt                            = 2,
  dampcoef                            = .003,
  zdamp                               = 5000.,
- khdif                               = 100,
+ khdif                               = 300,
  kvdif                               = 1,
  smdiv                               = 0.1,
  emdiv                               = 0.01,
@@ -92,22 +88,22 @@
  v_mom_adv_order                     = 3,
  h_sca_adv_order                     = 5,
  v_sca_adv_order                     = 3,
+ tracer_opt                          = 2,
  mix_full_fields                     = .true.,
  non_hydrostatic                     = .true.,
- pert_coriolis = .true.
  /
 
  &bdy_control
- periodic_x                          = .false.,
+ periodic_x                          = .true.,
  symmetric_xs                        = .false.,
  symmetric_xe                        = .false.,
- open_xs                             = .true.,
- open_xe                             = .true.,
- periodic_y                          = .false.,
+ open_xs                             = .false., 
+ open_xe                             = .false.,
+ periodic_y                          = .true.,
  symmetric_ys                        = .false.,
  symmetric_ye                        = .false.,
- open_ys                             = .true.,
- open_ye                             = .true.,
+ open_ys                             = .false.,
+ open_ye                             = .false.,
  /
 
  &grib2
@@ -117,5 +113,3 @@
  nio_tasks_per_group = 0,
  nio_groups = 1,
  /
-
-
diff --git a/wrfv2_fire/test/em_seabreeze2d_x/namelist.input.windspec b/wrfv2_fire/test/em_seabreeze2d_x/namelist.input.windspec
deleted file mode 100644
index 47f78efc..00000000
--- a/wrfv2_fire/test/em_seabreeze2d_x/namelist.input.windspec
+++ /dev/null
@@ -1,109 +0,0 @@
- &time_control
- run_days                            = 0,
- run_hours                           = 0,
- run_minutes                         = 360,
- run_seconds                         = 0,
- start_year                          = 0001,
- start_month                         = 01,
- start_day                           = 01,
- start_hour                          = 00,
- start_minute                        = 00,
- start_second                        = 00,
- end_year                            = 0001,
- end_month                           = 01,
- end_day                             = 16,
- end_hour                            = 00,
- end_minute                          = 00,
- end_second                          = 00,
- history_interval                    = 30,
- frames_per_outfile                  = 1,
- restart                             = .false.,
- restart_interval                    = 360,
- io_form_history                     = 2
- io_form_restart                     = 2
- io_form_input                       = 2
- io_form_boundary                    = 2
- debug_level                         = 0
- /
-
- &domains
- time_step                           = 3,
- time_step_fract_num                 = 0,
- time_step_fract_den                 = 1,
- max_dom                             = 1,
- s_we                                = 1,
- e_we                                = 101,
- s_sn                                = 1,
- e_sn                                = 101,
- s_vert                              = 1,
- e_vert                              = 81,
- dx                                  = 1000,
- dy                                  = 1000,
- ztop                                = 20000.,
- /
-
- &physics
- mp_physics                          = 0,
- ra_lw_physics                       = 0,
- ra_sw_physics                       = 0,
- radt                                = 0,
- sf_sfclay_physics                   = 5,
- sf_surface_physics                  = 0,
- bl_pbl_physics                      = 5,
- bldt                                = 0,
- cu_physics                          = 0,
- cudt                                = 0,
- isfflx                              = 0,
- num_soil_layers                     = 5,
- windturbines_spec = "windspec.in"
- /
-
- &fdda
- /
-
- &dynamics
- rk_ord                              = 3,
- diff_opt                            = 1,
- km_opt                              = 4,
- diff_6th_opt                        = 2,
- diff_6th_factor                     = 0.12,
- damp_opt                            = 2,
- dampcoef                            = .003,
- zdamp                               = 5000.,
- khdif                               = 100,
- kvdif                               = 1,
- smdiv                               = 0.1,
- emdiv                               = 0.01,
- epssm                               = 0.1,
- time_step_sound                     = 6,
- h_mom_adv_order                     = 5,
- v_mom_adv_order                     = 3,
- h_sca_adv_order                     = 5,
- v_sca_adv_order                     = 3,
- mix_full_fields                     = .true.,
- non_hydrostatic                     = .true.,
- pert_coriolis = .true.
- /
-
- &bdy_control
- periodic_x                          = .false.,
- symmetric_xs                        = .false.,
- symmetric_xe                        = .false.,
- open_xs                             = .true.,
- open_xe                             = .true.,
- periodic_y                          = .false.,
- symmetric_ys                        = .false.,
- symmetric_ye                        = .false.,
- open_ys                             = .true.,
- open_ye                             = .true.,
- /
-
- &grib2
- /
-
- &namelist_quilt
- nio_tasks_per_group = 0,
- nio_groups = 1,
- /
-
-
diff --git a/wrfv2_fire/test/em_seabreeze2d_x/run_me_first.csh b/wrfv2_fire/test/em_seabreeze2d_x/run_me_first.csh
index 403d27fa..38201dac 100755
--- a/wrfv2_fire/test/em_seabreeze2d_x/run_me_first.csh
+++ b/wrfv2_fire/test/em_seabreeze2d_x/run_me_first.csh
@@ -6,5 +6,6 @@ echo linking to LANDUSE.TBL in ../../run directory
 
 ln -sf ../../run/LANDUSE.TBL .
 ln -sf ../../run/RRTM_DATA .
+ln -sf ../../run/wind-turbine-1.tbl .
 
 echo done
diff --git a/wrfv2_fire/test/em_seabreeze2d_x/windspec.in b/wrfv2_fire/test/em_seabreeze2d_x/windspec.in
deleted file mode 100644
index 42de2fcb..00000000
--- a/wrfv2_fire/test/em_seabreeze2d_x/windspec.in
+++ /dev/null
@@ -1,104 +0,0 @@
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!   lat   hubheight         stdthrcoef         cutinspeed
-! id   lon         diameter           power             cutoutspeed
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  1 45 45 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 46 45 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 47 45 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 48 45 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 49 45 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 50 45 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 51 45 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 52 45 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 53 45 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 54 45 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 45 46 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 46 46 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 47 46 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 48 46 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 49 46 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 50 46 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 51 46 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 52 46 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 53 46 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 54 46 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 45 47 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 46 47 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 47 47 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 48 47 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 49 47 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 50 47 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 51 47 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 52 47 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 53 47 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 54 47 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 45 48 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 46 48 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 47 48 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 48 48 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 49 48 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 50 48 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 51 48 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 52 48 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 53 48 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 54 48 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 45 49 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 46 49 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 47 49 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 48 49 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 49 49 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 50 49 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 51 49 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 52 49 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 53 49 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 54 49 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 45 50 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 46 50 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 47 50 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 48 50 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 49 50 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 50 50 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 51 50 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 52 50 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 53 50 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 54 50 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 45 51 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 46 51 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 47 51 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 48 51 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 49 51 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 50 51 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 51 51 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 52 51 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 53 51 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 54 51 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 45 52 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 46 52 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 47 52 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 48 52 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 49 52 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 50 52 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 51 52 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 52 52 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 53 52 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 54 52 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 45 53 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 46 53 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 47 53 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 48 53 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 49 53 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 50 53 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 51 53 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 52 53 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 53 53 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 54 53 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 45 54 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 46 54 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 47 54 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 48 54 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 49 54 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 50 54 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 51 54 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 52 54 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 53 54 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
-  1 54 54 100.0000 100.0000 0.1580000 5.000000 3.500000 30.00000 
diff --git a/wrfv2_fire/test/em_squall2d_x/namelist.input b/wrfv2_fire/test/em_squall2d_x/namelist.input
index 9e7879d7..3b967251 100644
--- a/wrfv2_fire/test/em_squall2d_x/namelist.input
+++ b/wrfv2_fire/test/em_squall2d_x/namelist.input
@@ -61,8 +61,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 2,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
  damp_opt                            = 2,
  dampcoef                            = .003,
  zdamp                               = 5000.,
diff --git a/wrfv2_fire/test/em_squall2d_y/namelist.input b/wrfv2_fire/test/em_squall2d_y/namelist.input
index a773aad7..f0796bd8 100644
--- a/wrfv2_fire/test/em_squall2d_y/namelist.input
+++ b/wrfv2_fire/test/em_squall2d_y/namelist.input
@@ -61,8 +61,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 2,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 2,      2,      2,
  damp_opt                            = 2,
  dampcoef                            = .003,
  zdamp                               = 5000.,
diff --git a/wrfv2_fire/test/em_tropical_cyclone/namelist.input b/wrfv2_fire/test/em_tropical_cyclone/namelist.input
index 23108e0d..c5718f76 100644
--- a/wrfv2_fire/test/em_tropical_cyclone/namelist.input
+++ b/wrfv2_fire/test/em_tropical_cyclone/namelist.input
@@ -62,8 +62,8 @@
 
  &dynamics
  rk_ord                              = 3,
- diff_opt                            = 2,
- km_opt                              = 4,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 4,      4,      4,
  damp_opt                            = 2,
  dampcoef                            = .003,
  zdamp                               = 5000.,
diff --git a/wrfv2_fire/test/exp_real/namelist.input b/wrfv2_fire/test/exp_real/namelist.input
index 2e42018f..15f557a4 100755
--- a/wrfv2_fire/test/exp_real/namelist.input
+++ b/wrfv2_fire/test/exp_real/namelist.input
@@ -5,8 +5,8 @@
  restart                             = .false.,
  max_dom                             = 1,
  rk_ord                              = 3,
- diff_opt                            = 0,
- km_opt                              = 1,
+ diff_opt                            = 0,      0,      0,
+ km_opt                              = 1,      1,      1,
  damp_opt                            = 0,
  isfflx                              = 1,
  ifsnow                              = 0,
diff --git a/wrfv2_fire/test/nmm_real/namelist.input.HWRF b/wrfv2_fire/test/nmm_real/namelist.input.HWRF
new file mode 100644
index 00000000..66c03227
--- /dev/null
+++ b/wrfv2_fire/test/nmm_real/namelist.input.HWRF
@@ -0,0 +1,152 @@
+! This is the new unified namelist, which includes settings for all
+! wrf.exe and real_nmm.exe invocations, including 27:9, 27:9:3, ghost,
+! analysis, 12hr, and 126hr.  This is accomplished by using the 
+! HWRF stream parser to insert environment variables into the namelist.
+
+! Some of these settings require that the HWRF preprocessing
+! system is used to generate additional input files (D2/D3 analysis)
+! Please refer to the HWRF users guide at:
+!
+! http://www.dtcenter.org/HurrWRF/users/overview/hwrf_overview.php
+!
+!27:9:3non-ghostconfig
+
+
+
+ &time_control
+ start_year                          = 2012, 2012, 2012,
+ start_month                         = 10, 10, 10,
+ start_day                           = 28, 28, 28,
+ start_hour                          = 06, 06, 06,
+ start_minute                        = 00,      00,	00,
+ start_second                        = 00,      00,     00,
+ end_year                            = 2012, 2012, 2012,
+ end_month                           = 10, 10, 10,
+ end_day                             = 28, 28, 28,
+ end_hour                            = 12, 12, 12,
+ end_minute                          = 00, 00, 00,
+ end_second                          = 00,      00,     00,
+ interval_seconds                    = 21600,
+ history_interval                    = 360,         360,        360,
+ auxhist1_interval                   = 360,          360,        360
+ frames_per_outfile                  = 2,2,2
+ frames_per_auxhist1                 = 1,1,1
+ analysis                            = F,  T,T,
+
+ restart                             = .false.,
+ restart_interval                    = 36000,
+ reset_simulation_start              = F,
+ io_form_input                       = 2
+ io_form_history                     = 2
+ io_form_restart                     = 2
+ io_form_boundary                    = 2
+ io_form_auxinput1                   = 2
+ io_form_auxhist1                    =  2
+ auxinput1_inname                    = "met_nmm.d."
+ debug_level                         = 1
+ override_restart_timers             = T
+ 
+ /
+
+ &fdda
+ /
+
+ &domains
+ time_step                           = 45,
+ time_step_fract_num                 = 0,
+ time_step_fract_den                 = 1,
+ max_dom                             = 3,
+ s_we                                = 1,             1,	1,
+ e_we                                = 216,       88,	180,
+ s_sn                                = 1,             1,	1,
+ e_sn                                = 432,       170,	324,
+ s_vert                              = 1,             1,	1,
+ e_vert                              = 43,   43,    43,
+ dx                                  = 0.18,      0.06,   0.02,
+ dy                                  = 0.18,      0.06,   0.02,
+ grid_id                             = 1,             2,	3,
+ 
+ tile_sz_x                           = 0,
+ tile_sz_y                           = 0,
+ numtiles                            = 1,
+ nproc_x                             = -1, ! must be on its own line
+ nproc_y                             = -1, ! must be on its own line
+ parent_id                           = 0,              1,	2,
+ parent_grid_ratio                   = 1,              3,	3,
+ parent_time_step_ratio              = 1,              3,	3,
+ i_parent_start                      = 0,             00099,	14,
+ j_parent_start                      = 0,             00225,	33,
+ feedback                            = 1,
+ num_moves                           = -99
+ num_metgrid_levels                  =  27,
+ num_metgrid_soil_levels             =  4,
+ p_top_requested                     = 5000,
+ ptsgm                               = 42000
+eta_levels=1.0,.9919699,.9827400,.9710800,.9600599,.9462600,.9306099,.9129300,.8930600,.8708600,.8462000,.8190300,.7893100,.7570800,.7224600,.6856500,.6469100,.6066099,.5651600,.5230500,.4807700,.4388600,.3978000,.3580500,.3200099,.2840100,.2502900,.2190100,.1902600,.1640600,.1403600,.1190600,.1000500,.0831600,.0682400,.0551200,.0436200,.0335700,.0248200,.0172200,.0106300,.0049200,.0000000,
+
+/
+ &physics
+ num_soil_layers                     = 4,
+ mp_physics                          = 85,           85,	85,
+ ra_lw_physics                       = 98,          98,		98,
+ ra_sw_physics                       = 98,          98,		98,
+ sf_sfclay_physics                   = 88,          88,    	88,
+ sf_surface_physics                  = 88,          88,		88,
+ bl_pbl_physics                      = 3,          3,		3,
+ cu_physics                          = 84,         84,		0,
+ mommix                              = 1.0,       1.0,		1.0,
+ var_ric                             = 1.0,
+ coef_ric_l                          = 0.16,
+ coef_ric_s                          = 0.25,
+ h_diff                              = 1.0,        1.0,		1.0,
+ gwd_opt                             = 2, 0,		0,
+ sfenth                              = 0.0,        0.0,		0.0,
+ nrads                               = 80,240,720,
+ nradl                               = 80,240,720,
+ nphs                                = 2,6,6,
+ ncnvc                               = 2,6,6,
+
+ movemin                             = 3,6,18,
+
+! IMPORTANT: dt*nphs*movemin for domain 2 and 3 must be 540 and 180, respectively
+!            AND the history output times (10800, 10800, 3600) must be
+!            divisible by dt*nphs*movemin for domains 1, 2 and 3
+
+ gfs_alpha                           = 0.7,0.7,0.7,
+ sas_pgcon                           = 0.55,0.2,0.2,
+sas_mass_flux=0.5,0.5,0.5,
+ co2tf                               = 1,
+vortex_tracker=2,6,6,
+
+! Disable nest movement at certain intervals to prevent junk in the output files:
+ nomove_freq                         = 0.0,      6.0,      6.0, ! hours
+/
+
+ &dynamics
+ non_hydrostatic                     = .true.,    .true,        .true,
+ euler_adv                           = .false.
+ wp                                  = 0,         0,            0,
+ coac                                = 0.75,3.0,4.0,
+ codamp                              = 6.4,       6.4,          6.4,
+ terrain_smoothing                   = 2,
+/
+
+ &bdy_control
+ spec_bdy_width                      = 1,
+ specified                           = .true. /
+
+ &namelist_quilt 
+poll_servers=.true.
+ nio_tasks_per_group                 = 4,
+ nio_groups                          = 4 /
+
+ &logging
+  compute_slaves_silent=.true.
+  io_servers_silent=.true.
+  stderr_logging=1
+ /
+
+LSF_TIME=1:30
+NQS_TIME=0:10:00
+NUM_PROCESSORS=16
+
diff --git a/wrfv2_fire/test/nmm_real/namelist.input.chem_nmm b/wrfv2_fire/test/nmm_real/namelist.input.chem_nmm
deleted file mode 100644
index 2807f115..00000000
--- a/wrfv2_fire/test/nmm_real/namelist.input.chem_nmm
+++ /dev/null
@@ -1,132 +0,0 @@
- &time_control
- run_days                            = 1,
- run_hours                           = 0,   
- run_minutes                         = 0,
- run_seconds                         = 0,
- start_year                          = 2005,
- start_month                         = 01,
- start_day                           = 23,
- start_hour                          = 00,
- start_minute                        = 00,
- start_second                        = 00,
- tstart                              = 00,
- end_year                            = 2005,
- end_month                           = 01,
- end_day                             = 24,
- end_hour                            = 00,
- end_minute                          = 00,
- end_second                          = 00,
- interval_seconds                    = 10800,
- history_interval                    = 60
- frames_per_outfile                  = 1,
- restart                             = .false.,
- restart_interval                    = 5760,
- reset_simulation_start              = F,
- io_form_input                       = 2
- io_form_history                     = 2
- io_form_restart                     = 2
- io_form_boundary                    = 2
- io_form_auxinput1                   = 2
- auxinput1_inname                    = "met_nmm.d."
- debug_level                         = 1 
- /
-
- &domains
- time_step                           = 34,
- time_step_fract_num                 = 2,
- time_step_fract_den                 = 7,
- max_dom                             = 1,
- s_we                                = 1,
- e_we                                = 56,
- s_sn                                = 1,
- e_sn                                = 92,
- s_vert                              = 1,
- e_vert                              = 38,
- num_metgrid_levels                  = 40,
- dx                                  = .096,
- dy                                  = .095,
- grid_id                             = 1,
- p_top_requested                     = 5000.
- ptsgm                               = 42000.,
- eta_levels   =   1.000, 0.994, 0.983, 0.968, 0.950, 0.930, 0.908, 0.882, 0.853, 0.821,
-                  0.788, 0.752, 0.715, 0.677, 0.637, 0.597, 0.557, 0.517, 0.477,
-                  0.438, 0.401, 0.365, 0.332, 0.302, 0.274, 0.248, 0.224, 0.201,
-                  0.179, 0.158, 0.138, 0.118, 0.098, 0.078, 0.058, 0.038, 0.018, 0.000
- tile_sz_x		   	     = 0,
- tile_sz_y		   	     = 0,
- numtiles			     = 1
-/
- &physics
- mp_physics                          = 5,
- ra_lw_physics                       = 99,
- ra_sw_physics                       = 99,
- nrads                               = 105, 
- nradl                               = 105,
- co2tf                               = 1,
- sf_sfclay_physics                   = 2,
- sf_surface_physics                  = 99,
- bl_pbl_physics                      = 2,
- nphs                                = 6,
- cu_physics                          = 2,
- ncnvc                               = 6,
- tprec                               = 3,
- theat                               = 6,
- tclod                               = 6,
- trdsw                               = 6,
- trdlw                               = 6,
- tsrfc                               = 6,
- pcpflg                              = .false.,
- num_soil_layers                     = 4,
- mp_zero_out                         = 0
- cu_rad_feedback                     = .false.,
- gwd_opt                             = 0
- /
-
- &dynamics
- euler_advect                        = .false.,
- idtadt                              = 1,
- idtadc                              = 1
- /
-
- &bdy_control
- spec_bdy_width                      = 1,
- specified                           = .true.,
- nested                              = .false.
- /
-
- &grib2
-/
-
- &namelist_quilt
- nio_tasks_per_group = 0,
- nio_groups = 1
- /
-
- &chem
- kemit                               = 10,
- chem_opt                            = 2,
- bioemdt                             = 30,
- photdt                              = 30,
- chemdt                              = 0.5,
- frames_per_emissfile                = 12
- io_style_emissions                  = 1
- emiss_inpt_opt                      = 1,
- chem_in_opt                         = 0,
- phot_opt                            = 1,
- drydep_opt                          = 1,
- bio_emiss_opt                       = 1,
- gas_bc_opt                          = 1,
- gas_ic_opt                          = 1,
- aer_bc_opt                          = 1,
- aer_ic_opt                          = 1,
- gaschem_onoff                       = 1,
- aerchem_onoff                       = 1,
- aer_ra_feedback                     = 0,
- wetscav_onoff                       = 0,
- cldchem_onoff                       = 0,
- vertmix_onoff                       = 1,
- chem_conv_tr                        = 1,
- aer_ra_feedback                     = 0,
- have_bcs_chem                       = .false.,
- /
-
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/README.NMM.TROPICAL_CYCLONE b/wrfv2_fire/test/nmm_tropical_cyclone/README.NMM.TROPICAL_CYCLONE
new file mode 100644
index 00000000..078db4a6
--- /dev/null
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/README.NMM.TROPICAL_CYCLONE
@@ -0,0 +1,36 @@
+README.Idealized_HWRF
+Last updated:  May 2013
+
+This README file provides a short overview of the HWRF idealized tropical cyclone test case. For details, please refer to the HWRF user’s guide and scientific documentation at http://www.dtcenter.org/HurrWRF/users/docs/index.php.
+
+
+Initial conditions are specified using an idealized vortex superposed on a base state quiescent sounding. The initial base state temperature and humidity profile is prescribed in file sound.d, while the vortex properties are specified in input.d. 
+
+
+The default initial vortex has an intensity of 20 m/s and a radius of maximum wind of 90 km. To initialize the idealized vortex, the nonlinear balance equation in the pressure-based sigma coordinate system described in Wang (1995),  and  reported in Bao et al. (2012) and  Gopalakrishnan et al. (2011 and 2013), is solved within the rotated latitude–longitude E-grid framework. 
+
+
+The default initial ambient base state assumes a f-plane at the latitude of 12.5 deg. Options for f-plane and beta-plane can be found in namelist file input.d. The sea surface temperature is time-invariant and horizontally homogeneous, with the default set to 302K. No land is used in the simulation domain. 
+
+
+The lateral boundary conditions used in the HWRF idealized simulation are the same as  used in real data cases. This inevitably leads to some reflection when gravity waves emanating from the vortex reach the outer domain lateral boundaries.
+
+
+The idealized simulation is configured  for the operational HWRF triple nested domain configuration with grid spacing at 27-, 9-, and 3-km.  All the operational atmospheric physics, as well as the supported experimental physics options in HWRF, can be used in  the idealized HWRF framework.
+
+
+
+
+References
+
+
+J.-W. Bao, S. G. Gopalakrishnan, S. A. Michelson, F. D. Marks, and M. T. Montgomery,2012:Impact of physics representations in the HWRFX on simulated hurricane structure and pressure–wind relationships. Mon. Wea. Rev., 140, 3278-3299
+
+
+Gopalakrishnan,  S.  G.,  F. Marks,  X.  Zhang, J.-W.  Bao,  K.-S.  Yeh,  and  R.  Atlas, 2011: The experimental HWRF System: a study on the influence of horizontal resolution on the structure and intensity changes in tropical cyclones using an idealized framework. Mon. Wea. Rev., 139, 1762–1784.
+
+
+Gopalakrishnan, S. G., F. Marks, J. A. Zhang, X. Zhang, J.-W. Bao, and V. Tallapragada, 2013: A study of the impacts of vertical diffusion on the structure and intensity of the tropical Cyclones using the high-resolution HWRF system. J. Atmos. Sci., 70, 524–541.
+
+
+Wang, Y., 1995: An inverse balance equation in sigma coordinates for model initialization. Mon. Wea. Rev., 123, 482–488.
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/input.d b/wrfv2_fire/test/nmm_tropical_cyclone/input.d
new file mode 100644
index 00000000..09bcfe04
--- /dev/null
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/input.d
@@ -0,0 +1,4 @@
+0------------indx=0 on f-plane, 1 on beta-plane
+ 0-----------nenv: index for environ.
+ 20.0--------vm0: maximum tangential wind of the initial vortex (m/s)
+ 90.0--------rm0: radius of maximum wind of the initial vortex (km)
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/namelist.input b/wrfv2_fire/test/nmm_tropical_cyclone/namelist.input
new file mode 100644
index 00000000..01aecea6
--- /dev/null
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/namelist.input
@@ -0,0 +1,137 @@
+ &time_control
+ start_year                          = 2008, 2008, 2008,
+ start_month                         = 09, 09, 09,
+ start_day                           = 06, 06, 06,
+ start_hour                          = 12, 12, 12,
+ start_minute                        = 00,      00,     00,
+ start_second                        = 00,      00,     00,
+ end_year                            = 2008, 2008, 2008,
+ end_month                           = 09, 09, 09,
+ end_day                             = 11, 11, 11,
+ end_hour                            = 12, 12, 12,
+ end_minute                          = 00, 00, 00,
+ end_second                          = 00,      00,     00,
+ interval_seconds                    = 432000,
+ history_interval                    = 180,         180,        180,
+ auxhist1_interval                   = 600000,           600000,        600000
+ frames_per_outfile                  = 1,1,1
+ frames_per_auxhist1                 = 1,1,1
+ analysis                            = F,    F,F  ,
+ restart                             = .false.,
+ restart_interval                    = 36000,
+ reset_simulation_start              = F,
+ io_form_input                       = 2
+ io_form_history                     = 2
+ io_form_restart                     = 2
+ io_form_boundary                    = 2
+ io_form_auxinput1                   = 2
+ io_form_auxhist1                    = 2 
+ auxinput1_inname                    = "met_nmm.d."
+ debug_level                         = 1
+ override_restart_timers             = T
+ /
+
+ &fdda
+ /
+
+ &domains
+ time_step                           = 45,
+ time_step_fract_num                 = 0,
+ time_step_fract_den                 = 1,
+ max_dom                             = 3,
+ s_we                                = 1,             1,        1,
+ e_we                                = 160,          88,       190,
+ s_sn                                = 1,             1,        1,
+ e_sn                                = 310,         170,       302,
+ s_vert                              = 1,             1,	1,
+ e_vert                              = 43,   43,    43,
+ dx                                  = 0.18,      .06,   .02,
+ dy                                  = 0.18,      .06,   .02,
+ grid_id                             = 1,             2,	3,
+ 
+ tile_sz_x                           = 0,
+ tile_sz_y                           = 0,
+ numtiles                            = 1,
+ nproc_x                             = -1, ! must be on its own line
+ nproc_y                             = -1, ! must be on its own line
+ parent_id                           = 0,              1,	2,
+ parent_grid_ratio                   = 1,              3,	3,
+ parent_time_step_ratio              = 1,              3,	3,
+ i_parent_start                      = 0,             66,	12,
+ j_parent_start                      = 0,            126,	35,
+ feedback                            = 1,
+ num_moves                           = -99
+ num_metgrid_levels                  = 22,
+ p_top_requested                     =  5000,
+ ptsgm                               = 42000
+  eta_levels                          = 1.0,         .9919699, .9827400, .9721600, .9600599, .9462600,
+                                      .9306099,     .9129300, .8930600, .8708600, .8462000, .8190300,
+                                      .7893100,     .7570800, .7224600, .6856500, .6469100, .6066099,
+                                      .5651600,     .5230500, .4807700, .4388600, .3978000, .3580500,
+                                      .3200099,     .2840100, .2502900, .2190100, .1902600, .1640600,
+                                      .1403600,     .1190600, .1000500, .0831600, .0682400, .0551200,
+                                      .0436200,     .0335700, .0248200, .0172200, .0106300, .0049200,
+                                      .0000000,
+ use_prep_hybrid = F,
+ num_metgrid_soil_levels = 4,
+/
+ &physics
+ num_soil_layers                     = 4,
+ mp_physics                          = 85,           85,	85,
+ ra_lw_physics                       = 98,          98,		98,
+ ra_sw_physics                       = 98,          98,		98,
+ sf_sfclay_physics                   = 88,          88,    	88,
+ sf_surface_physics                  = 88,          88,		88,
+ bl_pbl_physics                      = 3,          3,		3,
+ cu_physics                          = 84,         84,		0,
+ mommix                              = 1.0,       1.0,		1.0,
+ var_ric                             = 1.0,
+ coef_ric_l                          = 0.16,
+ coef_ric_s                          = 0.25,
+ h_diff                              = 1.0,        1.0,		1.0,
+ gwd_opt                             = 2, 0,		0,
+ sfenth                              = 0.0,        0.0,		0.0,
+ nrads                               =  80,240,720    ,
+ nradl                               =  80,240,720    ,
+ nphs                                =       2,6,6    ,
+ ncnvc                               =       2,6,6    ,
+
+ movemin                             =  3,6,18         ,
+
+! IMPORTANT: dt*nphs*movemin for domain 2 and 3 must be 540 and 180, respectively
+!            AND the history output times (10800, 10800, 3600) must be
+!            divisible by dt*nphs*movemin for domains 1, 2 and 3
+
+ gfs_alpha                           =  0.7,0.7,0.7     ,
+ sas_pgcon                           =  0.55,0.2,0.2 ,
+sas_mass_flux     = 0.5,0.5,0.5, 
+ co2tf                               = 1,
+ vortex_tracker = 2, 2, 6, 
+
+! Disable nest movement at certain intervals to prevent junk in the output files:
+ nomove_freq                         = 0.0,      6.0,      6.0, ! hours
+/
+
+ &dynamics
+ non_hydrostatic                     = .true.,    .true,        .true,
+ euler_adv                           = .false.
+ wp                                  = 0,         0,            0,
+ coac                                =  0.75,3.0,4.0  ,
+ codamp                              = 6.4,       6.4,          6.4,
+ terrain_smoothing                   =       2        ,
+/
+
+ &bdy_control
+ spec_bdy_width                      = 1,
+ specified                           = .true. /
+
+ &namelist_quilt 
+
+ nio_tasks_per_group                 = 0,
+ nio_groups                          = 1 /
+
+ &logging
+  compute_slaves_silent=.true.
+  io_servers_silent=.true.
+  stderr_logging=0
+ /
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/namelist.wps b/wrfv2_fire/test/nmm_tropical_cyclone/namelist.wps
new file mode 100644
index 00000000..0334ae10
--- /dev/null
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/namelist.wps
@@ -0,0 +1,49 @@
+&share
+ wrf_core = 'NMM',
+ max_dom = 2,
+ start_date = '2008-09-06_12:00:00',
+ end_date   = '2008-09-11_12:00:00',
+ interval_seconds = 432000
+ io_form_geogrid = 2,
+/
+
+&geogrid
+ parent_id         =   1,   1,
+ parent_grid_ratio =   1,   3,
+ i_parent_start    =   1,  78,
+ j_parent_start    =   1,  96,
+ e_we              =  160,  80,
+ e_sn              =  310, 134,
+ geog_data_res     = '30s','30s',
+ dx = 0.18,
+ dy = 0.18,
+ map_proj = 'rotated_ll',
+ ref_lat   =  21.0,
+ ref_lon   =  287.250,
+ stand_lon =  287.250,
+ geog_data_path = '/scratch1/portfolios/BMC/dtc-hwrf/Shaowu.Bao/WPS_GEOG'
+/
+
+&ungrib
+ out_format = 'WPS',
+ prefix = 'GFS',
+/
+
+&metgrid
+ fg_name = 'new_GFS',
+ io_form_metgrid = 2,
+/
+
+&mod_levs
+ press_pa = 201300 , 200100 , 100000 ,
+             95000 ,  90000 ,
+             85000 ,  80000 ,
+             75000 ,  70000 ,
+             65000 ,  60000 ,
+             55000 ,  50000 ,
+             45000 ,  40000 ,
+             35000 ,  30000 ,
+             25000 ,  20000 ,
+             15000 ,  10000 ,
+              5000 ,   1000
+/
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/sigma.d b/wrfv2_fire/test/nmm_tropical_cyclone/sigma.d
new file mode 100644
index 00000000..e23d671b
--- /dev/null
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/sigma.d
@@ -0,0 +1,23 @@
+            1    0.000000    
+            2   8.9188218E-03
+            3   4.8558116E-02
+            4   9.8107219E-02
+            5   0.1476563    
+            6   0.1972054    
+            7   0.2467545    
+            8   0.2963036    
+            9   0.3458527    
+           10   0.3954018    
+           11   0.4449509    
+           12   0.4945000    
+           13   0.5440491    
+           14   0.5935982    
+           15   0.6431473    
+           16   0.6926965    
+           17   0.7422456    
+           18   0.7917947    
+           19   0.8413438    
+           20   0.8908929    
+           21   0.9404420    
+           22   0.9899911    
+           23    1.000000    
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/sound.d b/wrfv2_fire/test/nmm_tropical_cyclone/sound.d
new file mode 100644
index 00000000..71ca69a0
--- /dev/null
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/sound.d
@@ -0,0 +1,30 @@
+    01.0        -30.00        00.0
+    10.0        -30.00        00.0
+    30.0        -40.00        00.0
+    40.0        -46.00        00.0
+    50.0        -52.00        00.0
+    60.0        -58.00        02.0
+    70.0        -64.00        05.0
+    80.0        -69.40        10.0
+   100.0        -72.70        15.0
+   125.0        -71.90        20.0
+   150.0        -67.60        25.0
+   175.0        -61.20        28.0
+   200.0        -55.40        32.0
+   250.0        -43.40        34.0
+   300.0        -33.40        36.0
+   350.0        -24.90        40.0
+   400.0        -17.80        45.0
+   450.0        -12.00        50.0
+   500.0         -7.10        55.0
+   550.0         -2.70        60.0
+   600.0          1.30        65.0
+   650.0          5.00        70.0
+   700.0          8.60        73.0
+   750.0         11.80        76.0 
+   800.0         14.70        79.0
+   850.0         17.40        82.0
+   900.0         20.20        85.0
+   950.0         23.10        85.0
+  1000.0         26.10        86.0
+  1010.1         27.00        86.0
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/sound_gfdl.d b/wrfv2_fire/test/nmm_tropical_cyclone/sound_gfdl.d
new file mode 100644
index 00000000..361f4497
--- /dev/null
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/sound_gfdl.d
@@ -0,0 +1,30 @@
+    01.0        -30.00        00.0
+    10.0        -33.24        00.0
+    30.0        -40.00        00.0
+    40.0        -46.00        00.0
+    50.0        -63.75        00.0
+    60.0        -58.00        02.0
+    70.0        -64.00        05.0
+    80.0        -70.00        10.0
+   100.0        -69.15        15.0
+   125.0        -75.10        20.0
+   150.0        -62.95        25.0
+   175.0        -60.40        28.0
+   200.0        -54.35        32.0
+   250.0        -45.05        34.0
+   300.0        -36.35        36.0
+   350.0        -28.25        40.0
+   400.0        -21.45        45.0
+   450.0        -15.14        50.0
+   500.0        -10.15        55.0
+   550.0         -5.45        60.0
+   600.0         -1.45        65.0
+   650.0          1.93        70.0
+   700.0          4.95        73.0
+   750.0          7.65        76.0 
+   800.0         10.35        79.0
+   850.0         13.25        82.0
+   900.0         16.45        85.0
+   950.0         20.25        85.0
+  1000.0         24.45        86.0
+  1010.1         27.85        86.0
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/sound_jordan.d b/wrfv2_fire/test/nmm_tropical_cyclone/sound_jordan.d
new file mode 100644
index 00000000..2dd584a5
--- /dev/null
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/sound_jordan.d
@@ -0,0 +1,30 @@
+    01.0        -30.00        00.0
+    10.0        -30.00        00.0
+    30.0        -40.00        00.0
+    40.0        -46.00        00.0
+    50.0        -52.00        00.0
+    60.0        -58.00        02.0
+    70.0        -64.00        05.0
+    80.0        -70.00        10.0
+   100.0        -78.80        15.0
+   125.0        -75.10        20.0
+   150.0        -67.80        25.0
+   175.0        -60.40        28.0
+   200.0        -53.50        32.0
+   250.0        -41.40        34.0
+   300.0        -31.30        36.0
+   350.0        -22.90        40.0
+   400.0        -16.00        45.0
+   450.0        -10.50        50.0
+   500.0         -5.80        55.0
+   550.0         -1.60        60.0
+   600.0          2.30        65.0
+   650.0          6.20        70.0
+   700.0          9.90        73.0
+   750.0         12.90        76.0 
+   800.0         15.40        79.0
+   850.0         18.10        82.0
+   900.0         20.70        85.0
+   950.0         23.70        85.0
+  1000.0         26.50        86.0
+  1010.1         27.00        86.0
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/sound_wet.d b/wrfv2_fire/test/nmm_tropical_cyclone/sound_wet.d
new file mode 100644
index 00000000..8ecbdb7f
--- /dev/null
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/sound_wet.d
@@ -0,0 +1,30 @@
+    01.0        -30.00        00.0
+    10.0        -30.00        00.0
+    30.0        -40.00        00.0
+    40.0        -46.00        00.0
+    50.0        -52.00        00.0
+    60.0        -58.00        02.0
+    70.0        -64.00        05.0
+    80.0        -69.40        20.0
+   100.0        -72.70        25.0
+   125.0        -71.90        30.0
+   150.0        -67.60        35.0
+   175.0        -61.20        38.0
+   200.0        -55.40        42.0
+   250.0        -43.40        44.0
+   300.0        -33.40        46.0
+   350.0        -24.90        50.0
+   400.0        -17.80        55.0
+   450.0        -12.00        60.0
+   500.0         -7.10        65.0
+   550.0         -2.70        70.0
+   600.0          1.30        75.0
+   650.0          5.00        80.0
+   700.0          8.60        83.0
+   750.0         11.80        86.0 
+   800.0         14.70        89.0
+   850.0         17.40        92.0
+   900.0         20.20        95.0
+   950.0         23.10        95.0
+  1000.0         26.10        96.0
+  1010.1         27.00        96.0
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/storm.center b/wrfv2_fire/test/nmm_tropical_cyclone/storm.center
new file mode 100644
index 00000000..c4745469
--- /dev/null
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/storm.center
@@ -0,0 +1,2 @@
+14.32
+-67.82
diff --git a/wrfv2_fire/tools/fortran_2003_test.F b/wrfv2_fire/tools/fortran_2003_ieee_test.F
similarity index 100%
rename from wrfv2_fire/tools/fortran_2003_test.F
rename to wrfv2_fire/tools/fortran_2003_ieee_test.F
diff --git a/wrfv2_fire/tools/fortran_2003_iso_c_test.F b/wrfv2_fire/tools/fortran_2003_iso_c_test.F
new file mode 100644
index 00000000..8a0c4777
--- /dev/null
+++ b/wrfv2_fire/tools/fortran_2003_iso_c_test.F
@@ -0,0 +1,24 @@
+      PROGRAM fortran_2003_test         
+
+      USE , INTRINSIC :: ISO_C_BINDING
+
+      IMPLICIT NONE
+
+      INTEGER , PARAMETER :: STR_LEN = 10
+
+      type, bind(c) :: r_info
+          integer(c_int64_t)                         :: offset
+          integer(c_int64_t)                         :: data_offset
+          integer(c_int32_t)                         :: data_count
+          integer(c_int32_t)                         :: data_type
+          character(kind=c_char), dimension(STR_LEN) :: name
+          character(kind=c_char), dimension(STR_LEN) :: date
+      end type r_info
+
+      REAL :: x , y , z
+
+      x = 1.e+10
+      y = 1.e-10
+      z = x + y
+
+      END PROGRAM fortran_2003_test         
diff --git a/wrfv2_fire/tools/gen_config.c b/wrfv2_fire/tools/gen_config.c
index 1f6ed351..306ec683 100644
--- a/wrfv2_fire/tools/gen_config.c
+++ b/wrfv2_fire/tools/gen_config.c
@@ -484,8 +484,8 @@ gen_config_reads ( char * dirname )
 
   fprintf(fp,"    CALL wrf_alt_nml_obsolete(nml_read_unit, TRIM(nml_name))\n") ;
   fprintf(fp,"    CYCLE NML_LOOP\n") ;
-  fprintf(fp,"9202 CALL wrf_message(\"Namelist \"//TRIM(nml_name)//\" not found in namelist.input.\"// & \n") ;
-  fprintf(fp,"                      \" Using registry defaults for variables in \"//TRIM(nml_name))\n") ;
+  fprintf(fp,"9202 CALL wrf_debug(1,\"Namelist \"//TRIM(nml_name)//\" not found in namelist.input.\")\n") ;
+  fprintf(fp,"     CALL wrf_debug(1,\" --> Using registry defaults for variables in \"//TRIM(nml_name))\n") ;
   fprintf(fp," END DO NML_LOOP\n") ;
   fprintf(fp," \n") ;
   fprintf(fp," IF ( nml_read_error ) CALL wrf_error_fatal(\"ERRORS while reading one or more namelists from namelist.input.\")\n") ;
diff --git a/wrfv2_fire/tools/gen_interp.c b/wrfv2_fire/tools/gen_interp.c
index 900590b9..d5abc83e 100644
--- a/wrfv2_fire/tools/gen_interp.c
+++ b/wrfv2_fire/tools/gen_interp.c
@@ -265,8 +265,8 @@ if ( ! contains_tok ( halo_define , vname  , ":," ) ) {
             }
             fprintf(fp,"IF ( SIZE( %s%s, %d ) * SIZE( %s%s, %d ) .GT. 1", p->name,tag,xdex+1,p->name,tag,ydex+1 ) ;
         } else {
-          if ( !strcmp( fcn_name, "interp_mask_land_field" ) ||
-              !strcmp( fcn_name, "interp_mask_water_field" ) ) {
+          if ( !strcmp( fcn_name, "interp_mask_land_field" ) || !strcmp( fcn_name, "interp_mask_water_field" ) || 
+               !strcmp( fcn_name, "interp_mask_field")       || !strcmp( fcn_name, "interp_mask_soil") ) {
             fprintf(fp,"IF ( .TRUE.") ;
           } else {
             fprintf(fp,"IF ( SIZE( %s%s, %d ) * SIZE( %s%s, %d ) .GT. 1", grid,vname2,xdex+1,grid,vname2,ydex+1 ) ;
@@ -291,7 +291,8 @@ if ( ! contains_tok ( halo_define , vname  , ":," ) ) {
 #endif
 fprintf(fp,"CALL %s (  &         \n", fcn_name ) ;
 
-if ( !strcmp( fcn_name, "interp_mask_land_field" ) || !strcmp( fcn_name, "interp_mask_water_field" ) ) {
+if ( !strcmp( fcn_name, "interp_mask_land_field" ) || !strcmp( fcn_name, "interp_mask_water_field" ) ||
+     !strcmp( fcn_name, "interp_mask_field")       || !strcmp( fcn_name, "interp_mask_soil") ) {
 fprintf(fp,"  ( SIZE( %s%s , %d )*SIZE( %s%s , %d ) .GT. 1 ), & ! special argument needed because %s has bcasts in it\n",
                                                        grid,vname2,xdex+1,grid,vname2,ydex+1,fcn_name) ;
 }

From aaa0a37624ac6e8f38b3261ca4cd69e68f014676 Mon Sep 17 00:00:00 2001
From: Jan Mandel 
Date: Sat, 23 Apr 2016 22:18:13 -0600
Subject: [PATCH 02/15] WRFV3.7

---
 wrfv2_fire/Makefile                           |   339 +-
 wrfv2_fire/README                             |    56 +-
 wrfv2_fire/README.DA                          |    59 +-
 wrfv2_fire/README.SSIB                        |    26 +-
 wrfv2_fire/README_test_cases                  |     6 +
 wrfv2_fire/Registry/Registry.CONVERT          |     4 +-
 wrfv2_fire/Registry/Registry.EM               |    17 +-
 wrfv2_fire/Registry/Registry.EM_CHEM          |     3 +-
 wrfv2_fire/Registry/Registry.EM_COMMON        |   596 +-
 wrfv2_fire/Registry/Registry.EM_COMMON.var    |     5 +-
 wrfv2_fire/Registry/Registry.NMM              |  1202 +-
 wrfv2_fire/Registry/Registry.NMM_HWRF         |  1873 --
 wrfv2_fire/Registry/Registry.NMM_NEST         |  1756 --
 wrfv2_fire/Registry/registry.afwa             |   114 +
 wrfv2_fire/Registry/registry.bdy_perturb      |    13 +-
 wrfv2_fire/Registry/registry.cam              |     1 -
 wrfv2_fire/Registry/registry.chem             |  1456 +-
 wrfv2_fire/Registry/registry.diags            |     4 +-
 wrfv2_fire/Registry/registry.dimspec          |     5 +
 wrfv2_fire/Registry/registry.lake             |    44 +-
 wrfv2_fire/Registry/registry.sbm              |   532 +-
 wrfv2_fire/Registry/registry.stoch            |   124 +-
 wrfv2_fire/Registry/registry.tornado          |    46 +
 wrfv2_fire/Registry/registry.tracker          |   146 +
 wrfv2_fire/Registry/registry.var              |    28 +-
 wrfv2_fire/arch/Config_new.pl                 |   116 +-
 wrfv2_fire/arch/configure_new.defaults        |   429 +-
 wrfv2_fire/arch/md_calls.inc                  |   432 +-
 wrfv2_fire/arch/postamble_new                 |     3 +-
 ...ra_args_to_update_rconst_cb05_sorg_aq.inc} |     0
 ...extra_args_update_rconst_cb05_sorg_aq.inc} |     0
 ...xtra_decls_update_rconst_cb05_sorg_aq.inc} |     0
 .../kpp_mechd_a_cb05_sorg_aq.inc}             |     0
 .../kpp_mechd_b_cb05_sorg_aq.inc}             |     0
 .../kpp_mechd_e_cb05_sorg_aq.inc}             |     0
 .../kpp_mechd_ia_cb05_sorg_aq.inc             |    49 +
 .../kpp_mechd_ib_cb05_sorg_aq.inc             |     1 +
 .../kpp_mechd_ibu_cb05_sorg_aq.inc            |     1 +
 .../cb05_sorg_aq/kpp_mechd_l_cb05_sorg_aq.inc |    10 +
 .../cb05_sorg_aq/kpp_mechd_u_cb05_sorg_aq.inc |     8 +
 ...args_to_update_rconst_cb05_sorg_vbs_aq.inc |     2 +
 ...ra_args_update_rconst_cb05_sorg_vbs_aq.inc |     2 +
 ...a_decls_update_rconst_cb05_sorg_vbs_aq.inc |     2 +
 .../kpp_mechd_a_cb05_sorg_vbs_aq.inc          |     1 +
 .../kpp_mechd_b_cb05_sorg_vbs_aq.inc          |     1 +
 .../kpp_mechd_e_cb05_sorg_vbs_aq.inc          |     1 +
 .../kpp_mechd_ia_cb05_sorg_vbs_aq.inc         |   141 +
 .../kpp_mechd_ib_cb05_sorg_vbs_aq.inc         |     1 +
 .../kpp_mechd_ibu_cb05_sorg_vbs_aq.inc        |   116 +
 .../kpp_mechd_l_cb05_sorg_vbs_aq.inc          |    36 +
 .../kpp_mechd_u_cb05_sorg_vbs_aq.inc          |    26 +
 ...s_to_update_rconst_mozart_mosaic_4bin.inc} |     0
 ...args_update_rconst_mozart_mosaic_4bin.inc} |     0
 ...ecls_update_rconst_mozart_mosaic_4bin.inc} |     0
 .../kpp_mechd_a_mozart_mosaic_4bin.inc        |     1 +
 .../kpp_mechd_b_mozart_mosaic_4bin.inc        |     1 +
 .../kpp_mechd_e_mozart_mosaic_4bin.inc        |     1 +
 .../kpp_mechd_ia_mozart_mosaic_4bin.inc       |     1 +
 .../kpp_mechd_ib_mozart_mosaic_4bin.inc       |     1 +
 .../kpp_mechd_ibu_mozart_mosaic_4bin.inc}     |     0
 .../kpp_mechd_l_mozart_mosaic_4bin.inc}       |     0
 .../kpp_mechd_u_mozart_mosaic_4bin.inc        |     1 +
 ...to_update_rconst_mozart_mosaic_4bin_aq.inc |     5 +
 ...gs_update_rconst_mozart_mosaic_4bin_aq.inc |     4 +
 ...ls_update_rconst_mozart_mosaic_4bin_aq.inc |    10 +
 .../kpp_mechd_a_mozart_mosaic_4bin_aq.inc     |     1 +
 .../kpp_mechd_b_mozart_mosaic_4bin_aq.inc     |     1 +
 .../kpp_mechd_e_mozart_mosaic_4bin_aq.inc     |     1 +
 .../kpp_mechd_ia_mozart_mosaic_4bin_aq.inc    |     1 +
 .../kpp_mechd_ib_mozart_mosaic_4bin_aq.inc    |     1 +
 .../kpp_mechd_ibu_mozart_mosaic_4bin_aq.inc   |    11 +
 .../kpp_mechd_l_mozart_mosaic_4bin_aq.inc     |     2 +
 .../kpp_mechd_u_mozart_mosaic_4bin_aq.inc     |     1 +
 .../atoms_red                                 |     0
 .../mechanisms/cb05_sorg_aq/cb05_sorg_aq.def  |    22 +
 .../mechanisms/cb05_sorg_aq/cb05_sorg_aq.eqn  |   370 +
 .../cb05_sorg_aq.kpp}                         |     3 +-
 .../mechanisms/cb05_sorg_aq/cb05_sorg_aq.spc  |   101 +
 .../cb05_sorg_aq/cb05_sorg_aq_wrfkpp.equiv    |     8 +
 .../KPP/mechanisms/cb05_sorg_vbs_aq/atoms_red |   107 +
 .../cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.def     |    22 +
 .../cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.eqn     |   382 +
 .../cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.kpp     |    12 +
 .../cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.spc     |   109 +
 .../cb05_sorg_vbs_aq_wrfkpp.equiv             |     8 +
 .../chem/KPP/mechanisms/mozart/mozart.eqn     |     4 +-
 .../mechanisms/mozart_mosaic_4bin/atoms_red   |   107 +
 .../mozart_mosaic_4bin.def}                   |     4 +-
 .../mozart_mosaic_4bin/mozart_mosaic_4bin.eqn |   372 +
 .../mozart_mosaic_4bin/mozart_mosaic_4bin.kpp |    11 +
 .../mozart_mosaic_4bin.spc}                   |    63 +-
 .../mozart_mosaic_4bin_wrfkpp.equiv}          |     5 +
 .../mozart_mosaic_4bin_aq/atoms_red           |   107 +
 .../mozart_mosaic_4bin_aq.def                 |   250 +
 .../mozart_mosaic_4bin_aq.eqn                 |   426 +
 .../mozart_mosaic_4bin_aq.kpp                 |    11 +
 .../mozart_mosaic_4bin_aq.spc                 |   158 +
 .../mozart_mosaic_4bin_aq_wrfkpp.equiv        |    40 +
 .../mozart_mosaic_4bin_vbs0.eqn               |   203 -
 .../chem/KPP/mechanisms/mozcart/mozcart.eqn   |     4 +-
 .../chem/KPP/util/wkc/change_chem_Makefile.c  |     2 +-
 .../KPP/util/wkc/compare_kpp_to_species.c     |     4 +-
 .../chem/KPP/util/write_decomp/Makefile       |     2 +-
 wrfv2_fire/chem/Makefile                      |    49 +-
 wrfv2_fire/chem/aerorate_so2.F                |   118 +
 wrfv2_fire/chem/aerosol_driver.F              |   218 +-
 wrfv2_fire/chem/chem_driver.F                 |   314 +-
 wrfv2_fire/chem/chemics_init.F                |   925 +-
 wrfv2_fire/chem/cloudchem_driver.F            |    22 +-
 wrfv2_fire/chem/convert_emiss.F               |    37 +-
 wrfv2_fire/chem/depend.chem                   |    79 +-
 wrfv2_fire/chem/dry_dep_driver.F              |   671 +-
 wrfv2_fire/chem/emissions_driver.F            |   227 +-
 wrfv2_fire/chem/isocom.F                      |  4918 ++++
 wrfv2_fire/chem/isofwd.F                      |  6745 +++++
 wrfv2_fire/chem/isorev.F                      |  3604 +++
 wrfv2_fire/chem/mechanism_driver.F            |    29 +-
 wrfv2_fire/chem/moduleAERODATA.F              |    41 +
 wrfv2_fire/chem/moduleHETAERO.F               |    30 +
 wrfv2_fire/chem/moduleHETDATA.F               |    18 +
 wrfv2_fire/chem/module_add_emiss_burn.F       |    14 +-
 wrfv2_fire/chem/module_aerosols_sorgam.F      |   240 +-
 wrfv2_fire/chem/module_aerosols_sorgam_vbs.F  |  8376 ++++++
 wrfv2_fire/chem/module_bioemi_megan2.F        |   408 +-
 wrfv2_fire/chem/module_bioemi_simple.F        |    74 +-
 wrfv2_fire/chem/module_cb05_addemiss.F        |   307 +
 wrfv2_fire/chem/module_cb05_initmixrats.F     |   803 +
 wrfv2_fire/chem/module_cb05_vbs_initmixrats.F |   836 +
 wrfv2_fire/chem/module_chem_cup.F             |  3551 +++
 wrfv2_fire/chem/module_ctrans_aqchem.F        |    76 +-
 wrfv2_fire/chem/module_ctrans_grell.F         |   592 +-
 wrfv2_fire/chem/module_data_ISRPIA.F          |   181 +
 wrfv2_fire/chem/module_data_isrpia.F          | 13791 ----------
 wrfv2_fire/chem/module_data_isrpia_asrc.F     |    70 +
 wrfv2_fire/chem/module_data_isrpia_caseg.F    |     7 +
 wrfv2_fire/chem/module_data_isrpia_casej.F    |     6 +
 wrfv2_fire/chem/module_data_isrpia_data.F     |   366 +
 wrfv2_fire/chem/module_data_isrpia_expnc.F    |    58 +
 wrfv2_fire/chem/module_data_isrpia_kmc198.F   |  2191 ++
 wrfv2_fire/chem/module_data_isrpia_kmc223.F   |  2190 ++
 wrfv2_fire/chem/module_data_isrpia_kmc248.F   |  2193 ++
 wrfv2_fire/chem/module_data_isrpia_kmc273.F   |  2193 ++
 wrfv2_fire/chem/module_data_isrpia_kmc298.F   |  2193 ++
 wrfv2_fire/chem/module_data_isrpia_kmc323.F   |  2195 ++
 wrfv2_fire/chem/module_data_isrpia_solut.F    |     8 +
 wrfv2_fire/chem/module_data_mgn2mech.F        |   531 +
 wrfv2_fire/chem/module_data_mosaic_asect.F    |   287 +-
 wrfv2_fire/chem/module_data_mosaic_other.F    |    13 +-
 wrfv2_fire/chem/module_data_mosaic_therm.F    |    45 +-
 wrfv2_fire/chem/module_data_sorgam_vbs.F      |  1098 +
 wrfv2_fire/chem/module_dep_simple.F           |   632 +-
 .../chem/module_emissions_anthropogenics.F    |    29 +-
 wrfv2_fire/chem/module_ftuv_driver.F          |    76 +-
 wrfv2_fire/chem/module_ftuv_subs.F            |    55 +-
 wrfv2_fire/chem/module_ghg_fluxes.F           |    13 +-
 wrfv2_fire/chem/module_gocart_chem.F          |     2 +-
 wrfv2_fire/chem/module_gocart_dust_afwa.F     |   631 +-
 wrfv2_fire/chem/module_input_chem_data.F      |   281 +-
 wrfv2_fire/chem/module_input_tracer.F         |    18 +-
 .../chem/module_lightning_nox_decaria.F       |    82 +-
 wrfv2_fire/chem/module_mixactivate_wrappers.F |   146 +-
 wrfv2_fire/chem/module_mosaic_addemiss.F      |    86 +-
 wrfv2_fire/chem/module_mosaic_cloudchem.F     |    30 +-
 wrfv2_fire/chem/module_mosaic_driver.F        |  3322 ++-
 wrfv2_fire/chem/module_mosaic_gly.F           |   480 +
 wrfv2_fire/chem/module_mosaic_therm.F         |   609 +-
 wrfv2_fire/chem/module_mosaic_wetscav.F       |    76 +
 wrfv2_fire/chem/module_mozcart_wetscav.F      |    51 +-
 wrfv2_fire/chem/module_optical_averaging.F    |   743 +-
 wrfv2_fire/chem/module_phot_fastj.F           |     6 +-
 wrfv2_fire/chem/module_plumerise1.F           |    10 +-
 wrfv2_fire/chem/module_sorgam_aqchem.F        |    84 +-
 wrfv2_fire/chem/module_sorgam_cloudchem.F     |   197 +-
 wrfv2_fire/chem/module_sorgam_vbs_aqchem.F    |   500 +
 wrfv2_fire/chem/module_sorgam_vbs_cloudchem.F |  2206 ++
 wrfv2_fire/chem/module_uoc_dust.F             |     2 +-
 wrfv2_fire/chem/module_wave_data.F            |   146 +-
 wrfv2_fire/chem/module_wetscav_driver.F       |   309 +-
 wrfv2_fire/chem/optical_driver.F              |    25 +-
 wrfv2_fire/chem/photolysis_driver.F           |     5 +-
 wrfv2_fire/compile                            |    68 +-
 wrfv2_fire/configure                          |    89 +-
 wrfv2_fire/configure.nc4                      |   932 -
 wrfv2_fire/dyn_em/depend.dyn_em               |    15 +-
 wrfv2_fire/dyn_em/module_after_all_rk_steps.F |    17 +
 wrfv2_fire/dyn_em/module_bc_em.F              |   289 +-
 .../dyn_em/module_big_step_utilities_em.F     |   148 +-
 wrfv2_fire/dyn_em/module_diffusion_em.F       |    43 +-
 wrfv2_fire/dyn_em/module_em.F                 |   154 +-
 .../dyn_em/module_first_rk_step_part1.F       |   202 +-
 .../dyn_em/module_first_rk_step_part2.F       |   324 +-
 wrfv2_fire/dyn_em/module_initialize_convrad.F |   810 +
 wrfv2_fire/dyn_em/module_initialize_les.F     |    11 +-
 .../dyn_em/module_initialize_quarter_ss.F     |     6 +
 wrfv2_fire/dyn_em/module_initialize_real.F    |   992 +-
 .../dyn_em/module_initialize_seabreeze2d_x.F  |     6 +
 wrfv2_fire/dyn_em/module_polarfft.F           |   475 +-
 wrfv2_fire/dyn_em/module_small_step_em.F      |     4 +-
 wrfv2_fire/dyn_em/module_stoch.F              |  1499 +-
 wrfv2_fire/dyn_em/module_wps_io_arw.F         |     3 +-
 wrfv2_fire/dyn_em/nest_init_utils.F           |   182 +
 wrfv2_fire/dyn_em/solve_em.F                  |   521 +-
 wrfv2_fire/dyn_em/start_em.F                  |   575 +-
 wrfv2_fire/dyn_nmm/Makefile                   |     3 +
 wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F          |    58 +-
 wrfv2_fire/dyn_nmm/depend.dyn_nmm             |    18 +-
 wrfv2_fire/dyn_nmm/module_ADVECTION.F         |    79 +-
 wrfv2_fire/dyn_nmm/module_BNDRY_COND.F        |    88 -
 wrfv2_fire/dyn_nmm/module_GWD.F               |    18 +-
 wrfv2_fire/dyn_nmm/module_HIFREQ.F            |    37 +-
 wrfv2_fire/dyn_nmm/module_NEST_UTIL.F         |    83 +-
 wrfv2_fire/dyn_nmm/module_NONHY_DYNAM.F       |     5 +
 wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F     |   123 +-
 wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F    |    86 +-
 wrfv2_fire/dyn_nmm/module_initialize_real.F   |   893 +-
 .../module_initialize_tropical_cyclone.F      |     7 +-
 wrfv2_fire/dyn_nmm/module_membrane_mslp.F     |   120 +-
 wrfv2_fire/dyn_nmm/module_swath.F             |   261 +
 wrfv2_fire/dyn_nmm/module_tornado_genesis.F   |   465 +
 wrfv2_fire/dyn_nmm/module_tracker.F           |  1057 +-
 wrfv2_fire/dyn_nmm/nmm_get_cpu.c              |    20 +
 wrfv2_fire/dyn_nmm/solve_nmm.F                |   938 +-
 wrfv2_fire/dyn_nmm/start_domain_nmm.F         |   201 +-
 wrfv2_fire/external/Makefile                  |     1 +
 wrfv2_fire/external/RSL_LITE/gen_comms.c      |    40 +-
 wrfv2_fire/external/RSL_LITE/module_dm.F      |   328 +-
 wrfv2_fire/external/RSL_LITE/rsl_lite.h       |     2 +-
 wrfv2_fire/external/RSL_LITE/rsl_malloc.c     |    12 +-
 wrfv2_fire/external/atm_ocn/Makefile          |     2 +-
 wrfv2_fire/external/atm_ocn/atm_comm.F        |    38 +-
 wrfv2_fire/external/atm_ocn/cmpcomm.F         |     2 +-
 wrfv2_fire/external/esmf_time_f90/Makefile    |     8 +-
 wrfv2_fire/external/io_grib1/io_grib1.F       |   148 +-
 wrfv2_fire/external/io_int/makefile           |     2 +-
 wrfv2_fire/external/io_netcdf/makefile        |     2 +-
 wrfv2_fire/external/io_netcdf/wrf_io.F90      |    44 +-
 wrfv2_fire/external/io_pio/Makefile           |    70 +
 wrfv2_fire/external/io_pio/field_routines.F90 |   190 +
 .../external/io_pio/module_wrfsi_static.F90   |   102 +
 wrfv2_fire/external/io_pio/pio_routines.F90   |  2145 ++
 .../external/io_pio/read_bdy_routines.F90     |   186 +
 wrfv2_fire/external/io_pio/wrf_data_pio.F90   |   136 +
 wrfv2_fire/external/io_pio/wrf_io.F90         |  9163 +++++++
 .../io_pnetcdf/{makefile => Makefile}         |    14 +-
 wrfv2_fire/external/io_pnetcdf/wrf_io.F90     |    11 +-
 wrfv2_fire/frame/Makefile                     |     3 +-
 wrfv2_fire/frame/hires_timer.c                |     5 +-
 wrfv2_fire/frame/md_calls.m4                  |    23 +-
 wrfv2_fire/frame/module_clear_halos.F         |   396 +
 wrfv2_fire/frame/module_driver_constants.F    |     9 +-
 wrfv2_fire/frame/module_io.F                  |   432 +-
 wrfv2_fire/frame/module_io_quilt.F            |    24 +-
 wrfv2_fire/frame/module_quilt_outbuf_ops.F    |     8 +-
 wrfv2_fire/frame/module_timing.F              |    16 +
 wrfv2_fire/frame/module_wrf_error.F           |    43 +-
 wrfv2_fire/hydro/.svn/all-wcprops             |    17 +
 wrfv2_fire/hydro/.svn/entries                 |   117 +
 .../hydro/.svn/prop-base/configure.svn-base   |     5 +
 .../.svn/prop-base/wrf_hydro_config.svn-base  |     5 +
 .../hydro/.svn/text-base/configure.svn-base   |   107 +
 .../.svn/text-base/wrf_hydro_config.svn-base  |    28 +
 wrfv2_fire/hydro/CPL/.svn/all-wcprops         |     5 +
 wrfv2_fire/hydro/CPL/.svn/entries             |    31 +
 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/all-wcprops |    29 +
 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/entries     |   164 +
 .../.svn/text-base/Makefile.cpl.svn-base      |     9 +
 .../WRF_cpl/.svn/text-base/Makefile.svn-base  |    34 +
 .../text-base/module_wrf_HYDRO.F.svn-base     |   341 +
 .../.svn/text-base/wrf_drv_HYDRO.F.svn-base   |    31 +
 .../hydro/CPL/WRF_cpl/module_wrf_HYDRO.F      |    30 +-
 wrfv2_fire/hydro/Data_Rec/.svn/all-wcprops    |    47 +
 wrfv2_fire/hydro/Data_Rec/.svn/entries        |   266 +
 .../Data_Rec/.svn/text-base/Makefile.svn-base |    28 +
 .../text-base/gw_field_include.inc.svn-base   |    26 +
 .../module_GW_baseflow_data.F.svn-base        |     9 +
 .../.svn/text-base/module_RT_data.F.svn-base  |    10 +
 .../.svn/text-base/module_namelist.F.svn-base |   203 +
 .../.svn/text-base/namelist.inc.svn-base      |    39 +
 .../.svn/text-base/rt_include.inc.svn-base    |   178 +
 wrfv2_fire/hydro/Data_Rec/module_RT_data.F    |     2 +-
 wrfv2_fire/hydro/Data_Rec/module_namelist.F   |     3 +-
 wrfv2_fire/hydro/Data_Rec/namelist.inc        |     3 +-
 wrfv2_fire/hydro/Data_Rec/rt_include.inc      |    21 +-
 wrfv2_fire/hydro/HYDRO_drv/.svn/all-wcprops   |    17 +
 wrfv2_fire/hydro/HYDRO_drv/.svn/entries       |    96 +
 .../.svn/text-base/Makefile.svn-base          |    28 +
 .../text-base/module_HYDRO_drv.F.svn-base     |  1071 +
 wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F |   915 +-
 wrfv2_fire/hydro/MPP/.svn/all-wcprops         |    23 +
 wrfv2_fire/hydro/MPP/.svn/entries             |   130 +
 .../MPP/.svn/text-base/CPL_WRF.F.svn-base     |   159 +
 .../MPP/.svn/text-base/Makefile.svn-base      |    26 +
 .../MPP/.svn/text-base/mpp_land.F.svn-base    |  1876 ++
 wrfv2_fire/hydro/MPP/mpp_land.F               |   501 +-
 wrfv2_fire/hydro/Routing/.svn/all-wcprops     |    71 +
 wrfv2_fire/hydro/Routing/.svn/entries         |   402 +
 .../Routing/.svn/text-base/Makefile.svn-base  |    53 +
 .../text-base/Noah_distr_routing.F.svn-base   |  2768 ++
 .../text-base/module_GW_baseflow.F.svn-base   |   856 +
 .../.svn/text-base/module_HYDRO_io.F.svn-base |  6340 +++++
 .../text-base/module_HYDRO_utils.F.svn-base   |   414 +
 .../.svn/text-base/module_RT.F.svn-base       |   927 +
 .../module_channel_routing.F.svn-base         |  1329 +
 .../module_date_utilities_rt.F.svn-base       |  1040 +
 .../text-base/module_lsm_forcing.F.svn-base   |  2276 ++
 .../module_noah_chan_param_init_rt.F.svn-base |    87 +
 .../.svn/text-base/rtFunction.F.svn-base      |   222 +
 wrfv2_fire/hydro/Routing/Makefile             |     3 +-
 wrfv2_fire/hydro/Routing/Noah_distr_routing.F |  1956 +-
 wrfv2_fire/hydro/Routing/module_GW_baseflow.F |   121 +-
 wrfv2_fire/hydro/Routing/module_HYDRO_io.F    |  2272 +-
 wrfv2_fire/hydro/Routing/module_RT.F          |   159 +-
 .../hydro/Routing/module_channel_routing.F    |   289 +-
 .../hydro/Routing/module_date_utilities_rt.F  |    28 +-
 wrfv2_fire/hydro/Routing/module_lsm_forcing.F |   807 +-
 wrfv2_fire/hydro/Run/.svn/all-wcprops         |    17 +
 wrfv2_fire/hydro/Run/.svn/entries             |    96 +
 .../Run/.svn/text-base/HYDRO.TBL.svn-base     |    51 +
 .../.svn/text-base/hydro.namelist.svn-base    |   105 +
 wrfv2_fire/hydro/Run/HYDRO.TBL                |     5 +-
 wrfv2_fire/hydro/Run/hydro.namelist           |    35 +-
 wrfv2_fire/hydro/arc/.svn/all-wcprops         |    65 +
 wrfv2_fire/hydro/arc/.svn/entries             |   368 +
 .../arc/.svn/text-base/Makefile.mpp.svn-base  |    17 +
 .../arc/.svn/text-base/Makefile.seq.svn-base  |    30 +
 .../text-base/macros.mpp.IBM.xlf90_r.svn-base |    37 +
 .../.svn/text-base/macros.mpp.gfort.svn-base  |    33 +
 .../.svn/text-base/macros.mpp.ifort.svn-base  |    36 +
 .../.svn/text-base/macros.mpp.linux.svn-base  |    35 +
 .../text-base/macros.seq.IBM.xlf90_r.svn-base |    36 +
 .../.svn/text-base/macros.seq.gfort.svn-base  |    34 +
 .../.svn/text-base/macros.seq.ifort.svn-base  |    36 +
 .../.svn/text-base/macros.seq.linux.svn-base  |    36 +
 wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r   |     4 +
 wrfv2_fire/hydro/arc/macros.mpp.gfort         |    10 +-
 wrfv2_fire/hydro/arc/macros.mpp.ifort         |     4 +
 wrfv2_fire/hydro/arc/macros.mpp.linux         |     6 +-
 wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r   |     4 +
 wrfv2_fire/hydro/arc/macros.seq.gfort         |     8 +-
 wrfv2_fire/hydro/arc/macros.seq.ifort         |     4 +
 wrfv2_fire/hydro/arc/macros.seq.linux         |     6 +-
 wrfv2_fire/hydro/configure                    |     8 +-
 wrfv2_fire/inc/version_decl                   |     2 +-
 wrfv2_fire/main/Makefile                      |     2 +-
 wrfv2_fire/main/convert_em.F                  |     4 +-
 wrfv2_fire/main/depend.common                 |    87 +-
 wrfv2_fire/main/ideal_em.F                    |     7 +-
 wrfv2_fire/main/ideal_nmm.F                   |    12 +-
 wrfv2_fire/main/module_wrf_top.F              |     2 +-
 wrfv2_fire/main/ndown_em.F                    |    24 +-
 wrfv2_fire/main/nup_em.F                      |     6 +-
 wrfv2_fire/main/real_em.F                     |    29 +-
 wrfv2_fire/main/real_nmm.F                    |    10 +-
 wrfv2_fire/phys/Makefile                      |    10 +-
 wrfv2_fire/phys/module_bl_acm.F               |   445 +-
 wrfv2_fire/phys/module_bl_gfs.F               |   156 +-
 wrfv2_fire/phys/module_bl_gwdo.F              |  1030 +-
 wrfv2_fire/phys/module_bl_qnsepbl09.F         |  1345 -
 wrfv2_fire/phys/module_bl_shinhong.F          |  2458 ++
 wrfv2_fire/phys/module_bl_ysu.F               |   153 +-
 wrfv2_fire/phys/module_cam_mp_microp_aero.F   |     2 +-
 wrfv2_fire/phys/module_cam_mp_ndrop.F         |     1 -
 wrfv2_fire/phys/module_cam_support.F          |     2 +-
 wrfv2_fire/phys/module_cu_camzm.F             |    16 +-
 wrfv2_fire/phys/module_cu_camzm_driver.F      |    12 +-
 wrfv2_fire/phys/module_cu_kfcup.F             |  5544 ++++
 wrfv2_fire/phys/module_cu_kfeta.F             |    14 +-
 wrfv2_fire/phys/module_cu_mskf.F              |  3336 +++
 wrfv2_fire/phys/module_cu_ntiedtke.F          |  3719 +++
 wrfv2_fire/phys/module_cu_sas.F               |    82 +
 wrfv2_fire/phys/module_cu_tiedtke.F           |  5510 ++--
 wrfv2_fire/phys/module_cumulus_driver.F       |   321 +-
 wrfv2_fire/phys/module_data_cam_mam_aero.F    |     2 +-
 wrfv2_fire/phys/module_data_gocart_dust.F     |    12 +-
 wrfv2_fire/phys/module_diag_afwa.F            |  5457 ++--
 wrfv2_fire/phys/module_diag_afwa_hail.F       |   852 +
 wrfv2_fire/phys/module_diag_cl.F              |   168 +-
 wrfv2_fire/phys/module_diag_misc.F            |   512 +-
 wrfv2_fire/phys/module_diag_pld.F             |   143 +-
 wrfv2_fire/phys/module_diagnostics_driver.F   |   457 +-
 wrfv2_fire/phys/module_fdda_spnudging.F       |    13 +-
 wrfv2_fire/phys/module_lightning_driver.F     |    59 +-
 wrfv2_fire/phys/module_ltng_lpi.F             |   180 +
 wrfv2_fire/phys/module_microphysics_driver.F  |   313 +-
 wrfv2_fire/phys/module_mixactivate.F          |   136 +-
 wrfv2_fire/phys/module_mp_cammgmp_driver.F    |    36 +-
 wrfv2_fire/phys/module_mp_etanew.F            |    18 +-
 wrfv2_fire/phys/module_mp_etaold.F            |  2623 --
 wrfv2_fire/phys/module_mp_fast_sbm.F          |    44 +-
 wrfv2_fire/phys/module_mp_full_sbm.F          |    33 +-
 wrfv2_fire/phys/module_mp_gsfcgce.F           |     2 +-
 wrfv2_fire/phys/module_mp_milbrandt2mom.F     |  1187 +-
 wrfv2_fire/phys/module_mp_morr_two_moment.F   |    81 +-
 wrfv2_fire/phys/module_mp_nssl_2mom.F         | 22347 ++++++++--------
 wrfv2_fire/phys/module_mp_thompson.F          |   430 +-
 wrfv2_fire/phys/module_mp_wdm5.F              |   151 +
 wrfv2_fire/phys/module_mp_wdm6.F              |   197 +-
 wrfv2_fire/phys/module_mp_wsm3.F              |   160 +-
 wrfv2_fire/phys/module_mp_wsm5.F              |   152 +-
 wrfv2_fire/phys/module_mp_wsm6.F              |   184 +-
 wrfv2_fire/phys/module_pbl_driver.F           |   123 +-
 wrfv2_fire/phys/module_physics_addtendc.F     |    82 +-
 wrfv2_fire/phys/module_physics_init.F         |   318 +-
 wrfv2_fire/phys/module_ra_aerosol.F           |    18 +-
 wrfv2_fire/phys/module_ra_cam.F               |    95 +-
 wrfv2_fire/phys/module_ra_flg.F               |    75 +-
 wrfv2_fire/phys/module_ra_gsfcsw.F            |    54 +-
 wrfv2_fire/phys/module_ra_rrtm.F              |    30 +-
 wrfv2_fire/phys/module_ra_rrtmg_lw.F          |   130 +-
 wrfv2_fire/phys/module_ra_rrtmg_lwf.F         | 18180 +++++++++++++
 wrfv2_fire/phys/module_ra_rrtmg_sw.F          |  1142 +-
 wrfv2_fire/phys/module_ra_rrtmg_swf.F         | 13730 ++++++++++
 wrfv2_fire/phys/module_radiation_driver.F     |   910 +-
 wrfv2_fire/phys/module_sf_clm.F               |    76 +-
 wrfv2_fire/phys/module_sf_gfdl.F              |    12 +-
 wrfv2_fire/phys/module_sf_lake.F              |     3 +-
 wrfv2_fire/phys/module_sf_mynn.F              |    20 +-
 wrfv2_fire/phys/module_sf_noahdrv.F           |   458 +-
 wrfv2_fire/phys/module_sf_noahlsm.F           |    26 +-
 wrfv2_fire/phys/module_sf_noahmp_glacier.F    |    36 +-
 .../phys/module_sf_noahmp_groundwater.F       |    15 +-
 wrfv2_fire/phys/module_sf_noahmpdrv.F         |   450 +-
 wrfv2_fire/phys/module_sf_noahmplsm.F         |  3653 ++-
 wrfv2_fire/phys/module_sf_oml.F               |     2 +-
 wrfv2_fire/phys/module_sf_pxlsm.F             |   546 +-
 wrfv2_fire/phys/module_sf_pxlsm_data.F        |   495 +-
 wrfv2_fire/phys/module_sf_ruclsm.F            |  2071 +-
 wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F   |   109 +-
 wrfv2_fire/phys/module_sf_sfclay.F            |    64 +-
 wrfv2_fire/phys/module_sf_sfclayrev.F         |   226 +-
 wrfv2_fire/phys/module_sf_ssib.F              |    48 +-
 wrfv2_fire/phys/module_sf_urban.F             |  1266 +-
 wrfv2_fire/phys/module_shallowcu_driver.F     |    10 +-
 .../phys/module_shcu_camuwshcu_driver.F       |    18 +-
 wrfv2_fire/phys/module_surface_driver.F       |   222 +-
 wrfv2_fire/phys/rrtmg_lw_cpu_args.h           |     7 +
 wrfv2_fire/phys/rrtmg_lw_cpu_defs.h           |    58 +
 wrfv2_fire/phys/taug_cpu_args.h               |     9 +
 wrfv2_fire/phys/taug_cpu_defs.h               |    50 +
 wrfv2_fire/run/MPTABLE.TBL                    |   206 +-
 wrfv2_fire/run/README.namelist                |   145 +-
 wrfv2_fire/run/SOILPARM.TBL                   |    28 +-
 wrfv2_fire/run/URBPARM.TBL                    |    92 +-
 wrfv2_fire/run/VEGPARM.TBL                    |    20 +-
 wrfv2_fire/share/dfi.F                        |   101 +-
 wrfv2_fire/share/input_wrf.F                  |   380 +-
 wrfv2_fire/share/interp_fcn.F                 |  7813 +++---
 wrfv2_fire/share/landread.c                   |    18 +-
 wrfv2_fire/share/mediation_feedback_domain.F  |    77 +
 wrfv2_fire/share/mediation_force_domain.F     |    24 +-
 wrfv2_fire/share/mediation_integrate.F        |    47 +-
 wrfv2_fire/share/mediation_interp_domain.F    |    22 +-
 wrfv2_fire/share/mediation_nest_move.F        |    76 +-
 wrfv2_fire/share/module_bc.F                  |   316 +-
 wrfv2_fire/share/module_check_a_mundo.F       |   451 +-
 wrfv2_fire/share/module_date_time.F           |    30 +-
 wrfv2_fire/share/module_get_file_names.F      |     4 +
 wrfv2_fire/share/module_interp_nmm.F          |  1083 +-
 wrfv2_fire/share/module_interp_store.F        |    16 +-
 wrfv2_fire/share/module_io_domain.F           |    21 +-
 wrfv2_fire/share/module_model_constants.F     |     3 +-
 wrfv2_fire/share/module_optional_input.F      |   183 +-
 wrfv2_fire/share/module_soil_pre.F            |     4 +-
 wrfv2_fire/share/output_wrf.F                 |   232 +-
 wrfv2_fire/share/set_timekeeping.F            |     6 +-
 wrfv2_fire/share/solve_interface.F            |     6 +-
 wrfv2_fire/share/track_driver.F               |    26 +-
 wrfv2_fire/share/wrf_ext_read_field.F         |    18 +-
 wrfv2_fire/share/wrf_ext_write_field.F        |    74 +-
 wrfv2_fire/test/em_convrad/README.convrad     |    26 +
 wrfv2_fire/test/em_convrad/input_sounding     |    28 +
 wrfv2_fire/test/em_convrad/namelist.input     |   113 +
 wrfv2_fire/test/em_convrad/run_me_first.csh   |    12 +
 wrfv2_fire/test/em_les/README.les             |    11 +
 .../test/em_les/input_sounding_shalconv       |    42 +
 wrfv2_fire/test/em_les/namelist.input         |     1 +
 .../test/em_les/namelist.input_shalconv       |   121 +
 wrfv2_fire/test/em_real/examples.namelist     |    90 +-
 wrfv2_fire/tools/data.h                       |     2 +-
 wrfv2_fire/tools/fortran_2003_fflush_test.F   |    14 +
 wrfv2_fire/tools/fortran_2003_flush_test.F    |    14 +
 wrfv2_fire/tools/gen_interp.c                 |   180 +
 wrfv2_fire/tools/gen_wrf_io.c                 |     9 +-
 wrfv2_fire/tools/misc.c                       |    13 +
 wrfv2_fire/tools/protos.h                     |     5 +-
 wrfv2_fire/tools/reg_parse.c                  |    60 +
 wrfv2_fire/tools/registry.c                   |     1 +
 wrfv2_fire/tools/registry.h                   |     2 +-
 488 files changed, 201523 insertions(+), 58160 deletions(-)
 delete mode 100644 wrfv2_fire/Registry/Registry.NMM_HWRF
 delete mode 100644 wrfv2_fire/Registry/Registry.NMM_NEST
 create mode 100644 wrfv2_fire/Registry/registry.afwa
 create mode 100644 wrfv2_fire/Registry/registry.tornado
 create mode 100644 wrfv2_fire/Registry/registry.tracker
 rename wrfv2_fire/chem/KPP/inc/{mozart_mosaic_4bin_vbs0/kpp_mechd_a_mozart_mosaic_4bin_vbs0.inc => cb05_sorg_aq/extra_args_to_update_rconst_cb05_sorg_aq.inc} (100%)
 rename wrfv2_fire/chem/KPP/inc/{mozart_mosaic_4bin_vbs0/kpp_mechd_b_mozart_mosaic_4bin_vbs0.inc => cb05_sorg_aq/extra_args_update_rconst_cb05_sorg_aq.inc} (100%)
 rename wrfv2_fire/chem/KPP/inc/{mozart_mosaic_4bin_vbs0/kpp_mechd_e_mozart_mosaic_4bin_vbs0.inc => cb05_sorg_aq/extra_decls_update_rconst_cb05_sorg_aq.inc} (100%)
 rename wrfv2_fire/chem/KPP/inc/{mozart_mosaic_4bin_vbs0/kpp_mechd_ia_mozart_mosaic_4bin_vbs0.inc => cb05_sorg_aq/kpp_mechd_a_cb05_sorg_aq.inc} (100%)
 rename wrfv2_fire/chem/KPP/inc/{mozart_mosaic_4bin_vbs0/kpp_mechd_ib_mozart_mosaic_4bin_vbs0.inc => cb05_sorg_aq/kpp_mechd_b_cb05_sorg_aq.inc} (100%)
 rename wrfv2_fire/chem/KPP/inc/{mozart_mosaic_4bin_vbs0/kpp_mechd_u_mozart_mosaic_4bin_vbs0.inc => cb05_sorg_aq/kpp_mechd_e_cb05_sorg_aq.inc} (100%)
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ia_cb05_sorg_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ib_cb05_sorg_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ibu_cb05_sorg_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_l_cb05_sorg_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_u_cb05_sorg_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_args_to_update_rconst_cb05_sorg_vbs_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_args_update_rconst_cb05_sorg_vbs_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_decls_update_rconst_cb05_sorg_vbs_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_a_cb05_sorg_vbs_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_b_cb05_sorg_vbs_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_e_cb05_sorg_vbs_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ia_cb05_sorg_vbs_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ib_cb05_sorg_vbs_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ibu_cb05_sorg_vbs_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_l_cb05_sorg_vbs_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_u_cb05_sorg_vbs_aq.inc
 rename wrfv2_fire/chem/KPP/inc/{mozart_mosaic_4bin_vbs0/extra_args_to_update_rconst_mozart_mosaic_4bin_vbs0.inc => mozart_mosaic_4bin/extra_args_to_update_rconst_mozart_mosaic_4bin.inc} (100%)
 rename wrfv2_fire/chem/KPP/inc/{mozart_mosaic_4bin_vbs0/extra_args_update_rconst_mozart_mosaic_4bin_vbs0.inc => mozart_mosaic_4bin/extra_args_update_rconst_mozart_mosaic_4bin.inc} (100%)
 rename wrfv2_fire/chem/KPP/inc/{mozart_mosaic_4bin_vbs0/extra_decls_update_rconst_mozart_mosaic_4bin_vbs0.inc => mozart_mosaic_4bin/extra_decls_update_rconst_mozart_mosaic_4bin.inc} (100%)
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_a_mozart_mosaic_4bin.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_b_mozart_mosaic_4bin.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_e_mozart_mosaic_4bin.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_ia_mozart_mosaic_4bin.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_ib_mozart_mosaic_4bin.inc
 rename wrfv2_fire/chem/KPP/inc/{mozart_mosaic_4bin_vbs0/kpp_mechd_ibu_mozart_mosaic_4bin_vbs0.inc => mozart_mosaic_4bin/kpp_mechd_ibu_mozart_mosaic_4bin.inc} (100%)
 rename wrfv2_fire/chem/KPP/inc/{mozart_mosaic_4bin_vbs0/kpp_mechd_l_mozart_mosaic_4bin_vbs0.inc => mozart_mosaic_4bin/kpp_mechd_l_mozart_mosaic_4bin.inc} (100%)
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_u_mozart_mosaic_4bin.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_args_to_update_rconst_mozart_mosaic_4bin_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_args_update_rconst_mozart_mosaic_4bin_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_decls_update_rconst_mozart_mosaic_4bin_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_a_mozart_mosaic_4bin_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_b_mozart_mosaic_4bin_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_e_mozart_mosaic_4bin_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ia_mozart_mosaic_4bin_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ib_mozart_mosaic_4bin_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ibu_mozart_mosaic_4bin_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_l_mozart_mosaic_4bin_aq.inc
 create mode 100644 wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_u_mozart_mosaic_4bin_aq.inc
 rename wrfv2_fire/chem/KPP/mechanisms/{mozart_mosaic_4bin_vbs0 => cb05_sorg_aq}/atoms_red (100%)
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.def
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.eqn
 rename wrfv2_fire/chem/KPP/mechanisms/{mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.kpp => cb05_sorg_aq/cb05_sorg_aq.kpp} (82%)
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.spc
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq_wrfkpp.equiv
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/atoms_red
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.def
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.eqn
 create mode 100644 wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.kpp
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.spc
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq_wrfkpp.equiv
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/atoms_red
 rename wrfv2_fire/chem/KPP/mechanisms/{mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.def => mozart_mosaic_4bin/mozart_mosaic_4bin.def} (98%)
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.eqn
 create mode 100644 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.kpp
 rename wrfv2_fire/chem/KPP/mechanisms/{mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.spc => mozart_mosaic_4bin/mozart_mosaic_4bin.spc} (53%)
 rename wrfv2_fire/chem/KPP/mechanisms/{mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0_wrfkpp.equiv => mozart_mosaic_4bin/mozart_mosaic_4bin_wrfkpp.equiv} (85%)
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/atoms_red
 create mode 100644 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.def
 create mode 100755 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.eqn
 create mode 100644 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.kpp
 create mode 100644 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.spc
 create mode 100644 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq_wrfkpp.equiv
 delete mode 100755 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.eqn
 create mode 100755 wrfv2_fire/chem/aerorate_so2.F
 create mode 100755 wrfv2_fire/chem/isocom.F
 create mode 100755 wrfv2_fire/chem/isofwd.F
 create mode 100755 wrfv2_fire/chem/isorev.F
 create mode 100755 wrfv2_fire/chem/moduleAERODATA.F
 create mode 100755 wrfv2_fire/chem/moduleHETAERO.F
 create mode 100755 wrfv2_fire/chem/moduleHETDATA.F
 create mode 100644 wrfv2_fire/chem/module_aerosols_sorgam_vbs.F
 create mode 100755 wrfv2_fire/chem/module_cb05_addemiss.F
 create mode 100755 wrfv2_fire/chem/module_cb05_initmixrats.F
 create mode 100755 wrfv2_fire/chem/module_cb05_vbs_initmixrats.F
 create mode 100644 wrfv2_fire/chem/module_chem_cup.F
 create mode 100755 wrfv2_fire/chem/module_data_ISRPIA.F
 delete mode 100644 wrfv2_fire/chem/module_data_isrpia.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_asrc.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_caseg.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_casej.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_data.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_expnc.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_kmc198.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_kmc223.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_kmc248.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_kmc273.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_kmc298.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_kmc323.F
 create mode 100755 wrfv2_fire/chem/module_data_isrpia_solut.F
 create mode 100644 wrfv2_fire/chem/module_data_sorgam_vbs.F
 create mode 100644 wrfv2_fire/chem/module_mosaic_gly.F
 create mode 100644 wrfv2_fire/chem/module_sorgam_vbs_aqchem.F
 create mode 100644 wrfv2_fire/chem/module_sorgam_vbs_cloudchem.F
 delete mode 100755 wrfv2_fire/configure.nc4
 create mode 100644 wrfv2_fire/dyn_em/module_initialize_convrad.F
 create mode 100644 wrfv2_fire/dyn_nmm/module_swath.F
 create mode 100644 wrfv2_fire/dyn_nmm/module_tornado_genesis.F
 create mode 100644 wrfv2_fire/dyn_nmm/nmm_get_cpu.c
 create mode 100644 wrfv2_fire/external/io_pio/Makefile
 create mode 100644 wrfv2_fire/external/io_pio/field_routines.F90
 create mode 100644 wrfv2_fire/external/io_pio/module_wrfsi_static.F90
 create mode 100644 wrfv2_fire/external/io_pio/pio_routines.F90
 create mode 100644 wrfv2_fire/external/io_pio/read_bdy_routines.F90
 create mode 100644 wrfv2_fire/external/io_pio/wrf_data_pio.F90
 create mode 100644 wrfv2_fire/external/io_pio/wrf_io.F90
 rename wrfv2_fire/external/io_pnetcdf/{makefile => Makefile} (73%)
 create mode 100644 wrfv2_fire/frame/module_clear_halos.F
 create mode 100644 wrfv2_fire/hydro/.svn/all-wcprops
 create mode 100644 wrfv2_fire/hydro/.svn/entries
 create mode 100644 wrfv2_fire/hydro/.svn/prop-base/configure.svn-base
 create mode 100644 wrfv2_fire/hydro/.svn/prop-base/wrf_hydro_config.svn-base
 create mode 100644 wrfv2_fire/hydro/.svn/text-base/configure.svn-base
 create mode 100644 wrfv2_fire/hydro/.svn/text-base/wrf_hydro_config.svn-base
 create mode 100644 wrfv2_fire/hydro/CPL/.svn/all-wcprops
 create mode 100644 wrfv2_fire/hydro/CPL/.svn/entries
 create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/all-wcprops
 create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/entries
 create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.cpl.svn-base
 create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.svn-base
 create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/module_wrf_HYDRO.F.svn-base
 create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/wrf_drv_HYDRO.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/all-wcprops
 create mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/entries
 create mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/Makefile.svn-base
 create mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/gw_field_include.inc.svn-base
 create mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_GW_baseflow_data.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_RT_data.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_namelist.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/namelist.inc.svn-base
 create mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/rt_include.inc.svn-base
 create mode 100644 wrfv2_fire/hydro/HYDRO_drv/.svn/all-wcprops
 create mode 100644 wrfv2_fire/hydro/HYDRO_drv/.svn/entries
 create mode 100644 wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/Makefile.svn-base
 create mode 100644 wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/module_HYDRO_drv.F.svn-base
 create mode 100644 wrfv2_fire/hydro/MPP/.svn/all-wcprops
 create mode 100644 wrfv2_fire/hydro/MPP/.svn/entries
 create mode 100644 wrfv2_fire/hydro/MPP/.svn/text-base/CPL_WRF.F.svn-base
 create mode 100644 wrfv2_fire/hydro/MPP/.svn/text-base/Makefile.svn-base
 create mode 100644 wrfv2_fire/hydro/MPP/.svn/text-base/mpp_land.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/all-wcprops
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/entries
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/Makefile.svn-base
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/Noah_distr_routing.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_GW_baseflow.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_HYDRO_io.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_HYDRO_utils.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_RT.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_channel_routing.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_date_utilities_rt.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_lsm_forcing.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_noah_chan_param_init_rt.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/rtFunction.F.svn-base
 create mode 100644 wrfv2_fire/hydro/Run/.svn/all-wcprops
 create mode 100644 wrfv2_fire/hydro/Run/.svn/entries
 create mode 100644 wrfv2_fire/hydro/Run/.svn/text-base/HYDRO.TBL.svn-base
 create mode 100644 wrfv2_fire/hydro/Run/.svn/text-base/hydro.namelist.svn-base
 create mode 100644 wrfv2_fire/hydro/arc/.svn/all-wcprops
 create mode 100644 wrfv2_fire/hydro/arc/.svn/entries
 create mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/Makefile.mpp.svn-base
 create mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/Makefile.seq.svn-base
 create mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.IBM.xlf90_r.svn-base
 create mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.gfort.svn-base
 create mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.ifort.svn-base
 create mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.linux.svn-base
 create mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.IBM.xlf90_r.svn-base
 create mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.gfort.svn-base
 create mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.ifort.svn-base
 create mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.linux.svn-base
 delete mode 100755 wrfv2_fire/phys/module_bl_qnsepbl09.F
 create mode 100644 wrfv2_fire/phys/module_bl_shinhong.F
 create mode 100644 wrfv2_fire/phys/module_cu_kfcup.F
 create mode 100644 wrfv2_fire/phys/module_cu_mskf.F
 create mode 100644 wrfv2_fire/phys/module_cu_ntiedtke.F
 create mode 100644 wrfv2_fire/phys/module_diag_afwa_hail.F
 create mode 100644 wrfv2_fire/phys/module_ltng_lpi.F
 delete mode 100644 wrfv2_fire/phys/module_mp_etaold.F
 create mode 100644 wrfv2_fire/phys/module_ra_rrtmg_lwf.F
 create mode 100644 wrfv2_fire/phys/module_ra_rrtmg_swf.F
 create mode 100644 wrfv2_fire/phys/rrtmg_lw_cpu_args.h
 create mode 100644 wrfv2_fire/phys/rrtmg_lw_cpu_defs.h
 create mode 100644 wrfv2_fire/phys/taug_cpu_args.h
 create mode 100644 wrfv2_fire/phys/taug_cpu_defs.h
 create mode 100644 wrfv2_fire/test/em_convrad/README.convrad
 create mode 100644 wrfv2_fire/test/em_convrad/input_sounding
 create mode 100644 wrfv2_fire/test/em_convrad/namelist.input
 create mode 100755 wrfv2_fire/test/em_convrad/run_me_first.csh
 create mode 100644 wrfv2_fire/test/em_les/input_sounding_shalconv
 create mode 100644 wrfv2_fire/test/em_les/namelist.input_shalconv
 create mode 100644 wrfv2_fire/tools/fortran_2003_fflush_test.F
 create mode 100644 wrfv2_fire/tools/fortran_2003_flush_test.F

diff --git a/wrfv2_fire/Makefile b/wrfv2_fire/Makefile
index aa6a092a..a9bc14b9 100644
--- a/wrfv2_fire/Makefile
+++ b/wrfv2_fire/Makefile
@@ -9,6 +9,7 @@ CHEM_FILES =	../chem/module_aerosols_sorgam.o \
 		../chem/module_mosaic_driver.o \
 		../chem/module_input_tracer.o \
 		../chem/module_aerosols_soa_vbs.o
+CHEM_FILES2 =	../chem/module_data_mosaic_asect.o
 
 deflt :
 		@ echo Please compile the code using ./compile
@@ -40,6 +41,37 @@ ALL_MODULES =                           \
                $(INCLUDE_MODULES)
 
 configcheck:
+	@echo " "
+	@echo "============================================================================================== "
+	@echo " "
+	@echo "The following indicate the compilers selected to build the WRF system"
+	@echo " "
+	@echo "Serial Fortran compiler (mostly for tool generation):"
+	@echo which SFC
+	@which `echo $(SFC) | cut -d " " -f1`
+	@echo " "
+	@echo "Serial C compiler (mostly for tool generation):"
+	@echo which SCC
+	@which `echo $(SCC) | cut -d " " -f1`
+	@echo " "
+	@echo "Fortran compiler for the model source code:"
+	@echo which FC
+	@if command -v timex > /dev/null 2>&1; then \
+	  which `echo $(FC) | cut -d " " -f2` ; \
+	  echo "Will use 'timex' to report timing information" ; \
+	elif command -v time > /dev/null 2>&1; then \
+	  which `echo $(FC) | cut -d " " -f2` ; \
+	  echo "Will use 'time' to report timing information" ; \
+	else \
+	  which `echo $(FC) | cut -d " " -f1` ; \
+	fi
+	@echo " "
+	@echo "C compiler for the model source code:"
+	@echo which CC
+	@which `echo $(CC) | cut -d " " -f1`
+	@echo " "
+	@echo "============================================================================================== "
+	@echo " "
 	@if [ "$(A2DCASE)" -a "$(DMPARALLEL)" ] ; then \
 	 echo "------------------------------------------------------------------------------" ; \
 	 echo "WRF CONFIGURATION ERROR                                                       " ; \
@@ -50,6 +82,7 @@ configcheck:
 	 echo "------------------------------------------------------------------------------" ; \
          exit 2 ; \
 	fi
+ 
 
 framework_only : configcheck
 	$(MAKE) MODULE_DIRS="$(ALL_MODULES)" ext
@@ -112,13 +145,13 @@ nmm_wrf : wrf
 #  Eulerian mass coordinate initializations
 
 em_fire : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=fire em_ideal )
 	( cd test/em_fire ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
 	( cd test/em_fire ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
 	( cd test/em_fire ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
-	( cd test/em_fire ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
-	( cd test/em_fire ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . )
 	( cd test/em_fire ; /bin/sh create_links.sh )
 	( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . )
 	( cd run ; if test -f namelist.input ; then \
@@ -129,13 +162,13 @@ em_fire : wrf
 	@echo "build completed:" `date`
 
 em_quarter_ss : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=quarter_ss em_ideal )
 	( cd test/em_quarter_ss ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
 	( cd test/em_quarter_ss ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
 	( cd test/em_quarter_ss ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
-	( cd test/em_quarter_ss ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
-	( cd test/em_quarter_ss ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . )
 	( cd test/em_quarter_ss ; /bin/rm -f bulkdens.asc_s_0_03_0_9 ; ln -s ../../run/bulkdens.asc_s_0_03_0_9 . )
 	( cd test/em_quarter_ss ; /bin/rm -f bulkradii.asc_s_0_03_0_9 ; ln -s ../../run/bulkradii.asc_s_0_03_0_9 . )
 	( cd test/em_quarter_ss ; /bin/rm -f capacity.asc ; ln -s ../../run/capacity.asc . )
@@ -151,17 +184,34 @@ em_quarter_ss : wrf
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
 		/bin/rm -f namelist.input ; cp ../test/em_quarter_ss/namelist.input . )
 	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_quarter_ss/input_sounding . )
+	@echo " "
+	@echo "=========================================================================="
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/ideal.exe ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
 
 em_squall2d_x : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=squall2d_x em_ideal )
 	( cd test/em_squall2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
 	( cd test/em_squall2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
 	( cd test/em_squall2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
-	( cd test/em_squall2d_x ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
-	( cd test/em_squall2d_x ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . )
 	( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . )
 	( cd run ; if test -f namelist.input ; then \
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
@@ -169,72 +219,175 @@ em_squall2d_x : wrf
 	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_squall2d_x/input_sounding . )
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
+	@echo " "
+	@echo "=========================================================================="
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/ideal.exe ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
 
 em_squall2d_y : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=squall2d_y em_ideal )
 	( cd test/em_squall2d_y ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
 	( cd test/em_squall2d_y ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
 	( cd test/em_squall2d_y ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
-	( cd test/em_squall2d_y ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
-	( cd test/em_squall2d_y ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . )
 	( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . )
 	( cd run ; if test -f namelist.input ; then \
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
 		/bin/rm -f namelist.input ; cp ../test/em_squall2d_y/namelist.input . )
 	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_squall2d_y/input_sounding . )
+	@echo " "
+	@echo "=========================================================================="
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/ideal.exe ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
 
 em_b_wave : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=b_wave em_ideal )
 	( cd test/em_b_wave ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
 	( cd test/em_b_wave ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
 	( cd test/em_b_wave ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
-	( cd test/em_b_wave ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
-	( cd test/em_b_wave ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . )
 	( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . )
 	( cd run ; if test -f namelist.input ; then \
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
 		/bin/rm -f namelist.input ; cp ../test/em_b_wave/namelist.input . )
 	( cd run ; /bin/rm -f input_jet ; ln -s ../test/em_b_wave/input_jet . )
+	@echo " "
+	@echo "=========================================================================="
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/ideal.exe ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
 
 em_les : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=les em_ideal )
 	( cd test/em_les ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
 	( cd test/em_les ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
 	( cd test/em_les ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
-	( cd test/em_les ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
-	( cd test/em_les ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . )
 	( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . )
 	( cd run ; if test -f namelist.input ; then \
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
 		/bin/rm -f namelist.input ; cp ../test/em_les/namelist.input . )
 	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_les/input_sounding . )
+	@echo " "
+	@echo "=========================================================================="
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/ideal.exe ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
 
 em_seabreeze2d_x : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=seabreeze2d_x em_ideal )
 	( cd test/em_seabreeze2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
 	( cd test/em_seabreeze2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
 	( cd test/em_seabreeze2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
-	( cd test/em_seabreeze2d_x ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
-	( cd test/em_seabreeze2d_x ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . )
 	( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . )
 	( cd run ; if test -f namelist.input ; then \
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
 		/bin/rm -f namelist.input ; cp ../test/em_seabreeze2d_x/namelist.input . )
 	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_seabreeze2d_x/input_sounding . )
+	@echo " "
+	@echo "=========================================================================="
+	@echo "build started:   $(START_OF_COMPILE)"
+	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/ideal.exe ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
+
+em_convrad : wrf
+	@ echo '--------------------------------------'
+	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=convrad em_ideal )
+	( cd test/em_convrad ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
+	( cd test/em_convrad ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
+	( cd test/em_convrad ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
+	( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . )
+	( cd run ; if test -f namelist.input ; then \
+		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
+		/bin/rm -f namelist.input ; cp ../test/em_convrad/namelist.input . )
+	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_convrad/input_sounding . )
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
 
 em_tropical_cyclone : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=tropical_cyclone em_ideal )
 	( cd test/em_tropical_cyclone ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
@@ -245,10 +398,29 @@ em_tropical_cyclone : wrf
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
 		/bin/rm -f namelist.input ; cp ../test/em_tropical_cyclone/namelist.input . )
 	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_tropical_cyclone/input_sounding . )
+	@echo " "
+	@echo "=========================================================================="
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/ideal.exe ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
 
 em_scm_xy : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=scm_xy em_ideal )
 	( cd test/em_scm_xy ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
@@ -259,8 +431,25 @@ em_scm_xy : wrf
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
 		/bin/rm -f namelist.input ; cp ../test/em_scm_xy/namelist.input . )
 	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_scm_xy/input_sounding . )
+	@echo " "
+	@echo "=========================================================================="
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/ideal.exe ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
 
 convert_em : framework_only
 	if [ $(WRF_CONVERT) -eq 1 ] ; then \
@@ -273,6 +462,10 @@ convert_em : framework_only
 # wrf_SST_ESMF.exe is a coupled application.  Note that make 
 # target $(SOLVER)_wrf_SST_ESMF builds wrf_SST_ESMF.exe.  
 em_real : wrf
+	@/bin/rm -f real.exe  > /dev/null 2>&1
+	@/bin/rm -f tc.exe    > /dev/null 2>&1
+	@/bin/rm -f ndown.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real em_real )
 	( cd test/em_real ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
@@ -290,10 +483,9 @@ em_real : wrf
                ln -sf ../../run/RRTMG_SW_DATA . ;                      \
                ln -sf ../../run/CAM_ABS_DATA . ;                       \
                ln -sf ../../run/CAM_AEROPT_DATA . ;                    \
-               cp     ../../run/CAMtr_volume_mixing_ratio.RCP8.5 CAMtr_volume_mixing_ratio ;   \
                ln -sf ../../run/CAMtr_volume_mixing_ratio.RCP4.5 . ;   \
                ln -sf ../../run/CAMtr_volume_mixing_ratio.RCP6   . ;   \
-               ln -sf ../../run/CAMtr_volume_mixing_ratio.RCP8.5 . ;   \
+               ln -sf ../../run/CAMtr_volume_mixing_ratio.RCP8.5 CAMtr_volume_mixing_ratio ;   \
                ln -sf ../../run/CAMtr_volume_mixing_ratio.A1B    . ;   \
                ln -sf ../../run/CAMtr_volume_mixing_ratio.A2     . ;   \
                ln -sf ../../run/CLM_ALB_ICE_DFS_DATA . ;               \
@@ -335,7 +527,7 @@ em_real : wrf
 	( cd test/em_real ; /bin/rm -f real.exe ; ln -s ../../main/real.exe . )
 	( cd test/em_real ; /bin/rm -f tc.exe ; ln -s ../../main/tc.exe . )
 	( cd test/em_real ; /bin/rm -f ndown.exe ; ln -s ../../main/ndown.exe . )
-	( cd test/em_real ; /bin/rm -f nup.exe ; ln -s ../../main/nup.exe . )
+	#TEMPORARILY REMOVED ( cd test/em_real ; /bin/rm -f nup.exe ; ln -s ../../main/nup.exe . )
 	( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
 	( cd test/em_real ; /bin/rm -f ETAMPNEW_DATA.expanded_rain ETAMPNEW_DATA RRTM_DATA RRTMG_LW_DATA RRTMG_SW_DATA ;    \
              ln -sf ../../run/ETAMPNEW_DATA . ;                     \
@@ -345,10 +537,9 @@ em_real : wrf
              ln -sf ../../run/RRTMG_SW_DATA . ;                     \
              ln -sf ../../run/CAM_ABS_DATA . ;                      \
              ln -sf ../../run/CAM_AEROPT_DATA . ;                   \
-             cp     ../../run/CAMtr_volume_mixing_ratio.RCP8.5 CAMtr_volume_mixing_ratio ;   \
              ln -sf ../../run/CAMtr_volume_mixing_ratio.RCP4.5 . ;  \
              ln -sf ../../run/CAMtr_volume_mixing_ratio.RCP6   . ;  \
-             ln -sf ../../run/CAMtr_volume_mixing_ratio.RCP8.5 . ;  \
+             ln -sf ../../run/CAMtr_volume_mixing_ratio.RCP8.5 CAMtr_volume_mixing_ratio ;   \
              ln -sf ../../run/CAMtr_volume_mixing_ratio.A1B    . ;  \
              ln -sf ../../run/CAMtr_volume_mixing_ratio.A2     . ;  \
              ln -sf ../../run/CLM_ALB_ICE_DFS_DATA . ;              \
@@ -399,60 +590,128 @@ em_real : wrf
 	( cd run ; /bin/rm -f real.exe ; ln -s ../main/real.exe . )
 	( cd run ; /bin/rm -f tc.exe ; ln -s ../main/tc.exe . )
 	( cd run ; /bin/rm -f ndown.exe ; ln -s ../main/ndown.exe . )
-	( cd run ; /bin/rm -f nup.exe ; ln -s ../main/nup.exe . )
+	#TEMPORARILY REMOVED ( cd run ; /bin/rm -f nup.exe ; ln -s ../main/nup.exe . )
 	( cd run ; if test -f namelist.input ; then \
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
 		/bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . )
+	@echo " "
+	@echo "=========================================================================="
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/real.exe -a -e main/ndown.exe -a -e main/tc.exe  ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
 
 
 em_hill2d_x : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=hill2d_x em_ideal )
 	( cd test/em_hill2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
 	( cd test/em_hill2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
 	( cd test/em_hill2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
-	( cd test/em_hill2d_x ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
-	( cd test/em_hill2d_x ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . )
 	( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . )
 	( cd run ; if test -f namelist.input ; then \
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
 		/bin/rm -f namelist.input ; cp ../test/em_hill2d_x/namelist.input . )
 	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_hill2d_x/input_sounding . )
+	@echo " "
+	@echo "=========================================================================="
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/ideal.exe ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
 
 em_grav2d_x : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=grav2d_x em_ideal )
 	( cd test/em_grav2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
 	( cd test/em_grav2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
 	( cd test/em_grav2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
-	( cd test/em_grav2d_x ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
-	( cd test/em_grav2d_x ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . )
 	( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . )
 	( cd run ; if test -f namelist.input ; then \
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
 		/bin/rm -f namelist.input ; cp ../test/em_grav2d_x/namelist.input . )
 	( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_grav2d_x/input_sounding . )
+	@echo " "
+	@echo "=========================================================================="
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/ideal.exe ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
 
 em_heldsuarez : wrf
+	@/bin/rm -f ideal.exe > /dev/null 2>&1
+	@/bin/rm -f wrf.exe   > /dev/null 2>&1
 	@ echo '--------------------------------------'
 	( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=heldsuarez em_ideal )
 	( cd test/em_heldsuarez ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . )
 	( cd test/em_heldsuarez ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . )
 	( cd test/em_heldsuarez ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . )
-	( cd test/em_heldsuarez ; /bin/rm -f gribmap.txt ; ln -s ../../run/gribmap.txt . )
-	( cd test/em_heldsuarez ; /bin/rm -f grib2map.tbl ; ln -s ../../run/grib2map.tbl . )
 	( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . )
 	( cd run ; if test -f namelist.input ; then \
 		/bin/cp -f namelist.input namelist.input.backup ; fi ; \
 		/bin/rm -f namelist.input ; cp ../test/em_heldsuarez/namelist.input . )
+	@echo " "
+	@echo "=========================================================================="
 	@echo "build started:   $(START_OF_COMPILE)"
 	@echo "build completed:" `date`
+	@if test -e main/wrf.exe -a -e main/ideal.exe ; then \
+		echo " " ; \
+		echo "--->                  Executables successfully built                  <---" ; \
+		echo " " ; \
+		ls -l main/*.exe ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	else \
+		echo " " ; \
+		echo "---> Problems building executables, look for errors in the build log  <---" ; \
+		echo " " ; \
+		echo "==========================================================================" ; \
+		echo " " ; \
+	fi
 
 #### anthropogenic emissions converter
 
@@ -599,10 +858,20 @@ framework :
 	@ echo '--------------------------------------'
 	( cd frame ; $(MAKE) $(J) framework; \
           cd ../external/io_netcdf ; \
-          $(MAKE) NETCDFPATH="$(NETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \
+          $(MAKE) NETCDFPATH="$(NETCDFPATH)" FC="$(FC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \
                CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
 	       LIB_LOCAL="$(LIB_LOCAL)" \
                ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR" diffwrf; \
+          cd ../external/io_netcdf ; \
+          $(MAKE) NETCDFPATH="$(NETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \
+               CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+	       LIB_LOCAL="$(LIB_LOCAL)" \
+               ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR"; \
+          cd ../external/io_pio ; \
+          $(MAKE) NETCDFPATH="$(PNETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \
+               CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
+	       LIB_LOCAL="$(LIB_LOCAL)" \
+               ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR"; \
           cd ../io_int ; \
           $(MAKE) SFC="$(SFC) $(FCBASEOPTS)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) $(ARCH_LOCAL)" DM_FC="$(DM_FC) $(FCBASEOPTS)"\
                TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \
@@ -645,7 +914,11 @@ chemics :
 
 physics :
 	@ echo '--------------------------------------'
-	( cd phys ; $(MAKE) )
+	if [ $(WRF_CHEM) -eq 0 ] ; then \
+		( cd phys ; $(MAKE) CF2=" " ) ; \
+	else \
+		( cd phys ; $(MAKE) CF2="$(CHEM_FILES2)" ) ; \
+	fi
 
 em_core :
 	@ echo '--------------------------------------'
@@ -681,7 +954,15 @@ fortran_2003_ieee_test:
 fortran_2003_iso_c_test:
 	@cd tools ; /bin/rm -f fortran_2003_iso_c_test.{exe,o} ; $(SFC) -o fortran_2003_iso_c_test.exe fortran_2003_iso_c_test.F ; cd ..
 
-### 3.b.  sub-rule to build the expimental core
+# rule used by configure to test if Fortran 2003 FLUSH intrinsic subroutine support is available
+fortran_2003_flush_test:
+	@cd tools ; /bin/rm -f fortran_2003_flush_test.{exe,o} ; $(SFC) -o fortran_2003_flush_test.exe fortran_2003_flush_test.F ; cd ..
+
+# rule used by configure to test if Fortran 2003 FLUSH intrinsic subroutine is replaced by FFLUSH (thanks xlf)
+fortran_2003_fflush_test:
+	@cd tools ; /bin/rm -f fortran_2003_fflush_test.{exe,o} ; $(SFC) -o fortran_2003_fflush_test.exe fortran_2003_fflush_test.F ; cd ..
+
+### 3.b.  sub-rule to build the experimental core
 
 # uncomment the two lines after exp_core for EXP
 exp_core :
diff --git a/wrfv2_fire/README b/wrfv2_fire/README
index 63e8bca1..815519c0 100644
--- a/wrfv2_fire/README
+++ b/wrfv2_fire/README
@@ -1,4 +1,4 @@
-WRF Model Version 3.6 (April 18, 2014)
+WRF Model Version 3.7 (April 17, 2015)
 http://wrf-model.org/users/users.php
 
 ------------------------
@@ -27,11 +27,25 @@ infringement actions.
 This is the main directory for the WRF Version 3 source code release.
 ======================================
 
+V3.7 Release Notes (4/17/15) (rev 8350):
+-------------------
+
+- For more information on WRF V3.7 release, visit WRF User's home pages
+  http://www2.mmm.ucar.edu/wrf/users/, and
+  http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide.
+
+V3.6.1 Release Notes (8/14/14) (rev 7630):
+-------------------
+
+- For more information on WRF V3.6.1 release, visit WRF User's home pages
+  http://www2.mmm.ucar.edu/wrf/users/, and
+  http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide.
+
 V3.6 Release Notes (4/18/14) (rev 7412):
 -------------------
 
 - For more information on WRF V3.6 release, visit WRF User's home pages
-  http://www.mmm.ucar.edu/wrf/users/, and
+  http://www2.mmm.ucar.edu/wrf/users/, and
   http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide.
 
 ======================================
@@ -40,7 +54,7 @@ V3.5.1 Release Notes (9/23/13) (rev 6868):
 -------------------
 
 - For more information on WRF V3.5.1 release, visit WRF User's home pages
-  http://www.mmm.ucar.edu/wrf/users/, and
+  http://www2.mmm.ucar.edu/wrf/users/, and
   http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide.
 
 ======================================
@@ -49,7 +63,7 @@ V3.5 Release Notes (4/18/13) (rev 6660):
 -------------------
 
 - For more information on WRF V3.5 release, visit WRF User's home pages
-  http://www.mmm.ucar.edu/wrf/users/, and
+  http://www2.mmm.ucar.edu/wrf/users/, and
   http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide.
 
 ======================================
@@ -58,7 +72,7 @@ V3.4.1 Release Notes (8/16/12) (rev 5930):
 -------------------
 
 This is a bug fix release. The detailed updates for WRF-ARW can be found at
-http://www.mmm.ucar.edu/wrf/users/wrfv3.4/updates-3.4.1.html,
+http://www2.mmm.ucar.edu/wrf/users/wrfv3.4/updates-3.4.1.html,
 and for WRF-NMM at
 http://www.dtcenter.org/wrf-nmm/users/model/wrfv3/updates.php
 
@@ -70,7 +84,7 @@ V3.4 Release Notes:
 Version 3.4 is released on April 6, 2012 (rev 5745).
 
 - For more information on WRF V3.4 release, visit WRF User's home pages
-  http://www.mmm.ucar.edu/wrf/users/, and
+  http://www2.mmm.ucar.edu/wrf/users/, and
   http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide.
 
 ======================================
@@ -79,7 +93,7 @@ V3.3.1 Release Notes (9/16/11) (rev 5130):
 -------------------
 
 This is a bug fix release. The detailed updates for WRF-ARW can be found at
-http://www.mmm.ucar.edu/wrf/users/wrfv3.3/updates-3.3.1.html,
+http://www2.mmm.ucar.edu/wrf/users/wrfv3.3/updates-3.3.1.html,
 and for WRF-NMM at
 http://www.dtcenter.org/wrf-nmm/users/model/wrfv3/updates.php
 
@@ -91,7 +105,7 @@ V3.3 Release Notes:
 Version 3.3 is released on April 6, 2011 (rev 4896).
 
 - For more information on WRF V3.3 release, visit WRF User's home pages
-  http://www.mmm.ucar.edu/wrf/users/, and
+  http://www2.mmm.ucar.edu/wrf/users/, and
   http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide.
 
 
@@ -101,7 +115,7 @@ V3.2.1 Release Notes (8/18/10):
 ------------------
 
 This is a bug fix release. The detailed updates for WRF-ARW can be found at
-http://www.mmm.ucar.edu/wrf/users/wrfv3.2/updates-3.2.1.html, and
+http://www2.mmm.ucar.edu/wrf/users/wrfv3.2/updates-3.2.1.html, and
 for WRF-NMM at
 http://www.dtcenter.org/wrf-nmm/users/model/wrfv3/updates.php
 
@@ -115,7 +129,7 @@ V3.2 Release Notes:
 Version 3.2 is released on March 31, 2010.
 
 - For more information on WRF V3.2 release, visit WRF User's home pages
-  http://www.mmm.ucar.edu/wrf/users/, and 
+  http://www2.mmm.ucar.edu/wrf/users/, and 
   http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide.
 
 
@@ -125,7 +139,7 @@ V3.1.1 Release Notes (7/31/09):
 ------------------
 
 This is a bug fix release. The detailed updates for WRF-ARW can be found at
-http://www.mmm.ucar.edu/wrf/users/wrfv3.1/updates-3.1.1.html, and
+http://www2.mmm.ucar.edu/wrf/users/wrfv3.1/updates-3.1.1.html, and
 for WRF-NMM at
 http://www.dtcenter.org/wrf-nmm/users/model/wrfv3/updates.php
 
@@ -139,7 +153,7 @@ V3.1 Release Notes:
 Version 3.1 is released on April 9, 2009.
 
 - For more information on WRF V3.1 release, visit WRF Users home page
-  http://www.mmm.ucar.edu/wrf/users/, and read the online User's Guide.
+  http://www2.mmm.ucar.edu/wrf/users/, and read the online User's Guide.
 - WRF V3 executable will work with V3.0 wrfinput/wrfbdy (but requires 
   inserting a new namelist variable use_baseparam_fr_nml in &dynamics). As
   always, rerunning the new programs is recommended.
@@ -154,14 +168,14 @@ V3.0.1.1 Release Notes:
 
 Version 3.0.1.1 has only limited bug fixes compared to version 3.0.1.
 The detailed updates for WRF-ARW can be found at
-http://www.mmm.ucar.edu/wrf/users/wrfv3/updates-3.0.1.1.html.
+http://www2.mmm.ucar.edu/wrf/users/wrfv3/updates-3.0.1.1.html.
 
 
 V3.0.1 Release Notes:
 ---------------------
 
 This is a bug fix release. The detailed updates for WRF-ARW can be found at
-http://www.mmm.ucar.edu/wrf/users/wrfv3/updates-3.0.1.html.
+http://www2.mmm.ucar.edu/wrf/users/wrfv3/updates-3.0.1.html.
 
 Online User's Guides have also been updated.
 
@@ -172,7 +186,7 @@ V3.0 Release Notes:
 
 - For directions on compiling WRF, see below or Users Web page.
 - For more information on WRF V3 release, visit WRF Users home page
-  http://www.mmm.ucar.edu/wrf/users/
+  http://www2.mmm.ucar.edu/wrf/users/
 - WRF V3 works with WPS, and SI is no longer supported. 
   Please see User' Guide for WPS.
 - WRF V3 executable does not work with wrfinput/wrfbdy produced by previous versions.
@@ -204,6 +218,8 @@ WRF update history:
 - V3.4.1: Aug 16, 2012
 - V3.5: April 18, 2013
 - V3.5.1: Sept 23, 2013
+- V3.6: April 18, 2014
+- V3.6.1: Aug 14, 2014
 
 ======================================
 
@@ -230,6 +246,7 @@ How to compile and run?
       compile em_quarter_ss
       compile em_real
       compile em_seabreeze2d_x
+      compile em_convrad
       compile em_squall2d_x
       compile em_squall2d_y
       compile em_scm_xy
@@ -282,7 +299,7 @@ How to compile and run?
   mpirun -np number-of-processors wrf.exe
 
 - For information on how to make nested runs, visit
-  http://www.mmm.ucar.edu/wrf/users/
+  http://www2.mmm.ucar.edu/wrf/users/
 
 
 ======================================
@@ -325,10 +342,11 @@ What is in WRF V3?
     Betts-Miller-Janjic / Grell-Devenyi ensemble / Grell 3D (with shallow convection option) /
     Grell-Freitas ensemble /
     Tiedtke (with shallow conv and momentum transport) / NSAS (with shallow conv and momentum transport) /
-    SAS (with shallow conv for ARW) / Zhang-McFarlane (with momentum transport) )
+    SAS (with shallow conv for ARW) / Zhang-McFarlane (with momentum transport) ) /
+    New Tiedtke (with shallow conv and momentum transport) / Multi-scale KF (with shallow convection)
   * UW shallow convection / GRIMS shallow convection
   * planetary boundary layer (Yosei University / Mellor-Yamada-Janjic / ACM2 / QNSE-EDMF / MYNN / 
-    BouLac / UW / TEMF / Grenier-Bretherton-McCaa )
+    BouLac / UW / TEMF / Grenier-Bretherton-McCaa ) / Shin-Hong 
   * slab soil model (5-layer thermal diffusion / Noah land-surface model (4 levels) /
     RUC LSM (6 levels) / Pleim-Xu (2 levels / Noah-MP (4 levels) / SSiB (3 levels) / CLM4 (10 levels) )
   * Urban canopy model, BEP multi-layer and BEM  (works with Noah LSM, BEP and 
@@ -339,7 +357,7 @@ What is in WRF V3?
   * sub-grid turbulence (constant K diffusion/ 2-D Smagorinsky/ predicted TKE /
     2-D, 6th order diffusion / Nonlinear Backscatter Anisotropic (NBA) sub-grid turbulence stress for LES )
   * Rayleigh damping for w at the upper boundary layer
-  * gravity wave drag
+  * gravity wave drag (including flow blocking)
   * land-use categories determine surface properties; support for 24 category USGS and 
     20 category MODIS 
   * Options for modifying SST, sea ice, vegetation fraction, albedo, and deep soil temp
diff --git a/wrfv2_fire/README.DA b/wrfv2_fire/README.DA
index be7c2be3..3a1c3490 100644
--- a/wrfv2_fire/README.DA
+++ b/wrfv2_fire/README.DA
@@ -18,17 +18,64 @@ whatsoever, whether direct, indirect, consequential or special, that
 arise out of or in connection with the access, use or performance of 
 WRFDA, including infringement actions.
 
+
 ======================================
 This is the main directory for the WRFDA Version 3 source code release.
 ======================================
 
+V3.7 Release Notes :
+-------------------
+
+Version 3.7 was released on April 20, 2015.
+
+  For more information on WRFDA, visit the WRFDA Users home page
+  http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html
+
+  New features:
+
+    -New background error option: CV7 (cv_options = 7)
+    -Radar assimilation has been updated: new options have been added for reflectivity assimilation
+    -A new mp_physics option is available for WRFPLUS in 4DVAR runs
+
+  Updated features:
+
+    -WRFDA can now use WRF files with the "lat-lon" (cylindrical equidistant) map projection. This 
+     does not include global WRF files.
+    -Updated libraries:
+        -RTTOV interface is now for RTTOV Version 11.1 or 11.2
+    -Bug fixes and performance improvements
+    -WRFPLUS has been upgraded to V3.7.
+======================================
+
+V3.6.1 Release Notes :
+-------------------
+
+Version 3.6.1 was released on August 14, 2014.
+
+  For more information about WRFDA, visit the WRFDA Users home page
+  http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html
+
+  Updated features:
+
+    - A number of issues have been fixed for this release, including:
+        - The FGAT capability has been updated to produce better results
+        - Several bugs which may cause compilation failure
+        - Bugs in SEVIRI radiance assimilation
+        - Errors when using RTTOV to assimilate radiances in 4DVAR
+        - The FGAT capability has been updated to produce better results
+        - Many other minor problems
+    - WRFPLUS has been upgraded to V3.6.1
+
+See http://www2.mmm.ucar.edu/wrf/users/wrfda/updates-3.6.1.html for a full list of updates
+
+======================================
 V3.6 Release Notes :
 -------------------
 
 Version 3.6 was released on April 18, 2014.
 
   For more information on WRFDA, visit the WRFDA Users home page
-  http://www.mmm.ucar.edu/wrf/users/wrfda/index.html
+  http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html
 
   New features:
 
@@ -58,7 +105,7 @@ V3.5.1 Release Notes :
 Version 3.5.1 is released on September 23, 2013.
 
   For more information on WRFDA, visit the WRFDA Users home page
-  http://www.mmm.ucar.edu/wrf/users/wrfda/index.html
+  http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html
 
 
   The following bugs have been fixed:
@@ -77,7 +124,7 @@ V3.5 Release Notes :
 Version 3.5 is released on April 18. 2013.
 
   For more information on WRFDA, visit the WRFDA Users home page
-  http://www.mmm.ucar.edu/wrf/users/wrfda/index.html
+  http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html
 
   New features:
 
@@ -105,7 +152,7 @@ V3.4.1 Release Notes :
 Version 3.4.1 is released on August 16, 2012.
 
 - For more information on WRFDA, visit the WRFDA Users home page
-  http://www.mmm.ucar.edu/wrf/users/wrfda/index.html
+  http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html
 
 - WRFDA registry files have been reconstructed.
   Default namelist settings are now in registry.var file.
@@ -220,7 +267,7 @@ V3.1 Release Notes:
 Version 3.1 is released on April 9, 2009.
 
 - For more information on WRFDA, visit the new WRFDA Users home page
-  http://www.mmm.ucar.edu/wrf/users/wrfda/index.html
+  http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html
   and read the online User's Gudie.
 
 - 4DVAR and radiance data assimilation capabilities are included in V3.1.
@@ -255,7 +302,7 @@ Version 3.1 is released on April 9, 2009.
 
 - Most of the scripts under WRFDA/var/scripts are removed from the main source
   code tar file. They can still be downloaded separately.
-  See http://www.mmm.ucar.edu/wrf/users/wrfda/download/tools.html
+  See http://www2.mmm.ucar.edu/wrf/users/wrfda/download/tools.html
 
 For questions, send mail to wrfhelp@ucar.edu
 
diff --git a/wrfv2_fire/README.SSIB b/wrfv2_fire/README.SSIB
index df6dbc92..a1dcf7ba 100644
--- a/wrfv2_fire/README.SSIB
+++ b/wrfv2_fire/README.SSIB
@@ -1,5 +1,5 @@
 ***
-     WRF-ARW v3.4 coupled with SSiB v3.0 land-surface model
+     WRF-ARW v3.6.* coupled with SSiB v3.0 land-surface model
 ***
 
 The SSiB v3.0 is a land-surface model with a multi-layer snow scheme.
@@ -13,8 +13,9 @@ Currently, the SSIB will only work with the following options:
 1) SW and LW radiation schemes: 1 or 3
 2) Surface layer schemes: 1
 3) PBL scheme: 1
-4) Eta levels: the first two levels must be 1.0 and 0.982
-    For example, for a e_vert=28 domain, eta_levels may be set to:
+4) Eta levels: the first level above ground must be equal or smaller than 0.982,
+    to guarantee that the lowest layer is deep enough for SSIB. 
+    For example, for an e_vert=28 domain, the eta_levels may be set to:
     eta_levels = 1.000, 0.982, 0.973, 0.964, 0.946,
                  0.922, 0.894, 0.860, 0.817, 0.766,
                  0.707, 0.644, 0.576, 0.507, 0.444,
@@ -24,17 +25,22 @@ Currently, the SSIB will only work with the following options:
 5) num_soil_layers = 3
 6) fractional_seaice = 1
  
-Please note that SSiB does not provide U10 and V10 outputs.  The data shown in the SSiB output files for U10 and V10 
-are calculated by  thermal-diffusion surface layer scheme to avoid zero values in display"
+Since version 3.6.1, SSiB also provides 10-meter wind speed (U10 and V10) outputs. 
 
 ----------
  WPS
 ----------
-By default, SSiB will work with the USGS land-use/vegetation maps, however, for better results, we suggest you use SSiB the 12-type vegetation maps. This files are available in the WPS_GEOG directory.
-This can be done by prefixing the variable geog_data_res with the string "ssib_+", according to the resolution
+By default, SSiB will work with either USGS and MODIS land-use/vegetation maps, however, for better results, we suggest that you use the SSiB 12-type vegetation maps.
+These files are available in the WPS_GEOG directory.
+
+This can be done by prefixing the variable geog_data_res with the string "ssib_+", according to the desired resolution.
+
+For instance, to use the SSiB 10-minute resolution vegetation map, enter:
+geog_data_res = 'ssib_10m+10m'
+
+Or to use the 5-minute resolution vegetation map, enter:
+geog_data_res = 'ssib_5m+5m'
 
-For instance, to use SSiB 10-minute resolution vegetation map, enter:
-geog_data_res     = 'ssib_10m+10m',
 Only 10-minute and 5-minute maps are currently available.
 
 SSiB vegetation classification:
@@ -54,5 +60,5 @@ SSiB vegetation classification:
 
 
 **
-For further assistance please contact Dr. Yongkang Xue (yxue@geog.ucla.edu) or Dr. Fernando De Sales (fsales@ucla.edu)
+For further assistance please contact Dr. Yongkang Xue (yxue@geog.ucla.edu) or Dr. Fernando De Sales (fsales@geog.ucla.edu)
 **
diff --git a/wrfv2_fire/README_test_cases b/wrfv2_fire/README_test_cases
index 2c551256..a4201f51 100644
--- a/wrfv2_fire/README_test_cases
+++ b/wrfv2_fire/README_test_cases
@@ -118,3 +118,9 @@ The available test cases are
    case is useful for testing the effects of new model code (e.g., 
    new physics options) on tropical cyclones in an idealized framework. 
 
+12) Convective-radiative equilibrium test (test/em_convrad)
+
+   Idealized 3d convective-radiative equilibrium test with constant SST
+   and full physics at cloud-resolving 1 km grid size. Periodic b.c.s.
+   Tropical conditions, small f and weak wind.
+
diff --git a/wrfv2_fire/Registry/Registry.CONVERT b/wrfv2_fire/Registry/Registry.CONVERT
index 2e0423dd..b65c4c0d 100644
--- a/wrfv2_fire/Registry/Registry.CONVERT
+++ b/wrfv2_fire/Registry/Registry.CONVERT
@@ -285,6 +285,7 @@ rconfig   integer     cu_physics          namelist,physics	max_domains    0
 rconfig   real    CUDT                    namelist,physics	max_domains    0       h    "CUDT"          ""      ""
 rconfig   real    GSMDT                   namelist,physics	max_domains    0       h    "GSMDT"          ""      ""
 rconfig   integer ISFFLX                  namelist,physics 	1             1       irh    "ISFFLX"                        ""      ""
+rconfig   integer ideal_xland             namelist,physics      1             1        rh    "IDEAL_XLAND"  "land=1(def), water=2, for ideal cases with no land-use"      ""
 rconfig   integer IFSNOW                  namelist,physics	1             1       irh    "IFSNOW"                        ""      ""
 rconfig   integer ICLOUD                  namelist,physics	1             1       irh    "ICLOUD"                        ""      ""
 rconfig   integer surface_input_source    namelist,physics	1             1       irh    "surface_input_source"          "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)"      ""
@@ -515,5 +516,6 @@ package   io_esmf     io_form_restart==7                     -             -
 package   io_yyy      io_form_restart==8                     -             -
 package   io_zzz      io_form_restart==9                     -             -
 package   io_grib2    io_form_restart==10                    -             -
-package   io_pnetcdf  io_form_restart==11                     -             -
+package   io_pnetcdf  io_form_restart==11                    -             -
+package   io_pio      io_form_restart==12                    -             -
                                                 
diff --git a/wrfv2_fire/Registry/Registry.EM b/wrfv2_fire/Registry/Registry.EM
index d1796307..22bf4d5f 100644
--- a/wrfv2_fire/Registry/Registry.EM
+++ b/wrfv2_fire/Registry/Registry.EM
@@ -14,6 +14,7 @@ include registry.clm
 include registry.ssib
 include registry.lake
 include registry.diags
+include registry.afwa
 include registry.sbm
 include registry.bdy_perturb
 
@@ -38,14 +39,14 @@ state   real    -              ikjftb   chem        1         -     -    -
 # Tracer Scalars: If you want full resolved and non-resolved dispersion, compile WRF-Chem
 #
 state   real    -          ikjftb  tracer        1         -     -    -                                       
-state   real    tr17_1     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_1"         "tr17_1"          -
-state   real    tr17_2     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_2"         "tr17_2"          -
-state   real    tr17_3     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_3"         "tr17_3"          -
-state   real    tr17_4     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_4"         "tr17_4"          -
-state   real    tr17_5     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_5"         "tr17_5"          -
-state   real    tr17_6     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_6"         "tr17_6"          -
-state   real    tr17_7     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_7"         "tr17_7"          -
-state   real    tr17_8     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_8"         "tr17_8"
+state   real    tr17_1     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_1"         "tr17_1"     "Dimensionless"
+state   real    tr17_2     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_2"         "tr17_2"     "Dimensionless"
+state   real    tr17_3     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_3"         "tr17_3"     "Dimensionless"
+state   real    tr17_4     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_4"         "tr17_4"     "Dimensionless"
+state   real    tr17_5     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_5"         "tr17_5"     "Dimensionless"
+state   real    tr17_6     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_6"         "tr17_6"     "Dimensionless"
+state   real    tr17_7     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_7"         "tr17_7"     "Dimensionless"
+state   real    tr17_8     ikjftb  tracer        1         -     irhusdf=(bdy_interp:dt)    "tr17_8"         "tr17_8"     "Dimensionless"
 
 package   tracer_test1  tracer_opt==2       -             tracer:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8
 
diff --git a/wrfv2_fire/Registry/Registry.EM_CHEM b/wrfv2_fire/Registry/Registry.EM_CHEM
index 782d61ab..7706ad5a 100644
--- a/wrfv2_fire/Registry/Registry.EM_CHEM
+++ b/wrfv2_fire/Registry/Registry.EM_CHEM
@@ -15,10 +15,11 @@ include registry.lake
 include registry.ssib
 include registry.sbm
 include registry.diags
+include registry.afwa
 include registry.bdy_perturb
 
 state   real   landmask            ij    misc          1     -     i012rh0d=(interp_fcnm_imask)u=(copy_fcnm)   "LANDMASK"      "LAND MASK (1 FOR LAND, 0 FOR WATER)"  ""
-state   real   lakemask            ij    misc          1     -     i012rh0d=(interp_fcnm_imask)u=(copy_fcnm)   "LANDMASK"      "LAND MASK (1 FOR LAND, 0 FOR WATER)"  ""
+state   real   lakemask            ij    misc          1     -     i012rh0d=(interp_fcnm_imask)u=(copy_fcnm)   "LAKEMASK"      "LAKE MASK (1 FOR LAND, 0 FOR WATER)"  ""
 
 # Masked SST interpolation from the CG
 #state    real   SST              ij    misc        1         -     i0124rh0d=(interp_mask_field:lu_index,iswater)f=(p2c_mask:lu_index,tslb,num_soil_layers,iswater)   "SST"              "SEA SURFACE TEMPERATURE" "K"
diff --git a/wrfv2_fire/Registry/Registry.EM_COMMON b/wrfv2_fire/Registry/Registry.EM_COMMON
index 5d2a7c37..c252e063 100644
--- a/wrfv2_fire/Registry/Registry.EM_COMMON
+++ b/wrfv2_fire/Registry/Registry.EM_COMMON
@@ -50,8 +50,8 @@
 # table entries are of the form
 #
# -state real XLAT ij misc 1 - i0123rh01du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" -state real XLONG ij misc 1 - i0123rh01du=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLAT ij misc 1 - i0123rh01{23}du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG ij misc 1 - i0123rh01{23}du=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" # It is required that LU_INDEX appears before any variable that is # interpolated with a mask, as lu_index supplies that mask. @@ -87,7 +87,7 @@ state real t_gc igj dyn_em 1 Z i1 "TT" state real rh_gc igj dyn_em 1 Z i1 "RH" "relative humidity" "%" state real ght_gc igj dyn_em 1 Z i1 "GHT" "geopotential height" "m" state real p_gc igj dyn_em 1 Z i1 "PRES" "pressure" "Pa" -state real prho_gc igj dyn_em 1 Z i1 "PTHETA" "for UM data, from metgrid this is ptheta, but swapped to prho in real" "Pa" +state real prho_gc igj dyn_em 1 Z i1 "PRHO" "for UM data, pressure of U and V" "Pa" state real xlat_gc ij dyn_em 1 - i1 "XLAT_M" "latitude, positive north" "degrees" state real xlong_gc ij dyn_em 1 - i1 "XLONG_M" "longitude, positive east" "degrees" state real ht_gc ij dyn_em 1 - i1 "HGT_M" "topography elevation" "m" @@ -109,7 +109,10 @@ state real intq_gc ij dyn_em 1 - - "INTQ" " state real pdhs ij dyn_em 1 - - "PDHS" "hydrostatic dry surface pressure" "Pa" state real qv_gc igj dyn_em 1 Z i1 "QV" "mixing ratio" "kg kg-1" state real sh_gc igj dyn_em 1 Z i1 "SPECHUMD" "Specific humidity" "kg kg-1" +state real cl_gc igj dyn_em 1 Z i1 "SPECCLDL" "Cloud water content, liquid" "kg kg-1" +state real cf_gc igj dyn_em 1 Z i1 "SPECCLDF" "Cloud water content, frozen" "kg kg-1" state real icefrac_gc ij dyn_em 1 - i1 "ICEFRAC" "Sea ice fraction" "0 - 1 fraction" +state real icepct ij dyn_em 1 - i1 "ICEPCT" "Sea ice percent" "%" state real qr_gc igj dyn_em 1 Z i1 "QR" "rain water mixing ratio" "kg kg-1" state real qc_gc igj dyn_em 1 Z i1 "QC" "cloud water mixing ratio" "kg kg-1" state real qs_gc igj dyn_em 1 Z i1 "QS" "snow mixing ratio" "kg kg-1" @@ -118,6 +121,8 @@ state real qg_gc igj dyn_em 1 Z i1 "QG" " state real qh_gc igj dyn_em 1 Z i1 "QH" "hail mixing ratio" "kg kg-1" state real qni_gc igj dyn_em 1 Z i1 "QNI" "ice num concentration" "m-3" state real qnr_gc igj dyn_em 1 Z i1 "QNR" "rain num concentration" "m-3" +state real qnwfa_gc igj dyn_em 1 Z i1 "QNWFA" "water-friendly aerosol num concentration" "m-3" +state real qnifa_gc igj dyn_em 1 Z i1 "QNIFA" "water-friendly aerosol num concentration" "m-3" state real qnwfa_now igj dyn_em 1 Z - "QNWFA_NOW" "num water-friendly aerosol Now" "kg-1" state real qnwfa_jan igj dyn_em 1 Z i1 "QNWFA_JAN" "num water-friendly aerosol Jan" "kg-1" state real qnwfa_feb igj dyn_em 1 Z i1 "QNWFA_FEB" "num water-friendly aerosol Feb" "kg-1" @@ -152,6 +157,16 @@ state real max_p ij dyn_em 1 - i0d "MAX_P" state real t_min_p ij dyn_em 1 - i0d "T_MIN_P" "temperature at min pressure" "K" state real ght_min_p ij dyn_em 1 - i0d "GHT_MIN_P" "geopotential height at min pressure" "m" state real min_p ij dyn_em 1 - i0d "MIN_P" "min pressure " "Pa" +state real hgtmaxw ij dyn_em 1 - i1 "HGTMAXW" "Height of the max wind speed" "m" +state real hgttrop ij dyn_em 1 - i1 "HGTTROP" "Height of the tropopause" "m" +state real pmaxw ij dyn_em 1 - i1 "PMAXW" "Pressure of the max wind speed" "Pa" +state real ptrop ij dyn_em 1 - i1 "PTROP" "Pressure of the tropopause" "Pa" +state real tmaxw ij dyn_em 1 - i1 "TMAXW" "Temperature of the max wind speed" "K" +state real ttrop ij dyn_em 1 - i1 "TTROP" "Temperature of the tropopause" "K" +state real umaxw ij dyn_em 1 X i1 "UMAXW" "U-component of the max wind speed" "m s-1" +state real utrop ij dyn_em 1 X i1 "UTROP" "U-component of the tropopause wind" "m s-1" +state real vmaxw ij dyn_em 1 Y i1 "VMAXW" "V-component of the max wind speed" "m s-1" +state real vtrop ij dyn_em 1 Y i1 "VTROP" "V-component of the tropopause wind" "m s-1" #----------------------------------------------------------------------------------------------------------------------------------------------------------------- # @@ -210,10 +225,11 @@ i1 real ph_tendf ikj dyn_em 1 Z i1 real ph_save ikj dyn_em 1 Z # Potential Temperature +#KAL added d (interpolating down to t_init) for the vertical nesting code state real t ikjb dyn_em 2 - \ i0rhusdf=(bdy_interp:dt) "t" "perturbation potential temperature (theta-t0)" "K" -state real t_init ikj dyn_em 1 - ir "t_init" "initial potential temperature" "K" +state real t_init ikj dyn_em 1 - ird "t_init" "initial potential temperature" "K" i1 real t_tend ikj dyn_em 1 - i1 real t_tendf ikj dyn_em 1 - i1 real t_2save ikj dyn_em 1 - @@ -354,7 +370,7 @@ state real cfn1 - misc - - irh "cfn state integer step_number - misc - - ir "step_number" "" # Idealized run -state logical this_is_an_ideal_run - misc - - r "this_is_an_ideal_run" "T/F flag: this is an ARW ideal simulation" +state logical this_is_an_ideal_run - misc - - irh "this_is_an_ideal_run" "T/F flag: this is an ARW ideal simulation" # For the adaptive timestep restart state logical stepping_to_time - misc - - r "stepping_to_time" "" @@ -380,12 +396,14 @@ state real PSFC ij misc 1 - i01rhdu "P # with wave model, only if compiled with -DMCELIO, JM 2003/05/29 state real U10 ij misc 1 - irh01du "U10" "U at 10 M" "m s-1" state real V10 ij misc 1 - irh01du "V10" "V at 10 M" "m s-1" +# LPI +state real LPI ij misc 1 - rhdu "LPI" "Lightning Potential Index" "m^2 s-2" # these next 4 are for observational nudging state real uratx ij misc 1 - r "URATX" "Ratio of U over U10 on mass points " "dimensionless" state real vratx ij misc 1 - r "VRATX" "Ratio of V over V10 on mass points " "dimensionless" state real tratx ij misc 1 - r "TRATX" "Ratio of T over TH2 on mass points " "dimensionless" -state real obs_savwt hikj dyn_em 1 X - "OBS_SAVWT" +state real obs_savwt hikj dyn_em 1 X - "OBS_SAVWT" "Internal space holding weights of each ob, for each i,j,k" "dimensionless" # Other state real rdx - misc - - irh "rdx" "INVERSE X GRID LENGTH" "" @@ -406,7 +424,7 @@ state real power ij misc 1 - irh "Pow # State for derived time quantities. state integer itimestep - - - - rh "itimestep" "" "" -state real xtime - - - - rh "xtime" "minutes since simulation start" "" +state real xtime - - - - rh "xtime" "minutes since YYYY-MM-DD hh:mm:ss" "minutes since simulation start" state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" # input file descriptor for lbcs on parent domain @@ -470,7 +488,8 @@ state real dfi_qg ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QGRAUP" "Graupel mixing ratio" "kg kg-1" state real dfi_qh ikjftb dfi_moist 1 - \ rusdf=(bdy_interp:dt) "DFI_QHAIL" "Hail mixing ratio" "kg kg-1" -state real rimi ikj misc 1 - irh "RIMI" "riming intensity" "fraction" +state real qvold ikj misc 1 - rdu "QVOLD" "Water vapor mixing ratio, old time step" "kg kg-1" +state real rimi ikj misc 1 - irh "RIMI" "riming intensity" "fraction" state real qnwfa2d ij misc 1 - rhdu "QNWFA2D" "Surface aerosol number conc emission" "kg-1 s-1" state real re_cloud ikj misc 1 - r "RE_CLOUD" "Effective radius cloud water" "m" state real re_ice ikj misc 1 - r "RE_ICE" "Effective radius cloud ice" "m" @@ -508,9 +527,8 @@ state real qnifa ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" state real qvolg ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" -#state real qvolh ikjftb scalar 1 - \ - i0rhusdf=(bdy_interp:dt) "QVHAIL" "Hail Particle Volume" "m(3) kg(-1)"" - +state real qvolh ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QVHAIL" "Hail Particle Volume" "m(3) kg(-1)" state real - ikjftb dfi_scalar 1 - - - state real dfi_qndrop ikjftb dfi_scalar 1 - \ @@ -537,7 +555,7 @@ state real dfi_qnifa ikjftb dfi_scalar 1 - \ i0rhusdf=(bdy_interp:dt) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" state real dfi_qvolg ikjftb dfi_scalar 1 - \ rhusdf=(bdy_interp:dt) "DFI_QVGRAUPEL" "DFI Graupel Particle Volume" "m(3) kg(-1)" -#state real dfi_qvolh ikjftb dfi_scalar 1 - \ +state real dfi_qvolh ikjftb dfi_scalar 1 - \ rhusdf=(bdy_interp:dt) "DFI_QVHAIL" "DFI Hail Particle Volume" "m(3) kg(-1)" #----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -614,9 +632,9 @@ state real shdmin ij misc 1 - i012rhd=(inte state real snoalb ij misc 1 - i012rh "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" state real slopecat ij misc 1 - i12 "SLOPECAT" "SLOPE CATEGORY" "" state real toposoil ij misc 1 - i12 "SOILHGT" "ELEVATION OF LSM DATA" "m" -state real landusef iuj misc 1 Z i012r "LANDUSEF" "LANDUSE FRACTION BY CATEGORY" "" -state real soilctop isj misc 1 Z i012r "SOILCTOP" "SOIL CAT FRACTION (TOP)" "" -state real soilcbot isj misc 1 Z i012r "SOILCBOT" "SOIL CAT FRACTION (BOTTOM)" "" +state real landusef iuj misc 1 Z i012rdu "LANDUSEF" "LANDUSE FRACTION BY CATEGORY" "" +state real soilctop isj misc 1 Z i012rdu "SOILCTOP" "SOIL CAT FRACTION (TOP)" "" +state real soilcbot isj misc 1 Z i012rdu "SOILCBOT" "SOIL CAT FRACTION (BOTTOM)" "" state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" @@ -656,9 +674,9 @@ state real ts_qv_profile ?!k misc - - - "TS state real DZR l em - Z r "DZR" "THICKNESSES OF ROOF LAYERS" "m" state real DZB l em - Z r "DZB" "THICKNESSES OF WALL LAYERS" "m" state real DZG l em - Z r "DZG" "THICKNESSES OF ROAD LAYERS" "m" -state real URB_PARAM i{urb}j misc 1 - i1d=(interp_fcni)u=(copy_fcni) "URB_PARAM" "NUDAPT_NBSD Urban Parameters" "parameter" +state real URB_PARAM i{urb}j misc 1 - i1 "URB_PARAM" "NUDAPT_NBSD Urban Parameters" "parameter" state real LP_URB2D ij misc 1 - i0 "BUILD_AREA_FRACTION" "BUILDING PLAN AREA DENSITY" "dimensionless" -state real HI_URB2D i{uhi}j misc 1 Z i0 "HEIGHT_HISTOGRAMS" "DISTRIBUTION OF BUILDING HEIGHTS" "dimensionless" +state real HI_URB2D i{uhi}j misc 1 Z i0 "HEIGHT_HISTOGRAMS" "DISTRIBUTION OF BUILDING HEIGHTS" "dimensionless" state real LB_URB2D ij misc 1 - i0 "BUILD_SURF_RATIO" "BUILDING SURFACE AREA TO PLAN AREA RATIO" "dimensionless" state real HGT_URB2D ij misc 1 - i0 "BUILD_HEIGHT" "AVERAGE BUILDING HEIGHT WEIGHTED BY BUILDING PLAN AREA" "m" state real FAD0_URB2D i{uhi}j misc 1 Z - "FAD0_URB2D" "Frontal Area Density from the 0 Degree Wind Direction" "m-1" @@ -719,7 +737,7 @@ state integer IFNDSNOWSI - misc 1 - ir "F state integer IFNDICEDEPTH - misc 1 - ir "FNDICEDEPTH" "ICEDEPTH_LOGICAL" # SKIN SST state real SSTSK ij misc 1 - rhd=(interp_mask_field:lu_index,iswater) "SSTSK" "SKIN SEA SURFACE TEMPERATURE" "K" -state real lake_depth ij misc 1 - i012rd=(interp_mask_water_field:lu_index,iswater) "lake_depth" "lake depth" "m" +state real lake_depth ij misc 1 - i012rd=(interp_mask_water_field:lu_index,islake) "lake_depth" "lake depth" "m" state real DTW ij misc 1 - r "DTW" "WARM LAYER TEMP DIFF" "C" # Ocean surface currents state real UOCE ij misc 1 - i0124rd=(interp_mask_water_field:lu_index,iswater) "UOCE" "SEA SURFACE ZONAL CURRENTS" "m s-1" @@ -755,6 +773,7 @@ state real dfi_KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DF # urban state variables state real TR_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TR_URB" "URBAN ROOF SKIN TEMPERATURE" "K" +state real TGR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TGR_URB" "URBAN GREEN ROOF SKIN TEMPERATURE" "K" state real TB_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TB_URB" "URBAN WALL SKIN TEMPERATURE" "K" state real TG_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TG_URB" "URBAN ROAD SKIN TEMPERATURE" "K" state real TC_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TC_URB" "URBAN CANOPY TEMPERATURE" "K" @@ -764,6 +783,15 @@ state real XXXR_URB2D ij misc 1 - rd=(interp_m state real XXXB_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "XXXB_URB" "M-O LENGTH ABOVE URBAN WALL" "dimensionless" state real XXXG_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "XXXG_URB" "M-O LENGTH ABOVE URBAN ROAD" "dimensionless" state real XXXC_URB2D ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "XXXC_URB" "M-O LENGTH ABOVE URBAN CANOPY" "dimensionless" +state real CMCR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "CMCR_URB" "GREEN ROOF CANOPY INTERCAPTED WATER" "m" +state real DRELR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "DRELR_URB" "WATER HOLDING DEPTH ON ROOF IMPERVIOUS SURFACE" "m" +state real DRELB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "DRELB_URB" "WATER HOLDING DEPTH ON WALL IMPERVIOUS SURFACE" "m" +state real DRELG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "DRELG_URB" "WATER HOLDING DEPTH ON ROAD IMPERVIOUS SURFACE" "m" +state real FLXHUMR_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "FLXHUMR_URB" "WATER FLUX ON ROOF IMPERVIOUS SURFACE" "m/s" +state real FLXHUMB_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "FLXHUMB_URB" "WATER FLUX ON WALL IMPERVIOUS SURFACE" "m/s" +state real FLXHUMG_URB2D ij misc 1 - rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "FLXHUMG_URB" "WATER FLUX ON ROAD IMPERVIOUS SURFACE" "m/s" +state real TGRL_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "TGRL_URB" "GREEN ROOF LAYER TEMPERATURE" +state real SMR_URB3D ilj misc 1 Z rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SMR_URB" "GREEN ROOF LAYER SOIL MOISTURE" state real TRL_URB3D ilj misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TRL_URB" "ROOF LAYER TEMPERATURE" "K" state real TBL_URB3D ilj misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TBL_URB" "WALL LAYER TEMPERATURE" "K" state real TGL_URB3D ilj misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TGL_URB" "ROAD LAYER TEMPERATURE" "K" @@ -799,6 +827,8 @@ state real CMR_SFCDIF ij misc 1 - r "C state real CHR_SFCDIF ij misc 1 - r "CHR_SFCDIF" "" "" state real CMC_SFCDIF ij misc 1 - r "CMC_SFCDIF" "" "" state real CHC_SFCDIF ij misc 1 - r "CHC_SFCDIF" "" "" +state real CMGR_SFCDIF ij misc 1 - r "CMGR_SFCDIF" "" "" +state real CHGR_SFCDIF ij misc 1 - r "CHGR_SFCDIF" "" "" # solar location variables from radiation driver @@ -808,6 +838,9 @@ state real DECLIN - misc 1 - r "DE state real SOLCON - misc 1 - r "SOLCON" "SOLAR CONSTANT" "W m-2" # RUC LSM +state real RHOSNF ij misc 1 - irh "RHOSNF" "DENSITY OF FROZEN PRECIP" "kg/m^3" +state real SNOWFALLAC ij misc 1 - irh "SNOWFALLAC" "RUN-TOTAL ACCUMULATED SNOWFALL [mm]" "" +state real PRECIPFR ij misc 1 - - "PRECIPFR" "TIME-STEP FROZEN PRECIP [mm]" "" state real SMFR3D ilj misc 1 Z r "SMFR3D" "SOIL ICE" "" state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" @@ -822,14 +855,16 @@ state real ALSWNIRDIF ij misc 1 Z r "A # Additional for P-X PBL and LSM -state real RA ij misc 1 - r "RA" "AERODYNAMIC RESISTANCE" "s m-1" -state real RS ij misc 1 - r "RS" "SURFACE RESISTANCE" "s m-1" -state real LAI ij misc 1 - i0124rh "LAI" "LEAF AREA INDEX" "m-2/m-2" -state real VEGF_PX ij misc 1 - r "VEGF_PX" "Vegetation Fraction for PX LSM" "area/area" -state real T2OBS ij misc 1 - r "T2OBS" "2-m temperature from analysis " "K" -state real Q2OBS ij misc 1 - r "Q2OBS" "2-m mixing ratio from analysis " "kg/kg" - -# MRF PBL variables +state real RA ij misc 1 - r "RA" "AERODYNAMIC RESISTANCE" "s m-1" +state real RS ij misc 1 - r "RS" "SURFACE RESISTANCE" "s m-1" +state real LAI ij misc 1 - i0124rh "LAI" "LEAF AREA INDEX" "m-2/m-2" +state real VEGF_PX ij misc 1 - rh "VEGF_PX" "Vegetation Fraction for PX LSM" "area/area" +state real T2OBS ij misc 1 - r "T2OBS" "2-m temperature from analysis " "K" +state real Q2OBS ij misc 1 - r "Q2OBS" "2-m mixing ratio from analysis " "kg/kg" +state real IMPERV ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "IMPERV" "Impervious surface fraction NLCD" "percent" +state real CANFRA ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "CANFRA" "Satellite canopy fraction" "percent" + +# sfclay PBL variables i1 real PSIM ij misc 1 - - "PSIM" "SIMILARITY FUNCTION FOR MOMENTUM" "" i1 real PSIH ij misc 1 - - "PSIH" "SIMILARITY FUNCTION FOR HEAT" "" state real FM ij misc 1 - - "FM" "INTEGRATED FUNCTION FOR MOMENTUM" "" @@ -837,6 +872,7 @@ state real FH ij misc 1 - - "FH" i1 real WSPD ij misc 1 - - "WSPD" "Wind speed" "m s-1" i1 real GZ1OZ0 ij misc 1 - - "GZ1OZ0" "LOG OF Z1 over Z0" "" i1 real BR ij misc 1 - - "BR" "Bulk Richardson" "" +state real ZOL ij misc 1 - - "ZOL" "z/L" "" # ysupbl variables for grims shallow convection state real WSTAR_YSU ij misc 1 - - "WSTAR_YSU" "mixed-layer velocity scale from ysupbl" "m/s" @@ -855,6 +891,10 @@ state real QSFC ij misc 1 - r "QS state real AKHS ij misc 1 - r "AKHS" "SFC EXCH COEFF FOR HEAT" "m s-1" state real AKMS ij misc 1 - r "AKMS" "SFC EXCH COEFF FOR MOMENTUM" "m s-1" state integer KPBL ij misc 1 - r "KPBL" "LEVEL OF PBL TOP" "" +#BSINGH - For CuP +#~wig: added real pbl level index for output tests +state real AKPBL ij misc 1 - r "AKPBL" "LEVEL OF PBL TOP" "" +#BSINGH - ENDS state real TSHLTR ij misc 1 - r "TSHLTR" "SHELTER THETA FROM MYJ" "K" state real QSHLTR ij misc 1 - r "QSHLTR" "SHELTER SPECIFIC HUMIDITY FROM MYJ" "kg kg-1" state real PSHLTR ij misc 1 - r "PSHLTR" "SHELTER PRESSURE FROM MYJ" "Pa" @@ -1050,8 +1090,48 @@ state real OM_ML ij misc 1 - i012rhdu=(cop state real OM_TINI i{nocnl}j misc 1 Z i012rd "OM_TINI" "temperature init" "k" state real OM_SINI i{nocnl}j misc 1 Z i012rd "OM_SINI" "salinity init" "degree" +#BSINGH - added CuP related variables +# CuP fair-weather cumulus scheme variables; wig, 4-Aug-2006 +# The slopes and sigmas are really only needed for testing so they can +# be dropped to i1 level, or even a simple real within cup_driver, once +# they are no longer desired for output. +state logical cupflag ij misc 1 - r "CUPFLAG" "CuP scheme activavted, T=yes, F=no" "" +state real slopesfc ij misc 1 - r "SLOPESFC" "Slope of surface layer dTheta/dMixRatio" "K" +state real slopeez ij misc 1 - r "SLOPEEZ" "Slope of entrainment layer dTheta/dMixRatio" "K" +state real sigmasfc ij misc 1 - r "SIGMASFC" "Std. dev. of surface layer dTheta/dMixRatio" "K kg kg-1" +state real sigmaez ij misc 1 - r "SIGMAEZ" "Std. dev. of entrainment layer dTheta/dMixRatio" "K kg kg-1" +state real shall ij misc 1 - r "SHALL" "Cumulus type, 0=deep, 1=shallow, 2=none" "" +state real taucloud ij misc 1 - r "TAUCLOUD" "CuP cloud time scale for lifetime" "" +state real tactive ij misc 1 - r "TACTIVE" "CuP cloud formation time scale" "" +state real tcloud_cup ij misc 1 - r "TCLOUD_CUP" "CuP cloud duration for modifying T,QV,chem,etc" "" +state real wCloudBase ij misc 1 - r "wCloudBase" "CuP cloud base vertical velocity" "" +state real activeFrac ij misc 1 - r "activeFrac" "Fraction of PDF the forms clouds" "fraction" +state real cldfratend_cup ikj misc 1 - r "CLDFRATEND_CUP" "Cloud fraction tendency due to CuP Scheme" "fraction" +state real cldfra_cup ikj misc 1 - r "CLDFRA_CUP" "Cloud fraction due to CuP Scheme" "fraction" +state real updfra_cup ikj misc 1 - r "UPDFRA_CUP" "Updraft fractional area due to CuP Scheme" "fraction" +state real qc_iu_cup ikj misc 1 - r "QC_IU_CUP" "Cloud water due to CuP Scheme (in cumulus updraft)" "kg kg-1" +state real qc_ic_cup ikj misc 1 - r "QC_IC_CUP" "Cloud water due to CuP Scheme (in cumulus cloud)" "kg kg-1" +state real qndrop_ic_cup ikj misc 1 - r "QNDROP_IC_CUP" "Cloud droplet number due to CuP Scheme (in cumulus cloud)" "# kg-1" +state real wup_cup ikj misc 1 - r "WUP_CUP" "Updraft vertical velocity" "m s-1" +state real wact_cup ij misc 1 - r "WACT_CUP" "CuP cloud base vertical velocity for activation" "m s-1" +state real wulcl_cup ij misc 1 - r "WULCL_CUP" "CuP updraft vertical velocity at top of first cloud layer" "m s-1" +state real mfup_cup ikj misc 1 - r "MFUP_CUP" "Updraft mass flux for shallow-cu in CuP Scheme" "kg m-2 s-1" +state real mfup_ent_cup ikj misc 1 - r "MFUP_ENT_CUP" "Updraft mass flux entrainment (across layer) for shallow-cu in CuP Scheme" "kg m-2 s-1" +state real mfdn_cup ikj misc 1 - r "MFDN_CUP" "Downdraft mass flux for shallow-cu in CuP Scheme" "kg m-2 s-1" +state real mfdn_ent_cup ikj misc 1 - r "MFDN_ENT_CUP" "Downdraft mass flux entrainment (across layer) for shallow-cu in CuP Scheme" "kg m-2 s-1" +state real fcvt_qc_to_pr_cup ikj misc 1 - r "FCVT_QC_TO_PR_CUP" "Fraction of cloudwater converted to precip. as air rises thru an updraft layer" "--" +state real fcvt_qc_to_qi_cup ikj misc 1 - r "FCVT_QC_TO_QI_CUP" "Fraction of cloudwater converted to cloudice as air rises thru an updraft layer" "--" +state real fcvt_qi_to_pr_cup ikj misc 1 - r "FCVT_QI_TO_PR_CUP" "Fraction of cloudice converted to precip. as air rises thru an updraft layer" "--" +state real tstar ij misc 1 - r "TSTAR" "Boundary layer time scale" "s" +state real lnterms ikj misc 1 - r "LNTERMS" "Liquid+ice+1 ln term for cloud fraction" "" +state real lnint ij misc 1 - r "LNINT" "Integrated ln term for cloud fraction" "" +#BSINGH - adde CuP related variables -ENDS + + # Other Misc State Variables state real h_diabatic ikj misc 1 - rdu "h_diabatic" "MICROPHYSICS LATENT HEATING" "K s-1" +state real qv_diabatic ikj misc 1 - rdu "qv_diabatic" "MICROPHYSICS QV TENDENCY" "g g-1 s-1" +state real qc_diabatic ikj misc 1 - rdu "qc_diabatic" "MICROPHYSICS QC TENDENCY" "g g-1 s-1" state real msft ij misc 1 - i012rhdu=(copy_fcnm) "MAPFAC_M" "Map scale factor on mass grid" "" state real msfu ij misc 1 X i012rhdu=(copy_fcnm) "MAPFAC_U" "Map scale factor on u-grid" "" state real msfv ij misc 1 Y i012rhdu=(copy_fcnm) "MAPFAC_V" "Map scale factor on v-grid" "" @@ -1079,7 +1159,7 @@ state integer min_ptchsz - misc 1 - r state real TSK ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TSK" "SURFACE SKIN TEMPERATURE" "K" state real dfi_TSK ij misc 1 - r "TSK_dfi" "saved SURFACE SKIN TEMPERATURE" -state real TSK_SAVE ij misc 1 - - "TSK_SAVE" "SURFACE SKIN TEMPERATURE, EXTRA COPY FOR SEA ICE TESTS in REAL" "K" +state real TSK_SAVE ij misc 1 - r "TSK_SAVE" "SURFACE SKIN TEMPERATURE, EXTRA COPY FOR SEA ICE TESTS in REAL" "K" state real u_base k misc 1 - ir "u_base" "BASE STATE X WIND IN IDEALIZED CASES" "" state real v_base k misc 1 - ir "v_base" "BASE STATE Y WIND IN IDEALIZED CASES" "" state real qv_base k misc 1 - ir "qv_base" "BASE STATE QV IN IDEALIZED CASES" "" @@ -1095,12 +1175,52 @@ state real v_frame - misc 1 - ir "v # collision between a metadata name and a field record in the I/O data # resolve this how? Have the real program throw a switch to tell the code to get it # from the metadata? Otherwise it's a field? -state logical just_read_auxinput4 - misc - - r "we_just_read_sst" "1=AUXINPUT4 ALARM RINGING, 0=NO AUXINPUT4 ALARM" "-" -state real p_top - misc - - irh "p_top" "PRESSURE TOP OF THE MODEL" "Pa" +state logical just_read_auxinput4 - misc - - r "we_just_read_sst" "1=AUXINPUT4 ALARM RINGING, 0=NO AUXINPUT4 ALARM" "-" +state logical just_read_boundary - misc - - r "we_just_d01_LBC" "1=BOUNDARY ALARM RINGING, 0=NO BOUNDARY ALARM" "-" +state real mf_fft - misc - - r "mf_fft" "Mass point map factor at equatorward FFT filter location" "" +state real p_top - misc - - irh "p_top" "PRESSURE TOP OF THE MODEL" "Pa" + +#BSINGH - Adding all these variables for CuP scheme[any var before t00] +state real lat_ll_t - dyn_em - - ir "lat_ll_t" "latitude lower left, temp point" "degrees" +state real lat_ul_t - dyn_em - - ir "lat_ul_t" "latitude up left, temp point" "degrees" +state real lat_ur_t - dyn_em - - ir "lat_ur_t" "latitude up right, temp point" "degrees" +state real lat_lr_t - dyn_em - - ir "lat_lr_t" "latitude lower right, temp point" "degrees" +state real lat_ll_u - dyn_em - - ir "lat_ll_u" "latitude lower left, u point" "degrees" +state real lat_ul_u - dyn_em - - ir "lat_ul_u" "latitude up left, u point" "degrees" +state real lat_ur_u - dyn_em - - ir "lat_ur_u" "latitude up right, u point" "degrees" +state real lat_lr_u - dyn_em - - ir "lat_lr_u" "latitude lower right, u point" "degrees" +state real lat_ll_v - dyn_em - - ir "lat_ll_v" "latitude lower left, v point" "degrees" +state real lat_ul_v - dyn_em - - ir "lat_ul_v" "latitude up left, v point" "degrees" +state real lat_ur_v - dyn_em - - ir "lat_ur_v" "latitude up right, v point" "degrees" +state real lat_lr_v - dyn_em - - ir "lat_lr_v" "latitude lower right, v point" "degrees" +state real lat_ll_d - dyn_em - - ir "lat_ll_d" "latitude lower left, massless point" "degrees" +state real lat_ul_d - dyn_em - - ir "lat_ul_d" "latitude up left, massless point" "degrees" +state real lat_ur_d - dyn_em - - ir "lat_ur_d" "latitude up right, massless point" "degrees" +state real lat_lr_d - dyn_em - - ir "lat_lr_d" "latitude lower right, massless point" "degrees" +state real lon_ll_t - dyn_em - - ir "lon_ll_t" "longitude lower left, temp point" "degrees" +state real lon_ul_t - dyn_em - - ir "lon_ul_t" "longitude up left, temp point" "degrees" +state real lon_ur_t - dyn_em - - ir "lon_ur_t" "longitude up right, temp point" "degrees" +state real lon_lr_t - dyn_em - - ir "lon_lr_t" "longitude lower right, temp point" "degrees" +state real lon_ll_u - dyn_em - - ir "lon_ll_u" "longitude lower left, u point" "degrees" +state real lon_ul_u - dyn_em - - ir "lon_ul_u" "longitude up left, u point" "degrees" +state real lon_ur_u - dyn_em - - ir "lon_ur_u" "longitude up right, u point" "degrees" +state real lon_lr_u - dyn_em - - ir "lon_lr_u" "longitude lower right, u point" "degrees" +state real lon_ll_v - dyn_em - - ir "lon_ll_v" "longitude lower left, v point" "degrees" +state real lon_ul_v - dyn_em - - ir "lon_ul_v" "longitude up left, v point" "degrees" +state real lon_ur_v - dyn_em - - ir "lon_ur_v" "longitude up right, v point" "degrees" +state real lon_lr_v - dyn_em - - ir "lon_lr_v" "longitude lower right, v point" "degrees" +state real lon_ll_d - dyn_em - - ir "lon_ll_d" "longitude lower left, massless point" "degrees" +state real lon_ul_d - dyn_em - - ir "lon_ul_d" "longitude up left, massless point" "degrees" +state real lon_ur_d - dyn_em - - ir "lon_ur_d" "longitude up right, massless point" "degrees" +state real lon_lr_d - dyn_em - - ir "lon_lr_d" "longitude lower right, massless point" "degrees" +#BSINGH -ENDS + state real t00 - misc - - i02rh "t00" "BASE STATE TEMPERATURE " "K" state real p00 - misc - - i02rh "p00" "BASE STATE PRESURE" "Pa" state real tlp - misc - - i02rh "tlp" "BASE STATE LAPSE RATE " "" state real tiso - misc - - i02rh "tiso" "TEMP AT WHICH THE BASE T TURNS CONST" "K" +state real tlp_strat - misc - - i02rh "tlp_strat" "BASE STATE LAPSE RATE (DT/D(LN(P)) IN STRATOSPHERE" "K" +state real p_strat - misc - - i02rh "p_strat" "BASE STATE PRESSURE AT BOTTOM OF STRATOSPHERE" "Pa" state real max_msftx - misc - - rh "max_mstfx" "Max map factor in domain" "" state real max_msfty - misc - - rh "max_mstfy" "Max map factor in domain" "" @@ -1157,13 +1277,14 @@ state real HAILNC ij misc 1 - rhdu "H state real SNOWNCV ij misc 1 - r "SNOWNCV" "TIME-STEP NONCONVECTIVE SNOW AND ICE" "mm" state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" state real HAILNCV ij misc 1 - r "HAILNCV" "TIME-STEP NONCONVECTIVE HAIL" "mm" -state real refl_10cm ikj dyn_em 1 - hdu "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" +state real refl_10cm ikj dyn_em 1 - hdu "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" state real NCA ij misc 1 - r "NCA" "COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME" "" state integer LOWLYR ij misc 1 - - "LOWLYR" "INDEX OF LOWEST MODEL LAYER ABOVE THE GROUND IN BMJ SCHEME" "" state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb hour-1" # ckay -state real cldfra_dp ikj misc 1 - - "CLDFRA_DP" "DEEP CONVECTIVE CLOUD FRACTION FROM KF" "" -state real cldfra_sh ikj misc 1 - - "CLDFRA_SH" "SHALLOW CONVECTIVE CLOUD FRACTION FROM KF" "" +state real cldfra_dp ikj misc 1 - r "CLDFRA_DP" "DEEP CONVECTIVE CLOUD FRACTION FROM KF" "" +state real cldfra_sh ikj misc 1 - r "CLDFRA_SH" "SHALLOW CONVECTIVE CLOUD FRACTION FROM KF" "" +state real w_up ikj misc 1 - rdu "W_UP" "EFFECTIVE SUBGRID VELOCITY FROM KF" "m s-1" state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL" "mm hour-1" state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W" "mm hour-1" state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm hour-1" @@ -1209,23 +1330,26 @@ state real RTHRATENLW ikj misc 1 - r "R state real RTHRATENSW ikj misc 1 - r "RTHRATSW" "UNCOUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION" "K s-1" state real CLDFRA ikj misc 1 - rh "CLDFRA" "CLOUD FRACTION" "" state real CLDFRA_OLD ikj misc 1 - r "CLDFRA_OLD" "previous time level cldfra" "" - +state real CLDT ij misc 1 - - "CFRACT" "TOTAL CLOUD FRACTION" "" +#state real CLDL ij misc 1 - - "CFRACL" "LOW CLOUD FRACTION (ETA GREATER THAN 0.69)" "" +#state real LWP ij misc 1 - - "LWP" "LIQUID CLOUD WATER PATH" "kg m-2" state real SWDOWN ij misc 1 - rhd "SWDOWN" "DOWNWARD SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real SWDOWNC ij misc 1 - - "SWDOWNC" "DOWNWARD CLEAR-SKY SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GSW ij misc 1 - rd "GSW" "NET SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GLW ij misc 1 - rhd "GLW" "DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" state real SWNORM ij misc 1 - rhd "SWNORM" "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)" "W m-2" +state real diffuse_frac ij misc 1 - rhd "DIFFUSE_FRAC" "DIFFUSE FRACTION OF SURFACE SHORTWAVE IRRADIANCE" "" # WRF-Solar -state real swddir ij misc 1 - rd "SWDDIR" "Shortwave surface downward direct irradiance" "W/m^2" "" -state real swddni ij misc 1 - rd "SWDDNI" "Shortwave surface downward direct normal irradiance" "W/m^2" "" -state real swddif ij misc 1 - rd "SWDDIF" "Shortwave surface downward diffuse irradiance" "W/m^2" "" +state real swddir ij misc 1 - rd "SWDDIR" "Shortwave surface downward direct irradiance" "W m-2" "" +state real swddni ij misc 1 - rd "SWDDNI" "Shortwave surface downward direct normal irradiance" "W m-2" "" +state real swddif ij misc 1 - rd "SWDDIF" "Shortwave surface downward diffuse irradiance" "W m-2" "" state real Gx ij misc 1 - rd "Gx" "" "" state real Bx ij misc 1 - rd "Bx" "" "" state real gg ij misc 1 - rd "gg" "" "" state real bb ij misc 1 - rd "bb" "" "" -state real coszen_ref ij misc 1 - - "coszen_ref" "" "" -state real swdown_ref ij misc 1 - - "swdown_ref" "" "" -state real swddir_ref ij misc 1 - - "swddir_ref" "" "" +state real coszen_ref ij misc 1 - rd "coszen_ref" "" "" +state real swdown_ref ij misc 1 - rd "swdown_ref" "" "" +state real swddir_ref ij misc 1 - rd "swddir_ref" "" "" # jararias 2013/11 state real aod5502d ij misc 1 - i{15}r "AOD5502D" "Total aerosol optical depth at 550 nm" "" state real angexp2d ij misc 1 - i{15}r "ANGEXP2D" "Aerosol Angstrom exponent" "" @@ -1270,6 +1394,7 @@ state real RAINCVMEAN ij misc 1 - rh3 "R state real RAINNCVMEAN ij misc 1 - rh3 "RAINNCVMEAN" "MEAN GRID SCALE PRECIPITATION FLUX IN DIAGNOSTIC OUTPUT INTERVAL" "kg m-2 s-1" state real RAINCVSTD ij misc 1 - rh3 "RAINCVSTD" "STANDARD DEV. CUMULUS PRECIPITATION FLUX IN DIAGNOSTIC OUTPUT INTERVAL" "kg m-2 s-1" state real RAINNCVSTD ij misc 1 - rh3 "RAINNCVSTD" "STANDARD DEV. GRID SCALE PRECIPITATION IN FLUX DIAGNOSTIC OUTPUT INTERVAL" "kg m-2 s-1" +state integer nsteps - misc - - r "NSTEPS" "Time Step Counter" "" # upward and downward clearsky and total diagnostic fluxes for CAM radiation state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" @@ -1321,8 +1446,8 @@ state real LWUPBC ij misc 1 - rhdu "L state real LWDNB ij misc 1 - rhdu "LWDNB" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" state real LWDNBC ij misc 1 - rhdu "LWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2" -state real SWCF ij misc 1 - r "SWCF" "SHORT WAVE CLOUD FORCING AT TOA" "W m-2" -state real LWCF ij misc 1 - r "LWCF" "LONG WAVE CLOUD FORCING AT TOA" "W m-2" +state real SWCF ij misc 1 - r "SWCF" "SHORT WAVE CLOUD FORCING AT TOA" "W m-2" +state real LWCF ij misc 1 - r "LWCF" "LONG WAVE CLOUD FORCING AT TOA" "W m-2" state real OLR ij misc 1 - rh "OLR" "TOA OUTGOING LONG WAVE" "W m-2" # these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling @@ -1490,7 +1615,7 @@ state real G_URB2D_mosaic i{mocat}j misc 1 - r state real RN_URB2D_mosaic i{mocat}j misc 1 - r "RN_URB2D_mosaic" "NET RADIATION" "W m-2" state integer mosaic_cat_index iuj misc 1 Z i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "mosaic_cat_index" " " "" -state real landusef2 iuj misc 1 Z i012rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "LANDUSEF2" "sorted landuse fraction" "" +state real landusef2 iuj misc 1 Z i012rdu "LANDUSEF2" "sorted landuse fraction" "" # State vector for etampnew microphysics. Must be declared state because it is not read-once and is needed for restarting. state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" @@ -1522,12 +1647,12 @@ state real TMN ij misc 1 - i012rhd=(int state real TYR ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TYR" "ANNUAL MEAN SFC TEMPERATURE" "K" state real TYRA ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TYRA" "ACCUMULATED YEARLY SFC TEMPERATURE FOR CURRENT YEAR" "K" state real TDLY ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TDLY" "ACCUMULATED DAILY SFC TEMPERATURE FOR CURRENT DAY" "K" -state real TLAG i&j misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TLAG" "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS" "K" +state real TLAG i&j misc 1 - d=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TLAG" "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS" "K" state integer NYEAR - misc 1 - r "NYEAR" "ACCUM DAYS IN A YEAR" "" state real NDAY - misc 1 - r "NDAY" "ACCUM TIMESTEPS IN A DAY" "" state real XLAND ij misc 1 - i02rhd=(interp_fcnm_imask)u=(copy_fcnm) "XLAND" "LAND MASK (1 FOR LAND, 2 FOR WATER)" "" state real cplmask i{ncpldom}j misc 1 z i0r "CPLMASK" "COUPLING MASK (0:VALUE FROM SST UPDATE; 1:VALUE FROM COUPLED OCEAN), vertical dim is number of external domains" "" -state real ZNT ij misc 1 - i3r "ZNT" "TIME-VARYING ROUGHNESS LENGTH" "m" +state real ZNT ij misc 1 - i3r "ZNT" "TIME-VARYING ROUGHNESS LENGTH" "m" state real CK ij misc 1 - r "CK" "ENTHALPY EXCHANGE COEFF AT 10 m" "" state real CKA ij misc 1 - r "CKA" "ENTHALPY EXCHANGE COEFF AT LOWEST MODEL LVL" "" state real CD ij misc 1 - r "CD" "DRAG COEFF AT 10m" "" @@ -1544,6 +1669,8 @@ state real HFX ij misc 1 - rh "H state real QFX ij misc 1 - rh "QFX" "UPWARD MOISTURE FLUX AT THE SURFACE" "kg m-2 s-1" state real LH ij misc 1 - rh "LH" "LATENT HEAT FLUX AT THE SURFACE" "W m-2" state real ACHFX ij misc 1 - rhdu "ACHFX" "ACCUMULATED UPWARD HEAT FLUX AT THE SURFACE" "J m-2" +#BSINGH - Added WSTAR for CuP scheme +state real WSTAR ij misc 1 - - "WSTAR" "DEARDORFF CONVECTIVE VELOCITY SCALE" "m s-1" state real ACLHF ij misc 1 - rhdu "ACLHF" "ACCUMULATED UPWARD LATENT HEAT FLUX AT THE SURFACE" "J m-2" state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" @@ -1557,7 +1684,7 @@ state real dfi_SOILT1 ij misc 1 - r "S state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" state real dfi_TSNAV ij misc 1 - r "TSNAV_dfi" "AVERAGE SNOW TEMPERATURE " "C" state real REGIME ij misc 1 - r "REGIME" "FLAGS: 1=Night/Stable, 2=Mechanical Turbulent, 3=Forced Conv, 4=Free Conv" "" -state real SNOWC ij misc 1 - irhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" +state real SNOWC ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" state real dfi_SNOWC ij misc 1 - r "SNOWC_dfi" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" state real MAVAIL ij misc 1 - r "MAVAIL" "SURFACE MOISTURE AVAILABILITY" "" @@ -1584,7 +1711,7 @@ state real div ikj misc 1 - r "d state real BN2 ikj misc 1 - r "BN2" "BRUNT-VAISALA FREQUENCY" "s-2" state logical warm_rain - misc 1 - - "warm_rain" "WARM_RAIN_LOGICAL" state logical adv_moist_cond - misc 1 - - "adv_moist_cond" "ADVECT MOIST CONDENSATES LOGICAL" -state integer save_topo_from_real - dyn_em 1 - irh "save_topo_from_real" "1=original topo from real/0=topo modified by WRF" "flag" +state integer save_topo_from_real - dyn_em 1 - i02rh "save_topo_from_real" "1=original topo from real/0=topo modified by WRF" "flag" ## FDDA variables @@ -1647,17 +1774,19 @@ state real pk1m ij misc 1 - - "p state real mu_2m ij misc 1 - - "mu_2m" "mu_2 at previous step" "Pa" # these are NSSL WRF diagnostics -state real WSPD10MAX ij misc 1 - rh "WSPD10MAX" "WIND SPD MAX 10 M" "m s-1" -state real W_UP_MAX ij misc 1 - rh "W_UP_MAX" "MAX Z-WIND UPDRAFT" "m s-1" -state real W_DN_MAX ij misc 1 - rh "W_DN_MAX" "MAX Z-WIND DOWNDRAFT" "m s-1" -state real REFD_MAX ij misc 1 - r "REFD_MAX" "MAX DERIVED RADAR REFL" "dbZ" -state real UP_HELI_MAX ij misc 1 - rh "UP_HELI_MAX" "MAX UPDRAFT HELICITY" "m2 s-2" +state real WSPD10MAX ij misc 1 - rh02 "WSPD10MAX" "WIND SPD MAX 10 M" "m s-1" +state real W_UP_MAX ij misc 1 - rh02 "W_UP_MAX" "MAX Z-WIND UPDRAFT" "m s-1" +state real W_DN_MAX ij misc 1 - rh02 "W_DN_MAX" "MAX Z-WIND DOWNDRAFT" "m s-1" +state real REFD_MAX ij misc 1 - rh02 "REFD_MAX" "MAX DERIVED RADAR REFL" "dbZ" +state real UP_HELI_MAX ij misc 1 - rh02 "UP_HELI_MAX" "MAX UPDRAFT HELICITY" "m2 s-2" state real W_MEAN ij misc 1 - rh "W_MEAN" "HOURLY MEAN Z-WIND" "m s-1" state real GRPL_MAX ij misc 1 - rh "GRPL_MAX" "MAX COL INT GRAUPEL" "kg m-2" state real UH ij misc 1 - r "UH" "UPDRAFT HELICITY" "m2 s-2" state real W_COLMEAN ij misc 1 - - "W_COLMEAN" "COLUMN MEAN Z-WIND" "m s-1" state real NUMCOLPTS ij misc 1 - - "NUMCOLPTS" "NUMBER OF COLUMN PTS" "dimensionless" state real GRPL_COLINT ij misc 1 - - "GRPL_COLINT" "COL INT GRAUPEL" "kg m-2" +state real HAIL_MAXK1 ij misc 1 - rh02 "HAIL_MAXK1" "MAX HAIL DIAMETER K=1" "m" +state real HAIL_MAX2D ij misc 1 - rh02 "HAIL_MAX2D" "MAX HAIL DIAMETER ENTIRE COLUMN" "m" state real max_cfl - misc 1 - - "max_cfl" "maximum CFL value in grid at a time" "-" @@ -1665,52 +1794,6 @@ state real prec_acc_c ij misc 1 - rh "pr state real prec_acc_nc ij misc 1 - rh "prec_acc_nc" "ACCUMULATED GRID SCALE PRECIPITATION OVER prec_acc_dt PERIODS OF TIME" "mm" state real snow_acc_nc ij misc 1 - rh "snow_acc_nc" "ACCUMULATED SNOW WATER EQUIVALENT OVER prec_acc_dt PERIODS OF TIME" "mm" -# GAC--> -# These variables are for the AFWA diagnostics package. Note, in V3.5, some of these have been added -# inside the NSSL WRF diagnostics (above), and have been commented out. We need to merge these -# diagnostics packages together as they are largely duplicated. GAC 20130724 -#state real WSPD10MAX ij misc 1 - rh "WSPD10MAX" "WIND SPD MAX 10 M" "m s-1" -#state real W_UP_MAX ij misc 1 - rh "W_UP_MAX" "MAX Z-WIND UPDRAFT" "m s-1" -#state real W_DN_MAX ij misc 1 - rh "W_DN_MAX" "MAX Z-WIND DOWNDRAFT" "m s-1" -#state real REFD_MAX ij misc 1 - rh02 "REFD_MAX" "MAX DERIVED RADAR REFL" "dbZ" -#state real UP_HELI_MAX ij misc 1 - rh "UP_HELI_MAX" "MAX UPDRAFT HELICITY" "m2 s-2" -#state real UH ij misc 1 - r "UH" "UPDRAFT HELICITY" "m2 s-2" -state real TCOLI_MAX ij misc 1 - rh "TCOLI_MAX" "MAX TOTAL COLUMN INTEGRATED ICE" "kg m-2" -state real REFD_COM ij misc 1 - rh02 "REFD_COM" "DERIVED COMPOSITE RADAR REFL" "dbZ" -state real REFD ij misc 1 - rh02 "REFD" "DERIVED RADAR REFL" "dbZ" -state real VIL ij misc 1 - rh02 "VIL" "VERTICALLY INTEGRATED LIQUID WATER" "kg m-2" -state real RADARVIL ij misc 1 - rh02 "RADARVIL" "VERTICALLY INTEGRATED LIQUID WATER FROM Ze" "kg m-2" -state real ECHOTOP ij misc 1 - rh02 "ECHOTOP" "ECHO TOP HEIGHT FROM Ze" "m" -state real FZLEV ij misc 1 - rh02 "FZLEV" "FREEZING LEVEL" "m" -state real ICINGTOP ij misc 1 - rh02 "ICINGTOP" "TOPMOST ICING LEVEL" "m" -state real ICINGBOT ij misc 1 - rh02 "ICINGBOT" "BOTTOMMOST ICING LEVEL" "m" -state real QICING_LG ikj misc 1 - r "QICING_LG" "SUPERCOOLED WATER MIXING RATIO (>50 um)" "kg kg-1" -state real QICING_SM ikj misc 1 - r "QICING_SM" "SUPERCOOLED WATER MIXING RATIO (<50 um)" "kg kg-1" -state real QICING_LG_MAX ij misc 1 - rh02 "QICING_LG_MAX" "COLUMN MAX ICING MIXING RATIO (>50 um)" "kg kg-1" -state real QICING_SM_MAX ij misc 1 - rh02 "QICING_SM_MAX" "COLUMN MAX ICING MIXING RATIO (<50 um)" "kg kg-1" -state real ICING_LG ij misc 1 - rh02 "ICING_LG" "TOTAL COLUMN INTEGRATED ICING (>50 um)" "kg m-2" -state real ICING_SM ij misc 1 - rh02 "ICING_SM" "TOTAL COLUMN INTEGRATED ICING (<50 um)" "kg m-2" -state real AFWA_PRECIP ij misc 1 - r "AFWA_PRECIP" "AFWA Diagnostic: Precipitation bucket" "mm" -state real AFWA_RAIN ij misc 1 - rh02 "AFWA_RAIN" "AFWA Diagnostic: Rain fall" "mm" -state real AFWA_SNOW ij misc 1 - rh02 "AFWA_SNOW" "AFWA Diagnostic: Liq Equiv Snow fall" "mm" -state real AFWA_ICE ij misc 1 - rh02 "AFWA_ICE" "AFWA Diagnostic: Ice fall" "mm" -state real AFWA_FZRA ij misc 1 - rh02 "AFWA_FZRA" "AFWA Diagnostic: Freezing rain fall" "mm" -state real AFWA_SNOWFALL ij misc 1 - rh02 "AFWA_SNOWFALL" "AFWA Diagnostic: Snow fall" "mm" -state real AFWA_VIS ij misc 1 - rh02 "AFWA_VIS" "AFWA Diagnostic: Visibility" "m" -state real AFWA_VIS_DUST ij misc 1 - rh02 "AFWA_VIS_DUST" "AFWA Diagnostic: Visibility due to dust" "m" -state real AFWA_CLOUD ij misc 1 - rh02 "AFWA_CLOUD" "AFWA Diagnostic: Cloud cover fraction" "fraction" -state real AFWA_CLOUD_CEIL ij misc 1 - rh02 "AFWA_CLOUD_CEIL" "AFWA Diagnostic: Cloud ceiling" "m" -state real AFWA_CAPE ij misc 1 - rh02 "AFWA_CAPE" "AFWA Diagnostic: Convective Avail Pot Energy" "J kg-1" -state real AFWA_ZLFC ij misc 1 - rh02 "AFWA_ZLFC" "AFWA Diagnostic: Level of Free Convection" "m" -state real AFWA_PLFC ij misc 1 - rh02 "AFWA_PLFC" "AFWA Diagnostic: Pressure of LFC" "Pa" -state real MIDRH_MIN ij misc 1 - rh02 "MIDRH_MIN" "Min Mid-level relative humidity" "%" -state real MIDRH_MIN_OLD ij misc 1 - - "MIDRH_MIN_OLD" "Previous Min Mid-level relative humidity" "%" -state real AFWA_HAIL ij misc 1 - rh02 "AFWA_HAIL" "AFWA Diagnostic: Hail Diameter (Weibull)" "mm" -state real AFWA_LLWS ij misc 1 - rh02 "AFWA_LLWS" "AFWA Diagnostic: 0-2000 ft wind shear" "m s-1" -state real AFWA_TORNADO ij misc 1 - rh02 "AFWA_TORNADO" "AFWA Diagnostic: Tornado wind speed (Weibull)" "m s-1" -# <--GAC - - # Placeholder for decoupled advective tendency diagnostics for non-chem state real - ikjf advh_t 1 - - - state real advh_qv ikjf advh_t 1 - - "advh_qv" "ACCUMULATED HORIZONTAL TENDENCY FOR WATER VAPOR" "kg kg-1" @@ -1744,6 +1827,7 @@ state real track_qice {tl}k misc 1 - - "trac state real track_qsnow {tl}k misc 1 - - "track_qsnow" "snow mixing ratio" "kg kg-1" state real track_qgraup {tl}k misc 1 - - "track_qgraup" "graupel mixing ratio" "kg kg-1" state real track_qvapor {tl}k misc 1 - - "track_qvapor" "water vapor mixing ratio" "kg kg-1" + # #--------------------------------------------------------------------------------------------------------------------------------------- # @@ -1799,6 +1883,15 @@ rconfig logical nocolons namelist,time_control 1 rconfig logical cycling namelist,time_control 1 .false. - "true for cycling (using wrfout file as input data)" rconfig integer output_diagnostics namelist,time_control 1 0 rconfig integer nwp_diagnostics namelist,time_control 1 0 +rconfig logical output_ready_flag namelist,time_control 1 .false. - "drop a flag called wrfoutReady_d_ after history write" "" "" + +pioprocs, piostart, piostride, pioshift +# PIO namelist +rconfig logical usepio namelist,pio_control 1 .false. rh "pioprocs" "" "" +rconfig integer pioprocs namelist,pio_control 1 0 rh "pioprocs" "" "" +rconfig integer piostart namelist,pio_control 1 1 rh "piostart" "" "" +rconfig integer piostride namelist,pio_control 1 1 rh "piostride" "" "" +rconfig integer pioshift namelist,pio_control 1 1 rh "pioshift" "" "" # DFI namelist rconfig integer dfi_opt namelist,dfi_control 1 0 rh "dfi_opt" "" "" @@ -1854,7 +1947,8 @@ rconfig integer num_metgrid_soil_levels namelist,domains 1 4 rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" rconfig logical interp_theta namelist,domains 1 .false. irh "interp_theta" "inside real, vertically interpolate theta (T) or temperature (F)" "" rconfig integer interp_type namelist,domains 1 2 irh "interp_type" "1=interp in pressure, 2=interp in LOG pressure" "" -rconfig integer vert_refine_fact namelist,domains 1 1 irh "vertical refinment factor for ndown" "" +rconfig integer vert_refine_method namelist,domains max_domains 0 irh "vert_refine_method" "0=no vertical nesting, 1=integer refinement, 2=native WRF" "" +rconfig integer vert_refine_fact namelist,domains 1 1 irh "vertical refinment factor for ndown or for vertical nesting in a concurrent run" "" "" rconfig integer extrap_type namelist,domains 1 2 irh "extrap_type" "1= use 2 lowest levels, 2=constant" "" rconfig integer t_extrap_type namelist,domains 1 2 irh "t_extrap_type" "1=isothermal, 2=6.5 K/km, 3=adiabatic" "" rconfig integer hypsometric_opt namelist,domains 1 2 irh "hypsometric_opt" "Z relates P, 1=linearly, 2=LOG-linearly" "" @@ -1862,13 +1956,17 @@ rconfig logical lowest_lev_from_sfc namelist,domains 1 .false. rconfig logical use_levels_below_ground namelist,domains 1 .true. irh "use_levels_below_ground" "T/F: use input data levels below input sfc pres" "" rconfig logical use_tavg_for_tsk namelist,domains 1 .false. irh "use_tavg_for_tsk" "T/F: use diurnal avg sfc temp for tsk" "" rconfig logical use_surface namelist,domains 1 .true. irh "use_surface" "T/F: use input surface level in interpolation" "" -rconfig integer lagrange_order namelist,domains 1 2 irh "lagrange_order" "1=linear, 2=quadratic vertical interpolation" "" +rconfig integer lagrange_order namelist,domains 1 2 irh "lagrange_order" "1=linear, 2=quadratic vertical interpolation, 9=cubic spline" "" rconfig integer force_sfc_in_vinterp namelist,domains 1 1 irh "force_sfc_in_vinterp" "number of eta levels forced to use sfc in vert interp" "" rconfig real zap_close_levels namelist,domains 1 500 irh "zap_close_levels" "delta p where level is removed in vert interp" "Pa" +rconfig real maxw_horiz_pres_diff namelist,domains 1 5000 irh "maxw_horiz_pres_diff" "pressure limit (Pa), when horiz diff exceeded do not use max_wind level in real" +rconfig real trop_horiz_pres_diff namelist,domains 1 5000 irh "trop_horiz_pres_diff" "pressure limit (Pa), when horiz diff exceeded do not use tropopause level in real" +rconfig real maxw_above_this_level namelist,domains 1 30000 irh "maxw_above_this_level" "pressure limit (Pa), only use the max_wind data at or above this level" rconfig logical sfcp_to_sfcp namelist,domains 1 .false. irh "sfcp_to_sfcp" "T/F use incoming sfc pres to compute new sfc pres" "flag" rconfig logical adjust_heights namelist,domains 1 .false. irh "adjust_heights" "T/F adjust pressure level input to match 500 mb height" "flag" rconfig logical smooth_cg_topo namelist,domains 1 .false. irh "smooth_cg_topo" "T/F smooth CG topo on boundarries" "flag" rconfig integer nest_interp_coord namelist,domains 1 0 irh "nest_interp_coord" "0=std horiz vi interpolation on eta, 1=attempt isobaric interpolation" +rconfig integer interp_method_type namelist,domains 1 2 irh "interp_method_type" "horiz interp for FG for nesting: 1=bilinear, 2=sint, 3=nearest neighbor is only for testing, 4=quadratic, 12=sint for infrastructure tests" rconfig logical aggregate_lu namelist,domains 1 .false. irh "aggregate_lu" "T/F aggregate the grass, shrubs, trees in LU" rconfig logical rh2qv_wrt_liquid namelist,domains 1 .true. irh "rh2qv_wrt_liquid" "T = rh=>Qv assumes RH wrt liquid water, F = allows ice" rconfig integer rh2qv_method namelist,domains 1 1 irh "rh2qv_method" "1=old MM5 method, 2=new WMO method" @@ -1905,6 +2003,13 @@ rconfig integer nproc_x namelist,domains 1 -1 rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" rconfig integer irand namelist,domains 1 0 - "irand" "" "" rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" + +rconfig integer fft_used derived 1 0 - "fft_used" "stochastic, spectral nudging, polar filters - turn on if these are used" +rconfig integer cu_used derived 1 0 - "cu_used" "turn on if any cumulus scheme is used" +rconfig integer shcu_used derived 1 0 - "shcu_used" "turn on if any shallow cumulus scheme is used" +rconfig integer cam_used derived 1 0 - "cam_used" "turn on if one of the following CAM schemes is used: MP, PBL, SHCU" +rconfig integer alloc_qndropsource derived 1 0 - "alloc_qndropsource" "allocate qndropsource if CHEM==1 or if progn=1" + rconfig integer num_moves namelist,domains 1 0 rconfig integer ts_buf_size namelist,domains 1 200 - "ts_buf_size" "Size of time series buffer" rconfig integer max_ts_locs namelist,domains 1 5 - "max_ts_locs" "Maximum number of time series locations" @@ -1952,11 +2057,13 @@ rconfig real vmax_ratio namelist,tc max_bogus -999. i rconfig real rankine_lid namelist,tc 1 -999. irh "top pressure limit for the tc bogus scheme" # Physics -rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +rconfig logical force_read_thompson namelist,physics 1 .false. +rconfig logical write_thompson_tables namelist,physics 1 .true. +rconfig integer mp_physics namelist,physics max_domains 0 irh "mp_physics" "" "" #rconfig integer milbrandt_ccntype namelist,physics max_domains 0 rh "milbrandt select maritime(1)/continental(2)" "" "" -rconfig real nssl_cccn namelist,physics max_domains 1.5e9 rh "Base CCN concentration for NSSL microphysics" "" "" +rconfig real nssl_cccn namelist,physics max_domains 0.5e9 rh "Base CCN concentration for NSSL microphysics" "" "" rconfig real nssl_alphah namelist,physics max_domains 0 rh "Graupel PSD shape paramter" "" "" -rconfig real nssl_alphahl namelist,physics max_domains 2 rh "Hail PSD shape paramter" "" "" +rconfig real nssl_alphahl namelist,physics max_domains 1 rh "Hail PSD shape paramter" "" "" rconfig real nssl_cnoh namelist,physics max_domains 4.e5 rh "Graupel intercept paramter" "" "" rconfig real nssl_cnohl namelist,physics max_domains 4.e4 rh "Hail intercept paramter" "" "" rconfig real nssl_cnor namelist,physics max_domains 8.e5 rh "Rain intercept paramter" "" "" @@ -1971,6 +2078,7 @@ rconfig real accum_mode namelist,physics 1 10 rconfig real aitken_mode namelist,physics 1 300.0e6 rh "aitken_mode" "" "" rconfig real coarse_mode namelist,physics 1 0.2e6 rh "coarse_mode" "" "" rconfig integer do_radar_ref namelist,physics 1 0 rh "compute radar reflectivity for a number of schemes" "" "" +rconfig integer compute_radar_ref derived 1 0 - "compute_radar_ref" "0/1 flag: compute radar reflectivity, either do_radar_ref=1 .or. (milbrandt or NSSL schemes)" rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" @@ -1979,6 +2087,8 @@ rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" rconfig integer bl_mynn_tkebudget namelist,physics max_domains 0 rh "bl_mynn_tkebudget" "" "" +rconfig integer ysu_topdown_pblmix namelist,physics 1 0 rh "ysu_topdown_pblmix" "" "" +rconfig integer shinhong_tke_diag namelist,physics max_domains 0 rh "shinhong_tke_diag" "" "" rconfig logical bl_mynn_tkeadvect namelist,physics max_domains .false. rh "bl_mynn_tkeadvect" "" "" rconfig integer bl_mynn_cloudpdf namelist,physics 1 0 irh "bl_mynn_cloudpdf" "" "" rconfig integer mfshconv namelist,physics max_domains 1 rh "mfshconv" "To activate mass flux scheme with qnse, 1=true or 0=false" "" @@ -1988,12 +2098,13 @@ rconfig integer cu_physics namelist,physics max_domains 0 rconfig integer shcu_physics namelist,physics max_domains 0 rh "shcu_physics" "" "" rconfig integer cu_diag namelist,physics max_domains 0 rh "cu_diag" "additional t-averaged stuff for cuphys" "" rconfig integer kfeta_trigger namelist,physics 1 1 rh "KFETA Trigger function" "" "" -rconfig integer nsas_dx_factor namelist,physics 1 1 rh "NSAS DX-dependent option" "" "" +rconfig integer nsas_dx_factor namelist,physics 1 0 rh "NSAS DX-dependent option" "" "" rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" rconfig integer IFSNOW namelist,physics 1 1 irh "IFSNOW" "" "" rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" +rconfig integer ideal_xland namelist,physics 1 1 rh "IDEAL_XLAND" "land=1(def), water=2, for ideal cases with no land-use" "" rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=dominant cateogry from metgrid" "" rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" @@ -2041,7 +2152,7 @@ rconfig integer cam_abs_dim2 namelist,physics 1 1 rconfig integer lagday namelist,physics 1 1 - "lagday" "" "" rconfig integer no_src_types namelist,physics 1 1 - "no_src_types" "Number of aerosoal types from EC (6)" "" rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" -rconfig integer o3input namelist,physics 1 0 - "o3input" "ozone input option for radiation" "" +rconfig integer o3input namelist,physics 1 2 - "o3input" "ozone input for RRTMG for CG domain: original = 0; CAM ozone = 2" "" rconfig integer aer_opt namelist,physics 1 0 - "aer_opt" "aerosol input option for radiation" "" rconfig integer swint_opt namelist,physics 1 0 - "swint_opt" "interpolation option for sw radiation" "" rconfig integer aer_type namelist,physics max_domains 1 irh "aer_type" "aerosol type: 1 is SF79 rural, 2 is SF79 urban" "" @@ -2054,6 +2165,17 @@ rconfig real aer_angexp_val namelist,physics max_domains 1. rconfig real aer_ssa_val namelist,physics max_domains 0.85 irh "aer_ssa_val" "fixed value for aerosol single-scattering albedo. Valid when aer_ssa_opt=1" "" rconfig real aer_asy_val namelist,physics max_domains 0.90 irh "aer_asy_val" "fixed value for aerosol asymmetry parameter. Valid when aer_asy_opt=1" "" rconfig logical cu_rad_feedback namelist,physics max_domains .false. irh "feedback of cumulus cloud to radiation" "" + +#BSINGH - added shallowcu_forced_ra, numBins, thBinSize, rBinSize, minDeepFreq, minShallowFreq, shcu_aerosols_opt for CuP scheme + +rconfig logical shallowcu_forced_ra namelist,physics max_domains .true. - "force radiative impact of shallow Cu (KF-Eta and KF-CuP)" +rconfig integer numBins namelist,physics max_domains 1 - "number of bins to use in the CuP PDF" +rconfig real thBinSize namelist,physics max_domains 1 - "bin size of theta bins of PDF" +rconfig real rBinSize namelist,physics max_domains 1 - "bin size of mixing ratio bins of PDF" +rconfig real minDeepFreq namelist,physics max_domains 1 - "Minimum frequency required for deep convection" +rconfig real minShallowFreq namelist,physics max_domains 1 - "Minimum frequency required for shallow convection" +rconfig integer shcu_aerosols_opt namelist,physics max_domains 0 - "aerosols in shcu: 0=none, 1=prescribed, 2=prognostic, 10=prognostic and do aerosol processing" "" + rconfig integer ICLOUD_CU derived 1 0 - "ICLOUD_CU" "" "" rconfig integer pxlsm_smois_init namelist,physics max_domains 1 irh "PXLSM_SMOIS_INIT" "Soil moisture initialization option 0-From analysis 1-From MAVAIL" "" rconfig integer omlcall namelist,physics 1 0 h "omlcall" "temporary holder to allow checking for new name: oml_opt" @@ -2093,22 +2215,11 @@ rconfig real sas_pgcon namelist,physics max_domains 0.5 rconfig integer scalar_pblmix namelist,physics max_domains 0 h "mix 4d scalar variables with pbl scheme 0=no 1=yes" "" rconfig integer tracer_pblmix namelist,physics max_domains 1 h "mix 4d tracer variables with pbl scheme 0=no 1=yes" "" rconfig logical use_aero_icbc namelist,physics 1 .false. rh "use_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero" "logical flag" +rconfig logical use_rap_aero_icbc namelist,physics 1 .false. r "use_rap_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero from RAP" "logical flag" -# GAC--> -# AFWA Diagnostics package namelist options -rconfig integer afwa_diag_opt namelist,afwa max_domains 0 rh "afwa_diag_opt" "AFWA Diagnostic option, 1: on" "" -rconfig integer afwa_ptype_opt namelist,afwa max_domains 0 rh "afwa_ptype_opt" "AFWA Diagnostic: Precip type option, 1: on" "" -rconfig integer afwa_vil_opt namelist,afwa max_domains 0 rh "afwa_vil_opt" "AFWA Diagnostic: Vert Int Liquid option, 1: on" "" -rconfig integer afwa_radar_opt namelist,afwa max_domains 0 rh "afwa_radar_opt" "AFWA Diagnostic: Radar option, 1: on" "" -rconfig integer afwa_severe_opt namelist,afwa max_domains 0 rh "afwa_severe_opt" "AFWA Diagnostic: Severe Wx option, 1: on" "" -rconfig integer afwa_icing_opt namelist,afwa max_domains 0 rh "afwa_icing_opt" "AFWA Diagnostic: Icing option, 1: on" "" -rconfig integer afwa_vis_opt namelist,afwa max_domains 0 rh "afwa_vis_opt" "AFWA Diagnostic: Visibility option, 1: on" "" -rconfig integer afwa_cloud_opt namelist,afwa max_domains 0 rh "afwa_cloud_opt" "AFWA Diagnostic: Cloud option, 1: on" "" -rconfig real afwa_ptype_ccn_tmp namelist,afwa 1 264.15 h "afwa_ptype_ccn_tmp" "AFWA Diagnostic: CCN temperature for precipitation type calculation" "K" -rconfig real afwa_ptype_tot_melt namelist,afwa 1 50.0 h "afwa_ptype_tot_melt" "AFWA Diagnostic: Total melting energy for precipitation type calculation" "J kg-1" -rconfig real afwa_ccn_conc namelist,afwa 1 1.0E8 h "afwa_ccn_conc" "AFWA Diagnostic: CCN concentration" "# m-3" -rconfig integer afwa_hail_opt namelist,afwa 1 0 rh "afwa_hail_opt" "AFWA Diagnostic: Hail/Graupel switch, 1:hail, 0:graupel" "" -# <--GAC +# The following two options are hooked into various microphysics schemes to allow for ensemble perturbations of CCN and hail/graupel PSDs - GAC (AFWA) +rconfig real ccn_conc namelist,physics 1 1.0E8 h "ccn_conc" "CCN concentration" "# m-3" +rconfig integer hail_opt namelist,physics 1 0 rh "hail_opt" "Hail/Graupel switch, 1:hail, 0:graupel" "" # For Noah-MP rconfig integer dveg namelist,noah_mp 1 4 h "dveg" "dynamic vegetation (1 -> off ; 2 -> on)" "" @@ -2270,6 +2381,8 @@ rconfig real khdif namelist,dynamics max_domains 0 rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" rconfig real diff_6th_factor namelist,dynamics max_domains 0.12 h "diff_6th_factor" "factor that controls rate of 6th-order numerical diffusion" rconfig integer diff_6th_opt namelist,dynamics max_domains 0 irh "diff_6th_opt" "switch for 6th-order numerical diffusion" +rconfig integer use_theta_m namelist,dynamics 1 0 rh "use_theta_m" "theta_m = theta (1 + 1.61 Qv); 0-no, 1=yes" "" +rconfig integer use_q_diabatic namelist,dynamics 1 0 rh "use_q_diabatic" "account for q diabatic terms in advection " "" rconfig real c_s namelist,dynamics max_domains 0.25 h "c_s" "Smagorinsky coeff" "" rconfig real c_k namelist,dynamics max_domains 0.15 h "c_k" "TKE coeff" "" rconfig real smdiv namelist,dynamics max_domains 0.1 h "smdiv" "" "" @@ -2302,9 +2415,15 @@ rconfig logical mix_full_fields namelist,dynamics max_domains .fa rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" -rconfig real iso_temp namelist,dynamics 1 200. h "iso_temp" "Isothermal temperature in stratosphere, real only" "K" +rconfig real iso_temp namelist,dynamics 1 200.00 h "iso_temp" "Isothermal temperature in stratosphere, real only" "K" +rconfig real base_pres_strat namelist,dynamics 1 0. h "base_pres_strat" "Base state pressure (Pa) at bottom of the stratosphere, std atm = 5500 Pa" "Pa" +rconfig real base_lapse_strat namelist,dynamics 1 -11. h "base_lapse_strat", "Base state lapse rate ( dT / d(lnP) ) in stratosphere, std atm = -11 K/(ln delta p)" "K" rconfig logical use_baseparam_fr_nml namelist,dynamics 1 .false. irh "use_baseparam_fr_nml" "" "" -rconfig real fft_filter_lat namelist,dynamics 1 91. h "fft_filter_lat" "" "grid latitude to start polar filter" +rconfig real fft_filter_lat namelist,dynamics 1 91. h "fft_filter_lat" "degrees" "grid latitude to start polar filter" +rconfig logical coupled_filtering namelist,dynamics 1 .true. h "coupled_filtering" "for scalar/tracer/chem/moist, T/F filter the fields coupled with mu" +rconfig logical pos_def namelist,dynamics 1 .false. h "pos_def" "for scalar/tracer/chem/moist, T/F after filtering, reset negative values to zero" +rconfig logical swap_pole_with_next_j namelist,dynamics 1 .false. h "swap_pole_with_next_j" "for scalar/tracer/chem/moist, T/F replace the most poleward latitude of data with the next row in" +rconfig logical actual_distance_average namelist,dynamics 1 .false. h "actual_distance_average" "for scalar/tracer/chem/moist, T/F the number of points to use in the latitudinal average is based on the ratio of map factors" rconfig logical rotated_pole namelist,dynamics 1 .false. irh "rotated_pole" "" "" rconfig logical do_coriolis namelist,dynamics max_domains .true. irh "do_coriolis" "" "" rconfig logical do_curvature namelist,dynamics max_domains .true. irh "do_curvature" "" "" @@ -2332,6 +2451,7 @@ rconfig logical open_ye namelist,bdy_control max_domains .f rconfig logical polar namelist,bdy_control max_domains .false. rh "polar" "" "" rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" rconfig real spec_exp namelist,bdy_control 1 0. irh "spec_exp" "" "" +rconfig integer spec_bdy_final_mu namelist,bdy_control 1 0 rh "call spec_bdy_final for mu" "" "" rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" rconfig logical have_bcs_moist namelist,bdy_control max_domains .false. rh "have_bcs_moist" "" "" rconfig logical have_bcs_scalar namelist,bdy_control max_domains .false. rh "have_bcs_scalar" "" "" @@ -2367,6 +2487,7 @@ rconfig integer FLAG_SOIL_LAYERS derived 1 rconfig integer FLAG_SLP derived 1 0 - "FLAG_SLP" "Flag for sea level pressure in the global attributes for metgrid data" rconfig integer FLAG_SOILHGT derived 1 0 - "FLAG_SOILHGT" "Flag for soil height in the global attributes for metgrid data" rconfig integer FLAG_MF_XY derived 1 0 - "FLAG_MF_XY" "Flag for MF_XYin the global attributes for metgrid data" +rconfig integer FLAG_UM_SOIL derived 1 0 - "FLAG_UM_SOIL" "Flag for soil fields from the Unified Model in the globl attributes for metgrid data" rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" rconfig character mminlu derived max_domains " " - "mminlu" "land use dataset" "" rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" @@ -2394,138 +2515,169 @@ rconfig integer windfarm_ij namelist,physics 1 0 #key package associated package associated 4d scalars # name namelist choice state vars -#package passivec1 chem_opt==0 - +#package passivec1 chem_opt==0 - ifdef DA_CORE=0 -package passiveqv mp_physics==0 - moist:qv -package kesslerscheme mp_physics==1 - moist:qv,qc,qr -package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg -package wsm3scheme mp_physics==3 - moist:qv,qc,qr -package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs -package etampnew mp_physics==5 - moist:qv,qc,qr,qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy -package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg -package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg -package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr;state:re_cloud,re_ice,re_snow -package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow -package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh -package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng -package cammgmpscheme mp_physics==11 - moist:qv,qc,qi,qr,qs;scalar:qnc,qni,qnr,qns;state:rh_old_mp,lcd_old_mp,cldfra_old_mp,cldfra_mp,cldfra_mp_all,cldfra_conv,cldfrai,cldfral,turbtype3d,smaw3d,wsedl3d,icwmrdp3d,dp3d,shfrc3d,dlf,dlf2,tke_pbl,lradius,iradius -#package milbrandt3mom mp_physics==12 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qzr,qzi,qzs,qzg,qzh -package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs;state:rimi -package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr -package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr -package nssl_2mom mp_physics==17 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qvolg -package nssl_2momccn mp_physics==18 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qnc,qnr,qni,qns,qng,qnh,qvolg -package nssl_1mom mp_physics==19 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qvolg -package nssl_1momlfo mp_physics==21 - moist:qv,qc,qr,qi,qs,qg -package etampold mp_physics==95 - moist:qv,qc,qr,qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy +package passiveqv mp_physics==0 - moist:qv +package kesslerscheme mp_physics==1 - moist:qv,qc,qr +package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg +package wsm3scheme mp_physics==3 - moist:qv,qc,qr;state:re_cloud,re_ice,re_snow +package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs;state:re_cloud,re_ice,re_snow +package etamp_hr mp_physics==5 - moist:qv,qc,qr,qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy +package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg;state:re_cloud,re_ice,re_snow +package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg +package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr;state:re_cloud,re_ice,re_snow +package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh +package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng +package cammgmpscheme mp_physics==11 - moist:qv,qc,qi,qr,qs;scalar:qnc,qni,qnr,qns;state:rh_old_mp,lcd_old_mp,cldfra_old_mp,cldfra_mp,cldfra_mp_all,cldfra_conv,cldfrai,cldfral,turbtype3d,smaw3d,wsedl3d,icwmrdp3d,dp3d,shfrc3d,dlf,dlf2,tke_pbl,lradius,iradius +#package milbrandt3mom mp_physics==12 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qzr,qzi,qzs,qzg,qzh +package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs;state:rimi +package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow +package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow +package nssl_2mom mp_physics==17 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qndrop,qnr,qni,qns,qng,qnh,qvolg,qvolh;state:re_cloud,re_ice,re_snow +package nssl_2momccn mp_physics==18 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qndrop,qnr,qni,qns,qng,qnh,qvolg,qvolh;state:re_cloud,re_ice,re_snow +package nssl_1mom mp_physics==19 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qvolg +package nssl_1momlfo mp_physics==21 - moist:qv,qc,qr,qi,qs,qg +package nssl_2momg mp_physics==22 - moist:qv,qc,qr,qi,qs,qg;scalar:qndrop,qnr,qni,qns,qng,qvolg;state:re_cloud,re_ice,re_snow +package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow,qnwfa2d +package etampnew mp_physics==95 - moist:qv,qc,qr,qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy + +package radar_refl compute_radar_ref==1 - state:refl_10cm,refd_max endif package nodfimoist mp_physics_dfi==-1 - - package passiveqv_dfi mp_physics_dfi==0 - dfi_moist:dfi_qv package kesslerscheme_dfi mp_physics_dfi==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr package linscheme_dfi mp_physics_dfi==2 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package wsm3scheme_dfi mp_physics_dfi==3 - dfi_moist:dfi_qv,dfi_qc,dfi_qr -package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs -package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt -package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg +package wsm3scheme_dfi mp_physics_dfi==3 - dfi_moist:dfi_qv,dfi_qc,dfi_qr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package etamp_hr_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt +package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng #package milbrandt3mom_dfi mp_physics_dfi==12 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qzr,dfi_qzi,dfi_qzs,dfi_qzg,dfi_qzh #package sbu_ylinscheme_dfi mp_physics==13 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:rimi -package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr -package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr -package nssl_2mom_dfi mp_physics_dfi==17 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg -package nssl_2mom_dficcn mp_physics_dfi==18 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg +package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package nssl_2mom_dfi mp_physics_dfi==17 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qndrop,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg,dfi_qvolh;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package nssl_2mom_dficcn mp_physics_dfi==18 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package nssl_1mom_dfi mp_physics_dfi==19 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qvolg package nssl_1momlfo_dfi mp_physics_dfi==21 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package etampold_dfi mp_physics_dfi==95 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt +package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package etampnew_dfi mp_physics_dfi==95 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt package noprogn progn==0 - - -package progndrop progn==1 - scalar:qndrop;dfi_scalar:dfi_qndrop - -package rrtmscheme ra_lw_physics==1 - - -package camlwscheme ra_lw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc -package rrtmg_lwscheme ra_lw_physics==4 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,o3rad -package goddardlwscheme ra_lw_physics==5 - state:tlwdn,tlwup,slwdn,slwup -package flglwscheme ra_lw_physics==7 - - -package gfdllwscheme ra_lw_physics==99 - - -package heldsuarez ra_lw_physics==31 - - - -package swradscheme ra_sw_physics==1 - - -package gsfcswscheme ra_sw_physics==2 - - -package camswscheme ra_sw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc +package progndrop progn==1 - scalar:qndrop;dfi_scalar:dfi_qndrop;state:qndropsource + +package noqndrop alloc_qndropsource==0 - - +package qndrop alloc_qndropsource==1 - state:qndropsource + +package rrtmscheme ra_lw_physics==1 - - +package camlwscheme ra_lw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc;state:emstot,abstot,absnxt,acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,taucldc,taucldi +package rrtmg_lwscheme ra_lw_physics==4 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,o3rad +package rrtmg_lwscheme_fast ra_lw_physics==24 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,o3rad +package goddardlwscheme ra_lw_physics==5 - state:tlwdn,tlwup,slwdn,slwup,taucldc,taucldi +package flglwscheme ra_lw_physics==7 - - +package heldsuarez ra_lw_physics==31 - - +package gfdllwscheme ra_lw_physics==99 - - + +package swradscheme ra_sw_physics==1 - - +package gsfcswscheme ra_sw_physics==2 - state:taucldc,taucldi +package camswscheme ra_sw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc;state:emstot,abstot,absnxt,acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,taucldc,taucldi package rrtmg_swscheme ra_sw_physics==4 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,o3rad;aerod:ocarbon,seasalt,dust,bcarbon,sulfate,upperaer -package goddardswscheme ra_sw_physics==5 - state:tswdn,tswup,sswdn,sswup -package flgswscheme ra_sw_physics==7 - - -package gfdlswscheme ra_sw_physics==99 - - - -package sfclayscheme sf_sfclay_physics==91 - - -package myjsfcscheme sf_sfclay_physics==2 - state:tke_pbl -package gfssfcscheme sf_sfclay_physics==3 - - -package qnsesfcscheme sf_sfclay_physics==4 - - -package mynnsfcscheme sf_sfclay_physics==5 - state:sh3d,tsq,qsq,cov -package pxsfcscheme sf_sfclay_physics==7 - - -package temfsfcscheme sf_sfclay_physics==10 - state:wm_temf -package sfclayrevscheme sf_sfclay_physics==1 - - -package idealscmsfcscheme sf_sfclay_physics==89 - - - -package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,mh_urb2d,stdh_urb2d,lf_urb2d,lp_urb2d,hgt_urb2d,lb_urb2d -package bepscheme sf_urban_physics==2 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,hi_urb2d,lp_urb2d,hgt_urb2d,lb_urb2d -package bep_bemscheme sf_urban_physics==3 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,hi_urb2d,lp_urb2d,hgt_urb2d,lb_urb2d +package rrtmg_swscheme_fast ra_sw_physics==24 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,o3rad;aerod:ocarbon,seasalt,dust,bcarbon,sulfate,upperaer +package goddardswscheme ra_sw_physics==5 - state:tswdn,tswup,sswdn,sswup,taucldc,taucldi +package flgswscheme ra_sw_physics==7 - - +package gfdlswscheme ra_sw_physics==99 - - + +package sfclayrevscheme sf_sfclay_physics==1 - - +package myjsfcscheme sf_sfclay_physics==2 - state:tke_pbl +package gfssfcscheme sf_sfclay_physics==3 - - +package qnsesfcscheme sf_sfclay_physics==4 - - +package mynnsfcscheme sf_sfclay_physics==5 - state:sh3d,tsq,qsq,cov +package pxsfcscheme sf_sfclay_physics==7 - - +package temfsfcscheme sf_sfclay_physics==10 - state:wm_temf +package idealscmsfcscheme sf_sfclay_physics==89 - - +package sfclayscheme sf_sfclay_physics==91 - - + +package noahucmscheme sf_urban_physics==1 - state:trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,mh_urb2d,stdh_urb2d,lf_urb2d,lp_urb2d,hgt_urb2d,lb_urb2d,tgr_urb2d,cmcr_urb2d,drelr_urb2d,drelb_urb2d,drelg_urb2d,flxhumr_urb2d,flxhumb_urb2d,flxhumg_urb2d,tgrl_urb3d,smr_urb3d,cmgr_sfcdif,chgr_sfcdif,trl_urb3d,tgl_urb3d,tbl_urb3d +package bepscheme sf_urban_physics==2 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,hi_urb2d,lp_urb2d,hgt_urb2d,lb_urb2d,trl_urb3d,tgl_urb3d,tbl_urb3d +package bep_bemscheme sf_urban_physics==3 - state:a_u_bep,a_v_bep,a_t_bep,a_q_bep,a_e_bep,b_u_bep,b_v_bep,b_t_bep,b_q_bep,b_e_bep,dlg_bep,dl_u_bep,sf_bep,vl_bep,trb_urb4d,tw1_urb4d,tw2_urb4d,tgb_urb4d,tlev_urb3d,qlev_urb3d,tw1lev_urb3d,tw2lev_urb3d,tglev_urb3d,tflev_urb3d,sf_ac_urb3d,lf_ac_urb3d,cm_ac_urb3d,sfvent_urb3d,lfvent_urb3d,sfwin1_urb3d,sfwin2_urb3d,sfw1_urb3d,sfw2_urb3d,sfr_urb3d,sfg_urb3d,hi_urb2d,lp_urb2d,hgt_urb2d,lb_urb2d,trl_urb3d,tgl_urb3d,tbl_urb3d package slabscheme sf_surface_physics==1 - - -package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn -package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag,soilt1 +package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn,smcrel +package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag,soilt1,rhosnf,snowfallac,precipfr package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy,fdepthxy,areaxy,rivercondxy,riverbedxy,eqzwt,pexpxy,qrfxy,qrfsxy,qspringxy,qspringsxy,qslatxy,stepwtd package clmscheme sf_surface_physics==5 - state:numc,nump,sabv,sabg,lwup,lhsoi,lhveg,lhtran,snl,snowdp,wtc,wtp,h2osno,t_grnd,t_veg,h2ocan,h2ocan_col,t2m_max,t2m_min,t2clm,t_ref2m,h2osoi_liq_s1,h2osoi_liq_s2,h2osoi_liq_s3,h2osoi_liq_s4,h2osoi_liq_s5,h2osoi_liq1,h2osoi_liq2,h2osoi_liq3,h2osoi_liq4,h2osoi_liq5,h2osoi_liq6,h2osoi_liq7,h2osoi_liq8,h2osoi_liq9,h2osoi_liq10,h2osoi_ice_s1,h2osoi_ice_s2,h2osoi_ice_s3,h2osoi_ice_s4,h2osoi_ice_s5,h2osoi_ice1,h2osoi_ice2,h2osoi_ice3,h2osoi_ice4,h2osoi_ice5,h2osoi_ice6,h2osoi_ice7,h2osoi_ice8,h2osoi_ice9,h2osoi_ice10,t_soisno_s1,t_soisno_s2,t_soisno_s3,t_soisno_s4,t_soisno_s5,t_soisno1,t_soisno2,t_soisno3,t_soisno4,t_soisno5,t_soisno6,t_soisno7,t_soisno8,t_soisno9,t_soisno10,dzsnow1,dzsnow2,dzsnow3,dzsnow4,dzsnow5,snowrds1,snowrds2,snowrds3,snowrds4,snowrds5,t_lake1,t_lake2,t_lake3,t_lake4,t_lake5,t_lake6,t_lake7,t_lake8,t_lake9,t_lake10,h2osoi_vol1,h2osoi_vol2,h2osoi_vol3,h2osoi_vol4,h2osoi_vol5,h2osoi_vol6,h2osoi_vol7,h2osoi_vol8,h2osoi_vol9,h2osoi_vol10,albedosubgrid,lhsubgrid,hfxsubgrid,lwupsubgrid,q2subgrid,sabvsubgrid,sabgsubgrid,nrasubgrid,swupsubgrid -package pxlsmscheme sf_surface_physics==7 - state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old +package pxlsmscheme sf_surface_physics==7 - state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old,vegf_px,imperv,canfra package ssibscheme sf_surface_physics==8 - state:ssib_fm,ssib_fh,ssib_cm,ssibxdd,ssib_br,ssib_lhf,ssib_shf,ssib_ghf,ssib_egs,ssib_eci,ssib_ect,ssib_egi,ssib_egt,ssib_sdn,ssib_sup,ssib_ldn,ssib_lup,ssib_wat,ssib_shc,ssib_shg,ssib_lai,ssib_vcf,ssib_z00,ssib_veg,isnow,swe,snowden,snowdepth,tkair,dzo1,wo1,tssn1,tssno1,bwo1,bto1,cto1,fio1,flo1,bio1,blo1,ho1,dzo2,wo2,tssn2,tssno2,bwo2,bto2,cto2,fio2,flo2,bio2,blo2,ho2,dzo3,wo3,tssn3,tssno3,bwo3,bto3,cto3,fio3,flo3,bio3,blo3,ho3,dzo4,wo4,tssn4,tssno4,bwo4,bto4,cto4,fio4,flo4,bio4,blo4,ho4 -package noahmosaicscheme sf_surface_mosaic==1 - state:TSK_mosaic,QSFC_mosaic,TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic,CANWAT_mosaic,SNOW_mosaic,SNOWH_mosaic,SNOWC_mosaic,ALBEDO_mosaic,ALBBCK_mosaic,EMISS_mosaic,EMBCK_mosaic,ZNT_mosaic,Z0_mosaic,HFX_mosaic,QFX_mosaic,LH_mosaic,GRDFLX_mosaic,SNOTIME_mosaic,TR_URB2D_mosaic,TB_URB2D_mosaic,TG_URB2D_mosaic,TC_URB2D_mosaic,TS_URB2D_mosaic,TS_RUL2D_mosaic,QC_URB2D_mosaic,UC_URB2D_mosaic,TRL_URB3D_mosaic,TBL_URB3D_mosaic,TGL_URB3D_mosaic,SH_URB2D_mosaic,LH_URB2D_mosaic,G_URB2D_mosaic,RN_URB2D_mosaic,mosaic_cat_index,landusef2 +package noahmosaicscheme sf_surface_mosaic==1 - state:TSK_mosaic,QSFC_mosaic,TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic,CANWAT_mosaic,SNOW_mosaic,SNOWH_mosaic,SNOWC_mosaic,ALBEDO_mosaic,ALBBCK_mosaic,EMISS_mosaic,EMBCK_mosaic,ZNT_mosaic,Z0_mosaic,HFX_mosaic,QFX_mosaic,LH_mosaic,GRDFLX_mosaic,SNOTIME_mosaic,TR_URB2D_mosaic,TB_URB2D_mosaic,TG_URB2D_mosaic,TC_URB2D_mosaic,TS_URB2D_mosaic,TS_RUL2D_mosaic,QC_URB2D_mosaic,UC_URB2D_mosaic,TRL_URB3D_mosaic,TBL_URB3D_mosaic,TGL_URB3D_mosaic,SH_URB2D_mosaic,LH_URB2D_mosaic,G_URB2D_mosaic,RN_URB2D_mosaic,mosaic_cat_index,landusef2,smcrel package ysuscheme bl_pbl_physics==1 - - package myjpblscheme bl_pbl_physics==2 - state:tke_pbl,el_pbl package gfsscheme bl_pbl_physics==3 - - package qnsepblscheme bl_pbl_physics==4 - state:tke_pbl,el_pbl,massflux_EDKF,entr_EDKF,detr_EDKF,thl_up,thv_up,rv_up,rt_up,rc_up,u_up,v_up,frac_up,rc_mf -package qnsepbl09scheme bl_pbl_physics==94 - state:tke_pbl,el_pbl package mynnpblscheme2 bl_pbl_physics==5 - scalar:qke_adv;state:qke,tke_pbl,sh3d,tsq,qsq,cov,el_pbl package mynnpblscheme3 bl_pbl_physics==6 - scalar:qke_adv;state:qke,tke_pbl,sh3d,tsq,qsq,cov,el_pbl -package mynn_tkebudget bl_mynn_tkebudget==1 - state:qSHEAR,qBUOY,qDISS,qWT,dqke package acmpblscheme bl_pbl_physics==7 - - package boulacscheme bl_pbl_physics==8 - state:el_pbl,tke_pbl,wu_tur,wv_tur,wt_tur,wq_tur package camuwpblscheme bl_pbl_physics==9 - state:tauresx2d,tauresy2d,tpert2d,qpert2d,wpert2d,tke_pbl,smaw3d,wsedl3d,turbtype3d -package mrfscheme bl_pbl_physics==99 - - package temfpblscheme bl_pbl_physics==10 - state:te_temf,kh_temf,km_temf,shf_temf,qf_temf,uw_temf,vw_temf,wupd_temf,mf_temf,thup_temf,qlup_temf,qtup_temf,cf3d_temf,hd_temf,lcl_temf,hct_temf,cfm_temf +package shinhongscheme bl_pbl_physics==11 - state:el_pbl,tke_pbl package gbmpblscheme bl_pbl_physics==12 - state:exch_tke,el_pbl,tke_pbl -package kfetascheme cu_physics==1 - - +package mrfscheme bl_pbl_physics==99 - - + +package mynn_tkebudget bl_mynn_tkebudget==1 - state:qSHEAR,qBUOY,qDISS,qWT,dqke + +package nocuscheme cu_physics==0 - - +package kfetascheme cu_physics==1 - state:w0avg package bmjscheme cu_physics==2 - - -package gdscheme cu_physics==93 - - -package sasscheme cu_physics==84 - - -package meso_sas cu_physics==85 - - +package gfscheme cu_physics==3 - state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow package osasscheme cu_physics==4 - - package g3scheme cu_physics==5 - state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow -package gfscheme cu_physics==3 - state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow -package camzmscheme cu_physics==7 - state:precz,zmdt,zmdq,zmdice,zmdliq,evaptzm,fzsntzm,evsntzm,evapqzm,zmflxprc,zmflxsnw,zmntprpd,zmntsnpd,zmeiheat,cmfmc,cmfmcdzm,preccdzm,pconvb,pconvt,cape,zmmtu,zmmtv,zmmu,zmmd,zmupgu,zmupgd,zmvpgu,zmvpgd,zmicuu,zmicud,zmicvu,zmicvd,evapcdp3d,icwmrdp3d,rprddp3d,dp3d,du3d,ed3d,eu3d,md3d,mu3d,dsubcld2d,ideep2d,jt2d,maxg2d,lengath2d,dlf,rliq,tpert2d -package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep package tiedtkescheme cu_physics==6 - - +package camzmscheme cu_physics==7 - state:precz,zmdt,zmdq,zmdice,zmdliq,evaptzm,fzsntzm,evsntzm,evapqzm,zmflxprc,zmflxsnw,zmntprpd,zmntsnpd,zmeiheat,cmfmc,cmfmcdzm,preccdzm,pconvb,pconvt,cape,zmmtu,zmmtv,zmmu,zmmd,zmupgu,zmupgd,zmvpgu,zmvpgd,zmicuu,zmicud,zmicvu,zmicvd,evapcdp3d,icwmrdp3d,rprddp3d,dp3d,du3d,ed3d,eu3d,md3d,mu3d,dsubcld2d,ideep2d,jt2d,maxg2d,lengath2d,dlf,rliq,tpert2d +package kfcupscheme cu_physics==10 - state:cldfratend_cup,cldfra_cup,updfra_cup,qc_iu_cup,qc_ic_cup,qndrop_ic_cup,wup_cup,mfup_cup,mfup_ent_cup,mfdn_cup,mfdn_ent_cup,fcvt_qc_to_pr_cup,fcvt_qc_to_qi_cup,fcvt_qi_to_pr_cup,lnterms,w0avg +package mskfscheme cu_physics==11 - state:w0avg,w_up package nsasscheme cu_physics==14 - - -package kfscheme cu_physics==99 - - +package ntiedtkescheme cu_physics==16 - - +package gdscheme cu_physics==93 - - +package sasscheme cu_physics==84 - - +package meso_sas cu_physics==85 - - +package kfscheme cu_physics==99 - state:w0avg + +package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep -package g3shcuscheme shcu_physics==1 - - +package no_cu_used cu_used==0 - - +package any_cu_used cu_used==1 - state:rucuten,rvcuten,rthcuten,rqvcuten,rqrcuten,rqccuten,rqscuten,rqicuten,rqcncuten,rqincuten + +package no_cam_used cam_used==0 - - +package any_cam_used cam_used==1 - state:cldfra_old + +package noshcuscheme shcu_physics==0 - - +package g3shcuscheme shcu_physics==1 - - package camuwshcuscheme shcu_physics==2 - state:shfrc3d,dlf,dlf2,cmfmc,cmfmc2,qtflx_cu,slflx_cu,uflx_cu,vflx_cu,qtten_cu,slten_cu,uten_cu,vten_cu,qvten_cu,qlten_cu,qiten_cu,cbmf_cu,ufrcinvbase_cu,ufrclcl_cu,winvbase_cu,wlcl_cu,plcl_cu,pinv_cu,plfc_cu,pbup_cu,ppen_cu,qtsrc_cu,thlsrc_cu,thvlsrc_cu,emkfbup_cu,cin_cu,cinlcl_cu,cbmflimit_cu,tkeavg_cu,zinv_cu,rcwp_cu,rlwp_cu,riwp_cu,tophgt_cu,wu_cu,ufrc_cu,qtu_cu,thlu_cu,thvu_cu,uu_cu,vu_cu,qtu_emf_cu,thlu_emf_cu,uu_emf_cu,vu_emf_cu,umf_cu,uemf_cu,qcu_cu,qlu_cu,qiu_cu,cufrc_cu,fer_cu,fdr_cu,dwten_cu,diten_cu,qrten_cu,qsten_cu,flxrain_cu,flxsnow_cu,ntraprd_cu,ntsnprd_cu,excessu_cu,excessu0_cu,xc_cu,aquad_cu,bquad_cu,cquad_cu,bogbot_cu,bogtop_cu,exit_uwcu_cu,exit_conden_cu,exit_klclmkx_cu,exit_klfcmkx_cu,exit_ufrc_cu,exit_wtw_cu,exit_drycore_cu,exit_wu_cu,exit_cufliter_cu,exit_kinv1_cu,exit_rei_cu,limit_shcu_cu,limit_negcon_cu,limit_ufrc_cu,limit_ppen_cu,limit_emf_cu,limit_cinlcl_cu,limit_cin_cu,limit_cbmf_cu,limit_rei_cu,ind_delcin_cu,evapcsh,cmfsl,cmflq,cldfrash,cush,icwmrsh,snowsh,rprdsh,rliq2,rliq package grimsshcuscheme shcu_physics==3 - - +package no_shcu_used shcu_used==0 - - +package any_shcu_used shcu_used==1 - state:rushten,rvshten,rthshten,rqvshten,rqrshten,rqcshten,rqsshten,rqishten,rqgshten,rqcnshten,rqinshten + package fogsettling0 grav_settling==0 - state:vdfg package fogsettling1 grav_settling==1 - state:vdfg,fgdp,dfgdp package fogsettling2 grav_settling==2 - state:vdfg,fgdp,dfgdp package psufddagd grid_fdda==1 - fdda3d:u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,ph_ndg_old,u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,ph_ndg_new;fdda2d:mu_ndg_old,mu_ndg_new;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten +package spnudging grid_fdda==2 - fdda3d:u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,ph_ndg_old,u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,ph_ndg_new;fdda2d:mu_ndg_old,mu_ndg_new;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten,dif_analysis,dif_xxx,dif_yyy + package psusfddagd grid_sfdda==1 - state:u10_ndg_old,v10_ndg_old,t2_ndg_old,th2_ndg_old,q2_ndg_old,rh_ndg_old,psl_ndg_old,ps_ndg_old,u10_ndg_new,v10_ndg_new,t2_ndg_new,th2_ndg_new,q2_ndg_new,rh_ndg_new,psl_ndg_new,ps_ndg_new,tob_ndg_old,odis_ndg_old,tob_ndg_new,odis_ndg_new -package spnudging grid_fdda==2 - fdda3d:u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,ph_ndg_old,u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,ph_ndg_new;fdda2d:mu_ndg_old,mu_ndg_new;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten + +package obsnudging obs_nudge_opt==1 - state:obs_savwt,fdob + +package aeropt1 aer_opt==1 - state:aerodm +package aeropt2 aer_opt==2 - state:aod5503d package slopeopt slope_rad==1 - - package gwdopt gwd_opt==1 - state:oc12d,oa1,oa2,oa3,oa4,ol1,ol2,ol3,ol4,dtaux3d,dtauy3d,dusfcg,dvsfcg @@ -2549,19 +2701,7 @@ package weno_scalar moist_adv_opt==3 - - package wenopd_scalar moist_adv_opt==4 - - package maxmin_output output_diagnostics==1 - state:t2min,t2max,tt2min,tt2max,t2mean,t2std,q2min,q2max,tq2min,tq2max,q2mean,q2std,skintempmin,skintempmax,tskintempmin,tskintempmax,skintempmean,skintempstd,u10max,v10max,spduv10max,tspduv10max,u10mean,v10mean,spduv10mean,u10std,v10std,spduv10std,raincvmax,rainncvmax,traincvmax,trainncvmax,raincvmean,rainncvmean,raincvstd,rainncvstd -package nwp_output nwp_diagnostics==1 - state:wspd10max,w_up_max,w_dn_max,up_heli_max,w_mean,grpl_max - -# GAC--> -# Package declaration for AFWA diagnostics -package afwa_diag afwa_diag_opt==1 - - -package afwa_ptype afwa_ptype_opt==1 - state:afwa_precip,afwa_rain,afwa_snow,afwa_ice,afwa_fzra,afwa_snowfall -package afwa_vil afwa_vil_opt==1 - state:vil,radarvil -package afwa_radar afwa_radar_opt==1 - state:echotop,refd_com,refd -package afwa_severe afwa_severe_opt==1 - state:wspd10max,w_up_max,w_dn_max,tcoli_max -package afwa_icing afwa_icing_opt==1 - state:fzlev,icingtop,icingbot,qicing_lg,qicing_sm,icing_lg,icing_sm,qicing_lg_max,qicing_sm_max -package afwa_cloud afwa_cloud_opt==1 - state:afwa_cloud -package afwa_vis afwa_vis_opt==1 - state:afwa_vis,afwa_vis_dust -# <--GAC +package nwp_output nwp_diagnostics==1 - state:wspd10max,w_up_max,w_dn_max,up_heli_max,w_mean,grpl_max,hail_maxk1,hail_max2d package dfi_setup dfi_stage==0 - - package dfi_bck dfi_stage==1 - - @@ -2570,15 +2710,18 @@ package dfi_fst dfi_stage==3 - - package dfi_startfwd dfi_stage==4 - - package dfi_startbck dfi_stage==5 - - -#package digifilter dfi_opt==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qndrop,dfi_qni,dfi_qt,dfi_qns,dfi_qnr,dfi_qng;state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_rh,dfi_tten_rad -package dfi_nodfi dfi_opt==0 - - -package dfi_dfl dfi_opt==1 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad -package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad -package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad -package realonly use_wps_input==1 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc,sm000007,sm007028,sm028100,sm100255,st000007,st007028,st028100,st100255,sm000010,sm010040,sm040100,sm100200,sm010200,soilm000,soilm005,soilm020,soilm040,soilm160,soilm300,sw000010,sw010040,sw040100,sw100200,sw010200,soilw000,soilw005,soilw020,soilw040,soilw160,soilw300,st000010,st010040,st040100,st100200,st010200,soilt000,soilt005,soilt020,soilt040,soilt160,soilt300,fad0_urb2d,fad135_urb2d,fad45_urb2d,pad_urb2d,fad90_urb2d,rad_urb2d,car_urb2d,h2w_urb2d,svf_urb2d,z0s_urb2d,z0r_urb2d,z0m_urb2d,zds_urb2d,zdm_urb2d,zdr_urb2d,qnwfa_now,qnwfa_jan,qnwfa_feb,qnwfa_mar,qnwfa_apr,qnwfa_may,qnwfa_jun,qnwfa_jul,qnwfa_aug,qnwfa_sep,qnwfa_oct,qnwfa_nov,qnwfa_dec,qnifa_now,qnifa_jan,qnifa_feb,qnifa_mar,qnifa_apr,qnifa_may,qnifa_jun,qnifa_jul,qnifa_aug,qnifa_sep,qnifa_oct,qnifa_nov,qnifa_dec,qntemp,qntemp2 +package dfi_nodfi dfi_opt==0 - - +package dfi_dfl dfi_opt==1 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad +package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad +package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad + +package realonly use_wps_input==1 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,lai12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,cl_gc,cf_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc,prho_gc,pdrho_gc,qnr_gc,soil_layers,soil_levels,st,sm,sw,soilt,soilm,sm000007,sm007028,sm028100,sm100255,st000007,st007028,st028100,st100255,sm000010,sm010040,sm040100,sm100200,sm010200,soilm000,soilm005,soilm020,soilm040,soilm160,soilm300,sw000010,sw010040,sw040100,sw100200,sw010200,soilw000,soilw005,soilw020,soilw040,soilw160,soilw300,st000010,st010040,st040100,st100200,st010200,soilt000,soilt005,soilt020,soilt040,soilt160,soilt300,fad0_urb2d,fad135_urb2d,fad45_urb2d,pad_urb2d,fad90_urb2d,rad_urb2d,car_urb2d,h2w_urb2d,svf_urb2d,z0s_urb2d,z0r_urb2d,z0m_urb2d,zds_urb2d,zdm_urb2d,zdr_urb2d,qnwfa_gc,qnwfa_now,qnwfa_jan,qnwfa_feb,qnwfa_mar,qnwfa_apr,qnwfa_may,qnwfa_jun,qnwfa_jul,qnwfa_aug,qnwfa_sep,qnwfa_oct,qnwfa_nov,qnwfa_dec,qnifa_gc,qnifa_now,qnifa_jan,qnifa_feb,qnifa_mar,qnifa_apr,qnifa_may,qnifa_jun,qnifa_jul,qnifa_aug,qnifa_sep,qnifa_oct,qnifa_nov,qnifa_dec,qntemp,qntemp2,hgtmaxw,pmaxw,tmaxw,umaxw,vmaxw,hgttrop,ptrop,ttrop,utrop,vtrop,urb_param + package tconly use_wps_input==2 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc + package reg_interp nest_interp_coord==0 - - package flat_p_interp nest_interp_coord==1 - state:t_max_p,ght_max_p,max_p,t_min_p,ght_min_p,min_p + # Tendency diagnostics for non-chemistry decoupled advective tendency arrays package notenddiag tenddiag==0 - - package usetenddiag tenddiag==1 - advh_t:advh_qv;advz_t:advz_qv @@ -2627,6 +2770,7 @@ package ltng_none lightning_option==0 - - package ltng_crm_PR92w lightning_option==1 - state:ic_flashcount,ic_flashrate,cg_flashcount,cg_flashrate package ltng_crm_PR92z lightning_option==2 - state:ic_flashcount,ic_flashrate,cg_flashcount,cg_flashrate package ltng_cpm_PR92z lightning_option==11 - state:ic_flashcount,ic_flashrate,cg_flashcount,cg_flashrate +package ltng_lpi lightning_option==3 - state:lpi # only need to specify these once; not for every io_form* variable package io_intio io_form_restart==1 - - package io_netcdf io_form_restart==2 - - @@ -2641,7 +2785,8 @@ package io_esmf io_form_restart==7 - - package io_yyy io_form_restart==8 - - package io_zzz io_form_restart==9 - - package io_grib2 io_form_restart==10 - - -package io_pnetcdf io_form_restart==11 - - +package io_pnetcdf io_form_restart==11 - - +package io_pio io_form_restart==12 - - #WRF Hydro package no_wrfhydro wrf_hydro==0 - - @@ -2660,10 +2805,10 @@ package fitchscheme windfarm_opt==1 - state:power halo HALO_EM_INIT_1 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,ph_1,ph_2 halo HALO_EM_INIT_2 dyn_em 48:t_1,t_2,mu_1,mu_2,tke_1,tke_2,ww,phb halo HALO_EM_INIT_3 dyn_em 48:ph0,php,t_init,mub,mu0,p,al,alt,alb -halo HALO_EM_INIT_4 dyn_em 48:pb,h_diabatic,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,f,e,sina,cosa,ht,potevp,snopcx,soiltb,xlat,xlong,xlat_u,xlat_v,xlong_u,xlong_v,clat +halo HALO_EM_INIT_4 dyn_em 48:pb,h_diabatic,qv_diabatic,qc_diabatic,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,f,e,sina,cosa,ht,potevp,snopcx,soiltb,xlat,xlong,xlat_u,xlat_v,xlong_u,xlong_v,clat halo HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar,tracer halo HALO_EM_INIT_6 dyn_em 48:om_tmp,om_s,om_u,om_v,om_depth,om_tini,om_sini,om_lat,om_lon,om_ml -halo HALO_EM_VINTERP_UV_1 dyn_em 8:pd_gc,pb +halo HALO_EM_VINTERP_UV_1 dyn_em 24:pd_gc,pb,pmaxw,ptrop halo HALO_EM_A dyn_em 8:ru,rv,rw,ww,php,alt,al,p,muu,muv,mut halo HALO_EM_PHYS_A dyn_em 4:u_2,v_2 halo HALO_EM_PHYS_PBL dyn_em 4:rublten,rvblten @@ -2713,6 +2858,7 @@ halo HALO_EM_SCALAR_E_5 dyn_em 48:scalar halo HALO_EM_SCALAR_E_7 dyn_em 80:scalar halo HALO_TOPOSHAD phys 24:ht_shad halo HALO_EM_HORIZ_INTERP dyn_em 24:t_2,ph_2,ht,t_max_p,ght_max_p,max_p,t_min_p,ght_min_p,min_p +halo HALO_EM_THETAM dyn_em 48:t_1,t_2,h_diabatic halo HALO_EM_MOIST_OLD_E_3 dyn_em 24:moist_old halo HALO_EM_MOIST_OLD_E_5 dyn_em 48:moist_old @@ -2786,6 +2932,7 @@ period PERIOD_BDY_EM_C dyn_em 2:u_2,u_save,v_2,v_save,t_2,t_save,muv,msfvx,ms period PERIOD_BDY_EM_D dyn_em 3:u_2,v_2,w_2,t_2,ph_2,mu_2,tke_2 period PERIOD_BDY_EM_D3 dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,mu_1,mu_2 period PERIOD_EM_DA dyn_em 2:ru_m,rv_m,ww_m,mut,muts +period PERIOD_EM_THETAM dyn_em 3:t_1,t_2,h_diabatic # #swap SWAP_ETAMP_NEW dyn_em 1:dz8w,p_phy,pi_phy,rho,th_phy,moist,F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,RAINNC,RAINNCV,SR,LOWLYR @@ -2890,3 +3037,6 @@ state real dif_yyy ikjy - 1 xpose XPOSE_SPECTRAL_NUDGING dyn_em dif_analysis,dif_xxx,dif_yyy ## + +package no_fft_used fft_used==0 - - +package any_fft_used fft_used==1 - state:t_xxx,u_xxx,ru_xxx,v_xxx,rv_xxx,w_xxx,ww_xxx,ph_xxx,dum_yyy,fourd_xxx diff --git a/wrfv2_fire/Registry/Registry.EM_COMMON.var b/wrfv2_fire/Registry/Registry.EM_COMMON.var index d6d4dae8..47b81d52 100644 --- a/wrfv2_fire/Registry/Registry.EM_COMMON.var +++ b/wrfv2_fire/Registry/Registry.EM_COMMON.var @@ -296,6 +296,8 @@ state real t00 - misc - - i02rh "t state real p00 - misc - - i02rh "p00" "BASE STATE PRESURE" "Pa" state real tlp - misc - - i02rh "tlp" "BASE STATE LAPSE RATE " "" state real tiso - misc - - i02rh "tiso" "TEMP AT WHICH THE BASE T TURNS CONST" "K" +state real tlp_strat - misc - - i02rh "tlp_strat" "BASE STATE LAPSE RATE (DT/D(LN(P)) IN STRATOSPHERE" "K" +state real p_strat - misc - - i02rh "p_strat" "BASE STATE PRESSURE AT BOTTOM OF STRATOSPHERE" "Pa" state real max_msftx - misc - - rh "max_mstfx" "Max map factor in domain" "" state real max_msfty - misc - - rh "max_mstfy" "Max map factor in domain" "" @@ -386,7 +388,8 @@ package io_esmf io_form_restart==7 - - package io_yyy io_form_restart==8 - - package io_zzz io_form_restart==9 - - package io_grib2 io_form_restart==10 - - -package io_pnetcdf io_form_restart==11 - - +package io_pnetcdf io_form_restart==11 - - +package io_pio io_form_restart==12 - - #WRF Hydro package no_wrfhydro wrf_hydro==0 - - diff --git a/wrfv2_fire/Registry/Registry.NMM b/wrfv2_fire/Registry/Registry.NMM index 2585295a..d70b0434 100644 --- a/wrfv2_fire/Registry/Registry.NMM +++ b/wrfv2_fire/Registry/Registry.NMM @@ -1,4 +1,4 @@ -# Registry file NMM +# Registry file Registry.NMM - combined multi-configuration NMM Registry file # # At the present time this file is managed manually and edited by hand. # @@ -42,10 +42,7 @@ include registry.dimspec include registry.lake -#### 7. Edit the Registry file and create the state data assocaited with this -#### solver. Single entry: -state real x ikj dyn_exp 2 - ir "TOYVAR" -#### +rconfig integer halo_debug namelist,domains 1 0 - "halo_debug" "Halo clearing setting" ############# rconfig integer ntracers namelist,physics 1 4 - @@ -60,7 +57,7 @@ rconfig integer ntracers namelist,physics 1 4 #package tracer_option_1 ntracers==4 - tracers:t1,t2,t3,t4 # option 2 -state real - ijkf szj 1 - - - - +state real - ijkf szj 1 - - - - state real szj1 ijkf szj 1 - r "szj1" "szj" "units" state real szj2 ijkf szj 1 - r "szj2" "szj" "units" state real szj3 ijkf szj 1 - r "szj3" "szj" "units" @@ -72,13 +69,13 @@ state real s1z2 ijkf s1z 1 - r "s1z2" "s1z" "units" state real s1z3 ijkf s1z 1 - r "s1z3" "s1z" "units" state real s1z4 ijkf s1z 1 - r "s1z4" "s1z" "units" -state real - ijkf spz 1 - - - - +state real - ijkf spz 1 - - - - state real spz1 ijkf spz 1 - r "spz1" "spz" "units" state real spz2 ijkf spz 1 - r "spz2" "spz" "units" state real spz3 ijkf spz 1 - r "spz3" "spz" "units" state real spz4 ijkf spz 1 - r "spz4" "spz" "units" -state real - ijkf tcs 1 - - - - +state real - ijkf tcs 1 - - - - state real tcs1 ijkf tcs 1 - r "tcs1" "tcs" "units" state real tcs2 ijkf tcs 1 - r "tcs2" "tcs" "units" state real tcs3 ijkf tcs 1 - r "tcs3" "tcs" "units" @@ -97,19 +94,19 @@ package tracer_option_2 ntracers==4 - szj:szj1,szj2,szj3,szj4;s1z:s1z1,s1z2,s1z3 # It is reauired that LU_INDEX appears before any variable that is # interpolated with a mask, as lu_index supplies that mask. # -state real LU_INDEX ij misc 1 - irh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" -state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" +state real LU_INDEX ij misc 1 f irhd=(DownNear)u=(UpNear) "LU_INDEX" "LAND USE CATEGORY" "" +state real LU_MASK ij misc 1 f i3h "LU_MASK" "0 land 1 water" "" ################################################################################ ################################################################################ ################################ ## WPS-specific Variables ################################ - + state real p_gc ijg dyn_nmm 1 Z i1 "PRES" "pressure" "Pa" state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" - + state real input_soil_cat ij misc 1 - i12 "SOIL_CAT" "SOIL CAT DOMINANT TYPE" "" state real tsk_gc ij dyn_nmm 1 - i1 "SKINTEMP" "skin temperature" "K" state real XICE_gc ij misc 1 - i014r "SEAICE" "SEA ICE" "" @@ -132,12 +129,14 @@ state real vlon_gc ij dyn_nmm 1 - i1 "XLONG_ state real vlat_gc ij dyn_nmm 1 - i1 "XLAT_V" "latitude, positive north" "degrees" state real hlon_gc ij dyn_nmm 1 - i1 "XLONG_M" "longitude, positive east" "degrees" state real hlat_gc ij dyn_nmm 1 - i1 "XLAT_M" "latitude, positive north" "degrees" - -# Smoother work variables: -state real relaxwork ij dyn_nmm 1 - r "relaxwork" "Temporary Tv storage array for the membrane MSLP overrelaxation loops" "K" -state integer relaximask ij dyn_nmm 1 - r "relaximask" "Integer mask array for the membrane MSLP overrelaxation loops" "K" -state logical relaxmask ij dyn_nmm 1 - r "relaxmask" "Mask array for the membrane MSLP overrelaxation loops" "K" +############################################################## +# Variables for coupling + +ifdef HWRF=1 +state real dtc - dyn_nmm 1 - irh "DTC" "Coupling timestep" "s" +state real guessdtc - dyn_nmm 1 - irh "GUESSDTC" "Guessed Coupling Timestep for Uncoupled Run" "s" +endif ############################################################## # Variables for nmm dynamics @@ -146,60 +145,146 @@ state logical relaxmask ij dyn_nmm 1 - r "relaxmask" "Mask arr # # pdb is only 2d but registry doesn't support 2d bdy arrays right now... +# The following arrays were added to avoid using _b and _bt arrays for nesting. +# This is gopal' doing: + +state integer nrnd1 k dyn_nmm 1 - r "NRND1" + +state real relaxwork ij dyn_nmm 1 - r "relaxwork" "Temporary Tv storage array for the membrane MSLP overrelaxation loops" "K" +state integer relaximask ij dyn_nmm 1 - r "relaximask" "Integer mask array for the membrane MSLP overrelaxation loops" "K" +state logical relaxmask ij dyn_nmm 1 - r "relaxmask" "Mask array for the membrane MSLP overrelaxation loops" "K" + +# +# For the Inlined GFDL/NCEP Tracker +# +rconfig integer vortex_tracker namelist,physics max_domains 1 - "vortex_tracker" "Vortex Tracking Algorithm" "" +ifdef HWRF=1 +include registry.tracker +endif + + +# +# For the moving nest. This is gopal's doing +# + +state real pdyn ij dyn_nmm 1 - rh "PDYN" "Dynamic pressure at mean sea level" +state real mslp ij dyn_nmm 1 - rh "MSLP" "Shuell Mean Sea Level Pressure" "Pa" +ifdef HWRF=1 +state real best_mslp ij dyn_nmm 1 - rh0123 "BEST_MSLP" "Best Mean Sea Level Pressure (Shuell or Membrane)" "Pa" +endif +state real sqws ij dyn_nmm 1 - r "SQWS" "SQUARE OF WIND SPEED AT LEVEL 10" +state integer xloc - dyn_nmm 2 - r "XLOC" "I-LOCATION OF MINIMUM DYNAMIC PRESSURE" +state integer yloc - dyn_nmm 2 - r "YLOC" "J-LOCATION OF MINIMUM DYNAMIC PRESSURE" +state logical mvnest - dyn_nmm 1 - r "MVNEST" "LOGICAL SWITCH FOR NMM GRID MOTION" +#for HWRF: zhang's doing added to calculate radiation constant for moving nest for restart state integer julyr_rst - dyn_nmm 1 - r "JULYR_RST" "JULYR for restart moving nest " state integer julday_rst - dyn_nmm 1 - r "JULDAY_RST" "JULDAY for restart moving nest " state real gmt_rst - dyn_nmm 1 - r "GMT_RST" "GMT for restart moving nest " state integer NTIME0 - dyn_nmm 1 - r "NTIME0" "COUNT FOR PREVIOUS MOVING NEST" +#for HWRF: # flag for nest movement -state logical moved - misc 1 - - +state logical moved - misc 1 - r state real ducudt ijk misc 1 - rh "UMMIX" "U TENDENCY MOMENTUM MIXING IN SAS" state real dvcudt ijk misc 1 - rh "VMMIX" "V TENDENCY MOMENTUM MIXING IN SAS" -# For random number in SAS convection in HWRF state integer randstate1 ij dyn_nmm 1 - r "randstate1" "random number generator state word 1" state integer randstate2 ij dyn_nmm 1 - r "randstate2" "random number generator state word 2" state integer randstate3 ij dyn_nmm 1 - r "randstate3" "random number generator state word 3" state integer randstate4 ij dyn_nmm 1 - r "randstate4" "random number generator state word 4" state real random ij dyn_nmm 1 - rh "random" "random number in [0,1) used by SAS" -rconfig integer random_seed namelist,physics max_domains 0 irh "random_seed" "random number generator seed" +# Location of the SOUTH-WEST nested pointed in terms of parent grid + +state integer IIH ij dyn_nmm 1 - r +state integer JJH ij dyn_nmm 1 - r +state integer IIV ij dyn_nmm 1 - r +state integer JJV ij dyn_nmm 1 - r + +# Location of nearest parent point: + +state integer hnear_i ij dyn_nmm 1 - r "HNEAR_I" "I index of nearest parent point on H grid" +state integer hnear_j ij dyn_nmm 1 - r "HNEAR_J" "J index of nearest parent point on H grid" + +# Bi-linear weights + +state real HBWGT1 ij dyn_nmm 1 - r +state real HBWGT2 ij dyn_nmm 1 - r +state real HBWGT3 ij dyn_nmm 1 - r +state real HBWGT4 ij dyn_nmm 1 - r +state real VBWGT1 ij dyn_nmm 1 - r +state real VBWGT2 ij dyn_nmm 1 - r +state real VBWGT3 ij dyn_nmm 1 - r +state real VBWGT4 ij dyn_nmm 1 - r +#end of HWRF: + +# +state real HLON ij dyn_nmm 1 - h0123d=(NoInterp) +state real HLAT ij dyn_nmm 1 - h0123d=(NoInterp) +state real VLON ij dyn_nmm 1 - irh023 +state real VLAT ij dyn_nmm 1 - irh023 + +ifdef HWRF=1 +state integer hifreq_lun - dyn_nmm 0 - - +state integer outatcf_lun - dyn_nmm 0 - - +endif + +include registry.tornado # Projection south and west bounds for Post: rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain in rotated coordinates" rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain in rotated coordinates" -state real wbd0var - dyn_nmm 0 - h "wbd0var" "western boundary of the domain in rotated coordinates" -state real sbd0var - dyn_nmm 0 - h "sbd0var" "southern boundary of the domain in rotated coordinates" +state real wbd0var - dyn_nmm 0 - h0123 "wbd0var" "western boundary of the domain" +state real sbd0var - dyn_nmm 0 - h0123 "sbd0var" "southern boundary of the domain" +#for HWRF: +rconfig logical analysis namelist,time_control max_domains .false. irh "analysis flag" "analysis control for the nested domain" +rconfig logical write_analysis namelist,time_control max_domains .true. irh "analysis output flag" "if analysis=F and write_analysis=T then analysis file is written" +rconfig integer io_form_auxinput2 namelist,time_control 1 2 + +ifdef HWRF=1 +rconfig logical high_freq namelist,time_control 1 .true. irh "high frequency output" "flag for high frequency output" +rconfig integer high_dom namelist,time_control 1 -99 irh "domain" "domain for high frequency output (-99 means all domains without children)" +endif + +state real PSTD k dyn_nmm 1 Z r +state integer KZMAX - dyn_nmm - - r +#end of HWRF: + +state real HRES_FIS ij dyn_nmm 1 - rd=(NoInterp)u=(NoInterp)f=(NoInterp) "HRES_FIS" "HIGH RESOLUTION TERRAIN DATA FOR NESTED DOMAIN" +state real HRES_AVC ij dyn_nmm 1 - - "HRES_AVC" "TEMPORARY STORAGE OF HRES_FIS/9.81" +state real HRES_LND ij dyn_nmm 1 - - "HRES_LND" "TEMPORARY STORAGE OF HIGH-RES LND" # # module_MASKS # -state real hbm2 ij dyn_nmm 1 - irh "HBM2" "Height boundary mask; =0 outer 2 rows on H points" "" +state real hbm2 ij dyn_nmm 1 - irh0123 "HBM2" "Height boundary mask; =0 outer 2 rows on H points" "" state real hbm3 ij dyn_nmm 1 - irh "HBM3" "Height boundary mask; =0 outer 3 rows on H points" "" state real vbm2 ij dyn_nmm 1 - irh "VBM2" "Velocity boundary mask; =0 outer 2 rows on V points" "" state real vbm3 ij dyn_nmm 1 - irh "VBM3" "Velocity boundary mask; =0 outer 3 rows on V points" "" -state real sm ij dyn_nmm 1 - i01rh "SM" "Sea mask; =1 for sea, =0 for land" "" -state real sice ij dyn_nmm 1 - irh "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" +state real sm ij dyn_nmm 1 f i01rh0123d=(DownNear) "SM" "Sea mask; =1 for sea, =0 for land" "" +state real sice ij dyn_nmm 1 f irh023d=(DownNear) "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" # # module_VRBLS # -state integer ntsd - dyn_nmm - - r "NTSD" "Number of timesteps done" "" -state integer nstart_hour - dyn_nmm - - r "NSTART_HOUR" "Forecast hour at start of integration" "" -state real pd ijb dyn_nmm 1 - i01rh "PD" "Mass at I,J in the sigma domain" "Pa" -state real fis ij dyn_nmm 1 - i01rh "FIS" "Surface geopotential" "m2 s-2" -state real res ij dyn_nmm 1 - irh "RES" "Reciprocal of surface sigma" "" -state real t ijkb dyn_nmm 1 - i01rh "T" "Sensible temperature" "K" -state real q ijkb dyn_nmm 1 - i01rh "Q" "Specific humidity" "kg kg-1" -state real u ijkb dyn_nmm 1 - i01rh "U" "U component of wind" "m s-1" -state real v ijkb dyn_nmm 1 - i01rh "V" "V component of wind" "m s-1" -state real told ijk dyn_nmm 1 - r "TOLD" "T from previous timestep" "K" -state real uold ijk dyn_nmm 1 - r "UOLD" "U from previous timestep" "m s-1" -state real vold ijk dyn_nmm 1 - r "VOLD" "V from previous timestep" "m s-1" +state integer ntsd - dyn_nmm - - rh "NTSD" "Number of timesteps done" "" +state integer nstart_hour - dyn_nmm - - r "NSTART_HOUR" "Forecast hour at start of integration" "" + +state real pd ijb dyn_nmm 1 - i01rh023u=(NoInterp)d=(NoInterp)f=(NoInterp) "PD" "Mass at I,J in the sigma domain" "Pa" +state real fis ij dyn_nmm 1 - i01rh023u=(NoInterp)d=(NoInterp)f=(NoInterp) "FIS" "Surface geopotential" "m2 s-2" +state real res ij dyn_nmm 1 - irh "RES" "Reciprocal of surface sigma" "" +state real t ijkb dyn_nmm 1 - i01rh023u=(NoInterp)d=(NoInterp)f=(NoInterp) "T" "Sensible temperature" "K" +state real q ijkb dyn_nmm 1 - i01rh023u=(NoInterp)d=(NoInterp)f=(NoInterp) "Q" "Specific humidity" "kg kg-1" +state real test_vgrid ij dyn_nmm 1 v - "test_vgrid" "Testing V grid staggering" "gibbletrons" +state real u ijkb dyn_nmm 1 v i01rh023u=(UpVel)d=(DownVel)f=(BdyVel) "U" "U component of wind" "m s-1" +state real v ijkb dyn_nmm 1 v i01rh023u=(UpVel)d=(DownVel)f=(BdyVel) "V" "V component of wind" "m s-1" +state real told ijk dyn_nmm 1 - r "TOLD" "T from previous timestep" "K" +state real uold ijk dyn_nmm 1 - r "UOLD" "U from previous timestep" "m s-1" +state real vold ijk dyn_nmm 1 - r "VOLD" "V from previous timestep" "m s-1" # # NMM DFI # -# state real hcoeff {ndfi} misc 1 - - "HCOEFF" "initialization weights" -# state real hcoeff_tot - misc 1 - - "HCOEFF_TOT" "initialization weights" +state real hcoeff {ndfi} misc 1 - - "HCOEFF" "initialization weights" +state real hcoeff_tot - misc 1 - - "HCOEFF_TOT" "initialization weights" state real dfi_pd ij misc 1 - r "DFI_PD" "Mass at I,J in the sigma domain" "Pa" state real dfi_pint ijk misc 1 Z r "DFI_PINT" "Model layer interface pressure" "Pa" @@ -211,9 +296,8 @@ state real dfi_v ijk misc 1 - r "DFI_V" "V co state real dfi_q2 ijk misc 1 - r "DFI_Q2" "2 * Turbulence kinetic energy" "m2 s-2" state real dfi_cwm ijk misc 1 - r "DFI_CWM" "Total condensate" "kg kg-1" state real dfi_rrw ijk misc 1 - r "DFI_RRW" "Tracer" "kg kg-1" -# ### remaining simply set aside, and restored to original values after filtering. -# +### state real dfi_STC ilj misc 1 Z r "DFI_STC" "SOIL TEMPERATURE" "K" state real dfi_SMC ilj misc 1 Z r "DFI_SMC" "SOIL MOISTURE" "m3 m-3" state real dfi_SH2O ilj misc 1 Z r "DFI_SH2O" "UNFROZEN SOIL MOISTURE" "m3 m-3" @@ -223,11 +307,12 @@ state real dfi_SNOWH ij misc 1 - r "dfi_SNOWH state real dfi_CANWAT ij misc 1 - r "dfi_CANWAT" "CANOPY WATER" "kg m-2" state real dfi_NMM_TSK ij misc 1 - r "dfi_NMM_TSK" "saved SURFACE SKIN TEMPERATURE" state real dfi_SNOWC ij misc 1 - r "dfi_SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" + # # module_DYNAM # -state real dx_nmm ij dyn_nmm 1 - irh "DX_NMM" "East-west distance H-to-V points" "m" -state real wpdar ij dyn_nmm 1 - ir +state real dx_nmm ij dyn_nmm 1 - irh023 "DX_NMM" "East-west distance H-to-V points" "m" +state real wpdar ij dyn_nmm 1 - ir state real cpgfu ij dyn_nmm 1 - ir state real curv ij dyn_nmm 1 - ir "CURV" "Curvature term= .5*DT*TAN(phi)/RadEarth" "s m-1" state real fcp ij dyn_nmm 1 - ir @@ -238,119 +323,129 @@ state real ddmpu ij dyn_nmm 1 - ir "DDMPU" "Dive state real ddmpv ij dyn_nmm 1 - ir "DDMPV" "Divergence damping term for V" "m" state real deta k dyn_nmm 1 - i01r "DETA" "Delta sigma in sigma domain" "" state real rdeta k dyn_nmm 1 - ir "RDETA" "Reciprocal of DETA" "" -state real aeta k dyn_nmm 1 - i01r -state real f4q2 k dyn_nmm 1 - ir +state real aeta k dyn_nmm 1 - i01r +state real f4q2 k dyn_nmm 1 - ir state real etax k dyn_nmm 1 - i01r state real dfl k dyn_nmm 1 Z i01r "DFL" "Standard atmosphere geopotential" "m2 s-2" -state real deta1 k dyn_nmm 1 - i01r "DETA1" "Delta sigma in pressure domain" "" -state real aeta1 k dyn_nmm 1 - i01r "AETA1" "Midlayer sigma value in pressure domain" "" -state real eta1 k dyn_nmm 1 Z i01rh "ETA1" "Interface sigma value in pressure domain" "" -state real deta2 k dyn_nmm 1 - i01r "DETA2" "Delta sigma in sigma domain" "" -state real aeta2 k dyn_nmm 1 - i01r "AETA2" "Midlayer sigma value in sigma domain" "" -state real eta2 k dyn_nmm 1 Z i01rh "ETA2" "Interface sigma value in sigma domain" "" +state real deta1 k dyn_nmm 1 - i01rh023 "DETA1" "Delta sigma in pressure domain" "" +state real aeta1 k dyn_nmm 1 - i01rh023 "AETA1" "Midlayer sigma value in pressure domain" "" +state real eta1 k dyn_nmm 1 Z i01rh0123 "ETA1" "Interface sigma value in pressure domain" "" +state real deta2 k dyn_nmm 1 - i01rh023 "DETA2" "Delta sigma in sigma domain" "" +state real aeta2 k dyn_nmm 1 - i01rh023 "AETA2" "Midlayer sigma value in sigma domain" "" +state real eta2 k dyn_nmm 1 Z i01rh0123 "ETA2" "Interface sigma value in sigma domain" "" state real em q dyn_nmm 1 - ir state real emt q dyn_nmm 1 - ir -state real adt ij dyn_nmm 1 - - "ADT" "Change of T due to advection" "K" -state real adu ij dyn_nmm 1 - - "ADU" "Change of U due to advection" "m s-1" -state real adv ij dyn_nmm 1 - - "ADV" "Change of V due to advection" "m s-1" +#for HWRF: add to restart +state real adt ij dyn_nmm 1 - r "ADT" "Change of T due to advection" "K" +state real adu ij dyn_nmm 1 - r "ADU" "Change of U due to advection" "m s-1" +state real adv ij dyn_nmm 1 - r "ADV" "Change of V due to advection" "m s-1" +#end HWRF: state real em_loc q dyn_nmm 1 - r state real emt_loc q dyn_nmm 1 - r -state real dy_nmm - dyn_nmm - - ir "DY_NMM" "North-south distance H-to-V points" "m" +state real dy_nmm - dyn_nmm - - irh023 "DY_NMM" "North-south distance H-to-V points" "m" state real cpgfv - dyn_nmm - - ir state real en - dyn_nmm - - ir state real ent - dyn_nmm - - ir state real f4d - dyn_nmm - - ir state real f4q - dyn_nmm - - ir state real ef4t - dyn_nmm - - ir +#for HWRF: add to restart state logical upstrm - dyn_nmm - - - "UPSTRM" ".TRUE. => In upstream advec region of grid" "" -state real dlmd - dyn_nmm - - ir "DLMD" "East-west angular distance H-to-V points" "degrees" -state real dphd - dyn_nmm - - ir "DPHD" "North-south angular distance H-to-V points" "degrees" -state real pdtop - dyn_nmm - - i01rh "PDTOP" "Mass at I,J in pressure domain" "Pa" -state real pt - dyn_nmm - - i01rh "PT" "Pressure at top of domain" "Pa" +#end HWRF: +state real dlmd - dyn_nmm - - irh023 "DLMD" "East-west angular distance H-to-V points" "degrees" +state real dphd - dyn_nmm - - irh023 "DPHD" "North-south angular distance H-to-V points" "degrees" +state real pdtop - dyn_nmm - - i01rh023 "PDTOP" "Mass at I,J in pressure domain" "Pa" +state real pt - dyn_nmm - - i01rh023 "PT" "Pressure at top of domain" "Pa" # # module_CONTIN # +#for HWRF: add to restart state real pdsl ij dyn_nmm 1 - r "PDSL" "Sigma-domain pressure at sigma=1" "Pa" state real pdslo ij dyn_nmm 1 - r "PDSLO" "PDSL from previous timestep" "Pa" +#end HWRF: state real psdt ij dyn_nmm 1 - r "PSDT" "Surface pressure tendency" "Pa s-1" state real div ijk dyn_nmm 1 - r "DIV" "Divergence" "Pa s-1" +state real def3d ijk dyn_nmm 1 - r "DEF3D" "Deformation term from horizontal diffusion" "" +#for HWRF: add to restart state real few ijk dyn_nmm 1 - r "FEW" "Integrated east-west mass flux" "Pa m2 s-1" state real fne ijk dyn_nmm 1 - r "FNE" "Integrated northeast-southwest mass flux" "Pa m2 s-1" state real fns ijk dyn_nmm 1 - r "FNS" "Integrated north-south mass flux" "Pa m2 s-1" state real fse ijk dyn_nmm 1 - r "FSE" "Integrated southeast-northwest mass flux" "Pa m2 s-1" +#end HWRF: state real omgalf ijk dyn_nmm 1 - r "OMGALF" "Omega-alpha" "K" +#for HWRF: add to restart state real petdt ijk dyn_nmm 1 - r "PETDT" "Vertical mass flux" "Pa s-1" +#end HWRF: state real rtop ijk dyn_nmm 1 - r "RTOP" "Rd * Tv / P" "m3 kg-1" # # module_PVRBLS # -state real pblh ij dyn_nmm 1 - rh "PBLH" "PBL Height" "m" +state real pblh ij dyn_nmm 1 - rh023 "PBLH" "PBL Height" "m" state integer lpbl ij dyn_nmm 1 - ir "LPBL" "Model layer of PBL top" "" -state real mixht ij dyn_nmm 1 - rh "MIXHT" "MXL HEIGHT" "m" -state real ustar ij dyn_nmm 1 - irh "USTAR" "Friction velocity" "m s-1" -state real mz0 ij dyn_nmm 1 - h "MZ0" "momentum Roughness length" "m" +state real mixht ij dyn_nmm 1 - rh "MIXHT" "MXL HEIGHT" "m" +state real ustar ij dyn_nmm 1 - irh023d=(DownNear) "USTAR" "Friction velocity" "m s-1" +state real z0 ij dyn_nmm 1 - i01rh023d=(DownNear) "Z0" "Thermal Roughness length" "m" +state real mz0 ij dyn_nmm 1 - h "MZ0" "momentum Roughness length" "m" state real rc2d ij dyn_nmm 1 - h "RC2D" "critical Richardson number" "m" state real dku3d ijk dyn_nmm 1 - h "DKU3D" "Momentum Diffusivity" "m*m/s" state real dkt3d ijk dyn_nmm 1 - h "DKT3D" "Thermal Diffusivity" "m*m/s" -state real z0 ij dyn_nmm 1 - i01rh "Z0" "Roughness height" "m" -state real hpbl2d ij dyn_nmm 1 - irh "HPBL2D" "HEIGHT OF PBL from new2010 GFS pbl" "m" +state real hpbl2d ij dyn_nmm 1 - irh "HPBL2D" "HEIGHT OF PBL from new GFS pbl" "m" state real heat2d ij dyn_nmm 1 - irh "HEAT2D" "" "" state real evap2d ij dyn_nmm 1 - irh "EVAP2D" "" "" state real z0base ij dyn_nmm 1 - ir "Z0BASE" "Base roughness height" "m" -state real ths ij dyn_nmm 1 - irh "THS" "Surface potential temperature" "K" +state real ths ij dyn_nmm 1 - irh023d=(DownCopy) "THS" "Surface potential temperature" "K" state real mavail ij dyn_nmm 1 - i -state real qsh ij dyn_nmm 1 - irh "QS" "Surface specific humidity" "kg kg-1" -state real twbs ij dyn_nmm 1 - irh "TWBS" "Instantaneous sensible heat flux" "W m-2" -state real qwbs ij dyn_nmm 1 - irh "QWBS" "Instantaneous latent heat flux" "W m-2" -state real taux ij dyn_nmm 1 - irh "TAUX" "Instantaneous stress along X direction in KG/M/S^2" -state real tauy ij dyn_nmm 1 - irh "TAUY" "Instantaneous stress along Y direction in KG/M/S^2" -state real prec ij dyn_nmm 1 - rh "PREC" "Precipitation in physics timestep" "m" +state real qsh ij dyn_nmm 1 - irh023d=(DownCopy) "QS" "Surface specific humidity" "kg kg-1" +state real twbs ij dyn_nmm 1 - irh0123 "TWBS" "Instantaneous sensible heat flux" "W m-2" +state real qwbs ij dyn_nmm 1 - irh0123 "QWBS" "Instantaneous latent heat flux" "W m-2" +state real taux ij dyn_nmm 1 - irh0123 "TAUX" "Instantaneous stress along X direction in KG/M/S^2" +state real tauy ij dyn_nmm 1 - irh0123 "TAUY" "Instantaneous stress along Y direction in KG/M/S^2" +state real prec ij dyn_nmm 1 - rh023 "PREC" "Precipitation in physics timestep" "m" state real aprec ij dyn_nmm 1 - rh -state real acprec ij dyn_nmm 1 - rh "ACPREC" "Accumulated total precipitation" "m" -state real cuprec ij dyn_nmm 1 - rh "CUPREC" "Accumulated convective precipitation" "m" -state real lspa ij dyn_nmm 1 - h "LSPA" "Land Surface Precipitation Accumulation" "kg m-2" +state real acprec ij dyn_nmm 1 - rh0123d=(DownCopy) "ACPREC" "Accumulatedtotal precipitation" "m" +state real cuprec ij dyn_nmm 1 - rh023 "CUPREC" "Accumulated convective precipitation" "m" +state real lspa ij dyn_nmm 1 - h023 "LSPA" "Land Surface Precipitation Accumulation" "kg m-2" state real ddata ij dyn_nmm 1 - - "DDATA" "Observed precip to each physics timestep" "kg m-2" state real accliq ij dyn_nmm 1 - r -state real sno ij dyn_nmm 1 - irh "SNO" "Liquid water eqiv of snow on ground" "kg m-2" -state real si ij dyn_nmm 1 - irh "SI" "Depth of snow on ground" "mm" -state real cldefi ij dyn_nmm 1 - rh "CLDEFI" "Convective cloud efficiency" "" +state real sno ij dyn_nmm 1 - irh023 "SNO" "Liquid water eqiv of snow on ground" "kg m-2" +state real si ij dyn_nmm 1 - irh023 "SI" "Depth of snow on ground" "mm" +state real cldefi ij dyn_nmm 1 - rh023d=(DownCopy) "CLDEFI" "Convective cloud efficiency" "" state real deep ij dyn_nmm 1 - r "DEEP" "Deep convection =>.TRUE." "" state real rf ij dyn_nmm 1 - r -state real th10 ij dyn_nmm 1 - rh "TH10" "10-m potential temperature from MYJ" "K" -state real q10 ij dyn_nmm 1 - rh "Q10" "10-m specific humidity from MYJ" "kg kg-1" -state real pshltr ij dyn_nmm 1 - rh "PSHLTR" "2-m pressure from MYJ" "Pa" -state real tshltr ij dyn_nmm 1 - rh "TSHLTR" "2-m potential temperature from MYJ" "K" -state real qshltr ij dyn_nmm 1 - rh "QSHLTR" "2-m specific humidity from MYJ" "kg kg-1" -state real q2 ijkb dyn_nmm 1 - irh "Q2" "2 * Turbulence kinetic energy" "m2 s-2" -state real t_adj ijk dyn_nmm 1 - r "T_ADJ" "T change due to precip in phys step" "K" +state real th10 ij dyn_nmm 1 - rh023d=(DownCopy) "TH10" "10-m potential temperature from MYJ" "K" +state real q10 ij dyn_nmm 1 - rh023d=(DownCopy) "Q10" "10-m specific humidity from MYJ" "kg kg-1" +state real pshltr ij dyn_nmm 1 - rh023d=(DownCopy) "PSHLTR" "2-m pressure from MYJ" "Pa" +state real tshltr ij dyn_nmm 1 - rh023d=(DownCopy) "TSHLTR" "2-m potential temperature from MYJ" "K" +state real qshltr ij dyn_nmm 1 - rh023d=(DownCopy) "QSHLTR" "2-m specific humidity from MYJ" "kg kg-1" +state real q2 ijkb dyn_nmm 1 - irh023u=(UpMass:@EConst,0.0)d=(DownMass:@EConst,0.0)f=(BdyMass:@EConst,0.0) "Q2" "2 * Turbulence kinetic energy" "m2 s-2" +state real t_adj ijk dyn_nmm 1 - rd=(DownNear) "T_ADJ" "T change due to precip in phys step" "K" state real t_old ijk dyn_nmm 1 - r "T_OLD" "T before last call to precip" "K" state real zero_3d ijk dyn_nmm 1 - r state real W0AVG ikj dyn_nmm 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" -state real AKHS_OUT ij dyn_nmm 1 - rh "AKHS_OUT" "Output sfc exch coeff for heat" "m2 s-1" -state real AKMS_OUT ij dyn_nmm 1 - rh "AKMS_OUT" "Output sfc exch coeff for momentum" "m2 s-1" +state real AKHS_OUT ij dyn_nmm 1 - rh023 "AKHS_OUT" "Output sfc exch coeff for heat" "m2 s-1" +state real AKMS_OUT ij dyn_nmm 1 - rh023 "AKMS_OUT" "Output sfc exch coeff for momentum" "m2 s-1" # # module_PHYS # -state real albase ij dyn_nmm 1 - i01rh "ALBASE" "Base albedo" "" -state real albedo ij dyn_nmm 1 - irh "ALBEDO" "Dynamic albedo" "" -state real cnvbot ij dyn_nmm 1 - irh "CNVBOT" "Lowest convec cloud bottom lyr between outputs" "" -state real cnvtop ij dyn_nmm 1 - irh "CNVTOP" "Highest convec cloud top lyr between outputs" "" -state real czen ij dyn_nmm 1 - irh "CZEN" "Cosine of solar zenith angle" "" -state real czmean ij dyn_nmm 1 - irh "CZMEAN" "Mean CZEN between SW radiation calls" "" +state real albase ij dyn_nmm 1 - i01rh023d=(DownCopy) "ALBASE" "Base albedo" "" +state real albedo ij dyn_nmm 1 - irh023 "ALBEDO" "Dynamic albedo" "" +state real cnvbot ij dyn_nmm 1 - irh023 "CNVBOT" "Lowest convec cloud bottom lyr between outputs" "" +state real cnvtop ij dyn_nmm 1 - irh023 "CNVTOP" "Highest convec cloud top lyr between outputs" "" +state real czen ij dyn_nmm 1 - irh023 "CZEN" "Cosine of solar zenith angle" "" +state real czmean ij dyn_nmm 1 - irh023 "CZMEAN" "Mean CZEN between SW radiation calls" "" state real embck ij dyn_nmm 1 - ir "EMBCK" "Background radiative emissivity" "" -state real epsr ij dyn_nmm 1 - irh "EPSR" "Radiative emissivity" "" +state real epsr ij dyn_nmm 1 - irh023 "EPSR" "Radiative emissivity" "" state real gffc ij dyn_nmm 1 - ir -state real glat ij dyn_nmm 1 - i01rh "GLAT" "Geographic latitude, radians" "" -state real glon ij dyn_nmm 1 - i01rh "GLON" "Geographic longitude, radians" "" -state real NMM_TSK ij dyn_nmm 1 - i01r "TSK" "Skin temperature" "K" -state real def3d ijk dyn_nmm 1 - r "DEF3D" "Deformation term from horizontal diffusion" "" +state real glat ij dyn_nmm 1 - i01rh023 "GLAT" "Geographic latitude, radians" "" +state real glon ij dyn_nmm 1 - i01rh023 "GLON" "Geographic longitude, radians" "" +state real NMM_TSK ij dyn_nmm 1 - i01rh023d=(DownNear) "TSK" "Skin temperature" "K" state real hdac ij dyn_nmm 1 - ir "HDAC" "Composite diffusion coeff for mass points" "s m-1" state real hdacv ij dyn_nmm 1 - ir "HDACV" "Composite diffusion coeff for velocity points" "s m-1" -state real mxsnal ij dyn_nmm 1 - i01rh "MXSNAL" "Maximum deep snow albedo" "" -state real radin ij dyn_nmm 1 - r -state real radot ij dyn_nmm 1 - rh "RADOT" "Radiative emission from surface" "W m-2" -state real sigt4 ij dyn_nmm 1 - rh "SIGT4" "Stefan-Boltzmann * T**4" "W m-2" -state real tg ij dyn_nmm 1 - i01rh "TGROUND" "Deep ground soil temperature" "K" +state real mxsnal ij dyn_nmm 1 - i01rh023d=(DownNear) "MXSNAL" "Maximum deep snow albedo" "" +state real radin ij dyn_nmm 1 - r +state real radot ij dyn_nmm 1 - rh023 "RADOT" "Radiative emission from surface" "W m-2" +state real sigt4 ij dyn_nmm 1 - rh023d=(DownCopy) "SIGT4" "Stefan-Boltzmann * T**4" "W m-2" +state real tg ij dyn_nmm 1 - i01rh023d=(DownNear) "TGROUND" "Deep ground soil temperature" "K" state real dfrlg k dyn_nmm 1 Z i01r "DFRLG" "Std atmosphere height of model layer interfaces" "m" state integer lvl ij dyn_nmm 1 - ir state integer k22_deep ij misc 1 - - "K22_DEEP" "K22 LEVEL FROM DEEPCONVECTION (G3 only)" "" @@ -368,7 +463,7 @@ state real GD_CLDFR ikj misc 1 - r "GD_ # upward and downward clearsky and total diagnostic fluxes for radiation (RRTMG) state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" state real ACSWUPTC ij misc 1 - rhdu "ACSWUPTC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" -state real ACSWDNT ij misc 1 - rhdu "ACSWDNT" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" +state real ACSWDNT ij misc 1 - rh023du "ACSWDNT" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" state real ACSWDNTC ij misc 1 - rhdu "ACSWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" state real ACSWUPB ij misc 1 - rhdu "ACSWUPB" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" state real ACSWUPBC ij misc 1 - rhdu "ACSWUPBC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" @@ -382,9 +477,9 @@ state real ACLWUPB ij misc 1 - rhdu "A state real ACLWUPBC ij misc 1 - rhdu "ACLWUPBC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" state real ACLWDNB ij misc 1 - rhdu "ACLWDNB" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" state real ACLWDNBC ij misc 1 - rhdu "ACLWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" -state real SWUPT ij misc 1 - rhdu "SWUPT" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real SWUPT ij misc 1 - rh023du "SWUPT" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP" "W m-2" state real SWUPTC ij misc 1 - rhdu "SWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" -state real SWDNT ij misc 1 - rhdu "SWDNT" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real SWDNT ij misc 1 - rh023du "SWDNT" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP" "W m-2" state real SWDNTC ij misc 1 - rhdu "SWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" state real SWUPB ij misc 1 - rhdu "SWUPB" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" state real SWUPBC ij misc 1 - rhdu "SWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2" @@ -403,8 +498,8 @@ state real SWVISDIF ij misc 1 Z r "S state real SWNIRDIR ij misc 1 Z r "SWNIRDIR" "SWR NIR DIR component" "" state real SWNIRDIF ij misc 1 Z r "SWNIRDIF" "SWR NIR DIF component" "" -state real refl_10cm ikj dyn_nmm 1 - h "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" -state real REFD_MAX ij misc 1 - h "REFD_MAX" "MAX DERIVED RADAR REFL" "dbZ" +state real refl_10cm ikj dyn_nmm 1 - h023d=(DownMassIKJ:@ECopy,-35.0) "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" +state real REFD_MAX ij misc 1 - h0123d=(DownCopy) "REFD_MAX" "Composite (column maximum) radar reflectivity (lambda = 10 cm)" "dBZ" state real qnwfa2d ij misc 1 - rhdu "QNWFA2D" "Surface aerosol number conc emission" "kg-1 s-1" state real re_cloud ikj misc 1 - r "re_cloud" "Effective radius, cloud drops" "m" state real re_ice ikj misc 1 - r "re_ice" "Effective radius, cloud ice" "m" @@ -417,36 +512,61 @@ state integer has_reqi - misc 1 - r "has_reqi" state integer has_reqs - misc 1 - r "has_reqs" "Flag for has effective radius of snow" "" # +# added WRF-Solar +state real swddir ij misc 1 - rhd "SWDDIR" "Shortwave surface downward direct irradiance" "W/m^2" "" +state real swddni ij misc 1 - rhd "SWDDNI" "Shortwave surface downward direct normal irradiance" "W/m^2" "" +state real swddif ij misc 1 - rhd "SWDDIF" "Shortwave surface downward diffuse irradiance" "W/m^2" "" +state real Gx ij misc 1 - rd "Gx" "" "" +state real Bx ij misc 1 - rd "Bx" "" "" +state real gg ij misc 1 - rd "gg" "" "" +state real bb ij misc 1 - rd "bb" "" "" +state real coszen_ref ij misc 1 - rd "coszen_ref" "" "" +state real coszen ij misc 1 - - "coszen " "" "" +state real hrang ij misc 1 - - "hrang" "" "" +state real swdown_ref ij misc 1 - rd "swdown_ref" "" "" +state real swddir_ref ij misc 1 - rd "swddir_ref" "" "" +rconfig integer swint_opt namelist,physics 1 0 - "swint_opt" "interpolation option for sw radiation" "" +# add aerosol namelists +rconfig integer aer_type namelist,physics max_domains 1 irh "aer_type" "aerosol type: 1 is SF79 rural, 2 is SF79 urban" "" +rconfig integer aer_aod550_opt namelist,physics max_domains 1 irh "aer_aod550_opt" "input option for aerosol optical depth at 550 nm" "" +rconfig integer aer_angexp_opt namelist,physics max_domains 1 irh "aer_angexp_opt" "input option for aerosol Angstrom exponent" "" +rconfig integer aer_ssa_opt namelist,physics max_domains 1 irh "aer_ssa_opt" "input option for aerosol single-scattering albedo" "" +rconfig integer aer_asy_opt namelist,physics max_domains 1 irh "aer_asy_opt" "input option for aerosol asymmetry parameter" "" +rconfig real aer_aod550_val namelist,physics max_domains 0.12 irh "aer_aod550_val" "fixed value for aerosol optical depth at 550 nm. Valid when aer_aod550_opt=1" "" +rconfig real aer_angexp_val namelist,physics max_domains 1.3 irh "aer_angexp_val" "fixed value for aerosol Angstrom exponent. Valid when aer_angexp_opt=1" "" +rconfig real aer_ssa_val namelist,physics max_domains 0.85 irh "aer_ssa_val" "fixed value for aerosol single-scattering albedo. Valid when aer_ssa_opt=1" "" +rconfig real aer_asy_val namelist,physics max_domains 0.90 irh "aer_asy_val" "fixed value for aerosol asymmetry parameter. Valid when aer_asy_opt=1" "" + # module_CLDWTR.F # -state real cwm ijkb dyn_nmm 1 - rh "CWM" "Total condensate" "kg kg-1" +state real cwm ijkb dyn_nmm 1 - rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "CWM" "Total condensate" "kg kg-1" state real rrw ijkb dyn_nmm 1 - rh "RRW" "Tracer" "kg kg-1" -state real f_ice ikj dyn_nmm 1 - rh "F_ICE" "Frozen fraction of CWM" "" -state real f_rain ikj dyn_nmm 1 - rh "F_RAIN" "Rain fraction of liquid part of CWM" "" -state real f_rimef ikj dyn_nmm 1 - rh "F_RIMEF" "Rime factor" "" -state real cldfra ijk dyn_nmm 1 - rh "CLDFRA" "Cloud fraction" "" -state real sr ij dyn_nmm 1 - irh "SR" "Timestep mass ratio of snow:precip" "" -state real cfrach ij dyn_nmm 1 - rh "CFRACH" "High cloud fraction" "" -state real cfracl ij dyn_nmm 1 - rh "CFRACL" "Low cloud fraction" "" -state real cfracm ij dyn_nmm 1 - rh "CFRACM" "Middle cloud fraction" "" +state real f_ice ikj dyn_nmm 1 - rh023d=(DownMassIKJ:@EExtrap,0.0)u=(UpMassIKJ:@EExtrap,0.0) "F_ICE" "Frozen fraction of CWM" "" +state real f_rain ikj dyn_nmm 1 - rh023d=(DownMassIKJ:@EExtrap,0.0)u=(UpMassIKJ:@EExtrap,0.0) "F_RAIN" "Rain fraction of liquid part of CWM" "" +state real f_rimef ikj dyn_nmm 1 - rh023d=(DownMassIKJ:@EExtrap,1.0)u=(UpMassIKJ:@EExtrap,1.0) "F_RIMEF" "Rime factor" "" +state real cldfra ijk dyn_nmm 1 - rh023 "CLDFRA" "Cloud fraction" "" +state real sr ij dyn_nmm 1 - irh023 "SR" "Timestep mass ratio of snow:precip" "" +state real cfrach ij dyn_nmm 1 - rh023d=(DownCopy) "CFRACH" "High cloud fraction" "" +state real cfracl ij dyn_nmm 1 - rh023d=(DownCopy) "CFRACL" "Low cloud fraction" "" +state real cfracm ij dyn_nmm 1 - rh023d=(DownCopy) "CFRACM" "Middle cloud fraction" "" state logical micro_start - dyn_nmm - - - # # module_SOIL.F # -state integer islope ij dyn_nmm 1 - i01rh -state real dzsoil k dyn_nmm 1 - irh "DZSOIL" "Thickness of soil layers" "m" -state real rtdpth k dyn_nmm 1 - i01r -state real sldpth k dyn_nmm 1 - i01rh "SLDPTH" "Depths of centers of soil layers" "m" -state real cmc ij dyn_nmm 1 - i01rh "CMC" "Canopy moisture" "m" -state real grnflx ij dyn_nmm 1 - irh "GRNFLX" "Deep soil heat flux" "W m-2" -state real pctsno ij dyn_nmm 1 - irh -state real soiltb ij dyn_nmm 1 - i01rh "SOILTB" "Deep ground soil temperature" "K" -state real vegfrc ij dyn_nmm 1 - i014rh "VEGFRC" "Vegetation fraction" "" -state real shdmin ij dyn_nmm 1 - - -state real shdmax ij dyn_nmm 1 - - -state real sh2o ilj dyn_nmm 1 Z irh "SH2O" "Unfrozen soil moisture volume fraction" "" -state real smc ilj dyn_nmm 1 Z irh "SMC" "Soil moisture volume fraction" "" -state real stc ilj dyn_nmm 1 Z irh "STC" "Soil temperature" "K" +state integer islope ij dyn_nmm 1 - i01rh023d=(DownINear) "ISLOPE" +state real dzsoil k dyn_nmm 1 - irh023 "DZSOIL" "Thickness of soil layers" "m" +state real rtdpth k dyn_nmm 1 - i01r +state real sldpth k dyn_nmm 1 - i01rh023 "SLDPTH" "Depths of centers of soil layers" "m" +state real cmc ij dyn_nmm 1 - i01rh023d=(DownNear) "CMC" "Canopy moisture" "m" +state real grnflx ij dyn_nmm 1 - irh023 "GRNFLX" "Deep soil heat flux" "W m-2" +state real pctsno ij dyn_nmm 1 - irh023 +state real soiltb ij dyn_nmm 1 - i01rh023d=(DownNear) "SOILTB" "Deep ground soil temperature" "K" +state real vegfrc ij dyn_nmm 1 - i014rh023d=(DownNear) "VEGFRC" "Vegetation fraction" "" +state real shdmax ij dyn_nmm 1 - ird=(DownNear) "SHDMAX" "ANNUAL MAX VEG FRACTION" "" +state real shdmin ij dyn_nmm 1 - ird=(DownNear) "SHDMIN" "ANNUAL MIN VEG FRACTION" "" +state real sh2o ilj dyn_nmm 1 Z irh023d=(DownNearIKJ) "SH2O" "Unfrozen soil moisture volume fraction" "" +state real smc ilj dyn_nmm 1 Z irh023d=(DownNearIKJ) "SMC" "Soil moisture volume fraction" "" +state real stc ilj dyn_nmm 1 Z irh023d=(DownNearIKJ) "STC" "Soil temperature" "K" # # module_GWD.F # @@ -480,38 +600,40 @@ state logical hydro - dyn_nmm - - - "HYDRO" ".FALSE. state real dwdtmn ij dyn_nmm 1 - - "DWDTMN" "Minimum value for DWDT" "m s-2" state real dwdtmx ij dyn_nmm 1 - - "DWDTMX" "Maximum value for DWDT" "m s-2" state real baro ij dyn_nmm 1 - - "BARO" "external mode vvel" "m s-1" -state real dwdt ijk dyn_nmm 1 - r "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" -state real pdwdt ijk dyn_nmm 1 - r -state real pint ijk dyn_nmm 1 Z rh "PINT" "Model layer interface pressure" "Pa" -state real w ijk dyn_nmm 1 Z r "W" "Vertical velocity" "m s-1" -state real w_tot ijk dyn_nmm 1 Z h "W" "Vertical velocity (complete)" "m s-1" -state real z ijk dyn_nmm 1 Z - "Z" "Distance from ground" "m" +state real dwdt ijk dyn_nmm 1 - rd=(DownCopy) "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" +state real pdwdt ijk dyn_nmm 1 - r +state real pint ijk dyn_nmm 1 Z irh023d=(DownCopy)u=(NoInterp)f=(NoInterp) "PINT" "Model layer interface pressure" "Pa" +state real w ijk dyn_nmm 1 Z rd=(DownCopy) "W_nonhydro" "Vertical velocity (non-hydrostatic component only)" "m s-1" +state real w_tot ijk dyn_nmm 1 Z h023d=(DownCopy) "W" "Vertical velocity" "m s-1" +state real z ijk dyn_nmm 1 Z hd=(DownCopy) "Z" "Distance from ground" "m" # # module_ACCUM.F # -state real acfrcv ij dyn_nmm 1 - rh "ACFRCV" "Accum convective cloud fraction" "" -state real acfrst ij dyn_nmm 1 - rh "ACFRST" "Accum stratiform cloud fraction" "" -state real ssroff ij dyn_nmm 1 - rh "SSROFF" "Surface runoff" "mm" +state real acfrcv ij dyn_nmm 1 - rh023 "ACFRCV" "Accum convective cloud fraction" "" +state real acfrst ij dyn_nmm 1 - rh023 "ACFRST" "Accum stratiform cloud fraction" "" +state real ssroff ij dyn_nmm 1 - rh023 "SSROFF" "Surface runoff" "mm" state real bgroff ij dyn_nmm 1 - rh "BGROFF" "Subsurface runoff" "mm" -state real rlwin ij dyn_nmm 1 - rh "RLWIN" "Downward longwave at surface" "W m-2" +state real rlwin ij dyn_nmm 1 - rh0123d=(DownCopy) "RLWIN" "Downward longwave at surface" "W m-2" state real rlwout ij dyn_nmm 1 - - -state real rlwtoa ij dyn_nmm 1 - rh "RLWTOA" "Outgoing LW flux at top of atmos" "W m-2" -state real alwin ij dyn_nmm 1 - rh "ALWIN" "Accum LW down at surface" "W m-2" -state real alwout ij dyn_nmm 1 - rh "ALWOUT" "Accum RADOT (see above)" "W m-2" -state real alwtoa ij dyn_nmm 1 - rh "ALWTOA" "Accum RLWTOA" "W m-2" -state real rswin ij dyn_nmm 1 - rh "RSWIN" "Downward shortwave at surface" "W m-2" -state real rswinc ij dyn_nmm 1 - rh "RSWINC" "Clear-sky equivalent of RSWIN" "W m-2" -state real rswout ij dyn_nmm 1 - rh "RSWOUT" "Upward shortwave at surface" "W m-2" -state real rswtoa ij dyn_nmm 1 - r "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" -state real aswin ij dyn_nmm 1 - rh "ASWIN" "Accum SW down at surface" "W m-2" -state real aswout ij dyn_nmm 1 - rh "ASWOUT" "Accum RSWOUT" "W m-2" -state real aswtoa ij dyn_nmm 1 - rh "ASWTOA" "Accum RSWTOA" "W m-2" -state real sfcshx ij dyn_nmm 1 - rh "SFCSHX" "Accum sfc sensible heat flux" "W m-2" -state real sfclhx ij dyn_nmm 1 - rh "SFCLHX" "Accum sfc latent heat flux" "W m-2" -state real subshx ij dyn_nmm 1 - rh "SUBSHX" "Accum deep soil heat flux" "W m-2" +state real rlwtoa ij dyn_nmm 1 - rh023 "RLWTOA" "Outgoing LW flux at top of atmos" "W m-2" +state real alwin ij dyn_nmm 1 - rh023 "ALWIN" "Accum LW down at surface" "W m-2" +state real alwout ij dyn_nmm 1 - rh023 "ALWOUT" "Accum RADOT (see above)" "W m-2" +state real alwtoa ij dyn_nmm 1 - rh023 "ALWTOA" "Accum RLWTOA" "W m-2" +state real rswin ij dyn_nmm 1 - rh0123d=(DownCopy) "RSWIN" "Downward shortwave at surface" "W m-2" +state real rswinc ij dyn_nmm 1 - rh023 "RSWINC" "Clear-sky equivalent of RSWIN" "W m-2" +state real rswout ij dyn_nmm 1 - rh0123 "RSWOUT" "Upward shortwave at surface" "W m-2" +#for HWRF: add to restart +state real rswtoa ij dyn_nmm 1 - rh023 "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" +#end HWRF +state real aswin ij dyn_nmm 1 - rh023 "ASWIN" "Accum SW down at surface" "W m-2" +state real aswout ij dyn_nmm 1 - rh023 "ASWOUT" "Accum RSWOUT" "W m-2" +state real aswtoa ij dyn_nmm 1 - rh023 "ASWTOA" "Accum RSWTOA" "W m-2" +state real sfcshx ij dyn_nmm 1 - rh023 "SFCSHX" "Accum sfc sensible heat flux" "W m-2" +state real sfclhx ij dyn_nmm 1 - rh023 "SFCLHX" "Accum sfc latent heat flux" "W m-2" +state real subshx ij dyn_nmm 1 - rh023 "SUBSHX" "Accum deep soil heat flux" "W m-2" state real snopcx ij dyn_nmm 1 - rh "SNOPCX" "Snow phase change heat flux" "W m-2" state real sfcuvx ij dyn_nmm 1 - rh -state real potevp ij dyn_nmm 1 - rh "POTEVP" "Accum potential evaporation" "m" +state real potevp ij dyn_nmm 1 - rh023 "POTEVP" "Accum potential evaporation" "m" state real potflx ij dyn_nmm 1 - rh "POTFLX" "Energy equivalent of POTEVP" "W m-2" state real tlmin ij dyn_nmm 1 - rh state real tlmax ij dyn_nmm 1 - rh @@ -519,26 +641,29 @@ state real t02_min ij dyn_nmm 1 - rh "T02_MIN" "Hourly Min state real t02_max ij dyn_nmm 1 - rh "T02_MAX" "Hourly Max Shelter Temperature" "K" state real rh02_min ij dyn_nmm 1 - rh "RH02_MIN" "Hourly Min Relative Humidity" "" state real rh02_max ij dyn_nmm 1 - rh "RH02_MAX" "Hourly Max Relative Humidity" "" -state real rlwtt ijk dyn_nmm 1 - r "RLWTT" "Longwave temperature tendency" "K s-1" -state real rswtt ijk dyn_nmm 1 - r "RSWTT" "Shortwave temperature tendency" "K s-1" -state real tcucn ijk dyn_nmm 1 - r "TCUCN" "Accum convec temperature tendency" "K s-1" -state real train ijk dyn_nmm 1 - r "TRAIN" "Accum stratiform temp tendency" "K s-1" -state integer ncfrcv ij dyn_nmm 1 - irh "NCFRCV" "# times convec cloud >0 between rad calls" "" -state integer ncfrst ij dyn_nmm 1 - irh "NCFRST" "# times stratiform cloud >0 between rad calls" "" -state integer nphs0 - dyn_nmm - - rh -state integer nprec - dyn_nmm - - irh "NPREC" "# timesteps between resetting precip bucket" "" -state integer nclod - dyn_nmm - - irh "NCLOD" "# timesteps between resetting cloud frac accum" "" -state integer nheat - dyn_nmm - - irh "NHEAT" "# timesteps between resetting latent heat accum" "" -state integer nrdlw - dyn_nmm - - irh "NRDLW" "# timesteps between resetting longwave accums" "" -state integer nrdsw - dyn_nmm - - irh "NRDSW" "# timesteps between resetting shortwave accums" "" -state integer nsrfc - dyn_nmm - - irh "NSRFC" "# timesteps between resetting sfcflux accums" "" -state real avrain - dyn_nmm - - irh "AVRAIN" "# of times gridscale precip called in NHEAT steps" "" -state real avcnvc - dyn_nmm - - irh "AVCNVC" "# of times convective precip called in NHEAT steps" "" +state real rlwtt ijk dyn_nmm 1 - rh023d=(DownNear) "RLWTT" "Longwave temperature tendency" "K s-1" +state real rswtt ijk dyn_nmm 1 - rh023d=(DownNear) "RSWTT" "Shortwave temperature tendency" "K s-1" +#for HWRF: add to restart +state real tcucn ijk dyn_nmm 1 - rh023 "TCUCN" "Accum convec temperature tendency" "K s-1" +state real train ijk dyn_nmm 1 - rh023 "TRAIN" "Accum stratiform temp tendency" "K s-1" +#end HWRF +state integer ncfrcv ij dyn_nmm 1 - irh023 "NCFRCV" "# times convec cloud >0 between rad calls" "" +state integer ncfrst ij dyn_nmm 1 - irh023 "NCFRST" "# times stratiform cloud >0 between rad calls" "" +state integer nphs0 - dyn_nmm - - rh023 +state integer ncnvc0 - dyn_nmm - - rh +state integer nprec - dyn_nmm - - irh023 "NPREC" "# timesteps between resetting precip bucket" "" +state integer nclod - dyn_nmm - - irh023 "NCLOD" "# timesteps between resetting cloud frac accum" "" +state integer nheat - dyn_nmm - - irh023 "NHEAT" "# timesteps between resetting latent heat accum" "" +state integer nrdlw - dyn_nmm - - irh023 "NRDLW" "# timesteps between resetting longwave accums" "" +state integer nrdsw - dyn_nmm - - irh023 "NRDSW" "# timesteps between resetting shortwave accums" "" +state integer nsrfc - dyn_nmm - - irh023 "NSRFC" "# timesteps between resetting sfcflux accums" "" +state real avrain - dyn_nmm - - irh023 "AVRAIN" "# of times gridscale precip called in NHEAT steps" "" +state real avcnvc - dyn_nmm - - irh023 "AVCNVC" "# of times convective precip called in NHEAT steps" "" state real aratim - dyn_nmm - - ir state real acutim - dyn_nmm - - irh -state real ardlw - dyn_nmm - - irh "ARDLW" "# of times LW fluxes summed before resetting" "" -state real ardsw - dyn_nmm - - irh "ARDSW" "# of times SW fluxes summed before resetting" "" -state real asrfc - dyn_nmm - - irh "ASRFC" "# of times sfc fluxes summed before resetting" "" +state real ardlw - dyn_nmm - - irh023 "ARDLW" "# of times LW fluxes summed before resetting" "" +state real ardsw - dyn_nmm - - irh023 "ARDSW" "# of times SW fluxes summed before resetting" "" +state real asrfc - dyn_nmm - - irh023 "ASRFC" "# of times sfc fluxes summed before resetting" "" state real aphtim - dyn_nmm - - irh # # module_INDX.F @@ -564,12 +689,16 @@ state integer iup_adh ij dyn_nmm 1 - - state integer iup_adv ij dyn_nmm 1 - - state integer imicrogram - misc - - r "imicrogram" "flag 0/1 0=mixratio, 1=mcrograms/m3" "" +# Interpolation information +state real winfo ijkb dyn_nmm 1 Z u=(NoInterp)d=(NoInterp) "winfo" "Nest-parent interpolation/extrapolation weight" "" +state integer iinfo ijkb dyn_nmm 1 Z u=(NoInterp)d=(NoInterp) "iinfo" "Nest-parent interpolation index" "" + # # table entries are of the form #
# # Mask for moving nest interpolations -state integer imask_nostag ij misc - +state integer imask_nostag ij misc - - rh "IMASK_NOSTAG" "INTERPOLATION MASK" state integer imask_xstag ij misc X state integer imask_ystag ij misc Y state integer imask_xystag ij misc XY @@ -619,7 +748,7 @@ state real soilt020 ij misc 1 - i1 "SOIL state real soilt040 ij misc 1 - i1 "SOILT040" "description" "units" state real soilt160 ij misc 1 - i1 "SOILT160" "description" "units" state real soilt300 ij misc 1 - i1 "SOILT300" "description" "units" -state real landmask ij misc 1 - i01rh "LANDMASK" "description" "units" +state real landmask ij misc 1 f i01rhd=(DownNear) "LANDMASK" "description" "units" state real topostdv ij misc 1 - i1 "TOPOSTDV" "description" "units" state real toposlpx ij misc 1 - i1 "TOPOSLPX" "description" "units" state real toposlpy ij misc 1 - i1 "TOPOSLPY" "description" "units" @@ -627,8 +756,8 @@ state real greenmax ij misc 1 - i1 "GREE state real greenmin ij misc 1 - i1 "GREENMIN" "description" "units" state real albedomx ij misc 1 - i1 "ALBEDOMX" "description" "units" state real slopecat ij misc 1 - i1 "SLOPECAT" "description" "units" -state real toposoil ij misc 1 - i1 "SOILHGT" "description" "units" -state real landusef iuj misc 1 Z - "" "description" "units" +state real toposoil ij misc 1 - i1d=(DownNear) "TOPOSOIL" "description" "units" +state real landusef iuj misc 1 Z - "" "description" "units" state real soilctop isj misc 1 Z - "" "description" "units" state real soilcbot isj misc 1 Z - "" "description" "units" @@ -656,64 +785,67 @@ state real ts_clw ?! misc - - - "TS # moist_tend even if there are not any moist scalars (so the essentially # dry code will will still link properly) # -state real - ijkft moist 1 - - - -state real qv ijkft moist 1 - rh "QVAPOR" "Water vapor mixing ratio" "kg kg-1" -state real qc ijkft moist 1 - rh "QCLOUD" "Cloud water mixing ratio" "kg kg-1" -state real qr ijkft moist 1 - rh "QRAIN" "Rain water mixing ratio" "kg kg-1" -state real qi ijkft moist 1 - rh "QICE" "Ice mixing ratio" "kg kg-1" -state real qs ijkft moist 1 - rh "QSNOW" "Snow mixing ratio" "kg kg-1" -state real qg ijkft moist 1 - rh "QGRAUP" "Graupel mixing ratio" "kg kg-1" -state real qh ijkft moist 1 - rh "QHAIL" "Hail mixing ratio" "kg kg-1" - -state real - ijkft dfi_moist 1 - - - -state real dfi_qv ijkft dfi_moist 1 - r "QVAPOR" "Water vapor mixing ratio" "kg kg-1" -state real dfi_qc ijkft dfi_moist 1 - r "QCLOUD" "Cloud water mixing ratio" "kg kg-1" -state real dfi_qr ijkft dfi_moist 1 - r "QRAIN" "Rain water mixing ratio" "kg kg-1" -state real dfi_qi ijkft dfi_moist 1 - r "QICE" "Ice mixing ratio" "kg kg-1" -state real dfi_qs ijkft dfi_moist 1 - r "QSNOW" "Snow mixing ratio" "kg kg-1" -state real dfi_qg ijkft dfi_moist 1 - r "QGRAUP" "Graupel mixing ratio" "kg kg-1" -state real dfi_qh ijkft dfi_moist 1 - r "QHAIL" "Hail mixing ratio" "kg kg-1" -state real dfi_qnh ijkft dfi_moist 1 - r "QNHAIL" "Hail Number concentration" "# kg(-1)" +state real - ijkfbt moist 1 m - - +state real qv ijkfbt moist 1 m rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QVAPOR" "Water vapor mixing ratio" "kg kg-1" +state real qc ijkfbt moist 1 m rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QCLOUD" "Cloud water mixing ratio" "kg kg-1" +state real qr ijkfbt moist 1 m rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QRAIN" "Rain water mixing ratio" "kg kg-1" +state real qi ijkfbt moist 1 m rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QICE" "Ice mixing ratio" "kg kg-1" +state real qs ijkfbt moist 1 m rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QSNOW" "Snow mixing ratio" "kg kg-1" +state real qg ijkfbt moist 1 m rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QGRAUP" "Graupel mixing ratio" "kg kg-1" +state real qh ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QHAIL" "Hail mixing ratio" "kg kg-1" + + +state real - ijkfbt dfi_moist 1 m - - +state real dfi_qv ijkfbt dfi_moist 1 m r "QVAPOR" "Water vapor mixing ratio" "kg kg-1" +state real dfi_qc ijkfbt dfi_moist 1 m r "QCLOUD" "Cloud water mixing ratio" "kg kg-1" +state real dfi_qr ijkfbt dfi_moist 1 m r "QRAIN" "Rain water mixing ratio" "kg kg-1" +state real dfi_qi ijkfbt dfi_moist 1 m r "QICE" "Ice mixing ratio" "kg kg-1" +state real dfi_qs ijkfbt dfi_moist 1 m r "QSNOW" "Snow mixing ratio" "kg kg-1" +state real dfi_qg ijkfbt dfi_moist 1 m r "QGRAUP" "Graupel mixing ratio" "kg kg-1" +state real dfi_qh ijkfbt dfi_moist 1 m r "QHAIL" "Hail mixing ratio" "kg kg-1" + # # Other Scalars -state real - ijkftb scalar 1 - - - -state real qni ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNI" "Ice Number concentration" "# kg(-1)" -state real qt ikjftb scalar 1 - i0rhusdf=(bdy_interp:dt) "QT" "Total condensate mixing ratio" "kg kg-1" -state real qns ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNS" "Snow Number concentration" "# kg(-1)" -state real qnr ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNR" "Rain Number concentration" "# kg(-1)" -state real qng ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNG" "Graupel Number concentration" "# kg(-1)" -state real qnh ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNHAIL" "Hail Number concentration" "# kg(-1)" - -state real qnn ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNCCN" "CCN Number concentration" "# kg(-1)" -state real qnc ijkftb scalar 1 - i01rusdf=(bdy_interp:dt) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" -state real qnwfa ikjftb scalar 1 - i0rhusdf=(bdy_interp:dt) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" -state real qnifa ikjftb scalar 1 - i0rhusdf=(bdy_interp:dt) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" - -state real qvolg ikjftb scalar 1 - i0rhusdf=(bdy_interp:dt) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" - -state real - ijkftb dfi_scalar 1 - - - -state real dfi_qndrop ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNDROP" "DFI Droplet number mixing ratio" "# kg-1" -state real dfi_qni ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNICE" "DFI Ice Number concentration" "# kg-1" -state real dfi_qt ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_CWM" "DFI Total condensate mixing ratio" "kg kg-1" -state real dfi_qns ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNSNOW" "DFI Snow Number concentration" "# kg(-1)" -state real dfi_qnr ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNRAIN" "DFI Rain Number concentration" "# kg(-1)" -state real dfi_qng ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "DFI Graupel Number concentration" "# kg(-1)" -state real dfi_qnn ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNCC" "DFI CNN Number concentration" "# kg(-1)" -state real dfi_qnc ijkftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "DFI Cloud Number concentration" "# kg(-1)" -state real dfi_qnwfa ikjftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNWFA" "DFI water-friendly aerosol number con" "# kg(-1)" -state real dfi_qnifa ikjftb dfi_scalar 1 - \ - rusdf=(bdy_interp:dt) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" - +state real - ijkftb scalar 1 m - - +state real qni ijkftb scalar 1 m i01h023ru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNICE" "Ice Number concentration" "# kg(-1)" +state real qt ikjftb scalar 1 m i01h023ru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QT" "Total condensate mixing ratio" "kg kg-1" +state real qns ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNSNOW" "Snow Number concentration" "# kg(-1)" +state real qnr ijkftb scalar 1 m i01h023ru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNRAIN" "Rain Number concentration" "# kg(-1)" +state real qng ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNGRAUP" "Graupel Number concentration" "# kg(-1)" +state real qnh ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNHAIL" "Hail Number concentration" "# kg(-1)" +state real qnn ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCCN" "CCN Number concentration" "# kg(-1)" +state real qnc ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" +state real qvolg ikjftb scalar 1 m i01hru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" +state real qnwfa ikjftb scalar 1 m i01hru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" +state real qnifa ikjftb scalar 1 m i01hru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" +state real qndrop ikjftb scalar 1 m i01h023ru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QNDROP" "Droplet number mixing ratio" "# kg-1" + + +state real - ijkftb dfi_scalar 1 m - - +state real dfi_qndrop ijkftb dfi_scalar 1 m \ + rsu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "DFI_QNDROP" "DFI Droplet number mixing ratio" "# kg-1" +state real dfi_qni ijkftb dfi_scalar 1 m \ + rsu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "DFI_QNICE" "DFI Ice Number concentration" "# kg-1" +state real dfi_qt ijkftb dfi_scalar 1 m \ + rsu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "DFI_CWM" "DFI Total condensate mixing ratio" "kg kg-1" +state real dfi_qns ijkftb dfi_scalar 1 m \ + rsu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "DFI_QNSNOW" "DFI Snow Number concentration" "# kg(-1)" +state real dfi_qnr ijkftb dfi_scalar 1 m \ + rsu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "DFI_QNRAIN" "DFI Rain Number concentration" "# kg(-1)" +state real dfi_qng ijkftb dfi_scalar 1 m \ + rsu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "DFI_QNGRAUPEL" "DFI Graupel Number concentration" "# kg(-1)" +state real dfi_qnh ijkfbt dfi_scalar 1 m \ + rsu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNHAIL" "Hail Number concentration" "# kg(-1)" +state real dfi_qnn ijkftb dfi_scalar 1 m \ + rsu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "DFI_QNCC" "DFI CNN Number concentration" "# kg(-1)" +state real dfi_qnc ijkftb dfi_scalar 1 m \ + rsu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "DFI_QNCLOUD" "DFI Cloud Number concentration" "# kg(-1)" +state real dfi_qnwfa ikjftb dfi_scalar 1 m \ + rsu=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "DFI_QNWFA" "DFI water-friendly aerosol number con" "# kg(-1)" +state real dfi_qnifa ikjftb dfi_scalar 1 m \ + rsu=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" +state real qvolh ikjftb scalar 1 m i01hru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0. 0) "QVHAIL" "Hail Particle Volume" "m(3) kg(-1)" #----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -742,7 +874,6 @@ state real - ikjft chem 1 - - - # lsm State Variables state real SMOIS ilj - 1 Z rh "SMOIS" "SOIL MOISTURE" "" -state real SMCREL ilj - 1 Z r "SMCREL" "RELATIVE SOIL MOISTURE" "" state real TSLB ilj - 1 Z r "TSLB" "SOIL TEMPERATURE" "" state real lake_depth ij misc 1 - rd=(interp_mask_water_field:lu_index,iswater) "lake_depth" "lake depth" "m" @@ -786,83 +917,61 @@ state real XLONG ij misc 1 - - "" state real XLAND ij misc 1 - - "" "" state real RAINCV ij misc 1 - - "" "" + + ################################################################# # other misc variables (all cores) ################################################################# -# added WRF-Solar -state real swddir ij misc 1 - rhd "SWDDIR" "Shortwave surface downward direct irradiance" "W/m^2" "" -state real swddni ij misc 1 - rhd "SWDDNI" "Shortwave surface downward direct normal irradiance" "W/m^2" "" -state real swddif ij misc 1 - rhd "SWDDIF" "Shortwave surface downward diffuse irradiance" "W/m^2" "" -state real Gx ij misc 1 - rd "Gx" "" "" -state real Bx ij misc 1 - rd "Bx" "" "" -state real gg ij misc 1 - rd "gg" "" "" -state real bb ij misc 1 - rd "bb" "" "" -state real coszen_ref ij misc 1 - - "coszen_ref" "" "" -state real coszen ij misc 1 - - "coszen " "" "" -state real hrang ij misc 1 - - "hrang" "" "" -state real swdown_ref ij misc 1 - - "swdown_ref" "" "" -state real swddir_ref ij misc 1 - - "swddir_ref" "" "" -rconfig integer swint_opt namelist,physics 1 0 - "swint_opt" "interpolation option for sw radiation" "" -# add aerosol namelist -rconfig integer aer_type namelist,physics max_domains 1 irh "aer_type" "aerosol type: 1 is SF79 rural, 2 is SF79 urban" "" -rconfig integer aer_aod550_opt namelist,physics max_domains 1 irh "aer_aod550_opt" "input option for aerosol optical depth at 550 nm" "" -rconfig integer aer_angexp_opt namelist,physics max_domains 1 irh "aer_angexp_opt" "input option for aerosol Angstrom exponent" "" -rconfig integer aer_ssa_opt namelist,physics max_domains 1 irh "aer_ssa_opt" "input option for aerosol single-scattering albedo" "" -rconfig integer aer_asy_opt namelist,physics max_domains 1 irh "aer_asy_opt" "input option for aerosol asymmetry parameter" "" -rconfig real aer_aod550_val namelist,physics max_domains 0.12 irh "aer_aod550_val" "fixed value for aerosol optical depth at 550 nm. Valid when aer_aod550_opt=1" "" -rconfig real aer_angexp_val namelist,physics max_domains 1.3 irh "aer_angexp_val" "fixed value for aerosol Angstrom exponent. Valid when aer_angexp_opt=1" "" -rconfig real aer_ssa_val namelist,physics max_domains 0.85 irh "aer_ssa_val" "fixed value for aerosol single-scattering albedo. Valid when aer_ssa_opt=1" "" -rconfig real aer_asy_val namelist,physics max_domains 0.90 irh "aer_asy_val" "fixed value for aerosol asymmetry parameter. Valid when aer_asy_opt=1" "" - # added for surface_driver -state real PSFC ij misc 1 - i1rh "PSFC" "SFC PRESSURE" +state real PSFC ij misc 1 - i1rh "PSFC" "SFC PRESSURE" state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" state real TH2 ij misc 1 - irh "TH2" "POT TEMP at 2 M" "" state real T2 ij misc 1 - ir "T2" "TEMP at 2 M" "" -state real U10 ij misc 1 - irh "U10" "U at 10 M" " " -state real V10 ij misc 1 - irh "V10" "V at 10 M" " " -state real XICE ij misc 1 - i01r "XICE" "SEA ICE" "" -state real ICEDEPTH ij misc 1 - irh "ICEDEPTH" "SEA ICE THICKNESS" "m" -state real ALBSI ij misc 1 - irh "ALBSI" "SEA ICE ALBEDO" " " -state real SNOWSI ij misc 1 - irh "SNOWSI" "SNOW DEPTH ON SEA ICE" "m" +state real U10 ij misc 1 - irh0123d=(DownCopy) "U10" "U at 10 M" " " +state real V10 ij misc 1 - irh0123d=(DownCopy) "V10" "V at 10 M" " " +state real XICE ij misc 1 - i01rd=(DownNear) "XICE" "SEA ICE" "" +state real ICEDEPTH ij misc 1 - i0124rhd=(DownNear) "ICEDEPTH" "SEA ICE THICKNESS" "m" +state real ALBSI ij misc 1 - i0124rhd=(DownNear) "ALBSI" "SEA ICE ALBEDO" " " +state real SNOWSI ij misc 1 - i0124rhd=(DownNear) "SNOWSI" "SNOW DEPTH ON SEA ICE" "m" state real LAI ij misc 1 - i0124rh "LAI" "Leaf area index" "area/area" -state real SMSTAV ij misc 1 - irh "SMSTAV" "MOISTURE VARIBILITY" "" -state real SMSTOT ij misc 1 - irh "SMSTOT" "TOTAL SOIL MOISTURE" "" +state real SMSTAV ij misc 1 - irh023 "SMSTAV" "MOISTURE VARIBILITY" "" +state real SMSTOT ij misc 1 - irh023 "SMSTOT" "TOTAL SOIL MOISTURE" "" state real SOLDRAIN ij misc 1 - r "SOLDRAIN" "soil column drainage" "mm" state real SFCHEADRT ij misc 1 - r "SFCHEADRT" "surface water depth" "mm" state real INFXSRT ij misc 1 - r "INFXSRT" "time step infiltration excess" "mm" state real SFCRUNOFF ij misc 1 - rh "SFROFF" "SURFACE RUNOFF" "" -state real UDRUNOFF ij misc 1 - rh "UDROFF" "UNDERGROUND RUNOFF" "" -state integer IVGTYP ij misc 1 - irh "IVGTYP" "VEGETATION TYPE" "" -state integer ISLTYP ij misc 1 - irh "ISLTYP" "SOIL TYPE" " " -state real VEGFRA ij misc 1 - i014rh "VEGFRA" "VEGETATION FRACTION" "" -state real SFCEVP ij misc 1 - irh "SFCEVP" "SURFACE EVAPORATION" "" +state real UDRUNOFF ij misc 1 - rh023 "UDROFF" "UNDERGROUND RUNOFF" "" +state integer IVGTYP ij misc 1 f irh023d=(DownINear) "IVGTYP" "VEGETATION TYPE" "" +state integer ISLTYP ij misc 1 f irh023d=(DownINear) "ISLTYP" "SOIL TYPE" " " +state real VEGFRA ij misc 1 - i014rh023d=(DownNear) "VEGFRA" "VEGETATION FRACTION" "" +state real SFCEVP ij misc 1 - irh023 "SFCEVP" "SURFACE EVAPORATION" "" state real GRDFLX ij misc 1 - irh "GRDFLX" "GROUND HEAT FLUX" "" state real ALBBCK ij misc 1 - i0124r "ALBBCK" "BACKGROUND ALBEDO" "NA" -state real SFCEXC ij misc 1 - irh "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" +state real SFCEXC ij misc 1 - irh023 "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" state real SNOTIME ij misc 1 - r "SNOTIME" "SNOTIME" "" -state real ACSNOW ij misc 1 - irh "ACSNOW" "ACCUMULATED SNOW" "kg m-2" -state real ACSNOM ij misc 1 - irh "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" +state real ACSNOW ij misc 1 - irh023 "ACSNOW" "ACCUMULATED SNOW" "kg m-2" +state real ACSNOM ij misc 1 - irh023 "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" state real RMOL ij misc 1 - ir "RMOL" "" "" state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" -state real SST ij misc 1 - i014rh "SST" "SEA SURFACE TEMPERATURE" "K" -state real UOCE ij misc 1 - i014rh "UOCE" "SEA SURFACE ZONAL CURRENTS" "m s-1" -state real VOCE ij misc 1 - i014rh "VOCE" "SEA SURFACE MERIDIONAL CURRENTS" "m s-1" -state real WEASD ij misc 1 - i01rh "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "kg m-2" -state real ZNT ij misc 1 - ir "ZNT" "TIME-VARYING ROUGHNESS LENGTH" +state integer FORCE_SST k misc 1 - - "FORCE_SST" "IF FORCE_SST(1) IS 1, FEED SST FROM PARENT EVERY DT" "" +state real SST ij misc 1 - i014rh0123d=(DownNear)f=(force_sst_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,FORCE_SST) "SST" "SEA SURFACE TEMPERATURE" "K" +state real UOCE ij misc 1 - i014rh023 "UOCE" "SEA SURFACE ZONAL CURRENTS" "m s-1" +state real VOCE ij misc 1 - i014rh023 "VOCE" "SEA SURFACE MERIDIONAL CURRENTS" "m s-1" +state real WEASD ij misc 1 - i01rh023d=(DownNear) "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "kg m-2" +state real ZNT ij misc 1 - irh023 "ZNT" "TIME-VARYING ROUGHNESS LENGTH" state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" state real NOAHRES ij misc 1 - rh "NOAHRES" "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}" state real tke_pbl ijk misc 1 Z r "TKE_PBL" "TKE FROM PBL SCHEME" "m2 s-2" state real el_pbl ikj misc 1 Z - "EL_PBL" "MIXING LENGTH FROM PBL SCHEME" "m" -state real EXCH_H ikj misc 1 Z r "EXCH_H" "EXCHANGE COEFFICIENTS FOR HEAT" "m2 s-1" -state real EXCH_M ikj misc 1 Z r "EXCH_M" "EXCHANGE COEFFICIENTS FOR MOMENTUM" "m2 s-1" -state real THZ0 ij misc 1 - irh "THZ0" "POT. TEMPERATURE AT TOP OF VISC. SUBLYR" "K" -state real QZ0 ij misc 1 - irh "QZ0" "SPECIFIC HUMIDITY AT TOP OF VISC. SUBLYR" "kg kg-1" -state real UZ0 ij misc 1 - irh "UZ0" "U WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" -state real VZ0 ij misc 1 - irh "VZ0" "V WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" +state real EXCH_H ikj misc 1 Z r "EXCH_H" "EXCHANGE COEFFICIENTS FOR HEAT" "m2 s-1" +state real EXCH_M ikj misc 1 Z r "EXCH_M" "EXCHANGE COEFFICIENTS FOR MOMENTUM" "m2 s-1" +state real THZ0 ij misc 1 - irh023d=(DownCopy) "THZ0" "POT. TEMPERATURE AT TOP OF VISC. SUBLYR" "K" +state real QZ0 ij misc 1 - irh023d=(DownCopy) "QZ0" "SPECIFIC HUMIDITY AT TOP OF VISC. SUBLYR" "kg kg-1" +state real UZ0 ij misc 1 - irh023d=(DownVel) "UZ0" "U WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" +state real VZ0 ij misc 1 - irh023d=(DownVel) "VZ0" "V WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" @@ -881,18 +990,18 @@ state real dvdt ijk misc 1 - - state real QSFC ij misc 1 - irh "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" state real AKHS ij misc 1 - ir "AKHS" "SFC EXCH COEFF FOR HEAT /DELTA Z" "m s-1" -state real AKMS ij misc 1 - ir "AKMS" "SFC EXCH COEFF FOR MOMENTUM /DELTA Z" "m s-1" +state real AKMS ij misc 1 - ir "AKMS" "SFC EXCH COEFF FOR MOMENTUM /DELTA Z" "m s-1" i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" -state real HTOP ij misc 1 - irh "HTOP" "TOP OF CONVECTION LEVEL" "" -state real HBOT ij misc 1 - irh "HBOT" "BOT OF CONVECTION LEVEL" "" -state real HTOPR ij misc 1 - ir "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" -state real HBOTR ij misc 1 - ir "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" -state real HTOPD ij misc 1 - rh "HTOPD" "TOP DEEP CONVECTION LEVEL" "" -state real HBOTD ij misc 1 - rh "HBOTD" "BOT DEEP CONVECTION LEVEL" "" -state real HTOPS ij misc 1 - rh "HTOPS" "TOP SHALLOW CONVECTION LEVEL" "" -state real HBOTS ij misc 1 - rh "HBOTS" "BOT SHALLOW CONVECTION LEVEL" "" -state REAL CUPPT ij misc 1 - rh "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINCE LAST CALL TO THE RADIATION" "" -state REAL CPRATE ij misc 1 - rh "CPRATE" "INSTANTANEOUS CONVECTIVE PRECIPITATION RATE" "" # 1-17-06a +state real HTOP ij misc 1 - irhd=(DownNear) "HTOP" "TOP OF CONVECTION LEVEL" "" +state real HBOT ij misc 1 - irhd=(DownNear) "HBOT" "BOT OF CONVECTION LEVEL" "" +state real HTOPR ij misc 1 - ird=(DownNear) "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" +state real HBOTR ij misc 1 - ird=(DownNear) "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" +state real HTOPD ij misc 1 - rh023 "HTOPD" "TOP DEEP CONVECTION LEVEL" "" +state real HBOTD ij misc 1 - rh023 "HBOTD" "BOT DEEP CONVECTION LEVEL" "" +state real HTOPS ij misc 1 - rh023 "HTOPS" "TOP SHALLOW CONVECTION LEVEL" "" +state real HBOTS ij misc 1 - rh023 "HBOTS" "BOT SHALLOW CONVECTION LEVEL" "" +state REAL CUPPT ij misc 1 - rh023d=(DownNear) "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINCE LAST CALL TO THE RADIATION" "" +state REAL CPRATE ij misc 1 - rh023 "CPRATE" "INSTANTANEOUS CONVECTIVE PRECIPITATION RATE" "" # 1-17-06a state real F_ICE_PHY ikj misc 1 - - "F_ICE_PHY" "FRACTION OF ICE" "" state real F_RAIN_PHY ikj misc 1 - - "F_RAIN_PHY" "FRACTION OF RAIN " "" state real F_RIMEF_PHY ikj misc 1 - - "F_RIMEF_PHY" "MASS RATIO OF RIMED ICE " "" @@ -910,12 +1019,17 @@ state real pr_ens ije misc 1 Z r "P state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TOTAL ADVECTIVE POTENTIAL TEMPERATURE TENDENCY" "K s-1" state real RQVFTEN ikj misc 1 - r "RQVFTEN" "TOTAL ADVECTIVE MOISTURE TENDENCY" "kg kg-1 s-1" -state real SNOWH ij misc 1 - i01rhd=(interp_mask_land_field:lu_index) "SNOWH" "PHYSICAL SNOW DEPTH" "m" -state real RHOSN ij misc 1 - i01rd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "RHOSN" " SNOW DENSITY" "kg m-3" +state real SNOWH ij misc 1 - i01rhd=(DownCopy) "SNOWH" "PHYSICAL SNOW DEPTH" "m" +state real RHOSN ij misc 1 - i01rd=(DownCopy) "RHOSN" " SNOW DENSITY" "kg m-3" state real SMFR3D ilj misc 1 Z rh "SMFR3D" "SOIL ICE" "" state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" +state real RHOSNF ij misc 1 - irh "RHOSNF" "DENSITY OF FROZEN PRECIP" "kg/m^3" +state real SNOWFALLAC ij misc 1 - irh "SNOWFALLAC" "RUN-TOTAL ACCUMULATED SNOWFALL [mm]" "" +state real PRECIPFR ij misc 1 - - "PRECIPFR" "TIME-STEP FROZEN PRECIP [mm]" "" + state real rc_mf ikj misc 1 - r "RC_MF" "RC IN THE GRID COMPUTED BY EDKF" "kg/kg" +# For Noah-MP rconfig integer dveg namelist,noah_mp 1 4 h "dveg" "dynamic vegetation (1 -> off ; 2 -> on)" "" rconfig integer opt_crs namelist,noah_mp 1 1 h "opt_crs" "canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis)" "" rconfig integer opt_btr namelist,noah_mp 1 1 h "opt_btr" "soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB)" "" @@ -939,81 +1053,81 @@ state real fbur ij - 1 - h "F state real fgsn ij - 1 - h "FGSN" "fraction of ground covered by snow" "" # For Noah-MP -state integer isnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "isnow" "no. of snow layer" "m3 m-3" -state real tvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tv" "vegetation leaf temperature" "K" -state real tgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tg" "bulk ground temperature" "K" -state real canicexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "canice" "intercepted ice mass" "mm" -state real canliqxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "canliq" "intercepted liquid water" "mm" -state real eahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "eah" "canopy air vapor pressure" "pa" -state real tahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tah" "canopy air temperature" "K" -state real cmxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "cm" "surf. exchange coeff. for momentum" "m/s" -state real chxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ch" "surf. exchange coeff. for heat" "m/s" -state real fwetxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fwet" "wetted or snowed canopy fraction" "-" -state real sneqvoxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sneqvo" "snow mass at last time step" "mm" -state real alboldxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "albold" "snow albedo at last timestep" "-" -state real qsnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "qsnowxy" "snowfall on the ground" "mm/s" -state real wslakexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wslake" "lake water storage" "mm" -state real zwtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "zwt" "water table depth" "m" -state real waxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wa" "water in the acquifer" "mm" -state real wtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wt" "groundwater storage" "mm" -state real tsnoxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tsno" "snow temperature" "K" -state real zsnsoxy i{snsl}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "zsnso" "layer-bottom depth from snow surf" "m" -state real snicexy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "snice" "snow layer ice" "mm" -state real snliqxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "snliq" "snow layer liquid" "mm" -state real lfmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "lfmass" "leaf mass" "g/m2" -state real rtmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rtmass" "mass of fine roots" "g/m2" -state real stmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "stmass" "stem mass" "g/m2" -state real woodxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wood" "mass of wood" "g/m2" -state real stblcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "stblcp" "stable carbon pool" "g/m2" -state real fastcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fastcp" "short-lived carbon" "g/m2" -state real xsaixy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "xsai" "stem area index" "-" +state integer isnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "isnow" "no. of snow layer" "m3 m-3" +state real tvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "tv" "vegetation leaf temperature" "K" +state real tgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "tg" "bulk ground temperature" "K" +state real canicexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "canice" "intercepted ice mass" "mm" +state real canliqxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "canliq" "intercepted liquid water" "mm" +state real eahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "eah" "canopy air vapor pressure" "pa" +state real tahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "tah" "canopy air temperature" "K" +state real cmxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "cm" "surf. exchange coeff. for momentum" "m/s" +state real chxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "ch" "surf. exchange coeff. for heat" "m/s" +state real fwetxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "fwet" "wetted or snowed canopy fraction" "-" +state real sneqvoxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "sneqvo" "snow mass at last time step" "mm" +state real alboldxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "albold" "snow albedo at last timestep" "-" +state real qsnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "qsnowxy" "snowfall on the ground" "mm/s" +state real wslakexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "wslake" "lake water storage" "mm" +state real zwtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "zwt" "water table depth" "m" +state real waxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "wa" "water in the acquifer" "mm" +state real wtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "wt" "groundwater storage" "mm" +state real tsnoxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "tsno" "snow temperature" "K" +state real zsnsoxy i{snsl}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "zsnso" "layer-bottom depth from snow surf" "m" +state real snicexy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "snice" "snow layer ice" "mm" +state real snliqxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "snliq" "snow layer liquid" "mm" +state real lfmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "lfmass" "leaf mass" "g/m2" +state real rtmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "rtmass" "mass of fine roots" "g/m2" +state real stmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "stmass" "stem mass" "g/m2" +state real woodxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "wood" "mass of wood" "g/m2" +state real stblcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "stblcp" "stable carbon pool" "g/m2" +state real fastcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "fastcp" "short-lived carbon" "g/m2" +state real xsaixy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "xsai" "stem area index" "-" state real taussxy ij - 1 - rh "tauss" "non-dimensional snow age" "" -state real t2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "t2v" "2 meter temperature over canopy" "K" -state real t2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "t2b" "2 meter temperature over bare ground" "K" -state real q2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "q2v" "2 meter mixing ratio over canopy" "kg kg-1" -state real q2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "q2b" "2 meter mixing ratio over bare ground" "kg kg-1" -state real tradxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "trad" "surface radiative temperature" "K" -state real neexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "nee" "net ecosystem exchange" "g/m2/s CO2" -state real gppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "gpp" "gross primary productivity" "g/m2/s C" -state real nppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "npp" "net primary productivity" "g/m2/s C" -state real fvegxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fveg" "Noah-MP vegetation fraction" "" -state real qinxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "qin" "groundwater recharge" "mm/s" -state real runsfxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "runsf" "surface runoff" "mm/s" -state real runsbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "runsb" "subsurface runoff" "mm/s" -state real ecanxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ecan" "evaporation of intercepted water" "mm/s" -state real edirxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "edir" "ground surface evaporation rate" "mm/s" -state real etranxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "etran" "transpiration rate" "mm/s" -state real fsaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fsa" "total absorbed solar radiation" "W/m2" -state real firaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fira" "total net longwave rad" "W/m2" -state real aparxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "apar" "photosyn active energy by canopy" "W/m2" -state real psnxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "psn" "total photosynthesis" "umol co2/m2/s" -state real savxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sav" "solar rad absorbed by veg" "W/m2" -state real sagxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sag" "solar rad absorbed by ground" "W/m2" -state real rssunxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rssun" "sunlit stomatal resistance" "s/m" -state real rsshaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rssha" "shaded stomatal resistance" "s/m" -state real bgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "bgap" "between canopy gap" "fraction" -state real wgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wgap" "within canopy gap" "fraction" -state real tgvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tgv" "ground temp. under canopy""K" -state real tgbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tgb" "bare ground temperature" "K" -state real chvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv" "vegetated heat exchange coefficient" "m/s" -state real chbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb" "bare-ground heat exchange coefficient" "m/s" -state real shgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shg" "sensible heat flux: ground to canopy" "W/m2" -state real shcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shc" "sensible heat flux: leaf to canopy" "W/m2" -state real shbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shb" "sensible heat flux: bare grnd to atmo" "W/m2" -state real evgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evg" "latent heat flux: ground to canopy" "W/m2" -state real evbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evb" "latent heat flux: bare grnd to atmo" "W/m2" -state real ghvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ghv" "heat flux into soil: under canopy" "W/m2" -state real ghbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ghb" "heat flux into soil: bare fraction" "W/m2" -state real irgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irg" "net longwave at below canopy surface" "W/m2" -state real ircxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irc" "net longwave in canopy" "W/m2" -state real irbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irb" "net longwave at bare fraction surface" "W/m2" -state real trxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tr" "transpiration" "W/m2" -state real evcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evc" "canopy evaporation" "W/m2" -state real chleafxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chleaf" "leaf exchange coefficient" "m/s" -state real chucxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chuc" "under canopy exchange coefficient" "m/s" -state real chv2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv2" "leaf exchange coefficient" "m/s" -state real chb2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb2" "under canopy exchange coefficient" "m/s" -state real chstarxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chstar" "dummy exchange coefficient" "m/s" +state real t2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "t2v" "2 meter temperature over canopy" "K" +state real t2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "t2b" "2 meter temperature over bare ground" "K" +state real q2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "q2v" "2 meter mixing ratio over canopy" "kg kg-1" +state real q2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "q2b" "2 meter mixing ratio over bare ground" "kg kg-1" +state real tradxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "trad" "surface radiative temperature" "K" +state real neexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "nee" "net ecosystem exchange" "g/m2/s CO2" +state real gppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "gpp" "gross primary productivity" "g/m2/s C" +state real nppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "npp" "net primary productivity" "g/m2/s C" +state real fvegxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "fveg" "Noah-MP vegetation fraction" "" +state real qinxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "qin" "groundwater recharge" "mm/s" +state real runsfxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "runsf" "surface runoff" "mm/s" +state real runsbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "runsb" "subsurface runoff" "mm/s" +state real ecanxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "ecan" "evaporation of intercepted water" "mm/s" +state real edirxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "edir" "ground surface evaporation rate" "mm/s" +state real etranxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "etran" "transpiration rate" "mm/s" +state real fsaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "fsa" "total absorbed solar radiation" "W/m2" +state real firaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "fira" "total net longwave rad" "W/m2" +state real aparxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "apar" "photosyn active energy by canopy" "W/m2" +state real psnxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "psn" "total photosynthesis" "umol co2/m2/s" +state real savxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "sav" "solar rad absorbed by veg" "W/m2" +state real sagxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "sag" "solar rad absorbed by ground" "W/m2" +state real rssunxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "rssun" "sunlit stomatal resistance" "s/m" +state real rsshaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "rssha" "shaded stomatal resistance" "s/m" +state real bgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "bgap" "between canopy gap" "fraction" +state real wgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "wgap" "within canopy gap" "fraction" +state real tgvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "tgv" "ground temp. under canopy""K" +state real tgbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "tgb" "bare ground temperature" "K" +state real chvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "chv" "vegetated heat exchange coefficient" "m/s" +state real chbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "chb" "bare-ground heat exchange coefficient" "m/s" +state real shgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "shg" "sensible heat flux: ground to canopy" "W/m2" +state real shcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "shc" "sensible heat flux: leaf to canopy" "W/m2" +state real shbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "shb" "sensible heat flux: bare grnd to atmo" "W/m2" +state real evgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "evg" "latent heat flux: ground to canopy" "W/m2" +state real evbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "evb" "latent heat flux: bare grnd to atmo" "W/m2" +state real ghvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "ghv" "heat flux into soil: under canopy" "W/m2" +state real ghbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "ghb" "heat flux into soil: bare fraction" "W/m2" +state real irgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "irg" "net longwave at below canopy surface" "W/m2" +state real ircxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "irc" "net longwave in canopy" "W/m2" +state real irbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "irb" "net longwave at bare fraction surface" "W/m2" +state real trxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "tr" "transpiration" "W/m2" +state real evcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "evc" "canopy evaporation" "W/m2" +state real chleafxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "chleaf" "leaf exchange coefficient" "m/s" +state real chucxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "chuc" "under canopy exchange coefficient" "m/s" +state real chv2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "chv2" "leaf exchange coefficient" "m/s" +state real chb2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "chb2" "under canopy exchange coefficient" "m/s" +state real chstarxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "chstar" "dummy exchange coefficient" "m/s" state real SMOISEQ ilj - 1 Z r "SMOISEQ" "EQ. SOIL MOISTURE" "m3 m-3" state real smcwtdxy ij - 1 - rh "smcwtd" "deep soil moisture " "m3 m-3" state real rechxy ij - 1 - h "rech" "water table recharge" "mm" @@ -1040,10 +1154,11 @@ state integer number_at_same_level - - - - - state real power ij misc 1 - irh "Power" "Power production" "W" # State for derived time quantities. -state integer itimestep - - - - h "itimestep" "" "" +#for HWRF: add to restart +state integer itimestep - - - - rh "itimestep" "" "" state real xtime - - - - h "xtime" "minutes since simulation start" "" -state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" - +state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" + # input file descriptor for lbcs on parent domain state integer lbc_fid - - - - - "lbc_fid" "" "" @@ -1054,12 +1169,13 @@ state logical patched - - - - - "pa # indicates whether to read input from file or generate #state logical input_from_file - - - - - "input_from_file" "" "" - -state real hcoeff {ndfi} misc 1 - - "HCOEFF" "initialization weights" -state real hcoeff_tot - misc 1 - - "HCOEFF_TOT" "initialization weights" +# vortex center indices; need for restarts of moving nests +state real xi - misc - - r +state real xj - misc - - r +state real vc_i - misc - - r +state real vc_j - misc - - r ###### - # # Variables that are set at run-time to control configuration (namelist-settable) # @@ -1089,26 +1205,36 @@ rconfig integer fine_input_stream namelist,time_control max_doma include registry.io_boilerplate -rconfig integer JULYR namelist,time_control max_domains 0 h "JULYR" "" "" -rconfig integer JULDAY namelist,time_control max_domains 1 h "JULDAY" "" "" -rconfig real GMT namelist,time_control max_domains 0. h "GMT" "" "" +rconfig integer JULYR namelist,time_control max_domains 0 hr "JULYR" "" "" +rconfig integer JULDAY namelist,time_control max_domains 1 hr "JULDAY" "" "" +rconfig real GMT namelist,time_control max_domains 0. hr "GMT" "" "" + +ifdef HWRF=1 +rconfig character high_freq_outname namelist,time_control 1 "hifreq_d.htcf" - "name of hifreq output file" "" "" +rconfig character partial_atcf_outname namelist,time_control 1 "track_d.patcf" - "name of partial atcf output file" "" "" +endif + rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" +#for HWRF: +rconfig character anl_outname namelist,time_control max_domains "wrfanl_d_" - "name of analysis outfile" "" "" rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" rconfig logical write_hist_at_0h_rst namelist,time_control 1 .false. h "write_hist_at_0h_rst" "T/F write hist at 0 h of restarted forecast" rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" -rconfig real tstart namelist,time_control max_domains 0. irh "tstart" "forecast hour at the start of the NMM integration" +rconfig real tstart namelist,time_control max_domains 0. irh0123 "tstart" "forecast hour at the start of the NMM integration" rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" rconfig logical cycling namelist,time_control 1 .false. - "true for cycling (using wrfout file as input data)" +rconfig logical output_ready_flag namelist,time_control 1 .false. - "drop a flag called wrfoutReady_d_ after history write" "" "" # DFI namelist rconfig integer dfi_opt namelist,dfi_control 1 0 rh "dfi_opt" "" "" +rconfig integer dfi_savehydmeteors namelist,dfi_control 1 0 rh "dfi_radar" "DFI radar switch" "" rconfig integer dfi_nfilter namelist,dfi_control 1 7 rh "dfi_nfilter" "Digital filter type" "" rconfig logical dfi_write_filtered_input namelist,dfi_control 1 .true. rh "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?" "" rconfig logical dfi_write_dfi_history namelist,dfi_control 1 .false. rh "dfi_write_dfi_history" "Write history files during filtering?" "" @@ -1128,28 +1254,28 @@ rconfig integer dfi_bckstop_minute namelist,dfi_control 1 00 rh rconfig integer dfi_bckstop_second namelist,dfi_control 1 00 rh "dfi_bckstop_second" "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS" # Domains -rconfig integer time_step namelist,domains 1 - ih "time_step" -rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" -rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" -rconfig integer time_step_dfi namelist,domains 1 - ih "time_step_dfi" +rconfig integer time_step namelist,domains 1 - ih0123 "time_step" +rconfig integer time_step_fract_num namelist,domains 1 0 ih0123 "time_step_fract_num" +rconfig integer time_step_fract_den namelist,domains 1 1 ih0123 "time_step_fract_den" +rconfig integer time_step_dfi namelist,domains 1 - ih0123 "time_step_dfi" rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" -rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" -rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" -rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" -rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" -rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" -rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" +rconfig integer s_we namelist,domains max_domains 1 irh0123 "s_we" "" "" +rconfig integer e_we namelist,domains max_domains 32 irh0123 "e_we" "" "" +rconfig integer s_sn namelist,domains max_domains 1 irh0123 "s_sn" "" "" +rconfig integer e_sn namelist,domains max_domains 32 irh0123 "e_sn" "" "" +rconfig integer s_vert namelist,domains max_domains 1 irh0123 "s_vert" "" "" +rconfig integer e_vert namelist,domains max_domains 31 irh0123 "e_vert" "" "" rconfig integer num_metgrid_soil_levels namelist,domains 1 4 irh "num_metgrid_soil_levels" "number of input levels or layers in 3D sm, st, sw arrays" "" -rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" -rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" -rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" +rconfig real dx namelist,domains max_domains 200 h0123 "dx" "X HORIZONTAL RESOLUTION" "METERS" +rconfig real dy namelist,domains max_domains 200 h0123 "dy" "Y HORIZONTAL RESOLUTION" "METERS" +rconfig integer grid_id namelist,domains max_domains 1 irh0123 "id" "" "" rconfig logical grid_allowed namelist,domains max_domains .true. irh "allowed" "" "" rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" -rconfig integer i_parent_start namelist,domains max_domains 1 h "i_parent_start" "" "" -rconfig integer j_parent_start namelist,domains max_domains 1 h "j_parent_start" "" "" +rconfig integer i_parent_start namelist,domains max_domains 1 h0123 "i_parent_start" "" "" +rconfig integer j_parent_start namelist,domains max_domains 1 h0123 "j_parent_start" "" "" rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" -rconfig integer feedback namelist,domains 1 1 h "feedback" "" "" +rconfig integer feedback namelist,domains 1 0 h "feedback" "" "" rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" @@ -1165,10 +1291,12 @@ rconfig integer tile_strategy namelist,domains 1 0 rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" rconfig integer irand namelist,domains 1 0 - "irand" "" "" -rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" +rconfig real dt derived max_domains 2. h0123 "dt" "TEMPORAL RESOLUTION" "SECONDS" rconfig integer ts_buf_size namelist,domains 1 200 - "ts_buf_size" "Size of time series buffer" rconfig integer max_ts_locs namelist,domains 1 5 - "max_ts_locs" "Maximum number of time series locations" rconfig integer num_moves namelist,domains 1 0 +rconfig integer vortex_interval namelist,domains max_domains 15 - "" "" "minutes" +rconfig integer corral_dist namelist,domains max_domains 8 rconfig integer move_id namelist,domains max_moves 0 rconfig integer move_interval namelist,domains max_moves 999999999 rconfig integer move_cd_x namelist,domains max_moves 0 @@ -1181,43 +1309,56 @@ rconfig logical reorder_mesh namelist,domains 1 .false. r rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" # WPS related rconfig real eta_levels namelist,domains max_eta -1. -rconfig real ptsgm namelist,domains 1 42000. -rconfig integer num_metgrid_levels namelist,domains 1 43 irh "num_metgrid_levels" "" "" -rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" +rconfig real ptsgm namelist,domains 1 42000. +rconfig integer num_metgrid_levels namelist,domains 1 43 irh "num_metgrid_levels" "" "" +rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" +rconfig logical use_prep_hybrid namelist,domains 1 .false. irh "T=GFS spectral sigma files were used" "" "" # Physics -rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" +rconfig logical force_read_thompson namelist,physics 1 .false. +rconfig logical write_thompson_tables namelist,physics 1 .true. + +#for HWRF: +rconfig integer mp_physics namelist,physics max_domains 0 rh0123 "mp_physics" "" "" rconfig real mommix namelist,physics max_domains 0.7 irh "MOMENTUM MIXING FOR SAS CONVECTION SCHEME" rconfig logical disheat namelist,physics max_domains .true. irh "nmm input 7" -rconfig integer vortex_tracker namelist,physics max_domains 1 - "vortex_tracker" "Vortex Tracking Algorithm" "" +#end HWRF: rconfig integer do_radar_ref namelist,physics 1 0 rh "compute radar reflectivity for a number of schemes" -rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" -rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" +rconfig integer compute_radar_ref derived 1 0 - "compute_radar_ref" "0/1 flag: compute radar reflectivity, either do_radar_ref=1 .or. (milbrandt or NSSL schemes)" +rconfig integer ra_lw_physics namelist,physics max_domains 0 rh0123 "ra_lw_physics" "" "" +rconfig integer ra_sw_physics namelist,physics max_domains 0 rh0123 "ra_sw_physics" "" "" rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" -rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" -rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" -rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh0123 "sf_sfclay_physics" "" "" +rconfig integer sf_surface_physics namelist,physics max_domains 0 rh0123 "sf_surface_physics" "" "" +rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh0123 "bl_pbl_physics" "" "" +rconfig integer ysu_topdown_pblmix namelist,physics max_domains 0 rh "ysu_topdown_pblmix" "" "" +rconfig integer shinhong_tke_diag namelist,physics max_domains 0 rh "shinhong_tke_diag" "" "" rconfig integer windfarm_opt namelist,physics max_domains 0 rh "windfarm_opt" "" "" rconfig integer windfarm_ij namelist,physics 1 0 rh "windfarm_ij" "" "" rconfig integer mfshconv namelist,physics max_domains 1 rh "mfshconv" "To activate mass flux scheme with qnse, 1=true; 0=false" "" -rconfig integer sf_urban_physics namelist,physics max_domains 0 rh "sf_urban_physics" "" "" rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" -rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" -rconfig integer shcu_physics namelist,physics max_domains 0 rh "shcu_physics" "" "" -rconfig integer cu_diag namelist,physics max_domains 0 rh "cu_diag" " additional t-averaged stuff for cuphys" "" +rconfig integer cu_physics namelist,physics max_domains 0 rh0123 "cu_physics" "" "" +rconfig integer shcu_physics namelist,physics max_domains 0 rh0123 "shcu_physics" "" "" +rconfig integer cu_diag namelist,physics max_domains 0 rh0123 "cu_diag" " additional t-averaged stuff for cuphys" "" + +ifdef HWRF=1 +rconfig real gfs_alpha namelist,physics max_domains 1 irh0123 "boundary depth factor" "" "" +endif + rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" +rconfig integer ideal_xland namelist,physics 1 1 rh "IDEAL_XLAND" "land=1(def), water=2, for ideal cases with no land-use" "" rconfig integer IFSNOW namelist,physics 1 1 irh "IFSNOW" "" "" rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" rconfig integer num_urban_layers namelist,physics 1 400 irh "num_urban_layers" "" "" -rconfig integer num_urban_hi namelist,physics 1 15 irh "num_urban_hi" "" "" -rconfig integer sf_surface_mosaic namelist,physics 1 0 rh "sf_surface_mosaic" "1= mosaic, 0=no mosaic method, add by danli" "" +rconfig integer sf_surface_mosaic namelist,physics 1 0 rh "sf_surface_mosaic" "1= mosaic, 0=no mosaic method, add by danli" "" rconfig integer mosaic_cat namelist,physics 1 3 rh "mosaic_cat" "works when sf_surface_mosaic=1; it is the number of mosaic tiles" "" rconfig integer mosaic_cat_soil derived 1 12 rh "mosaic_cat_soil" "should be the number of soil layers times the mosaic_cat" "" +rconfig integer num_urban_hi namelist,physics 1 15 irh "num_urban_hi" "" "" rconfig integer mosaic_lu namelist,physics 1 0 irh "mosaic_lu" "" "" rconfig integer mosaic_soil namelist,physics 1 0 irh "mosaic_soil" "" "" rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" @@ -1242,18 +1383,39 @@ rconfig integer seaice_thickness_opt namelist,physics 1 0 rconfig real seaice_thickness_default namelist,physics 1 3.0 - "seaice_thickness_default" "Default value for sea-ice thickness" rconfig logical tice2tsk_if2cold namelist,physics 1 .false. - "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent" rconfig integer sst_update namelist,physics 1 0 i01rh "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" -rconfig logical usemonalb namelist,physics 1 .true. h "usemonalb" "use 2d field vs table values false=table, True=2d" "" +rconfig integer sf_urban_physics namelist,physics max_domains 0 h "sf_urban_physics" "activate urban model 0=no, 1=Noah_UCM 2=BEP_UCM" "" +rconfig logical usemonalb namelist,physics 1 .true. h "usemonalb" "use 2d field vs table values false=table, True=2d" "" rconfig logical rdmaxalb namelist,physics 1 .true. h "rdmaxalb" "false set it to table values" "" rconfig logical rdlai2d namelist,physics 1 .false. h "rdlai2d" "false set it to table values" "" rconfig logical ua_phys namelist,physics 1 .false. h "ua_phys" "activate UA Noah changes" "" + +ifdef HWRF=1 +rconfig integer gwd_opt namelist,physics max_domains 2 irh "gwd_opt" "activate gravity wave drag: 0=off, 1=ARW, 2=NMM" "" +endif rconfig integer gwd_opt namelist,physics max_domains 0 irh "gwd_opt" "activate gravity wave drag: 0=off, 1=ARW, 2=NMM" "" + rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" -rconfig real sas_pgcon namelist,physics max_domains 0.55 irh "sas_pgcon" "convectively forced pressure gradient factor (SAS scheme)" "" -rconfig real sas_shal_pgcon namelist,physics max_domains -1 irh "sas_shal_pgcon" "convectively forced pressure gradient factor, -1 means use sas_pgcon (SAS shallow conv)" "" -rconfig integer sas_shal_conv namelist,physics max_domains 0 - "sas_shal_conv" "1=enable shallow convection in SAS (must use bl_pbl_physics=83)" +rconfig real sas_pgcon namelist,physics max_domains 0.55 irh0123 "sas_pgcon" "convectively forced pressure gradient factor (SAS scheme)" "" +rconfig real sas_shal_pgcon namelist,physics max_domains -1 irh0123 "sas_shal_pgcon" "convectively forced pressure gradient factor, -1 means use sas_pgcon (SAS shallow conv)" "" +rconfig integer sas_shal_conv namelist,physics max_domains 1 - "sas_shal_conv" "1=enable shallow convection in SAS (must use bl_pbl_physics=83)" rconfig real sas_mass_flux namelist,physics max_domains 9e9 - "sas_mass_flux" "mass flux limit (SAS scheme)" "" + +ifdef HWRF=1 +rconfig real var_ric namelist,physics 1 1. - "1: use variable Ric 0: constant Ric" +rconfig real coef_ric_l namelist,physics 1 0.16 - "Regression coeff for Ric 0.16:origianl value over land" +rconfig real coef_ric_s namelist,physics 1 0.16 - "Regression coeff for Ric 0.16:origianl value OVER SEA" +endif + rconfig integer random_seed namelist,physics max_domains 0 irh "random_seed" "random number generator seed" +ifdef HWRF=1 +#added by Zhan Zhang for perturbings for SAS and PBL +rconfig integer ens_random_seed namelist,physics max_domains -1 irh "ens_random_seed" "ensemble random number generator initial seed" +rconfig logical pert_sas namelist,physics 1 .false. irh "pert_sas" "ensemble choice:F, no pert, T, pert SAS" +rconfig logical pert_pbl namelist,physics 1 .false. irh "pert_pbl" "ensemble choice:F, no pert, T, pert PBL" +rconfig real ens_sasamp namelist,physics max_domains 50. irh "sas perturbation Amplitude" "unit: hPa" +rconfig real ens_pblamp namelist,physics max_domains 0.2 irh "sas perturbation Amplitude" "unit: 100*%" +endif # nmm variables @@ -1261,18 +1423,18 @@ rconfig integer idtad namelist,physics max_domains 2 rconfig integer nsoil namelist,physics max_domains 4 irh "nsoil" "number of soil layers" rconfig integer nphs namelist,physics max_domains 10 irh "nphs" "fundamental timesteps between calls to NMM turbulence" rconfig integer ncnvc namelist,physics max_domains 10 irh "ncnvc" "fundamental timesteps between calls to NMM convection" -rconfig integer nrads namelist,physics max_domains 200 irh "nrads" "fundamental timesteps between calls to NMM shortwave radiation" rconfig integer nrand namelist,physics max_domains 10 irh "nrand" "fundamental timesteps between random number generator updates (0=use ncnvc)" +rconfig integer nrads namelist,physics max_domains 200 irh "nrads" "fundamental timesteps between calls to NMM shortwave radiation" rconfig integer nradl namelist,physics max_domains 200 irh "nradl" "fundamental timesteps between calls to NMM longwave radiation" -rconfig real tprec namelist,physics max_domains 3. irh "tprec" "number of hours in bucket for total precipitation" -rconfig real theat namelist,physics max_domains 6. irh "theat" "number of hours in bucket for gridscale and convective heating rates" -rconfig real tclod namelist,physics max_domains 6. irh "tclod" "number of hours in bucket for cloud amounts" -rconfig real trdsw namelist,physics max_domains 6. irh "trdsw" "number of hours in bucket for short wave fluxes" -rconfig real trdlw namelist,physics max_domains 6. irh "trdlw" "number of hours in bucket for long wave fluxes" -rconfig real tsrfc namelist,physics max_domains 6. irh "tsrfc" "number of hours in bucket for evaporation / sfc fluxes" +rconfig real tprec namelist,physics max_domains 385. irh "tprec" "number of hours in bucket for total precipitation" +rconfig real theat namelist,physics max_domains 385. irh "theat" "number of hours in bucket for gridscale and convective heating rates" +rconfig real tclod namelist,physics max_domains 385. irh "tclod" "number of hours in bucket for cloud amounts" +rconfig real trdsw namelist,physics max_domains 385. irh "trdsw" "number of hours in bucket for short wave fluxes" +rconfig real trdlw namelist,physics max_domains 385. irh "trdlw" "number of hours in bucket for long wave fluxes" +rconfig real tsrfc namelist,physics max_domains 385. irh "tsrfc" "number of hours in bucket for evaporation / sfc fluxes" rconfig logical pcpflg namelist,physics max_domains .false. irh "pcpflg" "logical switch that turns on/off the precipitation assimilation" rconfig integer sigma namelist,physics max_domains 1 irh "sigma" "logical switch for NMM vertical coordinate (sigma or hybrid)" -rconfig real sfenth namelist,physics max_domains 1.0 irh "sea spray parameter" +rconfig real sfenth namelist,physics max_domains 0.0 irh "sea spray parameter" rconfig integer co2tf namelist,physics 1 0 - "co2tf" "GFDL radiation co2 flag" rconfig integer ra_call_offset namelist,physics 1 -1 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" @@ -1284,13 +1446,24 @@ rconfig integer no_src_types namelist,physics 1 1 rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" rconfig integer o3input namelist,physics 1 0 - "o3input" "ozone input option for radiation" "" rconfig integer aer_opt namelist,physics 1 0 - "aer_opt" "aerosol input option for radiation" "" -rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback of cumulus cloud to radiation" +rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback of cumulus cloud to radiation" rconfig integer ICLOUD_CU derived 1 0 - "ICLOUD_CU" "" "" +rconfig real h_diff namelist,physics max_domains 0.1 irh "nmm input 9" + +ifdef HWRF=1 +rconfig integer movemin namelist,physics max_domains 10 irh "movemin" "nest movement timestep (multiples of nphs)" +endif +rconfig integer movemin namelist,physics max_domains 0 irh "movemin" "nest movement timestep (multiples of nphs)" + rconfig integer num_snso_layers namelist,physics 1 7 irh "num_snso_layers" "" "" rconfig integer num_snow_layers namelist,physics 1 3 irh "num_snow_layers" "" "" rconfig logical use_aero_icbc namelist,physics 1 .false. rh "use_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero" "logical flag" + +# The following two options are hooked into various microphysics schemes to allow for ensemble perturbations of CCN and hail/graupel PSDs - GAC (AFWA) +rconfig real ccn_conc namelist,physics 1 1.0E8 h "ccn_conc" "CCN concentration" "# m-3" +rconfig integer hail_opt namelist,physics 1 0 rh "hail_opt" "Hail/Graupel switch, 1:hail, 0:graupel" "" rconfig integer sf_lake_physics namelist,physics max_domains 0 h "sf_lake_physics" "activate lake model 0=no, 1=yes" "" -# For Noah-MP + # Dynamics # dynamics option (see package definitions, below) @@ -1326,13 +1499,25 @@ rconfig real tke_upper_bound namelist,dynamics max_domains 1000. rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "" rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "" rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" -rconfig logical euler_adv namelist,dynamics 1 .true. irh "euler_adv" "logical flag to turn on/off Eulerian passive advection" "" -rconfig integer idtadt namelist,dynamics 1 2 irh "idtadt" "fundamental timesteps between calls to Eulerian advection for dynamics" "" -rconfig integer idtadc namelist,dynamics 1 2 irh "idtadc" "fundamental timesteps between calls to Eulerian advection for chemistry" "" + +ifdef HWRF=1 + # HWRF configuration disables Eulerian passive advection + rconfig logical euler_adv namelist,dynamics 1 .false. irh "euler_adv" "logical flag to turn on/off Eulerian passive advection" "" + rconfig integer idtadt namelist,dynamics 1 1 irh "idtadt" "fundamental timesteps between calls to Eulerian advection for dynamics" "" + rconfig integer idtadc namelist,dynamics 1 1 irh "idtadc" "fundamental timesteps between calls to Eulerian advection for chemistry" "" +endif + +# Non-HWRF configuration uses Eulerian passive advection +rconfig logical euler_adv namelist,dynamics 1 .true. irh "euler_adv" "logical flag to turn on/off Eulerian passive advection" "" +rconfig integer idtadt namelist,dynamics 1 2 irh "idtadt" "fundamental timesteps between calls to Eulerian advection for dynamics" "" +rconfig integer idtadc namelist,dynamics 1 2 irh "idtadc" "fundamental timesteps between calls to Eulerian advection for chemistry" "" + rconfig real codamp namelist,dynamics max_domains 6.4 irh "codamp" "divergence damping weighting factor (larger = more damping) " "" rconfig real coac namelist,dynamics max_domains 1.6 irh "coac" "horizontal diffusion weighting factor (larger = more diffusion) " "" -rconfig real slophc namelist,dynamics max_domains 6.363961e-3 irh "slophc" "Maximum model level slope(dZ/dy) for which hor diffusion is applied" "" -rconfig real wp namelist,dynamics max_domains 0. irh "wp" "Off-centering weight in the updating ofnonhyrostatic eps" +rconfig real slophc namelist,dynamics max_domains 6.363961e-3 irh "slophc" "Maximum model level slope (dZ/dy) for which hor diffusion is applied" "" +rconfig real wp namelist,dynamics max_domains 0. irh "wp" "Off-centering weight in the updating of nonhyrostatic eps" + +rconfig integer terrain_smoothing namelist,dynamics 1 1 irh "parallel_smooth" "nest_terrain smoothing method 0=none, 1=old, 2=new" # Bdy_control rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" @@ -1380,7 +1565,8 @@ rconfig integer FLAG_SLP derived 1 rconfig integer FLAG_SOILHGT derived 1 0 - "FLAG_SOILHGT" "Flag for soil height in the global attributes for metgrid data" rconfig integer FLAG_MF_XY derived 1 0 - "FLAG_MF_XY" "Flag for MF_XYin the global attributes for metgrid data" rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" -rconfig character mminlu derived max_domains " " - "mminlu" "land use dataset" "" +rconfig character mminlu derived max_domains " " - "mminlu" "land use dataset" + "" rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" rconfig integer islake derived max_domains 0 - "islake" "land use index of inland lake" "index category" rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" @@ -1390,6 +1576,13 @@ rconfig integer map_proj derived max_domains rconfig integer dfi_stage derived 1 3 - "dfi_stage" "current stage of DFI processing" "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast" rconfig integer mp_physics_dfi derived max_domains -1 - "mp_physics_dfi" "" "-1 = no DFI and so no need to allocate DFI moistnd scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package" +#rconfig integer simulation_start_year derived 1 0 h "simulation_start_year" "start of simulation through restarts" "4-digit year" +#rconfig integer simulation_start_month derived 1 0 h "simulation_start_month" "start of simulation through restarts" "2-digit month" +#rconfig integer simulation_start_day derived 1 0 h "simulation_start_day" "start of simulation through restarts" "2-digit day" +#rconfig integer simulation_start_hour derived 1 0 h "simulation_start_hour" "start of simulation through restarts" "2-digit hour" +#rconfig integer simulation_start_minute derived 1 0 h "simulation_start_minute" "start of simulation through restarts" "2-digit minute" +#rconfig integer simulation_start_second derived 1 0 h "simulation_start_second" "start of simulation through restarts" "2-digit second" + # # Single dummy declaration to define a nodyn dyn option state integer nodyn_dummy - dyn_nodyn - - - "" "" "" @@ -1399,67 +1592,75 @@ rconfig integer maxpatch namelist,physics 1 10 #key package associated package associated 4d scalars # name namelist choice state vars -#package passivec1 chem_opt==0 - +#### 9. Edit the Registry file to set up '5' as the value of the +**** namelist variable dyn_opt that means to select our exp dyncore. +package dyn_exp dyn_opt==5 - - + +package passivec1 chem_opt==0 - package passiveqv mp_physics==0 - moist:qv package kesslerscheme mp_physics==1 - moist:qv,qc,qr package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg -package wsm3scheme mp_physics==3 - moist:qv,qc,qr -package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs -package etampnew mp_physics==5 - moist:qv,qc,qr,qs -package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg +package wsm3scheme mp_physics==3 - moist:qv,qc,qr;state:re_cloud,re_ice,re_snow +package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs;state:re_cloud,re_ice,re_snow +package etamp_hr mp_physics==5 - moist:qv,qc,qr,qs;state:f_ice,f_rain,f_rimef +package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg;state:re_cloud,re_ice,re_snow package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr;state:re_cloud,re_ice,re_snow package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs -package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr -package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr -package etamp_hwrf mp_physics==85 - moist:qv,qc,qr,qi,qs -package etampold mp_physics==95 - moist:qv,qc,qr,qs +package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow +package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow +package nssl_2mom mp_physics==17 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qndrop,qnr,qni,qns,qng,qnh,qvolg,qvolh;state:re_cloud,re_ice,re_snow +package nssl_2momccn mp_physics==18 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qndrop,qnr,qni,qns,qng,qnh,qvolg,qvolh;state:re_cloud,re_ice,re_snow +package nssl_1mom mp_physics==19 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qvolg +package nssl_1momlfo mp_physics==21 - moist:qv,qc,qr,qi,qs,qg +package nssl_2momg mp_physics==22 - moist:qv,qc,qr,qi,qs,qg;scalar:qndrop,qnr,qni,qns,qng,qvolg;state:re_cloud,re_ice,re_snow +package etamp_hwrf mp_physics==85 - moist:qv,qc,qr,qi,qs;state:f_ice,f_rain,f_rimef +package etampnew mp_physics==95 - moist:qv,qc,qr,qs;state:f_ice,f_rain,f_rimef +package radar_refl compute_radar_ref==1 - state:refl_10cm,refd_max package nodfimoist mp_physics_dfi==-1 - - package passiveqv_dfi mp_physics_dfi==0 - dfi_moist:dfi_qv package kesslerscheme_dfi mp_physics_dfi==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr package linscheme_dfi mp_physics_dfi==2 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package wsm3scheme_dfi mp_physics_dfi==3 - dfi_moist:dfi_qv,dfi_qc,dfi_qr -package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs -package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs -package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg +package wsm3scheme_dfi mp_physics_dfi==3 - dfi_moist:dfi_qv,dfi_qc,dfi_qr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package etamp_hr_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs +package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow - package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng -#package milbrandt3mom_dfi mp_physics_dfi==12 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_q_qzr,dfi_qzi,dfi_qzs,dfi_qzg,dfi_qzh package sbu_ylinscheme_dfi mp_physics==13 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs -package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr -package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr -package etampold_dfi mp_physics_dfi==95 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs +package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package etampnew_dfi mp_physics_dfi==95 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs # package noprogn progn==0 - - # package progndrop progn==1 - scalar:qndrop;dfi_scalar:dfi_qndrop - - package rrtmscheme ra_lw_physics==1 - - -package camlwscheme ra_lw_physics==3 - - -package rrtmg_lwscheme ra_lw_physics==4 - - +package camlwscheme ra_lw_physics==3 - state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc +package rrtmg_lwscheme ra_lw_physics==4 - state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc +package rrtmg_lwscheme_fast ra_lw_physics==24 - - package goddardlwscheme ra_lw_physics==5 - - package flglwscheme ra_lw_physics==7 - - package gfdllwscheme ra_lw_physics==99 - - -package hwrflwscheme ra_lw_physics==98 -package heldsuarez ra_lw_physics==31 - - +package hwrflwscheme ra_lw_physics==98 - - package swradscheme ra_sw_physics==1 - - package gsfcswscheme ra_sw_physics==2 - - -package camswscheme ra_sw_physics==3 - - -package rrtmg_swscheme ra_sw_physics==4 - - +package camswscheme ra_sw_physics==3 - state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc +package rrtmg_swscheme ra_sw_physics==4 - state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc +package rrtmg_swscheme_fast ra_sw_physics==24 - - package goddardswscheme ra_sw_physics==5 - - package flgswscheme ra_sw_physics==7 - - package gfdlswscheme ra_sw_physics==99 - - package hwrfswscheme ra_sw_physics==98 +package heldsuarez ra_lw_physics==31 - - package sfclayscheme sf_sfclay_physics==91 - - package myjsfcscheme sf_sfclay_physics==2 - - @@ -1470,12 +1671,13 @@ package pxsfcscheme sf_sfclay_physics==7 - - package temfsfcscheme sf_sfclay_physics==10 - - package sfclayrevscheme sf_sfclay_physics==1 - - package idealscmsfcscheme sf_sfclay_physics==89 - - +package gbmpblscheme sf_sfclay_physics==12 - - + package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn package ruclsmscheme sf_surface_physics==3 - - -package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy - +package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy,lake_depth package clmscheme sf_surface_physics==5 - - package gfdlslab sf_surface_physics==88 - - @@ -1483,29 +1685,30 @@ package pxlsmscheme sf_surface_physics==7 - - package ssibscheme sf_surface_physics==8 - - package ysuscheme bl_pbl_physics==1 - - package myjpblscheme bl_pbl_physics==2 - - -package gfsscheme bl_pbl_physics==3 - - +package gfsscheme bl_pbl_physics==3 - state:hpbl2d,heat2d,evap2d,rc2d package gfs2011scheme bl_pbl_physics==83 - state:hpbl2d,heat2d,evap2d package qnsepblscheme bl_pbl_physics==4 - - -package qnsepbl09scheme bl_pbl_physics==94 - - package acmpblscheme bl_pbl_physics==7 - - package boulacscheme bl_pbl_physics==8 - - package camuwpblscheme bl_pbl_physics==9 - - package mrfscheme bl_pbl_physics==99 - - package temfpblscheme bl_pbl_physics==10 - - -package gbmpblscheme bl_pbl_physics==12 - - +package shinhongscheme bl_pbl_physics==11 - - package fitchscheme windfarm_opt==1 - - package kfetascheme cu_physics==1 - - package bmjscheme cu_physics==2 - - package gdscheme cu_physics==93 - - package sasscheme cu_physics==84 - state:hpbl2d,heat2d,evap2d -package meso_sas cu_physics==85 - - +package meso_sas cu_physics==85 - state:hpbl2d,heat2d,evap2d package osasscheme cu_physics==4 - state:randstate1,randstate2,randstate3,randstate4,random package g3scheme cu_physics==5 - - package gfscheme cu_physics==3 - - package camzmscheme cu_physics==7 - - +package kfcupscheme cu_physics==10 - - package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep package tiedtkescheme cu_physics==6 - - +package ntiedtkescheme cu_physics==16 - - package nsasscheme cu_physics==14 - - package kfscheme cu_physics==99 - - @@ -1549,8 +1752,9 @@ package io_esmf io_form_restart==7 - - package io_yyy io_form_restart==8 - - package io_zzz io_form_restart==9 - - package io_grib2 io_form_restart==10 - - -package io_pnetcdf io_form_restart==11 - - - +package io_pnetcdf io_form_restart==11 - - +package io_pio io_form_restart==12 - - + #lightning package ltng_none lightning_option==0 - - package ltng_crm_PR92w lightning_option==1 - - @@ -1585,7 +1789,7 @@ halo HALO_NMM_INIT_12 dyn_nmm 120:DIV,OMGALF,PD,RES halo HALO_NMM_INIT_13 dyn_nmm 120:FIS,T,U halo HALO_NMM_INIT_14 dyn_nmm 120:V,Q,Q2 halo HALO_NMM_INIT_15 dyn_nmm 120:CWM,TRAIN,TCUCN -halo HALO_NMM_INIT_15B dyn_nmm 120:moist,scalar +halo HALO_NMM_INIT_15B dyn_nmm 120:moist,scalar halo HALO_NMM_INIT_16 dyn_nmm 120:RSWIN,RSWOUT,TG halo HALO_NMM_INIT_17 dyn_nmm 120:Z0,AKMS,CZEN halo HALO_NMM_INIT_18 dyn_nmm 120:AKHS,THS,QSH @@ -1599,7 +1803,7 @@ halo HALO_NMM_INIT_25 dyn_nmm 120:SFCEXC,SMSTAV,SMSTOT halo HALO_NMM_INIT_26 dyn_nmm 120:GRNFLX,PCTSNO,RLWIN halo HALO_NMM_INIT_27 dyn_nmm 120:RADOT,CZMEAN,SIGT4 halo HALO_NMM_INIT_28 dyn_nmm 120:SR -halo HALO_NMM_INIT_29 dyn_nmm 120:PREC,ACPREC,ACCLIQ +halo HALO_NMM_INIT_29 dyn_nmm 120:PREC,ACPREC,ACCLIQ,CUPREC halo HALO_NMM_INIT_30 dyn_nmm 120:ACFRST,ACSNOW halo HALO_NMM_INIT_31 dyn_nmm 120:ACSNOM,SSROFF,BGROFF halo HALO_NMM_INIT_32 dyn_nmm 120:SFCSHX,SFCLHX,SUBSHX @@ -1611,33 +1815,57 @@ halo HALO_NMM_INIT_37 dyn_nmm 120:STC,SH2O,ALBEDO halo HALO_NMM_INIT_38 dyn_nmm 120:PINT,Z,DWDT halo HALO_NMM_INIT_39 dyn_nmm 120:TOLD,UOLD,VOLD -halo HALO_NMM_A dyn_nmm 24:pd,t,u,v,q,cwm,dwdt,div;24:pint +#for HWRF: zhang increase halo width to fix feedback bug for HALO_NMM_A (24 => 48) +#for HWRF: zhang HALO_NMM_C (24 => 48), HALO_NMM_G (24 => 48), HALO_NMM_K (8 => 24) +halo HALO_NMM_A dyn_nmm 48:pd,t,u,v,q,cwm,dwdt,div;48:pint halo HALO_NMM_A_3 dyn_nmm 24:moist,scalar halo HALO_NMM_B dyn_nmm 24:div -halo HALO_NMM_C dyn_nmm 8:u,v -halo HALO_NMM_D dyn_nmm 24:pd +halo HALO_NMM_C dyn_nmm 48:u,v +halo HALO_NMM_D dyn_nmm 48:pd halo HALO_NMM_E dyn_nmm 24:petdt -halo HALO_NMM_F dyn_nmm 24:t,u,v -halo HALO_NMM_F1 dyn_nmm 80:pdslo -halo HALO_NMM_MEMBRANE_RELAX dyn_nmm 8:relaxwork -halo HALO_NMM_MEMBRANE_MASK dyn_nmm 8:relaximask -halo HALO_NMM_G dyn_nmm 24:u,v;24:z -halo HALO_NMM_H dyn_nmm 24:w -halo HALO_NMM_I dyn_nmm 48:q,q2,cwm +halo HALO_NMM_F dyn_nmm 120:t,u,v +halo HALO_NMM_F1 dyn_nmm 120:pdslo,few,fne,fse,uold,vold,told,petdt,fns +halo HALO_NMM_G dyn_nmm 48:u,v;24:z;48:w,hbm2,fad +halo HALO_NMM_H dyn_nmm 80:w,few +halo HALO_NMM_I dyn_nmm 48:q,q2,cwm,rrw halo HALO_NMM_I_3 dyn_nmm 48:moist,scalar halo HALO_NMM_J dyn_nmm 8:pd,uz0,vz0,t,q,cwm -halo HALO_NMM_J_3 dyn_nmm 8:moist,scalar -halo HALO_NMM_K dyn_nmm 8:q2;24:t,u,v,q,w,z +halo HALO_NMM_J_3 dyn_nmm 8:moist,scalar +halo HALO_NMM_K dyn_nmm 24:q2;24:t,u,v,q,w,z halo HALO_NMM_L dyn_nmm 8:pd,t,q,cwm,q2 halo HALO_NMM_L_3 dyn_nmm 8:moist,scalar halo HALO_NMM_MG dyn_nmm 8:ht_gc halo HALO_NMM_MG2 dyn_nmm 8:pd,psfc_out halo HALO_NMM_MG3 dyn_nmm 8:p_gc - +halo HALO_NMM_RAD dyn_nmm 120:GSW,RSWIN,RSWOUT halo HALO_NMM_TURBL_A dyn_nmm 8:uz0h,vz0h,hbm2 halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt +# following halos added for nesting purpose (gopal's doing): + +halo HALO_NMM_TRACK dyn_nmm 120:sm,pdyn,mslp,sqws +halo HALO_NMM_FORCE_DOWN_SST dyn_nmm 120:sst +halo HALO_NMM_WEIGHTS dyn_nmm 48:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4,HNEAR_I,HNEAR_J + +#halo HALO_NMM_FORCE_DOWN1 dyn_nmm 24:t,u,v,q,q2,cwm,pint,pd,hres_fis,fis,pdyn_parent,pdyn_smooth +#halo HALO_NMM_FORCE_DOWN1M dyn_nmm 24:MOIST,SCALAR + halo HALO_NMM_SAS_A dyn_nmm 24:uz0h,vz0h,hbm2 halo HALO_NMM_SAS_B dyn_nmm 24:ducudt,dvcudt halo HALO_TRACERS dyn_nmm 48:szj,s1z,spz,tcs +halo HALO_NMM_TERRAIN_SMOOTH dyn_nmm 24:HRES_AVC + +halo HALO_NMM_MSLP dyn_nmm 24:MSLP + +ifdef HWRF=1 +halo HALO_NMM_VT4_MSLP dyn_nmm 8:mslp +halo HALO_NMM_VT4_NOISE dyn_nmm 8:mslp_noisy +endif + +halo HALO_NMM_INTERP_INFO dyn_nmm 8:pd,iinfo,winfo,pint +halo HALO_NMM_INT_UP dyn_nmm 8:pd,fis,hres_fis,sm + +halo HALO_NMM_MEMBRANE_RELAX dyn_nmm 8:relaxwork +halo HALO_NMM_MEMBRANE_MASK dyn_nmm 8:relaximask +halo HALO_NMM_MEMBRANE_INTERP dyn_nmm 24:u10,v10,u,v diff --git a/wrfv2_fire/Registry/Registry.NMM_HWRF b/wrfv2_fire/Registry/Registry.NMM_HWRF deleted file mode 100644 index fe94da98..00000000 --- a/wrfv2_fire/Registry/Registry.NMM_HWRF +++ /dev/null @@ -1,1873 +0,0 @@ -# Registry file NMM_NEST -# -# At the present time this file is managed manually and edited by hand. -# -################################################################################ -# Dimension specifications -# -# This section of the Registry file is used to specify the dimensions -# that will be used to define arrays. Dim is the one-letter name of the -# dimension. How defined can either be "standard_domain", which means -# that the dimension (1) is one of the three spatial dimensions and (2) -# it will be set using the standard namelist mechanism and domain data -# structure dimension fields (e.g. sd31,ed31,sd32...). -# -# Order refers to which of the three sets of just-mentioned internal -# dimension variables the dimension is referred to by in the driver. -# That is, is it the first, second, or third dimension. The registry -# infers the mapping of its internal dimensions according to the -# combination of Order and Coord-axis that are specified in this table. -# Note that it is all right to more than one dimension name for, say, the -# x dimension. However, the Order and Coord-axis relationship must be -# consistent throughout. -# -# Note: these entries do not enforce storage order on a particular field. -# That is determined by the dimension strings for each field. But it does -# relate the dimspec to the internal data structures that the driver uses -# to maintain the three physical domain dimensions. -# -# "How defined" can also specify the name of a namelist variable from which -# the definition for the dimension will come; this is specified as -# "namelist=". The namelist variable must have been -# defined as an integer and with only one entry in the rconfig table. Or -# a constant can be specified. The coordinate axis for the dimension is -# either X, Y, Z, or C (for "not a spatial dimension"). The Dimname is -# the descriptive name of the dimension that will be included in the -# metadata in data sets. Note that the b, f, and t modifiers that appear -# as the last characters of dimension strings used # in state and # i1 -# registry definitions are not dimensions and do not need to be declared -# here. -# - -include registry.dimspec -include registry.lake - -############# -rconfig integer ntracers namelist,physics 1 4 - - -# option 1 -#dimspec ntracevars - constant=4 c number of 4d tracer variables -#state real - ijk{ntracevars}f tracers 1 - - - - -#state real t1 ijk{ntracevars}f tracers 1 - r - - -#state real t2 ijk{ntracevars}f tracers 1 - r - - -#state real t3 ijk{ntracevars}f tracers 1 - r - - -#state real t4 ijk{ntracevars}f tracers 1 - r - - -#package tracer_option_1 ntracers==4 - tracers:t1,t2,t3,t4 - -# option 2 -state real - ijkf szj 1 - - - - -state real szj1 ijkf szj 1 - r "szj1" "szj" "units" -state real szj2 ijkf szj 1 - r "szj2" "szj" "units" -state real szj3 ijkf szj 1 - r "szj3" "szj" "units" -state real szj4 ijkf szj 1 - r "szj4" "szj" "units" - -state real - ijkf s1z 1 - - - - -state real s1z1 ijkf s1z 1 - r "s1z1" "s1z" "units" -state real s1z2 ijkf s1z 1 - r "s1z2" "s1z" "units" -state real s1z3 ijkf s1z 1 - r "s1z3" "s1z" "units" -state real s1z4 ijkf s1z 1 - r "s1z4" "s1z" "units" - -state real - ijkf spz 1 - - - - -state real spz1 ijkf spz 1 - r "spz1" "spz" "units" -state real spz2 ijkf spz 1 - r "spz2" "spz" "units" -state real spz3 ijkf spz 1 - r "spz3" "spz" "units" -state real spz4 ijkf spz 1 - r "spz4" "spz" "units" - -state real - ijkf tcs 1 - - - - -state real tcs1 ijkf tcs 1 - r "tcs1" "tcs" "units" -state real tcs2 ijkf tcs 1 - r "tcs2" "tcs" "units" -state real tcs3 ijkf tcs 1 - r "tcs3" "tcs" "units" -state real tcs4 ijkf tcs 1 - r "tcs4" "tcs" "units" - -package tracer_option_2 ntracers==4 - szj:szj1,szj2,szj3,szj4;s1z:s1z1,s1z2,s1z3,s1z4;spz:spz1,spz2,spz3,spz4;tcs:tcs1,tcs2,tcs3,tcs4 - -################################################################################ -################################################################################ -################################################################################ - -# Lines that start with the word 'state' form a table that is -# used by the script use_registry to generate module_state_descript.F -# and other files. Also see documentation in use_registry. -# -# It is reauired that LU_INDEX appears before any variable that is -# interpolated with a mask, as lu_index supplies that mask. -# -state real LU_INDEX ij misc 1 - irh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" -state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" -################################################################################ -################################################################################ - -################################ -## WPS-specific Variables -################################ - -state real p_gc ijg dyn_nmm 1 Z i1 "PRES" "pressure" "Pa" -state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" -state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" - -state real input_soil_cat ij misc 1 - i12 "SOIL_CAT" "SOIL CAT DOMINANT TYPE" "" -state real tsk_gc ij dyn_nmm 1 - i1 "SKINTEMP" "skin temperature" "K" -state real XICE_gc ij misc 1 - i014r "SEAICE" "SEA ICE" "" -state real ght_gc ijg dyn_nmm 1 Z i1 "GHT" "geopotential height" "m" -state real rh_gc ijg dyn_nmm 1 Z i1 "RH" "relative humidity" "%" -state real v_gc ijg dyn_nmm 1 Z i1 "VV" "y-wind component" "m s-1" -state real u_gc ijg dyn_nmm 1 Z i1 "UU" "x-wind component" "m s-1" -state real t_gc ijg dyn_nmm 1 Z i1 "TT" "temperature" "K" -state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" -state real greenfrac_gc ijm dyn_nmm 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" -state real albedo12m_gc ijm dyn_nmm 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" -state real lai12m_gc ijm dyn_nmm 1 Z i1 "LAI12M" "monthly LAI" "m2/m2" -state real soilcbot_gc ijs misc 1 Z i1 "SOILCBOT" "description" "units" -state real soilctop_gc ijs misc 1 Z i1 "SOILCTOP" "description" "units" -state real tmn_gc ij dyn_nmm 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" -state real htv_gc ij dyn_nmm 1 - i1 "HGT_V" "wind point topography elevation" "m" -state real ht_gc ij dyn_nmm 1 - i1 "HGT_M" "mass point topography elevation" "m" -state real landusef_gc iju misc 1 Z i1 "LANDUSEF" "description" "units" -state real vlon_gc ij dyn_nmm 1 - i1 "XLONG_V" "longitude, positive east" "degrees" -state real vlat_gc ij dyn_nmm 1 - i1 "XLAT_V" "latitude, positive north" "degrees" -state real hlon_gc ij dyn_nmm 1 - i1 "XLONG_M" "longitude, positive east" "degrees" -state real hlat_gc ij dyn_nmm 1 - i1 "XLAT_M" "latitude, positive north" "degrees" - -############################################################## -# Variables for coupling - -state real dtc - dyn_nmm 1 - irh "DTC" "Coupling timestep" "s" -state real guessdtc - dyn_nmm 1 - irh "GUESSDTC" "Guessed Coupling Timestep for Uncoupled Run" "s" - -############################################################## -# Variables for nmm dynamics -# -# module_BC -# -# pdb is only 2d but registry doesn't support 2d bdy arrays right now... - -# The following arrays were added to avoid using _b and _bt arrays for nesting. -# This is gopal' doing: - -state integer nrnd1 k dyn_nmm 1 - r "NRND1" - -# -# For the Inlined NCEP Tracker -# - -state real track_stderr_m1 - dyn_nmm 1 - rh "track_stderr_m1" "Standard deviation of tracker centers one hour ago" "km" -state real track_stderr_m2 - dyn_nmm 1 - rh "track_stderr_m2" "Standard deviation of tracker centers two hours ago" "km" -state real track_stderr_m3 - dyn_nmm 1 - rh "track_stderr_m3" "Standard deviation of tracker centers three hours ago" "km" -state integer track_last_hour - dyn_nmm 1 - rh "track_last_hour" "Last completed forecast hour" "hours" -state integer tracker_fixes ij dyn_nmm 1 - rh "tracker_fixes" "Tracker fix information" "" -state real tracker_fixlon - dyn_nmm 1 - rh "tracker_fixlon" "Storm fix longitude according to inline NCEP tracker" "degrees" -state real tracker_fixlat - dyn_nmm 1 - rh "tracker_fixlat" "Storm fix latitude according to inline NCEP tracker" "degrees" -state integer tracker_ifix - dyn_nmm 1 - rh "tracker_ifix" "Storm fix i location (H grid)" "" -state integer tracker_jfix - dyn_nmm 1 - rh "tracker_jfix" "Storm fix j location (H grid)" "" -state logical tracker_havefix - dyn_nmm 1 - rh "tracker_havefix" "True = storm fix locations are valid" "" -state logical tracker_gave_up - dyn_nmm 1 - rh "tracker_gave_up" "True = inline tracker gave up on tracking the storm" "" - -state real membrane_mslp ij dyn_nmm 1 - rh "membrane_mslp" "Mean Sea Level Pressure using UPP Membrane MSLP method" "Pa" -state real relaxwork ij dyn_nmm 1 - r "relaxwork" "Temporary Tv storage array for the membrane MSLP overrelaxation loops" "K" -state integer relaximask ij dyn_nmm 1 - r "relaximask" "Integer mask array for the membrane MSLP overrelaxation loops" "K" -state logical relaxmask ij dyn_nmm 1 - r "relaxmask" "Mask array for the membrane MSLP overrelaxation loops" "K" - -state real p850rv ij dyn_nmm 1 - rh "P850rv" "Relative vorticity at 850mbar mass points" "s^-1" -state real p700rv ij dyn_nmm 1 - rh "P700rv" "Relative vorticity at 700mbar mass points" "s^-1" -state real p850wind ij dyn_nmm 1 - rh "P850wind" "Wind magnitude at 850mbar mass points" "m/s" -state real p700wind ij dyn_nmm 1 - rh "P700wind" "Wind magnitude at 700mbar mass points" "m/s" -state real p850z ij dyn_nmm 1 - rh "P850z" "Height at 850mbar mass points" "m" -state real p700z ij dyn_nmm 1 - rh "P700z" "Height at 700mbar mass points" "m" -state real m10wind ij dyn_nmm 1 - rh "m10wind" "Wind magnitude at 10m mass points" "m/s" -state real m10rv ij dyn_nmm 1 - rh "m10rv" "Relative vorticity at 10m mass points" "m/s" - -state real sp850rv ij dyn_nmm 1 - rh "sP850rv" "Smoothed relative vorticity at 850mbar mass points" "s^-1" -state real sp700rv ij dyn_nmm 1 - rh "sP700rv" "Smoothed relative vorticity at 700mbar mass points" "s^-1" -state real sp850wind ij dyn_nmm 1 - rh "sP850wind" "Smoothed wind magnitude at 850mbar mass points" "m/s" -state real sp700wind ij dyn_nmm 1 - rh "sP700wind" "Smoothed wind magnitude at 700mbar mass points" "m/s" -state real sp850z ij dyn_nmm 1 - rh "sP850z" "Smoothed height at 850mbar mass points" "m" -state real sp700z ij dyn_nmm 1 - rh "sP700z" "Smoothed height at 700mbar mass points" "m" -state real sm10wind ij dyn_nmm 1 - rh "sm10wind" "Smoothed wind magnitude at 10m mass points" "m/s" -state real sm10rv ij dyn_nmm 1 - rh "sm10rv" "Smoothed relative vorticity at 10m mass points" "m/s" - -state real smslp ij dyn_nmm 1 - rh "smslp" "Smoothed membrane_mslp" "Pa" - -# -# For the moving nest. This is gopal's doing -# - -state real pdyn ij dyn_nmm 1 - rh "PDYN" "Dynamic pressure at mean sea level" -state real mslp ij dyn_nmm 1 - rh "MSLP" "MSLP USED TO DETERMINE STORM LOCATION" -state real sqws ij dyn_nmm 1 - r "SQWS" "SQUARE OF WIND SPEED AT LEVEL 10" -state integer xloc - dyn_nmm 2 - r "XLOC" "I-LOCATION OF MINIMUM DYNAMIC PRESSURE" -state integer yloc - dyn_nmm 2 - r "YLOC" "J-LOCATION OF MINIMUM DYNAMIC PRESSURE" -state logical mvnest - dyn_nmm 1 - r "MVNEST" "LOGICAL SWITCH FOR NMM GRID MOTION" -#for HWRF: zhang's doing added to calculate radiation constant for moving nest for restart -state integer julyr_rst - dyn_nmm 1 - r "JULYR_RST" "JULYR for restart moving nest " -state integer julday_rst - dyn_nmm 1 - r "JULDAY_RST" "JULDAY for restart moving nest " -state real gmt_rst - dyn_nmm 1 - r "GMT_RST" "GMT for restart moving nest " -state integer NTIME0 - dyn_nmm 1 - r "NTIME0" "COUNT FOR PREVIOUS MOVING NEST" - -#for HWRF: -# flag for nest movement -state logical moved - misc 1 - r - -state real ducudt ijk misc 1 - rh "UMMIX" "U TENDENCY MOMENTUM MIXING IN SAS" -state real dvcudt ijk misc 1 - rh "VMMIX" "V TENDENCY MOMENTUM MIXING IN SAS" - -state integer randstate1 ij dyn_nmm 1 - r "randstate1" "random number generator state word 1" -state integer randstate2 ij dyn_nmm 1 - r "randstate2" "random number generator state word 2" -state integer randstate3 ij dyn_nmm 1 - r "randstate3" "random number generator state word 3" -state integer randstate4 ij dyn_nmm 1 - r "randstate4" "random number generator state word 4" -state real random ij dyn_nmm 1 - rh "random" "random number in [0,1) used by SAS" - -# Location of the SOUTH-WEST nested pointed in terms of parent grid - -state integer IIH ij dyn_nmm 1 - r -state integer JJH ij dyn_nmm 1 - r -state integer IIV ij dyn_nmm 1 - r -state integer JJV ij dyn_nmm 1 - r - -# Location of nearest parent point: - -state integer hnear_i ij dyn_nmm 1 - r "HNEAR_I" "I index of nearest parent point on H grid" -state integer hnear_j ij dyn_nmm 1 - r "HNEAR_J" "J index of nearest parent point on H grid" - -# Bi-linear weights - -state real HBWGT1 ij dyn_nmm 1 - r -state real HBWGT2 ij dyn_nmm 1 - r -state real HBWGT3 ij dyn_nmm 1 - r -state real HBWGT4 ij dyn_nmm 1 - r -state real VBWGT1 ij dyn_nmm 1 - r -state real VBWGT2 ij dyn_nmm 1 - r -state real VBWGT3 ij dyn_nmm 1 - r -state real VBWGT4 ij dyn_nmm 1 - r -#end of HWRF: - -# -state real HLON ij dyn_nmm 1 - h01 -state real HLAT ij dyn_nmm 1 - h01 -state real VLON ij dyn_nmm 1 - irh -state real VLAT ij dyn_nmm 1 - irh - -state integer hifreq_lun - dyn_nmm 0 - - - -# Projection south and west bounds for Post: -rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain in rotated coordinates" -rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain in rotated coordinates" -state real wbd0var - dyn_nmm 0 - h "wbd0var" "western boundary of the domain in rotated coordinates" -state real sbd0var - dyn_nmm 0 - h "sbd0var" "southern boundary of the domain in rotated coordinates" - -#for HWRF: -rconfig logical analysis namelist,time_control max_domains .false. irh "analysis flag" "analysis control for the nested domain" -rconfig logical write_analysis namelist,time_control max_domains .true. irh "analysis output flag" "if analysis=F and write_analysis=T then analysis file is written" - -rconfig logical high_freq namelist,time_control 1 .true. irh "high frequency output" "flag for high frequency output" -rconfig integer high_dom namelist,time_control 1 -99 irh "domain" "domain for high frequency output (-99 means all domains without children)" - -state real PSTD k dyn_nmm 1 Z r -state integer KZMAX - dyn_nmm - - r -#end of HWRF: - -state real HRES_FIS ij dyn_nmm 1 - rd=(NoInterp)u=(NoInterp)f=(NoInterp) "HRES_FIS" "HIGH RESOLUTION TERRAIN DATA FOR NESTED DOMAIN" -state real HRES_AVC ij dyn_nmm 1 - - "HRES_AVC" "TEMPORARY STORAGE OF HRES_FIS/9.81" -state real HRES_LND ij dyn_nmm 1 - - "HRES_LND" "TEMPORARY STORAGE OF HIGH-RES LND" - -# -# module_MASKS -# -state real hbm2 ij dyn_nmm 1 - irh "HBM2" "Height boundary mask; =0 outer 2 rows on H points" "" -state real hbm3 ij dyn_nmm 1 - irh "HBM3" "Height boundary mask; =0 outer 3 rows on H points" "" -state real vbm2 ij dyn_nmm 1 - irh "VBM2" "Velocity boundary mask; =0 outer 2 rows on V points" "" -state real vbm3 ij dyn_nmm 1 - irh "VBM3" "Velocity boundary mask; =0 outer 3 rows on V points" "" -state real sm ij dyn_nmm 1 - i01rh02d=(DownNear) "SM" "Sea mask; =1 for sea, =0 for land" "" -state real sice ij dyn_nmm 1 - irh02d=(DownNear) "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" -# -# module_VRBLS -# -state integer ntsd - dyn_nmm - - rh "NTSD" "Number of timesteps done" "" -state integer nstart_hour - dyn_nmm - - r "NSTART_HOUR" "Forecast hour at start of integration" "" - -state real pd ijb dyn_nmm 1 - i01rh02u=(NoInterp)d=(NoInterp)f=(NoInterp) "PD" "Mass at I,J in the sigma domain" "Pa" -state real fis ij dyn_nmm 1 - i01rh02u=(NoInterp)d=(NoInterp)f=(NoInterp) "FIS" "Surface geopotential" "m2 s-2" -state real res ij dyn_nmm 1 - irh "RES" "Reciprocal of surface sigma" "" -state real t ijkb dyn_nmm 1 - i01rh02u=(NoInterp)d=(NoInterp)f=(NoInterp) "T" "Sensible temperature" "K" -state real q ijkb dyn_nmm 1 - i01rh02u=(NoInterp)d=(NoInterp)f=(NoInterp) "Q" "Specific humidity" "kg kg-1" -state real test_vgrid ij dyn_nmm 1 v - "test_vgrid" "Testing V grid staggering" "gibbletrons" -state real u ijkb dyn_nmm 1 v i01rh02u=(UpVel)d=(DownVel)f=(BdyVel) "U" "U component of wind" "m s-1" -state real v ijkb dyn_nmm 1 v i01rh02u=(UpVel)d=(DownVel)f=(BdyVel) "V" "V component of wind" "m s-1" -state real told ijk dyn_nmm 1 - r "TOLD" "T from previous timestep" "K" -state real uold ijk dyn_nmm 1 - r "UOLD" "U from previous timestep" "m s-1" -state real vold ijk dyn_nmm 1 - r "VOLD" "V from previous timestep" "m s-1" -# -# NMM DFI -# -state real hcoeff {ndfi} misc 1 - - "HCOEFF" "initialization weights" -state real hcoeff_tot - misc 1 - - "HCOEFF_TOT" "initialization weights" - -state real dfi_pd ij misc 1 - r "DFI_PD" "Mass at I,J in the sigma domain" "Pa" -state real dfi_pint ijk misc 1 Z r "DFI_PINT" "Model layer interface pressure" "Pa" -state real dfi_dwdt ijk misc 1 - r "DFI_DWDT" "dwdt and 1+(dwdt)/g" "m s-2" -state real dfi_t ijk misc 1 - r "DFI_T" "Sensible temperature" "K" -state real dfi_q ijk misc 1 - r "DFI_Q" "Specific humidity" "kg kg-1" -state real dfi_u ijk misc 1 - r "DFI_U" "U component of wind" "m s-1" -state real dfi_v ijk misc 1 - r "DFI_V" "V component of wind" "m s-1" -state real dfi_q2 ijk misc 1 - r "DFI_Q2" "2 * Turbulence kinetic energy" "m2 s-2" -state real dfi_cwm ijk misc 1 - r "DFI_CWM" "Total condensate" "kg kg-1" -state real dfi_rrw ijk misc 1 - r "DFI_RRW" "Tracer" "kg kg-1" -### remaining simply set aside, and restored to original values after filtering. -### -state real dfi_STC ilj misc 1 Z r "DFI_STC" "SOIL TEMPERATURE" "K" -state real dfi_SMC ilj misc 1 Z r "DFI_SMC" "SOIL MOISTURE" "m3 m-3" -state real dfi_SH2O ilj misc 1 Z r "DFI_SH2O" "UNFROZEN SOIL MOISTURE" "m3 m-3" - -state real dfi_SNOW ij misc 1 - r "dfi_SNOW" "SNOW WATER EQUIVALENT" "kg m-2" -state real dfi_SNOWH ij misc 1 - r "dfi_SNOWH" "PHYSICAL SNOW DEPTH" "m" -state real dfi_CANWAT ij misc 1 - r "dfi_CANWAT" "CANOPY WATER" "kg m-2" -state real dfi_NMM_TSK ij misc 1 - r "dfi_NMM_TSK" "saved SURFACE SKIN TEMPERATURE" -state real dfi_SNOWC ij misc 1 - r "dfi_SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" - -# -# module_DYNAM -# -state real dx_nmm ij dyn_nmm 1 - irh02 "DX_NMM" "East-west distance H-to-V points" "m" -state real wpdar ij dyn_nmm 1 - ir -state real cpgfu ij dyn_nmm 1 - ir -state real curv ij dyn_nmm 1 - ir "CURV" "Curvature term= .5*DT*TAN(phi)/RadEarth" "s m-1" -state real fcp ij dyn_nmm 1 - ir -state real fdiv ij dyn_nmm 1 - ir -state real f ij dyn_nmm 1 - ir "F" "Coriolis * DT/2" "" -state real fad ij dyn_nmm 1 - ir -state real ddmpu ij dyn_nmm 1 - ir "DDMPU" "Divergence damping term for U" "m" -state real ddmpv ij dyn_nmm 1 - ir "DDMPV" "Divergence damping term for V" "m" -state real deta k dyn_nmm 1 - i01r "DETA" "Delta sigma in sigma domain" "" -state real rdeta k dyn_nmm 1 - ir "RDETA" "Reciprocal of DETA" "" -state real aeta k dyn_nmm 1 - i01r -state real f4q2 k dyn_nmm 1 - ir -state real etax k dyn_nmm 1 - i01r -state real dfl k dyn_nmm 1 Z i01r "DFL" "Standard atmosphere geopotential" "m2 s-2" -state real deta1 k dyn_nmm 1 - i01rh02 "DETA1" "Delta sigma in pressure domain" "" -state real aeta1 k dyn_nmm 1 - i01rh02 "AETA1" "Midlayer sigma value in pressure domain" "" -state real eta1 k dyn_nmm 1 Z i01rh02 "ETA1" "Interface sigma value in pressure domain" "" -state real deta2 k dyn_nmm 1 - i01rh02 "DETA2" "Delta sigma in sigma domain" "" -state real aeta2 k dyn_nmm 1 - i01rh02 "AETA2" "Midlayer sigma value in sigma domain" "" -state real eta2 k dyn_nmm 1 Z i01rh02 "ETA2" "Interface sigma value in sigma domain" "" -state real em q dyn_nmm 1 - ir -state real emt q dyn_nmm 1 - ir -#for HWRF: add to restart -state real adt ij dyn_nmm 1 - r "ADT" "Change of T due to advection" "K" -state real adu ij dyn_nmm 1 - r "ADU" "Change of U due to advection" "m s-1" -state real adv ij dyn_nmm 1 - r "ADV" "Change of V due to advection" "m s-1" -#end HWRF: -state real em_loc q dyn_nmm 1 - r -state real emt_loc q dyn_nmm 1 - r -state real dy_nmm - dyn_nmm - - irh02 "DY_NMM" "North-south distance H-to-V points" "m" -state real cpgfv - dyn_nmm - - ir -state real en - dyn_nmm - - ir -state real ent - dyn_nmm - - ir -state real f4d - dyn_nmm - - ir -state real f4q - dyn_nmm - - ir -state real ef4t - dyn_nmm - - ir -#for HWRF: add to restart -state logical upstrm - dyn_nmm - - - "UPSTRM" ".TRUE. => In upstream advec region of grid" "" -#end HWRF: -state real dlmd - dyn_nmm - - irh02 "DLMD" "East-west angular distance H-to-V points" "degrees" -state real dphd - dyn_nmm - - irh02 "DPHD" "North-south angular distance H-to-V points" "degrees" -state real pdtop - dyn_nmm - - i01rh02 "PDTOP" "Mass at I,J in pressure domain" "Pa" -state real pt - dyn_nmm - - i01rh02 "PT" "Pressure at top of domain" "Pa" -# -# module_CONTIN -# -#for HWRF: add to restart -state real pdsl ij dyn_nmm 1 - r "PDSL" "Sigma-domain pressure at sigma=1" "Pa" -state real pdslo ij dyn_nmm 1 - r "PDSLO" "PDSL from previous timestep" "Pa" -#end HWRF: -state real psdt ij dyn_nmm 1 - r "PSDT" "Surface pressure tendency" "Pa s-1" -state real div ijk dyn_nmm 1 - r "DIV" "Divergence" "Pa s-1" -state real def3d ijk dyn_nmm 1 - r "DEF3D" "Deformation term from horizontal diffusion" "" -#for HWRF: add to restart -state real few ijk dyn_nmm 1 - r "FEW" "Integrated east-west mass flux" "Pa m2 s-1" -state real fne ijk dyn_nmm 1 - r "FNE" "Integrated northeast-southwest mass flux" "Pa m2 s-1" -state real fns ijk dyn_nmm 1 - r "FNS" "Integrated north-south mass flux" "Pa m2 s-1" -state real fse ijk dyn_nmm 1 - r "FSE" "Integrated southeast-northwest mass flux" "Pa m2 s-1" -#end HWRF: -state real omgalf ijk dyn_nmm 1 - r "OMGALF" "Omega-alpha" "K" -#for HWRF: add to restart -state real petdt ijk dyn_nmm 1 - r "PETDT" "Vertical mass flux" "Pa s-1" -#end HWRF: -state real rtop ijk dyn_nmm 1 - r "RTOP" "Rd * Tv / P" "m3 kg-1" -# -# module_PVRBLS -# -state real pblh ij dyn_nmm 1 - rh "PBLH" "PBL Height" "m" -state integer lpbl ij dyn_nmm 1 - ir "LPBL" "Model layer of PBL top" "" -state real mixht ij dyn_nmm 1 - rh "MIXHT" "MXL HEIGHT" "m" -state real ustar ij dyn_nmm 1 - irhd=(DownNear) "USTAR" "Friction velocity" "m s-1" -state real z0 ij dyn_nmm 1 - i01rhd=(DownNear) "Z0" "Thermal Roughness length" "m" -state real mz0 ij dyn_nmm 1 - h "MZ0" "momentum Roughness length" "m" -state real rc2d ij dyn_nmm 1 - h "RC2D" "critical Richardson number" "m" -state real dku3d ijk dyn_nmm 1 - h "DKU3D" "Momentum Diffusivity" "m*m/s" -state real dkt3d ijk dyn_nmm 1 - h "DKT3D" "Thermal Diffusivity" "m*m/s" -state real hpbl2d ij dyn_nmm 1 - irh "HPBL2D" "HEIGHT OF PBL from new GFS pbl" "m" -state real heat2d ij dyn_nmm 1 - irh "HEAT2D" "" "" -state real evap2d ij dyn_nmm 1 - irh "EVAP2D" "" "" -state real z0base ij dyn_nmm 1 - ir "Z0BASE" "Base roughness height" "m" -state real ths ij dyn_nmm 1 - irhd=(DownCopy) "THS" "Surface potential temperature" "K" -state real mavail ij dyn_nmm 1 - i -state real qsh ij dyn_nmm 1 - irhd=(DownCopy) "QS" "Surface specific humidity" "kg kg-1" -state real twbs ij dyn_nmm 1 - irh "TWBS" "Instantaneous sensible heat flux" "W m-2" -state real qwbs ij dyn_nmm 1 - irh "QWBS" "Instantaneous latent heat flux" "W m-2" -state real taux ij dyn_nmm 1 - irh "TAUX" "Instantaneous stress along X direction in KG/M/S^2" -state real tauy ij dyn_nmm 1 - irh "TAUY" "Instantaneous stress along Y direction in KG/M/S^2" -state real prec ij dyn_nmm 1 - rh "PREC" "Precipitation in physics timestep" "m" -state real aprec ij dyn_nmm 1 - rh -state real acprec ij dyn_nmm 1 - rh01d=(DownCopy) "ACPREC" "Accumulatedtotal precipitation" "m" -state real cuprec ij dyn_nmm 1 - rh "CUPREC" "Accumulated convective precipitation" "m" -state real lspa ij dyn_nmm 1 - h "LSPA" "Land Surface Precipitation Accumulation" "kg m-2" -state real ddata ij dyn_nmm 1 - - "DDATA" "Observed precip to each physics timestep" "kg m-2" -state real accliq ij dyn_nmm 1 - r -state real sno ij dyn_nmm 1 - irh02 "SNO" "Liquid water eqiv of snow on ground" "kg m-2" -state real si ij dyn_nmm 1 - irh "SI" "Depth of snow on ground" "mm" -state real cldefi ij dyn_nmm 1 - rhd=(DownCopy) "CLDEFI" "Convective cloud efficiency" "" -state real deep ij dyn_nmm 1 - r "DEEP" "Deep convection =>.TRUE." "" -state real rf ij dyn_nmm 1 - r -state real th10 ij dyn_nmm 1 - rhd=(DownCopy) "TH10" "10-m potential temperature from MYJ" "K" -state real q10 ij dyn_nmm 1 - rhd=(DownCopy) "Q10" "10-m specific humidity from MYJ" "kg kg-1" -state real pshltr ij dyn_nmm 1 - rhd=(DownCopy) "PSHLTR" "2-m pressure from MYJ" "Pa" -state real tshltr ij dyn_nmm 1 - rhd=(DownCopy) "TSHLTR" "2-m potential temperature from MYJ" "K" -state real qshltr ij dyn_nmm 1 - rhd=(DownCopy) "QSHLTR" "2-m specific humidity from MYJ" "kg kg-1" -state real q2 ijkb dyn_nmm 1 - irhu=(UpMass:@EConst,0.0)d=(DownMass:@EConst,0.0)f=(BdyMass:@EConst,0.0) "Q2" "2 * Turbulence kinetic energy" "m2 s-2" -state real t_adj ijk dyn_nmm 1 - rd=(DownNear) "T_ADJ" "T change due to precip in phys step" "K" -state real t_old ijk dyn_nmm 1 - r "T_OLD" "T before last call to precip" "K" -state real zero_3d ijk dyn_nmm 1 - r -state real W0AVG ikj dyn_nmm 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" -state real AKHS_OUT ij dyn_nmm 1 - rh "AKHS_OUT" "Output sfc exch coeff for heat" "m2 s-1" -state real AKMS_OUT ij dyn_nmm 1 - rh "AKMS_OUT" "Output sfc exch coeff for momentum" "m2 s-1" -# -# module_PHYS -# -state real albase ij dyn_nmm 1 - i01rhd=(DownCopy) "ALBASE" "Base albedo" "" -state real albedo ij dyn_nmm 1 - irh "ALBEDO" "Dynamic albedo" "" -state real cnvbot ij dyn_nmm 1 - irh "CNVBOT" "Lowest convec cloud bottom lyr between outputs" "" -state real cnvtop ij dyn_nmm 1 - irh "CNVTOP" "Highest convec cloud top lyr between outputs" "" -state real czen ij dyn_nmm 1 - irh "CZEN" "Cosine of solar zenith angle" "" -state real czmean ij dyn_nmm 1 - irh "CZMEAN" "Mean CZEN between SW radiation calls" "" -state real embck ij dyn_nmm 1 - ir "EMBCK" "Background radiative emissivity" "" -state real epsr ij dyn_nmm 1 - irh "EPSR" "Radiative emissivity" "" -state real gffc ij dyn_nmm 1 - ir -state real glat ij dyn_nmm 1 - i01rh02 "GLAT" "Geographic latitude, radians" "" -state real glon ij dyn_nmm 1 - i01rh02 "GLON" "Geographic longitude, radians" "" -state real NMM_TSK ij dyn_nmm 1 - i01rh02d=(DownNear) "TSK" "Skin temperature" "K" -state real hdac ij dyn_nmm 1 - ir "HDAC" "Composite diffusion coeff for mass points" "s m-1" -state real hdacv ij dyn_nmm 1 - ir "HDACV" "Composite diffusion coeff for velocity points" "s m-1" -state real mxsnal ij dyn_nmm 1 - i01rhd=(DownNear) "MXSNAL" "Maximum deep snow albedo" "" -state real radin ij dyn_nmm 1 - r -state real radot ij dyn_nmm 1 - rh "RADOT" "Radiative emission from surface" "W m-2" -state real sigt4 ij dyn_nmm 1 - rhd=(DownCopy) "SIGT4" "Stefan-Boltzmann * T**4" "W m-2" -state real tg ij dyn_nmm 1 - i01rhd=(DownNear) "TGROUND" "Deep ground soil temperature" "K" -state real dfrlg k dyn_nmm 1 Z i01r "DFRLG" "Std atmosphere height of model layer interfaces" "m" -state integer lvl ij dyn_nmm 1 - ir -state integer k22_deep ij misc 1 - - "K22_DEEP" "K22 LEVEL FROM DEEPCONVECTION (G3 only)" "" -state integer kbcon_deep ij misc 1 - - "KBCON_DEEP" "KBCON LEVEL FROM DEEP CONVECTION (G3 only)" "" -state integer ktop_deep ij misc 1 - - "KTOP_DEEP" "KTOP LEVEL FROM DEEP CONVECTION (G3 only)" "" -state real RAINCV_A ij misc 1 - r "RAINCV_A" "taveragd TIME-STEP CUMULUS PRECIPITATION" "mm" -state real RAINCV_B ij misc 1 - r "RAINCV_B" "taveragd TIME-STEP CUMULUS PRECIPITATION" "mm" -state real GD_CLOUD ikj misc 1 - r "GD_CLOUD" "CLOUD WATER/ICE MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2 ikj misc 1 - r "GD_CLOUD2" "TEST for GD CLOUD" "kg kg-1" -state real GD_CLOUD_A ikj misc 1 - r "GD_CLOUD_A" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2_A ikj misc 1 - r "GD_CLOUD2_A" "taveragd cloud ice mix ratio in GD" "kg kg-1" -state real QC_CU ikj misc 1 - r "QC_CU" "CLOUD WATER MIXING RATIO FROM A CU SCHEME" "kg kg-1" -state real QI_CU ikj misc 1 - r "QI_CU" "CLOUD ICE MIXUNG RATIO FROM A CU SCHEME" "kg kg-1" -state real GD_CLDFR ikj misc 1 - r "GD_CLDFR" "GD CLOUD Fraction" " ? " -# upward and downward clearsky and total diagnostic fluxes for radiation (RRTMG) -state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" -state real ACSWUPTC ij misc 1 - rhdu "ACSWUPTC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" -state real ACSWDNT ij misc 1 - rhdu "ACSWDNT" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" -state real ACSWDNTC ij misc 1 - rhdu "ACSWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" -state real ACSWUPB ij misc 1 - rhdu "ACSWUPB" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" -state real ACSWUPBC ij misc 1 - rhdu "ACSWUPBC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" -state real ACSWDNB ij misc 1 - rhdu "ACSWDNB" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" -state real ACSWDNBC ij misc 1 - rhdu "ACSWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" -state real ACLWUPT ij misc 1 - rhdu "ACLWUPT" "ACCUMULATED UPWELLING LONGWAVE FLUX AT TOP" "J m-2" -state real ACLWUPTC ij misc 1 - rhdu "ACLWUPTC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" -state real ACLWDNT ij misc 1 - rhdu "ACLWDNT" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" -state real ACLWDNTC ij misc 1 - rhdu "ACLWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" -state real ACLWUPB ij misc 1 - rhdu "ACLWUPB" "ACCUMULATED UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" -state real ACLWUPBC ij misc 1 - rhdu "ACLWUPBC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" -state real ACLWDNB ij misc 1 - rhdu "ACLWDNB" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" -state real ACLWDNBC ij misc 1 - rhdu "ACLWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" -state real SWUPT ij misc 1 - rhdu "SWUPT" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP" "W m-2" -state real SWUPTC ij misc 1 - rhdu "SWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" -state real SWDNT ij misc 1 - rhdu "SWDNT" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP" "W m-2" -state real SWDNTC ij misc 1 - rhdu "SWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" -state real SWUPB ij misc 1 - rhdu "SWUPB" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" -state real SWUPBC ij misc 1 - rhdu "SWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2" -state real SWDNB ij misc 1 - rhdu "SWDNB" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" -state real SWDNBC ij misc 1 - rhdu "SWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2" -state real LWUPT ij misc 1 - rhdu "LWUPT" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP" "W m-2" -state real LWUPTC ij misc 1 - rhdu "LWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2" -state real LWDNT ij misc 1 - rhdu "LWDNT" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP" "W m-2" -state real LWDNTC ij misc 1 - rhdu "LWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2" -state real LWUPB ij misc 1 - rhdu "LWUPB" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" -state real LWUPBC ij misc 1 - rhdu "LWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2" -state real LWDNB ij misc 1 - rhdu "LWDNB" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" -state real LWDNBC ij misc 1 - rhdu "LWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "Wm-2" -state real SWVISDIR ij misc 1 Z r "SWVISDIR" "SWR VIS DIR component" "" -state real SWVISDIF ij misc 1 Z r "SWVISDIF" "SWR VIS DIF component" "" -state real SWNIRDIR ij misc 1 Z r "SWNIRDIR" "SWR NIR DIR component" "" -state real SWNIRDIF ij misc 1 Z r "SWNIRDIF" "SWR NIR DIF component" "" - -state real refl_10cm ikj dyn_nmm 1 - h "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" -state real REFD_MAX ij misc 1 - h "REFD_MAX" "MAX DERIVED RADAR REFL" "dbZ" -state real qnwfa2d ij misc 1 - rhdu "QNWFA2D" "Surface aerosol number conc emission" "kg-1 s-1" -state real re_cloud ikj misc 1 - r "re_cloud" "Effective radius, cloud drops" "m" -state real re_ice ikj misc 1 - r "re_ice" "Effective radius, cloud ice" "m" -state real re_snow ikj misc 1 - r "re_snow" "Effective radius, snow" "m" -state real dfi_re_cloud ikj misc 1 - - "DFI_RE_CLOUD" "DFI Effective radius cloud water" "m" -state real dfi_re_ice ikj misc 1 - - "DFI_RE_ICE" "DFI Effective radius cloud ice" "m" -state real dfi_re_snow ikj misc 1 - - "DFI_RE_SNOW" "DFI Effective radius snow" "m" -state integer has_reqc - misc 1 - r "has_reqc" "Flag for has effective radius of cloud water" "" -state integer has_reqi - misc 1 - r "has_reqi" "Flag for has effective radius of cloud ice" "" -state integer has_reqs - misc 1 - r "has_reqs" "Flag for has effective radius of snow" "" - -# -# added WRF-Solar -state real swddir ij misc 1 - rhd "SWDDIR" "Shortwave surface downward direct irradiance" "W/m^2" "" -state real swddni ij misc 1 - rhd "SWDDNI" "Shortwave surface downward direct normal irradiance" "W/m^2" "" -state real swddif ij misc 1 - rhd "SWDDIF" "Shortwave surface downward diffuse irradiance" "W/m^2" "" -state real Gx ij misc 1 - rd "Gx" "" "" -state real Bx ij misc 1 - rd "Bx" "" "" -state real gg ij misc 1 - rd "gg" "" "" -state real bb ij misc 1 - rd "bb" "" "" -state real coszen_ref ij misc 1 - - "coszen_ref" "" "" -state real coszen ij misc 1 - - "coszen " "" "" -state real hrang ij misc 1 - - "hrang" "" "" -state real swdown_ref ij misc 1 - - "swdown_ref" "" "" -state real swddir_ref ij misc 1 - - "swddir_ref" "" "" -rconfig integer swint_opt namelist,physics 1 0 - "swint_opt" "interpolation option for sw radiation" "" -# add aerosol namelists -rconfig integer aer_type namelist,physics max_domains 1 irh "aer_type" "aerosol type: 1 is SF79 rural, 2 is SF79 urban" "" -rconfig integer aer_aod550_opt namelist,physics max_domains 1 irh "aer_aod550_opt" "input option for aerosol optical depth at 550 nm" "" -rconfig integer aer_angexp_opt namelist,physics max_domains 1 irh "aer_angexp_opt" "input option for aerosol Angstrom exponent" "" -rconfig integer aer_ssa_opt namelist,physics max_domains 1 irh "aer_ssa_opt" "input option for aerosol single-scattering albedo" "" -rconfig integer aer_asy_opt namelist,physics max_domains 1 irh "aer_asy_opt" "input option for aerosol asymmetry parameter" "" -rconfig real aer_aod550_val namelist,physics max_domains 0.12 irh "aer_aod550_val" "fixed value for aerosol optical depth at 550 nm. Valid when aer_aod550_opt=1" "" -rconfig real aer_angexp_val namelist,physics max_domains 1.3 irh "aer_angexp_val" "fixed value for aerosol Angstrom exponent. Valid when aer_angexp_opt=1" "" -rconfig real aer_ssa_val namelist,physics max_domains 0.85 irh "aer_ssa_val" "fixed value for aerosol single-scattering albedo. Valid when aer_ssa_opt=1" "" -rconfig real aer_asy_val namelist,physics max_domains 0.90 irh "aer_asy_val" "fixed value for aerosol asymmetry parameter. Valid when aer_asy_opt=1" "" - -# module_CLDWTR.F -# -state real cwm ijkb dyn_nmm 1 - rh02u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "CWM" "Total condensate" "kg kg-1" -state real rrw ijkb dyn_nmm 1 - rh "RRW" "Tracer" "kg kg-1" -state real f_ice ikj dyn_nmm 1 - rhd=(DownMassIKJ:@EExtrap,0.0)u=(UpMassIKJ:@EExtrap,0.0) "F_ICE" "Frozen fraction of CWM" "" -state real f_rain ikj dyn_nmm 1 - rhd=(DownMassIKJ:@EExtrap,0.0)u=(UpMassIKJ:@EExtrap,0.0) "F_RAIN" "Rain fraction of liquid part of CWM" "" -state real f_rimef ikj dyn_nmm 1 - rhd=(DownMassIKJ:@EExtrap,1.0)u=(UpMassIKJ:@EExtrap,1.0) "F_RIMEF" "Rime factor" "" -state real cldfra ijk dyn_nmm 1 - rh "CLDFRA" "Cloud fraction" "" -state real sr ij dyn_nmm 1 - irh "SR" "Timestep mass ratio of snow:precip" "" -state real cfrach ij dyn_nmm 1 - rhd=(DownCopy) "CFRACH" "High cloud fraction" "" -state real cfracl ij dyn_nmm 1 - rhd=(DownCopy) "CFRACL" "Low cloud fraction" "" -state real cfracm ij dyn_nmm 1 - rhd=(DownCopy) "CFRACM" "Middle cloud fraction" "" -state logical micro_start - dyn_nmm - - - -# -# module_SOIL.F -# -state integer islope ij dyn_nmm 1 - i01rhd=(DownINear) "ISLOPE" -state real dzsoil k dyn_nmm 1 - irh "DZSOIL" "Thickness of soil layers" "m" -state real rtdpth k dyn_nmm 1 - i01r -state real sldpth k dyn_nmm 1 - i01rh "SLDPTH" "Depths of centers of soil layers" "m" -state real cmc ij dyn_nmm 1 - i01rhd=(DownNear) "CMC" "Canopy moisture" "m" -state real grnflx ij dyn_nmm 1 - irh "GRNFLX" "Deep soil heat flux" "W m-2" -state real pctsno ij dyn_nmm 1 - irh -state real soiltb ij dyn_nmm 1 - i01rhd=(DownNear) "SOILTB" "Deep ground soil temperature" "K" -state real vegfrc ij dyn_nmm 1 - i014rh02d=(DownNear) "VEGFRC" "Vegetation fraction" "" -state real shdmin ij dyn_nmm 1 - - -state real shdmax ij dyn_nmm 1 - - -state real sh2o ilj dyn_nmm 1 Z irhd=(DownNearIKJ) "SH2O" "Unfrozen soil moisture volume fraction" "" -state real smc ilj dyn_nmm 1 Z irh02d=(DownNearIKJ) "SMC" "Soil moisture volume fraction" "" -state real stc ilj dyn_nmm 1 Z irh02d=(DownNearIKJ) "STC" "Soil temperature" "K" -# -# module_GWD.F -# -state real hstdv ij dyn_nmm 1 - i01rh "HSTDV" "Standard deviation of height" "m" -state real hcnvx ij dyn_nmm 1 - i01rh "HCNVX" "Normalized 4th moment of orographic convexity" "" -state real hasyw ij dyn_nmm 1 - i01rh "HASYW" "Orographic asymmetry in W-E plane" "" -state real hasys ij dyn_nmm 1 - i01rh "HASYS" "Orographic asymmetry in S-N plane" "" -state real hasysw ij dyn_nmm 1 - i01rh "HASYSW" "Orographic asymmetry in SW-NE plane" "" -state real hasynw ij dyn_nmm 1 - i01rh "HASYNW" "Orographic asymmetry in NW-SE plane" "" -state real hlenw ij dyn_nmm 1 - i01rh "HLENW" "Orographic length scale in W-E plane" "" -state real hlens ij dyn_nmm 1 - i01rh "HLENS" "Orographic length scale in S-N plane" "" -state real hlensw ij dyn_nmm 1 - i01rh "HLENSW" "Orographic length scale in SW-NE plane" "" -state real hlennw ij dyn_nmm 1 - i01rh "HLENNW" "Orographic length scale in NW-SE plane" "" -state real hangl ij dyn_nmm 1 - i01rh "HANGL" "Angle of the mountain range w/r/t east" "deg" -state real hanis ij dyn_nmm 1 - i01rh "HANIS" "Anisotropy/aspect ratio of orography" "" -state real hslop ij dyn_nmm 1 - i01rh "HSLOP" "Slope of orography" "" -state real hzmax ij dyn_nmm 1 - i01rh "HZMAX" "Maximum height above mean orography" "m" -state real crot ij dyn_nmm 1 - - "CROT" "Cosine of angle between model and earth coordinates" "" -state real srot ij dyn_nmm 1 - - "SROT" "Sine of angle between model and earth coordinates" "" -state real UGWDsfc ij dyn_nmm 1 - h "UGWDsfc" "Surface zonal wind stress due to gravity wave drag" "N m-2" -state real VGWDsfc ij dyn_nmm 1 - h "VGWDsfc" "Surface meridional wind stress due to gravity wave drag" "N m-2" -# -# Additional for topo_wind -# -state real ctopo ij misc 1 - rdu "ctopo" "Correction for topography" "" -state real ctopo2 ij misc 1 - rdu "ctopo2" "Correction for topography 2" "" -# -# module_NHYDRO.F -# -state logical hydro - dyn_nmm - - - "HYDRO" ".FALSE. => nonhydrostatic" "" -state real dwdtmn ij dyn_nmm 1 - - "DWDTMN" "Minimum value for DWDT" "m s-2" -state real dwdtmx ij dyn_nmm 1 - - "DWDTMX" "Maximum value for DWDT" "m s-2" -state real baro ij dyn_nmm 1 - - "BARO" "external mode vvel" "m s-1" -state real dwdt ijk dyn_nmm 1 - rd=(DownCopy) "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" -state real pdwdt ijk dyn_nmm 1 - r -state real pint ijk dyn_nmm 1 Z irh02d=(DownCopy)u=(NoInterp)f=(NoInterp) "PINT" "Model layer interface pressure" "Pa" -state real w ijk dyn_nmm 1 Z rd=(DownCopy) "W" "Vertical velocity" "m s-1" -state real w_tot ijk dyn_nmm 1 Z hd=(DownCopy) "W" "Vertical velocity" "m s-1" -state real z ijk dyn_nmm 1 Z hd=(DownCopy) "Z" "Distance from ground" "m" -# -# module_ACCUM.F -# -state real acfrcv ij dyn_nmm 1 - rh "ACFRCV" "Accum convective cloud fraction" "" -state real acfrst ij dyn_nmm 1 - rh "ACFRST" "Accum stratiform cloud fraction" "" -state real ssroff ij dyn_nmm 1 - rh "SSROFF" "Surface runoff" "mm" -state real bgroff ij dyn_nmm 1 - rh "BGROFF" "Subsurface runoff" "mm" -state real rlwin ij dyn_nmm 1 - rhd=(DownCopy) "RLWIN" "Downward longwave at surface" "W m-2" -state real rlwout ij dyn_nmm 1 - - -state real rlwtoa ij dyn_nmm 1 - rh "RLWTOA" "Outgoing LW flux at top of atmos" "W m-2" -state real alwin ij dyn_nmm 1 - rh "ALWIN" "Accum LW down at surface" "W m-2" -state real alwout ij dyn_nmm 1 - rh "ALWOUT" "Accum RADOT (see above)" "W m-2" -state real alwtoa ij dyn_nmm 1 - rh "ALWTOA" "Accum RLWTOA" "W m-2" -state real rswin ij dyn_nmm 1 - rhd=(DownCopy) "RSWIN" "Downward shortwave at surface" "W m-2" -state real rswinc ij dyn_nmm 1 - rh "RSWINC" "Clear-sky equivalent of RSWIN" "W m-2" -state real rswout ij dyn_nmm 1 - rh "RSWOUT" "Upward shortwave at surface" "W m-2" -#for HWRF: add to restart -state real rswtoa ij dyn_nmm 1 - rh "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" -#end HWRF -state real aswin ij dyn_nmm 1 - rh "ASWIN" "Accum SW down at surface" "W m-2" -state real aswout ij dyn_nmm 1 - rh "ASWOUT" "Accum RSWOUT" "W m-2" -state real aswtoa ij dyn_nmm 1 - rh "ASWTOA" "Accum RSWTOA" "W m-2" -state real sfcshx ij dyn_nmm 1 - rh "SFCSHX" "Accum sfc sensible heat flux" "W m-2" -state real sfclhx ij dyn_nmm 1 - rh "SFCLHX" "Accum sfc latent heat flux" "W m-2" -state real subshx ij dyn_nmm 1 - rh "SUBSHX" "Accum deep soil heat flux" "W m-2" -state real snopcx ij dyn_nmm 1 - rh "SNOPCX" "Snow phase change heat flux" "W m-2" -state real sfcuvx ij dyn_nmm 1 - rh -state real potevp ij dyn_nmm 1 - rh "POTEVP" "Accum potential evaporation" "m" -state real potflx ij dyn_nmm 1 - rh "POTFLX" "Energy equivalent of POTEVP" "W m-2" -state real tlmin ij dyn_nmm 1 - rh -state real tlmax ij dyn_nmm 1 - rh -state real t02_min ij dyn_nmm 1 - rh "T02_MIN" "Hourly Min Shelter Temperature" "K" -state real t02_max ij dyn_nmm 1 - rh "T02_MAX" "Hourly Max Shelter Temperature" "K" -state real rh02_min ij dyn_nmm 1 - rh "RH02_MIN" "Hourly Min Relative Humidity" "" -state real rh02_max ij dyn_nmm 1 - rh "RH02_MAX" "Hourly Max Relative Humidity" "" -state real rlwtt ijk dyn_nmm 1 - rhd=(DownNear) "RLWTT" "Longwave temperature tendency" "K s-1" -state real rswtt ijk dyn_nmm 1 - rhd=(DownNear) "RSWTT" "Shortwave temperature tendency" "K s-1" -#for HWRF: add to restart -state real tcucn ijk dyn_nmm 1 - rh "TCUCN" "Accum convec temperature tendency" "K s-1" -state real train ijk dyn_nmm 1 - rh "TRAIN" "Accum stratiform temp tendency" "K s-1" -#end HWRF -state integer ncfrcv ij dyn_nmm 1 - irh "NCFRCV" "# times convec cloud >0 between rad calls" "" -state integer ncfrst ij dyn_nmm 1 - irh "NCFRST" "# times stratiform cloud >0 between rad calls" "" -state integer nphs0 - dyn_nmm - - rh -state integer ncnvc0 - dyn_nmm - - rh -state integer nprec - dyn_nmm - - irh "NPREC" "# timesteps between resetting precip bucket" "" -state integer nclod - dyn_nmm - - irh "NCLOD" "# timesteps between resetting cloud frac accum" "" -state integer nheat - dyn_nmm - - irh "NHEAT" "# timesteps between resetting latent heat accum" "" -state integer nrdlw - dyn_nmm - - irh "NRDLW" "# timesteps between resetting longwave accums" "" -state integer nrdsw - dyn_nmm - - irh "NRDSW" "# timesteps between resetting shortwave accums" "" -state integer nsrfc - dyn_nmm - - irh "NSRFC" "# timesteps between resetting sfcflux accums" "" -state real avrain - dyn_nmm - - irh "AVRAIN" "# of times gridscale precip called in NHEAT steps" "" -state real avcnvc - dyn_nmm - - irh "AVCNVC" "# of times convective precip called in NHEAT steps" "" -state real aratim - dyn_nmm - - ir -state real acutim - dyn_nmm - - irh -state real ardlw - dyn_nmm - - irh "ARDLW" "# of times LW fluxes summed before resetting" "" -state real ardsw - dyn_nmm - - irh "ARDSW" "# of times SW fluxes summed before resetting" "" -state real asrfc - dyn_nmm - - irh "ASRFC" "# of times sfc fluxes summed before resetting" "" -state real aphtim - dyn_nmm - - irh -# -# module_INDX.F -# -state integer ihe j dyn_nmm 1 - - "IHE" "0 or +1 to obtain I index of V point east of H point" "" -state integer ihw j dyn_nmm 1 - - "IHW" "0 or -1 to obtain I index of V point west of H point" "" -state integer ive j dyn_nmm 1 - - "IVE" "0 or +1 to obtain I index of H point east of V point" "" -state integer ivw j dyn_nmm 1 - - "IVW" "0 or -1 to obtain I index of H point west of V point" "" -state integer irad i dyn_nmm 1 - - -#definitions for NMM east-west orientation on E grid -state integer iheg q dyn_nmm 1 - - -state integer ihwg q dyn_nmm 1 - - -state integer iveg q dyn_nmm 1 - - -state integer ivwg q dyn_nmm 1 - - -state integer iradg r dyn_nmm 1 - - -state integer n_iup_h j dyn_nmm 1 - - "N_IUP_H" "# mass points needed in each row for upstream advection" "" -state integer n_iup_v j dyn_nmm 1 - - "N_IUP_V" "# velocity points needed in each row for upstream advection" "" -state integer n_iup_adh j dyn_nmm 1 - - "N_IUP_ADH" "# mass points in each row of upstream advection" "" -state integer n_iup_adv j dyn_nmm 1 - - "N_IUP_ADV" "# velocity points in each row of upstream advection" "" -state integer iup_h ij dyn_nmm 1 - - -state integer iup_v ij dyn_nmm 1 - - -state integer iup_adh ij dyn_nmm 1 - - -state integer iup_adv ij dyn_nmm 1 - - -state integer imicrogram - misc - - r "imicrogram" "flag 0/1 0=mixratio, 1=mcrograms/m3" "" - -# Vortex Tracker Variables - -# Revised Centroid Method (tracker #4) -state real distsq ij dyn_nmm 1 - rh "DISTSQ" "Approximate square of distance from nest center for vortex tracker #4" "m2" -state real weightout ij dyn_nmm 1 - rh "WEIGHTOUT" "Vortex center finder weight array for vortex tracker #4" "" -state integer mslp_noisy ij dyn_nmm 1 - rh "MSLP_NOISY" "0=okay, 1=noisy MSLP, 2=outside search radius, 3=boundary (vortex tracker #4)" "" - -# Dynamic Pressure Method (tracker #5) -state real vt5searchrad - dyn_nmm 1 - rh "vt5searchrad" "Search radius from domain center" "m" - -# Smoothed Dynamic Pressure (needed for #5, must be passed down by all) - -state integer pdyn_parent_age - dyn_nmm 1 - rh "PDYN_PARENT_AGE" "Last update of parent pdyn_parent propagated to this nest" "" -state integer pdyn_smooth_age - dyn_nmm 1 - rh "PDYN_SMOOTH_AGE" "Counter of updates of pdyn_smooth" "" -state real pdyn_smooth ij dyn_nmm 1 - rhd=(NoInterp)f=(NoInterp)u=(NoInterp) "PDYN_SMOOTH" "Average of PDYN and PDYN_PARENT" "Pa" -state real pdyn_parent ij dyn_nmm 1 - rhu=(NoInterp)\ -d=(DownAged2D:0,n%pdyn_parent_age,c%pdyn_smooth)\ -f=(DownAged2D:c%pdyn_smooth_age,n%pdyn_parent_age,c%pdyn_smooth)\ - "PDYN_PARENT" "Parent PDYN_SMOOTH for tracking grid motion" "Pa" - - -# Interpolation information -state real winfo ijkb dyn_nmm 1 Z u=(NoInterp)d=(NoInterp) "winfo" "Nest-parent interpolation/extrapolation weight" "" -state integer iinfo ijkb dyn_nmm 1 Z u=(NoInterp)d=(NoInterp) "iinfo" "Nest-parent interpolation index" "" - -# -# table entries are of the form -#
-# -# Mask for moving nest interpolations -state integer imask_nostag ij misc - -state integer imask_xstag ij misc X -state integer imask_ystag ij misc Y -state integer imask_xystag ij misc XY -# -#--------------------------------------------------------------------------------------------------------------------------------- -# SI - start variables from netCDF format from Standard Initialization, most eventually for use in LSM schemes -#--------------------------------------------------------------------------------------------------------------------------------- - -state real sm000007 ij misc 1 - i1 "SM000007" "LAYER SOIL MOISTURE" "m3 m-3" -state real sm007028 ij misc 1 - i1 "SM007028" "LAYER SOIL MOISTURE" "m3 m-3" -state real sm028100 ij misc 1 - i1 "SM028100" "LAYER SOIL MOISTURE" "m3 m-3" -state real sm100255 ij misc 1 - i1 "SM100255" "LAYER SOIL MOISTURE" "m3 m-3" -state real st000007 ij misc 1 - i1 "ST000007" "LAYER SOIL TEMPERATURE" "K" -state real st007028 ij misc 1 - i1 "ST007028" "LAYER SOIL TEMPERATURE" "K" -state real st028100 ij misc 1 - i1 "ST028100" "LAYER SOIL TEMPERATURE" "K" -state real st100255 ij misc 1 - i1 "ST100255" "LAYER SOIL TEMPERATURE" "K" -state real sm000010 ij misc 1 - i1 "SM000010" "description" "units" -state real sm010040 ij misc 1 - i1 "SM010040 " "description" "units" -state real sm040100 ij misc 1 - i1 "SM040100 " "description" "units" -state real sm100200 ij misc 1 - i1 "SM100200 " "description" "units" -state real sm010200 ij misc 1 - i1 "SM010200" "description" "units" -state real soilm000 ij misc 1 - i1 "SOILM000" "description" "units" -state real soilm005 ij misc 1 - i1 "SOILM005" "description" "units" -state real soilm020 ij misc 1 - i1 "SOILM020" "description" "units" -state real soilm040 ij misc 1 - i1 "SOILM040" "description" "units" -state real soilm160 ij misc 1 - i1 "SOILM160" "description" "units" -state real soilm300 ij misc 1 - i1 "SOILM300" "description" "units" -state real sw000010 ij misc 1 - i1 "SW000010" "description" "units" -state real sw010040 ij misc 1 - i1 "SW010040" "description" "units" -state real sw040100 ij misc 1 - i1 "SW040100" "description" "units" -state real sw100200 ij misc 1 - i1 "SW100200" "description" "units" -state real sw010200 ij misc 1 - i1 "SW010200" "description" "units" -state real soilw000 ij misc 1 - i1 "SOILW000" "description" "units" -state real soilw005 ij misc 1 - i1 "SOILW005" "description" "units" -state real soilw020 ij misc 1 - i1 "SOILW020" "description" "units" -state real soilw040 ij misc 1 - i1 "SOILW040" "description" "units" -state real soilw160 ij misc 1 - i1 "SOILW160" "description" "units" -state real soilw300 ij misc 1 - i1 "SOILW300" "description" "units" -state real st000010 ij misc 1 - i1 "ST000010" "description" "units" -state real st010040 ij misc 1 - i1 "ST010040" "description" "units" -state real st040100 ij misc 1 - i1 "ST040100" "description" "units" -state real st100200 ij misc 1 - i1 "ST100200" "description" "units" -state real st010200 ij misc 1 - i1 "ST010200" "description" "units" -state real soilt000 ij misc 1 - i1 "SOILT000" "description" "units" -state real soilt005 ij misc 1 - i1 "SOILT005" "description" "units" -state real soilt020 ij misc 1 - i1 "SOILT020" "description" "units" -state real soilt040 ij misc 1 - i1 "SOILT040" "description" "units" -state real soilt160 ij misc 1 - i1 "SOILT160" "description" "units" -state real soilt300 ij misc 1 - i1 "SOILT300" "description" "units" -state real landmask ij misc 1 - i01rhd=(DownNear) "LANDMASK" "description" "units" -state real topostdv ij misc 1 - i1 "TOPOSTDV" "description" "units" -state real toposlpx ij misc 1 - i1 "TOPOSLPX" "description" "units" -state real toposlpy ij misc 1 - i1 "TOPOSLPY" "description" "units" -state real greenmax ij misc 1 - i1 "GREENMAX" "description" "units" -state real greenmin ij misc 1 - i1 "GREENMIN" "description" "units" -state real albedomx ij misc 1 - i1 "ALBEDOMX" "description" "units" -state real slopecat ij misc 1 - i1 "SLOPECAT" "description" "units" -state real toposoil ij misc 1 - i1d=(DownNear) "TOPOSOIL" "description" "units" -state real landusef iuj misc 1 Z - "" "description" "units" -state real soilctop isj misc 1 Z - "" "description" "units" -state real soilcbot isj misc 1 Z - "" "description" "units" - -#------------------------------------------------------------------------------------------------------------------------------- -# SI - end variables from netCDF format from Standard Initialization -#------------------------------------------------------------------------------------------------------------------------------- - -# Time series variables -state real ts_hour ?! misc - - - "TS_HOUR" "Model integration time, hours" -state real ts_u ?! misc - - - "TS_U" "Surface wind U-component, earth-relative" -state real ts_v ?! misc - - - "TS_V" "Surface wind V-component, earth-relative" -state real ts_q ?! misc - - - "TS_Q" "Surface mixing ratio" -state real ts_t ?! misc - - - "TS_T" "Surface temperature" -state real ts_psfc ?! misc - - - "TS_PSFC" "Surface pressure" -state real ts_tsk ?! misc - - - "TS_TSK" "Skin temperature" -state real ts_tslb ?! misc - - - "TS_TSLB" "Soil temperature" -state real ts_clw ?! misc - - - "TS_CLW" "Column integrated cloud water" - -#----------------------------------------------------------------------------------------------------------------------------------------------------------------- - - -# Moist Scalars - both height and mass coordinate models -# -# The first line ensures that there will be identifiers named moist and -# moist_tend even if there are not any moist scalars (so the essentially -# dry code will will still link properly) -# -state real - ijkfbt moist 1 m - - -state real qv ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QVAPOR" "Water vapor mixing ratio" "kg kg-1" -state real qc ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QCLOUD" "Cloud water mixing ratio" "kg kg-1" -state real qr ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QRAIN" "Rain water mixing ratio" "kg kg-1" -state real qi ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QICE" "Ice mixing ratio" "kg kg-1" -state real qs ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QSNOW" "Snow mixing ratio" "kg kg-1" -state real qg ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QGRAUP" "Graupel mixing ratio" "kg kg-1" -state real qh ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QHAIL" "Hail mixing ratio" "kg kg-1" - - -state real - ijkfbt dfi_moist 1 m - - -state real dfi_qv ijkfbt dfi_moist 1 m r "QVAPOR" "Water vapor mixing ratio" "kg kg-1" -state real dfi_qc ijkfbt dfi_moist 1 m r "QCLOUD" "Cloud water mixing ratio" "kg kg-1" -state real dfi_qr ijkfbt dfi_moist 1 m r "QRAIN" "Rain water mixing ratio" "kg kg-1" -state real dfi_qi ijkfbt dfi_moist 1 m r "QICE" "Ice mixing ratio" "kg kg-1" -state real dfi_qs ijkfbt dfi_moist 1 m r "QSNOW" "Snow mixing ratio" "kg kg-1" -state real dfi_qg ijkfbt dfi_moist 1 m r "QGRAUP" "Graupel mixing ratio" "kg kg-1" -state real dfi_qh ijkfbt dfi_moist 1 m r "QHAIL" "Hail mixing ratio" "kg kg-1" -state real dfi_qnh ijkfbt dfi_moist 1 m r "QNHAIL" "Hail Number concentration" "# kg(-1)" - - -# -# Other Scalars -state real - ijkftb scalar 1 m - - -state real qni ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNICE" "Ice Number concentration" "# kg(-1)" -state real qt ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QT" "Total condensate mixing ratio" "kg kg-1" -state real qns ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNSNOW" "Snow Number concentration" "# kg(-1)" -state real qnr ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNRAIN" "Rain Number concentration" "# kg(-1)" -state real qng ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNGRAUP" "Graupel Number concentration" "# kg(-1)" -state real qnh ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNHAIL" "Hail Number concentration" "# kg(-1)" -state real qnn ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCCN" "CCN Number concentration" "# kg(-1)" -state real qnc ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" -state real qvolg ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" -state real qnwfa ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" -state real qnifa ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" - - -state real - ijkftb dfi_scalar 1 m - - -state real dfi_qndrop ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNDROP" "DFI Droplet number mixing ratio" "# kg-1" -state real dfi_qni ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNICE" "DFI Ice Number concentration" "# kg-1" -state real dfi_qt ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_CWM" "DFI Total condensate mixing ratio" "kg kg-1" -state real dfi_qns ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNSNOW" "DFI Snow Number concentration" "# kg(-1)" -state real dfi_qnr ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNRAIN" "DFI Rain Number concentration" "# kg(-1)" -state real dfi_qng ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNGRAUPEL" "DFI Graupel Number concentration" "# kg(-1)" -state real dfi_qnn ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNCC" "DFI CNN Number concentration" "# kg(-1)" -state real dfi_qnc ijkftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "DFI Cloud Number concentration" "# kg(-1)" -state real dfi_qnwfa ikjftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNWFA" "DFI water-friendly aerosol number con" "# kg(-1)" -state real dfi_qnifa ikjftb dfi_scalar 1 m \ - rusdf=(bdy_interp:dt) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" - -#----------------------------------------------------------------------------------------------------------------------------------------------------------------- - -## Chem Scalars - both height and mass coordinate models -# -state real - ikjft chem 1 - - - - -#----------------------------------------------------------------------------------------------------------------------------------------------------------------- - -# specified LBC arrays, first, Eulerian height coordinate model - - -# specified LBC arrays, next, Eulerian mass coordinate model - - -# specified LBC variables shared between the mass and height coordinate models - - -# soil model variables (Note that they are marked as staggered in the vertical dimension -# because they are "fully dimensioned" -- they use every element in that dim - - -# 2m and 10m output diagnostics - - -# lsm State Variables - -state real SMOIS ilj - 1 Z rh "SMOIS" "SOIL MOISTURE" "" -state real TSLB ilj - 1 Z r "TSLB" "SOIL TEMPERATURE" "" -state real lake_depth ij misc 1 - rd=(interp_mask_water_field:lu_index,iswater) "lake_depth" "lake depth" "m" - - -# MYJ PBL variables - - -# gfdl (eta) radiation State Variables - -# eta microphpysics State Variables - - -# new eta microphpysics State Variables - -# some mass-coordinate-model-specific variables - - - - - - -# was em_only - -################################################################# -# Physics Variables (em core) - - - -################################################################# -# Physics Variables (eh core) ; should be same as em - - - - -################################################################# -# variables added for CHEMISTRY compatibility with ARW core - kludge -################################################################# -state real GSW ij misc 1 - - "" "" -state real XLAT ij misc 1 - - "" "" -state real XLONG ij misc 1 - - "" "" -state real XLAND ij misc 1 - - "" "" -state real RAINCV ij misc 1 - - "" "" - -################################################################# -# HWRF nest movement variables -################################################################# - -# Duplicate of nomove_freq for overriding nest movement at certain times -state real nomove_freq_hr - dyn_nmm - - rh "nomove_freq" "nest will not move at analysis time or multiples of this hour (if positive)" -state integer move_countdown - dyn_nmm 1 - rh "MOVE_COUNTDOWN" "Timesteps left with extra CODAMP" "" - - - -################################################################# -# other misc variables (all cores) -################################################################# - -# added for surface_driver -state real PSFC ij misc 1 - i1rh "PSFC" "SFC PRESSURE" -state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" -state real TH2 ij misc 1 - irh "TH2" "POT TEMP at 2 M" "" -state real T2 ij misc 1 - ir "T2" "TEMP at 2 M" "" -state real U10 ij misc 1 - irh01d=(DownCopy) "U10" "U at 10 M" " " -state real V10 ij misc 1 - irh01d=(DownCopy) "V10" "V at 10 M" " " -state real XICE ij misc 1 - i01rd=(DownNear) "XICE" "SEA ICE" "" -state real ICEDEPTH ij misc 1 - i0124rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ICEDEPTH" "SEA ICE THICKNESS" "m" -state real ALBSI ij misc 1 - i0124rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ALBSI" "SEA ICE ALBEDO" " " -state real SNOWSI ij misc 1 - i0124rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SNOWSI" "SNOW DEPTH ON SEA ICE" "m" -state real LAI ij misc 1 - i0124rh "LAI" "Leaf area index" "area/area" -state real SMSTAV ij misc 1 - irh "SMSTAV" "MOISTURE VARIBILITY" "" -state real SMSTOT ij misc 1 - irh "SMSTOT" "TOTAL SOIL MOISTURE" "" -state real SOLDRAIN ij misc 1 - r "SOLDRAIN" "soil column drainage" "mm" -state real SFCHEADRT ij misc 1 - r "SFCHEADRT" "surface water depth" "mm" -state real INFXSRT ij misc 1 - r "INFXSRT" "time step infiltration excess" "mm" -state real SFCRUNOFF ij misc 1 - rh "SFROFF" "SURFACE RUNOFF" "" -state real UDRUNOFF ij misc 1 - rh "UDROFF" "UNDERGROUND RUNOFF" "" -state integer IVGTYP ij misc 1 - irh02d=(DownINear) "IVGTYP" "VEGETATION TYPE" "" -state integer ISLTYP ij misc 1 - irh02d=(DownINear) "ISLTYP" "SOIL TYPE" " " -state real VEGFRA ij misc 1 - i014rh02d=(DownNear) "VEGFRA" "VEGETATION FRACTION" "" -state real SFCEVP ij misc 1 - irh "SFCEVP" "SURFACE EVAPORATION" "" -state real GRDFLX ij misc 1 - irh "GRDFLX" "GROUND HEAT FLUX" "" -state real ALBBCK ij misc 1 - i0124r "ALBBCK" "BACKGROUND ALBEDO" "NA" -state real SFCEXC ij misc 1 - irh "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" -state real SNOTIME ij misc 1 - r "SNOTIME" "SNOTIME" "" -state real ACSNOW ij misc 1 - irh "ACSNOW" "ACCUMULATED SNOW" "kg m-2" -state real ACSNOM ij misc 1 - irh "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" -state real RMOL ij misc 1 - ir "RMOL" "" "" -state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" -state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" -state integer FORCE_SST k misc 1 - - "FORCE_SST" "IF FORCE_SST(1) IS 1, FEED SST FROM PARENT EVERY DT" "" -state real SST ij misc 1 - i014rh02d=(DownNear)f=(force_sst_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,FORCE_SST) "SST" "SEA SURFACE TEMPERATURE" "K" -state real UOCE ij misc 1 - i014rh "UOCE" "SEA SURFACE ZONAL CURRENTS" "m s-1" -state real VOCE ij misc 1 - i014rh "VOCE" "SEA SURFACE MERIDIONAL CURRENTS" "m s-1" -state real WEASD ij misc 1 - i01rhd=(DownNear) "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "kg m-2" -state real ZNT ij misc 1 - irh "ZNT" "TIME-VARYING ROUGHNESS LENGTH" -state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" -state real NOAHRES ij misc 1 - rh "NOAHRES" "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}" - -state real tke_pbl ijk misc 1 Z r "TKE_PBL" "TKE FROM PBL SCHEME" "m2 s-2" -state real el_pbl ikj misc 1 Z - "EL_PBL" "MIXING LENGTH FROM PBL SCHEME" "m" -state real EXCH_H ikj misc 1 Z r "EXCH_H" "EXCHANGE COEFFICIENTS FOR HEAT" "m2 s-1" -state real EXCH_M ikj misc 1 Z r "EXCH_M" "EXCHANGE COEFFICIENTS FOR MOMENTUM" "m2 s-1" -state real THZ0 ij misc 1 - irhd=(DownCopy) "THZ0" "POT. TEMPERATURE AT TOP OF VISC. SUBLYR" "K" -state real QZ0 ij misc 1 - irhd=(DownCopy) "QZ0" "SPECIFIC HUMIDITY AT TOP OF VISC. SUBLYR" "kg kg-1" -state real UZ0 ij misc 1 - irhd=(DownVel) "UZ0" "U WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" -state real VZ0 ij misc 1 - irhd=(DownVel) "VZ0" "V WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" -state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" -state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" -state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" -state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" -state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" -state real DEW ij misc 1 - r "DEW" "DEW MIXING RATIO AT THE SURFACE" "kg kg-1" -state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" -state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" -# added as state for HALO_NMM_MG2, mep -state real psfc_out ij dyn_nmm 1 - - -# added as state for HALO_NMM_TURBL, jm -state real UZ0h ij misc 1 - - -state real VZ0h ij misc 1 - - -state real dudt ijk misc 1 - - -state real dvdt ijk misc 1 - - - -state real QSFC ij misc 1 - irh "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" -state real AKHS ij misc 1 - ir "AKHS" "SFC EXCH COEFF FOR HEAT /DELTA Z" "m s-1" -state real AKMS ij misc 1 - ir "AKMS" "SFC EXCH COEFF FOR MOMENTUM /DELTA Z" "m s-1" -i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" -state real HTOP ij misc 1 - irhd=(DownNear) "HTOP" "TOP OF CONVECTION LEVEL" "" -state real HBOT ij misc 1 - irhd=(DownNear) "HBOT" "BOT OF CONVECTION LEVEL" "" -state real HTOPR ij misc 1 - ird=(DownNear) "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" -state real HBOTR ij misc 1 - ird=(DownNear) "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" -state real HTOPD ij misc 1 - rh "HTOPD" "TOP DEEP CONVECTION LEVEL" "" -state real HBOTD ij misc 1 - rh "HBOTD" "BOT DEEP CONVECTION LEVEL" "" -state real HTOPS ij misc 1 - rh "HTOPS" "TOP SHALLOW CONVECTION LEVEL" "" -state real HBOTS ij misc 1 - rh "HBOTS" "BOT SHALLOW CONVECTION LEVEL" "" -state REAL CUPPT ij misc 1 - rhd=(DownNear) "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINCE LAST CALL TO THE RADIATION" "" -state REAL CPRATE ij misc 1 - rh "CPRATE" "INSTANTANEOUS CONVECTIVE PRECIPITATION RATE" "" # 1-17-06a -state real F_ICE_PHY ikj misc 1 - - "F_ICE_PHY" "FRACTION OF ICE" "" -state real F_RAIN_PHY ikj misc 1 - - "F_RAIN_PHY" "FRACTION OF RAIN " "" -state real F_RIMEF_PHY ikj misc 1 - - "F_RIMEF_PHY" "MASS RATIO OF RIMED ICE " "" -state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb/hour" -state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL " "mm/hour" -state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W " "mm/hour" -state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm/hour" -state real apr_st ij misc 1 - r "APR_ST" "PRECIP FROM CLOSURE STABILITY " "mm/hour" -state real apr_as ij misc 1 - r "APR_AS" "PRECIP FROM CLOSURE AS-TYPE " "mm/hour" -state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm/hour" -state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm/hour" -state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm/hour" -state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" -state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" - -state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TOTAL ADVECTIVE POTENTIAL TEMPERATURE TENDENCY" "K s-1" -state real RQVFTEN ikj misc 1 - r "RQVFTEN" "TOTAL ADVECTIVE MOISTURE TENDENCY" "kg kg-1 s-1" -state real SNOWH ij misc 1 - i01rhd=(DownCopy) "SNOWH" "PHYSICAL SNOW DEPTH" "m" -state real RHOSN ij misc 1 - i01rd=(DownCopy) "RHOSN" " SNOW DENSITY" "kg m-3" -state real SMFR3D ilj misc 1 Z rh "SMFR3D" "SOIL ICE" "" -state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" -state real rc_mf ikj misc 1 - r "RC_MF" "RC IN THE GRID COMPUTED BY EDKF" "kg/kg" - -# For Noah-MP -rconfig integer dveg namelist,noah_mp 1 4 h "dveg" "dynamic vegetation (1 -> off ; 2 -> on)" "" -rconfig integer opt_crs namelist,noah_mp 1 1 h "opt_crs" "canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis)" "" -rconfig integer opt_btr namelist,noah_mp 1 1 h "opt_btr" "soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB)" "" -rconfig integer opt_run namelist,noah_mp 1 1 h "opt_run" "runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS)" "" -rconfig integer opt_sfc namelist,noah_mp 1 1 h "opt_sfc" "surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97)" "" -rconfig integer opt_frz namelist,noah_mp 1 1 h "opt_frz" "supercooled liquid water (1-> NY06; 2->Koren99)" "" -rconfig integer opt_inf namelist,noah_mp 1 1 h "opt_inf" "frozen soil permeability (1-> NY06; 2->Koren99)" "" -rconfig integer opt_rad namelist,noah_mp 1 3 h "opt_rad" "radiation transfer (1->gap=F(3D,cosz); 2->gap=0; 3->gap=1-Fveg)" "" -rconfig integer opt_alb namelist,noah_mp 1 2 h "opt_alb" "snow surface albedo (1->BATS; 2->CLASS)" "" -rconfig integer opt_snf namelist,noah_mp 1 1 h "opt_snf" "rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah)" "" -rconfig integer opt_tbot namelist,noah_mp 1 2 h "opt_tbot" "lower boundary of soil temperature (1->zero-flux; 2->Noah)" "" -rconfig integer opt_stc namelist,noah_mp 1 1 h "opt_stc" "soil/snow temperature time scheme 1->semi-implicit; 2->full-implicit (original Noah)" "" - -# For WRF Hydro -rconfig integer wrf_hydro derived 1 0 h "wrf_hydro" "descrip" "unit" - -# For Noah UA changes -state real flx4 ij - 1 - h "FLX4" "sensible heat from canopy" "W m{-2}" -state real fvb ij - 1 - h "FVB" "fraction of vegetation with snow below" "" -state real fbur ij - 1 - h "FBUR" "fraction of vegetation covered by snow" "" -state real fgsn ij - 1 - h "FGSN" "fraction of ground covered by snow" "" - -# For Noah-MP -state integer isnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "isnow" "no. of snow layer" "m3 m-3" -state real tvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tv" "vegetation leaf temperature" "K" -state real tgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tg" "bulk ground temperature" "K" -state real canicexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "canice" "intercepted ice mass" "mm" -state real canliqxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "canliq" "intercepted liquid water" "mm" -state real eahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "eah" "canopy air vapor pressure" "pa" -state real tahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tah" "canopy air temperature" "K" -state real cmxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "cm" "surf. exchange coeff. for momentum" "m/s" -state real chxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ch" "surf. exchange coeff. for heat" "m/s" -state real fwetxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fwet" "wetted or snowed canopy fraction" "-" -state real sneqvoxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sneqvo" "snow mass at last time step" "mm" -state real alboldxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "albold" "snow albedo at last timestep" "-" -state real qsnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "qsnowxy" "snowfall on the ground" "mm/s" -state real wslakexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wslake" "lake water storage" "mm" -state real zwtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "zwt" "water table depth" "m" -state real waxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wa" "water in the acquifer" "mm" -state real wtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wt" "groundwater storage" "mm" -state real tsnoxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tsno" "snow temperature" "K" -state real zsnsoxy i{snsl}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "zsnso" "layer-bottom depth from snow surf" "m" -state real snicexy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "snice" "snow layer ice" "mm" -state real snliqxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "snliq" "snow layer liquid" "mm" -state real lfmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "lfmass" "leaf mass" "g/m2" -state real rtmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rtmass" "mass of fine roots" "g/m2" -state real stmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "stmass" "stem mass" "g/m2" -state real woodxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wood" "mass of wood" "g/m2" -state real stblcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "stblcp" "stable carbon pool" "g/m2" -state real fastcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fastcp" "short-lived carbon" "g/m2" -state real xsaixy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "xsai" "stem area index" "-" -state real taussxy ij - 1 - rh "tauss" "non-dimensional snow age" "" -state real t2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "t2v" "2 meter temperature over canopy" "K" -state real t2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "t2b" "2 meter temperature over bare ground" "K" -state real q2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "q2v" "2 meter mixing ratio over canopy" "kg kg-1" -state real q2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "q2b" "2 meter mixing ratio over bare ground" "kg kg-1" -state real tradxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "trad" "surface radiative temperature" "K" -state real neexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "nee" "net ecosystem exchange" "g/m2/s CO2" -state real gppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "gpp" "gross primary productivity" "g/m2/s C" -state real nppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "npp" "net primary productivity" "g/m2/s C" -state real fvegxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fveg" "Noah-MP vegetation fraction" "" -state real qinxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "qin" "groundwater recharge" "mm/s" -state real runsfxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "runsf" "surface runoff" "mm/s" -state real runsbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "runsb" "subsurface runoff" "mm/s" -state real ecanxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ecan" "evaporation of intercepted water" "mm/s" -state real edirxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "edir" "ground surface evaporation rate" "mm/s" -state real etranxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "etran" "transpiration rate" "mm/s" -state real fsaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fsa" "total absorbed solar radiation" "W/m2" -state real firaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fira" "total net longwave rad" "W/m2" -state real aparxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "apar" "photosyn active energy by canopy" "W/m2" -state real psnxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "psn" "total photosynthesis" "umol co2/m2/s" -state real savxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sav" "solar rad absorbed by veg" "W/m2" -state real sagxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sag" "solar rad absorbed by ground" "W/m2" -state real rssunxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rssun" "sunlit stomatal resistance" "s/m" -state real rsshaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rssha" "shaded stomatal resistance" "s/m" -state real bgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "bgap" "between canopy gap" "fraction" -state real wgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wgap" "within canopy gap" "fraction" -state real tgvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tgv" "ground temp. under canopy""K" -state real tgbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tgb" "bare ground temperature" "K" -state real chvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv" "vegetated heat exchange coefficient" "m/s" -state real chbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb" "bare-ground heat exchange coefficient" "m/s" -state real shgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shg" "sensible heat flux: ground to canopy" "W/m2" -state real shcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shc" "sensible heat flux: leaf to canopy" "W/m2" -state real shbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shb" "sensible heat flux: bare grnd to atmo" "W/m2" -state real evgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evg" "latent heat flux: ground to canopy" "W/m2" -state real evbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evb" "latent heat flux: bare grnd to atmo" "W/m2" -state real ghvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ghv" "heat flux into soil: under canopy" "W/m2" -state real ghbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ghb" "heat flux into soil: bare fraction" "W/m2" -state real irgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irg" "net longwave at below canopy surface" "W/m2" -state real ircxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irc" "net longwave in canopy" "W/m2" -state real irbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irb" "net longwave at bare fraction surface" "W/m2" -state real trxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tr" "transpiration" "W/m2" -state real evcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evc" "canopy evaporation" "W/m2" -state real chleafxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chleaf" "leaf exchange coefficient" "m/s" -state real chucxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chuc" "under canopy exchange coefficient" "m/s" -state real chv2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv2" "leaf exchange coefficient" "m/s" -state real chb2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb2" "under canopy exchange coefficient" "m/s" -state real chstarxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chstar" "dummy exchange coefficient" "m/s" -state real SMOISEQ ilj - 1 Z r "SMOISEQ" "EQ. SOIL MOISTURE" "m3 m-3" -state real smcwtdxy ij - 1 - rh "smcwtd" "deep soil moisture " "m3 m-3" -state real rechxy ij - 1 - h "rech" "water table recharge" "mm" -state real deeprechxy ij - 1 - r "deeprech" "deep water table recharge" "mm" - -# added state for etampnew microphysics (needed for restarts) -state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" -state real tbpvs_state p misc 1 - r "TBPVS_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" -state real tbpvs0_state p misc 1 - r "TBPVS0_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" - -# State variables for landuse_init, Must be declared state because the are read in and needed for restarts. Had been SAVE vars in -# landuse_init (phys/module_physics_init.F) -state integer landuse_isice - misc - - - -state integer landuse_lucats - misc - - - -state integer landuse_luseas - misc - - - -state integer landuse_isn - misc - - - -state real lu_state p misc - - - - - -################################################################# -# - -state integer number_at_same_level - - - - - "number_at_same_level" "" "" -state real power ij misc 1 - irh "Power" "Power production" "W" - -# State for derived time quantities. -#for HWRF: add to restart -state integer itimestep - - - - rh "itimestep" "" "" -state real xtime - - - - h "xtime" "minutes since simulation start" "" -state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" - -# input file descriptor for lbcs on parent domain -state integer lbc_fid - - - - - "lbc_fid" "" "" - -# indicates if tiling has been computed -state logical tiled - - - - - "tiled" "" "" -# indicates if patches have been computed -state logical patched - - - - - "patched" "" "" -# indicates whether to read input from file or generate -#state logical input_from_file - - - - - "input_from_file" "" "" - -# vortex center indices; need for restarts of moving nests -state real xi - misc - - r -state real xj - misc - - r -state real vc_i - misc - - r -state real vc_j - misc - - r - -###### -# -# Variables that are set at run-time to control configuration (namelist-settable) -# -#
- - -# Time Control -rconfig integer run_days namelist,time_control 1 0 irh "run_days" "NUMBER OF DAYS TO RUN" -rconfig integer run_hours namelist,time_control 1 0 irh "run_hours" "NUMBER OF HOURS TO RUN" -rconfig integer run_minutes namelist,time_control 1 0 irh "run_minutes" "NUMBER OF MINUTES TO RUN" -rconfig integer run_seconds namelist,time_control 1 0 irh "run_seconds" "NUMBER OF SECONDS TO RUN" -rconfig integer start_year namelist,time_control max_domains 1993 irh "start_year" "4 DIGIT YEAR OF START OF MODEL" "YEARS" -rconfig integer start_month namelist,time_control max_domains 03 irh "start_month" "2 DIGIT MONTH OF THE YEAR OF START OF MODEL, 1-12" "MONTHS" -rconfig integer start_day namelist,time_control max_domains 13 irh "start_day" "2 DIGIT DAY OF THE MONTH OF START OF MODEL, 1-31" "DAYS" -rconfig integer start_hour namelist,time_control max_domains 12 irh "start_hour" "2 DIGIT HOUR OF THE DAY OF START OF MODEL, 0-23" "HOURS" -rconfig integer start_minute namelist,time_control max_domains 00 irh "start_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF MODEL, 0-59" "MINUTES" -rconfig integer start_second namelist,time_control max_domains 00 irh "start_second" "2 DIGIT SECOND OF THE MINUTE OF START OF MODEL, 0-59" "SECONDS" -rconfig integer end_year namelist,time_control max_domains 1993 irh "end_year" "4 DIGIT YEAR OF END OF MODEL" "YEARS" -rconfig integer end_month namelist,time_control max_domains 03 irh "end_month" "2 DIGIT MONTH OF THE YEAR OF END OF MODEL, 1-12" "MONTHS" -rconfig integer end_day namelist,time_control max_domains 14 irh "end_day" "2 DIGIT DAY OF THE MONTH OF END OF MODEL, 1-31" "DAYS" -rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" -rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" -rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" -rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" -rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" -rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 11, WHAT INPUT STREAM IS FINE GRID IC FROM" "" - -include registry.io_boilerplate - -#for HWRF: added a 'r' for restart -rconfig integer JULYR namelist,time_control max_domains 0 hr "JULYR" "" "" -rconfig integer JULDAY namelist,time_control max_domains 1 hr "JULDAY" "" "" -rconfig real GMT namelist,time_control max_domains 0. hr "GMT" "" "" -#for HWRF: end -rconfig character high_freq_outname namelist,time_control 1 "hifreq_d.htcf" - "name of hifreq output file" "" "" -rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" -rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" -rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" -rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" -rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" -rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" -#for HWRF: -rconfig character anl_outname namelist,time_control max_domains "wrfanl_d_" - "name of analysis outfile" "" "" -rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" -rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" -rconfig logical write_hist_at_0h_rst namelist,time_control 1 .false. h "write_hist_at_0h_rst" "T/F write hist at 0 h of restarted forecast" -rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" -rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" -rconfig real tstart namelist,time_control max_domains 0. irh "tstart" "forecast hour at the start of the NMM integration" -rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" -rconfig logical cycling namelist,time_control 1 .false. - "true for cycling (using wrfout file as input data)" - -# DFI namelist -rconfig integer dfi_opt namelist,dfi_control 1 0 rh "dfi_opt" "" "" -rconfig integer dfi_nfilter namelist,dfi_control 1 7 rh "dfi_nfilter" "Digital filter type" "" -rconfig logical dfi_write_filtered_input namelist,dfi_control 1 .true. rh "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?" "" -rconfig logical dfi_write_dfi_history namelist,dfi_control 1 .false. rh "dfi_write_dfi_history" "Write history files during filtering?" "" -rconfig integer dfi_cutoff_seconds namelist,dfi_control 1 3600 rh "dfi_cutoff_seconds" "Digital filter cutoff time" "" -rconfig integer dfi_time_dim namelist,dfi_control 1 1000 rh "dfi_time_dim" "MAX DIMENSION FOR HCOEFF" -rconfig integer dfi_fwdstop_year namelist,dfi_control 1 2004 rh "dfi_fwdstop_year" "4 DIGIT YEAR OF START OF DFI" "YEARS" -rconfig integer dfi_fwdstop_month namelist,dfi_control 1 03 rh "dfi_fwdstop_month" "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS" -rconfig integer dfi_fwdstop_day namelist,dfi_control 1 13 rh "dfi_fwdstop_day" "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS" -rconfig integer dfi_fwdstop_hour namelist,dfi_control 1 12 rh "dfi_fwdstop_hour" "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS" -rconfig integer dfi_fwdstop_minute namelist,dfi_control 1 00 rh "dfi_fwdstop_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES" -rconfig integer dfi_fwdstop_second namelist,dfi_control 1 00 rh "dfi_fwdstop_second" "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS" -rconfig integer dfi_bckstop_year namelist,dfi_control 1 2004 rh "dfi_bckstop_year" "4 DIGIT YEAR OF END OF DFI" "YEARS" -rconfig integer dfi_bckstop_month namelist,dfi_control 1 03 rh "dfi_bckstop_month" "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS" -rconfig integer dfi_bckstop_day namelist,dfi_control 1 14 rh "dfi_bckstop_day" "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS" -rconfig integer dfi_bckstop_hour namelist,dfi_control 1 12 rh "dfi_bckstop_hour" "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS" -rconfig integer dfi_bckstop_minute namelist,dfi_control 1 00 rh "dfi_bckstop_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES" -rconfig integer dfi_bckstop_second namelist,dfi_control 1 00 rh "dfi_bckstop_second" "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS" - -# Domains -rconfig integer time_step namelist,domains 1 - ih "time_step" -rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" -rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" -rconfig integer time_step_dfi namelist,domains 1 - ih "time_step_dfi" -rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" -rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" -rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" -rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" -rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" -rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" -rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" -rconfig integer num_metgrid_soil_levels namelist,domains 1 4 irh "num_metgrid_soil_levels" "number of input levels or layers in 3D sm, st, sw arrays" "" -rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" -rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" -rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" -rconfig logical grid_allowed namelist,domains max_domains .true. irh "allowed" "" "" -rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" -rconfig integer i_parent_start namelist,domains max_domains 1 h "i_parent_start" "" "" -rconfig integer j_parent_start namelist,domains max_domains 1 h "j_parent_start" "" "" -rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" -rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" -rconfig integer feedback namelist,domains 1 0 h "feedback" "" "" -rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" -rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" -rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" -rconfig integer moad_time_step_ratio namelist,domains max_domains 1 h "moad_time_step_ratio" "" "" -rconfig integer shw namelist,domains max_domains 2 h "stencil_half_width" "HORIZONTAL INTERPOLATION STENCIL HALF-WIDTH" "GRID POINTS" -rconfig integer tile_sz_x namelist,domains 1 0 - "tile_sz_x" "" "" -rconfig integer tile_sz_y namelist,domains 1 0 - "tile_sz_y" "" "" -rconfig integer numtiles namelist,domains 1 1 - "numtiles" "" "" -rconfig integer numtiles_inc namelist,domains 1 0 - "numtiles_inc" "" "" -rconfig integer numtiles_x namelist,domains 1 0 - "numtiles_x" "" "" -rconfig integer numtiles_y namelist,domains 1 0 - "numtiles_y" "" "" -rconfig integer tile_strategy namelist,domains 1 0 - "tile_strategy" "" "" -rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" -rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" -rconfig integer irand namelist,domains 1 0 - "irand" "" "" -rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" -rconfig integer ts_buf_size namelist,domains 1 200 - "ts_buf_size" "Size of time series buffer" -rconfig integer max_ts_locs namelist,domains 1 5 - "max_ts_locs" "Maximum number of time series locations" -rconfig integer num_moves namelist,domains 1 0 -rconfig integer vortex_interval namelist,domains max_domains 15 - "" "" "minutes" -rconfig integer corral_dist namelist,domains max_domains 8 -rconfig integer move_id namelist,domains max_moves 0 -rconfig integer move_interval namelist,domains max_moves 999999999 -rconfig integer move_cd_x namelist,domains max_moves 0 -rconfig integer move_cd_y namelist,domains max_moves 0 -rconfig logical swap_x namelist,domains max_domains .false. rh "swap_x" "" "" -rconfig logical swap_y namelist,domains max_domains .false. rh "swap_y" "" "" -rconfig logical cycle_x namelist,domains max_domains .false. rh "cycle_x" "" "" -rconfig logical cycle_y namelist,domains max_domains .false. rh "cycle_y" "" "" -rconfig logical reorder_mesh namelist,domains 1 .false. rh "reorder_mesh" "" "" -rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" -# WPS related -rconfig real eta_levels namelist,domains max_eta -1. -rconfig real ptsgm namelist,domains 1 42000. -rconfig integer num_metgrid_levels namelist,domains 1 43 irh "num_metgrid_levels" "" "" -rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" -rconfig logical use_prep_hybrid namelist,domains 1 .false. irh "T=GFS spectral sigma files were used" "" "" - -# Physics -rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" -#for HWRF: -rconfig real mommix namelist,physics max_domains 0.7 irh "MOMENTUM MIXING FOR SAS CONVECTION SCHEME" -rconfig logical disheat namelist,physics max_domains .true. irh "nmm input 7" -#end HWRF: -rconfig integer do_radar_ref namelist,physics 1 0 rh "compute radar reflectivity for a number of schemes" -rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" -rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" -rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" -rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" -rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" -rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" -rconfig integer windfarm_opt namelist,physics max_domains 0 rh "windfarm_opt" "" "" -rconfig integer windfarm_ij namelist,physics 1 0 rh "windfarm_ij" "" "" -rconfig integer mfshconv namelist,physics max_domains 1 rh "mfshconv" "To activate mass flux scheme with qnse, 1=true; 0=false" "" -rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" -rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" -rconfig integer shcu_physics namelist,physics max_domains 0 rh "shcu_physics" "" "" -rconfig integer cu_diag namelist,physics max_domains 0 rh "cu_diag" " additional t-averaged stuff for cuphys" "" - -rconfig integer vortex_tracker namelist,physics max_domains 6 - "vortex_tracker" "Vortex Tracking Algorithm" "" -rconfig real gfs_alpha namelist,physics max_domains 1 irh "boundary depth factor" "" "" - -rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" -rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" -rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" -rconfig integer IFSNOW namelist,physics 1 1 irh "IFSNOW" "" "" -rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" -rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" -rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" -rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" -rconfig integer num_urban_layers namelist,physics 1 400 irh "num_urban_layers" "" "" -rconfig integer sf_surface_mosaic namelist,physics 1 0 rh "sf_surface_mosaic" "1= mosaic, 0=no mosaic method, add by danli" "" -rconfig integer mosaic_cat namelist,physics 1 3 rh "mosaic_cat" "works when sf_surface_mosaic=1; it is the number of mosaic tiles" "" -rconfig integer mosaic_cat_soil derived 1 12 rh "mosaic_cat_soil" "should be the number of soil layers times the mosaic_cat" "" -rconfig integer num_urban_hi namelist,physics 1 15 irh "num_urban_hi" "" "" -rconfig integer mosaic_lu namelist,physics 1 0 irh "mosaic_lu" "" "" -rconfig integer mosaic_soil namelist,physics 1 0 irh "mosaic_soil" "" "" -rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" -rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" -rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" -rconfig integer maxens3 namelist,physics 1 16 irh "maxens3" "" "" -rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" -rconfig integer chem_opt namelist,physics max_domains 0 rh "chem_opt" "" "" -rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" -rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" -rconfig integer topo_wind namelist,physics max_domains 0 - "topo_wind" "2: Use Mass sfc drag scheme, 1: improve effects topography over surface wind, 0:not" "" -rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" -rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" -rconfig real seaice_threshold namelist,physics 1 100 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" -rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seiace" "Fractional sea-ice option" -rconfig integer seaice_albedo_opt namelist,physics 1 0 - "seaice_albedo_opt" "Method for setting albedo over sea ice" -rconfig real seaice_albedo_default namelist,physics 1 0.65 - "seaice_albedo_default" "Default value for sea-ice over albedo with seaice_albeo_opt=0" -rconfig integer seaice_snowdepth_opt namelist,physics 1 0 - "seaice_snowdepth_opt" "Method for treating snow depth on sea ice" -rconfig real seaice_snowdepth_max namelist,physics 1 1.E10 - "seaice_snowdepth_max" "Maximum allowed accumulation (m) of snow on sea ice" -rconfig real seaice_snowdepth_min namelist,physics 1 0.001 - "seaice_snowdepth_min" "Minimum snow depth (m) on sea ice" -rconfig integer seaice_thickness_opt namelist,physics 1 0 - "seaice_thickness_opt" "Method for setting sea-ice thickness" -rconfig real seaice_thickness_default namelist,physics 1 3.0 - "seaice_thickness_default" "Default value for sea-ice thickness" -rconfig logical tice2tsk_if2cold namelist,physics 1 .false. - "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent" -rconfig integer sst_update namelist,physics 1 0 i01rh "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" -rconfig integer sf_urban_physics namelist,physics max_domains 0 h "sf_urban_physics" "activate urban model 0=no, 1=Noah_UCM 2=BEP_UCM" "" -rconfig logical usemonalb namelist,physics 1 .true. h "usemonalb" "use 2d field vs table values false=table, True=2d" "" -rconfig logical rdmaxalb namelist,physics 1 .true. h "rdmaxalb" "false set it to table values" "" -rconfig logical rdlai2d namelist,physics 1 .false. h "rdlai2d" "false set it to table values" "" -rconfig logical ua_phys namelist,physics 1 .false. h "ua_phys" "activate UA Noah changes" "" -rconfig integer gwd_opt namelist,physics max_domains 2 irh "gwd_opt" "activate gravity wave drag: 0=off, 1=ARW, 2=NMM" "" -rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" -rconfig real sas_pgcon namelist,physics max_domains 0.55 irh "sas_pgcon" "convectively forced pressure gradient factor (SAS scheme)" "" -rconfig real sas_shal_pgcon namelist,physics max_domains -1 irh "sas_shal_pgcon" "convectively forced pressure gradient factor, -1 means use sas_pgcon (SAS shallow conv)" "" -rconfig integer sas_shal_conv namelist,physics max_domains 1 - "sas_shal_conv" "1=enable shallow convection in SAS (must use bl_pbl_physics=83)" -rconfig real sas_mass_flux namelist,physics max_domains 9e9 - "sas_mass_flux" "mass flux limit (SAS scheme)" "" -rconfig real var_ric namelist,physics 1 1. - "1: use variable Ric 0: constant Ric" -rconfig real coef_ric_l namelist,physics 1 0.16 - "Regression coeff for Ric 0.16:origianl value over land" -rconfig real coef_ric_s namelist,physics 1 0.16 - "Regression coeff for Ric 0.16:origianl value OVER SEA" -rconfig integer random_seed namelist,physics max_domains 0 irh "random_seed" "random number generator seed" - - -# Vortex Tracking (physics namelist) -rconfig integer vortex_tracker namelist,physics max_domains 1 - "vortex_tracker" "Vortex Tracking Algorithm" "" -# Only for algorithm 4: -rconfig real vt4_radius namelist,physics max_domains 150000. - "vt4_radius" "Vortex Search Radius for vortex tracker #4" "m" -rconfig real vt4_weightexp namelist,physics max_domains 1. - "vt4_weightexp" "Vortex Search Weight Exponent for vortex tracker #4" "" -rconfig real vt4_pmax namelist,physics max_domains -1. - "vt4_pmax" "Vortex Search Max Pressure for vortex tracker #4 (<0 = actual max pressure in search radius)" "Pa" - -rconfig real vt4_noise_pmax namelist,physics max_domains 103000. - "vt4_noise_pmax" "Noise Removal: Maximum Realistic MSLP" "Pa" -rconfig real vt4_noise_pmin namelist,physics max_domains 85000. - "vt4_noise_pmin" "Noise Removal: Minimum Realistic MSLP" "Pa" -rconfig real vt4_noise_dpdr namelist,physics max_domains 0.6 - "vt4_noise_dpdr" "Noise Removal: Maximum Realistic dMSLP/dr" "Pa/m" -rconfig integer vt4_noise_iter namelist,physics max_domains 2 - "vt4_noise_iter" "Noise Removal: number of iterations" "" - - -# nmm variables -rconfig integer idtad namelist,physics max_domains 2 irh "idtad" "fundamental timesteps between calls to NMM passive advection scheme" -rconfig integer nsoil namelist,physics max_domains 4 irh "nsoil" "number of soil layers" -rconfig integer nphs namelist,physics max_domains 10 irh "nphs" "fundamental timesteps between calls to NMM turbulence" -rconfig integer ncnvc namelist,physics max_domains 10 irh "ncnvc" "fundamental timesteps between calls to NMM convection" -rconfig integer nrand namelist,physics max_domains 10 irh "nrand" "fundamental timesteps between random number generator updates (0=use ncnvc)" -rconfig integer nrads namelist,physics max_domains 200 irh "nrads" "fundamental timesteps between calls to NMM shortwave radiation" -rconfig integer nradl namelist,physics max_domains 200 irh "nradl" "fundamental timesteps between calls to NMM longwave radiation" -rconfig real tprec namelist,physics max_domains 385. irh "tprec" "number of hours in bucket for total precipitation" -rconfig real theat namelist,physics max_domains 385. irh "theat" "number of hours in bucket for gridscale and convective heating rates" -rconfig real tclod namelist,physics max_domains 385. irh "tclod" "number of hours in bucket for cloud amounts" -rconfig real trdsw namelist,physics max_domains 385. irh "trdsw" "number of hours in bucket for short wave fluxes" -rconfig real trdlw namelist,physics max_domains 385. irh "trdlw" "number of hours in bucket for long wave fluxes" -rconfig real tsrfc namelist,physics max_domains 385. irh "tsrfc" "number of hours in bucket for evaporation / sfc fluxes" -rconfig logical pcpflg namelist,physics max_domains .false. irh "pcpflg" "logical switch that turns on/off the precipitation assimilation" -rconfig integer sigma namelist,physics max_domains 1 irh "sigma" "logical switch for NMM vertical coordinate (sigma or hybrid)" -rconfig real sfenth namelist,physics max_domains 0.0 irh "sea spray parameter" -rconfig integer co2tf namelist,physics 1 0 - "co2tf" "GFDL radiation co2 flag" -rconfig integer ra_call_offset namelist,physics 1 -1 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" -rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" -rconfig integer levsiz namelist,physics 1 1 - "levsiz" "Number of ozone data levels for CAM radiation (59)" "" -rconfig integer paerlev namelist,physics 1 1 - "paerlev" "Number of aerosol data levels for CAM radiation (29)" "" -rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" -rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" -rconfig integer no_src_types namelist,physics 1 1 - "no_src_types" "Number of aerosoal types from EC (6)" "" -rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" -rconfig integer o3input namelist,physics 1 0 - "o3input" "ozone input option for radiation" "" -rconfig integer aer_opt namelist,physics 1 0 - "aer_opt" "aerosol input option for radiation" "" -rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback of cumulus cloud to radiation" -rconfig integer ICLOUD_CU derived 1 0 - "ICLOUD_CU" "" "" -rconfig real h_diff namelist,physics max_domains 0.1 irh "nmm input 9" -rconfig integer movemin namelist,physics max_domains 10 irh "movemin" "nest movement timestep (multiples of nphs)" -rconfig real nomove_freq namelist,physics max_domains -1.0 irh "nomove_freq" "nest will not move at analysis time or multiples of this hour (if positive)" -rconfig integer num_snso_layers namelist,physics 1 7 irh "num_snso_layers" "" "" -rconfig integer num_snow_layers namelist,physics 1 3 irh "num_snow_layers" "" "" -rconfig logical use_aero_icbc namelist,physics 1 .false. rh "use_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero" "logical flag" -rconfig integer sf_lake_physics namelist,physics max_domains 0 h "sf_lake_physics" "activate lake model 0=no, 1=yes" "" - - -# Dynamics -# dynamics option (see package definitions, below) -rconfig integer dyn_opt namelist,dynamics 1 - -rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" -rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" -# diff_opt 1=old diffusion, 2=new -rconfig integer diff_opt namelist,dynamics max_domains -1 irh "diff_opt" "" "" -# km_opt 1=old coefs, 2=tke, 3=Smagorinksy -rconfig integer km_opt namelist,dynamics max_domains -1 irh "km_opt" "" "" -rconfig integer damp_opt namelist,dynamics 1 1 irh "damp_opt" "" "" -rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" -rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" -rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" -rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" -rconfig real iso_temp namelist,dynamics 1 0. h "iso_temp" "Isothermal temperature in stratosphere, real only" "K" -rconfig real dampcoef namelist,dynamics max_domains 0.2 h "dampcoef" "" "" -rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" -rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" -rconfig real c_s namelist,dynamics max_domains 0.25 h "c_s" "Smagorinsky coeff" "" -rconfig real c_k namelist,dynamics max_domains 0.15 h "c_k" "TKE coeff" "" -rconfig real smdiv namelist,dynamics max_domains 0. h "smdiv" "" "" -rconfig real emdiv namelist,dynamics max_domains 0. h "emdiv" "" "" -rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" -rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" -rconfig integer time_step_sound namelist,dynamics max_domains 10 h "time_step_sound" "" "" -rconfig integer h_mom_adv_order namelist,dynamics max_domains 3 rh "h_mom_adv_order" "" "" -rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rh "v_mom_adv_order" "" "" -rconfig integer h_sca_adv_order namelist,dynamics max_domains 3 rh "h_sca_adv_order" "" "" -rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" -rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" -rconfig real tke_upper_bound namelist,dynamics max_domains 1000. h "tke_upper_bound" "" "" -rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "" -rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "" -rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" -rconfig logical euler_adv namelist,dynamics 1 .false. irh "euler_adv" "logical flag to turn on/off Eulerian passive advection" "" -rconfig integer idtadt namelist,dynamics 1 1 irh "idtadt" "fundamental timesteps between calls to Eulerian advection for dynamics" "" -rconfig integer idtadc namelist,dynamics 1 1 irh "idtadc" "fundamental timesteps between calls to Eulerian advection for chemistry" "" -rconfig real codamp namelist,dynamics max_domains 6.4 irh "codamp" "divergence damping weighting factor (larger = more damping) " "" -rconfig real coac namelist,dynamics max_domains 1.6 irh "coac" "horizontal diffusion weighting factor (larger = more diffusion) " "" -rconfig real slophc namelist,dynamics max_domains 6.363961e-3 irh "slophc" "Maximum model level slope (dZ/dy) for which hor diffusion is applied" "" -rconfig real wp namelist,dynamics max_domains 0. irh "wp" "Off-centering weight in the updating of nonhyrostatic eps" - -rconfig integer terrain_smoothing namelist,dynamics 1 1 irh "parallel_smooth" "nest_terrain smoothing method 0=none, 1=old, 2=new" - -# Bdy_control -rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" -rconfig integer spec_zone namelist,bdy_control 1 1 irh "spec_zone" "" "" -rconfig integer relax_zone namelist,bdy_control 1 4 irh "relax_zone" "" "" -rconfig logical specified namelist,bdy_control max_domains .false. rh "specified" "" "" -rconfig logical periodic_x namelist,bdy_control max_domains .false. rh "periodic_x" "" "" -rconfig logical symmetric_xs namelist,bdy_control max_domains .false. rh "symmetric_xs" "" "" -rconfig logical symmetric_xe namelist,bdy_control max_domains .false. rh "symmetric_xe" "" "" -rconfig logical open_xs namelist,bdy_control max_domains .false. rh "open_xs" "" "" -rconfig logical open_xe namelist,bdy_control max_domains .false. rh "open_xe" "" "" -rconfig logical periodic_y namelist,bdy_control max_domains .false. rh "periodic_y" "" "" -rconfig logical symmetric_ys namelist,bdy_control max_domains .false. rh "symmetric_ys" "" "" -rconfig logical symmetric_ye namelist,bdy_control max_domains .false. rh "symmetric_ye" "" "" -rconfig logical open_ys namelist,bdy_control max_domains .false. rh "open_ys" "" "" -rconfig logical open_ye namelist,bdy_control max_domains .false. rh "open_ye" "" "" -rconfig logical polar namelist,bdy_control max_domains .false. rh "polar" "" "" -rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" -rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" - -rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" -rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" -rconfig integer production_status namelist,grib2 1 255 rh "production_status" "Background processing id for grib2" "" -rconfig integer compression namelist,grib2 1 40 rh "compression" "grib2 compression, 40 for JPEG2000 or 41 for PNG" "" - -# NAMELIST DERIVED -rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" -rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" -rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" -rconfig real truelat2 derived max_domains 0 - "true_lat2" "second standard parallel" "degrees, negative is south" -rconfig real moad_cen_lat derived max_domains 0 - "moad_cen_lat" "center latitude of the most coarse grid" "degrees, negative is south" -rconfig real stand_lon derived max_domains 0 - "stand_lon" "standard longitude, parallel to j-direction, perpendicular to i-direction " "degrees, negative is west" -rconfig integer FLAG_METGRID derived 1 0 - "FLAG_METGRID" "Flag in global attributes for metgrid data" -rconfig integer FLAG_SNOW derived 1 0 - "FLAG_SNOW" "Flag for snow in the global attributes for metgrid data" -rconfig integer FLAG_PSFC derived 1 0 - "FLAG_PSFC" "Flag for surface pressure in the global attributes for metgrid data" -rconfig integer FLAG_SM000010 derived 1 0 - "FLAG_SM000010" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_SM010040 derived 1 0 - "FLAG_SM010040" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_SM040100 derived 1 0 - "FLAG_SM040100" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_SM100200 derived 1 0 - "FLAG_SM100200" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_ST000010 derived 1 0 - "FLAG_ST000010" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_ST010040 derived 1 0 - "FLAG_ST000010" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_ST040100 derived 1 0 - "FLAG_ST010040" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_ST100200 derived 1 0 - "FLAG_ST100200" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_SLP derived 1 0 - "FLAG_SLP" "Flag for sea level pressure in the global attributes for metgrid data" -rconfig integer FLAG_SOILHGT derived 1 0 - "FLAG_SOILHGT" "Flag for soil height in the global attributes for metgrid data" -rconfig integer FLAG_MF_XY derived 1 0 - "FLAG_MF_XY" "Flag for MF_XYin the global attributes for metgrid data" -rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" -rconfig character mminlu derived max_domains " " - "mminlu" "land use dataset" - "" -rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" -rconfig integer islake derived max_domains 0 - "islake" "land use index of inland lake" "index category" -rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" -rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" -rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" -rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" -rconfig integer dfi_stage derived 1 3 - "dfi_stage" "current stage of DFI processing" "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast" -rconfig integer mp_physics_dfi derived max_domains -1 - "mp_physics_dfi" "" "-1 = no DFI and so no need to allocate DFI moistnd scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package" - -#rconfig integer simulation_start_year derived 1 0 h "simulation_start_year" "start of simulation through restarts" "4-digit year" -#rconfig integer simulation_start_month derived 1 0 h "simulation_start_month" "start of simulation through restarts" "2-digit month" -#rconfig integer simulation_start_day derived 1 0 h "simulation_start_day" "start of simulation through restarts" "2-digit day" -#rconfig integer simulation_start_hour derived 1 0 h "simulation_start_hour" "start of simulation through restarts" "2-digit hour" -#rconfig integer simulation_start_minute derived 1 0 h "simulation_start_minute" "start of simulation through restarts" "2-digit minute" -#rconfig integer simulation_start_second derived 1 0 h "simulation_start_second" "start of simulation through restarts" "2-digit second" - -# -# Single dummy declaration to define a nodyn dyn option -state integer nodyn_dummy - dyn_nodyn - - - "" "" "" - -rconfig integer maxpatch namelist,physics 1 10 irh "maxpatch" "" "" - -#key package associated package associated 4d scalars -# name namelist choice state vars - -#### 9. Edit the Registry file to set up '5' as the value of the -**** namelist variable dyn_opt that means to select our exp dyncore. -package dyn_exp dyn_opt==5 - - - -#--------------------------------------------------------------- -# Vortex tracker options - -# NOTE: ALL methods except #1 must use pdyn_parent and pdyn_smooth, -# if ANY domains use option #5 - -package vt_old_hwrf vortex_tracker==1 - - -package vt_track_nest vortex_tracker==2 - state:pdyn_parent,pdyn_smooth -package vt_centroid vortex_tracker==3 - state:pdyn_parent,pdyn_smooth -package vt_rev_centr vortex_tracker==4 - state:weightout,mslp_noisy,pdyn_parent,pdyn_smooth,distsq -package vt_pdyn vortex_tracker==5 - state:pdyn_parent,pdyn_smooth,distsq -package vt_ncep vortex_tracker==6 - state:pdyn_parent,pdyn_smooth,p850rv,p700rv,p850wind,p700wind,p850z,p700z,m10wind,m10rv,sp850rv,sp700rv,sp850wind,sp700wind,sp850z,sp700z,sm10wind,sm10rv,smslp,tracker_fixes,distsq -#--------------------------------------------------------------- -package passiveqv mp_physics==0 - moist:qv -package kesslerscheme mp_physics==1 - moist:qv,qc,qr -package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg -package wsm3scheme mp_physics==3 - moist:qv,qc,qr -package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs -package etampnew mp_physics==5 - moist:qv,qc,qr,qs;state:f_ice,f_rain,f_rimef -package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg -package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg -package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr;state:re_cloud,re_ice,re_snow -package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow -package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh -package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng -package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs -package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr -package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr -package etamp_hwrf mp_physics==85 - moist:qv,qc,qr,qi,qs;state:f_ice,f_rain,f_rimef -package etampold mp_physics==95 - moist:qv,qc,qr,qs;state:f_ice,f_rain,f_rimef - -package nodfimoist mp_physics_dfi==-1 - - -package passiveqv_dfi mp_physics_dfi==0 - dfi_moist:dfi_qv -package kesslerscheme_dfi mp_physics_dfi==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr -package linscheme_dfi mp_physics_dfi==2 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package wsm3scheme_dfi mp_physics_dfi==3 - dfi_moist:dfi_qv,dfi_qc,dfi_qr -package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs -package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs -package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh -package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng -package sbu_ylinscheme_dfi mp_physics==13 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs -package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr -package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr -package etampold_dfi mp_physics_dfi==95 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs - -# package noprogn progn==0 - - -# package progndrop progn==1 - scalar:qndrop;dfi_scalar:dfi_qndrop - -package rrtmscheme ra_lw_physics==1 - - -package camlwscheme ra_lw_physics==3 - - -package rrtmg_lwscheme ra_lw_physics==4 - - -package goddardlwscheme ra_lw_physics==5 - - -package flglwscheme ra_lw_physics==7 - - -package gfdllwscheme ra_lw_physics==99 - - -package hwrflwscheme ra_lw_physics==98 - -package swradscheme ra_sw_physics==1 - - -package gsfcswscheme ra_sw_physics==2 - - -package camswscheme ra_sw_physics==3 - - -package rrtmg_swscheme ra_sw_physics==4 - - -package goddardswscheme ra_sw_physics==5 - - -package flgswscheme ra_sw_physics==7 - - -package gfdlswscheme ra_sw_physics==99 - - -package hwrfswscheme ra_sw_physics==98 -package heldsuarez ra_lw_physics==31 - - - -package sfclayscheme sf_sfclay_physics==91 - - -package myjsfcscheme sf_sfclay_physics==2 - - -package gfssfcscheme sf_sfclay_physics==3 - - -package gfdlsfcscheme sf_sfclay_physics==88 - - -package qnsesfcscheme sf_sfclay_physics==4 - - -package pxsfcscheme sf_sfclay_physics==7 - - -package temfsfcscheme sf_sfclay_physics==10 - - -package sfclayrevscheme sf_sfclay_physics==1 - - -package idealscmsfcscheme sf_sfclay_physics==89 - - -package gbmpblscheme sf_sfclay_physics==12 - - - -package slabscheme sf_surface_physics==1 - - -package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn -package ruclsmscheme sf_surface_physics==3 - - - -package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy - -package clmscheme sf_surface_physics==5 - - -package gfdlslab sf_surface_physics==88 - - -package pxlsmscheme sf_surface_physics==7 - - -package ssibscheme sf_surface_physics==8 - - -package ysuscheme bl_pbl_physics==1 - - -package myjpblscheme bl_pbl_physics==2 - - -package gfsscheme bl_pbl_physics==3 - state:hpbl2d,heat2d,evap2d,rc2d -package gfs2011scheme bl_pbl_physics==83 - state:hpbl2d,heat2d,evap2d -package qnsepblscheme bl_pbl_physics==4 - - -package qnsepbl09scheme bl_pbl_physics==94 - - -package acmpblscheme bl_pbl_physics==7 - - -package boulacscheme bl_pbl_physics==8 - - -package camuwpblscheme bl_pbl_physics==9 - - -package mrfscheme bl_pbl_physics==99 - - -package temfpblscheme bl_pbl_physics==10 - - -package fitchscheme windfarm_opt==1 - - - -package kfetascheme cu_physics==1 - - -package bmjscheme cu_physics==2 - - -package gdscheme cu_physics==93 - - -package sasscheme cu_physics==84 - state:hpbl2d,heat2d,evap2d -package meso_sas cu_physics==85 - state:hpbl2d,heat2d,evap2d -package osasscheme cu_physics==4 - state:randstate1,randstate2,randstate3,randstate4,random -package g3scheme cu_physics==5 - - -package gfscheme cu_physics==3 - - -package camzmscheme cu_physics==7 - - -package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep -package tiedtkescheme cu_physics==6 - - -package nsasscheme cu_physics==14 - - -package kfscheme cu_physics==99 - - - -package g3shcuscheme shcu_physics==1 - - -package camuwshcuscheme shcu_physics==2 - - -package grimsshcuscheme shcu_physics==3 - - - -package dfi_setup dfi_stage==0 - - -package dfi_bck dfi_stage==1 - - -package dfi_fwd dfi_stage==2 - - -package dfi_fst dfi_stage==3 - - -package dfi_startfwd dfi_stage==4 - - -package dfi_startbck dfi_stage==5 - - -package dfi_nodfi dfi_opt==0 - - -package dfi_dfl dfi_opt==1 - \ - state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC -package dfi_ddfi dfi_opt==2 - \ - state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC -package dfi_tdfi dfi_opt==3 - \ - state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC - -package albsi_zero seaice_albedo_opt==0 - - -package albsi_one seaice_albedo_opt==1 - - -package albsi_two seaice_albedo_opt==2 - state:albsi -package snowsi_zero seaice_snowdepth_opt==0 - - -package snowsi_one seaice_snowdepth_opt==1 - state:snowsi -package icedepth_zero seaice_thickness_opt==0 - - -package icedepth_one seaice_thickness_opt==1 - state:icedepth - -# only need to specify these once; not for every io_form* variable -package io_intio io_form_restart==1 - - -package io_netcdf io_form_restart==2 - - -# Placeholders for additional packages (we can go beyond zzz -# but that will entail modifying frame/module_io.F and frame/md_calls.m4) -# Please note these are placeholders; HDF has not been implemented yet. -package io_hdf io_form_restart==3 - - -package io_phdf5 io_form_restart==4 - - -package io_grib1 io_form_restart==5 - - -package io_mcel io_form_restart==6 - - -package io_esmf io_form_restart==7 - - -package io_yyy io_form_restart==8 - - -package io_zzz io_form_restart==9 - - -package io_grib2 io_form_restart==10 - - -package io_pnetcdf io_form_restart==11 - - - -#lightning -package ltng_none lightning_option==0 - - -package ltng_crm_PR92w lightning_option==1 - - -package ltng_crm_PR92z lightning_option==2 - - -package ltng_cpm_PR92z lightning_option==11 - - - -#WRF Hydro -package no_wrfhydro wrf_hydro==0 - - -package wrfhydro wrf_hydro==1 - state:SOLDRAIN, SFCHEADRT, INFXSRT - - -## communications - -### 8. Edit the Registry file and create a halo-exchange for x_1. - -# NMM communications - -halo HALO_NMM_INIT_1 dyn_nmm 120:HBM2 -halo HALO_NMM_INIT_2 dyn_nmm 120:HBM3,VBM2,VBM3 -halo HALO_NMM_INIT_3 dyn_nmm 120:SM,SICE -halo HALO_NMM_INIT_4 dyn_nmm 120:DX_NMM,WPDAR -halo HALO_NMM_INIT_5 dyn_nmm 120:CPGFU,CURV,FCP -halo HALO_NMM_INIT_6 dyn_nmm 120:FDIV,FAD,F -halo HALO_NMM_INIT_7 dyn_nmm 120:DDMPU,DDMPV,GLAT -halo HALO_NMM_INIT_8 dyn_nmm 120:GLON,EPSR,TG -halo HALO_NMM_INIT_9 dyn_nmm 120:GFFC,SST,ALBASE -#halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV,IVGTYP -halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV -#halo HALO_NMM_INIT_11 dyn_nmm 120:ISLTYP,ISLOPE,VEGFRC -halo HALO_NMM_INIT_11 dyn_nmm 120:VEGFRC -halo HALO_NMM_INIT_12 dyn_nmm 120:DIV,OMGALF,PD,RES -halo HALO_NMM_INIT_13 dyn_nmm 120:FIS,T,U -halo HALO_NMM_INIT_14 dyn_nmm 120:V,Q,Q2 -halo HALO_NMM_INIT_15 dyn_nmm 120:CWM,TRAIN,TCUCN -halo HALO_NMM_INIT_15B dyn_nmm 120:moist,scalar -halo HALO_NMM_INIT_16 dyn_nmm 120:RSWIN,RSWOUT,TG -halo HALO_NMM_INIT_17 dyn_nmm 120:Z0,AKMS,CZEN -halo HALO_NMM_INIT_18 dyn_nmm 120:AKHS,THS,QSH -halo HALO_NMM_INIT_19 dyn_nmm 120:TWBS,QWBS,HBOT -halo HALO_NMM_INIT_20 dyn_nmm 120:CFRACL,THZ0,QZ0 -halo HALO_NMM_INIT_21 dyn_nmm 120:UZ0,VZ0,USTAR -halo HALO_NMM_INIT_22 dyn_nmm 120:HTOP,CFRACM,SNO -halo HALO_NMM_INIT_23 dyn_nmm 120:SI,CLDEFI,RF -halo HALO_NMM_INIT_24 dyn_nmm 120:CUPPT,CFRACH,SOILTB -halo HALO_NMM_INIT_25 dyn_nmm 120:SFCEXC,SMSTAV,SMSTOT -halo HALO_NMM_INIT_26 dyn_nmm 120:GRNFLX,PCTSNO,RLWIN -halo HALO_NMM_INIT_27 dyn_nmm 120:RADOT,CZMEAN,SIGT4 -halo HALO_NMM_INIT_28 dyn_nmm 120:SR -halo HALO_NMM_INIT_29 dyn_nmm 120:PREC,ACPREC,ACCLIQ -halo HALO_NMM_INIT_30 dyn_nmm 120:ACFRST,ACSNOW -halo HALO_NMM_INIT_31 dyn_nmm 120:ACSNOM,SSROFF,BGROFF -halo HALO_NMM_INIT_32 dyn_nmm 120:SFCSHX,SFCLHX,SUBSHX -halo HALO_NMM_INIT_33 dyn_nmm 120:SNOPCX,SFCUVX,SFCEVP -halo HALO_NMM_INIT_34 dyn_nmm 120:POTEVP,ASWIN,ASWOUT -halo HALO_NMM_INIT_35 dyn_nmm 120:ASWTOA,ALWIN,ALWOUT -halo HALO_NMM_INIT_36 dyn_nmm 120:ALWTOA,SMC,CMC -halo HALO_NMM_INIT_37 dyn_nmm 120:STC,SH2O,ALBEDO -halo HALO_NMM_INIT_38 dyn_nmm 120:PINT,Z,DWDT -halo HALO_NMM_INIT_39 dyn_nmm 120:TOLD,UOLD,VOLD - -#for HWRF: zhang increase halo width to fix feedback bug for HALO_NMM_A (24 => 48) -#for HWRF: zhang HALO_NMM_C (24 => 48), HALO_NMM_G (24 => 48), HALO_NMM_K (8 => 24) -halo HALO_NMM_A dyn_nmm 48:pd,t,u,v,q,cwm,dwdt,div;48:pint -halo HALO_NMM_A_3 dyn_nmm 24:moist,scalar -halo HALO_NMM_B dyn_nmm 24:div -halo HALO_NMM_C dyn_nmm 48:u,v -halo HALO_NMM_D dyn_nmm 48:pd -halo HALO_NMM_E dyn_nmm 24:petdt -halo HALO_NMM_F dyn_nmm 24:t,u,v -halo HALO_NMM_F1 dyn_nmm 80:pdslo -halo HALO_NMM_G dyn_nmm 48:u,v;24:z -halo HALO_NMM_H dyn_nmm 24:w -halo HALO_NMM_I dyn_nmm 48:q,q2,cwm,rrw -halo HALO_NMM_I_3 dyn_nmm 48:moist,scalar -halo HALO_NMM_J dyn_nmm 8:pd,uz0,vz0,t,q,cwm -halo HALO_NMM_J_3 dyn_nmm 8:moist,scalar -halo HALO_NMM_K dyn_nmm 24:q2;24:t,u,v,q,w,z -halo HALO_NMM_L dyn_nmm 8:pd,t,q,cwm,q2 -halo HALO_NMM_L_3 dyn_nmm 8:moist,scalar -halo HALO_NMM_MG dyn_nmm 8:ht_gc -halo HALO_NMM_MG2 dyn_nmm 8:pd,psfc_out -halo HALO_NMM_MG3 dyn_nmm 8:p_gc - -halo HALO_NMM_TURBL_A dyn_nmm 8:uz0h,vz0h,hbm2 -halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt - -# following halos added for nesting purpose (gopal's doing): - -halo HALO_NMM_TRACK dyn_nmm 120:sm,pdyn,mslp,sqws -halo HALO_NMM_INTERP_DOWN1 dyn_nmm 24:sm,fis,t,u,v,q,q2,pd,albase,nmm_tsk,mxsnal,tg,islope,cmc,soiltb,vegfrc,sh2o,smc,stc,toposoil,xice,ivgtyp,isltyp,vegfra,sst,weasd,snowh,hlat,hlon,z0,landmask,cwm,ustar,ths,qsh,cldefi,pshltr,dwdt,acprec,thz0,qz0,uz0,vz0,htop,hbot,cuppt,rlwtt,rswtt,t_adj,f_ice,f_rain,f_rimef,pint,hres_fis,pdyn_parent,pdyn_smooth -halo HALO_NMM_INTERP_DOWN1M dyn_nmm 24:MOIST,SCALAR -halo HALO_NMM_FORCE_DOWN1 dyn_nmm 24:t,u,v,q,q2,cwm,pint,pd,hres_fis,fis,pdyn_parent,pdyn_smooth -halo HALO_NMM_FORCE_DOWN1M dyn_nmm 24:MOIST,SCALAR -halo HALO_NMM_WEIGHTS dyn_nmm 48:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4,HNEAR_I,HNEAR_J - -halo HALO_NMM_SAS_A dyn_nmm 24:uz0h,vz0h,hbm2 -halo HALO_NMM_SAS_B dyn_nmm 24:ducudt,dvcudt -halo HALO_TRACERS dyn_nmm 48:szj,s1z,spz,tcs - -halo HALO_NMM_FORCE_DOWN_SST dyn_nmm 120:sst - -halo HALO_NMM_TERRAIN_SMOOTH dyn_nmm 24:HRES_AVC - -halo HALO_NMM_MSLP dyn_nmm 24:MSLP - -halo HALO_NMM_VT4_MSLP dyn_nmm 8:mslp -halo HALO_NMM_VT4_NOISE dyn_nmm 8:mslp_noisy - -halo HALO_NMM_INTERP_INFO dyn_nmm 8:pd,iinfo,winfo,pint -halo HALO_NMM_INT_UP dyn_nmm 8:pd,fis,hres_fis,sm - -halo HALO_NMM_MEMBRANE_RELAX dyn_nmm 8:relaxwork -halo HALO_NMM_MEMBRANE_MASK dyn_nmm 8:relaximask -halo HALO_NMM_MEMBRANE_INTERP dyn_nmm 8:u10,v10,u,v diff --git a/wrfv2_fire/Registry/Registry.NMM_NEST b/wrfv2_fire/Registry/Registry.NMM_NEST deleted file mode 100644 index 09258d85..00000000 --- a/wrfv2_fire/Registry/Registry.NMM_NEST +++ /dev/null @@ -1,1756 +0,0 @@ -# Registry file NMM_NEST -# -# At the present time this file is managed manually and edited by hand. -# -################################################################################ -# Dimension specifications -# -# This section of the Registry file is used to specify the dimensions -# that will be used to define arrays. Dim is the one-letter name of the -# dimension. How defined can either be "standard_domain", which means -# that the dimension (1) is one of the three spatial dimensions and (2) -# it will be set using the standard namelist mechanism and domain data -# structure dimension fields (e.g. sd31,ed31,sd32...). -# -# Order refers to which of the three sets of just-mentioned internal -# dimension variables the dimension is referred to by in the driver. -# That is, is it the first, second, or third dimension. The registry -# infers the mapping of its internal dimensions according to the -# combination of Order and Coord-axis that are specified in this table. -# Note that it is all right to more than one dimension name for, say, the -# x dimension. However, the Order and Coord-axis relationship must be -# consistent throughout. -# -# Note: these entries do not enforce storage order on a particular field. -# That is determined by the dimension strings for each field. But it does -# relate the dimspec to the internal data structures that the driver uses -# to maintain the three physical domain dimensions. -# -# "How defined" can also specify the name of a namelist variable from which -# the definition for the dimension will come; this is specified as -# "namelist=". The namelist variable must have been -# defined as an integer and with only one entry in the rconfig table. Or -# a constant can be specified. The coordinate axis for the dimension is -# either X, Y, Z, or C (for "not a spatial dimension"). The Dimname is -# the descriptive name of the dimension that will be included in the -# metadata in data sets. Note that the b, f, and t modifiers that appear -# as the last characters of dimension strings used # in state and # i1 -# registry definitions are not dimensions and do not need to be declared -# here. -# - -include registry.dimspec -include registry.lake - -############# -rconfig integer ntracers namelist,physics 1 4 - - -# option 1 -#dimspec ntracevars - constant=4 c number of 4d tracer variables -#state real - ijk{ntracevars}f tracers 1 - - - - -#state real t1 ijk{ntracevars}f tracers 1 - r - - -#state real t2 ijk{ntracevars}f tracers 1 - r - - -#state real t3 ijk{ntracevars}f tracers 1 - r - - -#state real t4 ijk{ntracevars}f tracers 1 - r - - -#package tracer_option_1 ntracers==4 - tracers:t1,t2,t3,t4 - -# option 2 -state real - ijkf szj 1 - - - - -state real szj1 ijkf szj 1 - r "szj1" "szj" "units" -state real szj2 ijkf szj 1 - r "szj2" "szj" "units" -state real szj3 ijkf szj 1 - r "szj3" "szj" "units" -state real szj4 ijkf szj 1 - r "szj4" "szj" "units" - -state real - ijkf s1z 1 - - - - -state real s1z1 ijkf s1z 1 - r "s1z1" "s1z" "units" -state real s1z2 ijkf s1z 1 - r "s1z2" "s1z" "units" -state real s1z3 ijkf s1z 1 - r "s1z3" "s1z" "units" -state real s1z4 ijkf s1z 1 - r "s1z4" "s1z" "units" - -state real - ijkf spz 1 - - - - -state real spz1 ijkf spz 1 - r "spz1" "spz" "units" -state real spz2 ijkf spz 1 - r "spz2" "spz" "units" -state real spz3 ijkf spz 1 - r "spz3" "spz" "units" -state real spz4 ijkf spz 1 - r "spz4" "spz" "units" - -state real - ijkf tcs 1 - - - - -state real tcs1 ijkf tcs 1 - r "tcs1" "tcs" "units" -state real tcs2 ijkf tcs 1 - r "tcs2" "tcs" "units" -state real tcs3 ijkf tcs 1 - r "tcs3" "tcs" "units" -state real tcs4 ijkf tcs 1 - r "tcs4" "tcs" "units" - -package tracer_option_2 ntracers==4 - szj:szj1,szj2,szj3,szj4;s1z:s1z1,s1z2,s1z3,s1z4;spz:spz1,spz2,spz3,spz4;tcs:tcs1,tcs2,tcs3,tcs4 - -################################################################################ -################################################################################ -################################################################################ - -# Lines that start with the word 'state' form a table that is -# used by the script use_registry to generate module_state_descript.F -# and other files. Also see documentation in use_registry. -# -# It is reauired that LU_INDEX appears before any variable that is -# interpolated with a mask, as lu_index supplies that mask. -# -state real LU_INDEX ij misc 1 - irh01d=(interp_fcnm)u=(copy_fcnm) "LU_INDEX" "LAND USE CATEGORY" "" -state real LU_MASK ij misc 1 - i3h1 "LU_MASK" "0 land 1 water" "" -################################################################################ -################################################################################ - -################################ -## WPS-specific Variables -################################ - -state real p_gc ijg dyn_nmm 1 Z i1 "PRES" "pressure" "Pa" -state real vegcat ij misc 1 - i12 "VEGCAT" "VEGETATION CAT DOMINANT TYPE" "" -state real soilcat ij misc 1 - i12 "SOILCAT" "SOIL CAT DOMINANT TYPE" "" - -state real input_soil_cat ij misc 1 - i12 "SOIL_CAT" "SOIL CAT DOMINANT TYPE" "" -state real tsk_gc ij dyn_nmm 1 - i1 "SKINTEMP" "skin temperature" "K" -state real XICE_gc ij misc 1 - i014r "SEAICE" "SEA ICE" "" -state real ght_gc ijg dyn_nmm 1 Z i1 "GHT" "geopotential height" "m" -state real rh_gc ijg dyn_nmm 1 Z i1 "RH" "relative humidity" "%" -state real v_gc ijg dyn_nmm 1 Z i1 "VV" "y-wind component" "m s-1" -state real u_gc ijg dyn_nmm 1 Z i1 "UU" "x-wind component" "m s-1" -state real t_gc ijg dyn_nmm 1 Z i1 "TT" "temperature" "K" -state real snoalb ij misc 1 - i012r "SNOALB" "ANNUAL MAX SNOW ALBEDO IN FRACTION" "" -state real greenfrac_gc ijm dyn_nmm 1 Z i1 "GREENFRAC" "monthly greenness fraction" "0 - 1 fraction" -state real albedo12m_gc ijm dyn_nmm 1 Z i1 "ALBEDO12M" "background albedo" "0 - 1 fraction" -state real lai12m_gc ijm dyn_nmm 1 Z i1 "LAI12M" "monthly LAI" "m2/m2" -state real soilcbot_gc ijs misc 1 Z i1 "SOILCBOT" "description" "units" -state real soilctop_gc ijs misc 1 Z i1 "SOILCTOP" "description" "units" -state real tmn_gc ij dyn_nmm 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" -state real htv_gc ij dyn_nmm 1 - i1 "HGT_V" "wind point topography elevation" "m" -state real ht_gc ij dyn_nmm 1 - i1 "HGT_M" "mass point topography elevation" "m" -state real landusef_gc iju misc 1 Z i1 "LANDUSEF" "description" "units" -state real vlon_gc ij dyn_nmm 1 - i1 "XLONG_V" "longitude, positive east" "degrees" -state real vlat_gc ij dyn_nmm 1 - i1 "XLAT_V" "latitude, positive north" "degrees" -state real hlon_gc ij dyn_nmm 1 - i1 "XLONG_M" "longitude, positive east" "degrees" -state real hlat_gc ij dyn_nmm 1 - i1 "XLAT_M" "latitude, positive north" "degrees" - -############################################################## -# Variables for nmm dynamics -# -# module_BC -# -# pdb is only 2d but registry doesn't support 2d bdy arrays right now... - -# The following arrays were added to avoid using _b and _bt arrays for nesting. -# This is gopal' doing: - -state integer nrnd1 k dyn_nmm 1 - r "NRND1" - -# -# For the moving nest. This is gopal's doing -# - -state real relaxwork ij dyn_nmm 1 - r "relaxwork" "Temporary Tv storage array for the membrane MSLP overrelaxation loops" "K" -state integer relaximask ij dyn_nmm 1 - r "relaximask" "Integer mask array for the membrane MSLP overrelaxation loops" "K" -state logical relaxmask ij dyn_nmm 1 - r "relaxmask" "Mask array for the membrane MSLP overrelaxation loops" "K" - -state real pdyn ij dyn_nmm 1 - r "PDYN" "DYNAMIC PRESSURE USED FOR TRACKING GRID MOTION" -state real mslp ij dyn_nmm 1 - rh "MSLP" "MSLP USED TO DETERMINE STORM LOCATION" -state real sqws ij dyn_nmm 1 - r "SQWS" "SQUARE OF WIND SPEED AT LEVEL 10" -state integer xloc - dyn_nmm 2 - r "XLOC" "I-LOCATION OF MINIMUM DYNAMIC PRESSURE" -state integer yloc - dyn_nmm 2 - r "YLOC" "J-LOCATION OF MINIMUM DYNAMIC PRESSURE" -state logical mvnest - dyn_nmm 1 - r "MVNEST" "LOGICAL SWITCH FOR NMM GRID MOTION" -#for HWRF: zhang's doing added to calculate radiation constant for moving nest for restart -state integer julyr_rst - dyn_nmm 1 - r "JULYR_RST" "JULYR for restart moving nest " -state integer julday_rst - dyn_nmm 1 - r "JULDAY_RST" "JULDAY for restart moving nest " -state real gmt_rst - dyn_nmm 1 - r "GMT_RST" "GMT for restart moving nest " -state integer NTIME0 - dyn_nmm 1 - r "NTIME0" "COUNT FOR PREVIOUS MOVING NEST" - -#for HWRF: -# flag for nest movement -state logical moved - misc 1 - r - -state real ducudt ijk misc 1 - rh "UMMIX" "U TENDENCY MOMENTUM MIXING IN SAS" -state real dvcudt ijk misc 1 - rh "VMMIX" "V TENDENCY MOMENTUM MIXING IN SAS" - -state integer randstate1 ij dyn_nmm 1 - r "randstate1" "random number generator state word 1" -state integer randstate2 ij dyn_nmm 1 - r "randstate2" "random number generator state word 2" -state integer randstate3 ij dyn_nmm 1 - r "randstate3" "random number generator state word 3" -state integer randstate4 ij dyn_nmm 1 - r "randstate4" "random number generator state word 4" -state real random ij dyn_nmm 1 - rh "random" "random number in [0,1) used by SAS" - -# Location of the SOUTH-WEST nested pointed in terms of parent grid - -state integer IIH ij dyn_nmm 1 - rh -state integer JJH ij dyn_nmm 1 - rh -state integer IIV ij dyn_nmm 1 - rh -state integer JJV ij dyn_nmm 1 - rh - -# Location of nearest parent point: - -state integer hnear_i ij dyn_nmm 1 - rh "HNEAR_I" "I index of nearest parent point on H grid" -state integer hnear_j ij dyn_nmm 1 - rh "HNEAR_J" "J index of nearest parent point on H grid" - -# Bi-linear weights - -state real HBWGT1 ij dyn_nmm 1 - rh -state real HBWGT2 ij dyn_nmm 1 - rh -state real HBWGT3 ij dyn_nmm 1 - rh -state real HBWGT4 ij dyn_nmm 1 - rh -state real VBWGT1 ij dyn_nmm 1 - rh -state real VBWGT2 ij dyn_nmm 1 - rh -state real VBWGT3 ij dyn_nmm 1 - rh -state real VBWGT4 ij dyn_nmm 1 - rh -#end of HWRF: - -# -state real HLON ij dyn_nmm 1 - h01d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) -state real HLAT ij dyn_nmm 1 - h01d=(test_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) -state real VLON ij dyn_nmm 1 - irh -state real VLAT ij dyn_nmm 1 - irh - -# Projection south and west bounds for Post: -rconfig real wbd0 derived max_domains 0 - "wbd0" "western boundary of the domain in rotated coordinates" -rconfig real sbd0 derived max_domains 0 - "sbd0" "southern boundary of the domain in rotated coordinates" -state real wbd0var - dyn_nmm 0 - h "wbd0var" "western boundary of the domain in rotated coordinates" -state real sbd0var - dyn_nmm 0 - h "sbd0var" "southern boundary of the domain in rotated coordinates" - -#for HWRF: -rconfig logical analysis namelist,time_control max_domains .false. irh "days" "analysis control for the nested domain" - -state real PSTD k dyn_nmm 1 Z r -state integer KZMAX - dyn_nmm - - r -#end of HWRF: - -state real HRES_FIS ij dyn_nmm 1 - rd=(NoInterp)u=(NoInterp)f=(NoInterp) "HRES_FIS" "HIGH RESOLUTION TERRAIN DATA FOR NESTED DOMAIN" -state real HRES_AVC ij dyn_nmm 1 - - "HRES_AVC" "TEMPORARY STORAGE OF HRES_FIS/9.81" -state real HRES_LND ij dyn_nmm 1 - - "HRES_LND" "TEMPORARY STORAGE OF HIGH-RES LND" - -# -# module_MASKS -# -state real hbm2 ij dyn_nmm 1 - irh "HBM2" "Height boundary mask; =0 outer 2 rows on H points" "" -state real hbm3 ij dyn_nmm 1 - irh "HBM3" "Height boundary mask; =0 outer 3 rows on H points" "" -state real vbm2 ij dyn_nmm 1 - irh "VBM2" "Velocity boundary mask; =0 outer 2 rows on V points" "" -state real vbm3 ij dyn_nmm 1 - irh "VBM3" "Velocity boundary mask; =0 outer 3 rows on V points" "" -state real sm ij dyn_nmm 1 - i01rhd=(DownNear) "SM" "Sea mask; =1 for sea, =0 for land" "" -state real sice ij dyn_nmm 1 - irhd=(DownNear) "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" -# -# module_VRBLS -# -state integer ntsd - dyn_nmm - - r "NTSD" "Number of timesteps done" "" -state integer nstart_hour - dyn_nmm - - r "NSTART_HOUR" "Forecast hour at start of integration" "" - -state real pd ijb dyn_nmm 1 - i01rhu=(NoInterp)d=(NoInterp)f=(NoInterp) "PD" "Mass at I,J in the sigma domain" "Pa" -state real fis ij dyn_nmm 1 - i01rhu=(NoInterp)d=(NoInterp)f=(NoInterp) "FIS" "Surface geopotential" "m2 s-2" -state real res ij dyn_nmm 1 - irh "RES" "Reciprocal of surface sigma" "" -state real t ijkb dyn_nmm 1 - i01rhu=(NoInterp)d=(NoInterp)f=(NoInterp) "T" "Sensible temperature" "K" -state real q ijkb dyn_nmm 1 - i01rhu=(NoInterp)d=(NoInterp)f=(NoInterp) "Q" "Specific humidity" "kg kg-1" -state real test_vgrid ij dyn_nmm 1 v - "test_vgrid" "Testing V grid staggering" "gibbletrons" -state real u ijkb dyn_nmm 1 v i01rhu=(UpVel)d=(DownVel)f=(BdyVel) "U" "U component of wind" "m s-1" -state real v ijkb dyn_nmm 1 v i01rhu=(UpVel)d=(DownVel)f=(BdyVel) "V" "V component of wind" "m s-1" -state real told ijk dyn_nmm 1 - r "TOLD" "T from previous timestep" "K" -state real uold ijk dyn_nmm 1 - r "UOLD" "U from previous timestep" "m s-1" -state real vold ijk dyn_nmm 1 - r "VOLD" "V from previous timestep" "m s-1" -# -# NMM DFI -# -state real hcoeff {ndfi} misc 1 - - "HCOEFF" "initialization weights" -state real hcoeff_tot - misc 1 - - "HCOEFF_TOT" "initialization weights" - -state real dfi_pd ij misc 1 - r "DFI_PD" "Mass at I,J in the sigma domain" "Pa" -state real dfi_pint ijk misc 1 Z r "DFI_PINT" "Model layer interface pressure" "Pa" -state real dfi_dwdt ijk misc 1 - r "DFI_DWDT" "dwdt and 1+(dwdt)/g" "m s-2" -state real dfi_t ijk misc 1 - r "DFI_T" "Sensible temperature" "K" -state real dfi_q ijk misc 1 - r "DFI_Q" "Specific humidity" "kg kg-1" -state real dfi_u ijk misc 1 - r "DFI_U" "U component of wind" "m s-1" -state real dfi_v ijk misc 1 - r "DFI_V" "V component of wind" "m s-1" -state real dfi_q2 ijk misc 1 - r "DFI_Q2" "2 * Turbulence kinetic energy" "m2 s-2" -state real dfi_cwm ijk misc 1 - r "DFI_CWM" "Total condensate" "kg kg-1" -state real dfi_rrw ijk misc 1 - r "DFI_RRW" "Tracer" "kg kg-1" -### remaining simply set aside, and restored to original values after filtering. -### -state real dfi_STC ilj misc 1 Z r "DFI_STC" "SOIL TEMPERATURE" "K" -state real dfi_SMC ilj misc 1 Z r "DFI_SMC" "SOIL MOISTURE" "m3 m-3" -state real dfi_SH2O ilj misc 1 Z r "DFI_SH2O" "UNFROZEN SOIL MOISTURE" "m3 m-3" - -state real dfi_SNOW ij misc 1 - r "dfi_SNOW" "SNOW WATER EQUIVALENT" "kg m-2" -state real dfi_SNOWH ij misc 1 - r "dfi_SNOWH" "PHYSICAL SNOW DEPTH" "m" -state real dfi_CANWAT ij misc 1 - r "dfi_CANWAT" "CANOPY WATER" "kg m-2" -state real dfi_NMM_TSK ij misc 1 - r "dfi_NMM_TSK" "saved SURFACE SKIN TEMPERATURE" -state real dfi_SNOWC ij misc 1 - r "dfi_SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" - -# -# module_DYNAM -# -state real dx_nmm ij dyn_nmm 1 - irh "DX_NMM" "East-west distance H-to-V points" "m" -state real wpdar ij dyn_nmm 1 - ir -state real cpgfu ij dyn_nmm 1 - ir -state real curv ij dyn_nmm 1 - ir "CURV" "Curvature term= .5*DT*TAN(phi)/RadEarth" "s m-1" -state real fcp ij dyn_nmm 1 - ir -state real fdiv ij dyn_nmm 1 - ir -state real f ij dyn_nmm 1 - ir "F" "Coriolis * DT/2" "" -state real fad ij dyn_nmm 1 - ir -state real ddmpu ij dyn_nmm 1 - ir "DDMPU" "Divergence damping term for U" "m" -state real ddmpv ij dyn_nmm 1 - ir "DDMPV" "Divergence damping term for V" "m" -state real deta k dyn_nmm 1 - i01r "DETA" "Delta sigma in sigma domain" "" -state real rdeta k dyn_nmm 1 - ir "RDETA" "Reciprocal of DETA" "" -state real aeta k dyn_nmm 1 - i01r -state real f4q2 k dyn_nmm 1 - ir -state real etax k dyn_nmm 1 - i01r -state real dfl k dyn_nmm 1 Z i01r "DFL" "Standard atmosphere geopotential" "m2 s-2" -state real deta1 k dyn_nmm 1 - i01rh "DETA1" "Delta sigma in pressure domain" "" -state real aeta1 k dyn_nmm 1 - i01rh "AETA1" "Midlayer sigma value in pressure domain" "" -state real eta1 k dyn_nmm 1 Z i01rh "ETA1" "Interface sigma value in pressure domain" "" -state real deta2 k dyn_nmm 1 - i01rh "DETA2" "Delta sigma in sigma domain" "" -state real aeta2 k dyn_nmm 1 - i01rh "AETA2" "Midlayer sigma value in sigma domain" "" -state real eta2 k dyn_nmm 1 Z i01rh "ETA2" "Interface sigma value in sigma domain" "" -state real em q dyn_nmm 1 - ir -state real emt q dyn_nmm 1 - ir -#for HWRF: add to restart -state real adt ij dyn_nmm 1 - r "ADT" "Change of T due to advection" "K" -state real adu ij dyn_nmm 1 - r "ADU" "Change of U due to advection" "m s-1" -state real adv ij dyn_nmm 1 - r "ADV" "Change of V due to advection" "m s-1" -#end HWRF: -state real em_loc q dyn_nmm 1 - r -state real emt_loc q dyn_nmm 1 - r -state real dy_nmm - dyn_nmm - - ir "DY_NMM" "North-south distance H-to-V points" "m" -state real cpgfv - dyn_nmm - - ir -state real en - dyn_nmm - - ir -state real ent - dyn_nmm - - ir -state real f4d - dyn_nmm - - ir -state real f4q - dyn_nmm - - ir -state real ef4t - dyn_nmm - - ir -#for HWRF: add to restart -state logical upstrm - dyn_nmm - - - "UPSTRM" ".TRUE. => In upstream advec region of grid" "" -#end HWRF: -state real dlmd - dyn_nmm - - irh "DLMD" "East-west angular distance H-to-V points" "degrees" -state real dphd - dyn_nmm - - irh "DPHD" "North-south angular distance H-to-V points" "degrees" -state real pdtop - dyn_nmm - - i01rh "PDTOP" "Mass at I,J in pressure domain" "Pa" -state real pt - dyn_nmm - - i01rh "PT" "Pressure at top of domain" "Pa" -# -# module_CONTIN -# -#for HWRF: add to restart -state real pdsl ij dyn_nmm 1 - r "PDSL" "Sigma-domain pressure at sigma=1" "Pa" -state real pdslo ij dyn_nmm 1 - r "PDSLO" "PDSL from previous timestep" "Pa" -#end HWRF: -state real psdt ij dyn_nmm 1 - r "PSDT" "Surface pressure tendency" "Pa s-1" -state real div ijk dyn_nmm 1 - r "DIV" "Divergence" "Pa s-1" -state real def3d ijk dyn_nmm 1 - r "DEF3D" "Deformation term from horizontal diffusion" "" -#for HWRF: add to restart -state real few ijk dyn_nmm 1 - r "FEW" "Integrated east-west mass flux" "Pa m2 s-1" -state real fne ijk dyn_nmm 1 - r "FNE" "Integrated northeast-southwest mass flux" "Pa m2 s-1" -state real fns ijk dyn_nmm 1 - r "FNS" "Integrated north-south mass flux" "Pa m2 s-1" -state real fse ijk dyn_nmm 1 - r "FSE" "Integrated southeast-northwest mass flux" "Pa m2 s-1" -#end HWRF: -state real omgalf ijk dyn_nmm 1 - r "OMGALF" "Omega-alpha" "K" -#for HWRF: add to restart -state real petdt ijk dyn_nmm 1 - r "PETDT" "Vertical mass flux" "Pa s-1" -#end HWRF: -state real rtop ijk dyn_nmm 1 - r "RTOP" "Rd * Tv / P" "m3 kg-1" -# -# module_PVRBLS -# -state real pblh ij dyn_nmm 1 - rh "PBLH" "PBL Height" "m" -state integer lpbl ij dyn_nmm 1 - ir "LPBL" "Model layer of PBL top" "" -state real mixht ij dyn_nmm 1 - rh "MIXHT" "MXL HEIGHT" "m" -state real ustar ij dyn_nmm 1 - irhd=(DownNear) "USTAR" "Friction velocity" "m s-1" -state real z0 ij dyn_nmm 1 - i01rhd=(DownNear) "Z0" "Roughness height" "m" -state real mz0 ij dyn_nmm 1 - h "MZ0" "momentum Roughness length" "m" -state real rc2d ij dyn_nmm 1 - h "RC2D" "critical Richardson number" "m" -state real dku3d ijk dyn_nmm 1 - h "DKU3D" "Momentum Diffusivity" "m*m/s" -state real dkt3d ijk dyn_nmm 1 - h "DKT3D" "Thermal Diffusivity" "m*m/s" -state real hpbl2d ij dyn_nmm 1 - irh "HPBL2D" "HEIGHT OF PBL from new GFS pbl" "m" -state real heat2d ij dyn_nmm 1 - irh "HEAT2D" "" "" -state real evap2d ij dyn_nmm 1 - irh "EVAP2D" "" "" -state real z0base ij dyn_nmm 1 - ir "Z0BASE" "Base roughness height" "m" -state real ths ij dyn_nmm 1 - irhd=(DownCopy) "THS" "Surface potential temperature" "K" -state real mavail ij dyn_nmm 1 - i -state real qsh ij dyn_nmm 1 - irhd=(DownCopy) "QS" "Surface specific humidity" "kg kg-1" -state real twbs ij dyn_nmm 1 - irh "TWBS" "Instantaneous sensible heat flux" "W m-2" -state real qwbs ij dyn_nmm 1 - irh "QWBS" "Instantaneous latent heat flux" "W m-2" -state real taux ij dyn_nmm 1 - irh "TAUX" "Instantaneous stress along X direction in KG/M/S^2" -state real tauy ij dyn_nmm 1 - irh "TAUY" "Instantaneous stress along Y direction in KG/M/S^2" -state real prec ij dyn_nmm 1 - rh "PREC" "Precipitation in physics timestep" "m" -state real aprec ij dyn_nmm 1 - rh -state real acprec ij dyn_nmm 1 - rh01d=(DownCopy) "ACPREC" "Accumulatedtotal precipitation" "m" -state real cuprec ij dyn_nmm 1 - rh "CUPREC" "Accumulated convective precipitation" "m" -state real lspa ij dyn_nmm 1 - h "LSPA" "Land Surface Precipitation Accumulation" "kg m-2" -state real ddata ij dyn_nmm 1 - - "DDATA" "Observed precip to each physics timestep" "kg m-2" -state real accliq ij dyn_nmm 1 - r -state real sno ij dyn_nmm 1 - irh "SNO" "Liquid water eqiv of snow on ground" "kg m-2" -state real si ij dyn_nmm 1 - irh "SI" "Depth of snow on ground" "mm" -state real cldefi ij dyn_nmm 1 - rhd=(DownCopy) "CLDEFI" "Convective cloud efficiency" "" -state real deep ij dyn_nmm 1 - r "DEEP" "Deep convection =>.TRUE." "" -state real rf ij dyn_nmm 1 - r -state real th10 ij dyn_nmm 1 - rhd=(DownCopy) "TH10" "10-m potential temperature from MYJ" "K" -state real q10 ij dyn_nmm 1 - rhd=(DownCopy) "Q10" "10-m specific humidity from MYJ" "kg kg-1" -state real pshltr ij dyn_nmm 1 - rhd=(DownCopy) "PSHLTR" "2-m pressure from MYJ" "Pa" -state real tshltr ij dyn_nmm 1 - rhd=(DownCopy) "TSHLTR" "2-m potential temperature from MYJ" "K" -state real qshltr ij dyn_nmm 1 - rhd=(DownCopy) "QSHLTR" "2-m specific humidity from MYJ" "kg kg-1" -state real q2 ijkb dyn_nmm 1 - irhu=(UpMass:@EConst,0.0)d=(DownMass:@EConst,0.0)f=(BdyMass:@EConst,0.0) "Q2" "2 * Turbulence kinetic energy" "m2 s-2" -state real t_adj ijk dyn_nmm 1 - rd=(DownNear) "T_ADJ" "T change due to precip in phys step" "K" -state real t_old ijk dyn_nmm 1 - r "T_OLD" "T before last call to precip" "K" -state real zero_3d ijk dyn_nmm 1 - r -state real W0AVG ikj dyn_nmm 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" -state real AKHS_OUT ij dyn_nmm 1 - rh "AKHS_OUT" "Output sfc exch coeff for heat" "m2 s-1" -state real AKMS_OUT ij dyn_nmm 1 - rh "AKMS_OUT" "Output sfc exch coeff for momentum" "m2 s-1" -# -# module_PHYS -# -state real albase ij dyn_nmm 1 - i01rhd=(DownCopy) "ALBASE" "Base albedo" "" -state real albedo ij dyn_nmm 1 - irh "ALBEDO" "Dynamic albedo" "" -state real cnvbot ij dyn_nmm 1 - irh "CNVBOT" "Lowest convec cloud bottom lyr between outputs" "" -state real cnvtop ij dyn_nmm 1 - irh "CNVTOP" "Highest convec cloud top lyr between outputs" "" -state real czen ij dyn_nmm 1 - irh "CZEN" "Cosine of solar zenith angle" "" -state real czmean ij dyn_nmm 1 - irh "CZMEAN" "Mean CZEN between SW radiation calls" "" -state real embck ij dyn_nmm 1 - ir "EMBCK" "Background radiative emissivity" "" -state real epsr ij dyn_nmm 1 - irh "EPSR" "Radiative emissivity" "" -state real gffc ij dyn_nmm 1 - ir -state real glat ij dyn_nmm 1 - i01rh "GLAT" "Geographic latitude, radians" "" -state real glon ij dyn_nmm 1 - i01rh "GLON" "Geographic longitude, radians" "" -state real NMM_TSK ij dyn_nmm 1 - i01rd=(DownNear) "TSK" "Skin temperature" "K" -state real hdac ij dyn_nmm 1 - ir "HDAC" "Composite diffusion coeff for mass points" "s m-1" -state real hdacv ij dyn_nmm 1 - ir "HDACV" "Composite diffusion coeff for velocity points" "s m-1" -state real mxsnal ij dyn_nmm 1 - i01rhd=(DownNear) "MXSNAL" "Maximum deep snow albedo" "" -state real radin ij dyn_nmm 1 - r -state real radot ij dyn_nmm 1 - rh "RADOT" "Radiative emission from surface" "W m-2" -state real sigt4 ij dyn_nmm 1 - rhd=(DownCopy) "SIGT4" "Stefan-Boltzmann * T**4" "W m-2" -state real tg ij dyn_nmm 1 - i01rhd=(DownNear) "TGROUND" "Deep ground soil temperature" "K" -state real dfrlg k dyn_nmm 1 Z i01r "DFRLG" "Std atmosphere height of model layer interfaces" "m" -state integer lvl ij dyn_nmm 1 - ir -state integer k22_deep ij misc 1 - - "K22_DEEP" "K22 LEVEL FROM DEEPCONVECTION (G3 only)" "" -state integer kbcon_deep ij misc 1 - - "KBCON_DEEP" "KBCON LEVEL FROM DEEP CONVECTION (G3 only)" "" -state integer ktop_deep ij misc 1 - - "KTOP_DEEP" "KTOP LEVEL FROM DEEP CONVECTION (G3 only)" "" -state real RAINCV_A ij misc 1 - r "RAINCV_A" "taveragd TIME-STEP CUMULUS PRECIPITATION" "mm" -state real RAINCV_B ij misc 1 - r "RAINCV_B" "taveragd TIME-STEP CUMULUS PRECIPITATION" "mm" -state real GD_CLOUD ikj misc 1 - r "GD_CLOUD" "CLOUD WATER/ICE MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2 ikj misc 1 - r "GD_CLOUD2" "TEST for GD CLOUD" "kg kg-1" -state real GD_CLOUD_A ikj misc 1 - r "GD_CLOUD_A" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" -state real GD_CLOUD2_A ikj misc 1 - r "GD_CLOUD2_A" "taveragd cloud ice mix ratio in GD" "kg kg-1" -state real QC_CU ikj misc 1 - r "QC_CU" "CLOUD WATER MIXING RATIO FROM A CU SCHEME" "kg kg-1" -state real QI_CU ikj misc 1 - r "QI_CU" "CLOUD ICE MIXUNG RATIO FROM A CU SCHEME" "kg kg-1" -state real GD_CLDFR ikj misc 1 - r "GD_CLDFR" "GD CLOUD Fraction" " ? " -+# upward and downward clearsky and total diagnostic fluxes for radiation (RRTMG) -state real ACSWUPT ij misc 1 - rhdu "ACSWUPT" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT TOP" "J m-2" -state real ACSWUPTC ij misc 1 - rhdu "ACSWUPTC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" -state real ACSWDNT ij misc 1 - rhdu "ACSWDNT" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT TOP" "J m-2" -state real ACSWDNTC ij misc 1 - rhdu "ACSWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "J m-2" -state real ACSWUPB ij misc 1 - rhdu "ACSWUPB" "ACCUMULATED UPWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" -state real ACSWUPBC ij misc 1 - rhdu "ACSWUPBC" "ACCUMULATED UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" -state real ACSWDNB ij misc 1 - rhdu "ACSWDNB" "ACCUMULATED DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "J m-2" -state real ACSWDNBC ij misc 1 - rhdu "ACSWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "J m-2" -state real ACLWUPT ij misc 1 - rhdu "ACLWUPT" "ACCUMULATED UPWELLING LONGWAVE FLUX AT TOP" "J m-2" -state real ACLWUPTC ij misc 1 - rhdu "ACLWUPTC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" -state real ACLWDNT ij misc 1 - rhdu "ACLWDNT" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT TOP" "J m-2" -state real ACLWDNTC ij misc 1 - rhdu "ACLWDNTC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "J m-2" -state real ACLWUPB ij misc 1 - rhdu "ACLWUPB" "ACCUMULATED UPWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" -state real ACLWUPBC ij misc 1 - rhdu "ACLWUPBC" "ACCUMULATED UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" -state real ACLWDNB ij misc 1 - rhdu "ACLWDNB" "ACCUMULATED DOWNWELLING LONGWAVE FLUX AT BOTTOM" "J m-2" -state real ACLWDNBC ij misc 1 - rhdu "ACLWDNBC" "ACCUMULATED DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "J m-2" -state real SWUPT ij misc 1 - rhdu "SWUPT" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT TOP" "W m-2" -state real SWUPTC ij misc 1 - rhdu "SWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" -state real SWDNT ij misc 1 - rhdu "SWDNT" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT TOP" "W m-2" -state real SWDNTC ij misc 1 - rhdu "SWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT TOP" "W m-2" -state real SWUPB ij misc 1 - rhdu "SWUPB" "INSTANTANEOUS UPWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" -state real SWUPBC ij misc 1 - rhdu "SWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2" -state real SWDNB ij misc 1 - rhdu "SWDNB" "INSTANTANEOUS DOWNWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" -state real SWDNBC ij misc 1 - rhdu "SWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY SHORTWAVE FLUX AT BOTTOM" "W m-2" -state real LWUPT ij misc 1 - rhdu "LWUPT" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT TOP" "W m-2" -state real LWUPTC ij misc 1 - rhdu "LWUPTC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2" -state real LWDNT ij misc 1 - rhdu "LWDNT" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT TOP" "W m-2" -state real LWDNTC ij misc 1 - rhdu "LWDNTC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT TOP" "W m-2" -state real LWUPB ij misc 1 - rhdu "LWUPB" "INSTANTANEOUS UPWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" -state real LWUPBC ij misc 1 - rhdu "LWUPBC" "INSTANTANEOUS UPWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "W m-2" -state real LWDNB ij misc 1 - rhdu "LWDNB" "INSTANTANEOUS DOWNWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" -state real LWDNBC ij misc 1 - rhdu "LWDNBC" "INSTANTANEOUS DOWNWELLING CLEAR SKY LONGWAVE FLUX AT BOTTOM" "Wm-2" -state real SWVISDIR ij misc 1 Z r "SWVISDIR" "SWR VIS DIR component" "" -state real SWVISDIF ij misc 1 Z r "SWVISDIF" "SWR VIS DIF component" "" -state real SWNIRDIR ij misc 1 Z r "SWNIRDIR" "SWR NIR DIR component" "" -state real SWNIRDIF ij misc 1 Z r "SWNIRDIF" "SWR NIR DIF component" "" - -state real refl_10cm ikj dyn_nmm 1 - h "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" -state real REFD_MAX ij misc 1 - h "REFD_MAX" "MAX DERIVED RADAR REFL" "dbZ" -state real qnwfa2d ij misc 1 - rhdu "QNWFA2D" "Surface aerosol number conc emission" "kg-1 s-1" -state real re_cloud ikj misc 1 - r "re_cloud" "Effective radius, cloud drops" "m" -state real re_ice ikj misc 1 - r "re_ice" "Effective radius, cloud ice" "m" -state real re_snow ikj misc 1 - r "re_snow" "Effective radius, snow" "m" -state real dfi_re_cloud ikj misc 1 - - "DFI_RE_CLOUD" "DFI Effective radius cloud water" "m" -state real dfi_re_ice ikj misc 1 - - "DFI_RE_ICE" "DFI Effective radius cloud ice" "m" -state real dfi_re_snow ikj misc 1 - - "DFI_RE_SNOW" "DFI Effective radius snow" "m" -state integer has_reqc - misc 1 - r "has_reqc" "Flag for has effective radius of cloud water" "" -state integer has_reqi - misc 1 - r "has_reqi" "Flag for has effective radius of cloud ice" "" -state integer has_reqs - misc 1 - r "has_reqs" "Flag for has effective radius of snow" "" - -# -# added WRF-Solar -state real swddir ij misc 1 - rhd "SWDDIR" "Shortwave surface downward direct irradiance" "W/m^2" "" -state real swddni ij misc 1 - rhd "SWDDNI" "Shortwave surface downward direct normal irradiance" "W/m^2" "" -state real swddif ij misc 1 - rhd "SWDDIF" "Shortwave surface downward diffuse irradiance" "W/m^2" "" -state real Gx ij misc 1 - rd "Gx" "" "" -state real Bx ij misc 1 - rd "Bx" "" "" -state real gg ij misc 1 - rd "gg" "" "" -state real bb ij misc 1 - rd "bb" "" "" -state real coszen_ref ij misc 1 - - "coszen_ref" "" "" -state real coszen ij misc 1 - - "coszen " "" "" -state real hrang ij misc 1 - - "hrang" "" "" -state real swdown_ref ij misc 1 - - "swdown_ref" "" "" -state real swddir_ref ij misc 1 - - "swddir_ref" "" "" -rconfig integer swint_opt namelist,physics 1 0 - "swint_opt" "interpolation option for sw radiation" "" -# add aerosol namelists -rconfig integer aer_type namelist,physics max_domains 1 irh "aer_type" "aerosol type: 1 is SF79 rural, 2 is SF79 urban" "" -rconfig integer aer_aod550_opt namelist,physics max_domains 1 irh "aer_aod550_opt" "input option for aerosol optical depth at 550 nm" "" -rconfig integer aer_angexp_opt namelist,physics max_domains 1 irh "aer_angexp_opt" "input option for aerosol Angstrom exponent" "" -rconfig integer aer_ssa_opt namelist,physics max_domains 1 irh "aer_ssa_opt" "input option for aerosol single-scattering albedo" "" -rconfig integer aer_asy_opt namelist,physics max_domains 1 irh "aer_asy_opt" "input option for aerosol asymmetry parameter" "" -rconfig real aer_aod550_val namelist,physics max_domains 0.12 irh "aer_aod550_val" "fixed value for aerosol optical depth at 550 nm. Valid when aer_aod550_opt=1" "" -rconfig real aer_angexp_val namelist,physics max_domains 1.3 irh "aer_angexp_val" "fixed value for aerosol Angstrom exponent. Valid when aer_angexp_opt=1" "" -rconfig real aer_ssa_val namelist,physics max_domains 0.85 irh "aer_ssa_val" "fixed value for aerosol single-scattering albedo. Valid when aer_ssa_opt=1" "" -rconfig real aer_asy_val namelist,physics max_domains 0.90 irh "aer_asy_val" "fixed value for aerosol asymmetry parameter. Valid when aer_asy_opt=1" "" - -# module_CLDWTR.F -# -state real cwm ijkb dyn_nmm 1 - rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "CWM" "Total condensate" "kg kg-1" -state real rrw ijkb dyn_nmm 1 - rh "RRW" "Tracer" "kg kg-1" -state real f_ice ikj dyn_nmm 1 - rhd=(DownMassIKJ:@EExtrap,0.0)u=(UpMassIKJ:@EExtrap,0.0) "F_ICE" "Frozen fraction of CWM" "" -state real f_rain ikj dyn_nmm 1 - rhd=(DownMassIKJ:@EExtrap,0.0)u=(UpMassIKJ:@EExtrap,0.0) "F_RAIN" "Rain fraction of liquid part of CWM" "" -state real f_rimef ikj dyn_nmm 1 - rhd=(DownMassIKJ:@EExtrap,1.0)u=(UpMassIKJ:@EExtrap,1.0) "F_RIMEF" "Rime factor" "" -state real cldfra ijk dyn_nmm 1 - rh "CLDFRA" "Cloud fraction" "" -state real sr ij dyn_nmm 1 - irh "SR" "Timestep mass ratio of snow:precip" "" -state real cfrach ij dyn_nmm 1 - rhd=(DownCopy) "CFRACH" "High cloud fraction" "" -state real cfracl ij dyn_nmm 1 - rhd=(DownCopy) "CFRACL" "Low cloud fraction" "" -state real cfracm ij dyn_nmm 1 - rhd=(DownCopy) "CFRACM" "Middle cloud fraction" "" -state logical micro_start - dyn_nmm - - - -# -# module_SOIL.F -# -state integer islope ij dyn_nmm 1 - i01rhd=(DownINear) "ISLOPE" -state real dzsoil k dyn_nmm 1 - irh "DZSOIL" "Thickness of soil layers" "m" -state real rtdpth k dyn_nmm 1 - i01r -state real sldpth k dyn_nmm 1 - i01rh "SLDPTH" "Depths of centers of soil layers" "m" -state real cmc ij dyn_nmm 1 - i01rhd=(DownNear) "CMC" "Canopy moisture" "m" -state real grnflx ij dyn_nmm 1 - irh "GRNFLX" "Deep soil heat flux" "W m-2" -state real pctsno ij dyn_nmm 1 - irh -state real soiltb ij dyn_nmm 1 - i01rhd=(DownNear) "SOILTB" "Deep ground soil temperature" "K" -state real vegfrc ij dyn_nmm 1 - i014rhd=(DownNear) "VEGFRC" "Vegetation fraction" "" -state real shdmin ij dyn_nmm 1 - - -state real shdmax ij dyn_nmm 1 - - -state real sh2o ilj dyn_nmm 1 Z irhd=(DownNearIKJ) "SH2O" "Unfrozen soil moisture volume fraction" "" -state real smc ilj dyn_nmm 1 Z irhd=(DownNearIKJ) "SMC" "Soil moisture volume fraction" "" -state real stc ilj dyn_nmm 1 Z irhd=(DownNearIKJ) "STC" "Soil temperature" "K" -# -# module_GWD.F -# -state real hstdv ij dyn_nmm 1 - i01rh "HSTDV" "Standard deviation of height" "m" -state real hcnvx ij dyn_nmm 1 - i01rh "HCNVX" "Normalized 4th moment of orographic convexity" "" -state real hasyw ij dyn_nmm 1 - i01rh "HASYW" "Orographic asymmetry in W-E plane" "" -state real hasys ij dyn_nmm 1 - i01rh "HASYS" "Orographic asymmetry in S-N plane" "" -state real hasysw ij dyn_nmm 1 - i01rh "HASYSW" "Orographic asymmetry in SW-NE plane" "" -state real hasynw ij dyn_nmm 1 - i01rh "HASYNW" "Orographic asymmetry in NW-SE plane" "" -state real hlenw ij dyn_nmm 1 - i01rh "HLENW" "Orographic length scale in W-E plane" "" -state real hlens ij dyn_nmm 1 - i01rh "HLENS" "Orographic length scale in S-N plane" "" -state real hlensw ij dyn_nmm 1 - i01rh "HLENSW" "Orographic length scale in SW-NE plane" "" -state real hlennw ij dyn_nmm 1 - i01rh "HLENNW" "Orographic length scale in NW-SE plane" "" -state real hangl ij dyn_nmm 1 - i01rh "HANGL" "Angle of the mountain range w/r/t east" "deg" -state real hanis ij dyn_nmm 1 - i01rh "HANIS" "Anisotropy/aspect ratio of orography" "" -state real hslop ij dyn_nmm 1 - i01rh "HSLOP" "Slope of orography" "" -state real hzmax ij dyn_nmm 1 - i01rh "HZMAX" "Maximum height above mean orography" "m" -state real crot ij dyn_nmm 1 - - "CROT" "Cosine of angle between model and earth coordinates" "" -state real srot ij dyn_nmm 1 - - "SROT" "Sine of angle between model and earth coordinates" "" -state real UGWDsfc ij dyn_nmm 1 - h "UGWDsfc" "Surface zonal wind stress due to gravity wave drag" "N m-2" -state real VGWDsfc ij dyn_nmm 1 - h "VGWDsfc" "Surface meridional wind stress due to gravity wave drag" "N m-2" -# -# Additional for topo_wind -# -state real ctopo ij misc 1 - rdu "ctopo" "Correction for topography" "" -state real ctopo2 ij misc 1 - rdu "ctopo2" "Correction for topography 2" "" -# -# module_NHYDRO.F -# -state logical hydro - dyn_nmm - - - "HYDRO" ".FALSE. => nonhydrostatic" "" -state real dwdtmn ij dyn_nmm 1 - - "DWDTMN" "Minimum value for DWDT" "m s-2" -state real dwdtmx ij dyn_nmm 1 - - "DWDTMX" "Maximum value for DWDT" "m s-2" -state real baro ij dyn_nmm 1 - - "BARO" "external mode vvel" "m s-1" -state real dwdt ijk dyn_nmm 1 - rd=(DownCopy) "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" -state real pdwdt ijk dyn_nmm 1 - r -state real pint ijk dyn_nmm 1 Z irhd=(DownCopy)u=(NoInterp)f=(NoInterp) "PINT" "Model layer interface pressure" "Pa" -state real w ijk dyn_nmm 1 Z rd=(DownCopy) "W" "Vertical velocity" "m s-1" -state real w_tot ijk dyn_nmm 1 Z hd=(DownCopy) "W" "Vertical velocity" "m s-1" -state real z ijk dyn_nmm 1 Z - "Z" "Distance from ground" "m" -# -# module_ACCUM.F -# -state real acfrcv ij dyn_nmm 1 - rh "ACFRCV" "Accum convective cloud fraction" "" -state real acfrst ij dyn_nmm 1 - rh "ACFRST" "Accum stratiform cloud fraction" "" -state real ssroff ij dyn_nmm 1 - rh "SSROFF" "Surface runoff" "mm" -state real bgroff ij dyn_nmm 1 - rh "BGROFF" "Subsurface runoff" "mm" -state real rlwin ij dyn_nmm 1 - rhd=(DownCopy) "RLWIN" "Downward longwave at surface" "W m-2" -state real rlwout ij dyn_nmm 1 - - -state real rlwtoa ij dyn_nmm 1 - rh "RLWTOA" "Outgoing LW flux at top of atmos" "W m-2" -state real alwin ij dyn_nmm 1 - rh "ALWIN" "Accum LW down at surface" "W m-2" -state real alwout ij dyn_nmm 1 - rh "ALWOUT" "Accum RADOT (see above)" "W m-2" -state real alwtoa ij dyn_nmm 1 - rh "ALWTOA" "Accum RLWTOA" "W m-2" -state real rswin ij dyn_nmm 1 - rhd=(DownCopy) "RSWIN" "Downward shortwave at surface" "W m-2" -state real rswinc ij dyn_nmm 1 - rh "RSWINC" "Clear-sky equivalent of RSWIN" "W m-2" -state real rswout ij dyn_nmm 1 - rh "RSWOUT" "Upward shortwave at surface" "W m-2" -#for HWRF: add to restart -state real rswtoa ij dyn_nmm 1 - rh "RSWTOA" "Outgoing SW flux at top of atmos" "W m-2" -#end HWRF -state real aswin ij dyn_nmm 1 - rh "ASWIN" "Accum SW down at surface" "W m-2" -state real aswout ij dyn_nmm 1 - rh "ASWOUT" "Accum RSWOUT" "W m-2" -state real aswtoa ij dyn_nmm 1 - r "ASWTOA" "Accum RSWTOA" "W m-2" -state real sfcshx ij dyn_nmm 1 - rh "SFCSHX" "Accum sfc sensible heat flux" "W m-2" -state real sfclhx ij dyn_nmm 1 - rh "SFCLHX" "Accum sfc latent heat flux" "W m-2" -state real subshx ij dyn_nmm 1 - rh "SUBSHX" "Accum deep soil heat flux" "W m-2" -state real snopcx ij dyn_nmm 1 - rh "SNOPCX" "Snow phase change heat flux" "W m-2" -state real sfcuvx ij dyn_nmm 1 - rh -state real potevp ij dyn_nmm 1 - rh "POTEVP" "Accum potential evaporation" "m" -state real potflx ij dyn_nmm 1 - rh "POTFLX" "Energy equivalent of POTEVP" "W m-2" -state real tlmin ij dyn_nmm 1 - rh -state real tlmax ij dyn_nmm 1 - rh -state real t02_min ij dyn_nmm 1 - rh "T02_MIN" "Hourly Min Shelter Temperature" "K" -state real t02_max ij dyn_nmm 1 - rh "T02_MAX" "Hourly Max Shelter Temperature" "K" -state real rh02_min ij dyn_nmm 1 - rh "RH02_MIN" "Hourly Min Relative Humidity" "" -state real rh02_max ij dyn_nmm 1 - rh "RH02_MAX" "Hourly Max Relative Humidity" "" -state real rlwtt ijk dyn_nmm 1 - rhd=(DownNear) "RLWTT" "Longwave temperature tendency" "K s-1" -state real rswtt ijk dyn_nmm 1 - rhd=(DownNear) "RSWTT" "Shortwave temperature tendency" "K s-1" -#for HWRF: add to restart -state real tcucn ijk dyn_nmm 1 - r "TCUCN" "Accum convec temperature tendency" "K s-1" -state real train ijk dyn_nmm 1 - r "TRAIN" "Accum stratiform temp tendency" "K s-1" -#end HWRF -state integer ncfrcv ij dyn_nmm 1 - irh "NCFRCV" "# times convec cloud >0 between rad calls" "" -state integer ncfrst ij dyn_nmm 1 - irh "NCFRST" "# times stratiform cloud >0 between rad calls" "" -state integer nphs0 - dyn_nmm - - rh -state integer ncnvc0 - dyn_nmm - - rh -state integer nprec - dyn_nmm - - irh "NPREC" "# timesteps between resetting precip bucket" "" -state integer nclod - dyn_nmm - - irh "NCLOD" "# timesteps between resetting cloud frac accum" "" -state integer nheat - dyn_nmm - - irh "NHEAT" "# timesteps between resetting latent heat accum" "" -state integer nrdlw - dyn_nmm - - irh "NRDLW" "# timesteps between resetting longwave accums" "" -state integer nrdsw - dyn_nmm - - irh "NRDSW" "# timesteps between resetting shortwave accums" "" -state integer nsrfc - dyn_nmm - - irh "NSRFC" "# timesteps between resetting sfcflux accums" "" -state real avrain - dyn_nmm - - irh "AVRAIN" "# of times gridscale precip called in NHEAT steps" "" -state real avcnvc - dyn_nmm - - irh "AVCNVC" "# of times convective precip called in NHEAT steps" "" -state real aratim - dyn_nmm - - ir -state real acutim - dyn_nmm - - irh -state real ardlw - dyn_nmm - - irh "ARDLW" "# of times LW fluxes summed before resetting" "" -state real ardsw - dyn_nmm - - irh "ARDSW" "# of times SW fluxes summed before resetting" "" -state real asrfc - dyn_nmm - - irh "ASRFC" "# of times sfc fluxes summed before resetting" "" -state real aphtim - dyn_nmm - - irh -# -# module_INDX.F -# -state integer ihe j dyn_nmm 1 - - "IHE" "0 or +1 to obtain I index of V point east of H point" "" -state integer ihw j dyn_nmm 1 - - "IHW" "0 or -1 to obtain I index of V point west of H point" "" -state integer ive j dyn_nmm 1 - - "IVE" "0 or +1 to obtain I index of H point east of V point" "" -state integer ivw j dyn_nmm 1 - - "IVW" "0 or -1 to obtain I index of H point west of V point" "" -state integer irad i dyn_nmm 1 - - -#definitions for NMM east-west orientation on E grid -state integer iheg q dyn_nmm 1 - - -state integer ihwg q dyn_nmm 1 - - -state integer iveg q dyn_nmm 1 - - -state integer ivwg q dyn_nmm 1 - - -state integer iradg r dyn_nmm 1 - - -state integer n_iup_h j dyn_nmm 1 - - "N_IUP_H" "# mass points needed in each row for upstream advection" "" -state integer n_iup_v j dyn_nmm 1 - - "N_IUP_V" "# velocity points needed in each row for upstream advection" "" -state integer n_iup_adh j dyn_nmm 1 - - "N_IUP_ADH" "# mass points in each row of upstream advection" "" -state integer n_iup_adv j dyn_nmm 1 - - "N_IUP_ADV" "# velocity points in each row of upstream advection" "" -state integer iup_h ij dyn_nmm 1 - - -state integer iup_v ij dyn_nmm 1 - - -state integer iup_adh ij dyn_nmm 1 - - -state integer iup_adv ij dyn_nmm 1 - - -state integer imicrogram - misc - - r "imicrogram" "flag 0/1 0=mixratio, 1=mcrograms/m3" "" - -# Interpolation information -state real winfo ijkb dyn_nmm 1 Z hu=(NoInterp)d=(NoInterp) "winfo" "Nest-parent interpolation/extrapolation weight" "" -state integer iinfo ijkb dyn_nmm 1 Z hu=(NoInterp)d=(NoInterp) "iinfo" "Nest-parent interpolation index" "" - -# -# table entries are of the form -#
-# -# Mask for moving nest interpolations -state integer imask_nostag ij misc - -state integer imask_xstag ij misc X -state integer imask_ystag ij misc Y -state integer imask_xystag ij misc XY -# -#--------------------------------------------------------------------------------------------------------------------------------- -# SI - start variables from netCDF format from Standard Initialization, most eventually for use in LSM schemes -#--------------------------------------------------------------------------------------------------------------------------------- - -state real sm000007 ij misc 1 - i1 "SM000007" "LAYER SOIL MOISTURE" "m3 m-3" -state real sm007028 ij misc 1 - i1 "SM007028" "LAYER SOIL MOISTURE" "m3 m-3" -state real sm028100 ij misc 1 - i1 "SM028100" "LAYER SOIL MOISTURE" "m3 m-3" -state real sm100255 ij misc 1 - i1 "SM100255" "LAYER SOIL MOISTURE" "m3 m-3" -state real st000007 ij misc 1 - i1 "ST000007" "LAYER SOIL TEMPERATURE" "K" -state real st007028 ij misc 1 - i1 "ST007028" "LAYER SOIL TEMPERATURE" "K" -state real st028100 ij misc 1 - i1 "ST028100" "LAYER SOIL TEMPERATURE" "K" -state real st100255 ij misc 1 - i1 "ST100255" "LAYER SOIL TEMPERATURE" "K" -state real sm000010 ij misc 1 - i1 "SM000010" "description" "units" -state real sm010040 ij misc 1 - i1 "SM010040 " "description" "units" -state real sm040100 ij misc 1 - i1 "SM040100 " "description" "units" -state real sm100200 ij misc 1 - i1 "SM100200 " "description" "units" -state real sm010200 ij misc 1 - i1 "SM010200" "description" "units" -state real soilm000 ij misc 1 - i1 "SOILM000" "description" "units" -state real soilm005 ij misc 1 - i1 "SOILM005" "description" "units" -state real soilm020 ij misc 1 - i1 "SOILM020" "description" "units" -state real soilm040 ij misc 1 - i1 "SOILM040" "description" "units" -state real soilm160 ij misc 1 - i1 "SOILM160" "description" "units" -state real soilm300 ij misc 1 - i1 "SOILM300" "description" "units" -state real sw000010 ij misc 1 - i1 "SW000010" "description" "units" -state real sw010040 ij misc 1 - i1 "SW010040" "description" "units" -state real sw040100 ij misc 1 - i1 "SW040100" "description" "units" -state real sw100200 ij misc 1 - i1 "SW100200" "description" "units" -state real sw010200 ij misc 1 - i1 "SW010200" "description" "units" -state real soilw000 ij misc 1 - i1 "SOILW000" "description" "units" -state real soilw005 ij misc 1 - i1 "SOILW005" "description" "units" -state real soilw020 ij misc 1 - i1 "SOILW020" "description" "units" -state real soilw040 ij misc 1 - i1 "SOILW040" "description" "units" -state real soilw160 ij misc 1 - i1 "SOILW160" "description" "units" -state real soilw300 ij misc 1 - i1 "SOILW300" "description" "units" -state real st000010 ij misc 1 - i1 "ST000010" "description" "units" -state real st010040 ij misc 1 - i1 "ST010040" "description" "units" -state real st040100 ij misc 1 - i1 "ST040100" "description" "units" -state real st100200 ij misc 1 - i1 "ST100200" "description" "units" -state real st010200 ij misc 1 - i1 "ST010200" "description" "units" -state real soilt000 ij misc 1 - i1 "SOILT000" "description" "units" -state real soilt005 ij misc 1 - i1 "SOILT005" "description" "units" -state real soilt020 ij misc 1 - i1 "SOILT020" "description" "units" -state real soilt040 ij misc 1 - i1 "SOILT040" "description" "units" -state real soilt160 ij misc 1 - i1 "SOILT160" "description" "units" -state real soilt300 ij misc 1 - i1 "SOILT300" "description" "units" -state real landmask ij misc 1 - i01rhd=(DownNear) "LANDMASK" "description" "units" -state real topostdv ij misc 1 - i1 "TOPOSTDV" "description" "units" -state real toposlpx ij misc 1 - i1 "TOPOSLPX" "description" "units" -state real toposlpy ij misc 1 - i1 "TOPOSLPY" "description" "units" -state real greenmax ij misc 1 - i1 "GREENMAX" "description" "units" -state real greenmin ij misc 1 - i1 "GREENMIN" "description" "units" -state real albedomx ij misc 1 - i1 "ALBEDOMX" "description" "units" -state real slopecat ij misc 1 - i1 "SLOPECAT" "description" "units" -state real toposoil ij misc 1 - i1d=(DownNear) "TOPOSOIL" "description" "units" -state real landusef iuj misc 1 Z - "" "description" "units" -state real soilctop isj misc 1 Z - "" "description" "units" -state real soilcbot isj misc 1 Z - "" "description" "units" - -#------------------------------------------------------------------------------------------------------------------------------- -# SI - end variables from netCDF format from Standard Initialization -#------------------------------------------------------------------------------------------------------------------------------- - -# Time series variables -state real ts_hour ?! misc - - - "TS_HOUR" "Model integration time, hours" -state real ts_u ?! misc - - - "TS_U" "Surface wind U-component, earth-relative" -state real ts_v ?! misc - - - "TS_V" "Surface wind V-component, earth-relative" -state real ts_q ?! misc - - - "TS_Q" "Surface mixing ratio" -state real ts_t ?! misc - - - "TS_T" "Surface temperature" -state real ts_psfc ?! misc - - - "TS_PSFC" "Surface pressure" -state real ts_tsk ?! misc - - - "TS_TSK" "Skin temperature" -state real ts_tslb ?! misc - - - "TS_TSLB" "Soil temperature" -state real ts_clw ?! misc - - - "TS_CLW" "Column integrated cloud water" - -#----------------------------------------------------------------------------------------------------------------------------------------------------------------- - - -# Moist Scalars - both height and mass coordinate models -# -# The first line ensures that there will be identifiers named moist and -# moist_tend even if there are not any moist scalars (so the essentially -# dry code will will still link properly) -# -state real - ijkfbt moist 1 m - - -state real qv ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QVAPOR" "Water vapor mixing ratio" "kg kg-1" -state real qc ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QCLOUD" "Cloud water mixing ratio" "kg kg-1" -state real qr ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QRAIN" "Rain water mixing ratio" "kg kg-1" -state real qi ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QICE" "Ice mixing ratio" "kg kg-1" -state real qs ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QSNOW" "Snow mixing ratio" "kg kg-1" -state real qg ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QGRAUP" "Graupel mixing ratio" "kg kg-1" -state real qh ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QHAIL" "Hail mixing ratio" "kg kg-1" - - -state real - ijkfbt dfi_moist 1 m - - -state real dfi_qv ijkfbt dfi_moist 1 m r "QVAPOR" "Water vapor mixing ratio" "kg kg-1" -state real dfi_qc ijkfbt dfi_moist 1 m r "QCLOUD" "Cloud water mixing ratio" "kg kg-1" -state real dfi_qr ijkfbt dfi_moist 1 m r "QRAIN" "Rain water mixing ratio" "kg kg-1" -state real dfi_qi ijkfbt dfi_moist 1 m r "QICE" "Ice mixing ratio" "kg kg-1" -state real dfi_qs ijkfbt dfi_moist 1 m r "QSNOW" "Snow mixing ratio" "kg kg-1" -state real dfi_qg ijkfbt dfi_moist 1 m r "QGRAUP" "Graupel mixing ratio" "kg kg-1" -state real dfi_qh ijkfbt dfi_moist 1 m r "QHAIL" "Hail mixing ratio" "kg kg-1" -state real dfi_qnh ijkfbt dfi_moist 1 m r "QNHAIL" "Hail Number concentration" "# kg(-1)" - - -# -# Other Scalars -state real - ijkftb scalar 1 m - - -state real qni ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNICE" "Ice Number concentration" "# kg(-1)" -state real qt ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QT" "Total condensate mixing ratio" "kg kg-1" -state real qns ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNSNOW" "Snow Number concentration" "# kg(-1)" -state real qnr ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNRAIN" "Rain Number concentration" "# kg(-1)" -state real qng ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNGRAUP" "Graupel Number concentration" "# kg(-1)" -state real qnh ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNHAIL" "Hail Number concentration" "# kg(-1)" -state real qnn ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCCN" "CCN Number concentration" "# kg(-1)" -state real qnc ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" -state real qnwfa ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" -state real qnifa ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" -state real qvolg ikjftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" - - -state real - ijkftb dfi_scalar 1 m - - -state real dfi_qndrop ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNDROP" "DFI Droplet number mixing ratio" "# kg-1" -state real dfi_qni ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNICE" "DFI Ice Number concentration" "# kg-1" -state real dfi_qt ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_CWM" "DFI Total condensate mixing ratio" "kg kg-1" -state real dfi_qns ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNSNOW" "DFI Snow Number concentration" "# kg(-1)" -state real dfi_qnr ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNRAIN" "DFI Rain Number concentration" "# kg(-1)" -state real dfi_qng ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNGRAUPEL" "DFI Graupel Number concentration" "# kg(-1)" -state real dfi_qnn ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNCC" "DFI CNN Number concentration" "# kg(-1)" -state real dfi_qnc ijkftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNCLOUD" "DFI Cloud Number concentration" "# kg(-1)" -state real dfi_qnwfa ikjftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNWFA" "DFI water-friendly aerosol number con" "# kg(-1)" -state real dfi_qnifa ikjftb dfi_scalar 1 m \ - rusdf=(BdyMass:@ECopy,0.0) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" - -#----------------------------------------------------------------------------------------------------------------------------------------------------------------- - -## Chem Scalars - both height and mass coordinate models -# -state real - ikjft chem 1 - - - - -#----------------------------------------------------------------------------------------------------------------------------------------------------------------- - -# specified LBC arrays, first, Eulerian height coordinate model - - -# specified LBC arrays, next, Eulerian mass coordinate model - - -# specified LBC variables shared between the mass and height coordinate models - - -# soil model variables (Note that they are marked as staggered in the vertical dimension -# because they are "fully dimensioned" -- they use every element in that dim - - -# 2m and 10m output diagnostics - - -# lsm State Variables - -state real SMOIS ilj - 1 Z rh "SMOIS" "SOIL MOISTURE" "" -state real TSLB ilj - 1 Z r "TSLB" "SOIL TEMPERATURE" "" -state real lake_depth ij misc 1 - rd=(interp_mask_water_field:lu_index,iswater) "lake_depth" "lake depth" "m" - - -# MYJ PBL variables - - -# gfdl (eta) radiation State Variables - -# eta microphpysics State Variables - - -# new eta microphpysics State Variables - -# some mass-coordinate-model-specific variables - - - - - - -# was em_only - -################################################################# -# Physics Variables (em core) - - - -################################################################# -# Physics Variables (eh core) ; should be same as em - - - - -################################################################# -# variables added for CHEMISTRY compatibility with ARW core - kludge -################################################################# -state real GSW ij misc 1 - - "" "" -state real XLAT ij misc 1 - - "" "" -state real XLONG ij misc 1 - - "" "" -state real XLAND ij misc 1 - - "" "" -state real RAINCV ij misc 1 - - "" "" - -################################################################# -# other misc variables (all cores) -################################################################# - -# added for surface_driver -state real PSFC ij misc 1 - i1rh "PSFC" "SFC PRESSURE" -state real dtbc - misc - - ir "dtbc" "TIME SINCE BOUNDARY READ" "" -state real TH2 ij misc 1 - irh "TH2" "POT TEMP at 2 M" "" -state real T2 ij misc 1 - ir "T2" "TEMP at 2 M" "" -state real U10 ij misc 1 - irh01d=(DownCopy) "U10" "U at 10 M" " " -state real V10 ij misc 1 - irh01d=(DownCopy) "V10" "V at 10 M" " " -state real XICE ij misc 1 - i01rd=(DownNear) "XICE" "SEA ICE" "" -state real ICEDEPTH ij misc 1 - i0124rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ICEDEPTH" "SEA ICE THICKNESS" "m" -state real ALBSI ij misc 1 - i0124rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "ALBSI" "SEA ICE ALBEDO" " " -state real SNOWSI ij misc 1 - i0124rhd=(interp_hnear_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4) "SNOWSI" "SNOW DEPTH ON SEA ICE" "m" -state real LAI ij misc 1 - i0124rh "LAI" "Leaf area index" "area/area" -state real SMSTAV ij misc 1 - irh "SMSTAV" "MOISTURE VARIBILITY" "" -state real SMSTOT ij misc 1 - irh "SMSTOT" "TOTAL SOIL MOISTURE" "" -state real SOLDRAIN ij misc 1 - r "SOLDRAIN" "soil column drainage" "mm" -state real SFCHEADRT ij misc 1 - r "SFCHEADRT" "surface water depth" "mm" -state real INFXSRT ij misc 1 - r "INFXSRT" "time step infiltration excess" "mm" -state real SFCRUNOFF ij misc 1 - rh "SFROFF" "SURFACE RUNOFF" "" -state real UDRUNOFF ij misc 1 - rh "UDROFF" "UNDERGROUND RUNOFF" "" -state integer IVGTYP ij misc 1 - irhd=(DownINear) "IVGTYP" "VEGETATION TYPE" "" -state integer ISLTYP ij misc 1 - irhd=(DownINear) "ISLTYP" "SOIL TYPE" " " -state real VEGFRA ij misc 1 - i014rhd=(DownNear) "VEGFRA" "VEGETATION FRACTION" "" -state real SFCEVP ij misc 1 - irh "SFCEVP" "SURFACE EVAPORATION" "" -state real GRDFLX ij misc 1 - irh "GRDFLX" "GROUND HEAT FLUX" "" -state real ALBBCK ij misc 1 - i0124r "ALBBCK" "BACKGROUND ALBEDO" "NA" -state real SFCEXC ij misc 1 - irh "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" -state real SNOTIME ij misc 1 - r "SNOTIME" "SNOTIME" "" -state real ACSNOW ij misc 1 - irh "ACSNOW" "ACCUMULATED SNOW" "kg m-2" -state real ACSNOM ij misc 1 - irh "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" -state real RMOL ij misc 1 - ir "RMOL" "" "" -state real SNOW ij misc 1 - i01rh "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" -state real CANWAT ij misc 1 - i01rh "CANWAT" "CANOPY WATER" "" -state integer FORCE_SST k misc 1 - - "FORCE_SST" "IF FORCE_SST(1) IS 1, FEED SST FROM PARENT EVERY DT" "" -state real SST ij misc 1 - i014rhd=(DownNear)f=(force_sst_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,FORCE_SST) "SST" "SEA SURFACE TEMPERATURE" "K" -state real UOCE ij misc 1 - i014rh "UOCE" "SEA SURFACE ZONAL CURRENTS" "m s-1" -state real VOCE ij misc 1 - i014rh "VOCE" "SEA SURFACE MERIDIONAL CURRENTS" "m s-1" -state real WEASD ij misc 1 - i01rhd=(DownNear) "WEASD" "WATER EQUIVALENT OF ACCUMULATED SNOW" "kg m-2" -state real ZNT ij misc 1 - irh "ZNT" "TIME-VARYING ROUGHNESS LENGTH" -state real MOL ij misc 1 - ir "MOL" "T* IN SIMILARITY THEORY" "K" -state real NOAHRES ij misc 1 - rh "NOAHRES" "RESIDUAL OF THE NOAH SURFACE ENERGY BUDGET" "W m{-2}" - -state real tke_pbl ijk misc 1 Z r "TKE_PBL" "TKE FROM PBL SCHEME" "m2 s-2" -state real el_pbl ikj misc 1 Z - "EL_PBL" "MIXING LENGTH FROM PBL SCHEME" "m" -state real EXCH_H ikj misc 1 Z r "EXCH_H" "EXCHANGE COEFFICIENTS FOR HEAT" "m2 s-1" -state real EXCH_M ikj misc 1 Z r "EXCH_M" "EXCHANGE COEFFICIENTS FOR MOMENTUM" "m2 s-1" -state real THZ0 ij misc 1 - irhd=(DownCopy) "THZ0" "POT. TEMPERATURE AT TOP OF VISC. SUBLYR" "K" -state real QZ0 ij misc 1 - irhd=(DownCopy) "QZ0" "SPECIFIC HUMIDITY AT TOP OF VISC. SUBLYR" "kg kg-1" -state real UZ0 ij misc 1 - irhd=(DownVel) "UZ0" "U WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" -state real VZ0 ij misc 1 - irhd=(DownVel) "VZ0" "V WIND COMPONENT AT TOP OF VISC. SUBLYR" "m s-1" -state real FLHC ij misc 1 - r "FLHC" "SURFACE EXCHANGE COEFFICIENT FOR HEAT" "" -state real FLQC ij misc 1 - r "FLQC" "SURFACE EXCHANGE COEFFICIENT FOR MOISTURE" "" -state real QSG ij misc 1 - r "QSG" "SURFACE SATURATION WATER VAPOR MIXING RATIO" "kg kg-1" -state real QVG ij misc 1 - r "QVG" "WATER VAPOR MIXING RATIO AT THE SURFACE" "kg kg-1" -state real QCG ij misc 1 - r "QCG" "CLOUD WATER MIXING RATIO AT THE SURFACE" "kg kg-1" -state real DEW ij misc 1 - r "DEW" "DEW MIXING RATIO AT THE SURFACE" "kg kg-1" -state real SOILT1 ij misc 1 - r "SOILT1" "TEMPERATURE INSIDE SNOW " "K" -state real TSNAV ij misc 1 - r "TSNAV" "AVERAGE SNOW TEMPERATURE " "C" -# added as state for HALO_NMM_MG2, mep -state real psfc_out ij dyn_nmm 1 - - -# added as state for HALO_NMM_TURBL, jm -state real UZ0h ij misc 1 - - -state real VZ0h ij misc 1 - - -state real dudt ijk misc 1 - - -state real dvdt ijk misc 1 - - - -state real QSFC ij misc 1 - irh "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" -state real AKHS ij misc 1 - ir "AKHS" "SFC EXCH COEFF FOR HEAT /DELTA Z" "m s-1" -state real AKMS ij misc 1 - ir "AKMS" "SFC EXCH COEFF FOR MOMENTUM /DELTA Z" "m s-1" -i1 real CHKLOWQ ij misc 1 - - "CHKLOWQ" "SURFACE SATURATION FLAG" "" -state real HTOP ij misc 1 - irhd=(DownNear) "HTOP" "TOP OF CONVECTION LEVEL" "" -state real HBOT ij misc 1 - irhd=(DownNear) "HBOT" "BOT OF CONVECTION LEVEL" "" -state real HTOPR ij misc 1 - ird=(DownNear) "HTOPR" "TOP OF CONVECTION LEVEL FOR RADIATION" "" -state real HBOTR ij misc 1 - ird=(DownNear) "HBOTR" "BOT OF CONVECTION LEVEL FOR RADIATION" "" -state real HTOPD ij misc 1 - rh "HTOPD" "TOP DEEP CONVECTION LEVEL" "" -state real HBOTD ij misc 1 - rh "HBOTD" "BOT DEEP CONVECTION LEVEL" "" -state real HTOPS ij misc 1 - rh "HTOPS" "TOP SHALLOW CONVECTION LEVEL" "" -state real HBOTS ij misc 1 - rh "HBOTS" "BOT SHALLOW CONVECTION LEVEL" "" -state REAL CUPPT ij misc 1 - rhd=(DownNear) "CUPPT" "ACCUMULATED CONVECTIVE RAIN SINCE LAST CALL TO THE RADIATION" "" -state REAL CPRATE ij misc 1 - rh "CPRATE" "INSTANTANEOUS CONVECTIVE PRECIPITATION RATE" "" # 1-17-06a -state real F_ICE_PHY ikj misc 1 - - "F_ICE_PHY" "FRACTION OF ICE" "" -state real F_RAIN_PHY ikj misc 1 - - "F_RAIN_PHY" "FRACTION OF RAIN " "" -state real F_RIMEF_PHY ikj misc 1 - - "F_RIMEF_PHY" "MASS RATIO OF RIMED ICE " "" -state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb/hour" -state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL " "mm/hour" -state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W " "mm/hour" -state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm/hour" -state real apr_st ij misc 1 - r "APR_ST" "PRECIP FROM CLOSURE STABILITY " "mm/hour" -state real apr_as ij misc 1 - r "APR_AS" "PRECIP FROM CLOSURE AS-TYPE " "mm/hour" -state real apr_capma ij misc 1 - r "APR_CAPMA" "PRECIP FROM MAX CAP" "mm/hour" -state real apr_capme ij misc 1 - r "APR_CAPME" "PRECIP FROM MEAN CAP" "mm/hour" -state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm/hour" -state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" -state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" - -state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TOTAL ADVECTIVE POTENTIAL TEMPERATURE TENDENCY" "K s-1" -state real RQVFTEN ikj misc 1 - r "RQVFTEN" "TOTAL ADVECTIVE MOISTURE TENDENCY" "kg kg-1 s-1" -state real SNOWH ij misc 1 - i01rhd=(DownCopy) "SNOWH" "PHYSICAL SNOW DEPTH" "m" -state real RHOSN ij misc 1 - i01rd=(DownCopy) "RHOSN" " SNOW DENSITY" "kg m-3" -state real SMFR3D ilj misc 1 Z rh "SMFR3D" "SOIL ICE" "" -state real KEEPFR3DFLAG ilj misc 1 Z r "KEEPFR3DFLAG" "FLAG - 1. FROZEN SOIL YES, 0 - NO" "" -state real rc_mf ikj misc 1 - r "RC_MF" "RC IN THE GRID COMPUTED BY EDKF" "kg/kg" - -# For Noah-MP -rconfig integer dveg namelist,noah_mp 1 4 h "dveg" "dynamic vegetation (1 -> off ; 2 -> on)" "" -rconfig integer opt_crs namelist,noah_mp 1 1 h "opt_crs" "canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis)" "" -rconfig integer opt_btr namelist,noah_mp 1 1 h "opt_btr" "soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB)" "" -rconfig integer opt_run namelist,noah_mp 1 1 h "opt_run" "runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS)" "" -rconfig integer opt_sfc namelist,noah_mp 1 1 h "opt_sfc" "surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97)" "" -rconfig integer opt_frz namelist,noah_mp 1 1 h "opt_frz" "supercooled liquid water (1-> NY06; 2->Koren99)" "" -rconfig integer opt_inf namelist,noah_mp 1 1 h "opt_inf" "frozen soil permeability (1-> NY06; 2->Koren99)" "" -rconfig integer opt_rad namelist,noah_mp 1 3 h "opt_rad" "radiation transfer (1->gap=F(3D,cosz); 2->gap=0; 3->gap=1-Fveg)" "" -rconfig integer opt_alb namelist,noah_mp 1 2 h "opt_alb" "snow surface albedo (1->BATS; 2->CLASS)" "" -rconfig integer opt_snf namelist,noah_mp 1 1 h "opt_snf" "rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah)" "" -rconfig integer opt_tbot namelist,noah_mp 1 2 h "opt_tbot" "lower boundary of soil temperature (1->zero-flux; 2->Noah)" "" -rconfig integer opt_stc namelist,noah_mp 1 1 h "opt_stc" "soil/snow temperature time scheme 1->semi-implicit; 2->full-implicit (original Noah)" "" - -# For WRF Hydro -rconfig integer wrf_hydro derived 1 0 h "wrf_hydro" "descrip" "unit" - -# For Noah UA changes -state real flx4 ij - 1 - h "FLX4" "sensible heat from canopy" "W m{-2}" -state real fvb ij - 1 - h "FVB" "fraction of vegetation with snow below" "" -state real fbur ij - 1 - h "FBUR" "fraction of vegetation covered by snow" "" -state real fgsn ij - 1 - h "FGSN" "fraction of ground covered by snow" "" - -# For Noah-MP -state integer isnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "isnow" "no. of snow layer" "m3 m-3" -state real tvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tv" "vegetation leaf temperature" "K" -state real tgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tg" "bulk ground temperature" "K" -state real canicexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "canice" "intercepted ice mass" "mm" -state real canliqxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "canliq" "intercepted liquid water" "mm" -state real eahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "eah" "canopy air vapor pressure" "pa" -state real tahxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tah" "canopy air temperature" "K" -state real cmxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "cm" "surf. exchange coeff. for momentum" "m/s" -state real chxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ch" "surf. exchange coeff. for heat" "m/s" -state real fwetxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fwet" "wetted or snowed canopy fraction" "-" -state real sneqvoxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sneqvo" "snow mass at last time step" "mm" -state real alboldxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "albold" "snow albedo at last timestep" "-" -state real qsnowxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "qsnowxy" "snowfall on the ground" "mm/s" -state real wslakexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wslake" "lake water storage" "mm" -state real zwtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "zwt" "water table depth" "m" -state real waxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wa" "water in the acquifer" "mm" -state real wtxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wt" "groundwater storage" "mm" -state real tsnoxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tsno" "snow temperature" "K" -state real zsnsoxy i{snsl}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "zsnso" "layer-bottom depth from snow surf" "m" -state real snicexy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "snice" "snow layer ice" "mm" -state real snliqxy i{snly}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "snliq" "snow layer liquid" "mm" -state real lfmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "lfmass" "leaf mass" "g/m2" -state real rtmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rtmass" "mass of fine roots" "g/m2" -state real stmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "stmass" "stem mass" "g/m2" -state real woodxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wood" "mass of wood" "g/m2" -state real stblcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "stblcp" "stable carbon pool" "g/m2" -state real fastcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fastcp" "short-lived carbon" "g/m2" -state real xsaixy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "xsai" "stem area index" "-" -state real taussxy ij - 1 - rh "tauss" "non-dimensional snow age" "" -state real t2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "t2v" "2 meter temperature over canopy" "K" -state real t2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "t2b" "2 meter temperature over bare ground" "K" -state real q2mvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "q2v" "2 meter mixing ratio over canopy" "kg kg-1" -state real q2mbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "q2b" "2 meter mixing ratio over bare ground" "kg kg-1" -state real tradxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "trad" "surface radiative temperature" "K" -state real neexy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "nee" "net ecosystem exchange" "g/m2/s CO2" -state real gppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "gpp" "gross primary productivity" "g/m2/s C" -state real nppxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "npp" "net primary productivity" "g/m2/s C" -state real fvegxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fveg" "Noah-MP vegetation fraction" "" -state real qinxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "qin" "groundwater recharge" "mm/s" -state real runsfxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "runsf" "surface runoff" "mm/s" -state real runsbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "runsb" "subsurface runoff" "mm/s" -state real ecanxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ecan" "evaporation of intercepted water" "mm/s" -state real edirxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "edir" "ground surface evaporation rate" "mm/s" -state real etranxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "etran" "transpiration rate" "mm/s" -state real fsaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fsa" "total absorbed solar radiation" "W/m2" -state real firaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "fira" "total net longwave rad" "W/m2" -state real aparxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "apar" "photosyn active energy by canopy" "W/m2" -state real psnxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "psn" "total photosynthesis" "umol co2/m2/s" -state real savxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sav" "solar rad absorbed by veg" "W/m2" -state real sagxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "sag" "solar rad absorbed by ground" "W/m2" -state real rssunxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rssun" "sunlit stomatal resistance" "s/m" -state real rsshaxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "rssha" "shaded stomatal resistance" "s/m" -state real bgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "bgap" "between canopy gap" "fraction" -state real wgapxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "wgap" "within canopy gap" "fraction" -state real tgvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tgv" "ground temp. under canopy""K" -state real tgbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tgb" "bare ground temperature" "K" -state real chvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv" "vegetated heat exchange coefficient" "m/s" -state real chbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb" "bare-ground heat exchange coefficient" "m/s" -state real shgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shg" "sensible heat flux: ground to canopy" "W/m2" -state real shcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shc" "sensible heat flux: leaf to canopy" "W/m2" -state real shbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "shb" "sensible heat flux: bare grnd to atmo" "W/m2" -state real evgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evg" "latent heat flux: ground to canopy" "W/m2" -state real evbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evb" "latent heat flux: bare grnd to atmo" "W/m2" -state real ghvxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ghv" "heat flux into soil: under canopy" "W/m2" -state real ghbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "ghb" "heat flux into soil: bare fraction" "W/m2" -state real irgxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irg" "net longwave at below canopy surface" "W/m2" -state real ircxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irc" "net longwave in canopy" "W/m2" -state real irbxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "irb" "net longwave at bare fraction surface" "W/m2" -state real trxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "tr" "transpiration" "W/m2" -state real evcxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "evc" "canopy evaporation" "W/m2" -state real chleafxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chleaf" "leaf exchange coefficient" "m/s" -state real chucxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chuc" "under canopy exchange coefficient" "m/s" -state real chv2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chv2" "leaf exchange coefficient" "m/s" -state real chb2xy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chb2" "under canopy exchange coefficient" "m/s" -state real chstarxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "chstar" "dummy exchange coefficient" "m/s" -state real SMOISEQ ilj - 1 Z r "SMOISEQ" "EQ. SOIL MOISTURE" "m3 m-3" -state real smcwtdxy ij - 1 - rh "smcwtd" "deep soil moisture " "m3 m-3" -state real rechxy ij - 1 - h "rech" "water table recharge" "mm" -state real deeprechxy ij - 1 - r "deeprech" "deep water table recharge" "mm" - -# added state for etampnew microphysics (needed for restarts) -state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" -state real tbpvs_state p misc 1 - r "TBPVS_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" -state real tbpvs0_state p misc 1 - r "TBPVS0_STATE" "STATE FOR ETAMPNEW MICROPHYSICS" - -# State variables for landuse_init, Must be declared state because the are read in and needed for restarts. Had been SAVE vars in -# landuse_init (phys/module_physics_init.F) -state integer landuse_isice - misc - - - -state integer landuse_lucats - misc - - - -state integer landuse_luseas - misc - - - -state integer landuse_isn - misc - - - -state real lu_state p misc - - - - - -################################################################# -# - -state integer number_at_same_level - - - - - "number_at_same_level" "" "" -state real power ij misc 1 - irh "Power" "Power production" "W" - -# State for derived time quantities. -#for HWRF: add to restart -state integer itimestep - - - - rh "itimestep" "" "" -state real xtime - - - - h "xtime" "minutes since simulation start" "" -state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" - -# input file descriptor for lbcs on parent domain -state integer lbc_fid - - - - - "lbc_fid" "" "" - -# indicates if tiling has been computed -state logical tiled - - - - - "tiled" "" "" -# indicates if patches have been computed -state logical patched - - - - - "patched" "" "" -# indicates whether to read input from file or generate -#state logical input_from_file - - - - - "input_from_file" "" "" - -# vortex center indices; need for restarts of moving nests -state real xi - misc - - r -state real xj - misc - - r -state real vc_i - misc - - r -state real vc_j - misc - - r - -###### -# -# Variables that are set at run-time to control configuration (namelist-settable) -# -#
- - -# Time Control -rconfig integer run_days namelist,time_control 1 0 irh "run_days" "NUMBER OF DAYS TO RUN" -rconfig integer run_hours namelist,time_control 1 0 irh "run_hours" "NUMBER OF HOURS TO RUN" -rconfig integer run_minutes namelist,time_control 1 0 irh "run_minutes" "NUMBER OF MINUTES TO RUN" -rconfig integer run_seconds namelist,time_control 1 0 irh "run_seconds" "NUMBER OF SECONDS TO RUN" -rconfig integer start_year namelist,time_control max_domains 1993 irh "start_year" "4 DIGIT YEAR OF START OF MODEL" "YEARS" -rconfig integer start_month namelist,time_control max_domains 03 irh "start_month" "2 DIGIT MONTH OF THE YEAR OF START OF MODEL, 1-12" "MONTHS" -rconfig integer start_day namelist,time_control max_domains 13 irh "start_day" "2 DIGIT DAY OF THE MONTH OF START OF MODEL, 1-31" "DAYS" -rconfig integer start_hour namelist,time_control max_domains 12 irh "start_hour" "2 DIGIT HOUR OF THE DAY OF START OF MODEL, 0-23" "HOURS" -rconfig integer start_minute namelist,time_control max_domains 00 irh "start_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF MODEL, 0-59" "MINUTES" -rconfig integer start_second namelist,time_control max_domains 00 irh "start_second" "2 DIGIT SECOND OF THE MINUTE OF START OF MODEL, 0-59" "SECONDS" -rconfig integer end_year namelist,time_control max_domains 1993 irh "end_year" "4 DIGIT YEAR OF END OF MODEL" "YEARS" -rconfig integer end_month namelist,time_control max_domains 03 irh "end_month" "2 DIGIT MONTH OF THE YEAR OF END OF MODEL, 1-12" "MONTHS" -rconfig integer end_day namelist,time_control max_domains 14 irh "end_day" "2 DIGIT DAY OF THE MONTH OF END OF MODEL, 1-31" "DAYS" -rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" -rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" -rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" -rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" -rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" -rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 11, WHAT INPUT STREAM IS FINE GRID IC FROM" "" - -include registry.io_boilerplate - -#for HWRF: added a 'r' for restart -rconfig integer JULYR namelist,time_control max_domains 0 hr "JULYR" "" "" -rconfig integer JULDAY namelist,time_control max_domains 1 hr "JULDAY" "" "" -rconfig real GMT namelist,time_control max_domains 0. hr "GMT" "" "" -#for HWRF: end -rconfig character input_inname namelist,time_control 1 "wrfinput_d" - "name of input infile" "" "" -rconfig character input_outname namelist,time_control 1 "wrfinput_d" - "name of input outfile" "" "" -rconfig character bdy_inname namelist,time_control 1 "wrfbdy_d" - "name of boundary infile" "" "" -rconfig character bdy_outname namelist,time_control 1 "wrfbdy_d" - "name of boundary outfile" "" "" -rconfig character rst_inname namelist,time_control 1 "wrfrst_d_" - "name of restrt infile" "" "" -rconfig character rst_outname namelist,time_control 1 "wrfrst_d_" - "name of restrt outfile" "" "" -#for HWRF: -rconfig character anl_outname namelist,time_control max_domains "wrfanl_d_" - "name of analysis outfile" "" "" -rconfig logical write_input namelist,time_control 1 .false. - "write input data for 3dvar etc." "" "" -rconfig logical write_restart_at_0h namelist,time_control 1 .false. h "write_restart_at_0h" "" "" -rconfig logical write_hist_at_0h_rst namelist,time_control 1 .false. h "write_hist_at_0h_rst" "T/F write hist at 0 h of restarted forecast" -rconfig logical adjust_output_times namelist,time_control 1 .false. - "adjust_output_times" -rconfig logical adjust_input_times namelist,time_control 1 .false. - "adjust_input_times" -rconfig real tstart namelist,time_control max_domains 0. irh "tstart" "forecast hour at the start of the NMM integration" -rconfig logical nocolons namelist,time_control 1 .false. - "nocolons" -rconfig logical cycling namelist,time_control 1 .false. - "true for cycling (using wrfout file as input data)" - -# DFI namelist -rconfig integer dfi_opt namelist,dfi_control 1 0 rh "dfi_opt" "" "" -rconfig integer dfi_nfilter namelist,dfi_control 1 7 rh "dfi_nfilter" "Digital filter type" "" -rconfig logical dfi_write_filtered_input namelist,dfi_control 1 .true. rh "dfi_write_filtered_input" "Write a wrfinput_filtered_d0n file?" "" -rconfig logical dfi_write_dfi_history namelist,dfi_control 1 .false. rh "dfi_write_dfi_history" "Write history files during filtering?" "" -rconfig integer dfi_cutoff_seconds namelist,dfi_control 1 3600 rh "dfi_cutoff_seconds" "Digital filter cutoff time" "" -rconfig integer dfi_time_dim namelist,dfi_control 1 1000 rh "dfi_time_dim" "MAX DIMENSION FOR HCOEFF" -rconfig integer dfi_fwdstop_year namelist,dfi_control 1 2004 rh "dfi_fwdstop_year" "4 DIGIT YEAR OF START OF DFI" "YEARS" -rconfig integer dfi_fwdstop_month namelist,dfi_control 1 03 rh "dfi_fwdstop_month" "2 DIGIT MONTH OF THE YEAR OF START OF DFI" "MONTHS" -rconfig integer dfi_fwdstop_day namelist,dfi_control 1 13 rh "dfi_fwdstop_day" "2 DIGIT DAY OF THE MONTH OF START OF DFI" "DAYS" -rconfig integer dfi_fwdstop_hour namelist,dfi_control 1 12 rh "dfi_fwdstop_hour" "2 DIGIT HOUR OF THE DAY OF START OF DFI" "HOURS" -rconfig integer dfi_fwdstop_minute namelist,dfi_control 1 00 rh "dfi_fwdstop_minute" "2 DIGIT MINUTE OF THE HOUR OF START OF DFI" "MINUTES" -rconfig integer dfi_fwdstop_second namelist,dfi_control 1 00 rh "dfi_fwdstop_second" "2 DIGIT SECOND OF THE MINUTE OF START OF DFI" "SECONDS" -rconfig integer dfi_bckstop_year namelist,dfi_control 1 2004 rh "dfi_bckstop_year" "4 DIGIT YEAR OF END OF DFI" "YEARS" -rconfig integer dfi_bckstop_month namelist,dfi_control 1 03 rh "dfi_bckstop_month" "2 DIGIT MONTH OF THE YEAR OF END OF DFI" "MONTHS" -rconfig integer dfi_bckstop_day namelist,dfi_control 1 14 rh "dfi_bckstop_day" "2 DIGIT DAY OF THE MONTH OF END OF DFI" "DAYS" -rconfig integer dfi_bckstop_hour namelist,dfi_control 1 12 rh "dfi_bckstop_hour" "2 DIGIT HOUR OF THE DAY OF END OF DFI" "HOURS" -rconfig integer dfi_bckstop_minute namelist,dfi_control 1 00 rh "dfi_bckstop_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF DFI" "MINUTES" -rconfig integer dfi_bckstop_second namelist,dfi_control 1 00 rh "dfi_bckstop_second" "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS" - -# Domains -rconfig integer time_step namelist,domains 1 - ih "time_step" -rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" -rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" -rconfig integer time_step_dfi namelist,domains 1 - ih "time_step_dfi" -rconfig integer max_dom namelist,domains 1 1 irh "max_dom" "" "" -rconfig integer s_we namelist,domains max_domains 1 irh "s_we" "" "" -rconfig integer e_we namelist,domains max_domains 32 irh "e_we" "" "" -rconfig integer s_sn namelist,domains max_domains 1 irh "s_sn" "" "" -rconfig integer e_sn namelist,domains max_domains 32 irh "e_sn" "" "" -rconfig integer s_vert namelist,domains max_domains 1 irh "s_vert" "" "" -rconfig integer e_vert namelist,domains max_domains 31 irh "e_vert" "" "" -rconfig integer num_metgrid_soil_levels namelist,domains 1 4 irh "num_metgrid_soil_levels" "number of input levels or layers in 3D sm, st, sw arrays" "" -rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" -rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" -rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" -rconfig logical grid_allowed namelist,domains max_domains .true. irh "allowed" "" "" -rconfig integer parent_id namelist,domains max_domains 0 h "parent_id" "" "" -rconfig integer i_parent_start namelist,domains max_domains 1 h "i_parent_start" "" "" -rconfig integer j_parent_start namelist,domains max_domains 1 h "j_parent_start" "" "" -rconfig integer parent_grid_ratio namelist,domains max_domains 1 h "parent_grid_ratio" "" "" -rconfig integer parent_time_step_ratio namelist,domains max_domains 1 h "parent_time_step_ratio" "" "" -rconfig integer feedback namelist,domains 1 0 h "feedback" "" "" -rconfig integer smooth_option namelist,domains 1 2 h "smooth_option" "" "" -rconfig real ztop namelist,domains max_domains 15000. h "ztop" "" "" -rconfig integer moad_grid_ratio namelist,domains max_domains 1 h "moad_grid_ratio" "" "" -rconfig integer moad_time_step_ratio namelist,domains max_domains 1 h "moad_time_step_ratio" "" "" -rconfig integer shw namelist,domains max_domains 2 h "stencil_half_width" "HORIZONTAL INTERPOLATION STENCIL HALF-WIDTH" "GRID POINTS" -rconfig integer tile_sz_x namelist,domains 1 0 - "tile_sz_x" "" "" -rconfig integer tile_sz_y namelist,domains 1 0 - "tile_sz_y" "" "" -rconfig integer numtiles namelist,domains 1 1 - "numtiles" "" "" -rconfig integer numtiles_inc namelist,domains 1 0 - "numtiles_inc" "" "" -rconfig integer numtiles_x namelist,domains 1 0 - "numtiles_x" "" "" -rconfig integer numtiles_y namelist,domains 1 0 - "numtiles_y" "" "" -rconfig integer tile_strategy namelist,domains 1 0 - "tile_strategy" "" "" -rconfig integer nproc_x namelist,domains 1 -1 - "nproc_x" "-1 means not set" "" -rconfig integer nproc_y namelist,domains 1 -1 - "nproc_y" "-1 means not set" "" -rconfig integer irand namelist,domains 1 0 - "irand" "" "" -rconfig real dt derived max_domains 2. h "dt" "TEMPORAL RESOLUTION" "SECONDS" -rconfig integer ts_buf_size namelist,domains 1 200 - "ts_buf_size" "Size of time series buffer" -rconfig integer max_ts_locs namelist,domains 1 5 - "max_ts_locs" "Maximum number of time series locations" -rconfig integer num_moves namelist,domains 1 0 -rconfig integer vortex_interval namelist,domains max_domains 15 - "" "" "minutes" -rconfig integer corral_dist namelist,domains max_domains 8 -rconfig integer move_id namelist,domains max_moves 0 -rconfig integer move_interval namelist,domains max_moves 999999999 -rconfig integer move_cd_x namelist,domains max_moves 0 -rconfig integer move_cd_y namelist,domains max_moves 0 -rconfig logical swap_x namelist,domains max_domains .false. rh "swap_x" "" "" -rconfig logical swap_y namelist,domains max_domains .false. rh "swap_y" "" "" -rconfig logical cycle_x namelist,domains max_domains .false. rh "cycle_x" "" "" -rconfig logical cycle_y namelist,domains max_domains .false. rh "cycle_y" "" "" -rconfig logical reorder_mesh namelist,domains 1 .false. rh "reorder_mesh" "" "" -rconfig logical perturb_input namelist,domains 1 .false. h "" "" "" -# WPS related -rconfig real eta_levels namelist,domains max_eta -1. -rconfig real ptsgm namelist,domains 1 42000. -rconfig integer num_metgrid_levels namelist,domains 1 43 irh "num_metgrid_levels" "" "" -rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" -rconfig logical use_prep_hybrid namelist,domains 1 .false. irh "T=GFS spectral sigma files were used" "" "" - -# Physics -rconfig integer mp_physics namelist,physics max_domains 0 rh "mp_physics" "" "" -#for HWRF: -rconfig real mommix namelist,physics max_domains 0.7 irh "MOMENTUM MIXING FOR SAS CONVECTION SCHEME" -rconfig logical disheat namelist,physics max_domains .true. irh "nmm input 7" -rconfig integer vortex_tracker namelist,physics max_domains 1 - "vortex_tracker" "Vortex Tracking Algorithm" "" -#end HWRF: -rconfig integer do_radar_ref namelist,physics 1 0 rh "compute radar reflectivity for a number of schemes" -rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" -rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" -rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" -rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" -rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" -rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" -rconfig integer windfarm_opt namelist,physics max_domains 0 rh "windfarm_opt" "" "" -rconfig integer windfarm_ij namelist,physics 1 0 rh "windfarm_ij" "" "" -rconfig integer mfshconv namelist,physics max_domains 1 rh "mfshconv" "To activate mass flux scheme with qnse, 1=true; 0=false" "" -rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" -rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" -rconfig integer shcu_physics namelist,physics max_domains 0 rh "shcu_physics" "" "" -rconfig integer cu_diag namelist,physics max_domains 0 rh "cu_diag" " additional t-averaged stuff for cuphys" "" -rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" -rconfig real GSMDT namelist,physics max_domains 0 h "GSMDT" "" "" -rconfig integer ISFFLX namelist,physics 1 1 irh "ISFFLX" "" "" -rconfig integer IFSNOW namelist,physics 1 1 irh "IFSNOW" "" "" -rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" -rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" -rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=hybrid (not yet implemented)" "" -rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" -rconfig integer num_urban_layers namelist,physics 1 400 irh "num_urban_layers" "" "" -rconfig integer num_urban_hi namelist,physics 1 15 irh "num_urban_hi" "" "" -rconfig integer sf_surface_mosaic namelist,physics 1 0 rh "sf_surface_mosaic" "1= mosaic, 0=no mosaic method, add by danli" "" -rconfig integer mosaic_cat namelist,physics 1 3 rh "mosaic_cat" "works when sf_surface_mosaic=1; it is the number of mosaic tiles" "" -rconfig integer mosaic_cat_soil derived 1 12 rh "mosaic_cat_soil" "should be the number of soil layers times the mosaic_cat" "" -rconfig integer mosaic_lu namelist,physics 1 0 irh "mosaic_lu" "" "" -rconfig integer mosaic_soil namelist,physics 1 0 irh "mosaic_soil" "" "" -rconfig integer maxiens namelist,physics 1 1 irh "maxiens" "" "" -rconfig integer maxens namelist,physics 1 3 irh "maxens" "" "" -rconfig integer maxens2 namelist,physics 1 3 irh "maxens2" "" "" -rconfig integer maxens3 namelist,physics 1 16 irh "maxens3" "" "" -rconfig integer ensdim namelist,physics 1 144 irh "ensdim" "" "" -rconfig integer chem_opt namelist,physics max_domains 0 rh "chem_opt" "" "" -rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" -rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" -rconfig integer topo_wind namelist,physics max_domains 0 - "topo_wind" "2: Use Mass sfc drag scheme, 1: improve effects topography over surface wind, 0:not" "" -rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" -rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" -rconfig real seaice_threshold namelist,physics 1 100 h "seaice_threshold" "tsk below which which water points are set to sea ice for slab scheme" "K" -rconfig integer fractional_seaice namelist,physics 1 0 - "fractional_seiace" "Fractional sea-ice option" -rconfig integer seaice_albedo_opt namelist,physics 1 0 - "seaice_albedo_opt" "Method for setting albedo over sea ice" -rconfig real seaice_albedo_default namelist,physics 1 0.65 - "seaice_albedo_default" "Default value for sea-ice over albedo with seaice_albeo_opt=0" -rconfig integer seaice_snowdepth_opt namelist,physics 1 0 - "seaice_snowdepth_opt" "Method for treating snow depth on sea ice" -rconfig real seaice_snowdepth_max namelist,physics 1 1.E10 - "seaice_snowdepth_max" "Maximum allowed accumulation (m) of snow on sea ice" -rconfig real seaice_snowdepth_min namelist,physics 1 0.001 - "seaice_snowdepth_min" "Minimum snow depth (m) on sea ice" -rconfig integer seaice_thickness_opt namelist,physics 1 0 - "seaice_thickness_opt" "Method for setting sea-ice thickness" -rconfig real seaice_thickness_default namelist,physics 1 3.0 - "seaice_thickness_default" "Default value for sea-ice thickness" -rconfig logical tice2tsk_if2cold namelist,physics 1 .false. - "tice2tsk_if2cold" "Avoid low ice temps when ice frac and Tsk are inconsistent" -rconfig integer sst_update namelist,physics 1 0 i01rh "sst_update" "update sst from wrflowinp file 0=no, 1=yes" "" -rconfig integer sf_urban_physics namelist,physics max_domains 0 h "sf_urban_physics" "activate urban model 0=no, 1=Noah_UCM 2=BEP_UCM" "" -rconfig logical usemonalb namelist,physics 1 .true. h "usemonalb" "use 2d field vs table values false=table, True=2d" "" -rconfig logical rdmaxalb namelist,physics 1 .true. h "rdmaxalb" "false set it to table values" "" -rconfig logical rdlai2d namelist,physics 1 .false. h "rdlai2d" "false set it to table values" "" -rconfig logical ua_phys namelist,physics 1 .false. h "ua_phys" "activate UA Noah changes" "" -rconfig integer gwd_opt namelist,physics max_domains 0 irh "gwd_opt" "activate gravity wave drag: 0=off, 1=ARW, 2=NMM" "" -rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" -rconfig real sas_pgcon namelist,physics max_domains 0.55 irh "sas_pgcon" "convectively forced pressure gradient factor (SAS scheme)" "" -rconfig real sas_shal_pgcon namelist,physics max_domains -1 irh "sas_shal_pgcon" "convectively forced pressure gradient factor, -1 means use sas_pgcon (SAS shallow conv)" "" -rconfig integer sas_shal_conv namelist,physics max_domains 0 - "sas_shal_conv" "1=enable shallow convection in SAS (must use bl_pbl_physics=83)" -rconfig real sas_mass_flux namelist,physics max_domains 9e9 - "sas_mass_flux" "mass flux limit (SAS scheme)" "" -rconfig integer random_seed namelist,physics max_domains 0 irh "random_seed" "random number generator seed" - -# nmm variables -rconfig integer idtad namelist,physics max_domains 2 irh "idtad" "fundamental timesteps between calls to NMM passive advection scheme" -rconfig integer nsoil namelist,physics max_domains 4 irh "nsoil" "number of soil layers" -rconfig integer nphs namelist,physics max_domains 10 irh "nphs" "fundamental timesteps between calls to NMM turbulence" -rconfig integer ncnvc namelist,physics max_domains 10 irh "ncnvc" "fundamental timesteps between calls to NMM convection" -rconfig integer nrand namelist,physics max_domains 10 irh "nrand" "fundamental timesteps between random number generator updates (0=use ncnvc)" -rconfig integer nrads namelist,physics max_domains 200 irh "nrads" "fundamental timesteps between calls to NMM shortwave radiation" -rconfig integer nradl namelist,physics max_domains 200 irh "nradl" "fundamental timesteps between calls to NMM longwave radiation" -rconfig real tprec namelist,physics max_domains 385. irh "tprec" "number of hours in bucket for total precipitation" -rconfig real theat namelist,physics max_domains 385. irh "theat" "number of hours in bucket for gridscale and convective heating rates" -rconfig real tclod namelist,physics max_domains 385. irh "tclod" "number of hours in bucket for cloud amounts" -rconfig real trdsw namelist,physics max_domains 385. irh "trdsw" "number of hours in bucket for short wave fluxes" -rconfig real trdlw namelist,physics max_domains 385. irh "trdlw" "number of hours in bucket for long wave fluxes" -rconfig real tsrfc namelist,physics max_domains 385. irh "tsrfc" "number of hours in bucket for evaporation / sfc fluxes" -rconfig logical pcpflg namelist,physics max_domains .false. irh "pcpflg" "logical switch that turns on/off the precipitation assimilation" -rconfig integer sigma namelist,physics max_domains 1 irh "sigma" "logical switch for NMM vertical coordinate (sigma or hybrid)" -rconfig real sfenth namelist,physics max_domains 0.0 irh "sea spray parameter" -rconfig integer co2tf namelist,physics 1 0 - "co2tf" "GFDL radiation co2 flag" -rconfig integer ra_call_offset namelist,physics 1 -1 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" -rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" -rconfig integer levsiz namelist,physics 1 1 - "levsiz" "Number of ozone data levels for CAM radiation (59)" "" -rconfig integer paerlev namelist,physics 1 1 - "paerlev" "Number of aerosol data levels for CAM radiation (29)" "" -rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" -rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" -rconfig integer no_src_types namelist,physics 1 1 - "no_src_types" "Number of aerosoal types from EC (6)" "" -rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" -rconfig integer o3input namelist,physics 1 0 - "o3input" "ozone input option for radiation" "" -rconfig integer aer_opt namelist,physics 1 0 - "aer_opt" "aerosol input option for radiation" "" -rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback of cumulus cloud to radiation" -rconfig integer ICLOUD_CU derived 1 0 - "ICLOUD_CU" "" "" -rconfig real h_diff namelist,physics max_domains 0.1 irh "nmm input 9" -rconfig integer movemin namelist,physics max_domains 0 irh "nmm input 12" -rconfig integer num_snso_layers namelist,physics 1 7 irh "num_snso_layers" "" "" -rconfig integer num_snow_layers namelist,physics 1 3 irh "num_snow_layers" "" "" -rconfig logical use_aero_icbc namelist,physics 1 .false. rh "use_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero" "logical flag" -rconfig integer sf_lake_physics namelist,physics max_domains 0 h "sf_lake_physics" "activate lake model 0=no, 1=yes" "" - - -# Dynamics -# dynamics option (see package definitions, below) -rconfig integer dyn_opt namelist,dynamics 1 - -rconfig integer rk_ord namelist,dynamics 1 3 irh "rk_order" "" "" -rconfig integer w_damping namelist,dynamics 1 0 irh "w_damping" "" "" -# diff_opt 1=old diffusion, 2=new -rconfig integer diff_opt namelist,dynamics max_domains -1 irh "diff_opt" "" "" -# km_opt 1=old coefs, 2=tke, 3=Smagorinksy -rconfig integer km_opt namelist,dynamics max_domains -1 irh "km_opt" "" "" -rconfig integer damp_opt namelist,dynamics 1 1 irh "damp_opt" "" "" -rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" -rconfig real base_pres namelist,dynamics 1 100000. h "base_pres" "Base state pressure - do not change (10^5 Pa), real only" "Pa" -rconfig real base_temp namelist,dynamics 1 290. h "base_temp" "Base state sea level temperature, real only" "K" -rconfig real base_lapse namelist,dynamics 1 50. h "base_lapse" "Base state temperature difference between base pres and 1/e of atm depth - do not change, real only" "K" -rconfig real iso_temp namelist,dynamics 1 0. h "iso_temp" "Isothermal temperature in stratosphere, real only" "K" -rconfig real dampcoef namelist,dynamics max_domains 0.2 h "dampcoef" "" "" -rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" -rconfig real kvdif namelist,dynamics max_domains 0 h "kvdif" "" "" -rconfig real c_s namelist,dynamics max_domains 0.25 h "c_s" "Smagorinsky coeff" "" -rconfig real c_k namelist,dynamics max_domains 0.15 h "c_k" "TKE coeff" "" -rconfig real smdiv namelist,dynamics max_domains 0. h "smdiv" "" "" -rconfig real emdiv namelist,dynamics max_domains 0. h "emdiv" "" "" -rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" -rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" -rconfig integer time_step_sound namelist,dynamics max_domains 10 h "time_step_sound" "" "" -rconfig integer h_mom_adv_order namelist,dynamics max_domains 3 rh "h_mom_adv_order" "" "" -rconfig integer v_mom_adv_order namelist,dynamics max_domains 3 rh "v_mom_adv_order" "" "" -rconfig integer h_sca_adv_order namelist,dynamics max_domains 3 rh "h_sca_adv_order" "" "" -rconfig integer v_sca_adv_order namelist,dynamics max_domains 3 rh "v_sca_adv_order" "" "" -rconfig logical top_radiation namelist,dynamics max_domains .false. rh "top_radiation" "" "" -rconfig real tke_upper_bound namelist,dynamics max_domains 1000. h "tke_upper_bound" "" "" -rconfig real tke_drag_coefficient namelist,dynamics max_domains 0. h "tke_drag_coefficient" "" "" -rconfig real tke_heat_flux namelist,dynamics max_domains 0. h "tke_heat_flux" "" "" -rconfig logical pert_coriolis namelist,dynamics max_domains .false. irh "pert_coriolis" "" "" -rconfig logical euler_adv namelist,dynamics 1 .true. irh "euler_adv" "logical flag to turn on/off Eulerian passive advection" "" -rconfig integer idtadt namelist,dynamics 1 2 irh "idtadt" "fundamental timesteps between calls to Eulerian advection for dynamics" "" -rconfig integer idtadc namelist,dynamics 1 2 irh "idtadc" "fundamental timesteps between calls to Eulerian advection for chemistry" "" -rconfig real codamp namelist,dynamics max_domains 6.4 irh "codamp" "divergence damping weighting factor (larger = more damping) " "" -rconfig real coac namelist,dynamics max_domains 1.6 irh "coac" "horizontal diffusion weighting factor (larger = more diffusion) " "" -rconfig real slophc namelist,dynamics max_domains 6.363961e-3 irh "slophc" "Maximum model level slope (dZ/dy) for which hor diffusion is applied" "" -rconfig real wp namelist,dynamics max_domains 0. irh "wp" "Off-centering weight in the updating of nonhyrostatic eps" - -rconfig integer terrain_smoothing namelist,dynamics 1 1 irh "parallel_smooth" "nest_terrain smoothing method 0=none, 1=old, 2=new" - -# Bdy_control -rconfig integer spec_bdy_width namelist,bdy_control 1 5 irh "spec_bdy_width" "" "" -rconfig integer spec_zone namelist,bdy_control 1 1 irh "spec_zone" "" "" -rconfig integer relax_zone namelist,bdy_control 1 4 irh "relax_zone" "" "" -rconfig logical specified namelist,bdy_control max_domains .false. rh "specified" "" "" -rconfig logical periodic_x namelist,bdy_control max_domains .false. rh "periodic_x" "" "" -rconfig logical symmetric_xs namelist,bdy_control max_domains .false. rh "symmetric_xs" "" "" -rconfig logical symmetric_xe namelist,bdy_control max_domains .false. rh "symmetric_xe" "" "" -rconfig logical open_xs namelist,bdy_control max_domains .false. rh "open_xs" "" "" -rconfig logical open_xe namelist,bdy_control max_domains .false. rh "open_xe" "" "" -rconfig logical periodic_y namelist,bdy_control max_domains .false. rh "periodic_y" "" "" -rconfig logical symmetric_ys namelist,bdy_control max_domains .false. rh "symmetric_ys" "" "" -rconfig logical symmetric_ye namelist,bdy_control max_domains .false. rh "symmetric_ye" "" "" -rconfig logical open_ys namelist,bdy_control max_domains .false. rh "open_ys" "" "" -rconfig logical open_ye namelist,bdy_control max_domains .false. rh "open_ye" "" "" -rconfig logical polar namelist,bdy_control max_domains .false. rh "polar" "" "" -rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" -rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" - -rconfig integer background_proc_id namelist,grib2 1 255 rh "background_proc_id" "Background processing id for grib2" "" -rconfig integer forecast_proc_id namelist,grib2 1 255 rh "forecast_proc_id" "Analysis and forecast processing id for grib2" "" -rconfig integer production_status namelist,grib2 1 255 rh "production_status" "Background processing id for grib2" "" -rconfig integer compression namelist,grib2 1 40 rh "compression" "grib2 compression, 40 for JPEG2000 or 41 for PNG" "" - -# NAMELIST DERIVED -rconfig real cen_lat derived max_domains 0 - "cen_lat" "center latitude" "degrees, negative is south" -rconfig real cen_lon derived max_domains 0 - "cen_lon" "central longitude" "degrees, negative is west" -rconfig real truelat1 derived max_domains 0 - "true_lat1" "first standard parallel" "degrees, negative is south" -rconfig real truelat2 derived max_domains 0 - "true_lat2" "second standard parallel" "degrees, negative is south" -rconfig real moad_cen_lat derived max_domains 0 - "moad_cen_lat" "center latitude of the most coarse grid" "degrees, negative is south" -rconfig real stand_lon derived max_domains 0 - "stand_lon" "standard longitude, parallel to j-direction, perpendicular to i-direction " "degrees, negative is west" -rconfig integer FLAG_METGRID derived 1 0 - "FLAG_METGRID" "Flag in global attributes for metgrid data" -rconfig integer FLAG_SNOW derived 1 0 - "FLAG_SNOW" "Flag for snow in the global attributes for metgrid data" -rconfig integer FLAG_PSFC derived 1 0 - "FLAG_PSFC" "Flag for surface pressure in the global attributes for metgrid data" -rconfig integer FLAG_SM000010 derived 1 0 - "FLAG_SM000010" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_SM010040 derived 1 0 - "FLAG_SM010040" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_SM040100 derived 1 0 - "FLAG_SM040100" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_SM100200 derived 1 0 - "FLAG_SM100200" "Flag for soil moisture in the global attributes for metgrid data" -rconfig integer FLAG_ST000010 derived 1 0 - "FLAG_ST000010" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_ST010040 derived 1 0 - "FLAG_ST000010" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_ST040100 derived 1 0 - "FLAG_ST010040" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_ST100200 derived 1 0 - "FLAG_ST100200" "Flag for soil temperature in the global attributes for metgrid data" -rconfig integer FLAG_SLP derived 1 0 - "FLAG_SLP" "Flag for sea level pressure in the global attributes for metgrid data" -rconfig integer FLAG_SOILHGT derived 1 0 - "FLAG_SOILHGT" "Flag for soil height in the global attributes for metgrid data" -rconfig integer FLAG_MF_XY derived 1 0 - "FLAG_MF_XY" "Flag for MF_XYin the global attributes for metgrid data" -rconfig real bdyfrq derived max_domains 0 - "bdyfrq" "lateral boundary input frequency" "seconds" -rconfig character mminlu derived max_domains " " - "mminlu" "land use dataset" - "" -rconfig integer iswater derived max_domains 0 - "iswater" "land use index of water" "index category" -rconfig integer islake derived max_domains 0 - "islake" "land use index of inland lake" "index category" -rconfig integer isice derived max_domains 0 - "isice" "land use index of ice" "index category" -rconfig integer isurban derived max_domains 0 - "isurban" "land use index for 'urban and built-up" "index category" -rconfig integer isoilwater derived max_domains 0 - "isoilwater" "land use index of water for soil" "index category" -rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" -rconfig integer dfi_stage derived 1 3 - "dfi_stage" "current stage of DFI processing" "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast" -rconfig integer mp_physics_dfi derived max_domains -1 - "mp_physics_dfi" "" "-1 = no DFI and so no need to allocate DFI moistnd scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package" - -#rconfig integer simulation_start_year derived 1 0 h "simulation_start_year" "start of simulation through restarts" "4-digit year" -#rconfig integer simulation_start_month derived 1 0 h "simulation_start_month" "start of simulation through restarts" "2-digit month" -#rconfig integer simulation_start_day derived 1 0 h "simulation_start_day" "start of simulation through restarts" "2-digit day" -#rconfig integer simulation_start_hour derived 1 0 h "simulation_start_hour" "start of simulation through restarts" "2-digit hour" -#rconfig integer simulation_start_minute derived 1 0 h "simulation_start_minute" "start of simulation through restarts" "2-digit minute" -#rconfig integer simulation_start_second derived 1 0 h "simulation_start_second" "start of simulation through restarts" "2-digit second" - -# -# Single dummy declaration to define a nodyn dyn option -state integer nodyn_dummy - dyn_nodyn - - - "" "" "" - -rconfig integer maxpatch namelist,physics 1 10 irh "maxpatch" "" "" - -#key package associated package associated 4d scalars -# name namelist choice state vars - -#### 9. Edit the Registry file to set up '5' as the value of the -**** namelist variable dyn_opt that means to select our exp dyncore. -package dyn_exp dyn_opt==5 - - - -#package passivec1 chem_opt==0 - -package passiveqv mp_physics==0 - moist:qv -package kesslerscheme mp_physics==1 - moist:qv,qc,qr -package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg -package wsm3scheme mp_physics==3 - moist:qv,qc,qr -package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs -package etampnew mp_physics==5 - moist:qv,qc,qr,qs;state:f_ice,f_rain,f_rimef -package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg -package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg -package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr;state:re_cloud,re_ice,re_snow -package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow -package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh -package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng -package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs -package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr -package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr -package etamp_hwrf mp_physics==85 - moist:qv,qc,qr,qi,qs;state:f_ice,f_rain,f_rimef -package etampold mp_physics==95 - moist:qv,qc,qr,qs;state:f_ice,f_rain,f_rimef - -package nodfimoist mp_physics_dfi==-1 - - -package passiveqv_dfi mp_physics_dfi==0 - dfi_moist:dfi_qv -package kesslerscheme_dfi mp_physics_dfi==1 - dfi_moist:dfi_qv,dfi_qc,dfi_qr -package linscheme_dfi mp_physics_dfi==2 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package wsm3scheme_dfi mp_physics_dfi==3 - dfi_moist:dfi_qv,dfi_qc,dfi_qr -package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs -package etampnew_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs -package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg -package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package milbrandt2mom_dfi mp_physics_dfi==9 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh -package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qns,dfi_qnr,dfi_qng -package sbu_ylinscheme_dfi mp_physics==13 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs -package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr -package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr -package etampold_dfi mp_physics_dfi==95 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs - -# package noprogn progn==0 - - -# package progndrop progn==1 - scalar:qndrop;dfi_scalar:dfi_qndrop - -package rrtmscheme ra_lw_physics==1 - - -package camlwscheme ra_lw_physics==3 - - -package rrtmg_lwscheme ra_lw_physics==4 - - -package goddardlwscheme ra_lw_physics==5 - - -package flglwscheme ra_lw_physics==7 - - -package gfdllwscheme ra_lw_physics==99 - - -package hwrflwscheme ra_lw_physics==98 - -package swradscheme ra_sw_physics==1 - - -package gsfcswscheme ra_sw_physics==2 - - -package camswscheme ra_sw_physics==3 - - -package rrtmg_swscheme ra_sw_physics==4 - - -package goddardswscheme ra_sw_physics==5 - - -package flgswscheme ra_sw_physics==7 - - -package gfdlswscheme ra_sw_physics==99 - - -package hwrfswscheme ra_sw_physics==98 -package heldsuarez ra_lw_physics==31 - - - -package sfclayscheme sf_sfclay_physics==91 - - -package myjsfcscheme sf_sfclay_physics==2 - - -package gfssfcscheme sf_sfclay_physics==3 - - -package gfdlsfcscheme sf_sfclay_physics==88 - - -package qnsesfcscheme sf_sfclay_physics==4 - - -package pxsfcscheme sf_sfclay_physics==7 - - -package temfsfcscheme sf_sfclay_physics==10 - - -package sfclayrevscheme sf_sfclay_physics==1 - - -package idealscmsfcscheme sf_sfclay_physics==89 - - - -package slabscheme sf_surface_physics==1 - - -package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn -package ruclsmscheme sf_surface_physics==3 - - - -package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy - -package clmscheme sf_surface_physics==5 - - -package gfdlslab sf_surface_physics==88 - - -package pxlsmscheme sf_surface_physics==7 - - -package ssibscheme sf_surface_physics==8 - - -package ysuscheme bl_pbl_physics==1 - - -package myjpblscheme bl_pbl_physics==2 - - -package gfsscheme bl_pbl_physics==3 - state:hpbl2d,heat2d,evap2d -package gfs2011scheme bl_pbl_physics==83 - state:hpbl2d,heat2d,evap2d -package qnsepblscheme bl_pbl_physics==4 - - -package qnsepbl09scheme bl_pbl_physics==94 - - -package acmpblscheme bl_pbl_physics==7 - - -package boulacscheme bl_pbl_physics==8 - - -package camuwpblscheme bl_pbl_physics==9 - - -package mrfscheme bl_pbl_physics==99 - - -package temfpblscheme bl_pbl_physics==10 - - -package gbmpblscheme bl_pbl_physics==12 - - -package fitchscheme windfarm_opt==1 - - - -package kfetascheme cu_physics==1 - - -package bmjscheme cu_physics==2 - - -package gdscheme cu_physics==93 - - -package sasscheme cu_physics==84 - state:hpbl2d,heat2d,evap2d -package meso_sas cu_physics==85 - - -package osasscheme cu_physics==4 - state:randstate1,randstate2,randstate3,randstate4,random -package g3scheme cu_physics==5 - - -package gfscheme cu_physics==3 - - -package camzmscheme cu_physics==7 - - -package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep -package tiedtkescheme cu_physics==6 - - -package nsasscheme cu_physics==14 - - -package kfscheme cu_physics==99 - - - -package g3shcuscheme shcu_physics==1 - - -package camuwshcuscheme shcu_physics==2 - - -package grimsshcuscheme shcu_physics==3 - - - -package dfi_setup dfi_stage==0 - - -package dfi_bck dfi_stage==1 - - -package dfi_fwd dfi_stage==2 - - -package dfi_fst dfi_stage==3 - - -package dfi_startfwd dfi_stage==4 - - -package dfi_startbck dfi_stage==5 - - -package dfi_nodfi dfi_opt==0 - - -package dfi_dfl dfi_opt==1 - \ - state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC -package dfi_ddfi dfi_opt==2 - \ - state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC -package dfi_tdfi dfi_opt==3 - \ - state:dfi_pd,dfi_pint,dfi_dwdt,dfi_t,dfi_q,dfi_u,dfi_v,dfi_q2,dfi_cwm,dfi_rrw,dfi_STC,dfi_SMC,dfi_SH2O,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_NMM_TSK,dfi_SNOWC - -package albsi_zero seaice_albedo_opt==0 - - -package albsi_one seaice_albedo_opt==1 - - -package albsi_two seaice_albedo_opt==2 - state:albsi -package snowsi_zero seaice_snowdepth_opt==0 - - -package snowsi_one seaice_snowdepth_opt==1 - state:snowsi -package icedepth_zero seaice_thickness_opt==0 - - -package icedepth_one seaice_thickness_opt==1 - state:icedepth - -# only need to specify these once; not for every io_form* variable -package io_intio io_form_restart==1 - - -package io_netcdf io_form_restart==2 - - -# Placeholders for additional packages (we can go beyond zzz -# but that will entail modifying frame/module_io.F and frame/md_calls.m4) -# Please note these are placeholders; HDF has not been implemented yet. -package io_hdf io_form_restart==3 - - -package io_phdf5 io_form_restart==4 - - -package io_grib1 io_form_restart==5 - - -package io_mcel io_form_restart==6 - - -package io_esmf io_form_restart==7 - - -package io_yyy io_form_restart==8 - - -package io_zzz io_form_restart==9 - - -package io_grib2 io_form_restart==10 - - -package io_pnetcdf io_form_restart==11 - - - -#lightning -package ltng_none lightning_option==0 - - -package ltng_crm_PR92w lightning_option==1 - - -package ltng_crm_PR92z lightning_option==2 - - -package ltng_cpm_PR92z lightning_option==11 - - - -#WRF Hydro -package no_wrfhydro wrf_hydro==0 - - -package wrfhydro wrf_hydro==1 - state:SOLDRAIN, SFCHEADRT, INFXSRT - - -## communications - -### 8. Edit the Registry file and create a halo-exchange for x_1. - -# NMM communications - -halo HALO_NMM_INIT_1 dyn_nmm 120:HBM2 -halo HALO_NMM_INIT_2 dyn_nmm 120:HBM3,VBM2,VBM3 -halo HALO_NMM_INIT_3 dyn_nmm 120:SM,SICE -halo HALO_NMM_INIT_4 dyn_nmm 120:DX_NMM,WPDAR -halo HALO_NMM_INIT_5 dyn_nmm 120:CPGFU,CURV,FCP -halo HALO_NMM_INIT_6 dyn_nmm 120:FDIV,FAD,F -halo HALO_NMM_INIT_7 dyn_nmm 120:DDMPU,DDMPV,GLAT -halo HALO_NMM_INIT_8 dyn_nmm 120:GLON,EPSR,TG -halo HALO_NMM_INIT_9 dyn_nmm 120:GFFC,SST,ALBASE -#halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV,IVGTYP -halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV -#halo HALO_NMM_INIT_11 dyn_nmm 120:ISLTYP,ISLOPE,VEGFRC -halo HALO_NMM_INIT_11 dyn_nmm 120:VEGFRC -halo HALO_NMM_INIT_12 dyn_nmm 120:DIV,OMGALF,PD,RES -halo HALO_NMM_INIT_13 dyn_nmm 120:FIS,T,U -halo HALO_NMM_INIT_14 dyn_nmm 120:V,Q,Q2 -halo HALO_NMM_INIT_15 dyn_nmm 120:CWM,TRAIN,TCUCN -halo HALO_NMM_INIT_15B dyn_nmm 120:moist,scalar -halo HALO_NMM_INIT_16 dyn_nmm 120:RSWIN,RSWOUT,TG -halo HALO_NMM_INIT_17 dyn_nmm 120:Z0,AKMS,CZEN -halo HALO_NMM_INIT_18 dyn_nmm 120:AKHS,THS,QSH -halo HALO_NMM_INIT_19 dyn_nmm 120:TWBS,QWBS,HBOT -halo HALO_NMM_INIT_20 dyn_nmm 120:CFRACL,THZ0,QZ0 -halo HALO_NMM_INIT_21 dyn_nmm 120:UZ0,VZ0,USTAR -halo HALO_NMM_INIT_22 dyn_nmm 120:HTOP,CFRACM,SNO -halo HALO_NMM_INIT_23 dyn_nmm 120:SI,CLDEFI,RF -halo HALO_NMM_INIT_24 dyn_nmm 120:CUPPT,CFRACH,SOILTB -halo HALO_NMM_INIT_25 dyn_nmm 120:SFCEXC,SMSTAV,SMSTOT -halo HALO_NMM_INIT_26 dyn_nmm 120:GRNFLX,PCTSNO,RLWIN -halo HALO_NMM_INIT_27 dyn_nmm 120:RADOT,CZMEAN,SIGT4 -halo HALO_NMM_INIT_28 dyn_nmm 120:SR -halo HALO_NMM_INIT_29 dyn_nmm 120:PREC,ACPREC,ACCLIQ -halo HALO_NMM_INIT_30 dyn_nmm 120:ACFRST,ACSNOW -halo HALO_NMM_INIT_31 dyn_nmm 120:ACSNOM,SSROFF,BGROFF -halo HALO_NMM_INIT_32 dyn_nmm 120:SFCSHX,SFCLHX,SUBSHX -halo HALO_NMM_INIT_33 dyn_nmm 120:SNOPCX,SFCUVX,SFCEVP -halo HALO_NMM_INIT_34 dyn_nmm 120:POTEVP,ASWIN,ASWOUT -halo HALO_NMM_INIT_35 dyn_nmm 120:ASWTOA,ALWIN,ALWOUT -halo HALO_NMM_INIT_36 dyn_nmm 120:ALWTOA,SMC,CMC -halo HALO_NMM_INIT_37 dyn_nmm 120:STC,SH2O,ALBEDO -halo HALO_NMM_INIT_38 dyn_nmm 120:PINT,Z,DWDT -halo HALO_NMM_INIT_39 dyn_nmm 120:TOLD,UOLD,VOLD - -#for HWRF: zhang increase halo width to fix feedback bug for HALO_NMM_A (24 => 48) -#for HWRF: zhang HALO_NMM_C (24 => 48), HALO_NMM_G (24 => 48), HALO_NMM_K (8 => 24) -halo HALO_NMM_A dyn_nmm 48:pd,t,u,v,q,cwm,dwdt,div;48:pint -halo HALO_NMM_A_3 dyn_nmm 24:moist,scalar -halo HALO_NMM_B dyn_nmm 24:div -halo HALO_NMM_C dyn_nmm 48:u,v -halo HALO_NMM_D dyn_nmm 48:pd -halo HALO_NMM_E dyn_nmm 24:petdt -halo HALO_NMM_F dyn_nmm 24:t,u,v -halo HALO_NMM_F1 dyn_nmm 80:pdslo -halo HALO_NMM_G dyn_nmm 48:u,v;24:z -halo HALO_NMM_H dyn_nmm 24:w -halo HALO_NMM_I dyn_nmm 48:q,q2,cwm,rrw -halo HALO_NMM_I_3 dyn_nmm 48:moist,scalar -halo HALO_NMM_J dyn_nmm 8:pd,uz0,vz0,t,q,cwm -halo HALO_NMM_J_3 dyn_nmm 8:moist,scalar -halo HALO_NMM_K dyn_nmm 24:q2;24:t,u,v,q,w,z -halo HALO_NMM_L dyn_nmm 8:pd,t,q,cwm,q2 -halo HALO_NMM_L_3 dyn_nmm 8:moist,scalar -halo HALO_NMM_MG dyn_nmm 8:ht_gc -halo HALO_NMM_MG2 dyn_nmm 8:pd,psfc_out -halo HALO_NMM_MG3 dyn_nmm 8:p_gc - -halo HALO_NMM_TURBL_A dyn_nmm 8:uz0h,vz0h,hbm2 -halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt - -# following halos added for nesting purpose (gopal's doing): - - -halo HALO_NMM_MEMBRANE_RELAX dyn_nmm 8:relaxwork -halo HALO_NMM_MEMBRANE_MASK dyn_nmm 8:relaximask -halo HALO_NMM_TRACK dyn_nmm 120:sm,pdyn,mslp,sqws -halo HALO_NMM_INTERP_DOWN1 dyn_nmm 24:sm,fis,t,u,v,q,q2,pd,albase,nmm_tsk,mxsnal,tg,islope,cmc,soiltb,vegfrc,sh2o,smc,stc,toposoil,xice,ivgtyp,isltyp,vegfra,sst,weasd,snowh,hlat,hlon,z0,landmask,cwm,ustar,ths,qsh,cldefi,pshltr,dwdt,acprec,thz0,qz0,uz0,vz0,htop,hbot,cuppt,rlwtt,rswtt,t_adj,f_ice,f_rain,f_rimef,pint,hres_fis -halo HALO_NMM_INTERP_DOWN1M dyn_nmm 24:MOIST,SCALAR -halo HALO_NMM_FORCE_DOWN1 dyn_nmm 24:t,u,v,q,q2,cwm,pint,pd,hres_fis,fis -halo HALO_NMM_FORCE_DOWN1M dyn_nmm 24:MOIST,SCALAR -halo HALO_NMM_WEIGHTS dyn_nmm 48:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4,HNEAR_I,HNEAR_J - -halo HALO_NMM_SAS_A dyn_nmm 24:uz0h,vz0h,hbm2 -halo HALO_NMM_SAS_B dyn_nmm 24:ducudt,dvcudt -halo HALO_TRACERS dyn_nmm 48:szj,s1z,spz,tcs - -halo HALO_NMM_FORCE_DOWN_SST dyn_nmm 120:sst - -halo HALO_NMM_TERRAIN_SMOOTH dyn_nmm 24:HRES_AVC - -halo HALO_NMM_VT4_MSLP dyn_nmm 8:mslp -halo HALO_NMM_VT4_NOISE dyn_nmm 8:mslp_noisy - -halo HALO_NMM_INTERP_INFO dyn_nmm 8:pd,iinfo,winfo,pint -halo HALO_NMM_INT_UP dyn_nmm 8:pd,fis,hres_fis,sm diff --git a/wrfv2_fire/Registry/registry.afwa b/wrfv2_fire/Registry/registry.afwa new file mode 100644 index 00000000..9af2da32 --- /dev/null +++ b/wrfv2_fire/Registry/registry.afwa @@ -0,0 +1,114 @@ +# Registry file specifically for some additional diagnostic output +# from WRF (AFWA contributed code) + +# The new dimspec. We need to have the number of pressure levels to interpolate to. + +dimspec nt 2 constant=7 z num_turb_layers + +# AFWA Diagnostics package namelist options + +rconfig integer afwa_diag_opt namelist,afwa max_domains 0 rh "afwa_diag_opt" "AFWA Diagnostic option, 1: on" "" +rconfig integer afwa_ptype_opt namelist,afwa max_domains 0 rh "afwa_ptype_opt" "AFWA Diagnostic: Precip type option, 1: on" "" +rconfig integer afwa_vil_opt namelist,afwa max_domains 0 rh "afwa_vil_opt" "AFWA Diagnostic: Vert Int Liquid option, 1: on" "" +rconfig integer afwa_radar_opt namelist,afwa max_domains 0 rh "afwa_radar_opt" "AFWA Diagnostic: Radar option, 1: on" "" +rconfig integer afwa_severe_opt namelist,afwa max_domains 0 rh "afwa_severe_opt" "AFWA Diagnostic: Severe Wx option, 1: on" "" +rconfig integer afwa_icing_opt namelist,afwa max_domains 0 rh "afwa_icing_opt" "AFWA Diagnostic: Icing option, 1: on" "" +rconfig integer afwa_vis_opt namelist,afwa max_domains 0 rh "afwa_vis_opt" "AFWA Diagnostic: Visibility option, 1: on" "" +rconfig integer afwa_cloud_opt namelist,afwa max_domains 0 rh "afwa_cloud_opt" "AFWA Diagnostic: Cloud option, 1: on" "" +rconfig integer afwa_therm_opt namelist,afwa max_domains 0 rh "afwa_therm_opt" "AFWA Diagnostic: Thermal indices option, 1: on" "" +rconfig integer afwa_turb_opt namelist,afwa max_domains 0 rh "afwa_turb_opt" "AFWA Diagnostic: Turbulence option, 1: on" "" +rconfig integer afwa_buoy_opt namelist,afwa max_domains 0 rh "afwa_buoy_opt" "AFWA Diagnostic: Buoyancy option, 1: on" "" +rconfig integer afwa_hailcast_opt namelist,afwa max_domains 0 rh "afwa_hailcast_opt" "AFWA Diagnostic: Hailcast option, 1: on" "" +rconfig real afwa_ptype_ccn_tmp namelist,afwa 1 264.15 h "afwa_ptype_ccn_tmp" "AFWA Diagnostic: CCN temperature for precipitation type calculation" "K" +rconfig real afwa_ptype_tot_melt namelist,afwa 1 50.0 h "afwa_ptype_tot_melt" "AFWA Diagnostic: Total melting energy for precipitation type calculation" "J kg-1" +rconfig integer afwa_bad_data_check namelist,afwa 1 0 r "afwa_bad_data_check" "AFWA Diagnostic: Stop model when bogus data is found (eg U>300m/s), 1: on" "" + +# These variables are for the AFWA diagnostics package. + +#state real WSPD10MAX ij misc 1 - rh "WSPD10MAX" "WIND SPD MAX 10 M" "m s-1" +#state real W_UP_MAX ij misc 1 - rh "W_UP_MAX" "MAX Z-WIND UPDRAFT" "m s-1" +#state real W_DN_MAX ij misc 1 - rh "W_DN_MAX" "MAX Z-WIND DOWNDRAFT" "m s-1" +#state real REFD_MAX ij misc 1 - rh02 "REFD_MAX" "MAX DERIVED RADAR REFL" "dbZ" +#state real UP_HELI_MAX ij misc 1 - rh "UP_HELI_MAX" "MAX UPDRAFT HELICITY" "m2 s-2" +#state real UH ij misc 1 - r "UH" "UPDRAFT HELICITY" "m2 s-2" +state real TCOLI_MAX ij misc 1 - rh02 "TCOLI_MAX" "MAX TOTAL COLUMN INTEGRATED ICE" "kg m-2" +state real GRPL_FLX_MAX ij misc 1 - rh02 "GRPL_FLX_MAX" "MAX PSEUDO GRAUPEL FLUX" "g kg-1 m s-1" +state real REFD_COM ij misc 1 - rh02 "REFD_COM" "DERIVED COMPOSITE RADAR REFL" "dbZ" +state real REFD ij misc 1 - rh02 "REFD" "DERIVED RADAR REFL" "dbZ" +state real VIL ij misc 1 - rh02 "VIL" "VERTICALLY INTEGRATED LIQUID WATER" "kg m-2" +state real RADARVIL ij misc 1 - rh02 "RADARVIL" "VERTICALLY INTEGRATED LIQUID WATER FROM Ze" "kg m-2" +state real ECHOTOP ij misc 1 - rh02 "ECHOTOP" "ECHO TOP HEIGHT FROM Ze" "m" +state real FZLEV ij misc 1 - rh02 "FZLEV" "FREEZING LEVEL" "m" +state real ICINGTOP ij misc 1 - rh02 "ICINGTOP" "TOPMOST ICING LEVEL" "m" +state real ICINGBOT ij misc 1 - rh02 "ICINGBOT" "BOTTOMMOST ICING LEVEL" "m" +state real QICING_LG ikj misc 1 - r "QICING_LG" "SUPERCOOLED WATER MIXING RATIO (>50 um)" "kg kg-1" +state real QICING_SM ikj misc 1 - r "QICING_SM" "SUPERCOOLED WATER MIXING RATIO (<50 um)" "kg kg-1" +state real QICING_LG_MAX ij misc 1 - rh02 "QICING_LG_MAX" "COLUMN MAX ICING MIXING RATIO (>50 um)" "kg kg-1" +state real QICING_SM_MAX ij misc 1 - rh02 "QICING_SM_MAX" "COLUMN MAX ICING MIXING RATIO (<50 um)" "kg kg-1" +state real ICING_LG ij misc 1 - rh02 "ICING_LG" "TOTAL COLUMN INTEGRATED ICING (>50 um)" "kg m-2" +state real ICING_SM ij misc 1 - rh02 "ICING_SM" "TOTAL COLUMN INTEGRATED ICING (<50 um)" "kg m-2" +state real AFWA_MSLP ij misc 1 - rh02 "AFWA_MSLP" "AFWA Diagnostic: Mean sea level pressure" "Pa" +state real AFWA_HEATIDX ij misc 1 - rh02 "AFWA_HEATIDX" "AFWA Diagnostic: Heat index" "K" +state real AFWA_WCHILL ij misc 1 - rh02 "AFWA_WCHILL" "AFWA Diagnostic: Wind chill" "K" +state real AFWA_FITS ij misc 1 - rh02 "AFWA_FITS" "AFWA Diagnostic: Fighter Index of Thermal Stress" "K" +state real AFWA_TLYRBOT {nt} misc 1 - rh02 "AFWA_TLYRBOT" "AFWA Diagnostic: Turbulence layer AGL bottom" "m" +state real AFWA_TLYRTOP {nt} misc 1 - rh02 "AFWA_TLYRTOP" "AFWA Diagnostic: Turbulence layer AGL top" "m" +state real AFWA_TURB i{nt}j misc 1 - rh02 "AFWA_TURB" "AFWA Diagnostic: Turbulence index" "dimensionless" +state real AFWA_LLTURB ij misc 1 - rh02 "AFWA_LLTURB" "AFWA Diagnostic: Low Level Turbulence index" "dimensionless" +state real AFWA_LLTURBLGT ij misc 1 - rh02 "AFWA_LLTURBLGT" "AFWA Diagnostic: Prob of LGT Low-level Turb" "%" +state real AFWA_LLTURBMDT ij misc 1 - rh02 "AFWA_LLTURBMDT" "AFWA Diagnostic: Prob of MDT Low-level Turb" "%" +state real AFWA_LLTURBSVR ij misc 1 - rh02 "AFWA_LLTURBSVR" "AFWA Diagnostic: Prob of SVR Low-level Turb" "%" +state real AFWA_PRECIP ij misc 1 - r "AFWA_PRECIP" "AFWA Diagnostic: Precipitation bucket" "mm" +state real AFWA_TOTPRECIP ij misc 1 - rh02 "AFWA_TOTPRECIP" "AFWA Diagnostic: Total simulation precip" "mm" +state real AFWA_RAIN ij misc 1 - rh02 "AFWA_RAIN" "AFWA Diagnostic: Rain fall" "mm" +state real AFWA_SNOW ij misc 1 - rh02 "AFWA_SNOW" "AFWA Diagnostic: Liq Equiv Snow fall" "mm" +state real AFWA_ICE ij misc 1 - rh02 "AFWA_ICE" "AFWA Diagnostic: Ice fall" "mm" +state real AFWA_FZRA ij misc 1 - rh02 "AFWA_FZRA" "AFWA Diagnostic: Freezing rain fall" "mm" +state real AFWA_SNOWFALL ij misc 1 - rh02 "AFWA_SNOWFALL" "AFWA Diagnostic: Snow fall" "mm" +state real AFWA_VIS ij misc 1 - rh02 "AFWA_VIS" "AFWA Diagnostic: Visibility" "m" +state real AFWA_VIS_ALPHA ij misc 1 - rh02 "AFWA_VIS_ALPHA" "AFWA Diagnostic: Vis alpha Weibull term" "dimensionless" +state real AFWA_VIS_DUST ij misc 1 - rh02 "AFWA_VIS_DUST" "AFWA Diagnostic: Visibility due to dust" "m" +state real AFWA_CLOUD ij misc 1 - rh02 "AFWA_CLOUD" "AFWA Diagnostic: Cloud cover fraction" "fraction" +state real AFWA_CLOUD_CEIL ij misc 1 - rh02 "AFWA_CLOUD_CEIL" "AFWA Diagnostic: Cloud ceiling" "m" +state real AFWA_CAPE ij misc 1 - rh02 "AFWA_CAPE" "AFWA Diagnostic: Convective Avail Pot Energy" "J kg-1" +state real AFWA_CIN ij misc 1 - rh02 "AFWA_CIN" "AFWA Diagnostic: Convective Inhibition" "J kg-1" +state real AFWA_CAPE_MU ij misc 1 - rh02 "AFWA_CAPE_MU" "AFWA Diagnostic: Most unstable CAPE 0-180mb" "J kg-1" +state real AFWA_CIN_MU ij misc 1 - rh02 "AFWA_CIN_MU" "AFWA Diagnostic: Most unstable CIN 0-180mb" "J kg-1" +state real AFWA_ZLFC ij misc 1 - rh02 "AFWA_ZLFC" "AFWA Diagnostic: Level of Free Convection" "m" +state real AFWA_PLFC ij misc 1 - rh02 "AFWA_PLFC" "AFWA Diagnostic: Pressure of LFC" "Pa" +state real AFWA_LIDX ij misc 1 - rh02 "AFWA_LIDX" "AFWA Diagnostic: Surface Lifted Index" "K" +state real AFWA_PWAT ij misc 1 - rh02 "AFWA_PWAT" "AFWA Diagnostic: Precipitable Water" "kg m-2" +state real MIDRH_MIN ij misc 1 - - "MIDRH_MIN" "Min Mid-level relative humidity" "%" +state real MIDRH_MIN_OLD ij misc 1 - r "MIDRH_MIN_OLD" "Previous Min Mid-level relative humidity" "%" +state real AFWA_HAIL ij misc 1 - rh02 "AFWA_HAIL" "AFWA Diagnostic: Hail Diameter (Weibull)" "mm" +state real AFWA_LLWS ij misc 1 - rh02 "AFWA_LLWS" "AFWA Diagnostic: 0-2000 ft wind shear" "m s-1" +state real AFWA_TORNADO ij misc 1 - rh02 "AFWA_TORNADO" "AFWA Diagnostic: Tornado wind speed (Weibull)" "m s-1" +state real AFWA_HAIL_NEW1 ij misc 1 - - "AFWA_HAIL_NEW1" "AFWA Diagnostic: New Hail Diameter, 1st rank order" "mm" +state real AFWA_HAIL_NEW2 ij misc 1 - - "AFWA_HAIL_NEW2" "AFWA Diagnostic: New Hail Diameter, 2nd rank order" "mm" +state real AFWA_HAIL_NEW3 ij misc 1 - - "AFWA_HAIL_NEW3" "AFWA Diagnostic: New Hail Diameter, 3rd rank order" "mm" +state real AFWA_HAIL_NEW4 ij misc 1 - - "AFWA_HAIL_NEW4" "AFWA Diagnostic: New Hail Diameter, 4th rank order" "mm" +state real AFWA_HAIL_NEW5 ij misc 1 - - "AFWA_HAIL_NEW5" "AFWA Diagnostic: New Hail Diameter, 5th rank order" "mm" +state real AFWA_HAIL_NEWMEAN ij misc 1 - rh02 "AFWA_HAIL_NEWMEAN" "AFWA Diagnostic: New Mean Hail Diameter (Selin)" "mm" +state real AFWA_HAIL_NEWSTD ij misc 1 - rh02 "AFWA_HAIL_NEWSTD" "AFWA Diagnostic: New Stand. Dev. Hail Diameter (Selin)" "mm" +state real WUP_MASK ij misc 1 - r "WUP_MASK" "Updraft mask, 1 if > 10m/s" "" +state real WDUR ij misc 1 - r "WDUR" "Updraft duration" "sec" +state real TORNADO_MASK ij misc 1 - r "TORNADO_MASK" "Tornado mask, 1 if AFWA tornado > 0" "" +state real TORNADO_DUR ij misc 1 - r "TORNADO_DUR" "Tornado duration" "sec" + +# Package declaration for AFWA diagnostics + +package afwa_diag afwa_diag_opt==1 - state:afwa_mslp,afwa_pwat,wspd10max +package afwa_ptype afwa_ptype_opt==1 - state:afwa_precip,afwa_totprecip,afwa_rain,afwa_snow,afwa_ice,afwa_fzra,afwa_snowfall +package afwa_vil afwa_vil_opt==1 - state:vil,radarvil +package afwa_radar afwa_radar_opt==1 - state:echotop,refd_com,refd +package afwa_severe afwa_severe_opt==1 - state:w_up_max,w_dn_max,tcoli_max,up_heli_max,grpl_flx_max,w_mean,afwa_hail,afwa_cape,afwa_zlfc,afwa_plfc,wup_mask,wdur,tornado_mask,tornado_dur,midrh_min,midrh_min_old,afwa_lidx,afwa_cin,afwa_tornado,afwa_llws +package afwa_icing afwa_icing_opt==1 - state:fzlev,icingtop,icingbot,qicing_lg,qicing_sm,icing_lg,icing_sm,qicing_lg_max,qicing_sm_max +package afwa_cloud afwa_cloud_opt==1 - state:afwa_cloud,afwa_cloud_ceil +package afwa_vis afwa_vis_opt==1 - state:afwa_vis,afwa_vis_dust,afwa_vis_alpha +package afwa_therm afwa_therm_opt==1 - state:afwa_heatidx,afwa_wchill,afwa_fits +package afwa_turb afwa_turb_opt==1 - state:afwa_turb,afwa_llturb,afwa_llturblgt,afwa_llturbmdt,afwa_llturbsvr,afwa_tlyrbot,afwa_tlyrtop +package afwa_buoy afwa_buoy_opt==1 - state:afwa_cape,afwa_zlfc,afwa_plfc,afwa_lidx,afwa_cape_mu,afwa_cin,afwa_cin_mu +package afwa_hailcast afwa_hailcast_opt==1 - state:afwa_hail_newmean,afwa_hail_newstd,afwa_hail_new1,afwa_hail_new2,afwa_hail_new3,afwa_hail_new4,afwa_hail_new5 + +# For AFWA Diagnostics 1-d hail model (Selin) +halo HALO_EM_PHYS_W dyn_em 8:wup_mask, wdur, tornado_mask, tornado_dur diff --git a/wrfv2_fire/Registry/registry.bdy_perturb b/wrfv2_fire/Registry/registry.bdy_perturb index 18df34e6..09274f62 100644 --- a/wrfv2_fire/Registry/registry.bdy_perturb +++ b/wrfv2_fire/Registry/registry.bdy_perturb @@ -1,14 +1,17 @@ # Perturb boundary condition option # 3D arrays -state real field_u_tend_perturb ikj dyn_em 1 X rhdf=(p2c) "field_u_tend_perturb" "field used to perturb u in the boundaries" "" -state real field_v_tend_perturb ikj dyn_em 1 Y rhdf=(p2c) "field_v_tend_perturb" "field used to perturb v in the boundaries" "" -state real field_t_tend_perturb ikj dyn_em 1 - rhdf=(p2c) "field_t_tend_perturb" "field used to perturb t in the boundaries" "" +state real field_u_tend_perturb i{stoclev}j dyn_em 1 X rhdf=(p2c) "field_u_tend_perturb" "field used to perturb u in the boundaries" "" +state real field_v_tend_perturb i{stoclev}j dyn_em 1 Y rhdf=(p2c) "field_v_tend_perturb" "field used to perturb v in the boundaries" "" +state real field_t_tend_perturb i{stoclev}j dyn_em 1 - rhdf=(p2c) "field_t_tend_perturb" "field used to perturb t in the boundaries" "" # Namelist parameter -rconfig integer perturb_bdy namelist,stoch 1 0 - "perturb boundaries option: 0=off, 1=on with SKEBS pattern, 2=on with user provided pattern" +rconfig integer perturb_bdy namelist,stoch 1 0 - "perturb lateral boundaries of fields U,V,T: 0=off, 1=on with SKEBS pattern, 2=on with user provided pattern" +rconfig integer perturb_chem_bdy namelist,stoch 1 0 - "perturb lateral boundaries of chemical tracers: 0=off, 1=on with RAND_PERTURB patter" # Package declarations package no_perturb_bdy perturb_bdy==0 - - -package perturb_bdy_stoch_patrn perturb_bdy==1 - - +package perturb_bdy_with_skebs perturb_bdy==1 - - package perturb_bdy_user_patrn perturb_bdy==2 - state:field_u_tend_perturb,field_v_tend_perturb,field_t_tend_perturb + +package perturb_chem_bdy_with_rand perturb_chem_bdy==1 - - diff --git a/wrfv2_fire/Registry/registry.cam b/wrfv2_fire/Registry/registry.cam index a865e235..5993e1a3 100644 --- a/wrfv2_fire/Registry/registry.cam +++ b/wrfv2_fire/Registry/registry.cam @@ -72,7 +72,6 @@ state real rprdsh ikj misc 1 - rh6 "RPRDSH" "dq/dt due state real rliq2 ij misc 1 - r "RLIQ2" "vertically-integrated reserved cloud condensate for shallow Cu" "m s-1" state real dlf2 ikj misc 1 - rh "DLF2" "dq/dt due to export of cloud water into environment by shallow convection" "kg/kg/s" state real shfrc3d ikj misc 1 - r "SHFRC3D" "Shallow cloud fraction" "" -state real EVAPCSH3D ikj misc 1 - r "EVAPCSH3D" "Evaporation of shallow convection precipitation" "kg/kg/s" #~~~above here needs to be added to package definition state real qtflx_cu ikj misc 1 Z h6 "QTFLX_CU" "cumulus qt flux" "kg m-2 s-1" state real slflx_cu ikj misc 1 Z h6 "SLFLX_CU" "cumulus sl flux" "J m-2 s-1" diff --git a/wrfv2_fire/Registry/registry.chem b/wrfv2_fire/Registry/registry.chem index c3a7d1ad..c56ef1dc 100644 --- a/wrfv2_fire/Registry/registry.chem +++ b/wrfv2_fire/Registry/registry.chem @@ -82,65 +82,77 @@ state real e_so4j i+jf emis_ant 1 Z i5r "E_ state real e_no3i i+jf emis_ant 1 Z i5r "E_NO3I" "EMISSION RATE OF I-MODE ORG. AER." "ug/m3 m/s" state real e_no3j i+jf emis_ant 1 Z i5r "E_NO3J" "EMISSION RATE OF J-MODE ORG. AER." "ug/m3 m/s" # Additional MOZART emission variables... -state real e_bigalk i+jf emis_ant 1 Z i5h "E_BIGALK" "EMISSIONS BIGALK" "mol km^-2 hr^-1" -state real e_bigene i+jf emis_ant 1 Z i5h "E_BIGENE" "EMISSIONS BIGENE" "mol km^-2 hr^-1" -state real e_c2h4 i+jf emis_ant 1 Z i5h "E_C2H4" "EMISSIONS C2H4" "mol km^-2 hr^-1" -state real e_c2h6 i+jf emis_ant 1 Z i5h "E_C2H6" "EMISSIONS C2H6" "mol km^-2 hr^-1" -state real e_c3h6 i+jf emis_ant 1 Z i5h "E_C3H6" "EMISSIONS C3H6" "mol km^-2 hr^-1" -state real e_c3h8 i+jf emis_ant 1 Z i5h "E_C3H8" "EMISSIONS C3H8" "mol km^-2 hr^-1" -state real e_ch2o i+jf emis_ant 1 Z i5h "E_CH2O" "EMISSIONS CH2O" "mol km^-2 hr^-1" -state real e_ch3cho i+jf emis_ant 1 Z i5h "E_CH3CHO" "EMISSIONS CH3CHO" "mol km^-2 hr^-1" -state real e_ch3coch3 i+jf emis_ant 1 Z i5h "E_CH3COCH3" "EMISSIONS CH3COCH3" "mol km^-2 hr^-1" -state real e_mek i+jf emis_ant 1 Z i5h "E_MEK" "EMISSIONS MEK" "mol km^-2 hr^-1" -state real e_toluene i+jf emis_ant 1 Z i5h "E_TOLUENE" "EMISSIONS TOLUENE" "mol km^-2 hr^-1" -state real e_isop i+jf emis_ant 1 Z i5h "E_ISOP" "EMISSIONS ISOP" "mol km^-2 hr^-1" -state real e_c10h16 i+jf emis_ant 1 Z i5h "E_C10H16" "EMISSIONS C10H16" "mol km^-2 hr^-1" +state real e_nh4i i+jf emis_ant 1 Z i5r "E_NH4I" "EMISSION RATE OF I-MODE ORG. AER." "ug/m3 m/s" +state real e_nh4j i+jf emis_ant 1 Z i5r "E_NH4J" "EMISSION RATE OF J-MODE ORG. AER." "ug/m3 m/s" +state real e_nai i+jf emis_ant 1 Z i5r "E_NAI" "EMISSION RATE OF I-MODE ORG. AER." "ug/m3 m/s" +state real e_naj i+jf emis_ant 1 Z i5r "E_NAJ" "EMISSION RATE OF J-MODE ORG. AER." "ug/m3 m/s" +state real e_cli i+jf emis_ant 1 Z i5r "E_CLI" "EMISSION RATE OF I-MODE ORG. AER." "ug/m3 m/s" +state real e_clj i+jf emis_ant 1 Z i5r "E_CLJ" "EMISSION RATE OF J-MODE ORG. AER." "ug/m3 m/s" +state real e_bigalk i+jf emis_ant 1 Z i5 "E_BIGALK" "EMISSIONS BIGALK" "mol km^-2 hr^-1" +state real e_bigene i+jf emis_ant 1 Z i5 "E_BIGENE" "EMISSIONS BIGENE" "mol km^-2 hr^-1" +state real e_c2h4 i+jf emis_ant 1 Z i5 "E_C2H4" "EMISSIONS C2H4" "mol km^-2 hr^-1" +state real e_c2h6 i+jf emis_ant 1 Z i5 "E_C2H6" "EMISSIONS C2H6" "mol km^-2 hr^-1" +state real e_c3h6 i+jf emis_ant 1 Z i5 "E_C3H6" "EMISSIONS C3H6" "mol km^-2 hr^-1" +state real e_c3h8 i+jf emis_ant 1 Z i5 "E_C3H8" "EMISSIONS C3H8" "mol km^-2 hr^-1" +state real e_ch2o i+jf emis_ant 1 Z i5 "E_CH2O" "EMISSIONS CH2O" "mol km^-2 hr^-1" +state real e_ch3cho i+jf emis_ant 1 Z i5 "E_CH3CHO" "EMISSIONS CH3CHO" "mol km^-2 hr^-1" +state real e_ch3coch3 i+jf emis_ant 1 Z i5 "E_CH3COCH3" "EMISSIONS CH3COCH3" "mol km^-2 hr^-1" +state real e_mek i+jf emis_ant 1 Z i5 "E_MEK" "EMISSIONS MEK" "mol km^-2 hr^-1" +state real e_toluene i+jf emis_ant 1 Z i5 "E_TOLUENE" "EMISSIONS TOLUENE" "mol km^-2 hr^-1" +state real e_xylene i+jf emis_ant 1 Z i5 "E_XYLENE" "EMISSIONS XYLENE" "mol km^-2 hr^-1" +state real e_isop i+jf emis_ant 1 Z i5 "E_ISOP" "EMISSIONS ISOP" "mol km^-2 hr^-1" +state real e_c10h16 i+jf emis_ant 1 Z i5 "E_C10H16" "EMISSIONS C10H16" "mol km^-2 hr^-1" state real e_voca i+jf emis_ant 1 Z i5 "E_VOCA" "VOCA emissions" "mol km^-2 hr^-1" state real e_vocbb i+jf emis_ant 1 Z i5 "E_VOCBB" "VOCBB emissions" "mol km^-2 hr^-1" +state real e_macr i+jf emis_ant 1 Z i5 "E_MACR" "MACR emissions" "mol km^-2 hr^-1" +state real e_hono i+jf emis_ant 1 Z i5 "E_HONO" "HONO emissions" "mol km^-2 hr^-1" # Additional crimech emission variables... -state real e_c5h8 i+jf emis_ant 1 Z i5h "E_C5H8" "EMISSIONS C5H8" "mol km^-2 hr^-1" -state real e_tm123b i+jf emis_ant 1 Z i5h "E_TM123B" "EMISSIONS TM123B" "mol km^-2 hr^-1" -state real e_tm124b i+jf emis_ant 1 Z i5h "E_TM124B" "EMISSIONS TM124B" "mol km^-2 hr^-1" -state real e_tm135b i+jf emis_ant 1 Z i5h "E_TM135B" "EMISSIONS TM124B" "mol km^-2 hr^-1" -state real e_oethtol i+jf emis_ant 1 Z i5h "E_OETHTOL" "EMISSIONS OETHTOL" "mol km^-2 hr^-1" -state real e_methtol i+jf emis_ant 1 Z i5h "E_METHTOL" "EMISSIONS METHTOL" "mol km^-2 hr^-1" -state real e_pethtol i+jf emis_ant 1 Z i5h "E_PETHTOL" "EMISSIONS PETHTOL" "mol km^-2 hr^-1" -state real e_dime35eb i+jf emis_ant 1 Z i5h "E_DIME35EB" "EMISSIONS DIME35EB" "mol km^-2 hr^-1" -state real e_c2h5cho i+jf emis_ant 1 Z i5h "E_C2H5CHO" "EMISSIONS C2H5CHO" "mol km^-2 hr^-1" -state real e_benzene i+jf emis_ant 1 Z i5h "E_BENZENE" "EMISSIONS BENZENE" "mol km^-2 hr^-1" -state real e_nc4h10 i+jf emis_ant 1 Z i5h "E_NC4H10" "EMISSIONS NC4H10" "mol km^-2 hr^-1" -state real e_oxyl i+jf emis_ant 1 Z i5h "E_OXYL" "EMISSIONS OXYL" "mol km^-2 hr^-1" -state real e_tbut2ene i+jf emis_ant 1 Z i5h "E_TBUT2ENE" "EMISSIONS TBUT2ENE" "mol km^-2 hr^-1" -state real e_ch3co2h i+jf emis_ant 1 Z i5h "E_CH3CO2H" "EMISSIONS CH3CO2H" "mol km^-2 hr^-1" +state real e_c5h8 i+jf emis_ant 1 Z i5 "E_C5H8" "EMISSIONS C5H8" "mol km^-2 hr^-1" +state real e_tm123b i+jf emis_ant 1 Z i5 "E_TM123B" "EMISSIONS TM123B" "mol km^-2 hr^-1" +state real e_tm124b i+jf emis_ant 1 Z i5 "E_TM124B" "EMISSIONS TM124B" "mol km^-2 hr^-1" +state real e_tm135b i+jf emis_ant 1 Z i5 "E_TM135B" "EMISSIONS TM124B" "mol km^-2 hr^-1" +state real e_oethtol i+jf emis_ant 1 Z i5 "E_OETHTOL" "EMISSIONS OETHTOL" "mol km^-2 hr^-1" +state real e_methtol i+jf emis_ant 1 Z i5 "E_METHTOL" "EMISSIONS METHTOL" "mol km^-2 hr^-1" +state real e_pethtol i+jf emis_ant 1 Z i5 "E_PETHTOL" "EMISSIONS PETHTOL" "mol km^-2 hr^-1" +state real e_dime35eb i+jf emis_ant 1 Z i5 "E_DIME35EB" "EMISSIONS DIME35EB" "mol km^-2 hr^-1" +state real e_c2h5cho i+jf emis_ant 1 Z i5 "E_C2H5CHO" "EMISSIONS C2H5CHO" "mol km^-2 hr^-1" +state real e_benzene i+jf emis_ant 1 Z i5 "E_BENZENE" "EMISSIONS BENZENE" "mol km^-2 hr^-1" +state real e_nc4h10 i+jf emis_ant 1 Z i5 "E_NC4H10" "EMISSIONS NC4H10" "mol km^-2 hr^-1" +state real e_oxyl i+jf emis_ant 1 Z i5 "E_OXYL" "EMISSIONS OXYL" "mol km^-2 hr^-1" +state real e_tbut2ene i+jf emis_ant 1 Z i5 "E_TBUT2ENE" "EMISSIONS TBUT2ENE" "mol km^-2 hr^-1" +state real e_ch3co2h i+jf emis_ant 1 Z i5 "E_CH3CO2H" "EMISSIONS CH3CO2H" "mol km^-2 hr^-1" # Additional TNO emission variables for the UK -state real e_bc_1 i+jf emis_ant 1 Z i5h "E_BC_1" "EMISSION RATE OF BLACK CARBON 1UM MODE" "ug/m3 m/s" -state real e_ec_1_25 i+jf emis_ant 1 Z i5h "E_EC_1_25" "EMISSION RATE OF ELEMENTAL CARBON 1UM-2.5UM MODE" "ug/m3 m/s" -state real e_ec_25_10 i+jf emis_ant 1 Z i5h "E_EC_25_10" "EMISSION RATE OF ELEMENTAL CARBON 2.5UM-10UM MODE" "ug/m3 m/s" -state real e_oc_dom i+jf emis_ant 1 Z i5h "E_OC_DOM" "EMISSION RATE OF ORGANIC CARBON 2.5UM MODE (Domestic combustion)" "ug/m3 m/s" -state real e_oc_tra i+jf emis_ant 1 Z i5h "E_OC_TRA" "EMISSION RATE OF ORGANIC CARBON 2.5UM MODE (Traffic and other sources)" "ug/m3 m/s" -state real e_oc_25_10 i+jf emis_ant 1 Z i5h "E_OC_25_10" "EMISSION RATE OF ORGANIC CARBON 2.5UM-10UM MODE" "ug/m3 m/s" -state real e_pm25 i+jf emis_ant 1 Z i5h "E_PM25" "EMISSION RATE OF PARTICULATE MATTER 2.5UM MODE" "ug/m3 m/s" -state real e_pm10 i+jf emis_ant 1 Z i5h "E_PM10" "EMISSION RATE OF PARTICULATE MATTER 10UM MODE" "ug/m3 m/s" -state real e_oin_25 i+jf emis_ant 1 Z i5h "E_OIN_25" "EMISSION RATE OF PARTICULATE MATTER OTHER INORGANICS 2.5UM MODE" "ug/m3 m/s" -state real e_oin_10 i+jf emis_ant 1 Z i5h "E_OIN_10" "EMISSION RATE OF PARTICULATE MATTER OTHER INORGANICS 10UM MODE" "ug/m3 m/s" +state real e_bc_1 i+jf emis_ant 1 Z i5 "E_BC_1" "EMISSION RATE OF BLACK CARBON 1UM MODE" "ug/m3 m/s" +state real e_ec_1_25 i+jf emis_ant 1 Z i5 "E_EC_1_25" "EMISSION RATE OF ELEMENTAL CARBON 1UM-2.5UM MODE" "ug/m3 m/s" +state real e_ec_25_10 i+jf emis_ant 1 Z i5 "E_EC_25_10" "EMISSION RATE OF ELEMENTAL CARBON 2.5UM-10UM MODE" "ug/m3 m/s" +state real e_oc_dom i+jf emis_ant 1 Z i5 "E_OC_DOM" "EMISSION RATE OF ORGANIC CARBON 2.5UM MODE (Domestic combustion)" "ug/m3 m/s" +state real e_oc_tra i+jf emis_ant 1 Z i5 "E_OC_TRA" "EMISSION RATE OF ORGANIC CARBON 2.5UM MODE (Traffic and other sources)" "ug/m3 m/s" +state real e_oc_25_10 i+jf emis_ant 1 Z i5 "E_OC_25_10" "EMISSION RATE OF ORGANIC CARBON 2.5UM-10UM MODE" "ug/m3 m/s" +state real e_pm25 i+jf emis_ant 1 Z i5 "E_PM25" "EMISSION RATE OF PARTICULATE MATTER 2.5UM MODE" "ug/m3 m/s" +state real e_pm10 i+jf emis_ant 1 Z i5 "E_PM10" "EMISSION RATE OF PARTICULATE MATTER 10UM MODE" "ug/m3 m/s" +state real e_oin_25 i+jf emis_ant 1 Z i5 "E_OIN_25" "EMISSION RATE OF PARTICULATE MATTER OTHER INORGANICS 2.5UM MODE" "ug/m3 m/s" +state real e_oin_10 i+jf emis_ant 1 Z i5 "E_OIN_10" "EMISSION RATE OF PARTICULATE MATTER OTHER INORGANICS 10UM MODE" "ug/m3 m/s" # Additional CBMZ and MOSAIC emission variables... -state real e_no2 i+jf emis_ant 1 Z i5 "E_NO2" "EMISSIONS NO2" "mol km^-2 hr^-1" +state real e_no2 i+jf emis_ant 1 Z i5r "E_NO2" "EMISSIONS NO2" "mol km^-2 hr^-1" state real e_ch3oh i+jf emis_ant 1 Z i5 "E_CH3OH" "EMISSIONS CH3OH" "mol km^-2 hr^-1" state real e_c2h5oh i+jf emis_ant 1 Z i5 "E_C2H5OH" "EMISSIONS C2H5OH" "mol km^-2 hr^-1" state real e_so4c i+jf emis_ant 1 Z i5 "E_SO4C" "EMISSIONS COARSE SO4 AER" "ug/m3 m/s" state real e_no3c i+jf emis_ant 1 Z i5 "E_NO3C" "EMISSIONS COARSE NO3 AER" "ug/m3 m/s" +state real e_nh4c i+jf emis_ant 1 Z i5 "E_NH4C" "EMISSIONS COARSE NH4 AER" "ug/m3 m/s" +state real e_nac i+jf emis_ant 1 Z i5 "E_NAC" "EMISSIONS COARSE NA AER" "ug/m3 m/s" +state real e_clc i+jf emis_ant 1 Z i5 "E_CLC" "EMISSIONS COARSE CL AER" "ug/m3 m/s" state real e_orgc i+jf emis_ant 1 Z i5 "E_ORGC" "EMISSIONS COARSE ORG AER" "ug/m3 m/s" state real e_ecc i+jf emis_ant 1 Z i5 "E_ECC" "EMISSIONS COARSE EC AER" "ug/m3 m/s" -state real e_orgi_a i+jf emis_ant 1 Z i5 "E_ORGI_A" "EMISSIONS ORGI_A AER" "ug/m3 m/s" -state real e_orgj_a i+jf emis_ant 1 Z i5 "E_ORGJ_A" "EMISSIONS ORGJ_A AER" "ug/m3 m/s" -state real e_orgi_bb i+jf emis_ant 1 Z i5 "E_ORGI_BB" "EMISSIONS ORGI_BB AER" "ug/m3 m/s" -state real e_orgj_bb i+jf emis_ant 1 Z i5 "E_ORGJ_BB" "EMISSIONS ORGJ_BB AER" "ug/m3 m/s" -state real e_co_a i+jf emis_ant 1 Z i5 "E_CO_A" "EMISSIONS CO_A AER" "ug/m3 m/s" -state real e_co_bb i+jf emis_ant 1 Z i5 "E_CO_BB" "EMISSIONS CO_BB AER" "ug/m3 m/s" +state real e_orgi_a i+jf emis_ant 1 Z i5r "E_ORGI_A" "EMISSIONS ORGI_A AER" "ug/m3 m/s" +state real e_orgj_a i+jf emis_ant 1 Z i5r "E_ORGJ_A" "EMISSIONS ORGJ_A AER" "ug/m3 m/s" +state real e_orgi_bb i+jf emis_ant 1 Z i5r "E_ORGI_BB" "EMISSIONS ORGI_BB AER" "ug/m3 m/s" +state real e_orgj_bb i+jf emis_ant 1 Z i5r "E_ORGJ_BB" "EMISSIONS ORGJ_BB AER" "ug/m3 m/s" +state real e_co_a i+jf emis_ant 1 Z i5 "E_CO_A" "EMISSIONS CO_A AER" "ug/m3 m/s" +state real e_co_bb i+jf emis_ant 1 Z i5 "E_CO_BB" "EMISSIONS CO_BB AER" "ug/m3 m/s" # GOCART state real e_bc i+jf emis_ant 1 Z i5 "E_BC" "EMISSIONS BC AER" "ug/m3 m/s" @@ -164,77 +176,104 @@ state real e_so4i_num i+jf emis_ant 1 Z i5 "E state real e_num_a3 i+jf emis_ant 1 Z i5 "E_NUM_A3" "COARSE MODE NUMBER" "particle/m2/s" state real e_dms i+jf emis_ant 1 Z i5r "E_DMS" "EMISSIONS" "mol km^-2 hr^-1" - # soiltexturef is texture category fraction for each grid cell state real ust_t ij misc 1 - i012rh "UST_T" "Threshold Friction Velocity" "m s-1" -state real rough_cor ij misc 1 - rh "Rough_cor" "roughness elements correction" "" -state real smois_cor ij misc 1 - rh "Smois_cor" "soil moisture correction" "" -state real dustload_1 ij misc 1 - rh "dustload_1" "dust loading for size 1" "ug/m2" -state real dustload_2 ij misc 1 - rh "dustload_2" "dust loading for size 2" "ug/m2" -state real dustload_3 ij misc 1 - rh "dustload_3" "dust loading for size 3" "ug/m2" -state real dustload_4 ij misc 1 - rh "dustload_4" "dust loading for size 4" "ug/m2" -state real dustload_5 ij misc 1 - rh "dustload_5" "total dust loading" "ug/m2" -state real depvelocity ij misc 1 - rh "drydepvel" "dust dry deposition velocity " "m/s" -state real setvel_1 ij misc 1 - rh "setvel_1" "dust gravitational settling velocity for size 1" "m/s" -state real setvel_2 ij misc 1 - rh "setvel_2" "dust gravitational settling velocity for size 2" "m/s" -state real setvel_3 ij misc 1 - rh "setvel_3" "dust gravitational settling velocity for size 3" "m/s" -state real setvel_4 ij misc 1 - rh "setvel_4" "dust gravitational settling velocity for size 4" "m/s" -state real setvel_5 ij misc 1 - rh "setvel_5" "effective gravitational settling velocity for total" "m/s" -state real dustgraset_1 ij misc 1 - rh "graset_1" "dust gravitational settling for size 1" "ug/m2/s" -state real dustgraset_2 ij misc 1 - rh "graset_2" "dust gravitational settling for size 2" "ug/m2/s" -state real dustgraset_3 ij misc 1 - rh "graset_3" "dust gravitational settling for size 3" "ug/m2/s" -state real dustgraset_4 ij misc 1 - rh "graset_4" "dust gravitational settling for size 4" "ug/m2/s" -state real dustgraset_5 ij misc 1 - rh "graset_5" "dust gravitational settling for size 5" "ug/m2/s" -state real dustdrydep_1 ij misc 1 - rh "drydep_1" "dust dry deposition for size 1" "ug/m2/s" -state real dustdrydep_2 ij misc 1 - rh "drydep_2" "dust dry deposition for size 2" "ug/m2/s" -state real dustdrydep_3 ij misc 1 - rh "drydep_3" "dust dry deposition for size 3" "ug/m2/s" -state real dustdrydep_4 ij misc 1 - rh "drydep_4" "dust dry deposition for size 4" "ug/m2/s" -state real dustdrydep_5 ij misc 1 - rh "drydep_5" "dust dry deposition for size 5" "ug/m2/s" +state real rough_cor ij misc 1 - r "Rough_cor" "roughness elements correction" "" +state real smois_cor ij misc 1 - r "Smois_cor" "soil moisture correction" "" +state real dustload_1 ij misc 1 - r "dustload_1" "dust loading for size 1" "ug/m2" +state real dustload_2 ij misc 1 - r "dustload_2" "dust loading for size 2" "ug/m2" +state real dustload_3 ij misc 1 - r "dustload_3" "dust loading for size 3" "ug/m2" +state real dustload_4 ij misc 1 - r "dustload_4" "dust loading for size 4" "ug/m2" +state real dustload_5 ij misc 1 - r "dustload_5" "total dust loading" "ug/m2" +state real depvelocity ij misc 1 - r "drydepvel" "dust dry deposition velocity " "m/s" +state real setvel_1 ij misc 1 - r "setvel_1" "dust gravitational settling velocity for size 1" "m/s" +state real setvel_2 ij misc 1 - r "setvel_2" "dust gravitational settling velocity for size 2" "m/s" +state real setvel_3 ij misc 1 - r "setvel_3" "dust gravitational settling velocity for size 3" "m/s" +state real setvel_4 ij misc 1 - r "setvel_4" "dust gravitational settling velocity for size 4" "m/s" +state real setvel_5 ij misc 1 - r "setvel_5" "effective gravitational settling velocity for total" "m/s" +state real dustgraset_1 ij misc 1 - r "graset_1" "dust gravitational settling for size 1" "ug/m2/s" +state real dustgraset_2 ij misc 1 - r "graset_2" "dust gravitational settling for size 2" "ug/m2/s" +state real dustgraset_3 ij misc 1 - r "graset_3" "dust gravitational settling for size 3" "ug/m2/s" +state real dustgraset_4 ij misc 1 - r "graset_4" "dust gravitational settling for size 4" "ug/m2/s" +state real dustgraset_5 ij misc 1 - r "graset_5" "dust gravitational settling for size 5" "ug/m2/s" +state real dustdrydep_1 ij misc 1 - r "drydep_1" "dust dry deposition for size 1" "ug/m2/s" +state real dustdrydep_2 ij misc 1 - r "drydep_2" "dust dry deposition for size 2" "ug/m2/s" +state real dustdrydep_3 ij misc 1 - r "drydep_3" "dust dry deposition for size 3" "ug/m2/s" +state real dustdrydep_4 ij misc 1 - r "drydep_4" "dust dry deposition for size 4" "ug/m2/s" +state real dustdrydep_5 ij misc 1 - r "drydep_5" "dust dry deposition for size 5" "ug/m2/s" #SAPRCNOV additional emissions, automatically created using diff_mechEmiss_wrfRegistry.m script (pablo-saide@uiowa.edu) -state real e_c2h2 i+jf emis_ant 1 Z i5 "E_C2H2" "C2H2 emissions" "mol km^-2 hr^-1" -state real e_alk3 i+jf emis_ant 1 Z i5 "E_ALK3" "ALK3 emissions" "mol km^-2 hr^-1" -state real e_alk4 i+jf emis_ant 1 Z i5 "E_ALK4" "ALK4 emissions" "mol km^-2 hr^-1" -state real e_alk5 i+jf emis_ant 1 Z i5 "E_ALK5" "ALK5 emissions" "mol km^-2 hr^-1" -state real e_ethene i+jf emis_ant 1 Z i5 "E_ETHENE" "ETHENE emissions" "mol km^-2 hr^-1" -state real e_ole1 i+jf emis_ant 1 Z i5 "E_OLE1" "OLE1 emissions" "mol km^-2 hr^-1" -state real e_ole2 i+jf emis_ant 1 Z i5 "E_OLE2" "OLE2 emissions" "mol km^-2 hr^-1" -state real e_aro1 i+jf emis_ant 1 Z i5 "E_ARO1" "ARO1 emissions" "mol km^-2 hr^-1" -state real e_aro2 i+jf emis_ant 1 Z i5 "E_ARO2" "ARO2 emissions" "mol km^-2 hr^-1" -state real e_ccho i+jf emis_ant 1 Z i5 "E_CCHO" "CCHO emissions" "mol km^-2 hr^-1" -state real e_rcho i+jf emis_ant 1 Z i5 "E_RCHO" "RCHO emissions" "mol km^-2 hr^-1" -state real e_acet i+jf emis_ant 1 Z i5 "E_ACET" "ACET emissions" "mol km^-2 hr^-1" -state real e_isoprene i+jf emis_ant 1 Z i5 "E_ISOPRENE" "ISOPRENE emissions" "mol km^-2 hr^-1" -state real e_terp i+jf emis_ant 1 Z i5 "E_TERP" "TERP emissions" "mol km^-2 hr^-1" -state real e_sesq i+jf emis_ant 1 Z i5 "E_SESQ" "SESQUITERPENE emissions" "mol km^-2 hr^-1" -state real e_phen i+jf emis_ant 1 Z i5 "E_PHEN" "PHEN emissions" "mol km^-2 hr^-1" -state real e_cres i+jf emis_ant 1 Z i5 "E_CRES" "CRES emissions" "mol km^-2 hr^-1" -state real e_meoh i+jf emis_ant 1 Z i5 "E_MEOH" "MEOH emissions" "mol km^-2 hr^-1" -state real e_gly i+jf emis_ant 1 Z i5 "E_GLY" "GLY emissions" "mol km^-2 hr^-1" -state real e_mgly i+jf emis_ant 1 Z i5 "E_MGLY" "MGLY emissions" "mol km^-2 hr^-1" -state real e_bacl i+jf emis_ant 1 Z i5 "E_BACL" "BACL emissions" "mol km^-2 hr^-1" -state real e_isoprod i+jf emis_ant 1 Z i5 "E_ISOPROD" "ISOPROD emissions" "mol km^-2 hr^-1" -state real e_methacro i+jf emis_ant 1 Z i5 "E_METHACRO" "METHACRO emissions" "mol km^-2 hr^-1" -state real e_mvk i+jf emis_ant 1 Z i5 "E_MVK" "MVK emissions" "mol km^-2 hr^-1" -state real e_prod2 i+jf emis_ant 1 Z i5 "E_PROD2" "PROD2 emissions" "mol km^-2 hr^-1" -state real e_ch4 i+jf emis_ant 1 Z i5 "E_CH4" "CH4 emissions" "mol km^-2 hr^-1" -state real e_bald i+jf emis_ant 1 Z i5 "E_BALD" "BALD emissions" "mol km^-2 hr^-1" -state real e_hcooh i+jf emis_ant 1 Z i5 "E_HCOOH" "HCOOH emissions" "mol km^-2 hr^-1" -state real e_cco_oh i+jf emis_ant 1 Z i5 "E_CCO_OH" "CCO_OH emissions" "mol km^-2 hr^-1" -state real e_rco_oh i+jf emis_ant 1 Z i5 "E_RCO_OH" "RCO_OH emissions" "mol km^-2 hr^-1" +state real e_c2h2 i+jf emis_ant 1 Z i5r "E_C2H2" "C2H2 emissions" "mol km^-2 hr^-1" +state real e_alk3 i+jf emis_ant 1 Z i5r "E_ALK3" "ALK3 emissions" "mol km^-2 hr^-1" +state real e_alk4 i+jf emis_ant 1 Z i5r "E_ALK4" "ALK4 emissions" "mol km^-2 hr^-1" +state real e_alk5 i+jf emis_ant 1 Z i5r "E_ALK5" "ALK5 emissions" "mol km^-2 hr^-1" +state real e_ethene i+jf emis_ant 1 Z i5r "E_ETHENE" "ETHENE emissions" "mol km^-2 hr^-1" +state real e_ole1 i+jf emis_ant 1 Z i5r "E_OLE1" "OLE1 emissions" "mol km^-2 hr^-1" +state real e_ole2 i+jf emis_ant 1 Z i5r "E_OLE2" "OLE2 emissions" "mol km^-2 hr^-1" +state real e_aro1 i+jf emis_ant 1 Z i5r "E_ARO1" "ARO1 emissions" "mol km^-2 hr^-1" +state real e_aro2 i+jf emis_ant 1 Z i5r "E_ARO2" "ARO2 emissions" "mol km^-2 hr^-1" +state real e_ccho i+jf emis_ant 1 Z i5r "E_CCHO" "CCHO emissions" "mol km^-2 hr^-1" +state real e_rcho i+jf emis_ant 1 Z i5r "E_RCHO" "RCHO emissions" "mol km^-2 hr^-1" +state real e_acet i+jf emis_ant 1 Z i5r "E_ACET" "ACET emissions" "mol km^-2 hr^-1" +state real e_isoprene i+jf emis_ant 1 Z i5r "E_ISOPRENE" "ISOPRENE emissions" "mol km^-2 hr^-1" +state real e_terp i+jf emis_ant 1 Z i5r "E_TERP" "TERP emissions" "mol km^-2 hr^-1" +state real e_sesq i+jf emis_ant 1 Z i5r "E_SESQ" "SESQUITERPENE emissions" "mol km^-2 hr^-1" +state real e_phen i+jf emis_ant 1 Z i5r "E_PHEN" "PHEN emissions" "mol km^-2 hr^-1" +state real e_cres i+jf emis_ant 1 Z i5r "E_CRES" "CRES emissions" "mol km^-2 hr^-1" +state real e_meoh i+jf emis_ant 1 Z i5r "E_MEOH" "MEOH emissions" "mol km^-2 hr^-1" +state real e_gly i+jf emis_ant 1 Z i5r "E_GLY" "GLY emissions" "mol km^-2 hr^-1" +state real e_mgly i+jf emis_ant 1 Z i5r "E_MGLY" "MGLY emissions" "mol km^-2 hr^-1" +state real e_bacl i+jf emis_ant 1 Z i5r "E_BACL" "BACL emissions" "mol km^-2 hr^-1" +state real e_isoprod i+jf emis_ant 1 Z i5r "E_ISOPROD" "ISOPROD emissions" "mol km^-2 hr^-1" +state real e_methacro i+jf emis_ant 1 Z i5r "E_METHACRO" "METHACRO emissions" "mol km^-2 hr^-1" +state real e_mvk i+jf emis_ant 1 Z i5r "E_MVK" "MVK emissions" "mol km^-2 hr^-1" +state real e_prod2 i+jf emis_ant 1 Z i5r "E_PROD2" "PROD2 emissions" "mol km^-2 hr^-1" +state real e_ch4 i+jf emis_ant 1 Z i5r "E_CH4" "CH4 emissions" "mol km^-2 hr^-1" +state real e_bald i+jf emis_ant 1 Z i5r "E_BALD" "BALD emissions" "mol km^-2 hr^-1" +state real e_hcooh i+jf emis_ant 1 Z i5r "E_HCOOH" "HCOOH emissions" "mol km^-2 hr^-1" +state real e_cco_oh i+jf emis_ant 1 Z i5r "E_CCO_OH" "CCO_OH emissions" "mol km^-2 hr^-1" +state real e_rco_oh i+jf emis_ant 1 Z i5r "E_RCO_OH" "RCO_OH emissions" "mol km^-2 hr^-1" # GHG anthropogenic emissions -state real e_co2tst i+jf emis_ant 1 Z i5h "E_CO2TST" "Anthropogenic CO2 test fluxes" "mol km^-2 hr^-1" -state real e_cotst i+jf emis_ant 1 Z i5h "E_COTST" "Anthropogenic CO test fluxes" "mol km^-2 hr^-1" -state real e_ch4tst i+jf emis_ant 1 Z i5h "E_CH4TST" "Anthropogenic CH4 test fluxes" "mol km^-2 hr^-1" +state real e_co2tst i+jf emis_ant 1 Z i5 "E_CO2TST" "Anthropogenic CO2 test fluxes" "mol km^-2 hr^-1" +state real e_cotst i+jf emis_ant 1 Z i5 "E_COTST" "Anthropogenic CO test fluxes" "mol km^-2 hr^-1" +state real e_ch4tst i+jf emis_ant 1 Z i5 "E_CH4TST" "Anthropogenic CH4 test fluxes" "mol km^-2 hr^-1" # GHG emission variables state real - ivjf eghg_bio - - - - "All biospheric GHG fluxes " "" -state real ebio_gee ivjf eghg_bio 1 Z h "EBIO_GEE" "biospheric VPRM CO2 uptake" "mol km^-2 hr^-1" -state real ebio_res ivjf eghg_bio 1 Z h "EBIO_RES" "biospheric VPRM CO2 release" "mol km^-2 hr^-1" -state real ebio_ch4wet ivjf eghg_bio 1 Z h "EBIO_CH4WET" "Biogenic CH4 wetland emissions" "mol km^-2 hr^-1" -state real ebio_ch4soil ivjf eghg_bio 1 Z h "EBIO_CH4SOIL" "CH4 soil uptake fluxes" "mol km^-2 hr^-1" -state real ebio_ch4term ivjf eghg_bio 1 Z h "EBIO_CH4TERM" "CH4 termite emissions" "mol km^-2 hr^-1" +state real ebio_gee ivjf eghg_bio 1 Z - "EBIO_GEE" "biospheric VPRM CO2 uptake" "mol km^-2 hr^-1" +state real ebio_res ivjf eghg_bio 1 Z - "EBIO_RES" "biospheric VPRM CO2 release" "mol km^-2 hr^-1" +state real ebio_ch4wet ivjf eghg_bio 1 Z - "EBIO_CH4WET" "Biogenic CH4 wetland emissions" "mol km^-2 hr^-1" +state real ebio_ch4soil ivjf eghg_bio 1 Z - "EBIO_CH4SOIL" "CH4 soil uptake fluxes" "mol km^-2 hr^-1" +state real ebio_ch4term ivjf eghg_bio 1 Z - "EBIO_CH4TERM" "CH4 termite emissions" "mol km^-2 hr^-1" + +#Additional CB05 emission variables +state real e_hcl i+jf emis_ant 1 Z i5 "E_HCL" "EMISSIONS HCL" "mol km^-2 hr^-1" +state real e_aldx i+jf emis_ant 1 Z i5 "E_ALDX" "EMISSIONS ALDX" "mol km^-2 hr^-1" +state real e_par i+jf emis_ant 1 Z i5 "E_PAR" "EMISSIONS PAR" "mol km^-2 hr^-1" +state real e_ole i+jf emis_ant 1 Z i5 "E_OLE" "EMISSIONS OLE" "mol km^-2 hr^-1" +state real e_iole i+jf emis_ant 1 Z i5 "E_IOLE" "EMISSIONS IOLE" "mol km^-2 hr^-1" +state real e_form i+jf emis_ant 1 Z i5 "E_FORM" "EMISSIONS FORM" "mol km^-2 hr^-1" +state real e_etha i+jf emis_ant 1 Z i5 "E_ETHA" "EMISSIONS ETHA" "mol km^-2 hr^-1" +state real e_etoh i+jf emis_ant 1 Z i5 "E_ETOH" "EMISSIONS ETOH" "mol km^-2 hr^-1" +state real e_ald2 i+jf emis_ant 1 Z i5 "E_ALD2" "EMISSIONS ALD2" "mol km^-2 hr^-1" +state real e_meo2 i+jf emis_ant 1 Z i5 "E_MEO2" "EMISSIONS MEO2" "mol km^-2 hr^-1" +state real e_psulf i+jf emis_ant 1 Z i5 "E_PSULF" "EMISSIONS PSULF" "mol km^-2 hr^-1" +state real e_ccooh i+jf emis_ant 1 Z i5 "E_CCOOH" "EMISSIONS CCOOH" "mol km^-2 hr^-1" +state real e_iprod i+jf emis_ant 1 Z i5 "E_IPROD" "EMISSIONS IPROD" "mol km^-2 hr^-1" + +state real e_hg2 i+jf emis_ant 1 Z i5 "E_HG2" "EMISSIONS HG2" "mol km^-2 hr^-1" +state real e_hg0 i+jf emis_ant 1 Z i5 "E_HG0" "EMISSIONS HG0" "mol km^-2 hr^-1" +state real e_fmcl i+jf emis_ant 1 Z i5 "E_FMCL" "EMISSIONS FMCL" "mol km^-2 hr^-1" +state real e_hgp i+jf emis_ant 1 Z i5 "E_HGP" "EMISSIONS HGP" "ug/m3 m/s" + +state real e_apin i+jf emis_ant 1 Z i5 "E_APIN" "EMISSIONS a-Pinene" "mol km^-2 hr^-1" +state real e_bpin i+jf emis_ant 1 Z i5 "E_BPIN" "EMISSIONS b-Pinene" "mol km^-2 hr^-1" +state real e_lim i+jf emis_ant 1 Z i5 "E_LIM" "EMISSIONS Limonene" "mol km^-2 hr^-1" +state real e_ter i+jf emis_ant 1 Z i5 "E_TER" "EMISSIONS Terpinene" "mol km^-2 hr^-1" +state real e_oci i+jf emis_ant 1 Z i5 "E_OCI" "EMISSIONS Ocimene" "mol km^-2 hr^-1" +state real e_hum i+jf emis_ant 1 Z i5 "E_HUM" "EMISSIONS Humulene" "mol km^-2 hr^-1" + # dust and seas emission arrays state real - i{dust}jf emis_dust - - - - "Dust Emissions" "" @@ -248,6 +287,12 @@ state real eseas1 i{dust}jf emis_seas 1 Z - state real eseas2 i{dust}jf emis_seas 1 Z - "ESEAS2" "Sea-Salt emissions bin2 " "" state real eseas3 i{dust}jf emis_seas 1 Z - "ESEAS3" "Sea-Salt emissions bin3 " "" state real eseas4 i{dust}jf emis_seas 1 Z - "ESEAS4" "Sea-Salt emissions bin4 " "" + +# seas emission diagnositic for seas_opt==2 +state real - i{dust}jf emis_seas2 - - - - "Sea-Salt Emissions" "" +state real eseasj i{dust}jf emis_seas2 1 Z - "ESEASJ" "Sea-Salt emissions accu mode " "g/m2/s" +state real eseasc i{dust}jf emis_seas2 1 Z - "ESEASC" "Sea-Salt emissions coarse mode " "g/m2/s" + # # volcanic ash emissions # @@ -299,29 +344,29 @@ state real ebu_oc ikjf ebu 1 Z h "eb state real ebu_bc ikjf ebu 1 Z - "ebu_bc" "biomass burning emiss" "ug/m2/s" state real ebu_sulf ikjf ebu 1 Z - "ebu_sulf" "biomass burning emiss" "mol km^-2 hr^-1" # additional arrays for mozcart biomass burning -state real ebu_bigalk ikjf ebu 1 Z h "ebu_bigalk" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_bigene ikjf ebu 1 Z h "ebu_bigene" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_c2h4 ikjf ebu 1 Z h "ebu_c2h4" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_c2h5oh ikjf ebu 1 Z h "ebu_c2h5oh" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_c2h6 ikjf ebu 1 Z h "ebu_c2h6" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_c3h6 ikjf ebu 1 Z h "ebu_c3h6" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_c3h8 ikjf ebu 1 Z h "ebu_c3h8" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_ch2o ikjf ebu 1 Z h "ebu_ch2o" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_ch3cho ikjf ebu 1 Z h "ebu_ch3cho" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_ch3coch3 ikjf ebu 1 Z h "ebu_ch3coch3" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_ch3oh ikjf ebu 1 Z h "ebu_ch3oh" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_mek ikjf ebu 1 Z h "ebu_mek" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_toluene ikjf ebu 1 Z h "ebu_toluene" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_open ikjf ebu 1 Z h "ebu_open" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_c10h16 ikjf ebu 1 Z h "ebu_c10h16" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_mgly ikjf ebu 1 Z h "ebu_mgly" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_ch3cooh ikjf ebu 1 Z h "ebu_ch3cooh" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_cres ikjf ebu 1 Z h "ebu_cres" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_glyald ikjf ebu 1 Z h "ebu_glyald" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_gly ikjf ebu 1 Z h "ebu_gly" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_acetol ikjf ebu 1 Z h "ebu_acetol" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_isop ikjf ebu 1 Z h "ebu_isop" "biomass burning emiss" "mol km^-2 hr^-1" -state real ebu_mvk ikjf ebu 1 Z h "ebu_mvk" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_bigalk ikjf ebu 1 Z - "ebu_bigalk" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_bigene ikjf ebu 1 Z - "ebu_bigene" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_c2h4 ikjf ebu 1 Z - "ebu_c2h4" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_c2h5oh ikjf ebu 1 Z - "ebu_c2h5oh" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_c2h6 ikjf ebu 1 Z - "ebu_c2h6" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_c3h6 ikjf ebu 1 Z - "ebu_c3h6" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_c3h8 ikjf ebu 1 Z - "ebu_c3h8" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_ch2o ikjf ebu 1 Z - "ebu_ch2o" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_ch3cho ikjf ebu 1 Z - "ebu_ch3cho" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_ch3coch3 ikjf ebu 1 Z - "ebu_ch3coch3" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_ch3oh ikjf ebu 1 Z - "ebu_ch3oh" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_mek ikjf ebu 1 Z - "ebu_mek" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_toluene ikjf ebu 1 Z - "ebu_toluene" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_open ikjf ebu 1 Z - "ebu_open" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_c10h16 ikjf ebu 1 Z - "ebu_c10h16" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_mgly ikjf ebu 1 Z - "ebu_mgly" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_ch3cooh ikjf ebu 1 Z - "ebu_ch3cooh" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_cres ikjf ebu 1 Z - "ebu_cres" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_glyald ikjf ebu 1 Z - "ebu_glyald" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_gly ikjf ebu 1 Z - "ebu_gly" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_acetol ikjf ebu 1 Z - "ebu_acetol" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_isop ikjf ebu 1 Z - "ebu_isop" "biomass burning emiss" "mol km^-2 hr^-1" +state real ebu_mvk ikjf ebu 1 Z - "ebu_mvk" "biomass burning emiss" "mol km^-2 hr^-1" # CH4 biomass burning emissions state real ebu_ch4 ikjf ebu 1 Z h "ebu_ch4" "biomass burning emiss" "mol km^-2 hr^-1" @@ -448,6 +493,12 @@ state real - ikjf asym_par - - - - state real asympar3 ikjf asym_par 1 Z - "ASYMPAR3" "assymetry parameter for .3um" "?" state real asympar55 ikjf asym_par 1 Z - "ASYMPAR55" "assymetry parameter for .55um" "?" state real asympar106 ikjf asym_par 1 Z - "ASYMPAR106" "assymetry parameter for 1.06um" "?" + +#for dep outputs +state real ddlen ijo misc 1 Z rh "DRY_DEP_LEN" "dry deposition velocity" "cm/s" +state real ddflx ijo misc 1 Z rh "DRY_DEP_FLUX" "dry deposition flux" "mol or ug m^-2" +state real wdflx ijo misc 1 Z rh "WET_DEP_FLUX" "column wet scavening flux" "mmol or ug m^-2" + # state real e_bio ijo misc 1 Z r "E_BIO" "EMISSIONS" "ppm m/min" state real sebio_iso ij misc 1 - i06r "sebio_iso" "Reference biog emiss" "mol km^-2 hr^-1" @@ -469,22 +520,22 @@ state real noag_grow ij misc 1 - i06r "noa state real noag_nongrow ij misc 1 - i06r "noag_nongrow" "Reference biog emiss" "mol km^-2 hr^-1" state real nononag ij misc 1 - i06r "nononag" "Reference biog emiss" "mol km^-2 hr^-1" state real slai ij misc 1 - i06r "slai" "Leaf area index isop" "" -state real ebio_iso ij misc 1 - - "EBIO_ISO" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_oli ij misc 1 - - "ebio_oli" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_api ij misc 1 - - "ebio_api" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_lim ij misc 1 - - "ebio_lim" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_xyl ij misc 1 - - "ebio_xyl" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_hc3 ij misc 1 - - "ebio_hc3" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_ete ij misc 1 - - "ebio_ete" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_olt ij misc 1 - - "ebio_olt" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_ket ij misc 1 - - "ebio_ket" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_ald ij misc 1 - - "ebio_ald" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_hcho ij misc 1 - - "ebio_hcho" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_eth ij misc 1 - - "ebio_eth" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_ora2 ij misc 1 - - "ebio_ora2" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_co ij misc 1 - - "ebio_co" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_nr ij misc 1 - - "ebio_nr" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_no ij misc 1 - - "ebio_no" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_iso ij misc 1 - rh "EBIO_ISO" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_oli ij misc 1 - r "ebio_oli" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_api ij misc 1 - rh "ebio_api" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_lim ij misc 1 - r "ebio_lim" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_xyl ij misc 1 - r "ebio_xyl" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_hc3 ij misc 1 - r "ebio_hc3" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ete ij misc 1 - r "ebio_ete" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_olt ij misc 1 - r "ebio_olt" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ket ij misc 1 - r "ebio_ket" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ald ij misc 1 - r "ebio_ald" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_hcho ij misc 1 - r "ebio_hcho" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_eth ij misc 1 - r "ebio_eth" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ora2 ij misc 1 - r "ebio_ora2" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_co ij misc 1 - r "ebio_co" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_nr ij misc 1 - r "ebio_nr" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_no ij misc 1 - r "ebio_no" "Actual biog emiss" "mol km^-2 hr^-1" # saprc state real ebio_alk3 ij misc 1 - - "ebio_alk3" "Actual biog emiss" "mol km^-2 hr^-1" state real ebio_alk4 ij misc 1 - - "ebio_alk4" "Actual biog emiss" "mol km^-2 hr^-1" @@ -502,23 +553,25 @@ state real ebio_bald ij misc 1 - - "ebi state real ebio_cco_oh ij misc 1 - - "ebio_cco_oh" "Actual biog emiss" "mol km^-2 hr^-1" state real ebio_rco_oh ij misc 1 - - "ebio_rco_oh" "Actual biog emiss" "mol km^-2 hr^-1" # mozcart megan2 bio emission species -state real ebio_c10h16 ij misc 1 - - "ebio_c10h16" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_tol ij misc 1 - - "ebio_tol" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_bigalk ij misc 1 - - "ebio_bigalk" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_bigene ij misc 1 - - "ebio_bigene" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_ch3oh ij misc 1 - - "ebio_ch3oh" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_acet ij misc 1 - - "ebio_acet" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_nh3 ij misc 1 - - "ebio_nh3" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_no2 ij misc 1 - - "ebio_no2" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_c2h5oh ij misc 1 - - "ebio_c2h5oh" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_ch3cooh ij misc 1 - - "ebio_ch3cooh" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_mek ij misc 1 - - "ebio_mek" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_c2h6 ij misc 1 - - "ebio_c2h6" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_c2h4 ij misc 1 - - "ebio_c2h4" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_c3h6 ij misc 1 - - "ebio_c3h6" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_c3h8 ij misc 1 - - "ebio_c3h8" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_so2 ij misc 1 - - "ebio_so2" "Actual biog emiss" "mol km^-2 hr^-1" -state real ebio_dms ij misc 1 - - "ebio_dms" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_c10h16 ij misc 1 - r "ebio_c10h16" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_tol ij misc 1 - r "ebio_tol" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_bigalk ij misc 1 - r "ebio_bigalk" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_bigene ij misc 1 - r "ebio_bigene" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ch3oh ij misc 1 - r "ebio_ch3oh" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_acet ij misc 1 - r "ebio_acet" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_nh3 ij misc 1 - r "ebio_nh3" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_no2 ij misc 1 - r "ebio_no2" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_c2h5oh ij misc 1 - r "ebio_c2h5oh" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_ch3cooh ij misc 1 - r "ebio_ch3cooh" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_mek ij misc 1 - r "ebio_mek" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_c2h6 ij misc 1 - r "ebio_c2h6" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_c2h4 ij misc 1 - r "ebio_c2h4" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_c3h6 ij misc 1 - r "ebio_c3h6" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_c3h8 ij misc 1 - r "ebio_c3h8" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_so2 ij misc 1 - r "ebio_so2" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_dms ij misc 1 - r "ebio_dms" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_myrc ij misc 1 - r "ebio_myrc" "Actual biog emiss" "mol km^-2 hr^-1" +state real ebio_bpi ij misc 1 - r "ebio_bpi" "Actual biog emiss" "mol km^-2 hr^-1" # crimech megan2 bio emission species state real ebio_c5h8 ij misc 1 - - "ebio_c5h8" "Actual biog emiss" "mol km^-2 hr^-1" state real ebio_apinene ij misc 1 - - "ebio_apinene" "Actual biog emiss" "mol km^-2 hr^-1" @@ -533,6 +586,9 @@ state real ebio_nc4h10 ij misc 1 - - "ebi # Ocean CO2 fluxes for the GHG options state real ebio_co2oce ij misc 1 - i06rh "ebio_co2oce" "Ocean CO2 fluxes" "mol km^-2 hr^-1" +state real dust_flux ij misc 1 - rdu "dust_flux" "Dust flux from soil" "ug m^-2 s^-1" +state real seas_flux ij misc 1 - rdu "seas_flux" "Sea salt flux" "ug m^-2 s^-1" + # SESQ and MBO fluxes for the new SOA_VBS mechanism state real sebio_sesq ij misc 1 - i06r "sebio_sesq" "Reference biog emiss" "mol km^-2 hr^-1" state real ebio_sesq ij misc 1 - r "ebio_sesq" "Actual biog emiss" "mol km^-2 hr^-1" @@ -562,8 +618,18 @@ state real backg_oh ikj misc 1 - i08r "BACK state real backg_h2o2 ikj misc 1 - i08r "BACKG_H2O2" "Background H2O2 for Aerosol-GOcart option" "volume mixing ratio" state real backg_no3 ikj misc 1 - i08r "BACKG_NO3" "Background NO3 for Aerosol-GOcart option" "volume mixing ratio" -state real clayfrac ij misc 1 - i01r "CLAYFRAC" "Clay fraction in each grid cell (0-1)" "none" -state real sandfrac ij misc 1 - i01r "SANDFRAC" "Sand fraction in each grid cell (0-1)" "none" +# AFWA GOCART Dust +state real erod_dri ij. misc 1 - i012rdu "EROD_DRI" "frac. of erodible surface in each grid cell (0-1); DRI" "none" +state real lai_vegmask ij misc 0 - i012rh "LAI_VEGMASK" "MODIS LAI vegetation mask for this date; 0=no dust produced (vegetation)" "none" +state real lai_veg_8day i^j dyn_em 1 Z i1 "LAI_VEG_8DAY" "eight-day MODIS LAI veg; 0=no dust produced (vegetation)" "0 - 1 fraction" +state real clayfrac ij misc 1 - i01r "CLAYFRAC" "Clay fraction in each grid cell (0-1)" "none" +state real sandfrac ij misc 1 - i01r "SANDFRAC" "Sand fraction in each grid cell (0-1)" "none" +state real clayfrac_nga ij misc 1 - i01r "CLAYFRAC_NGA" "Clay fraction in each grid cell (0-1)" "none" +state real sandfrac_nga ij misc 1 - i01r "SANDFRAC_NGA" "Sand fraction in each grid cell (0-1)" "none" +state real afwa_dustloft ij misc 1 - h02 "AFWA_DUSTLOFT" "AFWA Diagnostic dust lofting potential (U10-U10t)" "m s^-1" +state real tot_dust ikj misc 1 - h02 "TOT_DUST" "Total dust concentration (0.1-20 um)" "ug m^-3" +state real tot_edust ij misc 1 - h02 "TOT_EDUST" "Total dust emission flux (0.1-20 um)" "g m^-2 s^-1" +state real vis_dust ikj misc 1 - h02 "VIS_DUST" "Visibility due to dust only" "m" # These 3D arrays are output from the SOA module for different purposes state real br_rto ikj misc 1 - r "BRNCH_RTO" "branching ratio to determine NOx condition" "" "ug m^-3" @@ -588,77 +654,75 @@ state real cu_co_ten ikj misc 1 - - "CU_ # Search for "modify tendncy list here" #------------------------------------------------------------------------------- state real - ikjf conv_ct 1 - - - -state real conv_co ikjf conv_ct 1 - rh "conv_co" "ACCUMULATED CONV TRANSPORT FOR CO" "ppmv" -state real conv_o3 ikjf conv_ct 1 - rh "conv_o3" "ACCUMULATED CONV TRANSPORT FOR O3" "ppmv" -state real conv_no ikjf conv_ct 1 - rh "conv_no" "ACCUMULATED CONV TRANSPORT FOR NO" "ppmv" -state real conv_no2 ikjf conv_ct 1 - rh "conv_no2" "ACCUMULATED CONV TRANSPORT FOR NO2" "ppmv" -state real conv_hno3 ikjf conv_ct 1 - rh "conv_hno3" "ACCUMULATED CONV TRANSPORT FOR HNO3" "ppmv" -state real conv_iso ikjf conv_ct 1 - rh "conv_iso" "ACCUMULATED CONV TRANSPORT FOR ISO" "ppmv" -state real conv_ho ikjf conv_ct 1 - rh "conv_ho" "ACCUMULATED CONV TRANSPORT FOR HO" "ppmv" -state real conv_ho2 ikjf conv_ct 1 - rh "conv_ho2" "ACCUMULATED CONV TRANSPORT FOR HO2" "ppmv" +state real conv_co ikjf conv_ct 1 - r "conv_co" "ACCUMULATED CONV TRANSPORT FOR CO" "ppmv" +state real conv_o3 ikjf conv_ct 1 - r "conv_o3" "ACCUMULATED CONV TRANSPORT FOR O3" "ppmv" +state real conv_no ikjf conv_ct 1 - r "conv_no" "ACCUMULATED CONV TRANSPORT FOR NO" "ppmv" +state real conv_no2 ikjf conv_ct 1 - r "conv_no2" "ACCUMULATED CONV TRANSPORT FOR NO2" "ppmv" +state real conv_hno3 ikjf conv_ct 1 - r "conv_hno3" "ACCUMULATED CONV TRANSPORT FOR HNO3" "ppmv" +state real conv_iso ikjf conv_ct 1 - r "conv_iso" "ACCUMULATED CONV TRANSPORT FOR ISO" "ppmv" +state real conv_ho ikjf conv_ct 1 - r "conv_ho" "ACCUMULATED CONV TRANSPORT FOR HO" "ppmv" +state real conv_ho2 ikjf conv_ct 1 - r "conv_ho2" "ACCUMULATED CONV TRANSPORT FOR HO2" "ppmv" state real - ikjf chem_ct 1 - - - -state real chem_co ikjf chem_ct 1 - rh "chem_co" "ACCUMULATED CHEM TENDENCY FOR CO" "ppmv" -state real chem_o3 ikjf chem_ct 1 - rh "chem_o3" "ACCUMULATED CHEM TENDENCY FOR O3" "ppmv" -state real chem_no ikjf chem_ct 1 - rh "chem_no" "ACCUMULATED CHEM TENDENCY FOR NO" "ppmv" -state real chem_no2 ikjf chem_ct 1 - rh "chem_no2" "ACCUMULATED CHEM TENDENCY FOR NO2" "ppmv" -state real chem_hno3 ikjf chem_ct 1 - rh "chem_hno3" "ACCUMULATED CHEM TENDENCY FOR HNO3" "ppmv" -state real chem_iso ikjf chem_ct 1 - rh "chem_iso" "ACCUMULATED CHEM TENDENCY FOR ISO" "ppmv" -state real chem_ho ikjf chem_ct 1 - rh "chem_ho" "ACCUMULATED CHEM TENDENCY FOR HO" "ppmv" -state real chem_ho2 ikjf chem_ct 1 - rh "chem_ho2" "ACCUMULATED CHEM TENDENCY FOR HO2" "ppmv" +state real chem_co ikjf chem_ct 1 - r "chem_co" "ACCUMULATED CHEM TENDENCY FOR CO" "ppmv" +state real chem_o3 ikjf chem_ct 1 - r "chem_o3" "ACCUMULATED CHEM TENDENCY FOR O3" "ppmv" +state real chem_no ikjf chem_ct 1 - r "chem_no" "ACCUMULATED CHEM TENDENCY FOR NO" "ppmv" +state real chem_no2 ikjf chem_ct 1 - r "chem_no2" "ACCUMULATED CHEM TENDENCY FOR NO2" "ppmv" +state real chem_hno3 ikjf chem_ct 1 - r "chem_hno3" "ACCUMULATED CHEM TENDENCY FOR HNO3" "ppmv" +state real chem_iso ikjf chem_ct 1 - r "chem_iso" "ACCUMULATED CHEM TENDENCY FOR ISO" "ppmv" +state real chem_ho ikjf chem_ct 1 - r "chem_ho" "ACCUMULATED CHEM TENDENCY FOR HO" "ppmv" +state real chem_ho2 ikjf chem_ct 1 - r "chem_ho2" "ACCUMULATED CHEM TENDENCY FOR HO2" "ppmv" state real - ikjf vmix_ct 1 - - - -state real vmix_co ikjf vmix_ct 1 - rh "vmix_co" "ACCUMULATED TENDENCY FOR CO BY VERTICAL MIXING" "ppmv" -state real vmix_o3 ikjf vmix_ct 1 - rh "vmix_o3" "ACCUMULATED TENDENCY FOR O3 BY VERTICAL MIXING" "ppmv" -state real vmix_no ikjf vmix_ct 1 - rh "vmix_no" "ACCUMULATED TENDENCY FOR NO BY VERTICAL MIXING" "ppmv" -state real vmix_no2 ikjf vmix_ct 1 - rh "vmix_no2" "ACCUMULATED TENDENCY FOR NO2 BY VERTICAL MIXING" "ppmv" -state real vmix_hno3 ikjf vmix_ct 1 - rh "vmix_hno3" "ACCUMULATED TENDENCY FOR HNO3 BY VERTICAL MIXING" "ppmv" -state real vmix_iso ikjf vmix_ct 1 - rh "vmix_iso" "ACCUMULATED TENDENCY FOR ISO BY VERTICAL MIXING" "ppmv" -state real vmix_ho ikjf vmix_ct 1 - rh "vmix_ho" "ACCUMULATED TENDENCY FOR HO BY VERTICAL MIXING" "ppmv" -state real vmix_ho2 ikjf vmix_ct 1 - rh "vmix_ho2" "ACCUMULATED TENDENCY FOR HO2 BY VERTICAL MIXING" "ppmv" +state real vmix_co ikjf vmix_ct 1 - r "vmix_co" "ACCUMULATED TENDENCY FOR CO BY VERTICAL MIXING" "ppmv" +state real vmix_o3 ikjf vmix_ct 1 - r "vmix_o3" "ACCUMULATED TENDENCY FOR O3 BY VERTICAL MIXING" "ppmv" +state real vmix_no ikjf vmix_ct 1 - r "vmix_no" "ACCUMULATED TENDENCY FOR NO BY VERTICAL MIXING" "ppmv" +state real vmix_no2 ikjf vmix_ct 1 - r "vmix_no2" "ACCUMULATED TENDENCY FOR NO2 BY VERTICAL MIXING" "ppmv" +state real vmix_hno3 ikjf vmix_ct 1 - r "vmix_hno3" "ACCUMULATED TENDENCY FOR HNO3 BY VERTICAL MIXING" "ppmv" +state real vmix_iso ikjf vmix_ct 1 - r "vmix_iso" "ACCUMULATED TENDENCY FOR ISO BY VERTICAL MIXING" "ppmv" +state real vmix_ho ikjf vmix_ct 1 - r "vmix_ho" "ACCUMULATED TENDENCY FOR HO BY VERTICAL MIXING" "ppmv" +state real vmix_ho2 ikjf vmix_ct 1 - r "vmix_ho2" "ACCUMULATED TENDENCY FOR HO2 BY VERTICAL MIXING" "ppmv" state real - ikjf advh_ct 1 - - - -state real advh_co ikjf advh_ct 1 - rh "advh_co" "ACCUMULATED TENDENCY FOR CO BY HORIZONTAL ADVECTION" "ppmv" -state real advh_o3 ikjf advh_ct 1 - rh "advh_o3" "ACCUMULATED TENDENCY FOR O3 BY HORIZONTAL ADVECTION" "ppmv" -state real advh_no ikjf advh_ct 1 - rh "advh_no" "ACCUMULATED TENDENCY FOR NO BY HORIZONTAL ADVECTION" "ppmv" -state real advh_no2 ikjf advh_ct 1 - rh "advh_no2" "ACCUMULATED TENDENCY FOR NO2 BY HORIZONTAL ADVECTION" "ppmv" -state real advh_hno3 ikjf advh_ct 1 - rh "advh_hno3" "ACCUMULATED TENDENCY FOR HNO3 BY HORIZONTAL ADVECTION" "ppmv" -state real advh_iso ikjf advh_ct 1 - rh "advh_iso" "ACCUMULATED TENDENCY FOR ISO BY HORIZONTAL ADVECTION" "ppmv" -state real advh_ho ikjf advh_ct 1 - rh "advh_ho" "ACCUMULATED TENDENCY FOR HO BY HORIZONTAL ADVECTION" "ppmv" -state real advh_ho2 ikjf advh_ct 1 - rh "advh_ho2" "ACCUMULATED TENDENCY FOR HO2 BY HORIZONTAL ADVECTION" "ppmv" +state real advh_co ikjf advh_ct 1 - r "advh_co" "ACCUMULATED TENDENCY FOR CO BY HORIZONTAL ADVECTION" "ppmv" +state real advh_o3 ikjf advh_ct 1 - r "advh_o3" "ACCUMULATED TENDENCY FOR O3 BY HORIZONTAL ADVECTION" "ppmv" +state real advh_no ikjf advh_ct 1 - r "advh_no" "ACCUMULATED TENDENCY FOR NO BY HORIZONTAL ADVECTION" "ppmv" +state real advh_no2 ikjf advh_ct 1 - r "advh_no2" "ACCUMULATED TENDENCY FOR NO2 BY HORIZONTAL ADVECTION" "ppmv" +state real advh_hno3 ikjf advh_ct 1 - r "advh_hno3" "ACCUMULATED TENDENCY FOR HNO3 BY HORIZONTAL ADVECTION" "ppmv" +state real advh_iso ikjf advh_ct 1 - r "advh_iso" "ACCUMULATED TENDENCY FOR ISO BY HORIZONTAL ADVECTION" "ppmv" +state real advh_ho ikjf advh_ct 1 - r "advh_ho" "ACCUMULATED TENDENCY FOR HO BY HORIZONTAL ADVECTION" "ppmv" +state real advh_ho2 ikjf advh_ct 1 - r "advh_ho2" "ACCUMULATED TENDENCY FOR HO2 BY HORIZONTAL ADVECTION" "ppmv" state real - ikjf advz_ct 1 - - - -state real advz_co ikjf advz_ct 1 - rh "advz_co" "ACCUMULATED TENDENCY FOR CO BY VERTICAL ADVECTION" "ppmv" -state real advz_o3 ikjf advz_ct 1 - rh "advz_o3" "ACCUMULATED TENDENCY FOR O3 BY VERTICAL ADVECTION" "ppmv" -state real advz_no ikjf advz_ct 1 - rh "advz_no" "ACCUMULATED TENDENCY FOR NO BY VERTICAL ADVECTION" "ppmv" -state real advz_no2 ikjf advz_ct 1 - rh "advz_no2" "ACCUMULATED TENDENCY FOR NO2 BY VERTICAL ADVECTION" "ppmv" -state real advz_hno3 ikjf advz_ct 1 - rh "advz_hno3" "ACCUMULATED TENDENCY FOR HNO3 BY VERTICAL ADVECTION" "ppmv" -state real advz_iso ikjf advz_ct 1 - rh "advz_iso" "ACCUMULATED TENDENCY FOR ISO BY VERTICAL ADVECTION" "ppmv" -state real advz_ho ikjf advz_ct 1 - rh "advz_ho" "ACCUMULATED TENDENCY FOR HO BY VERTICAL ADVECTION" "ppmv" -state real advz_ho2 ikjf advz_ct 1 - rh "advz_ho2" "ACCUMULATED TENDENCY FOR HO2 BY VERTICAL ADVECTION" "ppmv" +state real advz_co ikjf advz_ct 1 - r "advz_co" "ACCUMULATED TENDENCY FOR CO BY VERTICAL ADVECTION" "ppmv" +state real advz_o3 ikjf advz_ct 1 - r "advz_o3" "ACCUMULATED TENDENCY FOR O3 BY VERTICAL ADVECTION" "ppmv" +state real advz_no ikjf advz_ct 1 - r "advz_no" "ACCUMULATED TENDENCY FOR NO BY VERTICAL ADVECTION" "ppmv" +state real advz_no2 ikjf advz_ct 1 - r "advz_no2" "ACCUMULATED TENDENCY FOR NO2 BY VERTICAL ADVECTION" "ppmv" +state real advz_hno3 ikjf advz_ct 1 - r "advz_hno3" "ACCUMULATED TENDENCY FOR HNO3 BY VERTICAL ADVECTION" "ppmv" +state real advz_iso ikjf advz_ct 1 - r "advz_iso" "ACCUMULATED TENDENCY FOR ISO BY VERTICAL ADVECTION" "ppmv" +state real advz_ho ikjf advz_ct 1 - r "advz_ho" "ACCUMULATED TENDENCY FOR HO BY VERTICAL ADVECTION" "ppmv" +state real advz_ho2 ikjf advz_ct 1 - r "advz_ho2" "ACCUMULATED TENDENCY FOR HO2 BY VERTICAL ADVECTION" "ppmv" # deposition velocities for diagnostic package, feel free to add if you like! # state real - i%jf dvel - - - - "deposition velocities" "" -state real dvel_o3 i%jf dvel 1 - - "dvel_o3" "O3 deposition velocity " "cm/s" -state real dvel_no i%jf dvel 1 - - "dvel_no" "NO deposition velocity " "cm/s" -state real dvel_no2 i%jf dvel 1 - - "dvel_no2" "NO2 deposition velocity " "cm/s" -state real dvel_nh3 i%jf dvel 1 - - "dvel_nh3" "NH3 deposition velocity " "cm/s" -state real dvel_hno3 i%jf dvel 1 - - "dvel_hno3" "HNO3 deposition velocity " "cm/s" +state real dvel_o3 i%jf dvel 1 - rh "dvel_o3" "O3 deposition velocity " "cm/s" +state real dvel_no i%jf dvel 1 - - "dvel_no" "NO deposition velocity " "cm/s" +state real dvel_no2 i%jf dvel 1 - - "dvel_no2" "NO2 deposition velocity " "cm/s" +state real dvel_nh3 i%jf dvel 1 - - "dvel_nh3" "NH3 deposition velocity " "cm/s" +state real dvel_hno3 i%jf dvel 1 - - "dvel_hno3" "HNO3 deposition velocity " "cm/s" state real dvel_hno4 i%jf dvel 1 - - "dvel_hno4" "HNO4 deposition velocity " "cm/s" -state real dvel_h2o2 i%jf dvel 1 - - "dvel_h2o2" "H2O2 deposition velocity " "cm/s" +state real dvel_h2o2 i%jf dvel 1 - - "dvel_h2o2" "H2O2 deposition velocity " "cm/s" state real dvel_co i%jf dvel 1 - - "dvel_co" "CO deposition velocity " "cm/s" state real dvel_ch3ooh i%jf dvel 1 - - "dvel_ch3ooh" "CH3OOH deposition velocity " "cm/s" -state real dvel_hcho i%jf dvel 1 - - "dvel_hcho" "HCHO deposition velocity " "cm/s" +state real dvel_hcho i%jf dvel 1 - - "dvel_hcho" "HCHO deposition velocity " "cm/s" state real dvel_ch3oh i%jf dvel 1 - - "dvel_ch3oh" "CH3OH deposition velocity " "cm/s" state real dvel_eo2 i%jf dvel 1 - - "dvel_eo2" "EO2 deposition velocity " "cm/s" state real dvel_ald i%jf dvel 1 - - "dvel_ald" "ALD deposition velocity " "cm/s" state real dvel_ch3cooh i%jf dvel 1 - - "dvel_ch3cooh" "CH3COOH deposition velocity " "cm/s" state real dvel_acet i%jf dvel 1 - - "dvel_acet" "ACET deposition velocity " "cm/s" state real dvel_mgly i%jf dvel 1 - - "dvel_mgly" "MGLY deposition velocity " "cm/s" -# 20130816 acd_ck_glysoa start state real dvel_gly i%jf dvel 1 - - "dvel_gly" "GLY deposition velocity " "cm/s" -# 20130816 acd_ck_glysoa end state real dvel_paa i%jf dvel 1 - - "dvel_paa" "PAA deposition velocity " "cm/s" state real dvel_pooh i%jf dvel 1 - - "dvel_pooh" "POOH deposition velocity " "cm/s" state real dvel_pan i%jf dvel 1 - - "dvel_pan" "PAN deposition velocity " "cm/s" @@ -679,9 +743,281 @@ state real dvel_alkooh i%jf dvel 1 - - "d state real dvel_mekooh i%jf dvel 1 - - "dvel_mekooh" "MEKOOH deposition velocity " "cm/s" state real dvel_tolooh i%jf dvel 1 - - "dvel_tolooh" "TOLOOH deposition velocity " "cm/s" state real dvel_xooh i%jf dvel 1 - - "dvel_xooh" "XOOH deposition velocity " "cm/s" -state real dvel_so2 i%jf dvel 1 - - "dvel_so2" "SO2 deposition velocity " "cm/s" -state real dvel_so4 i%jf dvel 1 - - "dvel_so4" "SO4 deposition velocity " "cm/s" +state real dvel_so2 i%jf dvel 1 - - "dvel_so2" "SO2 deposition velocity " "cm/s" +state real dvel_so4 i%jf dvel 1 - - "dvel_so4" "SO4 deposition velocity " "cm/s" state real dvel_terpooh i%jf dvel 1 - - "dvel_terpooh" "TERPOOH deposition velocity " "cm/s" +state real dvel_cvasoaX i%jf dvel 1 - - "dvel_cvasoaX" "CVASOAX deposition velocity " "cm/s" +state real dvel_cvasoa1 i%jf dvel 1 - - "dvel_cvasoa1" "CVASOA1 deposition velocity " "cm/s" +state real dvel_cvasoa2 i%jf dvel 1 - - "dvel_cvasoa2" "CVASOA2 deposition velocity " "cm/s" +state real dvel_cvasoa3 i%jf dvel 1 - - "dvel_cvasoa3" "CVASOA3 deposition velocity " "cm/s" +state real dvel_cvasoa4 i%jf dvel 1 - - "dvel_cvasoa4" "CVASOA4 deposition velocity " "cm/s" +state real dvel_cvbsoaX i%jf dvel 1 - - "dvel_cvbsoaX" "CVBSOAX deposition velocity " "cm/s" +state real dvel_cvbsoa1 i%jf dvel 1 - - "dvel_cvbsoa1" "CVBSOA1 deposition velocity " "cm/s" +state real dvel_cvbsoa2 i%jf dvel 1 - - "dvel_cvbsoa2" "CVBSOA2 deposition velocity " "cm/s" +state real dvel_cvbsoa3 i%jf dvel 1 - - "dvel_cvbsoa3" "CVBSOA3 deposition velocity " "cm/s" +state real dvel_cvbsoa4 i%jf dvel 1 - - "dvel_cvbsoa4" "CVBSOA4 deposition velocity " "cm/s" + +# accumulated dry deposition +state real ddmass_o3 i%jf dvel 1 - rdu "ddmass_o3" "O3 dry deposition, accumulated " "mol/m2" +state real ddmass_no i%jf dvel 1 - rdu "ddmass_no" "NO dry deposition, accumulated " "mol/m2" +state real ddmass_no2 i%jf dvel 1 - rdu "ddmass_no2" "NO2 dry deposition, accumulated" "mol/m2" +state real ddmass_nh3 i%jf dvel 1 - rdu "ddmass_nh3" "NH3 dry deposition, accumulated" "mol/m2" +state real ddmass_hno3 i%jf dvel 1 - rdu "ddmass_hno3" "HNO3 dry deposition, accumulated" "mol/m2" +state real ddmass_hno4 i%jf dvel 1 - rdu "ddmass_hno4" "HNO4 dry deposition, accumulated" "mol/m2" +state real ddmass_h2o2 i%jf dvel 1 - rdu "ddmass_h2o2" "H2O2 dry deposition, accumulated" "mol/m2" +state real ddmass_co i%jf dvel 1 - rdu "ddmass_co" "CO dry deposition, accumulated " "mol/m2" +state real ddmass_ch3ooh i%jf dvel 1 - rdu "ddmass_ch3ooh" "CH3OOH dry deposition, accumulated " "mol/m2" +state real ddmass_hcho i%jf dvel 1 - rdu "ddmass_hcho" "HCHO dry deposition, accumulated" "mol/m2" +state real ddmass_ch3oh i%jf dvel 1 - rdu "ddmass_ch3oh" "CH3OH dry deposition, accumulated " "mol/m2" +state real ddmass_eo2 i%jf dvel 1 - rdu "ddmass_eo2" "EO2 dry deposition, accumulated" "mol/m2" +state real ddmass_ald i%jf dvel 1 - rdu "ddmass_ald" "ALD dry deposition, accumulated" "mol/m2" +state real ddmass_ch3cooh i%jf dvel 1 - rdu "ddmass_ch3cooh" "CH3COOH dry deposition, accumulated " "mol/m2" +state real ddmass_acet i%jf dvel 1 - rdu "ddmass_acet" "ACET dry deposition, accumulated" "mol/m2" +state real ddmass_mgly i%jf dvel 1 - rdu "ddmass_mgly" "MGLY dry deposition, accumulated" "mol/m2" +state real ddmass_gly i%jf dvel 1 - rdu "ddmass_gly" "GLY dry deposition, accumulated" "mol/m2" +state real ddmass_paa i%jf dvel 1 - rdu "ddmass_paa" "PAA dry deposition, accumulated" "mol/m2" +state real ddmass_pooh i%jf dvel 1 - rdu "ddmass_pooh" "POOH dry deposition, accumulated" "mol/m2" +state real ddmass_pan i%jf dvel 1 - rdu "ddmass_pan" "PAN dry deposition, accumulated" "mol/m2" +state real ddmass_mpan i%jf dvel 1 - rdu "ddmass_mpan" "MPAN dry deposition, accumulated" "mol/m2" +state real ddmass_mco3 i%jf dvel 1 - rdu "ddmass_mco3" "MCO3 dry deposition, accumulated" "mol/m2" +state real ddmass_mvkooh i%jf dvel 1 - rdu "ddmass_mvkooh" "MVKOOH dry deposition, accumulated " "mol/m2" +state real ddmass_c2h5oh i%jf dvel 1 - rdu "ddmass_c2h5oh" "C2H5OH dry deposition, accumulated " "mol/m2" +state real ddmass_etooh i%jf dvel 1 - rdu "ddmass_etooh" "ETOOH dry deposition, accumulated " "mol/m2" +state real ddmass_prooh i%jf dvel 1 - rdu "ddmass_prooh" "PROOH dry deposition, accumulated " "mol/m2" +state real ddmass_acetp i%jf dvel 1 - rdu "ddmass_acetp" "ACETP dry deposition, accumulated " "mol/m2" +state real ddmass_onit i%jf dvel 1 - rdu "ddmass_onit" "ONIT dry deposition, accumulated" "mol/m2" +state real ddmass_onitr i%jf dvel 1 - rdu "ddmass_onitr" "ONITR dry deposition, accumulated " "mol/m2" +state real ddmass_isooh i%jf dvel 1 - rdu "ddmass_isooh" "ISOOH dry deposition, accumulated " "mol/m2" +state real ddmass_acetol i%jf dvel 1 - rdu "ddmass_acetol" "ACETOL dry deposition, accumulated " "mol/m2" +state real ddmass_glyald i%jf dvel 1 - rdu "ddmass_glyald" "GLYALD dry deposition, accumulated " "mol/m2" +state real ddmass_hydrald i%jf dvel 1 - rdu "ddmass_hydrald" "HYDRALD dry deposition, accumulated " "mol/m2" +state real ddmass_alkooh i%jf dvel 1 - rdu "ddmass_alkooh" "ALKOOH dry deposition, accumulated " "mol/m2" +state real ddmass_mekooh i%jf dvel 1 - rdu "ddmass_mekooh" "MEKOOH dry deposition, accumulated " "mol/m2" +state real ddmass_tolooh i%jf dvel 1 - rdu "ddmass_tolooh" "TOLOOH dry deposition, accumulated " "mol/m2" +state real ddmass_xooh i%jf dvel 1 - rdu "ddmass_xooh" "XOOH dry deposition, accumulated" "mol/m2" +state real ddmass_so2 i%jf dvel 1 - rdu "ddmass_so2" "SO2 dry deposition, accumulated" "mol/m2" +state real ddmass_so4 i%jf dvel 1 - rdu "ddmass_so4" "SO4 dry deposition, accumulated" "mol/m2" +state real ddmass_terpooh i%jf dvel 1 - rdu "ddmass_terpooh" "TERPOOH dry deposition, accumulated" "mol/m2" +state real ddmass_cvasoaX i%jf dvel 1 - rdu "ddmass_cvasoaX" "CVASOAX dry deposition, accumulated" "mol/m2" +state real ddmass_cvasoa1 i%jf dvel 1 - rdu "ddmass_cvasoa1" "CVASOA1 dry deposition, accumulated" "mol/m2" +state real ddmass_cvasoa2 i%jf dvel 1 - rdu "ddmass_cvasoa2" "CVASOA2 dry deposition, accumulated" "mol/m2" +state real ddmass_cvasoa3 i%jf dvel 1 - rdu "ddmass_cvasoa3" "CVASOA3 dry deposition, accumulated" "mol/m2" +state real ddmass_cvasoa4 i%jf dvel 1 - rdu "ddmass_cvasoa4" "CVASOA4 dry deposition, accumulated" "mol/m2" +state real ddmass_cvbsoaX i%jf dvel 1 - rdu "ddmass_cvbsoaX" "CVBSOAX dry deposition, accumulated" "mol/m2" +state real ddmass_cvbsoa1 i%jf dvel 1 - rdu "ddmass_cvbsoa1" "CVBSOA1 dry deposition, accumulated" "mol/m2" +state real ddmass_cvbsoa2 i%jf dvel 1 - rdu "ddmass_cvbsoa2" "CVBSOA2 dry deposition, accumulated" "mol/m2" +state real ddmass_cvbsoa3 i%jf dvel 1 - rdu "ddmass_cvbsoa3" "CVBSOA3 dry deposition, accumulated" "mol/m2" +state real ddmass_cvbsoa4 i%jf dvel 1 - rdu "ddmass_cvbsoa4" "CVBSOA4 dry deposition, accumulated" "mol/m2" + +#CB05/VBS/SORG +state real ddmass_so4aj i%jf dvel 1 - rhdu "ddmass_so4aj" "so4aj dry deposition, accumulated" "ug/m2" +state real ddmass_so4ai i%jf dvel 1 - rhdu "ddmass_so4ai" "so4ai dry deposition, accumulated" "ug/m2" +state real ddmass_no3aj i%jf dvel 1 - rhdu "ddmass_no3aj" "no3aj dry deposition, accumulated" "ug/m2" +state real ddmass_no3ai i%jf dvel 1 - rhdu "ddmass_no3ai" "no3ai dry deposition, accumulated" "ug/m2" +state real ddmass_nh4aj i%jf dvel 1 - rhdu "ddmass_nh4aj" "nh4aj dry deposition, accumulated" "ug/m2" +state real ddmass_nh4ai i%jf dvel 1 - rhdu "ddmass_nh4ai" "nh4ai dry deposition, accumulated" "ug/m2" + +state real ddmass_so4_a01 i%jf dvel 1 - rdu "ddmass_so4_a01" "so4_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_no3_a01 i%jf dvel 1 - rdu "ddmass_no3_a01" "no3_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_cl_a01 i%jf dvel 1 - rdu "ddmass_cl_a01" "cl_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_nh4_a01 i%jf dvel 1 - rdu "ddmass_nh4_a01" "nh4_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_na_a01 i%jf dvel 1 - rdu "ddmass_na_a01" "na_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_oin_a01 i%jf dvel 1 - rdu "ddmass_oin_a01" "oin_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_oc_a01 i%jf dvel 1 - rdu "ddmass_oc_a01" "oc_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_bc_a01 i%jf dvel 1 - rdu "ddmass_bc_a01" "bc_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_smpa_a01 i%jf dvel 1 - rdu "ddmass_smpa_a01" "smpa_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_smpbb_a01 i%jf dvel 1 - rdu "ddmass_smpbb_a01" "smpbb_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_glysoa_a01 i%jf dvel 1 - rdu "ddmass_glysoa_a01" "glysoa_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_c_a01 i%jf dvel 1 - rdu "ddmass_biog1_c_a01" "biog1_c_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_o_a01 i%jf dvel 1 - rdu "ddmass_biog1_o_a01" "biog1_o_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_asoaX_a01 i%jf dvel 1 - rdu "ddmass_asoaX_a01" "asoaX_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa1_a01 i%jf dvel 1 - rdu "ddmass_asoa1_a01" "asoa1_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa2_a01 i%jf dvel 1 - rdu "ddmass_asoa2_a01" "asoa2_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa3_a01 i%jf dvel 1 - rdu "ddmass_asoa3_a01" "asoa3_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa4_a01 i%jf dvel 1 - rdu "ddmass_asoa4_a01" "asoa4_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoaX_a01 i%jf dvel 1 - rdu "ddmass_bsoaX_a01" "bsoaX_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa1_a01 i%jf dvel 1 - rdu "ddmass_bsoa1_a01" "bsoa1_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa2_a01 i%jf dvel 1 - rdu "ddmass_bsoa2_a01" "bsoa2_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa3_a01 i%jf dvel 1 - rdu "ddmass_bsoa3_a01" "bsoa3_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa4_a01 i%jf dvel 1 - rdu "ddmass_bsoa4_a01" "bsoa4_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_so4_a02 i%jf dvel 1 - rdu "ddmass_so4_a02" "so4_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_no3_a02 i%jf dvel 1 - rdu "ddmass_no3_a02" "no3_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_cl_a02 i%jf dvel 1 - rdu "ddmass_cl_a02" "cl_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_nh4_a02 i%jf dvel 1 - rdu "ddmass_nh4_a02" "nh4_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_na_a02 i%jf dvel 1 - rdu "ddmass_na_a02" "na_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_oin_a02 i%jf dvel 1 - rdu "ddmass_oin_a02" "oin_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_oc_a02 i%jf dvel 1 - rdu "ddmass_oc_a02" "oc_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_bc_a02 i%jf dvel 1 - rdu "ddmass_bc_a02" "bc_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_smpa_a02 i%jf dvel 1 - rdu "ddmass_smpa_a02" "smpa_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_smpbb_a02 i%jf dvel 1 - rdu "ddmass_smpbb_a02" "smpbb_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_glysoa_a02 i%jf dvel 1 - rdu "ddmass_glysoa_a02" "glysoa_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_c_a02 i%jf dvel 1 - rdu "ddmass_biog1_c_a02" "biog1_c_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_o_a02 i%jf dvel 1 - rdu "ddmass_biog1_o_a02" "biog1_o_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_asoaX_a02 i%jf dvel 1 - rdu "ddmass_asoaX_a02" "asoaX_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa1_a02 i%jf dvel 1 - rdu "ddmass_asoa1_a02" "asoa1_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa2_a02 i%jf dvel 1 - rdu "ddmass_asoa2_a02" "asoa2_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa3_a02 i%jf dvel 1 - rdu "ddmass_asoa3_a02" "asoa3_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa4_a02 i%jf dvel 1 - rdu "ddmass_asoa4_a02" "asoa4_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoaX_a02 i%jf dvel 1 - rdu "ddmass_bsoaX_a02" "bsoaX_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa1_a02 i%jf dvel 1 - rdu "ddmass_bsoa1_a02" "bsoa1_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa2_a02 i%jf dvel 1 - rdu "ddmass_bsoa2_a02" "bsoa2_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa3_a02 i%jf dvel 1 - rdu "ddmass_bsoa3_a02" "bsoa3_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa4_a02 i%jf dvel 1 - rdu "ddmass_bsoa4_a02" "bsoa4_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_so4_a03 i%jf dvel 1 - rdu "ddmass_so4_a03" "so4_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_no3_a03 i%jf dvel 1 - rdu "ddmass_no3_a03" "no3_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_cl_a03 i%jf dvel 1 - rdu "ddmass_cl_a03" "cl_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_nh4_a03 i%jf dvel 1 - rdu "ddmass_nh4_a03" "nh4_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_na_a03 i%jf dvel 1 - rdu "ddmass_na_a03" "na_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_oin_a03 i%jf dvel 1 - rdu "ddmass_oin_a03" "oin_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_oc_a03 i%jf dvel 1 - rdu "ddmass_oc_a03" "oc_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_bc_a03 i%jf dvel 1 - rdu "ddmass_bc_a03" "bc_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_smpa_a03 i%jf dvel 1 - rdu "ddmass_smpa_a03" "smpa_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_smpbb_a03 i%jf dvel 1 - rdu "ddmass_smpbb_a03" "smpbb_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_glysoa_a03 i%jf dvel 1 - rdu "ddmass_glysoa_a03" "glysoa_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_c_a03 i%jf dvel 1 - rdu "ddmass_biog1_c_a03" "biog1_c_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_o_a03 i%jf dvel 1 - rdu "ddmass_biog1_o_a03" "biog1_o_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_asoaX_a03 i%jf dvel 1 - rdu "ddmass_asoaX_a03" "asoaX_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa1_a03 i%jf dvel 1 - rdu "ddmass_asoa1_a03" "asoa1_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa2_a03 i%jf dvel 1 - rdu "ddmass_asoa2_a03" "asoa2_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa3_a03 i%jf dvel 1 - rdu "ddmass_asoa3_a03" "asoa3_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa4_a03 i%jf dvel 1 - rdu "ddmass_asoa4_a03" "asoa4_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoaX_a03 i%jf dvel 1 - rdu "ddmass_bsoaX_a03" "bsoaX_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa1_a03 i%jf dvel 1 - rdu "ddmass_bsoa1_a03" "bsoa1_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa2_a03 i%jf dvel 1 - rdu "ddmass_bsoa2_a03" "bsoa2_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa3_a03 i%jf dvel 1 - rdu "ddmass_bsoa3_a03" "bsoa3_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa4_a03 i%jf dvel 1 - rdu "ddmass_bsoa4_a03" "bsoa4_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_so4_a04 i%jf dvel 1 - rdu "ddmass_so4_a04" "so4_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_no3_a04 i%jf dvel 1 - rdu "ddmass_no3_a04" "no3_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_cl_a04 i%jf dvel 1 - rdu "ddmass_cl_a04" "cl_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_nh4_a04 i%jf dvel 1 - rdu "ddmass_nh4_a04" "nh4_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_na_a04 i%jf dvel 1 - rdu "ddmass_na_a04" "na_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_oin_a04 i%jf dvel 1 - rdu "ddmass_oin_a04" "oin_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_oc_a04 i%jf dvel 1 - rdu "ddmass_oc_a04" "oc_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_bc_a04 i%jf dvel 1 - rdu "ddmass_bc_a04" "bc_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_smpa_a04 i%jf dvel 1 - rdu "ddmass_smpa_a04" "smpa_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_smpbb_a04 i%jf dvel 1 - rdu "ddmass_smpbb_a04" "smpbb_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_glysoa_a04 i%jf dvel 1 - rdu "ddmass_glysoa_a04" "glysoa_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_c_a04 i%jf dvel 1 - rdu "ddmass_biog1_c_a04" "biog1_c_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_o_a04 i%jf dvel 1 - rdu "ddmass_biog1_o_a04" "biog1_o_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_asoaX_a04 i%jf dvel 1 - rdu "ddmass_asoaX_a04" "asoaX_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa1_a04 i%jf dvel 1 - rdu "ddmass_asoa1_a04" "asoa1_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa2_a04 i%jf dvel 1 - rdu "ddmass_asoa2_a04" "asoa2_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa3_a04 i%jf dvel 1 - rdu "ddmass_asoa3_a04" "asoa3_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa4_a04 i%jf dvel 1 - rdu "ddmass_asoa4_a04" "asoa4_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoaX_a04 i%jf dvel 1 - rdu "ddmass_bsoaX_a04" "bsoaX_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa1_a04 i%jf dvel 1 - rdu "ddmass_bsoa1_a04" "bsoa1_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa2_a04 i%jf dvel 1 - rdu "ddmass_bsoa2_a04" "bsoa2_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa3_a04 i%jf dvel 1 - rdu "ddmass_bsoa3_a04" "bsoa3_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa4_a04 i%jf dvel 1 - rdu "ddmass_bsoa4_a04" "bsoa4_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_ca_a01 i%jf dvel 1 - rdu "ddmass_ca_a01" "ca_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_ca_a02 i%jf dvel 1 - rdu "ddmass_ca_a02" "ca_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_ca_a03 i%jf dvel 1 - rdu "ddmass_ca_a03" "ca_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_ca_a04 i%jf dvel 1 - rdu "ddmass_ca_a04" "ca_a04 dry deposition, accumulated" "ug/m2" +state real ddmass_co3_a01 i%jf dvel 1 - rdu "ddmass_co3_a01" "co3_a01 dry deposition, accumulated" "ug/m2" +state real ddmass_co3_a02 i%jf dvel 1 - rdu "ddmass_co3_a02" "co3_a02 dry deposition, accumulated" "ug/m2" +state real ddmass_co3_a03 i%jf dvel 1 - rdu "ddmass_co3_a03" "co3_a03 dry deposition, accumulated" "ug/m2" +state real ddmass_co3_a04 i%jf dvel 1 - rdu "ddmass_co3_a04" "co3_a04 dry deposition, accumulated" "ug/m2" + +state real ddmass_so4_cw01 i%jf dvel 1 - rdu "ddmass_so4_cw01" "so4_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_no3_cw01 i%jf dvel 1 - rdu "ddmass_no3_cw01" "no3_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_cl_cw01 i%jf dvel 1 - rdu "ddmass_cl_cw01" "cl_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_nh4_cw01 i%jf dvel 1 - rdu "ddmass_nh4_cw01" "nh4_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_na_cw01 i%jf dvel 1 - rdu "ddmass_na_cw01" "na_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_oin_cw01 i%jf dvel 1 - rdu "ddmass_oin_cw01" "oin_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_oc_cw01 i%jf dvel 1 - rdu "ddmass_oc_cw01" "oc_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_bc_cw01 i%jf dvel 1 - rdu "ddmass_bc_cw01" "bc_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_smpa_cw01 i%jf dvel 1 - rdu "ddmass_smpa_cw01" "smpa_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_smpbb_cw01 i%jf dvel 1 - rdu "ddmass_smpbb_cw01" "smpbb_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_glysoa_cw01 i%jf dvel 1 - rdu "ddmass_glysoa_cw01" "glysoa_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_c_cw01 i%jf dvel 1 - rdu "ddmass_biog1_c_cw01" "biog1_c_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_o_cw01 i%jf dvel 1 - rdu "ddmass_biog1_o_cw01" "biog1_o_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_asoaX_cw01 i%jf dvel 1 - rdu "ddmass_asoaX_cw01" "asoaX_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa1_cw01 i%jf dvel 1 - rdu "ddmass_asoa1_cw01" "asoa1_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa2_cw01 i%jf dvel 1 - rdu "ddmass_asoa2_cw01" "asoa2_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa3_cw01 i%jf dvel 1 - rdu "ddmass_asoa3_cw01" "asoa3_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa4_cw01 i%jf dvel 1 - rdu "ddmass_asoa4_cw01" "asoa4_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoaX_cw01 i%jf dvel 1 - rdu "ddmass_bsoaX_cw01" "bsoaX_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa1_cw01 i%jf dvel 1 - rdu "ddmass_bsoa1_cw01" "bsoa1_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa2_cw01 i%jf dvel 1 - rdu "ddmass_bsoa2_cw01" "bsoa2_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa3_cw01 i%jf dvel 1 - rdu "ddmass_bsoa3_cw01" "bsoa3_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa4_cw01 i%jf dvel 1 - rdu "ddmass_bsoa4_cw01" "bsoa4_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_so4_cw02 i%jf dvel 1 - rdu "ddmass_so4_cw02" "so4_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_no3_cw02 i%jf dvel 1 - rdu "ddmass_no3_cw02" "no3_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_cl_cw02 i%jf dvel 1 - rdu "ddmass_cl_cw02" "cl_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_nh4_cw02 i%jf dvel 1 - rdu "ddmass_nh4_cw02" "nh4_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_na_cw02 i%jf dvel 1 - rdu "ddmass_na_cw02" "na_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_oin_cw02 i%jf dvel 1 - rdu "ddmass_oin_cw02" "oin_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_oc_cw02 i%jf dvel 1 - rdu "ddmass_oc_cw02" "oc_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_bc_cw02 i%jf dvel 1 - rdu "ddmass_bc_cw02" "bc_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_smpa_cw02 i%jf dvel 1 - rdu "ddmass_smpa_cw02" "smpa_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_smpbb_cw02 i%jf dvel 1 - rdu "ddmass_smpbb_cw02" "smpbb_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_glysoa_cw02 i%jf dvel 1 - rdu "ddmass_glysoa_cw02" "glysoa_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_c_cw02 i%jf dvel 1 - rdu "ddmass_biog1_c_cw02" "biog1_c_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_o_cw02 i%jf dvel 1 - rdu "ddmass_biog1_o_cw02" "biog1_o_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_asoaX_cw02 i%jf dvel 1 - rdu "ddmass_asoaX_cw02" "asoaX_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa1_cw02 i%jf dvel 1 - rdu "ddmass_asoa1_cw02" "asoa1_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa2_cw02 i%jf dvel 1 - rdu "ddmass_asoa2_cw02" "asoa2_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa3_cw02 i%jf dvel 1 - rdu "ddmass_asoa3_cw02" "asoa3_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa4_cw02 i%jf dvel 1 - rdu "ddmass_asoa4_cw02" "asoa4_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoaX_cw02 i%jf dvel 1 - rdu "ddmass_bsoaX_cw02" "bsoaX_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa1_cw02 i%jf dvel 1 - rdu "ddmass_bsoa1_cw02" "bsoa1_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa2_cw02 i%jf dvel 1 - rdu "ddmass_bsoa2_cw02" "bsoa2_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa3_cw02 i%jf dvel 1 - rdu "ddmass_bsoa3_cw02" "bsoa3_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa4_cw02 i%jf dvel 1 - rdu "ddmass_bsoa4_cw02" "bsoa4_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_so4_cw03 i%jf dvel 1 - rdu "ddmass_so4_cw03" "so4_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_no3_cw03 i%jf dvel 1 - rdu "ddmass_no3_cw03" "no3_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_cl_cw03 i%jf dvel 1 - rdu "ddmass_cl_cw03" "cl_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_nh4_cw03 i%jf dvel 1 - rdu "ddmass_nh4_cw03" "nh4_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_na_cw03 i%jf dvel 1 - rdu "ddmass_na_cw03" "na_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_oin_cw03 i%jf dvel 1 - rdu "ddmass_oin_cw03" "oin_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_oc_cw03 i%jf dvel 1 - rdu "ddmass_oc_cw03" "oc_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_bc_cw03 i%jf dvel 1 - rdu "ddmass_bc_cw03" "bc_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_smpa_cw03 i%jf dvel 1 - rdu "ddmass_smpa_cw03" "smpa_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_smpbb_cw03 i%jf dvel 1 - rdu "ddmass_smpbb_cw03" "smpbb_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_glysoa_cw03 i%jf dvel 1 - rdu "ddmass_glysoa_cw03" "glysoa_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_c_cw03 i%jf dvel 1 - rdu "ddmass_biog1_c_cw03" "biog1_c_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_o_cw03 i%jf dvel 1 - rdu "ddmass_biog1_o_cw03" "biog1_o_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_asoaX_cw03 i%jf dvel 1 - rdu "ddmass_asoaX_cw03" "asoaX_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa1_cw03 i%jf dvel 1 - rdu "ddmass_asoa1_cw03" "asoa1_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa2_cw03 i%jf dvel 1 - rdu "ddmass_asoa2_cw03" "asoa2_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa3_cw03 i%jf dvel 1 - rdu "ddmass_asoa3_cw03" "asoa3_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa4_cw03 i%jf dvel 1 - rdu "ddmass_asoa4_cw03" "asoa4_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoaX_cw03 i%jf dvel 1 - rdu "ddmass_bsoaX_cw03" "bsoaX_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa1_cw03 i%jf dvel 1 - rdu "ddmass_bsoa1_cw03" "bsoa1_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa2_cw03 i%jf dvel 1 - rdu "ddmass_bsoa2_cw03" "bsoa2_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa3_cw03 i%jf dvel 1 - rdu "ddmass_bsoa3_cw03" "bsoa3_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa4_cw03 i%jf dvel 1 - rdu "ddmass_bsoa4_cw03" "bsoa4_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_so4_cw04 i%jf dvel 1 - rdu "ddmass_so4_cw04" "so4_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_no3_cw04 i%jf dvel 1 - rdu "ddmass_no3_cw04" "no3_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_cl_cw04 i%jf dvel 1 - rdu "ddmass_cl_cw04" "cl_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_nh4_cw04 i%jf dvel 1 - rdu "ddmass_nh4_cw04" "nh4_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_na_cw04 i%jf dvel 1 - rdu "ddmass_na_cw04" "na_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_oin_cw04 i%jf dvel 1 - rdu "ddmass_oin_cw04" "oin_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_oc_cw04 i%jf dvel 1 - rdu "ddmass_oc_cw04" "oc_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_bc_cw04 i%jf dvel 1 - rdu "ddmass_bc_cw04" "bc_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_smpa_cw04 i%jf dvel 1 - rdu "ddmass_smpa_cw04" "smpa_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_smpbb_cw04 i%jf dvel 1 - rdu "ddmass_smpbb_cw04" "smpbb_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_glysoa_cw04 i%jf dvel 1 - rdu "ddmass_glysoa_cw04" "glysoa_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_c_cw04 i%jf dvel 1 - rdu "ddmass_biog1_c_cw04" "biog1_c_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_biog1_o_cw04 i%jf dvel 1 - rdu "ddmass_biog1_o_cw04" "biog1_o_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_asoaX_cw04 i%jf dvel 1 - rdu "ddmass_asoaX_cw04" "asoaX_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa1_cw04 i%jf dvel 1 - rdu "ddmass_asoa1_cw04" "asoa1_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa2_cw04 i%jf dvel 1 - rdu "ddmass_asoa2_cw04" "asoa2_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa3_cw04 i%jf dvel 1 - rdu "ddmass_asoa3_cw04" "asoa3_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_asoa4_cw04 i%jf dvel 1 - rdu "ddmass_asoa4_cw04" "asoa4_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoaX_cw04 i%jf dvel 1 - rdu "ddmass_bsoaX_cw04" "bsoaX_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa1_cw04 i%jf dvel 1 - rdu "ddmass_bsoa1_cw04" "bsoa1_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa2_cw04 i%jf dvel 1 - rdu "ddmass_bsoa2_cw04" "bsoa2_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa3_cw04 i%jf dvel 1 - rdu "ddmass_bsoa3_cw04" "bsoa3_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_bsoa4_cw04 i%jf dvel 1 - rdu "ddmass_bsoa4_cw04" "bsoa4_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_ca_cw01 i%jf dvel 1 - rdu "ddmass_ca_cw01" "ca_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_ca_cw02 i%jf dvel 1 - rdu "ddmass_ca_cw02" "ca_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_ca_cw03 i%jf dvel 1 - rdu "ddmass_ca_cw03" "ca_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_ca_cw04 i%jf dvel 1 - rdu "ddmass_ca_cw04" "ca_cw04 dry deposition, accumulated" "ug/m2" +state real ddmass_co3_cw01 i%jf dvel 1 - rdu "ddmass_co3_cw01" "co3_cw01 dry deposition, accumulated" "ug/m2" +state real ddmass_co3_cw02 i%jf dvel 1 - rdu "ddmass_co3_cw02" "co3_cw02 dry deposition, accumulated" "ug/m2" +state real ddmass_co3_cw03 i%jf dvel 1 - rdu "ddmass_co3_cw03" "co3_cw03 dry deposition, accumulated" "ug/m2" +state real ddmass_co3_cw04 i%jf dvel 1 - rdu "ddmass_co3_cw04" "co3_cw04 dry deposition, accumulated" "ug/m2" # deposition velocities for diagnostic package, feel free to add if you like! # @@ -692,11 +1028,35 @@ state integer num_vert_mix - misc - - r "n # Wet deposition # -state real wd_so4_sc ij misc 1 - rdu "wd_so4_sc" "SO4 surface wet deposition, accumulated (Sc)" "mmol/m2" -state real wd_no3_sc ij misc 1 - rdu "wd_no3_sc" "NO3 surface wet deposition, accumulated (Sc)" "mmol/m2" - -state real wd_so4_cu ij misc 1 - rdu "wd_so4_cu" "SO4 surface wet deposition, accumulated (Cu)" "mmol/m2" -state real wd_no3_cu ij misc 1 - rdu "wd_no3_cu" "NO3 surface wet deposition, accumulated (Cu)" "mmol/m2" +state real wd_so4_sc ij misc 1 - rdu "wd_so4_sc" "SO4 surface wet deposition, accumulated (Sc)" "mmol/m2" +state real wd_no3_sc ij misc 1 - rdu "wd_no3_sc" "NO3 surface wet deposition, accumulated (Sc)" "mmol/m2" +# added wet deposition totals for NH4 and OA for MOZART coupled version +state real wd_nh4_sc ij misc 1 - rdu "wd_nh4_sc" "NH4 surface wet deposition, accumulated (Sc)" "mmol/m2" +state real wd_oa_sc ij misc 1 - rdu "wd_oa_sc" "Organics surface wet deposition, accumulated (Sc)" "mmol/m2" +state real wd_so2_sc ij misc 1 - rdu "wd_so2_sc" "SO2 surface wet deposition, accumulated (Sc)" "mmol/m2" +state real wd_sulf_sc ij misc 1 - rdu "wd_sulf_sc" "H2SO4 surface wet deposition, accumulated (Sc)" "mmol/m2" +state real wd_hno3_sc ij misc 1 - rdu "wd_hno3_sc" "HNO3 surface wet deposition, accumulated (Sc)" "mmol/m2" +state real wd_nh3_sc ij misc 1 - rdu "wd_nh3_sc" "NH3 surface wet deposition, accumulated (Sc)" "mmol/m2" + +state real wd_asoa_sc ij misc 1 - rdu "wd_asoa_sc" "Anth. SOA surface wet deposition, accumulated (Sc)" "mmol/m2" +state real wd_bsoa_sc ij misc 1 - rdu "wd_bsoa_sc" "Biog. SOA surface wet deposition, accumulated (Sc)" "mmol/m2" +state real wd_cvasoa_sc ij misc 1 - rdu "wd_cvasoa_sc" "Anth. CVSOA surface wet deposition, accumulated (Sc)" "mmol/m2" +state real wd_cvbsoa_sc ij misc 1 - rdu "wd_cvbsoa_sc" "Biog. CVSOA surface wet deposition, accumulated (Sc)" "mmol/m2" + +state real wd_so4_cu ij misc 1 - rdu "wd_so4_cu" "SO4 surface wet deposition, accumulated (Cu)" "mmol/m2" +state real wd_no3_cu ij misc 1 - rdu "wd_no3_cu" "NO3 surface wet deposition, accumulated (Cu)" "mmol/m2" +# added wet deposition totals for NH4 and OA for MOZART coupled version +state real wd_nh4_cu ij misc 1 - rdu "wd_nh4_cu" "NH4 surface wet deposition, accumulated (Cu)" "mmol/m2" +state real wd_oa_cu ij misc 1 - rdu "wd_oa_cu" "Organics surface wet deposition, accumulated (Cu)" "mmol/m2" +state real wd_so2_cu ij misc 1 - rdu "wd_so2_cu" "SO2 surface wet deposition, accumulated (Cu)" "mmol/m2" +state real wd_sulf_cu ij misc 1 - rdu "wd_sulf_cu" "H2SO4 surface wet deposition, accumulated (Cu)" "mmol/m2" +state real wd_hno3_cu ij misc 1 - rdu "wd_hno3_cu" "HNO3 surface wet deposition, accumulated (Cu)" "mmol/m2" +state real wd_nh3_cu ij misc 1 - rdu "wd_nh3_cu" "NH3 surface wet deposition, accumulated (Cu)" "mmol/m2" + +state real wd_asoa_cu ij misc 1 - rdu "wd_asoa_cu" "Anth. SOA surface wet deposition, accumulated (Cu)" "mmol/m2" +state real wd_bsoa_cu ij misc 1 - rdu "wd_bsoa_cu" "Biog. SOA surface wet deposition, accumulated (Cu)" "mmol/m2" +state real wd_cvasoa_cu ij misc 1 - rdu "wd_cvasoa_cu" "Anth. CVSOA surface wet deposition, accumulated (Cu)" "mmol/m2" +state real wd_cvbsoa_cu ij misc 1 - rdu "wd_cvbsoa_cu" "Biog. CVSOA surface wet deposition, accumulated (Cu)" "mmol/m2" # aerosol stuff state real aerwrf ikj misc 1 - r "AERWRF" "STANDARD AEROSOL PROFILE" "?" @@ -708,6 +1068,12 @@ state real pm10 ikj misc 1 - h "pm1 state real uvrad ij misc 1 - - "uv_rad " "uvb net-radiation" "W m^-2" state real tcosz ij misc 1 - - "TCOSZ " "daily average cossza" "?" state real ttday ij misc 1 - - "TTDAY " "" "?" + +#soa diagnostic +state real tsoa ikj misc 1 - r "TSOA" "soa dry mass" "ug m^-3" +state real bsoa ikj misc 1 - r "BSOA" "bsoa dry mass" "ug m^-3" +state real asoa ikj misc 1 - r "ASOA" "asoa dry mass" "ug m^-3" + # dms_0 is the dms concentration in the ocean (aqueous phase) and it should be in the unit of nM/L (1.e-9mol/L) state real dms_0 ij misc 1 - i08rh "DMS_0 " "dms oceanic concentrations" "nM/L" @@ -716,34 +1082,74 @@ state real hoa_a01 ikj misc 1 - r "ho state real hoa_a02 ikj misc 1 - r "hoa_a02" "hoa_a02" "ug m^-3" state real hoa_a03 ikj misc 1 - r "hoa_a03" "hoa_a03" "ug m^-3" state real hoa_a04 ikj misc 1 - r "hoa_a04" "hoa_a04" "ug m^-3" +state real hoa_a05 ikj misc 1 - r "hoa_a05" "hoa_a05" "ug m^-3" +state real hoa_a06 ikj misc 1 - r "hoa_a06" "hoa_a06" "ug m^-3" +state real hoa_a07 ikj misc 1 - r "hoa_a07" "hoa_a07" "ug m^-3" +state real hoa_a08 ikj misc 1 - r "hoa_a08" "hoa_a08" "ug m^-3" + state real soa_a01 ikj misc 1 - r "soa_a01" "soa_a01" "ug m^-3" state real soa_a02 ikj misc 1 - r "soa_a02" "soa_a02" "ug m^-3" state real soa_a03 ikj misc 1 - r "soa_a03" "soa_a03" "ug m^-3" state real soa_a04 ikj misc 1 - r "soa_a04" "soa_a04" "ug m^-3" +state real soa_a05 ikj misc 1 - r "soa_a05" "soa_a05" "ug m^-3" +state real soa_a06 ikj misc 1 - r "soa_a06" "soa_a06" "ug m^-3" +state real soa_a07 ikj misc 1 - r "soa_a07" "soa_a07" "ug m^-3" +state real soa_a08 ikj misc 1 - r "soa_a08" "soa_a08" "ug m^-3" + state real bboa_a01 ikj misc 1 - r "bboa_a01" "bboa_a01" "ug m^-3" state real bboa_a02 ikj misc 1 - r "bboa_a02" "bboa_a02" "ug m^-3" state real bboa_a03 ikj misc 1 - r "bboa_a03" "bboa_a03" "ug m^-3" state real bboa_a04 ikj misc 1 - r "bboa_a04" "bboa_a04" "ug m^-3" +state real bboa_a05 ikj misc 1 - r "bboa_a05" "bboa_a05" "ug m^-3" +state real bboa_a06 ikj misc 1 - r "bboa_a06" "bboa_a06" "ug m^-3" +state real bboa_a07 ikj misc 1 - r "bboa_a07" "bboa_a07" "ug m^-3" +state real bboa_a08 ikj misc 1 - r "bboa_a08" "bboa_a08" "ug m^-3" + state real bbsoa_a01 ikj misc 1 - r "bbsoa_a01" "bbsoa_a01" "ug m^-3" state real bbsoa_a02 ikj misc 1 - r "bbsoa_a02" "bbsoa_a02" "ug m^-3" state real bbsoa_a03 ikj misc 1 - r "bbsoa_a03" "bbsoa_a03" "ug m^-3" state real bbsoa_a04 ikj misc 1 - r "bbsoa_a04" "bbsoa_a04" "ug m^-3" +state real bbsoa_a05 ikj misc 1 - r "bbsoa_a05" "bbsoa_a05" "ug m^-3" +state real bbsoa_a06 ikj misc 1 - r "bbsoa_a06" "bbsoa_a06" "ug m^-3" +state real bbsoa_a07 ikj misc 1 - r "bbsoa_a07" "bbsoa_a07" "ug m^-3" +state real bbsoa_a08 ikj misc 1 - r "bbsoa_a08" "bbsoa_a08" "ug m^-3" + state real hsoa_a01 ikj misc 1 - r "hsoa_a01" "hsoa_a01" "ug m^-3" state real hsoa_a02 ikj misc 1 - r "hsoa_a02" "hsoa_a02" "ug m^-3" state real hsoa_a03 ikj misc 1 - r "hsoa_a03" "hsoa_a03" "ug m^-3" state real hsoa_a04 ikj misc 1 - r "hsoa_a04" "hsoa_a04" "ug m^-3" +state real hsoa_a05 ikj misc 1 - r "hsoa_a05" "hsoa_a05" "ug m^-3" +state real hsoa_a06 ikj misc 1 - r "hsoa_a06" "hsoa_a06" "ug m^-3" +state real hsoa_a07 ikj misc 1 - r "hsoa_a07" "hsoa_a07" "ug m^-3" +state real hsoa_a08 ikj misc 1 - r "hsoa_a08" "hsoa_a08" "ug m^-3" + state real biog_a01 ikj misc 1 - r "biog_a01" "biog_a01" "ug m^-3" state real biog_a02 ikj misc 1 - r "biog_a02" "biog_a02" "ug m^-3" state real biog_a03 ikj misc 1 - r "biog_a03" "biog_a03" "ug m^-3" state real biog_a04 ikj misc 1 - r "biog_a04" "biog_a04" "ug m^-3" +state real biog_a05 ikj misc 1 - r "biog_a05" "biog_a05" "ug m^-3" +state real biog_a06 ikj misc 1 - r "biog_a06" "biog_a06" "ug m^-3" +state real biog_a07 ikj misc 1 - r "biog_a07" "biog_a07" "ug m^-3" +state real biog_a08 ikj misc 1 - r "biog_a08" "biog_a08" "ug m^-3" + state real arosoa_a01 ikj misc 1 - r "arosoa_a01" "arosoa_a01" "ug m^-3" state real arosoa_a02 ikj misc 1 - r "arosoa_a02" "arosoa_a02" "ug m^-3" state real arosoa_a03 ikj misc 1 - r "arosoa_a03" "arosoa_a03" "ug m^-3" state real arosoa_a04 ikj misc 1 - r "arosoa_a04" "arosoa_a04" "ug m^-3" +state real arosoa_a05 ikj misc 1 - r "arosoa_a05" "arosoa_a05" "ug m^-3" +state real arosoa_a06 ikj misc 1 - r "arosoa_a06" "arosoa_a06" "ug m^-3" +state real arosoa_a07 ikj misc 1 - r "arosoa_a07" "arosoa_a07" "ug m^-3" +state real arosoa_a08 ikj misc 1 - r "arosoa_a08" "arosoa_a08" "ug m^-3" + state real totoa_a01 ikj misc 1 - r "totoa_a01" "totoa_a01" "ug m^-3" state real totoa_a02 ikj misc 1 - r "totoa_a02" "totoa_a02" "ug m^-3" state real totoa_a03 ikj misc 1 - r "totoa_a03" "totoa_a03" "ug m^-3" state real totoa_a04 ikj misc 1 - r "totoa_a04" "totoa_a04" "ug m^-3" +state real totoa_a05 ikj misc 1 - r "totoa_a05" "totoa_a05" "ug m^-3" +state real totoa_a06 ikj misc 1 - r "totoa_a06" "totoa_a06" "ug m^-3" +state real totoa_a07 ikj misc 1 - r "totoa_a07" "totoa_a07" "ug m^-3" +state real totoa_a08 ikj misc 1 - r "totoa_a08" "totoa_a08" "ug m^-3" + state real hsoa_c ikj misc 1 - r "hsoa_c" "hsoa_c" "ug m^-3" state real hsoa_o ikj misc 1 - r "hsoa_o" "hsoa_o" "ug m^-3" state real bbsoa_c ikj misc 1 - r "bbsoa_c" "bbsoa_c" "ug m^-3" @@ -757,6 +1163,87 @@ state real ant_v2 ikj misc 1 - r state real ant_v3 ikj misc 1 - r "ant_v3" "ant_v3" "ug m^-3" state real ant_v4 ikj misc 1 - r "ant_v4" "ant_v4" "ug m^-3" state integer vbs_nbin v misc 1 - r "vbs_nbin" "vbs_nbin" "" + +#Diagnostic Aerosol species for cloud borne species +state real hoa_cw01 ikj misc 1 - r "hoa_cw01" "hoa_cw01" "ug m^-3" +state real hoa_cw02 ikj misc 1 - r "hoa_cw02" "hoa_cw02" "ug m^-3" +state real hoa_cw03 ikj misc 1 - r "hoa_cw03" "hoa_cw03" "ug m^-3" +state real hoa_cw04 ikj misc 1 - r "hoa_cw04" "hoa_cw04" "ug m^-3" +state real hoa_cw05 ikj misc 1 - r "hoa_cw05" "hoa_cw05" "ug m^-3" +state real hoa_cw06 ikj misc 1 - r "hoa_cw06" "hoa_cw06" "ug m^-3" +state real hoa_cw07 ikj misc 1 - r "hoa_cw07" "hoa_cw07" "ug m^-3" +state real hoa_cw08 ikj misc 1 - r "hoa_cw08" "hoa_cw08" "ug m^-3" + +state real soa_cw01 ikj misc 1 - r "soa_cw01" "soa_cw01" "ug m^-3" +state real soa_cw02 ikj misc 1 - r "soa_cw02" "soa_cw02" "ug m^-3" +state real soa_cw03 ikj misc 1 - r "soa_cw03" "soa_cw03" "ug m^-3" +state real soa_cw04 ikj misc 1 - r "soa_cw04" "soa_cw04" "ug m^-3" +state real soa_cw05 ikj misc 1 - r "soa_cw05" "soa_cw05" "ug m^-3" +state real soa_cw06 ikj misc 1 - r "soa_cw06" "soa_cw06" "ug m^-3" +state real soa_cw07 ikj misc 1 - r "soa_cw07" "soa_cw07" "ug m^-3" +state real soa_cw08 ikj misc 1 - r "soa_cw08" "soa_cw08" "ug m^-3" + +state real bboa_cw01 ikj misc 1 - r "bboa_cw01" "bboa_cw01" "ug m^-3" +state real bboa_cw02 ikj misc 1 - r "bboa_cw02" "bboa_cw02" "ug m^-3" +state real bboa_cw03 ikj misc 1 - r "bboa_cw03" "bboa_cw03" "ug m^-3" +state real bboa_cw04 ikj misc 1 - r "bboa_cw04" "bboa_cw04" "ug m^-3" +state real bboa_cw05 ikj misc 1 - r "bboa_cw05" "bboa_cw05" "ug m^-3" +state real bboa_cw06 ikj misc 1 - r "bboa_cw06" "bboa_cw06" "ug m^-3" +state real bboa_cw07 ikj misc 1 - r "bboa_cw07" "bboa_cw07" "ug m^-3" +state real bboa_cw08 ikj misc 1 - r "bboa_cw08" "bboa_cw08" "ug m^-3" + +state real bbsoa_cw01 ikj misc 1 - r "bbsoa_cw01" "bbsoa_cw01" "ug m^-3" +state real bbsoa_cw02 ikj misc 1 - r "bbsoa_cw02" "bbsoa_cw02" "ug m^-3" +state real bbsoa_cw03 ikj misc 1 - r "bbsoa_cw03" "bbsoa_cw03" "ug m^-3" +state real bbsoa_cw04 ikj misc 1 - r "bbsoa_cw04" "bbsoa_cw04" "ug m^-3" +state real bbsoa_cw05 ikj misc 1 - r "bbsoa_cw05" "bbsoa_cw05" "ug m^-3" +state real bbsoa_cw06 ikj misc 1 - r "bbsoa_cw06" "bbsoa_cw06" "ug m^-3" +state real bbsoa_cw07 ikj misc 1 - r "bbsoa_cw07" "bbsoa_cw07" "ug m^-3" +state real bbsoa_cw08 ikj misc 1 - r "bbsoa_cw08" "bbsoa_cw08" "ug m^-3" + +state real hsoa_cw01 ikj misc 1 - r "hsoa_cw01" "hsoa_cw01" "ug m^-3" +state real hsoa_cw02 ikj misc 1 - r "hsoa_cw02" "hsoa_cw02" "ug m^-3" +state real hsoa_cw03 ikj misc 1 - r "hsoa_cw03" "hsoa_cw03" "ug m^-3" +state real hsoa_cw04 ikj misc 1 - r "hsoa_cw04" "hsoa_cw04" "ug m^-3" +state real hsoa_cw05 ikj misc 1 - r "hsoa_cw05" "hsoa_cw05" "ug m^-3" +state real hsoa_cw06 ikj misc 1 - r "hsoa_cw06" "hsoa_cw06" "ug m^-3" +state real hsoa_cw07 ikj misc 1 - r "hsoa_cw07" "hsoa_cw07" "ug m^-3" +state real hsoa_cw08 ikj misc 1 - r "hsoa_cw08" "hsoa_cw08" "ug m^-3" + +state real biog_cw01 ikj misc 1 - r "biog_cw01" "biog_cw01" "ug m^-3" +state real biog_cw02 ikj misc 1 - r "biog_cw02" "biog_cw02" "ug m^-3" +state real biog_cw03 ikj misc 1 - r "biog_cw03" "biog_cw03" "ug m^-3" +state real biog_cw04 ikj misc 1 - r "biog_cw04" "biog_cw04" "ug m^-3" +state real biog_cw05 ikj misc 1 - r "biog_cw05" "biog_cw05" "ug m^-3" +state real biog_cw06 ikj misc 1 - r "biog_cw06" "biog_cw06" "ug m^-3" +state real biog_cw07 ikj misc 1 - r "biog_cw07" "biog_cw07" "ug m^-3" +state real biog_cw08 ikj misc 1 - r "biog_cw08" "biog_cw08" "ug m^-3" + +state real arosoa_cw01 ikj misc 1 - r "arosoa_cw01" "arosoa_cw01" "ug m^-3" +state real arosoa_cw02 ikj misc 1 - r "arosoa_cw02" "arosoa_cw02" "ug m^-3" +state real arosoa_cw03 ikj misc 1 - r "arosoa_cw03" "arosoa_cw03" "ug m^-3" +state real arosoa_cw04 ikj misc 1 - r "arosoa_cw04" "arosoa_cw04" "ug m^-3" +state real arosoa_cw05 ikj misc 1 - r "arosoa_cw05" "arosoa_cw05" "ug m^-3" +state real arosoa_cw06 ikj misc 1 - r "arosoa_cw06" "arosoa_cw06" "ug m^-3" +state real arosoa_cw07 ikj misc 1 - r "arosoa_cw07" "arosoa_cw07" "ug m^-3" +state real arosoa_cw08 ikj misc 1 - r "arosoa_cw08" "arosoa_cw08" "ug m^-3" + +state real totoa_cw01 ikj misc 1 - r "totoa_cw01" "totoa_cw01" "ug m^-3" +state real totoa_cw02 ikj misc 1 - r "totoa_cw02" "totoa_cw02" "ug m^-3" +state real totoa_cw03 ikj misc 1 - r "totoa_cw03" "totoa_cw03" "ug m^-3" +state real totoa_cw04 ikj misc 1 - r "totoa_cw04" "totoa_cw04" "ug m^-3" +state real totoa_cw05 ikj misc 1 - r "totoa_cw05" "totoa_cw05" "ug m^-3" +state real totoa_cw06 ikj misc 1 - r "totoa_cw06" "totoa_cw06" "ug m^-3" +state real totoa_cw07 ikj misc 1 - r "totoa_cw07" "totoa_cw07" "ug m^-3" +state real totoa_cw08 ikj misc 1 - r "totoa_cw08" "totoa_cw08" "ug m^-3" + +state real hsoa_cw_c ikj misc 1 - r "hsoa_cw_c" "hsoa_cw_c" "ug m^-3" +state real hsoa_cw_o ikj misc 1 - r "hsoa_cw_o" "hsoa_cw_o" "ug m^-3" +state real bbsoa_cw_c ikj misc 1 - r "bbsoa_cw_c" "bbsoa_cw_c" "ug m^-3" +state real bbsoa_cw_o ikj misc 1 - r "bbsoa_cw_o" "bbsoa_cw_o" "ug m^-3" +state real ant_cw_v1 ikj misc 1 - r "ant_cw_v1" "ant_cw_v1" "ug m^-3" +state real biog_cw_v1 ikj misc 1 - r "biog_cw_v1" "biog_cw_v1" "ug m^-3" + state real smpa_v1 ikj misc 1 - r "smpa_v1" "smpa_v1" "ug m^-3" state real smpbb_v1 ikj misc 1 - r "smpbb_v1" "smpbb_v1" "ug m^-3" state real asmpsoa_a01 ikj misc 1 - r "asmpsoa_a01" "asmpsoa_a01" "ug m^-3" @@ -815,6 +1302,11 @@ state real ph_alkooh ikj misc 1 - - "PH state real ph_mekooh ikj misc 1 - - "PHOTR132" "mekooh photolysis rate" "min{-1}" state real ph_tolooh ikj misc 1 - - "PHOTR133" "tolooh photolysis rate" "min{-1}" state real ph_terpooh ikj misc 1 - - "PHOTR134" "terpooh photolysis rate" "min{-1}" +# cb05cl photolysis rates +state real ph_cl2 ikj misc 1 - h "PHOTR201" "cl2 photolysis rate" "min{-1}" +state real ph_hocl ikj misc 1 - h "PHOTR202" "hocl photolysis rate" "min{-1}" +state real ph_fmcl ikj misc 1 - h "PHOTR203" "fmcl photolysis rate" "min{-1}" + # # Aerosol optical properties from Mie code for rrtmg radiation state real extaerlw1 ikj misc 1 - r "LWEXTAER1" "layer extinction coef" "1/km" @@ -876,6 +1368,47 @@ state real l4aer ikj= misc 1 - r "L4 state real l5aer ikj= misc 1 - r "L5AER" "legendre polynomial 5" "?" state real l6aer ikj= misc 1 - r "L6AER" "legendre polynomial 6" "?" state real l7aer ikj= misc 1 - r "L7AER" "legendre polynomial 7" "?" +# chem variables for "cup" convective cloud parameterization +state integer chem_cupflag ikj misc 1 - - "CHEM_CUPFLAG" "flag for cup chemistry - positive when there is cup conv. cloud chemistry at ikj" + +state real co_a_ic_cup ikj misc 1 - - "CO_A_IC_CUP" "interstitial CO within convective cloud" "ppmv" +state real hno3_a_ic_cup ikj misc 1 - - "HNO3_A_IC_CUP" "interstitial HNO3 within convective cloud" "ppmv" +state real so4_a_1to4_ic_cup ikj misc 1 - - "SO4_A_1to4_IC_CUP" "interstitial sulfate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real so4_cw_1to4_ic_cup ikj misc 1 - - "SO4_CW_1to4_IC_CUP" "cloud-borne sulfate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real nh4_a_1to4_ic_cup ikj misc 1 - - "NH4_A_1to4_IC_CUP" "interstitial ammonium (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real nh4_cw_1to4_ic_cup ikj misc 1 - - "NH4_CW_1to4_IC_CUP" "cloud-borne ammonium (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real no3_a_1to4_ic_cup ikj misc 1 - - "NO3_A_1to4_IC_CUP" "interstitial nitrate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real no3_cw_1to4_ic_cup ikj misc 1 - - "NO3_CW_1to4_IC_CUP" "cloud-borne nitrate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real oa_a_1to4_ic_cup ikj misc 1 - - "OA_A_1to4_IC_CUP" "interstitial organic aerosol (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real oa_cw_1to4_ic_cup ikj misc 1 - - "OA_CW_1to4_IC_CUP" "cloud-borne organic aerosol (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real oin_a_1to4_ic_cup ikj misc 1 - - "OIN_A_1to4_IC_CUP" "interstitial sulfate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real oin_cw_1to4_ic_cup ikj misc 1 - - "OIN_CW_1to4_IC_CUP" "cloud-borne sulfate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real bc_a_1to4_ic_cup ikj misc 1 - - "BC_A_1to4_IC_CUP" "interstitial sulfate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real bc_cw_1to4_ic_cup ikj misc 1 - - "BC_CW_1to4_IC_CUP" "cloud-borne sulfate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real na_a_1to4_ic_cup ikj misc 1 - - "Na_A_1to4_IC_CUP" "interstitial sulfate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real na_cw_1to4_ic_cup ikj misc 1 - - "Na_CW_1to4_IC_CUP" "cloud-borne sulfate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real cl_a_1to4_ic_cup ikj misc 1 - - "Cl_A_1to4_IC_CUP" "interstitial sulfate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real cl_cw_1to4_ic_cup ikj misc 1 - - "Cl_CW_1to4_IC_CUP" "cloud-borne sulfate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real so4_a_5to6_ic_cup ikj misc 1 - - "SO4_A_5to6_IC_CUP" "interstitial sulfate (Ddry>625 nm and Ddry<2500 ) within convective cloud" "ug/kg-dryair" +state real so4_cw_5to6_ic_cup ikj misc 1 - - "SO4_CW_5to6_IC_CUP" "cloud-borne sulfate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real nh4_a_5to6_ic_cup ikj misc 1 - - "NH4_A_5to6_IC_CUP" "interstitial ammonium (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real nh4_cw_5to6_ic_cup ikj misc 1 - - "NH4_CW_5to6_IC_CUP" "cloud-borne ammonium (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real no3_a_5to6_ic_cup ikj misc 1 - - "NO3_A_5to6_IC_CUP" "interstitial nitrate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real no3_cw_5to6_ic_cup ikj misc 1 - - "NO3_CW_5to6_IC_CUP" "cloud-borne nitrate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real oa_a_5to6_ic_cup ikj misc 1 - - "OA_A_5to6_IC_CUP" "interstitial organic aerosol (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real oa_cw_5to6_ic_cup ikj misc 1 - - "OA_CW_5to6_IC_CUP" "cloud-borne organic aerosol (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real oin_a_5to6_ic_cup ikj misc 1 - - "OIN_A_5to6_IC_CUP" "interstitial sulfate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real oin_cw_5to6_ic_cup ikj misc 1 - - "OIN_CW_5to6_IC_CUP" "cloud-borne sulfate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real bc_a_5to6_ic_cup ikj misc 1 - - "BC_A_5to6_IC_CUP" "interstitial sulfate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real bc_cw_5to6_ic_cup ikj misc 1 - - "BC_CW_5to6_IC_CUP" "cloud-borne sulfate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real na_a_5to6_ic_cup ikj misc 1 - - "Na_A_5to6_IC_CUP" "interstitial sulfate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real na_cw_5to6_ic_cup ikj misc 1 - - "Na_CW_5to6_IC_CUP" "cloud-borne sulfate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real cl_a_5to6_ic_cup ikj misc 1 - - "Cl_A_5to6_IC_CUP" "interstitial sulfate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real cl_cw_5to6_ic_cup ikj misc 1 - - "Cl_CW_5to6_IC_CUP" "cloud-borne sulfate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" +state real water_1to4_ic_cup ikj misc 1 - - "WATER_1to4_IC_CUP" "interstitial sulfate (Ddry<625 nm) within convective cloud" "ug/kg-dryair" +state real water_5to6_ic_cup ikj misc 1 - - "WATER_5to6_IC_CUP" "interstitial sulfate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" + + # non-transported aerosol variables state real h2oaj ikj misc 1 - r "h2oaj" "Aerosol water conc. Acc.mode" "?" @@ -957,8 +1490,8 @@ state real wetmap ivjf wet_in 1 - i{15}r state real t_ann ivjf wet_in 1 - i{15}rh "T_ANN" "mean annual temperature" "K" # Parameters to for calculating the termite emissions online -state real biomt_par {ghgt} misc 1 - h "BIOMT_PAR" "biomass termite per vegetation type" "g/m^2" -state real emit_par {ghgt} misc 1 - h "EMIT_PAR" " " " " +state real biomt_par {ghgt} misc 1 - - "BIOMT_PAR" "biomass termite per vegetation type" "g/m^2" +state real emit_par {ghgt} misc 1 - - "EMIT_PAR" " " " " # Chem Scalars state real - ikjftb chem 1 - - - @@ -1016,6 +1549,8 @@ state real psd1 ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real psd2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "psd2" "LIM2 mixing ratio" "ppmv" state real nume ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nume" "LIM2 mixing ratio" "ppmv" state real den ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "den" "LIM2 mixing ratio" "ppmv" +state real bgas ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bgas" "Biogenic gas concentration" "ppmv" +state real agas ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "agas" "Anthropogenic gas concentration" "ppmv" state real pcg1_b_c ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pcg1_b_c" "pcg1_b_c mixing ratio" "ppmv" state real pcg2_b_c ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pcg2_b_c" "pcg2_b_c mixing ratio" "ppmv" state real pcg3_b_c ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pcg3_b_c" "pcg3_b_c mixing ratio" "ppmv" @@ -1122,10 +1657,12 @@ state real macr ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real mbo ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "mbo" "MBO (2-Methyl-3-Buten-2-ol) mixing ratio" "ppmv" # condensable organic vapors for the RACM_SOA_VBS_KPP mechanism: +state real cvasoaX ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cvasoaX" "cond.vapor from ASOAX" "ppmv" state real cvasoa1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cvasoa1" "cond.vapor from ASOA1" "ppmv" state real cvasoa2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cvasoa2" "cond.vapor from ASOA2" "ppmv" state real cvasoa3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cvasoa3" "cond.vapor from ASOA3" "ppmv" state real cvasoa4 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cvasoa4" "cond.vapor from ASOA4" "ppmv" +state real cvbsoaX ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cvbsoaX" "cond.vapor from BSOAX" "ppmv" state real cvbsoa1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cvbsoa1" "cond.vapor from BSOA1" "ppmv" state real cvbsoa2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cvbsoa2" "cond.vapor from BSOA2" "ppmv" state real cvbsoa3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cvbsoa3" "cond.vapor from BSOA3" "ppmv" @@ -1174,6 +1711,7 @@ state real xo2n ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real pna ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pna" "PNA mixing ratio" "ppmv" state real o ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "o" "o mixing ratio" "ppmv" state real o1d_cb4 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "o1d_cb4" "o1d_cb4 mixing ratio" "ppmv" + #Additional MOZART gas variables inside the chem array... state real n2o ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "n2o" "N2O mixing ratio" "ppmv" state real ch3ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch3ooh" "CH3OOH mixing ratio" "ppmv" @@ -1199,6 +1737,48 @@ state real c10h16 ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real terpo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "terpo2" "TERPO2 mixing ratio" "ppmv" state real tolo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tolo2" "TOLO2 mixing ratio" "ppmv" state real xoh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "xoh" "XOH mixing ratio" "ppmv" +state real hoch2oo ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hoch2oo" "HOCH2OO mixing ratio" "ppmv" +state real bepomuc ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bepomuc" "bepomuc mixing ratio" "ppmv" +state real benzo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "benzo2" "benzo2 mixing ratio" "ppmv" +state real pheno2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pheno2" "pheno2 mixing ratio" "ppmv" +state real pheno ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pheno" "pheno mixing ratio" "ppmv" +state real phenooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "phenooh" "phenooh mixing ratio" "ppmv" +state real c6h5o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "c6h5o2" "c6h5o2 mixing ratio" "ppmv" +state real c6h5ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "c6h5ooh" "c6h5ooh mixing ratio" "ppmv" +state real benzooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "benzooh" "benzooh mixing ratio" "ppmv" +state real bigald1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bigald1" "bigald1 mixing ratio" "ppmv" +state real bigald2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bigald2" "bigald2 mixing ratio" "ppmv" +state real bigald3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bigald3" "bigald3 mixing ratio" "ppmv" +state real bigald4 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bigald4" "bigald4 mixing ratio" "ppmv" +state real malo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "malo2" "malo2 mixing ratio" "ppmv" +state real tepomuc ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tepomuc" "tepomuc mixing ratio" "ppmv" +state real bzoo ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bzoo" "bzoo mixing ratio" "ppmv" +state real bzooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bzooh" "bzooh mixing ratio" "ppmv" +state real acbzo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "acbzo2" "acbzo2 mixing ratio" "ppmv" +state real dicarbo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "dicarbo2" "dicarbo2 mixing ratio" "ppmv" +state real mdialo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "mdialo2" "mdialo2 mixing ratio" "ppmv" +state real xylenes ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "xylenes" "xylenes mixing ratio" "ppmv" +state real xylol ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "xylol" "xylol mixing ratio" "ppmv" +state real xylolo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "xylolo2" "xylolo2 mixing ratio" "ppmv" +state real xylolooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "xylolooh" "xylolooh mixing ratio" "ppmv" +state real xyleno2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "xyleno2" "xyleno2 mixing ratio" "ppmv" +state real xylenooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "xylenooh" "xylenooh mixing ratio" "ppmv" +state real pbznit ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pbznit" "pbznit mixing ratio" "ppmv" +state real mboo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "mboo2" "MBOO2 concentration" "ppmv" +state real hmprop ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hmprop" "HMPROP concentration" "ppmv" +state real hmpropo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hmpropo2" "HMPROPO2 concentration" "ppmv" +state real mboooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "mboooh" "MBOOOH concentration" "ppmv" +state real mbono3o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "mbono3o2" "MBONO3O2 concentration" "ppmv" +state real apin ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "apin" "APIN mixing ratio" "ppmv" +state real bpin ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bpin" "BPIN mixing ratio" "ppmv" +state real limon ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "limon" "LIMON mixing ratio" "ppmv" +state real myrc ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "myrc" "MYRC mixing ratio" "ppmv" +state real bcary ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bcary" "BCARY C15H24 mixing ratio" "ppmv" +state real terprod1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "terprod1" "TERPROD1 -> C10H16O2 mixing ratio" "ppmv" +state real terprod2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "terprod2" "TERPROD2 -> C9H14O2 mixing ratio" "ppmv" +state real terp2o2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "terp2o2" "TERP2O2 -> C10H15O4 mixing ratio" "ppmv" +state real terp2ooh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "terp2ooh" "TERP2OOH -> C10H16O4 mixing ratio" "ppmv" +state real nterpo2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nterpo2" "NTERPO2 -> C10H16NO5 mixing ratio" "ppmv" #volcanic ash variables inside the chem array... # state real vash_1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "vash_1" "vash1 mixing ratio" "ug/kg-dryair" @@ -1538,6 +2118,64 @@ state real ma_rco3 ikjftb chem 1 - i0{12}rhusdf=(bd state real voca ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "voca" "VOCA mixing ratio" "ppmv" state real vocbb ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "vocbb" "VOCBB mixing ratio" "ppmv" +#Additional CB05 gas variables inside the chem array + +state real o1d ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "o1d" "O1D concentration" "ppmv" +state real oh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oh" "OH concentration" "ppmv" +state real ntr ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ntr" "NTR concentration" "ppmv" +state real form ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "form" "FORM concentration" "ppmv" +state real aldx ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "aldx" "ALDX concentration" "ppmv" +state real mepx ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "mepx" "MEPX concentration" "ppmv" +state real hco3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hco3" "HCO3 concentration" "ppmv" +state real facd ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "facd" "FACD concentration" "ppmv" +state real pacd ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pacd" "PACD concentration" "ppmv" +state real aacd ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "aacd" "AACD concentration" "ppmv" +state real cxo3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cxo3" "CXO3 concentration" "ppmv" +state real panx ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "panx" "PANX concentration" "ppmv" +state real iole ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "iole" "IOLE concentration" "ppmv" +state real tolaer1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tolaer1" "TOLAER1 concentration" "ppmv" +state real tolaer2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "tolaer2" "TOLAER2 concentration" "ppmv" +state real cslaer ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cslaer" "CSLAER concentration" "ppmv" +state real xylaer1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "xylaer1" "XYLAER1 concentration" "ppmv" +state real xylaer2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "xylaer2" "XYLAER2 concentration" "ppmv" +state real isop ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "isop" "ISOP concentration" "ppmv" +state real ispd ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ispd" "ISPD concentration" "ppmv" +state real isoaer1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "isoaer1" "ISOAER1 concentration" "ppmv" +state real isoaer2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "isoaer2" "ISOAER2 concentration" "ppmv" +state real sulaer ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "sulaer" "SULAER concentration" "ppmv" +state real etha ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "etha" "ETHA concentration" "ppmv" +state real terpaer ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "terpaer" "TERPAER concentration" "ppmv" +state real hum ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hum" "HUM concentration" "ppmv" +state real humaer ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "humaer" "HUMAER concentration" "ppmv" +state real limaer1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "limaer1" "LIMAER1 concentration" "ppmv" +state real limaer2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "limaer2" "LIMAER2 concentration" "ppmv" +state real oci ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oci" "OCI concentration" "ppmv" +state real ociaer1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ociaer1" "OCIAER1 concentration" "ppmv" +state real ociaer2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ociaer2" "OCIAER2 concentration" "ppmv" +state real apinaer1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "apinaer1" "APINAER1 concentration" "ppmv" +state real apinaer2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "apinaer2" "APINAER2 concentration" "ppmv" +state real apinaer3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "apinaer3" "APINAER3 concentration" "ppmv" +state real apinaer4 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "apinaer4" "APINAER4 concentration" "ppmv" +state real bpinaer1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bpinaer1" "BPINAER1 concentration" "ppmv" +state real bpinaer2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bpinaer2" "BPINAER2 concentration" "ppmv" +state real bpinaer3 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bpinaer3" "BPINAER3 concentration" "ppmv" +state real bpinaer4 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bpinaer4" "BPINAER4 concentration" "ppmv" +state real bpinaer5 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bpinaer5" "BPINAER5 concentration" "ppmv" +state real ter ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ter" "TER concentration" "ppmv" +state real teraer1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "teraer1" "TERAER1 concentration" "ppmv" +state real teraer2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "teraer2" "TERAER2 concentration" "ppmv" +state real alkh ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "alkh" "ALKH concentration" "ppmv" +state real alkhaer1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "alkhaer1" "ALKHAER1 concentration" "ppmv" +state real pah ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pah" "PAH concentration" "ppmv" +state real pahaer1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pahaer1" "PAHAER1 concentration" "ppmv" +state real pahaer2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pahaer2" "PAHAER2 concentration" "ppmv" +state real hg0 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hg0" "HG0 concentration" "ppmv" +state real hg2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hg2" "HG2 concentration" "ppmv" +state real fmcl ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "fmcl" "FMCL concentration" "ppmv" +state real cl ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cl" "CL concentration" "ppmv" +state real cl2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cl2" "CL2 concentration" "ppmv" +state real hocl ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hocl" "HOCL concentration" "ppmv" +state real clo ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "clo" "CLO concentration" "ppmv" #Aerosol variables inside the chem array... # the first two are for simple advection of total pm25 and pm10 mass @@ -1641,6 +2279,26 @@ state real soilcw ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real nu0cw ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nu0cw" "Aitken mode number in cloud" "#/kg-dryair" state real ac0cw ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ac0cw" "Accumulation mode number in cloud" "#/kg-dryair" state real corncw ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "corncw" "Coarse mode number in cloud" "#/kg-dryair" + +# new cloud phase species for MADE/SORG-VBS +state real asoa1cwj ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa1cwj" "SOA Anth. org. conc. with C* value=1 ug/m^3 Acc. mode in cloud" "ug/kg-dryair" +state real asoa1cwi ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa1cwi" "SOA Anth. org. conc. with C* value=1 ug/m^3 Aitken mode in cloud" "ug/kg-dryair" +state real asoa2cwj ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa2cwj" "SOA Anth. org. conc. with C* value=10 ug/m^3 Acc. mode in cloud" "ug/kg-dryair" +state real asoa2cwi ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa2cwi" "SOA Anth. org. conc. with C* value=10 ug/m^3 Aitken mode in cloud" "ug/kg-dryair" +state real asoa3cwj ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa3cwj" "SOA Anth. org. conc. with C* value=100 ug/m^3 Acc. mode in cloud" "ug/kg-dryair" +state real asoa3cwi ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa3cwi" "SOA Anth. org. conc. with C* value=100 ug/m^3 Aitken mode in cloud" "ug/kg-dryair" +state real asoa4cwj ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa4cwj" "SOA Anth. org. conc. with C* value=1000 ug/m^3 Acc. mode in cloud" "ug/kg-dryair" +state real asoa4cwi ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa4cwi" "SOA Anth. org. conc. with C* value=1000 ug/m^3 Aitken mode in cloud" "ug/kg-dryair" +state real bsoa1cwj ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa1cwj" "SOA Biog. org. conc. with C* value=1 ug/m^3 Acc. mode in cloud" "ug/kg-dryair" +state real bsoa1cwi ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa1cwi" "SOA Biog. org. conc. with C* value=1 ug/m^3 Aitken mode in cloud" "ug/kg-dryair" +state real bsoa2cwj ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa2cwj" "SOA Biog. org. conc. with C* value=10 ug/m^3 Acc. mode in cloud" "ug/kg-dryair" +state real bsoa2cwi ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa2cwi" "SOA Biog. org. conc. with C* value=10 ug/m^3 Aitken mode in cloud" "ug/kg-dryair" +state real bsoa3cwj ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa3cwj" "SOA Biog. org. conc. with C* value=100 ug/m^3 Acc. mode in cloud" "ug/kg-dryair" +state real bsoa3cwi ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa3cwi" "SOA Biog. org. conc. with C* value=100 ug/m^3 Aitken mode in cloud" "ug/kg-dryair" +state real bsoa4cwj ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa4cwj" "SOA Biog. org. conc. with C* value=1000 ug/m^3 Acc. mode in cloud" "ug/kg-dryair" +state real bsoa4cwi ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa4cwi" "SOA Biog. org. conc. with C* value=1000 ug/m^3 Aitken mode in cloud" "ug/kg-dryair" + + #cms++ additional species from RACM-MIM (Geiger et al., Atmos. Env., 2003) state real hace ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "hace" "HACE concentration" "ppm" state real ishp ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ishp" "ISHP concentration" "ppm" @@ -1747,6 +2405,21 @@ state real biog1_o_a01 ikjftb chem 1 - i0{12}rhusdf=(bd state real biog2_o_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog2_o_a01" "biog2_o, aerosol bin 01" "ug/kg-dryair" state real biog3_o_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog3_o_a01" "biog3_o, aerosol bin 01" "ug/kg-dryair" state real biog4_o_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog4_o_a01" "biog4_o, aerosol bin 01" "ug/kg-dryair" +state real asoaX_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoaX_a01" "SOA Anth. org. conc. with C* value=X ug/m^3 Bin 1" "ug/kg-dryair" +state real asoa1_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa1_a01" "SOA Anth. org. conc. with C* value=1 ug/m^3 Bin 1" "ug/kg-dryair" +state real asoa2_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa2_a01" "SOA Anth. org. conc. with C* value=10 ug/m^3 Bin 1" "ug/kg-dryair" +state real asoa3_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa3_a01" "SOA Anth. org. conc. with C* value=100 ug/m^3 Bin 1" "ug/kg-dryair" +state real asoa4_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa4_a01" "SOA Anth. org. conc. with C* value=1000 ug/m^3 Bin 1" "ug/kg-dryair" +state real bsoaX_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoaX_a01" "SOA Biog. org. conc. with C* value=X ug/m^3 Bin 1" "ug/kg-dryair" +state real bsoa1_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa1_a01" "SOA Biog. org. conc. with C* value=1 ug/m^3 Bin 1" "ug/kg-dryair" +state real bsoa2_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa2_a01" "SOA Biog. org. conc. with C* value=10 ug/m^3 Bin 1" "ug/kg-dryair" +state real bsoa3_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa3_a01" "SOA Biog. org. conc. with C* value=100 ug/m^3 Bin 1" "ug/kg-dryair" +state real bsoa4_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa4_a01" "SOA Biog. org. conc. with C* value=1000 ug/m^3 Bin 1" "ug/kg-dryair" +state real glysoa_r1_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r1_a01" "glysoa_r1, aerosol bin 01" "ug/kg-dryair" +state real glysoa_r2_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r2_a01" "glysoa_r2, aerosol bin 01" "ug/kg-dryair" +state real glysoa_sfc_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_sfc_a01" "glysoa_sfc, aerosol bin 01" "ug/kg-dryair" +state real glysoa_nh4_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_nh4_a01" "glysoa_nh4, aerosol bin 01" "ug/kg-dryair" +state real glysoa_oh_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_oh_a01" "glysoa_oh, aerosol bin 01" "ug/kg-dryair" state real cl_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cl_a01" "Chloride, aerosol bin 01" "ug/kg-dryair" state real msa_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "msa_a01" "MSA, aerosol bin 01" "ug/kg-dryair" state real co3_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "co3_a01" "Carbonate, aerosol bin 01" "ug/kg-dryair" @@ -1855,6 +2528,21 @@ state real biog1_o_a02 ikjftb chem 1 - i0{12}rhusdf=(bd state real biog2_o_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog2_o_a02" "biog2_o, aerosol bin 01" "ug/kg-dryair" state real biog3_o_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog3_o_a02" "biog3_o, aerosol bin 01" "ug/kg-dryair" state real biog4_o_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog4_o_a02" "biog4_o, aerosol bin 01" "ug/kg-dryair" +state real asoaX_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoaX_a02" "SOA Anth. org. conc. with C* value=X ug/m^3 Bin 2" "ug/kg-dryair" +state real asoa1_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa1_a02" "SOA Anth. org. conc. with C* value=1 ug/m^3 Bin 2" "ug/kg-dryair" +state real asoa2_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa2_a02" "SOA Anth. org. conc. with C* value=10 ug/m^3 Bin 2" "ug/kg-dryair" +state real asoa3_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa3_a02" "SOA Anth. org. conc. with C* value=100 ug/m^3 Bin 2" "ug/kg-dryair" +state real asoa4_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa4_a02" "SOA Anth. org. conc. with C* value=1000 ug/m^3 Bin 2" "ug/kg-dryair" +state real bsoaX_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoaX_a02" "SOA Biog. org. conc. with C* value=X ug/m^3 Bin 2" "ug/kg-dryair" +state real bsoa1_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa1_a02" "SOA Biog. org. conc. with C* value=1 ug/m^3 Bin 2" "ug/kg-dryair" +state real bsoa2_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa2_a02" "SOA Biog. org. conc. with C* value=10 ug/m^3 Bin 2" "ug/kg-dryair" +state real bsoa3_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa3_a02" "SOA Biog. org. conc. with C* value=100 ug/m^3 Bin 2" "ug/kg-dryair" +state real bsoa4_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa4_a02" "SOA Biog. org. conc. with C* value=1000 ug/m^3 Bin 2" "ug/kg-dryair" +state real glysoa_r1_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r1_a02" "glysoa_r1, aerosol bin 02" "ug/kg-dryair" +state real glysoa_r2_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r2_a02" "glysoa_r2, aerosol bin 02" "ug/kg-dryair" +state real glysoa_sfc_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_sfc_a02" "glysoa_sfc, aerosol bin 02" "ug/kg-dryair" +state real glysoa_nh4_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_nh4_a02" "glysoa_nh4, aerosol bin 02" "ug/kg-dryair" +state real glysoa_oh_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_oh_a02" "glysoa_oh, aerosol bin 02" "ug/kg-dryair" state real cl_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cl_a02" "Chloride, aerosol bin 02" "ug/kg-dryair" state real msa_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "msa_a02" "MSA, aerosol bin 02" "ug/kg-dryair" state real co3_a02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "co3_a02" "Carbonate, aerosol bin 02" "ug/kg-dryair" @@ -1963,6 +2651,21 @@ state real biog1_o_a03 ikjftb chem 1 - i0{12}rhusdf=(bd state real biog2_o_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog2_o_a03" "biog2_o, aerosol bin 01" "ug/kg-dryair" state real biog3_o_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog3_o_a03" "biog3_o, aerosol bin 01" "ug/kg-dryair" state real biog4_o_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog4_o_a03" "biog4_o, aerosol bin 01" "ug/kg-dryair" +state real asoaX_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoaX_a03" "SOA Anth. org. conc. with C* value=X ug/m^3 Bin 3" "ug/kg-dryair" +state real asoa1_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa1_a03" "SOA Anth. org. conc. with C* value=1 ug/m^3 Bin 3" "ug/kg-dryair" +state real asoa2_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa2_a03" "SOA Anth. org. conc. with C* value=10 ug/m^3 Bin 3" "ug/kg-dryair" +state real asoa3_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa3_a03" "SOA Anth. org. conc. with C* value=100 ug/m^3 Bin 3" "ug/kg-dryair" +state real asoa4_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa4_a03" "SOA Anth. org. conc. with C* value=1000 ug/m^3 Bin 3" "ug/kg-dryair" +state real bsoaX_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoaX_a03" "SOA Biog. org. conc. with C* value=X ug/m^3 Bin 3" "ug/kg-dryair" +state real bsoa1_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa1_a03" "SOA Biog. org. conc. with C* value=1 ug/m^3 Bin 3" "ug/kg-dryair" +state real bsoa2_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa2_a03" "SOA Biog. org. conc. with C* value=10 ug/m^3 Bin 3" "ug/kg-dryair" +state real bsoa3_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa3_a03" "SOA Biog. org. conc. with C* value=100 ug/m^3 Bin 3" "ug/kg-dryair" +state real bsoa4_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa4_a03" "SOA Biog. org. conc. with C* value=1000 ug/m^3 Bin 3" "ug/kg-dryair" +state real glysoa_r1_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r1_a03" "glysoa_r1, aerosol bin 03" "ug/kg-dryair" +state real glysoa_r2_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r2_a03" "glysoa_r2, aerosol bin 03" "ug/kg-dryair" +state real glysoa_sfc_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_sfc_a03" "glysoa_sfc, aerosol bin 03" "ug/kg-dryair" +state real glysoa_nh4_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_nh4_a03" "glysoa_nh4, aerosol bin 03" "ug/kg-dryair" +state real glysoa_oh_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_oh_a03" "glysoa_oh, aerosol bin 03" "ug/kg-dryair" state real cl_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cl_a03" "Chloride, aerosol bin 03" "ug/kg-dryair" state real msa_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "msa_a03" "MSA, aerosol bin 03" "ug/kg-dryair" state real co3_a03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "co3_a03" "Carbonate, aerosol bin 03" "ug/kg-dryair" @@ -2071,6 +2774,21 @@ state real biog1_o_a04 ikjftb chem 1 - i0{12}rhusdf=(bd state real biog2_o_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog2_o_a04" "biog2_o, aerosol bin 01" "ug/kg-dryair" state real biog3_o_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog3_o_a04" "biog3_o, aerosol bin 01" "ug/kg-dryair" state real biog4_o_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog4_o_a04" "biog4_o, aerosol bin 01" "ug/kg-dryair" +state real asoaX_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoaX_a04" "SOA Anth. org. conc. with C* value=X ug/m^3 Bin 4" "ug/kg-dryair" +state real asoa1_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa1_a04" "SOA Anth. org. conc. with C* value=1 ug/m^3 Bin 4" "ug/kg-dryair" +state real asoa2_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa2_a04" "SOA Anth. org. conc. with C* value=10 ug/m^3 Bin 4" "ug/kg-dryair" +state real asoa3_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa3_a04" "SOA Anth. org. conc. with C* value=100 ug/m^3 Bin 4" "ug/kg-dryair" +state real asoa4_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa4_a04" "SOA Anth. org. conc. with C* value=1000 ug/m^3 Bin 4" "ug/kg-dryair" +state real bsoaX_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoaX_a04" "SOA Biog. org. conc. with C* value=X ug/m^3 Bin 4" "ug/kg-dryair" +state real bsoa1_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa1_a04" "SOA Biog. org. conc. with C* value=1 ug/m^3 Bin 4" "ug/kg-dryair" +state real bsoa2_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa2_a04" "SOA Biog. org. conc. with C* value=10 ug/m^3 Bin 4" "ug/kg-dryair" +state real bsoa3_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa3_a04" "SOA Biog. org. conc. with C* value=100 ug/m^3 Bin 4" "ug/kg-dryair" +state real bsoa4_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa4_a04" "SOA Biog. org. conc. with C* value=1000 ug/m^3 Bin 4" "ug/kg-dryair" +state real glysoa_r1_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r1_a04" "glysoa_r2, aerosol bin 04" "ug/kg-dryair" +state real glysoa_r2_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r2_a04" "glysoa_r1, aerosol bin 04" "ug/kg-dryair" +state real glysoa_sfc_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_sfc_a04" "glysoa_sfc, aerosol bin 04" "ug/kg-dryair" +state real glysoa_nh4_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_nh4_a04" "glysoa_nh4, aerosol bin 04" "ug/kg-dryair" +state real glysoa_oh_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_oh_a04" "glysoa_oh, aerosol bin 04" "ug/kg-dryair" state real cl_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cl_a04" "Chloride, aerosol bin 04" "ug/kg-dryair" state real msa_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "msa_a04" "MSA, aerosol bin 04" "ug/kg-dryair" state real co3_a04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "co3_a04" "Carbonate, aerosol bin 04" "ug/kg-dryair" @@ -2161,6 +2879,25 @@ state real opcg5_f_o_a05 ikjftb chem 1 - i0{12}rhusdf=(bdy state real opcg6_f_o_a05 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg6_f_o_a05" "opcg6_f_o, aerosol bin 01" "ug/kg-dryair" state real opcg7_f_o_a05 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg7_f_o_a05" "opcg7_f_o, aerosol bin 01" "ug/kg-dryair" state real opcg8_f_o_a05 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg8_f_o_a05" "opcg8_f_o, aerosol bin 01" "ug/kg-dryair" +#BSINGH +state real ant1_c_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant1_c_a05" "ant1_c, aerosol bin 05" "ug/kg-dryair" +state real ant2_c_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant2_c_a05" "ant2_c, aerosol bin 01" "ug/kg-dryair" +state real ant3_c_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant3_c_a05" "ant3_c, aerosol bin 01" "ug/kg-dryair" +state real ant4_c_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant4_c_a05" "ant4_c, aerosol bin 01" "ug/kg-dryair" +state real ant1_o_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant1_o_a05" "ant1_o, aerosol bin 01" "ug/kg-dryair" +state real ant2_o_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant2_o_a05" "ant2_o, aerosol bin 01" "ug/kg-dryair" +state real ant3_o_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant3_o_a05" "ant3_o, aerosol bin 01" "ug/kg-dryair" +state real ant4_o_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant4_o_a05" "ant4_o, aerosol bin 01" "ug/kg-dryair" +state real biog1_c_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog1_c_a05" "biog1_c, aerosol bin 05" "ug/kg-dryair" +state real biog2_c_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog2_c_a05" "biog2_c, aerosol bin 01" "ug/kg-dryair" +state real biog3_c_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog3_c_a05" "biog3_c, aerosol bin 01" "ug/kg-dryair" +state real biog4_c_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog4_c_a05" "biog4_c, aerosol bin 01" "ug/kg-dryair" +state real biog1_o_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog1_o_a05" "biog1_o, aerosol bin 01" "ug/kg-dryair" +state real biog2_o_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog2_o_a05" "biog2_o, aerosol bin 01" "ug/kg-dryair" +state real biog3_o_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog3_o_a05" "biog3_o, aerosol bin 01" "ug/kg-dryair" +state real biog4_o_a05 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog4_o_a05" "biog4_o, aerosol bin 01" "ug/kg-dryair" +#BSINGH - ENDS + state real cl_a05 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cl_a05" "Chloride, aerosol bin 05" "ug/kg-dryair" state real msa_a05 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "msa_a05" "MSA, aerosol bin 05" "ug/kg-dryair" state real co3_a05 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "co3_a05" "Carbonate, aerosol bin 05" "ug/kg-dryair" @@ -2251,6 +2988,25 @@ state real opcg5_f_o_a06 ikjftb chem 1 - i0{12}rhusdf=(bdy state real opcg6_f_o_a06 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg6_f_o_a06" "opcg6_f_o, aerosol bin 01" "ug/kg-dryair" state real opcg7_f_o_a06 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg7_f_o_a06" "opcg7_f_o, aerosol bin 01" "ug/kg-dryair" state real opcg8_f_o_a06 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg8_f_o_a06" "opcg8_f_o, aerosol bin 01" "ug/kg-dryair" +#BSINGH +state real ant1_c_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant1_c_a06" "ant1_c, aerosol bin 05" "ug/kg-dryair" +state real ant2_c_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant2_c_a06" "ant2_c, aerosol bin 01" "ug/kg-dryair" +state real ant3_c_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant3_c_a06" "ant3_c, aerosol bin 01" "ug/kg-dryair" +state real ant4_c_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant4_c_a06" "ant4_c, aerosol bin 01" "ug/kg-dryair" +state real ant1_o_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant1_o_a06" "ant1_o, aerosol bin 01" "ug/kg-dryair" +state real ant2_o_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant2_o_a06" "ant2_o, aerosol bin 01" "ug/kg-dryair" +state real ant3_o_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant3_o_a06" "ant3_o, aerosol bin 01" "ug/kg-dryair" +state real ant4_o_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant4_o_a06" "ant4_o, aerosol bin 01" "ug/kg-dryair" + +state real biog1_c_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog1_c_a06" "biog1_c, aerosol bin 05" "ug/kg-dryair" +state real biog2_c_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog2_c_a06" "biog2_c, aerosol bin 01" "ug/kg-dryair" +state real biog3_c_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog3_c_a06" "biog3_c, aerosol bin 01" "ug/kg-dryair" +state real biog4_c_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog4_c_a06" "biog4_c, aerosol bin 01" "ug/kg-dryair" +state real biog1_o_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog1_o_a06" "biog1_o, aerosol bin 01" "ug/kg-dryair" +state real biog2_o_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog2_o_a06" "biog2_o, aerosol bin 01" "ug/kg-dryair" +state real biog3_o_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog3_o_a06" "biog3_o, aerosol bin 01" "ug/kg-dryair" +state real biog4_o_a06 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog4_o_a06" "biog4_o, aerosol bin 01" "ug/kg-dryair" +#BSINGH -ENDs state real cl_a06 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cl_a06" "Chloride, aerosol bin 06" "ug/kg-dryair" state real msa_a06 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "msa_a06" "MSA, aerosol bin 06" "ug/kg-dryair" state real co3_a06 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "co3_a06" "Carbonate, aerosol bin 06" "ug/kg-dryair" @@ -2341,6 +3097,25 @@ state real opcg5_f_o_a07 ikjftb chem 1 - i0{12}rhusdf=(bdy state real opcg6_f_o_a07 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg6_f_o_a07" "opcg6_f_o, aerosol bin 01" "ug/kg-dryair" state real opcg7_f_o_a07 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg7_f_o_a07" "opcg7_f_o, aerosol bin 01" "ug/kg-dryair" state real opcg8_f_o_a07 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg8_f_o_a07" "opcg8_f_o, aerosol bin 01" "ug/kg-dryair" +#BSINGH +state real ant1_c_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant1_c_a07" "ant1_c, aerosol bin 05" "ug/kg-dryair" +state real ant2_c_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant2_c_a07" "ant2_c, aerosol bin 01" "ug/kg-dryair" +state real ant3_c_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant3_c_a07" "ant3_c, aerosol bin 01" "ug/kg-dryair" +state real ant4_c_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant4_c_a07" "ant4_c, aerosol bin 01" "ug/kg-dryair" +state real ant1_o_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant1_o_a07" "ant1_o, aerosol bin 01" "ug/kg-dryair" +state real ant2_o_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant2_o_a07" "ant2_o, aerosol bin 01" "ug/kg-dryair" +state real ant3_o_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant3_o_a07" "ant3_o, aerosol bin 01" "ug/kg-dryair" +state real ant4_o_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant4_o_a07" "ant4_o, aerosol bin 01" "ug/kg-dryair" +state real biog1_c_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog1_c_a07" "biog1_c, aerosol bin 05" "ug/kg-dryair" +state real biog2_c_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog2_c_a07" "biog2_c, aerosol bin 01" "ug/kg-dryair" +state real biog3_c_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog3_c_a07" "biog3_c, aerosol bin 01" "ug/kg-dryair" +state real biog4_c_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog4_c_a07" "biog4_c, aerosol bin 01" "ug/kg-dryair" +state real biog1_o_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog1_o_a07" "biog1_o, aerosol bin 01" "ug/kg-dryair" +state real biog2_o_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog2_o_a07" "biog2_o, aerosol bin 01" "ug/kg-dryair" +state real biog3_o_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog3_o_a07" "biog3_o, aerosol bin 01" "ug/kg-dryair" +state real biog4_o_a07 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog4_o_a07" "biog4_o, aerosol bin 01" "ug/kg-dryair" +#BSINGH-Ends + state real cl_a07 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cl_a07" "Chloride, aerosol bin 07" "ug/kg-dryair" state real msa_a07 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "msa_a07" "MSA, aerosol bin 07" "ug/kg-dryair" state real co3_a07 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "co3_a07" "Carbonate, aerosol bin 07" "ug/kg-dryair" @@ -2431,6 +3206,25 @@ state real opcg5_f_o_a08 ikjftb chem 1 - i0{12}rhusdf=(bdy state real opcg6_f_o_a08 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg6_f_o_a08" "opcg6_f_o, aerosol bin 01" "ug/kg-dryair" state real opcg7_f_o_a08 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg7_f_o_a08" "opcg7_f_o, aerosol bin 01" "ug/kg-dryair" state real opcg8_f_o_a08 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "opcg8_f_o_a08" "opcg8_f_o, aerosol bin 01" "ug/kg-dryair" +#BSINGH +state real ant1_c_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant1_c_a08" "ant1_c, aerosol bin 05" "ug/kg-dryair" +state real ant2_c_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant2_c_a08" "ant2_c, aerosol bin 01" "ug/kg-dryair" +state real ant3_c_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant3_c_a08" "ant3_c, aerosol bin 01" "ug/kg-dryair" +state real ant4_c_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant4_c_a08" "ant4_c, aerosol bin 01" "ug/kg-dryair" +state real ant1_o_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant1_o_a08" "ant1_o, aerosol bin 01" "ug/kg-dryair" +state real ant2_o_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant2_o_a08" "ant2_o, aerosol bin 01" "ug/kg-dryair" +state real ant3_o_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant3_o_a08" "ant3_o, aerosol bin 01" "ug/kg-dryair" +state real ant4_o_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "ant4_o_a08" "ant4_o, aerosol bin 01" "ug/kg-dryair" +state real biog1_c_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog1_c_a08" "biog1_c, aerosol bin 05" "ug/kg-dryair" +state real biog2_c_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog2_c_a08" "biog2_c, aerosol bin 01" "ug/kg-dryair" +state real biog3_c_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog3_c_a08" "biog3_c, aerosol bin 01" "ug/kg-dryair" +state real biog4_c_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog4_c_a08" "biog4_c, aerosol bin 01" "ug/kg-dryair" +state real biog1_o_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog1_o_a08" "biog1_o, aerosol bin 01" "ug/kg-dryair" +state real biog2_o_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog2_o_a08" "biog2_o, aerosol bin 01" "ug/kg-dryair" +state real biog3_o_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog3_o_a08" "biog3_o, aerosol bin 01" "ug/kg-dryair" +state real biog4_o_a08 ikjftb chem 1 - i0{12}rusdf=(bdy_interp:dt) "biog4_o_a08" "biog4_o, aerosol bin 01" "ug/kg-dryair" +#BSINGH -ENDS + state real cl_a08 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "cl_a08" "Chloride, aerosol bin 08" "ug/kg-dryair" state real msa_a08 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "msa_a08" "MSA, aerosol bin 08" "ug/kg-dryair" state real co3_a08 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "co3_a08" "Carbonate, aerosol bin 08" "ug/kg-dryair" @@ -2455,6 +3249,11 @@ state real ca_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real oin_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oin_cw01" "Other inorganics, aerosol in cloud bin 01" "ug/kg-dryair" state real oc_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oc_cw01" "Organic carbon, aerosol in cloud bin 01" "ug/kg-dryair" state real bc_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bc_cw01" "Black carbon, aerosol in cloud bin 01" "ug/kg-dryair" +state real glysoa_r1_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r1_cw01" "glysoa_r1, aerosol in cloud bin 01" "ug/kg-dryair" +state real glysoa_r2_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r2_cw01" "glysoa_r2, aerosol in cloud bin 01" "ug/kg-dryair" +state real glysoa_sfc_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_sfc_cw01" "glysoa_sfc, aerosol in cloud bin 01" "ug/kg-dryair" +state real glysoa_nh4_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_nh4_cw01" "glysoa_nh4, aerosol in cloud bin 01" "ug/kg-dryair" +state real glysoa_oh_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_oh_cw01" "glysoa_oh, aerosol in cloud bin 01" "ug/kg-dryair" state real num_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "num_cw01" "Number, aerosol in cloud bin 01" "#/kg-dryair" state real so4_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "so4_cw02" "Sulfate, aerosol in cloud bin 02" "ug/kg-dryair" state real no3_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "no3_cw02" "Nitrate, aerosol in cloud bin 02" "ug/kg-dryair" @@ -2467,6 +3266,13 @@ state real ca_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real oin_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oin_cw02" "Other inorganics, aerosol in cloud bin 02" "ug/kg-dryair" state real oc_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oc_cw02" "Organic carbon, aerosol in cloud bin 02" "ug/kg-dryair" state real bc_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bc_cw02" "Black carbon, aerosol in cloud bin 02" "ug/kg-dryair" +state real glysoa_r1_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r1_cw02" "glysoa_r1, aerosol in cloud bin 02" "ug/kg-dryair" +state real glysoa_r2_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r2_cw02" "glysoa_r2, aerosol in cloud bin 02" "ug/kg-dryair" +state real glysoa_sfc_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_sfc_cw02" "glysoa_sfc, aerosol in cloud bin 02" "ug/kg-dryair" +state real glysoa_nh4_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_nh4_cw02" "glysoa_nh4, aerosol in cloud bin 02" "ug/kg-dryair" +state real glysoa_oh_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_oh_cw02" "glysoa_oh, aerosol in cloud bin 02" "ug/kg-dryair" +state real biog1_c_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog1_c_cw02" "biog1_c, aerosol in cloud bin 02" "ug/kg-dryair" +state real biog1_o_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog1_o_cw02" "biog1_o, aerosol in cloud bin 02" "ug/kg-dryair" state real num_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "num_cw02" "Number, aerosol in cloud bin 02" "#/kg-dryair" state real so4_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "so4_cw03" "Sulfate, aerosol in cloud bin 03" "ug/kg-dryair" state real no3_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "no3_cw03" "Nitrate, aerosol in cloud bin 03" "ug/kg-dryair" @@ -2479,6 +3285,13 @@ state real ca_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real oin_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oin_cw03" "Other inorganics, aerosol in cloud bin 03" "ug/kg-dryair" state real oc_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oc_cw03" "Organic carbon, aerosol in cloud bin 03" "ug/kg-dryair" state real bc_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bc_cw03" "Black carbon, aerosol in cloud bin 03" "ug/kg-dryair" +state real glysoa_r1_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r1_cw03" "glysoa_r1, aerosol in cloud bin 03" "ug/kg-dryair" +state real glysoa_r2_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r2_cw03" "glysoa_r2, aerosol in cloud bin 03" "ug/kg-dryair" +state real glysoa_sfc_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_sfc_cw03" "glysoa_sfc, aerosol in cloud bin 03" "ug/kg-dryair" +state real glysoa_nh4_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_nh4_cw03" "glysoa_nh4, aerosol in cloud bin 03" "ug/kg-dryair" +state real glysoa_oh_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_oh_cw03" "glysoa_oh, aerosol in cloud bin 03" "ug/kg-dryair" +state real biog1_c_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog1_c_cw03" "biog1_c, aerosol in cloud bin 03" "ug/kg-dryair" +state real biog1_o_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "biog1_o_cw03" "biog1_o, aerosol in cloud bin 03" "ug/kg-dryair" state real num_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "num_cw03" "Number, aerosol in cloud bin 03" "#/kg-dryair" state real so4_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "so4_cw04" "Sulfate, aerosol in cloud bin 04" "ug/kg-dryair" state real no3_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "no3_cw04" "Nitrate, aerosol in cloud bin 04" "ug/kg-dryair" @@ -2491,6 +3304,11 @@ state real ca_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real oin_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oin_cw04" "Other inorganics, aerosol in cloud bin 04" "ug/kg-dryair" state real oc_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "oc_cw04" "Organic carbon, aerosol in cloud bin 04" "ug/kg-dryair" state real bc_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bc_cw04" "Black carbon, aerosol in cloud bin 04" "ug/kg-dryair" +state real glysoa_r1_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r1_cw04" "glysoa_r1, aerosol in cloud bin 04" "ug/kg-dryair" +state real glysoa_r2_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_r2_cw04" "glysoa_r2, aerosol in cloud bin 04" "ug/kg-dryair" +state real glysoa_sfc_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_sfc_cw04" "glysoa_sfc, aerosol in cloud bin 04" "ug/kg-dryair" +state real glysoa_nh4_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_nh4_cw04" "glysoa_nh4, aerosol in cloud bin 04" "ug/kg-dryair" +state real glysoa_oh_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "glysoa_oh_cw04" "glysoa_oh, aerosol in cloud bin 04" "ug/kg-dryair" state real num_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "num_cw04" "Number, aerosol in cloud bin 04" "#/kg-dryair" state real so4_cw05 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "so4_cw05" "Sulfate, aerosol in cloud bin 05" "ug/kg-dryair" state real no3_cw05 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "no3_cw05" "Nitrate, aerosol in cloud bin 05" "ug/kg-dryair" @@ -2541,6 +3359,136 @@ state real oc_cw08 ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real bc_cw08 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bc_cw08" "Black carbon, aerosol in cloud bin 08" "ug/kg-dryair" state real num_cw08 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "num_cw08" "Number, aerosol in cloud bin 08" "#/kg-dryair" +state real asoaX_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoaX_cw01" "SOA Anth. org. conc. with C* value=X ug/m^3 in cloud Bin 1" "ug/kg-dryair" +state real asoa1_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa1_cw01" "SOA Anth. org. conc. with C* value=1 ug/m^3 in cloud Bin 1" "ug/kg-dryair" +state real asoa2_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa2_cw01" "SOA Anth. org. conc. with C* value=10 ug/m^3 in cloud Bin 1" "ug/kg-dryair" +state real asoa3_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa3_cw01" "SOA Anth. org. conc. with C* value=100 ug/m^3 in cloud Bin 1" "ug/kg-dryair" +state real asoa4_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa4_cw01" "SOA Anth. org. conc. with C* value=1000 ug/m^3 in cloud Bin 1" "ug/kg-dryair" +state real bsoaX_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoaX_cw01" "SOA Biog. org. conc. with C* value=X ug/m^3 in cloud Bin 1" "ug/kg-dryair" +state real bsoa1_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa1_cw01" "SOA Biog. org. conc. with C* value=1 ug/m^3 in cloud Bin 1" "ug/kg-dryair" +state real bsoa2_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa2_cw01" "SOA Biog. org. conc. with C* value=10 ug/m^3 in cloud Bin 1" "ug/kg-dryair" +state real bsoa3_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa3_cw01" "SOA Biog. org. conc. with C* value=100 ug/m^3 in cloud Bin 1" "ug/kg-dryair" +state real bsoa4_cw01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa4_cw01" "SOA Biog. org. conc. with C* value=1000 ug/m^3 in cloud Bin 1" "ug/kg-dryair" +state real asoaX_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoaX_cw02" "SOA Anth. org. conc. with C* value=X ug/m^3 in cloud Bin 2" "ug/kg-dryair" +state real asoa1_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa1_cw02" "SOA Anth. org. conc. with C* value=1 ug/m^3 in cloud Bin 2" "ug/kg-dryair" +state real asoa2_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa2_cw02" "SOA Anth. org. conc. with C* value=10 ug/m^3 in cloud Bin 2" "ug/kg-dryair" +state real asoa3_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa3_cw02" "SOA Anth. org. conc. with C* value=100 ug/m^3 in cloud Bin 2" "ug/kg-dryair" +state real asoa4_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa4_cw02" "SOA Anth. org. conc. with C* value=1000 ug/m^3 in cloud Bin 2" "ug/kg-dryair" +state real bsoaX_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoaX_cw02" "SOA Biog. org. conc. with C* value=X ug/m^3 in cloud Bin 2" "ug/kg-dryair" +state real bsoa1_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa1_cw02" "SOA Biog. org. conc. with C* value=1 ug/m^3 in cloud Bin 2" "ug/kg-dryair" +state real bsoa2_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa2_cw02" "SOA Biog. org. conc. with C* value=10 ug/m^3 in cloud Bin 2" "ug/kg-dryair" +state real bsoa3_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa3_cw02" "SOA Biog. org. conc. with C* value=100 ug/m^3 in cloud Bin 2" "ug/kg-dryair" +state real bsoa4_cw02 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa4_cw02" "SOA Biog. org. conc. with C* value=1000 ug/m^3 in cloud Bin 2" "ug/kg-dryair" +state real asoaX_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoaX_cw03" "SOA Anth. org. conc. with C* value=X ug/m^3 in cloud Bin 3" "ug/kg-dryair" +state real asoa1_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa1_cw03" "SOA Anth. org. conc. with C* value=1 ug/m^3 in cloud Bin 3" "ug/kg-dryair" +state real asoa2_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa2_cw03" "SOA Anth. org. conc. with C* value=10 ug/m^3 in cloud Bin 3" "ug/kg-dryair" +state real asoa3_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa3_cw03" "SOA Anth. org. conc. with C* value=100 ug/m^3 in cloud Bin 3" "ug/kg-dryair" +state real asoa4_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa4_cw03" "SOA Anth. org. conc. with C* value=1000 ug/m^3 in cloud Bin 3" "ug/kg-dryair" +state real bsoaX_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoaX_cw03" "SOA Biog. org. conc. with C* value=X ug/m^3 in cloud Bin 3" "ug/kg-dryair" +state real bsoa1_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa1_cw03" "SOA Biog. org. conc. with C* value=1 ug/m^3 in cloud Bin 3" "ug/kg-dryair" +state real bsoa2_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa2_cw03" "SOA Biog. org. conc. with C* value=10 ug/m^3 in cloud Bin 3" "ug/kg-dryair" +state real bsoa3_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa3_cw03" "SOA Biog. org. conc. with C* value=100 ug/m^3 in cloud Bin 3" "ug/kg-dryair" +state real bsoa4_cw03 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa4_cw03" "SOA Biog. org. conc. with C* value=1000 ug/m^3 in cloud Bin 3" "ug/kg-dryair" +state real asoaX_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoaX_cw04" "SOA Anth. org. conc. with C* value=X ug/m^3 in cloud Bin 4" "ug/kg-dryair" +state real asoa1_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa1_cw04" "SOA Anth. org. conc. with C* value=1 ug/m^3 in cloud Bin 4" "ug/kg-dryair" +state real asoa2_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa2_cw04" "SOA Anth. org. conc. with C* value=10 ug/m^3 in cloud Bin 4" "ug/kg-dryair" +state real asoa3_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa3_cw04" "SOA Anth. org. conc. with C* value=100 ug/m^3 in cloud Bin 4" "ug/kg-dryair" +state real asoa4_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "asoa4_cw04" "SOA Anth. org. conc. with C* value=1000 ug/m^3 in cloud Bin 4" "ug/kg-dryair" +state real bsoaX_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoaX_cw04" "SOA Biog. org. conc. with C* value=X ug/m^3 in cloud Bin 4" "ug/kg-dryair" +state real bsoa1_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa1_cw04" "SOA Biog. org. conc. with C* value=1 ug/m^3 in cloud Bin 4" "ug/kg-dryair" +state real bsoa2_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa2_cw04" "SOA Biog. org. conc. with C* value=10 ug/m^3 in cloud Bin 4" "ug/kg-dryair" +state real bsoa3_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa3_cw04" "SOA Biog. org. conc. with C* value=100 ug/m^3 in cloud Bin 4" "ug/kg-dryair" +state real bsoa4_cw04 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "bsoa4_cw04" "SOA Biog. org. conc. with C* value=1000 ug/m^3 in cloud Bin 4" "ug/kg-dryair" + +#BSINGH +state real pcg1_b_c_cw01 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_c_cw01" "pcg1_b_c_cw01, aerosol bin 01" "ug/kg-dryair" +state real pcg1_b_o_cw01 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_o_cw01" "pcg1_b_o_cw01, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_c_cw01 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_c_cw01" "opcg1_b_c_cw01, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_o_cw01 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_o_cw01" "opcg1_b_o_cw01, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_c_cw01 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_c_cw01" "pcg1_f_c_cw01, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_o_cw01 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_o_cw01" "pcg1_f_o_cw01, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_c_cw01 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_c_cw01" "opcg1_f_c_cw01, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_o_cw01 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_o_cw01" "opcg1_f_o_cw01, aerosol bin 01" "ug/kg-dryair" +state real ant1_c_cw01 ikjftb chem 1 - irusdf=(bdy_interp:dt) "ant1_c_cw01" "ant1_c_cw01, aerosol bin 01" "ug/kg-dryair" +state real biog1_c_cw01 ikjftb chem 1 - irusdf=(bdy_interp:dt) "biog1_c_cw01" "biog1_c_cw01, aerosol bin 01" "ug/kg-dryair" + +state real pcg1_b_c_cw02 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_c_cw02" "pcg1_b_c_cw02, aerosol bin 01" "ug/kg-dryair" +state real pcg1_b_o_cw02 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_o_cw02" "pcg1_b_o_cw02, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_c_cw02 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_c_cw02" "opcg1_b_c_cw02, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_o_cw02 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_o_cw02" "opcg1_b_o_cw02, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_c_cw02 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_c_cw02" "pcg1_f_c_cw02, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_o_cw02 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_o_cw02" "pcg1_f_o_cw02, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_c_cw02 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_c_cw02" "opcg1_f_c_cw02, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_o_cw02 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_o_cw02" "opcg1_f_o_cw02, aerosol bin 01" "ug/kg-dryair" +state real ant1_c_cw02 ikjftb chem 1 - irusdf=(bdy_interp:dt) "ant1_c_cw02" "ant1_c_cw02, aerosol bin 01" "ug/kg-dryair" + +state real pcg1_b_c_cw03 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_c_cw03" "pcg1_b_c_cw03, aerosol bin 01" "ug/kg-dryair" +state real pcg1_b_o_cw03 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_o_cw03" "pcg1_b_o_cw03, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_c_cw03 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_c_cw03" "opcg1_b_c_cw03, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_o_cw03 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_o_cw03" "opcg1_b_o_cw03, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_c_cw03 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_c_cw03" "pcg1_f_c_cw03, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_o_cw03 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_o_cw03" "pcg1_f_o_cw03, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_c_cw03 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_c_cw03" "opcg1_f_c_cw03, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_o_cw03 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_o_cw03" "opcg1_f_o_cw03, aerosol bin 01" "ug/kg-dryair" +state real ant1_c_cw03 ikjftb chem 1 - irusdf=(bdy_interp:dt) "ant1_c_cw03" "ant1_c_cw03, aerosol bin 01" "ug/kg-dryair" + +state real pcg1_b_c_cw04 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_c_cw04" "pcg1_b_c_cw04, aerosol bin 01" "ug/kg-dryair" +state real pcg1_b_o_cw04 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_o_cw04" "pcg1_b_o_cw04, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_c_cw04 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_c_cw04" "opcg1_b_c_cw04, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_o_cw04 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_o_cw04" "opcg1_b_o_cw04, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_c_cw04 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_c_cw04" "pcg1_f_c_cw04, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_o_cw04 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_o_cw04" "pcg1_f_o_cw04, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_c_cw04 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_c_cw04" "opcg1_f_c_cw04, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_o_cw04 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_o_cw04" "opcg1_f_o_cw04, aerosol bin 01" "ug/kg-dryair" +state real ant1_c_cw04 ikjftb chem 1 - irusdf=(bdy_interp:dt) "ant1_c_cw04" "ant1_c_cw04, aerosol bin 01" "ug/kg-dryair" +state real biog1_c_cw04 ikjftb chem 1 - irusdf=(bdy_interp:dt) "biog1_c_cw04" "biog1_c_cw04, aerosol bin 01" "ug/kg-dryair" + +state real pcg1_b_c_cw05 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_c_cw05" "pcg1_b_c_cw05, aerosol bin 05" "ug/kg-dryair" +state real pcg1_b_o_cw05 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_o_cw05" "pcg1_b_o_cw05, aerosol bin 05" "ug/kg-dryair" +state real opcg1_b_c_cw05 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_c_cw05" "opcg1_b_c_cw05, aerosol bin 05" "ug/kg-dryair" +state real opcg1_b_o_cw05 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_o_cw05" "opcg1_b_o_cw05, aerosol bin 05" "ug/kg-dryair" +state real pcg1_f_c_cw05 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_c_cw05" "pcg1_f_c_cw05, aerosol bin 05" "ug/kg-dryair" +state real pcg1_f_o_cw05 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_o_cw05" "pcg1_f_o_cw05, aerosol bin 05" "ug/kg-dryair" +state real opcg1_f_c_cw05 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_c_cw05" "opcg1_f_c_cw05, aerosol bin 05" "ug/kg-dryair" +state real opcg1_f_o_cw05 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_o_cw05" "opcg1_f_o_cw05, aerosol bin 05" "ug/kg-dryair" +state real ant1_c_cw05 ikjftb chem 1 - irusdf=(bdy_interp:dt) "ant1_c_cw05" "ant1_c_cw05, aerosol bin 05" "ug/kg-dryair" +state real biog1_c_cw05 ikjftb chem 1 - irusdf=(bdy_interp:dt) "biog1_c_cw05" "biog1_c_cw05, aerosol bin 05" "ug/kg-dryair" + +state real pcg1_b_c_cw06 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_c_cw06" "pcg1_b_c_cw06, aerosol bin 06" "ug/kg-dryair" +state real pcg1_b_o_cw06 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_o_cw06" "pcg1_b_o_cw06, aerosol bin 06" "ug/kg-dryair" +state real opcg1_b_c_cw06 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_c_cw06" "opcg1_b_c_cw06, aerosol bin 06" "ug/kg-dryair" +state real opcg1_b_o_cw06 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_o_cw06" "opcg1_b_o_cw06, aerosol bin 06" "ug/kg-dryair" +state real pcg1_f_c_cw06 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_c_cw06" "pcg1_f_c_cw06, aerosol bin 06" "ug/kg-dryair" +state real pcg1_f_o_cw06 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_o_cw06" "pcg1_f_o_cw06, aerosol bin 06" "ug/kg-dryair" +state real opcg1_f_c_cw06 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_c_cw06" "opcg1_f_c_cw06, aerosol bin 06" "ug/kg-dryair" +state real opcg1_f_o_cw06 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_o_cw06" "opcg1_f_o_cw06, aerosol bin 06" "ug/kg-dryair" +state real ant1_c_cw06 ikjftb chem 1 - irusdf=(bdy_interp:dt) "ant1_c_cw06" "ant1_c_cw06, aerosol bin 06" "ug/kg-dryair" +state real biog1_c_cw06 ikjftb chem 1 - irusdf=(bdy_interp:dt) "biog1_c_cw06" "biog1_c_cw06, aerosol bin 06" "ug/kg-dryair" + +state real pcg1_b_c_cw07 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_c_cw07" "pcg1_b_c_cw07, aerosol bin 01" "ug/kg-dryair" +state real pcg1_b_o_cw07 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_o_cw07" "pcg1_b_o_cw07, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_c_cw07 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_c_cw07" "opcg1_b_c_cw07, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_o_cw07 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_o_cw07" "opcg1_b_o_cw07, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_c_cw07 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_c_cw07" "pcg1_f_c_cw07, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_o_cw07 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_o_cw07" "pcg1_f_o_cw07, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_c_cw07 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_c_cw07" "opcg1_f_c_cw07, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_o_cw07 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_o_cw07" "opcg1_f_o_cw07, aerosol bin 01" "ug/kg-dryair" +state real ant1_c_cw07 ikjftb chem 1 - irusdf=(bdy_interp:dt) "ant1_c_cw07" "ant1_c_cw07, aerosol bin 01" "ug/kg-dryair" +state real biog1_c_cw07 ikjftb chem 1 - irusdf=(bdy_interp:dt) "biog1_c_cw07" "biog1_c_cw07, aerosol bin 01" "ug/kg-dryair" + +state real pcg1_b_c_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_c_cw08" "pcg1_b_c_cw08, aerosol bin 01" "ug/kg-dryair" +state real pcg1_b_o_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_b_o_cw08" "pcg1_b_o_cw08, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_c_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_c_cw08" "opcg1_b_c_cw08, aerosol bin 01" "ug/kg-dryair" +state real opcg1_b_o_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_b_o_cw08" "opcg1_b_o_cw08, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_c_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_c_cw08" "pcg1_f_c_cw08, aerosol bin 01" "ug/kg-dryair" +state real pcg1_f_o_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "pcg1_f_o_cw08" "pcg1_f_o_cw08, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_c_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_c_cw08" "opcg1_f_c_cw08, aerosol bin 01" "ug/kg-dryair" +state real opcg1_f_o_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_o_cw08" "opcg1_f_o_cw08, aerosol bin 01" "ug/kg-dryair" +state real ant1_c_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "ant1_c_cw08" "ant1_c_cw08, aerosol bin 01" "ug/kg-dryair" +state real biog1_c_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "biog1_c_cw08" "biog1_c_cw08, aerosol bin 01" "ug/kg-dryair" + + +#BSINGH -ENDS # GOCART Aerosols state real bc1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "BC1" "Hydrophobic Black Carbon" "ug/kg-dryair" state real bc2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "BC2" "Hydrophilic Black Carbon" "ug/kg-dryair" @@ -2797,6 +3745,8 @@ rconfig logical scale_fire_emiss namelist,chem max_domains rconfig integer aer_ra_feedback namelist,chem max_domains 0 rh "aer_ra_feedback" "" "" rconfig integer aer_op_opt namelist,chem max_domains 1 rh "aer_op_opt" "" "" rconfig integer opt_pars_out namelist,chem 1 0 h "opt_pars_out" "" "" +rconfig integer diagnostic_dep namelist,chem max_domains 0 rh "diagnostic_dep" "" "" + # aircraft emissions rconfig integer aircraft_emiss_opt namelist,chem max_domains 0 rh "aircraft_emiss_opt" "" "" rconfig integer kemit_aircraft namelist,chem 1 1 irh "kemit_aircraft" "" "" @@ -2812,10 +3762,21 @@ rconfig character wes_seasonal_inname namelist,chem max_domains rconfig integer chemdiag namelist,chem max_domains 0 - "Chemical tendency diagnostics" "" "" -# Dust tuning constant for AFWA GOCART (dust_opt=3) -rconfig real dust_alpha namelist,chem 1 1. rh "dust_alpha" "dust tuning constant" "m^-1" -rconfig real dust_gamma namelist,chem 1 1. rh "dust_gamma" "erodibility exponential tuning const" "" -rconfig real dust_smtune namelist,chem 1 1. rh "dust_smtune" "soil moisture tuning constant" "" +# Options for AFWA GOCART Dust model (dust_opt=3) +# +# Tuning constants +rconfig real dust_alpha namelist,chem 1 1. rh "dust_alpha" "AFWA Dust global tuning constant" "m^-1" +rconfig real dust_gamma namelist,chem 1 1. rh "dust_gamma" "AFWA Dust erodibility exponential tuning const" "" +rconfig real dust_smtune namelist,chem 1 1. rh "dust_smtune" "AFWA Dust soil moisture tuning constant" "" +rconfig real dust_ustune namelist,chem 1 1. rh "dust_ustune" "AFWA Dust friction velocity tuning constant" "" +# Dust source region selector +rconfig integer dust_dsr namelist,chem 1 0. rh "dust_dsr" "AFWA Dust dust source region: 0 Ginoux (default), 1 DRI" "" +# Vegetation mask selector (to be applied to dust source region) +rconfig integer dust_veg namelist,chem 1 0. rh "dust_veg" "AFWA Dust veg. mask: 0 Ginoux, 1 12mo GreenFrac, 2 8day MODIS LAI" "" +# Soil texture selector +rconfig integer dust_soils namelist,chem 1 0. rh "dust_soils" "AFWA Dust clayfrac and sandfrac: 0 WRF (default), 1 NGA" "" +# Soil moisture selector +rconfig integer dust_smois namelist,chem 1 0. rh "dust_smois" "AFWA Dust soil moisture option: 0 gravimetric, 1 volumetric" "" # Volcanic ash height rconfig real emiss_ash_hgt namelist,chem 1 0. rh "emiss_ash_hgt" "Volcanic ash cloud top elevation (AGL)" "" @@ -2827,7 +3788,7 @@ rconfig real depo_fact namelist,chem max_domains rconfig integer track_chem_num namelist,chem 1 0 - "number of track chem requested" "" "" rconfig character track_chem_name namelist,chem max_trackchem "" - "name of track chem requested" "" "" rconfig integer track_rad_num namelist,chem 1 17 - "nw-1 in module_wave_data" "" "" -rconfig integer track_tuv_num namelist,chem 1 30 - "tuv_jmax in module_wave_data" "" "" +rconfig integer track_tuv_num namelist,chem 1 58 - "tuv_jmax in module_wave_data" "" "" rconfig integer track_tuv_lev namelist,chem 1 51 - "nref in module_ftuv_driver" "" "" # control for N2O5 heterogenenous chemistry option in MOSAIC @@ -2897,6 +3858,11 @@ package mozcart_kpp chem_opt==112 - chem:o3,o1 # KPP mechanism from CBMZ package cbmz_bb_kpp chem_opt==120 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,ch4,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2 +# CB05 coupled with MADE/SORGAM-AQ +package cb05_sorg_aq_kpp chem_opt==131 - chem:no2,no,o,o3,no3,o1d,oh,ho2,n2o5,hno3,hono,pna,h2o2,xo2,xo2n,ntr,rooh,form,ald2,aldx,par,co,meo2,mepx,meoh,hco3,facd,c2o3,pan,pacd,aacd,cxo3,panx,ror,ole,eth,iole,tol,cres,to2,tolaer1,tolaer2,open,cro,cslaer,mgly,xyl,xylaer1,xylaer2,isop,ispd,isoaer1,isoaer2,so2,sulf,sulaer,etoh,etha,terp,terpaer,hum,humaer,lim,limaer1,limaer2,oci,ociaer1,ociaer2,apin,apinaer1,apinaer2,apinaer3,apinaer4,bpin,bpinaer1,bpinaer2,bpinaer3,bpinaer4,bpinaer5,ter,teraer1,teraer2,alkh,alkhaer1,pah,pahaer1,pahaer2,h2,ch4,cl,hcl,fmcl,hg0,hg2,hocl,clo,cl2,nh3,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,orgaro1j,orgaro1i,orgaro2j,orgaro2i,orgalk1j,orgalk1i,orgole1j,orgole1i,orgba1j,orgba1i,orgba2j,orgba2i,orgba3j,orgba3i,orgba4j,orgba4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,nacwj,nacwi,clcwj,clcwi,orgaro1cwj,orgaro1cwi,orgaro2cwj,orgaro2cwi,orgalk1cwj,orgalk1cwi,orgole1cwj,orgole1cwi,orgba1cwj,orgba1cwi,orgba2cwj,orgba2cwi,orgba3cwj,orgba3cwi,orgba4cwj,orgba4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw + +# CB05-MADE/SORG-VBS-AQ +package cb05_sorg_vbs_aq_kpp chem_opt==132 - chem:no2,no,o,o3,no3,o1d,oh,ho2,n2o5,hno3,hono,pna,h2o2,xo2,xo2n,ntr,rooh,form,ald2,aldx,par,co,meo2,mepx,meoh,hco3,facd,c2o3,pan,pacd,aacd,cxo3,panx,ror,ole,eth,iole,tol,cres,to2,tolaer1,tolaer2,open,cro,cslaer,mgly,xyl,xylaer1,xylaer2,isop,ispd,isoaer1,isoaer2,so2,sulf,sulaer,etoh,etha,terp,terpaer,hum,humaer,lim,limaer1,limaer2,oci,ociaer1,ociaer2,apin,apinaer1,apinaer2,apinaer3,apinaer4,bpin,bpinaer1,bpinaer2,bpinaer3,bpinaer4,bpinaer5,ter,teraer1,teraer2,alkh,alkhaer1,pah,pahaer1,pahaer2,h2,ch4,cl,hcl,fmcl,hg0,hg2,hocl,clo,cl2,cvasoa1,cvasoa2,cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4,nh3,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,asoa1j,asoa1i,asoa2j,asoa2i,asoa3j,asoa3i,asoa4j,asoa4i,bsoa1j,bsoa1i,bsoa2j,bsoa2i,bsoa3j,bsoa3i,bsoa4j,bsoa4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,nacwj,nacwi,clcwj,clcwi,asoa1cwj,asoa1cwi,asoa2cwj,asoa2cwi,asoa3cwj,asoa3cwi,asoa4cwj,asoa4cwi,bsoa1cwj,bsoa1cwi,bsoa2cwj,bsoa2cwi,bsoa3cwj,bsoa3cwi,bsoa4cwj,bsoa4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw #cbmz_mosaic_kpp (chem_opt=170) is for mosaic runs with sorgam soa species: coded by Manish Shrivastava on 12/8/2009 package cbmz_mosaic_kpp chem_opt==170 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,ch4,aro1,aro2,alk1,ole1,api1,api2,lim1,lim2,api,lim,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,aro1_a01,aro2_a01,alk1_a01,ole1_a01,api1_a01,api2_a01,lim1_a01,lim2_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,aro1_a02,aro2_a02,alk1_a02,ole1_a02,api1_a02,api2_a02,lim1_a02,lim2_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,aro1_a03,aro2_a03,alk1_a03,ole1_a03,api1_a03,api2_a03,lim1_a03,lim2_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,aro1_a04,aro2_a04,alk1_a04,ole1_a04,api1_a04,api2_a04,lim1_a04,lim2_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,aro1_a05,aro2_a05,alk1_a05,ole1_a05,api1_a05,api2_a05,lim1_a05,lim2_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,aro1_a06,aro2_a06,alk1_a06,ole1_a06,api1_a06,api2_a06,lim1_a06,lim2_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,aro1_a07,aro2_a07,alk1_a07,ole1_a07,api1_a07,api2_a07,lim1_a07,lim2_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,aro1_a08,aro2_a08,alk1_a08,ole1_a08,api1_a08,api2_a08,lim1_a08,lim2_a08,num_a08,ca_a01,ca_a02,ca_a03,ca_a04,ca_a05,ca_a06,ca_a07,ca_a08,co3_a01,co3_a02,co3_a03,co3_a04,co3_a05,co3_a06,co3_a07,co3_a08 @@ -2908,10 +3874,25 @@ package saprc99_kpp chem_opt==195 - chem:o3,h2o2,no,no2,no3,n2o5,hono package saprc99_mosaic_4bin_vbs2_kpp chem_opt==198 - chem:o3,h2o2,no,no2,no3,n2o5,hono,hno3,hno4,so2,h2so4,co,hcho,ccho,rcho,acet,mek,hcooh,meoh,etoh,cco_oh,rco_oh,gly,mgly,bacl,cres,bald,isoprod,methacro,mvk,prod2,dcb1,dcb2,dcb3,ethene,isoprene,c2h6,c3h8,c2h2,c3h6,alk3,alk4,alk5,aro1,aro2,ole1,ole2,terp,rno3,nphe,phen,pan,pan2,pbzn,ma_pan,co2,cco_ooh,rco_o2,rco_ooh,xn,xc,ho,ho2,c_o2,cooh,rooh,ro2_r,r2o2,ro2_n,cco_o2,bzco_o2,ma_rco3,sesq,pcg1_b_c,pcg2_b_c,pcg1_b_o,pcg2_b_o,opcg1_b_c,opcg1_b_o,pcg1_f_c,pcg2_f_c,pcg1_f_o,pcg2_f_o,opcg1_f_c,opcg1_f_o,psd1,psd2,nh3,hcl,nume,den,ant1_c,ant1_o,biog1_c,biog1_o,ch4,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,pcg1_b_c_a01,pcg2_b_c_a01,pcg1_b_o_a01,pcg2_b_o_a01,opcg1_b_c_a01,opcg1_b_o_a01,pcg1_f_c_a01,pcg2_f_c_a01,pcg1_f_o_a01,pcg2_f_o_a01,opcg1_f_c_a01,opcg1_f_o_a01,ant1_c_a01,ant1_o_a01,biog1_c_a01,biog1_o_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,pcg1_b_c_a02,pcg2_b_c_a02,pcg1_b_o_a02,pcg2_b_o_a02,opcg1_b_c_a02,opcg1_b_o_a02,pcg1_f_c_a02,pcg2_f_c_a02,pcg1_f_o_a02,pcg2_f_o_a02,opcg1_f_c_a02,opcg1_f_o_a02,ant1_c_a02,ant1_o_a02,biog1_c_a02,biog1_o_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,pcg1_b_c_a03,pcg2_b_c_a03,pcg1_b_o_a03,pcg2_b_o_a03,opcg1_b_c_a03,opcg1_b_o_a03,pcg1_f_c_a03,pcg2_f_c_a03,pcg1_f_o_a03,pcg2_f_o_a03,opcg1_f_c_a03,opcg1_f_o_a03,ant1_c_a03,ant1_o_a03,biog1_c_a03,biog1_o_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,pcg1_b_c_a04,pcg2_b_c_a04,pcg1_b_o_a04,pcg2_b_o_a04,opcg1_b_c_a04,opcg1_b_o_a04,pcg1_f_c_a04,pcg2_f_c_a04,pcg1_f_o_a04,pcg2_f_o_a04,opcg1_f_c_a04,opcg1_f_o_a04,ant1_c_a04,ant1_o_a04,biog1_c_a04,biog1_o_a04,num_a04,ca_a01,ca_a02,ca_a03,ca_a04,co3_a01,co3_a02,co3_a03,co3_a04 -package cbmz_mosaic_4bin_vbs2_kpp chem_opt==199 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,aro1,aro2,alk1,ole1,api1,api2,lim1,lim2,api,lim,pcg1_b_c,pcg2_b_c,pcg1_b_o,pcg2_b_o,opcg1_b_c,opcg1_b_o,pcg1_f_c,pcg2_f_c,pcg1_f_o,pcg2_f_o,opcg1_f_c,opcg1_f_o,psd1,psd2,nh3,hcl,ch4,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,pcg1_b_c_a01,pcg2_b_c_a01,pcg1_b_o_a01,pcg2_b_o_a01,opcg1_b_c_a01,opcg1_b_o_a01,pcg1_f_c_a01,pcg2_f_c_a01,pcg1_f_o_a01,pcg2_f_o_a01,opcg1_f_c_a01,opcg1_f_o_a01,ant1_c_a01,ant1_o_a01,biog1_c_a01,biog1_o_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,pcg1_b_c_a02,pcg2_b_c_a02,pcg1_b_o_a02,pcg2_b_o_a02,opcg1_b_c_a02,opcg1_b_o_a02,pcg1_f_c_a02,pcg2_f_c_a02,pcg1_f_o_a02,pcg2_f_o_a02,opcg1_f_c_a02,opcg1_f_o_a02,ant1_c_a02,ant1_o_a02,biog1_c_a02,biog1_o_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,pcg1_b_c_a03,pcg2_b_c_a03,pcg1_b_o_a03,pcg2_b_o_a03,opcg1_b_c_a03,opcg1_b_o_a03,pcg1_f_c_a03,pcg2_f_c_a03,pcg1_f_o_a03,pcg2_f_o_a03,opcg1_f_c_a03,opcg1_f_o_a03,ant1_c_a03,ant1_o_a03,biog1_c_a03,biog1_o_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,pcg1_b_c_a04,pcg2_b_c_a04,pcg1_b_o_a04,pcg2_b_o_a04,opcg1_b_c_a04,opcg1_b_o_a04,pcg1_f_c_a04,pcg2_f_c_a04,pcg1_f_o_a04,pcg2_f_o_a04,opcg1_f_c_a04,opcg1_f_o_a04,ant1_c_a04,ant1_o_a04,biog1_c_a04,biog1_o_a04,num_a04,ca_a01,ca_a02,ca_a03,ca_a04,co3_a01,co3_a02,co3_a03,co3_a04 # using an empirical soa scheme for anthropogenic and biomass burning sources -package mozart_mosaic_4bin_vbs0_kpp chem_opt==201 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,c10h16,terpo2,tol,cres,to2,xoh,onit,isopn,dms,nh3,nume,den,voca,vocbb,smpa,smpbb,biog1_c,biog1_o,meko2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,smpa_a01,smpbb_a01,biog1_c_a01,biog1_o_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,smpa_a02,smpbb_a02,biog1_c_a02,biog1_o_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,smpa_a03,smpbb_a03,biog1_c_a03,biog1_o_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,smpa_a04,smpbb_a04,biog1_c_a04,biog1_o_a04,num_a04,ca_a01,ca_a02,ca_a03,ca_a04,co3_a01,co3_a02,co3_a03,co3_a04 +#package mozart_mosaic_4bin_vbs0_kpp chem_opt==201 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,c10h16,terpo2,tol,cres,to2,xoh,onit,isopn,dms,nh3,nume,den,voca,vocbb,smpa,smpbb,biog1_c,biog1_o,meko2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,smpa_a01,smpbb_a01,biog1_c_a01,biog1_o_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,smpa_a02,smpbb_a02,biog1_c_a02,biog1_o_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,smpa_a03,smpbb_a03,biog1_c_a03,biog1_o_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,smpa_a04,smpbb_a04,biog1_c_a04,biog1_o_a04,num_a04,ca_a01,ca_a02,ca_a03,ca_a04,co3_a01,co3_a02,co3_a03,co3_a04 +package mozart_mosaic_4bin_kpp chem_opt==201 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,hcooh,c2h2,hoch2oo,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,apin,bpin,limon,myrc,bcary,terprod1,terprod2,terp2o2,terp2ooh,nterpo2,terpo2,tol,cres,to2,onit,isopn,dms,mbo,mboo2,hmprop,hmpropo2,mboooh,mbono3o2,nh3,nume,den,voca,vocbb,smpa,smpbb,biog1_c,biog1_o,benzene,phen,bepomuc,benzo2,pheno2,pheno,phenooh,c6h5o2,c6h5ooh,benzooh,bigald1,bigald2,bigald3,bigald4,malo2,tepomuc,bzoo,bzooh,bald,acbzo2,dicarbo2,mdialo2,xyl,xylol,xylolo2,xylolooh,xyleno2,xylenooh,pbznit,hono,meko2,so4_a01,no3_a01,smpa_a01,smpbb_a01,glysoa_sfc_a01,biog1_c_a01,biog1_o_a01,cl_a01,co3_a01,nh4_a01,na_a01,ca_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,smpa_a02,smpbb_a02,glysoa_sfc_a02,biog1_c_a02,biog1_o_a02,cl_a02,co3_a02,nh4_a02,na_a02,ca_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,smpa_a03,smpbb_a03,glysoa_sfc_a03,biog1_c_a03,biog1_o_a03,cl_a03,co3_a03,nh4_a03,na_a03,ca_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,smpa_a04,smpbb_a04,glysoa_sfc_a04,biog1_c_a04,biog1_o_a04,cl_a04,co3_a04,nh4_a04,na_a04,ca_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04 +# complete aq-phase chem. and wet scavenging version with MOZART, HONO, VOC reactivity + VBS SOA +package mozart_mosaic_4bin_aq_kpp chem_opt==202 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,hcooh,c2h2,hoch2oo,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,apin,bpin,limon,myrc,bcary,terprod1,terprod2,terp2o2,terp2ooh,nterpo2,terpo2,tol,cres,to2,onit,isopn,dms,mbo,mboo2,hmprop,hmpropo2,mboooh,mbono3o2,nh3,nume,den,cvasoaX,cvasoa1,cvasoa2,cvasoa3,cvasoa4,cvbsoaX,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4,benzene,phen,bepomuc,benzo2,pheno2,pheno,phenooh,c6h5o2,c6h5ooh,benzooh,bigald1,bigald2,bigald3,bigald4,malo2,tepomuc,bzoo,bzooh,bald,acbzo2,dicarbo2,mdialo2,xyl,xylol,xylolo2,xylolooh,xyleno2,xylenooh,pbznit,hono,meko2,so4_a01,no3_a01,asoaX_a01,asoa1_a01,asoa2_a01,asoa3_a01,asoa4_a01,bsoaX_a01,bsoa1_a01,bsoa2_a01,bsoa3_a01,bsoa4_a01,glysoa_r1_a01,glysoa_r2_a01,glysoa_sfc_a01,glysoa_nh4_a01,glysoa_oh_a01,cl_a01,co3_a01,nh4_a01,na_a01,ca_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,asoaX_a02,asoa1_a02,asoa2_a02,asoa3_a02,asoa4_a02,bsoaX_a02,bsoa1_a02,bsoa2_a02,bsoa3_a02,bsoa4_a02,glysoa_r1_a02,glysoa_r2_a02,glysoa_sfc_a02,glysoa_nh4_a02,glysoa_oh_a02,cl_a02,co3_a02,nh4_a02,na_a02,ca_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,asoaX_a03,asoa1_a03,asoa2_a03,asoa3_a03,asoa4_a03,bsoaX_a03,bsoa1_a03,bsoa2_a03,bsoa3_a03,bsoa4_a03,glysoa_r1_a03,glysoa_r2_a03,glysoa_sfc_a03,glysoa_nh4_a03,glysoa_oh_a03,cl_a03,co3_a03,nh4_a03,na_a03,ca_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,asoaX_a04,asoa1_a04,asoa2_a04,asoa3_a04,asoa4_a04,bsoaX_a04,bsoa1_a04,bsoa2_a04,bsoa3_a04,bsoa4_a04,glysoa_r1_a04,glysoa_r2_a04,glysoa_sfc_a04,glysoa_nh4_a04,glysoa_oh_a04,cl_a04,co3_a04,nh4_a04,na_a04,ca_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_cw01,no3_cw01,asoaX_cw01,asoa1_cw01,asoa2_cw01,asoa3_cw01,asoa4_cw01,bsoaX_cw01,bsoa1_cw01,bsoa2_cw01,bsoa3_cw01,bsoa4_cw01,glysoa_r1_cw01,glysoa_r2_cw01,glysoa_sfc_cw01,glysoa_nh4_cw01,glysoa_oh_cw01,cl_cw01,co3_cw01,nh4_cw01,na_cw01,ca_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,asoaX_cw02,asoa1_cw02,asoa2_cw02,asoa3_cw02,asoa4_cw02,bsoaX_cw02,bsoa1_cw02,bsoa2_cw02,bsoa3_cw02,bsoa4_cw02,glysoa_r1_cw02,glysoa_r2_cw02,glysoa_sfc_cw02,glysoa_nh4_cw02,glysoa_oh_cw02,cl_cw02,co3_cw02,nh4_cw02,na_cw02,ca_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,asoaX_cw03,asoa1_cw03,asoa2_cw03,asoa3_cw03,asoa4_cw03,bsoaX_cw03,bsoa1_cw03,bsoa2_cw03,bsoa3_cw03,bsoa4_cw03,glysoa_r1_cw03,glysoa_r2_cw03,glysoa_sfc_cw03,glysoa_nh4_cw03,glysoa_oh_cw03,cl_cw03,co3_cw03,nh4_cw03,na_cw03,ca_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,asoaX_cw04,asoa1_cw04,asoa2_cw04,asoa3_cw04,asoa4_cw04,bsoaX_cw04,bsoa1_cw04,bsoa2_cw04,bsoa3_cw04,bsoa4_cw04,glysoa_r1_cw04,glysoa_r2_cw04,glysoa_sfc_cw04,glysoa_nh4_cw04,glysoa_oh_cw04,cl_cw04,co3_cw04,nh4_cw04,na_cw04,ca_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04,wd_so4_sc,wd_no3_sc,wd_nh4_sc,wd_oa_sc,wd_so4_cu,wd_no3_cu,wd_nh4_cu,wd_oa_cu + + +package saprc99_mosaic_8bin_vbs2_aq_kpp chem_opt==203 - chem:o3,h2o2,no,no2,no3,n2o5,hono,hno3,hno4,so2,h2so4,co,hcho,ccho,rcho,acet,mek,hcooh,meoh,etoh,cco_oh,rco_oh,gly,mgly,bacl,cres,bald,isoprod,methacro,mvk,prod2,dcb1,dcb2,dcb3,ethene,isoprene,c2h6,c3h8,c2h2,c3h6,alk3,alk4,alk5,aro1,aro2,ole1,ole2,terp,rno3,nphe,phen,pan,pan2,pbzn,ma_pan,co2,cco_ooh,rco_o2,rco_ooh,xn,xc,ho,ho2,c_o2,cooh,rooh,ro2_r,r2o2,ro2_n,cco_o2,bzco_o2,ma_rco3,sesq,pcg1_b_c,pcg2_b_c,pcg1_b_o,pcg2_b_o,opcg1_b_c,opcg1_b_o,pcg1_f_c,pcg2_f_c,pcg1_f_o,pcg2_f_o,opcg1_f_c,opcg1_f_o,psd1,psd2,nh3,hcl,nume,den,ant1_c,biog1_c,ch4,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,pcg1_b_c_a01,pcg1_b_o_a01,opcg1_b_c_a01,opcg1_b_o_a01,pcg1_f_c_a01,pcg1_f_o_a01,opcg1_f_c_a01,opcg1_f_o_a01,ant1_c_a01,biog1_c_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,pcg1_b_c_a02,pcg1_b_o_a02,opcg1_b_c_a02,opcg1_b_o_a02,pcg1_f_c_a02,pcg1_f_o_a02,opcg1_f_c_a02,opcg1_f_o_a02,ant1_c_a02,biog1_c_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,pcg1_b_c_a03,pcg1_b_o_a03,opcg1_b_c_a03,opcg1_b_o_a03,pcg1_f_c_a03,pcg1_f_o_a03,opcg1_f_c_a03,opcg1_f_o_a03,ant1_c_a03,biog1_c_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,pcg1_b_c_a04,pcg1_b_o_a04,opcg1_b_c_a04,opcg1_b_o_a04,pcg1_f_c_a04,pcg1_f_o_a04,opcg1_f_c_a04,opcg1_f_o_a04,ant1_c_a04,biog1_c_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,pcg1_b_c_a05,pcg1_b_o_a05,opcg1_b_c_a05,opcg1_b_o_a05,pcg1_f_c_a05,pcg1_f_o_a05,opcg1_f_c_a05,opcg1_f_o_a05,ant1_c_a05,biog1_c_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,pcg1_b_c_a06,pcg1_b_o_a06,opcg1_b_c_a06,opcg1_b_o_a06,pcg1_f_c_a06,pcg1_f_o_a06,opcg1_f_c_a06,opcg1_f_o_a06,ant1_c_a06,biog1_c_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,pcg1_b_c_a07,pcg1_b_o_a07,opcg1_b_c_a07,opcg1_b_o_a07,pcg1_f_c_a07,pcg1_f_o_a07,opcg1_f_c_a07,opcg1_f_o_a07,ant1_c_a07,biog1_c_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,pcg1_b_c_a08,pcg1_b_o_a08,opcg1_b_c_a08,opcg1_b_o_a08,pcg1_f_c_a08,pcg1_f_o_a08,opcg1_f_c_a08,opcg1_f_o_a08,ant1_c_a08,biog1_c_a08,num_a08,so4_cw01,no3_cw01,cl_cw01,nh4_cw01,na_cw01,oin_cw01,oc_cw01,bc_cw01,pcg1_b_c_cw01,pcg1_b_o_cw01,opcg1_b_c_cw01,opcg1_b_o_cw01,pcg1_f_c_cw01,pcg1_f_o_cw01,opcg1_f_c_cw01,opcg1_f_o_cw01,ant1_c_cw01,biog1_c_cw01,num_cw01,so4_cw02,no3_cw02,cl_cw02,nh4_cw02,na_cw02,oin_cw02,oc_cw02,bc_cw02,pcg1_b_c_cw02,pcg1_b_o_cw02,opcg1_b_c_cw02,opcg1_b_o_cw02,pcg1_f_c_cw02,pcg1_f_o_cw02,opcg1_f_c_cw02,opcg1_f_o_cw02,ant1_c_cw02,biog1_c_cw02,num_cw02,so4_cw03,no3_cw03,cl_cw03,nh4_cw03,na_cw03,oin_cw03,oc_cw03,bc_cw03,pcg1_b_c_cw03,pcg1_b_o_cw03,opcg1_b_c_cw03,opcg1_b_o_cw03,pcg1_f_c_cw03,pcg1_f_o_cw03,opcg1_f_c_cw03,opcg1_f_o_cw03,ant1_c_cw03,biog1_c_cw03,num_cw03,so4_cw04,no3_cw04,cl_cw04,nh4_cw04,na_cw04,oin_cw04,oc_cw04,bc_cw04,pcg1_b_c_cw04,pcg1_b_o_cw04,opcg1_b_c_cw04,opcg1_b_o_cw04,pcg1_f_c_cw04,pcg1_f_o_cw04,opcg1_f_c_cw04,opcg1_f_o_cw04,ant1_c_cw04,biog1_c_cw04,num_cw04,so4_cw05,no3_cw05,cl_cw05,nh4_cw05,na_cw05,oin_cw05,oc_cw05,bc_cw05,pcg1_b_c_cw05,pcg1_b_o_cw05,opcg1_b_c_cw05,opcg1_b_o_cw05,pcg1_f_c_cw05,pcg1_f_o_cw05,opcg1_f_c_cw05,opcg1_f_o_cw05,ant1_c_cw05,biog1_c_cw05,num_cw05,so4_cw06,no3_cw06,cl_cw06,nh4_cw06,na_cw06,oin_cw06,oc_cw06,bc_cw06,pcg1_b_c_cw06,pcg1_b_o_cw06,opcg1_b_c_cw06,opcg1_b_o_cw06,pcg1_f_c_cw06,pcg1_f_o_cw06,opcg1_f_c_cw06,opcg1_f_o_cw06,ant1_c_cw06,biog1_c_cw06,num_cw06,so4_cw07,no3_cw07,cl_cw07,nh4_cw07,na_cw07,oin_cw07,oc_cw07,bc_cw07,pcg1_b_c_cw07,pcg1_b_o_cw07,opcg1_b_c_cw07,opcg1_b_o_cw07,pcg1_f_c_cw07,pcg1_f_o_cw07,opcg1_f_c_cw07,opcg1_f_o_cw07,ant1_c_cw07,biog1_c_cw07,num_cw07,so4_cw08,no3_cw08,cl_cw08,nh4_cw08,na_cw08,oin_cw08,oc_cw08,bc_cw08,pcg1_b_c_cw08,pcg1_b_o_cw08,opcg1_b_c_cw08,opcg1_b_o_cw08,pcg1_f_c_cw08,pcg1_f_o_cw08,opcg1_f_c_cw08,opcg1_f_o_cw08,ant1_c_cw08,biog1_c_cw08,num_cw08 + +package saprc99_mosaic_8bin_vbs2_kpp chem_opt==204 - chem:o3,h2o2,no,no2,no3,n2o5,hono,hno3,hno4,so2,h2so4,co,hcho,ccho,rcho,acet,mek,hcooh,meoh,etoh,cco_oh,rco_oh,gly,mgly,bacl,cres,bald,isoprod,methacro,mvk,prod2,dcb1,dcb2,dcb3,ethene,isoprene,c2h6,c3h8,c2h2,c3h6,alk3,alk4,alk5,aro1,aro2,ole1,ole2,terp,rno3,nphe,phen,pan,pan2,pbzn,ma_pan,co2,cco_ooh,rco_o2,rco_ooh,xn,xc,ho,ho2,c_o2,cooh,rooh,ro2_r,r2o2,ro2_n,cco_o2,bzco_o2,ma_rco3,sesq,pcg1_b_c,pcg2_b_c,pcg1_b_o,pcg2_b_o,opcg1_b_c,opcg1_b_o,pcg1_f_c,pcg2_f_c,pcg1_f_o,pcg2_f_o,opcg1_f_c,opcg1_f_o,psd1,psd2,nh3,hcl,nume,den,ant1_c,biog1_c,ant2_c,biog2_c,biog3_c,biog1_o,biog2_o,ant3_c,ant4_c,bgas,agas,ch4,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,pcg1_b_c_a01,pcg1_b_o_a01,opcg1_b_c_a01,opcg1_b_o_a01,pcg1_f_c_a01,pcg1_f_o_a01,opcg1_f_c_a01,opcg1_f_o_a01,ant1_c_a01,biog1_c_a01,ant2_c_a01,biog2_c_a01,biog3_c_a01,biog1_o_a01,biog2_o_a01,ant3_c_a01,ant4_c_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,pcg1_b_c_a02,pcg1_b_o_a02,opcg1_b_c_a02,opcg1_b_o_a02,pcg1_f_c_a02,pcg1_f_o_a02,opcg1_f_c_a02,opcg1_f_o_a02,ant1_c_a02,biog1_c_a02,ant2_c_a02,biog2_c_a02,biog3_c_a02,biog1_o_a02,biog2_o_a02,ant3_c_a02,ant4_c_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,pcg1_b_c_a03,pcg1_b_o_a03,opcg1_b_c_a03,opcg1_b_o_a03,pcg1_f_c_a03,pcg1_f_o_a03,opcg1_f_c_a03,opcg1_f_o_a03,ant1_c_a03,biog1_c_a03,ant2_c_a03,biog2_c_a03,biog3_c_a03,biog1_o_a03,biog2_o_a03,ant3_c_a03,ant4_c_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,pcg1_b_c_a04,pcg1_b_o_a04,opcg1_b_c_a04,opcg1_b_o_a04,pcg1_f_c_a04,pcg1_f_o_a04,opcg1_f_c_a04,opcg1_f_o_a04,ant1_c_a04,biog1_c_a04,ant2_c_a04,biog2_c_a04,biog3_c_a04,biog1_o_a04,biog2_o_a04,ant3_c_a04,ant4_c_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,pcg1_b_c_a05,pcg1_b_o_a05,opcg1_b_c_a05,opcg1_b_o_a05,pcg1_f_c_a05,pcg1_f_o_a05,opcg1_f_c_a05,opcg1_f_o_a05,ant1_c_a05,biog1_c_a05,ant2_c_a05,biog2_c_a05,biog3_c_a05,biog1_o_a05,biog2_o_a05,ant3_c_a05,ant4_c_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,pcg1_b_c_a06,pcg1_b_o_a06,opcg1_b_c_a06,opcg1_b_o_a06,pcg1_f_c_a06,pcg1_f_o_a06,opcg1_f_c_a06,opcg1_f_o_a06,ant1_c_a06,biog1_c_a06,ant2_c_a06,biog2_c_a06,biog3_c_a06,biog1_o_a06,biog2_o_a06,ant3_c_a06,ant4_c_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,pcg1_b_c_a07,pcg1_b_o_a07,opcg1_b_c_a07,opcg1_b_o_a07,pcg1_f_c_a07,pcg1_f_o_a07,opcg1_f_c_a07,opcg1_f_o_a07,ant1_c_a07,biog1_c_a07,ant2_c_a07,biog2_c_a07,biog3_c_a07,biog1_o_a07,biog2_o_a07,ant3_c_a07,ant4_c_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,pcg1_b_c_a08,pcg1_b_o_a08,opcg1_b_c_a08,opcg1_b_o_a08,pcg1_f_c_a08,pcg1_f_o_a08,opcg1_f_c_a08,opcg1_f_o_a08,ant1_c_a08,biog1_c_a08,ant2_c_a08,biog2_c_a08,biog3_c_a08,biog1_o_a08,biog2_o_a08,ant3_c_a08,ant4_c_a08,num_a08 + + + + + + + + # KPP mechanism from MATCH-MPI Mainz used for global chemistry package nmhc9_kpp chem_opt==200 - chem:o3,h2o2,ch4,op1,hcho,ch3oh,co,hno3,no3,n2o5,hno4,no,no2,isopr,mvk,iso2,isooh,mvko2,mvkooh,ison,aca,acol,hcooh,mpan,naca,pan,pa,paa,mglo,c2h6,eTooh,ald,c3h8,pRooh,acet,acooh,eTo2,pRo2,aco2,c3h6,c3h6ooh,c2h4,c4h10,buooh,mek,mekooh,mEcoco,c3h6o2,c4h9o2,meko2,onit,pRono2,ch3o2,acetol,acetp,aceto2,ch3cooh,c4h9ooh,mEoh,ho,ho2,mEo2,mEo2no2 @@ -2921,8 +3902,6 @@ package gocart_simple chem_opt==300 - chem:s package gocartracm_kpp chem_opt==301 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,ho,ho2,dms,msa,p25,bc1,bc2,oc1,oc2,dust_1,dust_2,dust_3,dust_4,dust_5,seas_1,seas_2,seas_3,seas_4,p10 -package gocartradm2_kpp chem_opt==302 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,ho,ho2,dms,msa,p25,bc1,bc2,oc1,oc2,dust_1,dust_2,dust_3,dust_4,dust_5,seas_1,seas_2,seas_3,seas_4,p10 - package gocartradm2 chem_opt==303 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,hcl,ho,ho2,dms,msa,p25,bc1,bc2,oc1,oc2,dust_1,dust_2,dust_3,dust_4,dust_5,seas_1,seas_2,seas_3,seas_4,p10 # volcanic ash for ash-fall and conc prediction, not other aerosols in this option (so for other "400" options) @@ -2966,8 +3945,13 @@ package mozem emiss_opt==7 - emis_ant: package mozcem emiss_opt==8 - emis_ant:e_co,e_no,e_no2,e_bigalk,e_bigene,e_c2h4,e_c2h5oh,e_c2h6,e_c3h6,e_c3h8,e_ch2o,e_ch3cho,e_ch3coch3,e_ch3oh,e_mek,e_so2,e_toluene,e_nh3,e_isop,e_c10h16,e_pm_10,e_pm_25,e_bc,e_oc,e_sulf package cammam emiss_opt==9 - emis_ant:e_iso,e_so2,e_no,e_co,e_eth,e_hc3,e_hc5,e_hc8,e_xyl,e_ol2,e_olt,e_oli,e_tol,e_csl,e_hcho,e_ald,e_ket,e_ora2,e_nh3,e_dms,e_ecj,e_orgj,e_so4i,e_so4j,e_soag_bigene,e_soag_isoprene,e_soag_terpene,e_soag_toluene,e_dust_a1,e_dust_a3,e_ncl_a1,e_ncl_a2,e_ncl_a3,e_orgj_num,e_ecj_num,e_so4j_num,e_so4i_num -package mozmem emiss_opt==10 - emis_ant:e_co,e_no,e_no2,e_bigalk,e_bigene,e_c2h4,e_c2h5oh,e_c2h6,e_c3h6,e_c3h8,e_ch2o,e_ch3cho,e_ch3coch3,e_ch3oh,e_mek,e_so2,e_toluene,e_nh3,e_isop,e_c10h16,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_co_a,e_orgj_a,e_co_bb,e_orgj_bb,e_voca,e_vocbb +package mozmem emiss_opt==10 - emis_ant:e_co,e_no,e_no2,e_bigalk,e_bigene,e_c2h4,e_c2h5oh,e_c2h6,e_c3h6,e_c3h8,e_ch2o,e_ch3cho,e_ch3coch3,e_ch3oh,e_mek,e_so2,e_toluene,e_benzene,e_xylene,e_nh3,e_isop,e_c10h16,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_nh4i,e_nh4j,e_nai,e_naj,e_cli,e_clj,e_co_a,e_orgi_a,e_orgj_a,e_co_bb,e_orgi_bb,e_orgj_bb,e_pm_10,e_c2h2,e_gly,e_sulf,e_macr,e_mgly,e_mvk,e_hcooh,e_hono package esaprcnov emiss_opt==13 - emis_ant:e_so2,e_c2h6,e_c3h8,e_c2h2,e_alk3,e_alk4,e_alk5,e_ethene,e_c3h6,e_ole1,e_ole2,e_aro1,e_aro2,e_hcho,e_ccho,e_rcho,e_acet,e_mek,e_isoprene,e_terp,e_sesq,e_co,e_no,e_no2,e_phen,e_cres,e_meoh,e_gly,e_mgly,e_bacl,e_isoprod,e_methacro,e_mvk,e_prod2,e_ch4,e_bald,e_hcooh,e_cco_oh,e_rco_oh,e_nh3,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_orgi_a,e_orgj_a,e_orgi_bb,e_orgj_bb +# For CB05 mechanism based on CBMZ speciation, used with emiss_inpt_opt = 102 +package ecb05_opt1 emiss_opt==14 - emis_ant:e_no2,e_xyl,e_tol,e_terp,e_so2,e_ora2,e_olt,e_oli,e_ol2,e_no,e_nh3,e_iso,e_hcl,e_hcho,e_eth,e_csl,e_co,e_ch3oh,e_c2h5oh,e_ald,e_aldx,e_hc3,e_hc5,e_hc8,e_ket,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_so4c,e_no3c,e_orgc,e_ecc,e_pm10 +# For CB05 emissions inventory base on CB05 speciation, used with emiss_inpt_opt = 101 +package ecb05_opt2 emiss_opt==15 - emis_ant:e_acet,e_par,e_alk1,e_alk2,e_alk3,e_alk4,e_alk5,e_tol,e_xyl,e_bald,e_ald2,e_ccooh,e_co,e_cres,e_eth,e_etha,e_gly,e_form,e_hcooh,e_iprod,e_isop,e_macr,e_mek,e_meoh,e_meo2,e_etoh,e_mgly,e_nh3,e_hcl,e_no,e_no2,e_iole,e_ole,e_phen,e_prod2,e_aldx,e_rcooh,e_so2,e_psulf,e_terp,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_so4c,e_no3c,e_orgc,e_ecc,e_pm10 + # Anthropogenic CO2, CO and CH4 emissions: package eco2 emiss_opt==16 - emis_ant:e_co2,e_co2tst,e_co package eghg emiss_opt==17 - emis_ant:e_co2,e_co2tst,e_co,e_cotst,e_ch4,e_ch4tst @@ -2990,9 +3974,7 @@ package wesely gas_drydep_opt==1 - - # # diagnostic packages, first for deposition velocities (original package for Mozart) # -# 20130925 acd_ck_bugfix start -package depvel1 diagnostic_chem==1 - dvel:dvel_o3,dvel_no,dvel_no2,dvel_nh3,dvel_hno3,dvel_hno4,dvel_h2o2,dvel_co,dvel_ch3ooh,dvel_hcho,dvel_ch3oh,dvel_eo2,dvel_ald,dvel_ch3cooh,dvel_acet,dvel_mgly,dvel_gly,dvel_paa,dvel_pooh,dvel_pan,dvel_mpan,dvel_mco3,dvel_mvkooh,dvel_c2h5oh,dvel_etooh,dvel_prooh,dvel_acetp,dvel_onit,dvel_onitr,dvel_isooh,dvel_acetol,dvel_glyald,dvel_hydrald,dvel_alkooh,dvel_mekooh,dvel_tolooh,dvel_xooh,dvel_so2,dvel_so4,dvel_terpooh -# 20130925 acd_ck_bugfix end +package depvel1 diagnostic_chem==1 - dvel:dvel_o3,dvel_no,dvel_no2,dvel_nh3,dvel_hno3,dvel_hno4,dvel_h2o2,dvel_co,dvel_ch3ooh,dvel_hcho,dvel_ch3oh,dvel_eo2,dvel_ald,dvel_ch3cooh,dvel_acet,dvel_mgly,dvel_gly,dvel_paa,dvel_pooh,dvel_pan,dvel_mpan,dvel_mco3,dvel_mvkooh,dvel_c2h5oh,dvel_etooh,dvel_prooh,dvel_acetp,dvel_onit,dvel_onitr,dvel_isooh,dvel_acetol,dvel_glyald,dvel_hydrald,dvel_alkooh,dvel_mekooh,dvel_tolooh,dvel_xooh,dvel_so2,dvel_so4,dvel_terpooh,dvel_cvasoaX,dvel_cvasoa1,dvel_cvasoa2,dvel_cvasoa3,dvel_cvasoa4,dvel_cvbsoaX,dvel_cvbsoa1,dvel_cvbsoa2,dvel_cvbsoa3,dvel_cvbsoa4,ddmass_o3,ddmass_no,ddmass_no2,ddmass_nh3,ddmass_hno3,ddmass_hno4,ddmass_h2o2,ddmass_co,ddmass_ch3ooh,ddmass_hcho,ddmass_ch3oh,ddmass_eo2,ddmass_ald,ddmass_ch3cooh,ddmass_acet,ddmass_mgly,ddmass_gly,ddmass_paa,ddmass_pooh,ddmass_pan,ddmass_mpan,ddmass_mco3,ddmass_mvkooh,ddmass_c2h5oh,ddmass_etooh,ddmass_prooh,ddmass_acetp,ddmass_onit,ddmass_onitr,ddmass_isooh,ddmass_acetol,ddmass_glyald,ddmass_hydrald,ddmass_alkooh,ddmass_mekooh,ddmass_tolooh,ddmass_xooh,ddmass_so2,ddmass_so4,ddmass_terpooh,ddmass_cvasoaX,ddmass_cvasoa1,ddmass_cvasoa2,ddmass_cvasoa3,ddmass_cvasoa4,ddmass_cvbsoaX,ddmass_cvbsoa1,ddmass_cvbsoa2,ddmass_cvbsoa3,ddmass_cvbsoa4,ddmass_so4_a01,ddmass_no3_a01,ddmass_cl_a01,ddmass_nh4_a01,ddmass_na_a01,ddmass_oin_a01,ddmass_oc_a01,ddmass_bc_a01,ddmass_smpa_a01,ddmass_smpbb_a01,ddmass_glysoa_a01,ddmass_biog1_c_a01,ddmass_biog1_o_a01,ddmass_asoaX_a01,ddmass_asoa1_a01,ddmass_asoa2_a01,ddmass_asoa3_a01,ddmass_asoa4_a01,ddmass_bsoaX_a01,ddmass_bsoa1_a01,ddmass_bsoa2_a01,ddmass_bsoa3_a01,ddmass_bsoa4_a01,ddmass_so4_a02,ddmass_no3_a02,ddmass_cl_a02,ddmass_nh4_a02,ddmass_na_a02,ddmass_oin_a02,ddmass_oc_a02,ddmass_bc_a02,ddmass_smpa_a02,ddmass_smpbb_a02,ddmass_glysoa_a02,ddmass_biog1_c_a02,ddmass_biog1_o_a02,ddmass_asoaX_a02,ddmass_asoa1_a02,ddmass_asoa2_a02,ddmass_asoa3_a02,ddmass_asoa4_a02,ddmass_bsoaX_a02,ddmass_bsoa1_a02,ddmass_bsoa2_a02,ddmass_bsoa3_a02,ddmass_bsoa4_a02,ddmass_so4_a03,ddmass_no3_a03,ddmass_cl_a03,ddmass_nh4_a03,ddmass_na_a03,ddmass_oin_a03,ddmass_oc_a03,ddmass_bc_a03,ddmass_smpa_a03,ddmass_smpbb_a03,ddmass_glysoa_a03,ddmass_biog1_c_a03,ddmass_biog1_o_a03,ddmass_asoaX_a03,ddmass_asoa1_a03,ddmass_asoa2_a03,ddmass_asoa3_a03,ddmass_asoa4_a03,ddmass_bsoaX_a03,ddmass_bsoa1_a03,ddmass_bsoa2_a03,ddmass_bsoa3_a03,ddmass_bsoa4_a03,ddmass_so4_a04,ddmass_no3_a04,ddmass_cl_a04,ddmass_nh4_a04,ddmass_na_a04,ddmass_oin_a04,ddmass_oc_a04,ddmass_bc_a04,ddmass_smpa_a04,ddmass_smpbb_a04,ddmass_glysoa_a04,ddmass_biog1_c_a04,ddmass_biog1_o_a04,ddmass_asoaX_a04,ddmass_asoa1_a04,ddmass_asoa2_a04,ddmass_asoa3_a04,ddmass_asoa4_a04,ddmass_bsoaX_a04,ddmass_bsoa1_a04,ddmass_bsoa2_a04,ddmass_bsoa3_a04,ddmass_bsoa4_a04,ddmass_ca_a01,ddmass_ca_a02,ddmass_ca_a03,ddmass_ca_a04,ddmass_co3_a01,ddmass_co3_a02,ddmass_co3_a03,ddmass_co3_a04,ddmass_so4_cw01,ddmass_no3_cw01,ddmass_cl_cw01,ddmass_nh4_cw01,ddmass_na_cw01,ddmass_oin_cw01,ddmass_oc_cw01,ddmass_bc_cw01,ddmass_smpa_cw01,ddmass_smpbb_cw01,ddmass_glysoa_cw01,ddmass_biog1_c_cw01,ddmass_biog1_o_cw01,ddmass_asoaX_cw01,ddmass_asoa1_cw01,ddmass_asoa2_cw01,ddmass_asoa3_cw01,ddmass_asoa4_cw01,ddmass_bsoaX_cw01,ddmass_bsoa1_cw01,ddmass_bsoa2_cw01,ddmass_bsoa3_cw01,ddmass_bsoa4_cw01,ddmass_so4_cw02,ddmass_no3_cw02,ddmass_cl_cw02,ddmass_nh4_cw02,ddmass_na_cw02,ddmass_oin_cw02,ddmass_oc_cw02,ddmass_bc_cw02,ddmass_smpa_cw02,ddmass_smpbb_cw02,ddmass_glysoa_cw02,ddmass_biog1_c_cw02,ddmass_biog1_o_cw02,ddmass_asoaX_cw02,ddmass_asoa1_cw02,ddmass_asoa2_cw02,ddmass_asoa3_cw02,ddmass_asoa4_cw02,ddmass_bsoaX_cw02,ddmass_bsoa1_cw02,ddmass_bsoa2_cw02,ddmass_bsoa3_cw02,ddmass_bsoa4_cw02,ddmass_so4_cw03,ddmass_no3_cw03,ddmass_cl_cw03,ddmass_nh4_cw03,ddmass_na_cw03,ddmass_oin_cw03,ddmass_oc_cw03,ddmass_bc_cw03,ddmass_smpa_cw03,ddmass_smpbb_cw03,ddmass_glysoa_cw03,ddmass_biog1_c_cw03,ddmass_biog1_o_cw03,ddmass_asoaX_cw03,ddmass_asoa1_cw03,ddmass_asoa2_cw03,ddmass_asoa3_cw03,ddmass_asoa4_cw03,ddmass_bsoaX_cw03,ddmass_bsoa1_cw03,ddmass_bsoa2_cw03,ddmass_bsoa3_cw03,ddmass_bsoa4_cw03,ddmass_so4_cw04,ddmass_no3_cw04,ddmass_cl_cw04,ddmass_nh4_cw04,ddmass_na_cw04,ddmass_oin_cw04,ddmass_oc_cw04,ddmass_bc_cw04,ddmass_smpa_cw04,ddmass_smpbb_cw04,ddmass_glysoa_cw04,ddmass_biog1_c_cw04,ddmass_biog1_o_cw04,ddmass_asoaX_cw04,ddmass_asoa1_cw04,ddmass_asoa2_cw04,ddmass_asoa3_cw04,ddmass_asoa4_cw04,ddmass_bsoaX_cw04,ddmass_bsoa1_cw04,ddmass_bsoa2_cw04,ddmass_bsoa3_cw04,ddmass_bsoa4_cw04,ddmass_ca_cw01,ddmass_ca_cw02,ddmass_ca_cw03,ddmass_ca_cw04,ddmass_co3_cw01,ddmass_co3_cw02,ddmass_co3_cw03,ddmass_co3_cw04 # package gunther1 bio_emiss_opt==1 - - package beis314 bio_emiss_opt==2 - - @@ -3015,12 +3997,13 @@ package opt_out opt_pars_out==1 - ext_coef:extcof3,e # dust and sea salt packages package dustgocart dust_opt==1 - emis_dust:edust1,edust2,edust3,edust4,edust5 -package dustgocartafwa dust_opt==3 - emis_dust:edust1,edust2,edust3,edust4,edust5 +package dustgocartafwa dust_opt==3 - emis_dust:edust1,edust2,edust3,edust4,edust5;state:afwa_dustloft,tot_dust,tot_edust,vis_dust package dustuoc dust_opt==4 - emis_dust:edust1,edust2,edust3,edust4,edust5 package shao_2001 dust_schme==1 - emis_dust:edust1,edust2,edust3,edust4,edust5 package shao_2004 dust_schme==2 - emis_dust:edust1,edust2,edust3,edust4,edust5 package shao_2011 dust_schme==3 - emis_dust:edust1,edust2,edust3,edust4,edust5 package seasgocart seas_opt==1 - emis_seas:eseas1,eseas2,eseas3,eseas4 +package seasmosaic seas_opt==2 - emis_seas2:eseasj,eseasc package dmsgocart dmsemis_opt==1 - - package volume_approx aer_op_opt==1 - - package maxwell_approx aer_op_opt==2 - - @@ -3040,7 +4023,6 @@ package emiss_inpt_pnnl_rs emiss_inpt_opt==102 - package emiss_inpt_cb4 emiss_inpt_opt==103 - - package emiss_inpt_pnnl_mam emiss_inpt_opt==104 - - package emiss_inpt_mozcem emiss_inpt_opt==111 - - -package emiss_inpt_mozmem emiss_inpt_opt==112 - - package emiss_inpt_tno emiss_inpt_opt==121 - - diff --git a/wrfv2_fire/Registry/registry.diags b/wrfv2_fire/Registry/registry.diags index 39619efa..4e155f68 100644 --- a/wrfv2_fire/Registry/registry.diags +++ b/wrfv2_fire/Registry/registry.diags @@ -12,6 +12,7 @@ rconfig integer p_lev_diags_dfi namelist,diags 1 0 - rconfig integer num_press_levels namelist,diags 1 0 - "number of pressure levels to interpolate diagnostics to" "index" rconfig real press_levels namelist,diags max_plevs 0 - "array of pressure levels to interpolate diagnostics to" "Pa" rconfig integer use_tot_or_hyd_p namelist,diags 1 2 - "1=use total pressure, 2=use hydrostatic pressure" "flag" +rconfig integer extrap_below_grnd namelist,diags 1 1 - "1=no extrapolation, 2=extrapolate adiabatically" "flag" rconfig real p_lev_missing namelist,diags 1 -999 - "missing values below ground, no extrapolation" "constant" # Derived, this is interval in seconds that is from auxhist23 interval, computed in check_a_mundo @@ -28,8 +29,9 @@ state real rh_pl i{np}j misc 1 Z h{23} "RH_PL" "Pressure level state real ght_pl i{np}j misc 1 Z h{23} "GHT_PL" "Pressure level data, Geopotential Height" "m" state real s_pl i{np}j misc 1 Z h{23} "S_PL" "Pressure level data, Speed" "m s-1" state real td_pl i{np}j misc 1 Z h{23} "TD_PL" "Pressure level data, Dew point temperature" "K" +state real q_pl i{np}j misc 1 Z h{23} "Q_PL" "Pressure level data, Mixing ratio" "kg/kg" # Package declarations package skip_press_diags p_lev_diags==0 - - -package press_diags p_lev_diags==1 - state:p_pl,u_pl,v_pl,t_pl,rh_pl,ght_pl,s_pl,td_pl +package press_diags p_lev_diags==1 - state:p_pl,u_pl,v_pl,t_pl,rh_pl,ght_pl,s_pl,td_pl,q_pl diff --git a/wrfv2_fire/Registry/registry.dimspec b/wrfv2_fire/Registry/registry.dimspec index a212c6bf..fe86cdd0 100644 --- a/wrfv2_fire/Registry/registry.dimspec +++ b/wrfv2_fire/Registry/registry.dimspec @@ -9,6 +9,7 @@ dimspec 4 2 namelist=maxpatch z subgrid ifdef EM_CORE=1 ifdef DA_CORE=0 +dimspec stoclev 2 namelist=num_stoch_levels z num_stoch_levels dimspec j 3 standard_domain y south_north dimspec k 2 standard_domain z bottom_top endif @@ -41,6 +42,9 @@ dimspec q - constant=2600 c # a little crud dimspec r - constant=2000 c # a little crude right now dimspec z - constant=(-3:3) c dimspec n - constant=(0:6) c +ifdef HWRF=1 +dimspec otrak - namelist=num_old_fixes c old_fixes +endif endif dimspec snly 2 namelist=num_snow_layers z snow_layers @@ -86,6 +90,7 @@ dimspec ] 2 namelist=kfire z klevs_for_fire dimspec % 2 namelist=kdvel z klevs_for_dvel dimspec airc 2 namelist=kemit_aircraft z ac_emissions_zdim dimspec . 3 namelist=erosion_dim z dust_erosion_dimension +dimspec ^ 2 constant=46 z eightday_dimension # Dimensions for the GHG options dimspec ghgv - constant=8 z vprm_vgcls diff --git a/wrfv2_fire/Registry/registry.lake b/wrfv2_fire/Registry/registry.lake index fd69b817..fbd7fdd3 100644 --- a/wrfv2_fire/Registry/registry.lake +++ b/wrfv2_fire/Registry/registry.lake @@ -1,28 +1,28 @@ # Lake variables state logical lake2d ij misc 1 - - "lake2d" "T/F: whether grid is lake" -state real lakedepth2d ij misc 1 - rh "lakedepth2d" "lake depth" "m" -state real savedtke12d ij misc 1 - irh "savedtke12d" "top level eddy conductivity from previous timestep" "W/m.K" -state real snowdp2d ij misc 1 - irh "snowdp2d" "snow depth" "m" -state real h2osno2d ij misc 1 - irh "h2osno2d" "snow water" "mm" -state real snl2d ij misc 1 - irh "snl2d" "number of snow layers" -state real t_grnd2d ij misc 1 - irh "t_grnd2d" "ground temperature" "k" -state real t_lake3d i{lake_sll}j misc 1 z irh "t_lake3d" "lake temperature" "k" -state real lake_icefrac3d i{lake_sll}j misc 1 z irh "lake_icefrac3d" "mass fraction of lake layer that is frozen" -state real z_lake3d i{lake_sll}j misc 1 z irh "z_lake3d" "layer depth for lake" "m" -state real dz_lake3d i{lake_sll}j misc 1 z irh "dz_lake3d" "layer thickness for lake" "m" -state real t_soisno3d i{lake_ssl}j misc 1 z irh "t_soisno3d" "soil (or snow) temperature" "m" -state real h2osoi_ice3d i{lake_ssl}j misc 1 z irh "h2osoi_ice3d" "ice lens" "kg/m2" -state real h2osoi_liq3d i{lake_ssl}j misc 1 z irh "h2osoi_liq3d" "liquid water" "kg/m2" -state real h2osoi_vol3d i{lake_ssl}j misc 1 z irh "h2osoi_vol3d" "volumetric soil water (0<=h2osoi_vol<=watsat)" "m3/m3" -state real z3d i{lake_ssl}j misc 1 z irh "z3d" "layer depth for snow & soil" "m" -state real dz3d i{lake_ssl}j misc 1 z irh "dz3d" "layer thickness for soil or snow" "m" -state real zi3d i{lake_intl}j misc 1 z irh "zi3d" "interface level below a "z" level" "m" -state real watsat3d i{lake_sll}j misc 1 z irh "watsat3d" "volumetric soil water at saturation (porosity)" -state real csol3d i{lake_sll}j misc 1 z irh "csol3d" "heat capacity, soil solids" "J/m**3/Kelvin" -state real tkmg3d i{lake_sll}j misc 1 z irh "tkmg3d" "thermal conductivity, soil minerals" "W/m-K" -state real tkdry3d i{lake_sll}j misc 1 z irh "tkdry3d" "thermal conductivity, dry soil" "W/m/Kelvin" -state real tksatu3d i{lake_sll}j misc 1 z irh "tksatu3d" "thermal conductivity, saturated soil" "W/m-K" +state real lakedepth2d ij misc 1 - i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "lakedepth2d" "lake depth" "m" +state real savedtke12d ij misc 1 - i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "savedtke12d" "top level eddy conductivity from previous timestep" "W/m.K" +state real snowdp2d ij misc 1 - i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "snowdp2d" "snow depth" "m" +state real h2osno2d ij misc 1 - i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "h2osno2d" "snow water" "mm" +state real snl2d ij misc 1 - i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "snl2d" "number of snow layers" +state real t_grnd2d ij misc 1 - i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "t_grnd2d" "ground temperature" "k" +state real t_lake3d i{lake_sll}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "t_lake3d" "lake temperature" "k" +state real lake_icefrac3d i{lake_sll}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "lake_icefrac3d" "mass fraction of lake layer that is frozen" +state real z_lake3d i{lake_sll}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "z_lake3d" "layer depth for lake" "m" +state real dz_lake3d i{lake_sll}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "dz_lake3d" "layer thickness for lake" "m" +state real t_soisno3d i{lake_ssl}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "t_soisno3d" "soil (or snow) temperature" "m" +state real h2osoi_ice3d i{lake_ssl}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "h2osoi_ice3d" "ice lens" "kg/m2" +state real h2osoi_liq3d i{lake_ssl}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "h2osoi_liq3d" "liquid water" "kg/m2" +state real h2osoi_vol3d i{lake_ssl}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "h2osoi_vol3d" "volumetric soil water (0<=h2osoi_vol<=watsat)" "m3/m3" +state real z3d i{lake_ssl}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "z3d" "layer depth for snow & soil" "m" +state real dz3d i{lake_ssl}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "dz3d" "layer thickness for soil or snow" "m" +state real zi3d i{lake_intl}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "zi3d" "interface level below a "z" level" "m" +state real watsat3d i{lake_sll}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "watsat3d" "volumetric soil water at saturation (porosity)" +state real csol3d i{lake_sll}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "csol3d" "heat capacity, soil solids" "J/m**3/Kelvin" +state real tkmg3d i{lake_sll}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "tkmg3d" "thermal conductivity, soil minerals" "W/m-K" +state real tkdry3d i{lake_sll}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "tkdry3d" "thermal conductivity, dry soil" "W/m/Kelvin" +state real tksatu3d i{lake_sll}j misc 1 z i012rhd=(interp_mask_water_field:lu_index,islake)u=(copy_fcnm) "tksatu3d" "thermal conductivity, saturated soil" "W/m-K" state integer LAKEFLAG - misc 1 - i0 "LAKEFLAG" "Flag for lake in the global attributes for metgrid data" state integer LAKE_DEPTH_FLAG - misc 1 - i0 "LAKE_DEPTH_FLAG" "Flag for lakedepth in the global attributes for metgrid data" diff --git a/wrfv2_fire/Registry/registry.sbm b/wrfv2_fire/Registry/registry.sbm index 7c423c10..57790ad8 100644 --- a/wrfv2_fire/Registry/registry.sbm +++ b/wrfv2_fire/Registry/registry.sbm @@ -1,266 +1,269 @@ # SBM Scalars # state real - ikjftb scalar 1 - - - -state real ff1i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i01" "cloud/rain bin 1" "# kg kg^-1" -state real ff1i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i02" "cloud/rain bin 2" "# kg kg^-1" -state real ff1i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i03" "cloud/rain bin 3" "# kg kg^-1" -state real ff1i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i04" "cloud/rain bin 4" "# kg kg^-1" -state real ff1i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i05" "cloud/rain bin 5" "# kg kg^-1" -state real ff1i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i06" "cloud/rain bin 6" "# kg kg^-1" -state real ff1i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i07" "cloud/rain bin 7" "# kg kg^-1" -state real ff1i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i08" "cloud/rain bin 8" "# kg kg^-1" -state real ff1i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i09" "cloud/rain bin 9" "# kg kg^-1" -state real ff1i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i10" "cloud/rain bin 10" "# kg kg^-1" -state real ff1i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i11" "cloud/rain bin 11" "# kg kg^-1" -state real ff1i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i12" "cloud/rain bin 12" "# kg kg^-1" -state real ff1i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i13" "cloud/rain bin 13" "# kg kg^-1" -state real ff1i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i14" "cloud/rain bin 14" "# kg kg^-1" -state real ff1i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i15" "cloud/rain bin 15" "# kg kg^-1" -state real ff1i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i16" "cloud/rain bin 16" "# kg kg^-1" -state real ff1i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i17" "cloud/rain bin 17" "# kg kg^-1" -state real ff1i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i18" "cloud/rain bin 18" "# kg kg^-1" -state real ff1i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i19" "cloud/rain bin 19" "# kg kg^-1" -state real ff1i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i20" "cloud/rain bin 20" "# kg kg^-1" -state real ff1i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i21" "cloud/rain bin 21" "# kg kg^-1" -state real ff1i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i22" "cloud/rain bin 22" "# kg kg^-1" -state real ff1i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i23" "cloud/rain bin 23" "# kg kg^-1" -state real ff1i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i24" "cloud/rain bin 24" "# kg kg^-1" -state real ff1i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i25" "cloud/rain bin 25" "# kg kg^-1" -state real ff1i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i26" "cloud/rain bin 26" "# kg kg^-1" -state real ff1i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i27" "cloud/rain bin 27" "# kg kg^-1" -state real ff1i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i28" "cloud/rain bin 28" "# kg kg^-1" -state real ff1i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i29" "cloud/rain bin 29" "# kg kg^-1" -state real ff1i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i30" "cloud/rain bin 30" "# kg kg^-1" -state real ff1i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i31" "cloud/rain bin 31" "# kg kg^-1" -state real ff1i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i32" "cloud/rain bin 32" "# kg kg^-1" -state real ff1i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff1i33" "cloud/rain bin 33" "# kg kg^-1" -state real ff5i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i01" "snow bin 1" "# kg kg^-1" -state real ff5i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i02" "snow bin 2" "# kg kg^-1" -state real ff5i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i03" "snow bin 3" "# kg kg^-1" -state real ff5i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i04" "snow bin 4" "# kg kg^-1" -state real ff5i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i05" "snow bin 5" "# kg kg^-1" -state real ff5i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i06" "snow bin 6" "# kg kg^-1" -state real ff5i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i07" "snow bin 7" "# kg kg^-1" -state real ff5i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i08" "snow bin 8" "# kg kg^-1" -state real ff5i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i09" "snow bin 9" "# kg kg^-1" -state real ff5i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i10" "snow bin 10" "# kg kg^-1" -state real ff5i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i11" "snow bin 11" "# kg kg^-1" -state real ff5i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i12" "snow bin 12" "# kg kg^-1" -state real ff5i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i13" "snow bin 13" "# kg kg^-1" -state real ff5i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i14" "snow bin 14" "# kg kg^-1" -state real ff5i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i15" "snow bin 15" "# kg kg^-1" -state real ff5i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i16" "snow bin 16" "# kg kg^-1" -state real ff5i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i17" "snow bin 17" "# kg kg^-1" -state real ff5i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i18" "snow bin 18" "# kg kg^-1" -state real ff5i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i19" "snow bin 19" "# kg kg^-1" -state real ff5i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i20" "snow bin 20" "# kg kg^-1" -state real ff5i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i21" "snow bin 21" "# kg kg^-1" -state real ff5i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i22" "snow bin 22" "# kg kg^-1" -state real ff5i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i23" "snow bin 23" "# kg kg^-1" -state real ff5i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i24" "snow bin 24" "# kg kg^-1" -state real ff5i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i25" "snow bin 25" "# kg kg^-1" -state real ff5i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i26" "snow bin 26" "# kg kg^-1" -state real ff5i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i27" "snow bin 27" "# kg kg^-1" -state real ff5i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i28" "snow bin 28" "# kg kg^-1" -state real ff5i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i29" "snow bin 29" "# kg kg^-1" -state real ff5i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i30" "snow bin 30" "# kg kg^-1" -state real ff5i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i31" "snow bin 31" "# kg kg^-1" -state real ff5i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i32" "snow bin 32" "# kg kg^-1" -state real ff5i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff5i33" "snow bin 33" "# kg kg^-1" -state real ff6i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i01" "graupel bin 1" "# kg kg^-1" -state real ff6i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i02" "graupel bin 2" "# kg kg^-1" -state real ff6i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i03" "graupel bin 3" "# kg kg^-1" -state real ff6i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i04" "graupel bin 4" "# kg kg^-1" -state real ff6i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i05" "graupel bin 5" "# kg kg^-1" -state real ff6i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i06" "graupel bin 6" "# kg kg^-1" -state real ff6i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i07" "graupel bin 7" "# kg kg^-1" -state real ff6i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i08" "graupel bin 8" "# kg kg^-1" -state real ff6i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i09" "graupel bin 9" "# kg kg^-1" -state real ff6i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i10" "graupel bin 10" "# kg kg^-1" -state real ff6i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i11" "graupel bin 11" "# kg kg^-1" -state real ff6i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i12" "graupel bin 12" "# kg kg^-1" -state real ff6i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i13" "graupel bin 13" "# kg kg^-1" -state real ff6i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i14" "graupel bin 14" "# kg kg^-1" -state real ff6i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i15" "graupel bin 15" "# kg kg^-1" -state real ff6i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i16" "graupel bin 16" "# kg kg^-1" -state real ff6i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i17" "graupel bin 17" "# kg kg^-1" -state real ff6i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i18" "graupel bin 18" "# kg kg^-1" -state real ff6i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i19" "graupel bin 19" "# kg kg^-1" -state real ff6i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i20" "graupel bin 20" "# kg kg^-1" -state real ff6i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i21" "graupel bin 21" "# kg kg^-1" -state real ff6i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i22" "graupel bin 22" "# kg kg^-1" -state real ff6i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i23" "graupel bin 23" "# kg kg^-1" -state real ff6i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i24" "graupel bin 24" "# kg kg^-1" -state real ff6i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i25" "graupel bin 25" "# kg kg^-1" -state real ff6i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i26" "graupel bin 26" "# kg kg^-1" -state real ff6i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i27" "graupel bin 27" "# kg kg^-1" -state real ff6i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i28" "graupel bin 28" "# kg kg^-1" -state real ff6i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i29" "graupel bin 29" "# kg kg^-1" -state real ff6i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i30" "graupel bin 30" "# kg kg^-1" -state real ff6i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i31" "graupel bin 31" "# kg kg^-1" -state real ff6i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i32" "graupel bin 32" "# kg kg^-1" -state real ff6i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff6i33" "graupel bin 33" "# kg kg^-1" -state real ff8i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i01" "aerosols bin 1" "# kg^-1" -state real ff8i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i02" "aerosols bin 2" "# kg^-1" -state real ff8i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i03" "aerosols bin 3" "# kg^-1" -state real ff8i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i04" "aerosols bin 4" "# kg^-1" -state real ff8i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i05" "aerosols bin 5" "# kg^-1" -state real ff8i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i06" "aerosols bin 6" "# kg^-1" -state real ff8i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i07" "aerosols bin 7" "# kg^-1" -state real ff8i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i08" "aerosols bin 8" "# kg^-1" -state real ff8i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i09" "aerosols bin 9" "# kg^-1" -state real ff8i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i10" "aerosols bin 10" "# kg^-1" -state real ff8i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i11" "aerosols bin 11" "# kg^-1" -state real ff8i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i12" "aerosols bin 12" "# kg^-1" -state real ff8i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i13" "aerosols bin 13" "# kg^-1" -state real ff8i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i14" "aerosols bin 14" "# kg^-1" -state real ff8i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i15" "aerosols bin 15" "# kg^-1" -state real ff8i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i16" "aerosols bin 16" "# kg^-1" -state real ff8i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i17" "aerosols bin 17" "# kg^-1" -state real ff8i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i18" "aerosols bin 18" "# kg^-1" -state real ff8i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i19" "aerosols bin 19" "# kg^-1" -state real ff8i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i20" "aerosols bin 20" "# kg^-1" -state real ff8i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i21" "aerosols bin 21" "# kg^-1" -state real ff8i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i22" "aerosols bin 22" "# kg^-1" -state real ff8i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i23" "aerosols bin 23" "# kg^-1" -state real ff8i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i24" "aerosols bin 24" "# kg^-1" -state real ff8i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i25" "aerosols bin 25" "# kg^-1" -state real ff8i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i26" "aerosols bin 26" "# kg^-1" -state real ff8i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i27" "aerosols bin 27" "# kg^-1" -state real ff8i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i28" "aerosols bin 28" "# kg^-1" -state real ff8i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i29" "aerosols bin 29" "# kg^-1" -state real ff8i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i30" "aerosols bin 30" "# kg^-1" -state real ff8i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i31" "aerosols bin 31" "# kg^-1" -state real ff8i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i32" "aerosols bin 32" "# kg^-1" -state real ff8i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff8i33" "aerosols bin 33" "# kg^-1" -state real ff2i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i01" "ice/columns bin 1" "# kg kg^-1" -state real ff2i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i02" "ice/columns bin 2" "# kg kg^-1" -state real ff2i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i03" "ice/columns bin 3" "# kg kg^-1" -state real ff2i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i04" "ice/columns bin 4" "# kg kg^-1" -state real ff2i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i05" "ice/columns bin 5" "# kg kg^-1" -state real ff2i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i06" "ice/columns bin 6" "# kg kg^-1" -state real ff2i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i07" "ice/columns bin 7" "# kg kg^-1" -state real ff2i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i08" "ice/columns bin 8" "# kg kg^-1" -state real ff2i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i09" "ice/columns bin 9" "# kg kg^-1" -state real ff2i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i10" "ice/columns bin 10" "# kg kg^-1" -state real ff2i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i14" "ice/columns bin 14" "# kg kg^-1" -state real ff2i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i15" "ice/columns bin 15" "# kg kg^-1" -state real ff2i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i16" "ice/columns bin 16" "# kg kg^-1" -state real ff2i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i17" "ice/columns bin 17" "# kg kg^-1" -state real ff2i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i18" "ice/columns bin 18" "# kg kg^-1" -state real ff2i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i19" "ice/columns bin 19" "# kg kg^-1" -state real ff2i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i20" "ice/columns bin 20" "# kg kg^-1" -state real ff2i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i21" "ice/columns bin 21" "# kg kg^-1" -state real ff2i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i22" "ice/columns bin 22" "# kg kg^-1" -state real ff2i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i23" "ice/columns bin 23" "# kg kg^-1" -state real ff2i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i24" "ice/columns bin 24" "# kg kg^-1" -state real ff2i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i25" "ice/columns bin 25" "# kg kg^-1" -state real ff2i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i26" "ice/columns bin 26" "# kg kg^-1" -state real ff2i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i27" "ice/columns bin 27" "# kg kg^-1" -state real ff2i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i28" "ice/columns bin 28" "# kg kg^-1" -state real ff2i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i29" "ice/columns bin 29" "# kg kg^-1" -state real ff2i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i30" "ice/columns bin 30" "# kg kg^-1" -state real ff2i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i31" "ice/columns bin 31" "# kg kg^-1" -state real ff2i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i32" "ice/columns bin 32" "# kg kg^-1" -state real ff2i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff2i33" "ice/columns bin 33" "# kg kg^-1" -state real ff3i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i01" "ice/plates bin 1" "# kg kg^-1" -state real ff3i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i02" "ice/plates bin 2" "# kg kg^-1" -state real ff3i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i03" "ice/plates bin 3" "# kg kg^-1" -state real ff3i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i04" "ice/plates bin 4" "# kg kg^-1" -state real ff3i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i05" "ice/plates bin 5" "# kg kg^-1" -state real ff3i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i06" "ice/plates bin 6" "# kg kg^-1" -state real ff3i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i07" "ice/plates bin 7" "# kg kg^-1" -state real ff3i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i08" "ice/plates bin 8" "# kg kg^-1" -state real ff3i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i09" "ice/plates bin 9" "# kg kg^-1" -state real ff3i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i10" "ice/plates bin 10" "# kg kg^-1" -state real ff3i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i11" "ice/plates bin 11" "# kg kg^-1" -state real ff3i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i12" "ice/plates bin 12" "# kg kg^-1" -state real ff3i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i13" "ice/plates bin 13" "# kg kg^-1" -state real ff3i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i14" "ice/plates bin 14" "# kg kg^-1" -state real ff3i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i15" "ice/plates bin 15" "# kg kg^-1" -state real ff3i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i16" "ice/plates bin 16" "# kg kg^-1" -state real ff3i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i17" "ice/plates bin 17" "# kg kg^-1" -state real ff3i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i18" "ice/plates bin 18" "# kg kg^-1" -state real ff3i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i19" "ice/plates bin 19" "# kg kg^-1" -state real ff3i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i20" "ice/plates bin 20" "# kg kg^-1" -state real ff3i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i21" "ice/plates bin 21" "# kg kg^-1" -state real ff3i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i22" "ice/plates bin 22" "# kg kg^-1" -state real ff3i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i23" "ice/plates bin 23" "# kg kg^-1" -state real ff3i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i24" "ice/plates bin 24" "# kg kg^-1" -state real ff3i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i25" "ice/plates bin 25" "# kg kg^-1" -state real ff3i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i26" "ice/plates bin 26" "# kg kg^-1" -state real ff3i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i27" "ice/plates bin 27" "# kg kg^-1" -state real ff3i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i28" "ice/plates bin 28" "# kg kg^-1" -state real ff3i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i29" "ice/plates bin 29" "# kg kg^-1" -state real ff3i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i30" "ice/plates bin 30" "# kg kg^-1" -state real ff3i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i31" "ice/plates bin 31" "# kg kg^-1" -state real ff3i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i32" "ice/plates bin 32" "# kg kg^-1" -state real ff3i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff3i33" "ice/plates bin 33" "# kg kg^-1" -state real ff4i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i01" "ice/dendrites bin 1" "# kg kg^-1" -state real ff4i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i02" "ice/dendrites bin 2" "# kg kg^-1" -state real ff4i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i03" "ice/dendrites bin 3" "# kg kg^-1" -state real ff4i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i04" "ice/dendrites bin 4" "# kg kg^-1" -state real ff4i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i05" "ice/dendrites bin 5" "# kg kg^-1" -state real ff4i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i06" "ice/dendrites bin 6" "# kg kg^-1" -state real ff4i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i07" "ice/dendrites bin 7" "# kg kg^-1" -state real ff4i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i08" "ice/dendrites bin 8" "# kg kg^-1" -state real ff4i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i09" "ice/dendrites bin 9" "# kg kg^-1" -state real ff4i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i10" "ice/dendrites bin 10" "# kg kg^-1" -state real ff4i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i11" "ice/dendrites bin 11" "# kg kg^-1" -state real ff4i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i12" "ice/dendrites bin 12" "# kg kg^-1" -state real ff4i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i13" "ice/dendrites bin 13" "# kg kg^-1" -state real ff4i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i14" "ice/dendrites bin 14" "# kg kg^-1" -state real ff4i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i15" "ice/dendrites bin 15" "# kg kg^-1" -state real ff4i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i16" "ice/dendrites bin 16" "# kg kg^-1" -state real ff4i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i17" "ice/dendrites bin 17" "# kg kg^-1" -state real ff4i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i18" "ice/dendrites bin 18" "# kg kg^-1" -state real ff4i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i19" "ice/dendrites bin 19" "# kg kg^-1" -state real ff4i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i20" "ice/dendrites bin 20" "# kg kg^-1" -state real ff4i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i21" "ice/dendrites bin 21" "# kg kg^-1" -state real ff4i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i22" "ice/dendrites bin 22" "# kg kg^-1" -state real ff4i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i23" "ice/dendrites bin 23" "# kg kg^-1" -state real ff4i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i24" "ice/dendrites bin 24" "# kg kg^-1" -state real ff4i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i25" "ice/dendrites bin 25" "# kg kg^-1" -state real ff4i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i26" "ice/dendrites bin 26" "# kg kg^-1" -state real ff4i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i27" "ice/dendrites bin 27" "# kg kg^-1" -state real ff4i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i28" "ice/dendrites bin 28" "# kg kg^-1" -state real ff4i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i29" "ice/dendrites bin 29" "# kg kg^-1" -state real ff4i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i30" "ice/dendrites bin 30" "# kg kg^-1" -state real ff4i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i31" "ice/dendrites bin 31" "# kg kg^-1" -state real ff4i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i32" "ice/dendrites bin 32" "# kg kg^-1" -state real ff4i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff4i33" "ice/dendrites bin 33" "# kg kg^-1" -state real ff7i01 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i01" "hail bin 1" "# kg kg^-1" -state real ff7i02 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i02" "hail bin 2" "# kg kg^-1" -state real ff7i03 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i03" "hail bin 3" "# kg kg^-1" -state real ff7i04 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i04" "hail bin 4" "# kg kg^-1" -state real ff7i05 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i05" "hail bin 5" "# kg kg^-1" -state real ff7i06 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i06" "hail bin 6" "# kg kg^-1" -state real ff7i07 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i07" "hail bin 7" "# kg kg^-1" -state real ff7i08 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i08" "hail bin 8" "# kg kg^-1" -state real ff7i09 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i09" "hail bin 9" "# kg kg^-1" -state real ff7i10 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i10" "hail bin 10" "# kg kg^-1" -state real ff7i11 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i11" "hail bin 11" "# kg kg^-1" -state real ff7i12 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i12" "hail bin 12" "# kg kg^-1" -state real ff7i13 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i13" "hail bin 13" "# kg kg^-1" -state real ff7i14 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i14" "hail bin 14" "# kg kg^-1" -state real ff7i15 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i15" "hail bin 15" "# kg kg^-1" -state real ff7i16 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i16" "hail bin 16" "# kg kg^-1" -state real ff7i17 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i17" "hail bin 17" "# kg kg^-1" -state real ff7i18 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i18" "hail bin 18" "# kg kg^-1" -state real ff7i19 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i19" "hail bin 19" "# kg kg^-1" -state real ff7i20 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i20" "hail bin 20" "# kg kg^-1" -state real ff7i21 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i21" "hail bin 21" "# kg kg^-1" -state real ff7i22 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i22" "hail bin 22" "# kg kg^-1" -state real ff7i23 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i23" "hail bin 23" "# kg kg^-1" -state real ff7i24 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i24" "hail bin 24" "# kg kg^-1" -state real ff7i25 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i25" "hail bin 25" "# kg kg^-1" -state real ff7i26 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i26" "hail bin 26" "# kg kg^-1" -state real ff7i27 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i27" "hail bin 27" "# kg kg^-1" -state real ff7i28 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i28" "hail bin 28" "# kg kg^-1" -state real ff7i29 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i29" "hail bin 29" "# kg kg^-1" -state real ff7i30 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i30" "hail bin 30" "# kg kg^-1" -state real ff7i31 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i31" "hail bin 31" "# kg kg^-1" -state real ff7i32 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i32" "hail bin 32" "# kg kg^-1" -state real ff7i33 ikjftb scalar 1 - i01h3rusdf=(bdy_interp:dt) "ff7i33" "hail bin 33" "# kg kg^-1" +state real ff1i01 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i01" "cloud/rain bin 1" "# kg kg-1" +state real ff1i02 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i02" "cloud/rain bin 2" "# kg kg-1" +state real ff1i03 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i03" "cloud/rain bin 3" "# kg kg-1" +state real ff1i04 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i04" "cloud/rain bin 4" "# kg kg-1" +state real ff1i05 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i05" "cloud/rain bin 5" "# kg kg-1" +state real ff1i06 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i06" "cloud/rain bin 6" "# kg kg-1" +state real ff1i07 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i07" "cloud/rain bin 7" "# kg kg-1" +state real ff1i08 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i08" "cloud/rain bin 8" "# kg kg-1" +state real ff1i09 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i09" "cloud/rain bin 9" "# kg kg-1" +state real ff1i10 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i10" "cloud/rain bin 10" "# kg kg-1" +state real ff1i11 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i11" "cloud/rain bin 11" "# kg kg-1" +state real ff1i12 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i12" "cloud/rain bin 12" "# kg kg-1" +state real ff1i13 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i13" "cloud/rain bin 13" "# kg kg-1" +state real ff1i14 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i14" "cloud/rain bin 14" "# kg kg-1" +state real ff1i15 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i15" "cloud/rain bin 15" "# kg kg-1" +state real ff1i16 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i16" "cloud/rain bin 16" "# kg kg-1" +state real ff1i17 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i17" "cloud/rain bin 17" "# kg kg-1" +state real ff1i18 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i18" "cloud/rain bin 18" "# kg kg-1" +state real ff1i19 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i19" "cloud/rain bin 19" "# kg kg-1" +state real ff1i20 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i20" "cloud/rain bin 20" "# kg kg-1" +state real ff1i21 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i21" "cloud/rain bin 21" "# kg kg-1" +state real ff1i22 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i22" "cloud/rain bin 22" "# kg kg-1" +state real ff1i23 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i23" "cloud/rain bin 23" "# kg kg-1" +state real ff1i24 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i24" "cloud/rain bin 24" "# kg kg-1" +state real ff1i25 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i25" "cloud/rain bin 25" "# kg kg-1" +state real ff1i26 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i26" "cloud/rain bin 26" "# kg kg-1" +state real ff1i27 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i27" "cloud/rain bin 27" "# kg kg-1" +state real ff1i28 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i28" "cloud/rain bin 28" "# kg kg-1" +state real ff1i29 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i29" "cloud/rain bin 29" "# kg kg-1" +state real ff1i30 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i30" "cloud/rain bin 30" "# kg kg-1" +state real ff1i31 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i31" "cloud/rain bin 31" "# kg kg-1" +state real ff1i32 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i32" "cloud/rain bin 32" "# kg kg-1" +state real ff1i33 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff1i33" "cloud/rain bin 33" "# kg kg-1" +state real ff5i01 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i01" "snow bin 1" "# kg kg-1" +state real ff5i02 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i02" "snow bin 2" "# kg kg-1" +state real ff5i03 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i03" "snow bin 3" "# kg kg-1" +state real ff5i04 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i04" "snow bin 4" "# kg kg-1" +state real ff5i05 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i05" "snow bin 5" "# kg kg-1" +state real ff5i06 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i06" "snow bin 6" "# kg kg-1" +state real ff5i07 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i07" "snow bin 7" "# kg kg-1" +state real ff5i08 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i08" "snow bin 8" "# kg kg-1" +state real ff5i09 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i09" "snow bin 9" "# kg kg-1" +state real ff5i10 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i10" "snow bin 10" "# kg kg-1" +state real ff5i11 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i11" "snow bin 11" "# kg kg-1" +state real ff5i12 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i12" "snow bin 12" "# kg kg-1" +state real ff5i13 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i13" "snow bin 13" "# kg kg-1" +state real ff5i14 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i14" "snow bin 14" "# kg kg-1" +state real ff5i15 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i15" "snow bin 15" "# kg kg-1" +state real ff5i16 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i16" "snow bin 16" "# kg kg-1" +state real ff5i17 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i17" "snow bin 17" "# kg kg-1" +state real ff5i18 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i18" "snow bin 18" "# kg kg-1" +state real ff5i19 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i19" "snow bin 19" "# kg kg-1" +state real ff5i20 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i20" "snow bin 20" "# kg kg-1" +state real ff5i21 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i21" "snow bin 21" "# kg kg-1" +state real ff5i22 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i22" "snow bin 22" "# kg kg-1" +state real ff5i23 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i23" "snow bin 23" "# kg kg-1" +state real ff5i24 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i24" "snow bin 24" "# kg kg-1" +state real ff5i25 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i25" "snow bin 25" "# kg kg-1" +state real ff5i26 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i26" "snow bin 26" "# kg kg-1" +state real ff5i27 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i27" "snow bin 27" "# kg kg-1" +state real ff5i28 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i28" "snow bin 28" "# kg kg-1" +state real ff5i29 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i29" "snow bin 29" "# kg kg-1" +state real ff5i30 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i30" "snow bin 30" "# kg kg-1" +state real ff5i31 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i31" "snow bin 31" "# kg kg-1" +state real ff5i32 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i32" "snow bin 32" "# kg kg-1" +state real ff5i33 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff5i33" "snow bin 33" "# kg kg-1" +state real ff6i01 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i01" "graupel bin 1" "# kg kg-1" +state real ff6i02 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i02" "graupel bin 2" "# kg kg-1" +state real ff6i03 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i03" "graupel bin 3" "# kg kg-1" +state real ff6i04 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i04" "graupel bin 4" "# kg kg-1" +state real ff6i05 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i05" "graupel bin 5" "# kg kg-1" +state real ff6i06 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i06" "graupel bin 6" "# kg kg-1" +state real ff6i07 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i07" "graupel bin 7" "# kg kg-1" +state real ff6i08 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i08" "graupel bin 8" "# kg kg-1" +state real ff6i09 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i09" "graupel bin 9" "# kg kg-1" +state real ff6i10 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i10" "graupel bin 10" "# kg kg-1" +state real ff6i11 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i11" "graupel bin 11" "# kg kg-1" +state real ff6i12 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i12" "graupel bin 12" "# kg kg-1" +state real ff6i13 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i13" "graupel bin 13" "# kg kg-1" +state real ff6i14 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i14" "graupel bin 14" "# kg kg-1" +state real ff6i15 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i15" "graupel bin 15" "# kg kg-1" +state real ff6i16 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i16" "graupel bin 16" "# kg kg-1" +state real ff6i17 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i17" "graupel bin 17" "# kg kg-1" +state real ff6i18 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i18" "graupel bin 18" "# kg kg-1" +state real ff6i19 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i19" "graupel bin 19" "# kg kg-1" +state real ff6i20 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i20" "graupel bin 20" "# kg kg-1" +state real ff6i21 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i21" "graupel bin 21" "# kg kg-1" +state real ff6i22 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i22" "graupel bin 22" "# kg kg-1" +state real ff6i23 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i23" "graupel bin 23" "# kg kg-1" +state real ff6i24 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i24" "graupel bin 24" "# kg kg-1" +state real ff6i25 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i25" "graupel bin 25" "# kg kg-1" +state real ff6i26 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i26" "graupel bin 26" "# kg kg-1" +state real ff6i27 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i27" "graupel bin 27" "# kg kg-1" +state real ff6i28 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i28" "graupel bin 28" "# kg kg-1" +state real ff6i29 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i29" "graupel bin 29" "# kg kg-1" +state real ff6i30 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i30" "graupel bin 30" "# kg kg-1" +state real ff6i31 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i31" "graupel bin 31" "# kg kg-1" +state real ff6i32 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i32" "graupel bin 32" "# kg kg-1" +state real ff6i33 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff6i33" "graupel bin 33" "# kg kg-1" +state real ff8i01 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i01" "aerosols bin 1" "# kg-1" +state real ff8i02 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i02" "aerosols bin 2" "# kg-1" +state real ff8i03 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i03" "aerosols bin 3" "# kg-1" +state real ff8i04 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i04" "aerosols bin 4" "# kg-1" +state real ff8i05 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i05" "aerosols bin 5" "# kg-1" +state real ff8i06 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i06" "aerosols bin 6" "# kg-1" +state real ff8i07 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i07" "aerosols bin 7" "# kg-1" +state real ff8i08 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i08" "aerosols bin 8" "# kg-1" +state real ff8i09 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i09" "aerosols bin 9" "# kg-1" +state real ff8i10 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i10" "aerosols bin 10" "# kg-1" +state real ff8i11 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i11" "aerosols bin 11" "# kg-1" +state real ff8i12 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i12" "aerosols bin 12" "# kg-1" +state real ff8i13 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i13" "aerosols bin 13" "# kg-1" +state real ff8i14 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i14" "aerosols bin 14" "# kg-1" +state real ff8i15 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i15" "aerosols bin 15" "# kg-1" +state real ff8i16 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i16" "aerosols bin 16" "# kg-1" +state real ff8i17 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i17" "aerosols bin 17" "# kg-1" +state real ff8i18 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i18" "aerosols bin 18" "# kg-1" +state real ff8i19 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i19" "aerosols bin 19" "# kg-1" +state real ff8i20 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i20" "aerosols bin 20" "# kg-1" +state real ff8i21 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i21" "aerosols bin 21" "# kg-1" +state real ff8i22 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i22" "aerosols bin 22" "# kg-1" +state real ff8i23 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i23" "aerosols bin 23" "# kg-1" +state real ff8i24 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i24" "aerosols bin 24" "# kg-1" +state real ff8i25 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i25" "aerosols bin 25" "# kg-1" +state real ff8i26 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i26" "aerosols bin 26" "# kg-1" +state real ff8i27 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i27" "aerosols bin 27" "# kg-1" +state real ff8i28 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i28" "aerosols bin 28" "# kg-1" +state real ff8i29 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i29" "aerosols bin 29" "# kg-1" +state real ff8i30 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i30" "aerosols bin 30" "# kg-1" +state real ff8i31 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i31" "aerosols bin 31" "# kg-1" +state real ff8i32 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i32" "aerosols bin 32" "# kg-1" +state real ff8i33 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff8i33" "aerosols bin 33" "# kg-1" +state real ff2i01 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i01" "ice/columns bin 1" "# kg kg-1" +state real ff2i02 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i02" "ice/columns bin 2" "# kg kg-1" +state real ff2i03 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i03" "ice/columns bin 3" "# kg kg-1" +state real ff2i04 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i04" "ice/columns bin 4" "# kg kg-1" +state real ff2i05 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i05" "ice/columns bin 5" "# kg kg-1" +state real ff2i06 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i06" "ice/columns bin 6" "# kg kg-1" +state real ff2i07 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i07" "ice/columns bin 7" "# kg kg-1" +state real ff2i08 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i08" "ice/columns bin 8" "# kg kg-1" +state real ff2i09 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i09" "ice/columns bin 9" "# kg kg-1" +state real ff2i10 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i10" "ice/columns bin 10" "# kg kg-1" +state real ff2i11 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i11" "ice/columns bin 11" "# kg kg-1" +state real ff2i12 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i12" "ice/columns bin 12" "# kg kg-1" +state real ff2i13 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i13" "ice/columns bin 13" "# kg kg-1" +state real ff2i14 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i14" "ice/columns bin 14" "# kg kg-1" +state real ff2i15 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i15" "ice/columns bin 15" "# kg kg-1" +state real ff2i16 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i16" "ice/columns bin 16" "# kg kg-1" +state real ff2i17 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i17" "ice/columns bin 17" "# kg kg-1" +state real ff2i18 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i18" "ice/columns bin 18" "# kg kg-1" +state real ff2i19 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i19" "ice/columns bin 19" "# kg kg-1" +state real ff2i20 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i20" "ice/columns bin 20" "# kg kg-1" +state real ff2i21 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i21" "ice/columns bin 21" "# kg kg-1" +state real ff2i22 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i22" "ice/columns bin 22" "# kg kg-1" +state real ff2i23 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i23" "ice/columns bin 23" "# kg kg-1" +state real ff2i24 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i24" "ice/columns bin 24" "# kg kg-1" +state real ff2i25 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i25" "ice/columns bin 25" "# kg kg-1" +state real ff2i26 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i26" "ice/columns bin 26" "# kg kg-1" +state real ff2i27 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i27" "ice/columns bin 27" "# kg kg-1" +state real ff2i28 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i28" "ice/columns bin 28" "# kg kg-1" +state real ff2i29 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i29" "ice/columns bin 29" "# kg kg-1" +state real ff2i30 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i30" "ice/columns bin 30" "# kg kg-1" +state real ff2i31 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i31" "ice/columns bin 31" "# kg kg-1" +state real ff2i32 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i32" "ice/columns bin 32" "# kg kg-1" +state real ff2i33 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff2i33" "ice/columns bin 33" "# kg kg-1" +state real ff3i01 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i01" "ice/plates bin 1" "# kg kg-1" +state real ff3i02 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i02" "ice/plates bin 2" "# kg kg-1" +state real ff3i03 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i03" "ice/plates bin 3" "# kg kg-1" +state real ff3i04 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i04" "ice/plates bin 4" "# kg kg-1" +state real ff3i05 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i05" "ice/plates bin 5" "# kg kg-1" +state real ff3i06 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i06" "ice/plates bin 6" "# kg kg-1" +state real ff3i07 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i07" "ice/plates bin 7" "# kg kg-1" +state real ff3i08 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i08" "ice/plates bin 8" "# kg kg-1" +state real ff3i09 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i09" "ice/plates bin 9" "# kg kg-1" +state real ff3i10 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i10" "ice/plates bin 10" "# kg kg-1" +state real ff3i11 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i11" "ice/plates bin 11" "# kg kg-1" +state real ff3i12 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i12" "ice/plates bin 12" "# kg kg-1" +state real ff3i13 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i13" "ice/plates bin 13" "# kg kg-1" +state real ff3i14 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i14" "ice/plates bin 14" "# kg kg-1" +state real ff3i15 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i15" "ice/plates bin 15" "# kg kg-1" +state real ff3i16 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i16" "ice/plates bin 16" "# kg kg-1" +state real ff3i17 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i17" "ice/plates bin 17" "# kg kg-1" +state real ff3i18 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i18" "ice/plates bin 18" "# kg kg-1" +state real ff3i19 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i19" "ice/plates bin 19" "# kg kg-1" +state real ff3i20 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i20" "ice/plates bin 20" "# kg kg-1" +state real ff3i21 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i21" "ice/plates bin 21" "# kg kg-1" +state real ff3i22 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i22" "ice/plates bin 22" "# kg kg-1" +state real ff3i23 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i23" "ice/plates bin 23" "# kg kg-1" +state real ff3i24 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i24" "ice/plates bin 24" "# kg kg-1" +state real ff3i25 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i25" "ice/plates bin 25" "# kg kg-1" +state real ff3i26 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i26" "ice/plates bin 26" "# kg kg-1" +state real ff3i27 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i27" "ice/plates bin 27" "# kg kg-1" +state real ff3i28 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i28" "ice/plates bin 28" "# kg kg-1" +state real ff3i29 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i29" "ice/plates bin 29" "# kg kg-1" +state real ff3i30 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i30" "ice/plates bin 30" "# kg kg-1" +state real ff3i31 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i31" "ice/plates bin 31" "# kg kg-1" +state real ff3i32 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i32" "ice/plates bin 32" "# kg kg-1" +state real ff3i33 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff3i33" "ice/plates bin 33" "# kg kg-1" +state real ff4i01 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i01" "ice/dendrites bin 1" "# kg kg-1" +state real ff4i02 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i02" "ice/dendrites bin 2" "# kg kg-1" +state real ff4i03 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i03" "ice/dendrites bin 3" "# kg kg-1" +state real ff4i04 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i04" "ice/dendrites bin 4" "# kg kg-1" +state real ff4i05 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i05" "ice/dendrites bin 5" "# kg kg-1" +state real ff4i06 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i06" "ice/dendrites bin 6" "# kg kg-1" +state real ff4i07 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i07" "ice/dendrites bin 7" "# kg kg-1" +state real ff4i08 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i08" "ice/dendrites bin 8" "# kg kg-1" +state real ff4i09 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i09" "ice/dendrites bin 9" "# kg kg-1" +state real ff4i10 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i10" "ice/dendrites bin 10" "# kg kg-1" +state real ff4i11 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i11" "ice/dendrites bin 11" "# kg kg-1" +state real ff4i12 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i12" "ice/dendrites bin 12" "# kg kg-1" +state real ff4i13 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i13" "ice/dendrites bin 13" "# kg kg-1" +state real ff4i14 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i14" "ice/dendrites bin 14" "# kg kg-1" +state real ff4i15 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i15" "ice/dendrites bin 15" "# kg kg-1" +state real ff4i16 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i16" "ice/dendrites bin 16" "# kg kg-1" +state real ff4i17 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i17" "ice/dendrites bin 17" "# kg kg-1" +state real ff4i18 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i18" "ice/dendrites bin 18" "# kg kg-1" +state real ff4i19 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i19" "ice/dendrites bin 19" "# kg kg-1" +state real ff4i20 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i20" "ice/dendrites bin 20" "# kg kg-1" +state real ff4i21 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i21" "ice/dendrites bin 21" "# kg kg-1" +state real ff4i22 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i22" "ice/dendrites bin 22" "# kg kg-1" +state real ff4i23 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i23" "ice/dendrites bin 23" "# kg kg-1" +state real ff4i24 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i24" "ice/dendrites bin 24" "# kg kg-1" +state real ff4i25 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i25" "ice/dendrites bin 25" "# kg kg-1" +state real ff4i26 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i26" "ice/dendrites bin 26" "# kg kg-1" +state real ff4i27 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i27" "ice/dendrites bin 27" "# kg kg-1" +state real ff4i28 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i28" "ice/dendrites bin 28" "# kg kg-1" +state real ff4i29 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i29" "ice/dendrites bin 29" "# kg kg-1" +state real ff4i30 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i30" "ice/dendrites bin 30" "# kg kg-1" +state real ff4i31 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i31" "ice/dendrites bin 31" "# kg kg-1" +state real ff4i32 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i32" "ice/dendrites bin 32" "# kg kg-1" +state real ff4i33 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff4i33" "ice/dendrites bin 33" "# kg kg-1" +state real ff7i01 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i01" "hail bin 1" "# kg kg-1" +state real ff7i02 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i02" "hail bin 2" "# kg kg-1" +state real ff7i03 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i03" "hail bin 3" "# kg kg-1" +state real ff7i04 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i04" "hail bin 4" "# kg kg-1" +state real ff7i05 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i05" "hail bin 5" "# kg kg-1" +state real ff7i06 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i06" "hail bin 6" "# kg kg-1" +state real ff7i07 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i07" "hail bin 7" "# kg kg-1" +state real ff7i08 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i08" "hail bin 8" "# kg kg-1" +state real ff7i09 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i09" "hail bin 9" "# kg kg-1" +state real ff7i10 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i10" "hail bin 10" "# kg kg-1" +state real ff7i11 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i11" "hail bin 11" "# kg kg-1" +state real ff7i12 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i12" "hail bin 12" "# kg kg-1" +state real ff7i13 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i13" "hail bin 13" "# kg kg-1" +state real ff7i14 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i14" "hail bin 14" "# kg kg-1" +state real ff7i15 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i15" "hail bin 15" "# kg kg-1" +state real ff7i16 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i16" "hail bin 16" "# kg kg-1" +state real ff7i17 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i17" "hail bin 17" "# kg kg-1" +state real ff7i18 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i18" "hail bin 18" "# kg kg-1" +state real ff7i19 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i19" "hail bin 19" "# kg kg-1" +state real ff7i20 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i20" "hail bin 20" "# kg kg-1" +state real ff7i21 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i21" "hail bin 21" "# kg kg-1" +state real ff7i22 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i22" "hail bin 22" "# kg kg-1" +state real ff7i23 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i23" "hail bin 23" "# kg kg-1" +state real ff7i24 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i24" "hail bin 24" "# kg kg-1" +state real ff7i25 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i25" "hail bin 25" "# kg kg-1" +state real ff7i26 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i26" "hail bin 26" "# kg kg-1" +state real ff7i27 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i27" "hail bin 27" "# kg kg-1" +state real ff7i28 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i28" "hail bin 28" "# kg kg-1" +state real ff7i29 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i29" "hail bin 29" "# kg kg-1" +state real ff7i30 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i30" "hail bin 30" "# kg kg-1" +state real ff7i31 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i31" "hail bin 31" "# kg kg-1" +state real ff7i32 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i32" "hail bin 32" "# kg kg-1" +state real ff7i33 ikjftb scalar 1 - h3rusdf=(bdy_interp:dt) "ff7i33" "hail bin 33" "# kg kg-1" state real qip ikjftb moist 1 - \ i0rhusdf=(bdy_interp:dt) "QICEP" "Plate Ice mixing ratio" "kg kg-1" @@ -288,7 +291,7 @@ state real qid_effr ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QID_EFF_RADIUS" "QID Effective Radius" "Microns" state real th_old ikj misc 1 - rusd "TH_OLD" "Old Value of Th" "K" -state real qv_old ikj misc 1 - rusd "QV_OLD" "Old Value of qv" "kg kg^-1" +state real qv_old ikj misc 1 - rusd "QV_OLD" "Old Value of qv" "kg kg-1" state real kext_ql ikj misc 1 - rh05 "KEXT_QL" " Extinction Coefficient for water " "m-1" state real kext_qic ikj misc 1 - rh05 "KEXT_QIC" " Extinction Coefficient for ice columns " "m-1" @@ -305,6 +308,5 @@ state real kext_ft_qs ikj misc 1 - rh05 state real kext_ft_qg ikj misc 1 - rh05 "KEXT_FT_QG" " Extinction Adj. Coefficient for graupel " "m-1" state real height ikj misc 1 - rh5 "HEIGHT" " Height " "m" state real tempc ikj misc 1 - rh5 "TEMPC" " Temperature " "C" -package fast_khain_lynn mp_physics==30 - moist:qv,qc,qr,qi,qs,qg;scalar:ff1i01,ff1i02,ff1i03,ff1i04,ff1i05,ff1i06,ff1i07,ff1i08,ff1i09,ff1i10,ff1i11,ff1i12,ff1i13,ff1i14,ff1i15,ff1i16,ff1i17,ff1i18,ff1i19,ff1i20,ff1i21,ff1i22,ff1i23,ff1i24,ff1i25,ff1i26,ff1i27,ff1i28,ff1i29,ff1i30,ff1i31,ff1i32,ff1i33,ff5i01,ff5i02,ff5i03,ff5i04,ff5i05,ff5i06,ff5i07,ff5i08,ff5i09,ff5i10,ff5i11,ff5i12,ff5i13,ff5i14,ff5i15,ff5i16,ff5i17,ff5i18,ff5i19,ff5i20,ff5i21,ff5i22,ff5i23,ff5i24,ff5i25,ff5i26,ff5i27,ff5i28,ff5i29,ff5i30,ff5i31,ff5i32,ff5i33,ff6i01,ff6i02,ff6i03,ff6i04,ff6i05,ff6i06,ff6i07,ff6i08,ff6i09,ff6i10,ff6i11,ff6i12,ff6i13,ff6i14,ff6i15,ff6i16,ff6i17,ff6i18,ff6i19,ff6i20,ff6i21,ff6i22,ff6i23,ff6i24,ff6i25,ff6i26,ff6i27,ff6i28,ff6i29,ff6i30,ff6i31,ff6i32,ff6i33,ff8i01,ff8i02,ff8i03,ff8i04,ff8i05,ff8i06,ff8i07,ff8i08,ff8i09,ff8i10,ff8i11,ff8i12,ff8i13,ff8i14,ff8i15,ff8i16,ff8i17,ff8i18,ff8i19,ff8i20,ff8i21,ff8i22,ff8i23,ff8i24,ff8i25,ff8i26,ff8i27,ff8i28,ff8i29,ff8i30,ff8i31,ff8i32,ff8i33,qnn,qnc,qnr,qni,qns,qng,effr,ice_effr,tot_effr -package full_khain_lynn mp_physics==32 - moist:qv,qc,qr,qi,qic,qip,qid,qs,qg,qh;scalar:ff1i01,ff1i02,ff1i03,ff1i04,ff1i05,ff1i06,ff1i07,ff1i08,ff1i09,ff1i10,ff1i11,ff1i12,ff1i13,ff1i14,ff1i15,ff1i16,ff1i17,ff1i18,ff1i19,ff1i20,ff1i21,ff1i22,ff1i23,ff1i24,ff1i25,ff1i26,ff1i27,ff1i28,ff1i29,ff1i30,ff1i31,ff1i32,ff1i33,ff5i01,ff5i02,ff5i03,ff5i04,ff5i05,ff5i06,ff5i07,ff5i08,ff5i09,ff5i10,ff5i11,ff5i12,ff5i13,ff5i14,ff5i15,ff5i16,ff5i17,ff5i18,ff5i19,ff5i20,ff5i21,ff5i22,ff5i23,ff5i24,ff5i25,ff5i26,ff5i27,ff5i28,ff5i29,ff5i30,ff5i31,ff5i32,ff5i33,ff6i01,ff6i02,ff6i03,ff6i04,ff6i05,ff6i06,ff6i07,ff6i08,ff6i09,ff6i10,ff6i11,ff6i12,ff6i13,ff6i14,ff6i15,ff6i16,ff6i17,ff6i18,ff6i19,ff6i20,ff6i21,ff6i22,ff6i23,ff6i24,ff6i25,ff6i26,ff6i27,ff6i28,ff6i29,ff6i30,ff6i31,ff6i32,ff6i33,ff8i01,ff8i02,ff8i03,ff8i04,ff8i05,ff8i06,ff8i07,ff8i08,ff8i09,ff8i10,ff8i11,ff8i12,ff8i13,ff8i14,ff8i15,ff8i16,ff8i17,ff8i18,ff8i19,ff8i20,ff8i21,ff8i22,ff8i23,ff8i24,ff8i25,ff8i26,ff8i27,ff8i28,ff8i29,ff8i30,ff8i31,ff8i32,ff8i33,ff2i01,ff2i02,ff2i03,ff2i04,ff2i05,ff2i06,ff2i07,ff2i08,ff2i09,ff2i10,ff2i11,ff2i12,ff2i13,ff2i14,ff2i15,ff2i16,ff2i17,ff2i18,ff2i19,ff2i20,ff2i21,ff2i22,ff2i23,ff2i24,ff2i25,ff2i26,ff2i27,ff2i28,ff2i29,ff2i30,ff2i31,ff2i32,ff2i33,ff3i01,ff3i02,ff3i03,ff3i04,ff3i05,ff3i06,ff3i07,ff3i08,ff3i09,ff3i10,ff3i11,ff3i12,ff3i13,ff3i14,ff3i15,ff3i16,ff3i17,ff3i18,ff3i19,ff3i20,ff3i21,ff3i22,ff3i23,ff3i24,ff3i25,ff3i26,ff3i27,ff3i28,ff3i29,ff3i30,ff3i31,ff3i32,ff3i33,ff4i01,ff4i02,ff4i03,ff4i04,ff4i05,ff4i06,ff4i07,ff4i08,ff4i09,ff4i10,ff4i11,ff4i12,ff4i13,ff4i14,ff4i15,ff4i16,ff4i17,ff4i18,ff4i19,ff4i20,ff4i21,ff4i22,ff4i23,ff4i24,ff4i25,ff4i26,ff4i27,ff4i28,ff4i29,ff4i30,ff4i31,ff4i32,ff4i33,ff7i01,ff7i02,ff7i03,ff7i04,ff7i05,ff7i06,ff7i07,ff7i08,ff7i09,ff7i10,ff7i11,ff7i12,ff7i13,ff7i14,ff7i15,ff7i16,ff7i17,ff7i18,ff7i19,ff7i20,ff7i21,ff7i22,ff7i23,ff7i24,ff7i25,ff7i26,ff7i27,ff7i28,ff7i29,ff7i30,ff7i31,ff7i32,ff7i33,qnn,qnc,qnr,qni,qnic,qnip,qnid,qns,qng,qnh,effr,ice_effr,tot_effr,qic_effr,qip_effr,qid_effr;state:kext_ql,kext_qic,kext_qip,kext_qid,kext_qs,kext_qg,kext_qh,kext_qa,kext_ft_qic,kext_ft_qip,kext_ft_qid,kext_ft_qs,kext_ft_qg - +package fast_khain_lynn mp_physics==30 - moist:qv,qc,qr,qi,qs,qg;scalar:ff1i01,ff1i02,ff1i03,ff1i04,ff1i05,ff1i06,ff1i07,ff1i08,ff1i09,ff1i10,ff1i11,ff1i12,ff1i13,ff1i14,ff1i15,ff1i16,ff1i17,ff1i18,ff1i19,ff1i20,ff1i21,ff1i22,ff1i23,ff1i24,ff1i25,ff1i26,ff1i27,ff1i28,ff1i29,ff1i30,ff1i31,ff1i32,ff1i33,ff5i01,ff5i02,ff5i03,ff5i04,ff5i05,ff5i06,ff5i07,ff5i08,ff5i09,ff5i10,ff5i11,ff5i12,ff5i13,ff5i14,ff5i15,ff5i16,ff5i17,ff5i18,ff5i19,ff5i20,ff5i21,ff5i22,ff5i23,ff5i24,ff5i25,ff5i26,ff5i27,ff5i28,ff5i29,ff5i30,ff5i31,ff5i32,ff5i33,ff6i01,ff6i02,ff6i03,ff6i04,ff6i05,ff6i06,ff6i07,ff6i08,ff6i09,ff6i10,ff6i11,ff6i12,ff6i13,ff6i14,ff6i15,ff6i16,ff6i17,ff6i18,ff6i19,ff6i20,ff6i21,ff6i22,ff6i23,ff6i24,ff6i25,ff6i26,ff6i27,ff6i28,ff6i29,ff6i30,ff6i31,ff6i32,ff6i33,ff8i01,ff8i02,ff8i03,ff8i04,ff8i05,ff8i06,ff8i07,ff8i08,ff8i09,ff8i10,ff8i11,ff8i12,ff8i13,ff8i14,ff8i15,ff8i16,ff8i17,ff8i18,ff8i19,ff8i20,ff8i21,ff8i22,ff8i23,ff8i24,ff8i25,ff8i26,ff8i27,ff8i28,ff8i29,ff8i30,ff8i31,ff8i32,ff8i33,qnn,qnc,qnr,qni,qns,qng,effr,ice_effr,tot_effr,th_old,qv_old,tempc,height +package full_khain_lynn mp_physics==32 - moist:qv,qc,qr,qi,qic,qip,qid,qs,qg,qh;scalar:ff1i01,ff1i02,ff1i03,ff1i04,ff1i05,ff1i06,ff1i07,ff1i08,ff1i09,ff1i10,ff1i11,ff1i12,ff1i13,ff1i14,ff1i15,ff1i16,ff1i17,ff1i18,ff1i19,ff1i20,ff1i21,ff1i22,ff1i23,ff1i24,ff1i25,ff1i26,ff1i27,ff1i28,ff1i29,ff1i30,ff1i31,ff1i32,ff1i33,ff5i01,ff5i02,ff5i03,ff5i04,ff5i05,ff5i06,ff5i07,ff5i08,ff5i09,ff5i10,ff5i11,ff5i12,ff5i13,ff5i14,ff5i15,ff5i16,ff5i17,ff5i18,ff5i19,ff5i20,ff5i21,ff5i22,ff5i23,ff5i24,ff5i25,ff5i26,ff5i27,ff5i28,ff5i29,ff5i30,ff5i31,ff5i32,ff5i33,ff6i01,ff6i02,ff6i03,ff6i04,ff6i05,ff6i06,ff6i07,ff6i08,ff6i09,ff6i10,ff6i11,ff6i12,ff6i13,ff6i14,ff6i15,ff6i16,ff6i17,ff6i18,ff6i19,ff6i20,ff6i21,ff6i22,ff6i23,ff6i24,ff6i25,ff6i26,ff6i27,ff6i28,ff6i29,ff6i30,ff6i31,ff6i32,ff6i33,ff8i01,ff8i02,ff8i03,ff8i04,ff8i05,ff8i06,ff8i07,ff8i08,ff8i09,ff8i10,ff8i11,ff8i12,ff8i13,ff8i14,ff8i15,ff8i16,ff8i17,ff8i18,ff8i19,ff8i20,ff8i21,ff8i22,ff8i23,ff8i24,ff8i25,ff8i26,ff8i27,ff8i28,ff8i29,ff8i30,ff8i31,ff8i32,ff8i33,ff2i01,ff2i02,ff2i03,ff2i04,ff2i05,ff2i06,ff2i07,ff2i08,ff2i09,ff2i10,ff2i11,ff2i12,ff2i13,ff2i14,ff2i15,ff2i16,ff2i17,ff2i18,ff2i19,ff2i20,ff2i21,ff2i22,ff2i23,ff2i24,ff2i25,ff2i26,ff2i27,ff2i28,ff2i29,ff2i30,ff2i31,ff2i32,ff2i33,ff3i01,ff3i02,ff3i03,ff3i04,ff3i05,ff3i06,ff3i07,ff3i08,ff3i09,ff3i10,ff3i11,ff3i12,ff3i13,ff3i14,ff3i15,ff3i16,ff3i17,ff3i18,ff3i19,ff3i20,ff3i21,ff3i22,ff3i23,ff3i24,ff3i25,ff3i26,ff3i27,ff3i28,ff3i29,ff3i30,ff3i31,ff3i32,ff3i33,ff4i01,ff4i02,ff4i03,ff4i04,ff4i05,ff4i06,ff4i07,ff4i08,ff4i09,ff4i10,ff4i11,ff4i12,ff4i13,ff4i14,ff4i15,ff4i16,ff4i17,ff4i18,ff4i19,ff4i20,ff4i21,ff4i22,ff4i23,ff4i24,ff4i25,ff4i26,ff4i27,ff4i28,ff4i29,ff4i30,ff4i31,ff4i32,ff4i33,ff7i01,ff7i02,ff7i03,ff7i04,ff7i05,ff7i06,ff7i07,ff7i08,ff7i09,ff7i10,ff7i11,ff7i12,ff7i13,ff7i14,ff7i15,ff7i16,ff7i17,ff7i18,ff7i19,ff7i20,ff7i21,ff7i22,ff7i23,ff7i24,ff7i25,ff7i26,ff7i27,ff7i28,ff7i29,ff7i30,ff7i31,ff7i32,ff7i33,qnn,qnc,qnr,qni,qnic,qnip,qnid,qns,qng,qnh,effr,ice_effr,tot_effr,qic_effr,qip_effr,qid_effr;state:kext_ql,kext_qic,kext_qip,kext_qid,kext_qs,kext_qg,kext_qh,kext_qa,kext_ft_qic,kext_ft_qip,kext_ft_qid,kext_ft_qs,kext_ft_qg,th_old,qv_old,tempc,height diff --git a/wrfv2_fire/Registry/registry.stoch b/wrfv2_fire/Registry/registry.stoch index 51dccf7c..f1ce95e8 100644 --- a/wrfv2_fire/Registry/registry.stoch +++ b/wrfv2_fire/Registry/registry.stoch @@ -4,60 +4,65 @@ state real VERTSTRUCC ikj dyn_em 1 - rd "VERTSTRUCC" "vertical structure for stoch. forcing " "" state real VERTSTRUCS ikj dyn_em 1 - rd "VERTSTRUCS" "vertical structure for stoch. forcing " "" -state real ru_tendf_stoch ikj dyn_em 1 X rhdf=(p2c) "ru_tendf_stoch" "stochastic forcing, U " "m/s^2" -state real rv_tendf_stoch ikj dyn_em 1 Y rhdf=(p2c) "rv_tendf_stoch" "stochastic forcing, V " "m/s^2" -state real rt_tendf_stoch ikj dyn_em 1 - rhdf=(p2c) "rt_tendf_stoch" "stochastic forcing, T " "K/s" +# full or possibly thin (i.e., length of 1) 3D arrays depending of dimension i{stoclev}j +state real ru_tendf_stoch i{stoclev}j dyn_em 1 X rhdf=(p2c) "ru_tendf_stoch" "stochastic forcing, U " "m/s^2" +state real rv_tendf_stoch i{stoclev}j dyn_em 1 Y rhdf=(p2c) "rv_tendf_stoch" "stochastic forcing, V " "m/s^2" +state real rt_tendf_stoch i{stoclev}j dyn_em 1 - rhdf=(p2c) "rt_tendf_stoch" "stochastic forcing, T " "K/s" +state real rand_pert i{stoclev}j dyn_em 1 - rhdf=(p2c) "rand_pert" "randomn field " "" +state real rstoch i{stoclev}j dyn_em 1 - rhdf=(p2c) "rstoch" "randomn field for SPPT" "" + +state real RAND_REAL i{stoclev}j dyn_em 1 XYZ - "RAND_REAL" "array for FFTs" "" +state real RAND_IMAG i{stoclev}j dyn_em 1 XYZ - "RAND_IMAG" "array for FFTs" "" + # 2d arrays -state real SPSTREAMFORCC ij misc 1 - r "SPSTREAMFORCC" "real spect. coeff. of stoch. streamfunction perturb." "" -state real SPSTREAMFORCS ij misc 1 - r "SPSTREAMFORCS" "imag. spect. coeff. of stoch. streamfunction perturb." "" -state real SPTFORCC ij misc 1 - r "SPTFORCC" "real spect. coeff. of stoch. temperature perturb." "" "" -state real SPTFORCS ij misc 1 - r "SPTFORCS" "imag. spect. coeff. of stoch. temperature perturb." "" "" +state real SPSTREAMFORCC ij misc 1 XY r "SPSTREAMFORCC" "real spect. coeff. of stoch. streamfunction perturb." "" +state real SPSTREAMFORCS ij misc 1 XY r "SPSTREAMFORCS" "imag. spect. coeff. of stoch. streamfunction perturb." "" state real SPSTREAM_AMP ij misc 1 - r "SPSTREAM_AMP" "amplitude of stoch. streamfunction perturb." "" "" +state real SPTFORCC ij misc 1 XY r "SPTFORCC" "real spect. coeff. of stoch. temperature perturb." "" "" +state real SPTFORCS ij misc 1 XY r "SPTFORCS" "imag. spect. coeff. of stoch. temperature perturb." "" "" state real SPT_AMP ij misc 1 - r "SPT_AMP" "amplitude of stoch. temperature perturb." "" "" +state real SPFORCC ij misc 1 XY r "SPFORCC" "real spect. coeff. of randomn perturbation field" "" "" +state real SPFORCS ij misc 1 XY r "SPFORCS" "imag. spect. coeff. of randomn perturbation field" "" "" +state real SP_AMP ij misc 1 - r "SP_AMP" "amplitude of random perturbation field" "" "" + +state real SPPTFORCC ij misc 1 XY r "SPPTFORCC" "real spect. coeff. of randomn perturbation field in SPPT" "" "" +state real SPPTFORCS ij misc 1 XY r "SPPTFORCS" "imag. spect. coeff. of randomn perturbation field in SPPT" "" "" +state real SPPT_AMP ij misc 1 - r "SPPT_AMP" "amplitude of random perturbation field in SPPT" "" "" + + # 1d arrays state real VERTAMPT k misc 1 - r "VERTAMPT" "vert. amplitude of stoch. temperature perturb." "" "" state real VERTAMPUV k misc 1 - r "VERTAMPUV" "vert. amplitude of stoch. u,v perturb." "" "" +state integer ISEEDARR_RAND_PERT k misc 1 - rh "ISEEDARR_RAND_PERTURB" "Array to hold seed for restart, RAND_PERT" "" "" +state integer ISEEDARR_SPPT k misc 1 - rh "ISEEDARR_SPPT" "Array to hold seed for restart, SPPT" "" "" +state integer ISEEDARR_SKEBS k misc 1 - rh "ISEEDARR_SKEBS" "Array to hold seed for restart, SKEBS" "" "" # 1d arrays for FFT transpose -state real RU_REAL ikj dyn_em 1 XYZ -state real RU_IMAG ikj dyn_em 1 XYZ -state real RU_REAL_xxx ikjx dyn_em 1 XYZ -state real RU_REAL_yyy ikjy dyn_em 1 XYZ -state real RU_IMAG_xxx ikjx dyn_em 1 XYZ -state real RU_IMAG_yyy ikjy dyn_em 1 XYZ -state real RV_REAL ikj dyn_em 1 XYZ -state real RV_IMAG ikj dyn_em 1 XYZ -state real RV_REAL_xxx ikjx dyn_em 1 XYZ -state real RV_REAL_yyy ikjy dyn_em 1 XYZ -state real RV_IMAG_xxx ikjx dyn_em 1 XYZ -state real RV_IMAG_yyy ikjy dyn_em 1 XYZ -state real RT_REAL ikj dyn_em 1 XYZ -state real RT_IMAG ikj dyn_em 1 XYZ -state real RT_REAL_xxx ikjx dyn_em 1 XYZ -state real RT_REAL_yyy ikjy dyn_em 1 XYZ -state real RT_IMAG_xxx ikjx dyn_em 1 XYZ -state real RT_IMAG_yyy ikjy dyn_em 1 XYZ - -xpose XPOSE_STOCH_BACK_U_REAL dyn_em RU_REAL,RU_REAL_xxx,RU_REAL_yyy -xpose XPOSE_STOCH_BACK_U_IMAG dyn_em RU_IMAG,RU_IMAG_xxx,RU_IMAG_yyy -xpose XPOSE_STOCH_BACK_V_REAL dyn_em RV_REAL,RV_REAL_xxx,RV_REAL_yyy -xpose XPOSE_STOCH_BACK_V_IMAG dyn_em RV_IMAG,RV_IMAG_xxx,RV_IMAG_yyy -xpose XPOSE_STOCH_BACK_T_REAL dyn_em RT_REAL,RT_REAL_xxx,RT_REAL_yyy -xpose XPOSE_STOCH_BACK_T_IMAG dyn_em RT_IMAG,RT_IMAG_xxx,RT_IMAG_yyy +state real RAND_REAL_xxx i{stoclev}jx dyn_em 1 XYZ +state real RAND_REAL_yyy i{stoclev}jy dyn_em 1 XYZ +state real RAND_IMAG_xxx i{stoclev}jx dyn_em 1 XYZ +state real RAND_IMAG_yyy i{stoclev}jy dyn_em 1 XYZ + +xpose XPOSE_RAND_REAL dyn_em RAND_REAL,RAND_REAL_xxx,RAND_REAL_yyy +xpose XPOSE_RAND_IMAG dyn_em RAND_IMAG,RAND_IMAG_xxx,RAND_IMAG_yyy # Variables -state integer SEED1 - misc 1 - rh "SEED1" "RANDOM SEED NUMBER 1" "" -state integer SEED2 - misc 1 - rh "SEED2" "RANDOM SEED NUMBER 2" "" -state logical did_stoch - misc 1 - r "DID_STOCH" "Logical to tell us that we already did the initialization for dom 1" "" +state real ALPH_T - misc 1 - - "ALPH_TAU " "autoregressive coeff. for theta perturb." "" +state real ALPH_PSI - misc 1 - - "ALPH_PSI " "autoregressive coeff. for psi perturb." "" +state real ALPH_SPPT - misc 1 - - "ALPH_SPPT" "autoregressive coeff. for tendf perturb." "" +state real ALPH_RAND - misc 1 - - "ALPH_RAND " "autoregressive coeff. for generic rand. pert." "" +state logical did_stoch - misc 1 - r "DID_STOCH" "Logical to tell us that we already did the initialization for dom 1" "" -# Namelist parameters general -rconfig integer stoch_force_opt namelist,stoch max_domains 0 - "stochastic forcing option: 0=none, 1=SKEBS, 2=SPPT" -rconfig integer stoch_vertstruc_opt namelist,stoch max_domains 0 - "vertical structure for stochastic forcing: 0=constant, 1=random phase, 2=user determined" -rconfig integer nens namelist,stoch 1 1 - "random number seed for ensemble members " "" "" +# Namelist parameters for random number streams +rconfig integer nens namelist,stoch 1 1 - "random number seed for ensemble members " "" "" -# Namelist parameters SKEBS +# Namelist parameters for SKEBS +rconfig integer skebs namelist,stoch max_domains 0 - "stochastic forcing option: 0=none, 1=SKEBS" +rconfig integer stoch_force_opt namelist,stoch max_domains 0 - "same as skebs - retained for backward compatibility" +rconfig integer skebs_vertstruc namelist,stoch 1 0 - "vertical structure for skebs: 0=constant, 1=random phase" +rconfig integer stoch_vertstruc_opt namelist,stoch max_domains 0 - "same as skebs_vertstruc - retained for backward compatibility" rconfig real tot_backscat_psi namelist,stoch max_domains 1.0E-05 - "total backscattered diss. for streamfunction m2 s-3" "" rconfig real tot_backscat_t namelist,stoch max_domains 1.0E-06 - "total backscattered diss. rate for pot. temperature" "m2 s-3" "" rconfig real ztau_psi namelist,stoch 1 10800.0 - "decorr. time of noise for psi perturb." @@ -74,23 +79,44 @@ rconfig integer kmaxforc namelist,stoch 1 100 rconfig integer lmaxforc namelist,stoch 1 1000000 - "max. forcing wavenumber in lat. for psi perturb." "" "" rconfig integer kmaxforct namelist,stoch 1 1000000 - "max. forcing wavenumber in lon. for theta perturb." "" "" rconfig integer lmaxforct namelist,stoch 1 1000000 - "max. forcing wavenumber in lat. for theta perturb." "" "" +rconfig integer ISEED_SKEBS namelist,stoch 1 811 - "ISEED_SKEBS" "RANDOM SEED FOR SKEBS " "" rconfig integer kmaxforch derived 1 0 - "sneak variable to make it work" "" "" rconfig integer lmaxforch derived 1 0 - "sneak variable to make it work" "" "" rconfig integer kmaxforcth derived 1 0 - "sneak variable to make it work" "" "" rconfig integer lmaxforcth derived 1 0 - "sneak variable to make it work" "" "" -# Namelist parameters SPPT -rconfig real gridpointvariance namelist,stoch max_domains 0.25 - "gridpoint variance" -rconfig real sppt_thresh_fact namelist,stoch max_domains 2.0 - "threshold for SPPT perturbations in std dev of gridpointvariance" -rconfig real l_sppt namelist,stoch max_domains 15000.0 - "Length scale in meters" -rconfig real tau_sppt namelist,stoch max_domains 21600.0 - "Decorrelation time scale in s" +# Namelist parameters for stochastically parameterized perturbation tendencies (SPPT) + +rconfig integer sppt namelist,stoch max_domains 0 - "generate array with random perturbations: 0=off, 1=on" +rconfig real gridpt_stddev_sppt namelist,stoch max_domains 0.5 - "gridpoint standard deviation of random perturbations in SPPT" +rconfig real stddev_cutoff_sppt namelist,stoch max_domains 2.0 - "cutoff tails of pdf above this threshold standard deviation" +rconfig real lengthscale_sppt namelist,stoch max_domains 150000.0 - "Correlation length scale in meters for SPPT" +rconfig real timescale_sppt namelist,stoch max_domains 21600.0 - "Decorrelation time scale in s for SPPT" +rconfig integer sppt_vertstruc namelist,stoch 1 0 - "vertical structure for sppt: 0=constant, 1=random phase" +rconfig integer ISEED_SPPT namelist,stoch 1 53 - "ISEED_SPPT" "RANDOM SEED FOR SPPT " "" + +# Namelist parameters for random perturbations + +rconfig integer rand_perturb namelist,stoch max_domains 0 - "generate array with random perturbations: 0=off, 1=on" +rconfig real gridpt_stddev_rand_pert namelist,stoch max_domains 0.03 - "gridpoint standard deviation of random perturbations" +rconfig real stddev_cutoff_rand_pert namelist,stoch max_domains 3.0 - "cutoff tails of pdf above this threshold standard deviation" +rconfig real lengthscale_rand_pert namelist,stoch max_domains 500000.0 - "Correlation length scale in meters" +rconfig real timescale_rand_pert namelist,stoch max_domains 21600.0 - "Decorrelation time scale in s" +rconfig integer rand_pert_vertstruc namelist,stoch 1 0 - "vertical structure for random perturb: 0=constant, 1=random phase" +rconfig integer ISEED_RAND_PERT namelist,stoch 1 17 - "ISEED_RAND_PERT" "RANDOM SEED FOR RAND_PERT " "" + + +# Derived namelist parameters used in share/module_check_amundo.F -rconfig integer stoch_force_global_opt derived 1 0 - "stoch_force_global_opt" "global (across domains) stochastic forcing option" "" +rconfig integer skebs_on derived 1 0 - "skebs_on" "skebs arrays are declared&filled for all domains" "" +rconfig integer sppt_on derived 1 0 - "sppt_on" "sppt arrays are declared&filled for all domains" "" +rconfig integer rand_perturb_on derived 1 0 - "rand_perturb_on " "random perturb. array is declared&filled for all domains" "" +rconfig integer num_stoch_levels derived 1 1 - "num_stoch_levels" "number of vertical levels of random fields" "" # Package declarations -package no_stoch_force stoch_force_opt==0 - - -package stoch_backscatter stoch_force_opt==1 - state:ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch,SPSTREAMFORCC,SPSTREAMFORCS,SPTFORCC,SPTFORCS,SPSTREAM_AMP,SPT_AMP,VERTSTRUCC,VERTSTRUCS,RU_IMAG,RU_REAL_xxx,RU_REAL_yyy,RU_IMAG_xxx,RU_IMAG_yyy,RV_IMAG,RV_REAL_xxx,RV_REAL_yyy,RV_IMAG_xxx,RV_IMAG_yyy,RT_IMAG,RT_REAL_xxx,RT_REAL_yyy,RT_IMAG_xxx,RT_IMAG_yyy,RU_REAL,RV_REAL,RT_REAL,VERTAMPT,VERTAMPUV +package sppt_perturb sppt_on==1 - state:rstoch,SPPTFORCS,SPPTFORCC,SPPT_AMP,VERTSTRUCC,VERTSTRUCS,VERTAMPT,RAND_REAL,RAND_IMAG,RAND_REAL_xxx,RAND_REAL_yyy,RAND_IMAG_xxx,RAND_IMAG_yyy -package perturb_tendf stoch_force_opt==2 - state:ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch,SPSTREAMFORCC,SPSTREAMFORCS,SPTFORCC,SPTFORCS,SPSTREAM_AMP,SPT_AMP,VERTSTRUCC,VERTSTRUCS,RU_IMAG,RU_REAL_xxx,RU_REAL_yyy,RU_IMAG_xxx,RU_IMAG_yyy,RV_IMAG,RV_REAL_xxx,RV_REAL_yyy,RV_IMAG_xxx,RV_IMAG_yyy,RT_IMAG,RT_REAL_xxx,RT_REAL_yyy,RT_IMAG_xxx,RT_IMAG_yyy,RU_REAL,RV_REAL,RT_REAL,VERTAMPT,VERTAMPUV +package random_perturb rand_perturb_on==1 - state:rand_pert,SPFORCS,SPFORCC,SP_AMP,VERTSTRUCC,VERTSTRUCS,VERTAMPT,RAND_REAL,RAND_IMAG,RAND_REAL_xxx,RAND_REAL_yyy,RAND_IMAG_xxx,RAND_IMAG_yyy +package skebs_perturb skebs_on==1 - state:ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch,SPSTREAMFORCC,SPSTREAMFORCS,SPTFORCC,SPTFORCS,SPSTREAM_AMP,SPT_AMP,VERTSTRUCC,VERTSTRUCS,VERTAMPT,VERTAMPUV,RAND_REAL,RAND_IMAG,RAND_REAL_xxx,RAND_REAL_yyy,RAND_IMAG_xxx,RAND_IMAG_yyy diff --git a/wrfv2_fire/Registry/registry.tornado b/wrfv2_fire/Registry/registry.tornado new file mode 100644 index 00000000..9bdcdd83 --- /dev/null +++ b/wrfv2_fire/Registry/registry.tornado @@ -0,0 +1,46 @@ +# ------------------------------------------------------------------------ +# Tornado Genesis parameters requested by NCEP SPC. These fields +# contain the minimum, maximum or summed value of various parameters +# in a given time interval. The interval and accumulations are reset +# upon I/O of a particular stream (tg_reset_stream). Note that the +# "f" in the staggering column ensures full (100%) upscale feedback. +# That, and downscale feedback, are needed to ensure correct +# multi-domain maximum calculations. +state real tg_max_m10wind ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MAX_M10WIND" "Maximum 10m wind magnitude since last output time." "m s-1" +state real tg_max_wwind ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MAX_WWIND" "Maximum vertical wind below 400mbar since last output time" "m s-1" +state real tg_min_wwind ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MIN_WWIND" "Minimum vertical wind below 400mbar since last output time" "m s-1" +state real tg_max_zhel_25 ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MAX_ZHEL_25" "Maximum helicity vertical term 2-5km above ground since last output time" "m2 s-2" +state real tg_min_zhel_25 ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MIN_ZHEL_25" "Minimum helicity vertical term 2-5km above ground since last output time" "m2 s-2" +state real tg_max_zhel_03 ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MAX_ZHEL_03" "Maximum helicity vertical term 0-3km above ground since last output time" "m2 s-2" +state real tg_min_zhel_03 ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MIN_ZHEL_03" "Minimum helicity vertical term 0-3km above ground since last output time" "m2 s-2" + + +state real tg_updhel25 ij dyn_nmm 1 f rhu=(UpCopy)d=(DownCopy) "TG_UPDHEL_25" "Updraft helicity 2-5km above ground since last output time" "m2 s-2" +state real tg_max_updhel25 ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MAX_UPDHEL_25" "Maximum updraft helicity 2-5km above ground since last output time" "m2 s-2" +state real tg_updhel03 ij dyn_nmm 1 f rhu=(UpCopy)d=(DownCopy) "TG_UPDHEL_03" "Updraft helicity 0-3km above ground since last output time" "m2 s-2" +state real tg_max_updhel03 ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MAX_UPDHEL_03" "Maximum updraft helicity 0-3km above ground since last output time" "m2 s-2" + + +state real tg_total_precip ij dyn_nmm 1 f rh0123u=(UpCopy)d=(DownCopy) "TG_TOTAL_PRECIP" "Accumulated precipitation" "m" +state real tg_interval_start - dyn_nmm 1 - rh0123 "TG_INTERVAL_START" "Start of interval, in seconds since analysis time" "s" +state real tg_interval_end - dyn_nmm 1 - rh0123 "TG_INTERVAL_END" "End of interval, in seconds since analysis time" "s" +state real tg_duration - dyn_nmm 1 - rh0123 "TG_DURATION" "Duration of accumulation interval in seconds" "s" +state integer tg_want_reset - dyn_nmm 1 - r "TG_WANT_RESET" "Flag: 1=reset tg vars on next timestep" "" + +# Not really tornado genesis stuff, but it is in here because it is +# really only needed when the tornado stuff is turned on: +state real tlow ij dyn_nmm 1 - h1 "TLOW" "Near-surface sensible air temperature" "K" +state real zlow ij dyn_nmm 1 - h1 "ZLOW" "Near-surface altitude" "m" +state real rotangle ij dyn_nmm 1 - h1 "ROTANGLE" "Wind rotation angle from grid to earth" "radians" + +# --------------------------- namelist config ---------------------------- +rconfig integer tg_reset_stream namelist,time_control 1 0 rh0123 "TG_RESET_STREAM" "Stream number of history stream that resets Tornado Genesis products" "" +rconfig integer tg_option namelist,physics 1 0 rh0123 "TG_OPTION" "Tornado Genesis products flag: 1=Enable, 0=Disable" "" +rconfig integer ntornado namelist,physics max_domains 1 rh0123 "NTORNADO" "Number of dynamics timesteps between updates of tg_ vars" "" +#------------------------------- tg option ------------------------------- +package tg_none tg_option==0 - - +package tg_emc2014spc tg_option==1 - state:tg_max_m10wind,tg_max_wwind,tg_min_wwind,tg_max_zhel_25,tg_min_zhel_25,tg_max_zhel_03,tg_min_zhel_03,tg_interval_start,tg_interval_end,tg_duration,tg_total_precip,tlow,zlow,tg_updhel03,tg_updhel25,tg_max_updhel03,tg_max_updhel25 +#--------------------------------- halos --------------------------------- +# Before forcing: +#halo HALO_NMM_TORNADO dyn_nmm 24:tg_max_m10wind,tg_max_wwind,tg_min_wwind,tg_max_zhel_25,tg_min_zhel_25,tg_max_zhel_03,tg_min_zhel_03,tg_total_precip,tg_updhel03,tg_updhel25,tg_max_updhel03,tg_max_updhel25 +# ------------------ end of tornado genesis parameters ------------------- diff --git a/wrfv2_fire/Registry/registry.tracker b/wrfv2_fire/Registry/registry.tracker new file mode 100644 index 00000000..cb7394b7 --- /dev/null +++ b/wrfv2_fire/Registry/registry.tracker @@ -0,0 +1,146 @@ +# This is the list of registry entries needed by the Inlined GFDL/NCEP +# Tracker and associated wind/precip swath generator. These entries +# were moved to the registry.tracker file to improve readability and +# maintainability of the main Registry files. + +# Note that the {otrak} dimension is declared in registry.dimspec + +state integer interesting ij dyn_nmm 1 - rh "interesting" "Bitmask for area of interest flags (0=not in area of interest)" "" +state real precip_swath ij dyn_nmm 1 - rh01u=(UpMax)d=(DownCopy) "precip_swath" "Accumulated total precip in area of interest" "m" +state real windsq_swath ij dyn_nmm 1 - rh01u=(UpMax)d=(DownCopy) "windsq_swath" "Accumulated maximum square of wind magnitude in area of interest" "m2 s-2" +state logical update_interest - dyn_nmm .false. - r "update_interest" ".true. = need to update area of interest" "" + +rconfig real interest_rad_storm namelist,physics max_domains 500 irh01 "interest_rad_storm" "Storm radius of interest for swaths." "km" +rconfig real interest_rad_parent namelist,physics max_domains 500 irh01 "interest_rad_parent" "Nest domain radius of interest in parent, for swaths." "km" +rconfig real interest_rad_self namelist,physics max_domains 500 irh01 "interest_rad_self" "Self-center radius of interest for swaths." "km" + +rconfig integer interest_kids namelist,physics max_domains 1 irh01 "interest_kids" "Flag for enabling area of interest around nest domain centers." "" +rconfig integer interest_self namelist,physics max_domains 0 irh01 "interest_kids" "Flag for enabling area of interest around domain center." "" +rconfig integer interest_storms namelist,physics max_domains 1 irh01 "interest_kids" "Flag for enabling area of interest around storm center." "" + +# Swath mode. Note there is only one of these: it is NOT per domain: +rconfig integer swath_mode namelist,physics - 1 irh01 "swath_mode" "1=enable swaths, 0=disable" "" + +package vt_swath swath_mode==1 - state:interesting,precip_swath,windsq_swath + +halo HALO_NMM_SWATH dyn_nmm 24:precip_swath,windsq_swath + +# ---------------------------------------------------------------------- + +state logical track_have_guess - dyn_nmm 1 - rh01 "track_have_guess" "Is a first guess available?" "" +state real track_guess_lat - dyn_nmm 1 - rh01 "track_guess_lat" "First guess latitude" "degrees" +state real track_guess_lon - dyn_nmm 1 - rh01 "track_guess_lat" "First guess longitude" "degrees" + +state real tracker_distsq ij dyn_nmm 1 - r "TRACKER_DISTSQ" "Square of distance from tracker fix location" "m2" +state real tracker_edge_dist - dyn_nmm 1 - r "tracker_edge_dist" "Distance from storm center to domain edge" "km" +state real tracker_angle ij dyn_nmm 1 - r "tracker_angle" "Angle to storm center (East=0, North=pi/2, etc.)" "radians" + +state real track_old_lon {otrak} dyn_nmm 1 - rh "track_old_lon" "Old tracker longitudes" "degrees" +state real track_old_lat {otrak} dyn_nmm 1 - rh "track_old_lat" "Old tracker latitudes" "degrees" +state integer track_old_ntsd {otrak} dyn_nmm 1 - rh "track_old_ntsd" "Old tracker times" "" +state integer track_n_old - dyn_nmm 1 - rh "track_n_old" "Number of old tracker latitudes" "" + +state real track_stderr_m1 - dyn_nmm 1 - rh01 "track_stderr_m1" "Standard deviation of tracker centers one hour ago" "km" +state real track_stderr_m2 - dyn_nmm 1 - rh01 "track_stderr_m2" "Standard deviation of tracker centers two hours ago" "km" +state real track_stderr_m3 - dyn_nmm 1 - rh01 "track_stderr_m3" "Standard deviation of tracker centers three hours ago" "km" +state integer track_last_hour - dyn_nmm 1 - rh01 "track_last_hour" "Last completed forecast hour" "hours" +state integer tracker_fixes ij dyn_nmm 1 - rh "tracker_fixes" "Tracker fix information for debugging" "" +state real tracker_fixlon - dyn_nmm 1 - rh01 "tracker_fixlon" "Storm fix longitude according to inline NCEP tracker" "degrees" +state real tracker_fixlat - dyn_nmm 1 - rh01 "tracker_fixlat" "Storm fix latitude according to inline NCEP tracker" "degrees" +state integer tracker_ifix - dyn_nmm 1 - rh01 "tracker_ifix" "Storm fix i location (H grid)" "" +state integer tracker_jfix - dyn_nmm 1 - rh01 "tracker_jfix" "Storm fix j location (H grid)" "" +state real tracker_rmw - dyn_nmm 1 - rh01 "tracker_rmw" "Storm RMW according to inline NCEP tracker" "km" +state real tracker_pmin - dyn_nmm 1 - rh01 "tracker_pmin" "Storm min MSLP according to inline NCEP tracker" "Pa" +state real tracker_vmax - dyn_nmm 1 - rh01 "tracker_vmax" "Storm max 10m wind according to inline NCEP tracker" "m s-1" +state logical tracker_havefix - dyn_nmm 1 - rh01 "tracker_havefix" "True = storm fix locations are valid" "" +state logical tracker_gave_up - dyn_nmm 1 - rh01 "tracker_gave_up" "True = inline tracker gave up on tracking the storm" "" + +state real membrane_mslp ij dyn_nmm 1 - rhd=(DownCopy) "membrane_mslp" "Mean Sea Level Pressure using UPP Membrane MSLP method" "Pa" + +state real p850rv ij dyn_nmm 1 - rh "P850rv" "Relative vorticity at 850mbar mass points" "s^-1" +state real p700rv ij dyn_nmm 1 - rh "P700rv" "Relative vorticity at 700mbar mass points" "s^-1" +state real p850wind ij dyn_nmm 1 - rh "P850wind" "Wind magnitude at 850mbar mass points" "m/s" +state real p700wind ij dyn_nmm 1 - rh "P700wind" "Wind magnitude at 700mbar mass points" "m/s" +state real p500u ij dyn_nmm 1 - rh "P500u" "Grid +X wind at 500mbar mass points" "m/s" +state real p500v ij dyn_nmm 1 - rh "P500v" "Grid +Y wind at 500mbar mass points" "m/s" +state real p700u ij dyn_nmm 1 - rh "P700u" "Grid +X wind at 700mbar mass points" "m/s" +state real p700v ij dyn_nmm 1 - rh "P700v" "Grid +Y wind at 700mbar mass points" "m/s" +state real p850u ij dyn_nmm 1 - rh "P850u" "Grid +X wind at 850mbar mass points" "m/s" +state real p850v ij dyn_nmm 1 - rh "P850v" "Grid +Y wind at 850mbar mass points" "m/s" +state real p850z ij dyn_nmm 1 - rh "P850z" "Height at 850mbar mass points" "m" +state real p700z ij dyn_nmm 1 - rh "P700z" "Height at 700mbar mass points" "m" +state real m10wind ij dyn_nmm 1 - rh "m10wind" "Wind magnitude at 10m mass points" "m/s" +state real m10rv ij dyn_nmm 1 - rh "m10rv" "Relative vorticity at 10m mass points" "m/s" + +state real sp850rv ij dyn_nmm 1 - rh "sP850rv" "Smoothed relative vorticity at 850mbar mass points" "s^-1" +state real sp700rv ij dyn_nmm 1 - rh "sP700rv" "Smoothed relative vorticity at 700mbar mass points" "s^-1" +state real sp850wind ij dyn_nmm 1 - rh "sP850wind" "Smoothed wind magnitude at 850mbar mass points" "m/s" +state real sp700wind ij dyn_nmm 1 - rh "sP700wind" "Smoothed wind magnitude at 700mbar mass points" "m/s" +state real sp850z ij dyn_nmm 1 - rh "sP850z" "Smoothed height at 850mbar mass points" "m" +state real sp700z ij dyn_nmm 1 - rh "sP700z" "Smoothed height at 700mbar mass points" "m" +state real sm10wind ij dyn_nmm 1 - rh "sm10wind" "Smoothed wind magnitude at 10m mass points" "m/s" +state real sm10rv ij dyn_nmm 1 - rh "sm10rv" "Smoothed relative vorticity at 10m mass points" "m/s" + +state real smslp ij dyn_nmm 1 - rh "smslp" "Smoothed membrane_mslp" "Pa" + +#--------------------------------------------------------------- +# Vortex tracker options + +# NOTE: ALL methods except #1 must use pdyn_parent and pdyn_smooth, +# if ANY domains use option #5 + +package vt_old_hwrf vortex_tracker==1 - - +package vt_track_nest vortex_tracker==2 - state:pdyn_parent,pdyn_smooth +package vt_centroid vortex_tracker==3 - state:pdyn_parent,pdyn_smooth +package vt_rev_centr vortex_tracker==4 - state:weightout,mslp_noisy,pdyn_parent,pdyn_smooth,distsq +package vt_pdyn vortex_tracker==5 - state:pdyn_parent,pdyn_smooth,distsq +package vt_ncep_2013 vortex_tracker==6 - state:pdyn_parent,pdyn_smooth,p850rv,p700rv,p850wind,p700wind,p850z,p700z,m10wind,m10rv,sp850rv,sp700rv,sp850wind,sp700wind,sp850z,sp700z,sm10wind,sm10rv,smslp,tracker_fixes,distsq,tracker_distsq +package vt_ncep_2014 vortex_tracker==7 - state:pdyn_parent,pdyn_smooth,p850rv,p700rv,p850wind,p700wind,p850z,p700z,m10wind,m10rv,sp850rv,sp700rv,sp850z,sp700z,sm10rv,smslp,tracker_fixes,distsq,p500u,p500v,p700u,p700v,p850u,p850v,tracker_distsq +#--------------------------------------------------------------- +# Vortex Tracker Variables + +state real distsq ij dyn_nmm 1 - rh "DISTSQ" "Approximate square of distance from nest center for vortex tracker #4" "m2" + +# Revised Centroid Method (tracker #4) +state real weightout ij dyn_nmm 1 - rh "WEIGHTOUT" "Vortex center finder weight array for vortex tracker #4" "" +state integer mslp_noisy ij dyn_nmm 1 - rh "MSLP_NOISY" "0=okay, 1=noisy MSLP, 2=outside search radius, 3=boundary (vortex tracker #4)" "" + +# Dynamic Pressure Method (tracker #5) +state real vt5searchrad - dyn_nmm 1 - rh "vt5searchrad" "Search radius from domain center" "m" + +# Smoothed Dynamic Pressure (needed for #5, must be passed down by all) + +state integer pdyn_parent_age - dyn_nmm 1 - rh "PDYN_PARENT_AGE" "Last update of parent pdyn_parent propagated to this nest" "" +state integer pdyn_smooth_age - dyn_nmm 1 - rh "PDYN_SMOOTH_AGE" "Counter of updates of pdyn_smooth" "" +state real pdyn_smooth ij dyn_nmm 1 - rhd=(NoInterp)f=(NoInterp)u=(NoInterp) "PDYN_SMOOTH" "Average of PDYN and PDYN_PARENT" "Pa" +state real pdyn_parent ij dyn_nmm 1 - rhu=(NoInterp)\ +d=(DownAged2D:0,n%pdyn_parent_age,c%pdyn_smooth)\ +f=(DownAged2D:c%pdyn_smooth_age,n%pdyn_parent_age,c%pdyn_smooth)\ + "PDYN_PARENT" "Parent PDYN_SMOOTH for tracking grid motion" "Pa" + +################################################################# +# HWRF nest movement variables +################################################################# + +# Duplicate of nomove_freq for overriding nest movement at certain times +state real nomove_freq_hr - dyn_nmm - - rh "nomove_freq" "nest will not move at analysis time or multiples of this hour (if positive)" +state integer move_countdown - dyn_nmm 1 - rh "MOVE_COUNTDOWN" "Timesteps left with extra CODAMP" "" + +# Choice of vortex tracking method +rconfig integer vortex_tracker namelist,physics max_domains 6 h0123 "vortex_tracker" "Vortex Tracking Algorithm" "" + +rconfig integer num_old_fixes namelist,physics 1 5 h "num_old_fixes" "Number of old tracker fixes to store." "" + +# Vortex Tracking (physics namelist) +# Only for algorithm 4: +rconfig real vt4_radius namelist,physics max_domains 150000. - "vt4_radius" "Vortex Search Radius for vortex tracker #4" "m" +rconfig real vt4_weightexp namelist,physics max_domains 1. - "vt4_weightexp" "Vortex Search Weight Exponent for vortex tracker #4" "" +rconfig real vt4_pmax namelist,physics max_domains -1. - "vt4_pmax" "Vortex Search Max Pressure for vortex tracker #4 (<0 = actual max pressure in search radius)" "Pa" + +rconfig real vt4_noise_pmax namelist,physics max_domains 103000. - "vt4_noise_pmax" "Noise Removal: Maximum Realistic MSLP" "Pa" +rconfig real vt4_noise_pmin namelist,physics max_domains 85000. - "vt4_noise_pmin" "Noise Removal: Minimum Realistic MSLP" "Pa" +rconfig real vt4_noise_dpdr namelist,physics max_domains 0.6 - "vt4_noise_dpdr" "Noise Removal: Maximum Realistic dMSLP/dr" "Pa/m" +rconfig integer vt4_noise_iter namelist,physics max_domains 2 - "vt4_noise_iter" "Noise Removal: number of iterations" "" + + +rconfig real nomove_freq namelist,physics max_domains -1.0 irh "nomove_freq" "nest will not move at analysis time or multiples of this hour (if positive)" diff --git a/wrfv2_fire/Registry/registry.var b/wrfv2_fire/Registry/registry.var index 9d1c3c14..fd05984d 100644 --- a/wrfv2_fire/Registry/registry.var +++ b/wrfv2_fire/Registry/registry.var @@ -158,8 +158,9 @@ rconfig logical use_qscatobs namelist,wrfvar4 1 .true. - "use rconfig logical use_radarobs namelist,wrfvar4 1 .false. - "use_radarobs" "" "" rconfig logical use_radar_rv namelist,wrfvar4 1 .false. - "use_radar_rv" "" "" rconfig logical use_radar_rf namelist,wrfvar4 1 .false. - "use_radar_rf" "" "" -rconfig logical use_radar_rle namelist,wrfvar4 1 .false. - "use_radar_rle" "" "" -rconfig logical use_radar_rr namelist,wrfvar4 1 .false. - "use_radar_rr" "" "" +rconfig logical use_radar_rqv namelist,wrfvar4 1 .false. - "use_radar_rqv" "" "" +rconfig logical use_radar_rhv namelist,wrfvar4 1 .false. - "use_radar_rhv" "" "" +rconfig logical use_3dvar_phy namelist,wrfvar4 1 .true. - "use_3dvar_phy" "" "" rconfig logical use_rainobs namelist,wrfvar4 1 .false. - "use_rainobs" "" "" rconfig logical use_hirs2obs namelist,wrfvar4 1 .false. - "use_hirs2obs" "" "" rconfig logical use_hirs3obs namelist,wrfvar4 1 .false. - "use_hirs3obs" "" "" @@ -271,6 +272,8 @@ rconfig real var_scaling6 namelist,wrfvar7 max_outer_iteratio rconfig real var_scaling7 namelist,wrfvar7 max_outer_iterations 1.0 - "var_scaling7" "" "" rconfig real var_scaling8 namelist,wrfvar7 max_outer_iterations 1.0 - "var_scaling8" "" "" rconfig real var_scaling9 namelist,wrfvar7 max_outer_iterations 1.0 - "var_scaling9" "" "" +rconfig real var_scaling10 namelist,wrfvar7 max_outer_iterations 1.0 - "var_scaling10" "" "" +rconfig real var_scaling11 namelist,wrfvar7 max_outer_iterations 1.0 - "var_scaling11" "" "" rconfig real len_scaling1 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling1" "" "" rconfig real len_scaling2 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling2" "" "" rconfig real len_scaling3 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling3" "" "" @@ -280,6 +283,8 @@ rconfig real len_scaling6 namelist,wrfvar7 max_outer_iteratio rconfig real len_scaling7 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling7" "" "" rconfig real len_scaling8 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling8" "" "" rconfig real len_scaling9 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling9" "" "" +rconfig real len_scaling10 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling10" "" "" +rconfig real len_scaling11 namelist,wrfvar7 max_outer_iterations 1.0 - "len_scaling11" "" "" rconfig real je_factor namelist,wrfvar7 1 1.0 - "je_factor" "" "" rconfig real power_truncation namelist,wrfvar7 1 1.0 - "power_truncation" "" "" rconfig logical def_sub_domain namelist,wrfvar8 1 .false. - "def_sub_domain" "" "" @@ -330,6 +335,8 @@ rconfig real max_vert_var6 namelist,wrfvar13 1 99.0 - "ma rconfig real max_vert_var7 namelist,wrfvar13 1 99.0 - "max_vert_var7" "" "" rconfig real max_vert_var8 namelist,wrfvar13 1 99.0 - "max_vert_var8" "" "" rconfig real max_vert_var9 namelist,wrfvar13 1 99.0 - "max_vert_var9" "" "" +rconfig real max_vert_var10 namelist,wrfvar13 1 99.0 - "max_vert_var10" "" "" +rconfig real max_vert_var11 namelist,wrfvar13 1 99.0 - "max_vert_var11" "" "" rconfig real max_vert_var_alpha namelist,wrfvar13 1 99.0 - "max_vert_var_alpha" "" "" rconfig real psi_chi_factor namelist,wrfvar13 1 1.0 - "psi_chi_factor" "" "" rconfig real psi_t_factor namelist,wrfvar13 1 1.0 - "psi_t_factor" "" "" @@ -411,7 +418,7 @@ rconfig integer alphacv_method namelist,wrfvar16 1 2 - "al rconfig integer ensdim_alpha namelist,wrfvar16 1 0 - "ensdim_alpha" "" "" rconfig integer alpha_truncation namelist,wrfvar16 1 0 - "alpha_truncation" "" "" rconfig integer alpha_corr_type namelist,wrfvar16 1 3 - "alpha_corr_type" "" "" -rconfig real alpha_corr_scale namelist,wrfvar16 1 1500.0 - "alpha_corr_scale" "" "km" +rconfig real alpha_corr_scale namelist,wrfvar16 1 200.0 - "alpha_corr_scale" "" "km" rconfig real alpha_std_dev namelist,wrfvar16 1 1.0 - "alpha_std_dev" "" "" rconfig logical alpha_vertloc namelist,wrfvar16 1 .false. - "alpha_vertloc" "" "" rconfig logical alpha_hydrometeors namelist,wrfvar16 1 .false. - "alpha_hydrometeors" "" "" @@ -432,6 +439,7 @@ rconfig logical enable_identity namelist,perturbation 1 .false. - rconfig logical trajectory_io namelist,perturbation 1 .true. - "0:disk IO;1:memory IO" "" "" rconfig logical var4d_detail_out namelist,perturbation 1 .false. - "true:output perturbation, gradient to disk" "" "" rconfig logical var4d_run namelist,perturbation 1 .true. - "true: exlcude the P calculation in start_em" "" "" +rconfig integer mp_physics_ad namelist,physics max_domains 98 - "mp_physics_ad" "" "" # NAMELIST DERIVED rconfig integer mp_physics_4dvar derived max_domains -1 - "mp_physics_4dvar" "" "-1 = no 4dvar and so no need to allocate a_ and g_ moist and scalar variables, >0 = running 4dvar, so allocate a_ and g_ moist and scalar variables appropriate for selected microphysics package" # @@ -454,7 +462,7 @@ package linscheme mp_physics==2 - moist:qv,qc,q package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs package wsm3scheme mp_physics==3 - moist:qv,qc,qr;g_moist:g_qv,g_qc,g_qr;a_moist:a_qv,a_qc,a_qr package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs -package etampnew mp_physics==5 - moist:qv,qc,qr,qs;g_moist:g_qv,g_qc,g_qr,g_qs;a_moist:a_qv,a_qc,a_qr,a_qs;scalar:qt +package etamp_hr mp_physics==5 - moist:qv,qc,qr,qs;g_moist:g_qv,g_qc,g_qr,g_qs;a_moist:a_qv,a_qc,a_qr,a_qs;scalar:qt package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg;scalar:qni,qnr @@ -465,7 +473,7 @@ package wdm5scheme mp_physics==14 - moist:qv,qc,q package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg;scalar:qnn,qnc,qnr package nssl_2mom mp_physics==17 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qvolg package nssl_2momccn mp_physics==18 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qnc,qnr,qni,qns,qng,qnh,qvolg -package etampold mp_physics==95 - moist:qv,qc,qr,qs;scalar:qt +package etampnew mp_physics==95 - moist:qv,qc,qr,qs;g_moist:g_qv,g_qc,g_qr,g_qs;a_moist:a_qv,a_qc,a_qr,a_qs;scalar:qt package lscondscheme mp_physics==98 - moist:qv;g_moist:g_qv;a_moist:a_qv package mkesslerscheme mp_physics==99 - moist:qv,qc,qr;g_moist:g_qv,g_qc,g_qr;a_moist:a_qv,a_qc,a_qr @@ -483,16 +491,16 @@ package ducuscheme cu_physics==98 - - # Halo Update Communications #### WRFVAR Portion ## -halo HALO_INIT dyn_em 24:xb%map_factor,xb%psac,xb%rough,xb%xland,xb%landmask,xb%tgrn,xb%u,xb%v,xb%w,xb%wh,xb%t,xb%p,xb%q,xb%qrn,xb%qcw,xb%qci,xb%qt,xb%rho,xb%rh,xb%h,xb%hf,xb%u10,xb%v10,xb%t2,xb%q2,xb%terr,xb%psfc,xb%regime,xb%ztd,xb%tpw,xb%speed,xb%tb19v,xb%tb19h,xb%tb22v,xb%tb37v,xb%tb37h,xb%tb85v,xb%tb85h,xb%ref,xb%reflog,xb%delt,xb%slp,xb%coefx,xb%coefy,xb%coefz,xb%tsk,xb%smois,xb%tslb,xb%xice,xb%ivgtyp,xb%isltyp,xb%vegfra,xb%snowh,xb%snow +halo HALO_INIT dyn_em 24:xb%map_factor,xb%psac,xb%rough,xb%xland,xb%landmask,xb%tgrn,xb%u,xb%v,xb%w,xb%wh,xb%t,xb%p,xb%q,xb%qrn,xb%qcw,xb%qci,xb%qsn,xb%qgr,xb%qt,xb%rho,xb%rh,xb%h,xb%hf,xb%u10,xb%v10,xb%t2,xb%q2,xb%terr,xb%psfc,xb%regime,xb%ztd,xb%tpw,xb%speed,xb%tb19v,xb%tb19h,xb%tb22v,xb%tb37v,xb%tb37h,xb%tb85v,xb%tb85h,xb%ref,xb%reflog,xb%delt,xb%slp,xb%coefx,xb%coefy,xb%coefz,xb%tsk,xb%smois,xb%tslb,xb%xice,xb%ivgtyp,xb%isltyp,xb%vegfra,xb%snowh,xb%snow halo HALO_PSICHI_UV dyn_em 24:vp%v1,vp%v2,vp6%v1,vp6%v2,xb%cori,xb%rho,xa%u,xa%v,xa%psfc halo HALO_BAL_EQN_ADJ dyn_em 24:xp%v1z halo HALO_PSICHI_UV_ADJ dyn_em 24:xa%u,xa%v,xa%psfc halo HALO_XA_A dyn_em 4:xa%u,xa%v halo HALO_X6A_A dyn_em 4:x6a%u,x6a%v halo HALO_EM_C_TL dyn_em 4:g_u_2,g_v_2,g_rainc,g_rainnc -halo HALO_XB dyn_em 24:xb%psac,xb%rough,xb%u,xb%v,xb%w,xb%wh,xb%t,xb%p,xb%q,xb%qrn,xb%qcw,xb%qci,xb%qt,xb%rho,xb%rh,xb%h,xb%hf,xb%u10,xb%v10,xb%t2,xb%q2,xb%psfc,xb%regime,xb%ztd,xb%tpw,xb%speed,xb%tb19v,xb%tb19h,xb%tb22v,xb%tb37v,xb%tb37h,xb%tb85v,xb%tb85h,xb%ref,xb%reflog,xb%delt,xb%slp,xb%tsk,xb%smois,xb%tslb,xb%xice,xb%ivgtyp,xb%isltyp,xb%vegfra,xb%snowh,xb%snow -halo HALO_XA dyn_em 24:xa%u,xa%v,xa%q,xa%p,xa%t,xa%rho,xa%rh,xa%psfc,xa%qcw,xa%qrn,xa%qci,xa%qt -halo HALO_XA_CLOUD dyn_em 24:xa%q,xa%t,xa%qcw,xa%qrn,xa%qci +halo HALO_XB dyn_em 24:xb%psac,xb%rough,xb%u,xb%v,xb%w,xb%wh,xb%t,xb%p,xb%q,xb%qs,xb%qrn,xb%qcw,xb%qci,xb%qsn,xb%qgr,xb%qt,xb%rho,xb%rh,xb%h,xb%hf,xb%u10,xb%v10,xb%t2,xb%q2,xb%psfc,xb%regime,xb%ztd,xb%tpw,xb%speed,xb%tb19v,xb%tb19h,xb%tb22v,xb%tb37v,xb%tb37h,xb%tb85v,xb%tb85h,xb%ref,xb%reflog,xb%delt,xb%slp,xb%tsk,xb%smois,xb%tslb,xb%xice,xb%ivgtyp,xb%isltyp,xb%vegfra,xb%snowh,xb%snow +halo HALO_XA dyn_em 24:xa%u,xa%v,xa%q,xa%p,xa%t,xa%rho,xa%rh,xa%psfc,xa%qcw,xa%qrn,xa%qci,xa%qt,xa%qsn,xa%qgr +halo HALO_XA_CLOUD dyn_em 24:xa%q,xa%t,xa%qcw,xa%qrn,xa%qci,xa%qsn,xa%qgr halo HALO_SFC_XA dyn_em 24:xa%u10,xa%v10,xa%t2,xa%q2 halo HALO_SSMI_XA dyn_em 24:xa%ztd,xa%tpw,xa%speed,xa%tb19v,xa%tb19h,xa%tb22v,xa%tb37v,xa%tb37h,xa%tb85v,xa%tb85h,xa%ref halo HALO_2D_WORK dyn_em 24:xp%vxy @@ -514,6 +522,8 @@ typedef vp_type real v6 ijk - 1 - typedef vp_type real v7 ijk - 1 - - typedef vp_type real v8 ijk - 1 - - typedef vp_type real v9 ijk - 1 - - +typedef vp_type real v10 ijk - 1 - - +typedef vp_type real v11 ijk - 1 - - typedef vp_type real alpha ijk9 - 1 - - # END VP_TYPE DEFINITION # BEGIN EP_TYPE DEFINITION: diff --git a/wrfv2_fire/arch/Config_new.pl b/wrfv2_fire/arch/Config_new.pl index 0aa046d9..56ab8a29 100644 --- a/wrfv2_fire/arch/Config_new.pl +++ b/wrfv2_fire/arch/Config_new.pl @@ -21,6 +21,7 @@ $sw_rttov_flag = "" ; $sw_rttov_inc = "" ; $sw_crtm_flag = "" ; +$sw_cloudcv_flag = "" ; $sw_4dvar_flag = "" ; $sw_wavelet_flag = "" ; $WRFCHEM = 0 ; @@ -255,6 +256,10 @@ $sw_rttov_flag = "-DRTTOV"; $sw_rttov_inc = "-I$ENV{RTTOV}/include -I$ENV{RTTOV}/mod"; } + if ( $ENV{CLOUD_CV} ) + { + $sw_cloudcv_flag = "-DCLOUD_CV"; + } if ( $sw_wrf_core eq "4D_DA_CORE" ) { $sw_4dvar_flag = "-DVAR4D"; @@ -296,31 +301,69 @@ # Display the choices to the user and get selection until ( $validresponse ) { printf "------------------------------------------------------------------------\n" ; - printf "Please select from among the following supported platforms.\n\n" ; + printf "Please select from among the following $sw_os $sw_mach options:\n\n" ; $opt = 1 ; + $optstr = ""; open CONFIGURE_DEFAULTS, "< ./arch/configure_new.defaults" or die "Cannot open ./arch/configure_new.defaults for reading" ; - while ( ) - { - for $paropt ( @platforms ) - { - if ( substr( $_, 0, 5 ) eq "#ARCH" - && ( index( $_, $sw_os ) >= 0 ) && ( index( $_, $sw_mach ) >= 0 ) - && ( index($_, $paropt) >= 0 ) ) - { - $optstr[$opt] = substr($_,6) ; - $optstr[$opt] =~ s/^[ ]*// ; - $optstr[$opt] =~ s/#.*$//g ; - chomp($optstr[$opt]) ; - $optstr[$opt] = $optstr[$opt]." (".$paropt.")" ; - if ( substr( $optstr[$opt], 0,4 ) ne "NULL" ) - { - printf " %2d. %s\n",$opt,$optstr[$opt] ; - $opt++ ; + while ( ) { + + $currline = $_; + chomp $currline; + # Look for our platform in the configuration option header. + # If we're going to list it, print parallelism options + if ( substr( $currline, 0, 5 ) eq "#ARCH" && ( index( $currline, $sw_os ) >= 0 ) + && ( index( $currline, $sw_mach ) >= 0 ) ) { + $optstr = substr($currline,6) ; + + foreach ( @platforms ) { # Check which parallelism options are valid for this configuration option + $paropt = $_ ; + if ( index($optstr, $paropt) >= 0 ) { #If parallelism option is valid, print and assign number + printf "%3d. (%s) ",$opt,$paropt ; + $pararray[$opt] = $paropt ; + $opttemp = $optstr ; + $opttemp =~ s/#.*$//g ; + chomp($opttemp) ; + $optarray[$opt] = $opttemp." (".$paropt.")" ; + $opt++ ; + } else { #If parallelism option is not valid, print spaces for formatting/readability + $paropt =~ s/./ /g ; + printf " %s ",$paropt ; + } } - } - } + next; + } + + next unless ( length $optstr ) ; # Don't read option lines unless it's valid for our platform + + if ( substr( $currline, 0, 11 ) eq "DESCRIPTION" ) { + $optstr = $currline ; #Initial value of $optstr is DESCRIPTION line + next; + } + + if ( substr( $currline, 0, 3 ) eq "SFC" ) { + $currline =~ s/^SFC\s*=\s*//g; #remove "SFC =" + $currline =~ s/ (\-\S*)*$//g; #remove trailing arguments and/or spaces + $optstr =~ s/\$SFC/$currline/g; #Substitute the fortran compiler name into optstr + $optstr =~ s/DESCRIPTION\s*=\s*//g; #Remove "DESCRIPTION =" + next; + } + + if ( substr( $currline, 0, 3 ) eq "SCC" ) { + $currline =~ s/^SCC\s*=\s*//g; #remove "SCC =" + $currline =~ s/ (\-\S*)*$//g; #remove trailing arguments and/or spaces + $optstr =~ s/\$SCC/$currline/g; #Substitute the C compiler name into optstr + next; + } + + if ( substr( $currline, 0, 4 ) eq "####" ) { #reached the end of this option's entry + chomp($optstr) ; + printf " %s\n",$optstr ; + $optstr = ""; + next; + } + } close CONFIGURE_DEFAULTS ; @@ -382,6 +425,7 @@ $_ =~ s/CONFIGURE_CRTM_FLAG/$sw_crtm_flag/g ; $_ =~ s/CONFIGURE_RTTOV_FLAG/$sw_rttov_flag/g ; $_ =~ s/CONFIGURE_RTTOV_INC/$sw_rttov_inc/g ; + $_ =~ s/CONFIGURE_CLOUDCV_FLAG/$sw_cloudcv_flag/g ; $_ =~ s/CONFIGURE_WAVELET_FLAG/$sw_wavelet_flag/g ; if ( $sw_ifort_r8 ) { $_ =~ s/^PROMOTION.*=/PROMOTION = -r8 /g ; @@ -533,12 +577,13 @@ && ( index( $_, $sw_os ) >= 0 ) && ( index( $_, $sw_mach ) >= 0 ) && ( index($_, $paropt) >= 0 ) ) { + # We are cycling through the configure_new.defaults file again. + # This bit tries to match the line corresponding to the option we previously selected. $x=substr($_,6) ; - $x=~s/^[ ]*// ; $x =~ s/#.*$//g ; chomp($x) ; $x = $x." (".$paropt.")" ; - if ( $x eq $optstr[$optchoice] ) + if ( $x eq $optarray[$optchoice] ) { if($ENV{WRF_HYDRO} eq 1) { @@ -553,19 +598,19 @@ if ( $paropt ne 'dmpar' && $paropt ne 'dm+sm' ) { $sw_pnetcdf_path = "" ; } # until ( $validresponse ) { - if ( $paropt eq 'serial' || $paropt eq 'smpar' ) { - printf "Compile for nesting? (0=no nesting, 1=basic, 2=preset moves, 3=vortex following) [default 0]: " ; - } elsif ( $ENV{WRF_NMM_CORE} eq "1" ) { - printf "Compile for nesting? (1=basic, 2=preset moves) [default 1]: " ; - } else { - printf "Compile for nesting? (1=basic, 2=preset moves, 3=vortex following) [default 1]: " ; - } if ( $ENV{WRF_DA_CORE} eq "1" || $sw_da_core eq "-DDA_CORE=1" ) { $response = 1 ; } elsif ( $ENV{HWRF} ) { printf "HWRF requires moving nests"; $response = "2\n"; } else { + if ( $paropt eq 'serial' || $paropt eq 'smpar' ) { + printf "Compile for nesting? (0=no nesting, 1=basic, 2=preset moves, 3=vortex following) [default 0]: " ; + } elsif ( $ENV{WRF_NMM_CORE} eq "1" ) { + printf "Compile for nesting? (1=basic, 2=preset moves) [default 1]: " ; + } else { + printf "Compile for nesting? (1=basic, 2=preset moves, 3=vortex following) [default 1]: " ; + } $response = ; } printf "\n" ; @@ -637,6 +682,15 @@ } } } + +if ($latchon == 0) { # Never hurts to check that we actually found the option again. + unlink "configure.wrf"; + print "\nERROR ERROR ERROR ERROR\n\n"; + print "SOMETHING TERRIBLE HAS HAPPENED: configure.wrf not created correctly.\n"; + print 'Check "$x" and "$optarray[$optchoice]"'; + die "\n\nERROR ERROR ERROR ERROR\n\n"; +} + close CONFIGURE_DEFAULTS ; close POSTAMBLE ; close ARCH_NOOPT_EXCEPTIONS ; @@ -718,7 +772,7 @@ close ARCH_PREAMBLE ; print CONFIGURE_WRF @preamble ; close ARCH_PREAMBLE ; -printf CONFIGURE_WRF "# Settings for %s\n", $optstr[$optchoice] ; +printf CONFIGURE_WRF "# Settings for %s\n", $optarray[$optchoice] ; print CONFIGURE_WRF @machopts ; print "$ENV{WRF_MARS}" ; if ( $ENV{WRF_MARS} || $ENV{WRF_TITAN} || $ENV{WRF_VENUS} ) @@ -730,7 +784,7 @@ close CONFIGURE_WRF ; -printf "Configuration successful. To build the model type compile . \n" ; +printf "Configuration successful! \n" ; printf "------------------------------------------------------------------------\n" ; diff --git a/wrfv2_fire/arch/configure_new.defaults b/wrfv2_fire/arch/configure_new.defaults index 92b8908f..99679784 100644 --- a/wrfv2_fire/arch/configure_new.defaults +++ b/wrfv2_fire/arch/configure_new.defaults @@ -1,6 +1,7 @@ ########################################################### #ARCH Linux i486 i586 i686, NEC SX sxf90 sxcc #serial smpar dmpar dm+sm # +DESCRIPTION = NEC SX ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -Popenmp @@ -14,11 +15,11 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = # -fdefault-real-8 # uncomment manually +PROMOTION = #-fdefault-real-8 ARCH_LOCAL = -DNEC -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -c #-DNCARIBM_NOC99 -Xa -Kc99 -LDFLAGS_LOCAL = -Wl,-h nodefs +LDFLAGS_LOCAL = -Wl,-h nodefs CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -w -Chopt -Wf'-M noflunf -M nozdiv' -Wf,-L fmtlist transform,-pvctl fullmsg loopcnt=1000000 -f4 -Wf,-P i @@ -44,6 +45,7 @@ CC_TOOLS = cc ########################################################### #ARCH Linux i486 i586 i686, gfortran compiler with gcc #serial smpar dmpar dm+sm # +DESCRIPTION = GNU ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -fopenmp @@ -57,7 +59,7 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = # -fdefault-real-8 # uncomment manually +PROMOTION = #-fdefault-real-8 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -c LDFLAGS_LOCAL = @@ -85,6 +87,7 @@ CC_TOOLS = $(SCC) ########################################################### #ARCH Linux i486 i586 i686, g95 compiler with gcc #serial dmpar # +DESCRIPTION = GNU ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # not supported OMP = # not supported @@ -124,8 +127,9 @@ RANLIB = ranlib CC_TOOLS = $(SCC) ########################################################### -#ARCH Linux x86_64 i486 i586 i686, PGI compiler with gcc # serial smpar dmpar dm+sm +#ARCH Linux x86_64 ppc64le i486 i586 i686, PGI compiler with gcc # serial smpar dmpar dm+sm # +DESCRIPTION = PGI ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -mp -Minfo=mp -Mrecursive @@ -165,8 +169,9 @@ RANLIB = ranlib CC_TOOLS = $(SCC) ########################################################### -#ARCH Linux x86_64, PGI compiler with pgcc, SGI MPT # serial smpar dmpar dm+sm +#ARCH Linux x86_64 ppc64le, PGI compiler with pgcc, SGI MPT # serial smpar dmpar dm+sm # +DESCRIPTION = PGI ($SFC/$SCC): SGI MPT DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -mp -Minfo=mp -Mrecursive @@ -206,8 +211,9 @@ RANLIB = ranlib CC_TOOLS = $(SCC) ########################################################### -#ARCH Linux x86_64, PGI accelerator compiler with gcc # serial smpar dmpar dm+sm +#ARCH Linux x86_64 ppc64le, PGI accelerator compiler with gcc # serial smpar dmpar dm+sm # +DESCRIPTION = PGI ($SFC/$SCC): PGI accelerator DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -mp -Minfo=mp -Mrecursive @@ -227,10 +233,10 @@ CFLAGS_LOCAL = -w -O3 LDFLAGS_LOCAL = CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) -FCOPTIM = -fastsse -Mvect=noaltcode -Msmartalloc -Mprefetch=distance:8 -ta=nvidia:fastmath,host # -Minfo=all =Mneginfo=all +FCOPTIM = -Kieee -acc -ta=nvidia,fastmath,cuda5.0,cc35 -Mcuda -fastsse -Mvect=noaltcode -Msmartalloc -Mprefetch=distance:8 # -Minfo=all =Mneginfo=all FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -FCDEBUG = # -g $(FCNOOPT) # -C -Ktrap=fp -traceback +FCDEBUG = # -g $(FCNOOPT) -Kieee -acc -ta=nvidia,cuda5.0,cc35 -Mcuda # -C -Ktrap=fp -traceback FORMAT_FIXED = -Mfixed FORMAT_FREE = -Mfree FCSUFFIX = @@ -246,7 +252,7 @@ RANLIB = ranlib CC_TOOLS = $(SCC) ########################################################### -#ARCH Linux x86_64 i486 i586 i686, ifort compiler with icc #serial smpar dmpar dm+sm +#ARCH Linux x86_64 ppc64le i486 i586 i686, ifort compiler with icc #serial smpar dmpar dm+sm # # By default, some files are compiled without optimizations to speed up compilation. Removing # respective makefile rules in the end of this file will result in longer compilation time, and, possibly @@ -281,6 +287,7 @@ CC_TOOLS = $(SCC) #LDFLAGS_LOCAL = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common #FCBASEOPTS_NO_G = -w -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common $(FORMAT_FREE) $(BYTESWAPIO) +DESCRIPTION = INTEL ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -openmp -fpp -auto @@ -294,7 +301,7 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = -i4 +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars LDFLAGS_LOCAL = -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common @@ -302,7 +309,7 @@ CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O0 -fno-inline -fno-ip +FCNOOPT = -O0 -fno-inline -no-ip FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR @@ -320,9 +327,10 @@ RANLIB = ranlib CC_TOOLS = $(SCC) ########################################################### -#ARCH Linux x86_64 i486 i586 i686, Xeon Phi (MIC architecture) ifort compiler with icc # dm+sm +#ARCH Linux x86_64 ppc64le i486 i586 i686, Xeon Phi (MIC architecture) ifort compiler with icc # dm+sm # +DESCRIPTION = INTEL ($SFC/$SCC): Xeon Phi (MIC architecture) DMPARALLEL = 1 OMPCPP = -D_OPENMP OMP = -openmp -fpp -auto @@ -335,8 +343,8 @@ DM_CC = mpiicc -mmic FC = $(DM_FC) CC = $(DM_CC) LD = $(FC) -RWORDSIZE = $(NATIVE_RWORDSIZE) -PROMOTION = -i4 +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DCHUNK=16 -DXEON_OPTIMIZED_WSM5 -DXEON_SIMD -DOPTIMIZE_CFL_TEST -DFSEEKO64_OK -DINTEL_YSU_KLUDGE -DWRF_USE_CLM OPTNOSIMD = OPTKNC = -fimf-precision=low -fimf-domain-exclusion=15 -opt-assume-safe-padding -opt-streaming-stores always -opt-streaming-cache-evict=0 -mP2OPT_hlo_pref_use_outer_strategy=F @@ -346,7 +354,7 @@ CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 $(OPTKNC) FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O0 -fno-inline -fno-ip +FCNOOPT = -O0 -fno-inline -no-ip FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR @@ -364,9 +372,10 @@ RANLIB = ranlib CC_TOOLS = gcc ########################################################### -#ARCH Linux x86_64 i486 i586 i686, Xeon (SNB with AVX mods) ifort compiler with icc # serial smpar dmpar dm+sm +#ARCH Linux x86_64 ppc64le i486 i586 i686, Xeon (SNB with AVX mods) ifort compiler with icc # serial smpar dmpar dm+sm # +DESCRIPTION = INTEL ($SFC/$SCC): Xeon (SNB with AVX mods) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -openmp -fpp -auto @@ -379,8 +388,8 @@ DM_CC = mpicc -cc=$(SCC) FC = $(DM_FC) CC = $(DM_CC) LD = $(FC) -RWORDSIZE = $(NATIVE_RWORDSIZE) -PROMOTION = -i4 +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DCHUNK=64 -DXEON_OPTIMIZED_WSM5 -DOPTIMIZE_CFL_TEST -DWRF_USE_CLM OPTNOSIMD = OPTAVX = -xAVX @@ -390,7 +399,7 @@ CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 $(OPTAVX) FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O0 -fno-inline -fno-ip +FCNOOPT = -O0 -fno-inline -no-ip FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR @@ -408,7 +417,7 @@ RANLIB = ranlib CC_TOOLS = gcc ########################################################### -#ARCH Linux x86_64 i486 i586 i686, ifort compiler with icc, SGI MPT #serial smpar dmpar dm+sm +#ARCH Linux x86_64 ppc64le i486 i586 i686, ifort compiler with icc, SGI MPT #serial smpar dmpar dm+sm # # By default, some files are compiled without optimizations to speed up compilation. Removing # respective makefile rules in the end of this file will result in longer compilation time, and, possibly @@ -437,6 +446,7 @@ CC_TOOLS = gcc # and source bin64/mpivars.sh file from your Intel MPI installation # before the build. +DESCRIPTION = INTEL ($SFC/$SCC): SGI MPT DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -openmp -fpp -auto @@ -450,7 +460,7 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = -i4 +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars LDFLAGS_LOCAL = -ip -lmpi #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common @@ -458,7 +468,7 @@ CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O0 -fno-inline -fno-ip +FCNOOPT = -O0 -fno-inline -no-ip FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR @@ -476,13 +486,14 @@ RANLIB = ranlib CC_TOOLS = $(SCC) ########################################################### -#ARCH Linux x86_64 i486 i586 i686, ifort compiler with icc, IBM POE #serial smpar dmpar dm+sm +#ARCH Linux x86_64 ppc64le i486 i586 i686, ifort compiler with icc, IBM POE #serial smpar dmpar dm+sm # This is identical to the Intel Fortran with Intel MPI but configured # to use IBM POE as the MPI implementation. NCEP needs this # configuration to run on the new WCOSS Tide and Gyre operational # forecasting machines. +DESCRIPTION = INTEL ($SFC/$SCC): IBM POE DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -openmp -fpp -auto @@ -496,7 +507,7 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = -i4 +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars LDFLAGS_LOCAL = -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common @@ -504,7 +515,7 @@ CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O0 -fno-inline -fno-ip +FCNOOPT = -O0 -fno-inline -no-ip FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR @@ -559,6 +570,7 @@ CC_TOOLS = $(SCC) # before the build. # +DESCRIPTION = INTEL ($SFC/$SCC): ia64 DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -openmp -fpp -auto @@ -572,7 +584,7 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = -i4 +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars LDFLAGS_LOCAL = -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common @@ -580,7 +592,7 @@ CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O0 -fno-inline -fno-ip +FCNOOPT = -O0 -fno-inline -no-ip FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR @@ -639,6 +651,7 @@ CC_TOOLS = $(SCC) # DM_CC = $(SFC) -I$(MPI_HOME)/include # LIB_LOCAL = -L$(MPI_HOME)/lib -lmpi +DESCRIPTION = INTEL ($SFC/$SCC): SGI Altix DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -openmp -fpp -auto @@ -652,7 +665,7 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = -i4 +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars LDFLAGS_LOCAL = -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common @@ -660,7 +673,7 @@ CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O0 -fno-inline -fno-ip +FCNOOPT = -O0 -fno-inline -no-ip FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR @@ -680,8 +693,9 @@ RANLIB = ranlib CC_TOOLS = $(SCC) ########################################################### -#ARCH Linux i486 i586 i686 x86_64, PathScale compiler with pathcc #serial dmpar +#ARCH Linux i486 i586 i686 x86_64 ppc64le, PathScale compiler with pathcc #serial dmpar # +DESCRIPTION = PATHSCALE ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # not supported OMP = # not supported @@ -721,8 +735,9 @@ RANLIB = ranlib CC_TOOLS = $(SCC) ########################################################### -#ARCH x86_64 Linux, gfortran compiler with gcc #serial smpar dmpar dm+sm +#ARCH Linux x86_64 ppc64le, gfortran compiler with gcc #serial smpar dmpar dm+sm # +DESCRIPTION = GNU ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -fopenmp @@ -736,7 +751,7 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = # -fdefault-real-8 # uncomment manually +PROMOTION = #-fdefault-real-8 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -c LDFLAGS_LOCAL = @@ -764,18 +779,19 @@ CC_TOOLS = $(SCC) ########################################################### #ARCH Darwin (MACOS) PGI compiler with pgcc #serial smpar dmpar dm+sm # +DESCRIPTION = PGI ($SFC/$SCC) DMPARALLEL = # 1 -OMPCPP = # -D_OPENMP -OMP = # -mp -Minfo=mp -Mrecursive -OMPCC = # -mp -SFC = pgf90 -SCC = pgcc -CCOMP = pgcc -DM_FC = mpif90 -DM_CC = mpicc +OMPCPP = # -D_OPENMP +OMP = # -mp -Minfo=mp -Mrecursive +OMPCC = # -mp +SFC = pgf90 +SCC = pgcc +CCOMP = pgcc +DM_FC = mpif90 +DM_CC = mpicc FC = CONFIGURE_FC CC = CONFIGURE_CC -LD = $(FC) +LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM @@ -783,7 +799,7 @@ CFLAGS_LOCAL = -DMACOS LDFLAGS_LOCAL = CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) -FCOPTIM = -O2 -fast +FCOPTIM = -O2 -fast FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 FCDEBUG = # -g $(FCNOOPT) # -C -Ktrap=fp -traceback @@ -798,13 +814,14 @@ TRADFLAG = -traditional CPP = cpp -P -xassembler-with-cpp AR = ar ARFLAGS = ru -M4 = m4 -B 14000 -RANLIB = ranlib +M4 = m4 -B 14000 +RANLIB = ranlib CC_TOOLS = cc ########################################################### #ARCH Darwin (MACOS) intel compiler with icc #serial smpar dmpar dm+sm # +DESCRIPTION = INTEL ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -openmp -fpp -auto @@ -818,7 +835,7 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = -i4 +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip -DMACOS #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars -DMACOS # increase stack size; also note that for OpenMP, set environment OMP_STACKSIZE 4G or greater @@ -827,7 +844,7 @@ CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O0 -fno-inline -fno-ip +FCNOOPT = -O0 -fno-inline -no-ip FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR @@ -848,6 +865,7 @@ CC_TOOLS = cc ########################################################### #ARCH Darwin (MACOS) intel compiler with cc #serial smpar dmpar dm+sm # +DESCRIPTION = INTEL ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -openmp -fpp -auto @@ -861,7 +879,7 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = -i4 +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip -DMACOS #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars -DMACOS # increase stack size; also note that for OpenMP, set environment OMP_STACKSIZE 4G or greater @@ -870,7 +888,7 @@ CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O0 -fno-inline -fno-ip +FCNOOPT = -O0 -fno-inline -no-ip FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR @@ -891,6 +909,7 @@ CC_TOOLS = cc ########################################################### #ARCH Darwin (MACOS) g95 with gcc #serial dmpar # +DESCRIPTION = GNU ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # not supported OMP = # not supported @@ -933,6 +952,7 @@ CC_TOOLS = $(SCC) ########################################################### #ARCH Darwin (MACOS) gfortran with gcc #serial smpar dmpar dm+sm # +DESCRIPTION = GNU ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -fopenmp @@ -946,7 +966,7 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = # -fdefault-real-8 # uncomment manually +PROMOTION = #-fdefault-real-8 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DMACOS -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -c -DMACOS LDFLAGS_LOCAL = @@ -974,6 +994,7 @@ CC_TOOLS = $(SCC) ########################################################### #ARCH Darwin (MACOS) xlf #serial dmpar # +DESCRIPTION = IBM ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # not supported OMP = # not supported @@ -1017,31 +1038,34 @@ CC_TOOLS = $(SCC) ########################################################### #ARCH AIX xlf compiler with xlc #serial smpar dmpar dm+sm # +DESCRIPTION = IBM ($SFC/$SCC) DMPARALLEL = # 1 -OMPCPP = # -D_OPENMP -OMP = # -qsmp=noauto -OMPCC = # -qsmp=noauto -SFC = xlf90_r -SCC = cc_r -SC99 = c99_r -CCOMP = cc_r -DM_FC = mpxlf90_r -DM_CC = mpcc_r +OMPCPP = # -D_OPENMP +OMP = # -qsmp=noauto +OMPCC = # -qsmp=noauto +SFC = xlf90_r +SCC = cc_r +SC99 = c99_r +CCOMP = cc_r +DM_FC = mpxlf90_r +DM_CC = mpcc_r -DMPI2_SUPPORT FC = CONFIGURE_FC CC = CONFIGURE_CC -LD = $(FC) +LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DNATIVE_MASSV -DWRF_USE_CLM CFLAGS_LOCAL = -DNOUNDERSCORE -LDFLAGS_LOCAL = -lmass -lmassv +LDFLAGS_LOCAL = -lmass -lmassv -bnoquiet # print diagnostic messages CPLUSPLUSLIB = -lC ESMF_LDFLAG = $(CPLUSPLUSLIB) # -qhot commented out in 3.0.1.1 release because of reported problems with # model results under certain configurations. Use at your own risk. -FCOPTIM = -O3 # -qhot -FCREDUCEDOPT = -O2 -FCNOOPT = -qnoopt +# -qstrict added in 3.6.1 release because of reported problems with +# model stability under certain configurations. Use at your own risk. +FCOPTIM = -O3 -qstrict # -qhot +FCREDUCEDOPT = -O2 # implies -qstrict +FCNOOPT = -qnoopt FCDEBUG = # -g $(FCNOOPT) -qfullpath FORMAT_FIXED = -qfixed FORMAT_FREE = -qfree=f90 @@ -1054,17 +1078,68 @@ TRADFLAG = -traditional CPP = /lib/cpp -P AR = ar ARFLAGS = ru -M4 = m4 -B 14000 -RANLIB = ranlib +M4 = m4 -B 14000 +RANLIB = ranlib CC_TOOLS = cc ########################################################### -#ARCH Cray XT CLE/Linux x86_64, PGI compiler with gcc # serial dmpar smpar dm+sm +#ARCH Linux x86_64 ppc64le i486 i586 i686, xlf compiler with xlc # serial smpar dmpar dm+sm +# +DESCRIPTION = IBM ($SFC/$SCC) +DMPARALLEL = #1 +OMPCPP = # -D_OPENMP +OMP = # -qsmp=noauto +OMPCC = # -qsmp=noauto +SFC = xlf90_r +SCC = cc_r +SC99 = c99_r +CCOMP = cc_r +DM_FC = mpfort -compiler xlf90_r +DM_CC = mpcc -DMPI2_SUPPORT +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DNATIVE_MASSV -DWRF_USE_CLM +CFLAGS_LOCAL = -DNOUNDERSCORE +LDFLAGS_LOCAL = -lmass_64 -lmassvp7_64 -q64 -bnoquiet # linking diagnostics +CPLUSPLUSLIB = -lC +ESMF_LDFLAG = $(CPLUSPLUSLIB) +# -qhot commented out in 3.0.1.1 release because of reported problems with +# model results under certain configurations. Use at your own risk. +# -qstrict added in 3.6.1 release because of reported problems with +# model stability under certain configurations. Use at your own risk. +FCOPTIM = -q64 -O3 -qstrict # -qhot +# if linking problems with libxlsmp occur, try -qsmp=noauto +FCREDUCEDOPT = -q64 -O2 +FCNOOPT = -q64 -qnoopt -qstrict # -qsmp=noauto +FCDEBUG = # -g $(FCNOOPT) -qfullpath +FORMAT_FIXED = -qfixed +FORMAT_FREE = -qfree=f90 +FCSUFFIX = -qsuffix=f=f90 +BYTESWAPIO = +FCBASEOPTS_NO_G = -w -qspill=81920 -qmaxmem=-1 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap -C # -qinitauto=7FF7FFFF +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = +TRADFLAG = +# instead of the GNU CPP, the CPP shipped with XLF should be used, +# which does not work with the -traditional flag +CPP = $(XLF_BASE)/exe/cpp -P +AR = ar +ARFLAGS = ru +M4 = m4 -B 14000 +RANLIB = ranlib +CC_TOOLS = cc + +########################################################### +#ARCH Cray XC CLE/Linux x86_64, PGI compiler with gcc # serial dmpar smpar dm+sm # # Recommended CLE/Linux memory allocation settings at run time: # export MALLOC_MMAP_MAX_=0 # export MALLOC_TRIM_THRESHOLD_=536870912 # +DESCRIPTION = PGI ($SFC/$SCC): Cray XC CLE DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -mp -Mrecursive @@ -1119,9 +1194,13 @@ RANLIB = ranlib CC_TOOLS = $(SCC) ########################################################### -#ARCH Cray XE and XC30 CLE/Linux x86_64, Cray CCE compiler # serial dmpar smpar dm+sm -# Use this for both XE6 systems with AMD Opteron and XC30 with Intel SB or IB +#ARCH Cray XE and XC CLE/Linux x86_64, Cray CCE compiler # serial dmpar smpar dm+sm +# Use this for both XE6 systems with AMD Opteron and XC with Intel x86_64 +DESCRIPTION = CRAY CCE ($SFC/$SCC): Cray XE and XC +# OpenMP is enabled by default for Cray CCE compiler +# This turns it off +OMP = -hnoomp DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -homp @@ -1134,7 +1213,7 @@ DM_CC = cc FC = $(DM_FC) CC = $(DM_CC) LD = $(FC) -RWORDSIZE = $(NATIVE_RWORDSIZE) +RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -s integer32 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -O3 @@ -1149,7 +1228,7 @@ FORMAT_FIXED = -f fixed FORMAT_FREE = -f free FCSUFFIX = BYTESWAPIO = -h byteswapio -FCBASEOPTS_NO_G = -h noomp -N255 $(FORMAT_FREE) $(BYTESWAPIO) #-ra +FCBASEOPTS_NO_G = -N1023 $(FORMAT_FREE) $(BYTESWAPIO) #-ra FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional @@ -1161,9 +1240,10 @@ RANLIB = ranlib CC_TOOLS = gcc ########################################################### -#ARCH Cray XC30 CLE/Linux x86_64, Xeon ifort compiler # serial dmpar smpar dm+sm +#ARCH Cray XC CLE/Linux x86_64, Xeon ifort compiler # serial dmpar smpar dm+sm # +DESCRIPTION = INTEL ($SFC/$SCC): Cray XC DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -openmp -fpp -auto @@ -1176,16 +1256,17 @@ DM_CC = cc FC = $(DM_FC) CC = $(DM_CC) LD = $(FC) -RWORDSIZE = $(NATIVE_RWORDSIZE) -PROMOTION = -i4 +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM OPTNOSIMD = -OPTAVX = -xAVX -CFLAGS_LOCAL = -w -O3 $(OPTAVX) +# set this to override Cray 'craype' module setting +#OPTAVX = -xAVX +CFLAGS_LOCAL = -w -O3 -ip $(OPTAVX) LDFLAGS_LOCAL = $(OPTAVX) CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) -FCOPTIM = -O3 $(OPTAVX) +FCOPTIM = -ip -O3 $(OPTAVX) FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -fno-inline -fno-ip FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u @@ -1193,7 +1274,7 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian -FCBASEOPTS_NO_G = -w -ftz -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-vec-report6 +FCBASEOPTS_NO_G = -w -ftz -fno-alias -align all $(FORMAT_FREE) $(BYTESWAPIO) #-vec-report6 FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional @@ -1207,6 +1288,7 @@ CC_TOOLS = gcc ########################################################### #ARCH Fujitsu FX10 Linux SPARC64IXfx, mpifrtpx and mpifccpx compilers #serial smpar dmpar dm+sm # +DESCRIPTION = FUJITSU ($SFC/$SCC): FX10 SPARC64 IXfx DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -Kopenmp @@ -1220,7 +1302,7 @@ FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = #-CcdRR8 # uncomment manually +PROMOTION = -CcdRR$(RWORDSIZE) ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -Kfast -Xg -DSUN LDFLAGS_LOCAL = @@ -1248,21 +1330,22 @@ CC_TOOLS = /usr/bin/gcc -Wall ########################################################### #ARCH Linux ppc64 BG /L blxlf compiler with blxlc # dmpar # +DESCRIPTION = IBM ($SFC/$SCC): ppc64 Blue Gene\L DMPARALLEL = # 1 -OMPCPP = # not supported -OMP = # not supported -OMPCC = # not supported +OMPCPP = # not supported +OMP = # not supported +OMPCC = # not supported BGL_SYS = /bgl/BlueLight/ppcfloor/bglsys MPI_INC = -I$(BGL_SYS)/include MPI_LIB = -L$(BGL_SYS)/lib -lmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts -SFC = blrts_xlf90 -SCC = blrts_xlc -CCOMP = blrts_xlc -DM_FC = $(SFC) -DM_CC = $(SCC) +SFC = blrts_xlf90 +SCC = blrts_xlc +CCOMP = blrts_xlc +DM_FC = $(SFC) +DM_CC = $(SCC) FC = CONFIGURE_FC CC = CONFIGURE_CC -LD = $(FC) +LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 # If system has even more processors, set VERY_LARGE_MAXPROC to that number @@ -1272,7 +1355,7 @@ LIB_LOCAL = $(MPI_LIB) LDFLAGS_LOCAL = -Wl,--allow-multiple-definition -qstatic CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) -FCOPTIM = -O2 -qarch=440 +FCOPTIM = -O2 -qarch=440 FCNOOPT = -qnoopt FCDEBUG = # $(FCNOOPT) -qfullpath FORMAT_FIXED = -qfixed @@ -1290,17 +1373,18 @@ CPP = /opt/ibmcmp/xlf/bg/10.1/exe/cpp -P CPP = /opt/ibmcmp/xlf/9.1/exe/cpp -P AR = ar ARFLAGS = ru -M4 = m4 -B 14000 -RANLIB = ranlib +M4 = m4 -B 14000 +RANLIB = ranlib CC_TOOLS = cc ########################################################### #ARCH Linux ppc64 BG /P xlf compiler with xlc # smpar dmpar dm+sm # developed on surveyor.alcf.anl.gov (thanks to ANL/ALCF) # +DESCRIPTION = IBM ($SFC/$SCC): ppc64 Blue Gene\P DMPARALLEL = # 1 -OMPCPP = # -D_OPENMP -OMP = # -qsmp=noauto -OMPCC = # -qsmp=noauto +OMPCPP = # -D_OPENMP +OMP = # -qsmp=noauto +OMPCC = # -qsmp=noauto # these have to be the same as DM_FC on surveyor or it fails with weird errors in time manager SFC = mpixlf90_r SCC = mpixlc_r @@ -1319,7 +1403,7 @@ LIB_LOCAL = LDFLAGS_LOCAL = -Wl,--allow-multiple-definition,--relax -qstatic CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) -FCOPTIM = -O3 -qnoipa -qarch=auto -qcache=auto -qtune=auto +FCOPTIM = -O3 -qnoipa -qarch=auto -qcache=auto -qtune=auto FCNOOPT = -qnoopt FCDEBUG = # $(FCNOOPT) -g -qfullpath FORMAT_FIXED = -qfixed @@ -1335,25 +1419,26 @@ TRADFLAG = -traditional CPP = /opt/ibmcmp/xlf/bg/11.1/exe/cpp -P AR = ar ARFLAGS = ru -M4 = m4 -B 14000 -RANLIB = ranlib +M4 = m4 -B 14000 +RANLIB = ranlib CC_TOOLS = cc ########################################################### #ARCH Linux ppc64 IBM Blade Server xlf compiler with xlc # dmpar # provided by Luis C. Cana Cascallar for IBM JS21 blade server, May 2009 # +DESCRIPTION = IBM ($SFC/$SCC): ppc64 IBM Blade DMPARALLEL = # 1 -OMPCPP = # not supported -OMP = # not supported -OMPCC = # not supported -SFC = xlf90_r -q64 -SCC = xlc_r -q64 -CCOMP = xlc_r -q64 -DM_FC = mpif90 -q64 -DM_CC = mpicc -q64 -DMPI2_SUPPORT -DFSEEKO64_OK +OMPCPP = # not supported +OMP = # not supported +OMPCC = # not supported +SFC = xlf90_r -q64 +SCC = xlc_r -q64 +CCOMP = xlc_r -q64 +DM_FC = mpif90 -q64 +DM_CC = mpicc -q64 -DMPI2_SUPPORT -DFSEEKO64_OK FC = CONFIGURE_FC CC = CONFIGURE_CC -LD = $(FC) +LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 # If system has even more processors, set VERY_LARGE_MAXPROC to that number @@ -1377,13 +1462,14 @@ TRADFLAG = -traditional CPP = /opt/ibmcmp/xlf/11.1/exe/cpp -P AR = ar ARFLAGS = ru -M4 = m4 -B 14000 -RANLIB = ranlib +M4 = m4 -B 14000 +RANLIB = ranlib CC_TOOLS = xlc -q64 ########################################################### -#ARCH Linux x86_64 i486 i586 i686, PGI compiler with pgcc # serial smpar dmpar dm+sm +#ARCH Linux x86_64 ppc64le i486 i586 i686, PGI compiler with pgcc # serial smpar dmpar dm+sm # +DESCRIPTION = PGI ($SFC/$SCC) DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -mp -Minfo=mp -Mrecursive @@ -1425,6 +1511,7 @@ CC_TOOLS = $(SCC) ########################################################### #ARCH CYGWIN_NT i686, PGI compiler on Windows # serial smpar dmpar dm+sm # +DESCRIPTION = PGI ($SFC/$SCC): Windows DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -mp -Minfo=mp @@ -1477,6 +1564,132 @@ LIB_BUNDLED = \ ../frame/module_internal_header_util.o \ ../frame/pack_utils.o +########################################################### +#ARCH Linux x86_64 ppc64le i486 i586 i686, PGI compiler with gcc -f90= # serial smpar dmpar dm+sm +# +DESCRIPTION = PGI ($SFC/$SCC): -f90=pgf90 +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -mp -Minfo=mp -Mrecursive +OMPCC = # -mp +SFC = pgf90 +SCC = gcc +CCOMP = gcc +DM_FC = mpif90 -f90=pgf90 +DM_CC = mpicc -cc=gcc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -r$(RWORDSIZE) -i4 +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +CFLAGS_LOCAL = -w -O3 +LDFLAGS_LOCAL = +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -O3 #-fastsse -Mvect=noaltcode -Msmartalloc -Mprefetch=distance:8 -Mfprelaxed # -Minfo=all =Mneginfo=all +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 +FCDEBUG = # -g $(FCNOOPT) # -C -Ktrap=fp -traceback +FORMAT_FIXED = -Mfixed +FORMAT_FREE = -Mfree +FCSUFFIX = +BYTESWAPIO = -byteswapio +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main +TRADFLAG = -traditional +CPP = /lib/cpp -P +AR = ar +ARFLAGS = ru +M4 = m4 -B 14000 +RANLIB = ranlib +CC_TOOLS = $(SCC) + +########################################################### +#ARCH Darwin (MACOS) PGI compiler with pgcc -f90= #serial smpar dmpar dm+sm +# +DESCRIPTION = PGI ($SFC/$SCC): -f90=pgf90 +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -mp -Minfo=mp -Mrecursive +OMPCC = # -mp +SFC = pgf90 +SCC = pgcc +CCOMP = pgcc +DM_FC = mpif90 -f90=pgf90 +DM_CC = mpicc -cc=pgcc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -r$(RWORDSIZE) -i4 +ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +CFLAGS_LOCAL = -DMACOS +LDFLAGS_LOCAL = +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -O2 -fast +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 +FCDEBUG = # -g $(FCNOOPT) # -C -Ktrap=fp -traceback +FORMAT_FIXED = -Mfixed +FORMAT_FREE = -Mfree +FCSUFFIX = +BYTESWAPIO = -byteswapio +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) -Mnomod +MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main +TRADFLAG = -traditional +CPP = cpp -P -xassembler-with-cpp +AR = ar +ARFLAGS = ru +M4 = m4 -B 14000 +RANLIB = ranlib +CC_TOOLS = cc + +########################################################### +#ARCH Linux x86_64 ppc64le i486 i586 i686, PGI compiler with pgcc -f90= # serial smpar dmpar dm+sm +# +DESCRIPTION = PGI ($SFC/$SCC): -f90=pgf90 +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -mp -Minfo=mp -Mrecursive +OMPCC = # -mp +SFC = pgf90 +SCC = pgcc +CCOMP = pgcc +DM_FC = mpif90 -f90=pgf90 +DM_CC = mpicc -cc=pgcc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -r$(RWORDSIZE) -i4 +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +CFLAGS_LOCAL = -w -O3 +LDFLAGS_LOCAL = +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -O3 #-fastsse -Mvect=noaltcode -Msmartalloc -Mprefetch=distance:8 -Mfprelaxed # -Minfo=all =Mneginfo=all +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 +FCDEBUG = # -g $(FCNOOPT) # -C -Ktrap=fp -traceback +FORMAT_FIXED = -Mfixed +FORMAT_FREE = -Mfree +FCSUFFIX = +BYTESWAPIO = -byteswapio +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main +TRADFLAG = -traditional +CPP = /lib/cpp -P +AR = ar +ARFLAGS = ru +M4 = m4 -B 14000 +RANLIB = ranlib +CC_TOOLS = $(SCC) + ########################################################### #ARCH NULL diff --git a/wrfv2_fire/arch/md_calls.inc b/wrfv2_fire/arch/md_calls.inc index 561489bd..77d24983 100644 --- a/wrfv2_fire/arch/md_calls.inc +++ b/wrfv2_fire/arch/md_calls.inc @@ -239,7 +239,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -253,7 +253,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -399,7 +399,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_ti_real ( Hndl, Element, Data, & locCount, Outcount, Status ) ELSE @@ -442,7 +442,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -456,7 +456,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -602,7 +602,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_ti_real ( Hndl, Element, Data, & locCount, Outcount, Status ) ELSE @@ -647,7 +647,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -661,7 +661,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -807,7 +807,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_ti_real ( Hndl, Element, Data, & locCount, Status ) ELSE @@ -850,7 +850,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -864,7 +864,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1010,7 +1010,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_ti_real ( Hndl, Element, Data, & locCount, Status ) ELSE @@ -1055,7 +1055,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -1069,7 +1069,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_dom_ti_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1170,7 +1170,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) ELSE @@ -1213,7 +1213,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -1227,7 +1227,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_dom_ti_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1328,7 +1328,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_ti_double ( Hndl, Element, Data, & locCount, Outcount, Status ) ELSE @@ -1373,7 +1373,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -1387,7 +1387,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_dom_ti_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1488,7 +1488,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) ELSE @@ -1531,7 +1531,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -1545,7 +1545,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_dom_ti_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1646,7 +1646,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_ti_double ( Hndl, Element, Data, & locCount, Status ) ELSE @@ -1691,7 +1691,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -1705,7 +1705,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1806,7 +1806,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_ti_integer ( Hndl, Element, Data, & locCount, Outcount, Status ) ELSE @@ -1849,7 +1849,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -1863,7 +1863,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1964,7 +1964,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_ti_integer ( Hndl, Element, Data, & locCount, Outcount, Status ) ELSE @@ -2009,7 +2009,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -2023,7 +2023,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -2124,7 +2124,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_ti_integer ( Hndl, Element, Data, & locCount, Status ) ELSE @@ -2167,7 +2167,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -2181,7 +2181,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -2282,7 +2282,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_ti_integer ( Hndl, Element, Data, & locCount, Status ) ELSE @@ -2327,7 +2327,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -2341,7 +2341,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -2442,7 +2442,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_ti_logical ( Hndl, Element, Data, & locCount, Outcount, Status ) ELSE @@ -2485,7 +2485,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -2499,7 +2499,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -2600,7 +2600,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_ti_logical ( Hndl, Element, Data, & locCount, Outcount, Status ) ELSE @@ -2645,7 +2645,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -2659,7 +2659,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -2760,7 +2760,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_ti_logical ( Hndl, Element, Data, & locCount, Status ) ELSE @@ -2803,7 +2803,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -2817,7 +2817,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -2918,7 +2918,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_ti_logical ( Hndl, Element, Data, & locCount, Status ) ELSE @@ -2963,7 +2963,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -2977,7 +2977,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_dom_ti_char_a Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -3078,7 +3078,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_ti_char ( Hndl, Element, Data, & Status ) ELSE @@ -3123,7 +3123,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -3137,7 +3137,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_dom_ti_char_a Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -3238,7 +3238,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_ti_char ( Hndl, Element, Data, & Status ) ELSE @@ -3284,7 +3284,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -3298,7 +3298,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -3444,7 +3444,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_td_real ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) ELSE @@ -3487,7 +3487,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -3501,7 +3501,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -3647,7 +3647,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_td_real ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) ELSE @@ -3692,7 +3692,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -3706,7 +3706,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -3852,7 +3852,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_td_real ( Hndl, Element, DateStr, Data, & locCount, Status ) ELSE @@ -3895,7 +3895,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -3909,7 +3909,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -4055,7 +4055,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_td_real ( Hndl, Element, DateStr, Data, & locCount, Status ) ELSE @@ -4100,7 +4100,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -4114,7 +4114,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_dom_td_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -4215,7 +4215,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) ELSE @@ -4258,7 +4258,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -4272,7 +4272,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_dom_td_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -4373,7 +4373,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) ELSE @@ -4418,7 +4418,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -4432,7 +4432,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_dom_td_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -4533,7 +4533,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) ELSE @@ -4576,7 +4576,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -4590,7 +4590,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_dom_td_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -4691,7 +4691,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_td_double ( Hndl, Element, DateStr, Data, & locCount, Status ) ELSE @@ -4736,7 +4736,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -4750,7 +4750,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -4851,7 +4851,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_td_integer ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) ELSE @@ -4894,7 +4894,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -4908,7 +4908,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -5009,7 +5009,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_td_integer ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) ELSE @@ -5054,7 +5054,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -5068,7 +5068,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -5169,7 +5169,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_td_integer ( Hndl, Element, DateStr, Data, & locCount, Status ) ELSE @@ -5212,7 +5212,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -5226,7 +5226,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -5327,7 +5327,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_td_integer ( Hndl, Element, DateStr, Data, & locCount, Status ) ELSE @@ -5372,7 +5372,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -5386,7 +5386,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -5487,7 +5487,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_td_logical ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) ELSE @@ -5530,7 +5530,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -5544,7 +5544,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -5645,7 +5645,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_td_logical ( Hndl, Element, DateStr, Data, & locCount, Outcount, Status ) ELSE @@ -5690,7 +5690,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -5704,7 +5704,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -5805,7 +5805,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_td_logical ( Hndl, Element, DateStr, Data, & locCount, Status ) ELSE @@ -5848,7 +5848,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -5862,7 +5862,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -5963,7 +5963,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_td_logical ( Hndl, Element, DateStr, Data, & locCount, Status ) ELSE @@ -6008,7 +6008,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -6022,7 +6022,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_dom_td_char_a Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -6123,7 +6123,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_dom_td_char ( Hndl, Element, DateStr, Data, & Status ) ELSE @@ -6168,7 +6168,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -6182,7 +6182,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_dom_td_char_a Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -6283,7 +6283,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_dom_td_char ( Hndl, Element, DateStr, Data, & Status ) ELSE @@ -6329,7 +6329,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -6343,7 +6343,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -6489,7 +6489,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_ti_real ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -6532,7 +6532,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -6546,7 +6546,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -6692,7 +6692,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_ti_real ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -6737,7 +6737,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -6751,7 +6751,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -6897,7 +6897,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_ti_real ( Hndl, Element, Varname, Data, & locCount, Status ) ELSE @@ -6940,7 +6940,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -6954,7 +6954,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -7100,7 +7100,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_ti_real ( Hndl, Element, Varname, Data, & locCount, Status ) ELSE @@ -7145,7 +7145,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -7159,7 +7159,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_var_ti_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -7260,7 +7260,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -7303,7 +7303,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -7317,7 +7317,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_var_ti_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -7418,7 +7418,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -7463,7 +7463,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -7477,7 +7477,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_var_ti_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -7578,7 +7578,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) ELSE @@ -7621,7 +7621,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -7635,7 +7635,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_var_ti_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -7736,7 +7736,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_ti_double ( Hndl, Element, Varname, Data, & locCount, Status ) ELSE @@ -7781,7 +7781,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -7795,7 +7795,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -7896,7 +7896,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_ti_integer ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -7939,7 +7939,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -7953,7 +7953,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -8054,7 +8054,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_ti_integer ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -8099,7 +8099,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -8113,7 +8113,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -8214,7 +8214,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_ti_integer ( Hndl, Element, Varname, Data, & locCount, Status ) ELSE @@ -8257,7 +8257,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -8271,7 +8271,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -8372,7 +8372,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_ti_integer ( Hndl, Element, Varname, Data, & locCount, Status ) ELSE @@ -8417,7 +8417,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -8431,7 +8431,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -8532,7 +8532,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_ti_logical ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -8575,7 +8575,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -8589,7 +8589,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -8690,7 +8690,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_ti_logical ( Hndl, Element, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -8735,7 +8735,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -8749,7 +8749,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -8850,7 +8850,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_ti_logical ( Hndl, Element, Varname, Data, & locCount, Status ) ELSE @@ -8893,7 +8893,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -8907,7 +8907,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -9008,7 +9008,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_ti_logical ( Hndl, Element, Varname, Data, & locCount, Status ) ELSE @@ -9053,7 +9053,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -9067,7 +9067,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_var_ti_char_a Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -9168,7 +9168,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_ti_char ( Hndl, Element, Varname, Data, & Status ) ELSE @@ -9213,7 +9213,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -9227,7 +9227,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_var_ti_char_a Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -9328,7 +9328,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_ti_char ( Hndl, Element, Varname, Data, & Status ) ELSE @@ -9374,7 +9374,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -9388,7 +9388,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -9534,7 +9534,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -9577,7 +9577,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -9591,7 +9591,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -9737,7 +9737,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_td_real ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -9782,7 +9782,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -9796,7 +9796,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -9942,7 +9942,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) ELSE @@ -9985,7 +9985,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -9999,7 +9999,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -10145,7 +10145,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_td_real ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) ELSE @@ -10190,7 +10190,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -10204,7 +10204,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_var_td_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -10305,7 +10305,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -10348,7 +10348,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -10362,7 +10362,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_var_td_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -10463,7 +10463,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -10508,7 +10508,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -10522,7 +10522,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_var_td_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -10623,7 +10623,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) ELSE @@ -10666,7 +10666,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -10680,7 +10680,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_var_td_double Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -10781,7 +10781,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_td_double ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) ELSE @@ -10826,7 +10826,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -10840,7 +10840,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -10941,7 +10941,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -10984,7 +10984,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -10998,7 +10998,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -11099,7 +11099,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_td_integer ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -11144,7 +11144,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -11158,7 +11158,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -11259,7 +11259,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) ELSE @@ -11302,7 +11302,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -11316,7 +11316,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -11417,7 +11417,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_td_integer ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) ELSE @@ -11462,7 +11462,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -11476,7 +11476,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -11577,7 +11577,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -11620,7 +11620,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -11634,7 +11634,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -11735,7 +11735,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_td_logical ( Hndl, Element, DateStr, Varname, Data, & locCount, Outcount, Status ) ELSE @@ -11780,7 +11780,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -11794,7 +11794,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -11895,7 +11895,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) ELSE @@ -11938,7 +11938,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -11952,7 +11952,7 @@ locCount = Count Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -12053,7 +12053,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_td_logical ( Hndl, Element, DateStr, Varname, Data, & locCount, Status ) ELSE @@ -12098,7 +12098,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -12112,7 +12112,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_get_var_td_char_a Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -12213,7 +12213,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_td_char ( Hndl, Element, DateStr, Varname, Data, & Status ) ELSE @@ -12258,7 +12258,7 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount INTEGER io_form , Hndl @@ -12272,7 +12272,7 @@ CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_put_var_td_char_a Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -12373,7 +12373,7 @@ IF ( Hndl .GT. -1 ) THEN #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_put_var_td_char ( Hndl, Element, DateStr, Varname, Data, & Status ) ELSE diff --git a/wrfv2_fire/arch/postamble_new b/wrfv2_fire/arch/postamble_new index 10c7cf9c..1738c3ef 100644 --- a/wrfv2_fire/arch/postamble_new +++ b/wrfv2_fire/arch/postamble_new @@ -14,6 +14,7 @@ ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZ CONFIGURE_GRIB2_FLAG \ CONFIGURE_RTTOV_FLAG \ CONFIGURE_CRTM_FLAG \ + CONFIGURE_CLOUDCV_FLAG \ CONFIGURE_4DVAR_FLAG \ CONFIGURE_WAVELET_FLAG \ CONFIGURE_NESTOPT \ @@ -137,7 +138,7 @@ fftpack : atm_ocn : ( cd $(WRF_SRC_ROOT_DIR)/external/atm_ocn ; \ make $(J) CC="$(SCC)" CFLAGS="$(CFLAGS) " RM="$(RM)" RANLIB="$(RANLIB)" \ - CPP="$(CPP)" \ + CPP="$(CPP)" CPPFLAGS="$(CPPFLAGS)" \ FC="$(DM_FC) $(PROMOTION) -I. $(FCDEBUG) $(FCBASEOPTS) $(FCSUFFIX)" TRADFLAG="-traditional" AR="$(AR)" ARFLAGS="$(ARFLAGS)" \ FIXED="$(FORMAT_FIXED)" ) diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_a_mozart_mosaic_4bin_vbs0.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/extra_args_to_update_rconst_cb05_sorg_aq.inc similarity index 100% rename from wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_a_mozart_mosaic_4bin_vbs0.inc rename to wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/extra_args_to_update_rconst_cb05_sorg_aq.inc diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_b_mozart_mosaic_4bin_vbs0.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/extra_args_update_rconst_cb05_sorg_aq.inc similarity index 100% rename from wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_b_mozart_mosaic_4bin_vbs0.inc rename to wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/extra_args_update_rconst_cb05_sorg_aq.inc diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_e_mozart_mosaic_4bin_vbs0.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/extra_decls_update_rconst_cb05_sorg_aq.inc similarity index 100% rename from wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_e_mozart_mosaic_4bin_vbs0.inc rename to wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/extra_decls_update_rconst_cb05_sorg_aq.inc diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_ia_mozart_mosaic_4bin_vbs0.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_a_cb05_sorg_aq.inc similarity index 100% rename from wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_ia_mozart_mosaic_4bin_vbs0.inc rename to wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_a_cb05_sorg_aq.inc diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_ib_mozart_mosaic_4bin_vbs0.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_b_cb05_sorg_aq.inc similarity index 100% rename from wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_ib_mozart_mosaic_4bin_vbs0.inc rename to wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_b_cb05_sorg_aq.inc diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_u_mozart_mosaic_4bin_vbs0.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_e_cb05_sorg_aq.inc similarity index 100% rename from wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_u_mozart_mosaic_4bin_vbs0.inc rename to wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_e_cb05_sorg_aq.inc diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ia_cb05_sorg_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ia_cb05_sorg_aq.inc new file mode 100644 index 00000000..e7d7a4d4 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ia_cb05_sorg_aq.inc @@ -0,0 +1,49 @@ +! +! couple CB05 with MADE/SORGAM, NCSU +! + + if(p_nu0.gt.1)then + + rxylho = ARR2(1.7D-11, -116.0_dp, TEMP); !ARR2(1.89D-11, -116.0_dp, TEMP); + rtolho = ARR2(1.8D-12, -355.0_dp, TEMP); !ARR2(2.1D-12, -322.0_dp, TEMP); + rcslho = 4.1D-11; !4.0D-11 ; + rcslno3 = 2.2D-11; + rhc8ho = 1.97D-11; !ARR2(3.64D-11, 380.0_dp, TEMP); + roliho = ARR2(1.0D-11, -550.0_dp, TEMP); !ARR2(1.07D-11, -549.0_dp, TEMP); + rolino3 = ARR2(9.6D-13, 270.0_dp, TEMP); !ARR2(3.23D-11, 975.0_dp, TEMP); + rolio3 = ARR2(8.4D-15, 1100.0_dp, TEMP); !ARR2(7.29D-15, 1136.0_dp, TEMP); + roltho = 3.2D-11; !ARR2(5.32D-12, -504.0_dp, TEMP); + roltno3 = ARR2(7.0D-13, 2160.0_dp, TEMP); !ARR2(1.0D-11, 1895.0_dp, TEMP); + rolto3 = ARR2(6.5D-15, 1900.0_dp, TEMP); !ARR2(1.32D-14, 2105.0_dp, TEMP); + rapiho = 5.37D-11; !ARR2(1.21D-11, -444.0_dp, TEMP); + rapino3 = 2.31D-12; !ARR2(1.19D-12, -490.0_dp, TEMP); + rapio3 = 8.66D-17; !ARR2(1.01D-15, 736.0_dp, TEMP); + rlimho = 1.71D-10; + rlimno3 = 1.22D-11; + rlimo3 = 2.00D-16; + + PRDROG(PXYL) = rxylho * var(ind_xyl)*var(ind_oh) + PRDROG(PTOL) = rtolho * var(ind_tol)*var(ind_oh) + PRDROG(PCSL1) = rcslho * var(ind_cres)*var(ind_oh) + PRDROG(PCSL2) = rcslno3* var(ind_cres)*var(ind_no3) + PRDROG(PHC8) = rhc8ho * var(ind_alkh)*var(ind_oh) + PRDROG(POLI1) = roliho * var(ind_iole)*var(ind_oh) + PRDROG(POLI2) = rolino3 * var(ind_iole)*var(ind_no3) + PRDROG(POLI3) = rolio3 * var(ind_iole)*var(ind_o3) + PRDROG(POLT1) = roltho * var(ind_ole)*var(ind_oh) + PRDROG(POLT2) = roltno3 * var(ind_ole)*var(ind_no3) + PRDROG(POLT3) = rolto3 * var(ind_ole)*var(ind_o3) + PRDROG(PAPI1) = rapiho * var(ind_apin)*var(ind_oh) + PRDROG(PAPI2) = rapino3 * var(ind_apin)*var(ind_no3) + PRDROG(PAPI3) = rapio3 * var(ind_apin)*var(ind_o3) + PRDROG(PLIM1) = rlimho * var(ind_lim)*var(ind_oh) + PRDROG(PLIM2) = rlimno3 * var(ind_lim)*var(ind_no3) + PRDROG(PLIM3) = rlimo3 * var(ind_lim)*var(ind_o3) + + DO n = 1, LDROG + VDROG3( i,k,j, n ) = oconv * PRDROG( n ) * DTSTEPC + VDROG3( i,k,j,n ) = MAX( 0., VDROG3( i,k,j, n ) ) + ENDDO + + endif + diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ib_cb05_sorg_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ib_cb05_sorg_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ib_cb05_sorg_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ibu_cb05_sorg_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ibu_cb05_sorg_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_ibu_cb05_sorg_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_l_cb05_sorg_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_l_cb05_sorg_aq.inc new file mode 100644 index 00000000..78d954f8 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_l_cb05_sorg_aq.inc @@ -0,0 +1,10 @@ +! +! couple CB05 with MADE/SORGAM, NCSU +! + + REAL(KIND=dp) :: rxylho,rtolho,rcslho,rcslno3,rhc8ho,roliho,rolino3, & + rolio3,roltho,roltno3,rolto3,rapiho,rapino3,rapio3, & + rlimho,rlimno3,rlimo3 + + REAL(KIND=dp) , DIMENSION(ldrog) :: PRDROG + diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_u_cb05_sorg_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_u_cb05_sorg_aq.inc new file mode 100644 index 00000000..4438aa6d --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_aq/kpp_mechd_u_cb05_sorg_aq.inc @@ -0,0 +1,8 @@ +! +! coupled CB05 with MADE/SORGAM, NCSU +! + + USE module_data_sorgam, ONLY : PXYL, PTOL, PCSL1, PCSL2, PHC8, & + POLI1, POLI2, POLI3, POLT1, POLT2, POLT3, PAPI1, PAPI2, & + PAPI3, PLIM1, PLIM2, PLIM3 + diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_args_to_update_rconst_cb05_sorg_vbs_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_args_to_update_rconst_cb05_sorg_vbs_aq.inc new file mode 100644 index 00000000..850fd363 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_args_to_update_rconst_cb05_sorg_vbs_aq.inc @@ -0,0 +1,2 @@ + rtdat_ae_so2, & +! diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_args_update_rconst_cb05_sorg_vbs_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_args_update_rconst_cb05_sorg_vbs_aq.inc new file mode 100644 index 00000000..ebce04bf --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_args_update_rconst_cb05_sorg_vbs_aq.inc @@ -0,0 +1,2 @@ +rtdat_ae_so2, & +! diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_decls_update_rconst_cb05_sorg_vbs_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_decls_update_rconst_cb05_sorg_vbs_aq.inc new file mode 100644 index 00000000..634a0986 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/extra_decls_update_rconst_cb05_sorg_vbs_aq.inc @@ -0,0 +1,2 @@ +REAL(KIND=dp) :: rtdat_ae_so2 +! diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_a_cb05_sorg_vbs_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_a_cb05_sorg_vbs_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_a_cb05_sorg_vbs_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_b_cb05_sorg_vbs_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_b_cb05_sorg_vbs_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_b_cb05_sorg_vbs_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_e_cb05_sorg_vbs_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_e_cb05_sorg_vbs_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_e_cb05_sorg_vbs_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ia_cb05_sorg_vbs_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ia_cb05_sorg_vbs_aq.inc new file mode 100644 index 00000000..0a6e0fc4 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ia_cb05_sorg_vbs_aq.inc @@ -0,0 +1,141 @@ +! RAR: modified to handle the new SOA mechanism based on the VBS approach and multi-generational +! VOC oxidation mechanism +! Correspondence among CB05, RACM, and SAPRC-99 SOA precursors +! KW CB05 RACM SAPRC99 +! 1) OLE -> OLT -> OLE1 +! 2) IOLE -> OLI -> OLE2 +! 3) TOL -> TOL -> ARO1 +! 4) XYL -> XYL -> ARO2 +! 5) CRES -> CSL -> ARO2 +! 6) PAR -> HC5 -> ALK4 !KW temporary setup +! 7) ALKH -> HC8 -> ALK5 +! 8) ISOP -> ISO -> ISO +! 9) APIN -> API -> TERP +! TERP +! BPIN +! OCI +!10) LIM -> LIM -> TERP +!11) HUM -> SESQ-> SESQ +! +if(p_nu0.gt.1)then + + ! OLE/OLT + rolto = RCONST(116) + roltho = RCONST(117) + rolto3 = RCONST(118) + roltno3 = RCONST(119) + + ! IOLE/OLI + rolio = RCONST(124) + roliho = RCONST(125) + rolio3 = RCONST(126) + rolino3 = RCONST(127) + + ! TOL/TOL + rtolho = RCONST(128) + + ! XYL/XYL + rxylho = RCONST(138) + + ! CRES/CSL + rcslho = RCONST(131) + rcslno3 = RCONST(132) + + ! PAR/HC5 + rhc5ho = RCONST(112) + + ! ALKH/HC8 + rhc8ho = RCONST(190) + + ! ISOP/ISO + risoo = RCONST(141) + risoho = RCONST(142) + risoo3 = RCONST(143) + risono3 = RCONST(144) + + ! APIN,BPIN,TERP,OCI/API + rapiho = RCONST(184) + rapio3 = RCONST(185) + rbpiho = RCONST(186) + rbpio3 = RCONST(187) + rbpino3 = RCONST(188) + rterpo = RCONST(149) + rterpho = RCONST(150) + rterpo3 = RCONST(151) + rterpno3= RCONST(152) + rociho = RCONST(183) + + ! LIM/LIM + rlimho = RCONST(182) + + ! HUM,SESQ + rsesqho = RCONST(181) + + ! XO2 radical + rxo2no = RCONST(54) + rxo2nno = RCONST(55) + rxo2ho2 = RCONST(56) + rxo2nho2 = RCONST(57) + rxo2co3 = RCONST(93) + rxo2cxo3 = RCONST(109) + rxo2xo2 = RCONST(58) + rxo2xo2n = RCONST(59) + rxo2nxo2n= RCONST(60) + + ! production from anthropogenic VOCs + PRDROG(PALK4)= 0.22*rhc5ho*var(ind_par)*var(ind_oh) + PRDROG(PALK5)= 0.36*rhc5ho*var(ind_par)*var(ind_oh)+rhc8ho*var(ind_alkh)*var(ind_oh) + + PRDROG(POLE1)= rolto*var(ind_ole)*var(ind_o)+roltho*var(ind_ole)*var(ind_oh) + rolto3*var(ind_ole)*var(ind_o3) + roltno3*var(ind_ole)*var(ind_no3) + PRDROG(POLE2)= rolio*var(ind_iole)*var(ind_o)+roliho*var(ind_iole)*var(ind_oh) + rolio3*var(ind_iole)*var(ind_o3) + rolino3*var(ind_iole)*var(ind_no3) + + PRDROG(PARO1)= rtolho*var(ind_tol)*var(ind_oh) + + PRDROG(PARO2)= rxylho*var(ind_xyl)*var(ind_oh) + PRDROG(PARO2)= PRDROG(PARO2) + rcslho*var(ind_cres)*var(ind_oh) + rcslno3*var(ind_cres)*var(ind_no3) + + ! Biogenic + PRDROG(PISOP)= risoo*var(ind_isop)*var(ind_o)+risoho*var(ind_isop)*var(ind_oh) + risoo3*var(ind_isop)*var(ind_o3) + risono3*var(ind_isop)*var(ind_no3) + + PRDROG(PTERP)= rterpo*var(ind_terp)*var(ind_o)+rterpho*var(ind_terp)*var(ind_oh) + rterpo3*var(ind_terp)*var(ind_o3) + rterpno3*var(ind_terp)*var(ind_no3) + PRDROG(PTERP)= PRDROG(PTERP) + rapiho*var(ind_apin)*var(ind_oh) + rapio3*var(ind_apin)*var(ind_o3) + PRDROG(PTERP)= PRDROG(PTERP) + rbpiho*var(ind_bpin)*var(ind_oh) + rbpio3*var(ind_bpin)*var(ind_o3) + rbpino3*var(ind_bpin)*var(ind_no3) + PRDROG(PTERP)= PRDROG(PTERP) + rociho*var(ind_oci)*var(ind_oh) + rlimho*var(ind_lim)*var(ind_oh) + + PRDROG(PSESQ)= rsesqho*var(ind_hum)*var(ind_oh) + +! RAR: to calculate the branching ratios to determine high NOx versus low NOx + + PRDROG(PBRCH)= rxo2no*var(ind_no)+rxo2nno*var(ind_no) + + ! VDROG carrying the branching ratios + if (PRDROG(PBRCH)>1.E-12) then + ro2loss= PRDROG(PBRCH) + rxo2ho2*var(ind_ho2) + rxo2nho2*var(ind_ho2) + rxo2co3*var(ind_c2o3) + rxo2cxo3*var(ind_cxo3) & + + rxo2xo2*var(ind_xo2) + rxo2xo2n*var(ind_xo2) + rxo2nxo2n*var(ind_xo2n) + VDROG3_VBS( i,k,j,LDROG_VBS )= MIN( 1.D0,(PRDROG(PBRCH)/ro2loss) ) + else + VDROG3_VBS( i,k,j,LDROG_VBS )= 0. + end if + + DO n = 1, LDROG_VBS-1 + VDROG3_VBS( i,k,j,n ) = oconv* PRDROG( n ) * DTSTEPC + VDROG3_VBS( i,k,j,n ) = MAX( 0., VDROG3_VBS( i,k,j,n ) ) + ENDDO +endif + +! RAR: debugging +!if (i==8 .AND. j==18) then +! if (k==1) then +! write(*,*)'rhch5ho',rhc5ho,'rhc8ho',rhc8ho,'rhc8ho',roltho,'roliho',roliho, & +! 'rtolho',rtolho,'rxylho',rxylho,'rsesqno3',rsesqno3 +! write(*,*)'ind_tol',ind_tol,'var(ind_tol)',var(ind_tol) +! write(*,*)'ind_ho',ind_ho,'var(ind_ho)',var(ind_ho) +! write(*,*)'ind_iso',ind_iso,'risoho',risoho +! write(*,*)'PRDROG(PBRCH)', PRDROG(PBRCH),'ro2loss=',ro2loss +! write(*,*)'VDROG3(8,1,18,:)', VDROG3(i,k,j,:) +! end if +!end if +! +!if (j==18 .AND. k==1) then +! write(*,*)'VDROG3(:,18,1,:)', VDROG3(i,k,j,:) +!end if diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ib_cb05_sorg_vbs_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ib_cb05_sorg_vbs_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ib_cb05_sorg_vbs_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ibu_cb05_sorg_vbs_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ibu_cb05_sorg_vbs_aq.inc new file mode 100644 index 00000000..56293b08 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_ibu_cb05_sorg_vbs_aq.inc @@ -0,0 +1,116 @@ +! +! Temperature and pressure + tempk = t_phy(i,k,j) + pressure = p_phy(i,k,j) +! print*,"in het chem, pressure=",pressure +! Heterogeneous reactions +! Cell number + NCELL = BLKSIZE + +! Rate constants for heterogeneous reactions on particles +! Gas-phase only, no aerosol present +! Update reaction rate constants + PMCONC ( : ) = 0.0 + PMNUM ( : ) = 0.0 + PMSG (1) = 1.7 + PMSG (2) = 2.0 + PMSG (3) = 2.5 +iphase = 1 +itype = 1 +! do itype=1,ntype_aer + DO INASEC = 1, NASECT-1 + l = lptr_so4_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_no3_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_cl_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_nh4_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_na_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_p25_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_orgpa_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_ec_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_asoa1_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_asoa2_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_asoa3_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_asoa4_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_bsoa1_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_bsoa2_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_bsoa3_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_bsoa4_aer(INASEC,itype,iphase) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + l = waterptr_aer(INASEC,itype) + if (l.gt.1) PMCONC ( INASEC ) = PMCONC ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + + l = numptr_aer(INASEC,itype,iphase) + if (l.gt.1) PMNUM ( INASEC ) = PMNUM ( INASEC ) & + + max ( chem(i,k,j,l), CMIN) + END DO + + itype = 2 + l = numptr_aer(1,itype,iphase) + if (l.gt.1) PMNUM ( 3 ) = PMNUM ( 3 ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_anth_aer(1,itype,iphase) + if (l.gt.1) PMCONC ( 3 ) = PMCONC ( 3 ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_seas_aer(1,itype,iphase) + if (l.gt.1) PMCONC ( 3 ) = PMCONC ( 3 ) & + + max ( chem(i,k,j,l), CMIN) + l = lptr_soil_aer(1,itype,iphase) + if (l.gt.1) PMCONC ( 3 ) = PMCONC ( 3 ) & + + max ( chem(i,k,j,l), CMIN) +! end do +! DRAT = ( DPUP / DPLOW ) ** ( 1.0 / REAL ( NASECT, KIND=sp) ) + DO INASEC = 1, NASECT + PMCONC ( INASEC ) = MAX(PMCONC(INASEC)*rho_phy(i,k,j),CMIN) + PMNUM ( INASEC ) = MAX(PMNUM(INASEC)*rho_phy(i,k,j),CMIN) + DPCTR ( INASEC ) = MAX(PMDGMIN,(6.0*PMCONC(INASEC)/DENSP & + /PMNUM(INASEC)/PI*1.0E+6 & + /exp(4.5*(log(PMSG(INASEC)))**2.0)) & + **(1.0/3.0)) +! DPCTR ( INASEC ) = ( 6.0 * ( PMCONC( INASEC ) / DENSP & +! / PMNUM( INASEC )* 1.0E+6 ) & +! / PI ) ** ( 1.0 / 3.0 ) +! DPLO = DPLOW * DRAT ** ( REAL ( INASEC, KIND=sp ) - 1.0 ) +! DPHI = DPLOW * DRAT ** REAL ( INASEC, KIND=sp ) +! if ( DPCTR ( INASEC ) .lt. DPLO ) DPCTR ( INASEC ) = DPLO +! if ( DPCTR ( INASEC ) .gt. DPHI ) DPCTR ( INASEC ) = DPHI + ! DPCTR ( INASEC ) = ( DPLOW * DRAT ** ( REAL ( INASEC, KIND=sp ) - 1.0 ) & + ! * DPLOW * DRAT ** REAL ( INASEC, KIND=sp ) ) ** 0.5 + END DO + + RTDAT_AE ( : ) = 0.0 + + CALL AERORATE_SO2( TEMPK, PRESSURE, RTDAT_AE( : ) ) + + rtdat_ae_so2 = REAL (RTDAT_AE( ISO2 ), KIND=dp) diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_l_cb05_sorg_vbs_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_l_cb05_sorg_vbs_aq.inc new file mode 100644 index 00000000..5f3e059f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_l_cb05_sorg_vbs_aq.inc @@ -0,0 +1,36 @@ +REAL(KIND=dp) :: rolto,roltho,rolto3,roltno3, & + rolio,roliho,rolio3,rolino3, & + rtolho,rxylho,rcslho,rcslno3, & + rhc5ho,rhc8ho, & + risoo,risoho,risoo3,risono3, & + rapiho,rapio3,rbpiho,rbpio3,rbpino3, & + rterpo,rterpho,rterpo3,rterpno3, & + rociho,rlimho,rsesqho, & + rxo2no,rxo2nno,rxo2ho2,rxo2nho2, & + rxo2co3,rxo2cxo3,rxo2xo2,rxo2xo2n,rxo2nxo2n + +REAL(KIND=dp) , DIMENSION(ldrog_vbs) :: PRDROG +REAL(KIND=dp) :: ro2loss + + REAL :: tempk + REAL :: pressure + + INTEGER, PARAMETER :: BLKSIZE = 1 + INTEGER :: NCELL + + REAL, PARAMETER :: CMIN = 1.001D-30 + REAL, PARAMETER :: PMDGMIN = 1.0D-9 + + REAL :: PMNUM ( NASECT ) + REAL :: PMSG ( NASECT ) + REAL :: DRAT + REAL :: DPLO + REAL :: DPHI + INTEGER :: iphase + INTEGER :: itype + INTEGER :: INASEC + INTEGER :: l + + REAL :: RTDAT_AE ( NRXNAERO ) + + REAL(KIND=dp) :: rtdat_ae_so2 diff --git a/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_u_cb05_sorg_vbs_aq.inc b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_u_cb05_sorg_vbs_aq.inc new file mode 100644 index 00000000..4d239804 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/cb05_sorg_vbs_aq/kpp_mechd_u_cb05_sorg_vbs_aq.inc @@ -0,0 +1,26 @@ +! + USE HETDATA + USE HETAERO + USE AERODATA + USE module_data_sorgam_vbs, ONLY: palk4,palk5,pole1,pole2,paro1,paro2,pisop,pterp,psesq,pbrch, & + lptr_so4_aer,lptr_no3_aer,lptr_cl_aer,lptr_nh4_aer,lptr_na_aer,lptr_p25_aer,lptr_orgpa_aer, & + lptr_ec_aer,lptr_asoa1_aer,lptr_asoa2_aer,lptr_asoa3_aer,lptr_asoa4_aer,lptr_bsoa1_aer, & + lptr_bsoa2_aer,lptr_bsoa3_aer,lptr_bsoa4_aer,waterptr_aer,numptr_aer,lptr_anth_aer, & + lptr_seas_aer,lptr_soil_aer +! +! +!INTEGER, PARAMETER :: palk4=1 +!INTEGER, PARAMETER :: palk5=2 +!INTEGER, PARAMETER :: pole1=3 +!INTEGER, PARAMETER :: pole2=4 +!INTEGER, PARAMETER :: paro1=5 +!INTEGER, PARAMETER :: paro2=6 + +! biogenic +!INTEGER, PARAMETER :: pisop=7 +!INTEGER, PARAMETER :: pterp=8 +!INTEGER, PARAMETER :: psesq=9 + +! for branching +!INTEGER, PARAMETER :: pbrch=10 +!USE module_data_soa_vbs, ONLY : palk4,palk5,pole1,pole2,paro1,paro2,pisop,pterp,psesq,pbrch diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/extra_args_to_update_rconst_mozart_mosaic_4bin_vbs0.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/extra_args_to_update_rconst_mozart_mosaic_4bin.inc similarity index 100% rename from wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/extra_args_to_update_rconst_mozart_mosaic_4bin_vbs0.inc rename to wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/extra_args_to_update_rconst_mozart_mosaic_4bin.inc diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/extra_args_update_rconst_mozart_mosaic_4bin_vbs0.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/extra_args_update_rconst_mozart_mosaic_4bin.inc similarity index 100% rename from wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/extra_args_update_rconst_mozart_mosaic_4bin_vbs0.inc rename to wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/extra_args_update_rconst_mozart_mosaic_4bin.inc diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/extra_decls_update_rconst_mozart_mosaic_4bin_vbs0.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/extra_decls_update_rconst_mozart_mosaic_4bin.inc similarity index 100% rename from wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/extra_decls_update_rconst_mozart_mosaic_4bin_vbs0.inc rename to wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/extra_decls_update_rconst_mozart_mosaic_4bin.inc diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_a_mozart_mosaic_4bin.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_a_mozart_mosaic_4bin.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_a_mozart_mosaic_4bin.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_b_mozart_mosaic_4bin.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_b_mozart_mosaic_4bin.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_b_mozart_mosaic_4bin.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_e_mozart_mosaic_4bin.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_e_mozart_mosaic_4bin.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_e_mozart_mosaic_4bin.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_ia_mozart_mosaic_4bin.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_ia_mozart_mosaic_4bin.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_ia_mozart_mosaic_4bin.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_ib_mozart_mosaic_4bin.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_ib_mozart_mosaic_4bin.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_ib_mozart_mosaic_4bin.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_ibu_mozart_mosaic_4bin_vbs0.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_ibu_mozart_mosaic_4bin.inc similarity index 100% rename from wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_ibu_mozart_mosaic_4bin_vbs0.inc rename to wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_ibu_mozart_mosaic_4bin.inc diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_l_mozart_mosaic_4bin_vbs0.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_l_mozart_mosaic_4bin.inc similarity index 100% rename from wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_vbs0/kpp_mechd_l_mozart_mosaic_4bin_vbs0.inc rename to wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_l_mozart_mosaic_4bin.inc diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_u_mozart_mosaic_4bin.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_u_mozart_mosaic_4bin.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin/kpp_mechd_u_mozart_mosaic_4bin.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_args_to_update_rconst_mozart_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_args_to_update_rconst_mozart_mosaic_4bin_aq.inc new file mode 100644 index 00000000..acec9db2 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_args_to_update_rconst_mozart_mosaic_4bin_aq.inc @@ -0,0 +1,5 @@ +! + rh, & + var(ind_NUME),var(ind_DEN), & +! + diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_args_update_rconst_mozart_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_args_update_rconst_mozart_mosaic_4bin_aq.inc new file mode 100644 index 00000000..f0c6eb55 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_args_update_rconst_mozart_mosaic_4bin_aq.inc @@ -0,0 +1,4 @@ +! + rh, & + nume,den, & +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_decls_update_rconst_mozart_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_decls_update_rconst_mozart_mosaic_4bin_aq.inc new file mode 100644 index 00000000..d56b70a1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/extra_decls_update_rconst_mozart_mosaic_4bin_aq.inc @@ -0,0 +1,10 @@ +! + real(kind=dp), intent(in) :: rh + REAL(KIND=dp), INTENT(IN) :: nume,den + + INTEGER, PARAMETER :: vbs_nbin = 4, vbs_nspec = 9, & + vbs_alk4 = 1, vbs_alk5 = 2, vbs_ole1 = 3, & + vbs_ole2 = 4, vbs_aro1 = 5, vbs_aro2 = 6, & + vbs_isop = 7, vbs_sesq = 8, vbs_terp = 9, & + vbs_c1 = 1, vbs_c10 = 2, vbs_c100 = 3, & + vbs_c1000 = 4 diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_a_mozart_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_a_mozart_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_a_mozart_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_b_mozart_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_b_mozart_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_b_mozart_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_e_mozart_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_e_mozart_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_e_mozart_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ia_mozart_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ia_mozart_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ia_mozart_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ib_mozart_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ib_mozart_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ib_mozart_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ibu_mozart_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ibu_mozart_mosaic_4bin_aq.inc new file mode 100644 index 00000000..10c7aeb9 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_ibu_mozart_mosaic_4bin_aq.inc @@ -0,0 +1,11 @@ +! +! calculate relative humidity +! + + es = 1000._dp*0.6112_dp*exp(17.67_dp*(t_phy(i,k,j)-273.15_dp)/(t_phy(i,k,j)- 29.65_dp)) + qvs = es / ( p_phy(i,k,j) - es ) + + + rh = moist(i,k,j,P_QV) / qvs + rh = MIN ( MAX ( rh, 0._dp), 1._dp) + diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_l_mozart_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_l_mozart_mosaic_4bin_aq.inc new file mode 100644 index 00000000..47906b4d --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_l_mozart_mosaic_4bin_aq.inc @@ -0,0 +1,2 @@ +! + REAL(kind=dp) :: es, qvs, rh diff --git a/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_u_mozart_mosaic_4bin_aq.inc b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_u_mozart_mosaic_4bin_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/mozart_mosaic_4bin_aq/kpp_mechd_u_mozart_mosaic_4bin_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/atoms_red similarity index 100% rename from wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/atoms_red rename to wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/atoms_red diff --git a/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.def b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.def new file mode 100755 index 00000000..d618a1b5 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.def @@ -0,0 +1,22 @@ +#include atoms_red +#include ./cb05_sorg_aq.spc +#include ./cb05_sorg_aq.eqn + + + + +#INLINE F90_RATES +REAL(KIND=dp) FUNCTION k46( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=7.2E-15_dp * EXP(785._dp/TEMP) + k2=4.1E-16_dp * EXP(1440._dp/TEMP) + k3=1.9E-33_dp * EXP(725._dp/TEMP) + + k46=k0+k3/(1+k3/k2) + + +END FUNCTION k46 +#ENDINLINE + diff --git a/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.eqn b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.eqn new file mode 100755 index 00000000..25f4f78f --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.eqn @@ -0,0 +1,370 @@ +#EQUATIONS { CB05 MADE/SORG Extension, Implemented by NCSU, Sep 2014} +//********************************************************************* +//The former rate constant corresponds that for the following reaction in original version of CB05 in CMAQ: +//< R34> HO2 + HO2 = H2O2. But CMAQ uses an older rate constant of (EP3(2.3D-13, 600.0, 1.7D-33, 1000.0, TEMP, C_M). +//An updated rate constant of (EP3(2.3D-13, 600.0, 1.7D-33, 1000.0, TEMP, C_M) * ARR2(1.4D-21, 2200.0_dp, TEMP) comes from +//Jacobson's book (2005), Table B.4, reaction 33: HO2 + HO2 = H2O2 + O2. +// +//Additions of Cl equations from CMAQ's CB05 with Cl extension, and also Hg reactions added +//********************************************************************* +< R1> NO2 + hv = NO + O : j(Pj_no2); +< R2> O {+ O2 + M} = O3 {+ M} : 0.21*C_M*C_M*ARR(6.0D-34, 0.0_dp, -2.4_dp, TEMP); +< R3> O3 + NO = NO2 {+ O2} : ARR2(3.0D-12, 1500.0_dp, TEMP); +< R4> O + NO2 = NO {+ O2} : ARR2(5.6D-12, -180.0_dp, TEMP); +< R5> O + NO2 {+ M} = NO3 {+ M} : TROE(2.5D-31, 1.8_dp, 2.2D-11, 0.7_dp, TEMP, C_M); +< R6> O + NO {+ M} = NO2 {+ M} : TROE(9.0D-32, 1.5_dp, 3.0D-11, 0.0_dp, TEMP, C_M); +< R7> NO2 + O3 = NO3 {+ O2} : ARR2(1.2D-13, 2450.0_dp, TEMP); +< R8> O3 + hv = O {+ O2} : j(Pj_o33p); +< R9> O3 + hv = O1D {+ O2} : j(Pj_o31d); +< R10> O1D + M = O + M : ARR2(2.1D-11, -102.0_dp, TEMP); +< R11> O1D + H2O = 2 OH : 2.2D-10; +< R12> O3 + OH = HO2 {+ O2} : ARR2(1.7D-12, 940.0_dp, TEMP); +< R13> O3 + HO2 = OH {+ 2 O2} : ARR2(1.0D-14, 490.0_dp, TEMP); +< R14> NO3 + hv = NO2 + O : j(Pj_no3o); +< R15> NO3 + hv = NO {+ O2} : j(Pj_no3o2); +< R16> NO3 + NO = 2 NO2 : ARR2(1.5D-11, -170.0_dp, TEMP); +< R17> NO3 + NO2 = NO + NO2 {+ O2} : ARR2(4.5D-14, 1260.0_dp, TEMP); +< R18> NO3 + NO2 {+ M} = N2O5 {+ M} : TROE(2.0D-30, 4.4_dp, 1.4D-12, 0.7_dp, TEMP, C_M); +< R19> N2O5 + H2O = 2 HNO3 : 2.5D-22; +< R20> N2O5 + H2O + H2O = 2 HNO3 : 1.8D-39; +< R21> N2O5 = NO3 + NO2 : FALL(1.0D-03, 11000.0_dp, -3.5_dp, 9.7D14, 11080.0_dp, 0.1_dp, 0.45_dp, TEMP, C_M); +< R22> NO + NO {+0.21M} = 2 NO2 : ARR2(3.3D-39, -530.0_dp, TEMP)*0.21*C_M; +< R23> NO + NO2 + H2O = 2 HONO : 5.0D-40; +< R24> NO + OH = HONO : TROE(7.0D-31, 2.6_dp, 3.6D-11, 0.1_dp, TEMP, C_M); +< R25> HONO + hv = NO + OH : j(Pj_hno2); +< R26> OH + HONO = NO2 {+ H2O} : ARR2(1.8D-11, 390.0_dp, TEMP); +< R27> HONO + HONO = NO + NO2 : 1.0D-20; +< R28> NO2 + OH = HNO3 : TROE(2.0D-30, 3.0_dp, 2.5D-11, 0.0_dp, TEMP, C_M); +< R29> OH + HNO3 = NO3 : EP2(2.4D-14, -460.0_dp, 2.7D-17, -2199.0_dp, 6.5D-34, -1335.0_dp, TEMP, C_M); +< R30> HO2 + NO = OH + NO2 : ARR2(3.5D-12, -250.0_dp, TEMP); +< R31> HO2 + NO2 = PNA : TROE(1.8D-31, 3.2_dp, 4.7D-12, 0.0_dp, TEMP, C_M); +< R32> PNA = HO2 + NO2 : FALL(4.1D-05, 10650.0_dp, 0.0_dp, 4.8D15, 11170.0_dp, 0.0_dp, 0.6_dp, TEMP, C_M); +< R33> OH + PNA = NO2 : ARR2(1.3D-12, -380.0_dp, TEMP); +< R34> HO2 + HO2 = H2O2 : EP3(2.3D-13, -600.0_dp, 1.7D-33, -1000.0_dp, TEMP, C_M); +< R35> HO2 + HO2 + H2O = H2O2 : EP3(3.22D-34, -2800.0_dp, 2.38D-54, -3200.0_dp, TEMP, C_M); +< R36> H2O2 + hv = 2 OH : j(Pj_h2o2); +< R37> OH + H2O2 = HO2 {+ H2O} : ARR2(2.9D-12, 160.0_dp, TEMP); +< R38> O1D + H2 = OH + HO2 : 1.1D-10; +< R39> OH + H2 = HO2 : ARR2(5.5D-12, 2000.0_dp, TEMP); +< R40> OH + O = HO2 : ARR2(2.2D-11, -120.0_dp, TEMP); +< R41> OH + OH = O : ARR2(4.2D-12, 240.0_dp, TEMP); +< R42> OH + OH = H2O2 : TROE(6.9D-31, 1.0_dp, 2.6D-11, 0.0_dp, TEMP, C_M); +< R43> OH + HO2 = H2O {+ O2} : ARR2(4.8D-11, -250.0_dp, TEMP); +< R44> HO2 + O = OH {+ O2} : ARR2(3.0D-11, -200.0_dp, TEMP); +< R45> H2O2 + O = OH + HO2 : ARR2(1.4D-12, 2000.0_dp, TEMP); +< R46> NO3 + O = NO2 {+ O2} : 1.0D-11; +< R47> NO3 + OH = HO2 + NO2 : 2.2D-11; +< R48> NO3 + HO2 = HNO3 {+ O2} : 3.5D-12; +< R49> NO3 + O3 = NO2 {+ 2 O2} : 1.0D-17; +< R50> NO3 + NO3 = 2 NO2 {+ O2} : ARR2(8.5D-13, 2450.0_dp, TEMP); +< R51> PNA + hv = 0.61 HO2 + 0.61 NO2 + + 0.39 OH + 0.39 NO3 : j(Pj_hno4); +< R52> HNO3 + hv = OH + NO2 : j(Pj_hno3); +< R53> N2O5 + hv = NO2 + NO3 : j(Pj_n2o5); +< R54> XO2 + NO = NO2 {+ XO} : ARR2(2.6D-12, -365.0_dp, TEMP); +< R55> XO2N + NO = NTR : ARR2(2.6D-12, -365.0_dp, TEMP); +< R56> XO2 + HO2 = ROOH : ARR2(7.5D-13, -700.0_dp, TEMP); +< R57> XO2N + HO2 = ROOH : ARR2(7.5D-13, -700.0_dp, TEMP); +< R58> XO2 + XO2 = 0.21 M : 6.8D-14; +< R59> XO2N + XO2N = 0.21 M : 6.8D-14; +< R60> XO2 + XO2N = 0.21 M : 6.8D-14; +< R61> NTR + OH = HNO3 + HO2 + + 0.33 FORM + 0.33 ALD2 + + 0.33 ALDX - 0.66 PAR : ARR2(5.9D-13, 360.0_dp, TEMP); +< R62> NTR + hv = NO2 + HO2 + + 0.33 FORM + 0.33 ALD2 + + 0.33 ALDX - 0.66 PAR : 1.0D-4*j(Pj_no2); +< R63> ROOH + OH = XO2 + 0.50 ALD2 + + 0.50 ALDX : ARR2(3.01D-12, -190.0_dp, TEMP); +< R64> ROOH + hv = OH + HO2 + + 0.50 ALD2 + 0.50 ALDX : 0.7 *j(Pj_h2o2); +< R65> OH + CO = HO2 : EP3(1.44D-13, 0.0_dp, 3.43D-33, 0.0_dp, TEMP, C_M); +< R66> OH + CH4 = MEO2 : ARR2(2.45D-12, 1775.0_dp, TEMP); +< R67> MEO2 + NO = FORM + HO2 + NO2 : ARR2(2.8D-12, -300.0_dp, TEMP); +< R68> MEO2 + HO2 = MEPX : ARR2(4.1D-13, -750.0_dp, TEMP); +< R69> MEO2 + MEO2 = 1.37 FORM + 0.74 HO2 + + 0.63 MEOH : ARR2(9.5D-14, -390.0_dp, TEMP); +< R70> MEPX + OH = 0.70 MEO2 + 0.30 XO2 + + 0.30 HO2 : ARR2(3.8D-12, -200.0_dp, TEMP); +< R71> MEPX + hv = FORM + HO2 + OH : 0.7 *j(Pj_h2o2); +< R72> MEOH + OH = FORM + HO2 : ARR2(7.3D-12, 620.0_dp, TEMP); +< R73> FORM + OH = HO2 + CO : 9.0D-12; +< R74> FORM + hv = 2.000 HO2 + CO : j(Pj_ch2or); +< R75> FORM + hv = CO : j(Pj_ch2om); +< R76> FORM + O = OH + HO2 + CO : ARR2(3.4D-11, 1600.0_dp, TEMP); +< R77> FORM + NO3 = HNO3 + HO2 + CO : 5.8D-16; +< R78> FORM + HO2 = HCO3 : ARR2(9.7D-15, -625.0_dp, TEMP); +< R79> HCO3 = FORM + HO2 : ARR2(2.4D+12, 7000.0_dp, TEMP); +< R80> HCO3 + NO = FACD + NO2 + HO2 : 5.6D-12; +< R81> HCO3 + HO2 = MEPX : ARR2(5.6D-15, -2300.0_dp, TEMP); +< R82> FACD + OH = HO2 : 4.0D-13; +< R83> ALD2 + O = C2O3 + OH : ARR2(1.8D-11, 1100.0_dp, TEMP); +< R84> ALD2 + OH = C2O3 : ARR2(5.6D-12, -270.0_dp, TEMP); +< R85> ALD2 + NO3 = C2O3 + HNO3 : ARR2(1.4D-12, 1900.0_dp, TEMP); +< R86> ALD2 + hv = MEO2 + CO + HO2 : 4.6D-4*j(Pj_no2); +< R87> C2O3 + NO = MEO2 + NO2 : ARR2(8.1D-12, -270.0_dp, TEMP); +< R88> C2O3 + NO2 = PAN : FALL(2.7D-28, 0.0_dp, -7.1_dp, 1.2D-11, 0.0_dp, -0.9_dp, 0.3_dp, TEMP, C_M); +< R89> PAN = C2O3 + NO2 : FALL(4.9D-03, 12100.0_dp, 0.0_dp, 5.4D16, 13830.0_dp, 0.0_dp, 0.3_dp, TEMP, C_M); +< R90> PAN + hv = C2O3 + NO2 : j(Pj_pan); +< R91> C2O3 + HO2 = 0.80 PACD + 0.20 AACD + + 0.20 O3 : ARR2(4.3D-13, -1040.0_dp, TEMP); +< R92> C2O3 + MEO2 = 0.90 MEO2 + 0.90 HO2 + + FORM + 0.10 AACD : ARR2(2.0D-12, -500.0_dp, TEMP); +< R93> C2O3 + XO2 = 0.90 MEO2 + 0.10 AACD : ARR2(4.4D-13, -1070.0_dp, TEMP); +< R94> C2O3 + C2O3 = 2.00 MEO2 : ARR2(2.9D-12, -500.0_dp, TEMP); +< R95> PACD + OH = C2O3 : ARR2(4.0D-13, -200.0_dp, TEMP); +< R96> PACD + hv = MEO2 + OH : 0.0*0.7 *j(Pj_h2o2); +< R97> AACD + OH = MEO2 : ARR2(4.0D-13, -200.0_dp, TEMP); +< R98> ALDX + O = CXO3 + OH : ARR2(1.3D-11, 870.0_dp, TEMP); +< R99> ALDX + OH = CXO3 : ARR2(5.1D-12, -405.0_dp, TEMP); + ALDX + NO3 = CXO3 + HNO3 : 6.5D-15; + ALDX + hv = MEO2 + CO + HO2 : j(Pj_ch3cho); + CXO3 + NO = ALD2 + NO2 + + HO2 + XO2 : ARR2(6.7D-12, -340.0_dp, TEMP); + CXO3 + NO2 = PANX : FALL(2.7D-28, 0.0_dp, -7.1_dp, 1.2D-11, 0.0_dp, -0.9_dp, 0.3_dp, TEMP, C_M); + PANX = CXO3 + NO2 : FALL(4.9D-03, 12100.0_dp, 0.0_dp, 5.4D16, 13830.0_dp, 0.0_dp, 0.3_dp, TEMP, C_M); + PANX + hv = CXO3 + NO2 : j(Pj_pan); + PANX + OH = ALD2 + NO2 : 3.0D-13; + CXO3 + HO2 = 0.80 PACD + 0.20 AACD + + 0.20 O3 : ARR2(4.3D-13, -1040.0_dp, TEMP); + CXO3 + MEO2 = 0.90 ALD2 + 0.90 XO2 + + HO2 + 0.10 AACD + + 0.10 FORM : ARR2(2.0D-12, -500.0_dp, TEMP); + CXO3 + XO2 = 0.90 ALD2 + 0.10 AACD : ARR2(4.4D-13, -1070.0_dp, TEMP); + CXO3 + CXO3 = 2.00 ALD2 + 2.00 XO2 + + 2.00 HO2 : ARR2(2.9D-12, -500.0_dp, TEMP); + CXO3 + C2O3 = MEO2 + XO2 + + HO2 + ALD2 : ARR2(2.9D-12, -500.0_dp, TEMP); + PAR + OH = 0.87 XO2 + 0.13 XO2N + + 0.11 HO2 + 0.06 ALD2 + - 0.11 PAR + 0.76 ROR + + 0.05 ALDX : 8.1D-13; + ROR = 0.96 XO2 + 0.60 ALD2 + + 0.94 HO2 - 2.10 PAR + + 0.04 XO2N + 0.02 ROR + + 0.50 ALDX : ARR2(1.0D15, 8000.0_dp, TEMP); + ROR = HO2 : 1.6E+03; + ROR + NO2 = NTR : 1.5D-11; + O + OLE = 0.20 ALD2 + 0.30 ALDX + + 0.30 HO2 + 0.20 XO2 + + 0.20 CO + 0.20 FORM + + 0.01 XO2N + 0.20 PAR + + 0.10 OH : ARR2(1.0D-11, 280.0_dp, TEMP); + OH + OLE = 0.80 FORM + 0.33 ALD2 + + 0.62 ALDX + 0.80 XO2 + + 0.95 HO2 - 0.70 PAR : 3.2D-11; + O3 + OLE = 0.18 ALD2 + 0.74 FORM + + 0.32 ALDX + 0.22 XO2 + + 0.10 OH + 0.33 CO + + 0.44 HO2 - 1.00 PAR : ARR2(6.5D-15, 1900.0_dp, TEMP); + NO3 + OLE = NO2 + FORM + + 0.91 XO2 + 0.09 XO2N + + 0.56 ALDX + 0.35 ALD2 + - 1.00 PAR : ARR2(7.0D-13, 2160.0_dp, TEMP); + O + ETH = FORM + 1.70 HO2 + + CO + 0.70 XO2 + + 0.30 OH : ARR2(1.04D-11, 792.0_dp, TEMP); + OH + ETH = XO2 + 1.56 FORM + + 0.22 ALDX + HO2 : TROE(1.0D-28, 0.8_dp, 8.8D-12, 0.0_dp, TEMP, C_M); + O3 + ETH = FORM + 0.63 CO + + 0.13 HO2 + 0.13 OH + + 0.37 FACD : ARR2(1.2D-14, 2630.0_dp, TEMP); + NO3 + ETH = NO2 + XO2 + + 2.0 FORM : ARR2(3.3D-12, 2880.0_dp, TEMP); + IOLE + O = 1.24 ALD2 + 0.66 ALDX + + 0.10 HO2 + 0.10 XO2 + + 0.10 CO + 0.10 PAR : 2.3D-11; + IOLE + OH = 1.30 ALD2 + 0.70 ALDX + + HO2 + XO2 : ARR2(1.0D-11, -550.0_dp, TEMP); + IOLE + O3 = 0.65 ALD2 + 0.35 ALDX + + 0.25 FORM + 0.25 CO + + 0.50 O + 0.50 OH + + 0.50 HO2 : ARR2(8.4D-15, 1100.0_dp, TEMP); + IOLE + NO3 = 1.18 ALD2 + 0.64 ALDX + + HO2 + NO2 : ARR2(9.6D-13, 270.0_dp, TEMP); + TOL + OH = 0.44 HO2 + 0.08 XO2 + + 0.36 CRES + 0.56 TO2 + + 0.071 TOLAER1 + + 0.138 TOLAER2 : ARR2(1.8D-12, -355.0_dp, TEMP); + TO2 + NO = 0.90 NO2 + 0.90 HO2 + + 0.90 OPEN + 0.10 NTR : 8.1D-12; + TO2 = CRES + HO2 : 4.2; + OH + CRES = 0.40 CRO + 0.60 XO2 + + 0.60 HO2 + 0.30 OPEN + + CSLAER : 4.1D-11; + CRES + NO3 = CRO + HNO3 + CSLAER : 2.2D-11; + CRO + NO2 = NTR : 1.4D-11; + CRO + HO2 = CRES : 5.5D-12; + OPEN + hv = C2O3 + HO2 + CO : 9.0 *j(Pj_ch2or); + OPEN + OH = XO2 + 2.0 CO + + 2.00 HO2 + C2O3 + FORM : 3.0D-11; + OPEN + O3 = 0.03 ALDX + 0.62 C2O3 + + 0.70 FORM + 0.03 XO2 + + 0.69 CO + 0.08 OH + + 0.76 HO2 + 0.20 MGLY : ARR2(5.4D-17, 500.0_dp, TEMP); + OH + XYL = 0.70 HO2 + 0.50 XO2 + + 0.20 CRES + 0.80 MGLY + + 1.10 PAR + 0.30 TO2 + + 0.038 XYLAER1 + + 0.167 XYLAER2 : ARR2(1.7D-11, -116.0_dp, TEMP); + OH + MGLY = XO2 + C2O3 : 1.7D-11; + + MGLY + hv = C2O3 + HO2 + CO : 9.64 *j(Pj_ch2or); + O + ISOP = 0.75 ISPD + 0.50 FORM + + 0.25 XO2 + 0.25 HO2 + + 0.25 CXO3 + + 0.232 ISOAER1 + + 0.0228 ISOAER2 : 3.6D-11; + OH + ISOP = 0.912 ISPD + 0.629 FORM + + 0.991 XO2 + 0.912 HO2 + + 0.088 XO2N + + 0.232 ISOAER1 + + 0.0288 ISOAER2 : ARR2(2.54D-11, -407.6_dp, TEMP); + O3 + ISOP = 0.650 ISPD + 0.600 FORM + + 0.200 XO2 + 0.066 HO2 + + 0.266 OH + 0.200 CXO3 + + 0.150 ALDX + 0.350 PAR + + 0.066 CO + + 0.232 ISOAER1 + + 0.0288 ISOAER2 : ARR2(7.86D-15, 1912.0_dp, TEMP); + NO3 + ISOP = 0.200 ISPD + 0.800 NTR + + XO2 + 0.800 HO2 + + 0.200 NO2 + 0.800 ALDX + + 0.232 ISOAER1 + + 0.0288 ISOAER2 : ARR2(3.03D-12, 448.0_dp, TEMP); + OH + ISPD = 1.565 PAR + 0.167 FORM + + 0.713 XO2 + 0.503 HO2 + + 0.334 CO + 0.168 MGLY + + 0.252 ALD2 + 0.210 C2O3 + + 0.250 CXO3 + 0.120 ALDX : 3.36D-11; + O3 + ISPD = 0.114 C2O3 + 0.150 FORM + + 0.850 MGLY + 0.154 HO2 + + 0.268 OH + 0.064 XO2 + + 0.020 ALD2 + 0.360 PAR + + 0.225 CO : 7.1D-18; + NO3 + ISPD = 0.357 ALDX + 0.282 FORM + + 1.282 PAR + 0.925 HO2 + + 0.643 CO + 0.850 NTR + + 0.075 CXO3 + 0.075 XO2 + + 0.150 HNO3 : 1.0D-15; + ISPD + hv = 0.333 CO + 0.067 ALD2 + + 0.900 FORM + 0.832 PAR + + 1.033 HO2 + 0.700 XO2 + + 0.967 C2O3 : 0.0036*0.025 *j(Pj_ch2om); + TERP + O = 0.150 OH + 5.12 PAR + + TERPAER : 3.6D-11; + TERP + OH = 0.750 HO2 + 1.250 XO2 + + 0.250 XO2N + 0.280 FORM + + 1.66 PAR + 0.470 ALDX + + TERPAER : ARR2(1.5D-11, -449.0_dp, TEMP); + TERP + O3 = 0.570 OH + 0.070 HO2 + + 0.760 XO2 + 0.180 XO2N + + 0.240 FORM + 0.001 CO + + 7.000 PAR + 0.210 ALDX + + 0.390 CXO3 + + TERPAER : ARR2(1.2D-15, 821.0_dp, TEMP); + TERP + NO3 = 0.470 NO2 + 0.280 HO2 + + 1.030 XO2 + 0.250 XO2N + + 0.470 ALDX + 0.530 NTR + + TERPAER : ARR2(3.7D-12, -175.0_dp, TEMP); + SO2 + OH = SULF + HO2 + SULAER : TROE(3.3D-31, 4.3_dp, 1.6D-12, 0.0_dp, TEMP, C_M); + OH + ETOH = HO2 + 0.900 ALD2 + + 0.050 ALDX + 0.100 FORM + + 0.100 XO2 : ARR2(6.9D-12, 230.0_dp, TEMP); + OH + ETHA = 0.991 ALD2 + 0.991 XO2 + + 0.009 XO2N + HO2 : ARR2(8.7D-12, 1070.0_dp, TEMP); + NO2 + ISOP = 0.200 ISPD + 0.800 NTR + + XO2 + 0.800 HO2 + + 0.200 NO + 0.800 ALDX + + 2.400 PAR : 1.5D-19; + CL2 + hv = 2.000 CL : j(Pj_cl2); + HOCL + hv = OH + CL : j(Pj_hocl); + CL + O3 = CLO : ARR2(2.3D-11, 200.0_dp, TEMP); + CLO + CLO = 0.300 CL2 + 1.400 CL : 1.63D-14; + CLO + NO = CL + NO2 : ARR2(6.4D-12, -290.0_dp, TEMP); + CLO + HO2 = HOCL : ARR2(2.7D-12, -220.0_dp, TEMP); + OH + FMCL = CL + CO : 5.0D-13; + FMCL + hv = CL + CO + HO2 : j(Pj_fmcl); + CL + CH4 = HCL + MEO2 : ARR2(6.6D-12, 1240.0_dp, TEMP); + CL + PAR = HCL + + 0.870 XO2 + + 0.130 XO2N + + 0.110 HO2 + + 0.060 ALD2 + - 0.110 PAR + + 0.760 ROR + + 0.050 ALDX : 5.0D-11; + CL + ETHA = HCL + + 0.991 ALD2 + + 0.991 XO2 + + 0.009 XO2N + + HO2 : ARR2(8.3D-11, 100.0_dp, TEMP); + CL + ETH = FMCL + + 2.000 XO2 + + 1.000 HO2 + + 1.000 FORM : 1.07D-10; + CL + OLE = FMCL + + 0.330 ALD2 + + 0.670 ALDX + + 2.000 XO2 + + 1.000 HO2 + - 1.000 PAR : 2.5D-10; + CL + IOLE = 0.300 HCL + + 0.700 FMCL + + 0.450 ALD2 + + 0.550 ALDX + + 0.300 OLE + + 0.300 PAR + + 1.700 XO2 + + 1.000 HO2 : 3.5D-10; + CL + ISOP = 0.15 HCL + + 1.000 XO2 + + 1.000 HO2 + + 0.850 FMCL + + 1.000 ISPD : 4.3D-10; + CL + FORM = HCL + + 1.000 HO2 + + 1.000 CO : ARR2(8.2D-11, 34.0_dp, TEMP); + CL + ALD2 = HCL + + 1.000 C2O3 : 7.9D-11; + CL + ALDX = HCL + + 1.000 CXO3 : 1.3D-10; + CL + MEOH = HCL + + 1.000 HO2 + + 1.000 FORM : 5.5D-11; + CL + ETOH = HCL + + 1.000 HO2 + + 1.000 ALD2 : ARR2(8.2D-11, -45.0_dp, TEMP); + HCL + OH = CL : ARR(6.58D-13, -58.0_dp, 1.16_dp, TEMP); + HG0 + O3 = HG2 : 3.0D-20; + HG0 + OH = HG2 : 8.7D-14; + HG0 + H2O2 = HG2 : 8.5D-19; + HUM + OH = HUMAER + OH : 2.93D-10; + LIM + OH = 0.239 LIMAER1 + + 0.363 LIMAER2 + + OH : 1.71D-10; + OCI + OH = 0.045 OCIAER1 + + 0.149 OCIAER2 + + OH : 2.52D-10; + APIN + OH = 0.038 APINAER1 + + 0.326 APINAER2 + + OH : 5.37D-11; + APIN + O3 = 0.125 APINAER3 + + 0.102 APINAER4 + + O3 : 8.66D-17; + BPIN + OH = 0.13 BPINAER1 + + 0.0406 BPINAER2 + + OH : 7.89D-11; + BPIN + O3 = 0.026 BPINAER3 + + 0.485 BPINAER4 + + O3 : 1.36D-17; + BPIN + NO3 = BPINAER5 + NO3 : 2.31D-12; + TER + OH = 0.091 TERAER1 + + 0.367 TERAER2 + + OH : 2.7D-10; + ALKH + OH = 1.173 ALKHAER1 + + OH : 1.97D-11; + PAH + OH = 0.156 PAHAER1 + + 0.777 PAHAER2 + + OH : 7.7D-11; + diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.kpp b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.kpp similarity index 82% rename from wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.kpp rename to wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.kpp index c3bd1bc5..53f6edbd 100644 --- a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.kpp +++ b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.kpp @@ -1,4 +1,4 @@ -#MODEL mozart_mosaic_4bin_vbs0 +#MODEL cb05_sorg_aq #LANGUAGE Fortran90 #DOUBLE ON #INTEGRATOR WRF_conform/rosenbrock @@ -9,3 +9,4 @@ #WRFCONFORM + diff --git a/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.spc b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.spc new file mode 100755 index 00000000..a0e1fb46 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq.spc @@ -0,0 +1,101 @@ +#DEFVAR + no2 =IGNORE ; + no =IGNORE ; + o =IGNORE ; + o3 =IGNORE ; + no3 =IGNORE ; + o1d =IGNORE ; + oh =IGNORE ; + ho2 =IGNORE ; + n2o5 =IGNORE ; + hno3 =IGNORE ; + hono =IGNORE ; + pna =IGNORE ; + h2o2 =IGNORE ; + xo2 =IGNORE ; + xo2n =IGNORE ; + ntr =IGNORE ; + rooh =IGNORE ; + form =IGNORE ; + ald2 =IGNORE ; + aldx =IGNORE ; + par =IGNORE ; + co =IGNORE ; + meo2 =IGNORE ; + mepx =IGNORE ; + meoh =IGNORE ; + hco3 =IGNORE ; + facd =IGNORE ; + c2o3 =IGNORE ; + pan =IGNORE ; + pacd =IGNORE ; + aacd =IGNORE ; + cxo3 =IGNORE ; + panx =IGNORE ; + ror =IGNORE ; + ole =IGNORE ; + eth =IGNORE ; + iole =IGNORE ; + tol =IGNORE ; + cres =IGNORE ; + to2 =IGNORE ; + tolaer1 =IGNORE ; + tolaer2 =IGNORE ; + open =IGNORE ; + cro =IGNORE ; + cslaer =IGNORE ; + mgly =IGNORE ; + xyl =IGNORE ; + xylaer1 =IGNORE ; + xylaer2 =IGNORE ; + isop =IGNORE ; + ispd =IGNORE ; + isoaer1 =IGNORE ; + isoaer2 =IGNORE ; + so2 =IGNORE ; + sulf =IGNORE ; + sulaer =IGNORE ; + etoh =IGNORE ; + etha =IGNORE ; + terp =IGNORE ; + terpaer =IGNORE ; + hum =IGNORE ; + humaer =IGNORE ; + lim =IGNORE ; + limaer1 =IGNORE ; + limaer2 =IGNORE ; + oci =IGNORE ; + ociaer1 =IGNORE ; + ociaer2 =IGNORE ; + apin =IGNORE ; + apinaer1 =IGNORE ; + apinaer2 =IGNORE ; + apinaer3 =IGNORE ; + apinaer4 =IGNORE ; + bpin =IGNORE ; + bpinaer1 =IGNORE ; + bpinaer2 =IGNORE ; + bpinaer3 =IGNORE ; + bpinaer4 =IGNORE ; + bpinaer5 =IGNORE ; + ter =IGNORE ; + teraer1 =IGNORE ; + teraer2 =IGNORE ; + alkh =IGNORE ; + alkhaer1 =IGNORE ; + pah =IGNORE ; + pahaer1 =IGNORE ; + pahaer2 =IGNORE ; + h2 =IGNORE ; + ch4 =IGNORE ; + hg0 = IGNORE ; + hg2 = IGNORE ; + fmcl = IGNORE ; + cl = IGNORE ; + hcl = IGNORE ; + hocl = IGNORE ; + clo = IGNORE ; + cl2 = IGNORE ; +#DEFFIX + H2O = IGNORE ; {water} + M = IGNORE ; diff --git a/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq_wrfkpp.equiv new file mode 100755 index 00000000..11aa3efd --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_aq/cb05_sorg_aq_wrfkpp.equiv @@ -0,0 +1,8 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP + diff --git a/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.def b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.def new file mode 100755 index 00000000..5b191b1b --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.def @@ -0,0 +1,22 @@ +#include atoms_red +#include ./cb05_sorg_vbs_aq.spc +#include ./cb05_sorg_vbs_aq.eqn + + + + +#INLINE F90_RATES +REAL(KIND=dp) FUNCTION k46( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=7.2E-15_dp * EXP(785._dp/TEMP) + k2=4.1E-16_dp * EXP(1440._dp/TEMP) + k3=1.9E-33_dp * EXP(725._dp/TEMP) + + k46=k0+k3/(1+k3/k2) + + +END FUNCTION k46 +#ENDINLINE + diff --git a/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.eqn b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.eqn new file mode 100755 index 00000000..93ef9d29 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.eqn @@ -0,0 +1,382 @@ +#EQUATIONS { CB05 MADE/SORG VBS Extension, Implemented by NCSU, Sep 2014 } +//********************************************************************* +//The former rate constant corresponds that for the following reaction in original version of CB05 in CMAQ: +//< R34> HO2 + HO2 = H2O2. But CMAQ uses an older rate constant of (EP3(2.3D-13, 600.0, 1.7D-33, 1000.0, TEMP, C_M). +//An updated rate constant of (EP3(2.3D-13, 600.0, 1.7D-33, 1000.0, TEMP, C_M) * ARR2(1.4D-21, 2200.0_dp, TEMP) comes from +//Jacobson's book (2005), Table B.4, reaction 33: HO2 + HO2 = H2O2 + O2. +//Additions of Cl equations from CMAQ's CB05 with Cl extension, and also Hg reactions taken from GU-WRF/Chem +//SO2 heteorogenous chemistry is also added here +//********************************************************************* +< R1> NO2 + hv = NO + O : j(Pj_no2); +< R2> O {+ O2 + M} = O3 {+ M} : 0.21*C_M*C_M*ARR(6.0D-34, 0.0_dp, -2.4_dp, TEMP); +< R3> O3 + NO = NO2 {+ O2} : ARR2(3.0D-12, 1500.0_dp, TEMP); +< R4> O + NO2 = NO {+ O2} : ARR2(5.6D-12, -180.0_dp, TEMP); +< R5> O + NO2 {+ M} = NO3 {+ M} : TROE(2.5D-31, 1.8_dp, 2.2D-11, 0.7_dp, TEMP, C_M); +< R6> O + NO {+ M} = NO2 {+ M} : TROE(9.0D-32, 1.5_dp, 3.0D-11, 0.0_dp, TEMP, C_M); +< R7> NO2 + O3 = NO3 {+ O2} : ARR2(1.2D-13, 2450.0_dp, TEMP); +< R8> O3 + hv = O {+ O2} : j(Pj_o33p); +< R9> O3 + hv = O1D {+ O2} : j(Pj_o31d); +< R10> O1D + M = O + M : ARR2(2.1D-11, -102.0_dp, TEMP); +< R11> O1D + H2O = 2 OH : 2.2D-10; +< R12> O3 + OH = HO2 {+ O2} : ARR2(1.7D-12, 940.0_dp, TEMP); +< R13> O3 + HO2 = OH {+ 2 O2} : ARR2(1.0D-14, 490.0_dp, TEMP); +< R14> NO3 + hv = NO2 + O : j(Pj_no3o); +< R15> NO3 + hv = NO {+ O2} : j(Pj_no3o2); +< R16> NO3 + NO = 2 NO2 : ARR2(1.5D-11, -170.0_dp, TEMP); +< R17> NO3 + NO2 = NO + NO2 {+ O2} : ARR2(4.5D-14, 1260.0_dp, TEMP); +< R18> NO3 + NO2 {+ M} = N2O5 {+ M} : TROE(2.0D-30, 4.4_dp, 1.4D-12, 0.7_dp, TEMP, C_M); +< R19> N2O5 + H2O = 2 HNO3 : 2.5D-22; +< R20> N2O5 + H2O + H2O = 2 HNO3 : 1.8D-39; +< R21> N2O5 = NO3 + NO2 : FALL(1.0D-03, 11000.0_dp, -3.5_dp, 9.7D14, 11080.0_dp, 0.1_dp, 0.45_dp, TEMP, C_M); +< R22> NO + NO {+0.21M} = 2 NO2 : ARR2(3.3D-39, -530.0_dp, TEMP)*0.21*C_M; +< R23> NO + NO2 + H2O = 2 HONO : 5.0D-40; +< R24> NO + OH = HONO : TROE(7.0D-31, 2.6_dp, 3.6D-11, 0.1_dp, TEMP, C_M); +< R25> HONO + hv = NO + OH : j(Pj_hno2); +< R26> OH + HONO = NO2 {+ H2O} : ARR2(1.8D-11, 390.0_dp, TEMP); +< R27> HONO + HONO = NO + NO2 : 1.0D-20; +< R28> NO2 + OH = HNO3 : TROE(2.0D-30, 3.0_dp, 2.5D-11, 0.0_dp, TEMP, C_M); +< R29> OH + HNO3 = NO3 : EP2(2.4D-14, -460.0_dp, 2.7D-17, -2199.0_dp, 6.5D-34, -1335.0_dp, TEMP, C_M); +< R30> HO2 + NO = OH + NO2 : ARR2(3.5D-12, -250.0_dp, TEMP); +< R31> HO2 + NO2 = PNA : TROE(1.8D-31, 3.2_dp, 4.7D-12, 0.0_dp, TEMP, C_M); +< R32> PNA = HO2 + NO2 : FALL(4.1D-05, 10650.0_dp, 0.0_dp, 4.8D15, 11170.0_dp, 0.0_dp, 0.6_dp, TEMP, C_M); +< R33> OH + PNA = NO2 : ARR2(1.3D-12, -380.0_dp, TEMP); +< R34> HO2 + HO2 = H2O2 : EP3(2.3D-13, -600.0_dp, 1.7D-33, -1000.0_dp, TEMP, C_M); +< R35> HO2 + HO2 + H2O = H2O2 : EP3(3.22D-34, -2800.0_dp, 2.38D-54, -3200.0_dp, TEMP, C_M); +< R36> H2O2 + hv = 2 OH : j(Pj_h2o2); +< R37> OH + H2O2 = HO2 {+ H2O} : ARR2(2.9D-12, 160.0_dp, TEMP); +< R38> O1D + H2 = OH + HO2 : 1.1D-10; +< R39> OH + H2 = HO2 : ARR2(5.5D-12, 2000.0_dp, TEMP); +< R40> OH + O = HO2 : ARR2(2.2D-11, -120.0_dp, TEMP); +< R41> OH + OH = O : ARR2(4.2D-12, 240.0_dp, TEMP); +< R42> OH + OH = H2O2 : TROE(6.9D-31, 1.0_dp, 2.6D-11, 0.0_dp, TEMP, C_M); +< R43> OH + HO2 = H2O {+ O2} : ARR2(4.8D-11, -250.0_dp, TEMP); +< R44> HO2 + O = OH {+ O2} : ARR2(3.0D-11, -200.0_dp, TEMP); +< R45> H2O2 + O = OH + HO2 : ARR2(1.4D-12, 2000.0_dp, TEMP); +< R46> NO3 + O = NO2 {+ O2} : 1.0D-11; +< R47> NO3 + OH = HO2 + NO2 : 2.2D-11; +< R48> NO3 + HO2 = HNO3 {+ O2} : 3.5D-12; +< R49> NO3 + O3 = NO2 {+ 2 O2} : 1.0D-17; +< R50> NO3 + NO3 = 2 NO2 {+ O2} : ARR2(8.5D-13, 2450.0_dp, TEMP); +< R51> PNA + hv = 0.61 HO2 + 0.61 NO2 + + 0.39 OH + 0.39 NO3 : j(Pj_hno4); +< R52> HNO3 + hv = OH + NO2 : j(Pj_hno3); +< R53> N2O5 + hv = NO2 + NO3 : j(Pj_n2o5); +< R54> XO2 + NO = NO2 {+ XO} : ARR2(2.6D-12, -365.0_dp, TEMP); +< R55> XO2N + NO = NTR : ARR2(2.6D-12, -365.0_dp, TEMP); +< R56> XO2 + HO2 = ROOH : ARR2(7.5D-13, -700.0_dp, TEMP); +< R57> XO2N + HO2 = ROOH : ARR2(7.5D-13, -700.0_dp, TEMP); +< R58> XO2 + XO2 = 0.21 M : 6.8D-14; +< R59> XO2N + XO2N = 0.21 M : 6.8D-14; +< R60> XO2 + XO2N = 0.21 M : 6.8D-14; +< R61> NTR + OH = HNO3 + HO2 + + 0.33 FORM + 0.33 ALD2 + + 0.33 ALDX - 0.66 PAR : ARR2(5.9D-13, 360.0_dp, TEMP); +< R62> NTR + hv = NO2 + HO2 + + 0.33 FORM + 0.33 ALD2 + + 0.33 ALDX - 0.66 PAR : 1.0D-4*j(Pj_no2); +< R63> ROOH + OH = XO2 + 0.50 ALD2 + + 0.50 ALDX : ARR2(3.01D-12, -190.0_dp, TEMP); +< R64> ROOH + hv = OH + HO2 + + 0.50 ALD2 + 0.50 ALDX : 0.7 *j(Pj_h2o2); +< R65> OH + CO = HO2 : EP3(1.44D-13, 0.0_dp, 3.43D-33, 0.0_dp, TEMP, C_M); +< R66> OH + CH4 = MEO2 : ARR2(2.45D-12, 1775.0_dp, TEMP); +< R67> MEO2 + NO = FORM + HO2 + NO2 : ARR2(2.8D-12, -300.0_dp, TEMP); +< R68> MEO2 + HO2 = MEPX : ARR2(4.1D-13, -750.0_dp, TEMP); +< R69> MEO2 + MEO2 = 1.37 FORM + 0.74 HO2 + + 0.63 MEOH : ARR2(9.5D-14, -390.0_dp, TEMP); +< R70> MEPX + OH = 0.70 MEO2 + 0.30 XO2 + + 0.30 HO2 : ARR2(3.8D-12, -200.0_dp, TEMP); +< R71> MEPX + hv = FORM + HO2 + OH : 0.7 *j(Pj_h2o2); +< R72> MEOH + OH = FORM + HO2 : ARR2(7.3D-12, 620.0_dp, TEMP); +< R73> FORM + OH = HO2 + CO : 9.0D-12; +< R74> FORM + hv = 2.000 HO2 + CO : j(Pj_ch2or); +< R75> FORM + hv = CO : j(Pj_ch2om); +< R76> FORM + O = OH + HO2 + CO : ARR2(3.4D-11, 1600.0_dp, TEMP); +< R77> FORM + NO3 = HNO3 + HO2 + CO : 5.8D-16; +< R78> FORM + HO2 = HCO3 : ARR2(9.7D-15, -625.0_dp, TEMP); +< R79> HCO3 = FORM + HO2 : ARR2(2.4D+12, 7000.0_dp, TEMP); +< R80> HCO3 + NO = FACD + NO2 + HO2 : 5.6D-12; +< R81> HCO3 + HO2 = MEPX : ARR2(5.6D-15, -2300.0_dp, TEMP); +< R82> FACD + OH = HO2 : 4.0D-13; +< R83> ALD2 + O = C2O3 + OH : ARR2(1.8D-11, 1100.0_dp, TEMP); +< R84> ALD2 + OH = C2O3 : ARR2(5.6D-12, -270.0_dp, TEMP); +< R85> ALD2 + NO3 = C2O3 + HNO3 : ARR2(1.4D-12, 1900.0_dp, TEMP); +< R86> ALD2 + hv = MEO2 + CO + HO2 : 4.6D-4*j(Pj_no2); +< R87> C2O3 + NO = MEO2 + NO2 : ARR2(8.1D-12, -270.0_dp, TEMP); +< R88> C2O3 + NO2 = PAN : FALL(2.7D-28, 0.0_dp, -7.1_dp, 1.2D-11, 0.0_dp, -0.9_dp, 0.3_dp, TEMP, C_M); +< R89> PAN = C2O3 + NO2 : FALL(4.9D-03, 12100.0_dp, 0.0_dp, 5.4D16, 13830.0_dp, 0.0_dp, 0.3_dp, TEMP, C_M); +< R90> PAN + hv = C2O3 + NO2 : j(Pj_pan); +< R91> C2O3 + HO2 = 0.80 PACD + 0.20 AACD + + 0.20 O3 : ARR2(4.3D-13, -1040.0_dp, TEMP); +< R92> C2O3 + MEO2 = 0.90 MEO2 + 0.90 HO2 + + FORM + 0.10 AACD : ARR2(2.0D-12, -500.0_dp, TEMP); +< R93> C2O3 + XO2 = 0.90 MEO2 + 0.10 AACD : ARR2(4.4D-13, -1070.0_dp, TEMP); +< R94> C2O3 + C2O3 = 2.00 MEO2 : ARR2(2.9D-12, -500.0_dp, TEMP); +< R95> PACD + OH = C2O3 : ARR2(4.0D-13, -200.0_dp, TEMP); +< R96> PACD + hv = MEO2 + OH : 0.0*0.7 *j(Pj_h2o2); +< R97> AACD + OH = MEO2 : ARR2(4.0D-13, -200.0_dp, TEMP); +< R98> ALDX + O = CXO3 + OH : ARR2(1.3D-11, 870.0_dp, TEMP); +< R99> ALDX + OH = CXO3 : ARR2(5.1D-12, -405.0_dp, TEMP); + ALDX + NO3 = CXO3 + HNO3 : 6.5D-15; + ALDX + hv = MEO2 + CO + HO2 : j(Pj_ch3cho); + CXO3 + NO = ALD2 + NO2 + + HO2 + XO2 : ARR2(6.7D-12, -340.0_dp, TEMP); + CXO3 + NO2 = PANX : FALL(2.7D-28, 0.0_dp, -7.1_dp, 1.2D-11, 0.0_dp, -0.9_dp, 0.3_dp, TEMP, C_M); + PANX = CXO3 + NO2 : FALL(4.9D-03, 12100.0_dp, 0.0_dp, 5.4D16, 13830.0_dp, 0.0_dp, 0.3_dp, TEMP, C_M); + PANX + hv = CXO3 + NO2 : j(Pj_pan); + PANX + OH = ALD2 + NO2 : 3.0D-13; + CXO3 + HO2 = 0.80 PACD + 0.20 AACD + + 0.20 O3 : ARR2(4.3D-13, -1040.0_dp, TEMP); + CXO3 + MEO2 = 0.90 ALD2 + 0.90 XO2 + + HO2 + 0.10 AACD + + 0.10 FORM : ARR2(2.0D-12, -500.0_dp, TEMP); + CXO3 + XO2 = 0.90 ALD2 + 0.10 AACD : ARR2(4.4D-13, -1070.0_dp, TEMP); + CXO3 + CXO3 = 2.00 ALD2 + 2.00 XO2 + + 2.00 HO2 : ARR2(2.9D-12, -500.0_dp, TEMP); + CXO3 + C2O3 = MEO2 + XO2 + + HO2 + ALD2 : ARR2(2.9D-12, -500.0_dp, TEMP); + PAR + OH = 0.87 XO2 + 0.13 XO2N + + 0.11 HO2 + 0.06 ALD2 + - 0.11 PAR + 0.76 ROR + + 0.05 ALDX : 8.1D-13; + ROR = 0.96 XO2 + 0.60 ALD2 + + 0.94 HO2 - 2.10 PAR + + 0.04 XO2N + 0.02 ROR + + 0.50 ALDX : ARR2(1.0D15, 8000.0_dp, TEMP); + ROR = HO2 : 1.6E+03; + ROR + NO2 = NTR : 1.5D-11; + O + OLE = 0.20 ALD2 + 0.30 ALDX + + 0.30 HO2 + 0.20 XO2 + + 0.20 CO + 0.20 FORM + + 0.01 XO2N + 0.20 PAR + + 0.10 OH : ARR2(1.0D-11, 280.0_dp, TEMP); + OH + OLE = 0.80 FORM + 0.33 ALD2 + + 0.62 ALDX + 0.80 XO2 + + 0.95 HO2 - 0.70 PAR : 3.2D-11; + O3 + OLE = 0.18 ALD2 + 0.74 FORM + + 0.32 ALDX + 0.22 XO2 + + 0.10 OH + 0.33 CO + + 0.44 HO2 - 1.00 PAR : ARR2(6.5D-15, 1900.0_dp, TEMP); + NO3 + OLE = NO2 + FORM + + 0.91 XO2 + 0.09 XO2N + + 0.56 ALDX + 0.35 ALD2 + - 1.00 PAR : ARR2(7.0D-13, 2160.0_dp, TEMP); + O + ETH = FORM + 1.70 HO2 + + CO + 0.70 XO2 + + 0.30 OH : ARR2(1.04D-11, 792.0_dp, TEMP); + OH + ETH = XO2 + 1.56 FORM + + 0.22 ALDX + HO2 : TROE(1.0D-28, 0.8_dp, 8.8D-12, 0.0_dp, TEMP, C_M); + O3 + ETH = FORM + 0.63 CO + + 0.13 HO2 + 0.13 OH + + 0.37 FACD : ARR2(1.2D-14, 2630.0_dp, TEMP); + NO3 + ETH = NO2 + XO2 + + 2.0 FORM : ARR2(3.3D-12, 2880.0_dp, TEMP); + IOLE + O = 1.24 ALD2 + 0.66 ALDX + + 0.10 HO2 + 0.10 XO2 + + 0.10 CO + 0.10 PAR : 2.3D-11; + IOLE + OH = 1.30 ALD2 + 0.70 ALDX + + HO2 + XO2 : ARR2(1.0D-11, -550.0_dp, TEMP); + IOLE + O3 = 0.65 ALD2 + 0.35 ALDX + + 0.25 FORM + 0.25 CO + + 0.50 O + 0.50 OH + + 0.50 HO2 : ARR2(8.4D-15, 1100.0_dp, TEMP); + IOLE + NO3 = 1.18 ALD2 + 0.64 ALDX + + HO2 + NO2 : ARR2(9.6D-13, 270.0_dp, TEMP); + TOL + OH = 0.44 HO2 + 0.08 XO2 + + 0.36 CRES + 0.56 TO2 + + 0.071 TOLAER1 + + 0.138 TOLAER2 : ARR2(1.8D-12, -355.0_dp, TEMP); + TO2 + NO = 0.90 NO2 + 0.90 HO2 + + 0.90 OPEN + 0.10 NTR : 8.1D-12; + TO2 = CRES + HO2 : 4.2; + OH + CRES = 0.40 CRO + 0.60 XO2 + + 0.60 HO2 + 0.30 OPEN + + CSLAER : 4.1D-11; + CRES + NO3 = CRO + HNO3 + CSLAER : 2.2D-11; + CRO + NO2 = NTR : 1.4D-11; + CRO + HO2 = CRES : 5.5D-12; + OPEN + hv = C2O3 + HO2 + CO : 9.0 *j(Pj_ch2or); + OPEN + OH = XO2 + 2.0 CO + + 2.00 HO2 + C2O3 + FORM : 3.0D-11; + OPEN + O3 = 0.03 ALDX + 0.62 C2O3 + + 0.70 FORM + 0.03 XO2 + + 0.69 CO + 0.08 OH + + 0.76 HO2 + 0.20 MGLY : ARR2(5.4D-17, 500.0_dp, TEMP); + OH + XYL = 0.70 HO2 + 0.50 XO2 + + 0.20 CRES + 0.80 MGLY + + 1.10 PAR + 0.30 TO2 + + 0.038 XYLAER1 + + 0.167 XYLAER2 : ARR2(1.7D-11, -116.0_dp, TEMP); + OH + MGLY = XO2 + C2O3 : 1.7D-11; + + MGLY + hv = C2O3 + HO2 + CO : 9.64 *j(Pj_ch2or); + O + ISOP = 0.75 ISPD + 0.50 FORM + + 0.25 XO2 + 0.25 HO2 + + 0.25 CXO3 + + 0.232 ISOAER1 + + 0.0228 ISOAER2 : 3.6D-11; + OH + ISOP = 0.912 ISPD + 0.629 FORM + + 0.991 XO2 + 0.912 HO2 + + 0.088 XO2N + + 0.232 ISOAER1 + + 0.0288 ISOAER2 : ARR2(2.54D-11, -407.6_dp, TEMP); + O3 + ISOP = 0.650 ISPD + 0.600 FORM + + 0.200 XO2 + 0.066 HO2 + + 0.266 OH + 0.200 CXO3 + + 0.150 ALDX + 0.350 PAR + + 0.066 CO + + 0.232 ISOAER1 + + 0.0288 ISOAER2 : ARR2(7.86D-15, 1912.0_dp, TEMP); + NO3 + ISOP = 0.200 ISPD + 0.800 NTR + + XO2 + 0.800 HO2 + + 0.200 NO2 + 0.800 ALDX + + 0.232 ISOAER1 + + 0.0288 ISOAER2 : ARR2(3.03D-12, 448.0_dp, TEMP); + OH + ISPD = 1.565 PAR + 0.167 FORM + + 0.713 XO2 + 0.503 HO2 + + 0.334 CO + 0.168 MGLY + + 0.252 ALD2 + 0.210 C2O3 + + 0.250 CXO3 + 0.120 ALDX : 3.36D-11; + O3 + ISPD = 0.114 C2O3 + 0.150 FORM + + 0.850 MGLY + 0.154 HO2 + + 0.268 OH + 0.064 XO2 + + 0.020 ALD2 + 0.360 PAR + + 0.225 CO : 7.1D-18; + NO3 + ISPD = 0.357 ALDX + 0.282 FORM + + 1.282 PAR + 0.925 HO2 + + 0.643 CO + 0.850 NTR + + 0.075 CXO3 + 0.075 XO2 + + 0.150 HNO3 : 1.0D-15; + ISPD + hv = 0.333 CO + 0.067 ALD2 + + 0.900 FORM + 0.832 PAR + + 1.033 HO2 + 0.700 XO2 + + 0.967 C2O3 : 0.0036*0.025 *j(Pj_ch2om); + TERP + O = 0.150 OH + 5.12 PAR + + TERPAER : 3.6D-11; + TERP + OH = 0.750 HO2 + 1.250 XO2 + + 0.250 XO2N + 0.280 FORM + + 1.66 PAR + 0.470 ALDX + + TERPAER : ARR2(1.5D-11, -449.0_dp, TEMP); + TERP + O3 = 0.570 OH + 0.070 HO2 + + 0.760 XO2 + 0.180 XO2N + + 0.240 FORM + 0.001 CO + + 7.000 PAR + 0.210 ALDX + + 0.390 CXO3 + + TERPAER : ARR2(1.2D-15, 821.0_dp, TEMP); + TERP + NO3 = 0.470 NO2 + 0.280 HO2 + + 1.030 XO2 + 0.250 XO2N + + 0.470 ALDX + 0.530 NTR + + TERPAER : ARR2(3.7D-12, -175.0_dp, TEMP); + SO2 + OH = SULF + HO2 + SULAER : TROE(3.3D-31, 4.3_dp, 1.6D-12, 0.0_dp, TEMP, C_M); + OH + ETOH = HO2 + 0.900 ALD2 + + 0.050 ALDX + 0.100 FORM + + 0.100 XO2 : ARR2(6.9D-12, 230.0_dp, TEMP); + OH + ETHA = 0.991 ALD2 + 0.991 XO2 + + 0.009 XO2N + HO2 : ARR2(8.7D-12, 1070.0_dp, TEMP); + NO2 + ISOP = 0.200 ISPD + 0.800 NTR + + XO2 + 0.800 HO2 + + 0.200 NO + 0.800 ALDX + + 2.400 PAR : 1.5D-19; + CL2 + hv = 2.000 CL : j(Pj_cl2); + HOCL + hv = OH + CL : j(Pj_hocl); + CL + O3 = CLO : ARR2(2.3D-11, 200.0_dp, TEMP); + CLO + CLO = 0.300 CL2 + 1.400 CL : 1.63D-14; + CLO + NO = CL + NO2 : ARR2(6.4D-12, -290.0_dp, TEMP); + CLO + HO2 = HOCL : ARR2(2.7D-12, -220.0_dp, TEMP); + OH + FMCL = CL + CO : 5.0D-13; + FMCL + hv = CL + CO + HO2 : j(Pj_fmcl); + CL + CH4 = HCL + MEO2 : ARR2(6.6D-12, 1240.0_dp, TEMP); + CL + PAR = HCL + + 0.870 XO2 + + 0.130 XO2N + + 0.110 HO2 + + 0.060 ALD2 + - 0.110 PAR + + 0.760 ROR + + 0.050 ALDX : 5.0D-11; + CL + ETHA = HCL + + 0.991 ALD2 + + 0.991 XO2 + + 0.009 XO2N + + HO2 : ARR2(8.3D-11, 100.0_dp, TEMP); + CL + ETH = FMCL + + 2.000 XO2 + + 1.000 HO2 + + 1.000 FORM : 1.07D-10; + CL + OLE = FMCL + + 0.330 ALD2 + + 0.670 ALDX + + 2.000 XO2 + + 1.000 HO2 + - 1.000 PAR : 2.5D-10; + CL + IOLE = 0.300 HCL + + 0.700 FMCL + + 0.450 ALD2 + + 0.550 ALDX + + 0.300 OLE + + 0.300 PAR + + 1.700 XO2 + + 1.000 HO2 : 3.5D-10; + CL + ISOP = 0.15 HCL + + 1.000 XO2 + + 1.000 HO2 + + 0.850 FMCL + + 1.000 ISPD : 4.3D-10; + CL + FORM = HCL + + 1.000 HO2 + + 1.000 CO : ARR2(8.2D-11, 34.0_dp, TEMP); + CL + ALD2 = HCL + + 1.000 C2O3 : 7.9D-11; + CL + ALDX = HCL + + 1.000 CXO3 : 1.3D-10; + CL + MEOH = HCL + + 1.000 HO2 + + 1.000 FORM : 5.5D-11; + CL + ETOH = HCL + + 1.000 HO2 + + 1.000 ALD2 : ARR2(8.2D-11, -45.0_dp, TEMP); + HCL + OH = CL : ARR(6.58D-13, -58.0_dp, 1.16_dp, TEMP); + HG0 + O3 = HG2 : 3.0D-20; + HG0 + OH = HG2 : 8.7D-14; + HG0 + H2O2 = HG2 : 8.5D-19; + HUM + OH = HUMAER + OH : 2.93D-10; + LIM + OH = 0.239 LIMAER1 + + 0.363 LIMAER2 + + OH : 1.71D-10; + OCI + OH = 0.045 OCIAER1 + + 0.149 OCIAER2 + + OH : 2.52D-10; + APIN + OH = 0.038 APINAER1 + + 0.326 APINAER2 + + OH : 5.37D-11; + APIN + O3 = 0.125 APINAER3 + + 0.102 APINAER4 + + O3 : 8.66D-17; + BPIN + OH = 0.13 BPINAER1 + + 0.0406 BPINAER2 + + OH : 7.89D-11; + BPIN + O3 = 0.026 BPINAER3 + + 0.485 BPINAER4 + + O3 : 1.36D-17; + BPIN + NO3 = BPINAER5 + NO3 : 2.31D-12; + TER + OH = 0.091 TERAER1 + + 0.367 TERAER2 + + OH : 2.7D-10; + ALKH + OH = 1.173 ALKHAER1 + + OH : 1.97D-11; + PAH + OH = 0.156 PAHAER1 + + 0.777 PAHAER2 + + OH : 7.7D-11; + CVASOA4 + OH = 1.075 CVASOA3 + + OH : ARR2(1.0D-11, 0.0_dp, TEMP); + CVASOA3 + OH = 1.075 CVASOA2 + + OH : ARR2(1.0D-11, 0.0_dp, TEMP); + CVASOA2 + OH = 1.075 CVASOA1 + + OH : ARR2(1.0D-11, 0.0_dp, TEMP); + CVBSOA4 + OH = 1.075 CVBSOA3 + + OH : ARR2(1.0D-11, 0.0_dp, TEMP); + CVBSOA3 + OH = 1.075 CVBSOA2 + + OH : ARR2(1.0D-11, 0.0_dp, TEMP); + CVBSOA2 + OH = 1.075 CVBSOA1 + + OH : ARR2(1.0D-11, 0.0_dp, TEMP); + SO2 = SULF : rtdat_ae_so2; diff --git a/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.kpp b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.kpp new file mode 100644 index 00000000..60462909 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.kpp @@ -0,0 +1,12 @@ +#MODEL cb05_sorg_vbs_aq +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.spc b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.spc new file mode 100755 index 00000000..b1457801 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq.spc @@ -0,0 +1,109 @@ +#DEFVAR + no2 =IGNORE ; + no =IGNORE ; + o =IGNORE ; + o3 =IGNORE ; + no3 =IGNORE ; + o1d =IGNORE ; + oh =IGNORE ; + ho2 =IGNORE ; + n2o5 =IGNORE ; + hno3 =IGNORE ; + hono =IGNORE ; + pna =IGNORE ; + h2o2 =IGNORE ; + xo2 =IGNORE ; + xo2n =IGNORE ; + ntr =IGNORE ; + rooh =IGNORE ; + form =IGNORE ; + ald2 =IGNORE ; + aldx =IGNORE ; + par =IGNORE ; + co =IGNORE ; + meo2 =IGNORE ; + mepx =IGNORE ; + meoh =IGNORE ; + hco3 =IGNORE ; + facd =IGNORE ; + c2o3 =IGNORE ; + pan =IGNORE ; + pacd =IGNORE ; + aacd =IGNORE ; + cxo3 =IGNORE ; + panx =IGNORE ; + ror =IGNORE ; + ole =IGNORE ; + eth =IGNORE ; + iole =IGNORE ; + tol =IGNORE ; + cres =IGNORE ; + to2 =IGNORE ; + tolaer1 =IGNORE ; + tolaer2 =IGNORE ; + open =IGNORE ; + cro =IGNORE ; + cslaer =IGNORE ; + mgly =IGNORE ; + xyl =IGNORE ; + xylaer1 =IGNORE ; + xylaer2 =IGNORE ; + isop =IGNORE ; + ispd =IGNORE ; + isoaer1 =IGNORE ; + isoaer2 =IGNORE ; + so2 =IGNORE ; + sulf =IGNORE ; + sulaer =IGNORE ; + etoh =IGNORE ; + etha =IGNORE ; + terp =IGNORE ; + terpaer =IGNORE ; + hum =IGNORE ; + humaer =IGNORE ; + lim =IGNORE ; + limaer1 =IGNORE ; + limaer2 =IGNORE ; + oci =IGNORE ; + ociaer1 =IGNORE ; + ociaer2 =IGNORE ; + apin =IGNORE ; + apinaer1 =IGNORE ; + apinaer2 =IGNORE ; + apinaer3 =IGNORE ; + apinaer4 =IGNORE ; + bpin =IGNORE ; + bpinaer1 =IGNORE ; + bpinaer2 =IGNORE ; + bpinaer3 =IGNORE ; + bpinaer4 =IGNORE ; + bpinaer5 =IGNORE ; + ter =IGNORE ; + teraer1 =IGNORE ; + teraer2 =IGNORE ; + alkh =IGNORE ; + alkhaer1 =IGNORE ; + pah =IGNORE ; + pahaer1 =IGNORE ; + pahaer2 =IGNORE ; + h2 =IGNORE ; + ch4 =IGNORE ; + hg0 = IGNORE ; + hg2 = IGNORE ; + fmcl = IGNORE ; + cl = IGNORE ; + hcl = IGNORE ; + hocl = IGNORE ; + clo = IGNORE ; + cl2 = IGNORE ; + CVASOA4 =IGNORE; + CVASOA3 =IGNORE; + CVASOA2 =IGNORE; + CVASOA1 =IGNORE; + CVBSOA4 =IGNORE; + CVBSOA3 =IGNORE; + CVBSOA2 =IGNORE; + CVBSOA1 =IGNORE; +#DEFFIX + H2O = IGNORE ; {water} + M = IGNORE ; diff --git a/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq_wrfkpp.equiv new file mode 100755 index 00000000..11aa3efd --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/cb05_sorg_vbs_aq/cb05_sorg_vbs_aq_wrfkpp.equiv @@ -0,0 +1,8 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP + diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart/mozart.eqn b/wrfv2_fire/chem/KPP/mechanisms/mozart/mozart.eqn index b398507d..2a429b34 100755 --- a/wrfv2_fire/chem/KPP/mechanisms/mozart/mozart.eqn +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart/mozart.eqn @@ -172,7 +172,7 @@ {170:130 } ISOP+NO3=ISOPNO3 : ARR2(3.03e-12_dp, 446._dp, TEMP) ; {171:131 } ISOPNO3+NO=1.206 NO2+.794 HO2+.072 CH2O+.167 MACR+.039 MVK+.794 ONITR : ARR2(2.7e-12_dp, -360._dp, TEMP) ; {172:132 } ISOPNO3+NO3=1.206 NO2+.072 CH2O+.167 MACR+.039 MVK+.794 ONITR+.794 HO2 : 2.4e-12_dp ; - {173:133 } ISOPNO3+HO2=.206 NO2+.794 HO2+.008 CH2O+.167 MACR+.039 MVK+.794 ONITR : ARR2(8.e-13_dp, -700._dp, TEMP) ; + {173:133 } ISOPNO3+HO2=.206 NO2+.206 OH+.206 CH2O+.167 MACR+.039 MVK+.794 ONITR : ARR2(8.e-13_dp, -700._dp, TEMP) ; {174:134 } CH3COCHO+OH=CH3CO3+CO{+H2O} : ARR2(8.4e-13_dp, -830._dp, TEMP) ; {175:135 } CH3COCHO+NO3=HNO3+CO+CH3CO3 : ARR2(1.4e-12_dp, 1860._dp, TEMP) ; {176:136 } ONITR+OH=HYDRALD+HO2+.4 NO2 : 4.5e-11_dp ; @@ -194,6 +194,6 @@ {192:152 } DMS+OH=SO2 : ARR2(9.6e-12_dp, 234._dp, TEMP) ; {193:153 } DMS+OH=.5 SO2+.5 HO2 : usr24( temp, c_m ) ; {194:154 } DMS+NO3=SO2+HNO3 : ARR2(1.9e-13_dp, -520._dp, TEMP) ; - {195:155 } NH3+OH=M : ARR2(1.7e-12_dp, -710._dp, TEMP) ; + {195:155 } NH3+OH=M : ARR2(1.7e-12_dp, 710._dp, TEMP) ; {196:156 } HO2=.5 H2O2 : usr26( rh, temp ) ; {197:157 } C2H5O2+C2H5O2=1.6 CH3CHO+1.2 HO2+.4 C2H5OH : 6.8e-14_dp ; diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.def b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.def similarity index 98% rename from wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.def rename to wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.def index b176a176..3870fa93 100644 --- a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.def +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.def @@ -1,6 +1,6 @@ #include atoms_red -#include ./mozart_mosaic_4bin_vbs0.spc -#include ./mozart_mosaic_4bin_vbs0.eqn +#include ./mozart_mosaic_4bin.spc +#include ./mozart_mosaic_4bin.eqn diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.eqn b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.eqn new file mode 100755 index 00000000..7f3f16a2 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.eqn @@ -0,0 +1,372 @@ +#EQUATIONS +{J001} M{ = O2} + hv = O + O : .20946_dp*j(Pj_o2) ; +{J002} O3 + hv = O1D_CB4{ + O2} : j(Pj_o31d) ; +{J003} O3 + hv = O{ + O2} : j(Pj_o33p) ; +{J004} N2O + hv = O1D_CB4{ + N2} : j(Pj_n2o) ; +{J005} NO2 + hv = O + NO : j(Pj_no2) ; +{J006} N2O5 + hv = NO2 + NO3 : j(Pj_n2o5) ; +{J007} HNO3 + hv = OH + NO2 : j(Pj_hno3) ; +{J008} NO3 + hv = .89 NO2 + .11 NO + .89 O3 : j(Pj_no3o) ; +{J009} HO2NO2 + hv = 0.66 HO2 + 0.66 NO2 + 0.33 OH + 0.33 NO3 : j(Pj_hno4) ; +{J010} CH3OOH + hv = CH2O + HO2 + OH : j(Pj_ch3o2h) ; +{J011} CH2O + hv = HO2 + HO2 + CO : j(Pj_ch2or) ; +{J012} CH2O + hv = CO + H2 : j(Pj_ch2om) ; +{J013} H2O2 + hv = OH + OH : j(Pj_h2o2) ; +{J014} CH3CHO + hv = CH3O2 + CO + HO2 : j(Pj_ch3cho) ; +{J015} POOH + hv = CH3CHO + CH2O + HO2 + OH : j(Pj_pooh) ; +{J016} CH3COOOH + hv = CH3O2 + OH{ + CO2} : .28_dp*j(Pj_h2o2) ; +{J017} PAN + hv = 0.6 CH3CO3 + 0.6 NO2 + 0.4 CH3O2 + 0.4 NO3 + { + 0.4 CO2} : j(Pj_pan) ; +{J018} MPAN + hv = MCO3 + NO2 : j(Pj_pan) ; +{J019} MACR + hv = 0.67 HO2 + 0.33 MCO3 + 0.67 CH2O + 0.67 CH3CO3 + + 0.33 OH + 0.67 CO : j(Pj_macr) ; +{J020} MVK + hv = 0.7 C3H6 + 0.7 CO + 0.3 CH3O2 + 0.3 CH3CO3 : j(Pj_mvk) ; +{J021} C2H5OOH + hv = CH3CHO + HO2 + OH : j(Pj_ch3o2h) ; +{J022} C3H7OOH + hv = 0.82 CH3COCH3 + HO2 + OH : j(Pj_ch3o2h) ; +{J023} ROOH + hv = CH3CO3 + CH2O + OH : j(Pj_ch3o2h) ; +{J024} CH3COCH3 + hv = CH3CO3 + CH3O2 : j(Pj_ch3coch3) ; +{J025} CH3COCHO + hv = CH3CO3 + CO + HO2 : j(Pj_ch3cocho) ; +{J026} XOOH + hv = OH : j(Pj_ch3o2h) ; +{J027} ONITR + hv = HO2 + CO + NO2 + CH2O : j(Pj_ch3cho) ; +{J028} ISOPOOH + hv = .402 MVK + .288 MACR + .69 CH2O + HO2 : j(Pj_ch3o2h) ; +{J029} HYAC + hv = CH3CO3 + HO2 + CH2O : j(Pj_hyac) ; +{J030} GLYALD + hv = HO2 + HO2 + CO + CH2O : j(Pj_glyald) ; +{J031} MEK + hv = CH3CO3 + C2H5O2 : j(Pj_mek) ; +{J032} BIGALD + hv = 0.45 CO + 0.13 GLYOXAL + 0.56 HO2 + 0.13 CH3CO3 + + 0.18 CH3COCHO : .2_dp*j(Pj_no2) ; +{J033} GLYOXAL + hv = CO + CO + HO2 + HO2 : j(Pj_gly) ; +{J034} ALKOOH + hv = 0.4 CH3CHO + 0.1 CH2O + 0.25 CH3COCH3 + 0.9 HO2 + + 0.8 MEK + OH : j(Pj_ch3o2h) ; +{J035} MEKOOH + hv = OH + CH3CO3 + CH3CHO : j(Pj_ch3o2h) ; +{J036} TOLOOH + hv = OH + 0.45 GLYOXAL + 0.45 CH3COCHO + 0.9 BIGALD : j(Pj_ch3o2h) ; +{J037} BIGALD1 + hv = 0.6 MALO2 + HO2 : 0.140*j(Pj_no2) ; +{J038} BEPOMUC + hv = BIGALD1 + 1.5 HO2 + 1.5 CO : 0.100*j(Pj_no2) ; +{J039} TEPOMUC + hv = .5 CH3CO3 + HO2 + 1.5 CO : 0.100*j(Pj_no2) ; +{J040} BIGALD2 + hv = 0.6 HO2 + 0.6 DICARBO2 : 0.200*j(Pj_no2) ; +{J041} BIGALD3 + hv = 0.6 HO2 + 0.6 CO + 0.6 MDIALO2 : 0.200*j(Pj_no2) ; +{J042} BIGALD4 + hv = HO2 + CO + CH3COCHO + CH3CO3 : 0.006*j(Pj_no2) ; +{J043} MBOOOH + hv = OH + HO2 + 0.67 * GLYALD + 0.67 * CH3COCH3 + + 0.33 * HMPROP + 0.33 * CH2O : j(Pj_ch3o2h) ; +{J044} HMPROP + hv = 2 * HO2 + CO + CH3COCH3 : j(Pj_glyald) ; +{J045} TERPROD1 + hv = HO2 + CO + TERPROD2 : j(Pj_ch3cho) ; +{J046} TERPROD2 + hv = 0.15 RO2 + 0.68 CH2O + 0.5 CH3COCH3 + + 0.65 CH3CO3 + 1.2 HO2 + 1.7 CO{ + 0.8 CO2} : j(Pj_ch3cho) ; +{J047} TERPOOH + hv = 0.4 CH2O + 0.05 CH3COCH3 + TERPROD1 + HO2 + OH : j(Pj_ch3o2h) ; +{J048} TERP2OOH + hv = OH + 0.375 CH2O + 0.3 CH3COCH3 + 0.25 CO + + TERPROD2 + HO2 + 0.25 GLYALD{ + CO2} : j(Pj_ch3o2h) ; +{J049} HONO + hv = OH + NO : j(Pj_hno2) ; +{T001} O + M{ = O2} = O3 : 0.20946*(C_M *6.00e-34_dp*(TEMP/300._dp)**(-2.3_dp)) ; +{T002} O + O3 = M{ = O2 + O2} : ARR2(8.0e-12_dp, 2060.0_dp, TEMP) ; +{T003} O1D_CB4 + + M{ = O2,N2} = O{ + O2,N2} : .79_dp*ARR2(2.1e-11_dp, -115.0_dp, TEMP) + .21_dp*ARR2(3.2e-11_dp, -70.0_dp, TEMP) ; +{T004} O1D_CB4 + H2O = OH + OH : 2.2e-10_dp ; +{T005} O1D_CB4 + H2 = HO2 + OH : 1.1e-10_dp ; +{T006} OH + H2 = HO2 + H2O : ARR2(5.5e-12_dp, 2000.0_dp, TEMP) ; +{T007} O + OH = HO2{ + O2} : ARR2(2.2e-11_dp, -120.0_dp, TEMP) ; +{T008} O + HO2 = OH{ + O2} : ARR2(3.0e-11_dp, -200.0_dp, TEMP) ; +{T009} OH + O3 = HO2{ + O2} : ARR2(1.7e-12_dp, 940.0_dp, TEMP) ; +{T010} HO2 + O3 = OH{ + O2 + O2} : ARR2(1.0e-14_dp, 490.0_dp, TEMP) ; +{T011} HO2 + HO2 + H2O = H2O2 : usr9( temp, c_m, c_h2o ) ; +{T012} H2O2 + OH = HO2 + H2O : ARR2(2.9e-12_dp, 160.0_dp, TEMP) ; +{T013} OH + HO2 = H2O{ + O2} : ARR2(4.8e-11_dp, -250.0_dp, TEMP) ; +{T014} OH + OH = H2O + O : ARR2(4.2e-12_dp, 240.0_dp, TEMP) ; +{T015} OH + OH{ + M} = H2O2{ + M} : TROE( 6.90e-31_dp , 1.0_dp , 2.60e-11_dp , 0.0_dp , TEMP, C_M) ; +{T016} N2O + O1D_CB4 = NO + NO : 6.7e-11_dp ; +{T017} N2O + O1D_CB4 = M{ = O2 + N2} : 4.9e-11_dp ; +{T018} NO + HO2 = NO2 + OH : ARR2(3.5e-12_dp, -250.0_dp, TEMP) ; +{T019} O3 + NO = NO2{ + O2} : ARR2(3.0e-12_dp, 1500.0_dp, TEMP) ; +{T020} O + NO2 = NO{ + O2} : ARR2(5.6e-12_dp, -180.0_dp, TEMP) ; +{T021} O3 + NO2 = NO3{ + O2} : ARR2(1.2e-13_dp, 2450.0_dp, TEMP) ; +{T022} NO3 + HO2 = OH + NO2 : ARR2(2.3e-12_dp, -170.0_dp, TEMP) ; +{T023} NO3 + NO2{ + M} = N2O5{ + M} : TROE( 2.e-30_dp , 4.4_dp , 1.4e-12_dp , .7_dp , TEMP, C_M) ; +{T024} N2O5{ + M} = NO2 + NO3{ + M} : TROEE(3.333e26_dp,10900._dp, 2.2e-30_dp , 4.4_dp , 1.4e-12_dp , .7_dp , TEMP, C_M ) ; +{T025} OH + NO2{ + M} = HNO3{ + M} : TROE( 2.e-30_dp , 3._dp , 2.5e-11_dp , 0._dp , TEMP, C_M) ; +{T026} OH + HNO3 = NO3 + H2O : usr5( TEMP, C_M ) ; +{T027} NO3 + NO = NO2 + NO2 : ARR2(1.5e-11_dp, -170._dp, TEMP) ; +{T028} HO2 + NO2{ + M} = HO2NO2{ + M} : TROE( 1.8e-31_dp , 3.2_dp , 4.7e-12_dp , 1.4_dp , TEMP, C_M) ; +{T029} OH + HO2NO2 = NO2 + H2O{ + O2} : ARR2(1.3e-12_dp, -380._dp, TEMP) ; +{T030} HO2NO2{ + M} = HO2 + NO2{ + M} : TROEE( 4.76e26_dp,10900._dp, 1.8e-31_dp , 3.2_dp , 4.7e-12_dp , 1.4_dp , TEMP, C_M ) ; +{T031} N2O5 + M = 2.00 HNO3{ + M} : usr16( rh, temp ) ; +{T032} NO3 = HNO3 : usr17(rh, temp) ; +{T033} NO2 = 0.5 OH + 0.5 NO + 0.5 HNO3 : usr17a(rh, temp) ; +{T034} CH4 + OH = CH3O2 + H2O : ARR2(2.45e-12_dp, 1775.0_dp, TEMP) ; +{T035} CH4 + O1D_CB4 = 0.75 CH3O2 + 0.75 OH + 0.25 CH2O + 0.4 HO2 + + 0.05 H2 : 1.5e-10_dp ; +{T036} CH3O2 + NO = CH2O + NO2 + HO2 + nume : ARR2(2.8e-12_dp, -300._dp, TEMP) ; +{T037} CH3O2 + CH3O2 = CH2O + CH2O + HO2 + HO2 + den : ARR2(5.e-13_dp, 424._dp, TEMP) ; +{T038} CH3O2 + CH3O2 = CH2O + CH3OH + den : ARR2(1.9e-14_dp, -706._dp, TEMP) ; +{T039} CH3O2 + HO2 = CH3OOH{ + O2} + den : ARR2(4.1e-13_dp, -750._dp, TEMP) ; +{T040} CH3OOH + OH = 0.7 CH3O2 + 0.3 OH + 0.3 CH2O + H2O : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T041} CH2O + NO3 = CO + HO2 + HNO3 : ARR2( 6.e-13_dp, 2058._dp, TEMP) ; +{T042} CH2O + OH = CO + HO2 + H2O : 9.e-12_dp ; +{T043} CO + OH = HO2{ + CO2} : usr8(temp, c_m) ; +{T044} C2H4 + OH{ + M} = 0.75 EO2 + 0.5 CH2O + 0.25 HO2{ + M} : TROE( 1.e-28_dp , .8_dp , 8.8e-12_dp , 0._dp , TEMP, C_M) ; +{T045} C2H4 + O3 = CH2O + 0.12 HO2 + 0.5 CO + 0.12 OH + 0.5 HCOOH : ARR2(1.2e-14_dp, 2630._dp, TEMP) ; +{T046} SO2 + OH = SO4 : usr23( TEMP, C_M ) ; +{T047} GLYOXAL + OH = HO2 + CO{ + CO2} : 1.1e-11_dp ; +{T048} EO2 + NO = EO + NO2 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T049} EO + M{ = O2} = GLYALD + HO2 : 1e-14_dp ; +{T050} EO = 2 CH2O + HO2 : ARR2(1.6e11_dp, 4150._dp, TEMP) ; +{T051} C2H6 + OH = C2H5O2{ + H2O} : ARR2(8.7e-12_dp, 1070._dp, TEMP) ; +{T052} C2H5O2 + NO = CH3CHO + HO2 + NO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T053} C2H5O2 + HO2 = C2H5OOH + den{ + O2} : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T054} C2H5O2 + CH3O2 = .7 CH2O + .8 CH3CHO + .3 CH3OH + .2 C2H5OH + + HO2 + den : 2.e-13_dp ; +{T055} C2H5OOH + OH = .5 C2H5O2 + .5 CH3CHO + .5 OH : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T056} C3H6 + OH{ + M} = PO2{ + M} : JPL_TROE( 8.0e-27_dp , 3.5_dp , 3.e-11_dp , 0._dp , .5_dp, TEMP, C_M) ; +{T057} C3H6 + O3 = .54 CH2O + .19 HO2 + .33 OH + .08 CH4 + .56 CO + + .5 CH3CHO + .31 CH3O2 + .25 CH3COOH : ARR2(6.5e-15_dp, 1900._dp, TEMP) ; +{T058} C3H6 + NO3 = ONIT : ARR2(4.6e-13_dp, 1156._dp, TEMP) ; +{T059} PO2 + NO = CH3CHO + CH2O + HO2 + NO2 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T060} PO2 + HO2 = POOH + den{ + O2} : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T061} POOH + OH = .5 PO2 + .5 OH + .5 HYAC : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T062} CH3CHO + OH = CH3CO3{ + H2O} : ARR2(5.6e-12_dp, -270._dp, TEMP) ; +{T063} CH3CHO + NO3 = CH3CO3 + HNO3 : ARR2(1.4e-12_dp, 1900._dp, TEMP) ; +{T064} CH3CO3 + NO = CH3O2 + NO2 + nume{ + CO2} : ARR2(8.1e-12_dp, -270._dp, TEMP) ; +{T065} CH3CO3 + NO2{ + M} = PAN{ + M} : TROE( 8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 1._dp , TEMP, C_M) ; +{T066} CH3CO3 + HO2 = .75 CH3COOOH + .25 CH3COOH + .25 O3 + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T067} CH3CO3 + CH3O2 = .9 CH3O2 + .9 HO2 + .1 CH3COOH + CH2O + { + 0.5 CO2} + den : ARR2(2.e-12_dp, -500._dp, TEMP) ; +{T068} CH3COOOH + OH = .5 CH3CO3 + .5 CH2O{ + H2O + 0.5 CO2} : 1.e-12_dp ; +{T069} PAN{ + M} = CH3CO3 + NO2{ + M} : TROEE( 1.111e28_dp,14000._dp,8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 0._dp , TEMP, C_M) ; +{T070} CH3CO3 + CH3CO3 = 2 CH3O2 + den{ + 2 CO2} : ARR2(2.5e-12_dp, -500._dp, TEMP) ; +{T071} C3H8 + OH = C3H7O2{ + H2O} : ARR2(1.e-11_dp, 660._dp, TEMP) ; +{T072} C3H7O2 + NO = .82 CH3COCH3 + .27 CH3CHO + NO2 + HO2 + nume : ARR2(4.e-12_dp, -180._dp, TEMP) ; +{T073} C3H7O2 + HO2 = C3H7OOH + den{ + O2} : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T074} C3H7O2 + CH3O2 = CH2O + HO2 + .82 CH3COCH3 + den : ARR2(3.75e-13_dp, 40._dp, TEMP) ; +{T075} C3H7OOH + OH = C3H7O2{ + H2O} : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T076} CH3COCH3 + OH = RO2{ + H2O} : 3.82e-11_dp*exp( -2000._dp/temp ) + 1.33e-13_dp ; +{T077} RO2 + NO = CH3CO3 + CH2O + NO2 + nume : ARR2(2.9e-12_dp, -300._dp, TEMP) ; +{T078} RO2 + HO2 = ROOH + den{ + O2} : ARR2(8.6e-13_dp, -700._dp, TEMP) ; +{T079} RO2 + CH3O2 = .3 CH3CO3 + .8 CH2O + .3 HO2 + .2 HYAC + + .5 CH3COCHO + .5 CH3OH + den : ARR2(2.e-12_dp, -500._dp, TEMP) ; +{T080} ROOH + OH = RO2{ + H2O} : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T081} BIGENE + OH = ENEO2 : 5.4e-11_dp ; +{T082} ENEO2 + NO = CH3CHO + .5 CH2O + .5 CH3COCH3 + HO2 + NO2 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T083} BIGALK + OH = ALKO2 : 3.5e-12_dp ; +{T084} ALKO2 + NO = .4 CH3CHO + .1 CH2O + .25 CH3COCH3 + .9 HO2 + + .75 MEK + .9 NO2 + .1 ONIT + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T085} ALKO2 + HO2 = ALKOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T086} ALKOOH + OH = ALKO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T087} ONIT + OH = NO2 + CH3COCHO : 6.8e-13_dp ; +{T088} MEK + OH = MEKO2 : ARR2(2.3e-12_dp, 170._dp, TEMP) ; +{T089} MEKO2 + NO = CH3CO3 + CH3CHO + NO2 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T090} MEKO2 + HO2 = MEKOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T091} MEKOOH + OH = MEKO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T092} TOLO2 + HO2 = TOLOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T093} TOLOOH + OH = TOLO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T094} ISOP + OH = ISOPO2 : ARR2(2.54e-11_dp, -410._dp, TEMP) ; +{T095} ISOP + O3 = .4 MACR + .2 MVK + .07 C3H6 + .27 OH + .06 HO2 + + .6 CH2O + .3 CO + .1 O3 + .2 MCO3 + .2 CH3COOH : ARR2(1.05e-14_dp, 2000._dp, TEMP) ; +{T096} ISOPO2 + NO = .08 ONITR + .92 NO2 + .23 MACR + .32 MVK + + .33 HYDRALD + .02 GLYOXAL + .02 GLYALD + + .02 CH3COCHO + .02 HYAC + .55 CH2O + .92 HO2 + + nume : ARR2(4.4e-12_dp, -180._dp, TEMP) ; +{T097} ISOPO2 + NO3 = HO2 + NO2 + .6 CH2O + .25 MACR + .35 MVK + + .36 HYDRALD + 0.02 HYAC + .02 CH3COCHO + + .02 GLYOXAL + .02 GLYALD : 2.4e-12_dp ; +{T098} ISOPO2 + HO2 = ISOPOOH + den : ARR2(8.e-13_dp, -700._dp, TEMP) ; +{T099} ISOPOOH + OH = .5 XO2 + .5 ISOPO2 : ARR2(1.52e-11_dp, -200._dp, TEMP) ; +{T100} ISOPO2 + CH3O2 = .25 CH3OH + HO2 + 1.2 CH2O + .19 MACR + .26 MVK + + .3 HYDRALD + den : ARR2(5.e-13_dp, -400._dp, TEMP) ; +{T101} ISOPO2 + CH3CO3 = CH3O2 + HO2 + 0.6 CH2O + .25 MACR + .35 MVK + + .4 HYDRALD + den { + CO2} : 1.4e-11_dp ; +{T102} MVK + OH = MACRO2 : ARR2(4.13e-12_dp, -452._dp, TEMP) ; +{T103} MVK + O3 = .8 CH2O + .95 CH3COCHO + .08 OH + .2 O3 + + .06 HO2 + .05 CO + .04 CH3CHO : ARR2(7.52e-16_dp, 1521._dp, TEMP) ; +{T104} MACR + OH = .5 MACRO2 + .5 MCO3{ + 0.5 H2O} : ARR2(1.86e-11_dp, -175._dp, TEMP) ; +{T105} MACR + O3 = .8 CH3COCHO + .275 HO2 + .2 CO + .7 CH2O + + .215 OH + .2 O3 : ARR2(4.4e-15_dp, 2500._dp, TEMP) ; +{T106} MACRO2 + NO = NO2 + .47 HO2 + .25 CH2O + .25 CH3COCHO + + .53 CH3CO3 + .53 GLYALD + .22 HYAC + .22 CO + + nume : ARR2(2.7e-12_dp, -360._dp, TEMP) ; +{T107} MACRO2 + NO = .8 ONITR + nume : ARR2(1.3e-13_dp, -360._dp, TEMP) ; +{T108} MACRO2 + NO3 = NO2 + .47 HO2 + .25 CH2O + .25 CH3COCHO + + .22 CO + .53 GLYALD + .22 HYAC + .53 CH3CO3 : 2.4e-12_dp ; +{T109} MACRO2 + HO2 = MACROOH + den : ARR2(8.e-13_dp, -700._dp, TEMP) ; +{T110} MACRO2 + CH3O2 = .73 HO2 + .88 CH2O + .11 CO + .24 CH3COCHO + + .26 GLYALD + .26 CH3CO3 + .25 CH3OH + + .23 HYAC + den : ARR2(5.e-13_dp, -400._dp, TEMP) ; +{T111} MACRO2 + CH3CO3 = .25 CH3COCHO + CH3O2 + .22 CO + .47 HO2 + + .53 GLYALD + .22 HYAC + .25 CH2O + .53 CH3CO3 + { + CO2} + den : 1.4e-11_dp ; +{T112} MACROOH + OH = .5 MCO3 + .2 MACRO2 + .1 OH + .2 HO2 : ARR2(2.3e-11_dp, -200._dp, TEMP) ; +{T113} MCO3 + NO = NO2 + CH2O + CH3CO3 + nume{ + CO2} : ARR2(5.3e-12_dp, -360._dp, TEMP) ; +{T114} MCO3 + NO3 = NO2 + CH2O + CH3CO3{ + CO2} : 5.e-12_dp ; +{T115} MCO3 + HO2 = .25 O3 + .25 CH3COOH + .75 CH3COOOH + den + { + 0.75 O2} : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T116} MCO3 + CH3O2 = 2 CH2O + HO2 + CH3CO3 + den { + CO2} : ARR2(2.e-12_dp, -500._dp, TEMP) ; +{T117} MCO3 + CH3CO3 = CH3O2 + CH2O + CH3CO3 + den { + 2 CO2} : ARR2(4.6e-12_dp, -530._dp, TEMP) ; +{T118} MCO3 + MCO3 = 2 CH2O + 2 CH3CO3 + den { + 2 CO2} : ARR2(2.3e-12_dp, -530._dp, TEMP) ; +{T119} MCO3 + NO2 + M = MPAN{ + M} : 1.1e-11_dp*300._dp/(temp*c_m) ; +{T120} MPAN + M = MCO3 + NO2{ + M} : 1.2221e17_dp*300._dp*exp( -14000._dp/temp )/(temp*c_m) ; +{T121} OH + BENZENE = .53 PHENOL + .12 BEPOMUC + .65 HO2 + .35 BENZO2 : ARR2(2.3e-12_dp, 193._dp, TEMP) ; +{T122} OH + PHENOL = 0.14 PHENO2 + 0.80 HO2 + 0.06 PHENO : ARR2(4.7e-13_dp, -1220._dp, TEMP) ; +{T123} PHENO2 + NO = HO2 + .70 GLYOXAL + NO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T124} PHENO2 + HO2 = PHENOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T125} OH + PHENOOH = PHENO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T126} PHENO + NO2 = M : 2.1e-12_dp ; +{T127} PHENO + O3 = C6H5O2 : 2.8e-13_dp ; +{T128} C6H5O2 + NO = PHENO + NO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T129} C6H5O2 + HO2 = C6H5OOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T130} OH + C6H5OOH = C6H5O2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T131} BENZO2 + NO = NO2 + GLYOXAL + 0.5 BIGALD1 + HO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T132} BENZO2 + HO2 = BENZOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T133} OH + BENZOOH = BENZO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T134} MALO2 + NO2 = M : TROE( 8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 1._dp , TEMP, C_M) ; +{T135} MALO2 + NO = 0.4 GLYOXAL + 0.4 HO2 + 0.4 CO + nume : ARR2(7.5e-12_dp, -290._dp, TEMP) ; +{T136} MALO2 + HO2 = 0.16 GLYOXAL + 0.16 HO2 + 0.16 CO + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T137} OH + TOLUENE = 0.18 CRESOL + 0.10 TEPOMUC + 0.07 BZOO + + 0.65 TOLO2 + 0.28 HO2 : ARR2(1.7e-12_dp, -352._dp, TEMP) ; +{T138} OH + CRESOL = 0.20 PHENO2 + 0.73 HO2 + 0.07 PHENO : 4.7e-11_dp ; +{T139} BZOO + HO2 = BZOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T140} OH + BZOOH = BZOO : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T141} BZOO + NO = BZALD + NO2 + HO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T142} OH + BZALD = ACBZO2 : ARR2(5.9e-12_dp, -225._dp, TEMP) ; +{T143} ACBZO2 + NO2 = PBZNIT : TROE( 8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 1._dp , TEMP, C_M) ; +{T144} PBZNIT = ACBZO2 + NO2 : TROEE( 1.111e28_dp,14000._dp,8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 0._dp , TEMP, C_M) ; +{T145} ACBZO2 + NO = C6H5O2 + NO2 + nume : ARR2(7.5e-12_dp, -290._dp, TEMP) ; +{T146} ACBZO2 + HO2 = 0.4 C6H5O2 + 0.4 OH + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T147} TOLO2 + NO = NO2 + 0.6 GLYOXAL + 0.4 CH3COCHO + HO2 + + 0.2 BIGALD1 + 0.2 BIGALD2 + 0.2 BIGALD3 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T148} DICARBO2 + HO2 = 0.4 OH + 0.07 HO2 + 0.07 CH3COCHO + 0.07 CO + + 0.33 CH3O2 + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T149} DICARBO2 + NO = NO2 + 0.17 HO2 + 0.17 CH3COCHO + 0.17 CO + + 0.83 CH3O2 + nume : ARR2(7.5e-12_dp, -290._dp, TEMP) ; +{T150} MDIALO2 + HO2 = 0.4 OH + 0.33 HO2 + 0.07 CH3COCHO + 0.14 CO + + 0.07 CH3O2 + 0.07 GLYOXAL + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T151} MDIALO2 + NO = NO2 + 0.83 HO2 + 0.17 CH3COCHO + 0.35 CO + + 0.17 CH3O2 + 0.17 GLYOXAL + nume : ARR2(7.5e-12_dp, -290._dp, TEMP) ; +{T152} DICARBO2 + NO2 = M : TROE( 8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 1._dp , TEMP, C_M) ; +{T153} MDIALO2 + NO2 = M : TROE( 8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 1._dp , TEMP, C_M) ; +{T154} OH + XYLENES = 0.15 XYLOL + 0.23 TEPOMUC + 0.06 BZOO + + 0.56 XYLENO2 + 0.38 HO2 : 1.7e-11_dp ; +{T155} OH + XYLOL = 0.30 XYLOLO2 + 0.63 HO2 + 0.07 PHENO : 8.4e-11_dp ; +{T156} XYLOLO2 + NO = HO2 + NO2 + .17 GLYOXAL + .51 CH3COCHO + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T157} XYLOLO2 + HO2 = XYLOLOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T158} OH + XYLOLOOH = XYLOLO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T159} XYLENO2 + HO2 = XYLENOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T160} OH + XYLENOOH = XYLENO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T161} XYLENO2 + NO = NO2 + HO2 + 0.34 GLYOXAL + 0.54 CH3COCHO + + 0.06 BIGALD1 + 0.2 BIGALD2 + 0.15 BIGALD3 + + .21 BIGALD4 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T162} APIN + OH = TERPO2 : ARR2(1.2e-11_dp, -440._dp, TEMP) ; +{T163} BPIN + OH = TERPO2 : ARR2(1.6e-11_dp, -470._dp, TEMP) ; +{T164} LIMON + OH = TERPO2 : ARR2(4.2e-11_dp, -400._dp, TEMP) ; +{T165} MYRC + OH = TERPO2 : 2.1e-10_dp ; +{T166} BCARY + OH = TERPO2 : 2.0e-10_dp ; +{T167} APIN + O3 = .33 TERPROD1 + .3 TERPROD2 + .63 OH + .57 HO2 + + .23 CO + .52 CH3COCH3 + .34 CH2O + .1 BIGALD + + .05 HCOOH + .05 BIGALK + .06 CH3CO3 + .06 RO2 + { + .27 CO2} : ARR2(6.3e-16_dp, 580._dp, TEMP) ; +{T168} BPIN + O3 = .33 TERPROD1 + .3 TERPROD2 + .63 OH + .57 HO2 + + .23 CO + .52 CH3COCH3 + .34 CH2O + .1 BIGALD + + .05 HCOOH + .05 BIGALK + .06 CH3CO3 + .06 RO2 + { + .27 CO2} : ARR2(1.7e-15_dp, 1300._dp, TEMP) ; +{T169} LIMON + O3 = .33 TERPROD1 + .3 TERPROD2 + .63 OH + .57 HO2 + + .23 CO + .52 CH3COCH3 + .34 CH2O + .1 BIGALD + + .05 HCOOH + .05 BIGALK + .06 CH3CO3 + .06 RO2 + { + .27 CO2} : ARR2(3.0e-15_dp, 780._dp, TEMP) ; +{T170} MYRC + O3 = .33 TERPROD1 + .3 TERPROD2 + .63 OH + .57 HO2 + + .23 CO + .52 CH3COCH3 + .34 CH2O + .1 BIGALD + + .05 HCOOH + .05 BIGALK + .06 CH3CO3 + .06 RO2 + { + .27 CO2} : 4.7e-16_dp ; +{T171} BCARY + O3 = .33 TERPROD1 + .3 TERPROD2 + .63 OH + .57 HO2 + + .23 CO + .52 CH3COCH3 + .34 CH2O + .1 BIGALD + + .05 HCOOH + .05 BIGALK + .06 CH3CO3 + .06 RO2 + { + .27 CO2} : 1.2e-14_dp ; +{T172} LIMON + NO3 = NTERPO2 : 1.1e-11_dp ; +{T173} MYRC + NO3 = NTERPO2 : 1.2e-11_dp ; +{T174} BCARY + NO3 = NTERPO2 : 1.9e-11_dp ; +{T175} TERPO2 + NO = .1 ONITR + .9 NO2 + .36 CH2O + .045 CH3COCH3 + + .9 TERPROD1 + .9 HO2 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T176} TERPO2 + HO2 = TERPOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T177} TERPO2 + CH3O2 = TERPROD1 + .95 CH2O + .25 CH3OH + HO2 + + .025 CH3COCH3 + den : ARR2(2.0e-12_dp, -500._dp, TEMP) ; +{T178} TERPOOH + OH = TERPO2 : 3.3e-11_dp ; +{T179} TERP2OOH + OH = TERP2O2 : 2.3e-11_dp ; +{T180} TERPROD1 + OH = TERP2O2 : 5.7e-11_dp ; +{T181} TERPROD1 + NO3 = .5 TERP2O2 + .5 NTERPO2 : 1.0e-12_dp ; +{T182} TERP2O2 + NO = .1 ONITR + .9 NO2 + .34 CH2O + .27 CH3COCH3 + + .225 CO + .9 TERPROD2 + .9 HO2 + .225 GLYALD + { + .9 CO2} + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T183} TERP2O2 + HO2 = TERP2OOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T184} TERP2O2 + CH3O2 = TERPROD2 + .93 CH2O + .25 CH3OH + HO2 + { + .5 CO2} + .125 CO + .125 GLYALD + + .15 CH3COCH3 + den : ARR2(2.0e-12_dp, -500._dp, TEMP) ; +{T185} TERPROD2 + OH = .15 RO2 + .68 CH2O{ + 1.8 CO2} + .5 CH3COCH3 + + .65 CH3CO3 + .2 HO2 + .7 CO : 3.4e-11_dp ; +{T186} NTERPO2 + NO = .1 ONITR + 1.9 NO2 + .9 TERPROD1 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T187} NTERPO2 + HO2 = ONITR + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T188} NTERPO2 + CH3O2 = .5 ONITR + .75 CH2O + .25 CH3OH + .5 HO2 + + .5 TERPROD1 + .5 NO2 + den : ARR2(2.0e-12_dp, -500._dp, TEMP) ; +{T189} NTERPO2 + NO3 = 2 NO2 + TERPROD1 : 2.4e-12_dp ; +{T190} CH3COOH + OH = CH3O2{ + H2O + CO2} : 7.e-13_dp ; +{T191} ISOP + NO3 = ISOPNO3 : ARR2(3.03e-12_dp, 446._dp, TEMP) ; +{T192} ISOPNO3 + NO = 1.206 NO2 + .794 HO2 + .072 CH2O + .167 MACR + + .039 MVK + .794 ONITR + nume : ARR2(2.7e-12_dp, -360._dp, TEMP) ; +{T193} ISOPNO3 + NO3 = 1.206 NO2 + .072 CH2O + .167 MACR + .039 MVK + + .794 ONITR + .794 HO2 : 2.4e-12_dp ; +{T194} ISOPNO3 + HO2 = .206 NO2 + .206 OH + .206 CH2O + .167 MACR + + .039 MVK + .794 ONITR + den : ARR2(8.e-13_dp, -700._dp, TEMP) ; +{T195} CH3COCHO + OH = CH3CO3 + CO{ + H2O} : ARR2(8.4e-13_dp, -830._dp, TEMP) ; +{T196} CH3COCHO + NO3 = HNO3 + CO + CH3CO3 : ARR2(1.4e-12_dp, 1860._dp, TEMP) ; +{T197} ONITR + OH = HYDRALD + HO2 + .4 NO2 : 4.5e-11_dp ; +{T198} ONITR + NO3 = HYDRALD + HO2 + NO2 : ARR2(1.4e-12_dp, 1860._dp, TEMP) ; +{T199} HYDRALD + OH = XO2 : ARR2(1.86e-11_dp, -175._dp, TEMP) ; +{T200} XO2 + NO = NO2 + HO2 + .25 CO + .25 CH2O + .25 GLYOXAL + + .25 CH3COCHO + .25 HYAC + .25 GLYALD + nume : ARR2(2.7e-12_dp, -360._dp, TEMP) ; +{T201} XO2 + NO3 = NO2 + HO2 + .25 CO + .25 CH2O + .25 GLYOXAL + + .25 CH3COCHO + .25 HYAC + .25 GLYALD : 2.4e-12_dp ; +{T202} XO2 + HO2 = XOOH + den : ARR2(8.e-13_dp, -700._dp, TEMP) ; +{T203} XO2 + CH3O2 = .3 CH3OH + .8 HO2 + .8 CH2O + .2 CO + + .1 GLYOXAL + .1 CH3COCHO + .1 HYAC + + .1 GLYALD + den : ARR2(5.e-13_dp, -400._dp, TEMP) ; +{T204} XO2 + CH3CO3 = .25 CO + .25 CH2O + .25 GLYOXAL + CH3O2 + HO2 + + .25 CH3COCHO + .25 HYAC + .25 GLYALD { + CO2} + + den : ARR2(1.3e-12_dp, -640._dp, TEMP) ; +{T205} XOOH + OH = XO2{ + H2O} : ARR2(1.9e-12_dp, -190._dp, TEMP) ; +{T206} XOOH + OH = OH{ + H2O} : THERMAL_T2(7.69e-17_dp, -253._dp, TEMP) ; +{T207} CH3OH + OH = HO2 + CH2O : ARR2(7.3e-12_dp, 620._dp, TEMP) ; +{T208} C2H5OH + OH = HO2 + CH3CHO : ARR2(6.9e-12_dp, 230._dp, TEMP) ; +{T209} MPAN + OH = .5 HYAC + .5 NO3 + .5 CH2O + .5 HO2 { + 0.5 CO2} : JPL_TROE( 8.e-27_dp , 3.5_dp , 3.e-11_dp , 0.0_dp , .5_dp, TEMP, C_M) ; +{T210} PAN + OH = CH2O + NO3{ + CO2} : 4.e-14_dp ; +{T211} HYAC + OH = CH3COCHO + HO2 : 3.e-12_dp ; +{T212} GLYALD + OH = HO2 + .2 GLYOXAL + .8 CH2O { + 0.8 CO2} : 1.e-11_dp ; +{T213} DMS + OH = SO2 : ARR2(9.6e-12_dp, 234._dp, TEMP) ; +{T214} DMS + OH = .5 SO2 + .5 HO2 : usr24( temp, c_m ) ; +{T215} DMS + NO3 = SO2 + HNO3 : ARR2(1.9e-13_dp, -520._dp, TEMP) ; +{T216} NH3 + OH = M : ARR2(1.7e-12_dp, 710._dp, TEMP) ; +{T217} HO2 = .5 H2O2 : usr26( rh, temp ) ; +{T218} C2H5O2 + C2H5O2 = 1.6 CH3CHO + 1.2 HO2 + .4 C2H5OH + den : 6.8e-14_dp ; +{T219} MBO + OH = MBOO2 : ARR2(8.1e-12_dp, -610._dp, TEMP) ; +{T220} MBOO2 + NO = HO2 + .67 GLYALD + .67 CH3COCH3 + .33 HMPROP + + .33 CH2O + NO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T221} MBOO2 + CH3O2 = .917 CH2O + HO2 + .25 CH3OH + .333 GLYALD + + .333 CH3COCH3 + .167 HMPROP + den : ARR2(3.75e-13_dp, 40._dp, TEMP) ; +{T222} HMPROP + OH = HMPROPO2 : 1.4e-11_dp ; +{T223} HMPROPO2 + NO = NO2 + HO2 + CH3COCH3{ + CO2} + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T224} HMPROPO2 + HO2 = .4 OH + .4 HO2 + .4 CH3COCH3{ + .4 * CO2} + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T225} MBOO2 + HO2 = MBOOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T226} MBOOOH + OH = .5 MBOO2 + .5 OH : ARR2(3.8e-12_dp ,-200._dp, TEMP) ; +{T227} MBO + O3 = .1 CO + .5 CH2O + .1 CH3COCH3 + .9 HMPROP + + .25 HCOOH + .25 CO + .06 HO2 + .06 OH : 1e-17_dp ; +{T228} MBO + NO3 = MBONO3O2 : ARR2(4.6e-14_dp, 400._dp, TEMP) ; +{T229} MBONO3O2 + HO2 = .0 * H2O + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T230} MBONO3O2 + NO = .25 HMPROP + .25 CH2O + 1.25 NO2 + .75 ONIT + + .75 CH3COCH3 + .75 HO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T231} MBONO3O2 + NO3 = .25 HMPROP + .25 CH2O + 1.25 NO2 + .75 ONIT + + .75 CH3COCH3 + .75 HO2 : 2.4e-12_dp ; +{T232} C2H2 + OH{ + M} = 0.65 GLYOXAL + 0.65 OH + 0.35 HCOOH + 0.35 HO2 + + 0.35 CO{ + M} : TROE( 5.5e-30_dp , 0._dp, 8.3e-13_dp, -2._dp, TEMP, C_M) ; +{T233} HCOOH + OH = HO2 + H2O{ + CO2} : 4.5e-13 ; +{T234} CH2O + HO2 = HOCH2OO : ARR2(9.7e-15_dp, -625._dp, TEMP) ; +{T235} HOCH2OO = CH2O + HO2 : ARR2(2.4e12_dp, 7000._dp, TEMP) ; +{T236} HOCH2OO + NO = HCOOH + NO2 + HO2 + nume : ARR2(2.6e-12_dp, -265._dp, TEMP) ; +{T237} HOCH2OO + HO2 = HCOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{S001} VOCA + OH = smpa + OH : 1.25D-11 ; +{S002} VOCBB + OH = smpbb + OH : 1.25D-11 ; +{S003} ISOP + OH = biog1_c + ISOP + OH : Keff(2.50D-11,-408.0_dp,0.0_dp,TEMP,nume,den,0.0104_dp,0.0078_dp) ; +{S004} APIN + OH = biog1_o + APIN + OH : Keff(1.2D-11,-440.0_dp,0.0_dp,TEMP,nume,den,0.036_dp,0.2065_dp) ; +{S005} BPIN + OH = biog1_o + BPIN + OH : Keff(1.6D-11,-470.0_dp,0.0_dp,TEMP,nume,den,0.036_dp,0.2065_dp) ; +{S006} LIMON + OH = biog1_o + LIMON + OH : Keff(4.2D-11,-400.0_dp,0.0_dp,TEMP,nume,den,0.036_dp,0.2065_dp) ; diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.kpp b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.kpp new file mode 100644 index 00000000..f58b0ca1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.kpp @@ -0,0 +1,11 @@ +#MODEL mozart_mosaic_4bin +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.spc b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.spc similarity index 53% rename from wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.spc rename to wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.spc index 95dc2f56..531a4e75 100644 --- a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.spc +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.spc @@ -16,10 +16,17 @@ H2O2 =IGNORE ; CH4 =IGNORE ; CO =IGNORE ; +// 20120808 acd_ck_formicacid start + HCOOH = IGNORE ; + HOCH2OO = IGNORE ; +// 20120808 acd_ck_formicacid end CH3O2 =IGNORE ; CH3OOH =IGNORE ; CH2O =IGNORE ; CH3OH =IGNORE ; +// 20120808 acd_ck_ethyne start +C2H2 = IGNORE ; +// 20120808 acd_ck_ethyne start C2H4 =IGNORE ; EO =IGNORE ; EO2 =IGNORE ; @@ -46,10 +53,29 @@ C2H5OOH =IGNORE ; C3H7O2 =IGNORE ; C3H7OOH =IGNORE ; - C10H16 =IGNORE ; +// 20130816 acd_alma_bio start + APIN =IGNORE ; + BPIN =IGNORE ; + LIMON =IGNORE ; + MYRC =IGNORE ; + BCARY =IGNORE ; + TERPROD1 =IGNORE ; + TERPROD2 =IGNORE ; + TERP2O2 =IGNORE ; + TERP2OOH =IGNORE ; + NTERPO2 =IGNORE ; +// 20130816 acd_alma_bio end RO2 =IGNORE ; ROOH =IGNORE ; ONIT =IGNORE ; +// 20130816 acd_alma_bio start + MBO =IGNORE ; + MBOO2 =IGNORE ; + HMPROP =IGNORE ; + HMPROPO2 =IGNORE ; + MBOOOH =IGNORE ; + MBONO3O2 =IGNORE ; +// 20130816 acd_alma_bio end ONITR =IGNORE ; ISOP =IGNORE ; ISOPO2 =IGNORE ; @@ -78,8 +104,41 @@ SO2 =IGNORE ; SO4 =IGNORE ; XO2 =IGNORE ; - XOH =IGNORE ; XOOH =IGNORE ; +// 20130816 acd_ck_aromatics start + BENZENE = IGNORE ; + PHENOL = IGNORE ; + BEPOMUC = IGNORE ; + BENZO2 = IGNORE ; + PHENO2 = IGNORE ; + PHENO = IGNORE ; + PHENOOH = IGNORE ; + C6H5O2 = IGNORE ; + C6H5OOH = IGNORE ; + BENZOOH = IGNORE ; + BIGALD1 = IGNORE ; + BIGALD2 = IGNORE ; + BIGALD3 = IGNORE ; + BIGALD4 = IGNORE ; + MALO2 = IGNORE ; + PBZNIT = IGNORE ; + TEPOMUC = IGNORE ; + BZOO = IGNORE ; + BZOOH = IGNORE ; + BZALD = IGNORE ; + ACBZO2 = IGNORE ; + DICARBO2 = IGNORE ; + MDIALO2 = IGNORE ; + XYLENES = IGNORE ; + XYLOL = IGNORE ; + XYLOLO2 = IGNORE ; + XYLOLOOH = IGNORE ; + XYLENO2 = IGNORE ; + XYLENOOH = IGNORE ; +// 20130816 acd_ck_aromatics end +// 20130816 acd_ck_hono start + HONO = IGNORE; +// 20130816 acd_ck_hono end NUME = IGNORE; DEN=IGNORE; BIOG1_c=IGNORE; diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin_wrfkpp.equiv similarity index 85% rename from wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0_wrfkpp.equiv rename to wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin_wrfkpp.equiv index 2938731f..d90feca4 100644 --- a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0_wrfkpp.equiv +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin_wrfkpp.equiv @@ -33,3 +33,8 @@ CRES CRESOL TOL TOLUENE TO2 TOLO2 SULF SO4 +! 20130116 acd_ck_aromatics start +PHEN PHENOL +XYL XYLENES +BALD BZALD +! 20130116 acd_ck_aromatics end diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.def b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.def new file mode 100644 index 00000000..a09ca0cf --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.def @@ -0,0 +1,250 @@ +#include atoms_red +#include ./mozart_mosaic_4bin_aq.spc +#include ./mozart_mosaic_4bin_aq.eqn + + + + +#INLINE F90_RATES + +REAL(kind=dp) FUNCTION JPL_TROE( k0_300K, n, kinf_300K, m, base, temp, cair ) + +!------------------------------------------------------------ +! ... dummy arguments +!------------------------------------------------------------ + REAL(kind=dp), INTENT(IN) :: base ! base expononent + REAL(kind=dp), INTENT(IN) :: temp ! temperature [K] + REAL(kind=dp), INTENT(IN) :: cair ! air concentration [molecules/cm3] + REAL(kind=dp), INTENT(IN) :: k0_300K ! low pressure limit at 300 K + REAL(kind=dp), INTENT(IN) :: n ! exponent for low pressure limit + REAL(kind=dp), INTENT(IN) :: kinf_300K ! high pressure limit at 300 K + REAL(kind=dp), INTENT(IN) :: m ! exponent for high pressure limit + +!------------------------------------------------------------ +! ... local variables +!------------------------------------------------------------ + REAL(kind=dp) :: zt_help, k0_T, kinf_T, k_ratio + + zt_help = 300._dp/temp + k0_T = k0_300K * zt_help**(n) * cair ! k_0 at current T + kinf_T = kinf_300K * zt_help**(m) ! k_inf at current T + k_ratio = k0_T/kinf_T + + JPL_TROE = k0_T/(1._dp + k_ratio)*base**(1._dp/(1._dp + LOG10(k_ratio)**2)) + +END FUNCTION JPL_TROE + +REAL(KIND=dp) FUNCTION usr5( temp, c_m ) + + REAL(KIND=dp), INTENT(IN) :: temp + REAL(KIND=dp), INTENT(IN) :: c_m + + REAL(KIND=dp) :: k0, k2 + + k0 = c_m * 6.5e-34_dp * exp( 1335._dp/temp ) + k2 = exp( 2199._dp/temp ) + k0 = k0 /(1.0_dp + k0/(2.7e-17_dp*k2)) + k2 = exp( 460._dp/temp ) + + usr5 = k0 + 2.4e-14_dp * k2 + +END FUNCTION usr5 + +REAL(KIND=dp) FUNCTION usr8( temp, c_m ) + + REAL(KIND=dp), INTENT(IN) :: temp + REAL(KIND=dp), INTENT(IN) :: c_m + + REAL(KIND=dp), parameter :: boltz = 1.38044e-16_dp + + usr8 = 1.5e-13_dp * (1._dp + 6.e-7_dp*boltz*c_m*temp) + +END FUNCTION usr8 + +REAL(KIND=dp) FUNCTION usr9( temp, c_m, c_h2o ) + + REAL(KIND=dp), INTENT(IN) :: temp + REAL(KIND=dp), INTENT(IN) :: c_m + REAL(KIND=dp), INTENT(IN) :: c_h2o + + REAL(KIND=dp) :: ko, kinf, fc + + if( c_h2o > 0._dp ) then + ko = 2.3e-13_dp * exp( 600._dp/temp ) + kinf = 1.7e-33_dp * c_m * exp( 1000._dp/temp ) + fc = 1._dp/c_h2o + 1.4e-21_dp * exp( 2200._dp/temp ) + usr9 = (ko + kinf) * fc + else + usr9 = 0._dp + end if + +END FUNCTION usr9 + +REAL(KIND=dp) FUNCTION usr16( rh, temp ) + + REAL(KIND=dp), INTENT(IN) :: rh ! relative humidity + REAL(KIND=dp), INTENT(IN) :: temp ! temperature (K) + + + usr16 = 0._dp + +END FUNCTION usr16 + +REAL(KIND=dp) FUNCTION usr17( rh, temp ) + + REAL(KIND=dp), INTENT(IN) :: rh ! relative humidity + REAL(KIND=dp), INTENT(IN) :: temp ! temperature (K) + + usr17 = 0._dp + +END FUNCTION usr17 + +REAL(KIND=dp) FUNCTION usr17a( rh, temp ) + + REAL(KIND=dp), INTENT(IN) :: rh ! relative humidity + REAL(KIND=dp), INTENT(IN) :: temp ! temperature (K) + + usr17a = 0._dp + +END FUNCTION usr17a + +REAL(KIND=dp) FUNCTION usr23( temp, c_m ) + + REAL(KIND=dp), INTENT(IN) :: temp + REAL(KIND=dp), INTENT(IN) :: c_m + + REAL(KIND=dp) :: fc, k0 + REAL(KIND=dp) :: wrk + + fc = 3.e-11_dp * (300._dp/temp) ** 3.3_dp + wrk = fc * c_m + k0 = wrk / (1._dp + wrk/1.5e-12_dp) + usr23 = k0 * .6_dp ** (1._dp/(1._dp + (log10( wrk/1.5e-12_dp ))**2._dp)) + +END FUNCTION usr23 + +REAL(KIND=dp) FUNCTION usr24( temp, c_m ) + + REAL(KIND=dp), INTENT(IN) :: temp + REAL(KIND=dp), INTENT(IN) :: c_m + + REAL(KIND=dp) :: ko, wrk + + wrk = .21_dp*c_m + ko = 1._dp + 5.5e-31_dp*exp( 7460._dp/temp )*wrk + usr24 = 1.7e-42_dp*exp( 7810._dp/temp )*wrk/ko + +END FUNCTION usr24 + +REAL(KIND=dp) FUNCTION usr26( rh, temp ) + + REAL(KIND=dp), INTENT(IN) :: rh ! relative humidity + REAL(KIND=dp), INTENT(IN) :: temp ! temperature (K) + + usr26 = 0._dp + +END FUNCTION usr26 + + + +!__________________________________________________ + + REAL(KIND=dp) FUNCTION Keff ( A0,B0,C0, TEMP,X1,X2,y1,y2 ) + REAL(KIND=dp),INTENT(IN) :: X1,X2,y1,y2 + REAL(KIND=dp),INTENT(IN) :: TEMP + REAL(KIND=dp),INTENT(IN):: A0,B0,C0 + Keff = A0 * EXP(- B0 /TEMP ) & + *(TEMP/300._dp)**C0*(y1*X1/(X1 + X2 + 1.0e-35) & + +y2*(1-X1/(X1 + X2 + 1.0e-35))) + END FUNCTION Keff +!__________________________________________________ + + REAL(KIND=dp) FUNCTION Keff2 ( C0,X1,X2,y1,y2 ) + REAL(KIND=dp),INTENT(IN) :: X1,X2,y1,y2 + REAL(KIND=dp),INTENT(IN):: C0 + Keff2 = C0*(y1*X1/(X1 + X2 + 1.0e-35) & + +y2*(1-X1/(X1 + X2 + 1.0e-35 ))) + END FUNCTION Keff2 + +!__________________________________________________ + + + REAL(KIND=dp) FUNCTION vbs_yield ( nume, den, voc_idx, bin_idx ) + REAL(KIND=dp), INTENT(IN) :: nume, den + INTEGER, INTENT(IN) :: voc_idx, bin_idx + INTEGER, PARAMETER :: vbs_nbin = 4, vbs_nspec = 9 + + ! normalized (1 g/m3 density) yield for condensable vapors + REAL(KIND=dp) :: vbs_alphlowN(vbs_nbin,vbs_nspec) + REAL(KIND=dp) :: vbs_alphhiN(vbs_nbin,vbs_nspec) + REAL(KIND=dp) :: vbs_mw_prec(vbs_nspec) + ! SOA density (g/m3) + REAL(KIND=dp), PARAMETER :: dens_aer = 1.5 + ! SOA molecular weight (g/mol) + REAL(KIND=dp), PARAMETER :: mw_aer = 250.0 + + ! -------------------------------------------------------------------------- + ! Yields used in Murphy and Pandis, 2009; Tsimpidi et al., 2010; + ! Ahmadov et al., 2012 + + ! low NOx condition + DATA vbs_alphlowN / & + 0.0000, 0.0750, 0.0000, 0.0000, & ! ALK4 + 0.0000, 0.3000, 0.0000, 0.0000, & ! ALK5 + 0.0045, 0.0090, 0.0600, 0.2250, & ! OLE1 + 0.0225, 0.0435, 0.1290, 0.3750, & ! OLE2 + 0.0750, 0.2250, 0.3750, 0.5250, & ! ARO1 + 0.0750, 0.3000, 0.3750, 0.5250, & ! ARO2 + 0.0090, 0.0300, 0.0150, 0.0000, & ! ISOP + 0.0750, 0.1500, 0.7500, 0.9000, & ! SESQ + 0.1073, 0.0918, 0.3587, 0.6075/ ! TERP + + ! high NOx condition + DATA vbs_alphhiN / & + 0.0000, 0.0375, 0.0000, 0.0000, & ! ALK4 + 0.0000, 0.1500, 0.0000, 0.0000, & ! ALK5 + 0.0008, 0.0045, 0.0375, 0.1500, & ! OLE1 + 0.0030, 0.0255, 0.0825, 0.2700, & ! OLE2 + 0.0030, 0.1650, 0.3000, 0.4350, & ! ARO1 + 0.0015, 0.1950, 0.3000, 0.4350, & ! ARO2 + 0.0003, 0.0225, 0.0150, 0.0000, & ! ISOP + 0.0750, 0.1500, 0.7500, 0.9000, & ! SESQ + 0.0120, 0.1215, 0.2010, 0.5070/ ! TERP + + DATA vbs_mw_prec / & + 120.0, & ! ALK4 + 150.0, & ! ALK5 + 120.0, & ! OLE1 + 120.0, & ! OLE2 + 150.0, & ! ARO1 + 150.0, & ! ARO2 + 136.0, & ! ISOP + 250.0, & ! SESQ + 180.0/ ! TERP + + REAL(KIND=dp), PARAMETER :: yields_dens_aer = 1.5 ! g/m3 + + ! + ! -------------------------------------------------------------------------- + + REAL(KIND=dp) :: B, mw_ratio, dens_ratio + + ! Lane et al., ES&T, 2008 + ! B = (RO2 + NO) / ((RO2 + NO) + (RO2 + RO2) + (RO2 + HO2)) + ! with nume = (RO2 + NO) and den = (RO2 + RO2) + (RO2 + HO2) + B = nume / (nume + den + 1.0e-35_dp) + + ! we need molar yields, not mass yields + mw_ratio = vbs_mw_prec(voc_idx)/mw_aer + + ! density correction + dens_ratio = dens_aer / yields_dens_aer + + vbs_yield = (vbs_alphhiN(bin_idx,voc_idx) * B + & + vbs_alphlowN(bin_idx,voc_idx) * (1.0_dp - B)) * & + dens_ratio * mw_ratio + + END FUNCTION vbs_yield + + +#ENDINLINE diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.eqn b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.eqn new file mode 100755 index 00000000..4257c73c --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.eqn @@ -0,0 +1,426 @@ +#EQUATIONS +{J001} M{ = O2} + hv = O + O : .20946_dp*j(Pj_o2) ; +{J002} O3 + hv = O1D_CB4{ + O2} : j(Pj_o31d) ; +{J003} O3 + hv = O{ + O2} : j(Pj_o33p) ; +{J004} N2O + hv = O1D_CB4{ + N2} : j(Pj_n2o) ; +{J005} NO2 + hv = O + NO : j(Pj_no2) ; +{J006} N2O5 + hv = NO2 + NO3 : j(Pj_n2o5) ; +{J007} HNO3 + hv = OH + NO2 : j(Pj_hno3) ; +{J008} NO3 + hv = .89 NO2 + .11 NO + .89 O3 : j(Pj_no3o) ; +{J009} HO2NO2 + hv = 0.66 HO2 + 0.66 NO2 + 0.33 OH + 0.33 NO3 : j(Pj_hno4) ; +{J010} CH3OOH + hv = CH2O + HO2 + OH : j(Pj_ch3o2h) ; +{J011} CH2O + hv = HO2 + HO2 + CO : j(Pj_ch2or) ; +{J012} CH2O + hv = CO + H2 : j(Pj_ch2om) ; +{J013} H2O2 + hv = OH + OH : j(Pj_h2o2) ; +{J014} CH3CHO + hv = CH3O2 + CO + HO2 : j(Pj_ch3cho) ; +{J015} POOH + hv = CH3CHO + CH2O + HO2 + OH : j(Pj_pooh) ; +{J016} CH3COOOH + hv = CH3O2 + OH{ + CO2} : .28_dp*j(Pj_h2o2) ; +{J017} PAN + hv = 0.6 CH3CO3 + 0.6 NO2 + 0.4 CH3O2 + 0.4 NO3 + { + 0.4 CO2} : j(Pj_pan) ; +{J018} MPAN + hv = MCO3 + NO2 : j(Pj_pan) ; +{J019} MACR + hv = 0.67 HO2 + 0.33 MCO3 + 0.67 CH2O + 0.67 CH3CO3 + + 0.33 OH + 0.67 CO : j(Pj_macr) ; +{J020} MVK + hv = 0.7 C3H6 + 0.7 CO + 0.3 CH3O2 + 0.3 CH3CO3 : j(Pj_mvk) ; +{J021} C2H5OOH + hv = CH3CHO + HO2 + OH : j(Pj_ch3o2h) ; +{J022} C3H7OOH + hv = 0.82 CH3COCH3 + HO2 + OH : j(Pj_ch3o2h) ; +{J023} ROOH + hv = CH3CO3 + CH2O + OH : j(Pj_ch3o2h) ; +{J024} CH3COCH3 + hv = CH3CO3 + CH3O2 : j(Pj_ch3coch3) ; +{J025} CH3COCHO + hv = CH3CO3 + CO + HO2 : j(Pj_ch3cocho) ; +{J026} XOOH + hv = OH : j(Pj_ch3o2h) ; +{J027} ONITR + hv = HO2 + CO + NO2 + CH2O : j(Pj_ch3cho) ; +{J028} ISOPOOH + hv = .402 MVK + .288 MACR + .69 CH2O + HO2 : j(Pj_ch3o2h) ; +{J029} HYAC + hv = CH3CO3 + HO2 + CH2O : j(Pj_hyac) ; +{J030} GLYALD + hv = HO2 + HO2 + CO + CH2O : j(Pj_glyald) ; +{J031} MEK + hv = CH3CO3 + C2H5O2 : j(Pj_mek) ; +{J032} BIGALD + hv = 0.45 CO + 0.13 GLYOXAL + 0.56 HO2 + 0.13 CH3CO3 + + 0.18 CH3COCHO : .2_dp*j(Pj_no2) ; +{J033} GLYOXAL + hv = CO + CO + HO2 + HO2 : j(Pj_gly) ; +{J034} ALKOOH + hv = 0.4 CH3CHO + 0.1 CH2O + 0.25 CH3COCH3 + 0.9 HO2 + + 0.8 MEK + OH : j(Pj_ch3o2h) ; +{J035} MEKOOH + hv = OH + CH3CO3 + CH3CHO : j(Pj_ch3o2h) ; +{J036} TOLOOH + hv = OH + 0.45 GLYOXAL + 0.45 CH3COCHO + 0.9 BIGALD : j(Pj_ch3o2h) ; +{J037} BIGALD1 + hv = 0.6 MALO2 + HO2 : 0.140*j(Pj_no2) ; +{J038} BEPOMUC + hv = BIGALD1 + 1.5 HO2 + 1.5 CO : 0.100*j(Pj_no2) ; +{J039} TEPOMUC + hv = .5 CH3CO3 + HO2 + 1.5 CO : 0.100*j(Pj_no2) ; +{J040} BIGALD2 + hv = 0.6 HO2 + 0.6 DICARBO2 : 0.200*j(Pj_no2) ; +{J041} BIGALD3 + hv = 0.6 HO2 + 0.6 CO + 0.6 MDIALO2 : 0.200*j(Pj_no2) ; +{J042} BIGALD4 + hv = HO2 + CO + CH3COCHO + CH3CO3 : 0.006*j(Pj_no2) ; +{J043} MBOOOH + hv = OH + HO2 + 0.67 * GLYALD + 0.67 * CH3COCH3 + + 0.33 * HMPROP + 0.33 * CH2O : j(Pj_ch3o2h) ; +{J044} HMPROP + hv = 2 * HO2 + CO + CH3COCH3 : j(Pj_glyald) ; +{J045} TERPROD1 + hv = HO2 + CO + TERPROD2 : j(Pj_ch3cho) ; +{J046} TERPROD2 + hv = 0.15 RO2 + 0.68 CH2O + 0.5 CH3COCH3 + + 0.65 CH3CO3 + 1.2 HO2 + 1.7 CO{ + 0.8 CO2} : j(Pj_ch3cho) ; +{J047} TERPOOH + hv = 0.4 CH2O + 0.05 CH3COCH3 + TERPROD1 + HO2 + OH : j(Pj_ch3o2h) ; +{J048} TERP2OOH + hv = OH + 0.375 CH2O + 0.3 CH3COCH3 + 0.25 CO + + TERPROD2 + HO2 + 0.25 GLYALD{ + CO2} : j(Pj_ch3o2h) ; +{J049} HONO + hv = OH + NO : j(Pj_hno2) ; +{T001} O + M{ = O2} = O3 : 0.20946*(C_M *6.00e-34_dp*(TEMP/300._dp)**(-2.3_dp)) ; +{T002} O + O3 = M{ = O2 + O2} : ARR2(8.0e-12_dp, 2060.0_dp, TEMP) ; +{T003} O1D_CB4 + + M{ = O2,N2} = O{ + O2,N2} : .79_dp*ARR2(2.1e-11_dp, -115.0_dp, TEMP) + .21_dp*ARR2(3.2e-11_dp, -70.0_dp, TEMP) ; +{T004} O1D_CB4 + H2O = OH + OH : 2.2e-10_dp ; +{T005} O1D_CB4 + H2 = HO2 + OH : 1.1e-10_dp ; +{T006} OH + H2 = HO2 + H2O : ARR2(5.5e-12_dp, 2000.0_dp, TEMP) ; +{T007} O + OH = HO2{ + O2} : ARR2(2.2e-11_dp, -120.0_dp, TEMP) ; +{T008} O + HO2 = OH{ + O2} : ARR2(3.0e-11_dp, -200.0_dp, TEMP) ; +{T009} OH + O3 = HO2{ + O2} : ARR2(1.7e-12_dp, 940.0_dp, TEMP) ; +{T010} HO2 + O3 = OH{ + O2 + O2} : ARR2(1.0e-14_dp, 490.0_dp, TEMP) ; +{T011} HO2 + HO2 + H2O = H2O2 : usr9( temp, c_m, c_h2o ) ; +{T012} H2O2 + OH = HO2 + H2O : ARR2(2.9e-12_dp, 160.0_dp, TEMP) ; +{T013} OH + HO2 = H2O{ + O2} : ARR2(4.8e-11_dp, -250.0_dp, TEMP) ; +{T014} OH + OH = H2O + O : ARR2(4.2e-12_dp, 240.0_dp, TEMP) ; +{T015} OH + OH{ + M} = H2O2{ + M} : TROE( 6.90e-31_dp , 1.0_dp , 2.60e-11_dp , 0.0_dp , TEMP, C_M) ; +{T016} N2O + O1D_CB4 = NO + NO : 6.7e-11_dp ; +{T017} N2O + O1D_CB4 = M{ = O2 + N2} : 4.9e-11_dp ; +{T018} NO + HO2 = NO2 + OH : ARR2(3.5e-12_dp, -250.0_dp, TEMP) ; +{T019} O3 + NO = NO2{ + O2} : ARR2(3.0e-12_dp, 1500.0_dp, TEMP) ; +{T020} O + NO2 = NO{ + O2} : ARR2(5.6e-12_dp, -180.0_dp, TEMP) ; +{T021} O3 + NO2 = NO3{ + O2} : ARR2(1.2e-13_dp, 2450.0_dp, TEMP) ; +{T022} NO3 + HO2 = OH + NO2 : ARR2(2.3e-12_dp, -170.0_dp, TEMP) ; +{T023} NO3 + NO2{ + M} = N2O5{ + M} : TROE( 2.e-30_dp , 4.4_dp , 1.4e-12_dp , .7_dp , TEMP, C_M) ; +{T024} N2O5{ + M} = NO2 + NO3{ + M} : TROEE(3.333e26_dp,10900._dp, 2.2e-30_dp , 4.4_dp , 1.4e-12_dp , .7_dp , TEMP, C_M ) ; +{T025} OH + NO2{ + M} = HNO3{ + M} : TROE( 2.e-30_dp , 3._dp , 2.5e-11_dp , 0._dp , TEMP, C_M) ; +{T026} OH + HNO3 = NO3 + H2O : usr5( TEMP, C_M ) ; +{T027} NO3 + NO = NO2 + NO2 : ARR2(1.5e-11_dp, -170._dp, TEMP) ; +{T028} HO2 + NO2{ + M} = HO2NO2{ + M} : TROE( 1.8e-31_dp , 3.2_dp , 4.7e-12_dp , 1.4_dp , TEMP, C_M) ; +{T029} OH + HO2NO2 = NO2 + H2O{ + O2} : ARR2(1.3e-12_dp, -380._dp, TEMP) ; +{T030} HO2NO2{ + M} = HO2 + NO2{ + M} : TROEE( 4.76e26_dp,10900._dp, 1.8e-31_dp , 3.2_dp , 4.7e-12_dp , 1.4_dp , TEMP, C_M ) ; +{T031} N2O5 + M = 2.00 HNO3{ + M} : usr16( rh, temp ) ; +{T032} NO3 = HNO3 : usr17(rh, temp) ; +{T033} NO2 = 0.5 OH + 0.5 NO + 0.5 HNO3 : usr17a(rh, temp) ; +{T034} CH4 + OH = CH3O2 + H2O : ARR2(2.45e-12_dp, 1775.0_dp, TEMP) ; +{T035} CH4 + O1D_CB4 = 0.75 CH3O2 + 0.75 OH + 0.25 CH2O + 0.4 HO2 + + 0.05 H2 : 1.5e-10_dp ; +{T036} CH3O2 + NO = CH2O + NO2 + HO2 + nume : ARR2(2.8e-12_dp, -300._dp, TEMP) ; +{T037} CH3O2 + CH3O2 = CH2O + CH2O + HO2 + HO2 + den : ARR2(5.e-13_dp, 424._dp, TEMP) ; +{T038} CH3O2 + CH3O2 = CH2O + CH3OH + den : ARR2(1.9e-14_dp, -706._dp, TEMP) ; +{T039} CH3O2 + HO2 = CH3OOH{ + O2} + den : ARR2(4.1e-13_dp, -750._dp, TEMP) ; +{T040} CH3OOH + OH = 0.7 CH3O2 + 0.3 OH + 0.3 CH2O + H2O : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T041} CH2O + NO3 = CO + HO2 + HNO3 : ARR2( 6.e-13_dp, 2058._dp, TEMP) ; +{T042} CH2O + OH = CO + HO2 + H2O : 9.e-12_dp ; +{T043} CO + OH = HO2{ + CO2} : usr8(temp, c_m) ; +{T044} C2H4 + OH{ + M} = 0.75 EO2 + 0.5 CH2O + 0.25 HO2{ + M} : TROE( 1.e-28_dp , .8_dp , 8.8e-12_dp , 0._dp , TEMP, C_M) ; +{T045} C2H4 + O3 = CH2O + 0.12 HO2 + 0.5 CO + 0.12 OH + 0.5 HCOOH : ARR2(1.2e-14_dp, 2630._dp, TEMP) ; +{T046} SO2 + OH = SO4 : usr23( TEMP, C_M ) ; +{T047} GLYOXAL + OH = HO2 + CO{ + CO2} : 1.1e-11_dp ; +{T048} EO2 + NO = EO + NO2 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T049} EO + M{ = O2} = GLYALD + HO2 : 1e-14_dp ; +{T050} EO = 2 CH2O + HO2 : ARR2(1.6e11_dp, 4150._dp, TEMP) ; +{T051} C2H6 + OH = C2H5O2{ + H2O} : ARR2(8.7e-12_dp, 1070._dp, TEMP) ; +{T052} C2H5O2 + NO = CH3CHO + HO2 + NO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T053} C2H5O2 + HO2 = C2H5OOH + den{ + O2} : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T054} C2H5O2 + CH3O2 = .7 CH2O + .8 CH3CHO + .3 CH3OH + .2 C2H5OH + + HO2 + den : 2.e-13_dp ; +{T055} C2H5OOH + OH = .5 C2H5O2 + .5 CH3CHO + .5 OH : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T056} C3H6 + OH{ + M} = PO2{ + M} : JPL_TROE( 8.0e-27_dp , 3.5_dp , 3.e-11_dp , 0._dp , .5_dp, TEMP, C_M) ; +{T057} C3H6 + O3 = .54 CH2O + .19 HO2 + .33 OH + .08 CH4 + .56 CO + + .5 CH3CHO + .31 CH3O2 + .25 CH3COOH : ARR2(6.5e-15_dp, 1900._dp, TEMP) ; +{T058} C3H6 + NO3 = ONIT : ARR2(4.6e-13_dp, 1156._dp, TEMP) ; +{T059} PO2 + NO = CH3CHO + CH2O + HO2 + NO2 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T060} PO2 + HO2 = POOH + den{ + O2} : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T061} POOH + OH = .5 PO2 + .5 OH + .5 HYAC : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T062} CH3CHO + OH = CH3CO3{ + H2O} : ARR2(5.6e-12_dp, -270._dp, TEMP) ; +{T063} CH3CHO + NO3 = CH3CO3 + HNO3 : ARR2(1.4e-12_dp, 1900._dp, TEMP) ; +{T064} CH3CO3 + NO = CH3O2 + NO2 + nume{ + CO2} : ARR2(8.1e-12_dp, -270._dp, TEMP) ; +{T065} CH3CO3 + NO2{ + M} = PAN{ + M} : TROE( 8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 1._dp , TEMP, C_M) ; +{T066} CH3CO3 + HO2 = .75 CH3COOOH + .25 CH3COOH + .25 O3 + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T067} CH3CO3 + CH3O2 = .9 CH3O2 + .9 HO2 + .1 CH3COOH + CH2O + { + 0.5 CO2} + den : ARR2(2.e-12_dp, -500._dp, TEMP) ; +{T068} CH3COOOH + OH = .5 CH3CO3 + .5 CH2O{ + H2O + 0.5 CO2} : 1.e-12_dp ; +{T069} PAN{ + M} = CH3CO3 + NO2{ + M} : TROEE( 1.111e28_dp,14000._dp,8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 0._dp , TEMP, C_M) ; +{T070} CH3CO3 + CH3CO3 = 2 CH3O2 + den{ + 2 CO2} : ARR2(2.5e-12_dp, -500._dp, TEMP) ; +{T071} C3H8 + OH = C3H7O2{ + H2O} : ARR2(1.e-11_dp, 660._dp, TEMP) ; +{T072} C3H7O2 + NO = .82 CH3COCH3 + .27 CH3CHO + NO2 + HO2 + nume : ARR2(4.e-12_dp, -180._dp, TEMP) ; +{T073} C3H7O2 + HO2 = C3H7OOH + den{ + O2} : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T074} C3H7O2 + CH3O2 = CH2O + HO2 + .82 CH3COCH3 + den : ARR2(3.75e-13_dp, 40._dp, TEMP) ; +{T075} C3H7OOH + OH = C3H7O2{ + H2O} : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T076} CH3COCH3 + OH = RO2{ + H2O} : 3.82e-11_dp*exp( -2000._dp/temp ) + 1.33e-13_dp ; +{T077} RO2 + NO = CH3CO3 + CH2O + NO2 + nume : ARR2(2.9e-12_dp, -300._dp, TEMP) ; +{T078} RO2 + HO2 = ROOH + den{ + O2} : ARR2(8.6e-13_dp, -700._dp, TEMP) ; +{T079} RO2 + CH3O2 = .3 CH3CO3 + .8 CH2O + .3 HO2 + .2 HYAC + + .5 CH3COCHO + .5 CH3OH + den : ARR2(2.e-12_dp, -500._dp, TEMP) ; +{T080} ROOH + OH = RO2{ + H2O} : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T081} BIGENE + OH = ENEO2 : 5.4e-11_dp ; +{S001} BIGENE + OH = BIGENE + OH + CVASOA4 : 5.4e-11_dp * vbs_yield(nume, den, vbs_ole2, vbs_c1000) ; +{S002} BIGENE + OH = BIGENE + OH + CVASOA3 : 5.4e-11_dp * vbs_yield(nume, den, vbs_ole2, vbs_c100) ; +{S003} BIGENE + OH = BIGENE + OH + CVASOA2 : 5.4e-11_dp * vbs_yield(nume, den, vbs_ole2, vbs_c10) ; +{S004} BIGENE + OH = BIGENE + OH + CVASOA1 : 5.4e-11_dp * vbs_yield(nume, den, vbs_ole2, vbs_c1) ; +{T082} ENEO2 + NO = CH3CHO + .5 CH2O + .5 CH3COCH3 + HO2 + NO2 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T083} BIGALK + OH = ALKO2 : 3.5e-12_dp ; +{S005} BIGALK + OH = BIGALK + OH + CVASOA4 : 3.5e-12_dp * vbs_yield(nume, den, vbs_alk5, vbs_c1000) ; +{S006} BIGALK + OH = BIGALK + OH + CVASOA3 : 3.5e-12_dp * vbs_yield(nume, den, vbs_alk5, vbs_c100) ; +{S007} BIGALK + OH = BIGALK + OH + CVASOA2 : 3.5e-12_dp * vbs_yield(nume, den, vbs_alk5, vbs_c10) ; +{S008} BIGALK + OH = BIGALK + OH + CVASOA1 : 3.5e-12_dp * vbs_yield(nume, den, vbs_alk5, vbs_c1) ; +{T084} ALKO2 + NO = .4 CH3CHO + .1 CH2O + .25 CH3COCH3 + .9 HO2 + + .75 MEK + .9 NO2 + .1 ONIT + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T085} ALKO2 + HO2 = ALKOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T086} ALKOOH + OH = ALKO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T087} ONIT + OH = NO2 + CH3COCHO : 6.8e-13_dp ; +{T088} MEK + OH = MEKO2 : ARR2(2.3e-12_dp, 170._dp, TEMP) ; +{T089} MEKO2 + NO = CH3CO3 + CH3CHO + NO2 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T090} MEKO2 + HO2 = MEKOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T091} MEKOOH + OH = MEKO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T092} TOLO2 + HO2 = TOLOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T093} TOLOOH + OH = TOLO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T094} ISOP + OH = ISOPO2 : ARR2(2.54e-11_dp, -410._dp, TEMP) ; +{S009} ISOP + OH = ISOP + OH + CVBSOA4 : ARR2(2.54e-11_dp, -410._dp, TEMP) * vbs_yield(nume, den, vbs_isop, vbs_c1000) ; +{S010} ISOP + OH = ISOP + OH + CVBSOA3 : ARR2(2.54e-11_dp, -410._dp, TEMP) * vbs_yield(nume, den, vbs_isop, vbs_c100) ; +{S011} ISOP + OH = ISOP + OH + CVBSOA2 : ARR2(2.54e-11_dp, -410._dp, TEMP) * vbs_yield(nume, den, vbs_isop, vbs_c10) ; +{S012} ISOP + OH = ISOP + OH + CVBSOA1 : ARR2(2.54e-11_dp, -410._dp, TEMP) * vbs_yield(nume, den, vbs_isop, vbs_c1) ; +{T095} ISOP + O3 = .4 MACR + .2 MVK + .07 C3H6 + .27 OH + .06 HO2 + + .6 CH2O + .3 CO + .1 O3 + .2 MCO3 + .2 CH3COOH : ARR2(1.05e-14_dp, 2000._dp, TEMP) ; +{S013} ISOP + O3 = ISOP + O3 + CVBSOA4 : ARR2(1.05e-14_dp, 2000._dp, TEMP) * vbs_yield(nume, den, vbs_isop, vbs_c1000) ; +{S014} ISOP + O3 = ISOP + O3 + CVBSOA3 : ARR2(1.05e-14_dp, 2000._dp, TEMP) * vbs_yield(nume, den, vbs_isop, vbs_c100) ; +{S015} ISOP + O3 = ISOP + O3 + CVBSOA2 : ARR2(1.05e-14_dp, 2000._dp, TEMP) * vbs_yield(nume, den, vbs_isop, vbs_c10) ; +{S016} ISOP + O3 = ISOP + O3 + CVBSOA1 : ARR2(1.05e-14_dp, 2000._dp, TEMP) * vbs_yield(nume, den, vbs_isop, vbs_c1) ; +{T096} ISOPO2 + NO = .08 ONITR + .92 NO2 + .23 MACR + .32 MVK + + .33 HYDRALD + .02 GLYOXAL + .02 GLYALD + + .02 CH3COCHO + .02 HYAC + .55 CH2O + .92 HO2 + + nume : ARR2(4.4e-12_dp, -180._dp, TEMP) ; +{T097} ISOPO2 + NO3 = HO2 + NO2 + .6 CH2O + .25 MACR + .35 MVK + + .36 HYDRALD + 0.02 HYAC + .02 CH3COCHO + + .02 GLYOXAL + .02 GLYALD : 2.4e-12_dp ; +{T098} ISOPO2 + HO2 = ISOPOOH + den : ARR2(8.e-13_dp, -700._dp, TEMP) ; +{T099} ISOPOOH + OH = .5 XO2 + .5 ISOPO2 : ARR2(1.52e-11_dp, -200._dp, TEMP) ; +{T100} ISOPO2 + CH3O2 = .25 CH3OH + HO2 + 1.2 CH2O + .19 MACR + .26 MVK + + .3 HYDRALD + den : ARR2(5.e-13_dp, -400._dp, TEMP) ; +{T101} ISOPO2 + CH3CO3 = CH3O2 + HO2 + 0.6 CH2O + .25 MACR + .35 MVK + + .4 HYDRALD + den { + CO2} : 1.4e-11_dp ; +{T102} MVK + OH = MACRO2 : ARR2(4.13e-12_dp, -452._dp, TEMP) ; +{T103} MVK + O3 = .8 CH2O + .95 CH3COCHO + .08 OH + .2 O3 + + .06 HO2 + .05 CO + .04 CH3CHO : ARR2(7.52e-16_dp, 1521._dp, TEMP) ; +{T104} MACR + OH = .5 MACRO2 + .5 MCO3{ + 0.5 H2O} : ARR2(1.86e-11_dp, -175._dp, TEMP) ; +{T105} MACR + O3 = .8 CH3COCHO + .275 HO2 + .2 CO + .7 CH2O + + .215 OH + .2 O3 : ARR2(4.4e-15_dp, 2500._dp, TEMP) ; +{T106} MACRO2 + NO = NO2 + .47 HO2 + .25 CH2O + .25 CH3COCHO + + .53 CH3CO3 + .53 GLYALD + .22 HYAC + .22 CO + + nume : ARR2(2.7e-12_dp, -360._dp, TEMP) ; +{T107} MACRO2 + NO = .8 ONITR + nume : ARR2(1.3e-13_dp, -360._dp, TEMP) ; +{T108} MACRO2 + NO3 = NO2 + .47 HO2 + .25 CH2O + .25 CH3COCHO + + .22 CO + .53 GLYALD + .22 HYAC + .53 CH3CO3 : 2.4e-12_dp ; +{T109} MACRO2 + HO2 = MACROOH + den : ARR2(8.e-13_dp, -700._dp, TEMP) ; +{T110} MACRO2 + CH3O2 = .73 HO2 + .88 CH2O + .11 CO + .24 CH3COCHO + + .26 GLYALD + .26 CH3CO3 + .25 CH3OH + + .23 HYAC + den : ARR2(5.e-13_dp, -400._dp, TEMP) ; +{T111} MACRO2 + CH3CO3 = .25 CH3COCHO + CH3O2 + .22 CO + .47 HO2 + + .53 GLYALD + .22 HYAC + .25 CH2O + .53 CH3CO3 + { + CO2} + den : 1.4e-11_dp ; +{T112} MACROOH + OH = .5 MCO3 + .2 MACRO2 + .1 OH + .2 HO2 : ARR2(2.3e-11_dp, -200._dp, TEMP) ; +{T113} MCO3 + NO = NO2 + CH2O + CH3CO3 + nume{ + CO2} : ARR2(5.3e-12_dp, -360._dp, TEMP) ; +{T114} MCO3 + NO3 = NO2 + CH2O + CH3CO3{ + CO2} : 5.e-12_dp ; +{T115} MCO3 + HO2 = .25 O3 + .25 CH3COOH + .75 CH3COOOH + den + { + 0.75 O2} : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T116} MCO3 + CH3O2 = 2 CH2O + HO2 + CH3CO3 + den { + CO2} : ARR2(2.e-12_dp, -500._dp, TEMP) ; +{T117} MCO3 + CH3CO3 = CH3O2 + CH2O + CH3CO3 + den { + 2 CO2} : ARR2(4.6e-12_dp, -530._dp, TEMP) ; +{T118} MCO3 + MCO3 = 2 CH2O + 2 CH3CO3 + den { + 2 CO2} : ARR2(2.3e-12_dp, -530._dp, TEMP) ; +{T119} MCO3 + NO2 + M = MPAN{ + M} : 1.1e-11_dp*300._dp/(temp*c_m) ; +{T120} MPAN + M = MCO3 + NO2{ + M} : 1.2221e17_dp*300._dp*exp( -14000._dp/temp )/(temp*c_m) ; +{T121} OH + BENZENE = .53 PHENOL + .12 BEPOMUC + .65 HO2 + .35 BENZO2 : ARR2(2.3e-12_dp, 193._dp, TEMP) ; +{S017} OH + BENZENE = OH + BENZENE + CVASOA4 : ARR2(2.3e-12_dp, 193._dp, TEMP) * vbs_yield(nume, den, vbs_aro2, vbs_c1000) ; +{S018} OH + BENZENE = OH + BENZENE + CVASOA3 : ARR2(2.3e-12_dp, 193._dp, TEMP) * vbs_yield(nume, den, vbs_aro2, vbs_c100) ; +{S019} OH + BENZENE = OH + BENZENE + CVASOA2 : ARR2(2.3e-12_dp, 193._dp, TEMP) * vbs_yield(nume, den, vbs_aro2, vbs_c10) ; +{S020} OH + BENZENE = OH + BENZENE + CVASOA1 : ARR2(2.3e-12_dp, 193._dp, TEMP) * vbs_yield(nume, den, vbs_aro2, vbs_c1) ; +{T122} OH + PHENOL = 0.14 PHENO2 + 0.80 HO2 + 0.06 PHENO : ARR2(4.7e-13_dp, -1220._dp, TEMP) ; +{T123} PHENO2 + NO = HO2 + .70 GLYOXAL + NO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T124} PHENO2 + HO2 = PHENOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T125} OH + PHENOOH = PHENO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T126} PHENO + NO2 = M : 2.1e-12_dp ; +{T127} PHENO + O3 = C6H5O2 : 2.8e-13_dp ; +{T128} C6H5O2 + NO = PHENO + NO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T129} C6H5O2 + HO2 = C6H5OOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T130} OH + C6H5OOH = C6H5O2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T131} BENZO2 + NO = NO2 + GLYOXAL + 0.5 BIGALD1 + HO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T132} BENZO2 + HO2 = BENZOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T133} OH + BENZOOH = BENZO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T134} MALO2 + NO2 = M : TROE( 8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 1._dp , TEMP, C_M) ; +{T135} MALO2 + NO = 0.4 GLYOXAL + 0.4 HO2 + 0.4 CO + nume : ARR2(7.5e-12_dp, -290._dp, TEMP) ; +{T136} MALO2 + HO2 = 0.16 GLYOXAL + 0.16 HO2 + 0.16 CO + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T137} OH + TOLUENE = 0.18 CRESOL + 0.10 TEPOMUC + 0.07 BZOO + + 0.65 TOLO2 + 0.28 HO2 : ARR2(1.7e-12_dp, -352._dp, TEMP) ; +{S021} OH + TOLUENE = OH + TOLUENE + CVASOA4 : ARR2(1.7e-12_dp, -352._dp, TEMP) * vbs_yield(nume, den, vbs_aro1, vbs_c1000) ; +{S022} OH + TOLUENE = OH + TOLUENE + CVASOA3 : ARR2(1.7e-12_dp, -352._dp, TEMP) * vbs_yield(nume, den, vbs_aro1, vbs_c100) ; +{S023} OH + TOLUENE = OH + TOLUENE + CVASOA2 : ARR2(1.7e-12_dp, -352._dp, TEMP) * vbs_yield(nume, den, vbs_aro1, vbs_c10) ; +{S024} OH + TOLUENE = OH + TOLUENE + CVASOA1 : ARR2(1.7e-12_dp, -352._dp, TEMP) * vbs_yield(nume, den, vbs_aro1, vbs_c1) ; +{T138} OH + CRESOL = 0.20 PHENO2 + 0.73 HO2 + 0.07 PHENO : 4.7e-11_dp ; +{T139} BZOO + HO2 = BZOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T140} OH + BZOOH = BZOO : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T141} BZOO + NO = BZALD + NO2 + HO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T142} OH + BZALD = ACBZO2 : ARR2(5.9e-12_dp, -225._dp, TEMP) ; +{T143} ACBZO2 + NO2 = PBZNIT : TROE( 8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 1._dp , TEMP, C_M) ; +{T144} PBZNIT = ACBZO2 + NO2 : TROEE( 1.111e28_dp,14000._dp,8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 0._dp , TEMP, C_M) ; +{T145} ACBZO2 + NO = C6H5O2 + NO2 + nume : ARR2(7.5e-12_dp, -290._dp, TEMP) ; +{T146} ACBZO2 + HO2 = 0.4 C6H5O2 + 0.4 OH + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T147} TOLO2 + NO = NO2 + 0.6 GLYOXAL + 0.4 CH3COCHO + HO2 + + 0.2 BIGALD1 + 0.2 BIGALD2 + 0.2 BIGALD3 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T148} DICARBO2 + HO2 = 0.4 OH + 0.07 HO2 + 0.07 CH3COCHO + 0.07 CO + + 0.33 CH3O2 + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T149} DICARBO2 + NO = NO2 + 0.17 HO2 + 0.17 CH3COCHO + 0.17 CO + + 0.83 CH3O2 + nume : ARR2(7.5e-12_dp, -290._dp, TEMP) ; +{T150} MDIALO2 + HO2 = 0.4 OH + 0.33 HO2 + 0.07 CH3COCHO + 0.14 CO + + 0.07 CH3O2 + 0.07 GLYOXAL + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T151} MDIALO2 + NO = NO2 + 0.83 HO2 + 0.17 CH3COCHO + 0.35 CO + + 0.17 CH3O2 + 0.17 GLYOXAL + nume : ARR2(7.5e-12_dp, -290._dp, TEMP) ; +{T152} DICARBO2 + NO2 = M : TROE( 8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 1._dp , TEMP, C_M) ; +{T153} MDIALO2 + NO2 = M : TROE( 8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 1._dp , TEMP, C_M) ; +{T154} OH + XYLENES = 0.15 XYLOL + 0.23 TEPOMUC + 0.06 BZOO + + 0.56 XYLENO2 + 0.38 HO2 : 1.7e-11_dp ; +{S025} OH + XYLENES = OH + XYLENES + CVASOA4 : 1.7e-11_dp * vbs_yield(nume, den, vbs_aro2, vbs_c1000) ; +{S026} OH + XYLENES = OH + XYLENES + CVASOA3 : 1.7e-11_dp * vbs_yield(nume, den, vbs_aro2, vbs_c100) ; +{S027} OH + XYLENES = OH + XYLENES + CVASOA2 : 1.7e-11_dp * vbs_yield(nume, den, vbs_aro2, vbs_c10) ; +{S028} OH + XYLENES = OH + XYLENES + CVASOA1 : 1.7e-11_dp * vbs_yield(nume, den, vbs_aro2, vbs_c1) ; +{T155} OH + XYLOL = 0.30 XYLOLO2 + 0.63 HO2 + 0.07 PHENO : 8.4e-11_dp ; +{T156} XYLOLO2 + NO = HO2 + NO2 + .17 GLYOXAL + .51 CH3COCHO + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T157} XYLOLO2 + HO2 = XYLOLOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T158} OH + XYLOLOOH = XYLOLO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T159} XYLENO2 + HO2 = XYLENOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T160} OH + XYLENOOH = XYLENO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; +{T161} XYLENO2 + NO = NO2 + HO2 + 0.34 GLYOXAL + 0.54 CH3COCHO + + 0.06 BIGALD1 + 0.2 BIGALD2 + 0.15 BIGALD3 + + .21 BIGALD4 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T162} APIN + OH = TERPO2 : ARR2(1.2e-11_dp, -440._dp, TEMP) ; +{S029} APIN + OH = APIN + OH + CVBSOA4 : ARR2(1.2e-11_dp, -440._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1000) ; +{S030} APIN + OH = APIN + OH + CVBSOA3 : ARR2(1.2e-11_dp, -440._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c100) ; +{S031} APIN + OH = APIN + OH + CVBSOA2 : ARR2(1.2e-11_dp, -440._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c10) ; +{S032} APIN + OH = APIN + OH + CVBSOA1 : ARR2(1.2e-11_dp, -440._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1) ; +{T163} BPIN + OH = TERPO2 : ARR2(1.6e-11_dp, -470._dp, TEMP) ; +{S033} BPIN + OH = BPIN + OH + CVBSOA4 : ARR2(1.6e-11_dp, -470._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1000) ; +{S034} BPIN + OH = BPIN + OH + CVBSOA3 : ARR2(1.6e-11_dp, -470._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c100) ; +{S035} BPIN + OH = BPIN + OH + CVBSOA2 : ARR2(1.6e-11_dp, -470._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c10) ; +{S036} BPIN + OH = BPIN + OH + CVBSOA1 : ARR2(1.6e-11_dp, -470._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1) ; +{T164} LIMON + OH = TERPO2 : ARR2(4.2e-11_dp, -400._dp, TEMP) ; +{S037} LIMON + OH = LIMON + OH + CVBSOA4 : ARR2(4.2e-11_dp, -400._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1000) ; +{S038} LIMON + OH = LIMON + OH + CVBSOA3 : ARR2(4.2e-11_dp, -400._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c100) ; +{S039} LIMON + OH = LIMON + OH + CVBSOA2 : ARR2(4.2e-11_dp, -400._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c10) ; +{S040} LIMON + OH = LIMON + OH + CVBSOA1 : ARR2(4.2e-11_dp, -400._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1) ; +{T165} MYRC + OH = TERPO2 : 2.1e-10_dp ; +{T166} BCARY + OH = TERPO2 : 2.0e-10_dp ; +{T167} APIN + O3 = .33 TERPROD1 + .3 TERPROD2 + .63 OH + .57 HO2 + + .23 CO + .52 CH3COCH3 + .34 CH2O + .1 BIGALD + + .05 HCOOH + .05 BIGALK + .06 CH3CO3 + .06 RO2 + { + .27 CO2} : ARR2(6.3e-16_dp, 580._dp, TEMP) ; +{S041} APIN + O3 = APIN + O3 + CVBSOA4 : ARR2(6.3e-16_dp, 580._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1000) ; +{S042} APIN + O3 = APIN + O3 + CVBSOA3 : ARR2(6.3e-16_dp, 580._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c100) ; +{S043} APIN + O3 = APIN + O3 + CVBSOA2 : ARR2(6.3e-16_dp, 580._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c10) ; +{S044} APIN + O3 = APIN + O3 + CVBSOA1 : ARR2(6.3e-16_dp, 580._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1) ; +{T168} BPIN + O3 = .33 TERPROD1 + .3 TERPROD2 + .63 OH + .57 HO2 + + .23 CO + .52 CH3COCH3 + .34 CH2O + .1 BIGALD + + .05 HCOOH + .05 BIGALK + .06 CH3CO3 + .06 RO2 + { + .27 CO2} : ARR2(1.7e-15_dp, 1300._dp, TEMP) ; +{S045} BPIN + O3 = BPIN + O3 + CVBSOA4 : ARR2(1.7e-15_dp, 1300._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1000) ; +{S046} BPIN + O3 = BPIN + O3 + CVBSOA3 : ARR2(1.7e-15_dp, 1300._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c100) ; +{S047} BPIN + O3 = BPIN + O3 + CVBSOA2 : ARR2(1.7e-15_dp, 1300._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c10) ; +{S048} BPIN + O3 = BPIN + O3 + CVBSOA1 : ARR2(1.7e-15_dp, 1300._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1) ; +{T169} LIMON + O3 = .33 TERPROD1 + .3 TERPROD2 + .63 OH + .57 HO2 + + .23 CO + .52 CH3COCH3 + .34 CH2O + .1 BIGALD + + .05 HCOOH + .05 BIGALK + .06 CH3CO3 + .06 RO2 + { + .27 CO2} : ARR2(3.0e-15_dp, 780._dp, TEMP) ; +{S049} LIMON + O3 = LIMON + O3 + CVBSOA4 : ARR2(3.0e-15_dp, 780._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1000) ; +{S050} LIMON + O3 = LIMON + O3 + CVBSOA3 : ARR2(3.0e-15_dp, 780._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c100) ; +{S051} LIMON + O3 = LIMON + O3 + CVBSOA2 : ARR2(3.0e-15_dp, 780._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c10) ; +{S052} LIMON + O3 = LIMON + O3 + CVBSOA1 : ARR2(3.0e-15_dp, 780._dp, TEMP) * vbs_yield(nume, den, vbs_terp, vbs_c1) ; +{T170} MYRC + O3 = .33 TERPROD1 + .3 TERPROD2 + .63 OH + .57 HO2 + + .23 CO + .52 CH3COCH3 + .34 CH2O + .1 BIGALD + + .05 HCOOH + .05 BIGALK + .06 CH3CO3 + .06 RO2 + { + .27 CO2} : 4.7e-16_dp ; +{T171} BCARY + O3 = .33 TERPROD1 + .3 TERPROD2 + .63 OH + .57 HO2 + + .23 CO + .52 CH3COCH3 + .34 CH2O + .1 BIGALD + + .05 HCOOH + .05 BIGALK + .06 CH3CO3 + .06 RO2 + { + .27 CO2} : 1.2e-14_dp ; +{T172} LIMON + NO3 = NTERPO2 : 1.1e-11_dp ; +{T173} MYRC + NO3 = NTERPO2 : 1.2e-11_dp ; +{T174} BCARY + NO3 = NTERPO2 : 1.9e-11_dp ; +{T175} TERPO2 + NO = .1 ONITR + .9 NO2 + .36 CH2O + .045 CH3COCH3 + + .9 TERPROD1 + .9 HO2 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T176} TERPO2 + HO2 = TERPOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T177} TERPO2 + CH3O2 = TERPROD1 + .95 CH2O + .25 CH3OH + HO2 + + .025 CH3COCH3 + den : ARR2(2.0e-12_dp, -500._dp, TEMP) ; +{T178} TERPOOH + OH = TERPO2 : 3.3e-11_dp ; +{T179} TERP2OOH + OH = TERP2O2 : 2.3e-11_dp ; +{T180} TERPROD1 + OH = TERP2O2 : 5.7e-11_dp ; +{T181} TERPROD1 + NO3 = .5 TERP2O2 + .5 NTERPO2 : 1.0e-12_dp ; +{T182} TERP2O2 + NO = .1 ONITR + .9 NO2 + .34 CH2O + .27 CH3COCH3 + + .225 CO + .9 TERPROD2 + .9 HO2 + .225 GLYALD + { + .9 CO2} + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T183} TERP2O2 + HO2 = TERP2OOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T184} TERP2O2 + CH3O2 = TERPROD2 + .93 CH2O + .25 CH3OH + HO2 + { + .5 CO2} + .125 CO + .125 GLYALD + + .15 CH3COCH3 + den : ARR2(2.0e-12_dp, -500._dp, TEMP) ; +{T185} TERPROD2 + OH = .15 RO2 + .68 CH2O{ + 1.8 CO2} + .5 CH3COCH3 + + .65 CH3CO3 + .2 HO2 + .7 CO : 3.4e-11_dp ; +{T186} NTERPO2 + NO = .1 ONITR + 1.9 NO2 + .9 TERPROD1 + nume : ARR2(4.2e-12_dp, -180._dp, TEMP) ; +{T187} NTERPO2 + HO2 = ONITR + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T188} NTERPO2 + CH3O2 = .5 ONITR + .75 CH2O + .25 CH3OH + .5 HO2 + + .5 TERPROD1 + .5 NO2 + den : ARR2(2.0e-12_dp, -500._dp, TEMP) ; +{T189} NTERPO2 + NO3 = 2 NO2 + TERPROD1 : 2.4e-12_dp ; +{T190} CH3COOH + OH = CH3O2{ + H2O + CO2} : 7.e-13_dp ; +{T191} ISOP + NO3 = ISOPNO3 : ARR2(3.03e-12_dp, 446._dp, TEMP) ; +{T192} ISOPNO3 + NO = 1.206 NO2 + .794 HO2 + .072 CH2O + .167 MACR + + .039 MVK + .794 ONITR + nume : ARR2(2.7e-12_dp, -360._dp, TEMP) ; +{T193} ISOPNO3 + NO3 = 1.206 NO2 + .072 CH2O + .167 MACR + .039 MVK + + .794 ONITR + .794 HO2 : 2.4e-12_dp ; +{T194} ISOPNO3 + HO2 = .206 NO2 + .206 OH + .206 CH2O + .167 MACR + + .039 MVK + .794 ONITR + den : ARR2(8.e-13_dp, -700._dp, TEMP) ; +{T195} CH3COCHO + OH = CH3CO3 + CO{ + H2O} : ARR2(8.4e-13_dp, -830._dp, TEMP) ; +{T196} CH3COCHO + NO3 = HNO3 + CO + CH3CO3 : ARR2(1.4e-12_dp, 1860._dp, TEMP) ; +{T197} ONITR + OH = HYDRALD + HO2 + .4 NO2 : 4.5e-11_dp ; +{T198} ONITR + NO3 = HYDRALD + HO2 + NO2 : ARR2(1.4e-12_dp, 1860._dp, TEMP) ; +{T199} HYDRALD + OH = XO2 : ARR2(1.86e-11_dp, -175._dp, TEMP) ; +{T200} XO2 + NO = NO2 + HO2 + .25 CO + .25 CH2O + .25 GLYOXAL + + .25 CH3COCHO + .25 HYAC + .25 GLYALD + nume : ARR2(2.7e-12_dp, -360._dp, TEMP) ; +{T201} XO2 + NO3 = NO2 + HO2 + .25 CO + .25 CH2O + .25 GLYOXAL + + .25 CH3COCHO + .25 HYAC + .25 GLYALD : 2.4e-12_dp ; +{T202} XO2 + HO2 = XOOH + den : ARR2(8.e-13_dp, -700._dp, TEMP) ; +{T203} XO2 + CH3O2 = .3 CH3OH + .8 HO2 + .8 CH2O + .2 CO + + .1 GLYOXAL + .1 CH3COCHO + .1 HYAC + + .1 GLYALD + den : ARR2(5.e-13_dp, -400._dp, TEMP) ; +{T204} XO2 + CH3CO3 = .25 CO + .25 CH2O + .25 GLYOXAL + CH3O2 + HO2 + + .25 CH3COCHO + .25 HYAC + .25 GLYALD { + CO2} + + den : ARR2(1.3e-12_dp, -640._dp, TEMP) ; +{T205} XOOH + OH = XO2{ + H2O} : ARR2(1.9e-12_dp, -190._dp, TEMP) ; +{T206} XOOH + OH = OH{ + H2O} : THERMAL_T2(7.69e-17_dp, -253._dp, TEMP) ; +{T207} CH3OH + OH = HO2 + CH2O : ARR2(7.3e-12_dp, 620._dp, TEMP) ; +{T208} C2H5OH + OH = HO2 + CH3CHO : ARR2(6.9e-12_dp, 230._dp, TEMP) ; +{T209} MPAN + OH = .5 HYAC + .5 NO3 + .5 CH2O + .5 HO2 { + 0.5 CO2} : JPL_TROE( 8.e-27_dp , 3.5_dp , 3.e-11_dp , 0.0_dp , .5_dp, TEMP, C_M) ; +{T210} PAN + OH = CH2O + NO3{ + CO2} : 4.e-14_dp ; +{T211} HYAC + OH = CH3COCHO + HO2 : 3.e-12_dp ; +{T212} GLYALD + OH = HO2 + .2 GLYOXAL + .8 CH2O { + 0.8 CO2} : 1.e-11_dp ; +{T213} DMS + OH = SO2 : ARR2(9.6e-12_dp, 234._dp, TEMP) ; +{T214} DMS + OH = .5 SO2 + .5 HO2 : usr24( temp, c_m ) ; +{T215} DMS + NO3 = SO2 + HNO3 : ARR2(1.9e-13_dp, -520._dp, TEMP) ; +{T216} NH3 + OH = M : ARR2(1.7e-12_dp, 710._dp, TEMP) ; +{T217} HO2 = .5 H2O2 : usr26( rh, temp ) ; +{T218} C2H5O2 + C2H5O2 = 1.6 CH3CHO + 1.2 HO2 + .4 C2H5OH + den : 6.8e-14_dp ; +{T219} MBO + OH = MBOO2 : ARR2(8.1e-12_dp, -610._dp, TEMP) ; +{T220} MBOO2 + NO = HO2 + .67 GLYALD + .67 CH3COCH3 + .33 HMPROP + + .33 CH2O + NO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T221} MBOO2 + CH3O2 = .917 CH2O + HO2 + .25 CH3OH + .333 GLYALD + + .333 CH3COCH3 + .167 HMPROP + den : ARR2(3.75e-13_dp, 40._dp, TEMP) ; +{T222} HMPROP + OH = HMPROPO2 : 1.4e-11_dp ; +{T223} HMPROPO2 + NO = NO2 + HO2 + CH3COCH3{ + CO2} + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T224} HMPROPO2 + HO2 = .4 OH + .4 HO2 + .4 CH3COCH3{ + .4 * CO2} + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T225} MBOO2 + HO2 = MBOOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{T226} MBOOOH + OH = .5 MBOO2 + .5 OH : ARR2(3.8e-12_dp ,-200._dp, TEMP) ; +{T227} MBO + O3 = .1 CO + .5 CH2O + .1 CH3COCH3 + .9 HMPROP + + .25 HCOOH + .25 CO + .06 HO2 + .06 OH : 1e-17_dp ; +{T228} MBO + NO3 = MBONO3O2 : ARR2(4.6e-14_dp, 400._dp, TEMP) ; +{T229} MBONO3O2 + HO2 = .0 * H2O + den : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; +{T230} MBONO3O2 + NO = .25 HMPROP + .25 CH2O + 1.25 NO2 + .75 ONIT + + .75 CH3COCH3 + .75 HO2 + nume : ARR2(2.6e-12_dp, -365._dp, TEMP) ; +{T231} MBONO3O2 + NO3 = .25 HMPROP + .25 CH2O + 1.25 NO2 + .75 ONIT + + .75 CH3COCH3 + .75 HO2 : 2.4e-12_dp ; +{T232} C2H2 + OH{ + M} = 0.65 GLYOXAL + 0.65 OH + 0.35 HCOOH + 0.35 HO2 + + 0.35 CO{ + M} : TROE( 5.5e-30_dp , 0._dp, 8.3e-13_dp, -2._dp, TEMP, C_M) ; +{T233} HCOOH + OH = HO2 + H2O{ + CO2} : 4.5e-13 ; +{T234} CH2O + HO2 = HOCH2OO : ARR2(9.7e-15_dp, -625._dp, TEMP) ; +{T235} HOCH2OO = CH2O + HO2 : ARR2(2.4e12_dp, 7000._dp, TEMP) ; +{T236} HOCH2OO + NO = HCOOH + NO2 + HO2 + nume : ARR2(2.6e-12_dp, -265._dp, TEMP) ; +{T237} HOCH2OO + HO2 = HCOOH + den : ARR2(7.5e-13_dp, -700._dp, TEMP) ; +{S053} CVASOA4 + OH = 1.075 CVASOA3 + OH : ARR2(1.0D-11, 0.0_dp, TEMP) ; +{S054} CVASOA3 + OH = 1.075 CVASOA2 + OH : ARR2(1.0D-11, 0.0_dp, TEMP) ; +{S055} CVASOA2 + OH = 1.075 CVASOA1 + OH : ARR2(1.0D-11, 0.0_dp, TEMP) ; +{S056} CVASOA1 + OH = 1.075 CVASOAX + OH : ARR2(1.0D-11, 0.0_dp, TEMP) ; +{S057} CVBSOA4 + OH = 1.075 CVBSOA3 + OH : ARR2(1.0D-11, 0.0_dp, TEMP) ; +{S058} CVBSOA3 + OH = 1.075 CVBSOA2 + OH : ARR2(1.0D-11, 0.0_dp, TEMP) ; +{S059} CVBSOA2 + OH = 1.075 CVBSOA1 + OH : ARR2(1.0D-11, 0.0_dp, TEMP) ; +{S060} CVBSOA1 + OH = 1.075 CVBSOAX + OH : ARR2(1.0D-11, 0.0_dp, TEMP) ; diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.kpp b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.kpp new file mode 100644 index 00000000..d4fdbfc1 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.kpp @@ -0,0 +1,11 @@ +#MODEL mozart_mosaic_4bin_aq +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.spc b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.spc new file mode 100644 index 00000000..6f3591d2 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.spc @@ -0,0 +1,158 @@ +#DEFVAR + O3 =IGNORE ; + O =IGNORE ; + O1D_CB4 =IGNORE ; + N2O =IGNORE ; + NO =IGNORE ; + NO2 =IGNORE ; + NO3 =IGNORE ; + NH3 =IGNORE ; + HNO3 =IGNORE ; + HO2NO2 =IGNORE ; + N2O5 =IGNORE ; + H2 =IGNORE ; + OH =IGNORE ; + HO2 =IGNORE ; + H2O2 =IGNORE ; + CH4 =IGNORE ; + CO =IGNORE ; +// 20120808 acd_ck_formicacid start + HCOOH = IGNORE ; + HOCH2OO = IGNORE ; +// 20120808 acd_ck_formicacid end + CH3O2 =IGNORE ; + CH3OOH =IGNORE ; + CH2O =IGNORE ; + CH3OH =IGNORE ; +// 20120808 acd_ck_ethyne start +C2H2 = IGNORE ; +// 20120808 acd_ck_ethyne start + C2H4 =IGNORE ; + EO =IGNORE ; + EO2 =IGNORE ; + CH3CHO =IGNORE ; + CH3COOH =IGNORE ; + CH3COCH3 =IGNORE ; + CH3COCHO =IGNORE ; + CH3CO3 =IGNORE ; + CH3COOOH =IGNORE ; + GLYOXAL =IGNORE ; + PO2 =IGNORE ; + POOH =IGNORE ; + PAN =IGNORE ; + MPAN =IGNORE ; + MCO3 =IGNORE ; + MACR =IGNORE ; + MACRO2 =IGNORE ; + MACROOH =IGNORE ; + MVK =IGNORE ; + C2H6 =IGNORE ; + C3H6 =IGNORE ; + C3H8 =IGNORE ; + C2H5OH =IGNORE ; + C2H5OOH =IGNORE ; + C3H7O2 =IGNORE ; + C3H7OOH =IGNORE ; +// 20130816 acd_alma_bio start + APIN =IGNORE ; + BPIN =IGNORE ; + LIMON =IGNORE ; + MYRC =IGNORE ; + BCARY =IGNORE ; + TERPROD1 =IGNORE ; + TERPROD2 =IGNORE ; + TERP2O2 =IGNORE ; + TERP2OOH =IGNORE ; + NTERPO2 =IGNORE ; +// 20130816 acd_alma_bio end + RO2 =IGNORE ; + ROOH =IGNORE ; + ONIT =IGNORE ; +// 20130816 acd_alma_bio start + MBO =IGNORE ; + MBOO2 =IGNORE ; + HMPROP =IGNORE ; + HMPROPO2 =IGNORE ; + MBOOOH =IGNORE ; + MBONO3O2 =IGNORE ; +// 20130816 acd_alma_bio end + ONITR =IGNORE ; + ISOP =IGNORE ; + ISOPO2 =IGNORE ; + ISOPOOH =IGNORE ; + ISOPNO3 =IGNORE ; + HYAC =IGNORE ; + GLYALD =IGNORE ; + HYDRALD =IGNORE ; + ENEO2 =IGNORE ; + MEK =IGNORE ; + MEKO2 =IGNORE ; + C2H5O2 =IGNORE ; + BIGENE =IGNORE ; + BIGALD =IGNORE ; + BIGALK =IGNORE ; + ALKO2 =IGNORE ; + ALKOOH =IGNORE ; + MEKOOH =IGNORE ; + TOLUENE =IGNORE ; + TOLO2 =IGNORE ; + TOLOOH =IGNORE ; + TERPO2 =IGNORE ; + TERPOOH =IGNORE ; + CRESOL =IGNORE ; + DMS =IGNORE ; + SO2 =IGNORE ; + SO4 =IGNORE ; + XO2 =IGNORE ; + XOOH =IGNORE ; +// 20130816 acd_ck_aromatics start + BENZENE = IGNORE ; + PHENOL = IGNORE ; + BEPOMUC = IGNORE ; + BENZO2 = IGNORE ; + PHENO2 = IGNORE ; + PHENO = IGNORE ; + PHENOOH = IGNORE ; + C6H5O2 = IGNORE ; + C6H5OOH = IGNORE ; + BENZOOH = IGNORE ; + BIGALD1 = IGNORE ; + BIGALD2 = IGNORE ; + BIGALD3 = IGNORE ; + BIGALD4 = IGNORE ; + MALO2 = IGNORE ; + PBZNIT = IGNORE ; + TEPOMUC = IGNORE ; + BZOO = IGNORE ; + BZOOH = IGNORE ; + BZALD = IGNORE ; + ACBZO2 = IGNORE ; + DICARBO2 = IGNORE ; + MDIALO2 = IGNORE ; + XYLENES = IGNORE ; + XYLOL = IGNORE ; + XYLOLO2 = IGNORE ; + XYLOLOOH = IGNORE ; + XYLENO2 = IGNORE ; + XYLENOOH = IGNORE ; +// 20130816 acd_ck_aromatics end +// 20130816 acd_ck_hono start + HONO = IGNORE; +// 20130816 acd_ck_hono end + NUME = IGNORE; + DEN=IGNORE; +// 20130816 acd_ck_vbsmoz start +CVASOAX = IGNORE; +CVASOA1 = IGNORE; +CVASOA2 = IGNORE; +CVASOA3 = IGNORE; +CVASOA4 = IGNORE; +CVBSOAX = IGNORE; +CVBSOA1 = IGNORE; +CVBSOA2 = IGNORE; +CVBSOA3 = IGNORE; +CVBSOA4 = IGNORE; +// 20130816 acd_ck_vbsmoz end +#DEFFIX + H2O = IGNORE ; {water} + M = IGNORE ; diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq_wrfkpp.equiv new file mode 100644 index 00000000..d90feca4 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq_wrfkpp.equiv @@ -0,0 +1,40 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +HO OH +HNO4 HO2NO2 +HCHO CH2O +ACET CH3COCH3 +ACETP ROOH +ACETOL HYAC +ACETO2 RO2 +MGLY CH3COCHO +ACO3 CH3CO3 +PAA CH3COOOH +GLY GLYOXAL +C3H6OOH POOH +ETOOH C2H5OOH +ETO2 C2H5O2 +ALD CH3CHO +MVKO2 MACRO2 +MVKOOH MACROOH +PROOH C3H7OOH +PRO2 C3H7O2 +ISOPR ISOP +ISO2 ISOPO2 +ISOOH ISOPOOH +ISOPN ISOPNO3 +OPEN BIGALD +CRES CRESOL +TOL TOLUENE +TO2 TOLO2 +SULF SO4 +! 20130116 acd_ck_aromatics start +PHEN PHENOL +XYL XYLENES +BALD BZALD +! 20130116 acd_ck_aromatics end diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.eqn b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.eqn deleted file mode 100755 index e331f910..00000000 --- a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_vbs0/mozart_mosaic_4bin_vbs0.eqn +++ /dev/null @@ -1,203 +0,0 @@ -#EQUATIONS {MOZART_MOSAIC with implified SOA, check troee, usr5, usr17, rc_n2o5 } -// photorates - {001:J01} M{=O2}+hv=O+O : .20946_dp*j(Pj_o2) ; - {002:J02} O3+hv=O1D_CB4{+O2} : j(Pj_o31d) ; - {003:J03} O3+hv=O{+O2} : j(Pj_o33p) ; - {004:J04} N2O+hv=O1D_CB4{+N2} : j(Pj_n2o) ; - {005:J05} NO2+hv=O+NO : j(Pj_no2) ; - {006:J06} N2O5+hv=NO2+NO3 : j(Pj_n2o5) ; - {007:J07} HNO3+hv=OH+NO2 : j(Pj_hno3) ; - {009:J09} NO3+hv=.89 NO2+ .11 NO + .89 O3: j(Pj_no3o) ; - {010:J10} HO2NO2+hv=0.66 HO2+0.66 NO2+0.33 OH+0.33 NO3 : j(Pj_hno4) ; - {011:J11} CH3OOH+hv=CH2O+HO2+OH : j(Pj_ch3o2h) ; - {012:J12} CH2O+hv=HO2+HO2+CO : j(Pj_ch2or) ; - {013:J13} CH2O+hv=CO+H2 : j(Pj_ch2om) ; - {014:J14} H2O2+hv=OH+OH : j(Pj_h2o2) ; - {015:J15} CH3CHO+hv=CH3O2+CO+HO2 : j(Pj_ch3cho) ; - {016:J16} POOH+hv=CH3CHO+CH2O+HO2+OH : j(Pj_pooh) ; - {017:J17} CH3COOOH+hv=CH3O2+OH{+CO2} : .28_dp*j(Pj_h2o2) ; - {018:J18} PAN+hv=0.6 CH3CO3+0.6 NO2+0.4 CH3O2+0.4 NO3{+0.4 CO2} : j(Pj_pan) ; - {019:J19} MPAN+hv=MCO3+NO2 : j(Pj_pan) ; - {020:J20} MACR+hv=0.67 HO2+0.33 MCO3+0.67 CH2O+0.67 CH3CO3+0.33 OH+0.67 CO: j(Pj_macr) ; - {021:J21} MVK+hv=0.7 C3H6+0.7 CO+0.3 CH3O2+0.3 CH3CO3 : j(Pj_mvk) ; - {022:J22} C2H5OOH+hv=CH3CHO+HO2+OH : j(Pj_ch3o2h) ; - {023:J23} C3H7OOH+hv=0.82 CH3COCH3+HO2+OH : j(Pj_ch3o2h) ; - {024:J24} ROOH+hv=CH3CO3+CH2O+OH : j(Pj_ch3o2h) ; - {025:J25} CH3COCH3+hv=CH3CO3+CH3O2 : j(Pj_ch3coch3) ; - {026:J26} CH3COCHO+hv=CH3CO3+CO+HO2 : j(Pj_ch3cocho) ; - {027:J27} XOOH+hv=OH : j(Pj_ch3o2h) ; - {028:J28} ONITR+hv=HO2+CO+NO2+CH2O : j(Pj_ch3cho) ; - {029:J29} ISOPOOH+hv=.402 MVK+.288 MACR+.69 CH2O+HO2: j(Pj_ch3o2h) ; - {030:J30} HYAC+hv=CH3CO3+HO2+CH2O : j(Pj_hyac) ; - {031:J31} GLYALD+hv=HO2+HO2+CO+CH2O : j(Pj_glyald) ; - {032:J32} MEK+hv=CH3CO3+C2H5O2 : j(Pj_mek) ; - {033:J33} BIGALD+hv=0.45 CO+0.13 GLYOXAL+0.56 HO2 +0.13 CH3CO3+ 0.18 CH3COCHO : .2_dp*j(Pj_no2) ; - {034:J34} GLYOXAL+hv=CO+CO+HO2+HO2 : j(Pj_gly) ; - {035:J35} ALKOOH+hv=0.4 CH3CHO+0.1 CH2O+0.25 CH3COCH3+0.9 HO2+0.8 MEK+OH: j(Pj_ch3o2h) ; - {036:J36} MEKOOH+hv=OH+CH3CO3+CH3CHO : j(Pj_ch3o2h) ; - {037:J37} TOLOOH+hv=OH+0.45 GLYOXAL+0.45 CH3COCHO+0.9 BIGALD : j(Pj_ch3o2h) ; - {038:J38} TERPOOH+hv=OH+0.1 CH3COCH3+HO2+MVK+MACR : j(Pj_ch3o2h) ; -// gas phase reactions - { 39:001 } O+M{=O2}=O3 : 0.20946*(C_M *6.00e-34_dp*(TEMP/300._dp)**(-2.3_dp)) ; - { 40:002 } O+O3=M{=O2+O2} : ARR2(8.0e-12_dp, 2060.0_dp, TEMP); - { 41:003 } O1D_CB4+M{=O2,N2}=O{+O2,N2} : .79_dp*ARR2(2.1e-11_dp, -115.0_dp, TEMP) + .21_dp*ARR2(3.2e-11_dp, -70.0_dp, TEMP); - { 42:004 } O1D_CB4+H2O=OH+OH : 2.2e-10_dp ; - { 43:005 } O1D_CB4+H2=HO2+OH : 1.1e-10_dp ; - { 44:006 } OH+H2=HO2+H2O : ARR2(5.5e-12_dp, 2000.0_dp, TEMP); - { 45:007 } O+OH=HO2{+O2} : ARR2(2.2e-11_dp, -120.0_dp, TEMP); - { 46:008 } O+HO2=OH{+O2} : ARR2(3.0e-11_dp, -200.0_dp, TEMP); - { 47:009 } OH+O3=HO2{+O2} : ARR2(1.7e-12_dp, 940.0_dp, TEMP); - { 48:010 } HO2+O3=OH{+O2+O2} : ARR2(1.0e-14_dp, 490.0_dp, TEMP); - { 49:011 } HO2+HO2+H2O=H2O2 : usr9( temp, c_m, c_h2o ) ; - { 50:012 } H2O2+OH=HO2+H2O : ARR2(2.9e-12_dp, 160.0_dp, TEMP); - { 51:013 } OH+HO2=H2O{+O2} : ARR2(4.8e-11_dp, -250.0_dp, TEMP); - { 52:014 } OH+OH=H2O+O : ARR2(4.2e-12_dp, 240.0_dp, TEMP); - { 53:015 } OH+OH{+M}=H2O2{+M} : TROE( 6.90e-31_dp , 1.0_dp , 2.60e-11_dp , 0.0_dp , TEMP, C_M) ; - { 54:016 } N2O+O1D_CB4=NO+NO : 6.7e-11_dp ; - { 55:017 } N2O+O1D_CB4=M{=O2+N2} : 4.9e-11_dp ; - { 56:018 } NO+HO2=NO2+OH : ARR2(3.5e-12_dp, -250.0_dp, TEMP) ; - { 57:019 } O3+NO=NO2{+O2} : ARR2(3.0e-12_dp, 1500.0_dp, TEMP); - { 58:020 } O+NO2=NO{+O2} : ARR2(5.6e-12_dp, -180.0_dp, TEMP); - { 59:021 } O3+NO2=NO3{+O2} : ARR2(1.2e-13_dp, 2450.0_dp, TEMP); - { 60:022 } NO3+HO2=OH+NO2 : ARR2(2.3e-12_dp, -170.0_dp, TEMP); - { 61:023 } NO3+NO2{+M}=N2O5{+M} : TROE( 2.e-30_dp , 4.4_dp , 1.4e-12_dp , .7_dp , TEMP, C_M) ; - { 62:024 } N2O5{+M}=NO2+NO3{+M} : TROEE(3.333e26_dp,10900._dp, 2.2e-30_dp , 4.4_dp , 1.4e-12_dp , .7_dp , TEMP, C_M ) ; - { 63:025 } OH+NO2{+M}=HNO3{+M} : TROE( 2.e-30_dp , 3._dp , 2.5e-11_dp , 0._dp , TEMP, C_M) ; - { 64:026 } OH+HNO3=NO3+H2O : usr5( TEMP, C_M ) ; - { 65:027 } NO3+NO=NO2+NO2 : ARR2(1.5e-11_dp, -170._dp, TEMP); - { 66:028 } HO2+NO2{+M}=HO2NO2{+M} : TROE( 1.8e-31_dp , 3.2_dp , 4.7e-12_dp , 1.4_dp , TEMP, C_M) ; - { 67:029 } OH+HO2NO2=NO2+H2O{+O2} : ARR2(1.3e-12_dp, -380._dp, TEMP); - { 68:030 } HO2NO2{+M}=HO2+NO2{+M} : TROEE( 4.76e26_dp,10900._dp, 1.8e-31_dp , 3.2_dp , 4.7e-12_dp , 1.4_dp , TEMP, C_M ) ; - { 69:031 } N2O5+M=2.00 HNO3{+M} : usr16( rh, temp ) ; - { 70:032 } NO3=HNO3 : usr17(rh, temp) ; - { 71:033 } NO2=0.5 OH+0.5 NO+0.5 HNO3 : usr17a(rh, temp) ; - { 72:034 } CH4+OH=CH3O2+H2O : ARR2(2.45e-12_dp, 1775.0_dp, TEMP) ; - { 73:035 } CH4+O1D_CB4=0.75 CH3O2+0.75 OH+0.25 CH2O+0.4 HO2+0.05 H2 : 1.5e-10_dp ; - { 74:036 } CH3O2+NO=CH2O+NO2+HO2 : ARR2(2.8e-12_dp, -300._dp, TEMP) ; - { 75:036 } CH3O2+CH3O2=CH2O+CH2O+HO2+HO2 : ARR2(5.e-13_dp, 424._dp, TEMP) ; - { 76:037 } CH3O2+CH3O2=CH2O+CH3OH : ARR2(1.9e-14_dp, -706._dp, TEMP) ; - { 77:038 } CH3O2+HO2=CH3OOH{+O2} : ARR2(4.1e-13_dp, -750._dp, TEMP) ; - { 78:039 } CH3OOH+OH=0.7 CH3O2+0.3 OH+0.3 CH2O+H2O : ARR2(3.8e-12_dp, -200._dp, TEMP) ; - { 79:040 } CH2O+NO3=CO+HO2+HNO3 : ARR2( 6.e-13_dp, 2058._dp, TEMP) ; - { 80:041 } CH2O+OH=CO+HO2+H2O : 9.e-12_dp ; - { 81:042 } CO+OH=HO2{+CO2} : usr8(temp, c_m) ; - { 82:043 } C2H4+OH{+M}=0.75 EO2+0.5 CH2O+0.25 HO2{+M} : TROE( 1.e-28_dp , .8_dp , 8.8e-12_dp , 0._dp , TEMP, C_M) ; - { 83:044 } C2H4+O3=CH2O+0.12 HO2+0.5 CO+0.12 OH+0.25 CH3COOH : ARR2(1.2e-14_dp, 2630._dp, TEMP) ; - { 84:045 } SO2+OH=SO4 : usr23( TEMP, C_M ) ; - { 85:046 } GLYOXAL+OH=HO2+CO{+CO2} : 1.1e-11_dp ; - { 86:047 } EO2+NO=EO+NO2 : ARR2(4.2e-12_dp, -180._dp, TEMP) ; - { 87:048 } EO+M{=O2}=GLYALD+HO2 : 1e-14_dp ; - { 88:049 } EO=2 CH2O+HO2 : ARR2(1.6e11_dp, 4150._dp, TEMP) ; - { 89:050 } C2H6+OH=C2H5O2{+H2O} : ARR2(8.7e-12_dp, 1070._dp, TEMP) ; - { 90:051 } C2H5O2+NO=CH3CHO+HO2+NO2 : ARR2(2.6e-12_dp, -365._dp, TEMP) ; - { 91:052 } C2H5O2+HO2=C2H5OOH{+O2} : ARR2(7.5e-13_dp, -700._dp, TEMP) ; - { 92:053 } C2H5O2+CH3O2=.7 CH2O+.8 CH3CHO+.3 CH3OH+.2 C2H5OH+HO2 : 2.e-13_dp ; - { 93:054 } C2H5OOH+OH=.5 C2H5O2+.5 CH3CHO+.5 OH : ARR2(3.8e-12_dp, -200._dp, TEMP) ; - { 94:055 } C3H6+OH{+M}=PO2{+M} : JPL_TROE( 8.0e-27_dp , 3.5_dp , 3.e-11_dp , 0._dp , .5_dp, TEMP, C_M) ; - { 95:056 } C3H6+O3=.54 CH2O+.19 HO2+.33 OH+.08 CH4+.56 CO+.5 CH3CHO+.31 CH3O2+.25 CH3COOH : ARR2(6.5e-15_dp, 1900._dp, TEMP) ; - { 96:057 } C3H6+NO3=ONIT : ARR2(4.6e-13_dp, 1156._dp, TEMP) ; - { 97:058 } PO2+NO=CH3CHO+CH2O+HO2+NO2 : ARR2(4.2e-12_dp, -180._dp, TEMP) ; - { 98:059 } PO2+HO2=POOH{+O2} : ARR2(7.5e-13_dp, -700._dp, TEMP) ; - { 99:060 } POOH+OH=.5 PO2+.5 OH+.5 HYAC : ARR2(3.8e-12_dp, -200._dp, TEMP) ; - {100:061 } CH3CHO+OH=CH3CO3{+H2O} : ARR2(5.6e-12_dp, -270._dp, TEMP) ; - {101:062 } CH3CHO+NO3=CH3CO3+HNO3 : ARR2(1.4e-12_dp, 1900._dp, TEMP) ; - {102:063 } CH3CO3+NO=CH3O2+NO2{+CO2} : ARR2(8.1e-12_dp, -270._dp, TEMP) ; - {103:064 } CH3CO3+NO2{+M}=PAN{+M} : TROE( 8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 1._dp , TEMP, C_M) ; - {104:065 } CH3CO3+HO2=.75 CH3COOOH+.25 CH3COOH+.25 O3 : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; - {105:066 } CH3CO3+CH3O2=.9 CH3O2+.9 HO2+.1 CH3COOH+CH2O{+0.5 CO2} : ARR2(2.e-12_dp, -500._dp, TEMP) ; - {106:067 } CH3COOOH+OH=.5 CH3CO3+.5 CH2O{+H2O+0.5 CO2} : 1.e-12_dp ; - {107:068 } PAN{+M}=CH3CO3+NO2{+M} : TROEE( 1.111e28_dp,14000._dp,8.5e-29_dp , 6.5_dp , 1.1e-11_dp , 0._dp , TEMP, C_M) ; - {108:069 } CH3CO3+CH3CO3=2 CH3O2{+2 CO2} : ARR2(2.5e-12_dp, -500._dp, TEMP) ; - {109:070 } C3H8+OH=C3H7O2{+H2O} : ARR2(1.e-11_dp, 660._dp, TEMP) ; - {110:071 } C3H7O2+NO=.82 CH3COCH3+.27 CH3CHO+NO2+HO2 : ARR2(4.e-12_dp, -180._dp, TEMP) ; - {111:072 } C3H7O2+HO2=C3H7OOH{+O2} : ARR2(7.5e-13_dp, -700._dp, TEMP) ; - {112:073 } C3H7O2+CH3O2=CH2O+HO2+.82 CH3COCH3 : ARR2(3.75e-13_dp, 40._dp, TEMP) ; - {113:074 } C3H7OOH+OH=C3H7O2{+H2O} : ARR2(3.8e-12_dp, -200._dp, TEMP) ; - {114:075 } CH3COCH3+OH=RO2{+H2O} : 3.82e-11_dp*exp( -2000._dp/temp )+1.33e-13_dp ; - {115:076 } RO2+NO=CH3CO3+CH2O+NO2+nume : ARR2(2.9e-12_dp, -300._dp, TEMP) ; - {116:077 } RO2+HO2=ROOH+den{+O2} : ARR2(8.6e-13_dp, -700._dp, TEMP) ; - {117:078 } RO2+CH3O2=.3 CH3CO3+.8 CH2O+.3 HO2+.2 HYAC+.5 CH3COCHO+.5 CH3OH : ARR2(2.e-12_dp, -500._dp, TEMP) ; - {118:079 } ROOH+OH=RO2{+H2O} : ARR2(3.8e-12_dp, -200._dp, TEMP) ; - {119:080 } BIGENE+OH=ENEO2 : 5.4e-11_dp ; - {120:081 } ENEO2+NO=CH3CHO+.5 CH2O+.5 CH3COCH3+HO2+NO2 : ARR2(4.2e-12_dp, -180._dp, TEMP) ; - {121:082 } BIGALK+OH=ALKO2 : 3.5e-12_dp ; - {122:083 } ALKO2+NO=.4 CH3CHO+.1 CH2O+.25 CH3COCH3+.9 HO2+.75 MEK+.9 NO2+.1 ONIT : ARR2(4.2e-12_dp, -180._dp, TEMP) ; - {123:084 } ALKO2+HO2=ALKOOH : ARR2(7.5e-13_dp, -700._dp, TEMP) ; - {124:085 } ALKOOH+OH=ALKO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; - {125:086 } ONIT+OH=NO2+CH3COCHO : 6.8e-13_dp ; - {126:087 } MEK+OH=MEKO2 : ARR2(2.3e-12_dp, 170._dp, TEMP) ; - {127:088 } MEKO2+NO=CH3CO3+CH3CHO+NO2 : ARR2(4.2e-12_dp, -180._dp, TEMP) ; - {128:089 } MEKO2+HO2=MEKOOH : ARR2(7.5e-13_dp, -700._dp, TEMP) ; - {129:090 } MEKOOH+OH=MEKO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; - {130:091 } TOLUENE+OH=.25 CRESOL+.25 HO2+.7 TOLO2 : ARR2(1.7e-12_dp, -352._dp, TEMP) ; - {131:092 } CRESOL+OH=XOH : 3.e-12_dp ; - {132:093 } XOH+NO2=.7 NO2+.7 BIGALD+.7 HO2 : 1.e-11_dp ; - {133:094 } TOLO2+NO=.45 GLYOXAL+.45 CH3COCHO+.9 BIGALD+.9 NO2+.9 HO2 : ARR2(4.2e-12_dp, -180._dp, TEMP) ; - {134:095 } TOLO2+HO2=TOLOOH : ARR2(7.5e-13_dp, -700._dp, TEMP) ; - {135:096 } TOLOOH+OH=TOLO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; - {136:097 } ISOP+OH=ISOPO2 : ARR2(2.54e-11_dp, -410._dp, TEMP) ; - {137:098 } ISOP+O3=.4 MACR+.2 MVK+.07 C3H6+.27 OH+.06 HO2+.6 CH2O+.3 CO+.1 O3+.2 MCO3+.2 CH3COOH : ARR2(1.05e-14_dp, 2000._dp, TEMP) ; - {138:099 } ISOPO2+NO=.08 ONITR+.92 NO2+.23 MACR+.32 MVK+.37 HYDRALD+.55 CH2O+HO2 : ARR2(4.4e-12_dp, -180._dp, TEMP) ; - {139:100 } ISOPO2+NO3=HO2+NO2+.6 CH2O+.25 MACR+.35 MVK+.4 HYDRALD : 2.4e-12_dp ; - {140:101 } ISOPO2+HO2=ISOPOOH : ARR2(8.e-13_dp, -700._dp, TEMP) ; - {141:102 } ISOPOOH+OH=.5 XO2+.5 ISOPO2 : ARR2(1.52e-11_dp, -200._dp, TEMP) ; - {142:103 } ISOPO2+CH3O2=.25 CH3OH+HO2+1.2 CH2O+.19 MACR+.26 MVK+.3 HYDRALD : ARR2(5.e-13_dp, -400._dp, TEMP) ; - {143:104 } ISOPO2+CH3CO3=CH3O2+HO2+0.6 CH2O+.25 MACR+.35 MVK+.4 HYDRALD{+CO2} : 1.4e-11_dp ; - {144:105 } MVK+OH=MACRO2 : ARR2(4.13e-12_dp, -452._dp, TEMP) ; - {145:106 } MVK+O3=.8 CH2O+.95 CH3COCHO+.08 OH+.2 O3+.06 HO2+.05 CO+.04 CH3CHO : ARR2(7.52e-16_dp, 1521._dp, TEMP) ; - {146:107 } MACR+OH=.5 MACRO2+.5 MCO3{+0.5 H2O} : ARR2(1.86e-11_dp, -175._dp, TEMP) ; - {147:108 } MACR+O3=.8 CH3COCHO+.275 HO2+.2 CO+.7 CH2O+.215 OH+.2 O3 : ARR2(4.4e-15_dp, 2500._dp, TEMP) ; - {148:109 } MACRO2+NO=NO2+.47 HO2+.25 CH2O+.25 CH3COCHO+.53 CH3CO3+.53 GLYALD+.22 HYAC+.22 CO : ARR2(2.7e-12_dp, -360._dp, TEMP) ; - {149:110 } MACRO2+NO=.8 ONITR : ARR2(1.3e-13_dp, -360._dp, TEMP) ; - {150:110 } MACRO2+NO3=NO2+.47 HO2+.25 CH2O+.25 CH3COCHO+.22 CO+.53 GLYALD+.22 HYAC+.53 CH3CO3 : 2.4e-12_dp ; - {151:111 } MACRO2+HO2=MACROOH : ARR2(8.e-13_dp, -700._dp, TEMP) ; - {152:112 } MACRO2+CH3O2=.73 HO2+.88 CH2O+.11 CO+.24 CH3COCHO+.26 GLYALD+.26 CH3CO3+.25 CH3OH+.23 HYAC : ARR2(5.e-13_dp, -400._dp, TEMP) ; - {153:113 } MACRO2+CH3CO3=.25 CH3COCHO+CH3O2+.22 CO+.47 HO2+.53 GLYALD+.22 HYAC+.25 CH2O+.53 CH3CO3{+CO2} : 1.4e-11_dp ; - {154:114 } MACROOH+OH=.5 MCO3+.2 MACRO2+.1 OH+.2 HO2 : ARR2(2.3e-11_dp, -200._dp, TEMP) ; - {155:115 } MCO3+NO=NO2+CH2O+CH3CO3{+CO2} : ARR2(5.3e-12_dp, -360._dp, TEMP) ; - {156:116 } MCO3+NO3=NO2+CH2O+CH3CO3{+CO2} : 5.e-12_dp ; - {157:117 } MCO3+HO2=.25 O3+.25 CH3COOH+.75 CH3COOOH {+0.75 O2} : ARR2(4.3e-13_dp, -1040._dp, TEMP) ; - {158:118 } MCO3+CH3O2=2 CH2O+HO2+CH3CO3{+CO2} : ARR2(2.e-12_dp, -500._dp, TEMP) ; - {159:119 } MCO3+CH3CO3=CH3O2+CH2O+CH3CO3{+2 CO2} : ARR2(4.6e-12_dp, -530._dp, TEMP) ; - {160:120 } MCO3+MCO3=2 CH2O+2 CH3CO3{+2 CO2} : ARR2(2.3e-12_dp, -530._dp, TEMP) ; - {161:121 } MCO3+NO2+M=MPAN{+M} : 1.1e-11_dp*300._dp/(temp*c_m) ; - {162:122 } MPAN+M=MCO3+NO2{+M} : 1.2221e17_dp*300._dp*exp( -14000._dp/temp )/(temp*c_m) ; - {163:123 } C10H16+OH=TERPO2 : ARR2(1.2e-11_dp, -444._dp, TEMP) ; - {164:124 } C10H16+O3=.7 OH+MVK+MACR+HO2 : ARR2(1.e-15_dp, 732._dp, TEMP) ; - {165:125 } C10H16+NO3=TERPO2+NO2 : ARR2(1.2e-12_dp, -490._dp, TEMP) ; - {166:126 } TERPO2+NO=.1 CH3COCH3+HO2+MVK+MACR+NO2 : ARR2(4.2e-12_dp, -180._dp, TEMP) ; - {167:127 } TERPO2+HO2=TERPOOH : ARR2(7.5e-13_dp, -700._dp, TEMP) ; - {168:128 } TERPOOH+OH=TERPO2 : ARR2(3.8e-12_dp, -200._dp, TEMP) ; - {169:129 } CH3COOH+OH=CH3O2{+H2O+CO2} : 7.e-13_dp ; - {170:130 } ISOP+NO3=ISOPNO3 : ARR2(3.03e-12_dp, 446._dp, TEMP) ; - {171:131 } ISOPNO3+NO=1.206 NO2+.794 HO2+.072 CH2O+.167 MACR+.039 MVK+.794 ONITR : ARR2(2.7e-12_dp, -360._dp, TEMP) ; - {172:132 } ISOPNO3+NO3=1.206 NO2+.072 CH2O+.167 MACR+.039 MVK+.794 ONITR+.794 HO2 : 2.4e-12_dp ; - {173:133 } ISOPNO3+HO2=.206 NO2+.794 HO2+.008 CH2O+.167 MACR+.039 MVK+.794 ONITR : ARR2(8.e-13_dp, -700._dp, TEMP) ; - {174:134 } CH3COCHO+OH=CH3CO3+CO{+H2O} : ARR2(8.4e-13_dp, -830._dp, TEMP) ; - {175:135 } CH3COCHO+NO3=HNO3+CO+CH3CO3 : ARR2(1.4e-12_dp, 1860._dp, TEMP) ; - {176:136 } ONITR+OH=HYDRALD+HO2+.4 NO2 : 4.5e-11_dp ; - {177:137 } ONITR+NO3=HYDRALD+HO2+NO2 : ARR2(1.4e-12_dp, 1860._dp, TEMP) ; - {178:138 } HYDRALD+OH=XO2 : ARR2(1.86e-11_dp, -175._dp, TEMP) ; - {179:139 } XO2+NO=NO2+1.5 HO2+CO+.25 HYAC+.25 CH3COCHO+.25 GLYALD : ARR2(2.7e-12_dp, -360._dp, TEMP) ; - {180:140 } XO2+NO3=NO2+1.5 HO2+CO+.25 HYAC+.25 CH3COCHO+.25 GLYALD : 2.4e-12_dp ; - {181:141 } XO2+HO2=XOOH : ARR2(8.e-13_dp, -700._dp, TEMP) ; - {182:142 } XO2+CH3O2=.3 CH3OH+HO2+.7 CH2O+.4 CO+.1 HYAC+.1 CH3COCHO+.1 GLYALD {+CO2} : ARR2(5.e-13_dp, -400._dp, TEMP) ; - {183:143 } XO2+CH3CO3=CO+CH3O2+1.5 HO2+.25 HYAC+.25 CH3COCHO+.25 GLYALD : ARR2(1.3e-12_dp, -640._dp, TEMP) ; - {184:144 } XOOH+OH=XO2{+H2O} : ARR2(1.9e-12_dp, -190._dp, TEMP) ; - {185:145 } XOOH+OH=OH{+H2O} : THERMAL_T2(7.69e-17_dp, -253._dp, TEMP) ; - {186:146 } CH3OH+OH=HO2+CH2O : ARR2(7.3e-12_dp, 620._dp, TEMP) ; - {187:147 } C2H5OH+OH=HO2+CH3CHO : ARR2(6.9e-12_dp, 230._dp, TEMP) ; - {188:148 } MPAN+OH=.5 HYAC+.5 NO3+.5 CH2O+.5 HO2 {+0.5 CO2} : JPL_TROE( 8.e-27_dp , 3.5_dp , 3.e-11_dp , 0.0_dp , .5_dp, TEMP, C_M) ; - {189:149 } PAN+OH=CH2O+NO3{+CO2} : 4.e-14_dp ; - {190:150 } HYAC+OH=CH3COCHO+HO2 : 3.e-12_dp ; - {191:151 } GLYALD+OH=HO2+.2 GLYOXAL+.8 CH2O {+0.8 CO2} : 1.e-11_dp ; - {192:152 } DMS+OH=SO2 : ARR2(9.6e-12_dp, 234._dp, TEMP) ; - {193:153 } DMS+OH=.5 SO2+.5 HO2 : usr24( temp, c_m ) ; - {194:154 } DMS+NO3=SO2+HNO3 : ARR2(1.9e-13_dp, -520._dp, TEMP) ; - {195:155 } NH3+OH=M : ARR2(1.7e-12_dp, -710._dp, TEMP) ; - {196:156 } HO2=.5 H2O2 : usr26( rh, temp ) ; - {197:157 } C2H5O2+C2H5O2=1.6 CH3CHO+1.2 HO2+.4 C2H5OH : 6.8e-14_dp ; - {198:158 } VOCA + OH = smpa +OH : 1.25D-11 ; - {199:159 } VOCBB + OH = smpbb +OH : 1.25D-11 ; - {200:160 } ISOP + OH = biog1_c + ISOP + OH : Keff(2.50D-11,-408.0_dp,0.0_dp,TEMP,nume,den,0.0104_dp,0.0078_dp) ; - {201:161 } C10H16 + OH = biog1_o + C10H16 + OH : Keff(1.83D-11,-449.0_dp,0.0_dp,TEMP,nume,den,0.036_dp,0.2065_dp) ; diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.eqn b/wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.eqn index b398507d..2a429b34 100755 --- a/wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.eqn +++ b/wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.eqn @@ -172,7 +172,7 @@ {170:130 } ISOP+NO3=ISOPNO3 : ARR2(3.03e-12_dp, 446._dp, TEMP) ; {171:131 } ISOPNO3+NO=1.206 NO2+.794 HO2+.072 CH2O+.167 MACR+.039 MVK+.794 ONITR : ARR2(2.7e-12_dp, -360._dp, TEMP) ; {172:132 } ISOPNO3+NO3=1.206 NO2+.072 CH2O+.167 MACR+.039 MVK+.794 ONITR+.794 HO2 : 2.4e-12_dp ; - {173:133 } ISOPNO3+HO2=.206 NO2+.794 HO2+.008 CH2O+.167 MACR+.039 MVK+.794 ONITR : ARR2(8.e-13_dp, -700._dp, TEMP) ; + {173:133 } ISOPNO3+HO2=.206 NO2+.206 OH+.206 CH2O+.167 MACR+.039 MVK+.794 ONITR : ARR2(8.e-13_dp, -700._dp, TEMP) ; {174:134 } CH3COCHO+OH=CH3CO3+CO{+H2O} : ARR2(8.4e-13_dp, -830._dp, TEMP) ; {175:135 } CH3COCHO+NO3=HNO3+CO+CH3CO3 : ARR2(1.4e-12_dp, 1860._dp, TEMP) ; {176:136 } ONITR+OH=HYDRALD+HO2+.4 NO2 : 4.5e-11_dp ; @@ -194,6 +194,6 @@ {192:152 } DMS+OH=SO2 : ARR2(9.6e-12_dp, 234._dp, TEMP) ; {193:153 } DMS+OH=.5 SO2+.5 HO2 : usr24( temp, c_m ) ; {194:154 } DMS+NO3=SO2+HNO3 : ARR2(1.9e-13_dp, -520._dp, TEMP) ; - {195:155 } NH3+OH=M : ARR2(1.7e-12_dp, -710._dp, TEMP) ; + {195:155 } NH3+OH=M : ARR2(1.7e-12_dp, 710._dp, TEMP) ; {196:156 } HO2=.5 H2O2 : usr26( rh, temp ) ; {197:157 } C2H5O2+C2H5O2=1.6 CH3CHO+1.2 HO2+.4 C2H5OH : 6.8e-14_dp ; diff --git a/wrfv2_fire/chem/KPP/util/wkc/change_chem_Makefile.c b/wrfv2_fire/chem/KPP/util/wkc/change_chem_Makefile.c index 6de7ad7a..cf3226b5 100644 --- a/wrfv2_fire/chem/KPP/util/wkc/change_chem_Makefile.c +++ b/wrfv2_fire/chem/KPP/util/wkc/change_chem_Makefile.c @@ -49,7 +49,7 @@ knode_t * p1, * p2, * pm1; /* if ( strncmp(inln, "MODULES",6) == 0){ */ - if ( strncmp(inln, " module_data_sorgam",25) == 0){ + if ( strncmp(inln, " module_data_sorgam_vbs",29) == 0){ for ( p1 = KPP_packs ; p1 != NULL ; p1 = p1->next ) { p2 = p1->assoc_wrf_pack; diff --git a/wrfv2_fire/chem/KPP/util/wkc/compare_kpp_to_species.c b/wrfv2_fire/chem/KPP/util/wkc/compare_kpp_to_species.c index e551e7e3..7489ecec 100644 --- a/wrfv2_fire/chem/KPP/util/wkc/compare_kpp_to_species.c +++ b/wrfv2_fire/chem/KPP/util/wkc/compare_kpp_to_species.c @@ -345,12 +345,12 @@ compare_kpp_to_species ( char * kpp_dirname) make_upper_case(name1); if ( strcmp (name1, kpp_third_body) == 0) { pm1->found_match = 2; - strcpy( pm1->assoc_wrf_name, "WATER VAPOR"); + strcpy( pm1->assoc_wrf_name, "THIRD BODY"); p1 -> got_air = 1; } if ( strcmp (name1, kpp_h2o) == 0) { pm1->found_match = 2; - strcpy( pm1->assoc_wrf_name, "THIRD BODY"); + strcpy( pm1->assoc_wrf_name, "WATER VAPOR"); got_h2o = 1; } } diff --git a/wrfv2_fire/chem/KPP/util/write_decomp/Makefile b/wrfv2_fire/chem/KPP/util/write_decomp/Makefile index 321b7fa3..20c852f1 100644 --- a/wrfv2_fire/chem/KPP/util/write_decomp/Makefile +++ b/wrfv2_fire/chem/KPP/util/write_decomp/Makefile @@ -28,7 +28,7 @@ all: $(MAKE) comp ./write_decomp.exe $(MAKE) integr_edit - integr_edit.exe $(MECH) + ./integr_edit.exe $(MECH) $(MAKE) clean diff --git a/wrfv2_fire/chem/Makefile b/wrfv2_fire/chem/Makefile index 152c12cd..d61256c7 100755 --- a/wrfv2_fire/chem/Makefile +++ b/wrfv2_fire/chem/Makefile @@ -10,6 +10,26 @@ MAKE = make -i -r RM = rm -f MODULES = \ + module_data_isrpia_data.o \ + module_data_ISRPIA.o \ + module_data_isrpia_asrc.o \ + module_data_isrpia_solut.o \ + module_data_isrpia_kmc198.o \ + module_data_isrpia_kmc223.o \ + module_data_isrpia_kmc248.o \ + module_data_isrpia_kmc273.o \ + module_data_isrpia_kmc298.o \ + module_data_isrpia_kmc323.o \ + module_data_isrpia_expnc.o \ + module_data_isrpia_caseg.o \ + module_data_isrpia_casej.o \ + isofwd.o \ + isorev.o \ + isocom.o \ + moduleHETDATA.o \ + moduleHETAERO.o \ + moduleAERODATA.o \ + aerorate_so2.o \ module_aer_opt_out.o \ module_add_emiss_burn.o \ module_add_emis_cptec.o \ @@ -29,6 +49,7 @@ MODULES = \ module_data_megan2.o \ module_data_soa_vbs.o \ module_data_sorgam.o \ + module_data_sorgam_vbs.o \ module_ftuv_subs.o \ module_ghg_fluxes.o \ module_gocart_drydep.o \ @@ -70,16 +91,21 @@ MODULES = \ module_fastj_mie.o \ module_input_chem_data.o \ module_mosaic_coag.o \ + module_mosaic_gly.o \ module_mosaic_wetscav.o \ module_mosaic_therm.o \ module_phot_mad.o \ module_radm.o \ module_sorgam_aqchem.o \ + module_sorgam_vbs_aqchem.o \ module_aerosols_soa_vbs.o \ module_aerosols_sorgam.o \ + module_aerosols_sorgam_vbs.o \ module_bioemi_megan2.o \ module_bioemi_simple.o \ module_cbm4_initmixrats.o \ + module_cb05_initmixrats.o \ + module_cb05_vbs_initmixrats.o \ module_cbmz.o \ module_cbmz_initmixrats.o \ module_cbmz_rodas_prep.o \ @@ -100,6 +126,7 @@ MODULES = \ module_input_gocart_dms.o \ module_cbmz_addemiss.o \ module_cbm4_addemiss.o \ + module_cb05_addemiss.o \ module_emissions_anthropogenics.o \ module_aer_drydep.o \ module_cam_mam_calcsize.o \ @@ -123,20 +150,22 @@ MODULES = \ module_cam_mam_mo_chem_utls.o \ module_mosaic_cloudchem.o \ module_sorgam_cloudchem.o \ + module_sorgam_vbs_cloudchem.o \ module_cam_mam_gas_wetdep_driver.o \ module_cam_mam_mo_sethet.o \ - module_phot_fastj.o + module_phot_fastj.o \ + module_chem_cup.o OBJS = \ - chemics_init.o \ - chem_driver.o \ - cloudchem_driver.o \ - photolysis_driver.o \ - optical_driver.o \ - mechanism_driver.o \ - emissions_driver.o \ - dry_dep_driver.o \ - aerosol_driver.o + chemics_init.o \ + chem_driver.o \ + cloudchem_driver.o \ + photolysis_driver.o \ + optical_driver.o \ + mechanism_driver.o \ + emissions_driver.o \ + dry_dep_driver.o \ + aerosol_driver.o LIBTARGET = chemics TARGETDIR = ./ diff --git a/wrfv2_fire/chem/aerorate_so2.F b/wrfv2_fire/chem/aerorate_so2.F new file mode 100755 index 00000000..0bddd92c --- /dev/null +++ b/wrfv2_fire/chem/aerorate_so2.F @@ -0,0 +1,118 @@ +!*********************************************************************** + SUBROUTINE AERORATE_SO2( BTEMP, BPRESS, RTDAT_AE ) +!*********************************************************************** + + USE AERODATA + USE HETAERO +! USE CONST_MADRID !CMAQ constants + + IMPLICIT NONE + +!........... ARGUMENTS and their descriptions + REAL BTEMP ! in degK + REAL BPRESS ! in Pa + REAL RTDAT_AE ( NRXNAERO ) ! heterogeneous reaction rate constant + ! first-order (if no reactant specified) + ! second-order (if reactant specified) + +! Local variables + + INTEGER :: INASEC, IRXN ! loop variables + + REAL VSP ! mean molecular speed (m/s) + REAL DG ! gas-phase moleular diffusion + ! coefficient (m2/s) + REAL, SAVE :: GAMMA( NRXNAERO ) ! reaction probability + + REAL RS_TOT ! first order heterogeneous reaction + ! rate constant (1/s) over the size distribution + REAL RS ! first order heterogeneous reaction + ! rate constant (1/s) for each size section + REAL TOTMA ! Total particle mass concentration, ug/m3 + REAL RCL ! mean radius of exch size section, in meter + REAL*8 PI ! pi (single precision 3.141593) + PARAMETER ( PI = 3.14159265358979324 ) + + LOGICAL, SAVE :: FIRSTIME = .TRUE. + +!*********************************************************************** +! begin body of main program + + IF ( IAERORATE == 0 ) RETURN ! Turn off gas-aerosol + ! heterogeneous reactions + IF ( FIRSTIME ) THEN + + FIRSTIME = .FALSE. + +! Assign the reaction probability +! according to Jacob, 2000, Atmos. Environ, 34, 2131-2159 +! NGAMMA is assigned in module HETAERO +! NGAMMA = 1 Using the recommended median value +! NGAMMA = 2 Using the low bound value +! NGAMMA = 3 Using the high bound value + + IF ( NGAMMA == 1 ) THEN ! Using the median value + GAMMA( ISO2 ) = 1.0E-4 + + ELSE IF ( NGAMMA == 2 ) THEN ! Using the low bound value + GAMMA( ISO2 ) = 1.0E-5 + + ELSE IF ( NGAMMA == 3 ) THEN ! Using the high bound value + GAMMA( ISO2 ) = 0.1 + END IF + + END IF ! If first time + +! Calculate total aerosol conc., total surface area, and heterogeneous +! loss rates + + DO INASEC = 1, NASECT + + TOTMA = 0.0 +! Following loop is deactivated +! Temporarily use input PM concentrations +! DO J = 1, NASPEC +! TOTMA = TOTMA + PMCONC( J, INASEC ) +! END DO + + TOTMA = PMCONC( INASEC ) +! calculate surface area of a single particle in each section + + SURFP = 4.0 * PI * ( DPCTR( INASEC ) / 2.0 )**2.0 ! um2 + VOL = ( 4.0 * PI / 3.0 ) * ( DPCTR( INASEC ) & + / 2.0 )**3.0 ! um3 + AEROMA = VOL * DENSP * 1.0E-6 ! ug + + IF ( AEROMA > 0.0 ) THEN + XNUM = TOTMA / AEROMA + AREA( INASEC ) = SURFP * XNUM * 1.0E-12 ! m2/m3 + ELSE + AREA( INASEC ) = 0.0 + END IF + + END DO + +! Calculate diffusion coefficients for reacting species in m2/s, +! molecular speed in m/s, and heterogeneous loss rate in 1/s + DO IRXN = 1, NRXNAERO + RS_TOT = 0.0 + DG = ( DG0( IRXN ) * ( PRESS0 / BPRESS ) * & + ( BTEMP / TEMP0 )**1.75 ) * 1.0E-4 + VSP = SQRT( 8.0 * RG * BTEMP / PI / XMOLWEI( IRXN ) ) + DO INASEC = 1, NASECT + RCL = ( DPCTR( INASEC ) / 2.0) * 1.0E-6 + RS = 1.0 / ( RCL / DG + 4.0 / VSP / & + GAMMA( IRXN ) ) * AREA( INASEC ) +! RS = 0.25 * VSP * AREA( INASEC ) * GAMMA( IRXN ) + RS_TOT = RS_TOT + RS + END DO + +! assign the heterogeneous loss rates to RTDAT_AE in 1/sec for first-order +! reaction (no specified reactant) or 1/sec/mol-cc for second-order reaction + + RTDAT_AE( IRXN ) = RS_TOT + + END DO + + RETURN + END diff --git a/wrfv2_fire/chem/aerosol_driver.F b/wrfv2_fire/chem/aerosol_driver.F index 9aceda5d..873fe8e4 100755 --- a/wrfv2_fire/chem/aerosol_driver.F +++ b/wrfv2_fire/chem/aerosol_driver.F @@ -4,6 +4,7 @@ ! William Gustafson (PNNL),Rainer Schmitz (University of Chile) and Georg Grell ! ! 10/12/2011 - Ravan Ahmadov (NOAA) updated to include the RACM_SOA_VBS option +! 10/08/2014 - Kai Wang and Yang Zhang (NCSU) updated to include the CB05_MADE/SORGAM and CB05_MADE/VBS options ! SUBROUTINE aerosols_driver (id,curr_secs,ktau,dtstep,ktauc, & config_flags,dtstepc,dx, & @@ -29,6 +30,7 @@ SUBROUTINE aerosols_driver (id,curr_secs,ktau,dtstep,ktauc, & USE module_data_sorgam USE module_mosaic_driver, only: mosaic_aerchem_driver USE module_aerosols_soa_vbs, only: soa_vbs_driver + USE module_aerosols_sorgam_vbs, only: sorgam_vbs_driver USE module_data_soa_vbs, only: ldrog_vbs USE module_cam_mam_aerchem_driver, only: cam_mam_aerchem_driver USE modal_aero_data, only: ntot_amode_cam_mam => ntot_amode @@ -204,13 +206,14 @@ SUBROUTINE aerosols_driver (id,curr_secs,ktau,dtstep,ktauc, & ! cps_select: SELECT CASE(config_flags%chem_opt) - CASE (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2_KPP,GOCARTRADM2,MOZCART_KPP) + CASE (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2,MOZCART_KPP) call gocart_aerosols_driver(ktauc,dtstepc,config_flags,t_phy,moist, & chem,rho_phy,dz8w,p8w,dx,g, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RADM2SORG_KPP,CBMZSORG,CBMZSORG_AQ) + CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RADM2SORG_KPP,CBMZSORG,CBMZSORG_AQ, & + CB05_SORG_AQ_KPP) CALL wrf_debug(15,'aerosols_driver calling sorgam_driver') do ii=its,ite do kk=kts,kte @@ -230,6 +233,25 @@ SUBROUTINE aerosols_driver (id,curr_secs,ktau,dtstep,ktauc, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE (CB05_SORG_VBS_AQ_KPP) + CALL wrf_debug(15,'aerosols_driver calling sorgam_vbs_driver') + do ii=its,ite + do kk=kts,kte + do jj=jts,jte + if(chem(ii,kk,jj,p_nu0).lt.1.e07)then + chem(ii,kk,jj,p_nu0)=1.e7 + endif + enddo + enddo + enddo + call sorgam_vbs_driver (id,ktauc,dtstepc,t_phy,moist,aerwrf,p8w,t8w, & + alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, & + vcsulf_old,vdrog3_vbs, & + config_flags%kemit,brch_ratio, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) CASE (RACMSORG_AQ,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACMSORG_KPP,RACM_ESRLSORG_KPP) ! ???? are separate cases needed here for radm2sorg and racmsorg packages ???? @@ -254,9 +276,10 @@ SUBROUTINE aerosols_driver (id,curr_secs,ktau,dtstep,ktauc, & its,ite, jts,jte, kts,kte ) CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, & - CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP, & - CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) + CBMZ_MOSAIC_8BIN_AQ, SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, SAPRC99_MOSAIC_8BIN_VBS2_KPP, & !BSINGH Added "SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP" and "SAPRC99_MOSAIC_8BIN_VBS2_KPP" + CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ) CALL wrf_debug(15,'aerosols_driver calling mosaic_aerchem_driver') CALL mosaic_aerchem_driver( & id, curr_secs, ktau, dtstep, ktauc, dtstepc, config_flags, & @@ -313,21 +336,51 @@ END SUBROUTINE aerosols_driver ! SUBROUTINE sum_pm_driver ( config_flags, & - alt, chem, h2oaj, h2oai, & - pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + alt, chem, h2oaj, h2oai, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + tsoa,asoa,bsoa, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & + hoa_a05,hoa_a06,hoa_a07,hoa_a08, & !BSINGH Added 4 more bins for each species for SAPRC 8 bin version bboa_a01,bboa_a02,bboa_a03,bboa_a04, & + bboa_a05,bboa_a06,bboa_a07,bboa_a08, & soa_a01,soa_a02,soa_a03,soa_a04, & + soa_a05,soa_a06,soa_a07,soa_a08, & bbsoa_a01,bbsoa_a02,bbsoa_a03,bbsoa_a04, & + bbsoa_a05,bbsoa_a06,bbsoa_a07,bbsoa_a08, & hsoa_a01,hsoa_a02,hsoa_a03,hsoa_a04, & + hsoa_a05,hsoa_a06,hsoa_a07,hsoa_a08, & biog_a01,biog_a02,biog_a03,biog_a04, & - asmpsoa_a01,asmpsoa_a02,asmpsoa_a03,asmpsoa_a04, & + biog_a05,biog_a06,biog_a07,biog_a08, & + asmpsoa_a01,asmpsoa_a02,asmpsoa_a03,asmpsoa_a04, & arosoa_a01,arosoa_a02,arosoa_a03,arosoa_a04, & + arosoa_a05,arosoa_a06,arosoa_a07,arosoa_a08, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & hsoa_c,hsoa_o,bbsoa_c,bbsoa_o, & biog_v1,biog_v2,biog_v3,biog_v4, & ant_v1,ant_v2,ant_v3,ant_v4, & - smpa_v1,smpbb_v1, & + smpa_v1,smpbb_v1, & + !BSINGH - Added cw aerosols(for VBS) + hoa_cw01, hoa_cw02, hoa_cw03, hoa_cw04, & + hoa_cw05, hoa_cw06, hoa_cw07, hoa_cw08, & + bboa_cw01, bboa_cw02, bboa_cw03, bboa_cw04, & + bboa_cw05, bboa_cw06, bboa_cw07, bboa_cw08, & + soa_cw01, soa_cw02, soa_cw03, soa_cw04, & + soa_cw05, soa_cw06, soa_cw07, soa_cw08, & + bbsoa_cw01, bbsoa_cw02, bbsoa_cw03, bbsoa_cw04, & + bbsoa_cw05, bbsoa_cw06, bbsoa_cw07, bbsoa_cw08, & + biog_cw01, biog_cw02, biog_cw03, biog_cw04, & + biog_cw05, biog_cw06, biog_cw07, biog_cw08, & + hsoa_cw01, hsoa_cw02, hsoa_cw03, hsoa_cw04, & + hsoa_cw05, hsoa_cw06, hsoa_cw07, hsoa_cw08, & + arosoa_cw01, arosoa_cw02, arosoa_cw03, arosoa_cw04, & + arosoa_cw05, arosoa_cw06, arosoa_cw07, arosoa_cw08, & + totoa_cw01, totoa_cw02, totoa_cw03, totoa_cw04, & + totoa_cw05, totoa_cw06, totoa_cw07, totoa_cw08, & + hsoa_cw_c, hsoa_cw_o, bbsoa_cw_c, bbsoa_cw_o, & + biog_cw_v1, & + ant_cw_v1, & + !BSINGH -ENDS ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -335,9 +388,11 @@ SUBROUTINE sum_pm_driver ( config_flags, & USE module_configure USE module_aerosols_sorgam, only: sum_pm_sorgam - USE module_mosaic_driver, only: sum_pm_mosaic,sum_pm_mosaic_vbs2,sum_pm_mosaic_vbs0,sum_vbs9,sum_vbs2,sum_vbs0 + USE module_mosaic_driver, only: sum_pm_mosaic,sum_pm_mosaic_vbs2,sum_pm_mosaic_vbs0,sum_pm_mosaic_vbs4,& + sum_vbs9,sum_vbs2,sum_vbs0,sum_vbs4,sum_aq_vbs2 USE module_gocart_aerosols, only: sum_pm_gocart USE module_aerosols_soa_vbs, only: sum_pm_soa_vbs + USE module_aerosols_sorgam_vbs, only: sum_pm_sorgam_vbs IMPLICIT NONE @@ -358,20 +413,50 @@ SUBROUTINE sum_pm_driver ( config_flags, & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & OPTIONAL, & INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10, & + tsoa,asoa,bsoa, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & + hoa_a05,hoa_a06,hoa_a07,hoa_a08, &!BSINGH Added 4 more bins for each species for SAPRC 8 bin version bboa_a01,bboa_a02,bboa_a03,bboa_a04, & + bboa_a05,bboa_a06,bboa_a07,bboa_a08, & soa_a01,soa_a02,soa_a03,soa_a04, & + soa_a05,soa_a06,soa_a07,soa_a08, & bbsoa_a01,bbsoa_a02,bbsoa_a03,bbsoa_a04, & + bbsoa_a05,bbsoa_a06,bbsoa_a07,bbsoa_a08, & hsoa_a01,hsoa_a02,hsoa_a03,hsoa_a04, & + hsoa_a05,hsoa_a06,hsoa_a07,hsoa_a08, & biog_a01,biog_a02,biog_a03,biog_a04, & + biog_a05,biog_a06,biog_a07,biog_a08, & arosoa_a01,arosoa_a02,arosoa_a03,arosoa_a04, & + arosoa_a05,arosoa_a06,arosoa_a07,arosoa_a08, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & hsoa_c,hsoa_o,bbsoa_c,bbsoa_o, & biog_v1,biog_v2,biog_v3,biog_v4, & - ant_v1,ant_v2,ant_v3,ant_v4, & - smpa_v1, & - smpbb_v1, & - asmpsoa_a01,asmpsoa_a02,asmpsoa_a03,asmpsoa_a04 + ant_v1,ant_v2,ant_v3,ant_v4, & + smpa_v1, & + smpbb_v1, & + asmpsoa_a01,asmpsoa_a02,asmpsoa_a03,asmpsoa_a04, &!BSINGH - Not adding 5-8 bins for asmpsoa, as it is not req. for 8 bin SAPRC + !BSINGH - Added cw aerosols(for VBS) + hoa_cw01, hoa_cw02, hoa_cw03, hoa_cw04, & + hoa_cw05, hoa_cw06, hoa_cw07, hoa_cw08, & + bboa_cw01, bboa_cw02, bboa_cw03, bboa_cw04, & + bboa_cw05, bboa_cw06, bboa_cw07, bboa_cw08, & + soa_cw01, soa_cw02, soa_cw03, soa_cw04, & + soa_cw05, soa_cw06, soa_cw07, soa_cw08, & + bbsoa_cw01, bbsoa_cw02, bbsoa_cw03, bbsoa_cw04, & + bbsoa_cw05, bbsoa_cw06, bbsoa_cw07, bbsoa_cw08, & + biog_cw01, biog_cw02, biog_cw03, biog_cw04, & + biog_cw05, biog_cw06, biog_cw07, biog_cw08, & + hsoa_cw01, hsoa_cw02, hsoa_cw03, hsoa_cw04, & + hsoa_cw05, hsoa_cw06, hsoa_cw07, hsoa_cw08, & + arosoa_cw01, arosoa_cw02, arosoa_cw03, arosoa_cw04, & + arosoa_cw05, arosoa_cw06, arosoa_cw07, arosoa_cw08, & + totoa_cw01, totoa_cw02, totoa_cw03, totoa_cw04, & + totoa_cw05, totoa_cw06, totoa_cw07, totoa_cw08, & + hsoa_cw_c, hsoa_cw_o, bbsoa_cw_c, bbsoa_cw_o, & + biog_cw_v1, & + ant_cw_v1 + !BSINGH -ENDS TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags @@ -381,16 +466,15 @@ SUBROUTINE sum_pm_driver ( config_flags, & ! sum_pm_select: SELECT CASE(config_flags%chem_opt) - CASE (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2_KPP,GOCARTRADM2,MOZCART_KPP) + CASE (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2,MOZCART_KPP) CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_gocart') CALL sum_pm_gocart ( & alt, chem,pm2_5_dry, pm2_5_dry_ec, pm10, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RACMSORG_AQ,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RADM2SORG_KPP, & - RACMSORG_KPP,RACM_ESRLSORG_KPP,CBMZSORG,CBMZSORG_AQ) + RACMSORG_KPP,RACM_ESRLSORG_KPP,CBMZSORG,CBMZSORG_AQ,CB05_SORG_AQ_KPP) CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_sorgam') CALL sum_pm_sorgam ( & alt, chem, h2oaj, h2oai, & @@ -398,6 +482,15 @@ SUBROUTINE sum_pm_driver ( config_flags, & config_flags%dust_opt,ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE (CB05_SORG_VBS_AQ_KPP) + CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_sorgam_vbs') + CALL sum_pm_sorgam_vbs ( & + alt, chem, h2oaj, h2oai, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + tsoa,asoa,bsoa, & + config_flags%dust_opt,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) CASE (RACM_SOA_VBS_KPP) CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_soa_vbs') @@ -419,7 +512,7 @@ SUBROUTINE sum_pm_driver ( config_flags, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (CBMZ_MOSAIC_4BIN_VBS2_KPP, SAPRC99_MOSAIC_4BIN_VBS2_KPP) + CASE (SAPRC99_MOSAIC_4BIN_VBS2_KPP) CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_mosaic_vbs2') call sum_pm_mosaic_vbs2 ( & @@ -433,13 +526,21 @@ SUBROUTINE sum_pm_driver ( config_flags, & call sum_vbs2 ( & alt, chem, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & + hoa_a05,hoa_a06,hoa_a07,hoa_a08, & bboa_a01,bboa_a02,bboa_a03,bboa_a04, & + bboa_a05,bboa_a06,bboa_a07,bboa_a08, & soa_a01,soa_a02,soa_a03,soa_a04, & + soa_a05,soa_a06,soa_a07,soa_a08, & bbsoa_a01,bbsoa_a02,bbsoa_a03,bbsoa_a04, & + bbsoa_a05,bbsoa_a06,bbsoa_a07,bbsoa_a08, & hsoa_a01,hsoa_a02,hsoa_a03,hsoa_a04, & + hsoa_a05,hsoa_a06,hsoa_a07,hsoa_a08, & biog_a01,biog_a02,biog_a03,biog_a04, & + biog_a05,biog_a06,biog_a07,biog_a08, & arosoa_a01,arosoa_a02,arosoa_a03,arosoa_a04, & + arosoa_a05,arosoa_a06,arosoa_a07,arosoa_a08, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & hsoa_c,hsoa_o,bbsoa_c,bbsoa_o, & biog_v1,biog_v2,biog_v3,biog_v4, & ant_v1,ant_v2,ant_v3,ant_v4, & @@ -447,7 +548,7 @@ SUBROUTINE sum_pm_driver ( config_flags, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (MOZART_MOSAIC_4BIN_VBS0_KPP) + CASE (MOZART_MOSAIC_4BIN_KPP) CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_mosaic_vbs0') call sum_pm_mosaic_vbs0 ( & @@ -475,6 +576,85 @@ SUBROUTINE sum_pm_driver ( config_flags, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE (MOZART_MOSAIC_4BIN_AQ_KPP) + + CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_mosaic_vbs4') + call sum_pm_mosaic_vbs4 ( & + alt, chem, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CALL wrf_debug(15,'sum_pm_driver: calling sum_vbs4') + call sum_vbs4 ( & + alt, chem, & + hoa_a01,hoa_a02,hoa_a03,hoa_a04, & + soa_a01,soa_a02,soa_a03,soa_a04, & + biog_a01,biog_a02,biog_a03,biog_a04, & + totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + biog_v1,biog_v2,biog_v3,biog_v4, & + ant_v1,ant_v2,ant_v3,ant_v4, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + !BSINGH - Added for 8 bin SAPRC VBS 2 and non-aq on (04/07/2014) + CASE (SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_KPP) + + CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_mosaic_vbs2') + call sum_pm_mosaic_vbs2 ( & + alt, chem, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + CALL wrf_debug(15,'sum_pm_driver: calling sum_vbs2') + call sum_vbs2 ( & + alt, chem, & + hoa_a01,hoa_a02,hoa_a03,hoa_a04, & + hoa_a05,hoa_a06,hoa_a07,hoa_a08, & + bboa_a01,bboa_a02,bboa_a03,bboa_a04, & + bboa_a05,bboa_a06,bboa_a07,bboa_a08, & + soa_a01,soa_a02,soa_a03,soa_a04, & + soa_a05,soa_a06,soa_a07,soa_a08, & + bbsoa_a01,bbsoa_a02,bbsoa_a03,bbsoa_a04, & + bbsoa_a05,bbsoa_a06,bbsoa_a07,bbsoa_a08, & + hsoa_a01,hsoa_a02,hsoa_a03,hsoa_a04, & + hsoa_a05,hsoa_a06,hsoa_a07,hsoa_a08, & + biog_a01,biog_a02,biog_a03,biog_a04, & + biog_a05,biog_a06,biog_a07,biog_a08, & + arosoa_a01,arosoa_a02,arosoa_a03,arosoa_a04, & + arosoa_a05,arosoa_a06,arosoa_a07,arosoa_a08, & + totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & + hsoa_c,hsoa_o,bbsoa_c,bbsoa_o, & + biog_v1,biog_v2,biog_v3,biog_v4, & + ant_v1,ant_v2,ant_v3,ant_v4, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + + + CALL wrf_debug(15,'sum_pm_driver: calling sum_aq_vbs2') + call sum_aq_vbs2 ( & + alt, chem, & + hoa_cw01,hoa_cw02,hoa_cw03,hoa_cw04,hoa_cw05,hoa_cw06,hoa_cw07,hoa_cw08, & + bboa_cw01,bboa_cw02,bboa_cw03,bboa_cw04,bboa_cw05,bboa_cw06,bboa_cw07,bboa_cw08, & + soa_cw01,soa_cw02,soa_cw03,soa_cw04,soa_cw05,soa_cw06,soa_cw07,soa_cw08, & + bbsoa_cw01,bbsoa_cw02,bbsoa_cw03,bbsoa_cw04,bbsoa_cw05,bbsoa_cw06,bbsoa_cw07,bbsoa_cw08, & + hsoa_cw01,hsoa_cw02,hsoa_cw03,hsoa_cw04,hsoa_cw05,hsoa_cw06,hsoa_cw07,hsoa_cw08, & + biog_cw01,biog_cw02,biog_cw03,biog_cw04,biog_cw05,biog_cw06,biog_cw07,biog_cw08, & + arosoa_cw01,arosoa_cw02,arosoa_cw03,arosoa_cw04,arosoa_cw05,arosoa_cw06,arosoa_cw07,arosoa_cw08, & + totoa_cw01,totoa_cw02,totoa_cw03,totoa_cw04,totoa_cw05,totoa_cw06,totoa_cw07,totoa_cw08, & + hsoa_cw_c,hsoa_cw_o,bbsoa_cw_c,bbsoa_cw_o, & + biog_cw_v1, & + ant_cw_v1, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + !BSINGH -ENDS CASE DEFAULT diff --git a/wrfv2_fire/chem/chem_driver.F b/wrfv2_fire/chem/chem_driver.F index 3c963b05..60b8c43f 100755 --- a/wrfv2_fire/chem/chem_driver.F +++ b/wrfv2_fire/chem/chem_driver.F @@ -3,6 +3,7 @@ ! Further developments, bugfixes and improvements by ! William Gustafson (PNNL), Marc Salzmann (GFDL), and Georg Grell ! 10/12/2011 - Ravan Ahmadov (NOAA) updated to include the RACM_SOA_VBS option +! 10/08/2014 - Kai Wang and Yang Zhang (NCSU) updated to include the CB05_MADE/SORGAM and CB05_MADE/VBS options ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine chem_driver ( grid , config_flags & @@ -33,6 +34,7 @@ subroutine chem_driver ( grid , config_flags & USE module_ctrans_grell USE module_data_soa_vbs, only: ldrog_vbs USE module_dust_load + USE module_chem_cup, only: chem_cup_driver !BSINGH - For WRFCuP scheme USE module_dry_dep_driver USE module_emissions_driver USE module_input_tracer, only: set_tracer @@ -56,25 +58,55 @@ subroutine chem_driver ( grid , config_flags & !BSINGH(PNNL)- Lahey compiler forces to declare the following interface interface - SUBROUTINE sum_pm_driver ( config_flags, & - alt, chem, h2oaj, h2oai, & - pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + SUBROUTINE sum_pm_driver ( config_flags, & + alt, chem, h2oaj, h2oai, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + tsoa,asoa,bsoa, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & + hoa_a05,hoa_a06,hoa_a07,hoa_a08, & !BSINGH Added 4 more bins for each species for SAPRC 8 bin version bboa_a01,bboa_a02,bboa_a03,bboa_a04, & + bboa_a05,bboa_a06,bboa_a07,bboa_a08, & soa_a01,soa_a02,soa_a03,soa_a04, & + soa_a05,soa_a06,soa_a07,soa_a08, & bbsoa_a01,bbsoa_a02,bbsoa_a03,bbsoa_a04, & + bbsoa_a05,bbsoa_a06,bbsoa_a07,bbsoa_a08, & hsoa_a01,hsoa_a02,hsoa_a03,hsoa_a04, & + hsoa_a05,hsoa_a06,hsoa_a07,hsoa_a08, & biog_a01,biog_a02,biog_a03,biog_a04, & - asmpsoa_a01,asmpsoa_a02,asmpsoa_a03,asmpsoa_a04, & + biog_a05,biog_a06,biog_a07,biog_a08, & + asmpsoa_a01,asmpsoa_a02,asmpsoa_a03,asmpsoa_a04, & arosoa_a01,arosoa_a02,arosoa_a03,arosoa_a04, & + arosoa_a05,arosoa_a06,arosoa_a07,arosoa_a08, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & hsoa_c,hsoa_o,bbsoa_c,bbsoa_o, & biog_v1,biog_v2,biog_v3,biog_v4, & ant_v1,ant_v2,ant_v3,ant_v4, & - smpa_v1,smpbb_v1, & + smpa_v1,smpbb_v1, & + !BSINGH - Added cw aerosols(for VBS) + hoa_cw01, hoa_cw02, hoa_cw03, hoa_cw04, & + hoa_cw05, hoa_cw06, hoa_cw07, hoa_cw08, & + bboa_cw01, bboa_cw02, bboa_cw03, bboa_cw04, & + bboa_cw05, bboa_cw06, bboa_cw07, bboa_cw08, & + soa_cw01, soa_cw02, soa_cw03, soa_cw04, & + soa_cw05, soa_cw06, soa_cw07, soa_cw08, & + bbsoa_cw01, bbsoa_cw02, bbsoa_cw03, bbsoa_cw04, & + bbsoa_cw05, bbsoa_cw06, bbsoa_cw07, bbsoa_cw08, & + biog_cw01, biog_cw02, biog_cw03, biog_cw04, & + biog_cw05, biog_cw06, biog_cw07, biog_cw08, & + hsoa_cw01, hsoa_cw02, hsoa_cw03, hsoa_cw04, & + hsoa_cw05, hsoa_cw06, hsoa_cw07, hsoa_cw08, & + arosoa_cw01, arosoa_cw02, arosoa_cw03, arosoa_cw04, & + arosoa_cw05, arosoa_cw06, arosoa_cw07, arosoa_cw08, & + totoa_cw01, totoa_cw02, totoa_cw03, totoa_cw04, & + totoa_cw05, totoa_cw06, totoa_cw07, totoa_cw08, & + hsoa_cw_c, hsoa_cw_o, bbsoa_cw_c, bbsoa_cw_o, & + biog_cw_v1, & + ant_cw_v1, & + !BSINGH -ENDS ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte ) USE module_configure @@ -82,6 +114,7 @@ SUBROUTINE sum_pm_driver ( config_flags, & USE module_mosaic_driver, only: sum_pm_mosaic,sum_pm_mosaic_vbs2,sum_pm_mosaic_vbs0,sum_vbs9,sum_vbs2,sum_vbs0 USE module_gocart_aerosols, only: sum_pm_gocart USE module_aerosols_soa_vbs, only: sum_pm_soa_vbs + USE module_aerosols_sorgam_vbs, only: sum_pm_sorgam_vbs IMPLICIT NONE @@ -99,23 +132,53 @@ SUBROUTINE sum_pm_driver ( config_flags, & OPTIONAL, & INTENT(IN ) :: h2oaj,h2oai - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - OPTIONAL, & - INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10, & + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + OPTIONAL, & + INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10, & + tsoa,asoa,bsoa, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & + hoa_a05,hoa_a06,hoa_a07,hoa_a08, &!BSINGH Added 4 more bins for each species for SAPRC 8 bin version bboa_a01,bboa_a02,bboa_a03,bboa_a04, & + bboa_a05,bboa_a06,bboa_a07,bboa_a08, & soa_a01,soa_a02,soa_a03,soa_a04, & + soa_a05,soa_a06,soa_a07,soa_a08, & bbsoa_a01,bbsoa_a02,bbsoa_a03,bbsoa_a04, & + bbsoa_a05,bbsoa_a06,bbsoa_a07,bbsoa_a08, & hsoa_a01,hsoa_a02,hsoa_a03,hsoa_a04, & + hsoa_a05,hsoa_a06,hsoa_a07,hsoa_a08, & biog_a01,biog_a02,biog_a03,biog_a04, & + biog_a05,biog_a06,biog_a07,biog_a08, & arosoa_a01,arosoa_a02,arosoa_a03,arosoa_a04, & + arosoa_a05,arosoa_a06,arosoa_a07,arosoa_a08, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & hsoa_c,hsoa_o,bbsoa_c,bbsoa_o, & biog_v1,biog_v2,biog_v3,biog_v4, & - ant_v1,ant_v2,ant_v3,ant_v4, & - smpa_v1, & - smpbb_v1, & - asmpsoa_a01,asmpsoa_a02,asmpsoa_a03,asmpsoa_a04 + ant_v1,ant_v2,ant_v3,ant_v4, & + smpa_v1, & + smpbb_v1, & + asmpsoa_a01,asmpsoa_a02,asmpsoa_a03,asmpsoa_a04, &!BSINGH - Not adding 5-8 bins for asmpsoa, as it is not req. for 8 bin SAPRC + !BSINGH - Added cw aerosols(for VBS) + hoa_cw01, hoa_cw02, hoa_cw03, hoa_cw04, & + hoa_cw05, hoa_cw06, hoa_cw07, hoa_cw08, & + bboa_cw01, bboa_cw02, bboa_cw03, bboa_cw04, & + bboa_cw05, bboa_cw06, bboa_cw07, bboa_cw08, & + soa_cw01, soa_cw02, soa_cw03, soa_cw04, & + soa_cw05, soa_cw06, soa_cw07, soa_cw08, & + bbsoa_cw01, bbsoa_cw02, bbsoa_cw03, bbsoa_cw04, & + bbsoa_cw05, bbsoa_cw06, bbsoa_cw07, bbsoa_cw08, & + biog_cw01, biog_cw02, biog_cw03, biog_cw04, & + biog_cw05, biog_cw06, biog_cw07, biog_cw08, & + hsoa_cw01, hsoa_cw02, hsoa_cw03, hsoa_cw04, & + hsoa_cw05, hsoa_cw06, hsoa_cw07, hsoa_cw08, & + arosoa_cw01, arosoa_cw02, arosoa_cw03, arosoa_cw04, & + arosoa_cw05, arosoa_cw06, arosoa_cw07, arosoa_cw08, & + totoa_cw01, totoa_cw02, totoa_cw03, totoa_cw04, & + totoa_cw05, totoa_cw06, totoa_cw07, totoa_cw08, & + hsoa_cw_c, hsoa_cw_o, bbsoa_cw_c, bbsoa_cw_o, & + biog_cw_v1, & + ant_cw_v1 + !BSINGH -ENDS TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags @@ -418,25 +481,29 @@ end SUBROUTINE sum_pm_driver CASE (GOCARTRACM_KPP) CALL wrf_debug(15,'calling gocart and racm driver from chem_driver') haveaer = .false. - CASE (GOCARTRADM2_KPP) - CALL wrf_debug(15,'calling gocart and radmkpp driver from chem_driver') - haveaer = .false. CASE (GOCARTRADM2) CALL wrf_debug(15,'calling gocart and radm driver from chem_driver') haveaer = .false. CASE (SAPRC99_KPP) CALL wrf_debug(15,'calling saprc99_kpp from chem_driver') haveaer = .false. - CASE (CBMZ_MOSAIC_4BIN_VBS2_KPP) - CALL wrf_debug(15,'calling cbmz_mosaic_4bin_vbs2_kpp from chem_driver') - haveaer = .false. CASE (SAPRC99_MOSAIC_4BIN_VBS2_KPP) CALL wrf_debug(15,'calling saprc99_mosaic_4bin_vbs2_kpp from chem_driver') haveaer = .false. - CASE (MOZART_MOSAIC_4BIN_VBS0_KPP) - CALL wrf_debug(15,'calling mozart_mosaic_4bin_vbs0_kpp from chem_driver') + CASE (MOZART_MOSAIC_4BIN_KPP) + CALL wrf_debug(15,'calling mozart_mosaic_4bin_kpp from chem_driver') haveaer = .true. - + CASE (MOZART_MOSAIC_4BIN_AQ_KPP) + CALL wrf_debug(15,'calling mozart_mosaic_4bin_aq_kpp from chem_driver') + haveaer = .true. + !BSINGH - Added case statement for SAPRC 8 bin + CASE (SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP) + CALL wrf_debug(15,'calling saprc99_mosaic_8bin_vbs2_aq_kpp from chem_driver') + haveaer = .false. + CASE (SAPRC99_MOSAIC_8BIN_VBS2_KPP) !BSINGH(04/04/2014) + CALL wrf_debug(15,'calling saprc99_mosaic_8bin_vbs2_kpp from chem_driver') + haveaer = .false. + !BSINGH - ENDS CASE (CBMZSORG) CALL wrf_debug(15,'calling cbmzsorg aerosols from chem_driver') haveaer = .true. @@ -489,6 +556,12 @@ end SUBROUTINE sum_pm_driver CALL wrf_debug(15,'calling mozart driver from chem_driver') CASE (MOZCART_KPP) CALL wrf_debug(15,'calling mozcart driver from chem_driver') + CASE (CB05_SORG_AQ_KPP) + CALL wrf_debug(15,'calling cb05_sorg_aq_kpp from chem_driver') + haveaer = .true. + CASE (CB05_SORG_VBS_AQ_KPP) + CALL wrf_debug(15,'calling cb05_sorg_vbs_aq_kpp from chem_driver') + haveaer = .true. CASE (CHEM_TRACER,CHEM_TRACE2) CALL wrf_debug(15,'tracer mode: only doing emissions and dry dep in chem_driver') CASE (CHEM_VOLC) @@ -567,7 +640,8 @@ end SUBROUTINE sum_pm_driver enddo ! Special treatment of CH4 in SAPRC99 - case (CBMZ_MOSAIC_4BIN_VBS2_KPP, SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP) + case (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_KPP) !BSINGH - Added for SAPRC 8 bin and non-aq on (04/04/2014) CALL wrf_debug ( 15 , ' fixing ch4 conc using co conc' ) do j=jps,jpe do k=kps,kpe @@ -605,7 +679,8 @@ end SUBROUTINE sum_pm_driver !------------------------------------------------------------------------ if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then if( config_flags%phot_opt == FTUV ) then CALL ftuv_timestep_init( grid%id, grid%julday ) endif @@ -659,7 +734,8 @@ end SUBROUTINE sum_pm_driver !--- emissions - if(config_flags%emiss_inpt_opt > 0 .or. config_flags%dust_opt > 0)then + if(config_flags%emiss_inpt_opt > 0 .or. config_flags%dust_opt > 0 & + .or. config_flags%tracer_opt > 0 )then call wrf_debug(15,'calling emissions driver') call emissions_driver(grid%id,ktau,grid%dt,grid%DX, & @@ -669,8 +745,10 @@ end SUBROUTINE sum_pm_driver config_flags, & grid%gmt,ijulian,rri,t_phy,moist,p8w,t8w,u_phy,v_phy,vvel, & grid%e_bio,p_phy,chem,rho,dz8w,grid%ne_area,emis_ant,emis_vol,grid%tsk, & - grid%erod,g,emis_seas,emis_dust,tracer, & - ebu , ebu_in,grid%mean_fct_agtf,grid%mean_fct_agef,grid%mean_fct_agsv, & + grid%erod,grid%erod_dri,grid%lai_vegmask, & + g,emis_seas,emis_dust,tracer, & + emis_seas2, & + ebu, ebu_in,grid%mean_fct_agtf,grid%mean_fct_agef,grid%mean_fct_agsv, & grid%mean_fct_aggr,grid%firesize_agtf, & grid%firesize_agef,grid%firesize_agsv,grid%firesize_aggr, & grid%u10,grid%v10,grid%ivgtyp,grid%isltyp,grid%gsw,grid%vegfra,grid%rmol, & @@ -686,7 +764,7 @@ end SUBROUTINE sum_pm_driver grid%ebio_iso,grid%ebio_oli,grid%ebio_api,grid%ebio_lim,grid%ebio_xyl, & grid%ebio_hc3,grid%ebio_ete,grid%ebio_olt,grid%ebio_ket,grid%ebio_ald, & grid%ebio_hcho,grid%ebio_eth,grid%ebio_ora2,grid%ebio_co,grid%ebio_nr, & - grid%ebio_no,grid%ebio_sesq,grid%ebio_mbo, & + grid%ebio_no,grid%ebio_sesq,grid%ebio_mbo,grid%ebio_bpi,grid%ebio_myrc, & grid%ebio_c10h16,grid%ebio_tol,grid%ebio_bigalk, & grid%ebio_ch3oh,grid%ebio_acet,grid%ebio_nh3,grid%ebio_no2, & grid%ebio_c2h5oh,grid%ebio_ch3cooh,grid%ebio_mek,grid%ebio_bigene, & @@ -696,8 +774,10 @@ end SUBROUTINE sum_pm_driver grid%ebio_aro1, grid%ebio_aro2, grid%ebio_ccho, grid%ebio_meoh, & grid%ebio_ethene, grid%ebio_hcooh, grid%ebio_terp, grid%ebio_bald, & grid%ebio_cco_oh, grid%ebio_rco_oh, & - grid%clayfrac,grid%sandfrac,grid%dust_alpha,grid%dust_gamma,grid%dust_smtune,& - grid%snowh,grid%zs, & + grid%clayfrac,grid%sandfrac,grid%dust_alpha,grid%dust_gamma,grid%dust_smtune, grid%dust_ustune, & + grid%clayfrac_nga,grid%sandfrac_nga, & + grid%snowh,grid%zs,grid%afwa_dustloft, & + grid%tot_dust,grid%tot_edust,grid%vis_dust, & grid%soilctop, grid%ust_t, grid%rough_cor, grid%smois_cor, & grid%ebio_c5h8,grid%ebio_apinene,grid%ebio_bpinene,grid%ebio_toluene, & grid%ebio_ch3cho,grid%ebio_ch3co2h,grid%ebio_tbut2ene, & @@ -723,13 +803,14 @@ end SUBROUTINE sum_pm_driver grid%potevp,grid%SFCEVP,grid%LU_INDEX, & grid%biomt_par,grid%emit_par,grid%ebio_co2oce, & eghg_bio, & - + grid%dust_flux, grid%seas_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite,jts,jte,kts,kte) if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then call mozcart_lbc_set( chem, num_chem, grid%id, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts ) @@ -774,6 +855,7 @@ end SUBROUTINE sum_pm_driver grid%bscoef1,grid%bscoef2,grid%bscoef3,grid%bscoef4, & grid%l2aer,grid%l3aer,grid%l4aer,grid%l5aer,grid%l6aer,grid%l7aer, & grid%totoa_a01,grid%totoa_a02,grid%totoa_a03,grid%totoa_a04, & + grid%totoa_a05,grid%totoa_a06,grid%totoa_a07,grid%totoa_a08, & grid%extaerlw1,grid%extaerlw2,grid%extaerlw3,grid%extaerlw4,grid%extaerlw5, & grid%extaerlw6,grid%extaerlw7,grid%extaerlw8,grid%extaerlw9,grid%extaerlw10, & grid%extaerlw11,grid%extaerlw12,grid%extaerlw13,grid%extaerlw14,grid%extaerlw15, & @@ -817,6 +899,7 @@ end SUBROUTINE sum_pm_driver grid%ph_acetp,grid%ph_xooh,grid%ph_isooh,grid%ph_alkooh, & grid%ph_mekooh,grid%ph_tolooh,grid%ph_terpooh,grid%ph_mvk, & grid%ph_glyald,grid%ph_hyac, & + grid%ph_cl2,grid%ph_hocl,grid%ph_fmcl, & config_flags%track_tuv_lev, & config_flags%track_rad_num, & config_flags%track_tuv_num, & @@ -888,6 +971,7 @@ end SUBROUTINE sum_pm_driver grid%h2oaj,grid%h2oai,grid%nu3,grid%ac3,grid%cor3,grid%asulf, & grid%ahno3,grid%anh3,grid%cvaro1,grid%cvaro2,grid%cvalk1,grid%cvole1,& grid%cvapi1,grid%cvapi2,grid%cvlim1,grid%cvlim2,grid%dep_vel_o3, & + grid%ddlen,grid%ddflx, & emis_ant,ebu_in, & config_flags%sf_urban_physics,numgas,current_month,dvel,grid%snowh, & grid%dustdrydep_1,grid%dustdrydep_2,grid%dustdrydep_3, & @@ -905,7 +989,8 @@ end SUBROUTINE sum_pm_driver if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then call mozcart_lbc_set( chem, num_chem, grid%id, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts ) @@ -949,7 +1034,8 @@ end SUBROUTINE sum_pm_driver ! convective transport/wet deposition ! ! - if( config_flags%cu_physics>0 .and. config_flags%chem_conv_tr>0)then + if( config_flags%cu_physics>0 .and. config_flags%chem_conv_tr>0 & + .and. config_flags%cu_physics/=kfcupscheme ) then !BSINGH - For WRFCuP scheme call wrf_debug(15,'calling conv transport for chemical species') if(config_flags%chem_opt >0 )then ! save old concentrations for convective tendencies @@ -962,6 +1048,9 @@ end SUBROUTINE sum_pm_driver p_phy,XLV,CP,G,r_v, & z_at_w,grid%cu_co_ten, & grid%wd_no3_cu,grid%wd_so4_cu, & + grid%wd_nh4_cu,grid%wd_oa_cu, & + grid%wd_so2_cu, grid%wd_sulf_cu, grid%wd_hno3_cu, grid%wd_nh3_cu, & + grid%wd_cvasoa_cu, grid%wd_cvbsoa_cu, grid%wd_asoa_cu, grid%wd_bsoa_cu, & grid%k22_shallow,grid%kbcon_shallow,grid%ktop_shallow,grid%xmb_shallow, & config_flags%ishallow,num_moist,numgas,num_chem,config_flags%chem_opt,0, & config_flags%conv_tr_wetscav,config_flags%conv_tr_aqchem, & @@ -970,7 +1059,8 @@ end SUBROUTINE sum_pm_driver its,ite,jts,jte,kts,k_end) if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then call mozcart_lbc_set( chem, num_chem, grid%id, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts ) @@ -990,6 +1080,9 @@ end SUBROUTINE sum_pm_driver p_phy,XLV,CP,G,r_v, & z_at_w, grid%cu_co_ten, & grid%wd_no3_cu,grid%wd_so4_cu, & + grid%wd_nh4_cu,grid%wd_oa_cu, & + grid%wd_so2_cu, grid%wd_sulf_cu, grid%wd_hno3_cu, grid%wd_nh3_cu, & + grid%wd_cvasoa_cu, grid%wd_cvbsoa_cu, grid%wd_asoa_cu, grid%wd_bsoa_cu, & grid%k22_shallow,grid%kbcon_shallow,grid%ktop_shallow,grid%xmb_shallow, & config_flags%ishallow,num_moist,0,num_tracer,0,config_flags%tracer_opt, & config_flags%conv_tr_wetscav,config_flags%conv_tr_aqchem, & @@ -1058,10 +1151,10 @@ end SUBROUTINE sum_pm_driver its,ite,jts,jte,kts,kte ) ! -#ifdef WRF_KPP +#if ( WRF_KPP == 1 ) - if( config_flags%chem_opt == CBMZ_MOSAIC_4BIN_VBS2_KPP .or. & - config_flags%chem_opt == SAPRC99_MOSAIC_4BIN_VBS2_KPP ) then + if( config_flags%chem_opt == SAPRC99_MOSAIC_4BIN_VBS2_KPP.or. & + config_flags%chem_opt ==SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP ) then do k=kts,kte do i=its,ite do j=jts,jte @@ -1087,7 +1180,8 @@ end SUBROUTINE sum_pm_driver its,ite,jts,jte,kts,kte) if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then call mozcart_lbc_set( chem, num_chem, grid%id, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts ) @@ -1126,6 +1220,40 @@ end SUBROUTINE sum_pm_driver END SELECT so2so4_selectb ENDIF +#else + if(config_flags%chem_opt == 301 ) then + chem(its:ite,kts:kte,jts:jte,p_sulf)=vcsulf_old(its:ite,kts:kte,jts:jte) + chem(its:ite,kts:kte,jts:jte,p_so2)=vcso2_old(its:ite,kts:kte,jts:jte) +! chem(its:ite,kts:kte,jts:jte,p_h2o2)=vch2o2_old(its:ite,kts:kte,jts:jte) + endif + + IF(config_flags%conv_tr_aqchem == 0 ) THEN + so2so4_selectc: SELECT CASE(config_flags%chem_opt) + CASE (RADM2SORG) + CALL wrf_debug(15,'gocart so2-so4 conversion') + CALL so2so4(0,chem,p_so2,p_sulf,p_h2o2,p_QC,T_PHY,MOIST, & + grid%qc_cu, grid%gd_cldfr, & + NUM_CHEM,NUM_MOIST, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE DEFAULT + CALL wrf_debug(15,'no gocart so2-so4 conversion') + END SELECT so2so4_selectc + else IF(config_flags%conv_tr_aqchem == 1 ) THEN + so2so4_selectd: SELECT CASE(config_flags%chem_opt) + CASE (RADM2SORG) + CALL wrf_debug(15,'gocart so2-so4 conversion') + CALL so2so4(1,chem,p_so2,p_sulf,p_h2o2,p_QC,T_PHY,MOIST, & + grid%qc_cu, grid%gd_cldfr, & + NUM_CHEM,NUM_MOIST, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE DEFAULT + CALL wrf_debug(15,'no gocart so2-so4 conversion') + END SELECT so2so4_selectd + ENDIF ! #endif @@ -1197,6 +1325,71 @@ end SUBROUTINE sum_pm_driver its,ite, jts,jte, kts,kte ) endif + !BSINGH - For WRFCuP scheme + + ! + ! now do convective cloud processing for cup cumulus scheme + ! + ! issues for future work + ! convective cloud processing should be done at same place (in the code) + ! and same time frequency for cup and grell schemes, + ! but doing it here is ok for initial testing + ! there should be a "convchem_driver" or "ctrans_driver" routine + ! to interface to the various options + ! + if( config_flags%chem_conv_tr>0 .and. & + config_flags%cu_physics==kfcupscheme ) then + + call chem_cup_driver( & + grid%id, ktau, grid%ktauc, grid%dt, dtstepc, config_flags, & + t_phy, p_phy, rho, rri, dz8w, zmid, z_at_w, & +#if (NMM_CORE == 1) + moist_trans, grid%cldfra, grid%ph_no2, & +#endif +#if (EM_CORE == 1) + moist, grid%cldfra, grid%ph_no2, & +#endif + chem, grid%chem_cupflag, & + grid%cupflag, grid%shall, grid%tcloud_cup, grid%nca, grid%wact_cup, & + grid%cldfra_cup, grid%updfra_cup, grid%qc_ic_cup, grid%qc_iu_cup, & + grid%mfup_cup, grid%mfup_ent_cup, grid%mfdn_cup, grid%mfdn_ent_cup, & + grid%fcvt_qc_to_pr_cup, grid%fcvt_qc_to_qi_cup, grid%fcvt_qi_to_pr_cup, & + !BSINGH(12/03/2013): Commenting out *_ams_* variables and replacing them with + !*_ic_cup* variables + !grid%so4_a_ams_ic_cup, grid%so4_cw_ams_ic_cup, & + !grid%nh4_a_ams_ic_cup, grid%nh4_cw_ams_ic_cup, & + !grid%no3_a_ams_ic_cup, grid%no3_cw_ams_ic_cup, & + !grid%oa_a_ams_ic_cup, grid%oa_cw_ams_ic_cup, & + grid%co_a_ic_cup, grid%hno3_a_ic_cup, & + grid%so4_a_1to4_ic_cup, grid%so4_cw_1to4_ic_cup, & + grid%nh4_a_1to4_ic_cup, grid%nh4_cw_1to4_ic_cup, & + grid%no3_a_1to4_ic_cup, grid%no3_cw_1to4_ic_cup, & + grid%oa_a_1to4_ic_cup, grid%oa_cw_1to4_ic_cup, & + grid%oin_a_1to4_ic_cup, grid%oin_cw_1to4_ic_cup, & + grid%bc_a_1to4_ic_cup, grid%bc_cw_1to4_ic_cup, & + grid%na_a_1to4_ic_cup, grid%na_cw_1to4_ic_cup, & + grid%cl_a_1to4_ic_cup, grid%cl_cw_1to4_ic_cup, & + grid%water_1to4_ic_cup, & + grid%so4_a_5to6_ic_cup, grid%so4_cw_5to6_ic_cup, & + grid%nh4_a_5to6_ic_cup, grid%nh4_cw_5to6_ic_cup, & + grid%no3_a_5to6_ic_cup, grid%no3_cw_5to6_ic_cup, & + grid%oa_a_5to6_ic_cup, grid%oa_cw_5to6_ic_cup, & + grid%oin_a_5to6_ic_cup, grid%oin_cw_5to6_ic_cup, & + grid%bc_a_5to6_ic_cup, grid%bc_cw_5to6_ic_cup, & + grid%na_a_5to6_ic_cup, grid%na_cw_5to6_ic_cup, & + grid%cl_a_5to6_ic_cup, grid%cl_cw_5to6_ic_cup, & + grid%water_5to6_ic_cup, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + else + grid%chem_cupflag = 0 + endif + + + !BSINGH - Ends + ! @@ -1268,12 +1461,15 @@ end SUBROUTINE sum_pm_driver p_phy,chem,rho,grid%cldfra,grid%cldfra2, & grid%rainprod,grid%evapprod,grid%hno3_col_mdel, & grid%qlsink,grid%precr,grid%preci,grid%precs,grid%precg, & + grid%wdflx, & gas_aqfrac, numgas_mam,dz8w, & grid%h2oaj,grid%h2oai,grid%nu3,grid%ac3,grid%cor3, & grid%asulf,grid%ahno3,grid%anh3,grid%cvaro1,grid%cvaro2, & grid%cvalk1,grid%cvole1,grid%cvapi1,grid%cvapi2, & grid%cvlim1,grid%cvlim2, & - grid%wd_no3_sc,grid%wd_so4_sc, & + grid%wd_no3_sc, grid%wd_so4_sc, grid%wd_nh4_sc,grid%wd_oa_sc, & + grid%wd_so2_sc, grid%wd_sulf_sc, grid%wd_hno3_sc, grid%wd_nh3_sc, & + grid%wd_cvasoa_sc, grid%wd_cvbsoa_sc, grid%wd_asoa_sc, grid%wd_bsoa_sc, & grid%qv_b4mp, grid%qc_b4mp, grid%qi_b4mp, grid%qs_b4mp, & !====================================================================================== !Variables required for CAM_MAM_WETSCAV @@ -1340,22 +1536,52 @@ end SUBROUTINE sum_pm_driver call sum_pm_driver ( config_flags, & rri, chem, grid%h2oaj, grid%h2oai, & grid%pm2_5_dry, grid%pm2_5_water, grid%pm2_5_dry_ec, grid%pm10, & - grid% hoa_a01,grid%hoa_a02,grid%hoa_a03,grid%hoa_a04, & + grid%tsoa,grid%asoa,grid%bsoa, & + grid%hoa_a01,grid%hoa_a02,grid%hoa_a03,grid%hoa_a04, & + grid%hoa_a05, grid%hoa_a06, grid%hoa_a07, grid%hoa_a08, & !BSINGH(12/03/2013) Added 4 more bins for each species for SAPRC 8 bin version grid%bboa_a01,grid%bboa_a02,grid%bboa_a03,grid%bboa_a04, & + grid%bboa_a05, grid%bboa_a06, grid%bboa_a07, grid%bboa_a08, & grid%soa_a01,grid%soa_a02,grid%soa_a03,grid%soa_a04, & + grid%soa_a05, grid%soa_a06, grid%soa_a07, grid%soa_a08, & grid%bbsoa_a01,grid%bbsoa_a02,grid%bbsoa_a03,grid%bbsoa_a04, & + grid%bbsoa_a05, grid%bbsoa_a06, grid%bbsoa_a07, grid%bbsoa_a08, & grid%hsoa_a01,grid%hsoa_a02,grid%hsoa_a03,grid%hsoa_a04, & + grid%hsoa_a05, grid%hsoa_a06, grid%hsoa_a07, grid%hsoa_a08, & grid%biog_a01,grid%biog_a02,grid%biog_a03,grid%biog_a04, & + grid%biog_a05, grid%biog_a06, grid%biog_a07, grid%biog_a08, & grid%asmpsoa_a01,grid%asmpsoa_a02,grid%asmpsoa_a03,grid%asmpsoa_a04, & grid%arosoa_a01,grid%arosoa_a02,grid%arosoa_a03,grid%arosoa_a04, & + grid%arosoa_a05, grid%arosoa_a06, grid%arosoa_a07, grid%arosoa_a08, & grid%totoa_a01,grid%totoa_a02,grid%totoa_a03,grid%totoa_a04, & + grid%totoa_a05, grid%totoa_a06, grid%totoa_a07, grid%totoa_a08, & grid%hsoa_c,grid%hsoa_o,grid%bbsoa_c,grid%bbsoa_o, & grid%biog_v1,grid%biog_v2,grid%biog_v3,grid%biog_v4, & grid%ant_v1,grid%ant_v2,grid%ant_v3,grid%ant_v4, & grid%smpa_v1,grid%smpbb_v1, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + !BSINGH(12/03/2013) - Added cw aerosols(for VBS) + grid%hoa_cw01, grid%hoa_cw02, grid%hoa_cw03, grid%hoa_cw04, & + grid%hoa_cw05, grid%hoa_cw06, grid%hoa_cw07, grid%hoa_cw08, & + grid%bboa_cw01, grid%bboa_cw02, grid%bboa_cw03, grid%bboa_cw04, & + grid%bboa_cw05, grid%bboa_cw06, grid%bboa_cw07, grid%bboa_cw08, & + grid%soa_cw01, grid%soa_cw02, grid%soa_cw03, grid%soa_cw04, & + grid%soa_cw05, grid%soa_cw06, grid%soa_cw07, grid%soa_cw08, & + grid%bbsoa_cw01, grid%bbsoa_cw02, grid%bbsoa_cw03, grid%bbsoa_cw04, & + grid%bbsoa_cw05, grid%bbsoa_cw06, grid%bbsoa_cw07, grid%bbsoa_cw08, & + grid%biog_cw01, grid%biog_cw02, grid%biog_cw03, grid%biog_cw04, & + grid%biog_cw05, grid%biog_cw06, grid%biog_cw07, grid%biog_cw08, & + grid%hsoa_cw01, grid%hsoa_cw02, grid%hsoa_cw03, grid%hsoa_cw04, & + grid%hsoa_cw05, grid%hsoa_cw06, grid%hsoa_cw07, grid%hsoa_cw08, & + grid%arosoa_cw01, grid%arosoa_cw02, grid%arosoa_cw03, grid%arosoa_cw04, & + grid%arosoa_cw05, grid%arosoa_cw06, grid%arosoa_cw07, grid%arosoa_cw08, & + grid%totoa_cw01, grid%totoa_cw02, grid%totoa_cw03, grid%totoa_cw04, & + grid%totoa_cw05, grid%totoa_cw06, grid%totoa_cw07, grid%totoa_cw08, & + grid%hsoa_cw_c, grid%hsoa_cw_o, grid%bbsoa_cw_c, grid%bbsoa_cw_o, & + grid%biog_cw_v1, & + grid%ant_cw_v1, & + !BSINGH(12/03/2013) -ENDS + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) call dust_load_driver ( config_flags, & rri, chem, dz8w, grid%dustload_1, grid%dustload_2, grid%dustload_3, & diff --git a/wrfv2_fire/chem/chemics_init.F b/wrfv2_fire/chem/chemics_init.F index 77058bdc..249e5460 100755 --- a/wrfv2_fire/chem/chemics_init.F +++ b/wrfv2_fire/chem/chemics_init.F @@ -18,6 +18,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, dgnum4d, dgnumwet4d, dgnum_a1, dgnum_a2, dgnum_a3, & dgnumwet_a1, dgnumwet_a2, dgnumwet_a3, & pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & + tsoa,asoa,bsoa, & last_chem_time_year, last_chem_time_month, & last_chem_time_day, last_chem_time_hour, & last_chem_time_minute, last_chem_time_second, & @@ -35,6 +36,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, USE module_mozcart_wetscav, only : wetscav_mozcart_init USE module_aerosols_sorgam USE module_aerosols_soa_vbs, only: aerosols_soa_vbs_init + USE module_aerosols_sorgam_vbs, only: aerosols_sorgam_vbs_init USE module_dep_simple USE module_data_gocart_dust USE module_data_gocart_seas @@ -76,6 +78,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & INTENT(INOUT ) :: & pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & + tsoa,asoa,bsoa, & tauaer1,tauaer2,tauaer3,tauaer4, & extaerlw1,extaerlw2,extaerlw3,extaerlw4, & extaerlw5,extaerlw6,extaerlw7,extaerlw8, & @@ -151,8 +154,6 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, chem_select: SELECT CASE(config_flags%chem_opt) CASE (GOCART_SIMPLE) CALL wrf_debug(15,'calling only gocart aerosols driver from chem_driver') - CASE (GOCARTRADM2_KPP) - CALL wrf_debug(15,'calling gocart and radmkpp driver from chem_driver') CASE (GOCARTRADM2) CALL wrf_debug(15,'calling gocart and radm driver from chem_driver') CASE (GOCARTRACM_KPP) @@ -176,14 +177,19 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, CALL wrf_debug(15,'calling SAPRC99_MOSAIC_4BIN_VBS2_4BIN from chem_driver') call wrf_message("WARNING: SAPRC99_MOSAIC_4BIN_VBS2_4BIN chemistry option is highly experimental and not recommended for use.") !jdf call wrf_error_fatal("WARNING: SAPRC99_MOSAIC_4BIN_VBS2_4BIN chemistry option is useable but does not fully pass regtesting. It is recommended that you contact Jerome.Fast@pnl.gov for information regarding this option.") - CASE (CBMZ_MOSAIC_4BIN_VBS2_KPP ) - CALL wrf_debug(15,'calling CBMZ_MOSAIC_4BIN_VBS2_4BIN from chem_driver') - call wrf_message("WARNING: CBMZ_MOSAIC_4BIN_VBS2_4BIN chemistry option is highly experimental and not recommended for use.") -!jdf call wrf_error_fatal("WARNING: CBMZ_MOSAIC_4BIN_VBS2_4BIN chemistry option is useable but does not fully pass regtesting. It is recommended that you contact Jerome.Fast@pnl.gov for information regarding this option.") - CASE (MOZART_MOSAIC_4BIN_VBS0_KPP ) - CALL wrf_debug(15,'calling MOZART_MOSAIC_4BIN_VBS0_KPP from chem_driver') - call wrf_message("WARNING: MOZART_MOSAIC_4BIN_VBS0_KPP chemistry option is highly experimental and not recommended for use.") - !! call wrf_error_fatal("WARNING: MOZART_MOSAIC_4BIN_VBS0_KPP chemistry option is useable but does not fully pass regtestint.????") + !BSINGH(04/03/2014): Added SAPRC 8 bin non-aq + CASE (SAPRC99_MOSAIC_8BIN_VBS2_KPP ) + CALL wrf_debug(15,'calling SAPRC99_MOSAIC_8BIN_VBS2_4BIN from chem_driver') + call wrf_message("WARNING: SAPRC99_MOSAIC_8BIN_VBS2_4BIN chemistry option is highly experimental and not recommended for use.") + !BSINGH(12/03/2013): Added SAPRC 8 bin aq + CASE (SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP ) + CALL wrf_debug(15,'calling SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP from chem_driver') + call wrf_message("WARNING: SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP chemistry option is highly experimental and not recommended for use.") + !BSINGH -ENDS + CASE (MOZART_MOSAIC_4BIN_KPP ) + CALL wrf_debug(15,'calling MOZART_MOSAIC_4BIN_KPP from chem_driver') + CASE (MOZART_MOSAIC_4BIN_AQ_KPP ) + CALL wrf_debug(15,'calling MOZART_MOSAIC_4BIN_AQ_KPP from chem_driver') CASE (RADM2SORG_AQ ) CALL wrf_debug(15,'calling RADM2/MADE/SORGAM with AQ chemistry from chem_driver') call wrf_message("WARNING: RADM2SORG_AQ chemistry option is experimental and not yet fully tested.") @@ -226,7 +232,12 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, CALL wrf_debug(15,'calling CBMZ_CAM_MAM7_AQ with AQCHEM chemistry from chem_driver') call wrf_message("WARNING: CBMZ_CAM_MAM7_AQ chemistry option is highly experimental and not recommended for use.") call wrf_error_fatal("ERROR: It is recommended that you contact phil.rasch at pnnl.gov for information regarding this option") - + CASE(CB05_SORG_AQ_KPP) + numgas_mam = numgas + CALL wrf_debug(15,'calling CB05_SORG_AQ_KPP chemistry from chem_driver') + CASE(CB05_SORG_VBS_AQ_KPP) + numgas_mam = numgas + CALL wrf_debug(15,'calling CB05_SORG_VBS_AQ_KPP chemistry from chem_driver') END SELECT chem_select if ( config_flags%dust_opt == 1 ) then @@ -247,7 +258,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if( config_flags%chem_opt == MOZCART_KPP .or. & config_flags%chem_opt == MOZART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then write(message_txt,*) 'chem_init: calling mozcart_lbc_init for domain ',id call wrf_message( trim(message_txt) ) call mozcart_lbc_init( chem, num_chem, id, & @@ -256,24 +268,30 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif if ( config_flags%wetscav_onoff == 1 ) then + if( config_flags%chem_opt /= MOZART_KPP .and. & config_flags%chem_opt /= MOZCART_KPP .and. & - config_flags%chem_opt /= MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt /= MOZART_MOSAIC_4BIN_KPP .and. & + config_flags%chem_opt /= MOZART_MOSAIC_4BIN_AQ_KPP ) then if( ( config_flags%chem_opt >= 8 .AND. config_flags%chem_opt <= 13) .OR. & ( config_flags%chem_opt >= 31 .AND. config_flags%chem_opt <= 36) .OR. & ( config_flags%chem_opt >= 41 .AND. config_flags%chem_opt <= 43) .OR. & + ( config_flags%chem_opt == 131 ) .OR. ( config_flags%chem_opt == 132 ) .OR. & ( config_flags%chem_opt == 503 .OR. config_flags%chem_opt == 504) .OR. & + ( config_flags%chem_opt == 203).OR. & !BSINGH(12/17/2013): Added for SAPRC 8 bin vbs ( config_flags%chem_opt == 601 .OR. config_flags%chem_opt == 611) ) then call wrf_debug( 15, 'Chemics_init: Wet scavenging turned on' ) else call wrf_error_fatal("ERROR: wet scavenging option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 42 or 503 or 504 or 601 or 611 to function.") endif - if ( config_flags%mp_physics /= 2 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 11) then - call wrf_error_fatal("ERROR: wet scavenging option requires mp_phys = 2 (Lin et al.) or 10 (Morrison) or 11 (CAMMGMP) to function.") + if ( config_flags%mp_physics /= 2 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 11 & + .and. config_flags%mp_physics /= 17 .and. config_flags%mp_physics /= 18 .and. config_flags%mp_physics /= 22) then + call wrf_error_fatal("ERROR: wet scavenging option requires mp_phys = 2 (Lin et al.) or 10 (Morrison) or 11 (CAMMGMP) or 17/18/22 NSSL_2mom to function.") endif elseif( id == 1 ) then - if ( config_flags%mp_physics /= 8 ) then - call wrf_error_fatal("ERROR: wet scavenging option for MOZART,MOZCART requires mp_phys = 8 (Thompson) to function.") + if ( config_flags%mp_physics /= 8 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 17 & + .and. config_flags%mp_physics /= 18 .and. config_flags%mp_physics /= 22) then + call wrf_error_fatal("ERROR: wet scavenging option for MOZART,MOZCART requires mp_phys = 8 (Thompson) or 10 (Morrison) .or 17/18/22 (NSSL 2-moment) to function.") else write(message_txt,*) 'chem_init: calling wetscav_mozcart_init for domain ',id call wrf_message( trim(message_txt) ) @@ -287,14 +305,17 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ( config_flags%chem_opt >= 31 .AND. config_flags%chem_opt <= 36) .OR. & ( config_flags%chem_opt >= 501 .AND. config_flags%chem_opt <= 504) .OR. & ( config_flags%chem_opt >= 41 .AND. config_flags%chem_opt <= 43) .OR. & + ( config_flags%chem_opt == 203).OR. & + ( config_flags%chem_opt == 131 ) .OR. ( config_flags%chem_opt == 132 ) .OR. & ( config_flags%chem_opt >= 601 .AND. config_flags%chem_opt <= 611) ) then call wrf_debug( 15, 'Chemics_init: Cloud chemistry turned on' ) else call wrf_error_fatal("ERROR: cloud chemistry option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 43 to function.") endif - if ( config_flags%mp_physics /= 2 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 11 ) then - call wrf_error_fatal("ERROR: cloud chemistry option requires mp_phys = 2 (Lin et al.) or 10 (Morrison) or 11 (CAMMGMP)to function.") - endif + if ( config_flags%mp_physics /= 2 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 11 & + .and. config_flags%mp_physics /= 17 .and. config_flags%mp_physics /= 18 .and. config_flags%mp_physics /= 22 ) then + call wrf_error_fatal("ERROR: cloud chemistry option requires mp_phys = 2 (Lin et al.) or 10 (Morrison) or 11 (CAMMGMP) or 17/18/22 NSSL_2mom to function.") + endif endif if ( config_flags%cu_physics == 5 .OR. config_flags%cu_physics == 3) then @@ -304,8 +325,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif if ( config_flags%cu_diag == 1) then - if ( config_flags%cu_physics /= 3 .AND. config_flags%cu_physics /= 5) then - call wrf_error_fatal(" Time averaged variables (cu_diag = 1) requires cu_physics = 3 or 5") + if ( config_flags%cu_physics /= 3 .AND. config_flags%cu_physics /= 5 .AND. config_flags%cu_physics /= 10) then !BSINGH(12/17/2013): Added for WRFCUP scheme + call wrf_error_fatal(" Time averaged variables (cu_diag = 1) requires cu_physics = 3 or 5 or 10") endif endif @@ -314,6 +335,10 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_error_fatal("ERROR: chem_conv_tr=1 requires cu_diag=1") endif + if ( config_flags%bio_emiss_opt .EQ. 3 .AND. config_flags%ne_area .LT. num_chem ) then + call wrf_error_fatal("ERROR: MEGAN biogenics requires ne_area to be equal or greater than num_chem") + endif + IF ( config_flags%chem_opt == 0 .AND. config_flags%aer_ra_feedback .NE. 0 ) THEN ! config_flags%aer_ra_feedback = 0 call wrf_error_fatal(" ERROR: CHEM_INIT: FOR CHEM_OPT = 0, AER_RA_FEEDBACK MUST = 0 ") @@ -338,6 +363,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, (config_flags%chem_opt >= 31 .AND. config_flags%chem_opt <= 34) .OR. & config_flags%chem_opt == 170 .OR. config_flags%chem_opt == 198 .OR. & config_flags%chem_opt == 199 .OR. config_flags%chem_opt == 201 .OR. & + config_flags%chem_opt == 203 .OR. & config_flags%chem_opt == 601 .OR. config_flags%chem_opt == 611 ) then call wrf_debug( 15, 'using N2O5 heterogeneous chemistry without Cl- pathway') else @@ -597,7 +623,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, enddo enddo endif - CASE (RADM2_KPP,RADM2SORG_KPP,GOCARTRADM2,GOCARTRADM2_KPP,SAPRC99_KPP) + CASE (RADM2_KPP,RADM2SORG_KPP,GOCARTRADM2,SAPRC99_KPP) if(config_flags%chem_in_opt == 0 )then do j=jts,jte do k=kts,kte @@ -618,8 +644,36 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, enddo enddo endif - - + CASE (CB05_SORG_AQ_KPP) + do j=jts,jte + do k=kts,kte + do i=its,ite + chem(i,k,j,p_apin)=chem(i,k,j,p_terp) * 0.248 ! 0.0885 + chem(i,k,j,p_bpin)=chem(i,k,j,p_terp) * 0.294 ! 0.069 + chem(i,k,j,p_lim) =chem(i,k,j,p_terp) * 0.164 ! 0.135 + chem(i,k,j,p_ter) =chem(i,k,j,p_terp) * 0.006 ! 0.158 + chem(i,k,j,p_oci) =chem(i,k,j,p_terp) * 0.213 ! 0.217 + chem(i,k,j,p_hum) =chem(i,k,j,p_terp) * 0.074 ! 0.331 + chem(i,k,j,p_h2) = 0.5 + chem(i,k,j,p_ch4) =1.7 + enddo + enddo + enddo + CASE (CB05_SORG_VBS_AQ_KPP) + do j=jts,jte + do k=kts,kte + do i=its,ite + chem(i,k,j,p_apin)=chem(i,k,j,p_terp) * 0.248 ! 0.0885 + chem(i,k,j,p_bpin)=chem(i,k,j,p_terp) * 0.294 ! 0.069 + chem(i,k,j,p_lim) =chem(i,k,j,p_terp) * 0.164 ! 0.135 + chem(i,k,j,p_ter) =chem(i,k,j,p_terp) * 0.006 ! 0.158 + chem(i,k,j,p_oci) =chem(i,k,j,p_terp) * 0.213 ! 0.217 + chem(i,k,j,p_hum) =chem(i,k,j,p_terp) * 0.074 ! 0.331 + chem(i,k,j,p_h2) = 0.5 + chem(i,k,j,p_ch4) =1.7 + enddo + enddo + enddo CASE (CBMZ_MOSAIC_KPP) if(config_flags%chem_in_opt == 0 )then do j=jts,jte @@ -640,15 +694,12 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, enddo enddo endif - - CASE (MOZART_MOSAIC_4BIN_VBS0_KPP) -! 20130708 acd_alma_bugfix start + CASE (MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP) grid%vbs_nbin=0 -! 20130708 acd_alma_bugfix end + if (config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then + grid%vbs_nbin=4 + endif if(config_flags%chem_in_opt == 0 )then -! 20130708 acd_alma_bugfix start -! grid%vbs_nbin=0 -! 20130708 acd_alma_bugfix end do j=jts,jte do k=kts,kte do i=its,ite @@ -673,8 +724,104 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, if (p_smpa.gt.1) chem(i,k,j,p_smpa)=0.0 if (p_smpbb.gt.1) chem(i,k,j,p_smpbb)=0.0 - chem(i,k,j,p_voca)=0.0 - chem(i,k,j,p_vocbb)=0.0 + if (p_cvasoaX.gt.1) chem(i,k,j,p_cvasoaX)=0.0 + if (p_cvasoa1.gt.1) chem(i,k,j,p_cvasoa1)=0.0 + if (p_cvasoa2.gt.1) chem(i,k,j,p_cvasoa2)=0.0 + if (p_cvasoa3.gt.1) chem(i,k,j,p_cvasoa3)=0.0 + if (p_cvasoa4.gt.1) chem(i,k,j,p_cvasoa4)=0.0 + if (p_cvbsoaX.gt.1) chem(i,k,j,p_cvbsoaX)=0.0 + if (p_cvbsoa1.gt.1) chem(i,k,j,p_cvbsoa1)=0.0 + if (p_cvbsoa2.gt.1) chem(i,k,j,p_cvbsoa2)=0.0 + if (p_cvbsoa3.gt.1) chem(i,k,j,p_cvbsoa3)=0.0 + if (p_cvbsoa4.gt.1) chem(i,k,j,p_cvbsoa4)=0.0 + + if (p_asoaX_a01.gt.1) chem(i,k,j,p_asoaX_a01)=0.0 + if (p_asoa1_a01.gt.1) chem(i,k,j,p_asoa1_a01)=0.0 + if (p_asoa2_a01.gt.1) chem(i,k,j,p_asoa2_a01)=0.0 + if (p_asoa3_a01.gt.1) chem(i,k,j,p_asoa3_a01)=0.0 + if (p_asoa4_a01.gt.1) chem(i,k,j,p_asoa4_a01)=0.0 + if (p_bsoaX_a01.gt.1) chem(i,k,j,p_bsoaX_a01)=0.0 + if (p_bsoa1_a01.gt.1) chem(i,k,j,p_bsoa1_a01)=0.0 + if (p_bsoa2_a01.gt.1) chem(i,k,j,p_bsoa2_a01)=0.0 + if (p_bsoa3_a01.gt.1) chem(i,k,j,p_bsoa3_a01)=0.0 + if (p_bsoa4_a01.gt.1) chem(i,k,j,p_bsoa4_a01)=0.0 + + if (p_asoaX_a02.gt.1) chem(i,k,j,p_asoaX_a02)=0.0 + if (p_asoa1_a02.gt.1) chem(i,k,j,p_asoa1_a02)=0.0 + if (p_asoa2_a02.gt.1) chem(i,k,j,p_asoa2_a02)=0.0 + if (p_asoa3_a02.gt.1) chem(i,k,j,p_asoa3_a02)=0.0 + if (p_asoa4_a02.gt.1) chem(i,k,j,p_asoa4_a02)=0.0 + if (p_bsoaX_a02.gt.1) chem(i,k,j,p_bsoaX_a02)=0.0 + if (p_bsoa1_a02.gt.1) chem(i,k,j,p_bsoa1_a02)=0.0 + if (p_bsoa2_a02.gt.1) chem(i,k,j,p_bsoa2_a02)=0.0 + if (p_bsoa3_a02.gt.1) chem(i,k,j,p_bsoa3_a02)=0.0 + if (p_bsoa4_a02.gt.1) chem(i,k,j,p_bsoa4_a02)=0.0 + + if (p_asoaX_a03.gt.1) chem(i,k,j,p_asoaX_a03)=0.0 + if (p_asoa1_a03.gt.1) chem(i,k,j,p_asoa1_a03)=0.0 + if (p_asoa2_a03.gt.1) chem(i,k,j,p_asoa2_a03)=0.0 + if (p_asoa3_a03.gt.1) chem(i,k,j,p_asoa3_a03)=0.0 + if (p_asoa4_a03.gt.1) chem(i,k,j,p_asoa4_a03)=0.0 + if (p_bsoaX_a03.gt.1) chem(i,k,j,p_bsoaX_a03)=0.0 + if (p_bsoa1_a03.gt.1) chem(i,k,j,p_bsoa1_a03)=0.0 + if (p_bsoa2_a03.gt.1) chem(i,k,j,p_bsoa2_a03)=0.0 + if (p_bsoa3_a03.gt.1) chem(i,k,j,p_bsoa3_a03)=0.0 + if (p_bsoa4_a03.gt.1) chem(i,k,j,p_bsoa4_a03)=0.0 + + if (p_asoaX_a04.gt.1) chem(i,k,j,p_asoaX_a04)=0.0 + if (p_asoa1_a04.gt.1) chem(i,k,j,p_asoa1_a04)=0.0 + if (p_asoa2_a04.gt.1) chem(i,k,j,p_asoa2_a04)=0.0 + if (p_asoa3_a04.gt.1) chem(i,k,j,p_asoa3_a04)=0.0 + if (p_asoa4_a04.gt.1) chem(i,k,j,p_asoa4_a04)=0.0 + if (p_bsoaX_a04.gt.1) chem(i,k,j,p_bsoaX_a04)=0.0 + if (p_bsoa1_a04.gt.1) chem(i,k,j,p_bsoa1_a04)=0.0 + if (p_bsoa2_a04.gt.1) chem(i,k,j,p_bsoa2_a04)=0.0 + if (p_bsoa3_a04.gt.1) chem(i,k,j,p_bsoa3_a04)=0.0 + if (p_bsoa4_a04.gt.1) chem(i,k,j,p_bsoa4_a04)=0.0 + + if (p_glysoa_r1_a01.gt.1) chem(i,k,j,p_glysoa_r1_a01)=0.0 + if (p_glysoa_r2_a01.gt.1) chem(i,k,j,p_glysoa_r2_a01)=0.0 + if (p_glysoa_oh_a01.gt.1) chem(i,k,j,p_glysoa_oh_a01)=0.0 + if (p_glysoa_nh4_a01.gt.1) chem(i,k,j,p_glysoa_nh4_a01)=0.0 + if (p_glysoa_sfc_a01.gt.1) chem(i,k,j,p_glysoa_sfc_a01)=0.0 + + if (p_glysoa_r1_a02.gt.1) chem(i,k,j,p_glysoa_r1_a02)=0.0 + if (p_glysoa_r2_a02.gt.1) chem(i,k,j,p_glysoa_r2_a02)=0.0 + if (p_glysoa_oh_a02.gt.1) chem(i,k,j,p_glysoa_oh_a02)=0.0 + if (p_glysoa_nh4_a02.gt.1) chem(i,k,j,p_glysoa_nh4_a02)=0.0 + if (p_glysoa_sfc_a02.gt.1) chem(i,k,j,p_glysoa_sfc_a02)=0.0 + + if (p_glysoa_r1_a03.gt.1) chem(i,k,j,p_glysoa_r1_a03)=0.0 + if (p_glysoa_r2_a03.gt.1) chem(i,k,j,p_glysoa_r2_a03)=0.0 + if (p_glysoa_oh_a03.gt.1) chem(i,k,j,p_glysoa_oh_a03)=0.0 + if (p_glysoa_nh4_a03.gt.1) chem(i,k,j,p_glysoa_nh4_a03)=0.0 + if (p_glysoa_sfc_a03.gt.1) chem(i,k,j,p_glysoa_sfc_a03)=0.0 + + if (p_glysoa_r1_a04.gt.1) chem(i,k,j,p_glysoa_r1_a04)=0.0 + if (p_glysoa_r2_a04.gt.1) chem(i,k,j,p_glysoa_r2_a04)=0.0 + if (p_glysoa_oh_a04.gt.1) chem(i,k,j,p_glysoa_oh_a04)=0.0 + if (p_glysoa_nh4_a04.gt.1) chem(i,k,j,p_glysoa_nh4_a04)=0.0 + if (p_glysoa_sfc_a04.gt.1) chem(i,k,j,p_glysoa_sfc_a04)=0.0 + +! chem(i,k,j,p_voca)=0.0 +! chem(i,k,j,p_vocbb)=0.0 + if (p_voca.gt.1) chem(i,k,j,p_voca)=0.0 + if (p_vocbb.gt.1) chem(i,k,j,p_vocbb)=0.0 + + if (p_smpa_a01.gt.1) chem(i,k,j,p_smpa_a01)=1.e-16 + if (p_smpa_a02.gt.1) chem(i,k,j,p_smpa_a02)=1.e-16 + if (p_smpa_a03.gt.1) chem(i,k,j,p_smpa_a03)=1.e-16 + if (p_smpa_a04.gt.1) chem(i,k,j,p_smpa_a04)=1.e-16 + + if (p_smpbb_a01.gt.1) chem(i,k,j,p_smpbb_a01)=1.e-16 + if (p_smpbb_a02.gt.1) chem(i,k,j,p_smpbb_a02)=1.e-16 + if (p_smpbb_a03.gt.1) chem(i,k,j,p_smpbb_a03)=1.e-16 + if (p_smpbb_a04.gt.1) chem(i,k,j,p_smpbb_a04)=1.e-16 + + if (p_nh4_a01.gt.1) chem(i,k,j,p_nh4_a01)=1.e-16 + if (p_nh4_a02.gt.1) chem(i,k,j,p_nh4_a02)=1.e-16 + if (p_nh4_a03.gt.1) chem(i,k,j,p_nh4_a03)=1.e-16 + if (p_nh4_a04.gt.1) chem(i,k,j,p_nh4_a04)=1.e-16 enddo @@ -684,7 +831,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, - CASE (CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP) + CASE (SAPRC99_MOSAIC_4BIN_VBS2_KPP) if(config_flags%chem_in_opt == 0 )then grid%vbs_nbin(1)=2 do j=jts,jte @@ -782,11 +929,561 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, enddo enddo enddo - endif - - - - + endif + + !BSINGH(04/03/2014): Added 8 bin vbs non-aq pakage + CASE (SAPRC99_MOSAIC_8BIN_VBS2_KPP) + if(config_flags%chem_in_opt == 0 )then + grid%vbs_nbin=3 + do j=jts,jte + do k=kts,kte + do i=its,ite + chem(i,k,j,p_co2)=370. + chem(i,k,j,p_ch4)=1.7 + if (p_pcg1_b_c.gt.1) chem(i,k,j,p_pcg1_b_c)=0.00 + if (p_pcg2_b_c.gt.1) chem(i,k,j,p_pcg2_b_c)=0.00 + if (p_pcg3_b_c.gt.1) chem(i,k,j,p_pcg3_b_c)=0.00 + if (p_pcg4_b_c.gt.1) chem(i,k,j,p_pcg4_b_c)=0.00 + if (p_pcg5_b_c.gt.1) chem(i,k,j,p_pcg5_b_c)=0.00 + if (p_pcg6_b_c.gt.1) chem(i,k,j,p_pcg6_b_c)=0.00 + if (p_pcg7_b_c.gt.1) chem(i,k,j,p_pcg7_b_c)=0.00 + if (p_pcg8_b_c.gt.1) chem(i,k,j,p_pcg8_b_c)=0.00 + if (p_pcg9_b_c.gt.1) chem(i,k,j,p_pcg9_b_c)=0.00 + if (p_pcg1_b_o.gt.1) chem(i,k,j,p_pcg1_b_o)=0.00 + if (p_pcg2_b_o.gt.1) chem(i,k,j,p_pcg2_b_o)=0.00 + if (p_pcg3_b_o.gt.1) chem(i,k,j,p_pcg3_b_o)=0.00 + if (p_pcg4_b_o.gt.1) chem(i,k,j,p_pcg4_b_o)=0.00 + if (p_pcg5_b_o.gt.1) chem(i,k,j,p_pcg5_b_o)=0.00 + if (p_pcg6_b_o.gt.1) chem(i,k,j,p_pcg6_b_o)=0.00 + if (p_pcg7_b_o.gt.1) chem(i,k,j,p_pcg7_b_o)=0.00 + if (p_pcg8_b_o.gt.1) chem(i,k,j,p_pcg8_b_o)=0.00 + if (p_pcg9_b_o.gt.1) chem(i,k,j,p_pcg9_b_o)=0.00 + if (p_opcg1_b_c.gt.1) chem(i,k,j,p_opcg1_b_c)=0.00 + if (p_opcg2_b_c.gt.1) chem(i,k,j,p_opcg2_b_c)=0.00 + if (p_opcg3_b_c.gt.1) chem(i,k,j,p_opcg3_b_c)=0.00 + if (p_opcg4_b_c.gt.1) chem(i,k,j,p_opcg4_b_c)=0.00 + if (p_opcg5_b_c.gt.1) chem(i,k,j,p_opcg5_b_c)=0.00 + if (p_opcg6_b_c.gt.1) chem(i,k,j,p_opcg6_b_c)=0.00 + if (p_opcg7_b_c.gt.1) chem(i,k,j,p_opcg7_b_c)=0.00 + if (p_opcg8_b_c.gt.1) chem(i,k,j,p_opcg8_b_c)=0.00 + if (p_opcg1_b_o.gt.1) chem(i,k,j,p_opcg1_b_o)=0.00 + if (p_opcg2_b_o.gt.1) chem(i,k,j,p_opcg2_b_o)=0.00 + if (p_opcg3_b_o.gt.1) chem(i,k,j,p_opcg3_b_o)=0.00 + if (p_opcg4_b_o.gt.1) chem(i,k,j,p_opcg4_b_o)=0.00 + if (p_opcg5_b_o.gt.1) chem(i,k,j,p_opcg5_b_o)=0.00 + if (p_opcg6_b_o.gt.1) chem(i,k,j,p_opcg6_b_o)=0.00 + if (p_opcg7_b_o.gt.1) chem(i,k,j,p_opcg7_b_o)=0.00 + if (p_opcg8_b_o.gt.1) chem(i,k,j,p_opcg8_b_o)=0.00 + if (p_pcg1_f_c.gt.1) chem(i,k,j,p_pcg1_f_c)=0.00 + if (p_pcg2_f_c.gt.1) chem(i,k,j,p_pcg2_f_c)=0.00 + if (p_pcg3_f_c.gt.1) chem(i,k,j,p_pcg3_f_c)=0.00 + if (p_pcg4_f_c.gt.1) chem(i,k,j,p_pcg4_f_c)=0.00 + if (p_pcg5_f_c.gt.1) chem(i,k,j,p_pcg5_f_c)=0.00 + if (p_pcg6_f_c.gt.1) chem(i,k,j,p_pcg6_f_c)=0.00 + if (p_pcg7_f_c.gt.1) chem(i,k,j,p_pcg7_f_c)=0.00 + if (p_pcg8_f_c.gt.1) chem(i,k,j,p_pcg8_f_c)=0.00 + if (p_pcg9_f_c.gt.1) chem(i,k,j,p_pcg9_f_c)=0.00 + if (p_pcg1_f_o.gt.1) chem(i,k,j,p_pcg1_f_o)=0.00 + if (p_pcg2_f_o.gt.1) chem(i,k,j,p_pcg2_f_o)=0.00 + if (p_pcg3_f_o.gt.1) chem(i,k,j,p_pcg3_f_o)=0.00 + if (p_pcg4_f_o.gt.1) chem(i,k,j,p_pcg4_f_o)=0.00 + if (p_pcg5_f_o.gt.1) chem(i,k,j,p_pcg5_f_o)=0.00 + if (p_pcg6_f_o.gt.1) chem(i,k,j,p_pcg6_f_o)=0.00 + if (p_pcg7_f_o.gt.1) chem(i,k,j,p_pcg7_f_o)=0.00 + if (p_pcg8_f_o.gt.1) chem(i,k,j,p_pcg8_f_o)=0.00 + if (p_pcg9_f_o.gt.1) chem(i,k,j,p_pcg9_f_o)=0.00 + if (p_opcg1_f_c.gt.1) chem(i,k,j,p_opcg1_f_c)=0.00 + if (p_opcg2_f_c.gt.1) chem(i,k,j,p_opcg2_f_c)=0.00 + if (p_opcg3_f_c.gt.1) chem(i,k,j,p_opcg3_f_c)=0.00 + if (p_opcg4_f_c.gt.1) chem(i,k,j,p_opcg4_f_c)=0.00 + if (p_opcg5_f_c.gt.1) chem(i,k,j,p_opcg5_f_c)=0.00 + if (p_opcg6_f_c.gt.1) chem(i,k,j,p_opcg6_f_c)=0.00 + if (p_opcg7_f_c.gt.1) chem(i,k,j,p_opcg7_f_c)=0.00 + if (p_opcg8_f_c.gt.1) chem(i,k,j,p_opcg8_f_c)=0.00 + if (p_opcg1_f_o.gt.1) chem(i,k,j,p_opcg1_f_o)=0.00 + if (p_opcg2_f_o.gt.1) chem(i,k,j,p_opcg2_f_o)=0.00 + if (p_opcg3_f_o.gt.1) chem(i,k,j,p_opcg3_f_o)=0.00 + if (p_opcg4_f_o.gt.1) chem(i,k,j,p_opcg4_f_o)=0.00 + if (p_opcg5_f_o.gt.1) chem(i,k,j,p_opcg5_f_o)=0.00 + if (p_opcg6_f_o.gt.1) chem(i,k,j,p_opcg6_f_o)=0.00 + if (p_opcg7_f_o.gt.1) chem(i,k,j,p_opcg7_f_o)=0.00 + if (p_opcg8_f_o.gt.1) chem(i,k,j,p_opcg8_f_o)=0.00 + if (p_ant1_c.gt.1) chem(i,k,j,p_ant1_c)=0.0 + if (p_ant2_c.gt.1) chem(i,k,j,p_ant2_c)=0.0 + if (p_ant3_c.gt.1) chem(i,k,j,p_ant3_c)=0.0 + if (p_ant4_c.gt.1) chem(i,k,j,p_ant4_c)=0.0 + if (p_ant1_o.gt.1) chem(i,k,j,p_ant1_o)=0.0 + if (p_ant2_o.gt.1) chem(i,k,j,p_ant2_o)=0.0 + if (p_ant3_o.gt.1) chem(i,k,j,p_ant3_o)=0.0 + if (p_ant4_o.gt.1) chem(i,k,j,p_ant4_o)=0.0 + if (p_biog1_c.gt.1) chem(i,k,j,p_biog1_c)=0.0 + if (p_biog2_c.gt.1) chem(i,k,j,p_biog2_c)=0.0 + if (p_biog3_c.gt.1) chem(i,k,j,p_biog3_c)=0.0 + if (p_biog4_c.gt.1) chem(i,k,j,p_biog4_c)=0.0 + if (p_biog1_o.gt.1) chem(i,k,j,p_biog1_o)=0.0 + if (p_biog2_o.gt.1) chem(i,k,j,p_biog2_o)=0.0 + if (p_biog3_o.gt.1) chem(i,k,j,p_biog3_o)=0.0 + if (p_biog4_o.gt.1) chem(i,k,j,p_biog4_o)=0.0 + if (p_bgas.gt.1) chem(i,k,j,p_bgas)=0.0 + if (p_agas.gt.1) chem(i,k,j,p_agas)=0.0 + if (p_nume.gt.1) chem(i,k,j,p_nume)=0.0 + if (p_den.gt.1) chem(i,k,j,p_den)=0.0 + if (p_psd1.gt.1) chem(i,k,j,p_psd1)=0.0 + if (p_psd2.gt.1) chem(i,k,j,p_psd2)=0.0 + if (p_isoprene.gt.1) chem(i,k,j,p_isoprene)=0.0 + if (p_terp.gt.1) chem(i,k,j,p_terp)=0.0 + if (p_sesq.gt.1) chem(i,k,j,p_sesq)=0.0 + if (p_aro1.gt.1) chem(i,k,j,p_aro1)=0.0 + if (p_aro2.gt.1) chem(i,k,j,p_aro2)=0.0 + + + if (p_pcg1_b_c_a01.gt.1) chem(i,k,j,p_pcg1_b_c_a01)=0.0 + if (p_pcg1_b_o_a01.gt.1) chem(i,k,j,p_pcg1_b_o_a01)=0.0 + if (p_opcg1_b_c_a01.gt.1) chem(i,k,j,p_opcg1_b_c_a01)=0.0 + if (p_opcg1_b_o_a01.gt.1) chem(i,k,j,p_opcg1_b_o_a01)=0.0 + if (p_pcg1_f_c_a01.gt.1) chem(i,k,j,p_pcg1_f_c_a01)=0.0 + if (p_pcg1_f_o_a01.gt.1) chem(i,k,j,p_pcg1_f_o_a01)=0.0 + if (p_opcg1_f_c_a01.gt.1) chem(i,k,j,p_opcg1_f_c_a01)=0.0 + if (p_opcg1_f_o_a01.gt.1) chem(i,k,j,p_opcg1_f_o_a01)=0.0 + if (p_ant1_c_a01.gt.1) chem(i,k,j,p_ant1_c_a01)=0.0 + if (p_biog1_c_a01.gt.1) chem(i,k,j,p_biog1_c_a01)=0.0 + if (p_ant2_c_a01.gt.1) chem(i,k,j,p_ant2_c_a01)=0.0 + if (p_biog2_c_a01.gt.1) chem(i,k,j,p_biog2_c_a01)=0.0 + if (p_biog3_c_a01.gt.1) chem(i,k,j,p_biog3_c_a01)=0.0 + if (p_biog4_c_a01.gt.1) chem(i,k,j,p_biog4_c_a01)=0.0 + if (p_biog1_o_a01.gt.1) chem(i,k,j,p_biog1_o_a01)=0.0 + if (p_biog2_o_a01.gt.1) chem(i,k,j,p_biog2_o_a01)=0.0 + if (p_ant3_c_a01.gt.1) chem(i,k,j,p_ant3_c_a01)=0.0 + if (p_ant4_c_a01.gt.1) chem(i,k,j,p_ant4_c_a01)=0.0 + + + if (p_pcg1_b_c_a02.gt.1) chem(i,k,j,p_pcg1_b_c_a02)=0.0 + if (p_pcg1_b_o_a02.gt.1) chem(i,k,j,p_pcg1_b_o_a02)=0.0 + if (p_opcg1_b_c_a02.gt.1) chem(i,k,j,p_opcg1_b_c_a02)=0.0 + if (p_opcg1_b_o_a02.gt.1) chem(i,k,j,p_opcg1_b_o_a02)=0.0 + if (p_pcg1_f_c_a02.gt.1) chem(i,k,j,p_pcg1_f_c_a02)=0.0 + if (p_pcg1_f_o_a02.gt.1) chem(i,k,j,p_pcg1_f_o_a02)=0.0 + if (p_opcg1_f_c_a02.gt.1) chem(i,k,j,p_opcg1_f_c_a02)=0.0 + if (p_opcg1_f_o_a02.gt.1) chem(i,k,j,p_opcg1_f_o_a02)=0.0 + if (p_ant1_c_a02.gt.1) chem(i,k,j,p_ant1_c_a02)=0.0 + if (p_biog1_c_a02.gt.1) chem(i,k,j,p_biog1_c_a02)=0.0 + if (p_ant2_c_a02.gt.1) chem(i,k,j,p_ant2_c_a02)=0.0 + if (p_biog2_c_a02.gt.1) chem(i,k,j,p_biog2_c_a02)=0.0 + if (p_biog3_c_a02.gt.1) chem(i,k,j,p_biog3_c_a02)=0.0 + if (p_biog4_c_a02.gt.1) chem(i,k,j,p_biog4_c_a02)=0.0 + if (p_biog1_o_a02.gt.1) chem(i,k,j,p_biog1_o_a02)=0.0 + if (p_biog2_o_a02.gt.1) chem(i,k,j,p_biog2_o_a02)=0.0 + if (p_ant3_c_a02.gt.1) chem(i,k,j,p_ant3_c_a02)=0.0 + if (p_ant4_c_a02.gt.1) chem(i,k,j,p_ant4_c_a02)=0.0 + + + + if (p_pcg1_b_c_a03.gt.1) chem(i,k,j,p_pcg1_b_c_a03)=0.0 + if (p_pcg1_b_o_a03.gt.1) chem(i,k,j,p_pcg1_b_o_a03)=0.0 + if (p_opcg1_b_c_a03.gt.1) chem(i,k,j,p_opcg1_b_c_a03)=0.0 + if (p_opcg1_b_o_a03.gt.1) chem(i,k,j,p_opcg1_b_o_a03)=0.0 + if (p_pcg1_f_c_a03.gt.1) chem(i,k,j,p_pcg1_f_c_a03)=0.0 + if (p_pcg1_f_o_a03.gt.1) chem(i,k,j,p_pcg1_f_o_a03)=0.0 + if (p_opcg1_f_c_a03.gt.1) chem(i,k,j,p_opcg1_f_c_a03)=0.0 + if (p_opcg1_f_o_a03.gt.1) chem(i,k,j,p_opcg1_f_o_a03)=0.0 + if (p_ant1_c_a03.gt.1) chem(i,k,j,p_ant1_c_a03)=0.0 + if (p_biog1_c_a03.gt.1) chem(i,k,j,p_biog1_c_a03)=0.0 + if (p_ant2_c_a03.gt.1) chem(i,k,j,p_ant2_c_a03)=0.0 + if (p_biog2_c_a03.gt.1) chem(i,k,j,p_biog2_c_a03)=0.0 + if (p_biog3_c_a03.gt.1) chem(i,k,j,p_biog3_c_a03)=0.0 + if (p_biog4_c_a03.gt.1) chem(i,k,j,p_biog4_c_a03)=0.0 + if (p_biog1_o_a03.gt.1) chem(i,k,j,p_biog1_o_a03)=0.0 + if (p_biog2_o_a03.gt.1) chem(i,k,j,p_biog2_o_a03)=0.0 + if (p_ant3_c_a03.gt.1) chem(i,k,j,p_ant3_c_a03)=0.0 + if (p_ant4_c_a03.gt.1) chem(i,k,j,p_ant4_c_a03)=0.0 + + + if (p_pcg1_b_c_a04.gt.1) chem(i,k,j,p_pcg1_b_c_a04)=0.0 + if (p_pcg1_b_o_a04.gt.1) chem(i,k,j,p_pcg1_b_o_a04)=0.0 + if (p_opcg1_b_c_a04.gt.1) chem(i,k,j,p_opcg1_b_c_a04)=0.0 + if (p_opcg1_b_o_a04.gt.1) chem(i,k,j,p_opcg1_b_o_a04)=0.0 + if (p_pcg1_f_c_a04.gt.1) chem(i,k,j,p_pcg1_f_c_a04)=0.0 + if (p_pcg1_f_o_a04.gt.1) chem(i,k,j,p_pcg1_f_o_a04)=0.0 + if (p_opcg1_f_c_a04.gt.1) chem(i,k,j,p_opcg1_f_c_a04)=0.0 + if (p_opcg1_f_o_a04.gt.1) chem(i,k,j,p_opcg1_f_o_a04)=0.0 + if (p_ant1_c_a04.gt.1) chem(i,k,j,p_ant1_c_a04)=0.0 + if (p_biog1_c_a04.gt.1) chem(i,k,j,p_biog1_c_a04)=0.0 + if (p_ant2_c_a04.gt.1) chem(i,k,j,p_ant2_c_a04)=0.0 + if (p_biog2_c_a04.gt.1) chem(i,k,j,p_biog2_c_a04)=0.0 + if (p_biog3_c_a04.gt.1) chem(i,k,j,p_biog3_c_a04)=0.0 + if (p_biog4_c_a04.gt.1) chem(i,k,j,p_biog4_c_a04)=0.0 + if (p_biog1_o_a04.gt.1) chem(i,k,j,p_biog1_o_a04)=0.0 + if (p_biog2_o_a04.gt.1) chem(i,k,j,p_biog2_o_a04)=0.0 + if (p_ant3_c_a04.gt.1) chem(i,k,j,p_ant3_c_a04)=0.0 + if (p_ant4_c_a04.gt.1) chem(i,k,j,p_ant4_c_a04)=0.0 + + + if (p_pcg1_b_c_a05.gt.1) chem(i,k,j,p_pcg1_b_c_a05)=0.0 + if (p_pcg1_b_o_a05.gt.1) chem(i,k,j,p_pcg1_b_o_a05)=0.0 + if (p_opcg1_b_c_a05.gt.1) chem(i,k,j,p_opcg1_b_c_a05)=0.0 + if (p_opcg1_b_o_a05.gt.1) chem(i,k,j,p_opcg1_b_o_a05)=0.0 + if (p_pcg1_f_c_a05.gt.1) chem(i,k,j,p_pcg1_f_c_a05)=0.0 + if (p_pcg1_f_o_a05.gt.1) chem(i,k,j,p_pcg1_f_o_a05)=0.0 + if (p_opcg1_f_c_a05.gt.1) chem(i,k,j,p_opcg1_f_c_a05)=0.0 + if (p_opcg1_f_o_a05.gt.1) chem(i,k,j,p_opcg1_f_o_a05)=0.0 + if (p_ant1_c_a05.gt.1) chem(i,k,j,p_ant1_c_a05)=0.0 + if (p_biog1_c_a05.gt.1) chem(i,k,j,p_biog1_c_a05)=0.0 + if (p_ant2_c_a05.gt.1) chem(i,k,j,p_ant2_c_a05)=0.0 + if (p_biog2_c_a05.gt.1) chem(i,k,j,p_biog2_c_a05)=0.0 + if (p_biog3_c_a05.gt.1) chem(i,k,j,p_biog3_c_a05)=0.0 + if (p_biog4_c_a05.gt.1) chem(i,k,j,p_biog4_c_a05)=0.0 + if (p_biog1_o_a05.gt.1) chem(i,k,j,p_biog1_o_a05)=0.0 + if (p_biog2_o_a05.gt.1) chem(i,k,j,p_biog2_o_a05)=0.0 + if (p_ant3_c_a05.gt.1) chem(i,k,j,p_ant3_c_a05)=0.0 + if (p_ant4_c_a05.gt.1) chem(i,k,j,p_ant4_c_a05)=0.0 + + + if (p_pcg1_b_c_a06.gt.1) chem(i,k,j,p_pcg1_b_c_a06)=0.0 + if (p_pcg1_b_o_a06.gt.1) chem(i,k,j,p_pcg1_b_o_a06)=0.0 + if (p_opcg1_b_c_a06.gt.1) chem(i,k,j,p_opcg1_b_c_a06)=0.0 + if (p_opcg1_b_o_a06.gt.1) chem(i,k,j,p_opcg1_b_o_a06)=0.0 + if (p_pcg1_f_c_a06.gt.1) chem(i,k,j,p_pcg1_f_c_a06)=0.0 + if (p_pcg1_f_o_a06.gt.1) chem(i,k,j,p_pcg1_f_o_a06)=0.0 + if (p_opcg1_f_c_a06.gt.1) chem(i,k,j,p_opcg1_f_c_a06)=0.0 + if (p_opcg1_f_o_a06.gt.1) chem(i,k,j,p_opcg1_f_o_a06)=0.0 + if (p_ant1_c_a06.gt.1) chem(i,k,j,p_ant1_c_a06)=0.0 + if (p_biog1_c_a06.gt.1) chem(i,k,j,p_biog1_c_a06)=0.0 + if (p_ant2_c_a06.gt.1) chem(i,k,j,p_ant2_c_a06)=0.0 + if (p_biog2_c_a06.gt.1) chem(i,k,j,p_biog2_c_a06)=0.0 + if (p_biog3_c_a06.gt.1) chem(i,k,j,p_biog3_c_a06)=0.0 + if (p_biog4_c_a06.gt.1) chem(i,k,j,p_biog4_c_a06)=0.0 + if (p_biog1_o_a06.gt.1) chem(i,k,j,p_biog1_o_a06)=0.0 + if (p_biog2_o_a06.gt.1) chem(i,k,j,p_biog2_o_a06)=0.0 + if (p_ant3_c_a06.gt.1) chem(i,k,j,p_ant3_c_a06)=0.0 + if (p_ant4_c_a06.gt.1) chem(i,k,j,p_ant4_c_a06)=0.0 + + + if (p_pcg1_b_c_a07.gt.1) chem(i,k,j,p_pcg1_b_c_a07)=0.0 + if (p_pcg1_b_o_a07.gt.1) chem(i,k,j,p_pcg1_b_o_a07)=0.0 + if (p_opcg1_b_c_a07.gt.1) chem(i,k,j,p_opcg1_b_c_a07)=0.0 + if (p_opcg1_b_o_a07.gt.1) chem(i,k,j,p_opcg1_b_o_a07)=0.0 + if (p_pcg1_f_c_a07.gt.1) chem(i,k,j,p_pcg1_f_c_a07)=0.0 + if (p_pcg1_f_o_a07.gt.1) chem(i,k,j,p_pcg1_f_o_a07)=0.0 + if (p_opcg1_f_c_a07.gt.1) chem(i,k,j,p_opcg1_f_c_a07)=0.0 + if (p_opcg1_f_o_a07.gt.1) chem(i,k,j,p_opcg1_f_o_a07)=0.0 + if (p_ant1_c_a07.gt.1) chem(i,k,j,p_ant1_c_a07)=0.0 + if (p_biog1_c_a07.gt.1) chem(i,k,j,p_biog1_c_a07)=0.0 + if (p_ant2_c_a07.gt.1) chem(i,k,j,p_ant2_c_a07)=0.0 + if (p_biog2_c_a07.gt.1) chem(i,k,j,p_biog2_c_a07)=0.0 + if (p_biog3_c_a07.gt.1) chem(i,k,j,p_biog3_c_a07)=0.0 + if (p_biog4_c_a07.gt.1) chem(i,k,j,p_biog4_c_a07)=0.0 + if (p_biog1_o_a07.gt.1) chem(i,k,j,p_biog1_o_a07)=0.0 + if (p_biog2_o_a07.gt.1) chem(i,k,j,p_biog2_o_a07)=0.0 + if (p_ant3_c_a07.gt.1) chem(i,k,j,p_ant3_c_a07)=0.0 + if (p_ant4_c_a07.gt.1) chem(i,k,j,p_ant4_c_a07)=0.0 + + + if (p_pcg1_b_c_a08.gt.1) chem(i,k,j,p_pcg1_b_c_a08)=0.0 + if (p_pcg1_b_o_a08.gt.1) chem(i,k,j,p_pcg1_b_o_a08)=0.0 + if (p_opcg1_b_c_a08.gt.1) chem(i,k,j,p_opcg1_b_c_a08)=0.0 + if (p_opcg1_b_o_a08.gt.1) chem(i,k,j,p_opcg1_b_o_a08)=0.0 + if (p_pcg1_f_c_a08.gt.1) chem(i,k,j,p_pcg1_f_c_a08)=0.0 + if (p_pcg1_f_o_a08.gt.1) chem(i,k,j,p_pcg1_f_o_a08)=0.0 + if (p_opcg1_f_c_a08.gt.1) chem(i,k,j,p_opcg1_f_c_a08)=0.0 + if (p_opcg1_f_o_a08.gt.1) chem(i,k,j,p_opcg1_f_o_a08)=0.0 + if (p_ant1_c_a08.gt.1) chem(i,k,j,p_ant1_c_a08)=0.0 + if (p_biog1_c_a08.gt.1) chem(i,k,j,p_biog1_c_a08)=0.0 + if (p_ant2_c_a08.gt.1) chem(i,k,j,p_ant2_c_a08)=0.0 + if (p_biog2_c_a08.gt.1) chem(i,k,j,p_biog2_c_a08)=0.0 + if (p_biog3_c_a08.gt.1) chem(i,k,j,p_biog3_c_a08)=0.0 + if (p_biog4_c_a08.gt.1) chem(i,k,j,p_biog4_c_a08)=0.0 + if (p_biog1_o_a08.gt.1) chem(i,k,j,p_biog1_o_a08)=0.0 + if (p_biog2_o_a08.gt.1) chem(i,k,j,p_biog2_o_a08)=0.0 + if (p_ant3_c_a08.gt.1) chem(i,k,j,p_ant3_c_a08)=0.0 + if (p_ant4_c_a08.gt.1) chem(i,k,j,p_ant4_c_a08)=0.0 + + + + enddo + enddo + enddo + endif + !BSINGH(04/03/2014):ENDS + + + !BSINGH(12/03/2013) - Added case statement for SAPRC 8 bin + CASE (SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP )!BSINGH (12/11/13): Got rid of SAPRC99_MOSAIC_4BIN_VBS2_AQ_KPP and SAPRC99_MOSAIC_4BIN_VBS2_KPP + + if(config_flags%chem_in_opt == 1 ) grid%vbs_nbin=2 + if(config_flags%chem_in_opt == 0 )then + grid%vbs_nbin=2 + do j=jts,jte + do k=kts,kte + do i=its,ite + chem(i,k,j,p_co2)=370. + chem(i,k,j,p_ch4)=1.7 + if (p_pcg1_b_c.gt.1) chem(i,k,j,p_pcg1_b_c)=0.00 + if (p_pcg2_b_c.gt.1) chem(i,k,j,p_pcg2_b_c)=0.00 + if (p_pcg3_b_c.gt.1) chem(i,k,j,p_pcg3_b_c)=0.00 + if (p_pcg4_b_c.gt.1) chem(i,k,j,p_pcg4_b_c)=0.00 + if (p_pcg5_b_c.gt.1) chem(i,k,j,p_pcg5_b_c)=0.00 + if (p_pcg6_b_c.gt.1) chem(i,k,j,p_pcg6_b_c)=0.00 + if (p_pcg7_b_c.gt.1) chem(i,k,j,p_pcg7_b_c)=0.00 + if (p_pcg8_b_c.gt.1) chem(i,k,j,p_pcg8_b_c)=0.00 + if (p_pcg9_b_c.gt.1) chem(i,k,j,p_pcg9_b_c)=0.00 + if (p_pcg1_b_o.gt.1) chem(i,k,j,p_pcg1_b_o)=0.00 + if (p_pcg2_b_o.gt.1) chem(i,k,j,p_pcg2_b_o)=0.00 + if (p_pcg3_b_o.gt.1) chem(i,k,j,p_pcg3_b_o)=0.00 + if (p_pcg4_b_o.gt.1) chem(i,k,j,p_pcg4_b_o)=0.00 + if (p_pcg5_b_o.gt.1) chem(i,k,j,p_pcg5_b_o)=0.00 + if (p_pcg6_b_o.gt.1) chem(i,k,j,p_pcg6_b_o)=0.00 + if (p_pcg7_b_o.gt.1) chem(i,k,j,p_pcg7_b_o)=0.00 + if (p_pcg8_b_o.gt.1) chem(i,k,j,p_pcg8_b_o)=0.00 + if (p_pcg9_b_o.gt.1) chem(i,k,j,p_pcg9_b_o)=0.00 + if (p_opcg1_b_c.gt.1) chem(i,k,j,p_opcg1_b_c)=0.00 + if (p_opcg2_b_c.gt.1) chem(i,k,j,p_opcg2_b_c)=0.00 + if (p_opcg3_b_c.gt.1) chem(i,k,j,p_opcg3_b_c)=0.00 + if (p_opcg4_b_c.gt.1) chem(i,k,j,p_opcg4_b_c)=0.00 + if (p_opcg5_b_c.gt.1) chem(i,k,j,p_opcg5_b_c)=0.00 + if (p_opcg6_b_c.gt.1) chem(i,k,j,p_opcg6_b_c)=0.00 + if (p_opcg7_b_c.gt.1) chem(i,k,j,p_opcg7_b_c)=0.00 + if (p_opcg8_b_c.gt.1) chem(i,k,j,p_opcg8_b_c)=0.00 + if (p_opcg1_b_o.gt.1) chem(i,k,j,p_opcg1_b_o)=0.00 + if (p_opcg2_b_o.gt.1) chem(i,k,j,p_opcg2_b_o)=0.00 + if (p_opcg3_b_o.gt.1) chem(i,k,j,p_opcg3_b_o)=0.00 + if (p_opcg4_b_o.gt.1) chem(i,k,j,p_opcg4_b_o)=0.00 + if (p_opcg5_b_o.gt.1) chem(i,k,j,p_opcg5_b_o)=0.00 + if (p_opcg6_b_o.gt.1) chem(i,k,j,p_opcg6_b_o)=0.00 + if (p_opcg7_b_o.gt.1) chem(i,k,j,p_opcg7_b_o)=0.00 + if (p_opcg8_b_o.gt.1) chem(i,k,j,p_opcg8_b_o)=0.00 + if (p_pcg1_f_c.gt.1) chem(i,k,j,p_pcg1_f_c)=0.00 + if (p_pcg2_f_c.gt.1) chem(i,k,j,p_pcg2_f_c)=0.00 + if (p_pcg3_f_c.gt.1) chem(i,k,j,p_pcg3_f_c)=0.00 + if (p_pcg4_f_c.gt.1) chem(i,k,j,p_pcg4_f_c)=0.00 + if (p_pcg5_f_c.gt.1) chem(i,k,j,p_pcg5_f_c)=0.00 + if (p_pcg6_f_c.gt.1) chem(i,k,j,p_pcg6_f_c)=0.00 + if (p_pcg7_f_c.gt.1) chem(i,k,j,p_pcg7_f_c)=0.00 + if (p_pcg8_f_c.gt.1) chem(i,k,j,p_pcg8_f_c)=0.00 + if (p_pcg9_f_c.gt.1) chem(i,k,j,p_pcg9_f_c)=0.00 + if (p_pcg1_f_o.gt.1) chem(i,k,j,p_pcg1_f_o)=0.00 + if (p_pcg2_f_o.gt.1) chem(i,k,j,p_pcg2_f_o)=0.00 + if (p_pcg3_f_o.gt.1) chem(i,k,j,p_pcg3_f_o)=0.00 + if (p_pcg4_f_o.gt.1) chem(i,k,j,p_pcg4_f_o)=0.00 + if (p_pcg5_f_o.gt.1) chem(i,k,j,p_pcg5_f_o)=0.00 + if (p_pcg6_f_o.gt.1) chem(i,k,j,p_pcg6_f_o)=0.00 + if (p_pcg7_f_o.gt.1) chem(i,k,j,p_pcg7_f_o)=0.00 + if (p_pcg8_f_o.gt.1) chem(i,k,j,p_pcg8_f_o)=0.00 + if (p_pcg9_f_o.gt.1) chem(i,k,j,p_pcg9_f_o)=0.00 + if (p_opcg1_f_c.gt.1) chem(i,k,j,p_opcg1_f_c)=0.00 + if (p_opcg2_f_c.gt.1) chem(i,k,j,p_opcg2_f_c)=0.00 + if (p_opcg3_f_c.gt.1) chem(i,k,j,p_opcg3_f_c)=0.00 + if (p_opcg4_f_c.gt.1) chem(i,k,j,p_opcg4_f_c)=0.00 + if (p_opcg5_f_c.gt.1) chem(i,k,j,p_opcg5_f_c)=0.00 + if (p_opcg6_f_c.gt.1) chem(i,k,j,p_opcg6_f_c)=0.00 + if (p_opcg7_f_c.gt.1) chem(i,k,j,p_opcg7_f_c)=0.00 + if (p_opcg8_f_c.gt.1) chem(i,k,j,p_opcg8_f_c)=0.00 + if (p_opcg1_f_o.gt.1) chem(i,k,j,p_opcg1_f_o)=0.00 + if (p_opcg2_f_o.gt.1) chem(i,k,j,p_opcg2_f_o)=0.00 + if (p_opcg3_f_o.gt.1) chem(i,k,j,p_opcg3_f_o)=0.00 + if (p_opcg4_f_o.gt.1) chem(i,k,j,p_opcg4_f_o)=0.00 + if (p_opcg5_f_o.gt.1) chem(i,k,j,p_opcg5_f_o)=0.00 + if (p_opcg6_f_o.gt.1) chem(i,k,j,p_opcg6_f_o)=0.00 + if (p_opcg7_f_o.gt.1) chem(i,k,j,p_opcg7_f_o)=0.00 + if (p_opcg8_f_o.gt.1) chem(i,k,j,p_opcg8_f_o)=0.00 + if (p_ant1_c.gt.1) chem(i,k,j,p_ant1_c)=0.0 + if (p_ant2_c.gt.1) chem(i,k,j,p_ant2_c)=0.0 + if (p_ant3_c.gt.1) chem(i,k,j,p_ant3_c)=0.0 + if (p_ant4_c.gt.1) chem(i,k,j,p_ant4_c)=0.0 + if (p_ant1_o.gt.1) chem(i,k,j,p_ant1_o)=0.0 + if (p_ant2_o.gt.1) chem(i,k,j,p_ant2_o)=0.0 + if (p_ant3_o.gt.1) chem(i,k,j,p_ant3_o)=0.0 + if (p_ant4_o.gt.1) chem(i,k,j,p_ant4_o)=0.0 + if (p_biog1_c.gt.1) chem(i,k,j,p_biog1_c)=0.0 + if (p_biog2_c.gt.1) chem(i,k,j,p_biog2_c)=0.0 + if (p_biog3_c.gt.1) chem(i,k,j,p_biog3_c)=0.0 + if (p_biog4_c.gt.1) chem(i,k,j,p_biog4_c)=0.0 + if (p_biog1_o.gt.1) chem(i,k,j,p_biog1_o)=0.0 + if (p_biog2_o.gt.1) chem(i,k,j,p_biog2_o)=0.0 + if (p_biog3_o.gt.1) chem(i,k,j,p_biog3_o)=0.0 + if (p_biog4_o.gt.1) chem(i,k,j,p_biog4_o)=0.0 + + if (p_pcg1_b_c_a01.gt.1) chem(i,k,j,p_pcg1_b_c_a01)=0.0 + if (p_pcg1_b_o_a01.gt.1) chem(i,k,j,p_pcg1_b_o_a01)=0.0 + if (p_opcg1_b_c_a01.gt.1) chem(i,k,j,p_opcg1_b_c_a01)=0.0 + if (p_opcg1_b_o_a01.gt.1) chem(i,k,j,p_opcg1_b_o_a01)=0.0 + if (p_pcg1_f_c_a01.gt.1) chem(i,k,j,p_pcg1_f_c_a01)=0.0 + if (p_pcg1_f_o_a01.gt.1) chem(i,k,j,p_pcg1_f_o_a01)=0.0 + if (p_opcg1_f_c_a01.gt.1) chem(i,k,j,p_opcg1_f_c_a01)=0.0 + if (p_opcg1_f_o_a01.gt.1) chem(i,k,j,p_opcg1_f_o_a01)=0.0 + if (p_ant1_c_a01.gt.1) chem(i,k,j,p_ant1_c_a01)=0.0 + if (p_biog1_c_a01.gt.1) chem(i,k,j,p_biog1_c_a01)=0.0 + + if (p_pcg1_b_c_a02.gt.1) chem(i,k,j,p_pcg1_b_c_a02)=0.0 + if (p_pcg1_b_o_a02.gt.1) chem(i,k,j,p_pcg1_b_o_a02)=0.0 + if (p_opcg1_b_c_a02.gt.1) chem(i,k,j,p_opcg1_b_c_a02)=0.0 + if (p_opcg1_b_o_a02.gt.1) chem(i,k,j,p_opcg1_b_o_a02)=0.0 + if (p_pcg1_f_c_a02.gt.1) chem(i,k,j,p_pcg1_f_c_a02)=0.0 + if (p_pcg1_f_o_a02.gt.1) chem(i,k,j,p_pcg1_f_o_a02)=0.0 + if (p_opcg1_f_c_a02.gt.1) chem(i,k,j,p_opcg1_f_c_a02)=0.0 + if (p_opcg1_f_o_a02.gt.1) chem(i,k,j,p_opcg1_f_o_a02)=0.0 + if (p_ant1_c_a02.gt.1) chem(i,k,j,p_ant1_c_a02)=0.0 + if (p_biog1_c_a02.gt.1) chem(i,k,j,p_biog1_c_a02)=0.0 + + if (p_pcg1_b_c_a03.gt.1) chem(i,k,j,p_pcg1_b_c_a03)=0.0 + if (p_pcg1_b_o_a03.gt.1) chem(i,k,j,p_pcg1_b_o_a03)=0.0 + if (p_opcg1_b_c_a03.gt.1) chem(i,k,j,p_opcg1_b_c_a03)=0.0 + if (p_opcg1_b_o_a03.gt.1) chem(i,k,j,p_opcg1_b_o_a03)=0.0 + if (p_pcg1_f_c_a03.gt.1) chem(i,k,j,p_pcg1_f_c_a03)=0.0 + if (p_pcg1_f_o_a03.gt.1) chem(i,k,j,p_pcg1_f_o_a03)=0.0 + if (p_opcg1_f_c_a03.gt.1) chem(i,k,j,p_opcg1_f_c_a03)=0.0 + if (p_opcg1_f_o_a03.gt.1) chem(i,k,j,p_opcg1_f_o_a03)=0.0 + if (p_ant1_c_a03.gt.1) chem(i,k,j,p_ant1_c_a03)=0.0 + if (p_biog1_c_a03.gt.1) chem(i,k,j,p_biog1_c_a03)=0.0 + + if (p_pcg1_b_c_a04.gt.1) chem(i,k,j,p_pcg1_b_c_a04)=0.0 + if (p_pcg1_b_o_a04.gt.1) chem(i,k,j,p_pcg1_b_o_a04)=0.0 + if (p_opcg1_b_c_a04.gt.1) chem(i,k,j,p_opcg1_b_c_a04)=0.0 + if (p_opcg1_b_o_a04.gt.1) chem(i,k,j,p_opcg1_b_o_a04)=0.0 + if (p_pcg1_f_c_a04.gt.1) chem(i,k,j,p_pcg1_f_c_a04)=0.0 + if (p_pcg1_f_o_a04.gt.1) chem(i,k,j,p_pcg1_f_o_a04)=0.0 + if (p_opcg1_f_c_a04.gt.1) chem(i,k,j,p_opcg1_f_c_a04)=0.0 + if (p_opcg1_f_o_a04.gt.1) chem(i,k,j,p_opcg1_f_o_a04)=0.0 + if (p_ant1_c_a04.gt.1) chem(i,k,j,p_ant1_c_a04)=0.0 + if (p_biog1_c_a04.gt.1) chem(i,k,j,p_biog1_c_a04)=0.0 + + if (p_pcg1_b_c_a05.gt.1) chem(i,k,j,p_pcg1_b_c_a05)=0.0 + if (p_pcg1_b_o_a05.gt.1) chem(i,k,j,p_pcg1_b_o_a05)=0.0 + if (p_opcg1_b_c_a05.gt.1) chem(i,k,j,p_opcg1_b_c_a05)=0.0 + if (p_opcg1_b_o_a05.gt.1) chem(i,k,j,p_opcg1_b_o_a05)=0.0 + if (p_pcg1_f_c_a05.gt.1) chem(i,k,j,p_pcg1_f_c_a05)=0.0 + if (p_pcg1_f_o_a05.gt.1) chem(i,k,j,p_pcg1_f_o_a05)=0.0 + if (p_opcg1_f_c_a05.gt.1) chem(i,k,j,p_opcg1_f_c_a05)=0.0 + if (p_opcg1_f_o_a05.gt.1) chem(i,k,j,p_opcg1_f_o_a05)=0.0 + if (p_ant1_c_a05.gt.1) chem(i,k,j,p_ant1_c_a05)=0.0 + if (p_biog1_c_a05.gt.1) chem(i,k,j,p_biog1_c_a05)=0.0 + + if (p_pcg1_b_c_a06.gt.1) chem(i,k,j,p_pcg1_b_c_a06)=0.0 + if (p_pcg1_b_o_a06.gt.1) chem(i,k,j,p_pcg1_b_o_a06)=0.0 + if (p_opcg1_b_c_a06.gt.1) chem(i,k,j,p_opcg1_b_c_a06)=0.0 + if (p_opcg1_b_o_a06.gt.1) chem(i,k,j,p_opcg1_b_o_a06)=0.0 + if (p_pcg1_f_c_a06.gt.1) chem(i,k,j,p_pcg1_f_c_a06)=0.0 + if (p_pcg1_f_o_a06.gt.1) chem(i,k,j,p_pcg1_f_o_a06)=0.0 + if (p_opcg1_f_c_a06.gt.1) chem(i,k,j,p_opcg1_f_c_a06)=0.0 + if (p_opcg1_f_o_a06.gt.1) chem(i,k,j,p_opcg1_f_o_a06)=0.0 + if (p_ant1_c_a06.gt.1) chem(i,k,j,p_ant1_c_a06)=0.0 + if (p_biog1_c_a06.gt.1) chem(i,k,j,p_biog1_c_a06)=0.0 + + if (p_pcg1_b_c_a07.gt.1) chem(i,k,j,p_pcg1_b_c_a07)=0.0 + if (p_pcg1_b_o_a07.gt.1) chem(i,k,j,p_pcg1_b_o_a07)=0.0 + if (p_opcg1_b_c_a07.gt.1) chem(i,k,j,p_opcg1_b_c_a07)=0.0 + if (p_opcg1_b_o_a07.gt.1) chem(i,k,j,p_opcg1_b_o_a07)=0.0 + if (p_pcg1_f_c_a07.gt.1) chem(i,k,j,p_pcg1_f_c_a07)=0.0 + if (p_pcg1_f_o_a07.gt.1) chem(i,k,j,p_pcg1_f_o_a07)=0.0 + if (p_opcg1_f_c_a07.gt.1) chem(i,k,j,p_opcg1_f_c_a07)=0.0 + if (p_opcg1_f_o_a07.gt.1) chem(i,k,j,p_opcg1_f_o_a07)=0.0 + if (p_ant1_c_a07.gt.1) chem(i,k,j,p_ant1_c_a07)=0.0 + if (p_biog1_c_a07.gt.1) chem(i,k,j,p_biog1_c_a07)=0.0 + + if (p_pcg1_b_c_a08.gt.1) chem(i,k,j,p_pcg1_b_c_a08)=0.0 + if (p_pcg1_b_o_a08.gt.1) chem(i,k,j,p_pcg1_b_o_a08)=0.0 + if (p_opcg1_b_c_a08.gt.1) chem(i,k,j,p_opcg1_b_c_a08)=0.0 + if (p_opcg1_b_o_a08.gt.1) chem(i,k,j,p_opcg1_b_o_a08)=0.0 + if (p_pcg1_f_c_a08.gt.1) chem(i,k,j,p_pcg1_f_c_a08)=0.0 + if (p_pcg1_f_o_a08.gt.1) chem(i,k,j,p_pcg1_f_o_a08)=0.0 + if (p_opcg1_f_c_a08.gt.1) chem(i,k,j,p_opcg1_f_c_a08)=0.0 + if (p_opcg1_f_o_a08.gt.1) chem(i,k,j,p_opcg1_f_o_a08)=0.0 + if (p_ant1_c_a08.gt.1) chem(i,k,j,p_ant1_c_a08)=0.0 + if (p_biog1_c_a08.gt.1) chem(i,k,j,p_biog1_c_a08)=0.0 + + + + if (p_pcg1_b_c_cw01.gt.1) chem(i,k,j,p_pcg1_b_c_cw01)=0.0 + if (p_pcg1_b_o_cw01.gt.1) chem(i,k,j,p_pcg1_b_o_cw01)=0.0 + if (p_opcg1_b_c_cw01.gt.1) chem(i,k,j,p_opcg1_b_c_cw01)=0.0 + if (p_opcg1_b_o_cw01.gt.1) chem(i,k,j,p_opcg1_b_o_cw01)=0.0 + if (p_pcg1_f_c_cw01.gt.1) chem(i,k,j,p_pcg1_f_c_cw01)=0.0 + if (p_pcg1_f_o_cw01.gt.1) chem(i,k,j,p_pcg1_f_o_cw01)=0.0 + if (p_opcg1_f_c_cw01.gt.1) chem(i,k,j,p_opcg1_f_c_cw01)=0.0 + if (p_opcg1_f_o_cw01.gt.1) chem(i,k,j,p_opcg1_f_o_cw01)=0.0 + if (p_ant1_c_cw01.gt.1) chem(i,k,j,p_ant1_c_cw01)=0.0 + if (p_biog1_c_cw01.gt.1) chem(i,k,j,p_biog1_c_cw01)=0.0 + + if (p_pcg1_b_c_cw02.gt.1) chem(i,k,j,p_pcg1_b_c_cw02)=0.0 + if (p_pcg1_b_o_cw02.gt.1) chem(i,k,j,p_pcg1_b_o_cw02)=0.0 + if (p_opcg1_b_c_cw02.gt.1) chem(i,k,j,p_opcg1_b_c_cw02)=0.0 + if (p_opcg1_b_o_cw02.gt.1) chem(i,k,j,p_opcg1_b_o_cw02)=0.0 + if (p_pcg1_f_c_cw02.gt.1) chem(i,k,j,p_pcg1_f_c_cw02)=0.0 + if (p_pcg1_f_o_cw02.gt.1) chem(i,k,j,p_pcg1_f_o_cw02)=0.0 + if (p_opcg1_f_c_cw02.gt.1) chem(i,k,j,p_opcg1_f_c_cw02)=0.0 + if (p_opcg1_f_o_cw02.gt.1) chem(i,k,j,p_opcg1_f_o_cw02)=0.0 + if (p_ant1_c_cw02.gt.1) chem(i,k,j,p_ant1_c_cw02)=0.0 + if (p_biog1_c_cw02.gt.1) chem(i,k,j,p_biog1_c_cw02)=0.0 + + if (p_pcg1_b_c_cw03.gt.1) chem(i,k,j,p_pcg1_b_c_cw03)=0.0 + if (p_pcg1_b_o_cw03.gt.1) chem(i,k,j,p_pcg1_b_o_cw03)=0.0 + if (p_opcg1_b_c_cw03.gt.1) chem(i,k,j,p_opcg1_b_c_cw03)=0.0 + if (p_opcg1_b_o_cw03.gt.1) chem(i,k,j,p_opcg1_b_o_cw03)=0.0 + if (p_pcg1_f_c_cw03.gt.1) chem(i,k,j,p_pcg1_f_c_cw03)=0.0 + if (p_pcg1_f_o_cw03.gt.1) chem(i,k,j,p_pcg1_f_o_cw03)=0.0 + if (p_opcg1_f_c_cw03.gt.1) chem(i,k,j,p_opcg1_f_c_cw03)=0.0 + if (p_opcg1_f_o_cw03.gt.1) chem(i,k,j,p_opcg1_f_o_cw03)=0.0 + if (p_ant1_c_cw03.gt.1) chem(i,k,j,p_ant1_c_cw03)=0.0 + if (p_biog1_c_cw03.gt.1) chem(i,k,j,p_biog1_c_cw03)=0.0 + + if (p_pcg1_b_c_cw04.gt.1) chem(i,k,j,p_pcg1_b_c_cw04)=0.0 + if (p_pcg1_b_o_cw04.gt.1) chem(i,k,j,p_pcg1_b_o_cw04)=0.0 + if (p_opcg1_b_c_cw04.gt.1) chem(i,k,j,p_opcg1_b_c_cw04)=0.0 + if (p_opcg1_b_o_cw04.gt.1) chem(i,k,j,p_opcg1_b_o_cw04)=0.0 + if (p_pcg1_f_c_cw04.gt.1) chem(i,k,j,p_pcg1_f_c_cw04)=0.0 + if (p_pcg1_f_o_cw04.gt.1) chem(i,k,j,p_pcg1_f_o_cw04)=0.0 + if (p_opcg1_f_c_cw04.gt.1) chem(i,k,j,p_opcg1_f_c_cw04)=0.0 + if (p_opcg1_f_o_cw04.gt.1) chem(i,k,j,p_opcg1_f_o_cw04)=0.0 + if (p_ant1_c_cw04.gt.1) chem(i,k,j,p_ant1_c_cw04)=0.0 + if (p_biog1_c_cw04.gt.1) chem(i,k,j,p_biog1_c_cw04)=0.0 + + if (p_pcg1_b_c_cw05.gt.1) chem(i,k,j,p_pcg1_b_c_cw05)=0.0 + if (p_pcg1_b_o_cw05.gt.1) chem(i,k,j,p_pcg1_b_o_cw05)=0.0 + if (p_opcg1_b_c_cw05.gt.1) chem(i,k,j,p_opcg1_b_c_cw05)=0.0 + if (p_opcg1_b_o_cw05.gt.1) chem(i,k,j,p_opcg1_b_o_cw05)=0.0 + if (p_pcg1_f_c_cw05.gt.1) chem(i,k,j,p_pcg1_f_c_cw05)=0.0 + if (p_pcg1_f_o_cw05.gt.1) chem(i,k,j,p_pcg1_f_o_cw05)=0.0 + if (p_opcg1_f_c_cw05.gt.1) chem(i,k,j,p_opcg1_f_c_cw05)=0.0 + if (p_opcg1_f_o_cw05.gt.1) chem(i,k,j,p_opcg1_f_o_cw05)=0.0 + if (p_ant1_c_cw05.gt.1) chem(i,k,j,p_ant1_c_cw05)=0.0 + if (p_biog1_c_cw05.gt.1) chem(i,k,j,p_biog1_c_cw05)=0.0 + + if (p_pcg1_b_c_cw06.gt.1) chem(i,k,j,p_pcg1_b_c_cw06)=0.0 + if (p_pcg1_b_o_cw06.gt.1) chem(i,k,j,p_pcg1_b_o_cw06)=0.0 + if (p_opcg1_b_c_cw06.gt.1) chem(i,k,j,p_opcg1_b_c_cw06)=0.0 + if (p_opcg1_b_o_cw06.gt.1) chem(i,k,j,p_opcg1_b_o_cw06)=0.0 + if (p_pcg1_f_c_cw06.gt.1) chem(i,k,j,p_pcg1_f_c_cw06)=0.0 + if (p_pcg1_f_o_cw06.gt.1) chem(i,k,j,p_pcg1_f_o_cw06)=0.0 + if (p_opcg1_f_c_cw06.gt.1) chem(i,k,j,p_opcg1_f_c_cw06)=0.0 + if (p_opcg1_f_o_cw06.gt.1) chem(i,k,j,p_opcg1_f_o_cw06)=0.0 + if (p_ant1_c_cw06.gt.1) chem(i,k,j,p_ant1_c_cw06)=0.0 + if (p_biog1_c_cw06.gt.1) chem(i,k,j,p_biog1_c_cw06)=0.0 + + if (p_pcg1_b_c_cw07.gt.1) chem(i,k,j,p_pcg1_b_c_cw07)=0.0 + if (p_pcg1_b_o_cw07.gt.1) chem(i,k,j,p_pcg1_b_o_cw07)=0.0 + if (p_opcg1_b_c_cw07.gt.1) chem(i,k,j,p_opcg1_b_c_cw07)=0.0 + if (p_opcg1_b_o_cw07.gt.1) chem(i,k,j,p_opcg1_b_o_cw07)=0.0 + if (p_pcg1_f_c_cw07.gt.1) chem(i,k,j,p_pcg1_f_c_cw07)=0.0 + if (p_pcg1_f_o_cw07.gt.1) chem(i,k,j,p_pcg1_f_o_cw07)=0.0 + if (p_opcg1_f_c_cw07.gt.1) chem(i,k,j,p_opcg1_f_c_cw07)=0.0 + if (p_opcg1_f_o_cw07.gt.1) chem(i,k,j,p_opcg1_f_o_cw07)=0.0 + if (p_ant1_c_cw07.gt.1) chem(i,k,j,p_ant1_c_cw07)=0.0 + if (p_biog1_c_cw07.gt.1) chem(i,k,j,p_biog1_c_cw07)=0.0 + + if (p_pcg1_b_c_cw08.gt.1) chem(i,k,j,p_pcg1_b_c_cw08)=0.0 + if (p_pcg1_b_o_cw08.gt.1) chem(i,k,j,p_pcg1_b_o_cw08)=0.0 + if (p_opcg1_b_c_cw08.gt.1) chem(i,k,j,p_opcg1_b_c_cw08)=0.0 + if (p_opcg1_b_o_cw08.gt.1) chem(i,k,j,p_opcg1_b_o_cw08)=0.0 + if (p_pcg1_f_c_cw08.gt.1) chem(i,k,j,p_pcg1_f_c_cw08)=0.0 + if (p_pcg1_f_o_cw08.gt.1) chem(i,k,j,p_pcg1_f_o_cw08)=0.0 + if (p_opcg1_f_c_cw08.gt.1) chem(i,k,j,p_opcg1_f_c_cw08)=0.0 + if (p_opcg1_f_o_cw08.gt.1) chem(i,k,j,p_opcg1_f_o_cw08)=0.0 + if (p_ant1_c_cw08.gt.1) chem(i,k,j,p_ant1_c_cw08)=0.0 + if (p_biog1_c_cw08.gt.1) chem(i,k,j,p_biog1_c_cw08)=0.0 + enddo + enddo + enddo + endif + !BSINGH - ENDS END SELECT kpp_select endif @@ -862,7 +1559,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, enddo endif endif - CASE (GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP) + CASE (GOCARTRACM_KPP,GOCARTRADM2) CALL wrf_debug(15,'call GOCARTRACM_KPP chem/aerosols initialization') ch_dust(:,:)=0.8D-9 ch_ss(:,:)=1. @@ -968,7 +1665,8 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ch_dust(:,:) = 0.8D-9 CASE (RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RADM2SORG_KPP, & - RACMSORG_KPP, RACM_ESRLSORG_KPP, CBMZSORG, CBMZSORG_AQ) + RACMSORG_KPP, RACM_ESRLSORG_KPP, CBMZSORG, CBMZSORG_AQ, & + CB05_SORG_AQ_KPP) CALL wrf_debug(15,'call MADE/SORGAM aerosols initialization') call aerosols_sorgam_init(chem,convfac,z_at_w, & @@ -994,6 +1692,33 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif chem(its:ite,kts:min(kte,kde-1),jts:jte,:)=max(chem(its:ite,kts:min(kte,kde-1),jts:jte,:),epsilc) ! + CASE (CB05_SORG_VBS_AQ_KPP) + CALL wrf_debug(15,'call MADE/SOA_VBS aerosols initialization') + + call aerosols_sorgam_vbs_init(chem,convfac,z_at_w, & + pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & + tsoa,asoa,bsoa, & + chem_in_opt,config_flags%aer_ic_opt,is_aerosol, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, config_flags ) +!...Convert aerosols to mixing ratio + if( .NOT. config_flags%restart ) then + if(config_flags%chem_in_opt == 0 .and. num_chem.gt.numgas)then + do l=numgas+1,num_chem + do j=jts,jte + do k=kts,kte + kk = min(k,kde-1) + do i=its,ite + chem(i,k,j,l)=chem(i,kk,j,l)*alt(i,kk,j) + enddo + enddo + enddo + enddo + endif + endif + chem(its:ite,kts:min(kte,kde-1),jts:jte,:)=max(chem(its:ite,kts:min(kte,kde-1),jts:jte,:),epsilc) + CASE (RACM_SOA_VBS_KPP) CALL wrf_debug(15,'call MADE/SOA_VBS aerosols initialization') @@ -1047,9 +1772,12 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP,CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) + SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + MOZART_MOSAIC_4BIN_KPP,MOZART_MOSAIC_4BIN_AQ_KPP, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, & !BSINGH(12/03/2013): Added SAPRC 8 bin + SAPRC99_MOSAIC_8BIN_VBS2_KPP) !BSINGH(04/03/2014): Added SAPRC 8 bin non-aq call wrf_debug(15,'call MOSAIC aerosols initialization') - call init_data_mosaic_asect(config_flags%n2o5_hetchem,is_aerosol) + call init_data_mosaic_asect(id,config_flags%n2o5_hetchem,is_aerosol) if(config_flags%chem_in_opt == 0 )then if( .NOT. config_flags%restart ) & call mosaic_init_wrf_mixrats( & @@ -1065,7 +1793,9 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, progn_sanity_check : SELECT CASE(config_flags%chem_opt) CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_DMS_4BIN_AQ, & - CBMZ_MOSAIC_DMS_8BIN_AQ,CBMZSORG_AQ,CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) + CBMZ_MOSAIC_DMS_8BIN_AQ,CBMZSORG_AQ,CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, & + MOZART_MOSAIC_4BIN_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, & + CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP) if( config_flags%progn /= 1 ) & call wrf_error_fatal( & "ERROR: When using a ..._AQ chemistry package, progn must be 1") @@ -1132,8 +1862,13 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ! Initialize the cloud droplet number and mass ! if( (.not.config_flags%restart) .and. (config_flags%progn > 0) ) then +!BSINGH(12/03/2013): send chem_in_opt as an arg +! For chem_in_opt==1 modified the mosaic_mixactivate_init +! The sum of mass from interstitial and cloud borne aerosols is attributed to interstitial aerosols +! Cloud drop number and cloud aerosol mass are then initialized to zero call mosaic_mixactivate_init( & config_flags, chem, scalar, & + chem_in_opt, & !BSINGH(12/03/2013):send chem_in_opt as an arg ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) end if @@ -1279,7 +2014,7 @@ subroutine print_chem_species_index( chem_opt ) ! Gas species... ! select case (chem_opt) - case (RADM2, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2_KPP, RADM2SORG_KPP, GOCARTRADM2,GOCARTRADM2_KPP) + case (RADM2, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2_KPP, RADM2SORG_KPP, GOCARTRADM2) print*,p_so2,"so2" print*,p_sulf,"sulf" print*,p_no2,"no2" @@ -1510,13 +2245,99 @@ subroutine print_chem_species_index( chem_opt ) print*,p_isopn,"isopn" print*,p_isopo2,"isopo2" + case (SAPRC99_MOSAIC_8BIN_VBS2_KPP) !BSINGh - Added for 8bin vbs pkg + print*,p_o3,"o3" + print*,p_h2o2,"h2o2" + print*,p_no,"no" + print*,p_no2,"no2" + print*,p_no3,"no3" + print*,p_n2o5,"n2o5" + print*,p_hono,"hono" + print*,p_hno3,"hno3" + print*,p_hno4,"hno4" + print*,p_so2,"so2" + print*,p_h2so4,"h2so4" + print*,p_co,"co" + print*,p_hcho,"hcho" + print*,p_ccho,"ccho" + print*,p_rcho,"rcho" + print*,p_acet,"acet" + print*,p_mek,"mek" + print*,p_hcooh,"hcooh" + print*,p_meoh,"meoh" + print*,p_etoh,"etoh" + print*,p_cco_oh,"cco_oh" + print*,p_rco_oh,"rco_oh" + print*,p_gly,"gly" + print*,p_mgly,"mgly" + print*,p_bacl,"bacl" + print*,p_cres,"cres" + print*,p_bald,"bald" + print*,p_isoprod,"isoprod" + print*,p_methacro,"methacro" + print*,p_mvk,"mvk" + print*,p_prod2,"prod2" + print*,p_dcb1,"dcb1" + print*,p_dcb2,"dcb2" + print*,p_dcb3,"dcb3" + print*,p_ethene,"ethene" + print*,p_isoprene,"isoprene" + print*,p_c2h6,"c2h6" + print*,p_c3h8,"c3h8" + print*,p_c2h2,"c2h2" + print*,p_c3h6,"c3h6" + print*,p_alk3,"alk3" + print*,p_alk4,"alk4" + print*,p_alk5,"alk5" + print*,p_aro1,"aro1" + print*,p_aro2,"aro2" + print*,p_ole1,"ole1" + print*,p_ole2,"ole2" + print*,p_terp,"terp" + print*,p_sesq,"sesq" + print*,p_rno3,"rno3" + print*,p_nphe,"nphe" + print*,p_phen,"phen" + print*,p_pan,"pan" + print*,p_pan2,"pan2" + print*,p_pbzn,"pbzn" + print*,p_ma_pan,"ma_pan" + print*,p_bc_spr,"bc_spr" + print*,p_oc_spr,"oc_spr" + print*,p_ssf,"ssf" + print*,p_ssc,"ssc" + print*,p_pm10_spr,"pm10_spr" + print*,p_pm25_spr,"pm25_spr" + print*,p_dms,"dms" + print*,p_dst1,"dst1" + print*,p_dst2,"dst2" + print*,p_dst3,"dst3" + print*,p_co2,"co2" + print*,p_cco_ooh,"cco_ooh" + print*,p_rco_o2,"rco_o2" + print*,p_rco_ooh,"rco_ooh" + print*,p_xn,"xn" + print*,p_xc,"xc" + print*,p_ho,"oh" + print*,p_ho2,"ho2" + print*,p_c_o2,"c_o2" + print*,p_cooh,"cooh" + print*,p_rooh,"rooh" + print*,p_ro2_r,"ro2_r" + print*,p_r2o2,"r2o2" + print*,p_ro2_n,"ro2_n" + print*,p_cco_o2,"cco_o2" + print*,p_bzco_o2,"bzco_o2" + print*,p_ma_rco3,"ma_rco3" + print*,p_ch4,"ch4" + select case (chem_opt) case( CBMZ_CAM_MAM3_NOAQ, CBMZ_CAM_MAM3_AQ, CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM7_AQ ) print*,p_soag,"soag" end select end select - case (CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_4BIN_VBS2_KPP) + case (CBMZ_MOSAIC_KPP) print*,p_so2,"so2" print*,p_sulf,"sulf" print*,p_no2,"no2" @@ -1590,7 +2411,7 @@ subroutine print_chem_species_index( chem_opt ) print*,p_api,"api" print*,p_lim,"lim" - case (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP) + case (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP)!BSINGH(12/03/2013): Added SAPRC 8 bin print*,p_o3,"o3" print*,p_h2o2,"h2o2" print*,p_no,"no" @@ -1675,14 +2496,16 @@ subroutine print_chem_species_index( chem_opt ) print*,p_bzco_o2,"bzco_o2" print*,p_ma_rco3,"ma_rco3" print*,p_ch4,"ch4" - + case (CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP) + print*,p_nh3,"nh3" end select ! ! Aerosol species... ! select case (chem_opt) case (RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & - RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP, RACM_ESRLSORG_KPP, CBMZSORG, CBMZSORG_AQ,RACMSORG) + RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP, RACM_ESRLSORG_KPP, CBMZSORG, CBMZSORG_AQ,RACMSORG, & + CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP) print*,p_so4aj,"so4aj" print*,p_so4ai,"so4ai" print*,p_nh4aj,"nh4aj" @@ -1762,7 +2585,7 @@ subroutine print_chem_species_index( chem_opt ) print*,p_hysw_a04,"hysw_a04" print*,p_water_a04,"water_a04" print*,p_num_a04,"num_a04" - case (MOZART_MOSAIC_4BIN_VBS0_KPP ) + case (MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP) print*,p_no3_a01,"no3_a01" print*,p_cl_a01,"cl_a01" print*,p_nh4_a01,"nh4_a01" diff --git a/wrfv2_fire/chem/cloudchem_driver.F b/wrfv2_fire/chem/cloudchem_driver.F index 80342d2c..0b216818 100644 --- a/wrfv2_fire/chem/cloudchem_driver.F +++ b/wrfv2_fire/chem/cloudchem_driver.F @@ -35,8 +35,10 @@ SUBROUTINE cloudchem_driver( & gas_pcnst_pos => gas_pcnst_modal_aero_pos USE module_mosaic_cloudchem, only: mosaic_cloudchem_driver USE module_sorgam_cloudchem, only: sorgam_cloudchem_driver + USE module_sorgam_vbs_cloudchem, only: sorgam_vbs_cloudchem_driver USE module_cam_mam_cloudchem, only: cam_mam_cloudchem_driver USE module_sorgam_aqchem, only: sorgam_aqchem_driver + USE module_sorgam_vbs_aqchem, only: sorgam_vbs_aqchem_driver ! This driver calls subroutines for wet scavenging. ! @@ -188,7 +190,9 @@ SUBROUTINE cloudchem_driver( & CASE ( CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, & - CBMZ_MOSAIC_DMS_8BIN_AQ, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) + CBMZ_MOSAIC_DMS_8BIN_AQ, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, & + MOZART_MOSAIC_4BIN_AQ_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP)!BSINGH(12/03/2013): Added SAPRC 8 bin call wrf_debug(15, & 'cloudchem_driver calling mosaic_cloudchem_driver') @@ -230,8 +234,22 @@ SUBROUTINE cloudchem_driver( & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE ( CB05_SORG_VBS_AQ_KPP ) - CASE ( RADM2SORG_AQCHEM, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP ) + call wrf_debug(15, & + 'cloudchem_driver calling sorgam_vbs_aqchem_driver') + call sorgam_vbs_aqchem_driver( & + id, ktau, ktauc, dtstepc, config_flags, & + p_phy, t_phy, rho_phy, alt, dz8w, & + moist, chem, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + + CASE ( RADM2SORG_AQCHEM, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, & + CB05_SORG_AQ_KPP ) call wrf_debug(15, & 'cloudchem_driver calling sorgam_aqchem_driver') diff --git a/wrfv2_fire/chem/convert_emiss.F b/wrfv2_fire/chem/convert_emiss.F index 189e5632..08f214b0 100644 --- a/wrfv2_fire/chem/convert_emiss.F +++ b/wrfv2_fire/chem/convert_emiss.F @@ -36,14 +36,6 @@ PROGRAM convert_emissions #if (EM_CORE ==1) USE module_big_step_utilities_em #endif -!#ifdef WRF_CHEM -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!! for chemistry -! USE module_input_chem_data -!! USE module_input_chem_bioemiss -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!#endif - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPLICIT NONE @@ -130,7 +122,11 @@ END SUBROUTINE Setup_Timekeeping REAL :: cen_lat, cen_lon, moad_cen_lat, truelat1, truelat2, gmt, stand_lon, dum1 INTEGER :: map_proj, julyr, julday, iswater, isice, isurban, isoilwater - INTEGER :: iswaterr,itest,beg_day,beg_hour +! Add a logical leap-year variable as we want to calculate Julian day from the volc_d01 file + LOGICAL :: LEAP +! Add beg_yr, beg_mon, and beg_jul to calculate the eruption Julian day and hour from the +! volc_d01 data file as it can be different than the run start day and hour. + INTEGER :: iswaterr,itest,beg_yr,beg_mon,beg_jul,beg_day,beg_hour INTEGER :: itime = 0 INTEGER :: inew_nei = 0 INTEGER :: inew_ch4 = 0 ! set to 1 if using 2011 NEI emissions @@ -649,10 +645,25 @@ END SUBROUTINE Setup_Timekeeping CALL geth_julgmt ( config_flags%julyr , config_flags%julday , config_flags%gmt ) ! dname = YYYYMMDDHHMMSS ! 12345678901234 +! read in the eruption beg_yr and beg_mon from the volc_d01 data file + read(unit=dname2(1:4), FMT='(I4)')beg_yr + read(unit=dname2(5:6), FMT='(I2)')beg_mon read(unit=dname2(7:8), FMT='(I2)')beg_day read(unit=dname2(9:10), FMT='(I2)')beg_hour -! write(0,*)' DNAME = ',dname -! write(0,*)' DNAME2 = ',dname2,beg_day,beg_hour,config_flags%julday +! +! convert the date from the volc_d01 data file to Julian day + LEAP = .FALSE. + IF((MOD(beg_yr,4) .EQ. 0 .AND. MOD(beg_yr,100).NE.0 ).OR. MOD(beg_yr,400).EQ.0 ) THEN + LEAP = .TRUE. + ENDIF + IF (LEAP) THEN + K = 1 + ELSE + K = 2 + END IF + beg_jul = ((275*beg_mon)/9) - K*((beg_mon+9)/12) + beg_day - 30 + + write(0,*)' DNAME2 = ',dname2,beg_jul,beg_hour #ifdef DM_PARALLEL IF (wrf_dm_on_monitor()) THEN read(92)size_dist @@ -799,8 +810,8 @@ END SUBROUTINE Setup_Timekeeping grid%emis_vol(i,ko,j,p_e_vash10)=size_dist(10)*vert_mass_dist(ko)*ash_mass(i,j) if(config_flags%emiss_opt_vol == 2)grid%emis_vol(i,ko,j,p_e_vso2)=vert_mass_dist(ko)*so2_mass(i,j) enddo -! grid%erup_beg(i,j)=float(beg_day)*1000.+float(beg_hour) - grid%erup_beg(i,j)=float(grid%julday)*1000.+float(beg_hour) +! Changes made to Julian day from the volc_d01 file + grid%erup_beg(i,j)=float(beg_jul)*1000.+float(beg_hour) grid%erup_end(i,j)=grid%erup_beg(i,j)+erup_dt(i,j) write(0,*)'new mass=',sum(vert_mass_dist)*100.,x1 ! endif diff --git a/wrfv2_fire/chem/depend.chem b/wrfv2_fire/chem/depend.chem index 41f9538c..e00a0eda 100644 --- a/wrfv2_fire/chem/depend.chem +++ b/wrfv2_fire/chem/depend.chem @@ -1,6 +1,41 @@ # DEPENDENCIES : only dependencies after this line (don't remove the word DEPENDENCIES) -module_mixactivate_wrappers.o: ../phys/module_mixactivate.o module_data_sorgam.o module_data_soa_vbs.o +module_data_isrpia_data.o: + +module_data_ISRPIA.o: module_data_isrpia_data.o + +module_data_isrpia_asrc.o: + +module_data_isrpia_solut.o: + +module_data_isrpia_kmc198.o: + +module_data_isrpia_kmc223.o: + +module_data_isrpia_kmc248.o: + +module_data_isrpia_kmc273.o: + +module_data_isrpia_kmc298.o: + +module_data_isrpia_kmc323.o: + +module_data_isrpia_expnc.o: + +module_data_isrpia_caseg.o: + +isofwd.o: module_data_ISRPIA.o module_data_isrpia_caseg.o module_data_isrpia_casej.o + +isorev.o: module_data_ISRPIA.o + +isocom.o: module_data_ISRPIA.o module_data_isrpia_asrc.o module_data_isrpia_solut.o module_data_isrpia_kmc198.o module_data_isrpia_kmc223.o module_data_isrpia_kmc248.o module_data_isrpia_kmc273.o module_data_isrpia_kmc298.o module_data_isrpia_kmc323.o module_data_isrpia_expnc.o isofwd.o isorev.o + +moduleHETDATA.o : +moduleHETAERO.o : moduleHETDATA.o +moduleAERODATA.o : +aerorate_so2.o : moduleAERODATA.o moduleHETAERO.o + +module_mixactivate_wrappers.o: ../phys/module_mixactivate.o module_data_sorgam.o module_data_soa_vbs.o module_data_sorgam_vbs.o module_data_radm2.o: @@ -12,7 +47,7 @@ module_radm.o: module_data_sorgam.o module_data_radm2.o module_gocart_dust.o: ../phys/module_data_gocart_dust.o -module_gocart_dust_afwa.o: ../phys/module_data_gocart_dust.o +module_gocart_dust_afwa.o: ../phys/module_data_gocart_dust.o module_data_sorgam.o module_uoc_dust.o: module_qf03.o module_soilpsd.o @@ -54,12 +89,18 @@ module_cbmz_addemiss.o: module_aerosols_sorgam.o module_cbm4_addemiss.o: module_aerosols_sorgam.o +module_cb05_addemiss.o: module_aerosols_sorgam.o + module_cbmz_rodas_prep.o: module_cbmz_rodas3_solver.o module_data_cbmz.o module_cbmz_initmixrats.o: module_input_chem_data.o module_peg_util.o module_cbm4_initmixrats.o: module_input_chem_data.o module_peg_util.o +module_cb05_initmixrats.o: module_input_chem_data.o + +module_cb05_vbs_initmixrats.o: module_input_chem_data.o + module_phot_mad.o: module_data_radm2.o module_phot_fastj.o: module_mosaic_driver.o module_peg_util.o module_data_cbmz.o @@ -74,7 +115,7 @@ module_input_tracer.o: module_input_tracer_data.o module_input_chem_data.o module_input_tracer_data.o: -module_input_chem_data.o: module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_cam_mam_initmixrats.o +module_input_chem_data.o: module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_cam_mam_initmixrats.o module_data_sorgam_vbs.o module_input_chem_bioemiss.o: module_aerosols_sorgam.o module_aerosols_soa_vbs.o @@ -104,10 +145,14 @@ module_data_sorgam.o: module_data_radm2.o module_data_soa_vbs.o: module_data_radm2.o +module_data_sorgam_vbs.o: module_data_radm2.o + module_cbmz_lsodes_solver.o: module_peg_util.o module_cbmz_rodas3_solver.o: module_peg_util.o +module_chem_cup.o: module_mosaic_cloudchem.o + module_mosaic_csuesat.o: module_data_mosaic_asect.o: @@ -126,6 +171,8 @@ module_aerosols_sorgam.o: module_data_sorgam.o module_mosaic_addemiss.o module_r module_aerosols_soa_vbs.o: module_data_soa_vbs.o module_radm.o module_mosaic_addemiss.o +module_aerosols_sorgam_vbs.o: module_data_sorgam_vbs.o module_mosaic_wetscav.o + module_mosaic_drydep.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o module_mosaic_driver.o module_mosaic_initmixrats.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o @@ -150,6 +197,8 @@ module_mosaic_cloudchem.o: module_data_cmu_bulkaqchem.o module_cmu_bulkaqchem.o module_sorgam_cloudchem.o: module_data_cmu_bulkaqchem.o module_cmu_bulkaqchem.o module_data_sorgam.o module_aerosols_sorgam.o +module_sorgam_vbs_cloudchem.o: module_data_cmu_bulkaqchem.o module_cmu_bulkaqchem.o module_data_sorgam_vbs.o module_aerosols_sorgam_vbs.o + module_cam_mam_cloudchem.o: ../frame/module_state_description.o ../phys/module_cam_support.o ../phys/module_data_cam_mam_aero.o module_cam_mam_setsox.o ../phys/module_data_cam_mam_asect.o ../phys/module_cam_physconst.o ../phys/module_cam_constituents.o ../phys/module_cam_infnan.o ../phys/module_radiation_driver.o module_cam_mam_setsox.o: ../phys/module_cam_shr_kind_mod.o ../phys/module_cam_support.o ../phys/module_data_cam_mam_aero.o module_cam_mam_mo_chem_utls.o ../phys/module_data_cam_mam_asect.o ../phys/module_cam_physconst.o @@ -160,7 +209,7 @@ module_fastj_data.o: module_data_mosaic_other.o module_fastj_mie.o: module_peg_util.o module_data_mosaic_therm.o -module_optical_averaging.o: module_data_sorgam.o module_data_rrtmgaeropt.o module_data_gocart_seas.o module_peg_util.o +module_optical_averaging.o: module_data_sorgam.o module_data_rrtmgaeropt.o module_data_gocart_seas.o module_peg_util.o module_data_sorgam_vbs.o module_ctrans_grell.o: module_dep_simple.o module_input_chem_data.o @@ -190,7 +239,7 @@ module_cam_mam_aerchem_driver.o: ../phys/module_cam_support.o ../phys/module_dat module_cam_mam_addemiss.o: ../phys/module_cam_support.o ../phys/module_data_cam_mam_aero.o ../phys/module_data_cam_mam_asect.o module_cam_mam_init.o -module_cam_mam_init.o: ../phys/module_cam_support.o ../phys/module_data_cam_mam_aero.o ../phys/module_data_cam_mam_asect.o module_cam_mam_initaerodata.o module_cam_mam_initmixrats.o ../phys/module_cam_mp_ndrop.o ../phys/module_cam_constituents.o ../phys/module_cam_physconst.o ../phys/module_cam_infnan.o module_data_radm2.o module_cam_mam_cloudchem.o module_cam_mam_gas_wetdep_driver.o +module_cam_mam_init.o: ../phys/module_cam_shr_kind_mod.o ../frame/module_state_description.o ../phys/module_cam_physconst.o ../phys/module_cam_esinti.o ../phys/module_cam_support.o ../phys/module_data_cam_mam_aero.o module_cam_mam_initaerodata.o ../phys/module_cam_mp_ndrop.o module_cam_mam_cloudchem.o module_cam_mam_gas_wetdep_driver.o module_cam_mam_wetscav.o: ../phys/module_cam_shr_kind_mod.o ../phys/module_cam_support.o ../phys/module_data_cam_mam_aero.o ../frame/module_state_description.o ../phys/module_data_cam_mam_asect.o ../phys/module_radiation_driver.o ../phys/module_mp_cammgmp_driver.o module_cam_mam_mz_aerosols_intr.o module_cam_mam_wetdep.o ../phys/module_cam_infnan.o @@ -203,19 +252,21 @@ module_aer_drydep.o: module_data_sorgam.o module_aerosols_sorgam.o module_aeroso module_interpolate.o: -chemics_init.o: module_cbm4_initmixrats.o module_cbmz_initmixrats.o module_gocart_aerosols.o ../phys/module_data_gocart_dust.o module_data_gocart_seas.o module_data_gocartchem.o module_gocart_chem.o module_dep_simple.o module_ftuv_driver.o module_phot_mad.o module_gocart_chem.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_mixactivate_wrappers.o module_mosaic_driver.o module_input_chem_data.o module_cam_mam_init.o module_cam_mam_wetscav.o +chemics_init.o: module_cbm4_initmixrats.o module_cbmz_initmixrats.o module_gocart_aerosols.o ../phys/module_data_gocart_dust.o module_data_gocart_seas.o module_data_gocartchem.o module_gocart_chem.o module_dep_simple.o module_ftuv_driver.o module_phot_mad.o module_gocart_chem.o module_aerosols_sorgam.o module_aerosols_sorgam_vbs.o module_aerosols_soa_vbs.o module_mixactivate_wrappers.o module_mosaic_driver.o module_input_chem_data.o module_cam_mam_init.o module_cam_mam_wetscav.o module_tropopause.o: module_interpolate.o module_upper_bc_driver.o: module_tropopause.o -chem_driver.o: module_radm.o ../dyn_em/module_convtrans_prep.o module_chem_utilities.o module_data_radm2.o module_dep_simple.o module_bioemi_simple.o module_vertmx_wrf.o module_phot_mad.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_data_cbmz.o module_cbmz.o module_wetscav_driver.o dry_dep_driver.o emissions_driver.o module_input_tracer.o module_input_tracer_data.o module_tropopause.o module_upper_bc_driver.o module_ctrans_grell.o module_data_soa_vbs.o module_aer_opt_out.o module_data_sorgam.o module_gocart_so2so4.o ../phys/module_cu_camzm_driver.o module_cam_mam_gas_wetdep_driver.o module_dust_load.o +chem_driver.o: module_radm.o ../dyn_em/module_convtrans_prep.o module_chem_utilities.o module_data_radm2.o module_dep_simple.o module_bioemi_simple.o module_vertmx_wrf.o module_phot_mad.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_aerosols_sorgam_vbs.o module_data_cbmz.o module_cbmz.o module_wetscav_driver.o dry_dep_driver.o emissions_driver.o module_input_tracer.o module_input_tracer_data.o module_tropopause.o module_upper_bc_driver.o module_ctrans_grell.o module_data_soa_vbs.o module_aer_opt_out.o module_data_sorgam.o module_gocart_so2so4.o ../phys/module_cu_camzm_driver.o module_cam_mam_gas_wetdep_driver.o module_dust_load.o module_chem_cup.o + +aerosol_driver.o: module_data_sorgam.o module_aerosols_sorgam.o module_data_soa_vbs.o module_aerosols_soa_vbs.o module_aerosols_sorgam_vbs.o module_mosaic_driver.o -chemics_init.o: module_cbm4_initmixrats.o module_cbmz_initmixrats.o module_gocart_aerosols.o ../phys/module_data_gocart_dust.o module_data_gocart_seas.o module_data_gocartchem.o module_gocart_chem.o module_dep_simple.o module_ftuv_driver.o module_phot_mad.o module_gocart_chem.o module_aerosols_sorgam.o module_mixactivate_wrappers.o module_mosaic_driver.o module_input_chem_data.o module_tropopause.o module_upper_bc_driver.o module_cam_mam_init.o module_cam_mam_wetscav.o +module_sorgam_aqchem.o: module_ctrans_aqchem.o module_data_sorgam.o -aerosol_driver.o: module_data_sorgam.o module_aerosols_sorgam.o module_data_soa_vbs.o module_aerosols_soa_vbs.o module_mosaic_driver.o +module_sorgam_vbs_aqchem.o: module_ctrans_aqchem.o module_data_sorgam_vbs.o -cloudchem_driver.o: module_mosaic_cloudchem.o module_sorgam_cloudchem.o +cloudchem_driver.o: module_mosaic_cloudchem.o module_sorgam_cloudchem.o module_sorgam_vbs_cloudchem.o module_sorgam_vbs_aqchem.o photolysis_driver.o: module_phot_mad.o module_phot_fastj.o module_ftuv_driver.o @@ -223,11 +274,11 @@ mechanism_driver.o: module_data_radm2.o module_radm.o module_aerosols_sorgam.o m optical_driver.o: module_optical_averaging.o module_peg_util.o -emissions_driver.o: module_add_emiss_burn.o module_data_radm2.o module_radm.o module_bioemi_simple.o module_bioemi_beis314.o module_bioemi_megan2.o module_emissions_anthropogenics.o module_cbmz_addemiss.o module_mosaic_addemiss.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_plumerise1.o module_gocart_dust.o module_gocart_dust_afwa.o module_uoc_dust.o module_gocart_seasalt.o module_ghg_fluxes.o module_lightning_nox_driver.o module_cam_mam_addemiss.o +emissions_driver.o: module_add_emiss_burn.o module_data_radm2.o module_radm.o module_bioemi_simple.o module_bioemi_beis314.o module_bioemi_megan2.o module_emissions_anthropogenics.o module_cbmz_addemiss.o module_cb05_addemiss.o module_mosaic_addemiss.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_aerosols_sorgam_vbs.o module_plumerise1.o module_gocart_dust.o module_gocart_dust_afwa.o module_uoc_dust.o module_gocart_seasalt.o module_ghg_fluxes.o module_lightning_nox_driver.o module_cam_mam_addemiss.o -dry_dep_driver.o: module_data_radm2.o module_aer_drydep.o module_dep_simple.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_mosaic_drydep.o ../phys/module_mixactivate.o module_cam_mam_drydep.o ../phys/module_data_cam_mam_asect.o ../phys/module_data_cam_mam_aero.o ../phys/module_cam_support.o +dry_dep_driver.o: module_data_radm2.o module_aer_drydep.o module_dep_simple.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_aerosols_sorgam_vbs.o module_mosaic_drydep.o ../phys/module_mixactivate.o module_cam_mam_drydep.o ../phys/module_data_cam_mam_asect.o ../phys/module_data_cam_mam_aero.o ../phys/module_cam_support.o -module_wetscav_driver.o: module_mosaic_wetscav.o module_aerosols_sorgam.o module_mozcart_wetscav.o ../phys/module_data_cam_mam_aero.o module_cam_mam_wetscav.o +module_wetscav_driver.o: module_mosaic_wetscav.o module_aerosols_sorgam.o module_aerosols_sorgam_vbs.o module_mozcart_wetscav.o ../phys/module_data_cam_mam_aero.o module_cam_mam_wetscav.o module_sorgam_aqchem.o: module_ctrans_aqchem.o module_data_sorgam.o @@ -239,5 +290,5 @@ module_lightning_nox_driver.o: module_lightning_nox_ott.o module_lightning_nox_d module_cam_mam_gas_wetdep_driver.o: ../frame/module_state_description.o ../phys/module_cam_support.o ../phys/module_data_cam_mam_asect.o ../phys/module_cam_physconst.o ../phys/module_cam_infnan.o module_cam_mam_mo_sethet.o -module_cam_mam_mo_sethet.o: ../phys/module_cam_support.o module_cam_mam_mo_chem_utls.o ../phys/module_cam_shr_kind_mod.o ../phys/module_cam_physconst.o module_cam_mam_init.o +module_cam_mam_mo_sethet.o: ../phys/module_cam_support.o module_cam_mam_mo_chem_utls.o ../phys/module_cam_shr_kind_mod.o ../phys/module_cam_physconst.o diff --git a/wrfv2_fire/chem/dry_dep_driver.F b/wrfv2_fire/chem/dry_dep_driver.F index ef2840c3..b71fd05c 100755 --- a/wrfv2_fire/chem/dry_dep_driver.F +++ b/wrfv2_fire/chem/dry_dep_driver.F @@ -18,8 +18,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & ivgtyp,tsk,gsw,vegfra,pbl,rmol,ust,znt,xlat,xlong,z,z_at_w,& xland,ash_fall,h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3, & - anh3,cvaro1,cvaro2, & + anh3,cvaro1,cvaro2, & cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2,dep_vel_o3, & + ddlen,ddflx, & emis_ant,ebu_in, & sf_urban_physics,numgas,current_month,dvel,snowh, & dustdrydep_1,dustdrydep_2,dustdrydep_3, & @@ -28,7 +29,7 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & dustgraset_1,dustgraset_2,dustgraset_3, & dustgraset_4,dustgraset_5, & setvel_1,setvel_2,setvel_3,setvel_4,setvel_5, imod, & - is_CAMMGMP_used, & !BSINGH:01/31/2013: Added is_CAMMGMP_used for MAM drydep + is_CAMMGMP_used, & dep_vel,num_vert_mix, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -46,7 +47,8 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & USE module_vash_settling USE module_gocart_drydep USE module_mosaic_drydep, only: mosaic_drydep_driver - USE module_mixactivate_wrappers, only: mosaic_mixactivate, sorgam_mixactivate + USE module_mixactivate_wrappers, only: mosaic_mixactivate, sorgam_mixactivate, & + sorgam_vbs_mixactivate USE module_aer_drydep USE module_aerosols_soa_vbs, only: soa_vbs_depdriver @@ -57,6 +59,7 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & USE modal_aero_data, only: numptr_amode, lmassptr_amode, ntot_amode, nspec_amode !Added by Balwinder.Singh@pnnl.gov to avoid mixing of CHEM array constituents multiple times USE module_cam_mam_drydep, only: cam_mam_drydep_driver use module_scalar_tables, only: chem_dname_table !Balwinder.Singh@pnnl.gov:Added for MAM aerosols dry deposition + USE module_aerosols_sorgam_vbs, only: sorgam_vbs_depdriver IMPLICIT NONE @@ -133,6 +136,11 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & REAL, DIMENSION( ims:ime , jms:jme ) , & INTENT(OUT) :: & dep_vel_o3 + REAL, DIMENSION( ims:ime , jms:jme , num_chem ) , & + INTENT(INOUT) :: & + ddlen, & !dry deposition length + ddflx !dry deposition flux + REAL, INTENT(OUT), dimension(ims:ime,kms:kme,jms:jme) :: nsource, & ccn1,ccn2,ccn3,ccn4,ccn5,ccn6 ! number conc of aerosols activated at supersat @@ -156,6 +164,7 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ! .. Local Scalars .. REAL :: clwchem, dvfog, dvpart, & rad, rhchem, ta, ustar, vegfrac, z1,zntt + REAL :: old, new, fac INTEGER :: iland, iprt, iseason, jce, jcs, & n, nr, ipr, jpr, nvr, & @@ -167,6 +176,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ! .. Local Arrays .. REAL :: p(kts:kte) REAL, DIMENSION( its:ite, jts:jte, num_chem ) :: ddvel + REAL, DIMENSION( num_chem ) :: ddmassn + + REAL, DIMENSION( ims:ime, jms:jme, num_chem ) :: qsrflx ! dry deposition flux of aerosols (explicit aq.-phase cases) REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) :: dryrho_phy REAL, DIMENSION( kms:kme ) :: dryrho_1d @@ -185,6 +197,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & real, parameter :: m2cm = 100. + REAL RSI ! gas constant in SI units (J/mol-K) + PARAMETER (RSI = 8.314510) ! RSI is the same as RGASUNIV in CONST.EXT + integer :: k_a, k_c, kmax, m_mam real, dimension( its:ite, jts:jte ) :: frac_removed @@ -277,10 +292,25 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) ENDIF + + if( config_flags%diagnostic_chem == DEPVEL1 .and. & + config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP ) then + do j = jts,jte + dvel(its:ite,1,j,p_dvel_o3) = m2cm*ddvel(its:ite,j,p_o3) + dvel(its:ite,1,j,p_dvel_no) = m2cm*ddvel(its:ite,j,p_no) + dvel(its:ite,1,j,p_dvel_no2) = m2cm*ddvel(its:ite,j,p_no2) + dvel(its:ite,1,j,p_dvel_nh3) = m2cm*ddvel(its:ite,j,p_nh3) + dvel(its:ite,1,j,p_dvel_so2) = m2cm*ddvel(its:ite,j,p_so2) + dvel(its:ite,1,j,p_dvel_so4) = m2cm*ddvel(its:ite,j,p_sulf) + dvel(its:ite,1,j,p_dvel_hno3) = m2cm*ddvel(its:ite,j,p_hno3) + enddo + endif + if( config_flags%diagnostic_chem == DEPVEL1 .and. & (config_flags%chem_opt == MOZCART_KPP .or. & config_flags%chem_opt == MOZART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP) ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) ) then do j = jts,jte dvel(its:ite,1,j,p_dvel_o3) = m2cm*ddvel(its:ite,j,p_o3) dvel(its:ite,1,j,p_dvel_no) = m2cm*ddvel(its:ite,j,p_no) @@ -298,9 +328,7 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & dvel(its:ite,1,j,p_dvel_ch3cooh) = m2cm*ddvel(its:ite,j,p_ch3cooh) dvel(its:ite,1,j,p_dvel_acet) = m2cm*ddvel(its:ite,j,p_acet) dvel(its:ite,1,j,p_dvel_mgly) = m2cm*ddvel(its:ite,j,p_mgly) -! 20120820 acd_ck_bugfix start dvel(its:ite,1,j,p_dvel_gly) = m2cm*ddvel(its:ite,j,p_gly) -! 20120820 acd_ck_bugfix end dvel(its:ite,1,j,p_dvel_paa) = m2cm*ddvel(its:ite,j,p_paa) dvel(its:ite,1,j,p_dvel_pooh) = m2cm*ddvel(its:ite,j,p_c3h6ooh) dvel(its:ite,1,j,p_dvel_mpan) = m2cm*ddvel(its:ite,j,p_mpan) @@ -326,6 +354,22 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & dvel(its:ite,1,j,p_dvel_terpooh) = m2cm*ddvel(its:ite,j,p_terpooh) enddo endif + + if ( config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then + do j = jts,jte + dvel(its:ite,1,j,p_dvel_cvasoaX) = 0.0 + dvel(its:ite,1,j,p_dvel_cvasoa1) = m2cm*ddvel(its:ite,j,p_cvasoa1) + dvel(its:ite,1,j,p_dvel_cvasoa2) = m2cm*ddvel(its:ite,j,p_cvasoa2) + dvel(its:ite,1,j,p_dvel_cvasoa3) = m2cm*ddvel(its:ite,j,p_cvasoa3) + dvel(its:ite,1,j,p_dvel_cvasoa4) = m2cm*ddvel(its:ite,j,p_cvasoa4) + dvel(its:ite,1,j,p_dvel_cvbsoaX) = 0.0 + dvel(its:ite,1,j,p_dvel_cvbsoa1) = m2cm*ddvel(its:ite,j,p_cvbsoa1) + dvel(its:ite,1,j,p_dvel_cvbsoa2) = m2cm*ddvel(its:ite,j,p_cvbsoa2) + dvel(its:ite,1,j,p_dvel_cvbsoa3) = m2cm*ddvel(its:ite,j,p_cvbsoa3) + dvel(its:ite,1,j,p_dvel_cvbsoa4) = m2cm*ddvel(its:ite,j,p_cvbsoa4) + enddo + endif + ELSEIF ( config_flags%chem_opt == GOCART_SIMPLE ) then call wesely_driver(id,ktau,dtstep, & config_flags,current_month, & @@ -398,6 +442,15 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ddvel(:,:,:) = 0. END IF +! diagnose output dry deposition flux + if( config_flags%diagnostic_dep == 1) then + do i = its, ite + do j = jts, jte + ddflx(i, j,1:numgas)=ddflx(i,j,1:numgas)+chem(i,kts,j,1:numgas)*p_phy(i,kts,j)/(RSI*t_phy(i,kts,j))*ddvel(i,j,1:numgas)*dtstep*1.E-6 + enddo + enddo + end if + if (config_flags%aer_aerodynres_opt == 2) then ! use aerodynamic resistance from center of layer kts to surface aer_res(:,:) = aer_res_zcen(:,:) @@ -411,14 +464,17 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & aer_mech_id_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RADM2SORG_KPP, & RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP, & - CBMZSORG,CBMZSORG_AQ) + CBMZSORG,CBMZSORG_AQ, & + CB05_SORG_AQ_KPP,CB05_SORG_VBS_AQ_KPP) aer_mech_id = 1 CASE (RACMSORG_AQ,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACMSORG_KPP) aer_mech_id = 2 CASE ( CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, & - CBMZ_MOSAIC_8BIN_AQ,CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP, & + CBMZ_MOSAIC_8BIN_AQ,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) + MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, &!BSINGH(12/03/2013): Added SAPRC 8 bin + SAPRC99_MOSAIC_8BIN_VBS2_KPP)!BSINGH(04/04/2014): Added SAPRC 8 bin non-aq aer_mech_id = 3 CASE ( CBMZ_CAM_MAM3_NOAQ, CBMZ_CAM_MAM3_AQ, CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM7_AQ ) aer_mech_id = 4 @@ -447,6 +503,7 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2, & aer_res,ddvel(:,:,numgas+1:num_chem), & + numgas,ddflx(:,:,numgas+1:num_chem), & num_chem-numgas, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -459,14 +516,43 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2, & aer_res,ddvel(:,:,numgas+1:num_chem), & + numgas,ddflx(:,:,numgas+1:num_chem), & + num_chem-numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE (CB05_SORG_AQ_KPP) + CALL wrf_debug(15,'DOING DRY DEP VELOCITIES FOR AEROSOLS/CB05') + call sorgam_depdriver (id,config_flags,ktau,dtstep, & + ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, & + alt,p_phy,chem,rho_phy,dz8w,z,z_at_w, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & + cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2, & + aer_res,ddvel(:,:,numgas+1:num_chem), & + numgas,ddflx(:,:,numgas+1:num_chem), & num_chem-numgas, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE (CB05_SORG_VBS_AQ_KPP) + CALL wrf_debug(15,'DOING DRY DEP VELOCITIES FOR AEROSOLS/CB05') + call sorgam_vbs_depdriver (id,config_flags,ktau,dtstep, & + ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, & + alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, & + aer_res,ddvel(:,:,numgas+1:num_chem), & + numgas,ddflx(:,:,numgas+1:num_chem), & + num_chem-numgas, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE ( CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP, & - CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) + SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_KPP)!BSINGH(12/03/2013): Added SAPRC 8 bin and non-aq on 04/04/2014 CALL wrf_debug(15,'DOING DRY DEP VELOCITIES FOR MOSAIC AEROSOLS') call mosaic_drydep_driver( & id, curr_secs, ktau, dtstep, config_flags, & @@ -560,11 +646,16 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ! This will be called later from subgrd_transport_driver.F !!!!!!!! ! ! + if( config_flags%diagnostic_dep == 1) then + ddlen(its:ite,jts:jte,:)=ddlen(its:ite,jts:jte,:)+ddvel(its:ite,jts:jte,:)*m2cm + end if + dep_vel_o3=0. if (num_vert_mix == 0) then do 100 j=jts,jte do 100 i=its,ite pblst=0. + ddmassn(:) = 0.0 ! ! !-- start with vertical mixing @@ -585,7 +676,11 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & !!$! if e_co > 0., the grid cell should not be over water !!$! if e_co > 200, the grid cell should be over a large urban region !!$! - if (p_e_co > param_first_scalar )then + +! this code is wrong - doesn't work if e_co is == param_first_scalar +! (like it happened to be the case for MOZCART) +! if (p_e_co > param_first_scalar )then + if (p_e_co >= param_first_scalar )then if (sf_urban_physics .eq. 0 ) then if (emis_ant(i,kts,j,p_e_co) .gt. 0) then ekmfull(kts:kts+10) = max(ekmfull(kts:kts+10),1.) @@ -607,7 +702,8 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & endif !!$! --- Mix the emissions up several layers when satellite data shows a wildfire !!$! if ebu_in_e_co > 0., a wildfire exists so increase vertical mixing - if (p_ebu_in_co > param_first_scalar )then +! if (p_ebu_in_co > param_first_scalar )then + if (p_ebu_in_co >= param_first_scalar )then if (ebu_in(i,1,j,p_ebu_in_co) .gt. 0) then ekmfull(kts:kte/2) = max(ekmfull(kts:kte/2),2.) endif @@ -632,8 +728,10 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & mix_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, CBMZ_MOSAIC_4BIN_AQ, & - CBMZ_MOSAIC_8BIN_AQ, CBMZSORG_AQ, CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, & - CBMZ_MOSAIC_DMS_8BIN_AQ, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) + CBMZ_MOSAIC_8BIN_AQ, CBMZSORG_AQ, CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & + MOZART_MOSAIC_4BIN_AQ_KPP, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, & + CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP) if(.not.is_aerosol(nv))then ! mix gases not aerosol call vertmx(dtstep,pblst,ekmfull,dryrho_1d, & zzfull,zz,ddvel(i,j,nv),kts,kte) @@ -649,10 +747,271 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & END SELECT mix_select + ! chem is in ppmv + ! dry deposition is combined with vertical mixing, but column independent. + ! Hence, all molecules lost per column must be dry deposited. + + ! old and new column totals (mol/m2 or ug/m2) + old = 0.0 + new = 0.0 + + do k=kts,kte-1 + fac = 1.0 + if (nv <= numgas) then + ! from ppmv to mol/m2 + ! fac = 1e-6 * rho * 1/mw_air * dz + ! kg/m3 mol/kg m + fac = 1e-6 * dryrho_1d(k) * 1./(mwdry*1.e-3) * dz8w(i,k,j) + else + ! from ug/kg to ug/m2 + ! fac = rho * dz + ! kg/m3 m + fac = dryrho_1d(k) * dz8w(i,k,j) + endif + + old = old + max(epsilc,chem(i,k,j,nv)) * fac + new = new + max(epsilc,pblst(k)) * fac + enddo + + ! we ignore (spurious) and add new dry deposition to + ! existing field (accumulated deposition!) + ddmassn(nv) = max( 0.0, (old - new) ) + do k=kts,kte-1 chem(i,k,j,nv)=max(epsilc,pblst(k)) enddo enddo + + if( config_flags%diagnostic_chem == DEPVEL1 .and. & + (config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP) ) then + dvel(i,1,j,p_ddmass_o3) = dvel(i,1,j,p_ddmass_o3) + ddmassn(p_o3) + dvel(i,1,j,p_ddmass_no) = dvel(i,1,j,p_ddmass_no) + ddmassn(p_no) + dvel(i,1,j,p_ddmass_no2) = dvel(i,1,j,p_ddmass_no2) + ddmassn(p_no2) + dvel(i,1,j,p_ddmass_nh3) = dvel(i,1,j,p_ddmass_nh3) + ddmassn(p_nh3) + dvel(i,1,j,p_ddmass_hno3) = dvel(i,1,j,p_ddmass_hno3) + ddmassn(p_hno3) + dvel(i,1,j,p_ddmass_so2) = dvel(i,1,j,p_ddmass_so2) + ddmassn(p_so2) + dvel(i,1,j,p_ddmass_so4) = dvel(i,1,j,p_ddmass_so4) + ddmassn(p_sulf) + dvel(i,1,j,p_ddmass_so4aj) = dvel(i,1,j,p_ddmass_so4aj) + ddmassn(p_so4aj) + dvel(i,1,j,p_ddmass_so4ai) = dvel(i,1,j,p_ddmass_so4ai) + ddmassn(p_so4ai) + dvel(i,1,j,p_ddmass_no3aj) = dvel(i,1,j,p_ddmass_no3aj) + ddmassn(p_no3aj) + dvel(i,1,j,p_ddmass_no3ai) = dvel(i,1,j,p_ddmass_no3ai) + ddmassn(p_no3ai) + dvel(i,1,j,p_ddmass_nh4aj) = dvel(i,1,j,p_ddmass_nh4aj) + ddmassn(p_nh4aj) + dvel(i,1,j,p_ddmass_nh4ai) = dvel(i,1,j,p_ddmass_nh4ai) + ddmassn(p_nh4ai) + endif + + if( config_flags%diagnostic_chem == DEPVEL1 .and. & + (config_flags%chem_opt == MOZCART_KPP .or. & + config_flags%chem_opt == MOZART_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) ) then + + dvel(i,1,j,p_ddmass_o3) = dvel(i,1,j,p_ddmass_o3) + ddmassn(p_o3) + dvel(i,1,j,p_ddmass_no) = dvel(i,1,j,p_ddmass_no) + ddmassn(p_no) + dvel(i,1,j,p_ddmass_no2) = dvel(i,1,j,p_ddmass_no2) + ddmassn(p_no2) + dvel(i,1,j,p_ddmass_nh3) = dvel(i,1,j,p_ddmass_nh3) + ddmassn(p_nh3) + dvel(i,1,j,p_ddmass_hno3) = dvel(i,1,j,p_ddmass_hno3) + ddmassn(p_hno3) + dvel(i,1,j,p_ddmass_hno4) = dvel(i,1,j,p_ddmass_hno4) + ddmassn(p_hno4) + dvel(i,1,j,p_ddmass_h2o2) = dvel(i,1,j,p_ddmass_h2o2) + ddmassn(p_h2o2) + dvel(i,1,j,p_ddmass_co) = dvel(i,1,j,p_ddmass_co) + ddmassn(p_co) + dvel(i,1,j,p_ddmass_ch3ooh) = dvel(i,1,j,p_ddmass_ch3ooh) + ddmassn(p_ch3ooh) + dvel(i,1,j,p_ddmass_hcho) = dvel(i,1,j,p_ddmass_hcho) + ddmassn(p_hcho) + dvel(i,1,j,p_ddmass_ch3oh) = dvel(i,1,j,p_ddmass_ch3oh) + ddmassn(p_ch3oh) + dvel(i,1,j,p_ddmass_eo2) = dvel(i,1,j,p_ddmass_eo2) + ddmassn(p_eo2) + dvel(i,1,j,p_ddmass_ald) = dvel(i,1,j,p_ddmass_ald) + ddmassn(p_ald) + dvel(i,1,j,p_ddmass_ch3cooh) = dvel(i,1,j,p_ddmass_ch3cooh) + ddmassn(p_ch3cooh) + dvel(i,1,j,p_ddmass_acet) = dvel(i,1,j,p_ddmass_acet) + ddmassn(p_acet) + dvel(i,1,j,p_ddmass_mgly) = dvel(i,1,j,p_ddmass_mgly) + ddmassn(p_mgly) + dvel(i,1,j,p_ddmass_gly) = dvel(i,1,j,p_ddmass_gly) + ddmassn(p_gly) + dvel(i,1,j,p_ddmass_paa) = dvel(i,1,j,p_ddmass_paa) + ddmassn(p_paa) + dvel(i,1,j,p_ddmass_pooh) = dvel(i,1,j,p_ddmass_pooh) + ddmassn(p_c3h6ooh) + dvel(i,1,j,p_ddmass_mpan) = dvel(i,1,j,p_ddmass_mpan) + ddmassn(p_mpan) + dvel(i,1,j,p_ddmass_mco3) = dvel(i,1,j,p_ddmass_mco3) + ddmassn(p_mco3) + dvel(i,1,j,p_ddmass_mvkooh) = dvel(i,1,j,p_ddmass_mvkooh) + ddmassn(p_mvkooh) + dvel(i,1,j,p_ddmass_c2h5oh) = dvel(i,1,j,p_ddmass_c2h5oh) + ddmassn(p_c2h5oh) + dvel(i,1,j,p_ddmass_etooh) = dvel(i,1,j,p_ddmass_etooh) + ddmassn(p_etooh) + dvel(i,1,j,p_ddmass_prooh) = dvel(i,1,j,p_ddmass_prooh) + ddmassn(p_prooh) + dvel(i,1,j,p_ddmass_acetp) = dvel(i,1,j,p_ddmass_acetp) + ddmassn(p_acetp) + dvel(i,1,j,p_ddmass_onit) = dvel(i,1,j,p_ddmass_onit) + ddmassn(p_onit) + dvel(i,1,j,p_ddmass_onitr) = dvel(i,1,j,p_ddmass_onitr) + ddmassn(p_onitr) + dvel(i,1,j,p_ddmass_isooh) = dvel(i,1,j,p_ddmass_isooh) + ddmassn(p_isooh) + dvel(i,1,j,p_ddmass_acetol) = dvel(i,1,j,p_ddmass_acetol) + ddmassn(p_acetol) + dvel(i,1,j,p_ddmass_glyald) = dvel(i,1,j,p_ddmass_glyald) + ddmassn(p_glyald) + dvel(i,1,j,p_ddmass_hydrald) = dvel(i,1,j,p_ddmass_hydrald) + ddmassn(p_hydrald) + dvel(i,1,j,p_ddmass_alkooh) = dvel(i,1,j,p_ddmass_alkooh) + ddmassn(p_alkooh) + dvel(i,1,j,p_ddmass_mekooh) = dvel(i,1,j,p_ddmass_mekooh) + ddmassn(p_mekooh) + dvel(i,1,j,p_ddmass_tolooh) = dvel(i,1,j,p_ddmass_tolooh) + ddmassn(p_tolooh) + dvel(i,1,j,p_ddmass_xooh) = dvel(i,1,j,p_ddmass_xooh) + ddmassn(p_xooh) + dvel(i,1,j,p_ddmass_so2) = dvel(i,1,j,p_ddmass_so2) + ddmassn(p_so2) + dvel(i,1,j,p_ddmass_so4) = dvel(i,1,j,p_ddmass_so4) + ddmassn(p_sulf) + dvel(i,1,j,p_ddmass_pan) = dvel(i,1,j,p_ddmass_pan) + ddmassn(p_pan) + dvel(i,1,j,p_ddmass_terpooh) = dvel(i,1,j,p_ddmass_terpooh) + ddmassn(p_terpooh) + + if (config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then + dvel(i,1,j,p_ddmass_cvasoaX) = dvel(i,1,j,p_ddmass_cvasoaX) + ddmassn(p_cvasoaX) + dvel(i,1,j,p_ddmass_cvasoa1) = dvel(i,1,j,p_ddmass_cvasoa1) + ddmassn(p_cvasoa1) + dvel(i,1,j,p_ddmass_cvasoa2) = dvel(i,1,j,p_ddmass_cvasoa2) + ddmassn(p_cvasoa2) + dvel(i,1,j,p_ddmass_cvasoa3) = dvel(i,1,j,p_ddmass_cvasoa3) + ddmassn(p_cvasoa3) + dvel(i,1,j,p_ddmass_cvasoa4) = dvel(i,1,j,p_ddmass_cvasoa4) + ddmassn(p_cvasoa4) + dvel(i,1,j,p_ddmass_cvbsoaX) = dvel(i,1,j,p_ddmass_cvbsoaX) + ddmassn(p_cvbsoaX) + dvel(i,1,j,p_ddmass_cvbsoa1) = dvel(i,1,j,p_ddmass_cvbsoa1) + ddmassn(p_cvbsoa1) + dvel(i,1,j,p_ddmass_cvbsoa2) = dvel(i,1,j,p_ddmass_cvbsoa2) + ddmassn(p_cvbsoa2) + dvel(i,1,j,p_ddmass_cvbsoa3) = dvel(i,1,j,p_ddmass_cvbsoa3) + ddmassn(p_cvbsoa3) + dvel(i,1,j,p_ddmass_cvbsoa4) = dvel(i,1,j,p_ddmass_cvbsoa4) + ddmassn(p_cvbsoa4) + endif + + if (config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then + + dvel(i,1,j,p_ddmass_so4_a01) = dvel(i,1,j,p_ddmass_so4_a01) + ddmassn(p_so4_a01) + dvel(i,1,j,p_ddmass_no3_a01) = dvel(i,1,j,p_ddmass_no3_a01) + ddmassn(p_no3_a01) + dvel(i,1,j,p_ddmass_cl_a01) = dvel(i,1,j,p_ddmass_cl_a01) + ddmassn(p_cl_a01) + dvel(i,1,j,p_ddmass_nh4_a01) = dvel(i,1,j,p_ddmass_nh4_a01) + ddmassn(p_nh4_a01) + dvel(i,1,j,p_ddmass_na_a01) = dvel(i,1,j,p_ddmass_na_a01) + ddmassn(p_na_a01) + dvel(i,1,j,p_ddmass_oin_a01) = dvel(i,1,j,p_ddmass_oin_a01) + ddmassn(p_oin_a01) + dvel(i,1,j,p_ddmass_oc_a01) = dvel(i,1,j,p_ddmass_oc_a01) + ddmassn(p_oc_a01) + dvel(i,1,j,p_ddmass_bc_a01) = dvel(i,1,j,p_ddmass_bc_a01) + ddmassn(p_bc_a01) + dvel(i,1,j,p_ddmass_so4_a02) = dvel(i,1,j,p_ddmass_so4_a02) + ddmassn(p_so4_a02) + dvel(i,1,j,p_ddmass_no3_a02) = dvel(i,1,j,p_ddmass_no3_a02) + ddmassn(p_no3_a02) + dvel(i,1,j,p_ddmass_cl_a02) = dvel(i,1,j,p_ddmass_cl_a02) + ddmassn(p_cl_a02) + dvel(i,1,j,p_ddmass_nh4_a02) = dvel(i,1,j,p_ddmass_nh4_a02) + ddmassn(p_nh4_a02) + dvel(i,1,j,p_ddmass_na_a02) = dvel(i,1,j,p_ddmass_na_a02) + ddmassn(p_na_a02) + dvel(i,1,j,p_ddmass_oin_a02) = dvel(i,1,j,p_ddmass_oin_a02) + ddmassn(p_oin_a02) + dvel(i,1,j,p_ddmass_oc_a02) = dvel(i,1,j,p_ddmass_oc_a02) + ddmassn(p_oc_a02) + dvel(i,1,j,p_ddmass_bc_a02) = dvel(i,1,j,p_ddmass_bc_a02) + ddmassn(p_bc_a02) + dvel(i,1,j,p_ddmass_so4_a03) = dvel(i,1,j,p_ddmass_so4_a03) + ddmassn(p_so4_a03) + dvel(i,1,j,p_ddmass_no3_a03) = dvel(i,1,j,p_ddmass_no3_a03) + ddmassn(p_no3_a03) + dvel(i,1,j,p_ddmass_cl_a03) = dvel(i,1,j,p_ddmass_cl_a03) + ddmassn(p_cl_a03) + dvel(i,1,j,p_ddmass_nh4_a03) = dvel(i,1,j,p_ddmass_nh4_a03) + ddmassn(p_nh4_a03) + dvel(i,1,j,p_ddmass_na_a03) = dvel(i,1,j,p_ddmass_na_a03) + ddmassn(p_na_a03) + dvel(i,1,j,p_ddmass_oin_a03) = dvel(i,1,j,p_ddmass_oin_a03) + ddmassn(p_oin_a03) + dvel(i,1,j,p_ddmass_oc_a03) = dvel(i,1,j,p_ddmass_oc_a03) + ddmassn(p_oc_a03) + dvel(i,1,j,p_ddmass_bc_a03) = dvel(i,1,j,p_ddmass_bc_a03) + ddmassn(p_bc_a03) + dvel(i,1,j,p_ddmass_so4_a04) = dvel(i,1,j,p_ddmass_so4_a04) + ddmassn(p_so4_a04) + dvel(i,1,j,p_ddmass_no3_a04) = dvel(i,1,j,p_ddmass_no3_a04) + ddmassn(p_no3_a04) + dvel(i,1,j,p_ddmass_cl_a04) = dvel(i,1,j,p_ddmass_cl_a04) + ddmassn(p_cl_a04) + dvel(i,1,j,p_ddmass_nh4_a04) = dvel(i,1,j,p_ddmass_nh4_a04) + ddmassn(p_nh4_a04) + dvel(i,1,j,p_ddmass_na_a04) = dvel(i,1,j,p_ddmass_na_a04) + ddmassn(p_na_a04) + dvel(i,1,j,p_ddmass_oin_a04) = dvel(i,1,j,p_ddmass_oin_a04) + ddmassn(p_oin_a04) + dvel(i,1,j,p_ddmass_oc_a04) = dvel(i,1,j,p_ddmass_oc_a04) + ddmassn(p_oc_a04) + dvel(i,1,j,p_ddmass_bc_a04) = dvel(i,1,j,p_ddmass_bc_a04) + ddmassn(p_bc_a04) + + dvel(i,1,j,p_ddmass_ca_a01) = dvel(i,1,j,p_ddmass_ca_a01) + ddmassn(p_ca_a01) + dvel(i,1,j,p_ddmass_ca_a02) = dvel(i,1,j,p_ddmass_ca_a02) + ddmassn(p_ca_a02) + dvel(i,1,j,p_ddmass_ca_a03) = dvel(i,1,j,p_ddmass_ca_a03) + ddmassn(p_ca_a03) + dvel(i,1,j,p_ddmass_ca_a04) = dvel(i,1,j,p_ddmass_ca_a04) + ddmassn(p_ca_a04) + + dvel(i,1,j,p_ddmass_co3_a01) = dvel(i,1,j,p_ddmass_co3_a01) + ddmassn(p_co3_a01) + dvel(i,1,j,p_ddmass_co3_a02) = dvel(i,1,j,p_ddmass_co3_a02) + ddmassn(p_co3_a02) + dvel(i,1,j,p_ddmass_co3_a03) = dvel(i,1,j,p_ddmass_co3_a03) + ddmassn(p_co3_a03) + dvel(i,1,j,p_ddmass_co3_a04) = dvel(i,1,j,p_ddmass_co3_a04) + ddmassn(p_co3_a04) + + if (config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .OR. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then + dvel(i,1,j,p_ddmass_glysoa_a01) = dvel(i,1,j,p_ddmass_glysoa_a01) + & + ddmassn(p_glysoa_r1_a01) + & + ddmassn(p_glysoa_r2_a01) + & + ddmassn(p_glysoa_oh_a01) + & + ddmassn(p_glysoa_sfc_a01) + & + ddmassn(p_glysoa_nh4_a01) + + dvel(i,1,j,p_ddmass_glysoa_a02) = dvel(i,1,j,p_ddmass_glysoa_a02) + & + ddmassn(p_glysoa_r1_a02) + & + ddmassn(p_glysoa_r2_a02) + & + ddmassn(p_glysoa_oh_a02) + & + ddmassn(p_glysoa_sfc_a02) + & + ddmassn(p_glysoa_nh4_a02) + + dvel(i,1,j,p_ddmass_glysoa_a03) = dvel(i,1,j,p_ddmass_glysoa_a03) + & + ddmassn(p_glysoa_r1_a03) + & + ddmassn(p_glysoa_r2_a03) + & + ddmassn(p_glysoa_oh_a03) + & + ddmassn(p_glysoa_sfc_a03) + & + ddmassn(p_glysoa_nh4_a03) + + dvel(i,1,j,p_ddmass_glysoa_a04) = dvel(i,1,j,p_ddmass_glysoa_a04) + & + ddmassn(p_glysoa_r1_a04) + & + ddmassn(p_glysoa_r2_a04) + & + ddmassn(p_glysoa_oh_a04) + & + ddmassn(p_glysoa_sfc_a04) + & + ddmassn(p_glysoa_nh4_a04) + endif + + if (config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP) then + + dvel(i,1,j,p_ddmass_smpa_a01) = dvel(i,1,j,p_ddmass_smpa_a01) + ddmassn(p_smpa_a01) + dvel(i,1,j,p_ddmass_smpbb_a01) = dvel(i,1,j,p_ddmass_smpbb_a01) + ddmassn(p_smpbb_a01) + dvel(i,1,j,p_ddmass_biog1_c_a01) = dvel(i,1,j,p_ddmass_biog1_c_a01) + ddmassn(p_biog1_c_a01) + dvel(i,1,j,p_ddmass_biog1_o_a01) = dvel(i,1,j,p_ddmass_biog1_o_a01) + ddmassn(p_biog1_o_a01) + + dvel(i,1,j,p_ddmass_smpa_a02) = dvel(i,1,j,p_ddmass_smpa_a02) + ddmassn(p_smpa_a02) + dvel(i,1,j,p_ddmass_smpbb_a02) = dvel(i,1,j,p_ddmass_smpbb_a02) + ddmassn(p_smpbb_a02) + dvel(i,1,j,p_ddmass_biog1_c_a02) = dvel(i,1,j,p_ddmass_biog1_c_a02) + ddmassn(p_biog1_c_a02) + dvel(i,1,j,p_ddmass_biog1_o_a02) = dvel(i,1,j,p_ddmass_biog1_o_a02) + ddmassn(p_biog1_o_a02) + + dvel(i,1,j,p_ddmass_smpa_a03) = dvel(i,1,j,p_ddmass_smpa_a03) + ddmassn(p_smpa_a03) + dvel(i,1,j,p_ddmass_smpbb_a03) = dvel(i,1,j,p_ddmass_smpbb_a03) + ddmassn(p_smpbb_a03) + dvel(i,1,j,p_ddmass_biog1_c_a03) = dvel(i,1,j,p_ddmass_biog1_c_a03) + ddmassn(p_biog1_c_a03) + dvel(i,1,j,p_ddmass_biog1_o_a03) = dvel(i,1,j,p_ddmass_biog1_o_a03) + ddmassn(p_biog1_o_a03) + + dvel(i,1,j,p_ddmass_smpa_a04) = dvel(i,1,j,p_ddmass_smpa_a04) + ddmassn(p_smpa_a04) + dvel(i,1,j,p_ddmass_smpbb_a04) = dvel(i,1,j,p_ddmass_smpbb_a04) + ddmassn(p_smpbb_a04) + dvel(i,1,j,p_ddmass_biog1_c_a04) = dvel(i,1,j,p_ddmass_biog1_c_a04) + ddmassn(p_biog1_c_a04) + dvel(i,1,j,p_ddmass_biog1_o_a04) = dvel(i,1,j,p_ddmass_biog1_o_a04) + ddmassn(p_biog1_o_a04) + + endif + + if (config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then + + dvel(i,1,j,p_ddmass_asoaX_a01) = dvel(i,1,j,p_ddmass_asoaX_a01) + ddmassn(p_asoaX_a01) + dvel(i,1,j,p_ddmass_asoa1_a01) = dvel(i,1,j,p_ddmass_asoa1_a01) + ddmassn(p_asoa1_a01) + dvel(i,1,j,p_ddmass_asoa2_a01) = dvel(i,1,j,p_ddmass_asoa2_a01) + ddmassn(p_asoa2_a01) + dvel(i,1,j,p_ddmass_asoa3_a01) = dvel(i,1,j,p_ddmass_asoa3_a01) + ddmassn(p_asoa3_a01) + dvel(i,1,j,p_ddmass_asoa4_a01) = dvel(i,1,j,p_ddmass_asoa4_a01) + ddmassn(p_asoa4_a01) + dvel(i,1,j,p_ddmass_bsoaX_a01) = dvel(i,1,j,p_ddmass_bsoaX_a01) + ddmassn(p_bsoaX_a01) + dvel(i,1,j,p_ddmass_bsoa1_a01) = dvel(i,1,j,p_ddmass_bsoa1_a01) + ddmassn(p_bsoa1_a01) + dvel(i,1,j,p_ddmass_bsoa2_a01) = dvel(i,1,j,p_ddmass_bsoa2_a01) + ddmassn(p_bsoa2_a01) + dvel(i,1,j,p_ddmass_bsoa3_a01) = dvel(i,1,j,p_ddmass_bsoa3_a01) + ddmassn(p_bsoa3_a01) + dvel(i,1,j,p_ddmass_bsoa4_a01) = dvel(i,1,j,p_ddmass_bsoa4_a01) + ddmassn(p_bsoa4_a01) + + dvel(i,1,j,p_ddmass_asoaX_a02) = dvel(i,1,j,p_ddmass_asoaX_a02) + ddmassn(p_asoaX_a02) + dvel(i,1,j,p_ddmass_asoa1_a02) = dvel(i,1,j,p_ddmass_asoa1_a02) + ddmassn(p_asoa1_a02) + dvel(i,1,j,p_ddmass_asoa2_a02) = dvel(i,1,j,p_ddmass_asoa2_a02) + ddmassn(p_asoa2_a02) + dvel(i,1,j,p_ddmass_asoa3_a02) = dvel(i,1,j,p_ddmass_asoa3_a02) + ddmassn(p_asoa3_a02) + dvel(i,1,j,p_ddmass_asoa4_a02) = dvel(i,1,j,p_ddmass_asoa4_a02) + ddmassn(p_asoa4_a02) + dvel(i,1,j,p_ddmass_bsoaX_a02) = dvel(i,1,j,p_ddmass_bsoaX_a02) + ddmassn(p_bsoaX_a02) + dvel(i,1,j,p_ddmass_bsoa1_a02) = dvel(i,1,j,p_ddmass_bsoa1_a02) + ddmassn(p_bsoa1_a02) + dvel(i,1,j,p_ddmass_bsoa2_a02) = dvel(i,1,j,p_ddmass_bsoa2_a02) + ddmassn(p_bsoa2_a02) + dvel(i,1,j,p_ddmass_bsoa3_a02) = dvel(i,1,j,p_ddmass_bsoa3_a02) + ddmassn(p_bsoa3_a02) + dvel(i,1,j,p_ddmass_bsoa4_a02) = dvel(i,1,j,p_ddmass_bsoa4_a02) + ddmassn(p_bsoa4_a02) + + dvel(i,1,j,p_ddmass_asoaX_a03) = dvel(i,1,j,p_ddmass_asoaX_a03) + ddmassn(p_asoaX_a03) + dvel(i,1,j,p_ddmass_asoa1_a03) = dvel(i,1,j,p_ddmass_asoa1_a03) + ddmassn(p_asoa1_a03) + dvel(i,1,j,p_ddmass_asoa2_a03) = dvel(i,1,j,p_ddmass_asoa2_a03) + ddmassn(p_asoa2_a03) + dvel(i,1,j,p_ddmass_asoa3_a03) = dvel(i,1,j,p_ddmass_asoa3_a03) + ddmassn(p_asoa3_a03) + dvel(i,1,j,p_ddmass_asoa4_a03) = dvel(i,1,j,p_ddmass_asoa4_a03) + ddmassn(p_asoa4_a03) + dvel(i,1,j,p_ddmass_bsoaX_a03) = dvel(i,1,j,p_ddmass_bsoaX_a03) + ddmassn(p_bsoaX_a03) + dvel(i,1,j,p_ddmass_bsoa1_a03) = dvel(i,1,j,p_ddmass_bsoa1_a03) + ddmassn(p_bsoa1_a03) + dvel(i,1,j,p_ddmass_bsoa2_a03) = dvel(i,1,j,p_ddmass_bsoa2_a03) + ddmassn(p_bsoa2_a03) + dvel(i,1,j,p_ddmass_bsoa3_a03) = dvel(i,1,j,p_ddmass_bsoa3_a03) + ddmassn(p_bsoa3_a03) + dvel(i,1,j,p_ddmass_bsoa4_a03) = dvel(i,1,j,p_ddmass_bsoa4_a03) + ddmassn(p_bsoa4_a03) + + dvel(i,1,j,p_ddmass_asoaX_a04) = dvel(i,1,j,p_ddmass_asoaX_a04) + ddmassn(p_asoaX_a04) + dvel(i,1,j,p_ddmass_asoa1_a04) = dvel(i,1,j,p_ddmass_asoa1_a04) + ddmassn(p_asoa1_a04) + dvel(i,1,j,p_ddmass_asoa2_a04) = dvel(i,1,j,p_ddmass_asoa2_a04) + ddmassn(p_asoa2_a04) + dvel(i,1,j,p_ddmass_asoa3_a04) = dvel(i,1,j,p_ddmass_asoa3_a04) + ddmassn(p_asoa3_a04) + dvel(i,1,j,p_ddmass_asoa4_a04) = dvel(i,1,j,p_ddmass_asoa4_a04) + ddmassn(p_asoa4_a04) + dvel(i,1,j,p_ddmass_bsoaX_a04) = dvel(i,1,j,p_ddmass_bsoaX_a04) + ddmassn(p_bsoaX_a04) + dvel(i,1,j,p_ddmass_bsoa1_a04) = dvel(i,1,j,p_ddmass_bsoa1_a04) + ddmassn(p_bsoa1_a04) + dvel(i,1,j,p_ddmass_bsoa2_a04) = dvel(i,1,j,p_ddmass_bsoa2_a04) + ddmassn(p_bsoa2_a04) + dvel(i,1,j,p_ddmass_bsoa3_a04) = dvel(i,1,j,p_ddmass_bsoa3_a04) + ddmassn(p_bsoa3_a04) + dvel(i,1,j,p_ddmass_bsoa4_a04) = dvel(i,1,j,p_ddmass_bsoa4_a04) + ddmassn(p_bsoa4_a04) + + endif + + endif + + endif + tracer_select: SELECT CASE(config_flags%tracer_opt) ! ! only mixing one fire(smoke) scalar array @@ -685,9 +1044,12 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & dryrho_phy(its:ite,kts:kte,jts:jte) = 0. end where + qsrflx(:,:,:) = 0.0 + mixactivate_select: SELECT CASE(config_flags%chem_opt) - CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, CBMZSORG_AQ) + CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, CBMZSORG_AQ, & + CB05_SORG_AQ_KPP) CALL wrf_debug(15,'call mixactivate for sorgam aerosol') call sorgam_mixactivate ( & id, ktau, dtstep, config_flags, idrydep_onoff, & @@ -699,8 +1061,22 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE (CB05_SORG_VBS_AQ_KPP) + CALL wrf_debug(15,'call mixactivate for sorgam_vbs aerosol') + call sorgam_vbs_mixactivate ( & + id, ktau, dtstep, config_flags, idrydep_onoff, & + dryrho_phy, t_phy, w, cldfra, cldfra_old, & + ddvel, z, dz8w, p8w, t8w, exch_h, & + moist(ims,kms,jms,P_QV), moist(ims,kms,jms,P_QC), moist(ims,kms,jms,P_QI), & + scalar(ims,kms,jms,P_QNDROP), f_qc, f_qi, chem, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + ! Mixactivate called only for _AQ packages below MS 12/28/2013 CASE (CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, & + MOZART_MOSAIC_4BIN_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP)!BSINGH(12/03/2013): Added SAPRC 8 bin) CALL wrf_debug(15,'call mixactivate for mosaic aerosol') call mosaic_mixactivate ( & id, ktau, dtstep, config_flags, idrydep_onoff, & @@ -709,11 +1085,271 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & moist(ims,kms,jms,P_QV), moist(ims,kms,jms,P_QC), moist(ims,kms,jms,P_QI), & scalar(ims,kms,jms,P_QNDROP), f_qc, f_qi, chem, & ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + qsrflx, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + + if( config_flags%diagnostic_chem == DEPVEL1 .and. & + config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP ) then + + ! qsrflx is in kg/m2/s, recalculate to match ug/m2 for aerosols + qsrflx = qsrflx * 1.0e9 * dtstep + + dvel(ims:ime,1,jms:jme,p_ddmass_so4aj) = dvel(ims:ime,1,jms:jme,p_ddmass_so4aj) + qsrflx(ims:ime,jms:jme,p_so4aj) + dvel(ims:ime,1,jms:jme,p_ddmass_so4ai) = dvel(ims:ime,1,jms:jme,p_ddmass_so4ai) + qsrflx(ims:ime,jms:jme,p_so4ai) + dvel(ims:ime,1,jms:jme,p_ddmass_no3aj) = dvel(ims:ime,1,jms:jme,p_ddmass_no3aj) + qsrflx(ims:ime,jms:jme,p_no3aj) + dvel(ims:ime,1,jms:jme,p_ddmass_no3ai) = dvel(ims:ime,1,jms:jme,p_ddmass_no3ai) + qsrflx(ims:ime,jms:jme,p_no3ai) + dvel(ims:ime,1,jms:jme,p_ddmass_nh4aj) = dvel(ims:ime,1,jms:jme,p_ddmass_nh4aj) + qsrflx(ims:ime,jms:jme,p_nh4aj) + dvel(ims:ime,1,jms:jme,p_ddmass_nh4ai) = dvel(ims:ime,1,jms:jme,p_ddmass_nh4ai) + qsrflx(ims:ime,jms:jme,p_nh4ai) + + endif + + if( config_flags%diagnostic_chem == DEPVEL1 .and. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then + + ! qsrflx is in kg/m2/s, recalculate to match ug/m2 for aerosols + qsrflx = qsrflx * 1.0e9 * dtstep + + dvel(ims:ime,1,jms:jme,p_ddmass_so4_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_so4_a01) + qsrflx(ims:ime,jms:jme,p_so4_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_no3_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_no3_a01) + qsrflx(ims:ime,jms:jme,p_no3_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_cl_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_cl_a01) + qsrflx(ims:ime,jms:jme,p_cl_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_nh4_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_nh4_a01) + qsrflx(ims:ime,jms:jme,p_nh4_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_na_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_na_a01) + qsrflx(ims:ime,jms:jme,p_na_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_oin_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_oin_a01) + qsrflx(ims:ime,jms:jme,p_oin_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_oc_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_oc_a01) + qsrflx(ims:ime,jms:jme,p_oc_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_bc_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_bc_a01) + qsrflx(ims:ime,jms:jme,p_bc_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_so4_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_so4_a02) + qsrflx(ims:ime,jms:jme,p_so4_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_no3_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_no3_a02) + qsrflx(ims:ime,jms:jme,p_no3_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_cl_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_cl_a02) + qsrflx(ims:ime,jms:jme,p_cl_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_nh4_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_nh4_a02) + qsrflx(ims:ime,jms:jme,p_nh4_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_na_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_na_a02) + qsrflx(ims:ime,jms:jme,p_na_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_oin_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_oin_a02) + qsrflx(ims:ime,jms:jme,p_oin_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_oc_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_oc_a02) + qsrflx(ims:ime,jms:jme,p_oc_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_bc_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_bc_a02) + qsrflx(ims:ime,jms:jme,p_bc_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_so4_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_so4_a03) + qsrflx(ims:ime,jms:jme,p_so4_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_no3_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_no3_a03) + qsrflx(ims:ime,jms:jme,p_no3_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_cl_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_cl_a03) + qsrflx(ims:ime,jms:jme,p_cl_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_nh4_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_nh4_a03) + qsrflx(ims:ime,jms:jme,p_nh4_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_na_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_na_a03) + qsrflx(ims:ime,jms:jme,p_na_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_oin_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_oin_a03) + qsrflx(ims:ime,jms:jme,p_oin_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_oc_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_oc_a03) + qsrflx(ims:ime,jms:jme,p_oc_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_bc_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_bc_a03) + qsrflx(ims:ime,jms:jme,p_bc_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_so4_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_so4_a04) + qsrflx(ims:ime,jms:jme,p_so4_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_no3_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_no3_a04) + qsrflx(ims:ime,jms:jme,p_no3_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_cl_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_cl_a04) + qsrflx(ims:ime,jms:jme,p_cl_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_nh4_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_nh4_a04) + qsrflx(ims:ime,jms:jme,p_nh4_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_na_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_na_a04) + qsrflx(ims:ime,jms:jme,p_na_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_oin_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_oin_a04) + qsrflx(ims:ime,jms:jme,p_oin_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_oc_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_oc_a04) + qsrflx(ims:ime,jms:jme,p_oc_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_bc_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_bc_a04) + qsrflx(ims:ime,jms:jme,p_bc_a04) + + dvel(ims:ime,1,jms:jme,p_ddmass_ca_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_ca_a01) + qsrflx(ims:ime,jms:jme,p_ca_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_ca_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_ca_a02) + qsrflx(ims:ime,jms:jme,p_ca_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_ca_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_ca_a03) + qsrflx(ims:ime,jms:jme,p_ca_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_ca_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_ca_a04) + qsrflx(ims:ime,jms:jme,p_ca_a04) + + dvel(ims:ime,1,jms:jme,p_ddmass_co3_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_co3_a01) + qsrflx(ims:ime,jms:jme,p_co3_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_co3_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_co3_a02) + qsrflx(ims:ime,jms:jme,p_co3_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_co3_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_co3_a03) + qsrflx(ims:ime,jms:jme,p_co3_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_co3_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_co3_a04) + qsrflx(ims:ime,jms:jme,p_co3_a04) + + dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_a01) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r1_a01) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r2_a01) + & + qsrflx(ims:ime,jms:jme,p_glysoa_oh_a01) + & + qsrflx(ims:ime,jms:jme,p_glysoa_sfc_a01) + & + qsrflx(ims:ime,jms:jme,p_glysoa_nh4_a01) + + dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_a02) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r1_a02) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r2_a02) + & + qsrflx(ims:ime,jms:jme,p_glysoa_oh_a02) + & + qsrflx(ims:ime,jms:jme,p_glysoa_sfc_a02) + & + qsrflx(ims:ime,jms:jme,p_glysoa_nh4_a02) + + dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_a03) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r1_a03) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r2_a03) + & + qsrflx(ims:ime,jms:jme,p_glysoa_oh_a03) + & + qsrflx(ims:ime,jms:jme,p_glysoa_sfc_a03) + & + qsrflx(ims:ime,jms:jme,p_glysoa_nh4_a03) + + dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_a04) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r1_a04) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r2_a04) + & + qsrflx(ims:ime,jms:jme,p_glysoa_oh_a04) + & + qsrflx(ims:ime,jms:jme,p_glysoa_sfc_a04) + & + qsrflx(ims:ime,jms:jme,p_glysoa_nh4_a04) + + dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_a01) + qsrflx(ims:ime,jms:jme,p_asoaX_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_a01) + qsrflx(ims:ime,jms:jme,p_asoa1_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_a01) + qsrflx(ims:ime,jms:jme,p_asoa2_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_a01) + qsrflx(ims:ime,jms:jme,p_asoa3_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_a01) + qsrflx(ims:ime,jms:jme,p_asoa4_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_a01) + qsrflx(ims:ime,jms:jme,p_bsoaX_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_a01) + qsrflx(ims:ime,jms:jme,p_bsoa1_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_a01) + qsrflx(ims:ime,jms:jme,p_bsoa2_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_a01) + qsrflx(ims:ime,jms:jme,p_bsoa3_a01) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_a01) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_a01) + qsrflx(ims:ime,jms:jme,p_bsoa4_a01) + + dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_a02) + qsrflx(ims:ime,jms:jme,p_asoaX_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_a02) + qsrflx(ims:ime,jms:jme,p_asoa1_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_a02) + qsrflx(ims:ime,jms:jme,p_asoa2_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_a02) + qsrflx(ims:ime,jms:jme,p_asoa3_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_a02) + qsrflx(ims:ime,jms:jme,p_asoa4_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_a02) + qsrflx(ims:ime,jms:jme,p_bsoaX_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_a02) + qsrflx(ims:ime,jms:jme,p_bsoa1_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_a02) + qsrflx(ims:ime,jms:jme,p_bsoa2_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_a02) + qsrflx(ims:ime,jms:jme,p_bsoa3_a02) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_a02) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_a02) + qsrflx(ims:ime,jms:jme,p_bsoa4_a02) + + dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_a03) + qsrflx(ims:ime,jms:jme,p_asoaX_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_a03) + qsrflx(ims:ime,jms:jme,p_asoa1_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_a03) + qsrflx(ims:ime,jms:jme,p_asoa2_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_a03) + qsrflx(ims:ime,jms:jme,p_asoa3_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_a03) + qsrflx(ims:ime,jms:jme,p_asoa4_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_a03) + qsrflx(ims:ime,jms:jme,p_bsoaX_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_a03) + qsrflx(ims:ime,jms:jme,p_bsoa1_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_a03) + qsrflx(ims:ime,jms:jme,p_bsoa2_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_a03) + qsrflx(ims:ime,jms:jme,p_bsoa3_a03) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_a03) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_a03) + qsrflx(ims:ime,jms:jme,p_bsoa4_a03) + + dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_a04) + qsrflx(ims:ime,jms:jme,p_asoaX_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_a04) + qsrflx(ims:ime,jms:jme,p_asoa1_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_a04) + qsrflx(ims:ime,jms:jme,p_asoa2_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_a04) + qsrflx(ims:ime,jms:jme,p_asoa3_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_a04) + qsrflx(ims:ime,jms:jme,p_asoa4_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_a04) + qsrflx(ims:ime,jms:jme,p_bsoaX_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_a04) + qsrflx(ims:ime,jms:jme,p_bsoa1_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_a04) + qsrflx(ims:ime,jms:jme,p_bsoa2_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_a04) + qsrflx(ims:ime,jms:jme,p_bsoa3_a04) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_a04) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_a04) + qsrflx(ims:ime,jms:jme,p_bsoa4_a04) + +! and the same for settling cloud droplets + + dvel(ims:ime,1,jms:jme,p_ddmass_so4_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_so4_cw01) + qsrflx(ims:ime,jms:jme,p_so4_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_no3_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_no3_cw01) + qsrflx(ims:ime,jms:jme,p_no3_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_cl_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_cl_cw01) + qsrflx(ims:ime,jms:jme,p_cl_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_nh4_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_nh4_cw01) + qsrflx(ims:ime,jms:jme,p_nh4_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_na_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_na_cw01) + qsrflx(ims:ime,jms:jme,p_na_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_oin_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_oin_cw01) + qsrflx(ims:ime,jms:jme,p_oin_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_oc_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_oc_cw01) + qsrflx(ims:ime,jms:jme,p_oc_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_bc_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_bc_cw01) + qsrflx(ims:ime,jms:jme,p_bc_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_so4_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_so4_cw02) + qsrflx(ims:ime,jms:jme,p_so4_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_no3_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_no3_cw02) + qsrflx(ims:ime,jms:jme,p_no3_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_cl_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_cl_cw02) + qsrflx(ims:ime,jms:jme,p_cl_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_nh4_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_nh4_cw02) + qsrflx(ims:ime,jms:jme,p_nh4_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_na_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_na_cw02) + qsrflx(ims:ime,jms:jme,p_na_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_oin_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_oin_cw02) + qsrflx(ims:ime,jms:jme,p_oin_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_oc_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_oc_cw02) + qsrflx(ims:ime,jms:jme,p_oc_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_bc_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_bc_cw02) + qsrflx(ims:ime,jms:jme,p_bc_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_so4_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_so4_cw03) + qsrflx(ims:ime,jms:jme,p_so4_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_no3_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_no3_cw03) + qsrflx(ims:ime,jms:jme,p_no3_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_cl_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_cl_cw03) + qsrflx(ims:ime,jms:jme,p_cl_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_nh4_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_nh4_cw03) + qsrflx(ims:ime,jms:jme,p_nh4_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_na_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_na_cw03) + qsrflx(ims:ime,jms:jme,p_na_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_oin_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_oin_cw03) + qsrflx(ims:ime,jms:jme,p_oin_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_oc_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_oc_cw03) + qsrflx(ims:ime,jms:jme,p_oc_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_bc_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_bc_cw03) + qsrflx(ims:ime,jms:jme,p_bc_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_so4_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_so4_cw04) + qsrflx(ims:ime,jms:jme,p_so4_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_no3_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_no3_cw04) + qsrflx(ims:ime,jms:jme,p_no3_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_cl_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_cl_cw04) + qsrflx(ims:ime,jms:jme,p_cl_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_nh4_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_nh4_cw04) + qsrflx(ims:ime,jms:jme,p_nh4_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_na_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_na_cw04) + qsrflx(ims:ime,jms:jme,p_na_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_oin_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_oin_cw04) + qsrflx(ims:ime,jms:jme,p_oin_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_oc_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_oc_cw04) + qsrflx(ims:ime,jms:jme,p_oc_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_bc_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_bc_cw04) + qsrflx(ims:ime,jms:jme,p_bc_cw04) + + dvel(ims:ime,1,jms:jme,p_ddmass_ca_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_ca_cw01) + qsrflx(ims:ime,jms:jme,p_ca_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_ca_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_ca_cw02) + qsrflx(ims:ime,jms:jme,p_ca_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_ca_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_ca_cw03) + qsrflx(ims:ime,jms:jme,p_ca_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_ca_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_ca_cw04) + qsrflx(ims:ime,jms:jme,p_ca_cw04) + + dvel(ims:ime,1,jms:jme,p_ddmass_co3_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_co3_cw01) + qsrflx(ims:ime,jms:jme,p_co3_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_co3_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_co3_cw02) + qsrflx(ims:ime,jms:jme,p_co3_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_co3_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_co3_cw03) + qsrflx(ims:ime,jms:jme,p_co3_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_co3_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_co3_cw04) + qsrflx(ims:ime,jms:jme,p_co3_cw04) + + dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_cw01) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r1_cw01) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r2_cw01) + & + qsrflx(ims:ime,jms:jme,p_glysoa_oh_cw01) + & + qsrflx(ims:ime,jms:jme,p_glysoa_sfc_cw01) + & + qsrflx(ims:ime,jms:jme,p_glysoa_nh4_cw01) + + dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_cw02) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r1_cw02) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r2_cw02) + & + qsrflx(ims:ime,jms:jme,p_glysoa_oh_cw02) + & + qsrflx(ims:ime,jms:jme,p_glysoa_sfc_cw02) + & + qsrflx(ims:ime,jms:jme,p_glysoa_nh4_cw02) + + dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_cw03) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r1_cw03) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r2_cw03) + & + qsrflx(ims:ime,jms:jme,p_glysoa_oh_cw03) + & + qsrflx(ims:ime,jms:jme,p_glysoa_sfc_cw03) + & + qsrflx(ims:ime,jms:jme,p_glysoa_nh4_cw03) + + dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_glysoa_cw04) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r1_cw04) + & + qsrflx(ims:ime,jms:jme,p_glysoa_r2_cw04) + & + qsrflx(ims:ime,jms:jme,p_glysoa_oh_cw04) + & + qsrflx(ims:ime,jms:jme,p_glysoa_sfc_cw04) + & + qsrflx(ims:ime,jms:jme,p_glysoa_nh4_cw04) + + dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_cw01) + qsrflx(ims:ime,jms:jme,p_asoaX_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_cw01) + qsrflx(ims:ime,jms:jme,p_asoa1_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_cw01) + qsrflx(ims:ime,jms:jme,p_asoa2_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_cw01) + qsrflx(ims:ime,jms:jme,p_asoa3_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_cw01) + qsrflx(ims:ime,jms:jme,p_asoa4_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_cw01) + qsrflx(ims:ime,jms:jme,p_bsoaX_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_cw01) + qsrflx(ims:ime,jms:jme,p_bsoa1_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_cw01) + qsrflx(ims:ime,jms:jme,p_bsoa2_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_cw01) + qsrflx(ims:ime,jms:jme,p_bsoa3_cw01) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_cw01) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_cw01) + qsrflx(ims:ime,jms:jme,p_bsoa4_cw01) + + dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_cw02) + qsrflx(ims:ime,jms:jme,p_asoaX_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_cw02) + qsrflx(ims:ime,jms:jme,p_asoa1_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_cw02) + qsrflx(ims:ime,jms:jme,p_asoa2_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_cw02) + qsrflx(ims:ime,jms:jme,p_asoa3_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_cw02) + qsrflx(ims:ime,jms:jme,p_asoa4_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_cw02) + qsrflx(ims:ime,jms:jme,p_bsoaX_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_cw02) + qsrflx(ims:ime,jms:jme,p_bsoa1_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_cw02) + qsrflx(ims:ime,jms:jme,p_bsoa2_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_cw02) + qsrflx(ims:ime,jms:jme,p_bsoa3_cw02) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_cw02) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_cw02) + qsrflx(ims:ime,jms:jme,p_bsoa4_cw02) + + dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_cw03) + qsrflx(ims:ime,jms:jme,p_asoaX_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_cw03) + qsrflx(ims:ime,jms:jme,p_asoa1_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_cw03) + qsrflx(ims:ime,jms:jme,p_asoa2_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_cw03) + qsrflx(ims:ime,jms:jme,p_asoa3_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_cw03) + qsrflx(ims:ime,jms:jme,p_asoa4_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_cw03) + qsrflx(ims:ime,jms:jme,p_bsoaX_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_cw03) + qsrflx(ims:ime,jms:jme,p_bsoa1_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_cw03) + qsrflx(ims:ime,jms:jme,p_bsoa2_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_cw03) + qsrflx(ims:ime,jms:jme,p_bsoa3_cw03) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_cw03) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_cw03) + qsrflx(ims:ime,jms:jme,p_bsoa4_cw03) + + dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_asoaX_cw04) + qsrflx(ims:ime,jms:jme,p_asoaX_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa1_cw04) + qsrflx(ims:ime,jms:jme,p_asoa1_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa2_cw04) + qsrflx(ims:ime,jms:jme,p_asoa2_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa3_cw04) + qsrflx(ims:ime,jms:jme,p_asoa3_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_asoa4_cw04) + qsrflx(ims:ime,jms:jme,p_asoa4_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoaX_cw04) + qsrflx(ims:ime,jms:jme,p_bsoaX_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa1_cw04) + qsrflx(ims:ime,jms:jme,p_bsoa1_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa2_cw04) + qsrflx(ims:ime,jms:jme,p_bsoa2_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa3_cw04) + qsrflx(ims:ime,jms:jme,p_bsoa3_cw04) + dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_cw04) = dvel(ims:ime,1,jms:jme,p_ddmass_bsoa4_cw04) + qsrflx(ims:ime,jms:jme,p_bsoa4_cw04) + + endif + CASE DEFAULT END SELECT mixactivate_select + + IF((config_flags%dust_opt .EQ. 1) .OR. (config_flags%dust_opt .GE. 3) .OR. & + (config_flags%seas_opt .GE. 1) ) THEN settling_select: SELECT CASE(config_flags%chem_opt) CASE (DUST,GOCART_SIMPLE,GOCARTRACM_KPP,MOZCART_KPP,RADM2SORG,RADM2SORG_AQ, & RADM2SORG_AQCHEM,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP) @@ -738,6 +1374,7 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & CASE DEFAULT CALL wrf_debug(15,'no settling routine') END SELECT settling_select + ENDIF CALL wrf_debug(15,'end of dry_dep_driver') diff --git a/wrfv2_fire/chem/emissions_driver.F b/wrfv2_fire/chem/emissions_driver.F index 0aaf021e..ef32b766 100755 --- a/wrfv2_fire/chem/emissions_driver.F +++ b/wrfv2_fire/chem/emissions_driver.F @@ -15,7 +15,9 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & bioemdt,stepbioe, & config_flags,gmt,julday,alt,t_phy,moist,p8w,t8w,u_phy, & v_phy,vvel,e_bio,p_phy,chem,rho_phy,dz8w,ne_area,emis_ant, & - emis_vol,tsk,erod,g,emis_seas,emis_dust,tracer, & + emis_vol,tsk,erod,erod_dri,lai_vegmask, & + g,emis_seas,emis_dust,tracer, & + emis_seas2, & ebu, ebu_in,mean_fct_agtf,mean_fct_agef, & mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef, & firesize_agsv,firesize_aggr, & @@ -30,7 +32,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no, & - ebio_sesq, ebio_mbo, & + ebio_sesq, ebio_mbo,ebio_bpi,ebio_myrc, & ebio_c10h16,ebio_tol,ebio_bigalk,ebio_ch3oh,ebio_acet, & ebio_nh3,ebio_no2,ebio_c2h5oh,ebio_ch3cooh,ebio_mek, & ebio_bigene,ebio_c2h6,ebio_c2h4,ebio_c3h6,ebio_c3h8,ebio_so2, & @@ -39,8 +41,9 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ebio_aro1, ebio_aro2, ebio_ccho, ebio_meoh, & ebio_ethene, ebio_hcooh, ebio_terp, ebio_bald, & ebio_cco_oh, ebio_rco_oh, & - clayfrac,sandfrac,dust_alpha,dust_gamma,dust_smtune, & - snowh,zs, & + clayfrac,sandfrac,dust_alpha,dust_gamma,dust_smtune,dust_ustune, & + clayfrac_nga,sandfrac_nga, & + snowh,zs,afwa_dustloft,tot_dust,tot_edust,vis_dust, & soil_top_cat, ust_t, rough_cor, smois_cor, & ebio_c5h8,ebio_apinene,ebio_bpinene,ebio_toluene, & ebio_ch3cho,ebio_ch3co2h,ebio_tbut2ene,ebio_c2h5cho, & @@ -67,7 +70,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & vprm_in,rad_vprm,lambda_vprm,alpha_vprm,resp_vprm, & xtime,tslb,wet_in,rainc,rainnc,potevp,sfcevp,lu_index, & biomt_par,emit_par,ebio_co2oce,eghg_bio, & - + dust_flux, seas_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -83,6 +86,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & USE module_bioemi_megan2 USE module_aerosols_sorgam, only: sorgam_addemiss USE module_cbmz_addemiss + USE module_cb05_addemiss USE gocart_dust USE gocart_dust_afwa USE gocart_seasalt @@ -92,6 +96,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & USE module_add_emis_cptec USE module_add_emiss_burn USE module_plumerise1 + USE module_aerosols_sorgam_vbs, only: sorgam_vbs_addemiss USE module_aerosols_soa_vbs, only: soa_vbs_addemiss USE module_ghg_fluxes USE module_lightning_nox_driver @@ -130,7 +135,10 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & dms_0,tsk,erup_beg,erup_end REAL, DIMENSION( ims:ime, jms:jme,3),& INTENT(IN ) :: & - erod + erod, erod_dri + REAL, DIMENSION( ims:ime, jms:jme), & + INTENT(IN ) :: & + lai_vegmask REAL, DIMENSION( ims:ime, jms:jme,5),& INTENT(INOUT ) :: & dustin,seasin @@ -141,7 +149,10 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & OPTIONAL, & INTENT(INOUT ) :: & emis_seas - + REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_seas2), & + OPTIONAL, & + INTENT(INOUT ) :: & + emis_seas2 REAL, DIMENSION( ims:ime, jms:jme ), & OPTIONAL, & INTENT(IN ) :: & @@ -189,12 +200,26 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & INTENT(IN ) :: & clayfrac, & sandfrac, & + clayfrac_nga, & + sandfrac_nga, & snowh REAL, INTENT(IN ) :: dust_alpha, & dust_gamma, & - dust_smtune + dust_smtune, & + dust_ustune + REAL, DIMENSION( config_flags%num_soil_layers ) , & INTENT(IN ) :: zs + REAL, DIMENSION( ims:ime , jms:jme ) , & + OPTIONAL, & + INTENT( OUT) :: & + tot_edust, & + afwa_dustloft + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + OPTIONAL, & + INTENT( OUT) :: & + tot_dust, & + vis_dust REAL, DIMENSION( ims:ime, config_flags%num_soil_layers, jms:jme ) , & INTENT(INOUT ) :: smois, tslb @@ -209,7 +234,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no, & - ebio_sesq,ebio_mbo, & + ebio_sesq,ebio_mbo,ebio_bpi,ebio_myrc, & ebio_c10h16,ebio_tol,ebio_bigalk, ebio_ch3oh,ebio_acet, & ebio_nh3,ebio_no2,ebio_c2h5oh,ebio_ch3cooh,ebio_mek, & ebio_bigene,ebio_c2h6,ebio_c2h4,ebio_c3h6,ebio_c3h8, & @@ -292,6 +317,8 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & REAL, DIMENSION(ims:ime, 8, jms:jme, num_vprm_in), INTENT(IN) :: vprm_in REAL, DIMENSION(ims:ime, 1,jms:jme, num_eghg_bio), INTENT(INOUT ) :: eghg_bio + + REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: dust_flux, seas_flux ! CO2 REAL, DIMENSION(8) :: rad_vprm,lambda_vprm,alpha_vprm,resp_vprm ! CH4 @@ -501,7 +528,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & endif ! julday.ge.begday .and. julday.le.endday volc_select: SELECT CASE(config_flags%chem_opt) - CASE (GOCART_SIMPLE,MOZCART_KPP,GOCARTRADM2,GOCARTRACM_KPP,GOCARTRADM2_KPP) + CASE (GOCART_SIMPLE,MOZCART_KPP,GOCARTRADM2,GOCARTRACM_KPP) CALL wrf_debug(15,'Adding volcanic emissions') do k=kts,kte conv = 4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) @@ -696,9 +723,10 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & CASE (DUSTGOCARTAFWA) CALL wrf_debug(15,'AFWA modified Gocart dust emissions') call gocart_dust_afwa_driver(ktau,dtstep,config_flags,julday,alt,t_phy,moist,u_phy, & - v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod,dustin,snowh,zs, & - ivgtyp,isltyp,vegfra,xland,xlat,xlong,gsw,dx,g,emis_dust, & - ust,znt,clayfrac,sandfrac,dust_alpha,dust_gamma,dust_smtune, & + v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod,erod_dri,dustin,snowh,zs, & + ivgtyp,isltyp,vegfra,lai_vegmask,xland,xlat,xlong,gsw,dx,g,emis_dust, & + ust,znt,clayfrac,sandfrac,clayfrac_nga,sandfrac_nga,afwa_dustloft, &!EDH + tot_dust,tot_edust,vis_dust,dust_alpha,dust_gamma,dust_smtune,dust_ustune, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -792,7 +820,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ,RACMSORG_AQCHEM_KPP, & RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP,RACM_ESRLSORG_KPP, RACM_SOA_VBS_KPP, & - CBM4_KPP, NMHC9_KPP, GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP) + CBM4_KPP, NMHC9_KPP, GOCARTRACM_KPP,GOCARTRADM2) CASE DEFAULT CALL wrf_error_fatal( & "emissions_driver: beis3.1.4 biogenic emis. implemented for RADM2 & RACM only") @@ -839,7 +867,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ebio_c5h8,ebio_apinene,ebio_bpinene,ebio_toluene, & ebio_ch3cho,ebio_ch3co2h,ebio_tbut2ene,ebio_c2h5cho, & ebio_nc4h10, & - ebio_sesq, ebio_mbo, & + ebio_sesq, ebio_mbo,ebio_bpi,ebio_myrc, & ebio_alk3, ebio_alk4, ebio_alk5, ebio_ole1, ebio_ole2, & ebio_aro1, ebio_aro2, ebio_ccho, ebio_meoh, & ebio_ethene, ebio_hcooh, ebio_terp, ebio_bald, & @@ -863,8 +891,9 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & gas_addemiss_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP, & - RACM_SOA_VBS_KPP, RACM_ESRLSORG_KPP, MOZART_KPP, MOZCART_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP, CRIMECH_KPP, & - CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) + RACM_SOA_VBS_KPP, RACM_ESRLSORG_KPP, & + MOZART_KPP, MOZCART_KPP, MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP, & + CRIMECH_KPP, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) IF(config_flags%emiss_inpt_opt /= 3 ) then IF(config_flags%kemit .GT. kte-ksub) THEN k=config_flags%kemit @@ -878,8 +907,6 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) call wrf_debug(15,'emissions_driver calling add_biogenics') - ! Do NOT call add_biogenics if using MEGAN v2.04 biogenic emissions - ! module call add_biogenics(id,dtstep,dz8w,config_flags, rho_phy,chem, & e_bio,ne_area, & ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & @@ -889,41 +916,9 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) -! IF(config_flags%emiss_inpt_opt == EMISS_INPT_MOZCEM ) then -! do j=jts,jte -! do i=its,ite -! do k=kts,min(config_flags%kemit,kte-ksub) -! conv = alt(i,k,j)*dtstep/dz8w(i,k,j) -! chem(i,k,j,p_p10) = chem(i,k,j,p_p10) + emis_ant(i,k,j,p_e_pm_10)*conv -! chem(i,k,j,p_p25) = chem(i,k,j,p_p25) + emis_ant(i,k,j,p_e_pm_25)*conv -! chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) + emis_ant(i,k,j,p_e_bc)*conv -! chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) + emis_ant(i,k,j,p_e_oc)*conv -! chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) + emis_ant(i,k,j,p_e_sulf)*conv*mwdry/mw_so4_aer*1.e-3 -! end do -! end do -! end do -! end if end if ! emiss_inpt_opt /= 3 -! 20130725 acd_ck_bugfix start -! > double counting - already added in add_anthropogenics (module_emissions_anthropogenic.F) -! IF(config_flags%emiss_opt == 10 ) then -! do j=jts,jte -! do i=its,ite -! do k=kts,min(config_flags%kemit,kte-ksub) -! conv = 4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) -! -! chem(i,k,j,p_voca) = chem(i,k,j,p_voca) & -! +emis_ant(i,k,j,p_e_co_a)*conv*0.08*28./250. -! chem(i,k,j,p_vocbb) = chem(i,k,j,p_vocbb) & -! +emis_ant(i,k,j,p_e_co_bb)*conv*0.08*28./250. -! -! end do -! end do -! end do -! endif -! 20130725 acd_ck_bugfix end !For SAPRC99 need to define SAPRC99_addemiss_anthro and SAPRC99_addemiss_bio !so did not add saprcnov packages here @@ -944,10 +939,6 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) call wrf_debug(15,'emissions_driver calling cbmz_addemiss_bio') - !**BSINGH- Should I delete this comment?? - ! Do NOT call add_biogenics if using MEGAN v2.04 biogenic emissions - ! module - !BSINGH: 03/13/2013 !Commented out (or delete??) the following call to "cbmz_addemiss_bio"and !replaced with an "add_biogenic" call to make it consistent @@ -968,6 +959,28 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE (CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP) + IF(config_flags%kemit .GT. kte-ksub) THEN + message = ' EMISSIONS_DRIVER: KEMIT > KME ' + CALL WRF_ERROR_FATAL (message) + ENDIF + call wrf_debug(15,'emissions_driver calling cb05_addemiss_anthro') + call cb05_addemiss_anthro( id, dtstep, dz8w, config_flags, & + rho_phy, chem, & + emis_ant,ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + call wrf_debug(15,'emissions_driver calling cb05_addemiss_bio') + ! Do NOT call add_biogenics if using MEGAN v2.04 biogenic emissions + ! module + if ( config_flags%bio_emiss_opt .ne. megan2 ) then + call cb05_addemiss_bio( id, dtstep, dz8w, config_flags, & + rho_phy, chem, e_bio, ne_area, emis_ant(ims,kms,jms,p_e_iso),& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif + CASE (CHEM_TRACER) do j=jts,jte do i=its,ite @@ -1159,79 +1172,6 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - - CASE (CBMZ_MOSAIC_4BIN_VBS2_KPP) !FIX FOR SAPRC07A - if(config_flags%emiss_opt == 3 ) then - IF(config_flags%kemit .GT. kte-ksub) THEN - message = ' EMISSIONS_DRIVER: KEMIT > KME ' - CALL WRF_ERROR_FATAL (message) - ENDIF - call wrf_debug(15,'emissions_driver calling cbmz_addemiss_anthro') - call cbmz_addemiss_anthro( id, dtstep, dz8w, config_flags, & - rho_phy, chem, & - emis_ant,alt,ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - call wrf_debug(15,'emissions_driver calling cbmz_addemiss_bio') - - !**BSINGH- Should I delete this comment?? - ! Do NOT call add_biogenics if using MEGAN v2.04 biogenic emissions - ! module - if ( config_flags%bio_emiss_opt .ne. megan2 ) then - !BSINGH: 03/13/2013 - !Commented out (or delete??) the following call to "cbmz_addemiss_bio"and - !replaced with an "add_biogenic" call to make it consistent - !with other packages - !call cbmz_addemiss_bio( id, dtstep, dz8w, config_flags, & - ! rho_phy, chem, e_bio, ne_area, emis_ant(ims,kms,jms,p_e_iso),& - ! ids,ide, jds,jde, kds,kde, & - ! ims,ime, jms,jme, kms,kme, & - ! its,ite, jts,jte, kts,kte ) - - call add_biogenics(id,dtstep,dz8w,config_flags, rho_phy,chem, & - e_bio,ne_area, & - ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & - ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & - ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no, & - ebio_sesq,ebio_mbo, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - endif - do j=jts,jte - do i=its,ite - do k=kts,min(config_flags%kemit,kte-ksub) - conv = 4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) - conv3 = (dtstep/dz8w(i,k,j))*alt(i,k,j)*28/250*1e-3! Molecular weight of C(15)H(27)N(0.3)O(4.5) - conv4= (dtstep/dz8w(i,k,j))*alt(i,k,j)*28/226*1e-3 ! Molecular weight of C(15)H(27)N(0.3)O(0.9) - oconv3= (dtstep/dz8w(i,k,j))*alt(i,k,j)*28/283*1e-3*4.5 !For biomass there are 4.5 moles of ) /mole of C15H27N0.3 - oconv4=(dtstep/dz8w(i,k,j))*alt(i,k,j)*28/226*1e-3*0.9 !For fossil there are 0.9 moles of O per mole of C15H27N0.3 - -!Use OM/OC of 1.25 for fossil and OM:OC of 1.57 for biomass -! O:C=0.06,H:C=1.8, N:C=0.02 for fossil : OM/OC=(16*0.06+12+14*0.02+12)/12=1.25 -!O:C=0.3 H:C=1.8, N:C=0.02 for biomass, OM/OC=1.57 for biomass - - chem(i,k,j,p_pcg1_b_c) = chem(i,k,j,p_pcg1_b_c) & - +(emis_ant(i,k,j,p_e_orgi_bb)/1.57+emis_ant(i,k,j,p_e_orgj_bb)/1.57)*conv3*1.17 - chem(i,k,j,p_pcg2_b_c) = chem(i,k,j,p_pcg2_b_c) & - +(emis_ant(i,k,j,p_e_orgi_bb)/1.57+emis_ant(i,k,j,p_e_orgj_bb)/1.57)*conv3*7.605 - chem(i,k,j,p_pcg1_f_c) = chem(i,k,j,p_pcg1_f_c) & - +(emis_ant(i,k,j,p_e_orgi_a)/1.25+emis_ant(i,k,j,p_e_orgj_a)/1.25)*conv3*1.17 - chem(i,k,j,p_pcg2_f_c) = chem(i,k,j,p_pcg2_f_c) & - +(emis_ant(i,k,j,p_e_orgi_a)/1.25+emis_ant(i,k,j,p_e_orgj_a)/1.25)*conv3*7.605 - chem(i,k,j,p_pcg1_b_o) = chem(i,k,j,p_pcg1_b_o) & - +(emis_ant(i,k,j,p_e_orgi_bb)/1.57+emis_ant(i,k,j,p_e_orgj_bb)/1.57)*conv3*0.40 - chem(i,k,j,p_pcg2_b_o) = chem(i,k,j,p_pcg2_b_o) & - +(emis_ant(i,k,j,p_e_orgi_bb)/1.57+emis_ant(i,k,j,p_e_orgj_bb)/1.57)*conv3*2.60 - chem(i,k,j,p_pcg1_f_o) = chem(i,k,j,p_pcg1_f_o) & - +(emis_ant(i,k,j,p_e_orgi_a)/1.25+emis_ant(i,k,j,p_e_orgj_a)/1.25)*conv3*0.08 - chem(i,k,j,p_pcg2_f_o) = chem(i,k,j,p_pcg2_f_o) & - +(emis_ant(i,k,j,p_e_orgi_a)/1.25+emis_ant(i,k,j,p_e_orgj_a)/1.25)*conv3*0.52 - - end do - end do - end do - endif CASE (SAPRC99_MOSAIC_4BIN_VBS2_KPP) !FIX FOR SAPRC07A if(config_flags%emiss_opt == 13 ) then do j=jts,jte @@ -1376,7 +1316,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP) + CASE (GOCARTRACM_KPP,GOCARTRADM2) IF(config_flags%emiss_inpt_opt /= 3 ) then IF(config_flags%kemit .GT. kte-ksub) THEN k=config_flags%kemit @@ -1506,7 +1446,8 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & aer_addemiss_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RADM2SORG_KPP, & - RACMSORG_AQ,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACMSORG_KPP,RACM_ESRLSORG_KPP,CBMZSORG,CBMZSORG_AQ) + RACMSORG_AQ,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACMSORG_KPP,RACM_ESRLSORG_KPP,CBMZSORG,CBMZSORG_AQ, & + CB05_SORG_AQ_KPP) call wrf_debug(15,'emissions_driver calling sorgam_addemiss') call sorgam_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, & ebu, & @@ -1515,13 +1456,28 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & seasalt_emiss_active,config_flags%kemit, & config_flags%biomass_burn_opt, & config_flags%num_soil_layers,config_flags%emiss_opt, & -!jdf config_flags%dust_opt, & ktau,p8w,u_phy,v_phy,rho_phy,g,dx,erod, & -!jdf ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + + CASE (CB05_SORG_VBS_AQ_KPP) + call wrf_debug(15,'emissions_driver calling sorgam_vbs_addemiss') + call sorgam_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, & + ebu, & + slai,ust,smois,ivgtyp,isltyp, & + emis_ant,dust_emiss_active, & + seasalt_emiss_active,config_flags%kemit, & + config_flags%biomass_burn_opt, & + config_flags%num_soil_layers,config_flags%emiss_opt, & + config_flags%dust_opt, & + ktau,p8w,u_phy,v_phy,rho_phy,g,dx,erod, & + emis_seas2, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! CASE (RACM_SOA_VBS_KPP) call wrf_debug(15,'emissions_driver calling soa_vbs_addemiss') @@ -1544,17 +1500,16 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ,SAPRC99_MOSAIC_4BIN_VBS2_KPP,& - CBMZ_MOSAIC_4BIN_VBS2_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP, & - CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) + MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP ) call wrf_debug(15,'emissions_driver calling mosaic_addemiss') call mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & config_flags, chem, slai, ust, smois, ivgtyp, isltyp, & -!jdf emis_ant,ebu,config_flags%biomass_burn_opt, & config_flags%dust_opt, & ktau,p8w,u_phy,v_phy,rho_phy,g,dx,erod, & -!jdf dust_emiss_active, seasalt_emiss_active, & + dust_flux, seas_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) diff --git a/wrfv2_fire/chem/isocom.F b/wrfv2_fire/chem/isocom.F new file mode 100755 index 00000000..aea71106 --- /dev/null +++ b/wrfv2_fire/chem/isocom.F @@ -0,0 +1,4918 @@ +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISOROPIA +! *** THIS SUBROUTINE IS THE MASTER ROUTINE FOR THE ISORROPIA +! THERMODYNAMIC EQUILIBRIUM AEROSOL MODEL (VERSION 1.1 and above) +! +! ======================== ARGUMENTS / USAGE =========================== +! +! INPUT: +! 1. [WI] +! DOUBLE PRECISION array of length [5]. +! Concentrations, expressed in moles/m3. Depending on the type of +! problem solved (specified in CNTRL(1)), WI contains either +! GAS+AEROSOL or AEROSOL only concentratios. +! WI(1) - sodium +! WI(2) - sulfate +! WI(3) - ammonium +! WI(4) - nitrate +! WI(5) - chloride +! +! 2. [RHI] +! DOUBLE PRECISION variable. +! Ambient relative humidity expressed on a (0,1) scale. +! +! 3. [TEMPI] +! DOUBLE PRECISION variable. +! Ambient temperature expressed in Kelvins. +! +! 4. [CNTRL] +! DOUBLE PRECISION array of length [2]. +! Parameters that control the type of problem solved. +! +! CNTRL(1): Defines the type of problem solved. +! 0 - Forward problem is solved. In this case, array WI contains +! GAS and AEROSOL concentrations together. +! 1 - Reverse problem is solved. In this case, array WI contains +! AEROSOL concentrations only. +! +! CNTRL(2): Defines the state of the aerosol +! 0 - The aerosol can have both solid+liquid phases (deliquescent) +! 1 - The aerosol is in only liquid state (metastable aerosol) +! +! OUTPUT: +! 1. [WT] +! DOUBLE PRECISION array of length [5]. +! Total concentrations (GAS+AEROSOL) of species, expressed in moles/m3. +! If the foreward probelm is solved (CNTRL(1)=0), array WT is +! identical to array WI. +! WT(1) - total sodium +! WT(2) - total sulfate +! WT(3) - total ammonium +! WT(4) - total nitrate +! WT(5) - total chloride +! +! 2. [GAS] +! DOUBLE PRECISION array of length [03]. +! Gaseous species concentrations, expressed in moles/m3. +! GAS(1) - NH3 +! GAS(2) - HNO3 +! GAS(3) - HCl +! +! 3. [AERLIQ] +! DOUBLE PRECISION array of length [11]. +! Liquid aerosol species concentrations, expressed in moles/m3. +! AERLIQ(01) - H+(aq) +! AERLIQ(02) - Na+(aq) +! AERLIQ(03) - NH4+(aq) +! AERLIQ(04) - Cl-(aq) +! AERLIQ(05) - SO4--(aq) +! AERLIQ(06) - HSO4-(aq) +! AERLIQ(07) - NO3-(aq) +! AERLIQ(08) - H2O +! AERLIQ(09) - NH3(aq) (undissociated) +! AERLIQ(10) - HNCl(aq) (undissociated) +! AERLIQ(11) - HNO3(aq) (undissociated) +! AERLIQ(12) - OH-(aq) +! +! 4. [AERSLD] +! DOUBLE PRECISION array of length [09]. +! Solid aerosol species concentrations, expressed in moles/m3. +! AERSLD(01) - NaNO3(s) +! AERSLD(02) - NH4NO3(s) +! AERSLD(03) - NaCl(s) +! AERSLD(04) - NH4Cl(s) +! AERSLD(05) - Na2SO4(s) +! AERSLD(06) - (NH4)2SO4(s) +! AERSLD(07) - NaHSO4(s) +! AERSLD(08) - NH4HSO4(s) +! AERSLD(09) - (NH4)4H(SO4)2(s) +! +! 5. [SCASI] +! CHARACTER*15 variable. +! Returns the subcase which the input corresponds to. +! +! 6. [OTHER] +! DOUBLE PRECISION array of length [6]. +! Returns solution information. +! +! OTHER(1): Shows if aerosol water exists. +! 0 - Aerosol is WET +! 1 - Aerosol is DRY +! +! OTHER(2): Aerosol Sulfate ratio, defined as (in moles/m3) : +! (total ammonia + total Na) / (total sulfate) +! +! OTHER(3): Sulfate ratio based on aerosol properties that defines +! a sulfate poor system: +! (aerosol ammonia + aerosol Na) / (aerosol sulfate) +! +! OTHER(4): Aerosol sodium ratio, defined as (in moles/m3) : +! (total Na) / (total sulfate) +! +! OTHER(5): Ionic strength of the aqueous aerosol (if it exists). +! +! OTHER(6): Total number of calls to the activity coefficient +! calculation subroutine. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE ISOROPIA (WI, RHI, TEMPI, CNTRL, & + WT, GAS, AERLIQ, AERSLD, SCASI, OTHER) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + PARAMETER (NCTRL=2,NOTHER=6) + CHARACTER SCASI*15 + DIMENSION WI(NCOMP), WT(NCOMP), GAS(NGASAQ), AERSLD(NSLDS), & + AERLIQ(NIONS+NGASAQ+2), CNTRL(NCTRL), OTHER(NOTHER) +! +! *** PROBLEM TYPE (0=FOREWARD, 1=REVERSE) ****************************** +! + IPROB = NINT(CNTRL(1)) +! +! *** AEROSOL STATE (0=SOLID+LIQUID, 1=METASTABLE) ********************** +! + METSTBL = NINT(CNTRL(2)) +! +! *** SOLVE FOREWARD PROBLEM ******************************************** +! +50 IF (IPROB.EQ.0) THEN + IF (WI(1)+WI(2)+WI(3)+WI(4)+WI(5) .LE. TINY) THEN ! Everything=0 + CALL INIT1 (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(4)+WI(5) .LE. TINY) THEN ! Na,Cl,NO3=0 + CALL ISRP1F (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(5) .LE. TINY) THEN ! Na,Cl=0 + CALL ISRP2F (WI, RHI, TEMPI) + ELSE + CALL ISRP3F (WI, RHI, TEMPI) + ENDIF +! +! *** SOLVE REVERSE PROBLEM ********************************************* +! + ELSE + IF (WI(1)+WI(2)+WI(3)+WI(4)+WI(5) .LE. TINY) THEN ! Everything=0 + CALL INIT1 (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(4)+WI(5) .LE. TINY) THEN ! Na,Cl,NO3=0 + CALL ISRP1R (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(5) .LE. TINY) THEN ! Na,Cl=0 + CALL ISRP2R (WI, RHI, TEMPI) + ELSE + CALL ISRP3R (WI, RHI, TEMPI) + ENDIF + ENDIF +! +! *** ADJUST MASS BALANCE *********************************************** +! + IF (NADJ.EQ.1) CALL ADJUST (WI) +!cC +!cC *** IF METASTABLE AND NO WATER - RESOLVE AS NORMAL ******************** +!cC +!c IF (WATER.LE.TINY .AND. METSTBL.EQ.1) THEN +!c METSTBL = 0 +!c GOTO 50 +!c ENDIF +! +! *** SAVE RESULTS TO ARRAYS (units = mole/m3) **************************** +! + GAS(1) = GNH3 ! Gaseous aerosol species + GAS(2) = GHNO3 + GAS(3) = GHCL +! + DO 10 I=1,NIONS ! Liquid aerosol species + AERLIQ(I) = MOLAL(I) + 10 CONTINUE + DO 20 I=1,NGASAQ + AERLIQ(NIONS+1+I) = GASAQ(I) + 20 CONTINUE + AERLIQ(NIONS+1) = WATER*1.0D3/18.0D0 + AERLIQ(NIONS+NGASAQ+2) = COH +! + AERSLD(1) = CNANO3 ! Solid aerosol species + AERSLD(2) = CNH4NO3 + AERSLD(3) = CNACL + AERSLD(4) = CNH4CL + AERSLD(5) = CNA2SO4 + AERSLD(6) = CNH42S4 + AERSLD(7) = CNAHSO4 + AERSLD(8) = CNH4HS4 + AERSLD(9) = CLC +! + IF(WATER.LE.TINY) THEN ! Dry flag + OTHER(1) = 1.d0 + ELSE + OTHER(1) = 0.d0 + ENDIF +! + OTHER(2) = SULRAT ! Other stuff + OTHER(3) = SULRATW + OTHER(4) = SODRAT + OTHER(5) = IONIC + OTHER(6) = ICLACT +! + SCASI = SCASE +! + WT(1) = WI(1) ! Total gas+aerosol phase + WT(2) = WI(2) + WT(3) = WI(3) + WT(4) = WI(4) + WT(5) = WI(5) + IF (IPROB.GT.0 .AND. WATER.GT.TINY) THEN + WT(3) = WT(3) + GNH3 + WT(4) = WT(4) + GHNO3 + WT(5) = WT(5) + GHCL + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE ISOROPIA ****************************************** +! + END +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE SETPARM +! *** THIS SUBROUTINE REDEFINES THE SOLUTION PARAMETERS OF ISORROPIA +! +! ======================== ARGUMENTS / USAGE =========================== +! +! *** NOTE: IF NEGATIVE VALUES ARE GIVEN FOR A PARAMETER, IT IS +! IGNORED AND THE CURRENT VALUE IS USED INSTEAD. +! +! INPUT: +! 1. [WFTYPI] +! INTEGER variable. +! Defines the type of weighting algorithm for the solution in Mutual +! Deliquescence Regions (MDR's): +! 0 - MDR's are assumed dry. This is equivalent to the approach +! used by SEQUILIB. +! 1 - The solution is assumed "half" dry and "half" wet throughout +! the MDR. +! 2 - The solution is a relative-humidity weighted mean of the +! dry and wet solutions (as defined in Nenes et al., 1998) +! +! 2. [IACALCI] +! INTEGER variable. +! Method of activity coefficient calculation: +! 0 - Calculate coefficients during runtime +! 1 - Use precalculated tables +! +! 3. [EPSI] +! DOUBLE PRECITION variable. +! Defines the convergence criterion for all iterative processes +! in ISORROPIA, except those for activity coefficient calculations +! (EPSACTI controls that). +! +! 4. [MAXITI] +! INTEGER variable. +! Defines the maximum number of iterations for all iterative +! processes in ISORROPIA, except for activity coefficient calculations +! (NSWEEPI controls that). +! +! 5. [NSWEEPI] +! INTEGER variable. +! Defines the maximum number of iterations for activity coefficient +! calculations. +! +! 6. [EPSACTI] +! DOUBLE PRECISION variable. +! Defines the convergence criterion for activity coefficient +! calculations. +! +! 7. [NDIV] +! INTEGER variable. +! Defines the number of subdivisions needed for the initial root +! tracking for the bisection method. Usually this parameter should +! not be altered, but is included for completeness. +! +! 8. [NADJ] +! INTEGER variable. +! Forces the solution obtained to satisfy total mass balance +! to machine precision +! 0 - No adjustment done (default) +! 1 - Do adjustment +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE SETPARM (WFTYPI, IACALCI, EPSI, MAXITI, NSWEEPI, & + EPSACTI, NDIVI, NADJI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + INTEGER WFTYPI +! +! *** SETUP SOLUTION PARAMETERS ***************************************** +! + IF (WFTYPI .GE. 0) WFTYP = WFTYPI + IF (IACALCI.GE. 0) IACALC = IACALCI + IF (EPSI .GE.ZERO) EPS = EPSI + IF (MAXITI .GT. 0) MAXIT = MAXITI + IF (NSWEEPI.GT. 0) NSWEEP = NSWEEPI + IF (EPSACTI.GE.ZERO) EPSACT = EPSACTI + IF (NDIVI .GT. 0) NDIV = NDIVI + IF (NADJI .GE. 0) NADJ = NADJI +! +! *** END OF SUBROUTINE SETPARM ***************************************** +! + RETURN + END + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE GETPARM +! *** THIS SUBROUTINE OBTAINS THE CURRENT VAULES OF THE SOLUTION +! PARAMETERS OF ISORROPIA +! +! ======================== ARGUMENTS / USAGE =========================== +! +! *** THE PARAMETERS ARE THOSE OF SUBROUTINE SETPARM +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE GETPARM (WFTYPI, IACALCI, EPSI, MAXITI, NSWEEPI, & + EPSACTI, NDIVI, NADJI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + INTEGER WFTYPI +! +! *** GET SOLUTION PARAMETERS ******************************************* +! + WFTYPI = WFTYP + IACALCI = IACALC + EPSI = EPS + MAXITI = MAXIT + NSWEEPI = NSWEEP + EPSACTI = EPSACT + NDIVI = NDIV + NADJI = NADJ +! +! *** END OF SUBROUTINE GETPARM ***************************************** +! + RETURN + END + +!======================================================================= +! +! *** ISORROPIA CODE +! *** BLOCK DATA BLKISO +! *** THIS SUBROUTINE PROVIDES INITIAL (DEFAULT) VALUES TO PROGRAM +! PARAMETERS VIA DATA STATEMENTS +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +! *** ZSR RELATIONSHIP PARAMETERS MODIFIED BY DOUGLAS WALDRON +! *** OCTOBER 2003 +! *** BASED ON AIM MODEL III (http://mae.ucdavis.edu/wexler/aim) +! +!======================================================================= +! + BLOCK DATA BLKISO + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** DEFAULT VALUES ************************************************* +! *** OTHER PARAMETERS *********************************************** +! +! *** ZSR RELATIONSHIP PARAMETERS ************************************** +! *** END OF BLOCK DATA SUBPROGRAM ************************************* +! + END +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE INIT1 +! *** THIS SUBROUTINE INITIALIZES ALL GLOBAL VARIABLES FOR AMMONIUM +! SULFATE AEROSOL SYSTEMS (SUBROUTINE ISRP1) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE INIT1 (WI, RHI, TEMPI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DIMENSION WI(NCOMP) + REAL IC,GII,GI0,XX,LN10 + PARAMETER (LN10=2.3025851) +! +! *** SAVE INPUT VARIABLES IN COMMON BLOCK ****************************** +! + IF (IPROB.EQ.0) THEN ! FORWARD CALCULATION + DO 10 I=1,NCOMP + W(I) = MAX(WI(I), TINY) +10 CONTINUE + ELSE + DO 15 I=1,NCOMP ! REVERSE CALCULATION + WAER(I) = MAX(WI(I), TINY) + W(I) = ZERO +15 CONTINUE + ENDIF + RH = RHI + TEMP = TEMPI +! +! *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +! + XK1 = 1.015e-2 ! HSO4(aq) <==> H(aq) + SO4(aq) + XK21 = 57.639 ! NH3(g) <==> NH3(aq) + XK22 = 1.805e-5 ! NH3(aq) <==> NH4(aq) + OH(aq) + XK7 = 1.817 ! (NH4)2SO4(s) <==> 2*NH4(aq) + SO4(aq) + XK12 = 1.382e2 ! NH4HSO4(s) <==> NH4(aq) + HSO4(aq) + XK13 = 29.268 ! (NH4)3H(SO4)2(s) <==> 3*NH4(aq) + HSO4(aq) + SO4(aq) + XKW = 1.010e-14 ! H2O <==> H(aq) + OH(aq) +! + IF (INT(TEMP) .NE. 298) THEN ! FOR T != 298K or 298.15K + T0 = 298.15 + T0T = T0/TEMP + COEF= 1.0+LOG(T0T)-T0T + XK1 = XK1 *EXP( 8.85*(T0T-1.0) + 25.140*COEF) + XK21= XK21*EXP( 13.79*(T0T-1.0) - 5.393*COEF) + XK22= XK22*EXP( -1.50*(T0T-1.0) + 26.920*COEF) + XK7 = XK7 *EXP( -2.65*(T0T-1.0) + 38.570*COEF) + XK12= XK12*EXP( -2.87*(T0T-1.0) + 15.830*COEF) + XK13= XK13*EXP( -5.19*(T0T-1.0) + 54.400*COEF) + XKW = XKW *EXP(-22.52*(T0T-1.0) + 26.920*COEF) + ENDIF + XK2 = XK21*XK22 +! +! *** CALCULATE DELIQUESCENCE RELATIVE HUMIDITIES (UNICOMPONENT) ******** +! + DRH2SO4 = 0.0000D0 + DRNH42S4 = 0.7997D0 + DRNH4HS4 = 0.4000D0 + DRLC = 0.6900D0 + IF (INT(TEMP) .NE. 298) THEN + T0 = 298.15d0 + TCF = 1.0/TEMP - 1.0/T0 + DRNH42S4 = DRNH42S4*EXP( 80.*TCF) + DRNH4HS4 = DRNH4HS4*EXP(384.*TCF) + DRLC = DRLC *EXP(186.*TCF) + ENDIF +! +! *** CALCULATE MUTUAL DELIQUESCENCE RELATIVE HUMIDITIES **************** +! + DRMLCAB = 0.3780D0 ! (NH4)3H(SO4)2 & NH4HSO4 + DRMLCAS = 0.6900D0 ! (NH4)3H(SO4)2 & (NH4)2SO4 +!CC IF (INT(TEMP) .NE. 298) THEN ! For the time being. +!CC T0 = 298.15d0 +!CC TCF = 1.0/TEMP - 1.0/T0 +!CC DRMLCAB = DRMLCAB*EXP(507.506*TCF) +!CC DRMLCAS = DRMLCAS*EXP(133.865*TCF) +!CC ENDIF +! +! *** LIQUID PHASE ****************************************************** +! + CHNO3 = ZERO + CHCL = ZERO + CH2SO4 = ZERO + COH = ZERO + WATER = TINY +! + DO 20 I=1,NPAIR + MOLALR(I)=ZERO + GAMA(I) =0.1 + GAMIN(I) =GREAT + GAMOU(I) =GREAT + M0(I) =1d5 + 20 CONTINUE +! + DO 30 I=1,NPAIR + GAMA(I) = 0.1d0 + 30 CONTINUE +! + DO 40 I=1,NIONS + MOLAL(I)=ZERO +40 CONTINUE + COH = ZERO +! + DO 50 I=1,NGASAQ + GASAQ(I)=ZERO +50 CONTINUE +! +! *** SOLID PHASE ******************************************************* +! + CNH42S4= ZERO + CNH4HS4= ZERO + CNACL = ZERO + CNA2SO4= ZERO + CNANO3 = ZERO + CNH4NO3= ZERO + CNH4CL = ZERO + CNAHSO4= ZERO + CLC = ZERO +! +! *** GAS PHASE ********************************************************* +! + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO +! +! *** CALCULATE ZSR PARAMETERS ****************************************** +! + IRH = MIN (INT(RH*NZSR+0.5),NZSR) ! Position in ZSR arrays + IRH = MAX (IRH, 1) +! +! M0(01) = AWSC(IRH) ! NACl +! IF (M0(01) .LT. 100.0) THEN +! IC = M0(01) +! CALL KMTAB(IC,298.0, GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(01) = M0(01)*EXP(LN10*(GI0-GII)) +! ENDIF +! +! M0(02) = AWSS(IRH) ! (NA)2SO4 +! IF (M0(02) .LT. 100.0) THEN +! IC = 3.0*M0(02) +! CALL KMTAB(IC,298.0, XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(02) = M0(02)*EXP(LN10*(GI0-GII)) +! ENDIF +! +! M0(03) = AWSN(IRH) ! NANO3 +! IF (M0(03) .LT. 100.0) THEN +! IC = M0(03) +! CALL KMTAB(IC,298.0, XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(03) = M0(03)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(04) = AWAS(IRH) ! (NH4)2SO4 +! IF (M0(04) .LT. 100.0) THEN +! IC = 3.0*M0(04) +! CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(04) = M0(04)*EXP(LN10*(GI0-GII)) +! ENDIF +! +! M0(05) = AWAN(IRH) ! NH4NO3 +! IF (M0(05) .LT. 100.0) THEN +! IC = M0(05) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX) +! M0(05) = M0(05)*EXP(LN10*(GI0-GII)) +! ENDIF +! +! M0(06) = AWAC(IRH) ! NH4CL +! IF (M0(06) .LT. 100.0) THEN +! IC = M0(06) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX) +! M0(06) = M0(06)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(07) = AWSA(IRH) ! 2H-SO4 +! IF (M0(07) .LT. 100.0) THEN +! IC = 3.0*M0(07) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX) +! M0(07) = M0(07)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(08) = AWSA(IRH) ! H-HSO4 +!CC IF (M0(08) .LT. 100.0) THEN ! These are redundant, because M0(8) is not used +!CC IC = M0(08) +!CC CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +!CC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +!CCCCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX) +!CC M0(08) = M0(08)*EXP(LN10*(GI0-GII)) +!CC ENDIF +! + M0(09) = AWAB(IRH) ! NH4HSO4 +! IF (M0(09) .LT. 100.0) THEN +! IC = M0(09) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX) +! M0(09) = M0(09)*EXP(LN10*(GI0-GII)) +! ENDIF +! +! M0(12) = AWSB(IRH) ! NAHSO4 +! IF (M0(12) .LT. 100.0) THEN +! IC = M0(12) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GI0) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GII) +! M0(12) = M0(12)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(13) = AWLC(IRH) ! (NH4)3H(SO4)2 +! IF (M0(13) .LT. 100.0) THEN +! IC = 4.0*M0(13) +! CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +! G130 = 0.2*(3.0*GI0+2.0*GII) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +! G13I = 0.2*(3.0*GI0+2.0*GII) +! M0(13) = M0(13)*EXP(LN10*SNGL(G130-G13I)) +! ENDIF +! +! *** OTHER INITIALIZATIONS ********************************************* +! + ICLACT = 0 + CALAOU = .TRUE. + CALAIN = .TRUE. + FRST = .TRUE. + SCASE = '??' + SULRATW = 2.D0 + SODRAT = ZERO + NOFER = 0 + STKOFL =.FALSE. + DO 60 I=1,NERRMX + ERRSTK(I) =-999 + ERRMSG(I) = 'MESSAGE N/A' + 60 CONTINUE +! +! *** END OF SUBROUTINE INIT1 ******************************************* +! + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE INIT2 +! *** THIS SUBROUTINE INITIALIZES ALL GLOBAL VARIABLES FOR AMMONIUM, +! NITRATE, SULFATE AEROSOL SYSTEMS (SUBROUTINE ISRP2) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE INIT2 (WI, RHI, TEMPI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DIMENSION WI(NCOMP) + REAL IC,GII,GI0,XX,LN10 + PARAMETER (LN10=2.3025851) +! +! *** SAVE INPUT VARIABLES IN COMMON BLOCK ****************************** +! + IF (IPROB.EQ.0) THEN ! FORWARD CALCULATION + DO 10 I=1,NCOMP + W(I) = MAX(WI(I), TINY) +10 CONTINUE + ELSE + DO 15 I=1,NCOMP ! REVERSE CALCULATION + WAER(I) = MAX(WI(I), TINY) + W(I) = ZERO +15 CONTINUE + ENDIF + RH = RHI + TEMP = TEMPI +! +! *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +! + XK1 = 1.015e-2 ! HSO4(aq) <==> H(aq) + SO4(aq) + XK21 = 57.639 ! NH3(g) <==> NH3(aq) + XK22 = 1.805e-5 ! NH3(aq) <==> NH4(aq) + OH(aq) + XK4 = 2.511e6 ! HNO3(g) <==> H(aq) + NO3(aq) ! ISORR +!CC XK4 = 3.638e6 ! HNO3(g) <==> H(aq) + NO3(aq) ! SEQUIL + XK41 = 2.100e5 ! HNO3(g) <==> HNO3(aq) + XK7 = 1.817 ! (NH4)2SO4(s) <==> 2*NH4(aq) + SO4(aq) + XK10 = 5.746e-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! ISORR +!CC XK10 = 2.985e-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! SEQUIL + XK12 = 1.382e2 ! NH4HSO4(s) <==> NH4(aq) + HSO4(aq) + XK13 = 29.268 ! (NH4)3H(SO4)2(s) <==> 3*NH4(aq) + HSO4(aq) + SO4(aq) + XKW = 1.010e-14 ! H2O <==> H(aq) + OH(aq) +! + IF (INT(TEMP) .NE. 298) THEN ! FOR T != 298K or 298.15K + T0 = 298.15D0 + T0T = T0/TEMP + COEF= 1.0+LOG(T0T)-T0T + XK1 = XK1 *EXP( 8.85*(T0T-1.0) + 25.140*COEF) + XK21= XK21*EXP( 13.79*(T0T-1.0) - 5.393*COEF) + XK22= XK22*EXP( -1.50*(T0T-1.0) + 26.920*COEF) + XK4 = XK4 *EXP( 29.17*(T0T-1.0) + 16.830*COEF) !ISORR +!CC XK4 = XK4 *EXP( 29.47*(T0T-1.0) + 16.840*COEF) ! SEQUIL + XK41= XK41*EXP( 29.17*(T0T-1.0) + 16.830*COEF) + XK7 = XK7 *EXP( -2.65*(T0T-1.0) + 38.570*COEF) + XK10= XK10*EXP(-74.38*(T0T-1.0) + 6.120*COEF) ! ISORR +!CC XK10= XK10*EXP(-75.11*(T0T-1.0) + 13.460*COEF) ! SEQUIL + XK12= XK12*EXP( -2.87*(T0T-1.0) + 15.830*COEF) + XK13= XK13*EXP( -5.19*(T0T-1.0) + 54.400*COEF) + XKW = XKW *EXP(-22.52*(T0T-1.0) + 26.920*COEF) + ENDIF + XK2 = XK21*XK22 + XK42 = XK4/XK41 +! +! *** CALCULATE DELIQUESCENCE RELATIVE HUMIDITIES (UNICOMPONENT) ******** +! + DRH2SO4 = ZERO + DRNH42S4 = 0.7997D0 + DRNH4HS4 = 0.4000D0 + DRNH4NO3 = 0.6183D0 + DRLC = 0.6900D0 + IF (INT(TEMP) .NE. 298) THEN + T0 = 298.15D0 + TCF = 1.0/TEMP - 1.0/T0 + DRNH4NO3 = DRNH4NO3*EXP(852.*TCF) + DRNH42S4 = DRNH42S4*EXP( 80.*TCF) + DRNH4HS4 = DRNH4HS4*EXP(384.*TCF) + DRLC = DRLC *EXP(186.*TCF) + DRNH4NO3 = MIN (DRNH4NO3,DRNH42S4) ! ADJUST FOR DRH CROSSOVER AT T<271K + ENDIF +! +! *** CALCULATE MUTUAL DELIQUESCENCE RELATIVE HUMIDITIES **************** +! + DRMLCAB = 0.3780D0 ! (NH4)3H(SO4)2 & NH4HSO4 + DRMLCAS = 0.6900D0 ! (NH4)3H(SO4)2 & (NH4)2SO4 + DRMASAN = 0.6000D0 ! (NH4)2SO4 & NH4NO3 +!CC IF (INT(TEMP) .NE. 298) THEN ! For the time being +!CC T0 = 298.15d0 +!CC TCF = 1.0/TEMP - 1.0/T0 +!CC DRMLCAB = DRMLCAB*EXP( 507.506*TCF) +!CC DRMLCAS = DRMLCAS*EXP( 133.865*TCF) +!CC DRMASAN = DRMASAN*EXP(1269.068*TCF) +!CC ENDIF +! +! *** LIQUID PHASE ****************************************************** +! + CHNO3 = ZERO + CHCL = ZERO + CH2SO4 = ZERO + COH = ZERO + WATER = TINY +! + DO 20 I=1,NPAIR + MOLALR(I)=ZERO + GAMA(I) =0.1 + GAMIN(I) =GREAT + GAMOU(I) =GREAT + M0(I) =1d5 + 20 CONTINUE +! + DO 30 I=1,NPAIR + GAMA(I) = 0.1d0 + 30 CONTINUE +! + DO 40 I=1,NIONS + MOLAL(I)=ZERO +40 CONTINUE + COH = ZERO +! + DO 50 I=1,NGASAQ + GASAQ(I)=ZERO +50 CONTINUE +! +! *** SOLID PHASE ******************************************************* +! + CNH42S4= ZERO + CNH4HS4= ZERO + CNACL = ZERO + CNA2SO4= ZERO + CNANO3 = ZERO + CNH4NO3= ZERO + CNH4CL = ZERO + CNAHSO4= ZERO + CLC = ZERO +! +! *** GAS PHASE ********************************************************* +! + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO +! +! *** CALCULATE ZSR PARAMETERS ****************************************** +! + IRH = MIN (INT(RH*NZSR+0.5),NZSR) ! Position in ZSR arrays + IRH = MAX (IRH, 1) +! +! M0(01) = AWSC(IRH) ! NACl +! IF (M0(01) .LT. 100.0) THEN +! IC = M0(01) +! CALL KMTAB(IC,298.0, GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(01) = M0(01)*EXP(LN10*(GI0-GII)) +! ENDIF +! +! M0(02) = AWSS(IRH) ! (NA)2SO4 +! IF (M0(02) .LT. 100.0) THEN +! IC = 3.0*M0(02) +! CALL KMTAB(IC,298.0, XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(02) = M0(02)*EXP(LN10*(GI0-GII)) +! ENDIF +! +! M0(03) = AWSN(IRH) ! NANO3 +! IF (M0(03) .LT. 100.0) THEN +! IC = M0(03) +! CALL KMTAB(IC,298.0, XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(03) = M0(03)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(04) = AWAS(IRH) ! (NH4)2SO4 +! IF (M0(04) .LT. 100.0) THEN +! IC = 3.0*M0(04) +! CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(04) = M0(04)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(05) = AWAN(IRH) ! NH4NO3 +! IF (M0(05) .LT. 100.0) THEN +! IC = M0(05) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX) +! M0(05) = M0(05)*EXP(LN10*(GI0-GII)) +! ENDIF +! +! M0(06) = AWAC(IRH) ! NH4CL +! IF (M0(06) .LT. 100.0) THEN +! IC = M0(06) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX) +! M0(06) = M0(06)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(07) = AWSA(IRH) ! 2H-SO4 +! IF (M0(07) .LT. 100.0) THEN +! IC = 3.0*M0(07) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX) +! M0(07) = M0(07)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(08) = AWSA(IRH) ! H-HSO4 +!CC IF (M0(08) .LT. 100.0) THEN ! These are redundant, because M0(8) is not used +!CC IC = M0(08) +!CC CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +!CC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +!CCCCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX) +!CC M0(08) = M0(08)*EXP(LN10*(GI0-GII)) +!CC ENDIF +! + M0(09) = AWAB(IRH) ! NH4HSO4 +! IF (M0(09) .LT. 100.0) THEN +! IC = M0(09) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX) +! M0(09) = M0(09)*EXP(LN10*(GI0-GII)) +! ENDIF +! +! M0(12) = AWSB(IRH) ! NAHSO4 +! IF (M0(12) .LT. 100.0) THEN +! IC = M0(12) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GI0) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GII) +! M0(12) = M0(12)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(13) = AWLC(IRH) ! (NH4)3H(SO4)2 +! IF (M0(13) .LT. 100.0) THEN +! IC = 4.0*M0(13) +! CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +! G130 = 0.2*(3.0*GI0+2.0*GII) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +! G13I = 0.2*(3.0*GI0+2.0*GII) +! M0(13) = M0(13)*EXP(LN10*SNGL(G130-G13I)) +! ENDIF +! +! *** OTHER INITIALIZATIONS ********************************************* +! + ICLACT = 0 + CALAOU = .TRUE. + CALAIN = .TRUE. + FRST = .TRUE. + SCASE = '??' + SULRATW = 2.D0 + SODRAT = ZERO + NOFER = 0 + STKOFL =.FALSE. + DO 60 I=1,NERRMX + ERRSTK(I) =-999 + ERRMSG(I) = 'MESSAGE N/A' + 60 CONTINUE +! +! *** END OF SUBROUTINE INIT2 ******************************************* +! + END + + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISOINIT3 +! *** THIS SUBROUTINE INITIALIZES ALL GLOBAL VARIABLES FOR AMMONIUM, +! SODIUM, CHLORIDE, NITRATE, SULFATE AEROSOL SYSTEMS (SUBROUTINE +! ISRP3) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE ISOINIT3 (WI, RHI, TEMPI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DIMENSION WI(NCOMP) + REAL IC,GII,GI0,XX,LN10 + PARAMETER (LN10=2.3025851) +! +! *** SAVE INPUT VARIABLES IN COMMON BLOCK ****************************** +! + IF (IPROB.EQ.0) THEN ! FORWARD CALCULATION + DO 10 I=1,NCOMP + W(I) = MAX(WI(I), TINY) +10 CONTINUE + ELSE + DO 15 I=1,NCOMP ! REVERSE CALCULATION + WAER(I) = MAX(WI(I), TINY) + W(I) = ZERO +15 CONTINUE + ENDIF + RH = RHI + TEMP = TEMPI +! +! *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +! + XK1 = 1.015D-2 ! HSO4(aq) <==> H(aq) + SO4(aq) + XK21 = 57.639D0 ! NH3(g) <==> NH3(aq) + XK22 = 1.805D-5 ! NH3(aq) <==> NH4(aq) + OH(aq) + XK3 = 1.971D6 ! HCL(g) <==> H(aq) + CL(aq) + XK31 = 2.500e3 ! HCL(g) <==> HCL(aq) + XK4 = 2.511e6 ! HNO3(g) <==> H(aq) + NO3(aq) ! ISORR +!CC XK4 = 3.638e6 ! HNO3(g) <==> H(aq) + NO3(aq) ! SEQUIL + XK41 = 2.100e5 ! HNO3(g) <==> HNO3(aq) + XK5 = 0.4799D0 ! NA2SO4(s) <==> 2*NA(aq) + SO4(aq) + XK6 = 1.086D-16 ! NH4CL(s) <==> NH3(g) + HCL(g) + XK7 = 1.817D0 ! (NH4)2SO4(s) <==> 2*NH4(aq) + SO4(aq) + XK8 = 37.661D0 ! NACL(s) <==> NA(aq) + CL(aq) + XK10 = 5.746D-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! ISORR +!CC XK10 = 2.985e-17 ! NH4NO3(s) <==> NH3(g) + HNO3(g) ! SEQUIL + XK11 = 2.413D4 ! NAHSO4(s) <==> NA(aq) + HSO4(aq) + XK12 = 1.382D2 ! NH4HSO4(s) <==> NH4(aq) + HSO4(aq) + XK13 = 29.268D0 ! (NH4)3H(SO4)2(s) <==> 3*NH4(aq) + HSO4(aq) + SO4(aq) + XK14 = 22.05D0 ! NH4CL(s) <==> NH4(aq) + CL(aq) + XKW = 1.010D-14 ! H2O <==> H(aq) + OH(aq) + XK9 = 11.977D0 ! NANO3(s) <==> NA(aq) + NO3(aq) +! + IF (INT(TEMP) .NE. 298) THEN ! FOR T != 298K or 298.15K + T0 = 298.15D0 + T0T = T0/TEMP + COEF= 1.0+LOG(T0T)-T0T + XK1 = XK1 *EXP( 8.85*(T0T-1.0) + 25.140*COEF) + XK21= XK21*EXP( 13.79*(T0T-1.0) - 5.393*COEF) + XK22= XK22*EXP( -1.50*(T0T-1.0) + 26.920*COEF) + XK3 = XK3 *EXP( 30.20*(T0T-1.0) + 19.910*COEF) + XK31= XK31*EXP( 30.20*(T0T-1.0) + 19.910*COEF) + XK4 = XK4 *EXP( 29.17*(T0T-1.0) + 16.830*COEF) !ISORR +!CC XK4 = XK4 *EXP( 29.47*(T0T-1.0) + 16.840*COEF) ! SEQUIL + XK41= XK41*EXP( 29.17*(T0T-1.0) + 16.830*COEF) + XK5 = XK5 *EXP( 0.98*(T0T-1.0) + 39.500*COEF) + XK6 = XK6 *EXP(-71.00*(T0T-1.0) + 2.400*COEF) + XK7 = XK7 *EXP( -2.65*(T0T-1.0) + 38.570*COEF) + XK8 = XK8 *EXP( -1.56*(T0T-1.0) + 16.900*COEF) + XK9 = XK9 *EXP( -8.22*(T0T-1.0) + 16.010*COEF) + XK10= XK10*EXP(-74.38*(T0T-1.0) + 6.120*COEF) ! ISORR +!CC XK10= XK10*EXP(-75.11*(T0T-1.0) + 13.460*COEF) ! SEQUIL + XK11= XK11*EXP( 0.79*(T0T-1.0) + 14.746*COEF) + XK12= XK12*EXP( -2.87*(T0T-1.0) + 15.830*COEF) + XK13= XK13*EXP( -5.19*(T0T-1.0) + 54.400*COEF) + XK14= XK14*EXP( 24.55*(T0T-1.0) + 16.900*COEF) + XKW = XKW *EXP(-22.52*(T0T-1.0) + 26.920*COEF) + ENDIF + XK2 = XK21*XK22 + XK42 = XK4/XK41 + XK32 = XK3/XK31 +! +! *** CALCULATE DELIQUESCENCE RELATIVE HUMIDITIES (UNICOMPONENT) ******** +! + DRH2SO4 = ZERO + DRNH42S4 = 0.7997D0 + DRNH4HS4 = 0.4000D0 + DRLC = 0.6900D0 + DRNACL = 0.7528D0 + DRNANO3 = 0.7379D0 + DRNH4CL = 0.7710D0 + DRNH4NO3 = 0.6183D0 + DRNA2SO4 = 0.9300D0 + DRNAHSO4 = 0.5200D0 + IF (INT(TEMP) .NE. 298) THEN + T0 = 298.15D0 + TCF = 1.0/TEMP - 1.0/T0 + DRNACL = DRNACL *EXP( 25.*TCF) + DRNANO3 = DRNANO3 *EXP(304.*TCF) + DRNA2SO4 = DRNA2SO4*EXP( 80.*TCF) + DRNH4NO3 = DRNH4NO3*EXP(852.*TCF) + DRNH42S4 = DRNH42S4*EXP( 80.*TCF) + DRNH4HS4 = DRNH4HS4*EXP(384.*TCF) + DRLC = DRLC *EXP(186.*TCF) + DRNH4CL = DRNH4Cl *EXP(239.*TCF) + DRNAHSO4 = DRNAHSO4*EXP(-45.*TCF) +! +! *** ADJUST FOR DRH "CROSSOVER" AT LOW TEMPERATURES +! + DRNH4NO3 = MIN (DRNH4NO3, DRNH4CL, DRNH42S4, DRNANO3, DRNACL) + DRNANO3 = MIN (DRNANO3, DRNACL) + DRNH4CL = MIN (DRNH4Cl, DRNH42S4) +! + ENDIF +! +! *** CALCULATE MUTUAL DELIQUESCENCE RELATIVE HUMIDITIES **************** +! + DRMLCAB = 0.378D0 ! (NH4)3H(SO4)2 & NH4HSO4 + DRMLCAS = 0.690D0 ! (NH4)3H(SO4)2 & (NH4)2SO4 + DRMASAN = 0.600D0 ! (NH4)2SO4 & NH4NO3 + DRMG1 = 0.460D0 ! (NH4)2SO4, NH4NO3, NA2SO4, NH4CL + DRMG2 = 0.691D0 ! (NH4)2SO4, NA2SO4, NH4CL + DRMG3 = 0.697D0 ! (NH4)2SO4, NA2SO4 + DRMH1 = 0.240D0 ! NA2SO4, NANO3, NACL, NH4NO3, NH4CL + DRMH2 = 0.596D0 ! NA2SO4, NANO3, NACL, NH4CL + DRMI1 = 0.240D0 ! LC, NAHSO4, NH4HSO4, NA2SO4, (NH4)2SO4 + DRMI2 = 0.363D0 ! LC, NAHSO4, NA2SO4, (NH4)2SO4 - NO DATA - + DRMI3 = 0.610D0 ! LC, NA2SO4, (NH4)2SO4 + DRMQ1 = 0.494D0 ! (NH4)2SO4, NH4NO3, NA2SO4 + DRMR1 = 0.663D0 ! NA2SO4, NANO3, NACL + DRMR2 = 0.735D0 ! NA2SO4, NACL + DRMR3 = 0.673D0 ! NANO3, NACL + DRMR4 = 0.694D0 ! NA2SO4, NACL, NH4CL + DRMR5 = 0.731D0 ! NA2SO4, NH4CL + DRMR6 = 0.596D0 ! NA2SO4, NANO3, NH4CL + DRMR7 = 0.380D0 ! NA2SO4, NANO3, NACL, NH4NO3 + DRMR8 = 0.380D0 ! NA2SO4, NACL, NH4NO3 + DRMR9 = 0.494D0 ! NA2SO4, NH4NO3 + DRMR10 = 0.476D0 ! NA2SO4, NANO3, NH4NO3 + DRMR11 = 0.340D0 ! NA2SO4, NACL, NH4NO3, NH4CL + DRMR12 = 0.460D0 ! NA2SO4, NH4NO3, NH4CL + DRMR13 = 0.438D0 ! NA2SO4, NANO3, NH4NO3, NH4CL +!CC IF (INT(TEMP) .NE. 298) THEN +!CC T0 = 298.15d0 +!CC TCF = 1.0/TEMP - 1.0/T0 +!CC DRMLCAB = DRMLCAB*EXP( 507.506*TCF) +!CC DRMLCAS = DRMLCAS*EXP( 133.865*TCF) +!CC DRMASAN = DRMASAN*EXP(1269.068*TCF) +!CC DRMG1 = DRMG1 *EXP( 572.207*TCF) +!CC DRMG2 = DRMG2 *EXP( 58.166*TCF) +!CC DRMG3 = DRMG3 *EXP( 22.253*TCF) +!CC DRMH1 = DRMH1 *EXP(2116.542*TCF) +!CC DRMH2 = DRMH2 *EXP( 650.549*TCF) +!CC DRMI1 = DRMI1 *EXP( 565.743*TCF) +!CC DRMI2 = DRMI2 *EXP( 91.745*TCF) +!CC DRMI3 = DRMI3 *EXP( 161.272*TCF) +!CC DRMQ1 = DRMQ1 *EXP(1616.621*TCF) +!CC DRMR1 = DRMR1 *EXP( 292.564*TCF) +!CC DRMR2 = DRMR2 *EXP( 14.587*TCF) +!CC DRMR3 = DRMR3 *EXP( 307.907*TCF) +!CC DRMR4 = DRMR4 *EXP( 97.605*TCF) +!CC DRMR5 = DRMR5 *EXP( 98.523*TCF) +!CC DRMR6 = DRMR6 *EXP( 465.500*TCF) +!CC DRMR7 = DRMR7 *EXP( 324.425*TCF) +!CC DRMR8 = DRMR8 *EXP(2660.184*TCF) +!CC DRMR9 = DRMR9 *EXP(1617.178*TCF) +!CC DRMR10 = DRMR10 *EXP(1745.226*TCF) +!CC DRMR11 = DRMR11 *EXP(3691.328*TCF) +!CC DRMR12 = DRMR12 *EXP(1836.842*TCF) +!CC DRMR13 = DRMR13 *EXP(1967.938*TCF) +!CC ENDIF +! +! *** LIQUID PHASE ****************************************************** +! + CHNO3 = ZERO + CHCL = ZERO + CH2SO4 = ZERO + COH = ZERO + WATER = TINY +! + DO 20 I=1,NPAIR + MOLALR(I)=ZERO + GAMA(I) =0.1 + GAMIN(I) =GREAT + GAMOU(I) =GREAT + M0(I) =1d5 + 20 CONTINUE +! + DO 30 I=1,NPAIR + GAMA(I) = 0.1d0 + 30 CONTINUE +! + DO 40 I=1,NIONS + MOLAL(I)=ZERO +40 CONTINUE + COH = ZERO +! + DO 50 I=1,NGASAQ + GASAQ(I)=ZERO +50 CONTINUE +! +! *** SOLID PHASE ******************************************************* +! + CNH42S4= ZERO + CNH4HS4= ZERO + CNACL = ZERO + CNA2SO4= ZERO + CNANO3 = ZERO + CNH4NO3= ZERO + CNH4CL = ZERO + CNAHSO4= ZERO + CLC = ZERO +! +! *** GAS PHASE ********************************************************* +! + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO +! +! *** CALCULATE ZSR PARAMETERS ****************************************** +! + IRH = MIN (INT(RH*NZSR+0.5),NZSR) ! Position in ZSR arrays + IRH = MAX (IRH, 1) +! + M0(01) = AWSC(IRH) ! NACl +! IF (M0(01) .LT. 100.0) THEN +! IC = M0(01) +! CALL KMTAB(IC,298.0, GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(01) = M0(01)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(02) = AWSS(IRH) ! (NA)2SO4 +! IF (M0(02) .LT. 100.0) THEN +! IC = 3.0*M0(02) +! CALL KMTAB(IC,298.0, XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(02) = M0(02)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(03) = AWSN(IRH) ! NANO3 +! IF (M0(03) .LT. 100.0) THEN +! IC = M0(03) +! CALL KMTAB(IC,298.0, XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(03) = M0(03)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(04) = AWAS(IRH) ! (NH4)2SO4 +! IF (M0(04) .LT. 100.0) THEN +! IC = 3.0*M0(04) +! CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX,XX) +! M0(04) = M0(04)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(05) = AWAN(IRH) ! NH4NO3 +! IF (M0(05) .LT. 100.0) THEN +! IC = M0(05) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX,XX) +! M0(05) = M0(05)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(06) = AWAC(IRH) ! NH4CL +! IF (M0(06) .LT. 100.0) THEN +! IC = M0(06) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX,XX) +! M0(06) = M0(06)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(07) = AWSA(IRH) ! 2H-SO4 +! IF (M0(07) .LT. 100.0) THEN +! IC = 3.0*M0(07) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX,XX) +! M0(07) = M0(07)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(08) = AWSA(IRH) ! H-HSO4 +!CC IF (M0(08) .LT. 100.0) THEN ! These are redundant, because M0(8) is not used +!CC IC = M0(08) +!CC CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +!CC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX,XX) +!CCCCC CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX,XX) +!CC M0(08) = M0(08)*EXP(LN10*(GI0-GII)) +!CC ENDIF +! + M0(09) = AWAB(IRH) ! NH4HSO4 +! IF (M0(09) .LT. 100.0) THEN +! IC = M0(09) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,GI0,XX,XX,XX) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,GII,XX,XX,XX) +! M0(09) = M0(09)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(12) = AWSB(IRH) ! NAHSO4 +! IF (M0(12) .LT. 100.0) THEN +! IC = M0(12) +! CALL KMTAB(IC,298.0, XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GI0) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,XX,GII) +! M0(12) = M0(12)*EXP(LN10*(GI0-GII)) +! ENDIF +! + M0(13) = AWLC(IRH) ! (NH4)3H(SO4)2 +! IF (M0(13) .LT. 100.0) THEN +! IC = 4.0*M0(13) +! CALL KMTAB(IC,298.0, XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +! G130 = 0.2*(3.0*GI0+2.0*GII) +! CALL KMTAB(IC,SNGL(TEMP),XX,XX,XX,GI0,XX,XX,XX,XX,GII,XX,XX,XX) +! G13I = 0.2*(3.0*GI0+2.0*GII) +! M0(13) = M0(13)*EXP(LN10*SNGL(G130-G13I)) +! ENDIF +! +! *** OTHER INITIALIZATIONS ********************************************* +! + ICLACT = 0 + CALAOU = .TRUE. + CALAIN = .TRUE. + FRST = .TRUE. + SCASE = '??' + SULRATW = 2.D0 + NOFER = 0 + STKOFL =.FALSE. + DO 60 I=1,NERRMX + ERRSTK(I) =-999 + ERRMSG(I) = 'MESSAGE N/A' + 60 CONTINUE +! +! *** END OF SUBROUTINE ISOINIT3 ******************************************* +! + END + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ADJUST +! *** ADJUSTS FOR MASS BALANCE BETWEEN VOLATILE SPECIES AND SULFATE +! FIRST CALCULATE THE EXCESS OF EACH PRECURSOR, AND IF IT EXISTS, THEN +! ADJUST SEQUENTIALY AEROSOL PHASE SPECIES WHICH CONTAIN THE EXCESS +! PRECURSOR. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE ADJUST (WI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION WI(*) +! +! *** FOR AMMONIUM ***************************************************** +! + IF (IPROB.EQ.0) THEN ! Calculate excess (solution - input) + EXNH4 = GNH3 + MOLAL(3) + CNH4CL + CNH4NO3 + CNH4HS4 & + + 2D0*CNH42S4 + 3D0*CLC & + -WI(3) + ELSE + EXNH4 = MOLAL(3) + CNH4CL + CNH4NO3 + CNH4HS4 + 2D0*CNH42S4 & + + 3D0*CLC & + -WI(3) + + ENDIF + EXNH4 = MAX(EXNH4,ZERO) + IF (EXNH4.LT.TINY) GOTO 20 ! No excess NH4, go to next precursor +! + IF (MOLAL(3).GT.EXNH4) THEN ! Adjust aqueous phase NH4 + MOLAL(3) = MOLAL(3) - EXNH4 + GOTO 20 + ELSE + EXNH4 = EXNH4 - MOLAL(3) + MOLAL(3) = ZERO + ENDIF +! + IF (CNH4CL.GT.EXNH4) THEN ! Adjust NH4Cl(s) + CNH4CL = CNH4CL - EXNH4 ! more solid than excess + GHCL = GHCL + EXNH4 ! evaporate Cl to gas phase + GOTO 20 + ELSE ! less solid than excess + GHCL = GHCL + CNH4CL ! evaporate into gas phase + EXNH4 = EXNH4 - CNH4CL ! reduce excess + CNH4CL = ZERO ! zero salt concentration + ENDIF +! + IF (CNH4NO3.GT.EXNH4) THEN ! Adjust NH4NO3(s) + CNH4NO3 = CNH4NO3- EXNH4 ! more solid than excess + GHNO3 = GHNO3 + EXNH4 ! evaporate NO3 to gas phase + GOTO 20 + ELSE ! less solid than excess + GHNO3 = GHNO3 + CNH4NO3! evaporate into gas phase + EXNH4 = EXNH4 - CNH4NO3! reduce excess + CNH4NO3 = ZERO ! zero salt concentration + ENDIF +! + IF (CLC.GT.3d0*EXNH4) THEN ! Adjust (NH4)3H(SO4)2(s) + CLC = CLC - EXNH4/3d0 ! more solid than excess + GOTO 20 + ELSE ! less solid than excess + EXNH4 = EXNH4 - 3d0*CLC ! reduce excess + CLC = ZERO ! zero salt concentration + ENDIF +! + IF (CNH4HS4.GT.EXNH4) THEN ! Adjust NH4HSO4(s) + CNH4HS4 = CNH4HS4- EXNH4 ! more solid than excess + GOTO 20 + ELSE ! less solid than excess + EXNH4 = EXNH4 - CNH4HS4! reduce excess + CNH4HS4 = ZERO ! zero salt concentration + ENDIF +! + IF (CNH42S4.GT.EXNH4) THEN ! Adjust (NH4)2SO4(s) + CNH42S4 = CNH42S4- EXNH4 ! more solid than excess + GOTO 20 + ELSE ! less solid than excess + EXNH4 = EXNH4 - CNH42S4! reduce excess + CNH42S4 = ZERO ! zero salt concentration + ENDIF +! +! *** FOR NITRATE ****************************************************** +! + 20 IF (IPROB.EQ.0) THEN ! Calculate excess (solution - input) + EXNO3 = GHNO3 + MOLAL(7) + CNH4NO3 & + -WI(4) + ELSE + EXNO3 = MOLAL(7) + CNH4NO3 & + -WI(4) + ENDIF + EXNO3 = MAX(EXNO3,ZERO) + IF (EXNO3.LT.TINY) GOTO 30 ! No excess NO3, go to next precursor +! + IF (MOLAL(7).GT.EXNO3) THEN ! Adjust aqueous phase NO3 + MOLAL(7) = MOLAL(7) - EXNO3 + GOTO 30 + ELSE + EXNO3 = EXNO3 - MOLAL(7) + MOLAL(7) = ZERO + ENDIF +! + IF (CNH4NO3.GT.EXNO3) THEN ! Adjust NH4NO3(s) + CNH4NO3 = CNH4NO3- EXNO3 ! more solid than excess + GNH3 = GNH3 + EXNO3 ! evaporate NO3 to gas phase + GOTO 30 + ELSE ! less solid than excess + GNH3 = GNH3 + CNH4NO3! evaporate into gas phase + EXNO3 = EXNO3 - CNH4NO3! reduce excess + CNH4NO3 = ZERO ! zero salt concentration + ENDIF +! +! *** FOR CHLORIDE ***************************************************** +! + 30 IF (IPROB.EQ.0) THEN ! Calculate excess (solution - input) + EXCl = GHCL + MOLAL(4) + CNH4CL & + -WI(5) + ELSE + EXCl = MOLAL(4) + CNH4CL & + -WI(5) + ENDIF + EXCl = MAX(EXCl,ZERO) + IF (EXCl.LT.TINY) GOTO 40 ! No excess Cl, go to next precursor +! + IF (MOLAL(4).GT.EXCL) THEN ! Adjust aqueous phase Cl + MOLAL(4) = MOLAL(4) - EXCL + GOTO 40 + ELSE + EXCL = EXCL - MOLAL(4) + MOLAL(4) = ZERO + ENDIF +! + IF (CNH4CL.GT.EXCL) THEN ! Adjust NH4Cl(s) + CNH4CL = CNH4CL - EXCL ! more solid than excess + GHCL = GHCL + EXCL ! evaporate Cl to gas phase + GOTO 40 + ELSE ! less solid than excess + GHCL = GHCL + CNH4CL ! evaporate into gas phase + EXCL = EXCL - CNH4CL ! reduce excess + CNH4CL = ZERO ! zero salt concentration + ENDIF +! +! *** FOR SULFATE ****************************************************** +! + 40 EXS4 = MOLAL(5) + MOLAL(6) + 2.d0*CLC + CNH42S4 + CNH4HS4 + & + CNA2SO4 + CNAHSO4 - WI(2) + EXS4 = MAX(EXS4,ZERO) ! Calculate excess (solution - input) + IF (EXS4.LT.TINY) GOTO 50 ! No excess SO4, return +! + IF (MOLAL(6).GT.EXS4) THEN ! Adjust aqueous phase HSO4 + MOLAL(6) = MOLAL(6) - EXS4 + GOTO 50 + ELSE + EXS4 = EXS4 - MOLAL(6) + MOLAL(6) = ZERO + ENDIF +! + IF (MOLAL(5).GT.EXS4) THEN ! Adjust aqueous phase SO4 + MOLAL(5) = MOLAL(5) - EXS4 + GOTO 50 + ELSE + EXS4 = EXS4 - MOLAL(5) + MOLAL(5) = ZERO + ENDIF +! + IF (CLC.GT.2d0*EXS4) THEN ! Adjust (NH4)3H(SO4)2(s) + CLC = CLC - EXS4/2d0 ! more solid than excess + GNH3 = GNH3 +1.5d0*EXS4! evaporate NH3 to gas phase + GOTO 50 + ELSE ! less solid than excess + GNH3 = GNH3 + 1.5d0*CLC! evaporate NH3 to gas phase + EXS4 = EXS4 - 2d0*CLC ! reduce excess + CLC = ZERO ! zero salt concentration + ENDIF +! + IF (CNH4HS4.GT.EXS4) THEN ! Adjust NH4HSO4(s) + CNH4HS4 = CNH4HS4 - EXS4 ! more solid than excess + GNH3 = GNH3 + EXS4 ! evaporate NH3 to gas phase + GOTO 50 + ELSE ! less solid than excess + GNH3 = GNH3 + CNH4HS4 ! evaporate NH3 to gas phase + EXS4 = EXS4 - CNH4HS4 ! reduce excess + CNH4HS4 = ZERO ! zero salt concentration + ENDIF +! + IF (CNH42S4.GT.EXS4) THEN ! Adjust (NH4)2SO4(s) + CNH42S4 = CNH42S4- EXS4 ! more solid than excess + GNH3 = GNH3 + 2.d0*EXS4! evaporate NH3 to gas phase + GOTO 50 + ELSE ! less solid than excess + GNH3 = GNH3+2.d0*CNH42S4 ! evaporate NH3 to gas phase + EXS4 = EXS4 - CNH42S4 ! reduce excess + CNH42S4 = ZERO ! zero salt concentration + ENDIF +! +! *** RETURN ********************************************************** +! + 50 RETURN + END + +!======================================================================= +! +! *** ISORROPIA CODE +! *** FUNCTION GETASR +! *** CALCULATES THE LIMITING NH4+/SO4 RATIO OF A SULFATE POOR SYSTEM +! (i.e. SULFATE RATIO = 2.0) FOR GIVEN SO4 LEVEL AND RH +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION GETASR (SO4I, RHI) + USE ASRC + PARAMETER (NSO4S=14, NRHS=20, NASRD=NSO4S*NRHS) +! COMMON /ASRC/ ASRAT(NASRD), ASSO4(NSO4S) + DOUBLE PRECISION SO4I, RHI +!CC +!CC *** SOLVE USING FULL COMPUTATIONS, NOT LOOK-UP TABLES ************** +!CC +!CC W(2) = WAER(2) +!CC W(3) = WAER(2)*2.0001D0 +!CC CALL CALCA2 +!CC SULRATW = MOLAL(3)/WAER(2) +!CC CALL INIT1 (WI, RHI, TEMPI) ! Re-initialize COMMON BLOCK +! +! *** CALCULATE INDICES ************************************************ +! + RAT = SO4I/1.E-9 + A1 = INT(ALOG10(RAT)) ! Magnitude of RAT + IA1 = INT(RAT/2.5/10.0**A1) +! + INDS = 4.0*A1 + MIN(IA1,4) + INDS = MIN(MAX(0, INDS), NSO4S-1) + 1 ! SO4 component of IPOS +! + INDR = INT(99.0-RHI*100.0) + 1 + INDR = MIN(MAX(1, INDR), NRHS) ! RH component of IPOS +! +! *** GET VALUE AND RETURN ********************************************* +! + INDSL = INDS + INDSH = MIN(INDSL+1, NSO4S) + IPOSL = (INDSL-1)*NRHS + INDR ! Low position in array + IPOSH = (INDSH-1)*NRHS + INDR ! High position in array +! + WF = (SO4I-ASSO4(INDSL))/(ASSO4(INDSH)-ASSO4(INDSL) + 1e-7) + WF = MIN(MAX(WF, 0.0), 1.0) +! + GETASR = WF*ASRAT(IPOSH) + (1.0-WF)*ASRAT(IPOSL) +! +! *** END OF FUNCTION GETASR ******************************************* +! + RETURN + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** BLOCK DATA AERSR +! *** CONTAINS DATA FOR AEROSOL SULFATE RATIO ARRAY NEEDED IN FUNCTION +! GETASR +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + BLOCK DATA AERSR + USE ASRC + PARAMETER (NSO4S=14, NRHS=20, NASRD=NSO4S*NRHS) +! COMMON /ASRC/ ASRAT(NASRD), ASSO4(NSO4S) +! +! DATA ASSO4/1.0E-9, 2.5E-9, 5.0E-9, 7.5E-9, 1.0E-8, & +! 2.5E-8, 5.0E-8, 7.5E-8, 1.0E-7, 2.5E-7, & +! 5.0E-7, 7.5E-7, 1.0E-6, 5.0E-6/ +! +! DATA (ASRAT(I), I=1,100)/ & +! 1.020464, 0.9998130, 0.9960167, 0.9984423, 1.004004, & +! 1.010885, 1.018356, 1.026726, 1.034268, 1.043846, & +! 1.052933, 1.062230, 1.062213, 1.080050, 1.088350, & +! 1.096603, 1.104289, 1.111745, 1.094662, 1.121594, & +! 1.268909, 1.242444, 1.233815, 1.232088, 1.234020, & +! 1.238068, 1.243455, 1.250636, 1.258734, 1.267543, & +! 1.276948, 1.286642, 1.293337, 1.305592, 1.314726, & +! 1.323463, 1.333258, 1.343604, 1.344793, 1.355571, & +! 1.431463, 1.405204, 1.395791, 1.393190, 1.394403, & +! 1.398107, 1.403811, 1.411744, 1.420560, 1.429990, & +! 1.439742, 1.449507, 1.458986, 1.468403, 1.477394, & +! 1.487373, 1.495385, 1.503854, 1.512281, 1.520394, & +! 1.514464, 1.489699, 1.480686, 1.478187, 1.479446, & +! 1.483310, 1.489316, 1.497517, 1.506501, 1.515816, & +! 1.524724, 1.533950, 1.542758, 1.551730, 1.559587, & +! 1.568343, 1.575610, 1.583140, 1.590440, 1.596481, & +! 1.567743, 1.544426, 1.535928, 1.533645, 1.535016, & +! 1.539003, 1.545124, 1.553283, 1.561886, 1.570530, & +! 1.579234, 1.587813, 1.595956, 1.603901, 1.611349, & +! 1.618833, 1.625819, 1.632543, 1.639032, 1.645276/ + +! DATA (ASRAT(I), I=101,200)/ & +! 1.707390, 1.689553, 1.683198, 1.681810, 1.683490, & +! 1.687477, 1.693148, 1.700084, 1.706917, 1.713507, & +! 1.719952, 1.726190, 1.731985, 1.737544, 1.742673, & +! 1.747756, 1.752431, 1.756890, 1.761141, 1.765190, & +! 1.785657, 1.771851, 1.767063, 1.766229, 1.767901, & +! 1.771455, 1.776223, 1.781769, 1.787065, 1.792081, & +! 1.796922, 1.801561, 1.805832, 1.809896, 1.813622, & +! 1.817292, 1.820651, 1.823841, 1.826871, 1.829745, & +! 1.822215, 1.810497, 1.806496, 1.805898, 1.807480, & +! 1.810684, 1.814860, 1.819613, 1.824093, 1.828306, & +! 1.832352, 1.836209, 1.839748, 1.843105, 1.846175, & +! 1.849192, 1.851948, 1.854574, 1.857038, 1.859387, & +! 1.844588, 1.834208, 1.830701, 1.830233, 1.831727, & +! 1.834665, 1.838429, 1.842658, 1.846615, 1.850321, & +! 1.853869, 1.857243, 1.860332, 1.863257, 1.865928, & +! 1.868550, 1.870942, 1.873208, 1.875355, 1.877389, & +! 1.899556, 1.892637, 1.890367, 1.890165, 1.891317, & +! 1.893436, 1.896036, 1.898872, 1.901485, 1.903908, & +! 1.906212, 1.908391, 1.910375, 1.912248, 1.913952, & +! 1.915621, 1.917140, 1.918576, 1.919934, 1.921220/ + +! DATA (ASRAT(I), I=201,280)/ & +! 1.928264, 1.923245, 1.921625, 1.921523, 1.922421, & +! 1.924016, 1.925931, 1.927991, 1.929875, 1.931614, & +! 1.933262, 1.934816, 1.936229, 1.937560, 1.938769, & +! 1.939951, 1.941026, 1.942042, 1.943003, 1.943911, & +! 1.941205, 1.937060, 1.935734, 1.935666, 1.936430, & +! 1.937769, 1.939359, 1.941061, 1.942612, 1.944041, & +! 1.945393, 1.946666, 1.947823, 1.948911, 1.949900, & +! 1.950866, 1.951744, 1.952574, 1.953358, 1.954099, & +! 1.948985, 1.945372, 1.944221, 1.944171, 1.944850, & +! 1.946027, 1.947419, 1.948902, 1.950251, 1.951494, & +! 1.952668, 1.953773, 1.954776, 1.955719, 1.956576, & +! 1.957413, 1.958174, 1.958892, 1.959571, 1.960213, & +! 1.977193, 1.975540, 1.975023, 1.975015, 1.975346, & +! 1.975903, 1.976547, 1.977225, 1.977838, 1.978401, & +! 1.978930, 1.979428, 1.979879, 1.980302, 1.980686, & +! 1.981060, 1.981401, 1.981722, 1.982025, 1.982312/ +!! +! *** END OF BLOCK DATA AERSR ****************************************** +! + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCHA +! *** CALCULATES CHLORIDES SPECIATION +! +! HYDROCHLORIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, +! AND DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE +! HYDROCHLORIC ACID DISSOLVED IS CALCULATED FROM THE +! HCL(G) <-> (H+) + (CL-) +! EQUILIBRIUM, USING THE (H+) FROM THE SULFATES. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCHA + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION KAPA +!C CHARACTER ERRINF*40 +! +! *** CALCULATE HCL DISSOLUTION ***************************************** +! + X = W(5) + DELT = 0.0d0 + IF (WATER.GT.TINY) THEN + KAPA = MOLAL(1) + ALFA = XK3*R*TEMP*(WATER/GAMA(11))**2.0 + DIAK = SQRT( (KAPA+ALFA)**2.0 + 4.0*ALFA*X) + DELT = 0.5*(-(KAPA+ALFA) + DIAK) +!C IF (DELT/KAPA.GT.0.1d0) THEN +!C WRITE (ERRINF,'(1PE10.3)') DELT/KAPA*100.0 +!C CALL PUSHERR (0033, ERRINF) +!C ENDIF + ENDIF +! +! *** CALCULATE HCL SPECIATION IN THE GAS PHASE ************************* +! + GHCL = MAX(X-DELT, 0.0d0) ! GAS HCL +! +! *** CALCULATE HCL SPECIATION IN THE LIQUID PHASE ********************** +! + MOLAL(4) = DELT ! CL- + MOLAL(1) = MOLAL(1) + DELT ! H+ +! + RETURN +! +! *** END OF SUBROUTINE CALCHA ****************************************** +! + END + + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCHAP +! *** CALCULATES CHLORIDES SPECIATION +! +! HYDROCHLORIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, +! THAT DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. +! THE HYDROCHLORIC ACID DISSOLVED IS CALCULATED FROM THE +! HCL(G) -> HCL(AQ) AND HCL(AQ) -> (H+) + (CL-) +! EQUILIBRIA, USING (H+) FROM THE SULFATES. +! +! THIS IS THE VERSION USED BY THE INVERSE PROBLEM SOVER +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCHAP + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** IS THERE A LIQUID PHASE? ****************************************** +! + IF (WATER.LE.TINY) RETURN +! +! *** CALCULATE HCL SPECIATION IN THE GAS PHASE ************************* +! + CALL CALCCLAQ (MOLAL(4), MOLAL(1), DELT) + ALFA = XK3*R*TEMP*(WATER/GAMA(11))**2.0 + GASAQ(3) = DELT + MOLAL(1) = MOLAL(1) - DELT + MOLAL(4) = MOLAL(4) - DELT + GHCL = MOLAL(1)*MOLAL(4)/ALFA +! + RETURN +! +! *** END OF SUBROUTINE CALCHAP ***************************************** +! + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCNA +! *** CALCULATES NITRATES SPECIATION +! +! NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT +! DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC +! ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> (H+) + (NO3-) +! EQUILIBRIUM, USING THE (H+) FROM THE SULFATES. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCNA + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION KAPA +!C CHARACTER ERRINF*40 +! +! *** CALCULATE HNO3 DISSOLUTION **************************************** +! + X = W(4) + DELT = 0.0d0 + IF (WATER.GT.TINY) THEN + KAPA = MOLAL(1) + ALFA = XK4*R*TEMP*(WATER/GAMA(10))**2.0 + DIAK = SQRT( (KAPA+ALFA)**2.0 + 4.0*ALFA*X) + DELT = 0.5*(-(KAPA+ALFA) + DIAK) +!C IF (DELT/KAPA.GT.0.1d0) THEN +!C WRITE (ERRINF,'(1PE10.3)') DELT/KAPA*100.0 +!C CALL PUSHERR (0019, ERRINF) ! WARNING ERROR: NO SOLUTION +!C ENDIF + ENDIF +! +! *** CALCULATE HNO3 SPECIATION IN THE GAS PHASE ************************ +! + GHNO3 = MAX(X-DELT, 0.0d0) ! GAS HNO3 +! +! *** CALCULATE HNO3 SPECIATION IN THE LIQUID PHASE ********************* +! + MOLAL(7) = DELT ! NO3- + MOLAL(1) = MOLAL(1) + DELT ! H+ +! + RETURN +! +! *** END OF SUBROUTINE CALCNA ****************************************** +! + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCNAP +! *** CALCULATES NITRATES SPECIATION +! +! NITRIC ACID IN THE LIQUID PHASE IS ASSUMED A MINOR SPECIES, THAT +! DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. THE NITRIC +! ACID DISSOLVED IS CALCULATED FROM THE HNO3(G) -> HNO3(AQ) AND +! HNO3(AQ) -> (H+) + (CL-) EQUILIBRIA, USING (H+) FROM THE SULFATES. +! +! THIS IS THE VERSION USED BY THE INVERSE PROBLEM SOVER +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCNAP + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** IS THERE A LIQUID PHASE? ****************************************** +! + IF (WATER.LE.TINY) RETURN +! +! *** CALCULATE HNO3 SPECIATION IN THE GAS PHASE ************************ +! + CALL CALCNIAQ (MOLAL(7), MOLAL(1), DELT) + ALFA = XK4*R*TEMP*(WATER/GAMA(10))**2.0 + GASAQ(3) = DELT + MOLAL(1) = MOLAL(1) - DELT + MOLAL(7) = MOLAL(7) - DELT + GHNO3 = MOLAL(1)*MOLAL(7)/ALFA + +! write (*,*) ALFA, MOLAL(1), MOLAL(7), GHNO3, DELT +! + RETURN +! +! *** END OF SUBROUTINE CALCNAP ***************************************** +! + END + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCNH3 +! *** CALCULATES AMMONIA IN GAS PHASE +! +! AMMONIA IN THE GAS PHASE IS ASSUMED A MINOR SPECIES, THAT +! DOES NOT SIGNIFICANTLY PERTURB THE AEROSOL EQUILIBRIUM. +! AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l) +! EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION. +! +! THIS IS THE VERSION USED BY THE DIRECT PROBLEM +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCNH3 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** IS THERE A LIQUID PHASE? ****************************************** +! + IF (WATER.LE.TINY) RETURN +! +! *** CALCULATE NH3 SUBLIMATION ***************************************** +! + A1 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + CHI1 = MOLAL(3) + CHI2 = MOLAL(1) +! + BB =(CHI2 + ONE/A1) ! a=1; b!=1; c!=1 + CC =-CHI1/A1 + DIAK = SQRT(BB*BB - 4.D0*CC) ! Always > 0 + PSI = 0.5*(-BB + DIAK) ! One positive root + PSI = MAX(TINY, MIN(PSI,CHI1))! Constrict in acceptible range +! +! *** CALCULATE NH3 SPECIATION IN THE GAS PHASE ************************* +! + GNH3 = PSI ! GAS HNO3 +! +! *** CALCULATE NH3 AFFECT IN THE LIQUID PHASE ************************** +! + MOLAL(3) = CHI1 - PSI ! NH4+ + MOLAL(1) = CHI2 + PSI ! H+ +! + RETURN +! +! *** END OF SUBROUTINE CALCNH3 ***************************************** +! + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCNH3P +! *** CALCULATES AMMONIA IN GAS PHASE +! +! AMMONIA GAS IS CALCULATED FROM THE NH3(g) + (H+)(l) <==> (NH4+)(l) +! EQUILIBRIUM, USING (H+), (NH4+) FROM THE AEROSOL SOLUTION. +! +! THIS IS THE VERSION USED BY THE INVERSE PROBLEM SOLVER +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCNH3P + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** IS THERE A LIQUID PHASE? ****************************************** +! + IF (WATER.LE.TINY) RETURN +! +! *** CALCULATE NH3 GAS PHASE CONCENTRATION ***************************** +! + A1 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + GNH3 = MOLAL(3)/MOLAL(1)/A1 +! + RETURN +! +! *** END OF SUBROUTINE CALCNH3P **************************************** +! + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCNHA +! +! THIS SUBROUTINE CALCULATES THE DISSOLUTION OF HCL, HNO3 AT +! THE PRESENCE OF (H,SO4). HCL, HNO3 ARE CONSIDERED MINOR SPECIES, +! THAT DO NOT SIGNIFICANTLY AFFECT THE EQUILIBRIUM POINT. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCNHA + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION M1, M2, M3 + CHARACTER ERRINF*40 +! +! *** SPECIAL CASE; WATER=ZERO ****************************************** +! + IF (WATER.LE.TINY) THEN + GOTO 55 +! +! *** SPECIAL CASE; HCL=HNO3=ZERO *************************************** +! + ELSEIF (W(5).LE.TINY .AND. W(4).LE.TINY) THEN + GOTO 60 +! +! *** SPECIAL CASE; HCL=ZERO ******************************************** +! + ELSE IF (W(5).LE.TINY) THEN + CALL CALCNA ! CALL HNO3 DISSOLUTION ROUTINE + GOTO 60 +! +! *** SPECIAL CASE; HNO3=ZERO ******************************************* +! + ELSE IF (W(4).LE.TINY) THEN + CALL CALCHA ! CALL HCL DISSOLUTION ROUTINE + GOTO 60 + ENDIF +! +! *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +! + A3 = XK4*R*TEMP*(WATER/GAMA(10))**2.0 ! HNO3 + A4 = XK3*R*TEMP*(WATER/GAMA(11))**2.0 ! HCL +! +! *** CALCULATE CUBIC EQUATION COEFFICIENTS ***************************** +! + DELCL = ZERO + DELNO = ZERO +! + OMEGA = MOLAL(1) ! H+ + CHI3 = W(4) ! HNO3 + CHI4 = W(5) ! HCL +! + C1 = A3*CHI3 + C2 = A4*CHI4 + C3 = A3 - A4 +! + M1 = (C1 + C2 + (OMEGA+A4)*C3)/C3 + M2 = ((OMEGA+A4)*C2 - A4*C3*CHI4)/C3 + M3 =-A4*C2*CHI4/C3 +! +! *** CALCULATE ROOTS *************************************************** +! + CALL POLY3 (M1, M2, M3, DELCL, ISLV) ! HCL DISSOLUTION + IF (ISLV.NE.0) THEN + DELCL = TINY ! TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT + WRITE (ERRINF,'(1PE7.1)') TINY + CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION + ENDIF + DELCL = MIN(DELCL, CHI4) +! + DELNO = C1*DELCL/(C2 + C3*DELCL) + DELNO = MIN(DELNO, CHI3) +! + IF (DELCL.LT.ZERO .OR. DELNO.LT.ZERO .OR. & + DELCL.GT.CHI4 .OR. DELNO.GT.CHI3 ) THEN + DELCL = TINY ! TINY AMOUNTS OF HCL ASSUMED WHEN NO ROOT + DELNO = TINY + WRITE (ERRINF,'(1PE7.1)') TINY + CALL PUSHERR (0022, ERRINF) ! WARNING ERROR: NO SOLUTION + ENDIF +!CC +!CC *** COMPARE DELTA TO TOTAL H+ ; ESTIMATE EFFECT TO HSO4 *************** +!CC +!C IF ((DELCL+DELNO)/MOLAL(1).GT.0.1d0) THEN +!C WRITE (ERRINF,'(1PE10.3)') (DELCL+DELNO)/MOLAL(1)*100.0 +!C CALL PUSHERR (0021, ERRINF) +!C ENDIF +! +! *** EFFECT ON LIQUID PHASE ******************************************** +! +50 MOLAL(1) = MOLAL(1) + (DELNO+DELCL) ! H+ CHANGE + MOLAL(4) = MOLAL(4) + DELCL ! CL- CHANGE + MOLAL(7) = MOLAL(7) + DELNO ! NO3- CHANGE +! +! *** EFFECT ON GAS PHASE *********************************************** +! +55 GHCL = MAX(W(5) - MOLAL(4), TINY) + GHNO3 = MAX(W(4) - MOLAL(7), TINY) +! +60 RETURN +! +! *** END OF SUBROUTINE CALCNHA ***************************************** +! + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCNHP +! +! THIS SUBROUTINE CALCULATES THE GAS PHASE NITRIC AND HYDROCHLORIC +! ACID. CONCENTRATIONS ARE CALCULATED FROM THE DISSOLUTION +! EQUILIBRIA, USING (H+), (Cl-), (NO3-) IN THE AEROSOL PHASE. +! +! THIS IS THE VERSION USED BY THE INVERSE PROBLEM SOLVER +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCNHP + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** IS THERE A LIQUID PHASE? ****************************************** +! + IF (WATER.LE.TINY) RETURN +! +! *** CALCULATE EQUILIBRIUM CONSTANTS *********************************** +! + A3 = XK3*R*TEMP*(WATER/GAMA(11))**2.0 + A4 = XK4*R*TEMP*(WATER/GAMA(10))**2.0 + MOLAL(1) = MOLAL(1) + WAER(4) + WAER(5) ! H+ increases because NO3, Cl are added. +! +! *** CALCULATE CONCENTRATIONS ****************************************** +! *** ASSUME THAT 'DELT' FROM HNO3 >> 'DELT' FROM HCL +! + CALL CALCNIAQ (WAER(4), MOLAL(1)+MOLAL(7)+MOLAL(4), DELT) + MOLAL(1) = MOLAL(1) - DELT + MOLAL(7) = WAER(4) - DELT ! NO3- = Waer(4) minus any turned into (HNO3aq) + GASAQ(3) = DELT +! + CALL CALCCLAQ (WAER(5), MOLAL(1)+MOLAL(7)+MOLAL(4), DELT) + MOLAL(1) = MOLAL(1) - DELT + MOLAL(4) = WAER(5) - DELT ! Cl- = Waer(4) minus any turned into (HNO3aq) + GASAQ(2) = DELT +! + GHNO3 = MOLAL(1)*MOLAL(7)/A4 + GHCL = MOLAL(1)*MOLAL(4)/A3 +! + RETURN +! +! *** END OF SUBROUTINE CALCNHP ***************************************** +! + END + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCAMAQ +! *** THIS SUBROUTINE CALCULATES THE NH3(aq) GENERATED FROM (H,NH4+). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCAMAQ (NH4I, OHI, DELT) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION NH4I +!C CHARACTER ERRINF*40 +! +! *** EQUILIBRIUM CONSTANTS +! + A22 = XK22/XKW/WATER*(GAMA(8)/GAMA(9))**2. ! GAMA(NH3) ASSUMED 1 + AKW = XKW *RH*WATER*WATER +! +! *** FIND ROOT +! + OM1 = NH4I + OM2 = OHI + BB =-(OM1+OM2+A22*AKW) + CC = OM1*OM2 + DD = SQRT(BB*BB-4.D0*CC) + + DEL1 = 0.5D0*(-BB - DD) + DEL2 = 0.5D0*(-BB + DD) +! +! *** GET APPROPRIATE ROOT. +! + IF (DEL1.LT.ZERO) THEN + IF (DEL2.GT.NH4I .OR. DEL2.GT.OHI) THEN + DELT = ZERO + ELSE + DELT = DEL2 + ENDIF + ELSE + DELT = DEL1 + ENDIF +!C +!C *** COMPARE DELTA TO TOTAL NH4+ ; ESTIMATE EFFECT ********************* +!C +!C IF (DELTA/HYD.GT.0.1d0) THEN +!C WRITE (ERRINF,'(1PE10.3)') DELTA/HYD*100.0 +!C CALL PUSHERR (0020, ERRINF) +!C ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCAMAQ **************************************** +! + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCAMAQ2 +! +! THIS SUBROUTINE CALCULATES THE NH3(aq) GENERATED FROM (H,NH4+). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCAMAQ2 (GGNH3, NH4I, OHI, NH3AQ) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION NH4I, NH3AQ +! +! *** EQUILIBRIUM CONSTANTS +! + A22 = XK22/XKW/WATER*(GAMA(8)/GAMA(9))**2. ! GAMA(NH3) ASSUMED 1 + AKW = XKW *RH*WATER*WATER +! +! *** FIND ROOT +! + ALF1 = NH4I - GGNH3 + ALF2 = GGNH3 + BB = ALF1 + A22*AKW + CC =-A22*AKW*ALF2 + DEL = 0.5D0*(-BB + SQRT(BB*BB-4.D0*CC)) +! +! *** ADJUST CONCENTRATIONS +! + NH4I = ALF1 + DEL + OHI = DEL + IF (OHI.LE.TINY) OHI = SQRT(AKW) ! If solution is neutral. + NH3AQ = ALF2 - DEL +! + RETURN +! +! *** END OF SUBROUTINE CALCAMAQ2 **************************************** +! + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCCLAQ +! +! THIS SUBROUTINE CALCULATES THE HCL(aq) GENERATED FROM (H+,CL-). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCCLAQ (CLI, HI, DELT) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION CLI +! +! *** EQUILIBRIUM CONSTANTS +! + A32 = XK32*WATER/(GAMA(11))**2. ! GAMA(HCL) ASSUMED 1 +! +! *** FIND ROOT +! + OM1 = CLI + OM2 = HI + BB =-(OM1+OM2+A32) + CC = OM1*OM2 + DD = SQRT(BB*BB-4.D0*CC) + + DEL1 = 0.5D0*(-BB - DD) + DEL2 = 0.5D0*(-BB + DD) +! +! *** GET APPROPRIATE ROOT. +! + IF (DEL1.LT.ZERO) THEN + IF (DEL2.LT.ZERO .OR. DEL2.GT.CLI .OR. DEL2.GT.HI) THEN + DELT = ZERO + ELSE + DELT = DEL2 + ENDIF + ELSE + DELT = DEL1 + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCCLAQ **************************************** +! + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCCLAQ2 +! +! THIS SUBROUTINE CALCULATES THE HCL(aq) GENERATED FROM (H+,CL-). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCCLAQ2 (GGCL, CLI, HI, CLAQ) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION CLI +! +! *** EQUILIBRIUM CONSTANTS +! + A32 = XK32*WATER/(GAMA(11))**2. ! GAMA(HCL) ASSUMED 1 + AKW = XKW *RH*WATER*WATER +! +! *** FIND ROOT +! + ALF1 = CLI - GGCL + ALF2 = GGCL + COEF = (ALF1+A32) + DEL1 = 0.5*(-COEF + SQRT(COEF*COEF+4.D0*A32*ALF2)) +! +! *** CORRECT CONCENTRATIONS +! + CLI = ALF1 + DEL1 + HI = DEL1 + IF (HI.LE.TINY) HI = SQRT(AKW) ! If solution is neutral. + CLAQ = ALF2 - DEL1 +! + RETURN +! +! *** END OF SUBROUTINE CALCCLAQ2 **************************************** +! + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCNIAQ +! +! THIS SUBROUTINE CALCULATES THE HNO3(aq) GENERATED FROM (H,NO3-). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCNIAQ (NO3I, HI, DELT) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION NO3I, HI, DELT +! +! *** EQUILIBRIUM CONSTANTS +! + A42 = XK42*WATER/(GAMA(10))**2. ! GAMA(HNO3) ASSUMED 1 +! +! *** FIND ROOT +! + OM1 = NO3I + OM2 = HI + BB =-(OM1+OM2+A42) + CC = OM1*OM2 + DD = SQRT(BB*BB-4.D0*CC) + + DEL1 = 0.5D0*(-BB - DD) + DEL2 = 0.5D0*(-BB + DD) +! +! *** GET APPROPRIATE ROOT. +! + IF (DEL1.LT.ZERO .OR. DEL1.GT.HI .OR. DEL1.GT.NO3I) THEN + print *, DELT + DELT = ZERO + ELSE + DELT = DEL1 + RETURN + ENDIF +! + IF (DEL2.LT.ZERO .OR. DEL2.GT.NO3I .OR. DEL2.GT.HI) THEN + DELT = ZERO + ELSE + DELT = DEL2 + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCNIAQ **************************************** +! + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCNIAQ2 +! +! THIS SUBROUTINE CALCULATES THE UNDISSOCIATED HNO3(aq) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION NO3I, NO3AQ +! +! *** EQUILIBRIUM CONSTANTS +! + A42 = XK42*WATER/(GAMA(10))**2. ! GAMA(HNO3) ASSUMED 1 + AKW = XKW *RH*WATER*WATER +! +! *** FIND ROOT +! + ALF1 = NO3I - GGNO3 + ALF2 = GGNO3 + ALF3 = HI +! + BB = ALF3 + ALF1 + A42 + CC = ALF3*ALF1 - A42*ALF2 + DEL1 = 0.5*(-BB + SQRT(BB*BB-4.D0*CC)) +! +! *** CORRECT CONCENTRATIONS +! + NO3I = ALF1 + DEL1 + HI = ALF3 + DEL1 + IF (HI.LE.TINY) HI = SQRT(AKW) ! If solution is neutral. + NO3AQ = ALF2 - DEL1 +! + RETURN +! +! *** END OF SUBROUTINE CALCNIAQ2 **************************************** +! + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCMR +! *** THIS SUBROUTINE CALCULATES: +! 1. ION PAIR CONCENTRATIONS (FROM [MOLAR] ARRAY) +! 2. WATER CONTENT OF LIQUID AEROSOL PHASE (FROM ZSR CORRELATION) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCMR + USE SOLUT + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 + CHARACTER SC*1 +! +! *** CALCULATE ION PAIR CONCENTRATIONS ACCORDING TO SPECIFIC CASE **** +! + SC =SCASE(1:1) ! SULRAT & SODRAT case +! +! *** NH4-SO4 SYSTEM ; SULFATE POOR CASE +! + IF (SC.EQ.'A') THEN + MOLALR(4) = MOLAL(5)+MOLAL(6) ! (NH4)2SO4 - CORRECT FOR SO4 TO HSO4 +! +! *** NH4-SO4 SYSTEM ; SULFATE RICH CASE ; NO FREE ACID +! + ELSE IF (SC.EQ.'B') THEN + SO4I = MOLAL(5)-MOLAL(1) ! CORRECT FOR HSO4 DISSOCIATION + HSO4I = MOLAL(6)+MOLAL(1) + IF (SO4I.LT.HSO4I) THEN + MOLALR(13) = SO4I ! [LC] = [SO4] + MOLALR(9) = MAX(HSO4I-SO4I, ZERO) ! NH4HSO4 + ELSE + MOLALR(13) = HSO4I ! [LC] = [HSO4] + MOLALR(4) = MAX(SO4I-HSO4I, ZERO) ! (NH4)2SO4 + ENDIF +! +! *** NH4-SO4 SYSTEM ; SULFATE RICH CASE ; FREE ACID +! + ELSE IF (SC.EQ.'C') THEN + MOLALR(9) = MOLAL(3) ! NH4HSO4 + MOLALR(7) = MAX(W(2)-W(3), ZERO) ! H2SO4 +! +! *** NH4-SO4-NO3 SYSTEM ; SULFATE POOR CASE +! + ELSE IF (SC.EQ.'D') THEN + MOLALR(4) = MOLAL(5) + MOLAL(6) ! (NH4)2SO4 + AML5 = MOLAL(3)-2.D0*MOLALR(4) ! "free" NH4 + MOLALR(5) = MAX(MIN(AML5,MOLAL(7)), ZERO)! NH4NO3 = MIN("free", NO3) +! +! *** NH4-SO4-NO3 SYSTEM ; SULFATE RICH CASE ; NO FREE ACID +! + ELSE IF (SC.EQ.'E') THEN + SO4I = MAX(MOLAL(5)-MOLAL(1),ZERO) ! FROM HSO4 DISSOCIATION + HSO4I = MOLAL(6)+MOLAL(1) + IF (SO4I.LT.HSO4I) THEN + MOLALR(13) = SO4I ! [LC] = [SO4] + MOLALR(9) = MAX(HSO4I-SO4I, ZERO) ! NH4HSO4 + ELSE + MOLALR(13) = HSO4I ! [LC] = [HSO4] + MOLALR(4) = MAX(SO4I-HSO4I, ZERO) ! (NH4)2SO4 + ENDIF +! +! *** NH4-SO4-NO3 SYSTEM ; SULFATE RICH CASE ; FREE ACID +! + ELSE IF (SC.EQ.'F') THEN + MOLALR(9) = MOLAL(3) ! NH4HSO4 + MOLALR(7) = MAX(MOLAL(5)+MOLAL(6)-MOLAL(3),ZERO) ! H2SO4 +! +! *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM POOR CASE +! + ELSE IF (SC.EQ.'G') THEN + MOLALR(2) = 0.5*MOLAL(2) ! NA2SO4 + TOTS4 = MOLAL(5)+MOLAL(6) ! Total SO4 + MOLALR(4) = MAX(TOTS4 - MOLALR(2), ZERO) ! (NH4)2SO4 + FRNH4 = MAX(MOLAL(3) - 2.D0*MOLALR(4), ZERO) + MOLALR(5) = MIN(MOLAL(7),FRNH4) ! NH4NO3 + FRNH4 = MAX(FRNH4 - MOLALR(5), ZERO) + MOLALR(6) = MIN(MOLAL(4), FRNH4) ! NH4CL +! +! *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE POOR ; SODIUM RICH CASE +! *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/ +! + ELSE IF (SC.EQ.'H') THEN + MOLALR(1) = PSI7 ! NACL + MOLALR(2) = PSI1 ! NA2SO4 + MOLALR(3) = PSI8 ! NANO3 + MOLALR(4) = ZERO ! (NH4)2SO4 + FRNO3 = MAX(MOLAL(7) - MOLALR(3), ZERO) ! "FREE" NO3 + FRCL = MAX(MOLAL(4) - MOLALR(1), ZERO) ! "FREE" CL + MOLALR(5) = MIN(MOLAL(3),FRNO3) ! NH4NO3 + FRNH4 = MAX(MOLAL(3) - MOLALR(5), ZERO) ! "FREE" NH3 + MOLALR(6) = MIN(FRCL, FRNH4) ! NH4CL +! +! *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE RICH CASE ; NO FREE ACID +! *** RETREIVE DISSOLVED SALTS DIRECTLY FROM COMMON BLOCK /SOLUT/ +! + ELSE IF (SC.EQ.'I') THEN + MOLALR(04) = PSI5 ! (NH4)2SO4 + MOLALR(02) = PSI4 ! NA2SO4 + MOLALR(09) = PSI1 ! NH4HSO4 + MOLALR(12) = PSI3 ! NAHSO4 + MOLALR(13) = PSI2 ! LC +! +! *** NA-NH4-SO4-NO3-CL SYSTEM ; SULFATE RICH CASE ; FREE ACID +! + ELSE IF (SC.EQ.'J') THEN + MOLALR(09) = MOLAL(3) ! NH4HSO4 + MOLALR(12) = MOLAL(2) ! NAHSO4 + MOLALR(07) = MOLAL(5)+MOLAL(6)-MOLAL(3)-MOLAL(2) ! H2SO4 + MOLALR(07) = MAX(MOLALR(07),ZERO) +! +! ======= REVERSE PROBLEMS =========================================== +! +! *** NH4-SO4-NO3 SYSTEM ; SULFATE POOR CASE +! + ELSE IF (SC.EQ.'N') THEN + MOLALR(4) = MOLAL(5) + MOLAL(6) ! (NH4)2SO4 + AML5 = WAER(3)-2.D0*MOLALR(4) ! "free" NH4 + MOLALR(5) = MAX(MIN(AML5,WAER(4)), ZERO) ! NH4NO3 = MIN("free", NO3) +! +! *** NH4-SO4-NO3-NA-CL SYSTEM ; SULFATE POOR, SODIUM POOR CASE +! + ELSE IF (SC.EQ.'Q') THEN + MOLALR(2) = PSI1 ! NA2SO4 + MOLALR(4) = PSI6 ! (NH4)2SO4 + MOLALR(5) = PSI5 ! NH4NO3 + MOLALR(6) = PSI4 ! NH4CL +! +! *** NH4-SO4-NO3-NA-CL SYSTEM ; SULFATE POOR, SODIUM RICH CASE +! + ELSE IF (SC.EQ.'R') THEN + MOLALR(1) = PSI3 ! NACL + MOLALR(2) = PSI1 ! NA2SO4 + MOLALR(3) = PSI2 ! NANO3 + MOLALR(4) = ZERO ! (NH4)2SO4 + MOLALR(5) = PSI5 ! NH4NO3 + MOLALR(6) = PSI4 ! NH4CL +! +! *** UNKNOWN CASE +! + ELSE + CALL PUSHERR (1001, ' ') ! FATAL ERROR: CASE NOT SUPPORTED + ENDIF +! +! *** CALCULATE WATER CONTENT ; ZSR CORRELATION *********************** +! + WATER = ZERO + DO 10 I=1,NPAIR + WATER = WATER + MOLALR(I)/M0(I) +10 CONTINUE + WATER = MAX(WATER, TINY) +! + RETURN +! +! *** END OF SUBROUTINE CALCMR ****************************************** +! + END +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCMDRH +! +! THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL +! DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED +! SOLUTIONS ; THE 'DRY' SOLUTION (SUBROUTINE DRYCASE) AND THE +! 'SATURATED LIQUID' SOLUTION (SUBROUTINE LIQCASE). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCMDRH (RHI, RHDRY, RHLIQ, DRYCASE, LIQCASE) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL DRYCASE, LIQCASE +! +! *** FIND WEIGHT FACTOR ********************************************** +! + IF (WFTYP.EQ.0) THEN + WF = ONE + ELSEIF (WFTYP.EQ.1) THEN + WF = 0.5D0 + ELSE + WF = (RHLIQ-RHI)/(RHLIQ-RHDRY) + ENDIF + ONEMWF = ONE - WF +! +! *** FIND FIRST SECTION ; DRY ONE ************************************ +! + CALL DRYCASE + IF (ABS(ONEMWF).LE.1D-5) GOTO 200 ! DRY AEROSOL +! + CNH42SO = CNH42S4 ! FIRST (DRY) SOLUTION + CNH4HSO = CNH4HS4 + CLCO = CLC + CNH4N3O = CNH4NO3 + CNH4CLO = CNH4CL + CNA2SO = CNA2SO4 + CNAHSO = CNAHSO4 + CNANO = CNANO3 + CNACLO = CNACL + GNH3O = GNH3 + GHNO3O = GHNO3 + GHCLO = GHCL +! +! *** FIND SECOND SECTION ; DRY & LIQUID ****************************** +! + CNH42S4 = ZERO + CNH4HS4 = ZERO + CLC = ZERO + CNH4NO3 = ZERO + CNH4CL = ZERO + CNA2SO4 = ZERO + CNAHSO4 = ZERO + CNANO3 = ZERO + CNACL = ZERO + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO + CALL LIQCASE ! SECOND (LIQUID) SOLUTION +! +! *** ADJUST THINGS FOR THE CASE THAT THE LIQUID SUB PREDICTS DRY AEROSOL +! + IF (WATER.LE.TINY) THEN + DO 100 I=1,NIONS + MOLAL(I)= ZERO ! Aqueous phase + 100 CONTINUE + WATER = ZERO +! + CNH42S4 = CNH42SO ! Solid phase + CNA2SO4 = CNA2SO + CNAHSO4 = CNAHSO + CNH4HS4 = CNH4HSO + CLC = CLCO + CNH4NO3 = CNH4N3O + CNANO3 = CNANO + CNACL = CNACLO + CNH4CL = CNH4CLO +! + GNH3 = GNH3O ! Gas phase + GHNO3 = GHNO3O + GHCL = GHCLO +! + GOTO 200 + ENDIF +! +! *** FIND SALT DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS. +! + DAMSUL = CNH42SO - CNH42S4 + DSOSUL = CNA2SO - CNA2SO4 + DAMBIS = CNH4HSO - CNH4HS4 + DSOBIS = CNAHSO - CNAHSO4 + DLC = CLCO - CLC + DAMNIT = CNH4N3O - CNH4NO3 + DAMCHL = CNH4CLO - CNH4CL + DSONIT = CNANO - CNANO3 + DSOCHL = CNACLO - CNACL +! +! *** FIND GAS DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS. +! + DAMG = GNH3O - GNH3 + DHAG = GHCLO - GHCL + DNAG = GHNO3O - GHNO3 +! +! *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS. +! +! LIQUID +! + MOLAL(1)= ONEMWF*MOLAL(1) ! H+ + MOLAL(2)= ONEMWF*(2.D0*DSOSUL + DSOBIS + DSONIT + DSOCHL) ! NA+ + MOLAL(3)= ONEMWF*(2.D0*DAMSUL + DAMG + DAMBIS + DAMCHL + & + 3.D0*DLC + DAMNIT ) ! NH4+ + MOLAL(4)= ONEMWF*( DAMCHL + DSOCHL + DHAG) ! CL- + MOLAL(5)= ONEMWF*( DAMSUL + DSOSUL + DLC - MOLAL(6)) ! SO4-- !VB 17 Sept 2001 + MOLAL(6)= ONEMWF*( MOLAL(6) + DSOBIS + DAMBIS + DLC) ! HSO4- + MOLAL(7)= ONEMWF*( DAMNIT + DSONIT + DNAG) ! NO3- + WATER = ONEMWF*WATER +! +! SOLID +! + CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4 + CNA2SO4 = WF*CNA2SO + ONEMWF*CNA2SO4 + CNAHSO4 = WF*CNAHSO + ONEMWF*CNAHSO4 + CNH4HS4 = WF*CNH4HSO + ONEMWF*CNH4HS4 + CLC = WF*CLCO + ONEMWF*CLC + CNH4NO3 = WF*CNH4N3O + ONEMWF*CNH4NO3 + CNANO3 = WF*CNANO + ONEMWF*CNANO3 + CNACL = WF*CNACLO + ONEMWF*CNACL + CNH4CL = WF*CNH4CLO + ONEMWF*CNH4CL +! +! GAS +! + GNH3 = WF*GNH3O + ONEMWF*GNH3 + GHNO3 = WF*GHNO3O + ONEMWF*GHNO3 + GHCL = WF*GHCLO + ONEMWF*GHCL +! +! *** RETURN POINT +! +200 RETURN +! +! *** END OF SUBROUTINE CALCMDRH **************************************** +! + END + + + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCMDRP +! +! THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL +! DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED +! SOLUTIONS ; THE 'DRY' SOLUTION (SUBROUTINE DRYCASE) AND THE +! 'SATURATED LIQUID' SOLUTION (SUBROUTINE LIQCASE). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCMDRP (RHI, RHDRY, RHLIQ, DRYCASE, LIQCASE) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL DRYCASE, LIQCASE +! +! *** FIND WEIGHT FACTOR ********************************************** +! + IF (WFTYP.EQ.0) THEN + WF = ONE + ELSEIF (WFTYP.EQ.1) THEN + WF = 0.5D0 + ELSE + WF = (RHLIQ-RHI)/(RHLIQ-RHDRY) + ENDIF + ONEMWF = ONE - WF +! +! *** FIND FIRST SECTION ; DRY ONE ************************************ +! + CALL DRYCASE + IF (ABS(ONEMWF).LE.1D-5) GOTO 200 ! DRY AEROSOL +! + CNH42SO = CNH42S4 ! FIRST (DRY) SOLUTION + CNH4HSO = CNH4HS4 + CLCO = CLC + CNH4N3O = CNH4NO3 + CNH4CLO = CNH4CL + CNA2SO = CNA2SO4 + CNAHSO = CNAHSO4 + CNANO = CNANO3 + CNACLO = CNACL +! +! *** FIND SECOND SECTION ; DRY & LIQUID ****************************** +! + CNH42S4 = ZERO + CNH4HS4 = ZERO + CLC = ZERO + CNH4NO3 = ZERO + CNH4CL = ZERO + CNA2SO4 = ZERO + CNAHSO4 = ZERO + CNANO3 = ZERO + CNACL = ZERO + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO + CALL LIQCASE ! SECOND (LIQUID) SOLUTION +! +! *** ADJUST THINGS FOR THE CASE THAT THE LIQUID SUB PREDICTS DRY AEROSOL +! + IF (WATER.LE.TINY) THEN + WATER = ZERO + DO 100 I=1,NIONS + MOLAL(I)= ZERO + 100 CONTINUE + CALL DRYCASE + GOTO 200 + ENDIF +! +! *** FIND SALT DISSOLUTIONS BETWEEN DRY & LIQUID SOLUTIONS. +! + DAMBIS = CNH4HSO - CNH4HS4 + DSOBIS = CNAHSO - CNAHSO4 + DLC = CLCO - CLC +! +! *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS. +! +! *** SOLID +! + CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4 + CNA2SO4 = WF*CNA2SO + ONEMWF*CNA2SO4 + CNAHSO4 = WF*CNAHSO + ONEMWF*CNAHSO4 + CNH4HS4 = WF*CNH4HSO + ONEMWF*CNH4HS4 + CLC = WF*CLCO + ONEMWF*CLC + CNH4NO3 = WF*CNH4N3O + ONEMWF*CNH4NO3 + CNANO3 = WF*CNANO + ONEMWF*CNANO3 + CNACL = WF*CNACLO + ONEMWF*CNACL + CNH4CL = WF*CNH4CLO + ONEMWF*CNH4CL +! +! *** LIQUID +! + WATER = ONEMWF*WATER +! + MOLAL(2)= WAER(1) - 2.D0*CNA2SO4 - CNAHSO4 - CNANO3 - & + CNACL ! NA+ + MOLAL(3)= WAER(3) - 2.D0*CNH42S4 - CNH4HS4 - CNH4CL - & + 3.D0*CLC - CNH4NO3 ! NH4+ + MOLAL(4)= WAER(5) - CNACL - CNH4CL ! CL- + MOLAL(7)= WAER(4) - CNANO3 - CNH4NO3 ! NO3- + MOLAL(6)= ONEMWF*(MOLAL(6) + DSOBIS + DAMBIS + DLC) ! HSO4- + MOLAL(5)= WAER(2) - MOLAL(6) - CLC - CNH42S4 - CNA2SO4 ! SO4-- +! + A8 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. + IF (MOLAL(5).LE.TINY) THEN + HIEQ = SQRT(XKW *RH*WATER*WATER) ! Neutral solution + ELSE + HIEQ = A8*MOLAL(6)/MOLAL(5) + ENDIF + HIEN = MOLAL(4) + MOLAL(7) + MOLAL(6) + 2.D0*MOLAL(5) - & + MOLAL(2) - MOLAL(3) + MOLAL(1)= MAX (HIEQ, HIEN) ! H+ +! +! *** GAS (ACTIVITY COEFS FROM LIQUID SOLUTION) +! + A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +! + GNH3 = MOLAL(3)/MAX(MOLAL(1),TINY)/A2 + GHNO3 = MOLAL(1)*MOLAL(7)/A3 + GHCL = MOLAL(1)*MOLAL(4)/A4 +! +200 RETURN +! +! *** END OF SUBROUTINE CALCMDRP **************************************** +! + END +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCHS4 +! *** THIS SUBROUTINE CALCULATES THE HSO4 GENERATED FROM (H,SO4). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCHS4 (HI, SO4I, HSO4I, DELTA) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +!C CHARACTER ERRINF*40 +! +! *** IF TOO LITTLE WATER, DONT SOLVE +! + IF (WATER.LE.1d1*TINY) THEN + DELTA = ZERO + RETURN + ENDIF +! +! *** CALCULATE HSO4 SPECIATION ***************************************** +! + A8 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. +! + BB =-(HI + SO4I + A8) + CC = HI*SO4I - HSO4I*A8 + DD = BB*BB - 4.D0*CC +! + IF (DD.GE.ZERO) THEN + SQDD = SQRT(DD) + DELTA1 = 0.5*(-BB + SQDD) + DELTA2 = 0.5*(-BB - SQDD) + IF (HSO4I.LE.TINY) THEN + DELTA = DELTA2 + ELSEIF( HI*SO4I .GE. A8*HSO4I ) THEN + DELTA = DELTA2 + ELSEIF( HI*SO4I .LT. A8*HSO4I ) THEN + DELTA = DELTA1 + ELSE + DELTA = ZERO + ENDIF + ELSE + DELTA = ZERO + ENDIF +!CC +!CC *** COMPARE DELTA TO TOTAL H+ ; ESTIMATE EFFECT OF HSO4 *************** +!CC +!C HYD = MAX(HI, MOLAL(1)) +!C IF (HYD.GT.TINY) THEN +!C IF (DELTA/HYD.GT.0.1d0) THEN +!C WRITE (ERRINF,'(1PE10.3)') DELTA/HYD*100.0 +!C CALL PUSHERR (0020, ERRINF) +!C ENDIF +!C ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCHS4 ***************************************** +! + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCPH +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCPH (GG, HI, OHI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + AKW = XKW *RH*WATER*WATER + CN = SQRT(AKW) +! +! *** GG = (negative charge) - (positive charge) +! + IF (GG.GT.TINY) THEN ! H+ in excess + BB =-GG + CC =-AKW + DD = BB*BB - 4.D0*CC + HI = MAX(0.5D0*(-BB + SQRT(DD)),CN) + OHI= AKW/HI + ELSE ! OH- in excess + BB = GG + CC =-AKW + DD = BB*BB - 4.D0*CC + OHI= MAX(0.5D0*(-BB + SQRT(DD)),CN) + HI = AKW/OHI + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCPH ****************************************** +! + END + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCACT +! *** CALCULATES MULTI-COMPONENET ACTIVITY COEFFICIENTS FROM BROMLEYS +! METHOD. THE BINARY ACTIVITY COEFFICIENTS ARE CALCULATED BY +! KUSIK-MEISNER RELATION (SUBROUTINE KMTAB or SUBROUTINE KMFUL). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCACT + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + REAL EX10, URF + REAL G0(3,4),ZPL,ZMI,AGAMA,SION,H,CH,F1(3),F2(4) + DOUBLE PRECISION MPL, XIJ, YJI +! PARAMETER (URF=0.5) + PARAMETER (LN10=2.30258509299404568402D0) +! + G(I,J)= (F1(I)/Z(I) + F2(J)/Z(J+3)) / (Z(I)+Z(J+3)) - H +! +! *** SAVE ACTIVITIES IN OLD ARRAY ************************************* +! + IF (FRST) THEN ! Outer loop + DO 10 I=1,NPAIR + GAMOU(I) = GAMA(I) +10 CONTINUE + ENDIF +! + DO 20 I=1,NPAIR ! Inner loop + GAMIN(I) = GAMA(I) +20 CONTINUE +! +! *** CALCULATE IONIC ACTIVITY OF SOLUTION ***************************** +! + IONIC=0.0 + DO 30 I=1,NIONS + IONIC=IONIC + MOLAL(I)*Z(I)*Z(I) +30 CONTINUE + IONIC = MAX(MIN(0.5*IONIC/WATER,500.d0), TINY) +! +! *** CALCULATE BINARY ACTIVITY COEFFICIENTS *************************** +! +! G0(1,1)=G11;G0(1,2)=G07;G0(1,3)=G08;G0(1,4)=G10;G0(2,1)=G01;G0(2,2)=G02 +! G0(2,3)=G12;G0(2,4)=G03;G0(3,1)=G06;G0(3,2)=G04;G0(3,3)=G09;G0(3,4)=G05 +! + IF (IACALC.EQ.0) THEN ! K.M.; FULL + CALL KMFUL (IONIC, SNGL(TEMP),G0(2,1),G0(2,2),G0(2,4), & + G0(3,2),G0(3,4),G0(3,1),G0(1,2),G0(1,3),G0(3,3), & + G0(1,4),G0(1,1),G0(2,3)) + ELSE ! K.M.; TABULATED + CALL KMTAB (IONIC, SNGL(TEMP),G0(2,1),G0(2,2),G0(2,4), & + G0(3,2),G0(3,4),G0(3,1),G0(1,2),G0(1,3),G0(3,3), & + G0(1,4),G0(1,1),G0(2,3)) + ENDIF +! +! *** CALCULATE MULTICOMPONENT ACTIVITY COEFFICIENTS ******************* +! + AGAMA = 0.511*(298.0/TEMP)**1.5 ! Debye Huckel const. at T + SION = SQRT(IONIC) + H = AGAMA*SION/(1+SION) +! + DO 100 I=1,3 + F1(I)=0.0 + F2(I)=0.0 +100 CONTINUE + F2(4)=0.0 +! + DO 110 I=1,3 + ZPL = Z(I) + MPL = MOLAL(I)/WATER + DO 110 J=1,4 + ZMI = Z(J+3) + CH = 0.25*(ZPL+ZMI)*(ZPL+ZMI)/IONIC + XIJ = CH*MPL + YJI = CH*MOLAL(J+3)/WATER + F1(I) = F1(I) + SNGL(YJI*(G0(I,J) + ZPL*ZMI*H)) + F2(J) = F2(J) + SNGL(XIJ*(G0(I,J) + ZPL*ZMI*H)) +110 CONTINUE +! +! *** LOG10 OF ACTIVITY COEFFICIENTS *********************************** +! + GAMA(01) = G(2,1)*ZZ(01) ! NACL + GAMA(02) = G(2,2)*ZZ(02) ! NA2SO4 + GAMA(03) = G(2,4)*ZZ(03) ! NANO3 + GAMA(04) = G(3,2)*ZZ(04) ! (NH4)2SO4 + GAMA(05) = G(3,4)*ZZ(05) ! NH4NO3 + GAMA(06) = G(3,1)*ZZ(06) ! NH4CL + GAMA(07) = G(1,2)*ZZ(07) ! 2H-SO4 + GAMA(08) = G(1,3)*ZZ(08) ! H-HSO4 + GAMA(09) = G(3,3)*ZZ(09) ! NH4HSO4 + GAMA(10) = G(1,4)*ZZ(10) ! HNO3 + GAMA(11) = G(1,1)*ZZ(11) ! HCL + GAMA(12) = G(2,3)*ZZ(12) ! NAHSO4 + GAMA(13) = 0.20*(3.0*GAMA(04)+2.0*GAMA(09)) ! LC ; SCAPE +!C GAMA(13) = 0.50*(GAMA(04)+GAMA(09)) ! LC ; SEQUILIB +!C GAMA(13) = 0.25*(3.0*GAMA(04)+GAMA(07)) ! LC ; AIM +! +! *** CONVERT LOG (GAMA) COEFFICIENTS TO GAMA ************************** +! + DO 200 I=1,NPAIR + GAMA(I)=MAX(-11.0d0, MIN(GAMA(I),11.0d0) ) ! F77 LIBRARY ROUTINE +! GAMA(I)=10.0**GAMA(I) + GAMA(I)=EXP(LN10*GAMA(I)) +!C GAMA(I)=EX10(SNGL(GAMA(I)), 5.0) ! CUTOFF SET TO [-5,5] +! GAMA(I) = GAMIN(I)*(1.0-URF) + URF*GAMA(I) ! Under-relax GAMA's + 200 CONTINUE +! +! *** SETUP ACTIVITY CALCULATION FLAGS ********************************* +! +! OUTER CALCULATION LOOP ; ONLY IF FRST=.TRUE. +! + IF (FRST) THEN + ERROU = ZERO ! CONVERGENCE CRITERION + DO 210 I=1,NPAIR + ERROU=MAX(ERROU, ABS((GAMOU(I)-GAMA(I))/GAMOU(I))) +210 CONTINUE + CALAOU = ERROU .GE. EPSACT ! SETUP FLAGS + FRST =.FALSE. + ENDIF +! +! INNER CALCULATION LOOP ; ALWAYS +! + ERRIN = ZERO ! CONVERGENCE CRITERION + DO 220 I=1,NPAIR + ERRIN = MAX (ERRIN, ABS((GAMIN(I)-GAMA(I))/GAMIN(I))) +220 CONTINUE + CALAIN = ERRIN .GE. EPSACT +! + ICLACT = ICLACT + 1 ! Increment ACTIVITY call counter +! +! *** END OF SUBROUTINE ACTIVITY **************************************** +! + RETURN + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE RSTGAM +! *** RESETS ACTIVITY COEFFICIENT ARRAYS TO DEFAULT VALUE OF 0.1 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE RSTGAM + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + DO 10 I=1, NPAIR + GAMA(I) = 0.1 +10 CONTINUE +! +! *** END OF SUBROUTINE RSTGAM ****************************************** +! + RETURN + END +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE KMFUL +! *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE KMFUL (IONIC,TEMP,G01,G02,G03,G04,G05,G06,G07,G08,G09, & + G10,G11,G12) + REAL Ionic, TEMP + DATA Z01,Z02,Z03,Z04,Z05,Z06,Z07,Z08,Z10,Z11 & + /1, 2, 1, 2, 1, 1, 2, 1, 1, 1/ +! + SION = SQRT(IONIC) +! +! *** Coefficients at 25 oC +! + CALL MKBI(2.230, IONIC, SION, Z01, G01) + CALL MKBI(-0.19, IONIC, SION, Z02, G02) + CALL MKBI(-0.39, IONIC, SION, Z03, G03) + CALL MKBI(-0.25, IONIC, SION, Z04, G04) + CALL MKBI(-1.15, IONIC, SION, Z05, G05) + CALL MKBI(0.820, IONIC, SION, Z06, G06) + CALL MKBI(-.100, IONIC, SION, Z07, G07) + CALL MKBI(8.000, IONIC, SION, Z08, G08) + CALL MKBI(2.600, IONIC, SION, Z10, G10) + CALL MKBI(6.000, IONIC, SION, Z11, G11) +! +! *** Correct for T other than 298 K +! + TI = TEMP-273.0 + TC = TI-25.0 + IF (ABS(TC) .GT. 1.0) THEN + CF1 = 1.125-0.005*TI + CF2 = (0.125-0.005*TI)*(0.039*IONIC**0.92-0.41*SION/(1.+SION)) + G01 = CF1*G01 - CF2*Z01 + G02 = CF1*G02 - CF2*Z02 + G03 = CF1*G03 - CF2*Z03 + G04 = CF1*G04 - CF2*Z04 + G05 = CF1*G05 - CF2*Z05 + G06 = CF1*G06 - CF2*Z06 + G07 = CF1*G07 - CF2*Z07 + G08 = CF1*G08 - CF2*Z08 + G10 = CF1*G10 - CF2*Z10 + G11 = CF1*G11 - CF2*Z11 + ENDIF +! + G09 = G06 + G08 - G11 + G12 = G01 + G08 - G11 +! +! *** Return point ; End of subroutine +! + RETURN + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE MKBI +! *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE MKBI(Q,IONIC,SION,ZIP,BI) +! + REAL IONIC +! + B=.75-.065*Q + C= 1.0 + IF (IONIC.LT.6.0) C=1.+.055*Q*EXP(-.023*IONIC*IONIC*IONIC) + XX=-0.5107*SION/(1.+C*SION) + BI=(1.+B*(1.+.1*IONIC)**Q-B) + BI=ZIP*ALOG10(BI) + ZIP*XX +! + RETURN + END +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE KMTAB +! *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +! THE COMPUTATIONS HAVE BEEN PERFORMED AND THE RESULTS ARE STORED IN +! LOOKUP TABLES. THE IONIC ACTIVITY 'IONIC' IS INPUT, AND THE ARRAY +! 'BINARR' IS RETURNED WITH THE BINARY COEFFICIENTS. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE KMTAB (IN,TEMP,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10, & + G11,G12) + REAL IN, Temp +! +! *** Find temperature range +! + IND = NINT((TEMP-198.0)/25.0) + 1 + IND = MIN(MAX(IND,1),6) +! +! *** Call appropriate routine +! + IF (IND.EQ.1) THEN + CALL KM198 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10,G11,G12) + ELSEIF (IND.EQ.2) THEN + CALL KM223 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10,G11,G12) + ELSEIF (IND.EQ.3) THEN + CALL KM248 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10,G11,G12) + ELSEIF (IND.EQ.4) THEN + CALL KM273 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10,G11,G12) + ELSEIF (IND.EQ.5) THEN + CALL KM298 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10,G11,G12) + ELSE + CALL KM323 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10,G11,G12) + ENDIF +! +! *** Return point; End of subroutine +! + RETURN + END + + + INTEGER FUNCTION IBACPOS(IN) +! +! Compute the index in the binary activity coefficient array +! based on the input ionic strength. +! +! Chris Nolte, 6/16/05 +! + implicit none + real IN + IF (IN .LE. 0.300000E+02) THEN + ibacpos = MIN(NINT( 0.200000E+02*IN) + 1, 600) + ELSE + ibacpos = 600+NINT( 0.200000E+01*IN- 0.600000E+02) + ENDIF + ibacpos = min(ibacpos, 741) + return + end + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE KM198 +! *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +! THE COMPUTATIONS HAVE BEEN PERFORMED AND THE RESULTS ARE STORED IN +! LOOKUP TABLES. THE IONIC ACTIVITY 'IN' IS INPUT, AND THE ARRAY +! 'BINARR' IS RETURNED WITH THE BINARY COEFFICIENTS. +! +! TEMPERATURE IS 198K +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE KM198 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10, & + G11,G12) + USE KMC198 +! +! *** Common block definition +! +! COMMON /KMC198/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) + REAL IN +! +! *** Find position in arrays for binary activity coefficients +! + ipos = ibacpos(IN) +! +! *** Assign values to return array +! + G01 = BNC01M(ipos) + G02 = BNC02M(ipos) + G03 = BNC03M(ipos) + G04 = BNC04M(ipos) + G05 = BNC05M(ipos) + G06 = BNC06M(ipos) + G07 = BNC07M(ipos) + G08 = BNC08M(ipos) + G09 = BNC09M(ipos) + G10 = BNC10M(ipos) + G11 = BNC11M(ipos) + G12 = BNC12M(ipos) +! +! *** Return point ; End of subroutine +! + RETURN + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE KM223 +! *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +! THE COMPUTATIONS HAVE BEEN PERFORMED AND THE RESULTS ARE STORED IN +! LOOKUP TABLES. THE IONIC ACTIVITY 'IN' IS INPUT, AND THE ARRAY +! 'BINARR' IS RETURNED WITH THE BINARY COEFFICIENTS. +! +! TEMPERATURE IS 223K +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE KM223 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10, & + G11,G12) + USE KMC223 +! +! *** Common block definition +! +! COMMON /KMC223/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) + REAL IN +! +! *** Find position in arrays for binary activity coefficients +! + ipos = ibacpos(IN) +! +! *** Assign values to return array +! + G01 = BNC01M(ipos) + G02 = BNC02M(ipos) + G03 = BNC03M(ipos) + G04 = BNC04M(ipos) + G05 = BNC05M(ipos) + G06 = BNC06M(ipos) + G07 = BNC07M(ipos) + G08 = BNC08M(ipos) + G09 = BNC09M(ipos) + G10 = BNC10M(ipos) + G11 = BNC11M(ipos) + G12 = BNC12M(ipos) +! +! *** Return point ; End of subroutine +! + RETURN + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE KM248 +! *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +! THE COMPUTATIONS HAVE BEEN PERFORMED AND THE RESULTS ARE STORED IN +! LOOKUP TABLES. THE IONIC ACTIVITY 'IN' IS INPUT, AND THE ARRAY +! 'BINARR' IS RETURNED WITH THE BINARY COEFFICIENTS. +! +! TEMPERATURE IS 248K +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE KM248 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10, & + G11,G12) + USE KMC248 +! +! *** Common block definition +! +! COMMON /KMC248/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) + REAL IN +! +! *** Find position in arrays for binary activity coefficients +! + ipos = ibacpos(IN) +! +! *** Assign values to return array +! + G01 = BNC01M(ipos) + G02 = BNC02M(ipos) + G03 = BNC03M(ipos) + G04 = BNC04M(ipos) + G05 = BNC05M(ipos) + G06 = BNC06M(ipos) + G07 = BNC07M(ipos) + G08 = BNC08M(ipos) + G09 = BNC09M(ipos) + G10 = BNC10M(ipos) + G11 = BNC11M(ipos) + G12 = BNC12M(ipos) +! +! *** Return point ; End of subroutine +! + RETURN + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE KM273 +! *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +! THE COMPUTATIONS HAVE BEEN PERFORMED AND THE RESULTS ARE STORED IN +! LOOKUP TABLES. THE IONIC ACTIVITY 'IN' IS INPUT, AND THE ARRAY +! 'BINARR' IS RETURNED WITH THE BINARY COEFFICIENTS. +! +! TEMPERATURE IS 273K +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE KM273 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10, & + G11,G12) + USE KMC273 +! +! *** Common block definition +! +! COMMON /KMC273/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) + REAL IN +! +! *** Find position in arrays for binary activity coefficients +! + ipos = ibacpos(IN) +! +! *** Assign values to return array +! + G01 = BNC01M(ipos) + G02 = BNC02M(ipos) + G03 = BNC03M(ipos) + G04 = BNC04M(ipos) + G05 = BNC05M(ipos) + G06 = BNC06M(ipos) + G07 = BNC07M(ipos) + G08 = BNC08M(ipos) + G09 = BNC09M(ipos) + G10 = BNC10M(ipos) + G11 = BNC11M(ipos) + G12 = BNC12M(ipos) +! +! *** Return point ; End of subroutine +! + RETURN + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE KM298 +! *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +! THE COMPUTATIONS HAVE BEEN PERFORMED AND THE RESULTS ARE STORED IN +! LOOKUP TABLES. THE IONIC ACTIVITY 'IN' IS INPUT, AND THE ARRAY +! 'BINARR' IS RETURNED WITH THE BINARY COEFFICIENTS. +! +! TEMPERATURE IS 298K +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE KM298 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10, & + G11,G12) + USE KMC298 +! +! *** Common block definition +! +! COMMON /KMC298/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) + REAL IN +! +! *** Find position in arrays for binary activity coefficients +! + ipos = ibacpos(IN) +! +! *** Assign values to return array +! + G01 = BNC01M(ipos) + G02 = BNC02M(ipos) + G03 = BNC03M(ipos) + G04 = BNC04M(ipos) + G05 = BNC05M(ipos) + G06 = BNC06M(ipos) + G07 = BNC07M(ipos) + G08 = BNC08M(ipos) + G09 = BNC09M(ipos) + G10 = BNC10M(ipos) + G11 = BNC11M(ipos) + G12 = BNC12M(ipos) +! +! *** Return point ; End of subroutine +! + RETURN + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE KM323 +! *** CALCULATES BINARY ACTIVITY COEFFICIENTS BY KUSIK-MEISSNER METHOD. +! THE COMPUTATIONS HAVE BEEN PERFORMED AND THE RESULTS ARE STORED IN +! LOOKUP TABLES. THE IONIC ACTIVITY 'IN' IS INPUT, AND THE ARRAY +! 'BINARR' IS RETURNED WITH THE BINARY COEFFICIENTS. +! +! TEMPERATURE IS 323K +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE KM323 (IN,G01,G02,G03,G04,G05,G06,G07,G08,G09,G10, & + G11,G12) + USE KMC323 +! +! *** Common block definition +! +! COMMON /KMC323/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) + REAL IN +! +! *** Find position in arrays for binary activity coefficients +! + ipos = ibacpos(IN) +! +! *** Assign values to return array +! + G01 = BNC01M(ipos) + G02 = BNC02M(ipos) + G03 = BNC03M(ipos) + G04 = BNC04M(ipos) + G05 = BNC05M(ipos) + G06 = BNC06M(ipos) + G07 = BNC07M(ipos) + G08 = BNC08M(ipos) + G09 = BNC09M(ipos) + G10 = BNC10M(ipos) + G11 = BNC11M(ipos) + G12 = BNC12M(ipos) +! +! *** Return point ; End of subroutine +! + RETURN + END + + + +! *** TEMP = 198.0 + + BLOCK DATA KMCF198 + USE KMC198 +! +! *** Common block definition +! +! COMMON /KMC198/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) +! + END + +! *** TEMP = 223.0 + + BLOCK DATA KMCF223 + USE KMC223 +! +! *** Common block definition +! +! COMMON /KMC223/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) +! + END + +! *** TEMP = 248.0 + + BLOCK DATA KMCF248 + USE KMC248 +! +! *** Common block definition +! +! COMMON /KMC248/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) + END + +! *** TEMP = 273.0 + + BLOCK DATA KMCF273 + USE KMC273 +! +! *** Common block definition +! +! COMMON /KMC273/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) + END + +! *** TEMP = 298.0 + + BLOCK DATA KMCF298 + USE KMC298 +! +! *** Common block definition +! +! COMMON /KMC298/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) + END + +! *** TEMP = 323.0 + + BLOCK DATA KMCF323 + USE KMC323 +! +! *** Common block definition +! +! COMMON /KMC323/ & +! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & +! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & +! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & +! BNC13M( 741) + END + +!C************************************************************************* +!C +!C TOOLBOX LIBRARY v.1.0 (May 1995) +!C +!C Program unit : SUBROUTINE CHRBLN +!C Purpose : Position of last non-blank character in a string +!C Author : Athanasios Nenes +!C +!C ======================= ARGUMENTS / USAGE ============================= +!C +!C STR is the CHARACTER variable containing the string examined +!C IBLK is a INTEGER variable containing the position of last non +!C blank character. If string is all spaces (ie ' '), then +!C the value returned is 1. +!C +!C EXAMPLE: +!C STR = 'TEST1.DAT ' +!C CALL CHRBLN (STR, IBLK) +!C +!C after execution of this code segment, "IBLK" has the value "9", which +!C is the position of the last non-blank character of "STR". +!C +!C*********************************************************************** +!C + SUBROUTINE CHRBLN (STR, IBLK) +!C +!C*********************************************************************** + CHARACTER*(*) STR +! + IBLK = 1 ! Substring pointer (default=1) + ILEN = LEN(STR) ! Length of string + DO 10 i=ILEN,1,-1 + IF (STR(i:i).NE.' ' .AND. STR(i:i).NE.CHAR(0)) THEN + IBLK = i + RETURN + ENDIF +10 CONTINUE + RETURN +! + END + + +!C************************************************************************* +!C +!C TOOLBOX LIBRARY v.1.0 (May 1995) +!C +!C Program unit : SUBROUTINE SHFTRGHT +!C Purpose : RIGHT-JUSTIFICATION FUNCTION ON A STRING +!C Author : Athanasios Nenes +!C +!C ======================= ARGUMENTS / USAGE ============================= +!C +!C STRING is the CHARACTER variable with the string to be justified +!C +!C EXAMPLE: +!C STRING = 'AAAA ' +!C CALL SHFTRGHT (STRING) +!C +!C after execution of this code segment, STRING contains the value +!C ' AAAA'. +!C +!C************************************************************************* +!C + SUBROUTINE SHFTRGHT (CHR) +!C +!C*********************************************************************** + CHARACTER CHR*(*) +! + I1 = LEN(CHR) ! Total length of string + CALL CHRBLN(CHR,I2) ! Position of last non-blank character + IF (I2.EQ.I1) RETURN +! + DO 10 I=I2,1,-1 ! Shift characters + CHR(I1+I-I2:I1+I-I2) = CHR(I:I) + CHR(I:I) = ' ' +10 CONTINUE + RETURN +! + END + + + + +!C************************************************************************* +!C +!C TOOLBOX LIBRARY v.1.0 (May 1995) +!C +!C Program unit : SUBROUTINE RPLSTR +!C Purpose : REPLACE CHARACTERS OCCURING IN A STRING +!C Author : Athanasios Nenes +!C +!C ======================= ARGUMENTS / USAGE ============================= +!C +!C STRING is the CHARACTER variable with the string to be edited +!C OLD is the old character which is to be replaced +!C NEW is the new character which OLD is to be replaced with +!C IERR is 0 if everything went well, is 1 if 'NEW' contains 'OLD'. +!C In this case, this is invalid, and no change is done. +!C +!C EXAMPLE: +!C STRING = 'AAAA' +!C OLD = 'A' +!C NEW = 'B' +!C CALL RPLSTR (STRING, OLD, NEW) +!C +!C after execution of this code segment, STRING contains the value +!C 'BBBB'. +!C +!C************************************************************************* +!C + SUBROUTINE RPLSTR (STRING, OLD, NEW, IERR) +!C +!C*********************************************************************** + CHARACTER STRING*(*), OLD*(*), NEW*(*) +! +! *** INITIALIZE ******************************************************** +! + ILO = LEN(OLD) +! +! *** CHECK AND SEE IF 'NEW' CONTAINS 'OLD', WHICH CANNOT *************** +! + IP = INDEX(NEW,OLD) + IF (IP.NE.0) THEN + IERR = 1 + RETURN + ELSE + IERR = 0 + ENDIF +! +! *** PROCEED WITH REPLACING ******************************************* +! +10 IP = INDEX(STRING,OLD) ! SEE IF 'OLD' EXISTS IN 'STRING' + IF (IP.EQ.0) RETURN ! 'OLD' DOES NOT EXIST ; RETURN + STRING(IP:IP+ILO-1) = NEW ! REPLACE SUBSTRING 'OLD' WITH 'NEW' + GOTO 10 ! GO FOR NEW OCCURANCE OF 'OLD' +! + END + + +!C************************************************************************* +!C +!C TOOLBOX LIBRARY v.1.0 (May 1995) +!C +!C Program unit : SUBROUTINE INPTD +!C Purpose : Prompts user for a value (DOUBLE). A default value +!C is provided, so if user presses , the default +!C is used. +!C Author : Athanasios Nenes +!C +!C ======================= ARGUMENTS / USAGE ============================= +!C +!C VAR is the DOUBLE PRECISION variable which value is to be saved +!C DEF is a DOUBLE PRECISION variable, with the default value of VAR. +!C PROMPT is a CHARACTER varible containing the prompt string. +!C PRFMT is a CHARACTER variable containing the FORMAT specifier +!C for the default value DEF. +!C IERR is an INTEGER error flag, and has the values: +!C 0 - No error detected. +!C 1 - Invalid FORMAT and/or Invalid default value. +!C 2 - Bad value specified by user +!C +!C EXAMPLE: +!C CALL INPTD (VAR, 1.0D0, 'Give value for A ', '*', Ierr) +!C +!C after execution of this code segment, the user is prompted for the +!C value of variable VAR. If is pressed (ie no value is specified) +!C then 1.0 is assigned to VAR. The default value is displayed in free- +!C format. The error status is specified by variable Ierr +!C +!C*********************************************************************** +!C + SUBROUTINE INPTD (VAR, DEF, PROMPT, PRFMT, IERR) +!C +!C*********************************************************************** + CHARACTER PROMPT*(*), PRFMT*(*), BUFFER*128 + DOUBLE PRECISION DEF, VAR + INTEGER IERR +! + IERR = 0 +! +! *** WRITE DEFAULT VALUE TO WORK BUFFER ******************************* +! + WRITE (BUFFER, FMT=PRFMT, ERR=10) DEF + CALL CHRBLN (BUFFER, IEND) +! +! *** PROMPT USER FOR INPUT AND READ IT ******************************** +! + WRITE (*,*) PROMPT,' [',BUFFER(1:IEND),']: ' + READ (*, '(A)', ERR=20, END=20) BUFFER + CALL CHRBLN (BUFFER,IEND) +! +! *** READ DATA OR SET DEFAULT ? **************************************** +! + IF (IEND.EQ.1 .AND. BUFFER(1:1).EQ.' ') THEN + VAR = DEF + ELSE + READ (BUFFER, *, ERR=20, END=20) VAR + ENDIF +! +! *** RETURN POINT ****************************************************** +! +30 RETURN +! +! *** ERROR HANDLER ***************************************************** +! +10 IERR = 1 ! Bad FORMAT and/or bad default value + GOTO 30 +! +20 IERR = 2 ! Bad number given by user + GOTO 30 +! + END + + +!C************************************************************************* +!C +!C TOOLBOX LIBRARY v.1.0 (May 1995) +!C +!C Program unit : SUBROUTINE Pushend +!C Purpose : Positions the pointer of a sequential file at its end +!C Simulates the ACCESS='APPEND' clause of a F77L OPEN +!C statement with Standard Fortran commands. +!C +!C ======================= ARGUMENTS / USAGE ============================= +!C +!C Iunit is a INTEGER variable, the file unit which the file is +!C connected to. +!C +!C EXAMPLE: +!C CALL PUSHEND (10) +!C +!C after execution of this code segment, the pointer of unit 10 is +!C pushed to its end. +!C +!C*********************************************************************** +!C + SUBROUTINE Pushend (Iunit) +!C +!C*********************************************************************** +! + LOGICAL OPNED +! +! *** INQUIRE IF Iunit CONNECTED TO FILE ******************************** +! + INQUIRE (UNIT=Iunit, OPENED=OPNED) + IF (.NOT.OPNED) GOTO 25 +! +! *** Iunit CONNECTED, PUSH POINTER TO END ****************************** +! +10 READ (Iunit,'()', ERR=20, END=20) + GOTO 10 +! +! *** RETURN POINT ****************************************************** +! +20 BACKSPACE (Iunit) +25 RETURN + END + + + +!C************************************************************************* +!C +!C TOOLBOX LIBRARY v.1.0 (May 1995) +!C +!C Program unit : SUBROUTINE APPENDEXT +!C Purpose : Fix extension in file name string +!C +!C ======================= ARGUMENTS / USAGE ============================= +!C +!C Filename is the CHARACTER variable with the file name +!C Defext is the CHARACTER variable with extension (including '.', +!C ex. '.DAT') +!C Overwrite is a LOGICAL value, .TRUE. overwrites any existing extension +!C in "Filename" with "Defext", .FALSE. puts "Defext" only if +!C there is no extension in "Filename". +!C +!C EXAMPLE: +!C FILENAME1 = 'TEST.DAT' +!C FILENAME2 = 'TEST.DAT' +!C CALL APPENDEXT (FILENAME1, '.TXT', .FALSE.) +!C CALL APPENDEXT (FILENAME2, '.TXT', .TRUE. ) +!C +!C after execution of this code segment, "FILENAME1" has the value +!C 'TEST.DAT', while "FILENAME2" has the value 'TEST.TXT' +!C +!C*********************************************************************** +!C + SUBROUTINE Appendext (Filename, Defext, Overwrite) +!C +!C*********************************************************************** + CHARACTER*(*) Filename, Defext + LOGICAL Overwrite +! + CALL CHRBLN (Filename, Iend) + IF (Filename(1:1).EQ.' ' .AND. Iend.EQ.1) RETURN ! Filename empty + Idot = INDEX (Filename, '.') ! Append extension ? + IF (Idot.EQ.0) Filename = Filename(1:Iend)//Defext + IF (Overwrite .AND. Idot.NE.0) & + Filename = Filename(:Idot-1)//Defext + RETURN + END + + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE POLY3 +! *** FINDS THE REAL ROOTS OF THE THIRD ORDER ALGEBRAIC EQUATION: +! X**3 + A1*X**2 + A2*X + A3 = 0.0 +! THE EQUATION IS SOLVED ANALYTICALLY. +! +! PARAMETERS A1, A2, A3 ARE SPECIFIED BY THE USER. THE MINIMUM +! NONEGATIVE ROOT IS RETURNED IN VARIABLE 'ROOT'. IF NO ROOT IS +! FOUND (WHICH IS GREATER THAN ZERO), ROOT HAS THE VALUE 1D30. +! AND THE FLAG ISLV HAS A VALUE GREATER THAN ZERO. +! +! SOLUTION FORMULA IS FOUND IN PAGE 32 OF: +! MATHEMATICAL HANDBOOK OF FORMULAS AND TABLES +! SCHAUM'S OUTLINE SERIES +! MURRAY SPIEGER, McGRAW-HILL, NEW YORK, 1968 +! (GREEK TRANSLATION: BY SOTIRIOS PERSIDES, ESPI, ATHENS, 1976) +! +! A SPECIAL CASE IS CONSIDERED SEPERATELY ; WHEN A3 = 0, THEN +! ONE ROOT IS X=0.0, AND THE OTHER TWO FROM THE SOLUTION OF THE +! QUADRATIC EQUATION X**2 + A1*X + A2 = 0.0 +! THIS SPECIAL CASE IS CONSIDERED BECAUSE THE ANALYTICAL FORMULA +! DOES NOT YIELD ACCURATE RESULTS (DUE TO NUMERICAL ROUNDOFF ERRORS) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE POLY3 (A1, A2, A3, ROOT, ISLV) +! + IMPLICIT DOUBLE PRECISION (A-H, O-Z) + PARAMETER (EXPON=1.D0/3.D0, ZERO=0.D0, THET1=120.D0/180.D0, & + THET2=240.D0/180.D0, PI=3.14159265358932, EPS=1D-50) + DOUBLE PRECISION X(3) +! +! *** SPECIAL CASE : QUADRATIC*X EQUATION ***************************** +! + IF (ABS(A3).LE.EPS) THEN + ISLV = 1 + IX = 1 + X(1) = ZERO + D = A1*A1-4.D0*A2 + IF (D.GE.ZERO) THEN + IX = 3 + SQD = SQRT(D) + X(2) = 0.5*(-A1+SQD) + X(3) = 0.5*(-A1-SQD) + ENDIF + ELSE +! +! *** NORMAL CASE : CUBIC EQUATION ************************************ +! +! DEFINE PARAMETERS Q, R, S, T, D +! + ISLV= 1 + Q = (3.D0*A2 - A1*A1)/9.D0 + R = (9.D0*A1*A2 - 27.D0*A3 - 2.D0*A1*A1*A1)/54.D0 + D = Q*Q*Q + R*R +! +! *** CALCULATE ROOTS ************************************************* +! +! D < 0, THREE REAL ROOTS +! + IF (D.LT.-EPS) THEN ! D < -EPS : D < ZERO + IX = 3 + THET = EXPON*ACOS(R/SQRT(-Q*Q*Q)) + COEF = 2.D0*SQRT(-Q) + X(1) = COEF*COS(THET) - EXPON*A1 + X(2) = COEF*COS(THET + THET1*PI) - EXPON*A1 + X(3) = COEF*COS(THET + THET2*PI) - EXPON*A1 +! +! D = 0, THREE REAL (ONE DOUBLE) ROOTS +! + ELSE IF (D.LE.EPS) THEN ! -EPS <= D <= EPS : D = ZERO + IX = 2 + SSIG = SIGN (1.D0, R) + S = SSIG*(ABS(R))**EXPON + X(1) = 2.D0*S - EXPON*A1 + X(2) = -S - EXPON*A1 +! +! D > 0, ONE REAL ROOT +! + ELSE ! D > EPS : D > ZERO + IX = 1 + SQD = SQRT(D) + SSIG = SIGN (1.D0, R+SQD) ! TRANSFER SIGN TO SSIG + TSIG = SIGN (1.D0, R-SQD) + S = SSIG*(ABS(R+SQD))**EXPON ! EXPONENTIATE ABS() + T = TSIG*(ABS(R-SQD))**EXPON + X(1) = S + T - EXPON*A1 + ENDIF + ENDIF +! +! *** SELECT APPROPRIATE ROOT ***************************************** +! + ROOT = 1.D30 + DO 10 I=1,IX + IF (X(I).GT.ZERO) THEN + ROOT = MIN (ROOT, X(I)) + ISLV = 0 + ENDIF +10 CONTINUE +! +! *** END OF SUBROUTINE POLY3 ***************************************** +! + RETURN + END + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE POLY3B +! *** FINDS A REAL ROOT OF THE THIRD ORDER ALGEBRAIC EQUATION: +! X**3 + A1*X**2 + A2*X + A3 = 0.0 +! THE EQUATION IS SOLVED NUMERICALLY (BISECTION). +! +! PARAMETERS A1, A2, A3 ARE SPECIFIED BY THE USER. THE MINIMUM +! NONEGATIVE ROOT IS RETURNED IN VARIABLE 'ROOT'. IF NO ROOT IS +! FOUND (WHICH IS GREATER THAN ZERO), ROOT HAS THE VALUE 1D30. +! AND THE FLAG ISLV HAS A VALUE GREATER THAN ZERO. +! +! RTLW, RTHI DEFINE THE INTERVAL WHICH THE ROOT IS LOOKED FOR. +! +!======================================================================= +! + SUBROUTINE POLY3B (A1, A2, A3, RTLW, RTHI, ROOT, ISLV) +! + IMPLICIT DOUBLE PRECISION (A-H, O-Z) + PARAMETER (ZERO=0.D0, EPS=1D-15, MAXIT=100, NDIV=5) +! + FUNC(X) = X**3.d0 + A1*X**2.0 + A2*X + A3 +! +! *** INITIAL VALUES FOR BISECTION ************************************* +! + X1 = RTLW + Y1 = FUNC(X1) + IF (ABS(Y1).LE.EPS) THEN ! Is low a root? + ROOT = RTLW + GOTO 50 + ENDIF +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO *********************** +! + DX = (RTHI-RTLW)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNC (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2) .LT. ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION FOUND +! + IF (ABS(Y2) .LT. EPS) THEN ! X2 is a root + ROOT = X2 + ELSE + ROOT = 1.d30 + ISLV = 1 + ENDIF + GOTO 50 +! +! *** BISECTION ******************************************************* +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNC (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE +! +! *** CONVERGED ; RETURN *********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNC (X3) + ROOT = X3 + ISLV = 0 +! +50 RETURN +! +! *** END OF SUBROUTINE POLY3B ***************************************** +! + END + + + +!cc PROGRAM DRIVER +!cc DOUBLE PRECISION ROOT +!ccC +!cc CALL POLY3 (-1.d0, 1.d0, -1.d0, ROOT, ISLV) +!cc IF (ISLV.NE.0) STOP 'Error in POLY3' +!cc WRITE (*,*) 'Root=', ROOT +!ccC +!cc CALL POLY3B (-1.d0, 1.d0, -1.d0, -10.d0, 10.d0, ROOT, ISLV) +!cc IF (ISLV.NE.0) STOP 'Error in POLY3B' +!cc WRITE (*,*) 'Root=', ROOT +!ccC +!cc END +!======================================================================= +! +! *** ISORROPIA CODE +! *** FUNCTION EX10 +! *** 10^X FUNCTION ; ALTERNATE OF LIBRARY ROUTINE ; USED BECAUSE IT IS +! MUCH FASTER BUT WITHOUT GREAT LOSS IN ACCURACY. , +! MAXIMUM ERROR IS 2%, EXECUTION TIME IS 42% OF THE LIBRARY ROUTINE +! (ON A 80286/80287 MACHINE, using Lahey FORTRAN 77 v.3.0). +! +! EXPONENT RANGE IS BETWEEN -K AND K (K IS THE REAL ARGUMENT 'K') +! MAX VALUE FOR K: 9.999 +! IF X < -K, X IS SET TO -K, IF X > K, X IS SET TO K +! +! THE EXPONENT IS CALCULATED BY THE PRODUCT ADEC*AINT, WHERE ADEC +! IS THE MANTISSA AND AINT IS THE MAGNITUDE (EXPONENT). BOTH +! MANTISSA AND MAGNITUDE ARE PRE-CALCULATED AND STORED IN LOOKUP +! TABLES ; THIS LEADS TO THE INCREASED SPEED. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + FUNCTION EX10(X,K) + USE EXPNC + REAL X, EX10, Y , K + INTEGER K1, K2 +! COMMON /EXPNC/ AINT10(20), ADEC10(200) +! +! *** LIMIT X TO [-K, K] RANGE ***************************************** +! + Y = MAX(-K, MIN(X,K)) ! MIN: -9.999, MAX: 9.999 +! +! *** GET INTEGER AND DECIMAL PART ************************************* +! + K1 = INT(Y) + K2 = INT(100*(Y-K1)) +! +! *** CALCULATE EXP FUNCTION ******************************************* +! + EX10 = AINT10(K1+10)*ADEC10(K2+100) +! +! *** END OF EXP FUNCTION ********************************************** +! + RETURN + END + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** BLOCK DATA EXPON +! *** CONTAINS DATA FOR EXPONENT ARRAYS NEEDED IN FUNCTION EXP10 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + BLOCK DATA EXPON +! +! *** Common block definition +! + USE EXPNC +! REAL AINT10, ADEC10 +! COMMON /EXPNC/ AINT10(20), ADEC10(200) +! +! *** Integer part +! +! DATA AINT10/ & +! 0.1000E-08, 0.1000E-07, 0.1000E-06, 0.1000E-05, 0.1000E-04, & +! 0.1000E-03, 0.1000E-02, 0.1000E-01, 0.1000E+00, 0.1000E+01, & +! 0.1000E+02, 0.1000E+03, 0.1000E+04, 0.1000E+05, 0.1000E+06, & +! 0.1000E+07, 0.1000E+08, 0.1000E+09, 0.1000E+10, 0.1000E+11 & +! / +! +! *** decimal part +! +! DATA (ADEC10(I),I=1,100)/ & +! 0.1023E+00, 0.1047E+00, 0.1072E+00, 0.1096E+00, 0.1122E+00, & +! 0.1148E+00, 0.1175E+00, 0.1202E+00, 0.1230E+00, 0.1259E+00, & +! 0.1288E+00, 0.1318E+00, 0.1349E+00, 0.1380E+00, 0.1413E+00, & +! 0.1445E+00, 0.1479E+00, 0.1514E+00, 0.1549E+00, 0.1585E+00, & +! 0.1622E+00, 0.1660E+00, 0.1698E+00, 0.1738E+00, 0.1778E+00, & +! 0.1820E+00, 0.1862E+00, 0.1905E+00, 0.1950E+00, 0.1995E+00, & +! 0.2042E+00, 0.2089E+00, 0.2138E+00, 0.2188E+00, 0.2239E+00, & +! 0.2291E+00, 0.2344E+00, 0.2399E+00, 0.2455E+00, 0.2512E+00, & +! 0.2570E+00, 0.2630E+00, 0.2692E+00, 0.2754E+00, 0.2818E+00, & +! 0.2884E+00, 0.2951E+00, 0.3020E+00, 0.3090E+00, 0.3162E+00, & +! 0.3236E+00, 0.3311E+00, 0.3388E+00, 0.3467E+00, 0.3548E+00, & +! 0.3631E+00, 0.3715E+00, 0.3802E+00, 0.3890E+00, 0.3981E+00, & +! 0.4074E+00, 0.4169E+00, 0.4266E+00, 0.4365E+00, 0.4467E+00, & +! 0.4571E+00, 0.4677E+00, 0.4786E+00, 0.4898E+00, 0.5012E+00, & +! 0.5129E+00, 0.5248E+00, 0.5370E+00, 0.5495E+00, 0.5623E+00, & +! 0.5754E+00, 0.5888E+00, 0.6026E+00, 0.6166E+00, 0.6310E+00, & +! 0.6457E+00, 0.6607E+00, 0.6761E+00, 0.6918E+00, 0.7079E+00, & +! 0.7244E+00, 0.7413E+00, 0.7586E+00, 0.7762E+00, 0.7943E+00, & +! 0.8128E+00, 0.8318E+00, 0.8511E+00, 0.8710E+00, 0.8913E+00, & +! 0.9120E+00, 0.9333E+00, 0.9550E+00, 0.9772E+00, 0.1000E+01/ +! +! DATA (ADEC10(I),I=101,200)/ & +! 0.1023E+01, 0.1047E+01, 0.1072E+01, 0.1096E+01, 0.1122E+01, & +! 0.1148E+01, 0.1175E+01, 0.1202E+01, 0.1230E+01, 0.1259E+01, & +! 0.1288E+01, 0.1318E+01, 0.1349E+01, 0.1380E+01, 0.1413E+01, & +! 0.1445E+01, 0.1479E+01, 0.1514E+01, 0.1549E+01, 0.1585E+01, & +! 0.1622E+01, 0.1660E+01, 0.1698E+01, 0.1738E+01, 0.1778E+01, & +! 0.1820E+01, 0.1862E+01, 0.1905E+01, 0.1950E+01, 0.1995E+01, & +! 0.2042E+01, 0.2089E+01, 0.2138E+01, 0.2188E+01, 0.2239E+01, & +! 0.2291E+01, 0.2344E+01, 0.2399E+01, 0.2455E+01, 0.2512E+01, & +! 0.2570E+01, 0.2630E+01, 0.2692E+01, 0.2754E+01, 0.2818E+01, & +! 0.2884E+01, 0.2951E+01, 0.3020E+01, 0.3090E+01, 0.3162E+01, & +! 0.3236E+01, 0.3311E+01, 0.3388E+01, 0.3467E+01, 0.3548E+01, & +! 0.3631E+01, 0.3715E+01, 0.3802E+01, 0.3890E+01, 0.3981E+01, & +! 0.4074E+01, 0.4169E+01, 0.4266E+01, 0.4365E+01, 0.4467E+01, & +! 0.4571E+01, 0.4677E+01, 0.4786E+01, 0.4898E+01, 0.5012E+01, & +! 0.5129E+01, 0.5248E+01, 0.5370E+01, 0.5495E+01, 0.5623E+01, & +! 0.5754E+01, 0.5888E+01, 0.6026E+01, 0.6166E+01, 0.6310E+01, & +! 0.6457E+01, 0.6607E+01, 0.6761E+01, 0.6918E+01, 0.7079E+01, & +! 0.7244E+01, 0.7413E+01, 0.7586E+01, 0.7762E+01, 0.7943E+01, & +! 0.8128E+01, 0.8318E+01, 0.8511E+01, 0.8710E+01, 0.8913E+01, & +! 0.9120E+01, 0.9333E+01, 0.9550E+01, 0.9772E+01, 0.1000E+02 & +! / +! +! *** END OF BLOCK DATA EXPON ****************************************** +! + END +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISOPLUS +! *** THIS SUBROUTINE IS THE MASTER ROUTINE FOR THE ISORROPIA-PLUS +! THERMODYNAMIC EQUILIBRIUM AEROSOL MODEL (VERSION 1.0) +! +! *** NOTE: THIS SUBROUTINE IS INCLUDED FOR BACKWARD COMPATABILITY ONLY. +! A PROGRAMMER SHOULD USE THE MORE COMPLETE SUBROUTINE ISOROPIA INSTEAD +! +! ======================== ARGUMENTS / USAGE =========================== +! +! INPUT: +! 1. [WI] +! DOUBLE PRECISION array of length [5]. +! Concentrations, expressed in moles/m3. Depending on the type of +! problem solved, WI contains either GAS+AEROSOL or AEROSOL only +! concentratios. +! WI(1) - sodium +! WI(2) - sulfate +! WI(3) - ammonium +! WI(4) - nitrate +! WI(5) - chloride +! +! 2. [RHI] +! DOUBLE PRECISION variable. +! Ambient relative humidity expressed in a (0,1) scale. +! +! 3. [TEMPI] +! DOUBLE PRECISION variable. +! Ambient temperature expressed in Kelvins. +! +! 4. [IPROB] +! INTEGER variable. +! The type of problem solved. +! IPROB = 0 - Forward problem is solved. In this case, array WI +! contains GAS and AEROSOL concentrations together. +! IPROB = 1 - Reverse problem is solved. In this case, array WI +! contains AEROSOL concentrations only. +! +! OUTPUT: +! 1. [GAS] +! DOUBLE PRECISION array of length [03]. +! Gaseous species concentrations, expressed in moles/m3. +! GAS(1) - NH3 +! GAS(2) - HNO3 +! GAS(3) - HCl +! +! 2. [AERLIQ] +! DOUBLE PRECISION array of length [11]. +! Liquid aerosol species concentrations, expressed in moles/m3. +! AERLIQ(01) - H+(aq) +! AERLIQ(02) - Na+(aq) +! AERLIQ(03) - NH4+(aq) +! AERLIQ(04) - Cl-(aq) +! AERLIQ(05) - SO4--(aq) +! AERLIQ(06) - HSO4-(aq) +! AERLIQ(07) - NO3-(aq) +! AERLIQ(08) - H2O +! AERLIQ(09) - NH3(aq) (undissociated) +! AERLIQ(10) - HNCl(aq) (undissociated) +! AERLIQ(11) - HNO3(aq) (undissociated) +! +! 3. [AERSLD] +! DOUBLE PRECISION array of length [09]. +! Solid aerosol species concentrations, expressed in moles/m3. +! AERSLD(01) - NaNO3(s) +! AERSLD(02) - NH4NO3(s) +! AERSLD(03) - NaCl(s) +! AERSLD(04) - NH4Cl(s) +! AERSLD(05) - Na2SO4(s) +! AERSLD(06) - (NH4)2SO4(s) +! AERSLD(07) - NaHSO4(s) +! AERSLD(08) - NH4HSO4(s) +! AERSLD(09) - (NH4)4H(SO4)2(s) +! +! 4. [DRY] +! LOGICAL variable. +! Contains information about the physical state of the system. +! .TRUE. - There is no aqueous phase present +! .FALSE.- There is an aqueous phase present +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE ISOPLUS (WI, RHI, TEMPI, IPROBI, & + GAS, AERLIQ, AERSLD, DRYI ) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DIMENSION WI(NCOMP), GAS(NGASAQ), AERLIQ(NIONS+NGASAQ+1), & + AERSLD(NSLDS) + LOGICAL DRYI +! +! *** PROBLEM TYPE (0=FOREWARD, 1=REVERSE) ****************************** +! + IPROB = IPROBI +! +! *** SOLVE FOREWARD PROBLEM ******************************************** +! + IF (IPROB.EQ.0) THEN + IF (WI(1)+WI(2)+WI(3)+WI(4)+WI(5) .LE. TINY) THEN ! Everything=0 + CALL INIT1 (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(4)+WI(5) .LE. TINY) THEN ! Na,Cl,NO3=0 + CALL ISRP1F (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(5) .LE. TINY) THEN ! Na,Cl=0 + CALL ISRP2F (WI, RHI, TEMPI) + ELSE + CALL ISRP3F (WI, RHI, TEMPI) + ENDIF +! +! *** SOLVE REVERSE PROBLEM ********************************************* +! + ELSE + IF (WI(1)+WI(2)+WI(3)+WI(4)+WI(5) .LE. TINY) THEN ! Everything=0 + CALL INIT1 (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(4)+WI(5) .LE. TINY) THEN ! Na,Cl,NO3=0 + CALL ISRP1R (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(5) .LE. TINY) THEN ! Na,Cl=0 + CALL ISRP2R (WI, RHI, TEMPI) + ELSE + CALL ISRP3R (WI, RHI, TEMPI) + ENDIF + ENDIF +! +! *** SAVE RESULTS TO ARRAYS (units = mole/m3, kg/m3 for water) ********* +! + GAS(1) = GNH3 + GAS(2) = GHNO3 + GAS(3) = GHCL +! + DO 10 I=1,NIONS + AERLIQ(I) = MOLAL(I) + 10 CONTINUE + AERLIQ(NIONS+1) = WATER*1.0D3/18.0D0 + DO 20 I=1,NGASAQ + AERLIQ(NIONS+1+I) = GASAQ(I) + 20 CONTINUE +! + AERSLD(1) = CNANO3 + AERSLD(2) = CNH4NO3 + AERSLD(3) = CNACL + AERSLD(4) = CNH4CL + AERSLD(5) = CNA2SO4 + AERSLD(6) = CNH42S4 + AERSLD(7) = CNAHSO4 + AERSLD(8) = CNH4HS4 + AERSLD(9) = CLC +! + DRYI = WATER.LE.TINY +! + RETURN +! +! *** END OF SUBROUTINE ISOPLUS ****************************************** +! + END + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISRPIA +! *** THIS SUBROUTINE IS THE MASTER ROUTINE FOR THE ISORROPIA-PLUS +! THERMODYNAMIC EQUILIBRIUM AEROSOL MODEL (VERSIONS 0.x) +! +! *** NOTE: THIS SUBROUTINE IS INCLUDED FOR BACKWARD COMPATABILITY ONLY. +! A PROGRAMMER SHOULD USE THE MORE COMPLETE SUBROUTINE ISOROPIA INSTEAD +! +! +! DEPENDING ON THE INPUT VALUES PROVIDED, THE FOLLOWING MODEL +! SUBVERSIONS ARE CALLED: +! +! FOREWARD PROBLEM (IPROB=0): +! Na SO4 NH4 NO3 CL SUBROUTINE CALLED +! ---- ---- ---- ---- ---- ----------------- +! 0.0 >0.0 >0.0 0.0 0.0 SUBROUTINE ISRP1F +! 0.0 >0.0 >0.0 >0.0 0.0 SUBROUTINE ISRP2F +! >0.0 >0.0 >0.0 >0.0 >0.0 SUBROUTINE ISRP3F +! +! REVERSE PROBLEM (IPROB=1): +! Na SO4 NH4 NO3 CL SUBROUTINE CALLED +! ---- ---- ---- ---- ---- ----------------- +! 0.0 >0.0 >0.0 0.0 0.0 SUBROUTINE ISRP1R +! 0.0 >0.0 >0.0 >0.0 0.0 SUBROUTINE ISRP2R +! >0.0 >0.0 >0.0 >0.0 >0.0 SUBROUTINE ISRP3R +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! +! SUBROUTINE ISRPIA (WI, RHI, TEMPI, IPROBI) + SUBROUTINE ISRPIAA (WI, RHI, TEMPI, IPROBI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DIMENSION WI(NCOMP) +! +! *** PROBLEM TYPE (0=FOREWARD, 1=REVERSE) ****************************** +! + IPROB = IPROBI +! +! *** SOLVE FOREWARD PROBLEM ******************************************** +! + IF (IPROB.EQ.0) THEN + IF (WI(1)+WI(2)+WI(3)+WI(4)+WI(5) .LE. TINY) THEN ! Everything=0 + CALL INIT1 (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(4)+WI(5) .LE. TINY) THEN ! Na,Cl,NO3=0 + CALL ISRP1F (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(5) .LE. TINY) THEN ! Na,Cl=0 + CALL ISRP2F (WI, RHI, TEMPI) + ELSE + CALL ISRP3F (WI, RHI, TEMPI) + ENDIF +! +! *** SOLVE REVERSE PROBLEM ********************************************* +! + ELSE + IF (WI(1)+WI(2)+WI(3)+WI(4)+WI(5) .LE. TINY) THEN ! Everything=0 + CALL INIT1 (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(4)+WI(5) .LE. TINY) THEN ! Na,Cl,NO3=0 + CALL ISRP1R (WI, RHI, TEMPI) + ELSE IF (WI(1)+WI(5) .LE. TINY) THEN ! Na,Cl=0 + CALL ISRP2R (WI, RHI, TEMPI) + ELSE + CALL ISRP3R (WI, RHI, TEMPI) + ENDIF + ENDIF +! +! *** SETUP 'DRY' FLAG *************************************************** +! + DRYF = WATER.LE.TINY +! +! *** FIND TOTALS ******************************************************* +! + IF (IPROB.EQ.0) THEN + CONTINUE + ELSE + W(1) = WAER(1) + W(2) = WAER(2) + W(3) = WAER(3) + W(4) = WAER(4) + W(5) = WAER(5) +! + IF (.NOT.DRYF) THEN + W(3) = W(3) + GNH3 + W(4) = W(4) + GHNO3 + W(5) = W(5) + GHCL + ENDIF + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE ISRPIA ******************************************* +! + END +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE PUSHERR +! *** THIS SUBROUTINE SAVES AN ERROR MESSAGE IN THE ERROR STACK +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE PUSHERR (IERR,ERRINF) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + CHARACTER ERRINF*(*) +! +! *** SAVE ERROR CODE IF THERE IS ANY SPACE *************************** +! + IF (NOFER.LT.NERRMX) THEN + NOFER = NOFER + 1 + ERRSTK(NOFER) = IERR + ERRMSG(NOFER) = ERRINF + STKOFL =.FALSE. + ELSE + STKOFL =.TRUE. ! STACK OVERFLOW + ENDIF +! +! *** END OF SUBROUTINE PUSHERR **************************************** +! + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISERRINF +! *** THIS SUBROUTINE OBTAINS A COPY OF THE ERROR STACK (& MESSAGES) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE ISERRINF (ERRSTKI, ERRMSGI, NOFERI, STKOFLI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + CHARACTER ERRMSGI*40 + INTEGER ERRSTKI + LOGICAL STKOFLI + DIMENSION ERRMSGI(NERRMX), ERRSTKI(NERRMX) +! +! *** OBTAIN WHOLE ERROR STACK **************************************** +! + DO 10 I=1,NOFER ! Error messages & codes + ERRSTKI(I) = ERRSTK(I) + ERRMSGI(I) = ERRMSG(I) + 10 CONTINUE +! + STKOFLI = STKOFL + NOFERI = NOFER +! + RETURN +! +! *** END OF SUBROUTINE ISERRINF *************************************** +! + END + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ERRSTAT +! *** THIS SUBROUTINE REPORTS ERROR MESSAGES TO UNIT 'IO' +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE ERRSTAT (IO,IERR,ERRINF) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + CHARACTER CER*4, NCIS*29, NCIF*27, NSIS*26, NSIF*24, ERRINF*(*) + DATA NCIS /'NO CONVERGENCE IN SUBROUTINE '/, & + NCIF /'NO CONVERGENCE IN FUNCTION ' /, & + NSIS /'NO SOLUTION IN SUBROUTINE ' /, & + NSIF /'NO SOLUTION IN FUNCTION ' / +! +! *** WRITE ERROR IN CHARACTER ***************************************** +! + WRITE (CER,'(I4)') IERR + CALL RPLSTR (CER, ' ', '0',IOK) ! REPLACE BLANKS WITH ZEROS + CALL CHRBLN (ERRINF, IEND) ! LAST POSITION OF ERRINF CHAR +! +! *** WRITE ERROR TYPE (FATAL, WARNING ) ******************************* +! + IF (IERR.EQ.0) THEN + WRITE (IO,1000) 'NO ERRORS DETECTED ' + GOTO 10 +! + ELSE IF (IERR.LT.0) THEN + WRITE (IO,1000) 'ERROR STACK EXHAUSTED ' + GOTO 10 +! + ELSE IF (IERR.GT.1000) THEN + WRITE (IO,1100) 'FATAL',CER +! + ELSE + WRITE (IO,1100) 'WARNING',CER + ENDIF +! +! *** WRITE ERROR MESSAGE ********************************************** +! +! FATAL MESSAGES +! + IF (IERR.EQ.1001) THEN + CALL CHRBLN (SCASE, IEND) + WRITE (IO,1000) 'CASE NOT SUPPORTED IN CALCMR ['//SCASE(1:IEND) & + //']' +! + ELSEIF (IERR.EQ.1002) THEN + CALL CHRBLN (SCASE, IEND) + WRITE (IO,1000) 'CASE NOT SUPPORTED ['//SCASE(1:IEND)//']' +! +! WARNING MESSAGES +! + ELSEIF (IERR.EQ.0001) THEN + WRITE (IO,1000) NSIS,ERRINF +! + ELSEIF (IERR.EQ.0002) THEN + WRITE (IO,1000) NCIS,ERRINF +! + ELSEIF (IERR.EQ.0003) THEN + WRITE (IO,1000) NSIF,ERRINF +! + ELSEIF (IERR.EQ.0004) THEN + WRITE (IO,1000) NCIF,ERRINF +! + ELSE IF (IERR.EQ.0019) THEN + WRITE (IO,1000) 'HNO3(aq) AFFECTS H+, WHICH '// & + 'MIGHT AFFECT SO4/HSO4 RATIO' + WRITE (IO,1000) 'DIRECT INCREASE IN H+ [',ERRINF(1:IEND),'] %' +! + ELSE IF (IERR.EQ.0020) THEN + IF (W(4).GT.TINY .AND. W(5).GT.TINY) THEN + WRITE (IO,1000) 'HSO4-SO4 EQUILIBRIUM MIGHT AFFECT HNO3,' & + //'HCL DISSOLUTION' + ELSE + WRITE (IO,1000) 'HSO4-SO4 EQUILIBRIUM MIGHT AFFECT NH3 ' & + //'DISSOLUTION' + ENDIF + WRITE (IO,1000) 'DIRECT DECREASE IN H+ [',ERRINF(1:IEND),'] %' +! + ELSE IF (IERR.EQ.0021) THEN + WRITE (IO,1000) 'HNO3(aq),HCL(aq) AFFECT H+, WHICH '// & + 'MIGHT AFFECT SO4/HSO4 RATIO' + WRITE (IO,1000) 'DIRECT INCREASE IN H+ [',ERRINF(1:IEND),'] %' +! + ELSE IF (IERR.EQ.0022) THEN + WRITE (IO,1000) 'HCL(g) EQUILIBRIUM YIELDS NONPHYSICAL '// & + 'DISSOLUTION' + WRITE (IO,1000) 'A TINY AMOUNT [',ERRINF(1:IEND),'] IS '// & + 'ASSUMED TO BE DISSOLVED' +! + ELSEIF (IERR.EQ.0033) THEN + WRITE (IO,1000) 'HCL(aq) AFFECTS H+, WHICH '// & + 'MIGHT AFFECT SO4/HSO4 RATIO' + WRITE (IO,1000) 'DIRECT INCREASE IN H+ [',ERRINF(1:IEND),'] %' +! + ELSEIF (IERR.EQ.0050) THEN + WRITE (IO,1000) 'TOO MUCH SODIUM GIVEN AS INPUT.' + WRITE (IO,1000) 'REDUCED TO COMPLETELY NEUTRALIZE SO4,Cl,NO3.' + WRITE (IO,1000) 'EXCESS SODIUM IS IGNORED.' +! + ELSE + WRITE (IO,1000) 'NO DIAGNOSTIC MESSAGE AVAILABLE' + ENDIF +! +10 RETURN +! +! *** FORMAT STATEMENTS ************************************* +! +1000 FORMAT (1X,A:A:A:A:A) +1100 FORMAT (1X,A,' ERROR [',A4,']:') +! +! *** END OF SUBROUTINE ERRSTAT ***************************** +! + END +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISORINF +! *** THIS SUBROUTINE PROVIDES INFORMATION ABOUT ISORROPIA +! +! ======================== ARGUMENTS / USAGE =========================== +! +! OUTPUT: +! 1. [VERSI] +! CHARACTER*15 variable. +! Contains version-date information of ISORROPIA +! +! 2. [NCMP] +! INTEGER variable. +! The number of components needed in input array WI +! (or, the number of major species accounted for by ISORROPIA) +! +! 3. [NION] +! INTEGER variable +! The number of ions considered in the aqueous phase +! +! 4. [NAQGAS] +! INTEGER variable +! The number of undissociated species found in aqueous aerosol +! phase +! +! 5. [NSOL] +! INTEGER variable +! The number of solids considered in the solid aerosol phase +! +! 6. [NERR] +! INTEGER variable +! The size of the error stack (maximum number of errors that can +! be stored before the stack exhausts). +! +! 7. [TIN] +! DOUBLE PRECISION variable +! The value used for a very small number. +! +! 8. [GRT] +! DOUBLE PRECISION variable +! The value used for a very large number. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE ISORINF (VERSI, NCMP, NION, NAQGAS, NSOL, NERR, TIN, & + GRT) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + CHARACTER VERSI*(*) +! +! *** ASSIGN INFO ******************************************************* +! + VERSI = VERSION + NCMP = NCOMP + NION = NIONS + NAQGAS = NGASAQ + NSOL = NSLDS + NERR = NERRMX + TIN = TINY + GRT = GREAT +! + RETURN +! +! *** END OF SUBROUTINE ISORINF ******************************************* +! + END diff --git a/wrfv2_fire/chem/isofwd.F b/wrfv2_fire/chem/isofwd.F new file mode 100755 index 00000000..ae6b2db9 --- /dev/null +++ b/wrfv2_fire/chem/isofwd.F @@ -0,0 +1,6745 @@ +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISRP1F +! *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FOREWARD PROBLEM OF +! AN AMMONIUM-SULFATE AEROSOL SYSTEM. +! THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY +! THE AMBIENT RELATIVE HUMIDITY. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +! REVISION HISTORY: * +! Original code was provided by Dr. ATHANASIOS NENES, Georgia Tech, in 2000 +! Revised by Y. Zhang, AER, Inc. to incorporate v1.5 into MADRID, 2000 +! Revised by Y. Zhang and Xiao-Ming Hu to incorporate it along with MADRID into WRF/Chem, 2005 +! Updated by Xiao-Ming Hu and Y. Zhang, NCSU to v. 1.7, Oct., 2007 +!======================================================================= +! + SUBROUTINE ISRP1F (WI, RHI, TEMPI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DIMENSION WI(NCOMP) +! +! *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +! + CALL INIT1 (WI, RHI, TEMPI) +! +! *** CALCULATE SULFATE RATIO ******************************************* +! + SULRAT = W(3)/W(2) +! +! *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** +! +! *** SULFATE POOR +! + IF (2.0.LE.SULRAT) THEN + DC = W(3) - 2.001D0*W(2) ! For numerical stability + W(3) = W(3) + MAX(-DC, ZERO) +! + IF(METSTBL.EQ.1) THEN + SCASE = 'A2' + CALL CALCA2 ! Only liquid (metastable) + ELSE +! + IF (RH.LT.DRNH42S4) THEN + SCASE = 'A1' + CALL CALCA1 ! NH42SO4 ; case A1 +! + ELSEIF (DRNH42S4.LE.RH) THEN + SCASE = 'A2' + CALL CALCA2 ! Only liquid ; case A2 + ENDIF + ENDIF +! +! *** SULFATE RICH (NO ACID) +! + ELSEIF (1.0.LE.SULRAT .AND. SULRAT.LT.2.0) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'B4' + CALL CALCB4 ! Only liquid (metastable) + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'B1' + CALL CALCB1 ! NH4HSO4,LC,NH42SO4 ; case B1 +! + ELSEIF (DRNH4HS4.LE.RH .AND. RH.LT.DRLC) THEN + SCASE = 'B2' + CALL CALCB2 ! LC,NH42S4 ; case B2 +! + ELSEIF (DRLC.LE.RH .AND. RH.LT.DRNH42S4) THEN + SCASE = 'B3' + CALL CALCB3 ! NH42S4 ; case B3 +! + ELSEIF (DRNH42S4.LE.RH) THEN + SCASE = 'B4' + CALL CALCB4 ! Only liquid ; case B4 + ENDIF + ENDIF + CALL CALCNH3 +! +! *** SULFATE RICH (FREE ACID) +! + ELSEIF (SULRAT.LT.1.0) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'C2' + CALL CALCC2 ! Only liquid (metastable) + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'C1' + CALL CALCC1 ! NH4HSO4 ; case C1 +! + ELSEIF (DRNH4HS4.LE.RH) THEN + SCASE = 'C2' + CALL CALCC2 ! Only liquid ; case C2 +! + ENDIF + ENDIF + CALL CALCNH3 + ENDIF +! +! *** RETURN POINT +! + RETURN +! +! *** END OF SUBROUTINE ISRP1F ***************************************** +! + END SUBROUTINE ISRP1F +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISRP2F +! *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FOREWARD PROBLEM OF +! AN AMMONIUM-SULFATE-NITRATE AEROSOL SYSTEM. +! THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY +! THE AMBIENT RELATIVE HUMIDITY. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE ISRP2F (WI, RHI, TEMPI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DIMENSION WI(NCOMP) +! +! *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +! + CALL INIT2 (WI, RHI, TEMPI) +! +! *** CALCULATE SULFATE RATIO ******************************************* +! + SULRAT = W(3)/W(2) +! +! *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** +! +! *** SULFATE POOR +! + IF (2.0.LE.SULRAT) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'D3' + CALL CALCD3 ! Only liquid (metastable) + ELSE +! + IF (RH.LT.DRNH4NO3) THEN + SCASE = 'D1' + CALL CALCD1 ! NH42SO4,NH4NO3 ; case D1 +! + ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNH42S4) THEN + SCASE = 'D2' + CALL CALCD2 ! NH42S4 ; case D2 +! + ELSEIF (DRNH42S4.LE.RH) THEN + SCASE = 'D3' + CALL CALCD3 ! Only liquid ; case D3 + ENDIF + ENDIF +! +! *** SULFATE RICH (NO ACID) +! FOR SOLVING THIS CASE, NITRIC ACID IS ASSUMED A MINOR SPECIES, +! THAT DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM. +! SUBROUTINES CALCB? ARE CALLED, AND THEN THE NITRIC ACID IS DISSOLVED +! FROM THE HNO3(G) -> (H+) + (NO3-) EQUILIBRIUM. +! + ELSEIF (1.0.LE.SULRAT .AND. SULRAT.LT.2.0) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'B4' + CALL CALCB4 ! Only liquid (metastable) + SCASE = 'E4' + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'B1' + CALL CALCB1 ! NH4HSO4,LC,NH42SO4 ; case E1 + SCASE = 'E1' +! + ELSEIF (DRNH4HS4.LE.RH .AND. RH.LT.DRLC) THEN + SCASE = 'B2' + CALL CALCB2 ! LC,NH42S4 ; case E2 + SCASE = 'E2' +! + ELSEIF (DRLC.LE.RH .AND. RH.LT.DRNH42S4) THEN + SCASE = 'B3' + CALL CALCB3 ! NH42S4 ; case E3 + SCASE = 'E3' +! + ELSEIF (DRNH42S4.LE.RH) THEN + SCASE = 'B4' + CALL CALCB4 ! Only liquid ; case E4 + SCASE = 'E4' + ENDIF + ENDIF +! + CALL CALCNA ! HNO3(g) DISSOLUTION +! +! *** SULFATE RICH (FREE ACID) +! FOR SOLVING THIS CASE, NITRIC ACID IS ASSUMED A MINOR SPECIES, +! THAT DOES NOT SIGNIFICANTLY PERTURB THE HSO4-SO4 EQUILIBRIUM +! SUBROUTINE CALCC? IS CALLED, AND THEN THE NITRIC ACID IS DISSOLVED +! FROM THE HNO3(G) -> (H+) + (NO3-) EQUILIBRIUM. +! + ELSEIF (SULRAT.LT.1.0) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'C2' + CALL CALCC2 ! Only liquid (metastable) + SCASE = 'F2' + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'C1' + CALL CALCC1 ! NH4HSO4 ; case F1 + SCASE = 'F1' +! + ELSEIF (DRNH4HS4.LE.RH) THEN + SCASE = 'C2' + CALL CALCC2 ! Only liquid ; case F2 + SCASE = 'F2' + ENDIF + ENDIF +! + CALL CALCNA ! HNO3(g) DISSOLUTION + ENDIF +! +! *** RETURN POINT +! + RETURN +! +! *** END OF SUBROUTINE ISRP2F ***************************************** +! + END SUBROUTINE ISRP2F +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISRP3F +! *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE FORWARD PROBLEM OF +! AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +! THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE & SODIUM +! RATIOS AND BY THE AMBIENT RELATIVE HUMIDITY. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE ISRP3F (WI, RHI, TEMPI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DIMENSION WI(NCOMP) +! +! *** ADJUST FOR TOO LITTLE AMMONIUM AND CHLORIDE *********************** +! + WI(3) = MAX (WI(3), 1.D-10) ! NH4+ : 1e-4 umoles/m3 + WI(5) = MAX (WI(5), 1.D-10) ! Cl- : 1e-4 umoles/m3 +! +! *** ADJUST FOR TOO LITTLE SODIUM, SULFATE AND NITRATE COMBINED ******** +! + IF (WI(1)+WI(2)+WI(4) .LE. 1d-10) THEN + WI(1) = 1.D-10 ! Na+ : 1e-4 umoles/m3 + WI(2) = 1.D-10 ! SO4- : 1e-4 umoles/m3 + ENDIF +! +! *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +! + CALL ISOINIT3 (WI, RHI, TEMPI) +! +! *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE ********* +! + REST = 2.D0*W(2) + W(4) + W(5) + IF (W(1).GT.REST) THEN ! NA > 2*SO4+CL+NO3 ? + W(1) = (ONE-1D-6)*REST ! Adjust Na amount + CALL PUSHERR (0050, 'ISRP3F') ! Warning error: Na adjusted + ENDIF +! +! *** CALCULATE SULFATE & SODIUM RATIOS ********************************* +! + SULRAT = (W(1)+W(3))/W(2) + SODRAT = W(1)/W(2) +! +! *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** +! +! *** SULFATE POOR ; SODIUM POOR +! + IF (2.0.LE.SULRAT .AND. SODRAT.LT.2.0) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'G5' + CALL CALCG5 ! Only liquid (metastable) + ELSE +! + IF (RH.LT.DRNH4NO3) THEN + SCASE = 'G1' + CALL CALCG1 ! NH42SO4,NH4NO3,NH4CL,NA2SO4 +! + ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNH4CL) THEN + SCASE = 'G2' + CALL CALCG2 ! NH42SO4,NH4CL,NA2SO4 +! + ELSEIF (DRNH4CL.LE.RH .AND. RH.LT.DRNH42S4) THEN + SCASE = 'G3' + CALL CALCG3 ! NH42SO4,NA2SO4 +! + ELSEIF (DRNH42S4.LE.RH .AND. RH.LT.DRNA2SO4) THEN + SCASE = 'G4' + CALL CALCG4 ! NA2SO4 +! + ELSEIF (DRNA2SO4.LE.RH) THEN + SCASE = 'G5' + CALL CALCG5 ! Only liquid + ENDIF + ENDIF +! +! *** SULFATE POOR ; SODIUM RICH +! + ELSE IF (SULRAT.GE.2.0 .AND. SODRAT.GE.2.0) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'H6' + CALL CALCH6 ! Only liquid (metastable) + ELSE +! + IF (RH.LT.DRNH4NO3) THEN + SCASE = 'H1' + CALL CALCH1 ! NH4NO3,NH4CL,NA2SO4,NACL,NANO3 +! + ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNANO3) THEN + SCASE = 'H2' + CALL CALCH2 ! NH4CL,NA2SO4,NACL,NANO3 +! + ELSEIF (DRNANO3.LE.RH .AND. RH.LT.DRNACL) THEN + SCASE = 'H3' + CALL CALCH3 ! NH4CL,NA2SO4,NACL +! + ELSEIF (DRNACL.LE.RH .AND. RH.LT.DRNH4Cl) THEN + SCASE = 'H4' + CALL CALCH4 ! NH4CL,NA2SO4 +! + ELSEIF (DRNH4Cl.LE.RH .AND. RH.LT.DRNA2SO4) THEN + SCASE = 'H5' + CALL CALCH5 ! NA2SO4 +! + ELSEIF (DRNA2SO4.LE.RH) THEN + SCASE = 'H6' + CALL CALCH6 ! NO SOLID + ENDIF + ENDIF +! +! *** SULFATE RICH (NO ACID) +! + ELSEIF (1.0.LE.SULRAT .AND. SULRAT.LT.2.0) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'I6' + CALL CALCI6 ! Only liquid (metastable) + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'I1' + CALL CALCI1 ! NA2SO4,(NH4)2SO4,NAHSO4,NH4HSO4,LC +! + ELSEIF (DRNH4HS4.LE.RH .AND. RH.LT.DRNAHSO4) THEN + SCASE = 'I2' + CALL CALCI2 ! NA2SO4,(NH4)2SO4,NAHSO4,LC +! + ELSEIF (DRNAHSO4.LE.RH .AND. RH.LT.DRLC) THEN + SCASE = 'I3' + CALL CALCI3 ! NA2SO4,(NH4)2SO4,LC +! + ELSEIF (DRLC.LE.RH .AND. RH.LT.DRNH42S4) THEN + SCASE = 'I4' + CALL CALCI4 ! NA2SO4,(NH4)2SO4 +! + ELSEIF (DRNH42S4.LE.RH .AND. RH.LT.DRNA2SO4) THEN + SCASE = 'I5' + CALL CALCI5 ! NA2SO4 +! + ELSEIF (DRNA2SO4.LE.RH) THEN + SCASE = 'I6' + CALL CALCI6 ! NO SOLIDS + ENDIF + ENDIF +! + CALL CALCNHA ! MINOR SPECIES: HNO3, HCl + CALL CALCNH3 ! NH3 +! +! *** SULFATE RICH (FREE ACID) +! + ELSEIF (SULRAT.LT.1.0) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'J3' + CALL CALCJ3 ! Only liquid (metastable) + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'J1' + CALL CALCJ1 ! NH4HSO4,NAHSO4 +! + ELSEIF (DRNH4HS4.LE.RH .AND. RH.LT.DRNAHSO4) THEN + SCASE = 'J2' + CALL CALCJ2 ! NAHSO4 +! + ELSEIF (DRNAHSO4.LE.RH) THEN + SCASE = 'J3' + CALL CALCJ3 + ENDIF + ENDIF +! + CALL CALCNHA ! MINOR SPECIES: HNO3, HCl + CALL CALCNH3 ! NH3 + ENDIF +! +! *** RETURN POINT +! + RETURN +! +! *** END OF SUBROUTINE ISRP3F ***************************************** +! + END SUBROUTINE ISRP3F +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCA2 +! *** CASE A2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. LIQUID AEROSOL PHASE ONLY POSSIBLE +! +! FOR CALCULATIONS, A BISECTION IS PERFORMED TOWARDS X, THE +! AMOUNT OF HYDROGEN IONS (H+) FOUND IN THE LIQUID PHASE. +! FOR EACH ESTIMATION OF H+, FUNCTION FUNCB2A CALCULATES THE +! CONCENTRATION OF IONS FROM THE NH3(GAS) - NH4+(LIQ) EQUILIBRIUM. +! ELECTRONEUTRALITY IS USED AS THE OBJECTIVE FUNCTION. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCA2 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU =.TRUE. ! Outer loop activity calculation flag + OMELO = TINY ! Low limit: SOLUTION IS VERY BASIC + OMEHI = 2.0D0*W(2) ! High limit: FROM NH4+ -> NH3(g) + H+(aq) +! +! *** CALCULATE WATER CONTENT ***************************************** +! + MOLAL(5) = W(2) + MOLAL(6) = ZERO + CALL CALCMR +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = OMEHI + Y1 = FUNCA2 (X1) + IF (ABS(Y1).LE.EPS) RETURN +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (OMEHI-OMELO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = MAX(X1-DX, OMELO) + Y2 = FUNCA2 (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE + IF (ABS(Y2).LE.EPS) THEN + RETURN + ELSE + CALL PUSHERR (0001, 'CALCA2') ! WARNING ERROR: NO SOLUTION + RETURN + ENDIF +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCA2 (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCA2') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCA2 (X3) + RETURN +! +! *** END OF SUBROUTINE CALCA2 **************************************** +! + END SUBROUTINE CALCA2 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** FUNCTION FUNCA2 +! *** CASE A2 +! FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE A2 ; +! AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCA2. +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCA2 (OMEGI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION LAMDA +! +! *** SETUP PARAMETERS ************************************************ +! + FRST = .TRUE. + CALAIN = .TRUE. + PSI = W(2) ! INITIAL AMOUNT OF (NH4)2SO4 IN SOLUTION +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A1 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. + A2 = XK2*R*TEMP/XKW*(GAMA(8)/GAMA(9))**2. + A3 = XKW*RH*WATER*WATER +! + LAMDA = PSI/(A1/OMEGI+ONE) + ZETA = A3/OMEGI +! +! *** SPECIATION & WATER CONTENT *************************************** +! + MOLAL (1) = OMEGI ! HI + MOLAL (3) = W(3)/(ONE/A2/OMEGI + ONE) ! NH4I + MOLAL (5) = MAX(PSI-LAMDA,TINY) ! SO4I + MOLAL (6) = LAMDA ! HSO4I + GNH3 = MAX (W(3)-MOLAL(3), TINY) ! NH3GI + COH = ZETA ! OHI +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE OBJECTIVE FUNCTION ************************************ +! +20 DENOM = (2.0*MOLAL(5)+MOLAL(6)) + FUNCA2= (MOLAL(3)/DENOM - ONE) + MOLAL(1)/DENOM + RETURN +! +! *** END OF FUNCTION FUNCA2 ******************************************** +! + END FUNCTION FUNCA2 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCA1 +! *** CASE A1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : (NH4)2SO4 +! +! A SIMPLE MATERIAL BALANCE IS PERFORMED, AND THE SOLID (NH4)2SO4 +! IS CALCULATED FROM THE SULFATES. THE EXCESS AMMONIA REMAINS IN +! THE GAS PHASE. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCA1 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + CNH42S4 = W(2) + GNH3 = MAX (W(3)-2.0*CNH42S4, ZERO) + RETURN +! +! *** END OF SUBROUTINE CALCA1 ****************************************** +! + END SUBROUTINE CALCA1 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCB4 +! *** CASE B4 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. LIQUID AEROSOL PHASE ONLY POSSIBLE +! +! FOR CALCULATIONS, A BISECTION IS PERFORMED WITH RESPECT TO H+. +! THE OBJECTIVE FUNCTION IS THE DIFFERENCE BETWEEN THE ESTIMATED H+ +! AND THAT CALCULATED FROM ELECTRONEUTRALITY. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCB4 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** SOLVE EQUATIONS ************************************************** +! + FRST = .TRUE. + CALAIN = .TRUE. + CALAOU = .TRUE. +! +! *** CALCULATE WATER CONTENT ****************************************** +! + CALL CALCB1A ! GET DRY SALT CONTENT, AND USE FOR WATER. + MOLALR(13) = CLC + MOLALR(9) = CNH4HS4 + MOLALR(4) = CNH42S4 + CLC = ZERO + CNH4HS4 = ZERO + CNH42S4 = ZERO + WATER = MOLALR(13)/M0(13)+MOLALR(9)/M0(9)+MOLALR(4)/M0(4) +! + MOLAL(3) = W(3) ! NH4I +! + DO 20 I=1,NSWEEP + AK1 = XK1*((GAMA(8)/GAMA(7))**2.)*(WATER/GAMA(7)) + BET = W(2) + GAM = MOLAL(3) +! + BB = BET + AK1 - GAM + CC =-AK1*BET + DD = BB*BB - 4.D0*CC +! +! *** SPECIATION & WATER CONTENT *************************************** +! + MOLAL (5) = MAX(TINY,MIN(0.5*(-BB + SQRT(DD)), W(2))) ! SO4I + MOLAL (6) = MAX(TINY,MIN(W(2)-MOLAL(5),W(2))) ! HSO4I + MOLAL (1) = MAX(TINY,MIN(AK1*MOLAL(6)/MOLAL(5),W(2))) ! HI + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (.NOT.CALAIN) GOTO 30 + CALL CALCACT +20 CONTINUE +! +30 RETURN +! +! *** END OF SUBROUTINE CALCB4 ****************************************** +! + END SUBROUTINE CALCB4 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCB3 +! *** CASE B3 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. BOTH LIQUID & SOLID PHASE IS POSSIBLE +! 3. SOLIDS POSSIBLE: (NH4)2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCB3 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** CALCULATE EQUIVALENT AMOUNT OF HSO4 AND SO4 *********************** +! + X = MAX(2*W(2)-W(3), ZERO) ! Equivalent NH4HSO4 + Y = MAX(W(3) -W(2), ZERO) ! Equivalent NH42SO4 +! +! *** CALCULATE SPECIES ACCORDING TO RELATIVE ABUNDANCE OF HSO4 ********* +! + IF (X.LT.Y) THEN ! LC is the MIN (x,y) + SCASE = 'B3 ; SUBCASE 1' + TLC = X + TNH42S4 = Y-X + CALL CALCB3A (TLC,TNH42S4) ! LC + (NH4)2SO4 + ELSE + SCASE = 'B3 ; SUBCASE 2' + TLC = Y + TNH4HS4 = X-Y + CALL CALCB3B (TLC,TNH4HS4) ! LC + NH4HSO4 + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCB3 ****************************************** +! + END SUBROUTINE CALCB3 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCB3A +! *** CASE B3 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH (1.0 < SULRAT < 2.0) +! 2. BOTH LIQUID & SOLID PHASE IS POSSIBLE +! 3. SOLIDS POSSIBLE: (NH4)2SO4 +! +! FOR CALCULATIONS, A BISECTION IS PERFORMED TOWARDS ZETA, THE +! AMOUNT OF SOLID (NH4)2SO4 DISSOLVED IN THE LIQUID PHASE. +! FOR EACH ESTIMATION OF ZETA, FUNCTION FUNCB3A CALCULATES THE +! AMOUNT OF H+ PRODUCED (BASED ON THE SO4 RELEASED INTO THE +! SOLUTION). THE SOLUBILITY PRODUCT OF (NH4)2SO4 IS USED AS THE +! OBJECTIVE FUNCTION. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCB3A (TLC, TNH42S4) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + ZLO = ZERO ! MIN DISSOLVED (NH4)2SO4 + ZHI = TNH42S4 ! MAX DISSOLVED (NH4)2SO4 +! +! *** INITIAL VALUES FOR BISECTION (DISSOLVED (NH4)2SO4 **************** +! + Z1 = ZLO + Y1 = FUNCB3A (Z1, TLC, TNH42S4) + IF (ABS(Y1).LE.EPS) RETURN + YLO= Y1 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO *********************** +! + DZ = (ZHI-ZLO)/REAL(NDIV) + DO 10 I=1,NDIV + Z2 = Z1+DZ + Y2 = FUNCB3A (Z2, TLC, TNH42S4) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + Z1 = Z2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION FOUND +! + YHI= Y1 ! Save Y-value at HI position + IF (ABS(Y2) .LT. EPS) THEN ! X2 IS A SOLUTION + RETURN +! +! *** { YLO, YHI } < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH LC +! + ELSE IF (YLO.LT.ZERO .AND. YHI.LT.ZERO) THEN + Z1 = ZHI + Z2 = ZHI + GOTO 40 +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH LC +! + ELSE IF (YLO.GT.ZERO .AND. YHI.GT.ZERO) THEN + Z1 = ZLO + Z2 = ZLO + GOTO 40 + ELSE + CALL PUSHERR (0001, 'CALCB3A') ! WARNING ERROR: NO SOLUTION + RETURN + ENDIF +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + Z3 = 0.5*(Z1+Z2) + Y3 = FUNCB3A (Z3, TLC, TNH42S4) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + Z2 = Z3 + ELSE + Y1 = Y3 + Z1 = Z3 + ENDIF + IF (ABS(Z2-Z1) .LE. EPS*Z1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCB3A') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ************************************************ +! +40 ZK = 0.5*(Z1+Z2) + Y3 = FUNCB3A (ZK, TLC, TNH42S4) +! + RETURN +! +! *** END OF SUBROUTINE CALCB3A ****************************************** +! + END SUBROUTINE CALCB3A + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** FUNCTION FUNCB3A +! *** CASE B3 ; SUBCASE 1 +! FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE B3 +! AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCA3. +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCB3A (ZK, Y, X) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION KK +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + FRST = .TRUE. + CALAIN = .TRUE. + DO 20 I=1,NSWEEP + GRAT1 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. + DD = SQRT( (ZK+GRAT1+Y)**2. + 4.0*Y*GRAT1) + KK = 0.5*(-(ZK+GRAT1+Y) + DD ) +! +! *** SPECIATION & WATER CONTENT *************************************** +! + MOLAL (1) = KK ! HI + MOLAL (5) = KK+ZK+Y ! SO4I + MOLAL (6) = MAX (Y-KK, TINY) ! HSO4I + MOLAL (3) = 3.0*Y+2*ZK ! NH4I + CNH42S4 = X-ZK ! Solid (NH4)2SO4 + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 30 + ENDIF +20 CONTINUE +! +! *** CALCULATE OBJECTIVE FUNCTION ************************************ +! +!CC30 FUNCB3A= ( SO4I*NH4I**2.0 )/( XK7*(WATER/GAMA(4))**3.0 ) +30 FUNCB3A= MOLAL(5)*MOLAL(3)**2.0 + FUNCB3A= FUNCB3A/(XK7*(WATER/GAMA(4))**3.0) - ONE + RETURN +! +! *** END OF FUNCTION FUNCB3A ******************************************** +! + END FUNCTION FUNCB3A + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCB3B +! *** CASE B3 ; SUBCASE 2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH (1.0 < SULRAT < 2.0) +! 2. LIQUID PHASE ONLY IS POSSIBLE +! +! SPECIATION CALCULATIONS IS BASED ON THE HSO4 <--> SO4 EQUILIBRIUM. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCB3B (Y, X) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION KK +! + CALAOU = .FALSE. ! Outer loop activity calculation flag + FRST = .FALSE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 20 I=1,NSWEEP + GRAT1 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. + DD = SQRT( (GRAT1+Y)**2. + 4.0*(X+Y)*GRAT1) + KK = 0.5*(-(GRAT1+Y) + DD ) +! +! *** SPECIATION & WATER CONTENT *************************************** +! + MOLAL (1) = KK ! HI + MOLAL (5) = Y+KK ! SO4I + MOLAL (6) = MAX (X+Y-KK, TINY) ! HSO4I + MOLAL (3) = 3.0*Y+X ! NH4I + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (.NOT.CALAIN) GOTO 30 + CALL CALCACT +20 CONTINUE +! +30 RETURN +! +! *** END OF SUBROUTINE CALCB3B ****************************************** +! + END SUBROUTINE CALCB3B +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCB2 +! *** CASE B2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : LC, (NH4)2SO4 +! +! THERE ARE TWO POSSIBLE REGIMES HERE, DEPENDING ON THE SULFATE RATIO: +! 1. WHEN BOTH LC AND (NH4)2SO4 ARE POSSIBLE (SUBROUTINE CALCB2A) +! 2. WHEN ONLY LC IS POSSIBLE (SUBROUTINE CALCB2B). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCB2 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** CALCULATE EQUIVALENT AMOUNT OF HSO4 AND SO4 *********************** +! + X = MAX(2*W(2)-W(3), TINY) ! Equivalent NH4HSO4 + Y = MAX(W(3) -W(2), TINY) ! Equivalent NH42SO4 +! +! *** CALCULATE SPECIES ACCORDING TO RELATIVE ABUNDANCE OF HSO4 ********* +! + IF (X.LE.Y) THEN ! LC is the MIN (x,y) + SCASE = 'B2 ; SUBCASE 1' + CALL CALCB2A (X,Y-X) ! LC + (NH4)2SO4 POSSIBLE + ELSE + SCASE = 'B2 ; SUBCASE 2' + CALL CALCB2B (Y,X-Y) ! LC ONLY POSSIBLE + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCB2 ****************************************** +! + END SUBROUTINE CALCB2 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCB2 +! *** CASE B2 ; SUBCASE A. +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH (1.0 < SULRAT < 2.0) +! 2. SOLID PHASE ONLY POSSIBLE +! 3. SOLIDS POSSIBLE: LC, (NH4)2SO4 +! +! THERE ARE TWO POSSIBLE REGIMES HERE, DEPENDING ON RELATIVE HUMIDITY: +! 1. WHEN RH >= MDRH ; LIQUID PHASE POSSIBLE (MDRH REGION) +! 2. WHEN RH < MDRH ; ONLY SOLID PHASE POSSIBLE +! +! FOR SOLID CALCULATIONS, A MATERIAL BALANCE BASED ON THE STOICHIMETRIC +! PROPORTION OF AMMONIUM AND SULFATE IS DONE TO CALCULATE THE AMOUNT +! OF LC AND (NH4)2SO4 IN THE SOLID PHASE. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCB2A (TLC, TNH42S4) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** REGIME DEPENDS UPON THE AMBIENT RELATIVE HUMIDITY ***************** +! + IF (RH.LT.DRMLCAS) THEN + SCASE = 'B2 ; SUBCASE A1' ! SOLIDS POSSIBLE ONLY + CLC = TLC + CNH42S4 = TNH42S4 + SCASE = 'B2 ; SUBCASE A1' + ELSE + SCASE = 'B2 ; SUBCASE A2' + CALL CALCB2A2 (TLC, TNH42S4) ! LIQUID & SOLID PHASE POSSIBLE + SCASE = 'B2 ; SUBCASE A2' + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCB2A ***************************************** +! + END SUBROUTINE CALCB2A + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCB2A2 +! *** CASE B2 ; SUBCASE A2. +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH (1.0 < SULRAT < 2.0) +! 2. SOLID PHASE ONLY POSSIBLE +! 3. SOLIDS POSSIBLE: LC, (NH4)2SO4 +! +! THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL +! DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED +! SOLUTIONS ; THE SOLID PHASE ONLY (SUBROUTINE CALCB2A1) AND THE +! THE SOLID WITH LIQUID PHASE (SUBROUTINE CALCB3). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCB2A2 (TLC, TNH42S4) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** FIND WEIGHT FACTOR ********************************************** +! + IF (WFTYP.EQ.0) THEN + WF = ZERO + ELSEIF (WFTYP.EQ.1) THEN + WF = 0.5D0 + ELSE + WF = (DRLC-RH)/(DRLC-DRMLCAS) + ENDIF + ONEMWF = ONE - WF +! +! *** FIND FIRST SECTION ; DRY ONE ************************************ +! + CLCO = TLC ! FIRST (DRY) SOLUTION + CNH42SO = TNH42S4 +! +! *** FIND SECOND SECTION ; DRY & LIQUID ****************************** +! + CLC = ZERO + CNH42S4 = ZERO + CALL CALCB3 ! SECOND (LIQUID) SOLUTION +! +! *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS. +! + MOLAL(1)= ONEMWF*MOLAL(1) ! H+ + MOLAL(3)= ONEMWF*(2.D0*(CNH42SO-CNH42S4) + 3.D0*(CLCO-CLC)) ! NH4+ + MOLAL(5)= ONEMWF*(CNH42SO-CNH42S4 + CLCO-CLC) ! SO4-- + MOLAL(6)= ONEMWF*(CLCO-CLC) ! HSO4- +! + WATER = ONEMWF*WATER +! + CLC = WF*CLCO + ONEMWF*CLC + CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4 +! + RETURN +! +! *** END OF SUBROUTINE CALCB2A2 **************************************** +! + END SUBROUTINE CALCB2A2 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCB2 +! *** CASE B2 ; SUBCASE B +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH (1.0 < SULRAT < 2.0) +! 2. BOTH LIQUID & SOLID PHASE IS POSSIBLE +! 3. SOLIDS POSSIBLE: LC +! +! FOR CALCULATIONS, A BISECTION IS PERFORMED TOWARDS ZETA, THE +! AMOUNT OF SOLID LC DISSOLVED IN THE LIQUID PHASE. +! FOR EACH ESTIMATION OF ZETA, FUNCTION FUNCB2A CALCULATES THE +! AMOUNT OF H+ PRODUCED (BASED ON THE HSO4, SO4 RELEASED INTO THE +! SOLUTION). THE SOLUBILITY PRODUCT OF LC IS USED AS THE OBJECTIVE +! FUNCTION. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCB2B (TLC,TNH4HS4) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + ZLO = ZERO + ZHI = TLC ! High limit: all of it in liquid phase +! +! *** INITIAL VALUES FOR BISECTION ************************************** +! + X1 = ZHI + Y1 = FUNCB2B (X1,TNH4HS4,TLC) + IF (ABS(Y1).LE.EPS) RETURN + YHI= Y1 ! Save Y-value at Hi position +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ************************ +! + DX = (ZHI-ZLO)/NDIV + DO 10 I=1,NDIV + X2 = X1-DX + Y2 = FUNCB2B (X2,TNH4HS4,TLC) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION FOUND +! + YLO= Y1 ! Save Y-value at LO position + IF (ABS(Y2) .LT. EPS) THEN ! X2 IS A SOLUTION + RETURN +! +! *** { YLO, YHI } < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH LC +! + ELSE IF (YLO.LT.ZERO .AND. YHI.LT.ZERO) THEN + X1 = ZHI + X2 = ZHI + GOTO 40 +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH LC +! + ELSE IF (YLO.GT.ZERO .AND. YHI.GT.ZERO) THEN + X1 = ZLO + X2 = ZLO + GOTO 40 + ELSE + CALL PUSHERR (0001, 'CALCB2B') ! WARNING ERROR: NO SOLUTION + RETURN + ENDIF +! +! *** PERFORM BISECTION ************************************************* +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCB2B (X3,TNH4HS4,TLC) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCB2B') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ************************************************ +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCB2B (X3,TNH4HS4,TLC) +! + RETURN +! +! *** END OF SUBROUTINE CALCB2B ***************************************** +! + END SUBROUTINE CALCB2B + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** FUNCTION FUNCB2B +! *** CASE B2 ; +! FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE B2 ; SUBCASE 2 +! AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCB2B. +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCB2B (X,TNH4HS4,TLC) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** SOLVE EQUATIONS ************************************************** +! + FRST = .TRUE. + CALAIN = .TRUE. + DO 20 I=1,NSWEEP + GRAT2 = XK1*WATER*(GAMA(8)/GAMA(7))**2./GAMA(7) + PARM = X+GRAT2 + DELTA = PARM*PARM + 4.0*(X+TNH4HS4)*GRAT2 ! Diakrinousa + OMEGA = 0.5*(-PARM + SQRT(DELTA)) ! Thetiki riza (ie:H+>0) +! +! *** SPECIATION & WATER CONTENT *************************************** +! + MOLAL (1) = OMEGA ! HI + MOLAL (3) = 3.0*X+TNH4HS4 ! NH4I + MOLAL (5) = X+OMEGA ! SO4I + MOLAL (6) = MAX (X+TNH4HS4-OMEGA, TINY) ! HSO4I + CLC = MAX(TLC-X,ZERO) ! Solid LC + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ****************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 30 + ENDIF +20 CONTINUE +! +! *** CALCULATE OBJECTIVE FUNCTION ************************************** +! +!CC30 FUNCB2B= ( NH4I**3.*SO4I*HSO4I )/( XK13*(WATER/GAMA(13))**5. ) +30 FUNCB2B= (MOLAL(3)**3.)*MOLAL(5)*MOLAL(6) + FUNCB2B= FUNCB2B/(XK13*(WATER/GAMA(13))**5.) - ONE + RETURN +! +! *** END OF FUNCTION FUNCB2B ******************************************* +! + END FUNCTION FUNCB2B + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCB1 +! *** CASE B1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : LC, (NH4)2SO4, NH4HSO4 +! +! THERE ARE TWO POSSIBLE REGIMES HERE, DEPENDING ON RELATIVE HUMIDITY: +! 1. WHEN RH >= MDRH ; LIQUID PHASE POSSIBLE (MDRH REGION) +! 2. WHEN RH < MDRH ; ONLY SOLID PHASE POSSIBLE (SUBROUTINE CALCB1A) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCB1 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** REGIME DEPENDS UPON THE AMBIENT RELATIVE HUMIDITY ***************** +! + IF (RH.LT.DRMLCAB) THEN + SCASE = 'B1 ; SUBCASE 1' + CALL CALCB1A ! SOLID PHASE ONLY POSSIBLE + SCASE = 'B1 ; SUBCASE 1' + ELSE + SCASE = 'B1 ; SUBCASE 2' + CALL CALCB1B ! LIQUID & SOLID PHASE POSSIBLE + SCASE = 'B1 ; SUBCASE 2' + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCB1 ****************************************** +! + END SUBROUTINE CALCB1 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCB1A +! *** CASE B1 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH +! 2. THERE IS NO LIQUID PHASE +! 3. SOLIDS POSSIBLE: LC, { (NH4)2SO4 XOR NH4HSO4 } (ONE OF TWO +! BUT NOT BOTH) +! +! A SIMPLE MATERIAL BALANCE IS PERFORMED, AND THE AMOUNT OF LC +! IS CALCULATED FROM THE (NH4)2SO4 AND NH4HSO4 WHICH IS LEAST +! ABUNDANT (STOICHIMETRICALLY). THE REMAINING EXCESS OF SALT +! IS MIXED WITH THE LC. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCB1A + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** SETUP PARAMETERS ************************************************ +! + X = 2*W(2)-W(3) ! Equivalent NH4HSO4 + Y = W(3)-W(2) ! Equivalent (NH4)2SO4 +! +! *** CALCULATE COMPOSITION ******************************************* +! + IF (X.LE.Y) THEN ! LC is the MIN (x,y) + CLC = X ! NH4HSO4 >= (NH4)2S04 + CNH4HS4 = ZERO + CNH42S4 = Y-X + ELSE + CLC = Y ! NH4HSO4 < (NH4)2S04 + CNH4HS4 = X-Y + CNH42S4 = ZERO + ENDIF + RETURN +! +! *** END OF SUBROUTINE CALCB1 ****************************************** +! + END SUBROUTINE CALCB1A + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCB1B +! *** CASE B1 ; SUBCASE 2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE: LC, { (NH4)2SO4 XOR NH4HSO4 } (ONE OF TWO +! BUT NOT BOTH) +! +! THIS IS THE CASE WHERE THE RELATIVE HUMIDITY IS IN THE MUTUAL +! DRH REGION. THE SOLUTION IS ASSUMED TO BE THE SUM OF TWO WEIGHTED +! SOLUTIONS ; THE SOLID PHASE ONLY (SUBROUTINE CALCB1A) AND THE +! THE SOLID WITH LIQUID PHASE (SUBROUTINE CALCB2). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCB1B + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** FIND WEIGHT FACTOR ********************************************** +! + IF (WFTYP.EQ.0) THEN + WF = ZERO + ELSEIF (WFTYP.EQ.1) THEN + WF = 0.5D0 + ELSE + WF = (DRNH4HS4-RH)/(DRNH4HS4-DRMLCAB) + ENDIF + ONEMWF = ONE - WF +! +! *** FIND FIRST SECTION ; DRY ONE ************************************ +! + CALL CALCB1A + CLCO = CLC ! FIRST (DRY) SOLUTION + CNH42SO = CNH42S4 + CNH4HSO = CNH4HS4 +! +! *** FIND SECOND SECTION ; DRY & LIQUID ****************************** +! + CLC = ZERO + CNH42S4 = ZERO + CNH4HS4 = ZERO + CALL CALCB2 ! SECOND (LIQUID) SOLUTION +! +! *** FIND SOLUTION AT MDRH BY WEIGHTING DRY & LIQUID SOLUTIONS. +! + MOLAL(1)= ONEMWF*MOLAL(1) ! H+ + MOLAL(3)= ONEMWF*(2.D0*(CNH42SO-CNH42S4) + (CNH4HSO-CNH4HS4) & + + 3.D0*(CLCO-CLC)) ! NH4+ + MOLAL(5)= ONEMWF*(CNH42SO-CNH42S4 + CLCO-CLC) ! SO4-- + MOLAL(6)= ONEMWF*(CNH4HSO-CNH4HS4 + CLCO-CLC) ! HSO4- +! + WATER = ONEMWF*WATER +! + CLC = WF*CLCO + ONEMWF*CLC + CNH42S4 = WF*CNH42SO + ONEMWF*CNH42S4 + CNH4HS4 = WF*CNH4HSO + ONEMWF*CNH4HS4 +! + RETURN +! +! *** END OF SUBROUTINE CALCB1B ***************************************** +! + END SUBROUTINE CALCB1B + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCC2 +! *** CASE C2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +! 2. THERE IS ONLY A LIQUID PHASE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCC2 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION LAMDA, KAPA +! + CALAOU =.TRUE. ! Outer loop activity calculation flag + FRST =.TRUE. + CALAIN =.TRUE. +! +! *** SOLVE EQUATIONS ************************************************** +! + LAMDA = W(3) ! NH4HSO4 INITIALLY IN SOLUTION + PSI = W(2)-W(3) ! H2SO4 IN SOLUTION + DO 20 I=1,NSWEEP + PARM = WATER*XK1/GAMA(7)*(GAMA(8)/GAMA(7))**2. + BB = PSI+PARM + CC =-PARM*(LAMDA+PSI) + KAPA = 0.5*(-BB+SQRT(BB*BB-4.0*CC)) +! +! *** SPECIATION & WATER CONTENT *************************************** +! + MOLAL(1) = PSI+KAPA ! HI + MOLAL(3) = LAMDA ! NH4I + MOLAL(5) = KAPA ! SO4I + MOLAL(6) = MAX(LAMDA+PSI-KAPA, TINY) ! HSO4I + CH2SO4 = MAX(MOLAL(5)+MOLAL(6)-MOLAL(3), ZERO) ! Free H2SO4 + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (.NOT.CALAIN) GOTO 30 + CALL CALCACT +20 CONTINUE +! +30 RETURN +! +! *** END OF SUBROUTINE CALCC2 ***************************************** +! + END SUBROUTINE CALCC2 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCC1 +! *** CASE C1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE: NH4HSO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCC1 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION KLO, KHI +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + KLO = TINY + KHI = W(3) +! +! *** INITIAL VALUES FOR BISECTION ************************************* +! + X1 = KLO + Y1 = FUNCC1 (X1) + IF (ABS(Y1).LE.EPS) GOTO 50 + YLO= Y1 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO *********************** +! + DX = (KHI-KLO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCC1 (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2) .LT. ZERO) GOTO 20 ! (Y1*Y2 .LT. ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION FOUND +! + YHI= Y2 ! Save Y-value at HI position + IF (ABS(Y2) .LT. EPS) THEN ! X2 IS A SOLUTION + GOTO 50 +! +! *** { YLO, YHI } < 0.0 SOLUTION IS ALWAYS UNDERSATURATED WITH NH4HS04 +! + ELSE IF (YLO.LT.ZERO .AND. YHI.LT.ZERO) THEN + GOTO 50 +! +! *** { YLO, YHI } > 0.0 SOLUTION IS ALWAYS SUPERSATURATED WITH NH4HS04 +! + ELSE IF (YLO.GT.ZERO .AND. YHI.GT.ZERO) THEN + X1 = KLO + X2 = KLO + GOTO 40 + ELSE + CALL PUSHERR (0001, 'CALCC1') ! WARNING ERROR: NO SOLUTION + GOTO 50 + ENDIF +! +! *** PERFORM BISECTION OF DISSOLVED NH4HSO4 ************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCC1 (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCC1') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN *********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCC1 (X3) +! +50 RETURN +! +! *** END OF SUBROUTINE CALCC1 ***************************************** +! + END SUBROUTINE CALCC1 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** FUNCTION FUNCC1 +! *** CASE C1 ; +! FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE C1 +! AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCC1. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCC1 (KAPA) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION KAPA, LAMDA +! +! *** SOLVE EQUATIONS ************************************************** +! + FRST = .TRUE. + CALAIN = .TRUE. +! + PSI = W(2)-W(3) + DO 20 I=1,NSWEEP + PAR1 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.0 + PAR2 = XK12*(WATER/GAMA(9))**2.0 + BB = PSI + PAR1 + CC =-PAR1*(PSI+KAPA) + LAMDA = 0.5*(-BB+SQRT(BB*BB-4*CC)) +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ******************************* +! + MOLAL(1) = PSI+LAMDA ! HI + MOLAL(3) = KAPA ! NH4I + MOLAL(5) = LAMDA ! SO4I + MOLAL(6) = MAX (ZERO, PSI+KAPA-LAMDA) ! HSO4I + CNH4HS4 = MAX(W(3)-MOLAL(3), ZERO) ! Solid NH4HSO4 + CH2SO4 = MAX(PSI, ZERO) ! Free H2SO4 + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 30 + ENDIF +20 CONTINUE +! +! *** CALCULATE ZERO FUNCTION ******************************************* +! +!CC30 FUNCC1= (NH4I*HSO4I/PAR2) - ONE +30 FUNCC1= (MOLAL(3)*MOLAL(6)/PAR2) - ONE + RETURN +! +! *** END OF FUNCTION FUNCC1 ******************************************** +! + END FUNCTION FUNCC1 + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCD3 +! *** CASE D3 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. THERE IS OLNY A LIQUID PHASE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCD3 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** FIND DRY COMPOSITION ********************************************** +! + CALL CALCD1A +! +! *** SETUP PARAMETERS ************************************************ +! + CHI1 = CNH4NO3 ! Save from CALCD1 run + CHI2 = CNH42S4 + CHI3 = GHNO3 + CHI4 = GNH3 +! + PSI1 = CNH4NO3 ! ASSIGN INITIAL PSI's + PSI2 = CHI2 + PSI3 = ZERO + PSI4 = ZERO +! + MOLAL(5) = ZERO + MOLAL(6) = ZERO + MOLAL(3) = PSI1 + MOLAL(7) = PSI1 + CALL CALCMR ! Initial water +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + PSI4LO = TINY ! Low limit + PSI4HI = CHI4 ! High limit +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! +60 X1 = PSI4LO + Y1 = FUNCD3 (X1) + IF (ABS(Y1).LE.EPS) RETURN + YLO= Y1 ! Save Y-value at HI position +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI4HI-PSI4LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCD3 (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION FOUND +! + YHI= Y1 ! Save Y-value at Hi position + IF (ABS(Y2) .LT. EPS) THEN ! X2 IS A SOLUTION + RETURN +! +! *** { YLO, YHI } < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NH3 +! Physically I dont know when this might happen, but I have put this +! branch in for completeness. I assume there is no solution; all NO3 goes to the +! gas phase. +! + ELSE IF (YLO.LT.ZERO .AND. YHI.LT.ZERO) THEN + P4 = TINY ! PSI4LO ! CHI4 + YY = FUNCD3(P4) + GOTO 50 +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NH3 +! This happens when Sul.Rat. = 2.0, so some NH4+ from sulfate evaporates +! and goes to the gas phase ; so I redefine the LO and HI limits of PSI4 +! and proceed again with root tracking. +! + ELSE IF (YLO.GT.ZERO .AND. YHI.GT.ZERO) THEN + PSI4HI = PSI4LO + PSI4LO = PSI4LO - 0.1*(PSI1+PSI2) ! No solution; some NH3 evaporates + IF (PSI4LO.LT.-(PSI1+PSI2)) THEN + CALL PUSHERR (0001, 'CALCD3') ! WARNING ERROR: NO SOLUTION + RETURN + ELSE + MOLAL(5) = ZERO + MOLAL(6) = ZERO + MOLAL(3) = PSI1 + MOLAL(7) = PSI1 + CALL CALCMR ! Initial water + GOTO 60 ! Redo root tracking + ENDIF + ENDIF +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCD3 (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*ABS(X1)) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCD3') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCD3 (X3) +! +! *** CALCULATE HSO4 SPECIATION AND RETURN ******************************* +! +50 CONTINUE + IF (MOLAL(1).GT.TINY) THEN + CALL CALCHS4 (MOLAL(1), MOLAL(5), ZERO, DELTA) + MOLAL(1) = MOLAL(1) - DELTA ! H+ EFFECT + MOLAL(5) = MOLAL(5) - DELTA ! SO4 EFFECT + MOLAL(6) = DELTA ! HSO4 EFFECT + ENDIF + RETURN +! +! *** END OF SUBROUTINE CALCD3 ****************************************** +! + END SUBROUTINE CALCD3 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** FUNCTION FUNCD3 +! *** CASE D3 +! FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D3 ; +! AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD3. +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCD3 (P4) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST = .TRUE. + CALAIN = .TRUE. + PSI4 = P4 +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A2 = XK7*(WATER/GAMA(4))**3.0 + A3 = XK4*R*TEMP*(WATER/GAMA(10))**2.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A7 = XKW *RH*WATER*WATER +! + PSI3 = A3*A4*CHI3*(CHI4-PSI4) - PSI1*(2.D0*PSI2+PSI1+PSI4) + PSI3 = PSI3/(A3*A4*(CHI4-PSI4) + 2.D0*PSI2+PSI1+PSI4) + PSI3 = MIN(MAX(PSI3, ZERO), CHI3) +! + BB = PSI4 - PSI3 +!CCOLD AHI = 0.5*(-BB + SQRT(BB*BB + 4.d0*A7)) ! This is correct also +!CC AHI =2.0*A7/(BB+SQRT(BB*BB + 4.d0*A7)) ! Avoid overflow when HI->0 + DENM = BB+SQRT(BB*BB + 4.d0*A7) + IF (DENM.LE.TINY) THEN ! Avoid overflow when HI->0 + ABB = ABS(BB) + DENM = (BB+ABB) + 2.0*A7/ABB ! Taylor expansion of SQRT + ENDIF + AHI = 2.0*A7/DENM +! +! *** SPECIATION & WATER CONTENT *************************************** +! + MOLAL (1) = AHI ! HI + MOLAL (3) = PSI1 + PSI4 + 2.D0*PSI2 ! NH4I + MOLAL (5) = PSI2 ! SO4I + MOLAL (6) = ZERO ! HSO4I + MOLAL (7) = PSI3 + PSI1 ! NO3I + CNH42S4 = CHI2 - PSI2 ! Solid (NH4)2SO4 + CNH4NO3 = ZERO ! Solid NH4NO3 + GHNO3 = CHI3 - PSI3 ! Gas HNO3 + GNH3 = CHI4 - PSI4 ! Gas NH3 + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE OBJECTIVE FUNCTION ************************************ +! +20 CONTINUE +!CC FUNCD3= NH4I/HI/MAX(GNH3,TINY)/A4 - ONE + FUNCD3= MOLAL(3)/MOLAL(1)/MAX(GNH3,TINY)/A4 - ONE + RETURN +! +! *** END OF FUNCTION FUNCD3 ******************************************** +! + END FUNCTION FUNCD3 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCD2 +! *** CASE D2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCD2 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** FIND DRY COMPOSITION ********************************************** +! + CALL CALCD1A +! +! *** SETUP PARAMETERS ************************************************ +! + CHI1 = CNH4NO3 ! Save from CALCD1 run + CHI2 = CNH42S4 + CHI3 = GHNO3 + CHI4 = GNH3 +! + PSI1 = CNH4NO3 ! ASSIGN INITIAL PSI's + PSI2 = CNH42S4 + PSI3 = ZERO + PSI4 = ZERO +! + MOLAL(5) = ZERO + MOLAL(6) = ZERO + MOLAL(3) = PSI1 + MOLAL(7) = PSI1 + CALL CALCMR ! Initial water +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + PSI4LO = TINY ! Low limit + PSI4HI = CHI4 ! High limit +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! +60 X1 = PSI4LO + Y1 = FUNCD2 (X1) + IF (ABS(Y1).LE.EPS) RETURN + YLO= Y1 ! Save Y-value at HI position +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI4HI-PSI4LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCD2 (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) THEN +! +! This is done, in case if Y(PSI4LO)>0, but Y(PSI4LO+DX) < 0 (i.e.undersat) +! + IF (Y1 .LE. Y2) GOTO 20 ! (Y1*Y2.LT.ZERO) + ENDIF + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION FOUND +! + YHI= Y1 ! Save Y-value at Hi position + IF (ABS(Y2) .LT. EPS) THEN ! X2 IS A SOLUTION + RETURN +! +! *** { YLO, YHI } < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NH3 +! Physically I dont know when this might happen, but I have put this +! branch in for completeness. I assume there is no solution; all NO3 goes to the +! gas phase. +! + ELSE IF (YLO.LT.ZERO .AND. YHI.LT.ZERO) THEN + P4 = TINY ! PSI4LO ! CHI4 + YY = FUNCD2(P4) + GOTO 50 +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NH3 +! This happens when Sul.Rat. = 2.0, so some NH4+ from sulfate evaporates +! and goes to the gas phase ; so I redefine the LO and HI limits of PSI4 +! and proceed again with root tracking. +! + ELSE IF (YLO.GT.ZERO .AND. YHI.GT.ZERO) THEN + PSI4HI = PSI4LO + PSI4LO = PSI4LO - 0.1*(PSI1+PSI2) ! No solution; some NH3 evaporates + IF (PSI4LO.LT.-(PSI1+PSI2)) THEN + CALL PUSHERR (0001, 'CALCD2') ! WARNING ERROR: NO SOLUTION + RETURN + ELSE + MOLAL(5) = ZERO + MOLAL(6) = ZERO + MOLAL(3) = PSI1 + MOLAL(7) = PSI1 + CALL CALCMR ! Initial water + GOTO 60 ! Redo root tracking + ENDIF + ENDIF +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCD2 (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*ABS(X1)) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCD2') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ********************************************** +! +40 X3 = MIN(X1,X2) ! 0.5*(X1+X2) ! Get "low" side, it's acidic soln. + Y3 = FUNCD2 (X3) +! +! *** CALCULATE HSO4 SPECIATION AND RETURN ******************************* +! +50 CONTINUE + IF (MOLAL(1).GT.TINY) THEN + CALL CALCHS4 (MOLAL(1), MOLAL(5), ZERO, DELTA) + MOLAL(1) = MOLAL(1) - DELTA ! H+ EFFECT + MOLAL(5) = MOLAL(5) - DELTA ! SO4 EFFECT + MOLAL(6) = DELTA ! HSO4 EFFECT + ENDIF + RETURN +! +! *** END OF SUBROUTINE CALCD2 ****************************************** +! + END SUBROUTINE CALCD2 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** FUNCTION FUNCD2 +! *** CASE D2 +! FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D2 ; +! AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCD2. +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCD2 (P4) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + CALL RSTGAM ! Reset activity coefficients to 0.1 + FRST = .TRUE. + CALAIN = .TRUE. + PSI4 = P4 + PSI2 = CHI2 +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A2 = XK7*(WATER/GAMA(4))**3.0 + A3 = XK4*R*TEMP*(WATER/GAMA(10))**2.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A7 = XKW *RH*WATER*WATER +! + IF (CHI2.GT.TINY .AND. WATER.GT.TINY) THEN + PSI14 = PSI1+PSI4 + CALL POLY3 (PSI14,0.25*PSI14**2.,-A2/4.D0, PSI2, ISLV) ! PSI2 + IF (ISLV.EQ.0) THEN + PSI2 = MIN (PSI2, CHI2) + ELSE + PSI2 = ZERO + ENDIF + ENDIF +! + PSI3 = A3*A4*CHI3*(CHI4-PSI4) - PSI1*(2.D0*PSI2+PSI1+PSI4) + PSI3 = PSI3/(A3*A4*(CHI4-PSI4) + 2.D0*PSI2+PSI1+PSI4) +!cc PSI3 = MIN(MAX(PSI3, ZERO), CHI3) +! + BB = PSI4-PSI3 ! (BB > 0, acidic solution, <0 alkaline) +! +! Do not change computation scheme for H+, all others did not work well. +! + DENM = BB+SQRT(BB*BB + 4.d0*A7) + IF (DENM.LE.TINY) THEN ! Avoid overflow when HI->0 + ABB = ABS(BB) + DENM = (BB+ABB) + 2.d0*A7/ABB ! Taylor expansion of SQRT + ENDIF + AHI = 2.d0*A7/DENM +! +! *** SPECIATION & WATER CONTENT *************************************** +! + MOLAL (1) = AHI ! HI + MOLAL (3) = PSI1 + PSI4 + 2.D0*PSI2 ! NH4 + MOLAL (5) = PSI2 ! SO4 + MOLAL (6) = ZERO ! HSO4 + MOLAL (7) = PSI3 + PSI1 ! NO3 + CNH42S4 = CHI2 - PSI2 ! Solid (NH4)2SO4 + CNH4NO3 = ZERO ! Solid NH4NO3 + GHNO3 = CHI3 - PSI3 ! Gas HNO3 + GNH3 = CHI4 - PSI4 ! Gas NH3 + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE OBJECTIVE FUNCTION ************************************ +! +20 CONTINUE +!CC FUNCD2= NH4I/HI/MAX(GNH3,TINY)/A4 - ONE + FUNCD2= MOLAL(3)/MOLAL(1)/MAX(GNH3,TINY)/A4 - ONE + RETURN +! +! *** END OF FUNCTION FUNCD2 ******************************************** +! + END FUNCTION FUNCD2 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCD1 +! *** CASE D1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4NO3 +! +! THERE ARE TWO REGIMES DEFINED BY RELATIVE HUMIDITY: +! 1. RH < MDRH ; ONLY SOLID PHASE POSSIBLE (SUBROUTINE CALCD1A) +! 2. RH >= MDRH ; LIQUID PHASE POSSIBLE (MDRH REGION) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCD1 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL CALCD1A, CALCD2 +! +! *** REGIME DEPENDS UPON THE AMBIENT RELATIVE HUMIDITY ***************** +! + IF (RH.LT.DRMASAN) THEN + SCASE = 'D1 ; SUBCASE 1' ! SOLID PHASE ONLY POSSIBLE + CALL CALCD1A + SCASE = 'D1 ; SUBCASE 1' + ELSE + SCASE = 'D1 ; SUBCASE 2' ! LIQUID & SOLID PHASE POSSIBLE + CALL CALCMDRH (RH, DRMASAN, DRNH4NO3, CALCD1A, CALCD2) + SCASE = 'D1 ; SUBCASE 2' + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCD1 ****************************************** +! + END SUBROUTINE CALCD1 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCD1A +! *** CASE D1 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4NO3 +! +! THE SOLID (NH4)2SO4 IS CALCULATED FROM THE SULFATES, WHILE NH4NO3 +! IS CALCULATED FROM NH3-HNO3 EQUILIBRIUM. 'ZE' IS THE AMOUNT OF +! NH4NO3 THAT VOLATIZES WHEN ALL POSSILBE NH4NO3 IS INITIALLY IN +! THE SOLID PHASE. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCD1A + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** SETUP PARAMETERS ************************************************ +! + PARM = XK10/(R*TEMP)/(R*TEMP) +! +! *** CALCULATE NH4NO3 THAT VOLATIZES ********************************* +! + CNH42S4 = W(2) + X = MAX(ZERO, MIN(W(3)-2.0*CNH42S4, W(4))) ! MAX NH4NO3 + PS = MAX(W(3) - X - 2.0*CNH42S4, ZERO) + OM = MAX(W(4) - X, ZERO) +! + OMPS = OM+PS + DIAK = SQRT(OMPS*OMPS + 4.0*PARM) ! DIAKRINOUSA + ZE = MIN(X, 0.5*(-OMPS + DIAK)) ! THETIKI RIZA +! +! *** SPECIATION ******************************************************* +! + CNH4NO3 = X - ZE ! Solid NH4NO3 + GNH3 = PS + ZE ! Gas NH3 + GHNO3 = OM + ZE ! Gas HNO3 +! + RETURN +! +! *** END OF SUBROUTINE CALCD1A ***************************************** +! + END SUBROUTINE CALCD1A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCG5 +! *** CASE G5 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCG5 + USE ISRPIA + USE CASEG + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! DOUBLE PRECISION LAMDA +! COMMON /CASEG/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, LAMDA, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, & +! A1, A2, A3, A4, A5, A6, A7 +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU = .TRUE. + CHI1 = 0.5*W(1) + CHI2 = MAX (W(2)-CHI1, ZERO) + CHI3 = ZERO + CHI4 = MAX (W(3)-2.D0*CHI2, ZERO) + CHI5 = W(4) + CHI6 = W(5) +! + PSI1 = CHI1 + PSI2 = CHI2 + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +! + WATER = CHI2/M0(4) + CHI1/M0(2) +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI6LO + Y1 = FUNCG5A (X1) + IF (CHI6.LE.TINY) GOTO 50 +!cc IF (ABS(Y1).LE.EPS .OR. CHI6.LE.TINY) GOTO 50 +!cc IF (WATER .LE. TINY) RETURN ! No water +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI6HI-PSI6LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCG5A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCG5A (X) + USE ISRPIA + USE CASEG + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! DOUBLE PRECISION LAMDA +! COMMON /CASEG/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, LAMDA, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, & +! A1, A2, A3, A4, A5, A6, A7 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI6 = X + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A1 = XK5 *(WATER/GAMA(2))**3.0 + A2 = XK7 *(WATER/GAMA(4))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 + AKK = A4*A6 +! +! CALCULATE DISSOCIATION QUANTITIES +! + IF (CHI5.GE.TINY) THEN + PSI5 = PSI6*CHI5/(A6/A5*(CHI6-PSI6) + PSI6) + ELSE + PSI5 = TINY + ENDIF +! +!CC IF(CHI4.GT.TINY) THEN + IF(W(2).GT.TINY) THEN ! Accounts for NH3 evaporation + BB =-(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) - 2.d0*PSI2/A4 + DD = MAX(BB*BB-4.d0*CC,ZERO) ! Patch proposed by Uma Shankar, 19/11/01 + PSI4 =0.5d0*(-BB - SQRT(DD)) + ELSE + PSI4 = TINY + ENDIF +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (2) = 2.0D0*PSI1 ! NAI + MOLAL (3) = 2.0*PSI2 + PSI4 ! NH4I + MOLAL (4) = PSI6 ! CLI + MOLAL (5) = PSI2 + PSI1 ! SO4I + MOLAL (6) = ZERO + MOLAL (7) = PSI5 ! NO3I +! + SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +! + GNH3 = MAX(CHI4 - PSI4, TINY) ! Gas NH3 + GHNO3 = MAX(CHI5 - PSI5, TINY) ! Gas HNO3 + GHCL = MAX(CHI6 - PSI6, TINY) ! Gas HCl +! + CNH42S4 = ZERO ! Solid (NH4)2SO4 + CNH4NO3 = ZERO ! Solid NH4NO3 + CNH4CL = ZERO ! Solid NH4Cl +! + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +! +20 FUNCG5A = MOLAL(1)*MOLAL(4)/GHCL/A6 - ONE +!CC FUNCG5A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE +! + RETURN +! +! *** END OF FUNCTION FUNCG5A ******************************************* +! + END FUNCTION FUNCG5A + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCG4 +! *** CASE G4 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCG4 + USE ISRPIA + USE CASEG + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! DOUBLE PRECISION LAMDA +! COMMON /CASEG/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, LAMDA, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, & +! A1, A2, A3, A4, A5, A6, A7 +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU = .TRUE. + CHI1 = 0.5*W(1) + CHI2 = MAX (W(2)-CHI1, ZERO) + CHI3 = ZERO + CHI4 = MAX (W(3)-2.D0*CHI2, ZERO) + CHI5 = W(4) + CHI6 = W(5) +! + PSI2 = CHI2 + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +! + WATER = CHI2/M0(4) + CHI1/M0(2) +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI6LO + Y1 = FUNCG4A (X1) + IF (CHI6.LE.TINY) GOTO 50 +!CC IF (ABS(Y1).LE.EPS .OR. CHI6.LE.TINY .OR. WATER .LE. TINY) GOTO 50 +!CC IF (WATER .LE. TINY) RETURN ! No water +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI6HI-PSI6LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCG4A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCG4A (X) + USE ISRPIA + USE CASEG + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! DOUBLE PRECISION LAMDA, NAI, NH4I, NO3I + DOUBLE PRECISION NAI, NH4I, NO3I +! COMMON /CASEG/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, LAMDA, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, & +! A1, A2, A3, A4, A5, A6, A7 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI6 = X + PSI1 = CHI1 + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A1 = XK5 *(WATER/GAMA(2))**3.0 + A2 = XK7 *(WATER/GAMA(4))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 +! +! CALCULATE DISSOCIATION QUANTITIES +! + IF (CHI5.GE.TINY) THEN + PSI5 = PSI6*CHI5/(A6/A5*(CHI6-PSI6) + PSI6) + ELSE + PSI5 = TINY + ENDIF +! +!CC IF(CHI4.GT.TINY) THEN + IF(W(2).GT.TINY) THEN ! Accounts for NH3 evaporation + BB =-(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) - 2.d0*PSI2/A4 + DD = MAX(BB*BB-4.d0*CC,ZERO) ! Patch proposed by Uma shankar, 19/11/2001 + PSI4 =0.5d0*(-BB - SQRT(DD)) + ELSE + PSI4 = TINY + ENDIF +! +! CALCULATE CONCENTRATIONS +! + NH4I = 2.0*PSI2 + PSI4 + CLI = PSI6 + SO4I = PSI2 + PSI1 + NO3I = PSI5 + NAI = 2.0D0*PSI1 +! + CALL CALCPH(2.d0*SO4I+NO3I+CLI-NAI-NH4I, HI, OHI) +! +! *** Na2SO4 DISSOLUTION +! + IF (CHI1.GT.TINY .AND. WATER.GT.TINY) THEN ! PSI1 + CALL POLY3 (PSI2, ZERO, -A1/4.D0, PSI1, ISLV) + IF (ISLV.EQ.0) THEN + PSI1 = MIN (PSI1, CHI1) + ELSE + PSI1 = ZERO + ENDIF + ELSE + PSI1 = ZERO + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL (1) = HI + MOLAL (2) = NAI + MOLAL (3) = NH4I + MOLAL (4) = CLI + MOLAL (5) = SO4I + MOLAL (6) = ZERO + MOLAL (7) = NO3I +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! + GNH3 = MAX(CHI4 - PSI4, TINY) + GHNO3 = MAX(CHI5 - PSI5, TINY) + GHCL = MAX(CHI6 - PSI6, TINY) +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNH4CL = ZERO + CNA2SO4 = MAX(CHI1-PSI1,ZERO) +! +! *** CALCULATE MOLALR ARRAY, WATER AND ACTIVITIES ********************** +! + CALL CALCMR +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +! +20 FUNCG4A = MOLAL(1)*MOLAL(4)/GHCL/A6 - ONE +!CC FUNCG4A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE +! + RETURN +! +! *** END OF FUNCTION FUNCG4A ******************************************* +! + END FUNCTION FUNCG4A + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCG3 +! *** CASE G3 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. LIQUID & SOLID PHASE ARE BOTH POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCG3 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL CALCG1A, CALCG4 +! +! *** REGIME DEPENDS ON THE EXISTANCE OF WATER AND OF THE RH ************ +! + IF (W(4).GT.TINY .AND. W(5).GT.TINY) THEN ! NO3,CL EXIST, WATER POSSIBLE + SCASE = 'G3 ; SUBCASE 1' + CALL CALCG3A + SCASE = 'G3 ; SUBCASE 1' + ELSE ! NO3, CL NON EXISTANT + SCASE = 'G1 ; SUBCASE 1' + CALL CALCG1A + SCASE = 'G1 ; SUBCASE 1' + ENDIF +! + IF (WATER.LE.TINY) THEN + IF (RH.LT.DRMG3) THEN ! ONLY SOLIDS + WATER = TINY + DO 10 I=1,NIONS + MOLAL(I) = ZERO +10 CONTINUE + CALL CALCG1A + SCASE = 'G3 ; SUBCASE 2' + RETURN + ELSE + SCASE = 'G3 ; SUBCASE 3' ! MDRH REGION (NA2SO4, NH42S4) + CALL CALCMDRH (RH, DRMG3, DRNH42S4, CALCG1A, CALCG4) + SCASE = 'G3 ; SUBCASE 3' + ENDIF + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCG3 ****************************************** +! + END SUBROUTINE CALCG3 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCG3A +! *** CASE G3 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCG3A + USE ISRPIA + USE CASEG + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! DOUBLE PRECISION LAMDA +! COMMON /CASEG/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, LAMDA, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, & +! A1, A2, A3, A4, A5, A6, A7 +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU = .TRUE. + CHI1 = 0.5*W(1) + CHI2 = MAX (W(2)-CHI1, ZERO) + CHI3 = ZERO + CHI4 = MAX (W(3)-2.D0*CHI2, ZERO) + CHI5 = W(4) + CHI6 = W(5) +! + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +! + WATER = TINY +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI6LO + Y1 = FUNCG3A (X1) + IF (CHI6.LE.TINY) GOTO 50 +!CC IF (ABS(Y1).LE.EPS .OR. CHI6.LE.TINY .OR. WATER .LE. TINY) GOTO 50 +!CC IF (WATER .LE. TINY) RETURN ! No water +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI6HI-PSI6LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCG3A (X2) +! + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCG3A (X) + USE ISRPIA + USE CASEG + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! DOUBLE PRECISION LAMDA +! COMMON /CASEG/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, LAMDA, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, & +! A1, A2, A3, A4, A5, A6, A7 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI6 = X + PSI2 = CHI2 + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A1 = XK5 *(WATER/GAMA(2))**3.0 + A2 = XK7 *(WATER/GAMA(4))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 +! +! CALCULATE DISSOCIATION QUANTITIES +! + IF (CHI5.GE.TINY) THEN + PSI5 = PSI6*CHI5/(A6/A5*(CHI6-PSI6) + PSI6) + ELSE + PSI5 = TINY + ENDIF +! +!CC IF(CHI4.GT.TINY) THEN + IF(W(2).GT.TINY) THEN ! Accounts for NH3 evaporation + BB =-(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) - 2.d0*PSI2/A4 + DD = MAX(BB*BB-4.d0*CC,ZERO) ! Patch proposed by Uma Shankar, 19/11/01 + PSI4 =0.5d0*(-BB - SQRT(DD)) + ELSE + PSI4 = TINY + ENDIF +! + IF (CHI2.GT.TINY .AND. WATER.GT.TINY) THEN + CALL POLY3 (PSI4, PSI4*PSI4/4.D0, -A2/4.D0, PSI20, ISLV) + IF (ISLV.EQ.0) PSI2 = MIN (PSI20, CHI2) + ENDIF +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! + MOLAL (2) = ZERO ! Na + MOLAL (3) = 2.0*PSI2 + PSI4 ! NH4I + MOLAL (4) = PSI6 ! CLI + MOLAL (5) = PSI2 ! SO4I + MOLAL (6) = ZERO ! HSO4 + MOLAL (7) = PSI5 ! NO3I +! + SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +! + GNH3 = MAX(CHI4 - PSI4, TINY) ! Gas NH3 + GHNO3 = MAX(CHI5 - PSI5, TINY) ! Gas HNO3 + GHCL = MAX(CHI6 - PSI6, TINY) ! Gas HCl +! + CNH42S4 = CHI2 - PSI2 ! Solid (NH4)2SO4 + CNH4NO3 = ZERO ! Solid NH4NO3 + CNH4CL = ZERO ! Solid NH4Cl +! + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +! +20 FUNCG3A = MOLAL(1)*MOLAL(4)/GHCL/A6 - ONE +!CC FUNCG3A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE +! + RETURN +! +! *** END OF FUNCTION FUNCG3A ******************************************* +! + END FUNCTION FUNCG3A + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCG2 +! *** CASE G2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. LIQUID & SOLID PHASE ARE BOTH POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCG2 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL CALCG1A, CALCG3A, CALCG4 +! +! *** REGIME DEPENDS ON THE EXISTANCE OF NITRATES *********************** +! + IF (W(4).GT.TINY) THEN ! NO3 EXISTS, WATER POSSIBLE + SCASE = 'G2 ; SUBCASE 1' + CALL CALCG2A + SCASE = 'G2 ; SUBCASE 1' + ELSE ! NO3 NON EXISTANT, WATER NOT POSSIBLE + SCASE = 'G1 ; SUBCASE 1' + CALL CALCG1A + SCASE = 'G1 ; SUBCASE 1' + ENDIF +! +! *** REGIME DEPENDS ON THE EXISTANCE OF WATER AND OF THE RH ************ +! + IF (WATER.LE.TINY) THEN + IF (RH.LT.DRMG2) THEN ! ONLY SOLIDS + WATER = TINY + DO 10 I=1,NIONS + MOLAL(I) = ZERO +10 CONTINUE + CALL CALCG1A + SCASE = 'G2 ; SUBCASE 2' + ELSE + IF (W(5).GT. TINY) THEN + SCASE = 'G2 ; SUBCASE 3' ! MDRH (NH4CL, NA2SO4, NH42S4) + CALL CALCMDRH (RH, DRMG2, DRNH4CL, CALCG1A, CALCG3A) + SCASE = 'G2 ; SUBCASE 3' + ENDIF + IF (WATER.LE.TINY .AND. RH.GE.DRMG3) THEN + SCASE = 'G2 ; SUBCASE 4' ! MDRH (NA2SO4, NH42S4) + CALL CALCMDRH (RH, DRMG3, DRNH42S4, CALCG1A, CALCG4) + SCASE = 'G2 ; SUBCASE 4' + ELSE + WATER = TINY + DO 20 I=1,NIONS + MOLAL(I) = ZERO +20 CONTINUE + CALL CALCG1A + SCASE = 'G2 ; SUBCASE 2' + ENDIF + ENDIF + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCG2 ****************************************** +! + END SUBROUTINE CALCG2 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCG2A +! *** CASE G2 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCG2A + USE ISRPIA + USE CASEG + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! DOUBLE PRECISION LAMDA +! COMMON /CASEG/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, LAMDA, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, & +! A1, A2, A3, A4, A5, A6, A7 +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU = .TRUE. + CHI1 = 0.5*W(1) + CHI2 = MAX (W(2)-CHI1, ZERO) + CHI3 = ZERO + CHI4 = MAX (W(3)-2.D0*CHI2, ZERO) + CHI5 = W(4) + CHI6 = W(5) +! + PSI6LO = TINY + PSI6HI = CHI6-TINY +! + WATER = TINY +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI6LO + Y1 = FUNCG2A (X1) + IF (CHI6.LE.TINY) GOTO 50 +!CC IF (ABS(Y1).LE.EPS .OR. CHI6.LE.TINY) GOTO 50 +!CC IF (WATER .LE. TINY) GOTO 50 ! No water +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI6HI-PSI6LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCG2A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCG2A (X) + USE ISRPIA + USE CASEG + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! DOUBLE PRECISION LAMDA +! COMMON /CASEG/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, LAMDA, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, & +! A1, A2, A3, A4, A5, A6, A7 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI6 = X + PSI2 = CHI2 + PSI3 = ZERO + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A1 = XK5 *(WATER/GAMA(2))**3.0 + A2 = XK7 *(WATER/GAMA(4))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 +! + DENO = MAX(CHI6-PSI6-PSI3, ZERO) + PSI5 = CHI5/((A6/A5)*(DENO/PSI6) + ONE) +! + PSI4 = MIN(PSI5+PSI6,CHI4) +! + IF (CHI2.GT.TINY .AND. WATER.GT.TINY) THEN + CALL POLY3 (PSI4, PSI4*PSI4/4.D0, -A2/4.D0, PSI20, ISLV) + IF (ISLV.EQ.0) PSI2 = MIN (PSI20, CHI2) + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL (2) = ZERO ! NA + MOLAL (3) = 2.0*PSI2 + PSI4 ! NH4I + MOLAL (4) = PSI6 ! CLI + MOLAL (5) = PSI2 ! SO4I + MOLAL (6) = ZERO ! HSO4 + MOLAL (7) = PSI5 ! NO3I +! +!CC MOLAL (1) = MAX(CHI5 - PSI5, TINY)*A5/PSI5 ! HI + SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! + GNH3 = MAX(CHI4 - PSI4, TINY) + GHNO3 = MAX(CHI5 - PSI5, TINY) + GHCL = MAX(CHI6 - PSI6, TINY) +! + CNH42S4 = MAX(CHI2 - PSI2, ZERO) + CNH4NO3 = ZERO +! +! *** NH4Cl(s) calculations +! + A3 = XK6 /(R*TEMP*R*TEMP) + IF (GNH3*GHCL.GT.A3) THEN + DELT = MIN(GNH3, GHCL) + BB = -(GNH3+GHCL) + CC = GNH3*GHCL-A3 + DD = BB*BB - 4.D0*CC + PSI31 = 0.5D0*(-BB + SQRT(DD)) + PSI32 = 0.5D0*(-BB - SQRT(DD)) + IF (DELT-PSI31.GT.ZERO .AND. PSI31.GT.ZERO) THEN + PSI3 = PSI31 + ELSEIF (DELT-PSI32.GT.ZERO .AND. PSI32.GT.ZERO) THEN + PSI3 = PSI32 + ELSE + PSI3 = ZERO + ENDIF + ELSE + PSI3 = ZERO + ENDIF +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! + GNH3 = MAX(GNH3 - PSI3, TINY) + GHCL = MAX(GHCL - PSI3, TINY) + CNH4CL = PSI3 +! +! *** CALCULATE MOLALR ARRAY, WATER AND ACTIVITIES ********************** +! + CALL CALCMR +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +! +20 IF (CHI4.LE.TINY) THEN + FUNCG2A = MOLAL(1)*MOLAL(4)/GHCL/A6 - ONE + ELSE + FUNCG2A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE + ENDIF +! + RETURN +! +! *** END OF FUNCTION FUNCG2A ******************************************* +! + END FUNCTION FUNCG2A + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCG1 +! *** CASE G1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4NO3, NH4CL, NA2SO4 +! +! THERE ARE TWO POSSIBLE REGIMES HERE, DEPENDING ON RELATIVE HUMIDITY: +! 1. WHEN RH >= MDRH ; LIQUID PHASE POSSIBLE (MDRH REGION) +! 2. WHEN RH < MDRH ; ONLY SOLID PHASE POSSIBLE (SUBROUTINE CALCG1A) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCG1 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL CALCG1A, CALCG2A +! +! *** REGIME DEPENDS UPON THE AMBIENT RELATIVE HUMIDITY ***************** +! + IF (RH.LT.DRMG1) THEN + SCASE = 'G1 ; SUBCASE 1' + CALL CALCG1A ! SOLID PHASE ONLY POSSIBLE + SCASE = 'G1 ; SUBCASE 1' + ELSE + SCASE = 'G1 ; SUBCASE 2' ! LIQUID & SOLID PHASE POSSIBLE + CALL CALCMDRH (RH, DRMG1, DRNH4NO3, CALCG1A, CALCG2A) + SCASE = 'G1 ; SUBCASE 2' + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCG1 ****************************************** +! + END SUBROUTINE CALCG1 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCG1A +! *** CASE G1 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4NO3 +! +! SOLID (NH4)2SO4 IS CALCULATED FROM THE SULFATES, WHILE NH4NO3 +! IS CALCULATED FROM NH3-HNO3 EQUILIBRIUM. 'ZE' IS THE AMOUNT OF +! NH4NO3 THAT VOLATIZES WHEN ALL POSSILBE NH4NO3 IS INITIALLY IN +! THE SOLID PHASE. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCG1A + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION LAMDA, LAMDA1, LAMDA2, KAPA, KAPA1, KAPA2 +! +! *** CALCULATE NON VOLATILE SOLIDS *********************************** +! + CNA2SO4 = 0.5*W(1) + CNH42S4 = W(2) - CNA2SO4 +! +! *** CALCULATE VOLATILE SPECIES ************************************** +! + ALF = W(3) - 2.0*CNH42S4 + BET = W(5) + GAM = W(4) +! + RTSQ = R*TEMP*R*TEMP + A1 = XK6/RTSQ + A2 = XK10/RTSQ +! + THETA1 = GAM - BET*(A2/A1) + THETA2 = A2/A1 +! +! QUADRATIC EQUATION SOLUTION +! + BB = (THETA1-ALF-BET*(ONE+THETA2))/(ONE+THETA2) + CC = (ALF*BET-A1-BET*THETA1)/(ONE+THETA2) + DD = BB*BB - 4.0D0*CC + IF (DD.LT.ZERO) GOTO 100 ! Solve each reaction seperately +! +! TWO ROOTS FOR KAPA, CHECK AND SEE IF ANY VALID +! + SQDD = SQRT(DD) + KAPA1 = 0.5D0*(-BB+SQDD) + KAPA2 = 0.5D0*(-BB-SQDD) + LAMDA1 = THETA1 + THETA2*KAPA1 + LAMDA2 = THETA1 + THETA2*KAPA2 +! + IF (KAPA1.GE.ZERO .AND. LAMDA1.GE.ZERO) THEN + IF (ALF-KAPA1-LAMDA1.GE.ZERO .AND. & + BET-KAPA1.GE.ZERO .AND. GAM-LAMDA1.GE.ZERO) THEN + KAPA = KAPA1 + LAMDA= LAMDA1 + GOTO 200 + ENDIF + ENDIF +! + IF (KAPA2.GE.ZERO .AND. LAMDA2.GE.ZERO) THEN + IF (ALF-KAPA2-LAMDA2.GE.ZERO .AND. & + BET-KAPA2.GE.ZERO .AND. GAM-LAMDA2.GE.ZERO) THEN + KAPA = KAPA2 + LAMDA= LAMDA2 + GOTO 200 + ENDIF + ENDIF +! +! SEPERATE SOLUTION OF NH4CL & NH4NO3 EQUILIBRIA +! +100 KAPA = ZERO + LAMDA = ZERO + DD1 = (ALF+BET)*(ALF+BET) - 4.0D0*(ALF*BET-A1) + DD2 = (ALF+GAM)*(ALF+GAM) - 4.0D0*(ALF*GAM-A2) +! +! NH4CL EQUILIBRIUM +! + IF (DD1.GE.ZERO) THEN + SQDD1 = SQRT(DD1) + KAPA1 = 0.5D0*(ALF+BET + SQDD1) + KAPA2 = 0.5D0*(ALF+BET - SQDD1) +! + IF (KAPA1.GE.ZERO .AND. KAPA1.LE.MIN(ALF,BET)) THEN + KAPA = KAPA1 + ELSE IF (KAPA2.GE.ZERO .AND. KAPA2.LE.MIN(ALF,BET)) THEN + KAPA = KAPA2 + ELSE + KAPA = ZERO + ENDIF + ENDIF +! +! NH4NO3 EQUILIBRIUM +! + IF (DD2.GE.ZERO) THEN + SQDD2 = SQRT(DD2) + LAMDA1= 0.5D0*(ALF+GAM + SQDD2) + LAMDA2= 0.5D0*(ALF+GAM - SQDD2) +! + IF (LAMDA1.GE.ZERO .AND. LAMDA1.LE.MIN(ALF,GAM)) THEN + LAMDA = LAMDA1 + ELSE IF (LAMDA2.GE.ZERO .AND. LAMDA2.LE.MIN(ALF,GAM)) THEN + LAMDA = LAMDA2 + ELSE + LAMDA = ZERO + ENDIF + ENDIF +! +! IF BOTH KAPA, LAMDA ARE > 0, THEN APPLY EXISTANCE CRITERION +! + IF (KAPA.GT.ZERO .AND. LAMDA.GT.ZERO) THEN + IF (BET .LT. LAMDA/THETA1) THEN + KAPA = ZERO + ELSE + LAMDA= ZERO + ENDIF + ENDIF +! +! *** CALCULATE COMPOSITION OF VOLATILE SPECIES *********************** +! +200 CONTINUE + CNH4NO3 = LAMDA + CNH4CL = KAPA +! + GNH3 = MAX(ALF - KAPA - LAMDA, ZERO) + GHNO3 = MAX(GAM - LAMDA, ZERO) + GHCL = MAX(BET - KAPA, ZERO) +! + RETURN +! +! *** END OF SUBROUTINE CALCG1A ***************************************** +! + END SUBROUTINE CALCG1A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCH6 +! *** CASE H6 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCH6 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU = .TRUE. + CHI1 = W(2) ! CNA2SO4 + CHI2 = ZERO ! CNH42S4 + CHI3 = ZERO ! CNH4CL + FRNA = MAX (W(1)-2.D0*CHI1, ZERO) + CHI8 = MIN (FRNA, W(4)) ! CNANO3 + CHI4 = W(3) ! NH3(g) + CHI5 = MAX (W(4)-CHI8, ZERO) ! HNO3(g) + CHI7 = MIN (MAX(FRNA-CHI8, ZERO), W(5)) ! CNACL + CHI6 = MAX (W(5)-CHI7, ZERO) ! HCL(g) +! + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI6LO + Y1 = FUNCH6A (X1) + IF (ABS(Y1).LE.EPS .OR. CHI6.LE.TINY) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI6HI-PSI6LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCH6A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCH6A (X) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI6 = X + PSI1 = CHI1 + PSI2 = ZERO + PSI3 = ZERO + PSI7 = CHI7 + PSI8 = CHI8 + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A1 = XK5 *(WATER/GAMA(2))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 + A7 = XK8 *(WATER/GAMA(1))**2.0 + A8 = XK9 *(WATER/GAMA(3))**2.0 + A9 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. +! +! CALCULATE DISSOCIATION QUANTITIES +! + PSI5 = CHI5*(PSI6+PSI7) - A6/A5*PSI8*(CHI6-PSI6-PSI3) + PSI5 = PSI5/(A6/A5*(CHI6-PSI6-PSI3) + PSI6 + PSI7) + PSI5 = MAX(PSI5, TINY) +! + IF (W(3).GT.TINY .AND. WATER.GT.TINY) THEN ! First try 3rd order soln + BB =-(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) + DD = BB*BB-4.d0*CC + PSI4 =0.5d0*(-BB - SQRT(DD)) + PSI4 = MIN(PSI4,CHI4) + ELSE + PSI4 = TINY + ENDIF +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (2) = PSI8 + PSI7 + 2.D0*PSI1 ! NAI + MOLAL (3) = PSI4 ! NH4I + MOLAL (4) = PSI6 + PSI7 ! CLI + MOLAL (5) = PSI2 + PSI1 ! SO4I + MOLAL (6) = ZERO ! HSO4I + MOLAL (7) = PSI5 + PSI8 ! NO3I +! + SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +! + GNH3 = MAX(CHI4 - PSI4, TINY) + GHNO3 = MAX(CHI5 - PSI5, TINY) + GHCL = MAX(CHI6 - PSI6, TINY) +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNACL = MAX(CHI7 - PSI7, ZERO) + CNANO3 = MAX(CHI8 - PSI8, ZERO) + CNA2SO4 = MAX(CHI1 - PSI1, ZERO) +! + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +! +20 FUNCH6A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE +! + RETURN +! +! *** END OF FUNCTION FUNCH6A ******************************************* +! + END FUNCTION FUNCH6A + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCH5 +! *** CASE H5 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCH5 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** REGIME DEPENDS ON THE EXISTANCE OF NITRATES *********************** +! + IF (W(4).LE.TINY .AND. W(5).LE.TINY) THEN + SCASE = 'H5' + CALL CALCH1A + SCASE = 'H5' + RETURN + ENDIF +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU = .TRUE. + CHI1 = W(2) ! CNA2SO4 + CHI2 = ZERO ! CNH42S4 + CHI3 = ZERO ! CNH4CL + FRNA = MAX (W(1)-2.D0*CHI1, ZERO) + CHI8 = MIN (FRNA, W(4)) ! CNANO3 + CHI4 = W(3) ! NH3(g) + CHI5 = MAX (W(4)-CHI8, ZERO) ! HNO3(g) + CHI7 = MIN (MAX(FRNA-CHI8, ZERO), W(5)) ! CNACL + CHI6 = MAX (W(5)-CHI7, ZERO) ! HCL(g) +! + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI6LO + Y1 = FUNCH5A (X1) + IF (ABS(Y1).LE.EPS .OR. CHI6.LE.TINY) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI6HI-PSI6LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCH5A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : NONE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCH5A (X) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI6 = X + PSI1 = CHI1 + PSI2 = ZERO + PSI3 = ZERO + PSI7 = CHI7 + PSI8 = CHI8 + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A1 = XK5 *(WATER/GAMA(2))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 + A7 = XK8 *(WATER/GAMA(1))**2.0 + A8 = XK9 *(WATER/GAMA(3))**2.0 + A9 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. +! +! CALCULATE DISSOCIATION QUANTITIES +! + PSI5 = CHI5*(PSI6+PSI7) - A6/A5*PSI8*(CHI6-PSI6-PSI3) + PSI5 = PSI5/(A6/A5*(CHI6-PSI6-PSI3) + PSI6 + PSI7) + PSI5 = MAX(PSI5, TINY) +! + IF (W(3).GT.TINY .AND. WATER.GT.TINY) THEN ! First try 3rd order soln + BB =-(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) + DD = BB*BB-4.d0*CC + PSI4 =0.5d0*(-BB - SQRT(DD)) + PSI4 = MIN(PSI4,CHI4) + ELSE + PSI4 = TINY + ENDIF +! + IF (CHI1.GT.TINY .AND. WATER.GT.TINY) THEN ! NA2SO4 DISSOLUTION + AA = PSI7+PSI8 + BB = AA*AA + CC =-A1/4.D0 + CALL POLY3 (AA, BB, CC, PSI1, ISLV) + IF (ISLV.EQ.0) THEN + PSI1 = MIN (PSI1, CHI1) + ELSE + PSI1 = ZERO + ENDIF + ENDIF +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (2) = PSI8 + PSI7 + 2.D0*PSI1 ! NAI + MOLAL (3) = PSI4 ! NH4I + MOLAL (4) = PSI6 + PSI7 ! CLI + MOLAL (5) = PSI2 + PSI1 ! SO4I + MOLAL (6) = ZERO + MOLAL (7) = PSI5 + PSI8 ! NO3I +! + SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +! + GNH3 = MAX(CHI4 - PSI4, TINY) + GHNO3 = MAX(CHI5 - PSI5, TINY) + GHCL = MAX(CHI6 - PSI6, TINY) +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNACL = MAX(CHI7 - PSI7, ZERO) + CNANO3 = MAX(CHI8 - PSI8, ZERO) + CNA2SO4 = MAX(CHI1 - PSI1, ZERO) +! + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +! +20 FUNCH5A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE +! + RETURN +! +! *** END OF FUNCTION FUNCH5A ******************************************* +! + END FUNCTION FUNCH5A + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCH4 +! *** CASE H4 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCH4 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** REGIME DEPENDS ON THE EXISTANCE OF NITRATES *********************** +! + IF (W(4).LE.TINY .AND. W(5).LE.TINY) THEN + SCASE = 'H4' + CALL CALCH1A + SCASE = 'H4' + RETURN + ENDIF +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU = .TRUE. + CHI1 = W(2) ! CNA2SO4 + CHI2 = ZERO ! CNH42S4 + CHI3 = ZERO ! CNH4CL + FRNA = MAX (W(1)-2.D0*CHI1, ZERO) + CHI8 = MIN (FRNA, W(4)) ! CNANO3 + CHI4 = W(3) ! NH3(g) + CHI5 = MAX (W(4)-CHI8, ZERO) ! HNO3(g) + CHI7 = MIN (MAX(FRNA-CHI8, ZERO), W(5)) ! CNACL + CHI6 = MAX (W(5)-CHI7, ZERO) ! HCL(g) +! + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI6LO + Y1 = FUNCH4A (X1) + IF (ABS(Y1).LE.EPS .OR. CHI6.LE.TINY) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI6HI-PSI6LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCH4A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCH4A (X) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI6 = X + PSI1 = CHI1 + PSI2 = ZERO + PSI3 = ZERO + PSI7 = CHI7 + PSI8 = CHI8 + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A1 = XK5 *(WATER/GAMA(2))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 + A7 = XK8 *(WATER/GAMA(1))**2.0 + A8 = XK9 *(WATER/GAMA(3))**2.0 + A9 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. +! +! CALCULATE DISSOCIATION QUANTITIES +! + PSI5 = CHI5*(PSI6+PSI7) - A6/A5*PSI8*(CHI6-PSI6-PSI3) + PSI5 = PSI5/(A6/A5*(CHI6-PSI6-PSI3) + PSI6 + PSI7) + PSI5 = MAX(PSI5, TINY) +! + IF (W(3).GT.TINY .AND. WATER.GT.TINY) THEN ! First try 3rd order soln + BB =-(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) + DD = BB*BB-4.d0*CC + PSI4 =0.5d0*(-BB - SQRT(DD)) + PSI4 = MIN(PSI4,CHI4) + ELSE + PSI4 = TINY + ENDIF +! + IF (CHI1.GT.TINY .AND. WATER.GT.TINY) THEN ! NA2SO4 DISSOLUTION + AA = PSI7+PSI8 + BB = AA*AA + CC =-A1/4.D0 + CALL POLY3 (AA, BB, CC, PSI1, ISLV) + IF (ISLV.EQ.0) THEN + PSI1 = MIN (PSI1, CHI1) + ELSE + PSI1 = ZERO + ENDIF + ENDIF +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (2) = PSI8 + PSI7 + 2.D0*PSI1 ! NAI + MOLAL (3) = PSI4 ! NH4I + MOLAL (4) = PSI6 + PSI7 ! CLI + MOLAL (5) = PSI2 + PSI1 ! SO4I + MOLAL (6) = ZERO + MOLAL (7) = PSI5 + PSI8 ! NO3I +! + SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! + GNH3 = MAX(CHI4 - PSI4, TINY) + GHNO3 = MAX(CHI5 - PSI5, TINY) + GHCL = MAX(CHI6 - PSI6, TINY) +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNACL = MAX(CHI7 - PSI7, ZERO) + CNANO3 = MAX(CHI8 - PSI8, ZERO) + CNA2SO4 = MAX(CHI1 - PSI1, ZERO) +! +! *** NH4Cl(s) calculations +! + A3 = XK6 /(R*TEMP*R*TEMP) + DELT = MIN(GNH3, GHCL) + BB = -(GNH3+GHCL) + CC = GNH3*GHCL-A3 + DD = BB*BB - 4.D0*CC + PSI31 = 0.5D0*(-BB + SQRT(DD)) + PSI32 = 0.5D0*(-BB - SQRT(DD)) + IF (DELT-PSI31.GT.ZERO .AND. PSI31.GT.ZERO) THEN + PSI3 = PSI31 + ELSEIF (DELT-PSI32.GT.ZERO .AND. PSI32.GT.ZERO) THEN + PSI3 = PSI32 + ELSE + PSI3 = ZERO + ENDIF +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! + GNH3 = MAX(GNH3 - PSI3, TINY) + GHCL = MAX(GHCL - PSI3, TINY) + CNH4CL = PSI3 +! + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +! +20 FUNCH4A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE +! + RETURN +! +! *** END OF FUNCTION FUNCH4A ******************************************* +! + END FUNCTION FUNCH4A + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCH3 +! *** CASE H3 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCH3 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** REGIME DEPENDS ON THE EXISTANCE OF NITRATES *********************** +! + IF (W(4).LE.TINY) THEN ! NO3 NOT EXIST, WATER NOT POSSIBLE + SCASE = 'H3' + CALL CALCH1A + SCASE = 'H3' + RETURN + ENDIF +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU = .TRUE. + CHI1 = W(2) ! CNA2SO4 + CHI2 = ZERO ! CNH42S4 + CHI3 = ZERO ! CNH4CL + FRNA = MAX (W(1)-2.D0*CHI1, ZERO) + CHI8 = MIN (FRNA, W(4)) ! CNANO3 + CHI4 = W(3) ! NH3(g) + CHI5 = MAX (W(4)-CHI8, ZERO) ! HNO3(g) + CHI7 = MIN (MAX(FRNA-CHI8, ZERO), W(5)) ! CNACL + CHI6 = MAX (W(5)-CHI7, ZERO) ! HCL(g) +! + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI6LO + Y1 = FUNCH3A (X1) + IF (ABS(Y1).LE.EPS .OR. CHI6.LE.TINY) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI6HI-PSI6LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCH3A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCH3A (X) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI6 = X + PSI1 = CHI1 + PSI2 = ZERO + PSI3 = ZERO + PSI7 = CHI7 + PSI8 = CHI8 + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A1 = XK5 *(WATER/GAMA(2))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 + A7 = XK8 *(WATER/GAMA(1))**2.0 + A8 = XK9 *(WATER/GAMA(3))**2.0 + A9 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. +! +! CALCULATE DISSOCIATION QUANTITIES +! + PSI5 = CHI5*(PSI6+PSI7) - A6/A5*PSI8*(CHI6-PSI6-PSI3) + PSI5 = PSI5/(A6/A5*(CHI6-PSI6-PSI3) + PSI6 + PSI7) + PSI5 = MAX(PSI5, TINY) +! + IF (W(3).GT.TINY .AND. WATER.GT.TINY) THEN ! First try 3rd order soln + BB =-(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) + DD = BB*BB-4.d0*CC + PSI4 =0.5d0*(-BB - SQRT(DD)) + PSI4 = MIN(PSI4,CHI4) + ELSE + PSI4 = TINY + ENDIF +! + IF (CHI7.GT.TINY .AND. WATER.GT.TINY) THEN ! NACL DISSOLUTION + DIAK = (PSI8-PSI6)**2.D0 + 4.D0*A7 + PSI7 = 0.5D0*( -(PSI8+PSI6) + SQRT(DIAK) ) + PSI7 = MAX(MIN(PSI7, CHI7), ZERO) + ENDIF +! + IF (CHI1.GT.TINY .AND. WATER.GT.TINY) THEN ! NA2SO4 DISSOLUTION + AA = PSI7+PSI8 + BB = AA*AA + CC =-A1/4.D0 + CALL POLY3 (AA, BB, CC, PSI1, ISLV) + IF (ISLV.EQ.0) THEN + PSI1 = MIN (PSI1, CHI1) + ELSE + PSI1 = ZERO + ENDIF + ENDIF +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (2) = PSI8 + PSI7 + 2.D0*PSI1 ! NAI + MOLAL (3) = PSI4 ! NH4I + MOLAL (4) = PSI6 + PSI7 ! CLI + MOLAL (5) = PSI2 + PSI1 ! SO4I + MOLAL (6) = ZERO + MOLAL (7) = PSI5 + PSI8 ! NO3I +! + SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! + GNH3 = MAX(CHI4 - PSI4, TINY) + GHNO3 = MAX(CHI5 - PSI5, TINY) + GHCL = MAX(CHI6 - PSI6, TINY) +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNACL = MAX(CHI7 - PSI7, ZERO) + CNANO3 = MAX(CHI8 - PSI8, ZERO) + CNA2SO4 = MAX(CHI1 - PSI1, ZERO) +! +! *** NH4Cl(s) calculations +! + A3 = XK6 /(R*TEMP*R*TEMP) + DELT = MIN(GNH3, GHCL) + BB = -(GNH3+GHCL) + CC = GNH3*GHCL-A3 + DD = BB*BB - 4.D0*CC + PSI31 = 0.5D0*(-BB + SQRT(DD)) + PSI32 = 0.5D0*(-BB - SQRT(DD)) + IF (DELT-PSI31.GT.ZERO .AND. PSI31.GT.ZERO) THEN + PSI3 = PSI31 + ELSEIF (DELT-PSI32.GT.ZERO .AND. PSI32.GT.ZERO) THEN + PSI3 = PSI32 + ELSE + PSI3 = ZERO + ENDIF +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! + GNH3 = MAX(GNH3 - PSI3, TINY) + GHCL = MAX(GHCL - PSI3, TINY) + CNH4CL = PSI3 +! + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +! +20 FUNCH3A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A6/A4 - ONE +! + RETURN +! +! *** END OF FUNCTION FUNCH3A ******************************************* +! + END FUNCTION FUNCH3A + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCH2 +! *** CASE H2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : NH4Cl, NA2SO4, NANO3, NACL +! +! THERE ARE THREE REGIMES IN THIS CASE: +! 1. NH4NO3(s) POSSIBLE. LIQUID & SOLID AEROSOL (SUBROUTINE CALCH2A) +! 2. NH4NO3(s) NOT POSSIBLE, AND RH < MDRH. SOLID AEROSOL ONLY +! 3. NH4NO3(s) NOT POSSIBLE, AND RH >= MDRH. (MDRH REGION) +! +! REGIMES 2. AND 3. ARE CONSIDERED TO BE THE SAME AS CASES H1A, H2B +! RESPECTIVELY (BECAUSE MDRH POINTS COINCIDE). +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCH2 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL CALCH1A, CALCH3 +! +! *** REGIME DEPENDS ON THE EXISTANCE OF NITRATES *********************** +! + IF (W(4).GT.TINY) THEN ! NO3 EXISTS, WATER POSSIBLE + SCASE = 'H2 ; SUBCASE 1' + CALL CALCH2A + SCASE = 'H2 ; SUBCASE 1' + ELSE ! NO3 NON EXISTANT, WATER NOT POSSIBLE + SCASE = 'H2 ; SUBCASE 1' + CALL CALCH1A + SCASE = 'H2 ; SUBCASE 1' + ENDIF +! + IF (WATER.LE.TINY .AND. RH.LT.DRMH2) THEN ! DRY AEROSOL + SCASE = 'H2 ; SUBCASE 2' +! + ELSEIF (WATER.LE.TINY .AND. RH.GE.DRMH2) THEN ! MDRH OF H2 + SCASE = 'H2 ; SUBCASE 3' + CALL CALCMDRH (RH, DRMH2, DRNANO3, CALCH1A, CALCH3) + SCASE = 'H2 ; SUBCASE 3' + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCH2 ****************************************** +! + END SUBROUTINE CALCH2 + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCH2A +! *** CASE H2 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCH2A + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU = .TRUE. + CHI1 = W(2) ! CNA2SO4 + CHI2 = ZERO ! CNH42S4 + CHI3 = ZERO ! CNH4CL + FRNA = MAX (W(1)-2.D0*CHI1, ZERO) + CHI8 = MIN (FRNA, W(4)) ! CNANO3 + CHI4 = W(3) ! NH3(g) + CHI5 = MAX (W(4)-CHI8, ZERO) ! HNO3(g) + CHI7 = MIN (MAX(FRNA-CHI8, ZERO), W(5)) ! CNACL + CHI6 = MAX (W(5)-CHI7, ZERO) ! HCL(g) +! + PSI6LO = TINY + PSI6HI = CHI6-TINY ! MIN(CHI6-TINY, CHI4) +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI6LO + Y1 = FUNCH2A (X1) + IF (ABS(Y1).LE.EPS .OR. CHI6.LE.TINY) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI6HI-PSI6LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1+DX + Y2 = FUNCH2A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION; IF ABS(Y2) 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCH2A (X) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI6 = X + PSI1 = CHI1 + PSI2 = ZERO + PSI3 = ZERO + PSI7 = CHI7 + PSI8 = CHI8 + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A1 = XK5 *(WATER/GAMA(2))**3.0 + A4 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2.0 + A5 = XK4 *R*TEMP*(WATER/GAMA(10))**2.0 + A6 = XK3 *R*TEMP*(WATER/GAMA(11))**2.0 + A7 = XK8 *(WATER/GAMA(1))**2.0 + A8 = XK9 *(WATER/GAMA(3))**2.0 + A64 = (XK3*XK2/XKW)*(GAMA(10)/GAMA(5)/GAMA(11))**2.0 + A64 = A64*(R*TEMP*WATER)**2.0 + A9 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. +! +! CALCULATE DISSOCIATION QUANTITIES +! + PSI5 = CHI5*(PSI6+PSI7) - A6/A5*PSI8*(CHI6-PSI6-PSI3) + PSI5 = PSI5/(A6/A5*(CHI6-PSI6-PSI3) + PSI6 + PSI7) + PSI5 = MAX(PSI5, TINY) +! + IF (W(3).GT.TINY .AND. WATER.GT.TINY) THEN ! First try 3rd order soln + BB =-(CHI4 + PSI6 + PSI5 + 1.d0/A4) + CC = CHI4*(PSI5+PSI6) + DD = BB*BB-4.d0*CC + PSI4 =0.5d0*(-BB - SQRT(DD)) + PSI4 = MIN(PSI4,CHI4) + ELSE + PSI4 = TINY + ENDIF +! + IF (CHI7.GT.TINY .AND. WATER.GT.TINY) THEN ! NACL DISSOLUTION + DIAK = (PSI8-PSI6)**2.D0 + 4.D0*A7 + PSI7 = 0.5D0*( -(PSI8+PSI6) + SQRT(DIAK) ) + PSI7 = MAX(MIN(PSI7, CHI7), ZERO) + ENDIF +! + IF (CHI8.GT.TINY .AND. WATER.GT.TINY) THEN ! NANO3 DISSOLUTION + DIAK = (PSI7-PSI5)**2.D0 + 4.D0*A8 + PSI8 = 0.5D0*( -(PSI7+PSI5) + SQRT(DIAK) ) + PSI8 = MAX(MIN(PSI8, CHI8), ZERO) + ENDIF +! + IF (CHI1.GT.TINY .AND. WATER.GT.TINY) THEN ! NA2SO4 DISSOLUTION + AA = PSI7+PSI8 + BB = AA*AA + CC =-A1/4.D0 + CALL POLY3 (AA, BB, CC, PSI1, ISLV) + IF (ISLV.EQ.0) THEN + PSI1 = MIN (PSI1, CHI1) + ELSE + PSI1 = ZERO + ENDIF + ENDIF +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (2) = PSI8 + PSI7 + 2.D0*PSI1 ! NAI + MOLAL (3) = PSI4 ! NH4I + MOLAL (4) = PSI6 + PSI7 ! CLI + MOLAL (5) = PSI2 + PSI1 ! SO4I + MOLAL (6) = ZERO ! HSO4I + MOLAL (7) = PSI5 + PSI8 ! NO3I +! + SMIN = 2.d0*MOLAL(5)+MOLAL(7)+MOLAL(4)-MOLAL(2)-MOLAL(3) + CALL CALCPH (SMIN, HI, OHI) + MOLAL (1) = HI +! + GNH3 = MAX(CHI4 - PSI4, TINY) + GHNO3 = MAX(CHI5 - PSI5, TINY) + GHCL = MAX(CHI6 - PSI6, TINY) +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNACL = MAX(CHI7 - PSI7, ZERO) + CNANO3 = MAX(CHI8 - PSI8, ZERO) + CNA2SO4 = MAX(CHI1 - PSI1, ZERO) +! +! *** NH4Cl(s) calculations +! + A3 = XK6 /(R*TEMP*R*TEMP) + DELT = MIN(GNH3, GHCL) + BB = -(GNH3+GHCL) + CC = GNH3*GHCL-A3 + DD = BB*BB - 4.D0*CC + PSI31 = 0.5D0*(-BB + SQRT(DD)) + PSI32 = 0.5D0*(-BB - SQRT(DD)) + IF (DELT-PSI31.GT.ZERO .AND. PSI31.GT.ZERO) THEN + PSI3 = PSI31 + ELSEIF (DELT-PSI32.GT.ZERO .AND. PSI32.GT.ZERO) THEN + PSI3 = PSI32 + ELSE + PSI3 = ZERO + ENDIF +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! + GNH3 = MAX(GNH3 - PSI3, TINY) + GHCL = MAX(GHCL - PSI3, TINY) + CNH4CL = PSI3 +! + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +! +20 FUNCH2A = MOLAL(3)*MOLAL(4)/GHCL/GNH3/A64 - ONE +! + RETURN +! +! *** END OF FUNCTION FUNCH2A ******************************************* +! + END FUNCTION FUNCH2A + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCH1 +! *** CASE H1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : NH4NO3, NH4CL, NA2SO4 +! +! THERE ARE TWO POSSIBLE REGIMES HERE, DEPENDING ON RELATIVE HUMIDITY: +! 1. WHEN RH >= MDRH ; LIQUID PHASE POSSIBLE (MDRH REGION) +! 2. WHEN RH < MDRH ; ONLY SOLID PHASE POSSIBLE (SUBROUTINE CALCH1A) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCH1 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL CALCH1A, CALCH2A +! +! *** REGIME DEPENDS UPON THE AMBIENT RELATIVE HUMIDITY ***************** +! + IF (RH.LT.DRMH1) THEN + SCASE = 'H1 ; SUBCASE 1' + CALL CALCH1A ! SOLID PHASE ONLY POSSIBLE + SCASE = 'H1 ; SUBCASE 1' + ELSE + SCASE = 'H1 ; SUBCASE 2' ! LIQUID & SOLID PHASE POSSIBLE + CALL CALCMDRH (RH, DRMH1, DRNH4NO3, CALCH1A, CALCH2A) + SCASE = 'H1 ; SUBCASE 2' + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCH1 ****************************************** +! + END SUBROUTINE CALCH1 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCH1A +! *** CASE H1 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : NH4NO3, NH4CL, NANO3, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCH1A + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION LAMDA, LAMDA1, LAMDA2, KAPA, KAPA1, KAPA2, NAFR, & + NO3FR +! +! *** CALCULATE NON VOLATILE SOLIDS *********************************** +! + CNA2SO4 = W(2) + CNH42S4 = ZERO + NAFR = MAX (W(1)-2*CNA2SO4, ZERO) + CNANO3 = MIN (NAFR, W(4)) + NO3FR = MAX (W(4)-CNANO3, ZERO) + CNACL = MIN (MAX(NAFR-CNANO3, ZERO), W(5)) + CLFR = MAX (W(5)-CNACL, ZERO) +! +! *** CALCULATE VOLATILE SPECIES ************************************** +! + ALF = W(3) ! FREE NH3 + BET = CLFR ! FREE CL + GAM = NO3FR ! FREE NO3 +! + RTSQ = R*TEMP*R*TEMP + A1 = XK6/RTSQ + A2 = XK10/RTSQ +! + THETA1 = GAM - BET*(A2/A1) + THETA2 = A2/A1 +! +! QUADRATIC EQUATION SOLUTION +! + BB = (THETA1-ALF-BET*(ONE+THETA2))/(ONE+THETA2) + CC = (ALF*BET-A1-BET*THETA1)/(ONE+THETA2) + DD = BB*BB - 4.0D0*CC + IF (DD.LT.ZERO) GOTO 100 ! Solve each reaction seperately +! +! TWO ROOTS FOR KAPA, CHECK AND SEE IF ANY VALID +! + SQDD = SQRT(DD) + KAPA1 = 0.5D0*(-BB+SQDD) + KAPA2 = 0.5D0*(-BB-SQDD) + LAMDA1 = THETA1 + THETA2*KAPA1 + LAMDA2 = THETA1 + THETA2*KAPA2 +! + IF (KAPA1.GE.ZERO .AND. LAMDA1.GE.ZERO) THEN + IF (ALF-KAPA1-LAMDA1.GE.ZERO .AND. & + BET-KAPA1.GE.ZERO .AND. GAM-LAMDA1.GE.ZERO) THEN + KAPA = KAPA1 + LAMDA= LAMDA1 + GOTO 200 + ENDIF + ENDIF +! + IF (KAPA2.GE.ZERO .AND. LAMDA2.GE.ZERO) THEN + IF (ALF-KAPA2-LAMDA2.GE.ZERO .AND. & + BET-KAPA2.GE.ZERO .AND. GAM-LAMDA2.GE.ZERO) THEN + KAPA = KAPA2 + LAMDA= LAMDA2 + GOTO 200 + ENDIF + ENDIF +! +! SEPERATE SOLUTION OF NH4CL & NH4NO3 EQUILIBRIA +! +100 KAPA = ZERO + LAMDA = ZERO + DD1 = (ALF+BET)*(ALF+BET) - 4.0D0*(ALF*BET-A1) + DD2 = (ALF+GAM)*(ALF+GAM) - 4.0D0*(ALF*GAM-A2) +! +! NH4CL EQUILIBRIUM +! + IF (DD1.GE.ZERO) THEN + SQDD1 = SQRT(DD1) + KAPA1 = 0.5D0*(ALF+BET + SQDD1) + KAPA2 = 0.5D0*(ALF+BET - SQDD1) +! + IF (KAPA1.GE.ZERO .AND. KAPA1.LE.MIN(ALF,BET)) THEN + KAPA = KAPA1 + ELSE IF (KAPA2.GE.ZERO .AND. KAPA2.LE.MIN(ALF,BET)) THEN + KAPA = KAPA2 + ELSE + KAPA = ZERO + ENDIF + ENDIF +! +! NH4NO3 EQUILIBRIUM +! + IF (DD2.GE.ZERO) THEN + SQDD2 = SQRT(DD2) + LAMDA1= 0.5D0*(ALF+GAM + SQDD2) + LAMDA2= 0.5D0*(ALF+GAM - SQDD2) +! + IF (LAMDA1.GE.ZERO .AND. LAMDA1.LE.MIN(ALF,GAM)) THEN + LAMDA = LAMDA1 + ELSE IF (LAMDA2.GE.ZERO .AND. LAMDA2.LE.MIN(ALF,GAM)) THEN + LAMDA = LAMDA2 + ELSE + LAMDA = ZERO + ENDIF + ENDIF +! +! IF BOTH KAPA, LAMDA ARE > 0, THEN APPLY EXISTANCE CRITERION +! + IF (KAPA.GT.ZERO .AND. LAMDA.GT.ZERO) THEN + IF (BET .LT. LAMDA/THETA1) THEN + KAPA = ZERO + ELSE + LAMDA= ZERO + ENDIF + ENDIF +! +! *** CALCULATE COMPOSITION OF VOLATILE SPECIES *********************** +! +200 CONTINUE + CNH4NO3 = LAMDA + CNH4CL = KAPA +! + GNH3 = ALF - KAPA - LAMDA + GHNO3 = GAM - LAMDA + GHCL = BET - KAPA +! + RETURN +! +! *** END OF SUBROUTINE CALCH1A ***************************************** +! + END SUBROUTINE CALCH1A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCI6 +! *** CASE I6 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCI6 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** FIND DRY COMPOSITION ********************************************** +! + CALL CALCI1A +! +! *** SETUP PARAMETERS ************************************************ +! + CHI1 = CNH4HS4 ! Save from CALCI1 run + CHI2 = CLC + CHI3 = CNAHSO4 + CHI4 = CNA2SO4 + CHI5 = CNH42S4 +! + PSI1 = CNH4HS4 ! ASSIGN INITIAL PSI's + PSI2 = CLC + PSI3 = CNAHSO4 + PSI4 = CNA2SO4 + PSI5 = CNH42S4 +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A6 = XK1 *WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. +! +! CALCULATE DISSOCIATION QUANTITIES +! + BB = PSI2 + PSI4 + PSI5 + A6 ! PSI6 + CC =-A6*(PSI2 + PSI3 + PSI1) + DD = BB*BB - 4.D0*CC + PSI6 = 0.5D0*(-BB + SQRT(DD)) +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (1) = PSI6 ! HI + MOLAL (2) = 2.D0*PSI4 + PSI3 ! NAI + MOLAL (3) = 3.D0*PSI2 + 2.D0*PSI5 + PSI1 ! NH4I + MOLAL (5) = PSI2 + PSI4 + PSI5 + PSI6 ! SO4I + MOLAL (6) = PSI2 + PSI3 + PSI1 - PSI6 ! HSO4I + CLC = ZERO + CNAHSO4 = ZERO + CNA2SO4 = CHI4 - PSI4 + CNH42S4 = ZERO + CNH4HS4 = ZERO + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +20 RETURN +! +! *** END OF SUBROUTINE CALCI6 ***************************************** +! + END SUBROUTINE CALCI6 + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCI5 +! *** CASE I5 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCI5 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** FIND DRY COMPOSITION ********************************************** +! + CALL CALCI1A +! +! *** SETUP PARAMETERS ************************************************ +! + CHI1 = CNH4HS4 ! Save from CALCI1 run + CHI2 = CLC + CHI3 = CNAHSO4 + CHI4 = CNA2SO4 + CHI5 = CNH42S4 +! + PSI1 = CNH4HS4 ! ASSIGN INITIAL PSI's + PSI2 = CLC + PSI3 = CNAHSO4 + PSI4 = ZERO + PSI5 = CNH42S4 +! + CALAOU =.TRUE. ! Outer loop activity calculation flag + PSI4LO = ZERO ! Low limit + PSI4HI = CHI4 ! High limit +! +! *** IF NA2SO4(S) =0, CALL FUNCI5B FOR Y4=0 *************************** +! + IF (CHI4.LE.TINY) THEN + Y1 = FUNCI5A (ZERO) + GOTO 50 + ENDIF +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI4HI + Y1 = FUNCI5A (X1) + YHI= Y1 ! Save Y-value at HI position +! +! *** YHI < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NA2SO4 ** +! + IF (ABS(Y1).LE.EPS .OR. YHI.LT.ZERO) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI4HI-PSI4LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1-DX + Y2 = FUNCI5A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NH4CL +! + YLO= Y1 ! Save Y-value at Hi position + IF (YLO.GT.ZERO .AND. YHI.GT.ZERO) THEN + Y3 = FUNCI5A (ZERO) + GOTO 50 + ELSE IF (ABS(Y2) .LT. EPS) THEN ! X2 IS A SOLUTION + GOTO 50 + ELSE + CALL PUSHERR (0001, 'CALCI5') ! WARNING ERROR: NO SOLUTION + GOTO 50 + ENDIF +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCI5A (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCI5') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCI5A (X3) +! +50 RETURN + +! *** END OF SUBROUTINE CALCI5 ***************************************** +! + END SUBROUTINE CALCI5 + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE FUNCI5A +! *** CASE I5 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCI5A (P4) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI4 = P4 ! PSI3 already assigned in FUNCI5A + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A4 = XK5 *(WATER/GAMA(2))**3.0 + A5 = XK7 *(WATER/GAMA(4))**3.0 + A6 = XK1 *WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. +! +! CALCULATE DISSOCIATION QUANTITIES +! + BB = PSI2 + PSI4 + PSI5 + A6 ! PSI6 + CC =-A6*(PSI2 + PSI3 + PSI1) + DD = BB*BB - 4.D0*CC + PSI6 = 0.5D0*(-BB + SQRT(DD)) +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (1) = PSI6 ! HI + MOLAL (2) = 2.D0*PSI4 + PSI3 ! NAI + MOLAL (3) = 3.D0*PSI2 + 2.D0*PSI5 + PSI1 ! NH4I + MOLAL (5) = PSI2 + PSI4 + PSI5 + PSI6 ! SO4I + MOLAL (6) = PSI2 + PSI3 + PSI1 - PSI6 ! HSO4I + CLC = ZERO + CNAHSO4 = ZERO + CNA2SO4 = CHI4 - PSI4 + CNH42S4 = ZERO + CNH4HS4 = ZERO + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE OBJECTIVE FUNCTION ************************************ +! +20 A4 = XK5 *(WATER/GAMA(2))**3.0 + FUNCI5A= MOLAL(5)*MOLAL(2)*MOLAL(2)/A4 - ONE + RETURN +! +! *** END OF FUNCTION FUNCI5A ******************************************** +! + END FUNCTION FUNCI5A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCI4 +! *** CASE I4 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCI4 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** FIND DRY COMPOSITION ********************************************** +! + CALL CALCI1A +! +! *** SETUP PARAMETERS ************************************************ +! + CHI1 = CNH4HS4 ! Save from CALCI1 run + CHI2 = CLC + CHI3 = CNAHSO4 + CHI4 = CNA2SO4 + CHI5 = CNH42S4 +! + PSI1 = CNH4HS4 ! ASSIGN INITIAL PSI's + PSI2 = CLC + PSI3 = CNAHSO4 + PSI4 = ZERO + PSI5 = ZERO +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + PSI4LO = ZERO ! Low limit + PSI4HI = CHI4 ! High limit +! +! *** IF NA2SO4(S) =0, CALL FUNCI4B FOR Y4=0 *************************** +! + IF (CHI4.LE.TINY) THEN + Y1 = FUNCI4A (ZERO) + GOTO 50 + ENDIF +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI4HI + Y1 = FUNCI4A (X1) + YHI= Y1 ! Save Y-value at HI position +! +! *** YHI < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NA2SO4 ** +! + IF (ABS(Y1).LE.EPS .OR. YHI.LT.ZERO) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI4HI-PSI4LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1-DX + Y2 = FUNCI4A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NH4CL +! + YLO= Y1 ! Save Y-value at Hi position + IF (YLO.GT.ZERO .AND. YHI.GT.ZERO) THEN + Y3 = FUNCI4A (ZERO) + GOTO 50 + ELSE IF (ABS(Y2) .LT. EPS) THEN ! X2 IS A SOLUTION + GOTO 50 + ELSE + CALL PUSHERR (0001, 'CALCI4') ! WARNING ERROR: NO SOLUTION + GOTO 50 + ENDIF +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCI4A (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCI4') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCI4A (X3) +! +50 RETURN + +! *** END OF SUBROUTINE CALCI4 ***************************************** +! + END SUBROUTINE CALCI4 + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE FUNCI4A +! *** CASE I4 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCI4A (P4) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI4 = P4 ! PSI3 already assigned in FUNCI4A + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A4 = XK5 *(WATER/GAMA(2))**3.0 + A5 = XK7 *(WATER/GAMA(4))**3.0 + A6 = XK1 *WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. + A7 = SQRT(A4/A5) +! +! CALCULATE DISSOCIATION QUANTITIES +! + BB = PSI2 + PSI4 + PSI5 + A6 ! PSI6 + CC =-A6*(PSI2 + PSI3 + PSI1) + DD = BB*BB - 4.D0*CC + PSI6 = 0.5D0*(-BB + SQRT(DD)) +! + PSI5 = (PSI3 + 2.D0*PSI4 - A7*(3.D0*PSI2 + PSI1))/2.D0/A7 + PSI5 = MIN (PSI5, CHI5) +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (1) = PSI6 ! HI + MOLAL (2) = 2.D0*PSI4 + PSI3 ! NAI + MOLAL (3) = 3.D0*PSI2 + 2.D0*PSI5 + PSI1 ! NH4I + MOLAL (5) = PSI2 + PSI4 + PSI5 + PSI6 ! SO4I + MOLAL (6) = PSI2 + PSI3 + PSI1 - PSI6 ! HSO4I + CLC = ZERO + CNAHSO4 = ZERO + CNA2SO4 = CHI4 - PSI4 + CNH42S4 = CHI5 - PSI5 + CNH4HS4 = ZERO + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE OBJECTIVE FUNCTION ************************************ +! +20 A4 = XK5 *(WATER/GAMA(2))**3.0 + FUNCI4A= MOLAL(5)*MOLAL(2)*MOLAL(2)/A4 - ONE + RETURN +! +! *** END OF FUNCTION FUNCI4A ******************************************** +! + END FUNCTION FUNCI4A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCI3 +! *** CASE I3 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4, NAHSO4, LC +! +! THERE ARE THREE REGIMES IN THIS CASE: +! 1.(NA,NH4)HSO4(s) POSSIBLE. LIQUID & SOLID AEROSOL (SUBROUTINE CALCI3A) +! 2.(NA,NH4)HSO4(s) NOT POSSIBLE, AND RH < MDRH. SOLID AEROSOL ONLY +! 3.(NA,NH4)HSO4(s) NOT POSSIBLE, AND RH >= MDRH. SOLID & LIQUID AEROSOL +! +! REGIMES 2. AND 3. ARE CONSIDERED TO BE THE SAME AS CASES I1A, I2B +! RESPECTIVELY +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCI3 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL CALCI1A, CALCI4 +! +! *** FIND DRY COMPOSITION ********************************************** +! + CALL CALCI1A +! +! *** REGIME DEPENDS UPON THE POSSIBLE SOLIDS & RH ********************** +! + IF (CNH4HS4.GT.TINY .OR. CNAHSO4.GT.TINY) THEN + SCASE = 'I3 ; SUBCASE 1' + CALL CALCI3A ! FULL SOLUTION + SCASE = 'I3 ; SUBCASE 1' + ENDIF +! + IF (WATER.LE.TINY) THEN + IF (RH.LT.DRMI3) THEN ! SOLID SOLUTION + WATER = TINY + DO 10 I=1,NIONS + MOLAL(I) = ZERO +10 CONTINUE + CALL CALCI1A + SCASE = 'I3 ; SUBCASE 2' +! + ELSEIF (RH.GE.DRMI3) THEN ! MDRH OF I3 + SCASE = 'I3 ; SUBCASE 3' + CALL CALCMDRH (RH, DRMI3, DRLC, CALCI1A, CALCI4) + SCASE = 'I3 ; SUBCASE 3' + ENDIF + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCI3 ****************************************** +! + END SUBROUTINE CALCI3 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCI3A +! *** CASE I3 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4, LC +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCI3A + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** FIND DRY COMPOSITION ********************************************** +! + CALL CALCI1A ! Needed when called from CALCMDRH +! +! *** SETUP PARAMETERS ************************************************ +! + CHI1 = CNH4HS4 ! Save from CALCI1 run + CHI2 = CLC + CHI3 = CNAHSO4 + CHI4 = CNA2SO4 + CHI5 = CNH42S4 +! + PSI1 = CNH4HS4 ! ASSIGN INITIAL PSI's + PSI2 = ZERO + PSI3 = CNAHSO4 + PSI4 = ZERO + PSI5 = ZERO +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + PSI2LO = ZERO ! Low limit + PSI2HI = CHI2 ! High limit +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI2HI + Y1 = FUNCI3A (X1) + YHI= Y1 ! Save Y-value at HI position +! +! *** YHI < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH LC ********* +! + IF (YHI.LT.EPS) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI2HI-PSI2LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = MAX(X1-DX, PSI2LO) + Y2 = FUNCI3A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH LC +! + IF (Y2.GT.EPS) Y2 = FUNCI3A (ZERO) + GOTO 50 +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCI3A (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCI3A') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCI3A (X3) +! +50 RETURN + +! *** END OF SUBROUTINE CALCI3A ***************************************** +! + END SUBROUTINE CALCI3A +! +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE FUNCI3A +! *** CASE I3 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4, LC +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCI3A (P2) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI2 = P2 ! Save PSI2 in COMMON BLOCK + PSI4LO = ZERO ! Low limit for PSI4 + PSI4HI = CHI4 ! High limit for PSI4 +! +! *** IF NH3 =0, CALL FUNCI3B FOR Y4=0 ******************************** +! + IF (CHI4.LE.TINY) THEN + FUNCI3A = FUNCI3B (ZERO) + GOTO 50 + ENDIF +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI4HI + Y1 = FUNCI3B (X1) + IF (ABS(Y1).LE.EPS) GOTO 50 + YHI= Y1 ! Save Y-value at HI position +! +! *** YHI < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NA2SO4 ***** +! + IF (YHI.LT.ZERO) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI4HI-PSI4LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = MAX(X1-DX, PSI4LO) + Y2 = FUNCI3B (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NA2SO4 +! + IF (Y2.GT.EPS) Y2 = FUNCI3B (PSI4LO) + GOTO 50 +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCI3B (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0004, 'FUNCI3A') ! WARNING ERROR: NO CONVERGENCE +! +! *** INNER LOOP CONVERGED ********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCI3B (X3) +! +! *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +! +50 A2 = XK13*(WATER/GAMA(13))**5.0 + FUNCI3A = MOLAL(5)*MOLAL(6)*MOLAL(3)**3.D0/A2 - ONE + RETURN +! +! *** END OF FUNCTION FUNCI3A ******************************************* +! + END FUNCTION FUNCI3A + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** FUNCTION FUNCI3B +! *** CASE I3 ; SUBCASE 2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4, LC +! +! SOLUTION IS SAVED IN COMMON BLOCK /CASE/ +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCI3B (P4) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + PSI4 = P4 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST = .TRUE. + CALAIN = .TRUE. +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A4 = XK5*(WATER/GAMA(2))**3.0 + A5 = XK7*(WATER/GAMA(4))**3.0 + A6 = XK1*WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. + A7 = SQRT(A4/A5) +! +! CALCULATE DISSOCIATION QUANTITIES +! + BB = PSI2 + PSI4 + PSI5 + A6 ! PSI6 + CC =-A6*(PSI2 + PSI3 + PSI1) + DD = BB*BB - 4.D0*CC + PSI6 = 0.5D0*(-BB + SQRT(DD)) +! + PSI5 = (PSI3 + 2.D0*PSI4 - A7*(3.D0*PSI2 + PSI1))/2.D0/A7 + PSI5 = MIN (PSI5, CHI5) +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL(1) = PSI6 ! HI + MOLAL(2) = 2.D0*PSI4 + PSI3 ! NAI + MOLAL(3) = 3.D0*PSI2 + 2.D0*PSI5 + PSI1 ! NH4I + MOLAL(5) = PSI2 + PSI4 + PSI5 + PSI6 ! SO4I + MOLAL(6) = MAX(PSI2 + PSI3 + PSI1 - PSI6, TINY) ! HSO4I + CLC = MAX(CHI2 - PSI2, ZERO) + CNAHSO4 = ZERO + CNA2SO4 = MAX(CHI4 - PSI4, ZERO) + CNH42S4 = MAX(CHI5 - PSI5, ZERO) + CNH4HS4 = ZERO + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE OBJECTIVE FUNCTION ************************************ +! +20 A4 = XK5 *(WATER/GAMA(2))**3.0 + FUNCI3B= MOLAL(5)*MOLAL(2)*MOLAL(2)/A4 - ONE + RETURN +! +! *** END OF FUNCTION FUNCI3B ******************************************** +! + END FUNCTION FUNCI3B +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCI2 +! *** CASE I2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4, NAHSO4, LC +! +! THERE ARE THREE REGIMES IN THIS CASE: +! 1. NH4HSO4(s) POSSIBLE. LIQUID & SOLID AEROSOL (SUBROUTINE CALCI2A) +! 2. NH4HSO4(s) NOT POSSIBLE, AND RH < MDRH. SOLID AEROSOL ONLY +! 3. NH4HSO4(s) NOT POSSIBLE, AND RH >= MDRH. SOLID & LIQUID AEROSOL +! +! REGIMES 2. AND 3. ARE CONSIDERED TO BE THE SAME AS CASES I1A, I2B +! RESPECTIVELY +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCI2 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL CALCI1A, CALCI3A +! +! *** FIND DRY COMPOSITION ********************************************** +! + CALL CALCI1A +! +! *** REGIME DEPENDS UPON THE POSSIBLE SOLIDS & RH ********************** +! + IF (CNH4HS4.GT.TINY) THEN + SCASE = 'I2 ; SUBCASE 1' + CALL CALCI2A + SCASE = 'I2 ; SUBCASE 1' + ENDIF +! + IF (WATER.LE.TINY) THEN + IF (RH.LT.DRMI2) THEN ! SOLID SOLUTION ONLY + WATER = TINY + DO 10 I=1,NIONS + MOLAL(I) = ZERO +10 CONTINUE + CALL CALCI1A + SCASE = 'I2 ; SUBCASE 2' +! + ELSEIF (RH.GE.DRMI2) THEN ! MDRH OF I2 + SCASE = 'I2 ; SUBCASE 3' + CALL CALCMDRH (RH, DRMI2, DRNAHSO4, CALCI1A, CALCI3A) + SCASE = 'I2 ; SUBCASE 3' + ENDIF + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCI2 ****************************************** +! + END SUBROUTINE CALCI2 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCI2A +! *** CASE I2 ; SUBCASE A +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4, NAHSO4, LC +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCI2A + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** FIND DRY COMPOSITION ********************************************** +! + CALL CALCI1A ! Needed when called from CALCMDRH +! +! *** SETUP PARAMETERS ************************************************ +! + CHI1 = CNH4HS4 ! Save from CALCI1 run + CHI2 = CLC + CHI3 = CNAHSO4 + CHI4 = CNA2SO4 + CHI5 = CNH42S4 +! + PSI1 = CNH4HS4 ! ASSIGN INITIAL PSI's + PSI2 = ZERO + PSI3 = ZERO + PSI4 = ZERO + PSI5 = ZERO +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + PSI2LO = ZERO ! Low limit + PSI2HI = CHI2 ! High limit +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI2HI + Y1 = FUNCI2A (X1) + YHI= Y1 ! Save Y-value at HI position +! +! *** YHI < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH LC ********* +! + IF (YHI.LT.EPS) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI2HI-PSI2LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = MAX(X1-DX, PSI2LO) + Y2 = FUNCI2A (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH LC +! + IF (Y2.GT.EPS) Y2 = FUNCI3A (ZERO) + GOTO 50 +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCI2A (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCI2A') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCI2A (X3) +! +50 RETURN + +! *** END OF SUBROUTINE CALCI2A ***************************************** +! + END SUBROUTINE CALCI2A + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE FUNCI2A +! *** CASE I2 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NA2SO4, NAHSO4, LC +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCI2A (P2) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST = .TRUE. + CALAIN = .TRUE. + PSI2 = P2 ! Save PSI2 in COMMON BLOCK + PSI3 = CHI3 + PSI4 = CHI4 + PSI5 = CHI5 + PSI6 = ZERO +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A3 = XK11*(WATER/GAMA(12))**2.0 + A4 = XK5 *(WATER/GAMA(2))**3.0 + A5 = XK7 *(WATER/GAMA(4))**3.0 + A6 = XK1 *WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2. + A7 = SQRT(A4/A5) +! +! CALCULATE DISSOCIATION QUANTITIES +! + IF (CHI5.GT.TINY .AND. WATER.GT.TINY) THEN + PSI5 = (PSI3 + 2.D0*PSI4 - A7*(3.D0*PSI2 + PSI1))/2.D0/A7 + PSI5 = MAX(MIN (PSI5, CHI5), TINY) + ENDIF +! + IF (CHI4.GT.TINY .AND. WATER.GT.TINY) THEN + AA = PSI2+PSI5+PSI6+PSI3 + BB = PSI3*AA + CC = 0.25D0*(PSI3*PSI3*(PSI2+PSI5+PSI6)-A4) + CALL POLY3 (AA, BB, CC, PSI4, ISLV) + IF (ISLV.EQ.0) THEN + PSI4 = MIN (PSI4, CHI4) + ELSE + PSI4 = ZERO + ENDIF + ENDIF +! + IF (CHI3.GT.TINY .AND. WATER.GT.TINY) THEN + AA = 2.D0*PSI4 + PSI2 + PSI1 - PSI6 + BB = 2.D0*PSI4*(PSI2 + PSI1 - PSI6) - A3 + CC = ZERO + CALL POLY3 (AA, BB, CC, PSI3, ISLV) + IF (ISLV.EQ.0) THEN + PSI3 = MIN (PSI3, CHI3) + ELSE + PSI3 = ZERO + ENDIF + ENDIF +! + BB = PSI2 + PSI4 + PSI5 + A6 ! PSI6 + CC =-A6*(PSI2 + PSI3 + PSI1) + DD = BB*BB - 4.D0*CC + PSI6 = 0.5D0*(-BB + SQRT(DD)) +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (1) = PSI6 ! HI + MOLAL (2) = 2.D0*PSI4 + PSI3 ! NAI + MOLAL (3) = 3.D0*PSI2 + 2.D0*PSI5 + PSI1 ! NH4I + MOLAL (5) = PSI2 + PSI4 + PSI5 + PSI6 ! SO4I + MOLAL (6) = PSI2 + PSI3 + PSI1 - PSI6 ! HSO4I + CLC = CHI2 - PSI2 + CNAHSO4 = CHI3 - PSI3 + CNA2SO4 = CHI4 - PSI4 + CNH42S4 = CHI5 - PSI5 + CNH4HS4 = ZERO + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE FUNCTION VALUE FOR OUTER LOOP *************************** +! +20 A2 = XK13*(WATER/GAMA(13))**5.0 + FUNCI2A = MOLAL(5)*MOLAL(6)*MOLAL(3)**3.D0/A2 - ONE + RETURN +! +! *** END OF FUNCTION FUNCI2A ******************************************* +! + END FUNCTION FUNCI2A + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCI1 +! *** CASE I1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : NH4NO3, NH4CL, NA2SO4 +! +! THERE ARE TWO POSSIBLE REGIMES HERE, DEPENDING ON RELATIVE HUMIDITY: +! 1. WHEN RH >= MDRH ; LIQUID PHASE POSSIBLE (MDRH REGION) +! 2. WHEN RH < MDRH ; ONLY SOLID PHASE POSSIBLE (SUBROUTINE CALCI1A) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCI1 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL CALCI1A, CALCI2A +! +! *** REGIME DEPENDS UPON THE AMBIENT RELATIVE HUMIDITY ***************** +! + IF (RH.LT.DRMI1) THEN + SCASE = 'I1 ; SUBCASE 1' + CALL CALCI1A ! SOLID PHASE ONLY POSSIBLE + SCASE = 'I1 ; SUBCASE 1' + ELSE + SCASE = 'I1 ; SUBCASE 2' ! LIQUID & SOLID PHASE POSSIBLE + CALL CALCMDRH (RH, DRMI1, DRNH4HS4, CALCI1A, CALCI2A) + SCASE = 'I1 ; SUBCASE 2' + ENDIF +! +! *** AMMONIA IN GAS PHASE ********************************************** +! +! CALL CALCNH3 +! + RETURN +! +! *** END OF SUBROUTINE CALCI1 ****************************************** +! + END SUBROUTINE CALCI1 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCI1A +! *** CASE I1 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, NO FREE ACID (1.0 <= SULRAT < 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : NH4HSO4, NAHSO4, (NH4)2SO4, NA2SO4, LC +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCI1A + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** CALCULATE NON VOLATILE SOLIDS *********************************** +! + CNA2SO4 = 0.5D0*W(1) + CNH4HS4 = ZERO + CNAHSO4 = ZERO + CNH42S4 = ZERO + FRSO4 = MAX(W(2)-CNA2SO4, ZERO) +! + CLC = MIN(W(3)/3.D0, FRSO4/2.D0) + FRSO4 = MAX(FRSO4-2.D0*CLC, ZERO) + FRNH4 = MAX(W(3)-3.D0*CLC, ZERO) +! + IF (FRSO4.LE.TINY) THEN + CLC = MAX(CLC - FRNH4, ZERO) + CNH42S4 = 2.D0*FRNH4 + + ELSEIF (FRNH4.LE.TINY) THEN + CNH4HS4 = 3.D0*MIN(FRSO4, CLC) + CLC = MAX(CLC-FRSO4, ZERO) + IF (CNA2SO4.GT.TINY) THEN + FRSO4 = MAX(FRSO4-CNH4HS4/3.D0, ZERO) + CNAHSO4 = 2.D0*FRSO4 + CNA2SO4 = MAX(CNA2SO4-FRSO4, ZERO) + ENDIF + ENDIF +! +! *** CALCULATE GAS SPECIES ********************************************* +! + GHNO3 = W(4) + GHCL = W(5) + GNH3 = ZERO +! + RETURN +! +! *** END OF SUBROUTINE CALCI1A ***************************************** +! + END SUBROUTINE CALCI1A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCJ3 +! *** CASE J3 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +! 2. THERE IS ONLY A LIQUID PHASE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCJ3 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + DOUBLE PRECISION LAMDA, KAPA +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + FRST = .TRUE. + CALAIN = .TRUE. +! + LAMDA = MAX(W(2) - W(3) - W(1), TINY) ! FREE H2SO4 + CHI1 = W(1) ! NA TOTAL as NaHSO4 + CHI2 = W(3) ! NH4 TOTAL as NH4HSO4 + PSI1 = CHI1 + PSI2 = CHI2 ! ALL NH4HSO4 DELIQUESCED +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A3 = XK1 *WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.0 +! +! CALCULATE DISSOCIATION QUANTITIES +! + BB = A3+LAMDA ! KAPA + CC =-A3*(LAMDA + PSI1 + PSI2) + DD = BB*BB-4.D0*CC + KAPA = 0.5D0*(-BB+SQRT(DD)) +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (1) = LAMDA + KAPA ! HI + MOLAL (2) = PSI1 ! NAI + MOLAL (3) = PSI2 ! NH4I + MOLAL (4) = ZERO ! CLI + MOLAL (5) = KAPA ! SO4I + MOLAL (6) = LAMDA + PSI1 + PSI2 - KAPA ! HSO4I + MOLAL (7) = ZERO ! NO3I +! + CNAHSO4 = ZERO + CNH4HS4 = ZERO +! + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 50 + ENDIF +10 CONTINUE +! +50 RETURN +! +! *** END OF SUBROUTINE CALCJ3 ****************************************** +! + END SUBROUTINE CALCJ3 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCJ2 +! *** CASE J2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : NAHSO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCJ2 + USE ISRPIA + USE CASEJ + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! DOUBLE PRECISION LAMDA, KAPA +! COMMON /CASEJ/ CHI1, CHI2, CHI3, LAMDA, KAPA, PSI1, PSI2, PSI3, & +! A1, A2, A3 +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + CHI1 = W(1) ! NA TOTAL + CHI2 = W(3) ! NH4 TOTAL + PSI1LO = TINY ! Low limit + PSI1HI = CHI1 ! High limit +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI1HI + Y1 = FUNCJ2 (X1) + YHI= Y1 ! Save Y-value at HI position +! +! *** YHI < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NH42SO4 **** +! + IF (ABS(Y1).LE.EPS .OR. YHI.LT.ZERO) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI1HI-PSI1LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1-DX + Y2 = FUNCJ2 (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NH42SO4 +! + YLO= Y1 ! Save Y-value at Hi position + IF (YLO.GT.ZERO .AND. YHI.GT.ZERO) THEN + Y3 = FUNCJ2 (ZERO) + GOTO 50 + ELSE IF (ABS(Y2) .LT. EPS) THEN ! X2 IS A SOLUTION + GOTO 50 + ELSE + CALL PUSHERR (0001, 'CALCJ2') ! WARNING ERROR: NO SOLUTION + GOTO 50 + ENDIF +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCJ2 (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCJ2') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCJ2 (X3) +! +50 RETURN +! +! *** END OF SUBROUTINE CALCJ2 ****************************************** +! + END SUBROUTINE CALCJ2 + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE FUNCJ2 +! *** CASE J2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCJ2 (P1) + USE CASEJ + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! DOUBLE PRECISION LAMDA, KAPA +! COMMON /CASEJ/ CHI1, CHI2, CHI3, LAMDA, KAPA, PSI1, PSI2, PSI3, & +! A1, A2, A3 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST = .TRUE. + CALAIN = .TRUE. +! + LAMDA = MAX(W(2) - W(3) - W(1), TINY) ! FREE H2SO4 + PSI1 = P1 + PSI2 = CHI2 ! ALL NH4HSO4 DELIQUESCED +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A1 = XK11 *(WATER/GAMA(12))**2.0 + A3 = XK1 *WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.0 +! +! CALCULATE DISSOCIATION QUANTITIES +! + BB = A3+LAMDA ! KAPA + CC =-A3*(LAMDA + PSI1 + PSI2) + DD = BB*BB-4.D0*CC + KAPA = 0.5D0*(-BB+SQRT(DD)) +! +! *** CALCULATE SPECIATION ******************************************** +! + MOLAL (1) = LAMDA + KAPA ! HI + MOLAL (2) = PSI1 ! NAI + MOLAL (3) = PSI2 ! NH4I + MOLAL (4) = ZERO ! CLI + MOLAL (5) = KAPA ! SO4I + MOLAL (6) = LAMDA + PSI1 + PSI2 - KAPA ! HSO4I + MOLAL (7) = ZERO ! NO3I +! + CNAHSO4 = MAX(CHI1-PSI1,ZERO) + CNH4HS4 = ZERO +! + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE OBJECTIVE FUNCTION ************************************ +! +20 FUNCJ2 = MOLAL(2)*MOLAL(6)/A1 - ONE +! +! *** END OF FUNCTION FUNCJ2 ******************************************* +! + END FUNCTION FUNCJ2 + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCJ1 +! *** CASE J1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : NH4HSO4, NAHSO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + SUBROUTINE CALCJ1 + USE ISRPIA + USE CASEJ + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! DOUBLE PRECISION LAMDA, KAPA +! COMMON /CASEJ/ CHI1, CHI2, CHI3, LAMDA, KAPA, PSI1, PSI2, PSI3, & +! A1, A2, A3 +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU =.TRUE. ! Outer loop activity calculation flag + CHI1 = W(1) ! Total NA initially as NaHSO4 + CHI2 = W(3) ! Total NH4 initially as NH4HSO4 +! + PSI1LO = TINY ! Low limit + PSI1HI = CHI1 ! High limit +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI1HI + Y1 = FUNCJ1 (X1) + YHI= Y1 ! Save Y-value at HI position +! +! *** YHI < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NH42SO4 **** +! + IF (ABS(Y1).LE.EPS .OR. YHI.LT.ZERO) GOTO 50 +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI1HI-PSI1LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = X1-DX + Y2 = FUNCJ1 (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NH42SO4 +! + YLO= Y1 ! Save Y-value at Hi position + IF (YLO.GT.ZERO .AND. YHI.GT.ZERO) THEN + Y3 = FUNCJ1 (ZERO) + GOTO 50 + ELSE IF (ABS(Y2) .LT. EPS) THEN ! X2 IS A SOLUTION + GOTO 50 + ELSE + CALL PUSHERR (0001, 'CALCJ1') ! WARNING ERROR: NO SOLUTION + GOTO 50 + ENDIF +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCJ1 (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCJ1') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCJ1 (X3) +! +50 RETURN +! +! *** END OF SUBROUTINE CALCJ1 ****************************************** +! + END SUBROUTINE CALCJ1 + + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE FUNCJ1 +! *** CASE J1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE RICH, FREE ACID (SULRAT < 1.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4CL, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! *** UPDATED BY CHRISTOS FOUNTOUKIS +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCJ1 (P1) + USE ISRPIA + USE CASEJ + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! DOUBLE PRECISION LAMDA, KAPA +! COMMON /CASEJ/ CHI1, CHI2, CHI3, LAMDA, KAPA, PSI1, PSI2, PSI3, & +! A1, A2, A3 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST = .TRUE. + CALAIN = .TRUE. +! + LAMDA = MAX(W(2) - W(3) - W(1), TINY) ! FREE H2SO4 + PSI1 = P1 +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +! + A1 = XK11 *(WATER/GAMA(12))**2.0 + A2 = XK12 *(WATER/GAMA(09))**2.0 + A3 = XK1 *WATER/GAMA(7)*(GAMA(8)/GAMA(7))**2.0 +! + PSI2 = 0.5*(-(LAMDA+PSI1) + SQRT((LAMDA+PSI1)**2.D0+4.D0*A2)) ! PSI2 + PSI2 = MIN (PSI2, CHI2) +! + BB = A3+LAMDA ! KAPA + CC =-A3*(LAMDA + PSI2 + PSI1) + DD = BB*BB-4.D0*CC + KAPA = 0.5D0*(-BB+SQRT(DD)) +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL (1) = LAMDA + KAPA ! HI + MOLAL (2) = PSI1 ! NAI + MOLAL (3) = PSI2 ! NH4I + MOLAL (4) = ZERO + MOLAL (5) = KAPA ! SO4I + MOLAL (6) = LAMDA + PSI1 + PSI2 - KAPA ! HSO4I + MOLAL (7) = ZERO +! + CNAHSO4 = MAX(CHI1-PSI1,ZERO) + CNH4HS4 = MAX(CHI2-PSI2,ZERO) +! + CALL CALCMR ! Water content +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE OBJECTIVE FUNCTION ************************************ +! +20 FUNCJ1 = MOLAL(2)*MOLAL(6)/A1 - ONE +! +! *** END OF FUNCTION FUNCJ1 ******************************************* +! + END FUNCTION FUNCJ1 + diff --git a/wrfv2_fire/chem/isorev.F b/wrfv2_fire/chem/isorev.F new file mode 100755 index 00000000..04580a62 --- /dev/null +++ b/wrfv2_fire/chem/isorev.F @@ -0,0 +1,3604 @@ +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISRP1R +! *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE REVERSE PROBLEM OF +! AN AMMONIUM-SULFATE AEROSOL SYSTEM. +! THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY +! THE AMBIENT RELATIVE HUMIDITY. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +! REVISION HISTORY: * +! Original code was provided by Dr. ATHANASIOS NENES, Georgia Tech, in 2000 +! Revised by Y. Zhang, AER, Inc. to incorporate v1.5 into MADRID, 2000 +! Revised by Y. Zhang and Xiao-Ming Hu to incorporate it along with MADRID into WRF/Chem, 2005 +! Updated by Xiao-Ming Hu and Y. Zhang, NCSU to v. 1.7, Oct., 2007 +!======================================================================= +! + SUBROUTINE ISRP1R (WI, RHI, TEMPI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DIMENSION WI(NCOMP) +! +! *** INITIALIZE COMMON BLOCK VARIABLES ********************************* +! + CALL INIT1 (WI, RHI, TEMPI) +! +! *** CALCULATE SULFATE RATIO ******************************************* +! + IF (RH.GE.DRNH42S4) THEN ! WET AEROSOL, NEED NH4 AT SRATIO=2.0 + SULRATW = GETASR(WAER(2), RHI) ! AEROSOL SULFATE RATIO + ELSE + SULRATW = 2.0D0 ! DRY AEROSOL SULFATE RATIO + ENDIF + SULRAT = WAER(3)/WAER(2) ! SULFATE RATIO +! +! *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** +! +! *** SULFATE POOR +! + IF (SULRATW.LE.SULRAT) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'K2' + CALL CALCK2 ! Only liquid (metastable) + ELSE +! + IF (RH.LT.DRNH42S4) THEN + SCASE = 'K1' + CALL CALCK1 ! NH42SO4 ; case K1 +! + ELSEIF (DRNH42S4.LE.RH) THEN + SCASE = 'K2' + CALL CALCK2 ! Only liquid ; case K2 + ENDIF + ENDIF +! +! *** SULFATE RICH (NO ACID) +! + ELSEIF (1.0.LE.SULRAT .AND. SULRAT.LT.SULRATW) THEN + W(2) = WAER(2) + W(3) = WAER(3) +! + IF(METSTBL.EQ.1) THEN + SCASE = 'B4' + CALL CALCB4 ! Only liquid (metastable) + SCASE = 'L4' + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'B1' + CALL CALCB1 ! NH4HSO4,LC,NH42SO4 ; case B1 + SCASE = 'L1' +! + ELSEIF (DRNH4HS4.LE.RH .AND. RH.LT.DRLC) THEN + SCASE = 'B2' + CALL CALCB2 ! LC,NH42S4 ; case B2 + SCASE = 'L2' +! + ELSEIF (DRLC.LE.RH .AND. RH.LT.DRNH42S4) THEN + SCASE = 'B3' + CALL CALCB3 ! NH42S4 ; case B3 + SCASE = 'L3' +! + ELSEIF (DRNH42S4.LE.RH) THEN + SCASE = 'B4' + CALL CALCB4 ! Only liquid ; case B4 + SCASE = 'L4' + ENDIF + ENDIF +! + CALL CALCNH3P ! Compute NH3(g) +! +! *** SULFATE RICH (FREE ACID) +! + ELSEIF (SULRAT.LT.1.0) THEN + W(2) = WAER(2) + W(3) = WAER(3) +! + IF(METSTBL.EQ.1) THEN + SCASE = 'C2' + CALL CALCC2 ! Only liquid (metastable) + SCASE = 'M2' + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'C1' + CALL CALCC1 ! NH4HSO4 ; case C1 + SCASE = 'M1' +! + ELSEIF (DRNH4HS4.LE.RH) THEN + SCASE = 'C2' + CALL CALCC2 ! Only liquid ; case C2 + SCASE = 'M2' + ENDIF + ENDIF +! + CALL CALCNH3P +! + ENDIF + RETURN +! +! *** END OF SUBROUTINE ISRP1R ***************************************** +! + END SUBROUTINE ISRP1R + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISRP2R +! *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE REVERSE PROBLEM OF +! AN AMMONIUM-SULFATE-NITRATE AEROSOL SYSTEM. +! THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE RATIO AND BY +! THE AMBIENT RELATIVE HUMIDITY. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE ISRP2R (WI, RHI, TEMPI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DIMENSION WI(NCOMP) + LOGICAL TRYLIQ +! +! *** INITIALIZE ALL VARIABLES IN COMMON BLOCK ************************** +! + TRYLIQ = .TRUE. ! Assume liquid phase, sulfate poor limit +! +10 CALL INIT2 (WI, RHI, TEMPI) +! +! *** CALCULATE SULFATE RATIO ******************************************* +! + IF (TRYLIQ .AND. RH.GE.DRNH4NO3) THEN ! *** WET AEROSOL + SULRATW = GETASR(WAER(2), RHI) ! LIMITING SULFATE RATIO + ELSE + SULRATW = 2.0D0 ! *** DRY AEROSOL + ENDIF + SULRAT = WAER(3)/WAER(2) +! +! *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** +! +! *** SULFATE POOR +! + IF (SULRATW.LE.SULRAT) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'N3' + CALL CALCN3 ! Only liquid (metastable) + ELSE +! + IF (RH.LT.DRNH4NO3) THEN + SCASE = 'N1' + CALL CALCN1 ! NH42SO4,NH4NO3 ; case N1 +! + ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNH42S4) THEN + SCASE = 'N2' + CALL CALCN2 ! NH42S4 ; case N2 +! + ELSEIF (DRNH42S4.LE.RH) THEN + SCASE = 'N3' + CALL CALCN3 ! Only liquid ; case N3 + ENDIF + ENDIF +! +! *** SULFATE RICH (NO ACID) +! +! FOR SOLVING THIS CASE, NITRIC ACID AND AMMONIA IN THE GAS PHASE ARE +! ASSUMED A MINOR SPECIES, THAT DO NOT SIGNIFICANTLY AFFECT THE +! AEROSOL EQUILIBRIUM. +! + ELSEIF (1.0.LE.SULRAT .AND. SULRAT.LT.SULRATW) THEN + W(2) = WAER(2) + W(3) = WAER(3) + W(4) = WAER(4) +! + IF(METSTBL.EQ.1) THEN + SCASE = 'B4' + CALL CALCB4 ! Only liquid (metastable) + SCASE = 'O4' + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'B1' + CALL CALCB1 ! NH4HSO4,LC,NH42SO4 ; case O1 + SCASE = 'O1' +! + ELSEIF (DRNH4HS4.LE.RH .AND. RH.LT.DRLC) THEN + SCASE = 'B2' + CALL CALCB2 ! LC,NH42S4 ; case O2 + SCASE = 'O2' +! + ELSEIF (DRLC.LE.RH .AND. RH.LT.DRNH42S4) THEN + SCASE = 'B3' + CALL CALCB3 ! NH42S4 ; case O3 + SCASE = 'O3' +! + ELSEIF (DRNH42S4.LE.RH) THEN + SCASE = 'B4' + CALL CALCB4 ! Only liquid ; case O4 + SCASE = 'O4' + ENDIF + ENDIF +! +! *** Add the NO3 to the solution now and calculate partitioning. +! + MOLAL(7) = WAER(4) ! There is always water, so NO3(aer) is NO3- + MOLAL(1) = MOLAL(1) + WAER(4) ! Add H+ to balance out + CALL CALCNAP ! HNO3, NH3 dissolved + CALL CALCNH3P +! +! *** SULFATE RICH (FREE ACID) +! +! FOR SOLVING THIS CASE, NITRIC ACID AND AMMONIA IN THE GAS PHASE ARE +! ASSUMED A MINOR SPECIES, THAT DO NOT SIGNIFICANTLY AFFECT THE +! AEROSOL EQUILIBRIUM. +! + ELSEIF (SULRAT.LT.1.0) THEN + W(2) = WAER(2) + W(3) = WAER(3) + W(4) = WAER(4) +! + IF(METSTBL.EQ.1) THEN + SCASE = 'C2' + CALL CALCC2 ! Only liquid (metastable) + SCASE = 'P2' + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'C1' + CALL CALCC1 ! NH4HSO4 ; case P1 + SCASE = 'P1' +! + ELSEIF (DRNH4HS4.LE.RH) THEN + SCASE = 'C2' + CALL CALCC2 ! Only liquid ; case P2 + SCASE = 'P2' + ENDIF + ENDIF +! +! *** Add the NO3 to the solution now and calculate partitioning. +! + MOLAL(7) = WAER(4) ! There is always water, so NO3(aer) is NO3- + MOLAL(1) = MOLAL(1) + WAER(4) ! Add H+ to balance out +! + CALL CALCNAP ! HNO3, NH3 dissolved + CALL CALCNH3P + ENDIF +! +! *** IF SULRATW < SULRAT < 2.0 and WATER = 0 => SULFATE RICH CASE. +! + IF (SULRATW.LE.SULRAT .AND. SULRAT.LT.2.0 & + .AND. WATER.LE.TINY) THEN + TRYLIQ = .FALSE. + GOTO 10 + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE ISRP2R ***************************************** +! + END SUBROUTINE ISRP2R +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE ISRP3R +! *** THIS SUBROUTINE IS THE DRIVER ROUTINE FOR THE REVERSE PROBLEM OF +! AN AMMONIUM-SULFATE-NITRATE-CHLORIDE-SODIUM AEROSOL SYSTEM. +! THE COMPOSITION REGIME IS DETERMINED BY THE SULFATE & SODIUM +! RATIOS AND BY THE AMBIENT RELATIVE HUMIDITY. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE ISRP3R (WI, RHI, TEMPI) + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DIMENSION WI(NCOMP) + LOGICAL TRYLIQ +!cC +!cC *** ADJUST FOR TOO LITTLE AMMONIUM AND CHLORIDE *********************** +!cC +!c WI(3) = MAX (WI(3), 1.D-10) ! NH4+ : 1e-4 umoles/m3 +!c WI(5) = MAX (WI(5), 1.D-10) ! Cl- : 1e-4 umoles/m3 +! +! *** INITIALIZE ALL VARIABLES ****************************************** +! + TRYLIQ = .TRUE. ! Use liquid phase sulfate poor limit +! +10 CALL ISOINIT3 (WI, RHI, TEMPI) ! COMMON block variables +!cC +!cC *** CHECK IF TOO MUCH SODIUM ; ADJUST AND ISSUE ERROR MESSAGE ********* +!cC +!c REST = 2.D0*WAER(2) + WAER(4) + WAER(5) +!c IF (WAER(1).GT.REST) THEN ! NA > 2*SO4+CL+NO3 ? +!c WAER(1) = (ONE-1D-6)*REST ! Adjust Na amount +!c CALL PUSHERR (0050, 'ISRP3R') ! Warning error: Na adjusted +!c ENDIF +! +! *** CALCULATE SULFATE & SODIUM RATIOS ********************************* +! + IF (TRYLIQ .AND. RH.GE.DRNH4NO3) THEN ! ** WET AEROSOL + FRSO4 = WAER(2) - WAER(1)/2.0D0 ! SULFATE UNBOUND BY SODIUM + FRSO4 = MAX(FRSO4, TINY) + SRI = GETASR(FRSO4, RHI) ! SULFATE RATIO FOR NH4+ + SULRATW = (WAER(1)+FRSO4*SRI)/WAER(2) ! LIMITING SULFATE RATIO + SULRATW = MIN (SULRATW, 2.0D0) + ELSE + SULRATW = 2.0D0 ! ** DRY AEROSOL + ENDIF + SULRAT = (WAER(1)+WAER(3))/WAER(2) + SODRAT = WAER(1)/WAER(2) +! +! *** FIND CALCULATION REGIME FROM (SULRAT,RH) ************************** +! +! *** SULFATE POOR ; SODIUM POOR +! + IF (SULRATW.LE.SULRAT .AND. SODRAT.LT.2.0) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'Q5' + CALL CALCQ5 ! Only liquid (metastable) + SCASE = 'Q5' + ELSE +! + IF (RH.LT.DRNH4NO3) THEN + SCASE = 'Q1' + CALL CALCQ1 ! NH42SO4,NH4NO3,NH4CL,NA2SO4 +! + ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNH4CL) THEN + SCASE = 'Q2' + CALL CALCQ2 ! NH42SO4,NH4CL,NA2SO4 +! + ELSEIF (DRNH4CL.LE.RH .AND. RH.LT.DRNH42S4) THEN + SCASE = 'Q3' + CALL CALCQ3 ! NH42SO4,NA2SO4 +! + ELSEIF (DRNH42S4.LE.RH .AND. RH.LT.DRNA2SO4) THEN + SCASE = 'Q4' + CALL CALCQ4 ! NA2SO4 + SCASE = 'Q4' +! + ELSEIF (DRNA2SO4.LE.RH) THEN + SCASE = 'Q5' + CALL CALCQ5 ! Only liquid + SCASE = 'Q5' + ENDIF + ENDIF +! +! *** SULFATE POOR ; SODIUM RICH +! + ELSE IF (SULRAT.GE.SULRATW .AND. SODRAT.GE.2.0) THEN +! + IF(METSTBL.EQ.1) THEN + SCASE = 'R6' + CALL CALCR6 ! Only liquid (metastable) + SCASE = 'R6' + ELSE +! + IF (RH.LT.DRNH4NO3) THEN + SCASE = 'R1' + CALL CALCR1 ! NH4NO3,NH4CL,NA2SO4,NACL,NANO3 +! + ELSEIF (DRNH4NO3.LE.RH .AND. RH.LT.DRNANO3) THEN + SCASE = 'R2' + CALL CALCR2 ! NH4CL,NA2SO4,NACL,NANO3 +! + ELSEIF (DRNANO3.LE.RH .AND. RH.LT.DRNACL) THEN + SCASE = 'R3' + CALL CALCR3 ! NH4CL,NA2SO4,NACL +! + ELSEIF (DRNACL.LE.RH .AND. RH.LT.DRNH4CL) THEN + SCASE = 'R4' + CALL CALCR4 ! NH4CL,NA2SO4 +! + ELSEIF (DRNH4CL.LE.RH .AND. RH.LT.DRNA2SO4) THEN + SCASE = 'R5' + CALL CALCR5 ! NA2SO4 + SCASE = 'R5' +! + ELSEIF (DRNA2SO4.LE.RH) THEN + SCASE = 'R6' + CALL CALCR6 ! NO SOLID + SCASE = 'R6' + ENDIF + ENDIF +! +! *** SULFATE RICH (NO ACID) +! + ELSEIF (1.0.LE.SULRAT .AND. SULRAT.LT.SULRATW) THEN + DO 100 I=1,NCOMP + W(I) = WAER(I) +100 CONTINUE +! + IF(METSTBL.EQ.1) THEN + SCASE = 'I6' + CALL CALCI6 ! Only liquid (metastable) + SCASE = 'S6' + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'I1' + CALL CALCI1 ! NA2SO4,(NH4)2SO4,NAHSO4,NH4HSO4,LC + SCASE = 'S1' +! + ELSEIF (DRNH4HS4.LE.RH .AND. RH.LT.DRNAHSO4) THEN + SCASE = 'I2' + CALL CALCI2 ! NA2SO4,(NH4)2SO4,NAHSO4,LC + SCASE = 'S2' +! + ELSEIF (DRNAHSO4.LE.RH .AND. RH.LT.DRLC) THEN + SCASE = 'I3' + CALL CALCI3 ! NA2SO4,(NH4)2SO4,LC + SCASE = 'S3' +! + ELSEIF (DRLC.LE.RH .AND. RH.LT.DRNH42S4) THEN + SCASE = 'I4' + CALL CALCI4 ! NA2SO4,(NH4)2SO4 + SCASE = 'S4' +! + ELSEIF (DRNH42S4.LE.RH .AND. RH.LT.DRNA2SO4) THEN + SCASE = 'I5' + CALL CALCI5 ! NA2SO4 + SCASE = 'S5' +! + ELSEIF (DRNA2SO4.LE.RH) THEN + SCASE = 'I6' + CALL CALCI6 ! NO SOLIDS + SCASE = 'S6' + ENDIF + ENDIF +! + CALL CALCNHP ! HNO3, NH3, HCL in gas phase + CALL CALCNH3P +! +! *** SULFATE RICH (FREE ACID) +! + ELSEIF (SULRAT.LT.1.0) THEN + DO 200 I=1,NCOMP + W(I) = WAER(I) +200 CONTINUE +! + IF(METSTBL.EQ.1) THEN + SCASE = 'J3' + CALL CALCJ3 ! Only liquid (metastable) + SCASE = 'T3' + ELSE +! + IF (RH.LT.DRNH4HS4) THEN + SCASE = 'J1' + CALL CALCJ1 ! NH4HSO4,NAHSO4 + SCASE = 'T1' +! + ELSEIF (DRNH4HS4.LE.RH .AND. RH.LT.DRNAHSO4) THEN + SCASE = 'J2' + CALL CALCJ2 ! NAHSO4 + SCASE = 'T2' +! + ELSEIF (DRNAHSO4.LE.RH) THEN + SCASE = 'J3' + CALL CALCJ3 + SCASE = 'T3' + ENDIF + ENDIF +! + CALL CALCNHP ! HNO3, NH3, HCL in gas phase + CALL CALCNH3P +! + ENDIF +! +! *** IF AFTER CALCULATIONS, SULRATW < SULRAT < 2.0 +! and WATER = 0 => SULFATE RICH CASE. +! + IF (SULRATW.LE.SULRAT .AND. SULRAT.LT.2.0 & + .AND. WATER.LE.TINY) THEN + TRYLIQ = .FALSE. + GOTO 10 + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE ISRP3R ***************************************** +! + END SUBROUTINE ISRP3R +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCK2 +! *** CASE K2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. LIQUID AEROSOL PHASE ONLY POSSIBLE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCK2 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION NH4I, NH3GI, NH3AQ +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU =.TRUE. ! Outer loop activity calculation flag + FRST =.TRUE. + CALAIN =.TRUE. +! +! *** CALCULATE WATER CONTENT ***************************************** +! + MOLALR(4)= MIN(WAER(2), 0.5d0*WAER(3)) + WATER = MOLALR(4)/M0(4) ! ZSR correlation +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP +!C A21 = XK21*WATER*R*TEMP + A2 = XK2 *R*TEMP/XKW/RH*(GAMA(8)/GAMA(9))**2. + AKW = XKW *RH*WATER*WATER +! + NH4I = WAER(3) + SO4I = WAER(2) + HSO4I= ZERO +! + CALL CALCPH (2.D0*SO4I - NH4I, HI, OHI) ! Get pH +! + NH3AQ = ZERO ! AMMONIA EQUILIBRIUM + IF (HI.LT.OHI) THEN + CALL CALCAMAQ (NH4I, OHI, DEL) + NH4I = MAX (NH4I-DEL, ZERO) + OHI = MAX (OHI -DEL, TINY) + NH3AQ = DEL + HI = AKW/OHI + ENDIF +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) ! SULFATE EQUILIBRIUM + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL +! + NH3GI = NH4I/HI/A2 ! NH3AQ/A21 +! +! *** SPECIATION & WATER CONTENT *************************************** +! + MOLAL(1) = HI + MOLAL(3) = NH4I + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + COH = OHI + GASAQ(1) = NH3AQ + GNH3 = NH3GI +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +20 RETURN +! +! *** END OF SUBROUTINE CALCK2 **************************************** +! + END SUBROUTINE CALCK2 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCK1 +! *** CASE K1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : (NH4)2SO4 +! +! A SIMPLE MATERIAL BALANCE IS PERFORMED, AND THE SOLID (NH4)2SO4 +! IS CALCULATED FROM THE SULFATES. THE EXCESS AMMONIA REMAINS IN +! THE GAS PHASE. +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCK1 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + CNH42S4 = MIN(WAER(2),0.5d0*WAER(3)) ! For bad input problems + GNH3 = ZERO +! + W(2) = CNH42S4 + W(3) = 2.D0*CNH42S4 + GNH3 +! + RETURN +! +! *** END OF SUBROUTINE CALCK1 ****************************************** +! + END SUBROUTINE CALCK1 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCN3 +! *** CASE N3 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. THERE IS ONLY A LIQUID PHASE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCN3 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION NH4I, NO3I, NH3AQ, NO3AQ +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + CALAOU =.TRUE. ! Outer loop activity calculation flag + FRST =.TRUE. + CALAIN =.TRUE. +! +! *** AEROSOL WATER CONTENT +! + MOLALR(4) = MIN(WAER(2),0.5d0*WAER(3)) ! (NH4)2SO4 + AML5 = MAX(WAER(3)-2.D0*MOLALR(4),ZERO) ! "free" NH4 + MOLALR(5) = MAX(MIN(AML5,WAER(4)), ZERO) ! NH4NO3=MIN("free",NO3) + WATER = MOLALR(4)/M0(4) + MOLALR(5)/M0(5) + WATER = MAX(WATER, TINY) +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A2 = XK2 *R*TEMP/XKW/RH*(GAMA(8)/GAMA(9))**2. +!C A21 = XK21*WATER*R*TEMP + A3 = XK4*R*TEMP*(WATER/GAMA(10))**2.0 + A4 = XK7*(WATER/GAMA(4))**3.0 + AKW = XKW *RH*WATER*WATER +! +! ION CONCENTRATIONS +! + NH4I = WAER(3) + NO3I = WAER(4) + SO4I = WAER(2) + HSO4I = ZERO +! + CALL CALCPH (2.D0*SO4I + NO3I - NH4I, HI, OHI) +! +! AMMONIA ASSOCIATION EQUILIBRIUM +! + NH3AQ = ZERO + NO3AQ = ZERO + GG = 2.D0*SO4I + NO3I - NH4I + IF (HI.LT.OHI) THEN + CALL CALCAMAQ2 (-GG, NH4I, OHI, NH3AQ) + HI = AKW/OHI + ELSE + HI = ZERO + CALL CALCNIAQ2 (GG, NO3I, HI, NO3AQ) ! HNO3 +! +! CONCENTRATION ADJUSTMENTS ; HSO4 minor species. +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL + OHI = AKW/HI + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL (1) = HI + MOLAL (3) = NH4I + MOLAL (5) = SO4I + MOLAL (6) = HSO4I + MOLAL (7) = NO3I + COH = OHI +! + CNH42S4 = ZERO + CNH4NO3 = ZERO +! + GASAQ(1) = NH3AQ + GASAQ(3) = NO3AQ +! + GHNO3 = HI*NO3I/A3 + GNH3 = NH4I/HI/A2 ! NH3AQ/A21 +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ****************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** RETURN *********************************************************** +! +20 RETURN +! +! *** END OF SUBROUTINE CALCN3 ***************************************** +! + END SUBROUTINE CALCN3 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCN2 +! *** CASE N2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. THERE IS BOTH A LIQUID & SOLID PHASE +! 3. SOLIDS POSSIBLE : (NH4)2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCN2 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + CHI1 = MIN(WAER(2),0.5d0*WAER(3)) ! (NH4)2SO4 + CHI2 = MAX(WAER(3) - 2.D0*CHI1, ZERO) ! "Free" NH4+ + CHI3 = MAX(WAER(4) - CHI2, ZERO) ! "Free" NO3 +! + PSI2 = CHI2 + PSI3 = CHI3 +! + CALAOU = .TRUE. ! Outer loop activity calculation flag + PSI1LO = TINY ! Low limit + PSI1HI = CHI1 ! High limit +! +! *** INITIAL VALUES FOR BISECTION ************************************ +! + X1 = PSI1HI + Y1 = FUNCN2 (X1) + IF (Y1.LE.EPS) RETURN ! IF (ABS(Y1).LE.EPS .OR. Y1.LE.ZERO) RETURN + YHI= Y1 ! Save Y-value at HI position +! +! *** ROOT TRACKING ; FOR THE RANGE OF HI AND LO ********************** +! + DX = (PSI1HI-PSI1LO)/REAL(NDIV) + DO 10 I=1,NDIV + X2 = MAX(X1-DX, ZERO) + Y2 = FUNCN2 (X2) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y2).LT.ZERO) GOTO 20 ! (Y1*Y2.LT.ZERO) + X1 = X2 + Y1 = Y2 +10 CONTINUE +! +! *** NO SUBDIVISION WITH SOLUTION FOUND +! + YLO= Y1 ! Save Y-value at Hi position + IF (ABS(Y2) .LT. EPS) THEN ! X2 IS A SOLUTION + RETURN +! +! *** { YLO, YHI } < 0.0 THE SOLUTION IS ALWAYS UNDERSATURATED WITH NH3 +! + ELSE IF (YLO.LT.ZERO .AND. YHI.LT.ZERO) THEN + P4 = CHI4 + YY = FUNCN2(P4) + GOTO 50 +! +! *** { YLO, YHI } > 0.0 THE SOLUTION IS ALWAYS SUPERSATURATED WITH NH3 +! + ELSE IF (YLO.GT.ZERO .AND. YHI.GT.ZERO) THEN + P4 = TINY + YY = FUNCN2(P4) + GOTO 50 + ELSE + CALL PUSHERR (0001, 'CALCN2') ! WARNING ERROR: NO SOLUTION + RETURN + ENDIF +! +! *** PERFORM BISECTION *********************************************** +! +20 DO 30 I=1,MAXIT + X3 = 0.5*(X1+X2) + Y3 = FUNCN2 (X3) + IF (SIGN(1.d0,Y1)*SIGN(1.d0,Y3) .LE. ZERO) THEN ! (Y1*Y3 .LE. ZERO) + Y2 = Y3 + X2 = X3 + ELSE + Y1 = Y3 + X1 = X3 + ENDIF + IF (ABS(X2-X1) .LE. EPS*X1) GOTO 40 +30 CONTINUE + CALL PUSHERR (0002, 'CALCN2') ! WARNING ERROR: NO CONVERGENCE +! +! *** CONVERGED ; RETURN ********************************************** +! +40 X3 = 0.5*(X1+X2) + Y3 = FUNCN2 (X3) +50 CONTINUE + RETURN +! +! *** END OF SUBROUTINE CALCN2 ****************************************** +! + END SUBROUTINE CALCN2 + + + +!====================================================================== +! +! *** ISORROPIA CODE +! *** FUNCTION FUNCN2 +! *** CASE D2 +! FUNCTION THAT SOLVES THE SYSTEM OF EQUATIONS FOR CASE D2 ; +! AND RETURNS THE VALUE OF THE ZEROED FUNCTION IN FUNCN2. +! +!======================================================================= +! + DOUBLE PRECISION FUNCTION FUNCN2 (P1) + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + DOUBLE PRECISION NH4I, NO3I, NH3AQ, NO3AQ +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST = .TRUE. + CALAIN = .TRUE. + PSI1 = P1 +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A2 = XK2 *R*TEMP/XKW/RH*(GAMA(8)/GAMA(9))**2. +!C A21 = XK21*WATER*R*TEMP + A3 = XK4*R*TEMP*(WATER/GAMA(10))**2.0 + A4 = XK7*(WATER/GAMA(4))**3.0 + AKW = XKW *RH*WATER*WATER +! +! ION CONCENTRATIONS +! + NH4I = 2.D0*PSI1 + PSI2 + NO3I = PSI2 + PSI3 + SO4I = PSI1 + HSO4I = ZERO +! + CALL CALCPH (2.D0*SO4I + NO3I - NH4I, HI, OHI) +! +! AMMONIA ASSOCIATION EQUILIBRIUM +! + NH3AQ = ZERO + NO3AQ = ZERO + GG = 2.D0*SO4I + NO3I - NH4I + IF (HI.LT.OHI) THEN + CALL CALCAMAQ2 (-GG, NH4I, OHI, NH3AQ) + HI = AKW/OHI + ELSE + HI = ZERO + CALL CALCNIAQ2 (GG, NO3I, HI, NO3AQ) ! HNO3 +! +! CONCENTRATION ADJUSTMENTS ; HSO4 minor species. +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL + OHI = AKW/HI + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL (1) = HI + MOLAL (3) = NH4I + MOLAL (5) = SO4I + MOLAL (6) = HSO4I + MOLAL (7) = NO3I + COH = OHI +! + CNH42S4 = CHI1 - PSI1 + CNH4NO3 = ZERO +! + GASAQ(1) = NH3AQ + GASAQ(3) = NO3AQ +! + GHNO3 = HI*NO3I/A3 + GNH3 = NH4I/HI/A2 ! NH3AQ/A21 +! +! *** CALCULATE MOLALR ARRAY, WATER AND ACTIVITIES ********************** +! + CALL CALCMR +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +! +! *** CALCULATE OBJECTIVE FUNCTION ************************************ +! +20 FUNCN2= NH4I*NH4I*SO4I/A4 - ONE + RETURN +! +! *** END OF FUNCTION FUNCN2 ******************************************** +! + END FUNCTION FUNCN2 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCN1 +! *** CASE N1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4NO3 +! +! THERE ARE TWO REGIMES DEFINED BY RELATIVE HUMIDITY: +! 1. RH < MDRH ; ONLY SOLID PHASE POSSIBLE (SUBROUTINE CALCN1A) +! 2. RH >= MDRH ; LIQUID PHASE POSSIBLE (MDRH REGION) +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCN1 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + EXTERNAL CALCN1A, CALCN2 +! +! *** REGIME DEPENDS UPON THE AMBIENT RELATIVE HUMIDITY ***************** +! + IF (RH.LT.DRMASAN) THEN + SCASE = 'N1 ; SUBCASE 1' + CALL CALCN1A ! SOLID PHASE ONLY POSSIBLE + SCASE = 'N1 ; SUBCASE 1' + ELSE + SCASE = 'N1 ; SUBCASE 2' + CALL CALCMDRP (RH, DRMASAN, DRNH4NO3, CALCN1A, CALCN2) + SCASE = 'N1 ; SUBCASE 2' + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCN1 ****************************************** +! + END SUBROUTINE CALCN1 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCN1A +! *** CASE N1 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : (NH4)2SO4, NH4NO3 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCN1A + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** SETUP PARAMETERS ************************************************* +! +!CC A1 = XK10/R/TEMP/R/TEMP +! +! *** CALCULATE AEROSOL COMPOSITION ************************************ +! +!CC CHI1 = 2.D0*WAER(4) ! Free parameter ; arbitrary value. + PSI1 = WAER(4) +! +! *** The following statment is here to avoid negative NH4+ values in +! CALCN? routines that call CALCN1A +! + PSI2 = MAX(MIN(WAER(2),0.5d0*(WAER(3)-PSI1)),TINY) +! + CNH4NO3 = PSI1 + CNH42S4 = PSI2 +! +!CC GNH3 = CHI1 + PSI1 + 2.0*PSI2 +!CC GHNO3 = A1/(CHI1-PSI1) + PSI1 + GNH3 = ZERO + GHNO3 = ZERO +! + W(2) = PSI2 + W(3) = GNH3 + PSI1 + 2.0*PSI2 + W(4) = GHNO3 + PSI1 +! + RETURN +! +! *** END OF SUBROUTINE CALCN1A ***************************************** +! + END SUBROUTINE CALCN1A + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCQ5 +! *** CASE Q5 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0); SODIUM POOR (SODRAT < 2.0) +! 2. LIQUID AND SOLID PHASES ARE POSSIBLE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCQ5 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + DOUBLE PRECISION NH4I, NAI, NO3I, NH3AQ, NO3AQ, CLAQ +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST =.TRUE. + CALAIN =.TRUE. + CALAOU =.TRUE. +! +! *** CALCULATE INITIAL SOLUTION *************************************** +! + CALL CALCQ1A +! + PSI1 = CNA2SO4 ! SALTS DISSOLVED + PSI4 = CNH4CL + PSI5 = CNH4NO3 + PSI6 = CNH42S4 +! + CALL CALCMR ! WATER +! + NH3AQ = ZERO + NO3AQ = ZERO + CLAQ = ZERO +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + AKW = XKW*RH*WATER*WATER ! H2O <==> H+ +! +! ION CONCENTRATIONS +! + NAI = WAER(1) + SO4I = WAER(2) + NH4I = WAER(3) + NO3I = WAER(4) + CLI = WAER(5) +! +! SOLUTION ACIDIC OR BASIC? +! + GG = 2.D0*SO4I + NO3I + CLI - NAI - NH4I + IF (GG.GT.TINY) THEN ! H+ in excess + BB =-GG + CC =-AKW + DD = BB*BB - 4.D0*CC + HI = 0.5D0*(-BB + SQRT(DD)) + OHI= AKW/HI + ELSE ! OH- in excess + BB = GG + CC =-AKW + DD = BB*BB - 4.D0*CC + OHI= 0.5D0*(-BB + SQRT(DD)) + HI = AKW/OHI + ENDIF +! +! UNDISSOCIATED SPECIES EQUILIBRIA +! + IF (HI.LT.OHI) THEN + CALL CALCAMAQ2 (-GG, NH4I, OHI, NH3AQ) + HI = AKW/OHI + HSO4I = ZERO + ELSE + GGNO3 = MAX(2.D0*SO4I + NO3I - NAI - NH4I, ZERO) + GGCL = MAX(GG-GGNO3, ZERO) + IF (GGCL .GT.TINY) CALL CALCCLAQ2 (GGCL, CLI, HI, CLAQ) ! HCl + IF (GGNO3.GT.TINY) THEN + IF (GGCL.LE.TINY) HI = ZERO + CALL CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ) ! HNO3 + ENDIF +! +! CONCENTRATION ADJUSTMENTS ; HSO4 minor species. +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL + OHI = AKW/HI + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL(1) = HI + MOLAL(2) = NAI + MOLAL(3) = NH4I + MOLAL(4) = CLI + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + MOLAL(7) = NO3I +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +!cc CALL PUSHERR (0002, 'CALCQ5') ! WARNING ERROR: NO CONVERGENCE +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! +20 A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +! + GNH3 = NH4I/HI/A2 + GHNO3 = HI*NO3I/A3 + GHCL = HI*CLI /A4 +! + GASAQ(1)= NH3AQ + GASAQ(2)= CLAQ + GASAQ(3)= NO3AQ +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNH4CL = ZERO + CNACL = ZERO + CNANO3 = ZERO + CNA2SO4 = ZERO +! + RETURN +! +! *** END OF SUBROUTINE CALCQ5 ****************************************** +! + END SUBROUTINE CALCQ5 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCQ4 +! *** CASE Q4 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0); SODIUM POOR (SODRAT < 2.0) +! 2. LIQUID AND SOLID PHASES ARE POSSIBLE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCQ4 + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + LOGICAL PSCONV1 + DOUBLE PRECISION NH4I, NAI, NO3I, NH3AQ, NO3AQ, CLAQ +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST =.TRUE. + CALAIN =.TRUE. + CALAOU =.TRUE. +! + PSCONV1 =.TRUE. + PSI1O =-GREAT + ROOT3 = ZERO +! +! *** CALCULATE INITIAL SOLUTION *************************************** +! + CALL CALCQ1A +! + CHI1 = CNA2SO4 ! SALTS +! + PSI1 = CNA2SO4 ! AMOUNT DISSOLVED + PSI4 = CNH4CL + PSI5 = CNH4NO3 + PSI6 = CNH42S4 +! + CALL CALCMR ! WATER +! + NAI = WAER(1) ! LIQUID CONCENTRATIONS + SO4I = WAER(2) + NH4I = WAER(3) + NO3I = WAER(4) + CLI = WAER(5) + HSO4I = ZERO + NH3AQ = ZERO + NO3AQ = ZERO + CLAQ = ZERO +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A5 = XK5 *(WATER/GAMA(2))**3. ! Na2SO4 <==> Na+ + AKW = XKW*RH*WATER*WATER ! H2O <==> H+ +! +! SODIUM SULFATE +! + IF (NAI*NAI*SO4I .GT. A5) THEN + BB =-(WAER(2) + WAER(1)) + CC = WAER(1)*WAER(2) + 0.25*WAER(1)*WAER(1) + DD =-0.25*(WAER(1)*WAER(1)*WAER(2) - A5) + CALL POLY3(BB, CC, DD, ROOT3, ISLV) + IF (ISLV.NE.0) ROOT3 = TINY + ROOT3 = MIN (ROOT3, WAER(1)/2.0, WAER(2), CHI1) + ROOT3 = MAX (ROOT3, ZERO) + PSI1 = CHI1-ROOT3 + ENDIF + PSCONV1 = ABS(PSI1-PSI1O) .LE. EPS*PSI1O + PSI1O = PSI1 +! +! ION CONCENTRATIONS ; CORRECTIONS +! + NAI = WAER(1) - 2.D0*ROOT3 + SO4I= WAER(2) - ROOT3 + NH4I = WAER(3) + NO3I = WAER(4) + CLI = WAER(5) +! +! SOLUTION ACIDIC OR BASIC? +! + GG = 2.D0*SO4I + NO3I + CLI - NAI - NH4I + IF (GG.GT.TINY) THEN ! H+ in excess + BB =-GG + CC =-AKW + DD = BB*BB - 4.D0*CC + HI = 0.5D0*(-BB + SQRT(DD)) + OHI= AKW/HI + ELSE ! OH- in excess + BB = GG + CC =-AKW + DD = BB*BB - 4.D0*CC + OHI= 0.5D0*(-BB + SQRT(DD)) + HI = AKW/OHI + ENDIF +! +! UNDISSOCIATED SPECIES EQUILIBRIA +! + IF (HI.LT.OHI) THEN + CALL CALCAMAQ2 (-GG, NH4I, OHI, NH3AQ) + HI = AKW/OHI + HSO4I = ZERO + ELSE + GGNO3 = MAX(2.D0*SO4I + NO3I - NAI - NH4I, ZERO) + GGCL = MAX(GG-GGNO3, ZERO) + IF (GGCL .GT.TINY) CALL CALCCLAQ2 (GGCL, CLI, HI, CLAQ) ! HCl + IF (GGNO3.GT.TINY) THEN + IF (GGCL.LE.TINY) HI = ZERO + CALL CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ) ! HNO3 + ENDIF +! +! CONCENTRATION ADJUSTMENTS ; HSO4 minor species. +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL + OHI = AKW/HI + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL(1) = HI + MOLAL(2) = NAI + MOLAL(3) = NH4I + MOLAL(4) = CLI + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + MOLAL(7) = NO3I +! +! *** CALCULATE WATER ************************************************** +! + CALL CALCMR +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + IF (PSCONV1) GOTO 20 + ENDIF +10 CONTINUE +!cc CALL PUSHERR (0002, 'CALCQ4') ! WARNING ERROR: NO CONVERGENCE +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! +20 A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +! + GNH3 = NH4I/HI/A2 + GHNO3 = HI*NO3I/A3 + GHCL = HI*CLI /A4 +! + GASAQ(1)= NH3AQ + GASAQ(2)= CLAQ + GASAQ(3)= NO3AQ +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNH4CL = ZERO + CNACL = ZERO + CNANO3 = ZERO + CNA2SO4 = CHI1 - PSI1 +! + RETURN +! +! *** END OF SUBROUTINE CALCQ4 ****************************************** +! + END SUBROUTINE CALCQ4 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCQ3 +! *** CASE Q3 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : NH4CL, NA2SO4, NANO3, NACL +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCQ3 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + LOGICAL EXNO, EXCL + EXTERNAL CALCQ1A, CALCQ4 +! +! *** REGIME DEPENDS ON AMBIENT RELATIVE HUMIDITY & POSSIBLE SPECIES *** +! + EXNO = WAER(4).GT.TINY + EXCL = WAER(5).GT.TINY +! + IF (EXNO .OR. EXCL) THEN ! *** NITRATE OR CHLORIDE EXISTS + SCASE = 'Q3 ; SUBCASE 1' + CALL CALCQ3A + SCASE = 'Q3 ; SUBCASE 1' +! + ELSE ! *** NO CHLORIDE AND NITRATE + IF (RH.LT.DRMG3) THEN + SCASE = 'Q3 ; SUBCASE 2' + CALL CALCQ1A ! SOLID + SCASE = 'Q3 ; SUBCASE 2' + ELSE + SCASE = 'Q3 ; SUBCASE 3' ! MDRH (NH4)2SO4, NA2SO4 + CALL CALCMDRP (RH, DRMG3, DRNH42S4, CALCQ1A, CALCQ4) + SCASE = 'Q3 ; SUBCASE 3' + ENDIF + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCQ3 ****************************************** +! + END SUBROUTINE CALCQ3 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCQ3A +! *** CASE Q3 ; SUBCASE A +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0); SODIUM POOR (SODRAT < 2.0) +! 2. LIQUID AND SOLID PHASES ARE POSSIBLE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCQ3A + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + LOGICAL PSCONV1, PSCONV6 + DOUBLE PRECISION NH4I, NAI, NO3I, NH3AQ, NO3AQ, CLAQ +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST =.TRUE. + CALAIN =.TRUE. + CALAOU =.TRUE. +! + PSCONV1 =.TRUE. + PSCONV6 =.TRUE. +! + PSI1O =-GREAT + PSI6O =-GREAT +! + ROOT1 = ZERO + ROOT3 = ZERO +! +! *** CALCULATE INITIAL SOLUTION *************************************** +! + CALL CALCQ1A +! + CHI1 = CNA2SO4 ! SALTS + CHI4 = CNH4CL + CHI6 = CNH42S4 +! + PSI1 = CNA2SO4 ! AMOUNT DISSOLVED + PSI4 = CNH4CL + PSI5 = CNH4NO3 + PSI6 = CNH42S4 +! + CALL CALCMR ! WATER +! + NAI = WAER(1) ! LIQUID CONCENTRATIONS + SO4I = WAER(2) + NH4I = WAER(3) + NO3I = WAER(4) + CLI = WAER(5) + HSO4I = ZERO + NH3AQ = ZERO + NO3AQ = ZERO + CLAQ = ZERO +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A5 = XK5 *(WATER/GAMA(2))**3. ! Na2SO4 <==> Na+ + A7 = XK7 *(WATER/GAMA(4))**3. ! (NH4)2SO4 <==> Na+ + AKW = XKW*RH*WATER*WATER ! H2O <==> H+ +! +! SODIUM SULFATE +! + IF (NAI*NAI*SO4I .GT. A5) THEN + BB =-(WAER(2) + WAER(1) - ROOT1) + CC = WAER(1)*(WAER(2) - ROOT1) + 0.25*WAER(1)*WAER(1) + DD =-0.25*(WAER(1)*WAER(1)*(WAER(2) - ROOT1) - A5) + CALL POLY3(BB, CC, DD, ROOT3, ISLV) + IF (ISLV.NE.0) ROOT3 = TINY + ROOT3 = MIN (ROOT3, WAER(1)/2.0, WAER(2) - ROOT1, CHI1) + ROOT3 = MAX (ROOT3, ZERO) + PSI1 = CHI1-ROOT3 + ENDIF + PSCONV1 = ABS(PSI1-PSI1O) .LE. EPS*PSI1O + PSI1O = PSI1 +! +! AMMONIUM SULFATE +! + IF (NH4I*NH4I*SO4I .GT. A4) THEN + BB =-(WAER(2)+WAER(3)-ROOT3) + CC = WAER(3)*(WAER(2)-ROOT3+0.5D0*WAER(3)) + DD =-((WAER(2)-ROOT3)*WAER(3)**2.D0 + A4)/4.D0 + CALL POLY3(BB, CC, DD, ROOT1, ISLV) + IF (ISLV.NE.0) ROOT1 = TINY + ROOT1 = MIN(ROOT1, WAER(3), WAER(2)-ROOT3, CHI6) + ROOT1 = MAX(ROOT1, ZERO) + PSI6 = CHI6-ROOT1 + ENDIF + PSCONV6 = ABS(PSI6-PSI6O) .LE. EPS*PSI6O + PSI6O = PSI6 +! +! ION CONCENTRATIONS +! + NAI = WAER(1) - 2.D0*ROOT3 + SO4I= WAER(2) - ROOT1 - ROOT3 + NH4I= WAER(3) - 2.D0*ROOT1 + NO3I= WAER(4) + CLI = WAER(5) +! +! SOLUTION ACIDIC OR BASIC? +! + GG = 2.D0*SO4I + NO3I + CLI - NAI - NH4I + IF (GG.GT.TINY) THEN ! H+ in excess + BB =-GG + CC =-AKW + DD = BB*BB - 4.D0*CC + HI = 0.5D0*(-BB + SQRT(DD)) + OHI= AKW/HI + ELSE ! OH- in excess + BB = GG + CC =-AKW + DD = BB*BB - 4.D0*CC + OHI= 0.5D0*(-BB + SQRT(DD)) + HI = AKW/OHI + ENDIF +! +! UNDISSOCIATED SPECIES EQUILIBRIA +! + IF (HI.LT.OHI) THEN + CALL CALCAMAQ2 (-GG, NH4I, OHI, NH3AQ) + HI = AKW/OHI + HSO4I = ZERO + ELSE + GGNO3 = MAX(2.D0*SO4I + NO3I - NAI - NH4I, ZERO) + GGCL = MAX(GG-GGNO3, ZERO) + IF (GGCL .GT.TINY) CALL CALCCLAQ2 (GGCL, CLI, HI, CLAQ) ! HCl + IF (GGNO3.GT.TINY) THEN + IF (GGCL.LE.TINY) HI = ZERO + CALL CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ) ! HNO3 + ENDIF +! +! CONCENTRATION ADJUSTMENTS ; HSO4 minor species. +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL + OHI = AKW/HI + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL(1) = HI + MOLAL(2) = NAI + MOLAL(3) = NH4I + MOLAL(4) = CLI + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + MOLAL(7) = NO3I +! +! *** CALCULATE WATER ************************************************** +! + CALL CALCMR +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + IF (PSCONV1 .AND. PSCONV6) GOTO 20 + ENDIF +10 CONTINUE +!cc CALL PUSHERR (0002, 'CALCQ3A') ! WARNING ERROR: NO CONVERGENCE +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! +20 A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +! + GNH3 = NH4I/HI/A2 + GHNO3 = HI*NO3I/A3 + GHCL = HI*CLI /A4 +! + GASAQ(1)= NH3AQ + GASAQ(2)= CLAQ + GASAQ(3)= NO3AQ +! + CNH42S4 = CHI6 - PSI6 + CNH4NO3 = ZERO + CNH4CL = ZERO + CNACL = ZERO + CNANO3 = ZERO + CNA2SO4 = CHI1 - PSI1 +! + RETURN +! +! *** END OF SUBROUTINE CALCQ3A ***************************************** +! + END SUBROUTINE CALCQ3A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCQ2 +! *** CASE Q2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. SOLID & LIQUID AEROSOL POSSIBLE +! 3. SOLIDS POSSIBLE : NH4CL, NA2SO4, NANO3, NACL +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCQ2 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + LOGICAL EXNO, EXCL + EXTERNAL CALCQ1A, CALCQ3A, CALCQ4 +! +! *** REGIME DEPENDS ON AMBIENT RELATIVE HUMIDITY & POSSIBLE SPECIES *** +! + EXNO = WAER(4).GT.TINY + EXCL = WAER(5).GT.TINY +! + IF (EXNO) THEN ! *** NITRATE EXISTS + SCASE = 'Q2 ; SUBCASE 1' + CALL CALCQ2A + SCASE = 'Q2 ; SUBCASE 1' +! + ELSEIF (.NOT.EXNO .AND. EXCL) THEN ! *** ONLY CHLORIDE EXISTS + IF (RH.LT.DRMG2) THEN + SCASE = 'Q2 ; SUBCASE 2' + CALL CALCQ1A ! SOLID + SCASE = 'Q2 ; SUBCASE 2' + ELSE + SCASE = 'Q2 ; SUBCASE 3' ! MDRH (NH4)2SO4, NA2SO4, NH4CL + CALL CALCMDRP (RH, DRMG2, DRNH4CL, CALCQ1A, CALCQ3A) + SCASE = 'Q2 ; SUBCASE 3' + ENDIF +! + ELSE ! *** NO CHLORIDE AND NITRATE + IF (RH.LT.DRMG3) THEN + SCASE = 'Q2 ; SUBCASE 2' + CALL CALCQ1A ! SOLID + SCASE = 'Q2 ; SUBCASE 2' + ELSE + SCASE = 'Q2 ; SUBCASE 4' ! MDRH (NH4)2SO4, NA2SO4 + CALL CALCMDRP (RH, DRMG3, DRNH42S4, CALCQ1A, CALCQ4) + SCASE = 'Q2 ; SUBCASE 4' + ENDIF + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCQ2 ****************************************** +! + END SUBROUTINE CALCQ2 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCQ2A +! *** CASE Q2 ; SUBCASE A +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0); SODIUM POOR (SODRAT < 2.0) +! 2. LIQUID AND SOLID PHASES ARE POSSIBLE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCQ2A + USE SOLUT + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + LOGICAL PSCONV1, PSCONV4, PSCONV6 + DOUBLE PRECISION NH4I, NAI, NO3I, NH3AQ, NO3AQ, CLAQ +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST =.TRUE. + CALAIN =.TRUE. + CALAOU =.TRUE. +! + PSCONV1 =.TRUE. + PSCONV4 =.TRUE. + PSCONV6 =.TRUE. +! + PSI1O =-GREAT + PSI4O =-GREAT + PSI6O =-GREAT +! + ROOT1 = ZERO + ROOT2 = ZERO + ROOT3 = ZERO +! +! *** CALCULATE INITIAL SOLUTION *************************************** +! + CALL CALCQ1A +! + CHI1 = CNA2SO4 ! SALTS + CHI4 = CNH4CL + CHI6 = CNH42S4 +! + PSI1 = CNA2SO4 ! AMOUNT DISSOLVED + PSI4 = CNH4CL + PSI5 = CNH4NO3 + PSI6 = CNH42S4 +! + CALL CALCMR ! WATER +! + NAI = WAER(1) ! LIQUID CONCENTRATIONS + SO4I = WAER(2) + NH4I = WAER(3) + NO3I = WAER(4) + CLI = WAER(5) + HSO4I = ZERO + NH3AQ = ZERO + NO3AQ = ZERO + CLAQ = ZERO +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A5 = XK5 *(WATER/GAMA(2))**3. ! Na2SO4 <==> Na+ + A14 = XK14*(WATER/GAMA(6))**2. ! NH4Cl <==> NH4+ + A7 = XK7 *(WATER/GAMA(4))**3. ! (NH4)2SO4 <==> Na+ + AKW = XKW*RH*WATER*WATER ! H2O <==> H+ +! +! AMMONIUM CHLORIDE +! + IF (NH4I*CLI .GT. A14) THEN + BB =-(WAER(3) + WAER(5) - 2.D0*ROOT1) + CC = WAER(5)*(WAER(3) - 2.D0*ROOT1) - A14 + DD = BB*BB - 4.D0*CC + IF (DD.LT.ZERO) THEN + ROOT2 = ZERO + ELSE + DD = SQRT(DD) + ROOT2A= 0.5D0*(-BB+DD) + ROOT2B= 0.5D0*(-BB-DD) + IF (ZERO.LE.ROOT2A) THEN + ROOT2 = ROOT2A + ELSE + ROOT2 = ROOT2B + ENDIF + ROOT2 = MIN(ROOT2, WAER(5), WAER(3) - 2.D0*ROOT1, CHI4) + ROOT2 = MAX(ROOT2, ZERO) + PSI4 = CHI4 - ROOT2 + ENDIF + ENDIF + PSCONV4 = ABS(PSI4-PSI4O) .LE. EPS*PSI4O + PSI4O = PSI4 +! +! SODIUM SULFATE +! + IF (NAI*NAI*SO4I .GT. A5) THEN + BB =-(WAER(2) + WAER(1) - ROOT1) + CC = WAER(1)*(WAER(2) - ROOT1) + 0.25*WAER(1)*WAER(1) + DD =-0.25*(WAER(1)*WAER(1)*(WAER(2) - ROOT1) - A5) + CALL POLY3(BB, CC, DD, ROOT3, ISLV) + IF (ISLV.NE.0) ROOT3 = TINY + ROOT3 = MIN (ROOT3, WAER(1)/2.0, WAER(2) - ROOT1, CHI1) + ROOT3 = MAX (ROOT3, ZERO) + PSI1 = CHI1-ROOT3 + ENDIF + PSCONV1 = ABS(PSI1-PSI1O) .LE. EPS*PSI1O + PSI1O = PSI1 +! +! AMMONIUM SULFATE +! + IF (NH4I*NH4I*SO4I .GT. A4) THEN + BB =-(WAER(2)+WAER(3)-ROOT2-ROOT3) + CC = (WAER(3)-ROOT2)*(WAER(2)-ROOT3+0.5D0*(WAER(3)-ROOT2)) + DD =-((WAER(2)-ROOT3)*(WAER(3)-ROOT2)**2.D0 + A4)/4.D0 + CALL POLY3(BB, CC, DD, ROOT1, ISLV) + IF (ISLV.NE.0) ROOT1 = TINY + ROOT1 = MIN(ROOT1, WAER(3)-ROOT2, WAER(2)-ROOT3, CHI6) + ROOT1 = MAX(ROOT1, ZERO) + PSI6 = CHI6-ROOT1 + ENDIF + PSCONV6 = ABS(PSI6-PSI6O) .LE. EPS*PSI6O + PSI6O = PSI6 +! +! ION CONCENTRATIONS +! + NAI = WAER(1) - 2.D0*ROOT3 + SO4I= WAER(2) - ROOT1 - ROOT3 + NH4I= WAER(3) - ROOT2 - 2.D0*ROOT1 + NO3I= WAER(4) + CLI = WAER(5) - ROOT2 +! +! SOLUTION ACIDIC OR BASIC? +! + GG = 2.D0*SO4I + NO3I + CLI - NAI - NH4I + IF (GG.GT.TINY) THEN ! H+ in excess + BB =-GG + CC =-AKW + DD = BB*BB - 4.D0*CC + HI = 0.5D0*(-BB + SQRT(DD)) + OHI= AKW/HI + ELSE ! OH- in excess + BB = GG + CC =-AKW + DD = BB*BB - 4.D0*CC + OHI= 0.5D0*(-BB + SQRT(DD)) + HI = AKW/OHI + ENDIF +! +! UNDISSOCIATED SPECIES EQUILIBRIA +! + IF (HI.LT.OHI) THEN + CALL CALCAMAQ2 (-GG, NH4I, OHI, NH3AQ) + HI = AKW/OHI + HSO4I = ZERO + ELSE + GGNO3 = MAX(2.D0*SO4I + NO3I - NAI - NH4I, ZERO) + GGCL = MAX(GG-GGNO3, ZERO) + IF (GGCL .GT.TINY) CALL CALCCLAQ2 (GGCL, CLI, HI, CLAQ) ! HCl + IF (GGNO3.GT.TINY) THEN + IF (GGCL.LE.TINY) HI = ZERO + CALL CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ) ! HNO3 + ENDIF +! +! CONCENTRATION ADJUSTMENTS ; HSO4 minor species. +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL + OHI = AKW/HI + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL(1) = HI + MOLAL(2) = NAI + MOLAL(3) = NH4I + MOLAL(4) = CLI + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + MOLAL(7) = NO3I +! +! *** CALCULATE WATER ************************************************** +! + CALL CALCMR +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + IF (PSCONV1 .AND. PSCONV4 .AND. PSCONV6) GOTO 20 + ENDIF +10 CONTINUE +!cc CALL PUSHERR (0002, 'CALCQ2A') ! WARNING ERROR: NO CONVERGENCE +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! +20 A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +! + GNH3 = NH4I/HI/A2 + GHNO3 = HI*NO3I/A3 + GHCL = HI*CLI /A4 +! + GASAQ(1)= NH3AQ + GASAQ(2)= CLAQ + GASAQ(3)= NO3AQ +! + CNH42S4 = CHI6 - PSI6 + CNH4NO3 = ZERO + CNH4CL = CHI4 - PSI4 + CNACL = ZERO + CNANO3 = ZERO + CNA2SO4 = CHI1 - PSI1 +! + RETURN +! +! *** END OF SUBROUTINE CALCQ2A ***************************************** +! + END SUBROUTINE CALCQ2A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCQ1 +! *** CASE Q1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : NH4NO3, NH4CL, (NH4)2SO4, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCQ1 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + LOGICAL EXNO, EXCL + EXTERNAL CALCQ1A, CALCQ2A, CALCQ3A, CALCQ4 +! +! *** REGIME DEPENDS ON AMBIENT RELATIVE HUMIDITY & POSSIBLE SPECIES *** +! + EXNO = WAER(4).GT.TINY + EXCL = WAER(5).GT.TINY +! + IF (EXNO .AND. EXCL) THEN ! *** NITRATE & CHLORIDE EXIST + IF (RH.LT.DRMG1) THEN + SCASE = 'Q1 ; SUBCASE 1' + CALL CALCQ1A ! SOLID + SCASE = 'Q1 ; SUBCASE 1' + ELSE + SCASE = 'Q1 ; SUBCASE 2' ! MDRH (NH4)2SO4, NA2SO4, NH4CL, NH4NO3 + CALL CALCMDRP (RH, DRMG1, DRNH4NO3, CALCQ1A, CALCQ2A) + SCASE = 'Q1 ; SUBCASE 2' + ENDIF +! + ELSE IF (EXNO .AND. .NOT.EXCL) THEN ! *** ONLY NITRATE EXISTS + IF (RH.LT.DRMQ1) THEN + SCASE = 'Q1 ; SUBCASE 1' + CALL CALCQ1A ! SOLID + SCASE = 'Q1 ; SUBCASE 1' + ELSE + SCASE = 'Q1 ; SUBCASE 3' ! MDRH (NH4)2SO4, NA2SO4, NH4NO3 + CALL CALCMDRP (RH, DRMQ1, DRNH4NO3, CALCQ1A, CALCQ2A) + SCASE = 'Q1 ; SUBCASE 3' + ENDIF +! + ELSE IF (.NOT.EXNO .AND. EXCL) THEN ! *** ONLY CHLORIDE EXISTS + IF (RH.LT.DRMG2) THEN + SCASE = 'Q1 ; SUBCASE 1' + CALL CALCQ1A ! SOLID + SCASE = 'Q1 ; SUBCASE 1' + ELSE + SCASE = 'Q1 ; SUBCASE 4' ! MDRH (NH4)2SO4, NA2SO4, NH4CL + CALL CALCMDRP (RH, DRMG2, DRNH4CL, CALCQ1A, CALCQ3A) + SCASE = 'Q1 ; SUBCASE 4' + ENDIF +! + ELSE ! *** NO CHLORIDE AND NITRATE + IF (RH.LT.DRMG3) THEN + SCASE = 'Q1 ; SUBCASE 1' + CALL CALCQ1A ! SOLID + SCASE = 'Q1 ; SUBCASE 1' + ELSE + SCASE = 'Q1 ; SUBCASE 5' ! MDRH (NH4)2SO4, NA2SO4 + CALL CALCMDRP (RH, DRMG3, DRNH42S4, CALCQ1A, CALCQ4) + SCASE = 'Q1 ; SUBCASE 5' + ENDIF + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCQ1 ****************************************** +! + END SUBROUTINE CALCQ1 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCQ1A +! *** CASE Q1 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM POOR (SODRAT < 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : NH4NO3, NH4CL, (NH4)2SO4, NA2SO4 +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCQ1A + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** CALCULATE SOLIDS ************************************************** +! + CNA2SO4 = 0.5d0*WAER(1) + FRSO4 = MAX (WAER(2)-CNA2SO4, ZERO) +! + CNH42S4 = MAX (MIN(FRSO4,0.5d0*WAER(3)), TINY) + FRNH3 = MAX (WAER(3)-2.D0*CNH42S4, ZERO) +! + CNH4NO3 = MIN (FRNH3, WAER(4)) +!CC FRNO3 = MAX (WAER(4)-CNH4NO3, ZERO) + FRNH3 = MAX (FRNH3-CNH4NO3, ZERO) +! + CNH4CL = MIN (FRNH3, WAER(5)) +!CC FRCL = MAX (WAER(5)-CNH4CL, ZERO) + FRNH3 = MAX (FRNH3-CNH4CL, ZERO) +! +! *** OTHER PHASES ****************************************************** +! + WATER = ZERO +! + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO +! + RETURN +! +! *** END OF SUBROUTINE CALCQ1A ***************************************** +! + END SUBROUTINE CALCQ1A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCR6 +! *** CASE R6 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0); SODIUM RICH (SODRAT >= 2.0) +! 2. THERE IS ONLY A LIQUID PHASE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCR6 + USE SOLUT + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + DOUBLE PRECISION NH4I, NAI, NO3I, NH3AQ, NO3AQ, CLAQ +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + CALL CALCR1A +! + PSI1 = CNA2SO4 + PSI2 = CNANO3 + PSI3 = CNACL + PSI4 = CNH4CL + PSI5 = CNH4NO3 +! + FRST = .TRUE. + CALAIN = .TRUE. + CALAOU = .TRUE. +! +! *** CALCULATE WATER ************************************************** +! + CALL CALCMR +! +! *** SETUP LIQUID CONCENTRATIONS ************************************** +! + HSO4I = ZERO + NH3AQ = ZERO + NO3AQ = ZERO + CLAQ = ZERO +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + AKW = XKW*RH*WATER*WATER ! H2O <==> H+ +! + NAI = WAER(1) + SO4I = WAER(2) + NH4I = WAER(3) + NO3I = WAER(4) + CLI = WAER(5) +! +! SOLUTION ACIDIC OR BASIC? +! + GG = 2.D0*WAER(2) + NO3I + CLI - NAI - NH4I + IF (GG.GT.TINY) THEN ! H+ in excess + BB =-GG + CC =-AKW + DD = BB*BB - 4.D0*CC + HI = 0.5D0*(-BB + SQRT(DD)) + OHI= AKW/HI + ELSE ! OH- in excess + BB = GG + CC =-AKW + DD = BB*BB - 4.D0*CC + OHI= 0.5D0*(-BB + SQRT(DD)) + HI = AKW/OHI + ENDIF +! +! UNDISSOCIATED SPECIES EQUILIBRIA +! + IF (HI.LT.OHI) THEN + CALL CALCAMAQ2 (-GG, NH4I, OHI, NH3AQ) + HI = AKW/OHI + ELSE + GGNO3 = MAX(2.D0*SO4I + NO3I - NAI - NH4I, ZERO) + GGCL = MAX(GG-GGNO3, ZERO) + IF (GGCL .GT.TINY) CALL CALCCLAQ2 (GGCL, CLI, HI, CLAQ) ! HCl + IF (GGNO3.GT.TINY) THEN + IF (GGCL.LE.TINY) HI = ZERO + CALL CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ) ! HNO3 + ENDIF +! +! CONCENTRATION ADJUSTMENTS ; HSO4 minor species. +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL + OHI = AKW/HI + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL(1) = HI + MOLAL(2) = NAI + MOLAL(3) = NH4I + MOLAL(4) = CLI + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + MOLAL(7) = NO3I +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + GOTO 20 + ENDIF +10 CONTINUE +!cc CALL PUSHERR (0002, 'CALCR6') ! WARNING ERROR: NO CONVERGENCE +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! +20 A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +! + GNH3 = NH4I/HI/A2 + GHNO3 = HI*NO3I/A3 + GHCL = HI*CLI /A4 +! + GASAQ(1) = NH3AQ + GASAQ(2) = CLAQ + GASAQ(3) = NO3AQ +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNH4CL = ZERO + CNACL = ZERO + CNANO3 = ZERO + CNA2SO4 = ZERO +! + RETURN +! +! *** END OF SUBROUTINE CALCR6 ****************************************** +! + END SUBROUTINE CALCR6 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCR5 +! *** CASE R5 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0); SODIUM RICH (SODRAT >= 2.0) +! 2. LIQUID AND SOLID PHASES ARE POSSIBLE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCR5 + USE SOLUT + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + LOGICAL PSCONV + DOUBLE PRECISION NH4I, NAI, NO3I, NH3AQ, NO3AQ, CLAQ +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! + LOGICAL NEAN, NEAC, NESN, NESC +! +! *** SETUP PARAMETERS ************************************************ +! + CALL CALCR1A ! DRY SOLUTION +! + NEAN = CNH4NO3.LE.TINY ! NH4NO3 ! Water exists? + NEAC = CNH4CL .LE.TINY ! NH4CL + NESN = CNANO3 .LE.TINY ! NANO3 + NESC = CNACL .LE.TINY ! NACL + IF (NEAN .AND. NEAC .AND. NESN .AND. NESC) RETURN +! + CHI1 = CNA2SO4 +! + PSI1 = CNA2SO4 + PSI2 = CNANO3 + PSI3 = CNACL + PSI4 = CNH4CL + PSI5 = CNH4NO3 +! + PSIO =-GREAT +! +! *** CALCULATE WATER ************************************************** +! + CALL CALCMR +! + FRST = .TRUE. + CALAIN = .TRUE. + CALAOU = .TRUE. + PSCONV = .FALSE. +! +! *** SETUP LIQUID CONCENTRATIONS ************************************** +! + NAI = WAER(1) + SO4I = WAER(2) + NH4I = WAER(3) + NO3I = WAER(4) + CLI = WAER(5) + HSO4I = ZERO + NH3AQ = ZERO + NO3AQ = ZERO + CLAQ = ZERO +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A5 = XK5*(WATER/GAMA(2))**3. ! Na2SO4 <==> Na+ + AKW = XKW*RH*WATER*WATER ! H2O <==> H+ +! +! SODIUM SULFATE +! + ROOT = ZERO + IF (NAI*NAI*SO4I .GT. A5) THEN + BB =-3.D0*CHI1 + CC = 3.D0*CHI1**2.0 + DD =-CHI1**3.0 + 0.25D0*A5 + CALL POLY3(BB, CC, DD, ROOT, ISLV) + IF (ISLV.NE.0) ROOT = TINY + ROOT = MIN (MAX(ROOT,ZERO), CHI1) + PSI1 = CHI1-ROOT + ENDIF + PSCONV = ABS(PSI1-PSIO) .LE. EPS*PSIO + PSIO = PSI1 +! +! ION CONCENTRATIONS +! + NAI = WAER(1) - 2.D0*ROOT + SO4I = WAER(2) - ROOT + NH4I = WAER(3) + NO3I = WAER(4) + CLI = WAER(5) +! +! SOLUTION ACIDIC OR BASIC? +! + GG = 2.D0*SO4I + NO3I + CLI - NAI - NH4I + IF (GG.GT.TINY) THEN ! H+ in excess + BB =-GG + CC =-AKW + DD = BB*BB - 4.D0*CC + HI = 0.5D0*(-BB + SQRT(DD)) + OHI= AKW/HI + ELSE ! OH- in excess + BB = GG + CC =-AKW + DD = BB*BB - 4.D0*CC + OHI= 0.5D0*(-BB + SQRT(DD)) + HI = AKW/OHI + ENDIF +! +! UNDISSOCIATED SPECIES EQUILIBRIA +! + IF (HI.LT.OHI) THEN + CALL CALCAMAQ2 (-GG, NH4I, OHI, NH3AQ) + HI = AKW/OHI + ELSE + GGNO3 = MAX(2.D0*SO4I + NO3I - NAI - NH4I, ZERO) + GGCL = MAX(GG-GGNO3, ZERO) + IF (GGCL .GT.TINY) CALL CALCCLAQ2 (GGCL, CLI, HI, CLAQ) ! HCl + IF (GGNO3.GT.TINY) THEN + IF (GGCL.LE.TINY) HI = ZERO + CALL CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ) ! HNO3 + ENDIF +! +! CONCENTRATION ADJUSTMENTS ; HSO4 minor species. +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL + OHI = AKW/HI + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL(1) = HI + MOLAL(2) = NAI + MOLAL(3) = NH4I + MOLAL(4) = CLI + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + MOLAL(7) = NO3I +! +! *** CALCULATE WATER ************************************************** +! + CALL CALCMR +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + IF (PSCONV) GOTO 20 + ENDIF +10 CONTINUE +!cc CALL PUSHERR (0002, 'CALCR5') ! WARNING ERROR: NO CONVERGENCE +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! +20 A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ +!C A21 = XK21*WATER*R*TEMP + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +! + GNH3 = NH4I/HI/A2 ! NH4I*OHI/A2/AKW + GHNO3 = HI*NO3I/A3 + GHCL = HI*CLI /A4 +! + GASAQ(1) = NH3AQ + GASAQ(2) = CLAQ + GASAQ(3) = NO3AQ +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNH4CL = ZERO + CNACL = ZERO + CNANO3 = ZERO + CNA2SO4 = CHI1 - PSI1 +! + RETURN +! +! *** END OF SUBROUTINE CALCR5 ****************************************** +! + END SUBROUTINE CALCR5 +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCR4 +! *** CASE R4 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : NH4NO3, NH4CL, NA2SO4, NANO3, NACL +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCR4 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + LOGICAL EXAN, EXAC, EXSN, EXSC + EXTERNAL CALCR1A, CALCR5 +! +! *** SOLVE FOR DRY CASE AND SEE WHICH SOLIDS ARE POSSIBLE ************** +! + SCASE = 'R4 ; SUBCASE 2' + CALL CALCR1A ! SOLID + SCASE = 'R4 ; SUBCASE 2' +! + EXAN = CNH4NO3.GT.TINY ! NH4NO3 + EXAC = CNH4CL .GT.TINY ! NH4CL + EXSN = CNANO3 .GT.TINY ! NANO3 + EXSC = CNACL .GT.TINY ! NACL +! +! *** REGIME DEPENDS ON RELATIVE HUMIDITY AND POSSIBLE SPECIES ********** +! + IF (EXAN .OR. EXSN .OR. EXSC) THEN ! *** NH4NO3,NANO3 EXIST + IF (RH.GE.DRMH1) THEN + SCASE = 'R4 ; SUBCASE 1' + CALL CALCR4A + SCASE = 'R4 ; SUBCASE 1' + ENDIF +! + ELSE IF (EXAC) THEN ! *** NH4CL EXISTS ONLY + IF (RH.GE.DRMR5) THEN + SCASE = 'R4 ; SUBCASE 3' + CALL CALCMDRP (RH, DRMR5, DRNH4CL, CALCR1A, CALCR5) + SCASE = 'R4 ; SUBCASE 3' + ENDIF + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCR4 ****************************************** +! + END SUBROUTINE CALCR4 + + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCR4A +! *** CASE R4A +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0); SODIUM RICH (SODRAT >= 2.0) +! 2. LIQUID AND SOLID PHASES ARE POSSIBLE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCR4A + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + LOGICAL PSCONV1, PSCONV4 + DOUBLE PRECISION NH4I, NAI, NO3I, NH3AQ, NO3AQ, CLAQ +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST = .TRUE. + CALAIN = .TRUE. + CALAOU = .TRUE. + PSCONV1 = .FALSE. + PSCONV4 = .FALSE. + PSIO1 =-GREAT + PSIO4 =-GREAT +! +! *** CALCULATE INITIAL SOLUTION *************************************** +! + CALL CALCR1A +! + CHI1 = CNA2SO4 ! SALTS + CHI4 = CNH4CL +! + PSI1 = CNA2SO4 + PSI2 = CNANO3 + PSI3 = CNACL + PSI4 = CNH4CL + PSI5 = CNH4NO3 +! + CALL CALCMR ! WATER +! + NAI = WAER(1) ! LIQUID CONCENTRATIONS + SO4I = WAER(2) + NH4I = WAER(3) + NO3I = WAER(4) + CLI = WAER(5) + HSO4I = ZERO + NH3AQ = ZERO + NO3AQ = ZERO + CLAQ = ZERO +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A5 = XK5 *(WATER/GAMA(2))**3. ! Na2SO4 <==> Na+ + A14 = XK14*(WATER/GAMA(6))**2. ! NH4Cl <==> NH4+ + AKW = XKW*RH*WATER*WATER ! H2O <==> H+ +! +! SODIUM SULFATE +! + ROOT = ZERO + IF (NAI*NAI*SO4I .GT. A5) THEN + BB =-3.D0*CHI1 + CC = 3.D0*CHI1**2.0 + DD =-CHI1**3.0 + 0.25D0*A5 + CALL POLY3(BB, CC, DD, ROOT, ISLV) + IF (ISLV.NE.0) ROOT = TINY + ROOT = MIN (MAX(ROOT,ZERO), CHI1) + PSI1 = CHI1-ROOT + NAI = WAER(1) - 2.D0*ROOT + SO4I = WAER(2) - ROOT + ENDIF + PSCONV1 = ABS(PSI1-PSIO1) .LE. EPS*PSIO1 + PSIO1 = PSI1 +! +! AMMONIUM CHLORIDE +! + ROOT = ZERO + IF (NH4I*CLI .GT. A14) THEN + BB =-(NH4I + CLI) + CC =-A14 + NH4I*CLI + DD = BB*BB - 4.D0*CC + ROOT = 0.5D0*(-BB-SQRT(DD)) + IF (ROOT.GT.TINY) THEN + ROOT = MIN(ROOT, CHI4) + PSI4 = CHI4 - ROOT + NH4I = WAER(3) - ROOT + CLI = WAER(5) - ROOT + ENDIF + ENDIF + PSCONV4 = ABS(PSI4-PSIO4) .LE. EPS*PSIO4 + PSIO4 = PSI4 +! + NO3I = WAER(4) +! +! SOLUTION ACIDIC OR BASIC? +! + GG = 2.D0*SO4I + NO3I + CLI - NAI - NH4I + IF (GG.GT.TINY) THEN ! H+ in excess + BB =-GG + CC =-AKW + DD = BB*BB - 4.D0*CC + HI = 0.5D0*(-BB + SQRT(DD)) + OHI= AKW/HI + ELSE ! OH- in excess + BB = GG + CC =-AKW + DD = BB*BB - 4.D0*CC + OHI= 0.5D0*(-BB + SQRT(DD)) + HI = AKW/OHI + ENDIF +! +! UNDISSOCIATED SPECIES EQUILIBRIA +! + IF (HI.LT.OHI) THEN + CALL CALCAMAQ2 (-GG, NH4I, OHI, NH3AQ) + HI = AKW/OHI + ELSE + GGNO3 = MAX(2.D0*SO4I + NO3I - NAI - NH4I, ZERO) + GGCL = MAX(GG-GGNO3, ZERO) + IF (GGCL .GT.TINY) CALL CALCCLAQ2 (GGCL, CLI, HI, CLAQ) ! HCl + IF (GGNO3.GT.TINY) THEN + IF (GGCL.LE.TINY) HI = ZERO + CALL CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ) ! HNO3 + ENDIF +! +! CONCENTRATION ADJUSTMENTS ; HSO4 minor species. +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL + OHI = AKW/HI + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL(1) = HI + MOLAL(2) = NAI + MOLAL(3) = NH4I + MOLAL(4) = CLI + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + MOLAL(7) = NO3I +! +! *** CALCULATE WATER ************************************************** +! + CALL CALCMR +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + IF (PSCONV1 .AND. PSCONV4) GOTO 20 + ENDIF +10 CONTINUE +!cc CALL PUSHERR (0002, 'CALCR4A') ! WARNING ERROR: NO CONVERGENCE +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! +20 A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +! + GNH3 = NH4I/HI/A2 + GHNO3 = HI*NO3I/A3 + GHCL = HI*CLI /A4 +! + GASAQ(1)= NH3AQ + GASAQ(2)= CLAQ + GASAQ(3)= NO3AQ +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNH4CL = CHI4 - PSI4 + CNACL = ZERO + CNANO3 = ZERO + CNA2SO4 = CHI1 - PSI1 +! + RETURN +! +! *** END OF SUBROUTINE CALCR4A ***************************************** +! + END SUBROUTINE CALCR4A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCR3 +! *** CASE R3 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : NH4NO3, NH4CL, NA2SO4, NANO3, NACL +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCR3 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + LOGICAL EXAN, EXAC, EXSN, EXSC + EXTERNAL CALCR1A, CALCR4A, CALCR5 +! +! *** SOLVE FOR DRY CASE AND SEE WHICH SOLIDS ARE POSSIBLE ************** +! + SCASE = 'R3 ; SUBCASE 2' + CALL CALCR1A ! SOLID + SCASE = 'R3 ; SUBCASE 2' +! + EXAN = CNH4NO3.GT.TINY ! NH4NO3 + EXAC = CNH4CL .GT.TINY ! NH4CL + EXSN = CNANO3 .GT.TINY ! NANO3 + EXSC = CNACL .GT.TINY ! NACL +! +! *** REGIME DEPENDS ON RELATIVE HUMIDITY AND POSSIBLE SPECIES ********** +! + IF (EXAN .OR. EXSN) THEN ! *** NH4NO3,NANO3 EXIST + IF (RH.GE.DRMH1) THEN + SCASE = 'R3 ; SUBCASE 1' + CALL CALCR3A + SCASE = 'R3 ; SUBCASE 1' + ENDIF +! + ELSE IF (.NOT.EXAN .AND. .NOT.EXSN) THEN ! *** NH4NO3,NANO3 = 0 + IF ( EXAC .AND. EXSC) THEN + IF (RH.GE.DRMR4) THEN + SCASE = 'R3 ; SUBCASE 3' + CALL CALCMDRP (RH, DRMR4, DRNACL, CALCR1A, CALCR4A) + SCASE = 'R3 ; SUBCASE 3' + ENDIF + + ELSE IF (.NOT.EXAC .AND. EXSC) THEN + IF (RH.GE.DRMR2) THEN + SCASE = 'R3 ; SUBCASE 4' + CALL CALCMDRP (RH, DRMR2, DRNACL, CALCR1A, CALCR4A) + SCASE = 'R3 ; SUBCASE 4' + ENDIF + + ELSE IF ( EXAC .AND. .NOT.EXSC) THEN + IF (RH.GE.DRMR5) THEN + SCASE = 'R3 ; SUBCASE 5' + CALL CALCMDRP (RH, DRMR5, DRNACL, CALCR1A, CALCR5) + SCASE = 'R3 ; SUBCASE 5' + ENDIF + ENDIF +! + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCR3 ****************************************** +! + END SUBROUTINE CALCR3 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCR3A +! *** CASE R3A +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0); SODIUM RICH (SODRAT >= 2.0) +! 2. LIQUID AND SOLID PHASES ARE POSSIBLE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCR3A + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + LOGICAL PSCONV1, PSCONV3, PSCONV4 + DOUBLE PRECISION NH4I, NAI, NO3I, NH3AQ, NO3AQ, CLAQ +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST =.TRUE. + CALAIN =.TRUE. + CALAOU =.TRUE. + PSCONV1 =.TRUE. + PSCONV3 =.TRUE. + PSCONV4 =.TRUE. + PSI1O =-GREAT + PSI3O =-GREAT + PSI4O =-GREAT + ROOT1 = ZERO + ROOT2 = ZERO + ROOT3 = ZERO +! +! *** CALCULATE INITIAL SOLUTION *************************************** +! + CALL CALCR1A +! + CHI1 = CNA2SO4 ! SALTS + CHI4 = CNH4CL + CHI3 = CNACL +! + PSI1 = CNA2SO4 + PSI2 = CNANO3 + PSI3 = CNACL + PSI4 = CNH4CL + PSI5 = CNH4NO3 +! + CALL CALCMR ! WATER +! + NAI = WAER(1) ! LIQUID CONCENTRATIONS + SO4I = WAER(2) + NH4I = WAER(3) + NO3I = WAER(4) + CLI = WAER(5) + HSO4I = ZERO + NH3AQ = ZERO + NO3AQ = ZERO + CLAQ = ZERO +! + MOLAL(1) = ZERO + MOLAL(2) = NAI + MOLAL(3) = NH4I + MOLAL(4) = CLI + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + MOLAL(7) = NO3I +! + CALL CALCACT ! CALCULATE ACTIVITY COEFFICIENTS +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A5 = XK5 *(WATER/GAMA(2))**3. ! Na2SO4 <==> Na+ + A8 = XK8 *(WATER/GAMA(1))**2. ! NaCl <==> Na+ + A14 = XK14*(WATER/GAMA(6))**2. ! NH4Cl <==> NH4+ + AKW = XKW*RH*WATER*WATER ! H2O <==> H+ +! +! AMMONIUM CHLORIDE +! + IF (NH4I*CLI .GT. A14) THEN + BB =-(WAER(3) + WAER(5) - ROOT3) + CC =-A14 + NH4I*(WAER(5) - ROOT3) + DD = MAX(BB*BB - 4.D0*CC, ZERO) + ROOT2A= 0.5D0*(-BB+SQRT(DD)) + ROOT2B= 0.5D0*(-BB-SQRT(DD)) + IF (ZERO.LE.ROOT2A) THEN + ROOT2 = ROOT2A + ELSE + ROOT2 = ROOT2B + ENDIF + ROOT2 = MIN(MAX(ZERO, ROOT2), MAX(WAER(5)-ROOT3,ZERO), & + CHI4, WAER(3)) + PSI4 = CHI4 - ROOT2 + ENDIF + PSCONV4 = ABS(PSI4-PSI4O) .LE. EPS*PSI4O + PSI4O = PSI4 +! +! SODIUM SULFATE +! + IF (NAI*NAI*SO4I .GT. A5) THEN + BB =-(CHI1 + WAER(1) - ROOT3) + CC = 0.25D0*(WAER(1) - ROOT3)*(4.D0*CHI1+WAER(1)-ROOT3) + DD =-0.25D0*(CHI1*(WAER(1)-ROOT3)**2.D0 - A5) + CALL POLY3(BB, CC, DD, ROOT1, ISLV) + IF (ISLV.NE.0) ROOT1 = TINY + ROOT1 = MIN (MAX(ROOT1,ZERO), MAX(WAER(1)-ROOT3,ZERO), & + CHI1, WAER(2)) + PSI1 = CHI1-ROOT1 + ENDIF + PSCONV1 = ABS(PSI1-PSI1O) .LE. EPS*PSI1O + PSI1O = PSI1 +! +! ION CONCENTRATIONS +! + NAI = WAER(1) - (2.D0*ROOT1 + ROOT3) + SO4I= WAER(2) - ROOT1 + NH4I= WAER(3) - ROOT2 + CLI = WAER(5) - (ROOT3 + ROOT2) + NO3I= WAER(4) +! +! SODIUM CHLORIDE ; To obtain new value for ROOT3 +! + IF (NAI*CLI .GT. A8) THEN + BB =-((CHI1-2.D0*ROOT1) + (WAER(5) - ROOT2)) + CC = (CHI1-2.D0*ROOT1)*(WAER(5) - ROOT2) - A8 + DD = SQRT(MAX(BB*BB - 4.D0*CC, TINY)) + ROOT3A= 0.5D0*(-BB-SQRT(DD)) + ROOT3B= 0.5D0*(-BB+SQRT(DD)) + IF (ZERO.LE.ROOT3A) THEN + ROOT3 = ROOT3A + ELSE + ROOT3 = ROOT3B + ENDIF + ROOT3 = MIN(MAX(ROOT3, ZERO), CHI3) + PSI3 = CHI3-ROOT3 + ENDIF + PSCONV3 = ABS(PSI3-PSI3O) .LE. EPS*PSI3O + PSI3O = PSI3 +! +! SOLUTION ACIDIC OR BASIC? +! + GG = 2.D0*SO4I + NO3I + CLI - NAI - NH4I + IF (GG.GT.TINY) THEN ! H+ in excess + BB =-GG + CC =-AKW + DD = BB*BB - 4.D0*CC + HI = 0.5D0*(-BB + SQRT(DD)) + OHI= AKW/HI + ELSE ! OH- in excess + BB = GG + CC =-AKW + DD = BB*BB - 4.D0*CC + OHI= 0.5D0*(-BB + SQRT(DD)) + HI = AKW/OHI + ENDIF +! +! UNDISSOCIATED SPECIES EQUILIBRIA +! + IF (HI.LT.OHI) THEN + CALL CALCAMAQ2 (-GG, NH4I, OHI, NH3AQ) + HI = AKW/OHI + ELSE + GGNO3 = MAX(2.D0*SO4I + NO3I - NAI - NH4I, ZERO) + GGCL = MAX(GG-GGNO3, ZERO) + IF (GGCL .GT.TINY) CALL CALCCLAQ2 (GGCL, CLI, HI, CLAQ) ! HCl + IF (GGNO3.GT.TINY) THEN + IF (GGCL.LE.TINY) HI = ZERO + CALL CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ) ! HNO3 + ENDIF +! +! CONCENTRATION ADJUSTMENTS ; HSO4 minor species. +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL + OHI = AKW/HI + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL(1) = HI + MOLAL(2) = NAI + MOLAL(3) = NH4I + MOLAL(4) = CLI + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + MOLAL(7) = NO3I +! +! *** CALCULATE WATER ************************************************** +! + CALL CALCMR +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + IF (PSCONV1.AND.PSCONV3.AND.PSCONV4) GOTO 20 + ENDIF +10 CONTINUE +!cc CALL PUSHERR (0002, 'CALCR3A') ! WARNING ERROR: NO CONVERGENCE +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! +20 IF (CLI.LE.TINY .AND. WAER(5).GT.TINY) THEN !No disslv Cl-;solid only + DO 30 I=1,NIONS + MOLAL(I) = ZERO +30 CONTINUE + DO 40 I=1,NGASAQ + GASAQ(I) = ZERO +40 CONTINUE + CALL CALCR1A + ELSE + A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +! + GNH3 = NH4I/HI/A2 + GHNO3 = HI*NO3I/A3 + GHCL = HI*CLI /A4 +! + GASAQ(1)= NH3AQ + GASAQ(2)= CLAQ + GASAQ(3)= NO3AQ +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNH4CL = CHI4 - PSI4 + CNACL = CHI3 - PSI3 + CNANO3 = ZERO + CNA2SO4 = CHI1 - PSI1 + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCR3A ***************************************** +! + END SUBROUTINE CALCR3A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCR2 +! *** CASE R2 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : NH4NO3, NH4CL, NA2SO4, NANO3, NACL +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCR2 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + LOGICAL EXAN, EXAC, EXSN, EXSC + EXTERNAL CALCR1A, CALCR3A, CALCR4A, CALCR5 +! +! *** SOLVE FOR DRY CASE AND SEE WHICH SOLIDS ARE POSSIBLE ************** +! + SCASE = 'R2 ; SUBCASE 2' + CALL CALCR1A ! SOLID + SCASE = 'R2 ; SUBCASE 2' +! + EXAN = CNH4NO3.GT.TINY ! NH4NO3 + EXAC = CNH4CL .GT.TINY ! NH4CL + EXSN = CNANO3 .GT.TINY ! NANO3 + EXSC = CNACL .GT.TINY ! NACL +! +! *** REGIME DEPENDS ON RELATIVE HUMIDITY AND POSSIBLE SPECIES ********** +! + IF (EXAN) THEN ! *** NH4NO3 EXISTS + IF (RH.GE.DRMH1) THEN + SCASE = 'R2 ; SUBCASE 1' + CALL CALCR2A + SCASE = 'R2 ; SUBCASE 1' + ENDIF +! + ELSE IF (.NOT.EXAN) THEN ! *** NH4NO3 = 0 + IF ( EXAC .AND. EXSN .AND. EXSC) THEN + IF (RH.GE.DRMH2) THEN + SCASE = 'R2 ; SUBCASE 3' + CALL CALCMDRP (RH, DRMH2, DRNANO3, CALCR1A, CALCR3A) + SCASE = 'R2 ; SUBCASE 3' + ENDIF + + ELSE IF (.NOT.EXAC .AND. EXSN .AND. EXSC) THEN + IF (RH.GE.DRMR1) THEN + SCASE = 'R2 ; SUBCASE 4' + CALL CALCMDRP (RH, DRMR1, DRNANO3, CALCR1A, CALCR3A) + SCASE = 'R2 ; SUBCASE 4' + ENDIF + + ELSE IF (.NOT.EXAC .AND. .NOT.EXSN .AND. EXSC) THEN + IF (RH.GE.DRMR2) THEN + SCASE = 'R2 ; SUBCASE 5' + CALL CALCMDRP (RH, DRMR2, DRNACL, CALCR1A, CALCR4A) + SCASE = 'R2 ; SUBCASE 5' + ENDIF + + ELSE IF (.NOT.EXAC .AND. EXSN .AND. .NOT.EXSC) THEN + IF (RH.GE.DRMR3) THEN + SCASE = 'R2 ; SUBCASE 6' + CALL CALCMDRP (RH, DRMR3, DRNANO3, CALCR1A, CALCR3A) + SCASE = 'R2 ; SUBCASE 6' + ENDIF + + ELSE IF ( EXAC .AND. .NOT.EXSN .AND. EXSC) THEN + IF (RH.GE.DRMR4) THEN + SCASE = 'R2 ; SUBCASE 7' + CALL CALCMDRP (RH, DRMR4, DRNACL, CALCR1A, CALCR4A) + SCASE = 'R2 ; SUBCASE 7' + ENDIF + + ELSE IF ( EXAC .AND. .NOT.EXSN .AND. .NOT.EXSC) THEN + IF (RH.GE.DRMR5) THEN + SCASE = 'R2 ; SUBCASE 8' + CALL CALCMDRP (RH, DRMR5, DRNH4CL, CALCR1A, CALCR5) + SCASE = 'R2 ; SUBCASE 8' + ENDIF + + ELSE IF ( EXAC .AND. EXSN .AND. .NOT.EXSC) THEN + IF (RH.GE.DRMR6) THEN + SCASE = 'R2 ; SUBCASE 9' + CALL CALCMDRP (RH, DRMR6, DRNANO3, CALCR1A, CALCR3A) + SCASE = 'R2 ; SUBCASE 9' + ENDIF + ENDIF +! + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCR2 ****************************************** +! + END SUBROUTINE CALCR2 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCR2A +! *** CASE R2A +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0); SODIUM RICH (SODRAT >= 2.0) +! 2. LIQUID AND SOLID PHASES ARE POSSIBLE +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCR2A + USE ISRPIA + USE SOLUT + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! + LOGICAL PSCONV1, PSCONV2, PSCONV3, PSCONV4 + DOUBLE PRECISION NH4I, NAI, NO3I, NH3AQ, NO3AQ, CLAQ +! COMMON /SOLUT/ CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & +! PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & +! A1, A2, A3, A4, A5, A6, A7, A8 +! +! *** SETUP PARAMETERS ************************************************ +! + FRST =.TRUE. + CALAIN =.TRUE. + CALAOU =.TRUE. +! + PSCONV1 =.TRUE. + PSCONV2 =.TRUE. + PSCONV3 =.TRUE. + PSCONV4 =.TRUE. +! + PSI1O =-GREAT + PSI2O =-GREAT + PSI3O =-GREAT + PSI4O =-GREAT +! + ROOT1 = ZERO + ROOT2 = ZERO + ROOT3 = ZERO + ROOT4 = ZERO +! +! *** CALCULATE INITIAL SOLUTION *************************************** +! + CALL CALCR1A +! + CHI1 = CNA2SO4 ! SALTS + CHI2 = CNANO3 + CHI3 = CNACL + CHI4 = CNH4CL +! + PSI1 = CNA2SO4 + PSI2 = CNANO3 + PSI3 = CNACL + PSI4 = CNH4CL + PSI5 = CNH4NO3 +! + CALL CALCMR ! WATER +! + NAI = WAER(1) ! LIQUID CONCENTRATIONS + SO4I = WAER(2) + NH4I = WAER(3) + NO3I = WAER(4) + CLI = WAER(5) + HSO4I = ZERO + NH3AQ = ZERO + NO3AQ = ZERO + CLAQ = ZERO +! + MOLAL(1) = ZERO + MOLAL(2) = NAI + MOLAL(3) = NH4I + MOLAL(4) = CLI + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + MOLAL(7) = NO3I +! + CALL CALCACT ! CALCULATE ACTIVITY COEFFICIENTS +! +! *** SOLVE EQUATIONS ; WITH ITERATIONS FOR ACTIVITY COEF. ************ +! + DO 10 I=1,NSWEEP + A5 = XK5 *(WATER/GAMA(2))**3. ! Na2SO4 <==> Na+ + A8 = XK8 *(WATER/GAMA(1))**2. ! NaCl <==> Na+ + A9 = XK9 *(WATER/GAMA(3))**2. ! NaNO3 <==> Na+ + A14 = XK14*(WATER/GAMA(6))**2. ! NH4Cl <==> NH4+ + AKW = XKW*RH*WATER*WATER ! H2O <==> H+ +! +! AMMONIUM CHLORIDE +! + IF (NH4I*CLI .GT. A14) THEN + BB =-(WAER(3) + WAER(5) - ROOT3) + CC = NH4I*(WAER(5) - ROOT3) - A14 + DD = MAX(BB*BB - 4.D0*CC, ZERO) + DD = SQRT(DD) + ROOT2A= 0.5D0*(-BB+DD) + ROOT2B= 0.5D0*(-BB-DD) + IF (ZERO.LE.ROOT2A) THEN + ROOT2 = ROOT2A + ELSE + ROOT2 = ROOT2B + ENDIF + ROOT2 = MIN(MAX(ROOT2, ZERO), CHI4) + PSI4 = CHI4 - ROOT2 + ENDIF + PSCONV4 = ABS(PSI4-PSI4O) .LE. EPS*PSI4O + PSI4O = PSI4 +! +! SODIUM SULFATE +! + IF (NAI*NAI*SO4I .GT. A5) THEN + BB =-(WAER(2) + WAER(1) - ROOT3 - ROOT4) + CC = WAER(1)*(2.D0*ROOT3 + 2.D0*ROOT4 - 4.D0*WAER(2) - ONE) & + -(ROOT3 + ROOT4)**2.0 + 4.D0*WAER(2)*(ROOT3 + ROOT4) + CC =-0.25*CC + DD = WAER(1)*WAER(2)*(ONE - 2.D0*ROOT3 - 2.D0*ROOT4) + & + WAER(2)*(ROOT3 + ROOT4)**2.0 - A5 + DD =-0.25*DD + CALL POLY3(BB, CC, DD, ROOT1, ISLV) + IF (ISLV.NE.0) ROOT1 = TINY + ROOT1 = MIN (MAX(ROOT1,ZERO), CHI1) + PSI1 = CHI1-ROOT1 + ENDIF + PSCONV1 = ABS(PSI1-PSI1O) .LE. EPS*PSI1O + PSI1O = PSI1 +! +! SODIUM NITRATE +! + IF (NAI*NO3I .GT. A9) THEN + BB =-(WAER(4) + WAER(1) - 2.D0*ROOT1 - ROOT3) + CC = WAER(4)*(WAER(1) - 2.D0*ROOT1 - ROOT3) - A9 + DD = SQRT(MAX(BB*BB - 4.D0*CC, TINY)) + ROOT4A= 0.5D0*(-BB-DD) + ROOT4B= 0.5D0*(-BB+DD) + IF (ZERO.LE.ROOT4A) THEN + ROOT4 = ROOT4A + ELSE + ROOT4 = ROOT4B + ENDIF + ROOT4 = MIN(MAX(ROOT4, ZERO), CHI2) + PSI2 = CHI2-ROOT4 + ENDIF + PSCONV2 = ABS(PSI2-PSI2O) .LE. EPS*PSI2O + PSI2O = PSI2 +! +! ION CONCENTRATIONS +! + NAI = WAER(1) - (2.D0*ROOT1 + ROOT3 + ROOT4) + SO4I= WAER(2) - ROOT1 + NH4I= WAER(3) - ROOT2 + NO3I= WAER(4) - ROOT4 + CLI = WAER(5) - (ROOT3 + ROOT2) +! +! SODIUM CHLORIDE ; To obtain new value for ROOT3 +! + IF (NAI*CLI .GT. A8) THEN + BB =-(WAER(1) - 2.D0*ROOT1 + WAER(5) - ROOT2 - ROOT4) + CC = (WAER(5) + ROOT2)*(WAER(1) - 2.D0*ROOT1 - ROOT4) - A8 + DD = SQRT(MAX(BB*BB - 4.D0*CC, TINY)) + ROOT3A= 0.5D0*(-BB-DD) + ROOT3B= 0.5D0*(-BB+DD) + IF (ZERO.LE.ROOT3A) THEN + ROOT3 = ROOT3A + ELSE + ROOT3 = ROOT3B + ENDIF + ROOT3 = MIN(MAX(ROOT3, ZERO), CHI3) + PSI3 = CHI3-ROOT3 + ENDIF + PSCONV3 = ABS(PSI3-PSI3O) .LE. EPS*PSI3O + PSI3O = PSI3 +! +! SOLUTION ACIDIC OR BASIC? +! + GG = 2.D0*SO4I + NO3I + CLI - NAI - NH4I + IF (GG.GT.TINY) THEN ! H+ in excess + BB =-GG + CC =-AKW + DD = BB*BB - 4.D0*CC + HI = 0.5D0*(-BB + SQRT(DD)) + OHI= AKW/HI + ELSE ! OH- in excess + BB = GG + CC =-AKW + DD = BB*BB - 4.D0*CC + OHI= 0.5D0*(-BB + SQRT(DD)) + HI = AKW/OHI + ENDIF +! +! UNDISSOCIATED SPECIES EQUILIBRIA +! + IF (HI.LT.OHI) THEN + CALL CALCAMAQ2 (-GG, NH4I, OHI, NH3AQ) + HI = AKW/OHI + ELSE + GGNO3 = MAX(2.D0*SO4I + NO3I - NAI - NH4I, ZERO) + GGCL = MAX(GG-GGNO3, ZERO) + IF (GGCL .GT.TINY) CALL CALCCLAQ2 (GGCL, CLI, HI, CLAQ) ! HCl + IF (GGNO3.GT.TINY) THEN + IF (GGCL.LE.TINY) HI = ZERO + CALL CALCNIAQ2 (GGNO3, NO3I, HI, NO3AQ) ! HNO3 + ENDIF +! +! CONCENTRATION ADJUSTMENTS ; HSO4 minor species. +! + CALL CALCHS4 (HI, SO4I, ZERO, DEL) + SO4I = SO4I - DEL + HI = HI - DEL + HSO4I = DEL + OHI = AKW/HI + ENDIF +! +! *** SAVE CONCENTRATIONS IN MOLAL ARRAY ****************************** +! + MOLAL(1) = HI + MOLAL(2) = NAI + MOLAL(3) = NH4I + MOLAL(4) = CLI + MOLAL(5) = SO4I + MOLAL(6) = HSO4I + MOLAL(7) = NO3I +! +! *** CALCULATE WATER ************************************************** +! + CALL CALCMR +! +! *** CALCULATE ACTIVITIES OR TERMINATE INTERNAL LOOP ***************** +! + IF (FRST.AND.CALAOU .OR. .NOT.FRST.AND.CALAIN) THEN + CALL CALCACT + ELSE + IF (PSCONV1.AND.PSCONV2.AND.PSCONV3.AND.PSCONV4) GOTO 20 + ENDIF +10 CONTINUE +!cc CALL PUSHERR (0002, 'CALCR2A') ! WARNING ERROR: NO CONVERGENCE +! +! *** CALCULATE GAS / SOLID SPECIES (LIQUID IN MOLAL ALREADY) ********* +! +20 IF (CLI.LE.TINY .AND. WAER(5).GT.TINY) THEN !No disslv Cl-;solid only + DO 30 I=1,NIONS + MOLAL(I) = ZERO +30 CONTINUE + DO 40 I=1,NGASAQ + GASAQ(I) = ZERO +40 CONTINUE + CALL CALCR1A + ELSE ! OK, aqueous phase present + A2 = (XK2/XKW)*R*TEMP*(GAMA(10)/GAMA(5))**2. ! NH3 <==> NH4+ + A3 = XK4 *R*TEMP*(WATER/GAMA(10))**2. ! HNO3 <==> NO3- + A4 = XK3 *R*TEMP*(WATER/GAMA(11))**2. ! HCL <==> CL- +! + GNH3 = NH4I/HI/A2 + GHNO3 = HI*NO3I/A3 + GHCL = HI*CLI /A4 +! + GASAQ(1)= NH3AQ + GASAQ(2)= CLAQ + GASAQ(3)= NO3AQ +! + CNH42S4 = ZERO + CNH4NO3 = ZERO + CNH4CL = CHI4 - PSI4 + CNACL = CHI3 - PSI3 + CNANO3 = CHI2 - PSI2 + CNA2SO4 = CHI1 - PSI1 + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCR2A ***************************************** +! + END SUBROUTINE CALCR2A +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCR1 +! *** CASE R1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : NH4NO3, NH4CL, NA2SO4, NANO3, NACL +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCR1 + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' + LOGICAL EXAN, EXAC, EXSN, EXSC + EXTERNAL CALCR1A, CALCR2A, CALCR3A, CALCR4A, CALCR5 +! +! *** SOLVE FOR DRY CASE AND SEE WHICH SOLIDS ARE POSSIBLE ************** +! + SCASE = 'R1 ; SUBCASE 1' + CALL CALCR1A ! SOLID + SCASE = 'R1 ; SUBCASE 1' +! + EXAN = CNH4NO3.GT.TINY ! NH4NO3 + EXAC = CNH4CL .GT.TINY ! NH4CL + EXSN = CNANO3 .GT.TINY ! NANO3 + EXSC = CNACL .GT.TINY ! NACL +! +! *** REGIME DEPENDS ON RELATIVE HUMIDITY AND POSSIBLE SPECIES ********** +! + IF (EXAN.AND.EXAC.AND.EXSC.AND.EXSN) THEN ! *** ALL EXIST + IF (RH.GE.DRMH1) THEN + SCASE = 'R1 ; SUBCASE 2' ! MDRH + CALL CALCMDRP (RH, DRMH1, DRNH4NO3, CALCR1A, CALCR2A) + SCASE = 'R1 ; SUBCASE 2' + ENDIF +! + ELSE IF (.NOT.EXAN) THEN ! *** NH4NO3 = 0 + IF ( EXAC .AND. EXSN .AND. EXSC) THEN + IF (RH.GE.DRMH2) THEN + SCASE = 'R1 ; SUBCASE 3' + CALL CALCMDRP (RH, DRMH2, DRNANO3, CALCR1A, CALCR3A) + SCASE = 'R1 ; SUBCASE 3' + ENDIF + + ELSE IF (.NOT.EXAC .AND. EXSN .AND. EXSC) THEN + IF (RH.GE.DRMR1) THEN + SCASE = 'R1 ; SUBCASE 4' + CALL CALCMDRP (RH, DRMR1, DRNANO3, CALCR1A, CALCR3A) + SCASE = 'R1 ; SUBCASE 4' + ENDIF + + ELSE IF (.NOT.EXAC .AND. .NOT.EXSN .AND. EXSC) THEN + IF (RH.GE.DRMR2) THEN + SCASE = 'R1 ; SUBCASE 5' + CALL CALCMDRP (RH, DRMR2, DRNACL, CALCR1A, CALCR3A) !, CALCR4A) + SCASE = 'R1 ; SUBCASE 5' + ENDIF + + ELSE IF (.NOT.EXAC .AND. EXSN .AND. .NOT.EXSC) THEN + IF (RH.GE.DRMR3) THEN + SCASE = 'R1 ; SUBCASE 6' + CALL CALCMDRP (RH, DRMR3, DRNANO3, CALCR1A, CALCR3A) + SCASE = 'R1 ; SUBCASE 6' + ENDIF + + ELSE IF ( EXAC .AND. .NOT.EXSN .AND. EXSC) THEN + IF (RH.GE.DRMR4) THEN + SCASE = 'R1 ; SUBCASE 7' + CALL CALCMDRP (RH, DRMR4, DRNACL, CALCR1A, CALCR3A) !, CALCR4A) + SCASE = 'R1 ; SUBCASE 7' + ENDIF + + ELSE IF ( EXAC .AND. .NOT.EXSN .AND. .NOT.EXSC) THEN + IF (RH.GE.DRMR5) THEN + SCASE = 'R1 ; SUBCASE 8' + CALL CALCMDRP (RH, DRMR5, DRNH4CL, CALCR1A, CALCR3A) !, CALCR5) + SCASE = 'R1 ; SUBCASE 8' + ENDIF + + ELSE IF ( EXAC .AND. EXSN .AND. .NOT.EXSC) THEN + IF (RH.GE.DRMR6) THEN + SCASE = 'R1 ; SUBCASE 9' + CALL CALCMDRP (RH, DRMR6, DRNANO3, CALCR1A, CALCR3A) + SCASE = 'R1 ; SUBCASE 9' + ENDIF + ENDIF +! + ELSE IF (.NOT.EXAC) THEN ! *** NH4CL = 0 + IF ( EXAN .AND. EXSN .AND. EXSC) THEN + IF (RH.GE.DRMR7) THEN + SCASE = 'R1 ; SUBCASE 10' + CALL CALCMDRP (RH, DRMR7, DRNH4NO3, CALCR1A, CALCR2A) + SCASE = 'R1 ; SUBCASE 10' + ENDIF + + ELSE IF ( EXAN .AND. .NOT.EXSN .AND. EXSC) THEN + IF (RH.GE.DRMR8) THEN + SCASE = 'R1 ; SUBCASE 11' + CALL CALCMDRP (RH, DRMR8, DRNH4NO3, CALCR1A, CALCR2A) + SCASE = 'R1 ; SUBCASE 11' + ENDIF + + ELSE IF ( EXAN .AND. .NOT.EXSN .AND. .NOT.EXSC) THEN + IF (RH.GE.DRMR9) THEN + SCASE = 'R1 ; SUBCASE 12' + CALL CALCMDRP (RH, DRMR9, DRNH4NO3, CALCR1A, CALCR2A) + SCASE = 'R1 ; SUBCASE 12' + ENDIF + + ELSE IF ( EXAN .AND. EXSN .AND. .NOT.EXSC) THEN + IF (RH.GE.DRMR10) THEN + SCASE = 'R1 ; SUBCASE 13' + CALL CALCMDRP (RH, DRMR10, DRNH4NO3, CALCR1A, CALCR2A) + SCASE = 'R1 ; SUBCASE 13' + ENDIF + ENDIF +! + ELSE IF (.NOT.EXSN) THEN ! *** NANO3 = 0 + IF ( EXAN .AND. EXAC .AND. EXSC) THEN + IF (RH.GE.DRMR11) THEN + SCASE = 'R1 ; SUBCASE 14' + CALL CALCMDRP (RH, DRMR11, DRNH4NO3, CALCR1A, CALCR2A) + SCASE = 'R1 ; SUBCASE 14' + ENDIF + + ELSE IF ( EXAN .AND. EXAC .AND. .NOT.EXSC) THEN + IF (RH.GE.DRMR12) THEN + SCASE = 'R1 ; SUBCASE 15' + CALL CALCMDRP (RH, DRMR12, DRNH4NO3, CALCR1A, CALCR2A) + SCASE = 'R1 ; SUBCASE 15' + ENDIF + ENDIF +! + ELSE IF (.NOT.EXSC) THEN ! *** NACL = 0 + IF ( EXAN .AND. EXAC .AND. EXSN) THEN + IF (RH.GE.DRMR13) THEN + SCASE = 'R1 ; SUBCASE 16' + CALL CALCMDRP (RH, DRMR13, DRNH4NO3, CALCR1A, CALCR2A) + SCASE = 'R1 ; SUBCASE 16' + ENDIF + ENDIF + ENDIF +! + RETURN +! +! *** END OF SUBROUTINE CALCR1 ****************************************** +! + END SUBROUTINE CALCR1 + + +!======================================================================= +! +! *** ISORROPIA CODE +! *** SUBROUTINE CALCR1A +! *** CASE R1 ; SUBCASE 1 +! +! THE MAIN CHARACTERISTICS OF THIS REGIME ARE: +! 1. SULFATE POOR (SULRAT > 2.0) ; SODIUM RICH (SODRAT >= 2.0) +! 2. SOLID AEROSOL ONLY +! 3. SOLIDS POSSIBLE : NH4NO3, NH4CL, NANO3, NA2SO4, NANO3, NACL +! +! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, +! *** GEORGIA INSTITUTE OF TECHNOLOGY +! *** WRITTEN BY ATHANASIOS NENES +! +!======================================================================= +! + SUBROUTINE CALCR1A + USE ISRPIA + IMPLICIT DOUBLE PRECISION (A-H, O-Z) +! INCLUDE 'ISRPIA.INC' +! +! *** CALCULATE SOLIDS ************************************************** +! + CNA2SO4 = WAER(2) + FRNA = MAX (WAER(1)-2*CNA2SO4, ZERO) +! + CNH42S4 = ZERO +! + CNANO3 = MIN (FRNA, WAER(4)) + FRNO3 = MAX (WAER(4)-CNANO3, ZERO) + FRNA = MAX (FRNA-CNANO3, ZERO) +! + CNACL = MIN (FRNA, WAER(5)) + FRCL = MAX (WAER(5)-CNACL, ZERO) + FRNA = MAX (FRNA-CNACL, ZERO) +! + CNH4NO3 = MIN (FRNO3, WAER(3)) + FRNO3 = MAX (FRNO3-CNH4NO3, ZERO) + FRNH3 = MAX (WAER(3)-CNH4NO3, ZERO) +! + CNH4CL = MIN (FRCL, FRNH3) + FRCL = MAX (FRCL-CNH4CL, ZERO) + FRNH3 = MAX (FRNH3-CNH4CL, ZERO) +! +! *** OTHER PHASES ****************************************************** +! + WATER = ZERO +! + GNH3 = ZERO + GHNO3 = ZERO + GHCL = ZERO +! + RETURN +! +! *** END OF SUBROUTINE CALCR1A ***************************************** +! + END SUBROUTINE CALCR1A diff --git a/wrfv2_fire/chem/mechanism_driver.F b/wrfv2_fire/chem/mechanism_driver.F index be861f4c..613d24f2 100755 --- a/wrfv2_fire/chem/mechanism_driver.F +++ b/wrfv2_fire/chem/mechanism_driver.F @@ -104,7 +104,7 @@ subroutine mechanism_driver(id,curr_secs,ktau,dtstep,ktauc,dtstepc,& ! select chemical mechanism ! chem_select: SELECT CASE(config_flags%chem_opt) - CASE (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2_KPP,GOCARTRADM2) + CASE (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2) CALL wrf_debug(15,'calling gocart chem from mechanism_driver') call gocart_chem_driver(curr_secs,dtstepc,config_flags, & gmt,julday,t_phy,moist, & @@ -146,7 +146,6 @@ subroutine mechanism_driver(id,curr_secs,ktau,dtstep,ktauc,dtstepc,& CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CBMZ_MOSAIC_4BIN_VBS2_KPP, & CBMZSORG, CBMZSORG_AQ, CBMZ_CAM_MAM3_NOAQ, & CBMZ_CAM_MAM3_AQ,CBMZ_CAM_MAM7_NOAQ, & CBMZ_CAM_MAM7_AQ) @@ -165,6 +164,32 @@ subroutine mechanism_driver(id,curr_secs,ktau,dtstep,ktauc,dtstepc,& ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE (CB05_SORG_AQ_KPP) + chem(its:ite,kts:kte,jts:jte,p_apin) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.248 + chem(its:ite,kts:kte,jts:jte,p_bpin) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.294 + chem(its:ite,kts:kte,jts:jte,p_lim) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.164 + chem(its:ite,kts:kte,jts:jte,p_ter) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.006 + chem(its:ite,kts:kte,jts:jte,p_oci) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.213 + chem(its:ite,kts:kte,jts:jte,p_hum) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.074 + chem(its:ite,kts:kte,jts:jte,p_ch4) = 1.7 + chem(its:ite,kts:kte,jts:jte,p_h2) = 0.5 + + vcsulf_old(its:ite,kts:kte,jts:jte) = & + max(chem(its:ite,kts:kte,jts:jte,p_sulf),epsilc) + + CASE (CB05_SORG_VBS_AQ_KPP) + chem(its:ite,kts:kte,jts:jte,p_apin) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.248 + chem(its:ite,kts:kte,jts:jte,p_bpin) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.294 + chem(its:ite,kts:kte,jts:jte,p_lim) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.164 + chem(its:ite,kts:kte,jts:jte,p_ter) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.006 + chem(its:ite,kts:kte,jts:jte,p_oci) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.213 + chem(its:ite,kts:kte,jts:jte,p_hum) = chem(its:ite,kts:kte,jts:jte,p_terp) * 0.074 + chem(its:ite,kts:kte,jts:jte,p_ch4) = 1.7 + chem(its:ite,kts:kte,jts:jte,p_h2) = 0.5 + + vcsulf_old(its:ite,kts:kte,jts:jte) = & + max(chem(its:ite,kts:kte,jts:jte,p_sulf),epsilc) + CASE DEFAULT END SELECT chem_select diff --git a/wrfv2_fire/chem/moduleAERODATA.F b/wrfv2_fire/chem/moduleAERODATA.F new file mode 100755 index 00000000..8bb2fbd4 --- /dev/null +++ b/wrfv2_fire/chem/moduleAERODATA.F @@ -0,0 +1,41 @@ + MODULE AERODATA + + INTEGER, PARAMETER :: NASECT = 3 ! total number of size sections + ! over the simulated aerosol size range + ! DEPENDS ON NO. OF SECTIONS + +! Maximum particle diameter simulated [micro meter] + REAL, PARAMETER :: DPUP = 10.0 + +! Minimum particle diameter simulated [micro meter] + REAL, PARAMETER :: DPLOW = 0.0215 + + REAL VRAT ! volume ratio of adjacent sections + + REAL VRLOW ! = (2.0 / (1.0 + VRAT) )**(1.0/3.0) + + REAL VRHI ! = VRLOW * VRAT**(1.0/3.0) + + REAL DPBINMIN! initial center diameter of the first size section + ! [micro meter] + +! Particle density [g / cm**3] +! For comparison between 2-bin and 8-bin, use the value of 1.352, +! so that the cut off size for PM2.5 is 2.15 um, consistent with +! the 8-bin cut off size + REAL, PARAMETER :: DENSP = 1.352 + +! Particle diameters (microns) + REAL :: DPCTR( NASECT ) + +! PM Conc (ug/m3) + REAL :: PMCONC( NASECT ) + +! Particle surface area (um2), volume (um3), mass (ug) and no. conc (#/m3) +! in each size section + REAL :: SURFP, VOL, AEROMA, XNUM + + REAL :: AREA( NASECT ) ! Surface area of each section [m**2/m**3] + + END MODULE AERODATA +!....................................................................... diff --git a/wrfv2_fire/chem/moduleHETAERO.F b/wrfv2_fire/chem/moduleHETAERO.F new file mode 100755 index 00000000..a290d7a4 --- /dev/null +++ b/wrfv2_fire/chem/moduleHETAERO.F @@ -0,0 +1,30 @@ + MODULE HETAERO + + USE HETDATA + +! Flag to turn on/off heterogeneous reactions on the surface of +! particles + INTEGER, PARAMETER :: IAERORATE = 1 + +! Assign species indices for gas-phase species that participate in +! heterogeneous reactions on aerosol surface,can be expanded + INTEGER, PARAMETER :: ISO2 = 1 + +! Molecular weights of gas species for each reaction + REAL :: XMOLWEI( NRXNAERO ) + DATA XMOLWEI/ 64.0 / + +! Assign gas-phase diffusivity [cm^2/s] at 273.15 K + REAL :: DG0( NRXNAERO ) + DATA DG0 / 0.1151 / + +! Species uptake coefficients for gas-aerosol reactions +! Assign the reaction probability according to +! Jacob, 2000, Atmos. Environ, 34, 2131-2159 +! NGAMMA = 1 Using the recommended median value +! NGAMMA = 2 Using the low bound value +! NGAMMA = 3 Using the high bound value + INTEGER, PARAMETER :: NGAMMA = 2 + + END MODULE HETAERO +!....................................................................... diff --git a/wrfv2_fire/chem/moduleHETDATA.F b/wrfv2_fire/chem/moduleHETDATA.F new file mode 100755 index 00000000..f22ad973 --- /dev/null +++ b/wrfv2_fire/chem/moduleHETDATA.F @@ -0,0 +1,18 @@ + MODULE HETDATA + + INTEGER, PARAMETER :: NRXNAERO = 1 ! # of heterogeneous gas-aerosol + ! reactions. can be expanded later + +! Constants +! gas constant in SI units (J/mol-K) (same as RGASUNIV in CONST.EXT) + REAL, PARAMETER :: RSI = 8.314510 + +! gas constant in J/kmol-K + REAL, PARAMETER :: RG = RSI * 1.0E3 + +! Standard temperature and pressure + REAL, PARAMETER :: TEMP0 = 273.15 ! standard temperature, in degK + REAL, PARAMETER :: PRESS0 = 101325.0 ! standard pressure, in Pa + + END MODULE HETDATA +!....................................................................... diff --git a/wrfv2_fire/chem/module_add_emiss_burn.F b/wrfv2_fire/chem/module_add_emiss_burn.F index 48cc453a..c2365711 100644 --- a/wrfv2_fire/chem/module_add_emiss_burn.F +++ b/wrfv2_fire/chem/module_add_emiss_burn.F @@ -230,7 +230,7 @@ subroutine add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,chem, & enddo enddo enddo - CASE (GOCARTRACM_KPP,GOCARTRADM2_KPP,GOCARTRADM2) + CASE (GOCARTRACM_KPP,GOCARTRADM2) do j=jts,jte do i=its,ite do k=kts,kte @@ -286,7 +286,8 @@ subroutine add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,chem, & enddo enddo enddo - CASE (RADM2,RACM_KPP,RACM_MIM_KPP,SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP) + CASE (RADM2,RACM_KPP,RACM_MIM_KPP,SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, SAPRC99_MOSAIC_8BIN_VBS2_KPP)!BSINGH(12/03/2013): Added SAPRC 8 bin and non-aq on (04/07/2014) do j=jts,jte do i=its,ite do k=kts,kte @@ -328,7 +329,7 @@ subroutine add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,chem, & enddo enddo enddo - CASE (MOZART_KPP,MOZCART_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP ) + CASE (MOZART_KPP,MOZCART_KPP,MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP ) if( biomass_burn_opt == BIOMASSB_MOZC .or. biomass_burn_opt == BIOMASSB_MOZ ) then do j=jts,jte do k=kts,kte @@ -364,13 +365,11 @@ subroutine add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,chem, & enddo enddo enddo -! 20130822 acd_rkumar_bb start ! Adding simple SOA scheme emissions from biomass burning. ! WARNING: do not provide e_co_bb in wrfchemi* files if you use ! the online plume rise - you would be double counting emissions! -! -- Dear Steven, could you please include this note in the user guide -! -- when you adopt these changes? Thanks. Rajesh and Christoph - IF (chem_opt .EQ. MOZART_MOSAIC_4BIN_VBS0_KPP) THEN + IF (chem_opt .EQ. MOZART_MOSAIC_4BIN_KPP .OR. & + chem_opt .EQ. MOZART_MOSAIC_4BIN_AQ_KPP) THEN do j=jts,jte do k=kts,kte do i=its,ite @@ -380,7 +379,6 @@ subroutine add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,chem, & enddo enddo ENDIF -! 20130822 acd_rkumar_bb end if( biomass_burn_opt == BIOMASSB_MOZC ) then do j=jts,jte diff --git a/wrfv2_fire/chem/module_aerosols_sorgam.F b/wrfv2_fire/chem/module_aerosols_sorgam.F index 9efe7069..a7105168 100644 --- a/wrfv2_fire/chem/module_aerosols_sorgam.F +++ b/wrfv2_fire/chem/module_aerosols_sorgam.F @@ -231,8 +231,8 @@ SUBROUTINE sorgam_driver (id,ktau,dtstep,t_phy,moist,aerwrf,p8w, & soilrat_in = 0. nitrate_in =max(epsilc,chem(i,k,j,p_hno3)*convfac*mwhno3) nh3_in = max(epsilc,chem(i,k,j,p_nh3)*convfac*mwnh3) -! hcl_in = max(epsilc,chem(i,k,j,p_hcl)*convfac*mwhcl) - hcl_in = 0. + hcl_in = max(epsilc,chem(i,k,j,p_hcl)*convfac*mwhcl) +! hcl_in = 0. vsulf_in = max(epsilc,chem(i,k,j,p_sulf)*convfac*mwso4) ! if(i.eq.28.and.j.eq.25.and.k.eq.1)then ! print *,'vsulfin = ',vsulf_in,chem(i,k,j,p_sulf),convfac,mwso4 @@ -257,7 +257,8 @@ SUBROUTINE sorgam_driver (id,ktau,dtstep,t_phy,moist,aerwrf,p8w, & drog_in(POLT2) = VDROG3(i,k,j,POLT2) drog_in(POLT3) = VDROG3(i,k,j,POLT3) !rs * biogenic organics DeltaROG - if(p_ete.eq.1)then + if(p_lim.eq.1)then +! if(p_ete.eq.1)then drog_in(PAPI1) = 0. drog_in(PAPI2) = 0. drog_in(PAPI3) = 0. @@ -268,7 +269,8 @@ SUBROUTINE sorgam_driver (id,ktau,dtstep,t_phy,moist,aerwrf,p8w, & condvap_in(PSOAAPI2) = 0. condvap_in(PSOALIM1) = 0. condvap_in(PSOALIM2) = 0. - elseif(p_ete.gt.1)then + elseif(p_lim.gt.1)then +! elseif(p_ete.gt.1)then drog_in(PAPI1) = VDROG3(i,k,j,PAPI1) drog_in(PAPI2) = VDROG3(i,k,j,PAPI2) drog_in(PAPI3) = VDROG3(i,k,j,PAPI3) @@ -318,10 +320,15 @@ SUBROUTINE sorgam_driver (id,ktau,dtstep,t_phy,moist,aerwrf,p8w, & cblk(1,VCVARO2 ) = max(epsilc,cvaro2(i,k,j)) cblk(1,VCVALK1 ) = max(epsilc,cvalk1(i,k,j)) cblk(1,VCVOLE1 ) = max(epsilc,cvole1(i,k,j)) - cblk(1,VCVAPI1 ) = 0. - cblk(1,VCVAPI2 ) = 0. - cblk(1,VCVLIM1 ) = 0. - cblk(1,VCVLIM2 ) = 0. +! cblk(1,VCVAPI1 ) = 0. +! cblk(1,VCVAPI2 ) = 0. +! cblk(1,VCVLIM1 ) = 0. +! cblk(1,VCVLIM2 ) = 0. + cblk(1,VCVAPI1 ) = max(epsilc,cvapi1(i,k,j)) + cblk(1,VCVAPI2 ) = max(epsilc,cvapi2(i,k,j)) + cblk(1,VCVLIM1 ) = max(epsilc,cvlim1(i,k,j)) + cblk(1,VCVLIM2 ) = max(epsilc,cvlim2(i,k,j)) + ! ! Set emissions to zero ! @@ -449,14 +456,19 @@ SUBROUTINE sorgam_driver (id,ktau,dtstep,t_phy,moist,aerwrf,p8w, & cvaro2(i,k,j) = cblk(1,VCVARO2 ) cvalk1(i,k,j) = cblk(1,VCVALK1 ) cvole1(i,k,j) = cblk(1,VCVOLE1 ) - cvapi1(i,k,j) = 0. - cvapi2(i,k,j) = 0. - cvlim1(i,k,j) = 0. - cvlim2(i,k,j) = 0. +! cvapi1(i,k,j) = 0. +! cvapi2(i,k,j) = 0. +! cvlim1(i,k,j) = 0. +! cvlim2(i,k,j) = 0. + cvapi1(i,k,j) = cblk(1,VCVAPI1 ) + cvapi2(i,k,j) = cblk(1,VCVAPI2 ) + cvlim1(i,k,j) = cblk(1,VCVLIM1 ) + cvlim2(i,k,j) = cblk(1,VCVLIM2 ) + chem(i,k,j,p_sulf)=max(epsilc,cblk(1,vsulf)/CONVFAC/MWSO4) chem(i,k,j,p_hno3)=max(epsilc,cblk(1,vhno3)/CONVFAC/MWHNO3) chem(i,k,j,p_nh3)=max(epsilc,cblk(1,vnh3)/CONVFAC/MWNH3) -! chem(i,k,j,p_hcl)=max(epsilc,cblk(1,vhcl)/CONVFAC/MWHCL) + chem(i,k,j,p_hcl)=max(epsilc,cblk(1,vhcl)/CONVFAC/MWHCL) ! if(i.eq.28.and.j.eq.25.and.k.eq.1)then ! print *,vhcl ! print *,'vsulfout = ',chem(i,k,j,p_sulf) @@ -579,6 +591,7 @@ SUBROUTINE sorgam_depdriver (id,config_flags,ktau,dtstep, & h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1,cvaro2, & cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2, & aer_res,vgsa, & + numgas,ddflx, & numaer, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -587,6 +600,7 @@ SUBROUTINE sorgam_depdriver (id,config_flags,ktau,dtstep, & USE module_configure,only: grid_config_rec_type TYPE (grid_config_rec_type) , INTENT (IN) :: config_flags INTEGER, INTENT(IN ) :: & + numgas, & numaer, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -603,6 +617,10 @@ SUBROUTINE sorgam_depdriver (id,config_flags,ktau,dtstep, & REAL, DIMENSION( its:ite, jts:jte, numaer ), & INTENT(INOUT ) :: & vgsa + real, intent(inout), & + dimension( ims:ime, jms:jme, numgas+1:num_chem ) :: & + ddflx + REAL, DIMENSION( its:ite, jts:jte ), & INTENT(INOUT ) :: & aer_res @@ -654,6 +672,8 @@ SUBROUTINE sorgam_depdriver (id,config_flags,ktau,dtstep, & REAL nitrate_in ! input NH3 to CBLK [ug/m^3] REAL nh3_in +! ! input hcl vapor + REAL hcl_in ! input SO4 vapor [ug/m^3] REAL vsulf_in @@ -682,6 +702,10 @@ SUBROUTINE sorgam_depdriver (id,config_flags,ktau,dtstep, & REAL mwnh3 PARAMETER (mwnh3=17.03061) +!molecular weight for HCL + REAL mwhcl + PARAMETER (mwhcl=36.46100) + !bs molecular weight for Organic Spec ! REAL mworg ! PARAMETER (mworg=175.0) @@ -813,7 +837,8 @@ SUBROUTINE sorgam_depdriver (id,config_flags,ktau,dtstep, & nitrate_in =chem(i,k,j,p_hno3)*convfac*mwhno3 nh3_in = chem(i,k,j,p_nh3)*convfac*mwnh3 vsulf_in = chem(i,k,j,p_sulf)*convfac*mwso4 - + hcl_in = chem(i,k,j,p_hcl)*convfac*mwhcl + !rs. nitrate, nh3, sulf BLKPRS(BLKSIZE) = 1.e3*P(K) ! pressure in Pa BLKTA(BLKSIZE) = T(K) ! temperature in K @@ -827,6 +852,7 @@ SUBROUTINE sorgam_depdriver (id,config_flags,ktau,dtstep, & cblk(1,vsulf) = max(epsilc,vsulf_in) cblk(1,vhno3) = max(epsilc,nitrate_in) cblk(1,vnh3) = max(epsilc,nh3_in) + cblk(1,vhcl) = max(epsilc,hcl_in) cblk(1,VSO4AJ ) = max(epsilc,chem(i,k,j,p_so4aj)*convfac2) cblk(1,VSO4AI ) = max(epsilc,chem(i,k,j,p_so4ai)*convfac2) cblk(1,VNH4AJ ) = max(epsilc,chem(i,k,j,p_nh4aj)*convfac2) @@ -878,14 +904,14 @@ SUBROUTINE sorgam_depdriver (id,config_flags,ktau,dtstep, & cblk(1,VCVARO2 ) = cvaro2(i,k,j) cblk(1,VCVALK1 ) = cvalk1(i,k,j) cblk(1,VCVOLE1 ) = cvole1(i,k,j) - cblk(1,VCVAPI1 ) = 0. - cblk(1,VCVAPI2 ) = 0. - cblk(1,VCVLIM1 ) = 0. - cblk(1,VCVLIM2 ) = 0. -! cblk(1,VCVAPI1 ) = cvapi1(i,k,j) -! cblk(1,VCVAPI2 ) = cvapi2(i,k,j) -! cblk(1,VCVLIM1 ) = cvlim1(i,k,j) -! cblk(1,VCVLIM2 ) = cvlim2(i,k,j) +! cblk(1,VCVAPI1 ) = 0. +! cblk(1,VCVAPI2 ) = 0. +! cblk(1,VCVLIM1 ) = 0. +! cblk(1,VCVLIM2 ) = 0. + cblk(1,VCVAPI1 ) = cvapi1(i,k,j) + cblk(1,VCVAPI2 ) = cvapi2(i,k,j) + cblk(1,VCVLIM1 ) = cvlim1(i,k,j) + cblk(1,VCVLIM2 ) = cvlim2(i,k,j) ! !rs. get size distribution information ! @@ -963,6 +989,47 @@ SUBROUTINE sorgam_depdriver (id,config_flags,ktau,dtstep, & VGSA(i, j, VNU0 ) = VDEP(1, VDNNUC ) VGSA(i, j, VAC0 ) = VDEP(1, VDNACC ) VGSA(i, j, VCORN ) = VDEP(1, VDNCOR ) + if( config_flags%diagnostic_dep == 1) then + ddflx(i,j,p_so4aj)=ddflx(i,j,p_so4aj)+chem(i,k,j,p_so4aj)/alt(i,k,j)*VGSA(i,j,VSO4AJ)*dtstep + ddflx(i,j,p_so4ai)=ddflx(i,j,p_so4ai)+chem(i,k,j,p_so4ai)/alt(i,k,j)*VGSA(i,j,VSO4AI)*dtstep + ddflx(i,j,p_nh4aj)=ddflx(i,j,p_nh4aj)+chem(i,k,j,p_nh4aj)/alt(i,k,j)*VGSA(i,j,VNH4AJ)*dtstep + ddflx(i,j,p_nh4ai)=ddflx(i,j,p_nh4ai)+chem(i,k,j,p_nh4ai)/alt(i,k,j)*VGSA(i,j,VNH4Ai)*dtstep + ddflx(i,j,p_no3aj)=ddflx(i,j,p_no3aj)+chem(i,k,j,p_no3aj)/alt(i,k,j)*VGSA(i,j,VNO3AJ)*dtstep + ddflx(i,j,p_no3ai)=ddflx(i,j,p_no3ai)+chem(i,k,j,p_no3ai)/alt(i,k,j)*VGSA(i,j,VNO3AI)*dtstep + ddflx(i,j,p_orgaro1j)=ddflx(i,j,p_orgaro1j)+chem(i,k,j,p_orgaro1j)/alt(i,k,j)*VGSA(i,j,VORGARO1J)*dtstep + ddflx(i,j,p_orgaro1i)=ddflx(i,j,p_orgaro1i)+chem(i,k,j,p_orgaro1i)/alt(i,k,j)*VGSA(i,j,VORGARO1I)*dtstep + ddflx(i,j,p_orgaro2j)=ddflx(i,j,p_orgaro2j)+chem(i,k,j,p_orgaro2j)/alt(i,k,j)*VGSA(i,j,VORGARO2J)*dtstep + ddflx(i,j,p_orgaro2i)=ddflx(i,j,p_orgaro2i)+chem(i,k,j,p_orgaro2i)/alt(i,k,j)*VGSA(i,j,VORGARO2I)*dtstep + ddflx(i,j,p_orgalk1j)=ddflx(i,j,p_orgalk1j)+chem(i,k,j,p_orgalk1j)/alt(i,k,j)*VGSA(i,j,VORGALK1J)*dtstep + ddflx(i,j,p_orgalk1i)=ddflx(i,j,p_orgalk1i)+chem(i,k,j,p_orgalk1i)/alt(i,k,j)*VGSA(i,j,VORGALK1I)*dtstep + ddflx(i,j,p_orgole1j)=ddflx(i,j,p_orgole1j)+chem(i,k,j,p_orgole1j)/alt(i,k,j)*VGSA(i,j,VORGOLE1J)*dtstep + ddflx(i,j,p_orgole1i)=ddflx(i,j,p_orgole1i)+chem(i,k,j,p_orgole1i)/alt(i,k,j)*VGSA(i,j,VORGOLE1I)*dtstep + ddflx(i,j,p_orgba1j)=ddflx(i,j,p_orgba1j)+chem(i,k,j,p_orgba1j)/alt(i,k,j)*VGSA(i,j,VORGBA1J)*dtstep + ddflx(i,j,p_orgba1i)=ddflx(i,j,p_orgba1i)+chem(i,k,j,p_orgba1i)/alt(i,k,j)*VGSA(i,j,VORGBA1I)*dtstep + ddflx(i,j,p_orgba2j)=ddflx(i,j,p_orgba2j)+chem(i,k,j,p_orgba2j)/alt(i,k,j)*VGSA(i,j,VORGBA2J)*dtstep + ddflx(i,j,p_orgba2i)=ddflx(i,j,p_orgba2i)+chem(i,k,j,p_orgba2i)/alt(i,k,j)*VGSA(i,j,VORGBA2I)*dtstep + ddflx(i,j,p_orgba3j)=ddflx(i,j,p_orgba3j)+chem(i,k,j,p_orgba3j)/alt(i,k,j)*VGSA(i,j,VORGBA3J)*dtstep + ddflx(i,j,p_orgba3i)=ddflx(i,j,p_orgba3i)+chem(i,k,j,p_orgba3i)/alt(i,k,j)*VGSA(i,j,VORGBA3I)*dtstep + ddflx(i,j,p_orgba4j)=ddflx(i,j,p_orgba4j)+chem(i,k,j,p_orgba4j)/alt(i,k,j)*VGSA(i,j,VORGBA4J)*dtstep + ddflx(i,j,p_orgba4i)=ddflx(i,j,p_orgba4i)+chem(i,k,j,p_orgba4i)/alt(i,k,j)*VGSA(i,j,VORGBA4I)*dtstep + ddflx(i,j,p_orgpaj)=ddflx(i,j,p_orgpaj)+chem(i,k,j,p_orgpaj)/alt(i,k,j)*VGSA(i,j,VORGPAJ)*dtstep + ddflx(i,j,p_orgpai)=ddflx(i,j,p_orgpai)+chem(i,k,j,p_orgpai)/alt(i,k,j)*VGSA(i,j,VORGPAI)*dtstep + ddflx(i,j,p_ecj)=ddflx(i,j,p_ecj)+chem(i,k,j,p_ecj)/alt(i,k,j)*VGSA(i,j,VECJ)*dtstep + ddflx(i,j,p_eci)=ddflx(i,j,p_eci)+chem(i,k,j,p_eci)/alt(i,k,j)*VGSA(i,j,VECI)*dtstep + ddflx(i,j,p_p25j)=ddflx(i,j,p_p25j)+chem(i,k,j,p_p25j)/alt(i,k,j)*VGSA(i,j,VP25AJ)*dtstep + ddflx(i,j,p_p25i)=ddflx(i,j,p_p25i)+chem(i,k,j,p_p25i)/alt(i,k,j)*VGSA(i,j,VP25AI)*dtstep + ddflx(i,j,p_naaj)=ddflx(i,j,p_naaj)+chem(i,k,j,p_naaj)/alt(i,k,j)*VGSA(i,j,VNAAJ)*dtstep + ddflx(i,j,p_naai)=ddflx(i,j,p_naai)+chem(i,k,j,p_naai)/alt(i,k,j)*VGSA(i,j,VNAAI)*dtstep + ddflx(i,j,p_claj)=ddflx(i,j,p_claj)+chem(i,k,j,p_claj)/alt(i,k,j)*VGSA(i,j,VCLAJ)*dtstep + ddflx(i,j,p_clai)=ddflx(i,j,p_clai)+chem(i,k,j,p_clai)/alt(i,k,j)*VGSA(i,j,VCLAI)*dtstep + ddflx(i,j,p_antha)=ddflx(i,j,p_antha)+chem(i,k,j,p_antha)/alt(i,k,j)*VGSA(i,j,VANTHA)*dtstep + ddflx(i,j,p_seas)=ddflx(i,j,p_seas)+chem(i,k,j,p_seas)/alt(i,k,j)*VGSA(i,j,VSEAS)*dtstep + ddflx(i,j,p_soila)=ddflx(i,j,p_soila)+chem(i,k,j,p_soila)/alt(i,k,j)*VGSA(i,j,VSOILA)*dtstep + ddflx(i,j,p_nu0)=ddflx(i,j,p_nu0)+chem(i,k,j,p_nu0)/alt(i,k,j)*VGSA(i,j,VNU0)*dtstep + ddflx(i,j,p_ac0)=ddflx(i,j,p_ac0)+chem(i,k,j,p_ac0)/alt(i,k,j)*VGSA(i,j,VAC0)*dtstep + ddflx(i,j,p_corn)=ddflx(i,j,p_corn)+chem(i,k,j,p_corn)/alt(i,k,j)*VGSA(i,j,VCORN)*dtstep + end if + ! enddo ! k-loop 100 continue ! i,j-loop @@ -1509,8 +1576,8 @@ SUBROUTINE aeroproc(blksize,nspcsda,numcells,layer,cblk,dt,blkta,blkprs, & INTEGER unit PARAMETER (unit=20) integer igrid,jgrid,kgrid,isorop - isorop=0 - +! isorop=0 + isorop=1 @@ -2914,9 +2981,16 @@ SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid) (cblk(lcell,vno3aj) + cblk(lcell,vno3ai))/mw_no3_aer)*1.e-6 ! nitrate - wi(5) = (cblk(lcell,vhcl)/(mw_cl_aer-1.) + & +! wi(5) = (cblk(lcell,vhcl)/(mw_cl_aer-1.) + & + wi(5) = (cblk(lcell,vhcl)/(mw_cl_aer+1.) + & (cblk(lcell,vclaj) + cblk(lcell,vclai))/mw_cl_aer)*1.e-6 ! chloride +! Following added: wi should be positive + wi(1) = max(wi(1),0.) + wi(2) = max(wi(2),0.) + wi(3) = max(wi(3),0.) + wi(4) = max(wi(4),0.) + wi(5) = max(wi(5),0.) wt_save(1) = wi(1) ! sodium wt_save(2) = wi(2) ! sulfate @@ -2928,7 +3002,7 @@ SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid) print *,wi(1),wi(2),wi(3),wi(4),wi(5) endif -! call isoropia(wi,rhi,tempi,cntrl,wt,gas,aerliq,aersld,scasi,other) + call isoropia(wi,rhi,tempi,cntrl,wt,gas,aerliq,aersld,scasi,other) ! *** the following is an interim procedure. Assume the i-mode has the @@ -2937,10 +3011,20 @@ SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid) ! *** update gas / vapor phase - - cblk(lcell,vnh3) = gas(1)*1.e6*17. - cblk(lcell,vhno3) = gas(2)*1.e6*63. - cblk(lcell,vhcl) = gas(3)*1.e6*36. + gas(1) = min(gas(1),wt_save(3)) + gas(2) = min(gas(2),wt_save(4)) + gas(3) = min(gas(3),wt_save(5)) + + gas(1) = max(gas(1),0.) + gas(2) = max(gas(2),0.) + gas(3) = max(gas(3),0.) + +! cblk(lcell,vnh3) = gas(1)*1.e6*17. +! cblk(lcell,vhno3) = gas(2)*1.e6*63. +! cblk(lcell,vhcl) = gas(3)*1.e6*36. + cblk(lcell,vnh3) = gas(1)*1.e6*(mw_nh4_aer-1.) + cblk(lcell,vhno3) = gas(2)*1.e6*(mw_no3_aer+1.) + cblk(lcell,vhcl) = gas(3)*1.e6*(mw_cl_aer+1.) if(igrid.eq.28.and.jgrid.eq.24.and.kgrid.eq.1)then print *,vhcl,vnh3,vhno3 print *,cblk(lcell,vnh3),cblk(lcell,vhno3),cblk(lcell,vhcl) @@ -2948,23 +3032,42 @@ SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid) ! *** get modal fraction fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai)) + + fraci = min(fraci,1.0) + fraci = max(fraci,0.0) + fracj = 1.0 - fraci ! *** update do i-mode +! correct mapping from (mol m-3) to (ug m-3) + aerliq(8) = max(aerliq(8),0.) + cblk(lcell,vh2oai) = fraci*aerliq(8)*18.*1.e6 - cblk(lcell,vnh4ai) = fraci*(wt_save(3) - gas(1)) - cblk(lcell,vno3ai) = fraci*(wt_save(4) - gas(2)) - cblk(lcell,vclai) = fraci*(wt_save(5) - gas(3)) - cblk(lcell,vnaai) = fraci*wi(1) + cblk(lcell,vnh4ai) = fraci*(wt_save(3) - gas(1))*mw_nh4_aer*1.e6 + cblk(lcell,vno3ai) = fraci*(wt_save(4) - gas(2))*mw_no3_aer*1.e6 + cblk(lcell,vclai) = fraci*(wt_save(5) - gas(3))*mw_cl_aer*1.e6 + cblk(lcell,vnaai) = fraci*wi(1)*mw_na_aer*1.e6 -! *** update accumulation mode: +! cblk(lcell,vh2oai) = fraci*aerliq(8)*18.*1.e6 +! cblk(lcell,vnh4ai) = fraci*(wt_save(3) - gas(1)) +! cblk(lcell,vno3ai) = fraci*(wt_save(4) - gas(2)) +! cblk(lcell,vclai) = fraci*(wt_save(5) - gas(3)) +! cblk(lcell,vnaai) = fraci*wi(1) +! *** update accumulation mode: +! correct mapping from (mol m-3) to (ug m-3) cblk(lcell,vh2oaj) = fracj*aerliq(8)*18.*1.e6 - cblk(lcell,vnh4aj) = fracj*(wt_save(3) - gas(1)) - cblk(lcell,vno3aj) = fracj*(wt_save(4) - gas(2)) - cblk(lcell,vclaj) = fracj*(wt_save(5) - gas(3)) - cblk(lcell,vnaaj) = fracj*wi(1) + cblk(lcell,vnh4aj) = fracj*(wt_save(3) - gas(1))*mw_nh4_aer*1.e6 + cblk(lcell,vno3aj) = fracj*(wt_save(4) - gas(2))*mw_no3_aer*1.e6 + cblk(lcell,vclaj) = fracj*(wt_save(5) - gas(3))*mw_cl_aer*1.e6 + cblk(lcell,vnaaj) = fracj*wi(1)*mw_na_aer*1.e6 + +! cblk(lcell,vh2oaj) = fracj*aerliq(8)*18.*1.e6 +! cblk(lcell,vnh4aj) = fracj*(wt_save(3) - gas(1)) +! cblk(lcell,vno3aj) = fracj*(wt_save(4) - gas(2)) +! cblk(lcell,vclaj) = fracj*(wt_save(5) - gas(3)) +! cblk(lcell,vnaaj) = fracj*wi(1) if(igrid.eq.28.and.jgrid.eq.24.and.kgrid.eq.1)then print *,vh2oaj,vnh4aj,vno3aj,vclaj,vnaaj print *,cblk(lcell,vnh4aj),cblk(lcell,vno3aj),cblk(lcell,vclaj),aerliq(8) @@ -3924,23 +4027,43 @@ SUBROUTINE modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn, & ! *** Aitken-mode: +! Na and Cl added to aitken mode mass conc + pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, & - vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+cblk(lcell, & + vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+ & + cblk(lcell,vnaai)+cblk(lcell,vclai)+cblk(lcell, & vorgaro1i)+cblk(lcell,vorgaro2i)+cblk(lcell,vorgalk1i)+cblk(lcell, & vorgole1i)+cblk(lcell,vorgba1i)+cblk(lcell,vorgba2i)+cblk(lcell, & vorgba3i)+cblk(lcell,vorgba4i)+cblk(lcell,vorgpai)+cblk(lcell, & vp25ai)+cblk(lcell,veci))) +! pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, & +! vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+cblk(lcell, & +! vorgaro1i)+cblk(lcell,vorgaro2i)+cblk(lcell,vorgalk1i)+cblk(lcell, & +! vorgole1i)+cblk(lcell,vorgba1i)+cblk(lcell,vorgba2i)+cblk(lcell, & +! vorgba3i)+cblk(lcell,vorgba4i)+cblk(lcell,vorgpai)+cblk(lcell, & +! vp25ai)+cblk(lcell,veci))) + ! *** Accumulation-mode: +! ! Na and Cl added to accum mode mass conc + pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, & - vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+cblk(lcell, & + vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+ & + cblk(lcell,vnaaj)+cblk(lcell,vclaj)+cblk(lcell, & vorgaro1j)+cblk(lcell,vorgaro2j)+cblk(lcell,vorgalk1j)+cblk(lcell, & vorgole1j)+cblk(lcell,vorgba1j)+cblk(lcell,vorgba2j)+cblk(lcell, & vorgba3j)+cblk(lcell,vorgba4j)+cblk(lcell,vorgpaj)+cblk(lcell, & vp25aj)+cblk(lcell,vecj))) +! pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, & +! vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+cblk(lcell, & +! vorgaro1j)+cblk(lcell,vorgaro2j)+cblk(lcell,vorgalk1j)+cblk(lcell, & +! vorgole1j)+cblk(lcell,vorgba1j)+cblk(lcell,vorgba2j)+cblk(lcell, & +! vorgba3j)+cblk(lcell,vorgba4j)+cblk(lcell,vorgpaj)+cblk(lcell, & +! vp25aj)+cblk(lcell,vecj))) + ! *** coarse mode: @@ -4754,7 +4877,9 @@ SUBROUTINE rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, & ! molecular weight for Organic Specie REAL mworg - PARAMETER (mworg=16.0) +! + PARAMETER (mworg=175.0) +! PARAMETER (mworg=16.0) ! molecular weight for Chloride REAL mwcl @@ -8187,27 +8312,31 @@ SUBROUTINE sorgam_addemiss( & dz8w(its:ite,kts:kte,jts:jte) ! ! Increment the aerosol numbers... - if(emissopt .lt. 5 )then + if (emissopt .ne. 5) then ! ! Aitken mode first... chem(its:ite,kts:kemit,jts:jte,p_nu0) = & chem(its:ite,kts:kemit,jts:jte,p_nu0) + & - factor(its:ite,kts:kemit,jts:jte)*factnumn*( & - anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i) + & - emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci) + & - emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai) ) + & - orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi) ) + factor(its:ite,kts:kemit,jts:jte)*factnumn*( & + anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai) ) + & + orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi) + & + so4fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4i) + & + no3fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3i) ) ! Accumulation mode next... chem(its:ite,kts:kemit,jts:jte,p_ac0) = & chem(its:ite,kts:kemit,jts:jte,p_ac0) + & - factor(its:ite,kts:kemit,jts:jte)*factnuma*( & - anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j) + & - emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj) + & - emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj) ) + & - orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj) ) + factor(its:ite,kts:kemit,jts:jte)*factnuma*( & + anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj) ) + & + orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj) + & + so4fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4j) + & + no3fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3j)) ! And now the coarse mode... @@ -8392,7 +8521,8 @@ SUBROUTINE sorgam_addemiss( & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) end if - if( dust_opt == 3 ) then +! dust_opt changed to 5 since it conflicts with gocart/afwa + if( dust_opt == 5 ) then call sorgam_dust_gocartemis( & ktau,dtstep,num_soil_layers,alt,u_phy, & v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, & @@ -8977,7 +9107,7 @@ subroutine sorgam_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & jdustcon = sum(bems(1:5))*accfrac/airmas ! kg/kg-dryair jdustcon = jdustcon * converi ! ug/kg-dryair - chem(i,k,j,p_p25)=chem(i,k,j,p_p25j) + jdustcon + chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + jdustcon chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + cdustcon ! czhao doing dust number emission following pm10 diff --git a/wrfv2_fire/chem/module_aerosols_sorgam_vbs.F b/wrfv2_fire/chem/module_aerosols_sorgam_vbs.F new file mode 100644 index 00000000..227ba4a6 --- /dev/null +++ b/wrfv2_fire/chem/module_aerosols_sorgam_vbs.F @@ -0,0 +1,8376 @@ +MODULE module_aerosols_sorgam_vbs +! +! 10/08/2014: This module is a modified version of the "module_aerosols_soa_vbs" based on the work of Ahmadov et al. (2012). +! This module treats the major aerosol processes related to chemical option CB05-MADE/VBS, which is implemented by NCSU +! +! References: +! 1) Wang, K., Y. Zhang, K. Yahya, S.-Y. Wu, and G. Grell (2014), Implementation and initial application of new chemistry-aerosol ! options in WRF/Chem for simulating secondary organic aerosols and aerosol indirect effects, Atmos. Environ., under review. +! 2) Ahmadov R., McKeen S.A., Robinson A.L., Bahreini R., Middlebrook A., deGouw J., Meagher J., Hsie E.-Y., +! Edgerton E., Shaw S., Trainer M. (2012), A volatility basis set model for summertime secondary organic aerosols +! over the eastern U.S. in 2006. J. Geophys. Res.,117, D06301, doi:10.1029/2011JD016831. +! 3) Murphy, B. N. and S. N. Pandis (2009). "Simulating the Formation of Semivolatile Primary and Secondary Organic Aerosol +! in a Regional Chemical Transport Model." Environmental Science & Technology 43(13): 4722-4728. +! 4) Donahue, N. M., A. L. Robinson, et al. (2006). "Coupled partitioning, dilution, and chemical aging of semivolatile +! organics." Environmental Science & Technology 40(8): 2635-2643. +! +! A reference for the MADE aerosol parameterization: +! Ackermann, I. J., H. Hass, M. Memmesheimer, A. Ebel, F. S. Binkowski, and U. Shankar (1998), +! Modal aerosol dynamics model for Europe: Development and first applications, Atmos. Environ., 32(17), 2981-2999. +! +!!WARNING! The deposition of organic condensable vapours (cvasoa* and cvbsoa*) are highly uncertain due to lack of observations. +! Currently this process is parameterized using modeled dry deposition velocities of HNO3 (multiplied by "depo_fact" for OCVs). +! Paper by Ahmadov et al. (2012) desribes this approach. The default value for "depo_fact" in WRF-CHEM is 0.25. +! A user can set a different value for "depo_fact" in namelist.input. +! +!!WARNING! Another uncertainty is wet removal of OCVs! This is neglected in the current version of the WRF-CHEM code. +! +! +! + USE module_state_description +! USE module_data_radm2 + USE module_data_sorgam_vbs +! USE module_radm + + IMPLICIT NONE +#define cw_species_are_in_registry + +CONTAINS + + SUBROUTINE sorgam_vbs_driver ( id,ktau,dtstep,t_phy,moist,aerwrf,p8w, & + t8w,alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, & + vcsulf_old, & + vdrog3, & + kemit,brch_ratio, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! USE module_configure, only: grid_config_rec_type +! TYPE (grid_config_rec_type), INTENT (in) :: config_flags + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + kemit, id, ktau + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! following are aerosol arrays that are not advected +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3 + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: brch_ratio + +! cvasoa1,cvasoa2, & +! cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4 + + REAL, DIMENSION(ims:ime,kms:kme-0,jms:jme,ldrog_vbs), & + INTENT(IN ) :: VDROG3 + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: t_phy, & + alt, & + p_phy, & + dz8w, & + rh, & ! fractional relative humidity + z, & + t8w,p8w,z_at_w , & + aerwrf , & + rho_phy + REAL, DIMENSION( ims:ime , kms:kme-0 , jms:jme ) , & + INTENT(IN ) :: vcsulf_old + REAL, INTENT(IN ) :: dtstep + + REAL drog_in(ldrog_vbs) ! anthropogenic AND biogenic organic aerosol precursors [ug m**-3 s**-1] + +! REAL condvap_in(lspcv) ! condensable vapors [ug m**-3] + REAL, PARAMETER :: rgas=8.314510 + REAL convfac,convfac2 + +!...BLKSIZE set to one in column model ciarev02 + INTEGER, PARAMETER :: blksize=1 + +!...number of aerosol species +! number of species (gas + aerosol) + INTEGER nspcsda + PARAMETER (nspcsda=l1ae) !bs +! (internal aerosol dynamics) +!bs # of anth. cond. vapors in SOA_VBS + INTEGER nacv + PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM +!bs total # of cond. vapors in SOA_VBS + INTEGER ncv + PARAMETER (ncv=lspcv) !bs +!bs total # of cond. vapors in CTM + REAL cblk(blksize,nspcsda) ! main array of variables + ! particles [ug/m^3/s] + REAL soilrat_in + ! emission rate of soil derived coars + ! input HNO3 to CBLK [ug/m^3] + REAL nitrate_in + ! input NH3 to CBLK [ug/m^3] + REAL nh3_in + ! input SO4 vapor [ug/m^3] + REAL hcl_in + + REAL vsulf_in + + REAL so4rat_in + ! input SO4 formation[ug/m^3/sec] + REAL epm25i(blksize),epm25j(blksize),epmcoarse(blksize) + ! Emission rate of i-mode EC [ug m**-3 s**-1] + REAL eeci_in + ! Emission rate of j-mode EC [ug m**-3 s**-1] + REAL eecj_in + ! Emission rate of j-mode org. aerosol [ug m**- + REAL eorgi_in + + REAL eorgj_in ! Emission rate of j-mode org. aerosol [ug m**- + REAL pres ! pressure in cb + REAL temp ! temperature in K + ! REAL relhum ! rel. humidity (0,1) + REAL brrto + + REAL :: p(kts:kte),t(kts:kte),rh0(kts:kte) + +!...molecular weights ciarev02 +! these molecular weights aren't used at all + +! molecular weight for SO4 + REAL mwso4 + PARAMETER (mwso4=96.0576) + +! molecular weight for HNO3 + REAL mwhno3 + PARAMETER (mwhno3=63.01287) + +! molecular weight for NH3 + REAL mwnh3 + PARAMETER (mwnh3=17.03061) + +! molecular weight for HCL + REAL mwhcl + PARAMETER (mwhcl=36.46100) + +!bs molecular weight for Organic Spec +!mworg uncommented + REAL mworg + PARAMETER (mworg=175.0) + +!bs molecular weight for Elemental Carbon + REAL mwec + PARAMETER (mwec=12.0) + +! they aren't used +!!rs molecular weight +! REAL mwaro1 +! PARAMETER (mwaro1=150.0) +! +!!rs molecular weight +! REAL mwaro2 +! PARAMETER (mwaro2=150.0) +! +!!rs molecular weight +! REAL mwalk1 +! PARAMETER (mwalk1=140.0) +! +!!rs molecular weight +! REAL mwalk2 +! PARAMETER (mwalk2=140.0) +! +!!rs molecular weight +! REAL mwole1 +! PARAMETER (mwole1=140.0) +! +!!rs molecular weight +! REAL mwapi1 +! PARAMETER (mwapi1=200.0) +! +!!rs molecular weight +! REAL mwapi2 +! PARAMETER (mwapi2=200.0) +! +!!rs molecular weight +! REAL mwlim1 +! PARAMETER (mwlim1=200.0) +! +!!rs molecular weight +! REAL mwlim2 +! PARAMETER (mwlim2=200.0) + +INTEGER :: i,j,k,l,debug_level +! convert advected aerosol variables to ug/m3 from mixing ratio +! they will be converted back at the end of this driver +! + do l=p_so4aj,num_chem + do j=jts,jte + do k=kts,kte + do i=its,ite + chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)/alt(i,k,j)) + enddo + enddo + enddo + enddo + + ! Use RH from phys/??? + do 100 j=jts,jte + do 100 i=its,ite + debug_level=0 + +! t(k) = t_phy(i,k,j) +! p(k) = .001*p_phy(i,k,j) +! rh(k) = MIN( 95.,100. * moist(i,k,j,p_qv) / & +! (3.80*exp(17.27*(t_phy(i,k,j)-273.)/ & +! (t_phy(i,k,j)-36.))/(.01*p_phy(i,k,j))) ) +! rh(k)=max(.1,0.01*rh(k)) +! ! rh(k) = .10 +! enddo + +k_loop: do k=kts,kte + +! added here + t(k) = t_phy(i,k,j) + p(k) = .001*p_phy(i,k,j) + rh0(k) = rh(i,k,j) + + cblk=0. + +! do l=1,ldrog +! drog_in(l)=0. +! enddo + +! do l=1,lspcv +! condvap_in(l)=0. +! enddo + + convfac = p(k)/rgas/t(k)*1000. + so4rat_in=(chem(i,k,j,p_sulf)-vcsulf_old(i,k,j))/dtstep*CONVFAC*MWSO4 + soilrat_in = 0. + nitrate_in = max(epsilc,chem(i,k,j,p_hno3)*convfac*mwhno3) + nh3_in = max(epsilc,chem(i,k,j,p_nh3)*convfac*mwnh3) + hcl_in = max(epsilc,chem(i,k,j,p_hcl)*convfac*mwhcl) +!KW hcl_in = 0. + vsulf_in = max(epsilc,chem(i,k,j,p_sulf)*convfac*mwso4) + +! * organic aerosol precursors DeltaROG and SOA production + drog_in(PALK4) = VDROG3(i,k,j,PALK4) + drog_in(PALK5) = VDROG3(i,k,j,PALK5) + drog_in(POLE1) = VDROG3(i,k,j,POLE1) + drog_in(POLE2) = VDROG3(i,k,j,POLE2) + drog_in(PARO1) = VDROG3(i,k,j,PARO1) + drog_in(PARO2) = VDROG3(i,k,j,PARO2) + drog_in(PISOP) = VDROG3(i,k,j,PISOP) + drog_in(PTERP) = VDROG3(i,k,j,PTERP) + drog_in(PSESQ) = VDROG3(i,k,j,PSESQ) + drog_in(PBRCH) = VDROG3(i,k,j,PBRCH) + + cblk(1,VASOA1J) = chem(i,k,j,p_asoa1j) + cblk(1,VASOA1I) = chem(i,k,j,p_asoa1i) + cblk(1,VASOA2J) = chem(i,k,j,p_asoa2j) + cblk(1,VASOA2I) = chem(i,k,j,p_asoa2i) + cblk(1,VASOA3J) = chem(i,k,j,p_asoa3j) + cblk(1,VASOA3I) = chem(i,k,j,p_asoa3i) + cblk(1,VASOA4J) = chem(i,k,j,p_asoa4j) + cblk(1,VASOA4I) = chem(i,k,j,p_asoa4i) + + cblk(1,VBSOA1J) = chem(i,k,j,p_bsoa1j) + cblk(1,VBSOA1I) = chem(i,k,j,p_bsoa1i) + cblk(1,VBSOA2J) = chem(i,k,j,p_bsoa2j) + cblk(1,VBSOA2I) = chem(i,k,j,p_bsoa2i) + cblk(1,VBSOA3J) = chem(i,k,j,p_bsoa3j) + cblk(1,VBSOA3I) = chem(i,k,j,p_bsoa3i) + cblk(1,VBSOA4J) = chem(i,k,j,p_bsoa4j) + cblk(1,VBSOA4I) = chem(i,k,j,p_bsoa4i) + +! Comment out the old code +! condvap_in(PSOAARO1) = max(epsilc,cvaro1(i,k,j)) +! condvap_in(PSOAARO2) = max(epsilc,cvaro2(i,k,j)) +! condvap_in(PSOAALK1) = max(epsilc,cvalk1(i,k,j)) +! condvap_in(PSOAOLE1) = max(epsilc,cvole1(i,k,j)) +! cblk(1,VORGARO1J) = chem(i,k,j,p_orgaro1j) +! cblk(1,VORGARO1I) = chem(i,k,j,p_orgaro1i) +! cblk(1,VORGARO2J) = chem(i,k,j,p_orgaro2j) +! cblk(1,VORGARO2I) = chem(i,k,j,p_orgaro2i) +! cblk(1,VORGALK1J) = chem(i,k,j,p_orgalk1j) +! cblk(1,VORGALK1I) = chem(i,k,j,p_orgalk1i) +! cblk(1,VORGOLE1J) = chem(i,k,j,p_orgole1j) +! cblk(1,VORGOLE1I) = chem(i,k,j,p_orgole1i) +! cblk(1,VORGBA1J ) = chem(i,k,j,p_orgba1j) +! cblk(1,VORGBA1I ) = chem(i,k,j,p_orgba1i) +! cblk(1,VORGBA2J ) = chem(i,k,j,p_orgba2j) +! cblk(1,VORGBA2I ) = chem(i,k,j,p_orgba2i) +! cblk(1,VORGBA3J ) = chem(i,k,j,p_orgba3j) +! cblk(1,VORGBA3I ) = chem(i,k,j,p_orgba3i) +! cblk(1,VORGBA4J ) = chem(i,k,j,p_orgba4j) +! cblk(1,VORGBA4I ) = chem(i,k,j,p_orgba4i) + + cblk(1,VORGPAJ ) = chem(i,k,j,p_orgpaj) + cblk(1,VORGPAI ) = chem(i,k,j,p_orgpai) + cblk(1,VECJ ) = chem(i,k,j,p_ecj) + cblk(1,VECI ) = chem(i,k,j,p_eci) + cblk(1,VP25AJ ) = chem(i,k,j,p_p25j) + cblk(1,VP25AI ) = chem(i,k,j,p_p25i) + cblk(1,VANTHA ) = chem(i,k,j,p_antha) + cblk(1,VSEAS ) = chem(i,k,j,p_seas) + cblk(1,VSOILA ) = chem(i,k,j,p_soila) + cblk(1,VH2OAJ ) = max(epsilc,h2oaj(i,k,j)) + cblk(1,VH2OAI ) = max(epsilc,h2oai(i,k,j)) + cblk(1,VNU3 ) = max(epsilc,nu3(i,k,j)) + cblk(1,VAC3 ) = max(epsilc,ac3(i,k,j)) + + cblk(1,VCOR3 ) = max(epsilc,cor3(i,k,j)) + + cblk(1,vcvasoa1) = chem(i,k,j,p_cvasoa1) + cblk(1,vcvasoa2) = chem(i,k,j,p_cvasoa2) + cblk(1,vcvasoa3) = chem(i,k,j,p_cvasoa3) + cblk(1,vcvasoa4) = chem(i,k,j,p_cvasoa4) + + cblk(1,vcvbsoa1) = chem(i,k,j,p_cvbsoa1) + cblk(1,vcvbsoa2) = chem(i,k,j,p_cvbsoa2) + cblk(1,vcvbsoa3) = chem(i,k,j,p_cvbsoa3) + cblk(1,vcvbsoa4) = chem(i,k,j,p_cvbsoa4) +! +! Set emissions to zero + epmcoarse(1) = 0. + epm25i(1) = 0. + epm25j(1) = 0. + eeci_in = 0. + eecj_in = 0. + eorgi_in = 0. + eorgj_in = 0. + cblk(1,VSO4AJ ) = chem(i,k,j,p_so4aj) + cblk(1,VSO4AI ) = chem(i,k,j,p_so4ai) + cblk(1,VNO3AJ ) = chem(i,k,j,p_no3aj) + cblk(1,VNO3AI ) = chem(i,k,j,p_no3ai) + cblk(1,VNAAJ ) = chem(i,k,j,p_naaj) + cblk(1,VNAAI ) = chem(i,k,j,p_naai) + cblk(1,VCLAJ ) = chem(i,k,j,p_claj) + cblk(1,VCLAI ) = chem(i,k,j,p_clai) +!KW cblk(1,VCLAJ ) = 0. +!KW cblk(1,VCLAI ) = 0. +! +!rs. nitrate, nh3, sulf + cblk(1,vsulf) = vsulf_in + cblk(1,vhno3) = nitrate_in + cblk(1,vnh3) = nh3_in + cblk(1,vhcl) = hcl_in + cblk(1,VNH4AJ) = chem(i,k,j,p_nh4aj) + cblk(1,VNH4AI) = chem(i,k,j,p_nh4ai) + cblk(1,VNU0 ) = max(1.e7,chem(i,k,j,p_nu0)) + cblk(1,VAC0 ) = max(1.e7,chem(i,k,j,p_ac0)) + cblk(1,VCORN ) = chem(i,k,j,p_corn) + +! the following operation updates cblk, which includes the vapors and SOA species +! condvap_in is removed + CALL rpmmod3(nspcsda,blksize,k,dtstep,10.*p(k),t(k),rh0(k),nitrate_in,nh3_in, & + vsulf_in,so4rat_in,drog_in,ldrog_vbs,ncv,nacv,eeci_in,eecj_in, & + eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse,soilrat_in,cblk,i,j,k,brrto) + +! calculation of brch_ratio + brch_ratio(i,k,j)= brrto + !------------------------------------------------------------------------ + + chem(i,k,j,p_so4aj) = cblk(1,VSO4AJ ) + chem(i,k,j,p_so4ai) = cblk(1,VSO4AI ) + chem(i,k,j,p_nh4aj) = cblk(1,VNH4AJ ) + chem(i,k,j,p_nh4ai) = cblk(1,VNH4AI ) + chem(i,k,j,p_no3aj) = cblk(1,VNO3AJ ) + chem(i,k,j,p_no3ai) = cblk(1,VNO3AI ) + chem(i,k,j,p_naaj) = cblk(1,VNAAJ ) + chem(i,k,j,p_naai) = cblk(1,VNAAI ) +!KW + chem(i,k,j,p_claj) = cblk(1,VCLAJ ) + chem(i,k,j,p_clai) = cblk(1,VCLAI ) + + chem(i,k,j,p_asoa1j) = cblk(1,VASOA1J) + chem(i,k,j,p_asoa1i) = cblk(1,VASOA1I) + chem(i,k,j,p_asoa2j) = cblk(1,VASOA2J) + chem(i,k,j,p_asoa2i) = cblk(1,VASOA2I) + chem(i,k,j,p_asoa3j) = cblk(1,VASOA3J) + chem(i,k,j,p_asoa3i) = cblk(1,VASOA3I) + chem(i,k,j,p_asoa4j) = cblk(1,VASOA4J) + chem(i,k,j,p_asoa4i) = cblk(1,VASOA4I) + + chem(i,k,j,p_bsoa1j) = cblk(1,VBSOA1J) + chem(i,k,j,p_bsoa1i) = cblk(1,VBSOA1I) + chem(i,k,j,p_bsoa2j) = cblk(1,VBSOA2J) + chem(i,k,j,p_bsoa2i) = cblk(1,VBSOA2I) + chem(i,k,j,p_bsoa3j) = cblk(1,VBSOA3J) + chem(i,k,j,p_bsoa3i) = cblk(1,VBSOA3I) + chem(i,k,j,p_bsoa4j) = cblk(1,VBSOA4J) + chem(i,k,j,p_bsoa4i) = cblk(1,VBSOA4I) + +! chem(i,k,j,p_orgaro1j) = cblk(1,VORGARO1J) +! chem(i,k,j,p_orgaro1i) = cblk(1,VORGARO1I) +! chem(i,k,j,p_orgaro2j) = cblk(1,VORGARO2J) +! chem(i,k,j,p_orgaro2i) = cblk(1,VORGARO2I) +! chem(i,k,j,p_orgalk1j) = cblk(1,VORGALK1J) +! chem(i,k,j,p_orgalk1i) = cblk(1,VORGALK1I) +! chem(i,k,j,p_orgole1j) = cblk(1,VORGOLE1J) +! chem(i,k,j,p_orgole1i) = cblk(1,VORGOLE1I) +! chem(i,k,j,p_orgba1j) = cblk(1,VORGBA1J ) +! chem(i,k,j,p_orgba1i) = cblk(1,VORGBA1I ) +! chem(i,k,j,p_orgba2j) = cblk(1,VORGBA2J ) +! chem(i,k,j,p_orgba2i) = cblk(1,VORGBA2I ) +! chem(i,k,j,p_orgba3j) = cblk(1,VORGBA3J ) +! chem(i,k,j,p_orgba3i) = cblk(1,VORGBA3I ) +! chem(i,k,j,p_orgba4j) = cblk(1,VORGBA4J ) +! chem(i,k,j,p_orgba4i) = cblk(1,VORGBA4I ) + + chem(i,k,j,p_orgpaj) = cblk(1,VORGPAJ ) + chem(i,k,j,p_orgpai) = cblk(1,VORGPAI ) + chem(i,k,j,p_ecj) = cblk(1,VECJ ) + chem(i,k,j,p_eci) = cblk(1,VECI ) + chem(i,k,j,p_p25j) = cblk(1,VP25AJ ) + chem(i,k,j,p_p25i) = cblk(1,VP25AI ) + chem(i,k,j,p_antha) = cblk(1,VANTHA ) + chem(i,k,j,p_seas) = cblk(1,VSEAS ) + chem(i,k,j,p_soila) = cblk(1,VSOILA ) + chem(i,k,j,p_nu0) = max(1.e7,cblk(1,VNU0 )) + chem(i,k,j,p_ac0) = max(1.e7,cblk(1,VAC0 )) + + chem(i,k,j,p_corn) = cblk(1,VCORN ) + h2oaj(i,k,j) = cblk(1,VH2OAJ ) + h2oai(i,k,j) = cblk(1,VH2OAI ) + nu3(i,k,j) = cblk(1,VNU3 ) + ac3(i,k,j) = cblk(1,VAC3 ) + cor3(i,k,j) = cblk(1,VCOR3 ) + + chem(i,k,j,p_cvasoa1)= cblk(1,VCVASOA1 ) + chem(i,k,j,p_cvasoa2)= cblk(1,VCVASOA2 ) + chem(i,k,j,p_cvasoa3)= cblk(1,VCVASOA3 ) + chem(i,k,j,p_cvasoa4)= cblk(1,VCVASOA4 ) + + chem(i,k,j,p_cvbsoa1)= cblk(1,VCVBSOA1 ) + chem(i,k,j,p_cvbsoa2)= cblk(1,VCVBSOA2 ) + chem(i,k,j,p_cvbsoa3)= cblk(1,VCVBSOA3 ) + chem(i,k,j,p_cvbsoa4)= cblk(1,VCVBSOA4 ) + +!--------------------------------------------------------------------------- + +! cvbsoa1(i,k,j) = 0. +! cvbsoa2(i,k,j) = 0. +! cvbsoa3(i,k,j) = 0. +! cvbsoa4(i,k,j) = 0. + +! cvaro1(i,k,j) = cblk(1,VCVARO1 ) +! cvaro2(i,k,j) = cblk(1,VCVARO2 ) +! cvalk1(i,k,j) = cblk(1,VCVALK1 ) +! cvole1(i,k,j) = cblk(1,VCVOLE1 ) +! cvapi1(i,k,j) = 0. +! cvapi2(i,k,j) = 0. +! cvlim1(i,k,j) = 0. +! cvlim2(i,k,j) = 0. + + chem(i,k,j,p_sulf)=max(epsilc,cblk(1,vsulf)/CONVFAC/MWSO4) + chem(i,k,j,p_hno3)=max(epsilc,cblk(1,vhno3)/CONVFAC/MWHNO3) + chem(i,k,j,p_nh3)=max(epsilc,cblk(1,vnh3)/CONVFAC/MWNH3) + chem(i,k,j,p_hcl)=max(epsilc,cblk(1,vhcl)/CONVFAC/MWHCL) + + enddo k_loop ! k-loop +100 continue ! i,j-loop ends + +! convert aerosol variables back to mixing ratio from ug/m3 + do l=p_so4aj,num_chem + do j=jts,jte + do k=kts,kte + do i=its,ite + chem(i,k,j,l)=max(epsilc,chem(i,k,j,l)*alt(i,k,j)) + enddo + enddo + enddo + enddo + +END SUBROUTINE sorgam_vbs_driver +! /////////////////////////////////////////////////// + +SUBROUTINE sum_pm_sorgam_vbs ( & + alt, chem, h2oaj, h2oai, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & +!KW + tsoa,asoa,bsoa, & +!KW + dust_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + INTEGER, INTENT(IN ) :: dust_opt, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: alt,h2oaj,h2oai + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10, & +!KW + tsoa,asoa,bsoa +!KW + + INTEGER :: i,ii,j,jj,k,n +! +! sum up pm2_5 and pm10 output +! + pm2_5_dry(its:ite, kts:kte, jts:jte) = 0. + pm2_5_water(its:ite, kts:kte, jts:jte) = 0. + pm2_5_dry_ec(its:ite, kts:kte, jts:jte) = 0. + tsoa(its:ite, kts:kte, jts:jte) = 0. + asoa(its:ite, kts:kte, jts:jte) = 0. + bsoa(its:ite, kts:kte, jts:jte) = 0. + do j=jts,jte + jj=min(jde-1,j) + do k=kts,kte + do i=its,ite + ii=min(ide-1,i) + do n=p_so4aj,p_p25i + pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n) + enddo +!KW adding cloud aerosols + if( p_p25cwi .gt. p_p25i) then + do n=p_so4cwj,p_p25cwi + pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n) + enddo + endif + pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j)+chem(ii,k,jj,p_ecj) & + + chem(ii,k,jj,p_eci) + pm2_5_water(i,k,j) = pm2_5_water(i,k,j)+h2oaj(i,k,j) & + + h2oai(i,k,j) +!KW calculating SOA concentration + do n=p_asoa1j,p_bsoa4i + tsoa(i,k,j) = tsoa(i,k,j)+chem(ii,k,jj,n) + enddo + do n=p_asoa1j,p_asoa4i + asoa(i,k,j) = asoa(i,k,j)+chem(ii,k,jj,n) + enddo + do n=p_bsoa1j,p_bsoa4i + bsoa(i,k,j) = bsoa(i,k,j)+chem(ii,k,jj,n) + enddo + if( p_p25cwi .gt. p_p25i) then + do n=p_asoa1cwj,p_bsoa4cwi + tsoa(i,k,j) = tsoa(i,k,j)+chem(ii,k,jj,n) + enddo + do n=p_asoa1cwj,p_asoa4cwi + asoa(i,k,j) = asoa(i,k,j)+chem(ii,k,jj,n) + enddo + do n=p_bsoa1cwj,p_bsoa4cwi + bsoa(i,k,j) = bsoa(i,k,j)+chem(ii,k,jj,n) + enddo + endif + !Convert the units from mixing ratio to concentration (ug m^-3) + pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) / alt(ii,k,jj) + pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) / alt(ii,k,jj) + pm2_5_water(i,k,j) = pm2_5_water(i,k,j) / alt(ii,k,jj) + tsoa(i,k,j) = tsoa(i,k,j) / alt(ii,k,jj) + asoa(i,k,j) = asoa(i,k,j) / alt(ii,k,jj) + bsoa(i,k,j) = bsoa(i,k,j) / alt(ii,k,jj) + enddo + enddo + enddo + do j=jts,jte + jj=min(jde-1,j) + do k=kts,kte + do i=its,ite + ii=min(ide-1,i) + pm10(i,k,j) = pm2_5_dry(i,k,j) & + + ( chem(ii,k,jj,p_antha) & + + chem(ii,k,jj,p_soila) & + + chem(ii,k,jj,p_seas) ) / alt(ii,k,jj) +!KW adding cloud aerosols + if( p_p25cwi .gt. p_p25i) then + pm10(i,k,j) = pm10(i,k,j) & + + ( chem(ii,k,jj,p_anthcw) & + + chem(ii,k,jj,p_soilcw) & + + chem(ii,k,jj,p_seascw) ) / alt(ii,k,jj) + endif + enddo + enddo + enddo + END SUBROUTINE sum_pm_sorgam_vbs +! /////////////////////////////////////////////////// + +SUBROUTINE sorgam_vbs_depdriver (id,config_flags,ktau,dtstep, & + ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, & + alt,p_phy,chem,rho_phy,dz8w,rh,z,z_at_w, & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3, & + +! the vapors are part of chem array +! cvasoa1,cvasoa2, & +! cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4, & + + aer_res,vgsa, & +!KW + numgas,ddflx, & +!KW + numaer, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure,only: grid_config_rec_type + TYPE (grid_config_rec_type) , INTENT (IN) :: config_flags + + INTEGER, INTENT(IN ) :: numgas, & !KW + numaer, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + id,ktau + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! following are aerosol arrays that are not advected +! + REAL, DIMENSION( its:ite, jts:jte, numaer ), & + INTENT(INOUT ) :: & + vgsa +!KW + real, intent(inout), & + dimension( ims:ime, jms:jme, numgas+1:num_chem ) :: & + ddflx +!KW + REAL, DIMENSION( its:ite, jts:jte ), & + INTENT(INOUT ) :: & + aer_res + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3 + +! no vapors +!cvaro1,cvaro2,cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2 + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: t_phy, & + alt, & + p_phy, & + dz8w, & + rh, & + z, & + t8w,p8w,z_at_w , & + rho_phy + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: ust,rmol, pbl, znt + REAL, INTENT(IN ) :: dtstep + + REAL, PARAMETER :: rgas=8.314510 + REAL convfac,convfac2 +!...BLKSIZE set to one in column model ciarev02 + + INTEGER, PARAMETER :: blksize=1 + +!...number of aerosol species +! number of species (gas + aerosol) + INTEGER nspcsda + PARAMETER (nspcsda=l1ae) !bs +! (internal aerosol dynamics) +!bs # of anth. cond. vapors in SOA_VBS + INTEGER nacv + PARAMETER (nacv=lcva) !bs # of anth. cond. vapors in CTM +!bs total # of cond. vapors in SOA_VBS + INTEGER, PARAMETER :: ncv=lspcv ! number of bins=8 +!bs total # of cond. vapors in CTM + REAL cblk(blksize,nspcsda) ! main array of variables + ! particles [ug/m^3/s] + REAL soilrat_in + ! emission rate of soil derived coars + ! input HNO3 to CBLK [ug/m^3] + REAL nitrate_in + ! input NH3 to CBLK [ug/m^3] + REAL nh3_in +!KW +!hcl_in added + REAL hcl_in + ! input SO4 vapor [ug/m^3] + REAL vsulf_in + + REAL so4rat_in + ! input SO4 formation[ug/m^3/sec] + ! pressure in cb + REAL pres + ! temperature in K + REAL temp + !bs + REAL relhum + ! rel. humidity (0,1) + REAL :: p(kts:kte),t(kts:kte),rh0(kts:kte) + +!...molecular weights ciarev02 + +! molecular weight for SO4 + REAL mwso4 + PARAMETER (mwso4=96.0576) + +! molecular weight for HNO3 + REAL mwhno3 + PARAMETER (mwhno3=63.01287) + +!KW +!molecular weight for HCL added + REAL mwhcl + PARAMETER (mwhcl=36.46100) + +! molecular weight for NH3 + REAL mwnh3 + PARAMETER (mwnh3=17.03061) + +!bs molecular weight for Organic Spec + REAL mworg + PARAMETER (mworg=175.0) + +!bs molecular weight for Elemental Ca + REAL mwec + PARAMETER (mwec=12.0) + +! they aren't used +!!rs molecular weight +! REAL mwaro1 +! PARAMETER (mwaro1=150.0) +! +!!rs molecular weight +! REAL mwaro2 +! PARAMETER (mwaro2=150.0) +! +!!rs molecular weight +! REAL mwalk1 +! PARAMETER (mwalk1=140.0) +! +!!rs molecular weight +! REAL mwalk2 +! PARAMETER (mwalk2=140.0) +! +!!rs molecular weight +!!rs molecular weight +! REAL mwole1 +! PARAMETER (mwole1=140.0) +! +!!rs molecular weight +! REAL mwapi1 +! PARAMETER (mwapi1=200.0) +! +!!rs molecular weight +! REAL mwapi2 +! PARAMETER (mwapi2=200.0) +! +!!rs molecular weight +! REAL mwlim1 +! PARAMETER (mwlim1=200.0) +! +! REAL mwlim2 +! PARAMETER (mwlim2=200.0) + + INTEGER NUMCELLS ! actual number of cells in arrays ( default is 1 in box model) +!ia kept to 1 in current version of column model + PARAMETER( NUMCELLS = 1) + + REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ] + REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ] + REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ] + REAL PBLH( BLKSIZE ) ! PBL height (m) + REAL ZNTT( BLKSIZE ) ! Surface roughness length (m) + REAL RMOLM( BLKSIZE ) ! Inverse of Monin-Obukhov length (1/m) + + REAL BLKPRS(BLKSIZE) ! pressure in cb + REAL BLKTA(BLKSIZE) ! temperature in K + REAL BLKDENS(BLKSIZE) ! Air density in kg/m3 +! +! *** OUTPUT: +! +! *** atmospheric properties + + REAL XLM( BLKSIZE ) ! atmospheric mean free path [ m ] + REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg/m s ] + +! *** followng is for future version + REAL VSED( BLKSIZE, NASPCSSED) ! sedimentation velocity [ m s**-1 ] + REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ] + +! *** modal diameters: [ m ] + REAL DGNUC( BLKSIZE ) ! nuclei mode geometric mean diameter [ m ] + REAL DGACC( BLKSIZE ) ! accumulation geometric mean diameter [ m ] + REAL DGCOR( BLKSIZE ) ! coarse mode geometric mean diameter [ m ] + +! *** aerosol properties: +! *** Modal mass concentrations [ ug m**3 ] + REAL PMASSN( BLKSIZE ) ! mass concentration in Aitken mode + REAL PMASSA( BLKSIZE ) ! mass concentration in accumulation mode + REAL PMASSC( BLKSIZE ) ! mass concentration in coarse mode + +! *** average modal particle densities [ kg/m**3 ] + REAL PDENSN( BLKSIZE ) ! average particle density in nuclei mode + REAL PDENSA( BLKSIZE ) ! average particle density in accumulation mode + REAL PDENSC( BLKSIZE ) ! average particle density in coarse mode + +! *** average modal Knudsen numbers + REAL KNNUC ( BLKSIZE ) ! nuclei mode Knudsen number + REAL KNACC ( BLKSIZE ) ! accumulation Knudsen number + REAL KNCOR ( BLKSIZE ) ! coarse mode Knudsen number +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +INTEGER :: i,j,k,l +! +! print *,'in sorgdepdriver ',its,ite,jts,jte + do l=1,numaer + do i=its,ite + do j=jts,jte + vgsa(i,j,l)=0. + enddo + enddo + enddo + vdep=0. + + do 100 j=jts,jte + do 100 i=its,ite + cblk=epsilc + do k=kts,kte + t(k) = t_phy(i,k,j) + p(k) = .001*p_phy(i,k,j) + rh0(k) = rh(i,k,j) + end do + + k=kts + convfac = p(k)/rgas/t(k)*1000. + nitrate_in = chem(i,k,j,p_hno3)*convfac*mwhno3 + nh3_in = chem(i,k,j,p_nh3)*convfac*mwnh3 + vsulf_in = chem(i,k,j,p_sulf)*convfac*mwso4 + hcl_in = chem(i,k,j,p_hcl)*convfac*mwhcl !KW + +!rs. nitrate, nh3, sulf + BLKPRS(BLKSIZE) = 1.e3*P(K) ! pressure in Pa + BLKTA(BLKSIZE) = T(K) ! temperature in K + USTAR(BLKSIZE) = max(1.e-1,UST(i,j)) + WSTAR(BLKSIZE) = 0. + pblh(blksize) = pbl(i,j) + zntt(blksize) = znt(i,j) + rmolm(blksize)= rmol(i,j) + convfac2=1./alt(i,k,j) ! density of dry air + BLKDENS(BLKSIZE)=convfac2 + cblk(1,vsulf) = max(epsilc,vsulf_in) + cblk(1,vhno3) = max(epsilc,nitrate_in) + cblk(1,vnh3) = max(epsilc,nh3_in) + cblk(1,vhcl) = max(epsilc,hcl_in) + cblk(1,VSO4AJ ) = max(epsilc,chem(i,k,j,p_so4aj)*convfac2) + cblk(1,VSO4AI ) = max(epsilc,chem(i,k,j,p_so4ai)*convfac2) + cblk(1,VNH4AJ ) = max(epsilc,chem(i,k,j,p_nh4aj)*convfac2) + cblk(1,VNH4AI ) = max(epsilc,chem(i,k,j,p_nh4ai)*convfac2) + cblk(1,VNO3AJ ) = max(epsilc,chem(i,k,j,p_no3aj)*convfac2) + cblk(1,VNO3AI ) = max(epsilc,chem(i,k,j,p_no3ai)*convfac2) + + if (p_naai >= param_first_scalar) & + cblk(1,VNAAI ) = max(epsilc,chem(i,k,j,p_naai)*convfac2) + if (p_naaj >= param_first_scalar) & + cblk(1,VNAAJ ) = max(epsilc,chem(i,k,j,p_naaj)*convfac2) + if (p_clai >= param_first_scalar) & + cblk(1,VCLAI ) = max(epsilc,chem(i,k,j,p_clai)*convfac2) + if (p_claj >= param_first_scalar) & + cblk(1,VCLAJ ) = max(epsilc,chem(i,k,j,p_claj)*convfac2) + + cblk(1,VASOA1J) = max(epsilc,chem(i,k,j,p_asoa1j)*convfac2) ! ug/kg-air to ug/m3 + cblk(1,VASOA1I) = max(epsilc,chem(i,k,j,p_asoa1i)*convfac2) + cblk(1,VASOA2J) = max(epsilc,chem(i,k,j,p_asoa2j)*convfac2) + cblk(1,VASOA2I) = max(epsilc,chem(i,k,j,p_asoa2i)*convfac2) + cblk(1,VASOA3J) = max(epsilc,chem(i,k,j,p_asoa3j)*convfac2) + cblk(1,VASOA3I) = max(epsilc,chem(i,k,j,p_asoa3i)*convfac2) + cblk(1,VASOA4J) = max(epsilc,chem(i,k,j,p_asoa4j)*convfac2) + cblk(1,VASOA4I) = max(epsilc,chem(i,k,j,p_asoa4i)*convfac2) + + cblk(1,VBSOA1J) = max(epsilc,chem(i,k,j,p_bsoa1j)*convfac2) + cblk(1,VBSOA1I) = max(epsilc,chem(i,k,j,p_bsoa1i)*convfac2) + cblk(1,VBSOA2J) = max(epsilc,chem(i,k,j,p_bsoa2j)*convfac2) + cblk(1,VBSOA2I) = max(epsilc,chem(i,k,j,p_bsoa2i)*convfac2) + cblk(1,VBSOA3J) = max(epsilc,chem(i,k,j,p_bsoa3j)*convfac2) + cblk(1,VBSOA3I) = max(epsilc,chem(i,k,j,p_bsoa3i)*convfac2) + cblk(1,VBSOA4J) = max(epsilc,chem(i,k,j,p_bsoa4j)*convfac2) + cblk(1,VBSOA4I) = max(epsilc,chem(i,k,j,p_bsoa4i)*convfac2) + +! cblk(1,VORGARO1J) = max(epsilc,chem(i,k,j,p_orgaro1j)*convfac2) +! cblk(1,VORGARO1I) = max(epsilc,chem(i,k,j,p_orgaro1i)*convfac2) +! cblk(1,VORGARO2J) = max(epsilc,chem(i,k,j,p_orgaro2j)*convfac2) +! cblk(1,VORGARO2I) = max(epsilc,chem(i,k,j,p_orgaro2i)*convfac2) +! cblk(1,VORGALK1J) = max(epsilc,chem(i,k,j,p_orgalk1j)*convfac2) +! cblk(1,VORGALK1I) = max(epsilc,chem(i,k,j,p_orgalk1i)*convfac2) +! cblk(1,VORGOLE1J) = max(epsilc,chem(i,k,j,p_orgole1j)*convfac2) +! cblk(1,VORGOLE1I) = max(epsilc,chem(i,k,j,p_orgole1i)*convfac2) +! cblk(1,VORGBA1J ) = max(epsilc,chem(i,k,j,p_orgba1j)*convfac2) +! cblk(1,VORGBA1I ) = max(epsilc,chem(i,k,j,p_orgba1i)*convfac2) +! cblk(1,VORGBA2J ) = max(epsilc,chem(i,k,j,p_orgba2j)*convfac2) +! cblk(1,VORGBA2I ) = max(epsilc,chem(i,k,j,p_orgba2i)*convfac2) +! cblk(1,VORGBA3J ) = max(epsilc,chem(i,k,j,p_orgba3j)*convfac2) +! cblk(1,VORGBA3I ) = max(epsilc,chem(i,k,j,p_orgba3i)*convfac2) +! cblk(1,VORGBA4J ) = max(epsilc,chem(i,k,j,p_orgba4j)*convfac2) +! cblk(1,VORGBA4I ) = max(epsilc,chem(i,k,j,p_orgba4i)*convfac2) + + cblk(1,VORGPAJ ) = max(epsilc,chem(i,k,j,p_orgpaj)*convfac2) + cblk(1,VORGPAI ) = max(epsilc,chem(i,k,j,p_orgpai)*convfac2) + cblk(1,VECJ ) = max(epsilc,chem(i,k,j,p_ecj)*convfac2) + cblk(1,VECI ) = max(epsilc,chem(i,k,j,p_eci)*convfac2) + cblk(1,VP25AJ ) = max(epsilc,chem(i,k,j,p_p25j)*convfac2) + cblk(1,VP25AI ) = max(epsilc,chem(i,k,j,p_p25i)*convfac2) + + cblk(1,VANTHA ) = max(epsilc,chem(i,k,j,p_antha)*convfac2) + cblk(1,VSEAS ) = max(epsilc,chem(i,k,j,p_seas)*convfac2) + cblk(1,VSOILA ) = max(epsilc,chem(i,k,j,p_soila)*convfac2) + + cblk(1,VNU0 ) = max(epsilc,chem(i,k,j,p_nu0)*convfac2) + cblk(1,VAC0 ) = max(epsilc,chem(i,k,j,p_ac0)*convfac2) + + cblk(1,VCORN ) = max(epsilc,chem(i,k,j,p_corn)*convfac2) + cblk(1,VH2OAJ ) = h2oaj(i,k,j) + cblk(1,VH2OAI ) = h2oai(i,k,j) + cblk(1,VNU3 ) = nu3(i,k,j) + cblk(1,VAC3 ) = ac3(i,k,j) + cblk(1,VCOR3 ) = cor3(i,k,j) + +! here cblk is used to call modpar, however modpar doesn't need vapors! +! cblk(1,vcvasoa1 ) = cvasoa1(i,k,j) +! cblk(1,vcvasoa2 ) = cvasoa2(i,k,j) +! cblk(1,vcvasoa3 ) = cvasoa3(i,k,j) +! cblk(1,vcvasoa4 ) = cvasoa4(i,k,j) +! cblk(1,vcvbsoa1) = 0. +! cblk(1,vcvbsoa2) = 0. +! cblk(1,vcvbsoa3) = 0. +! cblk(1,vcvbsoa4) = 0. + +! cblk(1,VCVARO1 ) = cvaro1(i,k,j) +! cblk(1,VCVARO2 ) = cvaro2(i,k,j) +! cblk(1,VCVALK1 ) = cvalk1(i,k,j) +! cblk(1,VCVOLE1 ) = cvole1(i,k,j) +! cblk(1,VCVAPI1 ) = 0. +! cblk(1,VCVAPI2 ) = 0. +! cblk(1,VCVLIM1 ) = 0. +! cblk(1,VCVLIM2 ) = 0. + +! cblk(1,VCVAPI1 ) = cvapi1(i,k,j) +! cblk(1,VCVAPI2 ) = cvapi2(i,k,j) +! cblk(1,VCVLIM1 ) = cvlim1(i,k,j) +! cblk(1,VCVLIM2 ) = cvlim2(i,k,j) +! +!rs. get size distribution information +! if(i.eq.126.and.j.eq.99)then +! print *,'in modpar ',i,j +! print *,cblk,BLKTA,BLKPRS,USTAR +! print *,'BLKSIZE, NSPCSDA, NUMCELLS' +! print *,BLKSIZE, NSPCSDA, NUMCELLS +! print *,'XLM, AMU,PDENSN, PDENSA, PDENSC' +! print *,XLM, AMU,PDENSN, PDENSA, PDENSC +! print *,'chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai)',p_orgpaj,p_orgpai +! print *,chem(i,k,j,p_orgpaj),chem(i,k,j,p_orgpai) +! endif + + CALL MODPAR( BLKSIZE, NSPCSDA, NUMCELLS, & + CBLK, & + BLKTA, BLKPRS, & + PMASSN, PMASSA, PMASSC, & + PDENSN, PDENSA, PDENSC, & + XLM, AMU, & + DGNUC, DGACC, DGCOR, & + KNNUC, KNACC,KNCOR ) + + if (config_flags%aer_drydep_opt == 11) then + CALL VDVG( BLKSIZE, NSPCSDA, NUMCELLS,k,CBLK, & + BLKTA, BLKDENS, AER_RES(I,j), USTAR, WSTAR, AMU, & + DGNUC, DGACC, DGCOR, & + KNNUC, KNACC,KNCOR, & + PDENSN, PDENSA, PDENSC, & + VSED, VDEP ) + else +! for aerosol dry deposition, no CBLK in VDVG_2 + CALL VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS,k, & + BLKTA, BLKDENS, AER_RES(I,j), USTAR, PBLH,& + ZNTT, RMOLM, AMU, DGNUC, DGACC, DGCOR,XLM,& + KNNUC, KNACC,KNCOR, & + PDENSN, PDENSA, PDENSC, & + VSED, VDEP ) + endif + + VGSA(i, j, VSO4AJ ) = VDEP(1, VDMACC ) + VGSA(i, j, VSO4AI ) = VDEP(1, VDMNUC ) + VGSA(i, j, VNH4AJ ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VNH4AI ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VNO3AJ ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VNO3AI ) = VGSA(i, j, VSO4AI ) + + if (p_naai >= param_first_scalar) VGSA(i, j, VNAAI ) = VGSA(i, j, VSO4AI ) + if (p_naaj >= param_first_scalar) VGSA(i, j, VNAAJ ) = VGSA(i, j, VSO4AJ ) + if (p_clai >= param_first_scalar) VGSA(i, j, VCLAI ) = VGSA(i, j, VSO4AI ) + if (p_claj >= param_first_scalar) VGSA(i, j, VCLAJ ) = VGSA(i, j, VSO4AJ ) + + VGSA(i, j, VASOA1J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VASOA1I ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VASOA2J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VASOA2I ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VASOA3J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VASOA3I ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VASOA4J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VASOA4I ) = VGSA(i, j, VSO4AI ) + + VGSA(i, j, VBSOA1J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VBSOA1I ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VBSOA2J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VBSOA2I ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VBSOA3J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VBSOA3I ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VBSOA4J ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VBSOA4I ) = VGSA(i, j, VSO4AI ) + !---------------------------------------------------------------------- + +! VGSA(i, j, VORGARO1J) = VGSA(i, j, VSO4AJ ) +! VGSA(i, j, VORGARO1I) = VGSA(i, j, VSO4AI ) +! VGSA(i, j, VORGARO2J) = VGSA(i, j, VSO4AJ ) +! VGSA(i, j, VORGARO2I) = VGSA(i, j, VSO4AI ) +! VGSA(i, j, VORGALK1J) = VGSA(i, j, VSO4AJ ) +! VGSA(i, j, VORGALK1I) = VGSA(i, j, VSO4AI ) +! VGSA(i, j, VORGOLE1J) = VGSA(i, j, VSO4AJ ) +! VGSA(i, j, VORGOLE1I) = VGSA(i, j, VSO4AI ) +! VGSA(i, j, VORGBA1J ) = VGSA(i, j, VSO4AJ ) +! VGSA(i, j, VORGBA1I ) = VGSA(i, j, VSO4AI ) +! VGSA(i, j, VORGBA2J ) = VGSA(i, j, VSO4AJ ) +! VGSA(i, j, VORGBA2I ) = VGSA(i, j, VSO4AI ) +! VGSA(i, j, VORGBA3J ) = VGSA(i, j, VSO4AJ ) +! VGSA(i, j, VORGBA3I ) = VGSA(i, j, VSO4AI ) +! VGSA(i, j, VORGBA4J ) = VGSA(i, j, VSO4AJ ) +! VGSA(i, j, VORGBA4I ) = VGSA(i, j, VSO4AI ) + + VGSA(i, j, VORGPAJ ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VORGPAI ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VECJ ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VECI ) = VGSA(i, j, VSO4AI ) + VGSA(i, j, VP25AJ ) = VGSA(i, j, VSO4AJ ) + VGSA(i, j, VP25AI ) = VGSA(i, j, VSO4AI ) + + VGSA(i, j, VANTHA ) = VDEP(1, VDMCOR ) + VGSA(i, j, VSEAS ) = VGSA(i, j, VANTHA ) + VGSA(i, j, VSOILA ) = VGSA(i, j, VANTHA ) + VGSA(i, j, VNU0 ) = VDEP(1, VDNNUC ) + VGSA(i, j, VAC0 ) = VDEP(1, VDNACC ) + VGSA(i, j, VCORN ) = VDEP(1, VDNCOR ) + +!KW + if( config_flags%diagnostic_dep == 1) then + ddflx(i,j,p_so4aj)=ddflx(i,j,p_so4aj)+chem(i,k,j,p_so4aj)/alt(i,k,j)*VGSA(i,j,VSO4AJ)*dtstep + ddflx(i,j,p_so4ai)=ddflx(i,j,p_so4ai)+chem(i,k,j,p_so4ai)/alt(i,k,j)*VGSA(i,j,VSO4AI)*dtstep + ddflx(i,j,p_nh4aj)=ddflx(i,j,p_nh4aj)+chem(i,k,j,p_nh4aj)/alt(i,k,j)*VGSA(i,j,VNH4AJ)*dtstep + ddflx(i,j,p_nh4ai)=ddflx(i,j,p_nh4ai)+chem(i,k,j,p_nh4ai)/alt(i,k,j)*VGSA(i,j,VNH4Ai)*dtstep + ddflx(i,j,p_no3aj)=ddflx(i,j,p_no3aj)+chem(i,k,j,p_no3aj)/alt(i,k,j)*VGSA(i,j,VNO3AJ)*dtstep + ddflx(i,j,p_no3ai)=ddflx(i,j,p_no3ai)+chem(i,k,j,p_no3ai)/alt(i,k,j)*VGSA(i,j,VNO3AI)*dtstep + ddflx(i,j,p_asoa1j)=ddflx(i,j,p_asoa1j)+chem(i,k,j,p_asoa1j)/alt(i,k,j)*VGSA(i,j,VASOA1J)*dtstep + ddflx(i,j,p_asoa1i)=ddflx(i,j,p_asoa1i)+chem(i,k,j,p_asoa1i)/alt(i,k,j)*VGSA(i,j,VASOA1I)*dtstep + ddflx(i,j,p_asoa2j)=ddflx(i,j,p_asoa2j)+chem(i,k,j,p_asoa2j)/alt(i,k,j)*VGSA(i,j,VASOA2J)*dtstep + ddflx(i,j,p_asoa2i)=ddflx(i,j,p_asoa2i)+chem(i,k,j,p_asoa2i)/alt(i,k,j)*VGSA(i,j,VASOA2I)*dtstep + ddflx(i,j,p_asoa3j)=ddflx(i,j,p_asoa3j)+chem(i,k,j,p_asoa3j)/alt(i,k,j)*VGSA(i,j,VASOA3J)*dtstep + ddflx(i,j,p_asoa3i)=ddflx(i,j,p_asoa3i)+chem(i,k,j,p_asoa3i)/alt(i,k,j)*VGSA(i,j,VASOA3I)*dtstep + ddflx(i,j,p_asoa4j)=ddflx(i,j,p_asoa4j)+chem(i,k,j,p_asoa4j)/alt(i,k,j)*VGSA(i,j,VASOA4J)*dtstep + ddflx(i,j,p_asoa4i)=ddflx(i,j,p_asoa4i)+chem(i,k,j,p_asoa4i)/alt(i,k,j)*VGSA(i,j,VASOA4I)*dtstep + ddflx(i,j,p_bsoa1j)=ddflx(i,j,p_bsoa1j)+chem(i,k,j,p_bsoa1j)/alt(i,k,j)*VGSA(i,j,VBSOA1J)*dtstep + ddflx(i,j,p_bsoa1i)=ddflx(i,j,p_bsoa1i)+chem(i,k,j,p_bsoa1i)/alt(i,k,j)*VGSA(i,j,VBSOA1I)*dtstep + ddflx(i,j,p_bsoa2j)=ddflx(i,j,p_bsoa2j)+chem(i,k,j,p_bsoa2j)/alt(i,k,j)*VGSA(i,j,VBSOA2J)*dtstep + ddflx(i,j,p_bsoa2i)=ddflx(i,j,p_bsoa2i)+chem(i,k,j,p_bsoa2i)/alt(i,k,j)*VGSA(i,j,VBSOA2I)*dtstep + ddflx(i,j,p_bsoa3j)=ddflx(i,j,p_bsoa3j)+chem(i,k,j,p_bsoa3j)/alt(i,k,j)*VGSA(i,j,VBSOA3J)*dtstep + ddflx(i,j,p_bsoa3i)=ddflx(i,j,p_bsoa3i)+chem(i,k,j,p_bsoa3i)/alt(i,k,j)*VGSA(i,j,VBSOA3I)*dtstep + ddflx(i,j,p_bsoa4j)=ddflx(i,j,p_bsoa4j)+chem(i,k,j,p_bsoa4j)/alt(i,k,j)*VGSA(i,j,VBSOA4J)*dtstep + ddflx(i,j,p_bsoa4i)=ddflx(i,j,p_bsoa4i)+chem(i,k,j,p_bsoa4i)/alt(i,k,j)*VGSA(i,j,VBSOA4I)*dtstep + ddflx(i,j,p_orgpaj)=ddflx(i,j,p_orgpaj)+chem(i,k,j,p_orgpaj)/alt(i,k,j)*VGSA(i,j,VORGPAJ)*dtstep + ddflx(i,j,p_orgpai)=ddflx(i,j,p_orgpai)+chem(i,k,j,p_orgpai)/alt(i,k,j)*VGSA(i,j,VORGPAI)*dtstep + ddflx(i,j,p_ecj)=ddflx(i,j,p_ecj)+chem(i,k,j,p_ecj)/alt(i,k,j)*VGSA(i,j,VECJ)*dtstep + ddflx(i,j,p_eci)=ddflx(i,j,p_eci)+chem(i,k,j,p_eci)/alt(i,k,j)*VGSA(i,j,VECI)*dtstep + ddflx(i,j,p_p25j)=ddflx(i,j,p_p25j)+chem(i,k,j,p_p25j)/alt(i,k,j)*VGSA(i,j,VP25AJ)*dtstep + ddflx(i,j,p_p25i)=ddflx(i,j,p_p25i)+chem(i,k,j,p_p25i)/alt(i,k,j)*VGSA(i,j,VP25AI)*dtstep + ddflx(i,j,p_naaj)=ddflx(i,j,p_naaj)+chem(i,k,j,p_naaj)/alt(i,k,j)*VGSA(i,j,VNAAJ)*dtstep + ddflx(i,j,p_naai)=ddflx(i,j,p_naai)+chem(i,k,j,p_naai)/alt(i,k,j)*VGSA(i,j,VNAAI)*dtstep + ddflx(i,j,p_claj)=ddflx(i,j,p_claj)+chem(i,k,j,p_claj)/alt(i,k,j)*VGSA(i,j,VCLAJ)*dtstep + ddflx(i,j,p_clai)=ddflx(i,j,p_clai)+chem(i,k,j,p_clai)/alt(i,k,j)*VGSA(i,j,VCLAI)*dtstep + ddflx(i,j,p_antha)=ddflx(i,j,p_antha)+chem(i,k,j,p_antha)/alt(i,k,j)*VGSA(i,j,VANTHA)*dtstep + ddflx(i,j,p_seas)=ddflx(i,j,p_seas)+chem(i,k,j,p_seas)/alt(i,k,j)*VGSA(i,j,VSEAS)*dtstep + ddflx(i,j,p_soila)=ddflx(i,j,p_soila)+chem(i,k,j,p_soila)/alt(i,k,j)*VGSA(i,j,VSOILA)*dtstep + ddflx(i,j,p_nu0)=ddflx(i,j,p_nu0)+chem(i,k,j,p_nu0)/alt(i,k,j)*VGSA(i,j,VNU0)*dtstep + ddflx(i,j,p_ac0)=ddflx(i,j,p_ac0)+chem(i,k,j,p_ac0)/alt(i,k,j)*VGSA(i,j,VAC0)*dtstep + ddflx(i,j,p_corn)=ddflx(i,j,p_corn)+chem(i,k,j,p_corn)/alt(i,k,j)*VGSA(i,j,VCORN)*dtstep + end if +!KW +! enddo ! k-loop + 100 continue ! i,j-loop + +END SUBROUTINE sorgam_vbs_depdriver +! /////////////////////////////////////////////////// + + SUBROUTINE actcof(cat,an,gama,molnu,phimult) +! DESCRIPTION: +! This subroutine computes the activity coefficients of (2NH4+,SO4--), +! (NH4+,NO3-),(2H+,SO4--),(H+,NO3-),AND (H+,HSO4-) in aqueous +! multicomponent solution, using Bromley's model and Pitzer's method. + +! REFERENCES: +! Bromley, L.A. (1973) Thermodynamic properties of strong electrolytes +! in aqueous solutions. AIChE J. 19, 313-320. + +! Chan, C.K. R.C. Flagen, & J.H. Seinfeld (1992) Water Activities of +! NH4NO3 / (NH4)2SO4 solutions, Atmos. Environ. (26A): 1661-1673. + +! Clegg, S.L. & P. Brimblecombe (1988) Equilibrium partial pressures +! of strong acids over saline solutions - I HNO3, +! Atmos. Environ. (22): 91-100 + +! Clegg, S.L. & P. Brimblecombe (1990) Equilibrium partial pressures +! and mean activity and osmotic coefficients of 0-100% nitric acid +! as a function of temperature, J. Phys. Chem (94): 5369 - 5380 + +! Pilinis, C. and J.H. Seinfeld (1987) Continued development of a +! general equilibrium model for inorganic multicomponent atmospheric +! aerosols. Atmos. Environ. 21(11), 2453-2466. + +! ARGUMENT DESCRIPTION: +! CAT(1) : conc. of H+ (moles/kg) +! CAT(2) : conc. of NH4+ (moles/kg) +! AN(1) : conc. of SO4-- (moles/kg) +! AN(2) : conc. of NO3- (moles/kg) +! AN(3) : conc. of HSO4- (moles/kg) +! GAMA(2,1) : mean molal ionic activity coeff for (2NH4+,SO4--) +! GAMA(2,2) : (NH4+,NO3-) +! GAMA(2,3) : (NH4+. HSO4-) +! GAMA(1,1) : (2H+,SO4--) +! GAMA(1,2) : (H+,NO3-) +! GAMA(1,3) : (H+,HSO4-) +! MOLNU : the total number of moles of all ions. +! PHIMULT : the multicomponent paractical osmotic coefficient. + +! REVISION HISTORY: +! Who When Detailed description of changes +! --------- -------- ------------------------------------------- +! S.Roselle 7/26/89 Copied parts of routine BROMLY, and began this +! new routine using a method described by Pilini +! and Seinfeld 1987, Atmos. Envirn. 21 pp2453-24 +! S.Roselle 7/30/97 Modified for use in Models-3 +! F.Binkowski 8/7/97 Modified coefficients BETA0, BETA1, CGAMA + +!----------------------------------------------------------------------- +!...........INCLUDES and their descriptions +! INCLUDE SUBST_XSTAT ! M3EXIT status codes +!.................................................................... + +! Normal, successful completion + INTEGER xstat0 + PARAMETER (xstat0=0) +! File I/O error + INTEGER xstat1 + PARAMETER (xstat1=1) +! Execution error + INTEGER xstat2 + PARAMETER (xstat2=2) +! Special error + INTEGER xstat3 + PARAMETER (xstat3=3) + CHARACTER*120 xmsg + +!...........PARAMETERS and their descriptions: +! number of cations + INTEGER ncat + PARAMETER (ncat=2) + +! number of anions + INTEGER nan + PARAMETER (nan=3) + +!...........ARGUMENTS and their descriptions +! tot # moles of all ions + REAL molnu +! multicomponent paractical osmo + REAL phimult + REAL cat(ncat) ! cation conc in moles/kg (input + REAL an(nan) ! anion conc in moles/kg (input) + REAL gama(ncat,nan) +!...........SCRATCH LOCAL VARIABLES and their descriptions: +! mean molal ionic activity coef + CHARACTER*16 & ! driver program name + pname + SAVE pname + +! anion indX + INTEGER ian + + INTEGER icat +! cation indX + + REAL fgama +! ionic strength + REAL i + REAL r + REAL s + REAL ta + REAL tb + REAL tc + REAL texpv + REAL trm +! 2*ionic strength + REAL twoi +! 2*sqrt of ionic strength + REAL twosri + REAL zbar + REAL zbar2 + REAL zot1 +! square root of ionic strength + REAL sri + REAL f2(ncat) + REAL f1(nan) + REAL zp(ncat) ! absolute value of charges of c + REAL zm(nan) ! absolute value of charges of a + REAL bgama(ncat,nan) + REAL x(ncat,nan) + REAL m(ncat,nan) ! molality of each electrolyte + REAL lgama0(ncat,nan) ! binary activity coefficients + REAL y(nan,ncat) + REAL beta0(ncat,nan) ! binary activity coefficient pa + REAL beta1(ncat,nan) ! binary activity coefficient pa + REAL cgama(ncat,nan) ! binary activity coefficient pa + REAL v1(ncat,nan) ! number of cations in electroly + REAL v2(ncat,nan) +! number of anions in electrolyt + DATA zp/1.0, 1.0/ + DATA zm/2.0, 1.0, 1.0/ + DATA xmsg/' '/ + DATA pname/'ACTCOF'/ + +! *** Sources for the coefficients BETA0, BETA1, CGAMA: + +! *** (1,1);(1,3) - Clegg & Brimblecombe (1988) +! *** (2,3) - Pilinis & Seinfeld (1987), cgama different +! *** (1,2) - Clegg & Brimblecombe (1990) +! *** (2,1);(2,2) - Chan, Flagen & Seinfeld (1992) + +! *** now set the basic constants, BETA0, BETA1, CGAMA + + DATA beta0(1,1)/2.98E-2/, beta1(1,1)/0.0/, cgama(1,1)/4.38E-2 / ! 2H+SO4 + DATA beta0(1,2)/1.2556E-1/, beta1(1,2)/2.8778E-1/, cgama(1,2)/ -5.59E-3 / ! HNO3 + DATA beta0(1,3)/2.0651E-1/, beta1(1,3)/5.556E-1/, cgama(1,3)/0.0 / ! H+HSO4 + DATA beta0(2,1)/4.6465E-2/, beta1(2,1)/ -0.54196/,cgama(2,1)/ -1.2683E-3/ ! (NH4)2 + DATA beta0(2,2)/ -7.26224E-3/, beta1(2,2)/ -1.168858/,cgama(2,2)/3.51217E-5/ ! NH4NO3 + DATA beta0(2,3)/4.494E-2/, beta1(2,3)/2.3594E-1/, cgama(2,3)/ -2.962E-3 & + / +! NH4HSO + DATA v1(1,1), v2(1,1)/2.0, 1.0/ ! 2H+SO4- + DATA v1(2,1), v2(2,1)/2.0, 1.0/ ! (NH4)2SO4 + DATA v1(1,2), v2(1,2)/1.0, 1.0/ ! HNO3 + DATA v1(2,2), v2(2,2)/1.0, 1.0/ ! NH4NO3 + DATA v1(1,3), v2(1,3)/1.0, 1.0/ ! H+HSO4- + DATA v1(2,3), v2(2,3)/1.0, 1.0/ +!----------------------------------------------------------------------- +! begin body of subroutine ACTCOF + +!...compute ionic strength +! NH4HSO4 + i = 0.0 + DO icat = 1, ncat + i = i + cat(icat)*zp(icat)*zp(icat) + END DO + + DO ian = 1, nan + i = i + an(ian)*zm(ian)*zm(ian) + END DO + + i = 0.5*i +!...check for problems in the ionic strength + IF (i==0.0) THEN + DO ian = 1, nan + DO icat = 1, ncat + gama(icat,ian) = 0.0 + END DO + END DO + +! xmsg = 'Ionic strength is zero...returning zero activities' +! WRITE (6,*) xmsg + RETURN + + ELSE IF (i<0.0) THEN +! xmsg = 'Ionic strength below zero...negative concentrations' +! CALL wrf_error_fatal ( xmsg ) +! KW + DO ian = 1, nan + DO icat = 1, ncat + gama(icat,ian) = 0.0 + END DO + END DO + xmsg = 'Ionic strength is below zero...returning zero activities' + WRITE (6,*) xmsg + RETURN + END IF + +!...compute some essential expressions + sri = sqrt(i) + twosri = 2.0*sri + twoi = 2.0*i + texpv = 1.0 - exp(-twosri)*(1.0+twosri-twoi) + r = 1.0 + 0.75*i + s = 1.0 + 1.5*i + zot1 = 0.511*sri/(1.0+sri) + +!...Compute binary activity coeffs + fgama = -0.392*((sri/(1.0+1.2*sri)+(2.0/1.2)*alog(1.0+1.2*sri))) + DO icat = 1, ncat + DO ian = 1, nan + + bgama(icat,ian) = 2.0*beta0(icat,ian) + (2.0*beta1(icat,ian)/(4.0*i) & + )*texpv + +!...compute the molality of each electrolyte for given ionic strength + + m(icat,ian) = (cat(icat)**v1(icat,ian)*an(ian)**v2(icat,ian))** & + (1.0/(v1(icat,ian)+v2(icat,ian))) + +!...calculate the binary activity coefficients + + lgama0(icat,ian) = (zp(icat)*zm(ian)*fgama+m(icat,ian)*(2.0*v1(icat, & + ian)*v2(icat,ian)/(v1(icat,ian)+v2(icat,ian))*bgama(icat, & + ian))+m(icat,ian)*m(icat,ian)*(2.0*(v1(icat,ian)* & + v2(icat,ian))**1.5/(v1(icat,ian)+v2(icat,ian))*cgama(icat, & + ian)))/2.302585093 + + END DO + END DO + +!...prepare variables for computing the multicomponent activity coeffs + + DO ian = 1, nan + DO icat = 1, ncat + zbar = (zp(icat)+zm(ian))*0.5 + zbar2 = zbar*zbar + y(ian,icat) = zbar2*an(ian)/i + x(icat,ian) = zbar2*cat(icat)/i + END DO + END DO + + DO ian = 1, nan + f1(ian) = 0.0 + DO icat = 1, ncat + f1(ian) = f1(ian) + x(icat,ian)*lgama0(icat,ian) + & + zot1*zp(icat)*zm(ian)*x(icat,ian) + END DO + END DO + + DO icat = 1, ncat + f2(icat) = 0.0 + DO ian = 1, nan + f2(icat) = f2(icat) + y(ian,icat)*lgama0(icat,ian) + & + zot1*zp(icat)*zm(ian)*y(ian,icat) + END DO + END DO + +!...now calculate the multicomponent activity coefficients + + DO ian = 1, nan + DO icat = 1, ncat + + ta = -zot1*zp(icat)*zm(ian) + tb = zp(icat)*zm(ian)/(zp(icat)+zm(ian)) + tc = (f2(icat)/zp(icat)+f1(ian)/zm(ian)) + trm = ta + tb*tc + + IF (trm>30.0) THEN + gama(icat,ian) = 1.0E+30 +! xmsg = 'Multicomponent activity coefficient is extremely large' +! WRITE (6,*) xmsg + ELSE + gama(icat,ian) = 10.0**trm + END IF + + END DO + END DO + + RETURN +!ia********************************************************************* + END SUBROUTINE actcof + +!ia +!ia AEROSOL DYNAMICS DRIVER ROUTINE * +!ia based on MODELS3 formulation by FZB +!ia Modified by IA in November 97 +!ia +!ia Revision history +!ia When WHO WHAT +!ia ---- ---- ---- +!ia ???? FZB BEGIN +!ia 05/97 IA Adapted for use in CTM2-S +!ia 11/97 IA Modified for new model version +!ia see comments under iarev02 +!ia +!ia Called BY: RPMMOD3 +!ia +!ia Calls to: EQL3, MODPAR, COAGRATE, NUCLCOND, AEROSTEP +!ia GETVSED +!ia +!ia********************************************************************* + +SUBROUTINE aeroproc(blksize,nspcsda,numcells,layer,cblk,dt,blkta,blkprs, & + blkdens,blkrh,so4rat,organt1rat,organt2rat,organt3rat,organt4rat, & + orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,epm25i, & + epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm,amu,dgnuc, & + dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc,knacc, & + kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3,urn00, & + ura00,brna01,c30,deltaso4a,igrid,jgrid,kgrid,brrto) + +!USE module_configure, only: grid_config_rec_type +!TYPE (grid_config_rec_type), INTENT (in) :: config_flags + +! IMPLICIT NONE +! dimension of arrays + INTEGER blksize +! number of species in CBLK + INTEGER nspcsda +! actual number of cells in arrays + INTEGER numcells +! number of k-level + INTEGER layer +! of organic aerosol precursor + INTEGER ldrog_vbs + REAL cblk(blksize,nspcsda) ! main array of variables (INPUT a + + REAL dt +! *** Meteorological information: + +! synchronization time [s] + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkprs(blksize) ! Air pressure in [ Pa ] + REAL blkdens(blksize) ! Air density [ kg/ m**3 ] + REAL blkrh(blksize) +! *** Chemical production rates: [ ug / m**3 s ] + +! Fractional relative humidity + REAL so4rat(blksize) +! sulfate gas-phase production rate +! total # of cond. vapors & SOA species + INTEGER ncv + INTEGER nacv +!bs * organic condensable vapor production rate +! # of anthrop. cond. vapors & SOA speci + REAL drog(blksize,ldrog_vbs) !bs +! *** anthropogenic organic aerosol mass production rates from aromatics +! Delta ROG conc. [ppm] + REAL organt1rat(blksize) + +! *** anthropogenic organic aerosol mass production rates from aromatics + REAL organt2rat(blksize) + +! *** anthropogenic organic aerosol mass production rates from alkanes & + REAL organt3rat(blksize) + +! *** anthropogenic organic aerosol mass production rates from alkenes & + REAL organt4rat(blksize) + +! *** biogenic organic aerosol production rates + REAL orgbio1rat(blksize) + +! *** biogenic organic aerosol production rates + REAL orgbio2rat(blksize) + +! *** biogenic organic aerosol production rates + REAL orgbio3rat(blksize) + +! *** biogenic organic aerosol production rates + REAL orgbio4rat(blksize) + +! *** Primary emissions rates: [ ug / m**3 s ] +! *** emissions rates for unidentified PM2.5 mass + REAL epm25i(blksize) ! Aitken mode + REAL epm25j(blksize) +! *** emissions rates for primary organic aerosol +! Accumululaton mode + REAL eorgi(blksize) ! Aitken mode + REAL eorgj(blksize) +! *** emissions rates for elemental carbon +! Accumululaton mode + REAL eeci(blksize) ! Aitken mode + REAL eecj(blksize) +! *** emissions rates for coarse mode particles +! Accumululaton mode + REAL esoil(blksize) ! soil derived coarse aerosols + REAL eseas(blksize) ! marine coarse aerosols + REAL epmcoarse(blksize) + +! *** OUTPUT: +! *** atmospheric properties +! anthropogenic coarse aerosols + REAL xlm(blksize) ! atmospheric mean free path [ m ] + REAL amu(blksize) +! *** modal diameters: [ m ] + +! atmospheric dynamic viscosity [ kg + REAL dgnuc(blksize) ! nuclei mode geometric mean diamete + REAL dgacc(blksize) ! accumulation geometric mean diamet + REAL dgcor(blksize) + +! *** aerosol properties: +! *** Modal mass concentrations [ ug m**3 ] +! coarse mode geometric mean diamete + REAL pmassn(blksize) ! mass concentration in Aitken mode + REAL pmassa(blksize) ! mass concentration in accumulation + REAL pmassc(blksize) +! *** average modal particle densities [ kg/m**3 ] + +! mass concentration in coarse mode + REAL pdensn(blksize) ! average particle density in nuclei + REAL pdensa(blksize) ! average particle density in accumu + REAL pdensc(blksize) +! *** average modal Knudsen numbers + +! average particle density in coarse + REAL knnuc(blksize) ! nuclei mode Knudsen number + REAL knacc(blksize) ! accumulation Knudsen number + REAL kncor(blksize) +! *** modal condensation factors ( see comments in NUCLCOND ) + +! coarse mode Knudsen number + REAL fconcn(blksize) + REAL fconca(blksize) +!bs + REAL fconcn_org(blksize) + REAL fconca_org(blksize) +!bs + +! *** Rates for secondary particle formation: + +! *** production of new mass concentration [ ug/m**3 s ] + REAL dmdt(blksize) ! by particle formation + +! *** production of new number concentration [ number/m**3 s ] + +! rate of production of new mass concen + REAL dndt(blksize) ! by particle formation + +! *** growth rate for third moment by condensation of precursor +! vapor on existing particles [ 3rd mom/m**3 s ] + +! rate of producton of new particle num + REAL cgrn3(blksize) ! Aitken mode + REAL cgra3(blksize) +! *** Rates for coaglulation: [ m**3/s ] + +! *** Unimodal Rates: + +! Accumulation mode + REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra + REAL ura00(blksize) + +! *** Bimodal Rates: Aitken mode with accumulation mode ( d( Aitken mod + +! accumulation mode 0th moment self-coagulat + REAL brna01(blksize) +! *** 3rd moment intermodal transfer rate replaces coagulation rate ( FS +! rate for 0th moment + REAL c30(blksize) ! by intermodal c + REAL brrto + +! *** other processes + +! intermodal 3rd moment transfer r + REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u + +! INTEGER NN, VV ! loop indICES +! increment of concentration added to + +! ////////////////////// Begin code /////////////////////////////////// +! concentration lower limit + CHARACTER*16 pname + PARAMETER (pname=' AEROPROC ') + + INTEGER unit + PARAMETER (unit=20) + integer igrid,jgrid,kgrid,isorop +!KW isorop=0 +!KW Originally isorop=0 but changed isorop=1 + isorop=1 + +! *** get water, ammonium and nitrate content: +! for now, don't call if temp is below -40C (humidity +! for this wrf version is already limited to 10 percent) + + if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.1)then + CALL eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid) + else if (blkta(1).ge.233.15.and.blkrh(1).ge.0.1 .and. isorop.eq.0)then + CALL eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh) + endif + +! *** get size distribution information: + + CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, & + pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, & + kncor) + +! *** Calculate coagulation rates for fine particles: + + CALL coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, & + dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30) + +! *** get condensation and particle formation (nucleation) rates: + + CALL nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs,blkrh, & + so4rat,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat, & + orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,dgnuc,dgacc, & + fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3,igrid,jgrid,kgrid,brrto) + +! *** advance forward in time DT seconds: + CALL aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat,organt1rat, & + organt2rat,organt3rat,organt4rat,orgbio1rat,orgbio2rat,orgbio3rat, & + orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas,epmcoarse, & + dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn,pmassa,pmassc, & + dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3,igrid,jgrid,kgrid) + +! *** get new distribution information: + CALL modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn,pmassa, & + pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc,knacc, & + kncor) + + RETURN + END SUBROUTINE aeroproc +!////////////////////////////////////////////////////////////////// + +! *** Time stepping code advances the aerosol moments one timestep; + SUBROUTINE aerostep(layer,blksize,nspcsda,numcells,cblk,dt,so4rat & + ,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat,orgbio2rat & + ,orgbio3rat,orgbio4rat,epm25i,epm25j,eorgi,eorgj,eeci,eecj,esoil,eseas & + ,epmcoarse,dgnuc,dgacc,fconcn,fconca,fconcn_org,fconca_org,pmassn & + ,pmassa,pmassc,dmdt,dndt,deltaso4a,urn00,ura00,brna01,c30,cgrn3,cgra3, & + igrid,jgrid,kgrid) + +! *** DESCRIPTION: Integrate the Number and Mass equations +! for each mode over the time interval DT. +! PRECONDITIONS: +! AEROSTEP() must follow calls to all other dynamics routines. + +! *** Revision history: +! Adapted 3/95 by UAS and CJC from EAM2's code. +! Revised 7/29/96 by FSB to use block structure +! Revised 11/15/96 by FSB dropped flow-through and cast +! number solver into Riccati equation form. +! Revised 8/8/97 by FSB to have mass in Aitken and accumulation mode +! each predicted rather than total mass and +! Aitken mode mass. Also used a local approximation +! the error function. Also added coarse mode. +! Revised 9/18/97 by FSB to fix mass transfer from Aitken to +! accumulation mode by coagulation +! Revised 10/27/97 by FSB to modify code to use primay emissions +! and to correct 3rd moment updates. +! Also added coarse mode. +! Revised 11/4/97 by FSB to fix error in other anthropogenic PM2.5 +! Revised 11/5/97 by FSB to fix error in MSTRNSFR +! Revised 11/6/97 FSB to correct the expression for FACTRANS to +! remove the 6/pi coefficient. UAS found this. +! Revised 12/15/97 by FSB to change equations for mass concentratin +! to a chemical production form with analytic +! solutions for the Aitken mode and to remove +! time stepping of the 3rd moments. The mass concentration +! in the accumulation mode is updated with a forward +! Eulerian step. +! Revised 1/6/98 by FSB Lowered minimum concentration for +! sulfate aerosol to 0.1 [ ng / m**3 ]. +! Revised 1/12/98 C30 replaces BRNA31 as a variable. C30 represents +! intermodal transfer rate of 3rd moment in place +! of 3rd moment coagulation rate. +! Revised 5/5/98 added new renaming criterion based on diameters +! Added 3/23/98 by BS condensational groth factors for organics + +!********************************************************************** +! IMPLICIT NONE + +! *** ARGUMENTS: + +! dimension of arrays + INTEGER blksize +! actual number of cells in arrays + INTEGER numcells +! nmber of species in CBLK + INTEGER nspcsda +! model layer + INTEGER layer + REAL cblk(blksize,nspcsda) ! main array of variables + INTEGER igrid,jgrid,kgrid + REAL dt +! *** Chemical production rates: [ ug / m**3 s ] + +! time step [sec] + REAL so4rat(blksize) ! sulfate gas-phase production rate + +! anthropogenic organic aerosol mass production rates + REAL organt1rat(blksize) + REAL organt2rat(blksize) + REAL organt3rat(blksize) + REAL organt4rat(blksize) + +! biogenic organic aerosol production rates + REAL orgbio1rat(blksize) + REAL orgbio2rat(blksize) + REAL orgbio3rat(blksize) + REAL orgbio4rat(blksize) + +! *** Primary emissions rates: [ ug / m**3 s ] +! *** emissions rates for unidentified PM2.5 mass + REAL epm25i(blksize) ! Aitken mode + REAL epm25j(blksize) +! *** emissions rates for primary organic aerosol +! Accumululaton mode + REAL eorgi(blksize) ! Aitken mode + REAL eorgj(blksize) +! *** emissions rates for elemental carbon +! Accumululaton mode + REAL eeci(blksize) ! Aitken mode + REAL eecj(blksize) +! *** emissions rates for coarse mode particles +! Accumululaton mode + REAL esoil(blksize) ! soil derived coarse aerosols + REAL eseas(blksize) ! marine coarse aerosols + REAL epmcoarse(blksize) +! anthropogenic coarse aerosols + REAL dgnuc(blksize) ! nuclei mode mean diameter [ m ] + REAL dgacc(blksize) +! accumulation + REAL fconcn(blksize) ! Aitken mode [ 1 / s ] +! reciprocal condensation rate + REAL fconca(blksize) ! acclumulation mode [ 1 / s ] +! reciprocal condensation rate + REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ] +! reciprocal condensation rate for organ + REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ] +! reciprocal condensation rate for organ + REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ] +! rate of production of new mass concent + REAL dndt(blksize) ! by particle formation [ number/m**3 /s +! rate of producton of new particle numb + REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m +! increment of concentration added to + REAL urn00(blksize) ! Aitken intramodal coagulation rate + REAL ura00(blksize) ! Accumulation mode intramodal coagulati + REAL brna01(blksize) ! bimodal coagulation rate for number + REAL c30(blksize) ! by intermodal coagulation +! intermodal 3rd moment transfer rate by + REAL cgrn3(blksize) ! growth rate for 3rd moment for Aitken + REAL cgra3(blksize) +! *** Modal mass concentrations [ ug m**3 ] + +! growth rate for 3rd moment for Accumul + REAL pmassn(blksize) ! mass concentration in Aitken mode + REAL pmassa(blksize) ! mass concentration in accumulation + REAL pmassc(blksize) + +! *** Local Variables + +! mass concentration in coarse mode + INTEGER l, lcell, spc +! ** following scratch variables are used for solvers + +! *** variables needed for modal dynamics solvers: +! Loop indices + REAL*8 a, b, c + REAL*8 m1, m2, y0, y + REAL*8 dhat, p, pexpdt, expdt + REAL*8 loss, prod, pol, lossinv +! mass intermodal transfer by coagulation + REAL mstrnsfr + + REAL factrans + +! *** CODE additions for renaming + REAL getaf2 + REAL aaa, xnum, xm3, fnum, fm3, phnum, phm3 ! Defined below + REAL erf, & ! Error and complementary error function + erfc + + REAL xx +! dummy argument for ERF and ERFC +! a numerical value for a minimum concentration + +! *** This value is smaller than any reported tropospheric concentration + +! *** Statement function given for error function. Source is +! Meng, Z., and J.H.Seinfeld (1994) On the source of the submicromet +! droplet mode of urban and regional aerosols. Aerosol Sci. and Tec +! 20:253-265. They cite Reasearch & Education Asociation (REA), (19 +! Handbook of Mathematical, Scientific, and Engineering Formulas, +! Tables, Functions, Graphs, Transforms: REA, Piscataway, NJ. p. 49 + + erf(xx) = sqrt(1.0-exp(-4.0*xx*xx/pirs)) + erfc(xx) = 1.0 - erf(xx) +! :::::::::::::::::::::::::::::::::::::::: + +! ///// begin code +! *** set up time-step integration + + DO l = 1, numcells + +! *** code to move number forward by one time step. +! *** solves the Ricatti equation: + +! dY/dt = C - A * Y ** 2 - B * Y + +! Coded 11/21/96 by Dr. Francis S. Binkowski + +! *** Aitken mode: +! *** coefficients + a = urn00(l) + b = brna01(l)*cblk(l,vac0) + c = dndt(l) + factnumn*(anthfac*(epm25i(l)+eeci(l))+orgfac*eorgi(l)) + +! includes primary emissions + y0 = cblk(l,vnu0) +! *** trap on C = 0 + +! initial condition + IF (c>0.0D0) THEN + + dhat = sqrt(b*b+4.0D0*a*c) + + m1 = 2.0D0*a*c/(b+dhat) + + m2 = -0.5D0*(b+dhat) + + p = -(m1-a*y0)/(m2-a*y0) + + pexpdt = p*exp(-dhat*dt) + + y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt)) +! solution + ELSE + +! *** rearrange solution for NUMERICAL stability +! note If B << A * Y0, the following form, although +! seemingly awkward gives the correct answer. + + expdt = exp(-b*dt) + IF (expdt<1.0D0) THEN + y = b*y0*expdt/(b+a*y0*(1.0D0-expdt)) + ELSE + y = y0 + END IF + + END IF +! if(y.lt.nummin_i)then +! print *,'a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l)' +! print *,'igrid,jgrid,kgrid = ',igrid,jgrid,kgrid +! print *,a,b,y,y0,c,cblk(l,vnu0),dt,dndt(l),brna01(l),epm25i(l),eeci(l),eorgi(l) +! endif + + cblk(l,vnu0) = max(nummin_i,y) + +! *** now do accumulation mode number + +! *** coefficients + +! update + a = ura00(l) + b = & ! NOTE B = 0.0 + 0.0D0 + c = factnuma*(anthfac*(epm25j(l)+eecj(l))+orgfac*eorgj(l)) +! includes primary emissi + y0 = cblk(l,vac0) +! *** this equation requires special handling, because C can be zero. +! if this happens, the form of the equation is different: + +! initial condition +! print *,vac0,y0,c,nummin_j,a + IF (c>0.0D0) THEN + + dhat = sqrt(4.0D0*a*c) + + m1 = 2.0D0*a*c/dhat + + m2 = -0.5D0*dhat + + p = -(m1-a*y0)/(m2-a*y0) + +! print *,p,-dhat,dt,-dhat*dt +! print *,exp(-dhat*dt) + pexpdt = p*exp(-dhat*dt) + + y = (m1+m2*pexpdt)/(a*(1.0D0+pexpdt)) +! solution + ELSE + + y = y0/(1.0D0+dt*a*y0) +! print *,dhat,y0,dt,a + y = y0/(1.+dt*a*y0) +! print *,y +! correct solution to equation + END IF + + cblk(l,vac0) = max(nummin_j,y) +! *** now do coarse mode number neglecting coagulation +! update +! print *,soilfac,seasfac,anthfac,esoil(l),eseas(l),epmcoarse(l) + prod = soilfac*esoil(l) + seasfac*eseas(l) + anthfac*epmcoarse(l) + +! print *,cblk(l,vcorn),factnumc,prod + cblk(l,vcorn) = cblk(l,vcorn) + factnumc*prod*dt + +! *** Prepare to advance modal mass concentration one time step. + +! *** Set up production and and intermodal transfer terms terms: +! print *,cgrn3(l),epm25i(l),eeci(l),orgfac,eorgi(l) + cgrn3(l) = cgrn3(l) + anthfac*(epm25i(l)+eeci(l)) + orgfac*eorgi(l) + +! includes growth from pri + cgra3(l) = cgra3(l) + c30(l) + anthfac*(epm25j(l)+eecj(l)) + & + orgfac*eorgj(l) ! and transfer of 3rd momen + ! intermodal coagulation + +! *** set up transfer coefficients for coagulation between Aitken and ac + + +! *** set up special factors for mass transfer from the Aitken to accumulation +! intermodal coagulation. The mass transfer rate is proportional to +! transfer rate, C30. The proportionality factor is p/6 times the the +! density. The average particle density for a species is the species +! divided by the particle volume concentration, pi/6 times the 3rd m +! The p/6 coefficients cancel. + +! includes growth from prim +! print *,'loss',vnu3,c30(l),cblk(l,vnu3) + loss = c30(l)/cblk(l,vnu3) + +! Normalized coagulation transfer r + factrans = loss*dt ! yields an estimate of the amount of mass t + ! the Aitken to the accumulation mode in the + +! Multiplying this factor by the species con +! print *,'factrans = ',factrans,loss + expdt = exp(-factrans) ! decay term is common to all Aitken mode +! print *,'factrans = ',factrans,loss,expdt +! variable name is re-used here. This expo + lossinv = 1.0/loss +! *** now advance mass concentrations one time step. + +! *** update sulfuric acid vapor concentration by removing mass concent +! condensed sulfate and newly produced particles. +! *** The method follows Youngblood and Kreidenweis, Further Development +! of a Bimodal Aerosol Dynamics Model, Colorado State University Dep +! Atmospheric Science Paper Number 550, April,1994, pp 85-89. +! set up for multiplication rather than divi + cblk(l,vsulf) = max(conmin,cblk(l,vsulf)-(deltaso4a(l)+dmdt(l)*dt)) + +! *** Solve Aitken-mode equations of form: dc/dt = P - L*c +! *** Solution is: c(t0 + dt) = p/L + ( c(0) - P/L ) * exp(-L*dt) + +! *** sulfate: + mstrnsfr = cblk(l,vso4ai)*factrans + prod = deltaso4a(l)*fconcn(l)/dt + dmdt(l) ! Condensed mass + + pol = prod*lossinv +! print *,'pol = ',prod,lossinv,deltaso4a(l),cblk(l,vso4ai),dmdt(l),mstrnsfr + + cblk(l,vso4ai) = pol + (cblk(l,vso4ai)-pol)*expdt + cblk(l,vso4ai) = max(aeroconcmin,cblk(l,vso4ai)) + cblk(l,vso4aj) = cblk(l,vso4aj) + deltaso4a(l)*fconca(l) + mstrnsfr + +! *** anthropogenic secondary organic: +!bs * anthropogenic secondary organics from aromatic precursors +!!! anthropogenic secondary organics from different precursors +!!! the formulas are the same as in BS's version, only precursors and partition are different! + + mstrnsfr = cblk(l,vasoa1i)*factrans + prod = organt1rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vasoa1i) = pol + (cblk(l,vasoa1i)-pol)*expdt + cblk(l,vasoa1i) = max(conmin,cblk(l,vasoa1i)) + cblk(l,vasoa1j) = cblk(l,vasoa1j) + organt1rat(l)*fconca_org(l)*dt + mstrnsfr + !!!!!!!!!!!!! + + mstrnsfr = cblk(l,vasoa2i)*factrans + prod = organt2rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vasoa2i) = pol + (cblk(l,vasoa2i)-pol)*expdt + cblk(l,vasoa2i) = max(conmin,cblk(l,vasoa2i)) + cblk(l,vasoa2j) = cblk(l,vasoa2j) + organt2rat(l)*fconca_org(l)*dt + mstrnsfr + !!!!!!!!!!!!! + + mstrnsfr = cblk(l,vasoa3i)*factrans + prod = organt3rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vasoa3i) = pol + (cblk(l,vasoa3i)-pol)*expdt + cblk(l,vasoa3i) = max(conmin,cblk(l,vasoa3i)) + cblk(l,vasoa3j) = cblk(l,vasoa3j) + organt3rat(l)*fconca_org(l)*dt + mstrnsfr + !!!!!!!!!!!!! + + mstrnsfr = cblk(l,vasoa4i)*factrans + prod = organt4rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vasoa4i) = pol + (cblk(l,vasoa4i)-pol)*expdt + cblk(l,vasoa4i) = max(conmin,cblk(l,vasoa4i)) + cblk(l,vasoa4j) = cblk(l,vasoa4j) + organt4rat(l)*fconca_org(l)*dt + mstrnsfr + +! *** biogenic secondary organic + mstrnsfr = cblk(l,vbsoa1i)*factrans + prod = orgbio1rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vbsoa1i) = pol + (cblk(l,vbsoa1i)-pol)*expdt + cblk(l,vbsoa1i) = max(conmin,cblk(l,vbsoa1i)) + cblk(l,vbsoa1j) = cblk(l,vbsoa1j) + orgbio1rat(l)*fconca_org(l)*dt + mstrnsfr + !!!!!!!!!!!!! + + mstrnsfr = cblk(l,vbsoa2i)*factrans + prod = orgbio2rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vbsoa2i) = pol + (cblk(l,vbsoa2i)-pol)*expdt + cblk(l,vbsoa2i) = max(conmin,cblk(l,vbsoa2i)) + cblk(l,vbsoa2j) = cblk(l,vbsoa2j) + orgbio2rat(l)*fconca_org(l)*dt + mstrnsfr + !!!!!!!!!!!!! + + mstrnsfr = cblk(l,vbsoa3i)*factrans + prod = orgbio3rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vbsoa3i) = pol + (cblk(l,vbsoa3i)-pol)*expdt + cblk(l,vbsoa3i) = max(conmin,cblk(l,vbsoa3i)) + cblk(l,vbsoa3j) = cblk(l,vbsoa3j) + orgbio3rat(l)*fconca_org(l)*dt + mstrnsfr + !!!!!!!!!!!!! + + mstrnsfr = cblk(l,vbsoa4i)*factrans + prod = orgbio4rat(l)*fconcn_org(l) + pol = prod*lossinv + + cblk(l,vbsoa4i) = pol + (cblk(l,vbsoa4i)-pol)*expdt + cblk(l,vbsoa4i) = max(conmin,cblk(l,vbsoa4i)) + cblk(l,vbsoa4j) = cblk(l,vbsoa4j) + orgbio4rat(l)*fconca_org(l)*dt + mstrnsfr + +! *** primary anthropogenic organic + mstrnsfr = cblk(l,vorgpai)*factrans + prod = eorgi(l) + pol = prod*lossinv + + cblk(l,vorgpai) = pol + (cblk(l,vorgpai)-pol)*expdt + cblk(l,vorgpai) = max(conmin,cblk(l,vorgpai)) + cblk(l,vorgpaj) = cblk(l,vorgpaj) + eorgj(l)*dt + mstrnsfr + +! *** other anthropogenic PM2.5 + mstrnsfr = cblk(l,vp25ai)*factrans + prod = epm25i(l) + pol = prod*lossinv + + cblk(l,vp25ai) = pol + (cblk(l,vp25ai)-pol)*expdt + cblk(l,vp25ai) = max(conmin,cblk(l,vp25ai)) + cblk(l,vp25aj) = cblk(l,vp25aj) + epm25j(l)*dt + mstrnsfr + +! *** elemental carbon + mstrnsfr = cblk(l,veci)*factrans + prod = eeci(l) + pol = prod*lossinv + + cblk(l,veci) = pol + (cblk(l,veci)-pol)*expdt + cblk(l,veci) = max(conmin,cblk(l,veci)) + cblk(l,vecj) = cblk(l,vecj) + eecj(l)*dt + mstrnsfr + +! *** coarse mode +! *** soil dust + cblk(l,vsoila) = cblk(l,vsoila) + esoil(l)*dt + cblk(l,vsoila) = max(conmin,cblk(l,vsoila)) + +! *** sea salt + cblk(l,vseas) = cblk(l,vseas) + eseas(l)*dt + cblk(l,vseas) = max(conmin,cblk(l,vseas)) + +! *** anthropogenic PM10 coarse fraction + cblk(l,vantha) = cblk(l,vantha) + epmcoarse(l)*dt + cblk(l,vantha) = max(conmin,cblk(l,vantha)) + + END DO + + +! *** Check for mode merging,if Aitken mode is growing faster than j-mod +! then merge modes by renaming. + +! *** use Binkowski-Kreidenweis paradigm, now including emissions + +! end of time-step loop for total mass + DO lcell = 1, numcells + +! IF( CGRN3(LCELL) .GT. CGRA3(LCELL) .AND. +! & CBLK(LCELL,VNU0) .GT. CBLK(LCELL,VAC0) ) THEN ! check if mer + IF (cgrn3(lcell)>cgra3(lcell) .OR. dgnuc(lcell)>.03E-6 .AND. cblk( & + lcell,vnu0)>cblk(lcell,vac0)) & + THEN + +! check if mer + aaa = getaf(cblk(lcell,vnu0),cblk(lcell,vac0),dgnuc(lcell), & + dgacc(lcell),xxlsgn,xxlsga,sqrt2) + +! *** AAA is the value of ln( dd / DGNUC ) / ( SQRT2 * XXLSGN ), where +! dd is the diameter at which the Aitken-mode and accumulation-mo +! distributions intersect (overap). + + xnum = max(aaa,xxm3) ! this means that no more than one ha + ! total Aitken mode number may be tra per call. + +! do not let XNUM become negative bec + xm3 = xnum - & + xxm3 +! set up for 3rd moment and mass tran + IF (xm3>0.0) & + THEN +! do mode merging if overlap is corr + phnum = 0.5*(1.0+erf(xnum)) + phm3 = 0.5*(1.0+erf(xm3)) + fnum = 0.5*erfc(xnum) + fm3 = 0.5*erfc(xm3) + +! In the Aitken mode: + +! *** FNUM and FM3 are the fractions of the number and 3rd moment +! distributions with diameters greater than dd respectively. + +! *** PHNUM and PHM3 are the fractions of the number and 3rd moment +! distributions with diameters less than dd. + +! *** rename the Aitken mode particle number as accumulation mode +! particle number + + cblk(lcell,vac0) = cblk(lcell,vac0) + fnum*cblk(lcell,vnu0) + +! *** adjust the Aitken mode number + + cblk(lcell,vnu0) = phnum*cblk(lcell,vnu0) + +! *** Rename mass from Aitken mode to acumulation mode. The mass transfe +! to the accumulation mode is proportional to the amount of 3rd mome +! transferred, therefore FM3 is used for mass transfer. + + cblk(lcell,vso4aj) = cblk(lcell,vso4aj) + cblk(lcell,vso4ai)*fm3 + + cblk(lcell,vnh4aj) = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai)*fm3 + + cblk(lcell,vno3aj) = cblk(lcell,vno3aj) + cblk(lcell,vno3ai)*fm3 + + cblk(lcell,vasoa1j) = cblk(lcell,vasoa1j) + cblk(lcell,vasoa1i)*fm3 + + cblk(lcell,vasoa2j) = cblk(lcell,vasoa2j) + cblk(lcell,vasoa2i)*fm3 + + cblk(lcell,vasoa3j) = cblk(lcell,vasoa3j) + cblk(lcell,vasoa3i)*fm3 + + cblk(lcell,vasoa4j) = cblk(lcell,vasoa4j) + cblk(lcell,vasoa4i)*fm3 + + cblk(lcell,vbsoa1j) = cblk(lcell,vbsoa1j) + cblk(lcell,vbsoa1i)*fm3 + + cblk(lcell,vbsoa2j) = cblk(lcell,vbsoa2j) + cblk(lcell,vbsoa2i)*fm3 + + cblk(lcell,vbsoa3j) = cblk(lcell,vbsoa3j) + cblk(lcell,vbsoa3i)*fm3 + + cblk(lcell,vbsoa4j) = cblk(lcell,vbsoa4j) + cblk(lcell,vbsoa4i)*fm3 + + cblk(lcell,vorgpaj) = cblk(lcell,vorgpaj) + cblk(lcell,vorgpai)*fm3 + + cblk(lcell,vp25aj) = cblk(lcell,vp25aj) + cblk(lcell,vp25ai)*fm3 + + cblk(lcell,vecj) = cblk(lcell,vecj) + cblk(lcell,veci)*fm3 + +! *** update Aitken mode for mass loss to accumulation mode + cblk(lcell,vso4ai) = cblk(lcell,vso4ai)*phm3 + + cblk(lcell,vnh4ai) = cblk(lcell,vnh4ai)*phm3 + + cblk(lcell,vno3ai) = cblk(lcell,vno3ai)*phm3 + + cblk(lcell,vasoa1i) = cblk(lcell,vasoa1i)*phm3 + + cblk(lcell,vasoa2i) = cblk(lcell,vasoa2i)*phm3 + + cblk(lcell,vasoa3i) = cblk(lcell,vasoa3i)*phm3 + + cblk(lcell,vasoa4i) = cblk(lcell,vasoa4i)*phm3 + + cblk(lcell,vbsoa1i) = cblk(lcell,vbsoa1i)*phm3 + + cblk(lcell,vbsoa2i) = cblk(lcell,vbsoa2i)*phm3 + + cblk(lcell,vbsoa3i) = cblk(lcell,vbsoa3i)*phm3 + + cblk(lcell,vbsoa4i) = cblk(lcell,vbsoa4i)*phm3 + + cblk(lcell,vorgpai) = cblk(lcell,vorgpai)*phm3 + + cblk(lcell,vp25ai) = cblk(lcell,vp25ai)*phm3 + + cblk(lcell,veci) = cblk(lcell,veci)*phm3 + + END IF +! end check on whether modal overlap is OK + + END IF +! end check on necessity for merging + +END DO +! set min value for all concentrations + +! loop for merging + DO spc = 1, nspcsda + DO lcell = 1, numcells + cblk(lcell,spc) = max(cblk(lcell,spc),conmin) + END DO + END DO +!--------------------------------------------------------------------------------- + +RETURN +END SUBROUTINE aerostep +!####################################################################### + +SUBROUTINE awater(irhx,mso4,mnh4,mno3,wh2o) +! NOTE!!! wh2o is returned in micrograms / cubic meter +! mso4,mnh4,mno3 are in microMOLES / cubic meter + +! This version uses polynomials rather than tables, and uses empirical +! polynomials for the mass fraction of solute (mfs) as a function of wat +! where: + +! mfs = ms / ( ms + mw) +! ms is the mass of solute +! mw is the mass of water. + +! Define y = mw/ ms + +! then mfs = 1 / (1 + y) + +! y can then be obtained from the values of mfs as + +! y = (1 - mfs) / mfs + + +! the aerosol is assumed to be in a metastable state if the rh is +! is below the rh of deliquescence, but above the rh of crystallizat + +! ZSR interpolation is used for sulfates with x ( the molar ratio of +! ammonium to sulfate in eh range 0 <= x <= 2, by sections. +! section 1: 0 <= x < 1 +! section 2: 1 <= x < 1.5 +! section 3: 1.5 <= x < 2.0 +! section 4: 2 <= x +! In sections 1 through 3, only the sulfates can affect the amount o +! on the particles. +! In section 4, we have fully neutralized sulfate, and extra ammoniu +! allows more nitrate to be present. Thus, the ammount of water is c +! using ZSR for ammonium sulfate and ammonium nitrate. Crystallizati +! assumed to occur in sections 2,3,and 4. See detailed discussion be + +! definitions: +! mso4, mnh4, and mno3 are the number of micromoles/(cubic meter of +! for sulfate, ammonium, and nitrate respectively +! irhx is the relative humidity (%) +! wh2o is the returned water amount in micrograms / cubic meter of a +! x is the molar ratio of ammonium to sulfate +! y0,y1,y1.5, y2 are the water contents in mass of water/mass of sol +! for pure aqueous solutions with x equal 1, 1.5, and 2 respectively +! y3 is the value of the mass ratio of water to solute for +! a pure ammonium nitrate solution. + +!coded by Dr. Francis S. Binkowski, 4/8/96. + +! IMPLICIT NONE + INTEGER irhx, irh + REAL mso4, mnh4, mno3 + REAL tso4, tnh4, tno3, wh2o, x + REAL aw, awc +! REAL poly4, poly6 + REAL mfs0, mfs1, mfs15, mfs2 + REAL c0(4), c1(4), c15(4), c2(4) + REAL y, y0, y1, y15, y2, y3, y40, y140, y1540, yc + REAL kso4(6), kno3(6), mfsso4, mfsno3 + REAL mwso4, mwnh4, mwno3, mw2, mwano3 + +! *** molecular weights: + PARAMETER (mwso4=96.0636,mwnh4=18.0985,mwno3=62.0049, & + mw2=mwso4+2.0*mwnh4,mwano3=mwno3+mwnh4) + +! The polynomials use data for aw as a function of mfs from Tang and +! Munkelwitz, JGR 99: 18801-18808, 1994. +! The polynomials were fit to Tang's values of water activity as a +! function of mfs. + +! *** coefficients of polynomials fit to Tang and Munkelwitz data +! now give mfs as a function of water activity. + + DATA c1/0.9995178, -0.7952896, 0.99683673, -1.143874/ + DATA c15/1.697092, -4.045936, 5.833688, -3.463783/ + DATA c2/2.085067, -6.024139, 8.967967, -5.002934/ + +! *** the following coefficients are a fit to the data in Table 1 of +! Nair & Vohra, J. Aerosol Sci., 6: 265-271, 1975 +! data c0/0.8258941, -1.899205, 3.296905, -2.214749 / +! *** New data fit to data from +! Nair and Vohra J. Aerosol Sci., 6: 265-271, 1975 +! Giaque et al. J.Am. Chem. Soc., 82: 62-70, 1960 +! Zeleznik J. Phys. Chem. Ref. Data, 20: 157-1200 + DATA c0/0.798079, -1.574367, 2.536686, -1.735297/ + +! *** polynomials for ammonium nitrate and ammonium sulfate are from: +! Chan et al.1992, Atmospheric Environment (26A): 1661-1673. + + DATA kno3/0.2906, 6.83665, -26.9093, 46.6983, -38.803, 11.8837/ + DATA kso4/2.27515, -11.147, 36.3369, -64.2134, 56.8341, -20.0953/ + +! *** check range of per cent relative humidity + irh = irhx + irh = max(1,irh) + irh = min(irh,100) + aw = float(irh)/ & ! water activity = fractional relative h + 100.0 + tso4 = max(mso4,0.0) + tnh4 = max(mnh4,0.0) + tno3 = max(mno3,0.0) + x = 0.0 +! *** if there is non-zero sulfate calculate the molar ratio + IF (tso4>0.0) THEN + x = tnh4/tso4 + ELSE +! *** otherwise check for non-zero nitrate and ammonium + IF (tno3>0.0 .AND. tnh4>0.0) x = 10.0 + END IF + +! *** begin screen on x for calculating wh2o + IF (x<1.0) THEN + + mfs0 = poly4(c0,aw) + mfs1 = poly4(c1,aw) + y0 = (1.0-mfs0)/mfs0 + y1 = (1.0-mfs1)/mfs1 + y = (1.0-x)*y0 + x*y1 + + ELSE IF (x<1.5) THEN + + IF (irh>=40) THEN + mfs1 = poly4(c1,aw) + mfs15 = poly4(c15,aw) + y1 = (1.0-mfs1)/mfs1 + y15 = (1.0-mfs15)/mfs15 + y = 2.0*(y1*(1.5-x)+y15*(x-1.0)) + ELSE +! *** set up for crystalization + +! *** Crystallization is done as follows: +! For 1.5 <= x, crystallization is assumed to occur at rh = 0.4 +! For x <= 1.0, crystallization is assumed to occur at an rh < 0.01 +! and since the code does not allow ar rh < 0.01, crystallization +! is assumed not to occur in this range. +! For 1.0 <= x <= 1.5 the crystallization curve is a straignt line +! from a value of y15 at rh = 0.4 to a value of zero at y1. From +! point B to point A in the diagram. +! The algorithm does a double interpolation to calculate the amount +! water. + +! y1(0.40) y15(0.40) +! + + Point B + +! +--------------------+ +! x=1 x=1.5 +! Point A + + awc = 0.80*(x-1.0) ! rh along the crystallization curve. + y = 0.0 + IF (aw>=awc) & ! interpolate using crystalization + THEN + mfs1 = poly4(c1,0.40) + mfs15 = poly4(c15,0.40) + y140 = (1.0-mfs1)/mfs1 + y1540 = (1.0-mfs15)/mfs15 + y40 = 2.0*(y140*(1.5-x)+y1540*(x-1.0)) + yc = 2.0*y1540*(x-1.0) ! y along crystallization cur + y = y40 - (y40-yc)*(0.40-aw)/(0.40-awc) +! end of checking for aw + END IF + + END IF +! end of checking on irh + ELSE IF (x<1.9999) THEN + + y = 0.0 + IF (irh>=40) THEN + mfs15 = poly4(c15,aw) + mfs2 = poly4(c2,aw) + y15 = (1.0-mfs15)/mfs15 + y2 = (1.0-mfs2)/mfs2 + y = 2.0*(y15*(2.0-x)+y2*(x-1.5)) + + END IF + +! end of check for crystallization + + ELSE +! regime where ammonium sulfate and ammonium nitrate are in solution. + +! *** following cf&s for both ammonium sulfate and ammonium nitrate +! *** check for crystallization here. their data indicate a 40% value +! is appropriate. +! 1.9999 < x + y2 = 0.0 + y3 = 0.0 + IF (irh>=40) THEN + mfsso4 = poly6(kso4,aw) + mfsno3 = poly6(kno3,aw) + y2 = (1.0-mfsso4)/mfsso4 + y3 = (1.0-mfsno3)/mfsno3 + + END IF + + END IF +! *** now set up output of wh2o + +! wh2o units are micrograms (liquid water) / cubic meter of air + +! end of checking on x + IF (x<1.9999) THEN + + wh2o = y*(tso4*mwso4+mwnh4*tnh4) + + ELSE + +! *** this is the case that all the sulfate is ammonium sulfate +! and the excess ammonium forms ammonum nitrate + + wh2o = y2*tso4*mw2 + y3*tno3*mwano3 + + END IF + + RETURN + END SUBROUTINE awater +!////////////////////////////////////////////////////////////////////// + + SUBROUTINE coagrate(blksize,nspcsda,numcells,cblk,blkta,pdensn,pdensa,amu, & + dgnuc,dgacc,knnuc,knacc,urn00,ura00,brna01,c30) +!*********************************************************************** +!** DESCRIPTION: calculates aerosol coagulation rates for unimodal +! and bimodal coagulation using E. Whitby 1990's prescription. + +!....... Rates for coaglulation: +!....... Unimodal Rates: +!....... URN00: nuclei mode 0th moment self-coagulation rate +!....... URA00: accumulation mode 0th moment self-coagulation rate + +!....... Bimodal Rates: (only 1st order coeffs appear) +!....... NA-- nuclei with accumulation coagulation rates, +!....... AN-- accumulation with nuclei coagulation rates +!....... BRNA01: rate for 0th moment ( d(nuclei mode 0) / dt term) +!....... BRNA31: 3rd ( d(nuclei mode 3) / dt term) +!** Revision history: +! prototype 1/95 by Uma and Carlie +! Revised 8/95 by US for calculation of density from stmt func +! and collect met variable stmt funcs in one include fil +! REVISED 7/25/96 by FSB to use block structure +! REVISED 9/13/96 BY FSB for Uma's FIXEDBOTH case only. +! REVISED 11/08/96 BY FSB the Whitby Shankar convention on signs +! changed. All coagulation coefficients +! returned with positive signs. Their +! linearization is also abandoned. +! Fixed values are used for the corrections +! to the free-molecular coagulation integra +! The code forces the harmonic means to be +! evaluated in 64 bit arithmetic on 32 bit +! REVISED 11/14/96 BY FSB Internal units are now MKS, moment / unit + +! REVISED 1/12/98 by FSB C30 replaces BRNA31 as an array. This wa +! because BRNA31 can become zero on a works +! because of limited precision. With the ch +! aerostep to omit update of the 3rd moment +! C30 is the only variable now needed. +! the logic using ONE88 to force REAL*8 ari +! has been removed and all intermediates ar +! REAL*8. +! IMPLICIT NONE + +! dimension of arrays + INTEGER blksize +! actual number of cells in arrays + INTEGER numcells + + INTEGER nspcsda + +! nmber of species in CBLK + REAL cblk(blksize,nspcsda) ! main array of variables + REAL blkta(blksize) ! Air temperature [ K ] + REAL pdensn(blksize) ! average particel density in Aitk + REAL pdensa(blksize) ! average particel density in accu + REAL amu(blksize) ! atmospheric dynamic viscosity [ + REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ] + REAL dgacc(blksize) ! accumulation mode mean diameter + REAL knnuc(blksize) ! Aitken mode Knudsen number + REAL knacc(blksize) +! *** output: + +! accumulation mode Knudsen number + REAL urn00(blksize) ! intramodal coagulation rate (Ait + REAL ura00(blksize) +! intramodal coagulation rate (acc + REAL brna01(blksize) ! intermodal coagulaton rate (numb + REAL c30(blksize) ! by inter + +! *** Local variables: +! intermodal 3rd moment transfer r + REAL*8 kncnuc, & ! coeffs for unimodal NC coag rate + kncacc + REAL*8 kfmnuc, & ! coeffs for unimodal FM coag rate + kfmacc + REAL*8 knc, & ! coeffs for bimodal NC, FM coag rate + kfm + REAL*8 bencnn, & ! NC 0th moment coag rate (both modes) + bencna + REAL*8 & ! NC 3rd moment coag rate (nuc mode) + bencm3n + REAL*8 befmnn, & ! FM 0th moment coag rate (both modes) + befmna + REAL*8 & ! FM 3rd moment coag rate (nuc mode) + befm3n + REAL*8 betann, & ! composite coag rates, mom 0 (both mode + betana + REAL*8 & ! intermodal coagulation rate for 3rd mo + brna31 + REAL*8 & ! scratch subexpression + s1 + REAL*8 t1, & ! scratch subexpressions + t2 + REAL*8 t16, & ! T1**6, T2**6 + t26 + REAL*8 rat, & ! ratio of acc to nuc size and its inver + rin + REAL*8 rsqt, & ! sqrt( rat ), rsqt**4 + rsq4 + REAL*8 rsqti, & ! sqrt( 1/rat ), sqrt( 1/rat**3 ) + rsqi3 + REAL*8 & ! dgnuc**3 + dgn3 + REAL*8 & ! in 64 bit arithmetic + dga3 +! dgacc**3 + + INTEGER lcell +! *** Fixed values for correctionss to coagulation +! integrals for free-molecular case. +! loop counter + REAL*8 bm0 + PARAMETER (bm0=0.8D0) + REAL*8 bm0i + PARAMETER (bm0i=0.9D0) + REAL*8 bm3i + PARAMETER (bm3i=0.9D0) + REAL*8 & ! approx Cunningham corr. factor + a + PARAMETER (a=1.246D0) +!....................................................................... +! begin body of subroutine COAGRATE + +!........... Main computational grid-traversal loops +!........... for computing coagulation rates. + +! *** Both modes have fixed std devs. + DO lcell = 1, & + numcells +! *** moment independent factors + +! loop on LCELL + s1 = two3*boltz*blkta(lcell)/amu(lcell) + +! For unimodal coagualtion: + + kncnuc = s1 + kncacc = s1 + + kfmnuc = sqrt(3.0*boltz*blkta(lcell)/pdensn(lcell)) + kfmacc = sqrt(3.0*boltz*blkta(lcell)/pdensa(lcell)) + +! For bimodal coagulation: + + knc = s1 + kfm = sqrt(6.0*boltz*blkta(lcell)/(pdensn(lcell)+pdensa(lcell))) + +!........... Begin unimodal coagulation rate calculations: +!........... Near-continuum regime. + + dgn3 = dgnuc(lcell)**3 + dga3 = dgacc(lcell)**3 + + t1 = sqrt(dgnuc(lcell)) + t2 = sqrt(dgacc(lcell)) + t16 = & ! = T1**6 + dgn3 + t26 = & + dga3 +!....... Note rationalization of fractions and subsequent cancellation +!....... from the formulation in Whitby et al. (1990) + +! = T2**6 + bencnn = kncnuc*(1.0+esn08+a*knnuc(lcell)*(esn04+esn20)) + + bencna = kncacc*(1.0+esa08+a*knacc(lcell)*(esa04+esa20)) + +!........... Free molecular regime. Uses fixed value for correction +! factor BM0 + + befmnn = kfmnuc*t1*(en1+esn25+2.0*esn05)*bm0 + befmna = kfmacc*t2*(ea1+esa25+2.0*esa05)*bm0 + +!........... Calculate half the harmonic mean between unimodal rates +!........... free molecular and near-continuum regimes + +! FSB 64 bit evaluation + + betann = bencnn*befmnn/(bencnn+befmnn) + betana = bencna*befmna/(bencna+befmna) + + urn00(lcell) = betann + ura00(lcell) = betana + +! *** End of unimodal coagulation calculations. + +!........... Begin bimodal coagulation rate calculations: + + rat = dgacc(lcell)/dgnuc(lcell) + rin = 1.0D0/rat + rsqt = sqrt(rat) + rsq4 = rat**2 + + rsqti = 1.0D0/rsqt + rsqi3 = rin*rsqti + +!........... Near-continuum coeffs: +!........... 0th moment nuc mode bimodal coag coefficient + + bencnn = knc*(2.0+a*knnuc(lcell)*(esn04+rat*esn16*esa04)+a*knacc(lcell & + )*(esa04+rin*esa16*esn04)+(rat+rin)*esn04*esa04) + +!........... 3rd moment nuc mode bimodal coag coefficient + + bencm3n = knc*dgn3*(2.0*esn36+a*knnuc(lcell)*(esn16+rat*esn04*esa04)+a & + *knacc(lcell)*(esn36*esa04+rin*esn64*esa16)+rat*esn16*esa04+ & + rin*esn64*esa04) + +!........... Free molecular regime coefficients: +!........... Uses fixed value for correction +! factor BM0I, BM3I +!........... 0th moment nuc mode coeff + + befmnn = kfm*bm0i*t1*(en1+rsqt*ea1+2.0*rat*en1*esa04+rsq4*esn09*esa16+ & + rsqi3*esn16*esa09+2.0*rsqti*esn04*ea1) + +!........... 3rd moment nuc mode coeff + + befm3n = kfm*bm3i*t1*t16*(esn49+rsqt*esn36*ea1+2.0*rat*esn25*esa04+ & + rsq4*esn09*esa16+rsqi3*esn100*esa09+2.0*rsqti*esn64*ea1) + + +!........... Calculate half the harmonic mean between bimodal rates +!........... free molecular and near-continuum regimes + +! FSB Force 64 bit evaluation + + brna01(lcell) = bencnn*befmnn/(bencnn+befmnn) + + brna31 = bencm3n* & ! BRNA31 now is a scala + befm3n/(bencm3n+befm3n) + c30(lcell) = brna31*cblk(lcell,vac0)*cblk(lcell,vnu0) +! print *,c30(lcell),brna31,cblk(lcell,vac0),cblk(lcell,vnu0) + ! 3d moment transfer by intermodal coagula +! End bimodal coagulation rate. + + END DO +! end of main lop over cells + RETURN +END SUBROUTINE coagrate +!------------------------------------------------------------------ + +! subroutine to find the roots of a cubic equation / 3rd order polynomi +! formulae can be found in numer. recip. on page 145 +! kiran developed this version on 25/4/1990 +! dr. francis binkowski modified the routine on 6/24/91, 8/7/97 +! *** +!234567 +! coagrate + SUBROUTINE cubic(a2,a1,a0,nr,crutes) +! IMPLICIT NONE + INTEGER nr + REAL*8 a2, a1, a0 + REAL crutes(3) + REAL*8 qq, rr, a2sq, theta, sqrt3, one3rd + REAL*8 dum1, dum2, part1, part2, part3, rrsq, phi, yy1, yy2, yy3 + REAL*8 costh, sinth + DATA sqrt3/1.732050808/, one3rd/0.333333333/ +!bs + REAL*8 onebs + PARAMETER (onebs=1.0) +!bs + a2sq = a2*a2 + qq = (a2sq-3.*a1)/9. + rr = (a2*(2.*a2sq-9.*a1)+27.*a0)/54. +! CASE 1 THREE REAL ROOTS or CASE 2 ONLY ONE REAL ROOT + dum1 = qq*qq*qq + rrsq = rr*rr + dum2 = dum1 - rrsq + IF (dum2>=0.) THEN +! NOW WE HAVE THREE REAL ROOTS + phi = sqrt(dum1) + IF (abs(phi)<1.E-20) THEN + print *, ' cubic phi small, phi = ',phi + crutes(1) = 0.0 + crutes(2) = 0.0 + crutes(3) = 0.0 + nr = 0 + CALL wrf_error_fatal ( 'PHI < CRITICAL VALUE') + END IF + theta = acos(rr/phi)/3.0 + costh = cos(theta) + sinth = sin(theta) +! *** use trig identities to simplify the expressions +! *** binkowski's modification + part1 = sqrt(qq) + yy1 = part1*costh + yy2 = yy1 - a2/3.0 + yy3 = sqrt3*part1*sinth + crutes(3) = -2.0*yy1 - a2/3.0 + crutes(2) = yy2 + yy3 + crutes(1) = yy2 - yy3 +! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE + IF (crutes(1)<0.0) crutes(1) = 1.0E9 + IF (crutes(2)<0.0) crutes(2) = 1.0E9 + IF (crutes(3)<0.0) crutes(3) = 1.0E9 +! *** put smallest positive root in crutes(1) + crutes(1) = min(crutes(1),crutes(2),crutes(3)) + nr = 3 +! NOW HERE WE HAVE ONLY ONE REAL ROOT + ELSE +! dum IS NEGATIVE + part1 = sqrt(rrsq-dum1) + part2 = abs(rr) + part3 = (part1+part2)**one3rd + crutes(1) = -sign(onebs,rr)*(part3+(qq/part3)) - a2/3. +!bs & -sign(1.0,rr) * ( part3 + (qq/part3) ) - a2/3. + crutes(2) = 0. + crutes(3) = 0. +!IAREV02...ADDITIONAL CHECK on NEGATIVE ROOTS +! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE +! if(crutes(1) .lt. 0.0) crutes(1) = 1.0e9 + nr = 1 + END IF + RETURN + END SUBROUTINE cubic +!/////////////////////////////////////////////////////////////////////// + +! Calculate the aerosol chemical speciation and water content. +! cubic + SUBROUTINE eql3(blksize,nspcsda,numcells,cblk,blkta,blkrh,igrid,jgrid,kgrid) +!*********************************************************************** +!** DESCRIPTION: +! Calculates the distribution of ammonia/ammonium, nitric acid/nitrate, +! and water between the gas and aerosol phases as the total sulfate, +! ammonia, and nitrate concentrations, relative humidity and +! temperature change. The evolution of the aerosol mass concentration +! due to the change in aerosol chemical composition is calculated. +!** REVISION HISTORY: +! prototype 1/95 by Uma and Carlie +! Revised 8/95 by US to calculate air density in stmt func +! and collect met variable stmt funcs in one include fil +! Revised 7/26/96 by FSB to use block concept. +! Revise 12/1896 to do do i-mode calculation. +!********************************************************************** +! IMPLICIT NONE + +! dimension of arrays + INTEGER blksize +! actual number of cells in arrays + INTEGER numcells +! nmber of species in CBLK + INTEGER nspcsda,igrid,jgrid,kgrid + REAL cblk(blksize,nspcsda) +! *** Meteorological information in blocked arays: + +! main array of variables + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkrh(blksize) + +! Fractional relative humidity + + INTEGER lcell +! loop counter +! air temperature + REAL temp +!iamodels3 + REAL rh +! relative humidity + REAL so4, no3, nh3, nh4, hno3 + REAL aso4, ano3, ah2o, anh4, gnh3, gno3 +! Fraction of dry sulfate mass in i-mode + REAL fraci +!....................................................................... + REAL fracj +! +! ISOROPIA variables double precision +! + real(kind=8) wi(5),wt(5),wt_save(5) + real(kind=8) rhi,tempi,cntrl(2) + real(kind=8) gas(3),aerliq(12),aersld(9),other(6) + character*15 scasi + +! WRITE(20,*) ' IN EQL 3 ' + +! Fraction of dry sulfate mass in j-mode + DO lcell = 1, & + numcells +! *** Fetch temperature, fractional relative humidity, and +! air density + +! loop on cells + temp = blkta(lcell) + rh = blkrh(lcell) + + rhi = amin1( rh,0.995 ) + tempi = temp + cntrl(1) = 0.d0 ! 0 = forward problem + cntrl(2) = 0.d0 ! 0 = solids and liquid allowed + + wi(1) = (cblk(lcell,vnaaj) + cblk(lcell,vnaai))/mw_na_aer*1.e-6 ! sodium + + wi(2) = (cblk(lcell,vsulf)/(mw_so4_aer+2.) + & + (cblk(lcell,vso4aj) + cblk(lcell,vso4ai))/mw_so4_aer)*1.e-6 ! sulfate + + wi(3) = (cblk(lcell,vnh3)/(mw_nh4_aer-1.) + & + (cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai))/mw_nh4_aer)*1.e-6 ! ammoinum + + wi(4) = (cblk(lcell,vhno3)/(mw_no3_aer+1.) + & + (cblk(lcell,vno3aj) + cblk(lcell,vno3ai))/mw_no3_aer)*1.e-6 ! nitrate + +!KW wi(5) = (cblk(lcell,vhcl)/(mw_cl_aer-1.) + & +!KW (cblk(lcell,vclaj) + cblk(lcell,vclai))/mw_cl_aer)*1.e-6 ! chloride +!KW wi(5) equation according to WRFV3.1 + wi(5) = (cblk(lcell,vhcl)/(mw_cl_aer+1.) + & + (cblk(lcell,vclaj) + cblk(lcell,vclai))/mw_cl_aer)*1.e-6 + +!KW +! Following added: wi should be positive + wi(1) = max(wi(1),0.) + wi(2) = max(wi(2),0.) + wi(3) = max(wi(3),0.) + wi(4) = max(wi(4),0.) + wi(5) = max(wi(5),0.) + + wt_save(1) = wi(1) ! sodium + wt_save(2) = wi(2) ! sulfate + wt_save(3) = wi(3) ! ammoinum + wt_save(4) = wi(4) ! nitrate + wt_save(5) = wi(5) ! chloride + if(igrid.eq.28.and.jgrid.eq.24.and.kgrid.eq.1)then + print *,vhcl,vclai + print *,wi(1),wi(2),wi(3),wi(4),wi(5) + endif + +!KW Originally isoropia not used + call isoropia(wi,rhi,tempi,cntrl,wt,gas,aerliq,aersld,scasi,other) + +! *** the following is an interim procedure. Assume the i-mode has the +! same relative mass concentrations as the total mass. Use SO4 as +! the surrogate. + +! *** update gas / vapor phase + +!KW Added the following: gas has to be positive and within input value + + gas(1) = min(gas(1),wt_save(3)) + gas(2) = min(gas(2),wt_save(4)) + gas(3) = min(gas(3),wt_save(5)) + + gas(1) = max(gas(1),0.) + gas(2) = max(gas(2),0.) + gas(3) = max(gas(3),0.) + +!KW Original code starts here + + cblk(lcell,vnh3) = gas(1)*1.e6*(mw_nh4_aer-1.) + cblk(lcell,vhno3) = gas(2)*1.e6*(mw_no3_aer+1.) + cblk(lcell,vhcl) = gas(3)*1.e6*(mw_cl_aer+1.) +!KW cblk(lcell,vnh3) = gas(1)*1.e6*17. +!KW cblk(lcell,vhno3) = gas(2)*1.e6*63. +!KW cblk(lcell,vhcl) = gas(3)*1.e6*36. + if(igrid.eq.28.and.jgrid.eq.24.and.kgrid.eq.1)then + print *,vhcl,vnh3,vhno3 + print *,cblk(lcell,vnh3),cblk(lcell,vhno3),cblk(lcell,vhcl) + endif + +! *** get modal fraction + fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai)) + +!KW Restrict fraci from between 0 to 1 + fraci = min(fraci,1.0) + fraci = max(fraci,0.0) + + fracj = 1.0 - fraci + +!KW correct mapping from (mol m-3) to (ug m-3) + + aerliq(8) = max(aerliq(8),0.) + +! *** update do i-mode + cblk(lcell,vh2oai) = fraci*aerliq(8)*18.*1.e6 + cblk(lcell,vnh4ai) = fraci*(wt_save(3) - gas(1))*mw_nh4_aer*1.e6 + cblk(lcell,vno3ai) = fraci*(wt_save(4) - gas(2))*mw_no3_aer*1.e6 + cblk(lcell,vclai) = fraci*(wt_save(5) - gas(3))*mw_cl_aer*1.e6 + cblk(lcell,vnaai) = fraci*wi(1)*mw_na_aer*1.e6 + +!KW cblk(lcell,vnh4ai) = fraci*(wt_save(3) - gas(1)) +!KW cblk(lcell,vno3ai) = fraci*(wt_save(4) - gas(2)) +!KW cblk(lcell,vclai) = fraci*(wt_save(5) - gas(3)) +!KW cblk(lcell,vnaai) = fraci*wi(1) + +! *** update accumulation mode: +!KW ! correct mapping from (mol m-3) to (ug m-3) + + cblk(lcell,vh2oaj) = fracj*aerliq(8)*18.*1.e6 + cblk(lcell,vnh4aj) = fracj*(wt_save(3) - gas(1))*mw_nh4_aer*1.e6 + cblk(lcell,vno3aj) = fracj*(wt_save(4) - gas(2))*mw_no3_aer*1.e6 + cblk(lcell,vclaj) = fracj*(wt_save(5) - gas(3))*mw_cl_aer*1.e6 + cblk(lcell,vnaaj) = fracj*wi(1)*mw_na_aer*1.e6 + +!KW cblk(lcell,vnh4aj) = fracj*(wt_save(3) - gas(1)) +!KW cblk(lcell,vno3aj) = fracj*(wt_save(4) - gas(2)) +!KW cblk(lcell,vclaj) = fracj*(wt_save(5) - gas(3)) +!KW cblk(lcell,vnaaj) = fracj*wi(1) + + if(igrid.eq.28.and.jgrid.eq.24.and.kgrid.eq.1)then + print *,vh2oaj,vnh4aj,vno3aj,vclaj,vnaaj + print *,cblk(lcell,vnh4aj),cblk(lcell,vno3aj),cblk(lcell,vclaj),aerliq(8) + endif + + END DO +! end loop on cells + + RETURN + +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + END SUBROUTINE eql3 +! eql3 +! Calculate the aerosol chemical speciation and water content. + +! cubic + SUBROUTINE eql4(blksize,nspcsda,numcells,cblk,blkta,blkrh) +!*********************************************************************** +!** DESCRIPTION: +! Calculates the distribution of ammonia/ammonium, nitric acid/nitrate, +! and water between the gas and aerosol phases as the total sulfate, +! ammonia, and nitrate concentrations, relative humidity and +! temperature change. The evolution of the aerosol mass concentration +! due to the change in aerosol chemical composition is calculated. +!** REVISION HISTORY: +! prototype 1/95 by Uma and Carlie +! Revised 8/95 by US to calculate air density in stmt func +! and collect met variable stmt funcs in one include fil +! Revised 7/26/96 by FSB to use block concept. +! Revise 12/1896 to do do i-mode calculation. +!********************************************************************** +! IMPLICIT NONE + +! dimension of arrays + INTEGER blksize +! actual number of cells in arrays + INTEGER numcells +! nmber of species in CBLK + INTEGER nspcsda + REAL cblk(blksize,nspcsda) +! *** Meteorological information in blocked arays: + +! main array of variables + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkrh(blksize) + +! Fractional relative humidity + + INTEGER lcell +! loop counter +! air temperature + REAL temp +!iamodels3 + REAL rh +! relative humidity + REAL so4, no3, nh3, nh4, hno3 + REAL aso4, ano3, ah2o, anh4, gnh3, gno3 +! Fraction of dry sulfate mass in i-mode + REAL fraci +!....................................................................... + REAL fracj +! Fraction of dry sulfate mass in j-mode + DO lcell = 1, & + numcells +! *** Fetch temperature, fractional relative humidity, and +! air density + +! loop on cells + temp = blkta(lcell) + rh = blkrh(lcell) + +! *** the following is an interim procedure. Assume the i-mode has the +! same relative mass concentrations as the total mass. Use SO4 as +! the surrogate. The results of this should be the same as those +! from the original RPM. + +! *** do total aerosol + so4 = cblk(lcell,vso4aj) + cblk(lcell,vso4ai) + +!iamodels3 + no3 = cblk(lcell,vno3aj) + cblk(lcell,vno3ai) +! & + CBLK(LCELL, VHNO3) + + hno3 = cblk(lcell,vhno3) + +!iamodels3 + + nh3 = cblk(lcell,vnh3) + + nh4 = cblk(lcell,vnh4aj) + cblk(lcell,vnh4ai) +! & + CBLK(LCELL, VNH3) + +!bs CALL rpmares(SO4,HNO3,NO3,NH3,NH4,RH,TEMP, +!bs & ASO4,ANO3,AH2O,ANH4,GNH3,GNO3) +!bs +!bs * call old version of rpmares +!bs + CALL rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, & + gnh3,gno3) +!bs + +! *** get modal fraction + fraci = cblk(lcell,vso4ai)/(cblk(lcell,vso4aj)+cblk(lcell,vso4ai)) + fracj = 1.0 - fraci + +! *** update do i-mode + + cblk(lcell,vh2oai) = fraci*ah2o + cblk(lcell,vnh4ai) = fraci*anh4 + cblk(lcell,vno3ai) = fraci*ano3 + +! *** update accumulation mode: + + cblk(lcell,vh2oaj) = fracj*ah2o + cblk(lcell,vnh4aj) = fracj*anh4 + cblk(lcell,vno3aj) = fracj*ano3 + + +! *** update gas / vapor phase + cblk(lcell,vnh3) = gnh3 + cblk(lcell,vhno3) = gno3 + + END DO +! end loop on cells + RETURN + +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + END SUBROUTINE eql4 +! eql4 + + SUBROUTINE fdjac(n,x,fjac,ct,cs,imw) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: ! +!bs ! +!bs Get the Jacobian of the function ! +!bs ! +!bs ( a1 * X1^2 + b1 * X1 + c1 ) ! +!bs ( a2 * X2^2 + b2 * X1 + c2 ) ! +!bs ( a3 * X3^2 + b3 * X1 + c3 ) ! +!bs F(X) = ( a4 * X4^2 + b4 * X1 + c4 ) = 0. ! +!bs ( a5 * X5^2 + b5 * X1 + c5 ) ! +!bs ( a6 * X6^2 + b6 * X1 + c6 ) ! +!bs ! +!bs a_i = IMW_i ! +!bs b_i = SUM(X_j * IMW_j)_j.NE.i + CSAT_i * IMX_i - CTOT_i * IMW_i ! +!bs c_i = - CTOT_i * [ SUM(X_j * IMW_j)_j.NE.i + M ] ! +!bs ! +!bs delta F_i ( 2. * a_i * X_i + b_i if i .EQ. j ! +!bs J_ij = ----------- = ( ! +!bs delta X_j ( X_i * IMW_j - CTOT_i * IMW_j if i .NE. j ! +!bs ! +!bs ! +!bs Called by: NEWT ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs +! IMPLICIT NONE +!bs +!bs +!dimension of problem + INTEGER n + REAL x(n) !bs +! INTEGER NP !bs maximum expected value of N +! PARAMETER (NP = 6) +!bs initial guess of CAER + REAL ct(np) + REAL cs(np) + REAL imw(np) +!bs + REAL fjac(n,n) +!bs + INTEGER i, & !bs loop index + j + REAL a(np) + REAL b(np) + REAL b1(np) + REAL b2(np) + REAL sum_jnei +!bs + DO i = 1, n + a(i) = imw(i) + sum_jnei = 0. + DO j = 1, n + sum_jnei = sum_jnei + x(j)*imw(j) + END DO + b1(i) = sum_jnei - (x(i)*imw(i)) + b2(i) = cs(i)*imw(i) - ct(i)*imw(i) + b(i) = b1(i) + b2(i) + END DO + DO j = 1, n + DO i = 1, n + IF (i==j) THEN + fjac(i,j) = 2.*a(i)*x(i) + b(i) + ELSE + fjac(i,j) = x(i)*imw(j) - ct(i)*imw(j) + END IF + END DO + END DO +!bs + RETURN + END SUBROUTINE fdjac +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + FUNCTION fmin(x,fvec,n,ct,cs,imw,m) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: ! +!bs ! +!bs Adopted from Numerical Recipes in FORTRAN, Chapter 9.7, 2nd ed. ! +!bs ! +!bs Returns f = 0.5 * F*F at X. SR FUNCV(N,X,F) is a fixed name, ! +!bs user-supplied routine that returns the vector of functions at X. ! +!bs The common block NEWTV communicates the function values back to ! +!bs NEWT. ! +!bs ! +!bs Called by: NEWT ! +!bs ! +!bs Calls: FUNCV ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + +! IMPLICIT NONE + +!bs +!bs + INTEGER n +! INTEGER NP +! PARAMETER (NP = 6) + REAL ct(np) + REAL cs(np) + REAL imw(np) + REAL m,fmin + REAL x(*), fvec(np) + + INTEGER i + REAL sum + + CALL funcv(n,x,fvec,ct,cs,imw,m) + sum = 0. + DO i = 1, n + sum = sum + fvec(i)**2 + END DO + fmin = 0.5*sum + RETURN + END FUNCTION fmin +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! + SUBROUTINE funcv(n,x,fvec,ct,cs,imw,m) +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs ! +!bs Description: ! +!bs ! +!bs Called by: FMIN ! +!bs ! +!bs Calls: None ! +!bs ! +!bs ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS ** ** BS ** BS *! +!bs +! IMPLICIT NONE +!bs +!bs + INTEGER n + REAL x(*) + REAL fvec(n) +!bs +! INTEGER NP +! PARAMETER (NP = 6) + REAL ct(np) + REAL cs(np) + REAL imw(np) + REAL m +!bs + INTEGER i, j + REAL sum_jnei + REAL a(np) + REAL b(np) + REAL c(np) +!bs + DO i = 1, n + a(i) = imw(i) + sum_jnei = 0. + DO j = 1, n + sum_jnei = sum_jnei + x(j)*imw(j) + END DO + sum_jnei = sum_jnei - (x(i)*imw(i)) + b(i) = sum_jnei + cs(i)*imw(i) - ct(i)*imw(i) + c(i) = -ct(i)*(sum_jnei+m) + fvec(i) = a(i)*x(i)**2 + b(i)*x(i) + c(i) + END DO +!bs + RETURN + END SUBROUTINE funcv + REAL FUNCTION getaf(ni,nj,dgni,dgnj,xlsgi,xlsgj,sqrt2) +! *** set up new processor for renaming of particles from i to j modes +! IMPLICIT NONE + REAL aa, bb, cc, disc, qq, alfa, l, yji + REAL ni, nj, dgni, dgnj, xlsgi, xlsgj, sqrt2 + + alfa = xlsgi/xlsgj + yji = log(dgnj/dgni)/(sqrt2*xlsgi) + aa = 1.0 - alfa*alfa + l = log(alfa*nj/ni) + bb = 2.0*yji*alfa*alfa + cc = l - yji*yji*alfa*alfa + disc = bb*bb - 4.0*aa*cc + IF (disc<0.0) THEN + getaf = - & ! error in intersection + 5.0 + RETURN + END IF + qq = -0.5*(bb+sign(1.0,bb)*sqrt(disc)) + getaf = cc/qq + RETURN +! *** subroutine to implement Kulmala, Laaksonen, Pirjola + END FUNCTION getaf +! Parameterization for sulfuric acid/water +! nucleation rates, J. Geophys. Research (103), pp 8301-8307, +! April 20, 1998. + +!ia rev01 27.04.99 changes made to calculation of MDOT see RBiV p.2f +!ia rev02 27.04.99 security check on MDOT > SO4RAT + +!ia subroutine klpnuc( Temp, RH, H2SO4,NDOT, MDOT, M2DOT) +! getaf + SUBROUTINE klpnuc(temp,rh,h2so4,ndot1,mdot1,so4rat) +! IMPLICIT NONE + +! *** Input: + +! ambient temperature [ K ] + REAL temp +! fractional relative humidity + REAL rh +! sulfuric acid concentration [ ug / m**3 ] + REAL h2so4 + + REAL so4rat +! *** Output: + +!sulfuric acid production rate [ ug / ( m**3 s )] +! particle number production rate [ # / ( m**3 s )] + REAL ndot1 +! particle mass production rate [ ug / ( m**3 s )] + REAL mdot1 + ! [ m**2 / ( m**3 s )] + REAL m2dot + +! *** Internal: + +! *** NOTE, all units are cgs internally. +! particle second moment production rate + + REAL ra +! fractional relative acidity +! sulfuric acid vaper concentration [ cm ** -3 ] + REAL nav +! water vapor concentration [ cm ** -3 ] + REAL nwv +! equilibrium sulfuric acid vapor conc. [ cm ** -3 ] + REAL nav0 + ! to produce a nucleation rate of 1 [ cm ** -3 s ** -1 + REAL nac +! critical sulfuric acid vapor concentration [ cm ** -3 +! mole fractio of the critical nucleus + REAL xal + REAL nsulf, & ! see usage + delta + REAL*8 & ! factor to calculate Jnuc + chi + REAL*8 & + jnuc +! nucleation rate [ cm ** -3 s ** -1 ] + REAL tt, & ! dummy variables for statement functions + rr + REAL pi + PARAMETER (pi=3.14159265) + + REAL pid6 + PARAMETER (pid6=pi/6.0) + +! avogadro's constant [ 1/mol ] + REAL avo + PARAMETER (avo=6.0221367E23) + +! universal gas constant [ j/mol-k ] + REAL rgasuniv + PARAMETER (rgasuniv=8.314510) + +! 1 atmosphere in pascals + REAL atm + PARAMETER (atm=1013.25E+02) + +! formula weight for h2so4 [ g mole **-1 ] + REAL mwh2so4 + PARAMETER (mwh2so4=98.07948) + +! diameter of a 3.5 nm particle in cm + REAL d35 + PARAMETER (d35=3.5E-07) + REAL d35sq + PARAMETER (d35sq=d35*d35) +! volume of a 3.5 nm particle in cm**3 + REAL v35 + PARAMETER (v35=pid6*d35*d35sq) +!ia rev01 + + REAL mp +! *** conversion factors: +! mass of sulfate in a 3.5 nm particle + ! number per cubic cm. + REAL ugm3_ncm3 +! micrograms per cubic meter to + PARAMETER (ugm3_ncm3=(avo/mwh2so4)*1.0E-12) +!ia rev01 +! molecules to micrograms + REAL nc_ug + PARAMETER (nc_ug=(1.0E6)*mwh2so4/avo) + +! *** statement functions ************** + + REAL pdens, & + rho_p +! particle density [ g / cm**3] + REAL ad0, ad1, ad2, & + ad3 +! coefficients for density expression + PARAMETER (ad0=1.738984,ad1=-1.882301,ad2=2.951849,ad3=-1.810427) +! *** Nair and Vohra, Growth of aqueous sulphuric acid droplets +! as a function of relative humidity, +! J. Aerosol Science, 6, pp 265-271, 1975. + +!ia rev01 + +! fit to Nair & Vohra data + ! the mass of sulfate in a 3.5 nm particle + REAL mp35 +! arithmetic statement function to compute + REAL a0, a1, a2, & ! coefficients for cubic in mp35 + a3 + PARAMETER (a0=1.961385E2,a1=-5.564447E2,a2=8.828801E2,a3=-5.231409E2) + + REAL ph2so4, & ! for h2so4 and h2o vapor pressures [ Pa ] + ph2o + +! arithmetic statement functions + pdens(rr) = ad0 + rr*(ad1+rr*(ad2+rr*ad3)) + + ph2o(tt) = exp(77.34491296-7235.4246512/tt-8.2*log(tt)+tt*5.7113E-03) + + ph2so4(tt) = exp(27.78492066-10156.0/tt) + +! *** both ph2o and ph2so4 are as in Kulmala et al. paper + +!ia rev01 + +! *** function for the mass of sulfate in a 3.5 nm sphere +! *** obtained from a fit to the number of sulfate monomers in +! a 3.5 nm particle. Uses data from Nair & Vohra + mp35(rr) = nc_ug*(a0+rr*(a1+rr*(a2+rr*a3))) + +! *** begin code: + +! The 1.0e-6 factor in the following converts from MKS to cgs units + +! *** get water vapor concentration [ molecles / cm **3 ] + + nwv = rh*ph2o(temp)/(rgasuniv*temp)*avo*1.0E-6 + +! *** calculate the equilibrium h2so4 vapor concentration. + +! *** use Kulmala corrections: + +! *** + nav0 = ph2so4(temp)/(rgasuniv*temp)*avo*1.0E-6 + +! *** convert sulfuric acid vapor concentration from micrograms +! per cubic meter to molecules per cubic centimeter. + + nav = ugm3_ncm3*h2so4 + +! *** calculate critical concentration of sulfuric acid vapor + + nac = exp(-14.5125+0.1335*temp-10.5462*rh+1958.4*rh/temp) + +! *** calculate relative acidity + + ra = nav/nav0 + +! *** calculate temperature correction + + delta = 1.0 + (temp-273.15)/273.14 + +! *** calculate molar fraction + + xal = 1.2233 - 0.0154*ra/(ra+rh) + 0.0102*log(nav) - 0.0415*log(nwv) + & + 0.0016*temp + +! *** calculate Nsulf + nsulf = log(nav/nac) + +! *** calculate particle produtcion rate [ # / cm**3 ] + + chi = 25.1289*nsulf - 4890.8*nsulf/temp - 1743.3/temp - & + 2.2479*delta*nsulf*rh + 7643.4*xal/temp - 1.9712*xal*delta/rh + + jnuc = exp(chi) +! [ # / cm**3 ] + ndot1 = (1.0E06)*jnuc +! write(91,*) ' inside klpnuc ' +! write(91,*) ' Jnuc = ', Jnuc +! write(91,*) ' NDOT = ', NDOT1 + +! *** calculate particle density + + rho_p = pdens(rh) + +! write(91,*) ' rho_p =', rho_p + +! *** get the mass of sulfate in a 3.5 nm particle + + mp = mp35(rh) ! in a 3.5 nm particle at ambient RH + +! *** calculate mass production rate [ ug / m**3] +! assume that the particles are 3.5 nm in diameter. + +! MDOT1 = (1.0E12) * rho_p * v35 * Jnuc + +!ia rev01 + +! number of micrograms of sulfate + mdot1 = mp*ndot1 + +!ia rev02 + + IF (mdot1>so4rat) THEN + + mdot1 = & + so4rat +! limit nucleated mass by available ma + ndot1 = mdot1/ & + mp +! adjust DNDT to this + END IF + + IF (mdot1==0.) ndot1 = 0. + +! *** calculate M2 production rate [ m**2 / (m**3 s)] + + m2dot = 1.0E-04*d35sq*ndot1 + + RETURN + +END SUBROUTINE klpnuc +!------------------------------------------------------------------------------ + + SUBROUTINE modpar(blksize,nspcsda,numcells,cblk,blkta,blkprs,pmassn, & + pmassa,pmassc,pdensn,pdensa,pdensc,xlm,amu,dgnuc,dgacc,dgcor,knnuc, & + knacc,kncor) + +!** DESCRIPTION: +! Calculates modal parameters and derived variables, +! log-squared of std deviation, mode mean size, Knudsen number) +! based on current values of moments for the modes. +! FSB Now calculates the 3rd moment, mass, and density in all 3 modes. +!** +!** Revision history: +! Adapted 3/95 by US and CJC from EAM2's MODPAR and INIT3 +! Revised 7/23/96 by FSB to use COMMON blocks and small blocks +! instead of large 3-d arrays, and to assume a fixed std. +! Revised 12/06/96 by FSB to include coarse mode +! Revised 1/10/97 by FSB to have arrays passed in call vector +!********************************************************************** + +! IMPLICIT NONE + +! Includes: + +! *** input: + +! dimension of arrays + INTEGER blksize +! actual number of cells in arrays + INTEGER numcells + + INTEGER nspcsda + +! nmber of species in CBLK + REAL cblk(blksize,nspcsda) ! main array of variables + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkprs(blksize) +! *** output: + +! Air pressure in [ Pa ] +! concentration lower limit [ ug/m* +! lowest particle diameter ( m ) + REAL dgmin + PARAMETER (dgmin=1.0E-09) + +! lowest particle density ( Kg/m**3 + REAL densmin + PARAMETER (densmin=1.0E03) + + REAL pmassn(blksize) ! mass concentration in nuclei mode + REAL pmassa(blksize) ! mass concentration in accumulation + REAL pmassc(blksize) ! mass concentration in coarse mode + REAL pdensn(blksize) ! average particel density in Aitken + REAL pdensa(blksize) ! average particel density in accumu + REAL pdensc(blksize) ! average particel density in coarse + REAL xlm(blksize) ! atmospheric mean free path [ m] + REAL amu(blksize) ! atmospheric dynamic viscosity [ kg + REAL dgnuc(blksize) ! Aitken mode mean diameter [ m ] + REAL dgacc(blksize) ! accumulation + REAL dgcor(blksize) ! coarse mode + REAL knnuc(blksize) ! Aitken mode Knudsen number + REAL knacc(blksize) ! accumulation + REAL kncor(blksize) + +! coarse mode + + INTEGER lcell +! WRITE(20,*) ' IN MODPAR ' + +! *** set up aerosol 3rd moment, mass, density + +! loop counter + DO lcell = 1, numcells + +! *** Aitken-mode +! cblk(lcell,vnu3) = max(conmin,(so4fac*cblk(lcell, & ! ghan + cblk(lcell,vnu3) = so4fac*cblk(lcell, & + vso4ai)+nh4fac*cblk(lcell,vnh4ai)+h2ofac*cblk(lcell, & + vh2oai)+no3fac*cblk(lcell,vno3ai)+ & + nafac*cblk(lcell,vnaai)+ clfac*cblk(lcell,vclai)+ & + orgfac*cblk(lcell, & + vasoa1i)+orgfac*cblk(lcell,vasoa2i)+orgfac*cblk(lcell, & + vasoa3i)+orgfac*cblk(lcell,vasoa4i)+orgfac*cblk(lcell, & + vbsoa1i)+orgfac*cblk(lcell,vbsoa2i)+orgfac*cblk(lcell, & + vbsoa3i)+orgfac*cblk(lcell,vbsoa4i)+orgfac*cblk(lcell, & + vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci) +! vorgpai)+anthfac*cblk(lcell,vp25ai)+anthfac*cblk(lcell,veci))) ! ghan + +! *** Accumulation-mode +! cblk(lcell,vac3) = max(conmin,(so4fac*cblk(lcell, & ! ghan + cblk(lcell,vac3) = so4fac*cblk(lcell, & + vso4aj)+nh4fac*cblk(lcell,vnh4aj)+h2ofac*cblk(lcell, & + vh2oaj)+no3fac*cblk(lcell,vno3aj) + & + nafac*cblk(lcell,vnaaj)+ clfac*cblk(lcell,vclaj)+ & + orgfac*cblk(lcell, & + vasoa1j)+orgfac*cblk(lcell,vasoa2j)+orgfac*cblk(lcell, & + vasoa3j)+orgfac*cblk(lcell,vasoa4j)+orgfac*cblk(lcell, & + vbsoa1j)+orgfac*cblk(lcell,vbsoa2j)+orgfac*cblk(lcell, & + vbsoa3j)+orgfac*cblk(lcell,vbsoa4j)+orgfac*cblk(lcell, & + vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj) +! vorgpaj)+anthfac*cblk(lcell,vp25aj)+anthfac*cblk(lcell,vecj))) ! ghan + +! *** coarse mode +! cblk(lcell,vcor3) = max(conmin,(soilfac*cblk(lcell, & ! ghan rely on conmin applied to mass, not moment +! vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha))) + + cblk(lcell,vcor3) = soilfac*cblk(lcell, & + vsoila)+seasfac*cblk(lcell,vseas)+anthfac*cblk(lcell,vantha) + +! *** now get particle mass and density + +! *** Aitken-mode: +!KW Na and Cl added to aitken mode mass conc + + pmassn(lcell) = max(conmin,(cblk(lcell,vso4ai)+cblk(lcell, & + vnh4ai)+cblk(lcell,vh2oai)+cblk(lcell,vno3ai)+ & + cblk(lcell,vnaai)+cblk(lcell,vclai)+cblk(lcell, & + vasoa1i)+cblk(lcell,vasoa2i)+cblk(lcell,vasoa3i)+cblk(lcell, & + vasoa4i)+cblk(lcell,vbsoa1i)+cblk(lcell,vbsoa2i)+cblk(lcell, & + vbsoa3i)+cblk(lcell,vbsoa4i)+cblk(lcell,vorgpai)+cblk(lcell, & + vp25ai)+cblk(lcell,veci))) + +! *** Accumulation-mode: +!KW Na and Cl added to accum mode mass conc + + pmassa(lcell) = max(conmin,(cblk(lcell,vso4aj)+cblk(lcell, & + vnh4aj)+cblk(lcell,vh2oaj)+cblk(lcell,vno3aj)+ & + cblk(lcell,vnaaj)+cblk(lcell,vclaj)+cblk(lcell, & + vasoa1j)+cblk(lcell,vasoa2j)+cblk(lcell,vasoa3j)+cblk(lcell, & + vasoa4j)+cblk(lcell,vbsoa1j)+cblk(lcell,vbsoa2j)+cblk(lcell, & + vbsoa3j)+cblk(lcell,vbsoa4j)+cblk(lcell,vorgpaj)+cblk(lcell, & + vp25aj)+cblk(lcell,vecj))) + +! *** coarse mode: + pmassc(lcell) = max(conmin,cblk(lcell,vsoila)+cblk(lcell,vseas)+cblk( & + lcell,vantha)) + + END DO +! *** now get particle density, mean free path, and dynamic viscosity + +! aerosol 3rd moment and mass + DO lcell = 1, & + numcells +! *** density in [ kg m**-3 ] + +! Density and mean free path + pdensn(lcell) = max(densmin,(f6dpim9*pmassn(lcell)/cblk(lcell,vnu3))) + pdensa(lcell) = max(densmin,(f6dpim9*pmassa(lcell)/cblk(lcell,vac3))) + pdensc(lcell) = max(densmin,(f6dpim9*pmassc(lcell)/cblk(lcell,vcor3))) + +! *** Calculate mean free path [ m ]: + xlm(lcell) = 6.6328E-8*pss0*blkta(lcell)/(tss0*blkprs(lcell)) + +! *** 6.6328E-8 is the sea level values given in Table I.2.8 +! *** on page 10 of U.S. Standard Atmosphere 1962 + +! *** Calculate dynamic viscosity [ kg m**-1 s**-1 ]: + +! *** U.S. Standard Atmosphere 1962 page 14 expression +! for dynamic viscosity is: +! dynamic viscosity = beta * T * sqrt(T) / ( T + S) +! where beta = 1.458e-6 [ kg sec^-1 K**-0.5 ], s = 110.4 [ K ]. + + amu(lcell) = 1.458E-6*blkta(lcell)*sqrt(blkta(lcell))/ & + (blkta(lcell)+110.4) + + END DO +!............... Standard deviation fixed in both modes, so +!............... diagnose diameter from 3rd moment and number concentr + +! density and mean free path + DO lcell = 1, & + numcells + +! calculate diameters + dgnuc(lcell) = max(dgmin,(cblk(lcell,vnu3)/(cblk(lcell,vnu0)*esn36))** & + one3) + + dgacc(lcell) = max(dgmin,(cblk(lcell,vac3)/(cblk(lcell,vac0)*esa36))** & + one3) + + dgcor(lcell) = max(dgmin,(cblk(lcell,vcor3)/(cblk(lcell,vcorn)*esc36)) & + **one3) + +! when running with cloudborne aerosol, apply some very mild bounding +! to avoid unrealistic dg values + if (cw_phase > 0) then + dgnuc(lcell) = max( dgnuc(lcell), dginin*0.2 ) ! > 0.002 um + dgnuc(lcell) = min( dgnuc(lcell), dginin*10.0 ) ! < 0.10 um + dgacc(lcell) = max( dgacc(lcell), dginia*0.2 ) ! > 0.014 um + dgacc(lcell) = min( dgacc(lcell), dginia*10.0 ) ! < 0.7 um + dgcor(lcell) = max( dgcor(lcell), dginic*0.2 ) ! > 0.2 um + dgcor(lcell) = min( dgcor(lcell), dginic*10.0 ) ! < 10.0 um + end if + + END DO +! end loop on diameters + DO lcell = 1, & + numcells +! Calculate Knudsen numbers + knnuc(lcell) = 2.0*xlm(lcell)/dgnuc(lcell) + + knacc(lcell) = 2.0*xlm(lcell)/dgacc(lcell) + + kncor(lcell) = 2.0*xlm(lcell)/dgcor(lcell) + + END DO + +! end loop for Knudsen numbers + RETURN + +END SUBROUTINE modpar +!------------------------------------------------------------------------------ + +SUBROUTINE nuclcond(blksize,nspcsda,numcells,cblk,dt,layer,blkta,blkprs, & + blkrh,so4rat,organt1rat,organt2rat,organt3rat,organt4rat,orgbio1rat, & + orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv,nacv,dgnuc,dgacc, & + fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,deltaso4a,cgrn3,cgra3,igrid,jgrid,kgrid,brrto) + +!*********************************************************************** +!** DESCRIPTION: calculates aerosol nucleation and condensational +!** growth rates using Binkowski and Shankar (1995) method. + +! *** In this version, the method od RPM is followed where +! the diffusivity, the average molecular ve3locity, and +! the accomodation coefficient for sulfuric acid are used for +! the organics. This is for consistency. +! Future versions will use the correct values. FSB 12/12/96 + + +!** +!** Revision history: +! prototype 1/95 by Uma and Carlie +! Corrected 7/95 by Uma for condensation of mass not nucleated +! and mass conservation check +! Revised 8/95 by US to calculate air density in stmt function +! and collect met variable stmt funcs in one include fil +! Revised 7/25/96 by FSB to use block structure. +! Revised 9/17/96 by FSB to use Y&K or K&W Nucleation mechanism +! Revised 11/15/96 by FSB to use MKS, and mom m^-3 units. +! Revised 1/13/97 by FSB to pass arrays and simplify code. +! Added 23/03/99 by BS growth factors for organics +!********************************************************************** +! IMPLICIT NONE + +! Includes: +! *** arguments + +! *** input; +!USE module_configure, only: grid_config_rec_type +!TYPE (grid_config_rec_type), INTENT (in) :: config_flags + + +! dimension of arrays + INTEGER blksize + INTEGER layer +! number of species in CBLK + INTEGER nspcsda +! actual number of cells in arrays + INTEGER numcells + INTEGER igrid,jgrid,kgrid + + INTEGER ldrog_vbs +! # of organic aerosol precursor + REAL cblk(blksize,nspcsda) ! main array of variables +! model time step in SECONDS + REAL dt + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkprs(blksize) ! Air pressure in [ Pa ] + REAL blkrh(blksize) ! Fractional relative humidity + REAL so4rat(blksize) ! rate [ ug/m**3 /s ] + REAL brrto +!bs +! sulfate gas-phase production +! total # of cond. vapors & SOA spe + INTEGER ncv +!bs + INTEGER nacv +!bs * anthropogenic organic condensable vapor production rate +! # of anthrop. cond. vapors & SOA + REAL drog(blksize,ldrog_vbs) !bs +! Delta ROG conc. [ppm] + +! anthropogenic vapor production rates +REAL organt1rat(blksize) +REAL organt2rat(blksize) +REAL organt3rat(blksize) +REAL organt4rat(blksize) + +! biogenic vapor production rates +REAL orgbio1rat(blksize) +REAL orgbio2rat(blksize) +REAL orgbio3rat(blksize) +REAL orgbio4rat(blksize) + +! biogenic organic aerosol production + REAL dgnuc(blksize) ! accumulation + REAL dgacc(blksize) +! *** output: + +! coarse mode + REAL fconcn(blksize) ! Aitken mode [ 1 / s ] +! reciprocal condensation rate + REAL fconca(blksize) ! acclumulation mode [ 1 / s ] +! reciprocal condensation rate + REAL fconcn_org(blksize) ! Aitken mode [ 1 / s ] +! reciprocal condensation rate + REAL fconca_org(blksize) ! acclumulation mode [ 1 / s ] +! reciprocal condensation rate + REAL dmdt(blksize) ! by particle formation [ ug/m**3 /s ] +! rate of production of new mass concent + REAL dndt(blksize) ! concentration by particle formation [# +! rate of producton of new particle numb + REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ ug/m +! increment of concentration added to + REAL cgrn3(blksize) ! Aitken mode [ 3rd mom/m **3 s ] +! growth rate for 3rd moment for + REAL cgra3(blksize) ! Accumulation mode + +!........... SCRATCH local variables and their descriptions: + +! growth rate for 3rd moment for + + INTEGER lcell + +! LOOP INDEX +! conv rate so2 --> so4 [mom-3/g/s] + REAL chemrat +! conv rate for organics [mom-3/g/s] + REAL chemrat_org + REAL am1n, & ! 1st mom density (nuc, acc modes) [mom_ + am1a + REAL am2n, & ! 2nd mom density (nuc, acc modes) [mom_ + am2a + REAL gnc3n, & ! near-cont fns (nuc, acc) for mom-3 den + gnc3a + REAL gfm3n, & ! free-mol fns (nuc, acc) for mom-3 den + gfm3a +! total reciprocal condensation rate + REAL fconc + + REAL td +! d * tinf (cgs) + REAL*8 & ! Cnstant to force 64 bit evaluation of + one88 + PARAMETER (one88=1.0D0) +! *** variables to set up sulfate and organic condensation rates + +! sulfuric acid vapor at current time step + REAL vapor1 +! chemistry and emissions + REAL vapor2 +! Sulfuric acid vapor prior to addition from +!bs + REAL deltavap +!bs * start update +!bs +! change to vapor at previous time step + REAL diffcorr + +!bs * + REAL csqt_org +!bs * end update +!bs + REAL csqt +!....................................................................... +! begin body of subroutine NUCLCOND + + +!........... Main computational grid-traversal loop nest +!........... for computing condensation and nucleation: + + DO lcell = 1, & + numcells +! *** First moment: + +! 1st loop over NUMCELLS + am1n = cblk(lcell,vnu0)*dgnuc(lcell)*esn04 + am1a = cblk(lcell,vac0)*dgacc(lcell)*esa04 + +!.............. near-continuum factors [ 1 / sec ] +!bs +!bs * adopted from code of FSB +!bs * correction to DIFFSULF and DIFFORG for temperature and pressure +!bs + diffcorr = (pss0/blkprs(lcell))*(blkta(lcell)/273.16)**1. +!bs + gnc3n = cconc*am1n*diffcorr + gnc3a = cconc*am1a*diffcorr + +! *** Second moment: + + am2n = cblk(lcell,vnu0)*dgnuc(lcell)*dgnuc(lcell)*esn16 + am2a = cblk(lcell,vac0)*dgacc(lcell)*dgacc(lcell)*esa16 + + csqt = ccofm*sqrt(blkta(lcell)) +!............... free molecular factors [ 1 / sec ] + +! put in temperature fac + gfm3n = csqt*am2n + gfm3a = csqt*am2a + +! *** Condensation factors in [ s**-1] for h2so4 +! *** In the future, separate factors for condensing organics will +! be included. In this version, the h2so4 values are used. + +!............... Twice the harmonic mean of fm, nc functions: +! *** Force 64 bit evaluation: + + fconcn(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n) + fconca(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a) + fconc = fconcn(lcell) + fconca(lcell) + +! *** NOTE: FCONCN and FCONCA will be redefined below <<<<<< +!bs +!bs * start modifications for organcis +!bs + gnc3n = cconc_org*am1n*diffcorr + gnc3a = cconc_org*am1a*diffcorr +!bs + csqt_org = ccofm_org*sqrt(blkta(lcell)) + gfm3n = csqt_org*am2n + gfm3a = csqt_org*am2a +!bs + fconcn_org(lcell) = one88*gnc3n*gfm3n/(gnc3n+gfm3n) + fconca_org(lcell) = one88*gnc3a*gfm3a/(gnc3a+gfm3a) +!bs +!bs * end modifications for organics +!bs +! *** calculate the total change to sulfuric acid vapor from production +! and condensation + + vapor1 = cblk(lcell,vsulf) ! curent sulfuric acid vapor + vapor2 = cblk(lcell,vsulf) - so4rat(lcell)* & + dt +! vapor at prev + vapor2 = max(0.0,vapor2) + deltavap = max(0.0,(so4rat(lcell)/fconc-vapor2)*(1.0-exp(-fconc*dt))) + +! *** Calculate increment in total sufate aerosol mass concentration + +! *** This follows the method of Youngblood & Kreidenweis.!bs +!bs DELTASO4A( LCELL) = MAX( 0.0, SO4RAT(LCELL) * DT - DELTAVAP) +!bs +!bs * allow DELTASO4A to be negative, but the change must not be larger +!bs * than the amount of vapor available. +!bs + deltaso4a(lcell) = max(-1.*cblk(lcell,vsulf), & + so4rat(lcell)*dt-deltavap) + +! *** zero out growth coefficients + cgrn3(lcell) = 0.0 + cgra3(lcell) = 0.0 + + END DO + +! *** Select method of nucleation +! End 1st loop over NUMCELLS + IF (inucl==1) THEN + +! *** Do Youngblood & Kreidenweis Nucleation + +! CALL BCSUINTF(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH, +! & DNDT,DMDT,NUMCELLS,BLKSIZE, +! & VAPOR1) +! IF (firstime) THEN +! WRITE (6,*) +! WRITE (6,'(a,i2)') 'INUCL =', inucl +! WRITE (90,'(a,i2)') 'INUCL =', inucl +! firstime = .FALSE. +! END IF + + ELSE IF (inucl==0) THEN + +! *** Do Kerminen & Wexler Nucleation + +! CALL nuclKW(DT,SO4RAT,FCONCN,FCONCA,BLKTA,BLKRH, +! & DNDT,DMDT,NUMCELLS,BLKSIZE) +! IF (firstime) THEN +! WRITE (6,*) +! WRITE (6,'(a,i2)') 'INUCL =', inucl +! WRITE (90,'(a,i2)') 'INUCL =', inucl +! firstime = .FALSE. +! END IF + + ELSE IF (inucl==2) THEN + +!bs ** Do Kulmala et al. Nucleation +! if(dndt(1).lt.-10.)print *,'before klpnuc',blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1) + + if(blkta(1).ge.233.15.and.blkrh(1).ge.0.1)then + CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1)) + else + dndt(1)=0. + dmdt(1)=0. + endif + +! CALL klpnuc(blkta(1),blkrh(1),vapor1,dndt(1),dmdt(1),so4rat(1)) +! if(dndt(1).lt.-10.)print *,'after klpnuc',dndt(1),dmdt(1) + IF (dndt(1)==0.) dmdt(1) = 0. + IF (dmdt(1)==0.) dndt(1) = 0. +! IF (firstime) THEN +! WRITE (6,*) +! WRITE (6,'(a,i2)') 'INUCL =', inucl +! WRITE (90,'(a,i2)') 'INUCL =', inucl +! firstime = .FALSE. +! END IF +! ELSE +! WRITE (6,'(a)') '*************************************' +! WRITE (6,'(a,i2,a)') ' INUCL =', inucl, ', PLEASE CHECK !!' +! WRITE (6,'(a)') ' PROGRAM TERMINATED !!' +! WRITE (6,'(a)') '*************************************' +! STOP + + END IF +!bs +!bs * Secondary organic aerosol module (SOA_VBS) +!bs +! end of selection of nucleation method + + CALL sorgam_vbs(layer,blkta,blkprs,organt1rat,organt2rat,organt3rat, & + organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, & + nacv,cblk,blksize,nspcsda,numcells,dt,igrid,jgrid,kgrid,brrto ) +!bs +!bs * Secondary organic aerosol module (SOA_VBS) +!bs + DO lcell = 1, numcells + +! *** redefine FCONCN & FCONCA to be the nondimensional fractionaL +! condensation factors + + td = 1.0/(fconcn(lcell)+fconca(lcell)) + fconcn(lcell) = td*fconcn(lcell) + fconca(lcell) = td*fconca(lcell) +!bs + td = 1.0/(fconcn_org(lcell)+fconca_org(lcell)) + fconcn_org(lcell) = td*fconcn_org(lcell) + fconca_org(lcell) = td*fconca_org(lcell) +!bs + END DO + +! *** Begin second loop over cells + + DO lcell = 1,numcells +! *** note CHEMRAT includes species other than sulfate. + +! 3rd loop on NUMCELLS + chemrat = so4fac*so4rat(lcell) ! [mom3 m**-3 s- + chemrat_org = orgfac*(organt1rat(lcell)+organt2rat(lcell)+organt3rat( & + lcell)+organt4rat(lcell)+orgbio1rat(lcell)+orgbio2rat(lcell)+ & + orgbio3rat(lcell)+orgbio4rat(lcell)) + +! *** Calculate the production rates for new particle +! [mom3 m**-3 s- + cgrn3(lcell) = so4fac*dmdt(lcell) +! Rate of increase of 3rd + chemrat = chemrat - cgrn3(lcell) !bs 3rd moment production fro + +!bs Remove the rate of new pa + chemrat = max(chemrat,0.0) +! *** Now calculate the rate of condensation on existing particles. + +! Prevent CHEMRAT from being negativ + cgrn3(lcell) = cgrn3(lcell) + chemrat*fconcn(lcell) + & + chemrat_org*fconcn_org(lcell) + cgra3(lcell) = chemrat*fconca(lcell) + chemrat_org*fconca_org(lcell) +! *** + END DO +! end 2nd loop over NUMCELLS + RETURN + + END SUBROUTINE nuclcond +!------------------------------------------------------------------------------ + +! nuclcond +REAL FUNCTION poly4(a,x) + REAL a(4), x + + poly4 = a(1) + x*(a(2)+x*(a(3)+x*(a(4)))) + RETURN +END FUNCTION poly4 +REAL FUNCTION poly6(a,x) + REAL a(6), x + + poly6 = a(1) + x*(a(2)+x*(a(3)+x*(a(4)+x*(a(5)+x*(a(6)))))) + RETURN +END FUNCTION poly6 +!----------------------------------------------------------------------- + +SUBROUTINE rpmares_old(so4,hno3,no3,nh3,nh4,rh,temp,aso4,ano3,ah2o,anh4, & + gnh3,gno3) +! Description: + +! ARES calculates the chemical composition of a sulfate/nitrate/ +! ammonium/water aerosol based on equilibrium thermodynamics. + +! This code considers two regimes depending upon the molar ratio +! of ammonium to sulfate. + +! For values of this ratio less than 2,the code solves a cubic for +! hydrogen ion molality, HPLUS, and if enough ammonium and liquid +! water are present calculates the dissolved nitric acid. For molal +! ionic strengths greater than 50, nitrate is assumed not to be present + +! For values of the molar ratio of 2 or greater, all sulfate is assumed +! to be ammonium sulfate and a calculation is made for the presence of +! ammonium nitrate. + +! The Pitzer multicomponent approach is used in subroutine ACTCOF to +! obtain the activity coefficients. Abandoned -7/30/97 FSB + +! The Bromley method of calculating the activity coefficients is used in this version + +! The calculation of liquid water is done in subroutine water. Details for both calculations are given +! in the respective subroutines. + +! Based upon MARS due to +! P. Saxena, A.B. Hudischewskyj, C. Seigneur, and J.H. Seinfeld, +! Atmos. Environ., vol. 20, Number 7, Pages 1471-1483, 1986. + +! and SCAPE due to +! Kim, Seinfeld, and Saxeena, Aerosol Ceience and Technology, +! Vol 19, number 2, pages 157-181 and pages 182-198, 1993. + +! NOTE: All concentrations supplied to this subroutine are TOTAL +! over gas and aerosol phases + +! Parameters: + +! SO4 : Total sulfate in MICROGRAMS/M**3 as sulfate (IN) +! HNO3 : Nitric Acid in MICROGRAMS/M**3 as nitric acid (IN) +! NO3 : Total nitrate in MICROGRAMS/M**3 as nitric acid (IN) +! NH3 : Total ammonia in MICROGRAMS/M**3 as ammonia (IN) +! NH4 : Ammonium in MICROGRAMS/M**3 as ammonium (IN) +! RH : Fractional relative humidity (IN) +! TEMP : Temperature in Kelvin (IN) +! GNO3 : Gas phase nitric acid in MICROGRAMS/M**3 (OUT) +! GNH3 : Gas phase ammonia in MICROGRAMS/M**3 (OUT) +! ASO4 : Aerosol phase sulfate in MICROGRAMS/M**3 (OUT) +! ANO3 : Aerosol phase nitrate in MICROGRAMS/M**3 (OUT) +! ANH4 : Aerosol phase ammonium in MICROGRAMS/M**3 (OUT) +! AH2O : Aerosol phase water in MICROGRAMS/M**3 (OUT) +! NITR : Number of iterations for obtaining activity coefficients (OU +! NR : Number of real roots to the cubic in the low ammonia case (OU + +! Revision History: +! Who When Detailed description of changes +! --------- -------- ------------------------------------------- +! S.Roselle 11/10/87 Received the first version of the MARS code +! S.Roselle 12/30/87 Restructured code +! S.Roselle 2/12/88 Made correction to compute liquid-phase +! concentration of H2O2. +! S.Roselle 5/26/88 Made correction as advised by SAI, for +! computing H+ concentration. +! S.Roselle 3/1/89 Modified to operate with EM2 +! S.Roselle 5/19/89 Changed the maximum ionic strength from +! 100 to 20, for numerical stability. +! F.Binkowski 3/3/91 Incorporate new method for ammonia rich case +! using equations for nitrate budget. +! F.Binkowski 6/18/91 New ammonia poor case which +! omits letovicite. +! F.Binkowski 7/25/91 Rearranged entire code, restructured +! ammonia poor case. +! F.Binkowski 9/9/91 Reconciled all cases of ASO4 to be output +! as SO4-- +! F.Binkowski 12/6/91 Changed the ammonia defficient case so that +! there is only neutralized sulfate (ammonium +! sulfate) and sulfuric acid. +! F.Binkowski 3/5/92 Set RH bound on AWAS to 37 % to be in agreemen +! with the Cohen et al. (1987) maximum molalit +! of 36.2 in Table III.( J. Phys Chem (91) page +! 4569, and Table IV p 4587.) +! F.Binkowski 3/9/92 Redid logic for ammonia defficient case to rem +! possibility for denomenator becoming zero; +! this involved solving for HPLUS first. +! Note that for a relative humidity +! less than 50%, the model assumes that there i +! aerosol nitrate. +! F.Binkowski 4/17/95 Code renamed ARES (AeRosol Equilibrium System +! Redid logic as follows +! 1. Water algorithm now follows Spann & Richard +! 2. Pitzer Multicomponent method used +! 3. Multicomponent practical osmotic coefficien +! use to close iterations. +! 4. The model now assumes that for a water +! mass fraction WFRAC less than 50% there is +! no aerosol nitrate. +! F.Binkowski 7/20/95 Changed how nitrate is calculated in ammonia p +! case, and changed the WFRAC criterion to 40%. +! For ammonium to sulfate ratio less than 1.0 +! all ammonium is aerosol and no nitrate aerosol +! exists. +! F.Binkowski 7/21/95 Changed ammonia-ammonium in ammonia poor case +! allow gas-phase ammonia to exist. +! F.Binkowski 7/26/95 Changed equilibrium constants to values from +! Kim et al. (1993) +! F.Binkowski 6/27/96 Changed to new water format +! F.Binkowski 7/30/97 Changed to Bromley method for multicomponent +! activity coefficients. The binary activity coe +! are the same as the previous version +! F.Binkowski 8/1/97 Chenged minimum sulfate from 0.0 to 1.0e-6 i.e +! 1 picogram per cubic meter + +!----------------------------------------------------------------------- +! IMPLICIT NONE +!...........INCLUDES and their descriptions +!cc INCLUDE SUBST_CONST ! constants +!...........PARAMETERS and their descriptions: + +! molecular weight for NaCl + REAL mwnacl + PARAMETER (mwnacl=58.44277) + +! molecular weight for NO3 + REAL mwno3 + PARAMETER (mwno3=62.0049) + +! molecular weight for HNO3 + REAL mwhno3 + PARAMETER (mwhno3=63.01287) + +! molecular weight for SO4 + REAL mwso4 + PARAMETER (mwso4=96.0576) + +! molecular weight for HSO4 + REAL mwhso4 + PARAMETER (mwhso4=mwso4+1.0080) + +! molecular weight for H2SO4 + REAL mh2so4 + PARAMETER (mh2so4=98.07354) + +! molecular weight for NH3 + REAL mwnh3 + PARAMETER (mwnh3=17.03061) + +! molecular weight for NH4 + REAL mwnh4 + PARAMETER (mwnh4=18.03858) + +! molecular weight for Organic Species + REAL mworg + PARAMETER (mworg=175.0) + +! molecular weight for Chloride + REAL mwcl + PARAMETER (mwcl=35.453) + +! molecular weight for AIR + REAL mwair + PARAMETER (mwair=28.964) + +! molecular weight for Letovicite + REAL mwlct + PARAMETER (mwlct=3.0*mwnh4+2.0*mwso4+1.0080) + +! molecular weight for Ammonium Sulfa + REAL mwas + PARAMETER (mwas=2.0*mwnh4+mwso4) + +! molecular weight for Ammonium Bisul + REAL mwabs + PARAMETER (mwabs=mwnh4+mwso4+1.0080) + +!...........ARGUMENTS and their descriptions + +!iamodels3 + REAL so4 +! Total sulfate in micrograms / m**3 +! Total nitric acid in micrograms / m + REAL hno3 +! Total nitrate in micrograms / m**3 + REAL no3 +! Total ammonia in micrograms / m**3 + REAL nh3 +! Total ammonium in micrograms / m**3 + REAL nh4 +! Fractional relative humidity + REAL rh +! Temperature in Kelvin + REAL temp +! Aerosol sulfate in micrograms / m** + REAL aso4 +! Aerosol nitrate in micrograms / m** + REAL ano3 +! Aerosol liquid water content water + REAL ah2o +! Aerosol ammonium in micrograms / m* + REAL anh4 +! Gas-phase nitric acid in micrograms + REAL gno3 + REAL gnh3 +!...........SCRATCH LOCAL VARIABLES and their descriptions: + +! Gas-phase ammonia in micrograms / m +! Index set to percent relative humid + INTEGER irh +! Number of iterations for activity c + INTEGER nitr +! Loop index for iterations + INTEGER nnn + INTEGER nr +! Number of roots to cubic equation f + REAL*8 & ! Coefficients and roots of + a0 + REAL*8 & ! Coefficients and roots of + a1 + REAL*8 & ! Coefficients and roots of + a2 +! Coefficients and discriminant for q + REAL aa +! internal variables ( high ammonia c + REAL bal +! Coefficients and discriminant for q + REAL bb +! Variables used for ammonia solubili + REAL bhat +! Coefficients and discriminant for q + REAL cc +! Factor for conversion of units + REAL convt +! Coefficients and discriminant for q + REAL dd +! Coefficients and discriminant for q + REAL disc +! Relative error used for convergence + REAL eror +! Free ammonia concentration , that + REAL fnh3 +! Activity Coefficient for (NH4+, HSO + REAL gamaab +! Activity coefficient for (NH4+, NO3 + REAL gamaan +! Variables used for ammonia solubili + REAL gamahat +! Activity coefficient for (H+ ,NO3-) + REAL gamana +! Activity coefficient for (2H+, SO4- + REAL gamas1 +! Activity coefficient for (H+, HSO4- + REAL gamas2 +! used for convergence of iteration + REAL gamold +! internal variables ( high ammonia c + REAL gasqd +! Hydrogen ion (low ammonia case) (mo + REAL hplus +! Equilibrium constant for ammoniua t + REAL k1a +! Equilibrium constant for sulfate-bi + REAL k2sa +! Dissociation constant for ammonium + REAL k3 +! Equilibrium constant for ammonium n + REAL kan +! Variables used for ammonia solubili + REAL khat +! Equilibrium constant for nitric aci + REAL kna +! Henry's Law Constant for ammonia + REAL kph +! Equilibrium constant for water diss + REAL kw +! Internal variable using KAN + REAL kw2 +! Nitrate (high ammonia case) (moles + REAL man +! Sulfate (high ammonia case) (moles + REAL mas +! Bisulfate (low ammonia case) (moles + REAL mhso4 +! Nitrate (low ammonia case) (moles / + REAL mna +! Ammonium (moles / kg water) + REAL mnh4 +! Total number of moles of all ions + REAL molnu +! Sulfate (low ammonia case) (moles / + REAL mso4 +! Practical osmotic coefficient + REAL phibar +! Previous value of practical osmotic + REAL phiold +! Molar ratio of ammonium to sulfate + REAL ratio +! Internal variable using K2SA + REAL rk2sa +! Internal variables using KNA + REAL rkna +! Internal variables using KNA + REAL rknwet + REAL rr1 + REAL rr2 +! Ionic strength + REAL stion +! Internal variables for temperature + REAL t1 +! Internal variables for temperature + REAL t2 +! Internal variables of convenience ( + REAL t21 +! Internal variables of convenience ( + REAL t221 +! Internal variables for temperature + REAL t3 +! Internal variables for temperature + REAL t4 +! Internal variables for temperature + REAL t6 +! Total ammonia and ammonium in micro + REAL tnh4 +! Total nitrate in micromoles / meter + REAL tno3 +! Tolerances for convergence test + REAL toler1 +! Tolerances for convergence test + REAL toler2 +! Total sulfate in micromoles / meter + REAL tso4 +! 2.0 * TSO4 (high ammonia case) (mo + REAL twoso4 +! Water mass fraction + REAL wfrac + ! micrograms / meter **3 on output + REAL wh2o + ! internally it is 10 ** (-6) kg (wat + ! the conversion factor (1000 g = 1 k + ! for AH2O output +! Aerosol liquid water content (inter +! internal variables ( high ammonia c + REAL wsqd +! Nitrate aerosol concentration in mi + REAL xno3 +! Variable used in quadratic solution + REAL xxq +! Ammonium aerosol concentration in m + REAL ynh4 +! Water variable saved in case ionic + REAL zh2o + + REAL zso4 +! Total sulfate molality - mso4 + mhs + REAL cat(2) ! Array for cations (1, H+); (2, NH4+ + REAL an(3) ! Array for anions (1, SO4--); (2, NO + REAL crutes(3) ! Coefficients and roots of + REAL gams(2,3) ! Array of activity coefficients +! Minimum value of sulfate laerosol c + REAL minso4 + PARAMETER (minso4=1.0E-6/mwso4) + REAL floor + PARAMETER (floor=1.0E-30) +!----------------------------------------------------------------------- +! begin body of subroutine RPMARES + +!...convert into micromoles/m**3 +!cc WRITE( 10, * ) 'SO4, NO3, NH3 ', SO4, NO3, NH3 +!iamodels3 merge NH3/NH4 , HNO3,NO3 here +! minimum concentration + tso4 = max(0.0,so4/mwso4) + tno3 = max(0.0,(no3/mwno3+hno3/mwhno3)) + tnh4 = max(0.0,(nh3/mwnh3+nh4/mwnh4)) +!cc WRITE( 10, * ) 'TSO4, TNO3, TNH4, RH ', TSO4, TNO3, TNH4, RH + +!...now set humidity index IRH as a percent + + irh = nint(100.0*rh) + +!...Check for valid IRH + + irh = max(1,irh) + irh = min(99,irh) +!cc WRITE(10,*)'RH,IRH ',RH,IRH + +!...Specify the equilibrium constants at correct +!... temperature. Also change units from ATM to MICROMOLE/M**3 (for KA +!... KPH, and K3 ) +!... Values from Kim et al. (1993) except as noted. + + convt = 1.0/(0.082*temp) + t6 = 0.082E-9*temp + t1 = 298.0/temp + t2 = alog(t1) + t3 = t1 - 1.0 + t4 = 1.0 + t2 - t1 + kna = 2.511E+06*exp(29.17*t3+16.83*t4)*t6 + k1a = 1.805E-05*exp(-1.50*t3+26.92*t4) + k2sa = 1.015E-02*exp(8.85*t3+25.14*t4) + kw = 1.010E-14*exp(-22.52*t3+26.92*t4) + kph = 57.639*exp(13.79*t3-5.39*t4)*t6 +!cc K3 = 5.746E-17 * EXP( -74.38 * T3 + 6.12 * T4 ) * T6 * T6 + khat = kph*k1a/kw + kan = kna*khat + +!...Compute temperature dependent equilibrium constant for NH4NO3 +!... ( from Mozurkewich, 1993) + k3 = exp(118.87-24084.0/temp-6.025*alog(temp)) + +!...Convert to (micromoles/m**3) **2 + k3 = k3*convt*convt + wh2o = 0.0 + stion = 0.0 + ah2o = 0.0 + mas = 0.0 + man = 0.0 + hplus = 0.0 + toler1 = 0.00001 + toler2 = 0.001 + nitr = 0 + nr = 0 + ratio = 0.0 + gamaan = 1.0 + gamold = 1.0 + +!...set the ratio according to the amount of sulfate and nitrate + IF (tso4>minso4) THEN + ratio = tnh4/tso4 + +!...If there is no sulfate and no nitrate, there can be no ammonium +!... under the current paradigm. Organics are ignored in this version. + + ELSE + + IF (tno3==0.0) THEN + +! *** If there is very little sulfate and no nitrate set concentrations +! to a very small value and return. + aso4 = max(floor,aso4) + ano3 = max(floor,ano3) + wh2o = 0.0 + ah2o = 0.0 + gnh3 = max(floor,gnh3) + gno3 = max(floor,gno3) + RETURN + END IF + +!...For the case of no sulfate and nonzero nitrate, set ratio to 5 +!... to send the code to the high ammonia case + + ratio = 5.0 + END IF + +!.................................... +!......... High Ammonia Case ........ +!.................................... + + IF (ratio>2.0) THEN + + gamaan = 0.1 + +!...Set up twice the sulfate for future use. + + twoso4 = 2.0*tso4 + xno3 = 0.0 + ynh4 = twoso4 + +!...Treat different regimes of relative humidity + +!...ZSR relationship is used to set water levels. Units are +!... 10**(-6) kg water/ (cubic meter of air) +!... start with ammomium sulfate solution without nitrate + + CALL awater(irh,tso4,ynh4,tno3,ah2o) !**** note TNO3 + wh2o = 1.0E-3*ah2o + aso4 = tso4*mwso4 + ano3 = 0.0 + anh4 = ynh4*mwnh4 + wfrac = ah2o/(aso4+anh4+ah2o) +!cc IF ( WFRAC .EQ. 0.0 ) RETURN ! No water + IF (wfrac<0.2) THEN + +!... dry ammonium sulfate and ammonium nitrate +!... compute free ammonia + + fnh3 = tnh4 - twoso4 + cc = tno3*fnh3 - k3 + +!...check for not enough to support aerosol + + IF (cc<=0.0) THEN + xno3 = 0.0 + ELSE + aa = 1.0 + bb = -(tno3+fnh3) + disc = bb*bb - 4.0*cc + +!...Check for complex roots of the quadratic +!... set nitrate to zero and RETURN if complex roots are found + + IF (disc<0.0) THEN + xno3 = 0.0 + ah2o = 1000.0*wh2o + ynh4 = twoso4 + gno3 = tno3*mwhno3 + gnh3 = (tnh4-ynh4)*mwnh3 + aso4 = tso4*mwso4 + ano3 = 0.0 + anh4 = ynh4*mwnh4 + RETURN + END IF + +!...to get here, BB .lt. 0.0, CC .gt. 0.0 always + + dd = sqrt(disc) + xxq = -0.5*(bb+sign(1.0,bb)*dd) + +!...Since both roots are positive, select smaller root. + + xno3 = min(xxq/aa,cc/xxq) + + END IF + ah2o = 1000.0*wh2o + ynh4 = 2.0*tso4 + xno3 + gno3 = (tno3-xno3)*mwhno3 + gnh3 = (tnh4-ynh4)*mwnh3 + aso4 = tso4*mwso4 + ano3 = xno3*mwno3 + anh4 = ynh4*mwnh4 + RETURN + + END IF + +!...liquid phase containing completely neutralized sulfate and +!... some nitrate. Solve for composition and quantity. + + mas = tso4/wh2o + man = 0.0 + xno3 = 0.0 + ynh4 = twoso4 + phiold = 1.0 + +!...Start loop for iteration + +!...The assumption here is that all sulfate is ammonium sulfate, +!... and is supersaturated at lower relative humidities. + + DO nnn = 1, 150 + nitr = nnn + gasqd = gamaan*gamaan + wsqd = wh2o*wh2o + kw2 = kan*wsqd/gasqd + aa = 1.0 - kw2 + bb = twoso4 + kw2*(tno3+tnh4-twoso4) + cc = -kw2*tno3*(tnh4-twoso4) + +!...This is a quadratic for XNO3 [MICROMOLES / M**3] of nitrate in solut + + disc = bb*bb - 4.0*aa*cc + +!...Check for complex roots, if so set nitrate to zero and RETURN + + IF (disc<0.0) THEN + xno3 = 0.0 + ah2o = 1000.0*wh2o + ynh4 = twoso4 + gno3 = tno3*mwhno3 + gnh3 = (tnh4-ynh4)*mwnh3 + aso4 = tso4*mwso4 + ano3 = 0.0 + anh4 = ynh4*mwnh4 +!cc WRITE( 10, * ) ' COMPLEX ROOTS ' + RETURN + END IF + + dd = sqrt(disc) + xxq = -0.5*(bb+sign(1.0,bb)*dd) + +!KW PMA + aa=max(aa,1.e-20) + xxq=max(xxq,1.e-20) + + rr1 = xxq/aa + rr2 = cc/xxq + +!...choose minimum positve root + + IF ((rr1*rr2)<0.0) THEN + xno3 = max(rr1,rr2) + ELSE + xno3 = min(rr1,rr2) + END IF + xno3 = min(xno3,tno3) + +!...This version assumes no solid sulfate forms (supersaturated ) +!... Now update water + + CALL awater(irh,tso4,ynh4,xno3,ah2o) + +!...ZSR relationship is used to set water levels. Units are +!... 10**(-6) kg water/ (cubic meter of air) +!... The conversion from micromoles to moles is done by the units of WH + + wh2o = 1.0E-3*ah2o + +!...Ionic balance determines the ammonium in solution. + + man = xno3/wh2o + mas = tso4/wh2o + mnh4 = 2.0*mas + man + ynh4 = mnh4*wh2o + +!...MAS, MAN and MNH4 are the aqueous concentrations of sulfate, nitrate +!... and ammonium in molal units (moles/(kg water) ). +!KW PMA adds avoid cat and an to be < 0 + stion = 3.0*mas + man + cat(1) = 0.0 +! cat(2) = mnh4 +! an(1) = mas +! an(2) = man + cat(2) = max(mnh4,0.0) + an(1) = max(mas,0.0) + an(2) = max(man,0.0) + an(3) = 0.0 + CALL actcof(cat,an,gams,molnu,phibar) + gamaan = gams(2,2) + +!...Use GAMAAN for convergence control + + eror = abs(gamold-gamaan)/gamold + gamold = gamaan + +!...Check to see if we have a solution + + IF (eror<=toler1) THEN +!cc WRITE( 11, * ) RH, STION, GAMS( 1, 1 ),GAMS( 1, 2 ), GAMS +!cc & GAMS( 2, 1 ), GAMS( 2, 2 ), GAMS( 2, 3 ), PHIBAR + + aso4 = tso4*mwso4 + ano3 = xno3*mwno3 + anh4 = ynh4*mwnh4 + gno3 = (tno3-xno3)*mwhno3 + gnh3 = (tnh4-ynh4)*mwnh3 + ah2o = 1000.0*wh2o + RETURN + END IF + + END DO + +!...If after NITR iterations no solution is found, then: + + aso4 = tso4*mwso4 + ano3 = 0.0 + ynh4 = twoso4 + anh4 = ynh4*mwnh4 + CALL awater(irh,tso4,ynh4,xno3,ah2o) + gno3 = tno3*mwhno3 + gnh3 = (tnh4-ynh4)*mwnh3 + RETURN + + ELSE +!...................................... +!......... Low Ammonia Case ........... +!...................................... + +!...coded by Dr. Francis S. Binkowski 12/8/91.(4/26/95) + +!...All cases covered by this logic + wh2o = 0.0 + CALL awater(irh,tso4,tnh4,tno3,ah2o) + wh2o = 1.0E-3*ah2o + zh2o = ah2o +!...convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate +!... per cubic meter of air (1000 g = 1 kg) + + aso4 = tso4*mwso4 + anh4 = tnh4*mwnh4 + ano3 = 0.0 + gno3 = tno3*mwhno3 + gnh3 = 0.0 + +!...Check for zero water. + IF (wh2o==0.0) RETURN + zso4 = tso4/wh2o + +!...ZSO4 is the molality of total sulfate i.e. MSO4 + MHSO4 + +!cc IF ( ZSO4 .GT. 11.0 ) THEN + +!...do not solve for aerosol nitrate for total sulfate molality +!... greater than 11.0 because the model parameters break down +!... greater than 9.0 because the model parameters break down + + IF (zso4>9.0) & ! 18 June 97 + THEN + RETURN + END IF + +!...First solve with activity coeffs of 1.0, then iterate. + phiold = 1.0 + gamana = 1.0 + gamas1 = 1.0 + gamas2 = 1.0 + gamaab = 1.0 + gamold = 1.0 + +!...All ammonia is considered to be aerosol ammonium. + mnh4 = tnh4/wh2o + +!...MNH4 is the molality of ammonium ion. + ynh4 = tnh4 + +!...loop for iteration + DO nnn = 1, 150 + nitr = nnn + +!...set up equilibrium constants including activities +!... solve the system for hplus first then sulfate & nitrate +! print*,'gamas,gamana',gamas1,gamas2,gamana + rk2sa = k2sa*gamas2*gamas2/(gamas1*gamas1*gamas1) + rkna = kna/(gamana*gamana) + rknwet = rkna*wh2o + t21 = zso4 - mnh4 + t221 = zso4 + t21 + +!...set up coefficients for cubic + + a2 = rk2sa + rknwet - t21 + a1 = rk2sa*rknwet - t21*(rk2sa+rknwet) - rk2sa*zso4 - rkna*tno3 + a0 = -(t21*rk2sa*rknwet+rk2sa*rknwet*zso4+rk2sa*rkna*tno3) + + CALL cubic(a2,a1,a0,nr,crutes) + +!...Code assumes the smallest positive root is in CRUTES(1) + + hplus = crutes(1) + bal = hplus**3 + a2*hplus**2 + a1*hplus + a0 + mso4 = rk2sa*zso4/(hplus+rk2sa) ! molality of sulfat + mhso4 = zso4 - & ! molality of bisulf + mso4 + mna = rkna*tno3/(hplus+rknwet) ! molality of nitrat + mna = max(0.0,mna) + mna = min(mna,tno3/wh2o) + xno3 = mna*wh2o + ano3 = mna*wh2o*mwno3 + gno3 = (tno3-xno3)*mwhno3 + +!...Calculate ionic strength + stion = 0.5*(hplus+mna+mnh4+mhso4+4.0*mso4) + +!...Update water + CALL awater(irh,tso4,ynh4,xno3,ah2o) + +!...Convert 10**(-6) kg water/(cubic meter of air) to micrograms of wate +!... per cubic meter of air (1000 g = 1 kg) +!KW PMA adds checker to avoid cat and an < 0.0 + + wh2o = 1.0E-3*ah2o + cat(1) = max(hplus,0.0) + cat(2) = max(mnh4,0.0) + an(1) = max(mso4,0.0) + an(2) = max(mna,0.0) + an(3) = max(mhso4,0.0) +! cat(1) = hplus +! cat(2) = mnh4 +! an(1) = mso4 +! an(2) = mna +! an(3) = mhso4 +! print*,'actcof',cat(1),cat(2),an(1),an(2),an(3),gams,molnu,phibar + CALL actcof(cat,an,gams,molnu,phibar) + + gamana = gams(1,2) + gamas1 = gams(1,1) + gamas2 = gams(1,3) + gamaan = gams(2,2) + + gamahat = (gamas2*gamas2/(gamaab*gamaab)) + bhat = khat*gamahat +!cc EROR = ABS ( ( PHIOLD - PHIBAR ) / PHIOLD ) +!cc PHIOLD = PHIBAR + eror = abs(gamold-gamahat)/gamold + gamold = gamahat + +!...write out molalities and activity coefficient +!... and return with good solution + + IF (eror<=toler2) THEN +!cc WRITE(12,*) RH, STION,HPLUS,ZSO4,MSO4,MHSO4,MNH4,MNA +!cc WRITE(11,*) RH, STION, GAMS(1,1),GAMS(1,2),GAMS(1,3), +!cc & GAMS(2,1),GAMS(2,2),GAMS(2,3), PHIBAR + RETURN + END IF + + END DO + +!...after NITR iterations, failure to solve the system, no ANO3 + + gno3 = tno3*mwhno3 + ano3 = 0.0 + CALL awater(irh,tso4,tnh4,tno3,ah2o) + RETURN + + END IF +! ratio .gt. 2.0 +END SUBROUTINE rpmares_old + +!ia********************************************************* +!ia * +!ia BEGIN OF AEROSOL ROUTINE * +!ia * +!ia********************************************************* + +!*********************************************************************** +! BEGIN OF AEROSOL CALCULATIONS +!*********************************************************************** +!ia * +!ia MAIN AEROSOL DYNAMICS ROUTINE * +!ia based on MODELS3 formulation by FZB * +!ia Modified by IA in May 97 * +!ia THIS PROGRAMME IS THE LINK BETWEEN GAS PHASE AND AEROSOL PHASE +!ia CALCULATIONS IN THE COLUMN MODEL. IT CONVERTS ALL DATA AND +!ia VARIABLES BETWEEN THE TWO PARTS AND DRIVES THE AEROSOL +!ia CALCULATIONS. +!ia INPUT DATA REQUIRED FOR AEROSOL DYNAMICS ARE SET UP HERE FOR +!ia ONE GRID CELL!!!! +!ia and passed to dynamics calcs. subroutines. +!ia * +!ia Revision history * +!ia When WHO WHAT * +!ia ---- ---- ---- * +!ia ???? FZB BEGIN * +!ia 05/97 IA Adapted for use in CTM2-S * +!ia Modified renaming/bug fixing * +!ia 11/97 IA Modified for new model version +!ia see comments under iarev02 +!ia 03/98 IA corrected error on pressure units +!ia * +!ia Called BY: CHEM * +!ia * +!ia Calls to: OUTPUT1,AEROPRC * +!ia * +!ia********************************************************************* + +! end RPMares +! convapr_in is removed, it wasn't used indeed + SUBROUTINE rpmmod3(nspcsda,blksize,layer,dtsec,pres,temp,relhum, & + nitrate_in,nh3_in,vsulf_in,so4rat_in,drog_in,ldrog_vbs,ncv, & + nacv,eeci_in,eecj_in,eorgi_in,eorgj_in,epm25i,epm25j,epmcoarse, & + soilrat_in,cblk,igrid,jgrid,kgrid,brrto) + +!USE module_configure, only: grid_config_rec_type +!TYPE (grid_config_rec_type), INTENT (in) :: config_flags + +! IMPLICIT NONE + +! Includes: +!iarev02 INCLUDE AEROINCL.EXT +! block size, set to 1 in column model ciarev0 + INTEGER blksize +!ia kept to 1 in current version of column model +! actual number of cells in arrays ( default is + INTEGER, PARAMETER :: numcells=1 + + INTEGER layer +! number of layer (default is 1 in + +! index for cell in blocked array (default is 1 in + INTEGER, PARAMETER :: ncell=1 +! *** inputs +! Input temperature [ K ] + REAL temp +! Input relative humidity [ fraction ] + REAL relhum +! Input pressure [ hPa ] + REAL pres +! Input number for Aitken mode [ m**-3 ] + REAL numnuc_in +! Input number for accumulation mode [ m**-3 ] + REAL numacc_in +! Input number for coarse mode [ m**-3 ] + REAL numcor_in + ! sulfuric acid [ ug m**-3 ] + REAL vsulf_in +! total sulfate vapor as sulfuric acid as + ! sulfuric acid [ ug m**-3 ] + REAL asulf_in +! total sulfate aerosol as sulfuric acid as +! i-mode sulfate input as sulfuric acid [ ug m* + REAL asulfi_in +! ammonia gas [ ug m**-3 ] + REAL nh3_in +! input value of nitric acid vapor [ ug m**-3 ] + REAL nitrate_in +! Production rate of sulfuric acid [ ug m**-3 + REAL so4rat_in + ! aerosol [ ug m**-3 s**-1 ] + REAL soilrat_in +! Production rate of soil derived coarse +! Emission rate of i-mode EC [ug m**-3 s**-1] + REAL eeci_in +! Emission rate of j-mode EC [ug m**-3 s**-1] + REAL eecj_in +! Emission rate of j-mode org. aerosol [ug m**- + REAL eorgi_in + REAL eorgj_in +! Emission rate of j-mode org. aerosol [ug m**- +! total # of cond. vapors & SOA species + INTEGER ncv +! # of anthrop. cond. vapors & SOA speci + INTEGER nacv +! # of organic aerosol precursor + INTEGER ldrog_vbs + REAL drog_in(ldrog_vbs) ! organic aerosol precursor [ppm] +! Input delta ROG concentration of + REAL condvap_in(ncv) ! cond. vapor input [ug m^-3] + REAL drog(blksize,ldrog_vbs) ! organic aerosol precursor [ppm] + + REAL brrto +!bs +! *** Primary emissions rates: [ ug / m**3 s ] + +! *** emissions rates for unidentified PM2.5 mass +! Delta ROG concentration of + REAL epm25i(blksize) ! Aitken mode + REAL epm25j(blksize) +! *** emissions rates for primary organic aerosol +! Accumululaton mode + REAL eorgi(blksize) ! Aitken mode + REAL eorgj(blksize) +! *** emissions rates for elemental carbon +! Accumululaton mode + REAL eeci(blksize) ! Aitken mode + REAL eecj(blksize) +! *** Primary emissions rates [ ug m**-3 s -1 ] : + +! Accumululaton mode + REAL epm25(blksize) ! emissions rate for PM2.5 mass + REAL esoil(blksize) ! emissions rate for soil derived coarse a + REAL eseas(blksize) ! emissions rate for marine coarse aerosol + REAL epmcoarse(blksize) +! emissions rate for anthropogenic coarse + + REAL dtsec +! time step [ s ], PASSED FROM MAIN COLUMN MODE + + REAL newm3 + REAL totaersulf +! total aerosol sulfate +! loop index for time steps + INTEGER numsteps + REAL step + +! *** arrays for aerosol model codes: + +! synchronization time [s] + + INTEGER nspcsda + +! number of species in CBLK ciarev02 + REAL cblk(blksize,nspcsda) + +! *** Meteorological information in blocked arays: + +! *** Thermodynamic variables: + +! main array of variables + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkprs(blksize) ! Air pressure in [ Pa ] + REAL blkdens(blksize) ! Air density [ kg m^-3 ] + REAL blkrh(blksize) + +! *** Chemical production rates [ ug m**-3 s -1 ] : + +! Fractional relative humidity + REAL so4rat(blksize) ! rate [ug/m^3/s] +! sulfuric acid vapor-phase production + REAL organt1rat(blksize) ! production rate from aromatics [ ug / +! anthropogenic organic aerosol mass + REAL organt2rat(blksize) ! production rate from aromatics [ ug / +! anthropogenic organic aerosol mass + REAL organt3rat(blksize) ! rate from alkanes & others [ ug / m^3 +! anthropogenic organic aerosol mass pro + REAL organt4rat(blksize) ! rate from alkanes & others [ ug / m^3 +! anthropogenic organic aerosol mass pro + REAL orgbio1rat(blksize) ! rate [ ug / m^3 s ] +! biogenic organic aerosol production + REAL orgbio2rat(blksize) ! rate [ ug / m^3 s ] +! biogenic organic aerosol production + REAL orgbio3rat(blksize) ! rate [ ug / m^3 s ] +! biogenic organic aerosol production + REAL orgbio4rat(blksize) ! rate [ ug / m^3 s ] +!bs +! *** atmospheric properties + +! biogenic organic aerosol production + REAL xlm(blksize) ! atmospheric mean free path [ m ] + REAL amu(blksize) +! *** aerosol properties: + +! *** modal diameters: + +! atmospheric dynamic viscosity [ kg + REAL dgnuc(blksize) ! nuclei mode geometric mean diamete + REAL dgacc(blksize) ! accumulation geometric mean diamet + REAL dgcor(blksize) + +! *** Modal mass concentrations [ ug m**3 ] + +! coarse mode geometric mean diamete + REAL pmassn(blksize) ! mass concentration in Aitken mode + REAL pmassa(blksize) ! mass concentration in accumulation + REAL pmassc(blksize) +! *** average modal particle densities [ kg/m**3 ] + +! mass concentration in coarse mode + REAL pdensn(blksize) ! average particle density in nuclei + REAL pdensa(blksize) ! average particle density in accumu + REAL pdensc(blksize) +! *** average modal Knudsen numbers + +! average particle density in coarse + REAL knnuc(blksize) ! nuclei mode Knudsen number + REAL knacc(blksize) ! accumulation Knudsen number + REAL kncor(blksize) +! *** reciprocal modal condensation rates for sulfuric acid [ 1/s ] + +! coarse mode Knudsen number + REAL fconcn(blksize) +! reciprocal condensation rate Aitke + REAL fconca(blksize) !bs +! reciprocal condensation rate acclu + REAL fconcn_org(blksize) + REAL fconca_org(blksize) + +! *** Rates for secondary particle formation: + +! *** production of new mass concentration [ ug/m**3 s ] + REAL dmdt(blksize) ! by particle formation + +! *** production of new number concentration [ number/m**3 s ] + +! rate of production of new mass concen + REAL dndt(blksize) ! by particle formation +! *** growth rate for third moment by condensation of precursor +! vapor on existing particles [ 3rd mom/m**3 s ] + +! rate of producton of new particle num + REAL cgrn3(blksize) ! Aitken mode + REAL cgra3(blksize) +! *** Rates for coaglulation: [ m**3/s ] + +! *** Unimodal Rates: + +! Accumulation mode + REAL urn00(blksize) ! Aitken mode 0th moment self-coagulation ra + REAL ura00(blksize) + +! *** Bimodal Rates: Aitken mode with accumulation mode ( Aitken mode) +! accumulation mode 0th moment self-coagulat + REAL brna01(blksize) ! rate for 0th moment + REAL brna31(blksize) +! *** other processes + +! rate for 3rd moment + REAL deltaso4a(blksize) ! sulfate aerosol by condensation [ u + +! *** housekeeping variables: +! increment of concentration added to + INTEGER unit + PARAMETER (unit=30) + CHARACTER*16 pname + PARAMETER (pname=' BOX ') + INTEGER isp,igrid,jgrid,kgrid + +! loop index for species. + INTEGER ii, iimap(8) + DATA iimap/1, 2, 18, 19, 21, 22, 23, 24/ + +! begin body of program box + +! *** Set up files and other info +! *** set up experimental conditions +! *** initialize model variables +!ia *** not required any more + +!ia DO ISP = 1, NSPCSDA +!ia CBLK(BLKSIZE,ISP) = 1.0e-19 ! set CBLK to a very small number +!ia END DO + + step = dtsec ! set time step + + blkta(blksize) = temp ! T in Kelvin + + blkprs(blksize)= pres*100. ! P in Pa (pres is given in + + blkrh(blksize) = relhum ! fractional RH + + blkdens(blksize) = blkprs(blksize)/(rdgas*blkta(blksize)) !rs CBLK(BLKSIZE,VSULF) = vsulf_in + +!rs CBLK(BLKSIZE,VHNO3) = nitrate_in +!rs CBLK(BLKSIZE,VNH3) = nh3_in +!bs +!rs CBLK(BLKSIZE,VCVARO1) = condvap_in(PSOAARO1) +!rs CBLK(BLKSIZE,VCVARO2) = condvap_in(PSOAARO2) +!rs CBLK(BLKSIZE,VCVALK1) = condvap_in(PSOAALK1) +!rs CBLK(BLKSIZE,VCVOLE1) = condvap_in(PSOAOLE1) +!rs CBLK(BLKSIZE,VCVAPI1) = condvap_in(PSOAAPI1) +!rs CBLK(BLKSIZE,VCVAPI2) = condvap_in(PSOAAPI2) +!rs CBLK(BLKSIZE,VCVLIM1) = condvap_in(PSOALIM1) +!rs CBLK(BLKSIZE,VCVLIM2) = condvap_in(PSOALIM2) + + DO isp = 1, ldrog_vbs + drog(blksize,isp) = drog_in(isp) + END DO + +! print*,'drog in rpm',drog +!bs +!ia *** 27/05/97 the following variables are transported quantities +!ia *** of the column-model now and thuse do not need this init. +!ia *** step. + +! CBLK(BLKSIZE,VNU0) = numnuc_in +! CBLK(BLKSIZE,VAC0) = numacc_in +! CBLK(BLKSIZE,VSO4A) = asulf_in +! CBLK(BLKSIZE,VSO4AI) = asulfi_in +! CBLK(BLKSIZE, VCORN) = numcor_in + + so4rat(blksize) = so4rat_in + +!...INITIALISE EMISSION RATES + +! epm25i(blksize) = & ! unidentified PM2.5 mass +! 0.0 +! epm25j(blksize) = & +! 0.0 +! unidentified PM2.5 m + eorgi(blksize) = & ! primary organic + eorgi_in + eorgj(blksize) = & + eorgj_in +! primary organic + eeci(blksize) = & ! elemental carbon + eeci_in + eecj(blksize) = & + eecj_in +! elemental carbon + epm25(blksize) = & !currently from input file ACTIONIA + 0.0 + esoil(blksize) = & ! ACTIONIA + soilrat_in + eseas(blksize) = & !currently from input file ACTIONIA + 0.0 +! epmcoarse(blksize) = & !currently from input file ACTIONIA +! 0.0 + dgnuc(blksize) = dginin + dgacc(blksize) = dginia + dgcor(blksize) = dginic + newm3 = 0.0 + +! *** Set up initial total 3rd moment factors + + totaersulf = 0.0 + newm3 = 0.0 +! *** time loop +! write(50,*) ' numsteps dgnuc dgacc ', ' aso4 aso4i Ni Nj ah2o ah2oi M3i m3j' + +! *** Call aerosol routines + CALL aeroproc(blksize,nspcsda,numcells,layer,cblk,step,blkta,blkprs, & + blkdens,blkrh,so4rat,organt1rat,organt2rat,organt3rat, & + organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, & + nacv,epm25i,epm25j,eorgi,eorgj,eeci,eecj,epmcoarse,esoil,eseas,xlm, & + amu,dgnuc,dgacc,dgcor,pmassn,pmassa,pmassc,pdensn,pdensa,pdensc,knnuc, & + knacc,kncor,fconcn,fconca,fconcn_org,fconca_org,dmdt,dndt,cgrn3,cgra3, & + urn00,ura00,brna01,brna31,deltaso4a,igrid,jgrid,kgrid,brrto) + +! *** write output +! WRITE(UNIT,*) ' AFTER AEROPROC ' +! WRITE(UNIT,*) ' NUMSTEPS = ', NUMSTEPS + +! *** Write out file for graphing. + +! write(50,*) NUMSTEPS, DGNUC,DGACC,(CBLK(1,iimap(ii)),ii=1,8) + + +! *** update sulfuric acid vapor +!ia 21.04.98 this update is not required here +!ia artefact from box model +! CBLK(BLKSIZE,VSULF) = CBLK(BLKSIZE,VSULF) + +! & SO4RAT(BLKSIZE) * STEP + + RETURN +END SUBROUTINE rpmmod3 +!--------------------------------------------------------------------------- +SUBROUTINE sorgam_vbs(layer,blkta,blkprs,organt1rat,organt2rat,organt3rat, & + organt4rat,orgbio1rat,orgbio2rat,orgbio3rat,orgbio4rat,drog,ldrog_vbs,ncv, & + nacv,cblk,blksize,nspcsda,numcells,dt,igrid,jgrid,kgrid,brrto) + +!***** SM ** ** SM ** SM ** ** SM ** SM ** ** SM ** SM ** ** SM ** SM *! +!bs Description: ! +!bs ! +!bs SOA_VBS calculates the formation and partitioning of secondary ! +!bs organic aerosol based on (pseudo-)ideal solution thermodynamics. ! +!bs ! +!sam The original Schell model (JGR, vol. 106, D22, 28275-28293, 2001) ! +!sam is modified drastically to incorporate the SOA vapor-pressure ! +!sam basis set approach developed by Carnegie Mellon folks. ! +!sam Recommended changes according to Allen Robinson, 9/15/09 ! +!sam The treatment is done very similar to Lane et al., Atmos. Envrn., ! +!sam vol 42, 7439-7451, 2008. ! +!sam Four basis vapor-pressures for anthropogenic and 4 basis vp's ! +!sam for biogenic SOA are used. The SAPRC-99 yield information for ! +!sam low and high NOx conditions (Lane, Donahue and Pandis, ES&T, ! +!sam vol. 42, 6022-6027, 2008) are mapped to RADM2/RACM species. ! +!sam ! +!sam Basis vapor pressures (@ 300K) ! +!sam Anthro (1 ug/m3) - asoa1 Biogenic (1 ug/m3) - bsoa1 ! +!sam Anthro (10 ug/m3) - asoa2 Biogenic (10 ug/m3) - bsoa2 ! +!sam Anthro (100 ug/m3) - asoa3 Biogenic (100 ug/m3) - bsoa3 ! +!sam Anthro (1000 ug/m3)- asoa4 Biogenic (1000 ug/m3)- bsoa4 ! +!bs ! +!bs This code considers two cases: ! +!bs i) initil absorbing mass is existend in the aerosol phase ! +!bs ii) a threshold has to be exeeded before partitioning (even below ! +!bs saturation) will take place. ! +!bs ! +!bs The temperature dependence of the saturation concentrations are ! +!bs calculated using the Clausius-Clapeyron equation. ! +!bs ! +!bs If there is no absorbing mass at all the Pandis method is applied ! +!bs for the first steps. ! +!bs ! +!bs References: ! +!bs Pankow (1994): ! +!bs An absorption model of the gas/aerosol ! +!bs partitioning involved in the formation of ! +!bs secondary organic aerosol, Atmos. Environ. 28(2), ! +!bs 189-193. ! +!bs Odum et al. (1996): ! +!bs Gas/particle partitioning and secondary organic ! +!bs aerosol yields, Environ. Sci. Technol. 30, ! +!bs 2580-2585. ! +!bs see also ! +!bs Bowman et al. (1997): ! +!bs Mathematical model for gas-particle partitioning ! +!bs of secondary organic aerosols, Atmos. Environ. ! +!bs 31(23), 3921-3931. ! +!bs Seinfeld and Pandis (1998): ! +!bs Atmospheric Chemistry and Physics (0-471-17816-0) ! +!bs chapter 13.5.2 Formation of binary ideal solution ! +!bs with -- preexisting aerosol ! +!bs -- other organic vapor ! +!bs ! +!bs Called by: SOA_VBS ! +!bs ! +!bs Calls: None ! +!bs ! +!bs Arguments: LAYER, ! +!bs BLKTA, BLKPRS, ! +!bs ORGARO1RAT, ORGARO2RAT, ! +!bs ORGALK1RAT, ORGOLE1RAT, ! +!bs ORGBIO1RAT, ORGBIO2RAT, ! +!bs ORGBIO3RAT, ORGBIO4RAT, ! +!bs DROG, LDROG, NCV, NACV, ! +!bs CBLK, BLKSIZE, NSPCSDA, NUMCELLS, ! +!bs DT ! +!bs ! +!bs Include files: AEROSTUFF.EXT ! +!bs AERO_internal.EXT ! +!bs ! +!bs Data: None ! +!bs ! +!bs Input files: None ! +!bs ! +!bs Output files: None ! +!bs ! +!bs--------------------------------------------------------------------! +!bs ! +!bs History: ! +!bs No Date Author Change ! +!bs ____ ______ ________________ _________________________________ ! +! 01 052011 McKeen/Ahmadov Subroutine development ! + + USE module_configure, only: grid_config_rec_type + + ! model layer + INTEGER layer + ! dimension of arrays + INTEGER blksize + ! number of species in CBLK + INTEGER nspcsda ! actual number of cells in arrays + INTEGER numcells ! # of organic aerosol precursor + INTEGER ldrog_vbs ! total # of cond. vapors & SOA sp + INTEGER ncv ! # of anthrop. cond. vapors & SOA + INTEGER nacv + INTEGER igrid,jgrid,kgrid + + REAL cblk(blksize,nspcsda) ! main array of variables + REAL dt ! model time step in SECONDS + REAL blkta(blksize) ! Air temperature [ K ] + REAL blkprs(blksize) ! Air pressure in [ Pa ] + + REAL, INTENT(OUT) :: brrto ! branching ratio for NOx conditions + + ! anthropogenic organic vapor production rates + + REAL organt1rat(blksize) ! rates from + REAL organt2rat(blksize) ! rates from + REAL organt3rat(blksize) ! rates from + REAL organt4rat(blksize) ! rates from + + ! biogenic organic vapor production rates + REAL orgbio1rat(blksize) + REAL orgbio2rat(blksize) + REAL orgbio3rat(blksize) + REAL orgbio4rat(blksize) + REAL drog(blksize,ldrog_vbs) !blksize=1, ldrog_vbs=9+1, the last ldrog_vbs is actually is the branching ratio + + !bs * local variable declaration + ! Delta ROG conc. [ppm] + !bs numerical value for a minimum thresh + REAL,PARAMETER :: thrsmin=1.E-19 + !bs numerical value for a minimum thresh + !bs + !bs universal gas constant [J/mol-K] + REAL, PARAMETER :: rgas=8.314510 + + !sam reference temperature T0 = 300 K, a change from original 298K + REAL, PARAMETER :: tnull=300. + + !bs molecular weight for C + REAL, PARAMETER :: mwc=12.0 + !bs molecular weight for organic species + REAL, PARAMETER :: mworg=175.0 + !bs molecular weight for SO4 + REAL, PARAMETER :: mwso4=96.0576 + !bs molecular weight for NH4 + REAL, PARAMETER :: mwnh4=18.03858 + !bs molecular weight for NO3 + REAL, PARAMETER :: mwno3=62.01287 + ! molecular weight for AIR + +! REAL mwair +! PARAMETER (mwair=28.964) + !bs relative tolerance for mass check + REAL, PARAMETER :: CABSMIN=.00001 ! Minimum amount of absorbing material - needed in iteration method + !sm number of basis set variables in CMU partitioning scheme + INTEGER, PARAMETER :: nbin=4 ! we use 4 bin volatility according to Robinson A. et al. + + ! we have 2 type of SOA - anthropogenic and biogenic + !sm number of SAPRC species variables in CMU lumped partitioning table + !sm 1=ALK4(hc5),2=ALK5(hc8),3=OLE1(ol2),4=OLE2(oli),5=ARO1(tol) + !sm 6=AOR2(xyl),7=ISOP(iso),8=SESQ(?),9=TERP(alp) + INTEGER, PARAMETER :: nsaprc=9 ! number of precursor classes + + !bs loop indices + INTEGER lcell, n, l, ll, bn, cls + !bs conversion factor ppm --> ug/m^3 + REAL convfac + !bs difference of inverse temperatures + REAL ttinv + !bs initial organic absorbing mass [ug/m^3] + REAL minit + !bs inorganic mass [ug/m^3] + REAL mnono + !bs total organic mass [ug/m^3] + REAL mtot + +! REAL msum(ncv) !bs input total mass [ug/m^3] + REAL mwcv(ncv) !bs molecular weight of cond. vapors [g/ + REAL pnull(ncv) !bs vapor pres. of pure cond. vapor [Pa] + REAL dhvap(ncv) !bs heat of vaporisation of compound i [ + REAL pvap(ncv) !bs vapor pressure cond. vapor [Pa] + REAL ctot(ncv) !bs total conc. of cond. vapor aerosol + + REAL cgas(ncv) !bs gasphase concentration of cond. vapors + REAL caer(ncv) !bs aerosolphase concentration of cond. + REAL asav(ncv) !bs saved CAER for iteration + REAL aold(ncv) !bs saved CAER for rate determination + REAL csat(ncv) !bs saturation conc. of cond. vapor ug/, + + ! in basis set approach we need only 4 csat + REAL ccsat(nbin) + REAL ccaer(nbin) + REAL cctot(nbin) + REAL w1(nbin), w2(nbin) + + REAL prod(ncv) !bs production of condensable vapor ug/ + REAL p(ncv) !bs PROD(L) * TIMEFAC [ug/m^3] + REAL f(ldrog_vbs) !bs scaling factor for ind. oxidant + + REAL alphlowN(nbin,nsaprc) ! sm normalized (1 g/m3 density) yield for condensable vapors low NOx condition + REAL alphhiN(nbin,nsaprc) ! sm normalized (1 g/m3 density) yield for condensable vapors high NOx condition + REAL alphai(nbin,nsaprc) ! mass-based stoichometric yield for product i and csti is the effective saturation + ! concentration in ug m^-3 + REAL mwvoc(nsaprc) ! molecular weight of the SOA precusors + + REAL PnGtotal,DUM,FMTOT,FMTOT2,DUM2 ! Real constants used in Newton iteration + integer, save :: icall + + ! this is a correction factor to take into account the density of aerosols, from Murphy et al. (2009) + ! Now it's determined by namelist + + ! in the preliminary version we use alphlowN only to check what would be the maximum yeild + ! SAM: from Murphy et al. 2009 + DATA alphlowN / & + 0.0000, 0.0750, 0.0000, 0.0000, & ! ALK4 + 0.0000, 0.3000, 0.0000, 0.0000, & ! ALK5 + 0.0045, 0.0090, 0.0600, 0.2250, & ! OLE1 + 0.0225, 0.0435, 0.1290, 0.3750, & ! OLE2 + 0.0750, 0.2250, 0.3750, 0.5250, & ! ARO1 + 0.0750, 0.3000, 0.3750, 0.5250, & ! ARO2 + 0.0090, 0.0300, 0.0150, 0.0000, & ! ISOP + 0.0750, 0.1500, 0.7500, 0.9000, & ! SESQ + 0.1073, 0.0918, 0.3587, 0.6075/ ! TERP + + DATA alphhiN / & + 0.0000, 0.0375, 0.0000, 0.0000, & ! ALK4 + 0.0000, 0.1500, 0.0000, 0.0000, & ! ALK5 + 0.0008, 0.0045, 0.0375, 0.1500, & ! OLE1 + 0.0030, 0.0255, 0.0825, 0.2700, & ! OLE2 + 0.0030, 0.1650, 0.3000, 0.4350, & ! ARO1 + 0.0015, 0.1950, 0.3000, 0.4350, & ! ARO2 + 0.0003, 0.0225, 0.0150, 0.0000, & ! ISOP + 0.0750, 0.1500, 0.7500, 0.9000, & ! SESQ + 0.0120, 0.1215, 0.2010, 0.5070/ ! TERP + + DATA mwvoc / & + 73.23, & ! ALK4 + 106.97, & ! ALK5 + 61.68, & ! OLE1 + 79.05, & ! OLE2 + 100.47, & ! ARO1 + 113.93, & ! ARO2 + 68.12, & ! ISOP + 204.0, & ! SESQ + 136.24 / ! TERP + +!bs * initialisation +!bs +!bs * DVAP data: average value calculated from C14-C18 monocarboxylic +!bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989): +!bs * Eniron. Sci. Technol. 1989, 23, 1519-1523. +!bs * average value is 156 kJ/mol +! +!sam changed 156kJ/mol to 30.kJ/mol as in Lane et al., AE, 2008 + dhvap(pasoa1) = 30.0E03 + dhvap(pasoa2) = 30.0E03 + dhvap(pasoa3) = 30.0E03 + dhvap(pasoa4) = 30.0E03 + + dhvap(pbsoa1) = 30.0E03 + dhvap(pbsoa2) = 30.0E03 + dhvap(pbsoa3) = 30.0E03 + dhvap(pbsoa4) = 30.0E03 +!---------------------------------------------------------------- +!bs +!bs * MWCV data: average value calculated from C14-C18 monocarboxylic +!bs * acids and C5-C6 dicarboxylic acids. Tao and McMurray (1989): +!bs * Eniron. Sci. Technol. 1989, 23, 1519-1523. +!bs * average value is 222.5 g/mol +!bs * +!bs * molecular weights used are estimates taking the origin (reactants) +!bs * into account. This should be updated if more information about +!bs * the products is available. +!bs * First hints are taken from Forstner et al. (1997), Environ. S +!bs * Technol. 31(5), 1345-1358. and Forstner et al. (1997), Atmos. +!bs * Environ. 31(13), 1953-1964. +!bs * +! Molecular weights of OCVs as in Murphy and Pandis, 2009 + mwcv(pasoa1) = 150. + mwcv(pasoa2) = 150. + mwcv(pasoa3) = 150. + mwcv(pasoa4) = 150. + + mwcv(pbsoa1) = 180. + mwcv(pbsoa2) = 180. + mwcv(pbsoa3) = 180. + mwcv(pbsoa4) = 180. + +! In Shell partitioned aerosols according to their precursors, but we do as Allen due to the saturation concentrations +! We have 2 sets for anthropogenic and biogenic and therefore we use the same denotation + pnull(pasoa1) = 1. + pnull(pasoa2) = 10. + pnull(pasoa3) = 100. + pnull(pasoa4) = 1000. + + pnull(pbsoa1) = 1. + pnull(pbsoa2) = 10. + pnull(pbsoa3) = 100. + pnull(pbsoa4) = 1000. + +! scaling factors, for testing purposes, check TOL and ISO only +! 05/23/2011: for testing all are zero! +f(palk4) = 1. +f(palk5) = 1. +f(pole1) = 1. +f(pole2) = 1. +f(paro1) = 1. +f(paro2) = 1. +f(pisop) = 1. +f(pterp) = 1. +f(psesq) = 1. + +loop_cells: DO lcell = 1, numcells ! numcells=1 + DO l= 1, ldrog_vbs-1 + drog(lcell,l) = f(l)*drog(lcell,l) + END DO + + ! calculation of the yields using the branching ratio + brrto= drog(lcell,pbrch) ! temporary variable for the branching ratio + DO bn=1,nbin ! bins + DO cls=1,nsaprc ! classes + alphai(bn,cls)= mwvoc(cls)*( alphhiN(bn,cls)*brrto + alphlowN(bn,cls)*(1.-brrto) ) + ENDDO + ENDDO + + ttinv = 1./tnull - 1./blkta(lcell) + convfac = blkprs(lcell)/(rgas*blkta(lcell)) + + ! cblk for gases comes in ppmv, we get the density in ug/m3 (microgram/m3) + ! by multiplying it by (convfac=rho_air/mu_air)x mwcv + cgas(pasoa1) = cblk(lcell,vcvasoa1)*convfac*mwcv(pasoa1) + cgas(pasoa2) = cblk(lcell,vcvasoa2)*convfac*mwcv(pasoa2) + cgas(pasoa3) = cblk(lcell,vcvasoa3)*convfac*mwcv(pasoa3) + cgas(pasoa4) = cblk(lcell,vcvasoa4)*convfac*mwcv(pasoa4) + + cgas(pbsoa1) = cblk(lcell,vcvbsoa1)*convfac*mwcv(pbsoa1) + cgas(pbsoa2) = cblk(lcell,vcvbsoa2)*convfac*mwcv(pbsoa2) + cgas(pbsoa3) = cblk(lcell,vcvbsoa3)*convfac*mwcv(pbsoa3) + cgas(pbsoa4) = cblk(lcell,vcvbsoa4)*convfac*mwcv(pbsoa4) + + ! cblk for aerosols come in density (ug/m3), converted already in soa_vbs_driver + caer(pasoa1) = cblk(lcell,vasoa1j) + cblk(lcell,vasoa1i) + caer(pasoa2) = cblk(lcell,vasoa2j) + cblk(lcell,vasoa2i) + caer(pasoa3) = cblk(lcell,vasoa3j) + cblk(lcell,vasoa3i) + caer(pasoa4) = cblk(lcell,vasoa4j) + cblk(lcell,vasoa4i) + + caer(pbsoa1) = cblk(lcell,vbsoa1j) + cblk(lcell,vbsoa1i) + caer(pbsoa2) = cblk(lcell,vbsoa2j) + cblk(lcell,vbsoa2i) + caer(pbsoa3) = cblk(lcell,vbsoa3j) + cblk(lcell,vbsoa3i) + caer(pbsoa4) = cblk(lcell,vbsoa4j) + cblk(lcell,vbsoa4i) + + ! #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !SAM diagnostics + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! if (igrid .eq. 1 .AND. jgrid .eq. 18) then +! if (kgrid .eq. 1 )then +! write(6,*)'drog', drog +! write(6,*)'caer(pasoa1)',caer(pasoa1) +! write(6,*)'caer(pasoa4)',caer(pasoa4) +! write(6,*)'caer(pbsoa1)',caer(pbsoa1) +! endif +! endif + !SAM end print of aerosol physical parameter diagnostics + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! #endif + ! Production of SOA by oxidation of VOCs + ! There are 6 classes of the precursors for ansthropogenic SOA + prod(pasoa1) = alphai(1,1)*drog(lcell,palk4) + alphai(1,2)*drog(lcell,palk5) + & + alphai(1,3)*drog(lcell,pole1) + alphai(1,4)*drog(lcell,pole2) + & + alphai(1,5)*drog(lcell,paro1) + alphai(1,6)*drog(lcell,paro2) + + prod(pasoa2) = alphai(2,1)*drog(lcell,palk4) + alphai(2,2)*drog(lcell,palk5) + & + alphai(2,3)*drog(lcell,pole1) + alphai(2,4)*drog(lcell,pole2) + & + alphai(2,5)*drog(lcell,paro1) + alphai(2,6)*drog(lcell,paro2) + + prod(pasoa3) = alphai(3,1)*drog(lcell,palk4) + alphai(3,2)*drog(lcell,palk5) + & + alphai(3,3)*drog(lcell,pole1) + alphai(3,4)*drog(lcell,pole2) + & + alphai(3,5)*drog(lcell,paro1) + alphai(3,6)*drog(lcell,paro2) + + prod(pasoa4) = alphai(4,1)*drog(lcell,palk4) + alphai(4,2)*drog(lcell,palk5) + & + alphai(4,3)*drog(lcell,pole1) + alphai(4,4)*drog(lcell,pole2) + & + alphai(4,5)*drog(lcell,paro1) + alphai(4,6)*drog(lcell,paro2) + + ! There are 3 classes of the precursors for biogenic SOA + prod(pbsoa1) = alphai(1,7)*drog(lcell,pisop) + alphai(1,8)*drog(lcell,psesq) + & + alphai(1,9)*drog(lcell,pterp) + + prod(pbsoa2) = alphai(2,7)*drog(lcell,pisop) + alphai(2,8)*drog(lcell,psesq) + & + alphai(2,9)*drog(lcell,pterp) + + prod(pbsoa3) = alphai(3,7)*drog(lcell,pisop) + alphai(3,8)*drog(lcell,psesq) + & + alphai(3,9)*drog(lcell,pterp) + + prod(pbsoa4) = alphai(4,7)*drog(lcell,pisop) + alphai(4,8)*drog(lcell,psesq) + & + alphai(4,9)*drog(lcell,pterp) + +!bs * calculate actual production from gasphase reactions [ug/m^3] +!bs * calculate vapor pressure of pure compound as a liquid using the Clausius-Clapeyron equation and the actual saturation concentration. +!bs * calculate the threshold for partitioning if no initial mass is present to partition into. + + loop_cc: DO l = 1,ncv ! we've total ncv=4*2 bins, no alpha is needed here + prod(l) = convfac*prod(l) ! get in density units (ug/m3) from ppmv, (convfac=rho_air/mu_air) + ctot(l) = prod(l) + cgas(l) + caer(l) + aold(l) = caer(l) + + ! csat should be calculated 4 times, since pnull is the same for biogenic! + csat(l) = pnull(l)*tnull/blkta(lcell)*exp(dhvap(l)/rgas*ttinv) + END DO loop_cc + +! when we solve the nonlinear equation to determine "caer" we need to combine +! asoa(n) and bsoa(n), since they have the same saturation concentrations, hence the equilibrium should cover the same bins + +PnGtotal=0. ! track total Condensed Vapors&SOA over bins for limits on Newton Iteration of total SOA mass +do ll=1,nbin + ccsat(ll)= csat(ll) + ccaer(ll)= caer(ll) + caer(ll+4) + cctot(ll)= ctot(ll) + ctot(ll+4) + PnGtotal=PnGtotal+cctot(ll) + w1(ll)= ctot(ll)/cctot(ll) ! Anthropogenic fraction to total + w2(ll)= 1. - w1(ll) ! Biogenic fraction of total +end do + +!bs +!bs * small amount of non-volatile absorbing mass is assumed to be +!bs * present (following Bowman et al. (1997) 0.01% of the inorganic +!bs * mass in each size section, here mode) +!bs +! inorganic mass isn't needed here + !mnono = 0.0001*(cblk(lcell,vso4aj)+cblk(lcell,vnh4aj)+ cblk(lcell,vno3aj)) + !mnono = mnono + 0.0001*(cblk(lcell,vso4ai)+cblk(lcell,vnh4ai)+ cblk(lcell,vno3ai)) + +! they're assigned to zero at the next step +! test with minit=0 + ! minit = cblk(lcell,vecj) + cblk(lcell,veci) + cblk(lcell,vorgpaj) + cblk(lcell,vorgpai) !+ mnono + minit= cblk(lcell,vorgpaj) + cblk(lcell,vorgpai) ! exclude EC from absorbing mass + +! minit is taken into account + +!bs * If MINIT is set to zero partitioning will occur if the pure +!bs * saturation concentation is exceeded (Pandis et al. 1992). +!bs * If some amount of absorbing organic mass is formed gas/particle +!bs * partitioning will follow the ideal solution approach. +!bs +!SAM 9/8/09 - Include absorbing SOA material within aerosols in calculation ! + + minit = AMAX1(minit,CABSMIN) + +! mtot is initial guess to SOA mass (aerosol plus extra absorbing mass (minit)) + mtot = 0. + DO L=1,NBIN + mtot = mtot + AMIN1(1.,CCTOT(L)/CCSAT(L))*CCTOT(L) + ENDDO + mtot = mtot + minit +! +! debugging +!if (igrid .eq. 8 .AND. jgrid .eq. 18) then +! if (kgrid .eq. 1 )then +! write(6,*)'before Newton iteration' +! write(6,*)'MTOT=',MTOT +! write(6,*)'minit=',minit +! write(6,*)'w1=',w1,'w2=',w2 +! write(6,*)'cctot=',cctot +! write(6,*)'ccaer=',ccaer +! write(6,*)'ccsat=',ccsat +! write(6,*)'nbin=',nbin +! endif +!endif + +!SAM: Find total SOA mass from newton iteration, needs only 5 iterations for exact solution +loop_newt: DO LL=1,5 ! Fixed Newton iteration number + FMTOT=0. + FMTOT2=0. + DO L=1,NBIN + DUM=CCTOT(L)/(1.+CCSAT(L)/MTOT) + FMTOT=FMTOT+DUM + FMTOT2=FMTOT2+DUM**2 + ENDDO + FMTOT=FMTOT+MINIT ! Forecast total SOA mass + DUM=MTOT-FMTOT + DUM2=((FMTOT-MINIT)/MTOT)-MTOT*FMTOT2 + MTOT=MTOT-DUM/(1.-DUM2) + MTOT=AMAX1(MTOT,MINIT) ! Limit MTOT to min possible in case of instability + MTOT=AMIN1(MTOT,PnGtotal+minit) ! Limit MTOT to max possible in case of instability +END DO loop_newt ! LL iteration number loop + +! Have total mass MTOT, get aerosol mass from semi-ideal partitioning equation + DO L=1,NBIN + CCAER(L)=CCTOT(L)*MTOT/(MTOT+CCSAT(L)) + ENDDO +! + +do ll=1,nbin + caer(ll)= AMAX1(w1(ll)*ccaer(ll),CONMIN) + caer(ll+4)= AMAX1(w2(ll)*ccaer(ll),CONMIN) + cgas(ll)= w1(ll)*(cctot(ll) - ccaer(ll)) + cgas(ll+4)= w2(ll)*(cctot(ll) - ccaer(ll)) +end do + + ! assigning values to CBLK array (gases), convert to ppm since it goes to chem + cblk(lcell,vcvasoa1) = max(cgas(pasoa1),conmin)/convfac/mwcv(pasoa1) + cblk(lcell,vcvasoa2) = max(cgas(pasoa2),conmin)/convfac/mwcv(pasoa2) + cblk(lcell,vcvasoa3) = max(cgas(pasoa3),conmin)/convfac/mwcv(pasoa3) + cblk(lcell,vcvasoa4) = max(cgas(pasoa4),conmin)/convfac/mwcv(pasoa4) + + cblk(lcell,vcvbsoa1) = max(cgas(pbsoa1),conmin)/convfac/mwcv(pbsoa1) + cblk(lcell,vcvbsoa2) = max(cgas(pbsoa2),conmin)/convfac/mwcv(pbsoa2) + cblk(lcell,vcvbsoa3) = max(cgas(pbsoa3),conmin)/convfac/mwcv(pbsoa3) + cblk(lcell,vcvbsoa4) = max(cgas(pbsoa4),conmin)/convfac/mwcv(pbsoa4) + + organt1rat(lcell) = (caer(pasoa1)-aold(pasoa1))/dt + organt2rat(lcell) = (caer(pasoa2)-aold(pasoa2))/dt + organt3rat(lcell) = (caer(pasoa3)-aold(pasoa3))/dt + organt4rat(lcell) = (caer(pasoa4)-aold(pasoa4))/dt + + orgbio1rat(lcell) = (caer(pbsoa1)-aold(pbsoa1))/dt + orgbio2rat(lcell) = (caer(pbsoa2)-aold(pbsoa2))/dt + orgbio3rat(lcell) = (caer(pbsoa3)-aold(pbsoa3))/dt + orgbio4rat(lcell) = (caer(pbsoa4)-aold(pbsoa4))/dt + END DO loop_cells + RETURN +END SUBROUTINE sorgam_vbs +! +! *** this routine calculates the dry deposition and sedimentation +! velocities for the three modes. +! coded 1/23/97 by Dr. Francis S. Binkowski. Follows +! FSB's original method, i.e. uses Jon Pleim's expression for deposition +! velocity but includes Marv Wesely's wstar contribution. +!ia eliminated Stokes term for coarse mode deposition calcs., +!ia see comments below + + SUBROUTINE VDVG( BLKSIZE, NSPCSDA, NUMCELLS, & + LAYER, & + CBLK, & + BLKTA, BLKDENS, RA, USTAR, WSTAR, AMU, & + DGNUC, DGACC, DGCOR, & + KNNUC, KNACC,KNCOR, & + PDENSN, PDENSA, PDENSC, & + VSED, VDEP ) + +! *** calculate size-averaged particle dry deposition and +! size-averaged sedimentation velocities. + + +! IMPLICIT NONE + + INTEGER BLKSIZE ! dimension of arrays + INTEGER NSPCSDA ! number of species in CBLK + INTEGER NUMCELLS ! actual number of cells in arrays + INTEGER LAYER ! number of layer + + REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables + REAL BLKTA( BLKSIZE ) ! Air temperature [ K ] + REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ] + REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ] + REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ] + REAL WSTAR( BLKSIZE ) ! convective velocity scale [ m s**-1 ] + REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ] + REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ] + REAL DGACC( BLKSIZE ) ! accumulation + REAL DGCOR( BLKSIZE ) ! coarse mode + REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number + REAL KNACC( BLKSIZE ) ! accumulation + REAL KNCOR( BLKSIZE ) ! coarse mode + REAL PDENSN( BLKSIZE ) ! average particel density in nuclei mode [ kg / m**3 ] + REAL PDENSA( BLKSIZE ) ! average particel density in accumulation mode [ kg / m**3 ] + REAL PDENSC( BLKSIZE ) ! average particel density in coarse mode [ kg / m**3 ] + + +! *** modal particle diffusivities for number and 3rd moment, or mass: + + REAL DCHAT0N( BLKSIZE), DCHAT0A(BLKSIZE), DCHAT0C(BLKSIZE) + REAL DCHAT3N( BLKSIZE), DCHAT3A(BLKSIZE), DCHAT3C(BLKSIZE) + +! *** modal sedimentation velocities for number and 3rd moment, or mass: + + REAL VGHAT0N( BLKSIZE), VGHAT0A(BLKSIZE), VGHAT0C(BLKSIZE) + REAL VGHAT3N( BLKSIZE), VGHAT3A(BLKSIZE), VGHAT3C(BLKSIZE) + +! *** deposition and sedimentation velocities + + REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ] + REAL VSED( BLKSIZE, NASPCSSED) ! sedimantation velocity [ m s**-1 ] + + + INTEGER LCELL + REAL DCONST1, DCONST1N, DCONST1A, DCONST1C + REAL DCONST2, DCONST3N, DCONST3A,DCONST3C + REAL SC0N, SC0A, SC0C ! Schmidt numbers for number + REAL SC3N, SC3A, SC3C ! Schmidt numbers for 3rd moment + REAL ST0N, ST0A, ST0C ! Stokes numbers for number + REAL ST3N, ST3A, ST3C ! Stokes numbers for 3rd moment + REAL RD0N, RD0A, RD0C ! canopy resistance for number + REAL RD3N, RD3A, RD3C ! canopy resisteance for 3rd moment + REAL UTSCALE ! scratch function of USTAR and WSTAR. + REAL NU !kinematic viscosity [ m**2 s**-1 ] + REAL USTFAC ! scratch function of USTAR, NU, and GRAV + REAL BHAT + PARAMETER( BHAT = 1.246 ) ! Constant from Cunningham slip correction. + + +! *** check layer value. + + IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and +! sedimentation velocities + + DO LCELL = 1, NUMCELLS + + DCONST1 = BOLTZ * BLKTA(LCELL) / & + ( THREEPI * AMU(LCELL) ) + DCONST1N = DCONST1 / DGNUC( LCELL ) + DCONST1A = DCONST1 / DGACC( LCELL ) + DCONST1C = DCONST1 / DGCOR( LCELL ) + DCONST2 = GRAV / ( 18.0 * AMU(LCELL) ) + DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2 + DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2 + DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2 + +! *** i-mode + + DCHAT0N(LCELL) = DCONST1N & + * ( ESN04 + BHAT * KNNUC( LCELL ) * ESN16 ) + + DCHAT3N(LCELL) = DCONST1N & + * ( ESNM20 + BHAT * KNNUC( LCELL ) * ESNM32 ) + + VGHAT0N(LCELL) = DCONST3N & + * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 ) + + VGHAT3N(LCELL) = DCONST3N & + * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 ) + +! *** j-mode + + DCHAT0A(LCELL) = DCONST1A & + * ( ESA04 + BHAT * KNACC( LCELL ) * ESA16 ) + + DCHAT3A(LCELL) = DCONST1A & + * ( ESAM20 + BHAT * KNACC( LCELL ) * ESAM32 ) + + VGHAT0A(LCELL) = DCONST3A & + * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 ) + + VGHAT3A(LCELL) = DCONST3A & + * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 ) + + +! *** coarse mode + + DCHAT0C(LCELL)= DCONST1C & + * ( ESC04 + BHAT * KNCOR( LCELL ) * ESC16 ) + + DCHAT3C(LCELL) = DCONST1C & + * ( ESCM20 + BHAT * KNCOR( LCELL ) * ESCM32 ) + + VGHAT0C(LCELL) = DCONST3C & + * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 ) + + VGHAT3C(LCELL) = DCONST3C & + * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 ) + + END DO + +! *** now calculate the deposition and sedmentation velocities + +!ia 07.05.98 +! *** NOTE In the deposition velocity for coarse mode, +! the impaction term 10.0 ** (-3.0 / st) is eliminated because +! coarse particles are likely to bounce on impact and the current +! formulation does not account for this. + + + DO LCELL = 1, NUMCELLS + + NU = AMU(LCELL) / BLKDENS(LCELL) + USTFAC = USTAR(LCELL) * USTAR(LCELL) / ( GRAV * NU) + UTSCALE = USTAR(LCELL) + & + 0.24 * WSTAR(LCELL) * WSTAR(LCELL) / USTAR(LCELL) + +! *** first do number + +! *** nuclei or Aitken mode ( no sedimentation velocity ) + + SC0N = NU / DCHAT0N(LCELL) + ST0N = MAX( VGHAT0N(LCELL) * USTFAC , 0.01) + RD0N = 1.0 / ( UTSCALE * & + ( SC0N**(-TWO3) + 10.0**(-3.0 / ST0N) ) ) + + VDEP(LCELL, VDNNUC) = VGHAT0N(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD0N + RD0N * RA(LCELL) * VGHAT0N(LCELL) ) + + VSED( LCELL, VSNNUC) = VGHAT0N(LCELL) + +! *** accumulation mode + + SC0A = NU / DCHAT0A(LCELL) + ST0A = MAX ( VGHAT0A(LCELL) * USTFAC, 0.01) + RD0A = 1.0 / ( UTSCALE * & + ( SC0A**(-TWO3) + 10.0**(-3.0 / ST0A) ) ) + + VDEP(LCELL, VDNACC) = VGHAT0A(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD0A + RD0A * RA(LCELL) * VGHAT0A(LCELL) ) + + VSED( LCELL, VSNACC) = VGHAT0A(LCELL) + +! *** coarse mode + + SC0C = NU / DCHAT0C(LCELL) +!ia ST0C = MAX( VGHAT0C(LCELL) * USTFAC, 0.01 ) +!ia RD0C = 1.0 / ( UTSCALE * +!ia & ( SC0C**(-TWO3) + 10.0**(-3.0 / ST0C) ) ) + + RD0C = 1.0 / ( UTSCALE * & + ( SC0C ** ( -TWO3 ) ) ) ! eliminate impaction term + + VDEP(LCELL, VDNCOR) = VGHAT0C(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD0C + RD0C * RA(LCELL) * VGHAT0C(LCELL) ) + + VSED( LCELL, VSNCOR) = VGHAT0C(LCELL) + +! *** now do m3 for the deposition of mass + +! *** nuclei or Aitken mode + + SC3N = NU / DCHAT3N(LCELL) + ST3N = MAX( VGHAT3N(LCELL) * USTFAC, 0.01) + RD3N = 1.0 / ( UTSCALE * & + ( SC3N**(-TWO3) + 10.0**(-3.0 / ST3N) ) ) + + VDEP(LCELL, VDMNUC) = VGHAT3N(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD3N + RD3N * RA(LCELL) * VGHAT3N(LCELL) ) + + VSED(LCELL, VSMNUC) = VGHAT3N(LCELL) + +! *** accumulation mode + + SC3A = NU / DCHAT3A(LCELL) + ST3A = MAX( VGHAT3A(LCELL) * USTFAC , 0.01 ) + RD3A = 1.0 / ( UTSCALE * & + ( SC3A**(-TWO3) + 10.0**(-3.0 / ST3A) ) ) + + VDEP(LCELL, VDMACC) = VGHAT3A(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD3A + RD3A * RA(LCELL) * VGHAT3A(LCELL) ) + + +! *** fine mass deposition velocity: combine Aitken and accumulation +! mode deposition velocities. Assume density is the same +! for both modes. + + +! VDEP(LCELL,VDMFINE) = ( +! & CBLK(LCELL,VNU3) * VDEP(LCELL, VDMNUC) + +! & CBLK(LCELL,VAC3) * VDEP(LCELL, VDMACC) ) / +! & ( CBLK(LCELL,VAC3) + CBLK(LCELL,VNU3) ) + + +! *** fine mass sedimentation velocity + +! VSED( LCELL, VSMFINE) = ( +! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) + +! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) / +! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) ) + + VSED( LCELL, VSMACC ) = VGHAT3A(LCELL) + +! *** coarse mode + + SC3C = NU / DCHAT3C(LCELL) +!ia ST3C = MAX( VGHAT3C(LCELL) * USTFAC, 0.01 ) +!ia RD3C = 1.0 / ( UTSCALE * +!ia & ( SC3C**(-TWO3) + 10.0**(-3.0 / ST3C) ) ) + + RD3C = 1.0 / ( UTSCALE * & + ( SC3C ** ( -TWO3 ) ) ) ! eliminate impaction term + VDEP(LCELL, VDMCOR) = VGHAT3C(LCELL) + & + 1.0 / ( & + RA(LCELL) + RD3C + RD3C * RA(LCELL) * VGHAT3C(LCELL)) + +! *** coarse mode sedmentation velocity + + VSED( LCELL, VSMCOR) = VGHAT3C(LCELL) + + + + END DO + + ELSE ! LAYER greater than 1 + +! *** for layer greater than 1 calculate sedimentation velocities only + + DO LCELL = 1, NUMCELLS + + DCONST2 = GRAV / ( 18.0 * AMU(LCELL) ) + + DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2 + DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2 + DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2 + + VGHAT0N(LCELL) = DCONST3N & + * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 ) + +! *** nucleation mode number sedimentation velocity + + VSED( LCELL, VSNNUC) = VGHAT0N(LCELL) + + VGHAT3N(LCELL) = DCONST3N & + * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 ) + +! *** nucleation mode volume sedimentation velocity + + VSED( LCELL, VSMNUC) = VGHAT3N(LCELL) + + VGHAT0A(LCELL) = DCONST3A & + * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 ) + +! *** accumulation mode number sedimentation velocity + + VSED( LCELL, VSNACC) = VGHAT0A(LCELL) + + VGHAT3A(LCELL) = DCONST3A & + * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 ) + +! *** fine mass sedimentation velocity + +! VSED( LCELL, VSMFINE) = ( +! & CBLK(LCELL, VNU3) * VGHAT3N(LCELL) + +! & CBLK(LCELL, VAC3) * VGHAT3A(LCELL) ) / +! & ( CBLK(LCELL, VNU3) + CBLK(LCELL, VAC3) ) + + VSED( LCELL, VSMACC) = VGHAT3A(LCELL) + + VGHAT0C(LCELL) = DCONST3C & + * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 ) + +! *** coarse mode sedimentation velocity + + VSED( LCELL, VSNCOR) = VGHAT0C(LCELL) + + + VGHAT3C(LCELL) = DCONST3C & + * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 ) + +! *** coarse mode mass sedimentation velocity + + VSED( LCELL, VSMCOR) = VGHAT3C(LCELL) + + END DO + + END IF ! check on layer + +END SUBROUTINE VDVG +! +!--------------------------------------------------------------------------- +! +! *** this routine calculates the dry deposition and sedimentation +! velocities for the three modes. +! Stu McKeen 10/13/08 +! Gaussian Quadrature numerical integration over diameter range for each mode. +! Quadrature taken from Abramowitz and Stegun (1974), equation 25.4.46 and Table 25.10 +! Quadrature points are the zeros of Hermite polynomials of order NGAUSdv +! Numerical Integration allows more complete discription of the +! Cunningham Slip correction factor, Interception Term (not included previously), +! and the correction due to rebound for higher diameter particles. +! Sedimentation velocities the same as original Binkowski code, also the +! Schmidt number and Brownian diffusion efficiency dependence on Schmidt number the +! same as Binkowski. +! Stokes number, and efficiency dependence on Stokes number now according to +! Peters and Eiden (1992). Interception term taken from Slinn (1982) with +! efficiency at .2 micron diam. (0.3%) tuned to yield .2 cm/s deposition velocitiy +! for needleaf evergreen trees (Pryor et al., Tellus, 2008). Rebound correction +! term is that of Slinn (1982) +! +! Original code 1/23/97 by Dr. Francis S. Binkowski. Follows +! FSB's original method, i.e. uses Jon Pleim's expression for deposition +! velocity but includes Marv Wesely's wstar contribution. +!ia eliminated Stokes term for coarse mode deposition calcs., +!ia see comments below + +! CBLK is eliminated since the subroutine doesn't use it! +SUBROUTINE VDVG_2( BLKSIZE, NSPCSDA, NUMCELLS, & + LAYER, & + BLKTA, BLKDENS, & + RA, USTAR, PBLH, ZNTT, RMOLM, AMU, & + DGNUC, DGACC, DGCOR, XLM, & + KNNUC, KNACC,KNCOR, & + PDENSN, PDENSA, PDENSC, & + VSED, VDEP) + +! *** calculate size-averaged particle dry deposition and +! size-averaged sedimentation velocities. +! IMPLICIT NONE + + INTEGER BLKSIZE ! dimension of arrays + INTEGER NSPCSDA ! number of species in CBLK + INTEGER NUMCELLS ! actual number of cells in arrays + INTEGER LAYER ! number of layer + INTEGER, PARAMETER :: iprnt = 0 + +! REAL CBLK( BLKSIZE, NSPCSDA ) ! main array of variables + REAL BLKTA( BLKSIZE ) ! Air temperature [ K ] + REAL BLKDENS(BLKSIZE) ! Air density [ kg m^-3 ] + REAL RA(BLKSIZE ) ! aerodynamic resistance [ s m**-1 ] + REAL USTAR( BLKSIZE ) ! surface friction velocity [ m s**-1 ] + REAL PBLH( BLKSIZE ) ! PBL height (m) + REAL ZNTT( BLKSIZE ) ! Surface roughness length (m) + REAL RMOLM( BLKSIZE ) ! Inverse of Monin-Obukhov length (1/m) + REAL AMU( BLKSIZE ) ! atmospheric dynamic viscosity [ kg m**-1 s**-1 ] + REAL XLM( BLKSIZE ) ! mean free path of dry air [ m ] + REAL DGNUC( BLKSIZE ) ! nuclei mode mean diameter [ m ] + REAL DGACC( BLKSIZE ) ! accumulation + REAL DGCOR( BLKSIZE ) ! coarse mode + REAL KNNUC( BLKSIZE ) ! nuclei mode Knudsen number + REAL KNACC( BLKSIZE ) ! accumulation + REAL KNCOR( BLKSIZE ) ! coarse mode + REAL PDENSN( BLKSIZE ) ! average particle density in nuclei mode [ kg / m**3 ] + REAL PDENSA( BLKSIZE ) ! average particle density in accumulation mode [ kg / m**3 ] + REAL PDENSC( BLKSIZE ) ! average particle density in coarse mode [ kg / m**3 ] + +! *** deposition and sedimentation velocities + + REAL VDEP( BLKSIZE, NASPCSDEP) ! deposition velocity [ m s**-1 ] + REAL VSED( BLKSIZE, NASPCSSED) ! sedimentation velocity [ m s**-1 ] + + INTEGER LCELL,N + REAL DCONST1, DCONST2, DCONST3, DCONST3N, DCONST3A,DCONST3C + REAL UTSCALE,CZH ! scratch functions of USTAR and WSTAR. + REAL NU !kinematic viscosity [ m**2 s**-1 ] + REAL BHAT + PARAMETER( BHAT = 1.246 ) ! Constant from Binkowski-Shankar approx to Cunningham slip correction. + REAL COLCTR_BIGD,COLCTR_SMALD + PARAMETER ( COLCTR_BIGD=2.E-3,COLCTR_SMALD=20.E-6 ) ! Collector diameters in Stokes number and Interception Efficiency (Needleleaf Forest) + REAL SUM0, SUM3, DQ, KNQ, CUNQ, VSEDQ, SCQ, STQ, RSURFQ, vdplim + REAL Eff_dif, Eff_imp, Eff_int, RBcor + INTEGER ISTOPvd0,IdoWesCor + PARAMETER (ISTOPvd0 = 0) ! ISTOPvd0 = 1 means dont call VDVG, particle dep. velocities are set = 0; ISTOPvd0 = 0 means do depvel calcs. + + ! no Wesley deposition, otherwise EC is too low + PARAMETER (IdoWesCor = 0) ! IdoWesCor = 1 means do Wesley (85) convective correction to PM dry dep velocities; 0 means don't do correction + IF (ISTOPvd0.EQ.1)THEN + RETURN + ENDIF +! *** check layer value. + + IF(iprnt.eq.1) print *,'In VDVG, Layer=',LAYER + IF ( LAYER .EQ. 1 ) THEN ! calculate diffusitities and sedimentation velocities + + DO LCELL = 1, NUMCELLS + DCONST1 = BOLTZ * BLKTA(LCELL) / & + ( THREEPI * AMU(LCELL) ) + DCONST2 = GRAV / ( 18.0 * AMU(LCELL) ) + DCONST3 = USTAR(LCELL)/(9.*AMU(LCELL)*COLCTR_BIGD) + +! *** now calculate the deposition velocities at layer 1 + + NU = AMU(LCELL) / BLKDENS(LCELL) + + UTSCALE = 1. + IF (IdoWesCor.EQ.1)THEN +! Wesley (1985) Monin-Obukov dependence for convective conditions (SAM 10/08) + IF(RMOLM(LCELL).LT.0.)THEN + CZH = -1.*PBLH(LCELL)*RMOLM(LCELL) + IF(CZH.GT.30.0)THEN + UTSCALE=0.45*CZH**0.6667 + ELSE + UTSCALE=1.+(-300.*RMOLM(LCELL))**0.6667 + ENDIF + ENDIF + ENDIF ! end of (IdoWesCor.EQ.1) test + + UTSCALE = USTAR(LCELL)*UTSCALE + IF(iprnt.eq.1)THEN + print *,'NGAUSdv,xxlsga,USTAR,UTSCALE' + print *,NGAUSdv,xxlsga,USTAR(LCELL),UTSCALE + print *,'DCONST2,PDENSA,DGACC,GRAV,AMU' + print *,DCONST2,PDENSA(LCELL),DGACC(LCELL),GRAV,AMU(LCELL) + endif + +! *** nuclei mode + + SUM0=0. + SUM3=0. + DO N=1,NGAUSdv + DQ=DGNUC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgn) ! Diameter (m) at quadrature point + KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point + CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16) + VSEDQ=PDENSN(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s + SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar + Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar + STQ=DCONST3*PDENSN(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992) + Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992) + ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam. + Eff_int=(0.00116+0.0061*ZNTT(LCELL))*DQ/1.414E-7 ! McKeen(2008) Intercptn trm, val of .00421 @ ustr=0.475, diam=.1414 micrn, stable, needleleaf evergreen + RBcor=1. ! Rebound correction factor + vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor + ! vdplim=.002*UTSCALE + vdplim=min(vdplim,.02) + RSURFQ=RA(LCELL)+1./vdplim + ! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence + ! +! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986 +! + ! RSURFQ=max(RSURFQ,50.) + SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment + SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment + ENDDO + VDEP(LCELL, VDNNUC) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume) + VDEP(LCELL, VDMNUC) = SUM3/(sqrtpi*EXP((1.5*sqrt2*xxlsgn)**2)*DGNUC(LCELL)**3) !normalize 3 moment quad. sum to sqrt(pi) and 3rd moment analytic sum + +! *** accumulation mode + + SUM0=0. + SUM3=0. + DO N=1,NGAUSdv + DQ=DGACC(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsga) ! Diameter (m) at quadrature point + KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point + CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16) + VSEDQ=PDENSA(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s + SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar + Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar + STQ=DCONST3*PDENSA(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992) + Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992) + ! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam. + Eff_int=(0.00116+0.0061*ZNTT(LCELL))*DQ/1.414E-7 ! McKeen(2008) Intercptn term, val of .00421 @ ustr=0.475, diam=.1414 micrn, stable, needleleaf evergreen + RBcor=1. ! Rebound correction factor + vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor + vdplim=min(vdplim,.02) + RSURFQ=RA(LCELL)+1./vdplim +! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence +! +! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986 +! +! RSURFQ=max(RSURFQ,50.) + SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment + SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment + IF(iprnt.eq.1)THEN + print *,'N,Y_GQ,WGAUS,DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ' + print *,N,Y_GQ(N),WGAUS(N),DQ,KNQ,CUNQ,VSEDQ,SCQ,STQ,RSURFQ + print *,'N,Eff_dif,imp,int,SUM0,SUM3' + print *,N,Eff_dif,Eff_imp,Eff_int,SUM0,SUM3 + endif + ENDDO + VDEP(LCELL, VDNACC) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume) + VDEP(LCELL, VDMACC) = SUM3/(sqrtpi*EXP((1.5*sqrt2*xxlsga)**2)*DGACC(LCELL)**3) !normalize 3 moment quad. sum to sqrt(pi) and 3rd moment analytic sum + +! *** coarse mode + + SUM0=0. + SUM3=0. + DO N=1,NGAUSdv + DQ=DGCOR(LCELL)*EXP(Y_GQ(N)*sqrt2*xxlsgc) ! Diameter (m) at quadrature point + KNQ=2.*XLM(LCELL)/DQ ! Knudsen number at quadrature point + CUNQ=1.+KNQ*(1.257+.4*exp(-1.1/KNQ)) ! Cunningham correction factor; Pruppacher and Klett (1980) Eq (12-16) + VSEDQ=PDENSC(LCELL)*DCONST2*CUNQ*DQ*DQ ! Gravitational sedimentation velocity m/s + SCQ=NU*DQ/DCONST1/CUNQ ! Schmidt number, Brownian diffusion parameter - Same as Binkowski and Shankar + Eff_dif=SCQ**(-TWO3) ! Efficiency term for diffusion - Same as Binkowski and Shankar + STQ=DCONST3*PDENSC(LCELL)*DQ**2 ! Stokes number, Peters and Eiden (1992) + Eff_imp=(STQ/(0.8+STQ))**2 ! Efficiency term for impaction - Peters and Eiden (1992) +! Eff_int=0.3*DQ/(COLCTR_SMALD+DQ) ! Slinn (1982) Interception term, 0.3 prefac insures .2 cm/s at .2 micron diam. + Eff_int=(0.00116+0.0061*ZNTT(LCELL))*DQ/1.414E-7 ! McKeen(2008) Interception term, val of .00421 @ ustr=0.475, diam=.1414 micrn, stable, needleleaf evergreen + EFF_int=min(1.,EFF_int) + RBcor=exp(-2.0*(STQ**0.5)) ! Rebound correction factor used in Slinn (1982) + vdplim=UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor + vdplim=min(vdplim,.02) + vdplim=max(vdplim,1e-35) !KW wig: add check since occasionally a lg particle causes overflow of rsurfq + RSURFQ=RA(LCELL)+1./vdplim +! RSURFQ=RA(LCELL)+1./(UTSCALE*(Eff_dif+Eff_imp+Eff_int)*RBcor) ! Total surface resistence +! +! limit this here to be consisten with the gocart routine, which bases this on Walcek et al. 1986 +! +! RSURFQ=max(RSURFQ,50.) + SUM0=SUM0+WGAUS(N)*(VSEDQ + 1./RSURFQ) ! Quadrature sum for 0 moment + SUM3=SUM3+WGAUS(N)*(VSEDQ + 1./RSURFQ)*DQ**3 ! Quadrature sum for 3rd moment + ENDDO + VDEP(LCELL, VDNCOR) = SUM0/sqrtpi ! normalize 0 moment vdep quadrature sum to sqrt(pi) (and number =1 per unit volume) + VDEP(LCELL, VDMCOR) = SUM3/(sqrtpi*EXP((1.5*sqrt2*xxlsgc)**2)*DGCOR(LCELL)**3) !normalize 3 moment quad. sum to sqrt(pi) and 3rd moment analytic sum + END DO + + ENDIF ! ENDOF LAYER = 1 test + +! *** Calculate gravitational sedimentation velocities for all layers - as in Binkowski and Shankar (1995) + + DO LCELL = 1, NUMCELLS + + DCONST2 = GRAV / ( 18.0 * AMU(LCELL) ) + DCONST3N = DCONST2 * PDENSN(LCELL) * DGNUC( LCELL )**2 + DCONST3A = DCONST2 * PDENSA(LCELL) * DGACC( LCELL )**2 + DCONST3C = DCONST2 * PDENSC(LCELL) * DGCOR( LCELL )**2 + +! *** nucleation mode number and mass sedimentation velociticies + VSED( LCELL, VSNNUC) = DCONST3N & + * ( ESN16 + BHAT * KNNUC( LCELL ) * ESN04 ) + VSED( LCELL, VSMNUC) = DCONST3N & + * (ESN64 + BHAT * KNNUC( LCELL ) * ESN28 ) + +! *** accumulation mode number and mass sedimentation velociticies + VSED( LCELL, VSNACC) = DCONST3A & + * ( ESA16 + BHAT * KNACC( LCELL ) * ESA04 ) + VSED( LCELL, VSMACC) = DCONST3A & + * ( ESA64 + BHAT * KNACC( LCELL ) * ESA28 ) + +! *** coarse mode number and mass sedimentation velociticies + VSED( LCELL, VSNCOR) = DCONST3C & + * ( ESC16 + BHAT * KNCOR( LCELL ) * ESC04 ) + VSED( LCELL, VSMCOR) = DCONST3C & + * ( ESC64 + BHAT * KNCOR( LCELL ) * ESC28 ) + END DO +END SUBROUTINE VDVG_2 +!------------------------------------------------------------------------------ + +SUBROUTINE aerosols_sorgam_vbs_init(chem,convfac,z_at_w, & + pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & +!KW + tsoa,asoa,bsoa, & +!KW + chem_in_opt,aer_ic_opt, is_aerosol, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, config_flags ) + + USE module_configure, only: grid_config_rec_type + + implicit none + INTEGER, INTENT(IN ) :: chem_in_opt,aer_ic_opt + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + LOGICAL, INTENT(OUT) :: is_aerosol(num_chem) + REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ) , & + INTENT(INOUT ) :: & + chem + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT ) :: & + pm2_5_dry,pm2_5_water,pm2_5_dry_ec, & +!KW + tsoa,asoa,bsoa +!KW + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + convfac + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + z_at_w + TYPE (grid_config_rec_type) , INTENT (in) :: config_flags + + + integer i,j,k,l,ii,jj,kk + real tempfac,mwso4,zz +! real,dimension(its:ite,kts:kte,jts:jte) :: convfac + REAL splitfac + !between gas and aerosol phase + REAL so4vaptoaer +!factor for splitting initial conc. of SO4 +!3rd moment i-mode [3rd moment/m^3] + REAL m3nuc +!3rd MOMENT j-mode [3rd moment/m^3] + REAL m3acc +! REAL ESN36 + REAL m3cor + DATA splitfac/.98/ + DATA so4vaptoaer/.999/ + +! *** Compute these once and they will all be saved in COMMON + xxlsgn = log(sginin) + xxlsga = log(sginia) + xxlsgc = log(sginic) + + l2sginin = xxlsgn**2 + l2sginia = xxlsga**2 + l2sginic = xxlsgc**2 + + en1 = exp(0.125*l2sginin) + ea1 = exp(0.125*l2sginia) + ec1 = exp(0.125*l2sginic) + + esn04 = en1**4 + esa04 = ea1**4 + esc04 = ec1**4 + + esn05 = esn04*en1 + esa05 = esa04*ea1 + + esn08 = esn04*esn04 + esa08 = esa04*esa04 + esc08 = esc04*esc04 + + esn09 = esn04*esn05 + esa09 = esa04*esa05 + + esn12 = esn04*esn04*esn04 + esa12 = esa04*esa04*esa04 + esc12 = esc04*esc04*esc04 + + esn16 = esn08*esn08 + esa16 = esa08*esa08 + esc16 = esc08*esc08 + + esn20 = esn16*esn04 + esa20 = esa16*esa04 + esc20 = esc16*esc04 + + esn24 = esn12*esn12 + esa24 = esa12*esa12 + esc24 = esc12*esc12 + + esn25 = esn16*esn09 + esa25 = esa16*esa09 + + esn28 = esn20*esn08 + esa28 = esa20*esa08 + esc28 = esc20*esc08 + + + esn32 = esn16*esn16 + esa32 = esa16*esa16 + esc32 = esc16*esc16 + + esn36 = esn16*esn20 + esa36 = esa16*esa20 + esc36 = esc16*esc20 + + esn49 = esn25*esn20*esn04 + esa49 = esa25*esa20*esa04 + + esn52 = esn16*esn36 + esa52 = esa16*esa36 + + esn64 = esn32*esn32 + esa64 = esa32*esa32 + esc64 = esc32*esc32 + + esn100 = esn36*esn64 + + esnm20 = 1.0/esn20 + esam20 = 1.0/esa20 + escm20 = 1.0/esc20 + + esnm32 = 1.0/esn32 + esam32 = 1.0/esa32 + escm32 = 1.0/esc32 + + xxm3 = 3.0*xxlsgn/ sqrt2 +! factor used in error function cal + nummin_i = facatkn_min*so4fac*aeroconcmin/(dginin**3*esn36) + + nummin_j = facacc_min*so4fac*aeroconcmin/(dginia**3*esa36) + + nummin_c = anthfac*aeroconcmin/(dginic**3*esc36) + +! *** Note, DGVEM_I, DGVEM_J, DGVEM_C are for the mass (volume) +! size distribution , then + +! vol = (p/6) * density * num * (dgemv_xx**3) * +! exp(- 4.5 * log( sgem_xx)**2 ) ) +! note minus sign!! + + factnumn = exp(4.5*log(sgem_i)**2)/dgvem_i**3 + factnuma = exp(4.5*log(sgem_j)**2)/dgvem_j**3 + factnumc = exp(4.5*log(sgem_c)**2)/dgvem_c**3 + ccofm = alphsulf*sqrt(pirs*rgasuniv/(2.0*mwh2so4)) + ccofm_org = alphaorg*sqrt(pirs*rgasuniv/(2.0*mworg)) + mwso4=96.03 + +! initialize pointers used by aerosol-cloud-interaction routines + call aerosols_sorgam_vbs_init_aercld_ptrs( & + num_chem, is_aerosol, config_flags ) + + pm2_5_dry(its:ite, kts:kte-1, jts:jte) = 0. + pm2_5_water(its:ite, kts:kte-1, jts:jte) = 0. + pm2_5_dry_ec(its:ite, kts:kte-1, jts:jte) = 0. + tsoa(its:ite, kts:kte-1, jts:jte) = 0. + asoa(its:ite, kts:kte-1, jts:jte) = 0. + bsoa(its:ite, kts:kte-1, jts:jte) = 0. + +!SAM 10/08 Add in Gaussian quadrature points and weights - Use 7 points = NGAUSdv + + Y_GQ(1)=-2.651961356835233 + WGAUS(1)=0.0009717812450995 + Y_GQ(2)=-1.673551628767471 + WGAUS(2)=0.05451558281913 + Y_GQ(3)=-0.816287882858965 + WGAUS(3)=0.4256072526101 + Y_GQ(4)=-0.0 + WGAUS(4)=0.8102646175568 + Y_GQ(5)=0.816287882858965 + WGAUS(5)=WGAUS(3) + Y_GQ(6)=1.673551628767471 + WGAUS(6)=WGAUS(2) + Y_GQ(7)=2.651961356835233 + WGAUS(7)=WGAUS(1) +! +! IF USING OLD SIMULATION, DO NOT REINITIALIZE! +! + if(chem_in_opt == 1 ) return + do l=p_so4aj,num_chem + chem(ims:ime,kms:kme,jms:jme,l)=epsilc + enddo + chem(ims:ime,kms:kme,jms:jme,p_nu0)=1.e8 + chem(ims:ime,kms:kme,jms:jme,p_ac0)=1.e8 + do j=jts,jte + jj=min(jde-1,j) + do k=kts,kte-1 + kk=min(kde-1,k) + do i=its,ite + ii=min(ide-1,i) + +!Option for alternate ic's + if( aer_ic_opt == AER_IC_DEFAULT ) then + chem(i,k,j,p_so4aj)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4*splitfac*so4vaptoaer + chem(i,k,j,p_so4ai)=chem(ii,kk,jj,p_sulf)*CONVFAC(ii,kk,jj)*MWSO4*(1.-splitfac)*so4vaptoaer + chem(i,k,j,p_sulf)=chem(ii,kk,jj,p_sulf)*(1.-so4vaptoaer) + chem(i,k,j,p_nh4aj) = 10.E-05 + chem(i,k,j,p_nh4ai) = 10.E-05 + chem(i,k,j,p_no3aj) = 10.E-05 + chem(i,k,j,p_no3ai) = 10.E-05 + chem(i,k,j,p_naaj) = 10.E-05 + chem(i,k,j,p_naai) = 10.E-05 + chem(i,k,j,p_claj) = 10.E-05 + chem(i,k,j,p_clai) = 10.E-05 + + elseif( aer_ic_opt == AER_IC_PNNL ) then + zz = (z_at_w(ii,k,jj)+z_at_w(ii,k+1,jj))*0.5 + call sorgam_vbs_init_aer_ic_pnnl( & + chem, zz, i,k,j, ims,ime,jms,jme,kms,kme ) + else + call wrf_error_fatal( & + "aerosols_sorgam_vbs_init: unable to parse aer_ic_opt" ) + end if + +!... i-mode + m3nuc = so4fac*chem(i,k,j,p_so4ai) + nh4fac*chem(i,k,j,p_nh4ai) + & + no3fac*chem(i,k,j,p_no3ai) + & + nafac*chem(i,k,j,p_naai) + clfac*chem(i,k,j,p_clai) + & + orgfac*chem(i,k,j,p_asoa1i) + & + orgfac*chem(i,k,j,p_asoa2i) + orgfac*chem(i,k,j,p_asoa3i) + & + orgfac*chem(i,k,j,p_asoa4i) + orgfac*chem(i,k,j,p_bsoa1i) + & + orgfac*chem(i,k,j,p_bsoa2i) + orgfac*chem(i,k,j,p_bsoa3i) + & + orgfac*chem(i,k,j,p_bsoa4i) + orgfac*chem(i,k,j,p_orgpai) + & + anthfac*chem(i,k,j,p_p25i) + anthfac*chem(i,k,j,p_eci) + +!... j-mode + m3acc = so4fac*chem(i,k,j,p_so4aj) + nh4fac*chem(i,k,j,p_nh4aj) + & + no3fac*chem(i,k,j,p_no3aj) + & + nafac*chem(i,k,j,p_naaj) + clfac*chem(i,k,j,p_claj) + & + orgfac*chem(i,k,j,p_asoa1j) + & + orgfac*chem(i,k,j,p_asoa2j) + orgfac*chem(i,k,j,p_asoa3j) + & + orgfac*chem(i,k,j,p_asoa4j) + orgfac*chem(i,k,j,p_bsoa1j) + & + orgfac*chem(i,k,j,p_bsoa2j) + orgfac*chem(i,k,j,p_bsoa3j) + & + orgfac*chem(i,k,j,p_bsoa4j) + orgfac*chem(i,k,j,p_orgpaj) + & + anthfac*chem(i,k,j,p_p25j) + anthfac*chem(i,k,j,p_ecj) + +!...c-mode + m3cor = soilfac*chem(i,k,j,p_soila) + seasfac*chem(i,k,j,p_seas) + & + anthfac*chem(i,k,j,p_antha) + +!...NOW CALCULATE INITIAL NUMBER CONCENTRATION + chem(i,k,j,p_nu0) = m3nuc/((dginin**3)*esn36) + + chem(i,k,j,p_ac0) = m3acc/((dginia**3)*esa36) + + chem(i,k,j,p_corn) = m3cor/((dginic**3)*esc36) + + enddo + enddo + enddo + + return + END SUBROUTINE aerosols_sorgam_vbs_init + + SUBROUTINE aerosols_sorgam_vbs_init_aercld_ptrs( & + num_chem, is_aerosol, config_flags ) +! +! initialize pointers used by aerosol-cloud-interaction routines +! + USE module_configure,only: grid_config_rec_type + USE module_mosaic_wetscav,only: initwet + + implicit none + INTEGER, INTENT(IN) :: num_chem + LOGICAL, INTENT(OUT) :: is_aerosol(num_chem) + TYPE (grid_config_rec_type) , INTENT (in) :: config_flags + + + integer iphase, isize, itype, l, ll, n, p1st + REAL dp_meanvol_tmp + + + nphase_aer = 1 + if(p_so4cwj.ge. param_first_scalar) then + nphase_aer = 2 + endif + ai_phase=-999888777 + cw_phase=-999888777 + ci_phase=-999888777 + cr_phase=-999888777 + cs_phase=-999888777 + cg_phase=-999888777 + if(nphase_aer>=1)ai_phase=1 + if(nphase_aer>=2)cw_phase=2 + if(nphase_aer>=3)cr_phase=3 + if(nphase_aer>=4)ci_phase=4 + if(nphase_aer>=5)cw_phase=5 + if(nphase_aer>=6)cg_phase=6 + +! aitken and accum mode have same set of species +! so are treated as isize=1,2 of itype=1 +! coarse mode has different set of species +! so is treated as isize=1 of itype=2 + ntype_aer = 2 + nsize_aer(1)=2 + nsize_aer(2)=1 + + msectional = 0 + maerosolincw = 0 +#if defined ( cw_species_are_in_registry ) + maerosolincw = 1 +#endif + name_mastercomp_aer( 1) = 'sulfate' + dens_mastercomp_aer( 1) = dens_so4_aer + mw_mastercomp_aer( 1) = mw_so4_aer + hygro_mastercomp_aer(1) = hygro_so4_aer + + name_mastercomp_aer( 2) = 'nitrate' + dens_mastercomp_aer( 2) = dens_no3_aer + mw_mastercomp_aer( 2) = mw_no3_aer + hygro_mastercomp_aer(2) = hygro_no3_aer + + name_mastercomp_aer( 3) = 'ammonium' + dens_mastercomp_aer( 3) = dens_nh4_aer + mw_mastercomp_aer( 3) = mw_nh4_aer + hygro_mastercomp_aer(3) = hygro_nh4_aer + + name_mastercomp_aer( 4) = 'asoa1' + dens_mastercomp_aer( 4) = dens_oc_aer + mw_mastercomp_aer( 4) = mw_oc_aer + hygro_mastercomp_aer(4) = hygro_oc_aer + + name_mastercomp_aer( 5) = 'asoa2' + dens_mastercomp_aer( 5) = dens_oc_aer + mw_mastercomp_aer( 5) = mw_oc_aer + hygro_mastercomp_aer(5) = hygro_oc_aer + + name_mastercomp_aer( 6) = 'asoa3' + dens_mastercomp_aer( 6) = dens_oc_aer + mw_mastercomp_aer( 6) = mw_oc_aer + hygro_mastercomp_aer(6) = hygro_oc_aer + + name_mastercomp_aer( 7) = 'asoa4' + dens_mastercomp_aer( 7) = dens_oc_aer + mw_mastercomp_aer( 7) = mw_oc_aer + hygro_mastercomp_aer(7) = hygro_oc_aer + + name_mastercomp_aer( 8) = 'bsoa1' + dens_mastercomp_aer( 8) = dens_oc_aer + mw_mastercomp_aer( 8) = mw_oc_aer + hygro_mastercomp_aer(8) = hygro_oc_aer + + name_mastercomp_aer( 9) = 'bsoa2' + dens_mastercomp_aer( 9) = dens_oc_aer + mw_mastercomp_aer( 9) = mw_oc_aer + hygro_mastercomp_aer(9) = hygro_oc_aer + + name_mastercomp_aer( 10) = 'bsoa3' + dens_mastercomp_aer( 10) = dens_oc_aer + mw_mastercomp_aer( 10) = mw_oc_aer + hygro_mastercomp_aer(10) = hygro_oc_aer + + name_mastercomp_aer( 11) = 'bsoa4' + dens_mastercomp_aer( 11) = dens_oc_aer + mw_mastercomp_aer( 11) = mw_oc_aer + hygro_mastercomp_aer(11) = hygro_oc_aer + + name_mastercomp_aer( 12) = 'orgpa' + dens_mastercomp_aer( 12) = dens_oc_aer + mw_mastercomp_aer( 12) = mw_oc_aer + hygro_mastercomp_aer(12) = hygro_oc_aer + + name_mastercomp_aer( 13) = 'ec' + dens_mastercomp_aer( 13) = dens_ec_aer + mw_mastercomp_aer( 13) = mw_ec_aer + hygro_mastercomp_aer(13) = hygro_ec_aer + + name_mastercomp_aer( 14) = 'p25' + dens_mastercomp_aer( 14) = dens_oin_aer + mw_mastercomp_aer( 14) = mw_oin_aer + hygro_mastercomp_aer(14) = hygro_oin_aer + + name_mastercomp_aer( 15) = 'anth' + dens_mastercomp_aer( 15) = dens_oin_aer + mw_mastercomp_aer( 15) = mw_oin_aer + hygro_mastercomp_aer(15) = hygro_oin_aer + + name_mastercomp_aer( 16) = 'seas' + dens_mastercomp_aer( 16) = dens_seas_aer + mw_mastercomp_aer( 16) = mw_seas_aer + hygro_mastercomp_aer(16) = hygro_seas_aer + + name_mastercomp_aer( 17) = 'soil' + dens_mastercomp_aer( 17) = dens_dust_aer + mw_mastercomp_aer( 17) = mw_dust_aer + hygro_mastercomp_aer(17) = hygro_dust_aer + + name_mastercomp_aer(18) = 'sodium' + dens_mastercomp_aer(18) = dens_na_aer + mw_mastercomp_aer( 18) = mw_na_aer + hygro_mastercomp_aer(18) = hygro_na_aer + + name_mastercomp_aer(19) = 'chloride' + dens_mastercomp_aer(19) = dens_cl_aer + mw_mastercomp_aer( 19) = mw_cl_aer + hygro_mastercomp_aer(19) = hygro_cl_aer + + lptr_so4_aer( :,:,:) = 1 + lptr_nh4_aer( :,:,:) = 1 + lptr_no3_aer( :,:,:) = 1 + lptr_na_aer( :,:,:) = 1 + lptr_cl_aer( :,:,:) = 1 + lptr_asoa1_aer(:,:,:) = 1 + lptr_asoa2_aer(:,:,:) = 1 + lptr_asoa3_aer( :,:,:) = 1 + lptr_asoa4_aer( :,:,:) = 1 + lptr_bsoa1_aer( :,:,:) = 1 + lptr_bsoa2_aer( :,:,:) = 1 + lptr_bsoa3_aer( :,:,:) = 1 + lptr_bsoa4_aer( :,:,:) = 1 + lptr_orgpa_aer( :,:,:) = 1 + lptr_ec_aer( :,:,:) = 1 + lptr_p25_aer( :,:,:) = 1 + lptr_anth_aer( :,:,:) = 1 + lptr_seas_aer( :,:,:) = 1 + lptr_soil_aer( :,:,:) = 1 + numptr_aer( :,:,:) = 1 + + do_cloudchem_aer(:,:) = .false. + + +! Aitken mode + itype = 1 + isize = 1 + ncomp_aer(itype) = 16 + numptr_aer( isize,itype,ai_phase) = p_nu0 + lptr_so4_aer( isize,itype,ai_phase) = p_so4ai + lptr_nh4_aer( isize,itype,ai_phase) = p_nh4ai + lptr_no3_aer( isize,itype,ai_phase) = p_no3ai + lptr_na_aer( isize,itype,ai_phase) = p_naai + lptr_cl_aer( isize,itype,ai_phase) = p_clai + lptr_asoa1_aer(isize,itype,ai_phase) = p_asoa1i + lptr_asoa2_aer(isize,itype,ai_phase) = p_asoa2i + lptr_asoa3_aer( isize,itype,ai_phase) = p_asoa3i + lptr_asoa4_aer( isize,itype,ai_phase) = p_asoa4i + lptr_bsoa1_aer( isize,itype,ai_phase) = p_bsoa1i + lptr_bsoa2_aer( isize,itype,ai_phase) = p_bsoa2i + lptr_bsoa3_aer( isize,itype,ai_phase) = p_bsoa3i + lptr_bsoa4_aer( isize,itype,ai_phase) = p_bsoa4i + lptr_orgpa_aer( isize,itype,ai_phase) = p_orgpai + lptr_ec_aer( isize,itype,ai_phase) = p_eci + lptr_p25_aer( isize,itype,ai_phase) = p_p25i +! aerosol in cloud water + if(cw_phase.gt.0)then + numptr_aer( isize,itype,cw_phase) = p_nu0cw + lptr_so4_aer( isize,itype,cw_phase) = p_so4cwi + lptr_nh4_aer( isize,itype,cw_phase) = p_nh4cwi + lptr_no3_aer( isize,itype,cw_phase) = p_no3cwi + lptr_na_aer( isize,itype,ai_phase) = p_nacwi + lptr_cl_aer( isize,itype,ai_phase) = p_clcwi + lptr_asoa1_aer(isize,itype,cw_phase) = p_asoa1cwi + lptr_asoa2_aer(isize,itype,cw_phase) = p_asoa2cwi + lptr_asoa3_aer( isize,itype,cw_phase) = p_asoa3cwi + lptr_asoa4_aer( isize,itype,cw_phase) = p_asoa4cwi + lptr_bsoa1_aer( isize,itype,cw_phase) = p_bsoa1cwi + lptr_bsoa2_aer( isize,itype,cw_phase) = p_bsoa2cwi + lptr_bsoa3_aer( isize,itype,cw_phase) = p_bsoa3cwi + lptr_bsoa4_aer( isize,itype,cw_phase) = p_bsoa4cwi + lptr_orgpa_aer( isize,itype,cw_phase) = p_orgpacwi + lptr_ec_aer( isize,itype,cw_phase) = p_eccwi + lptr_p25_aer( isize,itype,cw_phase) = p_p25cwi + do_cloudchem_aer(isize,itype) = .true. + endif + +! Accumulation mode + itype = 1 + isize = 2 + ncomp_aer(itype) = 16 + numptr_aer( isize,itype,ai_phase) = p_ac0 + lptr_so4_aer( isize,itype,ai_phase) = p_so4aj + lptr_nh4_aer( isize,itype,ai_phase) = p_nh4aj + lptr_no3_aer( isize,itype,ai_phase) = p_no3aj + lptr_na_aer( isize,itype,ai_phase) = p_naaj + lptr_cl_aer( isize,itype,ai_phase) = p_claj + lptr_asoa1_aer(isize,itype,ai_phase) = p_asoa1j + lptr_asoa2_aer(isize,itype,ai_phase) = p_asoa2j + lptr_asoa3_aer( isize,itype,ai_phase) = p_asoa3j + lptr_asoa4_aer( isize,itype,ai_phase) = p_asoa4j + lptr_bsoa1_aer( isize,itype,ai_phase) = p_bsoa1j + lptr_bsoa2_aer( isize,itype,ai_phase) = p_bsoa2j + lptr_bsoa3_aer( isize,itype,ai_phase) = p_bsoa3j + lptr_bsoa4_aer( isize,itype,ai_phase) = p_bsoa4j + lptr_orgpa_aer( isize,itype,ai_phase) = p_orgpaj + lptr_ec_aer( isize,itype,ai_phase) = p_ecj + lptr_p25_aer( isize,itype,ai_phase) = p_p25j +! aerosol in cloud water + if(cw_phase.gt.0)then + numptr_aer( isize,itype,cw_phase) = p_ac0cw + lptr_so4_aer( isize,itype,cw_phase) = p_so4cwj + lptr_nh4_aer( isize,itype,cw_phase) = p_nh4cwj + lptr_no3_aer( isize,itype,cw_phase) = p_no3cwj + lptr_na_aer( isize,itype,ai_phase) = p_nacwj + lptr_cl_aer( isize,itype,ai_phase) = p_clcwj + lptr_asoa1_aer(isize,itype,cw_phase) = p_asoa1cwj + lptr_asoa2_aer(isize,itype,cw_phase) = p_asoa2cwj + lptr_asoa3_aer( isize,itype,cw_phase) = p_asoa3cwj + lptr_asoa4_aer( isize,itype,cw_phase) = p_asoa4cwj + lptr_bsoa1_aer( isize,itype,cw_phase) = p_bsoa1cwj + lptr_bsoa2_aer( isize,itype,cw_phase) = p_bsoa2cwj + lptr_bsoa3_aer( isize,itype,cw_phase) = p_bsoa3cwj + lptr_bsoa4_aer( isize,itype,cw_phase) = p_bsoa4cwj + lptr_orgpa_aer( isize,itype,cw_phase) = p_orgpacwj + lptr_ec_aer( isize,itype,cw_phase) = p_eccwj + lptr_p25_aer( isize,itype,cw_phase) = p_p25cwj + do_cloudchem_aer(isize,itype) = .true. + endif + +! coarse mode + itype = 2 + isize = 1 + ncomp_aer(itype) = 3 + numptr_aer( isize,itype,ai_phase) = p_corn + lptr_anth_aer( isize,itype,ai_phase) = p_antha + lptr_seas_aer( isize,itype,ai_phase) = p_seas + lptr_soil_aer( isize,itype,ai_phase) = p_soila +! aerosol in cloud water + if(cw_phase.gt.0)then + numptr_aer( isize,itype,cw_phase) = p_corncw + lptr_anth_aer( isize,itype,cw_phase) = p_anthcw + lptr_seas_aer( isize,itype,cw_phase) = p_seascw + lptr_soil_aer( isize,itype,cw_phase) = p_soilcw +! no cloudchem for coarse mode because it has no so4/nh4/no3 species + do_cloudchem_aer(isize,itype) = .false. + endif + + massptr_aer(:,:,:,:) = -999888777 + mastercompptr_aer(:,:) = -999888777 + + p1st = param_first_scalar + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + ll = 0 + if (lptr_so4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_so4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 1 + end if + if (lptr_no3_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_no3_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 2 + end if + if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_nh4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 3 + end if + if (lptr_asoa1_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_asoa1_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 4 + end if + if (lptr_asoa2_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_asoa2_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 5 + end if + if (lptr_asoa3_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_asoa3_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 6 + end if + if (lptr_asoa4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_asoa4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 7 + end if + if (lptr_bsoa1_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_bsoa1_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 8 + end if + if (lptr_bsoa2_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_bsoa2_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 9 + end if + if (lptr_bsoa3_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_bsoa3_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 10 + end if + if (lptr_bsoa4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_bsoa4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 11 + end if + if (lptr_orgpa_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgpa_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 12 + end if + if (lptr_ec_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_ec_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 13 + end if + if (lptr_p25_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_p25_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 14 + end if + if (lptr_anth_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_anth_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 15 + end if + if (lptr_seas_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_seas_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 16 + end if + if (lptr_soil_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_soil_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 17 + end if + if (lptr_na_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_na_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 18 + end if + if (lptr_cl_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_cl_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 19 + endif + ncomp_aer_nontracer(itype) = ll + + ncomp_aer(itype) = ll + + mprognum_aer(n,itype,iphase) = 0 + if (numptr_aer(n,itype,iphase) .ge. p1st) then + mprognum_aer(n,itype,iphase) = 1 + end if + + end do ! size + end do ! type + end do ! phase + + waterptr_aer(:,:) = 0 + + do itype=1,ntype_aer + do ll=1,ncomp_aer(itype) + dens_aer(ll,itype) = dens_mastercomp_aer(mastercompptr_aer(ll,itype)) + mw_aer(ll,itype) = mw_mastercomp_aer(mastercompptr_aer(ll,itype)) + hygro_aer(ll,itype) = hygro_mastercomp_aer(mastercompptr_aer(ll,itype)) + name_aer(ll,itype) = name_mastercomp_aer(mastercompptr_aer(ll,itype)) + end do + end do + + is_aerosol(:) = .false. + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + do ll = 1, ncomp_aer(itype) + is_aerosol(massptr_aer(ll,n,itype,iphase))=.true. + end do + is_aerosol(numptr_aer(n,itype,iphase))=.true. + end do ! size + end do ! type + end do ! phase + +! for sectional +! the dhi/dlo_sect are the upper/lower bounds for +! mean-volume diameter for a section/bin +! for modal +! they should be set to reasonable upper/lower +! bounds for mean-volume diameters of each modes +! they are primarily used to put reasonable bounds +! on number (in relation to mass/volume) +! the dcen_sect are used by initwet for the impaction scavenging +! lookup tables, and should represent a "base" mean-volume diameter +! dp_meanvol_tmp (below) is the made-sorgam default initial value +! for mean-volume diameter (in cm) +! terminology: (pi/6) * (mean-volume diameter)**3 == +! (volume mixing ratio of section/mode)/(number mixing ratio) +! + dhi_sect(:,:) = 0.0 + dlo_sect(:,:) = 0.0 + + itype = 1 + isize = 1 + sigmag_aer(isize,itype) = sginin ! aitken + dp_meanvol_tmp = 1.0e2*dginin*exp(1.5*l2sginin) ! aitken + dcen_sect(isize,itype) = dp_meanvol_tmp + dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 + dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 + + itype = 1 + isize = 2 + sigmag_aer(isize,itype) = sginia ! accum + dp_meanvol_tmp = 1.0e2*dginia*exp(1.5*l2sginia) ! accum + dcen_sect(isize,itype) = dp_meanvol_tmp + dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 + dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 + + itype = 2 + isize = 1 + sigmag_aer(isize,itype) = sginic ! coarse + dp_meanvol_tmp = 1.0e2*dginic*exp(1.5*l2sginic) ! coarse + dcen_sect(isize,itype) = dp_meanvol_tmp + dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 + dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + volumcen_sect(isize,itype) = (pirs/6.0)*(dcen_sect(isize,itype)**3) + volumlo_sect(isize,itype) = (pirs/6.0)*(dlo_sect(isize,itype)**3) + volumhi_sect(isize,itype) = (pirs/6.0)*(dhi_sect(isize,itype)**3) + end do + end do + + +! do initialization of the impaction/interception scavenging +! lookup tables + call initwet( & + ntype_aer, nsize_aer, ncomp_aer, & + massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, & + dcen_sect, sigmag_aer, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, & + nimptblgrow_maxd, dlndg_nimptblgrow ) + + END SUBROUTINE aerosols_sorgam_vbs_init_aercld_ptrs + +!**************************************************************** +! * +! SUBROUTINE TO INITIALIZE AEROSOL VALUES USING THE * +! aer_ic_opt == aer_ic_pnnl OPTION. * +! * +! wig, 21-Apr-2004, original version * +! rce, 25-apr-2004 - name changes for consistency with * +! new aer_ic constants in Registry * +! wig, 7-May-2004, added height dependance * +! * +! CALLS THE FOLLOWING SUBROUTINES: NONE * +! * +! CALLED BY : aerosols_sorgam_init * +! * +!**************************************************************** + SUBROUTINE sorgam_vbs_init_aer_ic_pnnl( & + chem, z, i,k,j, ims,ime, jms,jme, kms,kme ) + + USE module_configure,only: num_chem, grid_config_rec_type + implicit none + + INTEGER,INTENT(IN ) :: i,k,j, & + ims,ime, jms,jme, kms,kme + REAL, DIMENSION( ims:ime , kms:kme , jms:jme, num_chem ),& + INTENT(INOUT ) :: chem + + real, intent(in ) :: z + real :: mult + +! +! Determine height multiplier... +! This should mimic the calculation in sorgam_set_aer_bc_pnnl, +! mosaic_init_wrf_mixrats_opt2, and bdy_chem_value_mosaic +!!$! Height(m) Multiplier +!!$! --------- ---------- +!!$! <=2000 1.0 +!!$! 2000=3000 0.25 +!!$! +!!$! which translates to: +!!$! 2000 2000. & +!!$ .and. z <= 3000. ) then +!!$ mult = 1.0 - 0.0005*(z-2000.) +!!$ elseif( z > 3000. & +!!$ .and. z <= 5000. ) then +!!$ mult = 0.5 - 1.25e-4*(z-3000.) +!!$ else +!!$ mult = 0.25 +!!$ end if +! Updated aerosol profile multiplier 1-Apr-2005: +! Height(m) Multiplier +! --------- ---------- +! <=2000 1.0 +! 2000=5000 0.125 +! +! which translates to: +! 2000 2000. & +! .and. z <= 3000. ) then +! mult = 1.0 - 0.00075*(z-2000.) +! elseif( z > 3000. & +! .and. z <= 5000. ) then +! mult = 0.25 - 4.166666667e-5*(z-3000.) +! else +! mult = 0.125 +! end if + if( z <= 500. ) then + mult = 1.0 + elseif( z > 500. & + .and. z <= 1000. ) then + mult = 1.0 - 0.001074*(z-500.) + elseif( z > 1000. & + .and. z <= 5000. ) then + mult = 0.463 - 0.000111*(z-1000.) + else + mult = 0.019 + end if + +! These should match what is in sorgam_set_aer_bc_pnnl. +! Values as of 2-Dec-2004: +!jdf comment these values and have another profile consistent with mosaic +! chem(i,k,j,p_sulf) = mult*conmin +! chem(i,k,j,p_so4aj) = mult*2.375 +! chem(i,k,j,p_so4ai) = mult*0.179 +! chem(i,k,j,p_nh4aj) = mult*0.9604 +! chem(i,k,j,p_nh4ai) = mult*0.0196 +! chem(i,k,j,p_no3aj) = mult*0.0650 +! chem(i,k,j,p_no3ai) = mult*0.0050 +! chem(i,k,j,p_ecj) = mult*0.1630 +! chem(i,k,j,p_eci) = mult*0.0120 +! chem(i,k,j,p_p25j) = mult*0.6350 +! chem(i,k,j,p_p25i) = mult*0.0490 +! chem(i,k,j,p_antha) = mult*2.2970 +! chem(i,k,j,p_orgpaj) = mult*0.9300 +! chem(i,k,j,p_orgpai) = mult*0.0700 +! chem(i,k,j,p_orgaro1j) = conmin +! chem(i,k,j,p_orgaro1i) = conmin +! chem(i,k,j,p_orgaro2j) = conmin +! chem(i,k,j,p_orgaro2i) = conmin +! chem(i,k,j,p_orgalk1j) = conmin +! chem(i,k,j,p_orgalk1i) = conmin +! chem(i,k,j,p_orgole1j) = conmin +! chem(i,k,j,p_orgole1i) = conmin +! chem(i,k,j,p_orgba1j) = conmin +! chem(i,k,j,p_orgba1i) = conmin +! chem(i,k,j,p_orgba2j) = conmin +! chem(i,k,j,p_orgba2i) = conmin +! chem(i,k,j,p_orgba3j) = conmin +! chem(i,k,j,p_orgba3i) = conmin +! chem(i,k,j,p_orgba4j) = conmin +! chem(i,k,j,p_orgba4i) = conmin +! chem(i,k,j,p_seas) = mult*0.229 + chem(i,k,j,p_sulf) = mult*conmin + chem(i,k,j,p_so4aj) = mult*0.300*0.97 + chem(i,k,j,p_so4ai) = mult*0.300*0.03 + chem(i,k,j,p_nh4aj) = mult*0.094*0.97 + chem(i,k,j,p_nh4ai) = mult*0.094*0.03 + chem(i,k,j,p_no3aj) = mult*0.001*0.97 + chem(i,k,j,p_no3ai) = mult*0.001*0.03 + chem(i,k,j,p_naaj) = 10.E-05 + chem(i,k,j,p_naai) = 10.E-05 + chem(i,k,j,p_claj) = 10.E-05 + chem(i,k,j,p_clai) = 10.E-05 + chem(i,k,j,p_ecj) = mult*0.013*0.97 + chem(i,k,j,p_eci) = mult*0.013*0.03 + chem(i,k,j,p_p25j) = mult*4.500*0.97 + chem(i,k,j,p_p25i) = mult*4.500*0.03 + chem(i,k,j,p_antha) = mult*4.500/2.0 + chem(i,k,j,p_orgpaj) = mult*0.088*0.97 + chem(i,k,j,p_orgpai) = mult*0.088*0.03 + chem(i,k,j,p_asoa1j) = conmin + chem(i,k,j,p_asoa1i) = conmin + chem(i,k,j,p_asoa2j) = conmin + chem(i,k,j,p_asoa2i) = conmin + chem(i,k,j,p_asoa3j) = conmin + chem(i,k,j,p_asoa3i) = conmin + chem(i,k,j,p_asoa4j) = conmin + chem(i,k,j,p_asoa4i) = conmin + chem(i,k,j,p_bsoa1j) = conmin + chem(i,k,j,p_bsoa1i) = conmin + chem(i,k,j,p_bsoa2j) = conmin + chem(i,k,j,p_bsoa2i) = conmin + chem(i,k,j,p_bsoa3j) = conmin + chem(i,k,j,p_bsoa3i) = conmin + chem(i,k,j,p_bsoa4j) = conmin + chem(i,k,j,p_bsoa4i) = conmin + chem(i,k,j,p_seas) = mult*1.75 + + + END SUBROUTINE sorgam_vbs_init_aer_ic_pnnl +! +SUBROUTINE sorgam_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, & + ebu, & + slai,ust,smois,ivgtyp,isltyp, & + emis_ant,dust_emiss_active, & + seasalt_emiss_active,kemit,biom,num_soil_layers,emissopt, & + dust_opt,ktau,p8w,u_phy,v_phy,rho_phy,g,dx,erod, & +!KW + emis_seas2, & +!KW + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! +! Routine to apply aerosol emissions for MADE/SOA_VBS... +! William.Gustafson@pnl.gov; 3-May-2007 +! Modified by +! steven.peckham@noaa.gov; 8-Jan-2008 +!------------------------------------------------------------------------ + + USE module_state_description, only: num_chem,num_emis_seas2 + + INTEGER, INTENT(IN ) :: seasalt_emiss_active,kemit,emissopt, & + dust_emiss_active,num_soil_layers,id, & + ktau,dust_opt,biom, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, INTENT(IN ) :: dtstep + +! trace species mixing ratios (aerosol mass = ug/kg-air; number = #/kg-air) + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +!KW + REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_seas2),OPTIONAL, & + INTENT(INOUT ) :: & + emis_seas2 +!KW + +! +! aerosol emissions arrays ((ug/m3)*m/s) +! + REAL, DIMENSION( ims:ime, kms:kemit, jms:jme,num_emis_ant ), & + INTENT(IN ) :: emis_ant + +! biomass burning aerosol emissions arrays ((ug/m3)*m/s) + REAL, DIMENSION( ims:ime, kms:kme, jms:jme,num_ebu ), & + INTENT(IN ) :: ebu + +! 1/(dry air density) and layer thickness (m) + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + alt, dz8w + + ! add for gocart dust + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: p8w,u_phy,v_phy,rho_phy + REAL, INTENT(IN ) :: dx, g + REAL, DIMENSION( ims:ime, jms:jme, 3 ), & + INTENT(IN ) :: erod + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: & + u10, v10, xland, slai, ust + INTEGER, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: ivgtyp, isltyp + REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ), & + INTENT(INOUT) :: smois + +! Local variables... + real, dimension(its:ite,kts:kte,jts:jte) :: factor +! +! Get the emissions unit conversion factor including the time step. +! Changes emissions from [ug/m3 m/s] to [ug/kg_dryair/timestep] +! + factor(its:ite,kts:kte,jts:jte) = alt(its:ite,kts:kte,jts:jte)*dtstep/ & + dz8w(its:ite,kts:kte,jts:jte) +! +! Increment the aerosol numbers... +! +! Increment the aerosol numbers... +!KW Changed 'if' statement +!KW if(emissopt .lt. 5 )then + if(emissopt .ne. 5 )then +! +! Aitken mode first... + + chem(its:ite,kts:kemit,jts:jte,p_nu0) = & + chem(its:ite,kts:kemit,jts:jte,p_nu0) + & + factor(its:ite,kts:kemit,jts:jte)*factnumn*( & + anthfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i) + & + anthfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci) + & + nafac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai) + & + orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi) + & + so4fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4i) + & + no3fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3i) ) + +!KW chem(its:ite,kts:kemit,jts:jte,p_nu0) = & +!KW chem(its:ite,kts:kemit,jts:jte,p_nu0) + & +!KW factor(its:ite,kts:kemit,jts:jte)*factnumn*( & +!KW anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i) + & +!KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci) + & +!KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai) ) + & +!KW orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi) ) + +! Accumulation mode next... + + chem(its:ite,kts:kemit,jts:jte,p_ac0) = & + chem(its:ite,kts:kemit,jts:jte,p_ac0) + & + factor(its:ite,kts:kemit,jts:jte)*factnuma*( & + anthfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j) + & + anthfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj) + & + nafac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj) + & + orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj) + & + so4fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4j) + & + no3fac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3j) ) + +!KW chem(its:ite,kts:kemit,jts:jte,p_ac0) = & +!KW chem(its:ite,kts:kemit,jts:jte,p_ac0) + & +!KW factor(its:ite,kts:kemit,jts:jte)*factnuma*( & +!KW anthfac*( emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j) + & +!KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj) + & +!KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj) ) + & +!KW orgfac*emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj) ) + +! And now the coarse mode... + + chem(its:ite,kts:kemit,jts:jte,p_corn) = & + chem(its:ite,kts:kemit,jts:jte,p_corn) + & + factor(its:ite,kts:kemit,jts:jte)*factnumc*anthfac* & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm10) !KW +!KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10) +! +! Increment the aerosol masses... +! + chem(its:ite,kts:kemit,jts:jte,p_antha) = & + chem(its:ite,kts:kemit,jts:jte,p_antha) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm10)*factor(its:ite,kts:kemit,jts:jte) !KW +!KW emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm_10)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_p25j) = & + chem(its:ite,kts:kemit,jts:jte,p_p25j) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25j)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_p25i) = & + chem(its:ite,kts:kemit,jts:jte,p_p25i) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_pm25i)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_ecj) = & + chem(its:ite,kts:kemit,jts:jte,p_ecj) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_ecj)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_eci) = & + chem(its:ite,kts:kemit,jts:jte,p_eci) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_eci)*factor(its:ite,kts:kemit,jts:jte) + chem(its:ite,kts:kemit,jts:jte,p_naaj) = & + chem(its:ite,kts:kemit,jts:jte,p_naaj) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_naaj)*factor(its:ite,kts:kemit,jts:jte) + chem(its:ite,kts:kemit,jts:jte,p_naai) = & + chem(its:ite,kts:kemit,jts:jte,p_naai) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_naai)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_orgpaj) = & + chem(its:ite,kts:kemit,jts:jte,p_orgpaj) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgj)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_orgpai) = & + chem(its:ite,kts:kemit,jts:jte,p_orgpai) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_orgi)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_so4aj) = & + chem(its:ite,kts:kemit,jts:jte,p_so4aj) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4j)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_so4ai) = & + chem(its:ite,kts:kemit,jts:jte,p_so4ai) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_so4i)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_no3aj) = & + chem(its:ite,kts:kemit,jts:jte,p_no3aj) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3j)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_no3ai) = & + chem(its:ite,kts:kemit,jts:jte,p_no3ai) + & + emis_ant(its:ite,kts:kemit,jts:jte,p_e_no3i)*factor(its:ite,kts:kemit,jts:jte) + + elseif(emissopt == 5)then +! +! Aitken mode first... + + chem(its:ite,kts:kemit,jts:jte,p_nu0) = & + chem(its:ite,kts:kemit,jts:jte,p_nu0) + & + factor(its:ite,kts:kemit,jts:jte)*factnumn*( & + anthfac*( .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + & + orgfac*.25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) ) + +! Accumulation mode next... + + chem(its:ite,kts:kemit,jts:jte,p_ac0) = & + chem(its:ite,kts:kemit,jts:jte,p_ac0) + & + factor(its:ite,kts:kemit,jts:jte)*factnuma*( & + anthfac*( .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc) ) + & + orgfac*.75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc) ) + +! +! Increment the aerosol masses... +! + + chem(its:ite,kts:kemit,jts:jte,p_ecj) = & + chem(its:ite,kts:kemit,jts:jte,p_ecj) + & + .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_eci) = & + chem(its:ite,kts:kemit,jts:jte,p_eci) + & + .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_bc)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_orgpaj) = & + chem(its:ite,kts:kemit,jts:jte,p_orgpaj) + & + .75*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte) + + chem(its:ite,kts:kemit,jts:jte,p_orgpai) = & + chem(its:ite,kts:kemit,jts:jte,p_orgpai) + & + .25*emis_ant(its:ite,kts:kemit,jts:jte,p_e_oc)*factor(its:ite,kts:kemit,jts:jte) + + endif +! add biomass burning emissions if present +! + if(biom == 1 )then +! +! Aitken mode first... + + chem(its:ite,kts:kte,jts:jte,p_nu0) = & + chem(its:ite,kts:kte,jts:jte,p_nu0) + & + factor(its:ite,kts:kte,jts:jte)*factnumn*( & + anthfac*( .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + & + .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + & + orgfac*.25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) ) + +! Accumulation mode next... + + chem(its:ite,kts:kte,jts:jte,p_ac0) = & + chem(its:ite,kts:kte,jts:jte,p_ac0) + & + factor(its:ite,kts:kte,jts:jte)*factnuma*( & + anthfac*(.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25) + & + .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc) ) + & + orgfac*.75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc) ) +! coarse + chem(its:ite,kts:kte,jts:jte,p_corn) = & + chem(its:ite,kts:kte,jts:jte,p_corn) + & + factor(its:ite,kts:kte,jts:jte)*factnumc*anthfac* & + ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10) + +! +! Increment the aerosol masses... +! + + chem(its:ite,kts:kte,jts:jte,p_ecj) = & + chem(its:ite,kts:kte,jts:jte,p_ecj) + & + .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_eci) = & + chem(its:ite,kts:kte,jts:jte,p_eci) + & + .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_bc)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_orgpaj) = & + chem(its:ite,kts:kte,jts:jte,p_orgpaj) + & + .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_orgpai) = & + chem(its:ite,kts:kte,jts:jte,p_orgpai) + & + .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_oc)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_antha) = & + chem(its:ite,kts:kte,jts:jte,p_antha) + & + ebu(its:ite,kts:kte,jts:jte,p_ebu_pm10)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_p25j) = & + chem(its:ite,kts:kte,jts:jte,p_p25j) + & + .75*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte) + + chem(its:ite,kts:kte,jts:jte,p_p25i) = & + chem(its:ite,kts:kte,jts:jte,p_p25i) + & + .25*ebu(its:ite,kts:kte,jts:jte,p_ebu_pm25)*factor(its:ite,kts:kte,jts:jte) + + endif !end biomass burning +! +! Get the sea salt emissions... +! + if( seasalt_emiss_active == 1 ) then + call sorgam_vbs_seasalt_emiss( & + dtstep, u10, v10, alt, dz8w, xland, chem, & +!KW + emis_seas2, & +!KW + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + end if + if( seasalt_emiss_active == 2 ) then +! call Monahan_seasalt_emiss( & +! dtstep, u10, v10, alt, dz8w, xland, chem, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) + end if + if( dust_opt == 2 ) then + call sorgam_vbs_dust_emiss( & + slai, ust, smois, ivgtyp, isltyp, & + id, dtstep, u10, v10, alt, dz8w, & + xland, num_soil_layers, chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + end if + if( dust_opt == 5 ) then + call sorgam_vbs_dust_gocartemis( & + ktau,dtstep,num_soil_layers,alt,u_phy, & + v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, & + ivgtyp,isltyp,xland,dx,g, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + end if + +END SUBROUTINE sorgam_vbs_addemiss + +!------------------------------------------------------------------------ +SUBROUTINE sorgam_vbs_seasalt_emiss( & + dtstep, u10, v10, alt, dz8w, xland, chem, & +!KW + emis_seas2, & +!KW + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! +! Routine to calculate seasalt emissions for SOA_VBS over the time +! dtstep... +! William.Gustafson@pnl.gov; 10-May-2007 +!------------------------------------------------------------------------ + + USE module_mosaic_addemiss, only: seasalt_emitfactors_1bin + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, INTENT(IN ) :: dtstep + +! 10-m wind speed components (m/s) + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: u10, v10, xland + +! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg) + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +!KW + REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_seas2),OPTIONAL, & + INTENT(INOUT ) :: & + emis_seas2 +!KW + +! alt = 1.0/(dry air density) in (m3/kg) +! dz8w = layer thickness in (m) + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: alt, dz8w + +! local variables + integer :: i, j, k, l, l_na, l_cl, n + integer :: p1st + + real :: dum, dumdlo, dumdhi, dumoceanfrac, dumspd10 + real :: factaa, factbb, fraccl, fracna + + real :: ssemfact_numb_i, ssemfact_numb_j, ssemfact_numb_c + real :: ssemfact_mass_i, ssemfact_mass_j, ssemfact_mass_c + + +! Compute emissions factors for the Aitken mode... +! Nope, we won't because the parameterization is only valid down to +! 0.1 microns. +! Setup in units of cm. +! dumdlo = 0.039e-4 +! dumdhi = 0.078e-4 + ssemfact_numb_i = 0. + ssemfact_mass_i = 0. + +! Compute emissions factors for the accumulation mode... +! Potentially, we could go down to 0.078 microns to match the bin +! boundary for MOSAIC, but MOSAIC is capped at 0.1 too. The upper end +! has been chosen to match the MOSAIC bin boundary closest to two +! standard deviations from the default bin mean diameter for the coarse +! mode. + dumdlo = 0.1e-4 + dumdhi = 1.250e-4 + call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, & + ssemfact_numb_j, dum, ssemfact_mass_j ) + +! Compute emissions factors for the coarse mode... + dumdlo = 1.25e-4 + dumdhi = 10.0e-4 + call seasalt_emitfactors_1bin( 1, dumdlo, dumdhi, & + ssemfact_numb_c, dum, ssemfact_mass_c ) + +! Convert mass emissions factor from (g/m2/s) to (ug/m2/s) + ssemfact_mass_i = ssemfact_mass_i*1.0e6 + ssemfact_mass_j = ssemfact_mass_j*1.0e6 + ssemfact_mass_c = ssemfact_mass_c*1.0e6 + +! Loop over i,j and apply seasalt emissions + k = kts + do j = jts, jte + do i = its, ite + + !Skip this point if over land. xland=1 for land and 2 for water. + !Also, there is no way to differentiate fresh from salt water. + !Currently, this assumes all water is salty. + if( xland(i,j) < 1.5 ) cycle + + !wig: As far as I can tell, only real.exe knows the fractional breakdown + ! of land use. So, in wrf.exe, dumoceanfrac will always be 1. + dumoceanfrac = 1. !fraction of grid i,j that is salt water + dumspd10 = dumoceanfrac* & + ( (u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5*3.41) ) + +! factaa is (s*m2/kg-air) +! factaa*ssemfact_mass(n) is (s*m2/kg-air)*(ug/m2/s) = ug/kg-air +! factaa*ssemfact_numb(n) is (s*m2/kg-air)*( #/m2/s) = #/kg-air + factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j) + factbb = factaa * dumspd10 + +! Apportion seasalt mass emissions assumming that seasalt is pure NaCl + fracna = mw_na_aer / (mw_na_aer + mw_cl_aer) + fraccl = 1.0 - fracna + +! Add the emissions into the chem array... + chem(i,k,j,p_naai) = chem(i,k,j,p_naai) + & + factbb * ssemfact_mass_i * fracna + chem(i,k,j,p_clai) = chem(i,k,j,p_clai) + & + factbb * ssemfact_mass_i * fraccl + chem(i,k,j,p_nu0) = chem(i,k,j,p_nu0) + & + factbb * ssemfact_numb_i + + chem(i,k,j,p_naaj) = chem(i,k,j,p_naaj) + & + factbb * ssemfact_mass_j * fracna + chem(i,k,j,p_claj) = chem(i,k,j,p_claj) + & + factbb * ssemfact_mass_j * fraccl + chem(i,k,j,p_ac0) = chem(i,k,j,p_ac0) + & + factbb * ssemfact_numb_j + + chem(i,k,j,p_seas) = chem(i,k,j,p_seas) + & + factbb * ssemfact_mass_c + chem(i,k,j,p_corn) = chem(i,k,j,p_corn) + & + factbb * ssemfact_numb_c + +!KW sea emis g/m2/s + emis_seas2(i,1,j,p_eseasj)=ssemfact_mass_j*dumspd10/1.0e6 + emis_seas2(i,1,j,p_eseasc)=ssemfact_mass_c*dumspd10/1.0e6 +!KW + + end do !i + end do !j +END SUBROUTINE sorgam_vbs_seasalt_emiss +!---------------------------------------------------------------------- + + subroutine sorgam_vbs_dust_emiss( slai,ust, smois, ivgtyp, isltyp, & + id, dtstep, u10, v10, alt, dz8w, xland, num_soil_layers, & + chem, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! +! adds dust emissions for mosaic aerosol species (i.e. emission tendencies +! over time dtstep are applied to the aerosol mixing ratios) +! +! This is a simple dust scheme based on Shaw et al. (2008) to appear in +! Atmospheric Environment, recoded by Jerome Fast +! +! NOTE: +! 1) This version only works with the 8-bin version of MOSAIC. +! 2) Dust added to MOSAIC's other inorganic specie, OIN. If Ca and CO3 are +! activated in the Registry, a small fraction also added to Ca and CO3. +! 3) The main departure from Shaw et al., is now alphamask is computed since +! the land-use categories in that paper and in WRF differ. WRF currently +! does not have that many land-use categories and adhoc assumptions had to +! be made. This version was tested for Mexico in the dry season. The main +! land-use categories in WRF that are likely dust sources are grass, shrub, +! and savannna (that WRF has in the desert regions of NW Mexico). Having +! dust emitted from these types for other locations and other times of the +! year is not likely to be valid. +! 4) An upper bound on ustar was placed because the surface parameterizations +! in WRF can produce unrealistically high values that lead to very high +! dust emission rates. +! 5) Other departures' from Shaw et al. noted below, but are probably not as +! important as 2) and 3). +! + USE module_configure, only: grid_config_rec_type + USE module_state_description, only: num_chem, param_first_scalar + USE module_data_mosaic_asect + + IMPLICIT NONE + +! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: id,num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, INTENT(IN ) :: dtstep + +! 10-m wind speed components (m/s) + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: u10, v10, xland, slai, ust + INTEGER, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: ivgtyp, isltyp + +! trace species mixing ratios (aerosol mass = ug/kg; number = #/kg) + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! alt = 1.0/(dry air density) in (m3/kg) +! dz8w = layer thickness in (m) + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: alt, dz8w + + REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , & + INTENT(INOUT) :: smois + +! local variables + integer i, j, k, l, l_oin, l_ca, l_co3, n, ii + integer iphase, itype, izob + integer p1st + + real dum, dumdlo, dumdhi, dumlandfrac, dumspd10 + real factaa, factbb, fracoin, fracca, fracco3, fractot + real ustart, ustar1, ustart0 + real alphamask, f8, f50, f51, f52, wetfactor, sumdelta, ftot + real smois_grav, wp, pclay + real :: beta(4,7) + real :: gamma(4), delta(4) + real :: sz(8) + real :: dustflux, densdust, mass1part + real :: dp_meanvol_tmp +! +! from Nickovic et al., JGR, 2001 and Shaw et al. 2007 +! beta: fraction of clay, small silt, large silt, and sand correcsponding to Zobler class (7) +! beta (1,*) for 0.5-1 um +! beta (2,*) for 1-10 um +! beta (3,*) for 10-25 um +! beta (4,*) for 25-50 um +! + beta(1,1)=0.12 + beta(2,1)=0.04 + beta(3,1)=0.04 + beta(4,1)=0.80 + beta(1,2)=0.34 + beta(2,2)=0.28 + beta(3,2)=0.28 + beta(4,2)=0.10 + beta(1,3)=0.45 + beta(2,3)=0.15 + beta(3,3)=0.15 + beta(4,3)=0.25 + beta(1,4)=0.12 + beta(2,4)=0.09 + beta(3,4)=0.09 + beta(4,4)=0.70 + beta(1,5)=0.40 + beta(2,5)=0.05 + beta(3,5)=0.05 + beta(4,5)=0.50 + beta(1,6)=0.34 + beta(2,6)=0.18 + beta(3,6)=0.18 + beta(4,6)=0.30 + beta(1,7)=0.22 + beta(2,7)=0.09 + beta(3,7)=0.09 + beta(4,7)=0.60 + gamma(1)=0.08 + gamma(2)=1.00 + gamma(3)=1.00 + gamma(4)=0.12 +! +! * Mass fractions for each size bin. These values were recommended by +! Natalie Mahowold, with bins 7 and 8 the same as bins 3 and 4 from CAM. +! * Changed slightly since Natelie's estimates do not add up to 1.0 +! * This would need to be made more generic for other bin sizes. +! sz(1)=0 +! sz(2)=1.78751e-06 +! sz(3)=0.000273786 +! sz(4)=0.00847978 +! sz(5)=0.056055 +! sz(6)=0.0951896 +! sz(7)=0.17 +! sz(8)=0.67 + sz(1)=0.0 + sz(2)=0.0 + sz(3)=0.0005 + sz(4)=0.0095 + sz(5)=0.03 + sz(6)=0.10 + sz(7)=0.18 + sz(8)=0.68 + +! for now just do itype=1 + itype = 1 + iphase = ai_phase + +! loop over i,j and apply dust emissions + k = kts + do 1830 j = jts, jte + do 1820 i = its, ite + + if( xland(i,j) > 1.5 ) cycle + +! compute wind speed anyway, even though ustar is used below + + dumlandfrac = 1. + dumspd10=(u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j))**(0.5) + if(dumspd10 >= 5.0) then + dumspd10 = dumlandfrac* & + ( dumspd10*dumspd10*(dumspd10-5.0)) + else + dumspd10=0. + endif + +! part1 - compute vegetation mask +! +! * f8, f50, f51, f52 refer to vegetation classes from the Olsen categories +! for desert, sand desert, grass aemi-desert, and shrub semi-desert +! * in WRF, vegetation types 7, 8 and 10 are grassland, shrubland, and savanna +! that are dominate types in Mexico and probably have some erodable surface +! during the dry season +! * currently modified these values so that only a small fraction of cell +! area is erodable +! * these values are highly tuneable! + + alphamask=0.001 + if (ivgtyp(i,j) .eq. 7) then + f8=0.005 + f50=0.00 + f51=0.10 + f52=0.00 + alphamask=(f8+f50)*1.0+(f51+f52)*0.5 + endif + if (ivgtyp(i,j) .eq. 8) then + f8=0.010 + f50=0.00 + f51=0.00 + f52=0.15 + alphamask=(f8+f50)*1.0+(f51+f52)*0.5 + endif + if (ivgtyp(i,j) .eq. 10) then + f8=0.00 + f50=0.00 + f51=0.01 + f52=0.00 + alphamask=(f8+f50)*1.0+(f51+f52)*0.5 + endif + +! part2 - zobler +! +! * in Shaw's paper, dust is computed for 4 size ranges: +! 0.5-1 um +! 1-10 um +! 10-25 um +! 25-50 um +! * Shaw's paper also accounts for sub-grid variability in soil +! texture, but here we just assume the same soil texture for each +! grid cell +! * since MOSAIC is currently has a maximum size range up to 10 um, +! neglect upper 2 size ranges and lowest size range (assume small) +! * map WRF soil classes arbitrarily to Zolber soil textural classes +! * skip dust computations for WRF soil classes greater than 13, i.e. +! do not compute dust over water, bedrock, and other surfaces +! * should be skipping for water surface at this point anyway +! + izob=0 + if(isltyp(i,j).eq.1) izob=1 + if(isltyp(i,j).eq.2) izob=1 + if(isltyp(i,j).eq.3) izob=4 + if(isltyp(i,j).eq.4) izob=2 + if(isltyp(i,j).eq.5) izob=2 + if(isltyp(i,j).eq.6) izob=2 + if(isltyp(i,j).eq.7) izob=7 + if(isltyp(i,j).eq.8) izob=2 + if(isltyp(i,j).eq.9) izob=6 + if(isltyp(i,j).eq.10) izob=5 + if(isltyp(i,j).eq.11) izob=2 + if(isltyp(i,j).eq.12) izob=3 + if(isltyp(i,j).ge.13) izob=0 + if(izob.eq.0) goto 1840 +! +! part3 - dustprod +! + do ii=1,4 + delta(ii)=0.0 + enddo + sumdelta=0.0 + do ii=1,4 + delta(ii)=beta(ii,izob)*gamma(ii) + if(ii.lt.4) then + sumdelta=sumdelta+delta(ii) + endif + enddo + do ii=1,4 + delta(ii)=delta(ii)/sumdelta + enddo + +! part4 - wetness +! +! * assume dry for now, have passed in soil moisture to this routine +! but needs to be included here +! * wetfactor less than 1 would reduce dustflux +! * convert model soil moisture (m3/m3) to gravimetric soil moisture +! (mass of water / mass of soil in %) assuming a constant density +! for soil + pclay=beta(1,izob)*100. + wp=0.0014*pclay*pclay+0.17*pclay + smois_grav=(smois(i,1,j)/2.6)*100. + if(smois_grav.gt.wp) then + wetfactor=sqrt(1.0+1.21*(smois_grav-wp)**0.68) + else + wetfactor=1.0 + endif +! wetfactor=1.0 + +! part5 - dustflux +! lower bound on ustar = 20 cm/s as in Shaw et al, but set upper +! bound to 100 cm/s + + ustar1=ust(i,j)*100.0 + if(ustar1.gt.100.0) ustar1=100.0 + ustart0=20.0 + ustart=ustart0*wetfactor + if(ustar1.le.ustart) then + dustflux=0.0 + else + dustflux=1.0e-14*(ustar1**4)*(1.0-(ustart/ustar1)) + endif + dustflux=dustflux*10.0 +! units kg m-2 s-1 + ftot=0.0 + do ii=1,2 + ftot=ftot+dustflux*alphamask*delta(ii) + enddo +! convert to ug m-2 s-1 + ftot=ftot*1.0e+09 + +! apportion other inorganics only + factaa = (dtstep/dz8w(i,k,j))*alt(i,k,j) + factbb = factaa * ftot + fracoin = 1.00 +! fracca = 0.03*0.4 +! fracco3 = 0.03*0.6 + fracca = 0.0 + fracco3 = 0.0 + fractot = fracoin + fracca + fracco3 +! if (ivgtyp(i,j) .eq. 8) print*,'jdf',i,j,ustar1,ustart0,factaa,ftot + chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + & + factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot + +!jdf factbb * (sz(3)+sz(4)+sz(5)) * fractot + chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + & + factbb * (sz(7)+sz(8)) * fractot +!jdf factbb * (sz(6)+sz(7)+sz(8)) * fractot +! mass1part is mass of a single particle in ug, density of dust ~2.5 g cm-3 + densdust=2.5 + dp_meanvol_tmp = 1.0e2*dginia*exp(1.5*l2sginia) ! accum + mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06 + chem(i,k,j,p_ac0)=chem(i,k,j,p_ac0) + & + factbb * (sz(3)+sz(4)+sz(5)+sz(6)) * fractot / mass1part +!jdf factbb * (sz(3)+sz(4)+sz(5)) * fractot / mass1part + dp_meanvol_tmp = 1.0e2*dginic*exp(1.5*l2sginic) ! coarse + mass1part=0.523598*(dp_meanvol_tmp**3)*densdust*1.0e06 + chem(i,k,j,p_corn)=chem(i,k,j,p_corn) + & + factbb * (sz(7)+sz(8)) * fractot / mass1part +!jdf factbb * (sz(6)+sz(7)+sz(8)) * fractot / mass1part + +1840 continue + +1820 continue +1830 continue + + return + + END subroutine sorgam_vbs_dust_emiss + +!==================================================================================== +!add another dust emission scheme following GOCART mechanism --czhao 09/17/2009 +!==================================================================================== + subroutine sorgam_vbs_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & + v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, & + ivgtyp,isltyp,xland,dx,g, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + USE module_data_gocart_dust + USE module_configure + USE module_state_description + USE module_model_constants, ONLY: mwdry + USE module_data_mosaic_asect + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ktau, num_soil_layers, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER,DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + ivgtyp, & + isltyp + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL, DIMENSION( ims:ime, num_soil_layers, jms:jme ) , & + INTENT(INOUT) :: smois + REAL, DIMENSION( ims:ime , jms:jme, 3 ) , & + INTENT(IN ) :: erod + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + u10, & + v10, & + xland + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: & + alt, & + dz8w,p8w, & + u_phy,v_phy,rho_phy + + REAL, INTENT(IN ) :: dt,dx,g +! +! local variables +! + integer :: nmx,i,j,k,ndt,imx,jmx,lmx + integer ilwi, start_month + real*8, DIMENSION (3) :: erodin + real*8, DIMENSION (5) :: bems + real*8 w10m,gwet,airden,airmas + real*8 cdustemis,jdustemis,cdustcon,jdustcon + real*8 cdustdens,jdustdens,mass1part,jdustdiam,cdustdiam,dp_meanvol_tmp + real*8 dxy + real*8 conver,converi + real dttt + real soilfacj,rhosoilj,rhosoilc + real totalemis,accfrac,corfrac,rscale1,rscale2 + + accfrac=0.07 ! assign 7% to accumulation mode + corfrac=0.93 ! assign 93% to coarse mode + rscale1=1.00 ! to account for the dust larger than 10um in radius + rscale2=1.02 ! to account for the dust larger than 10um in radius + accfrac=accfrac*rscale1 + corfrac=corfrac*rscale2 + + rhosoilj=2.5e3 + rhosoilc=2.6e3 + soilfacj=soilfac*rhosoilj/rhosoilc + + conver=1.e-9 + converi=1.e9 +! +! number of dust bins + nmx=5 + k=kts + do j=jts,jte + do i=its,ite +! +! don't do dust over water!!! + if(xland(i,j).lt.1.5)then + + ilwi=1 + start_month = 3 ! it doesn't matter, ch_dust is not a month dependent now, a constant + w10m=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) + airmas=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g ! kg + +! we don't trust the u10,v10 values, if model layers are very thin near surface + if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) + !erodin(1)=erod(i,j,1)/dx/dx ! czhao erod shouldn't be scaled to the area, because it's a fraction + !erodin(2)=erod(i,j,2)/dx/dx + !erodin(3)=erod(i,j,3)/dx/dx + erodin(1)=erod(i,j,1) + erodin(2)=erod(i,j,2) + erodin(3)=erod(i,j,3) +! +! volumetric soil moisture over porosity + gwet=smois(i,1,j)/porosity(isltyp(i,j)) + ndt=ifix(dt) + airden=rho_phy(i,kts,j) + dxy=dx*dx + + call sorgam_vbs_source_du( nmx, dt,i,j, & + erodin, ilwi, dxy, w10m, gwet, airden, airmas, & + bems,start_month,g) + +!bems: kg/timestep/cell + !sum up the dust emission from 0.1-10 um in radius + ! unit change from kg/timestep/cell to ug/m2/s + totalemis=(sum(bems(1:5))/dt)*converi/dxy + ! to account for the particles larger than 10 um radius + ! based on assumed size distribution + jdustemis = totalemis*accfrac ! accumulation mode + cdustemis = totalemis*corfrac ! coarse mode + + cdustcon = sum(bems(1:5))*corfrac/airmas ! kg/kg-dryair + cdustcon = cdustcon * converi ! ug/kg-dryair + jdustcon = sum(bems(1:5))*accfrac/airmas ! kg/kg-dryair + jdustcon = jdustcon * converi ! ug/kg-dryair + + chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + jdustcon + chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + cdustcon + +! czhao doing dust number emission following pm10 +! use soilfacj for accumulation mode because GOCART assign a less dense dust in +! accumulation mode + chem(i,k,j,p_ac0) = chem(i,k,j,p_ac0) + jdustcon * factnuma*soilfacj + chem(i,k,j,p_corn) = chem(i,k,j,p_corn) + cdustcon * factnumc*soilfac + + endif + enddo + enddo + +end subroutine sorgam_vbs_dust_gocartemis + + SUBROUTINE sorgam_vbs_source_du( nmx, dt1,i,j, & + erod, ilwi, dxy, w10m, gwet, airden, airmas, & + bems,month,g0) + +! **************************************************************************** +! * Evaluate the source of each dust particles size classes (kg/m3) +! * by soil emission. +! * Input: +! * EROD Fraction of erodible grid cell (-) +! * for 1: Sand, 2: Silt, 3: Clay +! * DUSTDEN Dust density (kg/m3) +! * DXY Surface of each grid cell (m2) +! * AIRVOL Volume occupy by each grid boxes (m3) +! * NDT1 Time step (s) +! * W10m Velocity at the anemometer level (10meters) (m/s) +! * u_tresh Threshold velocity for particule uplifting (m/s) +! * CH_dust Constant to fudge the total emission of dust (s2/m2) +! * +! * Output: +! * DSRC Source of each dust type (kg/timestep/cell) +! * +! * Working: +! * SRC Potential source (kg/m/timestep/cell) +! * +! **************************************************************************** + + USE module_data_gocart_dust + + INTEGER, INTENT(IN) :: nmx + REAL*8, INTENT(IN) :: erod(ndcls) + INTEGER, INTENT(IN) :: ilwi,month + + REAL*8, INTENT(IN) :: w10m, gwet + REAL*8, INTENT(IN) :: dxy + REAL*8, INTENT(IN) :: airden, airmas + REAL*8, INTENT(OUT) :: bems(nmx) + + REAL*8 :: den(nmx), diam(nmx) + REAL*8 :: tsrc, u_ts0, cw, u_ts, dsrc, srce + REAL, intent(in) :: g0 + REAL :: rhoa, g,dt1 + INTEGER :: i, j, n, m, k + + ! default is 1 ug s2 m-5 == 1.e-9 kg s2 m-5 + !ch_dust(:,:)=0.8D-9 ! ch_dust is defined here instead of in the chemics_ini.F if with SOA_VBS -czhao + ch_dust(:,:)=1.0D-9 ! default + !ch_dust(:,:)=0.65D-9 ! ch_dust is tuned to match MODIS and AERONET measurements over Sahara + !ch_dust(:,:)=1.0D-9*0.36 ! ch_dust is scaled to soa_vbs total dust emission + + ! executable statemenst + DO n = 1, nmx + ! Threshold velocity as a function of the dust density and the diameter from Bagnold (1941) + den(n) = den_dust(n)*1.0D-3 + diam(n) = 2.0*reff_dust(n)*1.0D2 + g = g0*1.0E2 + ! Pointer to the 3 classes considered in the source data files + m = ipoint(n) + tsrc = 0.0 + rhoa = airden*1.0D-3 + u_ts0 = 0.13*1.0D-2*SQRT(den(n)*g*diam(n)/rhoa)* & + SQRT(1.0+0.006/den(n)/g/(diam(n))**2.5)/ & + SQRT(1.928*(1331.0*(diam(n))**1.56+0.38)**0.092-1.0) + + ! Case of surface dry enough to erode + IF (gwet < 0.5) THEN ! Pete's modified value +! IF (gwet < 0.2) THEN + u_ts = MAX(0.0D+0,u_ts0*(1.2D+0+2.0D-1*LOG10(MAX(1.0D-3, gwet)))) + ELSE + ! Case of wet surface, no erosion + u_ts = 100.0 + END IF + srce = frac_s(n)*erod(m)*dxy ! (m2) + IF (ilwi == 1 ) THEN + dsrc = ch_dust(n,month)*srce*w10m**2 & + * (w10m - u_ts)*dt1 ! (kg) + ELSE + dsrc = 0.0 + END IF + IF (dsrc < 0.0) dsrc = 0.0 + + ! Update dust mixing ratio at first model level. + !tc(n) = tc(n) + dsrc / airmas !kg/kg-dryair -czhao + bems(n) = dsrc ! kg/timestep/cell + + ENDDO + +END SUBROUTINE sorgam_vbs_source_du + +!=========================================================================== +!=========================================================================== + subroutine wetscav_sorgam_vbs_driver (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg,qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! wet removal by grid-resolved precipitation +! scavenging of cloud-phase aerosols and gases by collection, freezing, ... +! scavenging of interstitial-phase aerosols by impaction +! scavenging of gas-phase gases by mass transfer and reaction + +!---------------------------------------------------------------------- + USE module_configure + USE module_state_description + USE module_data_sorgam_vbs + USE module_mosaic_wetscav,only: wetscav + +!---------------------------------------------------------------------- + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + id, ktau, ktauc, numgas_aqfrac + REAL, INTENT(IN ) :: dtstep,dtstepc +! +! all advected chemical species +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! fraction of gas species in cloud water + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), & + INTENT(IN ) :: gas_aqfrac + +! +! +! input from meteorology + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t_phy, & + p_phy, & + t8w,p8w, & + qlsink,precr,preci,precs,precg, & + rho_phy,cldfra + REAL, DIMENSION( ims:ime, jms:jme, num_chem ), & + INTENT(OUT ) :: qsrflx ! column change due to scavening + + call wetscav (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg,qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ntype_aer, nsize_aer, ncomp_aer, & + massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, & + volumcen_sect, volumlo_sect, volumhi_sect, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd, dlndg_nimptblgrow, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + end subroutine wetscav_sorgam_vbs_driver + +!=========================================================================== + + +END Module module_aerosols_sorgam_vbs diff --git a/wrfv2_fire/chem/module_bioemi_megan2.F b/wrfv2_fire/chem/module_bioemi_megan2.F index 0b6a4aa8..93b9528c 100644 --- a/wrfv2_fire/chem/module_bioemi_megan2.F +++ b/wrfv2_fire/chem/module_bioemi_megan2.F @@ -46,7 +46,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ebio_c5h8,ebio_apinene,ebio_bpinene,ebio_toluene, & ebio_ch3cho,ebio_ch3co2h,ebio_tbut2ene,ebio_c2h5cho, & ebio_nc4h10, & - ebio_sesq, ebio_mbo, & + ebio_sesq, ebio_mbo, ebio_bpi, ebio_myrc, & ebio_alk3, ebio_alk4, ebio_alk5, ebio_ole1, ebio_ole2, & ebio_aro1, ebio_aro2, ebio_ccho, ebio_meoh, & ebio_ethene, ebio_hcooh, ebio_terp, ebio_bald, & @@ -175,7 +175,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ebio_c5h8,ebio_apinene,ebio_bpinene,ebio_toluene, & ebio_ch3cho,ebio_ch3co2h,ebio_tbut2ene,ebio_c2h5cho, & ebio_nc4h10, & - ebio_sesq,ebio_mbo, & + ebio_sesq,ebio_mbo,ebio_bpi,ebio_myrc, & ebio_alk3, ebio_alk4, ebio_alk5, ebio_ole1, ebio_ole2, & ebio_aro1, ebio_aro2, ebio_ccho, ebio_meoh, & ebio_ethene, ebio_hcooh, ebio_terp, ebio_bald, & @@ -354,6 +354,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ebio_c3h8 ( its:ite , jts:jte ) = 0.0 ebio_so2 ( its:ite , jts:jte ) = 0.0 ebio_dms ( its:ite , jts:jte ) = 0.0 + ebio_terp ( its:ite , jts:jte ) = 0.0 ebio_c5h8 ( its:ite , jts:jte ) = 0.0 ebio_apinene ( its:ite , jts:jte ) = 0.0 ebio_bpinene ( its:ite , jts:jte ) = 0.0 @@ -367,6 +368,8 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ebio_nc4h10 ( its:ite , jts:jte ) = 0.0 ebio_sesq ( its:ite , jts:jte ) = 0.0 ebio_mbo ( its:ite , jts:jte ) = 0.0 + ebio_bpi ( its:ite , jts:jte ) = 0.0 + ebio_myrc ( its:ite , jts:jte ) = 0.0 e_bio ( its:ite , jts:jte , 1:ne_area) = 0.0 !...the following is redundant if there is no @@ -441,7 +444,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ! SHC (11/08/2007) GAS_MECH_SELECT1: SELECT CASE (config_flags%chem_opt) - CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP,GOCARTRADM2, GOCARTRADM2_KPP) + CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP,GOCARTRADM2) ! get p_of_radm2cbmz(:), p_of_radm2(:), and radm2_per_megan(:) CALL get_megan2radm2_table @@ -457,7 +460,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & CALL get_megan2racmSOA_table CASE (CBMZ, CBMZ_BB, CBMZ_BB_KPP, CBMZ_MOSAIC_KPP, & - CBMZ_MOSAIC_4BIN_VBS2_KPP, CBMZ_MOSAIC_4BIN, & + CBMZ_MOSAIC_4BIN, & CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, CBMZSORG, CBMZSORG_AQ, & @@ -466,11 +469,20 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ! get p_of_megan2cbmz(:), p_of_cbmz(:), and cbmz_per_megan(:) CALL get_megan2cbmz_table - CASE ( MOZART_KPP, MOZCART_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP ) + CASE (CB05_SORG_AQ_KPP) + CALL get_megan2cb05_table + + CASE ( CB05_SORG_VBS_AQ_KPP) + CALL get_megan2cb05vbs_table + + CASE ( MOZART_KPP, MOZCART_KPP ) ! get p_of_megan2mozcart(:), p_of_mozcart(:), and mozcart_per_megan(:) CALL get_megan2mozcart_table + CASE ( MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP ) + CALL get_megan2mozm_table - CASE (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP) ! FIX FOR SAPRC07A + CASE (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_KPP)!BSINGH(12/03/2013): Added SAPRC 8 bin and non-aq on (04/07/2014) ! FIX FOR SAPRC07A CALL get_megan2saprcnov_table CASE ( CRIMECH_KPP, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) @@ -773,7 +785,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & !... GAS_MECH_SELECT: SELECT CASE (config_flags%chem_opt) - CASE ( MOZART_KPP, MOZCART_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP ) + CASE ( MOZART_KPP, MOZCART_KPP ) DO icount = 1, n_megan2mozcart !----------------------------------------------------------------------- @@ -868,7 +880,117 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & END IF use_megan_emission END DO - CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP,GOCARTRADM2, GOCARTRADM2_KPP) + CASE ( MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP ) + + DO icount = 1, n_megan2mozm +!----------------------------------------------------------------------- +! Get index to chem array for the corresponding MOZCART species. +!----------------------------------------------------------------------- + p_in_chem = p_of_mozm(icount) +use_megan_emis : & + IF ( p_in_chem /= non_react ) THEN +!----------------------------------------------------------------------- +! Check if the species is actually in the mechanism +!----------------------------------------------------------------------- +is_mozm_species : & + IF ( p_in_chem > param_first_scalar ) THEN +!----------------------------------------------------------------------- +! Emission rate for mechanism species in mol km-2 hr-1 +!----------------------------------------------------------------------- + gas_emis = mozm_per_megan(icount) * E_megan2(p_of_megan2mozm(icount)) +!----------------------------------------------------------------------- +! Add emissions to diagnostic output variables. +! ebio_xxx (mol km-2 hr-1) were originally used by the +! BEIS3.11 biogenic emissions module. +! I have also borrowed variable e_bio (ppm m min-1). +!----------------------------------------------------------------------- + IF ( p_in_chem == p_isopr ) THEN + ebio_iso(i,j) = ebio_iso(i,j) + gas_emis + e_bio(i,j,p_isopr-1) = e_bio(i,j,p_isopr-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_no ) THEN + ebio_no(i,j) = ebio_no(i,j) + gas_emis + e_bio(i,j,p_no-1) = e_bio(i,j,p_no-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_no2 ) THEN + ebio_no2(i,j) = ebio_no2(i,j) + gas_emis + e_bio(i,j,p_no2-1) = e_bio(i,j,p_no2-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_co ) THEN + ebio_co(i,j) = ebio_co(i,j) + gas_emis + e_bio(i,j,p_co-1) = e_bio(i,j,p_co-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_hcho ) THEN + ebio_hcho(i,j) = ebio_hcho(i,j) + gas_emis + e_bio(i,j,p_hcho-1) = e_bio(i,j,p_hcho-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_ald ) THEN + ebio_ald(i,j) = ebio_ald(i,j) + gas_emis + e_bio(i,j,p_ald-1) = e_bio(i,j,p_ald-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_acet ) THEN + ebio_acet(i,j) = ebio_acet(i,j) + gas_emis + e_bio(i,j,p_acet-1) = e_bio(i,j,p_acet-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_tol ) THEN + ebio_tol(i,j) = ebio_tol(i,j) + gas_emis + e_bio(i,j,p_tol-1) = e_bio(i,j,p_tol-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_apin ) THEN + ebio_api(i,j) = ebio_api(i,j) + gas_emis + e_bio(i,j,p_apin-1) = e_bio(i,j,p_apin-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_bpin ) THEN + ebio_bpi(i,j) = ebio_bpi(i,j) + gas_emis + e_bio(i,j,p_bpin-1) = e_bio(i,j,p_bpin-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_limon ) THEN + ebio_lim(i,j) = ebio_lim(i,j) + gas_emis + e_bio(i,j,p_limon-1) = e_bio(i,j,p_limon-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_mbo ) THEN + ebio_mbo(i,j) = ebio_mbo(i,j) + gas_emis + e_bio(i,j,p_mbo-1) = e_bio(i,j,p_mbo-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_myrc ) THEN + ebio_myrc(i,j) = ebio_myrc(i,j) + gas_emis + e_bio(i,j,p_myrc-1) = e_bio(i,j,p_myrc-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_bcary ) THEN + ebio_sesq(i,j) = ebio_sesq(i,j) + gas_emis + e_bio(i,j,p_bcary-1) = e_bio(i,j,p_bcary-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_so2 ) THEN + ebio_so2(i,j) = ebio_so2(i,j) + gas_emis + e_bio(i,j,p_so2-1) = e_bio(i,j,p_so2-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_dms ) THEN + ebio_dms(i,j) = ebio_dms(i,j) + gas_emis + e_bio(i,j,p_dms-1) = e_bio(i,j,p_dms-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_bigalk ) THEN + ebio_bigalk(i,j) = ebio_bigalk(i,j) + gas_emis + e_bio(i,j,p_bigalk-1) = e_bio(i,j,p_bigalk-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_bigene ) THEN + ebio_bigene(i,j) = ebio_bigene(i,j) + gas_emis + e_bio(i,j,p_bigene-1) = e_bio(i,j,p_bigene-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_nh3 ) THEN + ebio_nh3(i,j) = ebio_nh3(i,j) + gas_emis + e_bio(i,j,p_nh3-1) = e_bio(i,j,p_nh3-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_ch3oh ) THEN + ebio_ch3oh(i,j) = ebio_ch3oh(i,j) + gas_emis + e_bio(i,j,p_ch3oh-1) = e_bio(i,j,p_ch3oh-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_c2h5oh ) THEN + ebio_c2h5oh(i,j) = ebio_c2h5oh(i,j) + gas_emis + e_bio(i,j,p_c2h5oh-1) = e_bio(i,j,p_c2h5oh-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_ch3cooh ) THEN + ebio_ch3cooh(i,j) = ebio_ch3cooh(i,j) + gas_emis + e_bio(i,j,p_ch3cooh-1) = e_bio(i,j,p_ch3cooh-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_mek ) THEN + ebio_mek(i,j) = ebio_mek(i,j) + gas_emis + e_bio(i,j,p_mek-1) = e_bio(i,j,p_mek-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_c2h4 ) THEN + ebio_c2h4(i,j) = ebio_c2h4(i,j) + gas_emis + e_bio(i,j,p_c2h4-1) = e_bio(i,j,p_c2h4-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_c2h6 ) THEN + ebio_c2h6(i,j) = ebio_c2h6(i,j) + gas_emis + e_bio(i,j,p_c2h6-1) = e_bio(i,j,p_c2h6-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_c3h6 ) THEN + ebio_c3h6(i,j) = ebio_c3h6(i,j) + gas_emis + e_bio(i,j,p_c3h6-1) = e_bio(i,j,p_c3h6-1) + gas_emis*convert2 + ELSE IF ( p_in_chem == p_c3h8 ) THEN + ebio_c3h8(i,j) = ebio_c3h8(i,j) + gas_emis + e_bio(i,j,p_c3h8-1) = e_bio(i,j,p_c3h8-1) + gas_emis*convert2 + END IF + END IF is_mozm_species + END IF use_megan_emis + END DO + + CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP,GOCARTRADM2) DO icount = 1, n_megan2radm2 @@ -1015,6 +1137,269 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & END DO + CASE (CB05_SORG_AQ_KPP) + + DO icount = 1, n_megan2cb05 + IF ( p_of_cb05 (icount) .NE. non_react ) THEN + ! Get index to chem array for the corresponding CB05 + ! species. + p_in_chem = p_of_cb05(icount) + + ! Check if the species is actually in the mechanism + ! (e.g., NH3 is in the mechanism only if aerosols + ! are simulated) + ! Check if the species is actually in the mechanism + IF ( p_in_chem > param_first_scalar ) THEN + + ! Emission rate for mechanism species in mol km-2 hr-1 + gas_emis = cb05_per_megan(icount) * E_megan2(p_of_megan2cb05(icount)) + + ! Increase gas-phase concentrations (in ppmv) due to + ! biogenic emissions + chem(i,kts,j,p_in_chem) = chem(i,kts,j,p_in_chem) + gas_emis*emis2ppm + + IF ( p_in_chem .EQ. p_apin ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + IF ( p_in_chem .EQ. p_bpin ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + IF ( p_in_chem .EQ. p_hum ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + IF ( p_in_chem .EQ. p_lim ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + IF ( p_in_chem .EQ. p_oci ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + IF ( p_in_chem .EQ. p_ter ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + + ! Add emissions to diagnostic output variables. + ! ebio_xxx (mol km-2 hr-1) were originally used by the + ! BEIS3.11 biogenic emissions module. + ! I have also borrowed variable e_bio (ppm m min-1). + IF ( p_in_chem .EQ. p_isop ) THEN + ebio_iso(i,j) = ebio_iso(i,j) + gas_emis + e_bio(i,j,p_isop-1) = e_bio(i,j,p_isop-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_aacd ) THEN + e_bio(i,j,p_aacd-1) = e_bio(i,j,p_aacd-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_ald2 ) THEN + ebio_ald(i,j) = ebio_ald(i,j) + gas_emis + e_bio(i,j,p_ald2-1) = e_bio(i,j,p_ald2-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_aldx ) THEN + ebio_ald(i,j) = ebio_ald(i,j) + gas_emis + e_bio(i,j,p_aldx-1) = e_bio(i,j,p_aldx-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_apin ) THEN + ebio_api(i,j) = ebio_api(i,j) + gas_emis + e_bio(i,j,p_apin-1) = e_bio(i,j,p_apin-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_bpin ) THEN + e_bio(i,j,p_bpin-1) = e_bio(i,j,p_bpin-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_ch4 ) THEN + e_bio(i,j,p_ch4-1) = e_bio(i,j,p_ch4-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_co ) THEN + ebio_co(i,j) = ebio_co(i,j) + gas_emis + e_bio(i,j,p_co-1) = e_bio(i,j,p_co-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_eth ) THEN + e_bio(i,j,p_eth-1) = e_bio(i,j,p_eth-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_etha ) THEN + e_bio(i,j,p_etha-1) = e_bio(i,j,p_etha-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_etoh ) THEN + e_bio(i,j,p_etoh-1) = e_bio(i,j,p_etoh-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_facd ) THEN + e_bio(i,j,p_facd-1) = e_bio(i,j,p_facd-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_form ) THEN + ebio_hcho(i,j) = ebio_hcho(i,j) + gas_emis + e_bio(i,j,p_form-1) = e_bio(i,j,p_form-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_hum ) THEN + e_bio(i,j,p_hum-1) = e_bio(i,j,p_hum-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_iole ) THEN + e_bio(i,j,p_iole-1) = e_bio(i,j,p_iole-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_lim ) THEN + ebio_lim(i,j) = ebio_lim(i,j) + gas_emis + e_bio(i,j,p_lim-1) = e_bio(i,j,p_lim-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_meoh ) THEN + e_bio(i,j,p_meoh-1) = e_bio(i,j,p_meoh-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_nh3 ) THEN + e_bio(i,j,p_nh3-1) = e_bio(i,j,p_nh3-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_no ) THEN + ebio_no(i,j) = ebio_no(i,j) + gas_emis + e_bio(i,j,p_no-1) = e_bio(i,j,p_no-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_oci ) THEN + e_bio(i,j,p_oci-1) = e_bio(i,j,p_oci-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_ole ) THEN + e_bio(i,j,p_ole-1) = e_bio(i,j,p_ole-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_par ) THEN + e_bio(i,j,p_par-1) = e_bio(i,j,p_par-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_terp ) THEN + ebio_terp(i,j) = ebio_terp(i,j) + gas_emis + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_tol ) THEN + e_bio(i,j,p_tol-1) = e_bio(i,j,p_tol-1) + gas_emis*convert2 + END IF + + END IF !( p_in_chem > param_first_scalar ) + + END IF + END DO + + CASE (CB05_SORG_VBS_AQ_KPP) + + DO icount = 1, n_megan2cb05vbs + IF ( p_of_cb05vbs (icount) .NE. non_react ) THEN + ! Get index to chem array for the corresponding CB05 + ! species. + p_in_chem = p_of_cb05vbs(icount) + + ! Check if the species is actually in the mechanism + ! (e.g., NH3 is in the mechanism only if aerosols + ! are simulated) + ! Check if the species is actually in the mechanism + IF ( p_in_chem > param_first_scalar ) THEN + + ! Emission rate for mechanism species in mol km-2 hr-1 + gas_emis = cb05vbs_per_megan(icount) * E_megan2(p_of_megan2cb05vbs(icount)) + + ! Increase gas-phase concentrations (in ppmv) due to + ! biogenic emissions + chem(i,kts,j,p_in_chem) = chem(i,kts,j,p_in_chem) + gas_emis*emis2ppm + + IF ( p_in_chem .EQ. p_apin ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + IF ( p_in_chem .EQ. p_bpin ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + IF ( p_in_chem .EQ. p_hum ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + IF ( p_in_chem .EQ. p_lim ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + IF ( p_in_chem .EQ. p_oci ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + IF ( p_in_chem .EQ. p_ter ) THEN + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm + END IF + + ! Add emissions to diagnostic output variables. + ! ebio_xxx (mol km-2 hr-1) were originally used by the + ! BEIS3.11 biogenic emissions module. + ! I have also borrowed variable e_bio (ppm m min-1). + IF ( p_in_chem .EQ. p_isop ) THEN + ebio_iso(i,j) = ebio_iso(i,j) + gas_emis + e_bio(i,j,p_isop-1) = e_bio(i,j,p_isop-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_aacd ) THEN + e_bio(i,j,p_aacd-1) = e_bio(i,j,p_aacd-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_ald2 ) THEN + ebio_ald(i,j) = ebio_ald(i,j) + gas_emis + e_bio(i,j,p_ald2-1) = e_bio(i,j,p_ald2-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_aldx ) THEN + ebio_ald(i,j) = ebio_ald(i,j) + gas_emis + e_bio(i,j,p_aldx-1) = e_bio(i,j,p_aldx-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_apin ) THEN + ebio_api(i,j) = ebio_api(i,j) + gas_emis + e_bio(i,j,p_apin-1) = e_bio(i,j,p_apin-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_bpin ) THEN + e_bio(i,j,p_bpin-1) = e_bio(i,j,p_bpin-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_ch4 ) THEN + e_bio(i,j,p_ch4-1) = e_bio(i,j,p_ch4-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_co ) THEN + ebio_co(i,j) = ebio_co(i,j) + gas_emis + e_bio(i,j,p_co-1) = e_bio(i,j,p_co-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_eth ) THEN + e_bio(i,j,p_eth-1) = e_bio(i,j,p_eth-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_etha ) THEN + e_bio(i,j,p_etha-1) = e_bio(i,j,p_etha-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_etoh ) THEN + e_bio(i,j,p_etoh-1) = e_bio(i,j,p_etoh-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_facd ) THEN + e_bio(i,j,p_facd-1) = e_bio(i,j,p_facd-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_form ) THEN + ebio_hcho(i,j) = ebio_hcho(i,j) + gas_emis + e_bio(i,j,p_form-1) = e_bio(i,j,p_form-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_hum ) THEN + e_bio(i,j,p_hum-1) = e_bio(i,j,p_hum-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_iole ) THEN + e_bio(i,j,p_iole-1) = e_bio(i,j,p_iole-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_lim ) THEN + ebio_lim(i,j) = ebio_lim(i,j) + gas_emis + e_bio(i,j,p_lim-1) = e_bio(i,j,p_lim-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_meoh ) THEN + e_bio(i,j,p_meoh-1) = e_bio(i,j,p_meoh-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_nh3 ) THEN + e_bio(i,j,p_nh3-1) = e_bio(i,j,p_nh3-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_no ) THEN + ebio_no(i,j) = ebio_no(i,j) + gas_emis + e_bio(i,j,p_no-1) = e_bio(i,j,p_no-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_oci ) THEN + e_bio(i,j,p_oci-1) = e_bio(i,j,p_oci-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_ole ) THEN + e_bio(i,j,p_ole-1) = e_bio(i,j,p_ole-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_par ) THEN + e_bio(i,j,p_par-1) = e_bio(i,j,p_par-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_terp ) THEN + ebio_terp(i,j) = ebio_terp(i,j) + gas_emis + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 + END IF + IF ( p_in_chem .EQ. p_tol ) THEN + e_bio(i,j,p_tol-1) = e_bio(i,j,p_tol-1) + gas_emis*convert2 + END IF + + END IF !( p_in_chem > param_first_scalar ) + + END IF + END DO + + CASE (RACM_SOA_VBS_KPP) DO icount = 1, n_megan2racmSOA @@ -1098,7 +1483,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & END DO CASE (CBMZ, CBMZ_BB, CBMZ_BB_KPP, CBMZ_MOSAIC_KPP, & - CBMZ_MOSAIC_4BIN_VBS2_KPP, CBMZ_MOSAIC_4BIN, & + CBMZ_MOSAIC_4BIN, & CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ,CBMZ_MOSAIC_DMS_8BIN_AQ,CBMZSORG, CBMZSORG_AQ, & @@ -1188,7 +1573,8 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & END DO - CASE (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP) ! FIX FOR SAPRC99 AND SAPRC07 + CASE (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_KPP)!BSINGH(12/03/2013): Added SAPRC 8 bin and non-aq on (04/07/2014) ! FIX FOR SAPRC99 AND SAPRC07 DO icount = 1, n_megan2saprcnov @@ -1280,9 +1666,11 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & e_bio(i,j,p_rco_oh-1) = e_bio(i,j,p_rco_oh-1) + gas_emis*convert2 ELSE IF ( p_in_chem .EQ. p_terp) THEN ebio_terp(i,j) = ebio_terp(i,j) + gas_emis + ebio_api(i,j) = ebio_api(i,j) + gas_emis e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 ELSE IF ( p_in_chem .EQ. p_sesq) THEN ebio_sesq(i,j) = ebio_sesq(i,j) + gas_emis + ebio_lim(i,j) = ebio_lim(i,j) + gas_emis e_bio(i,j,p_sesq-1) = e_bio(i,j,p_sesq-1) + gas_emis*convert2 !jdf END IF diff --git a/wrfv2_fire/chem/module_bioemi_simple.F b/wrfv2_fire/chem/module_bioemi_simple.F index 1ae36b94..c1fd7418 100755 --- a/wrfv2_fire/chem/module_bioemi_simple.F +++ b/wrfv2_fire/chem/module_bioemi_simple.F @@ -135,7 +135,7 @@ SUBROUTINE bio_emissions(id,ktau,dtstep,DX, & ! PRINT *, eiso, emter, eovoc, e_n, eisoc, eovocc CALL biosplit(iland,eiso,emter,eovoc,e_n,emiss_bio,ne_area,vegfrac, & - luse_typ,vegflag) + config_flags, luse_typ,vegflag) ! PRINT *, 'emiss_bio(liso) emiss_bio(lald) emiss_bio(lhcho) ', & ! ' emiss_bio(lhc3)' ! PRINT *, emiss_bio(liso), emiss_bio(lald), emiss_bio(lhcho), & @@ -1153,7 +1153,8 @@ END SUBROUTINE biogen ! *********************** SUBROUTINE BIOSPLIT ************************* ! ********************************************************************** SUBROUTINE biosplit(iland,eiso,emter,eovoc,e_n,emiss_bio,ne_area, & - vegfrc,mminlu,vegflag) + vegfrc, & + config_flags, mminlu,vegflag) ! THIS PROGRAMM SPLITS THE BIOGENIC EMISSION RATES FOR ! MONOTERPENES AND OTHER ORGANIC COMPOUNDS INTO THE ! COMPOUND CLASSES OF THE CHEMISTRY MODEL @@ -1206,6 +1207,12 @@ SUBROUTINE biosplit(iland,eiso,emter,eovoc,e_n,emiss_bio,ne_area, & ! XYL -- p-cymene ! The other VOCs are grouped according to Middleton et al. (1990) !*********************************************************************** + USE module_configure + USE module_state_description + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + ! .. Scalar Arguments .. REAL :: eiso, emter, eovoc, e_n, vegfrc INTEGER :: iland, ne_area @@ -1234,6 +1241,67 @@ SUBROUTINE biosplit(iland,eiso,emter,eovoc,e_n,emiss_bio,ne_area, & emiss_bio(liso) = eiso emiss_bio(lno) = emiss_bio(lno) + e_n + if (config_flags%chem_opt == CB05_SORG_AQ_KPP .OR. & + config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP ) then + + emiss_bio(ltpan) = emter ! Use tpan to represent terpene + +! ***************************************************************** +! Agricultural land + + IF (ixxxlu(iland)==2) THEN + emiss_bio(lhc5) = emiss_bio(lhc5) + 0.16*eovoc + emiss_bio(lhc8) = emiss_bio(lhc8) + 0.27*eovoc + emiss_bio(lolt) = emiss_bio(lolt) + 0.05*eovoc + emiss_bio(loli) = emiss_bio(loli) + 0.37*eovoc + emiss_bio(lket) = emiss_bio(lket) + 0.03*eovoc + emiss_bio(lald) = emiss_bio(lald) + 0.12*eovoc + END IF + +! ***************************************************************** +! Grassland + + IF (ixxxlu(iland)==3) THEN + emiss_bio(lhc5) = emiss_bio(lhc5) + 0.09*eovoc + emiss_bio(lolt) = emiss_bio(lolt) + 0.07*eovoc + emiss_bio(loli) = emiss_bio(loli) + 0.51*eovoc + emiss_bio(lket) = emiss_bio(lket) + 0.15*eovoc + emiss_bio(lald) = emiss_bio(lald) + 0.18*eovoc + END IF + +! ***************************************************************** +! Deciduous forest + + IF (ixxxlu(iland)==4) THEN + emiss_bio(lhcho) = emiss_bio(lhcho) + 0.19*eovoc + emiss_bio(lald) = emiss_bio(lald) + 0.13*eovoc + emiss_bio(lxyl) = emiss_bio(lxyl) + 0.04*emter + emiss_bio(lhc5) = emiss_bio(lhc5) + 0.03*eovoc + emiss_bio(loli) = emiss_bio(loli) + 0.07*eovoc + emiss_bio(lora1) = emiss_bio(lora1) + 0.23*eovoc + emiss_bio(lora2) = emiss_bio(lora2) + 0.35*eovoc + END IF + +! ***************************************************************** +! Coniferous forest and mixed forest + + + IF (ixxxlu(iland)==5) THEN + emiss_bio(lhcho) = emiss_bio(lhcho) + 0.04*eovoc + emiss_bio(lhcho) = emiss_bio(lhcho) + 0.04*eovoc + emiss_bio(lald) = emiss_bio(lald) + 0.14*eovoc + emiss_bio(lhc3) = emiss_bio(lhc3) + 0.07*eovoc + emiss_bio(lhc5) = emiss_bio(lhc5) + 0.07*eovoc + emiss_bio(lolt) = emiss_bio(lolt) + 0.07*eovoc + emiss_bio(loli) = emiss_bio(loli) + 0.50*eovoc + emiss_bio(lket) = emiss_bio(lket) + 0.03*eovoc + emiss_bio(lora1) = emiss_bio(lora1) + 0.03*eovoc + emiss_bio(lora2) = emiss_bio(lora2) + 0.05*eovoc + END IF + + else + + ! ***************************************************************** ! Agricultural land @@ -1301,6 +1369,8 @@ SUBROUTINE biosplit(iland,eiso,emter,eovoc,e_n,emiss_bio,ne_area, & emiss_bio(loli) = emiss_bio(loli) + emter END IF + end if + END SUBROUTINE biosplit END MODULE module_bioemi_simple diff --git a/wrfv2_fire/chem/module_cb05_addemiss.F b/wrfv2_fire/chem/module_cb05_addemiss.F new file mode 100755 index 00000000..8c989ba4 --- /dev/null +++ b/wrfv2_fire/chem/module_cb05_addemiss.F @@ -0,0 +1,307 @@ +! ************************************************************************************** +! This computer software was developed by Dr. Yang Zhang and her research group * +! at North Carolina State University (NCSU) with support from the NSF Career Award * +! No. Atm-0348819, and the Memorandum of Understanding between the * +! U.S. Environmental Protection Agency (EPA) and the U.S. Department of * +! Commerce's National Oceanic and Atmospheric Administration (NOAA) * +! and under agreement number DW13921548, and the U.S. EPA/Office of * +! Air Quality Planning & Standards via RTI International contract #4-321-0210288. * +! * +! NEITHER ANY COSPONSORS, NCSU, NOR ANY PERSON ACTING ON BEHALF * +! OF ANY OF THEM MAKES ANY WARRANTY OR REPRESENTATION * +! WHATSOEVER, EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR * +! THE USE OF THIS SOFTWARE. THIS SOFTWARE OR PART OF IT MAY BE * +! COPYRIGHTED AND IS PERMITTED BY ORIGINAL CODE DEVELOPERS FOR * +! NONPROFIT USE AND SUBJECTED TO RESTRICTIONS * +! * +! Contact information: * +! Dr. Yang Zhang * +! Principal Investigator * +! Department of Marine, Earth, and Atmospheric Sciences * +! North Carolina State University * +! Campus Box 8208 * +! Room 5151, Jordan Hall, 2800 Faucette Drive * +! Raleigh, NC 27695-8208, USA * +! Tel: (919) 515-9688 (Office) * +! Fax: (919) 515-7802 * +! E-Mail: yang_zhang@ncsu.edu * +!*************************************************************************************** + + MODULE module_cb05_addemiss + +!*************************************************************************************** +! FUNCTION: ADD EMISSIONS FOR CB05 GAS SPECIES * +! PRECONDITION REQUIRED: use for CB05 gas-phase mechanism * +! RETURN VALUES: * +! KEY SUBROUTINES AND FUNCTIONS CALLED: None * +! REVISION HISTORY: * +! This code was based on module_cbmz_addemiss.F, developed by PNNL, 2005 * +! Revised by J.P. HUANG AND Y. ZHANG, Air Quality Forecasting Laboratory, * +! North Carolina State University, Raleigh, NC 27695 * +! for incorporation of CB05 into WRF/Chem under several projects * +! led by Dr. Yang Zhang (contact: (919) 515-9688, yang_zhang@ncsu.edu) * +! March-Oct., 2006 * +! Revised by Y. ZHANG, NCSU, clean up, May 6, 2007 * +! Revised by Ying Pan and Yang Zhang, NCSU, Nov. 2007-Nov. 2008 * +! to couple MADRID with CB05 gas-phase mechanism * +! Revised by Yang Zhang, Xiao-Ming Hu, and Ying Pan, NCSU, Sept.-Nov., 2008 * +! Code cleanup for NOAA WRF/Chem repository checkin * +! Revised by Ying Pan and Yang Zhang, NCSU, Sep. 2009 * +! to transfer code to WRF/Chem v3.1.1 * +! Revised by Kai Wang, NCSU, Oct 2014 to transfer to WRF/Chem v3.6.1 * +! * +! REFERENCES: * +! * +!*************************************************************************************** + +!WRF:MODEL_LAYER:CHEMICS +! +CONTAINS +! +! currently this only adds in the emissions... +! this may be done differently for different chemical mechanisms +! in the future. aerosols are already added somewhere else.... +! + subroutine cb05_addemiss_anthro( id, dtstep, dz8w, config_flags, & + rho_phy, chem, emis_ant, & + ids,ide, jds,jde, kds, kde, & + ims,ime, jms,jme, kms, kme, & + its,ite, jts,jte, kts, kte ) + +!---------------------------------------------------------------------- + USE module_configure + USE module_state_description + USE module_data_radm2 + + IMPLICIT NONE + +! .. Parameters .. + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: id, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL, INTENT(IN ) :: & + dtstep + +! trace species mixing ratios (gases=ppm) + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem +! +! emissions arrays +! +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + REAL, DIMENSION( ims:ime, kms:config_flags%kemit, jms:jme,num_emis_ant),& + INTENT(IN ) :: & + emis_ant + +! layer thickness (m) + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: dz8w, rho_phy + +! local variables + integer i,j,k + real, parameter :: efact1 = 1.0/60.0 + real :: conv + double precision :: chem_sum(num_chem) + +!--- deposition and emissions stuff +! +! .. Intrinsic Functions .. + + call wrf_debug(15,'cb05_addemiss_anthro') +! +! add emissions +! + do 100 j=jts,jte + do 100 i=its,ite + + DO k=kts,min(config_flags%kemit,kte) +!v1 units: conv = dtstep/(dz8w(i,k,j)*60.) +!v2 units: + conv = 4.828e-4/rho_phy(i,k,j)*dtstep/(dz8w(i,k,j)*60.) + +#if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) + if( (i <= CHEM_DBG_I .and. i >= CHEM_DBG_I) .and. & + (j <= CHEM_DBG_J .and. j >= CHEM_DBG_J) .and. & + (k <= CHEM_DBG_K .and. k >= CHEM_DBG_K) ) then + print* + print*,"Converted emissions for CB05:" + end if +#endif + chem(i,k,j,p_no2) = chem(i,k,j,p_no2) & + + emis_ant(i,k,j,p_e_no2)*conv + chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) & + + emis_ant(i,k,j,p_e_xyl)*conv + chem(i,k,j,p_tol) = chem(i,k,j,p_tol) & + + emis_ant(i,k,j,p_e_tol)*conv + chem(i,k,j,p_so2) = chem(i,k,j,p_so2) & + + emis_ant(i,k,j,p_e_so2)*conv + chem(i,k,j,p_no) = chem(i,k,j,p_no) & + + emis_ant(i,k,j,p_e_no)*conv + chem(i,k,j,p_nh3) = chem(i,k,j,p_nh3) & + + emis_ant(i,k,j,p_e_nh3)*conv + chem(i,k,j,p_hcl) = chem(i,k,j,p_hcl) & + + emis_ant(i,k,j,p_e_hcl)*conv + chem(i,k,j,p_co) = chem(i,k,j,p_co) & + + emis_ant(i,k,j,p_e_co)*conv + chem(i,k,j,p_aldx) = chem(i,k,j,p_aldx) & + + emis_ant(i,k,j,p_e_aldx)*conv +! when biogenic emissions are off, terpene emissions are read from offline + if (config_flags%bio_emiss_opt == 0) then + chem(i,k,j,p_terp) = chem(i,k,j,p_terp) & + + emis_ant(i,k,j,p_e_terp)*conv + end if +! when emissions inventory is based on RADM2 speciation, which requires emiss_opt = 14 +! with emiss_inpt_opt = 102 + if ( (config_flags%emiss_opt == 14) ) then + chem(i,k,j,p_par) = chem(i,k,j,p_par) & + + conv* & + ( 2.9*emis_ant(i,k,j,p_e_hc3) & + + 4.8*emis_ant(i,k,j,p_e_hc5) + 7.9*emis_ant(i,k,j,p_e_hc8) & + + 0.9*emis_ant(i,k,j,p_e_ket) ) + chem(i,k,j,p_aacd) = chem(i,k,j,p_aacd) & + + emis_ant(i,k,j,p_e_ora2)*conv + chem(i,k,j,p_ole) = chem(i,k,j,p_ole) & + + emis_ant(i,k,j,p_e_olt)*conv + chem(i,k,j,p_iole) = chem(i,k,j,p_iole) & + + emis_ant(i,k,j,p_e_oli)*conv + chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & + + emis_ant(i,k,j,p_e_ol2)*conv + chem(i,k,j,p_form) = chem(i,k,j,p_form) & + + emis_ant(i,k,j,p_e_hcho)*conv + chem(i,k,j,p_etha) = chem(i,k,j,p_etha) & + + emis_ant(i,k,j,p_e_eth)*conv + chem(i,k,j,p_cres) = chem(i,k,j,p_cres) & + + emis_ant(i,k,j,p_e_csl)*conv + chem(i,k,j,p_meoh) = chem(i,k,j,p_meoh) & + + emis_ant(i,k,j,p_e_ch3oh)*conv + chem(i,k,j,p_etoh) = chem(i,k,j,p_etoh) & + + emis_ant(i,k,j,p_e_c2h5oh)*conv + chem(i,k,j,p_ald2) = chem(i,k,j,p_ald2) & + + emis_ant(i,k,j,p_e_ald)*conv +! when biogenic emissions are off, isoprene emissions are read from offline + if (config_flags%bio_emiss_opt == 0) then + chem(i,k,j,p_isop) = chem(i,k,j,p_isop) & + + emis_ant(i,k,j,p_e_iso)*conv + end if +! when emissions inventory is based on CBM speciation, which requires emiss_opt = 15 +! with emiss_inpt_opt = 101 + else + chem(i,k,j,p_par) = chem(i,k,j,p_par) & + + conv*emis_ant(i,k,j,p_e_par) + chem(i,k,j,p_ole) = chem(i,k,j,p_ole) & + + emis_ant(i,k,j,p_e_ole)*conv + chem(i,k,j,p_iole) = chem(i,k,j,p_iole) & + + emis_ant(i,k,j,p_e_iole)*conv + chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & + + emis_ant(i,k,j,p_e_eth)*conv + chem(i,k,j,p_form) = chem(i,k,j,p_form) & + + emis_ant(i,k,j,p_e_form)*conv + chem(i,k,j,p_etha) = chem(i,k,j,p_etha) & + + emis_ant(i,k,j,p_e_etha)*conv + chem(i,k,j,p_cres) = chem(i,k,j,p_cres) & + + emis_ant(i,k,j,p_e_cres)*conv & + + emis_ant(i,k,j,p_e_phen)*conv + chem(i,k,j,p_meoh) = chem(i,k,j,p_meoh) & + + emis_ant(i,k,j,p_e_meoh)*conv + chem(i,k,j,p_etoh) = chem(i,k,j,p_etoh) & + + emis_ant(i,k,j,p_e_etoh)*conv + chem(i,k,j,p_ald2) = chem(i,k,j,p_ald2) & + + emis_ant(i,k,j,p_e_ald2)*conv + chem(i,k,j,p_meo2) = chem(i,k,j,p_meo2) & + + emis_ant(i,k,j,p_e_meo2)*conv + chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) & + + emis_ant(i,k,j,p_e_psulf)*conv + chem(i,k,j,p_mgly) = chem(i,k,j,p_mgly) & + + emis_ant(i,k,j,p_e_mgly)*conv + chem(i,k,j,p_facd) = chem(i,k,j,p_facd) & + + emis_ant(i,k,j,p_e_hcooh)*conv + chem(i,k,j,p_aacd) = chem(i,k,j,p_aacd) & + + emis_ant(i,k,j,p_e_ccooh)*conv + chem(i,k,j,p_ispd) = chem(i,k,j,p_ispd) & + + emis_ant(i,k,j,p_e_iprod)*conv + + +! when biogenic emissions are off, isoprene emissions are read from offline + if (config_flags%bio_emiss_opt == 0) then + chem(i,k,j,p_isop) = chem(i,k,j,p_isop) & + + emis_ant(i,k,j,p_e_isop)*conv + end if + end if + + END DO + 100 continue + + END subroutine cb05_addemiss_anthro + + + + +!---------------------------------------------------------------------- + subroutine cb05_addemiss_bio( id, dtstep, dz8w, config_flags, & + rho_phy, chem, e_bio, ne_area, e_iso, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure + USE module_state_description + USE module_data_radm2 + USE module_aerosols_sorgam + + IMPLICIT NONE + +! subr arguments + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: id, ne_area, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, INTENT(IN ) :: dtstep + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + + REAL, DIMENSION( ims:ime, jms:jme,ne_area ), & + INTENT(IN ) :: e_bio + + REAL, DIMENSION( ims:ime, kms:config_flags%kemit, jms:jme ), & + INTENT(IN ) :: e_iso + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: dz8w, rho_phy + + +! local variables + integer i,j,k,n + real, parameter :: efact1 = 1.0/60.0 + double precision :: chem_sum(num_chem) + + +! +! apply gunther online biogenic gas emissions when bio_emiss_opt == GUNTHER1 +! only incoporated isoprene and terpene at the current stage for CB05 +! + if (config_flags%bio_emiss_opt == GUNTHER1) then + + do j=jts,jte + do i=its,ite + chem(i,kts,j,p_isop) = chem(i,kts,j,p_isop) & + + e_bio(i,j,liso)/(dz8w(i,kts,j)*60.)*dtstep +! tpan is used to be the place holder of terpene in Gunther scheme + chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) & + + e_bio(i,j,ltpan)/(dz8w(i,kts,j)*60.)*dtstep + end do + end do + + end if + + + END subroutine cb05_addemiss_bio + +! +END MODULE module_cb05_addemiss diff --git a/wrfv2_fire/chem/module_cb05_initmixrats.F b/wrfv2_fire/chem/module_cb05_initmixrats.F new file mode 100755 index 00000000..05926f45 --- /dev/null +++ b/wrfv2_fire/chem/module_cb05_initmixrats.F @@ -0,0 +1,803 @@ +! ************************************************************************************** +! This computer software was developed by Dr. Yang Zhang and her research group * +! at North Carolina State University (NCSU) with support from the NSF Career Award * +! No. Atm-0348819, and the Memorandum of Understanding between the * +! U.S. Environmental Protection Agency (EPA) and the U.S. Department of * +! Commerce's National Oceanic and Atmospheric Administration (NOAA) * +! and under agreement number DW13921548, and the U.S. EPA/Office of * +! Air Quality Planning & Standards via RTI International contract #4-321-0210288. * +! * +! NEITHER ANY COSPONSORS, NCSU, NOR ANY PERSON ACTING ON BEHALF * +! OF ANY OF THEM MAKES ANY WARRANTY OR REPRESENTATION * +! WHATSOEVER, EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR * +! THE USE OF THIS SOFTWARE. THIS SOFTWARE OR PART OF IT MAY BE * +! COPYRIGHTED AND IS PERMITTED BY ORIGINAL CODE DEVELOPERS FOR * +! NONPROFIT USE AND SUBJECTED TO RESTRICTIONS * +! * +! Contact information: * +! Dr. Yang Zhang * +! Principal Investigator * +! Department of Marine, Earth, and Atmospheric Sciences * +! North Carolina State University * +! Campus Box 8208 * +! Room 5151, Jordan Hall, 2800 Faucette Drive * +! Raleigh, NC 27695-8208, USA * +! Tel: (919) 515-9688 (Office) * +! Fax: (919) 515-7802 * +! E-Mail: yang_zhang@ncsu.edu * +! * +! ************************************************************************************** +! FUNCTION: PROVIDE BOUNDARY VALUES FOR CB05 MADRID extension GAS-PHASE SPECIES * +! PRECONDITION REQUIRED: use for CB05 MADRID extension gas-phase mechanism * +! RETURN VALUES: * +! KEY SUBROUTINES AND FUNCTIONS CALLED: None * +! REVISION HISTORY: * +! This code was based on module_cb05_initmixrats.F, * +! developed by J.P. Huang and Y. Zhang, NCSU, Mar.-Oct. 2006 * +! Revised by Ying Pan and Yang Zhang, NCSU, Nov. 2007-Nov. 2008 * +! to couple MADRID with CB05 MADRID extension gas-phase mechanism * +! Revised by Yang Zhang, Xiao-Ming Hu, and Ying Pan, NCSU, Sept.-Nov., 2008 * +! Code cleaned up for NOAA WRF/Chem repository checkin * +! Revised by Ying Pan and Yang Zhang, NCSU, Sep. 2009 * +! to transfer the code to WRF/Chem v3.1.1 * +!*************************************************************************************** + + +!----------------------------------------------------------------------- + subroutine bdy_chem_value_cb05 (id_bdy, chem_bv,kk, nch,config_flags,numgas ) + + use module_configure, only: grid_config_rec_type + use module_input_chem_data, only: bdy_chem_value + + implicit none + +! arguments + REAL, INTENT(OUT) :: chem_bv ! boundary value for chem(-,-,-,nch) +! REAL, INTENT(IN) :: z ! height + INTEGER, INTENT(IN) :: nch ! index number of chemical species + INTEGER, INTENT(IN) :: numgas ! index number of last gas species + INTEGER, INTENT(IN) :: kk ! level + INTEGER, INTENT(IN) :: id_bdy ! id of bdy: 1 = YS, 2 = YE, 3=XS, 4 =XE + TYPE(grid_config_rec_type), INTENT(IN) :: config_flags +! local variables + real chem_bv_ald, chem_bv_hc3, chem_bv_hc5, & + chem_bv_hc8, chem_bv_ket, chem_bv_oli, & + chem_bv_olt, chem_bv_ora2 + real, parameter :: chem_bv_def = 1.0e-20 + character (len=100) :: record + character (len=20) :: chem_var + real :: cmaq_bc9(98,4,34) + integer :: iv, i,j,k + +! The following boundary values were taken from CMAQ, July, 2001 episode +! +! for NO2 + data (cmaq_bc9(1,1,k),k=1,34)& + / 9.9999997E-06, 9.9999997E-06, 9.9999997E-06, & + 9.9999997E-06, 9.9999997E-06, 9.6428539E-06, 9.2857072E-06,& + 7.4999953E-06, 5.7142838E-06, 5.7142838E-06, 24*0./ + data (cmaq_bc9(1,2,k),k=1,34)& + / 9.9999997E-06, 9.9999997E-06, 9.9999997E-06, & + 9.9999997E-06, 9.9999997E-06, 9.6428539E-06, 9.2857072E-06,& + 7.4999953E-06, 5.7142838E-06, 5.7142838E-06, 24*0./ + data (cmaq_bc9(1,3,k),k=1,34)& + /1.6700001E-04, 1.6700001E-04, 1.6700001E-04,& + 1.6700001E-04, 1.6700001E-04, 1.6403571E-04, 1.6107140E-04,& + 1.4625001E-04, 1.3142861E-04, 1.3142861E-04, 8.3999999E-05,& + 8.3999999E-05, 8.3999999E-05, 5.6000019E-05, 5.6000019E-05,& + 2.5454530E-05, 2.5454530E-05, 2.5454530E-05, 7.4999953E-06,& + 5.7142838E-06, 5.7142838E-06, 13*0./ + data (cmaq_bc9(1,4,k),k=1,34)& + /1.6700001E-04, 1.6700001E-04, 1.6700001E-04,& + 1.6700001E-04, 1.6700001E-04, 1.6403571E-04, 1.6107140E-04,& + 1.4625001E-04, 1.3142861E-04, 1.3142861E-04, 8.3999999E-05,& + 8.3999999E-05, 8.3999999E-05, 5.6000019E-05, 5.6000019E-05,& + 2.5454530E-05, 2.5454530E-05, 2.5454530E-05, 7.4999953E-06,& + 5.7142838E-06, 5.7142838E-06, 13*0./ + +! for NO + data (cmaq_bc9(2,1,k),k=1,34)& + / 9.9999997E-06,9.9999997E-06,9.9999997E-06, & + 9.9999997E-06, 9.9999997E-06,9.6428539E-06, 9.2857072E-06,& + 7.4999953E-06, 5.7142838E-06,5.7142838E-06,24*0./ + data (cmaq_bc9(2,2,k),k=1,34)& + /34*0./ + data (cmaq_bc9(2,3,k),k=1,34)& + / 5*8.2999999E-05, 8.1535698E-05, 8.0071397E-05,& + 7.2749986E-05, 6.5428569E-05, 6.5428569E-05, 4.2000000E-05,& + 4.2000000E-05, 4.2000000E-05, 2.8000009E-05, 2.8000009E-05,& + 1.2727260E-05, 1.2727260E-05, 1.2727260E-05, 16*0./ + data (cmaq_bc9(2,4,k),k=1,34)& + / 5*8.2999999E-05, 8.1535698E-05, 8.0071397E-05,& + 7.2749986E-05, 2*6.5428569E-05,3*4.2000000E-05,& + 2*2.8000009E-05, 3*1.2727260E-05, 16*0./ + +! for O + data ((cmaq_bc9(3,i,k),k=1,34),i=1,4)& + /136*0./ + +! for O3 (CAM profile corporated) + data (cmaq_bc9(4,1,k),k=1,34)& + /2*2.9999999E-02, 3.0714281E-02,& + 3.1785712E-02, 3.2857139E-02, 3.4107145E-02, 0.034610,& + 0.034933, 0.035268, 0.035629, 0.035993,& + 0.036361, 0.036940, 0.037728, 0.038633,& + 0.039955, 0.041303, 0.042877, 0.044563,& + 0.046555, 0.048089, 0.049924, 0.052937,& + 0.056136, 0.059363, 0.062810, & + 0.064494, 0.065790, 0.069328, 0.074218, & + 0.086511, 0.100520, 0.117374, 0.182958 / + data (cmaq_bc9(4,2,k),k=1,34)& + /2*2.9999999E-02, 3.0714281E-02,& + 3.1785712E-02, 3.2857139E-02, 3.4107145E-02, 0.034610,& + 0.034933, 0.035268, 0.035629, 0.035993,& + 0.036361, 0.036940, 0.037728, 0.038633,& + 0.039955, 0.041303, 0.042877, 0.044563,& + 0.046555, 0.048089, 0.049924, 0.052937,& + 0.056136, 0.059363, 0.062810, & + 0.064494, 0.065790, 0.069328, 0.074218, & + 0.086511, 0.100520, 0.117374, 0.182958 / + data (cmaq_bc9(4,3,k),k=1,34)& + /5*3.5000000E-02,3.5178576E-02,0.034610,& + 0.034933,0.035268,0.035629,0.035993,& + 0.036361,0.036940,0.037728,0.038633,& + 0.039955,0.041303,0.042877,0.044563,& + 0.046555,0.048089,0.049924,0.052937,& + 0.056136, 0.059363, 0.062810, & + 0.064494, 0.065790, 0.069328, 0.074218, & + 0.086511, 0.100520, 0.117374, 0.182958 / + data (cmaq_bc9(4,4,k),k=1,34)& + /5*3.5000000E-02,3.5178576E-02,0.034610,& + 0.034933,0.035268,0.035629,0.035993,& + 0.036361,0.036940,0.037728,0.038633,& + 0.039955,0.041303,0.042877,0.044563,& + 0.046555,0.048089,0.049924,0.052937,& + 0.056136, 0.059363, 0.062810, & + 0.064494, 0.065790, 0.069328, 0.074218, & + 0.086511, 0.100520, 0.117374, 0.182958 / + +! for no3 + data ((cmaq_bc9(5,i,k),k=1,34),i=1,4)& + /136*0./ + +! for o1d + data ((cmaq_bc9(6,i,k),k=1,34),i=1,4)& + /136*0./ + +! for oh + data ((cmaq_bc9(7,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ho2 + data ((cmaq_bc9(8,i,k),k=1,34),i=1,4)& + /136*0./ + +! for n2o5 + data ((cmaq_bc9(9,i,k),k=1,34),i=1,4)& + /136*0./ + +! for hno3 + data (cmaq_bc9(10,1,k),k=1,34)& + /25*4.9999999E-05,3*9.9999997E-05,1.2500001E-04,5*1.5000001E-04/ + data (cmaq_bc9(10,2,k),k=1,34)& + /25*4.9999999E-05,3*9.9999997E-05,1.2500001E-04,5*1.5000001E-04/ + data (cmaq_bc9(10,3,k),k=1,34)& + /18*4.9999999E-05,2*5.1851850E-05, 5.5370372E-05,& + 5.8888891E-05, 6.3518521E-05, 2*6.8148147E-05,& + 3*8.5000000E-05,9.2499999E-05,5*9.9999997E-05/ + data (cmaq_bc9(10,4,k),k=1,34)& + /18*4.9999999E-05,2*5.1851850E-05, 5.5370372E-05,& + 5.8888891E-05, 6.3518521E-05, 2*6.8148147E-05,& + 3*8.5000000E-05,9.2499999E-05,5*9.9999997E-05/ + +! for hono + data ((cmaq_bc9(11,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for pna + data ((cmaq_bc9(12,i,k),k=1,34),i=1,4)& + /136*1.9999999E-09/ + +! for h2o2 + data (cmaq_bc9(13,1,k),k=1,34)& + /18*2.0000001E-03,2*1.9537040E-03, 1.8657411E-03,& + 1.7777780E-03, 1.6620370E-03, 1.5462959E-03, & + 1.5462959E-03, 1.2500000E-03, 1.2500000E-03, & + 1.2500000E-03, 1.1250000E-03, 5*1.0000000E-03/ + data (cmaq_bc9(13,2,k),k=1,34)& + /18*2.0000001E-03,2*1.9537040E-03, 1.8657411E-03,& + 1.7777780E-03, 1.6620370E-03, 1.5462959E-03, & + 1.5462959E-03, 1.2500000E-03, 1.2500000E-03, & + 1.2500000E-03, 1.1250000E-03, 5*1.0000000E-03/ + data (cmaq_bc9(13,3,k),k=1,34)& + /5*1.0000000E-03, 1.0178576E-03,1.0357150E-03,& + 1.1250004E-03,1.2142860E-03,1.2142860E-03,3*1.5000000E-03,& + 2*1.3333330E-03,3*1.1515151E-03,2*9.8148151E-04,& + 9.4629632E-04,9.1111113E-04,8.6481485E-04,2*8.1851851E-04,& + 3*5.0000002E-04, 3.5000002E-04,5*1.9999999E-04/ + data (cmaq_bc9(13,4,k),k=1,34)& + /5*1.0000000E-03, 1.0178576E-03,1.0357150E-03,& + 1.1250004E-03,1.2142860E-03,1.2142860E-03,3*1.5000000E-03,& + 2*1.3333330E-03,3*1.1515151E-03,2*9.8148151E-04,& + 9.4629632E-04,9.1111113E-04,8.6481485E-04,2*8.1851851E-04,& + 3*5.0000002E-04, 3.5000002E-04,5*1.9999999E-04/ + +! for xo2 + data ((cmaq_bc9(14,i,k),k=1,34),i=1,4)& + /136*0./ + +! for xo2n + data ((cmaq_bc9(15,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ntr + data ((cmaq_bc9(16,i,k),k=1,34),i=1,4)& + /136*0./ + +! for rooh + data ((cmaq_bc9(17,i,k),k=1,34),i=1,4)& + /136*0./ + +! for form + data ((cmaq_bc9(18,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ald2 + data ((cmaq_bc9(19,i,k),k=1,34),i=1,4)& + /136*0./ + +! for aldx + data ((cmaq_bc9(20,i,k),k=1,34),i=1,4)& + /136*0./ + +! for par + data ((cmaq_bc9(21,i,k),k=1,34),i=1,4)& + /136*0./ + +! for co + data (cmaq_bc9(22,1,k),k=1,34)& + /18*7.0000000E-02,2*6.9537044E-02,6.8657413E-02,& + 6.7777783E-02,6.6620372E-02,2*6.5462962E-02,& + 3*5.9999999E-02,5.7499997E-02,5*5.5000000E-02/ + data (cmaq_bc9(22,2,k),k=1,34)& + /13*7.9999998E-02,2*7.8333333E-02,3*7.6515153E-02,& + 2*7.4537039E-02, 7.3657408E-02, 7.2777778E-02,7.1620367E-02,& + 7.0462957E-02, 7.0462957E-02, 6.7500003E-02, 6.7500003E-02,& + 6.7500003E-02, 6.6249996E-02, 5*6.4999998E-02/ + data (cmaq_bc9(22,3,k),k=1,34)& + /13*7.9999998E-02,2*7.6666668E-02,3*7.3030300E-02,& + 2*6.9537044E-02,6.8657413E-02,6.7777783E-02,6.6620372E-02,& + 6.5462962E-02, 6.5462962E-02, 5.7500001E-02, 5.7500001E-02,& + 5.7500001E-02, 5.3750001E-02, 5*5.0000001E-02/ + data (cmaq_bc9(22,4,k),k=1,34)& + /13*7.9999998E-02,2*7.6666668E-02,3*7.3030300E-02,& + 2*6.9537044E-02,6.8657413E-02,6.7777783E-02,6.6620372E-02,& + 6.5462962E-02, 6.5462962E-02, 5.7500001E-02, 5.7500001E-02,& + 5.7500001E-02, 5.3750001E-02, 5*5.0000001E-02/ + +! for meo2 + data ((cmaq_bc9(23,i,k),k=1,34),i=1,4)& + /136*0./ + +! for mepx + data (cmaq_bc9(24,1,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07, & + 2*1.9537040E-07,1.8657411E-07,1.7777781E-07,1.6620371E-07,& + 2*1.5462960E-07,3*1.2500000E-07,1.1250000E-07,& + 5*1.0000000E-07/ + data (cmaq_bc9(24,2,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07, & + 2*1.9537040E-07,1.8657411E-07,1.7777781E-07,1.6620371E-07,& + 2*1.5462960E-07,3*1.2500000E-07,1.1250000E-07,& + 5*1.0000000E-07/ + data (cmaq_bc9(24,3,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,1.3240745E-07,& + 1.0925930E-07,1.0925930E-07,3*7.5000003E-08,6.2500000E-08,& + 5*5.0000001E-08/ + data (cmaq_bc9(24,4,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,1.3240745E-07,& + 1.0925930E-07,1.0925930E-07,3*7.5000003E-08,6.2500000E-08,& + 5*5.0000001E-08/ + +! for meoh + data ((cmaq_bc9(25,i,k),k=1,34),i=1,4)& + /136*0./ + +! for hco3 + data ((cmaq_bc9(26,i,k),k=1,34),i=1,4)& + /136*0./ + +! for facd + data (cmaq_bc9(27,1,k),k=1,34)& + /2*1.5000001E-06,1.3571430E-06,1.1428572E-06,& + 9.2857141E-07,7.1428570E-07,28*5.0000000E-07/ + data (cmaq_bc9(27,2,k),k=1,34)& + /2*1.5000001E-06,1.3571430E-06,1.1428572E-06,& + 9.2857141E-07,7.1428570E-07,28*5.0000000E-07/ + data (cmaq_bc9(27,3,k),k=1,34)& + /5*1.0000000E-06,9.8214264E-07,9.6428539E-07,& + 8.7499978E-07,7.8571418E-07,7.8571418E-07,& + 15*5.0000000E-07,3*2.5000000E-07,1.2500000E-07,& + 5*0./ + data (cmaq_bc9(27,4,k),k=1,34)& + /5*1.0000000E-06,9.8214264E-07,9.6428539E-07,& + 8.7499978E-07,7.8571418E-07,7.8571418E-07,& + 15*5.0000000E-07,3*2.5000000E-07,1.2500000E-07,& + 5*0./ + +! for c2o3 + data ((cmaq_bc9(28,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for pan + data ((cmaq_bc9(29,i,k),k=1,34),i=1,2)& + /68*1.5000000E-05/ + data (cmaq_bc9(29,3,k),k=1,34)& + /5*9.9999997E-05,9.8214266E-05,9.6428543E-05,& + 8.7499982E-05,7.8571422E-05,7.8571422E-05,8*4.9999999E-05,& + 2*4.6759251E-05, 4.0601852E-05,3.4444449E-05,2.6342594E-05,& + 2*1.8240740E-05, 3*7.4999998E-06,3.7499999E-06,5*0./ + data (cmaq_bc9(29,4,k),k=1,34)& + /5*9.9999997E-05,9.8214266E-05,9.6428543E-05,& + 8.7499982E-05,7.8571422E-05,7.8571422E-05,8*4.9999999E-05,& + 2*4.6759251E-05, 4.0601852E-05,3.4444449E-05,2.6342594E-05,& + 2*1.8240740E-05, 3*7.4999998E-06,3.7499999E-06,5*0./ + +! for pacd + data (cmaq_bc9(30,1,k),k=1,34)& + /18*9.9999997E-05,2*9.5370357E-05,8.6574073E-05,& + 7.7777782E-05,6.6203706E-05,5.4629629E-05,5.4629629E-05,& + 9*4.9999999E-05/ + data (cmaq_bc9(30,2,k),k=1,34)& + /34*4.9999999E-05/ + data (cmaq_bc9(30,3,k),k=1,34)& + /13*2.9999999E-05,2*2.8333330E-05,3*2.6515150E-05,& + 2*2.4537039E-05,2.3657409E-05,2.2777780E-05,2.1620370E-05,& + 2*2.0462960E-05, 3*1.7500000E-05,1.6250000E-05,5*1.5000000E-05/ + data (cmaq_bc9(30,4,k),k=1,34)& + /13*2.9999999E-05,2*2.8333330E-05,3*2.6515150E-05,& + 2*2.4537039E-05,2.3657409E-05,2.2777780E-05,2.1620370E-05,& + 2*2.0462960E-05, 3*1.7500000E-05,1.6250000E-05,5*1.5000000E-05/ + +! for aacd + data (cmaq_bc9(31,1,k),k=1,34)& + /2*1.5000001E-06, 1.3571430E-06,1.1428572E-06,9.2857141E-07,& + 7.1428570E-07, 28*5.0000000E-07/ + data (cmaq_bc9(31,2,k),k=1,34)& + /2*1.5000001E-06, 1.3571430E-06,1.1428572E-06,9.2857141E-07,& + 7.1428570E-07, 28*5.0000000E-07/ + data (cmaq_bc9(31,3,k),k=1,34)& + /5*1.0000000E-06,9.8214264E-07,9.6428539E-07,& + 8.7499978E-07,7.8571418E-07,7.8571418E-07,15*5.0000000E-07,& + 3*2.5000000E-07,1.2500000E-07,5*0/ + data (cmaq_bc9(31,4,k),k=1,34)& + /5*1.0000000E-06,9.8214264E-07,9.6428539E-07,& + 8.7499978E-07,7.8571418E-07,7.8571418E-07,15*5.0000000E-07,& + 3*2.5000000E-07,1.2500000E-07,5*0/ + +! for cxo3 + data ((cmaq_bc9(32,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for panx + data ((cmaq_bc9(33,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for ror + data ((cmaq_bc9(34,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ole + data ((cmaq_bc9(35,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(35,3,k),k=1,34)& + /5*2.0000000E-07,1.9642854E-07,1.9285710E-07,& + 1.7499994E-07,2*1.5714279E-07,3*1.0000000E-07,2*6.6666693E-08,& + 3*3.0303010E-08,16*0./ + data (cmaq_bc9(35,4,k),k=1,34)& + /5*2.0000000E-07,1.9642854E-07,1.9285710E-07,& + 1.7499994E-07,2*1.5714279E-07,3*1.0000000E-07,2*6.6666693E-08,& + 3*3.0303010E-08,16*0./ + +! for eth + data ((cmaq_bc9(36,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(36,3,k),k=1,34)& + /2*4.9999999E-06, 4.7142862E-06,4.2857146E-06,& + 3.8571429E-06,3.3928568E-06,2.9285709E-06,2.7499996E-06,& + 2*2.5714280E-06,3*2.0000000E-06,2*1.6666670E-06,3*1.3030300E-06,& + 7*1.0000000E-06, 3* 5.0000000E-07,2.5000000E-07,5*0./ + data (cmaq_bc9(36,4,k),k=1,34)& + /2*4.9999999E-06, 4.7142862E-06,4.2857146E-06,& + 3.8571429E-06,3.3928568E-06,2.9285709E-06,2.7499996E-06,& + 2*2.5714280E-06,3*2.0000000E-06,2*1.6666670E-06,3*1.3030300E-06,& + 7*1.0000000E-06, 3* 5.0000000E-07,2.5000000E-07,5*0./ + +! for iole + data ((cmaq_bc9(37,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(37,3,k),k=1,34)& + /5*1.0000000E-07,9.6428536E-08,9.2857071E-08,& + 7.4999960E-08,2*5.7142849E-08,24*0./ + data (cmaq_bc9(37,4,k),k=1,34)& + /5*1.0000000E-07,9.6428536E-08,9.2857071E-08,& + 7.4999960E-08,2*5.7142849E-08,24*0./ + +! for tol + data ((cmaq_bc9(38,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(38,3,k),k=1,34)& + /18*1.0000000E-06, 2*9.0740730E-07,& + 7.3148146E-07,5.5555557E-07,3.2407408E-07,& + 2*9.2592600E-08,9*0./ + data (cmaq_bc9(38,4,k),k=1,34)& + /18*1.0000000E-06, 2*9.0740730E-07,& + 7.3148146E-07,5.5555557E-07,3.2407408E-07,& + 2*9.2592600E-08,9*0./ + +! for cres + data ((cmaq_bc9(39,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for to2 + data ((cmaq_bc9(40,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for tolaer1 + data ((cmaq_bc9(41,i,k),k=1,34),i=1,4)& + /136*0./ +! for tolaer2 + data ((cmaq_bc9(42,i,k),k=1,34),i=1,4)& + /136*0./ + +! for open + data (cmaq_bc9(43,1,k),k=1,34)& + /13*2.5000000E-07, 2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9537040E-07, 1.8657411E-07,1.7777781E-07,1.6620371E-07,& + 2*1.5462960E-07,3*1.2500000E-07,1.1250000E-07,5*1.0000000E-07/ + data (cmaq_bc9(43,2,k),k=1,34)& + /13*2.5000000E-07, 2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9537040E-07, 1.8657411E-07,1.7777781E-07,1.6620371E-07,& + 2*1.5462960E-07,3*1.2500000E-07,1.1250000E-07,5*1.0000000E-07/ + data (cmaq_bc9(43,3,k),k=1,34)& + / 13*2.5000000E-07, 2*2.3333330E-07,& + 3*2.1515150E-07, 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,& + 1.3240745E-07,2*1.0925930E-07,& + 3*7.5000003E-08, 6.2500000E-08, 5*5.0000001E-08/ + data (cmaq_bc9(43,4,k),k=1,34)& + / 13*2.5000000E-07, 2*2.3333330E-07,& + 3*2.1515150E-07, 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,& + 1.3240745E-07,2*1.0925930E-07,& + 3*7.5000003E-08, 6.2500000E-08, 5*5.0000001E-08/ + +! for cro + data ((cmaq_bc9(44,i,k),k=1,34),i=1,4)& + /136*0./ + +! for cslaer + data ((cmaq_bc9(45,i,k),k=1,34),i=1,4)& + /136*0./ + +! for mgly + data (cmaq_bc9(46,1,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9537040E-07, 1.8657411E-07, 1.7777781E-07, 1.6620371E-07,& + 2*1.5462960E-07, 3*1.2500000E-07,1.1250000E-07,5*1.0000000E-07/ + data (cmaq_bc9(46,2,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9537040E-07, 1.8657411E-07, 1.7777781E-07, 1.6620371E-07,& + 2*1.5462960E-07, 3*1.2500000E-07,1.1250000E-07,5*1.0000000E-07/ + data (cmaq_bc9(46,3,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,1.3240745E-07,& + 2*1.0925930E-07, 3*7.5000003E-08,6.2500000E-08,& + 5*5.0000001E-08 / + data (cmaq_bc9(46,4,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,1.3240745E-07,& + 2*1.0925930E-07, 3*7.5000003E-08,6.2500000E-08,& + 5*5.0000001E-08 / + +! for xyl + data ((cmaq_bc9(47,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(47,3,k),k=1,34)& + / 5*2.0000000E-07,1.9642854E-07,1.9285710E-07,& + 1.7499994E-07,2*1.5714279E-07,3*1.0000000E-07,& + 2*6.6666693E-08,3*3.0303010E-08, 16*0.0/ + data (cmaq_bc9(47,4,k),k=1,34)& + / 5*2.0000000E-07,1.9642854E-07,1.9285710E-07,& + 1.7499994E-07,2*1.5714279E-07,3*1.0000000E-07,& + 2*6.6666693E-08,3*3.0303010E-08, 16*0.0/ + +! for xylaer1 + data ((cmaq_bc9(48,i,k),k=1,34),i=1,4)& + /136*0./ + +! for xylaer2 + data ((cmaq_bc9(49,i,k),k=1,34),i=1,4)& + /136*0./ + +! for isop + data ((cmaq_bc9(50,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(50,3,k),k=1,34)& + /5*1.5000001E-04,1.4464281E-04,1.3928561E-04,& + 1.1249994E-04,2*8.5714273E-05,24*0./ + data (cmaq_bc9(50,4,k),k=1,34)& + /5*1.5000001E-04,1.4464281E-04,1.3928561E-04,& + 1.1249994E-04,2*8.5714273E-05,24*0./ + +! for ispd + data ((cmaq_bc9(51,i,k),k=1,34),i=1,4)& + /136*0./ + +! for isoaer1 + data ((cmaq_bc9(52,i,k),k=1,34),i=1,4)& + /136*0./ + +! for isoaer2 + data ((cmaq_bc9(53,i,k),k=1,34),i=1,4)& + /136*0./ + +! so2 + data ((cmaq_bc9(54,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(54,3,k),k=1,34)& + /2*3.0000001E-04,2.8571431E-04, 2.6428571E-04,& + 2.4285710E-04,2.1785710E-04,1.9285710E-04,& + 1.7499995E-04,2*1.5714280E-04,1.5714280E-04,8*9.9999997E-05,& + 2*9.2592578E-05,7.8518511E-05,6.4444437E-05,4.5925924E-05,& + 2*2.7407410E-05,3*1.5000000E-05,5*9.9999997E-06/ + data (cmaq_bc9(54,4,k),k=1,34)& + /2*3.0000001E-04,2.8571431E-04, 2.6428571E-04,& + 2.4285710E-04,2.1785710E-04,1.9285710E-04,& + 1.7499995E-04,2*1.5714280E-04,1.5714280E-04,8*9.9999997E-05,& + 2*9.2592578E-05,7.8518511E-05,6.4444437E-05,4.5925924E-05,& + 2*2.7407410E-05,3*1.5000000E-05,5*9.9999997E-06/ + +! sulf + data ((cmaq_bc9(55,i,k),k=1,34),i=1,4)& + /136*1.0000000E-30/ + +! sulfaer + data ((cmaq_bc9(56,i,k),k=1,34),i=1,4)& + /136*0./ + +! etoh + data ((cmaq_bc9(57,i,k),k=1,34),i=1,4)& + /136*0./ + +! etha + data (cmaq_bc9(58,1,k),k=1,34)& + /13*9.9999997E-05,2*8.9000008E-05,& + 3*7.6999990E-05,16*6.7000001E-05/ + data (cmaq_bc9(58,2,k),k=1,34)& + /13*9.9999997E-05,2*8.9000008E-05,& + 3*7.6999990E-05,2*6.3851847E-05,& + 5.7870369E-05,5.1888888E-05,4.4018518E-05,& + 2*3.6148151E-05,9*3.3000000E-05/ + data (cmaq_bc9(58,3,k),k=1,34)& + /5*9.9999997E-05,9.9285702E-05,9.8571407E-05,& + 9.4999989E-05,2*9.1428570E-05,3*7.9999998E-05,& + 2*6.3333340E-05, 3*4.5151501E-05,& + 2*2.8148141E-05, 2.4629626E-05, 2.1111109E-05,1.6481479E-05,& + 2*1.1851850E-05, 3*4.9999999E-06,2.4999999E-06,5*0./ + data (cmaq_bc9(58,4,k),k=1,34)& + /5*9.9999997E-05,9.9285702E-05,9.8571407E-05,& + 9.4999989E-05,2*9.1428570E-05,3*7.9999998E-05,& + 2*6.3333340E-05, 3*4.5151501E-05,& + 2*2.8148141E-05, 2.4629626E-05, 2.1111109E-05,1.6481479E-05,& + 2*1.1851850E-05, 3*4.9999999E-06,2.4999999E-06,5*0./ + +! for terp + data ((cmaq_bc9(59,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(59,3,k),k=1,34)& + / 5*3.7500002E-05,3.6160702E-05,3.4821402E-05,& + 2.8124985E-05, 2*2.1428570E-05,24*0./ + data (cmaq_bc9(59,4,k),k=1,34)& + / 5*3.7500002E-05,3.6160702E-05,3.4821402E-05,& + 2.8124985E-05, 2*2.1428570E-05,24*0./ + +! terpaer + data ((cmaq_bc9(60,i,k),k=1,34),i=1,4)& + /136*0./ + +! for hum + data ((cmaq_bc9(61,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(61,3,k),k=1,34)& + / 5*1.2412500662E-05,1.1969192362E-05,1.1525884062E-05,& + 0.9309370035E-05, 2*0.709285667E-05,24*0./ + data (cmaq_bc9(61,4,k),k=1,34)& + / 5*1.218262564974E-05,1.174752725874E-05,1.131242886774E-05,& + 0.913696387695E-05, 2*0.69614995359E-05,24*0./ + +! for humaer + data ((cmaq_bc9(62,i,k),k=1,34),i=1,4)& + /136*0./ + +! for lim + data ((cmaq_bc9(63,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(63,3,k),k=1,34)& + / 5*0.506250027E-05,0.488269477E-05,0.470088927E-05,& + 0.3796872975E-05, 2*0.289285695E-05,24*0./ + data (cmaq_bc9(63,4,k),k=1,34)& + / 5*0.3016087660858E-05,0.2908369101158E-05,0.2800650541458E-05,& + 0.2262064418565E-05, 2*0.172347845653E-05,24*0./ + +! for limaer1 + data ((cmaq_bc9(64,i,k),k=1,34),i=1,4)& + /136*0./ + +! for limaer2 + data ((cmaq_bc9(65,i,k),k=1,34),i=1,4)& + /136*0./ + +! for oci + data ((cmaq_bc9(66,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(66,3,k),k=1,34)& + / 5*0.8137500434E-05,0.7846872334E-05,0.7556244234E-05,& + 0.6103121745E-05, 2*0.464999969E-05,24*0./ + data (cmaq_bc9(66,4,k),k=1,34)& + / 5*0.6262500334E-05,0.6038837234E-05,0.5815174134E-05,& + 0.4696872495E-05, 2*0.357857119E-05,24*0./ + +! for ociaer1 + data ((cmaq_bc9(67,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ociaer2 + data ((cmaq_bc9(68,i,k),k=1,34),i=1,4)& + /136*0./ + +! for apin + data ((cmaq_bc9(69,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(69,3,k),k=1,34)& + / 5*0.331875E-05,0.3200222127E-05,0.3081694077E-05,& + 0.24890611725E-05, 2*0.1896428445E-05,24*0./ + data (cmaq_bc9(69,4,k),k=1,34)& + / 5*0.69192375E-05,0.6672119608126E-05,0.6425001347226E-05,& + 0.5189425357305E-05, 2*0.395384973641E-05,24*0./ + +! for apinaer1 + data ((cmaq_bc9(70,i,k),k=1,34),i=1,4)& + /136*0./ + +! for apinaer2 + data ((cmaq_bc9(71,i,k),k=1,34),i=1,4)& + /136*0./ + +! for apinaer3 + data ((cmaq_bc9(72,i,k),k=1,34),i=1,4)& + /136*0./ + +! for apinaer4 + data ((cmaq_bc9(73,i,k),k=1,34),i=1,4)& + /136*0./ + +! for bpin + data ((cmaq_bc9(74,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(74,3,k),k=1,34)& + / 5*0.2587500138E-05,0.2495088438E-05,0.2402676738E-05,& + 0.1940623965E-05, 2*0.147857133E-05,24*0./ + data (cmaq_bc9(74,4,k),k=1,34)& + / 5*0.85875E-05,0.8280800758E-05,0.7974101058E-05,& + 0.6440621565E-05, 2*0.490714253E-05,24*0./ + +! for bpinaer1 + data ((cmaq_bc9(75,i,k),k=1,34),i=1,4)& + /136*0./ + +! for bpinaer2 + data ((cmaq_bc9(76,i,k),k=1,34),i=1,4)& + /136*0./ + +! for bpinaer3 + data ((cmaq_bc9(77,i,k),k=1,34),i=1,4)& + /136*0./ + +! for bpinaer4 + data ((cmaq_bc9(78,i,k),k=1,34),i=1,4)& + /136*0./ + +! for bpinaer5 + data ((cmaq_bc9(79,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ter + + data ((cmaq_bc9(80,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(80,3,k),k=1,34)& + / 5*0.5925000316E-05,0.5713390916E-05,0.5501781516E-05,& + 0.444374763E-05, 2*0.338571406E-05,24*0./ + data (cmaq_bc9(80,4,k),k=1,34)& + / 5*0.0532237528386E-05,0.0513228843486E-05,0.0494220158586E-05,& + 0.0399177912105E-05, 2*0.030413569401E-05,24*0./ + +! for teraer1 + data ((cmaq_bc9(81,i,k),k=1,34),i=1,4)& + /136*0./ + +! for teraer2 + data ((cmaq_bc9(82,i,k),k=1,34),i=1,4)& + /136*0./ + +! for alkh + data ((cmaq_bc9(83,i,k),k=1,34),i=1,4)& + /136*0./ + +! for alkhaer1 + data ((cmaq_bc9(84,i,k),k=1,34),i=1,4)& + /136*0./ + +! for pah + data ((cmaq_bc9(85,i,k),k=1,34),i=1,4)& + /136*0./ + +! for pahaer1 + data ((cmaq_bc9(86,i,k),k=1,34),i=1,4)& + /136*0./ + +! for pahaer2 + data ((cmaq_bc9(87,i,k),k=1,34),i=1,4)& + /136*0./ + +! for h2 + data ((cmaq_bc9(88,i,k),k=1,34),i=1,4)& + /136*0.5/ + +! for ch4 + data ((cmaq_bc9(89,i,k),k=1,34),i=1,4)& + /136*1.7/ + +! for cl + data ((cmaq_bc9(90,i,k),k=1,34),i=1,4)& + /136*0./ + +! for hcl + data ((cmaq_bc9(91,i,k),k=1,34),i=1,4)& + /136*0./ + +! for fmcl + data ((cmaq_bc9(92,i,k),k=1,34),i=1,4)& + /136*0./ +! for hg0 + data ((cmaq_bc9(93,i,k),k=1,34),i=1,4)& + /136*0./ +! for hg2 + data ((cmaq_bc9(94,i,k),k=1,34),i=1,4)& + /136*0./ +! for hocl + data ((cmaq_bc9(95,i,k),k=1,34),i=1,4)& + /136*0./ +! for clo + data ((cmaq_bc9(96,i,k),k=1,34),i=1,4)& + /136*0./ +! for cl2 + data ((cmaq_bc9(97,i,k),k=1,34),i=1,4)& + /136*0./ +! for nh3 + data ((cmaq_bc9(98,i,k),k=1,34),i=1,4)& + /136*0./ + + if (id_bdy .eq. 1 ) then + chem_bv = cmaq_bc9(nch-1,1,kk) + elseif (id_bdy .eq. 2 ) then + chem_bv = cmaq_bc9(nch-1,3,kk) + elseif (id_bdy .eq. 3 ) then + chem_bv = cmaq_bc9(nch-1,4,kk) + elseif (id_bdy .eq. 4 ) then + chem_bv = cmaq_bc9(nch-1,2,kk) + endif + return + end subroutine bdy_chem_value_cb05 + diff --git a/wrfv2_fire/chem/module_cb05_vbs_initmixrats.F b/wrfv2_fire/chem/module_cb05_vbs_initmixrats.F new file mode 100755 index 00000000..25a50ac7 --- /dev/null +++ b/wrfv2_fire/chem/module_cb05_vbs_initmixrats.F @@ -0,0 +1,836 @@ +! ************************************************************************************** +! This computer software was developed by Dr. Yang Zhang and her research group * +! at North Carolina State University (NCSU) with support from the NSF Career Award * +! No. Atm-0348819, and the Memorandum of Understanding between the * +! U.S. Environmental Protection Agency (EPA) and the U.S. Department of * +! Commerce's National Oceanic and Atmospheric Administration (NOAA) * +! and under agreement number DW13921548, and the U.S. EPA/Office of * +! Air Quality Planning & Standards via RTI International contract #4-321-0210288. * +! * +! NEITHER ANY COSPONSORS, NCSU, NOR ANY PERSON ACTING ON BEHALF * +! OF ANY OF THEM MAKES ANY WARRANTY OR REPRESENTATION * +! WHATSOEVER, EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR * +! THE USE OF THIS SOFTWARE. THIS SOFTWARE OR PART OF IT MAY BE * +! COPYRIGHTED AND IS PERMITTED BY ORIGINAL CODE DEVELOPERS FOR * +! NONPROFIT USE AND SUBJECTED TO RESTRICTIONS * +! * +! Contact information: * +! Dr. Yang Zhang * +! Principal Investigator * +! Department of Marine, Earth, and Atmospheric Sciences * +! North Carolina State University * +! Campus Box 8208 * +! Room 5151, Jordan Hall, 2800 Faucette Drive * +! Raleigh, NC 27695-8208, USA * +! Tel: (919) 515-9688 (Office) * +! Fax: (919) 515-7802 * +! E-Mail: yang_zhang@ncsu.edu * +! * +! ************************************************************************************** +! FUNCTION: PROVIDE BOUNDARY VALUES FOR CB05 MADRID extension GAS-PHASE SPECIES * +! PRECONDITION REQUIRED: use for CB05 MADRID extension gas-phase mechanism * +! RETURN VALUES: * +! KEY SUBROUTINES AND FUNCTIONS CALLED: None * +! REVISION HISTORY: * +! This code was based on module_cb05_initmixrats.F, * +! developed by J.P. Huang and Y. Zhang, NCSU, Mar.-Oct. 2006 * +! Revised by Ying Pan and Yang Zhang, NCSU, Nov. 2007-Nov. 2008 * +! to couple MADRID with CB05 MADRID extension gas-phase mechanism * +! Revised by Yang Zhang, Xiao-Ming Hu, and Ying Pan, NCSU, Sept.-Nov., 2008 * +! Code cleaned up for NOAA WRF/Chem repository checkin * +! Revised by Ying Pan and Yang Zhang, NCSU, Sep. 2009 * +! to transfer the code to WRF/Chem v3.1.1 * +!*************************************************************************************** + + +!----------------------------------------------------------------------- + subroutine bdy_chem_value_cb05_vbs (id_bdy, chem_bv,kk, nch,config_flags,numgas ) + + use module_configure, only: grid_config_rec_type + use module_input_chem_data, only: bdy_chem_value + + implicit none + +! arguments + REAL, INTENT(OUT) :: chem_bv ! boundary value for chem(-,-,-,nch) +! REAL, INTENT(IN) :: z ! height + INTEGER, INTENT(IN) :: nch ! index number of chemical species + INTEGER, INTENT(IN) :: numgas ! index number of last gas species + INTEGER, INTENT(IN) :: kk ! level + INTEGER, INTENT(IN) :: id_bdy ! id of bdy: 1 = YS, 2 = YE, 3=XS, 4 =XE + TYPE(grid_config_rec_type), INTENT(IN) :: config_flags +! local variables + real chem_bv_ald, chem_bv_hc3, chem_bv_hc5, & + chem_bv_hc8, chem_bv_ket, chem_bv_oli, & + chem_bv_olt, chem_bv_ora2 + real, parameter :: chem_bv_def = 1.0e-20 + character (len=100) :: record + character (len=20) :: chem_var + real :: cmaq_bc9(106,4,34) + integer :: iv, i,j,k + +! The following boundary values were taken from CMAQ, July, 2001 episode +! +! for NO2 + data (cmaq_bc9(1,1,k),k=1,34)& + / 9.9999997E-06, 9.9999997E-06, 9.9999997E-06, & + 9.9999997E-06, 9.9999997E-06, 9.6428539E-06, 9.2857072E-06,& + 7.4999953E-06, 5.7142838E-06, 5.7142838E-06, 24*0./ + data (cmaq_bc9(1,2,k),k=1,34)& + / 9.9999997E-06, 9.9999997E-06, 9.9999997E-06, & + 9.9999997E-06, 9.9999997E-06, 9.6428539E-06, 9.2857072E-06,& + 7.4999953E-06, 5.7142838E-06, 5.7142838E-06, 24*0./ + data (cmaq_bc9(1,3,k),k=1,34)& + /1.6700001E-04, 1.6700001E-04, 1.6700001E-04,& + 1.6700001E-04, 1.6700001E-04, 1.6403571E-04, 1.6107140E-04,& + 1.4625001E-04, 1.3142861E-04, 1.3142861E-04, 8.3999999E-05,& + 8.3999999E-05, 8.3999999E-05, 5.6000019E-05, 5.6000019E-05,& + 2.5454530E-05, 2.5454530E-05, 2.5454530E-05, 7.4999953E-06,& + 5.7142838E-06, 5.7142838E-06, 13*0./ + data (cmaq_bc9(1,4,k),k=1,34)& + /1.6700001E-04, 1.6700001E-04, 1.6700001E-04,& + 1.6700001E-04, 1.6700001E-04, 1.6403571E-04, 1.6107140E-04,& + 1.4625001E-04, 1.3142861E-04, 1.3142861E-04, 8.3999999E-05,& + 8.3999999E-05, 8.3999999E-05, 5.6000019E-05, 5.6000019E-05,& + 2.5454530E-05, 2.5454530E-05, 2.5454530E-05, 7.4999953E-06,& + 5.7142838E-06, 5.7142838E-06, 13*0./ + +! for NO + data (cmaq_bc9(2,1,k),k=1,34)& + / 9.9999997E-06,9.9999997E-06,9.9999997E-06, & + 9.9999997E-06, 9.9999997E-06,9.6428539E-06, 9.2857072E-06,& + 7.4999953E-06, 5.7142838E-06,5.7142838E-06,24*0./ + data (cmaq_bc9(2,2,k),k=1,34)& + /34*0./ + data (cmaq_bc9(2,3,k),k=1,34)& + / 5*8.2999999E-05, 8.1535698E-05, 8.0071397E-05,& + 7.2749986E-05, 6.5428569E-05, 6.5428569E-05, 4.2000000E-05,& + 4.2000000E-05, 4.2000000E-05, 2.8000009E-05, 2.8000009E-05,& + 1.2727260E-05, 1.2727260E-05, 1.2727260E-05, 16*0./ + data (cmaq_bc9(2,4,k),k=1,34)& + / 5*8.2999999E-05, 8.1535698E-05, 8.0071397E-05,& + 7.2749986E-05, 2*6.5428569E-05,3*4.2000000E-05,& + 2*2.8000009E-05, 3*1.2727260E-05, 16*0./ + +! for O + data ((cmaq_bc9(3,i,k),k=1,34),i=1,4)& + /136*0./ + +! for O3 (CAM profile corporated) + data (cmaq_bc9(4,1,k),k=1,34)& + /2*2.9999999E-02, 3.0714281E-02,& + 3.1785712E-02, 3.2857139E-02, 3.4107145E-02, 0.034610,& + 0.034933, 0.035268, 0.035629, 0.035993,& + 0.036361, 0.036940, 0.037728, 0.038633,& + 0.039955, 0.041303, 0.042877, 0.044563,& + 0.046555, 0.048089, 0.049924, 0.052937,& + 0.056136, 0.059363, 0.062810, & + 0.064494, 0.065790, 0.069328, 0.074218, & + 0.086511, 0.100520, 0.117374, 0.182958 / + data (cmaq_bc9(4,2,k),k=1,34)& + /2*2.9999999E-02, 3.0714281E-02,& + 3.1785712E-02, 3.2857139E-02, 3.4107145E-02, 0.034610,& + 0.034933, 0.035268, 0.035629, 0.035993,& + 0.036361, 0.036940, 0.037728, 0.038633,& + 0.039955, 0.041303, 0.042877, 0.044563,& + 0.046555, 0.048089, 0.049924, 0.052937,& + 0.056136, 0.059363, 0.062810, & + 0.064494, 0.065790, 0.069328, 0.074218, & + 0.086511, 0.100520, 0.117374, 0.182958 / + data (cmaq_bc9(4,3,k),k=1,34)& + /5*3.5000000E-02,3.5178576E-02,0.034610,& + 0.034933,0.035268,0.035629,0.035993,& + 0.036361,0.036940,0.037728,0.038633,& + 0.039955,0.041303,0.042877,0.044563,& + 0.046555,0.048089,0.049924,0.052937,& + 0.056136, 0.059363, 0.062810, & + 0.064494, 0.065790, 0.069328, 0.074218, & + 0.086511, 0.100520, 0.117374, 0.182958 / + data (cmaq_bc9(4,4,k),k=1,34)& + /5*3.5000000E-02,3.5178576E-02,0.034610,& + 0.034933,0.035268,0.035629,0.035993,& + 0.036361,0.036940,0.037728,0.038633,& + 0.039955,0.041303,0.042877,0.044563,& + 0.046555,0.048089,0.049924,0.052937,& + 0.056136, 0.059363, 0.062810, & + 0.064494, 0.065790, 0.069328, 0.074218, & + 0.086511, 0.100520, 0.117374, 0.182958 / + +! for no3 + data ((cmaq_bc9(5,i,k),k=1,34),i=1,4)& + /136*0./ + +! for o1d + data ((cmaq_bc9(6,i,k),k=1,34),i=1,4)& + /136*0./ + +! for oh + data ((cmaq_bc9(7,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ho2 + data ((cmaq_bc9(8,i,k),k=1,34),i=1,4)& + /136*0./ + +! for n2o5 + data ((cmaq_bc9(9,i,k),k=1,34),i=1,4)& + /136*0./ + +! for hno3 + data (cmaq_bc9(10,1,k),k=1,34)& + /25*4.9999999E-05,3*9.9999997E-05,1.2500001E-04,5*1.5000001E-04/ + data (cmaq_bc9(10,2,k),k=1,34)& + /25*4.9999999E-05,3*9.9999997E-05,1.2500001E-04,5*1.5000001E-04/ + data (cmaq_bc9(10,3,k),k=1,34)& + /18*4.9999999E-05,2*5.1851850E-05, 5.5370372E-05,& + 5.8888891E-05, 6.3518521E-05, 2*6.8148147E-05,& + 3*8.5000000E-05,9.2499999E-05,5*9.9999997E-05/ + data (cmaq_bc9(10,4,k),k=1,34)& + /18*4.9999999E-05,2*5.1851850E-05, 5.5370372E-05,& + 5.8888891E-05, 6.3518521E-05, 2*6.8148147E-05,& + 3*8.5000000E-05,9.2499999E-05,5*9.9999997E-05/ + +! for hono + data ((cmaq_bc9(11,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for pna + data ((cmaq_bc9(12,i,k),k=1,34),i=1,4)& + /136*1.9999999E-09/ + +! for h2o2 + data (cmaq_bc9(13,1,k),k=1,34)& + /18*2.0000001E-03,2*1.9537040E-03, 1.8657411E-03,& + 1.7777780E-03, 1.6620370E-03, 1.5462959E-03, & + 1.5462959E-03, 1.2500000E-03, 1.2500000E-03, & + 1.2500000E-03, 1.1250000E-03, 5*1.0000000E-03/ + data (cmaq_bc9(13,2,k),k=1,34)& + /18*2.0000001E-03,2*1.9537040E-03, 1.8657411E-03,& + 1.7777780E-03, 1.6620370E-03, 1.5462959E-03, & + 1.5462959E-03, 1.2500000E-03, 1.2500000E-03, & + 1.2500000E-03, 1.1250000E-03, 5*1.0000000E-03/ + data (cmaq_bc9(13,3,k),k=1,34)& + /5*1.0000000E-03, 1.0178576E-03,1.0357150E-03,& + 1.1250004E-03,1.2142860E-03,1.2142860E-03,3*1.5000000E-03,& + 2*1.3333330E-03,3*1.1515151E-03,2*9.8148151E-04,& + 9.4629632E-04,9.1111113E-04,8.6481485E-04,2*8.1851851E-04,& + 3*5.0000002E-04, 3.5000002E-04,5*1.9999999E-04/ + data (cmaq_bc9(13,4,k),k=1,34)& + /5*1.0000000E-03, 1.0178576E-03,1.0357150E-03,& + 1.1250004E-03,1.2142860E-03,1.2142860E-03,3*1.5000000E-03,& + 2*1.3333330E-03,3*1.1515151E-03,2*9.8148151E-04,& + 9.4629632E-04,9.1111113E-04,8.6481485E-04,2*8.1851851E-04,& + 3*5.0000002E-04, 3.5000002E-04,5*1.9999999E-04/ + +! for xo2 + data ((cmaq_bc9(14,i,k),k=1,34),i=1,4)& + /136*0./ + +! for xo2n + data ((cmaq_bc9(15,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ntr + data ((cmaq_bc9(16,i,k),k=1,34),i=1,4)& + /136*0./ + +! for rooh + data ((cmaq_bc9(17,i,k),k=1,34),i=1,4)& + /136*0./ + +! for form + data ((cmaq_bc9(18,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ald2 + data ((cmaq_bc9(19,i,k),k=1,34),i=1,4)& + /136*0./ + +! for aldx + data ((cmaq_bc9(20,i,k),k=1,34),i=1,4)& + /136*0./ + +! for par + data ((cmaq_bc9(21,i,k),k=1,34),i=1,4)& + /136*0./ + +! for co + data (cmaq_bc9(22,1,k),k=1,34)& + /18*7.0000000E-02,2*6.9537044E-02,6.8657413E-02,& + 6.7777783E-02,6.6620372E-02,2*6.5462962E-02,& + 3*5.9999999E-02,5.7499997E-02,5*5.5000000E-02/ + data (cmaq_bc9(22,2,k),k=1,34)& + /13*7.9999998E-02,2*7.8333333E-02,3*7.6515153E-02,& + 2*7.4537039E-02, 7.3657408E-02, 7.2777778E-02,7.1620367E-02,& + 7.0462957E-02, 7.0462957E-02, 6.7500003E-02, 6.7500003E-02,& + 6.7500003E-02, 6.6249996E-02, 5*6.4999998E-02/ + data (cmaq_bc9(22,3,k),k=1,34)& + /13*7.9999998E-02,2*7.6666668E-02,3*7.3030300E-02,& + 2*6.9537044E-02,6.8657413E-02,6.7777783E-02,6.6620372E-02,& + 6.5462962E-02, 6.5462962E-02, 5.7500001E-02, 5.7500001E-02,& + 5.7500001E-02, 5.3750001E-02, 5*5.0000001E-02/ + data (cmaq_bc9(22,4,k),k=1,34)& + /13*7.9999998E-02,2*7.6666668E-02,3*7.3030300E-02,& + 2*6.9537044E-02,6.8657413E-02,6.7777783E-02,6.6620372E-02,& + 6.5462962E-02, 6.5462962E-02, 5.7500001E-02, 5.7500001E-02,& + 5.7500001E-02, 5.3750001E-02, 5*5.0000001E-02/ + +! for meo2 + data ((cmaq_bc9(23,i,k),k=1,34),i=1,4)& + /136*0./ + +! for mepx + data (cmaq_bc9(24,1,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07, & + 2*1.9537040E-07,1.8657411E-07,1.7777781E-07,1.6620371E-07,& + 2*1.5462960E-07,3*1.2500000E-07,1.1250000E-07,& + 5*1.0000000E-07/ + data (cmaq_bc9(24,2,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07, & + 2*1.9537040E-07,1.8657411E-07,1.7777781E-07,1.6620371E-07,& + 2*1.5462960E-07,3*1.2500000E-07,1.1250000E-07,& + 5*1.0000000E-07/ + data (cmaq_bc9(24,3,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,1.3240745E-07,& + 1.0925930E-07,1.0925930E-07,3*7.5000003E-08,6.2500000E-08,& + 5*5.0000001E-08/ + data (cmaq_bc9(24,4,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,1.3240745E-07,& + 1.0925930E-07,1.0925930E-07,3*7.5000003E-08,6.2500000E-08,& + 5*5.0000001E-08/ + +! for meoh + data ((cmaq_bc9(25,i,k),k=1,34),i=1,4)& + /136*0./ + +! for hco3 + data ((cmaq_bc9(26,i,k),k=1,34),i=1,4)& + /136*0./ + +! for facd + data (cmaq_bc9(27,1,k),k=1,34)& + /2*1.5000001E-06,1.3571430E-06,1.1428572E-06,& + 9.2857141E-07,7.1428570E-07,28*5.0000000E-07/ + data (cmaq_bc9(27,2,k),k=1,34)& + /2*1.5000001E-06,1.3571430E-06,1.1428572E-06,& + 9.2857141E-07,7.1428570E-07,28*5.0000000E-07/ + data (cmaq_bc9(27,3,k),k=1,34)& + /5*1.0000000E-06,9.8214264E-07,9.6428539E-07,& + 8.7499978E-07,7.8571418E-07,7.8571418E-07,& + 15*5.0000000E-07,3*2.5000000E-07,1.2500000E-07,& + 5*0./ + data (cmaq_bc9(27,4,k),k=1,34)& + /5*1.0000000E-06,9.8214264E-07,9.6428539E-07,& + 8.7499978E-07,7.8571418E-07,7.8571418E-07,& + 15*5.0000000E-07,3*2.5000000E-07,1.2500000E-07,& + 5*0./ + +! for c2o3 + data ((cmaq_bc9(28,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for pan + data ((cmaq_bc9(29,i,k),k=1,34),i=1,2)& + /68*1.5000000E-05/ + data (cmaq_bc9(29,3,k),k=1,34)& + /5*9.9999997E-05,9.8214266E-05,9.6428543E-05,& + 8.7499982E-05,7.8571422E-05,7.8571422E-05,8*4.9999999E-05,& + 2*4.6759251E-05, 4.0601852E-05,3.4444449E-05,2.6342594E-05,& + 2*1.8240740E-05, 3*7.4999998E-06,3.7499999E-06,5*0./ + data (cmaq_bc9(29,4,k),k=1,34)& + /5*9.9999997E-05,9.8214266E-05,9.6428543E-05,& + 8.7499982E-05,7.8571422E-05,7.8571422E-05,8*4.9999999E-05,& + 2*4.6759251E-05, 4.0601852E-05,3.4444449E-05,2.6342594E-05,& + 2*1.8240740E-05, 3*7.4999998E-06,3.7499999E-06,5*0./ + +! for pacd + data (cmaq_bc9(30,1,k),k=1,34)& + /18*9.9999997E-05,2*9.5370357E-05,8.6574073E-05,& + 7.7777782E-05,6.6203706E-05,5.4629629E-05,5.4629629E-05,& + 9*4.9999999E-05/ + data (cmaq_bc9(30,2,k),k=1,34)& + /34*4.9999999E-05/ + data (cmaq_bc9(30,3,k),k=1,34)& + /13*2.9999999E-05,2*2.8333330E-05,3*2.6515150E-05,& + 2*2.4537039E-05,2.3657409E-05,2.2777780E-05,2.1620370E-05,& + 2*2.0462960E-05, 3*1.7500000E-05,1.6250000E-05,5*1.5000000E-05/ + data (cmaq_bc9(30,4,k),k=1,34)& + /13*2.9999999E-05,2*2.8333330E-05,3*2.6515150E-05,& + 2*2.4537039E-05,2.3657409E-05,2.2777780E-05,2.1620370E-05,& + 2*2.0462960E-05, 3*1.7500000E-05,1.6250000E-05,5*1.5000000E-05/ + +! for aacd + data (cmaq_bc9(31,1,k),k=1,34)& + /2*1.5000001E-06, 1.3571430E-06,1.1428572E-06,9.2857141E-07,& + 7.1428570E-07, 28*5.0000000E-07/ + data (cmaq_bc9(31,2,k),k=1,34)& + /2*1.5000001E-06, 1.3571430E-06,1.1428572E-06,9.2857141E-07,& + 7.1428570E-07, 28*5.0000000E-07/ + data (cmaq_bc9(31,3,k),k=1,34)& + /5*1.0000000E-06,9.8214264E-07,9.6428539E-07,& + 8.7499978E-07,7.8571418E-07,7.8571418E-07,15*5.0000000E-07,& + 3*2.5000000E-07,1.2500000E-07,5*0/ + data (cmaq_bc9(31,4,k),k=1,34)& + /5*1.0000000E-06,9.8214264E-07,9.6428539E-07,& + 8.7499978E-07,7.8571418E-07,7.8571418E-07,15*5.0000000E-07,& + 3*2.5000000E-07,1.2500000E-07,5*0/ + +! for cxo3 + data ((cmaq_bc9(32,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for panx + data ((cmaq_bc9(33,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for ror + data ((cmaq_bc9(34,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ole + data ((cmaq_bc9(35,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(35,3,k),k=1,34)& + /5*2.0000000E-07,1.9642854E-07,1.9285710E-07,& + 1.7499994E-07,2*1.5714279E-07,3*1.0000000E-07,2*6.6666693E-08,& + 3*3.0303010E-08,16*0./ + data (cmaq_bc9(35,4,k),k=1,34)& + /5*2.0000000E-07,1.9642854E-07,1.9285710E-07,& + 1.7499994E-07,2*1.5714279E-07,3*1.0000000E-07,2*6.6666693E-08,& + 3*3.0303010E-08,16*0./ + +! for eth + data ((cmaq_bc9(36,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(36,3,k),k=1,34)& + /2*4.9999999E-06, 4.7142862E-06,4.2857146E-06,& + 3.8571429E-06,3.3928568E-06,2.9285709E-06,2.7499996E-06,& + 2*2.5714280E-06,3*2.0000000E-06,2*1.6666670E-06,3*1.3030300E-06,& + 7*1.0000000E-06, 3* 5.0000000E-07,2.5000000E-07,5*0./ + data (cmaq_bc9(36,4,k),k=1,34)& + /2*4.9999999E-06, 4.7142862E-06,4.2857146E-06,& + 3.8571429E-06,3.3928568E-06,2.9285709E-06,2.7499996E-06,& + 2*2.5714280E-06,3*2.0000000E-06,2*1.6666670E-06,3*1.3030300E-06,& + 7*1.0000000E-06, 3* 5.0000000E-07,2.5000000E-07,5*0./ + +! for iole + data ((cmaq_bc9(37,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(37,3,k),k=1,34)& + /5*1.0000000E-07,9.6428536E-08,9.2857071E-08,& + 7.4999960E-08,2*5.7142849E-08,24*0./ + data (cmaq_bc9(37,4,k),k=1,34)& + /5*1.0000000E-07,9.6428536E-08,9.2857071E-08,& + 7.4999960E-08,2*5.7142849E-08,24*0./ + +! for tol + data ((cmaq_bc9(38,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(38,3,k),k=1,34)& + /18*1.0000000E-06, 2*9.0740730E-07,& + 7.3148146E-07,5.5555557E-07,3.2407408E-07,& + 2*9.2592600E-08,9*0./ + data (cmaq_bc9(38,4,k),k=1,34)& + /18*1.0000000E-06, 2*9.0740730E-07,& + 7.3148146E-07,5.5555557E-07,3.2407408E-07,& + 2*9.2592600E-08,9*0./ + +! for cres + data ((cmaq_bc9(39,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for to2 + data ((cmaq_bc9(40,i,k),k=1,34),i=1,4)& + /136*9.9999997E-10/ + +! for tolaer1 + data ((cmaq_bc9(41,i,k),k=1,34),i=1,4)& + /136*0./ +! for tolaer2 + data ((cmaq_bc9(42,i,k),k=1,34),i=1,4)& + /136*0./ + +! for open + data (cmaq_bc9(43,1,k),k=1,34)& + /13*2.5000000E-07, 2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9537040E-07, 1.8657411E-07,1.7777781E-07,1.6620371E-07,& + 2*1.5462960E-07,3*1.2500000E-07,1.1250000E-07,5*1.0000000E-07/ + data (cmaq_bc9(43,2,k),k=1,34)& + /13*2.5000000E-07, 2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9537040E-07, 1.8657411E-07,1.7777781E-07,1.6620371E-07,& + 2*1.5462960E-07,3*1.2500000E-07,1.1250000E-07,5*1.0000000E-07/ + data (cmaq_bc9(43,3,k),k=1,34)& + / 13*2.5000000E-07, 2*2.3333330E-07,& + 3*2.1515150E-07, 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,& + 1.3240745E-07,2*1.0925930E-07,& + 3*7.5000003E-08, 6.2500000E-08, 5*5.0000001E-08/ + data (cmaq_bc9(43,4,k),k=1,34)& + / 13*2.5000000E-07, 2*2.3333330E-07,& + 3*2.1515150E-07, 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,& + 1.3240745E-07,2*1.0925930E-07,& + 3*7.5000003E-08, 6.2500000E-08, 5*5.0000001E-08/ + +! for cro + data ((cmaq_bc9(44,i,k),k=1,34),i=1,4)& + /136*0./ + +! for cslaer + data ((cmaq_bc9(45,i,k),k=1,34),i=1,4)& + /136*0./ + +! for mgly + data (cmaq_bc9(46,1,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9537040E-07, 1.8657411E-07, 1.7777781E-07, 1.6620371E-07,& + 2*1.5462960E-07, 3*1.2500000E-07,1.1250000E-07,5*1.0000000E-07/ + data (cmaq_bc9(46,2,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9537040E-07, 1.8657411E-07, 1.7777781E-07, 1.6620371E-07,& + 2*1.5462960E-07, 3*1.2500000E-07,1.1250000E-07,5*1.0000000E-07/ + data (cmaq_bc9(46,3,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,1.3240745E-07,& + 2*1.0925930E-07, 3*7.5000003E-08,6.2500000E-08,& + 5*5.0000001E-08 / + data (cmaq_bc9(46,4,k),k=1,34)& + /13*2.5000000E-07,2*2.3333330E-07,3*2.1515150E-07,& + 2*1.9074071E-07,1.7314815E-07,1.5555560E-07,1.3240745E-07,& + 2*1.0925930E-07, 3*7.5000003E-08,6.2500000E-08,& + 5*5.0000001E-08 / + +! for xyl + data ((cmaq_bc9(47,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(47,3,k),k=1,34)& + / 5*2.0000000E-07,1.9642854E-07,1.9285710E-07,& + 1.7499994E-07,2*1.5714279E-07,3*1.0000000E-07,& + 2*6.6666693E-08,3*3.0303010E-08, 16*0.0/ + data (cmaq_bc9(47,4,k),k=1,34)& + / 5*2.0000000E-07,1.9642854E-07,1.9285710E-07,& + 1.7499994E-07,2*1.5714279E-07,3*1.0000000E-07,& + 2*6.6666693E-08,3*3.0303010E-08, 16*0.0/ + +! for xylaer1 + data ((cmaq_bc9(48,i,k),k=1,34),i=1,4)& + /136*0./ + +! for xylaer2 + data ((cmaq_bc9(49,i,k),k=1,34),i=1,4)& + /136*0./ + +! for isop + data ((cmaq_bc9(50,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(50,3,k),k=1,34)& + /5*1.5000001E-04,1.4464281E-04,1.3928561E-04,& + 1.1249994E-04,2*8.5714273E-05,24*0./ + data (cmaq_bc9(50,4,k),k=1,34)& + /5*1.5000001E-04,1.4464281E-04,1.3928561E-04,& + 1.1249994E-04,2*8.5714273E-05,24*0./ + +! for ispd + data ((cmaq_bc9(51,i,k),k=1,34),i=1,4)& + /136*0./ + +! for isoaer1 + data ((cmaq_bc9(52,i,k),k=1,34),i=1,4)& + /136*0./ + +! for isoaer2 + data ((cmaq_bc9(53,i,k),k=1,34),i=1,4)& + /136*0./ + +! so2 + data ((cmaq_bc9(54,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(54,3,k),k=1,34)& + /2*3.0000001E-04,2.8571431E-04, 2.6428571E-04,& + 2.4285710E-04,2.1785710E-04,1.9285710E-04,& + 1.7499995E-04,2*1.5714280E-04,1.5714280E-04,8*9.9999997E-05,& + 2*9.2592578E-05,7.8518511E-05,6.4444437E-05,4.5925924E-05,& + 2*2.7407410E-05,3*1.5000000E-05,5*9.9999997E-06/ + data (cmaq_bc9(54,4,k),k=1,34)& + /2*3.0000001E-04,2.8571431E-04, 2.6428571E-04,& + 2.4285710E-04,2.1785710E-04,1.9285710E-04,& + 1.7499995E-04,2*1.5714280E-04,1.5714280E-04,8*9.9999997E-05,& + 2*9.2592578E-05,7.8518511E-05,6.4444437E-05,4.5925924E-05,& + 2*2.7407410E-05,3*1.5000000E-05,5*9.9999997E-06/ + +! sulf + data ((cmaq_bc9(55,i,k),k=1,34),i=1,4)& + /136*1.0000000E-30/ + +! sulfaer + data ((cmaq_bc9(56,i,k),k=1,34),i=1,4)& + /136*0./ + +! etoh + data ((cmaq_bc9(57,i,k),k=1,34),i=1,4)& + /136*0./ + +! etha + data (cmaq_bc9(58,1,k),k=1,34)& + /13*9.9999997E-05,2*8.9000008E-05,& + 3*7.6999990E-05,16*6.7000001E-05/ + data (cmaq_bc9(58,2,k),k=1,34)& + /13*9.9999997E-05,2*8.9000008E-05,& + 3*7.6999990E-05,2*6.3851847E-05,& + 5.7870369E-05,5.1888888E-05,4.4018518E-05,& + 2*3.6148151E-05,9*3.3000000E-05/ + data (cmaq_bc9(58,3,k),k=1,34)& + /5*9.9999997E-05,9.9285702E-05,9.8571407E-05,& + 9.4999989E-05,2*9.1428570E-05,3*7.9999998E-05,& + 2*6.3333340E-05, 3*4.5151501E-05,& + 2*2.8148141E-05, 2.4629626E-05, 2.1111109E-05,1.6481479E-05,& + 2*1.1851850E-05, 3*4.9999999E-06,2.4999999E-06,5*0./ + data (cmaq_bc9(58,4,k),k=1,34)& + /5*9.9999997E-05,9.9285702E-05,9.8571407E-05,& + 9.4999989E-05,2*9.1428570E-05,3*7.9999998E-05,& + 2*6.3333340E-05, 3*4.5151501E-05,& + 2*2.8148141E-05, 2.4629626E-05, 2.1111109E-05,1.6481479E-05,& + 2*1.1851850E-05, 3*4.9999999E-06,2.4999999E-06,5*0./ + +! for terp + data ((cmaq_bc9(59,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(59,3,k),k=1,34)& + / 5*3.7500002E-05,3.6160702E-05,3.4821402E-05,& + 2.8124985E-05, 2*2.1428570E-05,24*0./ + data (cmaq_bc9(59,4,k),k=1,34)& + / 5*3.7500002E-05,3.6160702E-05,3.4821402E-05,& + 2.8124985E-05, 2*2.1428570E-05,24*0./ + +! terpaer + data ((cmaq_bc9(60,i,k),k=1,34),i=1,4)& + /136*0./ + +! for hum + data ((cmaq_bc9(61,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(61,3,k),k=1,34)& + / 5*1.2412500662E-05,1.1969192362E-05,1.1525884062E-05,& + 0.9309370035E-05, 2*0.709285667E-05,24*0./ + data (cmaq_bc9(61,4,k),k=1,34)& + / 5*1.218262564974E-05,1.174752725874E-05,1.131242886774E-05,& + 0.913696387695E-05, 2*0.69614995359E-05,24*0./ + +! for humaer + data ((cmaq_bc9(62,i,k),k=1,34),i=1,4)& + /136*0./ + +! for lim + data ((cmaq_bc9(63,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(63,3,k),k=1,34)& + / 5*0.506250027E-05,0.488269477E-05,0.470088927E-05,& + 0.3796872975E-05, 2*0.289285695E-05,24*0./ + data (cmaq_bc9(63,4,k),k=1,34)& + / 5*0.3016087660858E-05,0.2908369101158E-05,0.2800650541458E-05,& + 0.2262064418565E-05, 2*0.172347845653E-05,24*0./ + +! for limaer1 + data ((cmaq_bc9(64,i,k),k=1,34),i=1,4)& + /136*0./ + +! for limaer2 + data ((cmaq_bc9(65,i,k),k=1,34),i=1,4)& + /136*0./ + +! for oci + data ((cmaq_bc9(66,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(66,3,k),k=1,34)& + / 5*0.8137500434E-05,0.7846872334E-05,0.7556244234E-05,& + 0.6103121745E-05, 2*0.464999969E-05,24*0./ + data (cmaq_bc9(66,4,k),k=1,34)& + / 5*0.6262500334E-05,0.6038837234E-05,0.5815174134E-05,& + 0.4696872495E-05, 2*0.357857119E-05,24*0./ + +! for ociaer1 + data ((cmaq_bc9(67,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ociaer2 + data ((cmaq_bc9(68,i,k),k=1,34),i=1,4)& + /136*0./ + +! for apin + data ((cmaq_bc9(69,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(69,3,k),k=1,34)& + / 5*0.331875E-05,0.3200222127E-05,0.3081694077E-05,& + 0.24890611725E-05, 2*0.1896428445E-05,24*0./ + data (cmaq_bc9(69,4,k),k=1,34)& + / 5*0.69192375E-05,0.6672119608126E-05,0.6425001347226E-05,& + 0.5189425357305E-05, 2*0.395384973641E-05,24*0./ + +! for apinaer1 + data ((cmaq_bc9(70,i,k),k=1,34),i=1,4)& + /136*0./ + +! for apinaer2 + data ((cmaq_bc9(71,i,k),k=1,34),i=1,4)& + /136*0./ + +! for apinaer3 + data ((cmaq_bc9(72,i,k),k=1,34),i=1,4)& + /136*0./ + +! for apinaer4 + data ((cmaq_bc9(73,i,k),k=1,34),i=1,4)& + /136*0./ + +! for bpin + data ((cmaq_bc9(74,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(74,3,k),k=1,34)& + / 5*0.2587500138E-05,0.2495088438E-05,0.2402676738E-05,& + 0.1940623965E-05, 2*0.147857133E-05,24*0./ + data (cmaq_bc9(74,4,k),k=1,34)& + / 5*0.85875E-05,0.8280800758E-05,0.7974101058E-05,& + 0.6440621565E-05, 2*0.490714253E-05,24*0./ + +! for bpinaer1 + data ((cmaq_bc9(75,i,k),k=1,34),i=1,4)& + /136*0./ + +! for bpinaer2 + data ((cmaq_bc9(76,i,k),k=1,34),i=1,4)& + /136*0./ + +! for bpinaer3 + data ((cmaq_bc9(77,i,k),k=1,34),i=1,4)& + /136*0./ + +! for bpinaer4 + data ((cmaq_bc9(78,i,k),k=1,34),i=1,4)& + /136*0./ + +! for bpinaer5 + data ((cmaq_bc9(79,i,k),k=1,34),i=1,4)& + /136*0./ + +! for ter + + data ((cmaq_bc9(80,i,k),k=1,34),i=1,2)& + /68*0./ + data (cmaq_bc9(80,3,k),k=1,34)& + / 5*0.5925000316E-05,0.5713390916E-05,0.5501781516E-05,& + 0.444374763E-05, 2*0.338571406E-05,24*0./ + data (cmaq_bc9(80,4,k),k=1,34)& + / 5*0.0532237528386E-05,0.0513228843486E-05,0.0494220158586E-05,& + 0.0399177912105E-05, 2*0.030413569401E-05,24*0./ + +! for teraer1 + data ((cmaq_bc9(81,i,k),k=1,34),i=1,4)& + /136*0./ + +! for teraer2 + data ((cmaq_bc9(82,i,k),k=1,34),i=1,4)& + /136*0./ + +! for alkh + data ((cmaq_bc9(83,i,k),k=1,34),i=1,4)& + /136*0./ + +! for alkhaer1 + data ((cmaq_bc9(84,i,k),k=1,34),i=1,4)& + /136*0./ + +! for pah + data ((cmaq_bc9(85,i,k),k=1,34),i=1,4)& + /136*0./ + +! for pahaer1 + data ((cmaq_bc9(86,i,k),k=1,34),i=1,4)& + /136*0./ + +! for pahaer2 + data ((cmaq_bc9(87,i,k),k=1,34),i=1,4)& + /136*0./ + +! for cvasoa1 + data ((cmaq_bc9(88,i,k),k=1,34),i=1,4)& + /136*0./ + +! for cvasoa2 + data ((cmaq_bc9(89,i,k),k=1,34),i=1,4)& + /136*0./ + +! for cvasoa3 + data ((cmaq_bc9(90,i,k),k=1,34),i=1,4)& + /136*0./ + +! for cvasoa4 + data ((cmaq_bc9(91,i,k),k=1,34),i=1,4)& + /136*0./ + +! for cvbsoa1 + data ((cmaq_bc9(92,i,k),k=1,34),i=1,4)& + /136*0./ +! for cvbsoa2 + data ((cmaq_bc9(93,i,k),k=1,34),i=1,4)& + /136*0./ +! for cvbsoa3 + data ((cmaq_bc9(94,i,k),k=1,34),i=1,4)& + /136*0./ +! for cvbsoa4 + data ((cmaq_bc9(95,i,k),k=1,34),i=1,4)& + /136*0./ + +! for h2 + data ((cmaq_bc9(96,i,k),k=1,34),i=1,4)& + /136*0.5/ + +! for ch4 + data ((cmaq_bc9(97,i,k),k=1,34),i=1,4)& + /136*1.7/ + +! for cl + data ((cmaq_bc9(98,i,k),k=1,34),i=1,4)& + /136*0./ + +! for hcl + data ((cmaq_bc9(99,i,k),k=1,34),i=1,4)& + /136*0./ + +! for fmcl + data ((cmaq_bc9(100,i,k),k=1,34),i=1,4)& + /136*0./ +! for hg0 + data ((cmaq_bc9(101,i,k),k=1,34),i=1,4)& + /136*0./ +! for hg2 + data ((cmaq_bc9(102,i,k),k=1,34),i=1,4)& + /136*0./ +! for hocl + data ((cmaq_bc9(103,i,k),k=1,34),i=1,4)& + /136*0./ +! for clo + data ((cmaq_bc9(104,i,k),k=1,34),i=1,4)& + /136*0./ +! for cl2 + data ((cmaq_bc9(105,i,k),k=1,34),i=1,4)& + /136*0./ +! for nh3 + data ((cmaq_bc9(106,i,k),k=1,34),i=1,4)& + /136*0./ + + if (id_bdy .eq. 1 ) then + chem_bv = cmaq_bc9(nch-1,1,kk) + elseif (id_bdy .eq. 2 ) then + chem_bv = cmaq_bc9(nch-1,3,kk) + elseif (id_bdy .eq. 3 ) then + chem_bv = cmaq_bc9(nch-1,4,kk) + elseif (id_bdy .eq. 4 ) then + chem_bv = cmaq_bc9(nch-1,2,kk) + endif + if (nch==98 .and. id_bdy.eq.1) then +! print*,"chem_bv=,",chem_bv +! print*, "calling cb05 BC 101 option!!!" + endif + return + end subroutine bdy_chem_value_cb05_vbs + diff --git a/wrfv2_fire/chem/module_chem_cup.F b/wrfv2_fire/chem/module_chem_cup.F new file mode 100644 index 00000000..4cc37186 --- /dev/null +++ b/wrfv2_fire/chem/module_chem_cup.F @@ -0,0 +1,3551 @@ +! *** changes needed involving soa +! +! include soa in calculation of oa_a_1to4_ic_cup and oa_cw_1to4_ic_cup +! +! account for soa hygroscopicity for droplet activation (??) + + +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for references and terms of use +!********************************************************************************** + +! file module_chem_cup.F + module module_chem_cup + + + implicit none + + + private + + public :: chem_cup_driver + + logical, parameter :: do_deep = .true. + + integer, parameter :: r4=4 + integer, parameter :: r8=8 + + integer, parameter :: mode_chemcup_timeinteg = 2 + ! when mode_chemcup_timeinteg = 1, simulate the entire cumulus cloud fraction + ! with multiple time substeps of dt = dtstepc + ! when mode_chemcup_timeinteg = 2, simulate the entire cumulus cloud fraction + ! with a single timestep of dt = tcloud_cup, then set tcloud_cup negative + ! to signify that chem_cup calcs. are done for this cloud + ! + ! *** note 1 - mode_chemcup_timeinteg = 2 is recommended + ! *** note 2 - mode_chemcup_timeinteg = 1 may need lower values for the various ..._smallaa parameters + + real(r8), parameter :: cldfra_ls_testvalue = -0.5 + ! *** used for testing *** -- when cldfra_ls_testvalue >= 0.0, it overrides cldfra + real(r8), parameter :: wact_cup_testvalue = -0.1 + ! *** used for testing *** -- when wact_cup_testvalue > 0.0, it overrides wact_cup + + real(r8), parameter :: air_outflow_limit = 0.90_r8 + ! maximum faction of layer mass that can be transported out (to other layers) in a transport sub-time-step + + real(r8), parameter :: af_cucld_smallaa = 0.003_r8 ! "cutoff" value for cumulus cloud fractional area + real(r8), parameter :: af_cucld_maxaa = 0.8_r8 ! maximum value for cumulus cloud fractional area + +! subarea-average vertical mass fluxes (kg/m2/s) smaller than +! aw_up_smallaa*rhoair are treated as zero +! note that with a*w = 3e-5 m/s, dz over 1 hour = 0.11 m which is small + real(r8), parameter :: aw_up_smallaa = 3.0e-5_r8 ! m/s +! maximum expected updraft + real(r8), parameter :: w_up_maxaa = 50.0_r8 ! m/s +! updraft fractional areas below af_up_smallaa are ignored + real(r8), parameter :: af_up_smallaa = aw_up_smallaa/w_up_maxaa + + real(r8), parameter :: af_up_maxaa = 0.2_r8 ! maximum value for cumulus updraft fractional area + + real(r8), parameter :: qci_incu_smallaa = 1.0e-6_r8 ! "cutoff" value for in-cloud cloud-ice (kg/kg) + real(r8), parameter :: qci_inup_smallaa = 1.0e-6_r8 ! "cutoff" value for in-updraft cloud-ice (kg/kg) + real(r8), parameter :: qcw_incu_smallaa = 1.0e-6_r8 ! "cutoff" value for in-cloud cloud-water (kg/kg) + real(r8), parameter :: qcw_inup_smallaa = 1.0e-5_r8 ! "cutoff" value for in-updraft cloud-water (kg/kg) + + real(r8), parameter :: tau_active_smallaa = 30.0_r8 ! "cutoff" value for active cloud calculations (s) + real(r8), parameter :: tau_inactive_smallaa = 30.0_r8 ! "cutoff" value for inactive cloud calculations (s) + + + contains + + +!---------------------------------------------------------------------- + subroutine chem_cup_driver( & + grid_id, ktau, ktauc, dtstep, dtstepc, config_flags, & + t_phy, p_phy, rho_phy, alt, dz8w, zmid, z_at_w, & + moist, cldfra, ph_no2, & + chem, & + chem_cupflag, cupflag, shall, tcloud_cup, nca, wact_cup, & + cldfra_cup, updfra_cup, qc_ic_cup, qc_iu_cup, & + mfup_cup, mfup_ent_cup, mfdn_cup, mfdn_ent_cup, & + fcvt_qc_to_pr_cup, fcvt_qc_to_qi_cup, fcvt_qi_to_pr_cup, & + co_a_ic_cup, hno3_a_ic_cup, & + so4_a_1to4_ic_cup, so4_cw_1to4_ic_cup, & + nh4_a_1to4_ic_cup, nh4_cw_1to4_ic_cup, & + no3_a_1to4_ic_cup, no3_cw_1to4_ic_cup, & + oa_a_1to4_ic_cup, oa_cw_1to4_ic_cup, & + oin_a_1to4_ic_cup, oin_cw_1to4_ic_cup, & + bc_a_1to4_ic_cup, bc_cw_1to4_ic_cup, & + na_a_1to4_ic_cup, na_cw_1to4_ic_cup, & + cl_a_1to4_ic_cup, cl_cw_1to4_ic_cup, & + water_1to4_ic_cup, & + so4_a_5to6_ic_cup, so4_cw_5to6_ic_cup, & + nh4_a_5to6_ic_cup, nh4_cw_5to6_ic_cup, & + no3_a_5to6_ic_cup, no3_cw_5to6_ic_cup, & + oa_a_5to6_ic_cup, oa_cw_5to6_ic_cup, & + oin_a_5to6_ic_cup, oin_cw_5to6_ic_cup, & + bc_a_5to6_ic_cup, bc_cw_5to6_ic_cup, & + na_a_5to6_ic_cup, na_cw_5to6_ic_cup, & + cl_a_5to6_ic_cup, cl_cw_5to6_ic_cup, & + water_5to6_ic_cup, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! +! convective cloud processing (vertical transport, +! activation/resuspension, cloud chemistry, wet removal eventually) +! by **cup** convective clouds +! +! currently only works with following chem_opt packages +! CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ ) +! currently does not do wet removal +! + + use module_configure + use module_state_description + use module_model_constants + use module_scalar_tables, only: chem_dname_table + +!---------------------------------------------------------------------- +! arguments + + type(grid_config_rec_type), intent(in) :: config_flags + + integer, intent(in) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + integer, intent(in) :: & + grid_id, ktau, ktauc + + integer, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: & + chem_cupflag ! 1 if cupflag=.true. and chem_cup calcs were successful + ! -1 if cupflag=.true. and chem_cup calcs failed + ! 0 if cupflag=.false. + + real, intent(in) :: dtstep, dtstepc ! model and chemistry time-steps (s) + + real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: & + t_phy, & ! temp (K) + p_phy, & ! pressure (Pa) + rho_phy, & ! moist air density (kg/m3) + alt, & ! dry air 1/density (m3/kg) + dz8w, & ! layer thickness (m) + zmid, & ! height at layer center (m) + z_at_w, & ! height at layer boundary (m) + cldfra, & ! grid-resolved cloud fraction + ph_no2 ! no2 photolysis rate (1/s) + +! advected moisture variables + real, dimension( ims:ime, kms:kme, jms:jme, num_moist ), intent(in) :: & + moist + +! all advected chemical species + real, dimension( ims:ime, kms:kme, jms:jme, num_chem ), intent(inout) :: & + chem + + logical, dimension( ims:ime, jms:jme ), intent(in) :: & + cupflag ! .true. if cup convection is present in column + + real, dimension( ims:ime, jms:jme ), intent(in) :: & + nca, & ! time remaining for this cloud (s) + shall, & ! cumulus type: 0=deep, 1=shallow, 2=none + wact_cup ! vertical velocity for cloud-base aerosol activation (m/s) + + real, dimension( ims:ime, jms:jme ), intent(inout) :: & + tcloud_cup ! cumulus cloud duration (s) + + real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: & + cldfra_cup, & ! cumulus cloud fractional area (-) + updfra_cup, & ! cumulus updraft fractional area (-) + qc_ic_cup, & ! cloud-water in cumulus cloud (kg/kg) + qc_iu_cup, & ! cloud-water in updraft (kg/kg) + mfup_cup, & ! updraft mass-flux (kg/m2/s) + mfup_ent_cup, & ! updraft mass-flux change from entrainment (kg/m2/s) + mfdn_cup, & ! downdraft mass-flux (kg/m2/s) + mfdn_ent_cup, & ! downdraft mass-flux change from entrainment (kg/m2/s) + fcvt_qc_to_pr_cup, & ! fraction of cloud-water converted to precip as air move thru updraft layer (-) + fcvt_qc_to_qi_cup, & ! fraction of cloud-water converted to cloud-ice as air move thru updraft layer (-) + fcvt_qi_to_pr_cup ! fraction of cloud-ice converted to precip as air move thru updraft layer (-) + +! interstitial and cloudborne mixing ratios within the convective cloud, +! summed over size bins that the ams can see (Dp < 625 nm) + real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: & + co_a_ic_cup, hno3_a_ic_cup, & + so4_a_1to4_ic_cup, so4_cw_1to4_ic_cup, & + nh4_a_1to4_ic_cup, nh4_cw_1to4_ic_cup, & + no3_a_1to4_ic_cup, no3_cw_1to4_ic_cup, & + oa_a_1to4_ic_cup, oa_cw_1to4_ic_cup, & + oin_a_1to4_ic_cup, oin_cw_1to4_ic_cup, & + bc_a_1to4_ic_cup, bc_cw_1to4_ic_cup, & + na_a_1to4_ic_cup, na_cw_1to4_ic_cup, & + cl_a_1to4_ic_cup, cl_cw_1to4_ic_cup, & + water_1to4_ic_cup, & + so4_a_5to6_ic_cup, so4_cw_5to6_ic_cup, & + nh4_a_5to6_ic_cup, nh4_cw_5to6_ic_cup, & + no3_a_5to6_ic_cup, no3_cw_5to6_ic_cup, & + oa_a_5to6_ic_cup, oa_cw_5to6_ic_cup, & + oin_a_5to6_ic_cup, oin_cw_5to6_ic_cup, & + bc_a_5to6_ic_cup, bc_cw_5to6_ic_cup, & + na_a_5to6_ic_cup, na_cw_5to6_ic_cup, & + cl_a_5to6_ic_cup, cl_cw_5to6_ic_cup, & + water_5to6_ic_cup + + + +!----------------------------------------------------------------- +! local variables + integer :: iok + integer :: ii, jj, kk + + character(len=12) :: chem_name(num_chem) + +!----------------------------------------------------------------- + +! check for correct options + if ( config_flags%chem_conv_tr <= 0 .or. & + config_flags%cu_physics /= kfcupscheme ) then + call wrf_debug( 15, 'chem_cup_driver skipped because - ' // & + 'chem_conv_tr or cu_physics' ) + return + end if + + chem_name(1:num_chem) = chem_dname_table(grid_id,1:num_chem) + + + chem_opt_select: select case(config_flags%chem_opt) + + case ( CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP ) !BSINGH(12/11/13): Got rid of SAPRC99_MOSAIC_4BIN_VBS2_AQ_KPP pkg statement +!------------------------------------------------------------------------------- +! Below lines commented by Manish Shrivastava to skip CUP chemistry +!------------------------------------------------------------------------------ + call wrf_debug(15, & + 'chem_cup_driver calling mosaic_chem_cup_driver') + call mosaic_chem_cup_driver( & + grid_id, ktau, ktauc, dtstep, dtstepc, config_flags, & + t_phy, p_phy, rho_phy, alt, dz8w, zmid, z_at_w, & + moist, cldfra, ph_no2, & + chem, chem_name, & + chem_cupflag, cupflag, shall, tcloud_cup, nca, wact_cup, & + cldfra_cup, updfra_cup, qc_ic_cup, qc_iu_cup, & + mfup_cup, mfup_ent_cup, mfdn_cup, mfdn_ent_cup, & + fcvt_qc_to_pr_cup, fcvt_qc_to_qi_cup, fcvt_qi_to_pr_cup, & + co_a_ic_cup, hno3_a_ic_cup, & + so4_a_1to4_ic_cup, so4_cw_1to4_ic_cup, & + nh4_a_1to4_ic_cup, nh4_cw_1to4_ic_cup, & + no3_a_1to4_ic_cup, no3_cw_1to4_ic_cup, & + oa_a_1to4_ic_cup, oa_cw_1to4_ic_cup, & + oin_a_1to4_ic_cup, oin_cw_1to4_ic_cup, & + bc_a_1to4_ic_cup, bc_cw_1to4_ic_cup, & + na_a_1to4_ic_cup, na_cw_1to4_ic_cup, & + cl_a_1to4_ic_cup, cl_cw_1to4_ic_cup, & + water_1to4_ic_cup, & + so4_a_5to6_ic_cup, so4_cw_5to6_ic_cup, & + nh4_a_5to6_ic_cup, nh4_cw_5to6_ic_cup, & + no3_a_5to6_ic_cup, no3_cw_5to6_ic_cup, & + oa_a_5to6_ic_cup, oa_cw_5to6_ic_cup, & + oin_a_5to6_ic_cup, oin_cw_5to6_ic_cup, & + bc_a_5to6_ic_cup, bc_cw_5to6_ic_cup, & + na_a_5to6_ic_cup, na_cw_5to6_ic_cup, & + cl_a_5to6_ic_cup, cl_cw_5to6_ic_cup, & + water_5to6_ic_cup, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, kte+1 ) +!----------------------------------------------------------------------------------------- +! Above lines commented by Manish Shrivastava to skip CUP chemistry +!------------------------------------------------------------------------------------------- + case default + chem_cupflag = 0 + call wrf_debug( 15, 'chem_cup_driver skipped because - ' // & + 'chem_opt' ) + + end select chem_opt_select + + return + end subroutine chem_cup_driver + + +!---------------------------------------------------------------------- + subroutine mosaic_chem_cup_driver( & + grid_id, ktau, ktauc, dtstep, dtstepc, config_flags, & + t_phy, p_phy, rho_phy, alt, dz8w, zmid, z_at_w, & + moist, cldfra, ph_no2, & + chem, chem_name, & + chem_cupflag, cupflag, shall, tcloud_cup, nca, wact_cup, & + cldfra_cup, updfra_cup, qc_ic_cup, qc_iu_cup, & + mfup_cup, mfup_ent_cup, mfdn_cup, mfdn_ent_cup, & + fcvt_qc_to_pr_cup, fcvt_qc_to_qi_cup, fcvt_qi_to_pr_cup, & + co_a_ic_cup, hno3_a_ic_cup, & + so4_a_1to4_ic_cup, so4_cw_1to4_ic_cup, & + nh4_a_1to4_ic_cup, nh4_cw_1to4_ic_cup, & + no3_a_1to4_ic_cup, no3_cw_1to4_ic_cup, & + oa_a_1to4_ic_cup, oa_cw_1to4_ic_cup, & + oin_a_1to4_ic_cup, oin_cw_1to4_ic_cup, & + bc_a_1to4_ic_cup, bc_cw_1to4_ic_cup, & + na_a_1to4_ic_cup, na_cw_1to4_ic_cup, & + cl_a_1to4_ic_cup, cl_cw_1to4_ic_cup, & + water_1to4_ic_cup, & + so4_a_5to6_ic_cup, so4_cw_5to6_ic_cup, & + nh4_a_5to6_ic_cup, nh4_cw_5to6_ic_cup, & + no3_a_5to6_ic_cup, no3_cw_5to6_ic_cup, & + oa_a_5to6_ic_cup, oa_cw_5to6_ic_cup, & + oin_a_5to6_ic_cup, oin_cw_5to6_ic_cup, & + bc_a_5to6_ic_cup, bc_cw_5to6_ic_cup, & + na_a_5to6_ic_cup, na_cw_5to6_ic_cup, & + cl_a_5to6_ic_cup, cl_cw_5to6_ic_cup, & + water_5to6_ic_cup, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, ktep1 ) + +! wet removal by grid-resolved precipitation +! scavenging of cloud-phase aerosols and gases by collection, freezing, ... +! scavenging of interstitial-phase aerosols by impaction +! scavenging of gas-phase gases by mass transfer and reaction + + use module_configure + use module_state_description + use module_model_constants + + use module_data_mosaic_asect, only: & + dcen_sect, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nphase_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, msectional, & + massptr_aer, numptr_aer, & + lptr_cl_aer, lptr_na_aer, lptr_nh4_aer, lptr_no3_aer, & + lptr_oc_aer, lptr_oin_aer, lptr_so4_aer, lptr_bc_aer, & + lptr_pcg1_b_c_aer,lptr_pcg1_b_o_aer,lptr_opcg1_b_c_aer, & + lptr_opcg1_b_o_aer,lptr_pcg1_f_c_aer,lptr_pcg1_f_o_aer, & + lptr_opcg1_f_c_aer, lptr_opcg1_f_o_aer, lptr_ant1_c_aer, & + lptr_biog1_c_aer, waterptr_aer, & + dlo_sect, dhi_sect, dens_aer, hygro_aer, sigmag_aer + +!---------------------------------------------------------------------- +! arguments + + type(grid_config_rec_type), intent(in) :: config_flags + + integer, intent(in) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, ktep1 + + integer, intent(in) :: & + grid_id, ktau, ktauc + + integer, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: & + chem_cupflag + + real, intent(in) :: dtstep, dtstepc ! model and chemistry time-steps (s) + + real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: & + t_phy, & ! temp (K) + p_phy, & ! pressure (Pa) + rho_phy, & ! moist air density (kg/m3) + alt, & ! dry air 1/density (m3/kg) + dz8w, & ! layer thickness (m) + zmid, & ! height at layer center (m) + z_at_w, & ! height at layer boundary (m) + cldfra, & ! grid-resolved cloud fraction + ph_no2 ! no2 photolysis rate (1/s) + +! advected moisture variables + real, dimension( ims:ime, kms:kme, jms:jme, num_moist ), intent(in) :: & + moist + +! all advected chemical species + real, dimension( ims:ime, kms:kme, jms:jme, num_chem ), intent(inout) :: & + chem + +! interstitial and cloudborne mixing ratios within the convective cloud, +! summed over size bins that the ams can see (Dp < 625 nm) + real, dimension( ims:ime, kms:kme, jms:jme ), intent(out) :: & + co_a_ic_cup, hno3_a_ic_cup, & + so4_a_1to4_ic_cup, so4_cw_1to4_ic_cup, & + nh4_a_1to4_ic_cup, nh4_cw_1to4_ic_cup, & + no3_a_1to4_ic_cup, no3_cw_1to4_ic_cup, & + oa_a_1to4_ic_cup, oa_cw_1to4_ic_cup, & + oin_a_1to4_ic_cup, oin_cw_1to4_ic_cup, & + bc_a_1to4_ic_cup, bc_cw_1to4_ic_cup, & + na_a_1to4_ic_cup, na_cw_1to4_ic_cup, & + cl_a_1to4_ic_cup, cl_cw_1to4_ic_cup, & + water_1to4_ic_cup, & + so4_a_5to6_ic_cup, so4_cw_5to6_ic_cup, & + nh4_a_5to6_ic_cup, nh4_cw_5to6_ic_cup, & + no3_a_5to6_ic_cup, no3_cw_5to6_ic_cup, & + oa_a_5to6_ic_cup, oa_cw_5to6_ic_cup, & + oin_a_5to6_ic_cup, oin_cw_5to6_ic_cup, & + bc_a_5to6_ic_cup, bc_cw_5to6_ic_cup, & + na_a_5to6_ic_cup, na_cw_5to6_ic_cup, & + cl_a_5to6_ic_cup, cl_cw_5to6_ic_cup, & + water_5to6_ic_cup + + + character(len=12), intent(in) :: chem_name(num_chem) + + + logical, dimension( ims:ime, jms:jme ), intent(in) :: & + cupflag ! .true. if cup convection is present in column + + real, dimension( ims:ime, jms:jme ), intent(in) :: & + nca, & ! time remaining for this cloud (s) + shall, & ! cumulus type: 0=deep, 1=shallow, 2=none + wact_cup ! vertical velocity for cloud-base aerosol activation (m/s) + + real, dimension( ims:ime, jms:jme ), intent(inout) :: & + tcloud_cup ! cumulus cloud duration (s) + + real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: & + cldfra_cup, & ! cumulus cloud fractional area (-) + updfra_cup, & ! cumulus updraft fractional area (-) + qc_ic_cup, & ! cloud-water in cumulus cloud (kg/kg) + qc_iu_cup, & ! cloud-water in updraft (kg/kg) + mfup_cup, & ! updraft mass-flux (kg/m2/s) + mfup_ent_cup, & ! updraft mass-flux change from entrainment (kg/m2/s) + mfdn_cup, & ! downdraft mass-flux (kg/m2/s) + mfdn_ent_cup, & ! downdraft mass-flux change from entrainment (kg/m2/s) + fcvt_qc_to_pr_cup, & ! fraction of cloud-water converted to precip as air move thru updraft layer (-) + fcvt_qc_to_qi_cup, & ! fraction of cloud-water converted to cloud-ice as air move thru updraft layer (-) + fcvt_qi_to_pr_cup ! fraction of cloud-ice converted to precip as air move thru updraft layer (-) + +!----------------------------------------------------------------- +! local variables + integer :: aer_mech_id + integer :: chem_cupflag_1d(kts:kte) + integer :: i, icalcflagaa, idiagee, idiagff, ishall, isize, itype + integer :: j + integer :: k, kcldbot_1d, kcldtop_1d + integer :: lundiag, lunerr + + real(r8) :: chem_1d(kts:kte,num_chem) + real(r8) :: chem_incu(kts:kte,num_chem) + real(r8) :: cldfra_ls_1d(kts:kte) + real(r8) :: cldfra_cup_1d(kts:kte) + real(r8) :: dz_1d(kts:kte) + real(r8) :: fcvt_qc_to_pr_cup_1d(kts:kte) + real(r8) :: fcvt_qc_to_qi_cup_1d(kts:kte) + real(r8) :: fcvt_qi_to_pr_cup_1d(kts:kte) + real(r8) :: mfup_cup_1d(kts:ktep1) + real(r8) :: mfup_ent_cup_1d(kts:kte) + real(r8) :: mfdn_cup_1d(kts:ktep1) + real(r8) :: mfdn_ent_cup_1d(kts:kte) + real(r8) :: pcen_1d(kts:kte) + real(r8) :: ph_no2_1d(kts:kte) + real(r8) :: qc_ic_cup_1d(kts:kte) + real(r8) :: qc_iu_cup_1d(kts:kte) + real(r8) :: qi_ic_cup_1d(kts:kte) + real(r8) :: qi_iu_cup_1d(kts:kte) + real(r8) :: rhocen_1d(kts:kte) + real(r8) :: tcloud_cup_1d + real(r8) :: tcen_1d(kts:kte) + real(r8) :: tmpa + real(r8) :: updfra_cup_1d(kts:kte) + real(r8) :: wact_cup_1d + real(r8) :: zbnd_1d(kts:ktep1) + real(r8) :: zcen_1d(kts:kte) + + +!----------------------------------------------------------------- + + lunerr = 6 + lundiag = 6 + lundiag = 121 + + idiagff = 0 ; idiagee = 0 + if ((ide-ids <= 3) .and. (jde-jds <= 3)) then + idiagff = 1 ! turn on diagnostics for single column runs +! idiagff = 0 ! (do this to turn off extra diagnostics) + end if + + aer_mech_id = 3 + + if (ktau <= 1) then + write(*,'(a)') + write(*,'(2a,1p,4e12.4)') 'chemcup_control -- ', & + 'cldfra_ls_testvalue, wact_cup_testvalue ', & + cldfra_ls_testvalue, wact_cup_testvalue + write(*,'(2a,1p,4e12.4)') 'chemcup_control -- ', & + 'air_outflow_limit ', & + air_outflow_limit + write(*,'(2a,1p,4e12.4)') 'chemcup_control -- ', & + 'af_cucld_smallaa, af_cucld_maxaa ', & + af_cucld_smallaa, af_cucld_maxaa + write(*,'(2a,1p,4e12.4)') 'chemcup_control -- ', & + 'aw_up_smallaa, w_up_maxaa ', & + aw_up_smallaa, w_up_maxaa + write(*,'(2a,1p,4e12.4)') 'chemcup_control -- ', & + 'af_up_smallaa, af_up_maxaa ', & + af_up_smallaa, af_up_maxaa + write(*,'(2a,1p,4e12.4)') 'chemcup_control -- ', & + 'qci_incu_smallaa, qci_inup_smallaa ', & + qci_incu_smallaa, qci_inup_smallaa + write(*,'(2a,1p,4e12.4)') 'chemcup_control -- ', & + 'qcw_incu_smallaa, qcw_inup_smallaa ', & + qcw_incu_smallaa, qcw_inup_smallaa + write(*,'(2a,1p,4e12.4)') 'chemcup_control -- ', & + 'tau_active_smallaa, tau_inactive_smallaa ', & + tau_active_smallaa, tau_inactive_smallaa + write(*,'(a,2i5/(a,3(i9,i5)))') & + 'chemcup_control -- grid_id, ktau', grid_id, ktau, & + 'chemcup_control -- d indices', ids,ide, jds,jde, kds,kde, & + 'chemcup_control -- m indices', ims,ime, jms,jme, kms,kme, & + 'chemcup_control -- e indices', its,ite, jts,jte, kts,kte + write(*,'(a)') + end if + + +! loop over grid columns and do chem_cup where shall = 1 (shallow cu) or 2 (deep) +main_j_loop: & + do j = jts, jte +main_i_loop: & + do i = its, ite + + idiagee = 0 + if (idiagff > 0) then + ! turn on diagnostics at i=j=1 for single column runs + if (i==its .and. j==jts) idiagee = 1 + end if + + if (idiagee > 0) write(*,'(a,i7,l5,i5,20x,4f10.1)') & + 'chcup_a20 ktau, cupflag, ishall, tcloud, nca dtc', & + ktau, cupflag(i,j), nint(shall(i,j)), tcloud_cup(i,j), nca(i,j), dtstepc + + + ! icalcflagaa > 0 if chem_cup calculations will be done for current i,j and timestep + icalcflagaa = 0 + if (abs(shall(i,j)-1.0) < 0.1) then + ishall = 1 + icalcflagaa = 1 + else if (abs(shall(i,j)) < 0.1) then + ishall = 0 + if ( do_deep ) icalcflagaa = 1 + end if + ! no calculations if cloud has "expired" + if (nca(i,j) < 0.01) icalcflagaa = 0 + ! no calculations if cloud lifetime is too small + if (abs(tcloud_cup(i,j)) < tau_active_smallaa) icalcflagaa = 0 + + ! also no calculations when mode_chemcup_timeinteg=2 and the "one time only" + ! calculations have already been done (indicated by tcloud_cup < 0) + if (icalcflagaa > 0) then + if (mode_chemcup_timeinteg == 2 .and. tcloud_cup(i,j) <= 0.0) then + icalcflagaa = -1 + end if + end if + + if (icalcflagaa >= 0) then + ! zero out these history variables at current i,j except when icalcflagaa = -1 + chem_cupflag(i,:,j) = 0 + co_a_ic_cup(i,:,j) = 0.0 ; hno3_a_ic_cup(i,:,j) = 0.0 + so4_a_1to4_ic_cup(i,:,j) = 0.0 ; so4_cw_1to4_ic_cup(i,:,j) = 0.0 + nh4_a_1to4_ic_cup(i,:,j) = 0.0 ; nh4_cw_1to4_ic_cup(i,:,j) = 0.0 + no3_a_1to4_ic_cup(i,:,j) = 0.0 ; no3_cw_1to4_ic_cup(i,:,j) = 0.0 + oa_a_1to4_ic_cup (i,:,j) = 0.0 ; oa_cw_1to4_ic_cup(i,:,j) = 0.0 + oin_a_1to4_ic_cup (i,:,j) = 0.0 ; oin_cw_1to4_ic_cup(i,:,j) = 0.0 + bc_a_1to4_ic_cup (i,:,j) = 0.0 ; bc_cw_1to4_ic_cup(i,:,j) = 0.0 + na_a_1to4_ic_cup (i,:,j) = 0.0 ; na_cw_1to4_ic_cup(i,:,j) = 0.0 + cl_a_1to4_ic_cup (i,:,j) = 0.0 ; cl_cw_1to4_ic_cup(i,:,j) = 0.0 + water_1to4_ic_cup (i,:,j) = 0.0 + so4_a_5to6_ic_cup(i,:,j) = 0.0 ; so4_cw_5to6_ic_cup(i,:,j) = 0.0 + nh4_a_5to6_ic_cup(i,:,j) = 0.0 ; nh4_cw_5to6_ic_cup(i,:,j) = 0.0 + no3_a_5to6_ic_cup(i,:,j) = 0.0 ; no3_cw_5to6_ic_cup(i,:,j) = 0.0 + oa_a_5to6_ic_cup (i,:,j) = 0.0 ; oa_cw_5to6_ic_cup(i,:,j) = 0.0 + oin_a_5to6_ic_cup (i,:,j) = 0.0 ; oin_cw_5to6_ic_cup(i,:,j) = 0.0 + bc_a_5to6_ic_cup (i,:,j) = 0.0 ; bc_cw_5to6_ic_cup(i,:,j) = 0.0 + na_a_5to6_ic_cup (i,:,j) = 0.0 ; na_cw_5to6_ic_cup(i,:,j) = 0.0 + cl_a_5to6_ic_cup (i,:,j) = 0.0 ; cl_cw_5to6_ic_cup(i,:,j) = 0.0 + water_5to6_ic_cup (i,:,j) = 0.0 + + end if + + if (icalcflagaa <= 0) cycle main_i_loop + + + write(*,'(/a,i10,4i5)') & + 'mosaic_chem_cup_driver doing ktau, id, i, j, ishall =', ktau, grid_id, i, j, ishall + + chem_cupflag_1d(kts:kte) = chem_cupflag(i,kts:kte,j) + + chem_1d(kts:kte,1:num_chem) = chem(i,kts:kte,j,1:num_chem) + + cldfra_ls_1d(kts:kte) = cldfra(i,kts:kte,j) + dz_1d(kts:kte) = dz8w(i,kts:kte,j) + pcen_1d(kts:kte) = p_phy(i,kts:kte,j) + ph_no2_1d(kts:kte) = ph_no2(i,kts:kte,j) + rhocen_1d(kts:kte) = 1.0_r8/alt(i,kts:kte,j) + tcen_1d(kts:kte) = t_phy(i,kts:kte,j) + zbnd_1d(kts:ktep1) = z_at_w(i,kts:ktep1,j) + zcen_1d(kts:kte) = zmid(i,kts:kte,j) + + qc_ic_cup_1d(kts:kte) = qc_ic_cup(i,kts:kte,j) + qc_iu_cup_1d(kts:kte) = qc_iu_cup(i,kts:kte,j) + qi_ic_cup_1d(kts:kte) = 0.0_r8 + qi_iu_cup_1d(kts:kte) = 0.0_r8 + wact_cup_1d = wact_cup(i,j) + + fcvt_qc_to_pr_cup_1d(kts:kte) = fcvt_qc_to_pr_cup(i,kts:kte,j) + fcvt_qc_to_qi_cup_1d(kts:kte) = fcvt_qc_to_qi_cup(i,kts:kte,j) + fcvt_qi_to_pr_cup_1d(kts:kte) = fcvt_qi_to_pr_cup(i,kts:kte,j) + + if ( mode_chemcup_timeinteg == 1 ) then + ! simulate the entire cumulus cloud fraction using substeps of dt = dtstepc + ! also force dtsub <= nca+dtstep because tcloud_cup may not be an + ! integer multiple of dtstepc + ! use nca+dtstep because nca is decremented in phys before chem sees it + tcloud_cup_1d = min( nca(i,j)+dtstep, dtstepc ) + else if ( mode_chemcup_timeinteg == 2 ) then + ! simulate the entire cumulus cloud fraction in a "one time only" calculation + ! with dt = tcloud_cup + tcloud_cup_1d = tcloud_cup(i,j) + else + call wrf_error_fatal( & + '*** mosaic_chem_cup_driver -- bad value for mode_chemcup_timeinteg' ) + end if + cldfra_cup_1d(kts:kte) = cldfra_cup(i,kts:kte,j) + updfra_cup_1d(kts:kte) = updfra_cup(i,kts:kte,j) + mfup_cup_1d(kts:ktep1) = mfup_cup(i,kts:ktep1,j) + mfup_ent_cup_1d(kts:kte) = mfup_ent_cup(i,kts:kte,j) + mfdn_cup_1d(kts:ktep1) = mfdn_cup(i,kts:ktep1,j) + mfdn_ent_cup_1d(kts:kte) = mfdn_ent_cup(i,kts:kte,j) + + if (idiagee > 0) write(*,'(a,i6,l5,i5,20x,2f10.1)') & + 'chcup_a20 ktau, cupflag, ishall, tcloud, tcloud1d', & + ktau, cupflag(i,j), nint(shall(i,j)), tcloud_cup(i,j), tcloud_cup_1d + +! *** following are for testing + if (cldfra_ls_testvalue >= 0.0) & + cldfra_ls_1d(kts:kte) = max( 0.0, min( 1.0, cldfra_ls_testvalue ) ) + if (wact_cup_testvalue >= 0.0) & + wact_cup_1d = wact_cup_testvalue + + + kcldbot_1d = kts-1 + kcldtop_1d = kts-1 + do k = kts, kte + if (cldfra_cup_1d(k) > 0.0_r8) then + kcldtop_1d = k + if (kcldbot_1d < kts) kcldbot_1d = k + end if + end do + + +! subr. chem_cup_1d( & +! config_flags, aer_mech_id, & +! lundiag, lunerr, & +! kts, kte, ktep1, p1st, num_chem, num_moist, & +! ktau, grid_id, i, j, & +! ishall, kcldbot_inp, kcldtop_inp, & +! tau_active, tau_inactive, & +! dz, zcen, zbnd, pcen, tcen, rhocen, ph_no2, & +! af_lscld, af_cucld_inp, af_up_inp, & +! qcw_incu_inp, qci_incu_inp, & +! qcw_inup_inp, qci_inup_inp, & +! mf_up_inp, mf_up_ent_inp, & +! mf_dn_inp, mf_dn_ent_inp, & +! fcvt_qc_to_pr_inp, fcvt_qc_to_qi_inp, fcvt_qi_to_pr_inp, & +! wact_inp, & +! chem, chem_incu, chem_name, chem_cupflag, & +! maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & +! ncomp_aer, nphase_aer, nsize_aer, ntype_aer, & +! ai_phase, cw_phase, msectional, & +! massptr_aer, numptr_aer, & +! lptr_cl_aer, lptr_nh4_aer, lptr_no3_aer, lptr_oin_aer, lptr_so4_aer, & +! dlo_sect, dhi_sect, dens_aer, hygro_aer, sigmag_aer + + call chem_cup_1d( & + config_flags, aer_mech_id, & + lunerr, lundiag, idiagee, & + kts, kte, ktep1, param_first_scalar, num_chem, num_moist, & + ktau, grid_id, i, j, & + ishall, kcldbot_1d, kcldtop_1d, & + tcloud_cup_1d, tcloud_cup_1d, & + dz_1d, zcen_1d, zbnd_1d, pcen_1d, tcen_1d, rhocen_1d, ph_no2_1d, & + cldfra_ls_1d, cldfra_cup_1d, updfra_cup_1d, & + qc_ic_cup_1d, qi_ic_cup_1d, & + qc_iu_cup_1d, qi_iu_cup_1d, & + mfup_cup_1d, mfup_ent_cup_1d, & + mfdn_cup_1d, mfdn_ent_cup_1d, & + fcvt_qc_to_pr_cup_1d, fcvt_qc_to_qi_cup_1d, fcvt_qi_to_pr_cup_1d, & + wact_cup_1d, & + chem_1d, chem_incu, chem_name, chem_cupflag_1d, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nphase_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, msectional, & + massptr_aer, numptr_aer, & + lptr_cl_aer, lptr_nh4_aer, lptr_no3_aer, lptr_oin_aer, lptr_so4_aer, & + dlo_sect, dhi_sect, dens_aer, hygro_aer, sigmag_aer ) + + write(*,'(/a,4i10)') & + 'mosaic_chem_cup_driver back ktau, id, i, j =', ktau, grid_id, i, j + + chem_cupflag(i,kts:kte,j) = chem_cupflag_1d(kts:kte) + + chem(i,kts:kte,j,1:num_chem) = chem_1d(kts:kte,1:num_chem) + +! call wrf_error_fatal( 'aborting after first call to chem_cup_1d' ) +! if (ktau >= 465) call wrf_error_fatal( & +! 'aborting after call to chem_cup_1d and ktau>=465' ) + + if (mode_chemcup_timeinteg == 2) then + ! calculations for this cloud are totally finished + ! set tcloud_cup to a negative value to indicate this on next timestep + tcloud_cup(i,j) = -tcloud_cup(i,j) + end if + +! Do the gas variables co and hno3 here + do k = kcldbot_1d, kcldtop_1d + if (chem_cupflag(i,k,j) <= 0) cycle + co_a_ic_cup(i,k,j) = co_a_ic_cup(i,k,j) & + + chem_incu(k,p_co) + hno3_a_ic_cup(i,k,j) = hno3_a_ic_cup(i,k,j) & + + chem_incu(k,p_hno3) + enddo + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if (dcen_sect(isize,itype) .le. 0.625e-4) then + do k = kcldbot_1d, kcldtop_1d + if (chem_cupflag(i,k,j) <= 0) cycle + so4_a_1to4_ic_cup(i,k,j) = so4_a_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_so4_aer(isize,itype,ai_phase)) + so4_cw_1to4_ic_cup(i,k,j) = so4_cw_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_so4_aer(isize,itype,cw_phase)) + nh4_a_1to4_ic_cup(i,k,j) = nh4_a_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_nh4_aer(isize,itype,ai_phase)) + nh4_cw_1to4_ic_cup(i,k,j) = nh4_cw_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_nh4_aer(isize,itype,cw_phase)) + no3_a_1to4_ic_cup(i,k,j) = no3_a_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_no3_aer(isize,itype,ai_phase)) + no3_cw_1to4_ic_cup(i,k,j) = no3_cw_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_no3_aer(isize,itype,cw_phase)) + oa_a_1to4_ic_cup(i,k,j) = oa_a_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_oc_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_pcg1_b_c_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_pcg1_b_o_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_opcg1_b_c_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_opcg1_b_o_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_pcg1_f_c_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_pcg1_f_o_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_opcg1_f_c_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_opcg1_f_o_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_ant1_c_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_biog1_c_aer(isize,itype,ai_phase)) + + + oa_cw_1to4_ic_cup(i,k,j) = oa_cw_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_oc_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_pcg1_b_c_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_pcg1_b_o_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_opcg1_b_c_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_opcg1_b_o_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_pcg1_f_c_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_pcg1_f_o_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_opcg1_f_c_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_opcg1_f_o_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_ant1_c_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_biog1_c_aer(isize,itype,cw_phase)) + + oin_a_1to4_ic_cup(i,k,j) = oin_a_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_oin_aer(isize,itype,ai_phase)) + oin_cw_1to4_ic_cup(i,k,j) = oin_cw_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_oin_aer(isize,itype,cw_phase)) + + bc_a_1to4_ic_cup(i,k,j) = bc_a_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_bc_aer(isize,itype,ai_phase)) + bc_cw_1to4_ic_cup(i,k,j) = bc_cw_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_bc_aer(isize,itype,cw_phase)) + + na_a_1to4_ic_cup(i,k,j) = na_a_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_na_aer(isize,itype,ai_phase)) + na_cw_1to4_ic_cup(i,k,j) = na_cw_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_na_aer(isize,itype,cw_phase)) + + cl_a_1to4_ic_cup(i,k,j) = cl_a_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_cl_aer(isize,itype,ai_phase)) + cl_cw_1to4_ic_cup(i,k,j) = cl_cw_1to4_ic_cup(i,k,j) & + + chem_incu(k,lptr_cl_aer(isize,itype,cw_phase)) + + water_1to4_ic_cup(i,k,j) = water_1to4_ic_cup(i,k,j) & + + chem_incu(k,waterptr_aer(isize,itype)) + + end do ! k + + elseif (dcen_sect(isize,itype) .gt. 0.625e-4 .and. & + dcen_sect(isize,itype) .le. 2.5e-4) then + do k = kcldbot_1d, kcldtop_1d + if (chem_cupflag(i,k,j) <= 0) cycle + so4_a_5to6_ic_cup(i,k,j) = so4_a_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_so4_aer(isize,itype,ai_phase)) + so4_cw_5to6_ic_cup(i,k,j) = so4_cw_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_so4_aer(isize,itype,cw_phase)) + nh4_a_5to6_ic_cup(i,k,j) = nh4_a_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_nh4_aer(isize,itype,ai_phase)) + nh4_cw_5to6_ic_cup(i,k,j) = nh4_cw_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_nh4_aer(isize,itype,cw_phase)) + no3_a_5to6_ic_cup(i,k,j) = no3_a_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_no3_aer(isize,itype,ai_phase)) + no3_cw_5to6_ic_cup(i,k,j) = no3_cw_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_no3_aer(isize,itype,cw_phase)) + oa_a_5to6_ic_cup(i,k,j) = oa_a_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_oc_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_pcg1_b_c_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_pcg1_b_o_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_opcg1_b_c_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_opcg1_b_o_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_pcg1_f_c_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_pcg1_f_o_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_opcg1_f_c_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_opcg1_f_o_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_ant1_c_aer(isize,itype,ai_phase)) & + + chem_incu(k,lptr_biog1_c_aer(isize,itype,ai_phase)) + + + oa_cw_5to6_ic_cup(i,k,j) = oa_cw_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_oc_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_pcg1_b_c_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_pcg1_b_o_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_opcg1_b_c_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_opcg1_b_o_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_pcg1_f_c_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_pcg1_f_o_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_opcg1_f_c_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_opcg1_f_o_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_ant1_c_aer(isize,itype,cw_phase)) & + + chem_incu(k,lptr_biog1_c_aer(isize,itype,cw_phase)) + + oin_a_5to6_ic_cup(i,k,j) = oin_a_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_oin_aer(isize,itype,ai_phase)) + oin_cw_5to6_ic_cup(i,k,j) = oin_cw_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_oin_aer(isize,itype,cw_phase)) + + bc_a_5to6_ic_cup(i,k,j) = bc_a_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_bc_aer(isize,itype,ai_phase)) + bc_cw_5to6_ic_cup(i,k,j) = bc_cw_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_bc_aer(isize,itype,cw_phase)) + + na_a_5to6_ic_cup(i,k,j) = na_a_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_na_aer(isize,itype,ai_phase)) + na_cw_5to6_ic_cup(i,k,j) = na_cw_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_na_aer(isize,itype,cw_phase)) + + cl_a_5to6_ic_cup(i,k,j) = cl_a_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_cl_aer(isize,itype,ai_phase)) + cl_cw_5to6_ic_cup(i,k,j) = cl_cw_5to6_ic_cup(i,k,j) & + + chem_incu(k,lptr_cl_aer(isize,itype,cw_phase)) + + water_5to6_ic_cup(i,k,j) = water_5to6_ic_cup(i,k,j) & + + chem_incu(k,waterptr_aer(isize,itype)) + + + end do ! k + end if ! dcen size + + end do ! isize + end do ! itype + + + end do main_i_loop + end do main_j_loop + + + return + end subroutine mosaic_chem_cup_driver + + +!------------------------------------------------------------------------------- + subroutine chem_cup_1d( & + config_flags, aer_mech_id, & + lunerr, lundiag, idiagaa_inp, & + kts, kte, ktep1, p1st, num_chem, num_moist, & + ktau, grid_id, i, j, & + ishall, kcldbot_inp, kcldtop_inp, & + tau_active, tau_inactive, & + dz, zcen, zbnd, pcen, tcen, rhocen, ph_no2, & + af_lscld, af_cucld_inp, af_up_inp, & + qcw_incu_inp, qci_incu_inp, & + qcw_inup_inp, qci_inup_inp, & + mf_up_inp, mf_up_ent_inp, & + mf_dn_inp, mf_dn_ent_inp, & + fcvt_qc_to_pr, fcvt_qc_to_qi, fcvt_qi_to_pr, & + wact_inp, & + chem, chem_incu, chem_name, chem_cupflag, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nphase_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, msectional, & + massptr_aer, numptr_aer, & + lptr_cl_aer, lptr_nh4_aer, lptr_no3_aer, lptr_oin_aer, lptr_so4_aer, & + dlo_sect, dhi_sect, dens_aer, hygro_aer, sigmag_aer ) + + use module_configure, only: grid_config_rec_type + use module_configure, only: & + p_qc, & + p_h2o2, p_hcl, p_hno3, p_nh3, p_so2, p_sulf + +! arguments +! +! note: arguments ending in "_inp" may be adjusted for consistency + type(grid_config_rec_type), intent(in) :: config_flags + + integer, intent(in) :: aer_mech_id + integer, intent(in) :: grid_id + integer, intent(in) :: i, idiagaa_inp, ishall + integer, intent(in) :: j + integer, intent(in) :: ktau, kts, kte, ktep1 + integer, intent(in) :: kcldbot_inp, kcldtop_inp + integer, intent(in) :: lunerr, lundiag + integer, intent(in) :: num_chem, num_moist + integer, intent(in) :: p1st + + integer, intent(inout) :: chem_cupflag(kts:kte) ! the "in" value is 0 + + integer, intent(in) :: maxd_acomp, maxd_aphase, maxd_atype, maxd_asize + integer, intent(in) :: & + nphase_aer, ntype_aer, & + ai_phase, cw_phase, msectional, & + nsize_aer( maxd_atype ), & + ncomp_aer( maxd_atype ), & + massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & + numptr_aer( maxd_asize, maxd_atype, maxd_aphase ), & + lptr_so4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_oin_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_no3_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_nh4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_cl_aer(maxd_asize, maxd_atype, maxd_aphase) + real(r4), intent(in) :: & + dlo_sect( maxd_asize, maxd_atype ), & + dhi_sect( maxd_asize, maxd_atype ), & + dens_aer( maxd_acomp, maxd_atype ), & + hygro_aer( maxd_acomp, maxd_atype ), & + sigmag_aer(maxd_asize, maxd_atype) + + + real(r8), intent(in) :: tau_active, tau_inactive + real(r8), intent(in) :: wact_inp ! vertical velocity for activation at cloud-base (m/s) + + real(r8), intent(in), dimension(kts:kte) :: & + dz, & ! layer thickness (m) + zcen, & ! height at layer center (m) + pcen, & ! pressure at layer center (pa) + tcen, & ! temperature at layer center (K) + rhocen, & ! dry air density at layer center (kg/m3) + ph_no2, & ! no2 photolysis rate (1/s) + af_lscld, & ! grid-resolved cloud fractional area + af_cucld_inp, & ! cumulus cloud fractional area + af_up_inp, & ! updraft fractional area + qcw_incu_inp, & ! cloud-water mixing ratio in cumulus cloud (kg/kg) + qci_incu_inp, & ! cloud-ice mixing ratio in updraft (kg/kg) + qcw_inup_inp, & ! cloud-water mixing ratio in cumulus cloud (kg/kg) + qci_inup_inp, & ! cloud-ice mixing ratio in updraft (kg/kg) + mf_up_ent_inp, & ! change to updraft mass flux in layer from entrainment (kg/m2/s) + mf_dn_ent_inp, & ! change to updraft mass flux in layer from entrainment (kg/m2/s) + fcvt_qc_to_pr, & ! fraction of cloud-water converted to precip as air move thru updraft layer (-) + fcvt_qc_to_qi, & ! fraction of cloud-water converted to cloud-ice as air move thru updraft layer (-) + fcvt_qi_to_pr ! fraction of cloud-ice converted to precip as air move thru updraft layer (-) + + real(r8), intent(in), dimension(kts:ktep1) :: & + zbnd, & ! height at layer boundary (m) + mf_up_inp, & ! updraft mass flux at layer boundary (kg/m2/s) + mf_dn_inp ! updraft mass flux at layer boundary (kg/m2/s) + + real(r8), intent(inout), dimension(kts:kte,num_chem) :: & + chem, & ! grid-average aerosol and trace-gas mixing ratios (ug/kg, #/kg, or ppmv) + chem_incu ! in-convective-cloud aerosol and trace-gas mixing ratios (ug/kg, #/kg, or ppmv) + + character(len=12), intent(in) :: chem_name(num_chem) + +! local variables + integer :: aip, cwp, typ + integer :: idiagaa, idiagbb, iflagaa, iok, icomp, isize, itype, itmpa, itmpb + integer :: ido_inact(kts:kte) + integer :: jtsub + integer :: k, kaa, kzz + integer :: kcldbot, kcldtop, kcldbotliq + integer :: kdiagbot, kdiagtop + integer :: kupdrbot, kupdrtop, kdndrbot, kdndrtop + integer :: l, la, lc, l2, l3, lundiagbb + integer :: m + integer :: n + integer :: ntsub ! number of time sub-steps for active cloud integration + + logical, parameter :: do_activa = .true. + +!------To turn off cloud chemistry set do_aqchem-false : Manish Shrivastava ------------------- + logical, parameter :: do_aqchem = .true. +!--------------------------------------------------------------------------- + logical, parameter :: do_inact = .true. + logical, parameter :: do_resusp = .true. + logical, parameter :: do_updraft = .true. + + logical, parameter :: do_2ndact_deep = .true. + logical, parameter :: do_2ndact_shal = .false. + logical, parameter :: do_dndraft_deep = .true. + logical, parameter :: do_dndraft_shal = .false. + logical, parameter :: do_wetrem_deep = .true. + logical, parameter :: do_wetrem_shal = .false. + + logical :: do_2ndact, do_dndraft, do_wetrem + + real(r8), parameter :: rerrtol1_mbal = 3.0e-6 + + real(r8) :: af_cucld(kts:kte) ! cumulus cloud fractional area + real(r8) :: af_dn(kts:kte) ! downdraft fractional area + real(r8) :: af_ev(kts:kte) ! environment fractional area + real(r8) :: af_up(kts:kte) ! updraft fractional area + real(r8) :: af_inact(kts:kte) ! inactive cumulus cloud fractional area + real(r8) :: chem_av_new(kts:kte,num_chem) ! grid-average chem values at end of sub time-step + real(r8) :: chem_av_old(kts:kte,num_chem) ! grid-average chem values at start of sub time-step + real(r8) :: chem_inact_dsp(kts:kte,num_chem) ! inactive cloud chem values at end of time-step + ! but after resuspension/dissipation calculations + real(r8) :: chem_inact_new(kts:kte,num_chem) ! inactive cloud chem values at end of time-step + ! but before resuspension/dissipation calculations + real(r8) :: chem_inact_old(kts:kte,num_chem) ! inactive cloud chem values at start of time-step + real(r8) :: chem_dn(kts:ktep1,num_chem) ! steady-state dndraft chem values (at layer boundaries) + real(r8) :: chem_up(kts:ktep1,num_chem) ! steady-state updraft chem values (at layer boundaries) + ! the following dchemdt_xx_yyyyyy arrays are d(chem)/dt in environment or updraft + ! due to resuspension, activation, aqueous-chemistry, or wet-removal [(ug/kg or ...)/s] + real(r8) :: dchemdt_ev_resusp(kts:kte,num_chem) + real(r8) :: dchemdt_up_activa(kts:kte,num_chem) + real(r8) :: dchemdt_up_aqchem(kts:kte,num_chem) + real(r8) :: dchemdt_up_wetrem(kts:kte,num_chem) + ! the following del_chem_yyyyyy arrays are change (delta) + ! of grid-average chem due to various processes (ug/kg or ...) + real(r8) :: del_chem_activa(kts:kte,num_chem) ! activation + real(r8) :: del_chem_aqchem(kts:kte,num_chem) ! aqueous-chemistry + real(r8) :: del_chem_residu(kts:kte,num_chem) ! residual + real(r8) :: del_chem_resusp(kts:kte,num_chem) ! resuspension + real(r8) :: del_chem_totall(kts:kte,num_chem) ! total change + real(r8) :: del_chem_wetrem(kts:kte,num_chem) ! wet-removal + real(r8) :: del_chem_ztrans(kts:kte,num_chem) ! vertical-transport + real(r8) :: del_chem_actvbb(kts:kte,num_chem) ! activation for inactive cloud + real(r8) :: del_chem_aqchbb(kts:kte,num_chem) ! aqueous-chemistry for inactive cloud + real(r8) :: del_chem_resdbb(kts:kte,num_chem) ! residual for inactive cloud + real(r8) :: del_chem_respbb(kts:kte,num_chem) ! resuspension for inactive cloud + real(r8) :: del_chem_totlbb(kts:kte,num_chem) ! total change for inactive cloud + real(r8) :: dtsub ! time sub-step for active cloud integration (s) + real(r8) :: mf_dn_det(kts:kte) ! change to downdraft mass flux in layer from detrainment (kg/m2/s) + real(r8) :: mf_dn_ent(kts:kte) ! change to downdraft mass flux in layer from entrainment (kg/m2/s) + real(r8) :: mf_dn(kts:ktep1) ! downdraft mass flux at layer boundary (kg/m2/s) + real(r8) :: mf_ev(kts:ktep1) ! environment mass flux at layer boundary (kg/m2/s) + real(r8) :: mf_up_det(kts:kte) ! change to updraft mass flux in layer from detrainment (kg/m2/s) + real(r8) :: mf_up_ent(kts:kte) ! adjusted change to updraft mass flux in layer from entrainment (kg/m2/s) + real(r8) :: mf_up(kts:ktep1) ! adjusted updraft mass flux at layer boundary (kg/m2/s) + real(r8) :: qci_incu(kts:kte), qci_inup(kts:kte) + real(r8) :: qcw_incu(kts:kte), qcw_inup(kts:kte) + real(r8), parameter :: qcw_cldchem_cutoff = 1.0e-6_r8 + real(r8) :: rhodz(kts:kte) ! rho*dz (kg/m2) + real(r8) :: rhodzsum ! sum( rho*dz ) + real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpg + real(r8) :: tmp_chem_dn(num_chem) ! temporary/working value of chem_dn + real(r8) :: tmp_chem_up(num_chem) ! temporary/working value of chem_up + real(r8) :: tmp_dt ! temporary/working value of dt for cloud chemistry + real(r8) :: tmp_fmact(maxd_asize,maxd_atype), tmp_fnact(maxd_asize,maxd_atype) + real(r8) :: tmp_gas_aqfrac_up(num_chem) ! temporary/working value of gas_aqfrac in updraft + real(r8) :: tmp_mfxchem_dn(num_chem) ! temporary/working value of mf_up*chem_dn + real(r8) :: tmp_mfxchem_up(num_chem) ! temporary/working value of mf_up*chem_up + real(r8) :: tmp_mf_dn ! temporary/working value of mf_dn + real(r8) :: tmp_mf_up ! temporary/working value of mf_up + real(r8) :: tmp_w_up ! temporary/working value of w in updraft + real(r8) :: tmpveca(201), tmpvecb(201) + ! tmp_zflux_... - temporary/working values of trace-species vertical fluxes [(ug/kg or ...)/m2/s] + real(r8) :: tmp_zflux_bot, tmp_zflux_botev, tmp_zflux_botup, tmp_zflux_botdn + real(r8) :: tmp_zflux_top, tmp_zflux_topev, tmp_zflux_topup, tmp_zflux_topdn + real(r8) :: wact ! vertical velocity for activation at cloud-base (m/s) + real(r8), parameter :: wact_min = 0.2 ! (m/s) + ! the following zav_yyyyyy arrays are vertical averages of + ! the corresponding yyyyyy arrays, weighted by rhodz + real(r8) :: zav_chem_av_new(num_chem) + real(r8) :: zav_chem_av_old(num_chem) + real(r8) :: zav_chem_dn(num_chem) + real(r8) :: zav_chem_up(num_chem) + real(r8) :: zav_del_chem_activa(num_chem) + real(r8) :: zav_del_chem_aqchem(num_chem) + real(r8) :: zav_del_chem_residu(num_chem) + real(r8) :: zav_del_chem_resusp(num_chem) + real(r8) :: zav_del_chem_totall(num_chem) + real(r8) :: zav_del_chem_wetrem(num_chem) + real(r8) :: zav_del_chem_ztrans(num_chem) + real(r8) :: zav_del_chem_actvbb(num_chem) + real(r8) :: zav_del_chem_aqchbb(num_chem) + real(r8) :: zav_del_chem_resdbb(num_chem) + real(r8) :: zav_del_chem_respbb(num_chem) + real(r8) :: zav_del_chem_totlbb(num_chem) + + character(len=160) :: msg + + +! sanity checks + if ( (ai_phase < 1) .or. (ai_phase > nphase_aer) .or. & + (cw_phase < 1) .or. (cw_phase > nphase_aer) ) then + write(msg,'(a,3(1x,i10))') & + 'chem_cup_1d - bad ai_phase, cw_phase, nphase_aer =', & + ai_phase, cw_phase, nphase_aer + call wrf_message( msg ) + call wrf_error_fatal( msg ) + end if + if (aer_mech_id /= 3) then + write(msg,'(a,3(1x,i10))') & + 'chem_cup_1d - bad aer_mech_id = ', aer_mech_id + call wrf_message( msg ) + call wrf_error_fatal( msg ) + end if + +! checks on inputs + idiagaa = 0 + if (lundiag > 0) idiagaa = idiagaa_inp + if (idiagaa > 0) write(lundiag,'(//a,i10,4i5)') & + 'chem_cup_1d doing ktau, id, i, j, ishall =', ktau, grid_id, i, j, ishall + + idiagbb = 0 + if (idiagaa_inp > 0) idiagbb = idiagaa_inp + if (idiagaa_inp <= -1000) idiagbb = -idiagaa_inp/1000 + lundiagbb = 6 + if (lundiag > 0) lundiagbb = lundiag + + if (ishall == 1) then + do_2ndact = do_2ndact_shal + do_dndraft = do_dndraft_shal + do_wetrem = do_wetrem_shal + else + do_2ndact = do_2ndact_deep + do_dndraft = do_dndraft_deep + do_wetrem = do_wetrem_deep + end if + + kcldbot = kcldbot_inp + kcldtop = kcldtop_inp + + af_cucld(:) = max( af_cucld_inp(:), 0.0_r8 ) + af_up(:) = max( af_up_inp(:), 0.0_r8 ) + qcw_incu(:) = max( qcw_incu_inp(:), 0.0_r8 ) + qci_incu(:) = max( qci_incu_inp(:), 0.0_r8 ) + qcw_inup(:) = max( qcw_inup_inp(:), 0.0_r8 ) + qci_inup(:) = max( qci_inup_inp(:), 0.0_r8 ) + mf_up(:) = max( mf_up_inp(:), 0.0_r8 ) + mf_up_ent(:) = max( mf_up_ent_inp(:), 0.0_r8 ) + mf_up_det(:) = 0.0_r8 + wact = max( wact_inp, wact_min ) + + if ( do_dndraft ) then +! the cloud parameterization does not provide (?) downdraft area +! the chem_cup only uses af_dn for af_ev = 1 - af_up - af_dn, +! and it only uses af_ev for determining resuspension fraction of +! detrained cloud-borne aerosol +! for now, just leave af_dn = 0 + af_dn(:) = 0.0_r8 + mf_dn(:) = min( mf_dn_inp(:), 0.0_r8 ) + mf_dn_ent(:) = max( mf_dn_ent_inp(:), 0.0_r8 ) + mf_dn_det(:) = 0.0_r8 + else + af_dn(:) = 0.0_r8 + mf_dn(:) = 0.0_r8 + mf_dn_ent(:) = 0.0_r8 + mf_dn_det(:) = 0.0_r8 + end if + + if ( 1 .eq. 1 ) then + if (idiagaa > 0) then + write(lundiag,'(a,2i10)') 'kcldbot/top', kcldbot, kcldtop + write(lundiag,'(a,1p,2e10.2)') 'tau_... ', tau_active, tau_inactive + write(lundiag,'(a,1p,2e10.2)') 'wact_inp ', wact_inp + write(lundiag,'(a)') 'zbnd' + write(lundiag,'(1p,15e10.2)') zbnd + write(lundiag,'(a)') 'zcen' + write(lundiag,'(1p,15e10.2)') zcen + write(lundiag,'(a)') 'dz' + write(lundiag,'(1p,15e10.2)') dz + write(lundiag,'(a)') 'pcen' + write(lundiag,'(1p,15e10.2)') pcen + write(lundiag,'(a)') 'tcen' + write(lundiag,'(1p,15e10.2)') tcen + write(lundiag,'(a)') 'rhocen' + write(lundiag,'(1p,15e10.2)') rhocen + write(lundiag,'(a)') 'af_lscld' + write(lundiag,'(1p,15e10.2)') af_lscld + write(lundiag,'(a)') 'af_cucld' + write(lundiag,'(1p,15e10.2)') af_cucld + write(lundiag,'(a)') 'af_up' + write(lundiag,'(1p,15e10.2)') af_up + write(lundiag,'(a)') 'qcw_incu' + write(lundiag,'(1p,15e10.2)') qcw_incu + write(lundiag,'(a)') 'qcw_inup' + write(lundiag,'(1p,15e10.2)') qcw_inup + write(lundiag,'(a)') 'mf_up' + write(lundiag,'(1p,15e10.2)') mf_up + write(lundiag,'(a)') 'mf_up_ent' + write(lundiag,'(1p,15e10.2)') mf_up_ent + if ( do_dndraft ) then + write(lundiag,'(a)') 'mf_dn' + write(lundiag,'(1p,15e10.2)') mf_dn + write(lundiag,'(a)') 'mf_dn_ent' + write(lundiag,'(1p,15e10.2)') mf_dn_ent + end if + end if + end if + +! +! apply "reality checks" to inputs +! + call chem_cup_check_adjust_inputs( & + lunerr, lundiag, idiagaa, & + kts, kte, ktep1, & + ktau, grid_id, i, j, & + ishall, do_dndraft, & + kcldbot, kcldtop, kcldbotliq, & + kupdrbot, kupdrtop, kdndrbot, kdndrtop, & + iok, & + tau_active, tau_inactive, & + dz, zcen, zbnd, pcen, tcen, rhocen, & + af_lscld, af_cucld, af_up, af_dn, & + qcw_incu, qci_incu, & + qcw_inup, qci_inup, & + mf_up, mf_up_ent, mf_up_det, & + mf_dn, mf_dn_ent, mf_dn_det ) + + if (idiagaa > 0) write(lundiag,'(//a,i10)') & + 'chem_cup_check_adjust_inputs iok =', iok + + if ( do_dndraft ) then + kdiagbot = max( min(kupdrbot,kdndrbot)-2, kts ) + kdiagtop = min( max(kupdrtop,kdndrtop)+2, kte ) + else + kdiagbot = max( kupdrbot-2, kts ) + kdiagtop = min( kupdrtop+2, kte ) + end if +! kdiagbot = kts +! kdiagtop = kte + + if ( .not. do_updraft ) then + mf_up(:) = 0.0_r8 + mf_up_ent(:) = 0.0_r8 + mf_up_det(:) = 0.0_r8 + end if + +! diagnostic output + if (idiagaa > 0) then + + write(lundiag,'(/4a)') 'k, ', & + 'qcw_incu*1e3 a/b, qci_incu*1e3 a/b, ', & + 'qcw_inup*1e3 a/b, qci_inup*1e3 a/b' + do k = kdiagtop, kdiagbot, -1 + if (mod(kdiagtop-k,1) == 0) write(lundiag,'(a)') + write(lundiag,'(i2,6(3x,1p,2e10.2))') k, & + qcw_incu_inp(k)*1.0e3, qcw_incu(k)*1.0e3, & + qci_incu_inp(k)*1.0e3, qci_incu(k)*1.0e3, & + qcw_inup_inp(k)*1.0e3, qcw_inup(k)*1.0e3, & + qci_inup_inp(k)*1.0e3, qci_inup(k)*1.0e3 + end do + + if ( do_dndraft ) then + write(lundiag,'(/a2,2a23,2(2a23,a13))') & + 'k', 'af_cucld a/b', 'af_up a/b', & + 'mf_up a/b', 'mf_up_ent a/b', 'mf_up_det b', & + 'mf_dn a/b', 'mf_dn_ent a/b', 'mf_dn_det b' + else + write(lundiag,'(/a2,2a23,2(2a23,a13))') & + 'k', 'af_cucld a/b', 'af_up a/b', & + 'mf_up a/b', 'mf_up_ent a/b', 'mf_up_det b' + end if + do k = kdiagtop, kdiagbot, -1 + if (mod(kdiagtop-k,1) == 0) write(lundiag,'(a)') + if ( do_dndraft ) then + write(lundiag, & + '(i2,1p, 2(3x,2e10.2), 2(2(3x,2e10.2), 3x,e10.2))') k, & + af_cucld_inp(k), af_cucld(k), & + af_up_inp(k), af_up(k), & + mf_up_inp(k), mf_up(k), & + mf_up_ent_inp(k), mf_up_ent(k), & + mf_up_det(k), & + mf_dn_inp(k), mf_dn(k), & + mf_dn_ent_inp(k), mf_dn_ent(k), & + mf_dn_det(k) + else + write(lundiag, & + '(i2,1p, 2(3x,2e10.2), 2(2(3x,2e10.2), 3x,e10.2))') k, & + af_cucld_inp(k), af_cucld(k), & + af_up_inp(k), af_up(k), & + mf_up_inp(k), mf_up(k), & + mf_up_ent_inp(k), mf_up_ent(k), & + mf_up_det(k) + end if + end do + + write(lundiag,'(/a,2i5)') 'kcldbot, top inp', kcldbot_inp, kcldtop_inp + write(lundiag,'( a,2i5)') 'kcldbot, top ', kcldbot, kcldtop + write(lundiag,'( a,2i5)') 'kupdrbot, top ', kupdrbot, kupdrtop + if ( do_dndraft ) & + write(lundiag,'( a,2i5)') 'kdndrbot, top ', kdndrbot, kdndrtop + write(lundiag,'(a)') + + end if ! (idiagaa > 0) + + chem_incu = 0.0 + if (iok < 0) then + chem_cupflag = -1 + goto 89000 + end if + + +! +! determine time step for active cloud calculations +! the mass of air moving out of a layer +! into updraft and downdraft (through their entrainment) +! and into adjacent layers (through environment subsidence) +! cannot exceed the mass of air in the layer +! + rhodz(kts:kte) = rhocen(kts:kte)*dz(kts:kte) + rhodzsum = sum( rhodz(kts:kte) ) + + mf_ev(kts:ktep1) = -( mf_up(kts:ktep1) + mf_dn(kts:ktep1) ) + af_ev(kts:kte) = 1.0_r8 - ( af_up(kts:kte) + af_dn(kts:kte) ) + + tmpa = 1.0e10 ! tmpa is the smallest of the + ! individual layer maximum time steps + do k = kupdrbot, kupdrtop + tmpb = mf_up_ent(k) + mf_dn_ent(k) & + + max( mf_ev(k+1), 0.0_r8 ) & + + max( -mf_ev(k), 0.0_r8 ) ! tmpb is air-mass flux out of this layer + tmpc = rhodz(k) / max( tmpb, 1.0e-10_r8 ) ! tmpc is max. time step for this layer + tmpa = min( tmpa, tmpc ) ! tmpa is the smallest of all the tmpc + if (idiagaa > 0) write(lundiag,'(a,1x,i10,1p,e11.3)') & + 'k, dtmax', k, tmpc + end do + tmpd = tmpa + tmpa = tmpa * air_outflow_limit + ntsub = floor( tau_active/tmpa ) + 1 + dtsub = tau_active/ntsub + if (idiagaa > 0) then + write(lundiag,'(a,1x,i10,1p,2e11.3)') 'k, dtmax', -1, tmpd, tmpa + write(lundiag,'(a,1x,i10,1p,2e11.3)') & + 'ntsub, dtsub, tau_active', ntsub, dtsub, tau_active + write(lundiag,'(2a,1x,10l5)') & + 'do_activa, _2ndact, _resusp, _aqchem, ', & + '_wetrem, _updraft, _dndraft', & + do_activa, do_2ndact, do_resusp, do_aqchem, & + do_wetrem, do_updraft, do_dndraft + end if + +! +! +! do multiple substeps of active cloud +! +! + chem_av_new(:,:) = chem(:,:) + zav_chem_av_new(:) = 0.0_r8 + do l = p1st, num_chem + zav_chem_av_new(l) = sum( rhodz(kts:kte)*chem_av_new(kts:kte,l) ) / rhodzsum + end do + del_chem_activa(:,:) = 0.0_r8 + del_chem_aqchem(:,:) = 0.0_r8 + del_chem_residu(:,:) = 0.0_r8 + del_chem_resusp(:,:) = 0.0_r8 + del_chem_totall(:,:) = 0.0_r8 + del_chem_wetrem(:,:) = 0.0_r8 + del_chem_ztrans(:,:) = 0.0_r8 + del_chem_actvbb(:,:) = 0.0_r8 + del_chem_aqchbb(:,:) = 0.0_r8 + del_chem_resdbb(:,:) = 0.0_r8 + del_chem_respbb(:,:) = 0.0_r8 + del_chem_totlbb(:,:) = 0.0_r8 + + ido_inact = 0 + +active_cloud_jtsub_loop: & + do jtsub = 1, ntsub + + +! +! calculate aerosol and gas profiles in the updraft +! + chem_av_old(:,:) = chem_av_new(:,:) + zav_chem_av_old(:) = zav_chem_av_new(:) + + chem_up(:,:) = 0.0_r8 + dchemdt_ev_resusp(:,:) = 0.0_r8 + dchemdt_up_activa(:,:) = 0.0_r8 + dchemdt_up_aqchem(:,:) = 0.0_r8 + dchemdt_up_wetrem(:,:) = 0.0_r8 + + zav_chem_up(:) = 0.0_r8 + tmp_mfxchem_up = 0.0_r8 + +do_updraft_mixratio_calc: & + if ( do_updraft ) then + +updraft_mixratio_k_loop: & + do k = kupdrbot, kupdrtop + + tmp_mf_up = mf_up(k) + +! do activation at first cloudy layer +! when first cloudy layer > first updraft layer + if ( do_activa ) then + if ((k == kcldbotliq) .and. (k > kupdrbot)) then + iflagaa = 1 + call chem_cup_activate_up( & + lunerr, lundiag, idiagaa, & + kts, kte, p1st, num_chem, & + ktau, grid_id, i, j, k, iflagaa, & + pcen(k), tcen(k), rhocen(k), qcw_inup(k), & + rhodz(k), af_up(k), wact, & + tmp_mf_up, tmp_mfxchem_up, dchemdt_up_activa, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, msectional, & + massptr_aer, numptr_aer, & + dlo_sect, dhi_sect, dens_aer, hygro_aer, sigmag_aer ) + end if + end if ! ( do_activa ) then + +! do entrainment + if (mf_up_ent(k) > 0.0_r8) then + do l = p1st, num_chem + tmp_mfxchem_up(l) = tmp_mfxchem_up(l) + chem_av_old(k,l)*mf_up_ent(k) + end do + tmp_mf_up = tmp_mf_up + mf_up_ent(k) + end if + +! do activation at first cloudy layer +! when first cloudy layer = first updraft layer + if ( do_activa ) then + if ((k == kcldbotliq) .and. (k == kupdrbot)) then + iflagaa = 2 + else if (( do_2ndact ) .and. (k > kcldbotliq)) then + iflagaa = 10 + else + iflagaa = 0 + end if + if (iflagaa > 0) then + call chem_cup_activate_up( & + lunerr, lundiag, idiagaa, & + kts, kte, p1st, num_chem, & + ktau, grid_id, i, j, k, iflagaa, & + pcen(k), tcen(k), rhocen(k), qcw_inup(k), & + rhodz(k), af_up(k), wact, & + tmp_mf_up, tmp_mfxchem_up, dchemdt_up_activa, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, msectional, & + massptr_aer, numptr_aer, & + dlo_sect, dhi_sect, dens_aer, hygro_aer, sigmag_aer ) + end if + end if ! ( do_activa ) then + +! do cloud chemistry + if ( do_aqchem ) then + if (qcw_inup(k) > qcw_cldchem_cutoff) then + tmp_w_up = tmp_mf_up / (af_up(k) * rhocen(k)) + tmp_w_up = max( tmp_w_up, 0.1_r8 ) + tmp_dt = dz(k)/tmp_w_up + +! subr. chem_cup_aqchem( & +! config_flags, aer_mech_id, & +! lunerr, lundiag, idiagaa, & +! kts, kte, p1st, num_chem, & +! p_qc, num_moist, & +! ktau, grid_id, i, j, & +! iflagaa, ido_aqchem, & +! dt_aqchem, & +! pcen, tcen, rhocen, rhodz, qcw, ph_no2, & +! af_up, tmp_gas_aqfrac_up, tmp_mf_up, tmp_mfxchem_up, & +! dchemdt_up_aqchem, chem_inact ) + + call chem_cup_aqchem( & + config_flags, aer_mech_id, & + lunerr, lundiag, idiagaa, & + kts, kte, p1st, num_chem, & + p_qc, num_moist, & + ktau, grid_id, i, j, & + k, ido_inact, & + tmp_dt, & + pcen, tcen, rhocen, rhodz, qcw_inup, ph_no2, & + af_up(k), tmp_gas_aqfrac_up, tmp_mf_up, tmp_mfxchem_up, & + dchemdt_up_aqchem, chem_inact_new ) + end if + end if ! ( do_aqchem ) then + +! do wet removal + if ( do_wetrem ) then +! for now just do +! fcvt_qc_to_pr transfers cloud-borne to precip, which is assumed to fall out +! eventually should track ice-borne aerosol and do +! fcvt_qc_to_qi transfers cloud-borne to ice-borne +! fcvt_qi_to_pr transfers ice-borne to precip, which is assumed to fall out +! detrained ice-borne goes to interstitial (?) + tmpf = min( 1.0_r8, max( 0.0_r8, fcvt_qc_to_pr(k) ) ) + if (tmpf > 1.0e-10_r8) then + if ( do_aqchem .and. (qcw_inup(k) > qcw_cldchem_cutoff) ) then + do l = p1st, num_chem + if (tmp_gas_aqfrac_up(l) <= 1.0e-10_r8) cycle + tmpg = min( 1.0_r8, max( 0.0_r8, tmp_gas_aqfrac_up(l)*tmpf ) ) + ! tmpd = wet-removal change to (mf_up * chem_up) as air moves thru the layer + tmpd = -tmp_mfxchem_up(l)*tmpg + tmp_mfxchem_up(l) = tmp_mfxchem_up(l) + tmpd + dchemdt_up_wetrem(k,l) = tmpd/(rhodz(k)*af_up(k)) +! if (idiagaa > 0) & +! write(lundiag,'(a,2i5,1p,2e10.2,2x,a)') & +! 'gas_aqfrac', k, l, tmp_gas_aqfrac_up(l), qcw_inup(k), chem_name(l) + end do + end if + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + do icomp = 0, ncomp_aer(itype) + if (icomp == 0) then + l = numptr_aer(isize,itype,cw_phase) + else + l = massptr_aer(icomp,isize,itype,cw_phase) + end if + if ((l < p1st) .or. (l > num_chem)) cycle + ! tmpd = wet-removal change to (mf_up * chem_up) as air moves thru the layer + tmpd = -tmp_mfxchem_up(l)*tmpf + tmp_mfxchem_up(l) = tmp_mfxchem_up(l) + tmpd + dchemdt_up_wetrem(k,l) = tmpd/(rhodz(k)*af_up(k)) + end do + end do + end do + end if ! (tmpf > 1.0e-10_r8) + end if ! ( do_wetrem ) + + +! calculate updraft mixing ratios after above processes + tmp_chem_up(p1st:num_chem) = tmp_mfxchem_up(p1st:num_chem)/tmp_mf_up + +! do detrainment (which does not change the updraft mixing ratios + tmp_mf_up = max( 0.0_r8, tmp_mf_up - mf_up_det(k) ) +! tmp_mf_up = mf_up(k+1) + do l = p1st, num_chem + tmp_mfxchem_up(l) = tmp_mf_up*tmp_chem_up(l) + end do + +! tmp_chem_up at this point is the chem_up at top of layer k + chem_up(k+1,p1st:num_chem) = tmp_chem_up(p1st:num_chem) + +! calculate resuspension of detrained aerosol +! this occurs in occurs in the environment, so does not affect chem_up + if ( do_resusp ) then + tmpa = 1.0_r8 - af_lscld(k) ! fraction resuspended = 1 - ls_cloud_fraction + tmpa = max( 0.0_r8, min( 1.0_r8, tmpa ) ) + + tmpb = tmpa * mf_up_det(k)/(rhodz(k)*af_ev(k)) + +! do l1 = kts, kte +! l2 = l1 + lgrp*3 +! l3 = l1 + lgrp*4 + +! tmpc = tmp_chem_up(l2)*tmpb +! dchemdt_ev_resusp(k,l2) = dchemdt_ev_resusp(k,l2) - tmpc +! dchemdt_ev_resusp(k,l3) = dchemdt_ev_resusp(k,l3) + tmpc +! end do ! l1 + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + do l2 = 0, ncomp_aer(itype) + if (l2 == 0) then + la = numptr_aer(isize,itype,ai_phase) + lc = numptr_aer(isize,itype,cw_phase) + else + la = massptr_aer(l2,isize,itype,ai_phase) + lc = massptr_aer(l2,isize,itype,cw_phase) + end if + if ((la < p1st) .or. (la > num_chem)) cycle + if ((lc < p1st) .or. (lc > num_chem)) cycle + + tmpc = tmp_chem_up(lc)*tmpb + dchemdt_ev_resusp(k,lc) = dchemdt_ev_resusp(k,lc) - tmpc + dchemdt_ev_resusp(k,la) = dchemdt_ev_resusp(k,la) + tmpc + end do ! l2 + end do ! isize + end do ! itype + + end if ! ( do_resusp ) then + + end do updraft_mixratio_k_loop + + do l = 1, num_chem + zav_chem_up(l) = sum( rhodz(kts:kte)*chem_up(kts:kte,l) ) / rhodzsum + end do + + end if do_updraft_mixratio_calc + + +! +! calculate aerosol and gas profiles in the dndraft +! +do_dndraft_mixratio_calc: & + if ( do_dndraft ) then + + chem_dn(:,:) = 0.0_r8 + zav_chem_dn(:) = 0.0_r8 + tmp_mfxchem_dn = 0.0_r8 + +dndraft_mixratio_k_loop: & + do k = kdndrtop, kdndrbot, -1 + + tmp_mf_dn = mf_dn(k+1) +! at this point, tmp_mf_dn and tmp_mvxchem_dn are at the layer top + +! do entrainment + if (mf_dn_ent(k) > 0.0_r8) then + do l = p1st, num_chem + tmp_mfxchem_dn(l) = tmp_mfxchem_dn(l) - chem_av_old(k,l)*mf_dn_ent(k) + end do + tmp_mf_dn = tmp_mf_dn - mf_dn_ent(k) + end if +! at this point, tmp_mf_dn and tmp_mvxchem_dn are at the layer bottom +! (but before detrainment) + +! calculate dndraft mixing ratios after above processes + tmp_chem_dn(p1st:num_chem) = tmp_mfxchem_dn(p1st:num_chem)/tmp_mf_dn + +! do detrainment (which does not change the dndraft mixing ratios + tmp_mf_dn = min( 0.0_r8, tmp_mf_dn + mf_dn_det(k) ) + do l = p1st, num_chem + tmp_mfxchem_dn(l) = tmp_mf_dn*tmp_chem_dn(l) + end do + +! tmp_chem_dn at this point is the chem_dn at bottom of layer k + chem_dn(k,p1st:num_chem) = tmp_chem_dn(p1st:num_chem) + +! calculate resuspension of detrained aerosol +! this occurs in occurs in the environment, so does not affect chem_dn + if ( do_resusp ) then +! tmpa = 1.0_r8 - af_lscld(k) ! fraction resuspended = 1 - ls_cloud_fraction +! tmpa = max( 0.0_r8, min( 1.0_r8, tmpa ) ) + tmpa = 0.0_r8 ! assume that downdraft is subsaturated at detrainment level + ! so any cloud-borne aerosol is resuspended + + tmpb = tmpa * mf_dn_det(k)/(rhodz(k)*af_ev(k)) + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + do l2 = 0, ncomp_aer(itype) + if (l2 == 0) then + la = numptr_aer(isize,itype,ai_phase) + lc = numptr_aer(isize,itype,cw_phase) + else + la = massptr_aer(l2,isize,itype,ai_phase) + lc = massptr_aer(l2,isize,itype,cw_phase) + end if + if ((la < p1st) .or. (la > num_chem)) cycle + if ((lc < p1st) .or. (lc > num_chem)) cycle + + tmpc = tmp_chem_dn(lc)*tmpb + dchemdt_ev_resusp(k,lc) = dchemdt_ev_resusp(k,lc) - tmpc + dchemdt_ev_resusp(k,la) = dchemdt_ev_resusp(k,la) + tmpc + end do ! l2 + end do ! isize + end do ! itype + + end if ! ( do_resusp ) then + + end do dndraft_mixratio_k_loop + + do l = 1, num_chem + zav_chem_dn(l) = sum( rhodz(kts:kte)*chem_dn(kts:kte,l) ) / rhodzsum + end do + + end if do_dndraft_mixratio_calc + + +! +! +! now solve mass conservation for timestep dtsub +! +! + if ( do_dndraft ) then + kaa = min( kupdrbot, kdndrbot ) ; kzz = max( kupdrtop, kdndrtop ) + else + kaa = kupdrbot ; kzz = kupdrtop + end if + + do l = p1st, num_chem + + tmp_zflux_top = 0.0_r8 + + do k = kaa, kzz + + tmp_zflux_bot = tmp_zflux_top + + !BSINGH(12/19/2013) - Commented out the following (tmp_zflux_botev, tmp_zflux_botup and tmp_zflux_botdn) + !variables as "tmp_zflux_topev" is undefined at this point and other variables + !(tmp_zflux_botev, tmp_zflux_botup and tmp_zflux_botdn) are acting as dummy variables in the code + + !tmp_zflux_botev = tmp_zflux_topev + !tmp_zflux_botup = tmp_zflux_topup + !tmp_zflux_botdn = tmp_zflux_topdn + + if (mf_ev(k+1) >= 0.0_r8) then + tmp_zflux_topev = mf_ev(k+1)*chem_av_old(k,l) + else + tmp_zflux_topev = mf_ev(k+1)*chem_av_old(k+1,l) + end if + + tmp_zflux_topup = mf_up(k+1)*chem_up(k+1,l) + tmp_zflux_topdn = mf_dn(k+1)*chem_dn(k+1,l) ! this will be zero when do_dndraft=.false. + + tmp_zflux_top = tmp_zflux_topev + tmp_zflux_topup + tmp_zflux_topdn + + tmpa = (tmp_zflux_bot - tmp_zflux_top)*dtsub/rhodz(k) + tmpb = dchemdt_up_activa(k,l)*af_up(k)*dtsub + tmpc = dchemdt_up_aqchem(k,l)*af_up(k)*dtsub + tmpd = dchemdt_up_wetrem(k,l)*af_up(k)*dtsub + tmpe = dchemdt_ev_resusp(k,l)*af_ev(k)*dtsub + + del_chem_ztrans(k,l) = del_chem_ztrans(k,l) + tmpa + del_chem_activa(k,l) = del_chem_activa(k,l) + tmpb + del_chem_aqchem(k,l) = del_chem_aqchem(k,l) + tmpc + del_chem_wetrem(k,l) = del_chem_wetrem(k,l) + tmpd + del_chem_resusp(k,l) = del_chem_resusp(k,l) + tmpe + + chem_av_new(k,l) = chem_av_old(k,l) + (tmpa + tmpb + tmpc + tmpd + tmpe) + + if (chem_av_new(k,l) < 0.0_r8) then + del_chem_residu(k,l) = del_chem_residu(k,l) - chem_av_new(k,l) + chem_av_new(k,l) = 0.0_r8 + end if + del_chem_totall(k,l) = del_chem_totall(k,l) + (chem_av_new(k,l) - chem_av_old(k,l)) + +! if (idiagaa > 0) then +! if ((l == numptr_aer(2,1,ai_phase)) .or. (l == numptr_aer(2,1,cw_phase))) then +! tmpveca(1) = (tmp_zflux_botev - tmp_zflux_topev)*dtsub/rhodz(k) +! tmpveca(2) = (tmp_zflux_botup - tmp_zflux_topup)*dtsub/rhodz(k) +! tmpveca(3) = (tmp_zflux_botdn - tmp_zflux_topdn)*dtsub/rhodz(k) +! tmpveca(4) = tmpb +! tmpveca(5) = tmpc +! tmpveca(6) = tmpd +! tmpveca(7) = tmpe +! write(lundiag,'(i4,1p,7e12.4,3x,2a)') k, tmpveca(1:7), 'tends ', chem_name(l) +! end if +! end if + + end do ! k + + zav_chem_av_new(l) = sum( rhodz(kts:kte)*chem_av_new( kts:kte,l) ) / rhodzsum + zav_del_chem_activa(l) = sum( rhodz(kts:kte)*del_chem_activa(kts:kte,l) ) / rhodzsum + zav_del_chem_aqchem(l) = sum( rhodz(kts:kte)*del_chem_aqchem(kts:kte,l) ) / rhodzsum + zav_del_chem_residu(l) = sum( rhodz(kts:kte)*del_chem_residu(kts:kte,l) ) / rhodzsum + zav_del_chem_resusp(l) = sum( rhodz(kts:kte)*del_chem_resusp(kts:kte,l) ) / rhodzsum + zav_del_chem_totall(l) = sum( rhodz(kts:kte)*del_chem_totall(kts:kte,l) ) / rhodzsum + zav_del_chem_wetrem(l) = sum( rhodz(kts:kte)*del_chem_wetrem(kts:kte,l) ) / rhodzsum + zav_del_chem_ztrans(l) = sum( rhodz(kts:kte)*del_chem_ztrans(kts:kte,l) ) / rhodzsum + + end do ! l + + +! diagnostic outputs + if (idiagaa > 0) then + call chem_cup_1d_diags_pt21( & + lundiag, kdiagbot, kdiagtop, & + kts, kte, ktep1, p1st, num_chem, & + ktau, grid_id, i, j, jtsub, ntsub, & + ishall, do_dndraft, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nphase_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, & + massptr_aer, numptr_aer, & + lptr_cl_aer, lptr_nh4_aer, lptr_no3_aer, lptr_oin_aer, lptr_so4_aer, & + rhodz, rhodzsum, & + chem_av_new, chem_av_old, chem_up, chem_dn, & + zav_chem_av_new, zav_chem_av_old, zav_chem_up, zav_chem_dn, & + zav_del_chem_activa, zav_del_chem_aqchem, & + zav_del_chem_residu, zav_del_chem_resusp, & + zav_del_chem_wetrem, zav_del_chem_ztrans, & + zav_del_chem_totall, & + chem_name ) + end if ! (idiagaa > 0) + + + end do active_cloud_jtsub_loop + + +! mass balance check after active cloud calcs + itmpa = 0 + tmpveca(1:20) = 0.0_r8 + do l = p1st, num_chem + tmpa = 0.0_r8 ; tmpb = 0.0_r8 ; tmpd = 0.0_r8 + do k = kts, kte + tmpa = tmpa + rhodz(k)*chem(k,l) + tmpb = tmpb + rhodz(k)*chem_av_new(k,l) + tmpd = tmpd + rhodz(k)*(chem_av_new(k,l) - chem(k,l)) + end do ! k + tmpa = tmpa/rhodzsum ! initial column-avg mix-ratio + tmpb = tmpb/rhodzsum ! ending column-avg mix-ratio + tmpd = tmpd/rhodzsum ! column-avg mix-ratio change + + tmpvecb(11) = zav_del_chem_activa(l) + tmpvecb(12) = zav_del_chem_resusp(l) + tmpvecb(13) = zav_del_chem_aqchem(l) + tmpvecb(14) = zav_del_chem_wetrem(l) + tmpvecb(15) = zav_del_chem_ztrans(l) + tmpvecb(16) = zav_del_chem_residu(l) + + tmpe = sum( tmpvecb(11:16) ) ! column-avg m.r. changes by processes + tmpf = sum( max( tmpvecb(11:16), 0.0 ) ) + tmpg = sum( max( -tmpvecb(11:16), 0.0 ) ) + tmpf = max( tmpf, tmpg ) + tmpg = (tmpd-tmpe)/max( tmpa, tmpb, tmpf, 1.0e-30_r8 ) ! normalized residual + + if (abs(tmpg) > abs(tmpveca(1))) then + itmpa = l + tmpveca(1) = tmpg + tmpveca(2) = tmpd-tmpe + tmpveca(3) = tmpd + tmpveca(4) = tmpe + tmpveca(5) = tmpa + tmpveca(6) = tmpb + tmpveca(11:16) = tmpvecb(11:16) + end if + if ((idiagbb > 0) .and. (abs(tmpg) > rerrtol1_mbal)) then + write(lundiagbb,'(/a,i10,3i5,1p,6e11.3,2x,a)') & + 'chem_cup_1d massbal active -', ktau, grid_id, i, j, & + tmpg, (tmpd-tmpe), tmpd, tmpe, tmpa, tmpb, chem_name(l) + write(lundiagbb,'(2a,1p,8e11.3)') & + 'zav_del_chem_activa, resusp, ', & + 'aqchem, wetrem, ztrans, residu', tmpvecb(11:16) + end if + end do ! l + + if (idiagaa > 0) then + msg = 'perfect' ; if (itmpa > 0) msg = chem_name(itmpa) + write(lundiag,'(/a,i10,3i5,1p,6e11.3,2x,a)') & + 'chem_cup_1d massbal worst active -', & + ktau, grid_id, i, j, tmpveca(1:6), msg(1:12) + write(lundiag,'(2a,1p,8e11.3)') & + 'zav_del_chem_activa, resusp, ', & + 'aqchem, wetrem, ztrans, residu', tmpveca(11:16) + end if + + +! +! +! now do calculations for inactive cloud +! +! > start with chem_av_new in the entire grid-area +! > divide the grid area into +! > inactive cloud portion with area fraction = af_cucld(k) - af_up(k) +! > "other" portion = the rest +! > in inactive cloud portion +! > start with chem_inact_old = chem_av_new +! (cannot use chem_up here because in the steady-state updraft approach, +! the updrafts process aerosol/gas mass, +! but they do not really contain any aerosol/gas mass) +! > set interstitial/activated fractions based on +! the fractions in the updraft +! > do cloud chemistry +! > do partial aerosol resuspension before "dissipating" +! the inactive cloud back to the grid-average +! > "dissipate" the inactive cloud back to the grid-average +! + af_inact = 0.0 + ido_inact = 0 + chem_inact_new = -1.0e10 + chem_inact_dsp = -1.0e10 + if ( .not. do_inact ) goto 79000 + + itmpa = 0 + do k = kcldbot, kcldtop + ! count levels that have qcw>0 both in cumulus and in updraft + ! and also have cumulus area fraction > updraft area fraction + tmpa = af_cucld(k)-af_up(k) + if ( (qcw_incu(k) > 0.0) .and. & + (qcw_inup(k) > 0.0) .and. & + (tmpa >= af_cucld_smallaa*0.5) ) then + af_inact(k) = max( 0.0_r8, min( 1.0_r8, tmpa ) ) + ido_inact(k) = 1 + itmpa = itmpa + 1 + end if + end do + + if (itmpa <= 0)then + if (idiagaa > 0) write(lundiag,'(/a,4i10)') & + 'chem_cup_1d - no inactive cloud calcs - ktau, id, i, j =', & + ktau, grid_id, i, j + + chem(:,:) = chem_av_new(:,:) ! put updated mix-ratios into chem + goto 79000 + end if + + +! set initial mixing ratios for inactive cloud + chem_av_old(:,:) = chem_av_new(:,:) + chem_inact_old(:,:) = chem_av_new(:,:) + + if (idiagaa > 0) write(lundiag,'(//a)') 'inactive k, fmact, fnact' + do k = kcldtop, kcldbot, -1 + if (ido_inact(k) <= 0) cycle + + tmp_fmact = 0.0_r8 ; tmp_fnact = 0.0_r8 + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + tmpg = 0.0_r8 + do l2 = 0, ncomp_aer(itype) + if (l2 == 0) then + la = numptr_aer(isize,itype,ai_phase) + lc = numptr_aer(isize,itype,cw_phase) + else + la = massptr_aer(l2,isize,itype,ai_phase) + lc = massptr_aer(l2,isize,itype,cw_phase) + end if + if ((la < p1st) .or. (la > num_chem)) cycle + if ((lc < p1st) .or. (lc > num_chem)) cycle + + tmpa = max( chem_up(k+1,la), 1.0e-35_r8 ) + tmpc = max( chem_up(k+1,lc), 1.0e-35_r8 ) + tmpd = tmpa + tmpc + tmpe = max( chem_inact_old(k,la) + chem_inact_old(k,lc), 0.0_r8 ) + ! apply interstitial/activated fractions from the updraft + chem_inact_old(k,la) = tmpe*(tmpa/tmpd) + chem_inact_old(k,lc) = tmpe*(tmpc/tmpd) + + del_chem_actvbb(k,la) = af_inact(k)*(chem_inact_old(k,la) - chem_av_new(k,la)) + del_chem_actvbb(k,lc) = af_inact(k)*(chem_inact_old(k,lc) - chem_av_new(k,lc)) + + if (l2 == 0) then + tmp_fnact(isize,itype) = tmpc/tmpd + else + tmpe = max( tmpe, 1.0e-35_r8 ) + tmp_fmact(isize,itype) = tmp_fmact(isize,itype) + tmpe*(tmpc/tmpd) + tmpg = tmpg + tmpe + end if + end do ! l2 + tmp_fmact(isize,itype) = tmp_fmact(isize,itype)/tmpg + end do ! isize + if (idiagaa > 0) & + write(lundiag,'( i3,2(2x,8f8.4) / (3x,2(2x,8f8.4)) )') k, & + tmp_fmact(1:nsize_aer(itype),itype), tmp_fnact(1:nsize_aer(itype),itype) +! Added ',itype' in tmp_fmact and tmp_fnact arrays by Manish Shrivastava + end do ! itype + + chem_inact_new(k,:) = chem_inact_old(k,:) + end do ! k + + + if ( do_aqchem ) then + +! do cloud chemistry +! subr. chem_cup_aqchem( & +! config_flags, aer_mech_id, & +! lunerr, lundiag, idiagaa, & +! kts, kte, p1st, num_chem, & +! p_qc, num_moist, & +! ktau, grid_id, i, j, & +! iflagaa, ido_aqchem, & +! dt_aqchem, & +! pcen, tcen, rhocen, rhodz, qcw, ph_no2, & +! af_up, tmp_gas_aqfrac_up, tmp_mf_up, tmp_mfxchem_up, & +! dchemdt_up_aqchem, chem_inact ) + + itmpb = kts-1 + call chem_cup_aqchem( & + config_flags, aer_mech_id, & + lunerr, lundiag, idiagaa, & + kts, kte, p1st, num_chem, & + p_qc, num_moist, & + ktau, grid_id, i, j, & + itmpb, ido_inact, & + tau_inactive, & + pcen, tcen, rhocen, rhodz, qcw_incu, ph_no2, & + af_up(kts), tmp_gas_aqfrac_up, tmp_mf_up, tmp_mfxchem_up, & + dchemdt_up_aqchem, chem_inact_new ) + + do k = kcldbot, kcldtop + if (ido_inact(k) <= 0) cycle + do l = p1st, num_chem + del_chem_aqchbb(k,l) = af_inact(k)*(chem_inact_new(k,l) - chem_inact_old(k,l)) + end do + end do + + end if ! ( do_aqchem ) + + +! do "dissipation" of the cumulus cloud, +! because there is no "memory" for the aerosols/gases within the cumulus cloud +! +! as part of this, do partial resuspension of activated aerosols in the inactive cloud +! part of the cumulus cloud goes to grid-resolved cloud, and part goes to clear air +! if the grid-resolved cloud fraction is 0.0, +! then all of the activated aerosols in the cumulus cloud are resuspended +! if the grid-resolved cloud fraction is 1.0, +! then none of the activated aerosols in the cumulus cloud are resuspended + + chem_inact_dsp = chem_inact_new + do k = kcldbot, kcldtop + if (ido_inact(k) <= 0) cycle + +! first do the resuspension + if ( do_resusp ) then + tmpa = 1.0_r8 - af_lscld(k) ! fraction resuspended = 1 - ls_cloud_fraction + tmpa = max( 0.0_r8, min( 1.0_r8, tmpa ) ) + + if (tmpa > 0.0) then + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + do l2 = 0, ncomp_aer(itype) + if (l2 == 0) then + la = numptr_aer(isize,itype,ai_phase) + lc = numptr_aer(isize,itype,cw_phase) + else + la = massptr_aer(l2,isize,itype,ai_phase) + lc = massptr_aer(l2,isize,itype,cw_phase) + end if + if ((la < p1st) .or. (la > num_chem)) cycle + if ((lc < p1st) .or. (lc > num_chem)) cycle + + tmpc = chem_inact_new(k,lc)*tmpa + chem_inact_dsp(k,lc) = chem_inact_new(k,lc) - tmpc + chem_inact_dsp(k,la) = chem_inact_new(k,la) + tmpc + del_chem_respbb(k,lc) = -tmpc*af_inact(k) + del_chem_respbb(k,la) = tmpc*af_inact(k) + end do ! l2 + end do ! isize + end do ! itype + end if ! (tmpa > 0.0) + end if ! ( do_resusp ) + +! now the dissipation + tmpb = 1.0 - af_inact(k) + do l = p1st, num_chem + chem_av_new(k,l) = tmpb*chem_av_old(k,l) + af_inact(k)*chem_inact_dsp(k,l) + del_chem_totlbb(k,l) = chem_av_new(k,l) - chem_av_old(k,l) + del_chem_resdbb(k,l) = del_chem_totlbb(k,l) & + - ( del_chem_actvbb(k,l) + del_chem_aqchbb(k,l) + del_chem_respbb(k,l) ) + end do ! l + + end do ! k + + do l = p1st, num_chem + zav_del_chem_actvbb(l) = sum( rhodz(kts:kte)*del_chem_actvbb(kts:kte,l) ) / rhodzsum + zav_del_chem_aqchbb(l) = sum( rhodz(kts:kte)*del_chem_aqchbb(kts:kte,l) ) / rhodzsum + zav_del_chem_resdbb(l) = sum( rhodz(kts:kte)*del_chem_resdbb(kts:kte,l) ) / rhodzsum + zav_del_chem_respbb(l) = sum( rhodz(kts:kte)*del_chem_respbb(kts:kte,l) ) / rhodzsum + zav_del_chem_totlbb(l) = sum( rhodz(kts:kte)*del_chem_totlbb(kts:kte,l) ) / rhodzsum + end do + + +! diagnostics + if (idiagaa > 0) then + call chem_cup_1d_diags_pt41( & + lundiag, 1, & + kts, kte, ktep1, p1st, num_chem, & + ktau, grid_id, i, j, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nphase_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, & + massptr_aer, numptr_aer, & + lptr_cl_aer, lptr_nh4_aer, lptr_no3_aer, lptr_oin_aer, lptr_so4_aer, & + rhodz, rhodzsum, & + chem_av_old, chem_av_new, & + zav_del_chem_actvbb, zav_del_chem_aqchbb, & + zav_del_chem_resdbb, zav_del_chem_respbb, & + zav_del_chem_totlbb, zav_del_chem_wetrem, & + chem_name ) + end if ! (idiagaa > 0) + + +! mass balance check after inactive cloud calcs + itmpa = 0 + tmpveca(1:20) = 0.0 + do l = p1st, num_chem + tmpa = 0.0_r8 ; tmpb = 0.0_r8 ; tmpd = 0.0_r8 + do k = kts, kte + tmpa = tmpa + rhodz(k)*chem(k,l) + tmpb = tmpb + rhodz(k)*chem_av_new(k,l) + tmpd = tmpd + rhodz(k)*(chem_av_new(k,l) - chem(k,l)) + end do ! k + tmpa = tmpa/rhodzsum ! initial column-avg mix-ratio + tmpb = tmpb/rhodzsum ! ending column-avg mix-ratio + tmpd = tmpd/rhodzsum ! column-avg mix-ratio change + + tmpvecb(11) = zav_del_chem_activa(l) + tmpvecb(12) = zav_del_chem_resusp(l) + tmpvecb(13) = zav_del_chem_aqchem(l) + tmpvecb(14) = zav_del_chem_wetrem(l) + tmpvecb(15) = zav_del_chem_ztrans(l) + tmpvecb(16) = zav_del_chem_residu(l) + tmpvecb(17) = zav_del_chem_actvbb(l) + tmpvecb(18) = zav_del_chem_respbb(l) + tmpvecb(19) = zav_del_chem_aqchbb(l) + + tmpe = sum( tmpvecb(11:14) ) + sum( tmpvecb(17:19) ) ! column-avg m.r. changes by processes + tmpf = sum( max( tmpvecb(11:14), 0.0 ) ) + sum( max( tmpvecb(17:19), 0.0 ) ) + tmpg = sum( max( -tmpvecb(11:14), 0.0 ) ) + sum( max( -tmpvecb(17:19), 0.0 ) ) + tmpf = max( tmpf, tmpg ) + tmpg = (tmpd-tmpe)/max( tmpa, tmpb, tmpf, 1.0e-30_r8 ) ! normalized residual + + if (abs(tmpg) > abs(tmpveca(1))) then + itmpa = l + tmpveca(1) = tmpg + tmpveca(2) = tmpd-tmpe + tmpveca(3) = tmpd + tmpveca(4) = tmpe + tmpveca(5) = tmpa + tmpveca(6) = tmpb + tmpveca(11:19) = tmpvecb(11:19) + end if + if ((idiagbb > 0) .and. (abs(tmpg) > rerrtol1_mbal)) then + write(lundiagbb,'(/a,i10,3i5,1p,6e11.3,2x,a)') & + 'chem_cup_1d massbal final -', ktau, grid_id, i, j, & + tmpg, (tmpd-tmpe), tmpd, tmpe, tmpa, tmpb, chem_name(l) + write(lundiagbb,'(2a,1p,8e11.3)') & + 'zav_del_chem_activa, resusp, ', & + 'aqchem, wetrem, ztrans, residu', tmpvecb(11:16) + write(lundiagbb,'(2a,1p,8e11.3)') & + 'zav_del_chem_actvbb, respbb, ', & + 'aqchbb ', tmpvecb(17:19) + end if + end do ! l + + if (idiagaa > 0) then + msg = 'perfect' ; if (itmpa > 0) msg = chem_name(itmpa) + write(lundiag,'(/a,i10,3i5,1p,6e11.3,2x,a)') & + 'chem_cup_1d massbal worst final -', & + ktau, grid_id, i, j, tmpveca(1:6), msg(1:12) + write(lundiag,'(2a,1p,8e11.3)') & + 'zav_del_chem_activa, resusp, ', & + 'aqchem, wetrem, ztrans, residu', tmpveca(11:16) + write(lundiag,'(2a,1p,8e11.3)') & + 'zav_del_chem_actvbb, respbb, ', & + 'aqchbb ', tmpveca(17:19) + end if + + +! diagnostics + if (idiagaa > 0) then + call chem_cup_1d_diags_pt41( & + lundiag, 2, & + kts, kte, ktep1, p1st, num_chem, & + ktau, grid_id, i, j, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nphase_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, & + massptr_aer, numptr_aer, & + lptr_cl_aer, lptr_nh4_aer, lptr_no3_aer, lptr_oin_aer, lptr_so4_aer, & + rhodz, rhodzsum, & + chem, chem_av_new, & + zav_del_chem_actvbb, zav_del_chem_aqchbb, & + zav_del_chem_resdbb, zav_del_chem_respbb, & + zav_del_chem_totlbb, zav_del_chem_wetrem, & + chem_name ) + end if ! (idiagaa > 0) + + +! put final mixing ratios into chem + chem(:,:) = chem_av_new(:,:) + + +79000 continue ! "goto 79000" means no inactive cloud calcs + + +! calculate average in-convective-cloud mixing ratios +! The code below calculates average in-convective-cloud mixing ratios +! Commented out by Manish Shrivastava on 05/14/2013 because we wanted to look at just the active part values of CO_IC_CUP and other variables +!-------------------------------------------------------------------------------- +! do k = kcldbot, kcldtop +! if (af_up(k) < 0.5*af_up_smallaa) then + +! if (ido_inact(k) <= 0) then +! cycle ! note that chem_incu and chem_cupflag are initialized +! ! to zero, so those will be the values at this level +! else +! tmpa = 0.0_r8 ; tmpb = 1.0_r8 +! end if +! else +! if (ido_inact(k) <= 0) then +! tmpa = 1.0_r8 ; tmpb = 0.0_r8 +! else +! tmpa = af_up(k)/(af_up(k) + af_inact(k)) +! tmpa = max( 0.0_r8, min( 1.0_r8, tmpa ) ) +! tmpb = 1.0_r8 - tmpa +! end if +! end if +!--------------------------------------------------------------------------------- + +!The code below was changed by Easter Richard to calculate just active part cloud values +!It has changes so that the chem_incu will be equal to the updraft mixing ratios, +!Rather than area-weighted average of updraft and inactive cloud. + +!------------------------------------------------------------------------------------ + do k = kcldbot, kcldtop + if (af_up(k) < 0.5*af_up_smallaa) then + + cycle ! change to make chem_incu = chem_up (but no updraft at this k) + else + tmpa = 1.0_r8 ; tmpb = 0.0_r8 ! change to make chem_incu = chem_up + end if +!----------------------------------------------------------------------------------------------- + ! chem_up(k,:) is at top of layer k + ! when k>kcldbot, use an average of the k and k+1 values + ! when k=kcldbot, use the k+1 values because the k values are essentially + ! clear air (at the top of the last sub-cloud-base layer) + if (k == kcldbot) then + chem_incu(k,:) = tmpa*chem_up(k+1,:) + tmpb*chem_inact_new(k,:) + else + chem_incu(k,:) = tmpa*0.5*(chem_up(k,:)+chem_up(k+1,:)) + tmpb*chem_inact_new(k,:) + end if + chem_cupflag(k) = 1 + end do + + if (idiagaa > 0) then + call chem_cup_1d_diags_pt71( & + lundiag, kcldbot, kcldtop, & + kts, kte, ktep1, p1st, num_chem, & + ktau, grid_id, i, j, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nphase_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, & + massptr_aer, numptr_aer, & + lptr_cl_aer, lptr_nh4_aer, lptr_no3_aer, lptr_oin_aer, lptr_so4_aer, & + af_up, af_inact, & + chem_av_new, chem_up, chem_inact_new, chem_incu, & + chem_name ) + end if + + +89000 continue ! "goto 89000" means check_adjust_inputs failed + if (idiagaa > 0) write(lundiag,'(/a,4i10)') & + 'chem_cup_1d done ktau, id, i, j =', ktau, grid_id, i, j + + return + end subroutine chem_cup_1d + + +!------------------------------------------------------------------------------- + subroutine chem_cup_1d_diags_pt21( & + lundiag_inp, kdiagbot, kdiagtop, & + kts, kte, ktep1, p1st, num_chem, & + ktau, grid_id, i, j, jtsub, ntsub, & + ishall, do_dndraft, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nphase_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, & + massptr_aer, numptr_aer, & + lptr_cl_aer, lptr_nh4_aer, lptr_no3_aer, lptr_oin_aer, lptr_so4_aer, & + rhodz, rhodzsum, & + chem_av_new, chem_av_old, chem_up, chem_dn, & + zav_chem_av_new, zav_chem_av_old, zav_chem_up, zav_chem_dn, & + zav_del_chem_activa, zav_del_chem_aqchem, & + zav_del_chem_residu, zav_del_chem_resusp, & + zav_del_chem_wetrem, zav_del_chem_ztrans, & + zav_del_chem_totall, & + chem_name ) + + use module_configure, only: & + p_qc, & + p_h2o2, p_hcl, p_hno3, p_nh3, p_so2, p_sulf + +! arguments + integer, intent(in) :: lundiag_inp + integer, intent(in) :: kts, kte, ktep1, p1st, num_chem + integer, intent(in) :: ktau, grid_id, i, j, jtsub, ntsub + integer, intent(in) :: kdiagbot, kdiagtop + integer, intent(in) :: ishall + + integer, intent(in) :: maxd_acomp, maxd_aphase, maxd_atype, maxd_asize + integer, intent(in) :: & + nphase_aer, ntype_aer, & + ai_phase, cw_phase, & + nsize_aer( maxd_atype ), & + ncomp_aer( maxd_atype ), & + massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & + numptr_aer( maxd_asize, maxd_atype, maxd_aphase ), & + lptr_so4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_oin_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_no3_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_nh4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_cl_aer(maxd_asize, maxd_atype, maxd_aphase) + + logical, intent(in) :: do_dndraft + + real(r8), intent(in) :: rhodzsum + + real(r8), intent(in), dimension(kts:kte) :: rhodz + + real(r8), intent(in), dimension(kts:kte,1:num_chem) :: & + chem_av_new, chem_av_old + + real(r8), intent(in), dimension(kts:ktep1,1:num_chem) :: chem_up, chem_dn + + real(r8), intent(in), dimension(1:num_chem) :: & + zav_chem_av_new, zav_chem_av_old, zav_chem_up, zav_chem_dn, & + zav_del_chem_activa, zav_del_chem_aqchem, & + zav_del_chem_residu, zav_del_chem_resusp, & + zav_del_chem_wetrem, zav_del_chem_ztrans, & + zav_del_chem_totall + + character(len=12), intent(in) :: chem_name(num_chem) + +! local variables + integer, parameter :: mxg_max=100, nxg_max=8 + integer :: aip, cwp, typ + integer :: isize, itype, itmpa + integer :: l, l2, l3, lundiag + integer :: lxg(nxg_max,mxg_max) + integer :: k + integer :: m, mxg + integer :: n, nxg(mxg_max) + + real(r8) :: fxg(nxg_max,mxg_max) + real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpg + real(r8) :: tmpveca(num_chem) + + character(len=80) :: fmtaa, fmtbb, fmtcc, fmtdd, fmtee + + + lundiag = lundiag_inp +! lundiag = 122 + + m = 1 + nxg(m) = 3 + lxg(1:nxg(m),m) = (/ p_h2o2, p_so2, p_sulf /) + fxg(1:nxg(m),m) = 1.0e3 + m = m + 1 + nxg(m) = 2 + lxg(1:nxg(m),m) = (/ p_nh3, p_hno3 /) + fxg(1:nxg(m),m) = 1.0e3 + + aip = ai_phase ; cwp = cw_phase + typ = 1 ! aerosol type + if (cw_phase > 0) then + n = 2 ! size bin + m = m + 1 + nxg(m) = 2 + lxg(1:nxg(m),m) = (/ lptr_so4_aer(n,typ,aip), lptr_so4_aer(n,typ,cwp) /) + fxg(1:nxg(m),m) = 28.966/96.0 + m = m + 1 + nxg(m) = 2 + lxg(1:nxg(m),m) = (/ lptr_nh4_aer(n,typ,aip), lptr_nh4_aer(n,typ,cwp) /) + fxg(1:nxg(m),m) = 28.966/18.0 + m = m + 1 + nxg(m) = 2 + lxg(1:nxg(m),m) = (/ lptr_no3_aer(n,typ,aip), lptr_no3_aer(n,typ,cwp) /) + fxg(1:nxg(m),m) = 28.966/62.0 + m = m + 1 + nxg(m) = 2 + lxg(1:nxg(m),m) = (/ numptr_aer(n,typ,aip), numptr_aer(n,typ,cwp) /) + fxg(1:nxg(m),m) = 1.0e-6 + else + n = 2 ! size bin + m = m + 1 + nxg(m) = 2 + lxg(1:nxg(m),m) = (/ lptr_so4_aer(n,typ,aip), lptr_nh4_aer(n,typ,aip) /) + fxg(1:nxg(m),m) = (/ 28.966/96.0, 28.966/18.0 /) + m = m + 1 + nxg(m) = 2 + lxg(1:nxg(m),m) = (/ lptr_no3_aer(n,typ,aip), numptr_aer(n,typ,aip) /) + fxg(1:nxg(m),m) = (/ 28.966/62.0, 1.0e-6 /) + end if + mxg = m + + + write(lundiag,'(/a,i10,5i5)') & + 'chem_cup_1d_diags_pt21 - ktau, id, i, j =', ktau, grid_id, i, j + do m = 1, mxg + n = nxg(m) + write(lundiag,'(a9,2i3,3x,5(i5, 8x ))') 'm, n, lxg', m, n, (lxg(l2,m), l2=1,n) + write(lundiag,'(15x, 3x,5(a12,1x ))') (chem_name(lxg(l2,m)), l2=1,n) + write(lundiag,'(15x, 5(1p,e13.3))') (fxg(l2,m), l2=1,n) + end do + write(lundiag,'(/2a)') '*** units for following: ', & + 'trace gas and aerosol mass = ppb, aerosol number = #/mg' + + + write(lundiag,'(/a,i10,5i5)') & + 'ktau, jtsub, ntsub, id, i, j =', ktau, jtsub, ntsub, grid_id, i, j + + do m = 1, mxg +! cycle + n = nxg(m) + if ( do_dndraft ) then + if (n == 3) then + fmtaa = '(/4x, 4(3x,a33 ))' + fmtbb = '( 4x, 4(3x,3a11 ))' + fmtcc = '( i2, 1p,4(3x,3e11.3))' + fmtdd = '(90x,a20,1p,3x,3e11.3)' + else + fmtaa = '(/4x, 4(3x,a22 ))' + fmtbb = '( 4x, 4(3x,2a11 ))' + fmtcc = '( i2, 1p,4(3x,2e11.3))' + fmtdd = '(57x,a20,1p,3x,2e11.3)' + end if + else + if (n == 3) then + fmtaa = '(/4x, 3(3x,a33 ))' + fmtbb = '( 4x, 3(3x,3a11 ))' + fmtcc = '( i2, 1p,3(3x,3e11.3))' + fmtdd = '(54x,a20,1p,3x,3e11.3)' + else + fmtaa = '(/4x, 3(3x,a22 ))' + fmtbb = '( 4x, 3(3x,2a11 ))' + fmtcc = '( i2, 1p,3(3x,2e11.3))' + fmtdd = '(32x,a20,1p,3x,2e11.3)' + end if + end if + + if ( do_dndraft ) then + write(lundiag,fmtaa) & + 'chem_up ', & + 'chem_dn ', & + 'chem_av_old ', & + 'chem_av_new ' + write(lundiag,fmtbb) & + ( ( chem_name(lxg(l2,m)), l2=1,n ), l3=1,4 ) + else + write(lundiag,fmtaa) & + 'chem_up ', & + 'chem_av_old ', & + 'chem_av_new ' + write(lundiag,fmtbb) & + ( ( chem_name(lxg(l2,m)), l2=1,n ), l3=1,3 ) + end if + + itmpa = 0 + do l2 = 1, n + l = lxg(l2,n) + if (zav_chem_up(l) /= 0.0_r8 ) then + itmpa = 1 + cycle + end if + tmpa = 0.0 + do k = kts, kte + tmpa = max( tmpa, abs( chem_av_new(k,l)-chem_av_old(k,l) ) ) + end do + if (tmpa /= 0.0_r8 ) itmpa = 1 + end do + + do k = kdiagtop, kdiagbot, -1 + if (itmpa == 0) cycle + if ( do_dndraft ) then + write(lundiag,fmtcc) k, & + ( chem_up( k,lxg(l2,m))*fxg(l2,m) , l2=1,n ), & + ( chem_dn( k,lxg(l2,m))*fxg(l2,m) , l2=1,n ), & + ( chem_av_old(k,lxg(l2,m))*fxg(l2,m) , l2=1,n ), & + ( chem_av_new(k,lxg(l2,m))*fxg(l2,m) , l2=1,n ) + else + write(lundiag,fmtcc) k, & + ( chem_up( k,lxg(l2,m))*fxg(l2,m) , l2=1,n ), & + ( chem_av_old(k,lxg(l2,m))*fxg(l2,m) , l2=1,n ), & + ( chem_av_new(k,lxg(l2,m))*fxg(l2,m) , l2=1,n ) + end if + end do ! k + if (itmpa > 0) write(lundiag,'(a)') + if ( do_dndraft ) then + write(lundiag,fmtcc) -1, & + ( zav_chem_up( lxg(l2,m))*fxg(l2,m) , l2=1,n ), & + ( zav_chem_dn( lxg(l2,m))*fxg(l2,m) , l2=1,n ), & + ( zav_chem_av_old(lxg(l2,m))*fxg(l2,m) , l2=1,n ), & + ( zav_chem_av_new(lxg(l2,m))*fxg(l2,m) , l2=1,n ) + else + write(lundiag,fmtcc) -1, & + ( zav_chem_up( lxg(l2,m))*fxg(l2,m) , l2=1,n ), & + ( zav_chem_av_old(lxg(l2,m))*fxg(l2,m) , l2=1,n ), & + ( zav_chem_av_new(lxg(l2,m))*fxg(l2,m) , l2=1,n ) + end if + write(lundiag,fmtdd) & + 'zav_del_chem_totall ', & + ( zav_del_chem_totall(lxg(l2,m))*fxg(l2,m) , l2=1,n ) + if (itmpa == 0) cycle + write(lundiag,fmtdd) & + 'zav_del_chem_aqchem ', & + ( zav_del_chem_aqchem(lxg(l2,m))*fxg(l2,m) , l2=1,n ) + write(lundiag,fmtdd) & + 'zav_del_chem_wetrem ', & + ( zav_del_chem_wetrem(lxg(l2,m))*fxg(l2,m) , l2=1,n ) + write(lundiag,fmtdd) & + 'zav_del_chem_activa ', & + ( zav_del_chem_activa(lxg(l2,m))*fxg(l2,m) , l2=1,n ) + write(lundiag,fmtdd) & + 'zav_del_chem_resusp ', & + ( zav_del_chem_resusp(lxg(l2,m))*fxg(l2,m) , l2=1,n ) + write(lundiag,fmtdd) & + 'zav_del_chem_ztrans ', & + ( zav_del_chem_ztrans(lxg(l2,m))*fxg(l2,m) , l2=1,n ) + write(lundiag,fmtdd) & + 'zav_del_chem_residu ', & + ( zav_del_chem_residu(lxg(l2,m))*fxg(l2,m) , l2=1,n ) + end do ! m = 1, mxg + + + tmpveca(p1st:num_chem) = zav_del_chem_aqchem(p1st:num_chem) + write(lundiag,'(/a)') 'zav_del_chem_aqchem summary' + + write(lundiag,'(a,1p,10e12.4)') 'h2o2 ', & + tmpveca(p_h2o2)*1.0e3 + + tmpb = tmpveca(p_so2) + tmpveca(p_sulf) + write(lundiag,'(a,1p,10e12.4)') 'so2+h2so4, individ ', & + tmpb*1.0e3, & + tmpveca(p_so2)*1.0e3, & + tmpveca(p_sulf)*1.0e3 + itype = 1 + tmpa = 28.966/96.0 ; tmpb = 0.0 + do isize = 1, nsize_aer(itype) + tmpb = tmpb + tmpveca(lptr_so4_aer(isize,itype,cw_phase)) + end do + write(lundiag,'(a,1p,10e12.4)') 'so4_cw total, individ', & + tmpb*tmpa, & + ( tmpveca(lptr_so4_aer(isize,itype,cw_phase))*tmpa, isize=1,nsize_aer(itype) ) + + write(lundiag,'(a,1p,10e12.4)') 'nh3 ', & + tmpveca(p_nh3)*1.0e3 + tmpa = 28.966/18.0 ; tmpb = 0.0 + do isize = 1, nsize_aer(itype) + tmpb = tmpb + tmpveca(lptr_nh4_aer(isize,itype,cw_phase)) + end do + write(lundiag,'(a,1p,10e12.4)') 'nh4_cw total, individ', & + tmpb*tmpa, & + ( tmpveca(lptr_nh4_aer(isize,itype,cw_phase))*tmpa, isize=1,nsize_aer(itype) ) + + write(lundiag,'(a,1p,10e12.4)') 'hno3 ', & + tmpveca(p_hno3)*1.0e3 + tmpa = 28.966/62.0 ; tmpb = 0.0 + do isize = 1, nsize_aer(itype) + tmpb = tmpb + tmpveca(lptr_no3_aer(isize,itype,cw_phase)) + end do + write(lundiag,'(a,1p,10e12.4)') 'no3_cw total, individ', & + tmpb*tmpa, & + ( tmpveca(lptr_no3_aer(isize,itype,cw_phase))*tmpa, isize=1,nsize_aer(itype) ) + + write(lundiag,'(a,1p,10e12.4)') 'hcl ', & + tmpveca(p_hcl)*1.0e3 + tmpa = 28.966/35.5 ; tmpb = 0.0 + do isize = 1, nsize_aer(itype) + tmpb = tmpb + tmpveca(lptr_cl_aer(isize,itype,cw_phase)) + end do + write(lundiag,'(a,1p,10e12.4)') 'cl_cw total, individ', & + tmpb*tmpa, & + ( tmpveca(lptr_cl_aer(isize,itype,cw_phase))*tmpa, isize=1,nsize_aer(itype) ) + + tmpa = 1.0e-6 ; tmpb = 0.0 + do isize = 1, nsize_aer(itype) + tmpb = tmpb + tmpveca(numptr_aer(isize,itype,cw_phase)) + end do + write(lundiag,'(a,1p,10e12.4)') 'num_cw total, individ', & + tmpb*tmpa, & + ( tmpveca(numptr_aer(isize,itype,cw_phase))*tmpa, isize=1,nsize_aer(itype) ) + + + + + return + end subroutine chem_cup_1d_diags_pt21 + + +!------------------------------------------------------------------------------- + subroutine chem_cup_1d_diags_pt41( & + lundiag_inp, iflagaa, & + kts, kte, ktep1, p1st, num_chem, & + ktau, grid_id, i, j, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nphase_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, & + massptr_aer, numptr_aer, & + lptr_cl_aer, lptr_nh4_aer, lptr_no3_aer, lptr_oin_aer, lptr_so4_aer, & + rhodz, rhodzsum, & + chem_av_old, chem_av_new, & + zav_del_chem_actvbb, zav_del_chem_aqchbb, & + zav_del_chem_resdbb, zav_del_chem_respbb, & + zav_del_chem_totlbb, zav_del_chem_wetrem, & + chem_name ) + + use module_configure, only: & + p_qc, & + p_h2o2, p_hcl, p_hno3, p_nh3, p_so2, p_sulf + +! arguments + integer, intent(in) :: lundiag_inp, iflagaa + integer, intent(in) :: kts, kte, ktep1, p1st, num_chem + integer, intent(in) :: ktau, grid_id, i, j + + integer, intent(in) :: maxd_acomp, maxd_aphase, maxd_atype, maxd_asize + integer, intent(in) :: & + nphase_aer, ntype_aer, & + ai_phase, cw_phase, & + nsize_aer( maxd_atype ), & + ncomp_aer( maxd_atype ), & + massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & + numptr_aer( maxd_asize, maxd_atype, maxd_aphase ), & + lptr_so4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_oin_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_no3_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_nh4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_cl_aer(maxd_asize, maxd_atype, maxd_aphase) + + real(r8), intent(in) :: rhodzsum + + real(r8), intent(in), dimension(kts:kte) :: rhodz + + real(r8), intent(in), dimension(kts:kte,1:num_chem) :: chem_av_old, chem_av_new + + real(r8), intent(in), dimension(1:num_chem) :: & + zav_del_chem_actvbb, zav_del_chem_aqchbb, & + zav_del_chem_resdbb, zav_del_chem_respbb, & + zav_del_chem_totlbb, zav_del_chem_wetrem + + character(len=12), intent(in) :: chem_name(num_chem) + +! local variables + integer :: isize, itype + integer :: l, lundiag + integer :: m + real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpg, tmph, tmpi, tmpj, tmpk + real(r8) :: tmpveca(num_chem) + + + lundiag = lundiag_inp +! lundiag = 122 + + if (iflagaa <= 1) then + write(lundiag,'(/a,i10,5i5)') & + 'chem_cup_1d_diags_pt41 - ktau, id, i, j =', ktau, grid_id, i, j + else + write(lundiag,'(/a,i10,5i5)') & + 'chem_cup_1d_diags_pt42 - ktau, id, i, j =', ktau, grid_id, i, j + end if + + do m = 1, 9 + + if (iflagaa <= 1) then + if (m > 6) cycle + else + if (m < 7) cycle + end if + + if (m == 1) then + tmpveca(p1st:num_chem) = zav_del_chem_actvbb(p1st:num_chem) + write(lundiag,'(/a)') 'inactive zav_del_chem_actvbb summary' + else if (m == 2) then + tmpveca(p1st:num_chem) = zav_del_chem_aqchbb(p1st:num_chem) + write(lundiag,'(/a)') 'inactive zav_del_chem_aqchbb summary' + else if (m == 3) then + tmpveca(p1st:num_chem) = zav_del_chem_respbb(p1st:num_chem) + write(lundiag,'(/a)') 'inactive zav_del_chem_respbb summary' + else if (m == 4) then + tmpveca(p1st:num_chem) = zav_del_chem_totlbb(p1st:num_chem) + write(lundiag,'(/a)') 'inactive zav_del_chem_totlbb summary' + else if (m == 5) then + tmpveca(p1st:num_chem) = zav_del_chem_resdbb(p1st:num_chem) + write(lundiag,'(/a)') 'inactive zav_del_chem_resdbb summary' + else if (m == 6) then + do l = p1st, num_chem + tmpveca(l) = sum( rhodz(kts:kte)*chem_av_old(kts:kte,l) ) / rhodzsum + end do + write(lundiag,'(/a)') 'inactive zav_chem_av_old summary' + else if (m == 7) then + do l = p1st, num_chem + tmpveca(l) = sum( rhodz(kts:kte)*chem_av_old(kts:kte,l) ) / rhodzsum + end do + write(lundiag,'(/a)') '***final zav_chem_av_old summary' + else if (m == 8) then + do l = p1st, num_chem + tmpveca(l) = sum( rhodz(kts:kte)*chem_av_new(kts:kte,l) ) / rhodzsum + end do + write(lundiag,'(/a)') '***final zav_chem_av_new summary' + else if (m == 9) then + do l = p1st, num_chem + tmpveca(l) = sum( rhodz(kts:kte)* & + (chem_av_new(kts:kte,l)-chem_av_old(kts:kte,l)) ) / rhodzsum + end do + write(lundiag,'(/a)') '***final zav_chem_av_del summary' + else + cycle + end if + + write(lundiag,'(a,1p,10e12.4)') 'h2o2 ', & + tmpveca(p_h2o2)*1.0e3 + + tmpg = tmpveca(p_so2) + tmpveca(p_sulf) + write(lundiag,'(a,1p,10e12.4)') 'so2+h2so4, individ ', & + tmpg*1.0e3, & + tmpveca(p_so2)*1.0e3, & + tmpveca(p_sulf)*1.0e3 + itype = 1 + tmpe = 28.966/96.0 ; tmpa = 0.0_r8 ; tmpc = 0.0_r8 + tmpi = 0.0_r8 ; tmpj = 0.0_r8 + do isize = 1, nsize_aer(itype) + tmpa = tmpa + tmpveca(lptr_so4_aer(isize,itype,ai_phase)) + tmpc = tmpc + tmpveca(lptr_so4_aer(isize,itype,cw_phase)) + tmpi = tmpi + zav_del_chem_wetrem(lptr_so4_aer(isize,itype,ai_phase)) + tmpj = tmpj + zav_del_chem_wetrem(lptr_so4_aer(isize,itype,cw_phase)) + end do + write(lundiag,'(a,1p,10e12.4)') 'so4_a total, individ', & + tmpa*tmpe, & + ( tmpveca(lptr_so4_aer(isize,itype,ai_phase))*tmpe, isize=1,nsize_aer(itype) ) + write(lundiag,'(a,1p,10e12.4)') 'so4_cw total, individ', & + tmpc*tmpe, & + ( tmpveca(lptr_so4_aer(isize,itype,cw_phase))*tmpe, isize=1,nsize_aer(itype) ) + if (m >= 7) then + tmph = tmpg*1.0e3 + (tmpa+tmpc)*tmpe + write(lundiag,'(a,1p,10e12.4)') ' all total ', tmph + if (m <= 8) then + write(lundiag,'(a,1p,10e12.4)') ' all total ', tmph + else + tmpk = (tmpi+tmpj)*tmpe & + + (zav_del_chem_wetrem(p_so2)+zav_del_chem_wetrem(p_sulf))*1.0e3 + write(lundiag,'(a,1p,10e12.4)') ' all othr, wet, tot', (tmph-tmpk), tmpk, tmph + end if + end if + + write(lundiag,'(a,1p,10e12.4)') 'nh3 ', & + tmpveca(p_nh3)*1.0e3 + tmpe = 28.966/18.0 ; tmpa = 0.0_r8 ; tmpc = 0.0_r8 + tmpi = 0.0_r8 ; tmpj = 0.0_r8 + do isize = 1, nsize_aer(itype) + tmpa = tmpa + tmpveca(lptr_nh4_aer(isize,itype,ai_phase)) + tmpc = tmpc + tmpveca(lptr_nh4_aer(isize,itype,cw_phase)) + tmpi = tmpi + zav_del_chem_wetrem(lptr_nh4_aer(isize,itype,ai_phase)) + tmpj = tmpj + zav_del_chem_wetrem(lptr_nh4_aer(isize,itype,cw_phase)) + end do + write(lundiag,'(a,1p,10e12.4)') 'nh4_a total, individ', & + tmpa*tmpe, & + ( tmpveca(lptr_nh4_aer(isize,itype,ai_phase))*tmpe, isize=1,nsize_aer(itype) ) + write(lundiag,'(a,1p,10e12.4)') 'nh4_cw total, individ', & + tmpc*tmpe, & + ( tmpveca(lptr_nh4_aer(isize,itype,cw_phase))*tmpe, isize=1,nsize_aer(itype) ) + if (m >= 7) then + tmph = tmpveca(p_nh3)*1.0e3 + (tmpa+tmpc)*tmpe + write(lundiag,'(a,1p,10e12.4)') ' all total ', tmph + if (m <= 8) then + write(lundiag,'(a,1p,10e12.4)') ' all total ', tmph + else + tmpk = (tmpi+tmpj)*tmpe + zav_del_chem_wetrem(p_nh3)*1.0e3 + write(lundiag,'(a,1p,10e12.4)') ' all othr, wet, tot', (tmph-tmpk), tmpk, tmph + end if + end if + + write(lundiag,'(a,1p,10e12.4)') 'hno3 ', & + tmpveca(p_hno3)*1.0e3 + tmpe = 28.966/62.0 ; tmpa = 0.0_r8 ; tmpc = 0.0_r8 + tmpi = 0.0_r8 ; tmpj = 0.0_r8 + do isize = 1, nsize_aer(itype) + tmpa = tmpa + tmpveca(lptr_no3_aer(isize,itype,ai_phase)) + tmpc = tmpc + tmpveca(lptr_no3_aer(isize,itype,cw_phase)) + tmpi = tmpi + zav_del_chem_wetrem(lptr_no3_aer(isize,itype,ai_phase)) + tmpj = tmpj + zav_del_chem_wetrem(lptr_no3_aer(isize,itype,cw_phase)) + end do + write(lundiag,'(a,1p,10e12.4)') 'no3_a total, individ', & + tmpa*tmpe, & + ( tmpveca(lptr_no3_aer(isize,itype,ai_phase))*tmpe, isize=1,nsize_aer(itype) ) + write(lundiag,'(a,1p,10e12.4)') 'no3_cw total, individ', & + tmpc*tmpe, & + ( tmpveca(lptr_no3_aer(isize,itype,cw_phase))*tmpe, isize=1,nsize_aer(itype) ) + if (m >= 7) then + tmph = tmpveca(p_hno3)*1.0e3 + (tmpa+tmpc)*tmpe + write(lundiag,'(a,1p,10e12.4)') ' all total ', tmph + if (m <= 8) then + write(lundiag,'(a,1p,10e12.4)') ' all total ', tmph + else + tmpk = (tmpi+tmpj)*tmpe + zav_del_chem_wetrem(p_hno3)*1.0e3 + write(lundiag,'(a,1p,10e12.4)') ' all othr, wet, tot', (tmph-tmpk), tmpk, tmph + end if + end if + + write(lundiag,'(a,1p,10e12.4)') 'hcl ', & + tmpveca(p_hcl)*1.0e3 + tmpe = 28.966/35.5 ; tmpa = 0.0_r8 ; tmpc = 0.0_r8 + tmpi = 0.0_r8 ; tmpj = 0.0_r8 + do isize = 1, nsize_aer(itype) + tmpa = tmpa + tmpveca(lptr_cl_aer(isize,itype,ai_phase)) + tmpc = tmpc + tmpveca(lptr_cl_aer(isize,itype,cw_phase)) + tmpi = tmpi + zav_del_chem_wetrem(lptr_cl_aer(isize,itype,ai_phase)) + tmpj = tmpj + zav_del_chem_wetrem(lptr_cl_aer(isize,itype,cw_phase)) + end do + write(lundiag,'(a,1p,10e12.4)') 'cl_a total, individ', & + tmpa*tmpe, & + ( tmpveca(lptr_cl_aer(isize,itype,ai_phase))*tmpe, isize=1,nsize_aer(itype) ) + write(lundiag,'(a,1p,10e12.4)') 'cl_cw total, individ', & + tmpc*tmpe, & + ( tmpveca(lptr_cl_aer(isize,itype,cw_phase))*tmpe, isize=1,nsize_aer(itype) ) + if (m >= 7) then + tmph = tmpveca(p_hcl)*1.0e3 + (tmpa+tmpc)*tmpe + if (m <= 8) then + write(lundiag,'(a,1p,10e12.4)') ' all total ', tmph + else + tmpk = (tmpi+tmpj)*tmpe + zav_del_chem_wetrem(p_hcl)*1.0e3 + write(lundiag,'(a,1p,10e12.4)') ' all othr, wet, tot', (tmph-tmpk), tmpk, tmph + end if + end if + + tmpe = 1.0e-6 ; tmpa = 0.0_r8 ; tmpc = 0.0_r8 + tmpi = 0.0_r8 ; tmpj = 0.0_r8 + do isize = 1, nsize_aer(itype) + tmpa = tmpa + tmpveca(numptr_aer(isize,itype,ai_phase)) + tmpc = tmpc + tmpveca(numptr_aer(isize,itype,cw_phase)) + tmpi = tmpi + zav_del_chem_wetrem(numptr_aer(isize,itype,ai_phase)) + tmpj = tmpj + zav_del_chem_wetrem(numptr_aer(isize,itype,cw_phase)) + end do + write(lundiag,'(a,1p,10e12.4)') 'num_a total, individ', & + tmpa*tmpe, & + ( tmpveca(numptr_aer(isize,itype,ai_phase))*tmpe, isize=1,nsize_aer(itype) ) + write(lundiag,'(a,1p,10e12.4)') 'num_cw total, individ', & + tmpc*tmpe, & + ( tmpveca(numptr_aer(isize,itype,cw_phase))*tmpe, isize=1,nsize_aer(itype) ) + if (m >= 7) then + tmph = (tmpa+tmpc)*tmpe + if (m <= 8) then + write(lundiag,'(a,1p,10e12.4)') ' all total ', tmph + else + tmpk = (tmpi+tmpj)*tmpe + write(lundiag,'(a,1p,10e12.4)') ' all othr, wet, tot', (tmph-tmpk), tmpk, tmph + end if + end if + + end do ! m = 1, 6 + + return + end subroutine chem_cup_1d_diags_pt41 + + +!------------------------------------------------------------------------------- + subroutine chem_cup_1d_diags_pt71( & + lundiag_inp, kcldbot, kcldtop, & + kts, kte, ktep1, p1st, num_chem, & + ktau, grid_id, i, j, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nphase_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, & + massptr_aer, numptr_aer, & + lptr_cl_aer, lptr_nh4_aer, lptr_no3_aer, lptr_oin_aer, lptr_so4_aer, & + af_up, af_inact, & + chem_av_new, chem_up, chem_inact_new, chem_incu, & + chem_name ) + + use module_configure, only: & + p_qc, & + p_h2o2, p_hcl, p_hno3, p_nh3, p_so2, p_sulf + +! arguments + integer, intent(in) :: lundiag_inp, kcldbot, kcldtop + integer, intent(in) :: kts, kte, ktep1, p1st, num_chem + integer, intent(in) :: ktau, grid_id, i, j + + integer, intent(in) :: maxd_acomp, maxd_aphase, maxd_atype, maxd_asize + integer, intent(in) :: & + nphase_aer, ntype_aer, & + ai_phase, cw_phase, & + nsize_aer( maxd_atype ), & + ncomp_aer( maxd_atype ), & + massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & + numptr_aer( maxd_asize, maxd_atype, maxd_aphase ), & + lptr_so4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_oin_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_no3_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_nh4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_cl_aer(maxd_asize, maxd_atype, maxd_aphase) + + real(r8), intent(in), dimension(kts:kte) :: af_up, af_inact + + real(r8), intent(in), dimension(kts:kte,1:num_chem) :: & + chem_av_new, chem_inact_new, chem_incu + + real(r8), intent(in), dimension(kts:ktep1,1:num_chem) :: chem_up + + character(len=12), intent(in) :: chem_name(num_chem) + +! local variables + integer :: k, n, n2 + integer :: lundiag + real(r8) :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpg, tmph, tmpi, tmpj, tmpk + real(r8) :: tmpveca(num_chem) + + + lundiag = lundiag_inp +! lundiag = 122 + + write(lundiag,'(/a,i10,5i5)') & + 'chem_cup_1d_diags_pt71 - ktau, id, i, j =', ktau, grid_id, i, j + + n2 = (nsize_aer(1)+1)/2 + + write(lundiag,'(/a,i2.2,a,i2.2,a)') & + 'af_up, af_inact; so4_a01:', n2, & + ' gridav/up/inact/incu; so4_cw01:', n2, ' ...' + tmpa = (28.966/96.0) + do k = kcldtop+1, kts, -1 + tmpveca = 0.0 + do n = 1, (nsize_aer(1)+1)/2 + tmpveca(1) = tmpveca(1) + chem_av_new( k,lptr_so4_aer(n,1,1)) + tmpveca(2) = tmpveca(2) + chem_up( k,lptr_so4_aer(n,1,1)) + tmpveca(3) = tmpveca(3) + chem_inact_new(k,lptr_so4_aer(n,1,1)) + tmpveca(4) = tmpveca(4) + chem_incu( k,lptr_so4_aer(n,1,1)) + tmpveca(5) = tmpveca(5) + chem_av_new( k,lptr_so4_aer(n,1,2)) + tmpveca(6) = tmpveca(6) + chem_up( k,lptr_so4_aer(n,1,2)) + tmpveca(7) = tmpveca(7) + chem_inact_new(k,lptr_so4_aer(n,1,2)) + tmpveca(8) = tmpveca(8) + chem_incu( k,lptr_so4_aer(n,1,2)) + end do + write(lundiag,'(i3,2x,2f8.5,1p,2(2x,4e10.2))') & + k, af_up(k), af_inact(k), tmpveca(1:8)*tmpa + end do + + write(lundiag,'(/a,i2.2,a,i2.2,a)') & + 'af_up, af_inact; no3_a01:', n2, & + ' gridav/up/inact/incu; no3_cw01:', n2, ' ...' + tmpa = (28.966/62.0) + do k = kcldtop+1, kts, -1 + tmpveca = 0.0 + do n = 1, (nsize_aer(1)+1)/2 + tmpveca(1) = tmpveca(1) + chem_av_new( k,lptr_no3_aer(n,1,1)) + tmpveca(2) = tmpveca(2) + chem_up( k,lptr_no3_aer(n,1,1)) + tmpveca(3) = tmpveca(3) + chem_inact_new(k,lptr_no3_aer(n,1,1)) + tmpveca(4) = tmpveca(4) + chem_incu( k,lptr_no3_aer(n,1,1)) + tmpveca(5) = tmpveca(5) + chem_av_new( k,lptr_no3_aer(n,1,2)) + tmpveca(6) = tmpveca(6) + chem_up( k,lptr_no3_aer(n,1,2)) + tmpveca(7) = tmpveca(7) + chem_inact_new(k,lptr_no3_aer(n,1,2)) + tmpveca(8) = tmpveca(8) + chem_incu( k,lptr_no3_aer(n,1,2)) + end do + write(lundiag,'(i3,2x,2f8.5,1p,2(2x,4e10.2))') & + k, af_up(k), af_inact(k), tmpveca(1:8)*tmpa + end do + + write(lundiag,'(/2a)') & + 'af_up, af_inact; so2', & + ' gridav/up/inact/incu; hno3 ...' + tmpa = 1.0e3 + do k = kcldtop+1, kts, -1 + tmpveca = 0.0 + do n = 1, (nsize_aer(1)+1)/2 + tmpveca(1) = tmpveca(1) + chem_av_new( k,p_so2) + tmpveca(2) = tmpveca(2) + chem_up( k,p_so2) + tmpveca(3) = tmpveca(3) + chem_inact_new(k,p_so2) + tmpveca(4) = tmpveca(4) + chem_incu( k,p_so2) + tmpveca(5) = tmpveca(5) + chem_av_new( k,p_hno3) + tmpveca(6) = tmpveca(6) + chem_up( k,p_hno3) + tmpveca(7) = tmpveca(7) + chem_inact_new(k,p_hno3) + tmpveca(8) = tmpveca(8) + chem_incu( k,p_hno3) + end do + write(lundiag,'(i3,2x,2f8.5,1p,2(2x,4e10.2))') & + k, af_up(k), af_inact(k), tmpveca(1:8)*tmpa + end do + + return + end subroutine chem_cup_1d_diags_pt71 + + +!------------------------------------------------------------------------------- + subroutine chem_cup_activate_up( & + lunerr, lundiag, idiagaa, & + kts, kte, p1st, num_chem, & + ktau, grid_id, i, j, k, iflagaa, & + pcen, tcen, rhocen, qcw, & + rhodz, af_up, wact, & + tmp_mf_up, tmp_mfxchem_up, dchemdt_up_activa, & + maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ncomp_aer, nsize_aer, ntype_aer, & + ai_phase, cw_phase, msectional, & + massptr_aer, numptr_aer, & + dlo_sect, dhi_sect, dens_aer, hygro_aer, sigmag_aer ) +! +! compute changes to updraft mixing ratios from aerosol activation +! as updraft air moves through layer k +! +! when iflagaa = 1 or 2, do traditional cloud-base activation +! when iflagaa = 10, do secondary activation +! + use module_mixactivate, only: activate + +! arguments + integer :: lunerr, lundiag, idiagaa + integer :: kts, kte, p1st, num_chem + integer :: ktau, grid_id, i, j, k, iflagaa + + integer :: maxd_acomp, maxd_aphase, maxd_atype, maxd_asize + integer :: & + ntype_aer, & + ai_phase, cw_phase, msectional, & + nsize_aer( maxd_atype ), & + ncomp_aer( maxd_atype ), & + massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & + numptr_aer( maxd_asize, maxd_atype, maxd_aphase ) + real(r4) :: & + dlo_sect( maxd_asize, maxd_atype ), & + dhi_sect( maxd_asize, maxd_atype ), & + dens_aer( maxd_acomp, maxd_atype ), & + hygro_aer( maxd_acomp, maxd_atype ), & + sigmag_aer(maxd_asize, maxd_atype) + + real(r8) :: pcen, tcen, rhocen, qcw + real(r8) :: rhodz, af_up, wact + real(r8) :: tmp_mf_up + real(r8) :: tmp_mfxchem_up(1:num_chem) + real(r8) :: dchemdt_up_activa(kts:kte,1:num_chem) + +! local variables + integer :: isize, itype + integer :: la, lc, l2 + real(r8) :: tmpb, tmpc + real(r8) :: tmpvol + real(r8) :: tmp_chem_up(1:num_chem) + real(r8), dimension( 1:maxd_asize, 1:maxd_atype ) :: & + fn, fm, hygro, numbr, volum + +! single precision variable used for calls to other wrf-chem routines + real(r4) :: flux_fullact_sp + real(r4) :: rhocen_sp, tcen_sp, wact_sp + real(r4) :: smax_prescribed_sp + real(r4), dimension( 1:maxd_asize, 1:maxd_atype ) :: & + fn_sp, fs_sp, fm_sp, fluxn_sp, fluxs_sp, fluxm_sp, & + hygro_sp, numbr_sp, volum_sp + +! if ( do_activa ) +! get current mixing ratios in updraft + tmp_chem_up(p1st:num_chem) = tmp_mfxchem_up(p1st:num_chem)/tmp_mf_up + +! calculate activation fractions using the abdul-razak and ghan +! parameterization (subr. activate) +! for this need aerosol number, volume, and weighted hygroscopicity for +! each aerosol type and size + hygro(:,:) = 0.0_r8 + numbr(:,:) = 0.0_r8 + volum(:,:) = 0.0_r8 + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + la = numptr_aer(isize,itype,ai_phase) + numbr(isize,itype) = numbr(isize,itype) + max( 0.0_r8, tmp_chem_up(la) ) + do l2 = 1, ncomp_aer(itype) + la = massptr_aer(l2,isize,itype,ai_phase) + tmpvol = max( 0.0_r8, tmp_chem_up(la) ) / dens_aer(l2,itype) + volum(isize,itype) = volum(isize,itype) + tmpvol + hygro(isize,itype) = hygro(isize,itype) + tmpvol*hygro_aer(l2,itype) + end do + end do ! isize + end do ! itype + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + hygro(isize,itype) = hygro(isize,itype) / max( 1.0e-35_r8, volum(isize,itype) ) + ! convert numbr from (#/kg) to (#/m3) + numbr(isize,itype) = numbr(isize,itype)*rhocen + ! convert volum to (m3/m3) -- need 1e-12 factor because + ! (rhocen*chem)/dens_aer = [(ugaero/m3air)/(gaero/cm3aero)] + volum(isize,itype) = volum(isize,itype)*rhocen*1.0e-12_r8 + + ! avoid zero numbr or volum + tmpb = 1.0e-32_r8 ! 1e-32 m3/m3 volume ~= 1e-20 ug/m3 mass + tmpc = (dlo_sect(isize,itype) + dhi_sect(isize,itype))*0.5e-2_r8 ! dcen in m + tmpc = 1.91_r8 * tmpb / (tmpc**3) ! number in #/m3 when volume = tmpb + if ((volum(isize,itype) < tmpb) .or. (numbr(isize,itype) < tmpc)) then + volum(isize,itype) = tmpb + numbr(isize,itype) = tmpc + hygro(isize,itype) = 0.3_r8 + end if + end do ! isize + end do ! itype + +! subr. activate( wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & +! msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & +! na, volc, dlo_sect, dhi_sect, sigman, hygro, & +! fn, fs, fm, fluxn, fluxs, fluxm, flux_fullact, & +! grid_id, ktau, ii, jj, kk ) + +! call activate( wact, 0.0, 0.0, 0.0, 1.0, tcen, rhocen, & +! msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & +! numbr, volum, dlo_sect, dhi_sect, sigmag_aer, hygro, & +! fn, fs, fm, fluxn, fluxs, fluxm, flux_fullact, & +! grid_id, ktau, i, j, k ) + + wact_sp = wact + tcen_sp = tcen + rhocen_sp = rhocen + numbr_sp = numbr + volum_sp = volum + hygro_sp = hygro + + if (iflagaa < 10) then + call activate( & + wact_sp, 0.0, 0.0, 0.0, 1.0, tcen_sp, rhocen_sp, & + msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & + numbr_sp, volum_sp, dlo_sect, dhi_sect, sigmag_aer, hygro_sp, & + fn_sp, fs_sp, fm_sp, fluxn_sp, fluxs_sp, fluxm_sp, flux_fullact_sp, & + grid_id, ktau, i, j, k ) + else + if (qcw < qcw_inup_smallaa) return + smax_prescribed_sp = 0.001 ! 0.1% supersaturation + call activate( & + wact_sp, 0.0, 0.0, 0.0, 1.0, tcen_sp, rhocen_sp, & + msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & + numbr_sp, volum_sp, dlo_sect, dhi_sect, sigmag_aer, hygro_sp, & + fn_sp, fs_sp, fm_sp, fluxn_sp, fluxs_sp, fluxm_sp, flux_fullact_sp, & + grid_id, ktau, i, j, k, smax_prescribed_sp ) + end if + + fn = fn_sp + fm = fm_sp + + if (idiagaa > 0) then + write(lundiag,'(/a,i10,5i5,1p,e10.2)/a') & + 'chem_cup_activate_up - ktau, id, i, j, k, iflagaa, wact', & + ktau, grid_id, i, j, k, iflagaa, wact, & + 'chem_cup_activate_up - fn then fm' + write(lundiag,'(8f11.7)') & + ((fn(isize,itype), isize=1,nsize_aer(itype)), itype=1,ntype_aer) + write(lundiag,'(8f11.7)') & + ((fm(isize,itype), isize=1,nsize_aer(itype)), itype=1,ntype_aer) +! do itype = 1, ntype_aer +! do isize = 1, nsize_aer(itype) +! tmpb = volum(isize,itype) / max(numbr(isize,itype),1.0e-10) +! tmpb = ( tmpb*6.0/3.14159 )**(1.0/3.0) +! write(lundiag,'(a,2i5,1p,4e10.2)') 'itype, isize, diams', itype, isize, & +! dlo_sect(isize,itype), tmpb, dhi_sect(isize,itype) +! end do ! isize +! end do ! itype + end if + +! apply activation fractions + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + do l2 = 0, ncomp_aer(itype) + if (l2 == 0) then + la = numptr_aer(isize,itype,ai_phase) + lc = numptr_aer(isize,itype,cw_phase) + else + la = massptr_aer(l2,isize,itype,ai_phase) + lc = massptr_aer(l2,isize,itype,cw_phase) + end if + if ((la < p1st) .or. (la > num_chem)) cycle + if ((lc < p1st) .or. (lc > num_chem)) cycle + + if (l2 == 0) then + tmpb = tmp_chem_up(la)*fn(isize,itype) + else + tmpb = tmp_chem_up(la)*fm(isize,itype) + end if + ! update chem_up + tmp_chem_up(la) = tmp_chem_up(la) - tmpb + tmp_chem_up(lc) = tmp_chem_up(lc) + tmpb + + ! update mf_up*chem_up + tmp_mfxchem_up(la) = tmp_chem_up(la)*tmp_mf_up + tmp_mfxchem_up(lc) = tmp_chem_up(lc)*tmp_mf_up + + ! increment dchemdt_up_activa + tmpc = tmpb*tmp_mf_up/(rhodz*af_up) + dchemdt_up_activa(k,la) = dchemdt_up_activa(k,la) - tmpc + dchemdt_up_activa(k,lc) = dchemdt_up_activa(k,lc) + tmpc + + end do ! l2 + end do ! isize + end do ! itype + + return + end subroutine chem_cup_activate_up + + +!------------------------------------------------------------------------------- + subroutine chem_cup_aqchem( & + config_flags, aer_mech_id, & + lunerr, lundiag, idiagaa, & + kts, kte, p1st, num_chem, & + p_qc, num_moist, & + ktau, grid_id, i, j, & + iflagaa, ido_aqchem, & + dt_aqchem, & + pcen, tcen, rhocen, rhodz, qcw, ph_no2, & + af_up, tmp_gas_aqfrac_up, tmp_mf_up, tmp_mfxchem_up, & + dchemdt_up_aqchem, chem_inact ) +! +! compute changes to updraft mixing ratios from cloud chemistry +! as updraft air moves through layer k +! +! when iflagaa >= kts, do cloud chemistry +! in updraft for the layer given by k=iflagaa +! when iflagaa < kts, do cloud chemistry +! in inactive cloud for the layers having ido_aqchem(k)>0 +! + use module_configure, only: grid_config_rec_type + use module_mosaic_cloudchem, only: mosaic_cloudchem_driver + +! arguments + type(grid_config_rec_type), intent(in) :: config_flags + + integer :: aer_mech_id + integer :: lunerr, lundiag, idiagaa + integer :: kts, kte, p1st, num_chem + integer :: p_qc, num_moist + integer :: ktau, grid_id, i, j + integer :: iflagaa, ido_aqchem(kts:kte) + + real(r8) :: dt_aqchem + real(r8), dimension( kts:kte ) :: pcen, tcen, rhocen, rhodz, qcw, ph_no2 + real(r8) :: af_up + real(r8) :: tmp_gas_aqfrac_up(1:num_chem) + real(r8) :: tmp_mf_up + real(r8) :: tmp_mfxchem_up(1:num_chem) + real(r8) :: dchemdt_up_aqchem(kts:kte,1:num_chem) + real(r8) :: chem_inact(kts:kte,1:num_chem) + +! local variables + integer :: k, k2 + integer :: l + real(r8) :: tmpb + real(r8) :: tmp_chem_up(1:num_chem), tmp_chem_up_old(1:num_chem) + +! single precision variable used for calls to other wrf-chem routines + real(r4) :: dt_aqchem_sp + real(r4), dimension( 1:1, kts:kte, 1:1 ) :: & + tmp_alt_sp, tmp_cldfra_sp, tmp_p_sp, tmp_ph_no2_sp, tmp_rho_sp, tmp_t_sp + real(r4), dimension( 1:1, kts:kte, 1:1, 1:num_chem ) :: & + tmp_chem_sp, tmp_chem_old_sp, tmp_gas_aqfrac_sp + real(r4), dimension( 1:1, kts:kte, 1:1, 1:num_moist ) :: & + tmp_moist_sp + + + if (aer_mech_id /= 3) return + + tmp_gas_aqfrac_up = 0.0 + + tmp_chem_old_sp = 0.0 + tmp_chem_sp = 0.0 + tmp_cldfra_sp = 0.0 + tmp_moist_sp = 0.0 + tmp_ph_no2_sp = 0.0 + tmp_gas_aqfrac_sp = 0.0 + dt_aqchem_sp = dt_aqchem + + if (iflagaa >= kts) then + ! doing aqchem for 1 layer of updraft + k = iflagaa + ! first get current mixing ratios in updraft + tmp_chem_up_old(p1st:num_chem) = tmp_mfxchem_up(p1st:num_chem)/tmp_mf_up + + tmp_chem_old_sp(1,k,1,p1st:num_chem) = tmp_chem_up_old(p1st:num_chem) + tmp_chem_sp(1,k,1,p1st:num_chem) = tmp_chem_old_sp(1,k,1,p1st:num_chem) + + tmp_cldfra_sp(1,k,1) = 1.0 + tmp_moist_sp(1,k,1,p_qc) = qcw(k) + tmp_ph_no2_sp(1,k,1) = ph_no2(k) + + else + ! doing aqchem for multiple levels of inactive cloud + do k = kts, kte + if (ido_aqchem(k) <= 0) cycle + tmp_chem_old_sp(1,k,1,p1st:num_chem) = chem_inact(k,p1st:num_chem) + tmp_chem_sp(1,k,1,p1st:num_chem) = tmp_chem_old_sp(1,k,1,p1st:num_chem) + + tmp_cldfra_sp(1,k,1) = 1.0 + tmp_moist_sp(1,k,1,p_qc) = qcw(k) + tmp_ph_no2_sp(1,k,1) = ph_no2(k) + end do + end if + + do k = kts, kte + tmp_p_sp(1,k,1) = pcen(k) + tmp_t_sp(1,k,1) = tcen(k) + tmp_rho_sp(1,k,1) = rhocen(k) + tmp_alt_sp(1,k,1) = 1.0/rhocen(k) + end do + + if (aer_mech_id == 3) then +! subr. mosaic_cloudchem_driver( & +! id, ktau, ktauc, dtstepc, config_flags, & +! p_phy, t_phy, rho_phy, alt, & +! cldfra, ph_no2, & +! moist, chem, & +! gas_aqfrac, numgas_aqfrac, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) + + call mosaic_cloudchem_driver( & + grid_id, ktau, ktau, dt_aqchem_sp, config_flags, & + tmp_p_sp, tmp_t_sp, tmp_rho_sp, tmp_alt_sp, & + tmp_cldfra_sp, tmp_ph_no2_sp, & + tmp_moist_sp, tmp_chem_sp, & + tmp_gas_aqfrac_sp, num_chem, & + 1,1, 1,1, kts,kte, & + 1,1, 1,1, kts,kte, & + 1,1, 1,1, kts,kte ) + +! else +! call cloudchem routine for other aerosol treatments + end if + + + if (iflagaa >= kts) then + k = iflagaa + do l = p1st, num_chem + tmp_gas_aqfrac_up(l) = tmp_gas_aqfrac_sp(1,k,1,l) + + if (tmp_chem_sp(1,k,1,l) == tmp_chem_old_sp(1,k,1,l)) cycle + + tmp_chem_up(l) = tmp_chem_sp(1,k,1,l) + tmpb = tmp_chem_up(l) - tmp_chem_up_old(l) + + ! update mf_up*chem_up + tmp_mfxchem_up(l) = tmp_chem_up(l)*tmp_mf_up + ! increment dchemdt_up_aqchem + dchemdt_up_aqchem(k,l) = dchemdt_up_aqchem(k,l) & + + tmpb*tmp_mf_up/(rhodz(k)*af_up) + end do + + else + do k = kts, kte + if (ido_aqchem(k) <= 0) cycle + do l = p1st, num_chem + if (tmp_chem_sp(1,k,1,l) == tmp_chem_old_sp(1,k,1,l)) cycle + chem_inact(k,l) = tmp_chem_sp(1,k,1,l) + end do + end do + end if + + return + end subroutine chem_cup_aqchem + + +!------------------------------------------------------------------------------- + subroutine chem_cup_check_adjust_inputs( & + lunerr, lundiag, idiagaa, & + kts, kte, ktep1, & + ktau, grid_id, i, j, & + ishall, do_dndraft, & + kcldbot, kcldtop, kcldbotliq, & + kupdrbot, kupdrtop, kdndrbot, kdndrtop, & + iok, & + tau_active, tau_inactive, & + dz, zcen, zbnd, pcen, tcen, rhocen, & + af_lscld, af_cucld, af_up, af_dn, & + qcw_incu, qci_incu, & + qcw_inup, qci_inup, & + mf_up, mf_up_ent, mf_up_det, & + mf_dn, mf_dn_ent, mf_dn_det ) +! +! apply "reality checks" to inputs +! to avoid problems in the chem_cup_1d algorithm +! + +! arguments + integer, intent(in) :: lunerr, lundiag, idiagaa + integer, intent(in) :: kts, kte, ktep1 + integer, intent(in) :: ktau, grid_id, i, j + integer, intent(in) :: ishall + integer, intent(inout) :: kcldbot, kcldtop, kcldbotliq + integer, intent(inout) :: kupdrbot, kupdrtop, kdndrbot, kdndrtop + integer, intent(inout) :: iok + + logical, intent(in) :: do_dndraft + + real(r8), intent(in) :: tau_active, tau_inactive + + real(r8), intent(in), dimension(kts:kte) :: & + dz, zcen, pcen, tcen, rhocen, af_lscld + + real(r8), intent(inout), dimension(kts:kte) :: & + af_cucld, af_up, af_dn, & + qcw_incu, qci_incu, qcw_inup, qci_inup, & + mf_up_ent, mf_up_det, mf_dn_ent, mf_dn_det + + real(r8), intent(in), dimension(kts:ktep1) :: & + zbnd + + real(r8), intent(inout), dimension(kts:ktep1) :: & + mf_up, mf_dn + +! local variables + integer :: k, ktmpa, ktmpb, ktmpc, ktmpd + + real(r8) :: tmpa + + + iok = -1 + +! check for tau_active too small + if (tau_active < tau_active_smallaa) then + write(lunerr,'(2a,i10,3i5)') & + 'chem_cup_check_adjust_inputs - ', & + 'tau_active < tau_active_smallaa', ktau, grid_id, i, j + return + end if + + +! identify bottom and top of the updraft + mf_up(kts) = 0.0_r8 + mf_up(ktep1) = 0.0_r8 + kupdrbot = kts-1 + kupdrtop = kts-1 + tmpa = 1.0e20 + do k = kts, kte + if (mf_up(k) >= aw_up_smallaa*rhocen(k)) then + if (kupdrbot < kts) kupdrbot = k-1 + kupdrtop = k + tmpa = min( tmpa, mf_up(k) ) + else + mf_up(k) = 0.0_r8 + end if + end do + if (kupdrbot < kts) then + write(lunerr,'(2a,i10,3i5)') & + 'chem_cup_check_adjust_inputs - ', & + 'no mf_up > aw_up_smallaa*rho', ktau, grid_id, i, j + return + end if + +! force mf_up to have "reasonable" positive values throughout the updraft layers + do k = kupdrbot+1, kupdrtop + mf_up(k) = max( mf_up(k), tmpa ) + end do + + + if ( do_dndraft ) then +! identify bottom and top of the dndraft + mf_dn(kts) = 0.0_r8 + mf_dn(ktep1) = 0.0_r8 + kdndrbot = kts-1 + kdndrtop = kts-1 + tmpa = -1.0e20 + do k = kts, kte + if (k > kupdrtop) then + mf_dn(k) = 0.0_r8 ! do not allow downdraft to extend higher than updraft + else if (mf_dn(k) <= -aw_up_smallaa*rhocen(k)) then + if (kdndrbot < kts) kdndrbot = k-1 + kdndrtop = k + tmpa = max( tmpa, mf_dn(k) ) + else + mf_dn(k) = 0.0_r8 + end if + end do + if (kdndrbot < kts) then + write(lunerr,'(2a,i10,3i5)') & + 'chem_cup_check_adjust_inputs - ', & + 'no mf_dn > aw_dn_smallaa*rho', ktau, grid_id, i, j + return + end if + +! force mf_dn to have "reasonable" negative values throughout the dndraft layers + do k = kdndrbot+1, kdndrtop + mf_dn(k) = min( mf_dn(k), tmpa ) + end do + end if ! ( do_dndraft ) + + +! identify layers with cloudwater and cloud-ice + ktmpa = kts-1 ; ktmpb = kts-1 ; ktmpc = kts-1 ; ktmpd = kts-1 + do k = kts, kte + if ((k < kupdrbot) .or. (k > kupdrtop)) then + qcw_inup(k) = 0.0_r8 + qci_inup(k) = 0.0_r8 + qcw_incu(k) = 0.0_r8 + qci_incu(k) = 0.0_r8 + else + if (qcw_inup(k) < qcw_inup_smallaa) then + qcw_inup(k) = 0.0_r8 + else + if (ktmpa < kts) ktmpa = k + ktmpb = k + end if + if (qci_inup(k) < qci_inup_smallaa) then + qci_inup(k) = 0.0_r8 + else + if (ktmpc < kts) ktmpc = k + ktmpd = k + end if + + if (qcw_incu(k) < qcw_incu_smallaa) then + qcw_incu(k) = 0.0_r8 + end if + if (qci_incu(k) < qci_incu_smallaa) then + qci_incu(k) = 0.0_r8 + end if + end if + end do + if ((ktmpa < kts) .and. (ktmpc < kts)) then + write(lunerr,'(2a,i10,3i5)') & + 'chem_cup_check_adjust_inputs - ', & + 'no qcw/qci_inup > qcw/i_inup_smallaa', ktau, grid_id, i, j + return + end if +! at this point, kupdrbot <= ktmpa <= ktmpb <= kupdrtop +! and/or kupdrbot <= ktmpc <= ktmpd <= kupdrtop + + kcldbotliq = ktmpa + if (ktmpa < kts ) then + ! in this case, ktmpc >= kts + kcldbot = ktmpc + kcldtop = ktmpd + kcldbotliq = kts-1 + else if (ktmpc < kts ) then + ! in this case, ktmpa >= kts + kcldbot = ktmpa + kcldtop = ktmpb + else + kcldbot = min( ktmpa, ktmpc ) + kcldtop = max( ktmpb, ktmpd ) + end if + +! check/adjust af_cucld and af_up +! +! *** this should be done better +! check the ecpp code, which does something like +! af_up = max( af_up, mf_up/rho*wup_maxaa + do k = kts, kte + if ((k < kupdrbot) .or. (k > kupdrtop)) then + af_up(k) = 0.0_r8 + else + af_up(k) = max( af_up(k), af_up_smallaa ) + af_up(k) = min( af_up(k), af_up_maxaa ) + end if + end do + + do k = kts, kte + if ((k < kcldbot) .or. (k > kcldtop)) then + af_cucld(k) = 0.0_r8 + else + af_cucld(k) = max( af_cucld(k), af_up(k), af_cucld_smallaa ) + af_cucld(k) = min( af_cucld(k), af_cucld_maxaa ) + end if + end do + +! calculate mf_up_det and adjust mf_up_ent if needed + do k = kts, kte + if ((k < kupdrbot) .or. (k > kupdrtop)) then + mf_up_ent(k) = 0.0_r8 + mf_up_det(k) = 0.0_r8 + else + tmpa = mf_up(k+1) - mf_up(k) + mf_up_det(k) = mf_up_ent(k) - tmpa + if (mf_up_det(k) < 0.0_r8) then + mf_up_ent(k) = tmpa + mf_up_det(k) = 0.0_r8 + end if + end if + end do + +! calculate mf_dn_det and adjust mf_dn_ent if needed + do k = kts, kte + if ((k < kdndrbot) .or. (k > kdndrtop)) then + mf_dn_ent(k) = 0.0_r8 + mf_dn_det(k) = 0.0_r8 + else + tmpa = mf_dn(k+1) - mf_dn(k) + mf_dn_det(k) = mf_dn_ent(k) - tmpa + if (mf_dn_det(k) < 0.0_r8) then + mf_dn_ent(k) = tmpa + mf_dn_det(k) = 0.0_r8 + end if + end if + end do + + iok = 0 + return + end subroutine chem_cup_check_adjust_inputs + + +!----------------------------------------------------------------- + end module module_chem_cup diff --git a/wrfv2_fire/chem/module_ctrans_aqchem.F b/wrfv2_fire/chem/module_ctrans_aqchem.F index f42376d8..f00e7500 100755 --- a/wrfv2_fire/chem/module_ctrans_aqchem.F +++ b/wrfv2_fire/chem/module_ctrans_aqchem.F @@ -895,12 +895,18 @@ SUBROUTINE AQCHEM ( TEMP, PRES_PA, TAUCLD, PRCRATE, & !...Kinetic oxidation rates !... From Chamedies (1982) - RH2O2 = 8.0E+04 * EXP( -3650.0 * TEMP1 ) +! RH2O2 = 8.0E+04 * EXP( -3650.0 * TEMP1 ) +!KW based on CMAQv5.0 From Jacobson (1997) + RH2O2 = 7.45E+07 * EXP( -15.96E0 * ( ( 298.0E0 / TEMP ) - 1.0E0 ) ) !...From Kok - RMHP = 1.75E+07 * EXP( -3801.0 * TEMP1 ) - RPAA = 3.64E+07 * EXP( -3994.0 * TEMP1 ) +! RMHP = 1.75E+07 * EXP( -3801.0 * TEMP1 ) +! RPAA = 3.64E+07 * EXP( -3994.0 * TEMP1 ) +!KW based on CMAQv5.0 From Jacobson (1997) + + RMHP = 1.90E+07 * EXP( -12.75E0 * ( ( 298.0E0 / TEMP ) - 1.0E0 ) ) + RPAA = 3.67E+07 * EXP( -13.42E0 * ( ( 298.0E0 / TEMP ) - 1.0E0 ) ) !...make initializations @@ -1578,7 +1584,10 @@ SUBROUTINE AQCHEM ( TEMP, PRES_PA, TAUCLD, PRCRATE, & !...Calculate sulfur iv oxidation rate due to H2O2 - DSIVDT( 1 ) = -RH2O2 * H2O2L * SO2L / ( 0.1 + AC ) +!KW DSIVDT( 1 ) = -RH2O2 * H2O2L * SO2L / ( 0.1 + AC ) +!KW based on CMAQv5.0 + DSIVDT( 1 ) = -RH2O2 * H2O2L * HSO3 * AC / ( 0.1 + 13.0 * AC ) + TOTOX = PH2O20 * ONE_OVER_XL IF ( ( DSIVDT( 1 ) .EQ. 0.0 ) .OR. & ( TSIV .LE. CONCMIN ) .OR. & @@ -1590,11 +1599,15 @@ SUBROUTINE AQCHEM ( TEMP, PRES_PA, TAUCLD, PRCRATE, & !...Calculate sulfur iv oxidation rate due to O3 - IF ( BB .GE. 2.7 ) THEN - DSIVDT( 2 ) = -4.19E5 * ( 1.0 + 2.39E-4 / AC ) * O3L * SIV - ELSE - DSIVDT( 2 ) = -1.9E4 * SIV * O3L / SQRT( AC ) - END IF +!KW IF ( BB .GE. 2.7 ) THEN +!KW DSIVDT( 2 ) = -4.19E5 * ( 1.0 + 2.39E-4 / AC ) * O3L * SIV +!KW ELSE +!KW DSIVDT( 2 ) = -1.9E4 * SIV * O3L / SQRT( AC ) +!KW END IF +!KW based on CMAQv5.0 + DSIVDT( 2 ) = -( 2.4E4 * SO2L + & + 3.7E5 * EXP( -18.56 * ( ( 298.0E0 / TEMP ) - 1.0E0 ) ) * HSO3 + & + 1.5E9 * EXP( -17.72 * ( ( 298.0E0 / TEMP ) - 1.0E0 ) ) * SO3 ) * O3L TOTOX = PO30 * ONE_OVER_XL IF ( ( DSIVDT( 2 ) .EQ. 0.0 ) .OR. & ( TSIV .LE. CONCMIN ) .OR. & @@ -1607,27 +1620,34 @@ SUBROUTINE AQCHEM ( TEMP, PRES_PA, TAUCLD, PRCRATE, & !...Calculate sulfur iv oxidation rate due to 02 catalyzed by Mn++ !... and Fe+++ See Table IV Walcek & Taylor ( 1986) - IF ( BB .GE. 4.0 ) THEN ! 4.0 < pH +!KW IF ( BB .GE. 4.0 ) THEN ! 4.0 < pH + +! IF ( SIV .LE. 1.0E-5 ) THEN +! DSIVDT( 3 ) = -5000.0 * MN * HSO3 +! ELSE IF ( SIV .GT. 1.0E-5 ) THEN +! DSIVDT( 3 ) = -( 4.7 * MN * MN / AC & +! + 1.0E7 * FE * SIV * SIV ) +! END IF ! end of first pass through SIV conc. - IF ( SIV .LE. 1.0E-5 ) THEN - DSIVDT( 3 ) = -5000.0 * MN * HSO3 - ELSE IF ( SIV .GT. 1.0E-5 ) THEN - DSIVDT( 3 ) = -( 4.7 * MN * MN / AC & - + 1.0E7 * FE * SIV * SIV ) - END IF ! end of first pass through SIV conc. +! ELSE ! pH , + 4.0 - ELSE ! pH , + 4.0 +! IF ( SIV .LE. 1.0E-5 ) THEN +! DSIVDT( 3 ) = -3.0 * ( 5000.0 * MN * HSO3 & +! + 0.82 * FE * SIV / AC ) +! ELSE +! DSIVDT( 3 ) = -( 4.7 * MN * MN / AC & +! + ( 0.82 * FE * SIV / AC ) & +! * ( 1.0 + 1.7E3 * MN**1.5 / ( 6.3E-6 + FE ) ) ) +! END IF ! end of second pass through SIV conc. - IF ( SIV .LE. 1.0E-5 ) THEN - DSIVDT( 3 ) = -3.0 * ( 5000.0 * MN * HSO3 & - + 0.82 * FE * SIV / AC ) - ELSE - DSIVDT( 3 ) = -( 4.7 * MN * MN / AC & - + ( 0.82 * FE * SIV / AC ) & - * ( 1.0 + 1.7E3 * MN**1.5 / ( 6.3E-6 + FE ) ) ) - END IF ! end of second pass through SIV conc. +!KW END IF ! end of pass through pH - END IF ! end of pass through pH +!KW based on CMAQv5.0 +!...Calculate sulfur iv oxidation rate due to 02 catalyzed by Mn++ and Fe+++ +!...(Martin and Goodman, 1991) prescribled 0.01 ug/m3 for FeIII and 0.005 ug/m3 for MnII + DSIVDT( 3 ) = - ( 750.0E0 * MN * SIV + & ! GS 4May2011 + 2600.0E0 * FE * SIV + & ! GS 4May2011 + 1.0E10 * MN * FE * SIV ) ! GS 4May2011 IF ( ( DSIVDT( 3 ) .EQ. 0.0 ) .OR. ( TSIV .LE. CONCMIN ) ) THEN DTW( 3 ) = DTRMV @@ -1649,7 +1669,9 @@ SUBROUTINE AQCHEM ( TEMP, PRES_PA, TAUCLD, PRCRATE, & !...Calculate sulfur oxidation due to PAA - DSIVDT( 5 ) = -RPAA * HSO3 * PAAL * ( AC + 1.65E-5 ) +!KW DSIVDT( 5 ) = -RPAA * HSO3 * PAAL * ( AC + 1.65E-5 ) +!KW based on CMAQv5.0 + DSIVDT( 5 ) = -( RPAA * AC + 7.00E2 ) * HSO3 * PAAL TOTOX = PPAA0 * ONE_OVER_XL IF ( ( DSIVDT( 5 ) .EQ. 0.0 ) .OR. & ( TSIV .LE. CONCMIN ) .OR. & diff --git a/wrfv2_fire/chem/module_ctrans_grell.F b/wrfv2_fire/chem/module_ctrans_grell.F index 32cf3ab1..f4245859 100755 --- a/wrfv2_fire/chem/module_ctrans_grell.F +++ b/wrfv2_fire/chem/module_ctrans_grell.F @@ -7,14 +7,68 @@ MODULE module_ctrans_grell USE module_state_description, only:p_co,p_qv,p_so2,p_hno3,p_hno4,p_n2o5,p_nh3,p_h2o2, & p_o3,p_ora1,p_op1,p_paa,p_sulf,p_so4aj,p_nh4aj,p_no3aj, & p_bc1,p_bc2,p_oc1,p_oc2,p_seas_1,p_seas_2, & - p_seas_3,p_seas_4,p_dms - - REAL, PARAMETER :: qcldwtr_cutoff = 1.0e-6 ! kg/kg + p_seas_3,p_seas_4,p_dms, & + p_facd,p_mepx,p_pacd +USE module_state_description, only:p_cvasoaX,p_cvasoa1,p_cvasoa2,p_cvasoa3,p_cvasoa4,& + p_cvbsoaX,p_cvbsoa1,p_cvbsoa2,p_cvbsoa3,p_cvbsoa4 + +USE module_state_description, ONLY: mozart_mosaic_4bin_kpp, & + mozart_mosaic_4bin_aq_kpp,& + p_hcho, p_c3h6ooh, p_onit, p_mvk, p_macr, & + p_etooh, p_prooh, p_acetp, p_mgly, p_mvkooh, & + p_onitr, p_isooh, p_ch3oh, p_c2h5oh, & + p_glyald, p_hydrald, p_ald, p_isopn, & + p_alkooh, p_mekooh, p_tolooh, p_terpooh, & + p_xooh, p_ch3cooh, p_hcooh, p_ch3ooh, & + p_so4_a01,p_no3_a01,p_smpa_a01,p_smpbb_a01,& + p_glysoa_r1_a01,p_glysoa_r2_a01,& + p_glysoa_sfc_a01,p_glysoa_nh4_a01,& + p_glysoa_oh_a01,& + p_asoaX_a01,p_asoa1_a01,p_asoa2_a01,p_asoa3_a01,p_asoa4_a01,& + p_bsoaX_a01,p_bsoa1_a01,p_bsoa2_a01,p_bsoa3_a01,p_bsoa4_a01,& + p_biog1_c_a01,p_biog1_o_a01,& + p_cl_a01,p_co3_a01,p_nh4_a01,p_na_a01,& + p_ca_a01,p_oin_a01,p_oc_a01,p_bc_a01,& + p_so4_a02,p_no3_a02,p_smpa_a02,p_smpbb_a02,& + p_glysoa_r1_a02,p_glysoa_r2_a02,& + p_glysoa_sfc_a02,p_glysoa_nh4_a02,& + p_glysoa_oh_a02,& + p_asoaX_a02,p_asoa1_a02,p_asoa2_a02,p_asoa3_a02,p_asoa4_a02,& + p_bsoaX_a02,p_bsoa1_a02,p_bsoa2_a02,p_bsoa3_a02,p_bsoa4_a02,& + p_biog1_c_a02,p_biog1_o_a02,& + p_cl_a02,p_co3_a02,p_nh4_a02,p_na_a02,& + p_ca_a02,p_oin_a02,p_oc_a02,p_bc_a02,& + p_so4_a03,p_no3_a03,p_smpa_a03,p_smpbb_a03,& + p_glysoa_r1_a03,p_glysoa_r2_a03,& + p_glysoa_sfc_a03,p_glysoa_nh4_a03,& + p_glysoa_oh_a03,& + p_asoaX_a03,p_asoa1_a03,p_asoa2_a03,p_asoa3_a03,p_asoa4_a03,& + p_bsoaX_a03,p_bsoa1_a03,p_bsoa2_a03,p_bsoa3_a03,p_bsoa4_a03,& + p_biog1_c_a03,p_biog1_o_a03,& + p_cl_a03,p_co3_a03,p_nh4_a03,p_na_a03,& + p_ca_a03,p_oin_a03,p_oc_a03,p_bc_a03,& + p_so4_a04,p_no3_a04,p_smpa_a04,p_smpbb_a04,& + p_glysoa_r1_a04,p_glysoa_r2_a04,& + p_glysoa_sfc_a04,p_glysoa_nh4_a04,& + p_glysoa_oh_a04,& + p_asoaX_a04,p_asoa1_a04,p_asoa2_a04,p_asoa3_a04,p_asoa4_a04,& + p_bsoaX_a04,p_bsoa1_a04,p_bsoa2_a04,p_bsoa3_a04,p_bsoa4_a04,& + p_biog1_c_a04,p_biog1_o_a04,& + p_cl_a04,p_co3_a04,p_nh4_a04,p_na_a04,& + p_ca_a04,p_oin_a04,p_oc_a04,p_bc_a04 + + IMPLICIT NONE + +! REAL, PARAMETER :: qcldwtr_cutoff = 1.0e-6 ! kg/kg + REAL, PARAMETER :: qcldwtr_cutoff = 1.0e-6 ! kg/m3 +! REAL, PARAMETER :: mwdry = 28.966 ! Molecular mass of dry air (g/mol) REAL, PARAMETER :: mwso4 = 96.00 ! Molecular mass of SO4-- (g/mol) REAL, PARAMETER :: mwno3 = 62.0 ! Molecular mass of NO3- (g/mol) REAL, PARAMETER :: mwnh4 = 18.0985 ! Molecular mass of NH4+ (g/mol) + + REAL, PARAMETER :: mwoa = 250.0 ! Molecular mass of OA (g/mol) CONTAINS @@ -24,6 +78,9 @@ SUBROUTINE GRELLDRVCT(DT,itimestep,DX, & U,V,t_phy,moist,dz8w,p_phy, & XLV,CP,G,r_v,z,cu_co_ten, & wd_no3,wd_so4, & + wd_nh4,wd_oa, & + wd_so2, wd_sulf, wd_hno3, wd_nh3, & + wd_cvasoa, wd_cvbsoa, wd_asoa, wd_bsoa, & k22_shallow,kbcon_shallow,ktop_shallow,xmb_shallow, & ishallow,num_moist,numgas,num_chem,chemopt,scalaropt, & conv_tr_wetscav,conv_tr_aqchem, & @@ -80,6 +137,10 @@ SUBROUTINE GRELLDRVCT(DT,itimestep,DX, & ! Accumulated wet deposition ! REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: wd_no3,wd_so4 + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: wd_nh4,wd_oa, & + wd_so2, wd_sulf, wd_hno3, wd_nh3 + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: & + wd_cvasoa,wd_cvbsoa,wd_asoa,wd_bsoa ! LOCAL VARS real, dimension (its:ite,kts:kte) :: & OUTT,OUTQ,OUTQC @@ -90,7 +151,11 @@ SUBROUTINE GRELLDRVCT(DT,itimestep,DX, & REAL, DIMENSION (ims:ime,jms:jme,num_chem) :: wetdep_2d ! Wet deposition over the current time step REAL, DIMENSION( ims:ime , jms:jme ) :: wdi_no3,wdi_so4 -! + REAL, DIMENSION( ims:ime , jms:jme ) :: wdi_nh4,wdi_oa, & + wdi_so2, wdi_sulf, wdi_hno3, wdi_nh3 + REAL, DIMENSION( ims:ime , jms:jme ) :: wdi_cvasoa, wdi_cvbsoa, & + wdi_asoa, wdi_bsoa + ! basic environmental input includes moisture convergence (mconv) ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off ! convection for this call only and at that particular gridpoint @@ -254,22 +319,243 @@ SUBROUTINE GRELLDRVCT(DT,itimestep,DX, & wdi_no3(:,:) = 0.0 wdi_so4(:,:) = 0.0 + wdi_nh4(:,:) = 0.0 + wdi_oa(:,:) = 0.0 + wdi_so2(:,:) = 0.0 + wdi_sulf(:,:) = 0.0 + wdi_hno3(:,:) = 0.0 + wdi_nh3(:,:) = 0.0 + + wdi_cvasoa(:,:) = 0.0 + wdi_cvbsoa(:,:) = 0.0 + wdi_asoa(:,:) = 0.0 + wdi_bsoa(:,:) = 0.0 ! We use the indices of the chem array that point to aerosol outside of cloud water, ! because that's what the cumulus scheme operates with. - if (p_no3aj .gt.1) wdi_no3(its:ite,jts:jte) = wdi_no3(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_no3aj)*dt*0.001/mwno3 ! mmol/m2 - if (p_hno3 .gt.1) wdi_no3(its:ite,jts:jte) = wdi_no3(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_hno3)*dt ! mmol/m2 - if (p_hno4 .gt.1) wdi_no3(its:ite,jts:jte) = wdi_no3(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_hno4)*dt ! mmol/m2 + if (chemopt == mozart_mosaic_4bin_kpp .OR. & + chemopt == mozart_mosaic_4bin_aq_kpp) then + + wdi_no3(its:ite,jts:jte) = wdi_no3(its:ite,jts:jte) + & + (wetdep_2d(its:ite,jts:jte,p_no3_a01) + & + wetdep_2d(its:ite,jts:jte,p_no3_a02) + & + wetdep_2d(its:ite,jts:jte,p_no3_a03) + & + wetdep_2d(its:ite,jts:jte,p_no3_a04))*dt*0.001/mwno3 ! mmol/m2 + + wdi_so4(its:ite,jts:jte) = wdi_so4(its:ite,jts:jte) + & + (wetdep_2d(its:ite,jts:jte,p_so4_a01) + & + wetdep_2d(its:ite,jts:jte,p_so4_a02) + & + wetdep_2d(its:ite,jts:jte,p_so4_a03) + & + wetdep_2d(its:ite,jts:jte,p_so4_a04))*dt*0.001/mwso4 ! mmol/m2 + + wdi_nh4(its:ite,jts:jte) = wdi_nh4(its:ite,jts:jte) + & + (wetdep_2d(its:ite,jts:jte,p_nh4_a01) + & + wetdep_2d(its:ite,jts:jte,p_nh4_a02) + & + wetdep_2d(its:ite,jts:jte,p_nh4_a03) + & + wetdep_2d(its:ite,jts:jte,p_nh4_a04))*dt*0.001/mwnh4 ! mmol/m2 + + if (chemopt == mozart_mosaic_4bin_kpp) then + + wdi_oa(its:ite,jts:jte) = wdi_oa(its:ite,jts:jte) + & + (wetdep_2d(its:ite,jts:jte,p_oc_a01) + & + wetdep_2d(its:ite,jts:jte,p_oc_a02) + & + wetdep_2d(its:ite,jts:jte,p_oc_a03) + & + wetdep_2d(its:ite,jts:jte,p_oc_a04) + & + wetdep_2d(its:ite,jts:jte,p_smpa_a01) + & + wetdep_2d(its:ite,jts:jte,p_smpa_a02) + & + wetdep_2d(its:ite,jts:jte,p_smpa_a03) + & + wetdep_2d(its:ite,jts:jte,p_smpa_a04) + & + wetdep_2d(its:ite,jts:jte,p_smpbb_a01) + & + wetdep_2d(its:ite,jts:jte,p_smpbb_a02) + & + wetdep_2d(its:ite,jts:jte,p_smpbb_a03) + & + wetdep_2d(its:ite,jts:jte,p_smpbb_a04) + & + wetdep_2d(its:ite,jts:jte,p_biog1_c_a01) + & + wetdep_2d(its:ite,jts:jte,p_biog1_c_a02) + & + wetdep_2d(its:ite,jts:jte,p_biog1_c_a03) + & + wetdep_2d(its:ite,jts:jte,p_biog1_c_a04) + & + wetdep_2d(its:ite,jts:jte,p_biog1_o_a01) + & + wetdep_2d(its:ite,jts:jte,p_biog1_o_a02) + & + wetdep_2d(its:ite,jts:jte,p_biog1_o_a03) + & + wetdep_2d(its:ite,jts:jte,p_biog1_o_a04) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r1_a01) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r1_a02) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r1_a03) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r1_a04) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r2_a01) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r2_a02) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r2_a03) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r2_a04) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_oh_a01) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_oh_a02) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_oh_a03) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_oh_a04) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_nh4_a01) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_nh4_a02) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_nh4_a03) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_nh4_a04) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_sfc_a01) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_sfc_a02) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_sfc_a03) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_sfc_a04))*dt*0.001/mwoa ! mmol/m2 + endif + + if (chemopt == mozart_mosaic_4bin_aq_kpp) then + + wdi_asoa(its:ite,jts:jte) = wdi_asoa(its:ite,jts:jte) + & + (wetdep_2d(its:ite,jts:jte,p_asoaX_a01) + & + wetdep_2d(its:ite,jts:jte,p_asoaX_a02) + & + wetdep_2d(its:ite,jts:jte,p_asoaX_a03) + & + wetdep_2d(its:ite,jts:jte,p_asoaX_a04) + & + wetdep_2d(its:ite,jts:jte,p_asoa1_a01) + & + wetdep_2d(its:ite,jts:jte,p_asoa1_a02) + & + wetdep_2d(its:ite,jts:jte,p_asoa1_a03) + & + wetdep_2d(its:ite,jts:jte,p_asoa1_a04) + & + wetdep_2d(its:ite,jts:jte,p_asoa2_a01) + & + wetdep_2d(its:ite,jts:jte,p_asoa2_a02) + & + wetdep_2d(its:ite,jts:jte,p_asoa2_a03) + & + wetdep_2d(its:ite,jts:jte,p_asoa2_a04) + & + wetdep_2d(its:ite,jts:jte,p_asoa3_a01) + & + wetdep_2d(its:ite,jts:jte,p_asoa3_a02) + & + wetdep_2d(its:ite,jts:jte,p_asoa3_a03) + & + wetdep_2d(its:ite,jts:jte,p_asoa3_a04) + & + wetdep_2d(its:ite,jts:jte,p_asoa4_a01) + & + wetdep_2d(its:ite,jts:jte,p_asoa4_a02) + & + wetdep_2d(its:ite,jts:jte,p_asoa4_a03) + & + wetdep_2d(its:ite,jts:jte,p_asoa4_a04))*dt*0.001/150.0 ! mmol/m2 + + wdi_bsoa(its:ite,jts:jte) = wdi_bsoa(its:ite,jts:jte) + & + (wetdep_2d(its:ite,jts:jte,p_bsoaX_a01) + & + wetdep_2d(its:ite,jts:jte,p_bsoaX_a02) + & + wetdep_2d(its:ite,jts:jte,p_bsoaX_a03) + & + wetdep_2d(its:ite,jts:jte,p_bsoaX_a04) + & + wetdep_2d(its:ite,jts:jte,p_bsoa1_a01) + & + wetdep_2d(its:ite,jts:jte,p_bsoa1_a02) + & + wetdep_2d(its:ite,jts:jte,p_bsoa1_a03) + & + wetdep_2d(its:ite,jts:jte,p_bsoa1_a04) + & + wetdep_2d(its:ite,jts:jte,p_bsoa2_a01) + & + wetdep_2d(its:ite,jts:jte,p_bsoa2_a02) + & + wetdep_2d(its:ite,jts:jte,p_bsoa2_a03) + & + wetdep_2d(its:ite,jts:jte,p_bsoa2_a04) + & + wetdep_2d(its:ite,jts:jte,p_bsoa3_a01) + & + wetdep_2d(its:ite,jts:jte,p_bsoa3_a02) + & + wetdep_2d(its:ite,jts:jte,p_bsoa3_a03) + & + wetdep_2d(its:ite,jts:jte,p_bsoa3_a04) + & + wetdep_2d(its:ite,jts:jte,p_bsoa4_a01) + & + wetdep_2d(its:ite,jts:jte,p_bsoa4_a02) + & + wetdep_2d(its:ite,jts:jte,p_bsoa4_a03) + & + wetdep_2d(its:ite,jts:jte,p_bsoa4_a04))*dt*0.001/180.0 ! mmol/m2 + + wdi_cvasoa(its:ite,jts:jte) = wdi_cvasoa(its:ite,jts:jte) + & + (wetdep_2d(its:ite,jts:jte,p_cvasoaX) + & + wetdep_2d(its:ite,jts:jte,p_cvasoa1) + & + wetdep_2d(its:ite,jts:jte,p_cvasoa2) + & + wetdep_2d(its:ite,jts:jte,p_cvasoa3) + & + wetdep_2d(its:ite,jts:jte,p_cvasoa4))*dt ! mmol/m2 + + wdi_cvbsoa(its:ite,jts:jte) = wdi_cvbsoa(its:ite,jts:jte) + & + (wetdep_2d(its:ite,jts:jte,p_cvbsoaX) + & + wetdep_2d(its:ite,jts:jte,p_cvbsoa1) + & + wetdep_2d(its:ite,jts:jte,p_cvbsoa2) + & + wetdep_2d(its:ite,jts:jte,p_cvbsoa3) + & + wetdep_2d(its:ite,jts:jte,p_cvbsoa4))*dt ! mmol/m2 + + wdi_oa(its:ite,jts:jte) = wdi_oa(its:ite,jts:jte) + & + (wetdep_2d(its:ite,jts:jte,p_oc_a01) + & + wetdep_2d(its:ite,jts:jte,p_oc_a02) + & + wetdep_2d(its:ite,jts:jte,p_oc_a03) + & + wetdep_2d(its:ite,jts:jte,p_oc_a04) + & + wetdep_2d(its:ite,jts:jte,p_asoaX_a01) + & + wetdep_2d(its:ite,jts:jte,p_asoaX_a02) + & + wetdep_2d(its:ite,jts:jte,p_asoaX_a03) + & + wetdep_2d(its:ite,jts:jte,p_asoaX_a04) + & + wetdep_2d(its:ite,jts:jte,p_asoa1_a01) + & + wetdep_2d(its:ite,jts:jte,p_asoa1_a02) + & + wetdep_2d(its:ite,jts:jte,p_asoa1_a03) + & + wetdep_2d(its:ite,jts:jte,p_asoa1_a04) + & + wetdep_2d(its:ite,jts:jte,p_asoa2_a01) + & + wetdep_2d(its:ite,jts:jte,p_asoa2_a02) + & + wetdep_2d(its:ite,jts:jte,p_asoa2_a03) + & + wetdep_2d(its:ite,jts:jte,p_asoa2_a04) + & + wetdep_2d(its:ite,jts:jte,p_asoa3_a01) + & + wetdep_2d(its:ite,jts:jte,p_asoa3_a02) + & + wetdep_2d(its:ite,jts:jte,p_asoa3_a03) + & + wetdep_2d(its:ite,jts:jte,p_asoa3_a04) + & + wetdep_2d(its:ite,jts:jte,p_asoa4_a01) + & + wetdep_2d(its:ite,jts:jte,p_asoa4_a02) + & + wetdep_2d(its:ite,jts:jte,p_asoa4_a03) + & + wetdep_2d(its:ite,jts:jte,p_asoa4_a04) + & + wetdep_2d(its:ite,jts:jte,p_bsoaX_a01) + & + wetdep_2d(its:ite,jts:jte,p_bsoaX_a02) + & + wetdep_2d(its:ite,jts:jte,p_bsoaX_a03) + & + wetdep_2d(its:ite,jts:jte,p_bsoaX_a04) + & + wetdep_2d(its:ite,jts:jte,p_bsoa1_a01) + & + wetdep_2d(its:ite,jts:jte,p_bsoa1_a02) + & + wetdep_2d(its:ite,jts:jte,p_bsoa1_a03) + & + wetdep_2d(its:ite,jts:jte,p_bsoa1_a04) + & + wetdep_2d(its:ite,jts:jte,p_bsoa2_a01) + & + wetdep_2d(its:ite,jts:jte,p_bsoa2_a02) + & + wetdep_2d(its:ite,jts:jte,p_bsoa2_a03) + & + wetdep_2d(its:ite,jts:jte,p_bsoa2_a04) + & + wetdep_2d(its:ite,jts:jte,p_bsoa3_a01) + & + wetdep_2d(its:ite,jts:jte,p_bsoa3_a02) + & + wetdep_2d(its:ite,jts:jte,p_bsoa3_a03) + & + wetdep_2d(its:ite,jts:jte,p_bsoa3_a04) + & + wetdep_2d(its:ite,jts:jte,p_bsoa4_a01) + & + wetdep_2d(its:ite,jts:jte,p_bsoa4_a02) + & + wetdep_2d(its:ite,jts:jte,p_bsoa4_a03) + & + wetdep_2d(its:ite,jts:jte,p_bsoa4_a04) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r1_a01) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r1_a02) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r1_a03) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r1_a04) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r2_a01) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r2_a02) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r2_a03) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_r2_a04) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_oh_a01) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_oh_a02) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_oh_a03) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_oh_a04) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_nh4_a01) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_nh4_a02) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_nh4_a03) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_nh4_a04) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_sfc_a01) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_sfc_a02) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_sfc_a03) + & + wetdep_2d(its:ite,jts:jte,p_glysoa_sfc_a04))*dt*0.001/mwoa ! mmol/m2 + endif + + else + if (p_no3aj .gt.1) wdi_no3(its:ite,jts:jte) = wdi_no3(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_no3aj)*dt*0.001/mwno3 ! mmol/m2 + if (p_so4aj .gt.1) wdi_so4(its:ite,jts:jte) = wdi_so4(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_so4aj)*dt*0.001/mwso4 ! mmol/m2 + endif - if (p_so4aj .gt.1) wdi_so4(its:ite,jts:jte) = wdi_so4(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_so4aj)*dt*0.001/mwso4 ! mmol/m2 - if (p_sulf .gt.1) wdi_so4(its:ite,jts:jte) = wdi_so4(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_sulf)*dt ! mmol/m2 - if (p_so2 .gt.1) wdi_so4(its:ite,jts:jte) = wdi_so4(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_so2)*dt ! mmol/m2 + if (p_hno3 .gt.1) wdi_hno3(its:ite,jts:jte) = wdi_hno3(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_hno3)*dt ! mmol/m2 + if (p_hno4 .gt.1) wdi_hno3(its:ite,jts:jte) = wdi_hno3(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_hno4)*dt ! mmol/m2 + + if (p_sulf .gt.1) wdi_sulf(its:ite,jts:jte) = wdi_sulf(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_sulf)*dt ! mmol/m2 + if (p_so2 .gt.1) wdi_so2(its:ite,jts:jte) = wdi_so2(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_so2)*dt ! mmol/m2 + + if (p_nh3 .gt.1) wdi_nh3(its:ite,jts:jte) = wdi_nh3(its:ite,jts:jte) + wetdep_2d(its:ite,jts:jte,p_nh3)*dt ! mmol/m2 ! Update the accumulated wet deposition: wd_no3(its:ite,jts:jte) = wd_no3(its:ite,jts:jte) + wdi_no3(its:ite,jts:jte) ! mmol/m2 wd_so4(its:ite,jts:jte) = wd_so4(its:ite,jts:jte) + wdi_so4(its:ite,jts:jte) ! mmol/m2 + wd_nh4(its:ite,jts:jte) = wd_nh4(its:ite,jts:jte) + wdi_nh4(its:ite,jts:jte) ! mmol/m2 + wd_oa (its:ite,jts:jte) = wd_oa (its:ite,jts:jte) + wdi_oa (its:ite,jts:jte) ! mmol/m2 + wd_so2 (its:ite,jts:jte) = wd_so2 (its:ite,jts:jte) + wdi_so2 (its:ite,jts:jte) ! mmol/m2 + wd_sulf (its:ite,jts:jte) = wd_sulf (its:ite,jts:jte) + wdi_sulf (its:ite,jts:jte) ! mmol/m2 + wd_hno3 (its:ite,jts:jte) = wd_hno3 (its:ite,jts:jte) + wdi_hno3 (its:ite,jts:jte) ! mmol/m2 + wd_nh3 (its:ite,jts:jte) = wd_nh3 (its:ite,jts:jte) + wdi_nh3 (its:ite,jts:jte) ! mmol/m2 + + wd_asoa(its:ite,jts:jte) = wd_asoa(its:ite,jts:jte) + wdi_asoa(its:ite,jts:jte) ! mmol/m2 + wd_bsoa(its:ite,jts:jte) = wd_bsoa(its:ite,jts:jte) + wdi_bsoa(its:ite,jts:jte) ! mmol/m2 + wd_cvasoa(its:ite,jts:jte) = wd_cvasoa(its:ite,jts:jte) + wdi_cvasoa(its:ite,jts:jte) ! mmol/m2 + wd_cvbsoa(its:ite,jts:jte) = wd_cvbsoa(its:ite,jts:jte) + wdi_cvbsoa(its:ite,jts:jte) ! mmol/m2 + endif END SUBROUTINE GRELLDRVCT @@ -1181,7 +1467,8 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & ! USE module_configure USE module_state_description, only: RADM2SORG,RADM2SORG_AQ,RACMSORG_AQ,RACMSORG_KPP, & RADM2SORG_KPP,RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP, & - RADM2SORG_AQCHEM,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP + RADM2SORG_AQCHEM,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP, & + CB05_SORG_VBS_AQ_KPP USE module_ctrans_aqchem USE module_input_chem_data, only: get_last_gas implicit none @@ -1300,6 +1587,9 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & integer :: & itf,ktf,iaer,igas + real :: & + frac_so4(4), frac_no3(4), frac_nh4(4), tot_so4, tot_nh4, tot_no3 + ! Gas/aqueous phase partitioning for wet scavenging/deposition of gas ! phase and aerosol species: real aq_gas_ratio @@ -1383,8 +1673,9 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & if ((chemopt .EQ. RADM2SORG .OR. chemopt .EQ. RADM2SORG_AQ .OR. chemopt .EQ. RACMSORG_AQ .OR. & chemopt .EQ. RACMSORG_KPP .OR. chemopt .EQ. RADM2SORG_KPP .OR. chemopt .EQ. RACM_ESRLSORG_KPP .OR. & chemopt .EQ. RACM_SOA_VBS_KPP .OR. chemopt .EQ. RADM2SORG_AQCHEM .OR. chemopt .EQ. RACMSORG_AQCHEM_KPP .OR. & - chemopt .EQ. RACM_ESRLSORG_AQCHEM_KPP) & - .and. (conv_tr_aqchem == 1)) then + chemopt .EQ. RACM_ESRLSORG_AQCHEM_KPP .OR. & + chemopt .EQ. CB05_SORG_VBS_AQ_KPP) & + .AND. conv_tr_aqchem == 1 ) then ! ! For MADE/SORGAM derived schemes with aqueous chemistry @@ -1424,11 +1715,17 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & gas(lnh3) = tr_up(i,k,p_nh3)*1.0e-6 gas(lh2o2) = tr_up(i,k,p_h2o2)*1.0e-6 gas(lo3) = tr_up(i,k,p_o3)*1.0e-6 - gas(lfoa) = tr_up(i,k,p_ora1)*1.0e-6 - gas(lmhp) = tr_up(i,k,p_op1)*1.0e-6 - gas(lpaa) = tr_up(i,k,p_paa)*1.0e-6 gas(lh2so4) = tr_up(i,k,p_sulf)*1.0e-6 - + if (chemopt==CB05_SORG_VBS_AQ_KPP) then + gas(lfoa) = tr_up(i,k,p_facd)*1.0e-6 + gas(lmhp) = tr_up(i,k,p_mepx)*1.0e-6 + gas(lpaa) = tr_up(i,k,p_pacd)*1.0e-6 + else + gas(lfoa) = tr_up(i,k,p_ora1)*1.0e-6 + gas(lmhp) = tr_up(i,k,p_op1)*1.0e-6 + gas(lpaa) = tr_up(i,k,p_paa)*1.0e-6 + end if + ! Aerosol mass concentrations before aqueous phase chemistry ! (with units conversion ug/kg -> mol/mol). Although AQCHEM ! accounts for much of the aerosol compounds in MADE, they are @@ -1475,10 +1772,16 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & tr_up(i,k,p_nh3) = gas(lnh3)*1.0e6 tr_up(i,k,p_h2o2) = gas(lh2o2)*1.0e6 tr_up(i,k,p_o3) = gas(lo3)*1.0e6 - tr_up(i,k,p_ora1) = gas(lfoa)*1.0e6 - tr_up(i,k,p_op1) = gas(lmhp)*1.0e6 - tr_up(i,k,p_paa) = gas(lpaa)*1.0e6 tr_up(i,k,p_sulf) = gas(lh2so4)*1.0e6 + if (chemopt==CB05_SORG_VBS_AQ_KPP) then + tr_up(i,k,p_facd) = gas(lfoa)*1.0e6 + tr_up(i,k,p_mepx) = gas(lmhp)*1.0e6 + tr_up(i,k,p_pacd) = gas(lpaa)*1.0e6 + else + tr_up(i,k,p_ora1) = gas(lfoa)*1.0e6 + tr_up(i,k,p_op1) = gas(lmhp)*1.0e6 + tr_up(i,k,p_paa) = gas(lpaa)*1.0e6 + end if ! Aerosol mass concentrations ! (with units conversion mol/mol -> ug/kg) @@ -1487,9 +1790,158 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & tr_up(i,k,p_nh4aj) = aerosol(lnh4acc)*1.0e9*mwnh4/mwdry tr_up(i,k,p_no3aj) = aerosol(lno3acc)*1.0e9*mwno3/mwdry + else if ((chemopt .EQ. mozart_mosaic_4bin_kpp .OR. & + chemopt .EQ. mozart_mosaic_4bin_aq_kpp) & + .AND. (conv_tr_aqchem == 1)) then + + ! + ! For MOSAIC 4bin scheme with aqueous chemistry + ! + + ! Air mass density + dens = 0.1*p(i,k)/t(i,k)*mwdry/8.314472 ! kg/m3 + + ! Column air number density: + airm = 1000.0*dens*dz/mwdry ! mol/m2 + + ! Wet scavenging initialization for AQCHEM + + GASWDEP = 0.0 + AERWDEP = 0.0 + HPWDEP = 0.0 + + ! We provide a precipitation rate and aerosol scavenging rates of zero, + ! in order to prevent wet scavenging in AQCHEM (it is treated later): + + precip = 0.0 ! mm/hr + + alfa0 = 0.0 + alfa2 = 0.0 + alfa3 = 0.0 + + ! Gas phase concentrations before aqueous phase chemistry + ! (with units conversion ppm -> mol/mol) + + gas(:) = 0.0 + + gas(lco2) = 380.0e-6 + + gas(lso2) = tr_up(i,k,p_so2)*1.0e-6 + gas(lhno3) = tr_up(i,k,p_hno3)*1.0e-6 + gas(ln2o5) = tr_up(i,k,p_n2o5)*1.0e-6 + gas(lnh3) = tr_up(i,k,p_nh3)*1.0e-6 + gas(lh2o2) = tr_up(i,k,p_h2o2)*1.0e-6 + gas(lo3) = tr_up(i,k,p_o3)*1.0e-6 + gas(lfoa) = tr_up(i,k,p_hcooh)*1.0e-6 + gas(lmhp) = tr_up(i,k,p_ch3ooh)*1.0e-6 + gas(lpaa) = tr_up(i,k,p_paa)*1.0e-6 + gas(lh2so4) = tr_up(i,k,p_sulf)*1.0e-6 + + ! Aerosol mass concentrations before aqueous phase chemistry + ! (with units conversion ug/kg -> mol/mol). Although AQCHEM + ! accounts for much of the aerosol compounds in MADE, they are + ! not treated at the moment by AQCHEM, as the mapping between + ! the organic compound groups in MADE and AQCHEM is not obvious. + + aerosol(:) = 0.0 + + ! We assume all particles in bins 2 - 4 are activated in cumulus clouds: + + ! remember size distribution + ! (if none existed before, frac_x is not set, hence distribute equally as default) + frac_so4(:) = 0.25 + frac_nh4(:) = 0.25 + frac_no3(:) = 0.25 + + tot_so4 = tr_up(i,k,p_so4_a01)+tr_up(i,k,p_so4_a02)+& + tr_up(i,k,p_so4_a03)+tr_up(i,k,p_so4_a04) + tot_nh4 = tr_up(i,k,p_nh4_a01)+tr_up(i,k,p_nh4_a02)+& + tr_up(i,k,p_nh4_a03)+tr_up(i,k,p_nh4_a04) + tot_no3 = tr_up(i,k,p_no3_a01)+tr_up(i,k,p_no3_a02)+& + tr_up(i,k,p_no3_a03)+tr_up(i,k,p_no3_a04) + + if (tot_so4 > 0.0) then + frac_so4(1) = tr_up(i,k,p_so4_a01) / tot_so4 + frac_so4(2) = tr_up(i,k,p_so4_a02) / tot_so4 + frac_so4(3) = tr_up(i,k,p_so4_a03) / tot_so4 + frac_so4(4) = tr_up(i,k,p_so4_a04) / tot_so4 + aerosol(lso4acc) = tot_so4 *1.0e-9*mwdry/mwso4 + end if + + if (tot_nh4 > 0.0) then + frac_nh4(1) = tr_up(i,k,p_nh4_a01) / tot_nh4 + frac_nh4(2) = tr_up(i,k,p_nh4_a02) / tot_nh4 + frac_nh4(3) = tr_up(i,k,p_nh4_a03) / tot_nh4 + frac_nh4(4) = tr_up(i,k,p_nh4_a04) / tot_nh4 + aerosol(lnh4acc) = tot_nh4 *1.0e-9*mwdry/mwnh4 + end if + + if (tot_no3 > 0.0) then + frac_no3(1) = tr_up(i,k,p_no3_a01) / tot_no3 + frac_no3(2) = tr_up(i,k,p_no3_a02) / tot_no3 + frac_no3(3) = tr_up(i,k,p_no3_a03) / tot_no3 + frac_no3(4) = tr_up(i,k,p_no3_a04) / tot_no3 + aerosol(lno3acc) = tot_no3 *1.0e-9*mwdry/mwno3 + end if + + ! Cloud lifetime: + taucld = 1800.0 + + if (clw_all(i,k)*dens .gt. qcldwtr_cutoff) then ! Cloud water > threshold + CALL AQCHEM( & + t(i,k), & + p(i,k)*100., & + taucld, & + precip, & + clw_all(i,k)*dens, & + clw_all(i,k)*dens, & + airm, & + ALFA0, & + ALFA2, & + ALFA3, & + GAS, & + AEROSOL, & + LIQUID, & + GASWDEP, & + AERWDEP, & + HPWDEP) endif -! wet scavenging option (turn off by setting + ! Gas phase concentrations after aqueous phase chemistry + ! (with units conversion mol/mol -> ppm) + + tr_up(i,k,p_so2) = gas(lso2)*1.0e6 + tr_up(i,k,p_hno3) = gas(lhno3)*1.0e6 + tr_up(i,k,p_n2o5) = gas(ln2o5)*1.0e6 + tr_up(i,k,p_nh3) = gas(lnh3)*1.0e6 + tr_up(i,k,p_h2o2) = gas(lh2o2)*1.0e6 + tr_up(i,k,p_o3) = gas(lo3)*1.0e6 + tr_up(i,k,p_hcooh) = gas(lfoa)*1.0e6 + tr_up(i,k,p_ch3ooh) = gas(lmhp)*1.0e6 + tr_up(i,k,p_paa) = gas(lpaa)*1.0e6 + tr_up(i,k,p_sulf) = gas(lh2so4)*1.0e6 + + ! Aerosol mass concentrations + ! (with units conversion mol/mol -> ug/kg) + + tr_up(i,k,p_so4_a01) = aerosol(lso4acc) * frac_so4(1) * 1.0e9*mwso4/mwdry + tr_up(i,k,p_so4_a02) = aerosol(lso4acc) * frac_so4(2) * 1.0e9*mwso4/mwdry + tr_up(i,k,p_so4_a03) = aerosol(lso4acc) * frac_so4(3) * 1.0e9*mwso4/mwdry + tr_up(i,k,p_so4_a04) = aerosol(lso4acc) * frac_so4(4) * 1.0e9*mwso4/mwdry + + tr_up(i,k,p_nh4_a01) = aerosol(lnh4acc) * frac_nh4(1) * 1.0e9*mwnh4/mwdry + tr_up(i,k,p_nh4_a02) = aerosol(lnh4acc) * frac_nh4(2) * 1.0e9*mwnh4/mwdry + tr_up(i,k,p_nh4_a03) = aerosol(lnh4acc) * frac_nh4(3) * 1.0e9*mwnh4/mwdry + tr_up(i,k,p_nh4_a04) = aerosol(lnh4acc) * frac_nh4(4) * 1.0e9*mwnh4/mwdry + + tr_up(i,k,p_no3_a01) = aerosol(lno3acc) * frac_no3(1) * 1.0e9*mwno3/mwdry + tr_up(i,k,p_no3_a02) = aerosol(lno3acc) * frac_no3(2) * 1.0e9*mwno3/mwdry + tr_up(i,k,p_no3_a03) = aerosol(lno3acc) * frac_no3(3) * 1.0e9*mwno3/mwdry + tr_up(i,k,p_no3_a04) = aerosol(lno3acc) * frac_no3(4) * 1.0e9*mwno3/mwdry + + endif + +! wet scavenging option (turn off by setting conv_tr_wetscav = 0) ! if (conv_tr_wetscav == 1) then @@ -1499,12 +1951,66 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & aq_gas_ratio = 0.0 ! Fraction of gas phase species that partions into the liquid phase: + + ! tried to be consistent with values and species in module_mozcart_wetscav.F + if (nv .eq. p_h2o2) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 8.33e+04, 7379.) + if (nv .eq. p_hno3) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 2.6e+06, 8700.) + if (nv .eq. p_hcho) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 6.30e+03, 6425.) + if (nv .eq. p_ch3ooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 3.11e+02, 5241.) + if (nv .eq. p_c3h6ooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 2.20e+02, 5653.) + if (nv .eq. p_paa) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 8.37e+02, 5308.) + if (nv .eq. p_hno4) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 1.2e+04, 6900.) ! values from henrys-law.org, Regimbal and Mozurkewich, 1997 + if (nv .eq. p_onit) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 1.00e+03, 6000.) + if (nv .eq. p_mvk) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 1.7e-03, 0.) + if (nv .eq. p_macr) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 1.70e-03, 0.) + if (nv .eq. p_etooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 3.36e+02, 5995.) + if (nv .eq. p_prooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 3.36e+02, 5995.) + if (nv .eq. p_acetp) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 3.36e+02, 5995.) + if (nv .eq. p_mgly) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 3.71e+03, 7541.) + if (nv .eq. p_mvkooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 2.6e+06, 8700.) + if (nv .eq. p_onitr) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 7.51e+03, 6485.) + if (nv .eq. p_isooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 2.6e+06, 8700.) + if (nv .eq. p_ch3oh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 2.20e+02, 4934.) + if (nv .eq. p_c2h5oh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 2.00e+02, 6500.) + if (nv .eq. p_glyald) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 4.14e+04, 4630.) + if (nv .eq. p_hydrald) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 7.00e+01, 6000.) + if (nv .eq. p_ald) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 1.14e+01, 6267.) + if (nv .eq. p_isopn) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 1.00e+01, 0.) + if (nv .eq. p_alkooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 3.11e+02, 5241.) + if (nv .eq. p_mekooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 3.11e+02, 5241.) + if (nv .eq. p_tolooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 3.11e+02, 5241.) + if (nv .eq. p_terpooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 3.11e+02, 5241.) + if (nv .eq. p_nh3) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 7.40e+01, 3400.) + if (nv .eq. p_xooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 90.5, 5607.) + if (nv .eq. p_ch3cooh) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 4.1e3, 6300.) + if (nv .eq. p_so2) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 1.2, 3100.) + if (nv .eq. p_sulf) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 1e+11, 0.) ! order of magnitude approx. (Gmitro and Vermeulen, 1964) + + IF (chemopt .EQ. mozart_mosaic_4bin_aq_kpp) THEN + if (nv .eq. p_cvasoaX) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 0.0e+00, 0.) + if (nv .eq. p_cvasoa1) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 1.06E+08, 6014.) + if (nv .eq. p_cvasoa2) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 1.84E+07, 6014.) + if (nv .eq. p_cvasoa3) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 3.18E+06, 6014.) + if (nv .eq. p_cvasoa4) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 5.50E+05, 6014.) + if (nv .eq. p_cvbsoaX) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 0.0e+00, 0.) + if (nv .eq. p_cvbsoa1) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 5.25E+09, 6014.) + if (nv .eq. p_cvbsoa2) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 7.00E+08, 6014.) + if (nv .eq. p_cvbsoa3) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 9.33E+07, 6014.) + if (nv .eq. p_cvbsoa4) aq_gas_ratio = aq_frac(p(i,k)*100., t(i,k), clw_all(i,k)*dens, 1.24E+07, 6014.) + ENDIF - if (nv.eq.p_so2) aq_gas_ratio = 1.0 - if (nv.eq.p_sulf) aq_gas_ratio = 1.0 - if (nv.eq.p_nh3) aq_gas_ratio = 1.0 - if (nv.eq.p_hno3) aq_gas_ratio = 1.0 +! if (nv.eq.p_so2) aq_gas_ratio = 1.0 +! if (nv.eq.p_sulf) aq_gas_ratio = 1.0 +! if (nv.eq.p_nh3) aq_gas_ratio = 1.0 +! if (nv.eq.p_hno3) aq_gas_ratio = 1.0 + + if (nv.gt.numgas) aq_gas_ratio = 0.5 + + if (nv.eq.p_so4aj) aq_gas_ratio = 1.0 + if (nv.eq.p_nh4aj) aq_gas_ratio = 1.0 + if (nv.eq.p_no3aj) aq_gas_ratio = 1.0 + if (nv.eq.p_bc1 .or. nv.eq.p_oc1 .or. nv.eq.p_dms) aq_gas_ratio=0. if (nv.eq.p_sulf .or. nv.eq.p_seas_1 .or. nv.eq.p_seas_2) aq_gas_ratio=1. if (nv.eq.p_seas_3 .or. nv.eq.p_seas_4) aq_gas_ratio=1. @@ -1527,6 +2033,37 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & END subroutine cup_up_tracer +! calculates the fraction (0-1) of a soluble gas that should +! partition into the liquid phase according to instantaneous +! Henry's law equilibrium +REAL FUNCTION aq_frac(p, T, q, Kh_298, dHoR) + + REAL, INTENT(IN) :: p, & ! air pressure (Pa) + T, & ! air temperature (K) + q, & ! total liquid water content (kg/m3) + Kh_298, & ! Henry's law constant (M/atm == (mol_aq/dm3_aq)/atm) + dHoR ! enthalpy of solution (in K, dH/R) + + REAL, PARAMETER :: Rgas = 8.31446 ! ideal gas constant (J mol-1 K-1) + + ! local variables + REAL :: Kh, tr_air, tr_aq + + ! with van't Hoff's equation as temperature dependence + ! and conversion to SI units ( (mol_aq/m3_aq)/Pa ) + Kh = Kh_298 * exp ( dHoR * ( 1.0/T - 1.0/298 ) ) * 101.325 + + ! moles tracer m-3_air + tr_air = 1 / (Rgas * T) + + ! moles tracer m-3 (air) + tr_aq = Kh * (q / 1000.0) + + aq_frac = min( 1.0, max( 0.0, tr_aq / (tr_aq + tr_air) ) ) + +END FUNCTION aq_frac + + SUBROUTINE cup_dd_tracer(ierr,z_cup,qrcd,tracer,tre_cup,tr_up,tr_dd, & tr_pw,tr_pwd,jmin,cdd,entr,zd,pwdper,wetdep,xmb,k22, & @@ -1606,7 +2143,9 @@ SUBROUTINE cup_dd_tracer(ierr,z_cup,qrcd,tracer,tre_cup,tr_up,tr_dd, & IF(ierr(I).eq.0)then - do nv=1,numgas ! Only gas phase species evaporate along with rain water +! why shouldn't that work for aerosols as well? +! do nv=1,numgas ! Only gas phase species evaporate along with rain water + do nv=1,num_chem do k=ktf,kts,-1 ! Descending loop over all levels @@ -1718,6 +2257,7 @@ SUBROUTINE neg_check_ct(name,pret,ktop,epsilc,dt,q,outq,iopt,num_chem, & dt,epsilc real :: tracermin,tracermax,thresh,qmem,qmemf,qmem2,qtest,qmem1 character *(*) name + integer :: nv, i, k ! ! check whether routine produces negative q's. This can happen, since ! tendencies are calculated based on forced q's. This should have no diff --git a/wrfv2_fire/chem/module_data_ISRPIA.F b/wrfv2_fire/chem/module_data_ISRPIA.F new file mode 100755 index 00000000..4c514f99 --- /dev/null +++ b/wrfv2_fire/chem/module_data_ISRPIA.F @@ -0,0 +1,181 @@ + MODULE ISRPIA +! %W% %P% %G% %U% +!*********************************************************************** +!*********************************************************************** +! Development of this code was sponsored by EPRI, 3412 Hillview Ave., * +! Palo Alto, CA 94304 under Contract WO8221-01 * +! * +! Developed by Yang Zhang, Betty Pun, and Christian Seigneur, * +! Atmospheric and Environmental Research, Inc., 2682 Bishop Drive, * +! Suite 120, San Ramon, CA 94583 * +! +! Development of previously available modules are listed at the * +! begining of the code of the corresponding module. Some of these * +! modules may be copyrighted * +!*********************************************************************** +! RCS file, release, date & time of last delta, author, state, [and locker] +! $Header: /ncsu/volume2/Mac_Share3/yang/madrid_final/revision/code/july2002/models/CCTM/src/aero/aero_MADRID1_mebi/ISRPIA.EXT,v 1.1 2002/10/24 00:55:29 models3 Exp $ + +!======================================================================= +! +! *** ISORROPIA PLUS CODE +! *** INCLUDE FILE 'ISRPIA.EXT' +! *** THIS FILE CONTAINS THE DECLARATIONS OF THE GLOBAL CONSTANTS +! AND VARIABLES. +! +! *** COPYRIGHT 1996-98, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY +! *** WRITTEN BY ATHANASIOS NENES +! +! ************************************************************************************** +! FUNCTION: Include file for the ISORROPIA thermodynamic module * +! PRECONDITION REQUIRED: Aerosol Option: MADRID (Development and * +! Application of the Model of Aerosol * +! Dynamics, Reaction, Ionization and Dissolution) * +! RETURN VALUES: gaseous and PM species concentrations * +! KEY SUBROUTINES AND FUNCTIONS CALLED: * +! REVISION HISTORY: * +! Original coagsolv code provided by ATHANASIOS NENES, Caltech (now at * +! Georgia Tech), 2000 * +! Revised by Yang Zhang and Xiao-Ming Hu, NCSU, May-June 2005 * +! to incorporate MADRID into WRF/Chem * +! Revised by Ying Pan and Yang Zhang, NCSU, Oct. 2009 * +! to couple CB05 with MADE/SORGAM-AQ-ISORROPIA * +! ************************************************************************************** + +!======================================================================= +! +! USE OTHR +! USE CGEN +! USE SOLN +! USE IONSdata +! USE ZSRdata +! USE SALT +! USE GAS_MADRID +! USE EQUK + USE module_data_isrpia_data + + IMPLICIT DOUBLE PRECISION (A-H, O-Z) + PARAMETER (NCOMP=5, NIONS=7, NGASAQ=3, NSLDS=9, NPAIR=13, & + NZSR=100, NERRMX=25) +! PARAMETER (NIONS=7, NSLDS=9, NERRMX=25) + + DOUBLE PRECISION W(NCOMP), WAER(NCOMP), TEMP, RH, IPROB + INTEGER METSTBL, NADJ + + DOUBLE PRECISION DRH2SO4, DRNH42S4, DRNAHSO4, DRNACL, DRNANO3, & + DRNA2SO4, DRNH4HS4, DRLC, DRNH4NO3, DRNH4CL + + DOUBLE PRECISION :: DRMLCAB,DRMLCAS,DRMASAN,DRMG1, DRMG2, & + DRMG3, DRMH1, DRMH2, DRMI1, DRMI2, & + DRMI3, DRMQ1, DRMR1, DRMR2, DRMR3, & + DRMR4, DRMR5, DRMR6, DRMR7, DRMR8, & + DRMR9, DRMR10, DRMR11, DRMR12, DRMR13 + INTEGER WFTYP + +! DOUBLE PRECISION CH2SO4, CNH42S4, CNH4HS4, CNACL, CNA2SO4, & +! CNANO3, CNH4NO3, CNH4CL, CNAHSO4, CLC + +! DOUBLE PRECISION GNH3, GHNO3, GHCL + +! DOUBLE PRECISION XK1, XK2, XK3, XK4, XK5, XK6, XK7, XK8, XK9, XK10, & +! XK11, XK12, XK13, XK14, XKW, XK21, XK22, XK31, XK32, & +! XK41, XK42 + + CHARACTER SCASE*15 + DOUBLE PRECISION SULRATW, SULRAT, SODRAT + +! DOUBLE PRECISION EPS, MAXIT, NSWEEP, NDIV, ICLACT +! DATA EPS/1D-6/, MAXIT/100/,NSWEEP/4/,NDIV/5/ + + CHARACTER*40 ERRMSG(NERRMX) + INTEGER ERRSTK(NERRMX), NOFER + LOGICAL STKOFL + DATA ERRSTK/NERRMX*0/, ERRMSG/NERRMX*' '/, NOFER/0/, & + STKOFL/.FALSE./ + +! CHARACTER VERSION*15 +! DOUBLE PRECISION GREAT, TINY, TINY2, ZERO, ONE +! DATA & +! TINY/1D-20/, GREAT/1D10/, ZERO/0.0D0/, ONE/1.0D0/, & +! TINY2/1D-11/ +! DATA VERSION /'1.7 (03/26/07)'/ + +! +! *** INPUT VARIABLES ************************************************** +! +! INTEGER METSTBL +! COMMON /INPT/ W(NCOMP), WAER(NCOMP), TEMP, RH, IPROB, METSTBL +! +! *** WATER ACTIVITIES OF PURE SALT SOLUTIONS ************************** +! +! COMMON /ZSR / AWAS(NZSR), AWSS(NZSR), AWAC(NZSR), AWSC(NZSR), +! & AWAN(NZSR), AWSN(NZSR), AWSB(NZSR), AWAB(NZSR), +! & AWSA(NZSR), AWLC(NZSR) +! +! *** DELIQUESCENCE RELATIVE HUMIDITIES ******************************** +! +! INTEGER WFTYP +! COMMON /DRH / DRH2SO4, DRNH42S4, DRNAHSO4, DRNACL, DRNANO3, +! & DRNA2SO4, DRNH4HS4, DRLC, DRNH4NO3, DRNH4CL +! COMMON /MDRH/ DRMLCAB, DRMLCAS, DRMASAN, DRMG1, DRMG2, +! & DRMG3, DRMH1, DRMH2, DRMI1, DRMI2, +! & DRMI3, DRMQ1, DRMR1, DRMR2, DRMR3, +! & DRMR4, DRMR5, DRMR6, DRMR7, DRMR8, +! & DRMR9, DRMR10, DRMR11, DRMR12, DRMR13, +! & WFTYP +! +! *** VARIABLES FOR LIQUID AEROSOL PHASE ******************************* +! +! DOUBLE PRECISION MOLAL, MOLALR, M0 +! REAL IONIC +! LOGICAL CALAOU, CALAIN, FRST, DRYF +! COMMON /IONS/ MOLAL(NIONS), MOLALR(NPAIR), GAMA(NPAIR), ZZ(NPAIR), +! & Z(NIONS), GAMOU(NPAIR), GAMIN(NPAIR),M0(NPAIR), +! & GASAQ(NGASAQ), +! & EPSACT, COH, CHNO3, CHCL, +! & WATER, IONIC, IACALC, +! & FRST, CALAIN, CALAOU, DRYF +! +! *** VARIABLES FOR SOLID AEROSOL PHASE ******************************** +! +! COMMON /SALT/ CH2SO4, CNH42S4, CNH4HS4, CNACL, CNA2SO4, +! & CNANO3, CNH4NO3, CNH4CL, CNAHSO4, CLC +! +! *** VARIABLES FOR GAS PHASE ****************************************** +! +! COMMON /GAS / GNH3, GHNO3, GHCL +! +! *** EQUILIBRIUM CONSTANTS ******************************************** +! +! COMMON /EQUK/ XK1, XK2, XK3, XK4, XK5, XK6, XK7, XK8, XK9, XK10, +! & XK11, XK12, XK13, XK14, XKW, XK21, XK22, XK31, XK32, +! & XK41, XK42 +! +! *** MOLECULAR WEIGHTS ************************************************ +! +! DOUBLE PRECISION IMW +! COMMON /OTHR/ R, IMW(NIONS), WMW(NCOMP), SMW(NPAIR) +! +! *** SOLUTION/INFO VARIABLES ****************************************** +! +! CHARACTER SCASE*15 +! COMMON /CASE/ SULRATW, SULRAT, SODRAT, SCASE +! +! COMMON /SOLN/ EPS, MAXIT, NSWEEP, NDIV, ICLACT +! +! *** ERROR SYSTEM ***************************************************** +! +! CHARACTER ERRMSG*40 +! INTEGER ERRSTK, NOFER +! LOGICAL STKOFL +! COMMON /EROR/ STKOFL, NOFER, ERRSTK(NERRMX), ERRMSG(NERRMX) +! +! *** GENERIC VARIABLES ************************************************ +! +! CHARACTER VERSION*14 +! COMMON /CGEN/ GREAT, TINY, TINY2, ZERO, ONE, VERSION + +! +! *** END OF INCLUDE FILE ********************************************** + END MODULE ISRPIA +! diff --git a/wrfv2_fire/chem/module_data_isrpia.F b/wrfv2_fire/chem/module_data_isrpia.F deleted file mode 100644 index cfd5199a..00000000 --- a/wrfv2_fire/chem/module_data_isrpia.F +++ /dev/null @@ -1,13791 +0,0 @@ -module module_data_isrpia - -!======================================================================= -! -! *** ISORROPIA CODE -! *** INCLUDE FILE 'ISRPIA.INC' -! *** THIS FILE CONTAINS THE DECLARATIONS OF THE GLOBAL CONSTANTS -! AND VARIABLES. -! -! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, -! *** GEORGIA INSTITUTE OF TECHNOLOGY -! *** WRITTEN BY ATHANASIOS NENES -! *** UPDATED BY CHRISTOS FOUNTOUKIS -! -!======================================================================= -! -! - -! IMPLICIT DOUBLE PRECISION (A-H,O-Z) - implicit none - INTEGER,PARAMETER::NCOMP=5,NIONS=7,NGASAQ=3,NSLDS=9,NPAIR=13,NZSR=100, & - NERRMX=25 -! -! *** INPUT VARIABLES ************************************************** -! - - REAL(KIND=8) W(NCOMP), WAER(NCOMP), TEMP, RH - INTEGER NADJ, IPROB, METSTBL -! -! *** WATER ACTIVITIES OF PURE SALT SOLUTIONS ************************** -! - REAL(KIND=8) AWAS(NZSR), AWSS(NZSR), AWAC(NZSR), AWSC(NZSR), & - AWAN(NZSR), AWSN(NZSR), AWSB(NZSR), AWAB(NZSR), & - AWSA(NZSR), AWLC(NZSR) -! -! *** DELIQUESCENCE RELATIVE HUMIDITIES ******************************** -! - INTEGER WFTYP - REAL(KIND=8) DRH2SO4, DRNH42S4, DRNAHSO4, DRNACL, DRNANO3, & - DRNA2SO4, DRNH4HS4, DRLC, DRNH4NO3, DRNH4CL - REAL(KIND=8) DRMLCAB, DRMLCAS, DRMASAN, DRMG1, DRMG2, & - DRMG3, DRMH1, DRMH2, DRMI1, DRMI2, & - DRMI3, DRMQ1, DRMR1, DRMR2, DRMR3, & - DRMR4, DRMR5, DRMR6, DRMR7, DRMR8, & - DRMR9, DRMR10, DRMR11, DRMR12, DRMR13 -! -! *** VARIABLES FOR LIQUID AEROSOL PHASE ******************************* -! - - REAL(KIND=8) IONIC - LOGICAL CALAOU, CALAIN, FRST, DRYF - REAL(KIND=8) MOLAL(NIONS), MOLALR(NPAIR), GAMA(NPAIR), ZZ(NPAIR), & - Z(NIONS), GAMOU(NPAIR), GAMIN(NPAIR),M0(NPAIR), & - GASAQ(NGASAQ), & - EPSACT, COH, CHNO3, CHCL, & - WATER - - INTEGER IACALC -! -! *** VARIABLES FOR SOLID AEROSOL PHASE ******************************** -! - REAL(KIND=8)CH2SO4, CNH42S4, CNH4HS4, CNACL, CNA2SO4, & - CNANO3, CNH4NO3, CNH4CL, CNAHSO4, CLC -! -! *** VARIABLES FOR GAS PHASE ****************************************** -! - REAL(KIND=8) GNH3, GHNO3, GHCL -! -! *** EQUILIBRIUM CONSTANTS ******************************************** -! - REAL(KIND=8) XK1, XK2, XK3, XK4, XK5, XK6, XK7, XK8, XK9, XK10, & - XK11,XK12,XK13,XK14,XKW, XK21,XK22,XK31,XK32,XK41, & - XK42 -! -! *** MOLECULAR WEIGHTS ************************************************ -! - REAL(KIND=8) R, IMW(NIONS), WMW(NCOMP), SMW(NPAIR) -! -! *** SOLUTION/INFO VARIABLES ****************************************** -! - CHARACTER SCASE*15 - - REAL(KIND=8) SULRATW, SULRAT, SODRAT - - REAL(KIND=8) EPS, ICLACT - INTEGER MAXIT, NSWEEP, NDIV -! -! *** ERROR SYSTEM ***************************************************** -! - CHARACTER *40 ERRMSG(NERRMX) - INTEGER ERRSTK(NERRMX), NOFER - LOGICAL STKOFL -! -! *** GENERIC VARIABLES ************************************************ -! - CHARACTER VERSION*15 - REAL(KIND=8) GREAT, TINY, TINY2, ZERO, ONE -! -! *** END OF INCLUDE FILE ********************************************** -! - - REAL(KIND=8) FRSO4, FRNH4,SRI - -!======================================================================= -! -! *** ISORROPIA CODE -! *** BLOCK DATA BLKISO -! *** THIS SUBROUTINE PROVIDES INITIAL (DEFAULT) VALUES TO PROGRAM -! PARAMETERS VIA DATA STATEMENTS -! -! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, -! *** GEORGIA INSTITUTE OF TECHNOLOGY -! *** WRITTEN BY ATHANASIOS NENES -! *** UPDATED BY CHRISTOS FOUNTOUKIS -! -! *** ZSR RELATIONSHIP PARAMETERS MODIFIED BY DOUGLAS WALDRON -! *** OCTOBER 2003 -! *** BASED ON AIM MODEL III (http://mae.ucdavis.edu/wexler/aim) -! -!======================================================================= - -! BLOCK DATA BLKISO -! INCLUDE 'isrpia.inc' -! -! *** DEFAULT VALUES ************************************************* -! - DATA TEMP/298.0/, R/82.0567D-6/, RH/0.9D0/, EPS/1D-6/, MAXIT/100/, & - TINY/1D-20/, GREAT/1D10/, ZERO/0.0D0/, ONE/1.0D0/,NSWEEP/4/, & - TINY2/1D-11/,NDIV/5/ -! - DATA MOLAL/NIONS*0.0D0/, MOLALR/NPAIR*0.0D0/, GAMA/NPAIR*0.1D0/, & - GAMOU/NPAIR*1D10/, GAMIN/NPAIR*1D10/, CALAIN/.TRUE./, & - CALAOU/.TRUE./, EPSACT/5D-2/, ICLACT/0/, & - IACALC/1/, NADJ/0/, WFTYP/2/ - - DATA ERRSTK/NERRMX*0/, ERRMSG/NERRMX*' '/, NOFER/0/, & - STKOFL/.FALSE./ - - DATA IPROB/0/, METSTBL/0/ - - DATA VERSION /'1.7 (03/26/07)'/ - -! *** OTHER PARAMETERS *********************************************** -! - DATA SMW/58.5,142.,85.0,132.,80.0,53.5,98.0,98.0,115.,63.0,& - 36.5,120.,247./ & - IMW/ 1.0,23.0,18.0,35.5,96.0,97.0,63.0/, & - WMW/23.0,98.0,17.0,63.0,36.5/ - - DATA ZZ/1,2,1,2,1,1,2,1,1,1,1,1,2/, Z /1,1,1,1,2,1,1/ -! -! *** ZSR RELATIONSHIP PARAMETERS ************************************** -! -! awas= ammonium sulfate -! - DATA AWAS/10*187.72, & - 158.13,134.41,115.37,100.10, 87.86, 78.00, 70.00, 63.45, 58.02, & - 53.46, & - 49.59, 46.26, 43.37, 40.84, 38.59, 36.59, 34.79, 33.16, 31.67, & - 30.31, & - 29.07, 27.91, 26.84, 25.84, 24.91, 24.03, 23.21, 22.44, 21.70, & - 21.01, & - 20.34, 19.71, 19.11, 18.54, 17.99, 17.46, 16.95, 16.46, 15.99, & - 15.54, & - 15.10, 14.67, 14.26, 13.86, 13.47, 13.09, 12.72, 12.36, 12.01, & - 11.67, & - 11.33, 11.00, 10.68, 10.37, 10.06, 9.75, 9.45, 9.15, 8.86, & - 8.57, & - 8.29, 8.01, 7.73, 7.45, 7.18, 6.91, 6.64, 6.37, 6.10, & - 5.83, & - 5.56, 5.29, 5.02, 4.74, 4.47, 4.19, 3.91, 3.63, 3.34, & - 3.05, & - 2.75, 2.45, 2.14, 1.83, 1.51, 1.19, 0.87, 0.56, 0.26, & - 0.1/ -! -! awsn= sodium nitrate -! - DATA AWSN/10*394.54, & - 338.91,293.01,254.73,222.61,195.56,172.76,153.53,137.32,123.65, & - 112.08, & - 102.26, 93.88, 86.68, 80.45, 75.02, 70.24, 66.02, 62.26, 58.89, & - 55.85, & - 53.09, 50.57, 48.26, 46.14, 44.17, 42.35, 40.65, 39.06, 37.57, & - 36.17, & - 34.85, 33.60, 32.42, 31.29, 30.22, 29.20, 28.22, 27.28, 26.39, & - 25.52, & - 24.69, 23.89, 23.12, 22.37, 21.65, 20.94, 20.26, 19.60, 18.96, & - 18.33, & - 17.72, 17.12, 16.53, 15.96, 15.40, 14.85, 14.31, 13.78, 13.26, & - 12.75, & - 12.25, 11.75, 11.26, 10.77, 10.29, 9.82, 9.35, 8.88, 8.42, & - 7.97, & - 7.52, 7.07, 6.62, 6.18, 5.75, 5.32, 4.89, 4.47, 4.05, & - 3.64, & - 3.24, 2.84, 2.45, 2.07, 1.70, 1.34, 0.99, 0.65, 0.31, & - 0.1/ -! -! awsc= sodium chloride -! - DATA AWSC/10*28.16, & - 27.17, 26.27, 25.45, 24.69, 23.98, 23.33, 22.72, 22.14, 21.59, & - 21.08, & - 20.58, 20.12, 19.67, 19.24, 18.82, 18.43, 18.04, 17.67, 17.32, & - 16.97, & - 16.63, 16.31, 15.99, 15.68, 15.38, 15.08, 14.79, 14.51, 14.24, & - 13.97, & - 13.70, 13.44, 13.18, 12.93, 12.68, 12.44, 12.20, 11.96, 11.73, & - 11.50, & - 11.27, 11.05, 10.82, 10.60, 10.38, 10.16, 9.95, 9.74, 9.52, & - 9.31, & - 9.10, 8.89, 8.69, 8.48, 8.27, 8.07, 7.86, 7.65, 7.45, & - 7.24, & - 7.04, 6.83, 6.62, 6.42, 6.21, 6.00, 5.79, 5.58, 5.36, & - 5.15, & - 4.93, 4.71, 4.48, 4.26, 4.03, 3.80, 3.56, 3.32, 3.07, & - 2.82, & - 2.57, 2.30, 2.04, 1.76, 1.48, 1.20, 0.91, 0.61, 0.30, & - 0.1/ -! -! awac= ammonium chloride -! - DATA AWAC/10*1209.00, & - 1067.60,949.27,848.62,761.82,686.04,619.16,559.55,505.92,457.25,& - 412.69, & - 371.55,333.21,297.13,262.81,229.78,197.59,165.98,135.49,108.57, & - 88.29, & - 74.40, 64.75, 57.69, 52.25, 47.90, 44.30, 41.27, 38.65, 36.36, & - 34.34, & - 32.52, 30.88, 29.39, 28.02, 26.76, 25.60, 24.51, 23.50, 22.55, & - 21.65, & - 20.80, 20.00, 19.24, 18.52, 17.83, 17.17, 16.54, 15.93, 15.35, & - 14.79, & - 14.25, 13.73, 13.22, 12.73, 12.26, 11.80, 11.35, 10.92, 10.49, & - 10.08, & - 9.67, 9.28, 8.89, 8.51, 8.14, 7.77, 7.42, 7.06, 6.72, & - 6.37, & - 6.03, 5.70, 5.37, 5.05, 4.72, 4.40, 4.08, 3.77, 3.45, & - 3.14, & - 2.82, 2.51, 2.20, 1.89, 1.57, 1.26, 0.94, 0.62, 0.31, & - 0.1/ -! -! awss= sodium sulfate -! - DATA AWSS/10*24.10, & - 23.17, 22.34, 21.58, 20.90, 20.27, 19.69, 19.15, 18.64, 18.17, & - 17.72, & - 17.30, 16.90, 16.52, 16.16, 15.81, 15.48, 15.16, 14.85, 14.55, & - 14.27, & - 13.99, 13.73, 13.47, 13.21, 12.97, 12.73, 12.50, 12.27, 12.05, & - 11.84, & - 11.62, 11.42, 11.21, 11.01, 10.82, 10.63, 10.44, 10.25, 10.07, & - 9.89, & - 9.71, 9.53, 9.36, 9.19, 9.02, 8.85, 8.68, 8.51, 8.35, & - 8.19, & - 8.02, 7.86, 7.70, 7.54, 7.38, 7.22, 7.06, 6.90, 6.74, & - 6.58, & - 6.42, 6.26, 6.10, 5.94, 5.78, 5.61, 5.45, 5.28, 5.11, & - 4.93, & - 4.76, 4.58, 4.39, 4.20, 4.01, 3.81, 3.60, 3.39, 3.16, & - 2.93, & - 2.68, 2.41, 2.13, 1.83, 1.52, 1.19, 0.86, 0.54, 0.25, & - 0.1/ -! -! awab= ammonium bisulfate -! - DATA AWAB/10*312.84, & - 271.43,237.19,208.52,184.28,163.64,145.97,130.79,117.72,106.42, & - 96.64, & - 88.16, 80.77, 74.33, 68.67, 63.70, 59.30, 55.39, 51.89, 48.76, & - 45.93, & - 43.38, 41.05, 38.92, 36.97, 35.18, 33.52, 31.98, 30.55, 29.22, & - 27.98, & - 26.81, 25.71, 24.67, 23.70, 22.77, 21.90, 21.06, 20.27, 19.52, & - 18.80, & - 18.11, 17.45, 16.82, 16.21, 15.63, 15.07, 14.53, 14.01, 13.51, & - 13.02, & - 12.56, 12.10, 11.66, 11.24, 10.82, 10.42, 10.04, 9.66, 9.29, & - 8.93, & - 8.58, 8.24, 7.91, 7.58, 7.26, 6.95, 6.65, 6.35, 6.05, & - 5.76, & - 5.48, 5.20, 4.92, 4.64, 4.37, 4.09, 3.82, 3.54, 3.27, & - 2.99, & - 2.70, 2.42, 2.12, 1.83, 1.52, 1.22, 0.90, 0.59, 0.28, & - 0.1/ -! -! awsa= sulfuric acid -! - DATA AWSA/34.00, 33.56, 29.22, 26.55, 24.61, 23.11, 21.89, 20.87,& - 19.99, 18.45, & - 17.83, 17.26, 16.73, 16.25, 15.80, 15.38, 14.98, 14.61, 14.26, & - 13.93, & - 13.61, 13.30, 13.01, 12.73, 12.47, 12.21, 11.96, 11.72, 11.49, & - 11.26, & - 11.04, 10.83, 10.62, 10.42, 10.23, 10.03, 9.85, 9.67, 9.49, & - 9.31, & - 9.14, 8.97, 8.81, 8.65, 8.49, 8.33, 8.18, 8.02, 7.87, & - 7.73, & - 7.58, 7.44, 7.29, 7.15, 7.01, 6.88, 6.74, 6.61, 6.47, & - 6.34, & - 6.21, 6.07, 5.94, 5.81, 5.68, 5.55, 5.43, 5.30, 5.17, & - 5.04, & - 4.91, 4.78, 4.65, 4.52, 4.39, 4.26, 4.13, 4.00, 3.86, & - 3.73, & - 3.59, 3.45, 3.31, 3.17, 3.02, 2.87, 2.71, 2.56, 2.39, & - 2.22, & - 2.05, 1.87, 1.68, 1.48, 1.27, 1.04, 0.80, 0.55, 0.28, & - 0.1/ -! -! awlc= (NH4)3H(SO4)2 -! - DATA AWLC/10*125.37, & - 110.10, 97.50, 86.98, 78.08, 70.49, 63.97, 58.33, 53.43, 49.14, & - 45.36, & - 42.03, 39.07, 36.44, 34.08, 31.97, 30.06, 28.33, 26.76, 25.32, & - 24.01, & - 22.81, 21.70, 20.67, 19.71, 18.83, 18.00, 17.23, 16.50, 15.82, & - 15.18, & - 14.58, 14.01, 13.46, 12.95, 12.46, 11.99, 11.55, 11.13, 10.72, & - 10.33, & - 9.96, 9.60, 9.26, 8.93, 8.61, 8.30, 8.00, 7.72, 7.44, & - 7.17, & - 6.91, 6.66, 6.42, 6.19, 5.96, 5.74, 5.52, 5.31, 5.11, & - 4.91, & - 4.71, 4.53, 4.34, 4.16, 3.99, 3.81, 3.64, 3.48, 3.31, & - 3.15, & - 2.99, 2.84, 2.68, 2.53, 2.37, 2.22, 2.06, 1.91, 1.75, & - 1.60, & - 1.44, 1.28, 1.12, 0.95, 0.79, 0.62, 0.45, 0.29, 0.14, & - 0.1/ -! -! awan= ammonium nitrate -! - DATA AWAN/10*960.19, & - 853.15,763.85,688.20,623.27,566.92,517.54,473.91,435.06,400.26, & - 368.89, & - 340.48,314.63,291.01,269.36,249.46,231.11,214.17,198.50,184.00, & - 170.58, & - 158.15,146.66,136.04,126.25,117.24,108.97,101.39, 94.45, 88.11, & - 82.33, & - 77.06, 72.25, 67.85, 63.84, 60.16, 56.78, 53.68, 50.81, 48.17, & - 45.71, & - 43.43, 41.31, 39.32, 37.46, 35.71, 34.06, 32.50, 31.03, 29.63, & - 28.30, & - 27.03, 25.82, 24.67, 23.56, 22.49, 21.47, 20.48, 19.53, 18.61, & - 17.72, & - 16.86, 16.02, 15.20, 14.41, 13.64, 12.89, 12.15, 11.43, 10.73, & - 10.05, & - 9.38, 8.73, 8.09, 7.47, 6.86, 6.27, 5.70, 5.15, 4.61, & - 4.09, & - 3.60, 3.12, 2.66, 2.23, 1.81, 1.41, 1.03, 0.67, 0.32, & - 0.1/ -! -! awsb= sodium bisulfate -! - DATA AWSB/10*55.99, & - 53.79, 51.81, 49.99, 48.31, 46.75, 45.28, 43.91, 42.62, 41.39, & - 40.22, & - 39.10, 38.02, 36.99, 36.00, 35.04, 34.11, 33.21, 32.34, 31.49, & - 30.65, & - 29.84, 29.04, 28.27, 27.50, 26.75, 26.01, 25.29, 24.57, 23.87, & - 23.17, & - 22.49, 21.81, 21.15, 20.49, 19.84, 19.21, 18.58, 17.97, 17.37, & - 16.77, & - 16.19, 15.63, 15.08, 14.54, 14.01, 13.51, 13.01, 12.53, 12.07, & - 11.62, & - 11.19, 10.77, 10.36, 9.97, 9.59, 9.23, 8.87, 8.53, 8.20, & - 7.88, & - 7.57, 7.27, 6.97, 6.69, 6.41, 6.14, 5.88, 5.62, 5.36, & - 5.11, & - 4.87, 4.63, 4.39, 4.15, 3.92, 3.68, 3.45, 3.21, 2.98, & - 2.74, & - 2.49, 2.24, 1.98, 1.72, 1.44, 1.16, 0.87, 0.57, 0.28, & - 0.1/ -! -! *** ZSR RELATIONSHIP PARAMETERS ************************************** - -! awas= ammonium sulfate -! -! DATA AWAS/33*100.,30,30,30,29.54,28.25,27.06,25.94, -! & 24.89,23.90,22.97,22.10,21.27,20.48,19.73,19.02,18.34,17.69, -! & 17.07,16.48,15.91,15.37,14.85,14.34,13.86,13.39,12.94,12.50, -! & 12.08,11.67,11.27,10.88,10.51,10.14, 9.79, 9.44, 9.10, 8.78, -! & 8.45, 8.14, 7.83, 7.53, 7.23, 6.94, 6.65, 6.36, 6.08, 5.81, -! & 5.53, 5.26, 4.99, 4.72, 4.46, 4.19, 3.92, 3.65, 3.38, 3.11, -! & 2.83, 2.54, 2.25, 1.95, 1.63, 1.31, 0.97, 0.63, 0.30, 0.001/ -! -! awsn= sodium nitrate -! -! DATA AWSN/ 9*1.e5,685.59, -! & 451.00,336.46,268.48,223.41,191.28, -! & 167.20,148.46,133.44,121.12,110.83, -! & 102.09,94.57,88.03,82.29,77.20,72.65,68.56,64.87,61.51,58.44, -! & 55.62,53.03,50.63,48.40,46.32,44.39,42.57,40.87,39.27,37.76, -! & 36.33,34.98,33.70,32.48,31.32,30.21,29.16,28.14,27.18,26.25, -! & 25.35,24.50,23.67,22.87,22.11,21.36,20.65,19.95,19.28,18.62, -! & 17.99,17.37,16.77,16.18,15.61,15.05,14.51,13.98,13.45,12.94, -! & 12.44,11.94,11.46,10.98,10.51,10.04, 9.58, 9.12, 8.67, 8.22, -! & 7.77, 7.32, 6.88, 6.43, 5.98, 5.53, 5.07, 4.61, 4.15, 3.69, -! & 3.22, 2.76, 2.31, 1.87, 1.47, 1.10, 0.77, 0.48, 0.23, 0.001/ -! -! awsc= sodium chloride -! -! DATA AWS!/ -! & 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., -! & 100., 100., 100., 100., 100., 100., 100., 100., 100.,16.34, -! & 16.28,16.22,16.15,16.09,16.02,15.95,15.88,15.80,15.72,15.64, -! & 15.55,15.45,15.36,15.25,15.14,15.02,14.89,14.75,14.60,14.43, -! & 14.25,14.04,13.81,13.55,13.25,12.92,12.56,12.19,11.82,11.47, -! & 11.13,10.82,10.53,10.26,10.00, 9.76, 9.53, 9.30, 9.09, 8.88, -! & 8.67, 8.48, 8.28, 8.09, 7.90, 7.72, 7.54, 7.36, 7.17, 6.99, -! & 6.81, 6.63, 6.45, 6.27, 6.09, 5.91, 5.72, 5.53, 5.34, 5.14, -! & 4.94, 4.74, 4.53, 4.31, 4.09, 3.86, 3.62, 3.37, 3.12, 2.85, -! & 2.58, 2.30, 2.01, 1.72, 1.44, 1.16, 0.89, 0.64, 0.40, 0.18/ -! -! awac= ammonium chloride -! -! DATA AWA!/ -! & 100., 100., 100., 100., 100., 100., 100., 100., 100., 100., -! & 100., 100., 100., 100., 100., 100., 100., 100., 100.,31.45, -! & 31.30,31.14,30.98,30.82,30.65,30.48,30.30,30.11,29.92,29.71, -! & 29.50,29.29,29.06,28.82,28.57,28.30,28.03,27.78,27.78,27.77, -! & 27.77,27.43,27.07,26.67,26.21,25.73,25.18,24.56,23.84,23.01, -! & 22.05,20.97,19.85,18.77,17.78,16.89,16.10,15.39,14.74,14.14, -! & 13.59,13.06,12.56,12.09,11.65,11.22,10.81,10.42,10.03, 9.66, -! & 9.30, 8.94, 8.59, 8.25, 7.92, 7.59, 7.27, 6.95, 6.63, 6.32, -! & 6.01, 5.70, 5.39, 5.08, 4.78, 4.47, 4.17, 3.86, 3.56, 3.25, -! & 2.94, 2.62, 2.30, 1.98, 1.65, 1.32, 0.97, 0.62, 0.26, 0.13/ -! -! awss= sodium sulfate -! -! DATA AWSS/34*1.e5,23*14.30,14.21,12.53,11.47, -! & 10.66,10.01, 9.46, 8.99, 8.57, 8.19, 7.85, 7.54, 7.25, 6.98, -! & 6.74, 6.50, 6.29, 6.08, 5.88, 5.70, 5.52, 5.36, 5.20, 5.04, -! & 4.90, 4.75, 4.54, 4.34, 4.14, 3.93, 3.71, 3.49, 3.26, 3.02, -! & 2.76, 2.49, 2.20, 1.89, 1.55, 1.18, 0.82, 0.49, 0.22, 0.001/ -! -! awab= ammonium bisulfate -! -! DATA AWAB/356.45,296.51,253.21,220.47,194.85, -! & 174.24,157.31,143.16,131.15,120.82, -! & 111.86,103.99,97.04,90.86,85.31,80.31,75.78,71.66,67.90,64.44, -! & 61.25,58.31,55.58,53.04,50.68,48.47,46.40,44.46,42.63,40.91, -! & 39.29,37.75,36.30,34.92,33.61,32.36,31.18,30.04,28.96,27.93, -! & 26.94,25.99,25.08,24.21,23.37,22.57,21.79,21.05,20.32,19.63, -! & 18.96,18.31,17.68,17.07,16.49,15.92,15.36,14.83,14.31,13.80, -! & 13.31,12.83,12.36,11.91,11.46,11.03,10.61,10.20, 9.80, 9.41, -! & 9.02, 8.64, 8.28, 7.91, 7.56, 7.21, 6.87, 6.54, 6.21, 5.88, -! & 5.56, 5.25, 4.94, 4.63, 4.33, 4.03, 3.73, 3.44, 3.14, 2.85, -! & 2.57, 2.28, 1.99, 1.71, 1.42, 1.14, 0.86, 0.57, 0.29, 0.001/ -! -! awsa= sulfuric acid -! -! DATA AWSA/ -! & 34.0,33.56,29.22,26.55,24.61,23.11,21.89,20.87,19.99, -! & 19.21,18.51,17.87,17.29,16.76,16.26,15.8,15.37,14.95,14.56, -! & 14.20,13.85,13.53,13.22,12.93,12.66,12.40,12.14,11.90,11.67, -! & 11.44,11.22,11.01,10.8,10.60,10.4,10.2,10.01,9.83,9.65,9.47, -! & 9.3,9.13,8.96,8.81,8.64,8.48,8.33,8.17,8.02,7.87,7.72,7.58, -! & 7.44,7.30,7.16,7.02,6.88,6.75,6.61,6.48,6.35,6.21,6.08,5.95, -! & 5.82,5.69,5.56,5.44,5.31,5.18,5.05,4.92,4.79,4.66,4.53,4.40, -! & 4.27,4.14,4.,3.87,3.73,3.6,3.46,3.31,3.17,3.02,2.87,2.72, -! & 2.56,2.4,2.23,2.05,1.87,1.68,1.48,1.27,1.05,0.807,0.552,0.281/ -! -! awlc= (NH4)3H(SO4)2 -! -! DATA AWL!/34*1.e5,17.0,16.5,15.94,15.31,14.71,14.14, -! & 13.60,13.08,12.59,12.12,11.68,11.25,10.84,10.44,10.07, 9.71, -! & 9.36, 9.02, 8.70, 8.39, 8.09, 7.80, 7.52, 7.25, 6.99, 6.73, -! & 6.49, 6.25, 6.02, 5.79, 5.57, 5.36, 5.15, 4.95, 4.76, 4.56, -! & 4.38, 4.20, 4.02, 3.84, 3.67, 3.51, 3.34, 3.18, 3.02, 2.87, -! & 2.72, 2.57, 2.42, 2.28, 2.13, 1.99, 1.85, 1.71, 1.57, 1.43, -! & 1.30, 1.16, 1.02, 0.89, 0.75, 0.61, 0.46, 0.32, 0.16, 0.001/ -! -! awan= ammonium nitrate -! -! DATA AWAN/31*1.e5, -! & 97.17,92.28,87.66,83.15,78.87,74.84,70.98,67.46,64.11, -! & 60.98,58.07,55.37,52.85,50.43,48.24,46.19,44.26,42.40,40.70, -! & 39.10,37.54,36.10,34.69,33.35,32.11,30.89,29.71,28.58,27.46, -! & 26.42,25.37,24.33,23.89,22.42,21.48,20.56,19.65,18.76,17.91, -! & 17.05,16.23,15.40,14.61,13.82,13.03,12.30,11.55,10.83,10.14, -! & 9.44, 8.79, 8.13, 7.51, 6.91, 6.32, 5.75, 5.18, 4.65, 4.14, -! & 3.65, 3.16, 2.71, 2.26, 1.83, 1.42, 1.03, 0.66, 0.30, 0.001/ -! -! awsb= sodium bisulfate -! -! DATA AWSB/173.72,156.88,142.80,130.85,120.57, -! & 111.64,103.80,96.88,90.71,85.18, -! & 80.20,75.69,71.58,67.82,64.37,61.19,58.26,55.53,53.00,50.64, -! & 48.44,46.37,44.44,42.61,40.90,39.27,37.74,36.29,34.91,33.61, -! & 32.36,31.18,30.05,28.97,27.94,26.95,26.00,25.10,24.23,23.39, -! & 22.59,21.81,21.07,20.35,19.65,18.98,18.34,17.71,17.11,16.52, -! & 15.95,15.40,14.87,14.35,13.85,13.36,12.88,12.42,11.97,11.53, -! & 11.10,10.69,10.28, 9.88, 9.49, 9.12, 8.75, 8.38, 8.03, 7.68, -! & 7.34, 7.01, 6.69, 6.37, 6.06, 5.75, 5.45, 5.15, 4.86, 4.58, -! & 4.30, 4.02, 3.76, 3.49, 3.23, 2.98, 2.73, 2.48, 2.24, 2.01, -! & 1.78, 1.56, 1.34, 1.13, 0.92, 0.73, 0.53, 0.35, 0.17, 0.001/ -! -! *** END OF BLOCK DATA SUBPROGRAM ************************************* -! -! END - - REAL(KIND=8) CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8,& - PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & - A1, A2, A3, A4, A5, A6, A7, A8 - - REAL(KIND=8) LAMDA, KAPPA - -!======================================================================= -! -! *** ISORROPIA CODE -! *** BLOCK DATA AERSR -! *** CONTAINS DATA FOR AEROSOL SULFATE RATIO ARRAY NEEDED IN FUNCTION -! GETASR -! -! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, -! *** GEORGIA INSTITUTE OF TECHNOLOGY -! *** WRITTEN BY ATHANASIOS NENES -! *** UPDATED BY CHRISTOS FOUNTOUKIS -! -!======================================================================= -! - -! BLOCK DATA AERSR - INTEGER,PARAMETER::NSO4S=14, NRHS=20, NASRD=NSO4S*NRHS - REAL(KIND=8) ASRAT(NASRD), ASSO4(NSO4S) - INTEGER IA - - DATA ASSO4/1.0E-9, 2.5E-9, 5.0E-9, 7.5E-9, 1.0E-8, & - 2.5E-8, 5.0E-8, 7.5E-8, 1.0E-7, 2.5E-7, & - 5.0E-7, 7.5E-7, 1.0E-6, 5.0E-6/ - - DATA (ASRAT(IA), IA=1,100)/ & - 1.020464, 0.9998130, 0.9960167, 0.9984423, 1.004004, & - 1.010885, 1.018356, 1.026726, 1.034268, 1.043846, & - 1.052933, 1.062230, 1.062213, 1.080050, 1.088350, & - 1.096603, 1.104289, 1.111745, 1.094662, 1.121594, & - 1.268909, 1.242444, 1.233815, 1.232088, 1.234020, & - 1.238068, 1.243455, 1.250636, 1.258734, 1.267543, & - 1.276948, 1.286642, 1.293337, 1.305592, 1.314726, & - 1.323463, 1.333258, 1.343604, 1.344793, 1.355571, & - 1.431463, 1.405204, 1.395791, 1.393190, 1.394403, & - 1.398107, 1.403811, 1.411744, 1.420560, 1.429990, & - 1.439742, 1.449507, 1.458986, 1.468403, 1.477394, & - 1.487373, 1.495385, 1.503854, 1.512281, 1.520394, & - 1.514464, 1.489699, 1.480686, 1.478187, 1.479446, & - 1.483310, 1.489316, 1.497517, 1.506501, 1.515816, & - 1.524724, 1.533950, 1.542758, 1.551730, 1.559587, & - 1.568343, 1.575610, 1.583140, 1.590440, 1.596481, & - 1.567743, 1.544426, 1.535928, 1.533645, 1.535016, & - 1.539003, 1.545124, 1.553283, 1.561886, 1.570530, & - 1.579234, 1.587813, 1.595956, 1.603901, 1.611349, & - 1.618833, 1.625819, 1.632543, 1.639032, 1.645276/ - - DATA (ASRAT(IA), IA=101,200)/ & - 1.707390, 1.689553, 1.683198, 1.681810, 1.683490, & - 1.687477, 1.693148, 1.700084, 1.706917, 1.713507, & - 1.719952, 1.726190, 1.731985, 1.737544, 1.742673, & - 1.747756, 1.752431, 1.756890, 1.761141, 1.765190, & - 1.785657, 1.771851, 1.767063, 1.766229, 1.767901, & - 1.771455, 1.776223, 1.781769, 1.787065, 1.792081, & - 1.796922, 1.801561, 1.805832, 1.809896, 1.813622, & - 1.817292, 1.820651, 1.823841, 1.826871, 1.829745, & - 1.822215, 1.810497, 1.806496, 1.805898, 1.807480, & - 1.810684, 1.814860, 1.819613, 1.824093, 1.828306, & - 1.832352, 1.836209, 1.839748, 1.843105, 1.846175, & - 1.849192, 1.851948, 1.854574, 1.857038, 1.859387, & - 1.844588, 1.834208, 1.830701, 1.830233, 1.831727, & - 1.834665, 1.838429, 1.842658, 1.846615, 1.850321, & - 1.853869, 1.857243, 1.860332, 1.863257, 1.865928, & - 1.868550, 1.870942, 1.873208, 1.875355, 1.877389, & - 1.899556, 1.892637, 1.890367, 1.890165, 1.891317, & - 1.893436, 1.896036, 1.898872, 1.901485, 1.903908, & - 1.906212, 1.908391, 1.910375, 1.912248, 1.913952, & - 1.915621, 1.917140, 1.918576, 1.919934, 1.921220/ - - DATA (ASRAT(IA), IA=201,280)/ & - 1.928264, 1.923245, 1.921625, 1.921523, 1.922421, & - 1.924016, 1.925931, 1.927991, 1.929875, 1.931614, & - 1.933262, 1.934816, 1.936229, 1.937560, 1.938769, & - 1.939951, 1.941026, 1.942042, 1.943003, 1.943911, & - 1.941205, 1.937060, 1.935734, 1.935666, 1.936430, & - 1.937769, 1.939359, 1.941061, 1.942612, 1.944041, & - 1.945393, 1.946666, 1.947823, 1.948911, 1.949900, & - 1.950866, 1.951744, 1.952574, 1.953358, 1.954099, & - 1.948985, 1.945372, 1.944221, 1.944171, 1.944850, & - 1.946027, 1.947419, 1.948902, 1.950251, 1.951494, & - 1.952668, 1.953773, 1.954776, 1.955719, 1.956576, & - 1.957413, 1.958174, 1.958892, 1.959571, 1.960213, & - 1.977193, 1.975540, 1.975023, 1.975015, 1.975346, & - 1.975903, 1.976547, 1.977225, 1.977838, 1.978401, & - 1.978930, 1.979428, 1.979879, 1.980302, 1.980686, & - 1.981060, 1.981401, 1.981722, 1.982025, 1.982312/ -! -! *** END OF BLOCK DATA AERSR ****************************************** -! -! END - - REAL(KIND=8) & - BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741),& - BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741),& - BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741),& - BNC13M( 741) - - - -! *** TEMP = 198.0 - -! BLOCK DATA KMCF198 -! -! *** Common block definition -! -! COMMON /KMC198/ & -! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741),& -! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741),& -! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741),& - ! BNC13M( 741) -! -! *** NaCl -! - DATA (BNC01M (IA),IA= 1,100)/ & - -0.54728E-01,-0.96305E-01,-0.12309E+00,-0.13978E+00,-0.15161E+00,& - -0.16050E+00,-0.16740E+00,-0.17287E+00,-0.17725E+00,-0.18077E+00,& - -0.18360E+00,-0.18587E+00,-0.18765E+00,-0.18904E+00,-0.19007E+00,& - -0.19081E+00,-0.19129E+00,-0.19153E+00,-0.19157E+00,-0.19143E+00,& - -0.19114E+00,-0.19069E+00,-0.19012E+00,-0.18943E+00,-0.18863E+00,& - -0.18775E+00,-0.18677E+00,-0.18572E+00,-0.18460E+00,-0.18341E+00,& - -0.18217E+00,-0.18087E+00,-0.17953E+00,-0.17814E+00,-0.17672E+00,& - -0.17526E+00,-0.17377E+00,-0.17225E+00,-0.17071E+00,-0.16914E+00,& - -0.16756E+00,-0.16596E+00,-0.16434E+00,-0.16271E+00,-0.16106E+00,& - -0.15941E+00,-0.15775E+00,-0.15607E+00,-0.15440E+00,-0.15271E+00,& - -0.15102E+00,-0.14933E+00,-0.14763E+00,-0.14592E+00,-0.14422E+00,& - -0.14251E+00,-0.14080E+00,-0.13908E+00,-0.13736E+00,-0.13564E+00,& - -0.13392E+00,-0.13219E+00,-0.13046E+00,-0.12872E+00,-0.12698E+00,& - -0.12523E+00,-0.12347E+00,-0.12171E+00,-0.11995E+00,-0.11817E+00,& - -0.11638E+00,-0.11459E+00,-0.11279E+00,-0.11097E+00,-0.10915E+00,& - -0.10731E+00,-0.10546E+00,-0.10360E+00,-0.10172E+00,-0.99830E-01,& - -0.97925E-01,-0.96004E-01,-0.94068E-01,-0.92116E-01,-0.90147E-01,& - -0.88163E-01,-0.86161E-01,-0.84143E-01,-0.82108E-01,-0.80055E-01,& - -0.77986E-01,-0.75900E-01,-0.73797E-01,-0.71678E-01,-0.69542E-01,& - -0.67390E-01,-0.65222E-01,-0.63039E-01,-0.60840E-01,-0.58627E-01/ - - DATA (BNC01M (IA),IA=101,200)/ & - -0.56400E-01,-0.54159E-01,-0.51905E-01,-0.49639E-01,-0.47360E-01,& - -0.45070E-01,-0.42769E-01,-0.40457E-01,-0.38136E-01,-0.35805E-01,& - -0.33466E-01,-0.31119E-01,-0.28765E-01,-0.26404E-01,-0.24036E-01,& - -0.21663E-01,-0.19285E-01,-0.16902E-01,-0.14514E-01,-0.12123E-01,& - -0.10058E-01,-0.76233E-02,-0.51896E-02,-0.27575E-02,-0.32700E-03,& - 0.21018E-02, 0.45288E-02, 0.69540E-02, 0.93773E-02, 0.11799E-01,& - 0.14218E-01, 0.16635E-01, 0.19050E-01, 0.21463E-01, 0.23873E-01,& - 0.26281E-01, 0.28687E-01, 0.31090E-01, 0.33491E-01, 0.35889E-01,& - 0.38285E-01, 0.40678E-01, 0.43068E-01, 0.45456E-01, 0.47840E-01,& - 0.50222E-01, 0.52601E-01, 0.54977E-01, 0.57350E-01, 0.59721E-01,& - 0.62088E-01, 0.64452E-01, 0.66813E-01, 0.69171E-01, 0.71526E-01,& - 0.73877E-01, 0.76225E-01, 0.78571E-01, 0.80912E-01, 0.83251E-01,& - 0.85586E-01, 0.87918E-01, 0.90247E-01, 0.92572E-01, 0.94893E-01,& - 0.97212E-01, 0.99526E-01, 0.10184E+00, 0.10415E+00, 0.10645E+00,& - 0.10875E+00, 0.11105E+00, 0.11334E+00, 0.11563E+00, 0.11792E+00,& - 0.12020E+00, 0.12248E+00, 0.12475E+00, 0.12703E+00, 0.12929E+00,& - 0.13156E+00, 0.13382E+00, 0.13608E+00, 0.13833E+00, 0.14058E+00,& - 0.14282E+00, 0.14507E+00, 0.14730E+00, 0.14954E+00, 0.15177E+00,& - 0.15399E+00, 0.15622E+00, 0.15844E+00, 0.16065E+00, 0.16286E+00,& - 0.16507E+00, 0.16727E+00, 0.16947E+00, 0.17167E+00, 0.17386E+00/ - - DATA (BNC01M (IA),IA=201,300)/ & - 0.17605E+00, 0.17823E+00, 0.18041E+00, 0.18259E+00, 0.18476E+00,& - 0.18693E+00, 0.18909E+00, 0.19126E+00, 0.19341E+00, 0.19557E+00,& - 0.19771E+00, 0.19986E+00, 0.20200E+00, 0.20414E+00, 0.20627E+00,& - 0.20840E+00, 0.21053E+00, 0.21265E+00, 0.21476E+00, 0.21688E+00,& - 0.21899E+00, 0.22109E+00, 0.22320E+00, 0.22529E+00, 0.22739E+00,& - 0.22948E+00, 0.23156E+00, 0.23364E+00, 0.23572E+00, 0.23780E+00,& - 0.23987E+00, 0.24193E+00, 0.24400E+00, 0.24606E+00, 0.24811E+00,& - 0.25016E+00, 0.25221E+00, 0.25425E+00, 0.25629E+00, 0.25832E+00,& - 0.26036E+00, 0.26238E+00, 0.26441E+00, 0.26643E+00, 0.26844E+00,& - 0.27045E+00, 0.27246E+00, 0.27447E+00, 0.27647E+00, 0.27846E+00,& - 0.28045E+00, 0.28244E+00, 0.28443E+00, 0.28641E+00, 0.28839E+00,& - 0.29036E+00, 0.29233E+00, 0.29429E+00, 0.29626E+00, 0.29821E+00,& - 0.30017E+00, 0.30212E+00, 0.30406E+00, 0.30601E+00, 0.30794E+00,& - 0.30988E+00, 0.31181E+00, 0.31374E+00, 0.31566E+00, 0.31758E+00,& - 0.31950E+00, 0.32141E+00, 0.32332E+00, 0.32522E+00, 0.32712E+00,& - 0.32902E+00, 0.33092E+00, 0.33281E+00, 0.33469E+00, 0.33657E+00,& - 0.33845E+00, 0.34033E+00, 0.34220E+00, 0.34407E+00, 0.34593E+00,& - 0.34779E+00, 0.34965E+00, 0.35150E+00, 0.35335E+00, 0.35519E+00,& - 0.35704E+00, 0.35887E+00, 0.36071E+00, 0.36254E+00, 0.36437E+00,& - 0.36619E+00, 0.36801E+00, 0.36983E+00, 0.37164E+00, 0.37345E+00/ - - DATA (BNC01M (IA),IA=301,400)/ & - 0.37526E+00, 0.37706E+00, 0.37886E+00, 0.38065E+00, 0.38244E+00,& - 0.38423E+00, 0.38602E+00, 0.38780E+00, 0.38957E+00, 0.39135E+00,& - 0.39312E+00, 0.39489E+00, 0.39665E+00, 0.39841E+00, 0.40017E+00,& - 0.40192E+00, 0.40367E+00, 0.40541E+00, 0.40716E+00, 0.40890E+00,& - 0.41063E+00, 0.41236E+00, 0.41409E+00, 0.41582E+00, 0.41754E+00,& - 0.41926E+00, 0.42097E+00, 0.42268E+00, 0.42439E+00, 0.42610E+00,& - 0.42780E+00, 0.42950E+00, 0.43119E+00, 0.43288E+00, 0.43457E+00,& - 0.43626E+00, 0.43794E+00, 0.43962E+00, 0.44129E+00, 0.44296E+00,& - 0.44463E+00, 0.44630E+00, 0.44796E+00, 0.44962E+00, 0.45127E+00,& - 0.45292E+00, 0.45457E+00, 0.45622E+00, 0.45786E+00, 0.45950E+00,& - 0.46113E+00, 0.46277E+00, 0.46439E+00, 0.46602E+00, 0.46764E+00,& - 0.46926E+00, 0.47088E+00, 0.47249E+00, 0.47410E+00, 0.47571E+00,& - 0.47731E+00, 0.47891E+00, 0.48051E+00, 0.48211E+00, 0.48370E+00,& - 0.48528E+00, 0.48687E+00, 0.48845E+00, 0.49003E+00, 0.49161E+00,& - 0.49318E+00, 0.49475E+00, 0.49631E+00, 0.49788E+00, 0.49944E+00,& - 0.50099E+00, 0.50255E+00, 0.50410E+00, 0.50565E+00, 0.50719E+00,& - 0.50873E+00, 0.51027E+00, 0.51181E+00, 0.51334E+00, 0.51487E+00,& - 0.51640E+00, 0.51792E+00, 0.51944E+00, 0.52096E+00, 0.52248E+00,& - 0.52399E+00, 0.52550E+00, 0.52700E+00, 0.52851E+00, 0.53001E+00,& - 0.53150E+00, 0.53300E+00, 0.53449E+00, 0.53598E+00, 0.53747E+00/ - - DATA (BNC01M (IA),IA=401,500)/ & - 0.53895E+00, 0.54043E+00, 0.54191E+00, 0.54338E+00, 0.54485E+00,& - 0.54632E+00, 0.54779E+00, 0.54925E+00, 0.55071E+00, 0.55217E+00,& - 0.55362E+00, 0.55507E+00, 0.55652E+00, 0.55797E+00, 0.55941E+00,& - 0.56085E+00, 0.56229E+00, 0.56372E+00, 0.56515E+00, 0.56658E+00,& - 0.56801E+00, 0.56943E+00, 0.57086E+00, 0.57227E+00, 0.57369E+00,& - 0.57510E+00, 0.57651E+00, 0.57792E+00, 0.57932E+00, 0.58073E+00,& - 0.58213E+00, 0.58352E+00, 0.58492E+00, 0.58631E+00, 0.58770E+00,& - 0.58908E+00, 0.59047E+00, 0.59185E+00, 0.59323E+00, 0.59460E+00,& - 0.59597E+00, 0.59734E+00, 0.59871E+00, 0.60008E+00, 0.60144E+00,& - 0.60280E+00, 0.60415E+00, 0.60551E+00, 0.60686E+00, 0.60821E+00,& - 0.60956E+00, 0.61090E+00, 0.61224E+00, 0.61358E+00, 0.61492E+00,& - 0.61625E+00, 0.61758E+00, 0.61891E+00, 0.62024E+00, 0.62156E+00,& - 0.62288E+00, 0.62420E+00, 0.62552E+00, 0.62683E+00, 0.62815E+00,& - 0.62945E+00, 0.63076E+00, 0.63206E+00, 0.63337E+00, 0.63467E+00,& - 0.63596E+00, 0.63726E+00, 0.63855E+00, 0.63984E+00, 0.64112E+00,& - 0.64241E+00, 0.64369E+00, 0.64497E+00, 0.64625E+00, 0.64752E+00,& - 0.64879E+00, 0.65006E+00, 0.65133E+00, 0.65260E+00, 0.65386E+00,& - 0.65512E+00, 0.65638E+00, 0.65763E+00, 0.65889E+00, 0.66014E+00,& - 0.66139E+00, 0.66263E+00, 0.66388E+00, 0.66512E+00, 0.66636E+00,& - 0.66759E+00, 0.66883E+00, 0.67006E+00, 0.67129E+00, 0.67252E+00/ - - DATA (BNC01M (IA),IA=501,600)/ & - 0.67374E+00, 0.67497E+00, 0.67619E+00, 0.67741E+00, 0.67862E+00,& - 0.67984E+00, 0.68105E+00, 0.68226E+00, 0.68347E+00, 0.68467E+00,& - 0.68587E+00, 0.68707E+00, 0.68827E+00, 0.68947E+00, 0.69066E+00,& - 0.69185E+00, 0.69304E+00, 0.69423E+00, 0.69542E+00, 0.69660E+00,& - 0.69778E+00, 0.69896E+00, 0.70013E+00, 0.70131E+00, 0.70248E+00,& - 0.70365E+00, 0.70482E+00, 0.70598E+00, 0.70715E+00, 0.70831E+00,& - 0.70947E+00, 0.71062E+00, 0.71178E+00, 0.71293E+00, 0.71408E+00,& - 0.71523E+00, 0.71638E+00, 0.71752E+00, 0.71866E+00, 0.71980E+00,& - 0.72094E+00, 0.72208E+00, 0.72321E+00, 0.72434E+00, 0.72547E+00,& - 0.72660E+00, 0.72772E+00, 0.72885E+00, 0.72997E+00, 0.73109E+00,& - 0.73220E+00, 0.73332E+00, 0.73443E+00, 0.73554E+00, 0.73665E+00,& - 0.73776E+00, 0.73886E+00, 0.73997E+00, 0.74107E+00, 0.74217E+00,& - 0.74326E+00, 0.74436E+00, 0.74545E+00, 0.74654E+00, 0.74763E+00,& - 0.74872E+00, 0.74980E+00, 0.75089E+00, 0.75197E+00, 0.75305E+00,& - 0.75412E+00, 0.75520E+00, 0.75627E+00, 0.75734E+00, 0.75841E+00,& - 0.75948E+00, 0.76055E+00, 0.76161E+00, 0.76267E+00, 0.76373E+00,& - 0.76479E+00, 0.76584E+00, 0.76690E+00, 0.76795E+00, 0.76900E+00,& - 0.77005E+00, 0.77109E+00, 0.77214E+00, 0.77318E+00, 0.77422E+00,& - 0.77526E+00, 0.77630E+00, 0.77733E+00, 0.77836E+00, 0.77940E+00,& - 0.78043E+00, 0.78145E+00, 0.78248E+00, 0.78350E+00, 0.78733E+00/ - - DATA (BNC01M (IA),IA=601,700)/ & - 0.79565E+00, 0.80557E+00, 0.81531E+00, 0.82489E+00, 0.83429E+00,& - 0.84353E+00, 0.85261E+00, 0.86153E+00, 0.87029E+00, 0.87890E+00,& - 0.88737E+00, 0.89568E+00, 0.90385E+00, 0.91188E+00, 0.91978E+00,& - 0.92754E+00, 0.93516E+00, 0.94265E+00, 0.95002E+00, 0.95726E+00,& - 0.96438E+00, 0.97138E+00, 0.97825E+00, 0.98501E+00, 0.99166E+00,& - 0.99819E+00, 0.10046E+01, 0.10109E+01, 0.10171E+01, 0.10232E+01,& - 0.10292E+01, 0.10351E+01, 0.10409E+01, 0.10466E+01, 0.10522E+01,& - 0.10577E+01, 0.10632E+01, 0.10685E+01, 0.10737E+01, 0.10788E+01,& - 0.10839E+01, 0.10889E+01, 0.10938E+01, 0.10986E+01, 0.11033E+01,& - 0.11079E+01, 0.11125E+01, 0.11169E+01, 0.11213E+01, 0.11257E+01,& - 0.11299E+01, 0.11341E+01, 0.11382E+01, 0.11422E+01, 0.11462E+01,& - 0.11501E+01, 0.11539E+01, 0.11577E+01, 0.11613E+01, 0.11650E+01,& - 0.11685E+01, 0.11720E+01, 0.11754E+01, 0.11788E+01, 0.11821E+01,& - 0.11853E+01, 0.11885E+01, 0.11916E+01, 0.11947E+01, 0.11977E+01,& - 0.12007E+01, 0.12036E+01, 0.12064E+01, 0.12092E+01, 0.12119E+01,& - 0.12146E+01, 0.12172E+01, 0.12198E+01, 0.12223E+01, 0.12248E+01,& - 0.12272E+01, 0.12296E+01, 0.12319E+01, 0.12342E+01, 0.12364E+01,& - 0.12386E+01, 0.12407E+01, 0.12428E+01, 0.12449E+01, 0.12469E+01,& - 0.12488E+01, 0.12507E+01, 0.12526E+01, 0.12544E+01, 0.12562E+01,& - 0.12579E+01, 0.12596E+01, 0.12613E+01, 0.12629E+01, 0.12645E+01/ - - DATA (BNC01M(IA),IA=701,741)/ & - 0.12660E+01, 0.12675E+01, 0.12690E+01, 0.12704E+01, 0.12718E+01,& - 0.12731E+01, 0.12744E+01, 0.12757E+01, 0.12769E+01, 0.12781E+01,& - 0.12793E+01, 0.12804E+01, 0.12815E+01, 0.12825E+01, 0.12836E+01,& - 0.12846E+01, 0.12855E+01, 0.12864E+01, 0.12873E+01, 0.12882E+01,& - 0.12890E+01, 0.12898E+01, 0.12906E+01, 0.12913E+01, 0.12920E+01,& - 0.12927E+01, 0.12933E+01, 0.12939E+01, 0.12945E+01, 0.12951E+01,& - 0.12956E+01, 0.12961E+01, 0.12966E+01, 0.12970E+01, 0.12974E+01,& - 0.12978E+01, 0.12981E+01, 0.12985E+01, 0.12988E+01, 0.12991E+01,& - 0.12993E+01 / -! -! ** Na2SO4 -! - DATA (BNC02M (IA),IA= 1,100)/ & - -0.11393E+00,-0.20901E+00,-0.27708E+00,-0.32413E+00,-0.36089E+00,& - -0.39137E+00,-0.41757E+00,-0.44064E+00,-0.46132E+00,-0.48011E+00,& - -0.49735E+00,-0.51331E+00,-0.52819E+00,-0.54215E+00,-0.55531E+00,& - -0.56776E+00,-0.57959E+00,-0.59087E+00,-0.60165E+00,-0.61199E+00,& - -0.62193E+00,-0.63150E+00,-0.64073E+00,-0.64965E+00,-0.65829E+00,& - -0.66666E+00,-0.67479E+00,-0.68269E+00,-0.69038E+00,-0.69786E+00,& - -0.70517E+00,-0.71229E+00,-0.71925E+00,-0.72606E+00,-0.73272E+00,& - -0.73923E+00,-0.74562E+00,-0.75188E+00,-0.75802E+00,-0.76405E+00,& - -0.76996E+00,-0.77578E+00,-0.78149E+00,-0.78711E+00,-0.79264E+00,& - -0.79808E+00,-0.80343E+00,-0.80871E+00,-0.81391E+00,-0.81903E+00,& - -0.82409E+00,-0.82907E+00,-0.83399E+00,-0.83885E+00,-0.84364E+00,& - -0.84837E+00,-0.85305E+00,-0.85767E+00,-0.86224E+00,-0.86676E+00,& - -0.87123E+00,-0.87565E+00,-0.88002E+00,-0.88435E+00,-0.88863E+00,& - -0.89288E+00,-0.89708E+00,-0.90124E+00,-0.90537E+00,-0.90946E+00,& - -0.91351E+00,-0.91753E+00,-0.92152E+00,-0.92547E+00,-0.92939E+00,& - -0.93329E+00,-0.93715E+00,-0.94099E+00,-0.94480E+00,-0.94858E+00,& - -0.95234E+00,-0.95607E+00,-0.95978E+00,-0.96346E+00,-0.96712E+00,& - -0.97076E+00,-0.97438E+00,-0.97797E+00,-0.98155E+00,-0.98511E+00,& - -0.98864E+00,-0.99216E+00,-0.99566E+00,-0.99914E+00,-0.10026E+01,& - -0.10061E+01,-0.10095E+01,-0.10129E+01,-0.10163E+01,-0.10197E+01/ - - DATA (BNC02M (IA),IA=101,200)/ & - -0.10230E+01,-0.10264E+01,-0.10297E+01,-0.10330E+01,-0.10363E+01,& - -0.10396E+01,-0.10429E+01,-0.10462E+01,-0.10494E+01,-0.10526E+01,& - -0.10559E+01,-0.10591E+01,-0.10623E+01,-0.10654E+01,-0.10686E+01,& - -0.10718E+01,-0.10749E+01,-0.10780E+01,-0.10812E+01,-0.10843E+01,& - -0.10873E+01,-0.10904E+01,-0.10935E+01,-0.10965E+01,-0.10996E+01,& - -0.11026E+01,-0.11056E+01,-0.11087E+01,-0.11117E+01,-0.11147E+01,& - -0.11176E+01,-0.11206E+01,-0.11236E+01,-0.11265E+01,-0.11295E+01,& - -0.11324E+01,-0.11353E+01,-0.11382E+01,-0.11411E+01,-0.11440E+01,& - -0.11469E+01,-0.11497E+01,-0.11526E+01,-0.11555E+01,-0.11583E+01,& - -0.11611E+01,-0.11640E+01,-0.11668E+01,-0.11696E+01,-0.11724E+01,& - -0.11752E+01,-0.11779E+01,-0.11807E+01,-0.11835E+01,-0.11862E+01,& - -0.11890E+01,-0.11917E+01,-0.11945E+01,-0.11972E+01,-0.11999E+01,& - -0.12026E+01,-0.12053E+01,-0.12080E+01,-0.12107E+01,-0.12134E+01,& - -0.12160E+01,-0.12187E+01,-0.12214E+01,-0.12240E+01,-0.12267E+01,& - -0.12293E+01,-0.12319E+01,-0.12346E+01,-0.12372E+01,-0.12398E+01,& - -0.12424E+01,-0.12450E+01,-0.12476E+01,-0.12502E+01,-0.12528E+01,& - -0.12553E+01,-0.12579E+01,-0.12605E+01,-0.12630E+01,-0.12656E+01,& - -0.12681E+01,-0.12707E+01,-0.12732E+01,-0.12757E+01,-0.12782E+01,& - -0.12807E+01,-0.12833E+01,-0.12858E+01,-0.12883E+01,-0.12908E+01,& - -0.12932E+01,-0.12957E+01,-0.12982E+01,-0.13007E+01,-0.13032E+01/ - - DATA (BNC02M (IA),IA=201,300)/ & - -0.13056E+01,-0.13081E+01,-0.13105E+01,-0.13130E+01,-0.13154E+01,& - -0.13179E+01,-0.13203E+01,-0.13227E+01,-0.13251E+01,-0.13276E+01,& - -0.13300E+01,-0.13324E+01,-0.13348E+01,-0.13372E+01,-0.13396E+01,& - -0.13420E+01,-0.13444E+01,-0.13468E+01,-0.13491E+01,-0.13515E+01,& - -0.13539E+01,-0.13562E+01,-0.13586E+01,-0.13610E+01,-0.13633E+01,& - -0.13657E+01,-0.13680E+01,-0.13704E+01,-0.13727E+01,-0.13750E+01,& - -0.13774E+01,-0.13797E+01,-0.13820E+01,-0.13843E+01,-0.13866E+01,& - -0.13890E+01,-0.13913E+01,-0.13936E+01,-0.13959E+01,-0.13982E+01,& - -0.14004E+01,-0.14027E+01,-0.14050E+01,-0.14073E+01,-0.14096E+01,& - -0.14119E+01,-0.14141E+01,-0.14164E+01,-0.14187E+01,-0.14209E+01,& - -0.14232E+01,-0.14254E+01,-0.14277E+01,-0.14299E+01,-0.14322E+01,& - -0.14344E+01,-0.14366E+01,-0.14389E+01,-0.14411E+01,-0.14433E+01,& - -0.14456E+01,-0.14478E+01,-0.14500E+01,-0.14522E+01,-0.14544E+01,& - -0.14566E+01,-0.14588E+01,-0.14610E+01,-0.14632E+01,-0.14654E+01,& - -0.14676E+01,-0.14698E+01,-0.14720E+01,-0.14742E+01,-0.14764E+01,& - -0.14785E+01,-0.14807E+01,-0.14829E+01,-0.14851E+01,-0.14872E+01,& - -0.14894E+01,-0.14916E+01,-0.14937E+01,-0.14959E+01,-0.14980E+01,& - -0.15002E+01,-0.15023E+01,-0.15045E+01,-0.15066E+01,-0.15087E+01,& - -0.15109E+01,-0.15130E+01,-0.15152E+01,-0.15173E+01,-0.15194E+01,& - -0.15215E+01,-0.15237E+01,-0.15258E+01,-0.15279E+01,-0.15300E+01/ - - DATA (BNC02M (IA),IA=301,400)/ & - -0.15321E+01,-0.15342E+01,-0.15363E+01,-0.15384E+01,-0.15405E+01,& - -0.15426E+01,-0.15447E+01,-0.15468E+01,-0.15489E+01,-0.15510E+01,& - -0.15531E+01,-0.15552E+01,-0.15573E+01,-0.15594E+01,-0.15614E+01,& - -0.15635E+01,-0.15656E+01,-0.15677E+01,-0.15697E+01,-0.15718E+01,& - -0.15739E+01,-0.15759E+01,-0.15780E+01,-0.15800E+01,-0.15821E+01,& - -0.15842E+01,-0.15862E+01,-0.15883E+01,-0.15903E+01,-0.15923E+01,& - -0.15944E+01,-0.15964E+01,-0.15985E+01,-0.16005E+01,-0.16025E+01,& - -0.16046E+01,-0.16066E+01,-0.16086E+01,-0.16107E+01,-0.16127E+01,& - -0.16147E+01,-0.16167E+01,-0.16188E+01,-0.16208E+01,-0.16228E+01,& - -0.16248E+01,-0.16268E+01,-0.16288E+01,-0.16308E+01,-0.16328E+01,& - -0.16348E+01,-0.16368E+01,-0.16388E+01,-0.16408E+01,-0.16428E+01,& - -0.16448E+01,-0.16468E+01,-0.16488E+01,-0.16508E+01,-0.16528E+01,& - -0.16548E+01,-0.16568E+01,-0.16587E+01,-0.16607E+01,-0.16627E+01,& - -0.16647E+01,-0.16667E+01,-0.16686E+01,-0.16706E+01,-0.16726E+01,& - -0.16745E+01,-0.16765E+01,-0.16785E+01,-0.16804E+01,-0.16824E+01,& - -0.16844E+01,-0.16863E+01,-0.16883E+01,-0.16902E+01,-0.16922E+01,& - -0.16941E+01,-0.16961E+01,-0.16980E+01,-0.17000E+01,-0.17019E+01,& - -0.17039E+01,-0.17058E+01,-0.17077E+01,-0.17097E+01,-0.17116E+01,& - -0.17136E+01,-0.17155E+01,-0.17174E+01,-0.17194E+01,-0.17213E+01,& - -0.17232E+01,-0.17251E+01,-0.17271E+01,-0.17290E+01,-0.17309E+01/ - - DATA (BNC02M (IA),IA=401,500)/ & - -0.17328E+01,-0.17347E+01,-0.17367E+01,-0.17386E+01,-0.17405E+01,& - -0.17424E+01,-0.17443E+01,-0.17462E+01,-0.17481E+01,-0.17500E+01,& - -0.17519E+01,-0.17538E+01,-0.17557E+01,-0.17576E+01,-0.17595E+01,& - -0.17614E+01,-0.17633E+01,-0.17652E+01,-0.17671E+01,-0.17690E+01,& - -0.17709E+01,-0.17728E+01,-0.17747E+01,-0.17766E+01,-0.17785E+01,& - -0.17804E+01,-0.17822E+01,-0.17841E+01,-0.17860E+01,-0.17879E+01,& - -0.17898E+01,-0.17916E+01,-0.17935E+01,-0.17954E+01,-0.17973E+01,& - -0.17991E+01,-0.18010E+01,-0.18029E+01,-0.18047E+01,-0.18066E+01,& - -0.18085E+01,-0.18103E+01,-0.18122E+01,-0.18140E+01,-0.18159E+01,& - -0.18178E+01,-0.18196E+01,-0.18215E+01,-0.18233E+01,-0.18252E+01,& - -0.18270E+01,-0.18289E+01,-0.18307E+01,-0.18326E+01,-0.18344E+01,& - -0.18363E+01,-0.18381E+01,-0.18400E+01,-0.18418E+01,-0.18437E+01,& - -0.18455E+01,-0.18473E+01,-0.18492E+01,-0.18510E+01,-0.18528E+01,& - -0.18547E+01,-0.18565E+01,-0.18583E+01,-0.18602E+01,-0.18620E+01,& - -0.18638E+01,-0.18657E+01,-0.18675E+01,-0.18693E+01,-0.18711E+01,& - -0.18730E+01,-0.18748E+01,-0.18766E+01,-0.18784E+01,-0.18802E+01,& - -0.18821E+01,-0.18839E+01,-0.18857E+01,-0.18875E+01,-0.18893E+01,& - -0.18911E+01,-0.18929E+01,-0.18948E+01,-0.18966E+01,-0.18984E+01,& - -0.19002E+01,-0.19020E+01,-0.19038E+01,-0.19056E+01,-0.19074E+01,& - -0.19092E+01,-0.19110E+01,-0.19128E+01,-0.19146E+01,-0.19164E+01/ - - DATA (BNC02M (IA),IA=501,600)/ & - -0.19182E+01,-0.19200E+01,-0.19218E+01,-0.19236E+01,-0.19254E+01,& - -0.19272E+01,-0.19289E+01,-0.19307E+01,-0.19325E+01,-0.19343E+01,& - -0.19361E+01,-0.19379E+01,-0.19397E+01,-0.19415E+01,-0.19432E+01,& - -0.19450E+01,-0.19468E+01,-0.19486E+01,-0.19504E+01,-0.19521E+01,& - -0.19539E+01,-0.19557E+01,-0.19575E+01,-0.19592E+01,-0.19610E+01,& - -0.19628E+01,-0.19646E+01,-0.19663E+01,-0.19681E+01,-0.19699E+01,& - -0.19716E+01,-0.19734E+01,-0.19752E+01,-0.19769E+01,-0.19787E+01,& - -0.19804E+01,-0.19822E+01,-0.19840E+01,-0.19857E+01,-0.19875E+01,& - -0.19892E+01,-0.19910E+01,-0.19928E+01,-0.19945E+01,-0.19963E+01,& - -0.19980E+01,-0.19998E+01,-0.20015E+01,-0.20033E+01,-0.20050E+01,& - -0.20068E+01,-0.20085E+01,-0.20103E+01,-0.20120E+01,-0.20138E+01,& - -0.20155E+01,-0.20173E+01,-0.20190E+01,-0.20207E+01,-0.20225E+01,& - -0.20242E+01,-0.20260E+01,-0.20277E+01,-0.20294E+01,-0.20312E+01,& - -0.20329E+01,-0.20347E+01,-0.20364E+01,-0.20381E+01,-0.20399E+01,& - -0.20416E+01,-0.20433E+01,-0.20451E+01,-0.20468E+01,-0.20485E+01,& - -0.20502E+01,-0.20520E+01,-0.20537E+01,-0.20554E+01,-0.20572E+01,& - -0.20589E+01,-0.20606E+01,-0.20623E+01,-0.20640E+01,-0.20658E+01,& - -0.20675E+01,-0.20692E+01,-0.20709E+01,-0.20726E+01,-0.20744E+01,& - -0.20761E+01,-0.20778E+01,-0.20795E+01,-0.20812E+01,-0.20829E+01,& - -0.20847E+01,-0.20864E+01,-0.20881E+01,-0.20898E+01,-0.20962E+01/ - - DATA (BNC02M (IA),IA=601,700)/ & - -0.21103E+01,-0.21272E+01,-0.21441E+01,-0.21610E+01,-0.21778E+01,& - -0.21945E+01,-0.22111E+01,-0.22277E+01,-0.22442E+01,-0.22607E+01,& - -0.22771E+01,-0.22934E+01,-0.23097E+01,-0.23260E+01,-0.23422E+01,& - -0.23583E+01,-0.23744E+01,-0.23904E+01,-0.24064E+01,-0.24224E+01,& - -0.24383E+01,-0.24541E+01,-0.24699E+01,-0.24857E+01,-0.25014E+01,& - -0.25171E+01,-0.25327E+01,-0.25483E+01,-0.25639E+01,-0.25794E+01,& - -0.25949E+01,-0.26104E+01,-0.26258E+01,-0.26412E+01,-0.26565E+01,& - -0.26718E+01,-0.26871E+01,-0.27023E+01,-0.27175E+01,-0.27327E+01,& - -0.27479E+01,-0.27630E+01,-0.27781E+01,-0.27931E+01,-0.28082E+01,& - -0.28232E+01,-0.28381E+01,-0.28531E+01,-0.28680E+01,-0.28829E+01,& - -0.28977E+01,-0.29125E+01,-0.29274E+01,-0.29421E+01,-0.29569E+01,& - -0.29716E+01,-0.29863E+01,-0.30010E+01,-0.30157E+01,-0.30303E+01,& - -0.30449E+01,-0.30595E+01,-0.30740E+01,-0.30886E+01,-0.31031E+01,& - -0.31176E+01,-0.31321E+01,-0.31465E+01,-0.31610E+01,-0.31754E+01,& - -0.31898E+01,-0.32042E+01,-0.32185E+01,-0.32328E+01,-0.32472E+01,& - -0.32614E+01,-0.32757E+01,-0.32900E+01,-0.33042E+01,-0.33184E+01,& - -0.33326E+01,-0.33468E+01,-0.33610E+01,-0.33751E+01,-0.33893E+01,& - -0.34034E+01,-0.34175E+01,-0.34316E+01,-0.34456E+01,-0.34597E+01,& - -0.34737E+01,-0.34877E+01,-0.35017E+01,-0.35157E+01,-0.35297E+01,& - -0.35436E+01,-0.35576E+01,-0.35715E+01,-0.35854E+01,-0.35993E+01/ - - DATA (BNC02M(IA),IA=701,741)/ & - -0.36132E+01,-0.36270E+01,-0.36409E+01,-0.36547E+01,-0.36685E+01,& - -0.36823E+01,-0.36961E+01,-0.37099E+01,-0.37237E+01,-0.37374E+01,& - -0.37512E+01,-0.37649E+01,-0.37786E+01,-0.37923E+01,-0.38060E+01,& - -0.38197E+01,-0.38333E+01,-0.38470E+01,-0.38606E+01,-0.38743E+01,& - -0.38879E+01,-0.39015E+01,-0.39151E+01,-0.39286E+01,-0.39422E+01,& - -0.39558E+01,-0.39693E+01,-0.39828E+01,-0.39964E+01,-0.40099E+01,& - -0.40234E+01,-0.40369E+01,-0.40503E+01,-0.40638E+01,-0.40773E+01,& - -0.40907E+01,-0.41041E+01,-0.41176E+01,-0.41310E+01,-0.41444E+01,& - -0.41578E+01 / -! -! ** NaNO3 -! - DATA (BNC03M (IA),IA= 1,100)/ & - -0.57178E-01,-0.10530E+00,-0.14005E+00,-0.16425E+00,-0.18329E+00,& - -0.19916E+00,-0.21288E+00,-0.22502E+00,-0.23595E+00,-0.24593E+00,& - -0.25513E+00,-0.26368E+00,-0.27167E+00,-0.27920E+00,-0.28633E+00,& - -0.29309E+00,-0.29954E+00,-0.30570E+00,-0.31162E+00,-0.31730E+00,& - -0.32278E+00,-0.32807E+00,-0.33318E+00,-0.33813E+00,-0.34294E+00,& - -0.34761E+00,-0.35215E+00,-0.35657E+00,-0.36088E+00,-0.36509E+00,& - -0.36920E+00,-0.37322E+00,-0.37715E+00,-0.38099E+00,-0.38476E+00,& - -0.38845E+00,-0.39207E+00,-0.39563E+00,-0.39912E+00,-0.40255E+00,& - -0.40592E+00,-0.40923E+00,-0.41249E+00,-0.41570E+00,-0.41885E+00,& - -0.42196E+00,-0.42503E+00,-0.42805E+00,-0.43102E+00,-0.43396E+00,& - -0.43685E+00,-0.43971E+00,-0.44253E+00,-0.44532E+00,-0.44807E+00,& - -0.45079E+00,-0.45347E+00,-0.45613E+00,-0.45875E+00,-0.46135E+00,& - -0.46392E+00,-0.46647E+00,-0.46898E+00,-0.47148E+00,-0.47394E+00,& - -0.47639E+00,-0.47881E+00,-0.48121E+00,-0.48360E+00,-0.48596E+00,& - -0.48830E+00,-0.49062E+00,-0.49293E+00,-0.49522E+00,-0.49749E+00,& - -0.49975E+00,-0.50199E+00,-0.50421E+00,-0.50642E+00,-0.50862E+00,& - -0.51081E+00,-0.51298E+00,-0.51514E+00,-0.51729E+00,-0.51942E+00,& - -0.52154E+00,-0.52366E+00,-0.52576E+00,-0.52785E+00,-0.52994E+00,& - -0.53201E+00,-0.53407E+00,-0.53613E+00,-0.53817E+00,-0.54021E+00,& - -0.54224E+00,-0.54426E+00,-0.54627E+00,-0.54827E+00,-0.55026E+00/ - - DATA (BNC03M (IA),IA=101,200)/ & - -0.55225E+00,-0.55423E+00,-0.55620E+00,-0.55817E+00,-0.56012E+00,& - -0.56207E+00,-0.56401E+00,-0.56595E+00,-0.56787E+00,-0.56979E+00,& - -0.57171E+00,-0.57361E+00,-0.57551E+00,-0.57740E+00,-0.57929E+00,& - -0.58116E+00,-0.58304E+00,-0.58490E+00,-0.58676E+00,-0.58861E+00,& - -0.59039E+00,-0.59224E+00,-0.59407E+00,-0.59590E+00,-0.59772E+00,& - -0.59954E+00,-0.60135E+00,-0.60315E+00,-0.60494E+00,-0.60673E+00,& - -0.60851E+00,-0.61029E+00,-0.61206E+00,-0.61382E+00,-0.61558E+00,& - -0.61733E+00,-0.61907E+00,-0.62081E+00,-0.62254E+00,-0.62427E+00,& - -0.62599E+00,-0.62770E+00,-0.62941E+00,-0.63111E+00,-0.63281E+00,& - -0.63450E+00,-0.63619E+00,-0.63787E+00,-0.63955E+00,-0.64122E+00,& - -0.64289E+00,-0.64455E+00,-0.64620E+00,-0.64785E+00,-0.64950E+00,& - -0.65114E+00,-0.65278E+00,-0.65441E+00,-0.65603E+00,-0.65766E+00,& - -0.65927E+00,-0.66089E+00,-0.66250E+00,-0.66410E+00,-0.66570E+00,& - -0.66729E+00,-0.66888E+00,-0.67047E+00,-0.67205E+00,-0.67363E+00,& - -0.67520E+00,-0.67677E+00,-0.67834E+00,-0.67990E+00,-0.68146E+00,& - -0.68301E+00,-0.68456E+00,-0.68610E+00,-0.68765E+00,-0.68918E+00,& - -0.69072E+00,-0.69225E+00,-0.69377E+00,-0.69530E+00,-0.69682E+00,& - -0.69833E+00,-0.69984E+00,-0.70135E+00,-0.70285E+00,-0.70436E+00,& - -0.70585E+00,-0.70735E+00,-0.70884E+00,-0.71032E+00,-0.71181E+00,& - -0.71329E+00,-0.71477E+00,-0.71624E+00,-0.71771E+00,-0.71918E+00/ - - DATA (BNC03M (IA),IA=201,300)/ & - -0.72064E+00,-0.72210E+00,-0.72356E+00,-0.72501E+00,-0.72647E+00,& - -0.72791E+00,-0.72936E+00,-0.73080E+00,-0.73224E+00,-0.73368E+00,& - -0.73511E+00,-0.73654E+00,-0.73797E+00,-0.73939E+00,-0.74082E+00,& - -0.74223E+00,-0.74365E+00,-0.74506E+00,-0.74647E+00,-0.74788E+00,& - -0.74929E+00,-0.75069E+00,-0.75209E+00,-0.75348E+00,-0.75488E+00,& - -0.75627E+00,-0.75766E+00,-0.75905E+00,-0.76043E+00,-0.76181E+00,& - -0.76319E+00,-0.76456E+00,-0.76594E+00,-0.76731E+00,-0.76868E+00,& - -0.77004E+00,-0.77141E+00,-0.77277E+00,-0.77413E+00,-0.77548E+00,& - -0.77684E+00,-0.77819E+00,-0.77954E+00,-0.78088E+00,-0.78223E+00,& - -0.78357E+00,-0.78491E+00,-0.78625E+00,-0.78758E+00,-0.78892E+00,& - -0.79025E+00,-0.79158E+00,-0.79290E+00,-0.79423E+00,-0.79555E+00,& - -0.79687E+00,-0.79819E+00,-0.79950E+00,-0.80081E+00,-0.80213E+00,& - -0.80344E+00,-0.80474E+00,-0.80605E+00,-0.80735E+00,-0.80865E+00,& - -0.80995E+00,-0.81125E+00,-0.81254E+00,-0.81384E+00,-0.81513E+00,& - -0.81642E+00,-0.81770E+00,-0.81899E+00,-0.82027E+00,-0.82155E+00,& - -0.82283E+00,-0.82411E+00,-0.82539E+00,-0.82666E+00,-0.82793E+00,& - -0.82920E+00,-0.83047E+00,-0.83173E+00,-0.83300E+00,-0.83426E+00,& - -0.83552E+00,-0.83678E+00,-0.83804E+00,-0.83929E+00,-0.84055E+00,& - -0.84180E+00,-0.84305E+00,-0.84430E+00,-0.84555E+00,-0.84679E+00,& - -0.84803E+00,-0.84928E+00,-0.85052E+00,-0.85175E+00,-0.85299E+00/ - - DATA (BNC03M (IA),IA=301,400)/ & - -0.85423E+00,-0.85546E+00,-0.85669E+00,-0.85792E+00,-0.85915E+00,& - -0.86038E+00,-0.86160E+00,-0.86282E+00,-0.86405E+00,-0.86527E+00,& - -0.86648E+00,-0.86770E+00,-0.86892E+00,-0.87013E+00,-0.87134E+00,& - -0.87256E+00,-0.87377E+00,-0.87497E+00,-0.87618E+00,-0.87738E+00,& - -0.87859E+00,-0.87979E+00,-0.88099E+00,-0.88219E+00,-0.88339E+00,& - -0.88458E+00,-0.88578E+00,-0.88697E+00,-0.88816E+00,-0.88935E+00,& - -0.89054E+00,-0.89173E+00,-0.89292E+00,-0.89410E+00,-0.89528E+00,& - -0.89647E+00,-0.89765E+00,-0.89883E+00,-0.90000E+00,-0.90118E+00,& - -0.90236E+00,-0.90353E+00,-0.90470E+00,-0.90587E+00,-0.90704E+00,& - -0.90821E+00,-0.90938E+00,-0.91054E+00,-0.91171E+00,-0.91287E+00,& - -0.91403E+00,-0.91519E+00,-0.91635E+00,-0.91751E+00,-0.91867E+00,& - -0.91982E+00,-0.92098E+00,-0.92213E+00,-0.92328E+00,-0.92443E+00,& - -0.92558E+00,-0.92673E+00,-0.92788E+00,-0.92902E+00,-0.93017E+00,& - -0.93131E+00,-0.93245E+00,-0.93359E+00,-0.93473E+00,-0.93587E+00,& - -0.93701E+00,-0.93815E+00,-0.93928E+00,-0.94041E+00,-0.94155E+00,& - -0.94268E+00,-0.94381E+00,-0.94494E+00,-0.94607E+00,-0.94719E+00,& - -0.94832E+00,-0.94944E+00,-0.95057E+00,-0.95169E+00,-0.95281E+00,& - -0.95393E+00,-0.95505E+00,-0.95617E+00,-0.95729E+00,-0.95840E+00,& - -0.95952E+00,-0.96063E+00,-0.96174E+00,-0.96285E+00,-0.96396E+00,& - -0.96507E+00,-0.96618E+00,-0.96729E+00,-0.96840E+00,-0.96950E+00/ - - DATA (BNC03M (IA),IA=401,500)/ & - -0.97061E+00,-0.97171E+00,-0.97281E+00,-0.97391E+00,-0.97501E+00,& - -0.97611E+00,-0.97721E+00,-0.97831E+00,-0.97940E+00,-0.98050E+00,& - -0.98159E+00,-0.98268E+00,-0.98378E+00,-0.98487E+00,-0.98596E+00,& - -0.98705E+00,-0.98813E+00,-0.98922E+00,-0.99031E+00,-0.99139E+00,& - -0.99248E+00,-0.99356E+00,-0.99464E+00,-0.99572E+00,-0.99681E+00,& - -0.99788E+00,-0.99896E+00,-0.10000E+01,-0.10011E+01,-0.10022E+01,& - -0.10033E+01,-0.10043E+01,-0.10054E+01,-0.10065E+01,-0.10076E+01,& - -0.10086E+01,-0.10097E+01,-0.10108E+01,-0.10118E+01,-0.10129E+01,& - -0.10140E+01,-0.10150E+01,-0.10161E+01,-0.10172E+01,-0.10182E+01,& - -0.10193E+01,-0.10203E+01,-0.10214E+01,-0.10225E+01,-0.10235E+01,& - -0.10246E+01,-0.10256E+01,-0.10267E+01,-0.10277E+01,-0.10288E+01,& - -0.10299E+01,-0.10309E+01,-0.10320E+01,-0.10330E+01,-0.10341E+01,& - -0.10351E+01,-0.10362E+01,-0.10372E+01,-0.10382E+01,-0.10393E+01,& - -0.10403E+01,-0.10414E+01,-0.10424E+01,-0.10435E+01,-0.10445E+01,& - -0.10455E+01,-0.10466E+01,-0.10476E+01,-0.10487E+01,-0.10497E+01,& - -0.10507E+01,-0.10518E+01,-0.10528E+01,-0.10538E+01,-0.10549E+01,& - -0.10559E+01,-0.10569E+01,-0.10580E+01,-0.10590E+01,-0.10600E+01,& - -0.10611E+01,-0.10621E+01,-0.10631E+01,-0.10642E+01,-0.10652E+01,& - -0.10662E+01,-0.10672E+01,-0.10683E+01,-0.10693E+01,-0.10703E+01,& - -0.10713E+01,-0.10723E+01,-0.10734E+01,-0.10744E+01,-0.10754E+01/ - - DATA (BNC03M (IA),IA=501,600)/ & - -0.10764E+01,-0.10774E+01,-0.10785E+01,-0.10795E+01,-0.10805E+01,& - -0.10815E+01,-0.10825E+01,-0.10835E+01,-0.10845E+01,-0.10855E+01,& - -0.10866E+01,-0.10876E+01,-0.10886E+01,-0.10896E+01,-0.10906E+01,& - -0.10916E+01,-0.10926E+01,-0.10936E+01,-0.10946E+01,-0.10956E+01,& - -0.10966E+01,-0.10976E+01,-0.10986E+01,-0.10996E+01,-0.11006E+01,& - -0.11016E+01,-0.11026E+01,-0.11036E+01,-0.11046E+01,-0.11056E+01,& - -0.11066E+01,-0.11076E+01,-0.11086E+01,-0.11096E+01,-0.11106E+01,& - -0.11116E+01,-0.11126E+01,-0.11136E+01,-0.11146E+01,-0.11156E+01,& - -0.11166E+01,-0.11176E+01,-0.11186E+01,-0.11196E+01,-0.11205E+01,& - -0.11215E+01,-0.11225E+01,-0.11235E+01,-0.11245E+01,-0.11255E+01,& - -0.11265E+01,-0.11274E+01,-0.11284E+01,-0.11294E+01,-0.11304E+01,& - -0.11314E+01,-0.11324E+01,-0.11333E+01,-0.11343E+01,-0.11353E+01,& - -0.11363E+01,-0.11373E+01,-0.11382E+01,-0.11392E+01,-0.11402E+01,& - -0.11412E+01,-0.11421E+01,-0.11431E+01,-0.11441E+01,-0.11451E+01,& - -0.11460E+01,-0.11470E+01,-0.11480E+01,-0.11490E+01,-0.11499E+01,& - -0.11509E+01,-0.11519E+01,-0.11528E+01,-0.11538E+01,-0.11548E+01,& - -0.11557E+01,-0.11567E+01,-0.11577E+01,-0.11586E+01,-0.11596E+01,& - -0.11606E+01,-0.11615E+01,-0.11625E+01,-0.11635E+01,-0.11644E+01,& - -0.11654E+01,-0.11663E+01,-0.11673E+01,-0.11683E+01,-0.11692E+01,& - -0.11702E+01,-0.11711E+01,-0.11721E+01,-0.11731E+01,-0.11766E+01/ - - DATA (BNC03M (IA),IA=601,700)/ & - -0.11845E+01,-0.11940E+01,-0.12034E+01,-0.12128E+01,-0.12222E+01,& - -0.12315E+01,-0.12407E+01,-0.12499E+01,-0.12591E+01,-0.12682E+01,& - -0.12773E+01,-0.12863E+01,-0.12953E+01,-0.13043E+01,-0.13132E+01,& - -0.13221E+01,-0.13310E+01,-0.13398E+01,-0.13486E+01,-0.13573E+01,& - -0.13660E+01,-0.13747E+01,-0.13834E+01,-0.13920E+01,-0.14006E+01,& - -0.14092E+01,-0.14177E+01,-0.14262E+01,-0.14347E+01,-0.14432E+01,& - -0.14516E+01,-0.14600E+01,-0.14684E+01,-0.14768E+01,-0.14851E+01,& - -0.14934E+01,-0.15017E+01,-0.15099E+01,-0.15182E+01,-0.15264E+01,& - -0.15346E+01,-0.15427E+01,-0.15509E+01,-0.15590E+01,-0.15671E+01,& - -0.15752E+01,-0.15833E+01,-0.15913E+01,-0.15993E+01,-0.16073E+01,& - -0.16153E+01,-0.16233E+01,-0.16313E+01,-0.16392E+01,-0.16471E+01,& - -0.16550E+01,-0.16629E+01,-0.16707E+01,-0.16786E+01,-0.16864E+01,& - -0.16942E+01,-0.17020E+01,-0.17098E+01,-0.17176E+01,-0.17253E+01,& - -0.17331E+01,-0.17408E+01,-0.17485E+01,-0.17562E+01,-0.17639E+01,& - -0.17715E+01,-0.17792E+01,-0.17868E+01,-0.17944E+01,-0.18021E+01,& - -0.18096E+01,-0.18172E+01,-0.18248E+01,-0.18324E+01,-0.18399E+01,& - -0.18474E+01,-0.18550E+01,-0.18625E+01,-0.18700E+01,-0.18774E+01,& - -0.18849E+01,-0.18924E+01,-0.18998E+01,-0.19073E+01,-0.19147E+01,& - -0.19221E+01,-0.19295E+01,-0.19369E+01,-0.19443E+01,-0.19516E+01,& - -0.19590E+01,-0.19664E+01,-0.19737E+01,-0.19810E+01,-0.19883E+01/ - - DATA (BNC03M(IA),IA=701,741)/ & - -0.19957E+01,-0.20030E+01,-0.20102E+01,-0.20175E+01,-0.20248E+01,& - -0.20321E+01,-0.20393E+01,-0.20466E+01,-0.20538E+01,-0.20610E+01,& - -0.20682E+01,-0.20754E+01,-0.20826E+01,-0.20898E+01,-0.20970E+01,& - -0.21042E+01,-0.21113E+01,-0.21185E+01,-0.21256E+01,-0.21328E+01,& - -0.21399E+01,-0.21470E+01,-0.21542E+01,-0.21613E+01,-0.21684E+01,& - -0.21754E+01,-0.21825E+01,-0.21896E+01,-0.21967E+01,-0.22037E+01,& - -0.22108E+01,-0.22178E+01,-0.22249E+01,-0.22319E+01,-0.22389E+01,& - -0.22459E+01,-0.22530E+01,-0.22600E+01,-0.22670E+01,-0.22739E+01,& - -0.22809E+01 / -! -! ** (NH4)2SO4 -! - DATA (BNC04M (IA),IA= 1,100)/ & - -0.11406E+00,-0.20949E+00,-0.27798E+00,-0.32543E+00,-0.36258E+00,& - -0.39344E+00,-0.42000E+00,-0.44344E+00,-0.46447E+00,-0.48360E+00,& - -0.50119E+00,-0.51749E+00,-0.53270E+00,-0.54698E+00,-0.56046E+00,& - -0.57323E+00,-0.58538E+00,-0.59697E+00,-0.60807E+00,-0.61871E+00,& - -0.62895E+00,-0.63882E+00,-0.64835E+00,-0.65756E+00,-0.66649E+00,& - -0.67515E+00,-0.68356E+00,-0.69174E+00,-0.69971E+00,-0.70747E+00,& - -0.71505E+00,-0.72244E+00,-0.72967E+00,-0.73674E+00,-0.74366E+00,& - -0.75044E+00,-0.75708E+00,-0.76359E+00,-0.76998E+00,-0.77626E+00,& - -0.78242E+00,-0.78847E+00,-0.79443E+00,-0.80028E+00,-0.80605E+00,& - -0.81172E+00,-0.81731E+00,-0.82281E+00,-0.82823E+00,-0.83358E+00,& - -0.83886E+00,-0.84406E+00,-0.84919E+00,-0.85426E+00,-0.85927E+00,& - -0.86421E+00,-0.86910E+00,-0.87392E+00,-0.87870E+00,-0.88342E+00,& - -0.88808E+00,-0.89270E+00,-0.89727E+00,-0.90180E+00,-0.90628E+00,& - -0.91072E+00,-0.91511E+00,-0.91947E+00,-0.92378E+00,-0.92806E+00,& - -0.93230E+00,-0.93651E+00,-0.94069E+00,-0.94483E+00,-0.94894E+00,& - -0.95301E+00,-0.95706E+00,-0.96108E+00,-0.96508E+00,-0.96904E+00,& - -0.97298E+00,-0.97690E+00,-0.98079E+00,-0.98466E+00,-0.98850E+00,& - -0.99232E+00,-0.99612E+00,-0.99990E+00,-0.10037E+01,-0.10074E+01,& - -0.10111E+01,-0.10148E+01,-0.10185E+01,-0.10222E+01,-0.10258E+01,& - -0.10294E+01,-0.10331E+01,-0.10366E+01,-0.10402E+01,-0.10438E+01/ - - DATA (BNC04M (IA),IA=101,200)/ & - -0.10473E+01,-0.10509E+01,-0.10544E+01,-0.10579E+01,-0.10614E+01,& - -0.10648E+01,-0.10683E+01,-0.10718E+01,-0.10752E+01,-0.10786E+01,& - -0.10820E+01,-0.10854E+01,-0.10888E+01,-0.10921E+01,-0.10955E+01,& - -0.10988E+01,-0.11021E+01,-0.11054E+01,-0.11087E+01,-0.11120E+01,& - -0.11152E+01,-0.11185E+01,-0.11217E+01,-0.11250E+01,-0.11282E+01,& - -0.11314E+01,-0.11346E+01,-0.11378E+01,-0.11410E+01,-0.11442E+01,& - -0.11473E+01,-0.11505E+01,-0.11536E+01,-0.11567E+01,-0.11598E+01,& - -0.11629E+01,-0.11660E+01,-0.11691E+01,-0.11722E+01,-0.11752E+01,& - -0.11783E+01,-0.11813E+01,-0.11844E+01,-0.11874E+01,-0.11904E+01,& - -0.11934E+01,-0.11964E+01,-0.11994E+01,-0.12023E+01,-0.12053E+01,& - -0.12082E+01,-0.12112E+01,-0.12141E+01,-0.12171E+01,-0.12200E+01,& - -0.12229E+01,-0.12258E+01,-0.12287E+01,-0.12316E+01,-0.12344E+01,& - -0.12373E+01,-0.12402E+01,-0.12430E+01,-0.12459E+01,-0.12487E+01,& - -0.12515E+01,-0.12544E+01,-0.12572E+01,-0.12600E+01,-0.12628E+01,& - -0.12656E+01,-0.12683E+01,-0.12711E+01,-0.12739E+01,-0.12767E+01,& - -0.12794E+01,-0.12822E+01,-0.12849E+01,-0.12876E+01,-0.12904E+01,& - -0.12931E+01,-0.12958E+01,-0.12985E+01,-0.13012E+01,-0.13039E+01,& - -0.13066E+01,-0.13093E+01,-0.13120E+01,-0.13147E+01,-0.13173E+01,& - -0.13200E+01,-0.13226E+01,-0.13253E+01,-0.13279E+01,-0.13306E+01,& - -0.13332E+01,-0.13358E+01,-0.13385E+01,-0.13411E+01,-0.13437E+01/ - - DATA (BNC04M (IA),IA=201,300)/ & - -0.13463E+01,-0.13489E+01,-0.13515E+01,-0.13541E+01,-0.13567E+01,& - -0.13592E+01,-0.13618E+01,-0.13644E+01,-0.13669E+01,-0.13695E+01,& - -0.13720E+01,-0.13746E+01,-0.13771E+01,-0.13797E+01,-0.13822E+01,& - -0.13847E+01,-0.13873E+01,-0.13898E+01,-0.13923E+01,-0.13948E+01,& - -0.13973E+01,-0.13998E+01,-0.14023E+01,-0.14048E+01,-0.14073E+01,& - -0.14098E+01,-0.14122E+01,-0.14147E+01,-0.14172E+01,-0.14196E+01,& - -0.14221E+01,-0.14245E+01,-0.14270E+01,-0.14294E+01,-0.14319E+01,& - -0.14343E+01,-0.14368E+01,-0.14392E+01,-0.14416E+01,-0.14440E+01,& - -0.14465E+01,-0.14489E+01,-0.14513E+01,-0.14537E+01,-0.14561E+01,& - -0.14585E+01,-0.14609E+01,-0.14633E+01,-0.14657E+01,-0.14681E+01,& - -0.14704E+01,-0.14728E+01,-0.14752E+01,-0.14776E+01,-0.14799E+01,& - -0.14823E+01,-0.14846E+01,-0.14870E+01,-0.14893E+01,-0.14917E+01,& - -0.14940E+01,-0.14964E+01,-0.14987E+01,-0.15011E+01,-0.15034E+01,& - -0.15057E+01,-0.15080E+01,-0.15104E+01,-0.15127E+01,-0.15150E+01,& - -0.15173E+01,-0.15196E+01,-0.15219E+01,-0.15242E+01,-0.15265E+01,& - -0.15288E+01,-0.15311E+01,-0.15334E+01,-0.15357E+01,-0.15380E+01,& - -0.15402E+01,-0.15425E+01,-0.15448E+01,-0.15471E+01,-0.15493E+01,& - -0.15516E+01,-0.15538E+01,-0.15561E+01,-0.15584E+01,-0.15606E+01,& - -0.15629E+01,-0.15651E+01,-0.15674E+01,-0.15696E+01,-0.15718E+01,& - -0.15741E+01,-0.15763E+01,-0.15785E+01,-0.15808E+01,-0.15830E+01/ - - DATA (BNC04M (IA),IA=301,400)/ & - -0.15852E+01,-0.15874E+01,-0.15896E+01,-0.15919E+01,-0.15941E+01,& - -0.15963E+01,-0.15985E+01,-0.16007E+01,-0.16029E+01,-0.16051E+01,& - -0.16073E+01,-0.16095E+01,-0.16117E+01,-0.16138E+01,-0.16160E+01,& - -0.16182E+01,-0.16204E+01,-0.16226E+01,-0.16247E+01,-0.16269E+01,& - -0.16291E+01,-0.16313E+01,-0.16334E+01,-0.16356E+01,-0.16377E+01,& - -0.16399E+01,-0.16421E+01,-0.16442E+01,-0.16464E+01,-0.16485E+01,& - -0.16507E+01,-0.16528E+01,-0.16549E+01,-0.16571E+01,-0.16592E+01,& - -0.16614E+01,-0.16635E+01,-0.16656E+01,-0.16678E+01,-0.16699E+01,& - -0.16720E+01,-0.16741E+01,-0.16762E+01,-0.16784E+01,-0.16805E+01,& - -0.16826E+01,-0.16847E+01,-0.16868E+01,-0.16889E+01,-0.16910E+01,& - -0.16931E+01,-0.16952E+01,-0.16973E+01,-0.16994E+01,-0.17015E+01,& - -0.17036E+01,-0.17057E+01,-0.17078E+01,-0.17099E+01,-0.17120E+01,& - -0.17140E+01,-0.17161E+01,-0.17182E+01,-0.17203E+01,-0.17223E+01,& - -0.17244E+01,-0.17265E+01,-0.17286E+01,-0.17306E+01,-0.17327E+01,& - -0.17348E+01,-0.17368E+01,-0.17389E+01,-0.17409E+01,-0.17430E+01,& - -0.17450E+01,-0.17471E+01,-0.17491E+01,-0.17512E+01,-0.17532E+01,& - -0.17553E+01,-0.17573E+01,-0.17594E+01,-0.17614E+01,-0.17634E+01,& - -0.17655E+01,-0.17675E+01,-0.17695E+01,-0.17716E+01,-0.17736E+01,& - -0.17756E+01,-0.17776E+01,-0.17797E+01,-0.17817E+01,-0.17837E+01,& - -0.17857E+01,-0.17877E+01,-0.17898E+01,-0.17918E+01,-0.17938E+01/ - - DATA (BNC04M (IA),IA=401,500)/ & - -0.17958E+01,-0.17978E+01,-0.17998E+01,-0.18018E+01,-0.18038E+01,& - -0.18058E+01,-0.18078E+01,-0.18098E+01,-0.18118E+01,-0.18138E+01,& - -0.18158E+01,-0.18178E+01,-0.18198E+01,-0.18218E+01,-0.18238E+01,& - -0.18257E+01,-0.18277E+01,-0.18297E+01,-0.18317E+01,-0.18337E+01,& - -0.18356E+01,-0.18376E+01,-0.18396E+01,-0.18416E+01,-0.18435E+01,& - -0.18455E+01,-0.18475E+01,-0.18494E+01,-0.18514E+01,-0.18534E+01,& - -0.18553E+01,-0.18573E+01,-0.18593E+01,-0.18612E+01,-0.18632E+01,& - -0.18651E+01,-0.18671E+01,-0.18690E+01,-0.18710E+01,-0.18729E+01,& - -0.18749E+01,-0.18768E+01,-0.18788E+01,-0.18807E+01,-0.18827E+01,& - -0.18846E+01,-0.18865E+01,-0.18885E+01,-0.18904E+01,-0.18923E+01,& - -0.18943E+01,-0.18962E+01,-0.18981E+01,-0.19001E+01,-0.19020E+01,& - -0.19039E+01,-0.19058E+01,-0.19078E+01,-0.19097E+01,-0.19116E+01,& - -0.19135E+01,-0.19155E+01,-0.19174E+01,-0.19193E+01,-0.19212E+01,& - -0.19231E+01,-0.19250E+01,-0.19269E+01,-0.19289E+01,-0.19308E+01,& - -0.19327E+01,-0.19346E+01,-0.19365E+01,-0.19384E+01,-0.19403E+01,& - -0.19422E+01,-0.19441E+01,-0.19460E+01,-0.19479E+01,-0.19498E+01,& - -0.19517E+01,-0.19536E+01,-0.19555E+01,-0.19574E+01,-0.19592E+01,& - -0.19611E+01,-0.19630E+01,-0.19649E+01,-0.19668E+01,-0.19687E+01,& - -0.19706E+01,-0.19724E+01,-0.19743E+01,-0.19762E+01,-0.19781E+01,& - -0.19800E+01,-0.19818E+01,-0.19837E+01,-0.19856E+01,-0.19875E+01/ - - DATA (BNC04M (IA),IA=501,600)/ & - -0.19893E+01,-0.19912E+01,-0.19931E+01,-0.19949E+01,-0.19968E+01,& - -0.19987E+01,-0.20005E+01,-0.20024E+01,-0.20043E+01,-0.20061E+01,& - -0.20080E+01,-0.20098E+01,-0.20117E+01,-0.20136E+01,-0.20154E+01,& - -0.20173E+01,-0.20191E+01,-0.20210E+01,-0.20228E+01,-0.20247E+01,& - -0.20265E+01,-0.20284E+01,-0.20302E+01,-0.20321E+01,-0.20339E+01,& - -0.20358E+01,-0.20376E+01,-0.20394E+01,-0.20413E+01,-0.20431E+01,& - -0.20450E+01,-0.20468E+01,-0.20486E+01,-0.20505E+01,-0.20523E+01,& - -0.20541E+01,-0.20560E+01,-0.20578E+01,-0.20596E+01,-0.20615E+01,& - -0.20633E+01,-0.20651E+01,-0.20669E+01,-0.20688E+01,-0.20706E+01,& - -0.20724E+01,-0.20742E+01,-0.20761E+01,-0.20779E+01,-0.20797E+01,& - -0.20815E+01,-0.20833E+01,-0.20852E+01,-0.20870E+01,-0.20888E+01,& - -0.20906E+01,-0.20924E+01,-0.20942E+01,-0.20960E+01,-0.20979E+01,& - -0.20997E+01,-0.21015E+01,-0.21033E+01,-0.21051E+01,-0.21069E+01,& - -0.21087E+01,-0.21105E+01,-0.21123E+01,-0.21141E+01,-0.21159E+01,& - -0.21177E+01,-0.21195E+01,-0.21213E+01,-0.21231E+01,-0.21249E+01,& - -0.21267E+01,-0.21285E+01,-0.21303E+01,-0.21321E+01,-0.21339E+01,& - -0.21356E+01,-0.21374E+01,-0.21392E+01,-0.21410E+01,-0.21428E+01,& - -0.21446E+01,-0.21464E+01,-0.21482E+01,-0.21499E+01,-0.21517E+01,& - -0.21535E+01,-0.21553E+01,-0.21571E+01,-0.21588E+01,-0.21606E+01,& - -0.21624E+01,-0.21642E+01,-0.21660E+01,-0.21677E+01,-0.21744E+01/ - - DATA (BNC04M (IA),IA=601,700)/ & - -0.21890E+01,-0.22066E+01,-0.22241E+01,-0.22416E+01,-0.22589E+01,& - -0.22762E+01,-0.22935E+01,-0.23106E+01,-0.23277E+01,-0.23448E+01,& - -0.23617E+01,-0.23786E+01,-0.23955E+01,-0.24122E+01,-0.24290E+01,& - -0.24456E+01,-0.24622E+01,-0.24788E+01,-0.24953E+01,-0.25117E+01,& - -0.25281E+01,-0.25445E+01,-0.25608E+01,-0.25770E+01,-0.25932E+01,& - -0.26094E+01,-0.26255E+01,-0.26415E+01,-0.26575E+01,-0.26735E+01,& - -0.26894E+01,-0.27053E+01,-0.27212E+01,-0.27370E+01,-0.27528E+01,& - -0.27685E+01,-0.27842E+01,-0.27998E+01,-0.28155E+01,-0.28310E+01,& - -0.28466E+01,-0.28621E+01,-0.28776E+01,-0.28930E+01,-0.29084E+01,& - -0.29238E+01,-0.29392E+01,-0.29545E+01,-0.29698E+01,-0.29850E+01,& - -0.30002E+01,-0.30154E+01,-0.30306E+01,-0.30457E+01,-0.30608E+01,& - -0.30759E+01,-0.30910E+01,-0.31060E+01,-0.31210E+01,-0.31360E+01,& - -0.31509E+01,-0.31658E+01,-0.31807E+01,-0.31956E+01,-0.32104E+01,& - -0.32252E+01,-0.32400E+01,-0.32548E+01,-0.32696E+01,-0.32843E+01,& - -0.32990E+01,-0.33137E+01,-0.33283E+01,-0.33430E+01,-0.33576E+01,& - -0.33722E+01,-0.33867E+01,-0.34013E+01,-0.34158E+01,-0.34303E+01,& - -0.34448E+01,-0.34593E+01,-0.34737E+01,-0.34882E+01,-0.35026E+01,& - -0.35170E+01,-0.35313E+01,-0.35457E+01,-0.35600E+01,-0.35743E+01,& - -0.35886E+01,-0.36029E+01,-0.36172E+01,-0.36314E+01,-0.36456E+01,& - -0.36599E+01,-0.36741E+01,-0.36882E+01,-0.37024E+01,-0.37165E+01/ - - DATA (BNC04M(IA),IA=701,741)/ & - -0.37307E+01,-0.37448E+01,-0.37589E+01,-0.37730E+01,-0.37870E+01,& - -0.38011E+01,-0.38151E+01,-0.38291E+01,-0.38431E+01,-0.38571E+01,& - -0.38711E+01,-0.38850E+01,-0.38990E+01,-0.39129E+01,-0.39268E+01,& - -0.39407E+01,-0.39546E+01,-0.39685E+01,-0.39824E+01,-0.39962E+01,& - -0.40100E+01,-0.40239E+01,-0.40377E+01,-0.40515E+01,-0.40653E+01,& - -0.40790E+01,-0.40928E+01,-0.41065E+01,-0.41203E+01,-0.41340E+01,& - -0.41477E+01,-0.41614E+01,-0.41751E+01,-0.41887E+01,-0.42024E+01,& - -0.42160E+01,-0.42297E+01,-0.42433E+01,-0.42569E+01,-0.42705E+01,& - -0.42841E+01 / -! -! ** NH4NO3 -! - DATA (BNC05M (IA),IA= 1,100)/ & - -0.58030E-01,-0.10848E+00,-0.14612E+00,-0.17306E+00,-0.19474E+00,& - -0.21318E+00,-0.22940E+00,-0.24400E+00,-0.25734E+00,-0.26968E+00,& - -0.28121E+00,-0.29205E+00,-0.30231E+00,-0.31208E+00,-0.32141E+00,& - -0.33035E+00,-0.33895E+00,-0.34724E+00,-0.35526E+00,-0.36302E+00,& - -0.37055E+00,-0.37787E+00,-0.38499E+00,-0.39194E+00,-0.39871E+00,& - -0.40532E+00,-0.41178E+00,-0.41811E+00,-0.42430E+00,-0.43037E+00,& - -0.43632E+00,-0.44215E+00,-0.44788E+00,-0.45350E+00,-0.45902E+00,& - -0.46446E+00,-0.46979E+00,-0.47505E+00,-0.48021E+00,-0.48530E+00,& - -0.49031E+00,-0.49524E+00,-0.50010E+00,-0.50489E+00,-0.50962E+00,& - -0.51427E+00,-0.51886E+00,-0.52339E+00,-0.52786E+00,-0.53228E+00,& - -0.53663E+00,-0.54094E+00,-0.54519E+00,-0.54939E+00,-0.55354E+00,& - -0.55764E+00,-0.56170E+00,-0.56571E+00,-0.56968E+00,-0.57361E+00,& - -0.57750E+00,-0.58136E+00,-0.58517E+00,-0.58895E+00,-0.59270E+00,& - -0.59641E+00,-0.60010E+00,-0.60375E+00,-0.60738E+00,-0.61098E+00,& - -0.61455E+00,-0.61810E+00,-0.62162E+00,-0.62512E+00,-0.62860E+00,& - -0.63206E+00,-0.63550E+00,-0.63892E+00,-0.64233E+00,-0.64571E+00,& - -0.64908E+00,-0.65244E+00,-0.65578E+00,-0.65911E+00,-0.66242E+00,& - -0.66572E+00,-0.66901E+00,-0.67228E+00,-0.67555E+00,-0.67880E+00,& - -0.68205E+00,-0.68528E+00,-0.68850E+00,-0.69171E+00,-0.69492E+00,& - -0.69811E+00,-0.70130E+00,-0.70447E+00,-0.70764E+00,-0.71080E+00/ - - DATA (BNC05M (IA),IA=101,200)/ & - -0.71394E+00,-0.71708E+00,-0.72021E+00,-0.72334E+00,-0.72645E+00,& - -0.72955E+00,-0.73265E+00,-0.73573E+00,-0.73881E+00,-0.74187E+00,& - -0.74493E+00,-0.74798E+00,-0.75101E+00,-0.75404E+00,-0.75706E+00,& - -0.76007E+00,-0.76307E+00,-0.76606E+00,-0.76903E+00,-0.77200E+00,& - -0.77479E+00,-0.77776E+00,-0.78071E+00,-0.78366E+00,-0.78659E+00,& - -0.78951E+00,-0.79242E+00,-0.79531E+00,-0.79820E+00,-0.80107E+00,& - -0.80393E+00,-0.80678E+00,-0.80962E+00,-0.81245E+00,-0.81527E+00,& - -0.81808E+00,-0.82087E+00,-0.82366E+00,-0.82644E+00,-0.82920E+00,& - -0.83196E+00,-0.83470E+00,-0.83744E+00,-0.84016E+00,-0.84288E+00,& - -0.84558E+00,-0.84828E+00,-0.85097E+00,-0.85365E+00,-0.85631E+00,& - -0.85897E+00,-0.86162E+00,-0.86426E+00,-0.86689E+00,-0.86951E+00,& - -0.87213E+00,-0.87473E+00,-0.87733E+00,-0.87992E+00,-0.88249E+00,& - -0.88506E+00,-0.88763E+00,-0.89018E+00,-0.89272E+00,-0.89526E+00,& - -0.89779E+00,-0.90031E+00,-0.90282E+00,-0.90532E+00,-0.90782E+00,& - -0.91031E+00,-0.91279E+00,-0.91526E+00,-0.91773E+00,-0.92019E+00,& - -0.92264E+00,-0.92508E+00,-0.92751E+00,-0.92994E+00,-0.93236E+00,& - -0.93477E+00,-0.93718E+00,-0.93958E+00,-0.94197E+00,-0.94435E+00,& - -0.94673E+00,-0.94910E+00,-0.95147E+00,-0.95382E+00,-0.95617E+00,& - -0.95852E+00,-0.96085E+00,-0.96318E+00,-0.96550E+00,-0.96782E+00,& - -0.97013E+00,-0.97243E+00,-0.97473E+00,-0.97702E+00,-0.97931E+00/ - - DATA (BNC05M (IA),IA=201,300)/ & - -0.98158E+00,-0.98386E+00,-0.98612E+00,-0.98838E+00,-0.99063E+00,& - -0.99288E+00,-0.99512E+00,-0.99736E+00,-0.99959E+00,-0.10018E+01,& - -0.10040E+01,-0.10062E+01,-0.10084E+01,-0.10106E+01,-0.10128E+01,& - -0.10150E+01,-0.10172E+01,-0.10194E+01,-0.10216E+01,-0.10237E+01,& - -0.10259E+01,-0.10280E+01,-0.10302E+01,-0.10323E+01,-0.10345E+01,& - -0.10366E+01,-0.10387E+01,-0.10409E+01,-0.10430E+01,-0.10451E+01,& - -0.10472E+01,-0.10493E+01,-0.10514E+01,-0.10535E+01,-0.10556E+01,& - -0.10576E+01,-0.10597E+01,-0.10618E+01,-0.10639E+01,-0.10659E+01,& - -0.10680E+01,-0.10700E+01,-0.10721E+01,-0.10741E+01,-0.10762E+01,& - -0.10782E+01,-0.10802E+01,-0.10822E+01,-0.10843E+01,-0.10863E+01,& - -0.10883E+01,-0.10903E+01,-0.10923E+01,-0.10943E+01,-0.10963E+01,& - -0.10983E+01,-0.11002E+01,-0.11022E+01,-0.11042E+01,-0.11062E+01,& - -0.11081E+01,-0.11101E+01,-0.11120E+01,-0.11140E+01,-0.11159E+01,& - -0.11179E+01,-0.11198E+01,-0.11218E+01,-0.11237E+01,-0.11256E+01,& - -0.11275E+01,-0.11294E+01,-0.11314E+01,-0.11333E+01,-0.11352E+01,& - -0.11371E+01,-0.11390E+01,-0.11409E+01,-0.11428E+01,-0.11446E+01,& - -0.11465E+01,-0.11484E+01,-0.11503E+01,-0.11522E+01,-0.11540E+01,& - -0.11559E+01,-0.11577E+01,-0.11596E+01,-0.11614E+01,-0.11633E+01,& - -0.11651E+01,-0.11670E+01,-0.11688E+01,-0.11706E+01,-0.11725E+01,& - -0.11743E+01,-0.11761E+01,-0.11779E+01,-0.11798E+01,-0.11816E+01/ - - DATA (BNC05M (IA),IA=301,400)/ & - -0.11834E+01,-0.11852E+01,-0.11870E+01,-0.11888E+01,-0.11906E+01,& - -0.11924E+01,-0.11941E+01,-0.11959E+01,-0.11977E+01,-0.11995E+01,& - -0.12013E+01,-0.12030E+01,-0.12048E+01,-0.12066E+01,-0.12083E+01,& - -0.12101E+01,-0.12118E+01,-0.12136E+01,-0.12153E+01,-0.12171E+01,& - -0.12188E+01,-0.12205E+01,-0.12223E+01,-0.12240E+01,-0.12257E+01,& - -0.12275E+01,-0.12292E+01,-0.12309E+01,-0.12326E+01,-0.12343E+01,& - -0.12360E+01,-0.12377E+01,-0.12394E+01,-0.12411E+01,-0.12428E+01,& - -0.12445E+01,-0.12462E+01,-0.12479E+01,-0.12496E+01,-0.12513E+01,& - -0.12530E+01,-0.12546E+01,-0.12563E+01,-0.12580E+01,-0.12596E+01,& - -0.12613E+01,-0.12630E+01,-0.12646E+01,-0.12663E+01,-0.12679E+01,& - -0.12696E+01,-0.12712E+01,-0.12729E+01,-0.12745E+01,-0.12762E+01,& - -0.12778E+01,-0.12794E+01,-0.12811E+01,-0.12827E+01,-0.12843E+01,& - -0.12859E+01,-0.12876E+01,-0.12892E+01,-0.12908E+01,-0.12924E+01,& - -0.12940E+01,-0.12956E+01,-0.12972E+01,-0.12988E+01,-0.13004E+01,& - -0.13020E+01,-0.13036E+01,-0.13052E+01,-0.13068E+01,-0.13084E+01,& - -0.13100E+01,-0.13116E+01,-0.13131E+01,-0.13147E+01,-0.13163E+01,& - -0.13179E+01,-0.13194E+01,-0.13210E+01,-0.13226E+01,-0.13241E+01,& - -0.13257E+01,-0.13272E+01,-0.13288E+01,-0.13303E+01,-0.13319E+01,& - -0.13334E+01,-0.13350E+01,-0.13365E+01,-0.13381E+01,-0.13396E+01,& - -0.13411E+01,-0.13427E+01,-0.13442E+01,-0.13457E+01,-0.13473E+01/ - - DATA (BNC05M (IA),IA=401,500)/ & - -0.13488E+01,-0.13503E+01,-0.13518E+01,-0.13533E+01,-0.13549E+01,& - -0.13564E+01,-0.13579E+01,-0.13594E+01,-0.13609E+01,-0.13624E+01,& - -0.13639E+01,-0.13654E+01,-0.13669E+01,-0.13684E+01,-0.13699E+01,& - -0.13714E+01,-0.13729E+01,-0.13744E+01,-0.13758E+01,-0.13773E+01,& - -0.13788E+01,-0.13803E+01,-0.13818E+01,-0.13832E+01,-0.13847E+01,& - -0.13862E+01,-0.13877E+01,-0.13891E+01,-0.13906E+01,-0.13920E+01,& - -0.13935E+01,-0.13950E+01,-0.13964E+01,-0.13979E+01,-0.13993E+01,& - -0.14008E+01,-0.14022E+01,-0.14037E+01,-0.14051E+01,-0.14066E+01,& - -0.14080E+01,-0.14094E+01,-0.14109E+01,-0.14123E+01,-0.14137E+01,& - -0.14152E+01,-0.14166E+01,-0.14180E+01,-0.14195E+01,-0.14209E+01,& - -0.14223E+01,-0.14237E+01,-0.14251E+01,-0.14266E+01,-0.14280E+01,& - -0.14294E+01,-0.14308E+01,-0.14322E+01,-0.14336E+01,-0.14350E+01,& - -0.14364E+01,-0.14378E+01,-0.14392E+01,-0.14406E+01,-0.14420E+01,& - -0.14434E+01,-0.14448E+01,-0.14462E+01,-0.14476E+01,-0.14490E+01,& - -0.14504E+01,-0.14517E+01,-0.14531E+01,-0.14545E+01,-0.14559E+01,& - -0.14573E+01,-0.14586E+01,-0.14600E+01,-0.14614E+01,-0.14627E+01,& - -0.14641E+01,-0.14655E+01,-0.14668E+01,-0.14682E+01,-0.14696E+01,& - -0.14709E+01,-0.14723E+01,-0.14736E+01,-0.14750E+01,-0.14764E+01,& - -0.14777E+01,-0.14791E+01,-0.14804E+01,-0.14818E+01,-0.14831E+01,& - -0.14844E+01,-0.14858E+01,-0.14871E+01,-0.14885E+01,-0.14898E+01/ - - DATA (BNC05M (IA),IA=501,600)/ & - -0.14911E+01,-0.14925E+01,-0.14938E+01,-0.14951E+01,-0.14965E+01,& - -0.14978E+01,-0.14991E+01,-0.15005E+01,-0.15018E+01,-0.15031E+01,& - -0.15044E+01,-0.15057E+01,-0.15071E+01,-0.15084E+01,-0.15097E+01,& - -0.15110E+01,-0.15123E+01,-0.15136E+01,-0.15149E+01,-0.15162E+01,& - -0.15175E+01,-0.15188E+01,-0.15202E+01,-0.15215E+01,-0.15228E+01,& - -0.15241E+01,-0.15253E+01,-0.15266E+01,-0.15279E+01,-0.15292E+01,& - -0.15305E+01,-0.15318E+01,-0.15331E+01,-0.15344E+01,-0.15357E+01,& - -0.15370E+01,-0.15382E+01,-0.15395E+01,-0.15408E+01,-0.15421E+01,& - -0.15434E+01,-0.15446E+01,-0.15459E+01,-0.15472E+01,-0.15485E+01,& - -0.15497E+01,-0.15510E+01,-0.15523E+01,-0.15535E+01,-0.15548E+01,& - -0.15561E+01,-0.15573E+01,-0.15586E+01,-0.15598E+01,-0.15611E+01,& - -0.15624E+01,-0.15636E+01,-0.15649E+01,-0.15661E+01,-0.15674E+01,& - -0.15686E+01,-0.15699E+01,-0.15711E+01,-0.15724E+01,-0.15736E+01,& - -0.15749E+01,-0.15761E+01,-0.15773E+01,-0.15786E+01,-0.15798E+01,& - -0.15811E+01,-0.15823E+01,-0.15835E+01,-0.15848E+01,-0.15860E+01,& - -0.15872E+01,-0.15885E+01,-0.15897E+01,-0.15909E+01,-0.15922E+01,& - -0.15934E+01,-0.15946E+01,-0.15958E+01,-0.15971E+01,-0.15983E+01,& - -0.15995E+01,-0.16007E+01,-0.16019E+01,-0.16031E+01,-0.16044E+01,& - -0.16056E+01,-0.16068E+01,-0.16080E+01,-0.16092E+01,-0.16104E+01,& - -0.16116E+01,-0.16128E+01,-0.16140E+01,-0.16152E+01,-0.16198E+01/ - - DATA (BNC05M (IA),IA=601,700)/ & - -0.16296E+01,-0.16415E+01,-0.16532E+01,-0.16649E+01,-0.16764E+01,& - -0.16878E+01,-0.16992E+01,-0.17104E+01,-0.17216E+01,-0.17327E+01,& - -0.17437E+01,-0.17546E+01,-0.17654E+01,-0.17761E+01,-0.17868E+01,& - -0.17974E+01,-0.18079E+01,-0.18184E+01,-0.18287E+01,-0.18391E+01,& - -0.18493E+01,-0.18595E+01,-0.18696E+01,-0.18796E+01,-0.18896E+01,& - -0.18996E+01,-0.19094E+01,-0.19193E+01,-0.19290E+01,-0.19387E+01,& - -0.19484E+01,-0.19580E+01,-0.19675E+01,-0.19770E+01,-0.19865E+01,& - -0.19959E+01,-0.20053E+01,-0.20146E+01,-0.20238E+01,-0.20331E+01,& - -0.20423E+01,-0.20514E+01,-0.20605E+01,-0.20695E+01,-0.20786E+01,& - -0.20875E+01,-0.20965E+01,-0.21054E+01,-0.21143E+01,-0.21231E+01,& - -0.21319E+01,-0.21407E+01,-0.21494E+01,-0.21581E+01,-0.21667E+01,& - -0.21754E+01,-0.21840E+01,-0.21925E+01,-0.22011E+01,-0.22096E+01,& - -0.22180E+01,-0.22265E+01,-0.22349E+01,-0.22433E+01,-0.22517E+01,& - -0.22600E+01,-0.22683E+01,-0.22766E+01,-0.22848E+01,-0.22931E+01,& - -0.23013E+01,-0.23095E+01,-0.23176E+01,-0.23257E+01,-0.23338E+01,& - -0.23419E+01,-0.23500E+01,-0.23580E+01,-0.23661E+01,-0.23741E+01,& - -0.23820E+01,-0.23900E+01,-0.23979E+01,-0.24058E+01,-0.24137E+01,& - -0.24216E+01,-0.24294E+01,-0.24373E+01,-0.24451E+01,-0.24529E+01,& - -0.24607E+01,-0.24684E+01,-0.24762E+01,-0.24839E+01,-0.24916E+01,& - -0.24993E+01,-0.25070E+01,-0.25146E+01,-0.25222E+01,-0.25299E+01/ - - DATA (BNC05M(IA),IA=701,741)/ & - -0.25375E+01,-0.25451E+01,-0.25526E+01,-0.25602E+01,-0.25677E+01,& - -0.25753E+01,-0.25828E+01,-0.25903E+01,-0.25978E+01,-0.26052E+01,& - -0.26127E+01,-0.26201E+01,-0.26276E+01,-0.26350E+01,-0.26424E+01,& - -0.26498E+01,-0.26571E+01,-0.26645E+01,-0.26718E+01,-0.26792E+01,& - -0.26865E+01,-0.26938E+01,-0.27011E+01,-0.27084E+01,-0.27157E+01,& - -0.27229E+01,-0.27302E+01,-0.27374E+01,-0.27446E+01,-0.27519E+01,& - -0.27591E+01,-0.27663E+01,-0.27734E+01,-0.27806E+01,-0.27878E+01,& - -0.27949E+01,-0.28021E+01,-0.28092E+01,-0.28163E+01,-0.28234E+01,& - -0.28305E+01 / -! -! ** NH4Cl -! - DATA (BNC06M (IA),IA= 1,100)/ & - -0.55953E-01,-0.10077E+00,-0.13146E+00,-0.15183E+00,-0.16717E+00,& - -0.17947E+00,-0.18969E+00,-0.19842E+00,-0.20600E+00,-0.21268E+00,& - -0.21863E+00,-0.22398E+00,-0.22882E+00,-0.23322E+00,-0.23726E+00,& - -0.24097E+00,-0.24440E+00,-0.24758E+00,-0.25054E+00,-0.25330E+00,& - -0.25588E+00,-0.25830E+00,-0.26057E+00,-0.26271E+00,-0.26473E+00,& - -0.26663E+00,-0.26844E+00,-0.27015E+00,-0.27178E+00,-0.27333E+00,& - -0.27480E+00,-0.27621E+00,-0.27756E+00,-0.27885E+00,-0.28008E+00,& - -0.28126E+00,-0.28240E+00,-0.28349E+00,-0.28455E+00,-0.28556E+00,& - -0.28654E+00,-0.28749E+00,-0.28840E+00,-0.28929E+00,-0.29015E+00,& - -0.29098E+00,-0.29179E+00,-0.29258E+00,-0.29334E+00,-0.29409E+00,& - -0.29482E+00,-0.29552E+00,-0.29621E+00,-0.29689E+00,-0.29754E+00,& - -0.29819E+00,-0.29881E+00,-0.29943E+00,-0.30003E+00,-0.30061E+00,& - -0.30118E+00,-0.30174E+00,-0.30229E+00,-0.30283E+00,-0.30335E+00,& - -0.30386E+00,-0.30436E+00,-0.30484E+00,-0.30532E+00,-0.30578E+00,& - -0.30623E+00,-0.30667E+00,-0.30710E+00,-0.30751E+00,-0.30791E+00,& - -0.30830E+00,-0.30868E+00,-0.30905E+00,-0.30941E+00,-0.30975E+00,& - -0.31008E+00,-0.31040E+00,-0.31071E+00,-0.31100E+00,-0.31129E+00,& - -0.31156E+00,-0.31182E+00,-0.31207E+00,-0.31230E+00,-0.31253E+00,& - -0.31274E+00,-0.31295E+00,-0.31314E+00,-0.31332E+00,-0.31349E+00,& - -0.31365E+00,-0.31380E+00,-0.31394E+00,-0.31407E+00,-0.31420E+00/ - - DATA (BNC06M (IA),IA=101,200)/ & - -0.31431E+00,-0.31441E+00,-0.31451E+00,-0.31459E+00,-0.31467E+00,& - -0.31474E+00,-0.31480E+00,-0.31486E+00,-0.31491E+00,-0.31495E+00,& - -0.31499E+00,-0.31502E+00,-0.31504E+00,-0.31506E+00,-0.31508E+00,& - -0.31508E+00,-0.31509E+00,-0.31509E+00,-0.31508E+00,-0.31507E+00,& - -0.31518E+00,-0.31515E+00,-0.31512E+00,-0.31508E+00,-0.31505E+00,& - -0.31501E+00,-0.31497E+00,-0.31493E+00,-0.31488E+00,-0.31484E+00,& - -0.31479E+00,-0.31474E+00,-0.31470E+00,-0.31464E+00,-0.31459E+00,& - -0.31454E+00,-0.31449E+00,-0.31443E+00,-0.31437E+00,-0.31432E+00,& - -0.31426E+00,-0.31420E+00,-0.31414E+00,-0.31407E+00,-0.31401E+00,& - -0.31395E+00,-0.31389E+00,-0.31382E+00,-0.31375E+00,-0.31369E+00,& - -0.31362E+00,-0.31355E+00,-0.31349E+00,-0.31342E+00,-0.31335E+00,& - -0.31328E+00,-0.31321E+00,-0.31314E+00,-0.31307E+00,-0.31300E+00,& - -0.31293E+00,-0.31285E+00,-0.31278E+00,-0.31271E+00,-0.31264E+00,& - -0.31257E+00,-0.31249E+00,-0.31242E+00,-0.31235E+00,-0.31227E+00,& - -0.31220E+00,-0.31213E+00,-0.31205E+00,-0.31198E+00,-0.31190E+00,& - -0.31183E+00,-0.31176E+00,-0.31168E+00,-0.31161E+00,-0.31154E+00,& - -0.31146E+00,-0.31139E+00,-0.31132E+00,-0.31124E+00,-0.31117E+00,& - -0.31110E+00,-0.31102E+00,-0.31095E+00,-0.31088E+00,-0.31081E+00,& - -0.31073E+00,-0.31066E+00,-0.31059E+00,-0.31052E+00,-0.31045E+00,& - -0.31038E+00,-0.31031E+00,-0.31024E+00,-0.31017E+00,-0.31010E+00/ - - DATA (BNC06M (IA),IA=201,300)/ & - -0.31003E+00,-0.30996E+00,-0.30989E+00,-0.30982E+00,-0.30975E+00,& - -0.30969E+00,-0.30962E+00,-0.30955E+00,-0.30949E+00,-0.30942E+00,& - -0.30935E+00,-0.30929E+00,-0.30922E+00,-0.30916E+00,-0.30910E+00,& - -0.30903E+00,-0.30897E+00,-0.30891E+00,-0.30884E+00,-0.30878E+00,& - -0.30872E+00,-0.30866E+00,-0.30860E+00,-0.30854E+00,-0.30848E+00,& - -0.30842E+00,-0.30837E+00,-0.30831E+00,-0.30825E+00,-0.30819E+00,& - -0.30814E+00,-0.30808E+00,-0.30803E+00,-0.30797E+00,-0.30792E+00,& - -0.30787E+00,-0.30781E+00,-0.30776E+00,-0.30771E+00,-0.30766E+00,& - -0.30761E+00,-0.30756E+00,-0.30751E+00,-0.30746E+00,-0.30741E+00,& - -0.30737E+00,-0.30732E+00,-0.30727E+00,-0.30723E+00,-0.30718E+00,& - -0.30714E+00,-0.30709E+00,-0.30705E+00,-0.30701E+00,-0.30697E+00,& - -0.30692E+00,-0.30688E+00,-0.30684E+00,-0.30680E+00,-0.30676E+00,& - -0.30673E+00,-0.30669E+00,-0.30665E+00,-0.30662E+00,-0.30658E+00,& - -0.30654E+00,-0.30651E+00,-0.30648E+00,-0.30644E+00,-0.30641E+00,& - -0.30638E+00,-0.30635E+00,-0.30632E+00,-0.30629E+00,-0.30626E+00,& - -0.30623E+00,-0.30620E+00,-0.30617E+00,-0.30615E+00,-0.30612E+00,& - -0.30610E+00,-0.30607E+00,-0.30605E+00,-0.30602E+00,-0.30600E+00,& - -0.30598E+00,-0.30596E+00,-0.30594E+00,-0.30592E+00,-0.30590E+00,& - -0.30588E+00,-0.30586E+00,-0.30584E+00,-0.30583E+00,-0.30581E+00,& - -0.30580E+00,-0.30578E+00,-0.30577E+00,-0.30576E+00,-0.30574E+00/ - - DATA (BNC06M (IA),IA=301,400)/ & - -0.30573E+00,-0.30572E+00,-0.30571E+00,-0.30570E+00,-0.30569E+00,& - -0.30568E+00,-0.30567E+00,-0.30567E+00,-0.30566E+00,-0.30565E+00,& - -0.30565E+00,-0.30564E+00,-0.30564E+00,-0.30564E+00,-0.30564E+00,& - -0.30563E+00,-0.30563E+00,-0.30563E+00,-0.30563E+00,-0.30563E+00,& - -0.30563E+00,-0.30564E+00,-0.30564E+00,-0.30564E+00,-0.30565E+00,& - -0.30565E+00,-0.30566E+00,-0.30567E+00,-0.30567E+00,-0.30568E+00,& - -0.30569E+00,-0.30570E+00,-0.30571E+00,-0.30572E+00,-0.30573E+00,& - -0.30574E+00,-0.30575E+00,-0.30577E+00,-0.30578E+00,-0.30579E+00,& - -0.30581E+00,-0.30582E+00,-0.30584E+00,-0.30586E+00,-0.30588E+00,& - -0.30589E+00,-0.30591E+00,-0.30593E+00,-0.30595E+00,-0.30597E+00,& - -0.30600E+00,-0.30602E+00,-0.30604E+00,-0.30606E+00,-0.30609E+00,& - -0.30611E+00,-0.30614E+00,-0.30617E+00,-0.30619E+00,-0.30622E+00,& - -0.30625E+00,-0.30628E+00,-0.30631E+00,-0.30634E+00,-0.30637E+00,& - -0.30640E+00,-0.30643E+00,-0.30646E+00,-0.30650E+00,-0.30653E+00,& - -0.30657E+00,-0.30660E+00,-0.30664E+00,-0.30667E+00,-0.30671E+00,& - -0.30675E+00,-0.30679E+00,-0.30683E+00,-0.30687E+00,-0.30691E+00,& - -0.30695E+00,-0.30699E+00,-0.30703E+00,-0.30708E+00,-0.30712E+00,& - -0.30716E+00,-0.30721E+00,-0.30726E+00,-0.30730E+00,-0.30735E+00,& - -0.30740E+00,-0.30744E+00,-0.30749E+00,-0.30754E+00,-0.30759E+00,& - -0.30764E+00,-0.30769E+00,-0.30775E+00,-0.30780E+00,-0.30785E+00/ - - DATA (BNC06M (IA),IA=401,500)/ & - -0.30791E+00,-0.30796E+00,-0.30802E+00,-0.30807E+00,-0.30813E+00,& - -0.30818E+00,-0.30824E+00,-0.30830E+00,-0.30836E+00,-0.30842E+00,& - -0.30848E+00,-0.30854E+00,-0.30860E+00,-0.30866E+00,-0.30872E+00,& - -0.30879E+00,-0.30885E+00,-0.30891E+00,-0.30898E+00,-0.30904E+00,& - -0.30911E+00,-0.30918E+00,-0.30924E+00,-0.30931E+00,-0.30938E+00,& - -0.30945E+00,-0.30952E+00,-0.30959E+00,-0.30966E+00,-0.30973E+00,& - -0.30980E+00,-0.30987E+00,-0.30995E+00,-0.31002E+00,-0.31010E+00,& - -0.31017E+00,-0.31025E+00,-0.31032E+00,-0.31040E+00,-0.31048E+00,& - -0.31055E+00,-0.31063E+00,-0.31071E+00,-0.31079E+00,-0.31087E+00,& - -0.31095E+00,-0.31103E+00,-0.31111E+00,-0.31120E+00,-0.31128E+00,& - -0.31136E+00,-0.31145E+00,-0.31153E+00,-0.31162E+00,-0.31170E+00,& - -0.31179E+00,-0.31188E+00,-0.31196E+00,-0.31205E+00,-0.31214E+00,& - -0.31223E+00,-0.31232E+00,-0.31241E+00,-0.31250E+00,-0.31259E+00,& - -0.31268E+00,-0.31278E+00,-0.31287E+00,-0.31296E+00,-0.31306E+00,& - -0.31315E+00,-0.31325E+00,-0.31334E+00,-0.31344E+00,-0.31354E+00,& - -0.31363E+00,-0.31373E+00,-0.31383E+00,-0.31393E+00,-0.31403E+00,& - -0.31413E+00,-0.31423E+00,-0.31433E+00,-0.31443E+00,-0.31454E+00,& - -0.31464E+00,-0.31474E+00,-0.31485E+00,-0.31495E+00,-0.31506E+00,& - -0.31516E+00,-0.31527E+00,-0.31537E+00,-0.31548E+00,-0.31559E+00,& - -0.31570E+00,-0.31581E+00,-0.31591E+00,-0.31602E+00,-0.31613E+00/ - - DATA (BNC06M (IA),IA=501,600)/ & - -0.31625E+00,-0.31636E+00,-0.31647E+00,-0.31658E+00,-0.31669E+00,& - -0.31681E+00,-0.31692E+00,-0.31704E+00,-0.31715E+00,-0.31727E+00,& - -0.31738E+00,-0.31750E+00,-0.31761E+00,-0.31773E+00,-0.31785E+00,& - -0.31797E+00,-0.31809E+00,-0.31821E+00,-0.31833E+00,-0.31845E+00,& - -0.31857E+00,-0.31869E+00,-0.31881E+00,-0.31893E+00,-0.31906E+00,& - -0.31918E+00,-0.31931E+00,-0.31943E+00,-0.31955E+00,-0.31968E+00,& - -0.31981E+00,-0.31993E+00,-0.32006E+00,-0.32019E+00,-0.32032E+00,& - -0.32044E+00,-0.32057E+00,-0.32070E+00,-0.32083E+00,-0.32096E+00,& - -0.32109E+00,-0.32122E+00,-0.32136E+00,-0.32149E+00,-0.32162E+00,& - -0.32175E+00,-0.32189E+00,-0.32202E+00,-0.32216E+00,-0.32229E+00,& - -0.32243E+00,-0.32256E+00,-0.32270E+00,-0.32284E+00,-0.32298E+00,& - -0.32311E+00,-0.32325E+00,-0.32339E+00,-0.32353E+00,-0.32367E+00,& - -0.32381E+00,-0.32395E+00,-0.32409E+00,-0.32423E+00,-0.32438E+00,& - -0.32452E+00,-0.32466E+00,-0.32481E+00,-0.32495E+00,-0.32509E+00,& - -0.32524E+00,-0.32538E+00,-0.32553E+00,-0.32568E+00,-0.32582E+00,& - -0.32597E+00,-0.32612E+00,-0.32627E+00,-0.32642E+00,-0.32656E+00,& - -0.32671E+00,-0.32686E+00,-0.32701E+00,-0.32716E+00,-0.32732E+00,& - -0.32747E+00,-0.32762E+00,-0.32777E+00,-0.32793E+00,-0.32808E+00,& - -0.32823E+00,-0.32839E+00,-0.32854E+00,-0.32870E+00,-0.32885E+00,& - -0.32901E+00,-0.32917E+00,-0.32932E+00,-0.32948E+00,-0.33007E+00/ - - DATA (BNC06M (IA),IA=601,700)/ & - -0.33140E+00,-0.33305E+00,-0.33474E+00,-0.33647E+00,-0.33824E+00,& - -0.34005E+00,-0.34190E+00,-0.34379E+00,-0.34571E+00,-0.34767E+00,& - -0.34966E+00,-0.35169E+00,-0.35376E+00,-0.35586E+00,-0.35799E+00,& - -0.36016E+00,-0.36235E+00,-0.36458E+00,-0.36684E+00,-0.36913E+00,& - -0.37146E+00,-0.37381E+00,-0.37619E+00,-0.37859E+00,-0.38103E+00,& - -0.38349E+00,-0.38598E+00,-0.38850E+00,-0.39105E+00,-0.39361E+00,& - -0.39621E+00,-0.39883E+00,-0.40147E+00,-0.40414E+00,-0.40684E+00,& - -0.40955E+00,-0.41229E+00,-0.41506E+00,-0.41784E+00,-0.42065E+00,& - -0.42348E+00,-0.42633E+00,-0.42920E+00,-0.43209E+00,-0.43500E+00,& - -0.43793E+00,-0.44089E+00,-0.44386E+00,-0.44685E+00,-0.44986E+00,& - -0.45289E+00,-0.45594E+00,-0.45901E+00,-0.46209E+00,-0.46519E+00,& - -0.46831E+00,-0.47145E+00,-0.47460E+00,-0.47777E+00,-0.48096E+00,& - -0.48416E+00,-0.48738E+00,-0.49062E+00,-0.49387E+00,-0.49713E+00,& - -0.50042E+00,-0.50371E+00,-0.50702E+00,-0.51035E+00,-0.51369E+00,& - -0.51705E+00,-0.52042E+00,-0.52380E+00,-0.52720E+00,-0.53061E+00,& - -0.53403E+00,-0.53747E+00,-0.54092E+00,-0.54438E+00,-0.54786E+00,& - -0.55135E+00,-0.55485E+00,-0.55836E+00,-0.56189E+00,-0.56543E+00,& - -0.56898E+00,-0.57254E+00,-0.57611E+00,-0.57970E+00,-0.58329E+00,& - -0.58690E+00,-0.59052E+00,-0.59415E+00,-0.59779E+00,-0.60144E+00,& - -0.60510E+00,-0.60877E+00,-0.61245E+00,-0.61614E+00,-0.61985E+00/ - - DATA (BNC06M(IA),IA=701,741)/ & - -0.62356E+00,-0.62728E+00,-0.63101E+00,-0.63475E+00,-0.63851E+00,& - -0.64227E+00,-0.64604E+00,-0.64982E+00,-0.65360E+00,-0.65740E+00,& - -0.66121E+00,-0.66502E+00,-0.66885E+00,-0.67268E+00,-0.67652E+00,& - -0.68037E+00,-0.68423E+00,-0.68809E+00,-0.69197E+00,-0.69585E+00,& - -0.69974E+00,-0.70364E+00,-0.70755E+00,-0.71146E+00,-0.71539E+00,& - -0.71932E+00,-0.72325E+00,-0.72720E+00,-0.73115E+00,-0.73511E+00,& - -0.73908E+00,-0.74305E+00,-0.74703E+00,-0.75102E+00,-0.75502E+00,& - -0.75902E+00,-0.76303E+00,-0.76705E+00,-0.77107E+00,-0.77510E+00,& - -0.77914E+00 / -! -! ** (2H, SO4) -! - DATA (BNC07M (IA),IA= 1,100)/ & - -0.11374E+00,-0.20831E+00,-0.27574E+00,-0.32220E+00,-0.35838E+00,& - -0.38830E+00,-0.41395E+00,-0.43649E+00,-0.45665E+00,-0.47492E+00,& - -0.49165E+00,-0.50711E+00,-0.52150E+00,-0.53497E+00,-0.54765E+00,& - -0.55962E+00,-0.57099E+00,-0.58180E+00,-0.59213E+00,-0.60201E+00,& - -0.61150E+00,-0.62062E+00,-0.62941E+00,-0.63790E+00,-0.64610E+00,& - -0.65405E+00,-0.66175E+00,-0.66923E+00,-0.67651E+00,-0.68359E+00,& - -0.69048E+00,-0.69721E+00,-0.70377E+00,-0.71018E+00,-0.71645E+00,& - -0.72258E+00,-0.72859E+00,-0.73447E+00,-0.74024E+00,-0.74589E+00,& - -0.75145E+00,-0.75690E+00,-0.76225E+00,-0.76752E+00,-0.77270E+00,& - -0.77779E+00,-0.78281E+00,-0.78774E+00,-0.79261E+00,-0.79740E+00,& - -0.80212E+00,-0.80678E+00,-0.81138E+00,-0.81592E+00,-0.82039E+00,& - -0.82481E+00,-0.82918E+00,-0.83349E+00,-0.83776E+00,-0.84197E+00,& - -0.84614E+00,-0.85026E+00,-0.85434E+00,-0.85837E+00,-0.86237E+00,& - -0.86632E+00,-0.87023E+00,-0.87411E+00,-0.87795E+00,-0.88176E+00,& - -0.88553E+00,-0.88927E+00,-0.89297E+00,-0.89665E+00,-0.90029E+00,& - -0.90391E+00,-0.90750E+00,-0.91106E+00,-0.91459E+00,-0.91810E+00,& - -0.92158E+00,-0.92503E+00,-0.92847E+00,-0.93188E+00,-0.93527E+00,& - -0.93863E+00,-0.94197E+00,-0.94530E+00,-0.94860E+00,-0.95188E+00,& - -0.95514E+00,-0.95839E+00,-0.96161E+00,-0.96482E+00,-0.96801E+00,& - -0.97118E+00,-0.97433E+00,-0.97747E+00,-0.98059E+00,-0.98370E+00/ - - DATA (BNC07M (IA),IA=101,200)/ & - -0.98679E+00,-0.98986E+00,-0.99292E+00,-0.99596E+00,-0.99899E+00,& - -0.10020E+01,-0.10050E+01,-0.10080E+01,-0.10110E+01,-0.10139E+01,& - -0.10169E+01,-0.10198E+01,-0.10227E+01,-0.10256E+01,-0.10285E+01,& - -0.10314E+01,-0.10343E+01,-0.10371E+01,-0.10400E+01,-0.10428E+01,& - -0.10456E+01,-0.10484E+01,-0.10512E+01,-0.10540E+01,-0.10568E+01,& - -0.10596E+01,-0.10623E+01,-0.10651E+01,-0.10678E+01,-0.10706E+01,& - -0.10733E+01,-0.10760E+01,-0.10787E+01,-0.10814E+01,-0.10840E+01,& - -0.10867E+01,-0.10894E+01,-0.10920E+01,-0.10947E+01,-0.10973E+01,& - -0.10999E+01,-0.11025E+01,-0.11051E+01,-0.11077E+01,-0.11103E+01,& - -0.11129E+01,-0.11155E+01,-0.11180E+01,-0.11206E+01,-0.11232E+01,& - -0.11257E+01,-0.11282E+01,-0.11308E+01,-0.11333E+01,-0.11358E+01,& - -0.11383E+01,-0.11408E+01,-0.11433E+01,-0.11458E+01,-0.11482E+01,& - -0.11507E+01,-0.11532E+01,-0.11556E+01,-0.11581E+01,-0.11605E+01,& - -0.11629E+01,-0.11654E+01,-0.11678E+01,-0.11702E+01,-0.11726E+01,& - -0.11750E+01,-0.11774E+01,-0.11798E+01,-0.11822E+01,-0.11846E+01,& - -0.11870E+01,-0.11893E+01,-0.11917E+01,-0.11941E+01,-0.11964E+01,& - -0.11988E+01,-0.12011E+01,-0.12034E+01,-0.12058E+01,-0.12081E+01,& - -0.12104E+01,-0.12127E+01,-0.12150E+01,-0.12173E+01,-0.12196E+01,& - -0.12219E+01,-0.12242E+01,-0.12265E+01,-0.12288E+01,-0.12311E+01,& - -0.12333E+01,-0.12356E+01,-0.12379E+01,-0.12401E+01,-0.12424E+01/ - - DATA (BNC07M (IA),IA=201,300)/ & - -0.12446E+01,-0.12469E+01,-0.12491E+01,-0.12514E+01,-0.12536E+01,& - -0.12558E+01,-0.12580E+01,-0.12603E+01,-0.12625E+01,-0.12647E+01,& - -0.12669E+01,-0.12691E+01,-0.12713E+01,-0.12735E+01,-0.12757E+01,& - -0.12779E+01,-0.12800E+01,-0.12822E+01,-0.12844E+01,-0.12866E+01,& - -0.12887E+01,-0.12909E+01,-0.12930E+01,-0.12952E+01,-0.12974E+01,& - -0.12995E+01,-0.13017E+01,-0.13038E+01,-0.13059E+01,-0.13081E+01,& - -0.13102E+01,-0.13123E+01,-0.13144E+01,-0.13166E+01,-0.13187E+01,& - -0.13208E+01,-0.13229E+01,-0.13250E+01,-0.13271E+01,-0.13292E+01,& - -0.13313E+01,-0.13334E+01,-0.13355E+01,-0.13376E+01,-0.13397E+01,& - -0.13418E+01,-0.13438E+01,-0.13459E+01,-0.13480E+01,-0.13501E+01,& - -0.13521E+01,-0.13542E+01,-0.13563E+01,-0.13583E+01,-0.13604E+01,& - -0.13624E+01,-0.13645E+01,-0.13665E+01,-0.13686E+01,-0.13706E+01,& - -0.13727E+01,-0.13747E+01,-0.13767E+01,-0.13788E+01,-0.13808E+01,& - -0.13828E+01,-0.13848E+01,-0.13869E+01,-0.13889E+01,-0.13909E+01,& - -0.13929E+01,-0.13949E+01,-0.13969E+01,-0.13989E+01,-0.14009E+01,& - -0.14029E+01,-0.14049E+01,-0.14069E+01,-0.14089E+01,-0.14109E+01,& - -0.14129E+01,-0.14149E+01,-0.14169E+01,-0.14188E+01,-0.14208E+01,& - -0.14228E+01,-0.14248E+01,-0.14267E+01,-0.14287E+01,-0.14307E+01,& - -0.14326E+01,-0.14346E+01,-0.14366E+01,-0.14385E+01,-0.14405E+01,& - -0.14424E+01,-0.14444E+01,-0.14463E+01,-0.14483E+01,-0.14502E+01/ - - DATA (BNC07M (IA),IA=301,400)/ & - -0.14522E+01,-0.14541E+01,-0.14561E+01,-0.14580E+01,-0.14599E+01,& - -0.14619E+01,-0.14638E+01,-0.14657E+01,-0.14676E+01,-0.14696E+01,& - -0.14715E+01,-0.14734E+01,-0.14753E+01,-0.14772E+01,-0.14792E+01,& - -0.14811E+01,-0.14830E+01,-0.14849E+01,-0.14868E+01,-0.14887E+01,& - -0.14906E+01,-0.14925E+01,-0.14944E+01,-0.14963E+01,-0.14982E+01,& - -0.15001E+01,-0.15020E+01,-0.15039E+01,-0.15058E+01,-0.15077E+01,& - -0.15095E+01,-0.15114E+01,-0.15133E+01,-0.15152E+01,-0.15171E+01,& - -0.15189E+01,-0.15208E+01,-0.15227E+01,-0.15246E+01,-0.15264E+01,& - -0.15283E+01,-0.15302E+01,-0.15320E+01,-0.15339E+01,-0.15358E+01,& - -0.15376E+01,-0.15395E+01,-0.15413E+01,-0.15432E+01,-0.15450E+01,& - -0.15469E+01,-0.15487E+01,-0.15506E+01,-0.15524E+01,-0.15543E+01,& - -0.15561E+01,-0.15580E+01,-0.15598E+01,-0.15617E+01,-0.15635E+01,& - -0.15653E+01,-0.15672E+01,-0.15690E+01,-0.15708E+01,-0.15727E+01,& - -0.15745E+01,-0.15763E+01,-0.15781E+01,-0.15800E+01,-0.15818E+01,& - -0.15836E+01,-0.15854E+01,-0.15873E+01,-0.15891E+01,-0.15909E+01,& - -0.15927E+01,-0.15945E+01,-0.15963E+01,-0.15981E+01,-0.15999E+01,& - -0.16018E+01,-0.16036E+01,-0.16054E+01,-0.16072E+01,-0.16090E+01,& - -0.16108E+01,-0.16126E+01,-0.16144E+01,-0.16162E+01,-0.16180E+01,& - -0.16198E+01,-0.16216E+01,-0.16233E+01,-0.16251E+01,-0.16269E+01,& - -0.16287E+01,-0.16305E+01,-0.16323E+01,-0.16341E+01,-0.16358E+01/ - - DATA (BNC07M (IA),IA=401,500)/ & - -0.16376E+01,-0.16394E+01,-0.16412E+01,-0.16430E+01,-0.16447E+01,& - -0.16465E+01,-0.16483E+01,-0.16501E+01,-0.16518E+01,-0.16536E+01,& - -0.16554E+01,-0.16571E+01,-0.16589E+01,-0.16607E+01,-0.16624E+01,& - -0.16642E+01,-0.16660E+01,-0.16677E+01,-0.16695E+01,-0.16712E+01,& - -0.16730E+01,-0.16748E+01,-0.16765E+01,-0.16783E+01,-0.16800E+01,& - -0.16818E+01,-0.16835E+01,-0.16853E+01,-0.16870E+01,-0.16888E+01,& - -0.16905E+01,-0.16923E+01,-0.16940E+01,-0.16958E+01,-0.16975E+01,& - -0.16992E+01,-0.17010E+01,-0.17027E+01,-0.17045E+01,-0.17062E+01,& - -0.17079E+01,-0.17097E+01,-0.17114E+01,-0.17131E+01,-0.17149E+01,& - -0.17166E+01,-0.17183E+01,-0.17200E+01,-0.17218E+01,-0.17235E+01,& - -0.17252E+01,-0.17270E+01,-0.17287E+01,-0.17304E+01,-0.17321E+01,& - -0.17338E+01,-0.17356E+01,-0.17373E+01,-0.17390E+01,-0.17407E+01,& - -0.17424E+01,-0.17441E+01,-0.17459E+01,-0.17476E+01,-0.17493E+01,& - -0.17510E+01,-0.17527E+01,-0.17544E+01,-0.17561E+01,-0.17578E+01,& - -0.17595E+01,-0.17612E+01,-0.17629E+01,-0.17646E+01,-0.17663E+01,& - -0.17680E+01,-0.17697E+01,-0.17714E+01,-0.17731E+01,-0.17748E+01,& - -0.17765E+01,-0.17782E+01,-0.17799E+01,-0.17816E+01,-0.17833E+01,& - -0.17850E+01,-0.17867E+01,-0.17884E+01,-0.17901E+01,-0.17918E+01,& - -0.17935E+01,-0.17951E+01,-0.17968E+01,-0.17985E+01,-0.18002E+01,& - -0.18019E+01,-0.18036E+01,-0.18052E+01,-0.18069E+01,-0.18086E+01/ - - DATA (BNC07M (IA),IA=501,600)/ & - -0.18103E+01,-0.18120E+01,-0.18136E+01,-0.18153E+01,-0.18170E+01,& - -0.18187E+01,-0.18203E+01,-0.18220E+01,-0.18237E+01,-0.18254E+01,& - -0.18270E+01,-0.18287E+01,-0.18304E+01,-0.18320E+01,-0.18337E+01,& - -0.18354E+01,-0.18370E+01,-0.18387E+01,-0.18404E+01,-0.18420E+01,& - -0.18437E+01,-0.18454E+01,-0.18470E+01,-0.18487E+01,-0.18503E+01,& - -0.18520E+01,-0.18537E+01,-0.18553E+01,-0.18570E+01,-0.18586E+01,& - -0.18603E+01,-0.18619E+01,-0.18636E+01,-0.18653E+01,-0.18669E+01,& - -0.18686E+01,-0.18702E+01,-0.18719E+01,-0.18735E+01,-0.18752E+01,& - -0.18768E+01,-0.18785E+01,-0.18801E+01,-0.18817E+01,-0.18834E+01,& - -0.18850E+01,-0.18867E+01,-0.18883E+01,-0.18900E+01,-0.18916E+01,& - -0.18932E+01,-0.18949E+01,-0.18965E+01,-0.18982E+01,-0.18998E+01,& - -0.19014E+01,-0.19031E+01,-0.19047E+01,-0.19063E+01,-0.19080E+01,& - -0.19096E+01,-0.19112E+01,-0.19129E+01,-0.19145E+01,-0.19161E+01,& - -0.19178E+01,-0.19194E+01,-0.19210E+01,-0.19227E+01,-0.19243E+01,& - -0.19259E+01,-0.19275E+01,-0.19292E+01,-0.19308E+01,-0.19324E+01,& - -0.19340E+01,-0.19357E+01,-0.19373E+01,-0.19389E+01,-0.19405E+01,& - -0.19421E+01,-0.19438E+01,-0.19454E+01,-0.19470E+01,-0.19486E+01,& - -0.19502E+01,-0.19519E+01,-0.19535E+01,-0.19551E+01,-0.19567E+01,& - -0.19583E+01,-0.19599E+01,-0.19615E+01,-0.19632E+01,-0.19648E+01,& - -0.19664E+01,-0.19680E+01,-0.19696E+01,-0.19712E+01,-0.19772E+01/ - - DATA (BNC07M (IA),IA=601,700)/ & - -0.19905E+01,-0.20065E+01,-0.20224E+01,-0.20383E+01,-0.20541E+01,& - -0.20698E+01,-0.20856E+01,-0.21012E+01,-0.21168E+01,-0.21324E+01,& - -0.21479E+01,-0.21634E+01,-0.21788E+01,-0.21942E+01,-0.22096E+01,& - -0.22249E+01,-0.22401E+01,-0.22554E+01,-0.22705E+01,-0.22857E+01,& - -0.23008E+01,-0.23159E+01,-0.23309E+01,-0.23459E+01,-0.23609E+01,& - -0.23758E+01,-0.23907E+01,-0.24056E+01,-0.24204E+01,-0.24352E+01,& - -0.24500E+01,-0.24647E+01,-0.24795E+01,-0.24941E+01,-0.25088E+01,& - -0.25234E+01,-0.25380E+01,-0.25526E+01,-0.25672E+01,-0.25817E+01,& - -0.25962E+01,-0.26107E+01,-0.26251E+01,-0.26395E+01,-0.26539E+01,& - -0.26683E+01,-0.26827E+01,-0.26970E+01,-0.27113E+01,-0.27256E+01,& - -0.27399E+01,-0.27541E+01,-0.27683E+01,-0.27825E+01,-0.27967E+01,& - -0.28109E+01,-0.28250E+01,-0.28391E+01,-0.28532E+01,-0.28673E+01,& - -0.28814E+01,-0.28954E+01,-0.29094E+01,-0.29235E+01,-0.29374E+01,& - -0.29514E+01,-0.29654E+01,-0.29793E+01,-0.29932E+01,-0.30071E+01,& - -0.30210E+01,-0.30349E+01,-0.30487E+01,-0.30626E+01,-0.30764E+01,& - -0.30902E+01,-0.31040E+01,-0.31178E+01,-0.31315E+01,-0.31453E+01,& - -0.31590E+01,-0.31727E+01,-0.31864E+01,-0.32001E+01,-0.32138E+01,& - -0.32274E+01,-0.32411E+01,-0.32547E+01,-0.32683E+01,-0.32819E+01,& - -0.32955E+01,-0.33091E+01,-0.33226E+01,-0.33362E+01,-0.33497E+01,& - -0.33632E+01,-0.33767E+01,-0.33902E+01,-0.34037E+01,-0.34172E+01/ - - DATA (BNC07M(IA),IA=701,741)/ & - -0.34307E+01,-0.34441E+01,-0.34576E+01,-0.34710E+01,-0.34844E+01,& - -0.34978E+01,-0.35112E+01,-0.35246E+01,-0.35380E+01,-0.35513E+01,& - -0.35647E+01,-0.35780E+01,-0.35913E+01,-0.36046E+01,-0.36179E+01,& - -0.36312E+01,-0.36445E+01,-0.36578E+01,-0.36711E+01,-0.36843E+01,& - -0.36976E+01,-0.37108E+01,-0.37240E+01,-0.37372E+01,-0.37504E+01,& - -0.37636E+01,-0.37768E+01,-0.37900E+01,-0.38032E+01,-0.38163E+01,& - -0.38295E+01,-0.38426E+01,-0.38557E+01,-0.38689E+01,-0.38820E+01,& - -0.38951E+01,-0.39082E+01,-0.39213E+01,-0.39343E+01,-0.39474E+01,& - -0.39605E+01 / -! -! ** (H, HSO4) -! - DATA (BNC08M (IA),IA= 1,100)/ & - -0.51998E-01,-0.87278E-01,-0.10725E+00,-0.11796E+00,-0.12426E+00,& - -0.12788E+00,-0.12969E+00,-0.13016E+00,-0.12958E+00,-0.12816E+00,& - -0.12603E+00,-0.12329E+00,-0.12003E+00,-0.11630E+00,-0.11215E+00,& - -0.10761E+00,-0.10272E+00,-0.97512E-01,-0.91996E-01,-0.86196E-01,& - -0.80129E-01,-0.73810E-01,-0.67251E-01,-0.60465E-01,-0.53463E-01,& - -0.46254E-01,-0.38847E-01,-0.31251E-01,-0.23474E-01,-0.15524E-01,& - -0.74071E-02, 0.86952E-03, 0.92994E-02, 0.17876E-01, 0.26595E-01,& - 0.35448E-01, 0.44432E-01, 0.53541E-01, 0.62769E-01, 0.72112E-01,& - 0.81565E-01, 0.91123E-01, 0.10078E+00, 0.11054E+00, 0.12039E+00,& - 0.13032E+00, 0.14035E+00, 0.15045E+00, 0.16063E+00, 0.17089E+00,& - 0.18122E+00, 0.19162E+00, 0.20209E+00, 0.21262E+00, 0.22321E+00,& - 0.23386E+00, 0.24457E+00, 0.25534E+00, 0.26617E+00, 0.27704E+00,& - 0.28797E+00, 0.29896E+00, 0.30999E+00, 0.32108E+00, 0.33221E+00,& - 0.34340E+00, 0.35464E+00, 0.36593E+00, 0.37727E+00, 0.38867E+00,& - 0.40012E+00, 0.41162E+00, 0.42317E+00, 0.43478E+00, 0.44645E+00,& - 0.45817E+00, 0.46995E+00, 0.48179E+00, 0.49369E+00, 0.50566E+00,& - 0.51768E+00, 0.52976E+00, 0.54191E+00, 0.55412E+00, 0.56639E+00,& - 0.57873E+00, 0.59114E+00, 0.60360E+00, 0.61613E+00, 0.62873E+00,& - 0.64138E+00, 0.65410E+00, 0.66688E+00, 0.67973E+00, 0.69263E+00,& - 0.70559E+00, 0.71860E+00, 0.73167E+00, 0.74480E+00, 0.75797E+00/ - - DATA (BNC08M (IA),IA=101,200)/ & - 0.77120E+00, 0.78447E+00, 0.79778E+00, 0.81114E+00, 0.82454E+00,& - 0.83797E+00, 0.85144E+00, 0.86495E+00, 0.87848E+00, 0.89204E+00,& - 0.90562E+00, 0.91923E+00, 0.93286E+00, 0.94651E+00, 0.96017E+00,& - 0.97384E+00, 0.98753E+00, 0.10012E+01, 0.10149E+01, 0.10286E+01,& - 0.10411E+01, 0.10550E+01, 0.10688E+01, 0.10826E+01, 0.10964E+01,& - 0.11102E+01, 0.11240E+01, 0.11377E+01, 0.11514E+01, 0.11651E+01,& - 0.11788E+01, 0.11925E+01, 0.12061E+01, 0.12198E+01, 0.12334E+01,& - 0.12470E+01, 0.12605E+01, 0.12741E+01, 0.12876E+01, 0.13011E+01,& - 0.13145E+01, 0.13280E+01, 0.13414E+01, 0.13548E+01, 0.13682E+01,& - 0.13815E+01, 0.13949E+01, 0.14082E+01, 0.14214E+01, 0.14347E+01,& - 0.14479E+01, 0.14611E+01, 0.14743E+01, 0.14875E+01, 0.15006E+01,& - 0.15137E+01, 0.15267E+01, 0.15398E+01, 0.15528E+01, 0.15658E+01,& - 0.15788E+01, 0.15917E+01, 0.16046E+01, 0.16175E+01, 0.16304E+01,& - 0.16432E+01, 0.16560E+01, 0.16688E+01, 0.16815E+01, 0.16942E+01,& - 0.17069E+01, 0.17196E+01, 0.17322E+01, 0.17448E+01, 0.17574E+01,& - 0.17700E+01, 0.17825E+01, 0.17950E+01, 0.18075E+01, 0.18199E+01,& - 0.18324E+01, 0.18447E+01, 0.18571E+01, 0.18694E+01, 0.18818E+01,& - 0.18940E+01, 0.19063E+01, 0.19185E+01, 0.19307E+01, 0.19429E+01,& - 0.19550E+01, 0.19671E+01, 0.19792E+01, 0.19913E+01, 0.20033E+01,& - 0.20153E+01, 0.20273E+01, 0.20393E+01, 0.20512E+01, 0.20631E+01/ - - DATA (BNC08M (IA),IA=201,300)/ & - 0.20750E+01, 0.20868E+01, 0.20986E+01, 0.21104E+01, 0.21222E+01,& - 0.21339E+01, 0.21456E+01, 0.21573E+01, 0.21690E+01, 0.21806E+01,& - 0.21922E+01, 0.22038E+01, 0.22153E+01, 0.22269E+01, 0.22384E+01,& - 0.22498E+01, 0.22613E+01, 0.22727E+01, 0.22841E+01, 0.22955E+01,& - 0.23068E+01, 0.23181E+01, 0.23294E+01, 0.23407E+01, 0.23520E+01,& - 0.23632E+01, 0.23744E+01, 0.23855E+01, 0.23967E+01, 0.24078E+01,& - 0.24189E+01, 0.24299E+01, 0.24410E+01, 0.24520E+01, 0.24630E+01,& - 0.24740E+01, 0.24849E+01, 0.24958E+01, 0.25067E+01, 0.25176E+01,& - 0.25284E+01, 0.25393E+01, 0.25501E+01, 0.25608E+01, 0.25716E+01,& - 0.25823E+01, 0.25930E+01, 0.26037E+01, 0.26143E+01, 0.26250E+01,& - 0.26356E+01, 0.26462E+01, 0.26567E+01, 0.26673E+01, 0.26778E+01,& - 0.26883E+01, 0.26988E+01, 0.27092E+01, 0.27196E+01, 0.27300E+01,& - 0.27404E+01, 0.27508E+01, 0.27611E+01, 0.27714E+01, 0.27817E+01,& - 0.27920E+01, 0.28022E+01, 0.28124E+01, 0.28226E+01, 0.28328E+01,& - 0.28430E+01, 0.28531E+01, 0.28632E+01, 0.28733E+01, 0.28834E+01,& - 0.28934E+01, 0.29034E+01, 0.29134E+01, 0.29234E+01, 0.29334E+01,& - 0.29433E+01, 0.29533E+01, 0.29632E+01, 0.29730E+01, 0.29829E+01,& - 0.29927E+01, 0.30026E+01, 0.30123E+01, 0.30221E+01, 0.30319E+01,& - 0.30416E+01, 0.30513E+01, 0.30610E+01, 0.30707E+01, 0.30804E+01,& - 0.30900E+01, 0.30996E+01, 0.31092E+01, 0.31188E+01, 0.31283E+01/ - - DATA (BNC08M (IA),IA=301,400)/ & - 0.31379E+01, 0.31474E+01, 0.31569E+01, 0.31663E+01, 0.31758E+01,& - 0.31852E+01, 0.31947E+01, 0.32041E+01, 0.32134E+01, 0.32228E+01,& - 0.32321E+01, 0.32415E+01, 0.32508E+01, 0.32601E+01, 0.32693E+01,& - 0.32786E+01, 0.32878E+01, 0.32970E+01, 0.33062E+01, 0.33154E+01,& - 0.33245E+01, 0.33337E+01, 0.33428E+01, 0.33519E+01, 0.33610E+01,& - 0.33701E+01, 0.33791E+01, 0.33881E+01, 0.33971E+01, 0.34061E+01,& - 0.34151E+01, 0.34241E+01, 0.34330E+01, 0.34419E+01, 0.34508E+01,& - 0.34597E+01, 0.34686E+01, 0.34775E+01, 0.34863E+01, 0.34951E+01,& - 0.35039E+01, 0.35127E+01, 0.35215E+01, 0.35302E+01, 0.35390E+01,& - 0.35477E+01, 0.35564E+01, 0.35651E+01, 0.35737E+01, 0.35824E+01,& - 0.35910E+01, 0.35996E+01, 0.36083E+01, 0.36168E+01, 0.36254E+01,& - 0.36340E+01, 0.36425E+01, 0.36510E+01, 0.36595E+01, 0.36680E+01,& - 0.36765E+01, 0.36850E+01, 0.36934E+01, 0.37018E+01, 0.37102E+01,& - 0.37186E+01, 0.37270E+01, 0.37354E+01, 0.37437E+01, 0.37521E+01,& - 0.37604E+01, 0.37687E+01, 0.37770E+01, 0.37852E+01, 0.37935E+01,& - 0.38017E+01, 0.38100E+01, 0.38182E+01, 0.38264E+01, 0.38345E+01,& - 0.38427E+01, 0.38509E+01, 0.38590E+01, 0.38671E+01, 0.38752E+01,& - 0.38833E+01, 0.38914E+01, 0.38995E+01, 0.39075E+01, 0.39155E+01,& - 0.39236E+01, 0.39316E+01, 0.39396E+01, 0.39475E+01, 0.39555E+01,& - 0.39634E+01, 0.39714E+01, 0.39793E+01, 0.39872E+01, 0.39951E+01/ - - DATA (BNC08M (IA),IA=401,500)/ & - 0.40030E+01, 0.40108E+01, 0.40187E+01, 0.40265E+01, 0.40343E+01,& - 0.40421E+01, 0.40499E+01, 0.40577E+01, 0.40655E+01, 0.40732E+01,& - 0.40810E+01, 0.40887E+01, 0.40964E+01, 0.41041E+01, 0.41118E+01,& - 0.41195E+01, 0.41272E+01, 0.41348E+01, 0.41424E+01, 0.41501E+01,& - 0.41577E+01, 0.41653E+01, 0.41728E+01, 0.41804E+01, 0.41880E+01,& - 0.41955E+01, 0.42030E+01, 0.42105E+01, 0.42181E+01, 0.42255E+01,& - 0.42330E+01, 0.42405E+01, 0.42479E+01, 0.42554E+01, 0.42628E+01,& - 0.42702E+01, 0.42776E+01, 0.42850E+01, 0.42924E+01, 0.42998E+01,& - 0.43071E+01, 0.43145E+01, 0.43218E+01, 0.43291E+01, 0.43364E+01,& - 0.43437E+01, 0.43510E+01, 0.43583E+01, 0.43655E+01, 0.43728E+01,& - 0.43800E+01, 0.43872E+01, 0.43944E+01, 0.44016E+01, 0.44088E+01,& - 0.44160E+01, 0.44231E+01, 0.44303E+01, 0.44374E+01, 0.44446E+01,& - 0.44517E+01, 0.44588E+01, 0.44659E+01, 0.44729E+01, 0.44800E+01,& - 0.44871E+01, 0.44941E+01, 0.45012E+01, 0.45082E+01, 0.45152E+01,& - 0.45222E+01, 0.45292E+01, 0.45362E+01, 0.45431E+01, 0.45501E+01,& - 0.45570E+01, 0.45640E+01, 0.45709E+01, 0.45778E+01, 0.45847E+01,& - 0.45916E+01, 0.45985E+01, 0.46053E+01, 0.46122E+01, 0.46190E+01,& - 0.46259E+01, 0.46327E+01, 0.46395E+01, 0.46463E+01, 0.46531E+01,& - 0.46599E+01, 0.46667E+01, 0.46734E+01, 0.46802E+01, 0.46869E+01,& - 0.46936E+01, 0.47004E+01, 0.47071E+01, 0.47138E+01, 0.47205E+01/ - - DATA (BNC08M (IA),IA=501,600)/ & - 0.47271E+01, 0.47338E+01, 0.47405E+01, 0.47471E+01, 0.47537E+01,& - 0.47604E+01, 0.47670E+01, 0.47736E+01, 0.47802E+01, 0.47868E+01,& - 0.47934E+01, 0.47999E+01, 0.48065E+01, 0.48130E+01, 0.48196E+01,& - 0.48261E+01, 0.48326E+01, 0.48391E+01, 0.48456E+01, 0.48521E+01,& - 0.48586E+01, 0.48650E+01, 0.48715E+01, 0.48779E+01, 0.48844E+01,& - 0.48908E+01, 0.48972E+01, 0.49036E+01, 0.49100E+01, 0.49164E+01,& - 0.49228E+01, 0.49292E+01, 0.49355E+01, 0.49419E+01, 0.49482E+01,& - 0.49546E+01, 0.49609E+01, 0.49672E+01, 0.49735E+01, 0.49798E+01,& - 0.49861E+01, 0.49924E+01, 0.49986E+01, 0.50049E+01, 0.50112E+01,& - 0.50174E+01, 0.50236E+01, 0.50299E+01, 0.50361E+01, 0.50423E+01,& - 0.50485E+01, 0.50547E+01, 0.50608E+01, 0.50670E+01, 0.50732E+01,& - 0.50793E+01, 0.50855E+01, 0.50916E+01, 0.50977E+01, 0.51038E+01,& - 0.51099E+01, 0.51160E+01, 0.51221E+01, 0.51282E+01, 0.51343E+01,& - 0.51403E+01, 0.51464E+01, 0.51524E+01, 0.51585E+01, 0.51645E+01,& - 0.51705E+01, 0.51765E+01, 0.51825E+01, 0.51885E+01, 0.51945E+01,& - 0.52005E+01, 0.52065E+01, 0.52124E+01, 0.52184E+01, 0.52243E+01,& - 0.52303E+01, 0.52362E+01, 0.52421E+01, 0.52480E+01, 0.52539E+01,& - 0.52598E+01, 0.52657E+01, 0.52716E+01, 0.52775E+01, 0.52833E+01,& - 0.52892E+01, 0.52950E+01, 0.53009E+01, 0.53067E+01, 0.53125E+01,& - 0.53183E+01, 0.53241E+01, 0.53299E+01, 0.53357E+01, 0.53574E+01/ - - DATA (BNC08M (IA),IA=601,700)/ & - 0.54046E+01, 0.54611E+01, 0.55169E+01, 0.55719E+01, 0.56263E+01,& - 0.56799E+01, 0.57328E+01, 0.57851E+01, 0.58367E+01, 0.58877E+01,& - 0.59380E+01, 0.59878E+01, 0.60369E+01, 0.60855E+01, 0.61334E+01,& - 0.61808E+01, 0.62277E+01, 0.62740E+01, 0.63198E+01, 0.63651E+01,& - 0.64099E+01, 0.64542E+01, 0.64979E+01, 0.65413E+01, 0.65841E+01,& - 0.66265E+01, 0.66684E+01, 0.67099E+01, 0.67509E+01, 0.67916E+01,& - 0.68318E+01, 0.68715E+01, 0.69109E+01, 0.69499E+01, 0.69885E+01,& - 0.70267E+01, 0.70646E+01, 0.71020E+01, 0.71391E+01, 0.71759E+01,& - 0.72123E+01, 0.72483E+01, 0.72840E+01, 0.73194E+01, 0.73544E+01,& - 0.73891E+01, 0.74235E+01, 0.74576E+01, 0.74914E+01, 0.75248E+01,& - 0.75580E+01, 0.75909E+01, 0.76234E+01, 0.76557E+01, 0.76877E+01,& - 0.77195E+01, 0.77509E+01, 0.77821E+01, 0.78130E+01, 0.78437E+01,& - 0.78741E+01, 0.79042E+01, 0.79341E+01, 0.79637E+01, 0.79931E+01,& - 0.80223E+01, 0.80512E+01, 0.80799E+01, 0.81083E+01, 0.81365E+01,& - 0.81645E+01, 0.81923E+01, 0.82199E+01, 0.82472E+01, 0.82743E+01,& - 0.83012E+01, 0.83279E+01, 0.83544E+01, 0.83807E+01, 0.84068E+01,& - 0.84327E+01, 0.84584E+01, 0.84839E+01, 0.85093E+01, 0.85344E+01,& - 0.85593E+01, 0.85841E+01, 0.86087E+01, 0.86331E+01, 0.86573E+01,& - 0.86813E+01, 0.87052E+01, 0.87289E+01, 0.87524E+01, 0.87758E+01,& - 0.87990E+01, 0.88220E+01, 0.88449E+01, 0.88676E+01, 0.88902E+01/ - - DATA (BNC08M(IA),IA=701,741)/ & - 0.89126E+01, 0.89348E+01, 0.89569E+01, 0.89789E+01, 0.90006E+01,& - 0.90223E+01, 0.90438E+01, 0.90651E+01, 0.90863E+01, 0.91074E+01,& - 0.91283E+01, 0.91491E+01, 0.91698E+01, 0.91903E+01, 0.92107E+01,& - 0.92309E+01, 0.92510E+01, 0.92710E+01, 0.92909E+01, 0.93106E+01,& - 0.93302E+01, 0.93497E+01, 0.93690E+01, 0.93883E+01, 0.94074E+01,& - 0.94264E+01, 0.94452E+01, 0.94640E+01, 0.94826E+01, 0.95011E+01,& - 0.95195E+01, 0.95378E+01, 0.95560E+01, 0.95741E+01, 0.95920E+01,& - 0.96099E+01, 0.96276E+01, 0.96452E+01, 0.96628E+01, 0.96802E+01,& - 0.96975E+01 / -! -! ** NH4HSO4 -! - DATA (BNC09M (IA),IA= 1,100)/ & - -0.55422E-01,-0.99324E-01,-0.12935E+00,-0.14934E+00,-0.16445E+00,& - -0.17660E+00,-0.18672E+00,-0.19536E+00,-0.20285E+00,-0.20943E+00,& - -0.21526E+00,-0.22046E+00,-0.22511E+00,-0.22929E+00,-0.23305E+00,& - -0.23643E+00,-0.23948E+00,-0.24222E+00,-0.24468E+00,-0.24688E+00,& - -0.24884E+00,-0.25058E+00,-0.25210E+00,-0.25342E+00,-0.25456E+00,& - -0.25551E+00,-0.25630E+00,-0.25692E+00,-0.25739E+00,-0.25771E+00,& - -0.25789E+00,-0.25794E+00,-0.25785E+00,-0.25763E+00,-0.25730E+00,& - -0.25685E+00,-0.25628E+00,-0.25561E+00,-0.25483E+00,-0.25395E+00,& - -0.25297E+00,-0.25190E+00,-0.25074E+00,-0.24948E+00,-0.24815E+00,& - -0.24673E+00,-0.24523E+00,-0.24366E+00,-0.24201E+00,-0.24029E+00,& - -0.23850E+00,-0.23664E+00,-0.23472E+00,-0.23274E+00,-0.23069E+00,& - -0.22859E+00,-0.22643E+00,-0.22421E+00,-0.22194E+00,-0.21962E+00,& - -0.21725E+00,-0.21483E+00,-0.21236E+00,-0.20985E+00,-0.20729E+00,& - -0.20468E+00,-0.20203E+00,-0.19934E+00,-0.19661E+00,-0.19384E+00,& - -0.19102E+00,-0.18817E+00,-0.18528E+00,-0.18235E+00,-0.17938E+00,& - -0.17637E+00,-0.17333E+00,-0.17025E+00,-0.16713E+00,-0.16398E+00,& - -0.16079E+00,-0.15757E+00,-0.15431E+00,-0.15101E+00,-0.14768E+00,& - -0.14432E+00,-0.14092E+00,-0.13750E+00,-0.13403E+00,-0.13054E+00,& - -0.12701E+00,-0.12346E+00,-0.11987E+00,-0.11626E+00,-0.11261E+00,& - -0.10894E+00,-0.10524E+00,-0.10152E+00,-0.97765E-01,-0.93990E-01/ - - DATA (BNC09M (IA),IA=101,200)/ & - -0.90192E-01,-0.86371E-01,-0.82530E-01,-0.78668E-01,-0.74788E-01,& - -0.70889E-01,-0.66974E-01,-0.63042E-01,-0.59097E-01,-0.55137E-01,& - -0.51165E-01,-0.47182E-01,-0.43188E-01,-0.39185E-01,-0.35173E-01,& - -0.31154E-01,-0.27129E-01,-0.23099E-01,-0.19063E-01,-0.15024E-01,& - -0.11398E-01,-0.73058E-02,-0.32173E-02, 0.86749E-03, 0.49480E-02,& - 0.90243E-02, 0.13096E-01, 0.17162E-01, 0.21224E-01, 0.25280E-01,& - 0.29330E-01, 0.33374E-01, 0.37412E-01, 0.41443E-01, 0.45469E-01,& - 0.49487E-01, 0.53498E-01, 0.57502E-01, 0.61499E-01, 0.65488E-01,& - 0.69470E-01, 0.73444E-01, 0.77410E-01, 0.81368E-01, 0.85318E-01,& - 0.89260E-01, 0.93194E-01, 0.97118E-01, 0.10103E+00, 0.10494E+00,& - 0.10884E+00, 0.11273E+00, 0.11661E+00, 0.12049E+00, 0.12435E+00,& - 0.12820E+00, 0.13205E+00, 0.13588E+00, 0.13971E+00, 0.14353E+00,& - 0.14733E+00, 0.15113E+00, 0.15492E+00, 0.15870E+00, 0.16247E+00,& - 0.16623E+00, 0.16998E+00, 0.17373E+00, 0.17746E+00, 0.18118E+00,& - 0.18489E+00, 0.18860E+00, 0.19229E+00, 0.19597E+00, 0.19965E+00,& - 0.20331E+00, 0.20697E+00, 0.21061E+00, 0.21425E+00, 0.21787E+00,& - 0.22149E+00, 0.22510E+00, 0.22869E+00, 0.23228E+00, 0.23586E+00,& - 0.23943E+00, 0.24299E+00, 0.24654E+00, 0.25008E+00, 0.25361E+00,& - 0.25713E+00, 0.26064E+00, 0.26414E+00, 0.26763E+00, 0.27112E+00,& - 0.27459E+00, 0.27805E+00, 0.28151E+00, 0.28495E+00, 0.28839E+00/ - - DATA (BNC09M (IA),IA=201,300)/ & - 0.29182E+00, 0.29523E+00, 0.29864E+00, 0.30204E+00, 0.30543E+00,& - 0.30881E+00, 0.31218E+00, 0.31555E+00, 0.31890E+00, 0.32225E+00,& - 0.32558E+00, 0.32891E+00, 0.33223E+00, 0.33553E+00, 0.33883E+00,& - 0.34213E+00, 0.34541E+00, 0.34868E+00, 0.35195E+00, 0.35520E+00,& - 0.35845E+00, 0.36169E+00, 0.36492E+00, 0.36814E+00, 0.37135E+00,& - 0.37456E+00, 0.37775E+00, 0.38094E+00, 0.38412E+00, 0.38729E+00,& - 0.39045E+00, 0.39361E+00, 0.39675E+00, 0.39989E+00, 0.40302E+00,& - 0.40614E+00, 0.40925E+00, 0.41236E+00, 0.41546E+00, 0.41854E+00,& - 0.42162E+00, 0.42470E+00, 0.42776E+00, 0.43082E+00, 0.43387E+00,& - 0.43691E+00, 0.43994E+00, 0.44297E+00, 0.44598E+00, 0.44899E+00,& - 0.45200E+00, 0.45499E+00, 0.45798E+00, 0.46096E+00, 0.46393E+00,& - 0.46689E+00, 0.46985E+00, 0.47280E+00, 0.47574E+00, 0.47867E+00,& - 0.48160E+00, 0.48452E+00, 0.48743E+00, 0.49033E+00, 0.49323E+00,& - 0.49612E+00, 0.49900E+00, 0.50188E+00, 0.50475E+00, 0.50761E+00,& - 0.51046E+00, 0.51331E+00, 0.51615E+00, 0.51898E+00, 0.52181E+00,& - 0.52463E+00, 0.52744E+00, 0.53025E+00, 0.53305E+00, 0.53584E+00,& - 0.53862E+00, 0.54140E+00, 0.54417E+00, 0.54694E+00, 0.54969E+00,& - 0.55244E+00, 0.55519E+00, 0.55793E+00, 0.56066E+00, 0.56338E+00,& - 0.56610E+00, 0.56881E+00, 0.57152E+00, 0.57422E+00, 0.57691E+00,& - 0.57959E+00, 0.58227E+00, 0.58495E+00, 0.58761E+00, 0.59027E+00/ - - DATA (BNC09M (IA),IA=301,400)/ & - 0.59293E+00, 0.59558E+00, 0.59822E+00, 0.60085E+00, 0.60348E+00,& - 0.60611E+00, 0.60872E+00, 0.61133E+00, 0.61394E+00, 0.61654E+00,& - 0.61913E+00, 0.62172E+00, 0.62430E+00, 0.62687E+00, 0.62944E+00,& - 0.63200E+00, 0.63456E+00, 0.63711E+00, 0.63966E+00, 0.64219E+00,& - 0.64473E+00, 0.64726E+00, 0.64978E+00, 0.65229E+00, 0.65480E+00,& - 0.65731E+00, 0.65981E+00, 0.66230E+00, 0.66479E+00, 0.66727E+00,& - 0.66975E+00, 0.67222E+00, 0.67468E+00, 0.67714E+00, 0.67960E+00,& - 0.68205E+00, 0.68449E+00, 0.68693E+00, 0.68936E+00, 0.69179E+00,& - 0.69421E+00, 0.69663E+00, 0.69904E+00, 0.70144E+00, 0.70384E+00,& - 0.70624E+00, 0.70863E+00, 0.71101E+00, 0.71339E+00, 0.71577E+00,& - 0.71813E+00, 0.72050E+00, 0.72286E+00, 0.72521E+00, 0.72756E+00,& - 0.72990E+00, 0.73224E+00, 0.73457E+00, 0.73690E+00, 0.73922E+00,& - 0.74154E+00, 0.74386E+00, 0.74616E+00, 0.74847E+00, 0.75076E+00,& - 0.75306E+00, 0.75535E+00, 0.75763E+00, 0.75991E+00, 0.76218E+00,& - 0.76445E+00, 0.76671E+00, 0.76897E+00, 0.77123E+00, 0.77348E+00,& - 0.77572E+00, 0.77796E+00, 0.78020E+00, 0.78243E+00, 0.78465E+00,& - 0.78687E+00, 0.78909E+00, 0.79130E+00, 0.79351E+00, 0.79571E+00,& - 0.79791E+00, 0.80010E+00, 0.80229E+00, 0.80448E+00, 0.80666E+00,& - 0.80883E+00, 0.81100E+00, 0.81317E+00, 0.81533E+00, 0.81749E+00,& - 0.81964E+00, 0.82179E+00, 0.82394E+00, 0.82608E+00, 0.82821E+00/ - - DATA (BNC09M (IA),IA=401,500)/ & - 0.83034E+00, 0.83247E+00, 0.83459E+00, 0.83671E+00, 0.83882E+00,& - 0.84093E+00, 0.84304E+00, 0.84514E+00, 0.84723E+00, 0.84933E+00,& - 0.85141E+00, 0.85350E+00, 0.85558E+00, 0.85765E+00, 0.85972E+00,& - 0.86179E+00, 0.86385E+00, 0.86591E+00, 0.86797E+00, 0.87002E+00,& - 0.87207E+00, 0.87411E+00, 0.87615E+00, 0.87818E+00, 0.88021E+00,& - 0.88224E+00, 0.88426E+00, 0.88628E+00, 0.88829E+00, 0.89030E+00,& - 0.89231E+00, 0.89431E+00, 0.89631E+00, 0.89830E+00, 0.90029E+00,& - 0.90228E+00, 0.90426E+00, 0.90624E+00, 0.90822E+00, 0.91019E+00,& - 0.91216E+00, 0.91412E+00, 0.91608E+00, 0.91803E+00, 0.91999E+00,& - 0.92193E+00, 0.92388E+00, 0.92582E+00, 0.92776E+00, 0.92969E+00,& - 0.93162E+00, 0.93354E+00, 0.93547E+00, 0.93738E+00, 0.93930E+00,& - 0.94121E+00, 0.94312E+00, 0.94502E+00, 0.94692E+00, 0.94882E+00,& - 0.95071E+00, 0.95260E+00, 0.95448E+00, 0.95637E+00, 0.95824E+00,& - 0.96012E+00, 0.96199E+00, 0.96386E+00, 0.96572E+00, 0.96758E+00,& - 0.96944E+00, 0.97129E+00, 0.97314E+00, 0.97499E+00, 0.97683E+00,& - 0.97867E+00, 0.98051E+00, 0.98234E+00, 0.98417E+00, 0.98600E+00,& - 0.98782E+00, 0.98964E+00, 0.99145E+00, 0.99327E+00, 0.99507E+00,& - 0.99688E+00, 0.99868E+00, 0.10005E+01, 0.10023E+01, 0.10041E+01,& - 0.10059E+01, 0.10076E+01, 0.10094E+01, 0.10112E+01, 0.10130E+01,& - 0.10148E+01, 0.10165E+01, 0.10183E+01, 0.10200E+01, 0.10218E+01/ - - DATA (BNC09M (IA),IA=501,600)/ & - 0.10236E+01, 0.10253E+01, 0.10271E+01, 0.10288E+01, 0.10306E+01,& - 0.10323E+01, 0.10340E+01, 0.10358E+01, 0.10375E+01, 0.10392E+01,& - 0.10409E+01, 0.10427E+01, 0.10444E+01, 0.10461E+01, 0.10478E+01,& - 0.10495E+01, 0.10512E+01, 0.10529E+01, 0.10546E+01, 0.10563E+01,& - 0.10580E+01, 0.10597E+01, 0.10614E+01, 0.10631E+01, 0.10648E+01,& - 0.10664E+01, 0.10681E+01, 0.10698E+01, 0.10715E+01, 0.10731E+01,& - 0.10748E+01, 0.10765E+01, 0.10781E+01, 0.10798E+01, 0.10814E+01,& - 0.10831E+01, 0.10847E+01, 0.10864E+01, 0.10880E+01, 0.10896E+01,& - 0.10913E+01, 0.10929E+01, 0.10945E+01, 0.10961E+01, 0.10978E+01,& - 0.10994E+01, 0.11010E+01, 0.11026E+01, 0.11042E+01, 0.11058E+01,& - 0.11074E+01, 0.11090E+01, 0.11106E+01, 0.11122E+01, 0.11138E+01,& - 0.11154E+01, 0.11170E+01, 0.11186E+01, 0.11202E+01, 0.11218E+01,& - 0.11233E+01, 0.11249E+01, 0.11265E+01, 0.11281E+01, 0.11296E+01,& - 0.11312E+01, 0.11328E+01, 0.11343E+01, 0.11359E+01, 0.11374E+01,& - 0.11390E+01, 0.11405E+01, 0.11421E+01, 0.11436E+01, 0.11451E+01,& - 0.11467E+01, 0.11482E+01, 0.11497E+01, 0.11513E+01, 0.11528E+01,& - 0.11543E+01, 0.11559E+01, 0.11574E+01, 0.11589E+01, 0.11604E+01,& - 0.11619E+01, 0.11634E+01, 0.11649E+01, 0.11664E+01, 0.11679E+01,& - 0.11694E+01, 0.11709E+01, 0.11724E+01, 0.11739E+01, 0.11754E+01,& - 0.11769E+01, 0.11784E+01, 0.11798E+01, 0.11813E+01, 0.11868E+01/ - - DATA (BNC09M (IA),IA=601,700)/ & - 0.11989E+01, 0.12132E+01, 0.12273E+01, 0.12412E+01, 0.12549E+01,& - 0.12683E+01, 0.12816E+01, 0.12946E+01, 0.13074E+01, 0.13200E+01,& - 0.13324E+01, 0.13446E+01, 0.13566E+01, 0.13685E+01, 0.13801E+01,& - 0.13916E+01, 0.14029E+01, 0.14141E+01, 0.14250E+01, 0.14358E+01,& - 0.14465E+01, 0.14570E+01, 0.14673E+01, 0.14775E+01, 0.14875E+01,& - 0.14974E+01, 0.15072E+01, 0.15168E+01, 0.15262E+01, 0.15356E+01,& - 0.15448E+01, 0.15538E+01, 0.15628E+01, 0.15716E+01, 0.15803E+01,& - 0.15888E+01, 0.15973E+01, 0.16056E+01, 0.16138E+01, 0.16219E+01,& - 0.16299E+01, 0.16378E+01, 0.16455E+01, 0.16532E+01, 0.16608E+01,& - 0.16682E+01, 0.16756E+01, 0.16828E+01, 0.16900E+01, 0.16970E+01,& - 0.17040E+01, 0.17108E+01, 0.17176E+01, 0.17243E+01, 0.17308E+01,& - 0.17373E+01, 0.17438E+01, 0.17501E+01, 0.17563E+01, 0.17625E+01,& - 0.17685E+01, 0.17745E+01, 0.17804E+01, 0.17863E+01, 0.17920E+01,& - 0.17977E+01, 0.18033E+01, 0.18088E+01, 0.18142E+01, 0.18196E+01,& - 0.18249E+01, 0.18302E+01, 0.18353E+01, 0.18404E+01, 0.18454E+01,& - 0.18504E+01, 0.18553E+01, 0.18601E+01, 0.18649E+01, 0.18695E+01,& - 0.18742E+01, 0.18787E+01, 0.18832E+01, 0.18877E+01, 0.18921E+01,& - 0.18964E+01, 0.19007E+01, 0.19049E+01, 0.19090E+01, 0.19131E+01,& - 0.19171E+01, 0.19211E+01, 0.19250E+01, 0.19289E+01, 0.19327E+01,& - 0.19365E+01, 0.19402E+01, 0.19439E+01, 0.19475E+01, 0.19510E+01/ - - DATA (BNC09M(IA),IA=701,741)/ & - 0.19545E+01, 0.19580E+01, 0.19614E+01, 0.19647E+01, 0.19681E+01,& - 0.19713E+01, 0.19745E+01, 0.19777E+01, 0.19808E+01, 0.19839E+01,& - 0.19869E+01, 0.19899E+01, 0.19929E+01, 0.19958E+01, 0.19986E+01,& - 0.20014E+01, 0.20042E+01, 0.20069E+01, 0.20096E+01, 0.20123E+01,& - 0.20149E+01, 0.20175E+01, 0.20200E+01, 0.20225E+01, 0.20249E+01,& - 0.20273E+01, 0.20297E+01, 0.20320E+01, 0.20343E+01, 0.20366E+01,& - 0.20388E+01, 0.20410E+01, 0.20432E+01, 0.20453E+01, 0.20473E+01,& - 0.20494E+01, 0.20514E+01, 0.20534E+01, 0.20553E+01, 0.20572E+01,& - 0.20591E+01 / -! -! ** (H, NO3) -! - DATA (BNC10M (IA),IA= 1,100)/ & - -0.54443E-01,-0.95281E-01,-0.12118E+00,-0.13706E+00,-0.14810E+00,& - -0.15622E+00,-0.16239E+00,-0.16713E+00,-0.17079E+00,-0.17360E+00,& - -0.17573E+00,-0.17729E+00,-0.17838E+00,-0.17908E+00,-0.17943E+00,& - -0.17948E+00,-0.17928E+00,-0.17885E+00,-0.17821E+00,-0.17740E+00,& - -0.17642E+00,-0.17531E+00,-0.17407E+00,-0.17271E+00,-0.17124E+00,& - -0.16969E+00,-0.16805E+00,-0.16633E+00,-0.16455E+00,-0.16270E+00,& - -0.16080E+00,-0.15884E+00,-0.15684E+00,-0.15480E+00,-0.15272E+00,& - -0.15061E+00,-0.14847E+00,-0.14631E+00,-0.14412E+00,-0.14191E+00,& - -0.13968E+00,-0.13744E+00,-0.13518E+00,-0.13291E+00,-0.13063E+00,& - -0.12834E+00,-0.12605E+00,-0.12375E+00,-0.12144E+00,-0.11913E+00,& - -0.11682E+00,-0.11450E+00,-0.11218E+00,-0.10986E+00,-0.10754E+00,& - -0.10521E+00,-0.10289E+00,-0.10056E+00,-0.98232E-01,-0.95901E-01,& - -0.93569E-01,-0.91233E-01,-0.88895E-01,-0.86553E-01,-0.84207E-01,& - -0.81856E-01,-0.79499E-01,-0.77136E-01,-0.74766E-01,-0.72388E-01,& - -0.70002E-01,-0.67607E-01,-0.65201E-01,-0.62784E-01,-0.60355E-01,& - -0.57914E-01,-0.55459E-01,-0.52990E-01,-0.50507E-01,-0.48008E-01,& - -0.45493E-01,-0.42962E-01,-0.40413E-01,-0.37847E-01,-0.35263E-01,& - -0.32660E-01,-0.30039E-01,-0.27400E-01,-0.24741E-01,-0.22063E-01,& - -0.19367E-01,-0.16651E-01,-0.13917E-01,-0.11164E-01,-0.83926E-02,& - -0.56031E-02,-0.27959E-02, 0.28739E-04, 0.28702E-02, 0.57282E-02/ - - DATA (BNC10M (IA),IA=101,200)/ & - 0.86021E-02, 0.11491E-01, 0.14395E-01, 0.17314E-01, 0.20245E-01,& - 0.23190E-01, 0.26147E-01, 0.29115E-01, 0.32095E-01, 0.35084E-01,& - 0.38083E-01, 0.41091E-01, 0.44107E-01, 0.47130E-01, 0.50160E-01,& - 0.53197E-01, 0.56239E-01, 0.59286E-01, 0.62338E-01, 0.65393E-01,& - 0.68068E-01, 0.71174E-01, 0.74277E-01, 0.77379E-01, 0.80478E-01,& - 0.83575E-01, 0.86669E-01, 0.89761E-01, 0.92850E-01, 0.95936E-01,& - 0.99019E-01, 0.10210E+00, 0.10518E+00, 0.10825E+00, 0.11132E+00,& - 0.11439E+00, 0.11746E+00, 0.12052E+00, 0.12358E+00, 0.12663E+00,& - 0.12968E+00, 0.13273E+00, 0.13578E+00, 0.13882E+00, 0.14185E+00,& - 0.14489E+00, 0.14792E+00, 0.15094E+00, 0.15397E+00, 0.15698E+00,& - 0.16000E+00, 0.16301E+00, 0.16601E+00, 0.16902E+00, 0.17201E+00,& - 0.17501E+00, 0.17800E+00, 0.18098E+00, 0.18396E+00, 0.18694E+00,& - 0.18991E+00, 0.19288E+00, 0.19585E+00, 0.19881E+00, 0.20176E+00,& - 0.20471E+00, 0.20766E+00, 0.21060E+00, 0.21354E+00, 0.21647E+00,& - 0.21940E+00, 0.22232E+00, 0.22524E+00, 0.22816E+00, 0.23107E+00,& - 0.23397E+00, 0.23687E+00, 0.23977E+00, 0.24266E+00, 0.24554E+00,& - 0.24843E+00, 0.25130E+00, 0.25418E+00, 0.25704E+00, 0.25991E+00,& - 0.26276E+00, 0.26562E+00, 0.26846E+00, 0.27131E+00, 0.27415E+00,& - 0.27698E+00, 0.27981E+00, 0.28263E+00, 0.28545E+00, 0.28827E+00,& - 0.29107E+00, 0.29388E+00, 0.29668E+00, 0.29947E+00, 0.30226E+00/ - - DATA (BNC10M (IA),IA=201,300)/ & - 0.30505E+00, 0.30783E+00, 0.31060E+00, 0.31337E+00, 0.31614E+00,& - 0.31890E+00, 0.32165E+00, 0.32440E+00, 0.32715E+00, 0.32989E+00,& - 0.33262E+00, 0.33535E+00, 0.33808E+00, 0.34080E+00, 0.34351E+00,& - 0.34622E+00, 0.34893E+00, 0.35163E+00, 0.35432E+00, 0.35701E+00,& - 0.35970E+00, 0.36238E+00, 0.36505E+00, 0.36772E+00, 0.37039E+00,& - 0.37305E+00, 0.37571E+00, 0.37836E+00, 0.38100E+00, 0.38364E+00,& - 0.38628E+00, 0.38891E+00, 0.39153E+00, 0.39416E+00, 0.39677E+00,& - 0.39938E+00, 0.40199E+00, 0.40459E+00, 0.40719E+00, 0.40978E+00,& - 0.41236E+00, 0.41495E+00, 0.41752E+00, 0.42009E+00, 0.42266E+00,& - 0.42522E+00, 0.42778E+00, 0.43033E+00, 0.43288E+00, 0.43542E+00,& - 0.43796E+00, 0.44049E+00, 0.44302E+00, 0.44554E+00, 0.44806E+00,& - 0.45057E+00, 0.45308E+00, 0.45559E+00, 0.45808E+00, 0.46058E+00,& - 0.46307E+00, 0.46555E+00, 0.46803E+00, 0.47051E+00, 0.47298E+00,& - 0.47544E+00, 0.47790E+00, 0.48036E+00, 0.48281E+00, 0.48526E+00,& - 0.48770E+00, 0.49013E+00, 0.49257E+00, 0.49499E+00, 0.49742E+00,& - 0.49983E+00, 0.50225E+00, 0.50466E+00, 0.50706E+00, 0.50946E+00,& - 0.51185E+00, 0.51424E+00, 0.51663E+00, 0.51901E+00, 0.52139E+00,& - 0.52376E+00, 0.52612E+00, 0.52849E+00, 0.53084E+00, 0.53320E+00,& - 0.53555E+00, 0.53789E+00, 0.54023E+00, 0.54257E+00, 0.54490E+00,& - 0.54722E+00, 0.54954E+00, 0.55186E+00, 0.55417E+00, 0.55648E+00/ - - DATA (BNC10M (IA),IA=301,400)/ & - 0.55878E+00, 0.56108E+00, 0.56338E+00, 0.56567E+00, 0.56795E+00,& - 0.57023E+00, 0.57251E+00, 0.57478E+00, 0.57705E+00, 0.57932E+00,& - 0.58157E+00, 0.58383E+00, 0.58608E+00, 0.58833E+00, 0.59057E+00,& - 0.59280E+00, 0.59504E+00, 0.59727E+00, 0.59949E+00, 0.60171E+00,& - 0.60393E+00, 0.60614E+00, 0.60835E+00, 0.61055E+00, 0.61275E+00,& - 0.61494E+00, 0.61713E+00, 0.61932E+00, 0.62150E+00, 0.62368E+00,& - 0.62585E+00, 0.62802E+00, 0.63018E+00, 0.63234E+00, 0.63450E+00,& - 0.63665E+00, 0.63880E+00, 0.64095E+00, 0.64309E+00, 0.64522E+00,& - 0.64735E+00, 0.64948E+00, 0.65161E+00, 0.65372E+00, 0.65584E+00,& - 0.65795E+00, 0.66006E+00, 0.66216E+00, 0.66426E+00, 0.66636E+00,& - 0.66845E+00, 0.67053E+00, 0.67262E+00, 0.67470E+00, 0.67677E+00,& - 0.67884E+00, 0.68091E+00, 0.68297E+00, 0.68503E+00, 0.68709E+00,& - 0.68914E+00, 0.69119E+00, 0.69323E+00, 0.69527E+00, 0.69731E+00,& - 0.69934E+00, 0.70137E+00, 0.70339E+00, 0.70541E+00, 0.70743E+00,& - 0.70944E+00, 0.71145E+00, 0.71346E+00, 0.71546E+00, 0.71745E+00,& - 0.71945E+00, 0.72144E+00, 0.72342E+00, 0.72541E+00, 0.72738E+00,& - 0.72936E+00, 0.73133E+00, 0.73330E+00, 0.73526E+00, 0.73722E+00,& - 0.73918E+00, 0.74113E+00, 0.74308E+00, 0.74502E+00, 0.74697E+00,& - 0.74890E+00, 0.75084E+00, 0.75277E+00, 0.75470E+00, 0.75662E+00,& - 0.75854E+00, 0.76046E+00, 0.76237E+00, 0.76428E+00, 0.76618E+00/ - - DATA (BNC10M (IA),IA=401,500)/ & - 0.76808E+00, 0.76998E+00, 0.77188E+00, 0.77377E+00, 0.77566E+00,& - 0.77754E+00, 0.77942E+00, 0.78130E+00, 0.78317E+00, 0.78504E+00,& - 0.78691E+00, 0.78877E+00, 0.79063E+00, 0.79249E+00, 0.79434E+00,& - 0.79619E+00, 0.79803E+00, 0.79988E+00, 0.80171E+00, 0.80355E+00,& - 0.80538E+00, 0.80721E+00, 0.80904E+00, 0.81086E+00, 0.81268E+00,& - 0.81449E+00, 0.81630E+00, 0.81811E+00, 0.81992E+00, 0.82172E+00,& - 0.82352E+00, 0.82531E+00, 0.82710E+00, 0.82889E+00, 0.83068E+00,& - 0.83246E+00, 0.83424E+00, 0.83601E+00, 0.83779E+00, 0.83955E+00,& - 0.84132E+00, 0.84308E+00, 0.84484E+00, 0.84660E+00, 0.84835E+00,& - 0.85010E+00, 0.85185E+00, 0.85359E+00, 0.85533E+00, 0.85707E+00,& - 0.85880E+00, 0.86053E+00, 0.86226E+00, 0.86398E+00, 0.86570E+00,& - 0.86742E+00, 0.86914E+00, 0.87085E+00, 0.87256E+00, 0.87426E+00,& - 0.87596E+00, 0.87766E+00, 0.87936E+00, 0.88105E+00, 0.88274E+00,& - 0.88443E+00, 0.88611E+00, 0.88779E+00, 0.88947E+00, 0.89115E+00,& - 0.89282E+00, 0.89449E+00, 0.89615E+00, 0.89782E+00, 0.89948E+00,& - 0.90113E+00, 0.90279E+00, 0.90444E+00, 0.90608E+00, 0.90773E+00,& - 0.90937E+00, 0.91101E+00, 0.91265E+00, 0.91428E+00, 0.91591E+00,& - 0.91754E+00, 0.91916E+00, 0.92078E+00, 0.92240E+00, 0.92402E+00,& - 0.92563E+00, 0.92724E+00, 0.92885E+00, 0.93045E+00, 0.93205E+00,& - 0.93365E+00, 0.93525E+00, 0.93684E+00, 0.93843E+00, 0.94002E+00/ - - DATA (BNC10M (IA),IA=501,600)/ & - 0.94160E+00, 0.94318E+00, 0.94476E+00, 0.94634E+00, 0.94791E+00,& - 0.94948E+00, 0.95105E+00, 0.95261E+00, 0.95418E+00, 0.95574E+00,& - 0.95729E+00, 0.95885E+00, 0.96040E+00, 0.96195E+00, 0.96349E+00,& - 0.96504E+00, 0.96658E+00, 0.96811E+00, 0.96965E+00, 0.97118E+00,& - 0.97271E+00, 0.97424E+00, 0.97576E+00, 0.97728E+00, 0.97880E+00,& - 0.98032E+00, 0.98183E+00, 0.98334E+00, 0.98485E+00, 0.98635E+00,& - 0.98786E+00, 0.98936E+00, 0.99086E+00, 0.99235E+00, 0.99384E+00,& - 0.99533E+00, 0.99682E+00, 0.99831E+00, 0.99979E+00, 0.10013E+01,& - 0.10027E+01, 0.10042E+01, 0.10057E+01, 0.10072E+01, 0.10086E+01,& - 0.10101E+01, 0.10116E+01, 0.10130E+01, 0.10145E+01, 0.10159E+01,& - 0.10174E+01, 0.10188E+01, 0.10203E+01, 0.10217E+01, 0.10232E+01,& - 0.10246E+01, 0.10260E+01, 0.10275E+01, 0.10289E+01, 0.10303E+01,& - 0.10318E+01, 0.10332E+01, 0.10346E+01, 0.10360E+01, 0.10374E+01,& - 0.10389E+01, 0.10403E+01, 0.10417E+01, 0.10431E+01, 0.10445E+01,& - 0.10459E+01, 0.10473E+01, 0.10487E+01, 0.10501E+01, 0.10515E+01,& - 0.10529E+01, 0.10543E+01, 0.10556E+01, 0.10570E+01, 0.10584E+01,& - 0.10598E+01, 0.10612E+01, 0.10625E+01, 0.10639E+01, 0.10653E+01,& - 0.10666E+01, 0.10680E+01, 0.10694E+01, 0.10707E+01, 0.10721E+01,& - 0.10734E+01, 0.10748E+01, 0.10762E+01, 0.10775E+01, 0.10788E+01,& - 0.10802E+01, 0.10815E+01, 0.10829E+01, 0.10842E+01, 0.10892E+01/ - - DATA (BNC10M (IA),IA=601,700)/ & - 0.11001E+01, 0.11131E+01, 0.11259E+01, 0.11384E+01, 0.11508E+01,& - 0.11629E+01, 0.11749E+01, 0.11867E+01, 0.11983E+01, 0.12097E+01,& - 0.12209E+01, 0.12319E+01, 0.12428E+01, 0.12535E+01, 0.12640E+01,& - 0.12744E+01, 0.12846E+01, 0.12946E+01, 0.13045E+01, 0.13142E+01,& - 0.13238E+01, 0.13333E+01, 0.13426E+01, 0.13517E+01, 0.13607E+01,& - 0.13696E+01, 0.13784E+01, 0.13870E+01, 0.13955E+01, 0.14038E+01,& - 0.14121E+01, 0.14202E+01, 0.14282E+01, 0.14361E+01, 0.14438E+01,& - 0.14515E+01, 0.14590E+01, 0.14664E+01, 0.14738E+01, 0.14810E+01,& - 0.14881E+01, 0.14951E+01, 0.15020E+01, 0.15088E+01, 0.15155E+01,& - 0.15221E+01, 0.15286E+01, 0.15350E+01, 0.15413E+01, 0.15475E+01,& - 0.15536E+01, 0.15597E+01, 0.15656E+01, 0.15715E+01, 0.15773E+01,& - 0.15830E+01, 0.15886E+01, 0.15942E+01, 0.15996E+01, 0.16050E+01,& - 0.16103E+01, 0.16155E+01, 0.16207E+01, 0.16258E+01, 0.16308E+01,& - 0.16357E+01, 0.16406E+01, 0.16453E+01, 0.16501E+01, 0.16547E+01,& - 0.16593E+01, 0.16638E+01, 0.16682E+01, 0.16726E+01, 0.16769E+01,& - 0.16812E+01, 0.16854E+01, 0.16895E+01, 0.16936E+01, 0.16976E+01,& - 0.17015E+01, 0.17054E+01, 0.17092E+01, 0.17130E+01, 0.17167E+01,& - 0.17204E+01, 0.17240E+01, 0.17275E+01, 0.17310E+01, 0.17345E+01,& - 0.17379E+01, 0.17412E+01, 0.17445E+01, 0.17477E+01, 0.17509E+01,& - 0.17540E+01, 0.17571E+01, 0.17601E+01, 0.17631E+01, 0.17660E+01/ - - DATA (BNC10M(IA),IA=701,741)/ & - 0.17689E+01, 0.17718E+01, 0.17746E+01, 0.17773E+01, 0.17800E+01,& - 0.17827E+01, 0.17853E+01, 0.17879E+01, 0.17904E+01, 0.17929E+01,& - 0.17953E+01, 0.17977E+01, 0.18001E+01, 0.18024E+01, 0.18047E+01,& - 0.18069E+01, 0.18091E+01, 0.18113E+01, 0.18134E+01, 0.18155E+01,& - 0.18175E+01, 0.18195E+01, 0.18215E+01, 0.18234E+01, 0.18253E+01,& - 0.18271E+01, 0.18290E+01, 0.18307E+01, 0.18325E+01, 0.18342E+01,& - 0.18359E+01, 0.18375E+01, 0.18391E+01, 0.18407E+01, 0.18423E+01,& - 0.18438E+01, 0.18453E+01, 0.18467E+01, 0.18481E+01, 0.18495E+01,& - 0.18509E+01 / -! -! ** (H, Cl) -! - DATA (BNC11M (IA),IA= 1,100)/ & - -0.52529E-01,-0.88720E-01,-0.10935E+00,-0.12044E+00,-0.12697E+00,& - -0.13075E+00,-0.13267E+00,-0.13322E+00,-0.13273E+00,-0.13141E+00,& - -0.12940E+00,-0.12681E+00,-0.12374E+00,-0.12024E+00,-0.11636E+00,& - -0.11215E+00,-0.10765E+00,-0.10287E+00,-0.97853E-01,-0.92611E-01,& - -0.87164E-01,-0.81529E-01,-0.75720E-01,-0.69751E-01,-0.63632E-01,& - -0.57375E-01,-0.50988E-01,-0.44482E-01,-0.37863E-01,-0.31140E-01,& - -0.24319E-01,-0.17407E-01,-0.10411E-01,-0.33352E-02, 0.38142E-02,& - 0.11032E-01, 0.18315E-01, 0.25656E-01, 0.33053E-01, 0.40501E-01,& - 0.47996E-01, 0.55536E-01, 0.63116E-01, 0.70734E-01, 0.78387E-01,& - 0.86072E-01, 0.93788E-01, 0.10153E+00, 0.10930E+00, 0.11709E+00,& - 0.12490E+00, 0.13274E+00, 0.14059E+00, 0.14847E+00, 0.15636E+00,& - 0.16426E+00, 0.17219E+00, 0.18013E+00, 0.18808E+00, 0.19605E+00,& - 0.20404E+00, 0.21204E+00, 0.22006E+00, 0.22810E+00, 0.23615E+00,& - 0.24422E+00, 0.25232E+00, 0.26043E+00, 0.26857E+00, 0.27673E+00,& - 0.28491E+00, 0.29312E+00, 0.30136E+00, 0.30962E+00, 0.31792E+00,& - 0.32624E+00, 0.33460E+00, 0.34299E+00, 0.35142E+00, 0.35989E+00,& - 0.36839E+00, 0.37693E+00, 0.38551E+00, 0.39413E+00, 0.40279E+00,& - 0.41150E+00, 0.42024E+00, 0.42903E+00, 0.43786E+00, 0.44674E+00,& - 0.45565E+00, 0.46462E+00, 0.47362E+00, 0.48266E+00, 0.49175E+00,& - 0.50087E+00, 0.51004E+00, 0.51925E+00, 0.52849E+00, 0.53777E+00/ - - DATA (BNC11M (IA),IA=101,200)/ & - 0.54708E+00, 0.55643E+00, 0.56581E+00, 0.57522E+00, 0.58465E+00,& - 0.59412E+00, 0.60361E+00, 0.61313E+00, 0.62267E+00, 0.63222E+00,& - 0.64180E+00, 0.65140E+00, 0.66101E+00, 0.67063E+00, 0.68027E+00,& - 0.68991E+00, 0.69957E+00, 0.70923E+00, 0.71890E+00, 0.72857E+00,& - 0.73737E+00, 0.74715E+00, 0.75692E+00, 0.76668E+00, 0.77643E+00,& - 0.78617E+00, 0.79590E+00, 0.80562E+00, 0.81533E+00, 0.82502E+00,& - 0.83470E+00, 0.84437E+00, 0.85403E+00, 0.86368E+00, 0.87331E+00,& - 0.88293E+00, 0.89253E+00, 0.90212E+00, 0.91170E+00, 0.92126E+00,& - 0.93081E+00, 0.94034E+00, 0.94986E+00, 0.95936E+00, 0.96885E+00,& - 0.97833E+00, 0.98778E+00, 0.99723E+00, 0.10067E+01, 0.10161E+01,& - 0.10255E+01, 0.10348E+01, 0.10442E+01, 0.10535E+01, 0.10629E+01,& - 0.10722E+01, 0.10815E+01, 0.10908E+01, 0.11000E+01, 0.11093E+01,& - 0.11185E+01, 0.11277E+01, 0.11369E+01, 0.11461E+01, 0.11552E+01,& - 0.11644E+01, 0.11735E+01, 0.11826E+01, 0.11917E+01, 0.12008E+01,& - 0.12098E+01, 0.12189E+01, 0.12279E+01, 0.12369E+01, 0.12459E+01,& - 0.12548E+01, 0.12638E+01, 0.12727E+01, 0.12816E+01, 0.12905E+01,& - 0.12994E+01, 0.13083E+01, 0.13171E+01, 0.13259E+01, 0.13347E+01,& - 0.13435E+01, 0.13523E+01, 0.13610E+01, 0.13698E+01, 0.13785E+01,& - 0.13872E+01, 0.13958E+01, 0.14045E+01, 0.14131E+01, 0.14218E+01,& - 0.14304E+01, 0.14390E+01, 0.14475E+01, 0.14561E+01, 0.14646E+01/ - - DATA (BNC11M (IA),IA=201,300)/ & - 0.14731E+01, 0.14816E+01, 0.14901E+01, 0.14986E+01, 0.15070E+01,& - 0.15154E+01, 0.15238E+01, 0.15322E+01, 0.15406E+01, 0.15489E+01,& - 0.15573E+01, 0.15656E+01, 0.15739E+01, 0.15822E+01, 0.15904E+01,& - 0.15987E+01, 0.16069E+01, 0.16151E+01, 0.16233E+01, 0.16315E+01,& - 0.16397E+01, 0.16478E+01, 0.16559E+01, 0.16640E+01, 0.16721E+01,& - 0.16802E+01, 0.16882E+01, 0.16963E+01, 0.17043E+01, 0.17123E+01,& - 0.17203E+01, 0.17283E+01, 0.17362E+01, 0.17441E+01, 0.17521E+01,& - 0.17600E+01, 0.17678E+01, 0.17757E+01, 0.17836E+01, 0.17914E+01,& - 0.17992E+01, 0.18070E+01, 0.18148E+01, 0.18226E+01, 0.18303E+01,& - 0.18380E+01, 0.18458E+01, 0.18535E+01, 0.18611E+01, 0.18688E+01,& - 0.18765E+01, 0.18841E+01, 0.18917E+01, 0.18993E+01, 0.19069E+01,& - 0.19145E+01, 0.19220E+01, 0.19296E+01, 0.19371E+01, 0.19446E+01,& - 0.19521E+01, 0.19596E+01, 0.19670E+01, 0.19745E+01, 0.19819E+01,& - 0.19893E+01, 0.19967E+01, 0.20041E+01, 0.20114E+01, 0.20188E+01,& - 0.20261E+01, 0.20334E+01, 0.20407E+01, 0.20480E+01, 0.20553E+01,& - 0.20626E+01, 0.20698E+01, 0.20770E+01, 0.20842E+01, 0.20914E+01,& - 0.20986E+01, 0.21058E+01, 0.21129E+01, 0.21201E+01, 0.21272E+01,& - 0.21343E+01, 0.21414E+01, 0.21485E+01, 0.21555E+01, 0.21626E+01,& - 0.21696E+01, 0.21767E+01, 0.21837E+01, 0.21907E+01, 0.21976E+01,& - 0.22046E+01, 0.22115E+01, 0.22185E+01, 0.22254E+01, 0.22323E+01/ - - DATA (BNC11M (IA),IA=301,400)/ & - 0.22392E+01, 0.22461E+01, 0.22529E+01, 0.22598E+01, 0.22666E+01,& - 0.22735E+01, 0.22803E+01, 0.22871E+01, 0.22938E+01, 0.23006E+01,& - 0.23074E+01, 0.23141E+01, 0.23208E+01, 0.23276E+01, 0.23343E+01,& - 0.23409E+01, 0.23476E+01, 0.23543E+01, 0.23609E+01, 0.23676E+01,& - 0.23742E+01, 0.23808E+01, 0.23874E+01, 0.23940E+01, 0.24005E+01,& - 0.24071E+01, 0.24136E+01, 0.24202E+01, 0.24267E+01, 0.24332E+01,& - 0.24397E+01, 0.24462E+01, 0.24526E+01, 0.24591E+01, 0.24655E+01,& - 0.24719E+01, 0.24784E+01, 0.24848E+01, 0.24912E+01, 0.24975E+01,& - 0.25039E+01, 0.25103E+01, 0.25166E+01, 0.25229E+01, 0.25292E+01,& - 0.25356E+01, 0.25418E+01, 0.25481E+01, 0.25544E+01, 0.25607E+01,& - 0.25669E+01, 0.25731E+01, 0.25794E+01, 0.25856E+01, 0.25918E+01,& - 0.25979E+01, 0.26041E+01, 0.26103E+01, 0.26164E+01, 0.26226E+01,& - 0.26287E+01, 0.26348E+01, 0.26409E+01, 0.26470E+01, 0.26531E+01,& - 0.26592E+01, 0.26652E+01, 0.26713E+01, 0.26773E+01, 0.26833E+01,& - 0.26894E+01, 0.26954E+01, 0.27013E+01, 0.27073E+01, 0.27133E+01,& - 0.27193E+01, 0.27252E+01, 0.27311E+01, 0.27371E+01, 0.27430E+01,& - 0.27489E+01, 0.27548E+01, 0.27607E+01, 0.27665E+01, 0.27724E+01,& - 0.27782E+01, 0.27841E+01, 0.27899E+01, 0.27957E+01, 0.28015E+01,& - 0.28073E+01, 0.28131E+01, 0.28189E+01, 0.28247E+01, 0.28304E+01,& - 0.28362E+01, 0.28419E+01, 0.28476E+01, 0.28533E+01, 0.28590E+01/ - - DATA (BNC11M (IA),IA=401,500)/ & - 0.28647E+01, 0.28704E+01, 0.28761E+01, 0.28817E+01, 0.28874E+01,& - 0.28930E+01, 0.28987E+01, 0.29043E+01, 0.29099E+01, 0.29155E+01,& - 0.29211E+01, 0.29267E+01, 0.29323E+01, 0.29378E+01, 0.29434E+01,& - 0.29489E+01, 0.29544E+01, 0.29600E+01, 0.29655E+01, 0.29710E+01,& - 0.29765E+01, 0.29820E+01, 0.29874E+01, 0.29929E+01, 0.29984E+01,& - 0.30038E+01, 0.30093E+01, 0.30147E+01, 0.30201E+01, 0.30255E+01,& - 0.30309E+01, 0.30363E+01, 0.30417E+01, 0.30471E+01, 0.30524E+01,& - 0.30578E+01, 0.30631E+01, 0.30685E+01, 0.30738E+01, 0.30791E+01,& - 0.30844E+01, 0.30897E+01, 0.30950E+01, 0.31003E+01, 0.31056E+01,& - 0.31108E+01, 0.31161E+01, 0.31213E+01, 0.31266E+01, 0.31318E+01,& - 0.31370E+01, 0.31422E+01, 0.31474E+01, 0.31526E+01, 0.31578E+01,& - 0.31630E+01, 0.31681E+01, 0.31733E+01, 0.31785E+01, 0.31836E+01,& - 0.31887E+01, 0.31939E+01, 0.31990E+01, 0.32041E+01, 0.32092E+01,& - 0.32143E+01, 0.32194E+01, 0.32244E+01, 0.32295E+01, 0.32345E+01,& - 0.32396E+01, 0.32446E+01, 0.32497E+01, 0.32547E+01, 0.32597E+01,& - 0.32647E+01, 0.32697E+01, 0.32747E+01, 0.32797E+01, 0.32847E+01,& - 0.32896E+01, 0.32946E+01, 0.32995E+01, 0.33045E+01, 0.33094E+01,& - 0.33144E+01, 0.33193E+01, 0.33242E+01, 0.33291E+01, 0.33340E+01,& - 0.33389E+01, 0.33438E+01, 0.33486E+01, 0.33535E+01, 0.33583E+01,& - 0.33632E+01, 0.33680E+01, 0.33729E+01, 0.33777E+01, 0.33825E+01/ - - DATA (BNC11M (IA),IA=501,600)/ & - 0.33873E+01, 0.33921E+01, 0.33969E+01, 0.34017E+01, 0.34065E+01,& - 0.34113E+01, 0.34160E+01, 0.34208E+01, 0.34255E+01, 0.34303E+01,& - 0.34350E+01, 0.34398E+01, 0.34445E+01, 0.34492E+01, 0.34539E+01,& - 0.34586E+01, 0.34633E+01, 0.34680E+01, 0.34726E+01, 0.34773E+01,& - 0.34820E+01, 0.34866E+01, 0.34913E+01, 0.34959E+01, 0.35006E+01,& - 0.35052E+01, 0.35098E+01, 0.35144E+01, 0.35190E+01, 0.35236E+01,& - 0.35282E+01, 0.35328E+01, 0.35374E+01, 0.35419E+01, 0.35465E+01,& - 0.35511E+01, 0.35556E+01, 0.35602E+01, 0.35647E+01, 0.35692E+01,& - 0.35737E+01, 0.35783E+01, 0.35828E+01, 0.35873E+01, 0.35918E+01,& - 0.35963E+01, 0.36007E+01, 0.36052E+01, 0.36097E+01, 0.36141E+01,& - 0.36186E+01, 0.36230E+01, 0.36275E+01, 0.36319E+01, 0.36363E+01,& - 0.36408E+01, 0.36452E+01, 0.36496E+01, 0.36540E+01, 0.36584E+01,& - 0.36628E+01, 0.36672E+01, 0.36715E+01, 0.36759E+01, 0.36803E+01,& - 0.36846E+01, 0.36890E+01, 0.36933E+01, 0.36977E+01, 0.37020E+01,& - 0.37063E+01, 0.37106E+01, 0.37150E+01, 0.37193E+01, 0.37236E+01,& - 0.37279E+01, 0.37321E+01, 0.37364E+01, 0.37407E+01, 0.37450E+01,& - 0.37492E+01, 0.37535E+01, 0.37577E+01, 0.37620E+01, 0.37662E+01,& - 0.37704E+01, 0.37747E+01, 0.37789E+01, 0.37831E+01, 0.37873E+01,& - 0.37915E+01, 0.37957E+01, 0.37999E+01, 0.38041E+01, 0.38083E+01,& - 0.38124E+01, 0.38166E+01, 0.38208E+01, 0.38249E+01, 0.38404E+01/ - - DATA (BNC11M (IA),IA=601,700)/ & - 0.38743E+01, 0.39148E+01, 0.39548E+01, 0.39942E+01, 0.40331E+01,& - 0.40715E+01, 0.41094E+01, 0.41467E+01, 0.41836E+01, 0.42200E+01,& - 0.42560E+01, 0.42915E+01, 0.43265E+01, 0.43611E+01, 0.43953E+01,& - 0.44291E+01, 0.44624E+01, 0.44954E+01, 0.45280E+01, 0.45601E+01,& - 0.45919E+01, 0.46234E+01, 0.46544E+01, 0.46852E+01, 0.47155E+01,& - 0.47456E+01, 0.47752E+01, 0.48046E+01, 0.48336E+01, 0.48624E+01,& - 0.48908E+01, 0.49189E+01, 0.49467E+01, 0.49742E+01, 0.50014E+01,& - 0.50283E+01, 0.50550E+01, 0.50814E+01, 0.51075E+01, 0.51333E+01,& - 0.51589E+01, 0.51842E+01, 0.52093E+01, 0.52341E+01, 0.52587E+01,& - 0.52830E+01, 0.53071E+01, 0.53309E+01, 0.53546E+01, 0.53780E+01,& - 0.54011E+01, 0.54241E+01, 0.54468E+01, 0.54694E+01, 0.54917E+01,& - 0.55138E+01, 0.55357E+01, 0.55574E+01, 0.55789E+01, 0.56002E+01,& - 0.56214E+01, 0.56423E+01, 0.56630E+01, 0.56836E+01, 0.57040E+01,& - 0.57242E+01, 0.57442E+01, 0.57640E+01, 0.57837E+01, 0.58032E+01,& - 0.58226E+01, 0.58417E+01, 0.58608E+01, 0.58796E+01, 0.58983E+01,& - 0.59168E+01, 0.59352E+01, 0.59534E+01, 0.59715E+01, 0.59894E+01,& - 0.60072E+01, 0.60248E+01, 0.60423E+01, 0.60597E+01, 0.60769E+01,& - 0.60940E+01, 0.61109E+01, 0.61277E+01, 0.61444E+01, 0.61609E+01,& - 0.61773E+01, 0.61936E+01, 0.62097E+01, 0.62257E+01, 0.62416E+01,& - 0.62574E+01, 0.62731E+01, 0.62886E+01, 0.63040E+01, 0.63193E+01/ - - DATA (BNC11M(IA),IA=701,741)/ & - 0.63345E+01, 0.63496E+01, 0.63645E+01, 0.63794E+01, 0.63941E+01,& - 0.64087E+01, 0.64232E+01, 0.64376E+01, 0.64519E+01, 0.64661E+01,& - 0.64802E+01, 0.64942E+01, 0.65081E+01, 0.65218E+01, 0.65355E+01,& - 0.65491E+01, 0.65626E+01, 0.65760E+01, 0.65893E+01, 0.66025E+01,& - 0.66156E+01, 0.66286E+01, 0.66415E+01, 0.66543E+01, 0.66671E+01,& - 0.66797E+01, 0.66923E+01, 0.67047E+01, 0.67171E+01, 0.67294E+01,& - 0.67416E+01, 0.67538E+01, 0.67658E+01, 0.67778E+01, 0.67897E+01,& - 0.68015E+01, 0.68132E+01, 0.68248E+01, 0.68364E+01, 0.68479E+01,& - 0.68593E+01 / -! -! ** NaHSO4 -! - DATA (BNC12M (IA),IA= 1,100)/ & - -0.54197E-01,-0.94863E-01,-0.12098E+00,-0.13730E+00,-0.14889E+00,& - -0.15763E+00,-0.16443E+00,-0.16981E+00,-0.17410E+00,-0.17752E+00,& - -0.18023E+00,-0.18234E+00,-0.18394E+00,-0.18510E+00,-0.18586E+00,& - -0.18627E+00,-0.18636E+00,-0.18617E+00,-0.18572E+00,-0.18502E+00,& - -0.18410E+00,-0.18297E+00,-0.18165E+00,-0.18014E+00,-0.17847E+00,& - -0.17662E+00,-0.17463E+00,-0.17249E+00,-0.17021E+00,-0.16779E+00,& - -0.16525E+00,-0.16259E+00,-0.15982E+00,-0.15693E+00,-0.15394E+00,& - -0.15084E+00,-0.14765E+00,-0.14437E+00,-0.14099E+00,-0.13753E+00,& - -0.13399E+00,-0.13037E+00,-0.12667E+00,-0.12290E+00,-0.11906E+00,& - -0.11516E+00,-0.11118E+00,-0.10715E+00,-0.10306E+00,-0.98908E-01,& - -0.94703E-01,-0.90443E-01,-0.86133E-01,-0.81773E-01,-0.77365E-01,& - -0.72910E-01,-0.68410E-01,-0.63866E-01,-0.59280E-01,-0.54651E-01,& - -0.49983E-01,-0.45274E-01,-0.40525E-01,-0.35739E-01,-0.30914E-01,& - -0.26051E-01,-0.21151E-01,-0.16213E-01,-0.11239E-01,-0.62276E-02,& - -0.11793E-02, 0.39061E-02, 0.90287E-02, 0.14188E-01, 0.19386E-01,& - 0.24620E-01, 0.29893E-01, 0.35204E-01, 0.40552E-01, 0.45940E-01,& - 0.51365E-01, 0.56830E-01, 0.62333E-01, 0.67875E-01, 0.73455E-01,& - 0.79074E-01, 0.84733E-01, 0.90428E-01, 0.96163E-01, 0.10193E+00,& - 0.10774E+00, 0.11359E+00, 0.11947E+00, 0.12539E+00, 0.13134E+00,& - 0.13732E+00, 0.14334E+00, 0.14939E+00, 0.15547E+00, 0.16158E+00/ - - DATA (BNC12M (IA),IA=101,200)/ & - 0.16772E+00, 0.17388E+00, 0.18007E+00, 0.18628E+00, 0.19252E+00,& - 0.19878E+00, 0.20506E+00, 0.21136E+00, 0.21768E+00, 0.22401E+00,& - 0.23036E+00, 0.23672E+00, 0.24309E+00, 0.24947E+00, 0.25587E+00,& - 0.26227E+00, 0.26867E+00, 0.27509E+00, 0.28150E+00, 0.28793E+00,& - 0.29372E+00, 0.30022E+00, 0.30671E+00, 0.31319E+00, 0.31967E+00,& - 0.32613E+00, 0.33259E+00, 0.33904E+00, 0.34548E+00, 0.35192E+00,& - 0.35834E+00, 0.36475E+00, 0.37116E+00, 0.37755E+00, 0.38393E+00,& - 0.39031E+00, 0.39667E+00, 0.40302E+00, 0.40936E+00, 0.41569E+00,& - 0.42201E+00, 0.42832E+00, 0.43461E+00, 0.44090E+00, 0.44717E+00,& - 0.45343E+00, 0.45968E+00, 0.46592E+00, 0.47214E+00, 0.47835E+00,& - 0.48455E+00, 0.49074E+00, 0.49691E+00, 0.50307E+00, 0.50922E+00,& - 0.51536E+00, 0.52148E+00, 0.52759E+00, 0.53369E+00, 0.53978E+00,& - 0.54585E+00, 0.55191E+00, 0.55795E+00, 0.56398E+00, 0.57000E+00,& - 0.57601E+00, 0.58200E+00, 0.58798E+00, 0.59395E+00, 0.59990E+00,& - 0.60584E+00, 0.61177E+00, 0.61768E+00, 0.62358E+00, 0.62947E+00,& - 0.63534E+00, 0.64120E+00, 0.64705E+00, 0.65288E+00, 0.65870E+00,& - 0.66451E+00, 0.67030E+00, 0.67608E+00, 0.68185E+00, 0.68761E+00,& - 0.69335E+00, 0.69907E+00, 0.70479E+00, 0.71049E+00, 0.71618E+00,& - 0.72185E+00, 0.72752E+00, 0.73317E+00, 0.73880E+00, 0.74442E+00,& - 0.75003E+00, 0.75563E+00, 0.76122E+00, 0.76679E+00, 0.77235E+00/ - - DATA (BNC12M (IA),IA=201,300)/ & - 0.77789E+00, 0.78342E+00, 0.78894E+00, 0.79445E+00, 0.79995E+00,& - 0.80543E+00, 0.81090E+00, 0.81635E+00, 0.82180E+00, 0.82723E+00,& - 0.83265E+00, 0.83806E+00, 0.84345E+00, 0.84883E+00, 0.85420E+00,& - 0.85956E+00, 0.86490E+00, 0.87023E+00, 0.87556E+00, 0.88086E+00,& - 0.88616E+00, 0.89144E+00, 0.89671E+00, 0.90197E+00, 0.90722E+00,& - 0.91246E+00, 0.91768E+00, 0.92289E+00, 0.92809E+00, 0.93328E+00,& - 0.93846E+00, 0.94362E+00, 0.94878E+00, 0.95392E+00, 0.95905E+00,& - 0.96417E+00, 0.96928E+00, 0.97437E+00, 0.97946E+00, 0.98453E+00,& - 0.98959E+00, 0.99464E+00, 0.99968E+00, 0.10047E+01, 0.10097E+01,& - 0.10147E+01, 0.10197E+01, 0.10247E+01, 0.10297E+01, 0.10346E+01,& - 0.10396E+01, 0.10445E+01, 0.10495E+01, 0.10544E+01, 0.10593E+01,& - 0.10642E+01, 0.10691E+01, 0.10739E+01, 0.10788E+01, 0.10836E+01,& - 0.10885E+01, 0.10933E+01, 0.10981E+01, 0.11030E+01, 0.11078E+01,& - 0.11125E+01, 0.11173E+01, 0.11221E+01, 0.11269E+01, 0.11316E+01,& - 0.11363E+01, 0.11411E+01, 0.11458E+01, 0.11505E+01, 0.11552E+01,& - 0.11599E+01, 0.11646E+01, 0.11692E+01, 0.11739E+01, 0.11785E+01,& - 0.11832E+01, 0.11878E+01, 0.11924E+01, 0.11970E+01, 0.12016E+01,& - 0.12062E+01, 0.12108E+01, 0.12154E+01, 0.12199E+01, 0.12245E+01,& - 0.12290E+01, 0.12335E+01, 0.12381E+01, 0.12426E+01, 0.12471E+01,& - 0.12516E+01, 0.12561E+01, 0.12605E+01, 0.12650E+01, 0.12695E+01/ - - DATA (BNC12M (IA),IA=301,400)/ & - 0.12739E+01, 0.12784E+01, 0.12828E+01, 0.12872E+01, 0.12916E+01,& - 0.12960E+01, 0.13004E+01, 0.13048E+01, 0.13092E+01, 0.13135E+01,& - 0.13179E+01, 0.13222E+01, 0.13266E+01, 0.13309E+01, 0.13352E+01,& - 0.13396E+01, 0.13439E+01, 0.13482E+01, 0.13524E+01, 0.13567E+01,& - 0.13610E+01, 0.13653E+01, 0.13695E+01, 0.13738E+01, 0.13780E+01,& - 0.13822E+01, 0.13864E+01, 0.13907E+01, 0.13949E+01, 0.13990E+01,& - 0.14032E+01, 0.14074E+01, 0.14116E+01, 0.14157E+01, 0.14199E+01,& - 0.14240E+01, 0.14282E+01, 0.14323E+01, 0.14364E+01, 0.14405E+01,& - 0.14447E+01, 0.14487E+01, 0.14528E+01, 0.14569E+01, 0.14610E+01,& - 0.14651E+01, 0.14691E+01, 0.14732E+01, 0.14772E+01, 0.14812E+01,& - 0.14853E+01, 0.14893E+01, 0.14933E+01, 0.14973E+01, 0.15013E+01,& - 0.15053E+01, 0.15093E+01, 0.15132E+01, 0.15172E+01, 0.15212E+01,& - 0.15251E+01, 0.15290E+01, 0.15330E+01, 0.15369E+01, 0.15408E+01,& - 0.15447E+01, 0.15486E+01, 0.15525E+01, 0.15564E+01, 0.15603E+01,& - 0.15642E+01, 0.15681E+01, 0.15719E+01, 0.15758E+01, 0.15796E+01,& - 0.15835E+01, 0.15873E+01, 0.15911E+01, 0.15949E+01, 0.15988E+01,& - 0.16026E+01, 0.16064E+01, 0.16101E+01, 0.16139E+01, 0.16177E+01,& - 0.16215E+01, 0.16252E+01, 0.16290E+01, 0.16327E+01, 0.16365E+01,& - 0.16402E+01, 0.16439E+01, 0.16477E+01, 0.16514E+01, 0.16551E+01,& - 0.16588E+01, 0.16625E+01, 0.16662E+01, 0.16699E+01, 0.16735E+01/ - - DATA (BNC12M (IA),IA=401,500)/ & - 0.16772E+01, 0.16809E+01, 0.16845E+01, 0.16882E+01, 0.16918E+01,& - 0.16954E+01, 0.16991E+01, 0.17027E+01, 0.17063E+01, 0.17099E+01,& - 0.17135E+01, 0.17171E+01, 0.17207E+01, 0.17243E+01, 0.17279E+01,& - 0.17314E+01, 0.17350E+01, 0.17386E+01, 0.17421E+01, 0.17456E+01,& - 0.17492E+01, 0.17527E+01, 0.17562E+01, 0.17598E+01, 0.17633E+01,& - 0.17668E+01, 0.17703E+01, 0.17738E+01, 0.17773E+01, 0.17808E+01,& - 0.17842E+01, 0.17877E+01, 0.17912E+01, 0.17946E+01, 0.17981E+01,& - 0.18015E+01, 0.18050E+01, 0.18084E+01, 0.18118E+01, 0.18153E+01,& - 0.18187E+01, 0.18221E+01, 0.18255E+01, 0.18289E+01, 0.18323E+01,& - 0.18357E+01, 0.18391E+01, 0.18424E+01, 0.18458E+01, 0.18492E+01,& - 0.18525E+01, 0.18559E+01, 0.18592E+01, 0.18626E+01, 0.18659E+01,& - 0.18693E+01, 0.18726E+01, 0.18759E+01, 0.18792E+01, 0.18825E+01,& - 0.18858E+01, 0.18891E+01, 0.18924E+01, 0.18957E+01, 0.18990E+01,& - 0.19023E+01, 0.19055E+01, 0.19088E+01, 0.19121E+01, 0.19153E+01,& - 0.19186E+01, 0.19218E+01, 0.19250E+01, 0.19283E+01, 0.19315E+01,& - 0.19347E+01, 0.19379E+01, 0.19411E+01, 0.19443E+01, 0.19475E+01,& - 0.19507E+01, 0.19539E+01, 0.19571E+01, 0.19603E+01, 0.19635E+01,& - 0.19666E+01, 0.19698E+01, 0.19730E+01, 0.19761E+01, 0.19793E+01,& - 0.19824E+01, 0.19855E+01, 0.19887E+01, 0.19918E+01, 0.19949E+01,& - 0.19980E+01, 0.20012E+01, 0.20043E+01, 0.20074E+01, 0.20105E+01/ - - DATA (BNC12M (IA),IA=501,600)/ & - 0.20136E+01, 0.20166E+01, 0.20197E+01, 0.20228E+01, 0.20259E+01,& - 0.20289E+01, 0.20320E+01, 0.20351E+01, 0.20381E+01, 0.20412E+01,& - 0.20442E+01, 0.20472E+01, 0.20503E+01, 0.20533E+01, 0.20563E+01,& - 0.20593E+01, 0.20624E+01, 0.20654E+01, 0.20684E+01, 0.20714E+01,& - 0.20744E+01, 0.20774E+01, 0.20803E+01, 0.20833E+01, 0.20863E+01,& - 0.20893E+01, 0.20922E+01, 0.20952E+01, 0.20982E+01, 0.21011E+01,& - 0.21041E+01, 0.21070E+01, 0.21099E+01, 0.21129E+01, 0.21158E+01,& - 0.21187E+01, 0.21217E+01, 0.21246E+01, 0.21275E+01, 0.21304E+01,& - 0.21333E+01, 0.21362E+01, 0.21391E+01, 0.21420E+01, 0.21449E+01,& - 0.21477E+01, 0.21506E+01, 0.21535E+01, 0.21564E+01, 0.21592E+01,& - 0.21621E+01, 0.21649E+01, 0.21678E+01, 0.21706E+01, 0.21735E+01,& - 0.21763E+01, 0.21791E+01, 0.21820E+01, 0.21848E+01, 0.21876E+01,& - 0.21904E+01, 0.21932E+01, 0.21960E+01, 0.21988E+01, 0.22016E+01,& - 0.22044E+01, 0.22072E+01, 0.22100E+01, 0.22128E+01, 0.22156E+01,& - 0.22183E+01, 0.22211E+01, 0.22239E+01, 0.22266E+01, 0.22294E+01,& - 0.22321E+01, 0.22349E+01, 0.22376E+01, 0.22404E+01, 0.22431E+01,& - 0.22458E+01, 0.22486E+01, 0.22513E+01, 0.22540E+01, 0.22567E+01,& - 0.22594E+01, 0.22621E+01, 0.22648E+01, 0.22675E+01, 0.22702E+01,& - 0.22729E+01, 0.22756E+01, 0.22783E+01, 0.22810E+01, 0.22836E+01,& - 0.22863E+01, 0.22890E+01, 0.22916E+01, 0.22943E+01, 0.23042E+01/ - - DATA (BNC12M (IA),IA=601,700)/ & - 0.23259E+01, 0.23518E+01, 0.23774E+01, 0.24026E+01, 0.24274E+01,& - 0.24519E+01, 0.24761E+01, 0.24999E+01, 0.25234E+01, 0.25466E+01,& - 0.25694E+01, 0.25920E+01, 0.26142E+01, 0.26362E+01, 0.26579E+01,& - 0.26793E+01, 0.27004E+01, 0.27213E+01, 0.27419E+01, 0.27622E+01,& - 0.27823E+01, 0.28022E+01, 0.28218E+01, 0.28411E+01, 0.28602E+01,& - 0.28791E+01, 0.28978E+01, 0.29162E+01, 0.29344E+01, 0.29524E+01,& - 0.29702E+01, 0.29878E+01, 0.30052E+01, 0.30224E+01, 0.30393E+01,& - 0.30561E+01, 0.30727E+01, 0.30891E+01, 0.31054E+01, 0.31214E+01,& - 0.31373E+01, 0.31530E+01, 0.31685E+01, 0.31838E+01, 0.31990E+01,& - 0.32140E+01, 0.32289E+01, 0.32436E+01, 0.32581E+01, 0.32725E+01,& - 0.32868E+01, 0.33008E+01, 0.33148E+01, 0.33286E+01, 0.33422E+01,& - 0.33557E+01, 0.33691E+01, 0.33823E+01, 0.33954E+01, 0.34084E+01,& - 0.34212E+01, 0.34339E+01, 0.34465E+01, 0.34589E+01, 0.34712E+01,& - 0.34834E+01, 0.34955E+01, 0.35075E+01, 0.35193E+01, 0.35310E+01,& - 0.35426E+01, 0.35541E+01, 0.35655E+01, 0.35768E+01, 0.35880E+01,& - 0.35990E+01, 0.36100E+01, 0.36208E+01, 0.36316E+01, 0.36422E+01,& - 0.36527E+01, 0.36632E+01, 0.36735E+01, 0.36838E+01, 0.36939E+01,& - 0.37040E+01, 0.37139E+01, 0.37238E+01, 0.37336E+01, 0.37432E+01,& - 0.37528E+01, 0.37623E+01, 0.37718E+01, 0.37811E+01, 0.37903E+01,& - 0.37995E+01, 0.38086E+01, 0.38176E+01, 0.38265E+01, 0.38353E+01/ - - DATA (BNC12M(IA),IA=701,741)/ & - 0.38441E+01, 0.38528E+01, 0.38614E+01, 0.38699E+01, 0.38783E+01,& - 0.38867E+01, 0.38950E+01, 0.39032E+01, 0.39113E+01, 0.39194E+01,& - 0.39274E+01, 0.39353E+01, 0.39432E+01, 0.39510E+01, 0.39587E+01,& - 0.39664E+01, 0.39740E+01, 0.39815E+01, 0.39889E+01, 0.39963E+01,& - 0.40037E+01, 0.40109E+01, 0.40181E+01, 0.40253E+01, 0.40323E+01,& - 0.40393E+01, 0.40463E+01, 0.40532E+01, 0.40600E+01, 0.40668E+01,& - 0.40735E+01, 0.40802E+01, 0.40867E+01, 0.40933E+01, 0.40998E+01,& - 0.41062E+01, 0.41126E+01, 0.41189E+01, 0.41252E+01, 0.41314E+01,& - 0.41375E+01 / -! -! ** (NH4)3H(SO4)2 -! - DATA (BNC13M (IA),IA= 1,100)/ & - -0.90602E-01,-0.16542E+00,-0.21853E+00,-0.25500E+00,-0.28333E+00,& - -0.30670E+00,-0.32669E+00,-0.34420E+00,-0.35982E+00,-0.37393E+00,& - -0.38682E+00,-0.39867E+00,-0.40966E+00,-0.41990E+00,-0.42949E+00,& - -0.43851E+00,-0.44702E+00,-0.45507E+00,-0.46272E+00,-0.46998E+00,& - -0.47691E+00,-0.48352E+00,-0.48985E+00,-0.49591E+00,-0.50172E+00,& - -0.50730E+00,-0.51266E+00,-0.51782E+00,-0.52278E+00,-0.52757E+00,& - -0.53219E+00,-0.53664E+00,-0.54094E+00,-0.54510E+00,-0.54912E+00,& - -0.55300E+00,-0.55676E+00,-0.56040E+00,-0.56392E+00,-0.56733E+00,& - -0.57064E+00,-0.57384E+00,-0.57695E+00,-0.57996E+00,-0.58289E+00,& - -0.58572E+00,-0.58848E+00,-0.59115E+00,-0.59374E+00,-0.59626E+00,& - -0.59871E+00,-0.60109E+00,-0.60340E+00,-0.60565E+00,-0.60784E+00,& - -0.60996E+00,-0.61203E+00,-0.61404E+00,-0.61599E+00,-0.61790E+00,& - -0.61975E+00,-0.62155E+00,-0.62331E+00,-0.62502E+00,-0.62668E+00,& - -0.62830E+00,-0.62988E+00,-0.63142E+00,-0.63291E+00,-0.63437E+00,& - -0.63579E+00,-0.63718E+00,-0.63852E+00,-0.63984E+00,-0.64111E+00,& - -0.64236E+00,-0.64357E+00,-0.64475E+00,-0.64590E+00,-0.64702E+00,& - -0.64811E+00,-0.64917E+00,-0.65020E+00,-0.65120E+00,-0.65217E+00,& - -0.65312E+00,-0.65404E+00,-0.65494E+00,-0.65581E+00,-0.65666E+00,& - -0.65748E+00,-0.65828E+00,-0.65905E+00,-0.65980E+00,-0.66053E+00,& - -0.66124E+00,-0.66193E+00,-0.66260E+00,-0.66324E+00,-0.66387E+00/ - - DATA (BNC13M (IA),IA=101,200)/ & - -0.66448E+00,-0.66507E+00,-0.66564E+00,-0.66620E+00,-0.66674E+00,& - -0.66726E+00,-0.66777E+00,-0.66827E+00,-0.66875E+00,-0.66921E+00,& - -0.66966E+00,-0.67010E+00,-0.67053E+00,-0.67095E+00,-0.67135E+00,& - -0.67175E+00,-0.67213E+00,-0.67250E+00,-0.67287E+00,-0.67322E+00,& - -0.67369E+00,-0.67401E+00,-0.67433E+00,-0.67464E+00,-0.67495E+00,& - -0.67525E+00,-0.67554E+00,-0.67583E+00,-0.67611E+00,-0.67639E+00,& - -0.67667E+00,-0.67694E+00,-0.67720E+00,-0.67746E+00,-0.67772E+00,& - -0.67797E+00,-0.67822E+00,-0.67847E+00,-0.67871E+00,-0.67895E+00,& - -0.67919E+00,-0.67942E+00,-0.67965E+00,-0.67988E+00,-0.68011E+00,& - -0.68033E+00,-0.68055E+00,-0.68077E+00,-0.68099E+00,-0.68120E+00,& - -0.68141E+00,-0.68162E+00,-0.68183E+00,-0.68204E+00,-0.68224E+00,& - -0.68245E+00,-0.68265E+00,-0.68285E+00,-0.68305E+00,-0.68325E+00,& - -0.68345E+00,-0.68365E+00,-0.68384E+00,-0.68404E+00,-0.68423E+00,& - -0.68442E+00,-0.68462E+00,-0.68481E+00,-0.68500E+00,-0.68519E+00,& - -0.68538E+00,-0.68557E+00,-0.68576E+00,-0.68595E+00,-0.68614E+00,& - -0.68633E+00,-0.68651E+00,-0.68670E+00,-0.68689E+00,-0.68708E+00,& - -0.68727E+00,-0.68745E+00,-0.68764E+00,-0.68783E+00,-0.68802E+00,& - -0.68820E+00,-0.68839E+00,-0.68858E+00,-0.68877E+00,-0.68896E+00,& - -0.68914E+00,-0.68933E+00,-0.68952E+00,-0.68971E+00,-0.68990E+00,& - -0.69009E+00,-0.69028E+00,-0.69047E+00,-0.69066E+00,-0.69085E+00/ - - DATA (BNC13M (IA),IA=201,300)/ & - -0.69105E+00,-0.69124E+00,-0.69143E+00,-0.69162E+00,-0.69182E+00,& - -0.69201E+00,-0.69221E+00,-0.69240E+00,-0.69260E+00,-0.69280E+00,& - -0.69299E+00,-0.69319E+00,-0.69339E+00,-0.69359E+00,-0.69379E+00,& - -0.69399E+00,-0.69419E+00,-0.69439E+00,-0.69459E+00,-0.69480E+00,& - -0.69500E+00,-0.69520E+00,-0.69541E+00,-0.69561E+00,-0.69582E+00,& - -0.69603E+00,-0.69624E+00,-0.69644E+00,-0.69665E+00,-0.69686E+00,& - -0.69707E+00,-0.69729E+00,-0.69750E+00,-0.69771E+00,-0.69793E+00,& - -0.69814E+00,-0.69836E+00,-0.69857E+00,-0.69879E+00,-0.69901E+00,& - -0.69923E+00,-0.69945E+00,-0.69967E+00,-0.69989E+00,-0.70011E+00,& - -0.70034E+00,-0.70056E+00,-0.70078E+00,-0.70101E+00,-0.70124E+00,& - -0.70146E+00,-0.70169E+00,-0.70192E+00,-0.70215E+00,-0.70238E+00,& - -0.70261E+00,-0.70285E+00,-0.70308E+00,-0.70331E+00,-0.70355E+00,& - -0.70379E+00,-0.70402E+00,-0.70426E+00,-0.70450E+00,-0.70474E+00,& - -0.70498E+00,-0.70522E+00,-0.70546E+00,-0.70571E+00,-0.70595E+00,& - -0.70619E+00,-0.70644E+00,-0.70669E+00,-0.70693E+00,-0.70718E+00,& - -0.70743E+00,-0.70768E+00,-0.70793E+00,-0.70818E+00,-0.70844E+00,& - -0.70869E+00,-0.70895E+00,-0.70920E+00,-0.70946E+00,-0.70971E+00,& - -0.70997E+00,-0.71023E+00,-0.71049E+00,-0.71075E+00,-0.71101E+00,& - -0.71128E+00,-0.71154E+00,-0.71180E+00,-0.71207E+00,-0.71234E+00,& - -0.71260E+00,-0.71287E+00,-0.71314E+00,-0.71341E+00,-0.71368E+00/ - - DATA (BNC13M (IA),IA=301,400)/ & - -0.71395E+00,-0.71422E+00,-0.71450E+00,-0.71477E+00,-0.71505E+00,& - -0.71532E+00,-0.71560E+00,-0.71588E+00,-0.71615E+00,-0.71643E+00,& - -0.71671E+00,-0.71699E+00,-0.71728E+00,-0.71756E+00,-0.71784E+00,& - -0.71813E+00,-0.71841E+00,-0.71870E+00,-0.71899E+00,-0.71927E+00,& - -0.71956E+00,-0.71985E+00,-0.72014E+00,-0.72043E+00,-0.72073E+00,& - -0.72102E+00,-0.72131E+00,-0.72161E+00,-0.72190E+00,-0.72220E+00,& - -0.72250E+00,-0.72280E+00,-0.72310E+00,-0.72340E+00,-0.72370E+00,& - -0.72400E+00,-0.72430E+00,-0.72460E+00,-0.72491E+00,-0.72521E+00,& - -0.72552E+00,-0.72583E+00,-0.72613E+00,-0.72644E+00,-0.72675E+00,& - -0.72706E+00,-0.72737E+00,-0.72768E+00,-0.72799E+00,-0.72831E+00,& - -0.72862E+00,-0.72894E+00,-0.72925E+00,-0.72957E+00,-0.72989E+00,& - -0.73020E+00,-0.73052E+00,-0.73084E+00,-0.73116E+00,-0.73149E+00,& - -0.73181E+00,-0.73213E+00,-0.73245E+00,-0.73278E+00,-0.73310E+00,& - -0.73343E+00,-0.73376E+00,-0.73409E+00,-0.73441E+00,-0.73474E+00,& - -0.73507E+00,-0.73540E+00,-0.73574E+00,-0.73607E+00,-0.73640E+00,& - -0.73674E+00,-0.73707E+00,-0.73741E+00,-0.73774E+00,-0.73808E+00,& - -0.73842E+00,-0.73876E+00,-0.73910E+00,-0.73944E+00,-0.73978E+00,& - -0.74012E+00,-0.74046E+00,-0.74081E+00,-0.74115E+00,-0.74150E+00,& - -0.74184E+00,-0.74219E+00,-0.74253E+00,-0.74288E+00,-0.74323E+00,& - -0.74358E+00,-0.74393E+00,-0.74428E+00,-0.74463E+00,-0.74499E+00/ - - DATA (BNC13M (IA),IA=401,500)/ & - -0.74534E+00,-0.74569E+00,-0.74605E+00,-0.74640E+00,-0.74676E+00,& - -0.74712E+00,-0.74747E+00,-0.74783E+00,-0.74819E+00,-0.74855E+00,& - -0.74891E+00,-0.74927E+00,-0.74964E+00,-0.75000E+00,-0.75036E+00,& - -0.75073E+00,-0.75109E+00,-0.75146E+00,-0.75182E+00,-0.75219E+00,& - -0.75256E+00,-0.75293E+00,-0.75330E+00,-0.75367E+00,-0.75404E+00,& - -0.75441E+00,-0.75478E+00,-0.75515E+00,-0.75553E+00,-0.75590E+00,& - -0.75627E+00,-0.75665E+00,-0.75703E+00,-0.75740E+00,-0.75778E+00,& - -0.75816E+00,-0.75854E+00,-0.75892E+00,-0.75930E+00,-0.75968E+00,& - -0.76006E+00,-0.76044E+00,-0.76083E+00,-0.76121E+00,-0.76160E+00,& - -0.76198E+00,-0.76237E+00,-0.76275E+00,-0.76314E+00,-0.76353E+00,& - -0.76392E+00,-0.76431E+00,-0.76470E+00,-0.76509E+00,-0.76548E+00,& - -0.76587E+00,-0.76626E+00,-0.76666E+00,-0.76705E+00,-0.76744E+00,& - -0.76784E+00,-0.76824E+00,-0.76863E+00,-0.76903E+00,-0.76943E+00,& - -0.76983E+00,-0.77023E+00,-0.77063E+00,-0.77103E+00,-0.77143E+00,& - -0.77183E+00,-0.77223E+00,-0.77263E+00,-0.77304E+00,-0.77344E+00,& - -0.77385E+00,-0.77425E+00,-0.77466E+00,-0.77507E+00,-0.77547E+00,& - -0.77588E+00,-0.77629E+00,-0.77670E+00,-0.77711E+00,-0.77752E+00,& - -0.77793E+00,-0.77834E+00,-0.77876E+00,-0.77917E+00,-0.77958E+00,& - -0.78000E+00,-0.78041E+00,-0.78083E+00,-0.78124E+00,-0.78166E+00,& - -0.78208E+00,-0.78249E+00,-0.78291E+00,-0.78333E+00,-0.78375E+00/ - - DATA (BNC13M (IA),IA=501,600)/ & - -0.78417E+00,-0.78459E+00,-0.78502E+00,-0.78544E+00,-0.78586E+00,& - -0.78628E+00,-0.78671E+00,-0.78713E+00,-0.78756E+00,-0.78798E+00,& - -0.78841E+00,-0.78884E+00,-0.78926E+00,-0.78969E+00,-0.79012E+00,& - -0.79055E+00,-0.79098E+00,-0.79141E+00,-0.79184E+00,-0.79227E+00,& - -0.79271E+00,-0.79314E+00,-0.79357E+00,-0.79401E+00,-0.79444E+00,& - -0.79488E+00,-0.79531E+00,-0.79575E+00,-0.79619E+00,-0.79662E+00,& - -0.79706E+00,-0.79750E+00,-0.79794E+00,-0.79838E+00,-0.79882E+00,& - -0.79926E+00,-0.79970E+00,-0.80014E+00,-0.80058E+00,-0.80103E+00,& - -0.80147E+00,-0.80192E+00,-0.80236E+00,-0.80281E+00,-0.80325E+00,& - -0.80370E+00,-0.80414E+00,-0.80459E+00,-0.80504E+00,-0.80549E+00,& - -0.80594E+00,-0.80639E+00,-0.80684E+00,-0.80729E+00,-0.80774E+00,& - -0.80819E+00,-0.80864E+00,-0.80910E+00,-0.80955E+00,-0.81000E+00,& - -0.81046E+00,-0.81091E+00,-0.81137E+00,-0.81182E+00,-0.81228E+00,& - -0.81274E+00,-0.81320E+00,-0.81365E+00,-0.81411E+00,-0.81457E+00,& - -0.81503E+00,-0.81549E+00,-0.81595E+00,-0.81641E+00,-0.81688E+00,& - -0.81734E+00,-0.81780E+00,-0.81826E+00,-0.81873E+00,-0.81919E+00,& - -0.81966E+00,-0.82012E+00,-0.82059E+00,-0.82105E+00,-0.82152E+00,& - -0.82199E+00,-0.82246E+00,-0.82293E+00,-0.82339E+00,-0.82386E+00,& - -0.82433E+00,-0.82480E+00,-0.82528E+00,-0.82575E+00,-0.82622E+00,& - -0.82669E+00,-0.82716E+00,-0.82764E+00,-0.82811E+00,-0.82989E+00/ - - DATA (BNC13M (IA),IA=601,700)/ & - -0.83384E+00,-0.83866E+00,-0.84353E+00,-0.84845E+00,-0.85341E+00,& - -0.85841E+00,-0.86346E+00,-0.86856E+00,-0.87369E+00,-0.87886E+00,& - -0.88408E+00,-0.88933E+00,-0.89463E+00,-0.89996E+00,-0.90532E+00,& - -0.91073E+00,-0.91617E+00,-0.92164E+00,-0.92715E+00,-0.93270E+00,& - -0.93828E+00,-0.94389E+00,-0.94953E+00,-0.95520E+00,-0.96091E+00,& - -0.96664E+00,-0.97241E+00,-0.97820E+00,-0.98402E+00,-0.98987E+00,& - -0.99575E+00,-0.10017E+01,-0.10076E+01,-0.10136E+01,-0.10195E+01,& - -0.10256E+01,-0.10316E+01,-0.10377E+01,-0.10437E+01,-0.10499E+01,& - -0.10560E+01,-0.10621E+01,-0.10683E+01,-0.10745E+01,-0.10808E+01,& - -0.10870E+01,-0.10933E+01,-0.10996E+01,-0.11059E+01,-0.11122E+01,& - -0.11186E+01,-0.11249E+01,-0.11313E+01,-0.11377E+01,-0.11442E+01,& - -0.11506E+01,-0.11571E+01,-0.11636E+01,-0.11701E+01,-0.11766E+01,& - -0.11831E+01,-0.11897E+01,-0.11963E+01,-0.12028E+01,-0.12095E+01,& - -0.12161E+01,-0.12227E+01,-0.12294E+01,-0.12360E+01,-0.12427E+01,& - -0.12494E+01,-0.12561E+01,-0.12629E+01,-0.12696E+01,-0.12764E+01,& - -0.12831E+01,-0.12899E+01,-0.12967E+01,-0.13035E+01,-0.13104E+01,& - -0.13172E+01,-0.13241E+01,-0.13309E+01,-0.13378E+01,-0.13447E+01,& - -0.13516E+01,-0.13585E+01,-0.13655E+01,-0.13724E+01,-0.13794E+01,& - -0.13863E+01,-0.13933E+01,-0.14003E+01,-0.14073E+01,-0.14143E+01,& - -0.14213E+01,-0.14284E+01,-0.14354E+01,-0.14424E+01,-0.14495E+01/ - - DATA (BNC13M(IA),IA=701,741)/ & - -0.14566E+01,-0.14637E+01,-0.14708E+01,-0.14779E+01,-0.14850E+01,& - -0.14921E+01,-0.14992E+01,-0.15064E+01,-0.15135E+01,-0.15207E+01,& - -0.15279E+01,-0.15351E+01,-0.15422E+01,-0.15494E+01,-0.15567E+01,& - -0.15639E+01,-0.15711E+01,-0.15783E+01,-0.15856E+01,-0.15928E+01,& - -0.16001E+01,-0.16073E+01,-0.16146E+01,-0.16219E+01,-0.16292E+01,& - -0.16365E+01,-0.16438E+01,-0.16511E+01,-0.16584E+01,-0.16657E+01,& - -0.16731E+01,-0.16804E+01,-0.16878E+01,-0.16951E+01,-0.17025E+01,& - -0.17099E+01,-0.17172E+01,-0.17246E+01,-0.17320E+01,-0.17394E+01,& - -0.17468E+01 / -! END - -! ** TEMP = 223.0 - -! BLOCK DATA KMCF223 -! -! ** Common block definition -! -! COMMON /KMC223/ & -! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & -! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & - ! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & - ! BNC13M( 741) -! -! ** NaCl -! - DATA (BNC01M (IA),IA= 1,100)/ & - -0.53546E-01,-0.94317E-01,-0.12065E+00,-0.13711E+00,-0.14879E+00,& - -0.15760E+00,-0.16447E+00,-0.16993E+00,-0.17432E+00,-0.17787E+00,& - -0.18074E+00,-0.18305E+00,-0.18490E+00,-0.18635E+00,-0.18746E+00,& - -0.18827E+00,-0.18883E+00,-0.18916E+00,-0.18929E+00,-0.18925E+00,& - -0.18904E+00,-0.18869E+00,-0.18822E+00,-0.18763E+00,-0.18693E+00,& - -0.18614E+00,-0.18527E+00,-0.18432E+00,-0.18330E+00,-0.18222E+00,& - -0.18107E+00,-0.17988E+00,-0.17864E+00,-0.17735E+00,-0.17603E+00,& - -0.17467E+00,-0.17328E+00,-0.17186E+00,-0.17042E+00,-0.16895E+00,& - -0.16746E+00,-0.16595E+00,-0.16443E+00,-0.16289E+00,-0.16134E+00,& - -0.15977E+00,-0.15820E+00,-0.15661E+00,-0.15502E+00,-0.15342E+00,& - -0.15181E+00,-0.15020E+00,-0.14859E+00,-0.14696E+00,-0.14534E+00,& - -0.14371E+00,-0.14207E+00,-0.14043E+00,-0.13879E+00,-0.13714E+00,& - -0.13549E+00,-0.13383E+00,-0.13217E+00,-0.13051E+00,-0.12883E+00,& - -0.12716E+00,-0.12547E+00,-0.12378E+00,-0.12208E+00,-0.12038E+00,& - -0.11866E+00,-0.11694E+00,-0.11520E+00,-0.11346E+00,-0.11170E+00,& - -0.10993E+00,-0.10816E+00,-0.10636E+00,-0.10456E+00,-0.10274E+00,& - -0.10091E+00,-0.99060E-01,-0.97198E-01,-0.95320E-01,-0.93428E-01,& - -0.91520E-01,-0.89596E-01,-0.87656E-01,-0.85700E-01,-0.83729E-01,& - -0.81741E-01,-0.79737E-01,-0.77718E-01,-0.75682E-01,-0.73632E-01,& - -0.71566E-01,-0.69486E-01,-0.67391E-01,-0.65281E-01,-0.63158E-01/ - - DATA (BNC01M (IA),IA=101,200)/ & - -0.61022E-01,-0.58873E-01,-0.56711E-01,-0.54538E-01,-0.52353E-01,& - -0.50157E-01,-0.47951E-01,-0.45735E-01,-0.43510E-01,-0.41276E-01,& - -0.39034E-01,-0.36785E-01,-0.34529E-01,-0.32266E-01,-0.29997E-01,& - -0.27722E-01,-0.25443E-01,-0.23159E-01,-0.20871E-01,-0.18579E-01,& - -0.16586E-01,-0.14254E-01,-0.11922E-01,-0.95920E-02,-0.72631E-02,& - -0.49355E-02,-0.26095E-02,-0.28486E-03, 0.20382E-02, 0.43595E-02,& - 0.66792E-02, 0.89971E-02, 0.11313E-01, 0.13627E-01, 0.15940E-01,& - 0.18250E-01, 0.20558E-01, 0.22864E-01, 0.25168E-01, 0.27470E-01,& - 0.29770E-01, 0.32067E-01, 0.34362E-01, 0.36654E-01, 0.38945E-01,& - 0.41232E-01, 0.43517E-01, 0.45800E-01, 0.48080E-01, 0.50357E-01,& - 0.52632E-01, 0.54904E-01, 0.57174E-01, 0.59440E-01, 0.61704E-01,& - 0.63965E-01, 0.66223E-01, 0.68479E-01, 0.70731E-01, 0.72981E-01,& - 0.75227E-01, 0.77471E-01, 0.79711E-01, 0.81949E-01, 0.84183E-01,& - 0.86415E-01, 0.88643E-01, 0.90868E-01, 0.93091E-01, 0.95310E-01,& - 0.97525E-01, 0.99738E-01, 0.10195E+00, 0.10415E+00, 0.10636E+00,& - 0.10856E+00, 0.11075E+00, 0.11295E+00, 0.11514E+00, 0.11732E+00,& - 0.11950E+00, 0.12168E+00, 0.12386E+00, 0.12603E+00, 0.12820E+00,& - 0.13037E+00, 0.13253E+00, 0.13469E+00, 0.13685E+00, 0.13900E+00,& - 0.14115E+00, 0.14330E+00, 0.14544E+00, 0.14758E+00, 0.14971E+00,& - 0.15184E+00, 0.15397E+00, 0.15610E+00, 0.15822E+00, 0.16034E+00/ - - DATA (BNC01M (IA),IA=201,300)/ & - 0.16245E+00, 0.16456E+00, 0.16667E+00, 0.16877E+00, 0.17087E+00,& - 0.17297E+00, 0.17506E+00, 0.17715E+00, 0.17924E+00, 0.18132E+00,& - 0.18340E+00, 0.18548E+00, 0.18755E+00, 0.18962E+00, 0.19168E+00,& - 0.19374E+00, 0.19580E+00, 0.19786E+00, 0.19991E+00, 0.20195E+00,& - 0.20400E+00, 0.20604E+00, 0.20807E+00, 0.21011E+00, 0.21213E+00,& - 0.21416E+00, 0.21618E+00, 0.21820E+00, 0.22022E+00, 0.22223E+00,& - 0.22423E+00, 0.22624E+00, 0.22824E+00, 0.23024E+00, 0.23223E+00,& - 0.23422E+00, 0.23621E+00, 0.23819E+00, 0.24017E+00, 0.24214E+00,& - 0.24412E+00, 0.24608E+00, 0.24805E+00, 0.25001E+00, 0.25197E+00,& - 0.25392E+00, 0.25587E+00, 0.25782E+00, 0.25977E+00, 0.26171E+00,& - 0.26364E+00, 0.26558E+00, 0.26751E+00, 0.26943E+00, 0.27135E+00,& - 0.27327E+00, 0.27519E+00, 0.27710E+00, 0.27901E+00, 0.28092E+00,& - 0.28282E+00, 0.28472E+00, 0.28661E+00, 0.28850E+00, 0.29039E+00,& - 0.29227E+00, 0.29415E+00, 0.29603E+00, 0.29791E+00, 0.29978E+00,& - 0.30164E+00, 0.30351E+00, 0.30537E+00, 0.30722E+00, 0.30908E+00,& - 0.31093E+00, 0.31277E+00, 0.31462E+00, 0.31646E+00, 0.31829E+00,& - 0.32013E+00, 0.32196E+00, 0.32378E+00, 0.32561E+00, 0.32743E+00,& - 0.32924E+00, 0.33105E+00, 0.33286E+00, 0.33467E+00, 0.33647E+00,& - 0.33827E+00, 0.34007E+00, 0.34186E+00, 0.34365E+00, 0.34544E+00,& - 0.34722E+00, 0.34900E+00, 0.35078E+00, 0.35255E+00, 0.35432E+00/ - - DATA (BNC01M (IA),IA=301,400)/ & - 0.35608E+00, 0.35785E+00, 0.35961E+00, 0.36136E+00, 0.36312E+00,& - 0.36487E+00, 0.36661E+00, 0.36836E+00, 0.37010E+00, 0.37184E+00,& - 0.37357E+00, 0.37530E+00, 0.37703E+00, 0.37875E+00, 0.38047E+00,& - 0.38219E+00, 0.38391E+00, 0.38562E+00, 0.38733E+00, 0.38903E+00,& - 0.39073E+00, 0.39243E+00, 0.39413E+00, 0.39582E+00, 0.39751E+00,& - 0.39920E+00, 0.40088E+00, 0.40256E+00, 0.40424E+00, 0.40591E+00,& - 0.40758E+00, 0.40925E+00, 0.41092E+00, 0.41258E+00, 0.41424E+00,& - 0.41589E+00, 0.41755E+00, 0.41920E+00, 0.42084E+00, 0.42249E+00,& - 0.42413E+00, 0.42576E+00, 0.42740E+00, 0.42903E+00, 0.43066E+00,& - 0.43228E+00, 0.43391E+00, 0.43553E+00, 0.43714E+00, 0.43876E+00,& - 0.44037E+00, 0.44197E+00, 0.44358E+00, 0.44518E+00, 0.44678E+00,& - 0.44837E+00, 0.44997E+00, 0.45156E+00, 0.45315E+00, 0.45473E+00,& - 0.45631E+00, 0.45789E+00, 0.45946E+00, 0.46104E+00, 0.46261E+00,& - 0.46417E+00, 0.46574E+00, 0.46730E+00, 0.46886E+00, 0.47041E+00,& - 0.47197E+00, 0.47352E+00, 0.47506E+00, 0.47661E+00, 0.47815E+00,& - 0.47969E+00, 0.48122E+00, 0.48276E+00, 0.48429E+00, 0.48581E+00,& - 0.48734E+00, 0.48886E+00, 0.49038E+00, 0.49190E+00, 0.49341E+00,& - 0.49492E+00, 0.49643E+00, 0.49794E+00, 0.49944E+00, 0.50094E+00,& - 0.50244E+00, 0.50393E+00, 0.50542E+00, 0.50691E+00, 0.50840E+00,& - 0.50988E+00, 0.51136E+00, 0.51284E+00, 0.51432E+00, 0.51579E+00/ - - DATA (BNC01M (IA),IA=401,500)/ & - 0.51726E+00, 0.51873E+00, 0.52019E+00, 0.52166E+00, 0.52312E+00,& - 0.52457E+00, 0.52603E+00, 0.52748E+00, 0.52893E+00, 0.53038E+00,& - 0.53182E+00, 0.53326E+00, 0.53470E+00, 0.53614E+00, 0.53758E+00,& - 0.53901E+00, 0.54044E+00, 0.54186E+00, 0.54329E+00, 0.54471E+00,& - 0.54613E+00, 0.54754E+00, 0.54896E+00, 0.55037E+00, 0.55178E+00,& - 0.55318E+00, 0.55459E+00, 0.55599E+00, 0.55739E+00, 0.55878E+00,& - 0.56018E+00, 0.56157E+00, 0.56296E+00, 0.56434E+00, 0.56573E+00,& - 0.56711E+00, 0.56849E+00, 0.56987E+00, 0.57124E+00, 0.57261E+00,& - 0.57398E+00, 0.57535E+00, 0.57671E+00, 0.57808E+00, 0.57944E+00,& - 0.58079E+00, 0.58215E+00, 0.58350E+00, 0.58485E+00, 0.58620E+00,& - 0.58755E+00, 0.58889E+00, 0.59023E+00, 0.59157E+00, 0.59290E+00,& - 0.59424E+00, 0.59557E+00, 0.59690E+00, 0.59823E+00, 0.59955E+00,& - 0.60087E+00, 0.60219E+00, 0.60351E+00, 0.60483E+00, 0.60614E+00,& - 0.60745E+00, 0.60876E+00, 0.61006E+00, 0.61137E+00, 0.61267E+00,& - 0.61397E+00, 0.61527E+00, 0.61656E+00, 0.61786E+00, 0.61915E+00,& - 0.62043E+00, 0.62172E+00, 0.62300E+00, 0.62429E+00, 0.62557E+00,& - 0.62684E+00, 0.62812E+00, 0.62939E+00, 0.63066E+00, 0.63193E+00,& - 0.63320E+00, 0.63446E+00, 0.63572E+00, 0.63698E+00, 0.63824E+00,& - 0.63949E+00, 0.64075E+00, 0.64200E+00, 0.64325E+00, 0.64449E+00,& - 0.64574E+00, 0.64698E+00, 0.64822E+00, 0.64946E+00, 0.65070E+00/ - - DATA (BNC01M (IA),IA=501,600)/ & - 0.65193E+00, 0.65316E+00, 0.65439E+00, 0.65562E+00, 0.65685E+00,& - 0.65807E+00, 0.65929E+00, 0.66051E+00, 0.66173E+00, 0.66294E+00,& - 0.66416E+00, 0.66537E+00, 0.66658E+00, 0.66779E+00, 0.66899E+00,& - 0.67019E+00, 0.67139E+00, 0.67259E+00, 0.67379E+00, 0.67499E+00,& - 0.67618E+00, 0.67737E+00, 0.67856E+00, 0.67975E+00, 0.68093E+00,& - 0.68211E+00, 0.68329E+00, 0.68447E+00, 0.68565E+00, 0.68683E+00,& - 0.68800E+00, 0.68917E+00, 0.69034E+00, 0.69151E+00, 0.69267E+00,& - 0.69383E+00, 0.69500E+00, 0.69616E+00, 0.69731E+00, 0.69847E+00,& - 0.69962E+00, 0.70077E+00, 0.70192E+00, 0.70307E+00, 0.70422E+00,& - 0.70536E+00, 0.70650E+00, 0.70764E+00, 0.70878E+00, 0.70992E+00,& - 0.71105E+00, 0.71219E+00, 0.71332E+00, 0.71445E+00, 0.71557E+00,& - 0.71670E+00, 0.71782E+00, 0.71894E+00, 0.72006E+00, 0.72118E+00,& - 0.72230E+00, 0.72341E+00, 0.72452E+00, 0.72563E+00, 0.72674E+00,& - 0.72785E+00, 0.72895E+00, 0.73006E+00, 0.73116E+00, 0.73226E+00,& - 0.73335E+00, 0.73445E+00, 0.73554E+00, 0.73664E+00, 0.73773E+00,& - 0.73882E+00, 0.73990E+00, 0.74099E+00, 0.74207E+00, 0.74315E+00,& - 0.74423E+00, 0.74531E+00, 0.74639E+00, 0.74746E+00, 0.74853E+00,& - 0.74961E+00, 0.75067E+00, 0.75174E+00, 0.75281E+00, 0.75387E+00,& - 0.75493E+00, 0.75600E+00, 0.75705E+00, 0.75811E+00, 0.75917E+00,& - 0.76022E+00, 0.76127E+00, 0.76232E+00, 0.76337E+00, 0.76729E+00/ - - DATA (BNC01M (IA),IA=601,700)/ & - 0.77583E+00, 0.78602E+00, 0.79605E+00, 0.80593E+00, 0.81565E+00,& - 0.82522E+00, 0.83463E+00, 0.84391E+00, 0.85304E+00, 0.86203E+00,& - 0.87088E+00, 0.87959E+00, 0.88818E+00, 0.89663E+00, 0.90496E+00,& - 0.91316E+00, 0.92124E+00, 0.92920E+00, 0.93704E+00, 0.94477E+00,& - 0.95238E+00, 0.95988E+00, 0.96727E+00, 0.97455E+00, 0.98173E+00,& - 0.98880E+00, 0.99577E+00, 0.10026E+01, 0.10094E+01, 0.10161E+01,& - 0.10227E+01, 0.10292E+01, 0.10355E+01, 0.10418E+01, 0.10481E+01,& - 0.10542E+01, 0.10602E+01, 0.10662E+01, 0.10721E+01, 0.10778E+01,& - 0.10836E+01, 0.10892E+01, 0.10947E+01, 0.11002E+01, 0.11056E+01,& - 0.11109E+01, 0.11162E+01, 0.11213E+01, 0.11264E+01, 0.11315E+01,& - 0.11364E+01, 0.11413E+01, 0.11462E+01, 0.11509E+01, 0.11556E+01,& - 0.11603E+01, 0.11648E+01, 0.11693E+01, 0.11738E+01, 0.11782E+01,& - 0.11825E+01, 0.11867E+01, 0.11909E+01, 0.11951E+01, 0.11992E+01,& - 0.12032E+01, 0.12072E+01, 0.12111E+01, 0.12150E+01, 0.12188E+01,& - 0.12226E+01, 0.12263E+01, 0.12299E+01, 0.12335E+01, 0.12371E+01,& - 0.12406E+01, 0.12441E+01, 0.12475E+01, 0.12508E+01, 0.12542E+01,& - 0.12574E+01, 0.12607E+01, 0.12638E+01, 0.12670E+01, 0.12701E+01,& - 0.12731E+01, 0.12761E+01, 0.12791E+01, 0.12820E+01, 0.12849E+01,& - 0.12877E+01, 0.12905E+01, 0.12933E+01, 0.12960E+01, 0.12987E+01,& - 0.13013E+01, 0.13039E+01, 0.13065E+01, 0.13090E+01, 0.13115E+01/ - - DATA (BNC01M(IA),IA=701,741)/ & - 0.13139E+01, 0.13163E+01, 0.13187E+01, 0.13211E+01, 0.13234E+01,& - 0.13256E+01, 0.13279E+01, 0.13301E+01, 0.13323E+01, 0.13344E+01,& - 0.13365E+01, 0.13386E+01, 0.13406E+01, 0.13426E+01, 0.13446E+01,& - 0.13465E+01, 0.13485E+01, 0.13503E+01, 0.13522E+01, 0.13540E+01,& - 0.13558E+01, 0.13576E+01, 0.13593E+01, 0.13610E+01, 0.13627E+01,& - 0.13643E+01, 0.13660E+01, 0.13675E+01, 0.13691E+01, 0.13706E+01,& - 0.13722E+01, 0.13736E+01, 0.13751E+01, 0.13765E+01, 0.13779E+01,& - 0.13793E+01, 0.13807E+01, 0.13820E+01, 0.13833E+01, 0.13846E+01,& - 0.13858E+01 / -! -! ** Na2SO4 -! - DATA (BNC02M (IA),IA= 1,100)/ & - -0.11119E+00,-0.20367E+00,-0.26963E+00,-0.31506E+00,-0.35045E+00,& - -0.37972E+00,-0.40481E+00,-0.42685E+00,-0.44655E+00,-0.46441E+00,& - -0.48077E+00,-0.49588E+00,-0.50994E+00,-0.52310E+00,-0.53548E+00,& - -0.54717E+00,-0.55826E+00,-0.56881E+00,-0.57888E+00,-0.58852E+00,& - -0.59777E+00,-0.60666E+00,-0.61522E+00,-0.62348E+00,-0.63147E+00,& - -0.63919E+00,-0.64669E+00,-0.65396E+00,-0.66102E+00,-0.66789E+00,& - -0.67458E+00,-0.68110E+00,-0.68746E+00,-0.69367E+00,-0.69974E+00,& - -0.70567E+00,-0.71147E+00,-0.71716E+00,-0.72272E+00,-0.72818E+00,& - -0.73353E+00,-0.73878E+00,-0.74393E+00,-0.74900E+00,-0.75397E+00,& - -0.75886E+00,-0.76367E+00,-0.76841E+00,-0.77307E+00,-0.77765E+00,& - -0.78217E+00,-0.78662E+00,-0.79101E+00,-0.79534E+00,-0.79961E+00,& - -0.80382E+00,-0.80798E+00,-0.81208E+00,-0.81613E+00,-0.82013E+00,& - -0.82409E+00,-0.82799E+00,-0.83186E+00,-0.83568E+00,-0.83946E+00,& - -0.84320E+00,-0.84690E+00,-0.85056E+00,-0.85419E+00,-0.85778E+00,& - -0.86133E+00,-0.86486E+00,-0.86835E+00,-0.87181E+00,-0.87525E+00,& - -0.87865E+00,-0.88202E+00,-0.88537E+00,-0.88869E+00,-0.89199E+00,& - -0.89526E+00,-0.89851E+00,-0.90173E+00,-0.90493E+00,-0.90811E+00,& - -0.91127E+00,-0.91441E+00,-0.91753E+00,-0.92063E+00,-0.92370E+00,& - -0.92676E+00,-0.92981E+00,-0.93283E+00,-0.93584E+00,-0.93883E+00,& - -0.94180E+00,-0.94476E+00,-0.94770E+00,-0.95062E+00,-0.95353E+00/ - - DATA (BNC02M (IA),IA=101,200)/ & - -0.95642E+00,-0.95930E+00,-0.96217E+00,-0.96502E+00,-0.96786E+00,& - -0.97068E+00,-0.97349E+00,-0.97628E+00,-0.97907E+00,-0.98184E+00,& - -0.98459E+00,-0.98733E+00,-0.99007E+00,-0.99278E+00,-0.99549E+00,& - -0.99818E+00,-0.10009E+01,-0.10035E+01,-0.10062E+01,-0.10088E+01,& - -0.10114E+01,-0.10141E+01,-0.10167E+01,-0.10193E+01,-0.10219E+01,& - -0.10245E+01,-0.10270E+01,-0.10296E+01,-0.10321E+01,-0.10347E+01,& - -0.10372E+01,-0.10397E+01,-0.10422E+01,-0.10447E+01,-0.10472E+01,& - -0.10497E+01,-0.10522E+01,-0.10546E+01,-0.10571E+01,-0.10595E+01,& - -0.10620E+01,-0.10644E+01,-0.10668E+01,-0.10692E+01,-0.10716E+01,& - -0.10740E+01,-0.10764E+01,-0.10787E+01,-0.10811E+01,-0.10835E+01,& - -0.10858E+01,-0.10881E+01,-0.10905E+01,-0.10928E+01,-0.10951E+01,& - -0.10974E+01,-0.10997E+01,-0.11020E+01,-0.11043E+01,-0.11066E+01,& - -0.11088E+01,-0.11111E+01,-0.11134E+01,-0.11156E+01,-0.11179E+01,& - -0.11201E+01,-0.11223E+01,-0.11246E+01,-0.11268E+01,-0.11290E+01,& - -0.11312E+01,-0.11334E+01,-0.11356E+01,-0.11378E+01,-0.11399E+01,& - -0.11421E+01,-0.11443E+01,-0.11465E+01,-0.11486E+01,-0.11508E+01,& - -0.11529E+01,-0.11550E+01,-0.11572E+01,-0.11593E+01,-0.11614E+01,& - -0.11635E+01,-0.11657E+01,-0.11678E+01,-0.11699E+01,-0.11720E+01,& - -0.11740E+01,-0.11761E+01,-0.11782E+01,-0.11803E+01,-0.11824E+01,& - -0.11844E+01,-0.11865E+01,-0.11885E+01,-0.11906E+01,-0.11926E+01/ - - DATA (BNC02M (IA),IA=201,300)/ & - -0.11947E+01,-0.11967E+01,-0.11987E+01,-0.12008E+01,-0.12028E+01,& - -0.12048E+01,-0.12068E+01,-0.12088E+01,-0.12108E+01,-0.12128E+01,& - -0.12148E+01,-0.12168E+01,-0.12188E+01,-0.12208E+01,-0.12228E+01,& - -0.12247E+01,-0.12267E+01,-0.12287E+01,-0.12306E+01,-0.12326E+01,& - -0.12345E+01,-0.12365E+01,-0.12384E+01,-0.12404E+01,-0.12423E+01,& - -0.12443E+01,-0.12462E+01,-0.12481E+01,-0.12500E+01,-0.12520E+01,& - -0.12539E+01,-0.12558E+01,-0.12577E+01,-0.12596E+01,-0.12615E+01,& - -0.12634E+01,-0.12653E+01,-0.12672E+01,-0.12691E+01,-0.12710E+01,& - -0.12728E+01,-0.12747E+01,-0.12766E+01,-0.12785E+01,-0.12803E+01,& - -0.12822E+01,-0.12840E+01,-0.12859E+01,-0.12878E+01,-0.12896E+01,& - -0.12915E+01,-0.12933E+01,-0.12951E+01,-0.12970E+01,-0.12988E+01,& - -0.13006E+01,-0.13025E+01,-0.13043E+01,-0.13061E+01,-0.13079E+01,& - -0.13098E+01,-0.13116E+01,-0.13134E+01,-0.13152E+01,-0.13170E+01,& - -0.13188E+01,-0.13206E+01,-0.13224E+01,-0.13242E+01,-0.13260E+01,& - -0.13278E+01,-0.13296E+01,-0.13313E+01,-0.13331E+01,-0.13349E+01,& - -0.13367E+01,-0.13385E+01,-0.13402E+01,-0.13420E+01,-0.13438E+01,& - -0.13455E+01,-0.13473E+01,-0.13490E+01,-0.13508E+01,-0.13525E+01,& - -0.13543E+01,-0.13560E+01,-0.13578E+01,-0.13595E+01,-0.13613E+01,& - -0.13630E+01,-0.13647E+01,-0.13665E+01,-0.13682E+01,-0.13699E+01,& - -0.13717E+01,-0.13734E+01,-0.13751E+01,-0.13768E+01,-0.13785E+01/ - - DATA (BNC02M (IA),IA=301,400)/ & - -0.13802E+01,-0.13820E+01,-0.13837E+01,-0.13854E+01,-0.13871E+01,& - -0.13888E+01,-0.13905E+01,-0.13922E+01,-0.13939E+01,-0.13956E+01,& - -0.13973E+01,-0.13989E+01,-0.14006E+01,-0.14023E+01,-0.14040E+01,& - -0.14057E+01,-0.14074E+01,-0.14090E+01,-0.14107E+01,-0.14124E+01,& - -0.14141E+01,-0.14157E+01,-0.14174E+01,-0.14191E+01,-0.14207E+01,& - -0.14224E+01,-0.14240E+01,-0.14257E+01,-0.14274E+01,-0.14290E+01,& - -0.14307E+01,-0.14323E+01,-0.14340E+01,-0.14356E+01,-0.14372E+01,& - -0.14389E+01,-0.14405E+01,-0.14422E+01,-0.14438E+01,-0.14454E+01,& - -0.14471E+01,-0.14487E+01,-0.14503E+01,-0.14519E+01,-0.14536E+01,& - -0.14552E+01,-0.14568E+01,-0.14584E+01,-0.14601E+01,-0.14617E+01,& - -0.14633E+01,-0.14649E+01,-0.14665E+01,-0.14681E+01,-0.14697E+01,& - -0.14713E+01,-0.14729E+01,-0.14745E+01,-0.14761E+01,-0.14777E+01,& - -0.14793E+01,-0.14809E+01,-0.14825E+01,-0.14841E+01,-0.14857E+01,& - -0.14873E+01,-0.14889E+01,-0.14905E+01,-0.14921E+01,-0.14936E+01,& - -0.14952E+01,-0.14968E+01,-0.14984E+01,-0.15000E+01,-0.15015E+01,& - -0.15031E+01,-0.15047E+01,-0.15062E+01,-0.15078E+01,-0.15094E+01,& - -0.15110E+01,-0.15125E+01,-0.15141E+01,-0.15156E+01,-0.15172E+01,& - -0.15188E+01,-0.15203E+01,-0.15219E+01,-0.15234E+01,-0.15250E+01,& - -0.15265E+01,-0.15281E+01,-0.15296E+01,-0.15312E+01,-0.15327E+01,& - -0.15343E+01,-0.15358E+01,-0.15374E+01,-0.15389E+01,-0.15404E+01/ - - DATA (BNC02M (IA),IA=401,500)/ & - -0.15420E+01,-0.15435E+01,-0.15450E+01,-0.15466E+01,-0.15481E+01,& - -0.15496E+01,-0.15512E+01,-0.15527E+01,-0.15542E+01,-0.15557E+01,& - -0.15573E+01,-0.15588E+01,-0.15603E+01,-0.15618E+01,-0.15634E+01,& - -0.15649E+01,-0.15664E+01,-0.15679E+01,-0.15694E+01,-0.15709E+01,& - -0.15724E+01,-0.15740E+01,-0.15755E+01,-0.15770E+01,-0.15785E+01,& - -0.15800E+01,-0.15815E+01,-0.15830E+01,-0.15845E+01,-0.15860E+01,& - -0.15875E+01,-0.15890E+01,-0.15905E+01,-0.15920E+01,-0.15935E+01,& - -0.15950E+01,-0.15965E+01,-0.15979E+01,-0.15994E+01,-0.16009E+01,& - -0.16024E+01,-0.16039E+01,-0.16054E+01,-0.16069E+01,-0.16083E+01,& - -0.16098E+01,-0.16113E+01,-0.16128E+01,-0.16143E+01,-0.16157E+01,& - -0.16172E+01,-0.16187E+01,-0.16202E+01,-0.16216E+01,-0.16231E+01,& - -0.16246E+01,-0.16260E+01,-0.16275E+01,-0.16290E+01,-0.16305E+01,& - -0.16319E+01,-0.16334E+01,-0.16348E+01,-0.16363E+01,-0.16378E+01,& - -0.16392E+01,-0.16407E+01,-0.16421E+01,-0.16436E+01,-0.16451E+01,& - -0.16465E+01,-0.16480E+01,-0.16494E+01,-0.16509E+01,-0.16523E+01,& - -0.16538E+01,-0.16552E+01,-0.16567E+01,-0.16581E+01,-0.16596E+01,& - -0.16610E+01,-0.16624E+01,-0.16639E+01,-0.16653E+01,-0.16668E+01,& - -0.16682E+01,-0.16696E+01,-0.16711E+01,-0.16725E+01,-0.16739E+01,& - -0.16754E+01,-0.16768E+01,-0.16783E+01,-0.16797E+01,-0.16811E+01,& - -0.16825E+01,-0.16840E+01,-0.16854E+01,-0.16868E+01,-0.16883E+01/ - - DATA (BNC02M (IA),IA=501,600)/ & - -0.16897E+01,-0.16911E+01,-0.16925E+01,-0.16939E+01,-0.16954E+01,& - -0.16968E+01,-0.16982E+01,-0.16996E+01,-0.17010E+01,-0.17025E+01,& - -0.17039E+01,-0.17053E+01,-0.17067E+01,-0.17081E+01,-0.17095E+01,& - -0.17109E+01,-0.17124E+01,-0.17138E+01,-0.17152E+01,-0.17166E+01,& - -0.17180E+01,-0.17194E+01,-0.17208E+01,-0.17222E+01,-0.17236E+01,& - -0.17250E+01,-0.17264E+01,-0.17278E+01,-0.17292E+01,-0.17306E+01,& - -0.17320E+01,-0.17334E+01,-0.17348E+01,-0.17362E+01,-0.17376E+01,& - -0.17390E+01,-0.17404E+01,-0.17418E+01,-0.17432E+01,-0.17446E+01,& - -0.17460E+01,-0.17473E+01,-0.17487E+01,-0.17501E+01,-0.17515E+01,& - -0.17529E+01,-0.17543E+01,-0.17557E+01,-0.17571E+01,-0.17584E+01,& - -0.17598E+01,-0.17612E+01,-0.17626E+01,-0.17640E+01,-0.17653E+01,& - -0.17667E+01,-0.17681E+01,-0.17695E+01,-0.17709E+01,-0.17722E+01,& - -0.17736E+01,-0.17750E+01,-0.17764E+01,-0.17777E+01,-0.17791E+01,& - -0.17805E+01,-0.17818E+01,-0.17832E+01,-0.17846E+01,-0.17859E+01,& - -0.17873E+01,-0.17887E+01,-0.17900E+01,-0.17914E+01,-0.17928E+01,& - -0.17941E+01,-0.17955E+01,-0.17969E+01,-0.17982E+01,-0.17996E+01,& - -0.18009E+01,-0.18023E+01,-0.18037E+01,-0.18050E+01,-0.18064E+01,& - -0.18077E+01,-0.18091E+01,-0.18105E+01,-0.18118E+01,-0.18132E+01,& - -0.18145E+01,-0.18159E+01,-0.18172E+01,-0.18186E+01,-0.18199E+01,& - -0.18213E+01,-0.18226E+01,-0.18240E+01,-0.18253E+01,-0.18304E+01/ - - DATA (BNC02M (IA),IA=601,700)/ & - -0.18414E+01,-0.18548E+01,-0.18681E+01,-0.18813E+01,-0.18945E+01,& - -0.19076E+01,-0.19207E+01,-0.19337E+01,-0.19467E+01,-0.19596E+01,& - -0.19724E+01,-0.19852E+01,-0.19980E+01,-0.20107E+01,-0.20233E+01,& - -0.20359E+01,-0.20485E+01,-0.20610E+01,-0.20735E+01,-0.20859E+01,& - -0.20983E+01,-0.21107E+01,-0.21230E+01,-0.21353E+01,-0.21475E+01,& - -0.21598E+01,-0.21719E+01,-0.21841E+01,-0.21962E+01,-0.22082E+01,& - -0.22203E+01,-0.22323E+01,-0.22442E+01,-0.22562E+01,-0.22681E+01,& - -0.22800E+01,-0.22918E+01,-0.23036E+01,-0.23154E+01,-0.23272E+01,& - -0.23389E+01,-0.23506E+01,-0.23623E+01,-0.23740E+01,-0.23856E+01,& - -0.23972E+01,-0.24088E+01,-0.24204E+01,-0.24319E+01,-0.24434E+01,& - -0.24549E+01,-0.24663E+01,-0.24778E+01,-0.24892E+01,-0.25006E+01,& - -0.25119E+01,-0.25233E+01,-0.25346E+01,-0.25459E+01,-0.25572E+01,& - -0.25685E+01,-0.25797E+01,-0.25910E+01,-0.26022E+01,-0.26134E+01,& - -0.26245E+01,-0.26357E+01,-0.26468E+01,-0.26579E+01,-0.26690E+01,& - -0.26801E+01,-0.26912E+01,-0.27022E+01,-0.27132E+01,-0.27242E+01,& - -0.27352E+01,-0.27462E+01,-0.27572E+01,-0.27681E+01,-0.27790E+01,& - -0.27900E+01,-0.28009E+01,-0.28117E+01,-0.28226E+01,-0.28335E+01,& - -0.28443E+01,-0.28551E+01,-0.28659E+01,-0.28767E+01,-0.28875E+01,& - -0.28983E+01,-0.29090E+01,-0.29198E+01,-0.29305E+01,-0.29412E+01,& - -0.29519E+01,-0.29626E+01,-0.29733E+01,-0.29839E+01,-0.29946E+01/ - - DATA (BNC02M(IA),IA=701,741)/ & - -0.30052E+01,-0.30158E+01,-0.30264E+01,-0.30370E+01,-0.30476E+01,& - -0.30582E+01,-0.30688E+01,-0.30793E+01,-0.30899E+01,-0.31004E+01,& - -0.31109E+01,-0.31214E+01,-0.31319E+01,-0.31424E+01,-0.31529E+01,& - -0.31633E+01,-0.31738E+01,-0.31842E+01,-0.31946E+01,-0.32051E+01,& - -0.32155E+01,-0.32259E+01,-0.32363E+01,-0.32466E+01,-0.32570E+01,& - -0.32674E+01,-0.32777E+01,-0.32881E+01,-0.32984E+01,-0.33087E+01,& - -0.33190E+01,-0.33293E+01,-0.33396E+01,-0.33499E+01,-0.33602E+01,& - -0.33705E+01,-0.33807E+01,-0.33910E+01,-0.34012E+01,-0.34114E+01,& - -0.34217E+01 / -! -! ** NaNO3 -! - DATA (BNC03M (IA),IA= 1,100)/ & - -0.55791E-01,-0.10256E+00,-0.13620E+00,-0.15954E+00,-0.17783E+00,& - -0.19304E+00,-0.20616E+00,-0.21773E+00,-0.22813E+00,-0.23760E+00,& - -0.24630E+00,-0.25438E+00,-0.26192E+00,-0.26900E+00,-0.27569E+00,& - -0.28203E+00,-0.28806E+00,-0.29382E+00,-0.29933E+00,-0.30462E+00,& - -0.30971E+00,-0.31462E+00,-0.31936E+00,-0.32394E+00,-0.32838E+00,& - -0.33269E+00,-0.33687E+00,-0.34094E+00,-0.34490E+00,-0.34876E+00,& - -0.35252E+00,-0.35620E+00,-0.35979E+00,-0.36330E+00,-0.36674E+00,& - -0.37010E+00,-0.37340E+00,-0.37663E+00,-0.37979E+00,-0.38290E+00,& - -0.38596E+00,-0.38895E+00,-0.39190E+00,-0.39480E+00,-0.39764E+00,& - -0.40045E+00,-0.40320E+00,-0.40592E+00,-0.40859E+00,-0.41123E+00,& - -0.41383E+00,-0.41639E+00,-0.41891E+00,-0.42141E+00,-0.42387E+00,& - -0.42629E+00,-0.42869E+00,-0.43106E+00,-0.43340E+00,-0.43571E+00,& - -0.43799E+00,-0.44025E+00,-0.44249E+00,-0.44470E+00,-0.44689E+00,& - -0.44905E+00,-0.45120E+00,-0.45332E+00,-0.45543E+00,-0.45752E+00,& - -0.45958E+00,-0.46163E+00,-0.46367E+00,-0.46568E+00,-0.46768E+00,& - -0.46967E+00,-0.47164E+00,-0.47359E+00,-0.47554E+00,-0.47747E+00,& - -0.47938E+00,-0.48129E+00,-0.48318E+00,-0.48506E+00,-0.48693E+00,& - -0.48879E+00,-0.49064E+00,-0.49247E+00,-0.49430E+00,-0.49612E+00,& - -0.49793E+00,-0.49973E+00,-0.50152E+00,-0.50330E+00,-0.50508E+00,& - -0.50684E+00,-0.50860E+00,-0.51035E+00,-0.51209E+00,-0.51383E+00/ - - DATA (BNC03M (IA),IA=101,200)/ & - -0.51555E+00,-0.51727E+00,-0.51898E+00,-0.52069E+00,-0.52239E+00,& - -0.52408E+00,-0.52576E+00,-0.52743E+00,-0.52910E+00,-0.53077E+00,& - -0.53242E+00,-0.53407E+00,-0.53571E+00,-0.53735E+00,-0.53898E+00,& - -0.54060E+00,-0.54221E+00,-0.54382E+00,-0.54543E+00,-0.54702E+00,& - -0.54856E+00,-0.55015E+00,-0.55173E+00,-0.55331E+00,-0.55488E+00,& - -0.55644E+00,-0.55800E+00,-0.55955E+00,-0.56109E+00,-0.56263E+00,& - -0.56416E+00,-0.56568E+00,-0.56720E+00,-0.56871E+00,-0.57022E+00,& - -0.57172E+00,-0.57322E+00,-0.57471E+00,-0.57619E+00,-0.57767E+00,& - -0.57915E+00,-0.58061E+00,-0.58208E+00,-0.58353E+00,-0.58499E+00,& - -0.58643E+00,-0.58787E+00,-0.58931E+00,-0.59074E+00,-0.59217E+00,& - -0.59359E+00,-0.59501E+00,-0.59642E+00,-0.59783E+00,-0.59924E+00,& - -0.60063E+00,-0.60203E+00,-0.60342E+00,-0.60480E+00,-0.60619E+00,& - -0.60756E+00,-0.60893E+00,-0.61030E+00,-0.61167E+00,-0.61303E+00,& - -0.61438E+00,-0.61573E+00,-0.61708E+00,-0.61842E+00,-0.61976E+00,& - -0.62110E+00,-0.62243E+00,-0.62376E+00,-0.62508E+00,-0.62640E+00,& - -0.62772E+00,-0.62903E+00,-0.63034E+00,-0.63165E+00,-0.63295E+00,& - -0.63425E+00,-0.63554E+00,-0.63683E+00,-0.63812E+00,-0.63941E+00,& - -0.64069E+00,-0.64196E+00,-0.64324E+00,-0.64451E+00,-0.64578E+00,& - -0.64704E+00,-0.64830E+00,-0.64956E+00,-0.65082E+00,-0.65207E+00,& - -0.65332E+00,-0.65456E+00,-0.65580E+00,-0.65704E+00,-0.65828E+00/ - - DATA (BNC03M (IA),IA=201,300)/ & - -0.65951E+00,-0.66074E+00,-0.66197E+00,-0.66320E+00,-0.66442E+00,& - -0.66564E+00,-0.66685E+00,-0.66807E+00,-0.66928E+00,-0.67048E+00,& - -0.67169E+00,-0.67289E+00,-0.67409E+00,-0.67529E+00,-0.67648E+00,& - -0.67767E+00,-0.67886E+00,-0.68005E+00,-0.68123E+00,-0.68241E+00,& - -0.68359E+00,-0.68476E+00,-0.68594E+00,-0.68711E+00,-0.68828E+00,& - -0.68944E+00,-0.69060E+00,-0.69177E+00,-0.69292E+00,-0.69408E+00,& - -0.69523E+00,-0.69638E+00,-0.69753E+00,-0.69868E+00,-0.69983E+00,& - -0.70097E+00,-0.70211E+00,-0.70324E+00,-0.70438E+00,-0.70551E+00,& - -0.70664E+00,-0.70777E+00,-0.70890E+00,-0.71002E+00,-0.71115E+00,& - -0.71227E+00,-0.71338E+00,-0.71450E+00,-0.71561E+00,-0.71672E+00,& - -0.71783E+00,-0.71894E+00,-0.72005E+00,-0.72115E+00,-0.72225E+00,& - -0.72335E+00,-0.72445E+00,-0.72554E+00,-0.72664E+00,-0.72773E+00,& - -0.72882E+00,-0.72991E+00,-0.73099E+00,-0.73208E+00,-0.73316E+00,& - -0.73424E+00,-0.73532E+00,-0.73639E+00,-0.73747E+00,-0.73854E+00,& - -0.73961E+00,-0.74068E+00,-0.74175E+00,-0.74281E+00,-0.74388E+00,& - -0.74494E+00,-0.74600E+00,-0.74706E+00,-0.74811E+00,-0.74917E+00,& - -0.75022E+00,-0.75127E+00,-0.75232E+00,-0.75337E+00,-0.75442E+00,& - -0.75546E+00,-0.75651E+00,-0.75755E+00,-0.75859E+00,-0.75962E+00,& - -0.76066E+00,-0.76170E+00,-0.76273E+00,-0.76376E+00,-0.76479E+00,& - -0.76582E+00,-0.76685E+00,-0.76787E+00,-0.76890E+00,-0.76992E+00/ - - DATA (BNC03M (IA),IA=301,400)/ & - -0.77094E+00,-0.77196E+00,-0.77298E+00,-0.77399E+00,-0.77501E+00,& - -0.77602E+00,-0.77703E+00,-0.77804E+00,-0.77905E+00,-0.78006E+00,& - -0.78107E+00,-0.78207E+00,-0.78308E+00,-0.78408E+00,-0.78508E+00,& - -0.78608E+00,-0.78707E+00,-0.78807E+00,-0.78906E+00,-0.79006E+00,& - -0.79105E+00,-0.79204E+00,-0.79303E+00,-0.79402E+00,-0.79500E+00,& - -0.79599E+00,-0.79697E+00,-0.79796E+00,-0.79894E+00,-0.79992E+00,& - -0.80090E+00,-0.80187E+00,-0.80285E+00,-0.80382E+00,-0.80480E+00,& - -0.80577E+00,-0.80674E+00,-0.80771E+00,-0.80868E+00,-0.80965E+00,& - -0.81061E+00,-0.81158E+00,-0.81254E+00,-0.81350E+00,-0.81446E+00,& - -0.81542E+00,-0.81638E+00,-0.81734E+00,-0.81829E+00,-0.81925E+00,& - -0.82020E+00,-0.82116E+00,-0.82211E+00,-0.82306E+00,-0.82401E+00,& - -0.82496E+00,-0.82590E+00,-0.82685E+00,-0.82779E+00,-0.82874E+00,& - -0.82968E+00,-0.83062E+00,-0.83156E+00,-0.83250E+00,-0.83344E+00,& - -0.83437E+00,-0.83531E+00,-0.83624E+00,-0.83718E+00,-0.83811E+00,& - -0.83904E+00,-0.83997E+00,-0.84090E+00,-0.84183E+00,-0.84275E+00,& - -0.84368E+00,-0.84460E+00,-0.84553E+00,-0.84645E+00,-0.84737E+00,& - -0.84829E+00,-0.84921E+00,-0.85013E+00,-0.85105E+00,-0.85197E+00,& - -0.85288E+00,-0.85380E+00,-0.85471E+00,-0.85562E+00,-0.85653E+00,& - -0.85744E+00,-0.85835E+00,-0.85926E+00,-0.86017E+00,-0.86108E+00,& - -0.86198E+00,-0.86289E+00,-0.86379E+00,-0.86469E+00,-0.86560E+00/ - - DATA (BNC03M (IA),IA=401,500)/ & - -0.86650E+00,-0.86740E+00,-0.86830E+00,-0.86919E+00,-0.87009E+00,& - -0.87099E+00,-0.87188E+00,-0.87278E+00,-0.87367E+00,-0.87456E+00,& - -0.87545E+00,-0.87634E+00,-0.87723E+00,-0.87812E+00,-0.87901E+00,& - -0.87990E+00,-0.88078E+00,-0.88167E+00,-0.88255E+00,-0.88344E+00,& - -0.88432E+00,-0.88520E+00,-0.88608E+00,-0.88696E+00,-0.88784E+00,& - -0.88872E+00,-0.88960E+00,-0.89048E+00,-0.89135E+00,-0.89223E+00,& - -0.89310E+00,-0.89397E+00,-0.89485E+00,-0.89572E+00,-0.89659E+00,& - -0.89746E+00,-0.89833E+00,-0.89920E+00,-0.90006E+00,-0.90093E+00,& - -0.90180E+00,-0.90266E+00,-0.90353E+00,-0.90439E+00,-0.90525E+00,& - -0.90612E+00,-0.90698E+00,-0.90784E+00,-0.90870E+00,-0.90956E+00,& - -0.91041E+00,-0.91127E+00,-0.91213E+00,-0.91298E+00,-0.91384E+00,& - -0.91469E+00,-0.91555E+00,-0.91640E+00,-0.91725E+00,-0.91810E+00,& - -0.91895E+00,-0.91980E+00,-0.92065E+00,-0.92150E+00,-0.92235E+00,& - -0.92319E+00,-0.92404E+00,-0.92488E+00,-0.92573E+00,-0.92657E+00,& - -0.92742E+00,-0.92826E+00,-0.92910E+00,-0.92994E+00,-0.93078E+00,& - -0.93162E+00,-0.93246E+00,-0.93330E+00,-0.93413E+00,-0.93497E+00,& - -0.93581E+00,-0.93664E+00,-0.93748E+00,-0.93831E+00,-0.93914E+00,& - -0.93998E+00,-0.94081E+00,-0.94164E+00,-0.94247E+00,-0.94330E+00,& - -0.94413E+00,-0.94496E+00,-0.94578E+00,-0.94661E+00,-0.94744E+00,& - -0.94826E+00,-0.94909E+00,-0.94991E+00,-0.95074E+00,-0.95156E+00/ - - DATA (BNC03M (IA),IA=501,600)/ & - -0.95238E+00,-0.95320E+00,-0.95403E+00,-0.95485E+00,-0.95567E+00,& - -0.95649E+00,-0.95730E+00,-0.95812E+00,-0.95894E+00,-0.95976E+00,& - -0.96057E+00,-0.96139E+00,-0.96220E+00,-0.96302E+00,-0.96383E+00,& - -0.96464E+00,-0.96546E+00,-0.96627E+00,-0.96708E+00,-0.96789E+00,& - -0.96870E+00,-0.96951E+00,-0.97032E+00,-0.97113E+00,-0.97193E+00,& - -0.97274E+00,-0.97355E+00,-0.97435E+00,-0.97516E+00,-0.97596E+00,& - -0.97677E+00,-0.97757E+00,-0.97837E+00,-0.97917E+00,-0.97997E+00,& - -0.98078E+00,-0.98158E+00,-0.98238E+00,-0.98318E+00,-0.98397E+00,& - -0.98477E+00,-0.98557E+00,-0.98637E+00,-0.98716E+00,-0.98796E+00,& - -0.98875E+00,-0.98955E+00,-0.99034E+00,-0.99114E+00,-0.99193E+00,& - -0.99272E+00,-0.99351E+00,-0.99431E+00,-0.99510E+00,-0.99589E+00,& - -0.99668E+00,-0.99747E+00,-0.99825E+00,-0.99904E+00,-0.99983E+00,& - -0.10006E+01,-0.10014E+01,-0.10022E+01,-0.10030E+01,-0.10038E+01,& - -0.10045E+01,-0.10053E+01,-0.10061E+01,-0.10069E+01,-0.10077E+01,& - -0.10085E+01,-0.10092E+01,-0.10100E+01,-0.10108E+01,-0.10116E+01,& - -0.10124E+01,-0.10131E+01,-0.10139E+01,-0.10147E+01,-0.10155E+01,& - -0.10162E+01,-0.10170E+01,-0.10178E+01,-0.10186E+01,-0.10193E+01,& - -0.10201E+01,-0.10209E+01,-0.10217E+01,-0.10224E+01,-0.10232E+01,& - -0.10240E+01,-0.10248E+01,-0.10255E+01,-0.10263E+01,-0.10271E+01,& - -0.10278E+01,-0.10286E+01,-0.10294E+01,-0.10301E+01,-0.10330E+01/ - - DATA (BNC03M (IA),IA=601,700)/ & - -0.10393E+01,-0.10469E+01,-0.10545E+01,-0.10620E+01,-0.10694E+01,& - -0.10769E+01,-0.10842E+01,-0.10916E+01,-0.10989E+01,-0.11062E+01,& - -0.11134E+01,-0.11206E+01,-0.11277E+01,-0.11349E+01,-0.11420E+01,& - -0.11490E+01,-0.11560E+01,-0.11630E+01,-0.11700E+01,-0.11769E+01,& - -0.11838E+01,-0.11907E+01,-0.11976E+01,-0.12044E+01,-0.12112E+01,& - -0.12180E+01,-0.12247E+01,-0.12314E+01,-0.12381E+01,-0.12448E+01,& - -0.12514E+01,-0.12581E+01,-0.12647E+01,-0.12713E+01,-0.12778E+01,& - -0.12843E+01,-0.12909E+01,-0.12974E+01,-0.13038E+01,-0.13103E+01,& - -0.13167E+01,-0.13231E+01,-0.13295E+01,-0.13359E+01,-0.13423E+01,& - -0.13486E+01,-0.13549E+01,-0.13612E+01,-0.13675E+01,-0.13738E+01,& - -0.13800E+01,-0.13863E+01,-0.13925E+01,-0.13987E+01,-0.14049E+01,& - -0.14111E+01,-0.14172E+01,-0.14234E+01,-0.14295E+01,-0.14356E+01,& - -0.14417E+01,-0.14478E+01,-0.14539E+01,-0.14599E+01,-0.14660E+01,& - -0.14720E+01,-0.14780E+01,-0.14840E+01,-0.14900E+01,-0.14960E+01,& - -0.15020E+01,-0.15079E+01,-0.15139E+01,-0.15198E+01,-0.15257E+01,& - -0.15316E+01,-0.15375E+01,-0.15434E+01,-0.15493E+01,-0.15551E+01,& - -0.15610E+01,-0.15668E+01,-0.15727E+01,-0.15785E+01,-0.15843E+01,& - -0.15901E+01,-0.15959E+01,-0.16017E+01,-0.16074E+01,-0.16132E+01,& - -0.16189E+01,-0.16247E+01,-0.16304E+01,-0.16361E+01,-0.16418E+01,& - -0.16475E+01,-0.16532E+01,-0.16589E+01,-0.16646E+01,-0.16703E+01/ - - DATA (BNC03M(IA),IA=701,741)/ & - -0.16759E+01,-0.16816E+01,-0.16872E+01,-0.16928E+01,-0.16985E+01,& - -0.17041E+01,-0.17097E+01,-0.17153E+01,-0.17209E+01,-0.17265E+01,& - -0.17320E+01,-0.17376E+01,-0.17432E+01,-0.17487E+01,-0.17543E+01,& - -0.17598E+01,-0.17653E+01,-0.17709E+01,-0.17764E+01,-0.17819E+01,& - -0.17874E+01,-0.17929E+01,-0.17984E+01,-0.18039E+01,-0.18093E+01,& - -0.18148E+01,-0.18203E+01,-0.18257E+01,-0.18312E+01,-0.18366E+01,& - -0.18420E+01,-0.18475E+01,-0.18529E+01,-0.18583E+01,-0.18637E+01,& - -0.18691E+01,-0.18745E+01,-0.18799E+01,-0.18853E+01,-0.18907E+01,& - -0.18960E+01 / -! -! ** (NH4)2SO4 -! - DATA (BNC04M (IA),IA= 1,100)/ & - -0.11131E+00,-0.20410E+00,-0.27045E+00,-0.31626E+00,-0.35200E+00,& - -0.38161E+00,-0.40704E+00,-0.42941E+00,-0.44944E+00,-0.46762E+00,& - -0.48429E+00,-0.49971E+00,-0.51407E+00,-0.52753E+00,-0.54020E+00,& - -0.55219E+00,-0.56357E+00,-0.57441E+00,-0.58476E+00,-0.59468E+00,& - -0.60421E+00,-0.61337E+00,-0.62220E+00,-0.63073E+00,-0.63898E+00,& - -0.64698E+00,-0.65473E+00,-0.66226E+00,-0.66958E+00,-0.67670E+00,& - -0.68364E+00,-0.69041E+00,-0.69701E+00,-0.70347E+00,-0.70977E+00,& - -0.71594E+00,-0.72198E+00,-0.72789E+00,-0.73369E+00,-0.73937E+00,& - -0.74495E+00,-0.75042E+00,-0.75579E+00,-0.76107E+00,-0.76627E+00,& - -0.77137E+00,-0.77639E+00,-0.78133E+00,-0.78620E+00,-0.79099E+00,& - -0.79571E+00,-0.80036E+00,-0.80495E+00,-0.80947E+00,-0.81393E+00,& - -0.81834E+00,-0.82268E+00,-0.82697E+00,-0.83121E+00,-0.83540E+00,& - -0.83954E+00,-0.84363E+00,-0.84768E+00,-0.85168E+00,-0.85563E+00,& - -0.85955E+00,-0.86343E+00,-0.86727E+00,-0.87107E+00,-0.87483E+00,& - -0.87856E+00,-0.88226E+00,-0.88592E+00,-0.88956E+00,-0.89316E+00,& - -0.89673E+00,-0.90027E+00,-0.90379E+00,-0.90728E+00,-0.91075E+00,& - -0.91419E+00,-0.91760E+00,-0.92099E+00,-0.92436E+00,-0.92771E+00,& - -0.93104E+00,-0.93434E+00,-0.93763E+00,-0.94089E+00,-0.94414E+00,& - -0.94737E+00,-0.95058E+00,-0.95377E+00,-0.95694E+00,-0.96010E+00,& - -0.96324E+00,-0.96636E+00,-0.96947E+00,-0.97256E+00,-0.97564E+00/ - - DATA (BNC04M (IA),IA=101,200)/ & - -0.97870E+00,-0.98175E+00,-0.98478E+00,-0.98780E+00,-0.99081E+00,& - -0.99380E+00,-0.99677E+00,-0.99974E+00,-0.10027E+01,-0.10056E+01,& - -0.10085E+01,-0.10115E+01,-0.10144E+01,-0.10172E+01,-0.10201E+01,& - -0.10230E+01,-0.10258E+01,-0.10286E+01,-0.10315E+01,-0.10343E+01,& - -0.10370E+01,-0.10398E+01,-0.10426E+01,-0.10454E+01,-0.10481E+01,& - -0.10509E+01,-0.10536E+01,-0.10563E+01,-0.10590E+01,-0.10617E+01,& - -0.10644E+01,-0.10671E+01,-0.10698E+01,-0.10724E+01,-0.10751E+01,& - -0.10777E+01,-0.10803E+01,-0.10830E+01,-0.10856E+01,-0.10882E+01,& - -0.10908E+01,-0.10933E+01,-0.10959E+01,-0.10985E+01,-0.11010E+01,& - -0.11036E+01,-0.11061E+01,-0.11086E+01,-0.11111E+01,-0.11136E+01,& - -0.11161E+01,-0.11186E+01,-0.11211E+01,-0.11236E+01,-0.11260E+01,& - -0.11285E+01,-0.11309E+01,-0.11334E+01,-0.11358E+01,-0.11382E+01,& - -0.11406E+01,-0.11431E+01,-0.11455E+01,-0.11479E+01,-0.11502E+01,& - -0.11526E+01,-0.11550E+01,-0.11574E+01,-0.11597E+01,-0.11621E+01,& - -0.11644E+01,-0.11668E+01,-0.11691E+01,-0.11714E+01,-0.11737E+01,& - -0.11761E+01,-0.11784E+01,-0.11807E+01,-0.11830E+01,-0.11852E+01,& - -0.11875E+01,-0.11898E+01,-0.11921E+01,-0.11943E+01,-0.11966E+01,& - -0.11988E+01,-0.12011E+01,-0.12033E+01,-0.12056E+01,-0.12078E+01,& - -0.12100E+01,-0.12122E+01,-0.12144E+01,-0.12166E+01,-0.12189E+01,& - -0.12210E+01,-0.12232E+01,-0.12254E+01,-0.12276E+01,-0.12298E+01/ - - DATA (BNC04M (IA),IA=201,300)/ & - -0.12319E+01,-0.12341E+01,-0.12363E+01,-0.12384E+01,-0.12406E+01,& - -0.12427E+01,-0.12449E+01,-0.12470E+01,-0.12491E+01,-0.12513E+01,& - -0.12534E+01,-0.12555E+01,-0.12576E+01,-0.12597E+01,-0.12618E+01,& - -0.12639E+01,-0.12660E+01,-0.12681E+01,-0.12702E+01,-0.12723E+01,& - -0.12743E+01,-0.12764E+01,-0.12785E+01,-0.12805E+01,-0.12826E+01,& - -0.12847E+01,-0.12867E+01,-0.12888E+01,-0.12908E+01,-0.12928E+01,& - -0.12949E+01,-0.12969E+01,-0.12989E+01,-0.13010E+01,-0.13030E+01,& - -0.13050E+01,-0.13070E+01,-0.13090E+01,-0.13110E+01,-0.13130E+01,& - -0.13150E+01,-0.13170E+01,-0.13190E+01,-0.13210E+01,-0.13230E+01,& - -0.13249E+01,-0.13269E+01,-0.13289E+01,-0.13309E+01,-0.13328E+01,& - -0.13348E+01,-0.13367E+01,-0.13387E+01,-0.13406E+01,-0.13426E+01,& - -0.13445E+01,-0.13465E+01,-0.13484E+01,-0.13504E+01,-0.13523E+01,& - -0.13542E+01,-0.13561E+01,-0.13581E+01,-0.13600E+01,-0.13619E+01,& - -0.13638E+01,-0.13657E+01,-0.13676E+01,-0.13695E+01,-0.13714E+01,& - -0.13733E+01,-0.13752E+01,-0.13771E+01,-0.13790E+01,-0.13809E+01,& - -0.13828E+01,-0.13846E+01,-0.13865E+01,-0.13884E+01,-0.13903E+01,& - -0.13921E+01,-0.13940E+01,-0.13958E+01,-0.13977E+01,-0.13996E+01,& - -0.14014E+01,-0.14033E+01,-0.14051E+01,-0.14070E+01,-0.14088E+01,& - -0.14106E+01,-0.14125E+01,-0.14143E+01,-0.14162E+01,-0.14180E+01,& - -0.14198E+01,-0.14216E+01,-0.14235E+01,-0.14253E+01,-0.14271E+01/ - - DATA (BNC04M (IA),IA=301,400)/ & - -0.14289E+01,-0.14307E+01,-0.14325E+01,-0.14343E+01,-0.14361E+01,& - -0.14379E+01,-0.14397E+01,-0.14415E+01,-0.14433E+01,-0.14451E+01,& - -0.14469E+01,-0.14487E+01,-0.14505E+01,-0.14523E+01,-0.14541E+01,& - -0.14558E+01,-0.14576E+01,-0.14594E+01,-0.14612E+01,-0.14629E+01,& - -0.14647E+01,-0.14665E+01,-0.14682E+01,-0.14700E+01,-0.14717E+01,& - -0.14735E+01,-0.14752E+01,-0.14770E+01,-0.14787E+01,-0.14805E+01,& - -0.14822E+01,-0.14840E+01,-0.14857E+01,-0.14875E+01,-0.14892E+01,& - -0.14909E+01,-0.14927E+01,-0.14944E+01,-0.14961E+01,-0.14979E+01,& - -0.14996E+01,-0.15013E+01,-0.15030E+01,-0.15047E+01,-0.15065E+01,& - -0.15082E+01,-0.15099E+01,-0.15116E+01,-0.15133E+01,-0.15150E+01,& - -0.15167E+01,-0.15184E+01,-0.15201E+01,-0.15218E+01,-0.15235E+01,& - -0.15252E+01,-0.15269E+01,-0.15286E+01,-0.15303E+01,-0.15320E+01,& - -0.15337E+01,-0.15353E+01,-0.15370E+01,-0.15387E+01,-0.15404E+01,& - -0.15421E+01,-0.15437E+01,-0.15454E+01,-0.15471E+01,-0.15488E+01,& - -0.15504E+01,-0.15521E+01,-0.15538E+01,-0.15554E+01,-0.15571E+01,& - -0.15587E+01,-0.15604E+01,-0.15620E+01,-0.15637E+01,-0.15654E+01,& - -0.15670E+01,-0.15687E+01,-0.15703E+01,-0.15720E+01,-0.15736E+01,& - -0.15752E+01,-0.15769E+01,-0.15785E+01,-0.15802E+01,-0.15818E+01,& - -0.15834E+01,-0.15851E+01,-0.15867E+01,-0.15883E+01,-0.15900E+01,& - -0.15916E+01,-0.15932E+01,-0.15948E+01,-0.15965E+01,-0.15981E+01/ - - DATA (BNC04M (IA),IA=401,500)/ & - -0.15997E+01,-0.16013E+01,-0.16029E+01,-0.16045E+01,-0.16062E+01,& - -0.16078E+01,-0.16094E+01,-0.16110E+01,-0.16126E+01,-0.16142E+01,& - -0.16158E+01,-0.16174E+01,-0.16190E+01,-0.16206E+01,-0.16222E+01,& - -0.16238E+01,-0.16254E+01,-0.16270E+01,-0.16286E+01,-0.16302E+01,& - -0.16318E+01,-0.16334E+01,-0.16349E+01,-0.16365E+01,-0.16381E+01,& - -0.16397E+01,-0.16413E+01,-0.16429E+01,-0.16444E+01,-0.16460E+01,& - -0.16476E+01,-0.16492E+01,-0.16507E+01,-0.16523E+01,-0.16539E+01,& - -0.16555E+01,-0.16570E+01,-0.16586E+01,-0.16602E+01,-0.16617E+01,& - -0.16633E+01,-0.16648E+01,-0.16664E+01,-0.16680E+01,-0.16695E+01,& - -0.16711E+01,-0.16726E+01,-0.16742E+01,-0.16757E+01,-0.16773E+01,& - -0.16788E+01,-0.16804E+01,-0.16819E+01,-0.16835E+01,-0.16850E+01,& - -0.16866E+01,-0.16881E+01,-0.16897E+01,-0.16912E+01,-0.16928E+01,& - -0.16943E+01,-0.16958E+01,-0.16974E+01,-0.16989E+01,-0.17004E+01,& - -0.17020E+01,-0.17035E+01,-0.17050E+01,-0.17066E+01,-0.17081E+01,& - -0.17096E+01,-0.17111E+01,-0.17127E+01,-0.17142E+01,-0.17157E+01,& - -0.17172E+01,-0.17187E+01,-0.17203E+01,-0.17218E+01,-0.17233E+01,& - -0.17248E+01,-0.17263E+01,-0.17278E+01,-0.17294E+01,-0.17309E+01,& - -0.17324E+01,-0.17339E+01,-0.17354E+01,-0.17369E+01,-0.17384E+01,& - -0.17399E+01,-0.17414E+01,-0.17429E+01,-0.17444E+01,-0.17459E+01,& - -0.17474E+01,-0.17489E+01,-0.17504E+01,-0.17519E+01,-0.17534E+01/ - - DATA (BNC04M (IA),IA=501,600)/ & - -0.17549E+01,-0.17564E+01,-0.17579E+01,-0.17594E+01,-0.17609E+01,& - -0.17623E+01,-0.17638E+01,-0.17653E+01,-0.17668E+01,-0.17683E+01,& - -0.17698E+01,-0.17713E+01,-0.17727E+01,-0.17742E+01,-0.17757E+01,& - -0.17772E+01,-0.17787E+01,-0.17801E+01,-0.17816E+01,-0.17831E+01,& - -0.17846E+01,-0.17860E+01,-0.17875E+01,-0.17890E+01,-0.17904E+01,& - -0.17919E+01,-0.17934E+01,-0.17948E+01,-0.17963E+01,-0.17978E+01,& - -0.17992E+01,-0.18007E+01,-0.18022E+01,-0.18036E+01,-0.18051E+01,& - -0.18065E+01,-0.18080E+01,-0.18095E+01,-0.18109E+01,-0.18124E+01,& - -0.18138E+01,-0.18153E+01,-0.18167E+01,-0.18182E+01,-0.18196E+01,& - -0.18211E+01,-0.18225E+01,-0.18240E+01,-0.18254E+01,-0.18269E+01,& - -0.18283E+01,-0.18298E+01,-0.18312E+01,-0.18327E+01,-0.18341E+01,& - -0.18356E+01,-0.18370E+01,-0.18384E+01,-0.18399E+01,-0.18413E+01,& - -0.18427E+01,-0.18442E+01,-0.18456E+01,-0.18471E+01,-0.18485E+01,& - -0.18499E+01,-0.18514E+01,-0.18528E+01,-0.18542E+01,-0.18556E+01,& - -0.18571E+01,-0.18585E+01,-0.18599E+01,-0.18614E+01,-0.18628E+01,& - -0.18642E+01,-0.18656E+01,-0.18671E+01,-0.18685E+01,-0.18699E+01,& - -0.18713E+01,-0.18727E+01,-0.18742E+01,-0.18756E+01,-0.18770E+01,& - -0.18784E+01,-0.18798E+01,-0.18812E+01,-0.18827E+01,-0.18841E+01,& - -0.18855E+01,-0.18869E+01,-0.18883E+01,-0.18897E+01,-0.18911E+01,& - -0.18925E+01,-0.18940E+01,-0.18954E+01,-0.18968E+01,-0.19020E+01/ - - DATA (BNC04M (IA),IA=601,700)/ & - -0.19136E+01,-0.19275E+01,-0.19414E+01,-0.19552E+01,-0.19689E+01,& - -0.19826E+01,-0.19962E+01,-0.20097E+01,-0.20232E+01,-0.20366E+01,& - -0.20500E+01,-0.20633E+01,-0.20766E+01,-0.20897E+01,-0.21029E+01,& - -0.21160E+01,-0.21290E+01,-0.21420E+01,-0.21550E+01,-0.21679E+01,& - -0.21807E+01,-0.21935E+01,-0.22063E+01,-0.22190E+01,-0.22317E+01,& - -0.22443E+01,-0.22569E+01,-0.22695E+01,-0.22820E+01,-0.22945E+01,& - -0.23069E+01,-0.23193E+01,-0.23317E+01,-0.23440E+01,-0.23563E+01,& - -0.23686E+01,-0.23808E+01,-0.23930E+01,-0.24052E+01,-0.24173E+01,& - -0.24294E+01,-0.24415E+01,-0.24535E+01,-0.24655E+01,-0.24775E+01,& - -0.24895E+01,-0.25014E+01,-0.25133E+01,-0.25252E+01,-0.25370E+01,& - -0.25488E+01,-0.25606E+01,-0.25724E+01,-0.25841E+01,-0.25959E+01,& - -0.26076E+01,-0.26192E+01,-0.26309E+01,-0.26425E+01,-0.26541E+01,& - -0.26657E+01,-0.26772E+01,-0.26887E+01,-0.27002E+01,-0.27117E+01,& - -0.27232E+01,-0.27346E+01,-0.27461E+01,-0.27575E+01,-0.27688E+01,& - -0.27802E+01,-0.27915E+01,-0.28029E+01,-0.28142E+01,-0.28255E+01,& - -0.28367E+01,-0.28480E+01,-0.28592E+01,-0.28704E+01,-0.28816E+01,& - -0.28928E+01,-0.29039E+01,-0.29151E+01,-0.29262E+01,-0.29373E+01,& - -0.29484E+01,-0.29595E+01,-0.29705E+01,-0.29816E+01,-0.29926E+01,& - -0.30036E+01,-0.30146E+01,-0.30256E+01,-0.30366E+01,-0.30475E+01,& - -0.30585E+01,-0.30694E+01,-0.30803E+01,-0.30912E+01,-0.31021E+01/ - - DATA (BNC04M(IA),IA=701,741)/ & - -0.31129E+01,-0.31238E+01,-0.31346E+01,-0.31454E+01,-0.31562E+01,& - -0.31670E+01,-0.31778E+01,-0.31886E+01,-0.31993E+01,-0.32101E+01,& - -0.32208E+01,-0.32315E+01,-0.32423E+01,-0.32529E+01,-0.32636E+01,& - -0.32743E+01,-0.32850E+01,-0.32956E+01,-0.33062E+01,-0.33169E+01,& - -0.33275E+01,-0.33381E+01,-0.33487E+01,-0.33592E+01,-0.33698E+01,& - -0.33804E+01,-0.33909E+01,-0.34015E+01,-0.34120E+01,-0.34225E+01,& - -0.34330E+01,-0.34435E+01,-0.34540E+01,-0.34644E+01,-0.34749E+01,& - -0.34854E+01,-0.34958E+01,-0.35062E+01,-0.35166E+01,-0.35271E+01,& - -0.35375E+01 / -! -! ** NH4NO3 -! - DATA (BNC05M (IA),IA= 1,100)/ & - -0.56573E-01,-0.10548E+00,-0.14176E+00,-0.16761E+00,-0.18833E+00,& - -0.20590E+00,-0.22130E+00,-0.23513E+00,-0.24773E+00,-0.25937E+00,& - -0.27021E+00,-0.28039E+00,-0.29000E+00,-0.29914E+00,-0.30784E+00,& - -0.31618E+00,-0.32419E+00,-0.33189E+00,-0.33933E+00,-0.34653E+00,& - -0.35350E+00,-0.36027E+00,-0.36685E+00,-0.37326E+00,-0.37950E+00,& - -0.38559E+00,-0.39153E+00,-0.39735E+00,-0.40303E+00,-0.40860E+00,& - -0.41405E+00,-0.41939E+00,-0.42463E+00,-0.42977E+00,-0.43481E+00,& - -0.43977E+00,-0.44464E+00,-0.44943E+00,-0.45413E+00,-0.45876E+00,& - -0.46332E+00,-0.46780E+00,-0.47221E+00,-0.47656E+00,-0.48084E+00,& - -0.48506E+00,-0.48922E+00,-0.49332E+00,-0.49737E+00,-0.50136E+00,& - -0.50529E+00,-0.50918E+00,-0.51301E+00,-0.51680E+00,-0.52054E+00,& - -0.52424E+00,-0.52790E+00,-0.53151E+00,-0.53508E+00,-0.53861E+00,& - -0.54211E+00,-0.54557E+00,-0.54899E+00,-0.55239E+00,-0.55575E+00,& - -0.55908E+00,-0.56238E+00,-0.56565E+00,-0.56890E+00,-0.57212E+00,& - -0.57531E+00,-0.57848E+00,-0.58163E+00,-0.58476E+00,-0.58787E+00,& - -0.59096E+00,-0.59403E+00,-0.59708E+00,-0.60011E+00,-0.60313E+00,& - -0.60614E+00,-0.60912E+00,-0.61210E+00,-0.61506E+00,-0.61801E+00,& - -0.62095E+00,-0.62387E+00,-0.62678E+00,-0.62969E+00,-0.63258E+00,& - -0.63546E+00,-0.63833E+00,-0.64120E+00,-0.64405E+00,-0.64689E+00,& - -0.64973E+00,-0.65255E+00,-0.65537E+00,-0.65818E+00,-0.66098E+00/ - - DATA (BNC05M (IA),IA=101,200)/ & - -0.66377E+00,-0.66655E+00,-0.66933E+00,-0.67209E+00,-0.67485E+00,& - -0.67760E+00,-0.68034E+00,-0.68307E+00,-0.68579E+00,-0.68850E+00,& - -0.69121E+00,-0.69390E+00,-0.69659E+00,-0.69927E+00,-0.70194E+00,& - -0.70459E+00,-0.70724E+00,-0.70988E+00,-0.71251E+00,-0.71514E+00,& - -0.71759E+00,-0.72021E+00,-0.72282E+00,-0.72542E+00,-0.72800E+00,& - -0.73058E+00,-0.73314E+00,-0.73570E+00,-0.73824E+00,-0.74077E+00,& - -0.74329E+00,-0.74580E+00,-0.74830E+00,-0.75079E+00,-0.75327E+00,& - -0.75574E+00,-0.75821E+00,-0.76066E+00,-0.76310E+00,-0.76553E+00,& - -0.76795E+00,-0.77036E+00,-0.77277E+00,-0.77516E+00,-0.77755E+00,& - -0.77992E+00,-0.78229E+00,-0.78465E+00,-0.78700E+00,-0.78934E+00,& - -0.79167E+00,-0.79400E+00,-0.79631E+00,-0.79862E+00,-0.80092E+00,& - -0.80321E+00,-0.80549E+00,-0.80776E+00,-0.81003E+00,-0.81229E+00,& - -0.81454E+00,-0.81678E+00,-0.81901E+00,-0.82124E+00,-0.82346E+00,& - -0.82567E+00,-0.82787E+00,-0.83007E+00,-0.83226E+00,-0.83444E+00,& - -0.83661E+00,-0.83878E+00,-0.84094E+00,-0.84309E+00,-0.84524E+00,& - -0.84738E+00,-0.84951E+00,-0.85163E+00,-0.85375E+00,-0.85586E+00,& - -0.85797E+00,-0.86006E+00,-0.86215E+00,-0.86424E+00,-0.86632E+00,& - -0.86839E+00,-0.87045E+00,-0.87251E+00,-0.87456E+00,-0.87661E+00,& - -0.87865E+00,-0.88068E+00,-0.88271E+00,-0.88473E+00,-0.88675E+00,& - -0.88876E+00,-0.89076E+00,-0.89276E+00,-0.89475E+00,-0.89673E+00/ - - DATA (BNC05M (IA),IA=201,300)/ & - -0.89871E+00,-0.90068E+00,-0.90265E+00,-0.90462E+00,-0.90657E+00,& - -0.90852E+00,-0.91047E+00,-0.91241E+00,-0.91434E+00,-0.91627E+00,& - -0.91819E+00,-0.92011E+00,-0.92202E+00,-0.92393E+00,-0.92583E+00,& - -0.92773E+00,-0.92962E+00,-0.93151E+00,-0.93339E+00,-0.93526E+00,& - -0.93713E+00,-0.93900E+00,-0.94086E+00,-0.94272E+00,-0.94457E+00,& - -0.94641E+00,-0.94825E+00,-0.95009E+00,-0.95192E+00,-0.95375E+00,& - -0.95557E+00,-0.95738E+00,-0.95920E+00,-0.96100E+00,-0.96281E+00,& - -0.96460E+00,-0.96640E+00,-0.96818E+00,-0.96997E+00,-0.97175E+00,& - -0.97352E+00,-0.97529E+00,-0.97706E+00,-0.97882E+00,-0.98058E+00,& - -0.98233E+00,-0.98408E+00,-0.98582E+00,-0.98756E+00,-0.98930E+00,& - -0.99103E+00,-0.99276E+00,-0.99448E+00,-0.99620E+00,-0.99791E+00,& - -0.99962E+00,-0.10013E+01,-0.10030E+01,-0.10047E+01,-0.10064E+01,& - -0.10081E+01,-0.10098E+01,-0.10115E+01,-0.10132E+01,-0.10148E+01,& - -0.10165E+01,-0.10182E+01,-0.10198E+01,-0.10215E+01,-0.10231E+01,& - -0.10248E+01,-0.10264E+01,-0.10281E+01,-0.10297E+01,-0.10314E+01,& - -0.10330E+01,-0.10346E+01,-0.10363E+01,-0.10379E+01,-0.10395E+01,& - -0.10411E+01,-0.10427E+01,-0.10443E+01,-0.10459E+01,-0.10475E+01,& - -0.10491E+01,-0.10507E+01,-0.10523E+01,-0.10539E+01,-0.10555E+01,& - -0.10571E+01,-0.10586E+01,-0.10602E+01,-0.10618E+01,-0.10633E+01,& - -0.10649E+01,-0.10665E+01,-0.10680E+01,-0.10696E+01,-0.10711E+01/ - - DATA (BNC05M (IA),IA=301,400)/ & - -0.10727E+01,-0.10742E+01,-0.10757E+01,-0.10773E+01,-0.10788E+01,& - -0.10803E+01,-0.10819E+01,-0.10834E+01,-0.10849E+01,-0.10864E+01,& - -0.10879E+01,-0.10895E+01,-0.10910E+01,-0.10925E+01,-0.10940E+01,& - -0.10955E+01,-0.10970E+01,-0.10985E+01,-0.10999E+01,-0.11014E+01,& - -0.11029E+01,-0.11044E+01,-0.11059E+01,-0.11073E+01,-0.11088E+01,& - -0.11103E+01,-0.11118E+01,-0.11132E+01,-0.11147E+01,-0.11161E+01,& - -0.11176E+01,-0.11190E+01,-0.11205E+01,-0.11219E+01,-0.11234E+01,& - -0.11248E+01,-0.11263E+01,-0.11277E+01,-0.11291E+01,-0.11306E+01,& - -0.11320E+01,-0.11334E+01,-0.11348E+01,-0.11363E+01,-0.11377E+01,& - -0.11391E+01,-0.11405E+01,-0.11419E+01,-0.11433E+01,-0.11447E+01,& - -0.11461E+01,-0.11475E+01,-0.11489E+01,-0.11503E+01,-0.11517E+01,& - -0.11531E+01,-0.11545E+01,-0.11559E+01,-0.11572E+01,-0.11586E+01,& - -0.11600E+01,-0.11614E+01,-0.11627E+01,-0.11641E+01,-0.11655E+01,& - -0.11668E+01,-0.11682E+01,-0.11696E+01,-0.11709E+01,-0.11723E+01,& - -0.11736E+01,-0.11750E+01,-0.11763E+01,-0.11777E+01,-0.11790E+01,& - -0.11804E+01,-0.11817E+01,-0.11830E+01,-0.11844E+01,-0.11857E+01,& - -0.11870E+01,-0.11884E+01,-0.11897E+01,-0.11910E+01,-0.11923E+01,& - -0.11936E+01,-0.11950E+01,-0.11963E+01,-0.11976E+01,-0.11989E+01,& - -0.12002E+01,-0.12015E+01,-0.12028E+01,-0.12041E+01,-0.12054E+01,& - -0.12067E+01,-0.12080E+01,-0.12093E+01,-0.12106E+01,-0.12119E+01/ - - DATA (BNC05M (IA),IA=401,500)/ & - -0.12132E+01,-0.12144E+01,-0.12157E+01,-0.12170E+01,-0.12183E+01,& - -0.12196E+01,-0.12208E+01,-0.12221E+01,-0.12234E+01,-0.12246E+01,& - -0.12259E+01,-0.12272E+01,-0.12284E+01,-0.12297E+01,-0.12310E+01,& - -0.12322E+01,-0.12335E+01,-0.12347E+01,-0.12360E+01,-0.12372E+01,& - -0.12385E+01,-0.12397E+01,-0.12409E+01,-0.12422E+01,-0.12434E+01,& - -0.12447E+01,-0.12459E+01,-0.12471E+01,-0.12484E+01,-0.12496E+01,& - -0.12508E+01,-0.12520E+01,-0.12533E+01,-0.12545E+01,-0.12557E+01,& - -0.12569E+01,-0.12581E+01,-0.12594E+01,-0.12606E+01,-0.12618E+01,& - -0.12630E+01,-0.12642E+01,-0.12654E+01,-0.12666E+01,-0.12678E+01,& - -0.12690E+01,-0.12702E+01,-0.12714E+01,-0.12726E+01,-0.12738E+01,& - -0.12750E+01,-0.12762E+01,-0.12774E+01,-0.12786E+01,-0.12797E+01,& - -0.12809E+01,-0.12821E+01,-0.12833E+01,-0.12845E+01,-0.12856E+01,& - -0.12868E+01,-0.12880E+01,-0.12892E+01,-0.12903E+01,-0.12915E+01,& - -0.12927E+01,-0.12938E+01,-0.12950E+01,-0.12962E+01,-0.12973E+01,& - -0.12985E+01,-0.12996E+01,-0.13008E+01,-0.13020E+01,-0.13031E+01,& - -0.13043E+01,-0.13054E+01,-0.13066E+01,-0.13077E+01,-0.13088E+01,& - -0.13100E+01,-0.13111E+01,-0.13123E+01,-0.13134E+01,-0.13146E+01,& - -0.13157E+01,-0.13168E+01,-0.13180E+01,-0.13191E+01,-0.13202E+01,& - -0.13213E+01,-0.13225E+01,-0.13236E+01,-0.13247E+01,-0.13258E+01,& - -0.13270E+01,-0.13281E+01,-0.13292E+01,-0.13303E+01,-0.13314E+01/ - - DATA (BNC05M (IA),IA=501,600)/ & - -0.13325E+01,-0.13337E+01,-0.13348E+01,-0.13359E+01,-0.13370E+01,& - -0.13381E+01,-0.13392E+01,-0.13403E+01,-0.13414E+01,-0.13425E+01,& - -0.13436E+01,-0.13447E+01,-0.13458E+01,-0.13469E+01,-0.13480E+01,& - -0.13491E+01,-0.13502E+01,-0.13513E+01,-0.13524E+01,-0.13534E+01,& - -0.13545E+01,-0.13556E+01,-0.13567E+01,-0.13578E+01,-0.13589E+01,& - -0.13599E+01,-0.13610E+01,-0.13621E+01,-0.13632E+01,-0.13643E+01,& - -0.13653E+01,-0.13664E+01,-0.13675E+01,-0.13685E+01,-0.13696E+01,& - -0.13707E+01,-0.13717E+01,-0.13728E+01,-0.13739E+01,-0.13749E+01,& - -0.13760E+01,-0.13770E+01,-0.13781E+01,-0.13792E+01,-0.13802E+01,& - -0.13813E+01,-0.13823E+01,-0.13834E+01,-0.13844E+01,-0.13855E+01,& - -0.13865E+01,-0.13876E+01,-0.13886E+01,-0.13897E+01,-0.13907E+01,& - -0.13917E+01,-0.13928E+01,-0.13938E+01,-0.13949E+01,-0.13959E+01,& - -0.13969E+01,-0.13980E+01,-0.13990E+01,-0.14000E+01,-0.14011E+01,& - -0.14021E+01,-0.14031E+01,-0.14042E+01,-0.14052E+01,-0.14062E+01,& - -0.14072E+01,-0.14083E+01,-0.14093E+01,-0.14103E+01,-0.14113E+01,& - -0.14123E+01,-0.14134E+01,-0.14144E+01,-0.14154E+01,-0.14164E+01,& - -0.14174E+01,-0.14184E+01,-0.14194E+01,-0.14205E+01,-0.14215E+01,& - -0.14225E+01,-0.14235E+01,-0.14245E+01,-0.14255E+01,-0.14265E+01,& - -0.14275E+01,-0.14285E+01,-0.14295E+01,-0.14305E+01,-0.14315E+01,& - -0.14325E+01,-0.14335E+01,-0.14345E+01,-0.14355E+01,-0.14392E+01/ - - DATA (BNC05M (IA),IA=601,700)/ & - -0.14473E+01,-0.14571E+01,-0.14668E+01,-0.14763E+01,-0.14858E+01,& - -0.14952E+01,-0.15045E+01,-0.15137E+01,-0.15229E+01,-0.15319E+01,& - -0.15409E+01,-0.15498E+01,-0.15586E+01,-0.15674E+01,-0.15761E+01,& - -0.15847E+01,-0.15933E+01,-0.16017E+01,-0.16102E+01,-0.16185E+01,& - -0.16268E+01,-0.16351E+01,-0.16433E+01,-0.16514E+01,-0.16595E+01,& - -0.16675E+01,-0.16754E+01,-0.16834E+01,-0.16912E+01,-0.16990E+01,& - -0.17068E+01,-0.17145E+01,-0.17222E+01,-0.17298E+01,-0.17374E+01,& - -0.17450E+01,-0.17525E+01,-0.17599E+01,-0.17674E+01,-0.17747E+01,& - -0.17821E+01,-0.17894E+01,-0.17967E+01,-0.18039E+01,-0.18111E+01,& - -0.18182E+01,-0.18254E+01,-0.18325E+01,-0.18395E+01,-0.18466E+01,& - -0.18535E+01,-0.18605E+01,-0.18674E+01,-0.18743E+01,-0.18812E+01,& - -0.18881E+01,-0.18949E+01,-0.19017E+01,-0.19084E+01,-0.19152E+01,& - -0.19219E+01,-0.19285E+01,-0.19352E+01,-0.19418E+01,-0.19484E+01,& - -0.19550E+01,-0.19616E+01,-0.19681E+01,-0.19746E+01,-0.19811E+01,& - -0.19876E+01,-0.19940E+01,-0.20004E+01,-0.20068E+01,-0.20132E+01,& - -0.20196E+01,-0.20259E+01,-0.20322E+01,-0.20385E+01,-0.20448E+01,& - -0.20510E+01,-0.20573E+01,-0.20635E+01,-0.20697E+01,-0.20759E+01,& - -0.20821E+01,-0.20882E+01,-0.20943E+01,-0.21005E+01,-0.21066E+01,& - -0.21126E+01,-0.21187E+01,-0.21247E+01,-0.21308E+01,-0.21368E+01,& - -0.21428E+01,-0.21488E+01,-0.21548E+01,-0.21607E+01,-0.21667E+01/ - - DATA (BNC05M(IA),IA=701,741)/ & - -0.21726E+01,-0.21785E+01,-0.21844E+01,-0.21903E+01,-0.21962E+01,& - -0.22020E+01,-0.22079E+01,-0.22137E+01,-0.22195E+01,-0.22253E+01,& - -0.22311E+01,-0.22369E+01,-0.22427E+01,-0.22484E+01,-0.22542E+01,& - -0.22599E+01,-0.22656E+01,-0.22714E+01,-0.22771E+01,-0.22827E+01,& - -0.22884E+01,-0.22941E+01,-0.22997E+01,-0.23054E+01,-0.23110E+01,& - -0.23167E+01,-0.23223E+01,-0.23279E+01,-0.23335E+01,-0.23390E+01,& - -0.23446E+01,-0.23502E+01,-0.23557E+01,-0.23613E+01,-0.23668E+01,& - -0.23723E+01,-0.23779E+01,-0.23834E+01,-0.23889E+01,-0.23944E+01,& - -0.23998E+01 / -! -! ** NH4Cl -! - DATA (BNC06M (IA),IA= 1,100)/ & - -0.54668E-01,-0.98406E-01,-0.12832E+00,-0.14814E+00,-0.16306E+00,& - -0.17499E+00,-0.18490E+00,-0.19335E+00,-0.20067E+00,-0.20712E+00,& - -0.21285E+00,-0.21799E+00,-0.22263E+00,-0.22685E+00,-0.23071E+00,& - -0.23426E+00,-0.23752E+00,-0.24054E+00,-0.24335E+00,-0.24596E+00,& - -0.24839E+00,-0.25066E+00,-0.25280E+00,-0.25480E+00,-0.25668E+00,& - -0.25846E+00,-0.26014E+00,-0.26172E+00,-0.26322E+00,-0.26464E+00,& - -0.26599E+00,-0.26728E+00,-0.26850E+00,-0.26967E+00,-0.27078E+00,& - -0.27184E+00,-0.27286E+00,-0.27383E+00,-0.27477E+00,-0.27566E+00,& - -0.27653E+00,-0.27736E+00,-0.27815E+00,-0.27892E+00,-0.27966E+00,& - -0.28038E+00,-0.28107E+00,-0.28174E+00,-0.28239E+00,-0.28302E+00,& - -0.28363E+00,-0.28422E+00,-0.28479E+00,-0.28535E+00,-0.28588E+00,& - -0.28641E+00,-0.28692E+00,-0.28741E+00,-0.28789E+00,-0.28836E+00,& - -0.28882E+00,-0.28926E+00,-0.28969E+00,-0.29010E+00,-0.29051E+00,& - -0.29090E+00,-0.29128E+00,-0.29165E+00,-0.29201E+00,-0.29235E+00,& - -0.29269E+00,-0.29301E+00,-0.29332E+00,-0.29362E+00,-0.29390E+00,& - -0.29418E+00,-0.29444E+00,-0.29470E+00,-0.29494E+00,-0.29517E+00,& - -0.29538E+00,-0.29559E+00,-0.29578E+00,-0.29597E+00,-0.29614E+00,& - -0.29630E+00,-0.29645E+00,-0.29659E+00,-0.29671E+00,-0.29683E+00,& - -0.29694E+00,-0.29703E+00,-0.29711E+00,-0.29719E+00,-0.29725E+00,& - -0.29731E+00,-0.29735E+00,-0.29739E+00,-0.29741E+00,-0.29743E+00/ - - DATA (BNC06M (IA),IA=101,200)/ & - -0.29744E+00,-0.29744E+00,-0.29743E+00,-0.29741E+00,-0.29739E+00,& - -0.29736E+00,-0.29732E+00,-0.29727E+00,-0.29722E+00,-0.29716E+00,& - -0.29710E+00,-0.29703E+00,-0.29695E+00,-0.29687E+00,-0.29678E+00,& - -0.29669E+00,-0.29660E+00,-0.29650E+00,-0.29639E+00,-0.29628E+00,& - -0.29628E+00,-0.29615E+00,-0.29602E+00,-0.29589E+00,-0.29576E+00,& - -0.29562E+00,-0.29548E+00,-0.29534E+00,-0.29520E+00,-0.29506E+00,& - -0.29491E+00,-0.29477E+00,-0.29462E+00,-0.29447E+00,-0.29432E+00,& - -0.29417E+00,-0.29402E+00,-0.29386E+00,-0.29371E+00,-0.29355E+00,& - -0.29339E+00,-0.29323E+00,-0.29308E+00,-0.29291E+00,-0.29275E+00,& - -0.29259E+00,-0.29243E+00,-0.29226E+00,-0.29210E+00,-0.29193E+00,& - -0.29177E+00,-0.29160E+00,-0.29143E+00,-0.29127E+00,-0.29110E+00,& - -0.29093E+00,-0.29076E+00,-0.29059E+00,-0.29042E+00,-0.29025E+00,& - -0.29008E+00,-0.28990E+00,-0.28973E+00,-0.28956E+00,-0.28939E+00,& - -0.28921E+00,-0.28904E+00,-0.28887E+00,-0.28869E+00,-0.28852E+00,& - -0.28835E+00,-0.28817E+00,-0.28800E+00,-0.28782E+00,-0.28765E+00,& - -0.28747E+00,-0.28730E+00,-0.28712E+00,-0.28695E+00,-0.28677E+00,& - -0.28660E+00,-0.28642E+00,-0.28625E+00,-0.28607E+00,-0.28590E+00,& - -0.28572E+00,-0.28555E+00,-0.28537E+00,-0.28520E+00,-0.28502E+00,& - -0.28485E+00,-0.28468E+00,-0.28450E+00,-0.28433E+00,-0.28415E+00,& - -0.28398E+00,-0.28381E+00,-0.28363E+00,-0.28346E+00,-0.28329E+00/ - - DATA (BNC06M (IA),IA=201,300)/ & - -0.28312E+00,-0.28295E+00,-0.28277E+00,-0.28260E+00,-0.28243E+00,& - -0.28226E+00,-0.28209E+00,-0.28192E+00,-0.28175E+00,-0.28158E+00,& - -0.28141E+00,-0.28124E+00,-0.28107E+00,-0.28090E+00,-0.28074E+00,& - -0.28057E+00,-0.28040E+00,-0.28023E+00,-0.28007E+00,-0.27990E+00,& - -0.27974E+00,-0.27957E+00,-0.27941E+00,-0.27924E+00,-0.27908E+00,& - -0.27892E+00,-0.27875E+00,-0.27859E+00,-0.27843E+00,-0.27827E+00,& - -0.27810E+00,-0.27794E+00,-0.27778E+00,-0.27762E+00,-0.27746E+00,& - -0.27731E+00,-0.27715E+00,-0.27699E+00,-0.27683E+00,-0.27667E+00,& - -0.27652E+00,-0.27636E+00,-0.27621E+00,-0.27605E+00,-0.27590E+00,& - -0.27574E+00,-0.27559E+00,-0.27544E+00,-0.27529E+00,-0.27513E+00,& - -0.27498E+00,-0.27483E+00,-0.27468E+00,-0.27453E+00,-0.27438E+00,& - -0.27424E+00,-0.27409E+00,-0.27394E+00,-0.27379E+00,-0.27365E+00,& - -0.27350E+00,-0.27336E+00,-0.27321E+00,-0.27307E+00,-0.27292E+00,& - -0.27278E+00,-0.27264E+00,-0.27250E+00,-0.27236E+00,-0.27222E+00,& - -0.27208E+00,-0.27194E+00,-0.27180E+00,-0.27166E+00,-0.27152E+00,& - -0.27139E+00,-0.27125E+00,-0.27111E+00,-0.27098E+00,-0.27084E+00,& - -0.27071E+00,-0.27058E+00,-0.27044E+00,-0.27031E+00,-0.27018E+00,& - -0.27005E+00,-0.26992E+00,-0.26979E+00,-0.26966E+00,-0.26953E+00,& - -0.26940E+00,-0.26927E+00,-0.26915E+00,-0.26902E+00,-0.26890E+00,& - -0.26877E+00,-0.26865E+00,-0.26852E+00,-0.26840E+00,-0.26828E+00/ - - DATA (BNC06M (IA),IA=301,400)/ & - -0.26815E+00,-0.26803E+00,-0.26791E+00,-0.26779E+00,-0.26767E+00,& - -0.26755E+00,-0.26744E+00,-0.26732E+00,-0.26720E+00,-0.26708E+00,& - -0.26697E+00,-0.26685E+00,-0.26674E+00,-0.26662E+00,-0.26651E+00,& - -0.26640E+00,-0.26629E+00,-0.26617E+00,-0.26606E+00,-0.26595E+00,& - -0.26584E+00,-0.26573E+00,-0.26563E+00,-0.26552E+00,-0.26541E+00,& - -0.26530E+00,-0.26520E+00,-0.26509E+00,-0.26499E+00,-0.26488E+00,& - -0.26478E+00,-0.26468E+00,-0.26457E+00,-0.26447E+00,-0.26437E+00,& - -0.26427E+00,-0.26417E+00,-0.26407E+00,-0.26397E+00,-0.26387E+00,& - -0.26378E+00,-0.26368E+00,-0.26358E+00,-0.26349E+00,-0.26339E+00,& - -0.26330E+00,-0.26320E+00,-0.26311E+00,-0.26302E+00,-0.26293E+00,& - -0.26284E+00,-0.26274E+00,-0.26265E+00,-0.26256E+00,-0.26248E+00,& - -0.26239E+00,-0.26230E+00,-0.26221E+00,-0.26213E+00,-0.26204E+00,& - -0.26195E+00,-0.26187E+00,-0.26178E+00,-0.26170E+00,-0.26162E+00,& - -0.26154E+00,-0.26145E+00,-0.26137E+00,-0.26129E+00,-0.26121E+00,& - -0.26113E+00,-0.26105E+00,-0.26098E+00,-0.26090E+00,-0.26082E+00,& - -0.26074E+00,-0.26067E+00,-0.26059E+00,-0.26052E+00,-0.26044E+00,& - -0.26037E+00,-0.26030E+00,-0.26023E+00,-0.26015E+00,-0.26008E+00,& - -0.26001E+00,-0.25994E+00,-0.25987E+00,-0.25980E+00,-0.25973E+00,& - -0.25967E+00,-0.25960E+00,-0.25953E+00,-0.25947E+00,-0.25940E+00,& - -0.25934E+00,-0.25927E+00,-0.25921E+00,-0.25915E+00,-0.25908E+00/ - - DATA (BNC06M (IA),IA=401,500)/ & - -0.25902E+00,-0.25896E+00,-0.25890E+00,-0.25884E+00,-0.25878E+00,& - -0.25872E+00,-0.25866E+00,-0.25860E+00,-0.25855E+00,-0.25849E+00,& - -0.25843E+00,-0.25838E+00,-0.25832E+00,-0.25827E+00,-0.25821E+00,& - -0.25816E+00,-0.25811E+00,-0.25805E+00,-0.25800E+00,-0.25795E+00,& - -0.25790E+00,-0.25785E+00,-0.25780E+00,-0.25775E+00,-0.25770E+00,& - -0.25765E+00,-0.25761E+00,-0.25756E+00,-0.25751E+00,-0.25747E+00,& - -0.25742E+00,-0.25738E+00,-0.25733E+00,-0.25729E+00,-0.25725E+00,& - -0.25721E+00,-0.25716E+00,-0.25712E+00,-0.25708E+00,-0.25704E+00,& - -0.25700E+00,-0.25696E+00,-0.25692E+00,-0.25688E+00,-0.25685E+00,& - -0.25681E+00,-0.25677E+00,-0.25674E+00,-0.25670E+00,-0.25667E+00,& - -0.25663E+00,-0.25660E+00,-0.25656E+00,-0.25653E+00,-0.25650E+00,& - -0.25647E+00,-0.25644E+00,-0.25640E+00,-0.25637E+00,-0.25634E+00,& - -0.25632E+00,-0.25629E+00,-0.25626E+00,-0.25623E+00,-0.25620E+00,& - -0.25618E+00,-0.25615E+00,-0.25612E+00,-0.25610E+00,-0.25608E+00,& - -0.25605E+00,-0.25603E+00,-0.25600E+00,-0.25598E+00,-0.25596E+00,& - -0.25594E+00,-0.25592E+00,-0.25590E+00,-0.25588E+00,-0.25586E+00,& - -0.25584E+00,-0.25582E+00,-0.25580E+00,-0.25578E+00,-0.25577E+00,& - -0.25575E+00,-0.25573E+00,-0.25572E+00,-0.25570E+00,-0.25569E+00,& - -0.25567E+00,-0.25566E+00,-0.25565E+00,-0.25563E+00,-0.25562E+00,& - -0.25561E+00,-0.25560E+00,-0.25559E+00,-0.25558E+00,-0.25557E+00/ - - DATA (BNC06M (IA),IA=501,600)/ & - -0.25556E+00,-0.25555E+00,-0.25554E+00,-0.25553E+00,-0.25553E+00,& - -0.25552E+00,-0.25551E+00,-0.25551E+00,-0.25550E+00,-0.25550E+00,& - -0.25549E+00,-0.25549E+00,-0.25549E+00,-0.25548E+00,-0.25548E+00,& - -0.25548E+00,-0.25548E+00,-0.25548E+00,-0.25547E+00,-0.25547E+00,& - -0.25547E+00,-0.25548E+00,-0.25548E+00,-0.25548E+00,-0.25548E+00,& - -0.25548E+00,-0.25549E+00,-0.25549E+00,-0.25549E+00,-0.25550E+00,& - -0.25550E+00,-0.25551E+00,-0.25551E+00,-0.25552E+00,-0.25553E+00,& - -0.25553E+00,-0.25554E+00,-0.25555E+00,-0.25556E+00,-0.25557E+00,& - -0.25558E+00,-0.25559E+00,-0.25560E+00,-0.25561E+00,-0.25562E+00,& - -0.25563E+00,-0.25564E+00,-0.25565E+00,-0.25567E+00,-0.25568E+00,& - -0.25569E+00,-0.25571E+00,-0.25572E+00,-0.25574E+00,-0.25575E+00,& - -0.25577E+00,-0.25579E+00,-0.25580E+00,-0.25582E+00,-0.25584E+00,& - -0.25586E+00,-0.25588E+00,-0.25589E+00,-0.25591E+00,-0.25593E+00,& - -0.25595E+00,-0.25597E+00,-0.25600E+00,-0.25602E+00,-0.25604E+00,& - -0.25606E+00,-0.25609E+00,-0.25611E+00,-0.25613E+00,-0.25616E+00,& - -0.25618E+00,-0.25621E+00,-0.25623E+00,-0.25626E+00,-0.25628E+00,& - -0.25631E+00,-0.25634E+00,-0.25637E+00,-0.25639E+00,-0.25642E+00,& - -0.25645E+00,-0.25648E+00,-0.25651E+00,-0.25654E+00,-0.25657E+00,& - -0.25660E+00,-0.25663E+00,-0.25666E+00,-0.25670E+00,-0.25673E+00,& - -0.25676E+00,-0.25679E+00,-0.25683E+00,-0.25686E+00,-0.25699E+00/ - - DATA (BNC06M (IA),IA=601,700)/ & - -0.25730E+00,-0.25771E+00,-0.25816E+00,-0.25865E+00,-0.25917E+00,& - -0.25973E+00,-0.26033E+00,-0.26096E+00,-0.26163E+00,-0.26233E+00,& - -0.26307E+00,-0.26383E+00,-0.26463E+00,-0.26547E+00,-0.26633E+00,& - -0.26722E+00,-0.26815E+00,-0.26910E+00,-0.27009E+00,-0.27110E+00,& - -0.27214E+00,-0.27320E+00,-0.27430E+00,-0.27542E+00,-0.27657E+00,& - -0.27774E+00,-0.27894E+00,-0.28017E+00,-0.28142E+00,-0.28269E+00,& - -0.28399E+00,-0.28531E+00,-0.28666E+00,-0.28803E+00,-0.28942E+00,& - -0.29083E+00,-0.29226E+00,-0.29372E+00,-0.29520E+00,-0.29669E+00,& - -0.29821E+00,-0.29975E+00,-0.30131E+00,-0.30289E+00,-0.30449E+00,& - -0.30610E+00,-0.30774E+00,-0.30939E+00,-0.31107E+00,-0.31276E+00,& - -0.31447E+00,-0.31619E+00,-0.31794E+00,-0.31970E+00,-0.32147E+00,& - -0.32327E+00,-0.32508E+00,-0.32690E+00,-0.32875E+00,-0.33060E+00,& - -0.33248E+00,-0.33437E+00,-0.33627E+00,-0.33819E+00,-0.34012E+00,& - -0.34207E+00,-0.34403E+00,-0.34601E+00,-0.34800E+00,-0.35001E+00,& - -0.35203E+00,-0.35406E+00,-0.35610E+00,-0.35816E+00,-0.36023E+00,& - -0.36232E+00,-0.36441E+00,-0.36652E+00,-0.36864E+00,-0.37078E+00,& - -0.37292E+00,-0.37508E+00,-0.37725E+00,-0.37943E+00,-0.38162E+00,& - -0.38383E+00,-0.38604E+00,-0.38827E+00,-0.39051E+00,-0.39275E+00,& - -0.39501E+00,-0.39728E+00,-0.39956E+00,-0.40185E+00,-0.40415E+00,& - -0.40646E+00,-0.40879E+00,-0.41112E+00,-0.41346E+00,-0.41581E+00/ - - DATA (BNC06M(IA),IA=701,741)/ & - -0.41817E+00,-0.42054E+00,-0.42292E+00,-0.42530E+00,-0.42770E+00,& - -0.43011E+00,-0.43252E+00,-0.43495E+00,-0.43738E+00,-0.43982E+00,& - -0.44227E+00,-0.44473E+00,-0.44720E+00,-0.44967E+00,-0.45216E+00,& - -0.45465E+00,-0.45715E+00,-0.45966E+00,-0.46218E+00,-0.46470E+00,& - -0.46723E+00,-0.46977E+00,-0.47232E+00,-0.47487E+00,-0.47744E+00,& - -0.48001E+00,-0.48258E+00,-0.48517E+00,-0.48776E+00,-0.49036E+00,& - -0.49296E+00,-0.49558E+00,-0.49820E+00,-0.50082E+00,-0.50346E+00,& - -0.50610E+00,-0.50874E+00,-0.51140E+00,-0.51406E+00,-0.51672E+00,& - -0.51940E+00 / -! -! ** (2H, SO4) -! - DATA (BNC07M (IA),IA= 1,100)/ & - -0.11102E+00,-0.20302E+00,-0.26840E+00,-0.31329E+00,-0.34815E+00,& - -0.37690E+00,-0.40149E+00,-0.42304E+00,-0.44227E+00,-0.45966E+00,& - -0.47555E+00,-0.49020E+00,-0.50381E+00,-0.51652E+00,-0.52846E+00,& - -0.53971E+00,-0.55037E+00,-0.56050E+00,-0.57015E+00,-0.57937E+00,& - -0.58821E+00,-0.59669E+00,-0.60484E+00,-0.61271E+00,-0.62030E+00,& - -0.62763E+00,-0.63474E+00,-0.64162E+00,-0.64831E+00,-0.65480E+00,& - -0.66112E+00,-0.66727E+00,-0.67327E+00,-0.67912E+00,-0.68483E+00,& - -0.69041E+00,-0.69586E+00,-0.70120E+00,-0.70642E+00,-0.71154E+00,& - -0.71656E+00,-0.72147E+00,-0.72630E+00,-0.73104E+00,-0.73570E+00,& - -0.74027E+00,-0.74477E+00,-0.74919E+00,-0.75354E+00,-0.75782E+00,& - -0.76204E+00,-0.76619E+00,-0.77029E+00,-0.77432E+00,-0.77830E+00,& - -0.78222E+00,-0.78609E+00,-0.78991E+00,-0.79369E+00,-0.79741E+00,& - -0.80109E+00,-0.80472E+00,-0.80832E+00,-0.81187E+00,-0.81538E+00,& - -0.81885E+00,-0.82229E+00,-0.82569E+00,-0.82905E+00,-0.83239E+00,& - -0.83568E+00,-0.83895E+00,-0.84219E+00,-0.84539E+00,-0.84857E+00,& - -0.85172E+00,-0.85484E+00,-0.85793E+00,-0.86100E+00,-0.86405E+00,& - -0.86706E+00,-0.87006E+00,-0.87303E+00,-0.87598E+00,-0.87891E+00,& - -0.88182E+00,-0.88471E+00,-0.88757E+00,-0.89042E+00,-0.89325E+00,& - -0.89605E+00,-0.89885E+00,-0.90162E+00,-0.90437E+00,-0.90711E+00,& - -0.90983E+00,-0.91254E+00,-0.91522E+00,-0.91790E+00,-0.92056E+00/ - - DATA (BNC07M (IA),IA=101,200)/ & - -0.92320E+00,-0.92583E+00,-0.92844E+00,-0.93104E+00,-0.93362E+00,& - -0.93619E+00,-0.93875E+00,-0.94129E+00,-0.94382E+00,-0.94634E+00,& - -0.94885E+00,-0.95134E+00,-0.95382E+00,-0.95629E+00,-0.95874E+00,& - -0.96119E+00,-0.96362E+00,-0.96604E+00,-0.96845E+00,-0.97085E+00,& - -0.97321E+00,-0.97559E+00,-0.97796E+00,-0.98032E+00,-0.98267E+00,& - -0.98500E+00,-0.98733E+00,-0.98965E+00,-0.99196E+00,-0.99425E+00,& - -0.99654E+00,-0.99882E+00,-0.10011E+01,-0.10033E+01,-0.10056E+01,& - -0.10078E+01,-0.10101E+01,-0.10123E+01,-0.10145E+01,-0.10167E+01,& - -0.10189E+01,-0.10211E+01,-0.10233E+01,-0.10255E+01,-0.10276E+01,& - -0.10298E+01,-0.10319E+01,-0.10341E+01,-0.10362E+01,-0.10383E+01,& - -0.10405E+01,-0.10426E+01,-0.10447E+01,-0.10468E+01,-0.10489E+01,& - -0.10509E+01,-0.10530E+01,-0.10551E+01,-0.10572E+01,-0.10592E+01,& - -0.10613E+01,-0.10633E+01,-0.10653E+01,-0.10674E+01,-0.10694E+01,& - -0.10714E+01,-0.10734E+01,-0.10754E+01,-0.10775E+01,-0.10794E+01,& - -0.10814E+01,-0.10834E+01,-0.10854E+01,-0.10874E+01,-0.10893E+01,& - -0.10913E+01,-0.10933E+01,-0.10952E+01,-0.10972E+01,-0.10991E+01,& - -0.11010E+01,-0.11030E+01,-0.11049E+01,-0.11068E+01,-0.11087E+01,& - -0.11106E+01,-0.11126E+01,-0.11145E+01,-0.11164E+01,-0.11182E+01,& - -0.11201E+01,-0.11220E+01,-0.11239E+01,-0.11258E+01,-0.11276E+01,& - -0.11295E+01,-0.11314E+01,-0.11332E+01,-0.11351E+01,-0.11369E+01/ - - DATA (BNC07M (IA),IA=201,300)/ & - -0.11388E+01,-0.11406E+01,-0.11424E+01,-0.11443E+01,-0.11461E+01,& - -0.11479E+01,-0.11497E+01,-0.11516E+01,-0.11534E+01,-0.11552E+01,& - -0.11570E+01,-0.11588E+01,-0.11606E+01,-0.11624E+01,-0.11642E+01,& - -0.11659E+01,-0.11677E+01,-0.11695E+01,-0.11713E+01,-0.11730E+01,& - -0.11748E+01,-0.11766E+01,-0.11783E+01,-0.11801E+01,-0.11819E+01,& - -0.11836E+01,-0.11853E+01,-0.11871E+01,-0.11888E+01,-0.11906E+01,& - -0.11923E+01,-0.11940E+01,-0.11958E+01,-0.11975E+01,-0.11992E+01,& - -0.12009E+01,-0.12026E+01,-0.12044E+01,-0.12061E+01,-0.12078E+01,& - -0.12095E+01,-0.12112E+01,-0.12129E+01,-0.12146E+01,-0.12163E+01,& - -0.12179E+01,-0.12196E+01,-0.12213E+01,-0.12230E+01,-0.12247E+01,& - -0.12263E+01,-0.12280E+01,-0.12297E+01,-0.12313E+01,-0.12330E+01,& - -0.12347E+01,-0.12363E+01,-0.12380E+01,-0.12396E+01,-0.12413E+01,& - -0.12429E+01,-0.12446E+01,-0.12462E+01,-0.12479E+01,-0.12495E+01,& - -0.12511E+01,-0.12528E+01,-0.12544E+01,-0.12560E+01,-0.12577E+01,& - -0.12593E+01,-0.12609E+01,-0.12625E+01,-0.12641E+01,-0.12658E+01,& - -0.12674E+01,-0.12690E+01,-0.12706E+01,-0.12722E+01,-0.12738E+01,& - -0.12754E+01,-0.12770E+01,-0.12786E+01,-0.12802E+01,-0.12818E+01,& - -0.12834E+01,-0.12849E+01,-0.12865E+01,-0.12881E+01,-0.12897E+01,& - -0.12913E+01,-0.12929E+01,-0.12944E+01,-0.12960E+01,-0.12976E+01,& - -0.12991E+01,-0.13007E+01,-0.13023E+01,-0.13038E+01,-0.13054E+01/ - - DATA (BNC07M (IA),IA=301,400)/ & - -0.13070E+01,-0.13085E+01,-0.13101E+01,-0.13116E+01,-0.13132E+01,& - -0.13147E+01,-0.13163E+01,-0.13178E+01,-0.13194E+01,-0.13209E+01,& - -0.13224E+01,-0.13240E+01,-0.13255E+01,-0.13271E+01,-0.13286E+01,& - -0.13301E+01,-0.13316E+01,-0.13332E+01,-0.13347E+01,-0.13362E+01,& - -0.13378E+01,-0.13393E+01,-0.13408E+01,-0.13423E+01,-0.13438E+01,& - -0.13453E+01,-0.13468E+01,-0.13484E+01,-0.13499E+01,-0.13514E+01,& - -0.13529E+01,-0.13544E+01,-0.13559E+01,-0.13574E+01,-0.13589E+01,& - -0.13604E+01,-0.13619E+01,-0.13634E+01,-0.13649E+01,-0.13664E+01,& - -0.13679E+01,-0.13693E+01,-0.13708E+01,-0.13723E+01,-0.13738E+01,& - -0.13753E+01,-0.13768E+01,-0.13782E+01,-0.13797E+01,-0.13812E+01,& - -0.13827E+01,-0.13841E+01,-0.13856E+01,-0.13871E+01,-0.13886E+01,& - -0.13900E+01,-0.13915E+01,-0.13930E+01,-0.13944E+01,-0.13959E+01,& - -0.13973E+01,-0.13988E+01,-0.14003E+01,-0.14017E+01,-0.14032E+01,& - -0.14046E+01,-0.14061E+01,-0.14075E+01,-0.14090E+01,-0.14104E+01,& - -0.14119E+01,-0.14133E+01,-0.14148E+01,-0.14162E+01,-0.14176E+01,& - -0.14191E+01,-0.14205E+01,-0.14220E+01,-0.14234E+01,-0.14248E+01,& - -0.14263E+01,-0.14277E+01,-0.14291E+01,-0.14306E+01,-0.14320E+01,& - -0.14334E+01,-0.14349E+01,-0.14363E+01,-0.14377E+01,-0.14391E+01,& - -0.14406E+01,-0.14420E+01,-0.14434E+01,-0.14448E+01,-0.14462E+01,& - -0.14476E+01,-0.14491E+01,-0.14505E+01,-0.14519E+01,-0.14533E+01/ - - DATA (BNC07M (IA),IA=401,500)/ & - -0.14547E+01,-0.14561E+01,-0.14575E+01,-0.14589E+01,-0.14603E+01,& - -0.14617E+01,-0.14631E+01,-0.14646E+01,-0.14660E+01,-0.14674E+01,& - -0.14688E+01,-0.14702E+01,-0.14715E+01,-0.14729E+01,-0.14743E+01,& - -0.14757E+01,-0.14771E+01,-0.14785E+01,-0.14799E+01,-0.14813E+01,& - -0.14827E+01,-0.14841E+01,-0.14855E+01,-0.14868E+01,-0.14882E+01,& - -0.14896E+01,-0.14910E+01,-0.14924E+01,-0.14938E+01,-0.14951E+01,& - -0.14965E+01,-0.14979E+01,-0.14993E+01,-0.15007E+01,-0.15020E+01,& - -0.15034E+01,-0.15048E+01,-0.15061E+01,-0.15075E+01,-0.15089E+01,& - -0.15103E+01,-0.15116E+01,-0.15130E+01,-0.15144E+01,-0.15157E+01,& - -0.15171E+01,-0.15184E+01,-0.15198E+01,-0.15212E+01,-0.15225E+01,& - -0.15239E+01,-0.15252E+01,-0.15266E+01,-0.15280E+01,-0.15293E+01,& - -0.15307E+01,-0.15320E+01,-0.15334E+01,-0.15347E+01,-0.15361E+01,& - -0.15374E+01,-0.15388E+01,-0.15401E+01,-0.15415E+01,-0.15428E+01,& - -0.15442E+01,-0.15455E+01,-0.15469E+01,-0.15482E+01,-0.15495E+01,& - -0.15509E+01,-0.15522E+01,-0.15536E+01,-0.15549E+01,-0.15562E+01,& - -0.15576E+01,-0.15589E+01,-0.15603E+01,-0.15616E+01,-0.15629E+01,& - -0.15643E+01,-0.15656E+01,-0.15669E+01,-0.15683E+01,-0.15696E+01,& - -0.15709E+01,-0.15722E+01,-0.15736E+01,-0.15749E+01,-0.15762E+01,& - -0.15776E+01,-0.15789E+01,-0.15802E+01,-0.15815E+01,-0.15828E+01,& - -0.15842E+01,-0.15855E+01,-0.15868E+01,-0.15881E+01,-0.15894E+01/ - - DATA (BNC07M (IA),IA=501,600)/ & - -0.15908E+01,-0.15921E+01,-0.15934E+01,-0.15947E+01,-0.15960E+01,& - -0.15973E+01,-0.15987E+01,-0.16000E+01,-0.16013E+01,-0.16026E+01,& - -0.16039E+01,-0.16052E+01,-0.16065E+01,-0.16078E+01,-0.16091E+01,& - -0.16104E+01,-0.16117E+01,-0.16131E+01,-0.16144E+01,-0.16157E+01,& - -0.16170E+01,-0.16183E+01,-0.16196E+01,-0.16209E+01,-0.16222E+01,& - -0.16235E+01,-0.16248E+01,-0.16261E+01,-0.16274E+01,-0.16287E+01,& - -0.16300E+01,-0.16313E+01,-0.16325E+01,-0.16338E+01,-0.16351E+01,& - -0.16364E+01,-0.16377E+01,-0.16390E+01,-0.16403E+01,-0.16416E+01,& - -0.16429E+01,-0.16442E+01,-0.16455E+01,-0.16467E+01,-0.16480E+01,& - -0.16493E+01,-0.16506E+01,-0.16519E+01,-0.16532E+01,-0.16545E+01,& - -0.16557E+01,-0.16570E+01,-0.16583E+01,-0.16596E+01,-0.16609E+01,& - -0.16621E+01,-0.16634E+01,-0.16647E+01,-0.16660E+01,-0.16673E+01,& - -0.16685E+01,-0.16698E+01,-0.16711E+01,-0.16724E+01,-0.16736E+01,& - -0.16749E+01,-0.16762E+01,-0.16775E+01,-0.16787E+01,-0.16800E+01,& - -0.16813E+01,-0.16825E+01,-0.16838E+01,-0.16851E+01,-0.16863E+01,& - -0.16876E+01,-0.16889E+01,-0.16902E+01,-0.16914E+01,-0.16927E+01,& - -0.16939E+01,-0.16952E+01,-0.16965E+01,-0.16977E+01,-0.16990E+01,& - -0.17003E+01,-0.17015E+01,-0.17028E+01,-0.17040E+01,-0.17053E+01,& - -0.17066E+01,-0.17078E+01,-0.17091E+01,-0.17103E+01,-0.17116E+01,& - -0.17129E+01,-0.17141E+01,-0.17154E+01,-0.17166E+01,-0.17213E+01/ - - DATA (BNC07M (IA),IA=601,700)/ & - -0.17316E+01,-0.17441E+01,-0.17565E+01,-0.17688E+01,-0.17811E+01,& - -0.17934E+01,-0.18056E+01,-0.18178E+01,-0.18299E+01,-0.18420E+01,& - -0.18540E+01,-0.18660E+01,-0.18780E+01,-0.18899E+01,-0.19018E+01,& - -0.19136E+01,-0.19254E+01,-0.19372E+01,-0.19489E+01,-0.19607E+01,& - -0.19723E+01,-0.19840E+01,-0.19956E+01,-0.20072E+01,-0.20187E+01,& - -0.20302E+01,-0.20417E+01,-0.20532E+01,-0.20646E+01,-0.20760E+01,& - -0.20874E+01,-0.20988E+01,-0.21101E+01,-0.21214E+01,-0.21327E+01,& - -0.21440E+01,-0.21552E+01,-0.21664E+01,-0.21776E+01,-0.21888E+01,& - -0.21999E+01,-0.22110E+01,-0.22221E+01,-0.22332E+01,-0.22443E+01,& - -0.22553E+01,-0.22663E+01,-0.22773E+01,-0.22883E+01,-0.22992E+01,& - -0.23102E+01,-0.23211E+01,-0.23320E+01,-0.23429E+01,-0.23537E+01,& - -0.23646E+01,-0.23754E+01,-0.23862E+01,-0.23970E+01,-0.24078E+01,& - -0.24186E+01,-0.24293E+01,-0.24401E+01,-0.24508E+01,-0.24615E+01,& - -0.24722E+01,-0.24828E+01,-0.24935E+01,-0.25041E+01,-0.25148E+01,& - -0.25254E+01,-0.25360E+01,-0.25466E+01,-0.25571E+01,-0.25677E+01,& - -0.25782E+01,-0.25888E+01,-0.25993E+01,-0.26098E+01,-0.26203E+01,& - -0.26308E+01,-0.26412E+01,-0.26517E+01,-0.26621E+01,-0.26726E+01,& - -0.26830E+01,-0.26934E+01,-0.27038E+01,-0.27142E+01,-0.27245E+01,& - -0.27349E+01,-0.27453E+01,-0.27556E+01,-0.27659E+01,-0.27762E+01,& - -0.27866E+01,-0.27968E+01,-0.28071E+01,-0.28174E+01,-0.28277E+01/ - - DATA (BNC07M(IA),IA=701,741)/ & - -0.28379E+01,-0.28482E+01,-0.28584E+01,-0.28686E+01,-0.28788E+01,& - -0.28891E+01,-0.28992E+01,-0.29094E+01,-0.29196E+01,-0.29298E+01,& - -0.29399E+01,-0.29501E+01,-0.29602E+01,-0.29704E+01,-0.29805E+01,& - -0.29906E+01,-0.30007E+01,-0.30108E+01,-0.30209E+01,-0.30310E+01,& - -0.30410E+01,-0.30511E+01,-0.30612E+01,-0.30712E+01,-0.30812E+01,& - -0.30913E+01,-0.31013E+01,-0.31113E+01,-0.31213E+01,-0.31313E+01,& - -0.31413E+01,-0.31513E+01,-0.31613E+01,-0.31712E+01,-0.31812E+01,& - -0.31911E+01,-0.32011E+01,-0.32110E+01,-0.32210E+01,-0.32309E+01,& - -0.32408E+01 / -! -! ** (H, HSO4) -! - DATA (BNC08M (IA),IA= 1,100)/ & - -0.51043E-01,-0.86042E-01,-0.10613E+00,-0.11710E+00,-0.12372E+00,& - -0.12771E+00,-0.12990E+00,-0.13078E+00,-0.13062E+00,-0.12964E+00,& - -0.12796E+00,-0.12569E+00,-0.12291E+00,-0.11967E+00,-0.11602E+00,& - -0.11201E+00,-0.10765E+00,-0.10298E+00,-0.98013E-01,-0.92777E-01,& - -0.87285E-01,-0.81552E-01,-0.75590E-01,-0.69411E-01,-0.63026E-01,& - -0.56444E-01,-0.49675E-01,-0.42726E-01,-0.35606E-01,-0.28321E-01,& - -0.20880E-01,-0.13287E-01,-0.55488E-02, 0.23277E-02, 0.10337E-01,& - 0.18475E-01, 0.26735E-01, 0.35113E-01, 0.43603E-01, 0.52201E-01,& - 0.60903E-01, 0.69703E-01, 0.78599E-01, 0.87586E-01, 0.96660E-01,& - 0.10582E+00, 0.11506E+00, 0.12437E+00, 0.13376E+00, 0.14322E+00,& - 0.15274E+00, 0.16233E+00, 0.17199E+00, 0.18170E+00, 0.19147E+00,& - 0.20130E+00, 0.21119E+00, 0.22112E+00, 0.23111E+00, 0.24115E+00,& - 0.25124E+00, 0.26138E+00, 0.27157E+00, 0.28181E+00, 0.29209E+00,& - 0.30242E+00, 0.31280E+00, 0.32323E+00, 0.33370E+00, 0.34422E+00,& - 0.35480E+00, 0.36542E+00, 0.37609E+00, 0.38682E+00, 0.39759E+00,& - 0.40842E+00, 0.41931E+00, 0.43025E+00, 0.44124E+00, 0.45229E+00,& - 0.46340E+00, 0.47456E+00, 0.48578E+00, 0.49706E+00, 0.50840E+00,& - 0.51980E+00, 0.53126E+00, 0.54278E+00, 0.55435E+00, 0.56599E+00,& - 0.57768E+00, 0.58943E+00, 0.60124E+00, 0.61310E+00, 0.62502E+00,& - 0.63700E+00, 0.64902E+00, 0.66110E+00, 0.67322E+00, 0.68539E+00/ - - DATA (BNC08M (IA),IA=101,200)/ & - 0.69761E+00, 0.70987E+00, 0.72217E+00, 0.73451E+00, 0.74689E+00,& - 0.75930E+00, 0.77174E+00, 0.78422E+00, 0.79672E+00, 0.80925E+00,& - 0.82180E+00, 0.83437E+00, 0.84696E+00, 0.85957E+00, 0.87219E+00,& - 0.88482E+00, 0.89747E+00, 0.91012E+00, 0.92278E+00, 0.93544E+00,& - 0.94702E+00, 0.95981E+00, 0.97259E+00, 0.98535E+00, 0.99809E+00,& - 0.10108E+01, 0.10235E+01, 0.10362E+01, 0.10489E+01, 0.10616E+01,& - 0.10742E+01, 0.10869E+01, 0.10995E+01, 0.11121E+01, 0.11246E+01,& - 0.11372E+01, 0.11497E+01, 0.11622E+01, 0.11747E+01, 0.11872E+01,& - 0.11997E+01, 0.12121E+01, 0.12245E+01, 0.12369E+01, 0.12493E+01,& - 0.12616E+01, 0.12739E+01, 0.12862E+01, 0.12985E+01, 0.13108E+01,& - 0.13230E+01, 0.13352E+01, 0.13474E+01, 0.13595E+01, 0.13717E+01,& - 0.13838E+01, 0.13959E+01, 0.14079E+01, 0.14200E+01, 0.14320E+01,& - 0.14440E+01, 0.14559E+01, 0.14679E+01, 0.14798E+01, 0.14917E+01,& - 0.15036E+01, 0.15154E+01, 0.15272E+01, 0.15390E+01, 0.15508E+01,& - 0.15625E+01, 0.15742E+01, 0.15859E+01, 0.15976E+01, 0.16092E+01,& - 0.16209E+01, 0.16325E+01, 0.16440E+01, 0.16556E+01, 0.16671E+01,& - 0.16786E+01, 0.16900E+01, 0.17015E+01, 0.17129E+01, 0.17243E+01,& - 0.17356E+01, 0.17470E+01, 0.17583E+01, 0.17696E+01, 0.17809E+01,& - 0.17921E+01, 0.18033E+01, 0.18145E+01, 0.18257E+01, 0.18368E+01,& - 0.18479E+01, 0.18590E+01, 0.18701E+01, 0.18811E+01, 0.18921E+01/ - - DATA (BNC08M (IA),IA=201,300)/ & - 0.19031E+01, 0.19141E+01, 0.19250E+01, 0.19360E+01, 0.19468E+01,& - 0.19577E+01, 0.19686E+01, 0.19794E+01, 0.19902E+01, 0.20009E+01,& - 0.20117E+01, 0.20224E+01, 0.20331E+01, 0.20438E+01, 0.20544E+01,& - 0.20651E+01, 0.20757E+01, 0.20863E+01, 0.20968E+01, 0.21073E+01,& - 0.21179E+01, 0.21283E+01, 0.21388E+01, 0.21492E+01, 0.21597E+01,& - 0.21700E+01, 0.21804E+01, 0.21908E+01, 0.22011E+01, 0.22114E+01,& - 0.22217E+01, 0.22319E+01, 0.22422E+01, 0.22524E+01, 0.22625E+01,& - 0.22727E+01, 0.22829E+01, 0.22930E+01, 0.23031E+01, 0.23131E+01,& - 0.23232E+01, 0.23332E+01, 0.23432E+01, 0.23532E+01, 0.23632E+01,& - 0.23731E+01, 0.23830E+01, 0.23929E+01, 0.24028E+01, 0.24127E+01,& - 0.24225E+01, 0.24323E+01, 0.24421E+01, 0.24519E+01, 0.24616E+01,& - 0.24714E+01, 0.24811E+01, 0.24908E+01, 0.25004E+01, 0.25101E+01,& - 0.25197E+01, 0.25293E+01, 0.25389E+01, 0.25484E+01, 0.25580E+01,& - 0.25675E+01, 0.25770E+01, 0.25865E+01, 0.25960E+01, 0.26054E+01,& - 0.26148E+01, 0.26242E+01, 0.26336E+01, 0.26430E+01, 0.26523E+01,& - 0.26616E+01, 0.26709E+01, 0.26802E+01, 0.26895E+01, 0.26987E+01,& - 0.27079E+01, 0.27171E+01, 0.27263E+01, 0.27355E+01, 0.27446E+01,& - 0.27538E+01, 0.27629E+01, 0.27720E+01, 0.27810E+01, 0.27901E+01,& - 0.27991E+01, 0.28082E+01, 0.28171E+01, 0.28261E+01, 0.28351E+01,& - 0.28440E+01, 0.28530E+01, 0.28619E+01, 0.28707E+01, 0.28796E+01/ - - DATA (BNC08M (IA),IA=301,400)/ & - 0.28885E+01, 0.28973E+01, 0.29061E+01, 0.29149E+01, 0.29237E+01,& - 0.29325E+01, 0.29412E+01, 0.29499E+01, 0.29586E+01, 0.29673E+01,& - 0.29760E+01, 0.29847E+01, 0.29933E+01, 0.30019E+01, 0.30105E+01,& - 0.30191E+01, 0.30277E+01, 0.30363E+01, 0.30448E+01, 0.30533E+01,& - 0.30618E+01, 0.30703E+01, 0.30788E+01, 0.30872E+01, 0.30957E+01,& - 0.31041E+01, 0.31125E+01, 0.31209E+01, 0.31293E+01, 0.31376E+01,& - 0.31460E+01, 0.31543E+01, 0.31626E+01, 0.31709E+01, 0.31792E+01,& - 0.31874E+01, 0.31957E+01, 0.32039E+01, 0.32121E+01, 0.32203E+01,& - 0.32285E+01, 0.32366E+01, 0.32448E+01, 0.32529E+01, 0.32610E+01,& - 0.32691E+01, 0.32772E+01, 0.32853E+01, 0.32934E+01, 0.33014E+01,& - 0.33094E+01, 0.33175E+01, 0.33254E+01, 0.33334E+01, 0.33414E+01,& - 0.33494E+01, 0.33573E+01, 0.33652E+01, 0.33731E+01, 0.33810E+01,& - 0.33889E+01, 0.33968E+01, 0.34046E+01, 0.34124E+01, 0.34203E+01,& - 0.34281E+01, 0.34359E+01, 0.34436E+01, 0.34514E+01, 0.34592E+01,& - 0.34669E+01, 0.34746E+01, 0.34823E+01, 0.34900E+01, 0.34977E+01,& - 0.35054E+01, 0.35130E+01, 0.35206E+01, 0.35283E+01, 0.35359E+01,& - 0.35435E+01, 0.35511E+01, 0.35586E+01, 0.35662E+01, 0.35737E+01,& - 0.35813E+01, 0.35888E+01, 0.35963E+01, 0.36038E+01, 0.36112E+01,& - 0.36187E+01, 0.36262E+01, 0.36336E+01, 0.36410E+01, 0.36484E+01,& - 0.36558E+01, 0.36632E+01, 0.36706E+01, 0.36779E+01, 0.36853E+01/ - - DATA (BNC08M (IA),IA=401,500)/ & - 0.36926E+01, 0.36999E+01, 0.37072E+01, 0.37145E+01, 0.37218E+01,& - 0.37291E+01, 0.37363E+01, 0.37436E+01, 0.37508E+01, 0.37580E+01,& - 0.37652E+01, 0.37724E+01, 0.37796E+01, 0.37868E+01, 0.37939E+01,& - 0.38011E+01, 0.38082E+01, 0.38153E+01, 0.38225E+01, 0.38296E+01,& - 0.38366E+01, 0.38437E+01, 0.38508E+01, 0.38578E+01, 0.38649E+01,& - 0.38719E+01, 0.38789E+01, 0.38859E+01, 0.38929E+01, 0.38999E+01,& - 0.39068E+01, 0.39138E+01, 0.39207E+01, 0.39277E+01, 0.39346E+01,& - 0.39415E+01, 0.39484E+01, 0.39553E+01, 0.39622E+01, 0.39690E+01,& - 0.39759E+01, 0.39827E+01, 0.39895E+01, 0.39964E+01, 0.40032E+01,& - 0.40100E+01, 0.40167E+01, 0.40235E+01, 0.40303E+01, 0.40370E+01,& - 0.40438E+01, 0.40505E+01, 0.40572E+01, 0.40639E+01, 0.40706E+01,& - 0.40773E+01, 0.40840E+01, 0.40907E+01, 0.40973E+01, 0.41040E+01,& - 0.41106E+01, 0.41172E+01, 0.41238E+01, 0.41304E+01, 0.41370E+01,& - 0.41436E+01, 0.41502E+01, 0.41567E+01, 0.41633E+01, 0.41698E+01,& - 0.41763E+01, 0.41829E+01, 0.41894E+01, 0.41959E+01, 0.42024E+01,& - 0.42088E+01, 0.42153E+01, 0.42218E+01, 0.42282E+01, 0.42346E+01,& - 0.42411E+01, 0.42475E+01, 0.42539E+01, 0.42603E+01, 0.42667E+01,& - 0.42731E+01, 0.42794E+01, 0.42858E+01, 0.42921E+01, 0.42985E+01,& - 0.43048E+01, 0.43111E+01, 0.43174E+01, 0.43237E+01, 0.43300E+01,& - 0.43363E+01, 0.43426E+01, 0.43488E+01, 0.43551E+01, 0.43613E+01/ - - DATA (BNC08M (IA),IA=501,600)/ & - 0.43675E+01, 0.43738E+01, 0.43800E+01, 0.43862E+01, 0.43924E+01,& - 0.43986E+01, 0.44047E+01, 0.44109E+01, 0.44171E+01, 0.44232E+01,& - 0.44293E+01, 0.44355E+01, 0.44416E+01, 0.44477E+01, 0.44538E+01,& - 0.44599E+01, 0.44660E+01, 0.44721E+01, 0.44781E+01, 0.44842E+01,& - 0.44902E+01, 0.44963E+01, 0.45023E+01, 0.45083E+01, 0.45143E+01,& - 0.45203E+01, 0.45263E+01, 0.45323E+01, 0.45383E+01, 0.45443E+01,& - 0.45502E+01, 0.45562E+01, 0.45621E+01, 0.45681E+01, 0.45740E+01,& - 0.45799E+01, 0.45858E+01, 0.45917E+01, 0.45976E+01, 0.46035E+01,& - 0.46094E+01, 0.46152E+01, 0.46211E+01, 0.46269E+01, 0.46328E+01,& - 0.46386E+01, 0.46444E+01, 0.46502E+01, 0.46560E+01, 0.46618E+01,& - 0.46676E+01, 0.46734E+01, 0.46792E+01, 0.46849E+01, 0.46907E+01,& - 0.46965E+01, 0.47022E+01, 0.47079E+01, 0.47137E+01, 0.47194E+01,& - 0.47251E+01, 0.47308E+01, 0.47365E+01, 0.47422E+01, 0.47478E+01,& - 0.47535E+01, 0.47592E+01, 0.47648E+01, 0.47705E+01, 0.47761E+01,& - 0.47817E+01, 0.47873E+01, 0.47930E+01, 0.47986E+01, 0.48042E+01,& - 0.48098E+01, 0.48153E+01, 0.48209E+01, 0.48265E+01, 0.48320E+01,& - 0.48376E+01, 0.48431E+01, 0.48487E+01, 0.48542E+01, 0.48597E+01,& - 0.48652E+01, 0.48707E+01, 0.48762E+01, 0.48817E+01, 0.48872E+01,& - 0.48927E+01, 0.48982E+01, 0.49036E+01, 0.49091E+01, 0.49145E+01,& - 0.49200E+01, 0.49254E+01, 0.49308E+01, 0.49362E+01, 0.49565E+01/ - - DATA (BNC08M (IA),IA=601,700)/ & - 0.50007E+01, 0.50536E+01, 0.51058E+01, 0.51574E+01, 0.52083E+01,& - 0.52585E+01, 0.53082E+01, 0.53572E+01, 0.54056E+01, 0.54534E+01,& - 0.55007E+01, 0.55473E+01, 0.55935E+01, 0.56391E+01, 0.56841E+01,& - 0.57287E+01, 0.57727E+01, 0.58163E+01, 0.58594E+01, 0.59020E+01,& - 0.59441E+01, 0.59858E+01, 0.60270E+01, 0.60678E+01, 0.61081E+01,& - 0.61481E+01, 0.61876E+01, 0.62267E+01, 0.62654E+01, 0.63037E+01,& - 0.63416E+01, 0.63792E+01, 0.64164E+01, 0.64532E+01, 0.64897E+01,& - 0.65258E+01, 0.65615E+01, 0.65969E+01, 0.66320E+01, 0.66668E+01,& - 0.67012E+01, 0.67353E+01, 0.67691E+01, 0.68026E+01, 0.68358E+01,& - 0.68687E+01, 0.69013E+01, 0.69336E+01, 0.69656E+01, 0.69974E+01,& - 0.70288E+01, 0.70600E+01, 0.70910E+01, 0.71216E+01, 0.71520E+01,& - 0.71822E+01, 0.72121E+01, 0.72417E+01, 0.72711E+01, 0.73003E+01,& - 0.73292E+01, 0.73579E+01, 0.73864E+01, 0.74146E+01, 0.74426E+01,& - 0.74704E+01, 0.74980E+01, 0.75253E+01, 0.75524E+01, 0.75794E+01,& - 0.76061E+01, 0.76326E+01, 0.76589E+01, 0.76850E+01, 0.77110E+01,& - 0.77367E+01, 0.77622E+01, 0.77876E+01, 0.78127E+01, 0.78377E+01,& - 0.78625E+01, 0.78871E+01, 0.79115E+01, 0.79358E+01, 0.79599E+01,& - 0.79838E+01, 0.80075E+01, 0.80311E+01, 0.80545E+01, 0.80778E+01,& - 0.81009E+01, 0.81238E+01, 0.81466E+01, 0.81692E+01, 0.81916E+01,& - 0.82140E+01, 0.82361E+01, 0.82581E+01, 0.82800E+01, 0.83017E+01/ - - DATA (BNC08M(IA),IA=701,741)/ & - 0.83233E+01, 0.83447E+01, 0.83660E+01, 0.83872E+01, 0.84082E+01,& - 0.84291E+01, 0.84498E+01, 0.84704E+01, 0.84909E+01, 0.85113E+01,& - 0.85315E+01, 0.85516E+01, 0.85715E+01, 0.85914E+01, 0.86111E+01,& - 0.86307E+01, 0.86502E+01, 0.86695E+01, 0.86888E+01, 0.87079E+01,& - 0.87269E+01, 0.87458E+01, 0.87645E+01, 0.87832E+01, 0.88018E+01,& - 0.88202E+01, 0.88385E+01, 0.88567E+01, 0.88749E+01, 0.88929E+01,& - 0.89108E+01, 0.89286E+01, 0.89463E+01, 0.89638E+01, 0.89813E+01,& - 0.89987E+01, 0.90160E+01, 0.90332E+01, 0.90503E+01, 0.90673E+01,& - 0.90842E+01 / -! -! ** NH4HSO4 -! - DATA (BNC09M (IA),IA= 1,100)/ & - -0.54181E-01,-0.97084E-01,-0.12639E+00,-0.14587E+00,-0.16057E+00,& - -0.17236E+00,-0.18218E+00,-0.19054E+00,-0.19779E+00,-0.20414E+00,& - -0.20976E+00,-0.21476E+00,-0.21923E+00,-0.22324E+00,-0.22685E+00,& - -0.23009E+00,-0.23301E+00,-0.23563E+00,-0.23798E+00,-0.24008E+00,& - -0.24194E+00,-0.24359E+00,-0.24503E+00,-0.24629E+00,-0.24736E+00,& - -0.24827E+00,-0.24901E+00,-0.24959E+00,-0.25003E+00,-0.25033E+00,& - -0.25049E+00,-0.25052E+00,-0.25043E+00,-0.25022E+00,-0.24990E+00,& - -0.24946E+00,-0.24892E+00,-0.24827E+00,-0.24753E+00,-0.24669E+00,& - -0.24576E+00,-0.24473E+00,-0.24363E+00,-0.24244E+00,-0.24116E+00,& - -0.23982E+00,-0.23839E+00,-0.23690E+00,-0.23533E+00,-0.23370E+00,& - -0.23200E+00,-0.23024E+00,-0.22842E+00,-0.22654E+00,-0.22460E+00,& - -0.22261E+00,-0.22056E+00,-0.21846E+00,-0.21632E+00,-0.21412E+00,& - -0.21188E+00,-0.20959E+00,-0.20725E+00,-0.20487E+00,-0.20245E+00,& - -0.19999E+00,-0.19748E+00,-0.19494E+00,-0.19236E+00,-0.18974E+00,& - -0.18708E+00,-0.18439E+00,-0.18165E+00,-0.17889E+00,-0.17608E+00,& - -0.17324E+00,-0.17037E+00,-0.16746E+00,-0.16452E+00,-0.16154E+00,& - -0.15853E+00,-0.15549E+00,-0.15242E+00,-0.14931E+00,-0.14617E+00,& - -0.14300E+00,-0.13980E+00,-0.13656E+00,-0.13330E+00,-0.13001E+00,& - -0.12668E+00,-0.12333E+00,-0.11995E+00,-0.11655E+00,-0.11311E+00,& - -0.10965E+00,-0.10617E+00,-0.10266E+00,-0.99129E-01,-0.95574E-01/ - - DATA (BNC09M (IA),IA=101,200)/ & - -0.91997E-01,-0.88400E-01,-0.84784E-01,-0.81148E-01,-0.77495E-01,& - -0.73825E-01,-0.70139E-01,-0.66438E-01,-0.62724E-01,-0.58997E-01,& - -0.55258E-01,-0.51509E-01,-0.47750E-01,-0.43981E-01,-0.40206E-01,& - -0.36423E-01,-0.32634E-01,-0.28839E-01,-0.25041E-01,-0.21238E-01,& - -0.17814E-01,-0.13963E-01,-0.10114E-01,-0.62690E-02,-0.24276E-02,& - 0.14101E-02, 0.52436E-02, 0.90727E-02, 0.12897E-01, 0.16717E-01,& - 0.20532E-01, 0.24341E-01, 0.28145E-01, 0.31943E-01, 0.35736E-01,& - 0.39522E-01, 0.43302E-01, 0.47075E-01, 0.50843E-01, 0.54603E-01,& - 0.58356E-01, 0.62103E-01, 0.65842E-01, 0.69575E-01, 0.73300E-01,& - 0.77017E-01, 0.80727E-01, 0.84429E-01, 0.88124E-01, 0.91811E-01,& - 0.95490E-01, 0.99161E-01, 0.10282E+00, 0.10648E+00, 0.11012E+00,& - 0.11376E+00, 0.11739E+00, 0.12102E+00, 0.12463E+00, 0.12823E+00,& - 0.13183E+00, 0.13542E+00, 0.13900E+00, 0.14257E+00, 0.14613E+00,& - 0.14968E+00, 0.15323E+00, 0.15677E+00, 0.16029E+00, 0.16381E+00,& - 0.16732E+00, 0.17082E+00, 0.17432E+00, 0.17780E+00, 0.18128E+00,& - 0.18474E+00, 0.18820E+00, 0.19165E+00, 0.19509E+00, 0.19852E+00,& - 0.20194E+00, 0.20536E+00, 0.20876E+00, 0.21216E+00, 0.21555E+00,& - 0.21892E+00, 0.22229E+00, 0.22566E+00, 0.22901E+00, 0.23235E+00,& - 0.23569E+00, 0.23902E+00, 0.24233E+00, 0.24564E+00, 0.24894E+00,& - 0.25224E+00, 0.25552E+00, 0.25880E+00, 0.26206E+00, 0.26532E+00/ - - DATA (BNC09M (IA),IA=201,300)/ & - 0.26857E+00, 0.27181E+00, 0.27505E+00, 0.27827E+00, 0.28149E+00,& - 0.28470E+00, 0.28790E+00, 0.29109E+00, 0.29427E+00, 0.29745E+00,& - 0.30061E+00, 0.30377E+00, 0.30692E+00, 0.31007E+00, 0.31320E+00,& - 0.31633E+00, 0.31944E+00, 0.32255E+00, 0.32566E+00, 0.32875E+00,& - 0.33184E+00, 0.33492E+00, 0.33799E+00, 0.34105E+00, 0.34410E+00,& - 0.34715E+00, 0.35019E+00, 0.35322E+00, 0.35625E+00, 0.35926E+00,& - 0.36227E+00, 0.36527E+00, 0.36827E+00, 0.37125E+00, 0.37423E+00,& - 0.37720E+00, 0.38017E+00, 0.38312E+00, 0.38607E+00, 0.38901E+00,& - 0.39195E+00, 0.39487E+00, 0.39779E+00, 0.40070E+00, 0.40361E+00,& - 0.40651E+00, 0.40940E+00, 0.41228E+00, 0.41516E+00, 0.41803E+00,& - 0.42089E+00, 0.42374E+00, 0.42659E+00, 0.42943E+00, 0.43227E+00,& - 0.43509E+00, 0.43791E+00, 0.44073E+00, 0.44354E+00, 0.44634E+00,& - 0.44913E+00, 0.45192E+00, 0.45469E+00, 0.45747E+00, 0.46023E+00,& - 0.46299E+00, 0.46575E+00, 0.46849E+00, 0.47123E+00, 0.47397E+00,& - 0.47670E+00, 0.47942E+00, 0.48213E+00, 0.48484E+00, 0.48754E+00,& - 0.49023E+00, 0.49292E+00, 0.49561E+00, 0.49828E+00, 0.50095E+00,& - 0.50362E+00, 0.50627E+00, 0.50892E+00, 0.51157E+00, 0.51421E+00,& - 0.51684E+00, 0.51947E+00, 0.52209E+00, 0.52470E+00, 0.52731E+00,& - 0.52991E+00, 0.53251E+00, 0.53510E+00, 0.53769E+00, 0.54027E+00,& - 0.54284E+00, 0.54541E+00, 0.54797E+00, 0.55052E+00, 0.55307E+00/ - - DATA (BNC09M (IA),IA=301,400)/ & - 0.55562E+00, 0.55816E+00, 0.56069E+00, 0.56321E+00, 0.56574E+00,& - 0.56825E+00, 0.57076E+00, 0.57327E+00, 0.57576E+00, 0.57826E+00,& - 0.58075E+00, 0.58323E+00, 0.58570E+00, 0.58818E+00, 0.59064E+00,& - 0.59310E+00, 0.59556E+00, 0.59801E+00, 0.60045E+00, 0.60289E+00,& - 0.60532E+00, 0.60775E+00, 0.61017E+00, 0.61259E+00, 0.61500E+00,& - 0.61741E+00, 0.61981E+00, 0.62221E+00, 0.62460E+00, 0.62699E+00,& - 0.62937E+00, 0.63175E+00, 0.63412E+00, 0.63648E+00, 0.63885E+00,& - 0.64120E+00, 0.64355E+00, 0.64590E+00, 0.64824E+00, 0.65058E+00,& - 0.65291E+00, 0.65523E+00, 0.65755E+00, 0.65987E+00, 0.66218E+00,& - 0.66449E+00, 0.66679E+00, 0.66909E+00, 0.67138E+00, 0.67367E+00,& - 0.67595E+00, 0.67823E+00, 0.68050E+00, 0.68277E+00, 0.68503E+00,& - 0.68729E+00, 0.68955E+00, 0.69180E+00, 0.69404E+00, 0.69628E+00,& - 0.69852E+00, 0.70075E+00, 0.70298E+00, 0.70520E+00, 0.70742E+00,& - 0.70963E+00, 0.71184E+00, 0.71405E+00, 0.71625E+00, 0.71844E+00,& - 0.72063E+00, 0.72282E+00, 0.72500E+00, 0.72718E+00, 0.72935E+00,& - 0.73152E+00, 0.73369E+00, 0.73585E+00, 0.73800E+00, 0.74015E+00,& - 0.74230E+00, 0.74444E+00, 0.74658E+00, 0.74872E+00, 0.75085E+00,& - 0.75297E+00, 0.75510E+00, 0.75721E+00, 0.75933E+00, 0.76144E+00,& - 0.76354E+00, 0.76564E+00, 0.76774E+00, 0.76983E+00, 0.77192E+00,& - 0.77401E+00, 0.77609E+00, 0.77817E+00, 0.78024E+00, 0.78231E+00/ - - DATA (BNC09M (IA),IA=401,500)/ & - 0.78437E+00, 0.78643E+00, 0.78849E+00, 0.79054E+00, 0.79259E+00,& - 0.79464E+00, 0.79668E+00, 0.79871E+00, 0.80075E+00, 0.80278E+00,& - 0.80480E+00, 0.80682E+00, 0.80884E+00, 0.81085E+00, 0.81286E+00,& - 0.81487E+00, 0.81687E+00, 0.81887E+00, 0.82087E+00, 0.82286E+00,& - 0.82484E+00, 0.82683E+00, 0.82881E+00, 0.83078E+00, 0.83275E+00,& - 0.83472E+00, 0.83669E+00, 0.83865E+00, 0.84061E+00, 0.84256E+00,& - 0.84451E+00, 0.84646E+00, 0.84840E+00, 0.85034E+00, 0.85228E+00,& - 0.85421E+00, 0.85614E+00, 0.85806E+00, 0.85998E+00, 0.86190E+00,& - 0.86382E+00, 0.86573E+00, 0.86763E+00, 0.86954E+00, 0.87144E+00,& - 0.87333E+00, 0.87523E+00, 0.87712E+00, 0.87900E+00, 0.88089E+00,& - 0.88277E+00, 0.88464E+00, 0.88652E+00, 0.88839E+00, 0.89025E+00,& - 0.89212E+00, 0.89397E+00, 0.89583E+00, 0.89768E+00, 0.89953E+00,& - 0.90138E+00, 0.90322E+00, 0.90506E+00, 0.90690E+00, 0.90873E+00,& - 0.91056E+00, 0.91239E+00, 0.91421E+00, 0.91603E+00, 0.91784E+00,& - 0.91966E+00, 0.92147E+00, 0.92327E+00, 0.92508E+00, 0.92688E+00,& - 0.92868E+00, 0.93047E+00, 0.93226E+00, 0.93405E+00, 0.93583E+00,& - 0.93761E+00, 0.93939E+00, 0.94117E+00, 0.94294E+00, 0.94471E+00,& - 0.94648E+00, 0.94824E+00, 0.95000E+00, 0.95175E+00, 0.95351E+00,& - 0.95526E+00, 0.95701E+00, 0.95875E+00, 0.96049E+00, 0.96223E+00,& - 0.96397E+00, 0.96570E+00, 0.96743E+00, 0.96915E+00, 0.97088E+00/ - - DATA (BNC09M (IA),IA=501,600)/ & - 0.97260E+00, 0.97432E+00, 0.97603E+00, 0.97774E+00, 0.97945E+00,& - 0.98116E+00, 0.98286E+00, 0.98456E+00, 0.98626E+00, 0.98795E+00,& - 0.98964E+00, 0.99133E+00, 0.99302E+00, 0.99470E+00, 0.99638E+00,& - 0.99806E+00, 0.99973E+00, 0.10014E+01, 0.10031E+01, 0.10047E+01,& - 0.10064E+01, 0.10081E+01, 0.10097E+01, 0.10114E+01, 0.10130E+01,& - 0.10147E+01, 0.10163E+01, 0.10180E+01, 0.10196E+01, 0.10212E+01,& - 0.10229E+01, 0.10245E+01, 0.10261E+01, 0.10278E+01, 0.10294E+01,& - 0.10310E+01, 0.10326E+01, 0.10342E+01, 0.10359E+01, 0.10375E+01,& - 0.10391E+01, 0.10407E+01, 0.10423E+01, 0.10439E+01, 0.10455E+01,& - 0.10471E+01, 0.10487E+01, 0.10503E+01, 0.10519E+01, 0.10534E+01,& - 0.10550E+01, 0.10566E+01, 0.10582E+01, 0.10598E+01, 0.10613E+01,& - 0.10629E+01, 0.10645E+01, 0.10660E+01, 0.10676E+01, 0.10691E+01,& - 0.10707E+01, 0.10723E+01, 0.10738E+01, 0.10754E+01, 0.10769E+01,& - 0.10784E+01, 0.10800E+01, 0.10815E+01, 0.10831E+01, 0.10846E+01,& - 0.10861E+01, 0.10877E+01, 0.10892E+01, 0.10907E+01, 0.10922E+01,& - 0.10938E+01, 0.10953E+01, 0.10968E+01, 0.10983E+01, 0.10998E+01,& - 0.11013E+01, 0.11028E+01, 0.11043E+01, 0.11058E+01, 0.11073E+01,& - 0.11088E+01, 0.11103E+01, 0.11118E+01, 0.11133E+01, 0.11148E+01,& - 0.11163E+01, 0.11177E+01, 0.11192E+01, 0.11207E+01, 0.11222E+01,& - 0.11236E+01, 0.11251E+01, 0.11266E+01, 0.11280E+01, 0.11335E+01/ - - DATA (BNC09M (IA),IA=601,700)/ & - 0.11454E+01, 0.11597E+01, 0.11737E+01, 0.11876E+01, 0.12012E+01,& - 0.12146E+01, 0.12278E+01, 0.12409E+01, 0.12537E+01, 0.12663E+01,& - 0.12788E+01, 0.12911E+01, 0.13032E+01, 0.13152E+01, 0.13270E+01,& - 0.13386E+01, 0.13500E+01, 0.13613E+01, 0.13725E+01, 0.13835E+01,& - 0.13943E+01, 0.14050E+01, 0.14156E+01, 0.14260E+01, 0.14363E+01,& - 0.14464E+01, 0.14564E+01, 0.14663E+01, 0.14761E+01, 0.14857E+01,& - 0.14952E+01, 0.15046E+01, 0.15139E+01, 0.15231E+01, 0.15321E+01,& - 0.15410E+01, 0.15499E+01, 0.15586E+01, 0.15672E+01, 0.15757E+01,& - 0.15841E+01, 0.15923E+01, 0.16005E+01, 0.16086E+01, 0.16166E+01,& - 0.16245E+01, 0.16323E+01, 0.16400E+01, 0.16477E+01, 0.16552E+01,& - 0.16626E+01, 0.16700E+01, 0.16773E+01, 0.16845E+01, 0.16916E+01,& - 0.16986E+01, 0.17055E+01, 0.17124E+01, 0.17192E+01, 0.17259E+01,& - 0.17325E+01, 0.17390E+01, 0.17455E+01, 0.17519E+01, 0.17583E+01,& - 0.17645E+01, 0.17707E+01, 0.17768E+01, 0.17829E+01, 0.17889E+01,& - 0.17948E+01, 0.18006E+01, 0.18064E+01, 0.18121E+01, 0.18178E+01,& - 0.18234E+01, 0.18289E+01, 0.18344E+01, 0.18398E+01, 0.18452E+01,& - 0.18505E+01, 0.18557E+01, 0.18609E+01, 0.18660E+01, 0.18711E+01,& - 0.18761E+01, 0.18811E+01, 0.18860E+01, 0.18908E+01, 0.18956E+01,& - 0.19004E+01, 0.19050E+01, 0.19097E+01, 0.19143E+01, 0.19188E+01,& - 0.19233E+01, 0.19278E+01, 0.19322E+01, 0.19365E+01, 0.19408E+01/ - - DATA (BNC09M(IA),IA=701,741)/ & - 0.19451E+01, 0.19493E+01, 0.19535E+01, 0.19576E+01, 0.19616E+01,& - 0.19657E+01, 0.19697E+01, 0.19736E+01, 0.19775E+01, 0.19814E+01,& - 0.19852E+01, 0.19890E+01, 0.19927E+01, 0.19964E+01, 0.20001E+01,& - 0.20037E+01, 0.20073E+01, 0.20108E+01, 0.20143E+01, 0.20178E+01,& - 0.20212E+01, 0.20246E+01, 0.20279E+01, 0.20312E+01, 0.20345E+01,& - 0.20378E+01, 0.20410E+01, 0.20441E+01, 0.20473E+01, 0.20504E+01,& - 0.20534E+01, 0.20565E+01, 0.20595E+01, 0.20624E+01, 0.20654E+01,& - 0.20683E+01, 0.20711E+01, 0.20740E+01, 0.20768E+01, 0.20796E+01,& - 0.20823E+01 / -! -! ** (H, NO3) -! - DATA (BNC10M (IA),IA= 1,100)/ & - -0.53284E-01,-0.93378E-01,-0.11890E+00,-0.13461E+00,-0.14557E+00,& - -0.15369E+00,-0.15987E+00,-0.16466E+00,-0.16839E+00,-0.17129E+00,& - -0.17352E+00,-0.17519E+00,-0.17640E+00,-0.17722E+00,-0.17770E+00,& - -0.17789E+00,-0.17782E+00,-0.17753E+00,-0.17704E+00,-0.17638E+00,& - -0.17556E+00,-0.17459E+00,-0.17350E+00,-0.17230E+00,-0.17099E+00,& - -0.16959E+00,-0.16811E+00,-0.16655E+00,-0.16492E+00,-0.16323E+00,& - -0.16149E+00,-0.15969E+00,-0.15785E+00,-0.15596E+00,-0.15404E+00,& - -0.15208E+00,-0.15010E+00,-0.14808E+00,-0.14604E+00,-0.14398E+00,& - -0.14191E+00,-0.13981E+00,-0.13770E+00,-0.13557E+00,-0.13344E+00,& - -0.13129E+00,-0.12914E+00,-0.12698E+00,-0.12481E+00,-0.12264E+00,& - -0.12046E+00,-0.11828E+00,-0.11609E+00,-0.11390E+00,-0.11171E+00,& - -0.10952E+00,-0.10732E+00,-0.10512E+00,-0.10292E+00,-0.10071E+00,& - -0.98502E-01,-0.96290E-01,-0.94074E-01,-0.91854E-01,-0.89629E-01,& - -0.87399E-01,-0.85162E-01,-0.82919E-01,-0.80669E-01,-0.78411E-01,& - -0.76144E-01,-0.73868E-01,-0.71581E-01,-0.69284E-01,-0.66975E-01,& - -0.64655E-01,-0.62321E-01,-0.59973E-01,-0.57612E-01,-0.55236E-01,& - -0.52844E-01,-0.50437E-01,-0.48014E-01,-0.45574E-01,-0.43117E-01,& - -0.40643E-01,-0.38151E-01,-0.35641E-01,-0.33114E-01,-0.30569E-01,& - -0.28006E-01,-0.25426E-01,-0.22827E-01,-0.20212E-01,-0.17578E-01,& - -0.14928E-01,-0.12262E-01,-0.95788E-02,-0.68800E-02,-0.41657E-02/ - - DATA (BNC10M (IA),IA=101,200)/ & - -0.14365E-02, 0.13072E-02, 0.40646E-02, 0.68354E-02, 0.96189E-02,& - 0.12415E-01, 0.15222E-01, 0.18040E-01, 0.20868E-01, 0.23706E-01,& - 0.26553E-01, 0.29408E-01, 0.32271E-01, 0.35141E-01, 0.38017E-01,& - 0.40900E-01, 0.43787E-01, 0.46680E-01, 0.49577E-01, 0.52478E-01,& - 0.55030E-01, 0.57977E-01, 0.60923E-01, 0.63866E-01, 0.66808E-01,& - 0.69748E-01, 0.72686E-01, 0.75621E-01, 0.78554E-01, 0.81485E-01,& - 0.84414E-01, 0.87340E-01, 0.90263E-01, 0.93184E-01, 0.96103E-01,& - 0.99018E-01, 0.10193E+00, 0.10484E+00, 0.10775E+00, 0.11065E+00,& - 0.11355E+00, 0.11645E+00, 0.11934E+00, 0.12224E+00, 0.12512E+00,& - 0.12801E+00, 0.13089E+00, 0.13377E+00, 0.13664E+00, 0.13951E+00,& - 0.14238E+00, 0.14525E+00, 0.14811E+00, 0.15097E+00, 0.15382E+00,& - 0.15667E+00, 0.15951E+00, 0.16236E+00, 0.16520E+00, 0.16803E+00,& - 0.17086E+00, 0.17369E+00, 0.17651E+00, 0.17933E+00, 0.18215E+00,& - 0.18496E+00, 0.18776E+00, 0.19057E+00, 0.19337E+00, 0.19616E+00,& - 0.19895E+00, 0.20174E+00, 0.20452E+00, 0.20730E+00, 0.21008E+00,& - 0.21285E+00, 0.21561E+00, 0.21837E+00, 0.22113E+00, 0.22389E+00,& - 0.22663E+00, 0.22938E+00, 0.23212E+00, 0.23486E+00, 0.23759E+00,& - 0.24032E+00, 0.24304E+00, 0.24576E+00, 0.24847E+00, 0.25118E+00,& - 0.25389E+00, 0.25659E+00, 0.25929E+00, 0.26198E+00, 0.26467E+00,& - 0.26735E+00, 0.27003E+00, 0.27270E+00, 0.27537E+00, 0.27804E+00/ - - DATA (BNC10M (IA),IA=201,300)/ & - 0.28070E+00, 0.28336E+00, 0.28601E+00, 0.28866E+00, 0.29130E+00,& - 0.29394E+00, 0.29657E+00, 0.29920E+00, 0.30183E+00, 0.30445E+00,& - 0.30707E+00, 0.30968E+00, 0.31229E+00, 0.31489E+00, 0.31749E+00,& - 0.32008E+00, 0.32267E+00, 0.32525E+00, 0.32783E+00, 0.33041E+00,& - 0.33298E+00, 0.33555E+00, 0.33811E+00, 0.34067E+00, 0.34322E+00,& - 0.34577E+00, 0.34831E+00, 0.35085E+00, 0.35339E+00, 0.35592E+00,& - 0.35844E+00, 0.36097E+00, 0.36348E+00, 0.36599E+00, 0.36850E+00,& - 0.37101E+00, 0.37351E+00, 0.37600E+00, 0.37849E+00, 0.38098E+00,& - 0.38346E+00, 0.38593E+00, 0.38840E+00, 0.39087E+00, 0.39334E+00,& - 0.39579E+00, 0.39825E+00, 0.40070E+00, 0.40314E+00, 0.40558E+00,& - 0.40802E+00, 0.41045E+00, 0.41288E+00, 0.41530E+00, 0.41772E+00,& - 0.42014E+00, 0.42255E+00, 0.42495E+00, 0.42735E+00, 0.42975E+00,& - 0.43214E+00, 0.43453E+00, 0.43691E+00, 0.43929E+00, 0.44167E+00,& - 0.44404E+00, 0.44640E+00, 0.44877E+00, 0.45112E+00, 0.45348E+00,& - 0.45583E+00, 0.45817E+00, 0.46051E+00, 0.46285E+00, 0.46518E+00,& - 0.46751E+00, 0.46983E+00, 0.47215E+00, 0.47446E+00, 0.47677E+00,& - 0.47908E+00, 0.48138E+00, 0.48368E+00, 0.48597E+00, 0.48826E+00,& - 0.49054E+00, 0.49283E+00, 0.49510E+00, 0.49737E+00, 0.49964E+00,& - 0.50191E+00, 0.50417E+00, 0.50642E+00, 0.50867E+00, 0.51092E+00,& - 0.51316E+00, 0.51540E+00, 0.51764E+00, 0.51987E+00, 0.52210E+00/ - - DATA (BNC10M (IA),IA=301,400)/ & - 0.52432E+00, 0.52654E+00, 0.52875E+00, 0.53096E+00, 0.53317E+00,& - 0.53537E+00, 0.53757E+00, 0.53976E+00, 0.54195E+00, 0.54414E+00,& - 0.54632E+00, 0.54850E+00, 0.55067E+00, 0.55284E+00, 0.55501E+00,& - 0.55717E+00, 0.55933E+00, 0.56148E+00, 0.56363E+00, 0.56578E+00,& - 0.56792E+00, 0.57006E+00, 0.57219E+00, 0.57433E+00, 0.57645E+00,& - 0.57857E+00, 0.58069E+00, 0.58281E+00, 0.58492E+00, 0.58703E+00,& - 0.58913E+00, 0.59123E+00, 0.59333E+00, 0.59542E+00, 0.59751E+00,& - 0.59959E+00, 0.60167E+00, 0.60375E+00, 0.60582E+00, 0.60789E+00,& - 0.60996E+00, 0.61202E+00, 0.61407E+00, 0.61613E+00, 0.61818E+00,& - 0.62023E+00, 0.62227E+00, 0.62431E+00, 0.62634E+00, 0.62838E+00,& - 0.63040E+00, 0.63243E+00, 0.63445E+00, 0.63647E+00, 0.63848E+00,& - 0.64049E+00, 0.64250E+00, 0.64450E+00, 0.64650E+00, 0.64849E+00,& - 0.65049E+00, 0.65247E+00, 0.65446E+00, 0.65644E+00, 0.65842E+00,& - 0.66039E+00, 0.66236E+00, 0.66433E+00, 0.66629E+00, 0.66825E+00,& - 0.67021E+00, 0.67216E+00, 0.67411E+00, 0.67606E+00, 0.67800E+00,& - 0.67994E+00, 0.68187E+00, 0.68380E+00, 0.68573E+00, 0.68766E+00,& - 0.68958E+00, 0.69150E+00, 0.69341E+00, 0.69532E+00, 0.69723E+00,& - 0.69914E+00, 0.70104E+00, 0.70294E+00, 0.70483E+00, 0.70672E+00,& - 0.70861E+00, 0.71049E+00, 0.71237E+00, 0.71425E+00, 0.71613E+00,& - 0.71800E+00, 0.71986E+00, 0.72173E+00, 0.72359E+00, 0.72545E+00/ - - DATA (BNC10M (IA),IA=401,500)/ & - 0.72730E+00, 0.72915E+00, 0.73100E+00, 0.73285E+00, 0.73469E+00,& - 0.73653E+00, 0.73836E+00, 0.74019E+00, 0.74202E+00, 0.74385E+00,& - 0.74567E+00, 0.74749E+00, 0.74930E+00, 0.75112E+00, 0.75293E+00,& - 0.75473E+00, 0.75654E+00, 0.75834E+00, 0.76013E+00, 0.76193E+00,& - 0.76372E+00, 0.76550E+00, 0.76729E+00, 0.76907E+00, 0.77085E+00,& - 0.77262E+00, 0.77439E+00, 0.77616E+00, 0.77793E+00, 0.77969E+00,& - 0.78145E+00, 0.78321E+00, 0.78496E+00, 0.78671E+00, 0.78846E+00,& - 0.79021E+00, 0.79195E+00, 0.79369E+00, 0.79542E+00, 0.79715E+00,& - 0.79888E+00, 0.80061E+00, 0.80233E+00, 0.80405E+00, 0.80577E+00,& - 0.80749E+00, 0.80920E+00, 0.81091E+00, 0.81261E+00, 0.81432E+00,& - 0.81602E+00, 0.81771E+00, 0.81941E+00, 0.82110E+00, 0.82279E+00,& - 0.82448E+00, 0.82616E+00, 0.82784E+00, 0.82952E+00, 0.83119E+00,& - 0.83286E+00, 0.83453E+00, 0.83620E+00, 0.83786E+00, 0.83952E+00,& - 0.84118E+00, 0.84283E+00, 0.84448E+00, 0.84613E+00, 0.84778E+00,& - 0.84942E+00, 0.85106E+00, 0.85270E+00, 0.85434E+00, 0.85597E+00,& - 0.85760E+00, 0.85922E+00, 0.86085E+00, 0.86247E+00, 0.86409E+00,& - 0.86571E+00, 0.86732E+00, 0.86893E+00, 0.87054E+00, 0.87214E+00,& - 0.87375E+00, 0.87535E+00, 0.87694E+00, 0.87854E+00, 0.88013E+00,& - 0.88172E+00, 0.88331E+00, 0.88489E+00, 0.88647E+00, 0.88805E+00,& - 0.88963E+00, 0.89120E+00, 0.89277E+00, 0.89434E+00, 0.89590E+00/ - - DATA (BNC10M (IA),IA=501,600)/ & - 0.89747E+00, 0.89903E+00, 0.90059E+00, 0.90214E+00, 0.90369E+00,& - 0.90524E+00, 0.90679E+00, 0.90834E+00, 0.90988E+00, 0.91142E+00,& - 0.91296E+00, 0.91449E+00, 0.91603E+00, 0.91756E+00, 0.91908E+00,& - 0.92061E+00, 0.92213E+00, 0.92365E+00, 0.92517E+00, 0.92668E+00,& - 0.92820E+00, 0.92971E+00, 0.93122E+00, 0.93272E+00, 0.93422E+00,& - 0.93572E+00, 0.93722E+00, 0.93872E+00, 0.94021E+00, 0.94170E+00,& - 0.94319E+00, 0.94468E+00, 0.94616E+00, 0.94764E+00, 0.94912E+00,& - 0.95060E+00, 0.95207E+00, 0.95354E+00, 0.95501E+00, 0.95648E+00,& - 0.95794E+00, 0.95940E+00, 0.96086E+00, 0.96232E+00, 0.96378E+00,& - 0.96523E+00, 0.96668E+00, 0.96813E+00, 0.96957E+00, 0.97102E+00,& - 0.97246E+00, 0.97390E+00, 0.97533E+00, 0.97677E+00, 0.97820E+00,& - 0.97963E+00, 0.98106E+00, 0.98248E+00, 0.98391E+00, 0.98533E+00,& - 0.98674E+00, 0.98816E+00, 0.98957E+00, 0.99099E+00, 0.99240E+00,& - 0.99380E+00, 0.99521E+00, 0.99661E+00, 0.99801E+00, 0.99941E+00,& - 0.10008E+01, 0.10022E+01, 0.10036E+01, 0.10050E+01, 0.10064E+01,& - 0.10078E+01, 0.10091E+01, 0.10105E+01, 0.10119E+01, 0.10133E+01,& - 0.10146E+01, 0.10160E+01, 0.10174E+01, 0.10188E+01, 0.10201E+01,& - 0.10215E+01, 0.10228E+01, 0.10242E+01, 0.10256E+01, 0.10269E+01,& - 0.10283E+01, 0.10296E+01, 0.10310E+01, 0.10323E+01, 0.10337E+01,& - 0.10350E+01, 0.10363E+01, 0.10377E+01, 0.10390E+01, 0.10440E+01/ - - DATA (BNC10M (IA),IA=601,700)/ & - 0.10549E+01, 0.10679E+01, 0.10807E+01, 0.10933E+01, 0.11058E+01,& - 0.11180E+01, 0.11301E+01, 0.11420E+01, 0.11537E+01, 0.11652E+01,& - 0.11766E+01, 0.11878E+01, 0.11989E+01, 0.12098E+01, 0.12205E+01,& - 0.12311E+01, 0.12415E+01, 0.12518E+01, 0.12620E+01, 0.12720E+01,& - 0.12819E+01, 0.12916E+01, 0.13012E+01, 0.13107E+01, 0.13201E+01,& - 0.13293E+01, 0.13384E+01, 0.13474E+01, 0.13562E+01, 0.13650E+01,& - 0.13736E+01, 0.13821E+01, 0.13905E+01, 0.13988E+01, 0.14070E+01,& - 0.14151E+01, 0.14231E+01, 0.14310E+01, 0.14388E+01, 0.14464E+01,& - 0.14540E+01, 0.14615E+01, 0.14689E+01, 0.14762E+01, 0.14834E+01,& - 0.14906E+01, 0.14976E+01, 0.15045E+01, 0.15114E+01, 0.15182E+01,& - 0.15249E+01, 0.15315E+01, 0.15380E+01, 0.15444E+01, 0.15508E+01,& - 0.15571E+01, 0.15633E+01, 0.15695E+01, 0.15755E+01, 0.15815E+01,& - 0.15875E+01, 0.15933E+01, 0.15991E+01, 0.16048E+01, 0.16105E+01,& - 0.16160E+01, 0.16215E+01, 0.16270E+01, 0.16324E+01, 0.16377E+01,& - 0.16429E+01, 0.16481E+01, 0.16533E+01, 0.16583E+01, 0.16634E+01,& - 0.16683E+01, 0.16732E+01, 0.16780E+01, 0.16828E+01, 0.16875E+01,& - 0.16922E+01, 0.16968E+01, 0.17014E+01, 0.17059E+01, 0.17104E+01,& - 0.17148E+01, 0.17191E+01, 0.17234E+01, 0.17277E+01, 0.17319E+01,& - 0.17360E+01, 0.17401E+01, 0.17442E+01, 0.17482E+01, 0.17521E+01,& - 0.17560E+01, 0.17599E+01, 0.17637E+01, 0.17675E+01, 0.17712E+01/ - - DATA (BNC10M(IA),IA=701,741)/ & - 0.17749E+01, 0.17786E+01, 0.17822E+01, 0.17858E+01, 0.17893E+01,& - 0.17927E+01, 0.17962E+01, 0.17996E+01, 0.18029E+01, 0.18063E+01,& - 0.18095E+01, 0.18128E+01, 0.18160E+01, 0.18191E+01, 0.18223E+01,& - 0.18253E+01, 0.18284E+01, 0.18314E+01, 0.18344E+01, 0.18373E+01,& - 0.18402E+01, 0.18431E+01, 0.18459E+01, 0.18487E+01, 0.18515E+01,& - 0.18542E+01, 0.18569E+01, 0.18596E+01, 0.18623E+01, 0.18649E+01,& - 0.18674E+01, 0.18700E+01, 0.18725E+01, 0.18749E+01, 0.18774E+01,& - 0.18798E+01, 0.18822E+01, 0.18845E+01, 0.18869E+01, 0.18892E+01,& - 0.18914E+01 / -! -! ** (H, Cl) -! - DATA (BNC11M (IA),IA= 1,100)/ & - -0.51530E-01,-0.87364E-01,-0.10805E+00,-0.11938E+00,-0.12621E+00,& - -0.13034E+00,-0.13263E+00,-0.13358E+00,-0.13351E+00,-0.13262E+00,& - -0.13105E+00,-0.12892E+00,-0.12631E+00,-0.12328E+00,-0.11989E+00,& - -0.11617E+00,-0.11216E+00,-0.10789E+00,-0.10338E+00,-0.98657E-01,& - -0.93734E-01,-0.88627E-01,-0.83353E-01,-0.77922E-01,-0.72347E-01,& - -0.66638E-01,-0.60804E-01,-0.54854E-01,-0.48795E-01,-0.42636E-01,& - -0.36382E-01,-0.30040E-01,-0.23617E-01,-0.17116E-01,-0.10545E-01,& - -0.39064E-02, 0.27939E-02, 0.95516E-02, 0.16363E-01, 0.23224E-01,& - 0.30132E-01, 0.37082E-01, 0.44072E-01, 0.51099E-01, 0.58160E-01,& - 0.65253E-01, 0.72375E-01, 0.79524E-01, 0.86699E-01, 0.93897E-01,& - 0.10112E+00, 0.10836E+00, 0.11562E+00, 0.12290E+00, 0.13019E+00,& - 0.13750E+00, 0.14483E+00, 0.15218E+00, 0.15954E+00, 0.16691E+00,& - 0.17430E+00, 0.18171E+00, 0.18913E+00, 0.19657E+00, 0.20403E+00,& - 0.21151E+00, 0.21900E+00, 0.22652E+00, 0.23405E+00, 0.24161E+00,& - 0.24919E+00, 0.25680E+00, 0.26443E+00, 0.27209E+00, 0.27977E+00,& - 0.28749E+00, 0.29523E+00, 0.30301E+00, 0.31082E+00, 0.31867E+00,& - 0.32655E+00, 0.33446E+00, 0.34241E+00, 0.35040E+00, 0.35843E+00,& - 0.36650E+00, 0.37461E+00, 0.38275E+00, 0.39094E+00, 0.39916E+00,& - 0.40743E+00, 0.41574E+00, 0.42408E+00, 0.43246E+00, 0.44088E+00,& - 0.44934E+00, 0.45784E+00, 0.46637E+00, 0.47494E+00, 0.48354E+00/ - - DATA (BNC11M (IA),IA=101,200)/ & - 0.49217E+00, 0.50083E+00, 0.50952E+00, 0.51825E+00, 0.52699E+00,& - 0.53577E+00, 0.54456E+00, 0.55338E+00, 0.56222E+00, 0.57108E+00,& - 0.57996E+00, 0.58885E+00, 0.59776E+00, 0.60668E+00, 0.61561E+00,& - 0.62456E+00, 0.63351E+00, 0.64246E+00, 0.65143E+00, 0.66039E+00,& - 0.66855E+00, 0.67762E+00, 0.68668E+00, 0.69573E+00, 0.70477E+00,& - 0.71380E+00, 0.72282E+00, 0.73183E+00, 0.74082E+00, 0.74981E+00,& - 0.75879E+00, 0.76776E+00, 0.77671E+00, 0.78566E+00, 0.79459E+00,& - 0.80351E+00, 0.81241E+00, 0.82131E+00, 0.83019E+00, 0.83906E+00,& - 0.84792E+00, 0.85676E+00, 0.86559E+00, 0.87440E+00, 0.88321E+00,& - 0.89200E+00, 0.90077E+00, 0.90953E+00, 0.91827E+00, 0.92701E+00,& - 0.93572E+00, 0.94443E+00, 0.95311E+00, 0.96178E+00, 0.97044E+00,& - 0.97908E+00, 0.98771E+00, 0.99632E+00, 0.10049E+01, 0.10135E+01,& - 0.10221E+01, 0.10306E+01, 0.10392E+01, 0.10477E+01, 0.10562E+01,& - 0.10647E+01, 0.10731E+01, 0.10816E+01, 0.10900E+01, 0.10984E+01,& - 0.11069E+01, 0.11152E+01, 0.11236E+01, 0.11320E+01, 0.11403E+01,& - 0.11486E+01, 0.11570E+01, 0.11652E+01, 0.11735E+01, 0.11818E+01,& - 0.11900E+01, 0.11983E+01, 0.12065E+01, 0.12147E+01, 0.12228E+01,& - 0.12310E+01, 0.12391E+01, 0.12473E+01, 0.12554E+01, 0.12635E+01,& - 0.12716E+01, 0.12796E+01, 0.12877E+01, 0.12957E+01, 0.13037E+01,& - 0.13117E+01, 0.13197E+01, 0.13276E+01, 0.13356E+01, 0.13435E+01/ - - DATA (BNC11M (IA),IA=201,300)/ & - 0.13514E+01, 0.13593E+01, 0.13672E+01, 0.13751E+01, 0.13829E+01,& - 0.13908E+01, 0.13986E+01, 0.14064E+01, 0.14142E+01, 0.14219E+01,& - 0.14297E+01, 0.14374E+01, 0.14451E+01, 0.14528E+01, 0.14605E+01,& - 0.14682E+01, 0.14758E+01, 0.14835E+01, 0.14911E+01, 0.14987E+01,& - 0.15063E+01, 0.15139E+01, 0.15214E+01, 0.15289E+01, 0.15365E+01,& - 0.15440E+01, 0.15515E+01, 0.15590E+01, 0.15664E+01, 0.15739E+01,& - 0.15813E+01, 0.15887E+01, 0.15961E+01, 0.16035E+01, 0.16109E+01,& - 0.16182E+01, 0.16255E+01, 0.16329E+01, 0.16402E+01, 0.16475E+01,& - 0.16547E+01, 0.16620E+01, 0.16692E+01, 0.16765E+01, 0.16837E+01,& - 0.16909E+01, 0.16981E+01, 0.17052E+01, 0.17124E+01, 0.17195E+01,& - 0.17266E+01, 0.17338E+01, 0.17408E+01, 0.17479E+01, 0.17550E+01,& - 0.17620E+01, 0.17691E+01, 0.17761E+01, 0.17831E+01, 0.17901E+01,& - 0.17971E+01, 0.18040E+01, 0.18110E+01, 0.18179E+01, 0.18248E+01,& - 0.18317E+01, 0.18386E+01, 0.18455E+01, 0.18524E+01, 0.18592E+01,& - 0.18660E+01, 0.18729E+01, 0.18797E+01, 0.18865E+01, 0.18932E+01,& - 0.19000E+01, 0.19068E+01, 0.19135E+01, 0.19202E+01, 0.19269E+01,& - 0.19336E+01, 0.19403E+01, 0.19470E+01, 0.19536E+01, 0.19603E+01,& - 0.19669E+01, 0.19735E+01, 0.19801E+01, 0.19867E+01, 0.19933E+01,& - 0.19998E+01, 0.20064E+01, 0.20129E+01, 0.20194E+01, 0.20259E+01,& - 0.20324E+01, 0.20389E+01, 0.20454E+01, 0.20518E+01, 0.20583E+01/ - - DATA (BNC11M (IA),IA=301,400)/ & - 0.20647E+01, 0.20711E+01, 0.20775E+01, 0.20839E+01, 0.20903E+01,& - 0.20967E+01, 0.21030E+01, 0.21093E+01, 0.21157E+01, 0.21220E+01,& - 0.21283E+01, 0.21346E+01, 0.21409E+01, 0.21471E+01, 0.21534E+01,& - 0.21596E+01, 0.21659E+01, 0.21721E+01, 0.21783E+01, 0.21845E+01,& - 0.21907E+01, 0.21968E+01, 0.22030E+01, 0.22091E+01, 0.22153E+01,& - 0.22214E+01, 0.22275E+01, 0.22336E+01, 0.22397E+01, 0.22457E+01,& - 0.22518E+01, 0.22579E+01, 0.22639E+01, 0.22699E+01, 0.22759E+01,& - 0.22819E+01, 0.22879E+01, 0.22939E+01, 0.22999E+01, 0.23058E+01,& - 0.23118E+01, 0.23177E+01, 0.23237E+01, 0.23296E+01, 0.23355E+01,& - 0.23414E+01, 0.23472E+01, 0.23531E+01, 0.23590E+01, 0.23648E+01,& - 0.23707E+01, 0.23765E+01, 0.23823E+01, 0.23881E+01, 0.23939E+01,& - 0.23997E+01, 0.24054E+01, 0.24112E+01, 0.24170E+01, 0.24227E+01,& - 0.24284E+01, 0.24341E+01, 0.24398E+01, 0.24455E+01, 0.24512E+01,& - 0.24569E+01, 0.24626E+01, 0.24682E+01, 0.24739E+01, 0.24795E+01,& - 0.24851E+01, 0.24907E+01, 0.24963E+01, 0.25019E+01, 0.25075E+01,& - 0.25131E+01, 0.25187E+01, 0.25242E+01, 0.25298E+01, 0.25353E+01,& - 0.25408E+01, 0.25463E+01, 0.25518E+01, 0.25573E+01, 0.25628E+01,& - 0.25683E+01, 0.25737E+01, 0.25792E+01, 0.25846E+01, 0.25901E+01,& - 0.25955E+01, 0.26009E+01, 0.26063E+01, 0.26117E+01, 0.26171E+01,& - 0.26225E+01, 0.26278E+01, 0.26332E+01, 0.26386E+01, 0.26439E+01/ - - DATA (BNC11M (IA),IA=401,500)/ & - 0.26492E+01, 0.26545E+01, 0.26599E+01, 0.26652E+01, 0.26704E+01,& - 0.26757E+01, 0.26810E+01, 0.26863E+01, 0.26915E+01, 0.26968E+01,& - 0.27020E+01, 0.27072E+01, 0.27125E+01, 0.27177E+01, 0.27229E+01,& - 0.27281E+01, 0.27332E+01, 0.27384E+01, 0.27436E+01, 0.27487E+01,& - 0.27539E+01, 0.27590E+01, 0.27642E+01, 0.27693E+01, 0.27744E+01,& - 0.27795E+01, 0.27846E+01, 0.27897E+01, 0.27948E+01, 0.27998E+01,& - 0.28049E+01, 0.28100E+01, 0.28150E+01, 0.28200E+01, 0.28251E+01,& - 0.28301E+01, 0.28351E+01, 0.28401E+01, 0.28451E+01, 0.28501E+01,& - 0.28551E+01, 0.28600E+01, 0.28650E+01, 0.28699E+01, 0.28749E+01,& - 0.28798E+01, 0.28847E+01, 0.28897E+01, 0.28946E+01, 0.28995E+01,& - 0.29044E+01, 0.29093E+01, 0.29141E+01, 0.29190E+01, 0.29239E+01,& - 0.29287E+01, 0.29336E+01, 0.29384E+01, 0.29433E+01, 0.29481E+01,& - 0.29529E+01, 0.29577E+01, 0.29625E+01, 0.29673E+01, 0.29721E+01,& - 0.29769E+01, 0.29816E+01, 0.29864E+01, 0.29911E+01, 0.29959E+01,& - 0.30006E+01, 0.30054E+01, 0.30101E+01, 0.30148E+01, 0.30195E+01,& - 0.30242E+01, 0.30289E+01, 0.30336E+01, 0.30383E+01, 0.30430E+01,& - 0.30476E+01, 0.30523E+01, 0.30569E+01, 0.30616E+01, 0.30662E+01,& - 0.30708E+01, 0.30754E+01, 0.30801E+01, 0.30847E+01, 0.30893E+01,& - 0.30939E+01, 0.30984E+01, 0.31030E+01, 0.31076E+01, 0.31122E+01,& - 0.31167E+01, 0.31213E+01, 0.31258E+01, 0.31303E+01, 0.31349E+01/ - - DATA (BNC11M (IA),IA=501,600)/ & - 0.31394E+01, 0.31439E+01, 0.31484E+01, 0.31529E+01, 0.31574E+01,& - 0.31619E+01, 0.31664E+01, 0.31708E+01, 0.31753E+01, 0.31798E+01,& - 0.31842E+01, 0.31887E+01, 0.31931E+01, 0.31975E+01, 0.32020E+01,& - 0.32064E+01, 0.32108E+01, 0.32152E+01, 0.32196E+01, 0.32240E+01,& - 0.32284E+01, 0.32327E+01, 0.32371E+01, 0.32415E+01, 0.32458E+01,& - 0.32502E+01, 0.32545E+01, 0.32589E+01, 0.32632E+01, 0.32675E+01,& - 0.32718E+01, 0.32762E+01, 0.32805E+01, 0.32848E+01, 0.32891E+01,& - 0.32934E+01, 0.32976E+01, 0.33019E+01, 0.33062E+01, 0.33104E+01,& - 0.33147E+01, 0.33189E+01, 0.33232E+01, 0.33274E+01, 0.33317E+01,& - 0.33359E+01, 0.33401E+01, 0.33443E+01, 0.33485E+01, 0.33527E+01,& - 0.33569E+01, 0.33611E+01, 0.33653E+01, 0.33695E+01, 0.33736E+01,& - 0.33778E+01, 0.33819E+01, 0.33861E+01, 0.33902E+01, 0.33944E+01,& - 0.33985E+01, 0.34026E+01, 0.34068E+01, 0.34109E+01, 0.34150E+01,& - 0.34191E+01, 0.34232E+01, 0.34273E+01, 0.34314E+01, 0.34355E+01,& - 0.34395E+01, 0.34436E+01, 0.34477E+01, 0.34517E+01, 0.34558E+01,& - 0.34598E+01, 0.34639E+01, 0.34679E+01, 0.34719E+01, 0.34759E+01,& - 0.34800E+01, 0.34840E+01, 0.34880E+01, 0.34920E+01, 0.34960E+01,& - 0.35000E+01, 0.35040E+01, 0.35079E+01, 0.35119E+01, 0.35159E+01,& - 0.35198E+01, 0.35238E+01, 0.35277E+01, 0.35317E+01, 0.35356E+01,& - 0.35396E+01, 0.35435E+01, 0.35474E+01, 0.35513E+01, 0.35660E+01/ - - DATA (BNC11M (IA),IA=601,700)/ & - 0.35979E+01, 0.36362E+01, 0.36739E+01, 0.37112E+01, 0.37479E+01,& - 0.37842E+01, 0.38200E+01, 0.38554E+01, 0.38903E+01, 0.39247E+01,& - 0.39588E+01, 0.39924E+01, 0.40256E+01, 0.40584E+01, 0.40909E+01,& - 0.41229E+01, 0.41546E+01, 0.41859E+01, 0.42168E+01, 0.42474E+01,& - 0.42776E+01, 0.43075E+01, 0.43371E+01, 0.43664E+01, 0.43953E+01,& - 0.44239E+01, 0.44522E+01, 0.44802E+01, 0.45079E+01, 0.45353E+01,& - 0.45624E+01, 0.45893E+01, 0.46158E+01, 0.46421E+01, 0.46681E+01,& - 0.46939E+01, 0.47194E+01, 0.47447E+01, 0.47697E+01, 0.47944E+01,& - 0.48190E+01, 0.48432E+01, 0.48673E+01, 0.48911E+01, 0.49147E+01,& - 0.49381E+01, 0.49612E+01, 0.49842E+01, 0.50069E+01, 0.50294E+01,& - 0.50517E+01, 0.50738E+01, 0.50958E+01, 0.51175E+01, 0.51390E+01,& - 0.51603E+01, 0.51815E+01, 0.52024E+01, 0.52232E+01, 0.52438E+01,& - 0.52643E+01, 0.52845E+01, 0.53046E+01, 0.53245E+01, 0.53442E+01,& - 0.53638E+01, 0.53832E+01, 0.54025E+01, 0.54216E+01, 0.54405E+01,& - 0.54593E+01, 0.54779E+01, 0.54964E+01, 0.55147E+01, 0.55329E+01,& - 0.55510E+01, 0.55689E+01, 0.55866E+01, 0.56043E+01, 0.56217E+01,& - 0.56391E+01, 0.56563E+01, 0.56734E+01, 0.56903E+01, 0.57072E+01,& - 0.57239E+01, 0.57404E+01, 0.57569E+01, 0.57732E+01, 0.57894E+01,& - 0.58055E+01, 0.58215E+01, 0.58373E+01, 0.58530E+01, 0.58687E+01,& - 0.58842E+01, 0.58996E+01, 0.59148E+01, 0.59300E+01, 0.59451E+01/ - - DATA (BNC11M(IA),IA=701,741)/ & - 0.59600E+01, 0.59749E+01, 0.59896E+01, 0.60043E+01, 0.60188E+01,& - 0.60333E+01, 0.60476E+01, 0.60619E+01, 0.60760E+01, 0.60901E+01,& - 0.61040E+01, 0.61179E+01, 0.61316E+01, 0.61453E+01, 0.61589E+01,& - 0.61724E+01, 0.61858E+01, 0.61991E+01, 0.62123E+01, 0.62254E+01,& - 0.62385E+01, 0.62514E+01, 0.62643E+01, 0.62771E+01, 0.62898E+01,& - 0.63024E+01, 0.63150E+01, 0.63274E+01, 0.63398E+01, 0.63521E+01,& - 0.63644E+01, 0.63765E+01, 0.63886E+01, 0.64006E+01, 0.64125E+01,& - 0.64243E+01, 0.64361E+01, 0.64478E+01, 0.64594E+01, 0.64710E+01,& - 0.64825E+01 / -! -! ** NaHSO4 -! - DATA (BNC12M (IA),IA= 1,100)/ & - -0.53059E-01,-0.92995E-01,-0.11872E+00,-0.13483E+00,-0.14630E+00,& - -0.15498E+00,-0.16174E+00,-0.16712E+00,-0.17143E+00,-0.17489E+00,& - -0.17765E+00,-0.17982E+00,-0.18150E+00,-0.18274E+00,-0.18359E+00,& - -0.18411E+00,-0.18432E+00,-0.18425E+00,-0.18392E+00,-0.18337E+00,& - -0.18259E+00,-0.18162E+00,-0.18045E+00,-0.17912E+00,-0.17761E+00,& - -0.17595E+00,-0.17414E+00,-0.17219E+00,-0.17011E+00,-0.16790E+00,& - -0.16557E+00,-0.16313E+00,-0.16057E+00,-0.15791E+00,-0.15515E+00,& - -0.15229E+00,-0.14934E+00,-0.14630E+00,-0.14318E+00,-0.13997E+00,& - -0.13669E+00,-0.13333E+00,-0.12990E+00,-0.12640E+00,-0.12284E+00,& - -0.11921E+00,-0.11552E+00,-0.11177E+00,-0.10796E+00,-0.10410E+00,& - -0.10019E+00,-0.96227E-01,-0.92215E-01,-0.88157E-01,-0.84053E-01,& - -0.79905E-01,-0.75715E-01,-0.71483E-01,-0.67210E-01,-0.62899E-01,& - -0.58548E-01,-0.54161E-01,-0.49736E-01,-0.45274E-01,-0.40777E-01,& - -0.36244E-01,-0.31676E-01,-0.27073E-01,-0.22436E-01,-0.17763E-01,& - -0.13056E-01,-0.83143E-02,-0.35376E-02, 0.12738E-02, 0.61202E-02,& - 0.11002E-01, 0.15919E-01, 0.20871E-01, 0.25859E-01, 0.30883E-01,& - 0.35942E-01, 0.41038E-01, 0.46170E-01, 0.51337E-01, 0.56541E-01,& - 0.61781E-01, 0.67057E-01, 0.72367E-01, 0.77714E-01, 0.83095E-01,& - 0.88511E-01, 0.93961E-01, 0.99444E-01, 0.10496E+00, 0.11051E+00,& - 0.11609E+00, 0.12170E+00, 0.12733E+00, 0.13300E+00, 0.13870E+00/ - - DATA (BNC12M (IA),IA=101,200)/ & - 0.14442E+00, 0.15016E+00, 0.15593E+00, 0.16173E+00, 0.16754E+00,& - 0.17337E+00, 0.17923E+00, 0.18510E+00, 0.19099E+00, 0.19689E+00,& - 0.20280E+00, 0.20873E+00, 0.21467E+00, 0.22062E+00, 0.22658E+00,& - 0.23255E+00, 0.23852E+00, 0.24450E+00, 0.25048E+00, 0.25647E+00,& - 0.26188E+00, 0.26794E+00, 0.27399E+00, 0.28003E+00, 0.28607E+00,& - 0.29209E+00, 0.29812E+00, 0.30413E+00, 0.31014E+00, 0.31613E+00,& - 0.32212E+00, 0.32811E+00, 0.33408E+00, 0.34004E+00, 0.34600E+00,& - 0.35194E+00, 0.35788E+00, 0.36380E+00, 0.36972E+00, 0.37562E+00,& - 0.38152E+00, 0.38740E+00, 0.39328E+00, 0.39914E+00, 0.40500E+00,& - 0.41084E+00, 0.41667E+00, 0.42249E+00, 0.42830E+00, 0.43410E+00,& - 0.43989E+00, 0.44567E+00, 0.45143E+00, 0.45719E+00, 0.46293E+00,& - 0.46866E+00, 0.47438E+00, 0.48008E+00, 0.48578E+00, 0.49146E+00,& - 0.49713E+00, 0.50279E+00, 0.50844E+00, 0.51408E+00, 0.51970E+00,& - 0.52531E+00, 0.53091E+00, 0.53650E+00, 0.54208E+00, 0.54764E+00,& - 0.55319E+00, 0.55873E+00, 0.56426E+00, 0.56978E+00, 0.57528E+00,& - 0.58077E+00, 0.58625E+00, 0.59172E+00, 0.59717E+00, 0.60261E+00,& - 0.60804E+00, 0.61346E+00, 0.61887E+00, 0.62426E+00, 0.62965E+00,& - 0.63502E+00, 0.64038E+00, 0.64572E+00, 0.65106E+00, 0.65638E+00,& - 0.66169E+00, 0.66699E+00, 0.67227E+00, 0.67755E+00, 0.68281E+00,& - 0.68806E+00, 0.69330E+00, 0.69853E+00, 0.70375E+00, 0.70895E+00/ - - DATA (BNC12M (IA),IA=201,300)/ & - 0.71414E+00, 0.71932E+00, 0.72449E+00, 0.72965E+00, 0.73479E+00,& - 0.73993E+00, 0.74505E+00, 0.75016E+00, 0.75526E+00, 0.76035E+00,& - 0.76543E+00, 0.77049E+00, 0.77554E+00, 0.78059E+00, 0.78562E+00,& - 0.79064E+00, 0.79565E+00, 0.80064E+00, 0.80563E+00, 0.81061E+00,& - 0.81557E+00, 0.82052E+00, 0.82547E+00, 0.83040E+00, 0.83532E+00,& - 0.84023E+00, 0.84512E+00, 0.85001E+00, 0.85489E+00, 0.85975E+00,& - 0.86461E+00, 0.86945E+00, 0.87429E+00, 0.87911E+00, 0.88392E+00,& - 0.88873E+00, 0.89352E+00, 0.89830E+00, 0.90307E+00, 0.90783E+00,& - 0.91258E+00, 0.91732E+00, 0.92205E+00, 0.92677E+00, 0.93148E+00,& - 0.93617E+00, 0.94086E+00, 0.94554E+00, 0.95021E+00, 0.95487E+00,& - 0.95951E+00, 0.96415E+00, 0.96878E+00, 0.97340E+00, 0.97801E+00,& - 0.98260E+00, 0.98719E+00, 0.99177E+00, 0.99634E+00, 0.10009E+01,& - 0.10054E+01, 0.10100E+01, 0.10145E+01, 0.10190E+01, 0.10235E+01,& - 0.10281E+01, 0.10325E+01, 0.10370E+01, 0.10415E+01, 0.10460E+01,& - 0.10504E+01, 0.10549E+01, 0.10593E+01, 0.10637E+01, 0.10681E+01,& - 0.10725E+01, 0.10769E+01, 0.10813E+01, 0.10857E+01, 0.10901E+01,& - 0.10945E+01, 0.10988E+01, 0.11031E+01, 0.11075E+01, 0.11118E+01,& - 0.11161E+01, 0.11204E+01, 0.11247E+01, 0.11290E+01, 0.11333E+01,& - 0.11376E+01, 0.11419E+01, 0.11461E+01, 0.11504E+01, 0.11546E+01,& - 0.11588E+01, 0.11631E+01, 0.11673E+01, 0.11715E+01, 0.11757E+01/ - - DATA (BNC12M (IA),IA=301,400)/ & - 0.11799E+01, 0.11840E+01, 0.11882E+01, 0.11924E+01, 0.11965E+01,& - 0.12007E+01, 0.12048E+01, 0.12089E+01, 0.12131E+01, 0.12172E+01,& - 0.12213E+01, 0.12254E+01, 0.12295E+01, 0.12336E+01, 0.12376E+01,& - 0.12417E+01, 0.12457E+01, 0.12498E+01, 0.12538E+01, 0.12579E+01,& - 0.12619E+01, 0.12659E+01, 0.12699E+01, 0.12739E+01, 0.12779E+01,& - 0.12819E+01, 0.12859E+01, 0.12899E+01, 0.12938E+01, 0.12978E+01,& - 0.13017E+01, 0.13057E+01, 0.13096E+01, 0.13135E+01, 0.13175E+01,& - 0.13214E+01, 0.13253E+01, 0.13292E+01, 0.13331E+01, 0.13369E+01,& - 0.13408E+01, 0.13447E+01, 0.13485E+01, 0.13524E+01, 0.13562E+01,& - 0.13601E+01, 0.13639E+01, 0.13677E+01, 0.13715E+01, 0.13754E+01,& - 0.13792E+01, 0.13829E+01, 0.13867E+01, 0.13905E+01, 0.13943E+01,& - 0.13981E+01, 0.14018E+01, 0.14056E+01, 0.14093E+01, 0.14131E+01,& - 0.14168E+01, 0.14205E+01, 0.14242E+01, 0.14279E+01, 0.14316E+01,& - 0.14353E+01, 0.14390E+01, 0.14427E+01, 0.14464E+01, 0.14501E+01,& - 0.14537E+01, 0.14574E+01, 0.14610E+01, 0.14647E+01, 0.14683E+01,& - 0.14720E+01, 0.14756E+01, 0.14792E+01, 0.14828E+01, 0.14864E+01,& - 0.14900E+01, 0.14936E+01, 0.14972E+01, 0.15008E+01, 0.15043E+01,& - 0.15079E+01, 0.15115E+01, 0.15150E+01, 0.15186E+01, 0.15221E+01,& - 0.15256E+01, 0.15292E+01, 0.15327E+01, 0.15362E+01, 0.15397E+01,& - 0.15432E+01, 0.15467E+01, 0.15502E+01, 0.15537E+01, 0.15572E+01/ - - DATA (BNC12M (IA),IA=401,500)/ & - 0.15607E+01, 0.15641E+01, 0.15676E+01, 0.15710E+01, 0.15745E+01,& - 0.15779E+01, 0.15814E+01, 0.15848E+01, 0.15882E+01, 0.15916E+01,& - 0.15951E+01, 0.15985E+01, 0.16019E+01, 0.16053E+01, 0.16087E+01,& - 0.16120E+01, 0.16154E+01, 0.16188E+01, 0.16222E+01, 0.16255E+01,& - 0.16289E+01, 0.16322E+01, 0.16356E+01, 0.16389E+01, 0.16422E+01,& - 0.16456E+01, 0.16489E+01, 0.16522E+01, 0.16555E+01, 0.16588E+01,& - 0.16621E+01, 0.16654E+01, 0.16687E+01, 0.16720E+01, 0.16753E+01,& - 0.16785E+01, 0.16818E+01, 0.16850E+01, 0.16883E+01, 0.16916E+01,& - 0.16948E+01, 0.16980E+01, 0.17013E+01, 0.17045E+01, 0.17077E+01,& - 0.17109E+01, 0.17142E+01, 0.17174E+01, 0.17206E+01, 0.17238E+01,& - 0.17269E+01, 0.17301E+01, 0.17333E+01, 0.17365E+01, 0.17397E+01,& - 0.17428E+01, 0.17460E+01, 0.17491E+01, 0.17523E+01, 0.17554E+01,& - 0.17586E+01, 0.17617E+01, 0.17648E+01, 0.17680E+01, 0.17711E+01,& - 0.17742E+01, 0.17773E+01, 0.17804E+01, 0.17835E+01, 0.17866E+01,& - 0.17897E+01, 0.17928E+01, 0.17958E+01, 0.17989E+01, 0.18020E+01,& - 0.18050E+01, 0.18081E+01, 0.18112E+01, 0.18142E+01, 0.18173E+01,& - 0.18203E+01, 0.18233E+01, 0.18264E+01, 0.18294E+01, 0.18324E+01,& - 0.18354E+01, 0.18384E+01, 0.18414E+01, 0.18444E+01, 0.18474E+01,& - 0.18504E+01, 0.18534E+01, 0.18564E+01, 0.18594E+01, 0.18623E+01,& - 0.18653E+01, 0.18683E+01, 0.18712E+01, 0.18742E+01, 0.18771E+01/ - - DATA (BNC12M (IA),IA=501,600)/ & - 0.18801E+01, 0.18830E+01, 0.18860E+01, 0.18889E+01, 0.18918E+01,& - 0.18947E+01, 0.18977E+01, 0.19006E+01, 0.19035E+01, 0.19064E+01,& - 0.19093E+01, 0.19122E+01, 0.19151E+01, 0.19180E+01, 0.19209E+01,& - 0.19237E+01, 0.19266E+01, 0.19295E+01, 0.19323E+01, 0.19352E+01,& - 0.19381E+01, 0.19409E+01, 0.19438E+01, 0.19466E+01, 0.19494E+01,& - 0.19523E+01, 0.19551E+01, 0.19579E+01, 0.19607E+01, 0.19636E+01,& - 0.19664E+01, 0.19692E+01, 0.19720E+01, 0.19748E+01, 0.19776E+01,& - 0.19804E+01, 0.19832E+01, 0.19860E+01, 0.19887E+01, 0.19915E+01,& - 0.19943E+01, 0.19970E+01, 0.19998E+01, 0.20026E+01, 0.20053E+01,& - 0.20081E+01, 0.20108E+01, 0.20136E+01, 0.20163E+01, 0.20190E+01,& - 0.20218E+01, 0.20245E+01, 0.20272E+01, 0.20299E+01, 0.20327E+01,& - 0.20354E+01, 0.20381E+01, 0.20408E+01, 0.20435E+01, 0.20462E+01,& - 0.20489E+01, 0.20515E+01, 0.20542E+01, 0.20569E+01, 0.20596E+01,& - 0.20622E+01, 0.20649E+01, 0.20676E+01, 0.20702E+01, 0.20729E+01,& - 0.20755E+01, 0.20782E+01, 0.20808E+01, 0.20835E+01, 0.20861E+01,& - 0.20887E+01, 0.20914E+01, 0.20940E+01, 0.20966E+01, 0.20992E+01,& - 0.21019E+01, 0.21045E+01, 0.21071E+01, 0.21097E+01, 0.21123E+01,& - 0.21149E+01, 0.21175E+01, 0.21200E+01, 0.21226E+01, 0.21252E+01,& - 0.21278E+01, 0.21304E+01, 0.21329E+01, 0.21355E+01, 0.21381E+01,& - 0.21406E+01, 0.21432E+01, 0.21457E+01, 0.21483E+01, 0.21578E+01/ - - DATA (BNC12M (IA),IA=601,700)/ & - 0.21786E+01, 0.22034E+01, 0.22280E+01, 0.22522E+01, 0.22760E+01,& - 0.22996E+01, 0.23228E+01, 0.23457E+01, 0.23684E+01, 0.23907E+01,& - 0.24128E+01, 0.24345E+01, 0.24560E+01, 0.24773E+01, 0.24982E+01,& - 0.25190E+01, 0.25394E+01, 0.25596E+01, 0.25796E+01, 0.25993E+01,& - 0.26188E+01, 0.26381E+01, 0.26571E+01, 0.26760E+01, 0.26946E+01,& - 0.27130E+01, 0.27312E+01, 0.27491E+01, 0.27669E+01, 0.27845E+01,& - 0.28019E+01, 0.28191E+01, 0.28361E+01, 0.28529E+01, 0.28696E+01,& - 0.28860E+01, 0.29023E+01, 0.29185E+01, 0.29344E+01, 0.29502E+01,& - 0.29658E+01, 0.29813E+01, 0.29966E+01, 0.30117E+01, 0.30267E+01,& - 0.30415E+01, 0.30562E+01, 0.30708E+01, 0.30852E+01, 0.30994E+01,& - 0.31136E+01, 0.31275E+01, 0.31414E+01, 0.31551E+01, 0.31687E+01,& - 0.31821E+01, 0.31954E+01, 0.32086E+01, 0.32217E+01, 0.32346E+01,& - 0.32474E+01, 0.32601E+01, 0.32727E+01, 0.32852E+01, 0.32976E+01,& - 0.33098E+01, 0.33219E+01, 0.33339E+01, 0.33459E+01, 0.33577E+01,& - 0.33694E+01, 0.33810E+01, 0.33924E+01, 0.34038E+01, 0.34151E+01,& - 0.34263E+01, 0.34374E+01, 0.34484E+01, 0.34593E+01, 0.34701E+01,& - 0.34808E+01, 0.34914E+01, 0.35020E+01, 0.35124E+01, 0.35228E+01,& - 0.35330E+01, 0.35432E+01, 0.35533E+01, 0.35633E+01, 0.35732E+01,& - 0.35831E+01, 0.35928E+01, 0.36025E+01, 0.36121E+01, 0.36216E+01,& - 0.36311E+01, 0.36405E+01, 0.36497E+01, 0.36590E+01, 0.36681E+01/ - - DATA (BNC12M(IA),IA=701,741)/ & - 0.36772E+01, 0.36862E+01, 0.36951E+01, 0.37039E+01, 0.37127E+01,& - 0.37214E+01, 0.37301E+01, 0.37386E+01, 0.37472E+01, 0.37556E+01,& - 0.37640E+01, 0.37723E+01, 0.37805E+01, 0.37887E+01, 0.37968E+01,& - 0.38049E+01, 0.38129E+01, 0.38208E+01, 0.38287E+01, 0.38365E+01,& - 0.38442E+01, 0.38519E+01, 0.38595E+01, 0.38671E+01, 0.38746E+01,& - 0.38821E+01, 0.38895E+01, 0.38968E+01, 0.39041E+01, 0.39114E+01,& - 0.39186E+01, 0.39257E+01, 0.39328E+01, 0.39398E+01, 0.39468E+01,& - 0.39537E+01, 0.39606E+01, 0.39674E+01, 0.39742E+01, 0.39809E+01,& - 0.39875E+01 / -! -! ** (NH4)3H(SO4)2 -! - DATA (BNC13M (IA),IA= 1,100)/ & - -0.88457E-01,-0.16130E+00,-0.21283E+00,-0.24810E+00,-0.27543E+00,& - -0.29791E+00,-0.31709E+00,-0.33386E+00,-0.34878E+00,-0.36223E+00,& - -0.37448E+00,-0.38573E+00,-0.39614E+00,-0.40581E+00,-0.41486E+00,& - -0.42335E+00,-0.43134E+00,-0.43890E+00,-0.44605E+00,-0.45284E+00,& - -0.45930E+00,-0.46546E+00,-0.47134E+00,-0.47696E+00,-0.48234E+00,& - -0.48749E+00,-0.49244E+00,-0.49719E+00,-0.50176E+00,-0.50615E+00,& - -0.51038E+00,-0.51445E+00,-0.51838E+00,-0.52217E+00,-0.52582E+00,& - -0.52935E+00,-0.53275E+00,-0.53604E+00,-0.53922E+00,-0.54230E+00,& - -0.54527E+00,-0.54815E+00,-0.55093E+00,-0.55362E+00,-0.55622E+00,& - -0.55875E+00,-0.56119E+00,-0.56356E+00,-0.56585E+00,-0.56807E+00,& - -0.57023E+00,-0.57231E+00,-0.57434E+00,-0.57630E+00,-0.57820E+00,& - -0.58005E+00,-0.58183E+00,-0.58357E+00,-0.58525E+00,-0.58689E+00,& - -0.58847E+00,-0.59001E+00,-0.59151E+00,-0.59295E+00,-0.59436E+00,& - -0.59573E+00,-0.59705E+00,-0.59834E+00,-0.59958E+00,-0.60079E+00,& - -0.60197E+00,-0.60311E+00,-0.60421E+00,-0.60529E+00,-0.60633E+00,& - -0.60734E+00,-0.60831E+00,-0.60926E+00,-0.61018E+00,-0.61107E+00,& - -0.61193E+00,-0.61276E+00,-0.61356E+00,-0.61434E+00,-0.61509E+00,& - -0.61582E+00,-0.61652E+00,-0.61720E+00,-0.61786E+00,-0.61849E+00,& - -0.61909E+00,-0.61968E+00,-0.62024E+00,-0.62078E+00,-0.62130E+00,& - -0.62180E+00,-0.62229E+00,-0.62275E+00,-0.62319E+00,-0.62361E+00/ - - DATA (BNC13M (IA),IA=101,200)/ & - -0.62402E+00,-0.62441E+00,-0.62478E+00,-0.62514E+00,-0.62548E+00,& - -0.62581E+00,-0.62612E+00,-0.62642E+00,-0.62670E+00,-0.62697E+00,& - -0.62723E+00,-0.62748E+00,-0.62771E+00,-0.62793E+00,-0.62815E+00,& - -0.62835E+00,-0.62854E+00,-0.62873E+00,-0.62890E+00,-0.62907E+00,& - -0.62933E+00,-0.62947E+00,-0.62960E+00,-0.62973E+00,-0.62984E+00,& - -0.62996E+00,-0.63006E+00,-0.63017E+00,-0.63026E+00,-0.63036E+00,& - -0.63045E+00,-0.63053E+00,-0.63061E+00,-0.63068E+00,-0.63075E+00,& - -0.63082E+00,-0.63089E+00,-0.63095E+00,-0.63100E+00,-0.63106E+00,& - -0.63111E+00,-0.63116E+00,-0.63120E+00,-0.63125E+00,-0.63129E+00,& - -0.63132E+00,-0.63136E+00,-0.63139E+00,-0.63142E+00,-0.63145E+00,& - -0.63148E+00,-0.63150E+00,-0.63153E+00,-0.63155E+00,-0.63157E+00,& - -0.63159E+00,-0.63160E+00,-0.63162E+00,-0.63163E+00,-0.63165E+00,& - -0.63166E+00,-0.63167E+00,-0.63168E+00,-0.63169E+00,-0.63169E+00,& - -0.63170E+00,-0.63171E+00,-0.63171E+00,-0.63172E+00,-0.63172E+00,& - -0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00,& - -0.63174E+00,-0.63174E+00,-0.63174E+00,-0.63174E+00,-0.63174E+00,& - -0.63174E+00,-0.63174E+00,-0.63174E+00,-0.63174E+00,-0.63174E+00,& - -0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00,& - -0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00,& - -0.63173E+00,-0.63173E+00,-0.63174E+00,-0.63174E+00,-0.63174E+00/ - - DATA (BNC13M (IA),IA=201,300)/ & - -0.63174E+00,-0.63174E+00,-0.63174E+00,-0.63175E+00,-0.63175E+00,& - -0.63176E+00,-0.63176E+00,-0.63176E+00,-0.63177E+00,-0.63177E+00,& - -0.63178E+00,-0.63179E+00,-0.63179E+00,-0.63180E+00,-0.63181E+00,& - -0.63182E+00,-0.63183E+00,-0.63184E+00,-0.63185E+00,-0.63186E+00,& - -0.63187E+00,-0.63188E+00,-0.63189E+00,-0.63191E+00,-0.63192E+00,& - -0.63193E+00,-0.63195E+00,-0.63197E+00,-0.63198E+00,-0.63200E+00,& - -0.63202E+00,-0.63203E+00,-0.63205E+00,-0.63207E+00,-0.63209E+00,& - -0.63211E+00,-0.63214E+00,-0.63216E+00,-0.63218E+00,-0.63221E+00,& - -0.63223E+00,-0.63225E+00,-0.63228E+00,-0.63231E+00,-0.63233E+00,& - -0.63236E+00,-0.63239E+00,-0.63242E+00,-0.63245E+00,-0.63248E+00,& - -0.63251E+00,-0.63255E+00,-0.63258E+00,-0.63261E+00,-0.63265E+00,& - -0.63268E+00,-0.63272E+00,-0.63276E+00,-0.63280E+00,-0.63283E+00,& - -0.63287E+00,-0.63291E+00,-0.63296E+00,-0.63300E+00,-0.63304E+00,& - -0.63308E+00,-0.63313E+00,-0.63317E+00,-0.63322E+00,-0.63326E+00,& - -0.63331E+00,-0.63336E+00,-0.63341E+00,-0.63346E+00,-0.63351E+00,& - -0.63356E+00,-0.63361E+00,-0.63366E+00,-0.63372E+00,-0.63377E+00,& - -0.63383E+00,-0.63388E+00,-0.63394E+00,-0.63400E+00,-0.63406E+00,& - -0.63411E+00,-0.63417E+00,-0.63424E+00,-0.63430E+00,-0.63436E+00,& - -0.63442E+00,-0.63449E+00,-0.63455E+00,-0.63462E+00,-0.63468E+00,& - -0.63475E+00,-0.63482E+00,-0.63489E+00,-0.63496E+00,-0.63503E+00/ - - DATA (BNC13M (IA),IA=301,400)/ & - -0.63510E+00,-0.63517E+00,-0.63524E+00,-0.63531E+00,-0.63539E+00,& - -0.63546E+00,-0.63554E+00,-0.63562E+00,-0.63569E+00,-0.63577E+00,& - -0.63585E+00,-0.63593E+00,-0.63601E+00,-0.63609E+00,-0.63617E+00,& - -0.63626E+00,-0.63634E+00,-0.63643E+00,-0.63651E+00,-0.63660E+00,& - -0.63668E+00,-0.63677E+00,-0.63686E+00,-0.63695E+00,-0.63704E+00,& - -0.63713E+00,-0.63722E+00,-0.63731E+00,-0.63741E+00,-0.63750E+00,& - -0.63759E+00,-0.63769E+00,-0.63779E+00,-0.63788E+00,-0.63798E+00,& - -0.63808E+00,-0.63818E+00,-0.63828E+00,-0.63838E+00,-0.63848E+00,& - -0.63858E+00,-0.63869E+00,-0.63879E+00,-0.63889E+00,-0.63900E+00,& - -0.63911E+00,-0.63921E+00,-0.63932E+00,-0.63943E+00,-0.63954E+00,& - -0.63965E+00,-0.63976E+00,-0.63987E+00,-0.63998E+00,-0.64009E+00,& - -0.64021E+00,-0.64032E+00,-0.64044E+00,-0.64055E+00,-0.64067E+00,& - -0.64079E+00,-0.64090E+00,-0.64102E+00,-0.64114E+00,-0.64126E+00,& - -0.64138E+00,-0.64150E+00,-0.64163E+00,-0.64175E+00,-0.64187E+00,& - -0.64200E+00,-0.64212E+00,-0.64225E+00,-0.64238E+00,-0.64250E+00,& - -0.64263E+00,-0.64276E+00,-0.64289E+00,-0.64302E+00,-0.64315E+00,& - -0.64328E+00,-0.64342E+00,-0.64355E+00,-0.64368E+00,-0.64382E+00,& - -0.64395E+00,-0.64409E+00,-0.64423E+00,-0.64436E+00,-0.64450E+00,& - -0.64464E+00,-0.64478E+00,-0.64492E+00,-0.64506E+00,-0.64520E+00,& - -0.64534E+00,-0.64549E+00,-0.64563E+00,-0.64578E+00,-0.64592E+00/ - - DATA (BNC13M (IA),IA=401,500)/ & - -0.64607E+00,-0.64621E+00,-0.64636E+00,-0.64651E+00,-0.64666E+00,& - -0.64681E+00,-0.64696E+00,-0.64711E+00,-0.64726E+00,-0.64741E+00,& - -0.64756E+00,-0.64772E+00,-0.64787E+00,-0.64802E+00,-0.64818E+00,& - -0.64833E+00,-0.64849E+00,-0.64865E+00,-0.64881E+00,-0.64897E+00,& - -0.64912E+00,-0.64928E+00,-0.64944E+00,-0.64961E+00,-0.64977E+00,& - -0.64993E+00,-0.65009E+00,-0.65026E+00,-0.65042E+00,-0.65059E+00,& - -0.65075E+00,-0.65092E+00,-0.65109E+00,-0.65125E+00,-0.65142E+00,& - -0.65159E+00,-0.65176E+00,-0.65193E+00,-0.65210E+00,-0.65227E+00,& - -0.65245E+00,-0.65262E+00,-0.65279E+00,-0.65297E+00,-0.65314E+00,& - -0.65332E+00,-0.65349E+00,-0.65367E+00,-0.65385E+00,-0.65402E+00,& - -0.65420E+00,-0.65438E+00,-0.65456E+00,-0.65474E+00,-0.65492E+00,& - -0.65510E+00,-0.65529E+00,-0.65547E+00,-0.65565E+00,-0.65584E+00,& - -0.65602E+00,-0.65621E+00,-0.65639E+00,-0.65658E+00,-0.65677E+00,& - -0.65695E+00,-0.65714E+00,-0.65733E+00,-0.65752E+00,-0.65771E+00,& - -0.65790E+00,-0.65809E+00,-0.65828E+00,-0.65848E+00,-0.65867E+00,& - -0.65886E+00,-0.65906E+00,-0.65925E+00,-0.65945E+00,-0.65964E+00,& - -0.65984E+00,-0.66004E+00,-0.66024E+00,-0.66043E+00,-0.66063E+00,& - -0.66083E+00,-0.66103E+00,-0.66123E+00,-0.66143E+00,-0.66164E+00,& - -0.66184E+00,-0.66204E+00,-0.66225E+00,-0.66245E+00,-0.66265E+00,& - -0.66286E+00,-0.66307E+00,-0.66327E+00,-0.66348E+00,-0.66369E+00/ - - DATA (BNC13M (IA),IA=501,600)/ & - -0.66389E+00,-0.66410E+00,-0.66431E+00,-0.66452E+00,-0.66473E+00,& - -0.66494E+00,-0.66515E+00,-0.66537E+00,-0.66558E+00,-0.66579E+00,& - -0.66601E+00,-0.66622E+00,-0.66643E+00,-0.66665E+00,-0.66687E+00,& - -0.66708E+00,-0.66730E+00,-0.66752E+00,-0.66773E+00,-0.66795E+00,& - -0.66817E+00,-0.66839E+00,-0.66861E+00,-0.66883E+00,-0.66905E+00,& - -0.66928E+00,-0.66950E+00,-0.66972E+00,-0.66994E+00,-0.67017E+00,& - -0.67039E+00,-0.67062E+00,-0.67084E+00,-0.67107E+00,-0.67130E+00,& - -0.67152E+00,-0.67175E+00,-0.67198E+00,-0.67221E+00,-0.67244E+00,& - -0.67267E+00,-0.67290E+00,-0.67313E+00,-0.67336E+00,-0.67359E+00,& - -0.67382E+00,-0.67406E+00,-0.67429E+00,-0.67452E+00,-0.67476E+00,& - -0.67499E+00,-0.67523E+00,-0.67546E+00,-0.67570E+00,-0.67594E+00,& - -0.67617E+00,-0.67641E+00,-0.67665E+00,-0.67689E+00,-0.67713E+00,& - -0.67737E+00,-0.67761E+00,-0.67785E+00,-0.67809E+00,-0.67833E+00,& - -0.67857E+00,-0.67882E+00,-0.67906E+00,-0.67931E+00,-0.67955E+00,& - -0.67979E+00,-0.68004E+00,-0.68029E+00,-0.68053E+00,-0.68078E+00,& - -0.68103E+00,-0.68127E+00,-0.68152E+00,-0.68177E+00,-0.68202E+00,& - -0.68227E+00,-0.68252E+00,-0.68277E+00,-0.68302E+00,-0.68327E+00,& - -0.68352E+00,-0.68378E+00,-0.68403E+00,-0.68428E+00,-0.68454E+00,& - -0.68479E+00,-0.68505E+00,-0.68530E+00,-0.68556E+00,-0.68581E+00,& - -0.68607E+00,-0.68633E+00,-0.68659E+00,-0.68684E+00,-0.68782E+00/ - - - - DATA (BNC13M (IA),IA=601,700)/ & - -0.68998E+00,-0.69264E+00,-0.69534E+00,-0.69809E+00,-0.70088E+00,& - -0.70371E+00,-0.70659E+00,-0.70950E+00,-0.71245E+00,-0.71544E+00,& - -0.71847E+00,-0.72154E+00,-0.72464E+00,-0.72778E+00,-0.73095E+00,& - -0.73416E+00,-0.73741E+00,-0.74068E+00,-0.74399E+00,-0.74733E+00,& - -0.75070E+00,-0.75411E+00,-0.75754E+00,-0.76101E+00,-0.76450E+00,& - -0.76802E+00,-0.77157E+00,-0.77515E+00,-0.77876E+00,-0.78239E+00,& - -0.78605E+00,-0.78974E+00,-0.79345E+00,-0.79719E+00,-0.80095E+00,& - -0.80474E+00,-0.80855E+00,-0.81239E+00,-0.81625E+00,-0.82013E+00,& - -0.82403E+00,-0.82796E+00,-0.83191E+00,-0.83588E+00,-0.83987E+00,& - -0.84388E+00,-0.84792E+00,-0.85197E+00,-0.85604E+00,-0.86014E+00,& - -0.86425E+00,-0.86838E+00,-0.87253E+00,-0.87670E+00,-0.88089E+00,& - -0.88510E+00,-0.88932E+00,-0.89356E+00,-0.89782E+00,-0.90210E+00,& - -0.90639E+00,-0.91070E+00,-0.91503E+00,-0.91937E+00,-0.92373E+00,& - -0.92811E+00,-0.93250E+00,-0.93690E+00,-0.94132E+00,-0.94576E+00,& - -0.95021E+00,-0.95467E+00,-0.95915E+00,-0.96365E+00,-0.96815E+00,& - -0.97267E+00,-0.97721E+00,-0.98176E+00,-0.98632E+00,-0.99089E+00,& - -0.99548E+00,-0.10001E+01,-0.10047E+01,-0.10093E+01,-0.10140E+01,& - -0.10186E+01,-0.10233E+01,-0.10279E+01,-0.10326E+01,-0.10373E+01,& - -0.10420E+01,-0.10468E+01,-0.10515E+01,-0.10562E+01,-0.10610E+01,& - -0.10657E+01,-0.10705E+01,-0.10753E+01,-0.10801E+01,-0.10849E+01/ - - DATA (BNC13M(IA),IA=701,741)/ & - -0.10897E+01,-0.10945E+01,-0.10994E+01,-0.11042E+01,-0.11091E+01,& - -0.11139E+01,-0.11188E+01,-0.11237E+01,-0.11286E+01,-0.11335E+01,& - -0.11384E+01,-0.11433E+01,-0.11483E+01,-0.11532E+01,-0.11582E+01,& - -0.11631E+01,-0.11681E+01,-0.11730E+01,-0.11780E+01,-0.11830E+01,& - -0.11880E+01,-0.11930E+01,-0.11980E+01,-0.12031E+01,-0.12081E+01,& - -0.12131E+01,-0.12182E+01,-0.12232E+01,-0.12283E+01,-0.12333E+01,& - -0.12384E+01,-0.12435E+01,-0.12486E+01,-0.12537E+01,-0.12588E+01,& - -0.12639E+01,-0.12690E+01,-0.12741E+01,-0.12793E+01,-0.12844E+01,& - -0.12896E+01 / -! END - -! ** TEMP = 248.0 - -! BLOCK DATA KMCF248 -! -! ** Common block definition -! -! COMMON /KMC248/ & -! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & -! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & -! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & - ! BNC13M( 741) -! -! ** NaCl -! - DATA (BNC01M (IA),IA= 1,100)/ & - -0.52363E-01,-0.92329E-01,-0.11821E+00,-0.13443E+00,-0.14598E+00,& - -0.15471E+00,-0.16154E+00,-0.16698E+00,-0.17138E+00,-0.17496E+00,& - -0.17787E+00,-0.18024E+00,-0.18214E+00,-0.18366E+00,-0.18484E+00,& - -0.18573E+00,-0.18637E+00,-0.18679E+00,-0.18701E+00,-0.18706E+00,& - -0.18695E+00,-0.18669E+00,-0.18632E+00,-0.18583E+00,-0.18523E+00,& - -0.18454E+00,-0.18377E+00,-0.18292E+00,-0.18200E+00,-0.18102E+00,& - -0.17998E+00,-0.17889E+00,-0.17775E+00,-0.17657E+00,-0.17535E+00,& - -0.17409E+00,-0.17280E+00,-0.17147E+00,-0.17013E+00,-0.16876E+00,& - -0.16736E+00,-0.16595E+00,-0.16452E+00,-0.16307E+00,-0.16161E+00,& - -0.16013E+00,-0.15865E+00,-0.15715E+00,-0.15565E+00,-0.15413E+00,& - -0.15261E+00,-0.15108E+00,-0.14954E+00,-0.14800E+00,-0.14645E+00,& - -0.14490E+00,-0.14334E+00,-0.14178E+00,-0.14021E+00,-0.13864E+00,& - -0.13706E+00,-0.13548E+00,-0.13389E+00,-0.13229E+00,-0.13069E+00,& - -0.12909E+00,-0.12747E+00,-0.12585E+00,-0.12422E+00,-0.12258E+00,& - -0.12094E+00,-0.11928E+00,-0.11762E+00,-0.11594E+00,-0.11426E+00,& - -0.11256E+00,-0.11085E+00,-0.10913E+00,-0.10740E+00,-0.10565E+00,& - -0.10389E+00,-0.10212E+00,-0.10033E+00,-0.98525E-01,-0.96708E-01,& - -0.94877E-01,-0.93031E-01,-0.91169E-01,-0.89293E-01,-0.87402E-01,& - -0.85495E-01,-0.83574E-01,-0.81638E-01,-0.79687E-01,-0.77722E-01,& - -0.75743E-01,-0.73749E-01,-0.71742E-01,-0.69722E-01,-0.67689E-01/ - - DATA (BNC01M (IA),IA=101,200)/ & - -0.65644E-01,-0.63586E-01,-0.61517E-01,-0.59436E-01,-0.57345E-01,& - -0.55244E-01,-0.53133E-01,-0.51013E-01,-0.48884E-01,-0.46747E-01,& - -0.44603E-01,-0.42451E-01,-0.40292E-01,-0.38127E-01,-0.35957E-01,& - -0.33781E-01,-0.31601E-01,-0.29416E-01,-0.27227E-01,-0.25035E-01,& - -0.23114E-01,-0.20884E-01,-0.18655E-01,-0.16426E-01,-0.14199E-01,& - -0.11973E-01,-0.97477E-02,-0.75237E-02,-0.53010E-02,-0.30795E-02,& - -0.85942E-03, 0.13593E-02, 0.35765E-02, 0.57922E-02, 0.80063E-02,& - 0.10219E-01, 0.12430E-01, 0.14638E-01, 0.16846E-01, 0.19051E-01,& - 0.21255E-01, 0.23456E-01, 0.25656E-01, 0.27853E-01, 0.30049E-01,& - 0.32242E-01, 0.34434E-01, 0.36623E-01, 0.38810E-01, 0.40994E-01,& - 0.43177E-01, 0.45357E-01, 0.47535E-01, 0.49710E-01, 0.51883E-01,& - 0.54053E-01, 0.56221E-01, 0.58387E-01, 0.60550E-01, 0.62710E-01,& - 0.64868E-01, 0.67024E-01, 0.69176E-01, 0.71326E-01, 0.73474E-01,& - 0.75618E-01, 0.77760E-01, 0.79899E-01, 0.82036E-01, 0.84169E-01,& - 0.86300E-01, 0.88428E-01, 0.90554E-01, 0.92676E-01, 0.94796E-01,& - 0.96912E-01, 0.99026E-01, 0.10114E+00, 0.10324E+00, 0.10535E+00,& - 0.10745E+00, 0.10955E+00, 0.11165E+00, 0.11374E+00, 0.11583E+00,& - 0.11792E+00, 0.12000E+00, 0.12208E+00, 0.12416E+00, 0.12624E+00,& - 0.12831E+00, 0.13038E+00, 0.13244E+00, 0.13450E+00, 0.13656E+00,& - 0.13862E+00, 0.14067E+00, 0.14272E+00, 0.14477E+00, 0.14681E+00/ - - DATA (BNC01M (IA),IA=201,300)/ & - 0.14886E+00, 0.15089E+00, 0.15293E+00, 0.15496E+00, 0.15699E+00,& - 0.15901E+00, 0.16103E+00, 0.16305E+00, 0.16507E+00, 0.16708E+00,& - 0.16909E+00, 0.17110E+00, 0.17310E+00, 0.17510E+00, 0.17709E+00,& - 0.17909E+00, 0.18108E+00, 0.18306E+00, 0.18505E+00, 0.18703E+00,& - 0.18901E+00, 0.19098E+00, 0.19295E+00, 0.19492E+00, 0.19688E+00,& - 0.19884E+00, 0.20080E+00, 0.20276E+00, 0.20471E+00, 0.20666E+00,& - 0.20860E+00, 0.21054E+00, 0.21248E+00, 0.21442E+00, 0.21635E+00,& - 0.21828E+00, 0.22020E+00, 0.22213E+00, 0.22405E+00, 0.22596E+00,& - 0.22788E+00, 0.22979E+00, 0.23169E+00, 0.23360E+00, 0.23550E+00,& - 0.23739E+00, 0.23929E+00, 0.24118E+00, 0.24306E+00, 0.24495E+00,& - 0.24683E+00, 0.24871E+00, 0.25058E+00, 0.25245E+00, 0.25432E+00,& - 0.25619E+00, 0.25805E+00, 0.25991E+00, 0.26177E+00, 0.26362E+00,& - 0.26547E+00, 0.26731E+00, 0.26916E+00, 0.27100E+00, 0.27283E+00,& - 0.27467E+00, 0.27650E+00, 0.27833E+00, 0.28015E+00, 0.28197E+00,& - 0.28379E+00, 0.28560E+00, 0.28742E+00, 0.28923E+00, 0.29103E+00,& - 0.29283E+00, 0.29463E+00, 0.29643E+00, 0.29822E+00, 0.30001E+00,& - 0.30180E+00, 0.30359E+00, 0.30537E+00, 0.30715E+00, 0.30892E+00,& - 0.31069E+00, 0.31246E+00, 0.31423E+00, 0.31599E+00, 0.31775E+00,& - 0.31951E+00, 0.32126E+00, 0.32301E+00, 0.32476E+00, 0.32651E+00,& - 0.32825E+00, 0.32999E+00, 0.33172E+00, 0.33346E+00, 0.33518E+00/ - - DATA (BNC01M (IA),IA=301,400)/ & - 0.33691E+00, 0.33864E+00, 0.34036E+00, 0.34208E+00, 0.34379E+00,& - 0.34550E+00, 0.34721E+00, 0.34892E+00, 0.35062E+00, 0.35232E+00,& - 0.35402E+00, 0.35571E+00, 0.35741E+00, 0.35910E+00, 0.36078E+00,& - 0.36246E+00, 0.36414E+00, 0.36582E+00, 0.36750E+00, 0.36917E+00,& - 0.37084E+00, 0.37250E+00, 0.37417E+00, 0.37583E+00, 0.37748E+00,& - 0.37914E+00, 0.38079E+00, 0.38244E+00, 0.38409E+00, 0.38573E+00,& - 0.38737E+00, 0.38901E+00, 0.39064E+00, 0.39227E+00, 0.39390E+00,& - 0.39553E+00, 0.39715E+00, 0.39877E+00, 0.40039E+00, 0.40201E+00,& - 0.40362E+00, 0.40523E+00, 0.40684E+00, 0.40844E+00, 0.41004E+00,& - 0.41164E+00, 0.41324E+00, 0.41483E+00, 0.41642E+00, 0.41801E+00,& - 0.41960E+00, 0.42118E+00, 0.42276E+00, 0.42434E+00, 0.42591E+00,& - 0.42749E+00, 0.42906E+00, 0.43062E+00, 0.43219E+00, 0.43375E+00,& - 0.43531E+00, 0.43686E+00, 0.43842E+00, 0.43997E+00, 0.44152E+00,& - 0.44306E+00, 0.44461E+00, 0.44615E+00, 0.44769E+00, 0.44922E+00,& - 0.45075E+00, 0.45229E+00, 0.45381E+00, 0.45534E+00, 0.45686E+00,& - 0.45838E+00, 0.45990E+00, 0.46141E+00, 0.46293E+00, 0.46444E+00,& - 0.46594E+00, 0.46745E+00, 0.46895E+00, 0.47045E+00, 0.47195E+00,& - 0.47344E+00, 0.47494E+00, 0.47643E+00, 0.47791E+00, 0.47940E+00,& - 0.48088E+00, 0.48236E+00, 0.48384E+00, 0.48532E+00, 0.48679E+00,& - 0.48826E+00, 0.48973E+00, 0.49119E+00, 0.49266E+00, 0.49412E+00/ - - DATA (BNC01M (IA),IA=401,500)/ & - 0.49557E+00, 0.49703E+00, 0.49848E+00, 0.49993E+00, 0.50138E+00,& - 0.50283E+00, 0.50427E+00, 0.50572E+00, 0.50715E+00, 0.50859E+00,& - 0.51003E+00, 0.51146E+00, 0.51289E+00, 0.51432E+00, 0.51574E+00,& - 0.51716E+00, 0.51858E+00, 0.52000E+00, 0.52142E+00, 0.52283E+00,& - 0.52424E+00, 0.52565E+00, 0.52706E+00, 0.52846E+00, 0.52986E+00,& - 0.53126E+00, 0.53266E+00, 0.53406E+00, 0.53545E+00, 0.53684E+00,& - 0.53823E+00, 0.53962E+00, 0.54100E+00, 0.54238E+00, 0.54376E+00,& - 0.54514E+00, 0.54651E+00, 0.54789E+00, 0.54926E+00, 0.55062E+00,& - 0.55199E+00, 0.55335E+00, 0.55472E+00, 0.55608E+00, 0.55743E+00,& - 0.55879E+00, 0.56014E+00, 0.56149E+00, 0.56284E+00, 0.56419E+00,& - 0.56553E+00, 0.56688E+00, 0.56822E+00, 0.56955E+00, 0.57089E+00,& - 0.57222E+00, 0.57356E+00, 0.57488E+00, 0.57621E+00, 0.57754E+00,& - 0.57886E+00, 0.58018E+00, 0.58150E+00, 0.58282E+00, 0.58413E+00,& - 0.58545E+00, 0.58676E+00, 0.58806E+00, 0.58937E+00, 0.59068E+00,& - 0.59198E+00, 0.59328E+00, 0.59458E+00, 0.59587E+00, 0.59717E+00,& - 0.59846E+00, 0.59975E+00, 0.60104E+00, 0.60232E+00, 0.60361E+00,& - 0.60489E+00, 0.60617E+00, 0.60745E+00, 0.60872E+00, 0.61000E+00,& - 0.61127E+00, 0.61254E+00, 0.61381E+00, 0.61508E+00, 0.61634E+00,& - 0.61760E+00, 0.61886E+00, 0.62012E+00, 0.62138E+00, 0.62263E+00,& - 0.62388E+00, 0.62513E+00, 0.62638E+00, 0.62763E+00, 0.62887E+00/ - - DATA (BNC01M (IA),IA=501,600)/ & - 0.63012E+00, 0.63136E+00, 0.63260E+00, 0.63383E+00, 0.63507E+00,& - 0.63630E+00, 0.63753E+00, 0.63876E+00, 0.63999E+00, 0.64122E+00,& - 0.64244E+00, 0.64366E+00, 0.64488E+00, 0.64610E+00, 0.64732E+00,& - 0.64853E+00, 0.64975E+00, 0.65096E+00, 0.65217E+00, 0.65337E+00,& - 0.65458E+00, 0.65578E+00, 0.65698E+00, 0.65818E+00, 0.65938E+00,& - 0.66058E+00, 0.66177E+00, 0.66296E+00, 0.66415E+00, 0.66534E+00,& - 0.66653E+00, 0.66772E+00, 0.66890E+00, 0.67008E+00, 0.67126E+00,& - 0.67244E+00, 0.67362E+00, 0.67479E+00, 0.67596E+00, 0.67713E+00,& - 0.67830E+00, 0.67947E+00, 0.68064E+00, 0.68180E+00, 0.68296E+00,& - 0.68412E+00, 0.68528E+00, 0.68644E+00, 0.68760E+00, 0.68875E+00,& - 0.68990E+00, 0.69105E+00, 0.69220E+00, 0.69335E+00, 0.69449E+00,& - 0.69563E+00, 0.69678E+00, 0.69792E+00, 0.69905E+00, 0.70019E+00,& - 0.70133E+00, 0.70246E+00, 0.70359E+00, 0.70472E+00, 0.70585E+00,& - 0.70698E+00, 0.70810E+00, 0.70922E+00, 0.71035E+00, 0.71147E+00,& - 0.71258E+00, 0.71370E+00, 0.71482E+00, 0.71593E+00, 0.71704E+00,& - 0.71815E+00, 0.71926E+00, 0.72037E+00, 0.72147E+00, 0.72258E+00,& - 0.72368E+00, 0.72478E+00, 0.72588E+00, 0.72697E+00, 0.72807E+00,& - 0.72916E+00, 0.73026E+00, 0.73135E+00, 0.73244E+00, 0.73352E+00,& - 0.73461E+00, 0.73569E+00, 0.73678E+00, 0.73786E+00, 0.73894E+00,& - 0.74002E+00, 0.74109E+00, 0.74217E+00, 0.74324E+00, 0.74725E+00/ - - DATA (BNC01M (IA),IA=601,700)/ & - 0.75600E+00, 0.76647E+00, 0.77680E+00, 0.78697E+00, 0.79701E+00,& - 0.80690E+00, 0.81666E+00, 0.82629E+00, 0.83578E+00, 0.84515E+00,& - 0.85439E+00, 0.86350E+00, 0.87250E+00, 0.88138E+00, 0.89014E+00,& - 0.89879E+00, 0.90732E+00, 0.91574E+00, 0.92406E+00, 0.93227E+00,& - 0.94038E+00, 0.94838E+00, 0.95628E+00, 0.96409E+00, 0.97180E+00,& - 0.97941E+00, 0.98693E+00, 0.99435E+00, 0.10017E+01, 0.10089E+01,& - 0.10161E+01, 0.10232E+01, 0.10302E+01, 0.10371E+01, 0.10439E+01,& - 0.10506E+01, 0.10573E+01, 0.10639E+01, 0.10704E+01, 0.10768E+01,& - 0.10832E+01, 0.10895E+01, 0.10957E+01, 0.11018E+01, 0.11079E+01,& - 0.11139E+01, 0.11199E+01, 0.11257E+01, 0.11315E+01, 0.11373E+01,& - 0.11430E+01, 0.11486E+01, 0.11541E+01, 0.11596E+01, 0.11651E+01,& - 0.11704E+01, 0.11757E+01, 0.11810E+01, 0.11862E+01, 0.11913E+01,& - 0.11964E+01, 0.12015E+01, 0.12064E+01, 0.12114E+01, 0.12162E+01,& - 0.12211E+01, 0.12258E+01, 0.12306E+01, 0.12352E+01, 0.12399E+01,& - 0.12444E+01, 0.12490E+01, 0.12534E+01, 0.12579E+01, 0.12623E+01,& - 0.12666E+01, 0.12709E+01, 0.12751E+01, 0.12794E+01, 0.12835E+01,& - 0.12876E+01, 0.12917E+01, 0.12958E+01, 0.12998E+01, 0.13037E+01,& - 0.13076E+01, 0.13115E+01, 0.13153E+01, 0.13191E+01, 0.13229E+01,& - 0.13266E+01, 0.13303E+01, 0.13340E+01, 0.13376E+01, 0.13411E+01,& - 0.13447E+01, 0.13482E+01, 0.13517E+01, 0.13551E+01, 0.13585E+01/ - - DATA (BNC01M(IA),IA=701,741)/ & - 0.13619E+01, 0.13652E+01, 0.13685E+01, 0.13718E+01, 0.13750E+01,& - 0.13782E+01, 0.13814E+01, 0.13845E+01, 0.13876E+01, 0.13907E+01,& - 0.13937E+01, 0.13967E+01, 0.13997E+01, 0.14027E+01, 0.14056E+01,& - 0.14085E+01, 0.14114E+01, 0.14142E+01, 0.14170E+01, 0.14198E+01,& - 0.14226E+01, 0.14253E+01, 0.14280E+01, 0.14307E+01, 0.14333E+01,& - 0.14360E+01, 0.14386E+01, 0.14411E+01, 0.14437E+01, 0.14462E+01,& - 0.14487E+01, 0.14512E+01, 0.14536E+01, 0.14561E+01, 0.14585E+01,& - 0.14608E+01, 0.14632E+01, 0.14655E+01, 0.14678E+01, 0.14701E+01,& - 0.14724E+01 / -! -! ** Na2SO4 -! - DATA (BNC02M (IA),IA= 1,100)/ & - -0.10845E+00,-0.19833E+00,-0.26217E+00,-0.30599E+00,-0.34002E+00,& - -0.36806E+00,-0.39204E+00,-0.41305E+00,-0.43179E+00,-0.44872E+00,& - -0.46420E+00,-0.47846E+00,-0.49169E+00,-0.50405E+00,-0.51565E+00,& - -0.52658E+00,-0.53693E+00,-0.54675E+00,-0.55611E+00,-0.56505E+00,& - -0.57361E+00,-0.58182E+00,-0.58971E+00,-0.59731E+00,-0.60464E+00,& - -0.61173E+00,-0.61858E+00,-0.62522E+00,-0.63166E+00,-0.63792E+00,& - -0.64400E+00,-0.64991E+00,-0.65567E+00,-0.66129E+00,-0.66676E+00,& - -0.67211E+00,-0.67733E+00,-0.68243E+00,-0.68742E+00,-0.69231E+00,& - -0.69710E+00,-0.70178E+00,-0.70638E+00,-0.71089E+00,-0.71531E+00,& - -0.71965E+00,-0.72392E+00,-0.72811E+00,-0.73222E+00,-0.73627E+00,& - -0.74026E+00,-0.74418E+00,-0.74803E+00,-0.75183E+00,-0.75558E+00,& - -0.75926E+00,-0.76290E+00,-0.76648E+00,-0.77002E+00,-0.77350E+00,& - -0.77695E+00,-0.78034E+00,-0.78370E+00,-0.78701E+00,-0.79029E+00,& - -0.79352E+00,-0.79672E+00,-0.79988E+00,-0.80301E+00,-0.80610E+00,& - -0.80916E+00,-0.81219E+00,-0.81519E+00,-0.81816E+00,-0.82110E+00,& - -0.82401E+00,-0.82689E+00,-0.82975E+00,-0.83259E+00,-0.83540E+00,& - -0.83818E+00,-0.84095E+00,-0.84369E+00,-0.84641E+00,-0.84911E+00,& - -0.85178E+00,-0.85444E+00,-0.85708E+00,-0.85970E+00,-0.86230E+00,& - -0.86488E+00,-0.86745E+00,-0.87000E+00,-0.87253E+00,-0.87505E+00,& - -0.87755E+00,-0.88003E+00,-0.88250E+00,-0.88495E+00,-0.88739E+00/ - - DATA (BNC02M (IA),IA=101,200)/ & - -0.88982E+00,-0.89223E+00,-0.89462E+00,-0.89700E+00,-0.89937E+00,& - -0.90173E+00,-0.90407E+00,-0.90640E+00,-0.90872E+00,-0.91102E+00,& - -0.91332E+00,-0.91560E+00,-0.91786E+00,-0.92012E+00,-0.92236E+00,& - -0.92460E+00,-0.92682E+00,-0.92903E+00,-0.93123E+00,-0.93342E+00,& - -0.93555E+00,-0.93772E+00,-0.93988E+00,-0.94203E+00,-0.94417E+00,& - -0.94629E+00,-0.94841E+00,-0.95052E+00,-0.95262E+00,-0.95470E+00,& - -0.95678E+00,-0.95885E+00,-0.96090E+00,-0.96295E+00,-0.96499E+00,& - -0.96702E+00,-0.96904E+00,-0.97105E+00,-0.97305E+00,-0.97505E+00,& - -0.97703E+00,-0.97901E+00,-0.98098E+00,-0.98294E+00,-0.98489E+00,& - -0.98683E+00,-0.98877E+00,-0.99070E+00,-0.99262E+00,-0.99453E+00,& - -0.99643E+00,-0.99833E+00,-0.10002E+01,-0.10021E+01,-0.10040E+01,& - -0.10058E+01,-0.10077E+01,-0.10096E+01,-0.10114E+01,-0.10133E+01,& - -0.10151E+01,-0.10169E+01,-0.10187E+01,-0.10205E+01,-0.10224E+01,& - -0.10242E+01,-0.10260E+01,-0.10277E+01,-0.10295E+01,-0.10313E+01,& - -0.10331E+01,-0.10348E+01,-0.10366E+01,-0.10384E+01,-0.10401E+01,& - -0.10418E+01,-0.10436E+01,-0.10453E+01,-0.10470E+01,-0.10488E+01,& - -0.10505E+01,-0.10522E+01,-0.10539E+01,-0.10556E+01,-0.10573E+01,& - -0.10590E+01,-0.10606E+01,-0.10623E+01,-0.10640E+01,-0.10657E+01,& - -0.10673E+01,-0.10690E+01,-0.10706E+01,-0.10723E+01,-0.10739E+01,& - -0.10756E+01,-0.10772E+01,-0.10788E+01,-0.10805E+01,-0.10821E+01/ - - DATA (BNC02M (IA),IA=201,300)/ & - -0.10837E+01,-0.10853E+01,-0.10869E+01,-0.10885E+01,-0.10901E+01,& - -0.10917E+01,-0.10933E+01,-0.10949E+01,-0.10965E+01,-0.10981E+01,& - -0.10997E+01,-0.11012E+01,-0.11028E+01,-0.11044E+01,-0.11059E+01,& - -0.11075E+01,-0.11090E+01,-0.11106E+01,-0.11121E+01,-0.11137E+01,& - -0.11152E+01,-0.11167E+01,-0.11183E+01,-0.11198E+01,-0.11213E+01,& - -0.11228E+01,-0.11243E+01,-0.11259E+01,-0.11274E+01,-0.11289E+01,& - -0.11304E+01,-0.11319E+01,-0.11334E+01,-0.11349E+01,-0.11364E+01,& - -0.11378E+01,-0.11393E+01,-0.11408E+01,-0.11423E+01,-0.11437E+01,& - -0.11452E+01,-0.11467E+01,-0.11481E+01,-0.11496E+01,-0.11511E+01,& - -0.11525E+01,-0.11540E+01,-0.11554E+01,-0.11569E+01,-0.11583E+01,& - -0.11597E+01,-0.11612E+01,-0.11626E+01,-0.11640E+01,-0.11655E+01,& - -0.11669E+01,-0.11683E+01,-0.11697E+01,-0.11711E+01,-0.11726E+01,& - -0.11740E+01,-0.11754E+01,-0.11768E+01,-0.11782E+01,-0.11796E+01,& - -0.11810E+01,-0.11824E+01,-0.11838E+01,-0.11852E+01,-0.11865E+01,& - -0.11879E+01,-0.11893E+01,-0.11907E+01,-0.11921E+01,-0.11934E+01,& - -0.11948E+01,-0.11962E+01,-0.11976E+01,-0.11989E+01,-0.12003E+01,& - -0.12016E+01,-0.12030E+01,-0.12044E+01,-0.12057E+01,-0.12071E+01,& - -0.12084E+01,-0.12098E+01,-0.12111E+01,-0.12124E+01,-0.12138E+01,& - -0.12151E+01,-0.12165E+01,-0.12178E+01,-0.12191E+01,-0.12204E+01,& - -0.12218E+01,-0.12231E+01,-0.12244E+01,-0.12257E+01,-0.12271E+01/ - - DATA (BNC02M (IA),IA=301,400)/ & - -0.12284E+01,-0.12297E+01,-0.12310E+01,-0.12323E+01,-0.12336E+01,& - -0.12349E+01,-0.12362E+01,-0.12375E+01,-0.12388E+01,-0.12401E+01,& - -0.12414E+01,-0.12427E+01,-0.12440E+01,-0.12453E+01,-0.12466E+01,& - -0.12479E+01,-0.12491E+01,-0.12504E+01,-0.12517E+01,-0.12530E+01,& - -0.12543E+01,-0.12555E+01,-0.12568E+01,-0.12581E+01,-0.12593E+01,& - -0.12606E+01,-0.12619E+01,-0.12631E+01,-0.12644E+01,-0.12657E+01,& - -0.12669E+01,-0.12682E+01,-0.12694E+01,-0.12707E+01,-0.12719E+01,& - -0.12732E+01,-0.12744E+01,-0.12757E+01,-0.12769E+01,-0.12782E+01,& - -0.12794E+01,-0.12806E+01,-0.12819E+01,-0.12831E+01,-0.12844E+01,& - -0.12856E+01,-0.12868E+01,-0.12880E+01,-0.12893E+01,-0.12905E+01,& - -0.12917E+01,-0.12930E+01,-0.12942E+01,-0.12954E+01,-0.12966E+01,& - -0.12978E+01,-0.12990E+01,-0.13003E+01,-0.13015E+01,-0.13027E+01,& - -0.13039E+01,-0.13051E+01,-0.13063E+01,-0.13075E+01,-0.13087E+01,& - -0.13099E+01,-0.13111E+01,-0.13123E+01,-0.13135E+01,-0.13147E+01,& - -0.13159E+01,-0.13171E+01,-0.13183E+01,-0.13195E+01,-0.13207E+01,& - -0.13219E+01,-0.13230E+01,-0.13242E+01,-0.13254E+01,-0.13266E+01,& - -0.13278E+01,-0.13290E+01,-0.13301E+01,-0.13313E+01,-0.13325E+01,& - -0.13337E+01,-0.13348E+01,-0.13360E+01,-0.13372E+01,-0.13383E+01,& - -0.13395E+01,-0.13407E+01,-0.13418E+01,-0.13430E+01,-0.13442E+01,& - -0.13453E+01,-0.13465E+01,-0.13476E+01,-0.13488E+01,-0.13500E+01/ - - DATA (BNC02M (IA),IA=401,500)/ & - -0.13511E+01,-0.13523E+01,-0.13534E+01,-0.13546E+01,-0.13557E+01,& - -0.13569E+01,-0.13580E+01,-0.13592E+01,-0.13603E+01,-0.13615E+01,& - -0.13626E+01,-0.13637E+01,-0.13649E+01,-0.13660E+01,-0.13672E+01,& - -0.13683E+01,-0.13694E+01,-0.13706E+01,-0.13717E+01,-0.13728E+01,& - -0.13740E+01,-0.13751E+01,-0.13762E+01,-0.13774E+01,-0.13785E+01,& - -0.13796E+01,-0.13807E+01,-0.13819E+01,-0.13830E+01,-0.13841E+01,& - -0.13852E+01,-0.13863E+01,-0.13875E+01,-0.13886E+01,-0.13897E+01,& - -0.13908E+01,-0.13919E+01,-0.13930E+01,-0.13941E+01,-0.13952E+01,& - -0.13964E+01,-0.13975E+01,-0.13986E+01,-0.13997E+01,-0.14008E+01,& - -0.14019E+01,-0.14030E+01,-0.14041E+01,-0.14052E+01,-0.14063E+01,& - -0.14074E+01,-0.14085E+01,-0.14096E+01,-0.14107E+01,-0.14118E+01,& - -0.14129E+01,-0.14140E+01,-0.14151E+01,-0.14162E+01,-0.14172E+01,& - -0.14183E+01,-0.14194E+01,-0.14205E+01,-0.14216E+01,-0.14227E+01,& - -0.14238E+01,-0.14249E+01,-0.14259E+01,-0.14270E+01,-0.14281E+01,& - -0.14292E+01,-0.14303E+01,-0.14313E+01,-0.14324E+01,-0.14335E+01,& - -0.14346E+01,-0.14356E+01,-0.14367E+01,-0.14378E+01,-0.14389E+01,& - -0.14399E+01,-0.14410E+01,-0.14421E+01,-0.14431E+01,-0.14442E+01,& - -0.14453E+01,-0.14463E+01,-0.14474E+01,-0.14485E+01,-0.14495E+01,& - -0.14506E+01,-0.14517E+01,-0.14527E+01,-0.14538E+01,-0.14548E+01,& - -0.14559E+01,-0.14569E+01,-0.14580E+01,-0.14591E+01,-0.14601E+01/ - - DATA (BNC02M (IA),IA=501,600)/ & - -0.14612E+01,-0.14622E+01,-0.14633E+01,-0.14643E+01,-0.14654E+01,& - -0.14664E+01,-0.14675E+01,-0.14685E+01,-0.14696E+01,-0.14706E+01,& - -0.14717E+01,-0.14727E+01,-0.14737E+01,-0.14748E+01,-0.14758E+01,& - -0.14769E+01,-0.14779E+01,-0.14790E+01,-0.14800E+01,-0.14810E+01,& - -0.14821E+01,-0.14831E+01,-0.14841E+01,-0.14852E+01,-0.14862E+01,& - -0.14872E+01,-0.14883E+01,-0.14893E+01,-0.14903E+01,-0.14914E+01,& - -0.14924E+01,-0.14934E+01,-0.14945E+01,-0.14955E+01,-0.14965E+01,& - -0.14975E+01,-0.14986E+01,-0.14996E+01,-0.15006E+01,-0.15016E+01,& - -0.15027E+01,-0.15037E+01,-0.15047E+01,-0.15057E+01,-0.15068E+01,& - -0.15078E+01,-0.15088E+01,-0.15098E+01,-0.15108E+01,-0.15118E+01,& - -0.15129E+01,-0.15139E+01,-0.15149E+01,-0.15159E+01,-0.15169E+01,& - -0.15179E+01,-0.15189E+01,-0.15200E+01,-0.15210E+01,-0.15220E+01,& - -0.15230E+01,-0.15240E+01,-0.15250E+01,-0.15260E+01,-0.15270E+01,& - -0.15280E+01,-0.15290E+01,-0.15300E+01,-0.15310E+01,-0.15320E+01,& - -0.15330E+01,-0.15340E+01,-0.15350E+01,-0.15360E+01,-0.15370E+01,& - -0.15380E+01,-0.15390E+01,-0.15400E+01,-0.15410E+01,-0.15420E+01,& - -0.15430E+01,-0.15440E+01,-0.15450E+01,-0.15460E+01,-0.15470E+01,& - -0.15480E+01,-0.15490E+01,-0.15500E+01,-0.15510E+01,-0.15520E+01,& - -0.15529E+01,-0.15539E+01,-0.15549E+01,-0.15559E+01,-0.15569E+01,& - -0.15579E+01,-0.15589E+01,-0.15599E+01,-0.15608E+01,-0.15645E+01/ - - DATA (BNC02M (IA),IA=601,700)/ & - -0.15726E+01,-0.15824E+01,-0.15921E+01,-0.16017E+01,-0.16113E+01,& - -0.16208E+01,-0.16303E+01,-0.16397E+01,-0.16491E+01,-0.16584E+01,& - -0.16677E+01,-0.16770E+01,-0.16862E+01,-0.16954E+01,-0.17045E+01,& - -0.17136E+01,-0.17226E+01,-0.17316E+01,-0.17406E+01,-0.17495E+01,& - -0.17584E+01,-0.17673E+01,-0.17761E+01,-0.17849E+01,-0.17937E+01,& - -0.18024E+01,-0.18111E+01,-0.18198E+01,-0.18284E+01,-0.18370E+01,& - -0.18456E+01,-0.18542E+01,-0.18627E+01,-0.18712E+01,-0.18797E+01,& - -0.18881E+01,-0.18966E+01,-0.19050E+01,-0.19133E+01,-0.19217E+01,& - -0.19300E+01,-0.19383E+01,-0.19466E+01,-0.19548E+01,-0.19631E+01,& - -0.19713E+01,-0.19795E+01,-0.19876E+01,-0.19958E+01,-0.20039E+01,& - -0.20120E+01,-0.20201E+01,-0.20282E+01,-0.20362E+01,-0.20443E+01,& - -0.20523E+01,-0.20603E+01,-0.20682E+01,-0.20762E+01,-0.20841E+01,& - -0.20921E+01,-0.21000E+01,-0.21079E+01,-0.21157E+01,-0.21236E+01,& - -0.21314E+01,-0.21393E+01,-0.21471E+01,-0.21549E+01,-0.21626E+01,& - -0.21704E+01,-0.21782E+01,-0.21859E+01,-0.21936E+01,-0.22013E+01,& - -0.22090E+01,-0.22167E+01,-0.22244E+01,-0.22320E+01,-0.22396E+01,& - -0.22473E+01,-0.22549E+01,-0.22625E+01,-0.22701E+01,-0.22776E+01,& - -0.22852E+01,-0.22928E+01,-0.23003E+01,-0.23078E+01,-0.23153E+01,& - -0.23228E+01,-0.23303E+01,-0.23378E+01,-0.23453E+01,-0.23527E+01,& - -0.23602E+01,-0.23676E+01,-0.23750E+01,-0.23825E+01,-0.23899E+01/ - - DATA (BNC02M(IA),IA=701,741)/ & - -0.23973E+01,-0.24046E+01,-0.24120E+01,-0.24194E+01,-0.24267E+01,& - -0.24341E+01,-0.24414E+01,-0.24487E+01,-0.24560E+01,-0.24633E+01,& - -0.24706E+01,-0.24779E+01,-0.24852E+01,-0.24925E+01,-0.24997E+01,& - -0.25070E+01,-0.25142E+01,-0.25214E+01,-0.25287E+01,-0.25359E+01,& - -0.25431E+01,-0.25503E+01,-0.25575E+01,-0.25647E+01,-0.25718E+01,& - -0.25790E+01,-0.25862E+01,-0.25933E+01,-0.26004E+01,-0.26076E+01,& - -0.26147E+01,-0.26218E+01,-0.26289E+01,-0.26360E+01,-0.26431E+01,& - -0.26502E+01,-0.26573E+01,-0.26644E+01,-0.26714E+01,-0.26785E+01,& - -0.26856E+01 / -! -! ** NaNO3 -! - DATA (BNC03M (IA),IA= 1,100)/ & - -0.54405E-01,-0.99825E-01,-0.13234E+00,-0.15482E+00,-0.17238E+00,& - -0.18693E+00,-0.19943E+00,-0.21044E+00,-0.22031E+00,-0.22926E+00,& - -0.23748E+00,-0.24508E+00,-0.25216E+00,-0.25880E+00,-0.26505E+00,& - -0.27097E+00,-0.27658E+00,-0.28194E+00,-0.28705E+00,-0.29195E+00,& - -0.29665E+00,-0.30117E+00,-0.30553E+00,-0.30975E+00,-0.31382E+00,& - -0.31776E+00,-0.32159E+00,-0.32530E+00,-0.32891E+00,-0.33243E+00,& - -0.33585E+00,-0.33918E+00,-0.34243E+00,-0.34561E+00,-0.34871E+00,& - -0.35175E+00,-0.35472E+00,-0.35762E+00,-0.36047E+00,-0.36326E+00,& - -0.36599E+00,-0.36868E+00,-0.37131E+00,-0.37389E+00,-0.37643E+00,& - -0.37893E+00,-0.38138E+00,-0.38379E+00,-0.38617E+00,-0.38850E+00,& - -0.39080E+00,-0.39307E+00,-0.39530E+00,-0.39749E+00,-0.39966E+00,& - -0.40180E+00,-0.40391E+00,-0.40598E+00,-0.40804E+00,-0.41006E+00,& - -0.41206E+00,-0.41404E+00,-0.41599E+00,-0.41792E+00,-0.41983E+00,& - -0.42172E+00,-0.42359E+00,-0.42543E+00,-0.42726E+00,-0.42907E+00,& - -0.43087E+00,-0.43264E+00,-0.43440E+00,-0.43615E+00,-0.43787E+00,& - -0.43959E+00,-0.44129E+00,-0.44298E+00,-0.44465E+00,-0.44631E+00,& - -0.44796E+00,-0.44959E+00,-0.45122E+00,-0.45283E+00,-0.45444E+00,& - -0.45603E+00,-0.45761E+00,-0.45918E+00,-0.46075E+00,-0.46230E+00,& - -0.46385E+00,-0.46538E+00,-0.46691E+00,-0.46843E+00,-0.46994E+00,& - -0.47145E+00,-0.47294E+00,-0.47443E+00,-0.47591E+00,-0.47739E+00/ - - DATA (BNC03M (IA),IA=101,200)/ & - -0.47885E+00,-0.48031E+00,-0.48176E+00,-0.48321E+00,-0.48465E+00,& - -0.48608E+00,-0.48750E+00,-0.48892E+00,-0.49033E+00,-0.49174E+00,& - -0.49314E+00,-0.49453E+00,-0.49591E+00,-0.49729E+00,-0.49867E+00,& - -0.50003E+00,-0.50139E+00,-0.50275E+00,-0.50410E+00,-0.50544E+00,& - -0.50673E+00,-0.50806E+00,-0.50939E+00,-0.51071E+00,-0.51203E+00,& - -0.51334E+00,-0.51465E+00,-0.51594E+00,-0.51724E+00,-0.51852E+00,& - -0.51980E+00,-0.52108E+00,-0.52235E+00,-0.52361E+00,-0.52487E+00,& - -0.52612E+00,-0.52737E+00,-0.52861E+00,-0.52985E+00,-0.53108E+00,& - -0.53230E+00,-0.53353E+00,-0.53474E+00,-0.53595E+00,-0.53716E+00,& - -0.53836E+00,-0.53956E+00,-0.54075E+00,-0.54194E+00,-0.54312E+00,& - -0.54430E+00,-0.54548E+00,-0.54664E+00,-0.54781E+00,-0.54897E+00,& - -0.55013E+00,-0.55128E+00,-0.55243E+00,-0.55357E+00,-0.55471E+00,& - -0.55585E+00,-0.55698E+00,-0.55811E+00,-0.55923E+00,-0.56035E+00,& - -0.56147E+00,-0.56258E+00,-0.56369E+00,-0.56480E+00,-0.56590E+00,& - -0.56699E+00,-0.56809E+00,-0.56918E+00,-0.57027E+00,-0.57135E+00,& - -0.57243E+00,-0.57351E+00,-0.57458E+00,-0.57565E+00,-0.57671E+00,& - -0.57778E+00,-0.57884E+00,-0.57989E+00,-0.58095E+00,-0.58200E+00,& - -0.58304E+00,-0.58409E+00,-0.58513E+00,-0.58617E+00,-0.58720E+00,& - -0.58823E+00,-0.58926E+00,-0.59029E+00,-0.59131E+00,-0.59233E+00,& - -0.59334E+00,-0.59436E+00,-0.59537E+00,-0.59638E+00,-0.59738E+00/ - - DATA (BNC03M (IA),IA=201,300)/ & - -0.59839E+00,-0.59939E+00,-0.60038E+00,-0.60138E+00,-0.60237E+00,& - -0.60336E+00,-0.60434E+00,-0.60533E+00,-0.60631E+00,-0.60729E+00,& - -0.60826E+00,-0.60924E+00,-0.61021E+00,-0.61118E+00,-0.61214E+00,& - -0.61311E+00,-0.61407E+00,-0.61503E+00,-0.61598E+00,-0.61694E+00,& - -0.61789E+00,-0.61884E+00,-0.61979E+00,-0.62073E+00,-0.62167E+00,& - -0.62261E+00,-0.62355E+00,-0.62449E+00,-0.62542E+00,-0.62635E+00,& - -0.62728E+00,-0.62821E+00,-0.62913E+00,-0.63005E+00,-0.63097E+00,& - -0.63189E+00,-0.63281E+00,-0.63372E+00,-0.63463E+00,-0.63554E+00,& - -0.63645E+00,-0.63736E+00,-0.63826E+00,-0.63916E+00,-0.64006E+00,& - -0.64096E+00,-0.64186E+00,-0.64275E+00,-0.64364E+00,-0.64453E+00,& - -0.64542E+00,-0.64631E+00,-0.64719E+00,-0.64807E+00,-0.64896E+00,& - -0.64983E+00,-0.65071E+00,-0.65159E+00,-0.65246E+00,-0.65333E+00,& - -0.65420E+00,-0.65507E+00,-0.65594E+00,-0.65680E+00,-0.65766E+00,& - -0.65852E+00,-0.65938E+00,-0.66024E+00,-0.66110E+00,-0.66195E+00,& - -0.66281E+00,-0.66366E+00,-0.66451E+00,-0.66535E+00,-0.66620E+00,& - -0.66704E+00,-0.66789E+00,-0.66873E+00,-0.66957E+00,-0.67041E+00,& - -0.67124E+00,-0.67208E+00,-0.67291E+00,-0.67374E+00,-0.67457E+00,& - -0.67540E+00,-0.67623E+00,-0.67705E+00,-0.67788E+00,-0.67870E+00,& - -0.67952E+00,-0.68034E+00,-0.68116E+00,-0.68198E+00,-0.68279E+00,& - -0.68361E+00,-0.68442E+00,-0.68523E+00,-0.68604E+00,-0.68685E+00/ - - DATA (BNC03M (IA),IA=301,400)/ & - -0.68766E+00,-0.68846E+00,-0.68927E+00,-0.69007E+00,-0.69087E+00,& - -0.69167E+00,-0.69247E+00,-0.69327E+00,-0.69406E+00,-0.69486E+00,& - -0.69565E+00,-0.69644E+00,-0.69723E+00,-0.69802E+00,-0.69881E+00,& - -0.69960E+00,-0.70038E+00,-0.70117E+00,-0.70195E+00,-0.70273E+00,& - -0.70351E+00,-0.70429E+00,-0.70507E+00,-0.70585E+00,-0.70662E+00,& - -0.70740E+00,-0.70817E+00,-0.70894E+00,-0.70971E+00,-0.71048E+00,& - -0.71125E+00,-0.71202E+00,-0.71278E+00,-0.71355E+00,-0.71431E+00,& - -0.71507E+00,-0.71583E+00,-0.71659E+00,-0.71735E+00,-0.71811E+00,& - -0.71887E+00,-0.71962E+00,-0.72038E+00,-0.72113E+00,-0.72188E+00,& - -0.72263E+00,-0.72338E+00,-0.72413E+00,-0.72488E+00,-0.72563E+00,& - -0.72637E+00,-0.72712E+00,-0.72786E+00,-0.72860E+00,-0.72935E+00,& - -0.73009E+00,-0.73083E+00,-0.73156E+00,-0.73230E+00,-0.73304E+00,& - -0.73377E+00,-0.73451E+00,-0.73524E+00,-0.73597E+00,-0.73670E+00,& - -0.73743E+00,-0.73816E+00,-0.73889E+00,-0.73962E+00,-0.74034E+00,& - -0.74107E+00,-0.74179E+00,-0.74252E+00,-0.74324E+00,-0.74396E+00,& - -0.74468E+00,-0.74540E+00,-0.74612E+00,-0.74683E+00,-0.74755E+00,& - -0.74827E+00,-0.74898E+00,-0.74969E+00,-0.75041E+00,-0.75112E+00,& - -0.75183E+00,-0.75254E+00,-0.75325E+00,-0.75396E+00,-0.75467E+00,& - -0.75537E+00,-0.75608E+00,-0.75678E+00,-0.75749E+00,-0.75819E+00,& - -0.75889E+00,-0.75959E+00,-0.76029E+00,-0.76099E+00,-0.76169E+00/ - - DATA (BNC03M (IA),IA=401,500)/ & - -0.76239E+00,-0.76308E+00,-0.76378E+00,-0.76447E+00,-0.76517E+00,& - -0.76586E+00,-0.76655E+00,-0.76725E+00,-0.76794E+00,-0.76863E+00,& - -0.76932E+00,-0.77001E+00,-0.77069E+00,-0.77138E+00,-0.77207E+00,& - -0.77275E+00,-0.77344E+00,-0.77412E+00,-0.77480E+00,-0.77548E+00,& - -0.77616E+00,-0.77684E+00,-0.77752E+00,-0.77820E+00,-0.77888E+00,& - -0.77956E+00,-0.78024E+00,-0.78091E+00,-0.78159E+00,-0.78226E+00,& - -0.78293E+00,-0.78361E+00,-0.78428E+00,-0.78495E+00,-0.78562E+00,& - -0.78629E+00,-0.78696E+00,-0.78763E+00,-0.78829E+00,-0.78896E+00,& - -0.78963E+00,-0.79029E+00,-0.79096E+00,-0.79162E+00,-0.79228E+00,& - -0.79295E+00,-0.79361E+00,-0.79427E+00,-0.79493E+00,-0.79559E+00,& - -0.79625E+00,-0.79691E+00,-0.79756E+00,-0.79822E+00,-0.79888E+00,& - -0.79953E+00,-0.80019E+00,-0.80084E+00,-0.80149E+00,-0.80215E+00,& - -0.80280E+00,-0.80345E+00,-0.80410E+00,-0.80475E+00,-0.80540E+00,& - -0.80605E+00,-0.80670E+00,-0.80734E+00,-0.80799E+00,-0.80864E+00,& - -0.80928E+00,-0.80993E+00,-0.81057E+00,-0.81121E+00,-0.81186E+00,& - -0.81250E+00,-0.81314E+00,-0.81378E+00,-0.81442E+00,-0.81506E+00,& - -0.81570E+00,-0.81634E+00,-0.81698E+00,-0.81761E+00,-0.81825E+00,& - -0.81888E+00,-0.81952E+00,-0.82015E+00,-0.82079E+00,-0.82142E+00,& - -0.82205E+00,-0.82269E+00,-0.82332E+00,-0.82395E+00,-0.82458E+00,& - -0.82521E+00,-0.82584E+00,-0.82647E+00,-0.82710E+00,-0.82772E+00/ - - DATA (BNC03M (IA),IA=501,600)/ & - -0.82835E+00,-0.82898E+00,-0.82960E+00,-0.83023E+00,-0.83085E+00,& - -0.83147E+00,-0.83210E+00,-0.83272E+00,-0.83334E+00,-0.83397E+00,& - -0.83459E+00,-0.83521E+00,-0.83583E+00,-0.83645E+00,-0.83706E+00,& - -0.83768E+00,-0.83830E+00,-0.83892E+00,-0.83953E+00,-0.84015E+00,& - -0.84077E+00,-0.84138E+00,-0.84200E+00,-0.84261E+00,-0.84322E+00,& - -0.84384E+00,-0.84445E+00,-0.84506E+00,-0.84567E+00,-0.84628E+00,& - -0.84689E+00,-0.84750E+00,-0.84811E+00,-0.84872E+00,-0.84933E+00,& - -0.84993E+00,-0.85054E+00,-0.85115E+00,-0.85175E+00,-0.85236E+00,& - -0.85296E+00,-0.85357E+00,-0.85417E+00,-0.85478E+00,-0.85538E+00,& - -0.85598E+00,-0.85658E+00,-0.85718E+00,-0.85779E+00,-0.85839E+00,& - -0.85899E+00,-0.85959E+00,-0.86018E+00,-0.86078E+00,-0.86138E+00,& - -0.86198E+00,-0.86257E+00,-0.86317E+00,-0.86377E+00,-0.86436E+00,& - -0.86496E+00,-0.86555E+00,-0.86615E+00,-0.86674E+00,-0.86733E+00,& - -0.86793E+00,-0.86852E+00,-0.86911E+00,-0.86970E+00,-0.87029E+00,& - -0.87088E+00,-0.87147E+00,-0.87206E+00,-0.87265E+00,-0.87324E+00,& - -0.87383E+00,-0.87441E+00,-0.87500E+00,-0.87559E+00,-0.87617E+00,& - -0.87676E+00,-0.87734E+00,-0.87793E+00,-0.87851E+00,-0.87910E+00,& - -0.87968E+00,-0.88026E+00,-0.88085E+00,-0.88143E+00,-0.88201E+00,& - -0.88259E+00,-0.88317E+00,-0.88375E+00,-0.88433E+00,-0.88491E+00,& - -0.88549E+00,-0.88607E+00,-0.88665E+00,-0.88723E+00,-0.88939E+00/ - - DATA (BNC03M (IA),IA=601,700)/ & - -0.89413E+00,-0.89983E+00,-0.90549E+00,-0.91112E+00,-0.91671E+00,& - -0.92226E+00,-0.92777E+00,-0.93325E+00,-0.93869E+00,-0.94410E+00,& - -0.94948E+00,-0.95483E+00,-0.96015E+00,-0.96543E+00,-0.97069E+00,& - -0.97592E+00,-0.98112E+00,-0.98629E+00,-0.99143E+00,-0.99655E+00,& - -0.10016E+01,-0.10067E+01,-0.10118E+01,-0.10168E+01,-0.10218E+01,& - -0.10267E+01,-0.10317E+01,-0.10366E+01,-0.10415E+01,-0.10464E+01,& - -0.10513E+01,-0.10561E+01,-0.10609E+01,-0.10658E+01,-0.10705E+01,& - -0.10753E+01,-0.10801E+01,-0.10848E+01,-0.10895E+01,-0.10942E+01,& - -0.10989E+01,-0.11035E+01,-0.11082E+01,-0.11128E+01,-0.11174E+01,& - -0.11220E+01,-0.11266E+01,-0.11311E+01,-0.11357E+01,-0.11402E+01,& - -0.11447E+01,-0.11493E+01,-0.11537E+01,-0.11582E+01,-0.11627E+01,& - -0.11671E+01,-0.11716E+01,-0.11760E+01,-0.11804E+01,-0.11848E+01,& - -0.11892E+01,-0.11936E+01,-0.11979E+01,-0.12023E+01,-0.12066E+01,& - -0.12109E+01,-0.12153E+01,-0.12196E+01,-0.12239E+01,-0.12281E+01,& - -0.12324E+01,-0.12367E+01,-0.12409E+01,-0.12452E+01,-0.12494E+01,& - -0.12536E+01,-0.12578E+01,-0.12620E+01,-0.12662E+01,-0.12704E+01,& - -0.12746E+01,-0.12787E+01,-0.12829E+01,-0.12870E+01,-0.12912E+01,& - -0.12953E+01,-0.12994E+01,-0.13035E+01,-0.13076E+01,-0.13117E+01,& - -0.13158E+01,-0.13199E+01,-0.13239E+01,-0.13280E+01,-0.13320E+01,& - -0.13361E+01,-0.13401E+01,-0.13441E+01,-0.13482E+01,-0.13522E+01/ - - DATA (BNC03M(IA),IA=701,741)/ & - -0.13562E+01,-0.13602E+01,-0.13642E+01,-0.13682E+01,-0.13721E+01,& - -0.13761E+01,-0.13801E+01,-0.13840E+01,-0.13880E+01,-0.13919E+01,& - -0.13959E+01,-0.13998E+01,-0.14037E+01,-0.14076E+01,-0.14115E+01,& - -0.14154E+01,-0.14193E+01,-0.14232E+01,-0.14271E+01,-0.14310E+01,& - -0.14349E+01,-0.14387E+01,-0.14426E+01,-0.14464E+01,-0.14503E+01,& - -0.14541E+01,-0.14580E+01,-0.14618E+01,-0.14656E+01,-0.14695E+01,& - -0.14733E+01,-0.14771E+01,-0.14809E+01,-0.14847E+01,-0.14885E+01,& - -0.14923E+01,-0.14961E+01,-0.14998E+01,-0.15036E+01,-0.15074E+01,& - -0.15112E+01 / -! -! ** (NH4)2SO4 -! - DATA (BNC04M (IA),IA= 1,100)/ & - -0.10856E+00,-0.19872E+00,-0.26292E+00,-0.30708E+00,-0.34142E+00,& - -0.36979E+00,-0.39407E+00,-0.41538E+00,-0.43441E+00,-0.45164E+00,& - -0.46739E+00,-0.48193E+00,-0.49544E+00,-0.50808E+00,-0.51994E+00,& - -0.53114E+00,-0.54176E+00,-0.55184E+00,-0.56146E+00,-0.57065E+00,& - -0.57946E+00,-0.58792E+00,-0.59606E+00,-0.60391E+00,-0.61148E+00,& - -0.61880E+00,-0.62590E+00,-0.63277E+00,-0.63944E+00,-0.64593E+00,& - -0.65223E+00,-0.65837E+00,-0.66435E+00,-0.67019E+00,-0.67588E+00,& - -0.68144E+00,-0.68688E+00,-0.69219E+00,-0.69739E+00,-0.70249E+00,& - -0.70748E+00,-0.71237E+00,-0.71716E+00,-0.72187E+00,-0.72648E+00,& - -0.73102E+00,-0.73548E+00,-0.73985E+00,-0.74416E+00,-0.74840E+00,& - -0.75256E+00,-0.75666E+00,-0.76070E+00,-0.76468E+00,-0.76860E+00,& - -0.77246E+00,-0.77627E+00,-0.78002E+00,-0.78373E+00,-0.78739E+00,& - -0.79099E+00,-0.79456E+00,-0.79808E+00,-0.80155E+00,-0.80499E+00,& - -0.80839E+00,-0.81175E+00,-0.81507E+00,-0.81835E+00,-0.82160E+00,& - -0.82482E+00,-0.82801E+00,-0.83116E+00,-0.83428E+00,-0.83738E+00,& - -0.84045E+00,-0.84349E+00,-0.84650E+00,-0.84949E+00,-0.85245E+00,& - -0.85539E+00,-0.85831E+00,-0.86120E+00,-0.86407E+00,-0.86692E+00,& - -0.86975E+00,-0.87256E+00,-0.87535E+00,-0.87812E+00,-0.88088E+00,& - -0.88361E+00,-0.88633E+00,-0.88903E+00,-0.89172E+00,-0.89438E+00,& - -0.89704E+00,-0.89967E+00,-0.90229E+00,-0.90490E+00,-0.90749E+00/ - - DATA (BNC04M (IA),IA=101,200)/ & - -0.91007E+00,-0.91263E+00,-0.91518E+00,-0.91772E+00,-0.92024E+00,& - -0.92275E+00,-0.92524E+00,-0.92772E+00,-0.93019E+00,-0.93265E+00,& - -0.93509E+00,-0.93752E+00,-0.93994E+00,-0.94235E+00,-0.94475E+00,& - -0.94713E+00,-0.94950E+00,-0.95186E+00,-0.95421E+00,-0.95655E+00,& - -0.95881E+00,-0.96113E+00,-0.96344E+00,-0.96574E+00,-0.96803E+00,& - -0.97031E+00,-0.97257E+00,-0.97483E+00,-0.97707E+00,-0.97930E+00,& - -0.98153E+00,-0.98374E+00,-0.98594E+00,-0.98813E+00,-0.99032E+00,& - -0.99249E+00,-0.99465E+00,-0.99681E+00,-0.99895E+00,-0.10011E+01,& - -0.10032E+01,-0.10053E+01,-0.10074E+01,-0.10095E+01,-0.10116E+01,& - -0.10137E+01,-0.10158E+01,-0.10179E+01,-0.10199E+01,-0.10220E+01,& - -0.10240E+01,-0.10260E+01,-0.10281E+01,-0.10301E+01,-0.10321E+01,& - -0.10341E+01,-0.10361E+01,-0.10381E+01,-0.10401E+01,-0.10420E+01,& - -0.10440E+01,-0.10460E+01,-0.10479E+01,-0.10499E+01,-0.10518E+01,& - -0.10537E+01,-0.10556E+01,-0.10576E+01,-0.10595E+01,-0.10614E+01,& - -0.10633E+01,-0.10652E+01,-0.10671E+01,-0.10689E+01,-0.10708E+01,& - -0.10727E+01,-0.10746E+01,-0.10764E+01,-0.10783E+01,-0.10801E+01,& - -0.10819E+01,-0.10838E+01,-0.10856E+01,-0.10874E+01,-0.10892E+01,& - -0.10911E+01,-0.10929E+01,-0.10947E+01,-0.10965E+01,-0.10983E+01,& - -0.11000E+01,-0.11018E+01,-0.11036E+01,-0.11054E+01,-0.11071E+01,& - -0.11089E+01,-0.11106E+01,-0.11124E+01,-0.11141E+01,-0.11159E+01/ - - DATA (BNC04M (IA),IA=201,300)/ & - -0.11176E+01,-0.11193E+01,-0.11211E+01,-0.11228E+01,-0.11245E+01,& - -0.11262E+01,-0.11279E+01,-0.11296E+01,-0.11313E+01,-0.11330E+01,& - -0.11347E+01,-0.11364E+01,-0.11381E+01,-0.11398E+01,-0.11414E+01,& - -0.11431E+01,-0.11448E+01,-0.11464E+01,-0.11481E+01,-0.11497E+01,& - -0.11514E+01,-0.11530E+01,-0.11547E+01,-0.11563E+01,-0.11579E+01,& - -0.11596E+01,-0.11612E+01,-0.11628E+01,-0.11644E+01,-0.11660E+01,& - -0.11677E+01,-0.11693E+01,-0.11709E+01,-0.11725E+01,-0.11741E+01,& - -0.11757E+01,-0.11772E+01,-0.11788E+01,-0.11804E+01,-0.11820E+01,& - -0.11836E+01,-0.11851E+01,-0.11867E+01,-0.11883E+01,-0.11898E+01,& - -0.11914E+01,-0.11929E+01,-0.11945E+01,-0.11960E+01,-0.11976E+01,& - -0.11991E+01,-0.12007E+01,-0.12022E+01,-0.12037E+01,-0.12053E+01,& - -0.12068E+01,-0.12083E+01,-0.12098E+01,-0.12114E+01,-0.12129E+01,& - -0.12144E+01,-0.12159E+01,-0.12174E+01,-0.12189E+01,-0.12204E+01,& - -0.12219E+01,-0.12234E+01,-0.12249E+01,-0.12264E+01,-0.12278E+01,& - -0.12293E+01,-0.12308E+01,-0.12323E+01,-0.12338E+01,-0.12352E+01,& - -0.12367E+01,-0.12382E+01,-0.12396E+01,-0.12411E+01,-0.12426E+01,& - -0.12440E+01,-0.12455E+01,-0.12469E+01,-0.12484E+01,-0.12498E+01,& - -0.12513E+01,-0.12527E+01,-0.12541E+01,-0.12556E+01,-0.12570E+01,& - -0.12584E+01,-0.12599E+01,-0.12613E+01,-0.12627E+01,-0.12641E+01,& - -0.12655E+01,-0.12670E+01,-0.12684E+01,-0.12698E+01,-0.12712E+01/ - - DATA (BNC04M (IA),IA=301,400)/ & - -0.12726E+01,-0.12740E+01,-0.12754E+01,-0.12768E+01,-0.12782E+01,& - -0.12796E+01,-0.12810E+01,-0.12824E+01,-0.12838E+01,-0.12852E+01,& - -0.12866E+01,-0.12879E+01,-0.12893E+01,-0.12907E+01,-0.12921E+01,& - -0.12934E+01,-0.12948E+01,-0.12962E+01,-0.12976E+01,-0.12989E+01,& - -0.13003E+01,-0.13016E+01,-0.13030E+01,-0.13044E+01,-0.13057E+01,& - -0.13071E+01,-0.13084E+01,-0.13098E+01,-0.13111E+01,-0.13125E+01,& - -0.13138E+01,-0.13152E+01,-0.13165E+01,-0.13178E+01,-0.13192E+01,& - -0.13205E+01,-0.13218E+01,-0.13232E+01,-0.13245E+01,-0.13258E+01,& - -0.13271E+01,-0.13285E+01,-0.13298E+01,-0.13311E+01,-0.13324E+01,& - -0.13337E+01,-0.13351E+01,-0.13364E+01,-0.13377E+01,-0.13390E+01,& - -0.13403E+01,-0.13416E+01,-0.13429E+01,-0.13442E+01,-0.13455E+01,& - -0.13468E+01,-0.13481E+01,-0.13494E+01,-0.13507E+01,-0.13520E+01,& - -0.13533E+01,-0.13546E+01,-0.13558E+01,-0.13571E+01,-0.13584E+01,& - -0.13597E+01,-0.13610E+01,-0.13623E+01,-0.13635E+01,-0.13648E+01,& - -0.13661E+01,-0.13674E+01,-0.13686E+01,-0.13699E+01,-0.13712E+01,& - -0.13724E+01,-0.13737E+01,-0.13750E+01,-0.13762E+01,-0.13775E+01,& - -0.13787E+01,-0.13800E+01,-0.13812E+01,-0.13825E+01,-0.13838E+01,& - -0.13850E+01,-0.13863E+01,-0.13875E+01,-0.13887E+01,-0.13900E+01,& - -0.13912E+01,-0.13925E+01,-0.13937E+01,-0.13950E+01,-0.13962E+01,& - -0.13974E+01,-0.13987E+01,-0.13999E+01,-0.14011E+01,-0.14024E+01/ - - DATA (BNC04M (IA),IA=401,500)/ & - -0.14036E+01,-0.14048E+01,-0.14060E+01,-0.14073E+01,-0.14085E+01,& - -0.14097E+01,-0.14109E+01,-0.14122E+01,-0.14134E+01,-0.14146E+01,& - -0.14158E+01,-0.14170E+01,-0.14182E+01,-0.14195E+01,-0.14207E+01,& - -0.14219E+01,-0.14231E+01,-0.14243E+01,-0.14255E+01,-0.14267E+01,& - -0.14279E+01,-0.14291E+01,-0.14303E+01,-0.14315E+01,-0.14327E+01,& - -0.14339E+01,-0.14351E+01,-0.14363E+01,-0.14375E+01,-0.14387E+01,& - -0.14399E+01,-0.14411E+01,-0.14422E+01,-0.14434E+01,-0.14446E+01,& - -0.14458E+01,-0.14470E+01,-0.14482E+01,-0.14493E+01,-0.14505E+01,& - -0.14517E+01,-0.14529E+01,-0.14541E+01,-0.14552E+01,-0.14564E+01,& - -0.14576E+01,-0.14587E+01,-0.14599E+01,-0.14611E+01,-0.14623E+01,& - -0.14634E+01,-0.14646E+01,-0.14658E+01,-0.14669E+01,-0.14681E+01,& - -0.14692E+01,-0.14704E+01,-0.14716E+01,-0.14727E+01,-0.14739E+01,& - -0.14750E+01,-0.14762E+01,-0.14773E+01,-0.14785E+01,-0.14797E+01,& - -0.14808E+01,-0.14820E+01,-0.14831E+01,-0.14842E+01,-0.14854E+01,& - -0.14865E+01,-0.14877E+01,-0.14888E+01,-0.14900E+01,-0.14911E+01,& - -0.14923E+01,-0.14934E+01,-0.14945E+01,-0.14957E+01,-0.14968E+01,& - -0.14979E+01,-0.14991E+01,-0.15002E+01,-0.15013E+01,-0.15025E+01,& - -0.15036E+01,-0.15047E+01,-0.15059E+01,-0.15070E+01,-0.15081E+01,& - -0.15092E+01,-0.15104E+01,-0.15115E+01,-0.15126E+01,-0.15137E+01,& - -0.15149E+01,-0.15160E+01,-0.15171E+01,-0.15182E+01,-0.15193E+01/ - - DATA (BNC04M (IA),IA=501,600)/ & - -0.15204E+01,-0.15216E+01,-0.15227E+01,-0.15238E+01,-0.15249E+01,& - -0.15260E+01,-0.15271E+01,-0.15282E+01,-0.15293E+01,-0.15305E+01,& - -0.15316E+01,-0.15327E+01,-0.15338E+01,-0.15349E+01,-0.15360E+01,& - -0.15371E+01,-0.15382E+01,-0.15393E+01,-0.15404E+01,-0.15415E+01,& - -0.15426E+01,-0.15437E+01,-0.15448E+01,-0.15459E+01,-0.15470E+01,& - -0.15481E+01,-0.15492E+01,-0.15502E+01,-0.15513E+01,-0.15524E+01,& - -0.15535E+01,-0.15546E+01,-0.15557E+01,-0.15568E+01,-0.15579E+01,& - -0.15590E+01,-0.15600E+01,-0.15611E+01,-0.15622E+01,-0.15633E+01,& - -0.15644E+01,-0.15655E+01,-0.15665E+01,-0.15676E+01,-0.15687E+01,& - -0.15698E+01,-0.15708E+01,-0.15719E+01,-0.15730E+01,-0.15741E+01,& - -0.15751E+01,-0.15762E+01,-0.15773E+01,-0.15784E+01,-0.15794E+01,& - -0.15805E+01,-0.15816E+01,-0.15826E+01,-0.15837E+01,-0.15848E+01,& - -0.15858E+01,-0.15869E+01,-0.15880E+01,-0.15890E+01,-0.15901E+01,& - -0.15912E+01,-0.15922E+01,-0.15933E+01,-0.15943E+01,-0.15954E+01,& - -0.15965E+01,-0.15975E+01,-0.15986E+01,-0.15996E+01,-0.16007E+01,& - -0.16017E+01,-0.16028E+01,-0.16038E+01,-0.16049E+01,-0.16059E+01,& - -0.16070E+01,-0.16080E+01,-0.16091E+01,-0.16101E+01,-0.16112E+01,& - -0.16122E+01,-0.16133E+01,-0.16143E+01,-0.16154E+01,-0.16164E+01,& - -0.16175E+01,-0.16185E+01,-0.16196E+01,-0.16206E+01,-0.16216E+01,& - -0.16227E+01,-0.16237E+01,-0.16248E+01,-0.16258E+01,-0.16297E+01/ - - DATA (BNC04M (IA),IA=601,700)/ & - -0.16382E+01,-0.16485E+01,-0.16587E+01,-0.16688E+01,-0.16789E+01,& - -0.16890E+01,-0.16989E+01,-0.17088E+01,-0.17187E+01,-0.17285E+01,& - -0.17383E+01,-0.17480E+01,-0.17576E+01,-0.17673E+01,-0.17768E+01,& - -0.17863E+01,-0.17958E+01,-0.18053E+01,-0.18146E+01,-0.18240E+01,& - -0.18333E+01,-0.18426E+01,-0.18518E+01,-0.18610E+01,-0.18702E+01,& - -0.18793E+01,-0.18884E+01,-0.18974E+01,-0.19065E+01,-0.19154E+01,& - -0.19244E+01,-0.19333E+01,-0.19422E+01,-0.19511E+01,-0.19599E+01,& - -0.19687E+01,-0.19775E+01,-0.19862E+01,-0.19949E+01,-0.20036E+01,& - -0.20123E+01,-0.20209E+01,-0.20295E+01,-0.20381E+01,-0.20466E+01,& - -0.20552E+01,-0.20637E+01,-0.20722E+01,-0.20806E+01,-0.20890E+01,& - -0.20975E+01,-0.21058E+01,-0.21142E+01,-0.21226E+01,-0.21309E+01,& - -0.21392E+01,-0.21475E+01,-0.21557E+01,-0.21640E+01,-0.21722E+01,& - -0.21804E+01,-0.21886E+01,-0.21968E+01,-0.22049E+01,-0.22130E+01,& - -0.22211E+01,-0.22292E+01,-0.22373E+01,-0.22454E+01,-0.22534E+01,& - -0.22614E+01,-0.22694E+01,-0.22774E+01,-0.22854E+01,-0.22933E+01,& - -0.23013E+01,-0.23092E+01,-0.23171E+01,-0.23250E+01,-0.23329E+01,& - -0.23408E+01,-0.23486E+01,-0.23564E+01,-0.23643E+01,-0.23721E+01,& - -0.23799E+01,-0.23876E+01,-0.23954E+01,-0.24032E+01,-0.24109E+01,& - -0.24186E+01,-0.24263E+01,-0.24340E+01,-0.24417E+01,-0.24494E+01,& - -0.24570E+01,-0.24647E+01,-0.24723E+01,-0.24800E+01,-0.24876E+01/ - - DATA (BNC04M(IA),IA=701,741)/ & - -0.24952E+01,-0.25028E+01,-0.25103E+01,-0.25179E+01,-0.25255E+01,& - -0.25330E+01,-0.25405E+01,-0.25481E+01,-0.25556E+01,-0.25631E+01,& - -0.25706E+01,-0.25780E+01,-0.25855E+01,-0.25930E+01,-0.26004E+01,& - -0.26079E+01,-0.26153E+01,-0.26227E+01,-0.26301E+01,-0.26375E+01,& - -0.26449E+01,-0.26523E+01,-0.26597E+01,-0.26670E+01,-0.26744E+01,& - -0.26817E+01,-0.26891E+01,-0.26964E+01,-0.27037E+01,-0.27110E+01,& - -0.27183E+01,-0.27256E+01,-0.27329E+01,-0.27401E+01,-0.27474E+01,& - -0.27547E+01,-0.27619E+01,-0.27692E+01,-0.27764E+01,-0.27836E+01,& - -0.27908E+01 / -! -! ** NH4NO3 -! - DATA (BNC05M (IA),IA= 1,100)/ & - -0.55115E-01,-0.10248E+00,-0.13740E+00,-0.16216E+00,-0.18192E+00,& - -0.19861E+00,-0.21320E+00,-0.22626E+00,-0.23813E+00,-0.24905E+00,& - -0.25921E+00,-0.26872E+00,-0.27769E+00,-0.28619E+00,-0.29428E+00,& - -0.30201E+00,-0.30943E+00,-0.31655E+00,-0.32341E+00,-0.33004E+00,& - -0.33646E+00,-0.34268E+00,-0.34871E+00,-0.35458E+00,-0.36029E+00,& - -0.36586E+00,-0.37128E+00,-0.37658E+00,-0.38176E+00,-0.38682E+00,& - -0.39178E+00,-0.39663E+00,-0.40138E+00,-0.40603E+00,-0.41060E+00,& - -0.41508E+00,-0.41948E+00,-0.42380E+00,-0.42805E+00,-0.43222E+00,& - -0.43632E+00,-0.44035E+00,-0.44432E+00,-0.44823E+00,-0.45207E+00,& - -0.45585E+00,-0.45958E+00,-0.46325E+00,-0.46687E+00,-0.47044E+00,& - -0.47395E+00,-0.47742E+00,-0.48084E+00,-0.48422E+00,-0.48755E+00,& - -0.49084E+00,-0.49409E+00,-0.49730E+00,-0.50048E+00,-0.50361E+00,& - -0.50671E+00,-0.50978E+00,-0.51282E+00,-0.51582E+00,-0.51880E+00,& - -0.52174E+00,-0.52466E+00,-0.52755E+00,-0.53041E+00,-0.53326E+00,& - -0.53607E+00,-0.53887E+00,-0.54164E+00,-0.54440E+00,-0.54713E+00,& - -0.54985E+00,-0.55255E+00,-0.55523E+00,-0.55790E+00,-0.56055E+00,& - -0.56319E+00,-0.56581E+00,-0.56842E+00,-0.57102E+00,-0.57360E+00,& - -0.57617E+00,-0.57874E+00,-0.58129E+00,-0.58383E+00,-0.58636E+00,& - -0.58888E+00,-0.59139E+00,-0.59389E+00,-0.59638E+00,-0.59887E+00,& - -0.60134E+00,-0.60381E+00,-0.60627E+00,-0.60872E+00,-0.61116E+00/ - - DATA (BNC05M (IA),IA=101,200)/ & - -0.61360E+00,-0.61602E+00,-0.61844E+00,-0.62085E+00,-0.62325E+00,& - -0.62565E+00,-0.62803E+00,-0.63041E+00,-0.63278E+00,-0.63514E+00,& - -0.63749E+00,-0.63983E+00,-0.64217E+00,-0.64449E+00,-0.64681E+00,& - -0.64912E+00,-0.65142E+00,-0.65371E+00,-0.65599E+00,-0.65827E+00,& - -0.66039E+00,-0.66266E+00,-0.66492E+00,-0.66718E+00,-0.66942E+00,& - -0.67165E+00,-0.67387E+00,-0.67608E+00,-0.67828E+00,-0.68047E+00,& - -0.68265E+00,-0.68482E+00,-0.68698E+00,-0.68914E+00,-0.69128E+00,& - -0.69341E+00,-0.69554E+00,-0.69765E+00,-0.69976E+00,-0.70186E+00,& - -0.70395E+00,-0.70603E+00,-0.70810E+00,-0.71016E+00,-0.71222E+00,& - -0.71426E+00,-0.71630E+00,-0.71833E+00,-0.72035E+00,-0.72237E+00,& - -0.72437E+00,-0.72637E+00,-0.72836E+00,-0.73034E+00,-0.73232E+00,& - -0.73428E+00,-0.73624E+00,-0.73820E+00,-0.74014E+00,-0.74208E+00,& - -0.74401E+00,-0.74593E+00,-0.74784E+00,-0.74975E+00,-0.75165E+00,& - -0.75355E+00,-0.75544E+00,-0.75732E+00,-0.75919E+00,-0.76106E+00,& - -0.76292E+00,-0.76477E+00,-0.76662E+00,-0.76846E+00,-0.77029E+00,& - -0.77212E+00,-0.77394E+00,-0.77575E+00,-0.77756E+00,-0.77936E+00,& - -0.78116E+00,-0.78295E+00,-0.78473E+00,-0.78651E+00,-0.78828E+00,& - -0.79005E+00,-0.79180E+00,-0.79356E+00,-0.79531E+00,-0.79705E+00,& - -0.79878E+00,-0.80051E+00,-0.80224E+00,-0.80396E+00,-0.80567E+00,& - -0.80738E+00,-0.80908E+00,-0.81078E+00,-0.81247E+00,-0.81416E+00/ - - DATA (BNC05M (IA),IA=201,300)/ & - -0.81584E+00,-0.81751E+00,-0.81918E+00,-0.82085E+00,-0.82251E+00,& - -0.82416E+00,-0.82581E+00,-0.82746E+00,-0.82910E+00,-0.83073E+00,& - -0.83236E+00,-0.83398E+00,-0.83560E+00,-0.83722E+00,-0.83883E+00,& - -0.84043E+00,-0.84203E+00,-0.84363E+00,-0.84522E+00,-0.84680E+00,& - -0.84839E+00,-0.84996E+00,-0.85153E+00,-0.85310E+00,-0.85466E+00,& - -0.85622E+00,-0.85778E+00,-0.85932E+00,-0.86087E+00,-0.86241E+00,& - -0.86395E+00,-0.86548E+00,-0.86700E+00,-0.86853E+00,-0.87005E+00,& - -0.87156E+00,-0.87307E+00,-0.87458E+00,-0.87608E+00,-0.87758E+00,& - -0.87907E+00,-0.88056E+00,-0.88204E+00,-0.88353E+00,-0.88500E+00,& - -0.88648E+00,-0.88794E+00,-0.88941E+00,-0.89087E+00,-0.89233E+00,& - -0.89378E+00,-0.89523E+00,-0.89668E+00,-0.89812E+00,-0.89956E+00,& - -0.90099E+00,-0.90242E+00,-0.90385E+00,-0.90527E+00,-0.90669E+00,& - -0.90811E+00,-0.90952E+00,-0.91093E+00,-0.91233E+00,-0.91373E+00,& - -0.91513E+00,-0.91653E+00,-0.91792E+00,-0.91930E+00,-0.92069E+00,& - -0.92207E+00,-0.92344E+00,-0.92482E+00,-0.92619E+00,-0.92755E+00,& - -0.92892E+00,-0.93028E+00,-0.93163E+00,-0.93299E+00,-0.93434E+00,& - -0.93568E+00,-0.93703E+00,-0.93837E+00,-0.93970E+00,-0.94104E+00,& - -0.94237E+00,-0.94369E+00,-0.94502E+00,-0.94634E+00,-0.94765E+00,& - -0.94897E+00,-0.95028E+00,-0.95159E+00,-0.95289E+00,-0.95420E+00,& - -0.95549E+00,-0.95679E+00,-0.95808E+00,-0.95937E+00,-0.96066E+00/ - - DATA (BNC05M (IA),IA=301,400)/ & - -0.96194E+00,-0.96323E+00,-0.96450E+00,-0.96578E+00,-0.96705E+00,& - -0.96832E+00,-0.96959E+00,-0.97085E+00,-0.97211E+00,-0.97337E+00,& - -0.97463E+00,-0.97588E+00,-0.97713E+00,-0.97837E+00,-0.97962E+00,& - -0.98086E+00,-0.98210E+00,-0.98333E+00,-0.98457E+00,-0.98580E+00,& - -0.98703E+00,-0.98825E+00,-0.98947E+00,-0.99069E+00,-0.99191E+00,& - -0.99312E+00,-0.99434E+00,-0.99554E+00,-0.99675E+00,-0.99796E+00,& - -0.99916E+00,-0.10004E+01,-0.10016E+01,-0.10027E+01,-0.10039E+01,& - -0.10051E+01,-0.10063E+01,-0.10075E+01,-0.10087E+01,-0.10099E+01,& - -0.10110E+01,-0.10122E+01,-0.10134E+01,-0.10145E+01,-0.10157E+01,& - -0.10169E+01,-0.10180E+01,-0.10192E+01,-0.10204E+01,-0.10215E+01,& - -0.10227E+01,-0.10238E+01,-0.10250E+01,-0.10261E+01,-0.10273E+01,& - -0.10284E+01,-0.10295E+01,-0.10307E+01,-0.10318E+01,-0.10329E+01,& - -0.10341E+01,-0.10352E+01,-0.10363E+01,-0.10374E+01,-0.10386E+01,& - -0.10397E+01,-0.10408E+01,-0.10419E+01,-0.10430E+01,-0.10441E+01,& - -0.10452E+01,-0.10464E+01,-0.10475E+01,-0.10486E+01,-0.10497E+01,& - -0.10508E+01,-0.10519E+01,-0.10529E+01,-0.10540E+01,-0.10551E+01,& - -0.10562E+01,-0.10573E+01,-0.10584E+01,-0.10595E+01,-0.10605E+01,& - -0.10616E+01,-0.10627E+01,-0.10638E+01,-0.10648E+01,-0.10659E+01,& - -0.10670E+01,-0.10680E+01,-0.10691E+01,-0.10702E+01,-0.10712E+01,& - -0.10723E+01,-0.10733E+01,-0.10744E+01,-0.10754E+01,-0.10765E+01/ - - DATA (BNC05M (IA),IA=401,500)/ & - -0.10775E+01,-0.10786E+01,-0.10796E+01,-0.10807E+01,-0.10817E+01,& - -0.10827E+01,-0.10838E+01,-0.10848E+01,-0.10859E+01,-0.10869E+01,& - -0.10879E+01,-0.10889E+01,-0.10900E+01,-0.10910E+01,-0.10920E+01,& - -0.10930E+01,-0.10941E+01,-0.10951E+01,-0.10961E+01,-0.10971E+01,& - -0.10981E+01,-0.10991E+01,-0.11001E+01,-0.11011E+01,-0.11021E+01,& - -0.11031E+01,-0.11041E+01,-0.11051E+01,-0.11061E+01,-0.11071E+01,& - -0.11081E+01,-0.11091E+01,-0.11101E+01,-0.11111E+01,-0.11121E+01,& - -0.11131E+01,-0.11141E+01,-0.11150E+01,-0.11160E+01,-0.11170E+01,& - -0.11180E+01,-0.11190E+01,-0.11199E+01,-0.11209E+01,-0.11219E+01,& - -0.11229E+01,-0.11238E+01,-0.11248E+01,-0.11258E+01,-0.11267E+01,& - -0.11277E+01,-0.11286E+01,-0.11296E+01,-0.11306E+01,-0.11315E+01,& - -0.11325E+01,-0.11334E+01,-0.11344E+01,-0.11353E+01,-0.11363E+01,& - -0.11372E+01,-0.11382E+01,-0.11391E+01,-0.11401E+01,-0.11410E+01,& - -0.11419E+01,-0.11429E+01,-0.11438E+01,-0.11448E+01,-0.11457E+01,& - -0.11466E+01,-0.11476E+01,-0.11485E+01,-0.11494E+01,-0.11503E+01,& - -0.11513E+01,-0.11522E+01,-0.11531E+01,-0.11540E+01,-0.11549E+01,& - -0.11559E+01,-0.11568E+01,-0.11577E+01,-0.11586E+01,-0.11595E+01,& - -0.11604E+01,-0.11614E+01,-0.11623E+01,-0.11632E+01,-0.11641E+01,& - -0.11650E+01,-0.11659E+01,-0.11668E+01,-0.11677E+01,-0.11686E+01,& - -0.11695E+01,-0.11704E+01,-0.11713E+01,-0.11722E+01,-0.11731E+01/ - - DATA (BNC05M (IA),IA=501,600)/ & - -0.11740E+01,-0.11748E+01,-0.11757E+01,-0.11766E+01,-0.11775E+01,& - -0.11784E+01,-0.11793E+01,-0.11802E+01,-0.11810E+01,-0.11819E+01,& - -0.11828E+01,-0.11837E+01,-0.11846E+01,-0.11854E+01,-0.11863E+01,& - -0.11872E+01,-0.11881E+01,-0.11889E+01,-0.11898E+01,-0.11907E+01,& - -0.11915E+01,-0.11924E+01,-0.11933E+01,-0.11941E+01,-0.11950E+01,& - -0.11958E+01,-0.11967E+01,-0.11976E+01,-0.11984E+01,-0.11993E+01,& - -0.12001E+01,-0.12010E+01,-0.12018E+01,-0.12027E+01,-0.12035E+01,& - -0.12044E+01,-0.12052E+01,-0.12061E+01,-0.12069E+01,-0.12078E+01,& - -0.12086E+01,-0.12095E+01,-0.12103E+01,-0.12111E+01,-0.12120E+01,& - -0.12128E+01,-0.12137E+01,-0.12145E+01,-0.12153E+01,-0.12162E+01,& - -0.12170E+01,-0.12178E+01,-0.12186E+01,-0.12195E+01,-0.12203E+01,& - -0.12211E+01,-0.12220E+01,-0.12228E+01,-0.12236E+01,-0.12244E+01,& - -0.12252E+01,-0.12261E+01,-0.12269E+01,-0.12277E+01,-0.12285E+01,& - -0.12293E+01,-0.12302E+01,-0.12310E+01,-0.12318E+01,-0.12326E+01,& - -0.12334E+01,-0.12342E+01,-0.12350E+01,-0.12358E+01,-0.12366E+01,& - -0.12374E+01,-0.12383E+01,-0.12391E+01,-0.12399E+01,-0.12407E+01,& - -0.12415E+01,-0.12423E+01,-0.12431E+01,-0.12439E+01,-0.12447E+01,& - -0.12455E+01,-0.12462E+01,-0.12470E+01,-0.12478E+01,-0.12486E+01,& - -0.12494E+01,-0.12502E+01,-0.12510E+01,-0.12518E+01,-0.12526E+01,& - -0.12534E+01,-0.12541E+01,-0.12549E+01,-0.12557E+01,-0.12586E+01/ - - DATA (BNC05M (IA),IA=601,700)/ & - -0.12650E+01,-0.12727E+01,-0.12803E+01,-0.12878E+01,-0.12952E+01,& - -0.13026E+01,-0.13098E+01,-0.13170E+01,-0.13241E+01,-0.13312E+01,& - -0.13381E+01,-0.13450E+01,-0.13519E+01,-0.13586E+01,-0.13654E+01,& - -0.13720E+01,-0.13786E+01,-0.13851E+01,-0.13916E+01,-0.13980E+01,& - -0.14044E+01,-0.14107E+01,-0.14169E+01,-0.14231E+01,-0.14293E+01,& - -0.14354E+01,-0.14415E+01,-0.14475E+01,-0.14534E+01,-0.14594E+01,& - -0.14652E+01,-0.14711E+01,-0.14769E+01,-0.14827E+01,-0.14884E+01,& - -0.14941E+01,-0.14997E+01,-0.15053E+01,-0.15109E+01,-0.15164E+01,& - -0.15219E+01,-0.15274E+01,-0.15328E+01,-0.15382E+01,-0.15436E+01,& - -0.15490E+01,-0.15543E+01,-0.15595E+01,-0.15648E+01,-0.15700E+01,& - -0.15752E+01,-0.15804E+01,-0.15855E+01,-0.15906E+01,-0.15957E+01,& - -0.16008E+01,-0.16058E+01,-0.16108E+01,-0.16158E+01,-0.16208E+01,& - -0.16257E+01,-0.16306E+01,-0.16355E+01,-0.16404E+01,-0.16452E+01,& - -0.16500E+01,-0.16548E+01,-0.16596E+01,-0.16644E+01,-0.16691E+01,& - -0.16739E+01,-0.16786E+01,-0.16832E+01,-0.16879E+01,-0.16926E+01,& - -0.16972E+01,-0.17018E+01,-0.17064E+01,-0.17110E+01,-0.17155E+01,& - -0.17201E+01,-0.17246E+01,-0.17291E+01,-0.17336E+01,-0.17381E+01,& - -0.17425E+01,-0.17470E+01,-0.17514E+01,-0.17558E+01,-0.17602E+01,& - -0.17646E+01,-0.17690E+01,-0.17733E+01,-0.17777E+01,-0.17820E+01,& - -0.17863E+01,-0.17906E+01,-0.17949E+01,-0.17992E+01,-0.18035E+01/ - - DATA (BNC05M(IA),IA=701,741)/ & - -0.18077E+01,-0.18119E+01,-0.18162E+01,-0.18204E+01,-0.18246E+01,& - -0.18288E+01,-0.18330E+01,-0.18371E+01,-0.18413E+01,-0.18454E+01,& - -0.18496E+01,-0.18537E+01,-0.18578E+01,-0.18619E+01,-0.18660E+01,& - -0.18701E+01,-0.18742E+01,-0.18782E+01,-0.18823E+01,-0.18863E+01,& - -0.18903E+01,-0.18944E+01,-0.18984E+01,-0.19024E+01,-0.19064E+01,& - -0.19104E+01,-0.19144E+01,-0.19183E+01,-0.19223E+01,-0.19262E+01,& - -0.19302E+01,-0.19341E+01,-0.19380E+01,-0.19419E+01,-0.19459E+01,& - -0.19498E+01,-0.19537E+01,-0.19575E+01,-0.19614E+01,-0.19653E+01,& - -0.19691E+01 / -! -! ** NH4Cl -! - DATA (BNC06M (IA),IA= 1,100)/ & - -0.53384E-01,-0.96046E-01,-0.12518E+00,-0.14446E+00,-0.15894E+00,& - -0.17052E+00,-0.18011E+00,-0.18828E+00,-0.19534E+00,-0.20155E+00,& - -0.20706E+00,-0.21199E+00,-0.21644E+00,-0.22048E+00,-0.22416E+00,& - -0.22754E+00,-0.23064E+00,-0.23350E+00,-0.23615E+00,-0.23861E+00,& - -0.24090E+00,-0.24303E+00,-0.24503E+00,-0.24689E+00,-0.24864E+00,& - -0.25028E+00,-0.25183E+00,-0.25329E+00,-0.25466E+00,-0.25596E+00,& - -0.25718E+00,-0.25834E+00,-0.25944E+00,-0.26049E+00,-0.26148E+00,& - -0.26242E+00,-0.26332E+00,-0.26418E+00,-0.26499E+00,-0.26577E+00,& - -0.26651E+00,-0.26722E+00,-0.26790E+00,-0.26856E+00,-0.26918E+00,& - -0.26978E+00,-0.27035E+00,-0.27091E+00,-0.27144E+00,-0.27195E+00,& - -0.27244E+00,-0.27291E+00,-0.27337E+00,-0.27380E+00,-0.27422E+00,& - -0.27463E+00,-0.27502E+00,-0.27540E+00,-0.27576E+00,-0.27611E+00,& - -0.27645E+00,-0.27677E+00,-0.27708E+00,-0.27738E+00,-0.27767E+00,& - -0.27794E+00,-0.27821E+00,-0.27846E+00,-0.27870E+00,-0.27892E+00,& - -0.27914E+00,-0.27935E+00,-0.27954E+00,-0.27972E+00,-0.27989E+00,& - -0.28005E+00,-0.28020E+00,-0.28034E+00,-0.28047E+00,-0.28058E+00,& - -0.28069E+00,-0.28078E+00,-0.28086E+00,-0.28093E+00,-0.28099E+00,& - -0.28104E+00,-0.28108E+00,-0.28111E+00,-0.28112E+00,-0.28113E+00,& - -0.28113E+00,-0.28111E+00,-0.28109E+00,-0.28106E+00,-0.28101E+00,& - -0.28096E+00,-0.28090E+00,-0.28083E+00,-0.28075E+00,-0.28066E+00/ - - DATA (BNC06M (IA),IA=101,200)/ & - -0.28057E+00,-0.28046E+00,-0.28035E+00,-0.28023E+00,-0.28010E+00,& - -0.27997E+00,-0.27983E+00,-0.27968E+00,-0.27953E+00,-0.27937E+00,& - -0.27920E+00,-0.27903E+00,-0.27886E+00,-0.27868E+00,-0.27849E+00,& - -0.27830E+00,-0.27810E+00,-0.27790E+00,-0.27770E+00,-0.27749E+00,& - -0.27738E+00,-0.27716E+00,-0.27693E+00,-0.27670E+00,-0.27647E+00,& - -0.27623E+00,-0.27600E+00,-0.27576E+00,-0.27552E+00,-0.27528E+00,& - -0.27503E+00,-0.27479E+00,-0.27454E+00,-0.27430E+00,-0.27405E+00,& - -0.27380E+00,-0.27355E+00,-0.27329E+00,-0.27304E+00,-0.27279E+00,& - -0.27253E+00,-0.27227E+00,-0.27201E+00,-0.27176E+00,-0.27149E+00,& - -0.27123E+00,-0.27097E+00,-0.27071E+00,-0.27044E+00,-0.27018E+00,& - -0.26991E+00,-0.26965E+00,-0.26938E+00,-0.26911E+00,-0.26885E+00,& - -0.26858E+00,-0.26831E+00,-0.26804E+00,-0.26777E+00,-0.26750E+00,& - -0.26723E+00,-0.26695E+00,-0.26668E+00,-0.26641E+00,-0.26614E+00,& - -0.26586E+00,-0.26559E+00,-0.26531E+00,-0.26504E+00,-0.26477E+00,& - -0.26449E+00,-0.26422E+00,-0.26394E+00,-0.26366E+00,-0.26339E+00,& - -0.26311E+00,-0.26284E+00,-0.26256E+00,-0.26228E+00,-0.26201E+00,& - -0.26173E+00,-0.26146E+00,-0.26118E+00,-0.26090E+00,-0.26063E+00,& - -0.26035E+00,-0.26007E+00,-0.25980E+00,-0.25952E+00,-0.25924E+00,& - -0.25897E+00,-0.25869E+00,-0.25841E+00,-0.25814E+00,-0.25786E+00,& - -0.25759E+00,-0.25731E+00,-0.25703E+00,-0.25676E+00,-0.25648E+00/ - - DATA (BNC06M (IA),IA=201,300)/ & - -0.25621E+00,-0.25593E+00,-0.25566E+00,-0.25538E+00,-0.25511E+00,& - -0.25483E+00,-0.25456E+00,-0.25429E+00,-0.25401E+00,-0.25374E+00,& - -0.25347E+00,-0.25319E+00,-0.25292E+00,-0.25265E+00,-0.25238E+00,& - -0.25211E+00,-0.25183E+00,-0.25156E+00,-0.25129E+00,-0.25102E+00,& - -0.25075E+00,-0.25048E+00,-0.25021E+00,-0.24994E+00,-0.24967E+00,& - -0.24941E+00,-0.24914E+00,-0.24887E+00,-0.24860E+00,-0.24834E+00,& - -0.24807E+00,-0.24780E+00,-0.24754E+00,-0.24727E+00,-0.24701E+00,& - -0.24674E+00,-0.24648E+00,-0.24622E+00,-0.24595E+00,-0.24569E+00,& - -0.24543E+00,-0.24517E+00,-0.24491E+00,-0.24464E+00,-0.24438E+00,& - -0.24412E+00,-0.24386E+00,-0.24360E+00,-0.24335E+00,-0.24309E+00,& - -0.24283E+00,-0.24257E+00,-0.24232E+00,-0.24206E+00,-0.24180E+00,& - -0.24155E+00,-0.24129E+00,-0.24104E+00,-0.24078E+00,-0.24053E+00,& - -0.24028E+00,-0.24002E+00,-0.23977E+00,-0.23952E+00,-0.23927E+00,& - -0.23902E+00,-0.23877E+00,-0.23852E+00,-0.23827E+00,-0.23802E+00,& - -0.23777E+00,-0.23753E+00,-0.23728E+00,-0.23703E+00,-0.23679E+00,& - -0.23654E+00,-0.23630E+00,-0.23605E+00,-0.23581E+00,-0.23556E+00,& - -0.23532E+00,-0.23508E+00,-0.23484E+00,-0.23460E+00,-0.23436E+00,& - -0.23412E+00,-0.23388E+00,-0.23364E+00,-0.23340E+00,-0.23316E+00,& - -0.23292E+00,-0.23269E+00,-0.23245E+00,-0.23221E+00,-0.23198E+00,& - -0.23174E+00,-0.23151E+00,-0.23128E+00,-0.23104E+00,-0.23081E+00/ - - DATA (BNC06M (IA),IA=301,400)/ & - -0.23058E+00,-0.23035E+00,-0.23012E+00,-0.22988E+00,-0.22965E+00,& - -0.22943E+00,-0.22920E+00,-0.22897E+00,-0.22874E+00,-0.22851E+00,& - -0.22829E+00,-0.22806E+00,-0.22784E+00,-0.22761E+00,-0.22739E+00,& - -0.22716E+00,-0.22694E+00,-0.22672E+00,-0.22649E+00,-0.22627E+00,& - -0.22605E+00,-0.22583E+00,-0.22561E+00,-0.22539E+00,-0.22517E+00,& - -0.22495E+00,-0.22474E+00,-0.22452E+00,-0.22430E+00,-0.22409E+00,& - -0.22387E+00,-0.22366E+00,-0.22344E+00,-0.22323E+00,-0.22301E+00,& - -0.22280E+00,-0.22259E+00,-0.22238E+00,-0.22217E+00,-0.22196E+00,& - -0.22175E+00,-0.22154E+00,-0.22133E+00,-0.22112E+00,-0.22091E+00,& - -0.22070E+00,-0.22050E+00,-0.22029E+00,-0.22008E+00,-0.21988E+00,& - -0.21968E+00,-0.21947E+00,-0.21927E+00,-0.21906E+00,-0.21886E+00,& - -0.21866E+00,-0.21846E+00,-0.21826E+00,-0.21806E+00,-0.21786E+00,& - -0.21766E+00,-0.21746E+00,-0.21726E+00,-0.21707E+00,-0.21687E+00,& - -0.21667E+00,-0.21648E+00,-0.21628E+00,-0.21609E+00,-0.21589E+00,& - -0.21570E+00,-0.21551E+00,-0.21531E+00,-0.21512E+00,-0.21493E+00,& - -0.21474E+00,-0.21455E+00,-0.21436E+00,-0.21417E+00,-0.21398E+00,& - -0.21379E+00,-0.21360E+00,-0.21342E+00,-0.21323E+00,-0.21304E+00,& - -0.21286E+00,-0.21267E+00,-0.21249E+00,-0.21230E+00,-0.21212E+00,& - -0.21194E+00,-0.21176E+00,-0.21157E+00,-0.21139E+00,-0.21121E+00,& - -0.21103E+00,-0.21085E+00,-0.21067E+00,-0.21049E+00,-0.21032E+00/ - - DATA (BNC06M (IA),IA=401,500)/ & - -0.21014E+00,-0.20996E+00,-0.20978E+00,-0.20961E+00,-0.20943E+00,& - -0.20926E+00,-0.20908E+00,-0.20891E+00,-0.20873E+00,-0.20856E+00,& - -0.20839E+00,-0.20822E+00,-0.20804E+00,-0.20787E+00,-0.20770E+00,& - -0.20753E+00,-0.20736E+00,-0.20720E+00,-0.20703E+00,-0.20686E+00,& - -0.20669E+00,-0.20652E+00,-0.20636E+00,-0.20619E+00,-0.20603E+00,& - -0.20586E+00,-0.20570E+00,-0.20553E+00,-0.20537E+00,-0.20521E+00,& - -0.20504E+00,-0.20488E+00,-0.20472E+00,-0.20456E+00,-0.20440E+00,& - -0.20424E+00,-0.20408E+00,-0.20392E+00,-0.20376E+00,-0.20361E+00,& - -0.20345E+00,-0.20329E+00,-0.20313E+00,-0.20298E+00,-0.20282E+00,& - -0.20267E+00,-0.20251E+00,-0.20236E+00,-0.20221E+00,-0.20205E+00,& - -0.20190E+00,-0.20175E+00,-0.20160E+00,-0.20145E+00,-0.20130E+00,& - -0.20114E+00,-0.20100E+00,-0.20085E+00,-0.20070E+00,-0.20055E+00,& - -0.20040E+00,-0.20025E+00,-0.20011E+00,-0.19996E+00,-0.19982E+00,& - -0.19967E+00,-0.19952E+00,-0.19938E+00,-0.19924E+00,-0.19909E+00,& - -0.19895E+00,-0.19881E+00,-0.19867E+00,-0.19852E+00,-0.19838E+00,& - -0.19824E+00,-0.19810E+00,-0.19796E+00,-0.19782E+00,-0.19768E+00,& - -0.19755E+00,-0.19741E+00,-0.19727E+00,-0.19713E+00,-0.19700E+00,& - -0.19686E+00,-0.19672E+00,-0.19659E+00,-0.19646E+00,-0.19632E+00,& - -0.19619E+00,-0.19605E+00,-0.19592E+00,-0.19579E+00,-0.19566E+00,& - -0.19552E+00,-0.19539E+00,-0.19526E+00,-0.19513E+00,-0.19500E+00/ - - DATA (BNC06M (IA),IA=501,600)/ & - -0.19487E+00,-0.19474E+00,-0.19462E+00,-0.19449E+00,-0.19436E+00,& - -0.19423E+00,-0.19411E+00,-0.19398E+00,-0.19386E+00,-0.19373E+00,& - -0.19361E+00,-0.19348E+00,-0.19336E+00,-0.19323E+00,-0.19311E+00,& - -0.19299E+00,-0.19286E+00,-0.19274E+00,-0.19262E+00,-0.19250E+00,& - -0.19238E+00,-0.19226E+00,-0.19214E+00,-0.19202E+00,-0.19190E+00,& - -0.19178E+00,-0.19167E+00,-0.19155E+00,-0.19143E+00,-0.19131E+00,& - -0.19120E+00,-0.19108E+00,-0.19097E+00,-0.19085E+00,-0.19074E+00,& - -0.19062E+00,-0.19051E+00,-0.19040E+00,-0.19028E+00,-0.19017E+00,& - -0.19006E+00,-0.18995E+00,-0.18984E+00,-0.18972E+00,-0.18961E+00,& - -0.18950E+00,-0.18939E+00,-0.18929E+00,-0.18918E+00,-0.18907E+00,& - -0.18896E+00,-0.18885E+00,-0.18875E+00,-0.18864E+00,-0.18853E+00,& - -0.18843E+00,-0.18832E+00,-0.18822E+00,-0.18811E+00,-0.18801E+00,& - -0.18790E+00,-0.18780E+00,-0.18770E+00,-0.18759E+00,-0.18749E+00,& - -0.18739E+00,-0.18729E+00,-0.18719E+00,-0.18709E+00,-0.18699E+00,& - -0.18689E+00,-0.18679E+00,-0.18669E+00,-0.18659E+00,-0.18649E+00,& - -0.18639E+00,-0.18629E+00,-0.18620E+00,-0.18610E+00,-0.18600E+00,& - -0.18591E+00,-0.18581E+00,-0.18572E+00,-0.18562E+00,-0.18553E+00,& - -0.18543E+00,-0.18534E+00,-0.18525E+00,-0.18515E+00,-0.18506E+00,& - -0.18497E+00,-0.18488E+00,-0.18478E+00,-0.18469E+00,-0.18460E+00,& - -0.18451E+00,-0.18442E+00,-0.18433E+00,-0.18424E+00,-0.18391E+00/ - - DATA (BNC06M (IA),IA=601,700)/ & - -0.18320E+00,-0.18237E+00,-0.18158E+00,-0.18083E+00,-0.18010E+00,& - -0.17942E+00,-0.17876E+00,-0.17814E+00,-0.17755E+00,-0.17700E+00,& - -0.17647E+00,-0.17597E+00,-0.17551E+00,-0.17507E+00,-0.17467E+00,& - -0.17429E+00,-0.17394E+00,-0.17362E+00,-0.17333E+00,-0.17306E+00,& - -0.17282E+00,-0.17260E+00,-0.17241E+00,-0.17225E+00,-0.17211E+00,& - -0.17200E+00,-0.17190E+00,-0.17184E+00,-0.17179E+00,-0.17177E+00,& - -0.17177E+00,-0.17180E+00,-0.17184E+00,-0.17191E+00,-0.17200E+00,& - -0.17210E+00,-0.17223E+00,-0.17238E+00,-0.17255E+00,-0.17274E+00,& - -0.17295E+00,-0.17318E+00,-0.17342E+00,-0.17369E+00,-0.17397E+00,& - -0.17427E+00,-0.17459E+00,-0.17493E+00,-0.17528E+00,-0.17565E+00,& - -0.17604E+00,-0.17644E+00,-0.17687E+00,-0.17730E+00,-0.17775E+00,& - -0.17822E+00,-0.17871E+00,-0.17921E+00,-0.17972E+00,-0.18025E+00,& - -0.18079E+00,-0.18135E+00,-0.18193E+00,-0.18251E+00,-0.18311E+00,& - -0.18373E+00,-0.18436E+00,-0.18500E+00,-0.18565E+00,-0.18632E+00,& - -0.18700E+00,-0.18770E+00,-0.18840E+00,-0.18912E+00,-0.18985E+00,& - -0.19060E+00,-0.19135E+00,-0.19212E+00,-0.19290E+00,-0.19369E+00,& - -0.19450E+00,-0.19531E+00,-0.19614E+00,-0.19697E+00,-0.19782E+00,& - -0.19868E+00,-0.19955E+00,-0.20043E+00,-0.20132E+00,-0.20222E+00,& - -0.20313E+00,-0.20405E+00,-0.20498E+00,-0.20592E+00,-0.20687E+00,& - -0.20783E+00,-0.20880E+00,-0.20978E+00,-0.21077E+00,-0.21177E+00/ - - DATA (BNC06M(IA),IA=701,741)/ & - -0.21278E+00,-0.21379E+00,-0.21482E+00,-0.21585E+00,-0.21690E+00,& - -0.21795E+00,-0.21901E+00,-0.22008E+00,-0.22116E+00,-0.22224E+00,& - -0.22334E+00,-0.22444E+00,-0.22555E+00,-0.22667E+00,-0.22780E+00,& - -0.22893E+00,-0.23007E+00,-0.23122E+00,-0.23238E+00,-0.23355E+00,& - -0.23472E+00,-0.23590E+00,-0.23709E+00,-0.23828E+00,-0.23949E+00,& - -0.24070E+00,-0.24191E+00,-0.24314E+00,-0.24437E+00,-0.24561E+00,& - -0.24685E+00,-0.24810E+00,-0.24936E+00,-0.25062E+00,-0.25189E+00,& - -0.25317E+00,-0.25446E+00,-0.25575E+00,-0.25704E+00,-0.25835E+00,& - -0.25966E+00 / -! -! ** (2H, SO4) -! - DATA (BNC07M (IA),IA= 1,100)/ & - -0.10830E+00,-0.19774E+00,-0.26106E+00,-0.30438E+00,-0.33792E+00,& - -0.36551E+00,-0.38903E+00,-0.40959E+00,-0.42789E+00,-0.44440E+00,& - -0.45945E+00,-0.47329E+00,-0.48612E+00,-0.49807E+00,-0.50926E+00,& - -0.51980E+00,-0.52976E+00,-0.53920E+00,-0.54817E+00,-0.55673E+00,& - -0.56491E+00,-0.57275E+00,-0.58028E+00,-0.58752E+00,-0.59449E+00,& - -0.60122E+00,-0.60772E+00,-0.61401E+00,-0.62011E+00,-0.62602E+00,& - -0.63176E+00,-0.63734E+00,-0.64277E+00,-0.64805E+00,-0.65321E+00,& - -0.65823E+00,-0.66313E+00,-0.66792E+00,-0.67261E+00,-0.67718E+00,& - -0.68166E+00,-0.68605E+00,-0.69035E+00,-0.69456E+00,-0.69869E+00,& - -0.70275E+00,-0.70673E+00,-0.71063E+00,-0.71447E+00,-0.71824E+00,& - -0.72195E+00,-0.72560E+00,-0.72919E+00,-0.73272E+00,-0.73620E+00,& - -0.73963E+00,-0.74301E+00,-0.74633E+00,-0.74961E+00,-0.75285E+00,& - -0.75604E+00,-0.75919E+00,-0.76230E+00,-0.76537E+00,-0.76840E+00,& - -0.77139E+00,-0.77435E+00,-0.77727E+00,-0.78016E+00,-0.78302E+00,& - -0.78584E+00,-0.78863E+00,-0.79140E+00,-0.79414E+00,-0.79684E+00,& - -0.79952E+00,-0.80218E+00,-0.80481E+00,-0.80741E+00,-0.80999E+00,& - -0.81255E+00,-0.81509E+00,-0.81760E+00,-0.82009E+00,-0.82256E+00,& - -0.82501E+00,-0.82744E+00,-0.82985E+00,-0.83224E+00,-0.83461E+00,& - -0.83697E+00,-0.83930E+00,-0.84162E+00,-0.84393E+00,-0.84621E+00,& - -0.84848E+00,-0.85074E+00,-0.85298E+00,-0.85520E+00,-0.85741E+00/ - - DATA (BNC07M (IA),IA=101,200)/ & - -0.85961E+00,-0.86179E+00,-0.86396E+00,-0.86611E+00,-0.86825E+00,& - -0.87038E+00,-0.87249E+00,-0.87459E+00,-0.87668E+00,-0.87876E+00,& - -0.88082E+00,-0.88287E+00,-0.88491E+00,-0.88694E+00,-0.88896E+00,& - -0.89097E+00,-0.89296E+00,-0.89495E+00,-0.89692E+00,-0.89888E+00,& - -0.90081E+00,-0.90275E+00,-0.90469E+00,-0.90661E+00,-0.90853E+00,& - -0.91043E+00,-0.91233E+00,-0.91421E+00,-0.91609E+00,-0.91795E+00,& - -0.91981E+00,-0.92166E+00,-0.92349E+00,-0.92532E+00,-0.92715E+00,& - -0.92896E+00,-0.93076E+00,-0.93256E+00,-0.93435E+00,-0.93613E+00,& - -0.93790E+00,-0.93966E+00,-0.94142E+00,-0.94317E+00,-0.94491E+00,& - -0.94664E+00,-0.94837E+00,-0.95009E+00,-0.95180E+00,-0.95351E+00,& - -0.95521E+00,-0.95690E+00,-0.95858E+00,-0.96026E+00,-0.96193E+00,& - -0.96360E+00,-0.96525E+00,-0.96691E+00,-0.96855E+00,-0.97019E+00,& - -0.97183E+00,-0.97345E+00,-0.97508E+00,-0.97669E+00,-0.97830E+00,& - -0.97991E+00,-0.98150E+00,-0.98310E+00,-0.98469E+00,-0.98627E+00,& - -0.98784E+00,-0.98942E+00,-0.99098E+00,-0.99254E+00,-0.99410E+00,& - -0.99565E+00,-0.99719E+00,-0.99873E+00,-0.10003E+01,-0.10018E+01,& - -0.10033E+01,-0.10048E+01,-0.10064E+01,-0.10079E+01,-0.10094E+01,& - -0.10109E+01,-0.10124E+01,-0.10139E+01,-0.10154E+01,-0.10168E+01,& - -0.10183E+01,-0.10198E+01,-0.10213E+01,-0.10227E+01,-0.10242E+01,& - -0.10257E+01,-0.10271E+01,-0.10286E+01,-0.10300E+01,-0.10315E+01/ - - DATA (BNC07M (IA),IA=201,300)/ & - -0.10329E+01,-0.10343E+01,-0.10358E+01,-0.10372E+01,-0.10386E+01,& - -0.10400E+01,-0.10415E+01,-0.10429E+01,-0.10443E+01,-0.10457E+01,& - -0.10471E+01,-0.10485E+01,-0.10499E+01,-0.10513E+01,-0.10527E+01,& - -0.10540E+01,-0.10554E+01,-0.10568E+01,-0.10582E+01,-0.10595E+01,& - -0.10609E+01,-0.10623E+01,-0.10636E+01,-0.10650E+01,-0.10663E+01,& - -0.10677E+01,-0.10690E+01,-0.10704E+01,-0.10717E+01,-0.10731E+01,& - -0.10744E+01,-0.10757E+01,-0.10771E+01,-0.10784E+01,-0.10797E+01,& - -0.10810E+01,-0.10824E+01,-0.10837E+01,-0.10850E+01,-0.10863E+01,& - -0.10876E+01,-0.10889E+01,-0.10902E+01,-0.10915E+01,-0.10928E+01,& - -0.10941E+01,-0.10954E+01,-0.10967E+01,-0.10980E+01,-0.10993E+01,& - -0.11005E+01,-0.11018E+01,-0.11031E+01,-0.11044E+01,-0.11056E+01,& - -0.11069E+01,-0.11082E+01,-0.11094E+01,-0.11107E+01,-0.11120E+01,& - -0.11132E+01,-0.11145E+01,-0.11157E+01,-0.11170E+01,-0.11182E+01,& - -0.11195E+01,-0.11207E+01,-0.11220E+01,-0.11232E+01,-0.11244E+01,& - -0.11257E+01,-0.11269E+01,-0.11281E+01,-0.11294E+01,-0.11306E+01,& - -0.11318E+01,-0.11330E+01,-0.11342E+01,-0.11355E+01,-0.11367E+01,& - -0.11379E+01,-0.11391E+01,-0.11403E+01,-0.11415E+01,-0.11427E+01,& - -0.11439E+01,-0.11451E+01,-0.11463E+01,-0.11475E+01,-0.11487E+01,& - -0.11499E+01,-0.11511E+01,-0.11523E+01,-0.11535E+01,-0.11547E+01,& - -0.11559E+01,-0.11570E+01,-0.11582E+01,-0.11594E+01,-0.11606E+01/ - - DATA (BNC07M (IA),IA=301,400)/ & - -0.11617E+01,-0.11629E+01,-0.11641E+01,-0.11653E+01,-0.11664E+01,& - -0.11676E+01,-0.11688E+01,-0.11699E+01,-0.11711E+01,-0.11722E+01,& - -0.11734E+01,-0.11746E+01,-0.11757E+01,-0.11769E+01,-0.11780E+01,& - -0.11792E+01,-0.11803E+01,-0.11815E+01,-0.11826E+01,-0.11837E+01,& - -0.11849E+01,-0.11860E+01,-0.11872E+01,-0.11883E+01,-0.11894E+01,& - -0.11906E+01,-0.11917E+01,-0.11928E+01,-0.11940E+01,-0.11951E+01,& - -0.11962E+01,-0.11973E+01,-0.11985E+01,-0.11996E+01,-0.12007E+01,& - -0.12018E+01,-0.12029E+01,-0.12041E+01,-0.12052E+01,-0.12063E+01,& - -0.12074E+01,-0.12085E+01,-0.12096E+01,-0.12107E+01,-0.12118E+01,& - -0.12129E+01,-0.12140E+01,-0.12151E+01,-0.12162E+01,-0.12173E+01,& - -0.12184E+01,-0.12195E+01,-0.12206E+01,-0.12217E+01,-0.12228E+01,& - -0.12239E+01,-0.12250E+01,-0.12261E+01,-0.12272E+01,-0.12283E+01,& - -0.12293E+01,-0.12304E+01,-0.12315E+01,-0.12326E+01,-0.12337E+01,& - -0.12348E+01,-0.12358E+01,-0.12369E+01,-0.12380E+01,-0.12391E+01,& - -0.12401E+01,-0.12412E+01,-0.12423E+01,-0.12433E+01,-0.12444E+01,& - -0.12455E+01,-0.12465E+01,-0.12476E+01,-0.12487E+01,-0.12497E+01,& - -0.12508E+01,-0.12519E+01,-0.12529E+01,-0.12540E+01,-0.12550E+01,& - -0.12561E+01,-0.12571E+01,-0.12582E+01,-0.12592E+01,-0.12603E+01,& - -0.12613E+01,-0.12624E+01,-0.12634E+01,-0.12645E+01,-0.12655E+01,& - -0.12666E+01,-0.12676E+01,-0.12687E+01,-0.12697E+01,-0.12708E+01/ - - DATA (BNC07M (IA),IA=401,500)/ & - -0.12718E+01,-0.12728E+01,-0.12739E+01,-0.12749E+01,-0.12759E+01,& - -0.12770E+01,-0.12780E+01,-0.12790E+01,-0.12801E+01,-0.12811E+01,& - -0.12821E+01,-0.12832E+01,-0.12842E+01,-0.12852E+01,-0.12862E+01,& - -0.12873E+01,-0.12883E+01,-0.12893E+01,-0.12903E+01,-0.12914E+01,& - -0.12924E+01,-0.12934E+01,-0.12944E+01,-0.12954E+01,-0.12964E+01,& - -0.12975E+01,-0.12985E+01,-0.12995E+01,-0.13005E+01,-0.13015E+01,& - -0.13025E+01,-0.13035E+01,-0.13045E+01,-0.13055E+01,-0.13066E+01,& - -0.13076E+01,-0.13086E+01,-0.13096E+01,-0.13106E+01,-0.13116E+01,& - -0.13126E+01,-0.13136E+01,-0.13146E+01,-0.13156E+01,-0.13166E+01,& - -0.13176E+01,-0.13186E+01,-0.13196E+01,-0.13206E+01,-0.13216E+01,& - -0.13226E+01,-0.13235E+01,-0.13245E+01,-0.13255E+01,-0.13265E+01,& - -0.13275E+01,-0.13285E+01,-0.13295E+01,-0.13305E+01,-0.13315E+01,& - -0.13324E+01,-0.13334E+01,-0.13344E+01,-0.13354E+01,-0.13364E+01,& - -0.13374E+01,-0.13383E+01,-0.13393E+01,-0.13403E+01,-0.13413E+01,& - -0.13423E+01,-0.13432E+01,-0.13442E+01,-0.13452E+01,-0.13462E+01,& - -0.13471E+01,-0.13481E+01,-0.13491E+01,-0.13500E+01,-0.13510E+01,& - -0.13520E+01,-0.13530E+01,-0.13539E+01,-0.13549E+01,-0.13559E+01,& - -0.13568E+01,-0.13578E+01,-0.13588E+01,-0.13597E+01,-0.13607E+01,& - -0.13617E+01,-0.13626E+01,-0.13636E+01,-0.13645E+01,-0.13655E+01,& - -0.13665E+01,-0.13674E+01,-0.13684E+01,-0.13693E+01,-0.13703E+01/ - - DATA (BNC07M (IA),IA=501,600)/ & - -0.13712E+01,-0.13722E+01,-0.13732E+01,-0.13741E+01,-0.13751E+01,& - -0.13760E+01,-0.13770E+01,-0.13779E+01,-0.13789E+01,-0.13798E+01,& - -0.13808E+01,-0.13817E+01,-0.13827E+01,-0.13836E+01,-0.13846E+01,& - -0.13855E+01,-0.13865E+01,-0.13874E+01,-0.13883E+01,-0.13893E+01,& - -0.13902E+01,-0.13912E+01,-0.13921E+01,-0.13931E+01,-0.13940E+01,& - -0.13949E+01,-0.13959E+01,-0.13968E+01,-0.13978E+01,-0.13987E+01,& - -0.13996E+01,-0.14006E+01,-0.14015E+01,-0.14024E+01,-0.14034E+01,& - -0.14043E+01,-0.14052E+01,-0.14062E+01,-0.14071E+01,-0.14080E+01,& - -0.14090E+01,-0.14099E+01,-0.14108E+01,-0.14118E+01,-0.14127E+01,& - -0.14136E+01,-0.14145E+01,-0.14155E+01,-0.14164E+01,-0.14173E+01,& - -0.14182E+01,-0.14192E+01,-0.14201E+01,-0.14210E+01,-0.14219E+01,& - -0.14229E+01,-0.14238E+01,-0.14247E+01,-0.14256E+01,-0.14265E+01,& - -0.14275E+01,-0.14284E+01,-0.14293E+01,-0.14302E+01,-0.14311E+01,& - -0.14321E+01,-0.14330E+01,-0.14339E+01,-0.14348E+01,-0.14357E+01,& - -0.14366E+01,-0.14375E+01,-0.14385E+01,-0.14394E+01,-0.14403E+01,& - -0.14412E+01,-0.14421E+01,-0.14430E+01,-0.14439E+01,-0.14448E+01,& - -0.14457E+01,-0.14467E+01,-0.14476E+01,-0.14485E+01,-0.14494E+01,& - -0.14503E+01,-0.14512E+01,-0.14521E+01,-0.14530E+01,-0.14539E+01,& - -0.14548E+01,-0.14557E+01,-0.14566E+01,-0.14575E+01,-0.14584E+01,& - -0.14593E+01,-0.14602E+01,-0.14611E+01,-0.14620E+01,-0.14654E+01/ - - DATA (BNC07M (IA),IA=601,700)/ & - -0.14728E+01,-0.14817E+01,-0.14906E+01,-0.14994E+01,-0.15082E+01,& - -0.15170E+01,-0.15257E+01,-0.15343E+01,-0.15430E+01,-0.15515E+01,& - -0.15601E+01,-0.15686E+01,-0.15771E+01,-0.15856E+01,-0.15940E+01,& - -0.16024E+01,-0.16107E+01,-0.16191E+01,-0.16274E+01,-0.16356E+01,& - -0.16439E+01,-0.16521E+01,-0.16603E+01,-0.16684E+01,-0.16766E+01,& - -0.16847E+01,-0.16928E+01,-0.17008E+01,-0.17089E+01,-0.17169E+01,& - -0.17249E+01,-0.17328E+01,-0.17408E+01,-0.17487E+01,-0.17566E+01,& - -0.17645E+01,-0.17723E+01,-0.17802E+01,-0.17880E+01,-0.17958E+01,& - -0.18036E+01,-0.18114E+01,-0.18191E+01,-0.18268E+01,-0.18346E+01,& - -0.18423E+01,-0.18499E+01,-0.18576E+01,-0.18652E+01,-0.18729E+01,& - -0.18805E+01,-0.18881E+01,-0.18957E+01,-0.19032E+01,-0.19108E+01,& - -0.19183E+01,-0.19258E+01,-0.19334E+01,-0.19409E+01,-0.19483E+01,& - -0.19558E+01,-0.19633E+01,-0.19707E+01,-0.19781E+01,-0.19855E+01,& - -0.19929E+01,-0.20003E+01,-0.20077E+01,-0.20151E+01,-0.20224E+01,& - -0.20298E+01,-0.20371E+01,-0.20444E+01,-0.20517E+01,-0.20590E+01,& - -0.20663E+01,-0.20736E+01,-0.20808E+01,-0.20881E+01,-0.20953E+01,& - -0.21026E+01,-0.21098E+01,-0.21170E+01,-0.21242E+01,-0.21314E+01,& - -0.21386E+01,-0.21457E+01,-0.21529E+01,-0.21601E+01,-0.21672E+01,& - -0.21743E+01,-0.21815E+01,-0.21886E+01,-0.21957E+01,-0.22028E+01,& - -0.22099E+01,-0.22169E+01,-0.22240E+01,-0.22311E+01,-0.22381E+01/ - - DATA (BNC07M(IA),IA=701,741)/ & - -0.22452E+01,-0.22522E+01,-0.22593E+01,-0.22663E+01,-0.22733E+01,& - -0.22803E+01,-0.22873E+01,-0.22943E+01,-0.23013E+01,-0.23082E+01,& - -0.23152E+01,-0.23222E+01,-0.23291E+01,-0.23361E+01,-0.23430E+01,& - -0.23499E+01,-0.23569E+01,-0.23638E+01,-0.23707E+01,-0.23776E+01,& - -0.23845E+01,-0.23914E+01,-0.23983E+01,-0.24052E+01,-0.24120E+01,& - -0.24189E+01,-0.24258E+01,-0.24326E+01,-0.24395E+01,-0.24463E+01,& - -0.24531E+01,-0.24600E+01,-0.24668E+01,-0.24736E+01,-0.24804E+01,& - -0.24872E+01,-0.24940E+01,-0.25008E+01,-0.25076E+01,-0.25144E+01,& - -0.25211E+01 / -! -! ** (H, HSO4) -! - DATA (BNC08M (IA),IA= 1,100)/ & - -0.50088E-01,-0.84806E-01,-0.10501E+00,-0.11624E+00,-0.12318E+00,& - -0.12753E+00,-0.13011E+00,-0.13139E+00,-0.13166E+00,-0.13112E+00,& - -0.12989E+00,-0.12809E+00,-0.12579E+00,-0.12304E+00,-0.11990E+00,& - -0.11640E+00,-0.11257E+00,-0.10844E+00,-0.10403E+00,-0.99358E-01,& - -0.94441E-01,-0.89293E-01,-0.83928E-01,-0.78356E-01,-0.72588E-01,& - -0.66634E-01,-0.60502E-01,-0.54201E-01,-0.47738E-01,-0.41119E-01,& - -0.34352E-01,-0.27443E-01,-0.20397E-01,-0.13221E-01,-0.59198E-02,& - 0.15015E-02, 0.90380E-02, 0.16685E-01, 0.24437E-01, 0.32290E-01,& - 0.40241E-01, 0.48284E-01, 0.56416E-01, 0.64634E-01, 0.72933E-01,& - 0.81310E-01, 0.89763E-01, 0.98287E-01, 0.10688E+00, 0.11554E+00,& - 0.12426E+00, 0.13304E+00, 0.14189E+00, 0.15078E+00, 0.15974E+00,& - 0.16874E+00, 0.17780E+00, 0.18691E+00, 0.19606E+00, 0.20527E+00,& - 0.21452E+00, 0.22381E+00, 0.23315E+00, 0.24254E+00, 0.25197E+00,& - 0.26144E+00, 0.27096E+00, 0.28052E+00, 0.29013E+00, 0.29978E+00,& - 0.30948E+00, 0.31922E+00, 0.32902E+00, 0.33885E+00, 0.34874E+00,& - 0.35868E+00, 0.36866E+00, 0.37870E+00, 0.38878E+00, 0.39892E+00,& - 0.40911E+00, 0.41936E+00, 0.42965E+00, 0.44000E+00, 0.45041E+00,& - 0.46087E+00, 0.47138E+00, 0.48195E+00, 0.49257E+00, 0.50325E+00,& - 0.51398E+00, 0.52476E+00, 0.53560E+00, 0.54648E+00, 0.55742E+00,& - 0.56840E+00, 0.57944E+00, 0.59052E+00, 0.60164E+00, 0.61281E+00/ - - DATA (BNC08M (IA),IA=101,200)/ & - 0.62402E+00, 0.63527E+00, 0.64656E+00, 0.65788E+00, 0.66924E+00,& - 0.68062E+00, 0.69204E+00, 0.70349E+00, 0.71496E+00, 0.72646E+00,& - 0.73797E+00, 0.74951E+00, 0.76106E+00, 0.77263E+00, 0.78421E+00,& - 0.79581E+00, 0.80741E+00, 0.81902E+00, 0.83063E+00, 0.84225E+00,& - 0.85289E+00, 0.86463E+00, 0.87635E+00, 0.88806E+00, 0.89976E+00,& - 0.91145E+00, 0.92312E+00, 0.93477E+00, 0.94641E+00, 0.95804E+00,& - 0.96965E+00, 0.98124E+00, 0.99282E+00, 0.10044E+01, 0.10159E+01,& - 0.10274E+01, 0.10390E+01, 0.10504E+01, 0.10619E+01, 0.10734E+01,& - 0.10848E+01, 0.10962E+01, 0.11076E+01, 0.11190E+01, 0.11303E+01,& - 0.11417E+01, 0.11530E+01, 0.11643E+01, 0.11756E+01, 0.11868E+01,& - 0.11980E+01, 0.12093E+01, 0.12204E+01, 0.12316E+01, 0.12428E+01,& - 0.12539E+01, 0.12650E+01, 0.12761E+01, 0.12871E+01, 0.12982E+01,& - 0.13092E+01, 0.13202E+01, 0.13311E+01, 0.13421E+01, 0.13530E+01,& - 0.13639E+01, 0.13748E+01, 0.13857E+01, 0.13965E+01, 0.14073E+01,& - 0.14181E+01, 0.14289E+01, 0.14396E+01, 0.14504E+01, 0.14611E+01,& - 0.14717E+01, 0.14824E+01, 0.14930E+01, 0.15036E+01, 0.15142E+01,& - 0.15248E+01, 0.15353E+01, 0.15458E+01, 0.15563E+01, 0.15668E+01,& - 0.15773E+01, 0.15877E+01, 0.15981E+01, 0.16085E+01, 0.16188E+01,& - 0.16292E+01, 0.16395E+01, 0.16498E+01, 0.16600E+01, 0.16703E+01,& - 0.16805E+01, 0.16907E+01, 0.17009E+01, 0.17110E+01, 0.17212E+01/ - - DATA (BNC08M (IA),IA=201,300)/ & - 0.17313E+01, 0.17414E+01, 0.17514E+01, 0.17615E+01, 0.17715E+01,& - 0.17815E+01, 0.17915E+01, 0.18014E+01, 0.18114E+01, 0.18213E+01,& - 0.18312E+01, 0.18410E+01, 0.18509E+01, 0.18607E+01, 0.18705E+01,& - 0.18803E+01, 0.18901E+01, 0.18998E+01, 0.19095E+01, 0.19192E+01,& - 0.19289E+01, 0.19385E+01, 0.19482E+01, 0.19578E+01, 0.19674E+01,& - 0.19769E+01, 0.19865E+01, 0.19960E+01, 0.20055E+01, 0.20150E+01,& - 0.20244E+01, 0.20339E+01, 0.20433E+01, 0.20527E+01, 0.20621E+01,& - 0.20715E+01, 0.20808E+01, 0.20901E+01, 0.20994E+01, 0.21087E+01,& - 0.21179E+01, 0.21272E+01, 0.21364E+01, 0.21456E+01, 0.21548E+01,& - 0.21639E+01, 0.21731E+01, 0.21822E+01, 0.21913E+01, 0.22004E+01,& - 0.22094E+01, 0.22185E+01, 0.22275E+01, 0.22365E+01, 0.22455E+01,& - 0.22545E+01, 0.22634E+01, 0.22723E+01, 0.22812E+01, 0.22901E+01,& - 0.22990E+01, 0.23078E+01, 0.23167E+01, 0.23255E+01, 0.23343E+01,& - 0.23431E+01, 0.23518E+01, 0.23606E+01, 0.23693E+01, 0.23780E+01,& - 0.23867E+01, 0.23953E+01, 0.24040E+01, 0.24126E+01, 0.24212E+01,& - 0.24298E+01, 0.24384E+01, 0.24470E+01, 0.24555E+01, 0.24640E+01,& - 0.24725E+01, 0.24810E+01, 0.24895E+01, 0.24980E+01, 0.25064E+01,& - 0.25148E+01, 0.25232E+01, 0.25316E+01, 0.25400E+01, 0.25483E+01,& - 0.25567E+01, 0.25650E+01, 0.25733E+01, 0.25816E+01, 0.25898E+01,& - 0.25981E+01, 0.26063E+01, 0.26145E+01, 0.26227E+01, 0.26309E+01/ - - DATA (BNC08M (IA),IA=301,400)/ & - 0.26391E+01, 0.26472E+01, 0.26554E+01, 0.26635E+01, 0.26716E+01,& - 0.26797E+01, 0.26877E+01, 0.26958E+01, 0.27038E+01, 0.27119E+01,& - 0.27199E+01, 0.27279E+01, 0.27358E+01, 0.27438E+01, 0.27517E+01,& - 0.27597E+01, 0.27676E+01, 0.27755E+01, 0.27834E+01, 0.27912E+01,& - 0.27991E+01, 0.28069E+01, 0.28148E+01, 0.28226E+01, 0.28304E+01,& - 0.28381E+01, 0.28459E+01, 0.28536E+01, 0.28614E+01, 0.28691E+01,& - 0.28768E+01, 0.28845E+01, 0.28922E+01, 0.28998E+01, 0.29075E+01,& - 0.29151E+01, 0.29227E+01, 0.29303E+01, 0.29379E+01, 0.29455E+01,& - 0.29530E+01, 0.29606E+01, 0.29681E+01, 0.29756E+01, 0.29831E+01,& - 0.29906E+01, 0.29981E+01, 0.30055E+01, 0.30130E+01, 0.30204E+01,& - 0.30278E+01, 0.30353E+01, 0.30426E+01, 0.30500E+01, 0.30574E+01,& - 0.30647E+01, 0.30721E+01, 0.30794E+01, 0.30867E+01, 0.30940E+01,& - 0.31013E+01, 0.31086E+01, 0.31158E+01, 0.31231E+01, 0.31303E+01,& - 0.31375E+01, 0.31447E+01, 0.31519E+01, 0.31591E+01, 0.31663E+01,& - 0.31734E+01, 0.31806E+01, 0.31877E+01, 0.31948E+01, 0.32019E+01,& - 0.32090E+01, 0.32161E+01, 0.32231E+01, 0.32302E+01, 0.32372E+01,& - 0.32443E+01, 0.32513E+01, 0.32583E+01, 0.32653E+01, 0.32722E+01,& - 0.32792E+01, 0.32862E+01, 0.32931E+01, 0.33000E+01, 0.33069E+01,& - 0.33139E+01, 0.33207E+01, 0.33276E+01, 0.33345E+01, 0.33414E+01,& - 0.33482E+01, 0.33550E+01, 0.33619E+01, 0.33687E+01, 0.33755E+01/ - - DATA (BNC08M (IA),IA=401,500)/ & - 0.33823E+01, 0.33890E+01, 0.33958E+01, 0.34026E+01, 0.34093E+01,& - 0.34160E+01, 0.34227E+01, 0.34294E+01, 0.34361E+01, 0.34428E+01,& - 0.34495E+01, 0.34562E+01, 0.34628E+01, 0.34695E+01, 0.34761E+01,& - 0.34827E+01, 0.34893E+01, 0.34959E+01, 0.35025E+01, 0.35091E+01,& - 0.35156E+01, 0.35222E+01, 0.35287E+01, 0.35352E+01, 0.35418E+01,& - 0.35483E+01, 0.35548E+01, 0.35612E+01, 0.35677E+01, 0.35742E+01,& - 0.35806E+01, 0.35871E+01, 0.35935E+01, 0.35999E+01, 0.36064E+01,& - 0.36128E+01, 0.36192E+01, 0.36255E+01, 0.36319E+01, 0.36383E+01,& - 0.36446E+01, 0.36510E+01, 0.36573E+01, 0.36636E+01, 0.36699E+01,& - 0.36762E+01, 0.36825E+01, 0.36888E+01, 0.36951E+01, 0.37013E+01,& - 0.37076E+01, 0.37138E+01, 0.37200E+01, 0.37262E+01, 0.37325E+01,& - 0.37387E+01, 0.37448E+01, 0.37510E+01, 0.37572E+01, 0.37634E+01,& - 0.37695E+01, 0.37757E+01, 0.37818E+01, 0.37879E+01, 0.37940E+01,& - 0.38001E+01, 0.38062E+01, 0.38123E+01, 0.38184E+01, 0.38244E+01,& - 0.38305E+01, 0.38365E+01, 0.38426E+01, 0.38486E+01, 0.38546E+01,& - 0.38606E+01, 0.38666E+01, 0.38726E+01, 0.38786E+01, 0.38846E+01,& - 0.38906E+01, 0.38965E+01, 0.39025E+01, 0.39084E+01, 0.39143E+01,& - 0.39202E+01, 0.39261E+01, 0.39320E+01, 0.39379E+01, 0.39438E+01,& - 0.39497E+01, 0.39556E+01, 0.39614E+01, 0.39673E+01, 0.39731E+01,& - 0.39789E+01, 0.39847E+01, 0.39906E+01, 0.39964E+01, 0.40022E+01/ - - DATA (BNC08M (IA),IA=501,600)/ & - 0.40079E+01, 0.40137E+01, 0.40195E+01, 0.40253E+01, 0.40310E+01,& - 0.40368E+01, 0.40425E+01, 0.40482E+01, 0.40539E+01, 0.40596E+01,& - 0.40653E+01, 0.40710E+01, 0.40767E+01, 0.40824E+01, 0.40881E+01,& - 0.40937E+01, 0.40994E+01, 0.41050E+01, 0.41107E+01, 0.41163E+01,& - 0.41219E+01, 0.41275E+01, 0.41331E+01, 0.41387E+01, 0.41443E+01,& - 0.41499E+01, 0.41554E+01, 0.41610E+01, 0.41666E+01, 0.41721E+01,& - 0.41776E+01, 0.41832E+01, 0.41887E+01, 0.41942E+01, 0.41997E+01,& - 0.42052E+01, 0.42107E+01, 0.42162E+01, 0.42217E+01, 0.42271E+01,& - 0.42326E+01, 0.42381E+01, 0.42435E+01, 0.42489E+01, 0.42544E+01,& - 0.42598E+01, 0.42652E+01, 0.42706E+01, 0.42760E+01, 0.42814E+01,& - 0.42868E+01, 0.42922E+01, 0.42975E+01, 0.43029E+01, 0.43082E+01,& - 0.43136E+01, 0.43189E+01, 0.43243E+01, 0.43296E+01, 0.43349E+01,& - 0.43402E+01, 0.43455E+01, 0.43508E+01, 0.43561E+01, 0.43614E+01,& - 0.43667E+01, 0.43719E+01, 0.43772E+01, 0.43824E+01, 0.43877E+01,& - 0.43929E+01, 0.43982E+01, 0.44034E+01, 0.44086E+01, 0.44138E+01,& - 0.44190E+01, 0.44242E+01, 0.44294E+01, 0.44346E+01, 0.44397E+01,& - 0.44449E+01, 0.44501E+01, 0.44552E+01, 0.44604E+01, 0.44655E+01,& - 0.44706E+01, 0.44758E+01, 0.44809E+01, 0.44860E+01, 0.44911E+01,& - 0.44962E+01, 0.45013E+01, 0.45064E+01, 0.45115E+01, 0.45165E+01,& - 0.45216E+01, 0.45267E+01, 0.45317E+01, 0.45368E+01, 0.45556E+01/ - - DATA (BNC08M (IA),IA=601,700)/ & - 0.45968E+01, 0.46461E+01, 0.46948E+01, 0.47428E+01, 0.47903E+01,& - 0.48372E+01, 0.48835E+01, 0.49293E+01, 0.49745E+01, 0.50191E+01,& - 0.50633E+01, 0.51069E+01, 0.51500E+01, 0.51927E+01, 0.52349E+01,& - 0.52765E+01, 0.53178E+01, 0.53586E+01, 0.53989E+01, 0.54388E+01,& - 0.54783E+01, 0.55174E+01, 0.55560E+01, 0.55943E+01, 0.56322E+01,& - 0.56696E+01, 0.57067E+01, 0.57435E+01, 0.57799E+01, 0.58159E+01,& - 0.58515E+01, 0.58869E+01, 0.59218E+01, 0.59565E+01, 0.59908E+01,& - 0.60248E+01, 0.60585E+01, 0.60919E+01, 0.61249E+01, 0.61577E+01,& - 0.61902E+01, 0.62224E+01, 0.62543E+01, 0.62859E+01, 0.63172E+01,& - 0.63483E+01, 0.63791E+01, 0.64096E+01, 0.64399E+01, 0.64699E+01,& - 0.64997E+01, 0.65292E+01, 0.65585E+01, 0.65875E+01, 0.66163E+01,& - 0.66449E+01, 0.66733E+01, 0.67014E+01, 0.67293E+01, 0.67569E+01,& - 0.67844E+01, 0.68116E+01, 0.68387E+01, 0.68655E+01, 0.68921E+01,& - 0.69185E+01, 0.69447E+01, 0.69707E+01, 0.69966E+01, 0.70222E+01,& - 0.70477E+01, 0.70729E+01, 0.70980E+01, 0.71229E+01, 0.71476E+01,& - 0.71721E+01, 0.71965E+01, 0.72207E+01, 0.72447E+01, 0.72686E+01,& - 0.72922E+01, 0.73158E+01, 0.73391E+01, 0.73623E+01, 0.73854E+01,& - 0.74082E+01, 0.74310E+01, 0.74536E+01, 0.74760E+01, 0.74983E+01,& - 0.75204E+01, 0.75424E+01, 0.75642E+01, 0.75859E+01, 0.76075E+01,& - 0.76289E+01, 0.76502E+01, 0.76714E+01, 0.76924E+01, 0.77132E+01/ - - DATA (BNC08M(IA),IA=701,741)/ & - 0.77340E+01, 0.77546E+01, 0.77751E+01, 0.77955E+01, 0.78157E+01,& - 0.78358E+01, 0.78558E+01, 0.78757E+01, 0.78955E+01, 0.79151E+01,& - 0.79346E+01, 0.79540E+01, 0.79733E+01, 0.79925E+01, 0.80115E+01,& - 0.80305E+01, 0.80493E+01, 0.80680E+01, 0.80867E+01, 0.81052E+01,& - 0.81236E+01, 0.81419E+01, 0.81601E+01, 0.81782E+01, 0.81961E+01,& - 0.82140E+01, 0.82318E+01, 0.82495E+01, 0.82671E+01, 0.82846E+01,& - 0.83020E+01, 0.83193E+01, 0.83365E+01, 0.83536E+01, 0.83706E+01,& - 0.83876E+01, 0.84044E+01, 0.84212E+01, 0.84378E+01, 0.84544E+01,& - 0.84709E+01 / -! -! ** NH4HSO4 -! - DATA (BNC09M (IA),IA= 1,100)/ & - -0.52941E-01,-0.94844E-01,-0.12343E+00,-0.14239E+00,-0.15668E+00,& - -0.16813E+00,-0.17763E+00,-0.18572E+00,-0.19272E+00,-0.19884E+00,& - -0.20425E+00,-0.20906E+00,-0.21335E+00,-0.21720E+00,-0.22065E+00,& - -0.22375E+00,-0.22654E+00,-0.22903E+00,-0.23127E+00,-0.23327E+00,& - -0.23504E+00,-0.23660E+00,-0.23797E+00,-0.23915E+00,-0.24017E+00,& - -0.24102E+00,-0.24171E+00,-0.24226E+00,-0.24267E+00,-0.24294E+00,& - -0.24309E+00,-0.24311E+00,-0.24302E+00,-0.24281E+00,-0.24250E+00,& - -0.24208E+00,-0.24156E+00,-0.24094E+00,-0.24023E+00,-0.23943E+00,& - -0.23854E+00,-0.23757E+00,-0.23652E+00,-0.23539E+00,-0.23418E+00,& - -0.23290E+00,-0.23155E+00,-0.23014E+00,-0.22866E+00,-0.22711E+00,& - -0.22551E+00,-0.22384E+00,-0.22212E+00,-0.22034E+00,-0.21851E+00,& - -0.21663E+00,-0.21470E+00,-0.21272E+00,-0.21069E+00,-0.20862E+00,& - -0.20650E+00,-0.20434E+00,-0.20214E+00,-0.19990E+00,-0.19762E+00,& - -0.19530E+00,-0.19294E+00,-0.19054E+00,-0.18811E+00,-0.18564E+00,& - -0.18314E+00,-0.18060E+00,-0.17803E+00,-0.17542E+00,-0.17278E+00,& - -0.17011E+00,-0.16741E+00,-0.16467E+00,-0.16191E+00,-0.15911E+00,& - -0.15628E+00,-0.15342E+00,-0.15053E+00,-0.14761E+00,-0.14466E+00,& - -0.14168E+00,-0.13867E+00,-0.13563E+00,-0.13256E+00,-0.12947E+00,& - -0.12635E+00,-0.12321E+00,-0.12003E+00,-0.11684E+00,-0.11361E+00,& - -0.11037E+00,-0.10710E+00,-0.10381E+00,-0.10049E+00,-0.97158E-01/ - - DATA (BNC09M (IA),IA=101,200)/ & - -0.93803E-01,-0.90429E-01,-0.87037E-01,-0.83628E-01,-0.80202E-01,& - -0.76760E-01,-0.73304E-01,-0.69834E-01,-0.66351E-01,-0.62857E-01,& - -0.59352E-01,-0.55836E-01,-0.52311E-01,-0.48778E-01,-0.45238E-01,& - -0.41691E-01,-0.38138E-01,-0.34580E-01,-0.31018E-01,-0.27452E-01,& - -0.24230E-01,-0.20619E-01,-0.17011E-01,-0.13406E-01,-0.98032E-02,& - -0.62041E-02,-0.26086E-02, 0.98318E-03, 0.45710E-02, 0.81547E-02,& - 0.11734E-01, 0.15308E-01, 0.18878E-01, 0.22443E-01, 0.26003E-01,& - 0.29557E-01, 0.33105E-01, 0.36648E-01, 0.40186E-01, 0.43717E-01,& - 0.47242E-01, 0.50762E-01, 0.54274E-01, 0.57781E-01, 0.61281E-01,& - 0.64774E-01, 0.68261E-01, 0.71740E-01, 0.75213E-01, 0.78679E-01,& - 0.82138E-01, 0.85590E-01, 0.89034E-01, 0.92472E-01, 0.95902E-01,& - 0.99324E-01, 0.10274E+00, 0.10615E+00, 0.10955E+00, 0.11294E+00,& - 0.11633E+00, 0.11970E+00, 0.12307E+00, 0.12643E+00, 0.12979E+00,& - 0.13314E+00, 0.13647E+00, 0.13981E+00, 0.14313E+00, 0.14644E+00,& - 0.14975E+00, 0.15305E+00, 0.15634E+00, 0.15963E+00, 0.16290E+00,& - 0.16617E+00, 0.16943E+00, 0.17268E+00, 0.17593E+00, 0.17917E+00,& - 0.18239E+00, 0.18562E+00, 0.18883E+00, 0.19203E+00, 0.19523E+00,& - 0.19842E+00, 0.20160E+00, 0.20478E+00, 0.20794E+00, 0.21110E+00,& - 0.21425E+00, 0.21739E+00, 0.22053E+00, 0.22366E+00, 0.22677E+00,& - 0.22989E+00, 0.23299E+00, 0.23609E+00, 0.23917E+00, 0.24226E+00/ - - DATA (BNC09M (IA),IA=201,300)/ & - 0.24533E+00, 0.24839E+00, 0.25145E+00, 0.25450E+00, 0.25755E+00,& - 0.26058E+00, 0.26361E+00, 0.26663E+00, 0.26964E+00, 0.27265E+00,& - 0.27565E+00, 0.27864E+00, 0.28162E+00, 0.28460E+00, 0.28756E+00,& - 0.29053E+00, 0.29348E+00, 0.29643E+00, 0.29937E+00, 0.30230E+00,& - 0.30522E+00, 0.30814E+00, 0.31105E+00, 0.31396E+00, 0.31685E+00,& - 0.31974E+00, 0.32263E+00, 0.32550E+00, 0.32837E+00, 0.33123E+00,& - 0.33409E+00, 0.33694E+00, 0.33978E+00, 0.34261E+00, 0.34544E+00,& - 0.34826E+00, 0.35108E+00, 0.35388E+00, 0.35668E+00, 0.35948E+00,& - 0.36227E+00, 0.36505E+00, 0.36782E+00, 0.37059E+00, 0.37335E+00,& - 0.37610E+00, 0.37885E+00, 0.38159E+00, 0.38433E+00, 0.38706E+00,& - 0.38978E+00, 0.39250E+00, 0.39521E+00, 0.39791E+00, 0.40061E+00,& - 0.40330E+00, 0.40598E+00, 0.40866E+00, 0.41133E+00, 0.41400E+00,& - 0.41666E+00, 0.41931E+00, 0.42196E+00, 0.42460E+00, 0.42724E+00,& - 0.42987E+00, 0.43249E+00, 0.43511E+00, 0.43772E+00, 0.44033E+00,& - 0.44293E+00, 0.44552E+00, 0.44811E+00, 0.45069E+00, 0.45327E+00,& - 0.45584E+00, 0.45841E+00, 0.46097E+00, 0.46352E+00, 0.46607E+00,& - 0.46861E+00, 0.47115E+00, 0.47368E+00, 0.47620E+00, 0.47872E+00,& - 0.48124E+00, 0.48375E+00, 0.48625E+00, 0.48875E+00, 0.49124E+00,& - 0.49373E+00, 0.49621E+00, 0.49869E+00, 0.50116E+00, 0.50362E+00,& - 0.50608E+00, 0.50854E+00, 0.51099E+00, 0.51343E+00, 0.51587E+00/ - - DATA (BNC09M (IA),IA=301,400)/ & - 0.51831E+00, 0.52073E+00, 0.52316E+00, 0.52558E+00, 0.52799E+00,& - 0.53040E+00, 0.53280E+00, 0.53520E+00, 0.53759E+00, 0.53998E+00,& - 0.54236E+00, 0.54474E+00, 0.54711E+00, 0.54948E+00, 0.55184E+00,& - 0.55420E+00, 0.55655E+00, 0.55890E+00, 0.56125E+00, 0.56358E+00,& - 0.56592E+00, 0.56825E+00, 0.57057E+00, 0.57289E+00, 0.57520E+00,& - 0.57751E+00, 0.57982E+00, 0.58212E+00, 0.58442E+00, 0.58671E+00,& - 0.58899E+00, 0.59127E+00, 0.59355E+00, 0.59582E+00, 0.59809E+00,& - 0.60036E+00, 0.60261E+00, 0.60487E+00, 0.60712E+00, 0.60936E+00,& - 0.61160E+00, 0.61384E+00, 0.61607E+00, 0.61830E+00, 0.62052E+00,& - 0.62274E+00, 0.62495E+00, 0.62716E+00, 0.62937E+00, 0.63157E+00,& - 0.63377E+00, 0.63596E+00, 0.63815E+00, 0.64033E+00, 0.64251E+00,& - 0.64469E+00, 0.64686E+00, 0.64902E+00, 0.65119E+00, 0.65334E+00,& - 0.65550E+00, 0.65765E+00, 0.65979E+00, 0.66194E+00, 0.66407E+00,& - 0.66621E+00, 0.66834E+00, 0.67046E+00, 0.67258E+00, 0.67470E+00,& - 0.67681E+00, 0.67892E+00, 0.68103E+00, 0.68313E+00, 0.68523E+00,& - 0.68732E+00, 0.68941E+00, 0.69150E+00, 0.69358E+00, 0.69565E+00,& - 0.69773E+00, 0.69980E+00, 0.70186E+00, 0.70393E+00, 0.70598E+00,& - 0.70804E+00, 0.71009E+00, 0.71214E+00, 0.71418E+00, 0.71622E+00,& - 0.71825E+00, 0.72028E+00, 0.72231E+00, 0.72434E+00, 0.72636E+00,& - 0.72837E+00, 0.73039E+00, 0.73240E+00, 0.73440E+00, 0.73640E+00/ - - DATA (BNC09M (IA),IA=401,500)/ & - 0.73840E+00, 0.74040E+00, 0.74239E+00, 0.74438E+00, 0.74636E+00,& - 0.74834E+00, 0.75032E+00, 0.75229E+00, 0.75426E+00, 0.75623E+00,& - 0.75819E+00, 0.76015E+00, 0.76210E+00, 0.76405E+00, 0.76600E+00,& - 0.76795E+00, 0.76989E+00, 0.77183E+00, 0.77376E+00, 0.77569E+00,& - 0.77762E+00, 0.77955E+00, 0.78147E+00, 0.78338E+00, 0.78530E+00,& - 0.78721E+00, 0.78912E+00, 0.79102E+00, 0.79292E+00, 0.79482E+00,& - 0.79671E+00, 0.79861E+00, 0.80049E+00, 0.80238E+00, 0.80426E+00,& - 0.80614E+00, 0.80801E+00, 0.80988E+00, 0.81175E+00, 0.81361E+00,& - 0.81548E+00, 0.81733E+00, 0.81919E+00, 0.82104E+00, 0.82289E+00,& - 0.82474E+00, 0.82658E+00, 0.82842E+00, 0.83025E+00, 0.83209E+00,& - 0.83392E+00, 0.83574E+00, 0.83757E+00, 0.83939E+00, 0.84121E+00,& - 0.84302E+00, 0.84483E+00, 0.84664E+00, 0.84845E+00, 0.85025E+00,& - 0.85205E+00, 0.85384E+00, 0.85564E+00, 0.85743E+00, 0.85921E+00,& - 0.86100E+00, 0.86278E+00, 0.86456E+00, 0.86633E+00, 0.86811E+00,& - 0.86988E+00, 0.87164E+00, 0.87341E+00, 0.87517E+00, 0.87692E+00,& - 0.87868E+00, 0.88043E+00, 0.88218E+00, 0.88393E+00, 0.88567E+00,& - 0.88741E+00, 0.88915E+00, 0.89088E+00, 0.89262E+00, 0.89434E+00,& - 0.89607E+00, 0.89779E+00, 0.89952E+00, 0.90123E+00, 0.90295E+00,& - 0.90466E+00, 0.90637E+00, 0.90808E+00, 0.90978E+00, 0.91148E+00,& - 0.91318E+00, 0.91488E+00, 0.91657E+00, 0.91826E+00, 0.91995E+00/ - - DATA (BNC09M (IA),IA=501,600)/ & - 0.92163E+00, 0.92332E+00, 0.92500E+00, 0.92667E+00, 0.92835E+00,& - 0.93002E+00, 0.93169E+00, 0.93335E+00, 0.93502E+00, 0.93668E+00,& - 0.93834E+00, 0.93999E+00, 0.94165E+00, 0.94330E+00, 0.94495E+00,& - 0.94659E+00, 0.94823E+00, 0.94987E+00, 0.95151E+00, 0.95315E+00,& - 0.95478E+00, 0.95641E+00, 0.95804E+00, 0.95966E+00, 0.96128E+00,& - 0.96290E+00, 0.96452E+00, 0.96614E+00, 0.96775E+00, 0.96936E+00,& - 0.97097E+00, 0.97257E+00, 0.97417E+00, 0.97577E+00, 0.97737E+00,& - 0.97897E+00, 0.98056E+00, 0.98215E+00, 0.98374E+00, 0.98532E+00,& - 0.98690E+00, 0.98848E+00, 0.99006E+00, 0.99164E+00, 0.99321E+00,& - 0.99478E+00, 0.99635E+00, 0.99792E+00, 0.99948E+00, 0.10010E+01,& - 0.10026E+01, 0.10042E+01, 0.10057E+01, 0.10073E+01, 0.10088E+01,& - 0.10104E+01, 0.10119E+01, 0.10134E+01, 0.10150E+01, 0.10165E+01,& - 0.10181E+01, 0.10196E+01, 0.10211E+01, 0.10227E+01, 0.10242E+01,& - 0.10257E+01, 0.10272E+01, 0.10287E+01, 0.10303E+01, 0.10318E+01,& - 0.10333E+01, 0.10348E+01, 0.10363E+01, 0.10378E+01, 0.10393E+01,& - 0.10408E+01, 0.10423E+01, 0.10438E+01, 0.10453E+01, 0.10468E+01,& - 0.10483E+01, 0.10498E+01, 0.10513E+01, 0.10528E+01, 0.10542E+01,& - 0.10557E+01, 0.10572E+01, 0.10587E+01, 0.10601E+01, 0.10616E+01,& - 0.10631E+01, 0.10646E+01, 0.10660E+01, 0.10675E+01, 0.10689E+01,& - 0.10704E+01, 0.10719E+01, 0.10733E+01, 0.10748E+01, 0.10802E+01/ - - DATA (BNC09M (IA),IA=601,700)/ & - 0.10920E+01, 0.11062E+01, 0.11202E+01, 0.11339E+01, 0.11475E+01,& - 0.11609E+01, 0.11741E+01, 0.11872E+01, 0.12000E+01, 0.12127E+01,& - 0.12252E+01, 0.12376E+01, 0.12498E+01, 0.12619E+01, 0.12738E+01,& - 0.12855E+01, 0.12971E+01, 0.13086E+01, 0.13199E+01, 0.13311E+01,& - 0.13421E+01, 0.13531E+01, 0.13638E+01, 0.13745E+01, 0.13850E+01,& - 0.13954E+01, 0.14057E+01, 0.14159E+01, 0.14259E+01, 0.14359E+01,& - 0.14457E+01, 0.14554E+01, 0.14650E+01, 0.14745E+01, 0.14839E+01,& - 0.14932E+01, 0.15024E+01, 0.15115E+01, 0.15205E+01, 0.15294E+01,& - 0.15382E+01, 0.15469E+01, 0.15555E+01, 0.15641E+01, 0.15725E+01,& - 0.15808E+01, 0.15891E+01, 0.15973E+01, 0.16054E+01, 0.16134E+01,& - 0.16213E+01, 0.16292E+01, 0.16370E+01, 0.16447E+01, 0.16523E+01,& - 0.16598E+01, 0.16673E+01, 0.16747E+01, 0.16820E+01, 0.16893E+01,& - 0.16965E+01, 0.17036E+01, 0.17106E+01, 0.17176E+01, 0.17245E+01,& - 0.17314E+01, 0.17381E+01, 0.17449E+01, 0.17515E+01, 0.17581E+01,& - 0.17646E+01, 0.17711E+01, 0.17775E+01, 0.17839E+01, 0.17902E+01,& - 0.17964E+01, 0.18026E+01, 0.18087E+01, 0.18148E+01, 0.18208E+01,& - 0.18268E+01, 0.18327E+01, 0.18385E+01, 0.18443E+01, 0.18501E+01,& - 0.18558E+01, 0.18614E+01, 0.18671E+01, 0.18726E+01, 0.18781E+01,& - 0.18836E+01, 0.18890E+01, 0.18943E+01, 0.18997E+01, 0.19049E+01,& - 0.19102E+01, 0.19153E+01, 0.19205E+01, 0.19256E+01, 0.19306E+01/ - - DATA (BNC09M(IA),IA=701,741)/ & - 0.19356E+01, 0.19406E+01, 0.19455E+01, 0.19504E+01, 0.19552E+01,& - 0.19600E+01, 0.19648E+01, 0.19695E+01, 0.19742E+01, 0.19788E+01,& - 0.19835E+01, 0.19880E+01, 0.19925E+01, 0.19970E+01, 0.20015E+01,& - 0.20059E+01, 0.20103E+01, 0.20146E+01, 0.20190E+01, 0.20232E+01,& - 0.20275E+01, 0.20317E+01, 0.20359E+01, 0.20400E+01, 0.20441E+01,& - 0.20482E+01, 0.20522E+01, 0.20562E+01, 0.20602E+01, 0.20641E+01,& - 0.20681E+01, 0.20719E+01, 0.20758E+01, 0.20796E+01, 0.20834E+01,& - 0.20872E+01, 0.20909E+01, 0.20946E+01, 0.20983E+01, 0.21019E+01,& - 0.21055E+01 / -! -! ** (H, NO3) -! - DATA (BNC10M (IA),IA= 1,100)/ & - -0.52126E-01,-0.91475E-01,-0.11662E+00,-0.13216E+00,-0.14305E+00,& - -0.15115E+00,-0.15736E+00,-0.16220E+00,-0.16600E+00,-0.16898E+00,& - -0.17131E+00,-0.17309E+00,-0.17442E+00,-0.17536E+00,-0.17597E+00,& - -0.17629E+00,-0.17637E+00,-0.17622E+00,-0.17588E+00,-0.17536E+00,& - -0.17469E+00,-0.17388E+00,-0.17294E+00,-0.17189E+00,-0.17074E+00,& - -0.16950E+00,-0.16817E+00,-0.16677E+00,-0.16530E+00,-0.16377E+00,& - -0.16218E+00,-0.16054E+00,-0.15885E+00,-0.15712E+00,-0.15535E+00,& - -0.15355E+00,-0.15172E+00,-0.14986E+00,-0.14797E+00,-0.14606E+00,& - -0.14413E+00,-0.14218E+00,-0.14022E+00,-0.13824E+00,-0.13625E+00,& - -0.13425E+00,-0.13223E+00,-0.13021E+00,-0.12818E+00,-0.12615E+00,& - -0.12410E+00,-0.12206E+00,-0.12000E+00,-0.11795E+00,-0.11588E+00,& - -0.11382E+00,-0.11175E+00,-0.10968E+00,-0.10760E+00,-0.10552E+00,& - -0.10344E+00,-0.10135E+00,-0.99254E-01,-0.97155E-01,-0.95051E-01,& - -0.92942E-01,-0.90825E-01,-0.88702E-01,-0.86572E-01,-0.84433E-01,& - -0.82285E-01,-0.80128E-01,-0.77962E-01,-0.75784E-01,-0.73596E-01,& - -0.71395E-01,-0.69182E-01,-0.66957E-01,-0.64717E-01,-0.62464E-01,& - -0.60196E-01,-0.57913E-01,-0.55615E-01,-0.53301E-01,-0.50971E-01,& - -0.48625E-01,-0.46262E-01,-0.43883E-01,-0.41487E-01,-0.39075E-01,& - -0.36646E-01,-0.34200E-01,-0.31738E-01,-0.29259E-01,-0.26764E-01,& - -0.24254E-01,-0.21728E-01,-0.19186E-01,-0.16630E-01,-0.14060E-01/ - - DATA (BNC10M (IA),IA=101,200)/ & - -0.11475E-01,-0.88771E-02,-0.62662E-02,-0.36428E-02,-0.10075E-02,& - 0.16391E-02, 0.42964E-02, 0.69640E-02, 0.96412E-02, 0.12327E-01,& - 0.15022E-01, 0.17725E-01, 0.20434E-01, 0.23151E-01, 0.25874E-01,& - 0.28602E-01, 0.31336E-01, 0.34074E-01, 0.36816E-01, 0.39562E-01,& - 0.41991E-01, 0.44780E-01, 0.47568E-01, 0.50354E-01, 0.53138E-01,& - 0.55921E-01, 0.58702E-01, 0.61482E-01, 0.64259E-01, 0.67035E-01,& - 0.69808E-01, 0.72580E-01, 0.75349E-01, 0.78117E-01, 0.80882E-01,& - 0.83644E-01, 0.86404E-01, 0.89162E-01, 0.91917E-01, 0.94670E-01,& - 0.97420E-01, 0.10017E+00, 0.10291E+00, 0.10565E+00, 0.10839E+00,& - 0.11113E+00, 0.11386E+00, 0.11659E+00, 0.11932E+00, 0.12205E+00,& - 0.12477E+00, 0.12749E+00, 0.13020E+00, 0.13291E+00, 0.13562E+00,& - 0.13833E+00, 0.14103E+00, 0.14373E+00, 0.14643E+00, 0.14912E+00,& - 0.15181E+00, 0.15449E+00, 0.15718E+00, 0.15985E+00, 0.16253E+00,& - 0.16520E+00, 0.16787E+00, 0.17053E+00, 0.17320E+00, 0.17585E+00,& - 0.17851E+00, 0.18116E+00, 0.18380E+00, 0.18645E+00, 0.18909E+00,& - 0.19172E+00, 0.19435E+00, 0.19698E+00, 0.19961E+00, 0.20223E+00,& - 0.20484E+00, 0.20745E+00, 0.21006E+00, 0.21267E+00, 0.21527E+00,& - 0.21787E+00, 0.22046E+00, 0.22305E+00, 0.22564E+00, 0.22822E+00,& - 0.23079E+00, 0.23337E+00, 0.23594E+00, 0.23850E+00, 0.24107E+00,& - 0.24362E+00, 0.24618E+00, 0.24873E+00, 0.25127E+00, 0.25382E+00/ - - DATA (BNC10M (IA),IA=201,300)/ & - 0.25635E+00, 0.25889E+00, 0.26142E+00, 0.26394E+00, 0.26647E+00,& - 0.26898E+00, 0.27150E+00, 0.27401E+00, 0.27651E+00, 0.27901E+00,& - 0.28151E+00, 0.28401E+00, 0.28649E+00, 0.28898E+00, 0.29146E+00,& - 0.29394E+00, 0.29641E+00, 0.29888E+00, 0.30135E+00, 0.30381E+00,& - 0.30626E+00, 0.30872E+00, 0.31117E+00, 0.31361E+00, 0.31605E+00,& - 0.31849E+00, 0.32092E+00, 0.32335E+00, 0.32577E+00, 0.32819E+00,& - 0.33061E+00, 0.33302E+00, 0.33543E+00, 0.33783E+00, 0.34023E+00,& - 0.34263E+00, 0.34502E+00, 0.34741E+00, 0.34979E+00, 0.35217E+00,& - 0.35455E+00, 0.35692E+00, 0.35929E+00, 0.36165E+00, 0.36401E+00,& - 0.36637E+00, 0.36872E+00, 0.37107E+00, 0.37341E+00, 0.37575E+00,& - 0.37808E+00, 0.38041E+00, 0.38274E+00, 0.38507E+00, 0.38738E+00,& - 0.38970E+00, 0.39201E+00, 0.39432E+00, 0.39662E+00, 0.39892E+00,& - 0.40122E+00, 0.40351E+00, 0.40580E+00, 0.40808E+00, 0.41036E+00,& - 0.41264E+00, 0.41491E+00, 0.41718E+00, 0.41944E+00, 0.42170E+00,& - 0.42396E+00, 0.42621E+00, 0.42846E+00, 0.43070E+00, 0.43294E+00,& - 0.43518E+00, 0.43741E+00, 0.43964E+00, 0.44186E+00, 0.44409E+00,& - 0.44630E+00, 0.44852E+00, 0.45073E+00, 0.45293E+00, 0.45513E+00,& - 0.45733E+00, 0.45953E+00, 0.46172E+00, 0.46390E+00, 0.46609E+00,& - 0.46827E+00, 0.47044E+00, 0.47261E+00, 0.47478E+00, 0.47695E+00,& - 0.47911E+00, 0.48126E+00, 0.48342E+00, 0.48556E+00, 0.48771E+00/ - - DATA (BNC10M (IA),IA=301,400)/ & - 0.48985E+00, 0.49199E+00, 0.49412E+00, 0.49625E+00, 0.49838E+00,& - 0.50050E+00, 0.50262E+00, 0.50474E+00, 0.50685E+00, 0.50896E+00,& - 0.51107E+00, 0.51317E+00, 0.51526E+00, 0.51736E+00, 0.51945E+00,& - 0.52154E+00, 0.52362E+00, 0.52570E+00, 0.52778E+00, 0.52985E+00,& - 0.53192E+00, 0.53398E+00, 0.53604E+00, 0.53810E+00, 0.54016E+00,& - 0.54221E+00, 0.54426E+00, 0.54630E+00, 0.54834E+00, 0.55038E+00,& - 0.55241E+00, 0.55444E+00, 0.55647E+00, 0.55849E+00, 0.56051E+00,& - 0.56253E+00, 0.56454E+00, 0.56655E+00, 0.56856E+00, 0.57056E+00,& - 0.57256E+00, 0.57455E+00, 0.57654E+00, 0.57853E+00, 0.58052E+00,& - 0.58250E+00, 0.58448E+00, 0.58645E+00, 0.58843E+00, 0.59040E+00,& - 0.59236E+00, 0.59432E+00, 0.59628E+00, 0.59824E+00, 0.60019E+00,& - 0.60214E+00, 0.60408E+00, 0.60602E+00, 0.60796E+00, 0.60990E+00,& - 0.61183E+00, 0.61376E+00, 0.61569E+00, 0.61761E+00, 0.61953E+00,& - 0.62144E+00, 0.62336E+00, 0.62527E+00, 0.62717E+00, 0.62907E+00,& - 0.63097E+00, 0.63287E+00, 0.63476E+00, 0.63666E+00, 0.63854E+00,& - 0.64043E+00, 0.64231E+00, 0.64418E+00, 0.64606E+00, 0.64793E+00,& - 0.64980E+00, 0.65166E+00, 0.65353E+00, 0.65539E+00, 0.65724E+00,& - 0.65909E+00, 0.66094E+00, 0.66279E+00, 0.66463E+00, 0.66647E+00,& - 0.66831E+00, 0.67015E+00, 0.67198E+00, 0.67381E+00, 0.67563E+00,& - 0.67745E+00, 0.67927E+00, 0.68109E+00, 0.68290E+00, 0.68471E+00/ - - DATA (BNC10M (IA),IA=401,500)/ & - 0.68652E+00, 0.68832E+00, 0.69013E+00, 0.69192E+00, 0.69372E+00,& - 0.69551E+00, 0.69730E+00, 0.69909E+00, 0.70087E+00, 0.70265E+00,& - 0.70443E+00, 0.70621E+00, 0.70798E+00, 0.70975E+00, 0.71151E+00,& - 0.71328E+00, 0.71504E+00, 0.71680E+00, 0.71855E+00, 0.72030E+00,& - 0.72205E+00, 0.72380E+00, 0.72554E+00, 0.72728E+00, 0.72902E+00,& - 0.73075E+00, 0.73249E+00, 0.73422E+00, 0.73594E+00, 0.73767E+00,& - 0.73939E+00, 0.74111E+00, 0.74282E+00, 0.74453E+00, 0.74624E+00,& - 0.74795E+00, 0.74966E+00, 0.75136E+00, 0.75306E+00, 0.75475E+00,& - 0.75645E+00, 0.75814E+00, 0.75983E+00, 0.76151E+00, 0.76319E+00,& - 0.76487E+00, 0.76655E+00, 0.76823E+00, 0.76990E+00, 0.77157E+00,& - 0.77324E+00, 0.77490E+00, 0.77656E+00, 0.77822E+00, 0.77988E+00,& - 0.78153E+00, 0.78318E+00, 0.78483E+00, 0.78648E+00, 0.78812E+00,& - 0.78976E+00, 0.79140E+00, 0.79303E+00, 0.79467E+00, 0.79630E+00,& - 0.79792E+00, 0.79955E+00, 0.80117E+00, 0.80279E+00, 0.80441E+00,& - 0.80603E+00, 0.80764E+00, 0.80925E+00, 0.81086E+00, 0.81246E+00,& - 0.81406E+00, 0.81566E+00, 0.81726E+00, 0.81886E+00, 0.82045E+00,& - 0.82204E+00, 0.82363E+00, 0.82521E+00, 0.82679E+00, 0.82837E+00,& - 0.82995E+00, 0.83153E+00, 0.83310E+00, 0.83467E+00, 0.83624E+00,& - 0.83781E+00, 0.83937E+00, 0.84093E+00, 0.84249E+00, 0.84405E+00,& - 0.84560E+00, 0.84715E+00, 0.84870E+00, 0.85025E+00, 0.85179E+00/ - - DATA (BNC10M (IA),IA=501,600)/ & - 0.85333E+00, 0.85487E+00, 0.85641E+00, 0.85794E+00, 0.85948E+00,& - 0.86101E+00, 0.86254E+00, 0.86406E+00, 0.86558E+00, 0.86711E+00,& - 0.86862E+00, 0.87014E+00, 0.87165E+00, 0.87317E+00, 0.87468E+00,& - 0.87618E+00, 0.87769E+00, 0.87919E+00, 0.88069E+00, 0.88219E+00,& - 0.88369E+00, 0.88518E+00, 0.88667E+00, 0.88816E+00, 0.88965E+00,& - 0.89113E+00, 0.89261E+00, 0.89409E+00, 0.89557E+00, 0.89705E+00,& - 0.89852E+00, 0.89999E+00, 0.90146E+00, 0.90293E+00, 0.90439E+00,& - 0.90586E+00, 0.90732E+00, 0.90878E+00, 0.91023E+00, 0.91169E+00,& - 0.91314E+00, 0.91459E+00, 0.91604E+00, 0.91748E+00, 0.91893E+00,& - 0.92037E+00, 0.92181E+00, 0.92324E+00, 0.92468E+00, 0.92611E+00,& - 0.92754E+00, 0.92897E+00, 0.93040E+00, 0.93182E+00, 0.93324E+00,& - 0.93466E+00, 0.93608E+00, 0.93750E+00, 0.93891E+00, 0.94032E+00,& - 0.94173E+00, 0.94314E+00, 0.94455E+00, 0.94595E+00, 0.94735E+00,& - 0.94875E+00, 0.95015E+00, 0.95155E+00, 0.95294E+00, 0.95433E+00,& - 0.95572E+00, 0.95711E+00, 0.95850E+00, 0.95988E+00, 0.96126E+00,& - 0.96264E+00, 0.96402E+00, 0.96539E+00, 0.96677E+00, 0.96814E+00,& - 0.96951E+00, 0.97088E+00, 0.97224E+00, 0.97361E+00, 0.97497E+00,& - 0.97633E+00, 0.97769E+00, 0.97904E+00, 0.98040E+00, 0.98175E+00,& - 0.98310E+00, 0.98445E+00, 0.98580E+00, 0.98714E+00, 0.98848E+00,& - 0.98982E+00, 0.99116E+00, 0.99250E+00, 0.99383E+00, 0.99882E+00/ - - DATA (BNC10M (IA),IA=601,700)/ & - 0.10097E+01, 0.10227E+01, 0.10356E+01, 0.10483E+01, 0.10608E+01,& - 0.10731E+01, 0.10852E+01, 0.10972E+01, 0.11091E+01, 0.11208E+01,& - 0.11323E+01, 0.11437E+01, 0.11549E+01, 0.11660E+01, 0.11770E+01,& - 0.11878E+01, 0.11985E+01, 0.12090E+01, 0.12195E+01, 0.12298E+01,& - 0.12399E+01, 0.12500E+01, 0.12599E+01, 0.12697E+01, 0.12794E+01,& - 0.12889E+01, 0.12984E+01, 0.13077E+01, 0.13170E+01, 0.13261E+01,& - 0.13351E+01, 0.13441E+01, 0.13529E+01, 0.13616E+01, 0.13702E+01,& - 0.13788E+01, 0.13872E+01, 0.13955E+01, 0.14038E+01, 0.14119E+01,& - 0.14200E+01, 0.14280E+01, 0.14359E+01, 0.14437E+01, 0.14514E+01,& - 0.14590E+01, 0.14666E+01, 0.14741E+01, 0.14815E+01, 0.14888E+01,& - 0.14961E+01, 0.15032E+01, 0.15103E+01, 0.15174E+01, 0.15243E+01,& - 0.15312E+01, 0.15380E+01, 0.15448E+01, 0.15515E+01, 0.15581E+01,& - 0.15646E+01, 0.15711E+01, 0.15775E+01, 0.15839E+01, 0.15901E+01,& - 0.15964E+01, 0.16025E+01, 0.16086E+01, 0.16147E+01, 0.16207E+01,& - 0.16266E+01, 0.16325E+01, 0.16383E+01, 0.16441E+01, 0.16498E+01,& - 0.16554E+01, 0.16610E+01, 0.16666E+01, 0.16721E+01, 0.16775E+01,& - 0.16829E+01, 0.16882E+01, 0.16935E+01, 0.16988E+01, 0.17040E+01,& - 0.17091E+01, 0.17142E+01, 0.17193E+01, 0.17243E+01, 0.17292E+01,& - 0.17342E+01, 0.17390E+01, 0.17439E+01, 0.17486E+01, 0.17534E+01,& - 0.17581E+01, 0.17627E+01, 0.17674E+01, 0.17719E+01, 0.17765E+01/ - - DATA (BNC10M(IA),IA=701,741)/ & - 0.17810E+01, 0.17854E+01, 0.17898E+01, 0.17942E+01, 0.17985E+01,& - 0.18028E+01, 0.18071E+01, 0.18113E+01, 0.18155E+01, 0.18196E+01,& - 0.18238E+01, 0.18278E+01, 0.18319E+01, 0.18359E+01, 0.18399E+01,& - 0.18438E+01, 0.18477E+01, 0.18516E+01, 0.18554E+01, 0.18592E+01,& - 0.18630E+01, 0.18667E+01, 0.18704E+01, 0.18741E+01, 0.18777E+01,& - 0.18814E+01, 0.18849E+01, 0.18885E+01, 0.18920E+01, 0.18955E+01,& - 0.18990E+01, 0.19024E+01, 0.19058E+01, 0.19092E+01, 0.19125E+01,& - 0.19158E+01, 0.19191E+01, 0.19224E+01, 0.19256E+01, 0.19288E+01,& - 0.19320E+01 / -! -! ** (H, Cl) -! - DATA (BNC11M (IA),IA= 1,100)/ & - -0.50531E-01,-0.86008E-01,-0.10676E+00,-0.11831E+00,-0.12545E+00,& - -0.12992E+00,-0.13259E+00,-0.13394E+00,-0.13429E+00,-0.13382E+00,& - -0.13270E+00,-0.13103E+00,-0.12888E+00,-0.12633E+00,-0.12342E+00,& - -0.12019E+00,-0.11668E+00,-0.11291E+00,-0.10891E+00,-0.10470E+00,& - -0.10030E+00,-0.95726E-01,-0.90985E-01,-0.86094E-01,-0.81063E-01,& - -0.75902E-01,-0.70620E-01,-0.65226E-01,-0.59728E-01,-0.54132E-01,& - -0.48445E-01,-0.42673E-01,-0.36822E-01,-0.30897E-01,-0.24903E-01,& - -0.18845E-01,-0.12727E-01,-0.65528E-02,-0.32679E-03, 0.59476E-02,& - 0.12267E-01, 0.18628E-01, 0.25028E-01, 0.31464E-01, 0.37933E-01,& - 0.44433E-01, 0.50963E-01, 0.57519E-01, 0.64099E-01, 0.70704E-01,& - 0.77329E-01, 0.83976E-01, 0.90641E-01, 0.97325E-01, 0.10403E+00,& - 0.11074E+00, 0.11748E+00, 0.12423E+00, 0.13099E+00, 0.13777E+00,& - 0.14457E+00, 0.15138E+00, 0.15821E+00, 0.16505E+00, 0.17191E+00,& - 0.17879E+00, 0.18569E+00, 0.19260E+00, 0.19954E+00, 0.20650E+00,& - 0.21347E+00, 0.22048E+00, 0.22750E+00, 0.23455E+00, 0.24163E+00,& - 0.24873E+00, 0.25587E+00, 0.26303E+00, 0.27022E+00, 0.27745E+00,& - 0.28470E+00, 0.29200E+00, 0.29932E+00, 0.30668E+00, 0.31407E+00,& - 0.32150E+00, 0.32897E+00, 0.33647E+00, 0.34402E+00, 0.35159E+00,& - 0.35921E+00, 0.36686E+00, 0.37454E+00, 0.38226E+00, 0.39002E+00,& - 0.39781E+00, 0.40564E+00, 0.41349E+00, 0.42138E+00, 0.42931E+00/ - - DATA (BNC11M (IA),IA=101,200)/ & - 0.43726E+00, 0.44524E+00, 0.45324E+00, 0.46128E+00, 0.46933E+00,& - 0.47741E+00, 0.48552E+00, 0.49364E+00, 0.50178E+00, 0.50994E+00,& - 0.51812E+00, 0.52631E+00, 0.53452E+00, 0.54273E+00, 0.55096E+00,& - 0.55920E+00, 0.56744E+00, 0.57570E+00, 0.58395E+00, 0.59221E+00,& - 0.59974E+00, 0.60809E+00, 0.61644E+00, 0.62477E+00, 0.63310E+00,& - 0.64142E+00, 0.64973E+00, 0.65803E+00, 0.66632E+00, 0.67461E+00,& - 0.68288E+00, 0.69114E+00, 0.69939E+00, 0.70764E+00, 0.71587E+00,& - 0.72409E+00, 0.73230E+00, 0.74050E+00, 0.74869E+00, 0.75686E+00,& - 0.76502E+00, 0.77318E+00, 0.78132E+00, 0.78944E+00, 0.79756E+00,& - 0.80566E+00, 0.81375E+00, 0.82183E+00, 0.82990E+00, 0.83795E+00,& - 0.84599E+00, 0.85401E+00, 0.86202E+00, 0.87002E+00, 0.87801E+00,& - 0.88598E+00, 0.89394E+00, 0.90188E+00, 0.90981E+00, 0.91773E+00,& - 0.92563E+00, 0.93352E+00, 0.94139E+00, 0.94925E+00, 0.95710E+00,& - 0.96493E+00, 0.97275E+00, 0.98055E+00, 0.98834E+00, 0.99611E+00,& - 0.10039E+01, 0.10116E+01, 0.10193E+01, 0.10271E+01, 0.10348E+01,& - 0.10424E+01, 0.10501E+01, 0.10578E+01, 0.10654E+01, 0.10730E+01,& - 0.10807E+01, 0.10883E+01, 0.10958E+01, 0.11034E+01, 0.11110E+01,& - 0.11185E+01, 0.11260E+01, 0.11335E+01, 0.11410E+01, 0.11485E+01,& - 0.11560E+01, 0.11634E+01, 0.11708E+01, 0.11782E+01, 0.11857E+01,& - 0.11930E+01, 0.12004E+01, 0.12078E+01, 0.12151E+01, 0.12224E+01/ - - DATA (BNC11M (IA),IA=201,300)/ & - 0.12298E+01, 0.12370E+01, 0.12443E+01, 0.12516E+01, 0.12589E+01,& - 0.12661E+01, 0.12733E+01, 0.12805E+01, 0.12877E+01, 0.12949E+01,& - 0.13021E+01, 0.13092E+01, 0.13163E+01, 0.13235E+01, 0.13306E+01,& - 0.13377E+01, 0.13447E+01, 0.13518E+01, 0.13588E+01, 0.13659E+01,& - 0.13729E+01, 0.13799E+01, 0.13869E+01, 0.13939E+01, 0.14008E+01,& - 0.14078E+01, 0.14147E+01, 0.14216E+01, 0.14285E+01, 0.14354E+01,& - 0.14423E+01, 0.14491E+01, 0.14560E+01, 0.14628E+01, 0.14696E+01,& - 0.14764E+01, 0.14832E+01, 0.14900E+01, 0.14968E+01, 0.15035E+01,& - 0.15103E+01, 0.15170E+01, 0.15237E+01, 0.15304E+01, 0.15370E+01,& - 0.15437E+01, 0.15504E+01, 0.15570E+01, 0.15636E+01, 0.15702E+01,& - 0.15768E+01, 0.15834E+01, 0.15900E+01, 0.15965E+01, 0.16031E+01,& - 0.16096E+01, 0.16161E+01, 0.16226E+01, 0.16291E+01, 0.16356E+01,& - 0.16421E+01, 0.16485E+01, 0.16549E+01, 0.16614E+01, 0.16678E+01,& - 0.16742E+01, 0.16806E+01, 0.16869E+01, 0.16933E+01, 0.16996E+01,& - 0.17060E+01, 0.17123E+01, 0.17186E+01, 0.17249E+01, 0.17312E+01,& - 0.17374E+01, 0.17437E+01, 0.17499E+01, 0.17562E+01, 0.17624E+01,& - 0.17686E+01, 0.17748E+01, 0.17810E+01, 0.17872E+01, 0.17933E+01,& - 0.17995E+01, 0.18056E+01, 0.18117E+01, 0.18178E+01, 0.18239E+01,& - 0.18300E+01, 0.18361E+01, 0.18421E+01, 0.18482E+01, 0.18542E+01,& - 0.18602E+01, 0.18663E+01, 0.18723E+01, 0.18783E+01, 0.18842E+01/ - - DATA (BNC11M (IA),IA=301,400)/ & - 0.18902E+01, 0.18962E+01, 0.19021E+01, 0.19080E+01, 0.19139E+01,& - 0.19199E+01, 0.19258E+01, 0.19316E+01, 0.19375E+01, 0.19434E+01,& - 0.19492E+01, 0.19551E+01, 0.19609E+01, 0.19667E+01, 0.19725E+01,& - 0.19783E+01, 0.19841E+01, 0.19899E+01, 0.19956E+01, 0.20014E+01,& - 0.20071E+01, 0.20129E+01, 0.20186E+01, 0.20243E+01, 0.20300E+01,& - 0.20357E+01, 0.20413E+01, 0.20470E+01, 0.20527E+01, 0.20583E+01,& - 0.20639E+01, 0.20696E+01, 0.20752E+01, 0.20808E+01, 0.20864E+01,& - 0.20919E+01, 0.20975E+01, 0.21031E+01, 0.21086E+01, 0.21142E+01,& - 0.21197E+01, 0.21252E+01, 0.21307E+01, 0.21362E+01, 0.21417E+01,& - 0.21472E+01, 0.21526E+01, 0.21581E+01, 0.21635E+01, 0.21690E+01,& - 0.21744E+01, 0.21798E+01, 0.21852E+01, 0.21906E+01, 0.21960E+01,& - 0.22014E+01, 0.22068E+01, 0.22121E+01, 0.22175E+01, 0.22228E+01,& - 0.22281E+01, 0.22335E+01, 0.22388E+01, 0.22441E+01, 0.22494E+01,& - 0.22546E+01, 0.22599E+01, 0.22652E+01, 0.22704E+01, 0.22757E+01,& - 0.22809E+01, 0.22861E+01, 0.22913E+01, 0.22965E+01, 0.23017E+01,& - 0.23069E+01, 0.23121E+01, 0.23173E+01, 0.23224E+01, 0.23276E+01,& - 0.23327E+01, 0.23379E+01, 0.23430E+01, 0.23481E+01, 0.23532E+01,& - 0.23583E+01, 0.23634E+01, 0.23685E+01, 0.23735E+01, 0.23786E+01,& - 0.23837E+01, 0.23887E+01, 0.23937E+01, 0.23988E+01, 0.24038E+01,& - 0.24088E+01, 0.24138E+01, 0.24188E+01, 0.24238E+01, 0.24288E+01/ - - DATA (BNC11M (IA),IA=401,500)/ & - 0.24337E+01, 0.24387E+01, 0.24436E+01, 0.24486E+01, 0.24535E+01,& - 0.24584E+01, 0.24633E+01, 0.24682E+01, 0.24731E+01, 0.24780E+01,& - 0.24829E+01, 0.24878E+01, 0.24927E+01, 0.24975E+01, 0.25024E+01,& - 0.25072E+01, 0.25120E+01, 0.25169E+01, 0.25217E+01, 0.25265E+01,& - 0.25313E+01, 0.25361E+01, 0.25409E+01, 0.25457E+01, 0.25504E+01,& - 0.25552E+01, 0.25599E+01, 0.25647E+01, 0.25694E+01, 0.25742E+01,& - 0.25789E+01, 0.25836E+01, 0.25883E+01, 0.25930E+01, 0.25977E+01,& - 0.26024E+01, 0.26071E+01, 0.26117E+01, 0.26164E+01, 0.26210E+01,& - 0.26257E+01, 0.26303E+01, 0.26350E+01, 0.26396E+01, 0.26442E+01,& - 0.26488E+01, 0.26534E+01, 0.26580E+01, 0.26626E+01, 0.26672E+01,& - 0.26717E+01, 0.26763E+01, 0.26809E+01, 0.26854E+01, 0.26900E+01,& - 0.26945E+01, 0.26990E+01, 0.27035E+01, 0.27081E+01, 0.27126E+01,& - 0.27171E+01, 0.27216E+01, 0.27260E+01, 0.27305E+01, 0.27350E+01,& - 0.27395E+01, 0.27439E+01, 0.27484E+01, 0.27528E+01, 0.27572E+01,& - 0.27617E+01, 0.27661E+01, 0.27705E+01, 0.27749E+01, 0.27793E+01,& - 0.27837E+01, 0.27881E+01, 0.27925E+01, 0.27969E+01, 0.28012E+01,& - 0.28056E+01, 0.28099E+01, 0.28143E+01, 0.28186E+01, 0.28230E+01,& - 0.28273E+01, 0.28316E+01, 0.28359E+01, 0.28402E+01, 0.28445E+01,& - 0.28488E+01, 0.28531E+01, 0.28574E+01, 0.28617E+01, 0.28660E+01,& - 0.28702E+01, 0.28745E+01, 0.28787E+01, 0.28830E+01, 0.28872E+01/ - - DATA (BNC11M (IA),IA=501,600)/ & - 0.28914E+01, 0.28957E+01, 0.28999E+01, 0.29041E+01, 0.29083E+01,& - 0.29125E+01, 0.29167E+01, 0.29209E+01, 0.29251E+01, 0.29292E+01,& - 0.29334E+01, 0.29376E+01, 0.29417E+01, 0.29459E+01, 0.29500E+01,& - 0.29541E+01, 0.29583E+01, 0.29624E+01, 0.29665E+01, 0.29706E+01,& - 0.29747E+01, 0.29788E+01, 0.29829E+01, 0.29870E+01, 0.29911E+01,& - 0.29952E+01, 0.29993E+01, 0.30033E+01, 0.30074E+01, 0.30114E+01,& - 0.30155E+01, 0.30195E+01, 0.30236E+01, 0.30276E+01, 0.30316E+01,& - 0.30356E+01, 0.30396E+01, 0.30437E+01, 0.30477E+01, 0.30517E+01,& - 0.30556E+01, 0.30596E+01, 0.30636E+01, 0.30676E+01, 0.30715E+01,& - 0.30755E+01, 0.30795E+01, 0.30834E+01, 0.30874E+01, 0.30913E+01,& - 0.30952E+01, 0.30992E+01, 0.31031E+01, 0.31070E+01, 0.31109E+01,& - 0.31148E+01, 0.31187E+01, 0.31226E+01, 0.31265E+01, 0.31304E+01,& - 0.31343E+01, 0.31381E+01, 0.31420E+01, 0.31459E+01, 0.31497E+01,& - 0.31536E+01, 0.31574E+01, 0.31613E+01, 0.31651E+01, 0.31689E+01,& - 0.31727E+01, 0.31766E+01, 0.31804E+01, 0.31842E+01, 0.31880E+01,& - 0.31918E+01, 0.31956E+01, 0.31994E+01, 0.32032E+01, 0.32069E+01,& - 0.32107E+01, 0.32145E+01, 0.32182E+01, 0.32220E+01, 0.32257E+01,& - 0.32295E+01, 0.32332E+01, 0.32370E+01, 0.32407E+01, 0.32444E+01,& - 0.32482E+01, 0.32519E+01, 0.32556E+01, 0.32593E+01, 0.32630E+01,& - 0.32667E+01, 0.32704E+01, 0.32741E+01, 0.32778E+01, 0.32915E+01/ - - DATA (BNC11M (IA),IA=601,700)/ & - 0.33216E+01, 0.33575E+01, 0.33930E+01, 0.34281E+01, 0.34627E+01,& - 0.34969E+01, 0.35306E+01, 0.35640E+01, 0.35969E+01, 0.36294E+01,& - 0.36616E+01, 0.36933E+01, 0.37247E+01, 0.37557E+01, 0.37864E+01,& - 0.38167E+01, 0.38467E+01, 0.38764E+01, 0.39057E+01, 0.39347E+01,& - 0.39633E+01, 0.39917E+01, 0.40198E+01, 0.40475E+01, 0.40750E+01,& - 0.41022E+01, 0.41291E+01, 0.41558E+01, 0.41821E+01, 0.42082E+01,& - 0.42341E+01, 0.42596E+01, 0.42850E+01, 0.43100E+01, 0.43349E+01,& - 0.43595E+01, 0.43838E+01, 0.44080E+01, 0.44319E+01, 0.44556E+01,& - 0.44790E+01, 0.45023E+01, 0.45253E+01, 0.45481E+01, 0.45707E+01,& - 0.45932E+01, 0.46154E+01, 0.46374E+01, 0.46592E+01, 0.46809E+01,& - 0.47023E+01, 0.47236E+01, 0.47447E+01, 0.47656E+01, 0.47863E+01,& - 0.48069E+01, 0.48273E+01, 0.48475E+01, 0.48675E+01, 0.48874E+01,& - 0.49071E+01, 0.49267E+01, 0.49461E+01, 0.49654E+01, 0.49845E+01,& - 0.50034E+01, 0.50222E+01, 0.50409E+01, 0.50594E+01, 0.50778E+01,& - 0.50960E+01, 0.51141E+01, 0.51321E+01, 0.51499E+01, 0.51676E+01,& - 0.51851E+01, 0.52025E+01, 0.52198E+01, 0.52370E+01, 0.52541E+01,& - 0.52710E+01, 0.52878E+01, 0.53044E+01, 0.53210E+01, 0.53374E+01,& - 0.53538E+01, 0.53700E+01, 0.53861E+01, 0.54021E+01, 0.54179E+01,& - 0.54337E+01, 0.54494E+01, 0.54649E+01, 0.54804E+01, 0.54957E+01,& - 0.55109E+01, 0.55261E+01, 0.55411E+01, 0.55560E+01, 0.55709E+01/ - - DATA (BNC11M(IA),IA=701,741)/ & - 0.55856E+01, 0.56002E+01, 0.56148E+01, 0.56292E+01, 0.56436E+01,& - 0.56579E+01, 0.56720E+01, 0.56861E+01, 0.57001E+01, 0.57140E+01,& - 0.57278E+01, 0.57416E+01, 0.57552E+01, 0.57688E+01, 0.57822E+01,& - 0.57956E+01, 0.58089E+01, 0.58222E+01, 0.58353E+01, 0.58484E+01,& - 0.58614E+01, 0.58743E+01, 0.58871E+01, 0.58999E+01, 0.59126E+01,& - 0.59252E+01, 0.59377E+01, 0.59501E+01, 0.59625E+01, 0.59748E+01,& - 0.59871E+01, 0.59993E+01, 0.60114E+01, 0.60234E+01, 0.60353E+01,& - 0.60472E+01, 0.60591E+01, 0.60708E+01, 0.60825E+01, 0.60941E+01,& - 0.61057E+01 / -! -! ** NaHSO4 -! - DATA (BNC12M (IA),IA= 1,100)/ & - -0.51921E-01,-0.91127E-01,-0.11645E+00,-0.13236E+00,-0.14371E+00,& - -0.15232E+00,-0.15906E+00,-0.16443E+00,-0.16876E+00,-0.17225E+00,& - -0.17506E+00,-0.17730E+00,-0.17905E+00,-0.18038E+00,-0.18133E+00,& - -0.18195E+00,-0.18227E+00,-0.18232E+00,-0.18213E+00,-0.18171E+00,& - -0.18108E+00,-0.18026E+00,-0.17926E+00,-0.17809E+00,-0.17676E+00,& - -0.17528E+00,-0.17365E+00,-0.17190E+00,-0.17001E+00,-0.16801E+00,& - -0.16589E+00,-0.16366E+00,-0.16133E+00,-0.15889E+00,-0.15636E+00,& - -0.15374E+00,-0.15103E+00,-0.14824E+00,-0.14536E+00,-0.14241E+00,& - -0.13939E+00,-0.13629E+00,-0.13313E+00,-0.12990E+00,-0.12661E+00,& - -0.12326E+00,-0.11985E+00,-0.11638E+00,-0.11286E+00,-0.10930E+00,& - -0.10568E+00,-0.10201E+00,-0.98298E-01,-0.94541E-01,-0.90742E-01,& - -0.86901E-01,-0.83019E-01,-0.79099E-01,-0.75141E-01,-0.71146E-01,& - -0.67114E-01,-0.63048E-01,-0.58946E-01,-0.54810E-01,-0.50641E-01,& - -0.46438E-01,-0.42202E-01,-0.37933E-01,-0.33632E-01,-0.29299E-01,& - -0.24933E-01,-0.20535E-01,-0.16104E-01,-0.11641E-01,-0.71452E-02,& - -0.26167E-02, 0.19444E-02, 0.65385E-02, 0.11166E-01, 0.15826E-01,& - 0.20520E-01, 0.25246E-01, 0.30007E-01, 0.34800E-01, 0.39627E-01,& - 0.44487E-01, 0.49381E-01, 0.54307E-01, 0.59265E-01, 0.64256E-01,& - 0.69279E-01, 0.74333E-01, 0.79418E-01, 0.84533E-01, 0.89677E-01,& - 0.94851E-01, 0.10005E+00, 0.10528E+00, 0.11054E+00, 0.11582E+00/ - - DATA (BNC12M (IA),IA=101,200)/ & - 0.12112E+00, 0.12645E+00, 0.13180E+00, 0.13717E+00, 0.14256E+00,& - 0.14797E+00, 0.15339E+00, 0.15884E+00, 0.16429E+00, 0.16977E+00,& - 0.17525E+00, 0.18075E+00, 0.18625E+00, 0.19177E+00, 0.19729E+00,& - 0.20283E+00, 0.20836E+00, 0.21391E+00, 0.21946E+00, 0.22501E+00,& - 0.23004E+00, 0.23565E+00, 0.24126E+00, 0.24687E+00, 0.25246E+00,& - 0.25805E+00, 0.26364E+00, 0.26922E+00, 0.27479E+00, 0.28035E+00,& - 0.28591E+00, 0.29146E+00, 0.29700E+00, 0.30253E+00, 0.30806E+00,& - 0.31357E+00, 0.31908E+00, 0.32458E+00, 0.33007E+00, 0.33555E+00,& - 0.34103E+00, 0.34649E+00, 0.35194E+00, 0.35739E+00, 0.36282E+00,& - 0.36825E+00, 0.37367E+00, 0.37907E+00, 0.38447E+00, 0.38985E+00,& - 0.39523E+00, 0.40060E+00, 0.40595E+00, 0.41130E+00, 0.41663E+00,& - 0.42196E+00, 0.42727E+00, 0.43257E+00, 0.43787E+00, 0.44315E+00,& - 0.44842E+00, 0.45368E+00, 0.45893E+00, 0.46417E+00, 0.46940E+00,& - 0.47462E+00, 0.47982E+00, 0.48502E+00, 0.49021E+00, 0.49538E+00,& - 0.50054E+00, 0.50570E+00, 0.51084E+00, 0.51597E+00, 0.52109E+00,& - 0.52620E+00, 0.53130E+00, 0.53638E+00, 0.54146E+00, 0.54652E+00,& - 0.55158E+00, 0.55662E+00, 0.56165E+00, 0.56668E+00, 0.57169E+00,& - 0.57669E+00, 0.58168E+00, 0.58665E+00, 0.59162E+00, 0.59658E+00,& - 0.60152E+00, 0.60646E+00, 0.61138E+00, 0.61630E+00, 0.62120E+00,& - 0.62609E+00, 0.63097E+00, 0.63584E+00, 0.64070E+00, 0.64555E+00/ - - DATA (BNC12M (IA),IA=201,300)/ & - 0.65039E+00, 0.65522E+00, 0.66004E+00, 0.66484E+00, 0.66964E+00,& - 0.67443E+00, 0.67920E+00, 0.68397E+00, 0.68872E+00, 0.69347E+00,& - 0.69820E+00, 0.70293E+00, 0.70764E+00, 0.71234E+00, 0.71704E+00,& - 0.72172E+00, 0.72639E+00, 0.73105E+00, 0.73571E+00, 0.74035E+00,& - 0.74498E+00, 0.74960E+00, 0.75422E+00, 0.75882E+00, 0.76341E+00,& - 0.76799E+00, 0.77257E+00, 0.77713E+00, 0.78168E+00, 0.78623E+00,& - 0.79076E+00, 0.79528E+00, 0.79980E+00, 0.80430E+00, 0.80880E+00,& - 0.81328E+00, 0.81776E+00, 0.82223E+00, 0.82668E+00, 0.83113E+00,& - 0.83557E+00, 0.84000E+00, 0.84442E+00, 0.84883E+00, 0.85323E+00,& - 0.85762E+00, 0.86200E+00, 0.86638E+00, 0.87074E+00, 0.87509E+00,& - 0.87944E+00, 0.88378E+00, 0.88810E+00, 0.89242E+00, 0.89673E+00,& - 0.90103E+00, 0.90533E+00, 0.90961E+00, 0.91388E+00, 0.91815E+00,& - 0.92240E+00, 0.92665E+00, 0.93089E+00, 0.93512E+00, 0.93934E+00,& - 0.94356E+00, 0.94776E+00, 0.95196E+00, 0.95614E+00, 0.96032E+00,& - 0.96449E+00, 0.96865E+00, 0.97281E+00, 0.97695E+00, 0.98109E+00,& - 0.98522E+00, 0.98934E+00, 0.99345E+00, 0.99755E+00, 0.10016E+01,& - 0.10057E+01, 0.10098E+01, 0.10139E+01, 0.10179E+01, 0.10220E+01,& - 0.10260E+01, 0.10301E+01, 0.10341E+01, 0.10381E+01, 0.10422E+01,& - 0.10462E+01, 0.10502E+01, 0.10541E+01, 0.10581E+01, 0.10621E+01,& - 0.10661E+01, 0.10700E+01, 0.10740E+01, 0.10779E+01, 0.10819E+01/ - - DATA (BNC12M (IA),IA=301,400)/ & - 0.10858E+01, 0.10897E+01, 0.10936E+01, 0.10975E+01, 0.11014E+01,& - 0.11053E+01, 0.11092E+01, 0.11131E+01, 0.11170E+01, 0.11208E+01,& - 0.11247E+01, 0.11285E+01, 0.11324E+01, 0.11362E+01, 0.11400E+01,& - 0.11438E+01, 0.11476E+01, 0.11514E+01, 0.11552E+01, 0.11590E+01,& - 0.11628E+01, 0.11666E+01, 0.11703E+01, 0.11741E+01, 0.11779E+01,& - 0.11816E+01, 0.11853E+01, 0.11891E+01, 0.11928E+01, 0.11965E+01,& - 0.12002E+01, 0.12039E+01, 0.12076E+01, 0.12113E+01, 0.12150E+01,& - 0.12187E+01, 0.12224E+01, 0.12260E+01, 0.12297E+01, 0.12333E+01,& - 0.12370E+01, 0.12406E+01, 0.12442E+01, 0.12479E+01, 0.12515E+01,& - 0.12551E+01, 0.12587E+01, 0.12623E+01, 0.12659E+01, 0.12695E+01,& - 0.12730E+01, 0.12766E+01, 0.12802E+01, 0.12837E+01, 0.12873E+01,& - 0.12908E+01, 0.12944E+01, 0.12979E+01, 0.13014E+01, 0.13050E+01,& - 0.13085E+01, 0.13120E+01, 0.13155E+01, 0.13190E+01, 0.13225E+01,& - 0.13259E+01, 0.13294E+01, 0.13329E+01, 0.13364E+01, 0.13398E+01,& - 0.13433E+01, 0.13467E+01, 0.13502E+01, 0.13536E+01, 0.13570E+01,& - 0.13604E+01, 0.13639E+01, 0.13673E+01, 0.13707E+01, 0.13741E+01,& - 0.13775E+01, 0.13809E+01, 0.13842E+01, 0.13876E+01, 0.13910E+01,& - 0.13943E+01, 0.13977E+01, 0.14011E+01, 0.14044E+01, 0.14077E+01,& - 0.14111E+01, 0.14144E+01, 0.14177E+01, 0.14210E+01, 0.14244E+01,& - 0.14277E+01, 0.14310E+01, 0.14343E+01, 0.14376E+01, 0.14408E+01/ - - DATA (BNC12M (IA),IA=401,500)/ & - 0.14441E+01, 0.14474E+01, 0.14507E+01, 0.14539E+01, 0.14572E+01,& - 0.14604E+01, 0.14637E+01, 0.14669E+01, 0.14701E+01, 0.14734E+01,& - 0.14766E+01, 0.14798E+01, 0.14830E+01, 0.14862E+01, 0.14894E+01,& - 0.14926E+01, 0.14958E+01, 0.14990E+01, 0.15022E+01, 0.15054E+01,& - 0.15086E+01, 0.15117E+01, 0.15149E+01, 0.15180E+01, 0.15212E+01,& - 0.15243E+01, 0.15275E+01, 0.15306E+01, 0.15337E+01, 0.15369E+01,& - 0.15400E+01, 0.15431E+01, 0.15462E+01, 0.15493E+01, 0.15524E+01,& - 0.15555E+01, 0.15586E+01, 0.15617E+01, 0.15648E+01, 0.15678E+01,& - 0.15709E+01, 0.15740E+01, 0.15770E+01, 0.15801E+01, 0.15831E+01,& - 0.15862E+01, 0.15892E+01, 0.15923E+01, 0.15953E+01, 0.15983E+01,& - 0.16014E+01, 0.16044E+01, 0.16074E+01, 0.16104E+01, 0.16134E+01,& - 0.16164E+01, 0.16194E+01, 0.16224E+01, 0.16254E+01, 0.16283E+01,& - 0.16313E+01, 0.16343E+01, 0.16372E+01, 0.16402E+01, 0.16432E+01,& - 0.16461E+01, 0.16491E+01, 0.16520E+01, 0.16549E+01, 0.16579E+01,& - 0.16608E+01, 0.16637E+01, 0.16666E+01, 0.16696E+01, 0.16725E+01,& - 0.16754E+01, 0.16783E+01, 0.16812E+01, 0.16841E+01, 0.16870E+01,& - 0.16898E+01, 0.16927E+01, 0.16956E+01, 0.16985E+01, 0.17013E+01,& - 0.17042E+01, 0.17071E+01, 0.17099E+01, 0.17128E+01, 0.17156E+01,& - 0.17185E+01, 0.17213E+01, 0.17241E+01, 0.17269E+01, 0.17298E+01,& - 0.17326E+01, 0.17354E+01, 0.17382E+01, 0.17410E+01, 0.17438E+01/ - - DATA (BNC12M (IA),IA=501,600)/ & - 0.17466E+01, 0.17494E+01, 0.17522E+01, 0.17550E+01, 0.17578E+01,& - 0.17606E+01, 0.17633E+01, 0.17661E+01, 0.17689E+01, 0.17716E+01,& - 0.17744E+01, 0.17771E+01, 0.17799E+01, 0.17826E+01, 0.17854E+01,& - 0.17881E+01, 0.17908E+01, 0.17936E+01, 0.17963E+01, 0.17990E+01,& - 0.18017E+01, 0.18044E+01, 0.18072E+01, 0.18099E+01, 0.18126E+01,& - 0.18153E+01, 0.18180E+01, 0.18206E+01, 0.18233E+01, 0.18260E+01,& - 0.18287E+01, 0.18314E+01, 0.18340E+01, 0.18367E+01, 0.18394E+01,& - 0.18420E+01, 0.18447E+01, 0.18473E+01, 0.18500E+01, 0.18526E+01,& - 0.18553E+01, 0.18579E+01, 0.18605E+01, 0.18632E+01, 0.18658E+01,& - 0.18684E+01, 0.18710E+01, 0.18736E+01, 0.18763E+01, 0.18789E+01,& - 0.18815E+01, 0.18841E+01, 0.18867E+01, 0.18892E+01, 0.18918E+01,& - 0.18944E+01, 0.18970E+01, 0.18996E+01, 0.19022E+01, 0.19047E+01,& - 0.19073E+01, 0.19099E+01, 0.19124E+01, 0.19150E+01, 0.19175E+01,& - 0.19201E+01, 0.19226E+01, 0.19252E+01, 0.19277E+01, 0.19302E+01,& - 0.19328E+01, 0.19353E+01, 0.19378E+01, 0.19403E+01, 0.19428E+01,& - 0.19454E+01, 0.19479E+01, 0.19504E+01, 0.19529E+01, 0.19554E+01,& - 0.19579E+01, 0.19604E+01, 0.19629E+01, 0.19653E+01, 0.19678E+01,& - 0.19703E+01, 0.19728E+01, 0.19753E+01, 0.19777E+01, 0.19802E+01,& - 0.19827E+01, 0.19851E+01, 0.19876E+01, 0.19900E+01, 0.19925E+01,& - 0.19949E+01, 0.19974E+01, 0.19998E+01, 0.20022E+01, 0.20114E+01/ - - DATA (BNC12M (IA),IA=601,700)/ & - 0.20312E+01, 0.20550E+01, 0.20785E+01, 0.21017E+01, 0.21246E+01,& - 0.21472E+01, 0.21695E+01, 0.21916E+01, 0.22134E+01, 0.22349E+01,& - 0.22561E+01, 0.22771E+01, 0.22978E+01, 0.23183E+01, 0.23386E+01,& - 0.23586E+01, 0.23784E+01, 0.23980E+01, 0.24173E+01, 0.24364E+01,& - 0.24553E+01, 0.24740E+01, 0.24925E+01, 0.25108E+01, 0.25289E+01,& - 0.25468E+01, 0.25646E+01, 0.25821E+01, 0.25994E+01, 0.26166E+01,& - 0.26336E+01, 0.26504E+01, 0.26670E+01, 0.26835E+01, 0.26998E+01,& - 0.27160E+01, 0.27320E+01, 0.27478E+01, 0.27635E+01, 0.27790E+01,& - 0.27943E+01, 0.28096E+01, 0.28247E+01, 0.28396E+01, 0.28544E+01,& - 0.28690E+01, 0.28836E+01, 0.28980E+01, 0.29122E+01, 0.29263E+01,& - 0.29403E+01, 0.29542E+01, 0.29680E+01, 0.29816E+01, 0.29951E+01,& - 0.30085E+01, 0.30217E+01, 0.30349E+01, 0.30479E+01, 0.30609E+01,& - 0.30737E+01, 0.30864E+01, 0.30990E+01, 0.31115E+01, 0.31239E+01,& - 0.31362E+01, 0.31483E+01, 0.31604E+01, 0.31724E+01, 0.31843E+01,& - 0.31961E+01, 0.32078E+01, 0.32194E+01, 0.32309E+01, 0.32423E+01,& - 0.32536E+01, 0.32648E+01, 0.32760E+01, 0.32870E+01, 0.32980E+01,& - 0.33089E+01, 0.33197E+01, 0.33304E+01, 0.33411E+01, 0.33516E+01,& - 0.33621E+01, 0.33725E+01, 0.33828E+01, 0.33931E+01, 0.34032E+01,& - 0.34133E+01, 0.34233E+01, 0.34333E+01, 0.34431E+01, 0.34529E+01,& - 0.34627E+01, 0.34723E+01, 0.34819E+01, 0.34914E+01, 0.35009E+01/ - - DATA (BNC12M(IA),IA=701,741)/ & - 0.35103E+01, 0.35196E+01, 0.35288E+01, 0.35380E+01, 0.35471E+01,& - 0.35562E+01, 0.35652E+01, 0.35741E+01, 0.35830E+01, 0.35918E+01,& - 0.36005E+01, 0.36092E+01, 0.36178E+01, 0.36264E+01, 0.36349E+01,& - 0.36434E+01, 0.36518E+01, 0.36601E+01, 0.36684E+01, 0.36766E+01,& - 0.36848E+01, 0.36929E+01, 0.37010E+01, 0.37090E+01, 0.37169E+01,& - 0.37248E+01, 0.37327E+01, 0.37405E+01, 0.37483E+01, 0.37560E+01,& - 0.37636E+01, 0.37712E+01, 0.37788E+01, 0.37863E+01, 0.37938E+01,& - 0.38012E+01, 0.38085E+01, 0.38159E+01, 0.38231E+01, 0.38304E+01,& - 0.38376E+01 / -! -! ** (NH4)3H(SO4)2 -! - DATA (BNC13M (IA),IA= 1,100)/ & - -0.86312E-01,-0.15717E+00,-0.20713E+00,-0.24120E+00,-0.26753E+00,& - -0.28912E+00,-0.30750E+00,-0.32352E+00,-0.33773E+00,-0.35052E+00,& - -0.36214E+00,-0.37278E+00,-0.38261E+00,-0.39173E+00,-0.40023E+00,& - -0.40819E+00,-0.41567E+00,-0.42272E+00,-0.42938E+00,-0.43570E+00,& - -0.44169E+00,-0.44739E+00,-0.45282E+00,-0.45800E+00,-0.46295E+00,& - -0.46769E+00,-0.47222E+00,-0.47657E+00,-0.48073E+00,-0.48473E+00,& - -0.48858E+00,-0.49227E+00,-0.49582E+00,-0.49924E+00,-0.50253E+00,& - -0.50570E+00,-0.50875E+00,-0.51169E+00,-0.51453E+00,-0.51726E+00,& - -0.51990E+00,-0.52245E+00,-0.52490E+00,-0.52727E+00,-0.52956E+00,& - -0.53177E+00,-0.53391E+00,-0.53597E+00,-0.53796E+00,-0.53988E+00,& - -0.54174E+00,-0.54353E+00,-0.54527E+00,-0.54694E+00,-0.54856E+00,& - -0.55013E+00,-0.55164E+00,-0.55310E+00,-0.55451E+00,-0.55588E+00,& - -0.55720E+00,-0.55847E+00,-0.55970E+00,-0.56089E+00,-0.56204E+00,& - -0.56315E+00,-0.56422E+00,-0.56526E+00,-0.56625E+00,-0.56722E+00,& - -0.56815E+00,-0.56904E+00,-0.56991E+00,-0.57074E+00,-0.57154E+00,& - -0.57231E+00,-0.57305E+00,-0.57377E+00,-0.57445E+00,-0.57511E+00,& - -0.57574E+00,-0.57635E+00,-0.57693E+00,-0.57748E+00,-0.57802E+00,& - -0.57852E+00,-0.57900E+00,-0.57946E+00,-0.57990E+00,-0.58032E+00,& - -0.58071E+00,-0.58108E+00,-0.58143E+00,-0.58176E+00,-0.58208E+00,& - -0.58237E+00,-0.58264E+00,-0.58290E+00,-0.58314E+00,-0.58336E+00/ - - DATA (BNC13M (IA),IA=101,200)/ & - -0.58356E+00,-0.58375E+00,-0.58392E+00,-0.58408E+00,-0.58422E+00,& - -0.58435E+00,-0.58447E+00,-0.58457E+00,-0.58466E+00,-0.58473E+00,& - -0.58480E+00,-0.58485E+00,-0.58489E+00,-0.58492E+00,-0.58494E+00,& - -0.58495E+00,-0.58496E+00,-0.58495E+00,-0.58493E+00,-0.58491E+00,& - -0.58498E+00,-0.58493E+00,-0.58487E+00,-0.58481E+00,-0.58474E+00,& - -0.58467E+00,-0.58459E+00,-0.58450E+00,-0.58441E+00,-0.58432E+00,& - -0.58422E+00,-0.58412E+00,-0.58401E+00,-0.58390E+00,-0.58379E+00,& - -0.58367E+00,-0.58355E+00,-0.58342E+00,-0.58330E+00,-0.58316E+00,& - -0.58303E+00,-0.58289E+00,-0.58275E+00,-0.58261E+00,-0.58246E+00,& - -0.58232E+00,-0.58217E+00,-0.58201E+00,-0.58186E+00,-0.58170E+00,& - -0.58154E+00,-0.58138E+00,-0.58122E+00,-0.58106E+00,-0.58089E+00,& - -0.58072E+00,-0.58056E+00,-0.58039E+00,-0.58021E+00,-0.58004E+00,& - -0.57987E+00,-0.57969E+00,-0.57951E+00,-0.57934E+00,-0.57916E+00,& - -0.57898E+00,-0.57880E+00,-0.57862E+00,-0.57844E+00,-0.57825E+00,& - -0.57807E+00,-0.57789E+00,-0.57770E+00,-0.57752E+00,-0.57733E+00,& - -0.57715E+00,-0.57696E+00,-0.57677E+00,-0.57658E+00,-0.57640E+00,& - -0.57621E+00,-0.57602E+00,-0.57583E+00,-0.57564E+00,-0.57546E+00,& - -0.57527E+00,-0.57508E+00,-0.57489E+00,-0.57470E+00,-0.57451E+00,& - -0.57432E+00,-0.57413E+00,-0.57394E+00,-0.57375E+00,-0.57356E+00,& - -0.57338E+00,-0.57319E+00,-0.57300E+00,-0.57281E+00,-0.57262E+00/ - - DATA (BNC13M (IA),IA=201,300)/ & - -0.57243E+00,-0.57225E+00,-0.57206E+00,-0.57187E+00,-0.57168E+00,& - -0.57150E+00,-0.57131E+00,-0.57112E+00,-0.57094E+00,-0.57075E+00,& - -0.57057E+00,-0.57038E+00,-0.57020E+00,-0.57002E+00,-0.56983E+00,& - -0.56965E+00,-0.56947E+00,-0.56928E+00,-0.56910E+00,-0.56892E+00,& - -0.56874E+00,-0.56856E+00,-0.56838E+00,-0.56820E+00,-0.56802E+00,& - -0.56784E+00,-0.56766E+00,-0.56749E+00,-0.56731E+00,-0.56713E+00,& - -0.56696E+00,-0.56678E+00,-0.56661E+00,-0.56643E+00,-0.56626E+00,& - -0.56609E+00,-0.56591E+00,-0.56574E+00,-0.56557E+00,-0.56540E+00,& - -0.56523E+00,-0.56506E+00,-0.56489E+00,-0.56472E+00,-0.56456E+00,& - -0.56439E+00,-0.56422E+00,-0.56406E+00,-0.56389E+00,-0.56373E+00,& - -0.56356E+00,-0.56340E+00,-0.56324E+00,-0.56308E+00,-0.56292E+00,& - -0.56276E+00,-0.56260E+00,-0.56244E+00,-0.56228E+00,-0.56212E+00,& - -0.56196E+00,-0.56181E+00,-0.56165E+00,-0.56150E+00,-0.56134E+00,& - -0.56119E+00,-0.56103E+00,-0.56088E+00,-0.56073E+00,-0.56058E+00,& - -0.56043E+00,-0.56028E+00,-0.56013E+00,-0.55998E+00,-0.55983E+00,& - -0.55969E+00,-0.55954E+00,-0.55940E+00,-0.55925E+00,-0.55911E+00,& - -0.55896E+00,-0.55882E+00,-0.55868E+00,-0.55854E+00,-0.55840E+00,& - -0.55826E+00,-0.55812E+00,-0.55798E+00,-0.55784E+00,-0.55770E+00,& - -0.55757E+00,-0.55743E+00,-0.55730E+00,-0.55716E+00,-0.55703E+00,& - -0.55690E+00,-0.55676E+00,-0.55663E+00,-0.55650E+00,-0.55637E+00/ - - DATA (BNC13M (IA),IA=301,400)/ & - -0.55624E+00,-0.55611E+00,-0.55599E+00,-0.55586E+00,-0.55573E+00,& - -0.55561E+00,-0.55548E+00,-0.55536E+00,-0.55523E+00,-0.55511E+00,& - -0.55499E+00,-0.55487E+00,-0.55475E+00,-0.55463E+00,-0.55451E+00,& - -0.55439E+00,-0.55427E+00,-0.55415E+00,-0.55404E+00,-0.55392E+00,& - -0.55380E+00,-0.55369E+00,-0.55358E+00,-0.55346E+00,-0.55335E+00,& - -0.55324E+00,-0.55313E+00,-0.55302E+00,-0.55291E+00,-0.55280E+00,& - -0.55269E+00,-0.55258E+00,-0.55248E+00,-0.55237E+00,-0.55226E+00,& - -0.55216E+00,-0.55206E+00,-0.55195E+00,-0.55185E+00,-0.55175E+00,& - -0.55165E+00,-0.55155E+00,-0.55145E+00,-0.55135E+00,-0.55125E+00,& - -0.55115E+00,-0.55105E+00,-0.55096E+00,-0.55086E+00,-0.55077E+00,& - -0.55067E+00,-0.55058E+00,-0.55048E+00,-0.55039E+00,-0.55030E+00,& - -0.55021E+00,-0.55012E+00,-0.55003E+00,-0.54994E+00,-0.54985E+00,& - -0.54976E+00,-0.54968E+00,-0.54959E+00,-0.54951E+00,-0.54942E+00,& - -0.54934E+00,-0.54925E+00,-0.54917E+00,-0.54909E+00,-0.54900E+00,& - -0.54892E+00,-0.54884E+00,-0.54876E+00,-0.54868E+00,-0.54861E+00,& - -0.54853E+00,-0.54845E+00,-0.54838E+00,-0.54830E+00,-0.54822E+00,& - -0.54815E+00,-0.54808E+00,-0.54800E+00,-0.54793E+00,-0.54786E+00,& - -0.54779E+00,-0.54772E+00,-0.54765E+00,-0.54758E+00,-0.54751E+00,& - -0.54744E+00,-0.54737E+00,-0.54731E+00,-0.54724E+00,-0.54717E+00,& - -0.54711E+00,-0.54705E+00,-0.54698E+00,-0.54692E+00,-0.54686E+00/ - - DATA (BNC13M (IA),IA=401,500)/ & - -0.54679E+00,-0.54673E+00,-0.54667E+00,-0.54661E+00,-0.54655E+00,& - -0.54650E+00,-0.54644E+00,-0.54638E+00,-0.54632E+00,-0.54627E+00,& - -0.54621E+00,-0.54616E+00,-0.54610E+00,-0.54605E+00,-0.54600E+00,& - -0.54594E+00,-0.54589E+00,-0.54584E+00,-0.54579E+00,-0.54574E+00,& - -0.54569E+00,-0.54564E+00,-0.54559E+00,-0.54555E+00,-0.54550E+00,& - -0.54545E+00,-0.54541E+00,-0.54536E+00,-0.54532E+00,-0.54527E+00,& - -0.54523E+00,-0.54519E+00,-0.54515E+00,-0.54510E+00,-0.54506E+00,& - -0.54502E+00,-0.54498E+00,-0.54494E+00,-0.54491E+00,-0.54487E+00,& - -0.54483E+00,-0.54479E+00,-0.54476E+00,-0.54472E+00,-0.54469E+00,& - -0.54465E+00,-0.54462E+00,-0.54458E+00,-0.54455E+00,-0.54452E+00,& - -0.54449E+00,-0.54446E+00,-0.54443E+00,-0.54440E+00,-0.54437E+00,& - -0.54434E+00,-0.54431E+00,-0.54428E+00,-0.54426E+00,-0.54423E+00,& - -0.54420E+00,-0.54418E+00,-0.54415E+00,-0.54413E+00,-0.54411E+00,& - -0.54408E+00,-0.54406E+00,-0.54404E+00,-0.54402E+00,-0.54400E+00,& - -0.54397E+00,-0.54395E+00,-0.54394E+00,-0.54392E+00,-0.54390E+00,& - -0.54388E+00,-0.54386E+00,-0.54385E+00,-0.54383E+00,-0.54382E+00,& - -0.54380E+00,-0.54379E+00,-0.54377E+00,-0.54376E+00,-0.54375E+00,& - -0.54373E+00,-0.54372E+00,-0.54371E+00,-0.54370E+00,-0.54369E+00,& - -0.54368E+00,-0.54367E+00,-0.54366E+00,-0.54366E+00,-0.54365E+00,& - -0.54364E+00,-0.54364E+00,-0.54363E+00,-0.54362E+00,-0.54362E+00/ - - DATA (BNC13M (IA),IA=501,600)/ & - -0.54362E+00,-0.54361E+00,-0.54361E+00,-0.54361E+00,-0.54360E+00,& - -0.54360E+00,-0.54360E+00,-0.54360E+00,-0.54360E+00,-0.54360E+00,& - -0.54360E+00,-0.54360E+00,-0.54360E+00,-0.54361E+00,-0.54361E+00,& - -0.54361E+00,-0.54362E+00,-0.54362E+00,-0.54363E+00,-0.54363E+00,& - -0.54364E+00,-0.54365E+00,-0.54365E+00,-0.54366E+00,-0.54367E+00,& - -0.54368E+00,-0.54369E+00,-0.54369E+00,-0.54370E+00,-0.54371E+00,& - -0.54373E+00,-0.54374E+00,-0.54375E+00,-0.54376E+00,-0.54377E+00,& - -0.54379E+00,-0.54380E+00,-0.54382E+00,-0.54383E+00,-0.54385E+00,& - -0.54386E+00,-0.54388E+00,-0.54390E+00,-0.54391E+00,-0.54393E+00,& - -0.54395E+00,-0.54397E+00,-0.54399E+00,-0.54401E+00,-0.54403E+00,& - -0.54405E+00,-0.54407E+00,-0.54409E+00,-0.54411E+00,-0.54413E+00,& - -0.54416E+00,-0.54418E+00,-0.54420E+00,-0.54423E+00,-0.54425E+00,& - -0.54428E+00,-0.54430E+00,-0.54433E+00,-0.54436E+00,-0.54438E+00,& - -0.54441E+00,-0.54444E+00,-0.54447E+00,-0.54450E+00,-0.54453E+00,& - -0.54456E+00,-0.54459E+00,-0.54462E+00,-0.54465E+00,-0.54468E+00,& - -0.54471E+00,-0.54475E+00,-0.54478E+00,-0.54481E+00,-0.54485E+00,& - -0.54488E+00,-0.54492E+00,-0.54495E+00,-0.54499E+00,-0.54502E+00,& - -0.54506E+00,-0.54510E+00,-0.54513E+00,-0.54517E+00,-0.54521E+00,& - -0.54525E+00,-0.54529E+00,-0.54533E+00,-0.54537E+00,-0.54541E+00,& - -0.54545E+00,-0.54549E+00,-0.54553E+00,-0.54558E+00,-0.54574E+00/ - - DATA (BNC13M (IA),IA=601,700)/ & - -0.54612E+00,-0.54661E+00,-0.54715E+00,-0.54773E+00,-0.54835E+00,& - -0.54901E+00,-0.54971E+00,-0.55044E+00,-0.55121E+00,-0.55202E+00,& - -0.55286E+00,-0.55374E+00,-0.55466E+00,-0.55560E+00,-0.55658E+00,& - -0.55760E+00,-0.55864E+00,-0.55972E+00,-0.56083E+00,-0.56196E+00,& - -0.56313E+00,-0.56433E+00,-0.56556E+00,-0.56681E+00,-0.56809E+00,& - -0.56940E+00,-0.57074E+00,-0.57210E+00,-0.57349E+00,-0.57491E+00,& - -0.57635E+00,-0.57782E+00,-0.57931E+00,-0.58082E+00,-0.58236E+00,& - -0.58392E+00,-0.58551E+00,-0.58712E+00,-0.58875E+00,-0.59040E+00,& - -0.59207E+00,-0.59377E+00,-0.59549E+00,-0.59722E+00,-0.59898E+00,& - -0.60076E+00,-0.60256E+00,-0.60438E+00,-0.60621E+00,-0.60807E+00,& - -0.60994E+00,-0.61183E+00,-0.61375E+00,-0.61567E+00,-0.61762E+00,& - -0.61959E+00,-0.62157E+00,-0.62357E+00,-0.62558E+00,-0.62761E+00,& - -0.62966E+00,-0.63173E+00,-0.63381E+00,-0.63590E+00,-0.63801E+00,& - -0.64014E+00,-0.64228E+00,-0.64444E+00,-0.64661E+00,-0.64879E+00,& - -0.65099E+00,-0.65321E+00,-0.65544E+00,-0.65768E+00,-0.65993E+00,& - -0.66220E+00,-0.66448E+00,-0.66678E+00,-0.66909E+00,-0.67141E+00,& - -0.67374E+00,-0.67609E+00,-0.67845E+00,-0.68082E+00,-0.68320E+00,& - -0.68560E+00,-0.68800E+00,-0.69042E+00,-0.69285E+00,-0.69529E+00,& - -0.69774E+00,-0.70021E+00,-0.70268E+00,-0.70516E+00,-0.70766E+00,& - -0.71017E+00,-0.71268E+00,-0.71521E+00,-0.71775E+00,-0.72030E+00/ - - DATA (BNC13M(IA),IA=701,741)/ & - -0.72285E+00,-0.72542E+00,-0.72800E+00,-0.73059E+00,-0.73318E+00,& - -0.73579E+00,-0.73840E+00,-0.74103E+00,-0.74366E+00,-0.74631E+00,& - -0.74896E+00,-0.75162E+00,-0.75429E+00,-0.75697E+00,-0.75966E+00,& - -0.76235E+00,-0.76505E+00,-0.76777E+00,-0.77049E+00,-0.77322E+00,& - -0.77595E+00,-0.77870E+00,-0.78145E+00,-0.78421E+00,-0.78698E+00,& - -0.78976E+00,-0.79254E+00,-0.79534E+00,-0.79814E+00,-0.80094E+00,& - -0.80376E+00,-0.80658E+00,-0.80941E+00,-0.81224E+00,-0.81509E+00,& - -0.81794E+00,-0.82079E+00,-0.82366E+00,-0.82653E+00,-0.82940E+00,& - -0.83229E+00 / -! END - -! ** TEMP = 273.0 - -! BLOCK DATA KMCF273 -! -! ** Common block definition -! -! COMMON /KMC273/ & -! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & -! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & -! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & -! BNC13M( 741) -! -! ** NaCl -! - DATA (BNC01M (IA),IA= 1,100)/ & - -0.51181E-01,-0.90341E-01,-0.11577E+00,-0.13175E+00,-0.14316E+00,& - -0.15182E+00,-0.15860E+00,-0.16404E+00,-0.16845E+00,-0.17205E+00,& - -0.17501E+00,-0.17742E+00,-0.17939E+00,-0.18097E+00,-0.18222E+00,& - -0.18320E+00,-0.18392E+00,-0.18442E+00,-0.18473E+00,-0.18487E+00,& - -0.18485E+00,-0.18470E+00,-0.18442E+00,-0.18402E+00,-0.18353E+00,& - -0.18294E+00,-0.18227E+00,-0.18153E+00,-0.18071E+00,-0.17983E+00,& - -0.17889E+00,-0.17790E+00,-0.17686E+00,-0.17578E+00,-0.17466E+00,& - -0.17350E+00,-0.17231E+00,-0.17109E+00,-0.16984E+00,-0.16856E+00,& - -0.16726E+00,-0.16594E+00,-0.16461E+00,-0.16325E+00,-0.16188E+00,& - -0.16050E+00,-0.15910E+00,-0.15769E+00,-0.15627E+00,-0.15484E+00,& - -0.15340E+00,-0.15196E+00,-0.15050E+00,-0.14904E+00,-0.14757E+00,& - -0.14610E+00,-0.14462E+00,-0.14313E+00,-0.14164E+00,-0.14014E+00,& - -0.13863E+00,-0.13712E+00,-0.13560E+00,-0.13408E+00,-0.13255E+00,& - -0.13101E+00,-0.12947E+00,-0.12792E+00,-0.12636E+00,-0.12479E+00,& - -0.12321E+00,-0.12163E+00,-0.12003E+00,-0.11843E+00,-0.11681E+00,& - -0.11518E+00,-0.11355E+00,-0.11189E+00,-0.11023E+00,-0.10856E+00,& - -0.10687E+00,-0.10517E+00,-0.10346E+00,-0.10173E+00,-0.99989E-01,& - -0.98234E-01,-0.96465E-01,-0.94683E-01,-0.92886E-01,-0.91075E-01,& - -0.89250E-01,-0.87411E-01,-0.85558E-01,-0.83692E-01,-0.81812E-01,& - -0.79919E-01,-0.78013E-01,-0.76094E-01,-0.74163E-01,-0.72220E-01/ - - DATA (BNC01M (IA),IA=101,200)/ & - -0.70265E-01,-0.68299E-01,-0.66323E-01,-0.64335E-01,-0.62338E-01,& - -0.60331E-01,-0.58315E-01,-0.56291E-01,-0.54258E-01,-0.52218E-01,& - -0.50171E-01,-0.48116E-01,-0.46056E-01,-0.43989E-01,-0.41917E-01,& - -0.39840E-01,-0.37759E-01,-0.35673E-01,-0.33583E-01,-0.31490E-01,& - -0.29641E-01,-0.27514E-01,-0.25387E-01,-0.23261E-01,-0.21135E-01,& - -0.19010E-01,-0.16886E-01,-0.14763E-01,-0.12640E-01,-0.10519E-01,& - -0.83981E-02,-0.62786E-02,-0.41603E-02,-0.20431E-02, 0.72873E-04,& - 0.21874E-02, 0.43007E-02, 0.64126E-02, 0.85231E-02, 0.10632E-01,& - 0.12740E-01, 0.14845E-01, 0.16950E-01, 0.19052E-01, 0.21153E-01,& - 0.23252E-01, 0.25350E-01, 0.27446E-01, 0.29539E-01, 0.31631E-01,& - 0.33721E-01, 0.35809E-01, 0.37895E-01, 0.39979E-01, 0.42061E-01,& - 0.44141E-01, 0.46219E-01, 0.48295E-01, 0.50369E-01, 0.52440E-01,& - 0.54509E-01, 0.56576E-01, 0.58641E-01, 0.60703E-01, 0.62764E-01,& - 0.64821E-01, 0.66877E-01, 0.68930E-01, 0.70981E-01, 0.73029E-01,& - 0.75075E-01, 0.77119E-01, 0.79160E-01, 0.81199E-01, 0.83235E-01,& - 0.85268E-01, 0.87299E-01, 0.89328E-01, 0.91354E-01, 0.93378E-01,& - 0.95399E-01, 0.97417E-01, 0.99433E-01, 0.10145E+00, 0.10346E+00,& - 0.10546E+00, 0.10747E+00, 0.10947E+00, 0.11147E+00, 0.11347E+00,& - 0.11546E+00, 0.11746E+00, 0.11944E+00, 0.12143E+00, 0.12341E+00,& - 0.12540E+00, 0.12737E+00, 0.12935E+00, 0.13132E+00, 0.13329E+00/ - - DATA (BNC01M (IA),IA=201,300)/ & - 0.13526E+00, 0.13722E+00, 0.13919E+00, 0.14114E+00, 0.14310E+00,& - 0.14505E+00, 0.14700E+00, 0.14895E+00, 0.15090E+00, 0.15284E+00,& - 0.15478E+00, 0.15671E+00, 0.15865E+00, 0.16058E+00, 0.16251E+00,& - 0.16443E+00, 0.16635E+00, 0.16827E+00, 0.17019E+00, 0.17210E+00,& - 0.17402E+00, 0.17592E+00, 0.17783E+00, 0.17973E+00, 0.18163E+00,& - 0.18353E+00, 0.18542E+00, 0.18731E+00, 0.18920E+00, 0.19109E+00,& - 0.19297E+00, 0.19485E+00, 0.19672E+00, 0.19860E+00, 0.20047E+00,& - 0.20234E+00, 0.20420E+00, 0.20606E+00, 0.20792E+00, 0.20978E+00,& - 0.21164E+00, 0.21349E+00, 0.21533E+00, 0.21718E+00, 0.21902E+00,& - 0.22086E+00, 0.22270E+00, 0.22453E+00, 0.22636E+00, 0.22819E+00,& - 0.23002E+00, 0.23184E+00, 0.23366E+00, 0.23548E+00, 0.23729E+00,& - 0.23910E+00, 0.24091E+00, 0.24272E+00, 0.24452E+00, 0.24632E+00,& - 0.24812E+00, 0.24991E+00, 0.25170E+00, 0.25349E+00, 0.25528E+00,& - 0.25706E+00, 0.25884E+00, 0.26062E+00, 0.26239E+00, 0.26417E+00,& - 0.26594E+00, 0.26770E+00, 0.26947E+00, 0.27123E+00, 0.27299E+00,& - 0.27474E+00, 0.27649E+00, 0.27824E+00, 0.27999E+00, 0.28173E+00,& - 0.28348E+00, 0.28522E+00, 0.28695E+00, 0.28869E+00, 0.29042E+00,& - 0.29214E+00, 0.29387E+00, 0.29559E+00, 0.29731E+00, 0.29903E+00,& - 0.30074E+00, 0.30245E+00, 0.30416E+00, 0.30587E+00, 0.30757E+00,& - 0.30927E+00, 0.31097E+00, 0.31267E+00, 0.31436E+00, 0.31605E+00/ - - DATA (BNC01M (IA),IA=301,400)/ & - 0.31774E+00, 0.31942E+00, 0.32111E+00, 0.32279E+00, 0.32446E+00,& - 0.32614E+00, 0.32781E+00, 0.32948E+00, 0.33115E+00, 0.33281E+00,& - 0.33447E+00, 0.33613E+00, 0.33779E+00, 0.33944E+00, 0.34109E+00,& - 0.34274E+00, 0.34438E+00, 0.34603E+00, 0.34767E+00, 0.34930E+00,& - 0.35094E+00, 0.35257E+00, 0.35420E+00, 0.35583E+00, 0.35746E+00,& - 0.35908E+00, 0.36070E+00, 0.36232E+00, 0.36393E+00, 0.36554E+00,& - 0.36715E+00, 0.36876E+00, 0.37037E+00, 0.37197E+00, 0.37357E+00,& - 0.37517E+00, 0.37676E+00, 0.37835E+00, 0.37994E+00, 0.38153E+00,& - 0.38312E+00, 0.38470E+00, 0.38628E+00, 0.38786E+00, 0.38943E+00,& - 0.39100E+00, 0.39257E+00, 0.39414E+00, 0.39571E+00, 0.39727E+00,& - 0.39883E+00, 0.40039E+00, 0.40195E+00, 0.40350E+00, 0.40505E+00,& - 0.40660E+00, 0.40814E+00, 0.40969E+00, 0.41123E+00, 0.41277E+00,& - 0.41431E+00, 0.41584E+00, 0.41737E+00, 0.41890E+00, 0.42043E+00,& - 0.42195E+00, 0.42348E+00, 0.42500E+00, 0.42651E+00, 0.42803E+00,& - 0.42954E+00, 0.43105E+00, 0.43256E+00, 0.43407E+00, 0.43557E+00,& - 0.43707E+00, 0.43857E+00, 0.44007E+00, 0.44157E+00, 0.44306E+00,& - 0.44455E+00, 0.44604E+00, 0.44752E+00, 0.44901E+00, 0.45049E+00,& - 0.45197E+00, 0.45344E+00, 0.45492E+00, 0.45639E+00, 0.45786E+00,& - 0.45933E+00, 0.46079E+00, 0.46226E+00, 0.46372E+00, 0.46518E+00,& - 0.46664E+00, 0.46809E+00, 0.46954E+00, 0.47099E+00, 0.47244E+00/ - - DATA (BNC01M (IA),IA=401,500)/ & - 0.47389E+00, 0.47533E+00, 0.47677E+00, 0.47821E+00, 0.47965E+00,& - 0.48108E+00, 0.48252E+00, 0.48395E+00, 0.48538E+00, 0.48680E+00,& - 0.48823E+00, 0.48965E+00, 0.49107E+00, 0.49249E+00, 0.49391E+00,& - 0.49532E+00, 0.49673E+00, 0.49814E+00, 0.49955E+00, 0.50095E+00,& - 0.50236E+00, 0.50376E+00, 0.50516E+00, 0.50656E+00, 0.50795E+00,& - 0.50934E+00, 0.51074E+00, 0.51213E+00, 0.51351E+00, 0.51490E+00,& - 0.51628E+00, 0.51766E+00, 0.51904E+00, 0.52042E+00, 0.52179E+00,& - 0.52317E+00, 0.52454E+00, 0.52591E+00, 0.52727E+00, 0.52864E+00,& - 0.53000E+00, 0.53136E+00, 0.53272E+00, 0.53408E+00, 0.53543E+00,& - 0.53678E+00, 0.53814E+00, 0.53949E+00, 0.54083E+00, 0.54218E+00,& - 0.54352E+00, 0.54486E+00, 0.54620E+00, 0.54754E+00, 0.54888E+00,& - 0.55021E+00, 0.55154E+00, 0.55287E+00, 0.55420E+00, 0.55552E+00,& - 0.55685E+00, 0.55817E+00, 0.55949E+00, 0.56081E+00, 0.56213E+00,& - 0.56344E+00, 0.56475E+00, 0.56606E+00, 0.56737E+00, 0.56868E+00,& - 0.56999E+00, 0.57129E+00, 0.57259E+00, 0.57389E+00, 0.57519E+00,& - 0.57649E+00, 0.57778E+00, 0.57907E+00, 0.58036E+00, 0.58165E+00,& - 0.58294E+00, 0.58422E+00, 0.58551E+00, 0.58679E+00, 0.58807E+00,& - 0.58935E+00, 0.59062E+00, 0.59190E+00, 0.59317E+00, 0.59444E+00,& - 0.59571E+00, 0.59698E+00, 0.59824E+00, 0.59951E+00, 0.60077E+00,& - 0.60203E+00, 0.60329E+00, 0.60454E+00, 0.60580E+00, 0.60705E+00/ - - DATA (BNC01M (IA),IA=501,600)/ & - 0.60830E+00, 0.60955E+00, 0.61080E+00, 0.61205E+00, 0.61329E+00,& - 0.61454E+00, 0.61578E+00, 0.61702E+00, 0.61825E+00, 0.61949E+00,& - 0.62072E+00, 0.62196E+00, 0.62319E+00, 0.62442E+00, 0.62565E+00,& - 0.62687E+00, 0.62810E+00, 0.62932E+00, 0.63054E+00, 0.63176E+00,& - 0.63298E+00, 0.63419E+00, 0.63541E+00, 0.63662E+00, 0.63783E+00,& - 0.63904E+00, 0.64025E+00, 0.64145E+00, 0.64266E+00, 0.64386E+00,& - 0.64506E+00, 0.64626E+00, 0.64746E+00, 0.64866E+00, 0.64985E+00,& - 0.65104E+00, 0.65223E+00, 0.65342E+00, 0.65461E+00, 0.65580E+00,& - 0.65698E+00, 0.65817E+00, 0.65935E+00, 0.66053E+00, 0.66171E+00,& - 0.66289E+00, 0.66406E+00, 0.66524E+00, 0.66641E+00, 0.66758E+00,& - 0.66875E+00, 0.66992E+00, 0.67108E+00, 0.67225E+00, 0.67341E+00,& - 0.67457E+00, 0.67573E+00, 0.67689E+00, 0.67805E+00, 0.67920E+00,& - 0.68036E+00, 0.68151E+00, 0.68266E+00, 0.68381E+00, 0.68496E+00,& - 0.68610E+00, 0.68725E+00, 0.68839E+00, 0.68953E+00, 0.69068E+00,& - 0.69181E+00, 0.69295E+00, 0.69409E+00, 0.69522E+00, 0.69636E+00,& - 0.69749E+00, 0.69862E+00, 0.69975E+00, 0.70087E+00, 0.70200E+00,& - 0.70312E+00, 0.70425E+00, 0.70537E+00, 0.70649E+00, 0.70760E+00,& - 0.70872E+00, 0.70984E+00, 0.71095E+00, 0.71206E+00, 0.71317E+00,& - 0.71428E+00, 0.71539E+00, 0.71650E+00, 0.71761E+00, 0.71871E+00,& - 0.71981E+00, 0.72091E+00, 0.72201E+00, 0.72311E+00, 0.72722E+00/ - - DATA (BNC01M (IA),IA=601,700)/ & - 0.73618E+00, 0.74693E+00, 0.75754E+00, 0.76801E+00, 0.77836E+00,& - 0.78859E+00, 0.79869E+00, 0.80867E+00, 0.81853E+00, 0.82827E+00,& - 0.83790E+00, 0.84742E+00, 0.85682E+00, 0.86613E+00, 0.87532E+00,& - 0.88441E+00, 0.89340E+00, 0.90229E+00, 0.91108E+00, 0.91978E+00,& - 0.92838E+00, 0.93688E+00, 0.94530E+00, 0.95363E+00, 0.96187E+00,& - 0.97002E+00, 0.97808E+00, 0.98607E+00, 0.99397E+00, 0.10018E+01,& - 0.10095E+01, 0.10172E+01, 0.10248E+01, 0.10323E+01, 0.10397E+01,& - 0.10471E+01, 0.10544E+01, 0.10616E+01, 0.10688E+01, 0.10758E+01,& - 0.10828E+01, 0.10898E+01, 0.10967E+01, 0.11035E+01, 0.11102E+01,& - 0.11169E+01, 0.11236E+01, 0.11301E+01, 0.11366E+01, 0.11431E+01,& - 0.11495E+01, 0.11558E+01, 0.11621E+01, 0.11683E+01, 0.11745E+01,& - 0.11806E+01, 0.11867E+01, 0.11927E+01, 0.11986E+01, 0.12045E+01,& - 0.12104E+01, 0.12162E+01, 0.12220E+01, 0.12277E+01, 0.12333E+01,& - 0.12389E+01, 0.12445E+01, 0.12500E+01, 0.12555E+01, 0.12609E+01,& - 0.12663E+01, 0.12717E+01, 0.12770E+01, 0.12822E+01, 0.12874E+01,& - 0.12926E+01, 0.12977E+01, 0.13028E+01, 0.13079E+01, 0.13129E+01,& - 0.13179E+01, 0.13228E+01, 0.13277E+01, 0.13325E+01, 0.13374E+01,& - 0.13421E+01, 0.13469E+01, 0.13516E+01, 0.13563E+01, 0.13609E+01,& - 0.13655E+01, 0.13701E+01, 0.13746E+01, 0.13792E+01, 0.13836E+01,& - 0.13881E+01, 0.13925E+01, 0.13968E+01, 0.14012E+01, 0.14055E+01/ - - DATA (BNC01M(IA),IA=701,741)/ & - 0.14098E+01, 0.14140E+01, 0.14183E+01, 0.14224E+01, 0.14266E+01,& - 0.14307E+01, 0.14348E+01, 0.14389E+01, 0.14430E+01, 0.14470E+01,& - 0.14510E+01, 0.14549E+01, 0.14589E+01, 0.14628E+01, 0.14666E+01,& - 0.14705E+01, 0.14743E+01, 0.14781E+01, 0.14819E+01, 0.14856E+01,& - 0.14894E+01, 0.14931E+01, 0.14967E+01, 0.15004E+01, 0.15040E+01,& - 0.15076E+01, 0.15112E+01, 0.15147E+01, 0.15183E+01, 0.15218E+01,& - 0.15253E+01, 0.15287E+01, 0.15322E+01, 0.15356E+01, 0.15390E+01,& - 0.15424E+01, 0.15457E+01, 0.15490E+01, 0.15524E+01, 0.15556E+01,& - 0.15589E+01 / -! -! ** Na2SO4 -! - DATA (BNC02M (IA),IA= 1,100)/ & - -0.10572E+00,-0.19298E+00,-0.25472E+00,-0.29692E+00,-0.32958E+00,& - -0.35641E+00,-0.37928E+00,-0.39926E+00,-0.41702E+00,-0.43303E+00,& - -0.44762E+00,-0.46103E+00,-0.47344E+00,-0.48500E+00,-0.49582E+00,& - -0.50599E+00,-0.51560E+00,-0.52470E+00,-0.53334E+00,-0.54158E+00,& - -0.54945E+00,-0.55698E+00,-0.56420E+00,-0.57114E+00,-0.57782E+00,& - -0.58426E+00,-0.59048E+00,-0.59649E+00,-0.60231E+00,-0.60795E+00,& - -0.61341E+00,-0.61872E+00,-0.62388E+00,-0.62890E+00,-0.63378E+00,& - -0.63854E+00,-0.64318E+00,-0.64771E+00,-0.65213E+00,-0.65644E+00,& - -0.66066E+00,-0.66479E+00,-0.66882E+00,-0.67278E+00,-0.67665E+00,& - -0.68044E+00,-0.68416E+00,-0.68780E+00,-0.69138E+00,-0.69489E+00,& - -0.69834E+00,-0.70173E+00,-0.70505E+00,-0.70833E+00,-0.71154E+00,& - -0.71471E+00,-0.71782E+00,-0.72089E+00,-0.72391E+00,-0.72688E+00,& - -0.72981E+00,-0.73269E+00,-0.73554E+00,-0.73834E+00,-0.74111E+00,& - -0.74384E+00,-0.74654E+00,-0.74920E+00,-0.75183E+00,-0.75442E+00,& - -0.75698E+00,-0.75952E+00,-0.76202E+00,-0.76450E+00,-0.76695E+00,& - -0.76937E+00,-0.77176E+00,-0.77414E+00,-0.77648E+00,-0.77881E+00,& - -0.78111E+00,-0.78339E+00,-0.78564E+00,-0.78788E+00,-0.79010E+00,& - -0.79229E+00,-0.79447E+00,-0.79663E+00,-0.79877E+00,-0.80090E+00,& - -0.80300E+00,-0.80509E+00,-0.80717E+00,-0.80922E+00,-0.81127E+00,& - -0.81329E+00,-0.81530E+00,-0.81730E+00,-0.81928E+00,-0.82125E+00/ - - DATA (BNC02M (IA),IA=101,200)/ & - -0.82321E+00,-0.82515E+00,-0.82707E+00,-0.82899E+00,-0.83089E+00,& - -0.83278E+00,-0.83466E+00,-0.83652E+00,-0.83837E+00,-0.84021E+00,& - -0.84204E+00,-0.84386E+00,-0.84566E+00,-0.84746E+00,-0.84924E+00,& - -0.85101E+00,-0.85277E+00,-0.85452E+00,-0.85626E+00,-0.85799E+00,& - -0.85967E+00,-0.86138E+00,-0.86309E+00,-0.86478E+00,-0.86646E+00,& - -0.86813E+00,-0.86980E+00,-0.87145E+00,-0.87309E+00,-0.87473E+00,& - -0.87635E+00,-0.87797E+00,-0.87957E+00,-0.88117E+00,-0.88276E+00,& - -0.88434E+00,-0.88591E+00,-0.88747E+00,-0.88902E+00,-0.89057E+00,& - -0.89211E+00,-0.89364E+00,-0.89516E+00,-0.89667E+00,-0.89818E+00,& - -0.89968E+00,-0.90117E+00,-0.90266E+00,-0.90413E+00,-0.90560E+00,& - -0.90707E+00,-0.90852E+00,-0.90997E+00,-0.91141E+00,-0.91285E+00,& - -0.91428E+00,-0.91570E+00,-0.91711E+00,-0.91852E+00,-0.91992E+00,& - -0.92132E+00,-0.92271E+00,-0.92410E+00,-0.92547E+00,-0.92685E+00,& - -0.92821E+00,-0.92957E+00,-0.93093E+00,-0.93228E+00,-0.93362E+00,& - -0.93496E+00,-0.93629E+00,-0.93761E+00,-0.93894E+00,-0.94025E+00,& - -0.94156E+00,-0.94287E+00,-0.94417E+00,-0.94546E+00,-0.94675E+00,& - -0.94804E+00,-0.94932E+00,-0.95059E+00,-0.95186E+00,-0.95313E+00,& - -0.95439E+00,-0.95565E+00,-0.95690E+00,-0.95815E+00,-0.95939E+00,& - -0.96063E+00,-0.96186E+00,-0.96309E+00,-0.96431E+00,-0.96553E+00,& - -0.96675E+00,-0.96796E+00,-0.96917E+00,-0.97037E+00,-0.97157E+00/ - - DATA (BNC02M (IA),IA=201,300)/ & - -0.97277E+00,-0.97396E+00,-0.97514E+00,-0.97633E+00,-0.97751E+00,& - -0.97868E+00,-0.97985E+00,-0.98102E+00,-0.98218E+00,-0.98334E+00,& - -0.98450E+00,-0.98565E+00,-0.98680E+00,-0.98795E+00,-0.98909E+00,& - -0.99023E+00,-0.99136E+00,-0.99249E+00,-0.99362E+00,-0.99474E+00,& - -0.99586E+00,-0.99698E+00,-0.99809E+00,-0.99920E+00,-0.10003E+01,& - -0.10014E+01,-0.10025E+01,-0.10036E+01,-0.10047E+01,-0.10058E+01,& - -0.10069E+01,-0.10080E+01,-0.10091E+01,-0.10101E+01,-0.10112E+01,& - -0.10123E+01,-0.10133E+01,-0.10144E+01,-0.10155E+01,-0.10165E+01,& - -0.10176E+01,-0.10187E+01,-0.10197E+01,-0.10208E+01,-0.10218E+01,& - -0.10228E+01,-0.10239E+01,-0.10249E+01,-0.10260E+01,-0.10270E+01,& - -0.10280E+01,-0.10291E+01,-0.10301E+01,-0.10311E+01,-0.10321E+01,& - -0.10331E+01,-0.10341E+01,-0.10352E+01,-0.10362E+01,-0.10372E+01,& - -0.10382E+01,-0.10392E+01,-0.10402E+01,-0.10412E+01,-0.10422E+01,& - -0.10432E+01,-0.10442E+01,-0.10451E+01,-0.10461E+01,-0.10471E+01,& - -0.10481E+01,-0.10491E+01,-0.10500E+01,-0.10510E+01,-0.10520E+01,& - -0.10530E+01,-0.10539E+01,-0.10549E+01,-0.10559E+01,-0.10568E+01,& - -0.10578E+01,-0.10587E+01,-0.10597E+01,-0.10606E+01,-0.10616E+01,& - -0.10625E+01,-0.10635E+01,-0.10644E+01,-0.10654E+01,-0.10663E+01,& - -0.10672E+01,-0.10682E+01,-0.10691E+01,-0.10700E+01,-0.10710E+01,& - -0.10719E+01,-0.10728E+01,-0.10737E+01,-0.10747E+01,-0.10756E+01/ - - DATA (BNC02M (IA),IA=301,400)/ & - -0.10765E+01,-0.10774E+01,-0.10783E+01,-0.10792E+01,-0.10801E+01,& - -0.10811E+01,-0.10820E+01,-0.10829E+01,-0.10838E+01,-0.10847E+01,& - -0.10856E+01,-0.10865E+01,-0.10874E+01,-0.10883E+01,-0.10891E+01,& - -0.10900E+01,-0.10909E+01,-0.10918E+01,-0.10927E+01,-0.10936E+01,& - -0.10945E+01,-0.10953E+01,-0.10962E+01,-0.10971E+01,-0.10980E+01,& - -0.10988E+01,-0.10997E+01,-0.11006E+01,-0.11015E+01,-0.11023E+01,& - -0.11032E+01,-0.11040E+01,-0.11049E+01,-0.11058E+01,-0.11066E+01,& - -0.11075E+01,-0.11083E+01,-0.11092E+01,-0.11101E+01,-0.11109E+01,& - -0.11118E+01,-0.11126E+01,-0.11134E+01,-0.11143E+01,-0.11151E+01,& - -0.11160E+01,-0.11168E+01,-0.11177E+01,-0.11185E+01,-0.11193E+01,& - -0.11202E+01,-0.11210E+01,-0.11218E+01,-0.11227E+01,-0.11235E+01,& - -0.11243E+01,-0.11252E+01,-0.11260E+01,-0.11268E+01,-0.11276E+01,& - -0.11284E+01,-0.11293E+01,-0.11301E+01,-0.11309E+01,-0.11317E+01,& - -0.11325E+01,-0.11333E+01,-0.11342E+01,-0.11350E+01,-0.11358E+01,& - -0.11366E+01,-0.11374E+01,-0.11382E+01,-0.11390E+01,-0.11398E+01,& - -0.11406E+01,-0.11414E+01,-0.11422E+01,-0.11430E+01,-0.11438E+01,& - -0.11446E+01,-0.11454E+01,-0.11462E+01,-0.11470E+01,-0.11478E+01,& - -0.11486E+01,-0.11493E+01,-0.11501E+01,-0.11509E+01,-0.11517E+01,& - -0.11525E+01,-0.11533E+01,-0.11541E+01,-0.11548E+01,-0.11556E+01,& - -0.11564E+01,-0.11572E+01,-0.11579E+01,-0.11587E+01,-0.11595E+01/ - - DATA (BNC02M (IA),IA=401,500)/ & - -0.11603E+01,-0.11610E+01,-0.11618E+01,-0.11626E+01,-0.11633E+01,& - -0.11641E+01,-0.11649E+01,-0.11656E+01,-0.11664E+01,-0.11672E+01,& - -0.11679E+01,-0.11687E+01,-0.11694E+01,-0.11702E+01,-0.11710E+01,& - -0.11717E+01,-0.11725E+01,-0.11732E+01,-0.11740E+01,-0.11747E+01,& - -0.11755E+01,-0.11762E+01,-0.11770E+01,-0.11777E+01,-0.11785E+01,& - -0.11792E+01,-0.11800E+01,-0.11807E+01,-0.11815E+01,-0.11822E+01,& - -0.11829E+01,-0.11837E+01,-0.11844E+01,-0.11852E+01,-0.11859E+01,& - -0.11866E+01,-0.11874E+01,-0.11881E+01,-0.11888E+01,-0.11896E+01,& - -0.11903E+01,-0.11910E+01,-0.11918E+01,-0.11925E+01,-0.11932E+01,& - -0.11940E+01,-0.11947E+01,-0.11954E+01,-0.11961E+01,-0.11969E+01,& - -0.11976E+01,-0.11983E+01,-0.11990E+01,-0.11997E+01,-0.12005E+01,& - -0.12012E+01,-0.12019E+01,-0.12026E+01,-0.12033E+01,-0.12040E+01,& - -0.12048E+01,-0.12055E+01,-0.12062E+01,-0.12069E+01,-0.12076E+01,& - -0.12083E+01,-0.12090E+01,-0.12097E+01,-0.12104E+01,-0.12111E+01,& - -0.12118E+01,-0.12126E+01,-0.12133E+01,-0.12140E+01,-0.12147E+01,& - -0.12154E+01,-0.12161E+01,-0.12168E+01,-0.12175E+01,-0.12182E+01,& - -0.12189E+01,-0.12196E+01,-0.12203E+01,-0.12209E+01,-0.12216E+01,& - -0.12223E+01,-0.12230E+01,-0.12237E+01,-0.12244E+01,-0.12251E+01,& - -0.12258E+01,-0.12265E+01,-0.12272E+01,-0.12279E+01,-0.12285E+01,& - -0.12292E+01,-0.12299E+01,-0.12306E+01,-0.12313E+01,-0.12320E+01/ - - DATA (BNC02M (IA),IA=501,600)/ & - -0.12327E+01,-0.12333E+01,-0.12340E+01,-0.12347E+01,-0.12354E+01,& - -0.12361E+01,-0.12367E+01,-0.12374E+01,-0.12381E+01,-0.12388E+01,& - -0.12394E+01,-0.12401E+01,-0.12408E+01,-0.12415E+01,-0.12421E+01,& - -0.12428E+01,-0.12435E+01,-0.12441E+01,-0.12448E+01,-0.12455E+01,& - -0.12462E+01,-0.12468E+01,-0.12475E+01,-0.12482E+01,-0.12488E+01,& - -0.12495E+01,-0.12501E+01,-0.12508E+01,-0.12515E+01,-0.12521E+01,& - -0.12528E+01,-0.12535E+01,-0.12541E+01,-0.12548E+01,-0.12554E+01,& - -0.12561E+01,-0.12568E+01,-0.12574E+01,-0.12581E+01,-0.12587E+01,& - -0.12594E+01,-0.12600E+01,-0.12607E+01,-0.12613E+01,-0.12620E+01,& - -0.12626E+01,-0.12633E+01,-0.12639E+01,-0.12646E+01,-0.12652E+01,& - -0.12659E+01,-0.12665E+01,-0.12672E+01,-0.12678E+01,-0.12685E+01,& - -0.12691E+01,-0.12698E+01,-0.12704E+01,-0.12711E+01,-0.12717E+01,& - -0.12724E+01,-0.12730E+01,-0.12736E+01,-0.12743E+01,-0.12749E+01,& - -0.12756E+01,-0.12762E+01,-0.12768E+01,-0.12775E+01,-0.12781E+01,& - -0.12788E+01,-0.12794E+01,-0.12800E+01,-0.12807E+01,-0.12813E+01,& - -0.12819E+01,-0.12826E+01,-0.12832E+01,-0.12838E+01,-0.12845E+01,& - -0.12851E+01,-0.12857E+01,-0.12864E+01,-0.12870E+01,-0.12876E+01,& - -0.12882E+01,-0.12889E+01,-0.12895E+01,-0.12901E+01,-0.12908E+01,& - -0.12914E+01,-0.12920E+01,-0.12926E+01,-0.12933E+01,-0.12939E+01,& - -0.12945E+01,-0.12951E+01,-0.12957E+01,-0.12964E+01,-0.12987E+01/ - - DATA (BNC02M (IA),IA=601,700)/ & - -0.13038E+01,-0.13099E+01,-0.13160E+01,-0.13220E+01,-0.13280E+01,& - -0.13340E+01,-0.13399E+01,-0.13457E+01,-0.13515E+01,-0.13573E+01,& - -0.13631E+01,-0.13688E+01,-0.13744E+01,-0.13801E+01,-0.13856E+01,& - -0.13912E+01,-0.13967E+01,-0.14022E+01,-0.14077E+01,-0.14131E+01,& - -0.14185E+01,-0.14239E+01,-0.14292E+01,-0.14345E+01,-0.14398E+01,& - -0.14451E+01,-0.14503E+01,-0.14555E+01,-0.14607E+01,-0.14659E+01,& - -0.14710E+01,-0.14761E+01,-0.14812E+01,-0.14862E+01,-0.14913E+01,& - -0.14963E+01,-0.15013E+01,-0.15063E+01,-0.15112E+01,-0.15161E+01,& - -0.15211E+01,-0.15260E+01,-0.15308E+01,-0.15357E+01,-0.15405E+01,& - -0.15453E+01,-0.15501E+01,-0.15549E+01,-0.15597E+01,-0.15644E+01,& - -0.15692E+01,-0.15739E+01,-0.15786E+01,-0.15833E+01,-0.15880E+01,& - -0.15926E+01,-0.15972E+01,-0.16019E+01,-0.16065E+01,-0.16111E+01,& - -0.16157E+01,-0.16202E+01,-0.16248E+01,-0.16293E+01,-0.16338E+01,& - -0.16384E+01,-0.16429E+01,-0.16473E+01,-0.16518E+01,-0.16563E+01,& - -0.16607E+01,-0.16652E+01,-0.16696E+01,-0.16740E+01,-0.16784E+01,& - -0.16828E+01,-0.16872E+01,-0.16915E+01,-0.16959E+01,-0.17003E+01,& - -0.17046E+01,-0.17089E+01,-0.17132E+01,-0.17175E+01,-0.17218E+01,& - -0.17261E+01,-0.17304E+01,-0.17347E+01,-0.17389E+01,-0.17432E+01,& - -0.17474E+01,-0.17516E+01,-0.17559E+01,-0.17601E+01,-0.17643E+01,& - -0.17685E+01,-0.17726E+01,-0.17768E+01,-0.17810E+01,-0.17851E+01/ - - DATA (BNC02M(IA),IA=701,741)/ & - -0.17893E+01,-0.17934E+01,-0.17976E+01,-0.18017E+01,-0.18058E+01,& - -0.18099E+01,-0.18140E+01,-0.18181E+01,-0.18222E+01,-0.18263E+01,& - -0.18304E+01,-0.18344E+01,-0.18385E+01,-0.18425E+01,-0.18466E+01,& - -0.18506E+01,-0.18547E+01,-0.18587E+01,-0.18627E+01,-0.18667E+01,& - -0.18707E+01,-0.18747E+01,-0.18787E+01,-0.18827E+01,-0.18866E+01,& - -0.18906E+01,-0.18946E+01,-0.18985E+01,-0.19025E+01,-0.19064E+01,& - -0.19104E+01,-0.19143E+01,-0.19182E+01,-0.19222E+01,-0.19261E+01,& - -0.19300E+01,-0.19339E+01,-0.19378E+01,-0.19417E+01,-0.19456E+01,& - -0.19495E+01 / -! -! ** NaNO3 -! - DATA (BNC03M (IA),IA= 1,100)/ & - -0.53018E-01,-0.97087E-01,-0.12849E+00,-0.15010E+00,-0.16692E+00,& - -0.18081E+00,-0.19271E+00,-0.20315E+00,-0.21248E+00,-0.22092E+00,& - -0.22865E+00,-0.23578E+00,-0.24240E+00,-0.24860E+00,-0.25441E+00,& - -0.25991E+00,-0.26511E+00,-0.27005E+00,-0.27476E+00,-0.27927E+00,& - -0.28358E+00,-0.28773E+00,-0.29171E+00,-0.29555E+00,-0.29926E+00,& - -0.30284E+00,-0.30631E+00,-0.30967E+00,-0.31293E+00,-0.31609E+00,& - -0.31917E+00,-0.32216E+00,-0.32508E+00,-0.32792E+00,-0.33069E+00,& - -0.33340E+00,-0.33604E+00,-0.33862E+00,-0.34115E+00,-0.34361E+00,& - -0.34603E+00,-0.34840E+00,-0.35072E+00,-0.35299E+00,-0.35522E+00,& - -0.35741E+00,-0.35956E+00,-0.36167E+00,-0.36374E+00,-0.36578E+00,& - -0.36778E+00,-0.36974E+00,-0.37168E+00,-0.37358E+00,-0.37546E+00,& - -0.37730E+00,-0.37912E+00,-0.38091E+00,-0.38268E+00,-0.38442E+00,& - -0.38613E+00,-0.38783E+00,-0.38950E+00,-0.39115E+00,-0.39278E+00,& - -0.39439E+00,-0.39597E+00,-0.39754E+00,-0.39910E+00,-0.40063E+00,& - -0.40215E+00,-0.40365E+00,-0.40514E+00,-0.40661E+00,-0.40807E+00,& - -0.40951E+00,-0.41094E+00,-0.41236E+00,-0.41376E+00,-0.41515E+00,& - -0.41653E+00,-0.41790E+00,-0.41926E+00,-0.42061E+00,-0.42194E+00,& - -0.42327E+00,-0.42459E+00,-0.42590E+00,-0.42720E+00,-0.42849E+00,& - -0.42977E+00,-0.43104E+00,-0.43231E+00,-0.43356E+00,-0.43481E+00,& - -0.43605E+00,-0.43729E+00,-0.43852E+00,-0.43974E+00,-0.44095E+00/ - - DATA (BNC03M (IA),IA=101,200)/ & - -0.44215E+00,-0.44335E+00,-0.44455E+00,-0.44573E+00,-0.44691E+00,& - -0.44808E+00,-0.44925E+00,-0.45041E+00,-0.45156E+00,-0.45271E+00,& - -0.45385E+00,-0.45499E+00,-0.45611E+00,-0.45724E+00,-0.45836E+00,& - -0.45947E+00,-0.46057E+00,-0.46167E+00,-0.46277E+00,-0.46385E+00,& - -0.46489E+00,-0.46597E+00,-0.46705E+00,-0.46812E+00,-0.46918E+00,& - -0.47024E+00,-0.47129E+00,-0.47234E+00,-0.47338E+00,-0.47442E+00,& - -0.47545E+00,-0.47647E+00,-0.47749E+00,-0.47850E+00,-0.47951E+00,& - -0.48052E+00,-0.48152E+00,-0.48251E+00,-0.48350E+00,-0.48448E+00,& - -0.48546E+00,-0.48644E+00,-0.48741E+00,-0.48837E+00,-0.48934E+00,& - -0.49029E+00,-0.49124E+00,-0.49219E+00,-0.49313E+00,-0.49407E+00,& - -0.49501E+00,-0.49594E+00,-0.49687E+00,-0.49779E+00,-0.49871E+00,& - -0.49962E+00,-0.50053E+00,-0.50144E+00,-0.50234E+00,-0.50324E+00,& - -0.50414E+00,-0.50503E+00,-0.50592E+00,-0.50680E+00,-0.50768E+00,& - -0.50856E+00,-0.50943E+00,-0.51030E+00,-0.51117E+00,-0.51203E+00,& - -0.51289E+00,-0.51375E+00,-0.51460E+00,-0.51545E+00,-0.51630E+00,& - -0.51714E+00,-0.51798E+00,-0.51882E+00,-0.51965E+00,-0.52048E+00,& - -0.52131E+00,-0.52213E+00,-0.52295E+00,-0.52377E+00,-0.52459E+00,& - -0.52540E+00,-0.52621E+00,-0.52702E+00,-0.52782E+00,-0.52862E+00,& - -0.52942E+00,-0.53022E+00,-0.53101E+00,-0.53180E+00,-0.53259E+00,& - -0.53337E+00,-0.53416E+00,-0.53493E+00,-0.53571E+00,-0.53649E+00/ - - DATA (BNC03M (IA),IA=201,300)/ & - -0.53726E+00,-0.53803E+00,-0.53879E+00,-0.53956E+00,-0.54032E+00,& - -0.54108E+00,-0.54184E+00,-0.54259E+00,-0.54334E+00,-0.54409E+00,& - -0.54484E+00,-0.54559E+00,-0.54633E+00,-0.54707E+00,-0.54781E+00,& - -0.54854E+00,-0.54928E+00,-0.55001E+00,-0.55074E+00,-0.55147E+00,& - -0.55219E+00,-0.55291E+00,-0.55363E+00,-0.55435E+00,-0.55507E+00,& - -0.55578E+00,-0.55650E+00,-0.55721E+00,-0.55791E+00,-0.55862E+00,& - -0.55932E+00,-0.56003E+00,-0.56073E+00,-0.56142E+00,-0.56212E+00,& - -0.56282E+00,-0.56351E+00,-0.56420E+00,-0.56489E+00,-0.56557E+00,& - -0.56626E+00,-0.56694E+00,-0.56762E+00,-0.56830E+00,-0.56898E+00,& - -0.56966E+00,-0.57033E+00,-0.57100E+00,-0.57167E+00,-0.57234E+00,& - -0.57301E+00,-0.57367E+00,-0.57434E+00,-0.57500E+00,-0.57566E+00,& - -0.57632E+00,-0.57697E+00,-0.57763E+00,-0.57828E+00,-0.57893E+00,& - -0.57958E+00,-0.58023E+00,-0.58088E+00,-0.58153E+00,-0.58217E+00,& - -0.58281E+00,-0.58345E+00,-0.58409E+00,-0.58473E+00,-0.58537E+00,& - -0.58600E+00,-0.58663E+00,-0.58726E+00,-0.58789E+00,-0.58852E+00,& - -0.58915E+00,-0.58978E+00,-0.59040E+00,-0.59102E+00,-0.59164E+00,& - -0.59226E+00,-0.59288E+00,-0.59350E+00,-0.59411E+00,-0.59473E+00,& - -0.59534E+00,-0.59595E+00,-0.59656E+00,-0.59717E+00,-0.59778E+00,& - -0.59838E+00,-0.59899E+00,-0.59959E+00,-0.60019E+00,-0.60079E+00,& - -0.60139E+00,-0.60199E+00,-0.60259E+00,-0.60318E+00,-0.60378E+00/ - - DATA (BNC03M (IA),IA=301,400)/ & - -0.60437E+00,-0.60496E+00,-0.60555E+00,-0.60614E+00,-0.60673E+00,& - -0.60732E+00,-0.60790E+00,-0.60849E+00,-0.60907E+00,-0.60965E+00,& - -0.61023E+00,-0.61081E+00,-0.61139E+00,-0.61197E+00,-0.61254E+00,& - -0.61312E+00,-0.61369E+00,-0.61426E+00,-0.61484E+00,-0.61541E+00,& - -0.61597E+00,-0.61654E+00,-0.61711E+00,-0.61767E+00,-0.61824E+00,& - -0.61880E+00,-0.61936E+00,-0.61993E+00,-0.62049E+00,-0.62104E+00,& - -0.62160E+00,-0.62216E+00,-0.62272E+00,-0.62327E+00,-0.62382E+00,& - -0.62438E+00,-0.62493E+00,-0.62548E+00,-0.62603E+00,-0.62658E+00,& - -0.62712E+00,-0.62767E+00,-0.62822E+00,-0.62876E+00,-0.62930E+00,& - -0.62985E+00,-0.63039E+00,-0.63093E+00,-0.63147E+00,-0.63201E+00,& - -0.63254E+00,-0.63308E+00,-0.63362E+00,-0.63415E+00,-0.63468E+00,& - -0.63522E+00,-0.63575E+00,-0.63628E+00,-0.63681E+00,-0.63734E+00,& - -0.63787E+00,-0.63839E+00,-0.63892E+00,-0.63945E+00,-0.63997E+00,& - -0.64049E+00,-0.64102E+00,-0.64154E+00,-0.64206E+00,-0.64258E+00,& - -0.64310E+00,-0.64362E+00,-0.64413E+00,-0.64465E+00,-0.64516E+00,& - -0.64568E+00,-0.64619E+00,-0.64671E+00,-0.64722E+00,-0.64773E+00,& - -0.64824E+00,-0.64875E+00,-0.64926E+00,-0.64977E+00,-0.65027E+00,& - -0.65078E+00,-0.65129E+00,-0.65179E+00,-0.65229E+00,-0.65280E+00,& - -0.65330E+00,-0.65380E+00,-0.65430E+00,-0.65480E+00,-0.65530E+00,& - -0.65580E+00,-0.65630E+00,-0.65679E+00,-0.65729E+00,-0.65778E+00/ - - DATA (BNC03M (IA),IA=401,500)/ & - -0.65828E+00,-0.65877E+00,-0.65926E+00,-0.65976E+00,-0.66025E+00,& - -0.66074E+00,-0.66123E+00,-0.66172E+00,-0.66221E+00,-0.66269E+00,& - -0.66318E+00,-0.66367E+00,-0.66415E+00,-0.66464E+00,-0.66512E+00,& - -0.66560E+00,-0.66609E+00,-0.66657E+00,-0.66705E+00,-0.66753E+00,& - -0.66801E+00,-0.66849E+00,-0.66897E+00,-0.66944E+00,-0.66992E+00,& - -0.67040E+00,-0.67087E+00,-0.67135E+00,-0.67182E+00,-0.67229E+00,& - -0.67277E+00,-0.67324E+00,-0.67371E+00,-0.67418E+00,-0.67465E+00,& - -0.67512E+00,-0.67559E+00,-0.67606E+00,-0.67652E+00,-0.67699E+00,& - -0.67746E+00,-0.67792E+00,-0.67839E+00,-0.67885E+00,-0.67931E+00,& - -0.67978E+00,-0.68024E+00,-0.68070E+00,-0.68116E+00,-0.68162E+00,& - -0.68208E+00,-0.68254E+00,-0.68300E+00,-0.68346E+00,-0.68391E+00,& - -0.68437E+00,-0.68483E+00,-0.68528E+00,-0.68574E+00,-0.68619E+00,& - -0.68664E+00,-0.68710E+00,-0.68755E+00,-0.68800E+00,-0.68845E+00,& - -0.68890E+00,-0.68935E+00,-0.68980E+00,-0.69025E+00,-0.69070E+00,& - -0.69115E+00,-0.69159E+00,-0.69204E+00,-0.69249E+00,-0.69293E+00,& - -0.69338E+00,-0.69382E+00,-0.69426E+00,-0.69471E+00,-0.69515E+00,& - -0.69559E+00,-0.69603E+00,-0.69647E+00,-0.69691E+00,-0.69735E+00,& - -0.69779E+00,-0.69823E+00,-0.69867E+00,-0.69911E+00,-0.69954E+00,& - -0.69998E+00,-0.70042E+00,-0.70085E+00,-0.70129E+00,-0.70172E+00,& - -0.70216E+00,-0.70259E+00,-0.70302E+00,-0.70345E+00,-0.70389E+00/ - - DATA (BNC03M (IA),IA=501,600)/ & - -0.70432E+00,-0.70475E+00,-0.70518E+00,-0.70561E+00,-0.70604E+00,& - -0.70646E+00,-0.70689E+00,-0.70732E+00,-0.70775E+00,-0.70817E+00,& - -0.70860E+00,-0.70903E+00,-0.70945E+00,-0.70987E+00,-0.71030E+00,& - -0.71072E+00,-0.71115E+00,-0.71157E+00,-0.71199E+00,-0.71241E+00,& - -0.71283E+00,-0.71325E+00,-0.71367E+00,-0.71409E+00,-0.71451E+00,& - -0.71493E+00,-0.71535E+00,-0.71577E+00,-0.71618E+00,-0.71660E+00,& - -0.71702E+00,-0.71743E+00,-0.71785E+00,-0.71826E+00,-0.71868E+00,& - -0.71909E+00,-0.71951E+00,-0.71992E+00,-0.72033E+00,-0.72074E+00,& - -0.72116E+00,-0.72157E+00,-0.72198E+00,-0.72239E+00,-0.72280E+00,& - -0.72321E+00,-0.72362E+00,-0.72403E+00,-0.72443E+00,-0.72484E+00,& - -0.72525E+00,-0.72566E+00,-0.72606E+00,-0.72647E+00,-0.72687E+00,& - -0.72728E+00,-0.72768E+00,-0.72809E+00,-0.72849E+00,-0.72890E+00,& - -0.72930E+00,-0.72970E+00,-0.73010E+00,-0.73050E+00,-0.73091E+00,& - -0.73131E+00,-0.73171E+00,-0.73211E+00,-0.73251E+00,-0.73291E+00,& - -0.73330E+00,-0.73370E+00,-0.73410E+00,-0.73450E+00,-0.73490E+00,& - -0.73529E+00,-0.73569E+00,-0.73609E+00,-0.73648E+00,-0.73688E+00,& - -0.73727E+00,-0.73766E+00,-0.73806E+00,-0.73845E+00,-0.73885E+00,& - -0.73924E+00,-0.73963E+00,-0.74002E+00,-0.74041E+00,-0.74081E+00,& - -0.74120E+00,-0.74159E+00,-0.74198E+00,-0.74237E+00,-0.74276E+00,& - -0.74314E+00,-0.74353E+00,-0.74392E+00,-0.74431E+00,-0.74576E+00/ - - DATA (BNC03M (IA),IA=601,700)/ & - -0.74893E+00,-0.75275E+00,-0.75652E+00,-0.76027E+00,-0.76398E+00,& - -0.76765E+00,-0.77130E+00,-0.77492E+00,-0.77850E+00,-0.78206E+00,& - -0.78558E+00,-0.78908E+00,-0.79256E+00,-0.79600E+00,-0.79942E+00,& - -0.80282E+00,-0.80619E+00,-0.80954E+00,-0.81286E+00,-0.81616E+00,& - -0.81944E+00,-0.82270E+00,-0.82594E+00,-0.82915E+00,-0.83235E+00,& - -0.83552E+00,-0.83868E+00,-0.84181E+00,-0.84493E+00,-0.84803E+00,& - -0.85111E+00,-0.85417E+00,-0.85722E+00,-0.86025E+00,-0.86326E+00,& - -0.86626E+00,-0.86924E+00,-0.87221E+00,-0.87515E+00,-0.87809E+00,& - -0.88101E+00,-0.88391E+00,-0.88681E+00,-0.88968E+00,-0.89255E+00,& - -0.89540E+00,-0.89823E+00,-0.90106E+00,-0.90387E+00,-0.90666E+00,& - -0.90945E+00,-0.91222E+00,-0.91499E+00,-0.91773E+00,-0.92047E+00,& - -0.92320E+00,-0.92592E+00,-0.92862E+00,-0.93131E+00,-0.93400E+00,& - -0.93667E+00,-0.93933E+00,-0.94198E+00,-0.94462E+00,-0.94726E+00,& - -0.94988E+00,-0.95249E+00,-0.95509E+00,-0.95769E+00,-0.96027E+00,& - -0.96285E+00,-0.96541E+00,-0.96797E+00,-0.97052E+00,-0.97306E+00,& - -0.97559E+00,-0.97812E+00,-0.98063E+00,-0.98314E+00,-0.98564E+00,& - -0.98813E+00,-0.99062E+00,-0.99309E+00,-0.99556E+00,-0.99802E+00,& - -0.10005E+01,-0.10029E+01,-0.10054E+01,-0.10078E+01,-0.10102E+01,& - -0.10126E+01,-0.10150E+01,-0.10175E+01,-0.10198E+01,-0.10222E+01,& - -0.10246E+01,-0.10270E+01,-0.10294E+01,-0.10317E+01,-0.10341E+01/ - - DATA (BNC03M(IA),IA=701,741)/ & - -0.10365E+01,-0.10388E+01,-0.10411E+01,-0.10435E+01,-0.10458E+01,& - -0.10481E+01,-0.10505E+01,-0.10528E+01,-0.10551E+01,-0.10574E+01,& - -0.10597E+01,-0.10620E+01,-0.10642E+01,-0.10665E+01,-0.10688E+01,& - -0.10711E+01,-0.10733E+01,-0.10756E+01,-0.10778E+01,-0.10801E+01,& - -0.10823E+01,-0.10846E+01,-0.10868E+01,-0.10890E+01,-0.10913E+01,& - -0.10935E+01,-0.10957E+01,-0.10979E+01,-0.11001E+01,-0.11023E+01,& - -0.11045E+01,-0.11067E+01,-0.11089E+01,-0.11111E+01,-0.11133E+01,& - -0.11154E+01,-0.11176E+01,-0.11198E+01,-0.11219E+01,-0.11241E+01,& - -0.11263E+01 / -! -! ** (NH4)2SO4 -! - DATA (BNC04M (IA),IA= 1,100)/ & - -0.10581E+00,-0.19334E+00,-0.25539E+00,-0.29790E+00,-0.33085E+00,& - -0.35796E+00,-0.38111E+00,-0.40135E+00,-0.41938E+00,-0.43565E+00,& - -0.45050E+00,-0.46416E+00,-0.47682E+00,-0.48862E+00,-0.49969E+00,& - -0.51010E+00,-0.51994E+00,-0.52928E+00,-0.53815E+00,-0.54662E+00,& - -0.55471E+00,-0.56247E+00,-0.56992E+00,-0.57708E+00,-0.58397E+00,& - -0.59063E+00,-0.59706E+00,-0.60328E+00,-0.60931E+00,-0.61515E+00,& - -0.62082E+00,-0.62634E+00,-0.63169E+00,-0.63691E+00,-0.64199E+00,& - -0.64694E+00,-0.65178E+00,-0.65649E+00,-0.66110E+00,-0.66560E+00,& - -0.67000E+00,-0.67431E+00,-0.67853E+00,-0.68266E+00,-0.68670E+00,& - -0.69067E+00,-0.69456E+00,-0.69838E+00,-0.70212E+00,-0.70580E+00,& - -0.70942E+00,-0.71297E+00,-0.71646E+00,-0.71989E+00,-0.72326E+00,& - -0.72659E+00,-0.72986E+00,-0.73308E+00,-0.73625E+00,-0.73937E+00,& - -0.74245E+00,-0.74549E+00,-0.74848E+00,-0.75143E+00,-0.75435E+00,& - -0.75722E+00,-0.76006E+00,-0.76287E+00,-0.76564E+00,-0.76837E+00,& - -0.77108E+00,-0.77375E+00,-0.77640E+00,-0.77901E+00,-0.78160E+00,& - -0.78416E+00,-0.78670E+00,-0.78921E+00,-0.79169E+00,-0.79415E+00,& - -0.79659E+00,-0.79901E+00,-0.80140E+00,-0.80378E+00,-0.80613E+00,& - -0.80847E+00,-0.81078E+00,-0.81308E+00,-0.81536E+00,-0.81762E+00,& - -0.81986E+00,-0.82209E+00,-0.82430E+00,-0.82649E+00,-0.82867E+00,& - -0.83083E+00,-0.83298E+00,-0.83512E+00,-0.83724E+00,-0.83934E+00/ - - DATA (BNC04M (IA),IA=101,200)/ & - -0.84143E+00,-0.84351E+00,-0.84558E+00,-0.84763E+00,-0.84967E+00,& - -0.85169E+00,-0.85371E+00,-0.85571E+00,-0.85770E+00,-0.85967E+00,& - -0.86164E+00,-0.86359E+00,-0.86553E+00,-0.86746E+00,-0.86938E+00,& - -0.87129E+00,-0.87319E+00,-0.87507E+00,-0.87695E+00,-0.87881E+00,& - -0.88061E+00,-0.88246E+00,-0.88430E+00,-0.88612E+00,-0.88794E+00,& - -0.88975E+00,-0.89154E+00,-0.89333E+00,-0.89510E+00,-0.89687E+00,& - -0.89862E+00,-0.90037E+00,-0.90211E+00,-0.90383E+00,-0.90555E+00,& - -0.90726E+00,-0.90896E+00,-0.91065E+00,-0.91233E+00,-0.91401E+00,& - -0.91567E+00,-0.91733E+00,-0.91897E+00,-0.92061E+00,-0.92225E+00,& - -0.92387E+00,-0.92549E+00,-0.92710E+00,-0.92870E+00,-0.93029E+00,& - -0.93188E+00,-0.93345E+00,-0.93502E+00,-0.93659E+00,-0.93814E+00,& - -0.93969E+00,-0.94124E+00,-0.94277E+00,-0.94430E+00,-0.94582E+00,& - -0.94734E+00,-0.94885E+00,-0.95035E+00,-0.95185E+00,-0.95334E+00,& - -0.95482E+00,-0.95630E+00,-0.95777E+00,-0.95923E+00,-0.96069E+00,& - -0.96215E+00,-0.96359E+00,-0.96504E+00,-0.96647E+00,-0.96790E+00,& - -0.96933E+00,-0.97075E+00,-0.97216E+00,-0.97357E+00,-0.97497E+00,& - -0.97637E+00,-0.97776E+00,-0.97915E+00,-0.98053E+00,-0.98190E+00,& - -0.98327E+00,-0.98464E+00,-0.98600E+00,-0.98736E+00,-0.98871E+00,& - -0.99006E+00,-0.99140E+00,-0.99274E+00,-0.99407E+00,-0.99540E+00,& - -0.99672E+00,-0.99804E+00,-0.99935E+00,-0.10007E+01,-0.10020E+01/ - - DATA (BNC04M (IA),IA=201,300)/ & - -0.10033E+01,-0.10046E+01,-0.10059E+01,-0.10071E+01,-0.10084E+01,& - -0.10097E+01,-0.10110E+01,-0.10123E+01,-0.10135E+01,-0.10148E+01,& - -0.10160E+01,-0.10173E+01,-0.10186E+01,-0.10198E+01,-0.10210E+01,& - -0.10223E+01,-0.10235E+01,-0.10248E+01,-0.10260E+01,-0.10272E+01,& - -0.10284E+01,-0.10296E+01,-0.10309E+01,-0.10321E+01,-0.10333E+01,& - -0.10345E+01,-0.10357E+01,-0.10369E+01,-0.10381E+01,-0.10393E+01,& - -0.10404E+01,-0.10416E+01,-0.10428E+01,-0.10440E+01,-0.10451E+01,& - -0.10463E+01,-0.10475E+01,-0.10486E+01,-0.10498E+01,-0.10510E+01,& - -0.10521E+01,-0.10533E+01,-0.10544E+01,-0.10556E+01,-0.10567E+01,& - -0.10578E+01,-0.10590E+01,-0.10601E+01,-0.10612E+01,-0.10624E+01,& - -0.10635E+01,-0.10646E+01,-0.10657E+01,-0.10668E+01,-0.10679E+01,& - -0.10690E+01,-0.10702E+01,-0.10713E+01,-0.10724E+01,-0.10735E+01,& - -0.10745E+01,-0.10756E+01,-0.10767E+01,-0.10778E+01,-0.10789E+01,& - -0.10800E+01,-0.10811E+01,-0.10821E+01,-0.10832E+01,-0.10843E+01,& - -0.10853E+01,-0.10864E+01,-0.10875E+01,-0.10885E+01,-0.10896E+01,& - -0.10907E+01,-0.10917E+01,-0.10928E+01,-0.10938E+01,-0.10949E+01,& - -0.10959E+01,-0.10969E+01,-0.10980E+01,-0.10990E+01,-0.11001E+01,& - -0.11011E+01,-0.11021E+01,-0.11031E+01,-0.11042E+01,-0.11052E+01,& - -0.11062E+01,-0.11072E+01,-0.11083E+01,-0.11093E+01,-0.11103E+01,& - -0.11113E+01,-0.11123E+01,-0.11133E+01,-0.11143E+01,-0.11153E+01/ - - DATA (BNC04M (IA),IA=301,400)/ & - -0.11163E+01,-0.11173E+01,-0.11183E+01,-0.11193E+01,-0.11203E+01,& - -0.11213E+01,-0.11223E+01,-0.11232E+01,-0.11242E+01,-0.11252E+01,& - -0.11262E+01,-0.11272E+01,-0.11281E+01,-0.11291E+01,-0.11301E+01,& - -0.11311E+01,-0.11320E+01,-0.11330E+01,-0.11340E+01,-0.11349E+01,& - -0.11359E+01,-0.11368E+01,-0.11378E+01,-0.11388E+01,-0.11397E+01,& - -0.11407E+01,-0.11416E+01,-0.11426E+01,-0.11435E+01,-0.11444E+01,& - -0.11454E+01,-0.11463E+01,-0.11473E+01,-0.11482E+01,-0.11491E+01,& - -0.11501E+01,-0.11510E+01,-0.11519E+01,-0.11529E+01,-0.11538E+01,& - -0.11547E+01,-0.11556E+01,-0.11566E+01,-0.11575E+01,-0.11584E+01,& - -0.11593E+01,-0.11602E+01,-0.11612E+01,-0.11621E+01,-0.11630E+01,& - -0.11639E+01,-0.11648E+01,-0.11657E+01,-0.11666E+01,-0.11675E+01,& - -0.11684E+01,-0.11693E+01,-0.11702E+01,-0.11711E+01,-0.11720E+01,& - -0.11729E+01,-0.11738E+01,-0.11747E+01,-0.11756E+01,-0.11764E+01,& - -0.11773E+01,-0.11782E+01,-0.11791E+01,-0.11800E+01,-0.11809E+01,& - -0.11817E+01,-0.11826E+01,-0.11835E+01,-0.11844E+01,-0.11852E+01,& - -0.11861E+01,-0.11870E+01,-0.11879E+01,-0.11887E+01,-0.11896E+01,& - -0.11905E+01,-0.11913E+01,-0.11922E+01,-0.11930E+01,-0.11939E+01,& - -0.11948E+01,-0.11956E+01,-0.11965E+01,-0.11973E+01,-0.11982E+01,& - -0.11990E+01,-0.11999E+01,-0.12007E+01,-0.12016E+01,-0.12024E+01,& - -0.12033E+01,-0.12041E+01,-0.12050E+01,-0.12058E+01,-0.12067E+01/ - - DATA (BNC04M (IA),IA=401,500)/ & - -0.12075E+01,-0.12083E+01,-0.12092E+01,-0.12100E+01,-0.12108E+01,& - -0.12117E+01,-0.12125E+01,-0.12133E+01,-0.12142E+01,-0.12150E+01,& - -0.12158E+01,-0.12166E+01,-0.12175E+01,-0.12183E+01,-0.12191E+01,& - -0.12199E+01,-0.12208E+01,-0.12216E+01,-0.12224E+01,-0.12232E+01,& - -0.12240E+01,-0.12248E+01,-0.12257E+01,-0.12265E+01,-0.12273E+01,& - -0.12281E+01,-0.12289E+01,-0.12297E+01,-0.12305E+01,-0.12313E+01,& - -0.12321E+01,-0.12329E+01,-0.12337E+01,-0.12345E+01,-0.12353E+01,& - -0.12361E+01,-0.12369E+01,-0.12377E+01,-0.12385E+01,-0.12393E+01,& - -0.12401E+01,-0.12409E+01,-0.12417E+01,-0.12425E+01,-0.12433E+01,& - -0.12441E+01,-0.12449E+01,-0.12456E+01,-0.12464E+01,-0.12472E+01,& - -0.12480E+01,-0.12488E+01,-0.12496E+01,-0.12503E+01,-0.12511E+01,& - -0.12519E+01,-0.12527E+01,-0.12535E+01,-0.12542E+01,-0.12550E+01,& - -0.12558E+01,-0.12566E+01,-0.12573E+01,-0.12581E+01,-0.12589E+01,& - -0.12596E+01,-0.12604E+01,-0.12612E+01,-0.12619E+01,-0.12627E+01,& - -0.12635E+01,-0.12642E+01,-0.12650E+01,-0.12658E+01,-0.12665E+01,& - -0.12673E+01,-0.12680E+01,-0.12688E+01,-0.12696E+01,-0.12703E+01,& - -0.12711E+01,-0.12718E+01,-0.12726E+01,-0.12733E+01,-0.12741E+01,& - -0.12748E+01,-0.12756E+01,-0.12763E+01,-0.12771E+01,-0.12778E+01,& - -0.12786E+01,-0.12793E+01,-0.12801E+01,-0.12808E+01,-0.12816E+01,& - -0.12823E+01,-0.12830E+01,-0.12838E+01,-0.12845E+01,-0.12853E+01/ - - DATA (BNC04M (IA),IA=501,600)/ & - -0.12860E+01,-0.12867E+01,-0.12875E+01,-0.12882E+01,-0.12890E+01,& - -0.12897E+01,-0.12904E+01,-0.12912E+01,-0.12919E+01,-0.12926E+01,& - -0.12933E+01,-0.12941E+01,-0.12948E+01,-0.12955E+01,-0.12963E+01,& - -0.12970E+01,-0.12977E+01,-0.12984E+01,-0.12992E+01,-0.12999E+01,& - -0.13006E+01,-0.13013E+01,-0.13021E+01,-0.13028E+01,-0.13035E+01,& - -0.13042E+01,-0.13049E+01,-0.13057E+01,-0.13064E+01,-0.13071E+01,& - -0.13078E+01,-0.13085E+01,-0.13092E+01,-0.13099E+01,-0.13107E+01,& - -0.13114E+01,-0.13121E+01,-0.13128E+01,-0.13135E+01,-0.13142E+01,& - -0.13149E+01,-0.13156E+01,-0.13163E+01,-0.13170E+01,-0.13177E+01,& - -0.13184E+01,-0.13191E+01,-0.13198E+01,-0.13206E+01,-0.13213E+01,& - -0.13220E+01,-0.13227E+01,-0.13234E+01,-0.13241E+01,-0.13248E+01,& - -0.13254E+01,-0.13261E+01,-0.13268E+01,-0.13275E+01,-0.13282E+01,& - -0.13289E+01,-0.13296E+01,-0.13303E+01,-0.13310E+01,-0.13317E+01,& - -0.13324E+01,-0.13331E+01,-0.13338E+01,-0.13345E+01,-0.13351E+01,& - -0.13358E+01,-0.13365E+01,-0.13372E+01,-0.13379E+01,-0.13386E+01,& - -0.13393E+01,-0.13399E+01,-0.13406E+01,-0.13413E+01,-0.13420E+01,& - -0.13427E+01,-0.13434E+01,-0.13440E+01,-0.13447E+01,-0.13454E+01,& - -0.13461E+01,-0.13467E+01,-0.13474E+01,-0.13481E+01,-0.13488E+01,& - -0.13495E+01,-0.13501E+01,-0.13508E+01,-0.13515E+01,-0.13521E+01,& - -0.13528E+01,-0.13535E+01,-0.13542E+01,-0.13548E+01,-0.13573E+01/ - - DATA (BNC04M (IA),IA=601,700)/ & - -0.13628E+01,-0.13694E+01,-0.13760E+01,-0.13825E+01,-0.13889E+01,& - -0.13953E+01,-0.14016E+01,-0.14079E+01,-0.14142E+01,-0.14204E+01,& - -0.14265E+01,-0.14327E+01,-0.14387E+01,-0.14448E+01,-0.14507E+01,& - -0.14567E+01,-0.14626E+01,-0.14685E+01,-0.14743E+01,-0.14801E+01,& - -0.14859E+01,-0.14916E+01,-0.14973E+01,-0.15030E+01,-0.15087E+01,& - -0.15143E+01,-0.15198E+01,-0.15254E+01,-0.15309E+01,-0.15364E+01,& - -0.15419E+01,-0.15473E+01,-0.15527E+01,-0.15581E+01,-0.15635E+01,& - -0.15688E+01,-0.15741E+01,-0.15794E+01,-0.15846E+01,-0.15899E+01,& - -0.15951E+01,-0.16003E+01,-0.16055E+01,-0.16106E+01,-0.16157E+01,& - -0.16208E+01,-0.16259E+01,-0.16310E+01,-0.16360E+01,-0.16411E+01,& - -0.16461E+01,-0.16511E+01,-0.16560E+01,-0.16610E+01,-0.16659E+01,& - -0.16708E+01,-0.16757E+01,-0.16806E+01,-0.16855E+01,-0.16903E+01,& - -0.16952E+01,-0.17000E+01,-0.17048E+01,-0.17096E+01,-0.17143E+01,& - -0.17191E+01,-0.17238E+01,-0.17285E+01,-0.17333E+01,-0.17379E+01,& - -0.17426E+01,-0.17473E+01,-0.17520E+01,-0.17566E+01,-0.17612E+01,& - -0.17658E+01,-0.17704E+01,-0.17750E+01,-0.17796E+01,-0.17842E+01,& - -0.17887E+01,-0.17933E+01,-0.17978E+01,-0.18023E+01,-0.18068E+01,& - -0.18113E+01,-0.18158E+01,-0.18203E+01,-0.18247E+01,-0.18292E+01,& - -0.18336E+01,-0.18380E+01,-0.18425E+01,-0.18469E+01,-0.18513E+01,& - -0.18556E+01,-0.18600E+01,-0.18644E+01,-0.18687E+01,-0.18731E+01/ - - DATA (BNC04M(IA),IA=701,741)/ & - -0.18774E+01,-0.18818E+01,-0.18861E+01,-0.18904E+01,-0.18947E+01,& - -0.18990E+01,-0.19033E+01,-0.19075E+01,-0.19118E+01,-0.19161E+01,& - -0.19203E+01,-0.19245E+01,-0.19288E+01,-0.19330E+01,-0.19372E+01,& - -0.19414E+01,-0.19456E+01,-0.19498E+01,-0.19540E+01,-0.19582E+01,& - -0.19623E+01,-0.19665E+01,-0.19707E+01,-0.19748E+01,-0.19789E+01,& - -0.19831E+01,-0.19872E+01,-0.19913E+01,-0.19954E+01,-0.19995E+01,& - -0.20036E+01,-0.20077E+01,-0.20118E+01,-0.20159E+01,-0.20199E+01,& - -0.20240E+01,-0.20280E+01,-0.20321E+01,-0.20361E+01,-0.20402E+01,& - -0.20442E+01 / -! -! ** NH4NO3 -! - DATA (BNC05M (IA),IA= 1,100)/ & - -0.53657E-01,-0.99475E-01,-0.13304E+00,-0.15671E+00,-0.17551E+00,& - -0.19133E+00,-0.20511E+00,-0.21739E+00,-0.22852E+00,-0.23874E+00,& - -0.24821E+00,-0.25706E+00,-0.26538E+00,-0.27325E+00,-0.28072E+00,& - -0.28785E+00,-0.29466E+00,-0.30120E+00,-0.30749E+00,-0.31356E+00,& - -0.31941E+00,-0.32508E+00,-0.33057E+00,-0.33590E+00,-0.34108E+00,& - -0.34612E+00,-0.35103E+00,-0.35582E+00,-0.36049E+00,-0.36505E+00,& - -0.36951E+00,-0.37386E+00,-0.37813E+00,-0.38230E+00,-0.38639E+00,& - -0.39040E+00,-0.39433E+00,-0.39818E+00,-0.40197E+00,-0.40568E+00,& - -0.40933E+00,-0.41291E+00,-0.41643E+00,-0.41989E+00,-0.42330E+00,& - -0.42664E+00,-0.42994E+00,-0.43318E+00,-0.43637E+00,-0.43952E+00,& - -0.44261E+00,-0.44566E+00,-0.44867E+00,-0.45164E+00,-0.45456E+00,& - -0.45744E+00,-0.46029E+00,-0.46310E+00,-0.46587E+00,-0.46861E+00,& - -0.47132E+00,-0.47400E+00,-0.47664E+00,-0.47926E+00,-0.48184E+00,& - -0.48440E+00,-0.48694E+00,-0.48945E+00,-0.49193E+00,-0.49440E+00,& - -0.49684E+00,-0.49926E+00,-0.50166E+00,-0.50404E+00,-0.50640E+00,& - -0.50875E+00,-0.51108E+00,-0.51339E+00,-0.51569E+00,-0.51797E+00,& - -0.52024E+00,-0.52250E+00,-0.52474E+00,-0.52697E+00,-0.52919E+00,& - -0.53140E+00,-0.53360E+00,-0.53579E+00,-0.53797E+00,-0.54014E+00,& - -0.54229E+00,-0.54444E+00,-0.54659E+00,-0.54872E+00,-0.55084E+00,& - -0.55296E+00,-0.55507E+00,-0.55717E+00,-0.55926E+00,-0.56135E+00/ - - DATA (BNC05M (IA),IA=101,200)/ & - -0.56342E+00,-0.56549E+00,-0.56755E+00,-0.56961E+00,-0.57165E+00,& - -0.57369E+00,-0.57572E+00,-0.57775E+00,-0.57976E+00,-0.58177E+00,& - -0.58377E+00,-0.58576E+00,-0.58774E+00,-0.58972E+00,-0.59169E+00,& - -0.59364E+00,-0.59560E+00,-0.59754E+00,-0.59947E+00,-0.60140E+00,& - -0.60319E+00,-0.60512E+00,-0.60703E+00,-0.60894E+00,-0.61083E+00,& - -0.61272E+00,-0.61459E+00,-0.61646E+00,-0.61832E+00,-0.62017E+00,& - -0.62201E+00,-0.62384E+00,-0.62566E+00,-0.62748E+00,-0.62928E+00,& - -0.63108E+00,-0.63287E+00,-0.63465E+00,-0.63642E+00,-0.63819E+00,& - -0.63994E+00,-0.64169E+00,-0.64343E+00,-0.64516E+00,-0.64689E+00,& - -0.64860E+00,-0.65031E+00,-0.65201E+00,-0.65371E+00,-0.65539E+00,& - -0.65707E+00,-0.65875E+00,-0.66041E+00,-0.66207E+00,-0.66372E+00,& - -0.66536E+00,-0.66700E+00,-0.66863E+00,-0.67025E+00,-0.67187E+00,& - -0.67348E+00,-0.67508E+00,-0.67668E+00,-0.67827E+00,-0.67985E+00,& - -0.68143E+00,-0.68300E+00,-0.68456E+00,-0.68612E+00,-0.68767E+00,& - -0.68922E+00,-0.69076E+00,-0.69229E+00,-0.69382E+00,-0.69534E+00,& - -0.69686E+00,-0.69837E+00,-0.69987E+00,-0.70137E+00,-0.70286E+00,& - -0.70435E+00,-0.70583E+00,-0.70731E+00,-0.70878E+00,-0.71024E+00,& - -0.71170E+00,-0.71316E+00,-0.71460E+00,-0.71605E+00,-0.71749E+00,& - -0.71892E+00,-0.72035E+00,-0.72177E+00,-0.72319E+00,-0.72460E+00,& - -0.72600E+00,-0.72741E+00,-0.72880E+00,-0.73020E+00,-0.73158E+00/ - - DATA (BNC05M (IA),IA=201,300)/ & - -0.73297E+00,-0.73434E+00,-0.73572E+00,-0.73708E+00,-0.73845E+00,& - -0.73980E+00,-0.74116E+00,-0.74251E+00,-0.74385E+00,-0.74519E+00,& - -0.74653E+00,-0.74786E+00,-0.74918E+00,-0.75051E+00,-0.75182E+00,& - -0.75314E+00,-0.75445E+00,-0.75575E+00,-0.75705E+00,-0.75835E+00,& - -0.75964E+00,-0.76092E+00,-0.76221E+00,-0.76349E+00,-0.76476E+00,& - -0.76603E+00,-0.76730E+00,-0.76856E+00,-0.76982E+00,-0.77107E+00,& - -0.77232E+00,-0.77357E+00,-0.77481E+00,-0.77605E+00,-0.77729E+00,& - -0.77852E+00,-0.77974E+00,-0.78097E+00,-0.78219E+00,-0.78340E+00,& - -0.78461E+00,-0.78582E+00,-0.78703E+00,-0.78823E+00,-0.78943E+00,& - -0.79062E+00,-0.79181E+00,-0.79300E+00,-0.79418E+00,-0.79536E+00,& - -0.79653E+00,-0.79771E+00,-0.79887E+00,-0.80004E+00,-0.80120E+00,& - -0.80236E+00,-0.80351E+00,-0.80467E+00,-0.80581E+00,-0.80696E+00,& - -0.80810E+00,-0.80924E+00,-0.81037E+00,-0.81150E+00,-0.81263E+00,& - -0.81376E+00,-0.81488E+00,-0.81600E+00,-0.81711E+00,-0.81823E+00,& - -0.81934E+00,-0.82044E+00,-0.82155E+00,-0.82264E+00,-0.82374E+00,& - -0.82484E+00,-0.82593E+00,-0.82701E+00,-0.82810E+00,-0.82918E+00,& - -0.83026E+00,-0.83133E+00,-0.83241E+00,-0.83348E+00,-0.83454E+00,& - -0.83561E+00,-0.83667E+00,-0.83773E+00,-0.83878E+00,-0.83984E+00,& - -0.84089E+00,-0.84193E+00,-0.84298E+00,-0.84402E+00,-0.84506E+00,& - -0.84609E+00,-0.84713E+00,-0.84816E+00,-0.84918E+00,-0.85021E+00/ - - DATA (BNC05M (IA),IA=301,400)/ & - -0.85123E+00,-0.85225E+00,-0.85327E+00,-0.85428E+00,-0.85529E+00,& - -0.85630E+00,-0.85731E+00,-0.85831E+00,-0.85932E+00,-0.86031E+00,& - -0.86131E+00,-0.86230E+00,-0.86330E+00,-0.86428E+00,-0.86527E+00,& - -0.86625E+00,-0.86724E+00,-0.86821E+00,-0.86919E+00,-0.87016E+00,& - -0.87114E+00,-0.87210E+00,-0.87307E+00,-0.87404E+00,-0.87500E+00,& - -0.87596E+00,-0.87691E+00,-0.87787E+00,-0.87882E+00,-0.87977E+00,& - -0.88072E+00,-0.88167E+00,-0.88261E+00,-0.88355E+00,-0.88449E+00,& - -0.88542E+00,-0.88636E+00,-0.88729E+00,-0.88822E+00,-0.88915E+00,& - -0.89007E+00,-0.89100E+00,-0.89192E+00,-0.89284E+00,-0.89375E+00,& - -0.89467E+00,-0.89558E+00,-0.89649E+00,-0.89740E+00,-0.89830E+00,& - -0.89921E+00,-0.90011E+00,-0.90101E+00,-0.90191E+00,-0.90280E+00,& - -0.90370E+00,-0.90459E+00,-0.90548E+00,-0.90636E+00,-0.90725E+00,& - -0.90813E+00,-0.90901E+00,-0.90989E+00,-0.91077E+00,-0.91165E+00,& - -0.91252E+00,-0.91339E+00,-0.91426E+00,-0.91513E+00,-0.91599E+00,& - -0.91686E+00,-0.91772E+00,-0.91858E+00,-0.91944E+00,-0.92029E+00,& - -0.92115E+00,-0.92200E+00,-0.92285E+00,-0.92370E+00,-0.92455E+00,& - -0.92539E+00,-0.92623E+00,-0.92707E+00,-0.92791E+00,-0.92875E+00,& - -0.92959E+00,-0.93042E+00,-0.93125E+00,-0.93208E+00,-0.93291E+00,& - -0.93374E+00,-0.93456E+00,-0.93539E+00,-0.93621E+00,-0.93703E+00,& - -0.93785E+00,-0.93866E+00,-0.93948E+00,-0.94029E+00,-0.94110E+00/ - - DATA (BNC05M (IA),IA=401,500)/ & - -0.94191E+00,-0.94272E+00,-0.94353E+00,-0.94433E+00,-0.94513E+00,& - -0.94594E+00,-0.94673E+00,-0.94753E+00,-0.94833E+00,-0.94912E+00,& - -0.94992E+00,-0.95071E+00,-0.95150E+00,-0.95229E+00,-0.95307E+00,& - -0.95386E+00,-0.95464E+00,-0.95542E+00,-0.95620E+00,-0.95698E+00,& - -0.95776E+00,-0.95853E+00,-0.95931E+00,-0.96008E+00,-0.96085E+00,& - -0.96162E+00,-0.96239E+00,-0.96316E+00,-0.96392E+00,-0.96468E+00,& - -0.96545E+00,-0.96621E+00,-0.96696E+00,-0.96772E+00,-0.96848E+00,& - -0.96923E+00,-0.96999E+00,-0.97074E+00,-0.97149E+00,-0.97224E+00,& - -0.97298E+00,-0.97373E+00,-0.97447E+00,-0.97522E+00,-0.97596E+00,& - -0.97670E+00,-0.97744E+00,-0.97817E+00,-0.97891E+00,-0.97964E+00,& - -0.98038E+00,-0.98111E+00,-0.98184E+00,-0.98257E+00,-0.98329E+00,& - -0.98402E+00,-0.98474E+00,-0.98547E+00,-0.98619E+00,-0.98691E+00,& - -0.98763E+00,-0.98835E+00,-0.98906E+00,-0.98978E+00,-0.99049E+00,& - -0.99121E+00,-0.99192E+00,-0.99263E+00,-0.99334E+00,-0.99404E+00,& - -0.99475E+00,-0.99546E+00,-0.99616E+00,-0.99686E+00,-0.99756E+00,& - -0.99826E+00,-0.99896E+00,-0.99966E+00,-0.10004E+01,-0.10011E+01,& - -0.10017E+01,-0.10024E+01,-0.10031E+01,-0.10038E+01,-0.10045E+01,& - -0.10052E+01,-0.10059E+01,-0.10066E+01,-0.10072E+01,-0.10079E+01,& - -0.10086E+01,-0.10093E+01,-0.10100E+01,-0.10106E+01,-0.10113E+01,& - -0.10120E+01,-0.10127E+01,-0.10133E+01,-0.10140E+01,-0.10147E+01/ - - DATA (BNC05M (IA),IA=501,600)/ & - -0.10154E+01,-0.10160E+01,-0.10167E+01,-0.10174E+01,-0.10180E+01,& - -0.10187E+01,-0.10194E+01,-0.10200E+01,-0.10207E+01,-0.10213E+01,& - -0.10220E+01,-0.10227E+01,-0.10233E+01,-0.10240E+01,-0.10246E+01,& - -0.10253E+01,-0.10259E+01,-0.10266E+01,-0.10272E+01,-0.10279E+01,& - -0.10285E+01,-0.10292E+01,-0.10298E+01,-0.10305E+01,-0.10311E+01,& - -0.10317E+01,-0.10324E+01,-0.10330E+01,-0.10337E+01,-0.10343E+01,& - -0.10349E+01,-0.10356E+01,-0.10362E+01,-0.10368E+01,-0.10375E+01,& - -0.10381E+01,-0.10387E+01,-0.10394E+01,-0.10400E+01,-0.10406E+01,& - -0.10412E+01,-0.10419E+01,-0.10425E+01,-0.10431E+01,-0.10437E+01,& - -0.10444E+01,-0.10450E+01,-0.10456E+01,-0.10462E+01,-0.10468E+01,& - -0.10474E+01,-0.10481E+01,-0.10487E+01,-0.10493E+01,-0.10499E+01,& - -0.10505E+01,-0.10511E+01,-0.10517E+01,-0.10523E+01,-0.10530E+01,& - -0.10536E+01,-0.10542E+01,-0.10548E+01,-0.10554E+01,-0.10560E+01,& - -0.10566E+01,-0.10572E+01,-0.10578E+01,-0.10584E+01,-0.10590E+01,& - -0.10596E+01,-0.10602E+01,-0.10608E+01,-0.10614E+01,-0.10620E+01,& - -0.10626E+01,-0.10631E+01,-0.10637E+01,-0.10643E+01,-0.10649E+01,& - -0.10655E+01,-0.10661E+01,-0.10667E+01,-0.10673E+01,-0.10678E+01,& - -0.10684E+01,-0.10690E+01,-0.10696E+01,-0.10702E+01,-0.10708E+01,& - -0.10713E+01,-0.10719E+01,-0.10725E+01,-0.10731E+01,-0.10737E+01,& - -0.10742E+01,-0.10748E+01,-0.10754E+01,-0.10759E+01,-0.10781E+01/ - - DATA (BNC05M (IA),IA=601,700)/ & - -0.10828E+01,-0.10883E+01,-0.10939E+01,-0.10993E+01,-0.11047E+01,& - -0.11099E+01,-0.11152E+01,-0.11203E+01,-0.11254E+01,-0.11304E+01,& - -0.11354E+01,-0.11403E+01,-0.11451E+01,-0.11499E+01,-0.11546E+01,& - -0.11593E+01,-0.11639E+01,-0.11685E+01,-0.11730E+01,-0.11775E+01,& - -0.11819E+01,-0.11863E+01,-0.11906E+01,-0.11949E+01,-0.11991E+01,& - -0.12033E+01,-0.12075E+01,-0.12116E+01,-0.12156E+01,-0.12197E+01,& - -0.12237E+01,-0.12276E+01,-0.12316E+01,-0.12355E+01,-0.12393E+01,& - -0.12431E+01,-0.12469E+01,-0.12507E+01,-0.12544E+01,-0.12581E+01,& - -0.12618E+01,-0.12654E+01,-0.12690E+01,-0.12726E+01,-0.12761E+01,& - -0.12797E+01,-0.12831E+01,-0.12866E+01,-0.12901E+01,-0.12935E+01,& - -0.12969E+01,-0.13002E+01,-0.13036E+01,-0.13069E+01,-0.13102E+01,& - -0.13135E+01,-0.13167E+01,-0.13200E+01,-0.13232E+01,-0.13264E+01,& - -0.13295E+01,-0.13327E+01,-0.13358E+01,-0.13389E+01,-0.13420E+01,& - -0.13451E+01,-0.13481E+01,-0.13512E+01,-0.13542E+01,-0.13572E+01,& - -0.13601E+01,-0.13631E+01,-0.13661E+01,-0.13690E+01,-0.13719E+01,& - -0.13748E+01,-0.13777E+01,-0.13806E+01,-0.13834E+01,-0.13863E+01,& - -0.13891E+01,-0.13919E+01,-0.13947E+01,-0.13975E+01,-0.14002E+01,& - -0.14030E+01,-0.14057E+01,-0.14085E+01,-0.14112E+01,-0.14139E+01,& - -0.14166E+01,-0.14192E+01,-0.14219E+01,-0.14246E+01,-0.14272E+01,& - -0.14298E+01,-0.14325E+01,-0.14351E+01,-0.14377E+01,-0.14402E+01/ - - DATA (BNC05M(IA),IA=701,741)/ & - -0.14428E+01,-0.14454E+01,-0.14479E+01,-0.14505E+01,-0.14530E+01,& - -0.14555E+01,-0.14581E+01,-0.14606E+01,-0.14631E+01,-0.14655E+01,& - -0.14680E+01,-0.14705E+01,-0.14729E+01,-0.14754E+01,-0.14778E+01,& - -0.14803E+01,-0.14827E+01,-0.14851E+01,-0.14875E+01,-0.14899E+01,& - -0.14923E+01,-0.14947E+01,-0.14970E+01,-0.14994E+01,-0.15017E+01,& - -0.15041E+01,-0.15064E+01,-0.15088E+01,-0.15111E+01,-0.15134E+01,& - -0.15157E+01,-0.15180E+01,-0.15203E+01,-0.15226E+01,-0.15249E+01,& - -0.15272E+01,-0.15294E+01,-0.15317E+01,-0.15340E+01,-0.15362E+01,& - -0.15385E+01 / -! -! ** NH4Cl -! - DATA (BNC06M (IA),IA= 1,100)/ & - -0.52099E-01,-0.93686E-01,-0.12205E+00,-0.14078E+00,-0.15483E+00,& - -0.16604E+00,-0.17532E+00,-0.18320E+00,-0.19002E+00,-0.19599E+00,& - -0.20128E+00,-0.20600E+00,-0.21026E+00,-0.21411E+00,-0.21762E+00,& - -0.22082E+00,-0.22376E+00,-0.22646E+00,-0.22896E+00,-0.23127E+00,& - -0.23341E+00,-0.23540E+00,-0.23725E+00,-0.23898E+00,-0.24060E+00,& - -0.24211E+00,-0.24353E+00,-0.24485E+00,-0.24610E+00,-0.24727E+00,& - -0.24837E+00,-0.24941E+00,-0.25039E+00,-0.25131E+00,-0.25218E+00,& - -0.25300E+00,-0.25378E+00,-0.25452E+00,-0.25521E+00,-0.25587E+00,& - -0.25650E+00,-0.25709E+00,-0.25766E+00,-0.25819E+00,-0.25870E+00,& - -0.25918E+00,-0.25963E+00,-0.26007E+00,-0.26048E+00,-0.26088E+00,& - -0.26125E+00,-0.26160E+00,-0.26194E+00,-0.26226E+00,-0.26257E+00,& - -0.26285E+00,-0.26313E+00,-0.26339E+00,-0.26363E+00,-0.26386E+00,& - -0.26408E+00,-0.26429E+00,-0.26448E+00,-0.26466E+00,-0.26483E+00,& - -0.26499E+00,-0.26513E+00,-0.26527E+00,-0.26539E+00,-0.26550E+00,& - -0.26560E+00,-0.26569E+00,-0.26576E+00,-0.26583E+00,-0.26588E+00,& - -0.26593E+00,-0.26596E+00,-0.26598E+00,-0.26600E+00,-0.26600E+00,& - -0.26599E+00,-0.26597E+00,-0.26594E+00,-0.26590E+00,-0.26584E+00,& - -0.26578E+00,-0.26571E+00,-0.26563E+00,-0.26553E+00,-0.26543E+00,& - -0.26532E+00,-0.26520E+00,-0.26507E+00,-0.26492E+00,-0.26477E+00,& - -0.26462E+00,-0.26445E+00,-0.26427E+00,-0.26409E+00,-0.26390E+00/ - - DATA (BNC06M (IA),IA=101,200)/ & - -0.26370E+00,-0.26349E+00,-0.26327E+00,-0.26305E+00,-0.26282E+00,& - -0.26258E+00,-0.26234E+00,-0.26209E+00,-0.26184E+00,-0.26158E+00,& - -0.26131E+00,-0.26104E+00,-0.26076E+00,-0.26048E+00,-0.26020E+00,& - -0.25991E+00,-0.25961E+00,-0.25931E+00,-0.25901E+00,-0.25870E+00,& - -0.25848E+00,-0.25816E+00,-0.25783E+00,-0.25751E+00,-0.25718E+00,& - -0.25684E+00,-0.25651E+00,-0.25617E+00,-0.25584E+00,-0.25550E+00,& - -0.25516E+00,-0.25481E+00,-0.25447E+00,-0.25412E+00,-0.25378E+00,& - -0.25343E+00,-0.25308E+00,-0.25273E+00,-0.25237E+00,-0.25202E+00,& - -0.25167E+00,-0.25131E+00,-0.25095E+00,-0.25060E+00,-0.25024E+00,& - -0.24988E+00,-0.24951E+00,-0.24915E+00,-0.24879E+00,-0.24843E+00,& - -0.24806E+00,-0.24770E+00,-0.24733E+00,-0.24696E+00,-0.24659E+00,& - -0.24623E+00,-0.24586E+00,-0.24549E+00,-0.24512E+00,-0.24475E+00,& - -0.24438E+00,-0.24400E+00,-0.24363E+00,-0.24326E+00,-0.24289E+00,& - -0.24251E+00,-0.24214E+00,-0.24176E+00,-0.24139E+00,-0.24101E+00,& - -0.24064E+00,-0.24026E+00,-0.23988E+00,-0.23951E+00,-0.23913E+00,& - -0.23875E+00,-0.23838E+00,-0.23800E+00,-0.23762E+00,-0.23724E+00,& - -0.23687E+00,-0.23649E+00,-0.23611E+00,-0.23573E+00,-0.23535E+00,& - -0.23498E+00,-0.23460E+00,-0.23422E+00,-0.23384E+00,-0.23346E+00,& - -0.23308E+00,-0.23270E+00,-0.23232E+00,-0.23195E+00,-0.23157E+00,& - -0.23119E+00,-0.23081E+00,-0.23043E+00,-0.23005E+00,-0.22968E+00/ - - DATA (BNC06M (IA),IA=201,300)/ & - -0.22930E+00,-0.22892E+00,-0.22854E+00,-0.22816E+00,-0.22779E+00,& - -0.22741E+00,-0.22703E+00,-0.22665E+00,-0.22628E+00,-0.22590E+00,& - -0.22552E+00,-0.22515E+00,-0.22477E+00,-0.22439E+00,-0.22402E+00,& - -0.22364E+00,-0.22327E+00,-0.22289E+00,-0.22252E+00,-0.22214E+00,& - -0.22177E+00,-0.22139E+00,-0.22102E+00,-0.22064E+00,-0.22027E+00,& - -0.21990E+00,-0.21953E+00,-0.21915E+00,-0.21878E+00,-0.21841E+00,& - -0.21804E+00,-0.21767E+00,-0.21729E+00,-0.21692E+00,-0.21655E+00,& - -0.21618E+00,-0.21581E+00,-0.21544E+00,-0.21508E+00,-0.21471E+00,& - -0.21434E+00,-0.21397E+00,-0.21360E+00,-0.21324E+00,-0.21287E+00,& - -0.21250E+00,-0.21214E+00,-0.21177E+00,-0.21141E+00,-0.21104E+00,& - -0.21068E+00,-0.21031E+00,-0.20995E+00,-0.20958E+00,-0.20922E+00,& - -0.20886E+00,-0.20850E+00,-0.20814E+00,-0.20777E+00,-0.20741E+00,& - -0.20705E+00,-0.20669E+00,-0.20633E+00,-0.20597E+00,-0.20561E+00,& - -0.20526E+00,-0.20490E+00,-0.20454E+00,-0.20418E+00,-0.20383E+00,& - -0.20347E+00,-0.20312E+00,-0.20276E+00,-0.20241E+00,-0.20205E+00,& - -0.20170E+00,-0.20134E+00,-0.20099E+00,-0.20064E+00,-0.20029E+00,& - -0.19993E+00,-0.19958E+00,-0.19923E+00,-0.19888E+00,-0.19853E+00,& - -0.19818E+00,-0.19783E+00,-0.19749E+00,-0.19714E+00,-0.19679E+00,& - -0.19644E+00,-0.19610E+00,-0.19575E+00,-0.19541E+00,-0.19506E+00,& - -0.19472E+00,-0.19437E+00,-0.19403E+00,-0.19369E+00,-0.19334E+00/ - - DATA (BNC06M (IA),IA=301,400)/ & - -0.19300E+00,-0.19266E+00,-0.19232E+00,-0.19198E+00,-0.19164E+00,& - -0.19130E+00,-0.19096E+00,-0.19062E+00,-0.19028E+00,-0.18994E+00,& - -0.18961E+00,-0.18927E+00,-0.18893E+00,-0.18860E+00,-0.18826E+00,& - -0.18793E+00,-0.18759E+00,-0.18726E+00,-0.18692E+00,-0.18659E+00,& - -0.18626E+00,-0.18593E+00,-0.18560E+00,-0.18526E+00,-0.18493E+00,& - -0.18460E+00,-0.18427E+00,-0.18395E+00,-0.18362E+00,-0.18329E+00,& - -0.18296E+00,-0.18263E+00,-0.18231E+00,-0.18198E+00,-0.18166E+00,& - -0.18133E+00,-0.18101E+00,-0.18068E+00,-0.18036E+00,-0.18004E+00,& - -0.17971E+00,-0.17939E+00,-0.17907E+00,-0.17875E+00,-0.17843E+00,& - -0.17811E+00,-0.17779E+00,-0.17747E+00,-0.17715E+00,-0.17683E+00,& - -0.17652E+00,-0.17620E+00,-0.17588E+00,-0.17557E+00,-0.17525E+00,& - -0.17493E+00,-0.17462E+00,-0.17431E+00,-0.17399E+00,-0.17368E+00,& - -0.17337E+00,-0.17305E+00,-0.17274E+00,-0.17243E+00,-0.17212E+00,& - -0.17181E+00,-0.17150E+00,-0.17119E+00,-0.17088E+00,-0.17057E+00,& - -0.17027E+00,-0.16996E+00,-0.16965E+00,-0.16934E+00,-0.16904E+00,& - -0.16873E+00,-0.16843E+00,-0.16812E+00,-0.16782E+00,-0.16752E+00,& - -0.16721E+00,-0.16691E+00,-0.16661E+00,-0.16631E+00,-0.16601E+00,& - -0.16571E+00,-0.16540E+00,-0.16511E+00,-0.16481E+00,-0.16451E+00,& - -0.16421E+00,-0.16391E+00,-0.16361E+00,-0.16332E+00,-0.16302E+00,& - -0.16273E+00,-0.16243E+00,-0.16213E+00,-0.16184E+00,-0.16155E+00/ - - DATA (BNC06M (IA),IA=401,500)/ & - -0.16125E+00,-0.16096E+00,-0.16067E+00,-0.16038E+00,-0.16008E+00,& - -0.15979E+00,-0.15950E+00,-0.15921E+00,-0.15892E+00,-0.15863E+00,& - -0.15834E+00,-0.15806E+00,-0.15777E+00,-0.15748E+00,-0.15719E+00,& - -0.15691E+00,-0.15662E+00,-0.15634E+00,-0.15605E+00,-0.15577E+00,& - -0.15548E+00,-0.15520E+00,-0.15492E+00,-0.15463E+00,-0.15435E+00,& - -0.15407E+00,-0.15379E+00,-0.15351E+00,-0.15323E+00,-0.15295E+00,& - -0.15267E+00,-0.15239E+00,-0.15211E+00,-0.15183E+00,-0.15155E+00,& - -0.15127E+00,-0.15100E+00,-0.15072E+00,-0.15045E+00,-0.15017E+00,& - -0.14990E+00,-0.14962E+00,-0.14935E+00,-0.14907E+00,-0.14880E+00,& - -0.14853E+00,-0.14825E+00,-0.14798E+00,-0.14771E+00,-0.14744E+00,& - -0.14717E+00,-0.14690E+00,-0.14663E+00,-0.14636E+00,-0.14609E+00,& - -0.14582E+00,-0.14555E+00,-0.14529E+00,-0.14502E+00,-0.14475E+00,& - -0.14449E+00,-0.14422E+00,-0.14396E+00,-0.14369E+00,-0.14343E+00,& - -0.14316E+00,-0.14290E+00,-0.14264E+00,-0.14237E+00,-0.14211E+00,& - -0.14185E+00,-0.14159E+00,-0.14133E+00,-0.14107E+00,-0.14081E+00,& - -0.14055E+00,-0.14029E+00,-0.14003E+00,-0.13977E+00,-0.13951E+00,& - -0.13925E+00,-0.13900E+00,-0.13874E+00,-0.13848E+00,-0.13823E+00,& - -0.13797E+00,-0.13772E+00,-0.13746E+00,-0.13721E+00,-0.13695E+00,& - -0.13670E+00,-0.13645E+00,-0.13619E+00,-0.13594E+00,-0.13569E+00,& - -0.13544E+00,-0.13519E+00,-0.13494E+00,-0.13469E+00,-0.13444E+00/ - - DATA (BNC06M (IA),IA=501,600)/ & - -0.13419E+00,-0.13394E+00,-0.13369E+00,-0.13344E+00,-0.13319E+00,& - -0.13295E+00,-0.13270E+00,-0.13245E+00,-0.13221E+00,-0.13196E+00,& - -0.13172E+00,-0.13147E+00,-0.13123E+00,-0.13098E+00,-0.13074E+00,& - -0.13050E+00,-0.13025E+00,-0.13001E+00,-0.12977E+00,-0.12953E+00,& - -0.12929E+00,-0.12904E+00,-0.12880E+00,-0.12856E+00,-0.12832E+00,& - -0.12808E+00,-0.12785E+00,-0.12761E+00,-0.12737E+00,-0.12713E+00,& - -0.12689E+00,-0.12666E+00,-0.12642E+00,-0.12618E+00,-0.12595E+00,& - -0.12571E+00,-0.12548E+00,-0.12524E+00,-0.12501E+00,-0.12477E+00,& - -0.12454E+00,-0.12431E+00,-0.12407E+00,-0.12384E+00,-0.12361E+00,& - -0.12338E+00,-0.12315E+00,-0.12292E+00,-0.12269E+00,-0.12246E+00,& - -0.12223E+00,-0.12200E+00,-0.12177E+00,-0.12154E+00,-0.12131E+00,& - -0.12108E+00,-0.12086E+00,-0.12063E+00,-0.12040E+00,-0.12017E+00,& - -0.11995E+00,-0.11972E+00,-0.11950E+00,-0.11927E+00,-0.11905E+00,& - -0.11882E+00,-0.11860E+00,-0.11838E+00,-0.11815E+00,-0.11793E+00,& - -0.11771E+00,-0.11749E+00,-0.11726E+00,-0.11704E+00,-0.11682E+00,& - -0.11660E+00,-0.11638E+00,-0.11616E+00,-0.11594E+00,-0.11572E+00,& - -0.11550E+00,-0.11529E+00,-0.11507E+00,-0.11485E+00,-0.11463E+00,& - -0.11441E+00,-0.11420E+00,-0.11398E+00,-0.11377E+00,-0.11355E+00,& - -0.11333E+00,-0.11312E+00,-0.11291E+00,-0.11269E+00,-0.11248E+00,& - -0.11226E+00,-0.11205E+00,-0.11184E+00,-0.11163E+00,-0.11083E+00/ - - DATA (BNC06M (IA),IA=601,700)/ & - -0.10910E+00,-0.10704E+00,-0.10500E+00,-0.10300E+00,-0.10104E+00,& - -0.99099E-01,-0.97194E-01,-0.95319E-01,-0.93474E-01,-0.91659E-01,& - -0.89872E-01,-0.88115E-01,-0.86385E-01,-0.84682E-01,-0.83007E-01,& - -0.81358E-01,-0.79736E-01,-0.78139E-01,-0.76568E-01,-0.75022E-01,& - -0.73500E-01,-0.72002E-01,-0.70529E-01,-0.69079E-01,-0.67651E-01,& - -0.66247E-01,-0.64865E-01,-0.63505E-01,-0.62167E-01,-0.60850E-01,& - -0.59554E-01,-0.58278E-01,-0.57024E-01,-0.55789E-01,-0.54574E-01,& - -0.53379E-01,-0.52203E-01,-0.51046E-01,-0.49908E-01,-0.48788E-01,& - -0.47686E-01,-0.46602E-01,-0.45536E-01,-0.44487E-01,-0.43456E-01,& - -0.42441E-01,-0.41444E-01,-0.40462E-01,-0.39497E-01,-0.38548E-01,& - -0.37615E-01,-0.36698E-01,-0.35795E-01,-0.34909E-01,-0.34037E-01,& - -0.33180E-01,-0.32337E-01,-0.31509E-01,-0.30696E-01,-0.29896E-01,& - -0.29110E-01,-0.28338E-01,-0.27580E-01,-0.26835E-01,-0.26103E-01,& - -0.25384E-01,-0.24679E-01,-0.23986E-01,-0.23305E-01,-0.22637E-01,& - -0.21981E-01,-0.21338E-01,-0.20706E-01,-0.20086E-01,-0.19479E-01,& - -0.18882E-01,-0.18297E-01,-0.17724E-01,-0.17161E-01,-0.16610E-01,& - -0.16070E-01,-0.15540E-01,-0.15021E-01,-0.14513E-01,-0.14015E-01,& - -0.13528E-01,-0.13050E-01,-0.12583E-01,-0.12126E-01,-0.11679E-01,& - -0.11242E-01,-0.10814E-01,-0.10396E-01,-0.99873E-02,-0.95880E-02,& - -0.91981E-02,-0.88174E-02,-0.84457E-02,-0.80831E-02,-0.77294E-02/ - - DATA (BNC06M(IA),IA=701,741)/ & - -0.73845E-02,-0.70483E-02,-0.67207E-02,-0.64018E-02,-0.60913E-02,& - -0.57891E-02,-0.54953E-02,-0.52096E-02,-0.49322E-02,-0.46628E-02,& - -0.44013E-02,-0.41478E-02,-0.39020E-02,-0.36641E-02,-0.34337E-02,& - -0.32110E-02,-0.29958E-02,-0.27881E-02,-0.25878E-02,-0.23947E-02,& - -0.22090E-02,-0.20303E-02,-0.18589E-02,-0.16944E-02,-0.15369E-02,& - -0.13864E-02,-0.12427E-02,-0.11058E-02,-0.97562E-03,-0.85213E-03,& - -0.73527E-03,-0.62494E-03,-0.52106E-03,-0.42366E-03,-0.33266E-03,& - -0.24793E-03,-0.16948E-03,-0.97253E-04,-0.31242E-04, 0.28753E-04,& - 0.82669E-04 / -! -! ** (2H, SO4) -! - DATA (BNC07M (IA),IA= 1,100)/ & - -0.10557E+00,-0.19245E+00,-0.25372E+00,-0.29547E+00,-0.32770E+00,& - -0.35411E+00,-0.37657E+00,-0.39614E+00,-0.41351E+00,-0.42914E+00,& - -0.44335E+00,-0.45638E+00,-0.46842E+00,-0.47961E+00,-0.49007E+00,& - -0.49989E+00,-0.50915E+00,-0.51790E+00,-0.52620E+00,-0.53409E+00,& - -0.54162E+00,-0.54882E+00,-0.55571E+00,-0.56233E+00,-0.56868E+00,& - -0.57480E+00,-0.58070E+00,-0.58640E+00,-0.59191E+00,-0.59724E+00,& - -0.60240E+00,-0.60741E+00,-0.61227E+00,-0.61699E+00,-0.62158E+00,& - -0.62605E+00,-0.63041E+00,-0.63465E+00,-0.63879E+00,-0.64283E+00,& - -0.64677E+00,-0.65063E+00,-0.65440E+00,-0.65808E+00,-0.66169E+00,& - -0.66522E+00,-0.66869E+00,-0.67208E+00,-0.67540E+00,-0.67867E+00,& - -0.68187E+00,-0.68501E+00,-0.68810E+00,-0.69113E+00,-0.69411E+00,& - -0.69704E+00,-0.69992E+00,-0.70275E+00,-0.70554E+00,-0.70829E+00,& - -0.71099E+00,-0.71365E+00,-0.71628E+00,-0.71886E+00,-0.72141E+00,& - -0.72392E+00,-0.72640E+00,-0.72885E+00,-0.73126E+00,-0.73364E+00,& - -0.73600E+00,-0.73832E+00,-0.74061E+00,-0.74288E+00,-0.74512E+00,& - -0.74733E+00,-0.74952E+00,-0.75169E+00,-0.75383E+00,-0.75594E+00,& - -0.75804E+00,-0.76011E+00,-0.76216E+00,-0.76419E+00,-0.76621E+00,& - -0.76820E+00,-0.77017E+00,-0.77212E+00,-0.77406E+00,-0.77598E+00,& - -0.77788E+00,-0.77976E+00,-0.78163E+00,-0.78348E+00,-0.78532E+00,& - -0.78714E+00,-0.78894E+00,-0.79073E+00,-0.79251E+00,-0.79427E+00/ - - DATA (BNC07M (IA),IA=101,200)/ & - -0.79602E+00,-0.79775E+00,-0.79948E+00,-0.80118E+00,-0.80288E+00,& - -0.80456E+00,-0.80623E+00,-0.80789E+00,-0.80954E+00,-0.81117E+00,& - -0.81280E+00,-0.81441E+00,-0.81601E+00,-0.81760E+00,-0.81918E+00,& - -0.82074E+00,-0.82230E+00,-0.82385E+00,-0.82538E+00,-0.82691E+00,& - -0.82841E+00,-0.82992E+00,-0.83142E+00,-0.83291E+00,-0.83439E+00,& - -0.83586E+00,-0.83732E+00,-0.83877E+00,-0.84022E+00,-0.84165E+00,& - -0.84308E+00,-0.84449E+00,-0.84590E+00,-0.84730E+00,-0.84870E+00,& - -0.85008E+00,-0.85146E+00,-0.85283E+00,-0.85419E+00,-0.85554E+00,& - -0.85689E+00,-0.85823E+00,-0.85956E+00,-0.86088E+00,-0.86220E+00,& - -0.86351E+00,-0.86481E+00,-0.86611E+00,-0.86740E+00,-0.86868E+00,& - -0.86996E+00,-0.87123E+00,-0.87249E+00,-0.87375E+00,-0.87500E+00,& - -0.87625E+00,-0.87749E+00,-0.87872E+00,-0.87995E+00,-0.88117E+00,& - -0.88239E+00,-0.88360E+00,-0.88480E+00,-0.88600E+00,-0.88720E+00,& - -0.88839E+00,-0.88957E+00,-0.89075E+00,-0.89192E+00,-0.89309E+00,& - -0.89425E+00,-0.89541E+00,-0.89656E+00,-0.89771E+00,-0.89885E+00,& - -0.89999E+00,-0.90112E+00,-0.90225E+00,-0.90337E+00,-0.90449E+00,& - -0.90561E+00,-0.90672E+00,-0.90783E+00,-0.90893E+00,-0.91002E+00,& - -0.91112E+00,-0.91221E+00,-0.91329E+00,-0.91437E+00,-0.91545E+00,& - -0.91652E+00,-0.91759E+00,-0.91865E+00,-0.91971E+00,-0.92077E+00,& - -0.92182E+00,-0.92287E+00,-0.92392E+00,-0.92496E+00,-0.92600E+00/ - - DATA (BNC07M (IA),IA=201,300)/ & - -0.92703E+00,-0.92806E+00,-0.92909E+00,-0.93011E+00,-0.93113E+00,& - -0.93215E+00,-0.93316E+00,-0.93417E+00,-0.93518E+00,-0.93618E+00,& - -0.93718E+00,-0.93817E+00,-0.93917E+00,-0.94016E+00,-0.94114E+00,& - -0.94213E+00,-0.94311E+00,-0.94408E+00,-0.94506E+00,-0.94603E+00,& - -0.94700E+00,-0.94796E+00,-0.94892E+00,-0.94988E+00,-0.95084E+00,& - -0.95179E+00,-0.95274E+00,-0.95369E+00,-0.95463E+00,-0.95557E+00,& - -0.95651E+00,-0.95745E+00,-0.95838E+00,-0.95931E+00,-0.96024E+00,& - -0.96117E+00,-0.96209E+00,-0.96301E+00,-0.96393E+00,-0.96484E+00,& - -0.96576E+00,-0.96667E+00,-0.96758E+00,-0.96848E+00,-0.96938E+00,& - -0.97028E+00,-0.97118E+00,-0.97208E+00,-0.97297E+00,-0.97386E+00,& - -0.97475E+00,-0.97563E+00,-0.97652E+00,-0.97740E+00,-0.97828E+00,& - -0.97916E+00,-0.98003E+00,-0.98090E+00,-0.98177E+00,-0.98264E+00,& - -0.98351E+00,-0.98437E+00,-0.98523E+00,-0.98609E+00,-0.98695E+00,& - -0.98780E+00,-0.98866E+00,-0.98951E+00,-0.99036E+00,-0.99120E+00,& - -0.99205E+00,-0.99289E+00,-0.99373E+00,-0.99457E+00,-0.99541E+00,& - -0.99625E+00,-0.99708E+00,-0.99791E+00,-0.99874E+00,-0.99957E+00,& - -0.10004E+01,-0.10012E+01,-0.10020E+01,-0.10029E+01,-0.10037E+01,& - -0.10045E+01,-0.10053E+01,-0.10061E+01,-0.10069E+01,-0.10077E+01,& - -0.10086E+01,-0.10094E+01,-0.10102E+01,-0.10110E+01,-0.10118E+01,& - -0.10126E+01,-0.10134E+01,-0.10142E+01,-0.10150E+01,-0.10157E+01/ - - DATA (BNC07M (IA),IA=301,400)/ & - -0.10165E+01,-0.10173E+01,-0.10181E+01,-0.10189E+01,-0.10197E+01,& - -0.10205E+01,-0.10212E+01,-0.10220E+01,-0.10228E+01,-0.10236E+01,& - -0.10244E+01,-0.10251E+01,-0.10259E+01,-0.10267E+01,-0.10274E+01,& - -0.10282E+01,-0.10290E+01,-0.10297E+01,-0.10305E+01,-0.10313E+01,& - -0.10320E+01,-0.10328E+01,-0.10335E+01,-0.10343E+01,-0.10351E+01,& - -0.10358E+01,-0.10366E+01,-0.10373E+01,-0.10381E+01,-0.10388E+01,& - -0.10396E+01,-0.10403E+01,-0.10410E+01,-0.10418E+01,-0.10425E+01,& - -0.10433E+01,-0.10440E+01,-0.10447E+01,-0.10455E+01,-0.10462E+01,& - -0.10469E+01,-0.10477E+01,-0.10484E+01,-0.10491E+01,-0.10499E+01,& - -0.10506E+01,-0.10513E+01,-0.10520E+01,-0.10528E+01,-0.10535E+01,& - -0.10542E+01,-0.10549E+01,-0.10557E+01,-0.10564E+01,-0.10571E+01,& - -0.10578E+01,-0.10585E+01,-0.10592E+01,-0.10599E+01,-0.10606E+01,& - -0.10614E+01,-0.10621E+01,-0.10628E+01,-0.10635E+01,-0.10642E+01,& - -0.10649E+01,-0.10656E+01,-0.10663E+01,-0.10670E+01,-0.10677E+01,& - -0.10684E+01,-0.10691E+01,-0.10698E+01,-0.10705E+01,-0.10712E+01,& - -0.10719E+01,-0.10726E+01,-0.10733E+01,-0.10739E+01,-0.10746E+01,& - -0.10753E+01,-0.10760E+01,-0.10767E+01,-0.10774E+01,-0.10781E+01,& - -0.10787E+01,-0.10794E+01,-0.10801E+01,-0.10808E+01,-0.10815E+01,& - -0.10821E+01,-0.10828E+01,-0.10835E+01,-0.10842E+01,-0.10848E+01,& - -0.10855E+01,-0.10862E+01,-0.10869E+01,-0.10875E+01,-0.10882E+01/ - - DATA (BNC07M (IA),IA=401,500)/ & - -0.10889E+01,-0.10895E+01,-0.10902E+01,-0.10909E+01,-0.10915E+01,& - -0.10922E+01,-0.10929E+01,-0.10935E+01,-0.10942E+01,-0.10948E+01,& - -0.10955E+01,-0.10962E+01,-0.10968E+01,-0.10975E+01,-0.10981E+01,& - -0.10988E+01,-0.10994E+01,-0.11001E+01,-0.11008E+01,-0.11014E+01,& - -0.11021E+01,-0.11027E+01,-0.11034E+01,-0.11040E+01,-0.11047E+01,& - -0.11053E+01,-0.11059E+01,-0.11066E+01,-0.11072E+01,-0.11079E+01,& - -0.11085E+01,-0.11092E+01,-0.11098E+01,-0.11104E+01,-0.11111E+01,& - -0.11117E+01,-0.11124E+01,-0.11130E+01,-0.11136E+01,-0.11143E+01,& - -0.11149E+01,-0.11155E+01,-0.11162E+01,-0.11168E+01,-0.11174E+01,& - -0.11181E+01,-0.11187E+01,-0.11193E+01,-0.11200E+01,-0.11206E+01,& - -0.11212E+01,-0.11218E+01,-0.11225E+01,-0.11231E+01,-0.11237E+01,& - -0.11243E+01,-0.11250E+01,-0.11256E+01,-0.11262E+01,-0.11268E+01,& - -0.11274E+01,-0.11281E+01,-0.11287E+01,-0.11293E+01,-0.11299E+01,& - -0.11305E+01,-0.11312E+01,-0.11318E+01,-0.11324E+01,-0.11330E+01,& - -0.11336E+01,-0.11342E+01,-0.11348E+01,-0.11355E+01,-0.11361E+01,& - -0.11367E+01,-0.11373E+01,-0.11379E+01,-0.11385E+01,-0.11391E+01,& - -0.11397E+01,-0.11403E+01,-0.11409E+01,-0.11415E+01,-0.11421E+01,& - -0.11427E+01,-0.11433E+01,-0.11439E+01,-0.11445E+01,-0.11451E+01,& - -0.11457E+01,-0.11463E+01,-0.11469E+01,-0.11475E+01,-0.11481E+01,& - -0.11487E+01,-0.11493E+01,-0.11499E+01,-0.11505E+01,-0.11511E+01/ - - DATA (BNC07M (IA),IA=501,600)/ & - -0.11517E+01,-0.11523E+01,-0.11529E+01,-0.11535E+01,-0.11541E+01,& - -0.11547E+01,-0.11553E+01,-0.11559E+01,-0.11565E+01,-0.11570E+01,& - -0.11576E+01,-0.11582E+01,-0.11588E+01,-0.11594E+01,-0.11600E+01,& - -0.11606E+01,-0.11612E+01,-0.11617E+01,-0.11623E+01,-0.11629E+01,& - -0.11635E+01,-0.11641E+01,-0.11647E+01,-0.11652E+01,-0.11658E+01,& - -0.11664E+01,-0.11670E+01,-0.11676E+01,-0.11681E+01,-0.11687E+01,& - -0.11693E+01,-0.11699E+01,-0.11704E+01,-0.11710E+01,-0.11716E+01,& - -0.11722E+01,-0.11728E+01,-0.11733E+01,-0.11739E+01,-0.11745E+01,& - -0.11750E+01,-0.11756E+01,-0.11762E+01,-0.11768E+01,-0.11773E+01,& - -0.11779E+01,-0.11785E+01,-0.11790E+01,-0.11796E+01,-0.11802E+01,& - -0.11807E+01,-0.11813E+01,-0.11819E+01,-0.11824E+01,-0.11830E+01,& - -0.11836E+01,-0.11841E+01,-0.11847E+01,-0.11853E+01,-0.11858E+01,& - -0.11864E+01,-0.11870E+01,-0.11875E+01,-0.11881E+01,-0.11886E+01,& - -0.11892E+01,-0.11898E+01,-0.11903E+01,-0.11909E+01,-0.11914E+01,& - -0.11920E+01,-0.11925E+01,-0.11931E+01,-0.11937E+01,-0.11942E+01,& - -0.11948E+01,-0.11953E+01,-0.11959E+01,-0.11964E+01,-0.11970E+01,& - -0.11975E+01,-0.11981E+01,-0.11987E+01,-0.11992E+01,-0.11998E+01,& - -0.12003E+01,-0.12009E+01,-0.12014E+01,-0.12020E+01,-0.12025E+01,& - -0.12031E+01,-0.12036E+01,-0.12042E+01,-0.12047E+01,-0.12053E+01,& - -0.12058E+01,-0.12063E+01,-0.12069E+01,-0.12074E+01,-0.12095E+01/ - - DATA (BNC07M (IA),IA=601,700)/ & - -0.12140E+01,-0.12193E+01,-0.12247E+01,-0.12300E+01,-0.12353E+01,& - -0.12405E+01,-0.12457E+01,-0.12509E+01,-0.12560E+01,-0.12611E+01,& - -0.12662E+01,-0.12712E+01,-0.12763E+01,-0.12812E+01,-0.12862E+01,& - -0.12911E+01,-0.12960E+01,-0.13009E+01,-0.13058E+01,-0.13106E+01,& - -0.13154E+01,-0.13202E+01,-0.13250E+01,-0.13297E+01,-0.13344E+01,& - -0.13391E+01,-0.13438E+01,-0.13484E+01,-0.13531E+01,-0.13577E+01,& - -0.13623E+01,-0.13669E+01,-0.13714E+01,-0.13760E+01,-0.13805E+01,& - -0.13850E+01,-0.13895E+01,-0.13940E+01,-0.13984E+01,-0.14029E+01,& - -0.14073E+01,-0.14117E+01,-0.14161E+01,-0.14205E+01,-0.14249E+01,& - -0.14292E+01,-0.14336E+01,-0.14379E+01,-0.14422E+01,-0.14465E+01,& - -0.14508E+01,-0.14551E+01,-0.14593E+01,-0.14636E+01,-0.14678E+01,& - -0.14720E+01,-0.14763E+01,-0.14805E+01,-0.14847E+01,-0.14888E+01,& - -0.14930E+01,-0.14972E+01,-0.15013E+01,-0.15055E+01,-0.15096E+01,& - -0.15137E+01,-0.15178E+01,-0.15219E+01,-0.15260E+01,-0.15301E+01,& - -0.15341E+01,-0.15382E+01,-0.15423E+01,-0.15463E+01,-0.15503E+01,& - -0.15544E+01,-0.15584E+01,-0.15624E+01,-0.15664E+01,-0.15704E+01,& - -0.15744E+01,-0.15783E+01,-0.15823E+01,-0.15863E+01,-0.15902E+01,& - -0.15941E+01,-0.15981E+01,-0.16020E+01,-0.16059E+01,-0.16098E+01,& - -0.16138E+01,-0.16176E+01,-0.16215E+01,-0.16254E+01,-0.16293E+01,& - -0.16332E+01,-0.16370E+01,-0.16409E+01,-0.16448E+01,-0.16486E+01/ - - DATA (BNC07M(IA),IA=701,741)/ & - -0.16524E+01,-0.16563E+01,-0.16601E+01,-0.16639E+01,-0.16677E+01,& - -0.16715E+01,-0.16753E+01,-0.16791E+01,-0.16829E+01,-0.16867E+01,& - -0.16905E+01,-0.16943E+01,-0.16980E+01,-0.17018E+01,-0.17055E+01,& - -0.17093E+01,-0.17130E+01,-0.17168E+01,-0.17205E+01,-0.17243E+01,& - -0.17280E+01,-0.17317E+01,-0.17354E+01,-0.17391E+01,-0.17428E+01,& - -0.17465E+01,-0.17502E+01,-0.17539E+01,-0.17576E+01,-0.17613E+01,& - -0.17650E+01,-0.17686E+01,-0.17723E+01,-0.17760E+01,-0.17796E+01,& - -0.17833E+01,-0.17869E+01,-0.17906E+01,-0.17942E+01,-0.17978E+01,& - -0.18015E+01 / -! -! ** (H, HSO4) -! - DATA (BNC08M (IA),IA= 1,100)/ & - -0.49133E-01,-0.83570E-01,-0.10389E+00,-0.11538E+00,-0.12265E+00,& - -0.12736E+00,-0.13032E+00,-0.13201E+00,-0.13270E+00,-0.13259E+00,& - -0.13182E+00,-0.13049E+00,-0.12867E+00,-0.12642E+00,-0.12378E+00,& - -0.12080E+00,-0.11750E+00,-0.11391E+00,-0.11005E+00,-0.10594E+00,& - -0.10160E+00,-0.97035E-01,-0.92266E-01,-0.87301E-01,-0.82151E-01,& - -0.76825E-01,-0.71330E-01,-0.65676E-01,-0.59869E-01,-0.53917E-01,& - -0.47824E-01,-0.41599E-01,-0.35245E-01,-0.28770E-01,-0.22177E-01,& - -0.15472E-01,-0.86592E-02,-0.17436E-02, 0.52706E-02, 0.12379E-01,& - 0.19579E-01, 0.26864E-01, 0.34233E-01, 0.41682E-01, 0.49206E-01,& - 0.56803E-01, 0.64470E-01, 0.72204E-01, 0.80002E-01, 0.87862E-01,& - 0.95780E-01, 0.10376E+00, 0.11179E+00, 0.11987E+00, 0.12800E+00,& - 0.13618E+00, 0.14441E+00, 0.15269E+00, 0.16101E+00, 0.16938E+00,& - 0.17779E+00, 0.18624E+00, 0.19473E+00, 0.20327E+00, 0.21184E+00,& - 0.22046E+00, 0.22912E+00, 0.23782E+00, 0.24656E+00, 0.25534E+00,& - 0.26416E+00, 0.27303E+00, 0.28194E+00, 0.29089E+00, 0.29989E+00,& - 0.30893E+00, 0.31802E+00, 0.32715E+00, 0.33633E+00, 0.34556E+00,& - 0.35483E+00, 0.36415E+00, 0.37353E+00, 0.38295E+00, 0.39242E+00,& - 0.40194E+00, 0.41151E+00, 0.42113E+00, 0.43079E+00, 0.44051E+00,& - 0.45028E+00, 0.46009E+00, 0.46995E+00, 0.47986E+00, 0.48982E+00,& - 0.49981E+00, 0.50986E+00, 0.51994E+00, 0.53006E+00, 0.54023E+00/ - - DATA (BNC08M (IA),IA=101,200)/ & - 0.55043E+00, 0.56067E+00, 0.57094E+00, 0.58125E+00, 0.59158E+00,& - 0.60195E+00, 0.61234E+00, 0.62276E+00, 0.63320E+00, 0.64367E+00,& - 0.65415E+00, 0.66465E+00, 0.67516E+00, 0.68569E+00, 0.69624E+00,& - 0.70679E+00, 0.71735E+00, 0.72792E+00, 0.73849E+00, 0.74907E+00,& - 0.75876E+00, 0.76945E+00, 0.78012E+00, 0.79078E+00, 0.80143E+00,& - 0.81207E+00, 0.82269E+00, 0.83330E+00, 0.84390E+00, 0.85449E+00,& - 0.86506E+00, 0.87561E+00, 0.88616E+00, 0.89668E+00, 0.90719E+00,& - 0.91769E+00, 0.92817E+00, 0.93863E+00, 0.94908E+00, 0.95951E+00,& - 0.96993E+00, 0.98032E+00, 0.99070E+00, 0.10011E+01, 0.10114E+01,& - 0.10217E+01, 0.10320E+01, 0.10423E+01, 0.10526E+01, 0.10629E+01,& - 0.10731E+01, 0.10833E+01, 0.10935E+01, 0.11037E+01, 0.11138E+01,& - 0.11240E+01, 0.11341E+01, 0.11442E+01, 0.11543E+01, 0.11644E+01,& - 0.11744E+01, 0.11844E+01, 0.11944E+01, 0.12044E+01, 0.12144E+01,& - 0.12243E+01, 0.12342E+01, 0.12441E+01, 0.12540E+01, 0.12639E+01,& - 0.12737E+01, 0.12835E+01, 0.12933E+01, 0.13031E+01, 0.13129E+01,& - 0.13226E+01, 0.13323E+01, 0.13420E+01, 0.13517E+01, 0.13614E+01,& - 0.13710E+01, 0.13806E+01, 0.13902E+01, 0.13998E+01, 0.14093E+01,& - 0.14189E+01, 0.14284E+01, 0.14379E+01, 0.14474E+01, 0.14568E+01,& - 0.14662E+01, 0.14756E+01, 0.14850E+01, 0.14944E+01, 0.15038E+01,& - 0.15131E+01, 0.15224E+01, 0.15317E+01, 0.15410E+01, 0.15502E+01/ - - DATA (BNC08M (IA),IA=201,300)/ & - 0.15594E+01, 0.15687E+01, 0.15778E+01, 0.15870E+01, 0.15962E+01,& - 0.16053E+01, 0.16144E+01, 0.16235E+01, 0.16326E+01, 0.16416E+01,& - 0.16507E+01, 0.16597E+01, 0.16687E+01, 0.16776E+01, 0.16866E+01,& - 0.16955E+01, 0.17044E+01, 0.17133E+01, 0.17222E+01, 0.17311E+01,& - 0.17399E+01, 0.17487E+01, 0.17575E+01, 0.17663E+01, 0.17751E+01,& - 0.17838E+01, 0.17925E+01, 0.18012E+01, 0.18099E+01, 0.18186E+01,& - 0.18272E+01, 0.18359E+01, 0.18445E+01, 0.18531E+01, 0.18616E+01,& - 0.18702E+01, 0.18787E+01, 0.18872E+01, 0.18958E+01, 0.19042E+01,& - 0.19127E+01, 0.19211E+01, 0.19296E+01, 0.19380E+01, 0.19464E+01,& - 0.19548E+01, 0.19631E+01, 0.19715E+01, 0.19798E+01, 0.19881E+01,& - 0.19964E+01, 0.20046E+01, 0.20129E+01, 0.20211E+01, 0.20293E+01,& - 0.20375E+01, 0.20457E+01, 0.20539E+01, 0.20620E+01, 0.20702E+01,& - 0.20783E+01, 0.20864E+01, 0.20945E+01, 0.21025E+01, 0.21106E+01,& - 0.21186E+01, 0.21266E+01, 0.21346E+01, 0.21426E+01, 0.21506E+01,& - 0.21585E+01, 0.21665E+01, 0.21744E+01, 0.21823E+01, 0.21902E+01,& - 0.21980E+01, 0.22059E+01, 0.22137E+01, 0.22215E+01, 0.22294E+01,& - 0.22371E+01, 0.22449E+01, 0.22527E+01, 0.22604E+01, 0.22681E+01,& - 0.22759E+01, 0.22835E+01, 0.22912E+01, 0.22989E+01, 0.23065E+01,& - 0.23142E+01, 0.23218E+01, 0.23294E+01, 0.23370E+01, 0.23446E+01,& - 0.23521E+01, 0.23597E+01, 0.23672E+01, 0.23747E+01, 0.23822E+01/ - - DATA (BNC08M (IA),IA=301,400)/ & - 0.23897E+01, 0.23972E+01, 0.24046E+01, 0.24121E+01, 0.24195E+01,& - 0.24269E+01, 0.24343E+01, 0.24417E+01, 0.24490E+01, 0.24564E+01,& - 0.24637E+01, 0.24711E+01, 0.24784E+01, 0.24857E+01, 0.24930E+01,& - 0.25002E+01, 0.25075E+01, 0.25147E+01, 0.25220E+01, 0.25292E+01,& - 0.25364E+01, 0.25436E+01, 0.25507E+01, 0.25579E+01, 0.25650E+01,& - 0.25722E+01, 0.25793E+01, 0.25864E+01, 0.25935E+01, 0.26006E+01,& - 0.26076E+01, 0.26147E+01, 0.26217E+01, 0.26288E+01, 0.26358E+01,& - 0.26428E+01, 0.26498E+01, 0.26567E+01, 0.26637E+01, 0.26706E+01,& - 0.26776E+01, 0.26845E+01, 0.26914E+01, 0.26983E+01, 0.27052E+01,& - 0.27121E+01, 0.27189E+01, 0.27258E+01, 0.27326E+01, 0.27394E+01,& - 0.27463E+01, 0.27531E+01, 0.27598E+01, 0.27666E+01, 0.27734E+01,& - 0.27801E+01, 0.27869E+01, 0.27936E+01, 0.28003E+01, 0.28070E+01,& - 0.28137E+01, 0.28204E+01, 0.28270E+01, 0.28337E+01, 0.28403E+01,& - 0.28470E+01, 0.28536E+01, 0.28602E+01, 0.28668E+01, 0.28734E+01,& - 0.28799E+01, 0.28865E+01, 0.28930E+01, 0.28996E+01, 0.29061E+01,& - 0.29126E+01, 0.29191E+01, 0.29256E+01, 0.29321E+01, 0.29386E+01,& - 0.29450E+01, 0.29515E+01, 0.29579E+01, 0.29643E+01, 0.29708E+01,& - 0.29772E+01, 0.29835E+01, 0.29899E+01, 0.29963E+01, 0.30027E+01,& - 0.30090E+01, 0.30153E+01, 0.30217E+01, 0.30280E+01, 0.30343E+01,& - 0.30406E+01, 0.30469E+01, 0.30531E+01, 0.30594E+01, 0.30657E+01/ - - DATA (BNC08M (IA),IA=401,500)/ & - 0.30719E+01, 0.30781E+01, 0.30844E+01, 0.30906E+01, 0.30968E+01,& - 0.31030E+01, 0.31091E+01, 0.31153E+01, 0.31215E+01, 0.31276E+01,& - 0.31338E+01, 0.31399E+01, 0.31460E+01, 0.31521E+01, 0.31582E+01,& - 0.31643E+01, 0.31704E+01, 0.31764E+01, 0.31825E+01, 0.31886E+01,& - 0.31946E+01, 0.32006E+01, 0.32066E+01, 0.32127E+01, 0.32187E+01,& - 0.32246E+01, 0.32306E+01, 0.32366E+01, 0.32426E+01, 0.32485E+01,& - 0.32545E+01, 0.32604E+01, 0.32663E+01, 0.32722E+01, 0.32781E+01,& - 0.32840E+01, 0.32899E+01, 0.32958E+01, 0.33017E+01, 0.33075E+01,& - 0.33134E+01, 0.33192E+01, 0.33250E+01, 0.33309E+01, 0.33367E+01,& - 0.33425E+01, 0.33483E+01, 0.33540E+01, 0.33598E+01, 0.33656E+01,& - 0.33713E+01, 0.33771E+01, 0.33828E+01, 0.33886E+01, 0.33943E+01,& - 0.34000E+01, 0.34057E+01, 0.34114E+01, 0.34171E+01, 0.34228E+01,& - 0.34284E+01, 0.34341E+01, 0.34397E+01, 0.34454E+01, 0.34510E+01,& - 0.34567E+01, 0.34623E+01, 0.34679E+01, 0.34735E+01, 0.34791E+01,& - 0.34847E+01, 0.34902E+01, 0.34958E+01, 0.35014E+01, 0.35069E+01,& - 0.35124E+01, 0.35180E+01, 0.35235E+01, 0.35290E+01, 0.35345E+01,& - 0.35400E+01, 0.35455E+01, 0.35510E+01, 0.35565E+01, 0.35620E+01,& - 0.35674E+01, 0.35729E+01, 0.35783E+01, 0.35837E+01, 0.35892E+01,& - 0.35946E+01, 0.36000E+01, 0.36054E+01, 0.36108E+01, 0.36162E+01,& - 0.36216E+01, 0.36269E+01, 0.36323E+01, 0.36377E+01, 0.36430E+01/ - - DATA (BNC08M (IA),IA=501,600)/ & - 0.36483E+01, 0.36537E+01, 0.36590E+01, 0.36643E+01, 0.36696E+01,& - 0.36749E+01, 0.36802E+01, 0.36855E+01, 0.36908E+01, 0.36961E+01,& - 0.37013E+01, 0.37066E+01, 0.37118E+01, 0.37171E+01, 0.37223E+01,& - 0.37275E+01, 0.37328E+01, 0.37380E+01, 0.37432E+01, 0.37484E+01,& - 0.37536E+01, 0.37588E+01, 0.37639E+01, 0.37691E+01, 0.37743E+01,& - 0.37794E+01, 0.37846E+01, 0.37897E+01, 0.37948E+01, 0.38000E+01,& - 0.38051E+01, 0.38102E+01, 0.38153E+01, 0.38204E+01, 0.38255E+01,& - 0.38305E+01, 0.38356E+01, 0.38407E+01, 0.38458E+01, 0.38508E+01,& - 0.38559E+01, 0.38609E+01, 0.38659E+01, 0.38710E+01, 0.38760E+01,& - 0.38810E+01, 0.38860E+01, 0.38910E+01, 0.38960E+01, 0.39010E+01,& - 0.39059E+01, 0.39109E+01, 0.39159E+01, 0.39208E+01, 0.39258E+01,& - 0.39307E+01, 0.39357E+01, 0.39406E+01, 0.39455E+01, 0.39504E+01,& - 0.39554E+01, 0.39603E+01, 0.39652E+01, 0.39701E+01, 0.39749E+01,& - 0.39798E+01, 0.39847E+01, 0.39896E+01, 0.39944E+01, 0.39993E+01,& - 0.40041E+01, 0.40090E+01, 0.40138E+01, 0.40186E+01, 0.40234E+01,& - 0.40283E+01, 0.40331E+01, 0.40379E+01, 0.40427E+01, 0.40475E+01,& - 0.40522E+01, 0.40570E+01, 0.40618E+01, 0.40665E+01, 0.40713E+01,& - 0.40761E+01, 0.40808E+01, 0.40855E+01, 0.40903E+01, 0.40950E+01,& - 0.40997E+01, 0.41044E+01, 0.41091E+01, 0.41138E+01, 0.41185E+01,& - 0.41232E+01, 0.41279E+01, 0.41326E+01, 0.41373E+01, 0.41547E+01/ - - DATA (BNC08M (IA),IA=601,700)/ & - 0.41929E+01, 0.42386E+01, 0.42837E+01, 0.43283E+01, 0.43723E+01,& - 0.44159E+01, 0.44588E+01, 0.45013E+01, 0.45433E+01, 0.45849E+01,& - 0.46259E+01, 0.46665E+01, 0.47066E+01, 0.47463E+01, 0.47856E+01,& - 0.48244E+01, 0.48628E+01, 0.49008E+01, 0.49384E+01, 0.49757E+01,& - 0.50125E+01, 0.50490E+01, 0.50851E+01, 0.51208E+01, 0.51562E+01,& - 0.51912E+01, 0.52259E+01, 0.52603E+01, 0.52943E+01, 0.53280E+01,& - 0.53614E+01, 0.53945E+01, 0.54273E+01, 0.54598E+01, 0.54919E+01,& - 0.55238E+01, 0.55554E+01, 0.55868E+01, 0.56178E+01, 0.56486E+01,& - 0.56791E+01, 0.57094E+01, 0.57394E+01, 0.57691E+01, 0.57986E+01,& - 0.58279E+01, 0.58569E+01, 0.58856E+01, 0.59142E+01, 0.59425E+01,& - 0.59705E+01, 0.59984E+01, 0.60260E+01, 0.60534E+01, 0.60807E+01,& - 0.61076E+01, 0.61344E+01, 0.61610E+01, 0.61874E+01, 0.62136E+01,& - 0.62396E+01, 0.62653E+01, 0.62909E+01, 0.63164E+01, 0.63416E+01,& - 0.63666E+01, 0.63915E+01, 0.64162E+01, 0.64407E+01, 0.64650E+01,& - 0.64892E+01, 0.65132E+01, 0.65370E+01, 0.65607E+01, 0.65842E+01,& - 0.66076E+01, 0.66308E+01, 0.66538E+01, 0.66767E+01, 0.66994E+01,& - 0.67220E+01, 0.67444E+01, 0.67667E+01, 0.67889E+01, 0.68108E+01,& - 0.68327E+01, 0.68544E+01, 0.68760E+01, 0.68974E+01, 0.69188E+01,& - 0.69399E+01, 0.69610E+01, 0.69819E+01, 0.70027E+01, 0.70233E+01,& - 0.70439E+01, 0.70643E+01, 0.70846E+01, 0.71047E+01, 0.71248E+01/ - - DATA (BNC08M(IA),IA=701,741)/ & - 0.71447E+01, 0.71645E+01, 0.71842E+01, 0.72038E+01, 0.72233E+01,& - 0.72426E+01, 0.72619E+01, 0.72810E+01, 0.73000E+01, 0.73189E+01,& - 0.73378E+01, 0.73565E+01, 0.73751E+01, 0.73936E+01, 0.74120E+01,& - 0.74303E+01, 0.74484E+01, 0.74665E+01, 0.74845E+01, 0.75024E+01,& - 0.75203E+01, 0.75380E+01, 0.75556E+01, 0.75731E+01, 0.75905E+01,& - 0.76079E+01, 0.76251E+01, 0.76423E+01, 0.76593E+01, 0.76763E+01,& - 0.76932E+01, 0.77100E+01, 0.77268E+01, 0.77434E+01, 0.77600E+01,& - 0.77764E+01, 0.77928E+01, 0.78091E+01, 0.78253E+01, 0.78415E+01,& - 0.78576E+01 / -! -! ** NH4HSO4 -! - DATA (BNC09M (IA),IA= 1,100)/ & - -0.51701E-01,-0.92605E-01,-0.12047E+00,-0.13892E+00,-0.15280E+00,& - -0.16389E+00,-0.17309E+00,-0.18091E+00,-0.18765E+00,-0.19355E+00,& - -0.19875E+00,-0.20336E+00,-0.20748E+00,-0.21116E+00,-0.21445E+00,& - -0.21741E+00,-0.22006E+00,-0.22244E+00,-0.22456E+00,-0.22646E+00,& - -0.22813E+00,-0.22961E+00,-0.23090E+00,-0.23202E+00,-0.23297E+00,& - -0.23377E+00,-0.23442E+00,-0.23493E+00,-0.23531E+00,-0.23556E+00,& - -0.23569E+00,-0.23570E+00,-0.23561E+00,-0.23540E+00,-0.23510E+00,& - -0.23469E+00,-0.23419E+00,-0.23360E+00,-0.23293E+00,-0.23217E+00,& - -0.23132E+00,-0.23040E+00,-0.22941E+00,-0.22834E+00,-0.22720E+00,& - -0.22599E+00,-0.22471E+00,-0.22338E+00,-0.22198E+00,-0.22052E+00,& - -0.21901E+00,-0.21744E+00,-0.21582E+00,-0.21415E+00,-0.21242E+00,& - -0.21065E+00,-0.20884E+00,-0.20697E+00,-0.20507E+00,-0.20312E+00,& - -0.20113E+00,-0.19910E+00,-0.19703E+00,-0.19493E+00,-0.19278E+00,& - -0.19060E+00,-0.18839E+00,-0.18614E+00,-0.18386E+00,-0.18154E+00,& - -0.17919E+00,-0.17681E+00,-0.17440E+00,-0.17196E+00,-0.16948E+00,& - -0.16698E+00,-0.16445E+00,-0.16188E+00,-0.15929E+00,-0.15667E+00,& - -0.15402E+00,-0.15134E+00,-0.14864E+00,-0.14590E+00,-0.14314E+00,& - -0.14035E+00,-0.13754E+00,-0.13470E+00,-0.13183E+00,-0.12894E+00,& - -0.12602E+00,-0.12308E+00,-0.12011E+00,-0.11713E+00,-0.11411E+00,& - -0.11108E+00,-0.10803E+00,-0.10495E+00,-0.10186E+00,-0.98742E-01/ - - DATA (BNC09M (IA),IA=101,200)/ & - -0.95609E-01,-0.92458E-01,-0.89291E-01,-0.86108E-01,-0.82909E-01,& - -0.79696E-01,-0.76469E-01,-0.73230E-01,-0.69979E-01,-0.66717E-01,& - -0.63445E-01,-0.60163E-01,-0.56873E-01,-0.53575E-01,-0.50270E-01,& - -0.46959E-01,-0.43642E-01,-0.40321E-01,-0.36995E-01,-0.33666E-01,& - -0.30646E-01,-0.27276E-01,-0.23908E-01,-0.20542E-01,-0.17179E-01,& - -0.13818E-01,-0.10461E-01,-0.71064E-02,-0.37554E-02,-0.40779E-03,& - 0.29358E-02, 0.62756E-02, 0.96112E-02, 0.12942E-01, 0.16269E-01,& - 0.19592E-01, 0.22909E-01, 0.26221E-01, 0.29529E-01, 0.32832E-01,& - 0.36129E-01, 0.39420E-01, 0.42706E-01, 0.45987E-01, 0.49262E-01,& - 0.52531E-01, 0.55794E-01, 0.59051E-01, 0.62303E-01, 0.65548E-01,& - 0.68786E-01, 0.72019E-01, 0.75245E-01, 0.78465E-01, 0.81678E-01,& - 0.84885E-01, 0.88086E-01, 0.91279E-01, 0.94466E-01, 0.97647E-01,& - 0.10082E+00, 0.10399E+00, 0.10715E+00, 0.11030E+00, 0.11345E+00,& - 0.11659E+00, 0.11972E+00, 0.12285E+00, 0.12596E+00, 0.12908E+00,& - 0.13218E+00, 0.13528E+00, 0.13837E+00, 0.14146E+00, 0.14453E+00,& - 0.14760E+00, 0.15067E+00, 0.15372E+00, 0.15677E+00, 0.15981E+00,& - 0.16285E+00, 0.16588E+00, 0.16890E+00, 0.17191E+00, 0.17492E+00,& - 0.17792E+00, 0.18091E+00, 0.18390E+00, 0.18688E+00, 0.18985E+00,& - 0.19281E+00, 0.19577E+00, 0.19872E+00, 0.20167E+00, 0.20460E+00,& - 0.20753E+00, 0.21046E+00, 0.21338E+00, 0.21629E+00, 0.21919E+00/ - - DATA (BNC09M (IA),IA=201,300)/ & - 0.22208E+00, 0.22497E+00, 0.22786E+00, 0.23073E+00, 0.23360E+00,& - 0.23647E+00, 0.23932E+00, 0.24217E+00, 0.24501E+00, 0.24785E+00,& - 0.25068E+00, 0.25350E+00, 0.25632E+00, 0.25913E+00, 0.26193E+00,& - 0.26473E+00, 0.26752E+00, 0.27030E+00, 0.27308E+00, 0.27585E+00,& - 0.27861E+00, 0.28137E+00, 0.28412E+00, 0.28687E+00, 0.28961E+00,& - 0.29234E+00, 0.29506E+00, 0.29778E+00, 0.30050E+00, 0.30321E+00,& - 0.30591E+00, 0.30860E+00, 0.31129E+00, 0.31397E+00, 0.31665E+00,& - 0.31932E+00, 0.32199E+00, 0.32465E+00, 0.32730E+00, 0.32995E+00,& - 0.33259E+00, 0.33522E+00, 0.33785E+00, 0.34047E+00, 0.34309E+00,& - 0.34570E+00, 0.34831E+00, 0.35091E+00, 0.35350E+00, 0.35609E+00,& - 0.35867E+00, 0.36125E+00, 0.36382E+00, 0.36639E+00, 0.36895E+00,& - 0.37150E+00, 0.37405E+00, 0.37659E+00, 0.37913E+00, 0.38166E+00,& - 0.38419E+00, 0.38671E+00, 0.38923E+00, 0.39174E+00, 0.39424E+00,& - 0.39674E+00, 0.39924E+00, 0.40173E+00, 0.40421E+00, 0.40669E+00,& - 0.40916E+00, 0.41163E+00, 0.41409E+00, 0.41655E+00, 0.41900E+00,& - 0.42145E+00, 0.42389E+00, 0.42632E+00, 0.42876E+00, 0.43118E+00,& - 0.43360E+00, 0.43602E+00, 0.43843E+00, 0.44084E+00, 0.44324E+00,& - 0.44563E+00, 0.44803E+00, 0.45041E+00, 0.45279E+00, 0.45517E+00,& - 0.45754E+00, 0.45991E+00, 0.46227E+00, 0.46463E+00, 0.46698E+00,& - 0.46933E+00, 0.47167E+00, 0.47401E+00, 0.47634E+00, 0.47867E+00/ - - DATA (BNC09M (IA),IA=301,400)/ & - 0.48099E+00, 0.48331E+00, 0.48563E+00, 0.48794E+00, 0.49024E+00,& - 0.49254E+00, 0.49484E+00, 0.49713E+00, 0.49942E+00, 0.50170E+00,& - 0.50398E+00, 0.50625E+00, 0.50852E+00, 0.51079E+00, 0.51305E+00,& - 0.51530E+00, 0.51755E+00, 0.51980E+00, 0.52204E+00, 0.52428E+00,& - 0.52651E+00, 0.52874E+00, 0.53097E+00, 0.53319E+00, 0.53540E+00,& - 0.53762E+00, 0.53983E+00, 0.54203E+00, 0.54423E+00, 0.54642E+00,& - 0.54862E+00, 0.55080E+00, 0.55299E+00, 0.55516E+00, 0.55734E+00,& - 0.55951E+00, 0.56168E+00, 0.56384E+00, 0.56600E+00, 0.56815E+00,& - 0.57030E+00, 0.57245E+00, 0.57459E+00, 0.57673E+00, 0.57886E+00,& - 0.58099E+00, 0.58312E+00, 0.58524E+00, 0.58736E+00, 0.58947E+00,& - 0.59158E+00, 0.59369E+00, 0.59579E+00, 0.59789E+00, 0.59999E+00,& - 0.60208E+00, 0.60416E+00, 0.60625E+00, 0.60833E+00, 0.61040E+00,& - 0.61248E+00, 0.61455E+00, 0.61661E+00, 0.61867E+00, 0.62073E+00,& - 0.62278E+00, 0.62483E+00, 0.62688E+00, 0.62892E+00, 0.63096E+00,& - 0.63300E+00, 0.63503E+00, 0.63706E+00, 0.63908E+00, 0.64110E+00,& - 0.64312E+00, 0.64513E+00, 0.64714E+00, 0.64915E+00, 0.65115E+00,& - 0.65316E+00, 0.65515E+00, 0.65714E+00, 0.65913E+00, 0.66112E+00,& - 0.66310E+00, 0.66508E+00, 0.66706E+00, 0.66903E+00, 0.67100E+00,& - 0.67296E+00, 0.67492E+00, 0.67688E+00, 0.67884E+00, 0.68079E+00,& - 0.68274E+00, 0.68468E+00, 0.68663E+00, 0.68856E+00, 0.69050E+00/ - - DATA (BNC09M (IA),IA=401,500)/ & - 0.69243E+00, 0.69436E+00, 0.69629E+00, 0.69821E+00, 0.70013E+00,& - 0.70204E+00, 0.70396E+00, 0.70587E+00, 0.70777E+00, 0.70967E+00,& - 0.71157E+00, 0.71347E+00, 0.71536E+00, 0.71725E+00, 0.71914E+00,& - 0.72103E+00, 0.72291E+00, 0.72478E+00, 0.72666E+00, 0.72853E+00,& - 0.73040E+00, 0.73226E+00, 0.73413E+00, 0.73599E+00, 0.73784E+00,& - 0.73970E+00, 0.74155E+00, 0.74339E+00, 0.74524E+00, 0.74708E+00,& - 0.74892E+00, 0.75075E+00, 0.75258E+00, 0.75441E+00, 0.75624E+00,& - 0.75806E+00, 0.75988E+00, 0.76170E+00, 0.76352E+00, 0.76533E+00,& - 0.76714E+00, 0.76894E+00, 0.77074E+00, 0.77255E+00, 0.77434E+00,& - 0.77614E+00, 0.77793E+00, 0.77972E+00, 0.78150E+00, 0.78329E+00,& - 0.78507E+00, 0.78684E+00, 0.78862E+00, 0.79039E+00, 0.79216E+00,& - 0.79393E+00, 0.79569E+00, 0.79745E+00, 0.79921E+00, 0.80096E+00,& - 0.80272E+00, 0.80447E+00, 0.80621E+00, 0.80796E+00, 0.80970E+00,& - 0.81144E+00, 0.81318E+00, 0.81491E+00, 0.81664E+00, 0.81837E+00,& - 0.82009E+00, 0.82182E+00, 0.82354E+00, 0.82526E+00, 0.82697E+00,& - 0.82868E+00, 0.83039E+00, 0.83210E+00, 0.83381E+00, 0.83551E+00,& - 0.83721E+00, 0.83890E+00, 0.84060E+00, 0.84229E+00, 0.84398E+00,& - 0.84567E+00, 0.84735E+00, 0.84903E+00, 0.85071E+00, 0.85239E+00,& - 0.85406E+00, 0.85573E+00, 0.85740E+00, 0.85907E+00, 0.86074E+00,& - 0.86240E+00, 0.86406E+00, 0.86571E+00, 0.86737E+00, 0.86902E+00/ - - DATA (BNC09M (IA),IA=501,600)/ & - 0.87067E+00, 0.87232E+00, 0.87396E+00, 0.87560E+00, 0.87724E+00,& - 0.87888E+00, 0.88052E+00, 0.88215E+00, 0.88378E+00, 0.88541E+00,& - 0.88703E+00, 0.88865E+00, 0.89028E+00, 0.89189E+00, 0.89351E+00,& - 0.89512E+00, 0.89674E+00, 0.89834E+00, 0.89995E+00, 0.90156E+00,& - 0.90316E+00, 0.90476E+00, 0.90635E+00, 0.90795E+00, 0.90954E+00,& - 0.91113E+00, 0.91272E+00, 0.91431E+00, 0.91589E+00, 0.91747E+00,& - 0.91905E+00, 0.92063E+00, 0.92221E+00, 0.92378E+00, 0.92535E+00,& - 0.92692E+00, 0.92848E+00, 0.93005E+00, 0.93161E+00, 0.93317E+00,& - 0.93472E+00, 0.93628E+00, 0.93783E+00, 0.93938E+00, 0.94093E+00,& - 0.94248E+00, 0.94402E+00, 0.94556E+00, 0.94710E+00, 0.94864E+00,& - 0.95018E+00, 0.95171E+00, 0.95324E+00, 0.95477E+00, 0.95630E+00,& - 0.95782E+00, 0.95935E+00, 0.96087E+00, 0.96239E+00, 0.96390E+00,& - 0.96542E+00, 0.96693E+00, 0.96844E+00, 0.96995E+00, 0.97145E+00,& - 0.97296E+00, 0.97446E+00, 0.97596E+00, 0.97746E+00, 0.97896E+00,& - 0.98045E+00, 0.98194E+00, 0.98343E+00, 0.98492E+00, 0.98641E+00,& - 0.98789E+00, 0.98937E+00, 0.99085E+00, 0.99233E+00, 0.99380E+00,& - 0.99528E+00, 0.99675E+00, 0.99822E+00, 0.99969E+00, 0.10012E+01,& - 0.10026E+01, 0.10041E+01, 0.10055E+01, 0.10070E+01, 0.10085E+01,& - 0.10099E+01, 0.10114E+01, 0.10128E+01, 0.10143E+01, 0.10157E+01,& - 0.10172E+01, 0.10186E+01, 0.10200E+01, 0.10215E+01, 0.10269E+01/ - - DATA (BNC09M (IA),IA=601,700)/ & - 0.10386E+01, 0.10527E+01, 0.10666E+01, 0.10803E+01, 0.10938E+01,& - 0.11072E+01, 0.11204E+01, 0.11334E+01, 0.11463E+01, 0.11591E+01,& - 0.11717E+01, 0.11841E+01, 0.11964E+01, 0.12086E+01, 0.12206E+01,& - 0.12325E+01, 0.12442E+01, 0.12558E+01, 0.12673E+01, 0.12787E+01,& - 0.12900E+01, 0.13011E+01, 0.13121E+01, 0.13230E+01, 0.13338E+01,& - 0.13444E+01, 0.13550E+01, 0.13655E+01, 0.13758E+01, 0.13860E+01,& - 0.13962E+01, 0.14062E+01, 0.14162E+01, 0.14260E+01, 0.14358E+01,& - 0.14454E+01, 0.14550E+01, 0.14645E+01, 0.14738E+01, 0.14831E+01,& - 0.14923E+01, 0.15015E+01, 0.15105E+01, 0.15195E+01, 0.15284E+01,& - 0.15372E+01, 0.15459E+01, 0.15545E+01, 0.15631E+01, 0.15716E+01,& - 0.15800E+01, 0.15884E+01, 0.15966E+01, 0.16049E+01, 0.16130E+01,& - 0.16211E+01, 0.16291E+01, 0.16370E+01, 0.16449E+01, 0.16527E+01,& - 0.16604E+01, 0.16681E+01, 0.16757E+01, 0.16833E+01, 0.16908E+01,& - 0.16982E+01, 0.17056E+01, 0.17129E+01, 0.17201E+01, 0.17273E+01,& - 0.17345E+01, 0.17416E+01, 0.17486E+01, 0.17556E+01, 0.17625E+01,& - 0.17694E+01, 0.17763E+01, 0.17830E+01, 0.17898E+01, 0.17964E+01,& - 0.18031E+01, 0.18097E+01, 0.18162E+01, 0.18227E+01, 0.18291E+01,& - 0.18355E+01, 0.18418E+01, 0.18481E+01, 0.18544E+01, 0.18606E+01,& - 0.18668E+01, 0.18729E+01, 0.18790E+01, 0.18850E+01, 0.18910E+01,& - 0.18970E+01, 0.19029E+01, 0.19088E+01, 0.19146E+01, 0.19204E+01/ - - DATA (BNC09M(IA),IA=701,741)/ & - 0.19262E+01, 0.19319E+01, 0.19376E+01, 0.19432E+01, 0.19488E+01,& - 0.19544E+01, 0.19599E+01, 0.19654E+01, 0.19709E+01, 0.19763E+01,& - 0.19817E+01, 0.19871E+01, 0.19924E+01, 0.19977E+01, 0.20029E+01,& - 0.20082E+01, 0.20133E+01, 0.20185E+01, 0.20236E+01, 0.20287E+01,& - 0.20338E+01, 0.20388E+01, 0.20438E+01, 0.20488E+01, 0.20537E+01,& - 0.20586E+01, 0.20635E+01, 0.20683E+01, 0.20731E+01, 0.20779E+01,& - 0.20827E+01, 0.20874E+01, 0.20921E+01, 0.20968E+01, 0.21014E+01,& - 0.21061E+01, 0.21107E+01, 0.21152E+01, 0.21198E+01, 0.21243E+01,& - 0.21288E+01 / -! -! ** (H, NO3) -! - DATA (BNC10M (IA),IA= 1,100)/ & - -0.50967E-01,-0.89573E-01,-0.11434E+00,-0.12971E+00,-0.14053E+00,& - -0.14861E+00,-0.15484E+00,-0.15973E+00,-0.16360E+00,-0.16667E+00,& - -0.16910E+00,-0.17099E+00,-0.17243E+00,-0.17350E+00,-0.17424E+00,& - -0.17470E+00,-0.17491E+00,-0.17491E+00,-0.17471E+00,-0.17434E+00,& - -0.17382E+00,-0.17316E+00,-0.17238E+00,-0.17148E+00,-0.17049E+00,& - -0.16940E+00,-0.16823E+00,-0.16699E+00,-0.16567E+00,-0.16430E+00,& - -0.16287E+00,-0.16138E+00,-0.15985E+00,-0.15828E+00,-0.15667E+00,& - -0.15502E+00,-0.15334E+00,-0.15163E+00,-0.14989E+00,-0.14814E+00,& - -0.14635E+00,-0.14456E+00,-0.14274E+00,-0.14090E+00,-0.13906E+00,& - -0.13720E+00,-0.13533E+00,-0.13344E+00,-0.13155E+00,-0.12965E+00,& - -0.12775E+00,-0.12583E+00,-0.12392E+00,-0.12199E+00,-0.12006E+00,& - -0.11812E+00,-0.11618E+00,-0.11424E+00,-0.11229E+00,-0.11033E+00,& - -0.10837E+00,-0.10640E+00,-0.10443E+00,-0.10246E+00,-0.10047E+00,& - -0.98485E-01,-0.96489E-01,-0.94485E-01,-0.92474E-01,-0.90455E-01,& - -0.88427E-01,-0.86389E-01,-0.84342E-01,-0.82285E-01,-0.80216E-01,& - -0.78136E-01,-0.76044E-01,-0.73940E-01,-0.71822E-01,-0.69692E-01,& - -0.67547E-01,-0.65389E-01,-0.63216E-01,-0.61028E-01,-0.58825E-01,& - -0.56607E-01,-0.54374E-01,-0.52125E-01,-0.49861E-01,-0.47581E-01,& - -0.45285E-01,-0.42974E-01,-0.40648E-01,-0.38307E-01,-0.35950E-01,& - -0.33579E-01,-0.31194E-01,-0.28794E-01,-0.26380E-01,-0.23953E-01/ - - DATA (BNC10M (IA),IA=101,200)/ & - -0.21514E-01,-0.19061E-01,-0.16597E-01,-0.14121E-01,-0.11634E-01,& - -0.91364E-02,-0.66288E-02,-0.41117E-02,-0.15855E-02, 0.94906E-03,& - 0.34915E-02, 0.60415E-02, 0.85982E-02, 0.11161E-01, 0.13730E-01,& - 0.16305E-01, 0.18884E-01, 0.21468E-01, 0.24056E-01, 0.26647E-01,& - 0.28953E-01, 0.31584E-01, 0.34213E-01, 0.36841E-01, 0.39469E-01,& - 0.42094E-01, 0.44719E-01, 0.47342E-01, 0.49964E-01, 0.52584E-01,& - 0.55203E-01, 0.57820E-01, 0.60435E-01, 0.63049E-01, 0.65661E-01,& - 0.68270E-01, 0.70878E-01, 0.73484E-01, 0.76088E-01, 0.78689E-01,& - 0.81289E-01, 0.83886E-01, 0.86481E-01, 0.89073E-01, 0.91664E-01,& - 0.94252E-01, 0.96837E-01, 0.99420E-01, 0.10200E+00, 0.10458E+00,& - 0.10715E+00, 0.10973E+00, 0.11230E+00, 0.11486E+00, 0.11743E+00,& - 0.11999E+00, 0.12255E+00, 0.12510E+00, 0.12766E+00, 0.13021E+00,& - 0.13276E+00, 0.13530E+00, 0.13784E+00, 0.14038E+00, 0.14291E+00,& - 0.14545E+00, 0.14798E+00, 0.15050E+00, 0.15303E+00, 0.15555E+00,& - 0.15806E+00, 0.16058E+00, 0.16309E+00, 0.16559E+00, 0.16810E+00,& - 0.17060E+00, 0.17309E+00, 0.17559E+00, 0.17808E+00, 0.18057E+00,& - 0.18305E+00, 0.18553E+00, 0.18801E+00, 0.19048E+00, 0.19295E+00,& - 0.19542E+00, 0.19788E+00, 0.20034E+00, 0.20280E+00, 0.20525E+00,& - 0.20770E+00, 0.21015E+00, 0.21259E+00, 0.21503E+00, 0.21747E+00,& - 0.21990E+00, 0.22233E+00, 0.22475E+00, 0.22718E+00, 0.22959E+00/ - - DATA (BNC10M (IA),IA=201,300)/ & - 0.23201E+00, 0.23442E+00, 0.23683E+00, 0.23923E+00, 0.24163E+00,& - 0.24403E+00, 0.24642E+00, 0.24881E+00, 0.25120E+00, 0.25358E+00,& - 0.25596E+00, 0.25833E+00, 0.26070E+00, 0.26307E+00, 0.26544E+00,& - 0.26780E+00, 0.27016E+00, 0.27251E+00, 0.27486E+00, 0.27721E+00,& - 0.27955E+00, 0.28189E+00, 0.28422E+00, 0.28655E+00, 0.28888E+00,& - 0.29121E+00, 0.29353E+00, 0.29585E+00, 0.29816E+00, 0.30047E+00,& - 0.30278E+00, 0.30508E+00, 0.30738E+00, 0.30967E+00, 0.31197E+00,& - 0.31425E+00, 0.31654E+00, 0.31882E+00, 0.32110E+00, 0.32337E+00,& - 0.32564E+00, 0.32791E+00, 0.33017E+00, 0.33243E+00, 0.33469E+00,& - 0.33694E+00, 0.33919E+00, 0.34143E+00, 0.34367E+00, 0.34591E+00,& - 0.34815E+00, 0.35038E+00, 0.35260E+00, 0.35483E+00, 0.35705E+00,& - 0.35926E+00, 0.36148E+00, 0.36369E+00, 0.36589E+00, 0.36809E+00,& - 0.37029E+00, 0.37249E+00, 0.37468E+00, 0.37687E+00, 0.37905E+00,& - 0.38123E+00, 0.38341E+00, 0.38558E+00, 0.38775E+00, 0.38992E+00,& - 0.39208E+00, 0.39424E+00, 0.39640E+00, 0.39855E+00, 0.40070E+00,& - 0.40285E+00, 0.40499E+00, 0.40713E+00, 0.40927E+00, 0.41140E+00,& - 0.41353E+00, 0.41565E+00, 0.41777E+00, 0.41989E+00, 0.42201E+00,& - 0.42412E+00, 0.42623E+00, 0.42833E+00, 0.43043E+00, 0.43253E+00,& - 0.43463E+00, 0.43672E+00, 0.43880E+00, 0.44089E+00, 0.44297E+00,& - 0.44505E+00, 0.44712E+00, 0.44919E+00, 0.45126E+00, 0.45332E+00/ - - DATA (BNC10M (IA),IA=301,400)/ & - 0.45539E+00, 0.45744E+00, 0.45950E+00, 0.46155E+00, 0.46360E+00,& - 0.46564E+00, 0.46768E+00, 0.46972E+00, 0.47175E+00, 0.47378E+00,& - 0.47581E+00, 0.47784E+00, 0.47986E+00, 0.48188E+00, 0.48389E+00,& - 0.48590E+00, 0.48791E+00, 0.48992E+00, 0.49192E+00, 0.49392E+00,& - 0.49591E+00, 0.49790E+00, 0.49989E+00, 0.50188E+00, 0.50386E+00,& - 0.50584E+00, 0.50782E+00, 0.50979E+00, 0.51176E+00, 0.51373E+00,& - 0.51569E+00, 0.51765E+00, 0.51961E+00, 0.52156E+00, 0.52352E+00,& - 0.52546E+00, 0.52741E+00, 0.52935E+00, 0.53129E+00, 0.53323E+00,& - 0.53516E+00, 0.53709E+00, 0.53901E+00, 0.54094E+00, 0.54286E+00,& - 0.54478E+00, 0.54669E+00, 0.54860E+00, 0.55051E+00, 0.55241E+00,& - 0.55432E+00, 0.55622E+00, 0.55811E+00, 0.56001E+00, 0.56190E+00,& - 0.56378E+00, 0.56567E+00, 0.56755E+00, 0.56943E+00, 0.57130E+00,& - 0.57318E+00, 0.57505E+00, 0.57691E+00, 0.57878E+00, 0.58064E+00,& - 0.58249E+00, 0.58435E+00, 0.58620E+00, 0.58805E+00, 0.58990E+00,& - 0.59174E+00, 0.59358E+00, 0.59542E+00, 0.59725E+00, 0.59909E+00,& - 0.60092E+00, 0.60274E+00, 0.60457E+00, 0.60639E+00, 0.60820E+00,& - 0.61002E+00, 0.61183E+00, 0.61364E+00, 0.61545E+00, 0.61725E+00,& - 0.61905E+00, 0.62085E+00, 0.62265E+00, 0.62444E+00, 0.62623E+00,& - 0.62802E+00, 0.62980E+00, 0.63158E+00, 0.63336E+00, 0.63514E+00,& - 0.63691E+00, 0.63868E+00, 0.64045E+00, 0.64222E+00, 0.64398E+00/ - - DATA (BNC10M (IA),IA=401,500)/ & - 0.64574E+00, 0.64750E+00, 0.64925E+00, 0.65100E+00, 0.65275E+00,& - 0.65450E+00, 0.65624E+00, 0.65798E+00, 0.65972E+00, 0.66146E+00,& - 0.66319E+00, 0.66492E+00, 0.66665E+00, 0.66838E+00, 0.67010E+00,& - 0.67182E+00, 0.67354E+00, 0.67526E+00, 0.67697E+00, 0.67868E+00,& - 0.68039E+00, 0.68209E+00, 0.68379E+00, 0.68549E+00, 0.68719E+00,& - 0.68889E+00, 0.69058E+00, 0.69227E+00, 0.69396E+00, 0.69564E+00,& - 0.69732E+00, 0.69900E+00, 0.70068E+00, 0.70236E+00, 0.70403E+00,& - 0.70570E+00, 0.70736E+00, 0.70903E+00, 0.71069E+00, 0.71235E+00,& - 0.71401E+00, 0.71567E+00, 0.71732E+00, 0.71897E+00, 0.72062E+00,& - 0.72226E+00, 0.72390E+00, 0.72555E+00, 0.72718E+00, 0.72882E+00,& - 0.73045E+00, 0.73208E+00, 0.73371E+00, 0.73534E+00, 0.73696E+00,& - 0.73858E+00, 0.74020E+00, 0.74182E+00, 0.74344E+00, 0.74505E+00,& - 0.74666E+00, 0.74826E+00, 0.74987E+00, 0.75147E+00, 0.75307E+00,& - 0.75467E+00, 0.75627E+00, 0.75786E+00, 0.75945E+00, 0.76104E+00,& - 0.76263E+00, 0.76421E+00, 0.76580E+00, 0.76738E+00, 0.76895E+00,& - 0.77053E+00, 0.77210E+00, 0.77367E+00, 0.77524E+00, 0.77681E+00,& - 0.77837E+00, 0.77993E+00, 0.78149E+00, 0.78305E+00, 0.78461E+00,& - 0.78616E+00, 0.78771E+00, 0.78926E+00, 0.79081E+00, 0.79235E+00,& - 0.79389E+00, 0.79543E+00, 0.79697E+00, 0.79851E+00, 0.80004E+00,& - 0.80157E+00, 0.80310E+00, 0.80463E+00, 0.80615E+00, 0.80768E+00/ - - DATA (BNC10M (IA),IA=501,600)/ & - 0.80920E+00, 0.81072E+00, 0.81223E+00, 0.81375E+00, 0.81526E+00,& - 0.81677E+00, 0.81828E+00, 0.81978E+00, 0.82129E+00, 0.82279E+00,& - 0.82429E+00, 0.82579E+00, 0.82728E+00, 0.82878E+00, 0.83027E+00,& - 0.83176E+00, 0.83324E+00, 0.83473E+00, 0.83621E+00, 0.83769E+00,& - 0.83917E+00, 0.84065E+00, 0.84213E+00, 0.84360E+00, 0.84507E+00,& - 0.84654E+00, 0.84801E+00, 0.84947E+00, 0.85093E+00, 0.85240E+00,& - 0.85385E+00, 0.85531E+00, 0.85677E+00, 0.85822E+00, 0.85967E+00,& - 0.86112E+00, 0.86257E+00, 0.86401E+00, 0.86546E+00, 0.86690E+00,& - 0.86834E+00, 0.86977E+00, 0.87121E+00, 0.87264E+00, 0.87408E+00,& - 0.87551E+00, 0.87693E+00, 0.87836E+00, 0.87978E+00, 0.88121E+00,& - 0.88263E+00, 0.88404E+00, 0.88546E+00, 0.88688E+00, 0.88829E+00,& - 0.88970E+00, 0.89111E+00, 0.89251E+00, 0.89392E+00, 0.89532E+00,& - 0.89672E+00, 0.89812E+00, 0.89952E+00, 0.90092E+00, 0.90231E+00,& - 0.90370E+00, 0.90510E+00, 0.90648E+00, 0.90787E+00, 0.90926E+00,& - 0.91064E+00, 0.91202E+00, 0.91340E+00, 0.91478E+00, 0.91615E+00,& - 0.91753E+00, 0.91890E+00, 0.92027E+00, 0.92164E+00, 0.92301E+00,& - 0.92437E+00, 0.92573E+00, 0.92710E+00, 0.92846E+00, 0.92981E+00,& - 0.93117E+00, 0.93252E+00, 0.93388E+00, 0.93523E+00, 0.93658E+00,& - 0.93793E+00, 0.93927E+00, 0.94062E+00, 0.94196E+00, 0.94330E+00,& - 0.94464E+00, 0.94598E+00, 0.94731E+00, 0.94864E+00, 0.95363E+00/ - - DATA (BNC10M (IA),IA=601,700)/ & - 0.96452E+00, 0.97756E+00, 0.99045E+00, 0.10032E+01, 0.10157E+01,& - 0.10282E+01, 0.10404E+01, 0.10525E+01, 0.10645E+01, 0.10763E+01,& - 0.10880E+01, 0.10996E+01, 0.11110E+01, 0.11223E+01, 0.11335E+01,& - 0.11445E+01, 0.11555E+01, 0.11663E+01, 0.11769E+01, 0.11875E+01,& - 0.11980E+01, 0.12083E+01, 0.12185E+01, 0.12287E+01, 0.12387E+01,& - 0.12486E+01, 0.12584E+01, 0.12681E+01, 0.12777E+01, 0.12872E+01,& - 0.12967E+01, 0.13060E+01, 0.13152E+01, 0.13244E+01, 0.13334E+01,& - 0.13424E+01, 0.13513E+01, 0.13601E+01, 0.13688E+01, 0.13774E+01,& - 0.13860E+01, 0.13944E+01, 0.14028E+01, 0.14111E+01, 0.14194E+01,& - 0.14275E+01, 0.14356E+01, 0.14437E+01, 0.14516E+01, 0.14595E+01,& - 0.14673E+01, 0.14750E+01, 0.14827E+01, 0.14903E+01, 0.14978E+01,& - 0.15053E+01, 0.15127E+01, 0.15201E+01, 0.15274E+01, 0.15346E+01,& - 0.15418E+01, 0.15489E+01, 0.15559E+01, 0.15629E+01, 0.15698E+01,& - 0.15767E+01, 0.15835E+01, 0.15903E+01, 0.15970E+01, 0.16037E+01,& - 0.16103E+01, 0.16168E+01, 0.16233E+01, 0.16298E+01, 0.16362E+01,& - 0.16425E+01, 0.16488E+01, 0.16551E+01, 0.16613E+01, 0.16675E+01,& - 0.16736E+01, 0.16797E+01, 0.16857E+01, 0.16917E+01, 0.16976E+01,& - 0.17035E+01, 0.17093E+01, 0.17152E+01, 0.17209E+01, 0.17266E+01,& - 0.17323E+01, 0.17380E+01, 0.17436E+01, 0.17491E+01, 0.17546E+01,& - 0.17601E+01, 0.17656E+01, 0.17710E+01, 0.17763E+01, 0.17817E+01/ - - DATA (BNC10M(IA),IA=701,741)/ & - 0.17870E+01, 0.17922E+01, 0.17975E+01, 0.18026E+01, 0.18078E+01,& - 0.18129E+01, 0.18180E+01, 0.18230E+01, 0.18281E+01, 0.18330E+01,& - 0.18380E+01, 0.18429E+01, 0.18478E+01, 0.18526E+01, 0.18575E+01,& - 0.18622E+01, 0.18670E+01, 0.18717E+01, 0.18764E+01, 0.18811E+01,& - 0.18857E+01, 0.18903E+01, 0.18949E+01, 0.18994E+01, 0.19040E+01,& - 0.19085E+01, 0.19129E+01, 0.19174E+01, 0.19218E+01, 0.19261E+01,& - 0.19305E+01, 0.19348E+01, 0.19391E+01, 0.19434E+01, 0.19476E+01,& - 0.19519E+01, 0.19560E+01, 0.19602E+01, 0.19644E+01, 0.19685E+01,& - 0.19726E+01 / -! -! ** (H, Cl) -! - DATA (BNC11M (IA),IA= 1,100)/ & - -0.49531E-01,-0.84652E-01,-0.10547E+00,-0.11724E+00,-0.12469E+00,& - -0.12951E+00,-0.13255E+00,-0.13431E+00,-0.13506E+00,-0.13503E+00,& - -0.13435E+00,-0.13313E+00,-0.13145E+00,-0.12937E+00,-0.12694E+00,& - -0.12420E+00,-0.12119E+00,-0.11793E+00,-0.11444E+00,-0.11075E+00,& - -0.10687E+00,-0.10282E+00,-0.98618E-01,-0.94265E-01,-0.89778E-01,& - -0.85165E-01,-0.80436E-01,-0.75599E-01,-0.70661E-01,-0.65628E-01,& - -0.60508E-01,-0.55306E-01,-0.50028E-01,-0.44679E-01,-0.39262E-01,& - -0.33784E-01,-0.28247E-01,-0.22657E-01,-0.17017E-01,-0.11329E-01,& - -0.55978E-02, 0.17400E-03, 0.59837E-02, 0.11828E-01, 0.17706E-01,& - 0.23614E-01, 0.29550E-01, 0.35513E-01, 0.41500E-01, 0.47510E-01,& - 0.53542E-01, 0.59594E-01, 0.65665E-01, 0.71754E-01, 0.77861E-01,& - 0.83984E-01, 0.90123E-01, 0.96278E-01, 0.10245E+00, 0.10863E+00,& - 0.11483E+00, 0.12105E+00, 0.12728E+00, 0.13353E+00, 0.13979E+00,& - 0.14608E+00, 0.15237E+00, 0.15869E+00, 0.16503E+00, 0.17138E+00,& - 0.17776E+00, 0.18415E+00, 0.19058E+00, 0.19702E+00, 0.20349E+00,& - 0.20998E+00, 0.21650E+00, 0.22305E+00, 0.22962E+00, 0.23623E+00,& - 0.24286E+00, 0.24953E+00, 0.25623E+00, 0.26295E+00, 0.26972E+00,& - 0.27651E+00, 0.28334E+00, 0.29020E+00, 0.29709E+00, 0.30402E+00,& - 0.31098E+00, 0.31798E+00, 0.32500E+00, 0.33206E+00, 0.33916E+00,& - 0.34628E+00, 0.35343E+00, 0.36062E+00, 0.36783E+00, 0.37507E+00/ - - DATA (BNC11M (IA),IA=101,200)/ & - 0.38234E+00, 0.38964E+00, 0.39696E+00, 0.40431E+00, 0.41167E+00,& - 0.41906E+00, 0.42647E+00, 0.43390E+00, 0.44134E+00, 0.44880E+00,& - 0.45628E+00, 0.46377E+00, 0.47127E+00, 0.47879E+00, 0.48631E+00,& - 0.49384E+00, 0.50138E+00, 0.50893E+00, 0.51648E+00, 0.52403E+00,& - 0.53093E+00, 0.53856E+00, 0.54619E+00, 0.55382E+00, 0.56143E+00,& - 0.56904E+00, 0.57664E+00, 0.58424E+00, 0.59182E+00, 0.59940E+00,& - 0.60697E+00, 0.61453E+00, 0.62208E+00, 0.62962E+00, 0.63715E+00,& - 0.64467E+00, 0.65218E+00, 0.65969E+00, 0.66718E+00, 0.67466E+00,& - 0.68213E+00, 0.68959E+00, 0.69704E+00, 0.70448E+00, 0.71191E+00,& - 0.71933E+00, 0.72674E+00, 0.73413E+00, 0.74152E+00, 0.74889E+00,& - 0.75625E+00, 0.76360E+00, 0.77094E+00, 0.77826E+00, 0.78557E+00,& - 0.79288E+00, 0.80016E+00, 0.80744E+00, 0.81471E+00, 0.82196E+00,& - 0.82920E+00, 0.83642E+00, 0.84364E+00, 0.85084E+00, 0.85803E+00,& - 0.86520E+00, 0.87237E+00, 0.87952E+00, 0.88665E+00, 0.89378E+00,& - 0.90089E+00, 0.90799E+00, 0.91507E+00, 0.92215E+00, 0.92921E+00,& - 0.93625E+00, 0.94328E+00, 0.95030E+00, 0.95731E+00, 0.96430E+00,& - 0.97128E+00, 0.97825E+00, 0.98520E+00, 0.99214E+00, 0.99907E+00,& - 0.10060E+01, 0.10129E+01, 0.10198E+01, 0.10266E+01, 0.10335E+01,& - 0.10403E+01, 0.10472E+01, 0.10540E+01, 0.10608E+01, 0.10676E+01,& - 0.10744E+01, 0.10811E+01, 0.10879E+01, 0.10946E+01, 0.11014E+01/ - - DATA (BNC11M (IA),IA=201,300)/ & - 0.11081E+01, 0.11148E+01, 0.11214E+01, 0.11281E+01, 0.11348E+01,& - 0.11414E+01, 0.11481E+01, 0.11547E+01, 0.11613E+01, 0.11679E+01,& - 0.11745E+01, 0.11810E+01, 0.11876E+01, 0.11941E+01, 0.12006E+01,& - 0.12071E+01, 0.12136E+01, 0.12201E+01, 0.12266E+01, 0.12331E+01,& - 0.12395E+01, 0.12460E+01, 0.12524E+01, 0.12588E+01, 0.12652E+01,& - 0.12716E+01, 0.12779E+01, 0.12843E+01, 0.12906E+01, 0.12970E+01,& - 0.13033E+01, 0.13096E+01, 0.13159E+01, 0.13222E+01, 0.13284E+01,& - 0.13347E+01, 0.13409E+01, 0.13472E+01, 0.13534E+01, 0.13596E+01,& - 0.13658E+01, 0.13720E+01, 0.13781E+01, 0.13843E+01, 0.13904E+01,& - 0.13966E+01, 0.14027E+01, 0.14088E+01, 0.14149E+01, 0.14210E+01,& - 0.14270E+01, 0.14331E+01, 0.14391E+01, 0.14452E+01, 0.14512E+01,& - 0.14572E+01, 0.14632E+01, 0.14692E+01, 0.14751E+01, 0.14811E+01,& - 0.14871E+01, 0.14930E+01, 0.14989E+01, 0.15048E+01, 0.15107E+01,& - 0.15166E+01, 0.15225E+01, 0.15284E+01, 0.15342E+01, 0.15401E+01,& - 0.15459E+01, 0.15517E+01, 0.15575E+01, 0.15633E+01, 0.15691E+01,& - 0.15749E+01, 0.15807E+01, 0.15864E+01, 0.15922E+01, 0.15979E+01,& - 0.16036E+01, 0.16093E+01, 0.16150E+01, 0.16207E+01, 0.16264E+01,& - 0.16320E+01, 0.16377E+01, 0.16433E+01, 0.16490E+01, 0.16546E+01,& - 0.16602E+01, 0.16658E+01, 0.16714E+01, 0.16770E+01, 0.16825E+01,& - 0.16881E+01, 0.16936E+01, 0.16992E+01, 0.17047E+01, 0.17102E+01/ - - DATA (BNC11M (IA),IA=301,400)/ & - 0.17157E+01, 0.17212E+01, 0.17267E+01, 0.17321E+01, 0.17376E+01,& - 0.17431E+01, 0.17485E+01, 0.17539E+01, 0.17593E+01, 0.17648E+01,& - 0.17702E+01, 0.17755E+01, 0.17809E+01, 0.17863E+01, 0.17917E+01,& - 0.17970E+01, 0.18023E+01, 0.18077E+01, 0.18130E+01, 0.18183E+01,& - 0.18236E+01, 0.18289E+01, 0.18342E+01, 0.18394E+01, 0.18447E+01,& - 0.18500E+01, 0.18552E+01, 0.18604E+01, 0.18656E+01, 0.18709E+01,& - 0.18761E+01, 0.18813E+01, 0.18864E+01, 0.18916E+01, 0.18968E+01,& - 0.19019E+01, 0.19071E+01, 0.19122E+01, 0.19173E+01, 0.19225E+01,& - 0.19276E+01, 0.19327E+01, 0.19378E+01, 0.19428E+01, 0.19479E+01,& - 0.19530E+01, 0.19580E+01, 0.19631E+01, 0.19681E+01, 0.19731E+01,& - 0.19782E+01, 0.19832E+01, 0.19882E+01, 0.19932E+01, 0.19981E+01,& - 0.20031E+01, 0.20081E+01, 0.20130E+01, 0.20180E+01, 0.20229E+01,& - 0.20278E+01, 0.20328E+01, 0.20377E+01, 0.20426E+01, 0.20475E+01,& - 0.20524E+01, 0.20572E+01, 0.20621E+01, 0.20670E+01, 0.20718E+01,& - 0.20767E+01, 0.20815E+01, 0.20863E+01, 0.20912E+01, 0.20960E+01,& - 0.21008E+01, 0.21056E+01, 0.21104E+01, 0.21151E+01, 0.21199E+01,& - 0.21247E+01, 0.21294E+01, 0.21342E+01, 0.21389E+01, 0.21436E+01,& - 0.21483E+01, 0.21531E+01, 0.21578E+01, 0.21625E+01, 0.21672E+01,& - 0.21718E+01, 0.21765E+01, 0.21812E+01, 0.21858E+01, 0.21905E+01,& - 0.21951E+01, 0.21998E+01, 0.22044E+01, 0.22090E+01, 0.22136E+01/ - - DATA (BNC11M (IA),IA=401,500)/ & - 0.22182E+01, 0.22228E+01, 0.22274E+01, 0.22320E+01, 0.22366E+01,& - 0.22411E+01, 0.22457E+01, 0.22502E+01, 0.22548E+01, 0.22593E+01,& - 0.22638E+01, 0.22684E+01, 0.22729E+01, 0.22774E+01, 0.22819E+01,& - 0.22864E+01, 0.22908E+01, 0.22953E+01, 0.22998E+01, 0.23043E+01,& - 0.23087E+01, 0.23132E+01, 0.23176E+01, 0.23220E+01, 0.23265E+01,& - 0.23309E+01, 0.23353E+01, 0.23397E+01, 0.23441E+01, 0.23485E+01,& - 0.23529E+01, 0.23572E+01, 0.23616E+01, 0.23660E+01, 0.23703E+01,& - 0.23747E+01, 0.23790E+01, 0.23834E+01, 0.23877E+01, 0.23920E+01,& - 0.23963E+01, 0.24006E+01, 0.24049E+01, 0.24092E+01, 0.24135E+01,& - 0.24178E+01, 0.24221E+01, 0.24263E+01, 0.24306E+01, 0.24349E+01,& - 0.24391E+01, 0.24434E+01, 0.24476E+01, 0.24518E+01, 0.24560E+01,& - 0.24603E+01, 0.24645E+01, 0.24687E+01, 0.24729E+01, 0.24770E+01,& - 0.24812E+01, 0.24854E+01, 0.24896E+01, 0.24937E+01, 0.24979E+01,& - 0.25021E+01, 0.25062E+01, 0.25103E+01, 0.25145E+01, 0.25186E+01,& - 0.25227E+01, 0.25268E+01, 0.25309E+01, 0.25350E+01, 0.25391E+01,& - 0.25432E+01, 0.25473E+01, 0.25514E+01, 0.25554E+01, 0.25595E+01,& - 0.25636E+01, 0.25676E+01, 0.25717E+01, 0.25757E+01, 0.25797E+01,& - 0.25838E+01, 0.25878E+01, 0.25918E+01, 0.25958E+01, 0.25998E+01,& - 0.26038E+01, 0.26078E+01, 0.26118E+01, 0.26158E+01, 0.26198E+01,& - 0.26237E+01, 0.26277E+01, 0.26317E+01, 0.26356E+01, 0.26396E+01/ - - DATA (BNC11M (IA),IA=501,600)/ & - 0.26435E+01, 0.26474E+01, 0.26514E+01, 0.26553E+01, 0.26592E+01,& - 0.26631E+01, 0.26670E+01, 0.26709E+01, 0.26748E+01, 0.26787E+01,& - 0.26826E+01, 0.26865E+01, 0.26903E+01, 0.26942E+01, 0.26981E+01,& - 0.27019E+01, 0.27058E+01, 0.27096E+01, 0.27135E+01, 0.27173E+01,& - 0.27211E+01, 0.27249E+01, 0.27288E+01, 0.27326E+01, 0.27364E+01,& - 0.27402E+01, 0.27440E+01, 0.27478E+01, 0.27516E+01, 0.27553E+01,& - 0.27591E+01, 0.27629E+01, 0.27667E+01, 0.27704E+01, 0.27742E+01,& - 0.27779E+01, 0.27817E+01, 0.27854E+01, 0.27891E+01, 0.27929E+01,& - 0.27966E+01, 0.28003E+01, 0.28040E+01, 0.28077E+01, 0.28114E+01,& - 0.28151E+01, 0.28188E+01, 0.28225E+01, 0.28262E+01, 0.28299E+01,& - 0.28335E+01, 0.28372E+01, 0.28409E+01, 0.28445E+01, 0.28482E+01,& - 0.28518E+01, 0.28555E+01, 0.28591E+01, 0.28627E+01, 0.28664E+01,& - 0.28700E+01, 0.28736E+01, 0.28772E+01, 0.28808E+01, 0.28844E+01,& - 0.28880E+01, 0.28916E+01, 0.28952E+01, 0.28988E+01, 0.29024E+01,& - 0.29060E+01, 0.29095E+01, 0.29131E+01, 0.29167E+01, 0.29202E+01,& - 0.29238E+01, 0.29273E+01, 0.29309E+01, 0.29344E+01, 0.29379E+01,& - 0.29415E+01, 0.29450E+01, 0.29485E+01, 0.29520E+01, 0.29555E+01,& - 0.29590E+01, 0.29625E+01, 0.29660E+01, 0.29695E+01, 0.29730E+01,& - 0.29765E+01, 0.29800E+01, 0.29834E+01, 0.29869E+01, 0.29904E+01,& - 0.29938E+01, 0.29973E+01, 0.30007E+01, 0.30042E+01, 0.30171E+01/ - - DATA (BNC11M (IA),IA=601,700)/ & - 0.30452E+01, 0.30789E+01, 0.31122E+01, 0.31450E+01, 0.31775E+01,& - 0.32096E+01, 0.32413E+01, 0.32726E+01, 0.33035E+01, 0.33341E+01,& - 0.33644E+01, 0.33943E+01, 0.34238E+01, 0.34531E+01, 0.34820E+01,& - 0.35106E+01, 0.35389E+01, 0.35668E+01, 0.35945E+01, 0.36219E+01,& - 0.36490E+01, 0.36759E+01, 0.37024E+01, 0.37287E+01, 0.37548E+01,& - 0.37805E+01, 0.38061E+01, 0.38313E+01, 0.38564E+01, 0.38811E+01,& - 0.39057E+01, 0.39300E+01, 0.39541E+01, 0.39780E+01, 0.40016E+01,& - 0.40250E+01, 0.40483E+01, 0.40713E+01, 0.40941E+01, 0.41167E+01,& - 0.41391E+01, 0.41613E+01, 0.41833E+01, 0.42051E+01, 0.42268E+01,& - 0.42482E+01, 0.42695E+01, 0.42906E+01, 0.43116E+01, 0.43323E+01,& - 0.43529E+01, 0.43733E+01, 0.43936E+01, 0.44137E+01, 0.44336E+01,& - 0.44534E+01, 0.44730E+01, 0.44925E+01, 0.45118E+01, 0.45310E+01,& - 0.45500E+01, 0.45689E+01, 0.45877E+01, 0.46063E+01, 0.46247E+01,& - 0.46431E+01, 0.46613E+01, 0.46793E+01, 0.46973E+01, 0.47151E+01,& - 0.47327E+01, 0.47503E+01, 0.47677E+01, 0.47850E+01, 0.48022E+01,& - 0.48193E+01, 0.48362E+01, 0.48530E+01, 0.48698E+01, 0.48864E+01,& - 0.49029E+01, 0.49192E+01, 0.49355E+01, 0.49517E+01, 0.49677E+01,& - 0.49837E+01, 0.49995E+01, 0.50153E+01, 0.50309E+01, 0.50465E+01,& - 0.50619E+01, 0.50773E+01, 0.50925E+01, 0.51077E+01, 0.51227E+01,& - 0.51377E+01, 0.51526E+01, 0.51673E+01, 0.51820E+01, 0.51966E+01/ - - DATA (BNC11M(IA),IA=701,741)/ & - 0.52112E+01, 0.52256E+01, 0.52399E+01, 0.52542E+01, 0.52683E+01,& - 0.52824E+01, 0.52964E+01, 0.53104E+01, 0.53242E+01, 0.53380E+01,& - 0.53516E+01, 0.53652E+01, 0.53788E+01, 0.53922E+01, 0.54056E+01,& - 0.54189E+01, 0.54321E+01, 0.54453E+01, 0.54583E+01, 0.54713E+01,& - 0.54843E+01, 0.54971E+01, 0.55099E+01, 0.55226E+01, 0.55353E+01,& - 0.55479E+01, 0.55604E+01, 0.55729E+01, 0.55852E+01, 0.55976E+01,& - 0.56098E+01, 0.56220E+01, 0.56341E+01, 0.56462E+01, 0.56582E+01,& - 0.56701E+01, 0.56820E+01, 0.56938E+01, 0.57056E+01, 0.57173E+01,& - 0.57289E+01 / -! -! ** NaHSO4 -! - DATA (BNC12M (IA),IA= 1,100)/ & - -0.50782E-01,-0.89259E-01,-0.11419E+00,-0.12989E+00,-0.14113E+00,& - -0.14967E+00,-0.15637E+00,-0.16174E+00,-0.16609E+00,-0.16962E+00,& - -0.17248E+00,-0.17478E+00,-0.17660E+00,-0.17801E+00,-0.17906E+00,& - -0.17979E+00,-0.18023E+00,-0.18040E+00,-0.18034E+00,-0.18006E+00,& - -0.17958E+00,-0.17891E+00,-0.17806E+00,-0.17706E+00,-0.17590E+00,& - -0.17460E+00,-0.17317E+00,-0.17160E+00,-0.16992E+00,-0.16812E+00,& - -0.16621E+00,-0.16420E+00,-0.16208E+00,-0.15987E+00,-0.15758E+00,& - -0.15519E+00,-0.15272E+00,-0.15017E+00,-0.14755E+00,-0.14485E+00,& - -0.14209E+00,-0.13925E+00,-0.13636E+00,-0.13340E+00,-0.13038E+00,& - -0.12731E+00,-0.12418E+00,-0.12100E+00,-0.11777E+00,-0.11449E+00,& - -0.11116E+00,-0.10779E+00,-0.10438E+00,-0.10093E+00,-0.97430E-01,& - -0.93896E-01,-0.90324E-01,-0.86716E-01,-0.83072E-01,-0.79393E-01,& - -0.75680E-01,-0.71935E-01,-0.68156E-01,-0.64346E-01,-0.60504E-01,& - -0.56631E-01,-0.52728E-01,-0.48793E-01,-0.44829E-01,-0.40834E-01,& - -0.36810E-01,-0.32755E-01,-0.28670E-01,-0.24555E-01,-0.20411E-01,& - -0.16235E-01,-0.12030E-01,-0.77941E-02,-0.35277E-02, 0.76915E-03,& - 0.50967E-02, 0.94548E-02, 0.13844E-01, 0.18263E-01, 0.22713E-01,& - 0.27194E-01, 0.31705E-01, 0.36246E-01, 0.40817E-01, 0.45417E-01,& - 0.50047E-01, 0.54705E-01, 0.59392E-01, 0.64106E-01, 0.68847E-01,& - 0.73615E-01, 0.78408E-01, 0.83227E-01, 0.88069E-01, 0.92934E-01/ - - DATA (BNC12M (IA),IA=101,200)/ & - 0.97821E-01, 0.10273E+00, 0.10766E+00, 0.11261E+00, 0.11757E+00,& - 0.12256E+00, 0.12756E+00, 0.13257E+00, 0.13760E+00, 0.14264E+00,& - 0.14770E+00, 0.15276E+00, 0.15784E+00, 0.16292E+00, 0.16801E+00,& - 0.17311E+00, 0.17821E+00, 0.18332E+00, 0.18843E+00, 0.19355E+00,& - 0.19820E+00, 0.20337E+00, 0.20854E+00, 0.21370E+00, 0.21886E+00,& - 0.22401E+00, 0.22916E+00, 0.23430E+00, 0.23944E+00, 0.24457E+00,& - 0.24969E+00, 0.25481E+00, 0.25992E+00, 0.26502E+00, 0.27012E+00,& - 0.27521E+00, 0.28029E+00, 0.28536E+00, 0.29043E+00, 0.29548E+00,& - 0.30053E+00, 0.30558E+00, 0.31061E+00, 0.31563E+00, 0.32065E+00,& - 0.32566E+00, 0.33066E+00, 0.33565E+00, 0.34063E+00, 0.34560E+00,& - 0.35057E+00, 0.35552E+00, 0.36047E+00, 0.36541E+00, 0.37033E+00,& - 0.37525E+00, 0.38016E+00, 0.38506E+00, 0.38995E+00, 0.39483E+00,& - 0.39971E+00, 0.40457E+00, 0.40942E+00, 0.41426E+00, 0.41910E+00,& - 0.42392E+00, 0.42873E+00, 0.43354E+00, 0.43833E+00, 0.44312E+00,& - 0.44789E+00, 0.45266E+00, 0.45742E+00, 0.46216E+00, 0.46690E+00,& - 0.47163E+00, 0.47634E+00, 0.48105E+00, 0.48575E+00, 0.49043E+00,& - 0.49511E+00, 0.49978E+00, 0.50444E+00, 0.50909E+00, 0.51373E+00,& - 0.51836E+00, 0.52298E+00, 0.52759E+00, 0.53219E+00, 0.53678E+00,& - 0.54136E+00, 0.54593E+00, 0.55049E+00, 0.55504E+00, 0.55959E+00,& - 0.56412E+00, 0.56864E+00, 0.57316E+00, 0.57766E+00, 0.58216E+00/ - - DATA (BNC12M (IA),IA=201,300)/ & - 0.58664E+00, 0.59112E+00, 0.59558E+00, 0.60004E+00, 0.60449E+00,& - 0.60893E+00, 0.61336E+00, 0.61778E+00, 0.62219E+00, 0.62659E+00,& - 0.63098E+00, 0.63536E+00, 0.63973E+00, 0.64410E+00, 0.64845E+00,& - 0.65280E+00, 0.65714E+00, 0.66146E+00, 0.66578E+00, 0.67009E+00,& - 0.67439E+00, 0.67869E+00, 0.68297E+00, 0.68724E+00, 0.69151E+00,& - 0.69576E+00, 0.70001E+00, 0.70425E+00, 0.70848E+00, 0.71270E+00,& - 0.71691E+00, 0.72111E+00, 0.72531E+00, 0.72950E+00, 0.73367E+00,& - 0.73784E+00, 0.74200E+00, 0.74616E+00, 0.75030E+00, 0.75443E+00,& - 0.75856E+00, 0.76268E+00, 0.76679E+00, 0.77089E+00, 0.77498E+00,& - 0.77907E+00, 0.78314E+00, 0.78721E+00, 0.79127E+00, 0.79532E+00,& - 0.79937E+00, 0.80340E+00, 0.80743E+00, 0.81145E+00, 0.81546E+00,& - 0.81946E+00, 0.82346E+00, 0.82745E+00, 0.83143E+00, 0.83540E+00,& - 0.83936E+00, 0.84332E+00, 0.84726E+00, 0.85120E+00, 0.85514E+00,& - 0.85906E+00, 0.86298E+00, 0.86689E+00, 0.87079E+00, 0.87468E+00,& - 0.87857E+00, 0.88245E+00, 0.88632E+00, 0.89018E+00, 0.89404E+00,& - 0.89788E+00, 0.90173E+00, 0.90556E+00, 0.90939E+00, 0.91320E+00,& - 0.91702E+00, 0.92082E+00, 0.92462E+00, 0.92840E+00, 0.93219E+00,& - 0.93596E+00, 0.93973E+00, 0.94349E+00, 0.94724E+00, 0.95099E+00,& - 0.95473E+00, 0.95846E+00, 0.96219E+00, 0.96590E+00, 0.96961E+00,& - 0.97332E+00, 0.97702E+00, 0.98071E+00, 0.98439E+00, 0.98807E+00/ - - DATA (BNC12M (IA),IA=301,400)/ & - 0.99173E+00, 0.99540E+00, 0.99905E+00, 0.10027E+01, 0.10063E+01,& - 0.10100E+01, 0.10136E+01, 0.10172E+01, 0.10208E+01, 0.10245E+01,& - 0.10281E+01, 0.10316E+01, 0.10352E+01, 0.10388E+01, 0.10424E+01,& - 0.10460E+01, 0.10495E+01, 0.10531E+01, 0.10566E+01, 0.10602E+01,& - 0.10637E+01, 0.10672E+01, 0.10708E+01, 0.10743E+01, 0.10778E+01,& - 0.10813E+01, 0.10848E+01, 0.10883E+01, 0.10918E+01, 0.10953E+01,& - 0.10987E+01, 0.11022E+01, 0.11057E+01, 0.11091E+01, 0.11126E+01,& - 0.11160E+01, 0.11194E+01, 0.11229E+01, 0.11263E+01, 0.11297E+01,& - 0.11331E+01, 0.11365E+01, 0.11399E+01, 0.11433E+01, 0.11467E+01,& - 0.11501E+01, 0.11535E+01, 0.11569E+01, 0.11602E+01, 0.11636E+01,& - 0.11669E+01, 0.11703E+01, 0.11736E+01, 0.11770E+01, 0.11803E+01,& - 0.11836E+01, 0.11869E+01, 0.11902E+01, 0.11935E+01, 0.11969E+01,& - 0.12001E+01, 0.12034E+01, 0.12067E+01, 0.12100E+01, 0.12133E+01,& - 0.12165E+01, 0.12198E+01, 0.12231E+01, 0.12263E+01, 0.12296E+01,& - 0.12328E+01, 0.12360E+01, 0.12393E+01, 0.12425E+01, 0.12457E+01,& - 0.12489E+01, 0.12521E+01, 0.12553E+01, 0.12585E+01, 0.12617E+01,& - 0.12649E+01, 0.12681E+01, 0.12713E+01, 0.12744E+01, 0.12776E+01,& - 0.12808E+01, 0.12839E+01, 0.12871E+01, 0.12902E+01, 0.12934E+01,& - 0.12965E+01, 0.12996E+01, 0.13028E+01, 0.13059E+01, 0.13090E+01,& - 0.13121E+01, 0.13152E+01, 0.13183E+01, 0.13214E+01, 0.13245E+01/ - - DATA (BNC12M (IA),IA=401,500)/ & - 0.13276E+01, 0.13307E+01, 0.13337E+01, 0.13368E+01, 0.13399E+01,& - 0.13429E+01, 0.13460E+01, 0.13490E+01, 0.13521E+01, 0.13551E+01,& - 0.13581E+01, 0.13612E+01, 0.13642E+01, 0.13672E+01, 0.13702E+01,& - 0.13733E+01, 0.13763E+01, 0.13793E+01, 0.13823E+01, 0.13853E+01,& - 0.13882E+01, 0.13912E+01, 0.13942E+01, 0.13972E+01, 0.14001E+01,& - 0.14031E+01, 0.14061E+01, 0.14090E+01, 0.14120E+01, 0.14149E+01,& - 0.14179E+01, 0.14208E+01, 0.14237E+01, 0.14267E+01, 0.14296E+01,& - 0.14325E+01, 0.14354E+01, 0.14383E+01, 0.14412E+01, 0.14441E+01,& - 0.14470E+01, 0.14499E+01, 0.14528E+01, 0.14557E+01, 0.14586E+01,& - 0.14614E+01, 0.14643E+01, 0.14672E+01, 0.14700E+01, 0.14729E+01,& - 0.14758E+01, 0.14786E+01, 0.14815E+01, 0.14843E+01, 0.14871E+01,& - 0.14900E+01, 0.14928E+01, 0.14956E+01, 0.14984E+01, 0.15012E+01,& - 0.15041E+01, 0.15069E+01, 0.15097E+01, 0.15125E+01, 0.15153E+01,& - 0.15180E+01, 0.15208E+01, 0.15236E+01, 0.15264E+01, 0.15292E+01,& - 0.15319E+01, 0.15347E+01, 0.15375E+01, 0.15402E+01, 0.15430E+01,& - 0.15457E+01, 0.15485E+01, 0.15512E+01, 0.15539E+01, 0.15567E+01,& - 0.15594E+01, 0.15621E+01, 0.15648E+01, 0.15676E+01, 0.15703E+01,& - 0.15730E+01, 0.15757E+01, 0.15784E+01, 0.15811E+01, 0.15838E+01,& - 0.15865E+01, 0.15892E+01, 0.15918E+01, 0.15945E+01, 0.15972E+01,& - 0.15999E+01, 0.16025E+01, 0.16052E+01, 0.16079E+01, 0.16105E+01/ - - DATA (BNC12M (IA),IA=501,600)/ & - 0.16132E+01, 0.16158E+01, 0.16185E+01, 0.16211E+01, 0.16237E+01,& - 0.16264E+01, 0.16290E+01, 0.16316E+01, 0.16342E+01, 0.16369E+01,& - 0.16395E+01, 0.16421E+01, 0.16447E+01, 0.16473E+01, 0.16499E+01,& - 0.16525E+01, 0.16551E+01, 0.16577E+01, 0.16603E+01, 0.16628E+01,& - 0.16654E+01, 0.16680E+01, 0.16706E+01, 0.16731E+01, 0.16757E+01,& - 0.16783E+01, 0.16808E+01, 0.16834E+01, 0.16859E+01, 0.16885E+01,& - 0.16910E+01, 0.16935E+01, 0.16961E+01, 0.16986E+01, 0.17011E+01,& - 0.17037E+01, 0.17062E+01, 0.17087E+01, 0.17112E+01, 0.17137E+01,& - 0.17162E+01, 0.17188E+01, 0.17213E+01, 0.17238E+01, 0.17263E+01,& - 0.17287E+01, 0.17312E+01, 0.17337E+01, 0.17362E+01, 0.17387E+01,& - 0.17412E+01, 0.17436E+01, 0.17461E+01, 0.17486E+01, 0.17510E+01,& - 0.17535E+01, 0.17559E+01, 0.17584E+01, 0.17608E+01, 0.17633E+01,& - 0.17657E+01, 0.17682E+01, 0.17706E+01, 0.17730E+01, 0.17755E+01,& - 0.17779E+01, 0.17803E+01, 0.17827E+01, 0.17851E+01, 0.17876E+01,& - 0.17900E+01, 0.17924E+01, 0.17948E+01, 0.17972E+01, 0.17996E+01,& - 0.18020E+01, 0.18044E+01, 0.18068E+01, 0.18091E+01, 0.18115E+01,& - 0.18139E+01, 0.18163E+01, 0.18187E+01, 0.18210E+01, 0.18234E+01,& - 0.18258E+01, 0.18281E+01, 0.18305E+01, 0.18328E+01, 0.18352E+01,& - 0.18375E+01, 0.18399E+01, 0.18422E+01, 0.18446E+01, 0.18469E+01,& - 0.18492E+01, 0.18516E+01, 0.18539E+01, 0.18562E+01, 0.18649E+01/ - - DATA (BNC12M (IA),IA=601,700)/ & - 0.18839E+01, 0.19066E+01, 0.19291E+01, 0.19513E+01, 0.19732E+01,& - 0.19949E+01, 0.20163E+01, 0.20374E+01, 0.20583E+01, 0.20790E+01,& - 0.20994E+01, 0.21196E+01, 0.21396E+01, 0.21594E+01, 0.21789E+01,& - 0.21982E+01, 0.22174E+01, 0.22363E+01, 0.22550E+01, 0.22735E+01,& - 0.22918E+01, 0.23100E+01, 0.23279E+01, 0.23457E+01, 0.23633E+01,& - 0.23807E+01, 0.23979E+01, 0.24150E+01, 0.24319E+01, 0.24487E+01,& - 0.24653E+01, 0.24817E+01, 0.24980E+01, 0.25141E+01, 0.25301E+01,& - 0.25459E+01, 0.25616E+01, 0.25771E+01, 0.25925E+01, 0.26078E+01,& - 0.26229E+01, 0.26379E+01, 0.26527E+01, 0.26675E+01, 0.26821E+01,& - 0.26965E+01, 0.27109E+01, 0.27251E+01, 0.27393E+01, 0.27532E+01,& - 0.27671E+01, 0.27809E+01, 0.27945E+01, 0.28081E+01, 0.28215E+01,& - 0.28349E+01, 0.28481E+01, 0.28612E+01, 0.28742E+01, 0.28871E+01,& - 0.28999E+01, 0.29126E+01, 0.29252E+01, 0.29378E+01, 0.29502E+01,& - 0.29625E+01, 0.29747E+01, 0.29869E+01, 0.29989E+01, 0.30109E+01,& - 0.30228E+01, 0.30346E+01, 0.30463E+01, 0.30579E+01, 0.30694E+01,& - 0.30809E+01, 0.30923E+01, 0.31036E+01, 0.31148E+01, 0.31259E+01,& - 0.31370E+01, 0.31480E+01, 0.31589E+01, 0.31697E+01, 0.31805E+01,& - 0.31912E+01, 0.32018E+01, 0.32123E+01, 0.32228E+01, 0.32332E+01,& - 0.32436E+01, 0.32538E+01, 0.32640E+01, 0.32742E+01, 0.32842E+01,& - 0.32943E+01, 0.33042E+01, 0.33141E+01, 0.33239E+01, 0.33336E+01/ - - DATA (BNC12M(IA),IA=701,741)/ & - 0.33433E+01, 0.33530E+01, 0.33626E+01, 0.33721E+01, 0.33815E+01,& - 0.33909E+01, 0.34003E+01, 0.34095E+01, 0.34188E+01, 0.34279E+01,& - 0.34371E+01, 0.34461E+01, 0.34551E+01, 0.34641E+01, 0.34730E+01,& - 0.34819E+01, 0.34907E+01, 0.34994E+01, 0.35081E+01, 0.35167E+01,& - 0.35253E+01, 0.35339E+01, 0.35424E+01, 0.35508E+01, 0.35592E+01,& - 0.35676E+01, 0.35759E+01, 0.35842E+01, 0.35924E+01, 0.36006E+01,& - 0.36087E+01, 0.36168E+01, 0.36248E+01, 0.36328E+01, 0.36408E+01,& - 0.36487E+01, 0.36565E+01, 0.36644E+01, 0.36721E+01, 0.36799E+01,& - 0.36876E+01 / -! -! ** (NH4)3H(SO4)2 -! - DATA (BNC13M (IA),IA= 1,100)/ & - -0.84167E-01,-0.15304E+00,-0.20142E+00,-0.23431E+00,-0.25963E+00,& - -0.28033E+00,-0.29790E+00,-0.31317E+00,-0.32669E+00,-0.33881E+00,& - -0.34980E+00,-0.35984E+00,-0.36908E+00,-0.37764E+00,-0.38559E+00,& - -0.39302E+00,-0.39999E+00,-0.40654E+00,-0.41272E+00,-0.41855E+00,& - -0.42408E+00,-0.42933E+00,-0.43431E+00,-0.43905E+00,-0.44357E+00,& - -0.44789E+00,-0.45200E+00,-0.45594E+00,-0.45971E+00,-0.46332E+00,& - -0.46677E+00,-0.47008E+00,-0.47326E+00,-0.47631E+00,-0.47923E+00,& - -0.48204E+00,-0.48474E+00,-0.48734E+00,-0.48983E+00,-0.49223E+00,& - -0.49453E+00,-0.49675E+00,-0.49888E+00,-0.50093E+00,-0.50290E+00,& - -0.50480E+00,-0.50662E+00,-0.50838E+00,-0.51007E+00,-0.51169E+00,& - -0.51325E+00,-0.51476E+00,-0.51620E+00,-0.51759E+00,-0.51893E+00,& - -0.52021E+00,-0.52145E+00,-0.52263E+00,-0.52378E+00,-0.52487E+00,& - -0.52592E+00,-0.52693E+00,-0.52790E+00,-0.52883E+00,-0.52972E+00,& - -0.53058E+00,-0.53139E+00,-0.53218E+00,-0.53292E+00,-0.53364E+00,& - -0.53432E+00,-0.53498E+00,-0.53560E+00,-0.53619E+00,-0.53675E+00,& - -0.53729E+00,-0.53780E+00,-0.53828E+00,-0.53873E+00,-0.53916E+00,& - -0.53956E+00,-0.53994E+00,-0.54030E+00,-0.54063E+00,-0.54094E+00,& - -0.54122E+00,-0.54148E+00,-0.54173E+00,-0.54195E+00,-0.54215E+00,& - -0.54232E+00,-0.54248E+00,-0.54262E+00,-0.54275E+00,-0.54285E+00,& - -0.54293E+00,-0.54300E+00,-0.54305E+00,-0.54308E+00,-0.54310E+00/ - - DATA (BNC13M (IA),IA=101,200)/ & - -0.54310E+00,-0.54309E+00,-0.54306E+00,-0.54302E+00,-0.54296E+00,& - -0.54289E+00,-0.54281E+00,-0.54272E+00,-0.54261E+00,-0.54249E+00,& - -0.54236E+00,-0.54222E+00,-0.54207E+00,-0.54191E+00,-0.54174E+00,& - -0.54156E+00,-0.54137E+00,-0.54117E+00,-0.54097E+00,-0.54075E+00,& - -0.54062E+00,-0.54039E+00,-0.54014E+00,-0.53989E+00,-0.53964E+00,& - -0.53937E+00,-0.53911E+00,-0.53884E+00,-0.53856E+00,-0.53828E+00,& - -0.53800E+00,-0.53771E+00,-0.53742E+00,-0.53712E+00,-0.53682E+00,& - -0.53652E+00,-0.53621E+00,-0.53590E+00,-0.53559E+00,-0.53527E+00,& - -0.53495E+00,-0.53463E+00,-0.53430E+00,-0.53397E+00,-0.53364E+00,& - -0.53331E+00,-0.53297E+00,-0.53264E+00,-0.53230E+00,-0.53195E+00,& - -0.53161E+00,-0.53126E+00,-0.53092E+00,-0.53057E+00,-0.53022E+00,& - -0.52986E+00,-0.52951E+00,-0.52915E+00,-0.52879E+00,-0.52844E+00,& - -0.52808E+00,-0.52771E+00,-0.52735E+00,-0.52699E+00,-0.52662E+00,& - -0.52626E+00,-0.52589E+00,-0.52552E+00,-0.52515E+00,-0.52479E+00,& - -0.52442E+00,-0.52404E+00,-0.52367E+00,-0.52330E+00,-0.52293E+00,& - -0.52255E+00,-0.52218E+00,-0.52181E+00,-0.52143E+00,-0.52106E+00,& - -0.52068E+00,-0.52030E+00,-0.51993E+00,-0.51955E+00,-0.51918E+00,& - -0.51880E+00,-0.51842E+00,-0.51804E+00,-0.51767E+00,-0.51729E+00,& - -0.51691E+00,-0.51653E+00,-0.51615E+00,-0.51577E+00,-0.51540E+00,& - -0.51502E+00,-0.51464E+00,-0.51426E+00,-0.51388E+00,-0.51351E+00/ - - DATA (BNC13M (IA),IA=201,300)/ & - -0.51313E+00,-0.51275E+00,-0.51237E+00,-0.51199E+00,-0.51162E+00,& - -0.51124E+00,-0.51086E+00,-0.51049E+00,-0.51011E+00,-0.50973E+00,& - -0.50936E+00,-0.50898E+00,-0.50860E+00,-0.50823E+00,-0.50785E+00,& - -0.50748E+00,-0.50710E+00,-0.50673E+00,-0.50636E+00,-0.50598E+00,& - -0.50561E+00,-0.50524E+00,-0.50486E+00,-0.50449E+00,-0.50412E+00,& - -0.50375E+00,-0.50338E+00,-0.50301E+00,-0.50264E+00,-0.50227E+00,& - -0.50190E+00,-0.50153E+00,-0.50116E+00,-0.50079E+00,-0.50043E+00,& - -0.50006E+00,-0.49969E+00,-0.49933E+00,-0.49896E+00,-0.49860E+00,& - -0.49823E+00,-0.49787E+00,-0.49750E+00,-0.49714E+00,-0.49678E+00,& - -0.49642E+00,-0.49606E+00,-0.49569E+00,-0.49533E+00,-0.49497E+00,& - -0.49461E+00,-0.49426E+00,-0.49390E+00,-0.49354E+00,-0.49318E+00,& - -0.49283E+00,-0.49247E+00,-0.49211E+00,-0.49176E+00,-0.49141E+00,& - -0.49105E+00,-0.49070E+00,-0.49035E+00,-0.48999E+00,-0.48964E+00,& - -0.48929E+00,-0.48894E+00,-0.48859E+00,-0.48824E+00,-0.48789E+00,& - -0.48755E+00,-0.48720E+00,-0.48685E+00,-0.48651E+00,-0.48616E+00,& - -0.48581E+00,-0.48547E+00,-0.48513E+00,-0.48478E+00,-0.48444E+00,& - -0.48410E+00,-0.48376E+00,-0.48342E+00,-0.48308E+00,-0.48274E+00,& - -0.48240E+00,-0.48206E+00,-0.48172E+00,-0.48138E+00,-0.48105E+00,& - -0.48071E+00,-0.48038E+00,-0.48004E+00,-0.47971E+00,-0.47938E+00,& - -0.47904E+00,-0.47871E+00,-0.47838E+00,-0.47805E+00,-0.47772E+00/ - - DATA (BNC13M (IA),IA=301,400)/ & - -0.47739E+00,-0.47706E+00,-0.47673E+00,-0.47640E+00,-0.47608E+00,& - -0.47575E+00,-0.47542E+00,-0.47510E+00,-0.47477E+00,-0.47445E+00,& - -0.47413E+00,-0.47380E+00,-0.47348E+00,-0.47316E+00,-0.47284E+00,& - -0.47252E+00,-0.47220E+00,-0.47188E+00,-0.47156E+00,-0.47124E+00,& - -0.47093E+00,-0.47061E+00,-0.47029E+00,-0.46998E+00,-0.46966E+00,& - -0.46935E+00,-0.46903E+00,-0.46872E+00,-0.46841E+00,-0.46810E+00,& - -0.46779E+00,-0.46748E+00,-0.46717E+00,-0.46686E+00,-0.46655E+00,& - -0.46624E+00,-0.46593E+00,-0.46563E+00,-0.46532E+00,-0.46502E+00,& - -0.46471E+00,-0.46441E+00,-0.46410E+00,-0.46380E+00,-0.46350E+00,& - -0.46320E+00,-0.46289E+00,-0.46259E+00,-0.46229E+00,-0.46200E+00,& - -0.46170E+00,-0.46140E+00,-0.46110E+00,-0.46080E+00,-0.46051E+00,& - -0.46021E+00,-0.45992E+00,-0.45962E+00,-0.45933E+00,-0.45904E+00,& - -0.45874E+00,-0.45845E+00,-0.45816E+00,-0.45787E+00,-0.45758E+00,& - -0.45729E+00,-0.45700E+00,-0.45671E+00,-0.45642E+00,-0.45614E+00,& - -0.45585E+00,-0.45556E+00,-0.45528E+00,-0.45499E+00,-0.45471E+00,& - -0.45442E+00,-0.45414E+00,-0.45386E+00,-0.45358E+00,-0.45330E+00,& - -0.45302E+00,-0.45274E+00,-0.45246E+00,-0.45218E+00,-0.45190E+00,& - -0.45162E+00,-0.45134E+00,-0.45107E+00,-0.45079E+00,-0.45051E+00,& - -0.45024E+00,-0.44997E+00,-0.44969E+00,-0.44942E+00,-0.44915E+00,& - -0.44887E+00,-0.44860E+00,-0.44833E+00,-0.44806E+00,-0.44779E+00/ - - DATA (BNC13M (IA),IA=401,500)/ & - -0.44752E+00,-0.44725E+00,-0.44699E+00,-0.44672E+00,-0.44645E+00,& - -0.44619E+00,-0.44592E+00,-0.44565E+00,-0.44539E+00,-0.44513E+00,& - -0.44486E+00,-0.44460E+00,-0.44434E+00,-0.44408E+00,-0.44381E+00,& - -0.44355E+00,-0.44329E+00,-0.44303E+00,-0.44277E+00,-0.44252E+00,& - -0.44226E+00,-0.44200E+00,-0.44174E+00,-0.44149E+00,-0.44123E+00,& - -0.44098E+00,-0.44072E+00,-0.44047E+00,-0.44021E+00,-0.43996E+00,& - -0.43971E+00,-0.43946E+00,-0.43921E+00,-0.43896E+00,-0.43870E+00,& - -0.43846E+00,-0.43821E+00,-0.43796E+00,-0.43771E+00,-0.43746E+00,& - -0.43721E+00,-0.43697E+00,-0.43672E+00,-0.43648E+00,-0.43623E+00,& - -0.43599E+00,-0.43574E+00,-0.43550E+00,-0.43526E+00,-0.43502E+00,& - -0.43477E+00,-0.43453E+00,-0.43429E+00,-0.43405E+00,-0.43381E+00,& - -0.43357E+00,-0.43333E+00,-0.43310E+00,-0.43286E+00,-0.43262E+00,& - -0.43238E+00,-0.43215E+00,-0.43191E+00,-0.43168E+00,-0.43144E+00,& - -0.43121E+00,-0.43098E+00,-0.43074E+00,-0.43051E+00,-0.43028E+00,& - -0.43005E+00,-0.42982E+00,-0.42959E+00,-0.42936E+00,-0.42913E+00,& - -0.42890E+00,-0.42867E+00,-0.42844E+00,-0.42821E+00,-0.42799E+00,& - -0.42776E+00,-0.42754E+00,-0.42731E+00,-0.42708E+00,-0.42686E+00,& - -0.42664E+00,-0.42641E+00,-0.42619E+00,-0.42597E+00,-0.42575E+00,& - -0.42552E+00,-0.42530E+00,-0.42508E+00,-0.42486E+00,-0.42464E+00,& - -0.42442E+00,-0.42421E+00,-0.42399E+00,-0.42377E+00,-0.42355E+00/ - - DATA (BNC13M (IA),IA=501,600)/ & - -0.42334E+00,-0.42312E+00,-0.42290E+00,-0.42269E+00,-0.42248E+00,& - -0.42226E+00,-0.42205E+00,-0.42183E+00,-0.42162E+00,-0.42141E+00,& - -0.42120E+00,-0.42099E+00,-0.42077E+00,-0.42056E+00,-0.42035E+00,& - -0.42014E+00,-0.41994E+00,-0.41973E+00,-0.41952E+00,-0.41931E+00,& - -0.41910E+00,-0.41890E+00,-0.41869E+00,-0.41849E+00,-0.41828E+00,& - -0.41808E+00,-0.41787E+00,-0.41767E+00,-0.41746E+00,-0.41726E+00,& - -0.41706E+00,-0.41686E+00,-0.41665E+00,-0.41645E+00,-0.41625E+00,& - -0.41605E+00,-0.41585E+00,-0.41565E+00,-0.41545E+00,-0.41526E+00,& - -0.41506E+00,-0.41486E+00,-0.41466E+00,-0.41447E+00,-0.41427E+00,& - -0.41407E+00,-0.41388E+00,-0.41368E+00,-0.41349E+00,-0.41329E+00,& - -0.41310E+00,-0.41291E+00,-0.41272E+00,-0.41252E+00,-0.41233E+00,& - -0.41214E+00,-0.41195E+00,-0.41176E+00,-0.41157E+00,-0.41138E+00,& - -0.41119E+00,-0.41100E+00,-0.41081E+00,-0.41062E+00,-0.41044E+00,& - -0.41025E+00,-0.41006E+00,-0.40988E+00,-0.40969E+00,-0.40950E+00,& - -0.40932E+00,-0.40914E+00,-0.40895E+00,-0.40877E+00,-0.40858E+00,& - -0.40840E+00,-0.40822E+00,-0.40804E+00,-0.40785E+00,-0.40767E+00,& - -0.40749E+00,-0.40731E+00,-0.40713E+00,-0.40695E+00,-0.40677E+00,& - -0.40659E+00,-0.40642E+00,-0.40624E+00,-0.40606E+00,-0.40588E+00,& - -0.40571E+00,-0.40553E+00,-0.40535E+00,-0.40518E+00,-0.40500E+00,& - -0.40483E+00,-0.40466E+00,-0.40448E+00,-0.40431E+00,-0.40366E+00/ - - DATA (BNC13M (IA),IA=601,700)/ & - -0.40226E+00,-0.40059E+00,-0.39896E+00,-0.39738E+00,-0.39582E+00,& - -0.39431E+00,-0.39283E+00,-0.39138E+00,-0.38998E+00,-0.38860E+00,& - -0.38726E+00,-0.38595E+00,-0.38467E+00,-0.38343E+00,-0.38221E+00,& - -0.38103E+00,-0.37988E+00,-0.37876E+00,-0.37766E+00,-0.37660E+00,& - -0.37556E+00,-0.37455E+00,-0.37357E+00,-0.37261E+00,-0.37169E+00,& - -0.37078E+00,-0.36991E+00,-0.36906E+00,-0.36823E+00,-0.36743E+00,& - -0.36665E+00,-0.36590E+00,-0.36516E+00,-0.36446E+00,-0.36377E+00,& - -0.36311E+00,-0.36247E+00,-0.36185E+00,-0.36125E+00,-0.36067E+00,& - -0.36012E+00,-0.35958E+00,-0.35907E+00,-0.35857E+00,-0.35809E+00,& - -0.35764E+00,-0.35720E+00,-0.35678E+00,-0.35638E+00,-0.35600E+00,& - -0.35563E+00,-0.35529E+00,-0.35496E+00,-0.35465E+00,-0.35435E+00,& - -0.35407E+00,-0.35381E+00,-0.35357E+00,-0.35334E+00,-0.35313E+00,& - -0.35293E+00,-0.35275E+00,-0.35258E+00,-0.35243E+00,-0.35229E+00,& - -0.35217E+00,-0.35206E+00,-0.35197E+00,-0.35189E+00,-0.35183E+00,& - -0.35178E+00,-0.35174E+00,-0.35172E+00,-0.35171E+00,-0.35171E+00,& - -0.35173E+00,-0.35176E+00,-0.35180E+00,-0.35186E+00,-0.35193E+00,& - -0.35201E+00,-0.35210E+00,-0.35220E+00,-0.35232E+00,-0.35245E+00,& - -0.35258E+00,-0.35274E+00,-0.35290E+00,-0.35307E+00,-0.35326E+00,& - -0.35345E+00,-0.35366E+00,-0.35387E+00,-0.35410E+00,-0.35434E+00,& - -0.35459E+00,-0.35485E+00,-0.35512E+00,-0.35540E+00,-0.35569E+00/ - - DATA (BNC13M(IA),IA=701,741)/ & - -0.35599E+00,-0.35629E+00,-0.35661E+00,-0.35694E+00,-0.35728E+00,& - -0.35763E+00,-0.35798E+00,-0.35835E+00,-0.35872E+00,-0.35911E+00,& - -0.35950E+00,-0.35990E+00,-0.36031E+00,-0.36073E+00,-0.36116E+00,& - -0.36159E+00,-0.36204E+00,-0.36249E+00,-0.36295E+00,-0.36342E+00,& - -0.36390E+00,-0.36438E+00,-0.36487E+00,-0.36538E+00,-0.36588E+00,& - -0.36640E+00,-0.36692E+00,-0.36746E+00,-0.36799E+00,-0.36854E+00,& - -0.36909E+00,-0.36966E+00,-0.37022E+00,-0.37080E+00,-0.37138E+00,& - -0.37197E+00,-0.37257E+00,-0.37317E+00,-0.37378E+00,-0.37440E+00,& - -0.37502E+00 / -! END - -! ** TEMP = 298.0 - -! BLOCK DATA KMCF298 -! -! ** Common block definition -! -! COMMON /KMC298/ & -! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & -! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & -! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & -! BNC13M( 741) -! -! ** NaCl -! - DATA (BNC01M (IA),IA= 1,100)/ & - -0.49998E-01,-0.88352E-01,-0.11333E+00,-0.12907E+00,-0.14035E+00,& - -0.14892E+00,-0.15567E+00,-0.16110E+00,-0.16552E+00,-0.16915E+00,& - -0.17214E+00,-0.17461E+00,-0.17663E+00,-0.17828E+00,-0.17961E+00,& - -0.18066E+00,-0.18146E+00,-0.18205E+00,-0.18245E+00,-0.18268E+00,& - -0.18276E+00,-0.18270E+00,-0.18252E+00,-0.18222E+00,-0.18183E+00,& - -0.18134E+00,-0.18077E+00,-0.18013E+00,-0.17941E+00,-0.17864E+00,& - -0.17780E+00,-0.17691E+00,-0.17598E+00,-0.17500E+00,-0.17397E+00,& - -0.17292E+00,-0.17182E+00,-0.17070E+00,-0.16955E+00,-0.16837E+00,& - -0.16717E+00,-0.16594E+00,-0.16470E+00,-0.16343E+00,-0.16215E+00,& - -0.16086E+00,-0.15955E+00,-0.15823E+00,-0.15690E+00,-0.15555E+00,& - -0.15420E+00,-0.15283E+00,-0.15146E+00,-0.15008E+00,-0.14869E+00,& - -0.14729E+00,-0.14589E+00,-0.14448E+00,-0.14306E+00,-0.14163E+00,& - -0.14020E+00,-0.13877E+00,-0.13732E+00,-0.13587E+00,-0.13441E+00,& - -0.13294E+00,-0.13147E+00,-0.12999E+00,-0.12850E+00,-0.12700E+00,& - -0.12549E+00,-0.12397E+00,-0.12245E+00,-0.12091E+00,-0.11936E+00,& - -0.11781E+00,-0.11624E+00,-0.11466E+00,-0.11307E+00,-0.11147E+00,& - -0.10985E+00,-0.10823E+00,-0.10659E+00,-0.10493E+00,-0.10327E+00,& - -0.10159E+00,-0.99900E-01,-0.98196E-01,-0.96479E-01,-0.94748E-01,& - -0.93005E-01,-0.91248E-01,-0.89479E-01,-0.87697E-01,-0.85902E-01,& - -0.84096E-01,-0.82277E-01,-0.80446E-01,-0.78604E-01,-0.76751E-01/ - - DATA (BNC01M (IA),IA=101,200)/ & - -0.74887E-01,-0.73013E-01,-0.71128E-01,-0.69234E-01,-0.67331E-01,& - -0.65418E-01,-0.63498E-01,-0.61569E-01,-0.59633E-01,-0.57689E-01,& - -0.55739E-01,-0.53782E-01,-0.51819E-01,-0.49851E-01,-0.47877E-01,& - -0.45899E-01,-0.43917E-01,-0.41930E-01,-0.39940E-01,-0.37946E-01,& - -0.36169E-01,-0.34144E-01,-0.32120E-01,-0.30095E-01,-0.28071E-01,& - -0.26048E-01,-0.24024E-01,-0.22002E-01,-0.19979E-01,-0.17958E-01,& - -0.15937E-01,-0.13916E-01,-0.11897E-01,-0.98784E-02,-0.78606E-02,& - -0.58439E-02,-0.38280E-02,-0.18133E-02, 0.20048E-03, 0.22131E-02,& - 0.42245E-02, 0.62347E-02, 0.82436E-02, 0.10251E-01, 0.12258E-01,& - 0.14263E-01, 0.16266E-01, 0.18268E-01, 0.20269E-01, 0.22268E-01,& - 0.24266E-01, 0.26262E-01, 0.28256E-01, 0.30249E-01, 0.32240E-01,& - 0.34229E-01, 0.36217E-01, 0.38203E-01, 0.40187E-01, 0.42170E-01,& - 0.44150E-01, 0.46129E-01, 0.48106E-01, 0.50081E-01, 0.52054E-01,& - 0.54025E-01, 0.55994E-01, 0.57961E-01, 0.59926E-01, 0.61889E-01,& - 0.63850E-01, 0.65809E-01, 0.67766E-01, 0.69721E-01, 0.71674E-01,& - 0.73625E-01, 0.75573E-01, 0.77519E-01, 0.79464E-01, 0.81406E-01,& - 0.83345E-01, 0.85283E-01, 0.87218E-01, 0.89152E-01, 0.91082E-01,& - 0.93011E-01, 0.94937E-01, 0.96862E-01, 0.98783E-01, 0.10070E+00,& - 0.10262E+00, 0.10453E+00, 0.10645E+00, 0.10836E+00, 0.11027E+00,& - 0.11217E+00, 0.11407E+00, 0.11597E+00, 0.11787E+00, 0.11977E+00/ - - DATA (BNC01M (IA),IA=201,300)/ & - 0.12166E+00, 0.12355E+00, 0.12544E+00, 0.12733E+00, 0.12921E+00,& - 0.13109E+00, 0.13297E+00, 0.13485E+00, 0.13672E+00, 0.13860E+00,& - 0.14047E+00, 0.14233E+00, 0.14420E+00, 0.14606E+00, 0.14792E+00,& - 0.14978E+00, 0.15163E+00, 0.15348E+00, 0.15533E+00, 0.15718E+00,& - 0.15902E+00, 0.16087E+00, 0.16271E+00, 0.16454E+00, 0.16638E+00,& - 0.16821E+00, 0.17004E+00, 0.17187E+00, 0.17369E+00, 0.17551E+00,& - 0.17733E+00, 0.17915E+00, 0.18097E+00, 0.18278E+00, 0.18459E+00,& - 0.18640E+00, 0.18820E+00, 0.19000E+00, 0.19180E+00, 0.19360E+00,& - 0.19540E+00, 0.19719E+00, 0.19898E+00, 0.20076E+00, 0.20255E+00,& - 0.20433E+00, 0.20611E+00, 0.20789E+00, 0.20966E+00, 0.21144E+00,& - 0.21321E+00, 0.21497E+00, 0.21674E+00, 0.21850E+00, 0.22026E+00,& - 0.22202E+00, 0.22377E+00, 0.22553E+00, 0.22727E+00, 0.22902E+00,& - 0.23077E+00, 0.23251E+00, 0.23425E+00, 0.23599E+00, 0.23772E+00,& - 0.23946E+00, 0.24119E+00, 0.24291E+00, 0.24464E+00, 0.24636E+00,& - 0.24808E+00, 0.24980E+00, 0.25152E+00, 0.25323E+00, 0.25494E+00,& - 0.25665E+00, 0.25835E+00, 0.26006E+00, 0.26176E+00, 0.26346E+00,& - 0.26515E+00, 0.26684E+00, 0.26854E+00, 0.27022E+00, 0.27191E+00,& - 0.27360E+00, 0.27528E+00, 0.27696E+00, 0.27863E+00, 0.28031E+00,& - 0.28198E+00, 0.28365E+00, 0.28532E+00, 0.28698E+00, 0.28864E+00,& - 0.29030E+00, 0.29196E+00, 0.29362E+00, 0.29527E+00, 0.29692E+00/ - - DATA (BNC01M (IA),IA=301,400)/ & - 0.29857E+00, 0.30021E+00, 0.30186E+00, 0.30350E+00, 0.30514E+00,& - 0.30677E+00, 0.30841E+00, 0.31004E+00, 0.31167E+00, 0.31330E+00,& - 0.31492E+00, 0.31654E+00, 0.31816E+00, 0.31978E+00, 0.32140E+00,& - 0.32301E+00, 0.32462E+00, 0.32623E+00, 0.32784E+00, 0.32944E+00,& - 0.33104E+00, 0.33264E+00, 0.33424E+00, 0.33584E+00, 0.33743E+00,& - 0.33902E+00, 0.34061E+00, 0.34219E+00, 0.34378E+00, 0.34536E+00,& - 0.34694E+00, 0.34852E+00, 0.35009E+00, 0.35166E+00, 0.35323E+00,& - 0.35480E+00, 0.35637E+00, 0.35793E+00, 0.35949E+00, 0.36105E+00,& - 0.36261E+00, 0.36417E+00, 0.36572E+00, 0.36727E+00, 0.36882E+00,& - 0.37036E+00, 0.37191E+00, 0.37345E+00, 0.37499E+00, 0.37653E+00,& - 0.37806E+00, 0.37960E+00, 0.38113E+00, 0.38266E+00, 0.38419E+00,& - 0.38571E+00, 0.38723E+00, 0.38875E+00, 0.39027E+00, 0.39179E+00,& - 0.39330E+00, 0.39482E+00, 0.39633E+00, 0.39783E+00, 0.39934E+00,& - 0.40084E+00, 0.40235E+00, 0.40384E+00, 0.40534E+00, 0.40684E+00,& - 0.40833E+00, 0.40982E+00, 0.41131E+00, 0.41280E+00, 0.41429E+00,& - 0.41577E+00, 0.41725E+00, 0.41873E+00, 0.42021E+00, 0.42168E+00,& - 0.42315E+00, 0.42463E+00, 0.42609E+00, 0.42756E+00, 0.42903E+00,& - 0.43049E+00, 0.43195E+00, 0.43341E+00, 0.43487E+00, 0.43632E+00,& - 0.43778E+00, 0.43923E+00, 0.44068E+00, 0.44212E+00, 0.44357E+00,& - 0.44501E+00, 0.44645E+00, 0.44789E+00, 0.44933E+00, 0.45077E+00/ - - DATA (BNC01M (IA),IA=401,500)/ & - 0.45220E+00, 0.45363E+00, 0.45506E+00, 0.45649E+00, 0.45792E+00,& - 0.45934E+00, 0.46076E+00, 0.46218E+00, 0.46360E+00, 0.46502E+00,& - 0.46643E+00, 0.46784E+00, 0.46926E+00, 0.47066E+00, 0.47207E+00,& - 0.47348E+00, 0.47488E+00, 0.47628E+00, 0.47768E+00, 0.47908E+00,& - 0.48047E+00, 0.48187E+00, 0.48326E+00, 0.48465E+00, 0.48604E+00,& - 0.48743E+00, 0.48881E+00, 0.49019E+00, 0.49157E+00, 0.49295E+00,& - 0.49433E+00, 0.49571E+00, 0.49708E+00, 0.49845E+00, 0.49982E+00,& - 0.50119E+00, 0.50256E+00, 0.50392E+00, 0.50529E+00, 0.50665E+00,& - 0.50801E+00, 0.50937E+00, 0.51072E+00, 0.51208E+00, 0.51343E+00,& - 0.51478E+00, 0.51613E+00, 0.51748E+00, 0.51882E+00, 0.52017E+00,& - 0.52151E+00, 0.52285E+00, 0.52419E+00, 0.52553E+00, 0.52686E+00,& - 0.52819E+00, 0.52953E+00, 0.53086E+00, 0.53218E+00, 0.53351E+00,& - 0.53484E+00, 0.53616E+00, 0.53748E+00, 0.53880E+00, 0.54012E+00,& - 0.54144E+00, 0.54275E+00, 0.54406E+00, 0.54538E+00, 0.54669E+00,& - 0.54799E+00, 0.54930E+00, 0.55061E+00, 0.55191E+00, 0.55321E+00,& - 0.55451E+00, 0.55581E+00, 0.55711E+00, 0.55840E+00, 0.55970E+00,& - 0.56099E+00, 0.56228E+00, 0.56357E+00, 0.56485E+00, 0.56614E+00,& - 0.56742E+00, 0.56870E+00, 0.56999E+00, 0.57126E+00, 0.57254E+00,& - 0.57382E+00, 0.57509E+00, 0.57637E+00, 0.57764E+00, 0.57891E+00,& - 0.58017E+00, 0.58144E+00, 0.58271E+00, 0.58397E+00, 0.58523E+00/ - - DATA (BNC01M (IA),IA=501,600)/ & - 0.58649E+00, 0.58775E+00, 0.58901E+00, 0.59026E+00, 0.59152E+00,& - 0.59277E+00, 0.59402E+00, 0.59527E+00, 0.59652E+00, 0.59776E+00,& - 0.59901E+00, 0.60025E+00, 0.60149E+00, 0.60273E+00, 0.60397E+00,& - 0.60521E+00, 0.60645E+00, 0.60768E+00, 0.60891E+00, 0.61014E+00,& - 0.61137E+00, 0.61260E+00, 0.61383E+00, 0.61506E+00, 0.61628E+00,& - 0.61750E+00, 0.61872E+00, 0.61994E+00, 0.62116E+00, 0.62238E+00,& - 0.62359E+00, 0.62481E+00, 0.62602E+00, 0.62723E+00, 0.62844E+00,& - 0.62965E+00, 0.63085E+00, 0.63206E+00, 0.63326E+00, 0.63446E+00,& - 0.63567E+00, 0.63687E+00, 0.63806E+00, 0.63926E+00, 0.64045E+00,& - 0.64165E+00, 0.64284E+00, 0.64403E+00, 0.64522E+00, 0.64641E+00,& - 0.64760E+00, 0.64878E+00, 0.64997E+00, 0.65115E+00, 0.65233E+00,& - 0.65351E+00, 0.65469E+00, 0.65587E+00, 0.65704E+00, 0.65822E+00,& - 0.65939E+00, 0.66056E+00, 0.66173E+00, 0.66290E+00, 0.66407E+00,& - 0.66523E+00, 0.66640E+00, 0.66756E+00, 0.66872E+00, 0.66988E+00,& - 0.67104E+00, 0.67220E+00, 0.67336E+00, 0.67452E+00, 0.67567E+00,& - 0.67682E+00, 0.67797E+00, 0.67912E+00, 0.68027E+00, 0.68142E+00,& - 0.68257E+00, 0.68371E+00, 0.68486E+00, 0.68600E+00, 0.68714E+00,& - 0.68828E+00, 0.68942E+00, 0.69056E+00, 0.69169E+00, 0.69283E+00,& - 0.69396E+00, 0.69509E+00, 0.69622E+00, 0.69735E+00, 0.69848E+00,& - 0.69961E+00, 0.70073E+00, 0.70186E+00, 0.70298E+00, 0.70718E+00/ - - DATA (BNC01M (IA),IA=601,700)/ & - 0.71636E+00, 0.72738E+00, 0.73828E+00, 0.74906E+00, 0.75972E+00,& - 0.77027E+00, 0.78071E+00, 0.79104E+00, 0.80127E+00, 0.81139E+00,& - 0.82141E+00, 0.83133E+00, 0.84115E+00, 0.85087E+00, 0.86050E+00,& - 0.87004E+00, 0.87948E+00, 0.88883E+00, 0.89810E+00, 0.90728E+00,& - 0.91638E+00, 0.92539E+00, 0.93432E+00, 0.94316E+00, 0.95193E+00,& - 0.96063E+00, 0.96924E+00, 0.97778E+00, 0.98625E+00, 0.99464E+00,& - 0.10030E+01, 0.10112E+01, 0.10194E+01, 0.10275E+01, 0.10356E+01,& - 0.10435E+01, 0.10515E+01, 0.10593E+01, 0.10671E+01, 0.10748E+01,& - 0.10825E+01, 0.10901E+01, 0.10977E+01, 0.11051E+01, 0.11126E+01,& - 0.11200E+01, 0.11273E+01, 0.11345E+01, 0.11418E+01, 0.11489E+01,& - 0.11560E+01, 0.11631E+01, 0.11701E+01, 0.11770E+01, 0.11839E+01,& - 0.11908E+01, 0.11976E+01, 0.12044E+01, 0.12111E+01, 0.12177E+01,& - 0.12244E+01, 0.12309E+01, 0.12375E+01, 0.12440E+01, 0.12504E+01,& - 0.12568E+01, 0.12632E+01, 0.12695E+01, 0.12758E+01, 0.12820E+01,& - 0.12882E+01, 0.12943E+01, 0.13005E+01, 0.13065E+01, 0.13126E+01,& - 0.13186E+01, 0.13246E+01, 0.13305E+01, 0.13364E+01, 0.13422E+01,& - 0.13481E+01, 0.13539E+01, 0.13596E+01, 0.13653E+01, 0.13710E+01,& - 0.13767E+01, 0.13823E+01, 0.13879E+01, 0.13934E+01, 0.13990E+01,& - 0.14044E+01, 0.14099E+01, 0.14153E+01, 0.14207E+01, 0.14261E+01,& - 0.14314E+01, 0.14368E+01, 0.14420E+01, 0.14473E+01, 0.14525E+01/ - - DATA (BNC01M(IA),IA=701,741)/ & - 0.14577E+01, 0.14629E+01, 0.14680E+01, 0.14731E+01, 0.14782E+01,& - 0.14833E+01, 0.14883E+01, 0.14933E+01, 0.14983E+01, 0.15033E+01,& - 0.15082E+01, 0.15131E+01, 0.15180E+01, 0.15228E+01, 0.15277E+01,& - 0.15325E+01, 0.15372E+01, 0.15420E+01, 0.15467E+01, 0.15515E+01,& - 0.15561E+01, 0.15608E+01, 0.15655E+01, 0.15701E+01, 0.15747E+01,& - 0.15793E+01, 0.15838E+01, 0.15884E+01, 0.15929E+01, 0.15974E+01,& - 0.16018E+01, 0.16063E+01, 0.16107E+01, 0.16151E+01, 0.16195E+01,& - 0.16239E+01, 0.16282E+01, 0.16326E+01, 0.16369E+01, 0.16412E+01,& - 0.16454E+01 / -! -! ** Na2SO4 -! - DATA (BNC02M (IA),IA= 1,100)/ & - -0.10298E+00,-0.18764E+00,-0.24726E+00,-0.28786E+00,-0.31914E+00,& - -0.34476E+00,-0.36652E+00,-0.38546E+00,-0.40225E+00,-0.41734E+00,& - -0.43104E+00,-0.44360E+00,-0.45519E+00,-0.46595E+00,-0.47599E+00,& - -0.48541E+00,-0.49427E+00,-0.50264E+00,-0.51057E+00,-0.51811E+00,& - -0.52529E+00,-0.53214E+00,-0.53869E+00,-0.54497E+00,-0.55100E+00,& - -0.55680E+00,-0.56238E+00,-0.56776E+00,-0.57295E+00,-0.57797E+00,& - -0.58283E+00,-0.58753E+00,-0.59209E+00,-0.59651E+00,-0.60081E+00,& - -0.60498E+00,-0.60904E+00,-0.61298E+00,-0.61683E+00,-0.62058E+00,& - -0.62423E+00,-0.62779E+00,-0.63127E+00,-0.63466E+00,-0.63798E+00,& - -0.64123E+00,-0.64440E+00,-0.64750E+00,-0.65054E+00,-0.65351E+00,& - -0.65642E+00,-0.65928E+00,-0.66208E+00,-0.66482E+00,-0.66751E+00,& - -0.67015E+00,-0.67275E+00,-0.67529E+00,-0.67779E+00,-0.68025E+00,& - -0.68267E+00,-0.68504E+00,-0.68738E+00,-0.68968E+00,-0.69194E+00,& - -0.69416E+00,-0.69636E+00,-0.69852E+00,-0.70064E+00,-0.70274E+00,& - -0.70481E+00,-0.70685E+00,-0.70886E+00,-0.71084E+00,-0.71280E+00,& - -0.71473E+00,-0.71663E+00,-0.71852E+00,-0.72038E+00,-0.72221E+00,& - -0.72403E+00,-0.72583E+00,-0.72760E+00,-0.72935E+00,-0.73109E+00,& - -0.73281E+00,-0.73450E+00,-0.73618E+00,-0.73785E+00,-0.73949E+00,& - -0.74112E+00,-0.74274E+00,-0.74434E+00,-0.74592E+00,-0.74749E+00,& - -0.74904E+00,-0.75058E+00,-0.75210E+00,-0.75361E+00,-0.75511E+00/ - - DATA (BNC02M (IA),IA=101,200)/ & - -0.75660E+00,-0.75807E+00,-0.75953E+00,-0.76097E+00,-0.76241E+00,& - -0.76383E+00,-0.76524E+00,-0.76664E+00,-0.76803E+00,-0.76940E+00,& - -0.77077E+00,-0.77212E+00,-0.77346E+00,-0.77479E+00,-0.77612E+00,& - -0.77743E+00,-0.77873E+00,-0.78002E+00,-0.78130E+00,-0.78257E+00,& - -0.78379E+00,-0.78505E+00,-0.78629E+00,-0.78753E+00,-0.78876E+00,& - -0.78997E+00,-0.79118E+00,-0.79238E+00,-0.79357E+00,-0.79475E+00,& - -0.79592E+00,-0.79708E+00,-0.79824E+00,-0.79939E+00,-0.80052E+00,& - -0.80165E+00,-0.80277E+00,-0.80389E+00,-0.80499E+00,-0.80609E+00,& - -0.80718E+00,-0.80827E+00,-0.80934E+00,-0.81041E+00,-0.81147E+00,& - -0.81253E+00,-0.81358E+00,-0.81462E+00,-0.81565E+00,-0.81668E+00,& - -0.81770E+00,-0.81871E+00,-0.81972E+00,-0.82072E+00,-0.82172E+00,& - -0.82270E+00,-0.82369E+00,-0.82466E+00,-0.82563E+00,-0.82660E+00,& - -0.82756E+00,-0.82851E+00,-0.82946E+00,-0.83040E+00,-0.83133E+00,& - -0.83227E+00,-0.83319E+00,-0.83411E+00,-0.83503E+00,-0.83593E+00,& - -0.83684E+00,-0.83774E+00,-0.83863E+00,-0.83952E+00,-0.84040E+00,& - -0.84128E+00,-0.84216E+00,-0.84303E+00,-0.84389E+00,-0.84475E+00,& - -0.84561E+00,-0.84646E+00,-0.84731E+00,-0.84815E+00,-0.84898E+00,& - -0.84982E+00,-0.85065E+00,-0.85147E+00,-0.85229E+00,-0.85311E+00,& - -0.85392E+00,-0.85473E+00,-0.85553E+00,-0.85633E+00,-0.85712E+00,& - -0.85792E+00,-0.85870E+00,-0.85949E+00,-0.86027E+00,-0.86104E+00/ - - DATA (BNC02M (IA),IA=201,300)/ & - -0.86182E+00,-0.86258E+00,-0.86335E+00,-0.86411E+00,-0.86487E+00,& - -0.86562E+00,-0.86637E+00,-0.86712E+00,-0.86786E+00,-0.86860E+00,& - -0.86934E+00,-0.87007E+00,-0.87080E+00,-0.87153E+00,-0.87225E+00,& - -0.87297E+00,-0.87369E+00,-0.87440E+00,-0.87511E+00,-0.87582E+00,& - -0.87652E+00,-0.87722E+00,-0.87792E+00,-0.87862E+00,-0.87931E+00,& - -0.88000E+00,-0.88068E+00,-0.88136E+00,-0.88204E+00,-0.88272E+00,& - -0.88340E+00,-0.88407E+00,-0.88473E+00,-0.88540E+00,-0.88606E+00,& - -0.88672E+00,-0.88738E+00,-0.88804E+00,-0.88869E+00,-0.88934E+00,& - -0.88998E+00,-0.89063E+00,-0.89127E+00,-0.89191E+00,-0.89254E+00,& - -0.89318E+00,-0.89381E+00,-0.89444E+00,-0.89506E+00,-0.89569E+00,& - -0.89631E+00,-0.89693E+00,-0.89754E+00,-0.89816E+00,-0.89877E+00,& - -0.89938E+00,-0.89998E+00,-0.90059E+00,-0.90119E+00,-0.90179E+00,& - -0.90239E+00,-0.90299E+00,-0.90358E+00,-0.90417E+00,-0.90476E+00,& - -0.90535E+00,-0.90593E+00,-0.90651E+00,-0.90709E+00,-0.90767E+00,& - -0.90825E+00,-0.90882E+00,-0.90939E+00,-0.90996E+00,-0.91053E+00,& - -0.91110E+00,-0.91166E+00,-0.91222E+00,-0.91278E+00,-0.91334E+00,& - -0.91389E+00,-0.91445E+00,-0.91500E+00,-0.91555E+00,-0.91610E+00,& - -0.91664E+00,-0.91719E+00,-0.91773E+00,-0.91827E+00,-0.91881E+00,& - -0.91935E+00,-0.91988E+00,-0.92042E+00,-0.92095E+00,-0.92148E+00,& - -0.92201E+00,-0.92253E+00,-0.92306E+00,-0.92358E+00,-0.92410E+00/ - - DATA (BNC02M (IA),IA=301,400)/ & - -0.92462E+00,-0.92514E+00,-0.92565E+00,-0.92617E+00,-0.92668E+00,& - -0.92719E+00,-0.92770E+00,-0.92821E+00,-0.92871E+00,-0.92922E+00,& - -0.92972E+00,-0.93022E+00,-0.93072E+00,-0.93122E+00,-0.93171E+00,& - -0.93221E+00,-0.93270E+00,-0.93319E+00,-0.93368E+00,-0.93417E+00,& - -0.93466E+00,-0.93515E+00,-0.93563E+00,-0.93611E+00,-0.93659E+00,& - -0.93707E+00,-0.93755E+00,-0.93803E+00,-0.93850E+00,-0.93898E+00,& - -0.93945E+00,-0.93992E+00,-0.94039E+00,-0.94086E+00,-0.94133E+00,& - -0.94179E+00,-0.94226E+00,-0.94272E+00,-0.94318E+00,-0.94364E+00,& - -0.94410E+00,-0.94456E+00,-0.94501E+00,-0.94547E+00,-0.94592E+00,& - -0.94637E+00,-0.94682E+00,-0.94727E+00,-0.94772E+00,-0.94817E+00,& - -0.94861E+00,-0.94906E+00,-0.94950E+00,-0.94994E+00,-0.95038E+00,& - -0.95082E+00,-0.95126E+00,-0.95170E+00,-0.95213E+00,-0.95257E+00,& - -0.95300E+00,-0.95343E+00,-0.95386E+00,-0.95429E+00,-0.95472E+00,& - -0.95515E+00,-0.95557E+00,-0.95600E+00,-0.95642E+00,-0.95685E+00,& - -0.95727E+00,-0.95769E+00,-0.95811E+00,-0.95853E+00,-0.95894E+00,& - -0.95936E+00,-0.95977E+00,-0.96019E+00,-0.96060E+00,-0.96101E+00,& - -0.96142E+00,-0.96183E+00,-0.96224E+00,-0.96265E+00,-0.96305E+00,& - -0.96346E+00,-0.96386E+00,-0.96427E+00,-0.96467E+00,-0.96507E+00,& - -0.96547E+00,-0.96587E+00,-0.96627E+00,-0.96666E+00,-0.96706E+00,& - -0.96745E+00,-0.96785E+00,-0.96824E+00,-0.96863E+00,-0.96902E+00/ - - DATA (BNC02M (IA),IA=401,500)/ & - -0.96941E+00,-0.96980E+00,-0.97019E+00,-0.97058E+00,-0.97096E+00,& - -0.97135E+00,-0.97173E+00,-0.97211E+00,-0.97250E+00,-0.97288E+00,& - -0.97326E+00,-0.97364E+00,-0.97402E+00,-0.97439E+00,-0.97477E+00,& - -0.97515E+00,-0.97552E+00,-0.97589E+00,-0.97627E+00,-0.97664E+00,& - -0.97701E+00,-0.97738E+00,-0.97775E+00,-0.97812E+00,-0.97849E+00,& - -0.97885E+00,-0.97922E+00,-0.97958E+00,-0.97995E+00,-0.98031E+00,& - -0.98067E+00,-0.98104E+00,-0.98140E+00,-0.98176E+00,-0.98212E+00,& - -0.98247E+00,-0.98283E+00,-0.98319E+00,-0.98354E+00,-0.98390E+00,& - -0.98425E+00,-0.98461E+00,-0.98496E+00,-0.98531E+00,-0.98566E+00,& - -0.98601E+00,-0.98636E+00,-0.98671E+00,-0.98706E+00,-0.98741E+00,& - -0.98775E+00,-0.98810E+00,-0.98844E+00,-0.98879E+00,-0.98913E+00,& - -0.98947E+00,-0.98981E+00,-0.99015E+00,-0.99049E+00,-0.99083E+00,& - -0.99117E+00,-0.99151E+00,-0.99185E+00,-0.99218E+00,-0.99252E+00,& - -0.99285E+00,-0.99319E+00,-0.99352E+00,-0.99385E+00,-0.99419E+00,& - -0.99452E+00,-0.99485E+00,-0.99518E+00,-0.99551E+00,-0.99584E+00,& - -0.99616E+00,-0.99649E+00,-0.99682E+00,-0.99714E+00,-0.99747E+00,& - -0.99779E+00,-0.99812E+00,-0.99844E+00,-0.99876E+00,-0.99908E+00,& - -0.99940E+00,-0.99972E+00,-0.10000E+01,-0.10004E+01,-0.10007E+01,& - -0.10010E+01,-0.10013E+01,-0.10016E+01,-0.10019E+01,-0.10023E+01,& - -0.10026E+01,-0.10029E+01,-0.10032E+01,-0.10035E+01,-0.10038E+01/ - - DATA (BNC02M (IA),IA=501,600)/ & - -0.10041E+01,-0.10044E+01,-0.10048E+01,-0.10051E+01,-0.10054E+01,& - -0.10057E+01,-0.10060E+01,-0.10063E+01,-0.10066E+01,-0.10069E+01,& - -0.10072E+01,-0.10075E+01,-0.10078E+01,-0.10081E+01,-0.10084E+01,& - -0.10087E+01,-0.10090E+01,-0.10093E+01,-0.10096E+01,-0.10099E+01,& - -0.10102E+01,-0.10105E+01,-0.10108E+01,-0.10111E+01,-0.10114E+01,& - -0.10117E+01,-0.10120E+01,-0.10123E+01,-0.10126E+01,-0.10129E+01,& - -0.10132E+01,-0.10135E+01,-0.10138E+01,-0.10141E+01,-0.10144E+01,& - -0.10146E+01,-0.10149E+01,-0.10152E+01,-0.10155E+01,-0.10158E+01,& - -0.10161E+01,-0.10164E+01,-0.10167E+01,-0.10169E+01,-0.10172E+01,& - -0.10175E+01,-0.10178E+01,-0.10181E+01,-0.10184E+01,-0.10187E+01,& - -0.10189E+01,-0.10192E+01,-0.10195E+01,-0.10198E+01,-0.10201E+01,& - -0.10203E+01,-0.10206E+01,-0.10209E+01,-0.10212E+01,-0.10215E+01,& - -0.10217E+01,-0.10220E+01,-0.10223E+01,-0.10226E+01,-0.10228E+01,& - -0.10231E+01,-0.10234E+01,-0.10237E+01,-0.10239E+01,-0.10242E+01,& - -0.10245E+01,-0.10247E+01,-0.10250E+01,-0.10253E+01,-0.10256E+01,& - -0.10258E+01,-0.10261E+01,-0.10264E+01,-0.10266E+01,-0.10269E+01,& - -0.10272E+01,-0.10274E+01,-0.10277E+01,-0.10280E+01,-0.10282E+01,& - -0.10285E+01,-0.10288E+01,-0.10290E+01,-0.10293E+01,-0.10296E+01,& - -0.10298E+01,-0.10301E+01,-0.10303E+01,-0.10306E+01,-0.10309E+01,& - -0.10311E+01,-0.10314E+01,-0.10316E+01,-0.10319E+01,-0.10329E+01/ - - DATA (BNC02M (IA),IA=601,700)/ & - -0.10350E+01,-0.10375E+01,-0.10400E+01,-0.10424E+01,-0.10448E+01,& - -0.10471E+01,-0.10495E+01,-0.10517E+01,-0.10540E+01,-0.10562E+01,& - -0.10584E+01,-0.10605E+01,-0.10627E+01,-0.10647E+01,-0.10668E+01,& - -0.10688E+01,-0.10708E+01,-0.10728E+01,-0.10748E+01,-0.10767E+01,& - -0.10786E+01,-0.10805E+01,-0.10823E+01,-0.10841E+01,-0.10860E+01,& - -0.10877E+01,-0.10895E+01,-0.10912E+01,-0.10930E+01,-0.10947E+01,& - -0.10963E+01,-0.10980E+01,-0.10996E+01,-0.11013E+01,-0.11029E+01,& - -0.11044E+01,-0.11060E+01,-0.11076E+01,-0.11091E+01,-0.11106E+01,& - -0.11121E+01,-0.11136E+01,-0.11151E+01,-0.11165E+01,-0.11180E+01,& - -0.11194E+01,-0.11208E+01,-0.11222E+01,-0.11236E+01,-0.11250E+01,& - -0.11263E+01,-0.11277E+01,-0.11290E+01,-0.11303E+01,-0.11316E+01,& - -0.11329E+01,-0.11342E+01,-0.11355E+01,-0.11368E+01,-0.11380E+01,& - -0.11392E+01,-0.11405E+01,-0.11417E+01,-0.11429E+01,-0.11441E+01,& - -0.11453E+01,-0.11464E+01,-0.11476E+01,-0.11488E+01,-0.11499E+01,& - -0.11510E+01,-0.11522E+01,-0.11533E+01,-0.11544E+01,-0.11555E+01,& - -0.11566E+01,-0.11577E+01,-0.11587E+01,-0.11598E+01,-0.11609E+01,& - -0.11619E+01,-0.11630E+01,-0.11640E+01,-0.11650E+01,-0.11660E+01,& - -0.11670E+01,-0.11680E+01,-0.11690E+01,-0.11700E+01,-0.11710E+01,& - -0.11720E+01,-0.11729E+01,-0.11739E+01,-0.11749E+01,-0.11758E+01,& - -0.11767E+01,-0.11777E+01,-0.11786E+01,-0.11795E+01,-0.11804E+01/ - - DATA (BNC02M(IA),IA=701,741)/ & - -0.11813E+01,-0.11822E+01,-0.11831E+01,-0.11840E+01,-0.11849E+01,& - -0.11858E+01,-0.11867E+01,-0.11875E+01,-0.11884E+01,-0.11893E+01,& - -0.11901E+01,-0.11909E+01,-0.11918E+01,-0.11926E+01,-0.11934E+01,& - -0.11943E+01,-0.11951E+01,-0.11959E+01,-0.11967E+01,-0.11975E+01,& - -0.11983E+01,-0.11991E+01,-0.11999E+01,-0.12007E+01,-0.12015E+01,& - -0.12022E+01,-0.12030E+01,-0.12038E+01,-0.12045E+01,-0.12053E+01,& - -0.12060E+01,-0.12068E+01,-0.12075E+01,-0.12083E+01,-0.12090E+01,& - -0.12097E+01,-0.12105E+01,-0.12112E+01,-0.12119E+01,-0.12126E+01,& - -0.12133E+01 / -! -! ** NaNO3 -! - DATA (BNC03M (IA),IA= 1,100)/ & - -0.51631E-01,-0.94349E-01,-0.12464E+00,-0.14539E+00,-0.16147E+00,& - -0.17470E+00,-0.18599E+00,-0.19586E+00,-0.20466E+00,-0.21259E+00,& - -0.21982E+00,-0.22648E+00,-0.23265E+00,-0.23839E+00,-0.24378E+00,& - -0.24884E+00,-0.25363E+00,-0.25817E+00,-0.26248E+00,-0.26659E+00,& - -0.27052E+00,-0.27428E+00,-0.27789E+00,-0.28136E+00,-0.28470E+00,& - -0.28792E+00,-0.29103E+00,-0.29403E+00,-0.29694E+00,-0.29976E+00,& - -0.30249E+00,-0.30515E+00,-0.30772E+00,-0.31023E+00,-0.31267E+00,& - -0.31505E+00,-0.31736E+00,-0.31962E+00,-0.32182E+00,-0.32397E+00,& - -0.32607E+00,-0.32812E+00,-0.33013E+00,-0.33209E+00,-0.33401E+00,& - -0.33590E+00,-0.33774E+00,-0.33954E+00,-0.34131E+00,-0.34305E+00,& - -0.34475E+00,-0.34642E+00,-0.34806E+00,-0.34967E+00,-0.35125E+00,& - -0.35281E+00,-0.35434E+00,-0.35584E+00,-0.35732E+00,-0.35877E+00,& - -0.36021E+00,-0.36162E+00,-0.36300E+00,-0.36437E+00,-0.36572E+00,& - -0.36705E+00,-0.36836E+00,-0.36965E+00,-0.37093E+00,-0.37219E+00,& - -0.37343E+00,-0.37466E+00,-0.37588E+00,-0.37707E+00,-0.37826E+00,& - -0.37943E+00,-0.38059E+00,-0.38174E+00,-0.38287E+00,-0.38400E+00,& - -0.38511E+00,-0.38621E+00,-0.38730E+00,-0.38838E+00,-0.38945E+00,& - -0.39051E+00,-0.39157E+00,-0.39261E+00,-0.39364E+00,-0.39467E+00,& - -0.39569E+00,-0.39670E+00,-0.39770E+00,-0.39869E+00,-0.39968E+00,& - -0.40066E+00,-0.40163E+00,-0.40260E+00,-0.40356E+00,-0.40451E+00/ - - DATA (BNC03M (IA),IA=101,200)/ & - -0.40545E+00,-0.40639E+00,-0.40733E+00,-0.40825E+00,-0.40917E+00,& - -0.41009E+00,-0.41099E+00,-0.41190E+00,-0.41279E+00,-0.41368E+00,& - -0.41457E+00,-0.41544E+00,-0.41632E+00,-0.41718E+00,-0.41804E+00,& - -0.41890E+00,-0.41975E+00,-0.42060E+00,-0.42143E+00,-0.42227E+00,& - -0.42306E+00,-0.42389E+00,-0.42471E+00,-0.42553E+00,-0.42634E+00,& - -0.42714E+00,-0.42794E+00,-0.42874E+00,-0.42953E+00,-0.43031E+00,& - -0.43109E+00,-0.43187E+00,-0.43264E+00,-0.43340E+00,-0.43416E+00,& - -0.43492E+00,-0.43567E+00,-0.43641E+00,-0.43715E+00,-0.43789E+00,& - -0.43862E+00,-0.43935E+00,-0.44007E+00,-0.44079E+00,-0.44151E+00,& - -0.44222E+00,-0.44293E+00,-0.44363E+00,-0.44433E+00,-0.44503E+00,& - -0.44572E+00,-0.44640E+00,-0.44709E+00,-0.44777E+00,-0.44844E+00,& - -0.44912E+00,-0.44978E+00,-0.45045E+00,-0.45111E+00,-0.45177E+00,& - -0.45242E+00,-0.45307E+00,-0.45372E+00,-0.45437E+00,-0.45501E+00,& - -0.45565E+00,-0.45628E+00,-0.45691E+00,-0.45754E+00,-0.45816E+00,& - -0.45879E+00,-0.45940E+00,-0.46002E+00,-0.46063E+00,-0.46124E+00,& - -0.46185E+00,-0.46245E+00,-0.46305E+00,-0.46365E+00,-0.46425E+00,& - -0.46484E+00,-0.46543E+00,-0.46601E+00,-0.46660E+00,-0.46718E+00,& - -0.46776E+00,-0.46833E+00,-0.46891E+00,-0.46948E+00,-0.47005E+00,& - -0.47061E+00,-0.47117E+00,-0.47173E+00,-0.47229E+00,-0.47285E+00,& - -0.47340E+00,-0.47395E+00,-0.47450E+00,-0.47505E+00,-0.47559E+00/ - - DATA (BNC03M (IA),IA=201,300)/ & - -0.47613E+00,-0.47667E+00,-0.47721E+00,-0.47774E+00,-0.47827E+00,& - -0.47880E+00,-0.47933E+00,-0.47985E+00,-0.48038E+00,-0.48090E+00,& - -0.48142E+00,-0.48193E+00,-0.48245E+00,-0.48296E+00,-0.48347E+00,& - -0.48398E+00,-0.48449E+00,-0.48499E+00,-0.48549E+00,-0.48599E+00,& - -0.48649E+00,-0.48699E+00,-0.48748E+00,-0.48797E+00,-0.48847E+00,& - -0.48895E+00,-0.48944E+00,-0.48993E+00,-0.49041E+00,-0.49089E+00,& - -0.49137E+00,-0.49185E+00,-0.49232E+00,-0.49280E+00,-0.49327E+00,& - -0.49374E+00,-0.49421E+00,-0.49468E+00,-0.49514E+00,-0.49560E+00,& - -0.49607E+00,-0.49653E+00,-0.49699E+00,-0.49744E+00,-0.49790E+00,& - -0.49835E+00,-0.49880E+00,-0.49925E+00,-0.49970E+00,-0.50015E+00,& - -0.50060E+00,-0.50104E+00,-0.50148E+00,-0.50192E+00,-0.50236E+00,& - -0.50280E+00,-0.50324E+00,-0.50367E+00,-0.50411E+00,-0.50454E+00,& - -0.50497E+00,-0.50540E+00,-0.50582E+00,-0.50625E+00,-0.50668E+00,& - -0.50710E+00,-0.50752E+00,-0.50794E+00,-0.50836E+00,-0.50878E+00,& - -0.50919E+00,-0.50961E+00,-0.51002E+00,-0.51043E+00,-0.51085E+00,& - -0.51126E+00,-0.51166E+00,-0.51207E+00,-0.51248E+00,-0.51288E+00,& - -0.51328E+00,-0.51369E+00,-0.51409E+00,-0.51449E+00,-0.51488E+00,& - -0.51528E+00,-0.51568E+00,-0.51607E+00,-0.51646E+00,-0.51686E+00,& - -0.51725E+00,-0.51764E+00,-0.51802E+00,-0.51841E+00,-0.51880E+00,& - -0.51918E+00,-0.51956E+00,-0.51995E+00,-0.52033E+00,-0.52071E+00/ - - DATA (BNC03M (IA),IA=301,400)/ & - -0.52109E+00,-0.52146E+00,-0.52184E+00,-0.52222E+00,-0.52259E+00,& - -0.52296E+00,-0.52334E+00,-0.52371E+00,-0.52408E+00,-0.52445E+00,& - -0.52482E+00,-0.52518E+00,-0.52555E+00,-0.52591E+00,-0.52628E+00,& - -0.52664E+00,-0.52700E+00,-0.52736E+00,-0.52772E+00,-0.52808E+00,& - -0.52844E+00,-0.52879E+00,-0.52915E+00,-0.52950E+00,-0.52986E+00,& - -0.53021E+00,-0.53056E+00,-0.53091E+00,-0.53126E+00,-0.53161E+00,& - -0.53196E+00,-0.53230E+00,-0.53265E+00,-0.53299E+00,-0.53334E+00,& - -0.53368E+00,-0.53402E+00,-0.53436E+00,-0.53470E+00,-0.53504E+00,& - -0.53538E+00,-0.53572E+00,-0.53605E+00,-0.53639E+00,-0.53672E+00,& - -0.53706E+00,-0.53739E+00,-0.53772E+00,-0.53805E+00,-0.53838E+00,& - -0.53871E+00,-0.53904E+00,-0.53937E+00,-0.53970E+00,-0.54002E+00,& - -0.54035E+00,-0.54067E+00,-0.54100E+00,-0.54132E+00,-0.54164E+00,& - -0.54196E+00,-0.54228E+00,-0.54260E+00,-0.54292E+00,-0.54324E+00,& - -0.54355E+00,-0.54387E+00,-0.54419E+00,-0.54450E+00,-0.54481E+00,& - -0.54513E+00,-0.54544E+00,-0.54575E+00,-0.54606E+00,-0.54637E+00,& - -0.54668E+00,-0.54699E+00,-0.54730E+00,-0.54760E+00,-0.54791E+00,& - -0.54821E+00,-0.54852E+00,-0.54882E+00,-0.54913E+00,-0.54943E+00,& - -0.54973E+00,-0.55003E+00,-0.55033E+00,-0.55063E+00,-0.55093E+00,& - -0.55123E+00,-0.55152E+00,-0.55182E+00,-0.55212E+00,-0.55241E+00,& - -0.55271E+00,-0.55300E+00,-0.55329E+00,-0.55359E+00,-0.55388E+00/ - - DATA (BNC03M (IA),IA=401,500)/ & - -0.55417E+00,-0.55446E+00,-0.55475E+00,-0.55504E+00,-0.55533E+00,& - -0.55561E+00,-0.55590E+00,-0.55619E+00,-0.55647E+00,-0.55676E+00,& - -0.55704E+00,-0.55733E+00,-0.55761E+00,-0.55789E+00,-0.55817E+00,& - -0.55845E+00,-0.55874E+00,-0.55902E+00,-0.55929E+00,-0.55957E+00,& - -0.55985E+00,-0.56013E+00,-0.56041E+00,-0.56068E+00,-0.56096E+00,& - -0.56123E+00,-0.56151E+00,-0.56178E+00,-0.56205E+00,-0.56233E+00,& - -0.56260E+00,-0.56287E+00,-0.56314E+00,-0.56341E+00,-0.56368E+00,& - -0.56395E+00,-0.56422E+00,-0.56449E+00,-0.56475E+00,-0.56502E+00,& - -0.56529E+00,-0.56555E+00,-0.56582E+00,-0.56608E+00,-0.56634E+00,& - -0.56661E+00,-0.56687E+00,-0.56713E+00,-0.56739E+00,-0.56766E+00,& - -0.56792E+00,-0.56818E+00,-0.56843E+00,-0.56869E+00,-0.56895E+00,& - -0.56921E+00,-0.56947E+00,-0.56972E+00,-0.56998E+00,-0.57024E+00,& - -0.57049E+00,-0.57075E+00,-0.57100E+00,-0.57125E+00,-0.57151E+00,& - -0.57176E+00,-0.57201E+00,-0.57226E+00,-0.57251E+00,-0.57276E+00,& - -0.57301E+00,-0.57326E+00,-0.57351E+00,-0.57376E+00,-0.57401E+00,& - -0.57425E+00,-0.57450E+00,-0.57475E+00,-0.57499E+00,-0.57524E+00,& - -0.57548E+00,-0.57573E+00,-0.57597E+00,-0.57622E+00,-0.57646E+00,& - -0.57670E+00,-0.57694E+00,-0.57719E+00,-0.57743E+00,-0.57767E+00,& - -0.57791E+00,-0.57815E+00,-0.57839E+00,-0.57862E+00,-0.57886E+00,& - -0.57910E+00,-0.57934E+00,-0.57958E+00,-0.57981E+00,-0.58005E+00/ - - DATA (BNC03M (IA),IA=501,600)/ & - -0.58028E+00,-0.58052E+00,-0.58075E+00,-0.58099E+00,-0.58122E+00,& - -0.58145E+00,-0.58169E+00,-0.58192E+00,-0.58215E+00,-0.58238E+00,& - -0.58261E+00,-0.58284E+00,-0.58307E+00,-0.58330E+00,-0.58353E+00,& - -0.58376E+00,-0.58399E+00,-0.58422E+00,-0.58445E+00,-0.58467E+00,& - -0.58490E+00,-0.58513E+00,-0.58535E+00,-0.58558E+00,-0.58580E+00,& - -0.58603E+00,-0.58625E+00,-0.58648E+00,-0.58670E+00,-0.58692E+00,& - -0.58714E+00,-0.58737E+00,-0.58759E+00,-0.58781E+00,-0.58803E+00,& - -0.58825E+00,-0.58847E+00,-0.58869E+00,-0.58891E+00,-0.58913E+00,& - -0.58935E+00,-0.58957E+00,-0.58978E+00,-0.59000E+00,-0.59022E+00,& - -0.59044E+00,-0.59065E+00,-0.59087E+00,-0.59108E+00,-0.59130E+00,& - -0.59151E+00,-0.59173E+00,-0.59194E+00,-0.59215E+00,-0.59237E+00,& - -0.59258E+00,-0.59279E+00,-0.59300E+00,-0.59322E+00,-0.59343E+00,& - -0.59364E+00,-0.59385E+00,-0.59406E+00,-0.59427E+00,-0.59448E+00,& - -0.59469E+00,-0.59490E+00,-0.59511E+00,-0.59531E+00,-0.59552E+00,& - -0.59573E+00,-0.59594E+00,-0.59614E+00,-0.59635E+00,-0.59655E+00,& - -0.59676E+00,-0.59696E+00,-0.59717E+00,-0.59737E+00,-0.59758E+00,& - -0.59778E+00,-0.59799E+00,-0.59819E+00,-0.59839E+00,-0.59859E+00,& - -0.59880E+00,-0.59900E+00,-0.59920E+00,-0.59940E+00,-0.59960E+00,& - -0.59980E+00,-0.60000E+00,-0.60020E+00,-0.60040E+00,-0.60060E+00,& - -0.60080E+00,-0.60100E+00,-0.60119E+00,-0.60139E+00,-0.60213E+00/ - - DATA (BNC03M (IA),IA=601,700)/ & - -0.60374E+00,-0.60566E+00,-0.60755E+00,-0.60942E+00,-0.61125E+00,& - -0.61305E+00,-0.61483E+00,-0.61658E+00,-0.61831E+00,-0.62001E+00,& - -0.62169E+00,-0.62334E+00,-0.62497E+00,-0.62658E+00,-0.62816E+00,& - -0.62973E+00,-0.63127E+00,-0.63279E+00,-0.63429E+00,-0.63578E+00,& - -0.63724E+00,-0.63869E+00,-0.64012E+00,-0.64153E+00,-0.64292E+00,& - -0.64430E+00,-0.64566E+00,-0.64700E+00,-0.64833E+00,-0.64964E+00,& - -0.65094E+00,-0.65222E+00,-0.65349E+00,-0.65475E+00,-0.65599E+00,& - -0.65721E+00,-0.65843E+00,-0.65963E+00,-0.66082E+00,-0.66199E+00,& - -0.66315E+00,-0.66431E+00,-0.66544E+00,-0.66657E+00,-0.66769E+00,& - -0.66879E+00,-0.66989E+00,-0.67097E+00,-0.67204E+00,-0.67310E+00,& - -0.67415E+00,-0.67520E+00,-0.67623E+00,-0.67725E+00,-0.67826E+00,& - -0.67927E+00,-0.68026E+00,-0.68124E+00,-0.68222E+00,-0.68319E+00,& - -0.68415E+00,-0.68510E+00,-0.68604E+00,-0.68697E+00,-0.68790E+00,& - -0.68881E+00,-0.68972E+00,-0.69062E+00,-0.69152E+00,-0.69241E+00,& - -0.69329E+00,-0.69416E+00,-0.69502E+00,-0.69588E+00,-0.69673E+00,& - -0.69758E+00,-0.69841E+00,-0.69924E+00,-0.70007E+00,-0.70089E+00,& - -0.70170E+00,-0.70250E+00,-0.70330E+00,-0.70410E+00,-0.70488E+00,& - -0.70566E+00,-0.70644E+00,-0.70721E+00,-0.70797E+00,-0.70873E+00,& - -0.70948E+00,-0.71023E+00,-0.71097E+00,-0.71171E+00,-0.71244E+00,& - -0.71317E+00,-0.71389E+00,-0.71460E+00,-0.71531E+00,-0.71602E+00/ - - DATA (BNC03M(IA),IA=701,741)/ & - -0.71672E+00,-0.71742E+00,-0.71811E+00,-0.71880E+00,-0.71948E+00,& - -0.72016E+00,-0.72083E+00,-0.72150E+00,-0.72216E+00,-0.72282E+00,& - -0.72348E+00,-0.72413E+00,-0.72478E+00,-0.72542E+00,-0.72606E+00,& - -0.72670E+00,-0.72733E+00,-0.72795E+00,-0.72858E+00,-0.72920E+00,& - -0.72981E+00,-0.73042E+00,-0.73103E+00,-0.73163E+00,-0.73223E+00,& - -0.73283E+00,-0.73342E+00,-0.73401E+00,-0.73460E+00,-0.73518E+00,& - -0.73576E+00,-0.73634E+00,-0.73691E+00,-0.73748E+00,-0.73805E+00,& - -0.73861E+00,-0.73917E+00,-0.73972E+00,-0.74028E+00,-0.74083E+00,& - -0.74137E+00 / -! -! ** (NH4)2SO4 -! - DATA (BNC04M (IA),IA= 1,100)/ & - -0.10306E+00,-0.18795E+00,-0.24786E+00,-0.28872E+00,-0.32027E+00,& - -0.34614E+00,-0.36814E+00,-0.38733E+00,-0.40435E+00,-0.41967E+00,& - -0.43360E+00,-0.44638E+00,-0.45819E+00,-0.46917E+00,-0.47943E+00,& - -0.48906E+00,-0.49813E+00,-0.50671E+00,-0.51485E+00,-0.52259E+00,& - -0.52997E+00,-0.53702E+00,-0.54377E+00,-0.55025E+00,-0.55647E+00,& - -0.56246E+00,-0.56823E+00,-0.57380E+00,-0.57918E+00,-0.58438E+00,& - -0.58942E+00,-0.59430E+00,-0.59904E+00,-0.60363E+00,-0.60810E+00,& - -0.61245E+00,-0.61668E+00,-0.62079E+00,-0.62480E+00,-0.62872E+00,& - -0.63253E+00,-0.63626E+00,-0.63989E+00,-0.64345E+00,-0.64692E+00,& - -0.65032E+00,-0.65365E+00,-0.65690E+00,-0.66009E+00,-0.66321E+00,& - -0.66627E+00,-0.66927E+00,-0.67221E+00,-0.67510E+00,-0.67793E+00,& - -0.68071E+00,-0.68344E+00,-0.68613E+00,-0.68876E+00,-0.69136E+00,& - -0.69391E+00,-0.69641E+00,-0.69888E+00,-0.70131E+00,-0.70370E+00,& - -0.70606E+00,-0.70838E+00,-0.71067E+00,-0.71292E+00,-0.71514E+00,& - -0.71734E+00,-0.71950E+00,-0.72164E+00,-0.72374E+00,-0.72582E+00,& - -0.72788E+00,-0.72991E+00,-0.73191E+00,-0.73390E+00,-0.73586E+00,& - -0.73780E+00,-0.73971E+00,-0.74161E+00,-0.74349E+00,-0.74534E+00,& - -0.74718E+00,-0.74900E+00,-0.75080E+00,-0.75259E+00,-0.75436E+00,& - -0.75611E+00,-0.75784E+00,-0.75956E+00,-0.76127E+00,-0.76296E+00,& - -0.76463E+00,-0.76629E+00,-0.76794E+00,-0.76957E+00,-0.77119E+00/ - - DATA (BNC04M (IA),IA=101,200)/ & - -0.77280E+00,-0.77439E+00,-0.77597E+00,-0.77754E+00,-0.77910E+00,& - -0.78064E+00,-0.78218E+00,-0.78370E+00,-0.78520E+00,-0.78670E+00,& - -0.78819E+00,-0.78966E+00,-0.79113E+00,-0.79258E+00,-0.79402E+00,& - -0.79545E+00,-0.79687E+00,-0.79828E+00,-0.79968E+00,-0.80107E+00,& - -0.80241E+00,-0.80378E+00,-0.80515E+00,-0.80650E+00,-0.80785E+00,& - -0.80918E+00,-0.81051E+00,-0.81183E+00,-0.81313E+00,-0.81443E+00,& - -0.81572E+00,-0.81700E+00,-0.81827E+00,-0.81953E+00,-0.82078E+00,& - -0.82203E+00,-0.82327E+00,-0.82449E+00,-0.82571E+00,-0.82692E+00,& - -0.82813E+00,-0.82932E+00,-0.83051E+00,-0.83169E+00,-0.83287E+00,& - -0.83403E+00,-0.83519E+00,-0.83634E+00,-0.83748E+00,-0.83862E+00,& - -0.83975E+00,-0.84087E+00,-0.84199E+00,-0.84310E+00,-0.84420E+00,& - -0.84530E+00,-0.84639E+00,-0.84747E+00,-0.84855E+00,-0.84962E+00,& - -0.85068E+00,-0.85174E+00,-0.85280E+00,-0.85384E+00,-0.85488E+00,& - -0.85592E+00,-0.85695E+00,-0.85797E+00,-0.85899E+00,-0.86000E+00,& - -0.86101E+00,-0.86201E+00,-0.86301E+00,-0.86400E+00,-0.86498E+00,& - -0.86596E+00,-0.86694E+00,-0.86791E+00,-0.86887E+00,-0.86983E+00,& - -0.87079E+00,-0.87174E+00,-0.87268E+00,-0.87362E+00,-0.87456E+00,& - -0.87549E+00,-0.87642E+00,-0.87734E+00,-0.87826E+00,-0.87917E+00,& - -0.88008E+00,-0.88098E+00,-0.88188E+00,-0.88278E+00,-0.88367E+00,& - -0.88456E+00,-0.88544E+00,-0.88632E+00,-0.88719E+00,-0.88806E+00/ - - DATA (BNC04M (IA),IA=201,300)/ & - -0.88893E+00,-0.88979E+00,-0.89065E+00,-0.89151E+00,-0.89236E+00,& - -0.89320E+00,-0.89405E+00,-0.89489E+00,-0.89572E+00,-0.89655E+00,& - -0.89738E+00,-0.89821E+00,-0.89903E+00,-0.89984E+00,-0.90066E+00,& - -0.90147E+00,-0.90227E+00,-0.90308E+00,-0.90388E+00,-0.90467E+00,& - -0.90547E+00,-0.90626E+00,-0.90704E+00,-0.90783E+00,-0.90861E+00,& - -0.90938E+00,-0.91016E+00,-0.91093E+00,-0.91169E+00,-0.91246E+00,& - -0.91322E+00,-0.91398E+00,-0.91473E+00,-0.91548E+00,-0.91623E+00,& - -0.91698E+00,-0.91772E+00,-0.91846E+00,-0.91920E+00,-0.91993E+00,& - -0.92066E+00,-0.92139E+00,-0.92211E+00,-0.92284E+00,-0.92356E+00,& - -0.92427E+00,-0.92499E+00,-0.92570E+00,-0.92641E+00,-0.92712E+00,& - -0.92782E+00,-0.92852E+00,-0.92922E+00,-0.92991E+00,-0.93061E+00,& - -0.93130E+00,-0.93199E+00,-0.93267E+00,-0.93336E+00,-0.93404E+00,& - -0.93471E+00,-0.93539E+00,-0.93606E+00,-0.93674E+00,-0.93740E+00,& - -0.93807E+00,-0.93873E+00,-0.93940E+00,-0.94005E+00,-0.94071E+00,& - -0.94137E+00,-0.94202E+00,-0.94267E+00,-0.94332E+00,-0.94396E+00,& - -0.94460E+00,-0.94525E+00,-0.94589E+00,-0.94652E+00,-0.94716E+00,& - -0.94779E+00,-0.94842E+00,-0.94905E+00,-0.94967E+00,-0.95030E+00,& - -0.95092E+00,-0.95154E+00,-0.95216E+00,-0.95277E+00,-0.95339E+00,& - -0.95400E+00,-0.95461E+00,-0.95522E+00,-0.95582E+00,-0.95643E+00,& - -0.95703E+00,-0.95763E+00,-0.95823E+00,-0.95882E+00,-0.95942E+00/ - - DATA (BNC04M (IA),IA=301,400)/ & - -0.96001E+00,-0.96060E+00,-0.96119E+00,-0.96178E+00,-0.96236E+00,& - -0.96294E+00,-0.96353E+00,-0.96411E+00,-0.96468E+00,-0.96526E+00,& - -0.96583E+00,-0.96641E+00,-0.96698E+00,-0.96755E+00,-0.96811E+00,& - -0.96868E+00,-0.96924E+00,-0.96981E+00,-0.97037E+00,-0.97092E+00,& - -0.97148E+00,-0.97204E+00,-0.97259E+00,-0.97314E+00,-0.97369E+00,& - -0.97424E+00,-0.97479E+00,-0.97534E+00,-0.97588E+00,-0.97642E+00,& - -0.97696E+00,-0.97750E+00,-0.97804E+00,-0.97858E+00,-0.97911E+00,& - -0.97965E+00,-0.98018E+00,-0.98071E+00,-0.98124E+00,-0.98176E+00,& - -0.98229E+00,-0.98281E+00,-0.98334E+00,-0.98386E+00,-0.98438E+00,& - -0.98490E+00,-0.98541E+00,-0.98593E+00,-0.98644E+00,-0.98696E+00,& - -0.98747E+00,-0.98798E+00,-0.98849E+00,-0.98899E+00,-0.98950E+00,& - -0.99000E+00,-0.99051E+00,-0.99101E+00,-0.99151E+00,-0.99201E+00,& - -0.99251E+00,-0.99300E+00,-0.99350E+00,-0.99399E+00,-0.99448E+00,& - -0.99497E+00,-0.99546E+00,-0.99595E+00,-0.99644E+00,-0.99693E+00,& - -0.99741E+00,-0.99789E+00,-0.99838E+00,-0.99886E+00,-0.99934E+00,& - -0.99982E+00,-0.10003E+01,-0.10008E+01,-0.10012E+01,-0.10017E+01,& - -0.10022E+01,-0.10027E+01,-0.10031E+01,-0.10036E+01,-0.10041E+01,& - -0.10045E+01,-0.10050E+01,-0.10055E+01,-0.10059E+01,-0.10064E+01,& - -0.10068E+01,-0.10073E+01,-0.10078E+01,-0.10082E+01,-0.10087E+01,& - -0.10091E+01,-0.10096E+01,-0.10100E+01,-0.10105E+01,-0.10109E+01/ - - DATA (BNC04M (IA),IA=401,500)/ & - -0.10114E+01,-0.10118E+01,-0.10123E+01,-0.10127E+01,-0.10132E+01,& - -0.10136E+01,-0.10141E+01,-0.10145E+01,-0.10149E+01,-0.10154E+01,& - -0.10158E+01,-0.10163E+01,-0.10167E+01,-0.10171E+01,-0.10176E+01,& - -0.10180E+01,-0.10184E+01,-0.10189E+01,-0.10193E+01,-0.10197E+01,& - -0.10202E+01,-0.10206E+01,-0.10210E+01,-0.10214E+01,-0.10219E+01,& - -0.10223E+01,-0.10227E+01,-0.10231E+01,-0.10236E+01,-0.10240E+01,& - -0.10244E+01,-0.10248E+01,-0.10252E+01,-0.10256E+01,-0.10261E+01,& - -0.10265E+01,-0.10269E+01,-0.10273E+01,-0.10277E+01,-0.10281E+01,& - -0.10285E+01,-0.10289E+01,-0.10293E+01,-0.10298E+01,-0.10302E+01,& - -0.10306E+01,-0.10310E+01,-0.10314E+01,-0.10318E+01,-0.10322E+01,& - -0.10326E+01,-0.10330E+01,-0.10334E+01,-0.10338E+01,-0.10342E+01,& - -0.10346E+01,-0.10350E+01,-0.10354E+01,-0.10357E+01,-0.10361E+01,& - -0.10365E+01,-0.10369E+01,-0.10373E+01,-0.10377E+01,-0.10381E+01,& - -0.10385E+01,-0.10389E+01,-0.10393E+01,-0.10396E+01,-0.10400E+01,& - -0.10404E+01,-0.10408E+01,-0.10412E+01,-0.10416E+01,-0.10419E+01,& - -0.10423E+01,-0.10427E+01,-0.10431E+01,-0.10435E+01,-0.10438E+01,& - -0.10442E+01,-0.10446E+01,-0.10450E+01,-0.10453E+01,-0.10457E+01,& - -0.10461E+01,-0.10464E+01,-0.10468E+01,-0.10472E+01,-0.10476E+01,& - -0.10479E+01,-0.10483E+01,-0.10487E+01,-0.10490E+01,-0.10494E+01,& - -0.10498E+01,-0.10501E+01,-0.10505E+01,-0.10508E+01,-0.10512E+01/ - - DATA (BNC04M (IA),IA=501,600)/ & - -0.10516E+01,-0.10519E+01,-0.10523E+01,-0.10526E+01,-0.10530E+01,& - -0.10534E+01,-0.10537E+01,-0.10541E+01,-0.10544E+01,-0.10548E+01,& - -0.10551E+01,-0.10555E+01,-0.10558E+01,-0.10562E+01,-0.10565E+01,& - -0.10569E+01,-0.10572E+01,-0.10576E+01,-0.10579E+01,-0.10583E+01,& - -0.10586E+01,-0.10590E+01,-0.10593E+01,-0.10597E+01,-0.10600E+01,& - -0.10604E+01,-0.10607E+01,-0.10611E+01,-0.10614E+01,-0.10617E+01,& - -0.10621E+01,-0.10624E+01,-0.10628E+01,-0.10631E+01,-0.10634E+01,& - -0.10638E+01,-0.10641E+01,-0.10644E+01,-0.10648E+01,-0.10651E+01,& - -0.10655E+01,-0.10658E+01,-0.10661E+01,-0.10665E+01,-0.10668E+01,& - -0.10671E+01,-0.10674E+01,-0.10678E+01,-0.10681E+01,-0.10684E+01,& - -0.10688E+01,-0.10691E+01,-0.10694E+01,-0.10697E+01,-0.10701E+01,& - -0.10704E+01,-0.10707E+01,-0.10710E+01,-0.10714E+01,-0.10717E+01,& - -0.10720E+01,-0.10723E+01,-0.10727E+01,-0.10730E+01,-0.10733E+01,& - -0.10736E+01,-0.10739E+01,-0.10743E+01,-0.10746E+01,-0.10749E+01,& - -0.10752E+01,-0.10755E+01,-0.10758E+01,-0.10762E+01,-0.10765E+01,& - -0.10768E+01,-0.10771E+01,-0.10774E+01,-0.10777E+01,-0.10780E+01,& - -0.10783E+01,-0.10787E+01,-0.10790E+01,-0.10793E+01,-0.10796E+01,& - -0.10799E+01,-0.10802E+01,-0.10805E+01,-0.10808E+01,-0.10811E+01,& - -0.10814E+01,-0.10817E+01,-0.10820E+01,-0.10823E+01,-0.10827E+01,& - -0.10830E+01,-0.10833E+01,-0.10836E+01,-0.10839E+01,-0.10850E+01/ - - DATA (BNC04M (IA),IA=601,700)/ & - -0.10874E+01,-0.10904E+01,-0.10933E+01,-0.10961E+01,-0.10989E+01,& - -0.11017E+01,-0.11044E+01,-0.11070E+01,-0.11097E+01,-0.11123E+01,& - -0.11148E+01,-0.11173E+01,-0.11198E+01,-0.11223E+01,-0.11247E+01,& - -0.11271E+01,-0.11294E+01,-0.11317E+01,-0.11340E+01,-0.11363E+01,& - -0.11385E+01,-0.11407E+01,-0.11429E+01,-0.11450E+01,-0.11471E+01,& - -0.11492E+01,-0.11513E+01,-0.11534E+01,-0.11554E+01,-0.11574E+01,& - -0.11593E+01,-0.11613E+01,-0.11632E+01,-0.11651E+01,-0.11670E+01,& - -0.11689E+01,-0.11707E+01,-0.11726E+01,-0.11744E+01,-0.11762E+01,& - -0.11779E+01,-0.11797E+01,-0.11814E+01,-0.11831E+01,-0.11848E+01,& - -0.11865E+01,-0.11882E+01,-0.11898E+01,-0.11915E+01,-0.11931E+01,& - -0.11947E+01,-0.11963E+01,-0.11978E+01,-0.11994E+01,-0.12009E+01,& - -0.12025E+01,-0.12040E+01,-0.12055E+01,-0.12070E+01,-0.12084E+01,& - -0.12099E+01,-0.12114E+01,-0.12128E+01,-0.12142E+01,-0.12156E+01,& - -0.12170E+01,-0.12184E+01,-0.12198E+01,-0.12212E+01,-0.12225E+01,& - -0.12238E+01,-0.12252E+01,-0.12265E+01,-0.12278E+01,-0.12291E+01,& - -0.12304E+01,-0.12317E+01,-0.12329E+01,-0.12342E+01,-0.12355E+01,& - -0.12367E+01,-0.12379E+01,-0.12391E+01,-0.12404E+01,-0.12416E+01,& - -0.12428E+01,-0.12439E+01,-0.12451E+01,-0.12463E+01,-0.12474E+01,& - -0.12486E+01,-0.12497E+01,-0.12509E+01,-0.12520E+01,-0.12531E+01,& - -0.12542E+01,-0.12553E+01,-0.12564E+01,-0.12575E+01,-0.12586E+01/ - - DATA (BNC04M(IA),IA=701,741)/ & - -0.12597E+01,-0.12607E+01,-0.12618E+01,-0.12629E+01,-0.12639E+01,& - -0.12649E+01,-0.12660E+01,-0.12670E+01,-0.12680E+01,-0.12690E+01,& - -0.12700E+01,-0.12710E+01,-0.12720E+01,-0.12730E+01,-0.12740E+01,& - -0.12750E+01,-0.12760E+01,-0.12769E+01,-0.12779E+01,-0.12788E+01,& - -0.12798E+01,-0.12807E+01,-0.12816E+01,-0.12826E+01,-0.12835E+01,& - -0.12844E+01,-0.12853E+01,-0.12862E+01,-0.12871E+01,-0.12880E+01,& - -0.12889E+01,-0.12898E+01,-0.12907E+01,-0.12916E+01,-0.12924E+01,& - -0.12933E+01,-0.12942E+01,-0.12950E+01,-0.12959E+01,-0.12967E+01,& - -0.12976E+01 / -! -! ** NH4NO3 -! - DATA (BNC05M (IA),IA= 1,100)/ & - -0.52199E-01,-0.96472E-01,-0.12869E+00,-0.15126E+00,-0.16910E+00,& - -0.18404E+00,-0.19701E+00,-0.20852E+00,-0.21891E+00,-0.22842E+00,& - -0.23721E+00,-0.24540E+00,-0.25307E+00,-0.26031E+00,-0.26716E+00,& - -0.27368E+00,-0.27990E+00,-0.28586E+00,-0.29157E+00,-0.29707E+00,& - -0.30237E+00,-0.30748E+00,-0.31243E+00,-0.31723E+00,-0.32188E+00,& - -0.32639E+00,-0.33078E+00,-0.33506E+00,-0.33922E+00,-0.34328E+00,& - -0.34724E+00,-0.35110E+00,-0.35488E+00,-0.35857E+00,-0.36218E+00,& - -0.36571E+00,-0.36917E+00,-0.37256E+00,-0.37588E+00,-0.37914E+00,& - -0.38233E+00,-0.38547E+00,-0.38854E+00,-0.39156E+00,-0.39452E+00,& - -0.39743E+00,-0.40030E+00,-0.40311E+00,-0.40587E+00,-0.40860E+00,& - -0.41127E+00,-0.41391E+00,-0.41650E+00,-0.41905E+00,-0.42157E+00,& - -0.42404E+00,-0.42649E+00,-0.42890E+00,-0.43127E+00,-0.43361E+00,& - -0.43593E+00,-0.43821E+00,-0.44046E+00,-0.44269E+00,-0.44489E+00,& - -0.44707E+00,-0.44922E+00,-0.45135E+00,-0.45345E+00,-0.45554E+00,& - -0.45760E+00,-0.45964E+00,-0.46167E+00,-0.46368E+00,-0.46567E+00,& - -0.46764E+00,-0.46960E+00,-0.47154E+00,-0.47347E+00,-0.47539E+00,& - -0.47729E+00,-0.47918E+00,-0.48106E+00,-0.48293E+00,-0.48478E+00,& - -0.48663E+00,-0.48846E+00,-0.49029E+00,-0.49211E+00,-0.49391E+00,& - -0.49571E+00,-0.49750E+00,-0.49928E+00,-0.50105E+00,-0.50282E+00,& - -0.50458E+00,-0.50633E+00,-0.50807E+00,-0.50980E+00,-0.51153E+00/ - - DATA (BNC05M (IA),IA=101,200)/ & - -0.51325E+00,-0.51496E+00,-0.51667E+00,-0.51837E+00,-0.52006E+00,& - -0.52174E+00,-0.52342E+00,-0.52508E+00,-0.52675E+00,-0.52840E+00,& - -0.53005E+00,-0.53169E+00,-0.53332E+00,-0.53494E+00,-0.53656E+00,& - -0.53817E+00,-0.53977E+00,-0.54137E+00,-0.54295E+00,-0.54453E+00,& - -0.54599E+00,-0.54757E+00,-0.54914E+00,-0.55070E+00,-0.55225E+00,& - -0.55379E+00,-0.55532E+00,-0.55685E+00,-0.55836E+00,-0.55987E+00,& - -0.56137E+00,-0.56286E+00,-0.56435E+00,-0.56582E+00,-0.56729E+00,& - -0.56875E+00,-0.57020E+00,-0.57165E+00,-0.57308E+00,-0.57451E+00,& - -0.57594E+00,-0.57735E+00,-0.57876E+00,-0.58016E+00,-0.58156E+00,& - -0.58294E+00,-0.58432E+00,-0.58570E+00,-0.58706E+00,-0.58842E+00,& - -0.58977E+00,-0.59112E+00,-0.59246E+00,-0.59379E+00,-0.59512E+00,& - -0.59644E+00,-0.59775E+00,-0.59906E+00,-0.60036E+00,-0.60166E+00,& - -0.60295E+00,-0.60423E+00,-0.60551E+00,-0.60678E+00,-0.60805E+00,& - -0.60931E+00,-0.61056E+00,-0.61181E+00,-0.61305E+00,-0.61429E+00,& - -0.61552E+00,-0.61675E+00,-0.61797E+00,-0.61918E+00,-0.62039E+00,& - -0.62160E+00,-0.62280E+00,-0.62399E+00,-0.62518E+00,-0.62636E+00,& - -0.62754E+00,-0.62872E+00,-0.62988E+00,-0.63105E+00,-0.63221E+00,& - -0.63336E+00,-0.63451E+00,-0.63565E+00,-0.63679E+00,-0.63792E+00,& - -0.63905E+00,-0.64018E+00,-0.64130E+00,-0.64241E+00,-0.64352E+00,& - -0.64463E+00,-0.64573E+00,-0.64683E+00,-0.64792E+00,-0.64901E+00/ - - DATA (BNC05M (IA),IA=201,300)/ & - -0.65009E+00,-0.65117E+00,-0.65225E+00,-0.65332E+00,-0.65438E+00,& - -0.65545E+00,-0.65650E+00,-0.65756E+00,-0.65861E+00,-0.65965E+00,& - -0.66069E+00,-0.66173E+00,-0.66276E+00,-0.66379E+00,-0.66482E+00,& - -0.66584E+00,-0.66686E+00,-0.66787E+00,-0.66888E+00,-0.66989E+00,& - -0.67089E+00,-0.67189E+00,-0.67288E+00,-0.67387E+00,-0.67486E+00,& - -0.67584E+00,-0.67682E+00,-0.67780E+00,-0.67877E+00,-0.67974E+00,& - -0.68070E+00,-0.68166E+00,-0.68262E+00,-0.68358E+00,-0.68453E+00,& - -0.68548E+00,-0.68642E+00,-0.68736E+00,-0.68830E+00,-0.68923E+00,& - -0.69016E+00,-0.69109E+00,-0.69201E+00,-0.69293E+00,-0.69385E+00,& - -0.69476E+00,-0.69567E+00,-0.69658E+00,-0.69749E+00,-0.69839E+00,& - -0.69928E+00,-0.70018E+00,-0.70107E+00,-0.70196E+00,-0.70284E+00,& - -0.70373E+00,-0.70461E+00,-0.70548E+00,-0.70636E+00,-0.70723E+00,& - -0.70809E+00,-0.70896E+00,-0.70982E+00,-0.71068E+00,-0.71153E+00,& - -0.71238E+00,-0.71323E+00,-0.71408E+00,-0.71492E+00,-0.71577E+00,& - -0.71660E+00,-0.71744E+00,-0.71827E+00,-0.71910E+00,-0.71993E+00,& - -0.72075E+00,-0.72158E+00,-0.72239E+00,-0.72321E+00,-0.72402E+00,& - -0.72484E+00,-0.72564E+00,-0.72645E+00,-0.72725E+00,-0.72805E+00,& - -0.72885E+00,-0.72965E+00,-0.73044E+00,-0.73123E+00,-0.73202E+00,& - -0.73280E+00,-0.73359E+00,-0.73437E+00,-0.73514E+00,-0.73592E+00,& - -0.73669E+00,-0.73746E+00,-0.73823E+00,-0.73899E+00,-0.73976E+00/ - - DATA (BNC05M (IA),IA=301,400)/ & - -0.74052E+00,-0.74128E+00,-0.74203E+00,-0.74279E+00,-0.74354E+00,& - -0.74429E+00,-0.74503E+00,-0.74578E+00,-0.74652E+00,-0.74726E+00,& - -0.74800E+00,-0.74873E+00,-0.74946E+00,-0.75019E+00,-0.75092E+00,& - -0.75165E+00,-0.75237E+00,-0.75309E+00,-0.75381E+00,-0.75453E+00,& - -0.75525E+00,-0.75596E+00,-0.75667E+00,-0.75738E+00,-0.75809E+00,& - -0.75879E+00,-0.75949E+00,-0.76019E+00,-0.76089E+00,-0.76159E+00,& - -0.76228E+00,-0.76297E+00,-0.76366E+00,-0.76435E+00,-0.76504E+00,& - -0.76572E+00,-0.76641E+00,-0.76709E+00,-0.76776E+00,-0.76844E+00,& - -0.76911E+00,-0.76979E+00,-0.77046E+00,-0.77112E+00,-0.77179E+00,& - -0.77246E+00,-0.77312E+00,-0.77378E+00,-0.77444E+00,-0.77509E+00,& - -0.77575E+00,-0.77640E+00,-0.77705E+00,-0.77770E+00,-0.77835E+00,& - -0.77900E+00,-0.77964E+00,-0.78028E+00,-0.78092E+00,-0.78156E+00,& - -0.78220E+00,-0.78283E+00,-0.78347E+00,-0.78410E+00,-0.78473E+00,& - -0.78536E+00,-0.78598E+00,-0.78661E+00,-0.78723E+00,-0.78785E+00,& - -0.78847E+00,-0.78909E+00,-0.78970E+00,-0.79032E+00,-0.79093E+00,& - -0.79154E+00,-0.79215E+00,-0.79276E+00,-0.79336E+00,-0.79397E+00,& - -0.79457E+00,-0.79517E+00,-0.79577E+00,-0.79637E+00,-0.79696E+00,& - -0.79756E+00,-0.79815E+00,-0.79874E+00,-0.79933E+00,-0.79992E+00,& - -0.80051E+00,-0.80109E+00,-0.80168E+00,-0.80226E+00,-0.80284E+00,& - -0.80342E+00,-0.80399E+00,-0.80457E+00,-0.80514E+00,-0.80572E+00/ - - DATA (BNC05M (IA),IA=401,500)/ & - -0.80629E+00,-0.80686E+00,-0.80743E+00,-0.80799E+00,-0.80856E+00,& - -0.80912E+00,-0.80968E+00,-0.81025E+00,-0.81081E+00,-0.81136E+00,& - -0.81192E+00,-0.81248E+00,-0.81303E+00,-0.81358E+00,-0.81413E+00,& - -0.81468E+00,-0.81523E+00,-0.81578E+00,-0.81632E+00,-0.81687E+00,& - -0.81741E+00,-0.81795E+00,-0.81849E+00,-0.81903E+00,-0.81956E+00,& - -0.82010E+00,-0.82063E+00,-0.82117E+00,-0.82170E+00,-0.82223E+00,& - -0.82276E+00,-0.82329E+00,-0.82381E+00,-0.82434E+00,-0.82486E+00,& - -0.82538E+00,-0.82590E+00,-0.82642E+00,-0.82694E+00,-0.82746E+00,& - -0.82798E+00,-0.82849E+00,-0.82900E+00,-0.82952E+00,-0.83003E+00,& - -0.83054E+00,-0.83104E+00,-0.83155E+00,-0.83206E+00,-0.83256E+00,& - -0.83307E+00,-0.83357E+00,-0.83407E+00,-0.83457E+00,-0.83507E+00,& - -0.83556E+00,-0.83606E+00,-0.83656E+00,-0.83705E+00,-0.83754E+00,& - -0.83803E+00,-0.83852E+00,-0.83901E+00,-0.83950E+00,-0.83999E+00,& - -0.84047E+00,-0.84096E+00,-0.84144E+00,-0.84192E+00,-0.84240E+00,& - -0.84288E+00,-0.84336E+00,-0.84384E+00,-0.84432E+00,-0.84479E+00,& - -0.84527E+00,-0.84574E+00,-0.84621E+00,-0.84668E+00,-0.84715E+00,& - -0.84762E+00,-0.84809E+00,-0.84855E+00,-0.84902E+00,-0.84948E+00,& - -0.84995E+00,-0.85041E+00,-0.85087E+00,-0.85133E+00,-0.85179E+00,& - -0.85225E+00,-0.85270E+00,-0.85316E+00,-0.85361E+00,-0.85407E+00,& - -0.85452E+00,-0.85497E+00,-0.85542E+00,-0.85587E+00,-0.85632E+00/ - - DATA (BNC05M (IA),IA=501,600)/ & - -0.85677E+00,-0.85721E+00,-0.85766E+00,-0.85810E+00,-0.85855E+00,& - -0.85899E+00,-0.85943E+00,-0.85987E+00,-0.86031E+00,-0.86075E+00,& - -0.86119E+00,-0.86162E+00,-0.86206E+00,-0.86249E+00,-0.86293E+00,& - -0.86336E+00,-0.86379E+00,-0.86422E+00,-0.86465E+00,-0.86508E+00,& - -0.86551E+00,-0.86593E+00,-0.86636E+00,-0.86678E+00,-0.86721E+00,& - -0.86763E+00,-0.86805E+00,-0.86848E+00,-0.86890E+00,-0.86931E+00,& - -0.86973E+00,-0.87015E+00,-0.87057E+00,-0.87098E+00,-0.87140E+00,& - -0.87181E+00,-0.87222E+00,-0.87264E+00,-0.87305E+00,-0.87346E+00,& - -0.87387E+00,-0.87428E+00,-0.87468E+00,-0.87509E+00,-0.87550E+00,& - -0.87590E+00,-0.87630E+00,-0.87671E+00,-0.87711E+00,-0.87751E+00,& - -0.87791E+00,-0.87831E+00,-0.87871E+00,-0.87911E+00,-0.87951E+00,& - -0.87990E+00,-0.88030E+00,-0.88069E+00,-0.88109E+00,-0.88148E+00,& - -0.88187E+00,-0.88226E+00,-0.88265E+00,-0.88304E+00,-0.88343E+00,& - -0.88382E+00,-0.88421E+00,-0.88459E+00,-0.88498E+00,-0.88537E+00,& - -0.88575E+00,-0.88613E+00,-0.88651E+00,-0.88690E+00,-0.88728E+00,& - -0.88766E+00,-0.88804E+00,-0.88841E+00,-0.88879E+00,-0.88917E+00,& - -0.88955E+00,-0.88992E+00,-0.89030E+00,-0.89067E+00,-0.89104E+00,& - -0.89141E+00,-0.89179E+00,-0.89216E+00,-0.89253E+00,-0.89290E+00,& - -0.89326E+00,-0.89363E+00,-0.89400E+00,-0.89436E+00,-0.89473E+00,& - -0.89509E+00,-0.89546E+00,-0.89582E+00,-0.89618E+00,-0.89754E+00/ - - DATA (BNC05M (IA),IA=601,700)/ & - -0.90048E+00,-0.90398E+00,-0.90741E+00,-0.91077E+00,-0.91407E+00,& - -0.91731E+00,-0.92048E+00,-0.92360E+00,-0.92666E+00,-0.92966E+00,& - -0.93261E+00,-0.93551E+00,-0.93835E+00,-0.94115E+00,-0.94389E+00,& - -0.94659E+00,-0.94924E+00,-0.95185E+00,-0.95441E+00,-0.95693E+00,& - -0.95941E+00,-0.96185E+00,-0.96425E+00,-0.96661E+00,-0.96893E+00,& - -0.97121E+00,-0.97346E+00,-0.97568E+00,-0.97786E+00,-0.98000E+00,& - -0.98212E+00,-0.98420E+00,-0.98625E+00,-0.98827E+00,-0.99026E+00,& - -0.99222E+00,-0.99415E+00,-0.99605E+00,-0.99793E+00,-0.99978E+00,& - -0.10016E+01,-0.10034E+01,-0.10052E+01,-0.10069E+01,-0.10087E+01,& - -0.10104E+01,-0.10120E+01,-0.10137E+01,-0.10153E+01,-0.10169E+01,& - -0.10185E+01,-0.10201E+01,-0.10216E+01,-0.10232E+01,-0.10247E+01,& - -0.10262E+01,-0.10276E+01,-0.10291E+01,-0.10305E+01,-0.10319E+01,& - -0.10333E+01,-0.10347E+01,-0.10361E+01,-0.10374E+01,-0.10388E+01,& - -0.10401E+01,-0.10414E+01,-0.10427E+01,-0.10439E+01,-0.10452E+01,& - -0.10464E+01,-0.10477E+01,-0.10489E+01,-0.10501E+01,-0.10513E+01,& - -0.10524E+01,-0.10536E+01,-0.10547E+01,-0.10559E+01,-0.10570E+01,& - -0.10581E+01,-0.10592E+01,-0.10603E+01,-0.10613E+01,-0.10624E+01,& - -0.10635E+01,-0.10645E+01,-0.10655E+01,-0.10665E+01,-0.10675E+01,& - -0.10685E+01,-0.10695E+01,-0.10705E+01,-0.10715E+01,-0.10724E+01,& - -0.10734E+01,-0.10743E+01,-0.10752E+01,-0.10761E+01,-0.10770E+01/ - - DATA (BNC05M(IA),IA=701,741)/ & - -0.10779E+01,-0.10788E+01,-0.10797E+01,-0.10806E+01,-0.10814E+01,& - -0.10823E+01,-0.10831E+01,-0.10840E+01,-0.10848E+01,-0.10856E+01,& - -0.10865E+01,-0.10873E+01,-0.10881E+01,-0.10889E+01,-0.10896E+01,& - -0.10904E+01,-0.10912E+01,-0.10920E+01,-0.10927E+01,-0.10935E+01,& - -0.10942E+01,-0.10949E+01,-0.10957E+01,-0.10964E+01,-0.10971E+01,& - -0.10978E+01,-0.10985E+01,-0.10992E+01,-0.10999E+01,-0.11006E+01,& - -0.11013E+01,-0.11020E+01,-0.11026E+01,-0.11033E+01,-0.11039E+01,& - -0.11046E+01,-0.11052E+01,-0.11059E+01,-0.11065E+01,-0.11071E+01,& - -0.11078E+01 / -! -! ** NH4Cl -! - DATA (BNC06M (IA),IA= 1,100)/ & - -0.50814E-01,-0.91326E-01,-0.11891E+00,-0.13710E+00,-0.15072E+00,& - -0.16157E+00,-0.17053E+00,-0.17813E+00,-0.18469E+00,-0.19042E+00,& - -0.19549E+00,-0.20001E+00,-0.20407E+00,-0.20774E+00,-0.21107E+00,& - -0.21410E+00,-0.21687E+00,-0.21942E+00,-0.22176E+00,-0.22392E+00,& - -0.22592E+00,-0.22777E+00,-0.22948E+00,-0.23108E+00,-0.23256E+00,& - -0.23394E+00,-0.23522E+00,-0.23642E+00,-0.23754E+00,-0.23858E+00,& - -0.23956E+00,-0.24048E+00,-0.24133E+00,-0.24213E+00,-0.24288E+00,& - -0.24359E+00,-0.24424E+00,-0.24486E+00,-0.24544E+00,-0.24598E+00,& - -0.24649E+00,-0.24696E+00,-0.24741E+00,-0.24782E+00,-0.24821E+00,& - -0.24858E+00,-0.24892E+00,-0.24923E+00,-0.24953E+00,-0.24980E+00,& - -0.25006E+00,-0.25030E+00,-0.25052E+00,-0.25072E+00,-0.25091E+00,& - -0.25108E+00,-0.25123E+00,-0.25137E+00,-0.25150E+00,-0.25161E+00,& - -0.25171E+00,-0.25180E+00,-0.25188E+00,-0.25194E+00,-0.25199E+00,& - -0.25203E+00,-0.25206E+00,-0.25207E+00,-0.25208E+00,-0.25207E+00,& - -0.25205E+00,-0.25203E+00,-0.25199E+00,-0.25194E+00,-0.25188E+00,& - -0.25180E+00,-0.25172E+00,-0.25163E+00,-0.25153E+00,-0.25141E+00,& - -0.25129E+00,-0.25116E+00,-0.25101E+00,-0.25086E+00,-0.25070E+00,& - -0.25052E+00,-0.25034E+00,-0.25015E+00,-0.24994E+00,-0.24973E+00,& - -0.24951E+00,-0.24928E+00,-0.24904E+00,-0.24879E+00,-0.24854E+00,& - -0.24827E+00,-0.24800E+00,-0.24772E+00,-0.24743E+00,-0.24713E+00/ - - DATA (BNC06M (IA),IA=101,200)/ & - -0.24683E+00,-0.24651E+00,-0.24620E+00,-0.24587E+00,-0.24554E+00,& - -0.24520E+00,-0.24485E+00,-0.24450E+00,-0.24415E+00,-0.24379E+00,& - -0.24342E+00,-0.24305E+00,-0.24267E+00,-0.24229E+00,-0.24190E+00,& - -0.24151E+00,-0.24112E+00,-0.24072E+00,-0.24032E+00,-0.23991E+00,& - -0.23958E+00,-0.23916E+00,-0.23874E+00,-0.23831E+00,-0.23788E+00,& - -0.23745E+00,-0.23702E+00,-0.23659E+00,-0.23615E+00,-0.23572E+00,& - -0.23528E+00,-0.23484E+00,-0.23439E+00,-0.23395E+00,-0.23350E+00,& - -0.23306E+00,-0.23261E+00,-0.23216E+00,-0.23171E+00,-0.23126E+00,& - -0.23080E+00,-0.23035E+00,-0.22989E+00,-0.22944E+00,-0.22898E+00,& - -0.22852E+00,-0.22806E+00,-0.22760E+00,-0.22713E+00,-0.22667E+00,& - -0.22621E+00,-0.22574E+00,-0.22528E+00,-0.22481E+00,-0.22434E+00,& - -0.22388E+00,-0.22341E+00,-0.22294E+00,-0.22247E+00,-0.22200E+00,& - -0.22153E+00,-0.22105E+00,-0.22058E+00,-0.22011E+00,-0.21963E+00,& - -0.21916E+00,-0.21869E+00,-0.21821E+00,-0.21773E+00,-0.21726E+00,& - -0.21678E+00,-0.21631E+00,-0.21583E+00,-0.21535E+00,-0.21487E+00,& - -0.21440E+00,-0.21392E+00,-0.21344E+00,-0.21296E+00,-0.21248E+00,& - -0.21200E+00,-0.21152E+00,-0.21104E+00,-0.21056E+00,-0.21008E+00,& - -0.20960E+00,-0.20912E+00,-0.20864E+00,-0.20816E+00,-0.20768E+00,& - -0.20720E+00,-0.20672E+00,-0.20624E+00,-0.20576E+00,-0.20527E+00,& - -0.20479E+00,-0.20431E+00,-0.20383E+00,-0.20335E+00,-0.20287E+00/ - - DATA (BNC06M (IA),IA=201,300)/ & - -0.20239E+00,-0.20191E+00,-0.20143E+00,-0.20094E+00,-0.20046E+00,& - -0.19998E+00,-0.19950E+00,-0.19902E+00,-0.19854E+00,-0.19806E+00,& - -0.19758E+00,-0.19710E+00,-0.19662E+00,-0.19614E+00,-0.19566E+00,& - -0.19518E+00,-0.19470E+00,-0.19422E+00,-0.19374E+00,-0.19326E+00,& - -0.19278E+00,-0.19230E+00,-0.19182E+00,-0.19135E+00,-0.19087E+00,& - -0.19039E+00,-0.18991E+00,-0.18943E+00,-0.18896E+00,-0.18848E+00,& - -0.18800E+00,-0.18753E+00,-0.18705E+00,-0.18657E+00,-0.18610E+00,& - -0.18562E+00,-0.18515E+00,-0.18467E+00,-0.18420E+00,-0.18372E+00,& - -0.18325E+00,-0.18277E+00,-0.18230E+00,-0.18183E+00,-0.18135E+00,& - -0.18088E+00,-0.18041E+00,-0.17994E+00,-0.17946E+00,-0.17899E+00,& - -0.17852E+00,-0.17805E+00,-0.17758E+00,-0.17711E+00,-0.17664E+00,& - -0.17617E+00,-0.17570E+00,-0.17523E+00,-0.17476E+00,-0.17430E+00,& - -0.17383E+00,-0.17336E+00,-0.17289E+00,-0.17243E+00,-0.17196E+00,& - -0.17149E+00,-0.17103E+00,-0.17056E+00,-0.17010E+00,-0.16963E+00,& - -0.16917E+00,-0.16871E+00,-0.16824E+00,-0.16778E+00,-0.16732E+00,& - -0.16685E+00,-0.16639E+00,-0.16593E+00,-0.16547E+00,-0.16501E+00,& - -0.16455E+00,-0.16409E+00,-0.16363E+00,-0.16317E+00,-0.16271E+00,& - -0.16225E+00,-0.16179E+00,-0.16134E+00,-0.16088E+00,-0.16042E+00,& - -0.15997E+00,-0.15951E+00,-0.15905E+00,-0.15860E+00,-0.15814E+00,& - -0.15769E+00,-0.15724E+00,-0.15678E+00,-0.15633E+00,-0.15588E+00/ - - DATA (BNC06M (IA),IA=301,400)/ & - -0.15542E+00,-0.15497E+00,-0.15452E+00,-0.15407E+00,-0.15362E+00,& - -0.15317E+00,-0.15272E+00,-0.15227E+00,-0.15182E+00,-0.15137E+00,& - -0.15092E+00,-0.15048E+00,-0.15003E+00,-0.14958E+00,-0.14914E+00,& - -0.14869E+00,-0.14825E+00,-0.14780E+00,-0.14736E+00,-0.14691E+00,& - -0.14647E+00,-0.14602E+00,-0.14558E+00,-0.14514E+00,-0.14470E+00,& - -0.14425E+00,-0.14381E+00,-0.14337E+00,-0.14293E+00,-0.14249E+00,& - -0.14205E+00,-0.14161E+00,-0.14118E+00,-0.14074E+00,-0.14030E+00,& - -0.13986E+00,-0.13943E+00,-0.13899E+00,-0.13855E+00,-0.13812E+00,& - -0.13768E+00,-0.13725E+00,-0.13681E+00,-0.13638E+00,-0.13595E+00,& - -0.13551E+00,-0.13508E+00,-0.13465E+00,-0.13422E+00,-0.13379E+00,& - -0.13336E+00,-0.13292E+00,-0.13249E+00,-0.13207E+00,-0.13164E+00,& - -0.13121E+00,-0.13078E+00,-0.13035E+00,-0.12992E+00,-0.12950E+00,& - -0.12907E+00,-0.12865E+00,-0.12822E+00,-0.12779E+00,-0.12737E+00,& - -0.12695E+00,-0.12652E+00,-0.12610E+00,-0.12568E+00,-0.12525E+00,& - -0.12483E+00,-0.12441E+00,-0.12399E+00,-0.12357E+00,-0.12315E+00,& - -0.12273E+00,-0.12231E+00,-0.12189E+00,-0.12147E+00,-0.12105E+00,& - -0.12063E+00,-0.12022E+00,-0.11980E+00,-0.11938E+00,-0.11897E+00,& - -0.11855E+00,-0.11814E+00,-0.11772E+00,-0.11731E+00,-0.11689E+00,& - -0.11648E+00,-0.11607E+00,-0.11565E+00,-0.11524E+00,-0.11483E+00,& - -0.11442E+00,-0.11401E+00,-0.11360E+00,-0.11319E+00,-0.11278E+00/ - - DATA (BNC06M (IA),IA=401,500)/ & - -0.11237E+00,-0.11196E+00,-0.11155E+00,-0.11114E+00,-0.11074E+00,& - -0.11033E+00,-0.10992E+00,-0.10952E+00,-0.10911E+00,-0.10871E+00,& - -0.10830E+00,-0.10790E+00,-0.10749E+00,-0.10709E+00,-0.10668E+00,& - -0.10628E+00,-0.10588E+00,-0.10548E+00,-0.10507E+00,-0.10467E+00,& - -0.10427E+00,-0.10387E+00,-0.10347E+00,-0.10307E+00,-0.10267E+00,& - -0.10227E+00,-0.10188E+00,-0.10148E+00,-0.10108E+00,-0.10068E+00,& - -0.10029E+00,-0.99891E-01,-0.99495E-01,-0.99100E-01,-0.98704E-01,& - -0.98310E-01,-0.97915E-01,-0.97522E-01,-0.97128E-01,-0.96735E-01,& - -0.96342E-01,-0.95950E-01,-0.95558E-01,-0.95167E-01,-0.94776E-01,& - -0.94385E-01,-0.93995E-01,-0.93605E-01,-0.93216E-01,-0.92827E-01,& - -0.92438E-01,-0.92050E-01,-0.91662E-01,-0.91274E-01,-0.90887E-01,& - -0.90501E-01,-0.90114E-01,-0.89729E-01,-0.89343E-01,-0.88958E-01,& - -0.88573E-01,-0.88189E-01,-0.87805E-01,-0.87422E-01,-0.87039E-01,& - -0.86656E-01,-0.86274E-01,-0.85892E-01,-0.85510E-01,-0.85129E-01,& - -0.84748E-01,-0.84368E-01,-0.83988E-01,-0.83608E-01,-0.83229E-01,& - -0.82850E-01,-0.82472E-01,-0.82094E-01,-0.81716E-01,-0.81339E-01,& - -0.80962E-01,-0.80585E-01,-0.80209E-01,-0.79833E-01,-0.79458E-01,& - -0.79083E-01,-0.78708E-01,-0.78334E-01,-0.77960E-01,-0.77586E-01,& - -0.77213E-01,-0.76840E-01,-0.76468E-01,-0.76096E-01,-0.75724E-01,& - -0.75353E-01,-0.74982E-01,-0.74612E-01,-0.74242E-01,-0.73872E-01/ - - DATA (BNC06M (IA),IA=501,600)/ & - -0.73502E-01,-0.73133E-01,-0.72765E-01,-0.72396E-01,-0.72028E-01,& - -0.71661E-01,-0.71294E-01,-0.70927E-01,-0.70560E-01,-0.70194E-01,& - -0.69829E-01,-0.69463E-01,-0.69098E-01,-0.68734E-01,-0.68369E-01,& - -0.68005E-01,-0.67642E-01,-0.67279E-01,-0.66916E-01,-0.66553E-01,& - -0.66191E-01,-0.65829E-01,-0.65468E-01,-0.65107E-01,-0.64746E-01,& - -0.64386E-01,-0.64026E-01,-0.63666E-01,-0.63307E-01,-0.62948E-01,& - -0.62590E-01,-0.62232E-01,-0.61874E-01,-0.61516E-01,-0.61159E-01,& - -0.60802E-01,-0.60446E-01,-0.60090E-01,-0.59734E-01,-0.59379E-01,& - -0.59024E-01,-0.58669E-01,-0.58315E-01,-0.57961E-01,-0.57607E-01,& - -0.57254E-01,-0.56901E-01,-0.56548E-01,-0.56196E-01,-0.55844E-01,& - -0.55492E-01,-0.55141E-01,-0.54790E-01,-0.54439E-01,-0.54089E-01,& - -0.53739E-01,-0.53390E-01,-0.53040E-01,-0.52692E-01,-0.52343E-01,& - -0.51995E-01,-0.51647E-01,-0.51299E-01,-0.50952E-01,-0.50605E-01,& - -0.50259E-01,-0.49913E-01,-0.49567E-01,-0.49221E-01,-0.48876E-01,& - -0.48531E-01,-0.48187E-01,-0.47842E-01,-0.47498E-01,-0.47155E-01,& - -0.46812E-01,-0.46469E-01,-0.46126E-01,-0.45784E-01,-0.45442E-01,& - -0.45100E-01,-0.44759E-01,-0.44418E-01,-0.44078E-01,-0.43737E-01,& - -0.43397E-01,-0.43058E-01,-0.42718E-01,-0.42379E-01,-0.42041E-01,& - -0.41702E-01,-0.41364E-01,-0.41027E-01,-0.40689E-01,-0.40352E-01,& - -0.40015E-01,-0.39679E-01,-0.39343E-01,-0.39007E-01,-0.37750E-01/ - - DATA (BNC06M (IA),IA=601,700)/ & - -0.35001E-01,-0.31698E-01,-0.28424E-01,-0.25181E-01,-0.21967E-01,& - -0.18782E-01,-0.15626E-01,-0.12497E-01,-0.93963E-02,-0.63224E-02,& - -0.32753E-02,-0.25450E-03, 0.27406E-02, 0.57102E-02, 0.86547E-02,& - 0.11575E-01, 0.14470E-01, 0.17342E-01, 0.20191E-01, 0.23016E-01,& - 0.25819E-01, 0.28599E-01, 0.31357E-01, 0.34093E-01, 0.36808E-01,& - 0.39502E-01, 0.42175E-01, 0.44827E-01, 0.47460E-01, 0.50072E-01,& - 0.52665E-01, 0.55239E-01, 0.57793E-01, 0.60329E-01, 0.62847E-01,& - 0.65346E-01, 0.67827E-01, 0.70291E-01, 0.72737E-01, 0.75165E-01,& - 0.77577E-01, 0.79972E-01, 0.82351E-01, 0.84713E-01, 0.87059E-01,& - 0.89390E-01, 0.91704E-01, 0.94003E-01, 0.96287E-01, 0.98556E-01,& - 0.10081E+00, 0.10305E+00, 0.10527E+00, 0.10749E+00, 0.10968E+00,& - 0.11186E+00, 0.11403E+00, 0.11619E+00, 0.11833E+00, 0.12046E+00,& - 0.12257E+00, 0.12468E+00, 0.12677E+00, 0.12884E+00, 0.13091E+00,& - 0.13296E+00, 0.13500E+00, 0.13703E+00, 0.13904E+00, 0.14105E+00,& - 0.14304E+00, 0.14502E+00, 0.14699E+00, 0.14895E+00, 0.15090E+00,& - 0.15283E+00, 0.15476E+00, 0.15668E+00, 0.15858E+00, 0.16047E+00,& - 0.16236E+00, 0.16423E+00, 0.16609E+00, 0.16795E+00, 0.16979E+00,& - 0.17162E+00, 0.17345E+00, 0.17526E+00, 0.17706E+00, 0.17886E+00,& - 0.18064E+00, 0.18242E+00, 0.18419E+00, 0.18595E+00, 0.18769E+00,& - 0.18944E+00, 0.19117E+00, 0.19289E+00, 0.19460E+00, 0.19631E+00/ - - DATA (BNC06M(IA),IA=701,741)/ & - 0.19801E+00, 0.19970E+00, 0.20138E+00, 0.20305E+00, 0.20471E+00,& - 0.20637E+00, 0.20802E+00, 0.20966E+00, 0.21129E+00, 0.21292E+00,& - 0.21453E+00, 0.21614E+00, 0.21775E+00, 0.21934E+00, 0.22093E+00,& - 0.22251E+00, 0.22408E+00, 0.22565E+00, 0.22721E+00, 0.22876E+00,& - 0.23030E+00, 0.23184E+00, 0.23337E+00, 0.23490E+00, 0.23641E+00,& - 0.23792E+00, 0.23943E+00, 0.24093E+00, 0.24242E+00, 0.24390E+00,& - 0.24538E+00, 0.24685E+00, 0.24832E+00, 0.24978E+00, 0.25123E+00,& - 0.25268E+00, 0.25412E+00, 0.25555E+00, 0.25698E+00, 0.25840E+00,& - 0.25982E+00 / -! -! ** (2H, SO4) -! - DATA (BNC07M (IA),IA= 1,100)/ & - -0.10285E+00,-0.18717E+00,-0.24637E+00,-0.28657E+00,-0.31747E+00,& - -0.34271E+00,-0.36411E+00,-0.38270E+00,-0.39914E+00,-0.41388E+00,& - -0.42725E+00,-0.43947E+00,-0.45073E+00,-0.46116E+00,-0.47088E+00,& - -0.47998E+00,-0.48853E+00,-0.49659E+00,-0.50422E+00,-0.51145E+00,& - -0.51833E+00,-0.52489E+00,-0.53115E+00,-0.53714E+00,-0.54288E+00,& - -0.54839E+00,-0.55369E+00,-0.55879E+00,-0.56371E+00,-0.56845E+00,& - -0.57304E+00,-0.57747E+00,-0.58177E+00,-0.58593E+00,-0.58996E+00,& - -0.59388E+00,-0.59768E+00,-0.60138E+00,-0.60497E+00,-0.60847E+00,& - -0.61188E+00,-0.61521E+00,-0.61845E+00,-0.62161E+00,-0.62469E+00,& - -0.62770E+00,-0.63065E+00,-0.63352E+00,-0.63634E+00,-0.63909E+00,& - -0.64178E+00,-0.64442E+00,-0.64700E+00,-0.64953E+00,-0.65201E+00,& - -0.65445E+00,-0.65683E+00,-0.65917E+00,-0.66147E+00,-0.66373E+00,& - -0.66594E+00,-0.66812E+00,-0.67026E+00,-0.67236E+00,-0.67443E+00,& - -0.67646E+00,-0.67846E+00,-0.68043E+00,-0.68237E+00,-0.68427E+00,& - -0.68615E+00,-0.68800E+00,-0.68983E+00,-0.69162E+00,-0.69339E+00,& - -0.69514E+00,-0.69686E+00,-0.69856E+00,-0.70024E+00,-0.70189E+00,& - -0.70352E+00,-0.70514E+00,-0.70673E+00,-0.70830E+00,-0.70985E+00,& - -0.71139E+00,-0.71290E+00,-0.71440E+00,-0.71588E+00,-0.71734E+00,& - -0.71879E+00,-0.72022E+00,-0.72164E+00,-0.72304E+00,-0.72442E+00,& - -0.72579E+00,-0.72715E+00,-0.72849E+00,-0.72982E+00,-0.73113E+00/ - - DATA (BNC07M (IA),IA=101,200)/ & - -0.73243E+00,-0.73372E+00,-0.73500E+00,-0.73626E+00,-0.73751E+00,& - -0.73875E+00,-0.73998E+00,-0.74119E+00,-0.74240E+00,-0.74359E+00,& - -0.74477E+00,-0.74594E+00,-0.74710E+00,-0.74825E+00,-0.74939E+00,& - -0.75052E+00,-0.75164E+00,-0.75275E+00,-0.75385E+00,-0.75494E+00,& - -0.75600E+00,-0.75708E+00,-0.75814E+00,-0.75920E+00,-0.76025E+00,& - -0.76128E+00,-0.76231E+00,-0.76333E+00,-0.76435E+00,-0.76535E+00,& - -0.76634E+00,-0.76733E+00,-0.76831E+00,-0.76928E+00,-0.77025E+00,& - -0.77120E+00,-0.77215E+00,-0.77310E+00,-0.77403E+00,-0.77496E+00,& - -0.77588E+00,-0.77679E+00,-0.77770E+00,-0.77860E+00,-0.77949E+00,& - -0.78038E+00,-0.78126E+00,-0.78213E+00,-0.78300E+00,-0.78386E+00,& - -0.78472E+00,-0.78557E+00,-0.78641E+00,-0.78725E+00,-0.78808E+00,& - -0.78890E+00,-0.78972E+00,-0.79054E+00,-0.79135E+00,-0.79215E+00,& - -0.79295E+00,-0.79374E+00,-0.79453E+00,-0.79531E+00,-0.79609E+00,& - -0.79686E+00,-0.79763E+00,-0.79840E+00,-0.79915E+00,-0.79991E+00,& - -0.80065E+00,-0.80140E+00,-0.80214E+00,-0.80287E+00,-0.80360E+00,& - -0.80433E+00,-0.80505E+00,-0.80577E+00,-0.80648E+00,-0.80719E+00,& - -0.80789E+00,-0.80859E+00,-0.80929E+00,-0.80998E+00,-0.81067E+00,& - -0.81135E+00,-0.81203E+00,-0.81271E+00,-0.81338E+00,-0.81405E+00,& - -0.81471E+00,-0.81537E+00,-0.81603E+00,-0.81669E+00,-0.81734E+00,& - -0.81798E+00,-0.81863E+00,-0.81926E+00,-0.81990E+00,-0.82053E+00/ - - DATA (BNC07M (IA),IA=201,300)/ & - -0.82116E+00,-0.82179E+00,-0.82241E+00,-0.82303E+00,-0.82365E+00,& - -0.82426E+00,-0.82487E+00,-0.82548E+00,-0.82608E+00,-0.82668E+00,& - -0.82728E+00,-0.82787E+00,-0.82846E+00,-0.82905E+00,-0.82963E+00,& - -0.83022E+00,-0.83080E+00,-0.83137E+00,-0.83195E+00,-0.83252E+00,& - -0.83309E+00,-0.83365E+00,-0.83421E+00,-0.83477E+00,-0.83533E+00,& - -0.83589E+00,-0.83644E+00,-0.83699E+00,-0.83753E+00,-0.83808E+00,& - -0.83862E+00,-0.83916E+00,-0.83970E+00,-0.84023E+00,-0.84076E+00,& - -0.84129E+00,-0.84182E+00,-0.84234E+00,-0.84286E+00,-0.84338E+00,& - -0.84390E+00,-0.84442E+00,-0.84493E+00,-0.84544E+00,-0.84595E+00,& - -0.84645E+00,-0.84696E+00,-0.84746E+00,-0.84796E+00,-0.84846E+00,& - -0.84895E+00,-0.84945E+00,-0.84994E+00,-0.85043E+00,-0.85091E+00,& - -0.85140E+00,-0.85188E+00,-0.85236E+00,-0.85284E+00,-0.85332E+00,& - -0.85379E+00,-0.85426E+00,-0.85473E+00,-0.85520E+00,-0.85567E+00,& - -0.85614E+00,-0.85660E+00,-0.85706E+00,-0.85752E+00,-0.85798E+00,& - -0.85843E+00,-0.85889E+00,-0.85934E+00,-0.85979E+00,-0.86024E+00,& - -0.86069E+00,-0.86113E+00,-0.86157E+00,-0.86202E+00,-0.86246E+00,& - -0.86289E+00,-0.86333E+00,-0.86377E+00,-0.86420E+00,-0.86463E+00,& - -0.86506E+00,-0.86549E+00,-0.86592E+00,-0.86634E+00,-0.86676E+00,& - -0.86719E+00,-0.86761E+00,-0.86803E+00,-0.86844E+00,-0.86886E+00,& - -0.86927E+00,-0.86969E+00,-0.87010E+00,-0.87051E+00,-0.87091E+00/ - - DATA (BNC07M (IA),IA=301,400)/ & - -0.87132E+00,-0.87173E+00,-0.87213E+00,-0.87253E+00,-0.87293E+00,& - -0.87333E+00,-0.87373E+00,-0.87413E+00,-0.87452E+00,-0.87492E+00,& - -0.87531E+00,-0.87570E+00,-0.87609E+00,-0.87648E+00,-0.87687E+00,& - -0.87725E+00,-0.87764E+00,-0.87802E+00,-0.87840E+00,-0.87878E+00,& - -0.87916E+00,-0.87954E+00,-0.87992E+00,-0.88029E+00,-0.88067E+00,& - -0.88104E+00,-0.88141E+00,-0.88178E+00,-0.88215E+00,-0.88252E+00,& - -0.88289E+00,-0.88325E+00,-0.88362E+00,-0.88398E+00,-0.88434E+00,& - -0.88470E+00,-0.88506E+00,-0.88542E+00,-0.88578E+00,-0.88614E+00,& - -0.88649E+00,-0.88685E+00,-0.88720E+00,-0.88755E+00,-0.88790E+00,& - -0.88825E+00,-0.88860E+00,-0.88895E+00,-0.88929E+00,-0.88964E+00,& - -0.88998E+00,-0.89033E+00,-0.89067E+00,-0.89101E+00,-0.89135E+00,& - -0.89169E+00,-0.89203E+00,-0.89236E+00,-0.89270E+00,-0.89303E+00,& - -0.89337E+00,-0.89370E+00,-0.89403E+00,-0.89436E+00,-0.89469E+00,& - -0.89502E+00,-0.89535E+00,-0.89568E+00,-0.89600E+00,-0.89633E+00,& - -0.89665E+00,-0.89697E+00,-0.89730E+00,-0.89762E+00,-0.89794E+00,& - -0.89826E+00,-0.89857E+00,-0.89889E+00,-0.89921E+00,-0.89952E+00,& - -0.89984E+00,-0.90015E+00,-0.90047E+00,-0.90078E+00,-0.90109E+00,& - -0.90140E+00,-0.90171E+00,-0.90202E+00,-0.90232E+00,-0.90263E+00,& - -0.90294E+00,-0.90324E+00,-0.90355E+00,-0.90385E+00,-0.90415E+00,& - -0.90445E+00,-0.90475E+00,-0.90505E+00,-0.90535E+00,-0.90565E+00/ - - DATA (BNC07M (IA),IA=401,500)/ & - -0.90595E+00,-0.90625E+00,-0.90654E+00,-0.90684E+00,-0.90713E+00,& - -0.90743E+00,-0.90772E+00,-0.90801E+00,-0.90830E+00,-0.90859E+00,& - -0.90888E+00,-0.90917E+00,-0.90946E+00,-0.90975E+00,-0.91003E+00,& - -0.91032E+00,-0.91060E+00,-0.91089E+00,-0.91117E+00,-0.91145E+00,& - -0.91174E+00,-0.91202E+00,-0.91230E+00,-0.91258E+00,-0.91286E+00,& - -0.91314E+00,-0.91341E+00,-0.91369E+00,-0.91397E+00,-0.91424E+00,& - -0.91452E+00,-0.91479E+00,-0.91507E+00,-0.91534E+00,-0.91561E+00,& - -0.91588E+00,-0.91615E+00,-0.91642E+00,-0.91669E+00,-0.91696E+00,& - -0.91723E+00,-0.91750E+00,-0.91776E+00,-0.91803E+00,-0.91830E+00,& - -0.91856E+00,-0.91883E+00,-0.91909E+00,-0.91935E+00,-0.91961E+00,& - -0.91988E+00,-0.92014E+00,-0.92040E+00,-0.92066E+00,-0.92092E+00,& - -0.92117E+00,-0.92143E+00,-0.92169E+00,-0.92195E+00,-0.92220E+00,& - -0.92246E+00,-0.92271E+00,-0.92297E+00,-0.92322E+00,-0.92347E+00,& - -0.92373E+00,-0.92398E+00,-0.92423E+00,-0.92448E+00,-0.92473E+00,& - -0.92498E+00,-0.92523E+00,-0.92548E+00,-0.92572E+00,-0.92597E+00,& - -0.92622E+00,-0.92646E+00,-0.92671E+00,-0.92695E+00,-0.92720E+00,& - -0.92744E+00,-0.92768E+00,-0.92793E+00,-0.92817E+00,-0.92841E+00,& - -0.92865E+00,-0.92889E+00,-0.92913E+00,-0.92937E+00,-0.92961E+00,& - -0.92985E+00,-0.93009E+00,-0.93032E+00,-0.93056E+00,-0.93080E+00,& - -0.93103E+00,-0.93127E+00,-0.93150E+00,-0.93174E+00,-0.93197E+00/ - - DATA (BNC07M (IA),IA=501,600)/ & - -0.93220E+00,-0.93243E+00,-0.93267E+00,-0.93290E+00,-0.93313E+00,& - -0.93336E+00,-0.93359E+00,-0.93382E+00,-0.93405E+00,-0.93428E+00,& - -0.93450E+00,-0.93473E+00,-0.93496E+00,-0.93519E+00,-0.93541E+00,& - -0.93564E+00,-0.93586E+00,-0.93609E+00,-0.93631E+00,-0.93653E+00,& - -0.93676E+00,-0.93698E+00,-0.93720E+00,-0.93742E+00,-0.93765E+00,& - -0.93787E+00,-0.93809E+00,-0.93831E+00,-0.93853E+00,-0.93875E+00,& - -0.93896E+00,-0.93918E+00,-0.93940E+00,-0.93962E+00,-0.93983E+00,& - -0.94005E+00,-0.94027E+00,-0.94048E+00,-0.94070E+00,-0.94091E+00,& - -0.94112E+00,-0.94134E+00,-0.94155E+00,-0.94176E+00,-0.94198E+00,& - -0.94219E+00,-0.94240E+00,-0.94261E+00,-0.94282E+00,-0.94303E+00,& - -0.94324E+00,-0.94345E+00,-0.94366E+00,-0.94387E+00,-0.94408E+00,& - -0.94428E+00,-0.94449E+00,-0.94470E+00,-0.94491E+00,-0.94511E+00,& - -0.94532E+00,-0.94552E+00,-0.94573E+00,-0.94593E+00,-0.94614E+00,& - -0.94634E+00,-0.94654E+00,-0.94675E+00,-0.94695E+00,-0.94715E+00,& - -0.94735E+00,-0.94755E+00,-0.94775E+00,-0.94795E+00,-0.94815E+00,& - -0.94835E+00,-0.94855E+00,-0.94875E+00,-0.94895E+00,-0.94915E+00,& - -0.94935E+00,-0.94954E+00,-0.94974E+00,-0.94994E+00,-0.95014E+00,& - -0.95033E+00,-0.95053E+00,-0.95072E+00,-0.95092E+00,-0.95111E+00,& - -0.95131E+00,-0.95150E+00,-0.95169E+00,-0.95189E+00,-0.95208E+00,& - -0.95227E+00,-0.95246E+00,-0.95265E+00,-0.95285E+00,-0.95356E+00/ - - DATA (BNC07M (IA),IA=601,700)/ & - -0.95511E+00,-0.95697E+00,-0.95879E+00,-0.96057E+00,-0.96233E+00,& - -0.96406E+00,-0.96576E+00,-0.96743E+00,-0.96907E+00,-0.97069E+00,& - -0.97228E+00,-0.97385E+00,-0.97539E+00,-0.97691E+00,-0.97841E+00,& - -0.97989E+00,-0.98134E+00,-0.98277E+00,-0.98418E+00,-0.98558E+00,& - -0.98695E+00,-0.98830E+00,-0.98964E+00,-0.99096E+00,-0.99226E+00,& - -0.99354E+00,-0.99481E+00,-0.99606E+00,-0.99730E+00,-0.99852E+00,& - -0.99972E+00,-0.10009E+01,-0.10021E+01,-0.10032E+01,-0.10044E+01,& - -0.10055E+01,-0.10067E+01,-0.10078E+01,-0.10089E+01,-0.10099E+01,& - -0.10110E+01,-0.10121E+01,-0.10131E+01,-0.10142E+01,-0.10152E+01,& - -0.10162E+01,-0.10172E+01,-0.10182E+01,-0.10192E+01,-0.10201E+01,& - -0.10211E+01,-0.10221E+01,-0.10230E+01,-0.10239E+01,-0.10249E+01,& - -0.10258E+01,-0.10267E+01,-0.10276E+01,-0.10285E+01,-0.10293E+01,& - -0.10302E+01,-0.10311E+01,-0.10319E+01,-0.10328E+01,-0.10336E+01,& - -0.10345E+01,-0.10353E+01,-0.10361E+01,-0.10369E+01,-0.10377E+01,& - -0.10385E+01,-0.10393E+01,-0.10401E+01,-0.10409E+01,-0.10416E+01,& - -0.10424E+01,-0.10432E+01,-0.10439E+01,-0.10447E+01,-0.10454E+01,& - -0.10461E+01,-0.10469E+01,-0.10476E+01,-0.10483E+01,-0.10490E+01,& - -0.10497E+01,-0.10504E+01,-0.10511E+01,-0.10518E+01,-0.10525E+01,& - -0.10532E+01,-0.10538E+01,-0.10545E+01,-0.10552E+01,-0.10558E+01,& - -0.10565E+01,-0.10571E+01,-0.10578E+01,-0.10584E+01,-0.10591E+01/ - - DATA (BNC07M(IA),IA=701,741)/ & - -0.10597E+01,-0.10603E+01,-0.10609E+01,-0.10616E+01,-0.10622E+01,& - -0.10628E+01,-0.10634E+01,-0.10640E+01,-0.10646E+01,-0.10652E+01,& - -0.10658E+01,-0.10663E+01,-0.10669E+01,-0.10675E+01,-0.10681E+01,& - -0.10687E+01,-0.10692E+01,-0.10698E+01,-0.10703E+01,-0.10709E+01,& - -0.10714E+01,-0.10720E+01,-0.10725E+01,-0.10731E+01,-0.10736E+01,& - -0.10742E+01,-0.10747E+01,-0.10752E+01,-0.10757E+01,-0.10763E+01,& - -0.10768E+01,-0.10773E+01,-0.10778E+01,-0.10783E+01,-0.10788E+01,& - -0.10793E+01,-0.10798E+01,-0.10803E+01,-0.10808E+01,-0.10813E+01,& - -0.10818E+01 / -! -! ** (H, HSO4) -! - DATA (BNC08M (IA),IA= 1,100)/ & - -0.48178E-01,-0.82334E-01,-0.10277E+00,-0.11452E+00,-0.12211E+00,& - -0.12718E+00,-0.13053E+00,-0.13262E+00,-0.13374E+00,-0.13407E+00,& - -0.13376E+00,-0.13289E+00,-0.13155E+00,-0.12979E+00,-0.12766E+00,& - -0.12519E+00,-0.12242E+00,-0.11937E+00,-0.11607E+00,-0.11252E+00,& - -0.10875E+00,-0.10478E+00,-0.10060E+00,-0.96246E-01,-0.91714E-01,& - -0.87015E-01,-0.82158E-01,-0.77151E-01,-0.72001E-01,-0.66714E-01,& - -0.61297E-01,-0.55755E-01,-0.50094E-01,-0.44319E-01,-0.38434E-01,& - -0.32445E-01,-0.26356E-01,-0.20172E-01,-0.13895E-01,-0.75315E-02,& - -0.10835E-02, 0.54448E-02, 0.12050E-01, 0.18729E-01, 0.25479E-01,& - 0.32296E-01, 0.39178E-01, 0.46121E-01, 0.53125E-01, 0.60185E-01,& - 0.67299E-01, 0.74467E-01, 0.81685E-01, 0.88951E-01, 0.96265E-01,& - 0.10362E+00, 0.11103E+00, 0.11847E+00, 0.12596E+00, 0.13349E+00,& - 0.14106E+00, 0.14866E+00, 0.15631E+00, 0.16400E+00, 0.17172E+00,& - 0.17948E+00, 0.18727E+00, 0.19511E+00, 0.20298E+00, 0.21089E+00,& - 0.21884E+00, 0.22683E+00, 0.23486E+00, 0.24293E+00, 0.25103E+00,& - 0.25918E+00, 0.26737E+00, 0.27560E+00, 0.28387E+00, 0.29219E+00,& - 0.30055E+00, 0.30895E+00, 0.31740E+00, 0.32589E+00, 0.33443E+00,& - 0.34301E+00, 0.35163E+00, 0.36030E+00, 0.36901E+00, 0.37777E+00,& - 0.38658E+00, 0.39542E+00, 0.40431E+00, 0.41324E+00, 0.42221E+00,& - 0.43122E+00, 0.44027E+00, 0.44936E+00, 0.45849E+00, 0.46765E+00/ - - DATA (BNC08M (IA),IA=101,200)/ & - 0.47684E+00, 0.48607E+00, 0.49533E+00, 0.50462E+00, 0.51393E+00,& - 0.52328E+00, 0.53264E+00, 0.54203E+00, 0.55144E+00, 0.56087E+00,& - 0.57032E+00, 0.57979E+00, 0.58926E+00, 0.59876E+00, 0.60826E+00,& - 0.61777E+00, 0.62729E+00, 0.63682E+00, 0.64635E+00, 0.65589E+00,& - 0.66464E+00, 0.67427E+00, 0.68389E+00, 0.69350E+00, 0.70310E+00,& - 0.71269E+00, 0.72227E+00, 0.73184E+00, 0.74139E+00, 0.75094E+00,& - 0.76047E+00, 0.76999E+00, 0.77950E+00, 0.78899E+00, 0.79847E+00,& - 0.80794E+00, 0.81739E+00, 0.82683E+00, 0.83625E+00, 0.84566E+00,& - 0.85506E+00, 0.86444E+00, 0.87380E+00, 0.88315E+00, 0.89249E+00,& - 0.90181E+00, 0.91111E+00, 0.92039E+00, 0.92966E+00, 0.93892E+00,& - 0.94816E+00, 0.95738E+00, 0.96658E+00, 0.97577E+00, 0.98494E+00,& - 0.99409E+00, 0.10032E+01, 0.10123E+01, 0.10215E+01, 0.10305E+01,& - 0.10396E+01, 0.10487E+01, 0.10577E+01, 0.10667E+01, 0.10757E+01,& - 0.10847E+01, 0.10936E+01, 0.11026E+01, 0.11115E+01, 0.11204E+01,& - 0.11293E+01, 0.11382E+01, 0.11470E+01, 0.11559E+01, 0.11647E+01,& - 0.11735E+01, 0.11823E+01, 0.11910E+01, 0.11998E+01, 0.12085E+01,& - 0.12172E+01, 0.12259E+01, 0.12346E+01, 0.12432E+01, 0.12519E+01,& - 0.12605E+01, 0.12691E+01, 0.12777E+01, 0.12862E+01, 0.12948E+01,& - 0.13033E+01, 0.13118E+01, 0.13203E+01, 0.13288E+01, 0.13372E+01,& - 0.13457E+01, 0.13541E+01, 0.13625E+01, 0.13709E+01, 0.13793E+01/ - - DATA (BNC08M (IA),IA=201,300)/ & - 0.13876E+01, 0.13959E+01, 0.14043E+01, 0.14126E+01, 0.14208E+01,& - 0.14291E+01, 0.14373E+01, 0.14456E+01, 0.14538E+01, 0.14620E+01,& - 0.14701E+01, 0.14783E+01, 0.14864E+01, 0.14945E+01, 0.15027E+01,& - 0.15107E+01, 0.15188E+01, 0.15269E+01, 0.15349E+01, 0.15429E+01,& - 0.15509E+01, 0.15589E+01, 0.15669E+01, 0.15748E+01, 0.15828E+01,& - 0.15907E+01, 0.15986E+01, 0.16065E+01, 0.16143E+01, 0.16222E+01,& - 0.16300E+01, 0.16378E+01, 0.16456E+01, 0.16534E+01, 0.16612E+01,& - 0.16689E+01, 0.16767E+01, 0.16844E+01, 0.16921E+01, 0.16998E+01,& - 0.17075E+01, 0.17151E+01, 0.17227E+01, 0.17304E+01, 0.17380E+01,& - 0.17456E+01, 0.17531E+01, 0.17607E+01, 0.17683E+01, 0.17758E+01,& - 0.17833E+01, 0.17908E+01, 0.17983E+01, 0.18057E+01, 0.18132E+01,& - 0.18206E+01, 0.18281E+01, 0.18355E+01, 0.18429E+01, 0.18502E+01,& - 0.18576E+01, 0.18649E+01, 0.18723E+01, 0.18796E+01, 0.18869E+01,& - 0.18942E+01, 0.19014E+01, 0.19087E+01, 0.19159E+01, 0.19232E+01,& - 0.19304E+01, 0.19376E+01, 0.19448E+01, 0.19519E+01, 0.19591E+01,& - 0.19662E+01, 0.19734E+01, 0.19805E+01, 0.19876E+01, 0.19947E+01,& - 0.20017E+01, 0.20088E+01, 0.20158E+01, 0.20229E+01, 0.20299E+01,& - 0.20369E+01, 0.20439E+01, 0.20509E+01, 0.20578E+01, 0.20648E+01,& - 0.20717E+01, 0.20786E+01, 0.20855E+01, 0.20924E+01, 0.20993E+01,& - 0.21062E+01, 0.21130E+01, 0.21199E+01, 0.21267E+01, 0.21335E+01/ - - DATA (BNC08M (IA),IA=301,400)/ & - 0.21403E+01, 0.21471E+01, 0.21539E+01, 0.21606E+01, 0.21674E+01,& - 0.21741E+01, 0.21808E+01, 0.21875E+01, 0.21942E+01, 0.22009E+01,& - 0.22076E+01, 0.22143E+01, 0.22209E+01, 0.22275E+01, 0.22342E+01,& - 0.22408E+01, 0.22474E+01, 0.22540E+01, 0.22605E+01, 0.22671E+01,& - 0.22737E+01, 0.22802E+01, 0.22867E+01, 0.22932E+01, 0.22997E+01,& - 0.23062E+01, 0.23127E+01, 0.23192E+01, 0.23256E+01, 0.23321E+01,& - 0.23385E+01, 0.23449E+01, 0.23513E+01, 0.23577E+01, 0.23641E+01,& - 0.23705E+01, 0.23768E+01, 0.23832E+01, 0.23895E+01, 0.23958E+01,& - 0.24021E+01, 0.24084E+01, 0.24147E+01, 0.24210E+01, 0.24273E+01,& - 0.24335E+01, 0.24398E+01, 0.24460E+01, 0.24522E+01, 0.24585E+01,& - 0.24647E+01, 0.24709E+01, 0.24770E+01, 0.24832E+01, 0.24894E+01,& - 0.24955E+01, 0.25016E+01, 0.25078E+01, 0.25139E+01, 0.25200E+01,& - 0.25261E+01, 0.25322E+01, 0.25382E+01, 0.25443E+01, 0.25504E+01,& - 0.25564E+01, 0.25624E+01, 0.25685E+01, 0.25745E+01, 0.25805E+01,& - 0.25865E+01, 0.25924E+01, 0.25984E+01, 0.26044E+01, 0.26103E+01,& - 0.26163E+01, 0.26222E+01, 0.26281E+01, 0.26340E+01, 0.26399E+01,& - 0.26458E+01, 0.26517E+01, 0.26576E+01, 0.26634E+01, 0.26693E+01,& - 0.26751E+01, 0.26809E+01, 0.26868E+01, 0.26926E+01, 0.26984E+01,& - 0.27042E+01, 0.27099E+01, 0.27157E+01, 0.27215E+01, 0.27272E+01,& - 0.27330E+01, 0.27387E+01, 0.27444E+01, 0.27501E+01, 0.27559E+01/ - - DATA (BNC08M (IA),IA=401,500)/ & - 0.27615E+01, 0.27672E+01, 0.27729E+01, 0.27786E+01, 0.27842E+01,& - 0.27899E+01, 0.27955E+01, 0.28012E+01, 0.28068E+01, 0.28124E+01,& - 0.28180E+01, 0.28236E+01, 0.28292E+01, 0.28348E+01, 0.28403E+01,& - 0.28459E+01, 0.28515E+01, 0.28570E+01, 0.28625E+01, 0.28681E+01,& - 0.28736E+01, 0.28791E+01, 0.28846E+01, 0.28901E+01, 0.28956E+01,& - 0.29010E+01, 0.29065E+01, 0.29119E+01, 0.29174E+01, 0.29228E+01,& - 0.29283E+01, 0.29337E+01, 0.29391E+01, 0.29445E+01, 0.29499E+01,& - 0.29553E+01, 0.29607E+01, 0.29660E+01, 0.29714E+01, 0.29768E+01,& - 0.29821E+01, 0.29874E+01, 0.29928E+01, 0.29981E+01, 0.30034E+01,& - 0.30087E+01, 0.30140E+01, 0.30193E+01, 0.30246E+01, 0.30299E+01,& - 0.30351E+01, 0.30404E+01, 0.30456E+01, 0.30509E+01, 0.30561E+01,& - 0.30613E+01, 0.30666E+01, 0.30718E+01, 0.30770E+01, 0.30822E+01,& - 0.30874E+01, 0.30925E+01, 0.30977E+01, 0.31029E+01, 0.31080E+01,& - 0.31132E+01, 0.31183E+01, 0.31235E+01, 0.31286E+01, 0.31337E+01,& - 0.31388E+01, 0.31439E+01, 0.31490E+01, 0.31541E+01, 0.31592E+01,& - 0.31643E+01, 0.31693E+01, 0.31744E+01, 0.31794E+01, 0.31845E+01,& - 0.31895E+01, 0.31945E+01, 0.31996E+01, 0.32046E+01, 0.32096E+01,& - 0.32146E+01, 0.32196E+01, 0.32246E+01, 0.32296E+01, 0.32345E+01,& - 0.32395E+01, 0.32444E+01, 0.32494E+01, 0.32543E+01, 0.32593E+01,& - 0.32642E+01, 0.32691E+01, 0.32740E+01, 0.32790E+01, 0.32839E+01/ - - DATA (BNC08M (IA),IA=501,600)/ & - 0.32888E+01, 0.32936E+01, 0.32985E+01, 0.33034E+01, 0.33083E+01,& - 0.33131E+01, 0.33180E+01, 0.33228E+01, 0.33277E+01, 0.33325E+01,& - 0.33373E+01, 0.33421E+01, 0.33470E+01, 0.33518E+01, 0.33566E+01,& - 0.33614E+01, 0.33662E+01, 0.33709E+01, 0.33757E+01, 0.33805E+01,& - 0.33852E+01, 0.33900E+01, 0.33947E+01, 0.33995E+01, 0.34042E+01,& - 0.34089E+01, 0.34137E+01, 0.34184E+01, 0.34231E+01, 0.34278E+01,& - 0.34325E+01, 0.34372E+01, 0.34419E+01, 0.34465E+01, 0.34512E+01,& - 0.34559E+01, 0.34605E+01, 0.34652E+01, 0.34698E+01, 0.34745E+01,& - 0.34791E+01, 0.34837E+01, 0.34884E+01, 0.34930E+01, 0.34976E+01,& - 0.35022E+01, 0.35068E+01, 0.35114E+01, 0.35160E+01, 0.35205E+01,& - 0.35251E+01, 0.35297E+01, 0.35342E+01, 0.35388E+01, 0.35433E+01,& - 0.35479E+01, 0.35524E+01, 0.35569E+01, 0.35615E+01, 0.35660E+01,& - 0.35705E+01, 0.35750E+01, 0.35795E+01, 0.35840E+01, 0.35885E+01,& - 0.35930E+01, 0.35975E+01, 0.36019E+01, 0.36064E+01, 0.36109E+01,& - 0.36153E+01, 0.36198E+01, 0.36242E+01, 0.36286E+01, 0.36331E+01,& - 0.36375E+01, 0.36419E+01, 0.36463E+01, 0.36508E+01, 0.36552E+01,& - 0.36596E+01, 0.36639E+01, 0.36683E+01, 0.36727E+01, 0.36771E+01,& - 0.36815E+01, 0.36858E+01, 0.36902E+01, 0.36945E+01, 0.36989E+01,& - 0.37032E+01, 0.37076E+01, 0.37119E+01, 0.37162E+01, 0.37206E+01,& - 0.37249E+01, 0.37292E+01, 0.37335E+01, 0.37378E+01, 0.37539E+01/ - - DATA (BNC08M (IA),IA=601,700)/ & - 0.37890E+01, 0.38311E+01, 0.38727E+01, 0.39138E+01, 0.39544E+01,& - 0.39945E+01, 0.40342E+01, 0.40734E+01, 0.41122E+01, 0.41506E+01,& - 0.41885E+01, 0.42261E+01, 0.42632E+01, 0.42999E+01, 0.43363E+01,& - 0.43722E+01, 0.44078E+01, 0.44431E+01, 0.44780E+01, 0.45125E+01,& - 0.45467E+01, 0.45806E+01, 0.46141E+01, 0.46473E+01, 0.46802E+01,& - 0.47128E+01, 0.47451E+01, 0.47771E+01, 0.48088E+01, 0.48402E+01,& - 0.48713E+01, 0.49022E+01, 0.49327E+01, 0.49630E+01, 0.49931E+01,& - 0.50229E+01, 0.50524E+01, 0.50817E+01, 0.51107E+01, 0.51395E+01,& - 0.51681E+01, 0.51964E+01, 0.52245E+01, 0.52524E+01, 0.52800E+01,& - 0.53074E+01, 0.53346E+01, 0.53616E+01, 0.53884E+01, 0.54150E+01,& - 0.54414E+01, 0.54676E+01, 0.54936E+01, 0.55194E+01, 0.55450E+01,& - 0.55704E+01, 0.55956E+01, 0.56206E+01, 0.56455E+01, 0.56702E+01,& - 0.56947E+01, 0.57191E+01, 0.57432E+01, 0.57672E+01, 0.57911E+01,& - 0.58148E+01, 0.58383E+01, 0.58616E+01, 0.58848E+01, 0.59079E+01,& - 0.59308E+01, 0.59535E+01, 0.59761E+01, 0.59986E+01, 0.60209E+01,& - 0.60430E+01, 0.60650E+01, 0.60869E+01, 0.61087E+01, 0.61303E+01,& - 0.61517E+01, 0.61731E+01, 0.61943E+01, 0.62154E+01, 0.62363E+01,& - 0.62572E+01, 0.62779E+01, 0.62984E+01, 0.63189E+01, 0.63392E+01,& - 0.63595E+01, 0.63796E+01, 0.63996E+01, 0.64194E+01, 0.64392E+01,& - 0.64588E+01, 0.64784E+01, 0.64978E+01, 0.65171E+01, 0.65363E+01/ - - DATA (BNC08M(IA),IA=701,741)/ & - 0.65554E+01, 0.65744E+01, 0.65933E+01, 0.66121E+01, 0.66308E+01,& - 0.66494E+01, 0.66679E+01, 0.66863E+01, 0.67046E+01, 0.67228E+01,& - 0.67409E+01, 0.67589E+01, 0.67768E+01, 0.67947E+01, 0.68124E+01,& - 0.68300E+01, 0.68476E+01, 0.68651E+01, 0.68824E+01, 0.68997E+01,& - 0.69169E+01, 0.69341E+01, 0.69511E+01, 0.69680E+01, 0.69849E+01,& - 0.70017E+01, 0.70184E+01, 0.70350E+01, 0.70516E+01, 0.70681E+01,& - 0.70845E+01, 0.71008E+01, 0.71170E+01, 0.71332E+01, 0.71493E+01,& - 0.71653E+01, 0.71812E+01, 0.71971E+01, 0.72129E+01, 0.72286E+01,& - 0.72442E+01 / -! -! ** NH4HSO4 -! - DATA (BNC09M (IA),IA= 1,100)/ & - -0.50460E-01,-0.90365E-01,-0.11751E+00,-0.13545E+00,-0.14891E+00,& - -0.15966E+00,-0.16855E+00,-0.17609E+00,-0.18259E+00,-0.18826E+00,& - -0.19325E+00,-0.19767E+00,-0.20160E+00,-0.20511E+00,-0.20826E+00,& - -0.21107E+00,-0.21359E+00,-0.21585E+00,-0.21786E+00,-0.21965E+00,& - -0.22123E+00,-0.22262E+00,-0.22384E+00,-0.22488E+00,-0.22578E+00,& - -0.22652E+00,-0.22713E+00,-0.22760E+00,-0.22795E+00,-0.22817E+00,& - -0.22829E+00,-0.22829E+00,-0.22819E+00,-0.22799E+00,-0.22770E+00,& - -0.22731E+00,-0.22683E+00,-0.22627E+00,-0.22563E+00,-0.22491E+00,& - -0.22411E+00,-0.22324E+00,-0.22230E+00,-0.22129E+00,-0.22021E+00,& - -0.21907E+00,-0.21788E+00,-0.21662E+00,-0.21530E+00,-0.21394E+00,& - -0.21251E+00,-0.21104E+00,-0.20952E+00,-0.20795E+00,-0.20634E+00,& - -0.20468E+00,-0.20297E+00,-0.20123E+00,-0.19944E+00,-0.19762E+00,& - -0.19576E+00,-0.19386E+00,-0.19192E+00,-0.18995E+00,-0.18795E+00,& - -0.18591E+00,-0.18384E+00,-0.18174E+00,-0.17961E+00,-0.17744E+00,& - -0.17525E+00,-0.17303E+00,-0.17078E+00,-0.16849E+00,-0.16619E+00,& - -0.16385E+00,-0.16149E+00,-0.15910E+00,-0.15668E+00,-0.15423E+00,& - -0.15176E+00,-0.14927E+00,-0.14675E+00,-0.14420E+00,-0.14163E+00,& - -0.13903E+00,-0.13641E+00,-0.13376E+00,-0.13110E+00,-0.12840E+00,& - -0.12569E+00,-0.12295E+00,-0.12020E+00,-0.11742E+00,-0.11462E+00,& - -0.11180E+00,-0.10896E+00,-0.10610E+00,-0.10322E+00,-0.10033E+00/ - - DATA (BNC09M (IA),IA=101,200)/ & - -0.97415E-01,-0.94487E-01,-0.91545E-01,-0.88587E-01,-0.85616E-01,& - -0.82631E-01,-0.79634E-01,-0.76626E-01,-0.73606E-01,-0.70577E-01,& - -0.67538E-01,-0.64490E-01,-0.61435E-01,-0.58371E-01,-0.55302E-01,& - -0.52227E-01,-0.49147E-01,-0.46061E-01,-0.42972E-01,-0.39880E-01,& - -0.37062E-01,-0.33933E-01,-0.30805E-01,-0.27679E-01,-0.24555E-01,& - -0.21433E-01,-0.18313E-01,-0.15196E-01,-0.12082E-01,-0.89703E-02,& - -0.58621E-02,-0.27572E-02, 0.34429E-03, 0.34421E-02, 0.65364E-02,& - 0.96264E-02, 0.12713E-01, 0.15795E-01, 0.18873E-01, 0.21946E-01,& - 0.25015E-01, 0.28079E-01, 0.31139E-01, 0.34193E-01, 0.37243E-01,& - 0.40288E-01, 0.43328E-01, 0.46362E-01, 0.49392E-01, 0.52416E-01,& - 0.55435E-01, 0.58448E-01, 0.61456E-01, 0.64458E-01, 0.67455E-01,& - 0.70446E-01, 0.73432E-01, 0.76411E-01, 0.79385E-01, 0.82354E-01,& - 0.85316E-01, 0.88272E-01, 0.91223E-01, 0.94168E-01, 0.97106E-01,& - 0.10004E+00, 0.10297E+00, 0.10589E+00, 0.10880E+00, 0.11171E+00,& - 0.11461E+00, 0.11751E+00, 0.12040E+00, 0.12328E+00, 0.12616E+00,& - 0.12903E+00, 0.13190E+00, 0.13476E+00, 0.13761E+00, 0.14046E+00,& - 0.14330E+00, 0.14614E+00, 0.14896E+00, 0.15179E+00, 0.15460E+00,& - 0.15741E+00, 0.16022E+00, 0.16302E+00, 0.16581E+00, 0.16859E+00,& - 0.17138E+00, 0.17415E+00, 0.17692E+00, 0.17968E+00, 0.18243E+00,& - 0.18518E+00, 0.18793E+00, 0.19066E+00, 0.19340E+00, 0.19612E+00/ - - DATA (BNC09M (IA),IA=201,300)/ & - 0.19884E+00, 0.20155E+00, 0.20426E+00, 0.20696E+00, 0.20966E+00,& - 0.21235E+00, 0.21503E+00, 0.21771E+00, 0.22038E+00, 0.22305E+00,& - 0.22571E+00, 0.22837E+00, 0.23101E+00, 0.23366E+00, 0.23629E+00,& - 0.23893E+00, 0.24155E+00, 0.24417E+00, 0.24679E+00, 0.24940E+00,& - 0.25200E+00, 0.25460E+00, 0.25719E+00, 0.25978E+00, 0.26236E+00,& - 0.26493E+00, 0.26750E+00, 0.27007E+00, 0.27262E+00, 0.27518E+00,& - 0.27772E+00, 0.28027E+00, 0.28280E+00, 0.28534E+00, 0.28786E+00,& - 0.29038E+00, 0.29290E+00, 0.29541E+00, 0.29791E+00, 0.30041E+00,& - 0.30291E+00, 0.30540E+00, 0.30788E+00, 0.31036E+00, 0.31283E+00,& - 0.31530E+00, 0.31776E+00, 0.32022E+00, 0.32268E+00, 0.32512E+00,& - 0.32757E+00, 0.33000E+00, 0.33244E+00, 0.33486E+00, 0.33729E+00,& - 0.33971E+00, 0.34212E+00, 0.34453E+00, 0.34693E+00, 0.34933E+00,& - 0.35172E+00, 0.35411E+00, 0.35649E+00, 0.35887E+00, 0.36125E+00,& - 0.36362E+00, 0.36598E+00, 0.36834E+00, 0.37070E+00, 0.37305E+00,& - 0.37539E+00, 0.37773E+00, 0.38007E+00, 0.38240E+00, 0.38473E+00,& - 0.38705E+00, 0.38937E+00, 0.39168E+00, 0.39399E+00, 0.39630E+00,& - 0.39860E+00, 0.40089E+00, 0.40318E+00, 0.40547E+00, 0.40775E+00,& - 0.41003E+00, 0.41230E+00, 0.41457E+00, 0.41684E+00, 0.41910E+00,& - 0.42136E+00, 0.42361E+00, 0.42585E+00, 0.42810E+00, 0.43034E+00,& - 0.43257E+00, 0.43480E+00, 0.43703E+00, 0.43925E+00, 0.44147E+00/ - - DATA (BNC09M (IA),IA=301,400)/ & - 0.44368E+00, 0.44589E+00, 0.44810E+00, 0.45030E+00, 0.45250E+00,& - 0.45469E+00, 0.45688E+00, 0.45906E+00, 0.46124E+00, 0.46342E+00,& - 0.46559E+00, 0.46776E+00, 0.46993E+00, 0.47209E+00, 0.47425E+00,& - 0.47640E+00, 0.47855E+00, 0.48070E+00, 0.48284E+00, 0.48497E+00,& - 0.48711E+00, 0.48924E+00, 0.49136E+00, 0.49349E+00, 0.49561E+00,& - 0.49772E+00, 0.49983E+00, 0.50194E+00, 0.50404E+00, 0.50614E+00,& - 0.50824E+00, 0.51033E+00, 0.51242E+00, 0.51450E+00, 0.51658E+00,& - 0.51866E+00, 0.52074E+00, 0.52281E+00, 0.52487E+00, 0.52694E+00,& - 0.52900E+00, 0.53105E+00, 0.53311E+00, 0.53515E+00, 0.53720E+00,& - 0.53924E+00, 0.54128E+00, 0.54331E+00, 0.54535E+00, 0.54737E+00,& - 0.54940E+00, 0.55142E+00, 0.55344E+00, 0.55545E+00, 0.55746E+00,& - 0.55947E+00, 0.56147E+00, 0.56347E+00, 0.56547E+00, 0.56747E+00,& - 0.56946E+00, 0.57144E+00, 0.57343E+00, 0.57541E+00, 0.57738E+00,& - 0.57936E+00, 0.58133E+00, 0.58330E+00, 0.58526E+00, 0.58722E+00,& - 0.58918E+00, 0.59113E+00, 0.59309E+00, 0.59503E+00, 0.59698E+00,& - 0.59892E+00, 0.60086E+00, 0.60279E+00, 0.60473E+00, 0.60666E+00,& - 0.60858E+00, 0.61050E+00, 0.61242E+00, 0.61434E+00, 0.61625E+00,& - 0.61817E+00, 0.62007E+00, 0.62198E+00, 0.62388E+00, 0.62578E+00,& - 0.62767E+00, 0.62957E+00, 0.63145E+00, 0.63334E+00, 0.63522E+00,& - 0.63710E+00, 0.63898E+00, 0.64086E+00, 0.64273E+00, 0.64460E+00/ - - DATA (BNC09M (IA),IA=401,500)/ & - 0.64646E+00, 0.64833E+00, 0.65019E+00, 0.65204E+00, 0.65390E+00,& - 0.65575E+00, 0.65760E+00, 0.65944E+00, 0.66128E+00, 0.66312E+00,& - 0.66496E+00, 0.66680E+00, 0.66863E+00, 0.67046E+00, 0.67228E+00,& - 0.67410E+00, 0.67592E+00, 0.67774E+00, 0.67956E+00, 0.68137E+00,& - 0.68318E+00, 0.68498E+00, 0.68679E+00, 0.68859E+00, 0.69039E+00,& - 0.69218E+00, 0.69398E+00, 0.69577E+00, 0.69755E+00, 0.69934E+00,& - 0.70112E+00, 0.70290E+00, 0.70468E+00, 0.70645E+00, 0.70822E+00,& - 0.70999E+00, 0.71176E+00, 0.71352E+00, 0.71528E+00, 0.71704E+00,& - 0.71880E+00, 0.72055E+00, 0.72230E+00, 0.72405E+00, 0.72580E+00,& - 0.72754E+00, 0.72928E+00, 0.73102E+00, 0.73275E+00, 0.73449E+00,& - 0.73622E+00, 0.73794E+00, 0.73967E+00, 0.74139E+00, 0.74311E+00,& - 0.74483E+00, 0.74655E+00, 0.74826E+00, 0.74997E+00, 0.75168E+00,& - 0.75339E+00, 0.75509E+00, 0.75679E+00, 0.75849E+00, 0.76019E+00,& - 0.76188E+00, 0.76357E+00, 0.76526E+00, 0.76695E+00, 0.76863E+00,& - 0.77031E+00, 0.77199E+00, 0.77367E+00, 0.77534E+00, 0.77702E+00,& - 0.77869E+00, 0.78035E+00, 0.78202E+00, 0.78368E+00, 0.78534E+00,& - 0.78700E+00, 0.78866E+00, 0.79031E+00, 0.79197E+00, 0.79362E+00,& - 0.79526E+00, 0.79691E+00, 0.79855E+00, 0.80019E+00, 0.80183E+00,& - 0.80347E+00, 0.80510E+00, 0.80673E+00, 0.80836E+00, 0.80999E+00,& - 0.81161E+00, 0.81323E+00, 0.81486E+00, 0.81647E+00, 0.81809E+00/ - - DATA (BNC09M (IA),IA=501,600)/ & - 0.81970E+00, 0.82132E+00, 0.82293E+00, 0.82453E+00, 0.82614E+00,& - 0.82774E+00, 0.82934E+00, 0.83094E+00, 0.83254E+00, 0.83413E+00,& - 0.83573E+00, 0.83732E+00, 0.83890E+00, 0.84049E+00, 0.84207E+00,& - 0.84366E+00, 0.84524E+00, 0.84681E+00, 0.84839E+00, 0.84996E+00,& - 0.85154E+00, 0.85311E+00, 0.85467E+00, 0.85624E+00, 0.85780E+00,& - 0.85936E+00, 0.86092E+00, 0.86248E+00, 0.86404E+00, 0.86559E+00,& - 0.86714E+00, 0.86869E+00, 0.87024E+00, 0.87178E+00, 0.87333E+00,& - 0.87487E+00, 0.87641E+00, 0.87795E+00, 0.87948E+00, 0.88101E+00,& - 0.88255E+00, 0.88408E+00, 0.88560E+00, 0.88713E+00, 0.88865E+00,& - 0.89017E+00, 0.89169E+00, 0.89321E+00, 0.89473E+00, 0.89624E+00,& - 0.89776E+00, 0.89927E+00, 0.90077E+00, 0.90228E+00, 0.90379E+00,& - 0.90529E+00, 0.90679E+00, 0.90829E+00, 0.90979E+00, 0.91128E+00,& - 0.91277E+00, 0.91427E+00, 0.91576E+00, 0.91724E+00, 0.91873E+00,& - 0.92021E+00, 0.92170E+00, 0.92318E+00, 0.92466E+00, 0.92613E+00,& - 0.92761E+00, 0.92908E+00, 0.93055E+00, 0.93202E+00, 0.93349E+00,& - 0.93496E+00, 0.93642E+00, 0.93788E+00, 0.93935E+00, 0.94080E+00,& - 0.94226E+00, 0.94372E+00, 0.94517E+00, 0.94662E+00, 0.94807E+00,& - 0.94952E+00, 0.95097E+00, 0.95241E+00, 0.95386E+00, 0.95530E+00,& - 0.95674E+00, 0.95818E+00, 0.95961E+00, 0.96105E+00, 0.96248E+00,& - 0.96391E+00, 0.96534E+00, 0.96677E+00, 0.96820E+00, 0.97353E+00/ - - DATA (BNC09M (IA),IA=601,700)/ & - 0.98518E+00, 0.99915E+00, 0.10130E+01, 0.10266E+01, 0.10401E+01,& - 0.10535E+01, 0.10667E+01, 0.10797E+01, 0.10927E+01, 0.11054E+01,& - 0.11181E+01, 0.11306E+01, 0.11430E+01, 0.11553E+01, 0.11674E+01,& - 0.11794E+01, 0.11913E+01, 0.12031E+01, 0.12148E+01, 0.12263E+01,& - 0.12378E+01, 0.12491E+01, 0.12604E+01, 0.12715E+01, 0.12825E+01,& - 0.12934E+01, 0.13043E+01, 0.13150E+01, 0.13257E+01, 0.13362E+01,& - 0.13467E+01, 0.13570E+01, 0.13673E+01, 0.13775E+01, 0.13876E+01,& - 0.13976E+01, 0.14075E+01, 0.14174E+01, 0.14272E+01, 0.14369E+01,& - 0.14465E+01, 0.14560E+01, 0.14655E+01, 0.14749E+01, 0.14842E+01,& - 0.14935E+01, 0.15027E+01, 0.15118E+01, 0.15208E+01, 0.15298E+01,& - 0.15387E+01, 0.15476E+01, 0.15563E+01, 0.15651E+01, 0.15737E+01,& - 0.15823E+01, 0.15908E+01, 0.15993E+01, 0.16077E+01, 0.16161E+01,& - 0.16244E+01, 0.16326E+01, 0.16408E+01, 0.16489E+01, 0.16570E+01,& - 0.16650E+01, 0.16730E+01, 0.16809E+01, 0.16888E+01, 0.16966E+01,& - 0.17044E+01, 0.17121E+01, 0.17197E+01, 0.17274E+01, 0.17349E+01,& - 0.17424E+01, 0.17499E+01, 0.17574E+01, 0.17647E+01, 0.17721E+01,& - 0.17794E+01, 0.17866E+01, 0.17938E+01, 0.18010E+01, 0.18081E+01,& - 0.18152E+01, 0.18222E+01, 0.18292E+01, 0.18362E+01, 0.18431E+01,& - 0.18500E+01, 0.18568E+01, 0.18636E+01, 0.18704E+01, 0.18771E+01,& - 0.18838E+01, 0.18905E+01, 0.18971E+01, 0.19037E+01, 0.19102E+01/ - - DATA (BNC09M(IA),IA=701,741)/ & - 0.19167E+01, 0.19232E+01, 0.19296E+01, 0.19360E+01, 0.19424E+01,& - 0.19488E+01, 0.19551E+01, 0.19613E+01, 0.19676E+01, 0.19738E+01,& - 0.19800E+01, 0.19861E+01, 0.19922E+01, 0.19983E+01, 0.20044E+01,& - 0.20104E+01, 0.20164E+01, 0.20223E+01, 0.20283E+01, 0.20342E+01,& - 0.20401E+01, 0.20459E+01, 0.20517E+01, 0.20575E+01, 0.20633E+01,& - 0.20690E+01, 0.20747E+01, 0.20804E+01, 0.20861E+01, 0.20917E+01,& - 0.20973E+01, 0.21029E+01, 0.21084E+01, 0.21140E+01, 0.21195E+01,& - 0.21249E+01, 0.21304E+01, 0.21358E+01, 0.21412E+01, 0.21466E+01,& - 0.21520E+01 / -! -! ** (H, NO3) -! - DATA (BNC10M (IA),IA= 1,100)/ & - -0.49808E-01,-0.87670E-01,-0.11206E+00,-0.12725E+00,-0.13801E+00,& - -0.14607E+00,-0.15233E+00,-0.15727E+00,-0.16121E+00,-0.16437E+00,& - -0.16689E+00,-0.16889E+00,-0.17045E+00,-0.17164E+00,-0.17251E+00,& - -0.17311E+00,-0.17346E+00,-0.17359E+00,-0.17354E+00,-0.17332E+00,& - -0.17295E+00,-0.17244E+00,-0.17181E+00,-0.17107E+00,-0.17023E+00,& - -0.16931E+00,-0.16829E+00,-0.16721E+00,-0.16605E+00,-0.16483E+00,& - -0.16356E+00,-0.16223E+00,-0.16086E+00,-0.15944E+00,-0.15798E+00,& - -0.15649E+00,-0.15496E+00,-0.15340E+00,-0.15182E+00,-0.15021E+00,& - -0.14858E+00,-0.14693E+00,-0.14526E+00,-0.14357E+00,-0.14187E+00,& - -0.14015E+00,-0.13842E+00,-0.13668E+00,-0.13493E+00,-0.13316E+00,& - -0.13139E+00,-0.12961E+00,-0.12783E+00,-0.12603E+00,-0.12423E+00,& - -0.12243E+00,-0.12061E+00,-0.11880E+00,-0.11697E+00,-0.11514E+00,& - -0.11330E+00,-0.11146E+00,-0.10961E+00,-0.10776E+00,-0.10590E+00,& - -0.10403E+00,-0.10215E+00,-0.10027E+00,-0.98377E-01,-0.96477E-01,& - -0.94568E-01,-0.92650E-01,-0.90723E-01,-0.88785E-01,-0.86836E-01,& - -0.84877E-01,-0.82906E-01,-0.80923E-01,-0.78927E-01,-0.76919E-01,& - -0.74899E-01,-0.72864E-01,-0.70817E-01,-0.68755E-01,-0.66679E-01,& - -0.64590E-01,-0.62485E-01,-0.60367E-01,-0.58234E-01,-0.56087E-01,& - -0.53925E-01,-0.51749E-01,-0.49559E-01,-0.47354E-01,-0.45136E-01,& - -0.42905E-01,-0.40659E-01,-0.38401E-01,-0.36131E-01,-0.33847E-01/ - - DATA (BNC10M (IA),IA=101,200)/ & - -0.31552E-01,-0.29246E-01,-0.26928E-01,-0.24599E-01,-0.22261E-01,& - -0.19912E-01,-0.17554E-01,-0.15187E-01,-0.12812E-01,-0.10429E-01,& - -0.80390E-02,-0.56417E-02,-0.32380E-02,-0.82822E-03, 0.15871E-02,& - 0.40074E-02, 0.64324E-02, 0.88617E-02, 0.11295E-01, 0.13731E-01,& - 0.15915E-01, 0.18387E-01, 0.20858E-01, 0.23329E-01, 0.25799E-01,& - 0.28268E-01, 0.30736E-01, 0.33203E-01, 0.35669E-01, 0.38134E-01,& - 0.40598E-01, 0.43060E-01, 0.45521E-01, 0.47981E-01, 0.50440E-01,& - 0.52896E-01, 0.55352E-01, 0.57806E-01, 0.60258E-01, 0.62708E-01,& - 0.65157E-01, 0.67604E-01, 0.70049E-01, 0.72492E-01, 0.74934E-01,& - 0.77373E-01, 0.79810E-01, 0.82246E-01, 0.84679E-01, 0.87110E-01,& - 0.89539E-01, 0.91966E-01, 0.94390E-01, 0.96812E-01, 0.99232E-01,& - 0.10165E+00, 0.10407E+00, 0.10648E+00, 0.10889E+00, 0.11130E+00,& - 0.11370E+00, 0.11611E+00, 0.11851E+00, 0.12090E+00, 0.12330E+00,& - 0.12569E+00, 0.12808E+00, 0.13047E+00, 0.13285E+00, 0.13524E+00,& - 0.13762E+00, 0.13999E+00, 0.14237E+00, 0.14474E+00, 0.14711E+00,& - 0.14947E+00, 0.15183E+00, 0.15419E+00, 0.15655E+00, 0.15891E+00,& - 0.16126E+00, 0.16361E+00, 0.16595E+00, 0.16829E+00, 0.17063E+00,& - 0.17297E+00, 0.17530E+00, 0.17764E+00, 0.17996E+00, 0.18229E+00,& - 0.18461E+00, 0.18693E+00, 0.18924E+00, 0.19156E+00, 0.19387E+00,& - 0.19617E+00, 0.19848E+00, 0.20078E+00, 0.20308E+00, 0.20537E+00/ - - DATA (BNC10M (IA),IA=201,300)/ & - 0.20766E+00, 0.20995E+00, 0.21223E+00, 0.21452E+00, 0.21680E+00,& - 0.21907E+00, 0.22134E+00, 0.22361E+00, 0.22588E+00, 0.22814E+00,& - 0.23040E+00, 0.23266E+00, 0.23491E+00, 0.23717E+00, 0.23941E+00,& - 0.24166E+00, 0.24390E+00, 0.24614E+00, 0.24837E+00, 0.25060E+00,& - 0.25283E+00, 0.25506E+00, 0.25728E+00, 0.25950E+00, 0.26171E+00,& - 0.26393E+00, 0.26614E+00, 0.26834E+00, 0.27054E+00, 0.27274E+00,& - 0.27494E+00, 0.27713E+00, 0.27933E+00, 0.28151E+00, 0.28370E+00,& - 0.28588E+00, 0.28805E+00, 0.29023E+00, 0.29240E+00, 0.29457E+00,& - 0.29673E+00, 0.29890E+00, 0.30105E+00, 0.30321E+00, 0.30536E+00,& - 0.30751E+00, 0.30966E+00, 0.31180E+00, 0.31394E+00, 0.31607E+00,& - 0.31821E+00, 0.32034E+00, 0.32247E+00, 0.32459E+00, 0.32671E+00,& - 0.32883E+00, 0.33094E+00, 0.33305E+00, 0.33516E+00, 0.33727E+00,& - 0.33937E+00, 0.34147E+00, 0.34356E+00, 0.34565E+00, 0.34774E+00,& - 0.34983E+00, 0.35191E+00, 0.35399E+00, 0.35607E+00, 0.35814E+00,& - 0.36021E+00, 0.36228E+00, 0.36435E+00, 0.36641E+00, 0.36847E+00,& - 0.37052E+00, 0.37257E+00, 0.37462E+00, 0.37667E+00, 0.37871E+00,& - 0.38075E+00, 0.38279E+00, 0.38482E+00, 0.38685E+00, 0.38888E+00,& - 0.39091E+00, 0.39293E+00, 0.39495E+00, 0.39696E+00, 0.39898E+00,& - 0.40099E+00, 0.40299E+00, 0.40500E+00, 0.40700E+00, 0.40899E+00,& - 0.41099E+00, 0.41298E+00, 0.41497E+00, 0.41696E+00, 0.41894E+00/ - - DATA (BNC10M (IA),IA=301,400)/ & - 0.42092E+00, 0.42290E+00, 0.42487E+00, 0.42684E+00, 0.42881E+00,& - 0.43077E+00, 0.43274E+00, 0.43470E+00, 0.43665E+00, 0.43861E+00,& - 0.44056E+00, 0.44251E+00, 0.44445E+00, 0.44639E+00, 0.44833E+00,& - 0.45027E+00, 0.45220E+00, 0.45413E+00, 0.45606E+00, 0.45798E+00,& - 0.45991E+00, 0.46183E+00, 0.46374E+00, 0.46566E+00, 0.46757E+00,& - 0.46947E+00, 0.47138E+00, 0.47328E+00, 0.47518E+00, 0.47708E+00,& - 0.47897E+00, 0.48086E+00, 0.48275E+00, 0.48464E+00, 0.48652E+00,& - 0.48840E+00, 0.49028E+00, 0.49215E+00, 0.49402E+00, 0.49589E+00,& - 0.49776E+00, 0.49962E+00, 0.50148E+00, 0.50334E+00, 0.50520E+00,& - 0.50705E+00, 0.50890E+00, 0.51075E+00, 0.51259E+00, 0.51443E+00,& - 0.51627E+00, 0.51811E+00, 0.51994E+00, 0.52178E+00, 0.52360E+00,& - 0.52543E+00, 0.52725E+00, 0.52907E+00, 0.53089E+00, 0.53271E+00,& - 0.53452E+00, 0.53633E+00, 0.53814E+00, 0.53994E+00, 0.54175E+00,& - 0.54355E+00, 0.54534E+00, 0.54714E+00, 0.54893E+00, 0.55072E+00,& - 0.55251E+00, 0.55429E+00, 0.55607E+00, 0.55785E+00, 0.55963E+00,& - 0.56140E+00, 0.56318E+00, 0.56495E+00, 0.56671E+00, 0.56848E+00,& - 0.57024E+00, 0.57200E+00, 0.57375E+00, 0.57551E+00, 0.57726E+00,& - 0.57901E+00, 0.58076E+00, 0.58250E+00, 0.58424E+00, 0.58598E+00,& - 0.58772E+00, 0.58945E+00, 0.59119E+00, 0.59292E+00, 0.59464E+00,& - 0.59637E+00, 0.59809E+00, 0.59981E+00, 0.60153E+00, 0.60324E+00/ - - DATA (BNC10M (IA),IA=401,500)/ & - 0.60496E+00, 0.60667E+00, 0.60838E+00, 0.61008E+00, 0.61178E+00,& - 0.61349E+00, 0.61518E+00, 0.61688E+00, 0.61857E+00, 0.62027E+00,& - 0.62196E+00, 0.62364E+00, 0.62533E+00, 0.62701E+00, 0.62869E+00,& - 0.63037E+00, 0.63204E+00, 0.63372E+00, 0.63539E+00, 0.63705E+00,& - 0.63872E+00, 0.64039E+00, 0.64205E+00, 0.64371E+00, 0.64536E+00,& - 0.64702E+00, 0.64867E+00, 0.65032E+00, 0.65197E+00, 0.65362E+00,& - 0.65526E+00, 0.65690E+00, 0.65854E+00, 0.66018E+00, 0.66181E+00,& - 0.66344E+00, 0.66507E+00, 0.66670E+00, 0.66833E+00, 0.66995E+00,& - 0.67157E+00, 0.67319E+00, 0.67481E+00, 0.67643E+00, 0.67804E+00,& - 0.67965E+00, 0.68126E+00, 0.68286E+00, 0.68447E+00, 0.68607E+00,& - 0.68767E+00, 0.68927E+00, 0.69086E+00, 0.69246E+00, 0.69405E+00,& - 0.69564E+00, 0.69723E+00, 0.69881E+00, 0.70040E+00, 0.70198E+00,& - 0.70356E+00, 0.70513E+00, 0.70671E+00, 0.70828E+00, 0.70985E+00,& - 0.71142E+00, 0.71299E+00, 0.71455E+00, 0.71611E+00, 0.71767E+00,& - 0.71923E+00, 0.72079E+00, 0.72234E+00, 0.72390E+00, 0.72545E+00,& - 0.72699E+00, 0.72854E+00, 0.73008E+00, 0.73163E+00, 0.73317E+00,& - 0.73471E+00, 0.73624E+00, 0.73778E+00, 0.73931E+00, 0.74084E+00,& - 0.74237E+00, 0.74389E+00, 0.74542E+00, 0.74694E+00, 0.74846E+00,& - 0.74998E+00, 0.75150E+00, 0.75301E+00, 0.75453E+00, 0.75604E+00,& - 0.75755E+00, 0.75905E+00, 0.76056E+00, 0.76206E+00, 0.76356E+00/ - - DATA (BNC10M (IA),IA=501,600)/ & - 0.76506E+00, 0.76656E+00, 0.76806E+00, 0.76955E+00, 0.77104E+00,& - 0.77253E+00, 0.77402E+00, 0.77551E+00, 0.77699E+00, 0.77847E+00,& - 0.77995E+00, 0.78143E+00, 0.78291E+00, 0.78439E+00, 0.78586E+00,& - 0.78733E+00, 0.78880E+00, 0.79027E+00, 0.79173E+00, 0.79320E+00,& - 0.79466E+00, 0.79612E+00, 0.79758E+00, 0.79904E+00, 0.80049E+00,& - 0.80195E+00, 0.80340E+00, 0.80485E+00, 0.80630E+00, 0.80774E+00,& - 0.80919E+00, 0.81063E+00, 0.81207E+00, 0.81351E+00, 0.81495E+00,& - 0.81638E+00, 0.81782E+00, 0.81925E+00, 0.82068E+00, 0.82211E+00,& - 0.82353E+00, 0.82496E+00, 0.82638E+00, 0.82780E+00, 0.82923E+00,& - 0.83064E+00, 0.83206E+00, 0.83347E+00, 0.83489E+00, 0.83630E+00,& - 0.83771E+00, 0.83912E+00, 0.84052E+00, 0.84193E+00, 0.84333E+00,& - 0.84473E+00, 0.84613E+00, 0.84753E+00, 0.84893E+00, 0.85032E+00,& - 0.85171E+00, 0.85311E+00, 0.85450E+00, 0.85588E+00, 0.85727E+00,& - 0.85866E+00, 0.86004E+00, 0.86142E+00, 0.86280E+00, 0.86418E+00,& - 0.86555E+00, 0.86693E+00, 0.86830E+00, 0.86968E+00, 0.87105E+00,& - 0.87241E+00, 0.87378E+00, 0.87515E+00, 0.87651E+00, 0.87787E+00,& - 0.87923E+00, 0.88059E+00, 0.88195E+00, 0.88330E+00, 0.88466E+00,& - 0.88601E+00, 0.88736E+00, 0.88871E+00, 0.89006E+00, 0.89141E+00,& - 0.89275E+00, 0.89410E+00, 0.89544E+00, 0.89678E+00, 0.89812E+00,& - 0.89945E+00, 0.90079E+00, 0.90212E+00, 0.90346E+00, 0.90844E+00/ - - DATA (BNC10M (IA),IA=601,700)/ & - 0.91933E+00, 0.93239E+00, 0.94531E+00, 0.95808E+00, 0.97072E+00,& - 0.98322E+00, 0.99558E+00, 0.10078E+01, 0.10199E+01, 0.10319E+01,& - 0.10438E+01, 0.10555E+01, 0.10671E+01, 0.10786E+01, 0.10900E+01,& - 0.11013E+01, 0.11124E+01, 0.11235E+01, 0.11344E+01, 0.11453E+01,& - 0.11560E+01, 0.11666E+01, 0.11772E+01, 0.11876E+01, 0.11980E+01,& - 0.12082E+01, 0.12184E+01, 0.12285E+01, 0.12385E+01, 0.12484E+01,& - 0.12582E+01, 0.12679E+01, 0.12776E+01, 0.12871E+01, 0.12966E+01,& - 0.13060E+01, 0.13154E+01, 0.13246E+01, 0.13338E+01, 0.13429E+01,& - 0.13519E+01, 0.13609E+01, 0.13698E+01, 0.13786E+01, 0.13874E+01,& - 0.13960E+01, 0.14047E+01, 0.14132E+01, 0.14217E+01, 0.14301E+01,& - 0.14385E+01, 0.14468E+01, 0.14550E+01, 0.14632E+01, 0.14713E+01,& - 0.14794E+01, 0.14874E+01, 0.14954E+01, 0.15033E+01, 0.15111E+01,& - 0.15189E+01, 0.15266E+01, 0.15343E+01, 0.15419E+01, 0.15495E+01,& - 0.15570E+01, 0.15645E+01, 0.15719E+01, 0.15793E+01, 0.15866E+01,& - 0.15939E+01, 0.16012E+01, 0.16084E+01, 0.16155E+01, 0.16226E+01,& - 0.16297E+01, 0.16367E+01, 0.16436E+01, 0.16506E+01, 0.16574E+01,& - 0.16643E+01, 0.16711E+01, 0.16778E+01, 0.16845E+01, 0.16912E+01,& - 0.16979E+01, 0.17045E+01, 0.17110E+01, 0.17175E+01, 0.17240E+01,& - 0.17305E+01, 0.17369E+01, 0.17433E+01, 0.17496E+01, 0.17559E+01,& - 0.17622E+01, 0.17684E+01, 0.17746E+01, 0.17808E+01, 0.17869E+01/ - - DATA (BNC10M(IA),IA=701,741)/ & - 0.17930E+01, 0.17991E+01, 0.18051E+01, 0.18111E+01, 0.18171E+01,& - 0.18230E+01, 0.18289E+01, 0.18348E+01, 0.18406E+01, 0.18464E+01,& - 0.18522E+01, 0.18580E+01, 0.18637E+01, 0.18694E+01, 0.18751E+01,& - 0.18807E+01, 0.18863E+01, 0.18919E+01, 0.18974E+01, 0.19030E+01,& - 0.19085E+01, 0.19139E+01, 0.19194E+01, 0.19248E+01, 0.19302E+01,& - 0.19356E+01, 0.19409E+01, 0.19462E+01, 0.19515E+01, 0.19568E+01,& - 0.19620E+01, 0.19672E+01, 0.19724E+01, 0.19776E+01, 0.19828E+01,& - 0.19879E+01, 0.19930E+01, 0.19981E+01, 0.20031E+01, 0.20081E+01,& - 0.20131E+01 / -! -! ** (H, Cl) -! - DATA (BNC11M (IA),IA= 1,100)/ & - -0.48532E-01,-0.83296E-01,-0.10417E+00,-0.11618E+00,-0.12392E+00,& - -0.12909E+00,-0.13252E+00,-0.13467E+00,-0.13584E+00,-0.13624E+00,& - -0.13600E+00,-0.13524E+00,-0.13402E+00,-0.13242E+00,-0.13047E+00,& - -0.12822E+00,-0.12570E+00,-0.12295E+00,-0.11997E+00,-0.11680E+00,& - -0.11344E+00,-0.10992E+00,-0.10625E+00,-0.10244E+00,-0.98493E-01,& - -0.94429E-01,-0.90252E-01,-0.85971E-01,-0.81593E-01,-0.77125E-01,& - -0.72571E-01,-0.67939E-01,-0.63234E-01,-0.58460E-01,-0.53621E-01,& - -0.48723E-01,-0.43768E-01,-0.38762E-01,-0.33706E-01,-0.28606E-01,& - -0.23462E-01,-0.18280E-01,-0.13061E-01,-0.78068E-02,-0.25211E-02,& - 0.27943E-02, 0.81376E-02, 0.13507E-01, 0.18900E-01, 0.24317E-01,& - 0.29754E-01, 0.35212E-01, 0.40689E-01, 0.46183E-01, 0.51695E-01,& - 0.57224E-01, 0.62769E-01, 0.68329E-01, 0.73904E-01, 0.79495E-01,& - 0.85100E-01, 0.90721E-01, 0.96357E-01, 0.10201E+00, 0.10768E+00,& - 0.11336E+00, 0.11906E+00, 0.12478E+00, 0.13051E+00, 0.13627E+00,& - 0.14204E+00, 0.14783E+00, 0.15365E+00, 0.15948E+00, 0.16534E+00,& - 0.17123E+00, 0.17713E+00, 0.18307E+00, 0.18902E+00, 0.19501E+00,& - 0.20102E+00, 0.20706E+00, 0.21313E+00, 0.21923E+00, 0.22536E+00,& - 0.23151E+00, 0.23770E+00, 0.24392E+00, 0.25017E+00, 0.25645E+00,& - 0.26276E+00, 0.26910E+00, 0.27546E+00, 0.28186E+00, 0.28829E+00,& - 0.29475E+00, 0.30123E+00, 0.30774E+00, 0.31428E+00, 0.32084E+00/ - - DATA (BNC11M (IA),IA=101,200)/ & - 0.32743E+00, 0.33404E+00, 0.34068E+00, 0.34734E+00, 0.35401E+00,& - 0.36071E+00, 0.36742E+00, 0.37415E+00, 0.38090E+00, 0.38766E+00,& - 0.39444E+00, 0.40123E+00, 0.40803E+00, 0.41484E+00, 0.42166E+00,& - 0.42848E+00, 0.43532E+00, 0.44216E+00, 0.44900E+00, 0.45585E+00,& - 0.46211E+00, 0.46904E+00, 0.47595E+00, 0.48286E+00, 0.48977E+00,& - 0.49667E+00, 0.50356E+00, 0.51044E+00, 0.51732E+00, 0.52419E+00,& - 0.53105E+00, 0.53791E+00, 0.54476E+00, 0.55160E+00, 0.55843E+00,& - 0.56525E+00, 0.57207E+00, 0.57887E+00, 0.58567E+00, 0.59246E+00,& - 0.59924E+00, 0.60601E+00, 0.61277E+00, 0.61952E+00, 0.62627E+00,& - 0.63300E+00, 0.63972E+00, 0.64643E+00, 0.65314E+00, 0.65983E+00,& - 0.66651E+00, 0.67319E+00, 0.67985E+00, 0.68650E+00, 0.69314E+00,& - 0.69977E+00, 0.70639E+00, 0.71300E+00, 0.71960E+00, 0.72618E+00,& - 0.73276E+00, 0.73933E+00, 0.74588E+00, 0.75242E+00, 0.75896E+00,& - 0.76548E+00, 0.77198E+00, 0.77848E+00, 0.78497E+00, 0.79144E+00,& - 0.79791E+00, 0.80436E+00, 0.81080E+00, 0.81723E+00, 0.82365E+00,& - 0.83005E+00, 0.83645E+00, 0.84283E+00, 0.84920E+00, 0.85556E+00,& - 0.86191E+00, 0.86824E+00, 0.87457E+00, 0.88088E+00, 0.88718E+00,& - 0.89347E+00, 0.89975E+00, 0.90601E+00, 0.91226E+00, 0.91851E+00,& - 0.92473E+00, 0.93095E+00, 0.93716E+00, 0.94335E+00, 0.94953E+00,& - 0.95570E+00, 0.96186E+00, 0.96801E+00, 0.97414E+00, 0.98027E+00/ - - DATA (BNC11M (IA),IA=201,300)/ & - 0.98638E+00, 0.99248E+00, 0.99857E+00, 0.10046E+01, 0.10107E+01,& - 0.10168E+01, 0.10228E+01, 0.10288E+01, 0.10348E+01, 0.10408E+01,& - 0.10468E+01, 0.10528E+01, 0.10588E+01, 0.10648E+01, 0.10707E+01,& - 0.10766E+01, 0.10826E+01, 0.10885E+01, 0.10944E+01, 0.11003E+01,& - 0.11061E+01, 0.11120E+01, 0.11179E+01, 0.11237E+01, 0.11295E+01,& - 0.11354E+01, 0.11412E+01, 0.11470E+01, 0.11527E+01, 0.11585E+01,& - 0.11643E+01, 0.11700E+01, 0.11758E+01, 0.11815E+01, 0.11872E+01,& - 0.11929E+01, 0.11986E+01, 0.12043E+01, 0.12100E+01, 0.12156E+01,& - 0.12213E+01, 0.12269E+01, 0.12326E+01, 0.12382E+01, 0.12438E+01,& - 0.12494E+01, 0.12550E+01, 0.12605E+01, 0.12661E+01, 0.12717E+01,& - 0.12772E+01, 0.12827E+01, 0.12883E+01, 0.12938E+01, 0.12993E+01,& - 0.13048E+01, 0.13102E+01, 0.13157E+01, 0.13212E+01, 0.13266E+01,& - 0.13320E+01, 0.13375E+01, 0.13429E+01, 0.13483E+01, 0.13537E+01,& - 0.13591E+01, 0.13644E+01, 0.13698E+01, 0.13752E+01, 0.13805E+01,& - 0.13858E+01, 0.13912E+01, 0.13965E+01, 0.14018E+01, 0.14071E+01,& - 0.14123E+01, 0.14176E+01, 0.14229E+01, 0.14281E+01, 0.14334E+01,& - 0.14386E+01, 0.14438E+01, 0.14490E+01, 0.14542E+01, 0.14594E+01,& - 0.14646E+01, 0.14698E+01, 0.14749E+01, 0.14801E+01, 0.14852E+01,& - 0.14904E+01, 0.14955E+01, 0.15006E+01, 0.15057E+01, 0.15108E+01,& - 0.15159E+01, 0.15210E+01, 0.15260E+01, 0.15311E+01, 0.15362E+01/ - - DATA (BNC11M (IA),IA=301,400)/ & - 0.15412E+01, 0.15462E+01, 0.15512E+01, 0.15563E+01, 0.15613E+01,& - 0.15663E+01, 0.15712E+01, 0.15762E+01, 0.15812E+01, 0.15861E+01,& - 0.15911E+01, 0.15960E+01, 0.16010E+01, 0.16059E+01, 0.16108E+01,& - 0.16157E+01, 0.16206E+01, 0.16255E+01, 0.16303E+01, 0.16352E+01,& - 0.16401E+01, 0.16449E+01, 0.16498E+01, 0.16546E+01, 0.16594E+01,& - 0.16642E+01, 0.16690E+01, 0.16738E+01, 0.16786E+01, 0.16834E+01,& - 0.16882E+01, 0.16930E+01, 0.16977E+01, 0.17025E+01, 0.17072E+01,& - 0.17119E+01, 0.17167E+01, 0.17214E+01, 0.17261E+01, 0.17308E+01,& - 0.17355E+01, 0.17401E+01, 0.17448E+01, 0.17495E+01, 0.17541E+01,& - 0.17588E+01, 0.17634E+01, 0.17681E+01, 0.17727E+01, 0.17773E+01,& - 0.17819E+01, 0.17865E+01, 0.17911E+01, 0.17957E+01, 0.18003E+01,& - 0.18048E+01, 0.18094E+01, 0.18139E+01, 0.18185E+01, 0.18230E+01,& - 0.18276E+01, 0.18321E+01, 0.18366E+01, 0.18411E+01, 0.18456E+01,& - 0.18501E+01, 0.18546E+01, 0.18591E+01, 0.18635E+01, 0.18680E+01,& - 0.18724E+01, 0.18769E+01, 0.18813E+01, 0.18858E+01, 0.18902E+01,& - 0.18946E+01, 0.18990E+01, 0.19034E+01, 0.19078E+01, 0.19122E+01,& - 0.19166E+01, 0.19210E+01, 0.19253E+01, 0.19297E+01, 0.19340E+01,& - 0.19384E+01, 0.19427E+01, 0.19471E+01, 0.19514E+01, 0.19557E+01,& - 0.19600E+01, 0.19643E+01, 0.19686E+01, 0.19729E+01, 0.19772E+01,& - 0.19814E+01, 0.19857E+01, 0.19900E+01, 0.19942E+01, 0.19985E+01/ - - DATA (BNC11M (IA),IA=401,500)/ & - 0.20027E+01, 0.20069E+01, 0.20112E+01, 0.20154E+01, 0.20196E+01,& - 0.20238E+01, 0.20280E+01, 0.20322E+01, 0.20364E+01, 0.20406E+01,& - 0.20447E+01, 0.20489E+01, 0.20531E+01, 0.20572E+01, 0.20614E+01,& - 0.20655E+01, 0.20697E+01, 0.20738E+01, 0.20779E+01, 0.20820E+01,& - 0.20861E+01, 0.20902E+01, 0.20943E+01, 0.20984E+01, 0.21025E+01,& - 0.21066E+01, 0.21106E+01, 0.21147E+01, 0.21188E+01, 0.21228E+01,& - 0.21269E+01, 0.21309E+01, 0.21349E+01, 0.21390E+01, 0.21430E+01,& - 0.21470E+01, 0.21510E+01, 0.21550E+01, 0.21590E+01, 0.21630E+01,& - 0.21670E+01, 0.21709E+01, 0.21749E+01, 0.21789E+01, 0.21828E+01,& - 0.21868E+01, 0.21907E+01, 0.21947E+01, 0.21986E+01, 0.22026E+01,& - 0.22065E+01, 0.22104E+01, 0.22143E+01, 0.22182E+01, 0.22221E+01,& - 0.22260E+01, 0.22299E+01, 0.22338E+01, 0.22377E+01, 0.22415E+01,& - 0.22454E+01, 0.22493E+01, 0.22531E+01, 0.22570E+01, 0.22608E+01,& - 0.22646E+01, 0.22685E+01, 0.22723E+01, 0.22761E+01, 0.22799E+01,& - 0.22838E+01, 0.22876E+01, 0.22914E+01, 0.22951E+01, 0.22989E+01,& - 0.23027E+01, 0.23065E+01, 0.23103E+01, 0.23140E+01, 0.23178E+01,& - 0.23215E+01, 0.23253E+01, 0.23290E+01, 0.23328E+01, 0.23365E+01,& - 0.23402E+01, 0.23440E+01, 0.23477E+01, 0.23514E+01, 0.23551E+01,& - 0.23588E+01, 0.23625E+01, 0.23662E+01, 0.23699E+01, 0.23736E+01,& - 0.23772E+01, 0.23809E+01, 0.23846E+01, 0.23882E+01, 0.23919E+01/ - - DATA (BNC11M (IA),IA=501,600)/ & - 0.23955E+01, 0.23992E+01, 0.24028E+01, 0.24065E+01, 0.24101E+01,& - 0.24137E+01, 0.24173E+01, 0.24210E+01, 0.24246E+01, 0.24282E+01,& - 0.24318E+01, 0.24354E+01, 0.24390E+01, 0.24425E+01, 0.24461E+01,& - 0.24497E+01, 0.24533E+01, 0.24568E+01, 0.24604E+01, 0.24640E+01,& - 0.24675E+01, 0.24711E+01, 0.24746E+01, 0.24781E+01, 0.24817E+01,& - 0.24852E+01, 0.24887E+01, 0.24922E+01, 0.24957E+01, 0.24993E+01,& - 0.25028E+01, 0.25063E+01, 0.25097E+01, 0.25132E+01, 0.25167E+01,& - 0.25202E+01, 0.25237E+01, 0.25272E+01, 0.25306E+01, 0.25341E+01,& - 0.25375E+01, 0.25410E+01, 0.25444E+01, 0.25479E+01, 0.25513E+01,& - 0.25548E+01, 0.25582E+01, 0.25616E+01, 0.25650E+01, 0.25684E+01,& - 0.25719E+01, 0.25753E+01, 0.25787E+01, 0.25821E+01, 0.25855E+01,& - 0.25889E+01, 0.25922E+01, 0.25956E+01, 0.25990E+01, 0.26024E+01,& - 0.26057E+01, 0.26091E+01, 0.26125E+01, 0.26158E+01, 0.26192E+01,& - 0.26225E+01, 0.26258E+01, 0.26292E+01, 0.26325E+01, 0.26358E+01,& - 0.26392E+01, 0.26425E+01, 0.26458E+01, 0.26491E+01, 0.26524E+01,& - 0.26557E+01, 0.26590E+01, 0.26623E+01, 0.26656E+01, 0.26689E+01,& - 0.26722E+01, 0.26755E+01, 0.26787E+01, 0.26820E+01, 0.26853E+01,& - 0.26885E+01, 0.26918E+01, 0.26951E+01, 0.26983E+01, 0.27016E+01,& - 0.27048E+01, 0.27080E+01, 0.27113E+01, 0.27145E+01, 0.27177E+01,& - 0.27209E+01, 0.27242E+01, 0.27274E+01, 0.27306E+01, 0.27426E+01/ - - DATA (BNC11M (IA),IA=601,700)/ & - 0.27688E+01, 0.28002E+01, 0.28313E+01, 0.28620E+01, 0.28923E+01,& - 0.29223E+01, 0.29519E+01, 0.29812E+01, 0.30102E+01, 0.30388E+01,& - 0.30672E+01, 0.30952E+01, 0.31229E+01, 0.31504E+01, 0.31775E+01,& - 0.32044E+01, 0.32310E+01, 0.32573E+01, 0.32834E+01, 0.33092E+01,& - 0.33347E+01, 0.33601E+01, 0.33851E+01, 0.34099E+01, 0.34345E+01,& - 0.34589E+01, 0.34830E+01, 0.35069E+01, 0.35306E+01, 0.35541E+01,& - 0.35773E+01, 0.36004E+01, 0.36232E+01, 0.36459E+01, 0.36683E+01,& - 0.36906E+01, 0.37127E+01, 0.37346E+01, 0.37563E+01, 0.37778E+01,& - 0.37992E+01, 0.38203E+01, 0.38413E+01, 0.38622E+01, 0.38828E+01,& - 0.39033E+01, 0.39237E+01, 0.39439E+01, 0.39639E+01, 0.39838E+01,& - 0.40035E+01, 0.40231E+01, 0.40425E+01, 0.40618E+01, 0.40809E+01,& - 0.40999E+01, 0.41188E+01, 0.41375E+01, 0.41561E+01, 0.41746E+01,& - 0.41929E+01, 0.42111E+01, 0.42292E+01, 0.42472E+01, 0.42650E+01,& - 0.42827E+01, 0.43003E+01, 0.43177E+01, 0.43351E+01, 0.43523E+01,& - 0.43695E+01, 0.43865E+01, 0.44034E+01, 0.44202E+01, 0.44368E+01,& - 0.44534E+01, 0.44699E+01, 0.44862E+01, 0.45025E+01, 0.45187E+01,& - 0.45347E+01, 0.45507E+01, 0.45666E+01, 0.45823E+01, 0.45980E+01,& - 0.46136E+01, 0.46291E+01, 0.46445E+01, 0.46598E+01, 0.46750E+01,& - 0.46901E+01, 0.47051E+01, 0.47201E+01, 0.47350E+01, 0.47497E+01,& - 0.47644E+01, 0.47791E+01, 0.47936E+01, 0.48080E+01, 0.48224E+01/ - - DATA (BNC11M(IA),IA=701,741)/ & - 0.48367E+01, 0.48509E+01, 0.48651E+01, 0.48791E+01, 0.48931E+01,& - 0.49070E+01, 0.49208E+01, 0.49346E+01, 0.49483E+01, 0.49619E+01,& - 0.49755E+01, 0.49889E+01, 0.50023E+01, 0.50157E+01, 0.50290E+01,& - 0.50422E+01, 0.50553E+01, 0.50684E+01, 0.50814E+01, 0.50943E+01,& - 0.51072E+01, 0.51200E+01, 0.51327E+01, 0.51454E+01, 0.51580E+01,& - 0.51706E+01, 0.51831E+01, 0.51956E+01, 0.52079E+01, 0.52203E+01,& - 0.52325E+01, 0.52447E+01, 0.52569E+01, 0.52690E+01, 0.52810E+01,& - 0.52930E+01, 0.53049E+01, 0.53168E+01, 0.53286E+01, 0.53404E+01,& - 0.53521E+01 / -! -! ** NaHSO4 -! - DATA (BNC12M (IA),IA= 1,100)/ & - -0.49644E-01,-0.87391E-01,-0.11193E+00,-0.12742E+00,-0.13854E+00,& - -0.14701E+00,-0.15369E+00,-0.15906E+00,-0.16342E+00,-0.16698E+00,& - -0.16989E+00,-0.17226E+00,-0.17416E+00,-0.17565E+00,-0.17680E+00,& - -0.17763E+00,-0.17818E+00,-0.17848E+00,-0.17855E+00,-0.17840E+00,& - -0.17807E+00,-0.17755E+00,-0.17687E+00,-0.17603E+00,-0.17505E+00,& - -0.17393E+00,-0.17268E+00,-0.17131E+00,-0.16982E+00,-0.16823E+00,& - -0.16653E+00,-0.16473E+00,-0.16284E+00,-0.16086E+00,-0.15879E+00,& - -0.15664E+00,-0.15441E+00,-0.15211E+00,-0.14974E+00,-0.14729E+00,& - -0.14479E+00,-0.14222E+00,-0.13959E+00,-0.13690E+00,-0.13415E+00,& - -0.13136E+00,-0.12851E+00,-0.12561E+00,-0.12267E+00,-0.11968E+00,& - -0.11665E+00,-0.11358E+00,-0.11046E+00,-0.10731E+00,-0.10412E+00,& - -0.10089E+00,-0.97629E-01,-0.94332E-01,-0.91002E-01,-0.87640E-01,& - -0.84246E-01,-0.80821E-01,-0.77366E-01,-0.73882E-01,-0.70367E-01,& - -0.66825E-01,-0.63253E-01,-0.59653E-01,-0.56026E-01,-0.52370E-01,& - -0.48687E-01,-0.44975E-01,-0.41237E-01,-0.37470E-01,-0.33676E-01,& - -0.29854E-01,-0.26004E-01,-0.22127E-01,-0.18221E-01,-0.14288E-01,& - -0.10326E-01,-0.63369E-02,-0.23194E-02, 0.17259E-02, 0.57993E-02,& - 0.99002E-02, 0.14029E-01, 0.18185E-01, 0.22368E-01, 0.26578E-01,& - 0.30815E-01, 0.35078E-01, 0.39366E-01, 0.43679E-01, 0.48017E-01,& - 0.52379E-01, 0.56764E-01, 0.61172E-01, 0.65602E-01, 0.70053E-01/ - - DATA (BNC12M (IA),IA=101,200)/ & - 0.74523E-01, 0.79013E-01, 0.83522E-01, 0.88048E-01, 0.92591E-01,& - 0.97150E-01, 0.10172E+00, 0.10631E+00, 0.11091E+00, 0.11552E+00,& - 0.12014E+00, 0.12478E+00, 0.12942E+00, 0.13407E+00, 0.13872E+00,& - 0.14339E+00, 0.14806E+00, 0.15273E+00, 0.15741E+00, 0.16209E+00,& - 0.16635E+00, 0.17109E+00, 0.17581E+00, 0.18054E+00, 0.18526E+00,& - 0.18997E+00, 0.19469E+00, 0.19939E+00, 0.20409E+00, 0.20879E+00,& - 0.21348E+00, 0.21816E+00, 0.22284E+00, 0.22751E+00, 0.23218E+00,& - 0.23684E+00, 0.24149E+00, 0.24614E+00, 0.25078E+00, 0.25542E+00,& - 0.26004E+00, 0.26466E+00, 0.26927E+00, 0.27388E+00, 0.27848E+00,& - 0.28307E+00, 0.28765E+00, 0.29223E+00, 0.29680E+00, 0.30136E+00,& - 0.30591E+00, 0.31045E+00, 0.31499E+00, 0.31952E+00, 0.32404E+00,& - 0.32855E+00, 0.33306E+00, 0.33755E+00, 0.34204E+00, 0.34652E+00,& - 0.35099E+00, 0.35545E+00, 0.35991E+00, 0.36436E+00, 0.36879E+00,& - 0.37322E+00, 0.37764E+00, 0.38206E+00, 0.38646E+00, 0.39086E+00,& - 0.39524E+00, 0.39962E+00, 0.40399E+00, 0.40836E+00, 0.41271E+00,& - 0.41705E+00, 0.42139E+00, 0.42572E+00, 0.43003E+00, 0.43435E+00,& - 0.43865E+00, 0.44294E+00, 0.44722E+00, 0.45150E+00, 0.45577E+00,& - 0.46003E+00, 0.46428E+00, 0.46852E+00, 0.47275E+00, 0.47698E+00,& - 0.48119E+00, 0.48540E+00, 0.48960E+00, 0.49379E+00, 0.49797E+00,& - 0.50215E+00, 0.50631E+00, 0.51047E+00, 0.51462E+00, 0.51876E+00/ - - DATA (BNC12M (IA),IA=201,300)/ & - 0.52289E+00, 0.52702E+00, 0.53113E+00, 0.53524E+00, 0.53934E+00,& - 0.54343E+00, 0.54751E+00, 0.55158E+00, 0.55565E+00, 0.55971E+00,& - 0.56376E+00, 0.56780E+00, 0.57183E+00, 0.57586E+00, 0.57987E+00,& - 0.58388E+00, 0.58788E+00, 0.59187E+00, 0.59586E+00, 0.59984E+00,& - 0.60381E+00, 0.60777E+00, 0.61172E+00, 0.61566E+00, 0.61960E+00,& - 0.62353E+00, 0.62745E+00, 0.63137E+00, 0.63527E+00, 0.63917E+00,& - 0.64306E+00, 0.64695E+00, 0.65082E+00, 0.65469E+00, 0.65855E+00,& - 0.66240E+00, 0.66625E+00, 0.67008E+00, 0.67391E+00, 0.67774E+00,& - 0.68155E+00, 0.68536E+00, 0.68916E+00, 0.69295E+00, 0.69674E+00,& - 0.70051E+00, 0.70428E+00, 0.70805E+00, 0.71180E+00, 0.71555E+00,& - 0.71929E+00, 0.72303E+00, 0.72676E+00, 0.73048E+00, 0.73419E+00,& - 0.73789E+00, 0.74159E+00, 0.74528E+00, 0.74897E+00, 0.75265E+00,& - 0.75632E+00, 0.75998E+00, 0.76364E+00, 0.76729E+00, 0.77093E+00,& - 0.77457E+00, 0.77819E+00, 0.78182E+00, 0.78543E+00, 0.78904E+00,& - 0.79264E+00, 0.79624E+00, 0.79983E+00, 0.80341E+00, 0.80698E+00,& - 0.81055E+00, 0.81411E+00, 0.81767E+00, 0.82122E+00, 0.82476E+00,& - 0.82830E+00, 0.83183E+00, 0.83535E+00, 0.83886E+00, 0.84237E+00,& - 0.84588E+00, 0.84938E+00, 0.85287E+00, 0.85635E+00, 0.85983E+00,& - 0.86330E+00, 0.86676E+00, 0.87022E+00, 0.87368E+00, 0.87712E+00,& - 0.88056E+00, 0.88400E+00, 0.88743E+00, 0.89085E+00, 0.89426E+00/ - - DATA (BNC12M (IA),IA=301,400)/ & - 0.89767E+00, 0.90108E+00, 0.90447E+00, 0.90787E+00, 0.91125E+00,& - 0.91463E+00, 0.91801E+00, 0.92137E+00, 0.92473E+00, 0.92809E+00,& - 0.93144E+00, 0.93478E+00, 0.93812E+00, 0.94145E+00, 0.94478E+00,& - 0.94810E+00, 0.95142E+00, 0.95473E+00, 0.95803E+00, 0.96133E+00,& - 0.96462E+00, 0.96791E+00, 0.97119E+00, 0.97446E+00, 0.97773E+00,& - 0.98099E+00, 0.98425E+00, 0.98750E+00, 0.99075E+00, 0.99399E+00,& - 0.99723E+00, 0.10005E+01, 0.10037E+01, 0.10069E+01, 0.10101E+01,& - 0.10133E+01, 0.10165E+01, 0.10197E+01, 0.10229E+01, 0.10261E+01,& - 0.10293E+01, 0.10325E+01, 0.10356E+01, 0.10388E+01, 0.10420E+01,& - 0.10451E+01, 0.10483E+01, 0.10514E+01, 0.10546E+01, 0.10577E+01,& - 0.10608E+01, 0.10639E+01, 0.10671E+01, 0.10702E+01, 0.10733E+01,& - 0.10764E+01, 0.10795E+01, 0.10826E+01, 0.10857E+01, 0.10888E+01,& - 0.10918E+01, 0.10949E+01, 0.10980E+01, 0.11010E+01, 0.11041E+01,& - 0.11071E+01, 0.11102E+01, 0.11132E+01, 0.11163E+01, 0.11193E+01,& - 0.11223E+01, 0.11254E+01, 0.11284E+01, 0.11314E+01, 0.11344E+01,& - 0.11374E+01, 0.11404E+01, 0.11434E+01, 0.11464E+01, 0.11494E+01,& - 0.11524E+01, 0.11553E+01, 0.11583E+01, 0.11613E+01, 0.11642E+01,& - 0.11672E+01, 0.11702E+01, 0.11731E+01, 0.11761E+01, 0.11790E+01,& - 0.11819E+01, 0.11849E+01, 0.11878E+01, 0.11907E+01, 0.11936E+01,& - 0.11965E+01, 0.11994E+01, 0.12023E+01, 0.12052E+01, 0.12081E+01/ - - DATA (BNC12M (IA),IA=401,500)/ & - 0.12110E+01, 0.12139E+01, 0.12168E+01, 0.12197E+01, 0.12225E+01,& - 0.12254E+01, 0.12283E+01, 0.12311E+01, 0.12340E+01, 0.12368E+01,& - 0.12397E+01, 0.12425E+01, 0.12454E+01, 0.12482E+01, 0.12510E+01,& - 0.12539E+01, 0.12567E+01, 0.12595E+01, 0.12623E+01, 0.12651E+01,& - 0.12679E+01, 0.12707E+01, 0.12735E+01, 0.12763E+01, 0.12791E+01,& - 0.12819E+01, 0.12847E+01, 0.12874E+01, 0.12902E+01, 0.12930E+01,& - 0.12957E+01, 0.12985E+01, 0.13013E+01, 0.13040E+01, 0.13068E+01,& - 0.13095E+01, 0.13122E+01, 0.13150E+01, 0.13177E+01, 0.13204E+01,& - 0.13231E+01, 0.13259E+01, 0.13286E+01, 0.13313E+01, 0.13340E+01,& - 0.13367E+01, 0.13394E+01, 0.13421E+01, 0.13448E+01, 0.13475E+01,& - 0.13502E+01, 0.13528E+01, 0.13555E+01, 0.13582E+01, 0.13609E+01,& - 0.13635E+01, 0.13662E+01, 0.13688E+01, 0.13715E+01, 0.13741E+01,& - 0.13768E+01, 0.13794E+01, 0.13821E+01, 0.13847E+01, 0.13873E+01,& - 0.13900E+01, 0.13926E+01, 0.13952E+01, 0.13978E+01, 0.14004E+01,& - 0.14031E+01, 0.14057E+01, 0.14083E+01, 0.14109E+01, 0.14135E+01,& - 0.14160E+01, 0.14186E+01, 0.14212E+01, 0.14238E+01, 0.14264E+01,& - 0.14290E+01, 0.14315E+01, 0.14341E+01, 0.14367E+01, 0.14392E+01,& - 0.14418E+01, 0.14443E+01, 0.14469E+01, 0.14494E+01, 0.14520E+01,& - 0.14545E+01, 0.14570E+01, 0.14596E+01, 0.14621E+01, 0.14646E+01,& - 0.14671E+01, 0.14697E+01, 0.14722E+01, 0.14747E+01, 0.14772E+01/ - - DATA (BNC12M (IA),IA=501,600)/ & - 0.14797E+01, 0.14822E+01, 0.14847E+01, 0.14872E+01, 0.14897E+01,& - 0.14922E+01, 0.14947E+01, 0.14971E+01, 0.14996E+01, 0.15021E+01,& - 0.15046E+01, 0.15070E+01, 0.15095E+01, 0.15120E+01, 0.15144E+01,& - 0.15169E+01, 0.15193E+01, 0.15218E+01, 0.15242E+01, 0.15267E+01,& - 0.15291E+01, 0.15315E+01, 0.15340E+01, 0.15364E+01, 0.15388E+01,& - 0.15413E+01, 0.15437E+01, 0.15461E+01, 0.15485E+01, 0.15509E+01,& - 0.15533E+01, 0.15557E+01, 0.15581E+01, 0.15605E+01, 0.15629E+01,& - 0.15653E+01, 0.15677E+01, 0.15701E+01, 0.15725E+01, 0.15749E+01,& - 0.15772E+01, 0.15796E+01, 0.15820E+01, 0.15843E+01, 0.15867E+01,& - 0.15891E+01, 0.15914E+01, 0.15938E+01, 0.15961E+01, 0.15985E+01,& - 0.16008E+01, 0.16032E+01, 0.16055E+01, 0.16079E+01, 0.16102E+01,& - 0.16125E+01, 0.16149E+01, 0.16172E+01, 0.16195E+01, 0.16218E+01,& - 0.16242E+01, 0.16265E+01, 0.16288E+01, 0.16311E+01, 0.16334E+01,& - 0.16357E+01, 0.16380E+01, 0.16403E+01, 0.16426E+01, 0.16449E+01,& - 0.16472E+01, 0.16495E+01, 0.16518E+01, 0.16540E+01, 0.16563E+01,& - 0.16586E+01, 0.16609E+01, 0.16631E+01, 0.16654E+01, 0.16677E+01,& - 0.16699E+01, 0.16722E+01, 0.16744E+01, 0.16767E+01, 0.16790E+01,& - 0.16812E+01, 0.16834E+01, 0.16857E+01, 0.16879E+01, 0.16902E+01,& - 0.16924E+01, 0.16946E+01, 0.16969E+01, 0.16991E+01, 0.17013E+01,& - 0.17035E+01, 0.17058E+01, 0.17080E+01, 0.17102E+01, 0.17185E+01/ - - DATA (BNC12M (IA),IA=601,700)/ & - 0.17365E+01, 0.17582E+01, 0.17797E+01, 0.18009E+01, 0.18218E+01,& - 0.18425E+01, 0.18630E+01, 0.18833E+01, 0.19033E+01, 0.19232E+01,& - 0.19428E+01, 0.19622E+01, 0.19814E+01, 0.20004E+01, 0.20193E+01,& - 0.20379E+01, 0.20563E+01, 0.20746E+01, 0.20927E+01, 0.21106E+01,& - 0.21283E+01, 0.21459E+01, 0.21633E+01, 0.21806E+01, 0.21976E+01,& - 0.22146E+01, 0.22313E+01, 0.22480E+01, 0.22644E+01, 0.22808E+01,& - 0.22969E+01, 0.23130E+01, 0.23289E+01, 0.23447E+01, 0.23603E+01,& - 0.23758E+01, 0.23912E+01, 0.24064E+01, 0.24215E+01, 0.24365E+01,& - 0.24514E+01, 0.24662E+01, 0.24808E+01, 0.24953E+01, 0.25097E+01,& - 0.25240E+01, 0.25382E+01, 0.25523E+01, 0.25663E+01, 0.25802E+01,& - 0.25939E+01, 0.26076E+01, 0.26211E+01, 0.26346E+01, 0.26480E+01,& - 0.26612E+01, 0.26744E+01, 0.26875E+01, 0.27005E+01, 0.27133E+01,& - 0.27262E+01, 0.27389E+01, 0.27515E+01, 0.27640E+01, 0.27765E+01,& - 0.27889E+01, 0.28012E+01, 0.28134E+01, 0.28255E+01, 0.28375E+01,& - 0.28495E+01, 0.28614E+01, 0.28732E+01, 0.28849E+01, 0.28966E+01,& - 0.29082E+01, 0.29197E+01, 0.29312E+01, 0.29425E+01, 0.29538E+01,& - 0.29651E+01, 0.29762E+01, 0.29873E+01, 0.29984E+01, 0.30093E+01,& - 0.30202E+01, 0.30311E+01, 0.30419E+01, 0.30526E+01, 0.30632E+01,& - 0.30738E+01, 0.30843E+01, 0.30948E+01, 0.31052E+01, 0.31155E+01,& - 0.31258E+01, 0.31361E+01, 0.31462E+01, 0.31564E+01, 0.31664E+01/ - - DATA (BNC12M(IA),IA=701,741)/ & - 0.31764E+01, 0.31864E+01, 0.31963E+01, 0.32061E+01, 0.32159E+01,& - 0.32257E+01, 0.32354E+01, 0.32450E+01, 0.32546E+01, 0.32641E+01,& - 0.32736E+01, 0.32831E+01, 0.32924E+01, 0.33018E+01, 0.33111E+01,& - 0.33203E+01, 0.33295E+01, 0.33387E+01, 0.33478E+01, 0.33569E+01,& - 0.33659E+01, 0.33749E+01, 0.33838E+01, 0.33927E+01, 0.34016E+01,& - 0.34104E+01, 0.34191E+01, 0.34278E+01, 0.34365E+01, 0.34452E+01,& - 0.34538E+01, 0.34623E+01, 0.34708E+01, 0.34793E+01, 0.34878E+01,& - 0.34962E+01, 0.35045E+01, 0.35128E+01, 0.35211E+01, 0.35294E+01,& - 0.35376E+01 / -! -! ** (NH4)3H(SO4)2 -! - DATA (BNC13M (IA),IA= 1,100)/ & - -0.82022E-01,-0.14892E+00,-0.19572E+00,-0.22741E+00,-0.25173E+00,& - -0.27155E+00,-0.28831E+00,-0.30283E+00,-0.31565E+00,-0.32710E+00,& - -0.33746E+00,-0.34689E+00,-0.35555E+00,-0.36355E+00,-0.37096E+00,& - -0.37786E+00,-0.38431E+00,-0.39036E+00,-0.39605E+00,-0.40141E+00,& - -0.40647E+00,-0.41126E+00,-0.41580E+00,-0.42010E+00,-0.42419E+00,& - -0.42808E+00,-0.43179E+00,-0.43532E+00,-0.43868E+00,-0.44190E+00,& - -0.44496E+00,-0.44790E+00,-0.45070E+00,-0.45338E+00,-0.45594E+00,& - -0.45839E+00,-0.46074E+00,-0.46298E+00,-0.46513E+00,-0.46719E+00,& - -0.46916E+00,-0.47105E+00,-0.47285E+00,-0.47458E+00,-0.47624E+00,& - -0.47782E+00,-0.47934E+00,-0.48079E+00,-0.48217E+00,-0.48350E+00,& - -0.48477E+00,-0.48598E+00,-0.48713E+00,-0.48824E+00,-0.48929E+00,& - -0.49030E+00,-0.49125E+00,-0.49217E+00,-0.49304E+00,-0.49386E+00,& - -0.49465E+00,-0.49539E+00,-0.49610E+00,-0.49677E+00,-0.49740E+00,& - -0.49800E+00,-0.49856E+00,-0.49910E+00,-0.49960E+00,-0.50006E+00,& - -0.50050E+00,-0.50091E+00,-0.50129E+00,-0.50164E+00,-0.50197E+00,& - -0.50227E+00,-0.50254E+00,-0.50279E+00,-0.50301E+00,-0.50321E+00,& - -0.50338E+00,-0.50353E+00,-0.50366E+00,-0.50377E+00,-0.50386E+00,& - -0.50392E+00,-0.50396E+00,-0.50399E+00,-0.50399E+00,-0.50398E+00,& - -0.50394E+00,-0.50389E+00,-0.50382E+00,-0.50373E+00,-0.50362E+00,& - -0.50350E+00,-0.50336E+00,-0.50320E+00,-0.50303E+00,-0.50285E+00/ - - DATA (BNC13M (IA),IA=101,200)/ & - -0.50265E+00,-0.50243E+00,-0.50220E+00,-0.50196E+00,-0.50171E+00,& - -0.50144E+00,-0.50116E+00,-0.50087E+00,-0.50056E+00,-0.50025E+00,& - -0.49993E+00,-0.49959E+00,-0.49925E+00,-0.49890E+00,-0.49853E+00,& - -0.49816E+00,-0.49778E+00,-0.49739E+00,-0.49700E+00,-0.49660E+00,& - -0.49627E+00,-0.49584E+00,-0.49541E+00,-0.49497E+00,-0.49453E+00,& - -0.49408E+00,-0.49363E+00,-0.49317E+00,-0.49271E+00,-0.49225E+00,& - -0.49178E+00,-0.49130E+00,-0.49082E+00,-0.49034E+00,-0.48986E+00,& - -0.48937E+00,-0.48887E+00,-0.48838E+00,-0.48788E+00,-0.48738E+00,& - -0.48687E+00,-0.48636E+00,-0.48585E+00,-0.48534E+00,-0.48482E+00,& - -0.48430E+00,-0.48378E+00,-0.48326E+00,-0.48273E+00,-0.48221E+00,& - -0.48168E+00,-0.48115E+00,-0.48061E+00,-0.48008E+00,-0.47954E+00,& - -0.47900E+00,-0.47846E+00,-0.47792E+00,-0.47738E+00,-0.47683E+00,& - -0.47628E+00,-0.47574E+00,-0.47519E+00,-0.47464E+00,-0.47409E+00,& - -0.47354E+00,-0.47298E+00,-0.47243E+00,-0.47187E+00,-0.47132E+00,& - -0.47076E+00,-0.47020E+00,-0.46964E+00,-0.46908E+00,-0.46852E+00,& - -0.46796E+00,-0.46740E+00,-0.46684E+00,-0.46628E+00,-0.46572E+00,& - -0.46515E+00,-0.46459E+00,-0.46402E+00,-0.46346E+00,-0.46289E+00,& - -0.46233E+00,-0.46176E+00,-0.46120E+00,-0.46063E+00,-0.46006E+00,& - -0.45950E+00,-0.45893E+00,-0.45836E+00,-0.45780E+00,-0.45723E+00,& - -0.45666E+00,-0.45609E+00,-0.45553E+00,-0.45496E+00,-0.45439E+00/ - - DATA (BNC13M (IA),IA=201,300)/ & - -0.45382E+00,-0.45325E+00,-0.45269E+00,-0.45212E+00,-0.45155E+00,& - -0.45098E+00,-0.45041E+00,-0.44985E+00,-0.44928E+00,-0.44871E+00,& - -0.44814E+00,-0.44758E+00,-0.44701E+00,-0.44644E+00,-0.44588E+00,& - -0.44531E+00,-0.44474E+00,-0.44418E+00,-0.44361E+00,-0.44305E+00,& - -0.44248E+00,-0.44192E+00,-0.44135E+00,-0.44079E+00,-0.44022E+00,& - -0.43966E+00,-0.43909E+00,-0.43853E+00,-0.43797E+00,-0.43740E+00,& - -0.43684E+00,-0.43628E+00,-0.43572E+00,-0.43515E+00,-0.43459E+00,& - -0.43403E+00,-0.43347E+00,-0.43291E+00,-0.43235E+00,-0.43179E+00,& - -0.43123E+00,-0.43067E+00,-0.43012E+00,-0.42956E+00,-0.42900E+00,& - -0.42844E+00,-0.42789E+00,-0.42733E+00,-0.42678E+00,-0.42622E+00,& - -0.42567E+00,-0.42511E+00,-0.42456E+00,-0.42400E+00,-0.42345E+00,& - -0.42290E+00,-0.42234E+00,-0.42179E+00,-0.42124E+00,-0.42069E+00,& - -0.42014E+00,-0.41959E+00,-0.41904E+00,-0.41849E+00,-0.41794E+00,& - -0.41740E+00,-0.41685E+00,-0.41630E+00,-0.41575E+00,-0.41521E+00,& - -0.41466E+00,-0.41412E+00,-0.41357E+00,-0.41303E+00,-0.41249E+00,& - -0.41194E+00,-0.41140E+00,-0.41086E+00,-0.41032E+00,-0.40977E+00,& - -0.40923E+00,-0.40869E+00,-0.40815E+00,-0.40762E+00,-0.40708E+00,& - -0.40654E+00,-0.40600E+00,-0.40547E+00,-0.40493E+00,-0.40439E+00,& - -0.40386E+00,-0.40332E+00,-0.40279E+00,-0.40225E+00,-0.40172E+00,& - -0.40119E+00,-0.40066E+00,-0.40013E+00,-0.39959E+00,-0.39906E+00/ - - DATA (BNC13M (IA),IA=301,400)/ & - -0.39853E+00,-0.39800E+00,-0.39747E+00,-0.39695E+00,-0.39642E+00,& - -0.39589E+00,-0.39536E+00,-0.39484E+00,-0.39431E+00,-0.39379E+00,& - -0.39326E+00,-0.39274E+00,-0.39221E+00,-0.39169E+00,-0.39117E+00,& - -0.39065E+00,-0.39013E+00,-0.38961E+00,-0.38908E+00,-0.38857E+00,& - -0.38805E+00,-0.38753E+00,-0.38701E+00,-0.38649E+00,-0.38597E+00,& - -0.38546E+00,-0.38494E+00,-0.38443E+00,-0.38391E+00,-0.38340E+00,& - -0.38288E+00,-0.38237E+00,-0.38186E+00,-0.38135E+00,-0.38083E+00,& - -0.38032E+00,-0.37981E+00,-0.37930E+00,-0.37879E+00,-0.37828E+00,& - -0.37778E+00,-0.37727E+00,-0.37676E+00,-0.37625E+00,-0.37575E+00,& - -0.37524E+00,-0.37474E+00,-0.37423E+00,-0.37373E+00,-0.37322E+00,& - -0.37272E+00,-0.37222E+00,-0.37172E+00,-0.37122E+00,-0.37071E+00,& - -0.37021E+00,-0.36971E+00,-0.36922E+00,-0.36872E+00,-0.36822E+00,& - -0.36772E+00,-0.36722E+00,-0.36673E+00,-0.36623E+00,-0.36574E+00,& - -0.36524E+00,-0.36475E+00,-0.36425E+00,-0.36376E+00,-0.36327E+00,& - -0.36277E+00,-0.36228E+00,-0.36179E+00,-0.36130E+00,-0.36081E+00,& - -0.36032E+00,-0.35983E+00,-0.35934E+00,-0.35886E+00,-0.35837E+00,& - -0.35788E+00,-0.35739E+00,-0.35691E+00,-0.35642E+00,-0.35594E+00,& - -0.35545E+00,-0.35497E+00,-0.35449E+00,-0.35400E+00,-0.35352E+00,& - -0.35304E+00,-0.35256E+00,-0.35208E+00,-0.35160E+00,-0.35112E+00,& - -0.35064E+00,-0.35016E+00,-0.34968E+00,-0.34920E+00,-0.34873E+00/ - - DATA (BNC13M (IA),IA=401,500)/ & - -0.34825E+00,-0.34777E+00,-0.34730E+00,-0.34682E+00,-0.34635E+00,& - -0.34588E+00,-0.34540E+00,-0.34493E+00,-0.34446E+00,-0.34398E+00,& - -0.34351E+00,-0.34304E+00,-0.34257E+00,-0.34210E+00,-0.34163E+00,& - -0.34116E+00,-0.34069E+00,-0.34023E+00,-0.33976E+00,-0.33929E+00,& - -0.33882E+00,-0.33836E+00,-0.33789E+00,-0.33743E+00,-0.33696E+00,& - -0.33650E+00,-0.33604E+00,-0.33557E+00,-0.33511E+00,-0.33465E+00,& - -0.33419E+00,-0.33373E+00,-0.33327E+00,-0.33281E+00,-0.33235E+00,& - -0.33189E+00,-0.33143E+00,-0.33097E+00,-0.33051E+00,-0.33006E+00,& - -0.32960E+00,-0.32914E+00,-0.32869E+00,-0.32823E+00,-0.32778E+00,& - -0.32732E+00,-0.32687E+00,-0.32642E+00,-0.32596E+00,-0.32551E+00,& - -0.32506E+00,-0.32461E+00,-0.32416E+00,-0.32371E+00,-0.32326E+00,& - -0.32281E+00,-0.32236E+00,-0.32191E+00,-0.32146E+00,-0.32101E+00,& - -0.32057E+00,-0.32012E+00,-0.31967E+00,-0.31923E+00,-0.31878E+00,& - -0.31834E+00,-0.31789E+00,-0.31745E+00,-0.31701E+00,-0.31656E+00,& - -0.31612E+00,-0.31568E+00,-0.31524E+00,-0.31480E+00,-0.31436E+00,& - -0.31392E+00,-0.31348E+00,-0.31304E+00,-0.31260E+00,-0.31216E+00,& - -0.31172E+00,-0.31128E+00,-0.31085E+00,-0.31041E+00,-0.30997E+00,& - -0.30954E+00,-0.30910E+00,-0.30867E+00,-0.30823E+00,-0.30780E+00,& - -0.30737E+00,-0.30693E+00,-0.30650E+00,-0.30607E+00,-0.30564E+00,& - -0.30521E+00,-0.30478E+00,-0.30435E+00,-0.30392E+00,-0.30349E+00/ - - DATA (BNC13M (IA),IA=501,600)/ & - -0.30306E+00,-0.30263E+00,-0.30220E+00,-0.30177E+00,-0.30135E+00,& - -0.30092E+00,-0.30049E+00,-0.30007E+00,-0.29964E+00,-0.29922E+00,& - -0.29879E+00,-0.29837E+00,-0.29794E+00,-0.29752E+00,-0.29710E+00,& - -0.29668E+00,-0.29625E+00,-0.29583E+00,-0.29541E+00,-0.29499E+00,& - -0.29457E+00,-0.29415E+00,-0.29373E+00,-0.29331E+00,-0.29289E+00,& - -0.29248E+00,-0.29206E+00,-0.29164E+00,-0.29122E+00,-0.29081E+00,& - -0.29039E+00,-0.28997E+00,-0.28956E+00,-0.28914E+00,-0.28873E+00,& - -0.28832E+00,-0.28790E+00,-0.28749E+00,-0.28708E+00,-0.28666E+00,& - -0.28625E+00,-0.28584E+00,-0.28543E+00,-0.28502E+00,-0.28461E+00,& - -0.28420E+00,-0.28379E+00,-0.28338E+00,-0.28297E+00,-0.28256E+00,& - -0.28216E+00,-0.28175E+00,-0.28134E+00,-0.28093E+00,-0.28053E+00,& - -0.28012E+00,-0.27972E+00,-0.27931E+00,-0.27891E+00,-0.27850E+00,& - -0.27810E+00,-0.27770E+00,-0.27729E+00,-0.27689E+00,-0.27649E+00,& - -0.27609E+00,-0.27568E+00,-0.27528E+00,-0.27488E+00,-0.27448E+00,& - -0.27408E+00,-0.27368E+00,-0.27328E+00,-0.27288E+00,-0.27249E+00,& - -0.27209E+00,-0.27169E+00,-0.27129E+00,-0.27090E+00,-0.27050E+00,& - -0.27010E+00,-0.26971E+00,-0.26931E+00,-0.26892E+00,-0.26852E+00,& - -0.26813E+00,-0.26774E+00,-0.26734E+00,-0.26695E+00,-0.26656E+00,& - -0.26616E+00,-0.26577E+00,-0.26538E+00,-0.26499E+00,-0.26460E+00,& - -0.26421E+00,-0.26382E+00,-0.26343E+00,-0.26304E+00,-0.26158E+00/ - - DATA (BNC13M (IA),IA=601,700)/ & - -0.25840E+00,-0.25457E+00,-0.25078E+00,-0.24702E+00,-0.24330E+00,& - -0.23961E+00,-0.23595E+00,-0.23233E+00,-0.22874E+00,-0.22518E+00,& - -0.22165E+00,-0.21815E+00,-0.21469E+00,-0.21125E+00,-0.20784E+00,& - -0.20447E+00,-0.20112E+00,-0.19779E+00,-0.19450E+00,-0.19123E+00,& - -0.18799E+00,-0.18477E+00,-0.18158E+00,-0.17842E+00,-0.17528E+00,& - -0.17217E+00,-0.16907E+00,-0.16601E+00,-0.16297E+00,-0.15995E+00,& - -0.15695E+00,-0.15397E+00,-0.15102E+00,-0.14809E+00,-0.14518E+00,& - -0.14229E+00,-0.13943E+00,-0.13658E+00,-0.13375E+00,-0.13095E+00,& - -0.12816E+00,-0.12539E+00,-0.12265E+00,-0.11992E+00,-0.11721E+00,& - -0.11452E+00,-0.11184E+00,-0.10919E+00,-0.10655E+00,-0.10393E+00,& - -0.10133E+00,-0.98739E-01,-0.96170E-01,-0.93617E-01,-0.91081E-01,& - -0.88561E-01,-0.86056E-01,-0.83568E-01,-0.81095E-01,-0.78637E-01,& - -0.76195E-01,-0.73767E-01,-0.71355E-01,-0.68957E-01,-0.66573E-01,& - -0.64204E-01,-0.61849E-01,-0.59507E-01,-0.57180E-01,-0.54866E-01,& - -0.52566E-01,-0.50279E-01,-0.48005E-01,-0.45744E-01,-0.43496E-01,& - -0.41260E-01,-0.39037E-01,-0.36827E-01,-0.34628E-01,-0.32442E-01,& - -0.30268E-01,-0.28106E-01,-0.25956E-01,-0.23817E-01,-0.21689E-01,& - -0.19574E-01,-0.17469E-01,-0.15375E-01,-0.13292E-01,-0.11221E-01,& - -0.91598E-02,-0.71093E-02,-0.50696E-02,-0.30402E-02,-0.10212E-02,& - 0.98748E-03, 0.29862E-02, 0.49749E-02, 0.69534E-02, 0.89223E-02/ - - DATA (BNC13M(IA),IA=701,741)/ & - 0.10881E-01, 0.12831E-01, 0.14771E-01, 0.16702E-01, 0.18623E-01,& - 0.20535E-01, 0.22438E-01, 0.24331E-01, 0.26216E-01, 0.28092E-01,& - 0.29959E-01, 0.31817E-01, 0.33667E-01, 0.35508E-01, 0.37340E-01,& - 0.39165E-01, 0.40981E-01, 0.42788E-01, 0.44588E-01, 0.46379E-01,& - 0.48162E-01, 0.49937E-01, 0.51705E-01, 0.53464E-01, 0.55216E-01,& - 0.56961E-01, 0.58697E-01, 0.60426E-01, 0.62148E-01, 0.63862E-01,& - 0.65569E-01, 0.67268E-01, 0.68960E-01, 0.70645E-01, 0.72323E-01,& - 0.73994E-01, 0.75658E-01, 0.77315E-01, 0.78966E-01, 0.80609E-01,& - 0.82246E-01 / -! END - -! ** TEMP = 323.0 - -! BLOCK DATA KMCF323 -! -! ** Common block definition -! -! COMMON /KMC323/ & -! BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & -! BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & -! BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & -! BNC13M( 741) -! -! ** NaCl -! - DATA (BNC01M (IA),IA= 1,100)/ & - -0.48816E-01,-0.86364E-01,-0.11089E+00,-0.12640E+00,-0.13753E+00,& - -0.14603E+00,-0.15274E+00,-0.15816E+00,-0.16259E+00,-0.16624E+00,& - -0.16927E+00,-0.17179E+00,-0.17387E+00,-0.17559E+00,-0.17699E+00,& - -0.17812E+00,-0.17901E+00,-0.17968E+00,-0.18017E+00,-0.18049E+00,& - -0.18066E+00,-0.18070E+00,-0.18061E+00,-0.18042E+00,-0.18013E+00,& - -0.17974E+00,-0.17927E+00,-0.17873E+00,-0.17812E+00,-0.17744E+00,& - -0.17671E+00,-0.17593E+00,-0.17509E+00,-0.17421E+00,-0.17329E+00,& - -0.17233E+00,-0.17134E+00,-0.17031E+00,-0.16926E+00,-0.16817E+00,& - -0.16707E+00,-0.16594E+00,-0.16479E+00,-0.16362E+00,-0.16243E+00,& - -0.16122E+00,-0.16000E+00,-0.15877E+00,-0.15752E+00,-0.15626E+00,& - -0.15499E+00,-0.15371E+00,-0.15242E+00,-0.15112E+00,-0.14981E+00,& - -0.14849E+00,-0.14716E+00,-0.14583E+00,-0.14448E+00,-0.14313E+00,& - -0.14177E+00,-0.14041E+00,-0.13904E+00,-0.13766E+00,-0.13627E+00,& - -0.13487E+00,-0.13347E+00,-0.13206E+00,-0.13063E+00,-0.12920E+00,& - -0.12777E+00,-0.12632E+00,-0.12486E+00,-0.12340E+00,-0.12192E+00,& - -0.12043E+00,-0.11893E+00,-0.11743E+00,-0.11591E+00,-0.11438E+00,& - -0.11283E+00,-0.11128E+00,-0.10972E+00,-0.10814E+00,-0.10655E+00,& - -0.10495E+00,-0.10333E+00,-0.10171E+00,-0.10007E+00,-0.98421E-01,& - -0.96759E-01,-0.95085E-01,-0.93399E-01,-0.91702E-01,-0.89993E-01,& - -0.88272E-01,-0.86541E-01,-0.84798E-01,-0.83045E-01,-0.81282E-01/ - - DATA (BNC01M (IA),IA=101,200)/ & - -0.79509E-01,-0.77726E-01,-0.75934E-01,-0.74133E-01,-0.72323E-01,& - -0.70506E-01,-0.68680E-01,-0.66847E-01,-0.65007E-01,-0.63160E-01,& - -0.61307E-01,-0.59447E-01,-0.57583E-01,-0.55713E-01,-0.53838E-01,& - -0.51958E-01,-0.50075E-01,-0.48187E-01,-0.46296E-01,-0.44402E-01,& - -0.42697E-01,-0.40775E-01,-0.38852E-01,-0.36930E-01,-0.35007E-01,& - -0.33085E-01,-0.31163E-01,-0.29240E-01,-0.27318E-01,-0.25397E-01,& - -0.23475E-01,-0.21554E-01,-0.19634E-01,-0.17714E-01,-0.15794E-01,& - -0.13875E-01,-0.11957E-01,-0.10039E-01,-0.81222E-02,-0.62060E-02,& - -0.42906E-02,-0.23761E-02,-0.46246E-03, 0.14502E-02, 0.33620E-02,& - 0.52727E-02, 0.71824E-02, 0.90910E-02, 0.10999E-01, 0.12905E-01,& - 0.14810E-01, 0.16714E-01, 0.18617E-01, 0.20518E-01, 0.22419E-01,& - 0.24317E-01, 0.26215E-01, 0.28111E-01, 0.30006E-01, 0.31899E-01,& - 0.33791E-01, 0.35682E-01, 0.37571E-01, 0.39458E-01, 0.41344E-01,& - 0.43228E-01, 0.45111E-01, 0.46992E-01, 0.48871E-01, 0.50749E-01,& - 0.52625E-01, 0.54500E-01, 0.56373E-01, 0.58244E-01, 0.60113E-01,& - 0.61981E-01, 0.63847E-01, 0.65711E-01, 0.67573E-01, 0.69434E-01,& - 0.71292E-01, 0.73149E-01, 0.75004E-01, 0.76857E-01, 0.78709E-01,& - 0.80558E-01, 0.82406E-01, 0.84251E-01, 0.86095E-01, 0.87937E-01,& - 0.89776E-01, 0.91614E-01, 0.93450E-01, 0.95284E-01, 0.97116E-01,& - 0.98946E-01, 0.10077E+00, 0.10260E+00, 0.10442E+00, 0.10625E+00/ - - DATA (BNC01M (IA),IA=201,300)/ & - 0.10807E+00, 0.10988E+00, 0.11170E+00, 0.11351E+00, 0.11533E+00,& - 0.11714E+00, 0.11894E+00, 0.12075E+00, 0.12255E+00, 0.12435E+00,& - 0.12615E+00, 0.12795E+00, 0.12975E+00, 0.13154E+00, 0.13333E+00,& - 0.13512E+00, 0.13691E+00, 0.13869E+00, 0.14047E+00, 0.14226E+00,& - 0.14403E+00, 0.14581E+00, 0.14758E+00, 0.14936E+00, 0.15113E+00,& - 0.15289E+00, 0.15466E+00, 0.15642E+00, 0.15818E+00, 0.15994E+00,& - 0.16170E+00, 0.16346E+00, 0.16521E+00, 0.16696E+00, 0.16871E+00,& - 0.17045E+00, 0.17220E+00, 0.17394E+00, 0.17568E+00, 0.17742E+00,& - 0.17915E+00, 0.18089E+00, 0.18262E+00, 0.18435E+00, 0.18608E+00,& - 0.18780E+00, 0.18952E+00, 0.19124E+00, 0.19296E+00, 0.19468E+00,& - 0.19639E+00, 0.19811E+00, 0.19982E+00, 0.20152E+00, 0.20323E+00,& - 0.20493E+00, 0.20663E+00, 0.20833E+00, 0.21003E+00, 0.21172E+00,& - 0.21342E+00, 0.21511E+00, 0.21680E+00, 0.21848E+00, 0.22017E+00,& - 0.22185E+00, 0.22353E+00, 0.22521E+00, 0.22688E+00, 0.22856E+00,& - 0.23023E+00, 0.23190E+00, 0.23356E+00, 0.23523E+00, 0.23689E+00,& - 0.23855E+00, 0.24021E+00, 0.24187E+00, 0.24352E+00, 0.24518E+00,& - 0.24683E+00, 0.24847E+00, 0.25012E+00, 0.25176E+00, 0.25341E+00,& - 0.25505E+00, 0.25668E+00, 0.25832E+00, 0.25995E+00, 0.26158E+00,& - 0.26321E+00, 0.26484E+00, 0.26647E+00, 0.26809E+00, 0.26971E+00,& - 0.27133E+00, 0.27295E+00, 0.27456E+00, 0.27618E+00, 0.27779E+00/ - - DATA (BNC01M (IA),IA=301,400)/ & - 0.27940E+00, 0.28100E+00, 0.28261E+00, 0.28421E+00, 0.28581E+00,& - 0.28741E+00, 0.28901E+00, 0.29060E+00, 0.29219E+00, 0.29378E+00,& - 0.29537E+00, 0.29696E+00, 0.29854E+00, 0.30012E+00, 0.30171E+00,& - 0.30328E+00, 0.30486E+00, 0.30643E+00, 0.30801E+00, 0.30958E+00,& - 0.31115E+00, 0.31271E+00, 0.31428E+00, 0.31584E+00, 0.31740E+00,& - 0.31896E+00, 0.32052E+00, 0.32207E+00, 0.32362E+00, 0.32517E+00,& - 0.32672E+00, 0.32827E+00, 0.32982E+00, 0.33136E+00, 0.33290E+00,& - 0.33444E+00, 0.33598E+00, 0.33751E+00, 0.33904E+00, 0.34058E+00,& - 0.34211E+00, 0.34363E+00, 0.34516E+00, 0.34668E+00, 0.34820E+00,& - 0.34972E+00, 0.35124E+00, 0.35276E+00, 0.35427E+00, 0.35579E+00,& - 0.35730E+00, 0.35881E+00, 0.36031E+00, 0.36182E+00, 0.36332E+00,& - 0.36482E+00, 0.36632E+00, 0.36782E+00, 0.36931E+00, 0.37081E+00,& - 0.37230E+00, 0.37379E+00, 0.37528E+00, 0.37677E+00, 0.37825E+00,& - 0.37973E+00, 0.38121E+00, 0.38269E+00, 0.38417E+00, 0.38565E+00,& - 0.38712E+00, 0.38859E+00, 0.39006E+00, 0.39153E+00, 0.39300E+00,& - 0.39446E+00, 0.39593E+00, 0.39739E+00, 0.39885E+00, 0.40030E+00,& - 0.40176E+00, 0.40321E+00, 0.40467E+00, 0.40612E+00, 0.40757E+00,& - 0.40901E+00, 0.41046E+00, 0.41190E+00, 0.41334E+00, 0.41478E+00,& - 0.41622E+00, 0.41766E+00, 0.41909E+00, 0.42053E+00, 0.42196E+00,& - 0.42339E+00, 0.42482E+00, 0.42624E+00, 0.42767E+00, 0.42909E+00/ - - DATA (BNC01M (IA),IA=401,500)/ & - 0.43051E+00, 0.43193E+00, 0.43335E+00, 0.43477E+00, 0.43618E+00,& - 0.43759E+00, 0.43901E+00, 0.44042E+00, 0.44182E+00, 0.44323E+00,& - 0.44463E+00, 0.44604E+00, 0.44744E+00, 0.44884E+00, 0.45024E+00,& - 0.45163E+00, 0.45303E+00, 0.45442E+00, 0.45581E+00, 0.45720E+00,& - 0.45859E+00, 0.45998E+00, 0.46136E+00, 0.46274E+00, 0.46413E+00,& - 0.46551E+00, 0.46689E+00, 0.46826E+00, 0.46964E+00, 0.47101E+00,& - 0.47238E+00, 0.47375E+00, 0.47512E+00, 0.47649E+00, 0.47786E+00,& - 0.47922E+00, 0.48058E+00, 0.48194E+00, 0.48330E+00, 0.48466E+00,& - 0.48602E+00, 0.48737E+00, 0.48873E+00, 0.49008E+00, 0.49143E+00,& - 0.49278E+00, 0.49412E+00, 0.49547E+00, 0.49681E+00, 0.49816E+00,& - 0.49950E+00, 0.50084E+00, 0.50217E+00, 0.50351E+00, 0.50485E+00,& - 0.50618E+00, 0.50751E+00, 0.50884E+00, 0.51017E+00, 0.51150E+00,& - 0.51282E+00, 0.51415E+00, 0.51547E+00, 0.51679E+00, 0.51811E+00,& - 0.51943E+00, 0.52075E+00, 0.52206E+00, 0.52338E+00, 0.52469E+00,& - 0.52600E+00, 0.52731E+00, 0.52862E+00, 0.52993E+00, 0.53123E+00,& - 0.53254E+00, 0.53384E+00, 0.53514E+00, 0.53644E+00, 0.53774E+00,& - 0.53904E+00, 0.54033E+00, 0.54162E+00, 0.54292E+00, 0.54421E+00,& - 0.54550E+00, 0.54679E+00, 0.54807E+00, 0.54936E+00, 0.55064E+00,& - 0.55193E+00, 0.55321E+00, 0.55449E+00, 0.55577E+00, 0.55704E+00,& - 0.55832E+00, 0.55959E+00, 0.56087E+00, 0.56214E+00, 0.56341E+00/ - - DATA (BNC01M (IA),IA=501,600)/ & - 0.56468E+00, 0.56594E+00, 0.56721E+00, 0.56848E+00, 0.56974E+00,& - 0.57100E+00, 0.57226E+00, 0.57352E+00, 0.57478E+00, 0.57604E+00,& - 0.57729E+00, 0.57855E+00, 0.57980E+00, 0.58105E+00, 0.58230E+00,& - 0.58355E+00, 0.58480E+00, 0.58604E+00, 0.58729E+00, 0.58853E+00,& - 0.58977E+00, 0.59101E+00, 0.59225E+00, 0.59349E+00, 0.59473E+00,& - 0.59596E+00, 0.59720E+00, 0.59843E+00, 0.59966E+00, 0.60089E+00,& - 0.60212E+00, 0.60335E+00, 0.60458E+00, 0.60580E+00, 0.60703E+00,& - 0.60825E+00, 0.60947E+00, 0.61069E+00, 0.61191E+00, 0.61313E+00,& - 0.61435E+00, 0.61556E+00, 0.61678E+00, 0.61799E+00, 0.61920E+00,& - 0.62041E+00, 0.62162E+00, 0.62283E+00, 0.62403E+00, 0.62524E+00,& - 0.62644E+00, 0.62765E+00, 0.62885E+00, 0.63005E+00, 0.63125E+00,& - 0.63245E+00, 0.63364E+00, 0.63484E+00, 0.63603E+00, 0.63723E+00,& - 0.63842E+00, 0.63961E+00, 0.64080E+00, 0.64199E+00, 0.64318E+00,& - 0.64436E+00, 0.64555E+00, 0.64673E+00, 0.64791E+00, 0.64909E+00,& - 0.65027E+00, 0.65145E+00, 0.65263E+00, 0.65381E+00, 0.65498E+00,& - 0.65616E+00, 0.65733E+00, 0.65850E+00, 0.65967E+00, 0.66084E+00,& - 0.66201E+00, 0.66318E+00, 0.66435E+00, 0.66551E+00, 0.66667E+00,& - 0.66784E+00, 0.66900E+00, 0.67016E+00, 0.67132E+00, 0.67248E+00,& - 0.67363E+00, 0.67479E+00, 0.67595E+00, 0.67710E+00, 0.67825E+00,& - 0.67940E+00, 0.68055E+00, 0.68170E+00, 0.68285E+00, 0.68715E+00/ - - DATA (BNC01M (IA),IA=601,700)/ & - 0.69654E+00, 0.70783E+00, 0.71902E+00, 0.73010E+00, 0.74108E+00,& - 0.75196E+00, 0.76274E+00, 0.77342E+00, 0.78402E+00, 0.79451E+00,& - 0.80492E+00, 0.81524E+00, 0.82547E+00, 0.83562E+00, 0.84568E+00,& - 0.85566E+00, 0.86556E+00, 0.87538E+00, 0.88512E+00, 0.89478E+00,& - 0.90437E+00, 0.91389E+00, 0.92333E+00, 0.93270E+00, 0.94200E+00,& - 0.95123E+00, 0.96040E+00, 0.96949E+00, 0.97852E+00, 0.98749E+00,& - 0.99639E+00, 0.10052E+01, 0.10140E+01, 0.10227E+01, 0.10314E+01,& - 0.10400E+01, 0.10485E+01, 0.10570E+01, 0.10654E+01, 0.10738E+01,& - 0.10821E+01, 0.10904E+01, 0.10986E+01, 0.11068E+01, 0.11149E+01,& - 0.11230E+01, 0.11310E+01, 0.11389E+01, 0.11469E+01, 0.11547E+01,& - 0.11625E+01, 0.11703E+01, 0.11780E+01, 0.11857E+01, 0.11934E+01,& - 0.12010E+01, 0.12085E+01, 0.12160E+01, 0.12235E+01, 0.12309E+01,& - 0.12383E+01, 0.12457E+01, 0.12530E+01, 0.12602E+01, 0.12675E+01,& - 0.12747E+01, 0.12818E+01, 0.12889E+01, 0.12960E+01, 0.13031E+01,& - 0.13101E+01, 0.13170E+01, 0.13240E+01, 0.13309E+01, 0.13378E+01,& - 0.13446E+01, 0.13514E+01, 0.13582E+01, 0.13649E+01, 0.13716E+01,& - 0.13783E+01, 0.13849E+01, 0.13915E+01, 0.13981E+01, 0.14047E+01,& - 0.14112E+01, 0.14177E+01, 0.14241E+01, 0.14306E+01, 0.14370E+01,& - 0.14434E+01, 0.14497E+01, 0.14560E+01, 0.14623E+01, 0.14686E+01,& - 0.14748E+01, 0.14810E+01, 0.14872E+01, 0.14934E+01, 0.14995E+01/ - - DATA (BNC01M(IA),IA=701,741)/ & - 0.15056E+01, 0.15117E+01, 0.15178E+01, 0.15238E+01, 0.15298E+01,& - 0.15358E+01, 0.15418E+01, 0.15477E+01, 0.15536E+01, 0.15595E+01,& - 0.15654E+01, 0.15713E+01, 0.15771E+01, 0.15829E+01, 0.15887E+01,& - 0.15944E+01, 0.16002E+01, 0.16059E+01, 0.16116E+01, 0.16173E+01,& - 0.16229E+01, 0.16286E+01, 0.16342E+01, 0.16398E+01, 0.16453E+01,& - 0.16509E+01, 0.16564E+01, 0.16620E+01, 0.16675E+01, 0.16729E+01,& - 0.16784E+01, 0.16838E+01, 0.16893E+01, 0.16947E+01, 0.17000E+01,& - 0.17054E+01, 0.17108E+01, 0.17161E+01, 0.17214E+01, 0.17267E+01,& - 0.17320E+01 / -! -! ** Na2SO4 -! - DATA (BNC02M (IA),IA= 1,100)/ & - -0.10024E+00,-0.18230E+00,-0.23981E+00,-0.27879E+00,-0.30871E+00,& - -0.33311E+00,-0.35376E+00,-0.37167E+00,-0.38749E+00,-0.40165E+00,& - -0.41447E+00,-0.42617E+00,-0.43693E+00,-0.44690E+00,-0.45616E+00,& - -0.46482E+00,-0.47294E+00,-0.48058E+00,-0.48780E+00,-0.49464E+00,& - -0.50113E+00,-0.50730E+00,-0.51318E+00,-0.51880E+00,-0.52418E+00,& - -0.52933E+00,-0.53428E+00,-0.53903E+00,-0.54360E+00,-0.54800E+00,& - -0.55224E+00,-0.55634E+00,-0.56030E+00,-0.56412E+00,-0.56783E+00,& - -0.57141E+00,-0.57489E+00,-0.57826E+00,-0.58153E+00,-0.58471E+00,& - -0.58779E+00,-0.59080E+00,-0.59371E+00,-0.59655E+00,-0.59932E+00,& - -0.60201E+00,-0.60464E+00,-0.60720E+00,-0.60969E+00,-0.61213E+00,& - -0.61451E+00,-0.61683E+00,-0.61910E+00,-0.62131E+00,-0.62348E+00,& - -0.62560E+00,-0.62767E+00,-0.62970E+00,-0.63168E+00,-0.63362E+00,& - -0.63553E+00,-0.63739E+00,-0.63922E+00,-0.64101E+00,-0.64276E+00,& - -0.64449E+00,-0.64618E+00,-0.64784E+00,-0.64946E+00,-0.65106E+00,& - -0.65263E+00,-0.65417E+00,-0.65569E+00,-0.65718E+00,-0.65865E+00,& - -0.66009E+00,-0.66150E+00,-0.66290E+00,-0.66427E+00,-0.66562E+00,& - -0.66695E+00,-0.66826E+00,-0.66956E+00,-0.67083E+00,-0.67208E+00,& - -0.67332E+00,-0.67454E+00,-0.67574E+00,-0.67692E+00,-0.67809E+00,& - -0.67924E+00,-0.68038E+00,-0.68150E+00,-0.68261E+00,-0.68371E+00,& - -0.68479E+00,-0.68585E+00,-0.68691E+00,-0.68795E+00,-0.68897E+00/ - - DATA (BNC02M (IA),IA=101,200)/ & - -0.68999E+00,-0.69099E+00,-0.69198E+00,-0.69296E+00,-0.69393E+00,& - -0.69488E+00,-0.69582E+00,-0.69676E+00,-0.69768E+00,-0.69859E+00,& - -0.69949E+00,-0.70038E+00,-0.70126E+00,-0.70213E+00,-0.70299E+00,& - -0.70384E+00,-0.70468E+00,-0.70551E+00,-0.70633E+00,-0.70715E+00,& - -0.70792E+00,-0.70871E+00,-0.70950E+00,-0.71028E+00,-0.71105E+00,& - -0.71181E+00,-0.71257E+00,-0.71331E+00,-0.71405E+00,-0.71477E+00,& - -0.71549E+00,-0.71620E+00,-0.71691E+00,-0.71760E+00,-0.71829E+00,& - -0.71897E+00,-0.71964E+00,-0.72031E+00,-0.72097E+00,-0.72162E+00,& - -0.72226E+00,-0.72290E+00,-0.72353E+00,-0.72415E+00,-0.72477E+00,& - -0.72538E+00,-0.72598E+00,-0.72658E+00,-0.72717E+00,-0.72775E+00,& - -0.72833E+00,-0.72890E+00,-0.72947E+00,-0.73003E+00,-0.73058E+00,& - -0.73113E+00,-0.73168E+00,-0.73221E+00,-0.73274E+00,-0.73327E+00,& - -0.73379E+00,-0.73431E+00,-0.73482E+00,-0.73532E+00,-0.73582E+00,& - -0.73632E+00,-0.73681E+00,-0.73729E+00,-0.73778E+00,-0.73825E+00,& - -0.73872E+00,-0.73919E+00,-0.73965E+00,-0.74011E+00,-0.74056E+00,& - -0.74100E+00,-0.74145E+00,-0.74189E+00,-0.74232E+00,-0.74275E+00,& - -0.74318E+00,-0.74360E+00,-0.74402E+00,-0.74443E+00,-0.74484E+00,& - -0.74524E+00,-0.74564E+00,-0.74604E+00,-0.74644E+00,-0.74683E+00,& - -0.74721E+00,-0.74759E+00,-0.74797E+00,-0.74835E+00,-0.74872E+00,& - -0.74908E+00,-0.74945E+00,-0.74981E+00,-0.75016E+00,-0.75052E+00/ - - DATA (BNC02M (IA),IA=201,300)/ & - -0.75087E+00,-0.75121E+00,-0.75155E+00,-0.75189E+00,-0.75223E+00,& - -0.75256E+00,-0.75289E+00,-0.75322E+00,-0.75354E+00,-0.75386E+00,& - -0.75418E+00,-0.75449E+00,-0.75480E+00,-0.75511E+00,-0.75542E+00,& - -0.75572E+00,-0.75602E+00,-0.75631E+00,-0.75661E+00,-0.75690E+00,& - -0.75718E+00,-0.75747E+00,-0.75775E+00,-0.75803E+00,-0.75830E+00,& - -0.75858E+00,-0.75885E+00,-0.75912E+00,-0.75938E+00,-0.75964E+00,& - -0.75990E+00,-0.76016E+00,-0.76042E+00,-0.76067E+00,-0.76092E+00,& - -0.76117E+00,-0.76141E+00,-0.76165E+00,-0.76189E+00,-0.76213E+00,& - -0.76237E+00,-0.76260E+00,-0.76283E+00,-0.76306E+00,-0.76328E+00,& - -0.76351E+00,-0.76373E+00,-0.76395E+00,-0.76417E+00,-0.76438E+00,& - -0.76459E+00,-0.76480E+00,-0.76501E+00,-0.76522E+00,-0.76542E+00,& - -0.76562E+00,-0.76582E+00,-0.76602E+00,-0.76621E+00,-0.76641E+00,& - -0.76660E+00,-0.76679E+00,-0.76698E+00,-0.76716E+00,-0.76734E+00,& - -0.76753E+00,-0.76770E+00,-0.76788E+00,-0.76806E+00,-0.76823E+00,& - -0.76840E+00,-0.76857E+00,-0.76874E+00,-0.76891E+00,-0.76907E+00,& - -0.76923E+00,-0.76940E+00,-0.76955E+00,-0.76971E+00,-0.76987E+00,& - -0.77002E+00,-0.77017E+00,-0.77032E+00,-0.77047E+00,-0.77062E+00,& - -0.77076E+00,-0.77091E+00,-0.77105E+00,-0.77119E+00,-0.77133E+00,& - -0.77146E+00,-0.77160E+00,-0.77173E+00,-0.77186E+00,-0.77199E+00,& - -0.77212E+00,-0.77225E+00,-0.77238E+00,-0.77250E+00,-0.77262E+00/ - - DATA (BNC02M (IA),IA=301,400)/ & - -0.77274E+00,-0.77286E+00,-0.77298E+00,-0.77310E+00,-0.77321E+00,& - -0.77333E+00,-0.77344E+00,-0.77355E+00,-0.77366E+00,-0.77377E+00,& - -0.77387E+00,-0.77398E+00,-0.77408E+00,-0.77418E+00,-0.77428E+00,& - -0.77438E+00,-0.77448E+00,-0.77458E+00,-0.77467E+00,-0.77477E+00,& - -0.77486E+00,-0.77495E+00,-0.77504E+00,-0.77513E+00,-0.77522E+00,& - -0.77530E+00,-0.77539E+00,-0.77547E+00,-0.77555E+00,-0.77563E+00,& - -0.77571E+00,-0.77579E+00,-0.77587E+00,-0.77595E+00,-0.77602E+00,& - -0.77609E+00,-0.77617E+00,-0.77624E+00,-0.77631E+00,-0.77638E+00,& - -0.77644E+00,-0.77651E+00,-0.77657E+00,-0.77664E+00,-0.77670E+00,& - -0.77676E+00,-0.77682E+00,-0.77688E+00,-0.77694E+00,-0.77700E+00,& - -0.77705E+00,-0.77711E+00,-0.77716E+00,-0.77722E+00,-0.77727E+00,& - -0.77732E+00,-0.77737E+00,-0.77742E+00,-0.77746E+00,-0.77751E+00,& - -0.77755E+00,-0.77760E+00,-0.77764E+00,-0.77768E+00,-0.77772E+00,& - -0.77776E+00,-0.77780E+00,-0.77784E+00,-0.77788E+00,-0.77791E+00,& - -0.77795E+00,-0.77798E+00,-0.77802E+00,-0.77805E+00,-0.77808E+00,& - -0.77811E+00,-0.77814E+00,-0.77817E+00,-0.77819E+00,-0.77822E+00,& - -0.77825E+00,-0.77827E+00,-0.77829E+00,-0.77832E+00,-0.77834E+00,& - -0.77836E+00,-0.77838E+00,-0.77840E+00,-0.77841E+00,-0.77843E+00,& - -0.77845E+00,-0.77846E+00,-0.77848E+00,-0.77849E+00,-0.77850E+00,& - -0.77851E+00,-0.77852E+00,-0.77853E+00,-0.77854E+00,-0.77855E+00/ - - DATA (BNC02M (IA),IA=401,500)/ & - -0.77856E+00,-0.77857E+00,-0.77857E+00,-0.77858E+00,-0.77858E+00,& - -0.77858E+00,-0.77859E+00,-0.77859E+00,-0.77859E+00,-0.77859E+00,& - -0.77859E+00,-0.77859E+00,-0.77858E+00,-0.77858E+00,-0.77858E+00,& - -0.77857E+00,-0.77856E+00,-0.77856E+00,-0.77855E+00,-0.77854E+00,& - -0.77853E+00,-0.77852E+00,-0.77851E+00,-0.77850E+00,-0.77849E+00,& - -0.77848E+00,-0.77847E+00,-0.77845E+00,-0.77844E+00,-0.77842E+00,& - -0.77840E+00,-0.77839E+00,-0.77837E+00,-0.77835E+00,-0.77833E+00,& - -0.77831E+00,-0.77829E+00,-0.77827E+00,-0.77825E+00,-0.77823E+00,& - -0.77820E+00,-0.77818E+00,-0.77815E+00,-0.77813E+00,-0.77810E+00,& - -0.77807E+00,-0.77805E+00,-0.77802E+00,-0.77799E+00,-0.77796E+00,& - -0.77793E+00,-0.77790E+00,-0.77787E+00,-0.77784E+00,-0.77780E+00,& - -0.77777E+00,-0.77773E+00,-0.77770E+00,-0.77766E+00,-0.77763E+00,& - -0.77759E+00,-0.77755E+00,-0.77752E+00,-0.77748E+00,-0.77744E+00,& - -0.77740E+00,-0.77736E+00,-0.77732E+00,-0.77727E+00,-0.77723E+00,& - -0.77719E+00,-0.77714E+00,-0.77710E+00,-0.77706E+00,-0.77701E+00,& - -0.77696E+00,-0.77692E+00,-0.77687E+00,-0.77682E+00,-0.77677E+00,& - -0.77672E+00,-0.77668E+00,-0.77663E+00,-0.77657E+00,-0.77652E+00,& - -0.77647E+00,-0.77642E+00,-0.77637E+00,-0.77631E+00,-0.77626E+00,& - -0.77620E+00,-0.77615E+00,-0.77609E+00,-0.77604E+00,-0.77598E+00,& - -0.77592E+00,-0.77586E+00,-0.77580E+00,-0.77575E+00,-0.77569E+00/ - - DATA (BNC02M (IA),IA=501,600)/ & - -0.77563E+00,-0.77556E+00,-0.77550E+00,-0.77544E+00,-0.77538E+00,& - -0.77532E+00,-0.77525E+00,-0.77519E+00,-0.77512E+00,-0.77506E+00,& - -0.77499E+00,-0.77493E+00,-0.77486E+00,-0.77479E+00,-0.77473E+00,& - -0.77466E+00,-0.77459E+00,-0.77452E+00,-0.77445E+00,-0.77438E+00,& - -0.77431E+00,-0.77424E+00,-0.77417E+00,-0.77410E+00,-0.77402E+00,& - -0.77395E+00,-0.77388E+00,-0.77380E+00,-0.77373E+00,-0.77365E+00,& - -0.77358E+00,-0.77350E+00,-0.77343E+00,-0.77335E+00,-0.77327E+00,& - -0.77319E+00,-0.77312E+00,-0.77304E+00,-0.77296E+00,-0.77288E+00,& - -0.77280E+00,-0.77272E+00,-0.77264E+00,-0.77256E+00,-0.77247E+00,& - -0.77239E+00,-0.77231E+00,-0.77223E+00,-0.77214E+00,-0.77206E+00,& - -0.77197E+00,-0.77189E+00,-0.77180E+00,-0.77172E+00,-0.77163E+00,& - -0.77154E+00,-0.77146E+00,-0.77137E+00,-0.77128E+00,-0.77119E+00,& - -0.77110E+00,-0.77102E+00,-0.77093E+00,-0.77084E+00,-0.77074E+00,& - -0.77065E+00,-0.77056E+00,-0.77047E+00,-0.77038E+00,-0.77029E+00,& - -0.77019E+00,-0.77010E+00,-0.77001E+00,-0.76991E+00,-0.76982E+00,& - -0.76972E+00,-0.76963E+00,-0.76953E+00,-0.76943E+00,-0.76934E+00,& - -0.76924E+00,-0.76914E+00,-0.76904E+00,-0.76895E+00,-0.76885E+00,& - -0.76875E+00,-0.76865E+00,-0.76855E+00,-0.76845E+00,-0.76835E+00,& - -0.76825E+00,-0.76815E+00,-0.76804E+00,-0.76794E+00,-0.76784E+00,& - -0.76774E+00,-0.76763E+00,-0.76753E+00,-0.76743E+00,-0.76703E+00/ - - DATA (BNC02M (IA),IA=601,700)/ & - -0.76615E+00,-0.76505E+00,-0.76391E+00,-0.76274E+00,-0.76154E+00,& - -0.76031E+00,-0.75905E+00,-0.75775E+00,-0.75643E+00,-0.75509E+00,& - -0.75371E+00,-0.75231E+00,-0.75089E+00,-0.74944E+00,-0.74797E+00,& - -0.74647E+00,-0.74496E+00,-0.74342E+00,-0.74186E+00,-0.74028E+00,& - -0.73868E+00,-0.73706E+00,-0.73542E+00,-0.73376E+00,-0.73209E+00,& - -0.73040E+00,-0.72869E+00,-0.72696E+00,-0.72522E+00,-0.72346E+00,& - -0.72169E+00,-0.71990E+00,-0.71810E+00,-0.71628E+00,-0.71445E+00,& - -0.71261E+00,-0.71075E+00,-0.70888E+00,-0.70699E+00,-0.70510E+00,& - -0.70319E+00,-0.70127E+00,-0.69934E+00,-0.69739E+00,-0.69544E+00,& - -0.69347E+00,-0.69150E+00,-0.68951E+00,-0.68751E+00,-0.68551E+00,& - -0.68349E+00,-0.68146E+00,-0.67943E+00,-0.67738E+00,-0.67533E+00,& - -0.67326E+00,-0.67119E+00,-0.66911E+00,-0.66702E+00,-0.66493E+00,& - -0.66282E+00,-0.66071E+00,-0.65859E+00,-0.65646E+00,-0.65432E+00,& - -0.65218E+00,-0.65003E+00,-0.64787E+00,-0.64571E+00,-0.64354E+00,& - -0.64136E+00,-0.63917E+00,-0.63698E+00,-0.63478E+00,-0.63258E+00,& - -0.63037E+00,-0.62815E+00,-0.62593E+00,-0.62370E+00,-0.62147E+00,& - -0.61923E+00,-0.61699E+00,-0.61474E+00,-0.61248E+00,-0.61022E+00,& - -0.60795E+00,-0.60568E+00,-0.60341E+00,-0.60113E+00,-0.59884E+00,& - -0.59655E+00,-0.59425E+00,-0.59195E+00,-0.58965E+00,-0.58734E+00,& - -0.58503E+00,-0.58271E+00,-0.58039E+00,-0.57806E+00,-0.57573E+00/ - - DATA (BNC02M(IA),IA=701,741)/ & - -0.57339E+00,-0.57106E+00,-0.56871E+00,-0.56637E+00,-0.56402E+00,& - -0.56166E+00,-0.55930E+00,-0.55694E+00,-0.55458E+00,-0.55221E+00,& - -0.54984E+00,-0.54746E+00,-0.54508E+00,-0.54270E+00,-0.54031E+00,& - -0.53792E+00,-0.53553E+00,-0.53313E+00,-0.53073E+00,-0.52833E+00,& - -0.52593E+00,-0.52352E+00,-0.52111E+00,-0.51870E+00,-0.51628E+00,& - -0.51386E+00,-0.51144E+00,-0.50901E+00,-0.50658E+00,-0.50415E+00,& - -0.50172E+00,-0.49928E+00,-0.49684E+00,-0.49440E+00,-0.49196E+00,& - -0.48951E+00,-0.48706E+00,-0.48461E+00,-0.48216E+00,-0.47970E+00,& - -0.47725E+00 / -! -! ** NaNO3 -! - DATA (BNC03M (IA),IA= 1,100)/ & - -0.50245E-01,-0.91612E-01,-0.12079E+00,-0.14067E+00,-0.15601E+00,& - -0.16858E+00,-0.17927E+00,-0.18858E+00,-0.19683E+00,-0.20425E+00,& - -0.21100E+00,-0.21718E+00,-0.22289E+00,-0.22819E+00,-0.23314E+00,& - -0.23778E+00,-0.24215E+00,-0.24628E+00,-0.25020E+00,-0.25391E+00,& - -0.25745E+00,-0.26083E+00,-0.26407E+00,-0.26716E+00,-0.27014E+00,& - -0.27300E+00,-0.27575E+00,-0.27840E+00,-0.28095E+00,-0.28343E+00,& - -0.28582E+00,-0.28813E+00,-0.29037E+00,-0.29254E+00,-0.29465E+00,& - -0.29669E+00,-0.29868E+00,-0.30062E+00,-0.30250E+00,-0.30433E+00,& - -0.30611E+00,-0.30785E+00,-0.30954E+00,-0.31119E+00,-0.31281E+00,& - -0.31438E+00,-0.31592E+00,-0.31742E+00,-0.31889E+00,-0.32032E+00,& - -0.32173E+00,-0.32310E+00,-0.32444E+00,-0.32576E+00,-0.32705E+00,& - -0.32832E+00,-0.32955E+00,-0.33077E+00,-0.33196E+00,-0.33313E+00,& - -0.33428E+00,-0.33540E+00,-0.33651E+00,-0.33760E+00,-0.33867E+00,& - -0.33972E+00,-0.34075E+00,-0.34176E+00,-0.34276E+00,-0.34375E+00,& - -0.34472E+00,-0.34567E+00,-0.34661E+00,-0.34754E+00,-0.34845E+00,& - -0.34935E+00,-0.35024E+00,-0.35112E+00,-0.35198E+00,-0.35284E+00,& - -0.35368E+00,-0.35452E+00,-0.35534E+00,-0.35615E+00,-0.35696E+00,& - -0.35775E+00,-0.35854E+00,-0.35932E+00,-0.36009E+00,-0.36085E+00,& - -0.36161E+00,-0.36235E+00,-0.36309E+00,-0.36382E+00,-0.36455E+00,& - -0.36527E+00,-0.36598E+00,-0.36668E+00,-0.36738E+00,-0.36807E+00/ - - DATA (BNC03M (IA),IA=101,200)/ & - -0.36876E+00,-0.36943E+00,-0.37011E+00,-0.37077E+00,-0.37143E+00,& - -0.37209E+00,-0.37274E+00,-0.37338E+00,-0.37402E+00,-0.37465E+00,& - -0.37528E+00,-0.37590E+00,-0.37652E+00,-0.37713E+00,-0.37773E+00,& - -0.37833E+00,-0.37893E+00,-0.37952E+00,-0.38010E+00,-0.38068E+00,& - -0.38123E+00,-0.38180E+00,-0.38237E+00,-0.38293E+00,-0.38349E+00,& - -0.38404E+00,-0.38459E+00,-0.38513E+00,-0.38567E+00,-0.38621E+00,& - -0.38674E+00,-0.38726E+00,-0.38778E+00,-0.38830E+00,-0.38881E+00,& - -0.38931E+00,-0.38981E+00,-0.39031E+00,-0.39081E+00,-0.39130E+00,& - -0.39178E+00,-0.39226E+00,-0.39274E+00,-0.39321E+00,-0.39368E+00,& - -0.39415E+00,-0.39461E+00,-0.39507E+00,-0.39553E+00,-0.39598E+00,& - -0.39642E+00,-0.39687E+00,-0.39731E+00,-0.39775E+00,-0.39818E+00,& - -0.39861E+00,-0.39904E+00,-0.39946E+00,-0.39988E+00,-0.40030E+00,& - -0.40071E+00,-0.40112E+00,-0.40153E+00,-0.40193E+00,-0.40233E+00,& - -0.40273E+00,-0.40313E+00,-0.40352E+00,-0.40391E+00,-0.40430E+00,& - -0.40468E+00,-0.40506E+00,-0.40544E+00,-0.40582E+00,-0.40619E+00,& - -0.40656E+00,-0.40693E+00,-0.40729E+00,-0.40765E+00,-0.40801E+00,& - -0.40837E+00,-0.40872E+00,-0.40907E+00,-0.40942E+00,-0.40977E+00,& - -0.41011E+00,-0.41046E+00,-0.41080E+00,-0.41113E+00,-0.41147E+00,& - -0.41180E+00,-0.41213E+00,-0.41246E+00,-0.41278E+00,-0.41311E+00,& - -0.41343E+00,-0.41375E+00,-0.41407E+00,-0.41438E+00,-0.41469E+00/ - - DATA (BNC03M (IA),IA=201,300)/ & - -0.41500E+00,-0.41531E+00,-0.41562E+00,-0.41592E+00,-0.41622E+00,& - -0.41652E+00,-0.41682E+00,-0.41712E+00,-0.41741E+00,-0.41770E+00,& - -0.41799E+00,-0.41828E+00,-0.41857E+00,-0.41885E+00,-0.41914E+00,& - -0.41942E+00,-0.41970E+00,-0.41997E+00,-0.42025E+00,-0.42052E+00,& - -0.42079E+00,-0.42106E+00,-0.42133E+00,-0.42160E+00,-0.42186E+00,& - -0.42213E+00,-0.42239E+00,-0.42265E+00,-0.42290E+00,-0.42316E+00,& - -0.42342E+00,-0.42367E+00,-0.42392E+00,-0.42417E+00,-0.42442E+00,& - -0.42466E+00,-0.42491E+00,-0.42515E+00,-0.42539E+00,-0.42564E+00,& - -0.42587E+00,-0.42611E+00,-0.42635E+00,-0.42658E+00,-0.42681E+00,& - -0.42705E+00,-0.42728E+00,-0.42751E+00,-0.42773E+00,-0.42796E+00,& - -0.42818E+00,-0.42841E+00,-0.42863E+00,-0.42885E+00,-0.42907E+00,& - -0.42928E+00,-0.42950E+00,-0.42971E+00,-0.42993E+00,-0.43014E+00,& - -0.43035E+00,-0.43056E+00,-0.43077E+00,-0.43098E+00,-0.43118E+00,& - -0.43139E+00,-0.43159E+00,-0.43179E+00,-0.43199E+00,-0.43219E+00,& - -0.43239E+00,-0.43259E+00,-0.43278E+00,-0.43298E+00,-0.43317E+00,& - -0.43336E+00,-0.43355E+00,-0.43374E+00,-0.43393E+00,-0.43412E+00,& - -0.43430E+00,-0.43449E+00,-0.43467E+00,-0.43486E+00,-0.43504E+00,& - -0.43522E+00,-0.43540E+00,-0.43558E+00,-0.43576E+00,-0.43593E+00,& - -0.43611E+00,-0.43628E+00,-0.43645E+00,-0.43663E+00,-0.43680E+00,& - -0.43697E+00,-0.43714E+00,-0.43730E+00,-0.43747E+00,-0.43764E+00/ - - DATA (BNC03M (IA),IA=301,400)/ & - -0.43780E+00,-0.43797E+00,-0.43813E+00,-0.43829E+00,-0.43845E+00,& - -0.43861E+00,-0.43877E+00,-0.43893E+00,-0.43909E+00,-0.43924E+00,& - -0.43940E+00,-0.43955E+00,-0.43971E+00,-0.43986E+00,-0.44001E+00,& - -0.44016E+00,-0.44031E+00,-0.44046E+00,-0.44061E+00,-0.44075E+00,& - -0.44090E+00,-0.44104E+00,-0.44119E+00,-0.44133E+00,-0.44147E+00,& - -0.44161E+00,-0.44176E+00,-0.44190E+00,-0.44203E+00,-0.44217E+00,& - -0.44231E+00,-0.44245E+00,-0.44258E+00,-0.44272E+00,-0.44285E+00,& - -0.44298E+00,-0.44312E+00,-0.44325E+00,-0.44338E+00,-0.44351E+00,& - -0.44364E+00,-0.44377E+00,-0.44389E+00,-0.44402E+00,-0.44415E+00,& - -0.44427E+00,-0.44439E+00,-0.44452E+00,-0.44464E+00,-0.44476E+00,& - -0.44488E+00,-0.44500E+00,-0.44512E+00,-0.44524E+00,-0.44536E+00,& - -0.44548E+00,-0.44560E+00,-0.44571E+00,-0.44583E+00,-0.44594E+00,& - -0.44606E+00,-0.44617E+00,-0.44628E+00,-0.44639E+00,-0.44650E+00,& - -0.44661E+00,-0.44672E+00,-0.44683E+00,-0.44694E+00,-0.44705E+00,& - -0.44716E+00,-0.44726E+00,-0.44737E+00,-0.44747E+00,-0.44758E+00,& - -0.44768E+00,-0.44778E+00,-0.44789E+00,-0.44799E+00,-0.44809E+00,& - -0.44819E+00,-0.44829E+00,-0.44839E+00,-0.44848E+00,-0.44858E+00,& - -0.44868E+00,-0.44878E+00,-0.44887E+00,-0.44897E+00,-0.44906E+00,& - -0.44915E+00,-0.44925E+00,-0.44934E+00,-0.44943E+00,-0.44952E+00,& - -0.44961E+00,-0.44970E+00,-0.44979E+00,-0.44988E+00,-0.44997E+00/ - - DATA (BNC03M (IA),IA=401,500)/ & - -0.45006E+00,-0.45015E+00,-0.45023E+00,-0.45032E+00,-0.45040E+00,& - -0.45049E+00,-0.45057E+00,-0.45066E+00,-0.45074E+00,-0.45082E+00,& - -0.45091E+00,-0.45099E+00,-0.45107E+00,-0.45115E+00,-0.45123E+00,& - -0.45131E+00,-0.45139E+00,-0.45146E+00,-0.45154E+00,-0.45162E+00,& - -0.45170E+00,-0.45177E+00,-0.45185E+00,-0.45192E+00,-0.45200E+00,& - -0.45207E+00,-0.45214E+00,-0.45222E+00,-0.45229E+00,-0.45236E+00,& - -0.45243E+00,-0.45250E+00,-0.45257E+00,-0.45264E+00,-0.45271E+00,& - -0.45278E+00,-0.45285E+00,-0.45291E+00,-0.45298E+00,-0.45305E+00,& - -0.45311E+00,-0.45318E+00,-0.45325E+00,-0.45331E+00,-0.45337E+00,& - -0.45344E+00,-0.45350E+00,-0.45356E+00,-0.45363E+00,-0.45369E+00,& - -0.45375E+00,-0.45381E+00,-0.45387E+00,-0.45393E+00,-0.45399E+00,& - -0.45405E+00,-0.45411E+00,-0.45417E+00,-0.45422E+00,-0.45428E+00,& - -0.45434E+00,-0.45439E+00,-0.45445E+00,-0.45450E+00,-0.45456E+00,& - -0.45461E+00,-0.45467E+00,-0.45472E+00,-0.45477E+00,-0.45483E+00,& - -0.45488E+00,-0.45493E+00,-0.45498E+00,-0.45503E+00,-0.45508E+00,& - -0.45513E+00,-0.45518E+00,-0.45523E+00,-0.45528E+00,-0.45533E+00,& - -0.45538E+00,-0.45542E+00,-0.45547E+00,-0.45552E+00,-0.45556E+00,& - -0.45561E+00,-0.45566E+00,-0.45570E+00,-0.45575E+00,-0.45579E+00,& - -0.45583E+00,-0.45588E+00,-0.45592E+00,-0.45596E+00,-0.45600E+00,& - -0.45605E+00,-0.45609E+00,-0.45613E+00,-0.45617E+00,-0.45621E+00/ - - DATA (BNC03M (IA),IA=501,600)/ & - -0.45625E+00,-0.45629E+00,-0.45633E+00,-0.45637E+00,-0.45641E+00,& - -0.45644E+00,-0.45648E+00,-0.45652E+00,-0.45655E+00,-0.45659E+00,& - -0.45663E+00,-0.45666E+00,-0.45670E+00,-0.45673E+00,-0.45677E+00,& - -0.45680E+00,-0.45684E+00,-0.45687E+00,-0.45690E+00,-0.45693E+00,& - -0.45697E+00,-0.45700E+00,-0.45703E+00,-0.45706E+00,-0.45709E+00,& - -0.45712E+00,-0.45715E+00,-0.45718E+00,-0.45721E+00,-0.45724E+00,& - -0.45727E+00,-0.45730E+00,-0.45733E+00,-0.45736E+00,-0.45738E+00,& - -0.45741E+00,-0.45744E+00,-0.45746E+00,-0.45749E+00,-0.45751E+00,& - -0.45754E+00,-0.45757E+00,-0.45759E+00,-0.45761E+00,-0.45764E+00,& - -0.45766E+00,-0.45769E+00,-0.45771E+00,-0.45773E+00,-0.45775E+00,& - -0.45778E+00,-0.45780E+00,-0.45782E+00,-0.45784E+00,-0.45786E+00,& - -0.45788E+00,-0.45790E+00,-0.45792E+00,-0.45794E+00,-0.45796E+00,& - -0.45798E+00,-0.45800E+00,-0.45802E+00,-0.45803E+00,-0.45805E+00,& - -0.45807E+00,-0.45809E+00,-0.45810E+00,-0.45812E+00,-0.45814E+00,& - -0.45815E+00,-0.45817E+00,-0.45818E+00,-0.45820E+00,-0.45821E+00,& - -0.45823E+00,-0.45824E+00,-0.45825E+00,-0.45827E+00,-0.45828E+00,& - -0.45829E+00,-0.45831E+00,-0.45832E+00,-0.45833E+00,-0.45834E+00,& - -0.45835E+00,-0.45836E+00,-0.45838E+00,-0.45839E+00,-0.45840E+00,& - -0.45841E+00,-0.45842E+00,-0.45843E+00,-0.45843E+00,-0.45844E+00,& - -0.45845E+00,-0.45846E+00,-0.45847E+00,-0.45848E+00,-0.45850E+00/ - - DATA (BNC03M (IA),IA=601,700)/ & - -0.45855E+00,-0.45858E+00,-0.45858E+00,-0.45856E+00,-0.45852E+00,& - -0.45845E+00,-0.45836E+00,-0.45825E+00,-0.45812E+00,-0.45796E+00,& - -0.45779E+00,-0.45759E+00,-0.45738E+00,-0.45715E+00,-0.45690E+00,& - -0.45663E+00,-0.45634E+00,-0.45604E+00,-0.45573E+00,-0.45539E+00,& - -0.45504E+00,-0.45468E+00,-0.45430E+00,-0.45390E+00,-0.45350E+00,& - -0.45307E+00,-0.45264E+00,-0.45219E+00,-0.45173E+00,-0.45126E+00,& - -0.45077E+00,-0.45027E+00,-0.44976E+00,-0.44924E+00,-0.44871E+00,& - -0.44817E+00,-0.44762E+00,-0.44705E+00,-0.44648E+00,-0.44589E+00,& - -0.44530E+00,-0.44470E+00,-0.44408E+00,-0.44346E+00,-0.44283E+00,& - -0.44219E+00,-0.44154E+00,-0.44088E+00,-0.44022E+00,-0.43954E+00,& - -0.43886E+00,-0.43817E+00,-0.43747E+00,-0.43676E+00,-0.43605E+00,& - -0.43533E+00,-0.43460E+00,-0.43387E+00,-0.43313E+00,-0.43238E+00,& - -0.43162E+00,-0.43086E+00,-0.43009E+00,-0.42932E+00,-0.42854E+00,& - -0.42775E+00,-0.42695E+00,-0.42616E+00,-0.42535E+00,-0.42454E+00,& - -0.42372E+00,-0.42290E+00,-0.42207E+00,-0.42124E+00,-0.42040E+00,& - -0.41956E+00,-0.41871E+00,-0.41786E+00,-0.41700E+00,-0.41613E+00,& - -0.41527E+00,-0.41439E+00,-0.41351E+00,-0.41263E+00,-0.41175E+00,& - -0.41085E+00,-0.40996E+00,-0.40906E+00,-0.40815E+00,-0.40724E+00,& - -0.40633E+00,-0.40542E+00,-0.40449E+00,-0.40357E+00,-0.40264E+00,& - -0.40171E+00,-0.40077E+00,-0.39983E+00,-0.39889E+00,-0.39794E+00/ - - DATA (BNC03M(IA),IA=701,741)/ & - -0.39699E+00,-0.39604E+00,-0.39508E+00,-0.39412E+00,-0.39315E+00,& - -0.39218E+00,-0.39121E+00,-0.39024E+00,-0.38926E+00,-0.38828E+00,& - -0.38729E+00,-0.38630E+00,-0.38531E+00,-0.38432E+00,-0.38332E+00,& - -0.38232E+00,-0.38132E+00,-0.38032E+00,-0.37931E+00,-0.37830E+00,& - -0.37729E+00,-0.37627E+00,-0.37525E+00,-0.37423E+00,-0.37320E+00,& - -0.37218E+00,-0.37115E+00,-0.37012E+00,-0.36908E+00,-0.36804E+00,& - -0.36701E+00,-0.36596E+00,-0.36492E+00,-0.36387E+00,-0.36282E+00,& - -0.36177E+00,-0.36072E+00,-0.35967E+00,-0.35861E+00,-0.35755E+00,& - -0.35649E+00 / -! -! ** (NH4)2SO4 -! - DATA (BNC04M (IA),IA= 1,100)/ & - -0.10031E+00,-0.18257E+00,-0.24033E+00,-0.27955E+00,-0.30969E+00,& - -0.33432E+00,-0.35518E+00,-0.37330E+00,-0.38932E+00,-0.40369E+00,& - -0.41670E+00,-0.42860E+00,-0.43956E+00,-0.44971E+00,-0.45917E+00,& - -0.46801E+00,-0.47632E+00,-0.48414E+00,-0.49154E+00,-0.49856E+00,& - -0.50522E+00,-0.51157E+00,-0.51763E+00,-0.52342E+00,-0.52897E+00,& - -0.53428E+00,-0.53939E+00,-0.54431E+00,-0.54904E+00,-0.55361E+00,& - -0.55801E+00,-0.56226E+00,-0.56638E+00,-0.57036E+00,-0.57421E+00,& - -0.57795E+00,-0.58157E+00,-0.58509E+00,-0.58851E+00,-0.59183E+00,& - -0.59506E+00,-0.59820E+00,-0.60126E+00,-0.60424E+00,-0.60714E+00,& - -0.60997E+00,-0.61273E+00,-0.61542E+00,-0.61805E+00,-0.62062E+00,& - -0.62312E+00,-0.62557E+00,-0.62796E+00,-0.63030E+00,-0.63259E+00,& - -0.63484E+00,-0.63703E+00,-0.63918E+00,-0.64128E+00,-0.64334E+00,& - -0.64536E+00,-0.64734E+00,-0.64928E+00,-0.65119E+00,-0.65306E+00,& - -0.65489E+00,-0.65670E+00,-0.65847E+00,-0.66021E+00,-0.66191E+00,& - -0.66360E+00,-0.66525E+00,-0.66687E+00,-0.66847E+00,-0.67004E+00,& - -0.67159E+00,-0.67312E+00,-0.67462E+00,-0.67610E+00,-0.67756E+00,& - -0.67900E+00,-0.68042E+00,-0.68181E+00,-0.68319E+00,-0.68455E+00,& - -0.68590E+00,-0.68722E+00,-0.68853E+00,-0.68982E+00,-0.69109E+00,& - -0.69235E+00,-0.69360E+00,-0.69483E+00,-0.69604E+00,-0.69724E+00,& - -0.69843E+00,-0.69960E+00,-0.70076E+00,-0.70191E+00,-0.70304E+00/ - - DATA (BNC04M (IA),IA=101,200)/ & - -0.70417E+00,-0.70527E+00,-0.70637E+00,-0.70746E+00,-0.70853E+00,& - -0.70959E+00,-0.71064E+00,-0.71168E+00,-0.71271E+00,-0.71373E+00,& - -0.71473E+00,-0.71573E+00,-0.71672E+00,-0.71769E+00,-0.71866E+00,& - -0.71961E+00,-0.72056E+00,-0.72150E+00,-0.72242E+00,-0.72334E+00,& - -0.72420E+00,-0.72511E+00,-0.72600E+00,-0.72688E+00,-0.72776E+00,& - -0.72862E+00,-0.72948E+00,-0.73033E+00,-0.73116E+00,-0.73199E+00,& - -0.73282E+00,-0.73363E+00,-0.73443E+00,-0.73523E+00,-0.73602E+00,& - -0.73680E+00,-0.73757E+00,-0.73834E+00,-0.73909E+00,-0.73984E+00,& - -0.74059E+00,-0.74132E+00,-0.74205E+00,-0.74277E+00,-0.74348E+00,& - -0.74419E+00,-0.74489E+00,-0.74559E+00,-0.74627E+00,-0.74695E+00,& - -0.74763E+00,-0.74829E+00,-0.74896E+00,-0.74961E+00,-0.75026E+00,& - -0.75090E+00,-0.75154E+00,-0.75217E+00,-0.75280E+00,-0.75342E+00,& - -0.75403E+00,-0.75464E+00,-0.75524E+00,-0.75584E+00,-0.75643E+00,& - -0.75702E+00,-0.75760E+00,-0.75817E+00,-0.75874E+00,-0.75931E+00,& - -0.75987E+00,-0.76042E+00,-0.76098E+00,-0.76152E+00,-0.76206E+00,& - -0.76260E+00,-0.76313E+00,-0.76366E+00,-0.76418E+00,-0.76470E+00,& - -0.76521E+00,-0.76572E+00,-0.76622E+00,-0.76672E+00,-0.76722E+00,& - -0.76771E+00,-0.76820E+00,-0.76868E+00,-0.76916E+00,-0.76963E+00,& - -0.77010E+00,-0.77057E+00,-0.77103E+00,-0.77149E+00,-0.77194E+00,& - -0.77239E+00,-0.77284E+00,-0.77328E+00,-0.77372E+00,-0.77416E+00/ - - DATA (BNC04M (IA),IA=201,300)/ & - -0.77459E+00,-0.77502E+00,-0.77544E+00,-0.77587E+00,-0.77628E+00,& - -0.77670E+00,-0.77711E+00,-0.77751E+00,-0.77792E+00,-0.77832E+00,& - -0.77872E+00,-0.77911E+00,-0.77950E+00,-0.77989E+00,-0.78027E+00,& - -0.78065E+00,-0.78103E+00,-0.78140E+00,-0.78178E+00,-0.78214E+00,& - -0.78251E+00,-0.78287E+00,-0.78323E+00,-0.78359E+00,-0.78394E+00,& - -0.78429E+00,-0.78464E+00,-0.78498E+00,-0.78532E+00,-0.78566E+00,& - -0.78600E+00,-0.78633E+00,-0.78666E+00,-0.78699E+00,-0.78732E+00,& - -0.78764E+00,-0.78796E+00,-0.78827E+00,-0.78859E+00,-0.78890E+00,& - -0.78921E+00,-0.78952E+00,-0.78982E+00,-0.79012E+00,-0.79042E+00,& - -0.79072E+00,-0.79101E+00,-0.79130E+00,-0.79159E+00,-0.79188E+00,& - -0.79216E+00,-0.79245E+00,-0.79273E+00,-0.79300E+00,-0.79328E+00,& - -0.79355E+00,-0.79382E+00,-0.79409E+00,-0.79436E+00,-0.79462E+00,& - -0.79488E+00,-0.79514E+00,-0.79540E+00,-0.79566E+00,-0.79591E+00,& - -0.79616E+00,-0.79641E+00,-0.79666E+00,-0.79690E+00,-0.79714E+00,& - -0.79738E+00,-0.79762E+00,-0.79786E+00,-0.79809E+00,-0.79832E+00,& - -0.79855E+00,-0.79878E+00,-0.79901E+00,-0.79923E+00,-0.79946E+00,& - -0.79968E+00,-0.79990E+00,-0.80011E+00,-0.80033E+00,-0.80054E+00,& - -0.80075E+00,-0.80096E+00,-0.80117E+00,-0.80138E+00,-0.80158E+00,& - -0.80178E+00,-0.80198E+00,-0.80218E+00,-0.80238E+00,-0.80258E+00,& - -0.80277E+00,-0.80296E+00,-0.80315E+00,-0.80334E+00,-0.80353E+00/ - - DATA (BNC04M (IA),IA=301,400)/ & - -0.80371E+00,-0.80390E+00,-0.80408E+00,-0.80426E+00,-0.80444E+00,& - -0.80461E+00,-0.80479E+00,-0.80496E+00,-0.80513E+00,-0.80530E+00,& - -0.80547E+00,-0.80564E+00,-0.80581E+00,-0.80597E+00,-0.80613E+00,& - -0.80630E+00,-0.80646E+00,-0.80661E+00,-0.80677E+00,-0.80693E+00,& - -0.80708E+00,-0.80723E+00,-0.80738E+00,-0.80753E+00,-0.80768E+00,& - -0.80783E+00,-0.80797E+00,-0.80812E+00,-0.80826E+00,-0.80840E+00,& - -0.80854E+00,-0.80868E+00,-0.80881E+00,-0.80895E+00,-0.80908E+00,& - -0.80922E+00,-0.80935E+00,-0.80948E+00,-0.80961E+00,-0.80974E+00,& - -0.80986E+00,-0.80999E+00,-0.81011E+00,-0.81023E+00,-0.81035E+00,& - -0.81047E+00,-0.81059E+00,-0.81071E+00,-0.81082E+00,-0.81094E+00,& - -0.81105E+00,-0.81117E+00,-0.81128E+00,-0.81139E+00,-0.81150E+00,& - -0.81160E+00,-0.81171E+00,-0.81181E+00,-0.81192E+00,-0.81202E+00,& - -0.81212E+00,-0.81222E+00,-0.81232E+00,-0.81242E+00,-0.81252E+00,& - -0.81261E+00,-0.81271E+00,-0.81280E+00,-0.81289E+00,-0.81298E+00,& - -0.81307E+00,-0.81316E+00,-0.81325E+00,-0.81334E+00,-0.81342E+00,& - -0.81351E+00,-0.81359E+00,-0.81368E+00,-0.81376E+00,-0.81384E+00,& - -0.81392E+00,-0.81399E+00,-0.81407E+00,-0.81415E+00,-0.81422E+00,& - -0.81430E+00,-0.81437E+00,-0.81444E+00,-0.81451E+00,-0.81459E+00,& - -0.81465E+00,-0.81472E+00,-0.81479E+00,-0.81486E+00,-0.81492E+00,& - -0.81499E+00,-0.81505E+00,-0.81511E+00,-0.81517E+00,-0.81523E+00/ - - DATA (BNC04M (IA),IA=401,500)/ & - -0.81529E+00,-0.81535E+00,-0.81541E+00,-0.81547E+00,-0.81552E+00,& - -0.81558E+00,-0.81563E+00,-0.81568E+00,-0.81573E+00,-0.81579E+00,& - -0.81584E+00,-0.81589E+00,-0.81593E+00,-0.81598E+00,-0.81603E+00,& - -0.81607E+00,-0.81612E+00,-0.81616E+00,-0.81621E+00,-0.81625E+00,& - -0.81629E+00,-0.81633E+00,-0.81637E+00,-0.81641E+00,-0.81645E+00,& - -0.81648E+00,-0.81652E+00,-0.81656E+00,-0.81659E+00,-0.81662E+00,& - -0.81666E+00,-0.81669E+00,-0.81672E+00,-0.81675E+00,-0.81678E+00,& - -0.81681E+00,-0.81684E+00,-0.81687E+00,-0.81689E+00,-0.81692E+00,& - -0.81694E+00,-0.81697E+00,-0.81699E+00,-0.81701E+00,-0.81704E+00,& - -0.81706E+00,-0.81708E+00,-0.81710E+00,-0.81711E+00,-0.81713E+00,& - -0.81715E+00,-0.81717E+00,-0.81718E+00,-0.81720E+00,-0.81721E+00,& - -0.81723E+00,-0.81724E+00,-0.81725E+00,-0.81726E+00,-0.81727E+00,& - -0.81728E+00,-0.81729E+00,-0.81730E+00,-0.81731E+00,-0.81732E+00,& - -0.81732E+00,-0.81733E+00,-0.81733E+00,-0.81734E+00,-0.81734E+00,& - -0.81734E+00,-0.81735E+00,-0.81735E+00,-0.81735E+00,-0.81735E+00,& - -0.81735E+00,-0.81735E+00,-0.81734E+00,-0.81734E+00,-0.81734E+00,& - -0.81734E+00,-0.81733E+00,-0.81733E+00,-0.81732E+00,-0.81731E+00,& - -0.81731E+00,-0.81730E+00,-0.81729E+00,-0.81728E+00,-0.81727E+00,& - -0.81726E+00,-0.81725E+00,-0.81724E+00,-0.81723E+00,-0.81721E+00,& - -0.81720E+00,-0.81719E+00,-0.81717E+00,-0.81716E+00,-0.81714E+00/ - - DATA (BNC04M (IA),IA=501,600)/ & - -0.81712E+00,-0.81711E+00,-0.81709E+00,-0.81707E+00,-0.81705E+00,& - -0.81703E+00,-0.81701E+00,-0.81699E+00,-0.81697E+00,-0.81695E+00,& - -0.81693E+00,-0.81690E+00,-0.81688E+00,-0.81686E+00,-0.81683E+00,& - -0.81681E+00,-0.81678E+00,-0.81675E+00,-0.81673E+00,-0.81670E+00,& - -0.81667E+00,-0.81664E+00,-0.81661E+00,-0.81658E+00,-0.81655E+00,& - -0.81652E+00,-0.81649E+00,-0.81646E+00,-0.81642E+00,-0.81639E+00,& - -0.81636E+00,-0.81632E+00,-0.81629E+00,-0.81625E+00,-0.81622E+00,& - -0.81618E+00,-0.81614E+00,-0.81611E+00,-0.81607E+00,-0.81603E+00,& - -0.81599E+00,-0.81595E+00,-0.81591E+00,-0.81587E+00,-0.81583E+00,& - -0.81579E+00,-0.81575E+00,-0.81570E+00,-0.81566E+00,-0.81562E+00,& - -0.81557E+00,-0.81553E+00,-0.81548E+00,-0.81544E+00,-0.81539E+00,& - -0.81534E+00,-0.81530E+00,-0.81525E+00,-0.81520E+00,-0.81515E+00,& - -0.81510E+00,-0.81505E+00,-0.81500E+00,-0.81495E+00,-0.81490E+00,& - -0.81485E+00,-0.81480E+00,-0.81475E+00,-0.81469E+00,-0.81464E+00,& - -0.81459E+00,-0.81453E+00,-0.81448E+00,-0.81442E+00,-0.81437E+00,& - -0.81431E+00,-0.81425E+00,-0.81420E+00,-0.81414E+00,-0.81408E+00,& - -0.81402E+00,-0.81396E+00,-0.81391E+00,-0.81385E+00,-0.81379E+00,& - -0.81372E+00,-0.81366E+00,-0.81360E+00,-0.81354E+00,-0.81348E+00,& - -0.81341E+00,-0.81335E+00,-0.81329E+00,-0.81322E+00,-0.81316E+00,& - -0.81309E+00,-0.81303E+00,-0.81296E+00,-0.81290E+00,-0.81264E+00/ - - DATA (BNC04M (IA),IA=601,700)/ & - -0.81207E+00,-0.81133E+00,-0.81056E+00,-0.80975E+00,-0.80890E+00,& - -0.80801E+00,-0.80709E+00,-0.80614E+00,-0.80515E+00,-0.80414E+00,& - -0.80309E+00,-0.80201E+00,-0.80090E+00,-0.79977E+00,-0.79861E+00,& - -0.79742E+00,-0.79620E+00,-0.79496E+00,-0.79370E+00,-0.79241E+00,& - -0.79110E+00,-0.78976E+00,-0.78841E+00,-0.78703E+00,-0.78563E+00,& - -0.78421E+00,-0.78277E+00,-0.78131E+00,-0.77984E+00,-0.77834E+00,& - -0.77683E+00,-0.77529E+00,-0.77374E+00,-0.77218E+00,-0.77060E+00,& - -0.76900E+00,-0.76738E+00,-0.76575E+00,-0.76411E+00,-0.76245E+00,& - -0.76077E+00,-0.75908E+00,-0.75738E+00,-0.75566E+00,-0.75393E+00,& - -0.75219E+00,-0.75044E+00,-0.74867E+00,-0.74689E+00,-0.74510E+00,& - -0.74329E+00,-0.74148E+00,-0.73965E+00,-0.73781E+00,-0.73596E+00,& - -0.73411E+00,-0.73224E+00,-0.73036E+00,-0.72847E+00,-0.72657E+00,& - -0.72466E+00,-0.72274E+00,-0.72081E+00,-0.71887E+00,-0.71692E+00,& - -0.71497E+00,-0.71300E+00,-0.71103E+00,-0.70905E+00,-0.70706E+00,& - -0.70506E+00,-0.70306E+00,-0.70104E+00,-0.69902E+00,-0.69699E+00,& - -0.69496E+00,-0.69291E+00,-0.69086E+00,-0.68880E+00,-0.68674E+00,& - -0.68467E+00,-0.68259E+00,-0.68050E+00,-0.67841E+00,-0.67631E+00,& - -0.67421E+00,-0.67210E+00,-0.66998E+00,-0.66786E+00,-0.66573E+00,& - -0.66359E+00,-0.66145E+00,-0.65930E+00,-0.65715E+00,-0.65499E+00,& - -0.65283E+00,-0.65066E+00,-0.64849E+00,-0.64631E+00,-0.64413E+00/ - - DATA (BNC04M(IA),IA=701,741)/ & - -0.64194E+00,-0.63974E+00,-0.63755E+00,-0.63534E+00,-0.63313E+00,& - -0.63092E+00,-0.62870E+00,-0.62648E+00,-0.62425E+00,-0.62202E+00,& - -0.61979E+00,-0.61755E+00,-0.61530E+00,-0.61305E+00,-0.61080E+00,& - -0.60854E+00,-0.60628E+00,-0.60402E+00,-0.60175E+00,-0.59948E+00,& - -0.59720E+00,-0.59492E+00,-0.59264E+00,-0.59035E+00,-0.58806E+00,& - -0.58576E+00,-0.58346E+00,-0.58116E+00,-0.57886E+00,-0.57655E+00,& - -0.57424E+00,-0.57192E+00,-0.56960E+00,-0.56728E+00,-0.56496E+00,& - -0.56263E+00,-0.56030E+00,-0.55796E+00,-0.55562E+00,-0.55328E+00,& - -0.55094E+00 / -! -! ** NH4NO3 -! - DATA (BNC05M (IA),IA= 1,100)/ & - -0.50742E-01,-0.93469E-01,-0.12433E+00,-0.14581E+00,-0.16269E+00,& - -0.17676E+00,-0.18891E+00,-0.19965E+00,-0.20931E+00,-0.21811E+00,& - -0.22621E+00,-0.23373E+00,-0.24076E+00,-0.24737E+00,-0.25360E+00,& - -0.25952E+00,-0.26514E+00,-0.27051E+00,-0.27565E+00,-0.28058E+00,& - -0.28532E+00,-0.28989E+00,-0.29429E+00,-0.29855E+00,-0.30267E+00,& - -0.30666E+00,-0.31053E+00,-0.31429E+00,-0.31795E+00,-0.32150E+00,& - -0.32497E+00,-0.32834E+00,-0.33163E+00,-0.33484E+00,-0.33797E+00,& - -0.34103E+00,-0.34402E+00,-0.34694E+00,-0.34980E+00,-0.35260E+00,& - -0.35534E+00,-0.35802E+00,-0.36065E+00,-0.36322E+00,-0.36575E+00,& - -0.36823E+00,-0.37065E+00,-0.37304E+00,-0.37538E+00,-0.37767E+00,& - -0.37993E+00,-0.38215E+00,-0.38433E+00,-0.38647E+00,-0.38857E+00,& - -0.39065E+00,-0.39269E+00,-0.39469E+00,-0.39667E+00,-0.39861E+00,& - -0.40053E+00,-0.40242E+00,-0.40429E+00,-0.40613E+00,-0.40794E+00,& - -0.40973E+00,-0.41150E+00,-0.41324E+00,-0.41497E+00,-0.41668E+00,& - -0.41836E+00,-0.42003E+00,-0.42168E+00,-0.42332E+00,-0.42493E+00,& - -0.42654E+00,-0.42812E+00,-0.42970E+00,-0.43126E+00,-0.43281E+00,& - -0.43434E+00,-0.43587E+00,-0.43738E+00,-0.43888E+00,-0.44037E+00,& - -0.44186E+00,-0.44333E+00,-0.44479E+00,-0.44625E+00,-0.44769E+00,& - -0.44913E+00,-0.45056E+00,-0.45198E+00,-0.45339E+00,-0.45480E+00,& - -0.45619E+00,-0.45758E+00,-0.45897E+00,-0.46034E+00,-0.46171E+00/ - - DATA (BNC05M (IA),IA=101,200)/ & - -0.46308E+00,-0.46443E+00,-0.46578E+00,-0.46712E+00,-0.46846E+00,& - -0.46979E+00,-0.47111E+00,-0.47242E+00,-0.47373E+00,-0.47503E+00,& - -0.47633E+00,-0.47761E+00,-0.47889E+00,-0.48017E+00,-0.48144E+00,& - -0.48270E+00,-0.48395E+00,-0.48519E+00,-0.48643E+00,-0.48766E+00,& - -0.48879E+00,-0.49002E+00,-0.49124E+00,-0.49245E+00,-0.49366E+00,& - -0.49486E+00,-0.49605E+00,-0.49723E+00,-0.49840E+00,-0.49957E+00,& - -0.50073E+00,-0.50188E+00,-0.50303E+00,-0.50416E+00,-0.50529E+00,& - -0.50642E+00,-0.50753E+00,-0.50864E+00,-0.50975E+00,-0.51084E+00,& - -0.51193E+00,-0.51301E+00,-0.51409E+00,-0.51516E+00,-0.51622E+00,& - -0.51728E+00,-0.51833E+00,-0.51938E+00,-0.52042E+00,-0.52145E+00,& - -0.52247E+00,-0.52350E+00,-0.52451E+00,-0.52552E+00,-0.52652E+00,& - -0.52752E+00,-0.52851E+00,-0.52950E+00,-0.53048E+00,-0.53145E+00,& - -0.53242E+00,-0.53339E+00,-0.53434E+00,-0.53530E+00,-0.53625E+00,& - -0.53719E+00,-0.53813E+00,-0.53906E+00,-0.53999E+00,-0.54091E+00,& - -0.54183E+00,-0.54274E+00,-0.54365E+00,-0.54455E+00,-0.54545E+00,& - -0.54634E+00,-0.54723E+00,-0.54811E+00,-0.54899E+00,-0.54986E+00,& - -0.55073E+00,-0.55160E+00,-0.55246E+00,-0.55332E+00,-0.55417E+00,& - -0.55502E+00,-0.55586E+00,-0.55670E+00,-0.55753E+00,-0.55836E+00,& - -0.55919E+00,-0.56001E+00,-0.56083E+00,-0.56164E+00,-0.56245E+00,& - -0.56325E+00,-0.56405E+00,-0.56485E+00,-0.56565E+00,-0.56643E+00/ - - DATA (BNC05M (IA),IA=201,300)/ & - -0.56722E+00,-0.56800E+00,-0.56878E+00,-0.56955E+00,-0.57032E+00,& - -0.57109E+00,-0.57185E+00,-0.57261E+00,-0.57336E+00,-0.57411E+00,& - -0.57486E+00,-0.57561E+00,-0.57635E+00,-0.57708E+00,-0.57782E+00,& - -0.57854E+00,-0.57927E+00,-0.57999E+00,-0.58071E+00,-0.58143E+00,& - -0.58214E+00,-0.58285E+00,-0.58356E+00,-0.58426E+00,-0.58496E+00,& - -0.58565E+00,-0.58634E+00,-0.58703E+00,-0.58772E+00,-0.58840E+00,& - -0.58908E+00,-0.58976E+00,-0.59043E+00,-0.59110E+00,-0.59177E+00,& - -0.59243E+00,-0.59309E+00,-0.59375E+00,-0.59441E+00,-0.59506E+00,& - -0.59571E+00,-0.59635E+00,-0.59700E+00,-0.59764E+00,-0.59827E+00,& - -0.59891E+00,-0.59954E+00,-0.60017E+00,-0.60079E+00,-0.60141E+00,& - -0.60203E+00,-0.60265E+00,-0.60327E+00,-0.60388E+00,-0.60449E+00,& - -0.60509E+00,-0.60570E+00,-0.60630E+00,-0.60690E+00,-0.60749E+00,& - -0.60808E+00,-0.60868E+00,-0.60926E+00,-0.60985E+00,-0.61043E+00,& - -0.61101E+00,-0.61159E+00,-0.61216E+00,-0.61274E+00,-0.61331E+00,& - -0.61387E+00,-0.61444E+00,-0.61500E+00,-0.61556E+00,-0.61612E+00,& - -0.61667E+00,-0.61723E+00,-0.61778E+00,-0.61832E+00,-0.61887E+00,& - -0.61941E+00,-0.61995E+00,-0.62049E+00,-0.62103E+00,-0.62156E+00,& - -0.62209E+00,-0.62262E+00,-0.62315E+00,-0.62368E+00,-0.62420E+00,& - -0.62472E+00,-0.62524E+00,-0.62575E+00,-0.62627E+00,-0.62678E+00,& - -0.62729E+00,-0.62780E+00,-0.62830E+00,-0.62880E+00,-0.62931E+00/ - - DATA (BNC05M (IA),IA=301,400)/ & - -0.62980E+00,-0.63030E+00,-0.63080E+00,-0.63129E+00,-0.63178E+00,& - -0.63227E+00,-0.63275E+00,-0.63324E+00,-0.63372E+00,-0.63420E+00,& - -0.63468E+00,-0.63516E+00,-0.63563E+00,-0.63610E+00,-0.63657E+00,& - -0.63704E+00,-0.63751E+00,-0.63797E+00,-0.63844E+00,-0.63890E+00,& - -0.63936E+00,-0.63981E+00,-0.64027E+00,-0.64072E+00,-0.64117E+00,& - -0.64162E+00,-0.64207E+00,-0.64252E+00,-0.64296E+00,-0.64340E+00,& - -0.64385E+00,-0.64428E+00,-0.64472E+00,-0.64516E+00,-0.64559E+00,& - -0.64602E+00,-0.64645E+00,-0.64688E+00,-0.64731E+00,-0.64773E+00,& - -0.64815E+00,-0.64857E+00,-0.64899E+00,-0.64941E+00,-0.64983E+00,& - -0.65024E+00,-0.65066E+00,-0.65107E+00,-0.65148E+00,-0.65188E+00,& - -0.65229E+00,-0.65269E+00,-0.65310E+00,-0.65350E+00,-0.65390E+00,& - -0.65430E+00,-0.65469E+00,-0.65509E+00,-0.65548E+00,-0.65587E+00,& - -0.65626E+00,-0.65665E+00,-0.65704E+00,-0.65742E+00,-0.65781E+00,& - -0.65819E+00,-0.65857E+00,-0.65895E+00,-0.65933E+00,-0.65971E+00,& - -0.66008E+00,-0.66045E+00,-0.66083E+00,-0.66120E+00,-0.66157E+00,& - -0.66193E+00,-0.66230E+00,-0.66266E+00,-0.66303E+00,-0.66339E+00,& - -0.66375E+00,-0.66411E+00,-0.66447E+00,-0.66482E+00,-0.66518E+00,& - -0.66553E+00,-0.66588E+00,-0.66623E+00,-0.66658E+00,-0.66693E+00,& - -0.66727E+00,-0.66762E+00,-0.66796E+00,-0.66831E+00,-0.66865E+00,& - -0.66899E+00,-0.66932E+00,-0.66966E+00,-0.67000E+00,-0.67033E+00/ - - DATA (BNC05M (IA),IA=401,500)/ & - -0.67066E+00,-0.67100E+00,-0.67133E+00,-0.67166E+00,-0.67198E+00,& - -0.67231E+00,-0.67263E+00,-0.67296E+00,-0.67328E+00,-0.67360E+00,& - -0.67392E+00,-0.67424E+00,-0.67456E+00,-0.67488E+00,-0.67519E+00,& - -0.67551E+00,-0.67582E+00,-0.67613E+00,-0.67644E+00,-0.67675E+00,& - -0.67706E+00,-0.67736E+00,-0.67767E+00,-0.67797E+00,-0.67828E+00,& - -0.67858E+00,-0.67888E+00,-0.67918E+00,-0.67948E+00,-0.67977E+00,& - -0.68007E+00,-0.68037E+00,-0.68066E+00,-0.68095E+00,-0.68124E+00,& - -0.68153E+00,-0.68182E+00,-0.68211E+00,-0.68240E+00,-0.68268E+00,& - -0.68297E+00,-0.68325E+00,-0.68353E+00,-0.68382E+00,-0.68410E+00,& - -0.68438E+00,-0.68465E+00,-0.68493E+00,-0.68521E+00,-0.68548E+00,& - -0.68576E+00,-0.68603E+00,-0.68630E+00,-0.68657E+00,-0.68684E+00,& - -0.68711E+00,-0.68738E+00,-0.68764E+00,-0.68791E+00,-0.68817E+00,& - -0.68844E+00,-0.68870E+00,-0.68896E+00,-0.68922E+00,-0.68948E+00,& - -0.68974E+00,-0.69000E+00,-0.69025E+00,-0.69051E+00,-0.69076E+00,& - -0.69102E+00,-0.69127E+00,-0.69152E+00,-0.69177E+00,-0.69202E+00,& - -0.69227E+00,-0.69252E+00,-0.69276E+00,-0.69301E+00,-0.69325E+00,& - -0.69350E+00,-0.69374E+00,-0.69398E+00,-0.69422E+00,-0.69446E+00,& - -0.69470E+00,-0.69494E+00,-0.69517E+00,-0.69541E+00,-0.69565E+00,& - -0.69588E+00,-0.69611E+00,-0.69635E+00,-0.69658E+00,-0.69681E+00,& - -0.69704E+00,-0.69727E+00,-0.69749E+00,-0.69772E+00,-0.69795E+00/ - - DATA (BNC05M (IA),IA=501,600)/ & - -0.69817E+00,-0.69840E+00,-0.69862E+00,-0.69884E+00,-0.69907E+00,& - -0.69929E+00,-0.69951E+00,-0.69973E+00,-0.69994E+00,-0.70016E+00,& - -0.70038E+00,-0.70059E+00,-0.70081E+00,-0.70102E+00,-0.70124E+00,& - -0.70145E+00,-0.70166E+00,-0.70187E+00,-0.70208E+00,-0.70229E+00,& - -0.70250E+00,-0.70271E+00,-0.70291E+00,-0.70312E+00,-0.70332E+00,& - -0.70353E+00,-0.70373E+00,-0.70393E+00,-0.70413E+00,-0.70434E+00,& - -0.70454E+00,-0.70474E+00,-0.70493E+00,-0.70513E+00,-0.70533E+00,& - -0.70552E+00,-0.70572E+00,-0.70592E+00,-0.70611E+00,-0.70630E+00,& - -0.70649E+00,-0.70669E+00,-0.70688E+00,-0.70707E+00,-0.70726E+00,& - -0.70744E+00,-0.70763E+00,-0.70782E+00,-0.70801E+00,-0.70819E+00,& - -0.70838E+00,-0.70856E+00,-0.70874E+00,-0.70893E+00,-0.70911E+00,& - -0.70929E+00,-0.70947E+00,-0.70965E+00,-0.70983E+00,-0.71001E+00,& - -0.71018E+00,-0.71036E+00,-0.71054E+00,-0.71071E+00,-0.71089E+00,& - -0.71106E+00,-0.71123E+00,-0.71141E+00,-0.71158E+00,-0.71175E+00,& - -0.71192E+00,-0.71209E+00,-0.71226E+00,-0.71243E+00,-0.71259E+00,& - -0.71276E+00,-0.71293E+00,-0.71309E+00,-0.71326E+00,-0.71342E+00,& - -0.71359E+00,-0.71375E+00,-0.71391E+00,-0.71407E+00,-0.71423E+00,& - -0.71439E+00,-0.71455E+00,-0.71471E+00,-0.71487E+00,-0.71503E+00,& - -0.71519E+00,-0.71534E+00,-0.71550E+00,-0.71565E+00,-0.71581E+00,& - -0.71596E+00,-0.71611E+00,-0.71627E+00,-0.71642E+00,-0.71698E+00/ - - DATA (BNC05M (IA),IA=601,700)/ & - -0.71819E+00,-0.71960E+00,-0.72096E+00,-0.72225E+00,-0.72349E+00,& - -0.72467E+00,-0.72581E+00,-0.72689E+00,-0.72792E+00,-0.72891E+00,& - -0.72985E+00,-0.73074E+00,-0.73159E+00,-0.73240E+00,-0.73316E+00,& - -0.73389E+00,-0.73457E+00,-0.73522E+00,-0.73583E+00,-0.73640E+00,& - -0.73694E+00,-0.73744E+00,-0.73791E+00,-0.73835E+00,-0.73875E+00,& - -0.73912E+00,-0.73947E+00,-0.73978E+00,-0.74006E+00,-0.74032E+00,& - -0.74055E+00,-0.74075E+00,-0.74093E+00,-0.74107E+00,-0.74120E+00,& - -0.74130E+00,-0.74137E+00,-0.74142E+00,-0.74145E+00,-0.74146E+00,& - -0.74144E+00,-0.74141E+00,-0.74135E+00,-0.74127E+00,-0.74117E+00,& - -0.74105E+00,-0.74092E+00,-0.74076E+00,-0.74058E+00,-0.74039E+00,& - -0.74018E+00,-0.73995E+00,-0.73971E+00,-0.73945E+00,-0.73917E+00,& - -0.73887E+00,-0.73856E+00,-0.73824E+00,-0.73790E+00,-0.73754E+00,& - -0.73717E+00,-0.73679E+00,-0.73639E+00,-0.73598E+00,-0.73555E+00,& - -0.73512E+00,-0.73466E+00,-0.73420E+00,-0.73372E+00,-0.73324E+00,& - -0.73273E+00,-0.73222E+00,-0.73170E+00,-0.73116E+00,-0.73062E+00,& - -0.73006E+00,-0.72949E+00,-0.72891E+00,-0.72832E+00,-0.72772E+00,& - -0.72711E+00,-0.72649E+00,-0.72587E+00,-0.72523E+00,-0.72458E+00,& - -0.72392E+00,-0.72325E+00,-0.72258E+00,-0.72190E+00,-0.72120E+00,& - -0.72050E+00,-0.71979E+00,-0.71908E+00,-0.71835E+00,-0.71762E+00,& - -0.71687E+00,-0.71613E+00,-0.71537E+00,-0.71460E+00,-0.71383E+00/ - - DATA (BNC05M(IA),IA=701,741)/ & - -0.71305E+00,-0.71227E+00,-0.71148E+00,-0.71068E+00,-0.70987E+00,& - -0.70906E+00,-0.70824E+00,-0.70741E+00,-0.70658E+00,-0.70574E+00,& - -0.70490E+00,-0.70404E+00,-0.70319E+00,-0.70232E+00,-0.70146E+00,& - -0.70058E+00,-0.69970E+00,-0.69882E+00,-0.69792E+00,-0.69703E+00,& - -0.69613E+00,-0.69522E+00,-0.69431E+00,-0.69339E+00,-0.69247E+00,& - -0.69154E+00,-0.69061E+00,-0.68967E+00,-0.68873E+00,-0.68778E+00,& - -0.68683E+00,-0.68588E+00,-0.68492E+00,-0.68395E+00,-0.68298E+00,& - -0.68201E+00,-0.68103E+00,-0.68005E+00,-0.67907E+00,-0.67808E+00,& - -0.67708E+00 / -! -! ** NH4Cl -! - DATA (BNC06M (IA),IA= 1,100)/ & - -0.49530E-01,-0.88966E-01,-0.11577E+00,-0.13342E+00,-0.14661E+00,& - -0.15709E+00,-0.16574E+00,-0.17306E+00,-0.17936E+00,-0.18486E+00,& - -0.18971E+00,-0.19402E+00,-0.19789E+00,-0.20137E+00,-0.20452E+00,& - -0.20738E+00,-0.20999E+00,-0.21238E+00,-0.21457E+00,-0.21658E+00,& - -0.21843E+00,-0.22014E+00,-0.22171E+00,-0.22317E+00,-0.22451E+00,& - -0.22576E+00,-0.22692E+00,-0.22799E+00,-0.22898E+00,-0.22990E+00,& - -0.23075E+00,-0.23154E+00,-0.23228E+00,-0.23295E+00,-0.23358E+00,& - -0.23417E+00,-0.23470E+00,-0.23520E+00,-0.23566E+00,-0.23608E+00,& - -0.23647E+00,-0.23683E+00,-0.23716E+00,-0.23746E+00,-0.23773E+00,& - -0.23797E+00,-0.23820E+00,-0.23840E+00,-0.23857E+00,-0.23873E+00,& - -0.23887E+00,-0.23899E+00,-0.23909E+00,-0.23918E+00,-0.23925E+00,& - -0.23930E+00,-0.23934E+00,-0.23936E+00,-0.23937E+00,-0.23936E+00,& - -0.23935E+00,-0.23932E+00,-0.23927E+00,-0.23922E+00,-0.23915E+00,& - -0.23907E+00,-0.23898E+00,-0.23888E+00,-0.23877E+00,-0.23864E+00,& - -0.23851E+00,-0.23836E+00,-0.23821E+00,-0.23804E+00,-0.23787E+00,& - -0.23768E+00,-0.23748E+00,-0.23727E+00,-0.23706E+00,-0.23683E+00,& - -0.23659E+00,-0.23635E+00,-0.23609E+00,-0.23582E+00,-0.23555E+00,& - -0.23526E+00,-0.23497E+00,-0.23466E+00,-0.23435E+00,-0.23403E+00,& - -0.23370E+00,-0.23336E+00,-0.23302E+00,-0.23266E+00,-0.23230E+00,& - -0.23193E+00,-0.23155E+00,-0.23116E+00,-0.23076E+00,-0.23036E+00/ - - DATA (BNC06M (IA),IA=101,200)/ & - -0.22995E+00,-0.22954E+00,-0.22912E+00,-0.22869E+00,-0.22825E+00,& - -0.22781E+00,-0.22737E+00,-0.22692E+00,-0.22646E+00,-0.22600E+00,& - -0.22553E+00,-0.22506E+00,-0.22458E+00,-0.22410E+00,-0.22361E+00,& - -0.22312E+00,-0.22263E+00,-0.22213E+00,-0.22163E+00,-0.22112E+00,& - -0.22068E+00,-0.22017E+00,-0.21964E+00,-0.21912E+00,-0.21859E+00,& - -0.21807E+00,-0.21754E+00,-0.21700E+00,-0.21647E+00,-0.21594E+00,& - -0.21540E+00,-0.21486E+00,-0.21432E+00,-0.21378E+00,-0.21323E+00,& - -0.21269E+00,-0.21214E+00,-0.21159E+00,-0.21104E+00,-0.21049E+00,& - -0.20994E+00,-0.20939E+00,-0.20883E+00,-0.20828E+00,-0.20772E+00,& - -0.20716E+00,-0.20660E+00,-0.20604E+00,-0.20548E+00,-0.20492E+00,& - -0.20435E+00,-0.20379E+00,-0.20322E+00,-0.20266E+00,-0.20209E+00,& - -0.20152E+00,-0.20096E+00,-0.20039E+00,-0.19982E+00,-0.19925E+00,& - -0.19867E+00,-0.19810E+00,-0.19753E+00,-0.19696E+00,-0.19638E+00,& - -0.19581E+00,-0.19523E+00,-0.19466E+00,-0.19408E+00,-0.19351E+00,& - -0.19293E+00,-0.19235E+00,-0.19177E+00,-0.19119E+00,-0.19062E+00,& - -0.19004E+00,-0.18946E+00,-0.18888E+00,-0.18830E+00,-0.18772E+00,& - -0.18714E+00,-0.18656E+00,-0.18597E+00,-0.18539E+00,-0.18481E+00,& - -0.18423E+00,-0.18365E+00,-0.18306E+00,-0.18248E+00,-0.18190E+00,& - -0.18131E+00,-0.18073E+00,-0.18015E+00,-0.17956E+00,-0.17898E+00,& - -0.17840E+00,-0.17781E+00,-0.17723E+00,-0.17665E+00,-0.17606E+00/ - - DATA (BNC06M (IA),IA=201,300)/ & - -0.17548E+00,-0.17489E+00,-0.17431E+00,-0.17372E+00,-0.17314E+00,& - -0.17256E+00,-0.17197E+00,-0.17139E+00,-0.17080E+00,-0.17022E+00,& - -0.16964E+00,-0.16905E+00,-0.16847E+00,-0.16788E+00,-0.16730E+00,& - -0.16672E+00,-0.16613E+00,-0.16555E+00,-0.16496E+00,-0.16438E+00,& - -0.16380E+00,-0.16321E+00,-0.16263E+00,-0.16205E+00,-0.16146E+00,& - -0.16088E+00,-0.16030E+00,-0.15972E+00,-0.15913E+00,-0.15855E+00,& - -0.15797E+00,-0.15739E+00,-0.15681E+00,-0.15622E+00,-0.15564E+00,& - -0.15506E+00,-0.15448E+00,-0.15390E+00,-0.15332E+00,-0.15274E+00,& - -0.15216E+00,-0.15158E+00,-0.15100E+00,-0.15042E+00,-0.14984E+00,& - -0.14926E+00,-0.14868E+00,-0.14810E+00,-0.14752E+00,-0.14695E+00,& - -0.14637E+00,-0.14579E+00,-0.14521E+00,-0.14464E+00,-0.14406E+00,& - -0.14348E+00,-0.14291E+00,-0.14233E+00,-0.14175E+00,-0.14118E+00,& - -0.14060E+00,-0.14003E+00,-0.13945E+00,-0.13888E+00,-0.13831E+00,& - -0.13773E+00,-0.13716E+00,-0.13658E+00,-0.13601E+00,-0.13544E+00,& - -0.13487E+00,-0.13429E+00,-0.13372E+00,-0.13315E+00,-0.13258E+00,& - -0.13201E+00,-0.13144E+00,-0.13087E+00,-0.13030E+00,-0.12973E+00,& - -0.12916E+00,-0.12859E+00,-0.12802E+00,-0.12746E+00,-0.12689E+00,& - -0.12632E+00,-0.12575E+00,-0.12519E+00,-0.12462E+00,-0.12405E+00,& - -0.12349E+00,-0.12292E+00,-0.12236E+00,-0.12179E+00,-0.12123E+00,& - -0.12066E+00,-0.12010E+00,-0.11954E+00,-0.11897E+00,-0.11841E+00/ - - DATA (BNC06M (IA),IA=301,400)/ & - -0.11785E+00,-0.11729E+00,-0.11672E+00,-0.11616E+00,-0.11560E+00,& - -0.11504E+00,-0.11448E+00,-0.11392E+00,-0.11336E+00,-0.11280E+00,& - -0.11224E+00,-0.11169E+00,-0.11113E+00,-0.11057E+00,-0.11001E+00,& - -0.10945E+00,-0.10890E+00,-0.10834E+00,-0.10779E+00,-0.10723E+00,& - -0.10668E+00,-0.10612E+00,-0.10557E+00,-0.10501E+00,-0.10446E+00,& - -0.10391E+00,-0.10335E+00,-0.10280E+00,-0.10225E+00,-0.10170E+00,& - -0.10114E+00,-0.10059E+00,-0.10004E+00,-0.99493E-01,-0.98943E-01,& - -0.98393E-01,-0.97844E-01,-0.97295E-01,-0.96747E-01,-0.96199E-01,& - -0.95651E-01,-0.95104E-01,-0.94557E-01,-0.94010E-01,-0.93464E-01,& - -0.92918E-01,-0.92373E-01,-0.91828E-01,-0.91283E-01,-0.90739E-01,& - -0.90195E-01,-0.89652E-01,-0.89109E-01,-0.88566E-01,-0.88023E-01,& - -0.87481E-01,-0.86940E-01,-0.86399E-01,-0.85858E-01,-0.85317E-01,& - -0.84777E-01,-0.84238E-01,-0.83698E-01,-0.83159E-01,-0.82621E-01,& - -0.82083E-01,-0.81545E-01,-0.81007E-01,-0.80470E-01,-0.79934E-01,& - -0.79397E-01,-0.78861E-01,-0.78326E-01,-0.77791E-01,-0.77256E-01,& - -0.76722E-01,-0.76188E-01,-0.75654E-01,-0.75121E-01,-0.74588E-01,& - -0.74055E-01,-0.73523E-01,-0.72992E-01,-0.72460E-01,-0.71929E-01,& - -0.71399E-01,-0.70868E-01,-0.70339E-01,-0.69809E-01,-0.69280E-01,& - -0.68751E-01,-0.68223E-01,-0.67695E-01,-0.67167E-01,-0.66640E-01,& - -0.66113E-01,-0.65587E-01,-0.65061E-01,-0.64535E-01,-0.64010E-01/ - - DATA (BNC06M (IA),IA=401,500)/ & - -0.63485E-01,-0.62960E-01,-0.62436E-01,-0.61912E-01,-0.61389E-01,& - -0.60866E-01,-0.60343E-01,-0.59821E-01,-0.59299E-01,-0.58777E-01,& - -0.58256E-01,-0.57735E-01,-0.57214E-01,-0.56694E-01,-0.56174E-01,& - -0.55655E-01,-0.55136E-01,-0.54617E-01,-0.54099E-01,-0.53581E-01,& - -0.53064E-01,-0.52547E-01,-0.52030E-01,-0.51513E-01,-0.50997E-01,& - -0.50482E-01,-0.49966E-01,-0.49451E-01,-0.48937E-01,-0.48422E-01,& - -0.47908E-01,-0.47395E-01,-0.46882E-01,-0.46369E-01,-0.45857E-01,& - -0.45345E-01,-0.44833E-01,-0.44321E-01,-0.43811E-01,-0.43300E-01,& - -0.42790E-01,-0.42280E-01,-0.41770E-01,-0.41261E-01,-0.40752E-01,& - -0.40244E-01,-0.39736E-01,-0.39228E-01,-0.38720E-01,-0.38213E-01,& - -0.37707E-01,-0.37200E-01,-0.36694E-01,-0.36189E-01,-0.35684E-01,& - -0.35179E-01,-0.34674E-01,-0.34170E-01,-0.33666E-01,-0.33163E-01,& - -0.32659E-01,-0.32157E-01,-0.31654E-01,-0.31152E-01,-0.30650E-01,& - -0.30149E-01,-0.29648E-01,-0.29147E-01,-0.28647E-01,-0.28147E-01,& - -0.27647E-01,-0.27148E-01,-0.26649E-01,-0.26150E-01,-0.25652E-01,& - -0.25154E-01,-0.24657E-01,-0.24159E-01,-0.23662E-01,-0.23166E-01,& - -0.22670E-01,-0.22174E-01,-0.21678E-01,-0.21183E-01,-0.20688E-01,& - -0.20194E-01,-0.19700E-01,-0.19206E-01,-0.18712E-01,-0.18219E-01,& - -0.17726E-01,-0.17234E-01,-0.16742E-01,-0.16250E-01,-0.15758E-01,& - -0.15267E-01,-0.14777E-01,-0.14286E-01,-0.13796E-01,-0.13306E-01/ - - DATA (BNC06M (IA),IA=501,600)/ & - -0.12817E-01,-0.12328E-01,-0.11839E-01,-0.11350E-01,-0.10862E-01,& - -0.10374E-01,-0.98870E-02,-0.93998E-02,-0.89130E-02,-0.84266E-02,& - -0.79404E-02,-0.74546E-02,-0.69691E-02,-0.64839E-02,-0.59991E-02,& - -0.55146E-02,-0.50304E-02,-0.45465E-02,-0.40630E-02,-0.35797E-02,& - -0.30969E-02,-0.26142E-02,-0.21320E-02,-0.16501E-02,-0.11685E-02,& - -0.68724E-03,-0.20627E-03, 0.27439E-03, 0.75471E-03, 0.12347E-02,& - 0.17144E-02, 0.21938E-02, 0.26728E-02, 0.31515E-02, 0.36300E-02,& - 0.41080E-02, 0.45858E-02, 0.50633E-02, 0.55405E-02, 0.60173E-02,& - 0.64938E-02, 0.69700E-02, 0.74459E-02, 0.79215E-02, 0.83968E-02,& - 0.88718E-02, 0.93464E-02, 0.98208E-02, 0.10295E-01, 0.10768E-01,& - 0.11242E-01, 0.11715E-01, 0.12188E-01, 0.12660E-01, 0.13132E-01,& - 0.13604E-01, 0.14076E-01, 0.14547E-01, 0.15018E-01, 0.15489E-01,& - 0.15959E-01, 0.16429E-01, 0.16899E-01, 0.17368E-01, 0.17837E-01,& - 0.18306E-01, 0.18775E-01, 0.19243E-01, 0.19711E-01, 0.20179E-01,& - 0.20646E-01, 0.21113E-01, 0.21580E-01, 0.22046E-01, 0.22512E-01,& - 0.22978E-01, 0.23444E-01, 0.23909E-01, 0.24374E-01, 0.24838E-01,& - 0.25303E-01, 0.25767E-01, 0.26231E-01, 0.26694E-01, 0.27157E-01,& - 0.27620E-01, 0.28083E-01, 0.28545E-01, 0.29007E-01, 0.29469E-01,& - 0.29930E-01, 0.30391E-01, 0.30852E-01, 0.31313E-01, 0.31773E-01,& - 0.32233E-01, 0.32693E-01, 0.33152E-01, 0.33611E-01, 0.35330E-01/ - - DATA (BNC06M (IA),IA=601,700)/ & - 0.39099E-01, 0.43640E-01, 0.48154E-01, 0.52641E-01, 0.57101E-01,& - 0.61535E-01, 0.65943E-01, 0.70325E-01, 0.74682E-01, 0.79014E-01,& - 0.83322E-01, 0.87606E-01, 0.91866E-01, 0.96102E-01, 0.10032E+00,& - 0.10451E+00, 0.10868E+00, 0.11282E+00, 0.11695E+00, 0.12105E+00,& - 0.12514E+00, 0.12920E+00, 0.13324E+00, 0.13726E+00, 0.14127E+00,& - 0.14525E+00, 0.14921E+00, 0.15316E+00, 0.15709E+00, 0.16099E+00,& - 0.16488E+00, 0.16876E+00, 0.17261E+00, 0.17645E+00, 0.18027E+00,& - 0.18407E+00, 0.18786E+00, 0.19163E+00, 0.19538E+00, 0.19912E+00,& - 0.20284E+00, 0.20655E+00, 0.21024E+00, 0.21391E+00, 0.21757E+00,& - 0.22122E+00, 0.22485E+00, 0.22847E+00, 0.23207E+00, 0.23566E+00,& - 0.23924E+00, 0.24280E+00, 0.24634E+00, 0.24988E+00, 0.25340E+00,& - 0.25691E+00, 0.26040E+00, 0.26389E+00, 0.26735E+00, 0.27081E+00,& - 0.27426E+00, 0.27769E+00, 0.28111E+00, 0.28452E+00, 0.28792E+00,& - 0.29130E+00, 0.29468E+00, 0.29804E+00, 0.30139E+00, 0.30473E+00,& - 0.30806E+00, 0.31138E+00, 0.31469E+00, 0.31799E+00, 0.32127E+00,& - 0.32455E+00, 0.32782E+00, 0.33107E+00, 0.33432E+00, 0.33756E+00,& - 0.34078E+00, 0.34400E+00, 0.34721E+00, 0.35040E+00, 0.35359E+00,& - 0.35677E+00, 0.35994E+00, 0.36310E+00, 0.36625E+00, 0.36940E+00,& - 0.37253E+00, 0.37565E+00, 0.37877E+00, 0.38188E+00, 0.38498E+00,& - 0.38807E+00, 0.39115E+00, 0.39422E+00, 0.39729E+00, 0.40035E+00/ - - DATA (BNC06M(IA),IA=701,741)/ & - 0.40340E+00, 0.40644E+00, 0.40947E+00, 0.41250E+00, 0.41552E+00,& - 0.41853E+00, 0.42153E+00, 0.42453E+00, 0.42752E+00, 0.43050E+00,& - 0.43347E+00, 0.43644E+00, 0.43939E+00, 0.44235E+00, 0.44529E+00,& - 0.44823E+00, 0.45116E+00, 0.45408E+00, 0.45700E+00, 0.45991E+00,& - 0.46281E+00, 0.46571E+00, 0.46860E+00, 0.47148E+00, 0.47436E+00,& - 0.47723E+00, 0.48010E+00, 0.48296E+00, 0.48581E+00, 0.48865E+00,& - 0.49149E+00, 0.49433E+00, 0.49715E+00, 0.49998E+00, 0.50279E+00,& - 0.50560E+00, 0.50840E+00, 0.51120E+00, 0.51399E+00, 0.51678E+00,& - 0.51956E+00 / -! -! ** (2H, SO4) -! - DATA (BNC07M (IA),IA= 1,100)/ & - -0.10013E+00,-0.18189E+00,-0.23903E+00,-0.27766E+00,-0.30724E+00,& - -0.33132E+00,-0.35165E+00,-0.36925E+00,-0.38476E+00,-0.39862E+00,& - -0.41114E+00,-0.42256E+00,-0.43303E+00,-0.44271E+00,-0.45169E+00,& - -0.46007E+00,-0.46792E+00,-0.47529E+00,-0.48224E+00,-0.48881E+00,& - -0.49504E+00,-0.50095E+00,-0.50658E+00,-0.51195E+00,-0.51707E+00,& - -0.52197E+00,-0.52667E+00,-0.53118E+00,-0.53551E+00,-0.53967E+00,& - -0.54368E+00,-0.54754E+00,-0.55127E+00,-0.55486E+00,-0.55834E+00,& - -0.56170E+00,-0.56495E+00,-0.56811E+00,-0.57116E+00,-0.57412E+00,& - -0.57699E+00,-0.57978E+00,-0.58249E+00,-0.58513E+00,-0.58769E+00,& - -0.59018E+00,-0.59261E+00,-0.59497E+00,-0.59727E+00,-0.59951E+00,& - -0.60169E+00,-0.60383E+00,-0.60591E+00,-0.60794E+00,-0.60992E+00,& - -0.61185E+00,-0.61374E+00,-0.61559E+00,-0.61740E+00,-0.61916E+00,& - -0.62089E+00,-0.62258E+00,-0.62424E+00,-0.62586E+00,-0.62744E+00,& - -0.62900E+00,-0.63052E+00,-0.63201E+00,-0.63347E+00,-0.63490E+00,& - -0.63631E+00,-0.63769E+00,-0.63904E+00,-0.64037E+00,-0.64167E+00,& - -0.64295E+00,-0.64420E+00,-0.64544E+00,-0.64665E+00,-0.64784E+00,& - -0.64901E+00,-0.65016E+00,-0.65129E+00,-0.65240E+00,-0.65350E+00,& - -0.65457E+00,-0.65563E+00,-0.65667E+00,-0.65770E+00,-0.65871E+00,& - -0.65970E+00,-0.66068E+00,-0.66164E+00,-0.66259E+00,-0.66352E+00,& - -0.66444E+00,-0.66535E+00,-0.66624E+00,-0.66712E+00,-0.66799E+00/ - - DATA (BNC07M (IA),IA=101,200)/ & - -0.66884E+00,-0.66968E+00,-0.67051E+00,-0.67133E+00,-0.67214E+00,& - -0.67293E+00,-0.67372E+00,-0.67449E+00,-0.67525E+00,-0.67600E+00,& - -0.67674E+00,-0.67748E+00,-0.67820E+00,-0.67891E+00,-0.67961E+00,& - -0.68030E+00,-0.68098E+00,-0.68165E+00,-0.68232E+00,-0.68297E+00,& - -0.68360E+00,-0.68424E+00,-0.68487E+00,-0.68549E+00,-0.68610E+00,& - -0.68671E+00,-0.68731E+00,-0.68789E+00,-0.68848E+00,-0.68905E+00,& - -0.68961E+00,-0.69017E+00,-0.69072E+00,-0.69126E+00,-0.69180E+00,& - -0.69233E+00,-0.69285E+00,-0.69336E+00,-0.69387E+00,-0.69437E+00,& - -0.69487E+00,-0.69536E+00,-0.69584E+00,-0.69631E+00,-0.69678E+00,& - -0.69724E+00,-0.69770E+00,-0.69815E+00,-0.69860E+00,-0.69904E+00,& - -0.69947E+00,-0.69990E+00,-0.70032E+00,-0.70074E+00,-0.70115E+00,& - -0.70156E+00,-0.70196E+00,-0.70235E+00,-0.70274E+00,-0.70313E+00,& - -0.70351E+00,-0.70389E+00,-0.70426E+00,-0.70463E+00,-0.70499E+00,& - -0.70534E+00,-0.70570E+00,-0.70604E+00,-0.70639E+00,-0.70673E+00,& - -0.70706E+00,-0.70739E+00,-0.70772E+00,-0.70804E+00,-0.70836E+00,& - -0.70867E+00,-0.70898E+00,-0.70928E+00,-0.70958E+00,-0.70988E+00,& - -0.71018E+00,-0.71047E+00,-0.71075E+00,-0.71103E+00,-0.71131E+00,& - -0.71159E+00,-0.71186E+00,-0.71213E+00,-0.71239E+00,-0.71265E+00,& - -0.71291E+00,-0.71316E+00,-0.71341E+00,-0.71366E+00,-0.71390E+00,& - -0.71414E+00,-0.71438E+00,-0.71461E+00,-0.71484E+00,-0.71507E+00/ - - DATA (BNC07M (IA),IA=201,300)/ & - -0.71529E+00,-0.71552E+00,-0.71573E+00,-0.71595E+00,-0.71616E+00,& - -0.71637E+00,-0.71658E+00,-0.71678E+00,-0.71698E+00,-0.71718E+00,& - -0.71737E+00,-0.71757E+00,-0.71776E+00,-0.71794E+00,-0.71813E+00,& - -0.71831E+00,-0.71849E+00,-0.71866E+00,-0.71884E+00,-0.71901E+00,& - -0.71918E+00,-0.71934E+00,-0.71950E+00,-0.71967E+00,-0.71982E+00,& - -0.71998E+00,-0.72013E+00,-0.72029E+00,-0.72043E+00,-0.72058E+00,& - -0.72073E+00,-0.72087E+00,-0.72101E+00,-0.72114E+00,-0.72128E+00,& - -0.72141E+00,-0.72154E+00,-0.72167E+00,-0.72180E+00,-0.72192E+00,& - -0.72205E+00,-0.72217E+00,-0.72228E+00,-0.72240E+00,-0.72251E+00,& - -0.72263E+00,-0.72274E+00,-0.72284E+00,-0.72295E+00,-0.72305E+00,& - -0.72316E+00,-0.72326E+00,-0.72335E+00,-0.72345E+00,-0.72355E+00,& - -0.72364E+00,-0.72373E+00,-0.72382E+00,-0.72391E+00,-0.72399E+00,& - -0.72407E+00,-0.72416E+00,-0.72424E+00,-0.72432E+00,-0.72439E+00,& - -0.72447E+00,-0.72454E+00,-0.72461E+00,-0.72468E+00,-0.72475E+00,& - -0.72482E+00,-0.72488E+00,-0.72494E+00,-0.72501E+00,-0.72507E+00,& - -0.72513E+00,-0.72518E+00,-0.72524E+00,-0.72529E+00,-0.72534E+00,& - -0.72539E+00,-0.72544E+00,-0.72549E+00,-0.72554E+00,-0.72558E+00,& - -0.72563E+00,-0.72567E+00,-0.72571E+00,-0.72575E+00,-0.72579E+00,& - -0.72582E+00,-0.72586E+00,-0.72589E+00,-0.72592E+00,-0.72595E+00,& - -0.72598E+00,-0.72601E+00,-0.72604E+00,-0.72606E+00,-0.72609E+00/ - - DATA (BNC07M (IA),IA=301,400)/ & - -0.72611E+00,-0.72613E+00,-0.72615E+00,-0.72617E+00,-0.72619E+00,& - -0.72620E+00,-0.72622E+00,-0.72623E+00,-0.72624E+00,-0.72626E+00,& - -0.72627E+00,-0.72627E+00,-0.72628E+00,-0.72629E+00,-0.72629E+00,& - -0.72630E+00,-0.72630E+00,-0.72630E+00,-0.72630E+00,-0.72630E+00,& - -0.72630E+00,-0.72630E+00,-0.72629E+00,-0.72629E+00,-0.72628E+00,& - -0.72628E+00,-0.72627E+00,-0.72626E+00,-0.72625E+00,-0.72624E+00,& - -0.72622E+00,-0.72621E+00,-0.72619E+00,-0.72618E+00,-0.72616E+00,& - -0.72614E+00,-0.72612E+00,-0.72610E+00,-0.72608E+00,-0.72606E+00,& - -0.72604E+00,-0.72601E+00,-0.72599E+00,-0.72596E+00,-0.72594E+00,& - -0.72591E+00,-0.72588E+00,-0.72585E+00,-0.72582E+00,-0.72579E+00,& - -0.72575E+00,-0.72572E+00,-0.72569E+00,-0.72565E+00,-0.72561E+00,& - -0.72558E+00,-0.72554E+00,-0.72550E+00,-0.72546E+00,-0.72542E+00,& - -0.72538E+00,-0.72533E+00,-0.72529E+00,-0.72524E+00,-0.72520E+00,& - -0.72515E+00,-0.72511E+00,-0.72506E+00,-0.72501E+00,-0.72496E+00,& - -0.72491E+00,-0.72486E+00,-0.72481E+00,-0.72475E+00,-0.72470E+00,& - -0.72464E+00,-0.72459E+00,-0.72453E+00,-0.72448E+00,-0.72442E+00,& - -0.72436E+00,-0.72430E+00,-0.72424E+00,-0.72418E+00,-0.72412E+00,& - -0.72406E+00,-0.72399E+00,-0.72393E+00,-0.72386E+00,-0.72380E+00,& - -0.72373E+00,-0.72367E+00,-0.72360E+00,-0.72353E+00,-0.72346E+00,& - -0.72339E+00,-0.72332E+00,-0.72325E+00,-0.72318E+00,-0.72310E+00/ - - DATA (BNC07M (IA),IA=401,500)/ & - -0.72303E+00,-0.72296E+00,-0.72288E+00,-0.72281E+00,-0.72273E+00,& - -0.72265E+00,-0.72258E+00,-0.72250E+00,-0.72242E+00,-0.72234E+00,& - -0.72226E+00,-0.72218E+00,-0.72210E+00,-0.72201E+00,-0.72193E+00,& - -0.72185E+00,-0.72176E+00,-0.72168E+00,-0.72159E+00,-0.72151E+00,& - -0.72142E+00,-0.72133E+00,-0.72124E+00,-0.72116E+00,-0.72107E+00,& - -0.72098E+00,-0.72089E+00,-0.72080E+00,-0.72070E+00,-0.72061E+00,& - -0.72052E+00,-0.72042E+00,-0.72033E+00,-0.72024E+00,-0.72014E+00,& - -0.72004E+00,-0.71995E+00,-0.71985E+00,-0.71975E+00,-0.71966E+00,& - -0.71956E+00,-0.71946E+00,-0.71936E+00,-0.71926E+00,-0.71916E+00,& - -0.71905E+00,-0.71895E+00,-0.71885E+00,-0.71875E+00,-0.71864E+00,& - -0.71854E+00,-0.71843E+00,-0.71833E+00,-0.71822E+00,-0.71812E+00,& - -0.71801E+00,-0.71790E+00,-0.71779E+00,-0.71768E+00,-0.71758E+00,& - -0.71747E+00,-0.71736E+00,-0.71724E+00,-0.71713E+00,-0.71702E+00,& - -0.71691E+00,-0.71680E+00,-0.71668E+00,-0.71657E+00,-0.71646E+00,& - -0.71634E+00,-0.71623E+00,-0.71611E+00,-0.71599E+00,-0.71588E+00,& - -0.71576E+00,-0.71564E+00,-0.71552E+00,-0.71541E+00,-0.71529E+00,& - -0.71517E+00,-0.71505E+00,-0.71493E+00,-0.71481E+00,-0.71468E+00,& - -0.71456E+00,-0.71444E+00,-0.71432E+00,-0.71419E+00,-0.71407E+00,& - -0.71395E+00,-0.71382E+00,-0.71370E+00,-0.71357E+00,-0.71345E+00,& - -0.71332E+00,-0.71319E+00,-0.71307E+00,-0.71294E+00,-0.71281E+00/ - - DATA (BNC07M (IA),IA=501,600)/ & - -0.71268E+00,-0.71255E+00,-0.71242E+00,-0.71229E+00,-0.71216E+00,& - -0.71203E+00,-0.71190E+00,-0.71177E+00,-0.71164E+00,-0.71150E+00,& - -0.71137E+00,-0.71124E+00,-0.71111E+00,-0.71097E+00,-0.71084E+00,& - -0.71070E+00,-0.71057E+00,-0.71043E+00,-0.71030E+00,-0.71016E+00,& - -0.71002E+00,-0.70988E+00,-0.70975E+00,-0.70961E+00,-0.70947E+00,& - -0.70933E+00,-0.70919E+00,-0.70905E+00,-0.70891E+00,-0.70877E+00,& - -0.70863E+00,-0.70849E+00,-0.70835E+00,-0.70821E+00,-0.70807E+00,& - -0.70792E+00,-0.70778E+00,-0.70764E+00,-0.70749E+00,-0.70735E+00,& - -0.70721E+00,-0.70706E+00,-0.70692E+00,-0.70677E+00,-0.70662E+00,& - -0.70648E+00,-0.70633E+00,-0.70618E+00,-0.70604E+00,-0.70589E+00,& - -0.70574E+00,-0.70559E+00,-0.70544E+00,-0.70530E+00,-0.70515E+00,& - -0.70500E+00,-0.70485E+00,-0.70470E+00,-0.70455E+00,-0.70439E+00,& - -0.70424E+00,-0.70409E+00,-0.70394E+00,-0.70379E+00,-0.70363E+00,& - -0.70348E+00,-0.70333E+00,-0.70317E+00,-0.70302E+00,-0.70287E+00,& - -0.70271E+00,-0.70256E+00,-0.70240E+00,-0.70225E+00,-0.70209E+00,& - -0.70193E+00,-0.70178E+00,-0.70162E+00,-0.70146E+00,-0.70131E+00,& - -0.70115E+00,-0.70099E+00,-0.70083E+00,-0.70067E+00,-0.70051E+00,& - -0.70035E+00,-0.70019E+00,-0.70003E+00,-0.69987E+00,-0.69971E+00,& - -0.69955E+00,-0.69939E+00,-0.69923E+00,-0.69907E+00,-0.69891E+00,& - -0.69874E+00,-0.69858E+00,-0.69842E+00,-0.69826E+00,-0.69764E+00/ - - DATA (BNC07M (IA),IA=601,700)/ & - -0.69627E+00,-0.69459E+00,-0.69289E+00,-0.69115E+00,-0.68939E+00,& - -0.68761E+00,-0.68581E+00,-0.68398E+00,-0.68213E+00,-0.68026E+00,& - -0.67837E+00,-0.67646E+00,-0.67453E+00,-0.67259E+00,-0.67062E+00,& - -0.66864E+00,-0.66664E+00,-0.66463E+00,-0.66260E+00,-0.66055E+00,& - -0.65849E+00,-0.65641E+00,-0.65433E+00,-0.65222E+00,-0.65011E+00,& - -0.64798E+00,-0.64584E+00,-0.64368E+00,-0.64152E+00,-0.63934E+00,& - -0.63715E+00,-0.63495E+00,-0.63274E+00,-0.63052E+00,-0.62829E+00,& - -0.62605E+00,-0.62380E+00,-0.62154E+00,-0.61927E+00,-0.61700E+00,& - -0.61471E+00,-0.61242E+00,-0.61011E+00,-0.60780E+00,-0.60548E+00,& - -0.60316E+00,-0.60082E+00,-0.59848E+00,-0.59613E+00,-0.59378E+00,& - -0.59141E+00,-0.58904E+00,-0.58667E+00,-0.58428E+00,-0.58189E+00,& - -0.57950E+00,-0.57710E+00,-0.57469E+00,-0.57228E+00,-0.56986E+00,& - -0.56743E+00,-0.56500E+00,-0.56257E+00,-0.56013E+00,-0.55768E+00,& - -0.55523E+00,-0.55278E+00,-0.55032E+00,-0.54785E+00,-0.54538E+00,& - -0.54291E+00,-0.54043E+00,-0.53795E+00,-0.53546E+00,-0.53297E+00,& - -0.53047E+00,-0.52797E+00,-0.52547E+00,-0.52296E+00,-0.52045E+00,& - -0.51793E+00,-0.51541E+00,-0.51289E+00,-0.51037E+00,-0.50784E+00,& - -0.50530E+00,-0.50277E+00,-0.50023E+00,-0.49769E+00,-0.49514E+00,& - -0.49259E+00,-0.49004E+00,-0.48749E+00,-0.48493E+00,-0.48237E+00,& - -0.47980E+00,-0.47724E+00,-0.47467E+00,-0.47210E+00,-0.46952E+00/ - - DATA (BNC07M(IA),IA=701,741)/ & - -0.46694E+00,-0.46436E+00,-0.46178E+00,-0.45920E+00,-0.45661E+00,& - -0.45402E+00,-0.45143E+00,-0.44884E+00,-0.44624E+00,-0.44364E+00,& - -0.44104E+00,-0.43844E+00,-0.43583E+00,-0.43322E+00,-0.43062E+00,& - -0.42800E+00,-0.42539E+00,-0.42278E+00,-0.42016E+00,-0.41754E+00,& - -0.41492E+00,-0.41230E+00,-0.40967E+00,-0.40704E+00,-0.40442E+00,& - -0.40179E+00,-0.39916E+00,-0.39652E+00,-0.39389E+00,-0.39125E+00,& - -0.38861E+00,-0.38597E+00,-0.38333E+00,-0.38069E+00,-0.37805E+00,& - -0.37540E+00,-0.37275E+00,-0.37010E+00,-0.36746E+00,-0.36480E+00,& - -0.36215E+00 / -! -! ** (H, HSO4) -! - DATA (BNC08M (IA),IA= 1,100)/ & - -0.47223E-01,-0.81099E-01,-0.10165E+00,-0.11366E+00,-0.12158E+00,& - -0.12700E+00,-0.13074E+00,-0.13324E+00,-0.13478E+00,-0.13555E+00,& - -0.13569E+00,-0.13529E+00,-0.13443E+00,-0.13316E+00,-0.13154E+00,& - -0.12959E+00,-0.12735E+00,-0.12484E+00,-0.12208E+00,-0.11910E+00,& - -0.11591E+00,-0.11252E+00,-0.10894E+00,-0.10519E+00,-0.10128E+00,& - -0.97205E-01,-0.92986E-01,-0.88626E-01,-0.84132E-01,-0.79512E-01,& - -0.74769E-01,-0.69911E-01,-0.64942E-01,-0.59867E-01,-0.54691E-01,& - -0.49419E-01,-0.44054E-01,-0.38600E-01,-0.33062E-01,-0.27442E-01,& - -0.21746E-01,-0.15975E-01,-0.10133E-01,-0.42230E-02, 0.17517E-02,& - 0.77886E-02, 0.13885E-01, 0.20039E-01, 0.26247E-01, 0.32508E-01,& - 0.38819E-01, 0.45178E-01, 0.51584E-01, 0.58035E-01, 0.64529E-01,& - 0.71064E-01, 0.77640E-01, 0.84256E-01, 0.90910E-01, 0.97601E-01,& - 0.10433E+00, 0.11109E+00, 0.11789E+00, 0.12472E+00, 0.13159E+00,& - 0.13850E+00, 0.14543E+00, 0.15240E+00, 0.15941E+00, 0.16645E+00,& - 0.17353E+00, 0.18064E+00, 0.18778E+00, 0.19496E+00, 0.20218E+00,& - 0.20943E+00, 0.21672E+00, 0.22405E+00, 0.23142E+00, 0.23882E+00,& - 0.24627E+00, 0.25375E+00, 0.26127E+00, 0.26883E+00, 0.27643E+00,& - 0.28407E+00, 0.29175E+00, 0.29947E+00, 0.30724E+00, 0.31503E+00,& - 0.32287E+00, 0.33075E+00, 0.33867E+00, 0.34662E+00, 0.35461E+00,& - 0.36263E+00, 0.37069E+00, 0.37878E+00, 0.38691E+00, 0.39507E+00/ - - DATA (BNC08M (IA),IA=101,200)/ & - 0.40325E+00, 0.41147E+00, 0.41972E+00, 0.42799E+00, 0.43628E+00,& - 0.44460E+00, 0.45294E+00, 0.46130E+00, 0.46968E+00, 0.47808E+00,& - 0.48650E+00, 0.49492E+00, 0.50337E+00, 0.51182E+00, 0.52028E+00,& - 0.52875E+00, 0.53723E+00, 0.54572E+00, 0.55421E+00, 0.56270E+00,& - 0.57051E+00, 0.57908E+00, 0.58765E+00, 0.59621E+00, 0.60477E+00,& - 0.61331E+00, 0.62184E+00, 0.63037E+00, 0.63888E+00, 0.64739E+00,& - 0.65588E+00, 0.66436E+00, 0.67283E+00, 0.68130E+00, 0.68975E+00,& - 0.69818E+00, 0.70661E+00, 0.71502E+00, 0.72342E+00, 0.73181E+00,& - 0.74019E+00, 0.74855E+00, 0.75690E+00, 0.76524E+00, 0.77356E+00,& - 0.78187E+00, 0.79017E+00, 0.79845E+00, 0.80672E+00, 0.81497E+00,& - 0.82321E+00, 0.83144E+00, 0.83965E+00, 0.84785E+00, 0.85603E+00,& - 0.86420E+00, 0.87235E+00, 0.88049E+00, 0.88861E+00, 0.89672E+00,& - 0.90481E+00, 0.91289E+00, 0.92095E+00, 0.92900E+00, 0.93703E+00,& - 0.94505E+00, 0.95305E+00, 0.96103E+00, 0.96900E+00, 0.97696E+00,& - 0.98490E+00, 0.99282E+00, 0.10007E+01, 0.10086E+01, 0.10165E+01,& - 0.10244E+01, 0.10322E+01, 0.10400E+01, 0.10478E+01, 0.10556E+01,& - 0.10634E+01, 0.10712E+01, 0.10789E+01, 0.10867E+01, 0.10944E+01,& - 0.11021E+01, 0.11098E+01, 0.11175E+01, 0.11251E+01, 0.11328E+01,& - 0.11404E+01, 0.11480E+01, 0.11556E+01, 0.11632E+01, 0.11707E+01,& - 0.11783E+01, 0.11858E+01, 0.11933E+01, 0.12008E+01, 0.12083E+01/ - - DATA (BNC08M (IA),IA=201,300)/ & - 0.12158E+01, 0.12232E+01, 0.12307E+01, 0.12381E+01, 0.12455E+01,& - 0.12529E+01, 0.12603E+01, 0.12676E+01, 0.12750E+01, 0.12823E+01,& - 0.12896E+01, 0.12969E+01, 0.13042E+01, 0.13115E+01, 0.13187E+01,& - 0.13260E+01, 0.13332E+01, 0.13404E+01, 0.13476E+01, 0.13548E+01,& - 0.13619E+01, 0.13691E+01, 0.13762E+01, 0.13834E+01, 0.13905E+01,& - 0.13975E+01, 0.14046E+01, 0.14117E+01, 0.14187E+01, 0.14258E+01,& - 0.14328E+01, 0.14398E+01, 0.14468E+01, 0.14538E+01, 0.14607E+01,& - 0.14677E+01, 0.14746E+01, 0.14815E+01, 0.14884E+01, 0.14953E+01,& - 0.15022E+01, 0.15091E+01, 0.15159E+01, 0.15228E+01, 0.15296E+01,& - 0.15364E+01, 0.15432E+01, 0.15500E+01, 0.15567E+01, 0.15635E+01,& - 0.15702E+01, 0.15769E+01, 0.15837E+01, 0.15904E+01, 0.15970E+01,& - 0.16037E+01, 0.16104E+01, 0.16170E+01, 0.16237E+01, 0.16303E+01,& - 0.16369E+01, 0.16435E+01, 0.16501E+01, 0.16566E+01, 0.16632E+01,& - 0.16697E+01, 0.16763E+01, 0.16828E+01, 0.16893E+01, 0.16958E+01,& - 0.17022E+01, 0.17087E+01, 0.17152E+01, 0.17216E+01, 0.17280E+01,& - 0.17345E+01, 0.17409E+01, 0.17472E+01, 0.17536E+01, 0.17600E+01,& - 0.17663E+01, 0.17727E+01, 0.17790E+01, 0.17853E+01, 0.17916E+01,& - 0.17979E+01, 0.18042E+01, 0.18105E+01, 0.18167E+01, 0.18230E+01,& - 0.18292E+01, 0.18354E+01, 0.18416E+01, 0.18478E+01, 0.18540E+01,& - 0.18602E+01, 0.18664E+01, 0.18725E+01, 0.18787E+01, 0.18848E+01/ - - DATA (BNC08M (IA),IA=301,400)/ & - 0.18909E+01, 0.18970E+01, 0.19031E+01, 0.19092E+01, 0.19153E+01,& - 0.19213E+01, 0.19274E+01, 0.19334E+01, 0.19394E+01, 0.19455E+01,& - 0.19515E+01, 0.19575E+01, 0.19634E+01, 0.19694E+01, 0.19754E+01,& - 0.19813E+01, 0.19873E+01, 0.19932E+01, 0.19991E+01, 0.20050E+01,& - 0.20109E+01, 0.20168E+01, 0.20227E+01, 0.20286E+01, 0.20344E+01,& - 0.20403E+01, 0.20461E+01, 0.20519E+01, 0.20577E+01, 0.20635E+01,& - 0.20693E+01, 0.20751E+01, 0.20809E+01, 0.20866E+01, 0.20924E+01,& - 0.20981E+01, 0.21039E+01, 0.21096E+01, 0.21153E+01, 0.21210E+01,& - 0.21267E+01, 0.21324E+01, 0.21380E+01, 0.21437E+01, 0.21494E+01,& - 0.21550E+01, 0.21606E+01, 0.21663E+01, 0.21719E+01, 0.21775E+01,& - 0.21831E+01, 0.21887E+01, 0.21942E+01, 0.21998E+01, 0.22054E+01,& - 0.22109E+01, 0.22164E+01, 0.22220E+01, 0.22275E+01, 0.22330E+01,& - 0.22385E+01, 0.22440E+01, 0.22495E+01, 0.22549E+01, 0.22604E+01,& - 0.22658E+01, 0.22713E+01, 0.22767E+01, 0.22822E+01, 0.22876E+01,& - 0.22930E+01, 0.22984E+01, 0.23038E+01, 0.23092E+01, 0.23145E+01,& - 0.23199E+01, 0.23252E+01, 0.23306E+01, 0.23359E+01, 0.23413E+01,& - 0.23466E+01, 0.23519E+01, 0.23572E+01, 0.23625E+01, 0.23678E+01,& - 0.23730E+01, 0.23783E+01, 0.23836E+01, 0.23888E+01, 0.23941E+01,& - 0.23993E+01, 0.24045E+01, 0.24097E+01, 0.24150E+01, 0.24202E+01,& - 0.24254E+01, 0.24305E+01, 0.24357E+01, 0.24409E+01, 0.24460E+01/ - - DATA (BNC08M (IA),IA=401,500)/ & - 0.24512E+01, 0.24563E+01, 0.24615E+01, 0.24666E+01, 0.24717E+01,& - 0.24768E+01, 0.24819E+01, 0.24870E+01, 0.24921E+01, 0.24972E+01,& - 0.25023E+01, 0.25073E+01, 0.25124E+01, 0.25174E+01, 0.25225E+01,& - 0.25275E+01, 0.25325E+01, 0.25375E+01, 0.25426E+01, 0.25476E+01,& - 0.25526E+01, 0.25575E+01, 0.25625E+01, 0.25675E+01, 0.25725E+01,& - 0.25774E+01, 0.25824E+01, 0.25873E+01, 0.25922E+01, 0.25972E+01,& - 0.26021E+01, 0.26070E+01, 0.26119E+01, 0.26168E+01, 0.26217E+01,& - 0.26266E+01, 0.26314E+01, 0.26363E+01, 0.26412E+01, 0.26460E+01,& - 0.26509E+01, 0.26557E+01, 0.26605E+01, 0.26653E+01, 0.26702E+01,& - 0.26750E+01, 0.26798E+01, 0.26846E+01, 0.26894E+01, 0.26941E+01,& - 0.26989E+01, 0.27037E+01, 0.27084E+01, 0.27132E+01, 0.27179E+01,& - 0.27227E+01, 0.27274E+01, 0.27321E+01, 0.27369E+01, 0.27416E+01,& - 0.27463E+01, 0.27510E+01, 0.27557E+01, 0.27604E+01, 0.27650E+01,& - 0.27697E+01, 0.27744E+01, 0.27790E+01, 0.27837E+01, 0.27883E+01,& - 0.27930E+01, 0.27976E+01, 0.28022E+01, 0.28068E+01, 0.28115E+01,& - 0.28161E+01, 0.28207E+01, 0.28253E+01, 0.28298E+01, 0.28344E+01,& - 0.28390E+01, 0.28436E+01, 0.28481E+01, 0.28527E+01, 0.28572E+01,& - 0.28618E+01, 0.28663E+01, 0.28708E+01, 0.28754E+01, 0.28799E+01,& - 0.28844E+01, 0.28889E+01, 0.28934E+01, 0.28979E+01, 0.29024E+01,& - 0.29068E+01, 0.29113E+01, 0.29158E+01, 0.29203E+01, 0.29247E+01/ - - DATA (BNC08M (IA),IA=501,600)/ & - 0.29292E+01, 0.29336E+01, 0.29380E+01, 0.29425E+01, 0.29469E+01,& - 0.29513E+01, 0.29557E+01, 0.29601E+01, 0.29645E+01, 0.29689E+01,& - 0.29733E+01, 0.29777E+01, 0.29821E+01, 0.29865E+01, 0.29908E+01,& - 0.29952E+01, 0.29995E+01, 0.30039E+01, 0.30082E+01, 0.30126E+01,& - 0.30169E+01, 0.30212E+01, 0.30255E+01, 0.30299E+01, 0.30342E+01,& - 0.30385E+01, 0.30428E+01, 0.30471E+01, 0.30514E+01, 0.30556E+01,& - 0.30599E+01, 0.30642E+01, 0.30684E+01, 0.30727E+01, 0.30770E+01,& - 0.30812E+01, 0.30854E+01, 0.30897E+01, 0.30939E+01, 0.30981E+01,& - 0.31024E+01, 0.31066E+01, 0.31108E+01, 0.31150E+01, 0.31192E+01,& - 0.31234E+01, 0.31276E+01, 0.31317E+01, 0.31359E+01, 0.31401E+01,& - 0.31443E+01, 0.31484E+01, 0.31526E+01, 0.31567E+01, 0.31609E+01,& - 0.31650E+01, 0.31692E+01, 0.31733E+01, 0.31774E+01, 0.31815E+01,& - 0.31856E+01, 0.31898E+01, 0.31939E+01, 0.31980E+01, 0.32021E+01,& - 0.32061E+01, 0.32102E+01, 0.32143E+01, 0.32184E+01, 0.32224E+01,& - 0.32265E+01, 0.32306E+01, 0.32346E+01, 0.32387E+01, 0.32427E+01,& - 0.32468E+01, 0.32508E+01, 0.32548E+01, 0.32588E+01, 0.32629E+01,& - 0.32669E+01, 0.32709E+01, 0.32749E+01, 0.32789E+01, 0.32829E+01,& - 0.32869E+01, 0.32909E+01, 0.32948E+01, 0.32988E+01, 0.33028E+01,& - 0.33068E+01, 0.33107E+01, 0.33147E+01, 0.33186E+01, 0.33226E+01,& - 0.33265E+01, 0.33304E+01, 0.33344E+01, 0.33383E+01, 0.33530E+01/ - - DATA (BNC08M (IA),IA=601,700)/ & - 0.33851E+01, 0.34236E+01, 0.34616E+01, 0.34992E+01, 0.35364E+01,& - 0.35732E+01, 0.36095E+01, 0.36455E+01, 0.36811E+01, 0.37163E+01,& - 0.37511E+01, 0.37856E+01, 0.38198E+01, 0.38535E+01, 0.38870E+01,& - 0.39201E+01, 0.39529E+01, 0.39854E+01, 0.40175E+01, 0.40494E+01,& - 0.40809E+01, 0.41122E+01, 0.41432E+01, 0.41738E+01, 0.42043E+01,& - 0.42344E+01, 0.42643E+01, 0.42939E+01, 0.43232E+01, 0.43523E+01,& - 0.43812E+01, 0.44098E+01, 0.44382E+01, 0.44663E+01, 0.44942E+01,& - 0.45219E+01, 0.45494E+01, 0.45766E+01, 0.46036E+01, 0.46304E+01,& - 0.46570E+01, 0.46834E+01, 0.47096E+01, 0.47356E+01, 0.47614E+01,& - 0.47870E+01, 0.48124E+01, 0.48377E+01, 0.48627E+01, 0.48876E+01,& - 0.49122E+01, 0.49368E+01, 0.49611E+01, 0.49853E+01, 0.50093E+01,& - 0.50331E+01, 0.50568E+01, 0.50803E+01, 0.51036E+01, 0.51268E+01,& - 0.51499E+01, 0.51728E+01, 0.51955E+01, 0.52181E+01, 0.52406E+01,& - 0.52629E+01, 0.52850E+01, 0.53071E+01, 0.53290E+01, 0.53507E+01,& - 0.53723E+01, 0.53938E+01, 0.54152E+01, 0.54364E+01, 0.54575E+01,& - 0.54785E+01, 0.54993E+01, 0.55200E+01, 0.55406E+01, 0.55611E+01,& - 0.55815E+01, 0.56017E+01, 0.56219E+01, 0.56419E+01, 0.56618E+01,& - 0.56816E+01, 0.57013E+01, 0.57209E+01, 0.57404E+01, 0.57597E+01,& - 0.57790E+01, 0.57982E+01, 0.58172E+01, 0.58362E+01, 0.58550E+01,& - 0.58738E+01, 0.58925E+01, 0.59110E+01, 0.59295E+01, 0.59479E+01/ - - DATA (BNC08M(IA),IA=701,741)/ & - 0.59661E+01, 0.59843E+01, 0.60024E+01, 0.60204E+01, 0.60384E+01,& - 0.60562E+01, 0.60739E+01, 0.60916E+01, 0.61091E+01, 0.61266E+01,& - 0.61440E+01, 0.61614E+01, 0.61786E+01, 0.61957E+01, 0.62128E+01,& - 0.62298E+01, 0.62467E+01, 0.62636E+01, 0.62803E+01, 0.62970E+01,& - 0.63136E+01, 0.63301E+01, 0.63466E+01, 0.63630E+01, 0.63793E+01,& - 0.63955E+01, 0.64117E+01, 0.64278E+01, 0.64438E+01, 0.64598E+01,& - 0.64757E+01, 0.64915E+01, 0.65073E+01, 0.65229E+01, 0.65386E+01,& - 0.65541E+01, 0.65696E+01, 0.65850E+01, 0.66004E+01, 0.66157E+01,& - 0.66309E+01 / -! -! ** NH4HSO4 -! - DATA (BNC09M (IA),IA= 1,100)/ & - -0.49220E-01,-0.88125E-01,-0.11455E+00,-0.13197E+00,-0.14502E+00,& - -0.15542E+00,-0.16401E+00,-0.17127E+00,-0.17752E+00,-0.18296E+00,& - -0.18774E+00,-0.19197E+00,-0.19572E+00,-0.19907E+00,-0.20206E+00,& - -0.20473E+00,-0.20712E+00,-0.20925E+00,-0.21115E+00,-0.21284E+00,& - -0.21433E+00,-0.21563E+00,-0.21677E+00,-0.21775E+00,-0.21858E+00,& - -0.21927E+00,-0.21983E+00,-0.22027E+00,-0.22058E+00,-0.22079E+00,& - -0.22089E+00,-0.22088E+00,-0.22078E+00,-0.22058E+00,-0.22030E+00,& - -0.21992E+00,-0.21947E+00,-0.21894E+00,-0.21833E+00,-0.21764E+00,& - -0.21689E+00,-0.21607E+00,-0.21519E+00,-0.21424E+00,-0.21323E+00,& - -0.21216E+00,-0.21104E+00,-0.20986E+00,-0.20863E+00,-0.20735E+00,& - -0.20602E+00,-0.20464E+00,-0.20322E+00,-0.20175E+00,-0.20025E+00,& - -0.19870E+00,-0.19711E+00,-0.19548E+00,-0.19382E+00,-0.19212E+00,& - -0.19038E+00,-0.18862E+00,-0.18681E+00,-0.18498E+00,-0.18311E+00,& - -0.18122E+00,-0.17929E+00,-0.17734E+00,-0.17536E+00,-0.17334E+00,& - -0.17131E+00,-0.16924E+00,-0.16715E+00,-0.16503E+00,-0.16289E+00,& - -0.16072E+00,-0.15853E+00,-0.15631E+00,-0.15406E+00,-0.15180E+00,& - -0.14951E+00,-0.14719E+00,-0.14486E+00,-0.14250E+00,-0.14011E+00,& - -0.13771E+00,-0.13528E+00,-0.13283E+00,-0.13036E+00,-0.12787E+00,& - -0.12536E+00,-0.12283E+00,-0.12028E+00,-0.11771E+00,-0.11512E+00,& - -0.11251E+00,-0.10988E+00,-0.10724E+00,-0.10458E+00,-0.10191E+00/ - - DATA (BNC09M (IA),IA=101,200)/ & - -0.99221E-01,-0.96517E-01,-0.93798E-01,-0.91067E-01,-0.88323E-01,& - -0.85567E-01,-0.82800E-01,-0.80022E-01,-0.77234E-01,-0.74437E-01,& - -0.71631E-01,-0.68817E-01,-0.65996E-01,-0.63168E-01,-0.60334E-01,& - -0.57495E-01,-0.54651E-01,-0.51802E-01,-0.48950E-01,-0.46094E-01,& - -0.43478E-01,-0.40589E-01,-0.37702E-01,-0.34815E-01,-0.31930E-01,& - -0.29047E-01,-0.26165E-01,-0.23286E-01,-0.20408E-01,-0.17533E-01,& - -0.14660E-01,-0.11790E-01,-0.89226E-02,-0.60582E-02,-0.31967E-02,& - -0.33866E-03, 0.25164E-02, 0.53678E-02, 0.82159E-02, 0.11060E-01,& - 0.13901E-01, 0.16738E-01, 0.19571E-01, 0.22399E-01, 0.25224E-01,& - 0.28045E-01, 0.30861E-01, 0.33673E-01, 0.36481E-01, 0.39284E-01,& - 0.42083E-01, 0.44877E-01, 0.47667E-01, 0.50452E-01, 0.53232E-01,& - 0.56007E-01, 0.58778E-01, 0.61543E-01, 0.64304E-01, 0.67060E-01,& - 0.69811E-01, 0.72557E-01, 0.75298E-01, 0.78034E-01, 0.80765E-01,& - 0.83490E-01, 0.86211E-01, 0.88926E-01, 0.91637E-01, 0.94342E-01,& - 0.97042E-01, 0.99736E-01, 0.10243E+00, 0.10511E+00, 0.10779E+00,& - 0.11046E+00, 0.11313E+00, 0.11579E+00, 0.11845E+00, 0.12111E+00,& - 0.12375E+00, 0.12639E+00, 0.12903E+00, 0.13166E+00, 0.13429E+00,& - 0.13691E+00, 0.13953E+00, 0.14214E+00, 0.14474E+00, 0.14734E+00,& - 0.14994E+00, 0.15253E+00, 0.15511E+00, 0.15769E+00, 0.16026E+00,& - 0.16283E+00, 0.16540E+00, 0.16795E+00, 0.17051E+00, 0.17305E+00/ - - DATA (BNC09M (IA),IA=201,300)/ & - 0.17560E+00, 0.17814E+00, 0.18067E+00, 0.18319E+00, 0.18572E+00,& - 0.18823E+00, 0.19075E+00, 0.19325E+00, 0.19575E+00, 0.19825E+00,& - 0.20074E+00, 0.20323E+00, 0.20571E+00, 0.20819E+00, 0.21066E+00,& - 0.21313E+00, 0.21559E+00, 0.21805E+00, 0.22050E+00, 0.22294E+00,& - 0.22539E+00, 0.22782E+00, 0.23026E+00, 0.23268E+00, 0.23511E+00,& - 0.23752E+00, 0.23994E+00, 0.24235E+00, 0.24475E+00, 0.24715E+00,& - 0.24954E+00, 0.25193E+00, 0.25432E+00, 0.25670E+00, 0.25907E+00,& - 0.26144E+00, 0.26381E+00, 0.26617E+00, 0.26853E+00, 0.27088E+00,& - 0.27323E+00, 0.27557E+00, 0.27791E+00, 0.28024E+00, 0.28257E+00,& - 0.28490E+00, 0.28722E+00, 0.28954E+00, 0.29185E+00, 0.29416E+00,& - 0.29646E+00, 0.29876E+00, 0.30105E+00, 0.30334E+00, 0.30563E+00,& - 0.30791E+00, 0.31019E+00, 0.31246E+00, 0.31473E+00, 0.31699E+00,& - 0.31925E+00, 0.32151E+00, 0.32376E+00, 0.32601E+00, 0.32825E+00,& - 0.33049E+00, 0.33273E+00, 0.33496E+00, 0.33718E+00, 0.33941E+00,& - 0.34162E+00, 0.34384E+00, 0.34605E+00, 0.34826E+00, 0.35046E+00,& - 0.35266E+00, 0.35485E+00, 0.35704E+00, 0.35923E+00, 0.36141E+00,& - 0.36359E+00, 0.36577E+00, 0.36794E+00, 0.37010E+00, 0.37227E+00,& - 0.37443E+00, 0.37658E+00, 0.37874E+00, 0.38088E+00, 0.38303E+00,& - 0.38517E+00, 0.38731E+00, 0.38944E+00, 0.39157E+00, 0.39369E+00,& - 0.39582E+00, 0.39793E+00, 0.40005E+00, 0.40216E+00, 0.40427E+00/ - - DATA (BNC09M (IA),IA=301,400)/ & - 0.40637E+00, 0.40847E+00, 0.41057E+00, 0.41266E+00, 0.41475E+00,& - 0.41684E+00, 0.41892E+00, 0.42100E+00, 0.42307E+00, 0.42514E+00,& - 0.42721E+00, 0.42928E+00, 0.43134E+00, 0.43339E+00, 0.43545E+00,& - 0.43750E+00, 0.43955E+00, 0.44159E+00, 0.44363E+00, 0.44567E+00,& - 0.44770E+00, 0.44973E+00, 0.45176E+00, 0.45378E+00, 0.45581E+00,& - 0.45782E+00, 0.45984E+00, 0.46185E+00, 0.46385E+00, 0.46586E+00,& - 0.46786E+00, 0.46986E+00, 0.47185E+00, 0.47384E+00, 0.47583E+00,& - 0.47782E+00, 0.47980E+00, 0.48178E+00, 0.48375E+00, 0.48572E+00,& - 0.48769E+00, 0.48966E+00, 0.49162E+00, 0.49358E+00, 0.49554E+00,& - 0.49749E+00, 0.49944E+00, 0.50139E+00, 0.50333E+00, 0.50528E+00,& - 0.50721E+00, 0.50915E+00, 0.51108E+00, 0.51301E+00, 0.51494E+00,& - 0.51686E+00, 0.51878E+00, 0.52070E+00, 0.52261E+00, 0.52453E+00,& - 0.52643E+00, 0.52834E+00, 0.53024E+00, 0.53214E+00, 0.53404E+00,& - 0.53593E+00, 0.53782E+00, 0.53971E+00, 0.54160E+00, 0.54348E+00,& - 0.54536E+00, 0.54724E+00, 0.54911E+00, 0.55099E+00, 0.55285E+00,& - 0.55472E+00, 0.55658E+00, 0.55844E+00, 0.56030E+00, 0.56216E+00,& - 0.56401E+00, 0.56586E+00, 0.56770E+00, 0.56955E+00, 0.57139E+00,& - 0.57323E+00, 0.57507E+00, 0.57690E+00, 0.57873E+00, 0.58056E+00,& - 0.58238E+00, 0.58421E+00, 0.58603E+00, 0.58784E+00, 0.58966E+00,& - 0.59147E+00, 0.59328E+00, 0.59509E+00, 0.59689E+00, 0.59869E+00/ - - DATA (BNC09M (IA),IA=401,500)/ & - 0.60049E+00, 0.60229E+00, 0.60408E+00, 0.60588E+00, 0.60766E+00,& - 0.60945E+00, 0.61124E+00, 0.61302E+00, 0.61480E+00, 0.61657E+00,& - 0.61835E+00, 0.62012E+00, 0.62189E+00, 0.62366E+00, 0.62542E+00,& - 0.62718E+00, 0.62894E+00, 0.63070E+00, 0.63245E+00, 0.63421E+00,& - 0.63596E+00, 0.63770E+00, 0.63945E+00, 0.64119E+00, 0.64293E+00,& - 0.64467E+00, 0.64640E+00, 0.64814E+00, 0.64987E+00, 0.65160E+00,& - 0.65332E+00, 0.65505E+00, 0.65677E+00, 0.65849E+00, 0.66020E+00,& - 0.66192E+00, 0.66363E+00, 0.66534E+00, 0.66705E+00, 0.66875E+00,& - 0.67046E+00, 0.67216E+00, 0.67386E+00, 0.67555E+00, 0.67725E+00,& - 0.67894E+00, 0.68063E+00, 0.68232E+00, 0.68400E+00, 0.68568E+00,& - 0.68737E+00, 0.68904E+00, 0.69072E+00, 0.69240E+00, 0.69407E+00,& - 0.69574E+00, 0.69741E+00, 0.69907E+00, 0.70073E+00, 0.70240E+00,& - 0.70405E+00, 0.70571E+00, 0.70737E+00, 0.70902E+00, 0.71067E+00,& - 0.71232E+00, 0.71397E+00, 0.71561E+00, 0.71725E+00, 0.71889E+00,& - 0.72053E+00, 0.72217E+00, 0.72380E+00, 0.72543E+00, 0.72706E+00,& - 0.72869E+00, 0.73032E+00, 0.73194E+00, 0.73356E+00, 0.73518E+00,& - 0.73680E+00, 0.73842E+00, 0.74003E+00, 0.74164E+00, 0.74325E+00,& - 0.74486E+00, 0.74646E+00, 0.74807E+00, 0.74967E+00, 0.75127E+00,& - 0.75287E+00, 0.75446E+00, 0.75606E+00, 0.75765E+00, 0.75924E+00,& - 0.76083E+00, 0.76241E+00, 0.76400E+00, 0.76558E+00, 0.76716E+00/ - - DATA (BNC09M (IA),IA=501,600)/ & - 0.76874E+00, 0.77032E+00, 0.77189E+00, 0.77346E+00, 0.77503E+00,& - 0.77660E+00, 0.77817E+00, 0.77973E+00, 0.78130E+00, 0.78286E+00,& - 0.78442E+00, 0.78598E+00, 0.78753E+00, 0.78909E+00, 0.79064E+00,& - 0.79219E+00, 0.79374E+00, 0.79529E+00, 0.79683E+00, 0.79837E+00,& - 0.79991E+00, 0.80145E+00, 0.80299E+00, 0.80453E+00, 0.80606E+00,& - 0.80759E+00, 0.80912E+00, 0.81065E+00, 0.81218E+00, 0.81371E+00,& - 0.81523E+00, 0.81675E+00, 0.81827E+00, 0.81979E+00, 0.82131E+00,& - 0.82282E+00, 0.82433E+00, 0.82584E+00, 0.82735E+00, 0.82886E+00,& - 0.83037E+00, 0.83187E+00, 0.83337E+00, 0.83487E+00, 0.83637E+00,& - 0.83787E+00, 0.83937E+00, 0.84086E+00, 0.84235E+00, 0.84384E+00,& - 0.84533E+00, 0.84682E+00, 0.84831E+00, 0.84979E+00, 0.85127E+00,& - 0.85275E+00, 0.85423E+00, 0.85571E+00, 0.85719E+00, 0.85866E+00,& - 0.86013E+00, 0.86160E+00, 0.86307E+00, 0.86454E+00, 0.86601E+00,& - 0.86747E+00, 0.86893E+00, 0.87039E+00, 0.87185E+00, 0.87331E+00,& - 0.87477E+00, 0.87622E+00, 0.87768E+00, 0.87913E+00, 0.88058E+00,& - 0.88203E+00, 0.88347E+00, 0.88492E+00, 0.88636E+00, 0.88780E+00,& - 0.88924E+00, 0.89068E+00, 0.89212E+00, 0.89356E+00, 0.89499E+00,& - 0.89642E+00, 0.89786E+00, 0.89929E+00, 0.90071E+00, 0.90214E+00,& - 0.90357E+00, 0.90499E+00, 0.90641E+00, 0.90783E+00, 0.90925E+00,& - 0.91067E+00, 0.91209E+00, 0.91350E+00, 0.91491E+00, 0.92020E+00/ - - DATA (BNC09M (IA),IA=601,700)/ & - 0.93176E+00, 0.94563E+00, 0.95937E+00, 0.97296E+00, 0.98643E+00,& - 0.99976E+00, 0.10130E+01, 0.10260E+01, 0.10390E+01, 0.10518E+01,& - 0.10645E+01, 0.10771E+01, 0.10896E+01, 0.11020E+01, 0.11142E+01,& - 0.11264E+01, 0.11384E+01, 0.11504E+01, 0.11622E+01, 0.11740E+01,& - 0.11856E+01, 0.11972E+01, 0.12086E+01, 0.12200E+01, 0.12313E+01,& - 0.12425E+01, 0.12536E+01, 0.12646E+01, 0.12755E+01, 0.12864E+01,& - 0.12971E+01, 0.13078E+01, 0.13184E+01, 0.13290E+01, 0.13394E+01,& - 0.13498E+01, 0.13601E+01, 0.13704E+01, 0.13805E+01, 0.13906E+01,& - 0.14006E+01, 0.14106E+01, 0.14205E+01, 0.14303E+01, 0.14401E+01,& - 0.14498E+01, 0.14594E+01, 0.14690E+01, 0.14785E+01, 0.14880E+01,& - 0.14974E+01, 0.15067E+01, 0.15160E+01, 0.15252E+01, 0.15344E+01,& - 0.15435E+01, 0.15526E+01, 0.15616E+01, 0.15706E+01, 0.15795E+01,& - 0.15883E+01, 0.15971E+01, 0.16059E+01, 0.16146E+01, 0.16233E+01,& - 0.16319E+01, 0.16404E+01, 0.16489E+01, 0.16574E+01, 0.16658E+01,& - 0.16742E+01, 0.16825E+01, 0.16908E+01, 0.16991E+01, 0.17073E+01,& - 0.17155E+01, 0.17236E+01, 0.17317E+01, 0.17397E+01, 0.17477E+01,& - 0.17557E+01, 0.17636E+01, 0.17715E+01, 0.17793E+01, 0.17871E+01,& - 0.17949E+01, 0.18026E+01, 0.18103E+01, 0.18180E+01, 0.18256E+01,& - 0.18332E+01, 0.18408E+01, 0.18483E+01, 0.18558E+01, 0.18632E+01,& - 0.18707E+01, 0.18780E+01, 0.18854E+01, 0.18927E+01, 0.19000E+01/ - - DATA (BNC09M(IA),IA=701,741)/ & - 0.19073E+01, 0.19145E+01, 0.19217E+01, 0.19289E+01, 0.19360E+01,& - 0.19431E+01, 0.19502E+01, 0.19572E+01, 0.19643E+01, 0.19713E+01,& - 0.19782E+01, 0.19852E+01, 0.19921E+01, 0.19989E+01, 0.20058E+01,& - 0.20126E+01, 0.20194E+01, 0.20262E+01, 0.20329E+01, 0.20397E+01,& - 0.20464E+01, 0.20530E+01, 0.20597E+01, 0.20663E+01, 0.20729E+01,& - 0.20794E+01, 0.20860E+01, 0.20925E+01, 0.20990E+01, 0.21055E+01,& - 0.21119E+01, 0.21184E+01, 0.21248E+01, 0.21311E+01, 0.21375E+01,& - 0.21438E+01, 0.21502E+01, 0.21564E+01, 0.21627E+01, 0.21690E+01,& - 0.21752E+01 / -! -! ** (H, NO3) -! - DATA (BNC10M (IA),IA= 1,100)/ & - -0.48649E-01,-0.85767E-01,-0.10978E+00,-0.12480E+00,-0.13548E+00,& - -0.14354E+00,-0.14981E+00,-0.15480E+00,-0.15882E+00,-0.16206E+00,& - -0.16468E+00,-0.16679E+00,-0.16847E+00,-0.16978E+00,-0.17078E+00,& - -0.17151E+00,-0.17200E+00,-0.17228E+00,-0.17237E+00,-0.17230E+00,& - -0.17208E+00,-0.17173E+00,-0.17125E+00,-0.17067E+00,-0.16998E+00,& - -0.16921E+00,-0.16835E+00,-0.16742E+00,-0.16643E+00,-0.16536E+00,& - -0.16425E+00,-0.16308E+00,-0.16186E+00,-0.16060E+00,-0.15929E+00,& - -0.15795E+00,-0.15658E+00,-0.15518E+00,-0.15375E+00,-0.15229E+00,& - -0.15080E+00,-0.14930E+00,-0.14778E+00,-0.14623E+00,-0.14468E+00,& - -0.14310E+00,-0.14151E+00,-0.13991E+00,-0.13830E+00,-0.13667E+00,& - -0.13504E+00,-0.13339E+00,-0.13174E+00,-0.13008E+00,-0.12841E+00,& - -0.12673E+00,-0.12505E+00,-0.12335E+00,-0.12166E+00,-0.11995E+00,& - -0.11824E+00,-0.11652E+00,-0.11479E+00,-0.11306E+00,-0.11132E+00,& - -0.10957E+00,-0.10782E+00,-0.10605E+00,-0.10428E+00,-0.10250E+00,& - -0.10071E+00,-0.98911E-01,-0.97103E-01,-0.95285E-01,-0.93457E-01,& - -0.91617E-01,-0.89767E-01,-0.87906E-01,-0.86032E-01,-0.84147E-01,& - -0.82250E-01,-0.80340E-01,-0.78418E-01,-0.76482E-01,-0.74534E-01,& - -0.72572E-01,-0.70597E-01,-0.68609E-01,-0.66607E-01,-0.64593E-01,& - -0.62565E-01,-0.60523E-01,-0.58469E-01,-0.56402E-01,-0.54322E-01,& - -0.52230E-01,-0.50125E-01,-0.48009E-01,-0.45881E-01,-0.43741E-01/ - - DATA (BNC10M (IA),IA=101,200)/ & - -0.41591E-01,-0.39430E-01,-0.37259E-01,-0.35077E-01,-0.32887E-01,& - -0.30687E-01,-0.28479E-01,-0.26263E-01,-0.24039E-01,-0.21808E-01,& - -0.19569E-01,-0.17325E-01,-0.15074E-01,-0.12818E-01,-0.10556E-01,& - -0.82900E-02,-0.60192E-02,-0.37444E-02,-0.14659E-02, 0.81591E-03,& - 0.28768E-02, 0.51902E-02, 0.75034E-02, 0.98163E-02, 0.12129E-01,& - 0.14441E-01, 0.16752E-01, 0.19063E-01, 0.21374E-01, 0.23683E-01,& - 0.25992E-01, 0.28300E-01, 0.30607E-01, 0.32913E-01, 0.35219E-01,& - 0.37523E-01, 0.39826E-01, 0.42127E-01, 0.44428E-01, 0.46727E-01,& - 0.49025E-01, 0.51322E-01, 0.53617E-01, 0.55911E-01, 0.58203E-01,& - 0.60494E-01, 0.62784E-01, 0.65071E-01, 0.67357E-01, 0.69642E-01,& - 0.71924E-01, 0.74205E-01, 0.76484E-01, 0.78761E-01, 0.81037E-01,& - 0.83310E-01, 0.85582E-01, 0.87852E-01, 0.90120E-01, 0.92385E-01,& - 0.94649E-01, 0.96911E-01, 0.99170E-01, 0.10143E+00, 0.10368E+00,& - 0.10594E+00, 0.10819E+00, 0.11044E+00, 0.11268E+00, 0.11493E+00,& - 0.11717E+00, 0.11941E+00, 0.12165E+00, 0.12388E+00, 0.12612E+00,& - 0.12835E+00, 0.13058E+00, 0.13280E+00, 0.13503E+00, 0.13725E+00,& - 0.13947E+00, 0.14168E+00, 0.14390E+00, 0.14611E+00, 0.14832E+00,& - 0.15052E+00, 0.15273E+00, 0.15493E+00, 0.15713E+00, 0.15932E+00,& - 0.16152E+00, 0.16371E+00, 0.16590E+00, 0.16808E+00, 0.17027E+00,& - 0.17245E+00, 0.17463E+00, 0.17680E+00, 0.17898E+00, 0.18115E+00/ - - DATA (BNC10M (IA),IA=201,300)/ & - 0.18332E+00, 0.18548E+00, 0.18764E+00, 0.18980E+00, 0.19196E+00,& - 0.19412E+00, 0.19627E+00, 0.19842E+00, 0.20056E+00, 0.20271E+00,& - 0.20485E+00, 0.20699E+00, 0.20912E+00, 0.21126E+00, 0.21339E+00,& - 0.21552E+00, 0.21764E+00, 0.21976E+00, 0.22188E+00, 0.22400E+00,& - 0.22611E+00, 0.22823E+00, 0.23033E+00, 0.23244E+00, 0.23454E+00,& - 0.23664E+00, 0.23874E+00, 0.24084E+00, 0.24293E+00, 0.24502E+00,& - 0.24711E+00, 0.24919E+00, 0.25127E+00, 0.25335E+00, 0.25543E+00,& - 0.25750E+00, 0.25957E+00, 0.26164E+00, 0.26370E+00, 0.26577E+00,& - 0.26783E+00, 0.26988E+00, 0.27194E+00, 0.27399E+00, 0.27604E+00,& - 0.27808E+00, 0.28013E+00, 0.28217E+00, 0.28420E+00, 0.28624E+00,& - 0.28827E+00, 0.29030E+00, 0.29233E+00, 0.29435E+00, 0.29637E+00,& - 0.29839E+00, 0.30041E+00, 0.30242E+00, 0.30443E+00, 0.30644E+00,& - 0.30844E+00, 0.31044E+00, 0.31244E+00, 0.31444E+00, 0.31644E+00,& - 0.31843E+00, 0.32042E+00, 0.32240E+00, 0.32439E+00, 0.32637E+00,& - 0.32834E+00, 0.33032E+00, 0.33229E+00, 0.33426E+00, 0.33623E+00,& - 0.33819E+00, 0.34016E+00, 0.34211E+00, 0.34407E+00, 0.34603E+00,& - 0.34798E+00, 0.34993E+00, 0.35187E+00, 0.35382E+00, 0.35576E+00,& - 0.35769E+00, 0.35963E+00, 0.36156E+00, 0.36349E+00, 0.36542E+00,& - 0.36735E+00, 0.36927E+00, 0.37119E+00, 0.37310E+00, 0.37502E+00,& - 0.37693E+00, 0.37884E+00, 0.38075E+00, 0.38265E+00, 0.38455E+00/ - - DATA (BNC10M (IA),IA=301,400)/ & - 0.38645E+00, 0.38835E+00, 0.39024E+00, 0.39213E+00, 0.39402E+00,& - 0.39591E+00, 0.39779E+00, 0.39968E+00, 0.40155E+00, 0.40343E+00,& - 0.40530E+00, 0.40717E+00, 0.40904E+00, 0.41091E+00, 0.41277E+00,& - 0.41463E+00, 0.41649E+00, 0.41835E+00, 0.42020E+00, 0.42205E+00,& - 0.42390E+00, 0.42575E+00, 0.42759E+00, 0.42943E+00, 0.43127E+00,& - 0.43311E+00, 0.43494E+00, 0.43677E+00, 0.43860E+00, 0.44043E+00,& - 0.44225E+00, 0.44407E+00, 0.44589E+00, 0.44771E+00, 0.44952E+00,& - 0.45134E+00, 0.45315E+00, 0.45495E+00, 0.45676E+00, 0.45856E+00,& - 0.46036E+00, 0.46216E+00, 0.46395E+00, 0.46575E+00, 0.46754E+00,& - 0.46932E+00, 0.47111E+00, 0.47289E+00, 0.47467E+00, 0.47645E+00,& - 0.47823E+00, 0.48000E+00, 0.48178E+00, 0.48355E+00, 0.48531E+00,& - 0.48708E+00, 0.48884E+00, 0.49060E+00, 0.49236E+00, 0.49411E+00,& - 0.49587E+00, 0.49762E+00, 0.49937E+00, 0.50111E+00, 0.50286E+00,& - 0.50460E+00, 0.50634E+00, 0.50808E+00, 0.50981E+00, 0.51154E+00,& - 0.51327E+00, 0.51500E+00, 0.51673E+00, 0.51845E+00, 0.52017E+00,& - 0.52189E+00, 0.52361E+00, 0.52533E+00, 0.52704E+00, 0.52875E+00,& - 0.53046E+00, 0.53216E+00, 0.53387E+00, 0.53557E+00, 0.53727E+00,& - 0.53897E+00, 0.54066E+00, 0.54236E+00, 0.54405E+00, 0.54574E+00,& - 0.54742E+00, 0.54911E+00, 0.55079E+00, 0.55247E+00, 0.55415E+00,& - 0.55583E+00, 0.55750E+00, 0.55917E+00, 0.56084E+00, 0.56251E+00/ - - DATA (BNC10M (IA),IA=401,500)/ & - 0.56418E+00, 0.56584E+00, 0.56750E+00, 0.56916E+00, 0.57082E+00,& - 0.57247E+00, 0.57413E+00, 0.57578E+00, 0.57743E+00, 0.57907E+00,& - 0.58072E+00, 0.58236E+00, 0.58400E+00, 0.58564E+00, 0.58728E+00,& - 0.58891E+00, 0.59055E+00, 0.59218E+00, 0.59380E+00, 0.59543E+00,& - 0.59706E+00, 0.59868E+00, 0.60030E+00, 0.60192E+00, 0.60354E+00,& - 0.60515E+00, 0.60676E+00, 0.60837E+00, 0.60998E+00, 0.61159E+00,& - 0.61319E+00, 0.61480E+00, 0.61640E+00, 0.61800E+00, 0.61959E+00,& - 0.62119E+00, 0.62278E+00, 0.62437E+00, 0.62596E+00, 0.62755E+00,& - 0.62914E+00, 0.63072E+00, 0.63230E+00, 0.63388E+00, 0.63546E+00,& - 0.63704E+00, 0.63861E+00, 0.64018E+00, 0.64175E+00, 0.64332E+00,& - 0.64489E+00, 0.64645E+00, 0.64802E+00, 0.64958E+00, 0.65114E+00,& - 0.65269E+00, 0.65425E+00, 0.65580E+00, 0.65735E+00, 0.65890E+00,& - 0.66045E+00, 0.66200E+00, 0.66354E+00, 0.66509E+00, 0.66663E+00,& - 0.66817E+00, 0.66970E+00, 0.67124E+00, 0.67277E+00, 0.67431E+00,& - 0.67584E+00, 0.67736E+00, 0.67889E+00, 0.68042E+00, 0.68194E+00,& - 0.68346E+00, 0.68498E+00, 0.68650E+00, 0.68801E+00, 0.68953E+00,& - 0.69104E+00, 0.69255E+00, 0.69406E+00, 0.69557E+00, 0.69707E+00,& - 0.69858E+00, 0.70008E+00, 0.70158E+00, 0.70308E+00, 0.70457E+00,& - 0.70607E+00, 0.70756E+00, 0.70905E+00, 0.71054E+00, 0.71203E+00,& - 0.71352E+00, 0.71500E+00, 0.71649E+00, 0.71797E+00, 0.71945E+00/ - - DATA (BNC10M (IA),IA=501,600)/ & - 0.72093E+00, 0.72240E+00, 0.72388E+00, 0.72535E+00, 0.72682E+00,& - 0.72829E+00, 0.72976E+00, 0.73123E+00, 0.73269E+00, 0.73416E+00,& - 0.73562E+00, 0.73708E+00, 0.73854E+00, 0.74000E+00, 0.74145E+00,& - 0.74290E+00, 0.74436E+00, 0.74581E+00, 0.74726E+00, 0.74870E+00,& - 0.75015E+00, 0.75159E+00, 0.75304E+00, 0.75448E+00, 0.75592E+00,& - 0.75735E+00, 0.75879E+00, 0.76022E+00, 0.76166E+00, 0.76309E+00,& - 0.76452E+00, 0.76595E+00, 0.76737E+00, 0.76880E+00, 0.77022E+00,& - 0.77164E+00, 0.77307E+00, 0.77448E+00, 0.77590E+00, 0.77732E+00,& - 0.77873E+00, 0.78015E+00, 0.78156E+00, 0.78297E+00, 0.78437E+00,& - 0.78578E+00, 0.78719E+00, 0.78859E+00, 0.78999E+00, 0.79139E+00,& - 0.79279E+00, 0.79419E+00, 0.79559E+00, 0.79698E+00, 0.79838E+00,& - 0.79977E+00, 0.80116E+00, 0.80255E+00, 0.80393E+00, 0.80532E+00,& - 0.80671E+00, 0.80809E+00, 0.80947E+00, 0.81085E+00, 0.81223E+00,& - 0.81361E+00, 0.81498E+00, 0.81636E+00, 0.81773E+00, 0.81910E+00,& - 0.82047E+00, 0.82184E+00, 0.82321E+00, 0.82457E+00, 0.82594E+00,& - 0.82730E+00, 0.82866E+00, 0.83002E+00, 0.83138E+00, 0.83274E+00,& - 0.83409E+00, 0.83545E+00, 0.83680E+00, 0.83815E+00, 0.83950E+00,& - 0.84085E+00, 0.84220E+00, 0.84355E+00, 0.84489E+00, 0.84624E+00,& - 0.84758E+00, 0.84892E+00, 0.85026E+00, 0.85160E+00, 0.85293E+00,& - 0.85427E+00, 0.85560E+00, 0.85693E+00, 0.85827E+00, 0.86325E+00/ - - DATA (BNC10M (IA),IA=601,700)/ & - 0.87414E+00, 0.88722E+00, 0.90017E+00, 0.91300E+00, 0.92570E+00,& - 0.93828E+00, 0.95075E+00, 0.96310E+00, 0.97533E+00, 0.98746E+00,& - 0.99947E+00, 0.10114E+01, 0.10232E+01, 0.10349E+01, 0.10465E+01,& - 0.10580E+01, 0.10694E+01, 0.10807E+01, 0.10919E+01, 0.11030E+01,& - 0.11141E+01, 0.11250E+01, 0.11358E+01, 0.11466E+01, 0.11573E+01,& - 0.11679E+01, 0.11784E+01, 0.11889E+01, 0.11992E+01, 0.12095E+01,& - 0.12197E+01, 0.12299E+01, 0.12399E+01, 0.12499E+01, 0.12598E+01,& - 0.12697E+01, 0.12795E+01, 0.12892E+01, 0.12988E+01, 0.13084E+01,& - 0.13179E+01, 0.13274E+01, 0.13367E+01, 0.13461E+01, 0.13553E+01,& - 0.13645E+01, 0.13737E+01, 0.13828E+01, 0.13918E+01, 0.14008E+01,& - 0.14097E+01, 0.14186E+01, 0.14274E+01, 0.14362E+01, 0.14449E+01,& - 0.14535E+01, 0.14621E+01, 0.14707E+01, 0.14792E+01, 0.14876E+01,& - 0.14960E+01, 0.15044E+01, 0.15127E+01, 0.15210E+01, 0.15292E+01,& - 0.15374E+01, 0.15455E+01, 0.15536E+01, 0.15616E+01, 0.15696E+01,& - 0.15776E+01, 0.15855E+01, 0.15934E+01, 0.16012E+01, 0.16090E+01,& - 0.16168E+01, 0.16245E+01, 0.16322E+01, 0.16398E+01, 0.16474E+01,& - 0.16550E+01, 0.16625E+01, 0.16700E+01, 0.16774E+01, 0.16849E+01,& - 0.16922E+01, 0.16996E+01, 0.17069E+01, 0.17142E+01, 0.17214E+01,& - 0.17286E+01, 0.17358E+01, 0.17430E+01, 0.17501E+01, 0.17572E+01,& - 0.17642E+01, 0.17712E+01, 0.17782E+01, 0.17852E+01, 0.17921E+01/ - - DATA (BNC10M(IA),IA=701,741)/ & - 0.17990E+01, 0.18059E+01, 0.18127E+01, 0.18195E+01, 0.18263E+01,& - 0.18331E+01, 0.18398E+01, 0.18465E+01, 0.18532E+01, 0.18598E+01,& - 0.18664E+01, 0.18730E+01, 0.18796E+01, 0.18861E+01, 0.18926E+01,& - 0.18991E+01, 0.19056E+01, 0.19120E+01, 0.19184E+01, 0.19248E+01,& - 0.19312E+01, 0.19375E+01, 0.19439E+01, 0.19502E+01, 0.19564E+01,& - 0.19627E+01, 0.19689E+01, 0.19751E+01, 0.19813E+01, 0.19874E+01,& - 0.19936E+01, 0.19997E+01, 0.20058E+01, 0.20118E+01, 0.20179E+01,& - 0.20239E+01, 0.20299E+01, 0.20359E+01, 0.20419E+01, 0.20478E+01,& - 0.20537E+01 / -! -! ** (H, Cl) -! - DATA (BNC11M (IA),IA= 1,100)/ & - -0.47533E-01,-0.81940E-01,-0.10288E+00,-0.11511E+00,-0.12316E+00,& - -0.12868E+00,-0.13248E+00,-0.13503E+00,-0.13662E+00,-0.13745E+00,& - -0.13766E+00,-0.13734E+00,-0.13659E+00,-0.13546E+00,-0.13399E+00,& - -0.13224E+00,-0.13022E+00,-0.12796E+00,-0.12550E+00,-0.12284E+00,& - -0.12001E+00,-0.11702E+00,-0.11388E+00,-0.11061E+00,-0.10721E+00,& - -0.10369E+00,-0.10007E+00,-0.96344E-01,-0.92526E-01,-0.88621E-01,& - -0.84635E-01,-0.80573E-01,-0.76440E-01,-0.72241E-01,-0.67980E-01,& - -0.63661E-01,-0.59289E-01,-0.54866E-01,-0.50396E-01,-0.45882E-01,& - -0.41327E-01,-0.36734E-01,-0.32105E-01,-0.27442E-01,-0.22748E-01,& - -0.18025E-01,-0.13275E-01,-0.84990E-02,-0.36992E-02, 0.11231E-02,& - 0.59666E-02, 0.10830E-01, 0.15712E-01, 0.20613E-01, 0.25530E-01,& - 0.30464E-01, 0.35414E-01, 0.40380E-01, 0.45360E-01, 0.50356E-01,& - 0.55366E-01, 0.60391E-01, 0.65431E-01, 0.70486E-01, 0.75557E-01,& - 0.80642E-01, 0.85744E-01, 0.90863E-01, 0.95998E-01, 0.10115E+00,& - 0.10632E+00, 0.11151E+00, 0.11672E+00, 0.12195E+00, 0.12720E+00,& - 0.13247E+00, 0.13777E+00, 0.14308E+00, 0.14843E+00, 0.15379E+00,& - 0.15918E+00, 0.16460E+00, 0.17004E+00, 0.17550E+00, 0.18100E+00,& - 0.18652E+00, 0.19207E+00, 0.19764E+00, 0.20324E+00, 0.20887E+00,& - 0.21453E+00, 0.22022E+00, 0.22593E+00, 0.23166E+00, 0.23743E+00,& - 0.24322E+00, 0.24903E+00, 0.25487E+00, 0.26073E+00, 0.26661E+00/ - - DATA (BNC11M (IA),IA=101,200)/ & - 0.27252E+00, 0.27845E+00, 0.28440E+00, 0.29037E+00, 0.29635E+00,& - 0.30235E+00, 0.30838E+00, 0.31441E+00, 0.32046E+00, 0.32652E+00,& - 0.33260E+00, 0.33869E+00, 0.34478E+00, 0.35089E+00, 0.35701E+00,& - 0.36313E+00, 0.36926E+00, 0.37539E+00, 0.38153E+00, 0.38767E+00,& - 0.39330E+00, 0.39951E+00, 0.40571E+00, 0.41191E+00, 0.41810E+00,& - 0.42429E+00, 0.43047E+00, 0.43665E+00, 0.44282E+00, 0.44898E+00,& - 0.45514E+00, 0.46129E+00, 0.46744E+00, 0.47358E+00, 0.47971E+00,& - 0.48583E+00, 0.49195E+00, 0.49806E+00, 0.50417E+00, 0.51026E+00,& - 0.51635E+00, 0.52243E+00, 0.52850E+00, 0.53456E+00, 0.54062E+00,& - 0.54667E+00, 0.55271E+00, 0.55874E+00, 0.56476E+00, 0.57077E+00,& - 0.57678E+00, 0.58277E+00, 0.58876E+00, 0.59474E+00, 0.60071E+00,& - 0.60667E+00, 0.61262E+00, 0.61856E+00, 0.62449E+00, 0.63041E+00,& - 0.63633E+00, 0.64223E+00, 0.64812E+00, 0.65401E+00, 0.65988E+00,& - 0.66575E+00, 0.67160E+00, 0.67745E+00, 0.68328E+00, 0.68911E+00,& - 0.69493E+00, 0.70073E+00, 0.70653E+00, 0.71231E+00, 0.71809E+00,& - 0.72386E+00, 0.72961E+00, 0.73536E+00, 0.74109E+00, 0.74682E+00,& - 0.75253E+00, 0.75824E+00, 0.76393E+00, 0.76962E+00, 0.77529E+00,& - 0.78096E+00, 0.78661E+00, 0.79226E+00, 0.79789E+00, 0.80351E+00,& - 0.80913E+00, 0.81473E+00, 0.82032E+00, 0.82590E+00, 0.83148E+00,& - 0.83704E+00, 0.84259E+00, 0.84813E+00, 0.85366E+00, 0.85918E+00/ - - DATA (BNC11M (IA),IA=201,300)/ & - 0.86469E+00, 0.87019E+00, 0.87568E+00, 0.88116E+00, 0.88663E+00,& - 0.89209E+00, 0.89754E+00, 0.90298E+00, 0.90841E+00, 0.91383E+00,& - 0.91923E+00, 0.92463E+00, 0.93002E+00, 0.93540E+00, 0.94077E+00,& - 0.94612E+00, 0.95147E+00, 0.95681E+00, 0.96213E+00, 0.96745E+00,& - 0.97276E+00, 0.97806E+00, 0.98334E+00, 0.98862E+00, 0.99389E+00,& - 0.99914E+00, 0.10044E+01, 0.10096E+01, 0.10149E+01, 0.10201E+01,& - 0.10253E+01, 0.10305E+01, 0.10357E+01, 0.10408E+01, 0.10460E+01,& - 0.10512E+01, 0.10563E+01, 0.10615E+01, 0.10666E+01, 0.10717E+01,& - 0.10768E+01, 0.10819E+01, 0.10870E+01, 0.10921E+01, 0.10972E+01,& - 0.11022E+01, 0.11073E+01, 0.11123E+01, 0.11174E+01, 0.11224E+01,& - 0.11274E+01, 0.11324E+01, 0.11374E+01, 0.11424E+01, 0.11474E+01,& - 0.11523E+01, 0.11573E+01, 0.11622E+01, 0.11672E+01, 0.11721E+01,& - 0.11770E+01, 0.11819E+01, 0.11868E+01, 0.11917E+01, 0.11966E+01,& - 0.12015E+01, 0.12064E+01, 0.12112E+01, 0.12161E+01, 0.12209E+01,& - 0.12258E+01, 0.12306E+01, 0.12354E+01, 0.12402E+01, 0.12450E+01,& - 0.12498E+01, 0.12546E+01, 0.12593E+01, 0.12641E+01, 0.12688E+01,& - 0.12736E+01, 0.12783E+01, 0.12831E+01, 0.12878E+01, 0.12925E+01,& - 0.12972E+01, 0.13019E+01, 0.13066E+01, 0.13112E+01, 0.13159E+01,& - 0.13206E+01, 0.13252E+01, 0.13299E+01, 0.13345E+01, 0.13391E+01,& - 0.13437E+01, 0.13483E+01, 0.13529E+01, 0.13575E+01, 0.13621E+01/ - - DATA (BNC11M (IA),IA=301,400)/ & - 0.13667E+01, 0.13713E+01, 0.13758E+01, 0.13804E+01, 0.13849E+01,& - 0.13895E+01, 0.13940E+01, 0.13985E+01, 0.14030E+01, 0.14075E+01,& - 0.14120E+01, 0.14165E+01, 0.14210E+01, 0.14255E+01, 0.14299E+01,& - 0.14344E+01, 0.14388E+01, 0.14433E+01, 0.14477E+01, 0.14521E+01,& - 0.14565E+01, 0.14610E+01, 0.14654E+01, 0.14698E+01, 0.14741E+01,& - 0.14785E+01, 0.14829E+01, 0.14873E+01, 0.14916E+01, 0.14960E+01,& - 0.15003E+01, 0.15047E+01, 0.15090E+01, 0.15133E+01, 0.15176E+01,& - 0.15219E+01, 0.15262E+01, 0.15305E+01, 0.15348E+01, 0.15391E+01,& - 0.15433E+01, 0.15476E+01, 0.15519E+01, 0.15561E+01, 0.15604E+01,& - 0.15646E+01, 0.15688E+01, 0.15730E+01, 0.15773E+01, 0.15815E+01,& - 0.15857E+01, 0.15899E+01, 0.15940E+01, 0.15982E+01, 0.16024E+01,& - 0.16066E+01, 0.16107E+01, 0.16149E+01, 0.16190E+01, 0.16231E+01,& - 0.16273E+01, 0.16314E+01, 0.16355E+01, 0.16396E+01, 0.16437E+01,& - 0.16478E+01, 0.16519E+01, 0.16560E+01, 0.16601E+01, 0.16642E+01,& - 0.16682E+01, 0.16723E+01, 0.16763E+01, 0.16804E+01, 0.16844E+01,& - 0.16884E+01, 0.16925E+01, 0.16965E+01, 0.17005E+01, 0.17045E+01,& - 0.17085E+01, 0.17125E+01, 0.17165E+01, 0.17205E+01, 0.17245E+01,& - 0.17284E+01, 0.17324E+01, 0.17363E+01, 0.17403E+01, 0.17442E+01,& - 0.17482E+01, 0.17521E+01, 0.17560E+01, 0.17599E+01, 0.17639E+01,& - 0.17678E+01, 0.17717E+01, 0.17756E+01, 0.17795E+01, 0.17833E+01/ - - DATA (BNC11M (IA),IA=401,500)/ & - 0.17872E+01, 0.17911E+01, 0.17950E+01, 0.17988E+01, 0.18027E+01,& - 0.18065E+01, 0.18104E+01, 0.18142E+01, 0.18180E+01, 0.18218E+01,& - 0.18257E+01, 0.18295E+01, 0.18333E+01, 0.18371E+01, 0.18409E+01,& - 0.18447E+01, 0.18485E+01, 0.18522E+01, 0.18560E+01, 0.18598E+01,& - 0.18635E+01, 0.18673E+01, 0.18710E+01, 0.18748E+01, 0.18785E+01,& - 0.18823E+01, 0.18860E+01, 0.18897E+01, 0.18934E+01, 0.18971E+01,& - 0.19008E+01, 0.19045E+01, 0.19082E+01, 0.19119E+01, 0.19156E+01,& - 0.19193E+01, 0.19230E+01, 0.19266E+01, 0.19303E+01, 0.19340E+01,& - 0.19376E+01, 0.19413E+01, 0.19449E+01, 0.19485E+01, 0.19522E+01,& - 0.19558E+01, 0.19594E+01, 0.19630E+01, 0.19666E+01, 0.19702E+01,& - 0.19738E+01, 0.19774E+01, 0.19810E+01, 0.19846E+01, 0.19882E+01,& - 0.19918E+01, 0.19953E+01, 0.19989E+01, 0.20025E+01, 0.20060E+01,& - 0.20096E+01, 0.20131E+01, 0.20167E+01, 0.20202E+01, 0.20237E+01,& - 0.20272E+01, 0.20308E+01, 0.20343E+01, 0.20378E+01, 0.20413E+01,& - 0.20448E+01, 0.20483E+01, 0.20518E+01, 0.20553E+01, 0.20587E+01,& - 0.20622E+01, 0.20657E+01, 0.20692E+01, 0.20726E+01, 0.20761E+01,& - 0.20795E+01, 0.20830E+01, 0.20864E+01, 0.20899E+01, 0.20933E+01,& - 0.20967E+01, 0.21001E+01, 0.21036E+01, 0.21070E+01, 0.21104E+01,& - 0.21138E+01, 0.21172E+01, 0.21206E+01, 0.21240E+01, 0.21274E+01,& - 0.21308E+01, 0.21341E+01, 0.21375E+01, 0.21409E+01, 0.21442E+01/ - - DATA (BNC11M (IA),IA=501,600)/ & - 0.21476E+01, 0.21510E+01, 0.21543E+01, 0.21577E+01, 0.21610E+01,& - 0.21643E+01, 0.21677E+01, 0.21710E+01, 0.21743E+01, 0.21776E+01,& - 0.21810E+01, 0.21843E+01, 0.21876E+01, 0.21909E+01, 0.21942E+01,& - 0.21975E+01, 0.22008E+01, 0.22041E+01, 0.22073E+01, 0.22106E+01,& - 0.22139E+01, 0.22172E+01, 0.22204E+01, 0.22237E+01, 0.22269E+01,& - 0.22302E+01, 0.22334E+01, 0.22367E+01, 0.22399E+01, 0.22432E+01,& - 0.22464E+01, 0.22496E+01, 0.22528E+01, 0.22561E+01, 0.22593E+01,& - 0.22625E+01, 0.22657E+01, 0.22689E+01, 0.22721E+01, 0.22753E+01,& - 0.22785E+01, 0.22817E+01, 0.22849E+01, 0.22880E+01, 0.22912E+01,& - 0.22944E+01, 0.22975E+01, 0.23007E+01, 0.23039E+01, 0.23070E+01,& - 0.23102E+01, 0.23133E+01, 0.23165E+01, 0.23196E+01, 0.23227E+01,& - 0.23259E+01, 0.23290E+01, 0.23321E+01, 0.23352E+01, 0.23384E+01,& - 0.23415E+01, 0.23446E+01, 0.23477E+01, 0.23508E+01, 0.23539E+01,& - 0.23570E+01, 0.23601E+01, 0.23632E+01, 0.23662E+01, 0.23693E+01,& - 0.23724E+01, 0.23755E+01, 0.23785E+01, 0.23816E+01, 0.23847E+01,& - 0.23877E+01, 0.23908E+01, 0.23938E+01, 0.23969E+01, 0.23999E+01,& - 0.24029E+01, 0.24060E+01, 0.24090E+01, 0.24120E+01, 0.24150E+01,& - 0.24181E+01, 0.24211E+01, 0.24241E+01, 0.24271E+01, 0.24301E+01,& - 0.24331E+01, 0.24361E+01, 0.24391E+01, 0.24421E+01, 0.24451E+01,& - 0.24481E+01, 0.24511E+01, 0.24540E+01, 0.24570E+01, 0.24681E+01/ - - DATA (BNC11M (IA),IA=601,700)/ & - 0.24924E+01, 0.25216E+01, 0.25504E+01, 0.25789E+01, 0.26071E+01,& - 0.26349E+01, 0.26625E+01, 0.26898E+01, 0.27168E+01, 0.27435E+01,& - 0.27699E+01, 0.27961E+01, 0.28220E+01, 0.28477E+01, 0.28731E+01,& - 0.28982E+01, 0.29231E+01, 0.29478E+01, 0.29722E+01, 0.29965E+01,& - 0.30205E+01, 0.30442E+01, 0.30678E+01, 0.30911E+01, 0.31143E+01,& - 0.31372E+01, 0.31599E+01, 0.31825E+01, 0.32048E+01, 0.32270E+01,& - 0.32490E+01, 0.32708E+01, 0.32924E+01, 0.33138E+01, 0.33351E+01,& - 0.33562E+01, 0.33771E+01, 0.33979E+01, 0.34185E+01, 0.34389E+01,& - 0.34592E+01, 0.34794E+01, 0.34993E+01, 0.35192E+01, 0.35389E+01,& - 0.35584E+01, 0.35778E+01, 0.35971E+01, 0.36162E+01, 0.36352E+01,& - 0.36541E+01, 0.36728E+01, 0.36914E+01, 0.37099E+01, 0.37282E+01,& - 0.37465E+01, 0.37646E+01, 0.37826E+01, 0.38004E+01, 0.38182E+01,& - 0.38358E+01, 0.38533E+01, 0.38707E+01, 0.38880E+01, 0.39052E+01,& - 0.39223E+01, 0.39393E+01, 0.39562E+01, 0.39729E+01, 0.39896E+01,& - 0.40062E+01, 0.40226E+01, 0.40390E+01, 0.40553E+01, 0.40715E+01,& - 0.40876E+01, 0.41035E+01, 0.41194E+01, 0.41353E+01, 0.41510E+01,& - 0.41666E+01, 0.41822E+01, 0.41976E+01, 0.42130E+01, 0.42283E+01,& - 0.42435E+01, 0.42586E+01, 0.42737E+01, 0.42886E+01, 0.43035E+01,& - 0.43183E+01, 0.43330E+01, 0.43477E+01, 0.43623E+01, 0.43768E+01,& - 0.43912E+01, 0.44056E+01, 0.44198E+01, 0.44341E+01, 0.44482E+01/ - - DATA (BNC11M(IA),IA=701,741)/ & - 0.44623E+01, 0.44763E+01, 0.44902E+01, 0.45041E+01, 0.45179E+01,& - 0.45316E+01, 0.45453E+01, 0.45589E+01, 0.45724E+01, 0.45859E+01,& - 0.45993E+01, 0.46126E+01, 0.46259E+01, 0.46391E+01, 0.46523E+01,& - 0.46654E+01, 0.46785E+01, 0.46915E+01, 0.47044E+01, 0.47173E+01,& - 0.47301E+01, 0.47428E+01, 0.47555E+01, 0.47682E+01, 0.47808E+01,& - 0.47933E+01, 0.48058E+01, 0.48183E+01, 0.48306E+01, 0.48430E+01,& - 0.48552E+01, 0.48675E+01, 0.48797E+01, 0.48918E+01, 0.49039E+01,& - 0.49159E+01, 0.49279E+01, 0.49398E+01, 0.49517E+01, 0.49635E+01,& - 0.49753E+01 / -! -! ** NaHSO4 -! - DATA (BNC12M (IA),IA= 1,100)/ & - -0.48506E-01,-0.85523E-01,-0.10966E+00,-0.12495E+00,-0.13595E+00,& - -0.14436E+00,-0.15100E+00,-0.15637E+00,-0.16075E+00,-0.16435E+00,& - -0.16731E+00,-0.16974E+00,-0.17171E+00,-0.17329E+00,-0.17453E+00,& - -0.17547E+00,-0.17613E+00,-0.17655E+00,-0.17675E+00,-0.17675E+00,& - -0.17656E+00,-0.17620E+00,-0.17567E+00,-0.17500E+00,-0.17419E+00,& - -0.17325E+00,-0.17219E+00,-0.17101E+00,-0.16973E+00,-0.16834E+00,& - -0.16685E+00,-0.16526E+00,-0.16359E+00,-0.16184E+00,-0.16000E+00,& - -0.15809E+00,-0.15610E+00,-0.15405E+00,-0.15192E+00,-0.14973E+00,& - -0.14749E+00,-0.14518E+00,-0.14281E+00,-0.14040E+00,-0.13793E+00,& - -0.13541E+00,-0.13284E+00,-0.13023E+00,-0.12757E+00,-0.12488E+00,& - -0.12214E+00,-0.11936E+00,-0.11654E+00,-0.11369E+00,-0.11081E+00,& - -0.10789E+00,-0.10493E+00,-0.10195E+00,-0.98933E-01,-0.95887E-01,& - -0.92812E-01,-0.89708E-01,-0.86577E-01,-0.83417E-01,-0.80231E-01,& - -0.77018E-01,-0.73779E-01,-0.70513E-01,-0.67222E-01,-0.63906E-01,& - -0.60563E-01,-0.57196E-01,-0.53803E-01,-0.50385E-01,-0.46941E-01,& - -0.43472E-01,-0.39979E-01,-0.36459E-01,-0.32915E-01,-0.29345E-01,& - -0.25749E-01,-0.22128E-01,-0.18482E-01,-0.14811E-01,-0.11115E-01,& - -0.73934E-02,-0.36468E-02, 0.12404E-03, 0.39196E-02, 0.77393E-02,& - 0.11583E-01, 0.15450E-01, 0.19340E-01, 0.23253E-01, 0.27187E-01,& - 0.31143E-01, 0.35121E-01, 0.39118E-01, 0.43135E-01, 0.47171E-01/ - - DATA (BNC12M (IA),IA=101,200)/ & - 0.51225E-01, 0.55297E-01, 0.59385E-01, 0.63489E-01, 0.67608E-01,& - 0.71741E-01, 0.75888E-01, 0.80047E-01, 0.84217E-01, 0.88399E-01,& - 0.92590E-01, 0.96791E-01, 0.10100E+00, 0.10522E+00, 0.10944E+00,& - 0.11367E+00, 0.11790E+00, 0.12214E+00, 0.12638E+00, 0.13063E+00,& - 0.13451E+00, 0.13880E+00, 0.14309E+00, 0.14737E+00, 0.15166E+00,& - 0.15593E+00, 0.16021E+00, 0.16448E+00, 0.16874E+00, 0.17301E+00,& - 0.17726E+00, 0.18151E+00, 0.18576E+00, 0.19000E+00, 0.19424E+00,& - 0.19847E+00, 0.20270E+00, 0.20692E+00, 0.21114E+00, 0.21535E+00,& - 0.21955E+00, 0.22375E+00, 0.22794E+00, 0.23213E+00, 0.23630E+00,& - 0.24048E+00, 0.24464E+00, 0.24881E+00, 0.25296E+00, 0.25711E+00,& - 0.26125E+00, 0.26538E+00, 0.26951E+00, 0.27363E+00, 0.27774E+00,& - 0.28185E+00, 0.28595E+00, 0.29004E+00, 0.29413E+00, 0.29821E+00,& - 0.30228E+00, 0.30634E+00, 0.31040E+00, 0.31445E+00, 0.31849E+00,& - 0.32253E+00, 0.32656E+00, 0.33058E+00, 0.33459E+00, 0.33860E+00,& - 0.34260E+00, 0.34659E+00, 0.35057E+00, 0.35455E+00, 0.35852E+00,& - 0.36248E+00, 0.36644E+00, 0.37038E+00, 0.37432E+00, 0.37826E+00,& - 0.38218E+00, 0.38610E+00, 0.39001E+00, 0.39391E+00, 0.39781E+00,& - 0.40170E+00, 0.40558E+00, 0.40945E+00, 0.41332E+00, 0.41718E+00,& - 0.42103E+00, 0.42487E+00, 0.42871E+00, 0.43254E+00, 0.43636E+00,& - 0.44018E+00, 0.44398E+00, 0.44778E+00, 0.45158E+00, 0.45536E+00/ - - DATA (BNC12M (IA),IA=201,300)/ & - 0.45914E+00, 0.46291E+00, 0.46668E+00, 0.47043E+00, 0.47418E+00,& - 0.47793E+00, 0.48166E+00, 0.48539E+00, 0.48911E+00, 0.49283E+00,& - 0.49653E+00, 0.50023E+00, 0.50393E+00, 0.50761E+00, 0.51129E+00,& - 0.51496E+00, 0.51863E+00, 0.52228E+00, 0.52594E+00, 0.52958E+00,& - 0.53322E+00, 0.53685E+00, 0.54047E+00, 0.54409E+00, 0.54770E+00,& - 0.55130E+00, 0.55490E+00, 0.55849E+00, 0.56207E+00, 0.56564E+00,& - 0.56921E+00, 0.57278E+00, 0.57633E+00, 0.57988E+00, 0.58342E+00,& - 0.58696E+00, 0.59049E+00, 0.59401E+00, 0.59753E+00, 0.60104E+00,& - 0.60454E+00, 0.60804E+00, 0.61153E+00, 0.61501E+00, 0.61849E+00,& - 0.62196E+00, 0.62543E+00, 0.62888E+00, 0.63234E+00, 0.63578E+00,& - 0.63922E+00, 0.64265E+00, 0.64608E+00, 0.64950E+00, 0.65292E+00,& - 0.65632E+00, 0.65973E+00, 0.66312E+00, 0.66651E+00, 0.66990E+00,& - 0.67327E+00, 0.67664E+00, 0.68001E+00, 0.68337E+00, 0.68672E+00,& - 0.69007E+00, 0.69341E+00, 0.69675E+00, 0.70008E+00, 0.70340E+00,& - 0.70672E+00, 0.71003E+00, 0.71334E+00, 0.71664E+00, 0.71993E+00,& - 0.72322E+00, 0.72650E+00, 0.72978E+00, 0.73305E+00, 0.73632E+00,& - 0.73958E+00, 0.74283E+00, 0.74608E+00, 0.74932E+00, 0.75256E+00,& - 0.75579E+00, 0.75902E+00, 0.76224E+00, 0.76546E+00, 0.76867E+00,& - 0.77187E+00, 0.77507E+00, 0.77826E+00, 0.78145E+00, 0.78463E+00,& - 0.78781E+00, 0.79098E+00, 0.79415E+00, 0.79731E+00, 0.80046E+00/ - - DATA (BNC12M (IA),IA=301,400)/ & - 0.80361E+00, 0.80676E+00, 0.80990E+00, 0.81303E+00, 0.81616E+00,& - 0.81928E+00, 0.82240E+00, 0.82552E+00, 0.82862E+00, 0.83173E+00,& - 0.83483E+00, 0.83792E+00, 0.84101E+00, 0.84409E+00, 0.84717E+00,& - 0.85024E+00, 0.85331E+00, 0.85637E+00, 0.85943E+00, 0.86248E+00,& - 0.86553E+00, 0.86857E+00, 0.87160E+00, 0.87464E+00, 0.87766E+00,& - 0.88069E+00, 0.88371E+00, 0.88672E+00, 0.88973E+00, 0.89273E+00,& - 0.89573E+00, 0.89872E+00, 0.90171E+00, 0.90469E+00, 0.90767E+00,& - 0.91065E+00, 0.91362E+00, 0.91658E+00, 0.91954E+00, 0.92250E+00,& - 0.92545E+00, 0.92840E+00, 0.93134E+00, 0.93427E+00, 0.93721E+00,& - 0.94014E+00, 0.94306E+00, 0.94598E+00, 0.94889E+00, 0.95180E+00,& - 0.95471E+00, 0.95761E+00, 0.96050E+00, 0.96339E+00, 0.96628E+00,& - 0.96916E+00, 0.97204E+00, 0.97492E+00, 0.97779E+00, 0.98065E+00,& - 0.98351E+00, 0.98637E+00, 0.98922E+00, 0.99207E+00, 0.99491E+00,& - 0.99775E+00, 0.10006E+01, 0.10034E+01, 0.10062E+01, 0.10091E+01,& - 0.10119E+01, 0.10147E+01, 0.10175E+01, 0.10203E+01, 0.10231E+01,& - 0.10259E+01, 0.10287E+01, 0.10315E+01, 0.10343E+01, 0.10370E+01,& - 0.10398E+01, 0.10426E+01, 0.10454E+01, 0.10481E+01, 0.10509E+01,& - 0.10536E+01, 0.10564E+01, 0.10591E+01, 0.10619E+01, 0.10646E+01,& - 0.10674E+01, 0.10701E+01, 0.10728E+01, 0.10755E+01, 0.10783E+01,& - 0.10810E+01, 0.10837E+01, 0.10864E+01, 0.10891E+01, 0.10918E+01/ - - DATA (BNC12M (IA),IA=401,500)/ & - 0.10945E+01, 0.10972E+01, 0.10999E+01, 0.11026E+01, 0.11052E+01,& - 0.11079E+01, 0.11106E+01, 0.11133E+01, 0.11159E+01, 0.11186E+01,& - 0.11212E+01, 0.11239E+01, 0.11265E+01, 0.11292E+01, 0.11318E+01,& - 0.11345E+01, 0.11371E+01, 0.11397E+01, 0.11424E+01, 0.11450E+01,& - 0.11476E+01, 0.11502E+01, 0.11528E+01, 0.11554E+01, 0.11581E+01,& - 0.11607E+01, 0.11633E+01, 0.11658E+01, 0.11684E+01, 0.11710E+01,& - 0.11736E+01, 0.11762E+01, 0.11788E+01, 0.11813E+01, 0.11839E+01,& - 0.11865E+01, 0.11890E+01, 0.11916E+01, 0.11942E+01, 0.11967E+01,& - 0.11993E+01, 0.12018E+01, 0.12044E+01, 0.12069E+01, 0.12094E+01,& - 0.12120E+01, 0.12145E+01, 0.12170E+01, 0.12195E+01, 0.12221E+01,& - 0.12246E+01, 0.12271E+01, 0.12296E+01, 0.12321E+01, 0.12346E+01,& - 0.12371E+01, 0.12396E+01, 0.12421E+01, 0.12446E+01, 0.12471E+01,& - 0.12495E+01, 0.12520E+01, 0.12545E+01, 0.12570E+01, 0.12594E+01,& - 0.12619E+01, 0.12644E+01, 0.12668E+01, 0.12693E+01, 0.12717E+01,& - 0.12742E+01, 0.12766E+01, 0.12791E+01, 0.12815E+01, 0.12839E+01,& - 0.12864E+01, 0.12888E+01, 0.12912E+01, 0.12937E+01, 0.12961E+01,& - 0.12985E+01, 0.13009E+01, 0.13033E+01, 0.13057E+01, 0.13081E+01,& - 0.13106E+01, 0.13130E+01, 0.13153E+01, 0.13177E+01, 0.13201E+01,& - 0.13225E+01, 0.13249E+01, 0.13273E+01, 0.13297E+01, 0.13320E+01,& - 0.13344E+01, 0.13368E+01, 0.13392E+01, 0.13415E+01, 0.13439E+01/ - - DATA (BNC12M (IA),IA=501,600)/ & - 0.13462E+01, 0.13486E+01, 0.13509E+01, 0.13533E+01, 0.13556E+01,& - 0.13580E+01, 0.13603E+01, 0.13627E+01, 0.13650E+01, 0.13673E+01,& - 0.13697E+01, 0.13720E+01, 0.13743E+01, 0.13766E+01, 0.13789E+01,& - 0.13813E+01, 0.13836E+01, 0.13859E+01, 0.13882E+01, 0.13905E+01,& - 0.13928E+01, 0.13951E+01, 0.13974E+01, 0.13997E+01, 0.14020E+01,& - 0.14042E+01, 0.14065E+01, 0.14088E+01, 0.14111E+01, 0.14134E+01,& - 0.14156E+01, 0.14179E+01, 0.14202E+01, 0.14224E+01, 0.14247E+01,& - 0.14270E+01, 0.14292E+01, 0.14315E+01, 0.14337E+01, 0.14360E+01,& - 0.14382E+01, 0.14405E+01, 0.14427E+01, 0.14449E+01, 0.14472E+01,& - 0.14494E+01, 0.14516E+01, 0.14539E+01, 0.14561E+01, 0.14583E+01,& - 0.14605E+01, 0.14628E+01, 0.14650E+01, 0.14672E+01, 0.14694E+01,& - 0.14716E+01, 0.14738E+01, 0.14760E+01, 0.14782E+01, 0.14804E+01,& - 0.14826E+01, 0.14848E+01, 0.14870E+01, 0.14892E+01, 0.14913E+01,& - 0.14935E+01, 0.14957E+01, 0.14979E+01, 0.15001E+01, 0.15022E+01,& - 0.15044E+01, 0.15066E+01, 0.15087E+01, 0.15109E+01, 0.15130E+01,& - 0.15152E+01, 0.15174E+01, 0.15195E+01, 0.15217E+01, 0.15238E+01,& - 0.15260E+01, 0.15281E+01, 0.15302E+01, 0.15324E+01, 0.15345E+01,& - 0.15366E+01, 0.15388E+01, 0.15409E+01, 0.15430E+01, 0.15451E+01,& - 0.15473E+01, 0.15494E+01, 0.15515E+01, 0.15536E+01, 0.15557E+01,& - 0.15578E+01, 0.15599E+01, 0.15621E+01, 0.15642E+01, 0.15720E+01/ - - DATA (BNC12M (IA),IA=601,700)/ & - 0.15892E+01, 0.16098E+01, 0.16302E+01, 0.16504E+01, 0.16704E+01,& - 0.16902E+01, 0.17098E+01, 0.17291E+01, 0.17483E+01, 0.17673E+01,& - 0.17861E+01, 0.18047E+01, 0.18232E+01, 0.18415E+01, 0.18596E+01,& - 0.18775E+01, 0.18953E+01, 0.19129E+01, 0.19304E+01, 0.19477E+01,& - 0.19648E+01, 0.19818E+01, 0.19987E+01, 0.20154E+01, 0.20320E+01,& - 0.20484E+01, 0.20647E+01, 0.20809E+01, 0.20969E+01, 0.21128E+01,& - 0.21286E+01, 0.21443E+01, 0.21598E+01, 0.21752E+01, 0.21905E+01,& - 0.22057E+01, 0.22208E+01, 0.22357E+01, 0.22506E+01, 0.22653E+01,& - 0.22800E+01, 0.22945E+01, 0.23089E+01, 0.23232E+01, 0.23374E+01,& - 0.23515E+01, 0.23656E+01, 0.23795E+01, 0.23933E+01, 0.24071E+01,& - 0.24207E+01, 0.24343E+01, 0.24477E+01, 0.24611E+01, 0.24744E+01,& - 0.24876E+01, 0.25007E+01, 0.25138E+01, 0.25267E+01, 0.25396E+01,& - 0.25524E+01, 0.25651E+01, 0.25778E+01, 0.25903E+01, 0.26028E+01,& - 0.26152E+01, 0.26276E+01, 0.26398E+01, 0.26520E+01, 0.26642E+01,& - 0.26762E+01, 0.26882E+01, 0.27001E+01, 0.27120E+01, 0.27238E+01,& - 0.27355E+01, 0.27472E+01, 0.27588E+01, 0.27703E+01, 0.27818E+01,& - 0.27932E+01, 0.28045E+01, 0.28158E+01, 0.28270E+01, 0.28382E+01,& - 0.28493E+01, 0.28604E+01, 0.28714E+01, 0.28823E+01, 0.28932E+01,& - 0.29040E+01, 0.29148E+01, 0.29256E+01, 0.29362E+01, 0.29468E+01,& - 0.29574E+01, 0.29679E+01, 0.29784E+01, 0.29888E+01, 0.29992E+01/ - - DATA (BNC12M(IA),IA=701,741)/ & - 0.30095E+01, 0.30198E+01, 0.30300E+01, 0.30402E+01, 0.30503E+01,& - 0.30604E+01, 0.30705E+01, 0.30804E+01, 0.30904E+01, 0.31003E+01,& - 0.31102E+01, 0.31200E+01, 0.31298E+01, 0.31395E+01, 0.31492E+01,& - 0.31588E+01, 0.31684E+01, 0.31780E+01, 0.31875E+01, 0.31970E+01,& - 0.32065E+01, 0.32159E+01, 0.32252E+01, 0.32346E+01, 0.32439E+01,& - 0.32531E+01, 0.32623E+01, 0.32715E+01, 0.32807E+01, 0.32898E+01,& - 0.32988E+01, 0.33079E+01, 0.33169E+01, 0.33258E+01, 0.33348E+01,& - 0.33436E+01, 0.33525E+01, 0.33613E+01, 0.33701E+01, 0.33789E+01,& - 0.33876E+01 / -! -! ** (NH4)3H(SO4)2 -! - DATA (BNC13M (IA),IA= 1,100)/ & - -0.79876E-01,-0.14479E+00,-0.19002E+00,-0.22052E+00,-0.24382E+00,& - -0.26276E+00,-0.27871E+00,-0.29249E+00,-0.30460E+00,-0.31540E+00,& - -0.32512E+00,-0.33395E+00,-0.34203E+00,-0.34946E+00,-0.35632E+00,& - -0.36270E+00,-0.36864E+00,-0.37419E+00,-0.37939E+00,-0.38427E+00,& - -0.38886E+00,-0.39320E+00,-0.39728E+00,-0.40115E+00,-0.40481E+00,& - -0.40828E+00,-0.41157E+00,-0.41469E+00,-0.41766E+00,-0.42048E+00,& - -0.42316E+00,-0.42571E+00,-0.42814E+00,-0.43045E+00,-0.43265E+00,& - -0.43474E+00,-0.43673E+00,-0.43863E+00,-0.44044E+00,-0.44216E+00,& - -0.44379E+00,-0.44535E+00,-0.44683E+00,-0.44824E+00,-0.44958E+00,& - -0.45085E+00,-0.45205E+00,-0.45320E+00,-0.45428E+00,-0.45531E+00,& - -0.45628E+00,-0.45720E+00,-0.45807E+00,-0.45888E+00,-0.45966E+00,& - -0.46038E+00,-0.46106E+00,-0.46170E+00,-0.46230E+00,-0.46285E+00,& - -0.46337E+00,-0.46385E+00,-0.46430E+00,-0.46471E+00,-0.46508E+00,& - -0.46542E+00,-0.46574E+00,-0.46602E+00,-0.46627E+00,-0.46649E+00,& - -0.46668E+00,-0.46684E+00,-0.46698E+00,-0.46710E+00,-0.46718E+00,& - -0.46724E+00,-0.46728E+00,-0.46730E+00,-0.46729E+00,-0.46726E+00,& - -0.46720E+00,-0.46713E+00,-0.46703E+00,-0.46691E+00,-0.46678E+00,& - -0.46662E+00,-0.46644E+00,-0.46625E+00,-0.46604E+00,-0.46580E+00,& - -0.46556E+00,-0.46529E+00,-0.46501E+00,-0.46471E+00,-0.46439E+00,& - -0.46406E+00,-0.46372E+00,-0.46335E+00,-0.46298E+00,-0.46259E+00/ - - DATA (BNC13M (IA),IA=101,200)/ & - -0.46219E+00,-0.46177E+00,-0.46134E+00,-0.46090E+00,-0.46045E+00,& - -0.45998E+00,-0.45951E+00,-0.45902E+00,-0.45852E+00,-0.45801E+00,& - -0.45749E+00,-0.45697E+00,-0.45643E+00,-0.45588E+00,-0.45533E+00,& - -0.45477E+00,-0.45420E+00,-0.45362E+00,-0.45303E+00,-0.45244E+00,& - -0.45191E+00,-0.45130E+00,-0.45068E+00,-0.45006E+00,-0.44943E+00,& - -0.44879E+00,-0.44815E+00,-0.44751E+00,-0.44686E+00,-0.44621E+00,& - -0.44555E+00,-0.44489E+00,-0.44423E+00,-0.44356E+00,-0.44289E+00,& - -0.44221E+00,-0.44154E+00,-0.44085E+00,-0.44017E+00,-0.43948E+00,& - -0.43879E+00,-0.43810E+00,-0.43740E+00,-0.43670E+00,-0.43600E+00,& - -0.43530E+00,-0.43459E+00,-0.43388E+00,-0.43317E+00,-0.43246E+00,& - -0.43174E+00,-0.43103E+00,-0.43031E+00,-0.42959E+00,-0.42886E+00,& - -0.42814E+00,-0.42741E+00,-0.42669E+00,-0.42596E+00,-0.42523E+00,& - -0.42449E+00,-0.42376E+00,-0.42302E+00,-0.42229E+00,-0.42155E+00,& - -0.42081E+00,-0.42007E+00,-0.41933E+00,-0.41859E+00,-0.41785E+00,& - -0.41711E+00,-0.41636E+00,-0.41562E+00,-0.41487E+00,-0.41412E+00,& - -0.41337E+00,-0.41263E+00,-0.41188E+00,-0.41113E+00,-0.41038E+00,& - -0.40962E+00,-0.40887E+00,-0.40812E+00,-0.40737E+00,-0.40661E+00,& - -0.40586E+00,-0.40511E+00,-0.40435E+00,-0.40360E+00,-0.40284E+00,& - -0.40209E+00,-0.40133E+00,-0.40057E+00,-0.39982E+00,-0.39906E+00,& - -0.39830E+00,-0.39755E+00,-0.39679E+00,-0.39603E+00,-0.39527E+00/ - - DATA (BNC13M (IA),IA=201,300)/ & - -0.39452E+00,-0.39376E+00,-0.39300E+00,-0.39224E+00,-0.39148E+00,& - -0.39072E+00,-0.38997E+00,-0.38921E+00,-0.38845E+00,-0.38769E+00,& - -0.38693E+00,-0.38617E+00,-0.38542E+00,-0.38466E+00,-0.38390E+00,& - -0.38314E+00,-0.38238E+00,-0.38162E+00,-0.38087E+00,-0.38011E+00,& - -0.37935E+00,-0.37859E+00,-0.37784E+00,-0.37708E+00,-0.37632E+00,& - -0.37556E+00,-0.37481E+00,-0.37405E+00,-0.37329E+00,-0.37254E+00,& - -0.37178E+00,-0.37103E+00,-0.37027E+00,-0.36952E+00,-0.36876E+00,& - -0.36801E+00,-0.36725E+00,-0.36650E+00,-0.36574E+00,-0.36499E+00,& - -0.36423E+00,-0.36348E+00,-0.36273E+00,-0.36198E+00,-0.36122E+00,& - -0.36047E+00,-0.35972E+00,-0.35897E+00,-0.35822E+00,-0.35747E+00,& - -0.35672E+00,-0.35597E+00,-0.35522E+00,-0.35447E+00,-0.35372E+00,& - -0.35297E+00,-0.35222E+00,-0.35147E+00,-0.35072E+00,-0.34998E+00,& - -0.34923E+00,-0.34848E+00,-0.34774E+00,-0.34699E+00,-0.34624E+00,& - -0.34550E+00,-0.34475E+00,-0.34401E+00,-0.34327E+00,-0.34252E+00,& - -0.34178E+00,-0.34104E+00,-0.34029E+00,-0.33955E+00,-0.33881E+00,& - -0.33807E+00,-0.33733E+00,-0.33659E+00,-0.33585E+00,-0.33511E+00,& - -0.33437E+00,-0.33363E+00,-0.33289E+00,-0.33216E+00,-0.33142E+00,& - -0.33068E+00,-0.32994E+00,-0.32921E+00,-0.32847E+00,-0.32774E+00,& - -0.32700E+00,-0.32627E+00,-0.32553E+00,-0.32480E+00,-0.32407E+00,& - -0.32334E+00,-0.32260E+00,-0.32187E+00,-0.32114E+00,-0.32041E+00/ - - DATA (BNC13M (IA),IA=301,400)/ & - -0.31968E+00,-0.31895E+00,-0.31822E+00,-0.31749E+00,-0.31676E+00,& - -0.31603E+00,-0.31531E+00,-0.31458E+00,-0.31385E+00,-0.31313E+00,& - -0.31240E+00,-0.31167E+00,-0.31095E+00,-0.31023E+00,-0.30950E+00,& - -0.30878E+00,-0.30805E+00,-0.30733E+00,-0.30661E+00,-0.30589E+00,& - -0.30517E+00,-0.30445E+00,-0.30373E+00,-0.30301E+00,-0.30229E+00,& - -0.30157E+00,-0.30085E+00,-0.30013E+00,-0.29941E+00,-0.29870E+00,& - -0.29798E+00,-0.29726E+00,-0.29655E+00,-0.29583E+00,-0.29512E+00,& - -0.29440E+00,-0.29369E+00,-0.29298E+00,-0.29226E+00,-0.29155E+00,& - -0.29084E+00,-0.29013E+00,-0.28942E+00,-0.28871E+00,-0.28800E+00,& - -0.28729E+00,-0.28658E+00,-0.28587E+00,-0.28516E+00,-0.28445E+00,& - -0.28375E+00,-0.28304E+00,-0.28233E+00,-0.28163E+00,-0.28092E+00,& - -0.28022E+00,-0.27951E+00,-0.27881E+00,-0.27811E+00,-0.27740E+00,& - -0.27670E+00,-0.27600E+00,-0.27530E+00,-0.27459E+00,-0.27389E+00,& - -0.27319E+00,-0.27249E+00,-0.27179E+00,-0.27110E+00,-0.27040E+00,& - -0.26970E+00,-0.26900E+00,-0.26831E+00,-0.26761E+00,-0.26691E+00,& - -0.26622E+00,-0.26552E+00,-0.26483E+00,-0.26413E+00,-0.26344E+00,& - -0.26275E+00,-0.26205E+00,-0.26136E+00,-0.26067E+00,-0.25998E+00,& - -0.25929E+00,-0.25860E+00,-0.25791E+00,-0.25722E+00,-0.25653E+00,& - -0.25584E+00,-0.25515E+00,-0.25446E+00,-0.25378E+00,-0.25309E+00,& - -0.25240E+00,-0.25172E+00,-0.25103E+00,-0.25035E+00,-0.24966E+00/ - - DATA (BNC13M (IA),IA=401,500)/ & - -0.24898E+00,-0.24829E+00,-0.24761E+00,-0.24693E+00,-0.24625E+00,& - -0.24556E+00,-0.24488E+00,-0.24420E+00,-0.24352E+00,-0.24284E+00,& - -0.24216E+00,-0.24148E+00,-0.24080E+00,-0.24013E+00,-0.23945E+00,& - -0.23877E+00,-0.23809E+00,-0.23742E+00,-0.23674E+00,-0.23607E+00,& - -0.23539E+00,-0.23472E+00,-0.23404E+00,-0.23337E+00,-0.23270E+00,& - -0.23202E+00,-0.23135E+00,-0.23068E+00,-0.23001E+00,-0.22934E+00,& - -0.22867E+00,-0.22800E+00,-0.22733E+00,-0.22666E+00,-0.22599E+00,& - -0.22532E+00,-0.22465E+00,-0.22398E+00,-0.22332E+00,-0.22265E+00,& - -0.22198E+00,-0.22132E+00,-0.22065E+00,-0.21999E+00,-0.21932E+00,& - -0.21866E+00,-0.21799E+00,-0.21733E+00,-0.21667E+00,-0.21601E+00,& - -0.21534E+00,-0.21468E+00,-0.21402E+00,-0.21336E+00,-0.21270E+00,& - -0.21204E+00,-0.21138E+00,-0.21072E+00,-0.21006E+00,-0.20941E+00,& - -0.20875E+00,-0.20809E+00,-0.20743E+00,-0.20678E+00,-0.20612E+00,& - -0.20547E+00,-0.20481E+00,-0.20416E+00,-0.20350E+00,-0.20285E+00,& - -0.20219E+00,-0.20154E+00,-0.20089E+00,-0.20024E+00,-0.19958E+00,& - -0.19893E+00,-0.19828E+00,-0.19763E+00,-0.19698E+00,-0.19633E+00,& - -0.19568E+00,-0.19503E+00,-0.19438E+00,-0.19374E+00,-0.19309E+00,& - -0.19244E+00,-0.19179E+00,-0.19115E+00,-0.19050E+00,-0.18986E+00,& - -0.18921E+00,-0.18857E+00,-0.18792E+00,-0.18728E+00,-0.18663E+00,& - -0.18599E+00,-0.18535E+00,-0.18470E+00,-0.18406E+00,-0.18342E+00/ - - DATA (BNC13M (IA),IA=501,600)/ & - -0.18278E+00,-0.18214E+00,-0.18150E+00,-0.18086E+00,-0.18022E+00,& - -0.17958E+00,-0.17894E+00,-0.17830E+00,-0.17766E+00,-0.17703E+00,& - -0.17639E+00,-0.17575E+00,-0.17511E+00,-0.17448E+00,-0.17384E+00,& - -0.17321E+00,-0.17257E+00,-0.17194E+00,-0.17130E+00,-0.17067E+00,& - -0.17004E+00,-0.16940E+00,-0.16877E+00,-0.16814E+00,-0.16751E+00,& - -0.16687E+00,-0.16624E+00,-0.16561E+00,-0.16498E+00,-0.16435E+00,& - -0.16372E+00,-0.16309E+00,-0.16247E+00,-0.16184E+00,-0.16121E+00,& - -0.16058E+00,-0.15995E+00,-0.15933E+00,-0.15870E+00,-0.15807E+00,& - -0.15745E+00,-0.15682E+00,-0.15620E+00,-0.15557E+00,-0.15495E+00,& - -0.15432E+00,-0.15370E+00,-0.15308E+00,-0.15245E+00,-0.15183E+00,& - -0.15121E+00,-0.15059E+00,-0.14997E+00,-0.14935E+00,-0.14873E+00,& - -0.14811E+00,-0.14749E+00,-0.14687E+00,-0.14625E+00,-0.14563E+00,& - -0.14501E+00,-0.14439E+00,-0.14377E+00,-0.14316E+00,-0.14254E+00,& - -0.14192E+00,-0.14131E+00,-0.14069E+00,-0.14007E+00,-0.13946E+00,& - -0.13885E+00,-0.13823E+00,-0.13762E+00,-0.13700E+00,-0.13639E+00,& - -0.13578E+00,-0.13516E+00,-0.13455E+00,-0.13394E+00,-0.13333E+00,& - -0.13272E+00,-0.13211E+00,-0.13149E+00,-0.13088E+00,-0.13027E+00,& - -0.12966E+00,-0.12906E+00,-0.12845E+00,-0.12784E+00,-0.12723E+00,& - -0.12662E+00,-0.12601E+00,-0.12541E+00,-0.12480E+00,-0.12419E+00,& - -0.12359E+00,-0.12298E+00,-0.12238E+00,-0.12177E+00,-0.11951E+00/ - - DATA (BNC13M (IA),IA=601,700)/ & - -0.11454E+00,-0.10855E+00,-0.10259E+00,-0.96662E-01,-0.90768E-01,& - -0.84905E-01,-0.79073E-01,-0.73271E-01,-0.67500E-01,-0.61758E-01,& - -0.56045E-01,-0.50361E-01,-0.44704E-01,-0.39075E-01,-0.33474E-01,& - -0.27900E-01,-0.22352E-01,-0.16830E-01,-0.11333E-01,-0.58624E-02,& - -0.41641E-03, 0.50053E-02, 0.10403E-01, 0.15776E-01, 0.21127E-01,& - 0.26453E-01, 0.31758E-01, 0.37040E-01, 0.42299E-01, 0.47537E-01,& - 0.52753E-01, 0.57948E-01, 0.63123E-01, 0.68276E-01, 0.73409E-01,& - 0.78522E-01, 0.83615E-01, 0.88689E-01, 0.93744E-01, 0.98779E-01,& - 0.10380E+00, 0.10879E+00, 0.11377E+00, 0.11874E+00, 0.12368E+00,& - 0.12861E+00, 0.13352E+00, 0.13841E+00, 0.14328E+00, 0.14814E+00,& - 0.15298E+00, 0.15781E+00, 0.16262E+00, 0.16741E+00, 0.17219E+00,& - 0.17695E+00, 0.18170E+00, 0.18643E+00, 0.19115E+00, 0.19585E+00,& - 0.20054E+00, 0.20521E+00, 0.20987E+00, 0.21452E+00, 0.21915E+00,& - 0.22376E+00, 0.22837E+00, 0.23296E+00, 0.23753E+00, 0.24210E+00,& - 0.24665E+00, 0.25119E+00, 0.25571E+00, 0.26022E+00, 0.26472E+00,& - 0.26921E+00, 0.27369E+00, 0.27815E+00, 0.28260E+00, 0.28704E+00,& - 0.29147E+00, 0.29589E+00, 0.30029E+00, 0.30468E+00, 0.30907E+00,& - 0.31344E+00, 0.31780E+00, 0.32215E+00, 0.32649E+00, 0.33081E+00,& - 0.33513E+00, 0.33944E+00, 0.34374E+00, 0.34802E+00, 0.35230E+00,& - 0.35656E+00, 0.36082E+00, 0.36507E+00, 0.36930E+00, 0.37353E+00/ - - DATA (BNC13M(IA),IA=701,741)/ & - 0.37775E+00, 0.38196E+00, 0.38616E+00, 0.39035E+00, 0.39453E+00,& - 0.39870E+00, 0.40286E+00, 0.40701E+00, 0.41116E+00, 0.41529E+00,& - 0.41942E+00, 0.42354E+00, 0.42764E+00, 0.43175E+00, 0.43584E+00,& - 0.43992E+00, 0.44400E+00, 0.44807E+00, 0.45213E+00, 0.45618E+00,& - 0.46022E+00, 0.46426E+00, 0.46828E+00, 0.47230E+00, 0.47632E+00,& - 0.48032E+00, 0.48432E+00, 0.48831E+00, 0.49229E+00, 0.49626E+00,& - 0.50023E+00, 0.50419E+00, 0.50814E+00, 0.51209E+00, 0.51603E+00,& - 0.51996E+00, 0.52388E+00, 0.52780E+00, 0.53171E+00, 0.53562E+00,& - 0.53951E+00 / -! END - - -!======================================================================= -! -! *** ISORROPIA CODE -! *** BLOCK DATA EXPON -! *** CONTAINS DATA FOR EXPONENT ARRAYS NEEDED IN FUNCTION EXP10 -! -! *** COPYRIGHT 1996-2006, UNIVERSITY OF MIAMI, CARNEGIE MELLON UNIVERSITY, -! *** GEORGIA INSTITUTE OF TECHNOLOGY -! *** WRITTEN BY ATHANASIOS NENES -! *** UPDATED BY CHRISTOS FOUNTOUKIS -! -!======================================================================= -! -! BLOCK DATA EXPON -! -! *** Common block definition -! - REAL AINT10(20), ADEC10(200) -! -! *** Integer part -! - DATA AINT10/ & - 0.1000E-08, 0.1000E-07, 0.1000E-06, 0.1000E-05, 0.1000E-04,& - 0.1000E-03, 0.1000E-02, 0.1000E-01, 0.1000E+00, 0.1000E+01,& - 0.1000E+02, 0.1000E+03, 0.1000E+04, 0.1000E+05, 0.1000E+06,& - 0.1000E+07, 0.1000E+08, 0.1000E+09, 0.1000E+10, 0.1000E+11/ -! -! ***decimal part -! - DATA (ADEC10(IA),IA=1,100)/ & - 0.1023E+00, 0.1047E+00, 0.1072E+00, 0.1096E+00, 0.1122E+00,& - 0.1148E+00, 0.1175E+00, 0.1202E+00, 0.1230E+00, 0.1259E+00,& - 0.1288E+00, 0.1318E+00, 0.1349E+00, 0.1380E+00, 0.1413E+00,& - 0.1445E+00, 0.1479E+00, 0.1514E+00, 0.1549E+00, 0.1585E+00,& - 0.1622E+00, 0.1660E+00, 0.1698E+00, 0.1738E+00, 0.1778E+00,& - 0.1820E+00, 0.1862E+00, 0.1905E+00, 0.1950E+00, 0.1995E+00,& - 0.2042E+00, 0.2089E+00, 0.2138E+00, 0.2188E+00, 0.2239E+00,& - 0.2291E+00, 0.2344E+00, 0.2399E+00, 0.2455E+00, 0.2512E+00,& - 0.2570E+00, 0.2630E+00, 0.2692E+00, 0.2754E+00, 0.2818E+00,& - 0.2884E+00, 0.2951E+00, 0.3020E+00, 0.3090E+00, 0.3162E+00,& - 0.3236E+00, 0.3311E+00, 0.3388E+00, 0.3467E+00, 0.3548E+00,& - 0.3631E+00, 0.3715E+00, 0.3802E+00, 0.3890E+00, 0.3981E+00,& - 0.4074E+00, 0.4169E+00, 0.4266E+00, 0.4365E+00, 0.4467E+00,& - 0.4571E+00, 0.4677E+00, 0.4786E+00, 0.4898E+00, 0.5012E+00,& - 0.5129E+00, 0.5248E+00, 0.5370E+00, 0.5495E+00, 0.5623E+00,& - 0.5754E+00, 0.5888E+00, 0.6026E+00, 0.6166E+00, 0.6310E+00,& - 0.6457E+00, 0.6607E+00, 0.6761E+00, 0.6918E+00, 0.7079E+00,& - 0.7244E+00, 0.7413E+00, 0.7586E+00, 0.7762E+00, 0.7943E+00,& - 0.8128E+00, 0.8318E+00, 0.8511E+00, 0.8710E+00, 0.8913E+00,& - 0.9120E+00, 0.9333E+00, 0.9550E+00, 0.9772E+00, 0.1000E+01/ - - DATA (ADEC10(IA),IA=101,200)/ & - 0.1023E+01, 0.1047E+01, 0.1072E+01, 0.1096E+01, 0.1122E+01,& - 0.1148E+01, 0.1175E+01, 0.1202E+01, 0.1230E+01, 0.1259E+01,& - 0.1288E+01, 0.1318E+01, 0.1349E+01, 0.1380E+01, 0.1413E+01,& - 0.1445E+01, 0.1479E+01, 0.1514E+01, 0.1549E+01, 0.1585E+01,& - 0.1622E+01, 0.1660E+01, 0.1698E+01, 0.1738E+01, 0.1778E+01,& - 0.1820E+01, 0.1862E+01, 0.1905E+01, 0.1950E+01, 0.1995E+01,& - 0.2042E+01, 0.2089E+01, 0.2138E+01, 0.2188E+01, 0.2239E+01,& - 0.2291E+01, 0.2344E+01, 0.2399E+01, 0.2455E+01, 0.2512E+01,& - 0.2570E+01, 0.2630E+01, 0.2692E+01, 0.2754E+01, 0.2818E+01,& - 0.2884E+01, 0.2951E+01, 0.3020E+01, 0.3090E+01, 0.3162E+01,& - 0.3236E+01, 0.3311E+01, 0.3388E+01, 0.3467E+01, 0.3548E+01,& - 0.3631E+01, 0.3715E+01, 0.3802E+01, 0.3890E+01, 0.3981E+01,& - 0.4074E+01, 0.4169E+01, 0.4266E+01, 0.4365E+01, 0.4467E+01,& - 0.4571E+01, 0.4677E+01, 0.4786E+01, 0.4898E+01, 0.5012E+01,& - 0.5129E+01, 0.5248E+01, 0.5370E+01, 0.5495E+01, 0.5623E+01,& - 0.5754E+01, 0.5888E+01, 0.6026E+01, 0.6166E+01, 0.6310E+01,& - 0.6457E+01, 0.6607E+01, 0.6761E+01, 0.6918E+01, 0.7079E+01,& - 0.7244E+01, 0.7413E+01, 0.7586E+01, 0.7762E+01, 0.7943E+01,& - 0.8128E+01, 0.8318E+01, 0.8511E+01, 0.8710E+01, 0.8913E+01,& - 0.9120E+01, 0.9333E+01, 0.9550E+01, 0.9772E+01, 0.1000E+02/ -! -! *** END OF BLOCK DATA EXPON ****************************************** -! -! END - -END module module_data_isrpia diff --git a/wrfv2_fire/chem/module_data_isrpia_asrc.F b/wrfv2_fire/chem/module_data_isrpia_asrc.F new file mode 100755 index 00000000..e2d5a084 --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_asrc.F @@ -0,0 +1,70 @@ + + MODULE ASRC + DOUBLE PRECISION :: ASRAT(280), ASSO4(14) + + DATA ASSO4/1.0E-9, 2.5E-9, 5.0E-9, 7.5E-9, 1.0E-8, & + 2.5E-8, 5.0E-8, 7.5E-8, 1.0E-7, 2.5E-7, & + 5.0E-7, 7.5E-7, 1.0E-6, 5.0E-6/ +! + DATA (ASRAT(I), I=1,100)/ & + 1.020464, 0.9998130, 0.9960167, 0.9984423, 1.004004, & + 1.010885, 1.018356, 1.026726, 1.034268, 1.043846, & + 1.052933, 1.062230, 1.062213, 1.080050, 1.088350, & + 1.096603, 1.104289, 1.111745, 1.094662, 1.121594, & + 1.268909, 1.242444, 1.233815, 1.232088, 1.234020, & + 1.238068, 1.243455, 1.250636, 1.258734, 1.267543, & + 1.276948, 1.286642, 1.293337, 1.305592, 1.314726, & + 1.323463, 1.333258, 1.343604, 1.344793, 1.355571, & + 1.431463, 1.405204, 1.395791, 1.393190, 1.394403, & + 1.398107, 1.403811, 1.411744, 1.420560, 1.429990, & + 1.439742, 1.449507, 1.458986, 1.468403, 1.477394, & + 1.487373, 1.495385, 1.503854, 1.512281, 1.520394, & + 1.514464, 1.489699, 1.480686, 1.478187, 1.479446, & + 1.483310, 1.489316, 1.497517, 1.506501, 1.515816, & + 1.524724, 1.533950, 1.542758, 1.551730, 1.559587, & + 1.568343, 1.575610, 1.583140, 1.590440, 1.596481, & + 1.567743, 1.544426, 1.535928, 1.533645, 1.535016, & + 1.539003, 1.545124, 1.553283, 1.561886, 1.570530, & + 1.579234, 1.587813, 1.595956, 1.603901, 1.611349, & + 1.618833, 1.625819, 1.632543, 1.639032, 1.645276/ + DATA (ASRAT(I), I=101,200)/ & + 1.707390, 1.689553, 1.683198, 1.681810, 1.683490, & + 1.687477, 1.693148, 1.700084, 1.706917, 1.713507, & + 1.719952, 1.726190, 1.731985, 1.737544, 1.742673, & + 1.747756, 1.752431, 1.756890, 1.761141, 1.765190, & + 1.785657, 1.771851, 1.767063, 1.766229, 1.767901, & + 1.771455, 1.776223, 1.781769, 1.787065, 1.792081, & + 1.796922, 1.801561, 1.805832, 1.809896, 1.813622, & + 1.817292, 1.820651, 1.823841, 1.826871, 1.829745, & + 1.822215, 1.810497, 1.806496, 1.805898, 1.807480, & + 1.810684, 1.814860, 1.819613, 1.824093, 1.828306, & + 1.832352, 1.836209, 1.839748, 1.843105, 1.846175, & + 1.849192, 1.851948, 1.854574, 1.857038, 1.859387, & + 1.844588, 1.834208, 1.830701, 1.830233, 1.831727, & + 1.834665, 1.838429, 1.842658, 1.846615, 1.850321, & + 1.853869, 1.857243, 1.860332, 1.863257, 1.865928, & + 1.868550, 1.870942, 1.873208, 1.875355, 1.877389, & + 1.899556, 1.892637, 1.890367, 1.890165, 1.891317, & + 1.893436, 1.896036, 1.898872, 1.901485, 1.903908, & + 1.906212, 1.908391, 1.910375, 1.912248, 1.913952, & + 1.915621, 1.917140, 1.918576, 1.919934, 1.921220/ + + DATA (ASRAT(I), I=201,280)/ & + 1.928264, 1.923245, 1.921625, 1.921523, 1.922421, & + 1.924016, 1.925931, 1.927991, 1.929875, 1.931614, & + 1.933262, 1.934816, 1.936229, 1.937560, 1.938769, & + 1.939951, 1.941026, 1.942042, 1.943003, 1.943911, & + 1.941205, 1.937060, 1.935734, 1.935666, 1.936430, & + 1.937769, 1.939359, 1.941061, 1.942612, 1.944041, & + 1.945393, 1.946666, 1.947823, 1.948911, 1.949900, & + 1.950866, 1.951744, 1.952574, 1.953358, 1.954099, & + 1.948985, 1.945372, 1.944221, 1.944171, 1.944850, & + 1.946027, 1.947419, 1.948902, 1.950251, 1.951494, & + 1.952668, 1.953773, 1.954776, 1.955719, 1.956576, & + 1.957413, 1.958174, 1.958892, 1.959571, 1.960213, & + 1.977193, 1.975540, 1.975023, 1.975015, 1.975346, & + 1.975903, 1.976547, 1.977225, 1.977838, 1.978401, & + 1.978930, 1.979428, 1.979879, 1.980302, 1.980686, & + 1.981060, 1.981401, 1.981722, 1.982025, 1.982312/ + + END MODULE ASRC diff --git a/wrfv2_fire/chem/module_data_isrpia_caseg.F b/wrfv2_fire/chem/module_data_isrpia_caseg.F new file mode 100755 index 00000000..503eec45 --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_caseg.F @@ -0,0 +1,7 @@ + MODULE CASEG + DOUBLE PRECISION :: CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, LAMDA, & + PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, & + A1, A2, A3, A4, A5, A6, A7 + + END Module CASEG + diff --git a/wrfv2_fire/chem/module_data_isrpia_casej.F b/wrfv2_fire/chem/module_data_isrpia_casej.F new file mode 100755 index 00000000..b715d28d --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_casej.F @@ -0,0 +1,6 @@ + MODULE CASEJ + DOUBLE PRECISION :: HI1, CHI2, CHI3, LAMDA, KAPA, PSI1, PSI2, PSI3, & + A1, A2, A3 + + END Module CASEJ + diff --git a/wrfv2_fire/chem/module_data_isrpia_data.F b/wrfv2_fire/chem/module_data_isrpia_data.F new file mode 100755 index 00000000..633c8f73 --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_data.F @@ -0,0 +1,366 @@ +!========================================================================== +!========================================================================== +! Developed by Ying Pan and Yang Zhang, NCSU, Oct. 2009 +! to couple CB05 with MADE/SORGAM-AQ-ISORROPIA +!========================================================================== +!========================================================================== + + MODULE module_data_isrpia_data + +!======MODULE OTHR========================================================= + INTEGER,PRIVATE :: NIONS,NCOMP,NPAIR + PARAMETER (NCOMP=5, NIONS=7, NPAIR=13) + + DOUBLE PRECISION & + R, IMW(NIONS), WMW(NCOMP), SMW(NPAIR) + + DATA R/82.0567D-6/ + DATA SMW/58.5,142.,85.0,132.,80.0,53.5,98.0,98.0,115.,63.0, & + 36.5,120.,247./ & + IMW/ 1.0,23.0,18.0,35.5,96.0,97.0,63.0/, & + WMW/23.0,98.0,17.0,63.0,36.5/ +!=====END MODULE OTH====================================================== + +!=====MODULE CGEN========================================================= + + CHARACTER VERSION*15 + DOUBLE PRECISION GREAT, TINY, TINY2, ZERO, ONE + DATA & + TINY/1D-20/, GREAT/1D10/, ZERO/0.0D0/, ONE/1.0D0/, & + TINY2/1D-11/ + DATA VERSION /'1.7 (03/26/07)'/ + +!=====END MODULE CGEN===================================================== + +!=====MODULE SOLN========================================================= + + DOUBLE PRECISION EPS, MAXIT, NSWEEP, NDIV, ICLACT +! DATA R/82.0567D-6/, EPS/1D-6/, MAXIT/100/, + DATA EPS/1D-6/, MAXIT/100/,NSWEEP/4/,NDIV/5/ + +!=====END MODULE SOLN===================================================== + +!=====module IONSdata===================================================== + +! INTEGER,private:: NPAIR +! INTEGER,private:: NIONS +! INTEGER,private:: NCOMP + INTEGER,private:: NGASAQ + INTEGER IACALC +! PARAMETER (NPAIR=13,NIONS=7,NCOMP=5,NGASAQ=3) + PARAMETER (NGASAQ=3) + + DOUBLE PRECISION MOLAL(NIONS), MOLALR(NPAIR), M0(NPAIR) + REAL IONIC + LOGICAL CALAOU, CALAIN, FRST, DRYF + DOUBLE PRECISION GAMA(NPAIR) + DOUBLE PRECISION ZZ(NPAIR) + DOUBLE PRECISION Z(NIONS) + DOUBLE PRECISION GAMOU(NPAIR) + DOUBLE PRECISION GAMIN(NPAIR) + DOUBLE PRECISION GASAQ(NGASAQ) + DOUBLE PRECISION EPSACT + DOUBLE PRECISION COH + DOUBLE PRECISION CHNO3 + DOUBLE PRECISION CHCL + DOUBLE PRECISION WATER + DATA MOLAL/NIONS*0.0D0/, MOLALR/NPAIR*0.0D0/, GAMA/NPAIR*0.1D0/, & + GAMOU/NPAIR*1D10/, GAMIN/NPAIR*1D10/, CALAIN/.TRUE./, & + CALAOU/.TRUE./, EPSACT/5D-2/ & !, ICLACT/0/, + IACALC/1/ !, WFTYP/2/ + DATA ZZ/1,2,1,2,1,1,2,1,1,1,1,1,2/, Z /1,1,1,1,2,1,1/ +! COMMON /IONS/ MOLAL(NIONS), MOLALR(NPAIR), GAMA(NPAIR), ZZ(NPAIR), +! & Z(NIONS), GAMOU(NPAIR), GAMIN(NPAIR),M0(NPAIR), +! & GASAQ(NGASAQ), +! & EPSACT, COH, CHNO3, CHCL, +! & WATER, IONIC, IACALC, +! & FRST, CALAIN, CALAOU, DRYF + + +!=====end module IONSdata================================================= + +!=====MODULE ZSRdata====================================================== + + INTEGER, PRIVATE :: NZSR + PARAMETER ( NZSR=100) + DOUBLE PRECISION AWAS(NZSR), AWSS(NZSR), AWAC(NZSR), AWSC(NZSR), & + AWAN(NZSR), AWSN(NZSR), AWSB(NZSR), AWAB(NZSR), & + AWSA(NZSR), AWLC(NZSR) + +! awas= ammonium sulfate + DATA AWAS/10*187.72, & + 158.13,134.41,115.37,100.10, 87.86, 78.00, 70.00, 63.45, 58.02, & + 53.46, & + 49.59, 46.26, 43.37, 40.84, 38.59, 36.59, 34.79, 33.16, 31.67, & + 30.31, & + 29.07, 27.91, 26.84, 25.84, 24.91, 24.03, 23.21, 22.44, 21.70, & + 21.01, & + 20.34, 19.71, 19.11, 18.54, 17.99, 17.46, 16.95, 16.46, 15.99, & + 15.54, & + 15.10, 14.67, 14.26, 13.86, 13.47, 13.09, 12.72, 12.36, 12.01, & + 11.67, & + 11.33, 11.00, 10.68, 10.37, 10.06, 9.75, 9.45, 9.15, 8.86, & + 8.57, & + 8.29, 8.01, 7.73, 7.45, 7.18, 6.91, 6.64, 6.37, 6.10, & + 5.83, & + 5.56, 5.29, 5.02, 4.74, 4.47, 4.19, 3.91, 3.63, 3.34, & + 3.05, & + 2.75, 2.45, 2.14, 1.83, 1.51, 1.19, 0.87, 0.56, 0.26, & + 0.1/ +! +! awsn= sodium nitrate +! + DATA AWSN/10*394.54, & + 338.91,293.01,254.73,222.61,195.56,172.76,153.53,137.32,123.65, & + 112.08, & + 102.26, 93.88, 86.68, 80.45, 75.02, 70.24, 66.02, 62.26, 58.89, & + 55.85, & + 53.09, 50.57, 48.26, 46.14, 44.17, 42.35, 40.65, 39.06, 37.57, & + 36.17, & + 34.85, 33.60, 32.42, 31.29, 30.22, 29.20, 28.22, 27.28, 26.39, & + 25.52, & + 24.69, 23.89, 23.12, 22.37, 21.65, 20.94, 20.26, 19.60, 18.96, & + 18.33, & + 17.72, 17.12, 16.53, 15.96, 15.40, 14.85, 14.31, 13.78, 13.26, & + 12.75, & + 12.25, 11.75, 11.26, 10.77, 10.29, 9.82, 9.35, 8.88, 8.42, & + 7.97, & + 7.52, 7.07, 6.62, 6.18, 5.75, 5.32, 4.89, 4.47, 4.05, & + 3.64, & + 3.24, 2.84, 2.45, 2.07, 1.70, 1.34, 0.99, 0.65, 0.31, & + 0.1/ +! +! awsc= sodium chloride +! + DATA AWSC/10*28.16, & + 27.17, 26.27, 25.45, 24.69, 23.98, 23.33, 22.72, 22.14, 21.59, & + 21.08, & + 20.58, 20.12, 19.67, 19.24, 18.82, 18.43, 18.04, 17.67, 17.32, & + 16.97, & + 16.63, 16.31, 15.99, 15.68, 15.38, 15.08, 14.79, 14.51, 14.24, & + 13.97, & + 13.70, 13.44, 13.18, 12.93, 12.68, 12.44, 12.20, 11.96, 11.73, & + 11.50, & + 11.27, 11.05, 10.82, 10.60, 10.38, 10.16, 9.95, 9.74, 9.52, & + 9.31, & + 9.10, 8.89, 8.69, 8.48, 8.27, 8.07, 7.86, 7.65, 7.45, & + 7.24, & + 7.04, 6.83, 6.62, 6.42, 6.21, 6.00, 5.79, 5.58, 5.36, & + 5.15, & + 4.93, 4.71, 4.48, 4.26, 4.03, 3.80, 3.56, 3.32, 3.07, & + 2.82, & + 2.57, 2.30, 2.04, 1.76, 1.48, 1.20, 0.91, 0.61, 0.30, & + 0.1/ +! +! awac= ammonium chloride +! + DATA AWAC/10*1209.00, & + 1067.60,949.27,848.62,761.82,686.04,619.16,559.55,505.92,457.25, & + 412.69, & + 371.55,333.21,297.13,262.81,229.78,197.59,165.98,135.49,108.57, & + 88.29, & + 74.40, 64.75, 57.69, 52.25, 47.90, 44.30, 41.27, 38.65, 36.36, & + 34.34, & + 32.52, 30.88, 29.39, 28.02, 26.76, 25.60, 24.51, 23.50, 22.55, & + 21.65, & + 20.80, 20.00, 19.24, 18.52, 17.83, 17.17, 16.54, 15.93, 15.35, & + 14.79, & + 14.25, 13.73, 13.22, 12.73, 12.26, 11.80, 11.35, 10.92, 10.49, & + 10.08, & + 9.67, 9.28, 8.89, 8.51, 8.14, 7.77, 7.42, 7.06, 6.72, & + 6.37, & + 6.03, 5.70, 5.37, 5.05, 4.72, 4.40, 4.08, 3.77, 3.45, & + 3.14, & + 2.82, 2.51, 2.20, 1.89, 1.57, 1.26, 0.94, 0.62, 0.31, & + 0.1/ +! +! awss= sodium sulfate +! + DATA AWSS/10*24.10, & + 23.17, 22.34, 21.58, 20.90, 20.27, 19.69, 19.15, 18.64, 18.17, & + 17.72, & + 17.30, 16.90, 16.52, 16.16, 15.81, 15.48, 15.16, 14.85, 14.55, & + 14.27, & + 13.99, 13.73, 13.47, 13.21, 12.97, 12.73, 12.50, 12.27, 12.05, & + 11.84, & + 11.62, 11.42, 11.21, 11.01, 10.82, 10.63, 10.44, 10.25, 10.07, & + 9.89, & + 9.71, 9.53, 9.36, 9.19, 9.02, 8.85, 8.68, 8.51, 8.35, & + 8.19, & + 8.02, 7.86, 7.70, 7.54, 7.38, 7.22, 7.06, 6.90, 6.74, & + 6.58, & + 6.42, 6.26, 6.10, 5.94, 5.78, 5.61, 5.45, 5.28, 5.11, & + 4.93, & + 4.76, 4.58, 4.39, 4.20, 4.01, 3.81, 3.60, 3.39, 3.16, & + 2.93, & + 2.68, 2.41, 2.13, 1.83, 1.52, 1.19, 0.86, 0.54, 0.25, & + 0.1/ +! +! awab= ammonium bisulfate +! + DATA AWAB/10*312.84, & + 271.43,237.19,208.52,184.28,163.64,145.97,130.79,117.72,106.42, & + 96.64, & + 88.16, 80.77, 74.33, 68.67, 63.70, 59.30, 55.39, 51.89, 48.76, & + 45.93, & + 43.38, 41.05, 38.92, 36.97, 35.18, 33.52, 31.98, 30.55, 29.22, & + 27.98, & + 26.81, 25.71, 24.67, 23.70, 22.77, 21.90, 21.06, 20.27, 19.52, & + 18.80, & + 18.11, 17.45, 16.82, 16.21, 15.63, 15.07, 14.53, 14.01, 13.51, & + 13.02, & + 12.56, 12.10, 11.66, 11.24, 10.82, 10.42, 10.04, 9.66, 9.29, & + 8.93, & + 8.58, 8.24, 7.91, 7.58, 7.26, 6.95, 6.65, 6.35, 6.05, & + 5.76, & + 5.48, 5.20, 4.92, 4.64, 4.37, 4.09, 3.82, 3.54, 3.27, & + 2.99, & + 2.70, 2.42, 2.12, 1.83, 1.52, 1.22, 0.90, 0.59, 0.28, & + 0.1/ +! +! awsa= sulfuric acid +! + DATA AWSA/34.00, 33.56, 29.22, 26.55, 24.61, 23.11, 21.89, 20.87, & + 19.99, 18.45, & + 17.83, 17.26, 16.73, 16.25, 15.80, 15.38, 14.98, 14.61, 14.26, & + 13.93, & + 13.61, 13.30, 13.01, 12.73, 12.47, 12.21, 11.96, 11.72, 11.49, & + 11.26, & + 11.04, 10.83, 10.62, 10.42, 10.23, 10.03, 9.85, 9.67, 9.49, & + 9.31, & + 9.14, 8.97, 8.81, 8.65, 8.49, 8.33, 8.18, 8.02, 7.87, & + 7.73, & + 7.58, 7.44, 7.29, 7.15, 7.01, 6.88, 6.74, 6.61, 6.47, & + 6.34, & + 6.21, 6.07, 5.94, 5.81, 5.68, 5.55, 5.43, 5.30, 5.17, & + 5.04, & + 4.91, 4.78, 4.65, 4.52, 4.39, 4.26, 4.13, 4.00, 3.86, & + 3.73, & + 3.59, 3.45, 3.31, 3.17, 3.02, 2.87, 2.71, 2.56, 2.39, & + 2.22, & + 2.05, 1.87, 1.68, 1.48, 1.27, 1.04, 0.80, 0.55, 0.28, & + 0.1/ +! +! awlc= (NH4)3H(SO4)2 +! + DATA AWLC/10*125.37, & + 110.10, 97.50, 86.98, 78.08, 70.49, 63.97, 58.33, 53.43, 49.14, & + 45.36, & + 42.03, 39.07, 36.44, 34.08, 31.97, 30.06, 28.33, 26.76, 25.32, & + 24.01, & + 22.81, 21.70, 20.67, 19.71, 18.83, 18.00, 17.23, 16.50, 15.82, & + 15.18, & + 14.58, 14.01, 13.46, 12.95, 12.46, 11.99, 11.55, 11.13, 10.72, & + 10.33, & + 9.96, 9.60, 9.26, 8.93, 8.61, 8.30, 8.00, 7.72, 7.44, & + 7.17, & + 6.91, 6.66, 6.42, 6.19, 5.96, 5.74, 5.52, 5.31, 5.11, & + 4.91, & + 4.71, 4.53, 4.34, 4.16, 3.99, 3.81, 3.64, 3.48, 3.31, & + 3.15, & + 2.99, 2.84, 2.68, 2.53, 2.37, 2.22, 2.06, 1.91, 1.75, & + 1.60, & + 1.44, 1.28, 1.12, 0.95, 0.79, 0.62, 0.45, 0.29, 0.14, & + 0.1/ +! +! awan= ammonium nitrate +! + DATA AWAN/10*960.19, & + 853.15,763.85,688.20,623.27,566.92,517.54,473.91,435.06,400.26, & + 368.89, & + 340.48,314.63,291.01,269.36,249.46,231.11,214.17,198.50,184.00, & + 170.58, & + 158.15,146.66,136.04,126.25,117.24,108.97,101.39, 94.45, 88.11, & + 82.33, & + 77.06, 72.25, 67.85, 63.84, 60.16, 56.78, 53.68, 50.81, 48.17, & + 45.71, & + 43.43, 41.31, 39.32, 37.46, 35.71, 34.06, 32.50, 31.03, 29.63, & + 28.30, & + 27.03, 25.82, 24.67, 23.56, 22.49, 21.47, 20.48, 19.53, 18.61, & + 17.72, & + 16.86, 16.02, 15.20, 14.41, 13.64, 12.89, 12.15, 11.43, 10.73, & + 10.05, & + 9.38, 8.73, 8.09, 7.47, 6.86, 6.27, 5.70, 5.15, 4.61, & + 4.09, & + 3.60, 3.12, 2.66, 2.23, 1.81, 1.41, 1.03, 0.67, 0.32, & + 0.1/ +! +! awsb= sodium bisulfate +! + DATA AWSB/10*55.99, & + 53.79, 51.81, 49.99, 48.31, 46.75, 45.28, 43.91, 42.62, 41.39, & + 40.22, & + 39.10, 38.02, 36.99, 36.00, 35.04, 34.11, 33.21, 32.34, 31.49, & + 30.65, & + 29.84, 29.04, 28.27, 27.50, 26.75, 26.01, 25.29, 24.57, 23.87, & + 23.17, & + 22.49, 21.81, 21.15, 20.49, 19.84, 19.21, 18.58, 17.97, 17.37, & + 16.77, & + 16.19, 15.63, 15.08, 14.54, 14.01, 13.51, 13.01, 12.53, 12.07, & + 11.62, & + 11.19, 10.77, 10.36, 9.97, 9.59, 9.23, 8.87, 8.53, 8.20, & + 7.88, & + 7.57, 7.27, 6.97, 6.69, 6.41, 6.14, 5.88, 5.62, 5.36, & + 5.11, & + 4.87, 4.63, 4.39, 4.15, 3.92, 3.68, 3.45, 3.21, 2.98, & + 2.74, & + 2.49, 2.24, 1.98, 1.72, 1.44, 1.16, 0.87, 0.57, 0.28, & + 0.1/ +! +! *** ZSR RELATIONSHIP PARAMETERS ************************************** + +!=====END MODULE ZSRdata================================================== + +!=====MODULE SALT========================================================= + + DOUBLE PRECISION CH2SO4 + DOUBLE PRECISION CNH42S4 + DOUBLE PRECISION CNH4HS4 + DOUBLE PRECISION CNACL + DOUBLE PRECISION CNA2SO4 + DOUBLE PRECISION CNANO3 + DOUBLE PRECISION CNH4NO3 + DOUBLE PRECISION CNH4CL + DOUBLE PRECISION CNAHSO4 + DOUBLE PRECISION CLC + +! COMMON /SALT/ CH2SO4, CNH42S4, CNH4HS4, CNACL, CNA2SO4, +! & CNANO3, CNH4NO3, CNH4CL, CNAHSO4, CLC + +!=====END MODULE SALT===================================================== + +!=====MODULE GAS========================================================== + + DOUBLE PRECISION GNH3 + DOUBLE PRECISION GHNO3 + DOUBLE PRECISION GHCL + +!=====END MODULE GA======================================================= + +!=====MODULE EQUK========================================================= + + DOUBLE PRECISION XK1 + DOUBLE PRECISION XK2 + DOUBLE PRECISION XK3 + DOUBLE PRECISION XK4 + DOUBLE PRECISION XK5 + DOUBLE PRECISION XK6 + DOUBLE PRECISION XK7 + DOUBLE PRECISION XK8 + DOUBLE PRECISION XK9 + DOUBLE PRECISION XK10 + DOUBLE PRECISION XK11 + DOUBLE PRECISION XK12 + DOUBLE PRECISION XK13 + DOUBLE PRECISION XK14 + DOUBLE PRECISION XKW + DOUBLE PRECISION XK21 + DOUBLE PRECISION XK22 + DOUBLE PRECISION XK31 + DOUBLE PRECISION XK32 + DOUBLE PRECISION XK41 + DOUBLE PRECISION XK42 + +!=====END MODULE EQUK===================================================== + + END MODULE module_data_isrpia_data diff --git a/wrfv2_fire/chem/module_data_isrpia_expnc.F b/wrfv2_fire/chem/module_data_isrpia_expnc.F new file mode 100755 index 00000000..4e0a72ec --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_expnc.F @@ -0,0 +1,58 @@ + + MODULE EXPNC + REAL ::AINT10(20), ADEC10(200) + DATA AINT10/ & + 0.1000E-08, 0.1000E-07, 0.1000E-06, 0.1000E-05, 0.1000E-04, & + 0.1000E-03, 0.1000E-02, 0.1000E-01, 0.1000E+00, 0.1000E+01, & + 0.1000E+02, 0.1000E+03, 0.1000E+04, 0.1000E+05, 0.1000E+06, & + 0.1000E+07, 0.1000E+08, 0.1000E+09, 0.1000E+10, 0.1000E+11 & + / +! +! *** decimal part +! + DATA (ADEC10(I),I=1,100)/ & + 0.1023E+00, 0.1047E+00, 0.1072E+00, 0.1096E+00, 0.1122E+00, & + 0.1148E+00, 0.1175E+00, 0.1202E+00, 0.1230E+00, 0.1259E+00, & + 0.1288E+00, 0.1318E+00, 0.1349E+00, 0.1380E+00, 0.1413E+00, & + 0.1445E+00, 0.1479E+00, 0.1514E+00, 0.1549E+00, 0.1585E+00, & + 0.1622E+00, 0.1660E+00, 0.1698E+00, 0.1738E+00, 0.1778E+00, & + 0.1820E+00, 0.1862E+00, 0.1905E+00, 0.1950E+00, 0.1995E+00, & + 0.2042E+00, 0.2089E+00, 0.2138E+00, 0.2188E+00, 0.2239E+00, & + 0.2291E+00, 0.2344E+00, 0.2399E+00, 0.2455E+00, 0.2512E+00, & + 0.2570E+00, 0.2630E+00, 0.2692E+00, 0.2754E+00, 0.2818E+00, & + 0.2884E+00, 0.2951E+00, 0.3020E+00, 0.3090E+00, 0.3162E+00, & + 0.3236E+00, 0.3311E+00, 0.3388E+00, 0.3467E+00, 0.3548E+00, & + 0.3631E+00, 0.3715E+00, 0.3802E+00, 0.3890E+00, 0.3981E+00, & + 0.4074E+00, 0.4169E+00, 0.4266E+00, 0.4365E+00, 0.4467E+00, & + 0.4571E+00, 0.4677E+00, 0.4786E+00, 0.4898E+00, 0.5012E+00, & + 0.5129E+00, 0.5248E+00, 0.5370E+00, 0.5495E+00, 0.5623E+00, & + 0.5754E+00, 0.5888E+00, 0.6026E+00, 0.6166E+00, 0.6310E+00, & + 0.6457E+00, 0.6607E+00, 0.6761E+00, 0.6918E+00, 0.7079E+00, & + 0.7244E+00, 0.7413E+00, 0.7586E+00, 0.7762E+00, 0.7943E+00, & + 0.8128E+00, 0.8318E+00, 0.8511E+00, 0.8710E+00, 0.8913E+00, & + 0.9120E+00, 0.9333E+00, 0.9550E+00, 0.9772E+00, 0.1000E+01/ + DATA (ADEC10(I),I=101,200)/ & + 0.1023E+01, 0.1047E+01, 0.1072E+01, 0.1096E+01, 0.1122E+01, & + 0.1148E+01, 0.1175E+01, 0.1202E+01, 0.1230E+01, 0.1259E+01, & + 0.1288E+01, 0.1318E+01, 0.1349E+01, 0.1380E+01, 0.1413E+01, & + 0.1445E+01, 0.1479E+01, 0.1514E+01, 0.1549E+01, 0.1585E+01, & + 0.1622E+01, 0.1660E+01, 0.1698E+01, 0.1738E+01, 0.1778E+01, & + 0.1820E+01, 0.1862E+01, 0.1905E+01, 0.1950E+01, 0.1995E+01, & + 0.2042E+01, 0.2089E+01, 0.2138E+01, 0.2188E+01, 0.2239E+01, & + 0.2291E+01, 0.2344E+01, 0.2399E+01, 0.2455E+01, 0.2512E+01, & + 0.2570E+01, 0.2630E+01, 0.2692E+01, 0.2754E+01, 0.2818E+01, & + 0.2884E+01, 0.2951E+01, 0.3020E+01, 0.3090E+01, 0.3162E+01, & + 0.3236E+01, 0.3311E+01, 0.3388E+01, 0.3467E+01, 0.3548E+01, & + 0.3631E+01, 0.3715E+01, 0.3802E+01, 0.3890E+01, 0.3981E+01, & + 0.4074E+01, 0.4169E+01, 0.4266E+01, 0.4365E+01, 0.4467E+01, & + 0.4571E+01, 0.4677E+01, 0.4786E+01, 0.4898E+01, 0.5012E+01, & + 0.5129E+01, 0.5248E+01, 0.5370E+01, 0.5495E+01, 0.5623E+01, & + 0.5754E+01, 0.5888E+01, 0.6026E+01, 0.6166E+01, 0.6310E+01, & + 0.6457E+01, 0.6607E+01, 0.6761E+01, 0.6918E+01, 0.7079E+01, & + 0.7244E+01, 0.7413E+01, 0.7586E+01, 0.7762E+01, 0.7943E+01, & + 0.8128E+01, 0.8318E+01, 0.8511E+01, 0.8710E+01, 0.8913E+01, & + 0.9120E+01, 0.9333E+01, 0.9550E+01, 0.9772E+01, 0.1000E+02 & + / + + END Module EXPNC + diff --git a/wrfv2_fire/chem/module_data_isrpia_kmc198.F b/wrfv2_fire/chem/module_data_isrpia_kmc198.F new file mode 100755 index 00000000..3e21f9ce --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_kmc198.F @@ -0,0 +1,2191 @@ + MODULE KMC198 + DOUBLE PRECISION :: & + BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & + BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & + BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & + BNC13M( 741) + +! *** NaCl +! + DATA (BNC01M (I),I= 1,100)/ & + -0.54728E-01,-0.96305E-01,-0.12309E+00,-0.13978E+00,-0.15161E+00, & + -0.16050E+00,-0.16740E+00,-0.17287E+00,-0.17725E+00,-0.18077E+00, & + -0.18360E+00,-0.18587E+00,-0.18765E+00,-0.18904E+00,-0.19007E+00, & + -0.19081E+00,-0.19129E+00,-0.19153E+00,-0.19157E+00,-0.19143E+00, & + -0.19114E+00,-0.19069E+00,-0.19012E+00,-0.18943E+00,-0.18863E+00, & + -0.18775E+00,-0.18677E+00,-0.18572E+00,-0.18460E+00,-0.18341E+00, & + -0.18217E+00,-0.18087E+00,-0.17953E+00,-0.17814E+00,-0.17672E+00, & + -0.17526E+00,-0.17377E+00,-0.17225E+00,-0.17071E+00,-0.16914E+00, & + -0.16756E+00,-0.16596E+00,-0.16434E+00,-0.16271E+00,-0.16106E+00, & + -0.15941E+00,-0.15775E+00,-0.15607E+00,-0.15440E+00,-0.15271E+00, & + -0.15102E+00,-0.14933E+00,-0.14763E+00,-0.14592E+00,-0.14422E+00, & + -0.14251E+00,-0.14080E+00,-0.13908E+00,-0.13736E+00,-0.13564E+00, & + -0.13392E+00,-0.13219E+00,-0.13046E+00,-0.12872E+00,-0.12698E+00, & + -0.12523E+00,-0.12347E+00,-0.12171E+00,-0.11995E+00,-0.11817E+00, & + -0.11638E+00,-0.11459E+00,-0.11279E+00,-0.11097E+00,-0.10915E+00, & + -0.10731E+00,-0.10546E+00,-0.10360E+00,-0.10172E+00,-0.99830E-01, & + -0.97925E-01,-0.96004E-01,-0.94068E-01,-0.92116E-01,-0.90147E-01, & + -0.88163E-01,-0.86161E-01,-0.84143E-01,-0.82108E-01,-0.80055E-01, & + -0.77986E-01,-0.75900E-01,-0.73797E-01,-0.71678E-01,-0.69542E-01, & + -0.67390E-01,-0.65222E-01,-0.63039E-01,-0.60840E-01,-0.58627E-01/ + + DATA (BNC01M (I),I=101,200)/ & + -0.56400E-01,-0.54159E-01,-0.51905E-01,-0.49639E-01,-0.47360E-01, & + -0.45070E-01,-0.42769E-01,-0.40457E-01,-0.38136E-01,-0.35805E-01, & + -0.33466E-01,-0.31119E-01,-0.28765E-01,-0.26404E-01,-0.24036E-01, & + -0.21663E-01,-0.19285E-01,-0.16902E-01,-0.14514E-01,-0.12123E-01, & + -0.10058E-01,-0.76233E-02,-0.51896E-02,-0.27575E-02,-0.32700E-03, & + 0.21018E-02, 0.45288E-02, 0.69540E-02, 0.93773E-02, 0.11799E-01, & + 0.14218E-01, 0.16635E-01, 0.19050E-01, 0.21463E-01, 0.23873E-01, & + 0.26281E-01, 0.28687E-01, 0.31090E-01, 0.33491E-01, 0.35889E-01, & + 0.38285E-01, 0.40678E-01, 0.43068E-01, 0.45456E-01, 0.47840E-01, & + 0.50222E-01, 0.52601E-01, 0.54977E-01, 0.57350E-01, 0.59721E-01, & + 0.62088E-01, 0.64452E-01, 0.66813E-01, 0.69171E-01, 0.71526E-01, & + 0.73877E-01, 0.76225E-01, 0.78571E-01, 0.80912E-01, 0.83251E-01, & + 0.85586E-01, 0.87918E-01, 0.90247E-01, 0.92572E-01, 0.94893E-01, & + 0.97212E-01, 0.99526E-01, 0.10184E+00, 0.10415E+00, 0.10645E+00, & + 0.10875E+00, 0.11105E+00, 0.11334E+00, 0.11563E+00, 0.11792E+00, & + 0.12020E+00, 0.12248E+00, 0.12475E+00, 0.12703E+00, 0.12929E+00, & + 0.13156E+00, 0.13382E+00, 0.13608E+00, 0.13833E+00, 0.14058E+00, & + 0.14282E+00, 0.14507E+00, 0.14730E+00, 0.14954E+00, 0.15177E+00, & + 0.15399E+00, 0.15622E+00, 0.15844E+00, 0.16065E+00, 0.16286E+00, & + 0.16507E+00, 0.16727E+00, 0.16947E+00, 0.17167E+00, 0.17386E+00/ + + DATA (BNC01M (I),I=201,300)/ & + 0.17605E+00, 0.17823E+00, 0.18041E+00, 0.18259E+00, 0.18476E+00, & + 0.18693E+00, 0.18909E+00, 0.19126E+00, 0.19341E+00, 0.19557E+00, & + 0.19771E+00, 0.19986E+00, 0.20200E+00, 0.20414E+00, 0.20627E+00, & + 0.20840E+00, 0.21053E+00, 0.21265E+00, 0.21476E+00, 0.21688E+00, & + 0.21899E+00, 0.22109E+00, 0.22320E+00, 0.22529E+00, 0.22739E+00, & + 0.22948E+00, 0.23156E+00, 0.23364E+00, 0.23572E+00, 0.23780E+00, & + 0.23987E+00, 0.24193E+00, 0.24400E+00, 0.24606E+00, 0.24811E+00, & + 0.25016E+00, 0.25221E+00, 0.25425E+00, 0.25629E+00, 0.25832E+00, & + 0.26036E+00, 0.26238E+00, 0.26441E+00, 0.26643E+00, 0.26844E+00, & + 0.27045E+00, 0.27246E+00, 0.27447E+00, 0.27647E+00, 0.27846E+00, & + 0.28045E+00, 0.28244E+00, 0.28443E+00, 0.28641E+00, 0.28839E+00, & + 0.29036E+00, 0.29233E+00, 0.29429E+00, 0.29626E+00, 0.29821E+00, & + 0.30017E+00, 0.30212E+00, 0.30406E+00, 0.30601E+00, 0.30794E+00, & + 0.30988E+00, 0.31181E+00, 0.31374E+00, 0.31566E+00, 0.31758E+00, & + 0.31950E+00, 0.32141E+00, 0.32332E+00, 0.32522E+00, 0.32712E+00, & + 0.32902E+00, 0.33092E+00, 0.33281E+00, 0.33469E+00, 0.33657E+00, & + 0.33845E+00, 0.34033E+00, 0.34220E+00, 0.34407E+00, 0.34593E+00, & + 0.34779E+00, 0.34965E+00, 0.35150E+00, 0.35335E+00, 0.35519E+00, & + 0.35704E+00, 0.35887E+00, 0.36071E+00, 0.36254E+00, 0.36437E+00, & + 0.36619E+00, 0.36801E+00, 0.36983E+00, 0.37164E+00, 0.37345E+00/ + + DATA (BNC01M (I),I=301,400)/ & + 0.37526E+00, 0.37706E+00, 0.37886E+00, 0.38065E+00, 0.38244E+00, & + 0.38423E+00, 0.38602E+00, 0.38780E+00, 0.38957E+00, 0.39135E+00, & + 0.39312E+00, 0.39489E+00, 0.39665E+00, 0.39841E+00, 0.40017E+00, & + 0.40192E+00, 0.40367E+00, 0.40541E+00, 0.40716E+00, 0.40890E+00, & + 0.41063E+00, 0.41236E+00, 0.41409E+00, 0.41582E+00, 0.41754E+00, & + 0.41926E+00, 0.42097E+00, 0.42268E+00, 0.42439E+00, 0.42610E+00, & + 0.42780E+00, 0.42950E+00, 0.43119E+00, 0.43288E+00, 0.43457E+00, & + 0.43626E+00, 0.43794E+00, 0.43962E+00, 0.44129E+00, 0.44296E+00, & + 0.44463E+00, 0.44630E+00, 0.44796E+00, 0.44962E+00, 0.45127E+00, & + 0.45292E+00, 0.45457E+00, 0.45622E+00, 0.45786E+00, 0.45950E+00, & + 0.46113E+00, 0.46277E+00, 0.46439E+00, 0.46602E+00, 0.46764E+00, & + 0.46926E+00, 0.47088E+00, 0.47249E+00, 0.47410E+00, 0.47571E+00, & + 0.47731E+00, 0.47891E+00, 0.48051E+00, 0.48211E+00, 0.48370E+00, & + 0.48528E+00, 0.48687E+00, 0.48845E+00, 0.49003E+00, 0.49161E+00, & + 0.49318E+00, 0.49475E+00, 0.49631E+00, 0.49788E+00, 0.49944E+00, & + 0.50099E+00, 0.50255E+00, 0.50410E+00, 0.50565E+00, 0.50719E+00, & + 0.50873E+00, 0.51027E+00, 0.51181E+00, 0.51334E+00, 0.51487E+00, & + 0.51640E+00, 0.51792E+00, 0.51944E+00, 0.52096E+00, 0.52248E+00, & + 0.52399E+00, 0.52550E+00, 0.52700E+00, 0.52851E+00, 0.53001E+00, & + 0.53150E+00, 0.53300E+00, 0.53449E+00, 0.53598E+00, 0.53747E+00/ + + DATA (BNC01M (I),I=401,500)/ & + 0.53895E+00, 0.54043E+00, 0.54191E+00, 0.54338E+00, 0.54485E+00, & + 0.54632E+00, 0.54779E+00, 0.54925E+00, 0.55071E+00, 0.55217E+00, & + 0.55362E+00, 0.55507E+00, 0.55652E+00, 0.55797E+00, 0.55941E+00, & + 0.56085E+00, 0.56229E+00, 0.56372E+00, 0.56515E+00, 0.56658E+00, & + 0.56801E+00, 0.56943E+00, 0.57086E+00, 0.57227E+00, 0.57369E+00, & + 0.57510E+00, 0.57651E+00, 0.57792E+00, 0.57932E+00, 0.58073E+00, & + 0.58213E+00, 0.58352E+00, 0.58492E+00, 0.58631E+00, 0.58770E+00, & + 0.58908E+00, 0.59047E+00, 0.59185E+00, 0.59323E+00, 0.59460E+00, & + 0.59597E+00, 0.59734E+00, 0.59871E+00, 0.60008E+00, 0.60144E+00, & + 0.60280E+00, 0.60415E+00, 0.60551E+00, 0.60686E+00, 0.60821E+00, & + 0.60956E+00, 0.61090E+00, 0.61224E+00, 0.61358E+00, 0.61492E+00, & + 0.61625E+00, 0.61758E+00, 0.61891E+00, 0.62024E+00, 0.62156E+00, & + 0.62288E+00, 0.62420E+00, 0.62552E+00, 0.62683E+00, 0.62815E+00, & + 0.62945E+00, 0.63076E+00, 0.63206E+00, 0.63337E+00, 0.63467E+00, & + 0.63596E+00, 0.63726E+00, 0.63855E+00, 0.63984E+00, 0.64112E+00, & + 0.64241E+00, 0.64369E+00, 0.64497E+00, 0.64625E+00, 0.64752E+00, & + 0.64879E+00, 0.65006E+00, 0.65133E+00, 0.65260E+00, 0.65386E+00, & + 0.65512E+00, 0.65638E+00, 0.65763E+00, 0.65889E+00, 0.66014E+00, & + 0.66139E+00, 0.66263E+00, 0.66388E+00, 0.66512E+00, 0.66636E+00, & + 0.66759E+00, 0.66883E+00, 0.67006E+00, 0.67129E+00, 0.67252E+00/ + + DATA (BNC01M (I),I=501,600)/ & + 0.67374E+00, 0.67497E+00, 0.67619E+00, 0.67741E+00, 0.67862E+00, & + 0.67984E+00, 0.68105E+00, 0.68226E+00, 0.68347E+00, 0.68467E+00, & + 0.68587E+00, 0.68707E+00, 0.68827E+00, 0.68947E+00, 0.69066E+00, & + 0.69185E+00, 0.69304E+00, 0.69423E+00, 0.69542E+00, 0.69660E+00, & + 0.69778E+00, 0.69896E+00, 0.70013E+00, 0.70131E+00, 0.70248E+00, & + 0.70365E+00, 0.70482E+00, 0.70598E+00, 0.70715E+00, 0.70831E+00, & + 0.70947E+00, 0.71062E+00, 0.71178E+00, 0.71293E+00, 0.71408E+00, & + 0.71523E+00, 0.71638E+00, 0.71752E+00, 0.71866E+00, 0.71980E+00, & + 0.72094E+00, 0.72208E+00, 0.72321E+00, 0.72434E+00, 0.72547E+00, & + 0.72660E+00, 0.72772E+00, 0.72885E+00, 0.72997E+00, 0.73109E+00, & + 0.73220E+00, 0.73332E+00, 0.73443E+00, 0.73554E+00, 0.73665E+00, & + 0.73776E+00, 0.73886E+00, 0.73997E+00, 0.74107E+00, 0.74217E+00, & + 0.74326E+00, 0.74436E+00, 0.74545E+00, 0.74654E+00, 0.74763E+00, & + 0.74872E+00, 0.74980E+00, 0.75089E+00, 0.75197E+00, 0.75305E+00, & + 0.75412E+00, 0.75520E+00, 0.75627E+00, 0.75734E+00, 0.75841E+00, & + 0.75948E+00, 0.76055E+00, 0.76161E+00, 0.76267E+00, 0.76373E+00, & + 0.76479E+00, 0.76584E+00, 0.76690E+00, 0.76795E+00, 0.76900E+00, & + 0.77005E+00, 0.77109E+00, 0.77214E+00, 0.77318E+00, 0.77422E+00, & + 0.77526E+00, 0.77630E+00, 0.77733E+00, 0.77836E+00, 0.77940E+00, & + 0.78043E+00, 0.78145E+00, 0.78248E+00, 0.78350E+00, 0.78733E+00/ + + DATA (BNC01M (I),I=601,700)/ & + 0.79565E+00, 0.80557E+00, 0.81531E+00, 0.82489E+00, 0.83429E+00, & + 0.84353E+00, 0.85261E+00, 0.86153E+00, 0.87029E+00, 0.87890E+00, & + 0.88737E+00, 0.89568E+00, 0.90385E+00, 0.91188E+00, 0.91978E+00, & + 0.92754E+00, 0.93516E+00, 0.94265E+00, 0.95002E+00, 0.95726E+00, & + 0.96438E+00, 0.97138E+00, 0.97825E+00, 0.98501E+00, 0.99166E+00, & + 0.99819E+00, 0.10046E+01, 0.10109E+01, 0.10171E+01, 0.10232E+01, & + 0.10292E+01, 0.10351E+01, 0.10409E+01, 0.10466E+01, 0.10522E+01, & + 0.10577E+01, 0.10632E+01, 0.10685E+01, 0.10737E+01, 0.10788E+01, & + 0.10839E+01, 0.10889E+01, 0.10938E+01, 0.10986E+01, 0.11033E+01, & + 0.11079E+01, 0.11125E+01, 0.11169E+01, 0.11213E+01, 0.11257E+01, & + 0.11299E+01, 0.11341E+01, 0.11382E+01, 0.11422E+01, 0.11462E+01, & + 0.11501E+01, 0.11539E+01, 0.11577E+01, 0.11613E+01, 0.11650E+01, & + 0.11685E+01, 0.11720E+01, 0.11754E+01, 0.11788E+01, 0.11821E+01, & + 0.11853E+01, 0.11885E+01, 0.11916E+01, 0.11947E+01, 0.11977E+01, & + 0.12007E+01, 0.12036E+01, 0.12064E+01, 0.12092E+01, 0.12119E+01, & + 0.12146E+01, 0.12172E+01, 0.12198E+01, 0.12223E+01, 0.12248E+01, & + 0.12272E+01, 0.12296E+01, 0.12319E+01, 0.12342E+01, 0.12364E+01, & + 0.12386E+01, 0.12407E+01, 0.12428E+01, 0.12449E+01, 0.12469E+01, & + 0.12488E+01, 0.12507E+01, 0.12526E+01, 0.12544E+01, 0.12562E+01, & + 0.12579E+01, 0.12596E+01, 0.12613E+01, 0.12629E+01, 0.12645E+01/ + + DATA (BNC01M(I),I=701,741)/ & + 0.12660E+01, 0.12675E+01, 0.12690E+01, 0.12704E+01, 0.12718E+01, & + 0.12731E+01, 0.12744E+01, 0.12757E+01, 0.12769E+01, 0.12781E+01, & + 0.12793E+01, 0.12804E+01, 0.12815E+01, 0.12825E+01, 0.12836E+01, & + 0.12846E+01, 0.12855E+01, 0.12864E+01, 0.12873E+01, 0.12882E+01, & + 0.12890E+01, 0.12898E+01, 0.12906E+01, 0.12913E+01, 0.12920E+01, & + 0.12927E+01, 0.12933E+01, 0.12939E+01, 0.12945E+01, 0.12951E+01, & + 0.12956E+01, 0.12961E+01, 0.12966E+01, 0.12970E+01, 0.12974E+01, & + 0.12978E+01, 0.12981E+01, 0.12985E+01, 0.12988E+01, 0.12991E+01, & + 0.12993E+01 & + / +! +! *** Na2SO4 +! + DATA (BNC02M (I),I= 1,100)/ & + -0.11393E+00,-0.20901E+00,-0.27708E+00,-0.32413E+00,-0.36089E+00, & + -0.39137E+00,-0.41757E+00,-0.44064E+00,-0.46132E+00,-0.48011E+00, & + -0.49735E+00,-0.51331E+00,-0.52819E+00,-0.54215E+00,-0.55531E+00, & + -0.56776E+00,-0.57959E+00,-0.59087E+00,-0.60165E+00,-0.61199E+00, & + -0.62193E+00,-0.63150E+00,-0.64073E+00,-0.64965E+00,-0.65829E+00, & + -0.66666E+00,-0.67479E+00,-0.68269E+00,-0.69038E+00,-0.69786E+00, & + -0.70517E+00,-0.71229E+00,-0.71925E+00,-0.72606E+00,-0.73272E+00, & + -0.73923E+00,-0.74562E+00,-0.75188E+00,-0.75802E+00,-0.76405E+00, & + -0.76996E+00,-0.77578E+00,-0.78149E+00,-0.78711E+00,-0.79264E+00, & + -0.79808E+00,-0.80343E+00,-0.80871E+00,-0.81391E+00,-0.81903E+00, & + -0.82409E+00,-0.82907E+00,-0.83399E+00,-0.83885E+00,-0.84364E+00, & + -0.84837E+00,-0.85305E+00,-0.85767E+00,-0.86224E+00,-0.86676E+00, & + -0.87123E+00,-0.87565E+00,-0.88002E+00,-0.88435E+00,-0.88863E+00, & + -0.89288E+00,-0.89708E+00,-0.90124E+00,-0.90537E+00,-0.90946E+00, & + -0.91351E+00,-0.91753E+00,-0.92152E+00,-0.92547E+00,-0.92939E+00, & + -0.93329E+00,-0.93715E+00,-0.94099E+00,-0.94480E+00,-0.94858E+00, & + -0.95234E+00,-0.95607E+00,-0.95978E+00,-0.96346E+00,-0.96712E+00, & + -0.97076E+00,-0.97438E+00,-0.97797E+00,-0.98155E+00,-0.98511E+00, & + -0.98864E+00,-0.99216E+00,-0.99566E+00,-0.99914E+00,-0.10026E+01, & + -0.10061E+01,-0.10095E+01,-0.10129E+01,-0.10163E+01,-0.10197E+01/ + + DATA (BNC02M (I),I=101,200)/ & + -0.10230E+01,-0.10264E+01,-0.10297E+01,-0.10330E+01,-0.10363E+01, & + -0.10396E+01,-0.10429E+01,-0.10462E+01,-0.10494E+01,-0.10526E+01, & + -0.10559E+01,-0.10591E+01,-0.10623E+01,-0.10654E+01,-0.10686E+01, & + -0.10718E+01,-0.10749E+01,-0.10780E+01,-0.10812E+01,-0.10843E+01, & + -0.10873E+01,-0.10904E+01,-0.10935E+01,-0.10965E+01,-0.10996E+01, & + -0.11026E+01,-0.11056E+01,-0.11087E+01,-0.11117E+01,-0.11147E+01, & + -0.11176E+01,-0.11206E+01,-0.11236E+01,-0.11265E+01,-0.11295E+01, & + -0.11324E+01,-0.11353E+01,-0.11382E+01,-0.11411E+01,-0.11440E+01, & + -0.11469E+01,-0.11497E+01,-0.11526E+01,-0.11555E+01,-0.11583E+01, & + -0.11611E+01,-0.11640E+01,-0.11668E+01,-0.11696E+01,-0.11724E+01, & + -0.11752E+01,-0.11779E+01,-0.11807E+01,-0.11835E+01,-0.11862E+01, & + -0.11890E+01,-0.11917E+01,-0.11945E+01,-0.11972E+01,-0.11999E+01, & + -0.12026E+01,-0.12053E+01,-0.12080E+01,-0.12107E+01,-0.12134E+01, & + -0.12160E+01,-0.12187E+01,-0.12214E+01,-0.12240E+01,-0.12267E+01, & + -0.12293E+01,-0.12319E+01,-0.12346E+01,-0.12372E+01,-0.12398E+01, & + -0.12424E+01,-0.12450E+01,-0.12476E+01,-0.12502E+01,-0.12528E+01, & + -0.12553E+01,-0.12579E+01,-0.12605E+01,-0.12630E+01,-0.12656E+01, & + -0.12681E+01,-0.12707E+01,-0.12732E+01,-0.12757E+01,-0.12782E+01, & + -0.12807E+01,-0.12833E+01,-0.12858E+01,-0.12883E+01,-0.12908E+01, & + -0.12932E+01,-0.12957E+01,-0.12982E+01,-0.13007E+01,-0.13032E+01/ + + DATA (BNC02M (I),I=201,300)/ & + -0.13056E+01,-0.13081E+01,-0.13105E+01,-0.13130E+01,-0.13154E+01, & + -0.13179E+01,-0.13203E+01,-0.13227E+01,-0.13251E+01,-0.13276E+01, & + -0.13300E+01,-0.13324E+01,-0.13348E+01,-0.13372E+01,-0.13396E+01, & + -0.13420E+01,-0.13444E+01,-0.13468E+01,-0.13491E+01,-0.13515E+01, & + -0.13539E+01,-0.13562E+01,-0.13586E+01,-0.13610E+01,-0.13633E+01, & + -0.13657E+01,-0.13680E+01,-0.13704E+01,-0.13727E+01,-0.13750E+01, & + -0.13774E+01,-0.13797E+01,-0.13820E+01,-0.13843E+01,-0.13866E+01, & + -0.13890E+01,-0.13913E+01,-0.13936E+01,-0.13959E+01,-0.13982E+01, & + -0.14004E+01,-0.14027E+01,-0.14050E+01,-0.14073E+01,-0.14096E+01, & + -0.14119E+01,-0.14141E+01,-0.14164E+01,-0.14187E+01,-0.14209E+01, & + -0.14232E+01,-0.14254E+01,-0.14277E+01,-0.14299E+01,-0.14322E+01, & + -0.14344E+01,-0.14366E+01,-0.14389E+01,-0.14411E+01,-0.14433E+01, & + -0.14456E+01,-0.14478E+01,-0.14500E+01,-0.14522E+01,-0.14544E+01, & + -0.14566E+01,-0.14588E+01,-0.14610E+01,-0.14632E+01,-0.14654E+01, & + -0.14676E+01,-0.14698E+01,-0.14720E+01,-0.14742E+01,-0.14764E+01, & + -0.14785E+01,-0.14807E+01,-0.14829E+01,-0.14851E+01,-0.14872E+01, & + -0.14894E+01,-0.14916E+01,-0.14937E+01,-0.14959E+01,-0.14980E+01, & + -0.15002E+01,-0.15023E+01,-0.15045E+01,-0.15066E+01,-0.15087E+01, & + -0.15109E+01,-0.15130E+01,-0.15152E+01,-0.15173E+01,-0.15194E+01, & + -0.15215E+01,-0.15237E+01,-0.15258E+01,-0.15279E+01,-0.15300E+01/ + + DATA (BNC02M (I),I=301,400)/ & + -0.15321E+01,-0.15342E+01,-0.15363E+01,-0.15384E+01,-0.15405E+01, & + -0.15426E+01,-0.15447E+01,-0.15468E+01,-0.15489E+01,-0.15510E+01, & + -0.15531E+01,-0.15552E+01,-0.15573E+01,-0.15594E+01,-0.15614E+01, & + -0.15635E+01,-0.15656E+01,-0.15677E+01,-0.15697E+01,-0.15718E+01, & + -0.15739E+01,-0.15759E+01,-0.15780E+01,-0.15800E+01,-0.15821E+01, & + -0.15842E+01,-0.15862E+01,-0.15883E+01,-0.15903E+01,-0.15923E+01, & + -0.15944E+01,-0.15964E+01,-0.15985E+01,-0.16005E+01,-0.16025E+01, & + -0.16046E+01,-0.16066E+01,-0.16086E+01,-0.16107E+01,-0.16127E+01, & + -0.16147E+01,-0.16167E+01,-0.16188E+01,-0.16208E+01,-0.16228E+01, & + -0.16248E+01,-0.16268E+01,-0.16288E+01,-0.16308E+01,-0.16328E+01, & + -0.16348E+01,-0.16368E+01,-0.16388E+01,-0.16408E+01,-0.16428E+01, & + -0.16448E+01,-0.16468E+01,-0.16488E+01,-0.16508E+01,-0.16528E+01, & + -0.16548E+01,-0.16568E+01,-0.16587E+01,-0.16607E+01,-0.16627E+01, & + -0.16647E+01,-0.16667E+01,-0.16686E+01,-0.16706E+01,-0.16726E+01, & + -0.16745E+01,-0.16765E+01,-0.16785E+01,-0.16804E+01,-0.16824E+01, & + -0.16844E+01,-0.16863E+01,-0.16883E+01,-0.16902E+01,-0.16922E+01, & + -0.16941E+01,-0.16961E+01,-0.16980E+01,-0.17000E+01,-0.17019E+01, & + -0.17039E+01,-0.17058E+01,-0.17077E+01,-0.17097E+01,-0.17116E+01, & + -0.17136E+01,-0.17155E+01,-0.17174E+01,-0.17194E+01,-0.17213E+01, & + -0.17232E+01,-0.17251E+01,-0.17271E+01,-0.17290E+01,-0.17309E+01/ + + DATA (BNC02M (I),I=401,500)/ & + -0.17328E+01,-0.17347E+01,-0.17367E+01,-0.17386E+01,-0.17405E+01, & + -0.17424E+01,-0.17443E+01,-0.17462E+01,-0.17481E+01,-0.17500E+01, & + -0.17519E+01,-0.17538E+01,-0.17557E+01,-0.17576E+01,-0.17595E+01, & + -0.17614E+01,-0.17633E+01,-0.17652E+01,-0.17671E+01,-0.17690E+01, & + -0.17709E+01,-0.17728E+01,-0.17747E+01,-0.17766E+01,-0.17785E+01, & + -0.17804E+01,-0.17822E+01,-0.17841E+01,-0.17860E+01,-0.17879E+01, & + -0.17898E+01,-0.17916E+01,-0.17935E+01,-0.17954E+01,-0.17973E+01, & + -0.17991E+01,-0.18010E+01,-0.18029E+01,-0.18047E+01,-0.18066E+01, & + -0.18085E+01,-0.18103E+01,-0.18122E+01,-0.18140E+01,-0.18159E+01, & + -0.18178E+01,-0.18196E+01,-0.18215E+01,-0.18233E+01,-0.18252E+01, & + -0.18270E+01,-0.18289E+01,-0.18307E+01,-0.18326E+01,-0.18344E+01, & + -0.18363E+01,-0.18381E+01,-0.18400E+01,-0.18418E+01,-0.18437E+01, & + -0.18455E+01,-0.18473E+01,-0.18492E+01,-0.18510E+01,-0.18528E+01, & + -0.18547E+01,-0.18565E+01,-0.18583E+01,-0.18602E+01,-0.18620E+01, & + -0.18638E+01,-0.18657E+01,-0.18675E+01,-0.18693E+01,-0.18711E+01, & + -0.18730E+01,-0.18748E+01,-0.18766E+01,-0.18784E+01,-0.18802E+01, & + -0.18821E+01,-0.18839E+01,-0.18857E+01,-0.18875E+01,-0.18893E+01, & + -0.18911E+01,-0.18929E+01,-0.18948E+01,-0.18966E+01,-0.18984E+01, & + -0.19002E+01,-0.19020E+01,-0.19038E+01,-0.19056E+01,-0.19074E+01, & + -0.19092E+01,-0.19110E+01,-0.19128E+01,-0.19146E+01,-0.19164E+01/ + + DATA (BNC02M (I),I=501,600)/ & + -0.19182E+01,-0.19200E+01,-0.19218E+01,-0.19236E+01,-0.19254E+01, & + -0.19272E+01,-0.19289E+01,-0.19307E+01,-0.19325E+01,-0.19343E+01, & + -0.19361E+01,-0.19379E+01,-0.19397E+01,-0.19415E+01,-0.19432E+01, & + -0.19450E+01,-0.19468E+01,-0.19486E+01,-0.19504E+01,-0.19521E+01, & + -0.19539E+01,-0.19557E+01,-0.19575E+01,-0.19592E+01,-0.19610E+01, & + -0.19628E+01,-0.19646E+01,-0.19663E+01,-0.19681E+01,-0.19699E+01, & + -0.19716E+01,-0.19734E+01,-0.19752E+01,-0.19769E+01,-0.19787E+01, & + -0.19804E+01,-0.19822E+01,-0.19840E+01,-0.19857E+01,-0.19875E+01, & + -0.19892E+01,-0.19910E+01,-0.19928E+01,-0.19945E+01,-0.19963E+01, & + -0.19980E+01,-0.19998E+01,-0.20015E+01,-0.20033E+01,-0.20050E+01, & + -0.20068E+01,-0.20085E+01,-0.20103E+01,-0.20120E+01,-0.20138E+01, & + -0.20155E+01,-0.20173E+01,-0.20190E+01,-0.20207E+01,-0.20225E+01, & + -0.20242E+01,-0.20260E+01,-0.20277E+01,-0.20294E+01,-0.20312E+01, & + -0.20329E+01,-0.20347E+01,-0.20364E+01,-0.20381E+01,-0.20399E+01, & + -0.20416E+01,-0.20433E+01,-0.20451E+01,-0.20468E+01,-0.20485E+01, & + -0.20502E+01,-0.20520E+01,-0.20537E+01,-0.20554E+01,-0.20572E+01, & + -0.20589E+01,-0.20606E+01,-0.20623E+01,-0.20640E+01,-0.20658E+01, & + -0.20675E+01,-0.20692E+01,-0.20709E+01,-0.20726E+01,-0.20744E+01, & + -0.20761E+01,-0.20778E+01,-0.20795E+01,-0.20812E+01,-0.20829E+01, & + -0.20847E+01,-0.20864E+01,-0.20881E+01,-0.20898E+01,-0.20962E+01/ + + DATA (BNC02M (I),I=601,700)/ & + -0.21103E+01,-0.21272E+01,-0.21441E+01,-0.21610E+01,-0.21778E+01, & + -0.21945E+01,-0.22111E+01,-0.22277E+01,-0.22442E+01,-0.22607E+01, & + -0.22771E+01,-0.22934E+01,-0.23097E+01,-0.23260E+01,-0.23422E+01, & + -0.23583E+01,-0.23744E+01,-0.23904E+01,-0.24064E+01,-0.24224E+01, & + -0.24383E+01,-0.24541E+01,-0.24699E+01,-0.24857E+01,-0.25014E+01, & + -0.25171E+01,-0.25327E+01,-0.25483E+01,-0.25639E+01,-0.25794E+01, & + -0.25949E+01,-0.26104E+01,-0.26258E+01,-0.26412E+01,-0.26565E+01, & + -0.26718E+01,-0.26871E+01,-0.27023E+01,-0.27175E+01,-0.27327E+01, & + -0.27479E+01,-0.27630E+01,-0.27781E+01,-0.27931E+01,-0.28082E+01, & + -0.28232E+01,-0.28381E+01,-0.28531E+01,-0.28680E+01,-0.28829E+01, & + -0.28977E+01,-0.29125E+01,-0.29274E+01,-0.29421E+01,-0.29569E+01, & + -0.29716E+01,-0.29863E+01,-0.30010E+01,-0.30157E+01,-0.30303E+01, & + -0.30449E+01,-0.30595E+01,-0.30740E+01,-0.30886E+01,-0.31031E+01, & + -0.31176E+01,-0.31321E+01,-0.31465E+01,-0.31610E+01,-0.31754E+01, & + -0.31898E+01,-0.32042E+01,-0.32185E+01,-0.32328E+01,-0.32472E+01, & + -0.32614E+01,-0.32757E+01,-0.32900E+01,-0.33042E+01,-0.33184E+01, & + -0.33326E+01,-0.33468E+01,-0.33610E+01,-0.33751E+01,-0.33893E+01, & + -0.34034E+01,-0.34175E+01,-0.34316E+01,-0.34456E+01,-0.34597E+01, & + -0.34737E+01,-0.34877E+01,-0.35017E+01,-0.35157E+01,-0.35297E+01, & + -0.35436E+01,-0.35576E+01,-0.35715E+01,-0.35854E+01,-0.35993E+01/ + + DATA (BNC02M(I),I=701,741)/ & + -0.36132E+01,-0.36270E+01,-0.36409E+01,-0.36547E+01,-0.36685E+01, & + -0.36823E+01,-0.36961E+01,-0.37099E+01,-0.37237E+01,-0.37374E+01, & + -0.37512E+01,-0.37649E+01,-0.37786E+01,-0.37923E+01,-0.38060E+01, & + -0.38197E+01,-0.38333E+01,-0.38470E+01,-0.38606E+01,-0.38743E+01, & + -0.38879E+01,-0.39015E+01,-0.39151E+01,-0.39286E+01,-0.39422E+01, & + -0.39558E+01,-0.39693E+01,-0.39828E+01,-0.39964E+01,-0.40099E+01, & + -0.40234E+01,-0.40369E+01,-0.40503E+01,-0.40638E+01,-0.40773E+01, & + -0.40907E+01,-0.41041E+01,-0.41176E+01,-0.41310E+01,-0.41444E+01, & + -0.41578E+01 & + / +! +! *** NaNO3 +! + DATA (BNC03M (I),I= 1,100)/ & + -0.57178E-01,-0.10530E+00,-0.14005E+00,-0.16425E+00,-0.18329E+00, & + -0.19916E+00,-0.21288E+00,-0.22502E+00,-0.23595E+00,-0.24593E+00, & + -0.25513E+00,-0.26368E+00,-0.27167E+00,-0.27920E+00,-0.28633E+00, & + -0.29309E+00,-0.29954E+00,-0.30570E+00,-0.31162E+00,-0.31730E+00, & + -0.32278E+00,-0.32807E+00,-0.33318E+00,-0.33813E+00,-0.34294E+00, & + -0.34761E+00,-0.35215E+00,-0.35657E+00,-0.36088E+00,-0.36509E+00, & + -0.36920E+00,-0.37322E+00,-0.37715E+00,-0.38099E+00,-0.38476E+00, & + -0.38845E+00,-0.39207E+00,-0.39563E+00,-0.39912E+00,-0.40255E+00, & + -0.40592E+00,-0.40923E+00,-0.41249E+00,-0.41570E+00,-0.41885E+00, & + -0.42196E+00,-0.42503E+00,-0.42805E+00,-0.43102E+00,-0.43396E+00, & + -0.43685E+00,-0.43971E+00,-0.44253E+00,-0.44532E+00,-0.44807E+00, & + -0.45079E+00,-0.45347E+00,-0.45613E+00,-0.45875E+00,-0.46135E+00, & + -0.46392E+00,-0.46647E+00,-0.46898E+00,-0.47148E+00,-0.47394E+00, & + -0.47639E+00,-0.47881E+00,-0.48121E+00,-0.48360E+00,-0.48596E+00, & + -0.48830E+00,-0.49062E+00,-0.49293E+00,-0.49522E+00,-0.49749E+00, & + -0.49975E+00,-0.50199E+00,-0.50421E+00,-0.50642E+00,-0.50862E+00, & + -0.51081E+00,-0.51298E+00,-0.51514E+00,-0.51729E+00,-0.51942E+00, & + -0.52154E+00,-0.52366E+00,-0.52576E+00,-0.52785E+00,-0.52994E+00, & + -0.53201E+00,-0.53407E+00,-0.53613E+00,-0.53817E+00,-0.54021E+00, & + -0.54224E+00,-0.54426E+00,-0.54627E+00,-0.54827E+00,-0.55026E+00/ + + DATA (BNC03M (I),I=101,200)/ & + -0.55225E+00,-0.55423E+00,-0.55620E+00,-0.55817E+00,-0.56012E+00, & + -0.56207E+00,-0.56401E+00,-0.56595E+00,-0.56787E+00,-0.56979E+00, & + -0.57171E+00,-0.57361E+00,-0.57551E+00,-0.57740E+00,-0.57929E+00, & + -0.58116E+00,-0.58304E+00,-0.58490E+00,-0.58676E+00,-0.58861E+00, & + -0.59039E+00,-0.59224E+00,-0.59407E+00,-0.59590E+00,-0.59772E+00, & + -0.59954E+00,-0.60135E+00,-0.60315E+00,-0.60494E+00,-0.60673E+00, & + -0.60851E+00,-0.61029E+00,-0.61206E+00,-0.61382E+00,-0.61558E+00, & + -0.61733E+00,-0.61907E+00,-0.62081E+00,-0.62254E+00,-0.62427E+00, & + -0.62599E+00,-0.62770E+00,-0.62941E+00,-0.63111E+00,-0.63281E+00, & + -0.63450E+00,-0.63619E+00,-0.63787E+00,-0.63955E+00,-0.64122E+00, & + -0.64289E+00,-0.64455E+00,-0.64620E+00,-0.64785E+00,-0.64950E+00, & + -0.65114E+00,-0.65278E+00,-0.65441E+00,-0.65603E+00,-0.65766E+00, & + -0.65927E+00,-0.66089E+00,-0.66250E+00,-0.66410E+00,-0.66570E+00, & + -0.66729E+00,-0.66888E+00,-0.67047E+00,-0.67205E+00,-0.67363E+00, & + -0.67520E+00,-0.67677E+00,-0.67834E+00,-0.67990E+00,-0.68146E+00, & + -0.68301E+00,-0.68456E+00,-0.68610E+00,-0.68765E+00,-0.68918E+00, & + -0.69072E+00,-0.69225E+00,-0.69377E+00,-0.69530E+00,-0.69682E+00, & + -0.69833E+00,-0.69984E+00,-0.70135E+00,-0.70285E+00,-0.70436E+00, & + -0.70585E+00,-0.70735E+00,-0.70884E+00,-0.71032E+00,-0.71181E+00, & + -0.71329E+00,-0.71477E+00,-0.71624E+00,-0.71771E+00,-0.71918E+00/ + + DATA (BNC03M (I),I=201,300)/ & + -0.72064E+00,-0.72210E+00,-0.72356E+00,-0.72501E+00,-0.72647E+00, & + -0.72791E+00,-0.72936E+00,-0.73080E+00,-0.73224E+00,-0.73368E+00, & + -0.73511E+00,-0.73654E+00,-0.73797E+00,-0.73939E+00,-0.74082E+00, & + -0.74223E+00,-0.74365E+00,-0.74506E+00,-0.74647E+00,-0.74788E+00, & + -0.74929E+00,-0.75069E+00,-0.75209E+00,-0.75348E+00,-0.75488E+00, & + -0.75627E+00,-0.75766E+00,-0.75905E+00,-0.76043E+00,-0.76181E+00, & + -0.76319E+00,-0.76456E+00,-0.76594E+00,-0.76731E+00,-0.76868E+00, & + -0.77004E+00,-0.77141E+00,-0.77277E+00,-0.77413E+00,-0.77548E+00, & + -0.77684E+00,-0.77819E+00,-0.77954E+00,-0.78088E+00,-0.78223E+00, & + -0.78357E+00,-0.78491E+00,-0.78625E+00,-0.78758E+00,-0.78892E+00, & + -0.79025E+00,-0.79158E+00,-0.79290E+00,-0.79423E+00,-0.79555E+00, & + -0.79687E+00,-0.79819E+00,-0.79950E+00,-0.80081E+00,-0.80213E+00, & + -0.80344E+00,-0.80474E+00,-0.80605E+00,-0.80735E+00,-0.80865E+00, & + -0.80995E+00,-0.81125E+00,-0.81254E+00,-0.81384E+00,-0.81513E+00, & + -0.81642E+00,-0.81770E+00,-0.81899E+00,-0.82027E+00,-0.82155E+00, & + -0.82283E+00,-0.82411E+00,-0.82539E+00,-0.82666E+00,-0.82793E+00, & + -0.82920E+00,-0.83047E+00,-0.83173E+00,-0.83300E+00,-0.83426E+00, & + -0.83552E+00,-0.83678E+00,-0.83804E+00,-0.83929E+00,-0.84055E+00, & + -0.84180E+00,-0.84305E+00,-0.84430E+00,-0.84555E+00,-0.84679E+00, & + -0.84803E+00,-0.84928E+00,-0.85052E+00,-0.85175E+00,-0.85299E+00/ + + DATA (BNC03M (I),I=301,400)/ & + -0.85423E+00,-0.85546E+00,-0.85669E+00,-0.85792E+00,-0.85915E+00, & + -0.86038E+00,-0.86160E+00,-0.86282E+00,-0.86405E+00,-0.86527E+00, & + -0.86648E+00,-0.86770E+00,-0.86892E+00,-0.87013E+00,-0.87134E+00, & + -0.87256E+00,-0.87377E+00,-0.87497E+00,-0.87618E+00,-0.87738E+00, & + -0.87859E+00,-0.87979E+00,-0.88099E+00,-0.88219E+00,-0.88339E+00, & + -0.88458E+00,-0.88578E+00,-0.88697E+00,-0.88816E+00,-0.88935E+00, & + -0.89054E+00,-0.89173E+00,-0.89292E+00,-0.89410E+00,-0.89528E+00, & + -0.89647E+00,-0.89765E+00,-0.89883E+00,-0.90000E+00,-0.90118E+00, & + -0.90236E+00,-0.90353E+00,-0.90470E+00,-0.90587E+00,-0.90704E+00, & + -0.90821E+00,-0.90938E+00,-0.91054E+00,-0.91171E+00,-0.91287E+00, & + -0.91403E+00,-0.91519E+00,-0.91635E+00,-0.91751E+00,-0.91867E+00, & + -0.91982E+00,-0.92098E+00,-0.92213E+00,-0.92328E+00,-0.92443E+00, & + -0.92558E+00,-0.92673E+00,-0.92788E+00,-0.92902E+00,-0.93017E+00, & + -0.93131E+00,-0.93245E+00,-0.93359E+00,-0.93473E+00,-0.93587E+00, & + -0.93701E+00,-0.93815E+00,-0.93928E+00,-0.94041E+00,-0.94155E+00, & + -0.94268E+00,-0.94381E+00,-0.94494E+00,-0.94607E+00,-0.94719E+00, & + -0.94832E+00,-0.94944E+00,-0.95057E+00,-0.95169E+00,-0.95281E+00, & + -0.95393E+00,-0.95505E+00,-0.95617E+00,-0.95729E+00,-0.95840E+00, & + -0.95952E+00,-0.96063E+00,-0.96174E+00,-0.96285E+00,-0.96396E+00, & + -0.96507E+00,-0.96618E+00,-0.96729E+00,-0.96840E+00,-0.96950E+00/ + + DATA (BNC03M (I),I=401,500)/ & + -0.97061E+00,-0.97171E+00,-0.97281E+00,-0.97391E+00,-0.97501E+00, & + -0.97611E+00,-0.97721E+00,-0.97831E+00,-0.97940E+00,-0.98050E+00, & + -0.98159E+00,-0.98268E+00,-0.98378E+00,-0.98487E+00,-0.98596E+00, & + -0.98705E+00,-0.98813E+00,-0.98922E+00,-0.99031E+00,-0.99139E+00, & + -0.99248E+00,-0.99356E+00,-0.99464E+00,-0.99572E+00,-0.99681E+00, & + -0.99788E+00,-0.99896E+00,-0.10000E+01,-0.10011E+01,-0.10022E+01, & + -0.10033E+01,-0.10043E+01,-0.10054E+01,-0.10065E+01,-0.10076E+01, & + -0.10086E+01,-0.10097E+01,-0.10108E+01,-0.10118E+01,-0.10129E+01, & + -0.10140E+01,-0.10150E+01,-0.10161E+01,-0.10172E+01,-0.10182E+01, & + -0.10193E+01,-0.10203E+01,-0.10214E+01,-0.10225E+01,-0.10235E+01, & + -0.10246E+01,-0.10256E+01,-0.10267E+01,-0.10277E+01,-0.10288E+01, & + -0.10299E+01,-0.10309E+01,-0.10320E+01,-0.10330E+01,-0.10341E+01, & + -0.10351E+01,-0.10362E+01,-0.10372E+01,-0.10382E+01,-0.10393E+01, & + -0.10403E+01,-0.10414E+01,-0.10424E+01,-0.10435E+01,-0.10445E+01, & + -0.10455E+01,-0.10466E+01,-0.10476E+01,-0.10487E+01,-0.10497E+01, & + -0.10507E+01,-0.10518E+01,-0.10528E+01,-0.10538E+01,-0.10549E+01, & + -0.10559E+01,-0.10569E+01,-0.10580E+01,-0.10590E+01,-0.10600E+01, & + -0.10611E+01,-0.10621E+01,-0.10631E+01,-0.10642E+01,-0.10652E+01, & + -0.10662E+01,-0.10672E+01,-0.10683E+01,-0.10693E+01,-0.10703E+01, & + -0.10713E+01,-0.10723E+01,-0.10734E+01,-0.10744E+01,-0.10754E+01/ + + DATA (BNC03M (I),I=501,600)/ & + -0.10764E+01,-0.10774E+01,-0.10785E+01,-0.10795E+01,-0.10805E+01, & + -0.10815E+01,-0.10825E+01,-0.10835E+01,-0.10845E+01,-0.10855E+01, & + -0.10866E+01,-0.10876E+01,-0.10886E+01,-0.10896E+01,-0.10906E+01, & + -0.10916E+01,-0.10926E+01,-0.10936E+01,-0.10946E+01,-0.10956E+01, & + -0.10966E+01,-0.10976E+01,-0.10986E+01,-0.10996E+01,-0.11006E+01, & + -0.11016E+01,-0.11026E+01,-0.11036E+01,-0.11046E+01,-0.11056E+01, & + -0.11066E+01,-0.11076E+01,-0.11086E+01,-0.11096E+01,-0.11106E+01, & + -0.11116E+01,-0.11126E+01,-0.11136E+01,-0.11146E+01,-0.11156E+01, & + -0.11166E+01,-0.11176E+01,-0.11186E+01,-0.11196E+01,-0.11205E+01, & + -0.11215E+01,-0.11225E+01,-0.11235E+01,-0.11245E+01,-0.11255E+01, & + -0.11265E+01,-0.11274E+01,-0.11284E+01,-0.11294E+01,-0.11304E+01, & + -0.11314E+01,-0.11324E+01,-0.11333E+01,-0.11343E+01,-0.11353E+01, & + -0.11363E+01,-0.11373E+01,-0.11382E+01,-0.11392E+01,-0.11402E+01, & + -0.11412E+01,-0.11421E+01,-0.11431E+01,-0.11441E+01,-0.11451E+01, & + -0.11460E+01,-0.11470E+01,-0.11480E+01,-0.11490E+01,-0.11499E+01, & + -0.11509E+01,-0.11519E+01,-0.11528E+01,-0.11538E+01,-0.11548E+01, & + -0.11557E+01,-0.11567E+01,-0.11577E+01,-0.11586E+01,-0.11596E+01, & + -0.11606E+01,-0.11615E+01,-0.11625E+01,-0.11635E+01,-0.11644E+01, & + -0.11654E+01,-0.11663E+01,-0.11673E+01,-0.11683E+01,-0.11692E+01, & + -0.11702E+01,-0.11711E+01,-0.11721E+01,-0.11731E+01,-0.11766E+01/ + + DATA (BNC03M (I),I=601,700)/ & + -0.11845E+01,-0.11940E+01,-0.12034E+01,-0.12128E+01,-0.12222E+01, & + -0.12315E+01,-0.12407E+01,-0.12499E+01,-0.12591E+01,-0.12682E+01, & + -0.12773E+01,-0.12863E+01,-0.12953E+01,-0.13043E+01,-0.13132E+01, & + -0.13221E+01,-0.13310E+01,-0.13398E+01,-0.13486E+01,-0.13573E+01, & + -0.13660E+01,-0.13747E+01,-0.13834E+01,-0.13920E+01,-0.14006E+01, & + -0.14092E+01,-0.14177E+01,-0.14262E+01,-0.14347E+01,-0.14432E+01, & + -0.14516E+01,-0.14600E+01,-0.14684E+01,-0.14768E+01,-0.14851E+01, & + -0.14934E+01,-0.15017E+01,-0.15099E+01,-0.15182E+01,-0.15264E+01, & + -0.15346E+01,-0.15427E+01,-0.15509E+01,-0.15590E+01,-0.15671E+01, & + -0.15752E+01,-0.15833E+01,-0.15913E+01,-0.15993E+01,-0.16073E+01, & + -0.16153E+01,-0.16233E+01,-0.16313E+01,-0.16392E+01,-0.16471E+01, & + -0.16550E+01,-0.16629E+01,-0.16707E+01,-0.16786E+01,-0.16864E+01, & + -0.16942E+01,-0.17020E+01,-0.17098E+01,-0.17176E+01,-0.17253E+01, & + -0.17331E+01,-0.17408E+01,-0.17485E+01,-0.17562E+01,-0.17639E+01, & + -0.17715E+01,-0.17792E+01,-0.17868E+01,-0.17944E+01,-0.18021E+01, & + -0.18096E+01,-0.18172E+01,-0.18248E+01,-0.18324E+01,-0.18399E+01, & + -0.18474E+01,-0.18550E+01,-0.18625E+01,-0.18700E+01,-0.18774E+01, & + -0.18849E+01,-0.18924E+01,-0.18998E+01,-0.19073E+01,-0.19147E+01, & + -0.19221E+01,-0.19295E+01,-0.19369E+01,-0.19443E+01,-0.19516E+01, & + -0.19590E+01,-0.19664E+01,-0.19737E+01,-0.19810E+01,-0.19883E+01/ + + DATA (BNC03M(I),I=701,741)/ & + -0.19957E+01,-0.20030E+01,-0.20102E+01,-0.20175E+01,-0.20248E+01, & + -0.20321E+01,-0.20393E+01,-0.20466E+01,-0.20538E+01,-0.20610E+01, & + -0.20682E+01,-0.20754E+01,-0.20826E+01,-0.20898E+01,-0.20970E+01, & + -0.21042E+01,-0.21113E+01,-0.21185E+01,-0.21256E+01,-0.21328E+01, & + -0.21399E+01,-0.21470E+01,-0.21542E+01,-0.21613E+01,-0.21684E+01, & + -0.21754E+01,-0.21825E+01,-0.21896E+01,-0.21967E+01,-0.22037E+01, & + -0.22108E+01,-0.22178E+01,-0.22249E+01,-0.22319E+01,-0.22389E+01, & + -0.22459E+01,-0.22530E+01,-0.22600E+01,-0.22670E+01,-0.22739E+01, & + -0.22809E+01 & + / +! +! *** (NH4)2SO4 +! + DATA (BNC04M (I),I= 1,100)/ & + -0.11406E+00,-0.20949E+00,-0.27798E+00,-0.32543E+00,-0.36258E+00, & + -0.39344E+00,-0.42000E+00,-0.44344E+00,-0.46447E+00,-0.48360E+00, & + -0.50119E+00,-0.51749E+00,-0.53270E+00,-0.54698E+00,-0.56046E+00, & + -0.57323E+00,-0.58538E+00,-0.59697E+00,-0.60807E+00,-0.61871E+00, & + -0.62895E+00,-0.63882E+00,-0.64835E+00,-0.65756E+00,-0.66649E+00, & + -0.67515E+00,-0.68356E+00,-0.69174E+00,-0.69971E+00,-0.70747E+00, & + -0.71505E+00,-0.72244E+00,-0.72967E+00,-0.73674E+00,-0.74366E+00, & + -0.75044E+00,-0.75708E+00,-0.76359E+00,-0.76998E+00,-0.77626E+00, & + -0.78242E+00,-0.78847E+00,-0.79443E+00,-0.80028E+00,-0.80605E+00, & + -0.81172E+00,-0.81731E+00,-0.82281E+00,-0.82823E+00,-0.83358E+00, & + -0.83886E+00,-0.84406E+00,-0.84919E+00,-0.85426E+00,-0.85927E+00, & + -0.86421E+00,-0.86910E+00,-0.87392E+00,-0.87870E+00,-0.88342E+00, & + -0.88808E+00,-0.89270E+00,-0.89727E+00,-0.90180E+00,-0.90628E+00, & + -0.91072E+00,-0.91511E+00,-0.91947E+00,-0.92378E+00,-0.92806E+00, & + -0.93230E+00,-0.93651E+00,-0.94069E+00,-0.94483E+00,-0.94894E+00, & + -0.95301E+00,-0.95706E+00,-0.96108E+00,-0.96508E+00,-0.96904E+00, & + -0.97298E+00,-0.97690E+00,-0.98079E+00,-0.98466E+00,-0.98850E+00, & + -0.99232E+00,-0.99612E+00,-0.99990E+00,-0.10037E+01,-0.10074E+01, & + -0.10111E+01,-0.10148E+01,-0.10185E+01,-0.10222E+01,-0.10258E+01, & + -0.10294E+01,-0.10331E+01,-0.10366E+01,-0.10402E+01,-0.10438E+01/ + + DATA (BNC04M (I),I=101,200)/ & + -0.10473E+01,-0.10509E+01,-0.10544E+01,-0.10579E+01,-0.10614E+01, & + -0.10648E+01,-0.10683E+01,-0.10718E+01,-0.10752E+01,-0.10786E+01, & + -0.10820E+01,-0.10854E+01,-0.10888E+01,-0.10921E+01,-0.10955E+01, & + -0.10988E+01,-0.11021E+01,-0.11054E+01,-0.11087E+01,-0.11120E+01, & + -0.11152E+01,-0.11185E+01,-0.11217E+01,-0.11250E+01,-0.11282E+01, & + -0.11314E+01,-0.11346E+01,-0.11378E+01,-0.11410E+01,-0.11442E+01, & + -0.11473E+01,-0.11505E+01,-0.11536E+01,-0.11567E+01,-0.11598E+01, & + -0.11629E+01,-0.11660E+01,-0.11691E+01,-0.11722E+01,-0.11752E+01, & + -0.11783E+01,-0.11813E+01,-0.11844E+01,-0.11874E+01,-0.11904E+01, & + -0.11934E+01,-0.11964E+01,-0.11994E+01,-0.12023E+01,-0.12053E+01, & + -0.12082E+01,-0.12112E+01,-0.12141E+01,-0.12171E+01,-0.12200E+01, & + -0.12229E+01,-0.12258E+01,-0.12287E+01,-0.12316E+01,-0.12344E+01, & + -0.12373E+01,-0.12402E+01,-0.12430E+01,-0.12459E+01,-0.12487E+01, & + -0.12515E+01,-0.12544E+01,-0.12572E+01,-0.12600E+01,-0.12628E+01, & + -0.12656E+01,-0.12683E+01,-0.12711E+01,-0.12739E+01,-0.12767E+01, & + -0.12794E+01,-0.12822E+01,-0.12849E+01,-0.12876E+01,-0.12904E+01, & + -0.12931E+01,-0.12958E+01,-0.12985E+01,-0.13012E+01,-0.13039E+01, & + -0.13066E+01,-0.13093E+01,-0.13120E+01,-0.13147E+01,-0.13173E+01, & + -0.13200E+01,-0.13226E+01,-0.13253E+01,-0.13279E+01,-0.13306E+01, & + -0.13332E+01,-0.13358E+01,-0.13385E+01,-0.13411E+01,-0.13437E+01/ + + DATA (BNC04M (I),I=201,300)/ & + -0.13463E+01,-0.13489E+01,-0.13515E+01,-0.13541E+01,-0.13567E+01, & + -0.13592E+01,-0.13618E+01,-0.13644E+01,-0.13669E+01,-0.13695E+01, & + -0.13720E+01,-0.13746E+01,-0.13771E+01,-0.13797E+01,-0.13822E+01, & + -0.13847E+01,-0.13873E+01,-0.13898E+01,-0.13923E+01,-0.13948E+01, & + -0.13973E+01,-0.13998E+01,-0.14023E+01,-0.14048E+01,-0.14073E+01, & + -0.14098E+01,-0.14122E+01,-0.14147E+01,-0.14172E+01,-0.14196E+01, & + -0.14221E+01,-0.14245E+01,-0.14270E+01,-0.14294E+01,-0.14319E+01, & + -0.14343E+01,-0.14368E+01,-0.14392E+01,-0.14416E+01,-0.14440E+01, & + -0.14465E+01,-0.14489E+01,-0.14513E+01,-0.14537E+01,-0.14561E+01, & + -0.14585E+01,-0.14609E+01,-0.14633E+01,-0.14657E+01,-0.14681E+01, & + -0.14704E+01,-0.14728E+01,-0.14752E+01,-0.14776E+01,-0.14799E+01, & + -0.14823E+01,-0.14846E+01,-0.14870E+01,-0.14893E+01,-0.14917E+01, & + -0.14940E+01,-0.14964E+01,-0.14987E+01,-0.15011E+01,-0.15034E+01, & + -0.15057E+01,-0.15080E+01,-0.15104E+01,-0.15127E+01,-0.15150E+01, & + -0.15173E+01,-0.15196E+01,-0.15219E+01,-0.15242E+01,-0.15265E+01, & + -0.15288E+01,-0.15311E+01,-0.15334E+01,-0.15357E+01,-0.15380E+01, & + -0.15402E+01,-0.15425E+01,-0.15448E+01,-0.15471E+01,-0.15493E+01, & + -0.15516E+01,-0.15538E+01,-0.15561E+01,-0.15584E+01,-0.15606E+01, & + -0.15629E+01,-0.15651E+01,-0.15674E+01,-0.15696E+01,-0.15718E+01, & + -0.15741E+01,-0.15763E+01,-0.15785E+01,-0.15808E+01,-0.15830E+01/ + + DATA (BNC04M (I),I=301,400)/ & + -0.15852E+01,-0.15874E+01,-0.15896E+01,-0.15919E+01,-0.15941E+01, & + -0.15963E+01,-0.15985E+01,-0.16007E+01,-0.16029E+01,-0.16051E+01, & + -0.16073E+01,-0.16095E+01,-0.16117E+01,-0.16138E+01,-0.16160E+01, & + -0.16182E+01,-0.16204E+01,-0.16226E+01,-0.16247E+01,-0.16269E+01, & + -0.16291E+01,-0.16313E+01,-0.16334E+01,-0.16356E+01,-0.16377E+01, & + -0.16399E+01,-0.16421E+01,-0.16442E+01,-0.16464E+01,-0.16485E+01, & + -0.16507E+01,-0.16528E+01,-0.16549E+01,-0.16571E+01,-0.16592E+01, & + -0.16614E+01,-0.16635E+01,-0.16656E+01,-0.16678E+01,-0.16699E+01, & + -0.16720E+01,-0.16741E+01,-0.16762E+01,-0.16784E+01,-0.16805E+01, & + -0.16826E+01,-0.16847E+01,-0.16868E+01,-0.16889E+01,-0.16910E+01, & + -0.16931E+01,-0.16952E+01,-0.16973E+01,-0.16994E+01,-0.17015E+01, & + -0.17036E+01,-0.17057E+01,-0.17078E+01,-0.17099E+01,-0.17120E+01, & + -0.17140E+01,-0.17161E+01,-0.17182E+01,-0.17203E+01,-0.17223E+01, & + -0.17244E+01,-0.17265E+01,-0.17286E+01,-0.17306E+01,-0.17327E+01, & + -0.17348E+01,-0.17368E+01,-0.17389E+01,-0.17409E+01,-0.17430E+01, & + -0.17450E+01,-0.17471E+01,-0.17491E+01,-0.17512E+01,-0.17532E+01, & + -0.17553E+01,-0.17573E+01,-0.17594E+01,-0.17614E+01,-0.17634E+01, & + -0.17655E+01,-0.17675E+01,-0.17695E+01,-0.17716E+01,-0.17736E+01, & + -0.17756E+01,-0.17776E+01,-0.17797E+01,-0.17817E+01,-0.17837E+01, & + -0.17857E+01,-0.17877E+01,-0.17898E+01,-0.17918E+01,-0.17938E+01/ + + DATA (BNC04M (I),I=401,500)/ & + -0.17958E+01,-0.17978E+01,-0.17998E+01,-0.18018E+01,-0.18038E+01, & + -0.18058E+01,-0.18078E+01,-0.18098E+01,-0.18118E+01,-0.18138E+01, & + -0.18158E+01,-0.18178E+01,-0.18198E+01,-0.18218E+01,-0.18238E+01, & + -0.18257E+01,-0.18277E+01,-0.18297E+01,-0.18317E+01,-0.18337E+01, & + -0.18356E+01,-0.18376E+01,-0.18396E+01,-0.18416E+01,-0.18435E+01, & + -0.18455E+01,-0.18475E+01,-0.18494E+01,-0.18514E+01,-0.18534E+01, & + -0.18553E+01,-0.18573E+01,-0.18593E+01,-0.18612E+01,-0.18632E+01, & + -0.18651E+01,-0.18671E+01,-0.18690E+01,-0.18710E+01,-0.18729E+01, & + -0.18749E+01,-0.18768E+01,-0.18788E+01,-0.18807E+01,-0.18827E+01, & + -0.18846E+01,-0.18865E+01,-0.18885E+01,-0.18904E+01,-0.18923E+01, & + -0.18943E+01,-0.18962E+01,-0.18981E+01,-0.19001E+01,-0.19020E+01, & + -0.19039E+01,-0.19058E+01,-0.19078E+01,-0.19097E+01,-0.19116E+01, & + -0.19135E+01,-0.19155E+01,-0.19174E+01,-0.19193E+01,-0.19212E+01, & + -0.19231E+01,-0.19250E+01,-0.19269E+01,-0.19289E+01,-0.19308E+01, & + -0.19327E+01,-0.19346E+01,-0.19365E+01,-0.19384E+01,-0.19403E+01, & + -0.19422E+01,-0.19441E+01,-0.19460E+01,-0.19479E+01,-0.19498E+01, & + -0.19517E+01,-0.19536E+01,-0.19555E+01,-0.19574E+01,-0.19592E+01, & + -0.19611E+01,-0.19630E+01,-0.19649E+01,-0.19668E+01,-0.19687E+01, & + -0.19706E+01,-0.19724E+01,-0.19743E+01,-0.19762E+01,-0.19781E+01, & + -0.19800E+01,-0.19818E+01,-0.19837E+01,-0.19856E+01,-0.19875E+01/ + + DATA (BNC04M (I),I=501,600)/ & + -0.19893E+01,-0.19912E+01,-0.19931E+01,-0.19949E+01,-0.19968E+01, & + -0.19987E+01,-0.20005E+01,-0.20024E+01,-0.20043E+01,-0.20061E+01, & + -0.20080E+01,-0.20098E+01,-0.20117E+01,-0.20136E+01,-0.20154E+01, & + -0.20173E+01,-0.20191E+01,-0.20210E+01,-0.20228E+01,-0.20247E+01, & + -0.20265E+01,-0.20284E+01,-0.20302E+01,-0.20321E+01,-0.20339E+01, & + -0.20358E+01,-0.20376E+01,-0.20394E+01,-0.20413E+01,-0.20431E+01, & + -0.20450E+01,-0.20468E+01,-0.20486E+01,-0.20505E+01,-0.20523E+01, & + -0.20541E+01,-0.20560E+01,-0.20578E+01,-0.20596E+01,-0.20615E+01, & + -0.20633E+01,-0.20651E+01,-0.20669E+01,-0.20688E+01,-0.20706E+01, & + -0.20724E+01,-0.20742E+01,-0.20761E+01,-0.20779E+01,-0.20797E+01, & + -0.20815E+01,-0.20833E+01,-0.20852E+01,-0.20870E+01,-0.20888E+01, & + -0.20906E+01,-0.20924E+01,-0.20942E+01,-0.20960E+01,-0.20979E+01, & + -0.20997E+01,-0.21015E+01,-0.21033E+01,-0.21051E+01,-0.21069E+01, & + -0.21087E+01,-0.21105E+01,-0.21123E+01,-0.21141E+01,-0.21159E+01, & + -0.21177E+01,-0.21195E+01,-0.21213E+01,-0.21231E+01,-0.21249E+01, & + -0.21267E+01,-0.21285E+01,-0.21303E+01,-0.21321E+01,-0.21339E+01, & + -0.21356E+01,-0.21374E+01,-0.21392E+01,-0.21410E+01,-0.21428E+01, & + -0.21446E+01,-0.21464E+01,-0.21482E+01,-0.21499E+01,-0.21517E+01, & + -0.21535E+01,-0.21553E+01,-0.21571E+01,-0.21588E+01,-0.21606E+01, & + -0.21624E+01,-0.21642E+01,-0.21660E+01,-0.21677E+01,-0.21744E+01/ + + DATA (BNC04M (I),I=601,700)/ & + -0.21890E+01,-0.22066E+01,-0.22241E+01,-0.22416E+01,-0.22589E+01, & + -0.22762E+01,-0.22935E+01,-0.23106E+01,-0.23277E+01,-0.23448E+01, & + -0.23617E+01,-0.23786E+01,-0.23955E+01,-0.24122E+01,-0.24290E+01, & + -0.24456E+01,-0.24622E+01,-0.24788E+01,-0.24953E+01,-0.25117E+01, & + -0.25281E+01,-0.25445E+01,-0.25608E+01,-0.25770E+01,-0.25932E+01, & + -0.26094E+01,-0.26255E+01,-0.26415E+01,-0.26575E+01,-0.26735E+01, & + -0.26894E+01,-0.27053E+01,-0.27212E+01,-0.27370E+01,-0.27528E+01, & + -0.27685E+01,-0.27842E+01,-0.27998E+01,-0.28155E+01,-0.28310E+01, & + -0.28466E+01,-0.28621E+01,-0.28776E+01,-0.28930E+01,-0.29084E+01, & + -0.29238E+01,-0.29392E+01,-0.29545E+01,-0.29698E+01,-0.29850E+01, & + -0.30002E+01,-0.30154E+01,-0.30306E+01,-0.30457E+01,-0.30608E+01, & + -0.30759E+01,-0.30910E+01,-0.31060E+01,-0.31210E+01,-0.31360E+01, & + -0.31509E+01,-0.31658E+01,-0.31807E+01,-0.31956E+01,-0.32104E+01, & + -0.32252E+01,-0.32400E+01,-0.32548E+01,-0.32696E+01,-0.32843E+01, & + -0.32990E+01,-0.33137E+01,-0.33283E+01,-0.33430E+01,-0.33576E+01, & + -0.33722E+01,-0.33867E+01,-0.34013E+01,-0.34158E+01,-0.34303E+01, & + -0.34448E+01,-0.34593E+01,-0.34737E+01,-0.34882E+01,-0.35026E+01, & + -0.35170E+01,-0.35313E+01,-0.35457E+01,-0.35600E+01,-0.35743E+01, & + -0.35886E+01,-0.36029E+01,-0.36172E+01,-0.36314E+01,-0.36456E+01, & + -0.36599E+01,-0.36741E+01,-0.36882E+01,-0.37024E+01,-0.37165E+01/ + + DATA (BNC04M(I),I=701,741)/ & + -0.37307E+01,-0.37448E+01,-0.37589E+01,-0.37730E+01,-0.37870E+01, & + -0.38011E+01,-0.38151E+01,-0.38291E+01,-0.38431E+01,-0.38571E+01, & + -0.38711E+01,-0.38850E+01,-0.38990E+01,-0.39129E+01,-0.39268E+01, & + -0.39407E+01,-0.39546E+01,-0.39685E+01,-0.39824E+01,-0.39962E+01, & + -0.40100E+01,-0.40239E+01,-0.40377E+01,-0.40515E+01,-0.40653E+01, & + -0.40790E+01,-0.40928E+01,-0.41065E+01,-0.41203E+01,-0.41340E+01, & + -0.41477E+01,-0.41614E+01,-0.41751E+01,-0.41887E+01,-0.42024E+01, & + -0.42160E+01,-0.42297E+01,-0.42433E+01,-0.42569E+01,-0.42705E+01, & + -0.42841E+01 & + / +! +! *** NH4NO3 +! + DATA (BNC05M (I),I= 1,100)/ & + -0.58030E-01,-0.10848E+00,-0.14612E+00,-0.17306E+00,-0.19474E+00, & + -0.21318E+00,-0.22940E+00,-0.24400E+00,-0.25734E+00,-0.26968E+00, & + -0.28121E+00,-0.29205E+00,-0.30231E+00,-0.31208E+00,-0.32141E+00, & + -0.33035E+00,-0.33895E+00,-0.34724E+00,-0.35526E+00,-0.36302E+00, & + -0.37055E+00,-0.37787E+00,-0.38499E+00,-0.39194E+00,-0.39871E+00, & + -0.40532E+00,-0.41178E+00,-0.41811E+00,-0.42430E+00,-0.43037E+00, & + -0.43632E+00,-0.44215E+00,-0.44788E+00,-0.45350E+00,-0.45902E+00, & + -0.46446E+00,-0.46979E+00,-0.47505E+00,-0.48021E+00,-0.48530E+00, & + -0.49031E+00,-0.49524E+00,-0.50010E+00,-0.50489E+00,-0.50962E+00, & + -0.51427E+00,-0.51886E+00,-0.52339E+00,-0.52786E+00,-0.53228E+00, & + -0.53663E+00,-0.54094E+00,-0.54519E+00,-0.54939E+00,-0.55354E+00, & + -0.55764E+00,-0.56170E+00,-0.56571E+00,-0.56968E+00,-0.57361E+00, & + -0.57750E+00,-0.58136E+00,-0.58517E+00,-0.58895E+00,-0.59270E+00, & + -0.59641E+00,-0.60010E+00,-0.60375E+00,-0.60738E+00,-0.61098E+00, & + -0.61455E+00,-0.61810E+00,-0.62162E+00,-0.62512E+00,-0.62860E+00, & + -0.63206E+00,-0.63550E+00,-0.63892E+00,-0.64233E+00,-0.64571E+00, & + -0.64908E+00,-0.65244E+00,-0.65578E+00,-0.65911E+00,-0.66242E+00, & + -0.66572E+00,-0.66901E+00,-0.67228E+00,-0.67555E+00,-0.67880E+00, & + -0.68205E+00,-0.68528E+00,-0.68850E+00,-0.69171E+00,-0.69492E+00, & + -0.69811E+00,-0.70130E+00,-0.70447E+00,-0.70764E+00,-0.71080E+00/ + + DATA (BNC05M (I),I=101,200)/ & + -0.71394E+00,-0.71708E+00,-0.72021E+00,-0.72334E+00,-0.72645E+00, & + -0.72955E+00,-0.73265E+00,-0.73573E+00,-0.73881E+00,-0.74187E+00, & + -0.74493E+00,-0.74798E+00,-0.75101E+00,-0.75404E+00,-0.75706E+00, & + -0.76007E+00,-0.76307E+00,-0.76606E+00,-0.76903E+00,-0.77200E+00, & + -0.77479E+00,-0.77776E+00,-0.78071E+00,-0.78366E+00,-0.78659E+00, & + -0.78951E+00,-0.79242E+00,-0.79531E+00,-0.79820E+00,-0.80107E+00, & + -0.80393E+00,-0.80678E+00,-0.80962E+00,-0.81245E+00,-0.81527E+00, & + -0.81808E+00,-0.82087E+00,-0.82366E+00,-0.82644E+00,-0.82920E+00, & + -0.83196E+00,-0.83470E+00,-0.83744E+00,-0.84016E+00,-0.84288E+00, & + -0.84558E+00,-0.84828E+00,-0.85097E+00,-0.85365E+00,-0.85631E+00, & + -0.85897E+00,-0.86162E+00,-0.86426E+00,-0.86689E+00,-0.86951E+00, & + -0.87213E+00,-0.87473E+00,-0.87733E+00,-0.87992E+00,-0.88249E+00, & + -0.88506E+00,-0.88763E+00,-0.89018E+00,-0.89272E+00,-0.89526E+00, & + -0.89779E+00,-0.90031E+00,-0.90282E+00,-0.90532E+00,-0.90782E+00, & + -0.91031E+00,-0.91279E+00,-0.91526E+00,-0.91773E+00,-0.92019E+00, & + -0.92264E+00,-0.92508E+00,-0.92751E+00,-0.92994E+00,-0.93236E+00, & + -0.93477E+00,-0.93718E+00,-0.93958E+00,-0.94197E+00,-0.94435E+00, & + -0.94673E+00,-0.94910E+00,-0.95147E+00,-0.95382E+00,-0.95617E+00, & + -0.95852E+00,-0.96085E+00,-0.96318E+00,-0.96550E+00,-0.96782E+00, & + -0.97013E+00,-0.97243E+00,-0.97473E+00,-0.97702E+00,-0.97931E+00/ + + DATA (BNC05M (I),I=201,300)/ & + -0.98158E+00,-0.98386E+00,-0.98612E+00,-0.98838E+00,-0.99063E+00, & + -0.99288E+00,-0.99512E+00,-0.99736E+00,-0.99959E+00,-0.10018E+01, & + -0.10040E+01,-0.10062E+01,-0.10084E+01,-0.10106E+01,-0.10128E+01, & + -0.10150E+01,-0.10172E+01,-0.10194E+01,-0.10216E+01,-0.10237E+01, & + -0.10259E+01,-0.10280E+01,-0.10302E+01,-0.10323E+01,-0.10345E+01, & + -0.10366E+01,-0.10387E+01,-0.10409E+01,-0.10430E+01,-0.10451E+01, & + -0.10472E+01,-0.10493E+01,-0.10514E+01,-0.10535E+01,-0.10556E+01, & + -0.10576E+01,-0.10597E+01,-0.10618E+01,-0.10639E+01,-0.10659E+01, & + -0.10680E+01,-0.10700E+01,-0.10721E+01,-0.10741E+01,-0.10762E+01, & + -0.10782E+01,-0.10802E+01,-0.10822E+01,-0.10843E+01,-0.10863E+01, & + -0.10883E+01,-0.10903E+01,-0.10923E+01,-0.10943E+01,-0.10963E+01, & + -0.10983E+01,-0.11002E+01,-0.11022E+01,-0.11042E+01,-0.11062E+01, & + -0.11081E+01,-0.11101E+01,-0.11120E+01,-0.11140E+01,-0.11159E+01, & + -0.11179E+01,-0.11198E+01,-0.11218E+01,-0.11237E+01,-0.11256E+01, & + -0.11275E+01,-0.11294E+01,-0.11314E+01,-0.11333E+01,-0.11352E+01, & + -0.11371E+01,-0.11390E+01,-0.11409E+01,-0.11428E+01,-0.11446E+01, & + -0.11465E+01,-0.11484E+01,-0.11503E+01,-0.11522E+01,-0.11540E+01, & + -0.11559E+01,-0.11577E+01,-0.11596E+01,-0.11614E+01,-0.11633E+01, & + -0.11651E+01,-0.11670E+01,-0.11688E+01,-0.11706E+01,-0.11725E+01, & + -0.11743E+01,-0.11761E+01,-0.11779E+01,-0.11798E+01,-0.11816E+01/ + + DATA (BNC05M (I),I=301,400)/ & + -0.11834E+01,-0.11852E+01,-0.11870E+01,-0.11888E+01,-0.11906E+01, & + -0.11924E+01,-0.11941E+01,-0.11959E+01,-0.11977E+01,-0.11995E+01, & + -0.12013E+01,-0.12030E+01,-0.12048E+01,-0.12066E+01,-0.12083E+01, & + -0.12101E+01,-0.12118E+01,-0.12136E+01,-0.12153E+01,-0.12171E+01, & + -0.12188E+01,-0.12205E+01,-0.12223E+01,-0.12240E+01,-0.12257E+01, & + -0.12275E+01,-0.12292E+01,-0.12309E+01,-0.12326E+01,-0.12343E+01, & + -0.12360E+01,-0.12377E+01,-0.12394E+01,-0.12411E+01,-0.12428E+01, & + -0.12445E+01,-0.12462E+01,-0.12479E+01,-0.12496E+01,-0.12513E+01, & + -0.12530E+01,-0.12546E+01,-0.12563E+01,-0.12580E+01,-0.12596E+01, & + -0.12613E+01,-0.12630E+01,-0.12646E+01,-0.12663E+01,-0.12679E+01, & + -0.12696E+01,-0.12712E+01,-0.12729E+01,-0.12745E+01,-0.12762E+01, & + -0.12778E+01,-0.12794E+01,-0.12811E+01,-0.12827E+01,-0.12843E+01, & + -0.12859E+01,-0.12876E+01,-0.12892E+01,-0.12908E+01,-0.12924E+01, & + -0.12940E+01,-0.12956E+01,-0.12972E+01,-0.12988E+01,-0.13004E+01, & + -0.13020E+01,-0.13036E+01,-0.13052E+01,-0.13068E+01,-0.13084E+01, & + -0.13100E+01,-0.13116E+01,-0.13131E+01,-0.13147E+01,-0.13163E+01, & + -0.13179E+01,-0.13194E+01,-0.13210E+01,-0.13226E+01,-0.13241E+01, & + -0.13257E+01,-0.13272E+01,-0.13288E+01,-0.13303E+01,-0.13319E+01, & + -0.13334E+01,-0.13350E+01,-0.13365E+01,-0.13381E+01,-0.13396E+01, & + -0.13411E+01,-0.13427E+01,-0.13442E+01,-0.13457E+01,-0.13473E+01/ + + DATA (BNC05M (I),I=401,500)/ & + -0.13488E+01,-0.13503E+01,-0.13518E+01,-0.13533E+01,-0.13549E+01, & + -0.13564E+01,-0.13579E+01,-0.13594E+01,-0.13609E+01,-0.13624E+01, & + -0.13639E+01,-0.13654E+01,-0.13669E+01,-0.13684E+01,-0.13699E+01, & + -0.13714E+01,-0.13729E+01,-0.13744E+01,-0.13758E+01,-0.13773E+01, & + -0.13788E+01,-0.13803E+01,-0.13818E+01,-0.13832E+01,-0.13847E+01, & + -0.13862E+01,-0.13877E+01,-0.13891E+01,-0.13906E+01,-0.13920E+01, & + -0.13935E+01,-0.13950E+01,-0.13964E+01,-0.13979E+01,-0.13993E+01, & + -0.14008E+01,-0.14022E+01,-0.14037E+01,-0.14051E+01,-0.14066E+01, & + -0.14080E+01,-0.14094E+01,-0.14109E+01,-0.14123E+01,-0.14137E+01, & + -0.14152E+01,-0.14166E+01,-0.14180E+01,-0.14195E+01,-0.14209E+01, & + -0.14223E+01,-0.14237E+01,-0.14251E+01,-0.14266E+01,-0.14280E+01, & + -0.14294E+01,-0.14308E+01,-0.14322E+01,-0.14336E+01,-0.14350E+01, & + -0.14364E+01,-0.14378E+01,-0.14392E+01,-0.14406E+01,-0.14420E+01, & + -0.14434E+01,-0.14448E+01,-0.14462E+01,-0.14476E+01,-0.14490E+01, & + -0.14504E+01,-0.14517E+01,-0.14531E+01,-0.14545E+01,-0.14559E+01, & + -0.14573E+01,-0.14586E+01,-0.14600E+01,-0.14614E+01,-0.14627E+01, & + -0.14641E+01,-0.14655E+01,-0.14668E+01,-0.14682E+01,-0.14696E+01, & + -0.14709E+01,-0.14723E+01,-0.14736E+01,-0.14750E+01,-0.14764E+01, & + -0.14777E+01,-0.14791E+01,-0.14804E+01,-0.14818E+01,-0.14831E+01, & + -0.14844E+01,-0.14858E+01,-0.14871E+01,-0.14885E+01,-0.14898E+01/ + + DATA (BNC05M (I),I=501,600)/ & + -0.14911E+01,-0.14925E+01,-0.14938E+01,-0.14951E+01,-0.14965E+01, & + -0.14978E+01,-0.14991E+01,-0.15005E+01,-0.15018E+01,-0.15031E+01, & + -0.15044E+01,-0.15057E+01,-0.15071E+01,-0.15084E+01,-0.15097E+01, & + -0.15110E+01,-0.15123E+01,-0.15136E+01,-0.15149E+01,-0.15162E+01, & + -0.15175E+01,-0.15188E+01,-0.15202E+01,-0.15215E+01,-0.15228E+01, & + -0.15241E+01,-0.15253E+01,-0.15266E+01,-0.15279E+01,-0.15292E+01, & + -0.15305E+01,-0.15318E+01,-0.15331E+01,-0.15344E+01,-0.15357E+01, & + -0.15370E+01,-0.15382E+01,-0.15395E+01,-0.15408E+01,-0.15421E+01, & + -0.15434E+01,-0.15446E+01,-0.15459E+01,-0.15472E+01,-0.15485E+01, & + -0.15497E+01,-0.15510E+01,-0.15523E+01,-0.15535E+01,-0.15548E+01, & + -0.15561E+01,-0.15573E+01,-0.15586E+01,-0.15598E+01,-0.15611E+01, & + -0.15624E+01,-0.15636E+01,-0.15649E+01,-0.15661E+01,-0.15674E+01, & + -0.15686E+01,-0.15699E+01,-0.15711E+01,-0.15724E+01,-0.15736E+01, & + -0.15749E+01,-0.15761E+01,-0.15773E+01,-0.15786E+01,-0.15798E+01, & + -0.15811E+01,-0.15823E+01,-0.15835E+01,-0.15848E+01,-0.15860E+01, & + -0.15872E+01,-0.15885E+01,-0.15897E+01,-0.15909E+01,-0.15922E+01, & + -0.15934E+01,-0.15946E+01,-0.15958E+01,-0.15971E+01,-0.15983E+01, & + -0.15995E+01,-0.16007E+01,-0.16019E+01,-0.16031E+01,-0.16044E+01, & + -0.16056E+01,-0.16068E+01,-0.16080E+01,-0.16092E+01,-0.16104E+01, & + -0.16116E+01,-0.16128E+01,-0.16140E+01,-0.16152E+01,-0.16198E+01/ + + DATA (BNC05M (I),I=601,700)/ & + -0.16296E+01,-0.16415E+01,-0.16532E+01,-0.16649E+01,-0.16764E+01, & + -0.16878E+01,-0.16992E+01,-0.17104E+01,-0.17216E+01,-0.17327E+01, & + -0.17437E+01,-0.17546E+01,-0.17654E+01,-0.17761E+01,-0.17868E+01, & + -0.17974E+01,-0.18079E+01,-0.18184E+01,-0.18287E+01,-0.18391E+01, & + -0.18493E+01,-0.18595E+01,-0.18696E+01,-0.18796E+01,-0.18896E+01, & + -0.18996E+01,-0.19094E+01,-0.19193E+01,-0.19290E+01,-0.19387E+01, & + -0.19484E+01,-0.19580E+01,-0.19675E+01,-0.19770E+01,-0.19865E+01, & + -0.19959E+01,-0.20053E+01,-0.20146E+01,-0.20238E+01,-0.20331E+01, & + -0.20423E+01,-0.20514E+01,-0.20605E+01,-0.20695E+01,-0.20786E+01, & + -0.20875E+01,-0.20965E+01,-0.21054E+01,-0.21143E+01,-0.21231E+01, & + -0.21319E+01,-0.21407E+01,-0.21494E+01,-0.21581E+01,-0.21667E+01, & + -0.21754E+01,-0.21840E+01,-0.21925E+01,-0.22011E+01,-0.22096E+01, & + -0.22180E+01,-0.22265E+01,-0.22349E+01,-0.22433E+01,-0.22517E+01, & + -0.22600E+01,-0.22683E+01,-0.22766E+01,-0.22848E+01,-0.22931E+01, & + -0.23013E+01,-0.23095E+01,-0.23176E+01,-0.23257E+01,-0.23338E+01, & + -0.23419E+01,-0.23500E+01,-0.23580E+01,-0.23661E+01,-0.23741E+01, & + -0.23820E+01,-0.23900E+01,-0.23979E+01,-0.24058E+01,-0.24137E+01, & + -0.24216E+01,-0.24294E+01,-0.24373E+01,-0.24451E+01,-0.24529E+01, & + -0.24607E+01,-0.24684E+01,-0.24762E+01,-0.24839E+01,-0.24916E+01, & + -0.24993E+01,-0.25070E+01,-0.25146E+01,-0.25222E+01,-0.25299E+01/ + + DATA (BNC05M(I),I=701,741)/ & + -0.25375E+01,-0.25451E+01,-0.25526E+01,-0.25602E+01,-0.25677E+01, & + -0.25753E+01,-0.25828E+01,-0.25903E+01,-0.25978E+01,-0.26052E+01, & + -0.26127E+01,-0.26201E+01,-0.26276E+01,-0.26350E+01,-0.26424E+01, & + -0.26498E+01,-0.26571E+01,-0.26645E+01,-0.26718E+01,-0.26792E+01, & + -0.26865E+01,-0.26938E+01,-0.27011E+01,-0.27084E+01,-0.27157E+01, & + -0.27229E+01,-0.27302E+01,-0.27374E+01,-0.27446E+01,-0.27519E+01, & + -0.27591E+01,-0.27663E+01,-0.27734E+01,-0.27806E+01,-0.27878E+01, & + -0.27949E+01,-0.28021E+01,-0.28092E+01,-0.28163E+01,-0.28234E+01, & + -0.28305E+01 & + / +! +! *** NH4Cl +! + DATA (BNC06M (I),I= 1,100)/ & + -0.55953E-01,-0.10077E+00,-0.13146E+00,-0.15183E+00,-0.16717E+00, & + -0.17947E+00,-0.18969E+00,-0.19842E+00,-0.20600E+00,-0.21268E+00, & + -0.21863E+00,-0.22398E+00,-0.22882E+00,-0.23322E+00,-0.23726E+00, & + -0.24097E+00,-0.24440E+00,-0.24758E+00,-0.25054E+00,-0.25330E+00, & + -0.25588E+00,-0.25830E+00,-0.26057E+00,-0.26271E+00,-0.26473E+00, & + -0.26663E+00,-0.26844E+00,-0.27015E+00,-0.27178E+00,-0.27333E+00, & + -0.27480E+00,-0.27621E+00,-0.27756E+00,-0.27885E+00,-0.28008E+00, & + -0.28126E+00,-0.28240E+00,-0.28349E+00,-0.28455E+00,-0.28556E+00, & + -0.28654E+00,-0.28749E+00,-0.28840E+00,-0.28929E+00,-0.29015E+00, & + -0.29098E+00,-0.29179E+00,-0.29258E+00,-0.29334E+00,-0.29409E+00, & + -0.29482E+00,-0.29552E+00,-0.29621E+00,-0.29689E+00,-0.29754E+00, & + -0.29819E+00,-0.29881E+00,-0.29943E+00,-0.30003E+00,-0.30061E+00, & + -0.30118E+00,-0.30174E+00,-0.30229E+00,-0.30283E+00,-0.30335E+00, & + -0.30386E+00,-0.30436E+00,-0.30484E+00,-0.30532E+00,-0.30578E+00, & + -0.30623E+00,-0.30667E+00,-0.30710E+00,-0.30751E+00,-0.30791E+00, & + -0.30830E+00,-0.30868E+00,-0.30905E+00,-0.30941E+00,-0.30975E+00, & + -0.31008E+00,-0.31040E+00,-0.31071E+00,-0.31100E+00,-0.31129E+00, & + -0.31156E+00,-0.31182E+00,-0.31207E+00,-0.31230E+00,-0.31253E+00, & + -0.31274E+00,-0.31295E+00,-0.31314E+00,-0.31332E+00,-0.31349E+00, & + -0.31365E+00,-0.31380E+00,-0.31394E+00,-0.31407E+00,-0.31420E+00/ + + DATA (BNC06M (I),I=101,200)/ & + -0.31431E+00,-0.31441E+00,-0.31451E+00,-0.31459E+00,-0.31467E+00, & + -0.31474E+00,-0.31480E+00,-0.31486E+00,-0.31491E+00,-0.31495E+00, & + -0.31499E+00,-0.31502E+00,-0.31504E+00,-0.31506E+00,-0.31508E+00, & + -0.31508E+00,-0.31509E+00,-0.31509E+00,-0.31508E+00,-0.31507E+00, & + -0.31518E+00,-0.31515E+00,-0.31512E+00,-0.31508E+00,-0.31505E+00, & + -0.31501E+00,-0.31497E+00,-0.31493E+00,-0.31488E+00,-0.31484E+00, & + -0.31479E+00,-0.31474E+00,-0.31470E+00,-0.31464E+00,-0.31459E+00, & + -0.31454E+00,-0.31449E+00,-0.31443E+00,-0.31437E+00,-0.31432E+00, & + -0.31426E+00,-0.31420E+00,-0.31414E+00,-0.31407E+00,-0.31401E+00, & + -0.31395E+00,-0.31389E+00,-0.31382E+00,-0.31375E+00,-0.31369E+00, & + -0.31362E+00,-0.31355E+00,-0.31349E+00,-0.31342E+00,-0.31335E+00, & + -0.31328E+00,-0.31321E+00,-0.31314E+00,-0.31307E+00,-0.31300E+00, & + -0.31293E+00,-0.31285E+00,-0.31278E+00,-0.31271E+00,-0.31264E+00, & + -0.31257E+00,-0.31249E+00,-0.31242E+00,-0.31235E+00,-0.31227E+00, & + -0.31220E+00,-0.31213E+00,-0.31205E+00,-0.31198E+00,-0.31190E+00, & + -0.31183E+00,-0.31176E+00,-0.31168E+00,-0.31161E+00,-0.31154E+00, & + -0.31146E+00,-0.31139E+00,-0.31132E+00,-0.31124E+00,-0.31117E+00, & + -0.31110E+00,-0.31102E+00,-0.31095E+00,-0.31088E+00,-0.31081E+00, & + -0.31073E+00,-0.31066E+00,-0.31059E+00,-0.31052E+00,-0.31045E+00, & + -0.31038E+00,-0.31031E+00,-0.31024E+00,-0.31017E+00,-0.31010E+00/ + + DATA (BNC06M (I),I=201,300)/ & + -0.31003E+00,-0.30996E+00,-0.30989E+00,-0.30982E+00,-0.30975E+00, & + -0.30969E+00,-0.30962E+00,-0.30955E+00,-0.30949E+00,-0.30942E+00, & + -0.30935E+00,-0.30929E+00,-0.30922E+00,-0.30916E+00,-0.30910E+00, & + -0.30903E+00,-0.30897E+00,-0.30891E+00,-0.30884E+00,-0.30878E+00, & + -0.30872E+00,-0.30866E+00,-0.30860E+00,-0.30854E+00,-0.30848E+00, & + -0.30842E+00,-0.30837E+00,-0.30831E+00,-0.30825E+00,-0.30819E+00, & + -0.30814E+00,-0.30808E+00,-0.30803E+00,-0.30797E+00,-0.30792E+00, & + -0.30787E+00,-0.30781E+00,-0.30776E+00,-0.30771E+00,-0.30766E+00, & + -0.30761E+00,-0.30756E+00,-0.30751E+00,-0.30746E+00,-0.30741E+00, & + -0.30737E+00,-0.30732E+00,-0.30727E+00,-0.30723E+00,-0.30718E+00, & + -0.30714E+00,-0.30709E+00,-0.30705E+00,-0.30701E+00,-0.30697E+00, & + -0.30692E+00,-0.30688E+00,-0.30684E+00,-0.30680E+00,-0.30676E+00, & + -0.30673E+00,-0.30669E+00,-0.30665E+00,-0.30662E+00,-0.30658E+00, & + -0.30654E+00,-0.30651E+00,-0.30648E+00,-0.30644E+00,-0.30641E+00, & + -0.30638E+00,-0.30635E+00,-0.30632E+00,-0.30629E+00,-0.30626E+00, & + -0.30623E+00,-0.30620E+00,-0.30617E+00,-0.30615E+00,-0.30612E+00, & + -0.30610E+00,-0.30607E+00,-0.30605E+00,-0.30602E+00,-0.30600E+00, & + -0.30598E+00,-0.30596E+00,-0.30594E+00,-0.30592E+00,-0.30590E+00, & + -0.30588E+00,-0.30586E+00,-0.30584E+00,-0.30583E+00,-0.30581E+00, & + -0.30580E+00,-0.30578E+00,-0.30577E+00,-0.30576E+00,-0.30574E+00/ + + DATA (BNC06M (I),I=301,400)/ & + -0.30573E+00,-0.30572E+00,-0.30571E+00,-0.30570E+00,-0.30569E+00, & + -0.30568E+00,-0.30567E+00,-0.30567E+00,-0.30566E+00,-0.30565E+00, & + -0.30565E+00,-0.30564E+00,-0.30564E+00,-0.30564E+00,-0.30564E+00, & + -0.30563E+00,-0.30563E+00,-0.30563E+00,-0.30563E+00,-0.30563E+00, & + -0.30563E+00,-0.30564E+00,-0.30564E+00,-0.30564E+00,-0.30565E+00, & + -0.30565E+00,-0.30566E+00,-0.30567E+00,-0.30567E+00,-0.30568E+00, & + -0.30569E+00,-0.30570E+00,-0.30571E+00,-0.30572E+00,-0.30573E+00, & + -0.30574E+00,-0.30575E+00,-0.30577E+00,-0.30578E+00,-0.30579E+00, & + -0.30581E+00,-0.30582E+00,-0.30584E+00,-0.30586E+00,-0.30588E+00, & + -0.30589E+00,-0.30591E+00,-0.30593E+00,-0.30595E+00,-0.30597E+00, & + -0.30600E+00,-0.30602E+00,-0.30604E+00,-0.30606E+00,-0.30609E+00, & + -0.30611E+00,-0.30614E+00,-0.30617E+00,-0.30619E+00,-0.30622E+00, & + -0.30625E+00,-0.30628E+00,-0.30631E+00,-0.30634E+00,-0.30637E+00, & + -0.30640E+00,-0.30643E+00,-0.30646E+00,-0.30650E+00,-0.30653E+00, & + -0.30657E+00,-0.30660E+00,-0.30664E+00,-0.30667E+00,-0.30671E+00, & + -0.30675E+00,-0.30679E+00,-0.30683E+00,-0.30687E+00,-0.30691E+00, & + -0.30695E+00,-0.30699E+00,-0.30703E+00,-0.30708E+00,-0.30712E+00, & + -0.30716E+00,-0.30721E+00,-0.30726E+00,-0.30730E+00,-0.30735E+00, & + -0.30740E+00,-0.30744E+00,-0.30749E+00,-0.30754E+00,-0.30759E+00, & + -0.30764E+00,-0.30769E+00,-0.30775E+00,-0.30780E+00,-0.30785E+00/ + + DATA (BNC06M (I),I=401,500)/ & + -0.30791E+00,-0.30796E+00,-0.30802E+00,-0.30807E+00,-0.30813E+00, & + -0.30818E+00,-0.30824E+00,-0.30830E+00,-0.30836E+00,-0.30842E+00, & + -0.30848E+00,-0.30854E+00,-0.30860E+00,-0.30866E+00,-0.30872E+00, & + -0.30879E+00,-0.30885E+00,-0.30891E+00,-0.30898E+00,-0.30904E+00, & + -0.30911E+00,-0.30918E+00,-0.30924E+00,-0.30931E+00,-0.30938E+00, & + -0.30945E+00,-0.30952E+00,-0.30959E+00,-0.30966E+00,-0.30973E+00, & + -0.30980E+00,-0.30987E+00,-0.30995E+00,-0.31002E+00,-0.31010E+00, & + -0.31017E+00,-0.31025E+00,-0.31032E+00,-0.31040E+00,-0.31048E+00, & + -0.31055E+00,-0.31063E+00,-0.31071E+00,-0.31079E+00,-0.31087E+00, & + -0.31095E+00,-0.31103E+00,-0.31111E+00,-0.31120E+00,-0.31128E+00, & + -0.31136E+00,-0.31145E+00,-0.31153E+00,-0.31162E+00,-0.31170E+00, & + -0.31179E+00,-0.31188E+00,-0.31196E+00,-0.31205E+00,-0.31214E+00, & + -0.31223E+00,-0.31232E+00,-0.31241E+00,-0.31250E+00,-0.31259E+00, & + -0.31268E+00,-0.31278E+00,-0.31287E+00,-0.31296E+00,-0.31306E+00, & + -0.31315E+00,-0.31325E+00,-0.31334E+00,-0.31344E+00,-0.31354E+00, & + -0.31363E+00,-0.31373E+00,-0.31383E+00,-0.31393E+00,-0.31403E+00, & + -0.31413E+00,-0.31423E+00,-0.31433E+00,-0.31443E+00,-0.31454E+00, & + -0.31464E+00,-0.31474E+00,-0.31485E+00,-0.31495E+00,-0.31506E+00, & + -0.31516E+00,-0.31527E+00,-0.31537E+00,-0.31548E+00,-0.31559E+00, & + -0.31570E+00,-0.31581E+00,-0.31591E+00,-0.31602E+00,-0.31613E+00/ + + DATA (BNC06M (I),I=501,600)/ & + -0.31625E+00,-0.31636E+00,-0.31647E+00,-0.31658E+00,-0.31669E+00, & + -0.31681E+00,-0.31692E+00,-0.31704E+00,-0.31715E+00,-0.31727E+00, & + -0.31738E+00,-0.31750E+00,-0.31761E+00,-0.31773E+00,-0.31785E+00, & + -0.31797E+00,-0.31809E+00,-0.31821E+00,-0.31833E+00,-0.31845E+00, & + -0.31857E+00,-0.31869E+00,-0.31881E+00,-0.31893E+00,-0.31906E+00, & + -0.31918E+00,-0.31931E+00,-0.31943E+00,-0.31955E+00,-0.31968E+00, & + -0.31981E+00,-0.31993E+00,-0.32006E+00,-0.32019E+00,-0.32032E+00, & + -0.32044E+00,-0.32057E+00,-0.32070E+00,-0.32083E+00,-0.32096E+00, & + -0.32109E+00,-0.32122E+00,-0.32136E+00,-0.32149E+00,-0.32162E+00, & + -0.32175E+00,-0.32189E+00,-0.32202E+00,-0.32216E+00,-0.32229E+00, & + -0.32243E+00,-0.32256E+00,-0.32270E+00,-0.32284E+00,-0.32298E+00, & + -0.32311E+00,-0.32325E+00,-0.32339E+00,-0.32353E+00,-0.32367E+00, & + -0.32381E+00,-0.32395E+00,-0.32409E+00,-0.32423E+00,-0.32438E+00, & + -0.32452E+00,-0.32466E+00,-0.32481E+00,-0.32495E+00,-0.32509E+00, & + -0.32524E+00,-0.32538E+00,-0.32553E+00,-0.32568E+00,-0.32582E+00, & + -0.32597E+00,-0.32612E+00,-0.32627E+00,-0.32642E+00,-0.32656E+00, & + -0.32671E+00,-0.32686E+00,-0.32701E+00,-0.32716E+00,-0.32732E+00, & + -0.32747E+00,-0.32762E+00,-0.32777E+00,-0.32793E+00,-0.32808E+00, & + -0.32823E+00,-0.32839E+00,-0.32854E+00,-0.32870E+00,-0.32885E+00, & + -0.32901E+00,-0.32917E+00,-0.32932E+00,-0.32948E+00,-0.33007E+00/ + + DATA (BNC06M (I),I=601,700)/ & + -0.33140E+00,-0.33305E+00,-0.33474E+00,-0.33647E+00,-0.33824E+00, & + -0.34005E+00,-0.34190E+00,-0.34379E+00,-0.34571E+00,-0.34767E+00, & + -0.34966E+00,-0.35169E+00,-0.35376E+00,-0.35586E+00,-0.35799E+00, & + -0.36016E+00,-0.36235E+00,-0.36458E+00,-0.36684E+00,-0.36913E+00, & + -0.37146E+00,-0.37381E+00,-0.37619E+00,-0.37859E+00,-0.38103E+00, & + -0.38349E+00,-0.38598E+00,-0.38850E+00,-0.39105E+00,-0.39361E+00, & + -0.39621E+00,-0.39883E+00,-0.40147E+00,-0.40414E+00,-0.40684E+00, & + -0.40955E+00,-0.41229E+00,-0.41506E+00,-0.41784E+00,-0.42065E+00, & + -0.42348E+00,-0.42633E+00,-0.42920E+00,-0.43209E+00,-0.43500E+00, & + -0.43793E+00,-0.44089E+00,-0.44386E+00,-0.44685E+00,-0.44986E+00, & + -0.45289E+00,-0.45594E+00,-0.45901E+00,-0.46209E+00,-0.46519E+00, & + -0.46831E+00,-0.47145E+00,-0.47460E+00,-0.47777E+00,-0.48096E+00, & + -0.48416E+00,-0.48738E+00,-0.49062E+00,-0.49387E+00,-0.49713E+00, & + -0.50042E+00,-0.50371E+00,-0.50702E+00,-0.51035E+00,-0.51369E+00, & + -0.51705E+00,-0.52042E+00,-0.52380E+00,-0.52720E+00,-0.53061E+00, & + -0.53403E+00,-0.53747E+00,-0.54092E+00,-0.54438E+00,-0.54786E+00, & + -0.55135E+00,-0.55485E+00,-0.55836E+00,-0.56189E+00,-0.56543E+00, & + -0.56898E+00,-0.57254E+00,-0.57611E+00,-0.57970E+00,-0.58329E+00, & + -0.58690E+00,-0.59052E+00,-0.59415E+00,-0.59779E+00,-0.60144E+00, & + -0.60510E+00,-0.60877E+00,-0.61245E+00,-0.61614E+00,-0.61985E+00/ + + DATA (BNC06M(I),I=701,741)/ & + -0.62356E+00,-0.62728E+00,-0.63101E+00,-0.63475E+00,-0.63851E+00, & + -0.64227E+00,-0.64604E+00,-0.64982E+00,-0.65360E+00,-0.65740E+00, & + -0.66121E+00,-0.66502E+00,-0.66885E+00,-0.67268E+00,-0.67652E+00, & + -0.68037E+00,-0.68423E+00,-0.68809E+00,-0.69197E+00,-0.69585E+00, & + -0.69974E+00,-0.70364E+00,-0.70755E+00,-0.71146E+00,-0.71539E+00, & + -0.71932E+00,-0.72325E+00,-0.72720E+00,-0.73115E+00,-0.73511E+00, & + -0.73908E+00,-0.74305E+00,-0.74703E+00,-0.75102E+00,-0.75502E+00, & + -0.75902E+00,-0.76303E+00,-0.76705E+00,-0.77107E+00,-0.77510E+00, & + -0.77914E+00 & + / +! +! *** (2H, SO4) +! + DATA (BNC07M (I),I= 1,100)/ & + -0.11374E+00,-0.20831E+00,-0.27574E+00,-0.32220E+00,-0.35838E+00, & + -0.38830E+00,-0.41395E+00,-0.43649E+00,-0.45665E+00,-0.47492E+00, & + -0.49165E+00,-0.50711E+00,-0.52150E+00,-0.53497E+00,-0.54765E+00, & + -0.55962E+00,-0.57099E+00,-0.58180E+00,-0.59213E+00,-0.60201E+00, & + -0.61150E+00,-0.62062E+00,-0.62941E+00,-0.63790E+00,-0.64610E+00, & + -0.65405E+00,-0.66175E+00,-0.66923E+00,-0.67651E+00,-0.68359E+00, & + -0.69048E+00,-0.69721E+00,-0.70377E+00,-0.71018E+00,-0.71645E+00, & + -0.72258E+00,-0.72859E+00,-0.73447E+00,-0.74024E+00,-0.74589E+00, & + -0.75145E+00,-0.75690E+00,-0.76225E+00,-0.76752E+00,-0.77270E+00, & + -0.77779E+00,-0.78281E+00,-0.78774E+00,-0.79261E+00,-0.79740E+00, & + -0.80212E+00,-0.80678E+00,-0.81138E+00,-0.81592E+00,-0.82039E+00, & + -0.82481E+00,-0.82918E+00,-0.83349E+00,-0.83776E+00,-0.84197E+00, & + -0.84614E+00,-0.85026E+00,-0.85434E+00,-0.85837E+00,-0.86237E+00, & + -0.86632E+00,-0.87023E+00,-0.87411E+00,-0.87795E+00,-0.88176E+00, & + -0.88553E+00,-0.88927E+00,-0.89297E+00,-0.89665E+00,-0.90029E+00, & + -0.90391E+00,-0.90750E+00,-0.91106E+00,-0.91459E+00,-0.91810E+00, & + -0.92158E+00,-0.92503E+00,-0.92847E+00,-0.93188E+00,-0.93527E+00, & + -0.93863E+00,-0.94197E+00,-0.94530E+00,-0.94860E+00,-0.95188E+00, & + -0.95514E+00,-0.95839E+00,-0.96161E+00,-0.96482E+00,-0.96801E+00, & + -0.97118E+00,-0.97433E+00,-0.97747E+00,-0.98059E+00,-0.98370E+00/ + + DATA (BNC07M (I),I=101,200)/ & + -0.98679E+00,-0.98986E+00,-0.99292E+00,-0.99596E+00,-0.99899E+00, & + -0.10020E+01,-0.10050E+01,-0.10080E+01,-0.10110E+01,-0.10139E+01, & + -0.10169E+01,-0.10198E+01,-0.10227E+01,-0.10256E+01,-0.10285E+01, & + -0.10314E+01,-0.10343E+01,-0.10371E+01,-0.10400E+01,-0.10428E+01, & + -0.10456E+01,-0.10484E+01,-0.10512E+01,-0.10540E+01,-0.10568E+01, & + -0.10596E+01,-0.10623E+01,-0.10651E+01,-0.10678E+01,-0.10706E+01, & + -0.10733E+01,-0.10760E+01,-0.10787E+01,-0.10814E+01,-0.10840E+01, & + -0.10867E+01,-0.10894E+01,-0.10920E+01,-0.10947E+01,-0.10973E+01, & + -0.10999E+01,-0.11025E+01,-0.11051E+01,-0.11077E+01,-0.11103E+01, & + -0.11129E+01,-0.11155E+01,-0.11180E+01,-0.11206E+01,-0.11232E+01, & + -0.11257E+01,-0.11282E+01,-0.11308E+01,-0.11333E+01,-0.11358E+01, & + -0.11383E+01,-0.11408E+01,-0.11433E+01,-0.11458E+01,-0.11482E+01, & + -0.11507E+01,-0.11532E+01,-0.11556E+01,-0.11581E+01,-0.11605E+01, & + -0.11629E+01,-0.11654E+01,-0.11678E+01,-0.11702E+01,-0.11726E+01, & + -0.11750E+01,-0.11774E+01,-0.11798E+01,-0.11822E+01,-0.11846E+01, & + -0.11870E+01,-0.11893E+01,-0.11917E+01,-0.11941E+01,-0.11964E+01, & + -0.11988E+01,-0.12011E+01,-0.12034E+01,-0.12058E+01,-0.12081E+01, & + -0.12104E+01,-0.12127E+01,-0.12150E+01,-0.12173E+01,-0.12196E+01, & + -0.12219E+01,-0.12242E+01,-0.12265E+01,-0.12288E+01,-0.12311E+01, & + -0.12333E+01,-0.12356E+01,-0.12379E+01,-0.12401E+01,-0.12424E+01/ + + DATA (BNC07M (I),I=201,300)/ & + -0.12446E+01,-0.12469E+01,-0.12491E+01,-0.12514E+01,-0.12536E+01, & + -0.12558E+01,-0.12580E+01,-0.12603E+01,-0.12625E+01,-0.12647E+01, & + -0.12669E+01,-0.12691E+01,-0.12713E+01,-0.12735E+01,-0.12757E+01, & + -0.12779E+01,-0.12800E+01,-0.12822E+01,-0.12844E+01,-0.12866E+01, & + -0.12887E+01,-0.12909E+01,-0.12930E+01,-0.12952E+01,-0.12974E+01, & + -0.12995E+01,-0.13017E+01,-0.13038E+01,-0.13059E+01,-0.13081E+01, & + -0.13102E+01,-0.13123E+01,-0.13144E+01,-0.13166E+01,-0.13187E+01, & + -0.13208E+01,-0.13229E+01,-0.13250E+01,-0.13271E+01,-0.13292E+01, & + -0.13313E+01,-0.13334E+01,-0.13355E+01,-0.13376E+01,-0.13397E+01, & + -0.13418E+01,-0.13438E+01,-0.13459E+01,-0.13480E+01,-0.13501E+01, & + -0.13521E+01,-0.13542E+01,-0.13563E+01,-0.13583E+01,-0.13604E+01, & + -0.13624E+01,-0.13645E+01,-0.13665E+01,-0.13686E+01,-0.13706E+01, & + -0.13727E+01,-0.13747E+01,-0.13767E+01,-0.13788E+01,-0.13808E+01, & + -0.13828E+01,-0.13848E+01,-0.13869E+01,-0.13889E+01,-0.13909E+01, & + -0.13929E+01,-0.13949E+01,-0.13969E+01,-0.13989E+01,-0.14009E+01, & + -0.14029E+01,-0.14049E+01,-0.14069E+01,-0.14089E+01,-0.14109E+01, & + -0.14129E+01,-0.14149E+01,-0.14169E+01,-0.14188E+01,-0.14208E+01, & + -0.14228E+01,-0.14248E+01,-0.14267E+01,-0.14287E+01,-0.14307E+01, & + -0.14326E+01,-0.14346E+01,-0.14366E+01,-0.14385E+01,-0.14405E+01, & + -0.14424E+01,-0.14444E+01,-0.14463E+01,-0.14483E+01,-0.14502E+01/ + + DATA (BNC07M (I),I=301,400)/ & + -0.14522E+01,-0.14541E+01,-0.14561E+01,-0.14580E+01,-0.14599E+01, & + -0.14619E+01,-0.14638E+01,-0.14657E+01,-0.14676E+01,-0.14696E+01, & + -0.14715E+01,-0.14734E+01,-0.14753E+01,-0.14772E+01,-0.14792E+01, & + -0.14811E+01,-0.14830E+01,-0.14849E+01,-0.14868E+01,-0.14887E+01, & + -0.14906E+01,-0.14925E+01,-0.14944E+01,-0.14963E+01,-0.14982E+01, & + -0.15001E+01,-0.15020E+01,-0.15039E+01,-0.15058E+01,-0.15077E+01, & + -0.15095E+01,-0.15114E+01,-0.15133E+01,-0.15152E+01,-0.15171E+01, & + -0.15189E+01,-0.15208E+01,-0.15227E+01,-0.15246E+01,-0.15264E+01, & + -0.15283E+01,-0.15302E+01,-0.15320E+01,-0.15339E+01,-0.15358E+01, & + -0.15376E+01,-0.15395E+01,-0.15413E+01,-0.15432E+01,-0.15450E+01, & + -0.15469E+01,-0.15487E+01,-0.15506E+01,-0.15524E+01,-0.15543E+01, & + -0.15561E+01,-0.15580E+01,-0.15598E+01,-0.15617E+01,-0.15635E+01, & + -0.15653E+01,-0.15672E+01,-0.15690E+01,-0.15708E+01,-0.15727E+01, & + -0.15745E+01,-0.15763E+01,-0.15781E+01,-0.15800E+01,-0.15818E+01, & + -0.15836E+01,-0.15854E+01,-0.15873E+01,-0.15891E+01,-0.15909E+01, & + -0.15927E+01,-0.15945E+01,-0.15963E+01,-0.15981E+01,-0.15999E+01, & + -0.16018E+01,-0.16036E+01,-0.16054E+01,-0.16072E+01,-0.16090E+01, & + -0.16108E+01,-0.16126E+01,-0.16144E+01,-0.16162E+01,-0.16180E+01, & + -0.16198E+01,-0.16216E+01,-0.16233E+01,-0.16251E+01,-0.16269E+01, & + -0.16287E+01,-0.16305E+01,-0.16323E+01,-0.16341E+01,-0.16358E+01/ + + DATA (BNC07M (I),I=401,500)/ & + -0.16376E+01,-0.16394E+01,-0.16412E+01,-0.16430E+01,-0.16447E+01, & + -0.16465E+01,-0.16483E+01,-0.16501E+01,-0.16518E+01,-0.16536E+01, & + -0.16554E+01,-0.16571E+01,-0.16589E+01,-0.16607E+01,-0.16624E+01, & + -0.16642E+01,-0.16660E+01,-0.16677E+01,-0.16695E+01,-0.16712E+01, & + -0.16730E+01,-0.16748E+01,-0.16765E+01,-0.16783E+01,-0.16800E+01, & + -0.16818E+01,-0.16835E+01,-0.16853E+01,-0.16870E+01,-0.16888E+01, & + -0.16905E+01,-0.16923E+01,-0.16940E+01,-0.16958E+01,-0.16975E+01, & + -0.16992E+01,-0.17010E+01,-0.17027E+01,-0.17045E+01,-0.17062E+01, & + -0.17079E+01,-0.17097E+01,-0.17114E+01,-0.17131E+01,-0.17149E+01, & + -0.17166E+01,-0.17183E+01,-0.17200E+01,-0.17218E+01,-0.17235E+01, & + -0.17252E+01,-0.17270E+01,-0.17287E+01,-0.17304E+01,-0.17321E+01, & + -0.17338E+01,-0.17356E+01,-0.17373E+01,-0.17390E+01,-0.17407E+01, & + -0.17424E+01,-0.17441E+01,-0.17459E+01,-0.17476E+01,-0.17493E+01, & + -0.17510E+01,-0.17527E+01,-0.17544E+01,-0.17561E+01,-0.17578E+01, & + -0.17595E+01,-0.17612E+01,-0.17629E+01,-0.17646E+01,-0.17663E+01, & + -0.17680E+01,-0.17697E+01,-0.17714E+01,-0.17731E+01,-0.17748E+01, & + -0.17765E+01,-0.17782E+01,-0.17799E+01,-0.17816E+01,-0.17833E+01, & + -0.17850E+01,-0.17867E+01,-0.17884E+01,-0.17901E+01,-0.17918E+01, & + -0.17935E+01,-0.17951E+01,-0.17968E+01,-0.17985E+01,-0.18002E+01, & + -0.18019E+01,-0.18036E+01,-0.18052E+01,-0.18069E+01,-0.18086E+01/ + + DATA (BNC07M (I),I=501,600)/ & + -0.18103E+01,-0.18120E+01,-0.18136E+01,-0.18153E+01,-0.18170E+01, & + -0.18187E+01,-0.18203E+01,-0.18220E+01,-0.18237E+01,-0.18254E+01, & + -0.18270E+01,-0.18287E+01,-0.18304E+01,-0.18320E+01,-0.18337E+01, & + -0.18354E+01,-0.18370E+01,-0.18387E+01,-0.18404E+01,-0.18420E+01, & + -0.18437E+01,-0.18454E+01,-0.18470E+01,-0.18487E+01,-0.18503E+01, & + -0.18520E+01,-0.18537E+01,-0.18553E+01,-0.18570E+01,-0.18586E+01, & + -0.18603E+01,-0.18619E+01,-0.18636E+01,-0.18653E+01,-0.18669E+01, & + -0.18686E+01,-0.18702E+01,-0.18719E+01,-0.18735E+01,-0.18752E+01, & + -0.18768E+01,-0.18785E+01,-0.18801E+01,-0.18817E+01,-0.18834E+01, & + -0.18850E+01,-0.18867E+01,-0.18883E+01,-0.18900E+01,-0.18916E+01, & + -0.18932E+01,-0.18949E+01,-0.18965E+01,-0.18982E+01,-0.18998E+01, & + -0.19014E+01,-0.19031E+01,-0.19047E+01,-0.19063E+01,-0.19080E+01, & + -0.19096E+01,-0.19112E+01,-0.19129E+01,-0.19145E+01,-0.19161E+01, & + -0.19178E+01,-0.19194E+01,-0.19210E+01,-0.19227E+01,-0.19243E+01, & + -0.19259E+01,-0.19275E+01,-0.19292E+01,-0.19308E+01,-0.19324E+01, & + -0.19340E+01,-0.19357E+01,-0.19373E+01,-0.19389E+01,-0.19405E+01, & + -0.19421E+01,-0.19438E+01,-0.19454E+01,-0.19470E+01,-0.19486E+01, & + -0.19502E+01,-0.19519E+01,-0.19535E+01,-0.19551E+01,-0.19567E+01, & + -0.19583E+01,-0.19599E+01,-0.19615E+01,-0.19632E+01,-0.19648E+01, & + -0.19664E+01,-0.19680E+01,-0.19696E+01,-0.19712E+01,-0.19772E+01/ + + DATA (BNC07M (I),I=601,700)/ & + -0.19905E+01,-0.20065E+01,-0.20224E+01,-0.20383E+01,-0.20541E+01, & + -0.20698E+01,-0.20856E+01,-0.21012E+01,-0.21168E+01,-0.21324E+01, & + -0.21479E+01,-0.21634E+01,-0.21788E+01,-0.21942E+01,-0.22096E+01, & + -0.22249E+01,-0.22401E+01,-0.22554E+01,-0.22705E+01,-0.22857E+01, & + -0.23008E+01,-0.23159E+01,-0.23309E+01,-0.23459E+01,-0.23609E+01, & + -0.23758E+01,-0.23907E+01,-0.24056E+01,-0.24204E+01,-0.24352E+01, & + -0.24500E+01,-0.24647E+01,-0.24795E+01,-0.24941E+01,-0.25088E+01, & + -0.25234E+01,-0.25380E+01,-0.25526E+01,-0.25672E+01,-0.25817E+01, & + -0.25962E+01,-0.26107E+01,-0.26251E+01,-0.26395E+01,-0.26539E+01, & + -0.26683E+01,-0.26827E+01,-0.26970E+01,-0.27113E+01,-0.27256E+01, & + -0.27399E+01,-0.27541E+01,-0.27683E+01,-0.27825E+01,-0.27967E+01, & + -0.28109E+01,-0.28250E+01,-0.28391E+01,-0.28532E+01,-0.28673E+01, & + -0.28814E+01,-0.28954E+01,-0.29094E+01,-0.29235E+01,-0.29374E+01, & + -0.29514E+01,-0.29654E+01,-0.29793E+01,-0.29932E+01,-0.30071E+01, & + -0.30210E+01,-0.30349E+01,-0.30487E+01,-0.30626E+01,-0.30764E+01, & + -0.30902E+01,-0.31040E+01,-0.31178E+01,-0.31315E+01,-0.31453E+01, & + -0.31590E+01,-0.31727E+01,-0.31864E+01,-0.32001E+01,-0.32138E+01, & + -0.32274E+01,-0.32411E+01,-0.32547E+01,-0.32683E+01,-0.32819E+01, & + -0.32955E+01,-0.33091E+01,-0.33226E+01,-0.33362E+01,-0.33497E+01, & + -0.33632E+01,-0.33767E+01,-0.33902E+01,-0.34037E+01,-0.34172E+01/ + + DATA (BNC07M(I),I=701,741)/ & + -0.34307E+01,-0.34441E+01,-0.34576E+01,-0.34710E+01,-0.34844E+01, & + -0.34978E+01,-0.35112E+01,-0.35246E+01,-0.35380E+01,-0.35513E+01, & + -0.35647E+01,-0.35780E+01,-0.35913E+01,-0.36046E+01,-0.36179E+01, & + -0.36312E+01,-0.36445E+01,-0.36578E+01,-0.36711E+01,-0.36843E+01, & + -0.36976E+01,-0.37108E+01,-0.37240E+01,-0.37372E+01,-0.37504E+01, & + -0.37636E+01,-0.37768E+01,-0.37900E+01,-0.38032E+01,-0.38163E+01, & + -0.38295E+01,-0.38426E+01,-0.38557E+01,-0.38689E+01,-0.38820E+01, & + -0.38951E+01,-0.39082E+01,-0.39213E+01,-0.39343E+01,-0.39474E+01, & + -0.39605E+01 & + / +! +! *** (H, HSO4) +! + DATA (BNC08M (I),I= 1,100)/ & + -0.51998E-01,-0.87278E-01,-0.10725E+00,-0.11796E+00,-0.12426E+00, & + -0.12788E+00,-0.12969E+00,-0.13016E+00,-0.12958E+00,-0.12816E+00, & + -0.12603E+00,-0.12329E+00,-0.12003E+00,-0.11630E+00,-0.11215E+00, & + -0.10761E+00,-0.10272E+00,-0.97512E-01,-0.91996E-01,-0.86196E-01, & + -0.80129E-01,-0.73810E-01,-0.67251E-01,-0.60465E-01,-0.53463E-01, & + -0.46254E-01,-0.38847E-01,-0.31251E-01,-0.23474E-01,-0.15524E-01, & + -0.74071E-02, 0.86952E-03, 0.92994E-02, 0.17876E-01, 0.26595E-01, & + 0.35448E-01, 0.44432E-01, 0.53541E-01, 0.62769E-01, 0.72112E-01, & + 0.81565E-01, 0.91123E-01, 0.10078E+00, 0.11054E+00, 0.12039E+00, & + 0.13032E+00, 0.14035E+00, 0.15045E+00, 0.16063E+00, 0.17089E+00, & + 0.18122E+00, 0.19162E+00, 0.20209E+00, 0.21262E+00, 0.22321E+00, & + 0.23386E+00, 0.24457E+00, 0.25534E+00, 0.26617E+00, 0.27704E+00, & + 0.28797E+00, 0.29896E+00, 0.30999E+00, 0.32108E+00, 0.33221E+00, & + 0.34340E+00, 0.35464E+00, 0.36593E+00, 0.37727E+00, 0.38867E+00, & + 0.40012E+00, 0.41162E+00, 0.42317E+00, 0.43478E+00, 0.44645E+00, & + 0.45817E+00, 0.46995E+00, 0.48179E+00, 0.49369E+00, 0.50566E+00, & + 0.51768E+00, 0.52976E+00, 0.54191E+00, 0.55412E+00, 0.56639E+00, & + 0.57873E+00, 0.59114E+00, 0.60360E+00, 0.61613E+00, 0.62873E+00, & + 0.64138E+00, 0.65410E+00, 0.66688E+00, 0.67973E+00, 0.69263E+00, & + 0.70559E+00, 0.71860E+00, 0.73167E+00, 0.74480E+00, 0.75797E+00/ + + DATA (BNC08M (I),I=101,200)/ & + 0.77120E+00, 0.78447E+00, 0.79778E+00, 0.81114E+00, 0.82454E+00, & + 0.83797E+00, 0.85144E+00, 0.86495E+00, 0.87848E+00, 0.89204E+00, & + 0.90562E+00, 0.91923E+00, 0.93286E+00, 0.94651E+00, 0.96017E+00, & + 0.97384E+00, 0.98753E+00, 0.10012E+01, 0.10149E+01, 0.10286E+01, & + 0.10411E+01, 0.10550E+01, 0.10688E+01, 0.10826E+01, 0.10964E+01, & + 0.11102E+01, 0.11240E+01, 0.11377E+01, 0.11514E+01, 0.11651E+01, & + 0.11788E+01, 0.11925E+01, 0.12061E+01, 0.12198E+01, 0.12334E+01, & + 0.12470E+01, 0.12605E+01, 0.12741E+01, 0.12876E+01, 0.13011E+01, & + 0.13145E+01, 0.13280E+01, 0.13414E+01, 0.13548E+01, 0.13682E+01, & + 0.13815E+01, 0.13949E+01, 0.14082E+01, 0.14214E+01, 0.14347E+01, & + 0.14479E+01, 0.14611E+01, 0.14743E+01, 0.14875E+01, 0.15006E+01, & + 0.15137E+01, 0.15267E+01, 0.15398E+01, 0.15528E+01, 0.15658E+01, & + 0.15788E+01, 0.15917E+01, 0.16046E+01, 0.16175E+01, 0.16304E+01, & + 0.16432E+01, 0.16560E+01, 0.16688E+01, 0.16815E+01, 0.16942E+01, & + 0.17069E+01, 0.17196E+01, 0.17322E+01, 0.17448E+01, 0.17574E+01, & + 0.17700E+01, 0.17825E+01, 0.17950E+01, 0.18075E+01, 0.18199E+01, & + 0.18324E+01, 0.18447E+01, 0.18571E+01, 0.18694E+01, 0.18818E+01, & + 0.18940E+01, 0.19063E+01, 0.19185E+01, 0.19307E+01, 0.19429E+01, & + 0.19550E+01, 0.19671E+01, 0.19792E+01, 0.19913E+01, 0.20033E+01, & + 0.20153E+01, 0.20273E+01, 0.20393E+01, 0.20512E+01, 0.20631E+01/ + + DATA (BNC08M (I),I=201,300)/ & + 0.20750E+01, 0.20868E+01, 0.20986E+01, 0.21104E+01, 0.21222E+01, & + 0.21339E+01, 0.21456E+01, 0.21573E+01, 0.21690E+01, 0.21806E+01, & + 0.21922E+01, 0.22038E+01, 0.22153E+01, 0.22269E+01, 0.22384E+01, & + 0.22498E+01, 0.22613E+01, 0.22727E+01, 0.22841E+01, 0.22955E+01, & + 0.23068E+01, 0.23181E+01, 0.23294E+01, 0.23407E+01, 0.23520E+01, & + 0.23632E+01, 0.23744E+01, 0.23855E+01, 0.23967E+01, 0.24078E+01, & + 0.24189E+01, 0.24299E+01, 0.24410E+01, 0.24520E+01, 0.24630E+01, & + 0.24740E+01, 0.24849E+01, 0.24958E+01, 0.25067E+01, 0.25176E+01, & + 0.25284E+01, 0.25393E+01, 0.25501E+01, 0.25608E+01, 0.25716E+01, & + 0.25823E+01, 0.25930E+01, 0.26037E+01, 0.26143E+01, 0.26250E+01, & + 0.26356E+01, 0.26462E+01, 0.26567E+01, 0.26673E+01, 0.26778E+01, & + 0.26883E+01, 0.26988E+01, 0.27092E+01, 0.27196E+01, 0.27300E+01, & + 0.27404E+01, 0.27508E+01, 0.27611E+01, 0.27714E+01, 0.27817E+01, & + 0.27920E+01, 0.28022E+01, 0.28124E+01, 0.28226E+01, 0.28328E+01, & + 0.28430E+01, 0.28531E+01, 0.28632E+01, 0.28733E+01, 0.28834E+01, & + 0.28934E+01, 0.29034E+01, 0.29134E+01, 0.29234E+01, 0.29334E+01, & + 0.29433E+01, 0.29533E+01, 0.29632E+01, 0.29730E+01, 0.29829E+01, & + 0.29927E+01, 0.30026E+01, 0.30123E+01, 0.30221E+01, 0.30319E+01, & + 0.30416E+01, 0.30513E+01, 0.30610E+01, 0.30707E+01, 0.30804E+01, & + 0.30900E+01, 0.30996E+01, 0.31092E+01, 0.31188E+01, 0.31283E+01/ + + DATA (BNC08M (I),I=301,400)/ & + 0.31379E+01, 0.31474E+01, 0.31569E+01, 0.31663E+01, 0.31758E+01, & + 0.31852E+01, 0.31947E+01, 0.32041E+01, 0.32134E+01, 0.32228E+01, & + 0.32321E+01, 0.32415E+01, 0.32508E+01, 0.32601E+01, 0.32693E+01, & + 0.32786E+01, 0.32878E+01, 0.32970E+01, 0.33062E+01, 0.33154E+01, & + 0.33245E+01, 0.33337E+01, 0.33428E+01, 0.33519E+01, 0.33610E+01, & + 0.33701E+01, 0.33791E+01, 0.33881E+01, 0.33971E+01, 0.34061E+01, & + 0.34151E+01, 0.34241E+01, 0.34330E+01, 0.34419E+01, 0.34508E+01, & + 0.34597E+01, 0.34686E+01, 0.34775E+01, 0.34863E+01, 0.34951E+01, & + 0.35039E+01, 0.35127E+01, 0.35215E+01, 0.35302E+01, 0.35390E+01, & + 0.35477E+01, 0.35564E+01, 0.35651E+01, 0.35737E+01, 0.35824E+01, & + 0.35910E+01, 0.35996E+01, 0.36083E+01, 0.36168E+01, 0.36254E+01, & + 0.36340E+01, 0.36425E+01, 0.36510E+01, 0.36595E+01, 0.36680E+01, & + 0.36765E+01, 0.36850E+01, 0.36934E+01, 0.37018E+01, 0.37102E+01, & + 0.37186E+01, 0.37270E+01, 0.37354E+01, 0.37437E+01, 0.37521E+01, & + 0.37604E+01, 0.37687E+01, 0.37770E+01, 0.37852E+01, 0.37935E+01, & + 0.38017E+01, 0.38100E+01, 0.38182E+01, 0.38264E+01, 0.38345E+01, & + 0.38427E+01, 0.38509E+01, 0.38590E+01, 0.38671E+01, 0.38752E+01, & + 0.38833E+01, 0.38914E+01, 0.38995E+01, 0.39075E+01, 0.39155E+01, & + 0.39236E+01, 0.39316E+01, 0.39396E+01, 0.39475E+01, 0.39555E+01, & + 0.39634E+01, 0.39714E+01, 0.39793E+01, 0.39872E+01, 0.39951E+01/ + + DATA (BNC08M (I),I=401,500)/ & + 0.40030E+01, 0.40108E+01, 0.40187E+01, 0.40265E+01, 0.40343E+01, & + 0.40421E+01, 0.40499E+01, 0.40577E+01, 0.40655E+01, 0.40732E+01, & + 0.40810E+01, 0.40887E+01, 0.40964E+01, 0.41041E+01, 0.41118E+01, & + 0.41195E+01, 0.41272E+01, 0.41348E+01, 0.41424E+01, 0.41501E+01, & + 0.41577E+01, 0.41653E+01, 0.41728E+01, 0.41804E+01, 0.41880E+01, & + 0.41955E+01, 0.42030E+01, 0.42105E+01, 0.42181E+01, 0.42255E+01, & + 0.42330E+01, 0.42405E+01, 0.42479E+01, 0.42554E+01, 0.42628E+01, & + 0.42702E+01, 0.42776E+01, 0.42850E+01, 0.42924E+01, 0.42998E+01, & + 0.43071E+01, 0.43145E+01, 0.43218E+01, 0.43291E+01, 0.43364E+01, & + 0.43437E+01, 0.43510E+01, 0.43583E+01, 0.43655E+01, 0.43728E+01, & + 0.43800E+01, 0.43872E+01, 0.43944E+01, 0.44016E+01, 0.44088E+01, & + 0.44160E+01, 0.44231E+01, 0.44303E+01, 0.44374E+01, 0.44446E+01, & + 0.44517E+01, 0.44588E+01, 0.44659E+01, 0.44729E+01, 0.44800E+01, & + 0.44871E+01, 0.44941E+01, 0.45012E+01, 0.45082E+01, 0.45152E+01, & + 0.45222E+01, 0.45292E+01, 0.45362E+01, 0.45431E+01, 0.45501E+01, & + 0.45570E+01, 0.45640E+01, 0.45709E+01, 0.45778E+01, 0.45847E+01, & + 0.45916E+01, 0.45985E+01, 0.46053E+01, 0.46122E+01, 0.46190E+01, & + 0.46259E+01, 0.46327E+01, 0.46395E+01, 0.46463E+01, 0.46531E+01, & + 0.46599E+01, 0.46667E+01, 0.46734E+01, 0.46802E+01, 0.46869E+01, & + 0.46936E+01, 0.47004E+01, 0.47071E+01, 0.47138E+01, 0.47205E+01/ + + DATA (BNC08M (I),I=501,600)/ & + 0.47271E+01, 0.47338E+01, 0.47405E+01, 0.47471E+01, 0.47537E+01, & + 0.47604E+01, 0.47670E+01, 0.47736E+01, 0.47802E+01, 0.47868E+01, & + 0.47934E+01, 0.47999E+01, 0.48065E+01, 0.48130E+01, 0.48196E+01, & + 0.48261E+01, 0.48326E+01, 0.48391E+01, 0.48456E+01, 0.48521E+01, & + 0.48586E+01, 0.48650E+01, 0.48715E+01, 0.48779E+01, 0.48844E+01, & + 0.48908E+01, 0.48972E+01, 0.49036E+01, 0.49100E+01, 0.49164E+01, & + 0.49228E+01, 0.49292E+01, 0.49355E+01, 0.49419E+01, 0.49482E+01, & + 0.49546E+01, 0.49609E+01, 0.49672E+01, 0.49735E+01, 0.49798E+01, & + 0.49861E+01, 0.49924E+01, 0.49986E+01, 0.50049E+01, 0.50112E+01, & + 0.50174E+01, 0.50236E+01, 0.50299E+01, 0.50361E+01, 0.50423E+01, & + 0.50485E+01, 0.50547E+01, 0.50608E+01, 0.50670E+01, 0.50732E+01, & + 0.50793E+01, 0.50855E+01, 0.50916E+01, 0.50977E+01, 0.51038E+01, & + 0.51099E+01, 0.51160E+01, 0.51221E+01, 0.51282E+01, 0.51343E+01, & + 0.51403E+01, 0.51464E+01, 0.51524E+01, 0.51585E+01, 0.51645E+01, & + 0.51705E+01, 0.51765E+01, 0.51825E+01, 0.51885E+01, 0.51945E+01, & + 0.52005E+01, 0.52065E+01, 0.52124E+01, 0.52184E+01, 0.52243E+01, & + 0.52303E+01, 0.52362E+01, 0.52421E+01, 0.52480E+01, 0.52539E+01, & + 0.52598E+01, 0.52657E+01, 0.52716E+01, 0.52775E+01, 0.52833E+01, & + 0.52892E+01, 0.52950E+01, 0.53009E+01, 0.53067E+01, 0.53125E+01, & + 0.53183E+01, 0.53241E+01, 0.53299E+01, 0.53357E+01, 0.53574E+01/ + + DATA (BNC08M (I),I=601,700)/ & + 0.54046E+01, 0.54611E+01, 0.55169E+01, 0.55719E+01, 0.56263E+01, & + 0.56799E+01, 0.57328E+01, 0.57851E+01, 0.58367E+01, 0.58877E+01, & + 0.59380E+01, 0.59878E+01, 0.60369E+01, 0.60855E+01, 0.61334E+01, & + 0.61808E+01, 0.62277E+01, 0.62740E+01, 0.63198E+01, 0.63651E+01, & + 0.64099E+01, 0.64542E+01, 0.64979E+01, 0.65413E+01, 0.65841E+01, & + 0.66265E+01, 0.66684E+01, 0.67099E+01, 0.67509E+01, 0.67916E+01, & + 0.68318E+01, 0.68715E+01, 0.69109E+01, 0.69499E+01, 0.69885E+01, & + 0.70267E+01, 0.70646E+01, 0.71020E+01, 0.71391E+01, 0.71759E+01, & + 0.72123E+01, 0.72483E+01, 0.72840E+01, 0.73194E+01, 0.73544E+01, & + 0.73891E+01, 0.74235E+01, 0.74576E+01, 0.74914E+01, 0.75248E+01, & + 0.75580E+01, 0.75909E+01, 0.76234E+01, 0.76557E+01, 0.76877E+01, & + 0.77195E+01, 0.77509E+01, 0.77821E+01, 0.78130E+01, 0.78437E+01, & + 0.78741E+01, 0.79042E+01, 0.79341E+01, 0.79637E+01, 0.79931E+01, & + 0.80223E+01, 0.80512E+01, 0.80799E+01, 0.81083E+01, 0.81365E+01, & + 0.81645E+01, 0.81923E+01, 0.82199E+01, 0.82472E+01, 0.82743E+01, & + 0.83012E+01, 0.83279E+01, 0.83544E+01, 0.83807E+01, 0.84068E+01, & + 0.84327E+01, 0.84584E+01, 0.84839E+01, 0.85093E+01, 0.85344E+01, & + 0.85593E+01, 0.85841E+01, 0.86087E+01, 0.86331E+01, 0.86573E+01, & + 0.86813E+01, 0.87052E+01, 0.87289E+01, 0.87524E+01, 0.87758E+01, & + 0.87990E+01, 0.88220E+01, 0.88449E+01, 0.88676E+01, 0.88902E+01/ + + DATA (BNC08M(I),I=701,741)/ & + 0.89126E+01, 0.89348E+01, 0.89569E+01, 0.89789E+01, 0.90006E+01, & + 0.90223E+01, 0.90438E+01, 0.90651E+01, 0.90863E+01, 0.91074E+01, & + 0.91283E+01, 0.91491E+01, 0.91698E+01, 0.91903E+01, 0.92107E+01, & + 0.92309E+01, 0.92510E+01, 0.92710E+01, 0.92909E+01, 0.93106E+01, & + 0.93302E+01, 0.93497E+01, 0.93690E+01, 0.93883E+01, 0.94074E+01, & + 0.94264E+01, 0.94452E+01, 0.94640E+01, 0.94826E+01, 0.95011E+01, & + 0.95195E+01, 0.95378E+01, 0.95560E+01, 0.95741E+01, 0.95920E+01, & + 0.96099E+01, 0.96276E+01, 0.96452E+01, 0.96628E+01, 0.96802E+01, & + 0.96975E+01 & + / +! +! *** NH4HSO4 +! + DATA (BNC09M (I),I= 1,100)/ & + -0.55422E-01,-0.99324E-01,-0.12935E+00,-0.14934E+00,-0.16445E+00, & + -0.17660E+00,-0.18672E+00,-0.19536E+00,-0.20285E+00,-0.20943E+00, & + -0.21526E+00,-0.22046E+00,-0.22511E+00,-0.22929E+00,-0.23305E+00, & + -0.23643E+00,-0.23948E+00,-0.24222E+00,-0.24468E+00,-0.24688E+00, & + -0.24884E+00,-0.25058E+00,-0.25210E+00,-0.25342E+00,-0.25456E+00, & + -0.25551E+00,-0.25630E+00,-0.25692E+00,-0.25739E+00,-0.25771E+00, & + -0.25789E+00,-0.25794E+00,-0.25785E+00,-0.25763E+00,-0.25730E+00, & + -0.25685E+00,-0.25628E+00,-0.25561E+00,-0.25483E+00,-0.25395E+00, & + -0.25297E+00,-0.25190E+00,-0.25074E+00,-0.24948E+00,-0.24815E+00, & + -0.24673E+00,-0.24523E+00,-0.24366E+00,-0.24201E+00,-0.24029E+00, & + -0.23850E+00,-0.23664E+00,-0.23472E+00,-0.23274E+00,-0.23069E+00, & + -0.22859E+00,-0.22643E+00,-0.22421E+00,-0.22194E+00,-0.21962E+00, & + -0.21725E+00,-0.21483E+00,-0.21236E+00,-0.20985E+00,-0.20729E+00, & + -0.20468E+00,-0.20203E+00,-0.19934E+00,-0.19661E+00,-0.19384E+00, & + -0.19102E+00,-0.18817E+00,-0.18528E+00,-0.18235E+00,-0.17938E+00, & + -0.17637E+00,-0.17333E+00,-0.17025E+00,-0.16713E+00,-0.16398E+00, & + -0.16079E+00,-0.15757E+00,-0.15431E+00,-0.15101E+00,-0.14768E+00, & + -0.14432E+00,-0.14092E+00,-0.13750E+00,-0.13403E+00,-0.13054E+00, & + -0.12701E+00,-0.12346E+00,-0.11987E+00,-0.11626E+00,-0.11261E+00, & + -0.10894E+00,-0.10524E+00,-0.10152E+00,-0.97765E-01,-0.93990E-01/ + + DATA (BNC09M (I),I=101,200)/ & + -0.90192E-01,-0.86371E-01,-0.82530E-01,-0.78668E-01,-0.74788E-01, & + -0.70889E-01,-0.66974E-01,-0.63042E-01,-0.59097E-01,-0.55137E-01, & + -0.51165E-01,-0.47182E-01,-0.43188E-01,-0.39185E-01,-0.35173E-01, & + -0.31154E-01,-0.27129E-01,-0.23099E-01,-0.19063E-01,-0.15024E-01, & + -0.11398E-01,-0.73058E-02,-0.32173E-02, 0.86749E-03, 0.49480E-02, & + 0.90243E-02, 0.13096E-01, 0.17162E-01, 0.21224E-01, 0.25280E-01, & + 0.29330E-01, 0.33374E-01, 0.37412E-01, 0.41443E-01, 0.45469E-01, & + 0.49487E-01, 0.53498E-01, 0.57502E-01, 0.61499E-01, 0.65488E-01, & + 0.69470E-01, 0.73444E-01, 0.77410E-01, 0.81368E-01, 0.85318E-01, & + 0.89260E-01, 0.93194E-01, 0.97118E-01, 0.10103E+00, 0.10494E+00, & + 0.10884E+00, 0.11273E+00, 0.11661E+00, 0.12049E+00, 0.12435E+00, & + 0.12820E+00, 0.13205E+00, 0.13588E+00, 0.13971E+00, 0.14353E+00, & + 0.14733E+00, 0.15113E+00, 0.15492E+00, 0.15870E+00, 0.16247E+00, & + 0.16623E+00, 0.16998E+00, 0.17373E+00, 0.17746E+00, 0.18118E+00, & + 0.18489E+00, 0.18860E+00, 0.19229E+00, 0.19597E+00, 0.19965E+00, & + 0.20331E+00, 0.20697E+00, 0.21061E+00, 0.21425E+00, 0.21787E+00, & + 0.22149E+00, 0.22510E+00, 0.22869E+00, 0.23228E+00, 0.23586E+00, & + 0.23943E+00, 0.24299E+00, 0.24654E+00, 0.25008E+00, 0.25361E+00, & + 0.25713E+00, 0.26064E+00, 0.26414E+00, 0.26763E+00, 0.27112E+00, & + 0.27459E+00, 0.27805E+00, 0.28151E+00, 0.28495E+00, 0.28839E+00/ + + DATA (BNC09M (I),I=201,300)/ & + 0.29182E+00, 0.29523E+00, 0.29864E+00, 0.30204E+00, 0.30543E+00, & + 0.30881E+00, 0.31218E+00, 0.31555E+00, 0.31890E+00, 0.32225E+00, & + 0.32558E+00, 0.32891E+00, 0.33223E+00, 0.33553E+00, 0.33883E+00, & + 0.34213E+00, 0.34541E+00, 0.34868E+00, 0.35195E+00, 0.35520E+00, & + 0.35845E+00, 0.36169E+00, 0.36492E+00, 0.36814E+00, 0.37135E+00, & + 0.37456E+00, 0.37775E+00, 0.38094E+00, 0.38412E+00, 0.38729E+00, & + 0.39045E+00, 0.39361E+00, 0.39675E+00, 0.39989E+00, 0.40302E+00, & + 0.40614E+00, 0.40925E+00, 0.41236E+00, 0.41546E+00, 0.41854E+00, & + 0.42162E+00, 0.42470E+00, 0.42776E+00, 0.43082E+00, 0.43387E+00, & + 0.43691E+00, 0.43994E+00, 0.44297E+00, 0.44598E+00, 0.44899E+00, & + 0.45200E+00, 0.45499E+00, 0.45798E+00, 0.46096E+00, 0.46393E+00, & + 0.46689E+00, 0.46985E+00, 0.47280E+00, 0.47574E+00, 0.47867E+00, & + 0.48160E+00, 0.48452E+00, 0.48743E+00, 0.49033E+00, 0.49323E+00, & + 0.49612E+00, 0.49900E+00, 0.50188E+00, 0.50475E+00, 0.50761E+00, & + 0.51046E+00, 0.51331E+00, 0.51615E+00, 0.51898E+00, 0.52181E+00, & + 0.52463E+00, 0.52744E+00, 0.53025E+00, 0.53305E+00, 0.53584E+00, & + 0.53862E+00, 0.54140E+00, 0.54417E+00, 0.54694E+00, 0.54969E+00, & + 0.55244E+00, 0.55519E+00, 0.55793E+00, 0.56066E+00, 0.56338E+00, & + 0.56610E+00, 0.56881E+00, 0.57152E+00, 0.57422E+00, 0.57691E+00, & + 0.57959E+00, 0.58227E+00, 0.58495E+00, 0.58761E+00, 0.59027E+00/ + + DATA (BNC09M (I),I=301,400)/ & + 0.59293E+00, 0.59558E+00, 0.59822E+00, 0.60085E+00, 0.60348E+00, & + 0.60611E+00, 0.60872E+00, 0.61133E+00, 0.61394E+00, 0.61654E+00, & + 0.61913E+00, 0.62172E+00, 0.62430E+00, 0.62687E+00, 0.62944E+00, & + 0.63200E+00, 0.63456E+00, 0.63711E+00, 0.63966E+00, 0.64219E+00, & + 0.64473E+00, 0.64726E+00, 0.64978E+00, 0.65229E+00, 0.65480E+00, & + 0.65731E+00, 0.65981E+00, 0.66230E+00, 0.66479E+00, 0.66727E+00, & + 0.66975E+00, 0.67222E+00, 0.67468E+00, 0.67714E+00, 0.67960E+00, & + 0.68205E+00, 0.68449E+00, 0.68693E+00, 0.68936E+00, 0.69179E+00, & + 0.69421E+00, 0.69663E+00, 0.69904E+00, 0.70144E+00, 0.70384E+00, & + 0.70624E+00, 0.70863E+00, 0.71101E+00, 0.71339E+00, 0.71577E+00, & + 0.71813E+00, 0.72050E+00, 0.72286E+00, 0.72521E+00, 0.72756E+00, & + 0.72990E+00, 0.73224E+00, 0.73457E+00, 0.73690E+00, 0.73922E+00, & + 0.74154E+00, 0.74386E+00, 0.74616E+00, 0.74847E+00, 0.75076E+00, & + 0.75306E+00, 0.75535E+00, 0.75763E+00, 0.75991E+00, 0.76218E+00, & + 0.76445E+00, 0.76671E+00, 0.76897E+00, 0.77123E+00, 0.77348E+00, & + 0.77572E+00, 0.77796E+00, 0.78020E+00, 0.78243E+00, 0.78465E+00, & + 0.78687E+00, 0.78909E+00, 0.79130E+00, 0.79351E+00, 0.79571E+00, & + 0.79791E+00, 0.80010E+00, 0.80229E+00, 0.80448E+00, 0.80666E+00, & + 0.80883E+00, 0.81100E+00, 0.81317E+00, 0.81533E+00, 0.81749E+00, & + 0.81964E+00, 0.82179E+00, 0.82394E+00, 0.82608E+00, 0.82821E+00/ + + DATA (BNC09M (I),I=401,500)/ & + 0.83034E+00, 0.83247E+00, 0.83459E+00, 0.83671E+00, 0.83882E+00, & + 0.84093E+00, 0.84304E+00, 0.84514E+00, 0.84723E+00, 0.84933E+00, & + 0.85141E+00, 0.85350E+00, 0.85558E+00, 0.85765E+00, 0.85972E+00, & + 0.86179E+00, 0.86385E+00, 0.86591E+00, 0.86797E+00, 0.87002E+00, & + 0.87207E+00, 0.87411E+00, 0.87615E+00, 0.87818E+00, 0.88021E+00, & + 0.88224E+00, 0.88426E+00, 0.88628E+00, 0.88829E+00, 0.89030E+00, & + 0.89231E+00, 0.89431E+00, 0.89631E+00, 0.89830E+00, 0.90029E+00, & + 0.90228E+00, 0.90426E+00, 0.90624E+00, 0.90822E+00, 0.91019E+00, & + 0.91216E+00, 0.91412E+00, 0.91608E+00, 0.91803E+00, 0.91999E+00, & + 0.92193E+00, 0.92388E+00, 0.92582E+00, 0.92776E+00, 0.92969E+00, & + 0.93162E+00, 0.93354E+00, 0.93547E+00, 0.93738E+00, 0.93930E+00, & + 0.94121E+00, 0.94312E+00, 0.94502E+00, 0.94692E+00, 0.94882E+00, & + 0.95071E+00, 0.95260E+00, 0.95448E+00, 0.95637E+00, 0.95824E+00, & + 0.96012E+00, 0.96199E+00, 0.96386E+00, 0.96572E+00, 0.96758E+00, & + 0.96944E+00, 0.97129E+00, 0.97314E+00, 0.97499E+00, 0.97683E+00, & + 0.97867E+00, 0.98051E+00, 0.98234E+00, 0.98417E+00, 0.98600E+00, & + 0.98782E+00, 0.98964E+00, 0.99145E+00, 0.99327E+00, 0.99507E+00, & + 0.99688E+00, 0.99868E+00, 0.10005E+01, 0.10023E+01, 0.10041E+01, & + 0.10059E+01, 0.10076E+01, 0.10094E+01, 0.10112E+01, 0.10130E+01, & + 0.10148E+01, 0.10165E+01, 0.10183E+01, 0.10200E+01, 0.10218E+01/ + + DATA (BNC09M (I),I=501,600)/ & + 0.10236E+01, 0.10253E+01, 0.10271E+01, 0.10288E+01, 0.10306E+01, & + 0.10323E+01, 0.10340E+01, 0.10358E+01, 0.10375E+01, 0.10392E+01, & + 0.10409E+01, 0.10427E+01, 0.10444E+01, 0.10461E+01, 0.10478E+01, & + 0.10495E+01, 0.10512E+01, 0.10529E+01, 0.10546E+01, 0.10563E+01, & + 0.10580E+01, 0.10597E+01, 0.10614E+01, 0.10631E+01, 0.10648E+01, & + 0.10664E+01, 0.10681E+01, 0.10698E+01, 0.10715E+01, 0.10731E+01, & + 0.10748E+01, 0.10765E+01, 0.10781E+01, 0.10798E+01, 0.10814E+01, & + 0.10831E+01, 0.10847E+01, 0.10864E+01, 0.10880E+01, 0.10896E+01, & + 0.10913E+01, 0.10929E+01, 0.10945E+01, 0.10961E+01, 0.10978E+01, & + 0.10994E+01, 0.11010E+01, 0.11026E+01, 0.11042E+01, 0.11058E+01, & + 0.11074E+01, 0.11090E+01, 0.11106E+01, 0.11122E+01, 0.11138E+01, & + 0.11154E+01, 0.11170E+01, 0.11186E+01, 0.11202E+01, 0.11218E+01, & + 0.11233E+01, 0.11249E+01, 0.11265E+01, 0.11281E+01, 0.11296E+01, & + 0.11312E+01, 0.11328E+01, 0.11343E+01, 0.11359E+01, 0.11374E+01, & + 0.11390E+01, 0.11405E+01, 0.11421E+01, 0.11436E+01, 0.11451E+01, & + 0.11467E+01, 0.11482E+01, 0.11497E+01, 0.11513E+01, 0.11528E+01, & + 0.11543E+01, 0.11559E+01, 0.11574E+01, 0.11589E+01, 0.11604E+01, & + 0.11619E+01, 0.11634E+01, 0.11649E+01, 0.11664E+01, 0.11679E+01, & + 0.11694E+01, 0.11709E+01, 0.11724E+01, 0.11739E+01, 0.11754E+01, & + 0.11769E+01, 0.11784E+01, 0.11798E+01, 0.11813E+01, 0.11868E+01/ + + DATA (BNC09M (I),I=601,700)/ & + 0.11989E+01, 0.12132E+01, 0.12273E+01, 0.12412E+01, 0.12549E+01, & + 0.12683E+01, 0.12816E+01, 0.12946E+01, 0.13074E+01, 0.13200E+01, & + 0.13324E+01, 0.13446E+01, 0.13566E+01, 0.13685E+01, 0.13801E+01, & + 0.13916E+01, 0.14029E+01, 0.14141E+01, 0.14250E+01, 0.14358E+01, & + 0.14465E+01, 0.14570E+01, 0.14673E+01, 0.14775E+01, 0.14875E+01, & + 0.14974E+01, 0.15072E+01, 0.15168E+01, 0.15262E+01, 0.15356E+01, & + 0.15448E+01, 0.15538E+01, 0.15628E+01, 0.15716E+01, 0.15803E+01, & + 0.15888E+01, 0.15973E+01, 0.16056E+01, 0.16138E+01, 0.16219E+01, & + 0.16299E+01, 0.16378E+01, 0.16455E+01, 0.16532E+01, 0.16608E+01, & + 0.16682E+01, 0.16756E+01, 0.16828E+01, 0.16900E+01, 0.16970E+01, & + 0.17040E+01, 0.17108E+01, 0.17176E+01, 0.17243E+01, 0.17308E+01, & + 0.17373E+01, 0.17438E+01, 0.17501E+01, 0.17563E+01, 0.17625E+01, & + 0.17685E+01, 0.17745E+01, 0.17804E+01, 0.17863E+01, 0.17920E+01, & + 0.17977E+01, 0.18033E+01, 0.18088E+01, 0.18142E+01, 0.18196E+01, & + 0.18249E+01, 0.18302E+01, 0.18353E+01, 0.18404E+01, 0.18454E+01, & + 0.18504E+01, 0.18553E+01, 0.18601E+01, 0.18649E+01, 0.18695E+01, & + 0.18742E+01, 0.18787E+01, 0.18832E+01, 0.18877E+01, 0.18921E+01, & + 0.18964E+01, 0.19007E+01, 0.19049E+01, 0.19090E+01, 0.19131E+01, & + 0.19171E+01, 0.19211E+01, 0.19250E+01, 0.19289E+01, 0.19327E+01, & + 0.19365E+01, 0.19402E+01, 0.19439E+01, 0.19475E+01, 0.19510E+01/ + + DATA (BNC09M(I),I=701,741)/ & + 0.19545E+01, 0.19580E+01, 0.19614E+01, 0.19647E+01, 0.19681E+01, & + 0.19713E+01, 0.19745E+01, 0.19777E+01, 0.19808E+01, 0.19839E+01, & + 0.19869E+01, 0.19899E+01, 0.19929E+01, 0.19958E+01, 0.19986E+01, & + 0.20014E+01, 0.20042E+01, 0.20069E+01, 0.20096E+01, 0.20123E+01, & + 0.20149E+01, 0.20175E+01, 0.20200E+01, 0.20225E+01, 0.20249E+01, & + 0.20273E+01, 0.20297E+01, 0.20320E+01, 0.20343E+01, 0.20366E+01, & + 0.20388E+01, 0.20410E+01, 0.20432E+01, 0.20453E+01, 0.20473E+01, & + 0.20494E+01, 0.20514E+01, 0.20534E+01, 0.20553E+01, 0.20572E+01, & + 0.20591E+01 & + / +! +! *** (H, NO3) +! + DATA (BNC10M (I),I= 1,100)/ & + -0.54443E-01,-0.95281E-01,-0.12118E+00,-0.13706E+00,-0.14810E+00, & + -0.15622E+00,-0.16239E+00,-0.16713E+00,-0.17079E+00,-0.17360E+00, & + -0.17573E+00,-0.17729E+00,-0.17838E+00,-0.17908E+00,-0.17943E+00, & + -0.17948E+00,-0.17928E+00,-0.17885E+00,-0.17821E+00,-0.17740E+00, & + -0.17642E+00,-0.17531E+00,-0.17407E+00,-0.17271E+00,-0.17124E+00, & + -0.16969E+00,-0.16805E+00,-0.16633E+00,-0.16455E+00,-0.16270E+00, & + -0.16080E+00,-0.15884E+00,-0.15684E+00,-0.15480E+00,-0.15272E+00, & + -0.15061E+00,-0.14847E+00,-0.14631E+00,-0.14412E+00,-0.14191E+00, & + -0.13968E+00,-0.13744E+00,-0.13518E+00,-0.13291E+00,-0.13063E+00, & + -0.12834E+00,-0.12605E+00,-0.12375E+00,-0.12144E+00,-0.11913E+00, & + -0.11682E+00,-0.11450E+00,-0.11218E+00,-0.10986E+00,-0.10754E+00, & + -0.10521E+00,-0.10289E+00,-0.10056E+00,-0.98232E-01,-0.95901E-01, & + -0.93569E-01,-0.91233E-01,-0.88895E-01,-0.86553E-01,-0.84207E-01, & + -0.81856E-01,-0.79499E-01,-0.77136E-01,-0.74766E-01,-0.72388E-01, & + -0.70002E-01,-0.67607E-01,-0.65201E-01,-0.62784E-01,-0.60355E-01, & + -0.57914E-01,-0.55459E-01,-0.52990E-01,-0.50507E-01,-0.48008E-01, & + -0.45493E-01,-0.42962E-01,-0.40413E-01,-0.37847E-01,-0.35263E-01, & + -0.32660E-01,-0.30039E-01,-0.27400E-01,-0.24741E-01,-0.22063E-01, & + -0.19367E-01,-0.16651E-01,-0.13917E-01,-0.11164E-01,-0.83926E-02, & + -0.56031E-02,-0.27959E-02, 0.28739E-04, 0.28702E-02, 0.57282E-02/ + + DATA (BNC10M (I),I=101,200)/ & + 0.86021E-02, 0.11491E-01, 0.14395E-01, 0.17314E-01, 0.20245E-01, & + 0.23190E-01, 0.26147E-01, 0.29115E-01, 0.32095E-01, 0.35084E-01, & + 0.38083E-01, 0.41091E-01, 0.44107E-01, 0.47130E-01, 0.50160E-01, & + 0.53197E-01, 0.56239E-01, 0.59286E-01, 0.62338E-01, 0.65393E-01, & + 0.68068E-01, 0.71174E-01, 0.74277E-01, 0.77379E-01, 0.80478E-01, & + 0.83575E-01, 0.86669E-01, 0.89761E-01, 0.92850E-01, 0.95936E-01, & + 0.99019E-01, 0.10210E+00, 0.10518E+00, 0.10825E+00, 0.11132E+00, & + 0.11439E+00, 0.11746E+00, 0.12052E+00, 0.12358E+00, 0.12663E+00, & + 0.12968E+00, 0.13273E+00, 0.13578E+00, 0.13882E+00, 0.14185E+00, & + 0.14489E+00, 0.14792E+00, 0.15094E+00, 0.15397E+00, 0.15698E+00, & + 0.16000E+00, 0.16301E+00, 0.16601E+00, 0.16902E+00, 0.17201E+00, & + 0.17501E+00, 0.17800E+00, 0.18098E+00, 0.18396E+00, 0.18694E+00, & + 0.18991E+00, 0.19288E+00, 0.19585E+00, 0.19881E+00, 0.20176E+00, & + 0.20471E+00, 0.20766E+00, 0.21060E+00, 0.21354E+00, 0.21647E+00, & + 0.21940E+00, 0.22232E+00, 0.22524E+00, 0.22816E+00, 0.23107E+00, & + 0.23397E+00, 0.23687E+00, 0.23977E+00, 0.24266E+00, 0.24554E+00, & + 0.24843E+00, 0.25130E+00, 0.25418E+00, 0.25704E+00, 0.25991E+00, & + 0.26276E+00, 0.26562E+00, 0.26846E+00, 0.27131E+00, 0.27415E+00, & + 0.27698E+00, 0.27981E+00, 0.28263E+00, 0.28545E+00, 0.28827E+00, & + 0.29107E+00, 0.29388E+00, 0.29668E+00, 0.29947E+00, 0.30226E+00/ + + DATA (BNC10M (I),I=201,300)/ & + 0.30505E+00, 0.30783E+00, 0.31060E+00, 0.31337E+00, 0.31614E+00, & + 0.31890E+00, 0.32165E+00, 0.32440E+00, 0.32715E+00, 0.32989E+00, & + 0.33262E+00, 0.33535E+00, 0.33808E+00, 0.34080E+00, 0.34351E+00, & + 0.34622E+00, 0.34893E+00, 0.35163E+00, 0.35432E+00, 0.35701E+00, & + 0.35970E+00, 0.36238E+00, 0.36505E+00, 0.36772E+00, 0.37039E+00, & + 0.37305E+00, 0.37571E+00, 0.37836E+00, 0.38100E+00, 0.38364E+00, & + 0.38628E+00, 0.38891E+00, 0.39153E+00, 0.39416E+00, 0.39677E+00, & + 0.39938E+00, 0.40199E+00, 0.40459E+00, 0.40719E+00, 0.40978E+00, & + 0.41236E+00, 0.41495E+00, 0.41752E+00, 0.42009E+00, 0.42266E+00, & + 0.42522E+00, 0.42778E+00, 0.43033E+00, 0.43288E+00, 0.43542E+00, & + 0.43796E+00, 0.44049E+00, 0.44302E+00, 0.44554E+00, 0.44806E+00, & + 0.45057E+00, 0.45308E+00, 0.45559E+00, 0.45808E+00, 0.46058E+00, & + 0.46307E+00, 0.46555E+00, 0.46803E+00, 0.47051E+00, 0.47298E+00, & + 0.47544E+00, 0.47790E+00, 0.48036E+00, 0.48281E+00, 0.48526E+00, & + 0.48770E+00, 0.49013E+00, 0.49257E+00, 0.49499E+00, 0.49742E+00, & + 0.49983E+00, 0.50225E+00, 0.50466E+00, 0.50706E+00, 0.50946E+00, & + 0.51185E+00, 0.51424E+00, 0.51663E+00, 0.51901E+00, 0.52139E+00, & + 0.52376E+00, 0.52612E+00, 0.52849E+00, 0.53084E+00, 0.53320E+00, & + 0.53555E+00, 0.53789E+00, 0.54023E+00, 0.54257E+00, 0.54490E+00, & + 0.54722E+00, 0.54954E+00, 0.55186E+00, 0.55417E+00, 0.55648E+00/ + + DATA (BNC10M (I),I=301,400)/ & + 0.55878E+00, 0.56108E+00, 0.56338E+00, 0.56567E+00, 0.56795E+00, & + 0.57023E+00, 0.57251E+00, 0.57478E+00, 0.57705E+00, 0.57932E+00, & + 0.58157E+00, 0.58383E+00, 0.58608E+00, 0.58833E+00, 0.59057E+00, & + 0.59280E+00, 0.59504E+00, 0.59727E+00, 0.59949E+00, 0.60171E+00, & + 0.60393E+00, 0.60614E+00, 0.60835E+00, 0.61055E+00, 0.61275E+00, & + 0.61494E+00, 0.61713E+00, 0.61932E+00, 0.62150E+00, 0.62368E+00, & + 0.62585E+00, 0.62802E+00, 0.63018E+00, 0.63234E+00, 0.63450E+00, & + 0.63665E+00, 0.63880E+00, 0.64095E+00, 0.64309E+00, 0.64522E+00, & + 0.64735E+00, 0.64948E+00, 0.65161E+00, 0.65372E+00, 0.65584E+00, & + 0.65795E+00, 0.66006E+00, 0.66216E+00, 0.66426E+00, 0.66636E+00, & + 0.66845E+00, 0.67053E+00, 0.67262E+00, 0.67470E+00, 0.67677E+00, & + 0.67884E+00, 0.68091E+00, 0.68297E+00, 0.68503E+00, 0.68709E+00, & + 0.68914E+00, 0.69119E+00, 0.69323E+00, 0.69527E+00, 0.69731E+00, & + 0.69934E+00, 0.70137E+00, 0.70339E+00, 0.70541E+00, 0.70743E+00, & + 0.70944E+00, 0.71145E+00, 0.71346E+00, 0.71546E+00, 0.71745E+00, & + 0.71945E+00, 0.72144E+00, 0.72342E+00, 0.72541E+00, 0.72738E+00, & + 0.72936E+00, 0.73133E+00, 0.73330E+00, 0.73526E+00, 0.73722E+00, & + 0.73918E+00, 0.74113E+00, 0.74308E+00, 0.74502E+00, 0.74697E+00, & + 0.74890E+00, 0.75084E+00, 0.75277E+00, 0.75470E+00, 0.75662E+00, & + 0.75854E+00, 0.76046E+00, 0.76237E+00, 0.76428E+00, 0.76618E+00/ + + DATA (BNC10M (I),I=401,500)/ & + 0.76808E+00, 0.76998E+00, 0.77188E+00, 0.77377E+00, 0.77566E+00, & + 0.77754E+00, 0.77942E+00, 0.78130E+00, 0.78317E+00, 0.78504E+00, & + 0.78691E+00, 0.78877E+00, 0.79063E+00, 0.79249E+00, 0.79434E+00, & + 0.79619E+00, 0.79803E+00, 0.79988E+00, 0.80171E+00, 0.80355E+00, & + 0.80538E+00, 0.80721E+00, 0.80904E+00, 0.81086E+00, 0.81268E+00, & + 0.81449E+00, 0.81630E+00, 0.81811E+00, 0.81992E+00, 0.82172E+00, & + 0.82352E+00, 0.82531E+00, 0.82710E+00, 0.82889E+00, 0.83068E+00, & + 0.83246E+00, 0.83424E+00, 0.83601E+00, 0.83779E+00, 0.83955E+00, & + 0.84132E+00, 0.84308E+00, 0.84484E+00, 0.84660E+00, 0.84835E+00, & + 0.85010E+00, 0.85185E+00, 0.85359E+00, 0.85533E+00, 0.85707E+00, & + 0.85880E+00, 0.86053E+00, 0.86226E+00, 0.86398E+00, 0.86570E+00, & + 0.86742E+00, 0.86914E+00, 0.87085E+00, 0.87256E+00, 0.87426E+00, & + 0.87596E+00, 0.87766E+00, 0.87936E+00, 0.88105E+00, 0.88274E+00, & + 0.88443E+00, 0.88611E+00, 0.88779E+00, 0.88947E+00, 0.89115E+00, & + 0.89282E+00, 0.89449E+00, 0.89615E+00, 0.89782E+00, 0.89948E+00, & + 0.90113E+00, 0.90279E+00, 0.90444E+00, 0.90608E+00, 0.90773E+00, & + 0.90937E+00, 0.91101E+00, 0.91265E+00, 0.91428E+00, 0.91591E+00, & + 0.91754E+00, 0.91916E+00, 0.92078E+00, 0.92240E+00, 0.92402E+00, & + 0.92563E+00, 0.92724E+00, 0.92885E+00, 0.93045E+00, 0.93205E+00, & + 0.93365E+00, 0.93525E+00, 0.93684E+00, 0.93843E+00, 0.94002E+00/ + + DATA (BNC10M (I),I=501,600)/ & + 0.94160E+00, 0.94318E+00, 0.94476E+00, 0.94634E+00, 0.94791E+00, & + 0.94948E+00, 0.95105E+00, 0.95261E+00, 0.95418E+00, 0.95574E+00, & + 0.95729E+00, 0.95885E+00, 0.96040E+00, 0.96195E+00, 0.96349E+00, & + 0.96504E+00, 0.96658E+00, 0.96811E+00, 0.96965E+00, 0.97118E+00, & + 0.97271E+00, 0.97424E+00, 0.97576E+00, 0.97728E+00, 0.97880E+00, & + 0.98032E+00, 0.98183E+00, 0.98334E+00, 0.98485E+00, 0.98635E+00, & + 0.98786E+00, 0.98936E+00, 0.99086E+00, 0.99235E+00, 0.99384E+00, & + 0.99533E+00, 0.99682E+00, 0.99831E+00, 0.99979E+00, 0.10013E+01, & + 0.10027E+01, 0.10042E+01, 0.10057E+01, 0.10072E+01, 0.10086E+01, & + 0.10101E+01, 0.10116E+01, 0.10130E+01, 0.10145E+01, 0.10159E+01, & + 0.10174E+01, 0.10188E+01, 0.10203E+01, 0.10217E+01, 0.10232E+01, & + 0.10246E+01, 0.10260E+01, 0.10275E+01, 0.10289E+01, 0.10303E+01, & + 0.10318E+01, 0.10332E+01, 0.10346E+01, 0.10360E+01, 0.10374E+01, & + 0.10389E+01, 0.10403E+01, 0.10417E+01, 0.10431E+01, 0.10445E+01, & + 0.10459E+01, 0.10473E+01, 0.10487E+01, 0.10501E+01, 0.10515E+01, & + 0.10529E+01, 0.10543E+01, 0.10556E+01, 0.10570E+01, 0.10584E+01, & + 0.10598E+01, 0.10612E+01, 0.10625E+01, 0.10639E+01, 0.10653E+01, & + 0.10666E+01, 0.10680E+01, 0.10694E+01, 0.10707E+01, 0.10721E+01, & + 0.10734E+01, 0.10748E+01, 0.10762E+01, 0.10775E+01, 0.10788E+01, & + 0.10802E+01, 0.10815E+01, 0.10829E+01, 0.10842E+01, 0.10892E+01/ + + DATA (BNC10M (I),I=601,700)/ & + 0.11001E+01, 0.11131E+01, 0.11259E+01, 0.11384E+01, 0.11508E+01, & + 0.11629E+01, 0.11749E+01, 0.11867E+01, 0.11983E+01, 0.12097E+01, & + 0.12209E+01, 0.12319E+01, 0.12428E+01, 0.12535E+01, 0.12640E+01, & + 0.12744E+01, 0.12846E+01, 0.12946E+01, 0.13045E+01, 0.13142E+01, & + 0.13238E+01, 0.13333E+01, 0.13426E+01, 0.13517E+01, 0.13607E+01, & + 0.13696E+01, 0.13784E+01, 0.13870E+01, 0.13955E+01, 0.14038E+01, & + 0.14121E+01, 0.14202E+01, 0.14282E+01, 0.14361E+01, 0.14438E+01, & + 0.14515E+01, 0.14590E+01, 0.14664E+01, 0.14738E+01, 0.14810E+01, & + 0.14881E+01, 0.14951E+01, 0.15020E+01, 0.15088E+01, 0.15155E+01, & + 0.15221E+01, 0.15286E+01, 0.15350E+01, 0.15413E+01, 0.15475E+01, & + 0.15536E+01, 0.15597E+01, 0.15656E+01, 0.15715E+01, 0.15773E+01, & + 0.15830E+01, 0.15886E+01, 0.15942E+01, 0.15996E+01, 0.16050E+01, & + 0.16103E+01, 0.16155E+01, 0.16207E+01, 0.16258E+01, 0.16308E+01, & + 0.16357E+01, 0.16406E+01, 0.16453E+01, 0.16501E+01, 0.16547E+01, & + 0.16593E+01, 0.16638E+01, 0.16682E+01, 0.16726E+01, 0.16769E+01, & + 0.16812E+01, 0.16854E+01, 0.16895E+01, 0.16936E+01, 0.16976E+01, & + 0.17015E+01, 0.17054E+01, 0.17092E+01, 0.17130E+01, 0.17167E+01, & + 0.17204E+01, 0.17240E+01, 0.17275E+01, 0.17310E+01, 0.17345E+01, & + 0.17379E+01, 0.17412E+01, 0.17445E+01, 0.17477E+01, 0.17509E+01, & + 0.17540E+01, 0.17571E+01, 0.17601E+01, 0.17631E+01, 0.17660E+01/ + + DATA (BNC10M(I),I=701,741)/ & + 0.17689E+01, 0.17718E+01, 0.17746E+01, 0.17773E+01, 0.17800E+01, & + 0.17827E+01, 0.17853E+01, 0.17879E+01, 0.17904E+01, 0.17929E+01, & + 0.17953E+01, 0.17977E+01, 0.18001E+01, 0.18024E+01, 0.18047E+01, & + 0.18069E+01, 0.18091E+01, 0.18113E+01, 0.18134E+01, 0.18155E+01, & + 0.18175E+01, 0.18195E+01, 0.18215E+01, 0.18234E+01, 0.18253E+01, & + 0.18271E+01, 0.18290E+01, 0.18307E+01, 0.18325E+01, 0.18342E+01, & + 0.18359E+01, 0.18375E+01, 0.18391E+01, 0.18407E+01, 0.18423E+01, & + 0.18438E+01, 0.18453E+01, 0.18467E+01, 0.18481E+01, 0.18495E+01, & + 0.18509E+01 & + / +! +! *** (H, Cl) +! + DATA (BNC11M (I),I= 1,100)/ & + -0.52529E-01,-0.88720E-01,-0.10935E+00,-0.12044E+00,-0.12697E+00, & + -0.13075E+00,-0.13267E+00,-0.13322E+00,-0.13273E+00,-0.13141E+00, & + -0.12940E+00,-0.12681E+00,-0.12374E+00,-0.12024E+00,-0.11636E+00, & + -0.11215E+00,-0.10765E+00,-0.10287E+00,-0.97853E-01,-0.92611E-01, & + -0.87164E-01,-0.81529E-01,-0.75720E-01,-0.69751E-01,-0.63632E-01, & + -0.57375E-01,-0.50988E-01,-0.44482E-01,-0.37863E-01,-0.31140E-01, & + -0.24319E-01,-0.17407E-01,-0.10411E-01,-0.33352E-02, 0.38142E-02, & + 0.11032E-01, 0.18315E-01, 0.25656E-01, 0.33053E-01, 0.40501E-01, & + 0.47996E-01, 0.55536E-01, 0.63116E-01, 0.70734E-01, 0.78387E-01, & + 0.86072E-01, 0.93788E-01, 0.10153E+00, 0.10930E+00, 0.11709E+00, & + 0.12490E+00, 0.13274E+00, 0.14059E+00, 0.14847E+00, 0.15636E+00, & + 0.16426E+00, 0.17219E+00, 0.18013E+00, 0.18808E+00, 0.19605E+00, & + 0.20404E+00, 0.21204E+00, 0.22006E+00, 0.22810E+00, 0.23615E+00, & + 0.24422E+00, 0.25232E+00, 0.26043E+00, 0.26857E+00, 0.27673E+00, & + 0.28491E+00, 0.29312E+00, 0.30136E+00, 0.30962E+00, 0.31792E+00, & + 0.32624E+00, 0.33460E+00, 0.34299E+00, 0.35142E+00, 0.35989E+00, & + 0.36839E+00, 0.37693E+00, 0.38551E+00, 0.39413E+00, 0.40279E+00, & + 0.41150E+00, 0.42024E+00, 0.42903E+00, 0.43786E+00, 0.44674E+00, & + 0.45565E+00, 0.46462E+00, 0.47362E+00, 0.48266E+00, 0.49175E+00, & + 0.50087E+00, 0.51004E+00, 0.51925E+00, 0.52849E+00, 0.53777E+00/ + + DATA (BNC11M (I),I=101,200)/ & + 0.54708E+00, 0.55643E+00, 0.56581E+00, 0.57522E+00, 0.58465E+00, & + 0.59412E+00, 0.60361E+00, 0.61313E+00, 0.62267E+00, 0.63222E+00, & + 0.64180E+00, 0.65140E+00, 0.66101E+00, 0.67063E+00, 0.68027E+00, & + 0.68991E+00, 0.69957E+00, 0.70923E+00, 0.71890E+00, 0.72857E+00, & + 0.73737E+00, 0.74715E+00, 0.75692E+00, 0.76668E+00, 0.77643E+00, & + 0.78617E+00, 0.79590E+00, 0.80562E+00, 0.81533E+00, 0.82502E+00, & + 0.83470E+00, 0.84437E+00, 0.85403E+00, 0.86368E+00, 0.87331E+00, & + 0.88293E+00, 0.89253E+00, 0.90212E+00, 0.91170E+00, 0.92126E+00, & + 0.93081E+00, 0.94034E+00, 0.94986E+00, 0.95936E+00, 0.96885E+00, & + 0.97833E+00, 0.98778E+00, 0.99723E+00, 0.10067E+01, 0.10161E+01, & + 0.10255E+01, 0.10348E+01, 0.10442E+01, 0.10535E+01, 0.10629E+01, & + 0.10722E+01, 0.10815E+01, 0.10908E+01, 0.11000E+01, 0.11093E+01, & + 0.11185E+01, 0.11277E+01, 0.11369E+01, 0.11461E+01, 0.11552E+01, & + 0.11644E+01, 0.11735E+01, 0.11826E+01, 0.11917E+01, 0.12008E+01, & + 0.12098E+01, 0.12189E+01, 0.12279E+01, 0.12369E+01, 0.12459E+01, & + 0.12548E+01, 0.12638E+01, 0.12727E+01, 0.12816E+01, 0.12905E+01, & + 0.12994E+01, 0.13083E+01, 0.13171E+01, 0.13259E+01, 0.13347E+01, & + 0.13435E+01, 0.13523E+01, 0.13610E+01, 0.13698E+01, 0.13785E+01, & + 0.13872E+01, 0.13958E+01, 0.14045E+01, 0.14131E+01, 0.14218E+01, & + 0.14304E+01, 0.14390E+01, 0.14475E+01, 0.14561E+01, 0.14646E+01/ + + DATA (BNC11M (I),I=201,300)/ & + 0.14731E+01, 0.14816E+01, 0.14901E+01, 0.14986E+01, 0.15070E+01, & + 0.15154E+01, 0.15238E+01, 0.15322E+01, 0.15406E+01, 0.15489E+01, & + 0.15573E+01, 0.15656E+01, 0.15739E+01, 0.15822E+01, 0.15904E+01, & + 0.15987E+01, 0.16069E+01, 0.16151E+01, 0.16233E+01, 0.16315E+01, & + 0.16397E+01, 0.16478E+01, 0.16559E+01, 0.16640E+01, 0.16721E+01, & + 0.16802E+01, 0.16882E+01, 0.16963E+01, 0.17043E+01, 0.17123E+01, & + 0.17203E+01, 0.17283E+01, 0.17362E+01, 0.17441E+01, 0.17521E+01, & + 0.17600E+01, 0.17678E+01, 0.17757E+01, 0.17836E+01, 0.17914E+01, & + 0.17992E+01, 0.18070E+01, 0.18148E+01, 0.18226E+01, 0.18303E+01, & + 0.18380E+01, 0.18458E+01, 0.18535E+01, 0.18611E+01, 0.18688E+01, & + 0.18765E+01, 0.18841E+01, 0.18917E+01, 0.18993E+01, 0.19069E+01, & + 0.19145E+01, 0.19220E+01, 0.19296E+01, 0.19371E+01, 0.19446E+01, & + 0.19521E+01, 0.19596E+01, 0.19670E+01, 0.19745E+01, 0.19819E+01, & + 0.19893E+01, 0.19967E+01, 0.20041E+01, 0.20114E+01, 0.20188E+01, & + 0.20261E+01, 0.20334E+01, 0.20407E+01, 0.20480E+01, 0.20553E+01, & + 0.20626E+01, 0.20698E+01, 0.20770E+01, 0.20842E+01, 0.20914E+01, & + 0.20986E+01, 0.21058E+01, 0.21129E+01, 0.21201E+01, 0.21272E+01, & + 0.21343E+01, 0.21414E+01, 0.21485E+01, 0.21555E+01, 0.21626E+01, & + 0.21696E+01, 0.21767E+01, 0.21837E+01, 0.21907E+01, 0.21976E+01, & + 0.22046E+01, 0.22115E+01, 0.22185E+01, 0.22254E+01, 0.22323E+01/ + + DATA (BNC11M (I),I=301,400)/ & + 0.22392E+01, 0.22461E+01, 0.22529E+01, 0.22598E+01, 0.22666E+01, & + 0.22735E+01, 0.22803E+01, 0.22871E+01, 0.22938E+01, 0.23006E+01, & + 0.23074E+01, 0.23141E+01, 0.23208E+01, 0.23276E+01, 0.23343E+01, & + 0.23409E+01, 0.23476E+01, 0.23543E+01, 0.23609E+01, 0.23676E+01, & + 0.23742E+01, 0.23808E+01, 0.23874E+01, 0.23940E+01, 0.24005E+01, & + 0.24071E+01, 0.24136E+01, 0.24202E+01, 0.24267E+01, 0.24332E+01, & + 0.24397E+01, 0.24462E+01, 0.24526E+01, 0.24591E+01, 0.24655E+01, & + 0.24719E+01, 0.24784E+01, 0.24848E+01, 0.24912E+01, 0.24975E+01, & + 0.25039E+01, 0.25103E+01, 0.25166E+01, 0.25229E+01, 0.25292E+01, & + 0.25356E+01, 0.25418E+01, 0.25481E+01, 0.25544E+01, 0.25607E+01, & + 0.25669E+01, 0.25731E+01, 0.25794E+01, 0.25856E+01, 0.25918E+01, & + 0.25979E+01, 0.26041E+01, 0.26103E+01, 0.26164E+01, 0.26226E+01, & + 0.26287E+01, 0.26348E+01, 0.26409E+01, 0.26470E+01, 0.26531E+01, & + 0.26592E+01, 0.26652E+01, 0.26713E+01, 0.26773E+01, 0.26833E+01, & + 0.26894E+01, 0.26954E+01, 0.27013E+01, 0.27073E+01, 0.27133E+01, & + 0.27193E+01, 0.27252E+01, 0.27311E+01, 0.27371E+01, 0.27430E+01, & + 0.27489E+01, 0.27548E+01, 0.27607E+01, 0.27665E+01, 0.27724E+01, & + 0.27782E+01, 0.27841E+01, 0.27899E+01, 0.27957E+01, 0.28015E+01, & + 0.28073E+01, 0.28131E+01, 0.28189E+01, 0.28247E+01, 0.28304E+01, & + 0.28362E+01, 0.28419E+01, 0.28476E+01, 0.28533E+01, 0.28590E+01/ + + DATA (BNC11M (I),I=401,500)/ & + 0.28647E+01, 0.28704E+01, 0.28761E+01, 0.28817E+01, 0.28874E+01, & + 0.28930E+01, 0.28987E+01, 0.29043E+01, 0.29099E+01, 0.29155E+01, & + 0.29211E+01, 0.29267E+01, 0.29323E+01, 0.29378E+01, 0.29434E+01, & + 0.29489E+01, 0.29544E+01, 0.29600E+01, 0.29655E+01, 0.29710E+01, & + 0.29765E+01, 0.29820E+01, 0.29874E+01, 0.29929E+01, 0.29984E+01, & + 0.30038E+01, 0.30093E+01, 0.30147E+01, 0.30201E+01, 0.30255E+01, & + 0.30309E+01, 0.30363E+01, 0.30417E+01, 0.30471E+01, 0.30524E+01, & + 0.30578E+01, 0.30631E+01, 0.30685E+01, 0.30738E+01, 0.30791E+01, & + 0.30844E+01, 0.30897E+01, 0.30950E+01, 0.31003E+01, 0.31056E+01, & + 0.31108E+01, 0.31161E+01, 0.31213E+01, 0.31266E+01, 0.31318E+01, & + 0.31370E+01, 0.31422E+01, 0.31474E+01, 0.31526E+01, 0.31578E+01, & + 0.31630E+01, 0.31681E+01, 0.31733E+01, 0.31785E+01, 0.31836E+01, & + 0.31887E+01, 0.31939E+01, 0.31990E+01, 0.32041E+01, 0.32092E+01, & + 0.32143E+01, 0.32194E+01, 0.32244E+01, 0.32295E+01, 0.32345E+01, & + 0.32396E+01, 0.32446E+01, 0.32497E+01, 0.32547E+01, 0.32597E+01, & + 0.32647E+01, 0.32697E+01, 0.32747E+01, 0.32797E+01, 0.32847E+01, & + 0.32896E+01, 0.32946E+01, 0.32995E+01, 0.33045E+01, 0.33094E+01, & + 0.33144E+01, 0.33193E+01, 0.33242E+01, 0.33291E+01, 0.33340E+01, & + 0.33389E+01, 0.33438E+01, 0.33486E+01, 0.33535E+01, 0.33583E+01, & + 0.33632E+01, 0.33680E+01, 0.33729E+01, 0.33777E+01, 0.33825E+01/ + + DATA (BNC11M (I),I=501,600)/ & + 0.33873E+01, 0.33921E+01, 0.33969E+01, 0.34017E+01, 0.34065E+01, & + 0.34113E+01, 0.34160E+01, 0.34208E+01, 0.34255E+01, 0.34303E+01, & + 0.34350E+01, 0.34398E+01, 0.34445E+01, 0.34492E+01, 0.34539E+01, & + 0.34586E+01, 0.34633E+01, 0.34680E+01, 0.34726E+01, 0.34773E+01, & + 0.34820E+01, 0.34866E+01, 0.34913E+01, 0.34959E+01, 0.35006E+01, & + 0.35052E+01, 0.35098E+01, 0.35144E+01, 0.35190E+01, 0.35236E+01, & + 0.35282E+01, 0.35328E+01, 0.35374E+01, 0.35419E+01, 0.35465E+01, & + 0.35511E+01, 0.35556E+01, 0.35602E+01, 0.35647E+01, 0.35692E+01, & + 0.35737E+01, 0.35783E+01, 0.35828E+01, 0.35873E+01, 0.35918E+01, & + 0.35963E+01, 0.36007E+01, 0.36052E+01, 0.36097E+01, 0.36141E+01, & + 0.36186E+01, 0.36230E+01, 0.36275E+01, 0.36319E+01, 0.36363E+01, & + 0.36408E+01, 0.36452E+01, 0.36496E+01, 0.36540E+01, 0.36584E+01, & + 0.36628E+01, 0.36672E+01, 0.36715E+01, 0.36759E+01, 0.36803E+01, & + 0.36846E+01, 0.36890E+01, 0.36933E+01, 0.36977E+01, 0.37020E+01, & + 0.37063E+01, 0.37106E+01, 0.37150E+01, 0.37193E+01, 0.37236E+01, & + 0.37279E+01, 0.37321E+01, 0.37364E+01, 0.37407E+01, 0.37450E+01, & + 0.37492E+01, 0.37535E+01, 0.37577E+01, 0.37620E+01, 0.37662E+01, & + 0.37704E+01, 0.37747E+01, 0.37789E+01, 0.37831E+01, 0.37873E+01, & + 0.37915E+01, 0.37957E+01, 0.37999E+01, 0.38041E+01, 0.38083E+01, & + 0.38124E+01, 0.38166E+01, 0.38208E+01, 0.38249E+01, 0.38404E+01/ + + DATA (BNC11M (I),I=601,700)/ & + 0.38743E+01, 0.39148E+01, 0.39548E+01, 0.39942E+01, 0.40331E+01, & + 0.40715E+01, 0.41094E+01, 0.41467E+01, 0.41836E+01, 0.42200E+01, & + 0.42560E+01, 0.42915E+01, 0.43265E+01, 0.43611E+01, 0.43953E+01, & + 0.44291E+01, 0.44624E+01, 0.44954E+01, 0.45280E+01, 0.45601E+01, & + 0.45919E+01, 0.46234E+01, 0.46544E+01, 0.46852E+01, 0.47155E+01, & + 0.47456E+01, 0.47752E+01, 0.48046E+01, 0.48336E+01, 0.48624E+01, & + 0.48908E+01, 0.49189E+01, 0.49467E+01, 0.49742E+01, 0.50014E+01, & + 0.50283E+01, 0.50550E+01, 0.50814E+01, 0.51075E+01, 0.51333E+01, & + 0.51589E+01, 0.51842E+01, 0.52093E+01, 0.52341E+01, 0.52587E+01, & + 0.52830E+01, 0.53071E+01, 0.53309E+01, 0.53546E+01, 0.53780E+01, & + 0.54011E+01, 0.54241E+01, 0.54468E+01, 0.54694E+01, 0.54917E+01, & + 0.55138E+01, 0.55357E+01, 0.55574E+01, 0.55789E+01, 0.56002E+01, & + 0.56214E+01, 0.56423E+01, 0.56630E+01, 0.56836E+01, 0.57040E+01, & + 0.57242E+01, 0.57442E+01, 0.57640E+01, 0.57837E+01, 0.58032E+01, & + 0.58226E+01, 0.58417E+01, 0.58608E+01, 0.58796E+01, 0.58983E+01, & + 0.59168E+01, 0.59352E+01, 0.59534E+01, 0.59715E+01, 0.59894E+01, & + 0.60072E+01, 0.60248E+01, 0.60423E+01, 0.60597E+01, 0.60769E+01, & + 0.60940E+01, 0.61109E+01, 0.61277E+01, 0.61444E+01, 0.61609E+01, & + 0.61773E+01, 0.61936E+01, 0.62097E+01, 0.62257E+01, 0.62416E+01, & + 0.62574E+01, 0.62731E+01, 0.62886E+01, 0.63040E+01, 0.63193E+01/ + + DATA (BNC11M(I),I=701,741)/ & + 0.63345E+01, 0.63496E+01, 0.63645E+01, 0.63794E+01, 0.63941E+01, & + 0.64087E+01, 0.64232E+01, 0.64376E+01, 0.64519E+01, 0.64661E+01, & + 0.64802E+01, 0.64942E+01, 0.65081E+01, 0.65218E+01, 0.65355E+01, & + 0.65491E+01, 0.65626E+01, 0.65760E+01, 0.65893E+01, 0.66025E+01, & + 0.66156E+01, 0.66286E+01, 0.66415E+01, 0.66543E+01, 0.66671E+01, & + 0.66797E+01, 0.66923E+01, 0.67047E+01, 0.67171E+01, 0.67294E+01, & + 0.67416E+01, 0.67538E+01, 0.67658E+01, 0.67778E+01, 0.67897E+01, & + 0.68015E+01, 0.68132E+01, 0.68248E+01, 0.68364E+01, 0.68479E+01, & + 0.68593E+01 & + / +! +! *** NaHSO4 +! + DATA (BNC12M (I),I= 1,100)/ & + -0.54197E-01,-0.94863E-01,-0.12098E+00,-0.13730E+00,-0.14889E+00, & + -0.15763E+00,-0.16443E+00,-0.16981E+00,-0.17410E+00,-0.17752E+00, & + -0.18023E+00,-0.18234E+00,-0.18394E+00,-0.18510E+00,-0.18586E+00, & + -0.18627E+00,-0.18636E+00,-0.18617E+00,-0.18572E+00,-0.18502E+00, & + -0.18410E+00,-0.18297E+00,-0.18165E+00,-0.18014E+00,-0.17847E+00, & + -0.17662E+00,-0.17463E+00,-0.17249E+00,-0.17021E+00,-0.16779E+00, & + -0.16525E+00,-0.16259E+00,-0.15982E+00,-0.15693E+00,-0.15394E+00, & + -0.15084E+00,-0.14765E+00,-0.14437E+00,-0.14099E+00,-0.13753E+00, & + -0.13399E+00,-0.13037E+00,-0.12667E+00,-0.12290E+00,-0.11906E+00, & + -0.11516E+00,-0.11118E+00,-0.10715E+00,-0.10306E+00,-0.98908E-01, & + -0.94703E-01,-0.90443E-01,-0.86133E-01,-0.81773E-01,-0.77365E-01, & + -0.72910E-01,-0.68410E-01,-0.63866E-01,-0.59280E-01,-0.54651E-01, & + -0.49983E-01,-0.45274E-01,-0.40525E-01,-0.35739E-01,-0.30914E-01, & + -0.26051E-01,-0.21151E-01,-0.16213E-01,-0.11239E-01,-0.62276E-02, & + -0.11793E-02, 0.39061E-02, 0.90287E-02, 0.14188E-01, 0.19386E-01, & + 0.24620E-01, 0.29893E-01, 0.35204E-01, 0.40552E-01, 0.45940E-01, & + 0.51365E-01, 0.56830E-01, 0.62333E-01, 0.67875E-01, 0.73455E-01, & + 0.79074E-01, 0.84733E-01, 0.90428E-01, 0.96163E-01, 0.10193E+00, & + 0.10774E+00, 0.11359E+00, 0.11947E+00, 0.12539E+00, 0.13134E+00, & + 0.13732E+00, 0.14334E+00, 0.14939E+00, 0.15547E+00, 0.16158E+00/ + + DATA (BNC12M (I),I=101,200)/ & + 0.16772E+00, 0.17388E+00, 0.18007E+00, 0.18628E+00, 0.19252E+00, & + 0.19878E+00, 0.20506E+00, 0.21136E+00, 0.21768E+00, 0.22401E+00, & + 0.23036E+00, 0.23672E+00, 0.24309E+00, 0.24947E+00, 0.25587E+00, & + 0.26227E+00, 0.26867E+00, 0.27509E+00, 0.28150E+00, 0.28793E+00, & + 0.29372E+00, 0.30022E+00, 0.30671E+00, 0.31319E+00, 0.31967E+00, & + 0.32613E+00, 0.33259E+00, 0.33904E+00, 0.34548E+00, 0.35192E+00, & + 0.35834E+00, 0.36475E+00, 0.37116E+00, 0.37755E+00, 0.38393E+00, & + 0.39031E+00, 0.39667E+00, 0.40302E+00, 0.40936E+00, 0.41569E+00, & + 0.42201E+00, 0.42832E+00, 0.43461E+00, 0.44090E+00, 0.44717E+00, & + 0.45343E+00, 0.45968E+00, 0.46592E+00, 0.47214E+00, 0.47835E+00, & + 0.48455E+00, 0.49074E+00, 0.49691E+00, 0.50307E+00, 0.50922E+00, & + 0.51536E+00, 0.52148E+00, 0.52759E+00, 0.53369E+00, 0.53978E+00, & + 0.54585E+00, 0.55191E+00, 0.55795E+00, 0.56398E+00, 0.57000E+00, & + 0.57601E+00, 0.58200E+00, 0.58798E+00, 0.59395E+00, 0.59990E+00, & + 0.60584E+00, 0.61177E+00, 0.61768E+00, 0.62358E+00, 0.62947E+00, & + 0.63534E+00, 0.64120E+00, 0.64705E+00, 0.65288E+00, 0.65870E+00, & + 0.66451E+00, 0.67030E+00, 0.67608E+00, 0.68185E+00, 0.68761E+00, & + 0.69335E+00, 0.69907E+00, 0.70479E+00, 0.71049E+00, 0.71618E+00, & + 0.72185E+00, 0.72752E+00, 0.73317E+00, 0.73880E+00, 0.74442E+00, & + 0.75003E+00, 0.75563E+00, 0.76122E+00, 0.76679E+00, 0.77235E+00/ + + DATA (BNC12M (I),I=201,300)/ & + 0.77789E+00, 0.78342E+00, 0.78894E+00, 0.79445E+00, 0.79995E+00, & + 0.80543E+00, 0.81090E+00, 0.81635E+00, 0.82180E+00, 0.82723E+00, & + 0.83265E+00, 0.83806E+00, 0.84345E+00, 0.84883E+00, 0.85420E+00, & + 0.85956E+00, 0.86490E+00, 0.87023E+00, 0.87556E+00, 0.88086E+00, & + 0.88616E+00, 0.89144E+00, 0.89671E+00, 0.90197E+00, 0.90722E+00, & + 0.91246E+00, 0.91768E+00, 0.92289E+00, 0.92809E+00, 0.93328E+00, & + 0.93846E+00, 0.94362E+00, 0.94878E+00, 0.95392E+00, 0.95905E+00, & + 0.96417E+00, 0.96928E+00, 0.97437E+00, 0.97946E+00, 0.98453E+00, & + 0.98959E+00, 0.99464E+00, 0.99968E+00, 0.10047E+01, 0.10097E+01, & + 0.10147E+01, 0.10197E+01, 0.10247E+01, 0.10297E+01, 0.10346E+01, & + 0.10396E+01, 0.10445E+01, 0.10495E+01, 0.10544E+01, 0.10593E+01, & + 0.10642E+01, 0.10691E+01, 0.10739E+01, 0.10788E+01, 0.10836E+01, & + 0.10885E+01, 0.10933E+01, 0.10981E+01, 0.11030E+01, 0.11078E+01, & + 0.11125E+01, 0.11173E+01, 0.11221E+01, 0.11269E+01, 0.11316E+01, & + 0.11363E+01, 0.11411E+01, 0.11458E+01, 0.11505E+01, 0.11552E+01, & + 0.11599E+01, 0.11646E+01, 0.11692E+01, 0.11739E+01, 0.11785E+01, & + 0.11832E+01, 0.11878E+01, 0.11924E+01, 0.11970E+01, 0.12016E+01, & + 0.12062E+01, 0.12108E+01, 0.12154E+01, 0.12199E+01, 0.12245E+01, & + 0.12290E+01, 0.12335E+01, 0.12381E+01, 0.12426E+01, 0.12471E+01, & + 0.12516E+01, 0.12561E+01, 0.12605E+01, 0.12650E+01, 0.12695E+01/ + + DATA (BNC12M (I),I=301,400)/ & + 0.12739E+01, 0.12784E+01, 0.12828E+01, 0.12872E+01, 0.12916E+01, & + 0.12960E+01, 0.13004E+01, 0.13048E+01, 0.13092E+01, 0.13135E+01, & + 0.13179E+01, 0.13222E+01, 0.13266E+01, 0.13309E+01, 0.13352E+01, & + 0.13396E+01, 0.13439E+01, 0.13482E+01, 0.13524E+01, 0.13567E+01, & + 0.13610E+01, 0.13653E+01, 0.13695E+01, 0.13738E+01, 0.13780E+01, & + 0.13822E+01, 0.13864E+01, 0.13907E+01, 0.13949E+01, 0.13990E+01, & + 0.14032E+01, 0.14074E+01, 0.14116E+01, 0.14157E+01, 0.14199E+01, & + 0.14240E+01, 0.14282E+01, 0.14323E+01, 0.14364E+01, 0.14405E+01, & + 0.14447E+01, 0.14487E+01, 0.14528E+01, 0.14569E+01, 0.14610E+01, & + 0.14651E+01, 0.14691E+01, 0.14732E+01, 0.14772E+01, 0.14812E+01, & + 0.14853E+01, 0.14893E+01, 0.14933E+01, 0.14973E+01, 0.15013E+01, & + 0.15053E+01, 0.15093E+01, 0.15132E+01, 0.15172E+01, 0.15212E+01, & + 0.15251E+01, 0.15290E+01, 0.15330E+01, 0.15369E+01, 0.15408E+01, & + 0.15447E+01, 0.15486E+01, 0.15525E+01, 0.15564E+01, 0.15603E+01, & + 0.15642E+01, 0.15681E+01, 0.15719E+01, 0.15758E+01, 0.15796E+01, & + 0.15835E+01, 0.15873E+01, 0.15911E+01, 0.15949E+01, 0.15988E+01, & + 0.16026E+01, 0.16064E+01, 0.16101E+01, 0.16139E+01, 0.16177E+01, & + 0.16215E+01, 0.16252E+01, 0.16290E+01, 0.16327E+01, 0.16365E+01, & + 0.16402E+01, 0.16439E+01, 0.16477E+01, 0.16514E+01, 0.16551E+01, & + 0.16588E+01, 0.16625E+01, 0.16662E+01, 0.16699E+01, 0.16735E+01/ + + DATA (BNC12M (I),I=401,500)/ & + 0.16772E+01, 0.16809E+01, 0.16845E+01, 0.16882E+01, 0.16918E+01, & + 0.16954E+01, 0.16991E+01, 0.17027E+01, 0.17063E+01, 0.17099E+01, & + 0.17135E+01, 0.17171E+01, 0.17207E+01, 0.17243E+01, 0.17279E+01, & + 0.17314E+01, 0.17350E+01, 0.17386E+01, 0.17421E+01, 0.17456E+01, & + 0.17492E+01, 0.17527E+01, 0.17562E+01, 0.17598E+01, 0.17633E+01, & + 0.17668E+01, 0.17703E+01, 0.17738E+01, 0.17773E+01, 0.17808E+01, & + 0.17842E+01, 0.17877E+01, 0.17912E+01, 0.17946E+01, 0.17981E+01, & + 0.18015E+01, 0.18050E+01, 0.18084E+01, 0.18118E+01, 0.18153E+01, & + 0.18187E+01, 0.18221E+01, 0.18255E+01, 0.18289E+01, 0.18323E+01, & + 0.18357E+01, 0.18391E+01, 0.18424E+01, 0.18458E+01, 0.18492E+01, & + 0.18525E+01, 0.18559E+01, 0.18592E+01, 0.18626E+01, 0.18659E+01, & + 0.18693E+01, 0.18726E+01, 0.18759E+01, 0.18792E+01, 0.18825E+01, & + 0.18858E+01, 0.18891E+01, 0.18924E+01, 0.18957E+01, 0.18990E+01, & + 0.19023E+01, 0.19055E+01, 0.19088E+01, 0.19121E+01, 0.19153E+01, & + 0.19186E+01, 0.19218E+01, 0.19250E+01, 0.19283E+01, 0.19315E+01, & + 0.19347E+01, 0.19379E+01, 0.19411E+01, 0.19443E+01, 0.19475E+01, & + 0.19507E+01, 0.19539E+01, 0.19571E+01, 0.19603E+01, 0.19635E+01, & + 0.19666E+01, 0.19698E+01, 0.19730E+01, 0.19761E+01, 0.19793E+01, & + 0.19824E+01, 0.19855E+01, 0.19887E+01, 0.19918E+01, 0.19949E+01, & + 0.19980E+01, 0.20012E+01, 0.20043E+01, 0.20074E+01, 0.20105E+01/ + + DATA (BNC12M (I),I=501,600)/ & + 0.20136E+01, 0.20166E+01, 0.20197E+01, 0.20228E+01, 0.20259E+01, & + 0.20289E+01, 0.20320E+01, 0.20351E+01, 0.20381E+01, 0.20412E+01, & + 0.20442E+01, 0.20472E+01, 0.20503E+01, 0.20533E+01, 0.20563E+01, & + 0.20593E+01, 0.20624E+01, 0.20654E+01, 0.20684E+01, 0.20714E+01, & + 0.20744E+01, 0.20774E+01, 0.20803E+01, 0.20833E+01, 0.20863E+01, & + 0.20893E+01, 0.20922E+01, 0.20952E+01, 0.20982E+01, 0.21011E+01, & + 0.21041E+01, 0.21070E+01, 0.21099E+01, 0.21129E+01, 0.21158E+01, & + 0.21187E+01, 0.21217E+01, 0.21246E+01, 0.21275E+01, 0.21304E+01, & + 0.21333E+01, 0.21362E+01, 0.21391E+01, 0.21420E+01, 0.21449E+01, & + 0.21477E+01, 0.21506E+01, 0.21535E+01, 0.21564E+01, 0.21592E+01, & + 0.21621E+01, 0.21649E+01, 0.21678E+01, 0.21706E+01, 0.21735E+01, & + 0.21763E+01, 0.21791E+01, 0.21820E+01, 0.21848E+01, 0.21876E+01, & + 0.21904E+01, 0.21932E+01, 0.21960E+01, 0.21988E+01, 0.22016E+01, & + 0.22044E+01, 0.22072E+01, 0.22100E+01, 0.22128E+01, 0.22156E+01, & + 0.22183E+01, 0.22211E+01, 0.22239E+01, 0.22266E+01, 0.22294E+01, & + 0.22321E+01, 0.22349E+01, 0.22376E+01, 0.22404E+01, 0.22431E+01, & + 0.22458E+01, 0.22486E+01, 0.22513E+01, 0.22540E+01, 0.22567E+01, & + 0.22594E+01, 0.22621E+01, 0.22648E+01, 0.22675E+01, 0.22702E+01, & + 0.22729E+01, 0.22756E+01, 0.22783E+01, 0.22810E+01, 0.22836E+01, & + 0.22863E+01, 0.22890E+01, 0.22916E+01, 0.22943E+01, 0.23042E+01/ + + DATA (BNC12M (I),I=601,700)/ & + 0.23259E+01, 0.23518E+01, 0.23774E+01, 0.24026E+01, 0.24274E+01, & + 0.24519E+01, 0.24761E+01, 0.24999E+01, 0.25234E+01, 0.25466E+01, & + 0.25694E+01, 0.25920E+01, 0.26142E+01, 0.26362E+01, 0.26579E+01, & + 0.26793E+01, 0.27004E+01, 0.27213E+01, 0.27419E+01, 0.27622E+01, & + 0.27823E+01, 0.28022E+01, 0.28218E+01, 0.28411E+01, 0.28602E+01, & + 0.28791E+01, 0.28978E+01, 0.29162E+01, 0.29344E+01, 0.29524E+01, & + 0.29702E+01, 0.29878E+01, 0.30052E+01, 0.30224E+01, 0.30393E+01, & + 0.30561E+01, 0.30727E+01, 0.30891E+01, 0.31054E+01, 0.31214E+01, & + 0.31373E+01, 0.31530E+01, 0.31685E+01, 0.31838E+01, 0.31990E+01, & + 0.32140E+01, 0.32289E+01, 0.32436E+01, 0.32581E+01, 0.32725E+01, & + 0.32868E+01, 0.33008E+01, 0.33148E+01, 0.33286E+01, 0.33422E+01, & + 0.33557E+01, 0.33691E+01, 0.33823E+01, 0.33954E+01, 0.34084E+01, & + 0.34212E+01, 0.34339E+01, 0.34465E+01, 0.34589E+01, 0.34712E+01, & + 0.34834E+01, 0.34955E+01, 0.35075E+01, 0.35193E+01, 0.35310E+01, & + 0.35426E+01, 0.35541E+01, 0.35655E+01, 0.35768E+01, 0.35880E+01, & + 0.35990E+01, 0.36100E+01, 0.36208E+01, 0.36316E+01, 0.36422E+01, & + 0.36527E+01, 0.36632E+01, 0.36735E+01, 0.36838E+01, 0.36939E+01, & + 0.37040E+01, 0.37139E+01, 0.37238E+01, 0.37336E+01, 0.37432E+01, & + 0.37528E+01, 0.37623E+01, 0.37718E+01, 0.37811E+01, 0.37903E+01, & + 0.37995E+01, 0.38086E+01, 0.38176E+01, 0.38265E+01, 0.38353E+01/ + + DATA (BNC12M(I),I=701,741)/ & + 0.38441E+01, 0.38528E+01, 0.38614E+01, 0.38699E+01, 0.38783E+01, & + 0.38867E+01, 0.38950E+01, 0.39032E+01, 0.39113E+01, 0.39194E+01, & + 0.39274E+01, 0.39353E+01, 0.39432E+01, 0.39510E+01, 0.39587E+01, & + 0.39664E+01, 0.39740E+01, 0.39815E+01, 0.39889E+01, 0.39963E+01, & + 0.40037E+01, 0.40109E+01, 0.40181E+01, 0.40253E+01, 0.40323E+01, & + 0.40393E+01, 0.40463E+01, 0.40532E+01, 0.40600E+01, 0.40668E+01, & + 0.40735E+01, 0.40802E+01, 0.40867E+01, 0.40933E+01, 0.40998E+01, & + 0.41062E+01, 0.41126E+01, 0.41189E+01, 0.41252E+01, 0.41314E+01, & + 0.41375E+01 & + / +! +! *** (NH4)3H(SO4)2 +! + DATA (BNC13M (I),I= 1,100)/ & + -0.90602E-01,-0.16542E+00,-0.21853E+00,-0.25500E+00,-0.28333E+00, & + -0.30670E+00,-0.32669E+00,-0.34420E+00,-0.35982E+00,-0.37393E+00, & + -0.38682E+00,-0.39867E+00,-0.40966E+00,-0.41990E+00,-0.42949E+00, & + -0.43851E+00,-0.44702E+00,-0.45507E+00,-0.46272E+00,-0.46998E+00, & + -0.47691E+00,-0.48352E+00,-0.48985E+00,-0.49591E+00,-0.50172E+00, & + -0.50730E+00,-0.51266E+00,-0.51782E+00,-0.52278E+00,-0.52757E+00, & + -0.53219E+00,-0.53664E+00,-0.54094E+00,-0.54510E+00,-0.54912E+00, & + -0.55300E+00,-0.55676E+00,-0.56040E+00,-0.56392E+00,-0.56733E+00, & + -0.57064E+00,-0.57384E+00,-0.57695E+00,-0.57996E+00,-0.58289E+00, & + -0.58572E+00,-0.58848E+00,-0.59115E+00,-0.59374E+00,-0.59626E+00, & + -0.59871E+00,-0.60109E+00,-0.60340E+00,-0.60565E+00,-0.60784E+00, & + -0.60996E+00,-0.61203E+00,-0.61404E+00,-0.61599E+00,-0.61790E+00, & + -0.61975E+00,-0.62155E+00,-0.62331E+00,-0.62502E+00,-0.62668E+00, & + -0.62830E+00,-0.62988E+00,-0.63142E+00,-0.63291E+00,-0.63437E+00, & + -0.63579E+00,-0.63718E+00,-0.63852E+00,-0.63984E+00,-0.64111E+00, & + -0.64236E+00,-0.64357E+00,-0.64475E+00,-0.64590E+00,-0.64702E+00, & + -0.64811E+00,-0.64917E+00,-0.65020E+00,-0.65120E+00,-0.65217E+00, & + -0.65312E+00,-0.65404E+00,-0.65494E+00,-0.65581E+00,-0.65666E+00, & + -0.65748E+00,-0.65828E+00,-0.65905E+00,-0.65980E+00,-0.66053E+00, & + -0.66124E+00,-0.66193E+00,-0.66260E+00,-0.66324E+00,-0.66387E+00/ + + DATA (BNC13M (I),I=101,200)/ & + -0.66448E+00,-0.66507E+00,-0.66564E+00,-0.66620E+00,-0.66674E+00, & + -0.66726E+00,-0.66777E+00,-0.66827E+00,-0.66875E+00,-0.66921E+00, & + -0.66966E+00,-0.67010E+00,-0.67053E+00,-0.67095E+00,-0.67135E+00, & + -0.67175E+00,-0.67213E+00,-0.67250E+00,-0.67287E+00,-0.67322E+00, & + -0.67369E+00,-0.67401E+00,-0.67433E+00,-0.67464E+00,-0.67495E+00, & + -0.67525E+00,-0.67554E+00,-0.67583E+00,-0.67611E+00,-0.67639E+00, & + -0.67667E+00,-0.67694E+00,-0.67720E+00,-0.67746E+00,-0.67772E+00, & + -0.67797E+00,-0.67822E+00,-0.67847E+00,-0.67871E+00,-0.67895E+00, & + -0.67919E+00,-0.67942E+00,-0.67965E+00,-0.67988E+00,-0.68011E+00, & + -0.68033E+00,-0.68055E+00,-0.68077E+00,-0.68099E+00,-0.68120E+00, & + -0.68141E+00,-0.68162E+00,-0.68183E+00,-0.68204E+00,-0.68224E+00, & + -0.68245E+00,-0.68265E+00,-0.68285E+00,-0.68305E+00,-0.68325E+00, & + -0.68345E+00,-0.68365E+00,-0.68384E+00,-0.68404E+00,-0.68423E+00, & + -0.68442E+00,-0.68462E+00,-0.68481E+00,-0.68500E+00,-0.68519E+00, & + -0.68538E+00,-0.68557E+00,-0.68576E+00,-0.68595E+00,-0.68614E+00, & + -0.68633E+00,-0.68651E+00,-0.68670E+00,-0.68689E+00,-0.68708E+00, & + -0.68727E+00,-0.68745E+00,-0.68764E+00,-0.68783E+00,-0.68802E+00, & + -0.68820E+00,-0.68839E+00,-0.68858E+00,-0.68877E+00,-0.68896E+00, & + -0.68914E+00,-0.68933E+00,-0.68952E+00,-0.68971E+00,-0.68990E+00, & + -0.69009E+00,-0.69028E+00,-0.69047E+00,-0.69066E+00,-0.69085E+00/ + + DATA (BNC13M (I),I=201,300)/ & + -0.69105E+00,-0.69124E+00,-0.69143E+00,-0.69162E+00,-0.69182E+00, & + -0.69201E+00,-0.69221E+00,-0.69240E+00,-0.69260E+00,-0.69280E+00, & + -0.69299E+00,-0.69319E+00,-0.69339E+00,-0.69359E+00,-0.69379E+00, & + -0.69399E+00,-0.69419E+00,-0.69439E+00,-0.69459E+00,-0.69480E+00, & + -0.69500E+00,-0.69520E+00,-0.69541E+00,-0.69561E+00,-0.69582E+00, & + -0.69603E+00,-0.69624E+00,-0.69644E+00,-0.69665E+00,-0.69686E+00, & + -0.69707E+00,-0.69729E+00,-0.69750E+00,-0.69771E+00,-0.69793E+00, & + -0.69814E+00,-0.69836E+00,-0.69857E+00,-0.69879E+00,-0.69901E+00, & + -0.69923E+00,-0.69945E+00,-0.69967E+00,-0.69989E+00,-0.70011E+00, & + -0.70034E+00,-0.70056E+00,-0.70078E+00,-0.70101E+00,-0.70124E+00, & + -0.70146E+00,-0.70169E+00,-0.70192E+00,-0.70215E+00,-0.70238E+00, & + -0.70261E+00,-0.70285E+00,-0.70308E+00,-0.70331E+00,-0.70355E+00, & + -0.70379E+00,-0.70402E+00,-0.70426E+00,-0.70450E+00,-0.70474E+00, & + -0.70498E+00,-0.70522E+00,-0.70546E+00,-0.70571E+00,-0.70595E+00, & + -0.70619E+00,-0.70644E+00,-0.70669E+00,-0.70693E+00,-0.70718E+00, & + -0.70743E+00,-0.70768E+00,-0.70793E+00,-0.70818E+00,-0.70844E+00, & + -0.70869E+00,-0.70895E+00,-0.70920E+00,-0.70946E+00,-0.70971E+00, & + -0.70997E+00,-0.71023E+00,-0.71049E+00,-0.71075E+00,-0.71101E+00, & + -0.71128E+00,-0.71154E+00,-0.71180E+00,-0.71207E+00,-0.71234E+00, & + -0.71260E+00,-0.71287E+00,-0.71314E+00,-0.71341E+00,-0.71368E+00/ + + DATA (BNC13M (I),I=301,400)/ & + -0.71395E+00,-0.71422E+00,-0.71450E+00,-0.71477E+00,-0.71505E+00, & + -0.71532E+00,-0.71560E+00,-0.71588E+00,-0.71615E+00,-0.71643E+00, & + -0.71671E+00,-0.71699E+00,-0.71728E+00,-0.71756E+00,-0.71784E+00, & + -0.71813E+00,-0.71841E+00,-0.71870E+00,-0.71899E+00,-0.71927E+00, & + -0.71956E+00,-0.71985E+00,-0.72014E+00,-0.72043E+00,-0.72073E+00, & + -0.72102E+00,-0.72131E+00,-0.72161E+00,-0.72190E+00,-0.72220E+00, & + -0.72250E+00,-0.72280E+00,-0.72310E+00,-0.72340E+00,-0.72370E+00, & + -0.72400E+00,-0.72430E+00,-0.72460E+00,-0.72491E+00,-0.72521E+00, & + -0.72552E+00,-0.72583E+00,-0.72613E+00,-0.72644E+00,-0.72675E+00, & + -0.72706E+00,-0.72737E+00,-0.72768E+00,-0.72799E+00,-0.72831E+00, & + -0.72862E+00,-0.72894E+00,-0.72925E+00,-0.72957E+00,-0.72989E+00, & + -0.73020E+00,-0.73052E+00,-0.73084E+00,-0.73116E+00,-0.73149E+00, & + -0.73181E+00,-0.73213E+00,-0.73245E+00,-0.73278E+00,-0.73310E+00, & + -0.73343E+00,-0.73376E+00,-0.73409E+00,-0.73441E+00,-0.73474E+00, & + -0.73507E+00,-0.73540E+00,-0.73574E+00,-0.73607E+00,-0.73640E+00, & + -0.73674E+00,-0.73707E+00,-0.73741E+00,-0.73774E+00,-0.73808E+00, & + -0.73842E+00,-0.73876E+00,-0.73910E+00,-0.73944E+00,-0.73978E+00, & + -0.74012E+00,-0.74046E+00,-0.74081E+00,-0.74115E+00,-0.74150E+00, & + -0.74184E+00,-0.74219E+00,-0.74253E+00,-0.74288E+00,-0.74323E+00, & + -0.74358E+00,-0.74393E+00,-0.74428E+00,-0.74463E+00,-0.74499E+00/ + + DATA (BNC13M (I),I=401,500)/ & + -0.74534E+00,-0.74569E+00,-0.74605E+00,-0.74640E+00,-0.74676E+00, & + -0.74712E+00,-0.74747E+00,-0.74783E+00,-0.74819E+00,-0.74855E+00, & + -0.74891E+00,-0.74927E+00,-0.74964E+00,-0.75000E+00,-0.75036E+00, & + -0.75073E+00,-0.75109E+00,-0.75146E+00,-0.75182E+00,-0.75219E+00, & + -0.75256E+00,-0.75293E+00,-0.75330E+00,-0.75367E+00,-0.75404E+00, & + -0.75441E+00,-0.75478E+00,-0.75515E+00,-0.75553E+00,-0.75590E+00, & + -0.75627E+00,-0.75665E+00,-0.75703E+00,-0.75740E+00,-0.75778E+00, & + -0.75816E+00,-0.75854E+00,-0.75892E+00,-0.75930E+00,-0.75968E+00, & + -0.76006E+00,-0.76044E+00,-0.76083E+00,-0.76121E+00,-0.76160E+00, & + -0.76198E+00,-0.76237E+00,-0.76275E+00,-0.76314E+00,-0.76353E+00, & + -0.76392E+00,-0.76431E+00,-0.76470E+00,-0.76509E+00,-0.76548E+00, & + -0.76587E+00,-0.76626E+00,-0.76666E+00,-0.76705E+00,-0.76744E+00, & + -0.76784E+00,-0.76824E+00,-0.76863E+00,-0.76903E+00,-0.76943E+00, & + -0.76983E+00,-0.77023E+00,-0.77063E+00,-0.77103E+00,-0.77143E+00, & + -0.77183E+00,-0.77223E+00,-0.77263E+00,-0.77304E+00,-0.77344E+00, & + -0.77385E+00,-0.77425E+00,-0.77466E+00,-0.77507E+00,-0.77547E+00, & + -0.77588E+00,-0.77629E+00,-0.77670E+00,-0.77711E+00,-0.77752E+00, & + -0.77793E+00,-0.77834E+00,-0.77876E+00,-0.77917E+00,-0.77958E+00, & + -0.78000E+00,-0.78041E+00,-0.78083E+00,-0.78124E+00,-0.78166E+00, & + -0.78208E+00,-0.78249E+00,-0.78291E+00,-0.78333E+00,-0.78375E+00/ + + DATA (BNC13M (I),I=501,600)/ & + -0.78417E+00,-0.78459E+00,-0.78502E+00,-0.78544E+00,-0.78586E+00, & + -0.78628E+00,-0.78671E+00,-0.78713E+00,-0.78756E+00,-0.78798E+00, & + -0.78841E+00,-0.78884E+00,-0.78926E+00,-0.78969E+00,-0.79012E+00, & + -0.79055E+00,-0.79098E+00,-0.79141E+00,-0.79184E+00,-0.79227E+00, & + -0.79271E+00,-0.79314E+00,-0.79357E+00,-0.79401E+00,-0.79444E+00, & + -0.79488E+00,-0.79531E+00,-0.79575E+00,-0.79619E+00,-0.79662E+00, & + -0.79706E+00,-0.79750E+00,-0.79794E+00,-0.79838E+00,-0.79882E+00, & + -0.79926E+00,-0.79970E+00,-0.80014E+00,-0.80058E+00,-0.80103E+00, & + -0.80147E+00,-0.80192E+00,-0.80236E+00,-0.80281E+00,-0.80325E+00, & + -0.80370E+00,-0.80414E+00,-0.80459E+00,-0.80504E+00,-0.80549E+00, & + -0.80594E+00,-0.80639E+00,-0.80684E+00,-0.80729E+00,-0.80774E+00, & + -0.80819E+00,-0.80864E+00,-0.80910E+00,-0.80955E+00,-0.81000E+00, & + -0.81046E+00,-0.81091E+00,-0.81137E+00,-0.81182E+00,-0.81228E+00, & + -0.81274E+00,-0.81320E+00,-0.81365E+00,-0.81411E+00,-0.81457E+00, & + -0.81503E+00,-0.81549E+00,-0.81595E+00,-0.81641E+00,-0.81688E+00, & + -0.81734E+00,-0.81780E+00,-0.81826E+00,-0.81873E+00,-0.81919E+00, & + -0.81966E+00,-0.82012E+00,-0.82059E+00,-0.82105E+00,-0.82152E+00, & + -0.82199E+00,-0.82246E+00,-0.82293E+00,-0.82339E+00,-0.82386E+00, & + -0.82433E+00,-0.82480E+00,-0.82528E+00,-0.82575E+00,-0.82622E+00, & + -0.82669E+00,-0.82716E+00,-0.82764E+00,-0.82811E+00,-0.82989E+00/ + + DATA (BNC13M (I),I=601,700)/ & + -0.83384E+00,-0.83866E+00,-0.84353E+00,-0.84845E+00,-0.85341E+00, & + -0.85841E+00,-0.86346E+00,-0.86856E+00,-0.87369E+00,-0.87886E+00, & + -0.88408E+00,-0.88933E+00,-0.89463E+00,-0.89996E+00,-0.90532E+00, & + -0.91073E+00,-0.91617E+00,-0.92164E+00,-0.92715E+00,-0.93270E+00, & + -0.93828E+00,-0.94389E+00,-0.94953E+00,-0.95520E+00,-0.96091E+00, & + -0.96664E+00,-0.97241E+00,-0.97820E+00,-0.98402E+00,-0.98987E+00, & + -0.99575E+00,-0.10017E+01,-0.10076E+01,-0.10136E+01,-0.10195E+01, & + -0.10256E+01,-0.10316E+01,-0.10377E+01,-0.10437E+01,-0.10499E+01, & + -0.10560E+01,-0.10621E+01,-0.10683E+01,-0.10745E+01,-0.10808E+01, & + -0.10870E+01,-0.10933E+01,-0.10996E+01,-0.11059E+01,-0.11122E+01, & + -0.11186E+01,-0.11249E+01,-0.11313E+01,-0.11377E+01,-0.11442E+01, & + -0.11506E+01,-0.11571E+01,-0.11636E+01,-0.11701E+01,-0.11766E+01, & + -0.11831E+01,-0.11897E+01,-0.11963E+01,-0.12028E+01,-0.12095E+01, & + -0.12161E+01,-0.12227E+01,-0.12294E+01,-0.12360E+01,-0.12427E+01, & + -0.12494E+01,-0.12561E+01,-0.12629E+01,-0.12696E+01,-0.12764E+01, & + -0.12831E+01,-0.12899E+01,-0.12967E+01,-0.13035E+01,-0.13104E+01, & + -0.13172E+01,-0.13241E+01,-0.13309E+01,-0.13378E+01,-0.13447E+01, & + -0.13516E+01,-0.13585E+01,-0.13655E+01,-0.13724E+01,-0.13794E+01, & + -0.13863E+01,-0.13933E+01,-0.14003E+01,-0.14073E+01,-0.14143E+01, & + -0.14213E+01,-0.14284E+01,-0.14354E+01,-0.14424E+01,-0.14495E+01/ + + DATA (BNC13M(I),I=701,741)/ & + -0.14566E+01,-0.14637E+01,-0.14708E+01,-0.14779E+01,-0.14850E+01, & + -0.14921E+01,-0.14992E+01,-0.15064E+01,-0.15135E+01,-0.15207E+01, & + -0.15279E+01,-0.15351E+01,-0.15422E+01,-0.15494E+01,-0.15567E+01, & + -0.15639E+01,-0.15711E+01,-0.15783E+01,-0.15856E+01,-0.15928E+01, & + -0.16001E+01,-0.16073E+01,-0.16146E+01,-0.16219E+01,-0.16292E+01, & + -0.16365E+01,-0.16438E+01,-0.16511E+01,-0.16584E+01,-0.16657E+01, & + -0.16731E+01,-0.16804E+01,-0.16878E+01,-0.16951E+01,-0.17025E+01, & + -0.17099E+01,-0.17172E+01,-0.17246E+01,-0.17320E+01,-0.17394E+01, & + -0.17468E+01 & + / + END Module KMC198 diff --git a/wrfv2_fire/chem/module_data_isrpia_kmc223.F b/wrfv2_fire/chem/module_data_isrpia_kmc223.F new file mode 100755 index 00000000..fbd61684 --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_kmc223.F @@ -0,0 +1,2190 @@ + MODULE KMC223 + DOUBLE PRECISION :: & + BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & + BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & + BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & + BNC13M( 741) + + + DATA (BNC01M (I),I= 1,100)/ & + -0.53546E-01,-0.94317E-01,-0.12065E+00,-0.13711E+00,-0.14879E+00, & + -0.15760E+00,-0.16447E+00,-0.16993E+00,-0.17432E+00,-0.17787E+00, & + -0.18074E+00,-0.18305E+00,-0.18490E+00,-0.18635E+00,-0.18746E+00, & + -0.18827E+00,-0.18883E+00,-0.18916E+00,-0.18929E+00,-0.18925E+00, & + -0.18904E+00,-0.18869E+00,-0.18822E+00,-0.18763E+00,-0.18693E+00, & + -0.18614E+00,-0.18527E+00,-0.18432E+00,-0.18330E+00,-0.18222E+00, & + -0.18107E+00,-0.17988E+00,-0.17864E+00,-0.17735E+00,-0.17603E+00, & + -0.17467E+00,-0.17328E+00,-0.17186E+00,-0.17042E+00,-0.16895E+00, & + -0.16746E+00,-0.16595E+00,-0.16443E+00,-0.16289E+00,-0.16134E+00, & + -0.15977E+00,-0.15820E+00,-0.15661E+00,-0.15502E+00,-0.15342E+00, & + -0.15181E+00,-0.15020E+00,-0.14859E+00,-0.14696E+00,-0.14534E+00, & + -0.14371E+00,-0.14207E+00,-0.14043E+00,-0.13879E+00,-0.13714E+00, & + -0.13549E+00,-0.13383E+00,-0.13217E+00,-0.13051E+00,-0.12883E+00, & + -0.12716E+00,-0.12547E+00,-0.12378E+00,-0.12208E+00,-0.12038E+00, & + -0.11866E+00,-0.11694E+00,-0.11520E+00,-0.11346E+00,-0.11170E+00, & + -0.10993E+00,-0.10816E+00,-0.10636E+00,-0.10456E+00,-0.10274E+00, & + -0.10091E+00,-0.99060E-01,-0.97198E-01,-0.95320E-01,-0.93428E-01, & + -0.91520E-01,-0.89596E-01,-0.87656E-01,-0.85700E-01,-0.83729E-01, & + -0.81741E-01,-0.79737E-01,-0.77718E-01,-0.75682E-01,-0.73632E-01, & + -0.71566E-01,-0.69486E-01,-0.67391E-01,-0.65281E-01,-0.63158E-01/ + + DATA (BNC01M (I),I=101,200)/ & + -0.61022E-01,-0.58873E-01,-0.56711E-01,-0.54538E-01,-0.52353E-01, & + -0.50157E-01,-0.47951E-01,-0.45735E-01,-0.43510E-01,-0.41276E-01, & + -0.39034E-01,-0.36785E-01,-0.34529E-01,-0.32266E-01,-0.29997E-01, & + -0.27722E-01,-0.25443E-01,-0.23159E-01,-0.20871E-01,-0.18579E-01, & + -0.16586E-01,-0.14254E-01,-0.11922E-01,-0.95920E-02,-0.72631E-02, & + -0.49355E-02,-0.26095E-02,-0.28486E-03, 0.20382E-02, 0.43595E-02, & + 0.66792E-02, 0.89971E-02, 0.11313E-01, 0.13627E-01, 0.15940E-01, & + 0.18250E-01, 0.20558E-01, 0.22864E-01, 0.25168E-01, 0.27470E-01, & + 0.29770E-01, 0.32067E-01, 0.34362E-01, 0.36654E-01, 0.38945E-01, & + 0.41232E-01, 0.43517E-01, 0.45800E-01, 0.48080E-01, 0.50357E-01, & + 0.52632E-01, 0.54904E-01, 0.57174E-01, 0.59440E-01, 0.61704E-01, & + 0.63965E-01, 0.66223E-01, 0.68479E-01, 0.70731E-01, 0.72981E-01, & + 0.75227E-01, 0.77471E-01, 0.79711E-01, 0.81949E-01, 0.84183E-01, & + 0.86415E-01, 0.88643E-01, 0.90868E-01, 0.93091E-01, 0.95310E-01, & + 0.97525E-01, 0.99738E-01, 0.10195E+00, 0.10415E+00, 0.10636E+00, & + 0.10856E+00, 0.11075E+00, 0.11295E+00, 0.11514E+00, 0.11732E+00, & + 0.11950E+00, 0.12168E+00, 0.12386E+00, 0.12603E+00, 0.12820E+00, & + 0.13037E+00, 0.13253E+00, 0.13469E+00, 0.13685E+00, 0.13900E+00, & + 0.14115E+00, 0.14330E+00, 0.14544E+00, 0.14758E+00, 0.14971E+00, & + 0.15184E+00, 0.15397E+00, 0.15610E+00, 0.15822E+00, 0.16034E+00/ + + DATA (BNC01M (I),I=201,300)/ & + 0.16245E+00, 0.16456E+00, 0.16667E+00, 0.16877E+00, 0.17087E+00, & + 0.17297E+00, 0.17506E+00, 0.17715E+00, 0.17924E+00, 0.18132E+00, & + 0.18340E+00, 0.18548E+00, 0.18755E+00, 0.18962E+00, 0.19168E+00, & + 0.19374E+00, 0.19580E+00, 0.19786E+00, 0.19991E+00, 0.20195E+00, & + 0.20400E+00, 0.20604E+00, 0.20807E+00, 0.21011E+00, 0.21213E+00, & + 0.21416E+00, 0.21618E+00, 0.21820E+00, 0.22022E+00, 0.22223E+00, & + 0.22423E+00, 0.22624E+00, 0.22824E+00, 0.23024E+00, 0.23223E+00, & + 0.23422E+00, 0.23621E+00, 0.23819E+00, 0.24017E+00, 0.24214E+00, & + 0.24412E+00, 0.24608E+00, 0.24805E+00, 0.25001E+00, 0.25197E+00, & + 0.25392E+00, 0.25587E+00, 0.25782E+00, 0.25977E+00, 0.26171E+00, & + 0.26364E+00, 0.26558E+00, 0.26751E+00, 0.26943E+00, 0.27135E+00, & + 0.27327E+00, 0.27519E+00, 0.27710E+00, 0.27901E+00, 0.28092E+00, & + 0.28282E+00, 0.28472E+00, 0.28661E+00, 0.28850E+00, 0.29039E+00, & + 0.29227E+00, 0.29415E+00, 0.29603E+00, 0.29791E+00, 0.29978E+00, & + 0.30164E+00, 0.30351E+00, 0.30537E+00, 0.30722E+00, 0.30908E+00, & + 0.31093E+00, 0.31277E+00, 0.31462E+00, 0.31646E+00, 0.31829E+00, & + 0.32013E+00, 0.32196E+00, 0.32378E+00, 0.32561E+00, 0.32743E+00, & + 0.32924E+00, 0.33105E+00, 0.33286E+00, 0.33467E+00, 0.33647E+00, & + 0.33827E+00, 0.34007E+00, 0.34186E+00, 0.34365E+00, 0.34544E+00, & + 0.34722E+00, 0.34900E+00, 0.35078E+00, 0.35255E+00, 0.35432E+00/ + + DATA (BNC01M (I),I=301,400)/ & + 0.35608E+00, 0.35785E+00, 0.35961E+00, 0.36136E+00, 0.36312E+00, & + 0.36487E+00, 0.36661E+00, 0.36836E+00, 0.37010E+00, 0.37184E+00, & + 0.37357E+00, 0.37530E+00, 0.37703E+00, 0.37875E+00, 0.38047E+00, & + 0.38219E+00, 0.38391E+00, 0.38562E+00, 0.38733E+00, 0.38903E+00, & + 0.39073E+00, 0.39243E+00, 0.39413E+00, 0.39582E+00, 0.39751E+00, & + 0.39920E+00, 0.40088E+00, 0.40256E+00, 0.40424E+00, 0.40591E+00, & + 0.40758E+00, 0.40925E+00, 0.41092E+00, 0.41258E+00, 0.41424E+00, & + 0.41589E+00, 0.41755E+00, 0.41920E+00, 0.42084E+00, 0.42249E+00, & + 0.42413E+00, 0.42576E+00, 0.42740E+00, 0.42903E+00, 0.43066E+00, & + 0.43228E+00, 0.43391E+00, 0.43553E+00, 0.43714E+00, 0.43876E+00, & + 0.44037E+00, 0.44197E+00, 0.44358E+00, 0.44518E+00, 0.44678E+00, & + 0.44837E+00, 0.44997E+00, 0.45156E+00, 0.45315E+00, 0.45473E+00, & + 0.45631E+00, 0.45789E+00, 0.45946E+00, 0.46104E+00, 0.46261E+00, & + 0.46417E+00, 0.46574E+00, 0.46730E+00, 0.46886E+00, 0.47041E+00, & + 0.47197E+00, 0.47352E+00, 0.47506E+00, 0.47661E+00, 0.47815E+00, & + 0.47969E+00, 0.48122E+00, 0.48276E+00, 0.48429E+00, 0.48581E+00, & + 0.48734E+00, 0.48886E+00, 0.49038E+00, 0.49190E+00, 0.49341E+00, & + 0.49492E+00, 0.49643E+00, 0.49794E+00, 0.49944E+00, 0.50094E+00, & + 0.50244E+00, 0.50393E+00, 0.50542E+00, 0.50691E+00, 0.50840E+00, & + 0.50988E+00, 0.51136E+00, 0.51284E+00, 0.51432E+00, 0.51579E+00/ + + DATA (BNC01M (I),I=401,500)/ & + 0.51726E+00, 0.51873E+00, 0.52019E+00, 0.52166E+00, 0.52312E+00, & + 0.52457E+00, 0.52603E+00, 0.52748E+00, 0.52893E+00, 0.53038E+00, & + 0.53182E+00, 0.53326E+00, 0.53470E+00, 0.53614E+00, 0.53758E+00, & + 0.53901E+00, 0.54044E+00, 0.54186E+00, 0.54329E+00, 0.54471E+00, & + 0.54613E+00, 0.54754E+00, 0.54896E+00, 0.55037E+00, 0.55178E+00, & + 0.55318E+00, 0.55459E+00, 0.55599E+00, 0.55739E+00, 0.55878E+00, & + 0.56018E+00, 0.56157E+00, 0.56296E+00, 0.56434E+00, 0.56573E+00, & + 0.56711E+00, 0.56849E+00, 0.56987E+00, 0.57124E+00, 0.57261E+00, & + 0.57398E+00, 0.57535E+00, 0.57671E+00, 0.57808E+00, 0.57944E+00, & + 0.58079E+00, 0.58215E+00, 0.58350E+00, 0.58485E+00, 0.58620E+00, & + 0.58755E+00, 0.58889E+00, 0.59023E+00, 0.59157E+00, 0.59290E+00, & + 0.59424E+00, 0.59557E+00, 0.59690E+00, 0.59823E+00, 0.59955E+00, & + 0.60087E+00, 0.60219E+00, 0.60351E+00, 0.60483E+00, 0.60614E+00, & + 0.60745E+00, 0.60876E+00, 0.61006E+00, 0.61137E+00, 0.61267E+00, & + 0.61397E+00, 0.61527E+00, 0.61656E+00, 0.61786E+00, 0.61915E+00, & + 0.62043E+00, 0.62172E+00, 0.62300E+00, 0.62429E+00, 0.62557E+00, & + 0.62684E+00, 0.62812E+00, 0.62939E+00, 0.63066E+00, 0.63193E+00, & + 0.63320E+00, 0.63446E+00, 0.63572E+00, 0.63698E+00, 0.63824E+00, & + 0.63949E+00, 0.64075E+00, 0.64200E+00, 0.64325E+00, 0.64449E+00, & + 0.64574E+00, 0.64698E+00, 0.64822E+00, 0.64946E+00, 0.65070E+00/ + + DATA (BNC01M (I),I=501,600)/ & + 0.65193E+00, 0.65316E+00, 0.65439E+00, 0.65562E+00, 0.65685E+00, & + 0.65807E+00, 0.65929E+00, 0.66051E+00, 0.66173E+00, 0.66294E+00, & + 0.66416E+00, 0.66537E+00, 0.66658E+00, 0.66779E+00, 0.66899E+00, & + 0.67019E+00, 0.67139E+00, 0.67259E+00, 0.67379E+00, 0.67499E+00, & + 0.67618E+00, 0.67737E+00, 0.67856E+00, 0.67975E+00, 0.68093E+00, & + 0.68211E+00, 0.68329E+00, 0.68447E+00, 0.68565E+00, 0.68683E+00, & + 0.68800E+00, 0.68917E+00, 0.69034E+00, 0.69151E+00, 0.69267E+00, & + 0.69383E+00, 0.69500E+00, 0.69616E+00, 0.69731E+00, 0.69847E+00, & + 0.69962E+00, 0.70077E+00, 0.70192E+00, 0.70307E+00, 0.70422E+00, & + 0.70536E+00, 0.70650E+00, 0.70764E+00, 0.70878E+00, 0.70992E+00, & + 0.71105E+00, 0.71219E+00, 0.71332E+00, 0.71445E+00, 0.71557E+00, & + 0.71670E+00, 0.71782E+00, 0.71894E+00, 0.72006E+00, 0.72118E+00, & + 0.72230E+00, 0.72341E+00, 0.72452E+00, 0.72563E+00, 0.72674E+00, & + 0.72785E+00, 0.72895E+00, 0.73006E+00, 0.73116E+00, 0.73226E+00, & + 0.73335E+00, 0.73445E+00, 0.73554E+00, 0.73664E+00, 0.73773E+00, & + 0.73882E+00, 0.73990E+00, 0.74099E+00, 0.74207E+00, 0.74315E+00, & + 0.74423E+00, 0.74531E+00, 0.74639E+00, 0.74746E+00, 0.74853E+00, & + 0.74961E+00, 0.75067E+00, 0.75174E+00, 0.75281E+00, 0.75387E+00, & + 0.75493E+00, 0.75600E+00, 0.75705E+00, 0.75811E+00, 0.75917E+00, & + 0.76022E+00, 0.76127E+00, 0.76232E+00, 0.76337E+00, 0.76729E+00/ + + DATA (BNC01M (I),I=601,700)/ & + 0.77583E+00, 0.78602E+00, 0.79605E+00, 0.80593E+00, 0.81565E+00, & + 0.82522E+00, 0.83463E+00, 0.84391E+00, 0.85304E+00, 0.86203E+00, & + 0.87088E+00, 0.87959E+00, 0.88818E+00, 0.89663E+00, 0.90496E+00, & + 0.91316E+00, 0.92124E+00, 0.92920E+00, 0.93704E+00, 0.94477E+00, & + 0.95238E+00, 0.95988E+00, 0.96727E+00, 0.97455E+00, 0.98173E+00, & + 0.98880E+00, 0.99577E+00, 0.10026E+01, 0.10094E+01, 0.10161E+01, & + 0.10227E+01, 0.10292E+01, 0.10355E+01, 0.10418E+01, 0.10481E+01, & + 0.10542E+01, 0.10602E+01, 0.10662E+01, 0.10721E+01, 0.10778E+01, & + 0.10836E+01, 0.10892E+01, 0.10947E+01, 0.11002E+01, 0.11056E+01, & + 0.11109E+01, 0.11162E+01, 0.11213E+01, 0.11264E+01, 0.11315E+01, & + 0.11364E+01, 0.11413E+01, 0.11462E+01, 0.11509E+01, 0.11556E+01, & + 0.11603E+01, 0.11648E+01, 0.11693E+01, 0.11738E+01, 0.11782E+01, & + 0.11825E+01, 0.11867E+01, 0.11909E+01, 0.11951E+01, 0.11992E+01, & + 0.12032E+01, 0.12072E+01, 0.12111E+01, 0.12150E+01, 0.12188E+01, & + 0.12226E+01, 0.12263E+01, 0.12299E+01, 0.12335E+01, 0.12371E+01, & + 0.12406E+01, 0.12441E+01, 0.12475E+01, 0.12508E+01, 0.12542E+01, & + 0.12574E+01, 0.12607E+01, 0.12638E+01, 0.12670E+01, 0.12701E+01, & + 0.12731E+01, 0.12761E+01, 0.12791E+01, 0.12820E+01, 0.12849E+01, & + 0.12877E+01, 0.12905E+01, 0.12933E+01, 0.12960E+01, 0.12987E+01, & + 0.13013E+01, 0.13039E+01, 0.13065E+01, 0.13090E+01, 0.13115E+01/ + + DATA (BNC01M(I),I=701,741)/ & + 0.13139E+01, 0.13163E+01, 0.13187E+01, 0.13211E+01, 0.13234E+01, & + 0.13256E+01, 0.13279E+01, 0.13301E+01, 0.13323E+01, 0.13344E+01, & + 0.13365E+01, 0.13386E+01, 0.13406E+01, 0.13426E+01, 0.13446E+01, & + 0.13465E+01, 0.13485E+01, 0.13503E+01, 0.13522E+01, 0.13540E+01, & + 0.13558E+01, 0.13576E+01, 0.13593E+01, 0.13610E+01, 0.13627E+01, & + 0.13643E+01, 0.13660E+01, 0.13675E+01, 0.13691E+01, 0.13706E+01, & + 0.13722E+01, 0.13736E+01, 0.13751E+01, 0.13765E+01, 0.13779E+01, & + 0.13793E+01, 0.13807E+01, 0.13820E+01, 0.13833E+01, 0.13846E+01, & + 0.13858E+01 & + / +! +! *** Na2SO4 +! + DATA (BNC02M (I),I= 1,100)/ & + -0.11119E+00,-0.20367E+00,-0.26963E+00,-0.31506E+00,-0.35045E+00, & + -0.37972E+00,-0.40481E+00,-0.42685E+00,-0.44655E+00,-0.46441E+00, & + -0.48077E+00,-0.49588E+00,-0.50994E+00,-0.52310E+00,-0.53548E+00, & + -0.54717E+00,-0.55826E+00,-0.56881E+00,-0.57888E+00,-0.58852E+00, & + -0.59777E+00,-0.60666E+00,-0.61522E+00,-0.62348E+00,-0.63147E+00, & + -0.63919E+00,-0.64669E+00,-0.65396E+00,-0.66102E+00,-0.66789E+00, & + -0.67458E+00,-0.68110E+00,-0.68746E+00,-0.69367E+00,-0.69974E+00, & + -0.70567E+00,-0.71147E+00,-0.71716E+00,-0.72272E+00,-0.72818E+00, & + -0.73353E+00,-0.73878E+00,-0.74393E+00,-0.74900E+00,-0.75397E+00, & + -0.75886E+00,-0.76367E+00,-0.76841E+00,-0.77307E+00,-0.77765E+00, & + -0.78217E+00,-0.78662E+00,-0.79101E+00,-0.79534E+00,-0.79961E+00, & + -0.80382E+00,-0.80798E+00,-0.81208E+00,-0.81613E+00,-0.82013E+00, & + -0.82409E+00,-0.82799E+00,-0.83186E+00,-0.83568E+00,-0.83946E+00, & + -0.84320E+00,-0.84690E+00,-0.85056E+00,-0.85419E+00,-0.85778E+00, & + -0.86133E+00,-0.86486E+00,-0.86835E+00,-0.87181E+00,-0.87525E+00, & + -0.87865E+00,-0.88202E+00,-0.88537E+00,-0.88869E+00,-0.89199E+00, & + -0.89526E+00,-0.89851E+00,-0.90173E+00,-0.90493E+00,-0.90811E+00, & + -0.91127E+00,-0.91441E+00,-0.91753E+00,-0.92063E+00,-0.92370E+00, & + -0.92676E+00,-0.92981E+00,-0.93283E+00,-0.93584E+00,-0.93883E+00, & + -0.94180E+00,-0.94476E+00,-0.94770E+00,-0.95062E+00,-0.95353E+00/ + + DATA (BNC02M (I),I=101,200)/ & + -0.95642E+00,-0.95930E+00,-0.96217E+00,-0.96502E+00,-0.96786E+00, & + -0.97068E+00,-0.97349E+00,-0.97628E+00,-0.97907E+00,-0.98184E+00, & + -0.98459E+00,-0.98733E+00,-0.99007E+00,-0.99278E+00,-0.99549E+00, & + -0.99818E+00,-0.10009E+01,-0.10035E+01,-0.10062E+01,-0.10088E+01, & + -0.10114E+01,-0.10141E+01,-0.10167E+01,-0.10193E+01,-0.10219E+01, & + -0.10245E+01,-0.10270E+01,-0.10296E+01,-0.10321E+01,-0.10347E+01, & + -0.10372E+01,-0.10397E+01,-0.10422E+01,-0.10447E+01,-0.10472E+01, & + -0.10497E+01,-0.10522E+01,-0.10546E+01,-0.10571E+01,-0.10595E+01, & + -0.10620E+01,-0.10644E+01,-0.10668E+01,-0.10692E+01,-0.10716E+01, & + -0.10740E+01,-0.10764E+01,-0.10787E+01,-0.10811E+01,-0.10835E+01, & + -0.10858E+01,-0.10881E+01,-0.10905E+01,-0.10928E+01,-0.10951E+01, & + -0.10974E+01,-0.10997E+01,-0.11020E+01,-0.11043E+01,-0.11066E+01, & + -0.11088E+01,-0.11111E+01,-0.11134E+01,-0.11156E+01,-0.11179E+01, & + -0.11201E+01,-0.11223E+01,-0.11246E+01,-0.11268E+01,-0.11290E+01, & + -0.11312E+01,-0.11334E+01,-0.11356E+01,-0.11378E+01,-0.11399E+01, & + -0.11421E+01,-0.11443E+01,-0.11465E+01,-0.11486E+01,-0.11508E+01, & + -0.11529E+01,-0.11550E+01,-0.11572E+01,-0.11593E+01,-0.11614E+01, & + -0.11635E+01,-0.11657E+01,-0.11678E+01,-0.11699E+01,-0.11720E+01, & + -0.11740E+01,-0.11761E+01,-0.11782E+01,-0.11803E+01,-0.11824E+01, & + -0.11844E+01,-0.11865E+01,-0.11885E+01,-0.11906E+01,-0.11926E+01/ + + DATA (BNC02M (I),I=201,300)/ & + -0.11947E+01,-0.11967E+01,-0.11987E+01,-0.12008E+01,-0.12028E+01, & + -0.12048E+01,-0.12068E+01,-0.12088E+01,-0.12108E+01,-0.12128E+01, & + -0.12148E+01,-0.12168E+01,-0.12188E+01,-0.12208E+01,-0.12228E+01, & + -0.12247E+01,-0.12267E+01,-0.12287E+01,-0.12306E+01,-0.12326E+01, & + -0.12345E+01,-0.12365E+01,-0.12384E+01,-0.12404E+01,-0.12423E+01, & + -0.12443E+01,-0.12462E+01,-0.12481E+01,-0.12500E+01,-0.12520E+01, & + -0.12539E+01,-0.12558E+01,-0.12577E+01,-0.12596E+01,-0.12615E+01, & + -0.12634E+01,-0.12653E+01,-0.12672E+01,-0.12691E+01,-0.12710E+01, & + -0.12728E+01,-0.12747E+01,-0.12766E+01,-0.12785E+01,-0.12803E+01, & + -0.12822E+01,-0.12840E+01,-0.12859E+01,-0.12878E+01,-0.12896E+01, & + -0.12915E+01,-0.12933E+01,-0.12951E+01,-0.12970E+01,-0.12988E+01, & + -0.13006E+01,-0.13025E+01,-0.13043E+01,-0.13061E+01,-0.13079E+01, & + -0.13098E+01,-0.13116E+01,-0.13134E+01,-0.13152E+01,-0.13170E+01, & + -0.13188E+01,-0.13206E+01,-0.13224E+01,-0.13242E+01,-0.13260E+01, & + -0.13278E+01,-0.13296E+01,-0.13313E+01,-0.13331E+01,-0.13349E+01, & + -0.13367E+01,-0.13385E+01,-0.13402E+01,-0.13420E+01,-0.13438E+01, & + -0.13455E+01,-0.13473E+01,-0.13490E+01,-0.13508E+01,-0.13525E+01, & + -0.13543E+01,-0.13560E+01,-0.13578E+01,-0.13595E+01,-0.13613E+01, & + -0.13630E+01,-0.13647E+01,-0.13665E+01,-0.13682E+01,-0.13699E+01, & + -0.13717E+01,-0.13734E+01,-0.13751E+01,-0.13768E+01,-0.13785E+01/ + + DATA (BNC02M (I),I=301,400)/ & + -0.13802E+01,-0.13820E+01,-0.13837E+01,-0.13854E+01,-0.13871E+01, & + -0.13888E+01,-0.13905E+01,-0.13922E+01,-0.13939E+01,-0.13956E+01, & + -0.13973E+01,-0.13989E+01,-0.14006E+01,-0.14023E+01,-0.14040E+01, & + -0.14057E+01,-0.14074E+01,-0.14090E+01,-0.14107E+01,-0.14124E+01, & + -0.14141E+01,-0.14157E+01,-0.14174E+01,-0.14191E+01,-0.14207E+01, & + -0.14224E+01,-0.14240E+01,-0.14257E+01,-0.14274E+01,-0.14290E+01, & + -0.14307E+01,-0.14323E+01,-0.14340E+01,-0.14356E+01,-0.14372E+01, & + -0.14389E+01,-0.14405E+01,-0.14422E+01,-0.14438E+01,-0.14454E+01, & + -0.14471E+01,-0.14487E+01,-0.14503E+01,-0.14519E+01,-0.14536E+01, & + -0.14552E+01,-0.14568E+01,-0.14584E+01,-0.14601E+01,-0.14617E+01, & + -0.14633E+01,-0.14649E+01,-0.14665E+01,-0.14681E+01,-0.14697E+01, & + -0.14713E+01,-0.14729E+01,-0.14745E+01,-0.14761E+01,-0.14777E+01, & + -0.14793E+01,-0.14809E+01,-0.14825E+01,-0.14841E+01,-0.14857E+01, & + -0.14873E+01,-0.14889E+01,-0.14905E+01,-0.14921E+01,-0.14936E+01, & + -0.14952E+01,-0.14968E+01,-0.14984E+01,-0.15000E+01,-0.15015E+01, & + -0.15031E+01,-0.15047E+01,-0.15062E+01,-0.15078E+01,-0.15094E+01, & + -0.15110E+01,-0.15125E+01,-0.15141E+01,-0.15156E+01,-0.15172E+01, & + -0.15188E+01,-0.15203E+01,-0.15219E+01,-0.15234E+01,-0.15250E+01, & + -0.15265E+01,-0.15281E+01,-0.15296E+01,-0.15312E+01,-0.15327E+01, & + -0.15343E+01,-0.15358E+01,-0.15374E+01,-0.15389E+01,-0.15404E+01/ + + DATA (BNC02M (I),I=401,500)/ & + -0.15420E+01,-0.15435E+01,-0.15450E+01,-0.15466E+01,-0.15481E+01, & + -0.15496E+01,-0.15512E+01,-0.15527E+01,-0.15542E+01,-0.15557E+01, & + -0.15573E+01,-0.15588E+01,-0.15603E+01,-0.15618E+01,-0.15634E+01, & + -0.15649E+01,-0.15664E+01,-0.15679E+01,-0.15694E+01,-0.15709E+01, & + -0.15724E+01,-0.15740E+01,-0.15755E+01,-0.15770E+01,-0.15785E+01, & + -0.15800E+01,-0.15815E+01,-0.15830E+01,-0.15845E+01,-0.15860E+01, & + -0.15875E+01,-0.15890E+01,-0.15905E+01,-0.15920E+01,-0.15935E+01, & + -0.15950E+01,-0.15965E+01,-0.15979E+01,-0.15994E+01,-0.16009E+01, & + -0.16024E+01,-0.16039E+01,-0.16054E+01,-0.16069E+01,-0.16083E+01, & + -0.16098E+01,-0.16113E+01,-0.16128E+01,-0.16143E+01,-0.16157E+01, & + -0.16172E+01,-0.16187E+01,-0.16202E+01,-0.16216E+01,-0.16231E+01, & + -0.16246E+01,-0.16260E+01,-0.16275E+01,-0.16290E+01,-0.16305E+01, & + -0.16319E+01,-0.16334E+01,-0.16348E+01,-0.16363E+01,-0.16378E+01, & + -0.16392E+01,-0.16407E+01,-0.16421E+01,-0.16436E+01,-0.16451E+01, & + -0.16465E+01,-0.16480E+01,-0.16494E+01,-0.16509E+01,-0.16523E+01, & + -0.16538E+01,-0.16552E+01,-0.16567E+01,-0.16581E+01,-0.16596E+01, & + -0.16610E+01,-0.16624E+01,-0.16639E+01,-0.16653E+01,-0.16668E+01, & + -0.16682E+01,-0.16696E+01,-0.16711E+01,-0.16725E+01,-0.16739E+01, & + -0.16754E+01,-0.16768E+01,-0.16783E+01,-0.16797E+01,-0.16811E+01, & + -0.16825E+01,-0.16840E+01,-0.16854E+01,-0.16868E+01,-0.16883E+01/ + + DATA (BNC02M (I),I=501,600)/ & + -0.16897E+01,-0.16911E+01,-0.16925E+01,-0.16939E+01,-0.16954E+01, & + -0.16968E+01,-0.16982E+01,-0.16996E+01,-0.17010E+01,-0.17025E+01, & + -0.17039E+01,-0.17053E+01,-0.17067E+01,-0.17081E+01,-0.17095E+01, & + -0.17109E+01,-0.17124E+01,-0.17138E+01,-0.17152E+01,-0.17166E+01, & + -0.17180E+01,-0.17194E+01,-0.17208E+01,-0.17222E+01,-0.17236E+01, & + -0.17250E+01,-0.17264E+01,-0.17278E+01,-0.17292E+01,-0.17306E+01, & + -0.17320E+01,-0.17334E+01,-0.17348E+01,-0.17362E+01,-0.17376E+01, & + -0.17390E+01,-0.17404E+01,-0.17418E+01,-0.17432E+01,-0.17446E+01, & + -0.17460E+01,-0.17473E+01,-0.17487E+01,-0.17501E+01,-0.17515E+01, & + -0.17529E+01,-0.17543E+01,-0.17557E+01,-0.17571E+01,-0.17584E+01, & + -0.17598E+01,-0.17612E+01,-0.17626E+01,-0.17640E+01,-0.17653E+01, & + -0.17667E+01,-0.17681E+01,-0.17695E+01,-0.17709E+01,-0.17722E+01, & + -0.17736E+01,-0.17750E+01,-0.17764E+01,-0.17777E+01,-0.17791E+01, & + -0.17805E+01,-0.17818E+01,-0.17832E+01,-0.17846E+01,-0.17859E+01, & + -0.17873E+01,-0.17887E+01,-0.17900E+01,-0.17914E+01,-0.17928E+01, & + -0.17941E+01,-0.17955E+01,-0.17969E+01,-0.17982E+01,-0.17996E+01, & + -0.18009E+01,-0.18023E+01,-0.18037E+01,-0.18050E+01,-0.18064E+01, & + -0.18077E+01,-0.18091E+01,-0.18105E+01,-0.18118E+01,-0.18132E+01, & + -0.18145E+01,-0.18159E+01,-0.18172E+01,-0.18186E+01,-0.18199E+01, & + -0.18213E+01,-0.18226E+01,-0.18240E+01,-0.18253E+01,-0.18304E+01/ + + DATA (BNC02M (I),I=601,700)/ & + -0.18414E+01,-0.18548E+01,-0.18681E+01,-0.18813E+01,-0.18945E+01, & + -0.19076E+01,-0.19207E+01,-0.19337E+01,-0.19467E+01,-0.19596E+01, & + -0.19724E+01,-0.19852E+01,-0.19980E+01,-0.20107E+01,-0.20233E+01, & + -0.20359E+01,-0.20485E+01,-0.20610E+01,-0.20735E+01,-0.20859E+01, & + -0.20983E+01,-0.21107E+01,-0.21230E+01,-0.21353E+01,-0.21475E+01, & + -0.21598E+01,-0.21719E+01,-0.21841E+01,-0.21962E+01,-0.22082E+01, & + -0.22203E+01,-0.22323E+01,-0.22442E+01,-0.22562E+01,-0.22681E+01, & + -0.22800E+01,-0.22918E+01,-0.23036E+01,-0.23154E+01,-0.23272E+01, & + -0.23389E+01,-0.23506E+01,-0.23623E+01,-0.23740E+01,-0.23856E+01, & + -0.23972E+01,-0.24088E+01,-0.24204E+01,-0.24319E+01,-0.24434E+01, & + -0.24549E+01,-0.24663E+01,-0.24778E+01,-0.24892E+01,-0.25006E+01, & + -0.25119E+01,-0.25233E+01,-0.25346E+01,-0.25459E+01,-0.25572E+01, & + -0.25685E+01,-0.25797E+01,-0.25910E+01,-0.26022E+01,-0.26134E+01, & + -0.26245E+01,-0.26357E+01,-0.26468E+01,-0.26579E+01,-0.26690E+01, & + -0.26801E+01,-0.26912E+01,-0.27022E+01,-0.27132E+01,-0.27242E+01, & + -0.27352E+01,-0.27462E+01,-0.27572E+01,-0.27681E+01,-0.27790E+01, & + -0.27900E+01,-0.28009E+01,-0.28117E+01,-0.28226E+01,-0.28335E+01, & + -0.28443E+01,-0.28551E+01,-0.28659E+01,-0.28767E+01,-0.28875E+01, & + -0.28983E+01,-0.29090E+01,-0.29198E+01,-0.29305E+01,-0.29412E+01, & + -0.29519E+01,-0.29626E+01,-0.29733E+01,-0.29839E+01,-0.29946E+01/ + + DATA (BNC02M(I),I=701,741)/ & + -0.30052E+01,-0.30158E+01,-0.30264E+01,-0.30370E+01,-0.30476E+01, & + -0.30582E+01,-0.30688E+01,-0.30793E+01,-0.30899E+01,-0.31004E+01, & + -0.31109E+01,-0.31214E+01,-0.31319E+01,-0.31424E+01,-0.31529E+01, & + -0.31633E+01,-0.31738E+01,-0.31842E+01,-0.31946E+01,-0.32051E+01, & + -0.32155E+01,-0.32259E+01,-0.32363E+01,-0.32466E+01,-0.32570E+01, & + -0.32674E+01,-0.32777E+01,-0.32881E+01,-0.32984E+01,-0.33087E+01, & + -0.33190E+01,-0.33293E+01,-0.33396E+01,-0.33499E+01,-0.33602E+01, & + -0.33705E+01,-0.33807E+01,-0.33910E+01,-0.34012E+01,-0.34114E+01, & + -0.34217E+01 & + / +! +! *** NaNO3 +! + DATA (BNC03M (I),I= 1,100)/ & + -0.55791E-01,-0.10256E+00,-0.13620E+00,-0.15954E+00,-0.17783E+00, & + -0.19304E+00,-0.20616E+00,-0.21773E+00,-0.22813E+00,-0.23760E+00, & + -0.24630E+00,-0.25438E+00,-0.26192E+00,-0.26900E+00,-0.27569E+00, & + -0.28203E+00,-0.28806E+00,-0.29382E+00,-0.29933E+00,-0.30462E+00, & + -0.30971E+00,-0.31462E+00,-0.31936E+00,-0.32394E+00,-0.32838E+00, & + -0.33269E+00,-0.33687E+00,-0.34094E+00,-0.34490E+00,-0.34876E+00, & + -0.35252E+00,-0.35620E+00,-0.35979E+00,-0.36330E+00,-0.36674E+00, & + -0.37010E+00,-0.37340E+00,-0.37663E+00,-0.37979E+00,-0.38290E+00, & + -0.38596E+00,-0.38895E+00,-0.39190E+00,-0.39480E+00,-0.39764E+00, & + -0.40045E+00,-0.40320E+00,-0.40592E+00,-0.40859E+00,-0.41123E+00, & + -0.41383E+00,-0.41639E+00,-0.41891E+00,-0.42141E+00,-0.42387E+00, & + -0.42629E+00,-0.42869E+00,-0.43106E+00,-0.43340E+00,-0.43571E+00, & + -0.43799E+00,-0.44025E+00,-0.44249E+00,-0.44470E+00,-0.44689E+00, & + -0.44905E+00,-0.45120E+00,-0.45332E+00,-0.45543E+00,-0.45752E+00, & + -0.45958E+00,-0.46163E+00,-0.46367E+00,-0.46568E+00,-0.46768E+00, & + -0.46967E+00,-0.47164E+00,-0.47359E+00,-0.47554E+00,-0.47747E+00, & + -0.47938E+00,-0.48129E+00,-0.48318E+00,-0.48506E+00,-0.48693E+00, & + -0.48879E+00,-0.49064E+00,-0.49247E+00,-0.49430E+00,-0.49612E+00, & + -0.49793E+00,-0.49973E+00,-0.50152E+00,-0.50330E+00,-0.50508E+00, & + -0.50684E+00,-0.50860E+00,-0.51035E+00,-0.51209E+00,-0.51383E+00/ + + DATA (BNC03M (I),I=101,200)/ & + -0.51555E+00,-0.51727E+00,-0.51898E+00,-0.52069E+00,-0.52239E+00, & + -0.52408E+00,-0.52576E+00,-0.52743E+00,-0.52910E+00,-0.53077E+00, & + -0.53242E+00,-0.53407E+00,-0.53571E+00,-0.53735E+00,-0.53898E+00, & + -0.54060E+00,-0.54221E+00,-0.54382E+00,-0.54543E+00,-0.54702E+00, & + -0.54856E+00,-0.55015E+00,-0.55173E+00,-0.55331E+00,-0.55488E+00, & + -0.55644E+00,-0.55800E+00,-0.55955E+00,-0.56109E+00,-0.56263E+00, & + -0.56416E+00,-0.56568E+00,-0.56720E+00,-0.56871E+00,-0.57022E+00, & + -0.57172E+00,-0.57322E+00,-0.57471E+00,-0.57619E+00,-0.57767E+00, & + -0.57915E+00,-0.58061E+00,-0.58208E+00,-0.58353E+00,-0.58499E+00, & + -0.58643E+00,-0.58787E+00,-0.58931E+00,-0.59074E+00,-0.59217E+00, & + -0.59359E+00,-0.59501E+00,-0.59642E+00,-0.59783E+00,-0.59924E+00, & + -0.60063E+00,-0.60203E+00,-0.60342E+00,-0.60480E+00,-0.60619E+00, & + -0.60756E+00,-0.60893E+00,-0.61030E+00,-0.61167E+00,-0.61303E+00, & + -0.61438E+00,-0.61573E+00,-0.61708E+00,-0.61842E+00,-0.61976E+00, & + -0.62110E+00,-0.62243E+00,-0.62376E+00,-0.62508E+00,-0.62640E+00, & + -0.62772E+00,-0.62903E+00,-0.63034E+00,-0.63165E+00,-0.63295E+00, & + -0.63425E+00,-0.63554E+00,-0.63683E+00,-0.63812E+00,-0.63941E+00, & + -0.64069E+00,-0.64196E+00,-0.64324E+00,-0.64451E+00,-0.64578E+00, & + -0.64704E+00,-0.64830E+00,-0.64956E+00,-0.65082E+00,-0.65207E+00, & + -0.65332E+00,-0.65456E+00,-0.65580E+00,-0.65704E+00,-0.65828E+00/ + + DATA (BNC03M (I),I=201,300)/ & + -0.65951E+00,-0.66074E+00,-0.66197E+00,-0.66320E+00,-0.66442E+00, & + -0.66564E+00,-0.66685E+00,-0.66807E+00,-0.66928E+00,-0.67048E+00, & + -0.67169E+00,-0.67289E+00,-0.67409E+00,-0.67529E+00,-0.67648E+00, & + -0.67767E+00,-0.67886E+00,-0.68005E+00,-0.68123E+00,-0.68241E+00, & + -0.68359E+00,-0.68476E+00,-0.68594E+00,-0.68711E+00,-0.68828E+00, & + -0.68944E+00,-0.69060E+00,-0.69177E+00,-0.69292E+00,-0.69408E+00, & + -0.69523E+00,-0.69638E+00,-0.69753E+00,-0.69868E+00,-0.69983E+00, & + -0.70097E+00,-0.70211E+00,-0.70324E+00,-0.70438E+00,-0.70551E+00, & + -0.70664E+00,-0.70777E+00,-0.70890E+00,-0.71002E+00,-0.71115E+00, & + -0.71227E+00,-0.71338E+00,-0.71450E+00,-0.71561E+00,-0.71672E+00, & + -0.71783E+00,-0.71894E+00,-0.72005E+00,-0.72115E+00,-0.72225E+00, & + -0.72335E+00,-0.72445E+00,-0.72554E+00,-0.72664E+00,-0.72773E+00, & + -0.72882E+00,-0.72991E+00,-0.73099E+00,-0.73208E+00,-0.73316E+00, & + -0.73424E+00,-0.73532E+00,-0.73639E+00,-0.73747E+00,-0.73854E+00, & + -0.73961E+00,-0.74068E+00,-0.74175E+00,-0.74281E+00,-0.74388E+00, & + -0.74494E+00,-0.74600E+00,-0.74706E+00,-0.74811E+00,-0.74917E+00, & + -0.75022E+00,-0.75127E+00,-0.75232E+00,-0.75337E+00,-0.75442E+00, & + -0.75546E+00,-0.75651E+00,-0.75755E+00,-0.75859E+00,-0.75962E+00, & + -0.76066E+00,-0.76170E+00,-0.76273E+00,-0.76376E+00,-0.76479E+00, & + -0.76582E+00,-0.76685E+00,-0.76787E+00,-0.76890E+00,-0.76992E+00/ + + DATA (BNC03M (I),I=301,400)/ & + -0.77094E+00,-0.77196E+00,-0.77298E+00,-0.77399E+00,-0.77501E+00, & + -0.77602E+00,-0.77703E+00,-0.77804E+00,-0.77905E+00,-0.78006E+00, & + -0.78107E+00,-0.78207E+00,-0.78308E+00,-0.78408E+00,-0.78508E+00, & + -0.78608E+00,-0.78707E+00,-0.78807E+00,-0.78906E+00,-0.79006E+00, & + -0.79105E+00,-0.79204E+00,-0.79303E+00,-0.79402E+00,-0.79500E+00, & + -0.79599E+00,-0.79697E+00,-0.79796E+00,-0.79894E+00,-0.79992E+00, & + -0.80090E+00,-0.80187E+00,-0.80285E+00,-0.80382E+00,-0.80480E+00, & + -0.80577E+00,-0.80674E+00,-0.80771E+00,-0.80868E+00,-0.80965E+00, & + -0.81061E+00,-0.81158E+00,-0.81254E+00,-0.81350E+00,-0.81446E+00, & + -0.81542E+00,-0.81638E+00,-0.81734E+00,-0.81829E+00,-0.81925E+00, & + -0.82020E+00,-0.82116E+00,-0.82211E+00,-0.82306E+00,-0.82401E+00, & + -0.82496E+00,-0.82590E+00,-0.82685E+00,-0.82779E+00,-0.82874E+00, & + -0.82968E+00,-0.83062E+00,-0.83156E+00,-0.83250E+00,-0.83344E+00, & + -0.83437E+00,-0.83531E+00,-0.83624E+00,-0.83718E+00,-0.83811E+00, & + -0.83904E+00,-0.83997E+00,-0.84090E+00,-0.84183E+00,-0.84275E+00, & + -0.84368E+00,-0.84460E+00,-0.84553E+00,-0.84645E+00,-0.84737E+00, & + -0.84829E+00,-0.84921E+00,-0.85013E+00,-0.85105E+00,-0.85197E+00, & + -0.85288E+00,-0.85380E+00,-0.85471E+00,-0.85562E+00,-0.85653E+00, & + -0.85744E+00,-0.85835E+00,-0.85926E+00,-0.86017E+00,-0.86108E+00, & + -0.86198E+00,-0.86289E+00,-0.86379E+00,-0.86469E+00,-0.86560E+00/ + + DATA (BNC03M (I),I=401,500)/ & + -0.86650E+00,-0.86740E+00,-0.86830E+00,-0.86919E+00,-0.87009E+00, & + -0.87099E+00,-0.87188E+00,-0.87278E+00,-0.87367E+00,-0.87456E+00, & + -0.87545E+00,-0.87634E+00,-0.87723E+00,-0.87812E+00,-0.87901E+00, & + -0.87990E+00,-0.88078E+00,-0.88167E+00,-0.88255E+00,-0.88344E+00, & + -0.88432E+00,-0.88520E+00,-0.88608E+00,-0.88696E+00,-0.88784E+00, & + -0.88872E+00,-0.88960E+00,-0.89048E+00,-0.89135E+00,-0.89223E+00, & + -0.89310E+00,-0.89397E+00,-0.89485E+00,-0.89572E+00,-0.89659E+00, & + -0.89746E+00,-0.89833E+00,-0.89920E+00,-0.90006E+00,-0.90093E+00, & + -0.90180E+00,-0.90266E+00,-0.90353E+00,-0.90439E+00,-0.90525E+00, & + -0.90612E+00,-0.90698E+00,-0.90784E+00,-0.90870E+00,-0.90956E+00, & + -0.91041E+00,-0.91127E+00,-0.91213E+00,-0.91298E+00,-0.91384E+00, & + -0.91469E+00,-0.91555E+00,-0.91640E+00,-0.91725E+00,-0.91810E+00, & + -0.91895E+00,-0.91980E+00,-0.92065E+00,-0.92150E+00,-0.92235E+00, & + -0.92319E+00,-0.92404E+00,-0.92488E+00,-0.92573E+00,-0.92657E+00, & + -0.92742E+00,-0.92826E+00,-0.92910E+00,-0.92994E+00,-0.93078E+00, & + -0.93162E+00,-0.93246E+00,-0.93330E+00,-0.93413E+00,-0.93497E+00, & + -0.93581E+00,-0.93664E+00,-0.93748E+00,-0.93831E+00,-0.93914E+00, & + -0.93998E+00,-0.94081E+00,-0.94164E+00,-0.94247E+00,-0.94330E+00, & + -0.94413E+00,-0.94496E+00,-0.94578E+00,-0.94661E+00,-0.94744E+00, & + -0.94826E+00,-0.94909E+00,-0.94991E+00,-0.95074E+00,-0.95156E+00/ + + DATA (BNC03M (I),I=501,600)/ & + -0.95238E+00,-0.95320E+00,-0.95403E+00,-0.95485E+00,-0.95567E+00, & + -0.95649E+00,-0.95730E+00,-0.95812E+00,-0.95894E+00,-0.95976E+00, & + -0.96057E+00,-0.96139E+00,-0.96220E+00,-0.96302E+00,-0.96383E+00, & + -0.96464E+00,-0.96546E+00,-0.96627E+00,-0.96708E+00,-0.96789E+00, & + -0.96870E+00,-0.96951E+00,-0.97032E+00,-0.97113E+00,-0.97193E+00, & + -0.97274E+00,-0.97355E+00,-0.97435E+00,-0.97516E+00,-0.97596E+00, & + -0.97677E+00,-0.97757E+00,-0.97837E+00,-0.97917E+00,-0.97997E+00, & + -0.98078E+00,-0.98158E+00,-0.98238E+00,-0.98318E+00,-0.98397E+00, & + -0.98477E+00,-0.98557E+00,-0.98637E+00,-0.98716E+00,-0.98796E+00, & + -0.98875E+00,-0.98955E+00,-0.99034E+00,-0.99114E+00,-0.99193E+00, & + -0.99272E+00,-0.99351E+00,-0.99431E+00,-0.99510E+00,-0.99589E+00, & + -0.99668E+00,-0.99747E+00,-0.99825E+00,-0.99904E+00,-0.99983E+00, & + -0.10006E+01,-0.10014E+01,-0.10022E+01,-0.10030E+01,-0.10038E+01, & + -0.10045E+01,-0.10053E+01,-0.10061E+01,-0.10069E+01,-0.10077E+01, & + -0.10085E+01,-0.10092E+01,-0.10100E+01,-0.10108E+01,-0.10116E+01, & + -0.10124E+01,-0.10131E+01,-0.10139E+01,-0.10147E+01,-0.10155E+01, & + -0.10162E+01,-0.10170E+01,-0.10178E+01,-0.10186E+01,-0.10193E+01, & + -0.10201E+01,-0.10209E+01,-0.10217E+01,-0.10224E+01,-0.10232E+01, & + -0.10240E+01,-0.10248E+01,-0.10255E+01,-0.10263E+01,-0.10271E+01, & + -0.10278E+01,-0.10286E+01,-0.10294E+01,-0.10301E+01,-0.10330E+01/ + + DATA (BNC03M (I),I=601,700)/ & + -0.10393E+01,-0.10469E+01,-0.10545E+01,-0.10620E+01,-0.10694E+01, & + -0.10769E+01,-0.10842E+01,-0.10916E+01,-0.10989E+01,-0.11062E+01, & + -0.11134E+01,-0.11206E+01,-0.11277E+01,-0.11349E+01,-0.11420E+01, & + -0.11490E+01,-0.11560E+01,-0.11630E+01,-0.11700E+01,-0.11769E+01, & + -0.11838E+01,-0.11907E+01,-0.11976E+01,-0.12044E+01,-0.12112E+01, & + -0.12180E+01,-0.12247E+01,-0.12314E+01,-0.12381E+01,-0.12448E+01, & + -0.12514E+01,-0.12581E+01,-0.12647E+01,-0.12713E+01,-0.12778E+01, & + -0.12843E+01,-0.12909E+01,-0.12974E+01,-0.13038E+01,-0.13103E+01, & + -0.13167E+01,-0.13231E+01,-0.13295E+01,-0.13359E+01,-0.13423E+01, & + -0.13486E+01,-0.13549E+01,-0.13612E+01,-0.13675E+01,-0.13738E+01, & + -0.13800E+01,-0.13863E+01,-0.13925E+01,-0.13987E+01,-0.14049E+01, & + -0.14111E+01,-0.14172E+01,-0.14234E+01,-0.14295E+01,-0.14356E+01, & + -0.14417E+01,-0.14478E+01,-0.14539E+01,-0.14599E+01,-0.14660E+01, & + -0.14720E+01,-0.14780E+01,-0.14840E+01,-0.14900E+01,-0.14960E+01, & + -0.15020E+01,-0.15079E+01,-0.15139E+01,-0.15198E+01,-0.15257E+01, & + -0.15316E+01,-0.15375E+01,-0.15434E+01,-0.15493E+01,-0.15551E+01, & + -0.15610E+01,-0.15668E+01,-0.15727E+01,-0.15785E+01,-0.15843E+01, & + -0.15901E+01,-0.15959E+01,-0.16017E+01,-0.16074E+01,-0.16132E+01, & + -0.16189E+01,-0.16247E+01,-0.16304E+01,-0.16361E+01,-0.16418E+01, & + -0.16475E+01,-0.16532E+01,-0.16589E+01,-0.16646E+01,-0.16703E+01/ + + DATA (BNC03M(I),I=701,741)/ & + -0.16759E+01,-0.16816E+01,-0.16872E+01,-0.16928E+01,-0.16985E+01, & + -0.17041E+01,-0.17097E+01,-0.17153E+01,-0.17209E+01,-0.17265E+01, & + -0.17320E+01,-0.17376E+01,-0.17432E+01,-0.17487E+01,-0.17543E+01, & + -0.17598E+01,-0.17653E+01,-0.17709E+01,-0.17764E+01,-0.17819E+01, & + -0.17874E+01,-0.17929E+01,-0.17984E+01,-0.18039E+01,-0.18093E+01, & + -0.18148E+01,-0.18203E+01,-0.18257E+01,-0.18312E+01,-0.18366E+01, & + -0.18420E+01,-0.18475E+01,-0.18529E+01,-0.18583E+01,-0.18637E+01, & + -0.18691E+01,-0.18745E+01,-0.18799E+01,-0.18853E+01,-0.18907E+01, & + -0.18960E+01 & + / +! +! *** (NH4)2SO4 +! + DATA (BNC04M (I),I= 1,100)/ & + -0.11131E+00,-0.20410E+00,-0.27045E+00,-0.31626E+00,-0.35200E+00, & + -0.38161E+00,-0.40704E+00,-0.42941E+00,-0.44944E+00,-0.46762E+00, & + -0.48429E+00,-0.49971E+00,-0.51407E+00,-0.52753E+00,-0.54020E+00, & + -0.55219E+00,-0.56357E+00,-0.57441E+00,-0.58476E+00,-0.59468E+00, & + -0.60421E+00,-0.61337E+00,-0.62220E+00,-0.63073E+00,-0.63898E+00, & + -0.64698E+00,-0.65473E+00,-0.66226E+00,-0.66958E+00,-0.67670E+00, & + -0.68364E+00,-0.69041E+00,-0.69701E+00,-0.70347E+00,-0.70977E+00, & + -0.71594E+00,-0.72198E+00,-0.72789E+00,-0.73369E+00,-0.73937E+00, & + -0.74495E+00,-0.75042E+00,-0.75579E+00,-0.76107E+00,-0.76627E+00, & + -0.77137E+00,-0.77639E+00,-0.78133E+00,-0.78620E+00,-0.79099E+00, & + -0.79571E+00,-0.80036E+00,-0.80495E+00,-0.80947E+00,-0.81393E+00, & + -0.81834E+00,-0.82268E+00,-0.82697E+00,-0.83121E+00,-0.83540E+00, & + -0.83954E+00,-0.84363E+00,-0.84768E+00,-0.85168E+00,-0.85563E+00, & + -0.85955E+00,-0.86343E+00,-0.86727E+00,-0.87107E+00,-0.87483E+00, & + -0.87856E+00,-0.88226E+00,-0.88592E+00,-0.88956E+00,-0.89316E+00, & + -0.89673E+00,-0.90027E+00,-0.90379E+00,-0.90728E+00,-0.91075E+00, & + -0.91419E+00,-0.91760E+00,-0.92099E+00,-0.92436E+00,-0.92771E+00, & + -0.93104E+00,-0.93434E+00,-0.93763E+00,-0.94089E+00,-0.94414E+00, & + -0.94737E+00,-0.95058E+00,-0.95377E+00,-0.95694E+00,-0.96010E+00, & + -0.96324E+00,-0.96636E+00,-0.96947E+00,-0.97256E+00,-0.97564E+00/ + + DATA (BNC04M (I),I=101,200)/ & + -0.97870E+00,-0.98175E+00,-0.98478E+00,-0.98780E+00,-0.99081E+00, & + -0.99380E+00,-0.99677E+00,-0.99974E+00,-0.10027E+01,-0.10056E+01, & + -0.10085E+01,-0.10115E+01,-0.10144E+01,-0.10172E+01,-0.10201E+01, & + -0.10230E+01,-0.10258E+01,-0.10286E+01,-0.10315E+01,-0.10343E+01, & + -0.10370E+01,-0.10398E+01,-0.10426E+01,-0.10454E+01,-0.10481E+01, & + -0.10509E+01,-0.10536E+01,-0.10563E+01,-0.10590E+01,-0.10617E+01, & + -0.10644E+01,-0.10671E+01,-0.10698E+01,-0.10724E+01,-0.10751E+01, & + -0.10777E+01,-0.10803E+01,-0.10830E+01,-0.10856E+01,-0.10882E+01, & + -0.10908E+01,-0.10933E+01,-0.10959E+01,-0.10985E+01,-0.11010E+01, & + -0.11036E+01,-0.11061E+01,-0.11086E+01,-0.11111E+01,-0.11136E+01, & + -0.11161E+01,-0.11186E+01,-0.11211E+01,-0.11236E+01,-0.11260E+01, & + -0.11285E+01,-0.11309E+01,-0.11334E+01,-0.11358E+01,-0.11382E+01, & + -0.11406E+01,-0.11431E+01,-0.11455E+01,-0.11479E+01,-0.11502E+01, & + -0.11526E+01,-0.11550E+01,-0.11574E+01,-0.11597E+01,-0.11621E+01, & + -0.11644E+01,-0.11668E+01,-0.11691E+01,-0.11714E+01,-0.11737E+01, & + -0.11761E+01,-0.11784E+01,-0.11807E+01,-0.11830E+01,-0.11852E+01, & + -0.11875E+01,-0.11898E+01,-0.11921E+01,-0.11943E+01,-0.11966E+01, & + -0.11988E+01,-0.12011E+01,-0.12033E+01,-0.12056E+01,-0.12078E+01, & + -0.12100E+01,-0.12122E+01,-0.12144E+01,-0.12166E+01,-0.12189E+01, & + -0.12210E+01,-0.12232E+01,-0.12254E+01,-0.12276E+01,-0.12298E+01/ + + DATA (BNC04M (I),I=201,300)/ & + -0.12319E+01,-0.12341E+01,-0.12363E+01,-0.12384E+01,-0.12406E+01, & + -0.12427E+01,-0.12449E+01,-0.12470E+01,-0.12491E+01,-0.12513E+01, & + -0.12534E+01,-0.12555E+01,-0.12576E+01,-0.12597E+01,-0.12618E+01, & + -0.12639E+01,-0.12660E+01,-0.12681E+01,-0.12702E+01,-0.12723E+01, & + -0.12743E+01,-0.12764E+01,-0.12785E+01,-0.12805E+01,-0.12826E+01, & + -0.12847E+01,-0.12867E+01,-0.12888E+01,-0.12908E+01,-0.12928E+01, & + -0.12949E+01,-0.12969E+01,-0.12989E+01,-0.13010E+01,-0.13030E+01, & + -0.13050E+01,-0.13070E+01,-0.13090E+01,-0.13110E+01,-0.13130E+01, & + -0.13150E+01,-0.13170E+01,-0.13190E+01,-0.13210E+01,-0.13230E+01, & + -0.13249E+01,-0.13269E+01,-0.13289E+01,-0.13309E+01,-0.13328E+01, & + -0.13348E+01,-0.13367E+01,-0.13387E+01,-0.13406E+01,-0.13426E+01, & + -0.13445E+01,-0.13465E+01,-0.13484E+01,-0.13504E+01,-0.13523E+01, & + -0.13542E+01,-0.13561E+01,-0.13581E+01,-0.13600E+01,-0.13619E+01, & + -0.13638E+01,-0.13657E+01,-0.13676E+01,-0.13695E+01,-0.13714E+01, & + -0.13733E+01,-0.13752E+01,-0.13771E+01,-0.13790E+01,-0.13809E+01, & + -0.13828E+01,-0.13846E+01,-0.13865E+01,-0.13884E+01,-0.13903E+01, & + -0.13921E+01,-0.13940E+01,-0.13958E+01,-0.13977E+01,-0.13996E+01, & + -0.14014E+01,-0.14033E+01,-0.14051E+01,-0.14070E+01,-0.14088E+01, & + -0.14106E+01,-0.14125E+01,-0.14143E+01,-0.14162E+01,-0.14180E+01, & + -0.14198E+01,-0.14216E+01,-0.14235E+01,-0.14253E+01,-0.14271E+01/ + + DATA (BNC04M (I),I=301,400)/ & + -0.14289E+01,-0.14307E+01,-0.14325E+01,-0.14343E+01,-0.14361E+01, & + -0.14379E+01,-0.14397E+01,-0.14415E+01,-0.14433E+01,-0.14451E+01, & + -0.14469E+01,-0.14487E+01,-0.14505E+01,-0.14523E+01,-0.14541E+01, & + -0.14558E+01,-0.14576E+01,-0.14594E+01,-0.14612E+01,-0.14629E+01, & + -0.14647E+01,-0.14665E+01,-0.14682E+01,-0.14700E+01,-0.14717E+01, & + -0.14735E+01,-0.14752E+01,-0.14770E+01,-0.14787E+01,-0.14805E+01, & + -0.14822E+01,-0.14840E+01,-0.14857E+01,-0.14875E+01,-0.14892E+01, & + -0.14909E+01,-0.14927E+01,-0.14944E+01,-0.14961E+01,-0.14979E+01, & + -0.14996E+01,-0.15013E+01,-0.15030E+01,-0.15047E+01,-0.15065E+01, & + -0.15082E+01,-0.15099E+01,-0.15116E+01,-0.15133E+01,-0.15150E+01, & + -0.15167E+01,-0.15184E+01,-0.15201E+01,-0.15218E+01,-0.15235E+01, & + -0.15252E+01,-0.15269E+01,-0.15286E+01,-0.15303E+01,-0.15320E+01, & + -0.15337E+01,-0.15353E+01,-0.15370E+01,-0.15387E+01,-0.15404E+01, & + -0.15421E+01,-0.15437E+01,-0.15454E+01,-0.15471E+01,-0.15488E+01, & + -0.15504E+01,-0.15521E+01,-0.15538E+01,-0.15554E+01,-0.15571E+01, & + -0.15587E+01,-0.15604E+01,-0.15620E+01,-0.15637E+01,-0.15654E+01, & + -0.15670E+01,-0.15687E+01,-0.15703E+01,-0.15720E+01,-0.15736E+01, & + -0.15752E+01,-0.15769E+01,-0.15785E+01,-0.15802E+01,-0.15818E+01, & + -0.15834E+01,-0.15851E+01,-0.15867E+01,-0.15883E+01,-0.15900E+01, & + -0.15916E+01,-0.15932E+01,-0.15948E+01,-0.15965E+01,-0.15981E+01/ + + DATA (BNC04M (I),I=401,500)/ & + -0.15997E+01,-0.16013E+01,-0.16029E+01,-0.16045E+01,-0.16062E+01, & + -0.16078E+01,-0.16094E+01,-0.16110E+01,-0.16126E+01,-0.16142E+01, & + -0.16158E+01,-0.16174E+01,-0.16190E+01,-0.16206E+01,-0.16222E+01, & + -0.16238E+01,-0.16254E+01,-0.16270E+01,-0.16286E+01,-0.16302E+01, & + -0.16318E+01,-0.16334E+01,-0.16349E+01,-0.16365E+01,-0.16381E+01, & + -0.16397E+01,-0.16413E+01,-0.16429E+01,-0.16444E+01,-0.16460E+01, & + -0.16476E+01,-0.16492E+01,-0.16507E+01,-0.16523E+01,-0.16539E+01, & + -0.16555E+01,-0.16570E+01,-0.16586E+01,-0.16602E+01,-0.16617E+01, & + -0.16633E+01,-0.16648E+01,-0.16664E+01,-0.16680E+01,-0.16695E+01, & + -0.16711E+01,-0.16726E+01,-0.16742E+01,-0.16757E+01,-0.16773E+01, & + -0.16788E+01,-0.16804E+01,-0.16819E+01,-0.16835E+01,-0.16850E+01, & + -0.16866E+01,-0.16881E+01,-0.16897E+01,-0.16912E+01,-0.16928E+01, & + -0.16943E+01,-0.16958E+01,-0.16974E+01,-0.16989E+01,-0.17004E+01, & + -0.17020E+01,-0.17035E+01,-0.17050E+01,-0.17066E+01,-0.17081E+01, & + -0.17096E+01,-0.17111E+01,-0.17127E+01,-0.17142E+01,-0.17157E+01, & + -0.17172E+01,-0.17187E+01,-0.17203E+01,-0.17218E+01,-0.17233E+01, & + -0.17248E+01,-0.17263E+01,-0.17278E+01,-0.17294E+01,-0.17309E+01, & + -0.17324E+01,-0.17339E+01,-0.17354E+01,-0.17369E+01,-0.17384E+01, & + -0.17399E+01,-0.17414E+01,-0.17429E+01,-0.17444E+01,-0.17459E+01, & + -0.17474E+01,-0.17489E+01,-0.17504E+01,-0.17519E+01,-0.17534E+01/ + + DATA (BNC04M (I),I=501,600)/ & + -0.17549E+01,-0.17564E+01,-0.17579E+01,-0.17594E+01,-0.17609E+01, & + -0.17623E+01,-0.17638E+01,-0.17653E+01,-0.17668E+01,-0.17683E+01, & + -0.17698E+01,-0.17713E+01,-0.17727E+01,-0.17742E+01,-0.17757E+01, & + -0.17772E+01,-0.17787E+01,-0.17801E+01,-0.17816E+01,-0.17831E+01, & + -0.17846E+01,-0.17860E+01,-0.17875E+01,-0.17890E+01,-0.17904E+01, & + -0.17919E+01,-0.17934E+01,-0.17948E+01,-0.17963E+01,-0.17978E+01, & + -0.17992E+01,-0.18007E+01,-0.18022E+01,-0.18036E+01,-0.18051E+01, & + -0.18065E+01,-0.18080E+01,-0.18095E+01,-0.18109E+01,-0.18124E+01, & + -0.18138E+01,-0.18153E+01,-0.18167E+01,-0.18182E+01,-0.18196E+01, & + -0.18211E+01,-0.18225E+01,-0.18240E+01,-0.18254E+01,-0.18269E+01, & + -0.18283E+01,-0.18298E+01,-0.18312E+01,-0.18327E+01,-0.18341E+01, & + -0.18356E+01,-0.18370E+01,-0.18384E+01,-0.18399E+01,-0.18413E+01, & + -0.18427E+01,-0.18442E+01,-0.18456E+01,-0.18471E+01,-0.18485E+01, & + -0.18499E+01,-0.18514E+01,-0.18528E+01,-0.18542E+01,-0.18556E+01, & + -0.18571E+01,-0.18585E+01,-0.18599E+01,-0.18614E+01,-0.18628E+01, & + -0.18642E+01,-0.18656E+01,-0.18671E+01,-0.18685E+01,-0.18699E+01, & + -0.18713E+01,-0.18727E+01,-0.18742E+01,-0.18756E+01,-0.18770E+01, & + -0.18784E+01,-0.18798E+01,-0.18812E+01,-0.18827E+01,-0.18841E+01, & + -0.18855E+01,-0.18869E+01,-0.18883E+01,-0.18897E+01,-0.18911E+01, & + -0.18925E+01,-0.18940E+01,-0.18954E+01,-0.18968E+01,-0.19020E+01/ + + DATA (BNC04M (I),I=601,700)/ & + -0.19136E+01,-0.19275E+01,-0.19414E+01,-0.19552E+01,-0.19689E+01, & + -0.19826E+01,-0.19962E+01,-0.20097E+01,-0.20232E+01,-0.20366E+01, & + -0.20500E+01,-0.20633E+01,-0.20766E+01,-0.20897E+01,-0.21029E+01, & + -0.21160E+01,-0.21290E+01,-0.21420E+01,-0.21550E+01,-0.21679E+01, & + -0.21807E+01,-0.21935E+01,-0.22063E+01,-0.22190E+01,-0.22317E+01, & + -0.22443E+01,-0.22569E+01,-0.22695E+01,-0.22820E+01,-0.22945E+01, & + -0.23069E+01,-0.23193E+01,-0.23317E+01,-0.23440E+01,-0.23563E+01, & + -0.23686E+01,-0.23808E+01,-0.23930E+01,-0.24052E+01,-0.24173E+01, & + -0.24294E+01,-0.24415E+01,-0.24535E+01,-0.24655E+01,-0.24775E+01, & + -0.24895E+01,-0.25014E+01,-0.25133E+01,-0.25252E+01,-0.25370E+01, & + -0.25488E+01,-0.25606E+01,-0.25724E+01,-0.25841E+01,-0.25959E+01, & + -0.26076E+01,-0.26192E+01,-0.26309E+01,-0.26425E+01,-0.26541E+01, & + -0.26657E+01,-0.26772E+01,-0.26887E+01,-0.27002E+01,-0.27117E+01, & + -0.27232E+01,-0.27346E+01,-0.27461E+01,-0.27575E+01,-0.27688E+01, & + -0.27802E+01,-0.27915E+01,-0.28029E+01,-0.28142E+01,-0.28255E+01, & + -0.28367E+01,-0.28480E+01,-0.28592E+01,-0.28704E+01,-0.28816E+01, & + -0.28928E+01,-0.29039E+01,-0.29151E+01,-0.29262E+01,-0.29373E+01, & + -0.29484E+01,-0.29595E+01,-0.29705E+01,-0.29816E+01,-0.29926E+01, & + -0.30036E+01,-0.30146E+01,-0.30256E+01,-0.30366E+01,-0.30475E+01, & + -0.30585E+01,-0.30694E+01,-0.30803E+01,-0.30912E+01,-0.31021E+01/ + + DATA (BNC04M(I),I=701,741)/ & + -0.31129E+01,-0.31238E+01,-0.31346E+01,-0.31454E+01,-0.31562E+01, & + -0.31670E+01,-0.31778E+01,-0.31886E+01,-0.31993E+01,-0.32101E+01, & + -0.32208E+01,-0.32315E+01,-0.32423E+01,-0.32529E+01,-0.32636E+01, & + -0.32743E+01,-0.32850E+01,-0.32956E+01,-0.33062E+01,-0.33169E+01, & + -0.33275E+01,-0.33381E+01,-0.33487E+01,-0.33592E+01,-0.33698E+01, & + -0.33804E+01,-0.33909E+01,-0.34015E+01,-0.34120E+01,-0.34225E+01, & + -0.34330E+01,-0.34435E+01,-0.34540E+01,-0.34644E+01,-0.34749E+01, & + -0.34854E+01,-0.34958E+01,-0.35062E+01,-0.35166E+01,-0.35271E+01, & + -0.35375E+01 & + / +! +! *** NH4NO3 +! + DATA (BNC05M (I),I= 1,100)/ & + -0.56573E-01,-0.10548E+00,-0.14176E+00,-0.16761E+00,-0.18833E+00, & + -0.20590E+00,-0.22130E+00,-0.23513E+00,-0.24773E+00,-0.25937E+00, & + -0.27021E+00,-0.28039E+00,-0.29000E+00,-0.29914E+00,-0.30784E+00, & + -0.31618E+00,-0.32419E+00,-0.33189E+00,-0.33933E+00,-0.34653E+00, & + -0.35350E+00,-0.36027E+00,-0.36685E+00,-0.37326E+00,-0.37950E+00, & + -0.38559E+00,-0.39153E+00,-0.39735E+00,-0.40303E+00,-0.40860E+00, & + -0.41405E+00,-0.41939E+00,-0.42463E+00,-0.42977E+00,-0.43481E+00, & + -0.43977E+00,-0.44464E+00,-0.44943E+00,-0.45413E+00,-0.45876E+00, & + -0.46332E+00,-0.46780E+00,-0.47221E+00,-0.47656E+00,-0.48084E+00, & + -0.48506E+00,-0.48922E+00,-0.49332E+00,-0.49737E+00,-0.50136E+00, & + -0.50529E+00,-0.50918E+00,-0.51301E+00,-0.51680E+00,-0.52054E+00, & + -0.52424E+00,-0.52790E+00,-0.53151E+00,-0.53508E+00,-0.53861E+00, & + -0.54211E+00,-0.54557E+00,-0.54899E+00,-0.55239E+00,-0.55575E+00, & + -0.55908E+00,-0.56238E+00,-0.56565E+00,-0.56890E+00,-0.57212E+00, & + -0.57531E+00,-0.57848E+00,-0.58163E+00,-0.58476E+00,-0.58787E+00, & + -0.59096E+00,-0.59403E+00,-0.59708E+00,-0.60011E+00,-0.60313E+00, & + -0.60614E+00,-0.60912E+00,-0.61210E+00,-0.61506E+00,-0.61801E+00, & + -0.62095E+00,-0.62387E+00,-0.62678E+00,-0.62969E+00,-0.63258E+00, & + -0.63546E+00,-0.63833E+00,-0.64120E+00,-0.64405E+00,-0.64689E+00, & + -0.64973E+00,-0.65255E+00,-0.65537E+00,-0.65818E+00,-0.66098E+00/ + + DATA (BNC05M (I),I=101,200)/ & + -0.66377E+00,-0.66655E+00,-0.66933E+00,-0.67209E+00,-0.67485E+00, & + -0.67760E+00,-0.68034E+00,-0.68307E+00,-0.68579E+00,-0.68850E+00, & + -0.69121E+00,-0.69390E+00,-0.69659E+00,-0.69927E+00,-0.70194E+00, & + -0.70459E+00,-0.70724E+00,-0.70988E+00,-0.71251E+00,-0.71514E+00, & + -0.71759E+00,-0.72021E+00,-0.72282E+00,-0.72542E+00,-0.72800E+00, & + -0.73058E+00,-0.73314E+00,-0.73570E+00,-0.73824E+00,-0.74077E+00, & + -0.74329E+00,-0.74580E+00,-0.74830E+00,-0.75079E+00,-0.75327E+00, & + -0.75574E+00,-0.75821E+00,-0.76066E+00,-0.76310E+00,-0.76553E+00, & + -0.76795E+00,-0.77036E+00,-0.77277E+00,-0.77516E+00,-0.77755E+00, & + -0.77992E+00,-0.78229E+00,-0.78465E+00,-0.78700E+00,-0.78934E+00, & + -0.79167E+00,-0.79400E+00,-0.79631E+00,-0.79862E+00,-0.80092E+00, & + -0.80321E+00,-0.80549E+00,-0.80776E+00,-0.81003E+00,-0.81229E+00, & + -0.81454E+00,-0.81678E+00,-0.81901E+00,-0.82124E+00,-0.82346E+00, & + -0.82567E+00,-0.82787E+00,-0.83007E+00,-0.83226E+00,-0.83444E+00, & + -0.83661E+00,-0.83878E+00,-0.84094E+00,-0.84309E+00,-0.84524E+00, & + -0.84738E+00,-0.84951E+00,-0.85163E+00,-0.85375E+00,-0.85586E+00, & + -0.85797E+00,-0.86006E+00,-0.86215E+00,-0.86424E+00,-0.86632E+00, & + -0.86839E+00,-0.87045E+00,-0.87251E+00,-0.87456E+00,-0.87661E+00, & + -0.87865E+00,-0.88068E+00,-0.88271E+00,-0.88473E+00,-0.88675E+00, & + -0.88876E+00,-0.89076E+00,-0.89276E+00,-0.89475E+00,-0.89673E+00/ + + DATA (BNC05M (I),I=201,300)/ & + -0.89871E+00,-0.90068E+00,-0.90265E+00,-0.90462E+00,-0.90657E+00, & + -0.90852E+00,-0.91047E+00,-0.91241E+00,-0.91434E+00,-0.91627E+00, & + -0.91819E+00,-0.92011E+00,-0.92202E+00,-0.92393E+00,-0.92583E+00, & + -0.92773E+00,-0.92962E+00,-0.93151E+00,-0.93339E+00,-0.93526E+00, & + -0.93713E+00,-0.93900E+00,-0.94086E+00,-0.94272E+00,-0.94457E+00, & + -0.94641E+00,-0.94825E+00,-0.95009E+00,-0.95192E+00,-0.95375E+00, & + -0.95557E+00,-0.95738E+00,-0.95920E+00,-0.96100E+00,-0.96281E+00, & + -0.96460E+00,-0.96640E+00,-0.96818E+00,-0.96997E+00,-0.97175E+00, & + -0.97352E+00,-0.97529E+00,-0.97706E+00,-0.97882E+00,-0.98058E+00, & + -0.98233E+00,-0.98408E+00,-0.98582E+00,-0.98756E+00,-0.98930E+00, & + -0.99103E+00,-0.99276E+00,-0.99448E+00,-0.99620E+00,-0.99791E+00, & + -0.99962E+00,-0.10013E+01,-0.10030E+01,-0.10047E+01,-0.10064E+01, & + -0.10081E+01,-0.10098E+01,-0.10115E+01,-0.10132E+01,-0.10148E+01, & + -0.10165E+01,-0.10182E+01,-0.10198E+01,-0.10215E+01,-0.10231E+01, & + -0.10248E+01,-0.10264E+01,-0.10281E+01,-0.10297E+01,-0.10314E+01, & + -0.10330E+01,-0.10346E+01,-0.10363E+01,-0.10379E+01,-0.10395E+01, & + -0.10411E+01,-0.10427E+01,-0.10443E+01,-0.10459E+01,-0.10475E+01, & + -0.10491E+01,-0.10507E+01,-0.10523E+01,-0.10539E+01,-0.10555E+01, & + -0.10571E+01,-0.10586E+01,-0.10602E+01,-0.10618E+01,-0.10633E+01, & + -0.10649E+01,-0.10665E+01,-0.10680E+01,-0.10696E+01,-0.10711E+01/ + + DATA (BNC05M (I),I=301,400)/ & + -0.10727E+01,-0.10742E+01,-0.10757E+01,-0.10773E+01,-0.10788E+01, & + -0.10803E+01,-0.10819E+01,-0.10834E+01,-0.10849E+01,-0.10864E+01, & + -0.10879E+01,-0.10895E+01,-0.10910E+01,-0.10925E+01,-0.10940E+01, & + -0.10955E+01,-0.10970E+01,-0.10985E+01,-0.10999E+01,-0.11014E+01, & + -0.11029E+01,-0.11044E+01,-0.11059E+01,-0.11073E+01,-0.11088E+01, & + -0.11103E+01,-0.11118E+01,-0.11132E+01,-0.11147E+01,-0.11161E+01, & + -0.11176E+01,-0.11190E+01,-0.11205E+01,-0.11219E+01,-0.11234E+01, & + -0.11248E+01,-0.11263E+01,-0.11277E+01,-0.11291E+01,-0.11306E+01, & + -0.11320E+01,-0.11334E+01,-0.11348E+01,-0.11363E+01,-0.11377E+01, & + -0.11391E+01,-0.11405E+01,-0.11419E+01,-0.11433E+01,-0.11447E+01, & + -0.11461E+01,-0.11475E+01,-0.11489E+01,-0.11503E+01,-0.11517E+01, & + -0.11531E+01,-0.11545E+01,-0.11559E+01,-0.11572E+01,-0.11586E+01, & + -0.11600E+01,-0.11614E+01,-0.11627E+01,-0.11641E+01,-0.11655E+01, & + -0.11668E+01,-0.11682E+01,-0.11696E+01,-0.11709E+01,-0.11723E+01, & + -0.11736E+01,-0.11750E+01,-0.11763E+01,-0.11777E+01,-0.11790E+01, & + -0.11804E+01,-0.11817E+01,-0.11830E+01,-0.11844E+01,-0.11857E+01, & + -0.11870E+01,-0.11884E+01,-0.11897E+01,-0.11910E+01,-0.11923E+01, & + -0.11936E+01,-0.11950E+01,-0.11963E+01,-0.11976E+01,-0.11989E+01, & + -0.12002E+01,-0.12015E+01,-0.12028E+01,-0.12041E+01,-0.12054E+01, & + -0.12067E+01,-0.12080E+01,-0.12093E+01,-0.12106E+01,-0.12119E+01/ + + DATA (BNC05M (I),I=401,500)/ & + -0.12132E+01,-0.12144E+01,-0.12157E+01,-0.12170E+01,-0.12183E+01, & + -0.12196E+01,-0.12208E+01,-0.12221E+01,-0.12234E+01,-0.12246E+01, & + -0.12259E+01,-0.12272E+01,-0.12284E+01,-0.12297E+01,-0.12310E+01, & + -0.12322E+01,-0.12335E+01,-0.12347E+01,-0.12360E+01,-0.12372E+01, & + -0.12385E+01,-0.12397E+01,-0.12409E+01,-0.12422E+01,-0.12434E+01, & + -0.12447E+01,-0.12459E+01,-0.12471E+01,-0.12484E+01,-0.12496E+01, & + -0.12508E+01,-0.12520E+01,-0.12533E+01,-0.12545E+01,-0.12557E+01, & + -0.12569E+01,-0.12581E+01,-0.12594E+01,-0.12606E+01,-0.12618E+01, & + -0.12630E+01,-0.12642E+01,-0.12654E+01,-0.12666E+01,-0.12678E+01, & + -0.12690E+01,-0.12702E+01,-0.12714E+01,-0.12726E+01,-0.12738E+01, & + -0.12750E+01,-0.12762E+01,-0.12774E+01,-0.12786E+01,-0.12797E+01, & + -0.12809E+01,-0.12821E+01,-0.12833E+01,-0.12845E+01,-0.12856E+01, & + -0.12868E+01,-0.12880E+01,-0.12892E+01,-0.12903E+01,-0.12915E+01, & + -0.12927E+01,-0.12938E+01,-0.12950E+01,-0.12962E+01,-0.12973E+01, & + -0.12985E+01,-0.12996E+01,-0.13008E+01,-0.13020E+01,-0.13031E+01, & + -0.13043E+01,-0.13054E+01,-0.13066E+01,-0.13077E+01,-0.13088E+01, & + -0.13100E+01,-0.13111E+01,-0.13123E+01,-0.13134E+01,-0.13146E+01, & + -0.13157E+01,-0.13168E+01,-0.13180E+01,-0.13191E+01,-0.13202E+01, & + -0.13213E+01,-0.13225E+01,-0.13236E+01,-0.13247E+01,-0.13258E+01, & + -0.13270E+01,-0.13281E+01,-0.13292E+01,-0.13303E+01,-0.13314E+01/ + + DATA (BNC05M (I),I=501,600)/ & + -0.13325E+01,-0.13337E+01,-0.13348E+01,-0.13359E+01,-0.13370E+01, & + -0.13381E+01,-0.13392E+01,-0.13403E+01,-0.13414E+01,-0.13425E+01, & + -0.13436E+01,-0.13447E+01,-0.13458E+01,-0.13469E+01,-0.13480E+01, & + -0.13491E+01,-0.13502E+01,-0.13513E+01,-0.13524E+01,-0.13534E+01, & + -0.13545E+01,-0.13556E+01,-0.13567E+01,-0.13578E+01,-0.13589E+01, & + -0.13599E+01,-0.13610E+01,-0.13621E+01,-0.13632E+01,-0.13643E+01, & + -0.13653E+01,-0.13664E+01,-0.13675E+01,-0.13685E+01,-0.13696E+01, & + -0.13707E+01,-0.13717E+01,-0.13728E+01,-0.13739E+01,-0.13749E+01, & + -0.13760E+01,-0.13770E+01,-0.13781E+01,-0.13792E+01,-0.13802E+01, & + -0.13813E+01,-0.13823E+01,-0.13834E+01,-0.13844E+01,-0.13855E+01, & + -0.13865E+01,-0.13876E+01,-0.13886E+01,-0.13897E+01,-0.13907E+01, & + -0.13917E+01,-0.13928E+01,-0.13938E+01,-0.13949E+01,-0.13959E+01, & + -0.13969E+01,-0.13980E+01,-0.13990E+01,-0.14000E+01,-0.14011E+01, & + -0.14021E+01,-0.14031E+01,-0.14042E+01,-0.14052E+01,-0.14062E+01, & + -0.14072E+01,-0.14083E+01,-0.14093E+01,-0.14103E+01,-0.14113E+01, & + -0.14123E+01,-0.14134E+01,-0.14144E+01,-0.14154E+01,-0.14164E+01, & + -0.14174E+01,-0.14184E+01,-0.14194E+01,-0.14205E+01,-0.14215E+01, & + -0.14225E+01,-0.14235E+01,-0.14245E+01,-0.14255E+01,-0.14265E+01, & + -0.14275E+01,-0.14285E+01,-0.14295E+01,-0.14305E+01,-0.14315E+01, & + -0.14325E+01,-0.14335E+01,-0.14345E+01,-0.14355E+01,-0.14392E+01/ + + DATA (BNC05M (I),I=601,700)/ & + -0.14473E+01,-0.14571E+01,-0.14668E+01,-0.14763E+01,-0.14858E+01, & + -0.14952E+01,-0.15045E+01,-0.15137E+01,-0.15229E+01,-0.15319E+01, & + -0.15409E+01,-0.15498E+01,-0.15586E+01,-0.15674E+01,-0.15761E+01, & + -0.15847E+01,-0.15933E+01,-0.16017E+01,-0.16102E+01,-0.16185E+01, & + -0.16268E+01,-0.16351E+01,-0.16433E+01,-0.16514E+01,-0.16595E+01, & + -0.16675E+01,-0.16754E+01,-0.16834E+01,-0.16912E+01,-0.16990E+01, & + -0.17068E+01,-0.17145E+01,-0.17222E+01,-0.17298E+01,-0.17374E+01, & + -0.17450E+01,-0.17525E+01,-0.17599E+01,-0.17674E+01,-0.17747E+01, & + -0.17821E+01,-0.17894E+01,-0.17967E+01,-0.18039E+01,-0.18111E+01, & + -0.18182E+01,-0.18254E+01,-0.18325E+01,-0.18395E+01,-0.18466E+01, & + -0.18535E+01,-0.18605E+01,-0.18674E+01,-0.18743E+01,-0.18812E+01, & + -0.18881E+01,-0.18949E+01,-0.19017E+01,-0.19084E+01,-0.19152E+01, & + -0.19219E+01,-0.19285E+01,-0.19352E+01,-0.19418E+01,-0.19484E+01, & + -0.19550E+01,-0.19616E+01,-0.19681E+01,-0.19746E+01,-0.19811E+01, & + -0.19876E+01,-0.19940E+01,-0.20004E+01,-0.20068E+01,-0.20132E+01, & + -0.20196E+01,-0.20259E+01,-0.20322E+01,-0.20385E+01,-0.20448E+01, & + -0.20510E+01,-0.20573E+01,-0.20635E+01,-0.20697E+01,-0.20759E+01, & + -0.20821E+01,-0.20882E+01,-0.20943E+01,-0.21005E+01,-0.21066E+01, & + -0.21126E+01,-0.21187E+01,-0.21247E+01,-0.21308E+01,-0.21368E+01, & + -0.21428E+01,-0.21488E+01,-0.21548E+01,-0.21607E+01,-0.21667E+01/ + + DATA (BNC05M(I),I=701,741)/ & + -0.21726E+01,-0.21785E+01,-0.21844E+01,-0.21903E+01,-0.21962E+01, & + -0.22020E+01,-0.22079E+01,-0.22137E+01,-0.22195E+01,-0.22253E+01, & + -0.22311E+01,-0.22369E+01,-0.22427E+01,-0.22484E+01,-0.22542E+01, & + -0.22599E+01,-0.22656E+01,-0.22714E+01,-0.22771E+01,-0.22827E+01, & + -0.22884E+01,-0.22941E+01,-0.22997E+01,-0.23054E+01,-0.23110E+01, & + -0.23167E+01,-0.23223E+01,-0.23279E+01,-0.23335E+01,-0.23390E+01, & + -0.23446E+01,-0.23502E+01,-0.23557E+01,-0.23613E+01,-0.23668E+01, & + -0.23723E+01,-0.23779E+01,-0.23834E+01,-0.23889E+01,-0.23944E+01, & + -0.23998E+01 & + / +! +! *** NH4Cl +! + DATA (BNC06M (I),I= 1,100)/ & + -0.54668E-01,-0.98406E-01,-0.12832E+00,-0.14814E+00,-0.16306E+00, & + -0.17499E+00,-0.18490E+00,-0.19335E+00,-0.20067E+00,-0.20712E+00, & + -0.21285E+00,-0.21799E+00,-0.22263E+00,-0.22685E+00,-0.23071E+00, & + -0.23426E+00,-0.23752E+00,-0.24054E+00,-0.24335E+00,-0.24596E+00, & + -0.24839E+00,-0.25066E+00,-0.25280E+00,-0.25480E+00,-0.25668E+00, & + -0.25846E+00,-0.26014E+00,-0.26172E+00,-0.26322E+00,-0.26464E+00, & + -0.26599E+00,-0.26728E+00,-0.26850E+00,-0.26967E+00,-0.27078E+00, & + -0.27184E+00,-0.27286E+00,-0.27383E+00,-0.27477E+00,-0.27566E+00, & + -0.27653E+00,-0.27736E+00,-0.27815E+00,-0.27892E+00,-0.27966E+00, & + -0.28038E+00,-0.28107E+00,-0.28174E+00,-0.28239E+00,-0.28302E+00, & + -0.28363E+00,-0.28422E+00,-0.28479E+00,-0.28535E+00,-0.28588E+00, & + -0.28641E+00,-0.28692E+00,-0.28741E+00,-0.28789E+00,-0.28836E+00, & + -0.28882E+00,-0.28926E+00,-0.28969E+00,-0.29010E+00,-0.29051E+00, & + -0.29090E+00,-0.29128E+00,-0.29165E+00,-0.29201E+00,-0.29235E+00, & + -0.29269E+00,-0.29301E+00,-0.29332E+00,-0.29362E+00,-0.29390E+00, & + -0.29418E+00,-0.29444E+00,-0.29470E+00,-0.29494E+00,-0.29517E+00, & + -0.29538E+00,-0.29559E+00,-0.29578E+00,-0.29597E+00,-0.29614E+00, & + -0.29630E+00,-0.29645E+00,-0.29659E+00,-0.29671E+00,-0.29683E+00, & + -0.29694E+00,-0.29703E+00,-0.29711E+00,-0.29719E+00,-0.29725E+00, & + -0.29731E+00,-0.29735E+00,-0.29739E+00,-0.29741E+00,-0.29743E+00/ + + DATA (BNC06M (I),I=101,200)/ & + -0.29744E+00,-0.29744E+00,-0.29743E+00,-0.29741E+00,-0.29739E+00, & + -0.29736E+00,-0.29732E+00,-0.29727E+00,-0.29722E+00,-0.29716E+00, & + -0.29710E+00,-0.29703E+00,-0.29695E+00,-0.29687E+00,-0.29678E+00, & + -0.29669E+00,-0.29660E+00,-0.29650E+00,-0.29639E+00,-0.29628E+00, & + -0.29628E+00,-0.29615E+00,-0.29602E+00,-0.29589E+00,-0.29576E+00, & + -0.29562E+00,-0.29548E+00,-0.29534E+00,-0.29520E+00,-0.29506E+00, & + -0.29491E+00,-0.29477E+00,-0.29462E+00,-0.29447E+00,-0.29432E+00, & + -0.29417E+00,-0.29402E+00,-0.29386E+00,-0.29371E+00,-0.29355E+00, & + -0.29339E+00,-0.29323E+00,-0.29308E+00,-0.29291E+00,-0.29275E+00, & + -0.29259E+00,-0.29243E+00,-0.29226E+00,-0.29210E+00,-0.29193E+00, & + -0.29177E+00,-0.29160E+00,-0.29143E+00,-0.29127E+00,-0.29110E+00, & + -0.29093E+00,-0.29076E+00,-0.29059E+00,-0.29042E+00,-0.29025E+00, & + -0.29008E+00,-0.28990E+00,-0.28973E+00,-0.28956E+00,-0.28939E+00, & + -0.28921E+00,-0.28904E+00,-0.28887E+00,-0.28869E+00,-0.28852E+00, & + -0.28835E+00,-0.28817E+00,-0.28800E+00,-0.28782E+00,-0.28765E+00, & + -0.28747E+00,-0.28730E+00,-0.28712E+00,-0.28695E+00,-0.28677E+00, & + -0.28660E+00,-0.28642E+00,-0.28625E+00,-0.28607E+00,-0.28590E+00, & + -0.28572E+00,-0.28555E+00,-0.28537E+00,-0.28520E+00,-0.28502E+00, & + -0.28485E+00,-0.28468E+00,-0.28450E+00,-0.28433E+00,-0.28415E+00, & + -0.28398E+00,-0.28381E+00,-0.28363E+00,-0.28346E+00,-0.28329E+00/ + + DATA (BNC06M (I),I=201,300)/ & + -0.28312E+00,-0.28295E+00,-0.28277E+00,-0.28260E+00,-0.28243E+00, & + -0.28226E+00,-0.28209E+00,-0.28192E+00,-0.28175E+00,-0.28158E+00, & + -0.28141E+00,-0.28124E+00,-0.28107E+00,-0.28090E+00,-0.28074E+00, & + -0.28057E+00,-0.28040E+00,-0.28023E+00,-0.28007E+00,-0.27990E+00, & + -0.27974E+00,-0.27957E+00,-0.27941E+00,-0.27924E+00,-0.27908E+00, & + -0.27892E+00,-0.27875E+00,-0.27859E+00,-0.27843E+00,-0.27827E+00, & + -0.27810E+00,-0.27794E+00,-0.27778E+00,-0.27762E+00,-0.27746E+00, & + -0.27731E+00,-0.27715E+00,-0.27699E+00,-0.27683E+00,-0.27667E+00, & + -0.27652E+00,-0.27636E+00,-0.27621E+00,-0.27605E+00,-0.27590E+00, & + -0.27574E+00,-0.27559E+00,-0.27544E+00,-0.27529E+00,-0.27513E+00, & + -0.27498E+00,-0.27483E+00,-0.27468E+00,-0.27453E+00,-0.27438E+00, & + -0.27424E+00,-0.27409E+00,-0.27394E+00,-0.27379E+00,-0.27365E+00, & + -0.27350E+00,-0.27336E+00,-0.27321E+00,-0.27307E+00,-0.27292E+00, & + -0.27278E+00,-0.27264E+00,-0.27250E+00,-0.27236E+00,-0.27222E+00, & + -0.27208E+00,-0.27194E+00,-0.27180E+00,-0.27166E+00,-0.27152E+00, & + -0.27139E+00,-0.27125E+00,-0.27111E+00,-0.27098E+00,-0.27084E+00, & + -0.27071E+00,-0.27058E+00,-0.27044E+00,-0.27031E+00,-0.27018E+00, & + -0.27005E+00,-0.26992E+00,-0.26979E+00,-0.26966E+00,-0.26953E+00, & + -0.26940E+00,-0.26927E+00,-0.26915E+00,-0.26902E+00,-0.26890E+00, & + -0.26877E+00,-0.26865E+00,-0.26852E+00,-0.26840E+00,-0.26828E+00/ + + DATA (BNC06M (I),I=301,400)/ & + -0.26815E+00,-0.26803E+00,-0.26791E+00,-0.26779E+00,-0.26767E+00, & + -0.26755E+00,-0.26744E+00,-0.26732E+00,-0.26720E+00,-0.26708E+00, & + -0.26697E+00,-0.26685E+00,-0.26674E+00,-0.26662E+00,-0.26651E+00, & + -0.26640E+00,-0.26629E+00,-0.26617E+00,-0.26606E+00,-0.26595E+00, & + -0.26584E+00,-0.26573E+00,-0.26563E+00,-0.26552E+00,-0.26541E+00, & + -0.26530E+00,-0.26520E+00,-0.26509E+00,-0.26499E+00,-0.26488E+00, & + -0.26478E+00,-0.26468E+00,-0.26457E+00,-0.26447E+00,-0.26437E+00, & + -0.26427E+00,-0.26417E+00,-0.26407E+00,-0.26397E+00,-0.26387E+00, & + -0.26378E+00,-0.26368E+00,-0.26358E+00,-0.26349E+00,-0.26339E+00, & + -0.26330E+00,-0.26320E+00,-0.26311E+00,-0.26302E+00,-0.26293E+00, & + -0.26284E+00,-0.26274E+00,-0.26265E+00,-0.26256E+00,-0.26248E+00, & + -0.26239E+00,-0.26230E+00,-0.26221E+00,-0.26213E+00,-0.26204E+00, & + -0.26195E+00,-0.26187E+00,-0.26178E+00,-0.26170E+00,-0.26162E+00, & + -0.26154E+00,-0.26145E+00,-0.26137E+00,-0.26129E+00,-0.26121E+00, & + -0.26113E+00,-0.26105E+00,-0.26098E+00,-0.26090E+00,-0.26082E+00, & + -0.26074E+00,-0.26067E+00,-0.26059E+00,-0.26052E+00,-0.26044E+00, & + -0.26037E+00,-0.26030E+00,-0.26023E+00,-0.26015E+00,-0.26008E+00, & + -0.26001E+00,-0.25994E+00,-0.25987E+00,-0.25980E+00,-0.25973E+00, & + -0.25967E+00,-0.25960E+00,-0.25953E+00,-0.25947E+00,-0.25940E+00, & + -0.25934E+00,-0.25927E+00,-0.25921E+00,-0.25915E+00,-0.25908E+00/ + + DATA (BNC06M (I),I=401,500)/ & + -0.25902E+00,-0.25896E+00,-0.25890E+00,-0.25884E+00,-0.25878E+00, & + -0.25872E+00,-0.25866E+00,-0.25860E+00,-0.25855E+00,-0.25849E+00, & + -0.25843E+00,-0.25838E+00,-0.25832E+00,-0.25827E+00,-0.25821E+00, & + -0.25816E+00,-0.25811E+00,-0.25805E+00,-0.25800E+00,-0.25795E+00, & + -0.25790E+00,-0.25785E+00,-0.25780E+00,-0.25775E+00,-0.25770E+00, & + -0.25765E+00,-0.25761E+00,-0.25756E+00,-0.25751E+00,-0.25747E+00, & + -0.25742E+00,-0.25738E+00,-0.25733E+00,-0.25729E+00,-0.25725E+00, & + -0.25721E+00,-0.25716E+00,-0.25712E+00,-0.25708E+00,-0.25704E+00, & + -0.25700E+00,-0.25696E+00,-0.25692E+00,-0.25688E+00,-0.25685E+00, & + -0.25681E+00,-0.25677E+00,-0.25674E+00,-0.25670E+00,-0.25667E+00, & + -0.25663E+00,-0.25660E+00,-0.25656E+00,-0.25653E+00,-0.25650E+00, & + -0.25647E+00,-0.25644E+00,-0.25640E+00,-0.25637E+00,-0.25634E+00, & + -0.25632E+00,-0.25629E+00,-0.25626E+00,-0.25623E+00,-0.25620E+00, & + -0.25618E+00,-0.25615E+00,-0.25612E+00,-0.25610E+00,-0.25608E+00, & + -0.25605E+00,-0.25603E+00,-0.25600E+00,-0.25598E+00,-0.25596E+00, & + -0.25594E+00,-0.25592E+00,-0.25590E+00,-0.25588E+00,-0.25586E+00, & + -0.25584E+00,-0.25582E+00,-0.25580E+00,-0.25578E+00,-0.25577E+00, & + -0.25575E+00,-0.25573E+00,-0.25572E+00,-0.25570E+00,-0.25569E+00, & + -0.25567E+00,-0.25566E+00,-0.25565E+00,-0.25563E+00,-0.25562E+00, & + -0.25561E+00,-0.25560E+00,-0.25559E+00,-0.25558E+00,-0.25557E+00/ + + DATA (BNC06M (I),I=501,600)/ & + -0.25556E+00,-0.25555E+00,-0.25554E+00,-0.25553E+00,-0.25553E+00, & + -0.25552E+00,-0.25551E+00,-0.25551E+00,-0.25550E+00,-0.25550E+00, & + -0.25549E+00,-0.25549E+00,-0.25549E+00,-0.25548E+00,-0.25548E+00, & + -0.25548E+00,-0.25548E+00,-0.25548E+00,-0.25547E+00,-0.25547E+00, & + -0.25547E+00,-0.25548E+00,-0.25548E+00,-0.25548E+00,-0.25548E+00, & + -0.25548E+00,-0.25549E+00,-0.25549E+00,-0.25549E+00,-0.25550E+00, & + -0.25550E+00,-0.25551E+00,-0.25551E+00,-0.25552E+00,-0.25553E+00, & + -0.25553E+00,-0.25554E+00,-0.25555E+00,-0.25556E+00,-0.25557E+00, & + -0.25558E+00,-0.25559E+00,-0.25560E+00,-0.25561E+00,-0.25562E+00, & + -0.25563E+00,-0.25564E+00,-0.25565E+00,-0.25567E+00,-0.25568E+00, & + -0.25569E+00,-0.25571E+00,-0.25572E+00,-0.25574E+00,-0.25575E+00, & + -0.25577E+00,-0.25579E+00,-0.25580E+00,-0.25582E+00,-0.25584E+00, & + -0.25586E+00,-0.25588E+00,-0.25589E+00,-0.25591E+00,-0.25593E+00, & + -0.25595E+00,-0.25597E+00,-0.25600E+00,-0.25602E+00,-0.25604E+00, & + -0.25606E+00,-0.25609E+00,-0.25611E+00,-0.25613E+00,-0.25616E+00, & + -0.25618E+00,-0.25621E+00,-0.25623E+00,-0.25626E+00,-0.25628E+00, & + -0.25631E+00,-0.25634E+00,-0.25637E+00,-0.25639E+00,-0.25642E+00, & + -0.25645E+00,-0.25648E+00,-0.25651E+00,-0.25654E+00,-0.25657E+00, & + -0.25660E+00,-0.25663E+00,-0.25666E+00,-0.25670E+00,-0.25673E+00, & + -0.25676E+00,-0.25679E+00,-0.25683E+00,-0.25686E+00,-0.25699E+00/ + + DATA (BNC06M (I),I=601,700)/ & + -0.25730E+00,-0.25771E+00,-0.25816E+00,-0.25865E+00,-0.25917E+00, & + -0.25973E+00,-0.26033E+00,-0.26096E+00,-0.26163E+00,-0.26233E+00, & + -0.26307E+00,-0.26383E+00,-0.26463E+00,-0.26547E+00,-0.26633E+00, & + -0.26722E+00,-0.26815E+00,-0.26910E+00,-0.27009E+00,-0.27110E+00, & + -0.27214E+00,-0.27320E+00,-0.27430E+00,-0.27542E+00,-0.27657E+00, & + -0.27774E+00,-0.27894E+00,-0.28017E+00,-0.28142E+00,-0.28269E+00, & + -0.28399E+00,-0.28531E+00,-0.28666E+00,-0.28803E+00,-0.28942E+00, & + -0.29083E+00,-0.29226E+00,-0.29372E+00,-0.29520E+00,-0.29669E+00, & + -0.29821E+00,-0.29975E+00,-0.30131E+00,-0.30289E+00,-0.30449E+00, & + -0.30610E+00,-0.30774E+00,-0.30939E+00,-0.31107E+00,-0.31276E+00, & + -0.31447E+00,-0.31619E+00,-0.31794E+00,-0.31970E+00,-0.32147E+00, & + -0.32327E+00,-0.32508E+00,-0.32690E+00,-0.32875E+00,-0.33060E+00, & + -0.33248E+00,-0.33437E+00,-0.33627E+00,-0.33819E+00,-0.34012E+00, & + -0.34207E+00,-0.34403E+00,-0.34601E+00,-0.34800E+00,-0.35001E+00, & + -0.35203E+00,-0.35406E+00,-0.35610E+00,-0.35816E+00,-0.36023E+00, & + -0.36232E+00,-0.36441E+00,-0.36652E+00,-0.36864E+00,-0.37078E+00, & + -0.37292E+00,-0.37508E+00,-0.37725E+00,-0.37943E+00,-0.38162E+00, & + -0.38383E+00,-0.38604E+00,-0.38827E+00,-0.39051E+00,-0.39275E+00, & + -0.39501E+00,-0.39728E+00,-0.39956E+00,-0.40185E+00,-0.40415E+00, & + -0.40646E+00,-0.40879E+00,-0.41112E+00,-0.41346E+00,-0.41581E+00/ + + DATA (BNC06M(I),I=701,741)/ & + -0.41817E+00,-0.42054E+00,-0.42292E+00,-0.42530E+00,-0.42770E+00, & + -0.43011E+00,-0.43252E+00,-0.43495E+00,-0.43738E+00,-0.43982E+00, & + -0.44227E+00,-0.44473E+00,-0.44720E+00,-0.44967E+00,-0.45216E+00, & + -0.45465E+00,-0.45715E+00,-0.45966E+00,-0.46218E+00,-0.46470E+00, & + -0.46723E+00,-0.46977E+00,-0.47232E+00,-0.47487E+00,-0.47744E+00, & + -0.48001E+00,-0.48258E+00,-0.48517E+00,-0.48776E+00,-0.49036E+00, & + -0.49296E+00,-0.49558E+00,-0.49820E+00,-0.50082E+00,-0.50346E+00, & + -0.50610E+00,-0.50874E+00,-0.51140E+00,-0.51406E+00,-0.51672E+00, & + -0.51940E+00 & + / +! +! *** (2H, SO4) +! + DATA (BNC07M (I),I= 1,100)/ & + -0.11102E+00,-0.20302E+00,-0.26840E+00,-0.31329E+00,-0.34815E+00, & + -0.37690E+00,-0.40149E+00,-0.42304E+00,-0.44227E+00,-0.45966E+00, & + -0.47555E+00,-0.49020E+00,-0.50381E+00,-0.51652E+00,-0.52846E+00, & + -0.53971E+00,-0.55037E+00,-0.56050E+00,-0.57015E+00,-0.57937E+00, & + -0.58821E+00,-0.59669E+00,-0.60484E+00,-0.61271E+00,-0.62030E+00, & + -0.62763E+00,-0.63474E+00,-0.64162E+00,-0.64831E+00,-0.65480E+00, & + -0.66112E+00,-0.66727E+00,-0.67327E+00,-0.67912E+00,-0.68483E+00, & + -0.69041E+00,-0.69586E+00,-0.70120E+00,-0.70642E+00,-0.71154E+00, & + -0.71656E+00,-0.72147E+00,-0.72630E+00,-0.73104E+00,-0.73570E+00, & + -0.74027E+00,-0.74477E+00,-0.74919E+00,-0.75354E+00,-0.75782E+00, & + -0.76204E+00,-0.76619E+00,-0.77029E+00,-0.77432E+00,-0.77830E+00, & + -0.78222E+00,-0.78609E+00,-0.78991E+00,-0.79369E+00,-0.79741E+00, & + -0.80109E+00,-0.80472E+00,-0.80832E+00,-0.81187E+00,-0.81538E+00, & + -0.81885E+00,-0.82229E+00,-0.82569E+00,-0.82905E+00,-0.83239E+00, & + -0.83568E+00,-0.83895E+00,-0.84219E+00,-0.84539E+00,-0.84857E+00, & + -0.85172E+00,-0.85484E+00,-0.85793E+00,-0.86100E+00,-0.86405E+00, & + -0.86706E+00,-0.87006E+00,-0.87303E+00,-0.87598E+00,-0.87891E+00, & + -0.88182E+00,-0.88471E+00,-0.88757E+00,-0.89042E+00,-0.89325E+00, & + -0.89605E+00,-0.89885E+00,-0.90162E+00,-0.90437E+00,-0.90711E+00, & + -0.90983E+00,-0.91254E+00,-0.91522E+00,-0.91790E+00,-0.92056E+00/ + + DATA (BNC07M (I),I=101,200)/ & + -0.92320E+00,-0.92583E+00,-0.92844E+00,-0.93104E+00,-0.93362E+00, & + -0.93619E+00,-0.93875E+00,-0.94129E+00,-0.94382E+00,-0.94634E+00, & + -0.94885E+00,-0.95134E+00,-0.95382E+00,-0.95629E+00,-0.95874E+00, & + -0.96119E+00,-0.96362E+00,-0.96604E+00,-0.96845E+00,-0.97085E+00, & + -0.97321E+00,-0.97559E+00,-0.97796E+00,-0.98032E+00,-0.98267E+00, & + -0.98500E+00,-0.98733E+00,-0.98965E+00,-0.99196E+00,-0.99425E+00, & + -0.99654E+00,-0.99882E+00,-0.10011E+01,-0.10033E+01,-0.10056E+01, & + -0.10078E+01,-0.10101E+01,-0.10123E+01,-0.10145E+01,-0.10167E+01, & + -0.10189E+01,-0.10211E+01,-0.10233E+01,-0.10255E+01,-0.10276E+01, & + -0.10298E+01,-0.10319E+01,-0.10341E+01,-0.10362E+01,-0.10383E+01, & + -0.10405E+01,-0.10426E+01,-0.10447E+01,-0.10468E+01,-0.10489E+01, & + -0.10509E+01,-0.10530E+01,-0.10551E+01,-0.10572E+01,-0.10592E+01, & + -0.10613E+01,-0.10633E+01,-0.10653E+01,-0.10674E+01,-0.10694E+01, & + -0.10714E+01,-0.10734E+01,-0.10754E+01,-0.10775E+01,-0.10794E+01, & + -0.10814E+01,-0.10834E+01,-0.10854E+01,-0.10874E+01,-0.10893E+01, & + -0.10913E+01,-0.10933E+01,-0.10952E+01,-0.10972E+01,-0.10991E+01, & + -0.11010E+01,-0.11030E+01,-0.11049E+01,-0.11068E+01,-0.11087E+01, & + -0.11106E+01,-0.11126E+01,-0.11145E+01,-0.11164E+01,-0.11182E+01, & + -0.11201E+01,-0.11220E+01,-0.11239E+01,-0.11258E+01,-0.11276E+01, & + -0.11295E+01,-0.11314E+01,-0.11332E+01,-0.11351E+01,-0.11369E+01/ + + DATA (BNC07M (I),I=201,300)/ & + -0.11388E+01,-0.11406E+01,-0.11424E+01,-0.11443E+01,-0.11461E+01, & + -0.11479E+01,-0.11497E+01,-0.11516E+01,-0.11534E+01,-0.11552E+01, & + -0.11570E+01,-0.11588E+01,-0.11606E+01,-0.11624E+01,-0.11642E+01, & + -0.11659E+01,-0.11677E+01,-0.11695E+01,-0.11713E+01,-0.11730E+01, & + -0.11748E+01,-0.11766E+01,-0.11783E+01,-0.11801E+01,-0.11819E+01, & + -0.11836E+01,-0.11853E+01,-0.11871E+01,-0.11888E+01,-0.11906E+01, & + -0.11923E+01,-0.11940E+01,-0.11958E+01,-0.11975E+01,-0.11992E+01, & + -0.12009E+01,-0.12026E+01,-0.12044E+01,-0.12061E+01,-0.12078E+01, & + -0.12095E+01,-0.12112E+01,-0.12129E+01,-0.12146E+01,-0.12163E+01, & + -0.12179E+01,-0.12196E+01,-0.12213E+01,-0.12230E+01,-0.12247E+01, & + -0.12263E+01,-0.12280E+01,-0.12297E+01,-0.12313E+01,-0.12330E+01, & + -0.12347E+01,-0.12363E+01,-0.12380E+01,-0.12396E+01,-0.12413E+01, & + -0.12429E+01,-0.12446E+01,-0.12462E+01,-0.12479E+01,-0.12495E+01, & + -0.12511E+01,-0.12528E+01,-0.12544E+01,-0.12560E+01,-0.12577E+01, & + -0.12593E+01,-0.12609E+01,-0.12625E+01,-0.12641E+01,-0.12658E+01, & + -0.12674E+01,-0.12690E+01,-0.12706E+01,-0.12722E+01,-0.12738E+01, & + -0.12754E+01,-0.12770E+01,-0.12786E+01,-0.12802E+01,-0.12818E+01, & + -0.12834E+01,-0.12849E+01,-0.12865E+01,-0.12881E+01,-0.12897E+01, & + -0.12913E+01,-0.12929E+01,-0.12944E+01,-0.12960E+01,-0.12976E+01, & + -0.12991E+01,-0.13007E+01,-0.13023E+01,-0.13038E+01,-0.13054E+01/ + + DATA (BNC07M (I),I=301,400)/ & + -0.13070E+01,-0.13085E+01,-0.13101E+01,-0.13116E+01,-0.13132E+01, & + -0.13147E+01,-0.13163E+01,-0.13178E+01,-0.13194E+01,-0.13209E+01, & + -0.13224E+01,-0.13240E+01,-0.13255E+01,-0.13271E+01,-0.13286E+01, & + -0.13301E+01,-0.13316E+01,-0.13332E+01,-0.13347E+01,-0.13362E+01, & + -0.13378E+01,-0.13393E+01,-0.13408E+01,-0.13423E+01,-0.13438E+01, & + -0.13453E+01,-0.13468E+01,-0.13484E+01,-0.13499E+01,-0.13514E+01, & + -0.13529E+01,-0.13544E+01,-0.13559E+01,-0.13574E+01,-0.13589E+01, & + -0.13604E+01,-0.13619E+01,-0.13634E+01,-0.13649E+01,-0.13664E+01, & + -0.13679E+01,-0.13693E+01,-0.13708E+01,-0.13723E+01,-0.13738E+01, & + -0.13753E+01,-0.13768E+01,-0.13782E+01,-0.13797E+01,-0.13812E+01, & + -0.13827E+01,-0.13841E+01,-0.13856E+01,-0.13871E+01,-0.13886E+01, & + -0.13900E+01,-0.13915E+01,-0.13930E+01,-0.13944E+01,-0.13959E+01, & + -0.13973E+01,-0.13988E+01,-0.14003E+01,-0.14017E+01,-0.14032E+01, & + -0.14046E+01,-0.14061E+01,-0.14075E+01,-0.14090E+01,-0.14104E+01, & + -0.14119E+01,-0.14133E+01,-0.14148E+01,-0.14162E+01,-0.14176E+01, & + -0.14191E+01,-0.14205E+01,-0.14220E+01,-0.14234E+01,-0.14248E+01, & + -0.14263E+01,-0.14277E+01,-0.14291E+01,-0.14306E+01,-0.14320E+01, & + -0.14334E+01,-0.14349E+01,-0.14363E+01,-0.14377E+01,-0.14391E+01, & + -0.14406E+01,-0.14420E+01,-0.14434E+01,-0.14448E+01,-0.14462E+01, & + -0.14476E+01,-0.14491E+01,-0.14505E+01,-0.14519E+01,-0.14533E+01/ + + DATA (BNC07M (I),I=401,500)/ & + -0.14547E+01,-0.14561E+01,-0.14575E+01,-0.14589E+01,-0.14603E+01, & + -0.14617E+01,-0.14631E+01,-0.14646E+01,-0.14660E+01,-0.14674E+01, & + -0.14688E+01,-0.14702E+01,-0.14715E+01,-0.14729E+01,-0.14743E+01, & + -0.14757E+01,-0.14771E+01,-0.14785E+01,-0.14799E+01,-0.14813E+01, & + -0.14827E+01,-0.14841E+01,-0.14855E+01,-0.14868E+01,-0.14882E+01, & + -0.14896E+01,-0.14910E+01,-0.14924E+01,-0.14938E+01,-0.14951E+01, & + -0.14965E+01,-0.14979E+01,-0.14993E+01,-0.15007E+01,-0.15020E+01, & + -0.15034E+01,-0.15048E+01,-0.15061E+01,-0.15075E+01,-0.15089E+01, & + -0.15103E+01,-0.15116E+01,-0.15130E+01,-0.15144E+01,-0.15157E+01, & + -0.15171E+01,-0.15184E+01,-0.15198E+01,-0.15212E+01,-0.15225E+01, & + -0.15239E+01,-0.15252E+01,-0.15266E+01,-0.15280E+01,-0.15293E+01, & + -0.15307E+01,-0.15320E+01,-0.15334E+01,-0.15347E+01,-0.15361E+01, & + -0.15374E+01,-0.15388E+01,-0.15401E+01,-0.15415E+01,-0.15428E+01, & + -0.15442E+01,-0.15455E+01,-0.15469E+01,-0.15482E+01,-0.15495E+01, & + -0.15509E+01,-0.15522E+01,-0.15536E+01,-0.15549E+01,-0.15562E+01, & + -0.15576E+01,-0.15589E+01,-0.15603E+01,-0.15616E+01,-0.15629E+01, & + -0.15643E+01,-0.15656E+01,-0.15669E+01,-0.15683E+01,-0.15696E+01, & + -0.15709E+01,-0.15722E+01,-0.15736E+01,-0.15749E+01,-0.15762E+01, & + -0.15776E+01,-0.15789E+01,-0.15802E+01,-0.15815E+01,-0.15828E+01, & + -0.15842E+01,-0.15855E+01,-0.15868E+01,-0.15881E+01,-0.15894E+01/ + + DATA (BNC07M (I),I=501,600)/ & + -0.15908E+01,-0.15921E+01,-0.15934E+01,-0.15947E+01,-0.15960E+01, & + -0.15973E+01,-0.15987E+01,-0.16000E+01,-0.16013E+01,-0.16026E+01, & + -0.16039E+01,-0.16052E+01,-0.16065E+01,-0.16078E+01,-0.16091E+01, & + -0.16104E+01,-0.16117E+01,-0.16131E+01,-0.16144E+01,-0.16157E+01, & + -0.16170E+01,-0.16183E+01,-0.16196E+01,-0.16209E+01,-0.16222E+01, & + -0.16235E+01,-0.16248E+01,-0.16261E+01,-0.16274E+01,-0.16287E+01, & + -0.16300E+01,-0.16313E+01,-0.16325E+01,-0.16338E+01,-0.16351E+01, & + -0.16364E+01,-0.16377E+01,-0.16390E+01,-0.16403E+01,-0.16416E+01, & + -0.16429E+01,-0.16442E+01,-0.16455E+01,-0.16467E+01,-0.16480E+01, & + -0.16493E+01,-0.16506E+01,-0.16519E+01,-0.16532E+01,-0.16545E+01, & + -0.16557E+01,-0.16570E+01,-0.16583E+01,-0.16596E+01,-0.16609E+01, & + -0.16621E+01,-0.16634E+01,-0.16647E+01,-0.16660E+01,-0.16673E+01, & + -0.16685E+01,-0.16698E+01,-0.16711E+01,-0.16724E+01,-0.16736E+01, & + -0.16749E+01,-0.16762E+01,-0.16775E+01,-0.16787E+01,-0.16800E+01, & + -0.16813E+01,-0.16825E+01,-0.16838E+01,-0.16851E+01,-0.16863E+01, & + -0.16876E+01,-0.16889E+01,-0.16902E+01,-0.16914E+01,-0.16927E+01, & + -0.16939E+01,-0.16952E+01,-0.16965E+01,-0.16977E+01,-0.16990E+01, & + -0.17003E+01,-0.17015E+01,-0.17028E+01,-0.17040E+01,-0.17053E+01, & + -0.17066E+01,-0.17078E+01,-0.17091E+01,-0.17103E+01,-0.17116E+01, & + -0.17129E+01,-0.17141E+01,-0.17154E+01,-0.17166E+01,-0.17213E+01/ + + DATA (BNC07M (I),I=601,700)/ & + -0.17316E+01,-0.17441E+01,-0.17565E+01,-0.17688E+01,-0.17811E+01, & + -0.17934E+01,-0.18056E+01,-0.18178E+01,-0.18299E+01,-0.18420E+01, & + -0.18540E+01,-0.18660E+01,-0.18780E+01,-0.18899E+01,-0.19018E+01, & + -0.19136E+01,-0.19254E+01,-0.19372E+01,-0.19489E+01,-0.19607E+01, & + -0.19723E+01,-0.19840E+01,-0.19956E+01,-0.20072E+01,-0.20187E+01, & + -0.20302E+01,-0.20417E+01,-0.20532E+01,-0.20646E+01,-0.20760E+01, & + -0.20874E+01,-0.20988E+01,-0.21101E+01,-0.21214E+01,-0.21327E+01, & + -0.21440E+01,-0.21552E+01,-0.21664E+01,-0.21776E+01,-0.21888E+01, & + -0.21999E+01,-0.22110E+01,-0.22221E+01,-0.22332E+01,-0.22443E+01, & + -0.22553E+01,-0.22663E+01,-0.22773E+01,-0.22883E+01,-0.22992E+01, & + -0.23102E+01,-0.23211E+01,-0.23320E+01,-0.23429E+01,-0.23537E+01, & + -0.23646E+01,-0.23754E+01,-0.23862E+01,-0.23970E+01,-0.24078E+01, & + -0.24186E+01,-0.24293E+01,-0.24401E+01,-0.24508E+01,-0.24615E+01, & + -0.24722E+01,-0.24828E+01,-0.24935E+01,-0.25041E+01,-0.25148E+01, & + -0.25254E+01,-0.25360E+01,-0.25466E+01,-0.25571E+01,-0.25677E+01, & + -0.25782E+01,-0.25888E+01,-0.25993E+01,-0.26098E+01,-0.26203E+01, & + -0.26308E+01,-0.26412E+01,-0.26517E+01,-0.26621E+01,-0.26726E+01, & + -0.26830E+01,-0.26934E+01,-0.27038E+01,-0.27142E+01,-0.27245E+01, & + -0.27349E+01,-0.27453E+01,-0.27556E+01,-0.27659E+01,-0.27762E+01, & + -0.27866E+01,-0.27968E+01,-0.28071E+01,-0.28174E+01,-0.28277E+01/ + + DATA (BNC07M(I),I=701,741)/ & + -0.28379E+01,-0.28482E+01,-0.28584E+01,-0.28686E+01,-0.28788E+01, & + -0.28891E+01,-0.28992E+01,-0.29094E+01,-0.29196E+01,-0.29298E+01, & + -0.29399E+01,-0.29501E+01,-0.29602E+01,-0.29704E+01,-0.29805E+01, & + -0.29906E+01,-0.30007E+01,-0.30108E+01,-0.30209E+01,-0.30310E+01, & + -0.30410E+01,-0.30511E+01,-0.30612E+01,-0.30712E+01,-0.30812E+01, & + -0.30913E+01,-0.31013E+01,-0.31113E+01,-0.31213E+01,-0.31313E+01, & + -0.31413E+01,-0.31513E+01,-0.31613E+01,-0.31712E+01,-0.31812E+01, & + -0.31911E+01,-0.32011E+01,-0.32110E+01,-0.32210E+01,-0.32309E+01, & + -0.32408E+01 & + / +! +! *** (H, HSO4) +! + DATA (BNC08M (I),I= 1,100)/ & + -0.51043E-01,-0.86042E-01,-0.10613E+00,-0.11710E+00,-0.12372E+00, & + -0.12771E+00,-0.12990E+00,-0.13078E+00,-0.13062E+00,-0.12964E+00, & + -0.12796E+00,-0.12569E+00,-0.12291E+00,-0.11967E+00,-0.11602E+00, & + -0.11201E+00,-0.10765E+00,-0.10298E+00,-0.98013E-01,-0.92777E-01, & + -0.87285E-01,-0.81552E-01,-0.75590E-01,-0.69411E-01,-0.63026E-01, & + -0.56444E-01,-0.49675E-01,-0.42726E-01,-0.35606E-01,-0.28321E-01, & + -0.20880E-01,-0.13287E-01,-0.55488E-02, 0.23277E-02, 0.10337E-01, & + 0.18475E-01, 0.26735E-01, 0.35113E-01, 0.43603E-01, 0.52201E-01, & + 0.60903E-01, 0.69703E-01, 0.78599E-01, 0.87586E-01, 0.96660E-01, & + 0.10582E+00, 0.11506E+00, 0.12437E+00, 0.13376E+00, 0.14322E+00, & + 0.15274E+00, 0.16233E+00, 0.17199E+00, 0.18170E+00, 0.19147E+00, & + 0.20130E+00, 0.21119E+00, 0.22112E+00, 0.23111E+00, 0.24115E+00, & + 0.25124E+00, 0.26138E+00, 0.27157E+00, 0.28181E+00, 0.29209E+00, & + 0.30242E+00, 0.31280E+00, 0.32323E+00, 0.33370E+00, 0.34422E+00, & + 0.35480E+00, 0.36542E+00, 0.37609E+00, 0.38682E+00, 0.39759E+00, & + 0.40842E+00, 0.41931E+00, 0.43025E+00, 0.44124E+00, 0.45229E+00, & + 0.46340E+00, 0.47456E+00, 0.48578E+00, 0.49706E+00, 0.50840E+00, & + 0.51980E+00, 0.53126E+00, 0.54278E+00, 0.55435E+00, 0.56599E+00, & + 0.57768E+00, 0.58943E+00, 0.60124E+00, 0.61310E+00, 0.62502E+00, & + 0.63700E+00, 0.64902E+00, 0.66110E+00, 0.67322E+00, 0.68539E+00/ + + DATA (BNC08M (I),I=101,200)/ & + 0.69761E+00, 0.70987E+00, 0.72217E+00, 0.73451E+00, 0.74689E+00, & + 0.75930E+00, 0.77174E+00, 0.78422E+00, 0.79672E+00, 0.80925E+00, & + 0.82180E+00, 0.83437E+00, 0.84696E+00, 0.85957E+00, 0.87219E+00, & + 0.88482E+00, 0.89747E+00, 0.91012E+00, 0.92278E+00, 0.93544E+00, & + 0.94702E+00, 0.95981E+00, 0.97259E+00, 0.98535E+00, 0.99809E+00, & + 0.10108E+01, 0.10235E+01, 0.10362E+01, 0.10489E+01, 0.10616E+01, & + 0.10742E+01, 0.10869E+01, 0.10995E+01, 0.11121E+01, 0.11246E+01, & + 0.11372E+01, 0.11497E+01, 0.11622E+01, 0.11747E+01, 0.11872E+01, & + 0.11997E+01, 0.12121E+01, 0.12245E+01, 0.12369E+01, 0.12493E+01, & + 0.12616E+01, 0.12739E+01, 0.12862E+01, 0.12985E+01, 0.13108E+01, & + 0.13230E+01, 0.13352E+01, 0.13474E+01, 0.13595E+01, 0.13717E+01, & + 0.13838E+01, 0.13959E+01, 0.14079E+01, 0.14200E+01, 0.14320E+01, & + 0.14440E+01, 0.14559E+01, 0.14679E+01, 0.14798E+01, 0.14917E+01, & + 0.15036E+01, 0.15154E+01, 0.15272E+01, 0.15390E+01, 0.15508E+01, & + 0.15625E+01, 0.15742E+01, 0.15859E+01, 0.15976E+01, 0.16092E+01, & + 0.16209E+01, 0.16325E+01, 0.16440E+01, 0.16556E+01, 0.16671E+01, & + 0.16786E+01, 0.16900E+01, 0.17015E+01, 0.17129E+01, 0.17243E+01, & + 0.17356E+01, 0.17470E+01, 0.17583E+01, 0.17696E+01, 0.17809E+01, & + 0.17921E+01, 0.18033E+01, 0.18145E+01, 0.18257E+01, 0.18368E+01, & + 0.18479E+01, 0.18590E+01, 0.18701E+01, 0.18811E+01, 0.18921E+01/ + + DATA (BNC08M (I),I=201,300)/ & + 0.19031E+01, 0.19141E+01, 0.19250E+01, 0.19360E+01, 0.19468E+01, & + 0.19577E+01, 0.19686E+01, 0.19794E+01, 0.19902E+01, 0.20009E+01, & + 0.20117E+01, 0.20224E+01, 0.20331E+01, 0.20438E+01, 0.20544E+01, & + 0.20651E+01, 0.20757E+01, 0.20863E+01, 0.20968E+01, 0.21073E+01, & + 0.21179E+01, 0.21283E+01, 0.21388E+01, 0.21492E+01, 0.21597E+01, & + 0.21700E+01, 0.21804E+01, 0.21908E+01, 0.22011E+01, 0.22114E+01, & + 0.22217E+01, 0.22319E+01, 0.22422E+01, 0.22524E+01, 0.22625E+01, & + 0.22727E+01, 0.22829E+01, 0.22930E+01, 0.23031E+01, 0.23131E+01, & + 0.23232E+01, 0.23332E+01, 0.23432E+01, 0.23532E+01, 0.23632E+01, & + 0.23731E+01, 0.23830E+01, 0.23929E+01, 0.24028E+01, 0.24127E+01, & + 0.24225E+01, 0.24323E+01, 0.24421E+01, 0.24519E+01, 0.24616E+01, & + 0.24714E+01, 0.24811E+01, 0.24908E+01, 0.25004E+01, 0.25101E+01, & + 0.25197E+01, 0.25293E+01, 0.25389E+01, 0.25484E+01, 0.25580E+01, & + 0.25675E+01, 0.25770E+01, 0.25865E+01, 0.25960E+01, 0.26054E+01, & + 0.26148E+01, 0.26242E+01, 0.26336E+01, 0.26430E+01, 0.26523E+01, & + 0.26616E+01, 0.26709E+01, 0.26802E+01, 0.26895E+01, 0.26987E+01, & + 0.27079E+01, 0.27171E+01, 0.27263E+01, 0.27355E+01, 0.27446E+01, & + 0.27538E+01, 0.27629E+01, 0.27720E+01, 0.27810E+01, 0.27901E+01, & + 0.27991E+01, 0.28082E+01, 0.28171E+01, 0.28261E+01, 0.28351E+01, & + 0.28440E+01, 0.28530E+01, 0.28619E+01, 0.28707E+01, 0.28796E+01/ + + DATA (BNC08M (I),I=301,400)/ & + 0.28885E+01, 0.28973E+01, 0.29061E+01, 0.29149E+01, 0.29237E+01, & + 0.29325E+01, 0.29412E+01, 0.29499E+01, 0.29586E+01, 0.29673E+01, & + 0.29760E+01, 0.29847E+01, 0.29933E+01, 0.30019E+01, 0.30105E+01, & + 0.30191E+01, 0.30277E+01, 0.30363E+01, 0.30448E+01, 0.30533E+01, & + 0.30618E+01, 0.30703E+01, 0.30788E+01, 0.30872E+01, 0.30957E+01, & + 0.31041E+01, 0.31125E+01, 0.31209E+01, 0.31293E+01, 0.31376E+01, & + 0.31460E+01, 0.31543E+01, 0.31626E+01, 0.31709E+01, 0.31792E+01, & + 0.31874E+01, 0.31957E+01, 0.32039E+01, 0.32121E+01, 0.32203E+01, & + 0.32285E+01, 0.32366E+01, 0.32448E+01, 0.32529E+01, 0.32610E+01, & + 0.32691E+01, 0.32772E+01, 0.32853E+01, 0.32934E+01, 0.33014E+01, & + 0.33094E+01, 0.33175E+01, 0.33254E+01, 0.33334E+01, 0.33414E+01, & + 0.33494E+01, 0.33573E+01, 0.33652E+01, 0.33731E+01, 0.33810E+01, & + 0.33889E+01, 0.33968E+01, 0.34046E+01, 0.34124E+01, 0.34203E+01, & + 0.34281E+01, 0.34359E+01, 0.34436E+01, 0.34514E+01, 0.34592E+01, & + 0.34669E+01, 0.34746E+01, 0.34823E+01, 0.34900E+01, 0.34977E+01, & + 0.35054E+01, 0.35130E+01, 0.35206E+01, 0.35283E+01, 0.35359E+01, & + 0.35435E+01, 0.35511E+01, 0.35586E+01, 0.35662E+01, 0.35737E+01, & + 0.35813E+01, 0.35888E+01, 0.35963E+01, 0.36038E+01, 0.36112E+01, & + 0.36187E+01, 0.36262E+01, 0.36336E+01, 0.36410E+01, 0.36484E+01, & + 0.36558E+01, 0.36632E+01, 0.36706E+01, 0.36779E+01, 0.36853E+01/ + + DATA (BNC08M (I),I=401,500)/ & + 0.36926E+01, 0.36999E+01, 0.37072E+01, 0.37145E+01, 0.37218E+01, & + 0.37291E+01, 0.37363E+01, 0.37436E+01, 0.37508E+01, 0.37580E+01, & + 0.37652E+01, 0.37724E+01, 0.37796E+01, 0.37868E+01, 0.37939E+01, & + 0.38011E+01, 0.38082E+01, 0.38153E+01, 0.38225E+01, 0.38296E+01, & + 0.38366E+01, 0.38437E+01, 0.38508E+01, 0.38578E+01, 0.38649E+01, & + 0.38719E+01, 0.38789E+01, 0.38859E+01, 0.38929E+01, 0.38999E+01, & + 0.39068E+01, 0.39138E+01, 0.39207E+01, 0.39277E+01, 0.39346E+01, & + 0.39415E+01, 0.39484E+01, 0.39553E+01, 0.39622E+01, 0.39690E+01, & + 0.39759E+01, 0.39827E+01, 0.39895E+01, 0.39964E+01, 0.40032E+01, & + 0.40100E+01, 0.40167E+01, 0.40235E+01, 0.40303E+01, 0.40370E+01, & + 0.40438E+01, 0.40505E+01, 0.40572E+01, 0.40639E+01, 0.40706E+01, & + 0.40773E+01, 0.40840E+01, 0.40907E+01, 0.40973E+01, 0.41040E+01, & + 0.41106E+01, 0.41172E+01, 0.41238E+01, 0.41304E+01, 0.41370E+01, & + 0.41436E+01, 0.41502E+01, 0.41567E+01, 0.41633E+01, 0.41698E+01, & + 0.41763E+01, 0.41829E+01, 0.41894E+01, 0.41959E+01, 0.42024E+01, & + 0.42088E+01, 0.42153E+01, 0.42218E+01, 0.42282E+01, 0.42346E+01, & + 0.42411E+01, 0.42475E+01, 0.42539E+01, 0.42603E+01, 0.42667E+01, & + 0.42731E+01, 0.42794E+01, 0.42858E+01, 0.42921E+01, 0.42985E+01, & + 0.43048E+01, 0.43111E+01, 0.43174E+01, 0.43237E+01, 0.43300E+01, & + 0.43363E+01, 0.43426E+01, 0.43488E+01, 0.43551E+01, 0.43613E+01/ + + DATA (BNC08M (I),I=501,600)/ & + 0.43675E+01, 0.43738E+01, 0.43800E+01, 0.43862E+01, 0.43924E+01, & + 0.43986E+01, 0.44047E+01, 0.44109E+01, 0.44171E+01, 0.44232E+01, & + 0.44293E+01, 0.44355E+01, 0.44416E+01, 0.44477E+01, 0.44538E+01, & + 0.44599E+01, 0.44660E+01, 0.44721E+01, 0.44781E+01, 0.44842E+01, & + 0.44902E+01, 0.44963E+01, 0.45023E+01, 0.45083E+01, 0.45143E+01, & + 0.45203E+01, 0.45263E+01, 0.45323E+01, 0.45383E+01, 0.45443E+01, & + 0.45502E+01, 0.45562E+01, 0.45621E+01, 0.45681E+01, 0.45740E+01, & + 0.45799E+01, 0.45858E+01, 0.45917E+01, 0.45976E+01, 0.46035E+01, & + 0.46094E+01, 0.46152E+01, 0.46211E+01, 0.46269E+01, 0.46328E+01, & + 0.46386E+01, 0.46444E+01, 0.46502E+01, 0.46560E+01, 0.46618E+01, & + 0.46676E+01, 0.46734E+01, 0.46792E+01, 0.46849E+01, 0.46907E+01, & + 0.46965E+01, 0.47022E+01, 0.47079E+01, 0.47137E+01, 0.47194E+01, & + 0.47251E+01, 0.47308E+01, 0.47365E+01, 0.47422E+01, 0.47478E+01, & + 0.47535E+01, 0.47592E+01, 0.47648E+01, 0.47705E+01, 0.47761E+01, & + 0.47817E+01, 0.47873E+01, 0.47930E+01, 0.47986E+01, 0.48042E+01, & + 0.48098E+01, 0.48153E+01, 0.48209E+01, 0.48265E+01, 0.48320E+01, & + 0.48376E+01, 0.48431E+01, 0.48487E+01, 0.48542E+01, 0.48597E+01, & + 0.48652E+01, 0.48707E+01, 0.48762E+01, 0.48817E+01, 0.48872E+01, & + 0.48927E+01, 0.48982E+01, 0.49036E+01, 0.49091E+01, 0.49145E+01, & + 0.49200E+01, 0.49254E+01, 0.49308E+01, 0.49362E+01, 0.49565E+01/ + + DATA (BNC08M (I),I=601,700)/ & + 0.50007E+01, 0.50536E+01, 0.51058E+01, 0.51574E+01, 0.52083E+01, & + 0.52585E+01, 0.53082E+01, 0.53572E+01, 0.54056E+01, 0.54534E+01, & + 0.55007E+01, 0.55473E+01, 0.55935E+01, 0.56391E+01, 0.56841E+01, & + 0.57287E+01, 0.57727E+01, 0.58163E+01, 0.58594E+01, 0.59020E+01, & + 0.59441E+01, 0.59858E+01, 0.60270E+01, 0.60678E+01, 0.61081E+01, & + 0.61481E+01, 0.61876E+01, 0.62267E+01, 0.62654E+01, 0.63037E+01, & + 0.63416E+01, 0.63792E+01, 0.64164E+01, 0.64532E+01, 0.64897E+01, & + 0.65258E+01, 0.65615E+01, 0.65969E+01, 0.66320E+01, 0.66668E+01, & + 0.67012E+01, 0.67353E+01, 0.67691E+01, 0.68026E+01, 0.68358E+01, & + 0.68687E+01, 0.69013E+01, 0.69336E+01, 0.69656E+01, 0.69974E+01, & + 0.70288E+01, 0.70600E+01, 0.70910E+01, 0.71216E+01, 0.71520E+01, & + 0.71822E+01, 0.72121E+01, 0.72417E+01, 0.72711E+01, 0.73003E+01, & + 0.73292E+01, 0.73579E+01, 0.73864E+01, 0.74146E+01, 0.74426E+01, & + 0.74704E+01, 0.74980E+01, 0.75253E+01, 0.75524E+01, 0.75794E+01, & + 0.76061E+01, 0.76326E+01, 0.76589E+01, 0.76850E+01, 0.77110E+01, & + 0.77367E+01, 0.77622E+01, 0.77876E+01, 0.78127E+01, 0.78377E+01, & + 0.78625E+01, 0.78871E+01, 0.79115E+01, 0.79358E+01, 0.79599E+01, & + 0.79838E+01, 0.80075E+01, 0.80311E+01, 0.80545E+01, 0.80778E+01, & + 0.81009E+01, 0.81238E+01, 0.81466E+01, 0.81692E+01, 0.81916E+01, & + 0.82140E+01, 0.82361E+01, 0.82581E+01, 0.82800E+01, 0.83017E+01/ + + DATA (BNC08M(I),I=701,741)/ & + 0.83233E+01, 0.83447E+01, 0.83660E+01, 0.83872E+01, 0.84082E+01, & + 0.84291E+01, 0.84498E+01, 0.84704E+01, 0.84909E+01, 0.85113E+01, & + 0.85315E+01, 0.85516E+01, 0.85715E+01, 0.85914E+01, 0.86111E+01, & + 0.86307E+01, 0.86502E+01, 0.86695E+01, 0.86888E+01, 0.87079E+01, & + 0.87269E+01, 0.87458E+01, 0.87645E+01, 0.87832E+01, 0.88018E+01, & + 0.88202E+01, 0.88385E+01, 0.88567E+01, 0.88749E+01, 0.88929E+01, & + 0.89108E+01, 0.89286E+01, 0.89463E+01, 0.89638E+01, 0.89813E+01, & + 0.89987E+01, 0.90160E+01, 0.90332E+01, 0.90503E+01, 0.90673E+01, & + 0.90842E+01 & + / +! +! *** NH4HSO4 +! + DATA (BNC09M (I),I= 1,100)/ & + -0.54181E-01,-0.97084E-01,-0.12639E+00,-0.14587E+00,-0.16057E+00, & + -0.17236E+00,-0.18218E+00,-0.19054E+00,-0.19779E+00,-0.20414E+00, & + -0.20976E+00,-0.21476E+00,-0.21923E+00,-0.22324E+00,-0.22685E+00, & + -0.23009E+00,-0.23301E+00,-0.23563E+00,-0.23798E+00,-0.24008E+00, & + -0.24194E+00,-0.24359E+00,-0.24503E+00,-0.24629E+00,-0.24736E+00, & + -0.24827E+00,-0.24901E+00,-0.24959E+00,-0.25003E+00,-0.25033E+00, & + -0.25049E+00,-0.25052E+00,-0.25043E+00,-0.25022E+00,-0.24990E+00, & + -0.24946E+00,-0.24892E+00,-0.24827E+00,-0.24753E+00,-0.24669E+00, & + -0.24576E+00,-0.24473E+00,-0.24363E+00,-0.24244E+00,-0.24116E+00, & + -0.23982E+00,-0.23839E+00,-0.23690E+00,-0.23533E+00,-0.23370E+00, & + -0.23200E+00,-0.23024E+00,-0.22842E+00,-0.22654E+00,-0.22460E+00, & + -0.22261E+00,-0.22056E+00,-0.21846E+00,-0.21632E+00,-0.21412E+00, & + -0.21188E+00,-0.20959E+00,-0.20725E+00,-0.20487E+00,-0.20245E+00, & + -0.19999E+00,-0.19748E+00,-0.19494E+00,-0.19236E+00,-0.18974E+00, & + -0.18708E+00,-0.18439E+00,-0.18165E+00,-0.17889E+00,-0.17608E+00, & + -0.17324E+00,-0.17037E+00,-0.16746E+00,-0.16452E+00,-0.16154E+00, & + -0.15853E+00,-0.15549E+00,-0.15242E+00,-0.14931E+00,-0.14617E+00, & + -0.14300E+00,-0.13980E+00,-0.13656E+00,-0.13330E+00,-0.13001E+00, & + -0.12668E+00,-0.12333E+00,-0.11995E+00,-0.11655E+00,-0.11311E+00, & + -0.10965E+00,-0.10617E+00,-0.10266E+00,-0.99129E-01,-0.95574E-01/ + + DATA (BNC09M (I),I=101,200)/ & + -0.91997E-01,-0.88400E-01,-0.84784E-01,-0.81148E-01,-0.77495E-01, & + -0.73825E-01,-0.70139E-01,-0.66438E-01,-0.62724E-01,-0.58997E-01, & + -0.55258E-01,-0.51509E-01,-0.47750E-01,-0.43981E-01,-0.40206E-01, & + -0.36423E-01,-0.32634E-01,-0.28839E-01,-0.25041E-01,-0.21238E-01, & + -0.17814E-01,-0.13963E-01,-0.10114E-01,-0.62690E-02,-0.24276E-02, & + 0.14101E-02, 0.52436E-02, 0.90727E-02, 0.12897E-01, 0.16717E-01, & + 0.20532E-01, 0.24341E-01, 0.28145E-01, 0.31943E-01, 0.35736E-01, & + 0.39522E-01, 0.43302E-01, 0.47075E-01, 0.50843E-01, 0.54603E-01, & + 0.58356E-01, 0.62103E-01, 0.65842E-01, 0.69575E-01, 0.73300E-01, & + 0.77017E-01, 0.80727E-01, 0.84429E-01, 0.88124E-01, 0.91811E-01, & + 0.95490E-01, 0.99161E-01, 0.10282E+00, 0.10648E+00, 0.11012E+00, & + 0.11376E+00, 0.11739E+00, 0.12102E+00, 0.12463E+00, 0.12823E+00, & + 0.13183E+00, 0.13542E+00, 0.13900E+00, 0.14257E+00, 0.14613E+00, & + 0.14968E+00, 0.15323E+00, 0.15677E+00, 0.16029E+00, 0.16381E+00, & + 0.16732E+00, 0.17082E+00, 0.17432E+00, 0.17780E+00, 0.18128E+00, & + 0.18474E+00, 0.18820E+00, 0.19165E+00, 0.19509E+00, 0.19852E+00, & + 0.20194E+00, 0.20536E+00, 0.20876E+00, 0.21216E+00, 0.21555E+00, & + 0.21892E+00, 0.22229E+00, 0.22566E+00, 0.22901E+00, 0.23235E+00, & + 0.23569E+00, 0.23902E+00, 0.24233E+00, 0.24564E+00, 0.24894E+00, & + 0.25224E+00, 0.25552E+00, 0.25880E+00, 0.26206E+00, 0.26532E+00/ + + DATA (BNC09M (I),I=201,300)/ & + 0.26857E+00, 0.27181E+00, 0.27505E+00, 0.27827E+00, 0.28149E+00, & + 0.28470E+00, 0.28790E+00, 0.29109E+00, 0.29427E+00, 0.29745E+00, & + 0.30061E+00, 0.30377E+00, 0.30692E+00, 0.31007E+00, 0.31320E+00, & + 0.31633E+00, 0.31944E+00, 0.32255E+00, 0.32566E+00, 0.32875E+00, & + 0.33184E+00, 0.33492E+00, 0.33799E+00, 0.34105E+00, 0.34410E+00, & + 0.34715E+00, 0.35019E+00, 0.35322E+00, 0.35625E+00, 0.35926E+00, & + 0.36227E+00, 0.36527E+00, 0.36827E+00, 0.37125E+00, 0.37423E+00, & + 0.37720E+00, 0.38017E+00, 0.38312E+00, 0.38607E+00, 0.38901E+00, & + 0.39195E+00, 0.39487E+00, 0.39779E+00, 0.40070E+00, 0.40361E+00, & + 0.40651E+00, 0.40940E+00, 0.41228E+00, 0.41516E+00, 0.41803E+00, & + 0.42089E+00, 0.42374E+00, 0.42659E+00, 0.42943E+00, 0.43227E+00, & + 0.43509E+00, 0.43791E+00, 0.44073E+00, 0.44354E+00, 0.44634E+00, & + 0.44913E+00, 0.45192E+00, 0.45469E+00, 0.45747E+00, 0.46023E+00, & + 0.46299E+00, 0.46575E+00, 0.46849E+00, 0.47123E+00, 0.47397E+00, & + 0.47670E+00, 0.47942E+00, 0.48213E+00, 0.48484E+00, 0.48754E+00, & + 0.49023E+00, 0.49292E+00, 0.49561E+00, 0.49828E+00, 0.50095E+00, & + 0.50362E+00, 0.50627E+00, 0.50892E+00, 0.51157E+00, 0.51421E+00, & + 0.51684E+00, 0.51947E+00, 0.52209E+00, 0.52470E+00, 0.52731E+00, & + 0.52991E+00, 0.53251E+00, 0.53510E+00, 0.53769E+00, 0.54027E+00, & + 0.54284E+00, 0.54541E+00, 0.54797E+00, 0.55052E+00, 0.55307E+00/ + + DATA (BNC09M (I),I=301,400)/ & + 0.55562E+00, 0.55816E+00, 0.56069E+00, 0.56321E+00, 0.56574E+00, & + 0.56825E+00, 0.57076E+00, 0.57327E+00, 0.57576E+00, 0.57826E+00, & + 0.58075E+00, 0.58323E+00, 0.58570E+00, 0.58818E+00, 0.59064E+00, & + 0.59310E+00, 0.59556E+00, 0.59801E+00, 0.60045E+00, 0.60289E+00, & + 0.60532E+00, 0.60775E+00, 0.61017E+00, 0.61259E+00, 0.61500E+00, & + 0.61741E+00, 0.61981E+00, 0.62221E+00, 0.62460E+00, 0.62699E+00, & + 0.62937E+00, 0.63175E+00, 0.63412E+00, 0.63648E+00, 0.63885E+00, & + 0.64120E+00, 0.64355E+00, 0.64590E+00, 0.64824E+00, 0.65058E+00, & + 0.65291E+00, 0.65523E+00, 0.65755E+00, 0.65987E+00, 0.66218E+00, & + 0.66449E+00, 0.66679E+00, 0.66909E+00, 0.67138E+00, 0.67367E+00, & + 0.67595E+00, 0.67823E+00, 0.68050E+00, 0.68277E+00, 0.68503E+00, & + 0.68729E+00, 0.68955E+00, 0.69180E+00, 0.69404E+00, 0.69628E+00, & + 0.69852E+00, 0.70075E+00, 0.70298E+00, 0.70520E+00, 0.70742E+00, & + 0.70963E+00, 0.71184E+00, 0.71405E+00, 0.71625E+00, 0.71844E+00, & + 0.72063E+00, 0.72282E+00, 0.72500E+00, 0.72718E+00, 0.72935E+00, & + 0.73152E+00, 0.73369E+00, 0.73585E+00, 0.73800E+00, 0.74015E+00, & + 0.74230E+00, 0.74444E+00, 0.74658E+00, 0.74872E+00, 0.75085E+00, & + 0.75297E+00, 0.75510E+00, 0.75721E+00, 0.75933E+00, 0.76144E+00, & + 0.76354E+00, 0.76564E+00, 0.76774E+00, 0.76983E+00, 0.77192E+00, & + 0.77401E+00, 0.77609E+00, 0.77817E+00, 0.78024E+00, 0.78231E+00/ + + DATA (BNC09M (I),I=401,500)/ & + 0.78437E+00, 0.78643E+00, 0.78849E+00, 0.79054E+00, 0.79259E+00, & + 0.79464E+00, 0.79668E+00, 0.79871E+00, 0.80075E+00, 0.80278E+00, & + 0.80480E+00, 0.80682E+00, 0.80884E+00, 0.81085E+00, 0.81286E+00, & + 0.81487E+00, 0.81687E+00, 0.81887E+00, 0.82087E+00, 0.82286E+00, & + 0.82484E+00, 0.82683E+00, 0.82881E+00, 0.83078E+00, 0.83275E+00, & + 0.83472E+00, 0.83669E+00, 0.83865E+00, 0.84061E+00, 0.84256E+00, & + 0.84451E+00, 0.84646E+00, 0.84840E+00, 0.85034E+00, 0.85228E+00, & + 0.85421E+00, 0.85614E+00, 0.85806E+00, 0.85998E+00, 0.86190E+00, & + 0.86382E+00, 0.86573E+00, 0.86763E+00, 0.86954E+00, 0.87144E+00, & + 0.87333E+00, 0.87523E+00, 0.87712E+00, 0.87900E+00, 0.88089E+00, & + 0.88277E+00, 0.88464E+00, 0.88652E+00, 0.88839E+00, 0.89025E+00, & + 0.89212E+00, 0.89397E+00, 0.89583E+00, 0.89768E+00, 0.89953E+00, & + 0.90138E+00, 0.90322E+00, 0.90506E+00, 0.90690E+00, 0.90873E+00, & + 0.91056E+00, 0.91239E+00, 0.91421E+00, 0.91603E+00, 0.91784E+00, & + 0.91966E+00, 0.92147E+00, 0.92327E+00, 0.92508E+00, 0.92688E+00, & + 0.92868E+00, 0.93047E+00, 0.93226E+00, 0.93405E+00, 0.93583E+00, & + 0.93761E+00, 0.93939E+00, 0.94117E+00, 0.94294E+00, 0.94471E+00, & + 0.94648E+00, 0.94824E+00, 0.95000E+00, 0.95175E+00, 0.95351E+00, & + 0.95526E+00, 0.95701E+00, 0.95875E+00, 0.96049E+00, 0.96223E+00, & + 0.96397E+00, 0.96570E+00, 0.96743E+00, 0.96915E+00, 0.97088E+00/ + + DATA (BNC09M (I),I=501,600)/ & + 0.97260E+00, 0.97432E+00, 0.97603E+00, 0.97774E+00, 0.97945E+00, & + 0.98116E+00, 0.98286E+00, 0.98456E+00, 0.98626E+00, 0.98795E+00, & + 0.98964E+00, 0.99133E+00, 0.99302E+00, 0.99470E+00, 0.99638E+00, & + 0.99806E+00, 0.99973E+00, 0.10014E+01, 0.10031E+01, 0.10047E+01, & + 0.10064E+01, 0.10081E+01, 0.10097E+01, 0.10114E+01, 0.10130E+01, & + 0.10147E+01, 0.10163E+01, 0.10180E+01, 0.10196E+01, 0.10212E+01, & + 0.10229E+01, 0.10245E+01, 0.10261E+01, 0.10278E+01, 0.10294E+01, & + 0.10310E+01, 0.10326E+01, 0.10342E+01, 0.10359E+01, 0.10375E+01, & + 0.10391E+01, 0.10407E+01, 0.10423E+01, 0.10439E+01, 0.10455E+01, & + 0.10471E+01, 0.10487E+01, 0.10503E+01, 0.10519E+01, 0.10534E+01, & + 0.10550E+01, 0.10566E+01, 0.10582E+01, 0.10598E+01, 0.10613E+01, & + 0.10629E+01, 0.10645E+01, 0.10660E+01, 0.10676E+01, 0.10691E+01, & + 0.10707E+01, 0.10723E+01, 0.10738E+01, 0.10754E+01, 0.10769E+01, & + 0.10784E+01, 0.10800E+01, 0.10815E+01, 0.10831E+01, 0.10846E+01, & + 0.10861E+01, 0.10877E+01, 0.10892E+01, 0.10907E+01, 0.10922E+01, & + 0.10938E+01, 0.10953E+01, 0.10968E+01, 0.10983E+01, 0.10998E+01, & + 0.11013E+01, 0.11028E+01, 0.11043E+01, 0.11058E+01, 0.11073E+01, & + 0.11088E+01, 0.11103E+01, 0.11118E+01, 0.11133E+01, 0.11148E+01, & + 0.11163E+01, 0.11177E+01, 0.11192E+01, 0.11207E+01, 0.11222E+01, & + 0.11236E+01, 0.11251E+01, 0.11266E+01, 0.11280E+01, 0.11335E+01/ + + DATA (BNC09M (I),I=601,700)/ & + 0.11454E+01, 0.11597E+01, 0.11737E+01, 0.11876E+01, 0.12012E+01, & + 0.12146E+01, 0.12278E+01, 0.12409E+01, 0.12537E+01, 0.12663E+01, & + 0.12788E+01, 0.12911E+01, 0.13032E+01, 0.13152E+01, 0.13270E+01, & + 0.13386E+01, 0.13500E+01, 0.13613E+01, 0.13725E+01, 0.13835E+01, & + 0.13943E+01, 0.14050E+01, 0.14156E+01, 0.14260E+01, 0.14363E+01, & + 0.14464E+01, 0.14564E+01, 0.14663E+01, 0.14761E+01, 0.14857E+01, & + 0.14952E+01, 0.15046E+01, 0.15139E+01, 0.15231E+01, 0.15321E+01, & + 0.15410E+01, 0.15499E+01, 0.15586E+01, 0.15672E+01, 0.15757E+01, & + 0.15841E+01, 0.15923E+01, 0.16005E+01, 0.16086E+01, 0.16166E+01, & + 0.16245E+01, 0.16323E+01, 0.16400E+01, 0.16477E+01, 0.16552E+01, & + 0.16626E+01, 0.16700E+01, 0.16773E+01, 0.16845E+01, 0.16916E+01, & + 0.16986E+01, 0.17055E+01, 0.17124E+01, 0.17192E+01, 0.17259E+01, & + 0.17325E+01, 0.17390E+01, 0.17455E+01, 0.17519E+01, 0.17583E+01, & + 0.17645E+01, 0.17707E+01, 0.17768E+01, 0.17829E+01, 0.17889E+01, & + 0.17948E+01, 0.18006E+01, 0.18064E+01, 0.18121E+01, 0.18178E+01, & + 0.18234E+01, 0.18289E+01, 0.18344E+01, 0.18398E+01, 0.18452E+01, & + 0.18505E+01, 0.18557E+01, 0.18609E+01, 0.18660E+01, 0.18711E+01, & + 0.18761E+01, 0.18811E+01, 0.18860E+01, 0.18908E+01, 0.18956E+01, & + 0.19004E+01, 0.19050E+01, 0.19097E+01, 0.19143E+01, 0.19188E+01, & + 0.19233E+01, 0.19278E+01, 0.19322E+01, 0.19365E+01, 0.19408E+01/ + + DATA (BNC09M(I),I=701,741)/ & + 0.19451E+01, 0.19493E+01, 0.19535E+01, 0.19576E+01, 0.19616E+01, & + 0.19657E+01, 0.19697E+01, 0.19736E+01, 0.19775E+01, 0.19814E+01, & + 0.19852E+01, 0.19890E+01, 0.19927E+01, 0.19964E+01, 0.20001E+01, & + 0.20037E+01, 0.20073E+01, 0.20108E+01, 0.20143E+01, 0.20178E+01, & + 0.20212E+01, 0.20246E+01, 0.20279E+01, 0.20312E+01, 0.20345E+01, & + 0.20378E+01, 0.20410E+01, 0.20441E+01, 0.20473E+01, 0.20504E+01, & + 0.20534E+01, 0.20565E+01, 0.20595E+01, 0.20624E+01, 0.20654E+01, & + 0.20683E+01, 0.20711E+01, 0.20740E+01, 0.20768E+01, 0.20796E+01, & + 0.20823E+01 & + / +! +! *** (H, NO3) +! + DATA (BNC10M (I),I= 1,100)/ & + -0.53284E-01,-0.93378E-01,-0.11890E+00,-0.13461E+00,-0.14557E+00, & + -0.15369E+00,-0.15987E+00,-0.16466E+00,-0.16839E+00,-0.17129E+00, & + -0.17352E+00,-0.17519E+00,-0.17640E+00,-0.17722E+00,-0.17770E+00, & + -0.17789E+00,-0.17782E+00,-0.17753E+00,-0.17704E+00,-0.17638E+00, & + -0.17556E+00,-0.17459E+00,-0.17350E+00,-0.17230E+00,-0.17099E+00, & + -0.16959E+00,-0.16811E+00,-0.16655E+00,-0.16492E+00,-0.16323E+00, & + -0.16149E+00,-0.15969E+00,-0.15785E+00,-0.15596E+00,-0.15404E+00, & + -0.15208E+00,-0.15010E+00,-0.14808E+00,-0.14604E+00,-0.14398E+00, & + -0.14191E+00,-0.13981E+00,-0.13770E+00,-0.13557E+00,-0.13344E+00, & + -0.13129E+00,-0.12914E+00,-0.12698E+00,-0.12481E+00,-0.12264E+00, & + -0.12046E+00,-0.11828E+00,-0.11609E+00,-0.11390E+00,-0.11171E+00, & + -0.10952E+00,-0.10732E+00,-0.10512E+00,-0.10292E+00,-0.10071E+00, & + -0.98502E-01,-0.96290E-01,-0.94074E-01,-0.91854E-01,-0.89629E-01, & + -0.87399E-01,-0.85162E-01,-0.82919E-01,-0.80669E-01,-0.78411E-01, & + -0.76144E-01,-0.73868E-01,-0.71581E-01,-0.69284E-01,-0.66975E-01, & + -0.64655E-01,-0.62321E-01,-0.59973E-01,-0.57612E-01,-0.55236E-01, & + -0.52844E-01,-0.50437E-01,-0.48014E-01,-0.45574E-01,-0.43117E-01, & + -0.40643E-01,-0.38151E-01,-0.35641E-01,-0.33114E-01,-0.30569E-01, & + -0.28006E-01,-0.25426E-01,-0.22827E-01,-0.20212E-01,-0.17578E-01, & + -0.14928E-01,-0.12262E-01,-0.95788E-02,-0.68800E-02,-0.41657E-02/ + + DATA (BNC10M (I),I=101,200)/ & + -0.14365E-02, 0.13072E-02, 0.40646E-02, 0.68354E-02, 0.96189E-02, & + 0.12415E-01, 0.15222E-01, 0.18040E-01, 0.20868E-01, 0.23706E-01, & + 0.26553E-01, 0.29408E-01, 0.32271E-01, 0.35141E-01, 0.38017E-01, & + 0.40900E-01, 0.43787E-01, 0.46680E-01, 0.49577E-01, 0.52478E-01, & + 0.55030E-01, 0.57977E-01, 0.60923E-01, 0.63866E-01, 0.66808E-01, & + 0.69748E-01, 0.72686E-01, 0.75621E-01, 0.78554E-01, 0.81485E-01, & + 0.84414E-01, 0.87340E-01, 0.90263E-01, 0.93184E-01, 0.96103E-01, & + 0.99018E-01, 0.10193E+00, 0.10484E+00, 0.10775E+00, 0.11065E+00, & + 0.11355E+00, 0.11645E+00, 0.11934E+00, 0.12224E+00, 0.12512E+00, & + 0.12801E+00, 0.13089E+00, 0.13377E+00, 0.13664E+00, 0.13951E+00, & + 0.14238E+00, 0.14525E+00, 0.14811E+00, 0.15097E+00, 0.15382E+00, & + 0.15667E+00, 0.15951E+00, 0.16236E+00, 0.16520E+00, 0.16803E+00, & + 0.17086E+00, 0.17369E+00, 0.17651E+00, 0.17933E+00, 0.18215E+00, & + 0.18496E+00, 0.18776E+00, 0.19057E+00, 0.19337E+00, 0.19616E+00, & + 0.19895E+00, 0.20174E+00, 0.20452E+00, 0.20730E+00, 0.21008E+00, & + 0.21285E+00, 0.21561E+00, 0.21837E+00, 0.22113E+00, 0.22389E+00, & + 0.22663E+00, 0.22938E+00, 0.23212E+00, 0.23486E+00, 0.23759E+00, & + 0.24032E+00, 0.24304E+00, 0.24576E+00, 0.24847E+00, 0.25118E+00, & + 0.25389E+00, 0.25659E+00, 0.25929E+00, 0.26198E+00, 0.26467E+00, & + 0.26735E+00, 0.27003E+00, 0.27270E+00, 0.27537E+00, 0.27804E+00/ + + DATA (BNC10M (I),I=201,300)/ & + 0.28070E+00, 0.28336E+00, 0.28601E+00, 0.28866E+00, 0.29130E+00, & + 0.29394E+00, 0.29657E+00, 0.29920E+00, 0.30183E+00, 0.30445E+00, & + 0.30707E+00, 0.30968E+00, 0.31229E+00, 0.31489E+00, 0.31749E+00, & + 0.32008E+00, 0.32267E+00, 0.32525E+00, 0.32783E+00, 0.33041E+00, & + 0.33298E+00, 0.33555E+00, 0.33811E+00, 0.34067E+00, 0.34322E+00, & + 0.34577E+00, 0.34831E+00, 0.35085E+00, 0.35339E+00, 0.35592E+00, & + 0.35844E+00, 0.36097E+00, 0.36348E+00, 0.36599E+00, 0.36850E+00, & + 0.37101E+00, 0.37351E+00, 0.37600E+00, 0.37849E+00, 0.38098E+00, & + 0.38346E+00, 0.38593E+00, 0.38840E+00, 0.39087E+00, 0.39334E+00, & + 0.39579E+00, 0.39825E+00, 0.40070E+00, 0.40314E+00, 0.40558E+00, & + 0.40802E+00, 0.41045E+00, 0.41288E+00, 0.41530E+00, 0.41772E+00, & + 0.42014E+00, 0.42255E+00, 0.42495E+00, 0.42735E+00, 0.42975E+00, & + 0.43214E+00, 0.43453E+00, 0.43691E+00, 0.43929E+00, 0.44167E+00, & + 0.44404E+00, 0.44640E+00, 0.44877E+00, 0.45112E+00, 0.45348E+00, & + 0.45583E+00, 0.45817E+00, 0.46051E+00, 0.46285E+00, 0.46518E+00, & + 0.46751E+00, 0.46983E+00, 0.47215E+00, 0.47446E+00, 0.47677E+00, & + 0.47908E+00, 0.48138E+00, 0.48368E+00, 0.48597E+00, 0.48826E+00, & + 0.49054E+00, 0.49283E+00, 0.49510E+00, 0.49737E+00, 0.49964E+00, & + 0.50191E+00, 0.50417E+00, 0.50642E+00, 0.50867E+00, 0.51092E+00, & + 0.51316E+00, 0.51540E+00, 0.51764E+00, 0.51987E+00, 0.52210E+00/ + + DATA (BNC10M (I),I=301,400)/ & + 0.52432E+00, 0.52654E+00, 0.52875E+00, 0.53096E+00, 0.53317E+00, & + 0.53537E+00, 0.53757E+00, 0.53976E+00, 0.54195E+00, 0.54414E+00, & + 0.54632E+00, 0.54850E+00, 0.55067E+00, 0.55284E+00, 0.55501E+00, & + 0.55717E+00, 0.55933E+00, 0.56148E+00, 0.56363E+00, 0.56578E+00, & + 0.56792E+00, 0.57006E+00, 0.57219E+00, 0.57433E+00, 0.57645E+00, & + 0.57857E+00, 0.58069E+00, 0.58281E+00, 0.58492E+00, 0.58703E+00, & + 0.58913E+00, 0.59123E+00, 0.59333E+00, 0.59542E+00, 0.59751E+00, & + 0.59959E+00, 0.60167E+00, 0.60375E+00, 0.60582E+00, 0.60789E+00, & + 0.60996E+00, 0.61202E+00, 0.61407E+00, 0.61613E+00, 0.61818E+00, & + 0.62023E+00, 0.62227E+00, 0.62431E+00, 0.62634E+00, 0.62838E+00, & + 0.63040E+00, 0.63243E+00, 0.63445E+00, 0.63647E+00, 0.63848E+00, & + 0.64049E+00, 0.64250E+00, 0.64450E+00, 0.64650E+00, 0.64849E+00, & + 0.65049E+00, 0.65247E+00, 0.65446E+00, 0.65644E+00, 0.65842E+00, & + 0.66039E+00, 0.66236E+00, 0.66433E+00, 0.66629E+00, 0.66825E+00, & + 0.67021E+00, 0.67216E+00, 0.67411E+00, 0.67606E+00, 0.67800E+00, & + 0.67994E+00, 0.68187E+00, 0.68380E+00, 0.68573E+00, 0.68766E+00, & + 0.68958E+00, 0.69150E+00, 0.69341E+00, 0.69532E+00, 0.69723E+00, & + 0.69914E+00, 0.70104E+00, 0.70294E+00, 0.70483E+00, 0.70672E+00, & + 0.70861E+00, 0.71049E+00, 0.71237E+00, 0.71425E+00, 0.71613E+00, & + 0.71800E+00, 0.71986E+00, 0.72173E+00, 0.72359E+00, 0.72545E+00/ + + DATA (BNC10M (I),I=401,500)/ & + 0.72730E+00, 0.72915E+00, 0.73100E+00, 0.73285E+00, 0.73469E+00, & + 0.73653E+00, 0.73836E+00, 0.74019E+00, 0.74202E+00, 0.74385E+00, & + 0.74567E+00, 0.74749E+00, 0.74930E+00, 0.75112E+00, 0.75293E+00, & + 0.75473E+00, 0.75654E+00, 0.75834E+00, 0.76013E+00, 0.76193E+00, & + 0.76372E+00, 0.76550E+00, 0.76729E+00, 0.76907E+00, 0.77085E+00, & + 0.77262E+00, 0.77439E+00, 0.77616E+00, 0.77793E+00, 0.77969E+00, & + 0.78145E+00, 0.78321E+00, 0.78496E+00, 0.78671E+00, 0.78846E+00, & + 0.79021E+00, 0.79195E+00, 0.79369E+00, 0.79542E+00, 0.79715E+00, & + 0.79888E+00, 0.80061E+00, 0.80233E+00, 0.80405E+00, 0.80577E+00, & + 0.80749E+00, 0.80920E+00, 0.81091E+00, 0.81261E+00, 0.81432E+00, & + 0.81602E+00, 0.81771E+00, 0.81941E+00, 0.82110E+00, 0.82279E+00, & + 0.82448E+00, 0.82616E+00, 0.82784E+00, 0.82952E+00, 0.83119E+00, & + 0.83286E+00, 0.83453E+00, 0.83620E+00, 0.83786E+00, 0.83952E+00, & + 0.84118E+00, 0.84283E+00, 0.84448E+00, 0.84613E+00, 0.84778E+00, & + 0.84942E+00, 0.85106E+00, 0.85270E+00, 0.85434E+00, 0.85597E+00, & + 0.85760E+00, 0.85922E+00, 0.86085E+00, 0.86247E+00, 0.86409E+00, & + 0.86571E+00, 0.86732E+00, 0.86893E+00, 0.87054E+00, 0.87214E+00, & + 0.87375E+00, 0.87535E+00, 0.87694E+00, 0.87854E+00, 0.88013E+00, & + 0.88172E+00, 0.88331E+00, 0.88489E+00, 0.88647E+00, 0.88805E+00, & + 0.88963E+00, 0.89120E+00, 0.89277E+00, 0.89434E+00, 0.89590E+00/ + + DATA (BNC10M (I),I=501,600)/ & + 0.89747E+00, 0.89903E+00, 0.90059E+00, 0.90214E+00, 0.90369E+00, & + 0.90524E+00, 0.90679E+00, 0.90834E+00, 0.90988E+00, 0.91142E+00, & + 0.91296E+00, 0.91449E+00, 0.91603E+00, 0.91756E+00, 0.91908E+00, & + 0.92061E+00, 0.92213E+00, 0.92365E+00, 0.92517E+00, 0.92668E+00, & + 0.92820E+00, 0.92971E+00, 0.93122E+00, 0.93272E+00, 0.93422E+00, & + 0.93572E+00, 0.93722E+00, 0.93872E+00, 0.94021E+00, 0.94170E+00, & + 0.94319E+00, 0.94468E+00, 0.94616E+00, 0.94764E+00, 0.94912E+00, & + 0.95060E+00, 0.95207E+00, 0.95354E+00, 0.95501E+00, 0.95648E+00, & + 0.95794E+00, 0.95940E+00, 0.96086E+00, 0.96232E+00, 0.96378E+00, & + 0.96523E+00, 0.96668E+00, 0.96813E+00, 0.96957E+00, 0.97102E+00, & + 0.97246E+00, 0.97390E+00, 0.97533E+00, 0.97677E+00, 0.97820E+00, & + 0.97963E+00, 0.98106E+00, 0.98248E+00, 0.98391E+00, 0.98533E+00, & + 0.98674E+00, 0.98816E+00, 0.98957E+00, 0.99099E+00, 0.99240E+00, & + 0.99380E+00, 0.99521E+00, 0.99661E+00, 0.99801E+00, 0.99941E+00, & + 0.10008E+01, 0.10022E+01, 0.10036E+01, 0.10050E+01, 0.10064E+01, & + 0.10078E+01, 0.10091E+01, 0.10105E+01, 0.10119E+01, 0.10133E+01, & + 0.10146E+01, 0.10160E+01, 0.10174E+01, 0.10188E+01, 0.10201E+01, & + 0.10215E+01, 0.10228E+01, 0.10242E+01, 0.10256E+01, 0.10269E+01, & + 0.10283E+01, 0.10296E+01, 0.10310E+01, 0.10323E+01, 0.10337E+01, & + 0.10350E+01, 0.10363E+01, 0.10377E+01, 0.10390E+01, 0.10440E+01/ + + DATA (BNC10M (I),I=601,700)/ & + 0.10549E+01, 0.10679E+01, 0.10807E+01, 0.10933E+01, 0.11058E+01, & + 0.11180E+01, 0.11301E+01, 0.11420E+01, 0.11537E+01, 0.11652E+01, & + 0.11766E+01, 0.11878E+01, 0.11989E+01, 0.12098E+01, 0.12205E+01, & + 0.12311E+01, 0.12415E+01, 0.12518E+01, 0.12620E+01, 0.12720E+01, & + 0.12819E+01, 0.12916E+01, 0.13012E+01, 0.13107E+01, 0.13201E+01, & + 0.13293E+01, 0.13384E+01, 0.13474E+01, 0.13562E+01, 0.13650E+01, & + 0.13736E+01, 0.13821E+01, 0.13905E+01, 0.13988E+01, 0.14070E+01, & + 0.14151E+01, 0.14231E+01, 0.14310E+01, 0.14388E+01, 0.14464E+01, & + 0.14540E+01, 0.14615E+01, 0.14689E+01, 0.14762E+01, 0.14834E+01, & + 0.14906E+01, 0.14976E+01, 0.15045E+01, 0.15114E+01, 0.15182E+01, & + 0.15249E+01, 0.15315E+01, 0.15380E+01, 0.15444E+01, 0.15508E+01, & + 0.15571E+01, 0.15633E+01, 0.15695E+01, 0.15755E+01, 0.15815E+01, & + 0.15875E+01, 0.15933E+01, 0.15991E+01, 0.16048E+01, 0.16105E+01, & + 0.16160E+01, 0.16215E+01, 0.16270E+01, 0.16324E+01, 0.16377E+01, & + 0.16429E+01, 0.16481E+01, 0.16533E+01, 0.16583E+01, 0.16634E+01, & + 0.16683E+01, 0.16732E+01, 0.16780E+01, 0.16828E+01, 0.16875E+01, & + 0.16922E+01, 0.16968E+01, 0.17014E+01, 0.17059E+01, 0.17104E+01, & + 0.17148E+01, 0.17191E+01, 0.17234E+01, 0.17277E+01, 0.17319E+01, & + 0.17360E+01, 0.17401E+01, 0.17442E+01, 0.17482E+01, 0.17521E+01, & + 0.17560E+01, 0.17599E+01, 0.17637E+01, 0.17675E+01, 0.17712E+01/ + + DATA (BNC10M(I),I=701,741)/ & + 0.17749E+01, 0.17786E+01, 0.17822E+01, 0.17858E+01, 0.17893E+01, & + 0.17927E+01, 0.17962E+01, 0.17996E+01, 0.18029E+01, 0.18063E+01, & + 0.18095E+01, 0.18128E+01, 0.18160E+01, 0.18191E+01, 0.18223E+01, & + 0.18253E+01, 0.18284E+01, 0.18314E+01, 0.18344E+01, 0.18373E+01, & + 0.18402E+01, 0.18431E+01, 0.18459E+01, 0.18487E+01, 0.18515E+01, & + 0.18542E+01, 0.18569E+01, 0.18596E+01, 0.18623E+01, 0.18649E+01, & + 0.18674E+01, 0.18700E+01, 0.18725E+01, 0.18749E+01, 0.18774E+01, & + 0.18798E+01, 0.18822E+01, 0.18845E+01, 0.18869E+01, 0.18892E+01, & + 0.18914E+01 & + / +! +! *** (H, Cl) +! + DATA (BNC11M (I),I= 1,100)/ & + -0.51530E-01,-0.87364E-01,-0.10805E+00,-0.11938E+00,-0.12621E+00, & + -0.13034E+00,-0.13263E+00,-0.13358E+00,-0.13351E+00,-0.13262E+00, & + -0.13105E+00,-0.12892E+00,-0.12631E+00,-0.12328E+00,-0.11989E+00, & + -0.11617E+00,-0.11216E+00,-0.10789E+00,-0.10338E+00,-0.98657E-01, & + -0.93734E-01,-0.88627E-01,-0.83353E-01,-0.77922E-01,-0.72347E-01, & + -0.66638E-01,-0.60804E-01,-0.54854E-01,-0.48795E-01,-0.42636E-01, & + -0.36382E-01,-0.30040E-01,-0.23617E-01,-0.17116E-01,-0.10545E-01, & + -0.39064E-02, 0.27939E-02, 0.95516E-02, 0.16363E-01, 0.23224E-01, & + 0.30132E-01, 0.37082E-01, 0.44072E-01, 0.51099E-01, 0.58160E-01, & + 0.65253E-01, 0.72375E-01, 0.79524E-01, 0.86699E-01, 0.93897E-01, & + 0.10112E+00, 0.10836E+00, 0.11562E+00, 0.12290E+00, 0.13019E+00, & + 0.13750E+00, 0.14483E+00, 0.15218E+00, 0.15954E+00, 0.16691E+00, & + 0.17430E+00, 0.18171E+00, 0.18913E+00, 0.19657E+00, 0.20403E+00, & + 0.21151E+00, 0.21900E+00, 0.22652E+00, 0.23405E+00, 0.24161E+00, & + 0.24919E+00, 0.25680E+00, 0.26443E+00, 0.27209E+00, 0.27977E+00, & + 0.28749E+00, 0.29523E+00, 0.30301E+00, 0.31082E+00, 0.31867E+00, & + 0.32655E+00, 0.33446E+00, 0.34241E+00, 0.35040E+00, 0.35843E+00, & + 0.36650E+00, 0.37461E+00, 0.38275E+00, 0.39094E+00, 0.39916E+00, & + 0.40743E+00, 0.41574E+00, 0.42408E+00, 0.43246E+00, 0.44088E+00, & + 0.44934E+00, 0.45784E+00, 0.46637E+00, 0.47494E+00, 0.48354E+00/ + + DATA (BNC11M (I),I=101,200)/ & + 0.49217E+00, 0.50083E+00, 0.50952E+00, 0.51825E+00, 0.52699E+00, & + 0.53577E+00, 0.54456E+00, 0.55338E+00, 0.56222E+00, 0.57108E+00, & + 0.57996E+00, 0.58885E+00, 0.59776E+00, 0.60668E+00, 0.61561E+00, & + 0.62456E+00, 0.63351E+00, 0.64246E+00, 0.65143E+00, 0.66039E+00, & + 0.66855E+00, 0.67762E+00, 0.68668E+00, 0.69573E+00, 0.70477E+00, & + 0.71380E+00, 0.72282E+00, 0.73183E+00, 0.74082E+00, 0.74981E+00, & + 0.75879E+00, 0.76776E+00, 0.77671E+00, 0.78566E+00, 0.79459E+00, & + 0.80351E+00, 0.81241E+00, 0.82131E+00, 0.83019E+00, 0.83906E+00, & + 0.84792E+00, 0.85676E+00, 0.86559E+00, 0.87440E+00, 0.88321E+00, & + 0.89200E+00, 0.90077E+00, 0.90953E+00, 0.91827E+00, 0.92701E+00, & + 0.93572E+00, 0.94443E+00, 0.95311E+00, 0.96178E+00, 0.97044E+00, & + 0.97908E+00, 0.98771E+00, 0.99632E+00, 0.10049E+01, 0.10135E+01, & + 0.10221E+01, 0.10306E+01, 0.10392E+01, 0.10477E+01, 0.10562E+01, & + 0.10647E+01, 0.10731E+01, 0.10816E+01, 0.10900E+01, 0.10984E+01, & + 0.11069E+01, 0.11152E+01, 0.11236E+01, 0.11320E+01, 0.11403E+01, & + 0.11486E+01, 0.11570E+01, 0.11652E+01, 0.11735E+01, 0.11818E+01, & + 0.11900E+01, 0.11983E+01, 0.12065E+01, 0.12147E+01, 0.12228E+01, & + 0.12310E+01, 0.12391E+01, 0.12473E+01, 0.12554E+01, 0.12635E+01, & + 0.12716E+01, 0.12796E+01, 0.12877E+01, 0.12957E+01, 0.13037E+01, & + 0.13117E+01, 0.13197E+01, 0.13276E+01, 0.13356E+01, 0.13435E+01/ + + DATA (BNC11M (I),I=201,300)/ & + 0.13514E+01, 0.13593E+01, 0.13672E+01, 0.13751E+01, 0.13829E+01, & + 0.13908E+01, 0.13986E+01, 0.14064E+01, 0.14142E+01, 0.14219E+01, & + 0.14297E+01, 0.14374E+01, 0.14451E+01, 0.14528E+01, 0.14605E+01, & + 0.14682E+01, 0.14758E+01, 0.14835E+01, 0.14911E+01, 0.14987E+01, & + 0.15063E+01, 0.15139E+01, 0.15214E+01, 0.15289E+01, 0.15365E+01, & + 0.15440E+01, 0.15515E+01, 0.15590E+01, 0.15664E+01, 0.15739E+01, & + 0.15813E+01, 0.15887E+01, 0.15961E+01, 0.16035E+01, 0.16109E+01, & + 0.16182E+01, 0.16255E+01, 0.16329E+01, 0.16402E+01, 0.16475E+01, & + 0.16547E+01, 0.16620E+01, 0.16692E+01, 0.16765E+01, 0.16837E+01, & + 0.16909E+01, 0.16981E+01, 0.17052E+01, 0.17124E+01, 0.17195E+01, & + 0.17266E+01, 0.17338E+01, 0.17408E+01, 0.17479E+01, 0.17550E+01, & + 0.17620E+01, 0.17691E+01, 0.17761E+01, 0.17831E+01, 0.17901E+01, & + 0.17971E+01, 0.18040E+01, 0.18110E+01, 0.18179E+01, 0.18248E+01, & + 0.18317E+01, 0.18386E+01, 0.18455E+01, 0.18524E+01, 0.18592E+01, & + 0.18660E+01, 0.18729E+01, 0.18797E+01, 0.18865E+01, 0.18932E+01, & + 0.19000E+01, 0.19068E+01, 0.19135E+01, 0.19202E+01, 0.19269E+01, & + 0.19336E+01, 0.19403E+01, 0.19470E+01, 0.19536E+01, 0.19603E+01, & + 0.19669E+01, 0.19735E+01, 0.19801E+01, 0.19867E+01, 0.19933E+01, & + 0.19998E+01, 0.20064E+01, 0.20129E+01, 0.20194E+01, 0.20259E+01, & + 0.20324E+01, 0.20389E+01, 0.20454E+01, 0.20518E+01, 0.20583E+01/ + + DATA (BNC11M (I),I=301,400)/ & + 0.20647E+01, 0.20711E+01, 0.20775E+01, 0.20839E+01, 0.20903E+01, & + 0.20967E+01, 0.21030E+01, 0.21093E+01, 0.21157E+01, 0.21220E+01, & + 0.21283E+01, 0.21346E+01, 0.21409E+01, 0.21471E+01, 0.21534E+01, & + 0.21596E+01, 0.21659E+01, 0.21721E+01, 0.21783E+01, 0.21845E+01, & + 0.21907E+01, 0.21968E+01, 0.22030E+01, 0.22091E+01, 0.22153E+01, & + 0.22214E+01, 0.22275E+01, 0.22336E+01, 0.22397E+01, 0.22457E+01, & + 0.22518E+01, 0.22579E+01, 0.22639E+01, 0.22699E+01, 0.22759E+01, & + 0.22819E+01, 0.22879E+01, 0.22939E+01, 0.22999E+01, 0.23058E+01, & + 0.23118E+01, 0.23177E+01, 0.23237E+01, 0.23296E+01, 0.23355E+01, & + 0.23414E+01, 0.23472E+01, 0.23531E+01, 0.23590E+01, 0.23648E+01, & + 0.23707E+01, 0.23765E+01, 0.23823E+01, 0.23881E+01, 0.23939E+01, & + 0.23997E+01, 0.24054E+01, 0.24112E+01, 0.24170E+01, 0.24227E+01, & + 0.24284E+01, 0.24341E+01, 0.24398E+01, 0.24455E+01, 0.24512E+01, & + 0.24569E+01, 0.24626E+01, 0.24682E+01, 0.24739E+01, 0.24795E+01, & + 0.24851E+01, 0.24907E+01, 0.24963E+01, 0.25019E+01, 0.25075E+01, & + 0.25131E+01, 0.25187E+01, 0.25242E+01, 0.25298E+01, 0.25353E+01, & + 0.25408E+01, 0.25463E+01, 0.25518E+01, 0.25573E+01, 0.25628E+01, & + 0.25683E+01, 0.25737E+01, 0.25792E+01, 0.25846E+01, 0.25901E+01, & + 0.25955E+01, 0.26009E+01, 0.26063E+01, 0.26117E+01, 0.26171E+01, & + 0.26225E+01, 0.26278E+01, 0.26332E+01, 0.26386E+01, 0.26439E+01/ + + DATA (BNC11M (I),I=401,500)/ & + 0.26492E+01, 0.26545E+01, 0.26599E+01, 0.26652E+01, 0.26704E+01, & + 0.26757E+01, 0.26810E+01, 0.26863E+01, 0.26915E+01, 0.26968E+01, & + 0.27020E+01, 0.27072E+01, 0.27125E+01, 0.27177E+01, 0.27229E+01, & + 0.27281E+01, 0.27332E+01, 0.27384E+01, 0.27436E+01, 0.27487E+01, & + 0.27539E+01, 0.27590E+01, 0.27642E+01, 0.27693E+01, 0.27744E+01, & + 0.27795E+01, 0.27846E+01, 0.27897E+01, 0.27948E+01, 0.27998E+01, & + 0.28049E+01, 0.28100E+01, 0.28150E+01, 0.28200E+01, 0.28251E+01, & + 0.28301E+01, 0.28351E+01, 0.28401E+01, 0.28451E+01, 0.28501E+01, & + 0.28551E+01, 0.28600E+01, 0.28650E+01, 0.28699E+01, 0.28749E+01, & + 0.28798E+01, 0.28847E+01, 0.28897E+01, 0.28946E+01, 0.28995E+01, & + 0.29044E+01, 0.29093E+01, 0.29141E+01, 0.29190E+01, 0.29239E+01, & + 0.29287E+01, 0.29336E+01, 0.29384E+01, 0.29433E+01, 0.29481E+01, & + 0.29529E+01, 0.29577E+01, 0.29625E+01, 0.29673E+01, 0.29721E+01, & + 0.29769E+01, 0.29816E+01, 0.29864E+01, 0.29911E+01, 0.29959E+01, & + 0.30006E+01, 0.30054E+01, 0.30101E+01, 0.30148E+01, 0.30195E+01, & + 0.30242E+01, 0.30289E+01, 0.30336E+01, 0.30383E+01, 0.30430E+01, & + 0.30476E+01, 0.30523E+01, 0.30569E+01, 0.30616E+01, 0.30662E+01, & + 0.30708E+01, 0.30754E+01, 0.30801E+01, 0.30847E+01, 0.30893E+01, & + 0.30939E+01, 0.30984E+01, 0.31030E+01, 0.31076E+01, 0.31122E+01, & + 0.31167E+01, 0.31213E+01, 0.31258E+01, 0.31303E+01, 0.31349E+01/ + + DATA (BNC11M (I),I=501,600)/ & + 0.31394E+01, 0.31439E+01, 0.31484E+01, 0.31529E+01, 0.31574E+01, & + 0.31619E+01, 0.31664E+01, 0.31708E+01, 0.31753E+01, 0.31798E+01, & + 0.31842E+01, 0.31887E+01, 0.31931E+01, 0.31975E+01, 0.32020E+01, & + 0.32064E+01, 0.32108E+01, 0.32152E+01, 0.32196E+01, 0.32240E+01, & + 0.32284E+01, 0.32327E+01, 0.32371E+01, 0.32415E+01, 0.32458E+01, & + 0.32502E+01, 0.32545E+01, 0.32589E+01, 0.32632E+01, 0.32675E+01, & + 0.32718E+01, 0.32762E+01, 0.32805E+01, 0.32848E+01, 0.32891E+01, & + 0.32934E+01, 0.32976E+01, 0.33019E+01, 0.33062E+01, 0.33104E+01, & + 0.33147E+01, 0.33189E+01, 0.33232E+01, 0.33274E+01, 0.33317E+01, & + 0.33359E+01, 0.33401E+01, 0.33443E+01, 0.33485E+01, 0.33527E+01, & + 0.33569E+01, 0.33611E+01, 0.33653E+01, 0.33695E+01, 0.33736E+01, & + 0.33778E+01, 0.33819E+01, 0.33861E+01, 0.33902E+01, 0.33944E+01, & + 0.33985E+01, 0.34026E+01, 0.34068E+01, 0.34109E+01, 0.34150E+01, & + 0.34191E+01, 0.34232E+01, 0.34273E+01, 0.34314E+01, 0.34355E+01, & + 0.34395E+01, 0.34436E+01, 0.34477E+01, 0.34517E+01, 0.34558E+01, & + 0.34598E+01, 0.34639E+01, 0.34679E+01, 0.34719E+01, 0.34759E+01, & + 0.34800E+01, 0.34840E+01, 0.34880E+01, 0.34920E+01, 0.34960E+01, & + 0.35000E+01, 0.35040E+01, 0.35079E+01, 0.35119E+01, 0.35159E+01, & + 0.35198E+01, 0.35238E+01, 0.35277E+01, 0.35317E+01, 0.35356E+01, & + 0.35396E+01, 0.35435E+01, 0.35474E+01, 0.35513E+01, 0.35660E+01/ + + DATA (BNC11M (I),I=601,700)/ & + 0.35979E+01, 0.36362E+01, 0.36739E+01, 0.37112E+01, 0.37479E+01, & + 0.37842E+01, 0.38200E+01, 0.38554E+01, 0.38903E+01, 0.39247E+01, & + 0.39588E+01, 0.39924E+01, 0.40256E+01, 0.40584E+01, 0.40909E+01, & + 0.41229E+01, 0.41546E+01, 0.41859E+01, 0.42168E+01, 0.42474E+01, & + 0.42776E+01, 0.43075E+01, 0.43371E+01, 0.43664E+01, 0.43953E+01, & + 0.44239E+01, 0.44522E+01, 0.44802E+01, 0.45079E+01, 0.45353E+01, & + 0.45624E+01, 0.45893E+01, 0.46158E+01, 0.46421E+01, 0.46681E+01, & + 0.46939E+01, 0.47194E+01, 0.47447E+01, 0.47697E+01, 0.47944E+01, & + 0.48190E+01, 0.48432E+01, 0.48673E+01, 0.48911E+01, 0.49147E+01, & + 0.49381E+01, 0.49612E+01, 0.49842E+01, 0.50069E+01, 0.50294E+01, & + 0.50517E+01, 0.50738E+01, 0.50958E+01, 0.51175E+01, 0.51390E+01, & + 0.51603E+01, 0.51815E+01, 0.52024E+01, 0.52232E+01, 0.52438E+01, & + 0.52643E+01, 0.52845E+01, 0.53046E+01, 0.53245E+01, 0.53442E+01, & + 0.53638E+01, 0.53832E+01, 0.54025E+01, 0.54216E+01, 0.54405E+01, & + 0.54593E+01, 0.54779E+01, 0.54964E+01, 0.55147E+01, 0.55329E+01, & + 0.55510E+01, 0.55689E+01, 0.55866E+01, 0.56043E+01, 0.56217E+01, & + 0.56391E+01, 0.56563E+01, 0.56734E+01, 0.56903E+01, 0.57072E+01, & + 0.57239E+01, 0.57404E+01, 0.57569E+01, 0.57732E+01, 0.57894E+01, & + 0.58055E+01, 0.58215E+01, 0.58373E+01, 0.58530E+01, 0.58687E+01, & + 0.58842E+01, 0.58996E+01, 0.59148E+01, 0.59300E+01, 0.59451E+01/ + + DATA (BNC11M(I),I=701,741)/ & + 0.59600E+01, 0.59749E+01, 0.59896E+01, 0.60043E+01, 0.60188E+01, & + 0.60333E+01, 0.60476E+01, 0.60619E+01, 0.60760E+01, 0.60901E+01, & + 0.61040E+01, 0.61179E+01, 0.61316E+01, 0.61453E+01, 0.61589E+01, & + 0.61724E+01, 0.61858E+01, 0.61991E+01, 0.62123E+01, 0.62254E+01, & + 0.62385E+01, 0.62514E+01, 0.62643E+01, 0.62771E+01, 0.62898E+01, & + 0.63024E+01, 0.63150E+01, 0.63274E+01, 0.63398E+01, 0.63521E+01, & + 0.63644E+01, 0.63765E+01, 0.63886E+01, 0.64006E+01, 0.64125E+01, & + 0.64243E+01, 0.64361E+01, 0.64478E+01, 0.64594E+01, 0.64710E+01, & + 0.64825E+01 & + / +! +! *** NaHSO4 +! + DATA (BNC12M (I),I= 1,100)/ & + -0.53059E-01,-0.92995E-01,-0.11872E+00,-0.13483E+00,-0.14630E+00, & + -0.15498E+00,-0.16174E+00,-0.16712E+00,-0.17143E+00,-0.17489E+00, & + -0.17765E+00,-0.17982E+00,-0.18150E+00,-0.18274E+00,-0.18359E+00, & + -0.18411E+00,-0.18432E+00,-0.18425E+00,-0.18392E+00,-0.18337E+00, & + -0.18259E+00,-0.18162E+00,-0.18045E+00,-0.17912E+00,-0.17761E+00, & + -0.17595E+00,-0.17414E+00,-0.17219E+00,-0.17011E+00,-0.16790E+00, & + -0.16557E+00,-0.16313E+00,-0.16057E+00,-0.15791E+00,-0.15515E+00, & + -0.15229E+00,-0.14934E+00,-0.14630E+00,-0.14318E+00,-0.13997E+00, & + -0.13669E+00,-0.13333E+00,-0.12990E+00,-0.12640E+00,-0.12284E+00, & + -0.11921E+00,-0.11552E+00,-0.11177E+00,-0.10796E+00,-0.10410E+00, & + -0.10019E+00,-0.96227E-01,-0.92215E-01,-0.88157E-01,-0.84053E-01, & + -0.79905E-01,-0.75715E-01,-0.71483E-01,-0.67210E-01,-0.62899E-01, & + -0.58548E-01,-0.54161E-01,-0.49736E-01,-0.45274E-01,-0.40777E-01, & + -0.36244E-01,-0.31676E-01,-0.27073E-01,-0.22436E-01,-0.17763E-01, & + -0.13056E-01,-0.83143E-02,-0.35376E-02, 0.12738E-02, 0.61202E-02, & + 0.11002E-01, 0.15919E-01, 0.20871E-01, 0.25859E-01, 0.30883E-01, & + 0.35942E-01, 0.41038E-01, 0.46170E-01, 0.51337E-01, 0.56541E-01, & + 0.61781E-01, 0.67057E-01, 0.72367E-01, 0.77714E-01, 0.83095E-01, & + 0.88511E-01, 0.93961E-01, 0.99444E-01, 0.10496E+00, 0.11051E+00, & + 0.11609E+00, 0.12170E+00, 0.12733E+00, 0.13300E+00, 0.13870E+00/ + + DATA (BNC12M (I),I=101,200)/ & + 0.14442E+00, 0.15016E+00, 0.15593E+00, 0.16173E+00, 0.16754E+00, & + 0.17337E+00, 0.17923E+00, 0.18510E+00, 0.19099E+00, 0.19689E+00, & + 0.20280E+00, 0.20873E+00, 0.21467E+00, 0.22062E+00, 0.22658E+00, & + 0.23255E+00, 0.23852E+00, 0.24450E+00, 0.25048E+00, 0.25647E+00, & + 0.26188E+00, 0.26794E+00, 0.27399E+00, 0.28003E+00, 0.28607E+00, & + 0.29209E+00, 0.29812E+00, 0.30413E+00, 0.31014E+00, 0.31613E+00, & + 0.32212E+00, 0.32811E+00, 0.33408E+00, 0.34004E+00, 0.34600E+00, & + 0.35194E+00, 0.35788E+00, 0.36380E+00, 0.36972E+00, 0.37562E+00, & + 0.38152E+00, 0.38740E+00, 0.39328E+00, 0.39914E+00, 0.40500E+00, & + 0.41084E+00, 0.41667E+00, 0.42249E+00, 0.42830E+00, 0.43410E+00, & + 0.43989E+00, 0.44567E+00, 0.45143E+00, 0.45719E+00, 0.46293E+00, & + 0.46866E+00, 0.47438E+00, 0.48008E+00, 0.48578E+00, 0.49146E+00, & + 0.49713E+00, 0.50279E+00, 0.50844E+00, 0.51408E+00, 0.51970E+00, & + 0.52531E+00, 0.53091E+00, 0.53650E+00, 0.54208E+00, 0.54764E+00, & + 0.55319E+00, 0.55873E+00, 0.56426E+00, 0.56978E+00, 0.57528E+00, & + 0.58077E+00, 0.58625E+00, 0.59172E+00, 0.59717E+00, 0.60261E+00, & + 0.60804E+00, 0.61346E+00, 0.61887E+00, 0.62426E+00, 0.62965E+00, & + 0.63502E+00, 0.64038E+00, 0.64572E+00, 0.65106E+00, 0.65638E+00, & + 0.66169E+00, 0.66699E+00, 0.67227E+00, 0.67755E+00, 0.68281E+00, & + 0.68806E+00, 0.69330E+00, 0.69853E+00, 0.70375E+00, 0.70895E+00/ + + DATA (BNC12M (I),I=201,300)/ & + 0.71414E+00, 0.71932E+00, 0.72449E+00, 0.72965E+00, 0.73479E+00, & + 0.73993E+00, 0.74505E+00, 0.75016E+00, 0.75526E+00, 0.76035E+00, & + 0.76543E+00, 0.77049E+00, 0.77554E+00, 0.78059E+00, 0.78562E+00, & + 0.79064E+00, 0.79565E+00, 0.80064E+00, 0.80563E+00, 0.81061E+00, & + 0.81557E+00, 0.82052E+00, 0.82547E+00, 0.83040E+00, 0.83532E+00, & + 0.84023E+00, 0.84512E+00, 0.85001E+00, 0.85489E+00, 0.85975E+00, & + 0.86461E+00, 0.86945E+00, 0.87429E+00, 0.87911E+00, 0.88392E+00, & + 0.88873E+00, 0.89352E+00, 0.89830E+00, 0.90307E+00, 0.90783E+00, & + 0.91258E+00, 0.91732E+00, 0.92205E+00, 0.92677E+00, 0.93148E+00, & + 0.93617E+00, 0.94086E+00, 0.94554E+00, 0.95021E+00, 0.95487E+00, & + 0.95951E+00, 0.96415E+00, 0.96878E+00, 0.97340E+00, 0.97801E+00, & + 0.98260E+00, 0.98719E+00, 0.99177E+00, 0.99634E+00, 0.10009E+01, & + 0.10054E+01, 0.10100E+01, 0.10145E+01, 0.10190E+01, 0.10235E+01, & + 0.10281E+01, 0.10325E+01, 0.10370E+01, 0.10415E+01, 0.10460E+01, & + 0.10504E+01, 0.10549E+01, 0.10593E+01, 0.10637E+01, 0.10681E+01, & + 0.10725E+01, 0.10769E+01, 0.10813E+01, 0.10857E+01, 0.10901E+01, & + 0.10945E+01, 0.10988E+01, 0.11031E+01, 0.11075E+01, 0.11118E+01, & + 0.11161E+01, 0.11204E+01, 0.11247E+01, 0.11290E+01, 0.11333E+01, & + 0.11376E+01, 0.11419E+01, 0.11461E+01, 0.11504E+01, 0.11546E+01, & + 0.11588E+01, 0.11631E+01, 0.11673E+01, 0.11715E+01, 0.11757E+01/ + + DATA (BNC12M (I),I=301,400)/ & + 0.11799E+01, 0.11840E+01, 0.11882E+01, 0.11924E+01, 0.11965E+01, & + 0.12007E+01, 0.12048E+01, 0.12089E+01, 0.12131E+01, 0.12172E+01, & + 0.12213E+01, 0.12254E+01, 0.12295E+01, 0.12336E+01, 0.12376E+01, & + 0.12417E+01, 0.12457E+01, 0.12498E+01, 0.12538E+01, 0.12579E+01, & + 0.12619E+01, 0.12659E+01, 0.12699E+01, 0.12739E+01, 0.12779E+01, & + 0.12819E+01, 0.12859E+01, 0.12899E+01, 0.12938E+01, 0.12978E+01, & + 0.13017E+01, 0.13057E+01, 0.13096E+01, 0.13135E+01, 0.13175E+01, & + 0.13214E+01, 0.13253E+01, 0.13292E+01, 0.13331E+01, 0.13369E+01, & + 0.13408E+01, 0.13447E+01, 0.13485E+01, 0.13524E+01, 0.13562E+01, & + 0.13601E+01, 0.13639E+01, 0.13677E+01, 0.13715E+01, 0.13754E+01, & + 0.13792E+01, 0.13829E+01, 0.13867E+01, 0.13905E+01, 0.13943E+01, & + 0.13981E+01, 0.14018E+01, 0.14056E+01, 0.14093E+01, 0.14131E+01, & + 0.14168E+01, 0.14205E+01, 0.14242E+01, 0.14279E+01, 0.14316E+01, & + 0.14353E+01, 0.14390E+01, 0.14427E+01, 0.14464E+01, 0.14501E+01, & + 0.14537E+01, 0.14574E+01, 0.14610E+01, 0.14647E+01, 0.14683E+01, & + 0.14720E+01, 0.14756E+01, 0.14792E+01, 0.14828E+01, 0.14864E+01, & + 0.14900E+01, 0.14936E+01, 0.14972E+01, 0.15008E+01, 0.15043E+01, & + 0.15079E+01, 0.15115E+01, 0.15150E+01, 0.15186E+01, 0.15221E+01, & + 0.15256E+01, 0.15292E+01, 0.15327E+01, 0.15362E+01, 0.15397E+01, & + 0.15432E+01, 0.15467E+01, 0.15502E+01, 0.15537E+01, 0.15572E+01/ + + DATA (BNC12M (I),I=401,500)/ & + 0.15607E+01, 0.15641E+01, 0.15676E+01, 0.15710E+01, 0.15745E+01, & + 0.15779E+01, 0.15814E+01, 0.15848E+01, 0.15882E+01, 0.15916E+01, & + 0.15951E+01, 0.15985E+01, 0.16019E+01, 0.16053E+01, 0.16087E+01, & + 0.16120E+01, 0.16154E+01, 0.16188E+01, 0.16222E+01, 0.16255E+01, & + 0.16289E+01, 0.16322E+01, 0.16356E+01, 0.16389E+01, 0.16422E+01, & + 0.16456E+01, 0.16489E+01, 0.16522E+01, 0.16555E+01, 0.16588E+01, & + 0.16621E+01, 0.16654E+01, 0.16687E+01, 0.16720E+01, 0.16753E+01, & + 0.16785E+01, 0.16818E+01, 0.16850E+01, 0.16883E+01, 0.16916E+01, & + 0.16948E+01, 0.16980E+01, 0.17013E+01, 0.17045E+01, 0.17077E+01, & + 0.17109E+01, 0.17142E+01, 0.17174E+01, 0.17206E+01, 0.17238E+01, & + 0.17269E+01, 0.17301E+01, 0.17333E+01, 0.17365E+01, 0.17397E+01, & + 0.17428E+01, 0.17460E+01, 0.17491E+01, 0.17523E+01, 0.17554E+01, & + 0.17586E+01, 0.17617E+01, 0.17648E+01, 0.17680E+01, 0.17711E+01, & + 0.17742E+01, 0.17773E+01, 0.17804E+01, 0.17835E+01, 0.17866E+01, & + 0.17897E+01, 0.17928E+01, 0.17958E+01, 0.17989E+01, 0.18020E+01, & + 0.18050E+01, 0.18081E+01, 0.18112E+01, 0.18142E+01, 0.18173E+01, & + 0.18203E+01, 0.18233E+01, 0.18264E+01, 0.18294E+01, 0.18324E+01, & + 0.18354E+01, 0.18384E+01, 0.18414E+01, 0.18444E+01, 0.18474E+01, & + 0.18504E+01, 0.18534E+01, 0.18564E+01, 0.18594E+01, 0.18623E+01, & + 0.18653E+01, 0.18683E+01, 0.18712E+01, 0.18742E+01, 0.18771E+01/ + + DATA (BNC12M (I),I=501,600)/ & + 0.18801E+01, 0.18830E+01, 0.18860E+01, 0.18889E+01, 0.18918E+01, & + 0.18947E+01, 0.18977E+01, 0.19006E+01, 0.19035E+01, 0.19064E+01, & + 0.19093E+01, 0.19122E+01, 0.19151E+01, 0.19180E+01, 0.19209E+01, & + 0.19237E+01, 0.19266E+01, 0.19295E+01, 0.19323E+01, 0.19352E+01, & + 0.19381E+01, 0.19409E+01, 0.19438E+01, 0.19466E+01, 0.19494E+01, & + 0.19523E+01, 0.19551E+01, 0.19579E+01, 0.19607E+01, 0.19636E+01, & + 0.19664E+01, 0.19692E+01, 0.19720E+01, 0.19748E+01, 0.19776E+01, & + 0.19804E+01, 0.19832E+01, 0.19860E+01, 0.19887E+01, 0.19915E+01, & + 0.19943E+01, 0.19970E+01, 0.19998E+01, 0.20026E+01, 0.20053E+01, & + 0.20081E+01, 0.20108E+01, 0.20136E+01, 0.20163E+01, 0.20190E+01, & + 0.20218E+01, 0.20245E+01, 0.20272E+01, 0.20299E+01, 0.20327E+01, & + 0.20354E+01, 0.20381E+01, 0.20408E+01, 0.20435E+01, 0.20462E+01, & + 0.20489E+01, 0.20515E+01, 0.20542E+01, 0.20569E+01, 0.20596E+01, & + 0.20622E+01, 0.20649E+01, 0.20676E+01, 0.20702E+01, 0.20729E+01, & + 0.20755E+01, 0.20782E+01, 0.20808E+01, 0.20835E+01, 0.20861E+01, & + 0.20887E+01, 0.20914E+01, 0.20940E+01, 0.20966E+01, 0.20992E+01, & + 0.21019E+01, 0.21045E+01, 0.21071E+01, 0.21097E+01, 0.21123E+01, & + 0.21149E+01, 0.21175E+01, 0.21200E+01, 0.21226E+01, 0.21252E+01, & + 0.21278E+01, 0.21304E+01, 0.21329E+01, 0.21355E+01, 0.21381E+01, & + 0.21406E+01, 0.21432E+01, 0.21457E+01, 0.21483E+01, 0.21578E+01/ + + DATA (BNC12M (I),I=601,700)/ & + 0.21786E+01, 0.22034E+01, 0.22280E+01, 0.22522E+01, 0.22760E+01, & + 0.22996E+01, 0.23228E+01, 0.23457E+01, 0.23684E+01, 0.23907E+01, & + 0.24128E+01, 0.24345E+01, 0.24560E+01, 0.24773E+01, 0.24982E+01, & + 0.25190E+01, 0.25394E+01, 0.25596E+01, 0.25796E+01, 0.25993E+01, & + 0.26188E+01, 0.26381E+01, 0.26571E+01, 0.26760E+01, 0.26946E+01, & + 0.27130E+01, 0.27312E+01, 0.27491E+01, 0.27669E+01, 0.27845E+01, & + 0.28019E+01, 0.28191E+01, 0.28361E+01, 0.28529E+01, 0.28696E+01, & + 0.28860E+01, 0.29023E+01, 0.29185E+01, 0.29344E+01, 0.29502E+01, & + 0.29658E+01, 0.29813E+01, 0.29966E+01, 0.30117E+01, 0.30267E+01, & + 0.30415E+01, 0.30562E+01, 0.30708E+01, 0.30852E+01, 0.30994E+01, & + 0.31136E+01, 0.31275E+01, 0.31414E+01, 0.31551E+01, 0.31687E+01, & + 0.31821E+01, 0.31954E+01, 0.32086E+01, 0.32217E+01, 0.32346E+01, & + 0.32474E+01, 0.32601E+01, 0.32727E+01, 0.32852E+01, 0.32976E+01, & + 0.33098E+01, 0.33219E+01, 0.33339E+01, 0.33459E+01, 0.33577E+01, & + 0.33694E+01, 0.33810E+01, 0.33924E+01, 0.34038E+01, 0.34151E+01, & + 0.34263E+01, 0.34374E+01, 0.34484E+01, 0.34593E+01, 0.34701E+01, & + 0.34808E+01, 0.34914E+01, 0.35020E+01, 0.35124E+01, 0.35228E+01, & + 0.35330E+01, 0.35432E+01, 0.35533E+01, 0.35633E+01, 0.35732E+01, & + 0.35831E+01, 0.35928E+01, 0.36025E+01, 0.36121E+01, 0.36216E+01, & + 0.36311E+01, 0.36405E+01, 0.36497E+01, 0.36590E+01, 0.36681E+01/ + + DATA (BNC12M(I),I=701,741)/ & + 0.36772E+01, 0.36862E+01, 0.36951E+01, 0.37039E+01, 0.37127E+01, & + 0.37214E+01, 0.37301E+01, 0.37386E+01, 0.37472E+01, 0.37556E+01, & + 0.37640E+01, 0.37723E+01, 0.37805E+01, 0.37887E+01, 0.37968E+01, & + 0.38049E+01, 0.38129E+01, 0.38208E+01, 0.38287E+01, 0.38365E+01, & + 0.38442E+01, 0.38519E+01, 0.38595E+01, 0.38671E+01, 0.38746E+01, & + 0.38821E+01, 0.38895E+01, 0.38968E+01, 0.39041E+01, 0.39114E+01, & + 0.39186E+01, 0.39257E+01, 0.39328E+01, 0.39398E+01, 0.39468E+01, & + 0.39537E+01, 0.39606E+01, 0.39674E+01, 0.39742E+01, 0.39809E+01, & + 0.39875E+01 & + / +! +! *** (NH4)3H(SO4)2 +! + DATA (BNC13M (I),I= 1,100)/ & + -0.88457E-01,-0.16130E+00,-0.21283E+00,-0.24810E+00,-0.27543E+00, & + -0.29791E+00,-0.31709E+00,-0.33386E+00,-0.34878E+00,-0.36223E+00, & + -0.37448E+00,-0.38573E+00,-0.39614E+00,-0.40581E+00,-0.41486E+00, & + -0.42335E+00,-0.43134E+00,-0.43890E+00,-0.44605E+00,-0.45284E+00, & + -0.45930E+00,-0.46546E+00,-0.47134E+00,-0.47696E+00,-0.48234E+00, & + -0.48749E+00,-0.49244E+00,-0.49719E+00,-0.50176E+00,-0.50615E+00, & + -0.51038E+00,-0.51445E+00,-0.51838E+00,-0.52217E+00,-0.52582E+00, & + -0.52935E+00,-0.53275E+00,-0.53604E+00,-0.53922E+00,-0.54230E+00, & + -0.54527E+00,-0.54815E+00,-0.55093E+00,-0.55362E+00,-0.55622E+00, & + -0.55875E+00,-0.56119E+00,-0.56356E+00,-0.56585E+00,-0.56807E+00, & + -0.57023E+00,-0.57231E+00,-0.57434E+00,-0.57630E+00,-0.57820E+00, & + -0.58005E+00,-0.58183E+00,-0.58357E+00,-0.58525E+00,-0.58689E+00, & + -0.58847E+00,-0.59001E+00,-0.59151E+00,-0.59295E+00,-0.59436E+00, & + -0.59573E+00,-0.59705E+00,-0.59834E+00,-0.59958E+00,-0.60079E+00, & + -0.60197E+00,-0.60311E+00,-0.60421E+00,-0.60529E+00,-0.60633E+00, & + -0.60734E+00,-0.60831E+00,-0.60926E+00,-0.61018E+00,-0.61107E+00, & + -0.61193E+00,-0.61276E+00,-0.61356E+00,-0.61434E+00,-0.61509E+00, & + -0.61582E+00,-0.61652E+00,-0.61720E+00,-0.61786E+00,-0.61849E+00, & + -0.61909E+00,-0.61968E+00,-0.62024E+00,-0.62078E+00,-0.62130E+00, & + -0.62180E+00,-0.62229E+00,-0.62275E+00,-0.62319E+00,-0.62361E+00/ + + DATA (BNC13M (I),I=101,200)/ & + -0.62402E+00,-0.62441E+00,-0.62478E+00,-0.62514E+00,-0.62548E+00, & + -0.62581E+00,-0.62612E+00,-0.62642E+00,-0.62670E+00,-0.62697E+00, & + -0.62723E+00,-0.62748E+00,-0.62771E+00,-0.62793E+00,-0.62815E+00, & + -0.62835E+00,-0.62854E+00,-0.62873E+00,-0.62890E+00,-0.62907E+00, & + -0.62933E+00,-0.62947E+00,-0.62960E+00,-0.62973E+00,-0.62984E+00, & + -0.62996E+00,-0.63006E+00,-0.63017E+00,-0.63026E+00,-0.63036E+00, & + -0.63045E+00,-0.63053E+00,-0.63061E+00,-0.63068E+00,-0.63075E+00, & + -0.63082E+00,-0.63089E+00,-0.63095E+00,-0.63100E+00,-0.63106E+00, & + -0.63111E+00,-0.63116E+00,-0.63120E+00,-0.63125E+00,-0.63129E+00, & + -0.63132E+00,-0.63136E+00,-0.63139E+00,-0.63142E+00,-0.63145E+00, & + -0.63148E+00,-0.63150E+00,-0.63153E+00,-0.63155E+00,-0.63157E+00, & + -0.63159E+00,-0.63160E+00,-0.63162E+00,-0.63163E+00,-0.63165E+00, & + -0.63166E+00,-0.63167E+00,-0.63168E+00,-0.63169E+00,-0.63169E+00, & + -0.63170E+00,-0.63171E+00,-0.63171E+00,-0.63172E+00,-0.63172E+00, & + -0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00, & + -0.63174E+00,-0.63174E+00,-0.63174E+00,-0.63174E+00,-0.63174E+00, & + -0.63174E+00,-0.63174E+00,-0.63174E+00,-0.63174E+00,-0.63174E+00, & + -0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00, & + -0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00,-0.63173E+00, & + -0.63173E+00,-0.63173E+00,-0.63174E+00,-0.63174E+00,-0.63174E+00/ + + DATA (BNC13M (I),I=201,300)/ & + -0.63174E+00,-0.63174E+00,-0.63174E+00,-0.63175E+00,-0.63175E+00, & + -0.63176E+00,-0.63176E+00,-0.63176E+00,-0.63177E+00,-0.63177E+00, & + -0.63178E+00,-0.63179E+00,-0.63179E+00,-0.63180E+00,-0.63181E+00, & + -0.63182E+00,-0.63183E+00,-0.63184E+00,-0.63185E+00,-0.63186E+00, & + -0.63187E+00,-0.63188E+00,-0.63189E+00,-0.63191E+00,-0.63192E+00, & + -0.63193E+00,-0.63195E+00,-0.63197E+00,-0.63198E+00,-0.63200E+00, & + -0.63202E+00,-0.63203E+00,-0.63205E+00,-0.63207E+00,-0.63209E+00, & + -0.63211E+00,-0.63214E+00,-0.63216E+00,-0.63218E+00,-0.63221E+00, & + -0.63223E+00,-0.63225E+00,-0.63228E+00,-0.63231E+00,-0.63233E+00, & + -0.63236E+00,-0.63239E+00,-0.63242E+00,-0.63245E+00,-0.63248E+00, & + -0.63251E+00,-0.63255E+00,-0.63258E+00,-0.63261E+00,-0.63265E+00, & + -0.63268E+00,-0.63272E+00,-0.63276E+00,-0.63280E+00,-0.63283E+00, & + -0.63287E+00,-0.63291E+00,-0.63296E+00,-0.63300E+00,-0.63304E+00, & + -0.63308E+00,-0.63313E+00,-0.63317E+00,-0.63322E+00,-0.63326E+00, & + -0.63331E+00,-0.63336E+00,-0.63341E+00,-0.63346E+00,-0.63351E+00, & + -0.63356E+00,-0.63361E+00,-0.63366E+00,-0.63372E+00,-0.63377E+00, & + -0.63383E+00,-0.63388E+00,-0.63394E+00,-0.63400E+00,-0.63406E+00, & + -0.63411E+00,-0.63417E+00,-0.63424E+00,-0.63430E+00,-0.63436E+00, & + -0.63442E+00,-0.63449E+00,-0.63455E+00,-0.63462E+00,-0.63468E+00, & + -0.63475E+00,-0.63482E+00,-0.63489E+00,-0.63496E+00,-0.63503E+00/ + + DATA (BNC13M (I),I=301,400)/ & + -0.63510E+00,-0.63517E+00,-0.63524E+00,-0.63531E+00,-0.63539E+00, & + -0.63546E+00,-0.63554E+00,-0.63562E+00,-0.63569E+00,-0.63577E+00, & + -0.63585E+00,-0.63593E+00,-0.63601E+00,-0.63609E+00,-0.63617E+00, & + -0.63626E+00,-0.63634E+00,-0.63643E+00,-0.63651E+00,-0.63660E+00, & + -0.63668E+00,-0.63677E+00,-0.63686E+00,-0.63695E+00,-0.63704E+00, & + -0.63713E+00,-0.63722E+00,-0.63731E+00,-0.63741E+00,-0.63750E+00, & + -0.63759E+00,-0.63769E+00,-0.63779E+00,-0.63788E+00,-0.63798E+00, & + -0.63808E+00,-0.63818E+00,-0.63828E+00,-0.63838E+00,-0.63848E+00, & + -0.63858E+00,-0.63869E+00,-0.63879E+00,-0.63889E+00,-0.63900E+00, & + -0.63911E+00,-0.63921E+00,-0.63932E+00,-0.63943E+00,-0.63954E+00, & + -0.63965E+00,-0.63976E+00,-0.63987E+00,-0.63998E+00,-0.64009E+00, & + -0.64021E+00,-0.64032E+00,-0.64044E+00,-0.64055E+00,-0.64067E+00, & + -0.64079E+00,-0.64090E+00,-0.64102E+00,-0.64114E+00,-0.64126E+00, & + -0.64138E+00,-0.64150E+00,-0.64163E+00,-0.64175E+00,-0.64187E+00, & + -0.64200E+00,-0.64212E+00,-0.64225E+00,-0.64238E+00,-0.64250E+00, & + -0.64263E+00,-0.64276E+00,-0.64289E+00,-0.64302E+00,-0.64315E+00, & + -0.64328E+00,-0.64342E+00,-0.64355E+00,-0.64368E+00,-0.64382E+00, & + -0.64395E+00,-0.64409E+00,-0.64423E+00,-0.64436E+00,-0.64450E+00, & + -0.64464E+00,-0.64478E+00,-0.64492E+00,-0.64506E+00,-0.64520E+00, & + -0.64534E+00,-0.64549E+00,-0.64563E+00,-0.64578E+00,-0.64592E+00/ + + DATA (BNC13M (I),I=401,500)/ & + -0.64607E+00,-0.64621E+00,-0.64636E+00,-0.64651E+00,-0.64666E+00, & + -0.64681E+00,-0.64696E+00,-0.64711E+00,-0.64726E+00,-0.64741E+00, & + -0.64756E+00,-0.64772E+00,-0.64787E+00,-0.64802E+00,-0.64818E+00, & + -0.64833E+00,-0.64849E+00,-0.64865E+00,-0.64881E+00,-0.64897E+00, & + -0.64912E+00,-0.64928E+00,-0.64944E+00,-0.64961E+00,-0.64977E+00, & + -0.64993E+00,-0.65009E+00,-0.65026E+00,-0.65042E+00,-0.65059E+00, & + -0.65075E+00,-0.65092E+00,-0.65109E+00,-0.65125E+00,-0.65142E+00, & + -0.65159E+00,-0.65176E+00,-0.65193E+00,-0.65210E+00,-0.65227E+00, & + -0.65245E+00,-0.65262E+00,-0.65279E+00,-0.65297E+00,-0.65314E+00, & + -0.65332E+00,-0.65349E+00,-0.65367E+00,-0.65385E+00,-0.65402E+00, & + -0.65420E+00,-0.65438E+00,-0.65456E+00,-0.65474E+00,-0.65492E+00, & + -0.65510E+00,-0.65529E+00,-0.65547E+00,-0.65565E+00,-0.65584E+00, & + -0.65602E+00,-0.65621E+00,-0.65639E+00,-0.65658E+00,-0.65677E+00, & + -0.65695E+00,-0.65714E+00,-0.65733E+00,-0.65752E+00,-0.65771E+00, & + -0.65790E+00,-0.65809E+00,-0.65828E+00,-0.65848E+00,-0.65867E+00, & + -0.65886E+00,-0.65906E+00,-0.65925E+00,-0.65945E+00,-0.65964E+00, & + -0.65984E+00,-0.66004E+00,-0.66024E+00,-0.66043E+00,-0.66063E+00, & + -0.66083E+00,-0.66103E+00,-0.66123E+00,-0.66143E+00,-0.66164E+00, & + -0.66184E+00,-0.66204E+00,-0.66225E+00,-0.66245E+00,-0.66265E+00, & + -0.66286E+00,-0.66307E+00,-0.66327E+00,-0.66348E+00,-0.66369E+00/ + + DATA (BNC13M (I),I=501,600)/ & + -0.66389E+00,-0.66410E+00,-0.66431E+00,-0.66452E+00,-0.66473E+00, & + -0.66494E+00,-0.66515E+00,-0.66537E+00,-0.66558E+00,-0.66579E+00, & + -0.66601E+00,-0.66622E+00,-0.66643E+00,-0.66665E+00,-0.66687E+00, & + -0.66708E+00,-0.66730E+00,-0.66752E+00,-0.66773E+00,-0.66795E+00, & + -0.66817E+00,-0.66839E+00,-0.66861E+00,-0.66883E+00,-0.66905E+00, & + -0.66928E+00,-0.66950E+00,-0.66972E+00,-0.66994E+00,-0.67017E+00, & + -0.67039E+00,-0.67062E+00,-0.67084E+00,-0.67107E+00,-0.67130E+00, & + -0.67152E+00,-0.67175E+00,-0.67198E+00,-0.67221E+00,-0.67244E+00, & + -0.67267E+00,-0.67290E+00,-0.67313E+00,-0.67336E+00,-0.67359E+00, & + -0.67382E+00,-0.67406E+00,-0.67429E+00,-0.67452E+00,-0.67476E+00, & + -0.67499E+00,-0.67523E+00,-0.67546E+00,-0.67570E+00,-0.67594E+00, & + -0.67617E+00,-0.67641E+00,-0.67665E+00,-0.67689E+00,-0.67713E+00, & + -0.67737E+00,-0.67761E+00,-0.67785E+00,-0.67809E+00,-0.67833E+00, & + -0.67857E+00,-0.67882E+00,-0.67906E+00,-0.67931E+00,-0.67955E+00, & + -0.67979E+00,-0.68004E+00,-0.68029E+00,-0.68053E+00,-0.68078E+00, & + -0.68103E+00,-0.68127E+00,-0.68152E+00,-0.68177E+00,-0.68202E+00, & + -0.68227E+00,-0.68252E+00,-0.68277E+00,-0.68302E+00,-0.68327E+00, & + -0.68352E+00,-0.68378E+00,-0.68403E+00,-0.68428E+00,-0.68454E+00, & + -0.68479E+00,-0.68505E+00,-0.68530E+00,-0.68556E+00,-0.68581E+00, & + -0.68607E+00,-0.68633E+00,-0.68659E+00,-0.68684E+00,-0.68782E+00/ + + DATA (BNC13M (I),I=601,700)/ & + -0.68998E+00,-0.69264E+00,-0.69534E+00,-0.69809E+00,-0.70088E+00, & + -0.70371E+00,-0.70659E+00,-0.70950E+00,-0.71245E+00,-0.71544E+00, & + -0.71847E+00,-0.72154E+00,-0.72464E+00,-0.72778E+00,-0.73095E+00, & + -0.73416E+00,-0.73741E+00,-0.74068E+00,-0.74399E+00,-0.74733E+00, & + -0.75070E+00,-0.75411E+00,-0.75754E+00,-0.76101E+00,-0.76450E+00, & + -0.76802E+00,-0.77157E+00,-0.77515E+00,-0.77876E+00,-0.78239E+00, & + -0.78605E+00,-0.78974E+00,-0.79345E+00,-0.79719E+00,-0.80095E+00, & + -0.80474E+00,-0.80855E+00,-0.81239E+00,-0.81625E+00,-0.82013E+00, & + -0.82403E+00,-0.82796E+00,-0.83191E+00,-0.83588E+00,-0.83987E+00, & + -0.84388E+00,-0.84792E+00,-0.85197E+00,-0.85604E+00,-0.86014E+00, & + -0.86425E+00,-0.86838E+00,-0.87253E+00,-0.87670E+00,-0.88089E+00, & + -0.88510E+00,-0.88932E+00,-0.89356E+00,-0.89782E+00,-0.90210E+00, & + -0.90639E+00,-0.91070E+00,-0.91503E+00,-0.91937E+00,-0.92373E+00, & + -0.92811E+00,-0.93250E+00,-0.93690E+00,-0.94132E+00,-0.94576E+00, & + -0.95021E+00,-0.95467E+00,-0.95915E+00,-0.96365E+00,-0.96815E+00, & + -0.97267E+00,-0.97721E+00,-0.98176E+00,-0.98632E+00,-0.99089E+00, & + -0.99548E+00,-0.10001E+01,-0.10047E+01,-0.10093E+01,-0.10140E+01, & + -0.10186E+01,-0.10233E+01,-0.10279E+01,-0.10326E+01,-0.10373E+01, & + -0.10420E+01,-0.10468E+01,-0.10515E+01,-0.10562E+01,-0.10610E+01, & + -0.10657E+01,-0.10705E+01,-0.10753E+01,-0.10801E+01,-0.10849E+01/ + + DATA (BNC13M(I),I=701,741)/ & + -0.10897E+01,-0.10945E+01,-0.10994E+01,-0.11042E+01,-0.11091E+01, & + -0.11139E+01,-0.11188E+01,-0.11237E+01,-0.11286E+01,-0.11335E+01, & + -0.11384E+01,-0.11433E+01,-0.11483E+01,-0.11532E+01,-0.11582E+01, & + -0.11631E+01,-0.11681E+01,-0.11730E+01,-0.11780E+01,-0.11830E+01, & + -0.11880E+01,-0.11930E+01,-0.11980E+01,-0.12031E+01,-0.12081E+01, & + -0.12131E+01,-0.12182E+01,-0.12232E+01,-0.12283E+01,-0.12333E+01, & + -0.12384E+01,-0.12435E+01,-0.12486E+01,-0.12537E+01,-0.12588E+01, & + -0.12639E+01,-0.12690E+01,-0.12741E+01,-0.12793E+01,-0.12844E+01, & + -0.12896E+01 & + / + END Module KMC223 diff --git a/wrfv2_fire/chem/module_data_isrpia_kmc248.F b/wrfv2_fire/chem/module_data_isrpia_kmc248.F new file mode 100755 index 00000000..99d40a15 --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_kmc248.F @@ -0,0 +1,2193 @@ + MODULE KMC248 + DOUBLE PRECISION :: & + BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & + BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & + BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & + BNC13M( 741) + + +! +! *** NaCl +! + DATA (BNC01M (I),I= 1,100)/ & + -0.52363E-01,-0.92329E-01,-0.11821E+00,-0.13443E+00,-0.14598E+00, & + -0.15471E+00,-0.16154E+00,-0.16698E+00,-0.17138E+00,-0.17496E+00, & + -0.17787E+00,-0.18024E+00,-0.18214E+00,-0.18366E+00,-0.18484E+00, & + -0.18573E+00,-0.18637E+00,-0.18679E+00,-0.18701E+00,-0.18706E+00, & + -0.18695E+00,-0.18669E+00,-0.18632E+00,-0.18583E+00,-0.18523E+00, & + -0.18454E+00,-0.18377E+00,-0.18292E+00,-0.18200E+00,-0.18102E+00, & + -0.17998E+00,-0.17889E+00,-0.17775E+00,-0.17657E+00,-0.17535E+00, & + -0.17409E+00,-0.17280E+00,-0.17147E+00,-0.17013E+00,-0.16876E+00, & + -0.16736E+00,-0.16595E+00,-0.16452E+00,-0.16307E+00,-0.16161E+00, & + -0.16013E+00,-0.15865E+00,-0.15715E+00,-0.15565E+00,-0.15413E+00, & + -0.15261E+00,-0.15108E+00,-0.14954E+00,-0.14800E+00,-0.14645E+00, & + -0.14490E+00,-0.14334E+00,-0.14178E+00,-0.14021E+00,-0.13864E+00, & + -0.13706E+00,-0.13548E+00,-0.13389E+00,-0.13229E+00,-0.13069E+00, & + -0.12909E+00,-0.12747E+00,-0.12585E+00,-0.12422E+00,-0.12258E+00, & + -0.12094E+00,-0.11928E+00,-0.11762E+00,-0.11594E+00,-0.11426E+00, & + -0.11256E+00,-0.11085E+00,-0.10913E+00,-0.10740E+00,-0.10565E+00, & + -0.10389E+00,-0.10212E+00,-0.10033E+00,-0.98525E-01,-0.96708E-01, & + -0.94877E-01,-0.93031E-01,-0.91169E-01,-0.89293E-01,-0.87402E-01, & + -0.85495E-01,-0.83574E-01,-0.81638E-01,-0.79687E-01,-0.77722E-01, & + -0.75743E-01,-0.73749E-01,-0.71742E-01,-0.69722E-01,-0.67689E-01/ + + DATA (BNC01M (I),I=101,200)/ & + -0.65644E-01,-0.63586E-01,-0.61517E-01,-0.59436E-01,-0.57345E-01, & + -0.55244E-01,-0.53133E-01,-0.51013E-01,-0.48884E-01,-0.46747E-01, & + -0.44603E-01,-0.42451E-01,-0.40292E-01,-0.38127E-01,-0.35957E-01, & + -0.33781E-01,-0.31601E-01,-0.29416E-01,-0.27227E-01,-0.25035E-01, & + -0.23114E-01,-0.20884E-01,-0.18655E-01,-0.16426E-01,-0.14199E-01, & + -0.11973E-01,-0.97477E-02,-0.75237E-02,-0.53010E-02,-0.30795E-02, & + -0.85942E-03, 0.13593E-02, 0.35765E-02, 0.57922E-02, 0.80063E-02, & + 0.10219E-01, 0.12430E-01, 0.14638E-01, 0.16846E-01, 0.19051E-01, & + 0.21255E-01, 0.23456E-01, 0.25656E-01, 0.27853E-01, 0.30049E-01, & + 0.32242E-01, 0.34434E-01, 0.36623E-01, 0.38810E-01, 0.40994E-01, & + 0.43177E-01, 0.45357E-01, 0.47535E-01, 0.49710E-01, 0.51883E-01, & + 0.54053E-01, 0.56221E-01, 0.58387E-01, 0.60550E-01, 0.62710E-01, & + 0.64868E-01, 0.67024E-01, 0.69176E-01, 0.71326E-01, 0.73474E-01, & + 0.75618E-01, 0.77760E-01, 0.79899E-01, 0.82036E-01, 0.84169E-01, & + 0.86300E-01, 0.88428E-01, 0.90554E-01, 0.92676E-01, 0.94796E-01, & + 0.96912E-01, 0.99026E-01, 0.10114E+00, 0.10324E+00, 0.10535E+00, & + 0.10745E+00, 0.10955E+00, 0.11165E+00, 0.11374E+00, 0.11583E+00, & + 0.11792E+00, 0.12000E+00, 0.12208E+00, 0.12416E+00, 0.12624E+00, & + 0.12831E+00, 0.13038E+00, 0.13244E+00, 0.13450E+00, 0.13656E+00, & + 0.13862E+00, 0.14067E+00, 0.14272E+00, 0.14477E+00, 0.14681E+00/ + + DATA (BNC01M (I),I=201,300)/ & + 0.14886E+00, 0.15089E+00, 0.15293E+00, 0.15496E+00, 0.15699E+00, & + 0.15901E+00, 0.16103E+00, 0.16305E+00, 0.16507E+00, 0.16708E+00, & + 0.16909E+00, 0.17110E+00, 0.17310E+00, 0.17510E+00, 0.17709E+00, & + 0.17909E+00, 0.18108E+00, 0.18306E+00, 0.18505E+00, 0.18703E+00, & + 0.18901E+00, 0.19098E+00, 0.19295E+00, 0.19492E+00, 0.19688E+00, & + 0.19884E+00, 0.20080E+00, 0.20276E+00, 0.20471E+00, 0.20666E+00, & + 0.20860E+00, 0.21054E+00, 0.21248E+00, 0.21442E+00, 0.21635E+00, & + 0.21828E+00, 0.22020E+00, 0.22213E+00, 0.22405E+00, 0.22596E+00, & + 0.22788E+00, 0.22979E+00, 0.23169E+00, 0.23360E+00, 0.23550E+00, & + 0.23739E+00, 0.23929E+00, 0.24118E+00, 0.24306E+00, 0.24495E+00, & + 0.24683E+00, 0.24871E+00, 0.25058E+00, 0.25245E+00, 0.25432E+00, & + 0.25619E+00, 0.25805E+00, 0.25991E+00, 0.26177E+00, 0.26362E+00, & + 0.26547E+00, 0.26731E+00, 0.26916E+00, 0.27100E+00, 0.27283E+00, & + 0.27467E+00, 0.27650E+00, 0.27833E+00, 0.28015E+00, 0.28197E+00, & + 0.28379E+00, 0.28560E+00, 0.28742E+00, 0.28923E+00, 0.29103E+00, & + 0.29283E+00, 0.29463E+00, 0.29643E+00, 0.29822E+00, 0.30001E+00, & + 0.30180E+00, 0.30359E+00, 0.30537E+00, 0.30715E+00, 0.30892E+00, & + 0.31069E+00, 0.31246E+00, 0.31423E+00, 0.31599E+00, 0.31775E+00, & + 0.31951E+00, 0.32126E+00, 0.32301E+00, 0.32476E+00, 0.32651E+00, & + 0.32825E+00, 0.32999E+00, 0.33172E+00, 0.33346E+00, 0.33518E+00/ + + DATA (BNC01M (I),I=301,400)/ & + 0.33691E+00, 0.33864E+00, 0.34036E+00, 0.34208E+00, 0.34379E+00, & + 0.34550E+00, 0.34721E+00, 0.34892E+00, 0.35062E+00, 0.35232E+00, & + 0.35402E+00, 0.35571E+00, 0.35741E+00, 0.35910E+00, 0.36078E+00, & + 0.36246E+00, 0.36414E+00, 0.36582E+00, 0.36750E+00, 0.36917E+00, & + 0.37084E+00, 0.37250E+00, 0.37417E+00, 0.37583E+00, 0.37748E+00, & + 0.37914E+00, 0.38079E+00, 0.38244E+00, 0.38409E+00, 0.38573E+00, & + 0.38737E+00, 0.38901E+00, 0.39064E+00, 0.39227E+00, 0.39390E+00, & + 0.39553E+00, 0.39715E+00, 0.39877E+00, 0.40039E+00, 0.40201E+00, & + 0.40362E+00, 0.40523E+00, 0.40684E+00, 0.40844E+00, 0.41004E+00, & + 0.41164E+00, 0.41324E+00, 0.41483E+00, 0.41642E+00, 0.41801E+00, & + 0.41960E+00, 0.42118E+00, 0.42276E+00, 0.42434E+00, 0.42591E+00, & + 0.42749E+00, 0.42906E+00, 0.43062E+00, 0.43219E+00, 0.43375E+00, & + 0.43531E+00, 0.43686E+00, 0.43842E+00, 0.43997E+00, 0.44152E+00, & + 0.44306E+00, 0.44461E+00, 0.44615E+00, 0.44769E+00, 0.44922E+00, & + 0.45075E+00, 0.45229E+00, 0.45381E+00, 0.45534E+00, 0.45686E+00, & + 0.45838E+00, 0.45990E+00, 0.46141E+00, 0.46293E+00, 0.46444E+00, & + 0.46594E+00, 0.46745E+00, 0.46895E+00, 0.47045E+00, 0.47195E+00, & + 0.47344E+00, 0.47494E+00, 0.47643E+00, 0.47791E+00, 0.47940E+00, & + 0.48088E+00, 0.48236E+00, 0.48384E+00, 0.48532E+00, 0.48679E+00, & + 0.48826E+00, 0.48973E+00, 0.49119E+00, 0.49266E+00, 0.49412E+00/ + + DATA (BNC01M (I),I=401,500)/ & + 0.49557E+00, 0.49703E+00, 0.49848E+00, 0.49993E+00, 0.50138E+00, & + 0.50283E+00, 0.50427E+00, 0.50572E+00, 0.50715E+00, 0.50859E+00, & + 0.51003E+00, 0.51146E+00, 0.51289E+00, 0.51432E+00, 0.51574E+00, & + 0.51716E+00, 0.51858E+00, 0.52000E+00, 0.52142E+00, 0.52283E+00, & + 0.52424E+00, 0.52565E+00, 0.52706E+00, 0.52846E+00, 0.52986E+00, & + 0.53126E+00, 0.53266E+00, 0.53406E+00, 0.53545E+00, 0.53684E+00, & + 0.53823E+00, 0.53962E+00, 0.54100E+00, 0.54238E+00, 0.54376E+00, & + 0.54514E+00, 0.54651E+00, 0.54789E+00, 0.54926E+00, 0.55062E+00, & + 0.55199E+00, 0.55335E+00, 0.55472E+00, 0.55608E+00, 0.55743E+00, & + 0.55879E+00, 0.56014E+00, 0.56149E+00, 0.56284E+00, 0.56419E+00, & + 0.56553E+00, 0.56688E+00, 0.56822E+00, 0.56955E+00, 0.57089E+00, & + 0.57222E+00, 0.57356E+00, 0.57488E+00, 0.57621E+00, 0.57754E+00, & + 0.57886E+00, 0.58018E+00, 0.58150E+00, 0.58282E+00, 0.58413E+00, & + 0.58545E+00, 0.58676E+00, 0.58806E+00, 0.58937E+00, 0.59068E+00, & + 0.59198E+00, 0.59328E+00, 0.59458E+00, 0.59587E+00, 0.59717E+00, & + 0.59846E+00, 0.59975E+00, 0.60104E+00, 0.60232E+00, 0.60361E+00, & + 0.60489E+00, 0.60617E+00, 0.60745E+00, 0.60872E+00, 0.61000E+00, & + 0.61127E+00, 0.61254E+00, 0.61381E+00, 0.61508E+00, 0.61634E+00, & + 0.61760E+00, 0.61886E+00, 0.62012E+00, 0.62138E+00, 0.62263E+00, & + 0.62388E+00, 0.62513E+00, 0.62638E+00, 0.62763E+00, 0.62887E+00/ + + DATA (BNC01M (I),I=501,600)/ & + 0.63012E+00, 0.63136E+00, 0.63260E+00, 0.63383E+00, 0.63507E+00, & + 0.63630E+00, 0.63753E+00, 0.63876E+00, 0.63999E+00, 0.64122E+00, & + 0.64244E+00, 0.64366E+00, 0.64488E+00, 0.64610E+00, 0.64732E+00, & + 0.64853E+00, 0.64975E+00, 0.65096E+00, 0.65217E+00, 0.65337E+00, & + 0.65458E+00, 0.65578E+00, 0.65698E+00, 0.65818E+00, 0.65938E+00, & + 0.66058E+00, 0.66177E+00, 0.66296E+00, 0.66415E+00, 0.66534E+00, & + 0.66653E+00, 0.66772E+00, 0.66890E+00, 0.67008E+00, 0.67126E+00, & + 0.67244E+00, 0.67362E+00, 0.67479E+00, 0.67596E+00, 0.67713E+00, & + 0.67830E+00, 0.67947E+00, 0.68064E+00, 0.68180E+00, 0.68296E+00, & + 0.68412E+00, 0.68528E+00, 0.68644E+00, 0.68760E+00, 0.68875E+00, & + 0.68990E+00, 0.69105E+00, 0.69220E+00, 0.69335E+00, 0.69449E+00, & + 0.69563E+00, 0.69678E+00, 0.69792E+00, 0.69905E+00, 0.70019E+00, & + 0.70133E+00, 0.70246E+00, 0.70359E+00, 0.70472E+00, 0.70585E+00, & + 0.70698E+00, 0.70810E+00, 0.70922E+00, 0.71035E+00, 0.71147E+00, & + 0.71258E+00, 0.71370E+00, 0.71482E+00, 0.71593E+00, 0.71704E+00, & + 0.71815E+00, 0.71926E+00, 0.72037E+00, 0.72147E+00, 0.72258E+00, & + 0.72368E+00, 0.72478E+00, 0.72588E+00, 0.72697E+00, 0.72807E+00, & + 0.72916E+00, 0.73026E+00, 0.73135E+00, 0.73244E+00, 0.73352E+00, & + 0.73461E+00, 0.73569E+00, 0.73678E+00, 0.73786E+00, 0.73894E+00, & + 0.74002E+00, 0.74109E+00, 0.74217E+00, 0.74324E+00, 0.74725E+00/ + + DATA (BNC01M (I),I=601,700)/ & + 0.75600E+00, 0.76647E+00, 0.77680E+00, 0.78697E+00, 0.79701E+00, & + 0.80690E+00, 0.81666E+00, 0.82629E+00, 0.83578E+00, 0.84515E+00, & + 0.85439E+00, 0.86350E+00, 0.87250E+00, 0.88138E+00, 0.89014E+00, & + 0.89879E+00, 0.90732E+00, 0.91574E+00, 0.92406E+00, 0.93227E+00, & + 0.94038E+00, 0.94838E+00, 0.95628E+00, 0.96409E+00, 0.97180E+00, & + 0.97941E+00, 0.98693E+00, 0.99435E+00, 0.10017E+01, 0.10089E+01, & + 0.10161E+01, 0.10232E+01, 0.10302E+01, 0.10371E+01, 0.10439E+01, & + 0.10506E+01, 0.10573E+01, 0.10639E+01, 0.10704E+01, 0.10768E+01, & + 0.10832E+01, 0.10895E+01, 0.10957E+01, 0.11018E+01, 0.11079E+01, & + 0.11139E+01, 0.11199E+01, 0.11257E+01, 0.11315E+01, 0.11373E+01, & + 0.11430E+01, 0.11486E+01, 0.11541E+01, 0.11596E+01, 0.11651E+01, & + 0.11704E+01, 0.11757E+01, 0.11810E+01, 0.11862E+01, 0.11913E+01, & + 0.11964E+01, 0.12015E+01, 0.12064E+01, 0.12114E+01, 0.12162E+01, & + 0.12211E+01, 0.12258E+01, 0.12306E+01, 0.12352E+01, 0.12399E+01, & + 0.12444E+01, 0.12490E+01, 0.12534E+01, 0.12579E+01, 0.12623E+01, & + 0.12666E+01, 0.12709E+01, 0.12751E+01, 0.12794E+01, 0.12835E+01, & + 0.12876E+01, 0.12917E+01, 0.12958E+01, 0.12998E+01, 0.13037E+01, & + 0.13076E+01, 0.13115E+01, 0.13153E+01, 0.13191E+01, 0.13229E+01, & + 0.13266E+01, 0.13303E+01, 0.13340E+01, 0.13376E+01, 0.13411E+01, & + 0.13447E+01, 0.13482E+01, 0.13517E+01, 0.13551E+01, 0.13585E+01/ + + DATA (BNC01M(I),I=701,741)/ & + 0.13619E+01, 0.13652E+01, 0.13685E+01, 0.13718E+01, 0.13750E+01, & + 0.13782E+01, 0.13814E+01, 0.13845E+01, 0.13876E+01, 0.13907E+01, & + 0.13937E+01, 0.13967E+01, 0.13997E+01, 0.14027E+01, 0.14056E+01, & + 0.14085E+01, 0.14114E+01, 0.14142E+01, 0.14170E+01, 0.14198E+01, & + 0.14226E+01, 0.14253E+01, 0.14280E+01, 0.14307E+01, 0.14333E+01, & + 0.14360E+01, 0.14386E+01, 0.14411E+01, 0.14437E+01, 0.14462E+01, & + 0.14487E+01, 0.14512E+01, 0.14536E+01, 0.14561E+01, 0.14585E+01, & + 0.14608E+01, 0.14632E+01, 0.14655E+01, 0.14678E+01, 0.14701E+01, & + 0.14724E+01 & + / +! +! *** Na2SO4 +! + DATA (BNC02M (I),I= 1,100)/ & + -0.10845E+00,-0.19833E+00,-0.26217E+00,-0.30599E+00,-0.34002E+00, & + -0.36806E+00,-0.39204E+00,-0.41305E+00,-0.43179E+00,-0.44872E+00, & + -0.46420E+00,-0.47846E+00,-0.49169E+00,-0.50405E+00,-0.51565E+00, & + -0.52658E+00,-0.53693E+00,-0.54675E+00,-0.55611E+00,-0.56505E+00, & + -0.57361E+00,-0.58182E+00,-0.58971E+00,-0.59731E+00,-0.60464E+00, & + -0.61173E+00,-0.61858E+00,-0.62522E+00,-0.63166E+00,-0.63792E+00, & + -0.64400E+00,-0.64991E+00,-0.65567E+00,-0.66129E+00,-0.66676E+00, & + -0.67211E+00,-0.67733E+00,-0.68243E+00,-0.68742E+00,-0.69231E+00, & + -0.69710E+00,-0.70178E+00,-0.70638E+00,-0.71089E+00,-0.71531E+00, & + -0.71965E+00,-0.72392E+00,-0.72811E+00,-0.73222E+00,-0.73627E+00, & + -0.74026E+00,-0.74418E+00,-0.74803E+00,-0.75183E+00,-0.75558E+00, & + -0.75926E+00,-0.76290E+00,-0.76648E+00,-0.77002E+00,-0.77350E+00, & + -0.77695E+00,-0.78034E+00,-0.78370E+00,-0.78701E+00,-0.79029E+00, & + -0.79352E+00,-0.79672E+00,-0.79988E+00,-0.80301E+00,-0.80610E+00, & + -0.80916E+00,-0.81219E+00,-0.81519E+00,-0.81816E+00,-0.82110E+00, & + -0.82401E+00,-0.82689E+00,-0.82975E+00,-0.83259E+00,-0.83540E+00, & + -0.83818E+00,-0.84095E+00,-0.84369E+00,-0.84641E+00,-0.84911E+00, & + -0.85178E+00,-0.85444E+00,-0.85708E+00,-0.85970E+00,-0.86230E+00, & + -0.86488E+00,-0.86745E+00,-0.87000E+00,-0.87253E+00,-0.87505E+00, & + -0.87755E+00,-0.88003E+00,-0.88250E+00,-0.88495E+00,-0.88739E+00/ + + DATA (BNC02M (I),I=101,200)/ & + -0.88982E+00,-0.89223E+00,-0.89462E+00,-0.89700E+00,-0.89937E+00, & + -0.90173E+00,-0.90407E+00,-0.90640E+00,-0.90872E+00,-0.91102E+00, & + -0.91332E+00,-0.91560E+00,-0.91786E+00,-0.92012E+00,-0.92236E+00, & + -0.92460E+00,-0.92682E+00,-0.92903E+00,-0.93123E+00,-0.93342E+00, & + -0.93555E+00,-0.93772E+00,-0.93988E+00,-0.94203E+00,-0.94417E+00, & + -0.94629E+00,-0.94841E+00,-0.95052E+00,-0.95262E+00,-0.95470E+00, & + -0.95678E+00,-0.95885E+00,-0.96090E+00,-0.96295E+00,-0.96499E+00, & + -0.96702E+00,-0.96904E+00,-0.97105E+00,-0.97305E+00,-0.97505E+00, & + -0.97703E+00,-0.97901E+00,-0.98098E+00,-0.98294E+00,-0.98489E+00, & + -0.98683E+00,-0.98877E+00,-0.99070E+00,-0.99262E+00,-0.99453E+00, & + -0.99643E+00,-0.99833E+00,-0.10002E+01,-0.10021E+01,-0.10040E+01, & + -0.10058E+01,-0.10077E+01,-0.10096E+01,-0.10114E+01,-0.10133E+01, & + -0.10151E+01,-0.10169E+01,-0.10187E+01,-0.10205E+01,-0.10224E+01, & + -0.10242E+01,-0.10260E+01,-0.10277E+01,-0.10295E+01,-0.10313E+01, & + -0.10331E+01,-0.10348E+01,-0.10366E+01,-0.10384E+01,-0.10401E+01, & + -0.10418E+01,-0.10436E+01,-0.10453E+01,-0.10470E+01,-0.10488E+01, & + -0.10505E+01,-0.10522E+01,-0.10539E+01,-0.10556E+01,-0.10573E+01, & + -0.10590E+01,-0.10606E+01,-0.10623E+01,-0.10640E+01,-0.10657E+01, & + -0.10673E+01,-0.10690E+01,-0.10706E+01,-0.10723E+01,-0.10739E+01, & + -0.10756E+01,-0.10772E+01,-0.10788E+01,-0.10805E+01,-0.10821E+01/ + + DATA (BNC02M (I),I=201,300)/ & + -0.10837E+01,-0.10853E+01,-0.10869E+01,-0.10885E+01,-0.10901E+01, & + -0.10917E+01,-0.10933E+01,-0.10949E+01,-0.10965E+01,-0.10981E+01, & + -0.10997E+01,-0.11012E+01,-0.11028E+01,-0.11044E+01,-0.11059E+01, & + -0.11075E+01,-0.11090E+01,-0.11106E+01,-0.11121E+01,-0.11137E+01, & + -0.11152E+01,-0.11167E+01,-0.11183E+01,-0.11198E+01,-0.11213E+01, & + -0.11228E+01,-0.11243E+01,-0.11259E+01,-0.11274E+01,-0.11289E+01, & + -0.11304E+01,-0.11319E+01,-0.11334E+01,-0.11349E+01,-0.11364E+01, & + -0.11378E+01,-0.11393E+01,-0.11408E+01,-0.11423E+01,-0.11437E+01, & + -0.11452E+01,-0.11467E+01,-0.11481E+01,-0.11496E+01,-0.11511E+01, & + -0.11525E+01,-0.11540E+01,-0.11554E+01,-0.11569E+01,-0.11583E+01, & + -0.11597E+01,-0.11612E+01,-0.11626E+01,-0.11640E+01,-0.11655E+01, & + -0.11669E+01,-0.11683E+01,-0.11697E+01,-0.11711E+01,-0.11726E+01, & + -0.11740E+01,-0.11754E+01,-0.11768E+01,-0.11782E+01,-0.11796E+01, & + -0.11810E+01,-0.11824E+01,-0.11838E+01,-0.11852E+01,-0.11865E+01, & + -0.11879E+01,-0.11893E+01,-0.11907E+01,-0.11921E+01,-0.11934E+01, & + -0.11948E+01,-0.11962E+01,-0.11976E+01,-0.11989E+01,-0.12003E+01, & + -0.12016E+01,-0.12030E+01,-0.12044E+01,-0.12057E+01,-0.12071E+01, & + -0.12084E+01,-0.12098E+01,-0.12111E+01,-0.12124E+01,-0.12138E+01, & + -0.12151E+01,-0.12165E+01,-0.12178E+01,-0.12191E+01,-0.12204E+01, & + -0.12218E+01,-0.12231E+01,-0.12244E+01,-0.12257E+01,-0.12271E+01/ + + DATA (BNC02M (I),I=301,400)/ & + -0.12284E+01,-0.12297E+01,-0.12310E+01,-0.12323E+01,-0.12336E+01, & + -0.12349E+01,-0.12362E+01,-0.12375E+01,-0.12388E+01,-0.12401E+01, & + -0.12414E+01,-0.12427E+01,-0.12440E+01,-0.12453E+01,-0.12466E+01, & + -0.12479E+01,-0.12491E+01,-0.12504E+01,-0.12517E+01,-0.12530E+01, & + -0.12543E+01,-0.12555E+01,-0.12568E+01,-0.12581E+01,-0.12593E+01, & + -0.12606E+01,-0.12619E+01,-0.12631E+01,-0.12644E+01,-0.12657E+01, & + -0.12669E+01,-0.12682E+01,-0.12694E+01,-0.12707E+01,-0.12719E+01, & + -0.12732E+01,-0.12744E+01,-0.12757E+01,-0.12769E+01,-0.12782E+01, & + -0.12794E+01,-0.12806E+01,-0.12819E+01,-0.12831E+01,-0.12844E+01, & + -0.12856E+01,-0.12868E+01,-0.12880E+01,-0.12893E+01,-0.12905E+01, & + -0.12917E+01,-0.12930E+01,-0.12942E+01,-0.12954E+01,-0.12966E+01, & + -0.12978E+01,-0.12990E+01,-0.13003E+01,-0.13015E+01,-0.13027E+01, & + -0.13039E+01,-0.13051E+01,-0.13063E+01,-0.13075E+01,-0.13087E+01, & + -0.13099E+01,-0.13111E+01,-0.13123E+01,-0.13135E+01,-0.13147E+01, & + -0.13159E+01,-0.13171E+01,-0.13183E+01,-0.13195E+01,-0.13207E+01, & + -0.13219E+01,-0.13230E+01,-0.13242E+01,-0.13254E+01,-0.13266E+01, & + -0.13278E+01,-0.13290E+01,-0.13301E+01,-0.13313E+01,-0.13325E+01, & + -0.13337E+01,-0.13348E+01,-0.13360E+01,-0.13372E+01,-0.13383E+01, & + -0.13395E+01,-0.13407E+01,-0.13418E+01,-0.13430E+01,-0.13442E+01, & + -0.13453E+01,-0.13465E+01,-0.13476E+01,-0.13488E+01,-0.13500E+01/ + + DATA (BNC02M (I),I=401,500)/ & + -0.13511E+01,-0.13523E+01,-0.13534E+01,-0.13546E+01,-0.13557E+01, & + -0.13569E+01,-0.13580E+01,-0.13592E+01,-0.13603E+01,-0.13615E+01, & + -0.13626E+01,-0.13637E+01,-0.13649E+01,-0.13660E+01,-0.13672E+01, & + -0.13683E+01,-0.13694E+01,-0.13706E+01,-0.13717E+01,-0.13728E+01, & + -0.13740E+01,-0.13751E+01,-0.13762E+01,-0.13774E+01,-0.13785E+01, & + -0.13796E+01,-0.13807E+01,-0.13819E+01,-0.13830E+01,-0.13841E+01, & + -0.13852E+01,-0.13863E+01,-0.13875E+01,-0.13886E+01,-0.13897E+01, & + -0.13908E+01,-0.13919E+01,-0.13930E+01,-0.13941E+01,-0.13952E+01, & + -0.13964E+01,-0.13975E+01,-0.13986E+01,-0.13997E+01,-0.14008E+01, & + -0.14019E+01,-0.14030E+01,-0.14041E+01,-0.14052E+01,-0.14063E+01, & + -0.14074E+01,-0.14085E+01,-0.14096E+01,-0.14107E+01,-0.14118E+01, & + -0.14129E+01,-0.14140E+01,-0.14151E+01,-0.14162E+01,-0.14172E+01, & + -0.14183E+01,-0.14194E+01,-0.14205E+01,-0.14216E+01,-0.14227E+01, & + -0.14238E+01,-0.14249E+01,-0.14259E+01,-0.14270E+01,-0.14281E+01, & + -0.14292E+01,-0.14303E+01,-0.14313E+01,-0.14324E+01,-0.14335E+01, & + -0.14346E+01,-0.14356E+01,-0.14367E+01,-0.14378E+01,-0.14389E+01, & + -0.14399E+01,-0.14410E+01,-0.14421E+01,-0.14431E+01,-0.14442E+01, & + -0.14453E+01,-0.14463E+01,-0.14474E+01,-0.14485E+01,-0.14495E+01, & + -0.14506E+01,-0.14517E+01,-0.14527E+01,-0.14538E+01,-0.14548E+01, & + -0.14559E+01,-0.14569E+01,-0.14580E+01,-0.14591E+01,-0.14601E+01/ + + DATA (BNC02M (I),I=501,600)/ & + -0.14612E+01,-0.14622E+01,-0.14633E+01,-0.14643E+01,-0.14654E+01, & + -0.14664E+01,-0.14675E+01,-0.14685E+01,-0.14696E+01,-0.14706E+01, & + -0.14717E+01,-0.14727E+01,-0.14737E+01,-0.14748E+01,-0.14758E+01, & + -0.14769E+01,-0.14779E+01,-0.14790E+01,-0.14800E+01,-0.14810E+01, & + -0.14821E+01,-0.14831E+01,-0.14841E+01,-0.14852E+01,-0.14862E+01, & + -0.14872E+01,-0.14883E+01,-0.14893E+01,-0.14903E+01,-0.14914E+01, & + -0.14924E+01,-0.14934E+01,-0.14945E+01,-0.14955E+01,-0.14965E+01, & + -0.14975E+01,-0.14986E+01,-0.14996E+01,-0.15006E+01,-0.15016E+01, & + -0.15027E+01,-0.15037E+01,-0.15047E+01,-0.15057E+01,-0.15068E+01, & + -0.15078E+01,-0.15088E+01,-0.15098E+01,-0.15108E+01,-0.15118E+01, & + -0.15129E+01,-0.15139E+01,-0.15149E+01,-0.15159E+01,-0.15169E+01, & + -0.15179E+01,-0.15189E+01,-0.15200E+01,-0.15210E+01,-0.15220E+01, & + -0.15230E+01,-0.15240E+01,-0.15250E+01,-0.15260E+01,-0.15270E+01, & + -0.15280E+01,-0.15290E+01,-0.15300E+01,-0.15310E+01,-0.15320E+01, & + -0.15330E+01,-0.15340E+01,-0.15350E+01,-0.15360E+01,-0.15370E+01, & + -0.15380E+01,-0.15390E+01,-0.15400E+01,-0.15410E+01,-0.15420E+01, & + -0.15430E+01,-0.15440E+01,-0.15450E+01,-0.15460E+01,-0.15470E+01, & + -0.15480E+01,-0.15490E+01,-0.15500E+01,-0.15510E+01,-0.15520E+01, & + -0.15529E+01,-0.15539E+01,-0.15549E+01,-0.15559E+01,-0.15569E+01, & + -0.15579E+01,-0.15589E+01,-0.15599E+01,-0.15608E+01,-0.15645E+01/ + + DATA (BNC02M (I),I=601,700)/ & + -0.15726E+01,-0.15824E+01,-0.15921E+01,-0.16017E+01,-0.16113E+01, & + -0.16208E+01,-0.16303E+01,-0.16397E+01,-0.16491E+01,-0.16584E+01, & + -0.16677E+01,-0.16770E+01,-0.16862E+01,-0.16954E+01,-0.17045E+01, & + -0.17136E+01,-0.17226E+01,-0.17316E+01,-0.17406E+01,-0.17495E+01, & + -0.17584E+01,-0.17673E+01,-0.17761E+01,-0.17849E+01,-0.17937E+01, & + -0.18024E+01,-0.18111E+01,-0.18198E+01,-0.18284E+01,-0.18370E+01, & + -0.18456E+01,-0.18542E+01,-0.18627E+01,-0.18712E+01,-0.18797E+01, & + -0.18881E+01,-0.18966E+01,-0.19050E+01,-0.19133E+01,-0.19217E+01, & + -0.19300E+01,-0.19383E+01,-0.19466E+01,-0.19548E+01,-0.19631E+01, & + -0.19713E+01,-0.19795E+01,-0.19876E+01,-0.19958E+01,-0.20039E+01, & + -0.20120E+01,-0.20201E+01,-0.20282E+01,-0.20362E+01,-0.20443E+01, & + -0.20523E+01,-0.20603E+01,-0.20682E+01,-0.20762E+01,-0.20841E+01, & + -0.20921E+01,-0.21000E+01,-0.21079E+01,-0.21157E+01,-0.21236E+01, & + -0.21314E+01,-0.21393E+01,-0.21471E+01,-0.21549E+01,-0.21626E+01, & + -0.21704E+01,-0.21782E+01,-0.21859E+01,-0.21936E+01,-0.22013E+01, & + -0.22090E+01,-0.22167E+01,-0.22244E+01,-0.22320E+01,-0.22396E+01, & + -0.22473E+01,-0.22549E+01,-0.22625E+01,-0.22701E+01,-0.22776E+01, & + -0.22852E+01,-0.22928E+01,-0.23003E+01,-0.23078E+01,-0.23153E+01, & + -0.23228E+01,-0.23303E+01,-0.23378E+01,-0.23453E+01,-0.23527E+01, & + -0.23602E+01,-0.23676E+01,-0.23750E+01,-0.23825E+01,-0.23899E+01/ + + DATA (BNC02M(I),I=701,741)/ & + -0.23973E+01,-0.24046E+01,-0.24120E+01,-0.24194E+01,-0.24267E+01, & + -0.24341E+01,-0.24414E+01,-0.24487E+01,-0.24560E+01,-0.24633E+01, & + -0.24706E+01,-0.24779E+01,-0.24852E+01,-0.24925E+01,-0.24997E+01, & + -0.25070E+01,-0.25142E+01,-0.25214E+01,-0.25287E+01,-0.25359E+01, & + -0.25431E+01,-0.25503E+01,-0.25575E+01,-0.25647E+01,-0.25718E+01, & + -0.25790E+01,-0.25862E+01,-0.25933E+01,-0.26004E+01,-0.26076E+01, & + -0.26147E+01,-0.26218E+01,-0.26289E+01,-0.26360E+01,-0.26431E+01, & + -0.26502E+01,-0.26573E+01,-0.26644E+01,-0.26714E+01,-0.26785E+01, & + -0.26856E+01 & + / +! +! *** NaNO3 +! + DATA (BNC03M (I),I= 1,100)/ & + -0.54405E-01,-0.99825E-01,-0.13234E+00,-0.15482E+00,-0.17238E+00, & + -0.18693E+00,-0.19943E+00,-0.21044E+00,-0.22031E+00,-0.22926E+00, & + -0.23748E+00,-0.24508E+00,-0.25216E+00,-0.25880E+00,-0.26505E+00, & + -0.27097E+00,-0.27658E+00,-0.28194E+00,-0.28705E+00,-0.29195E+00, & + -0.29665E+00,-0.30117E+00,-0.30553E+00,-0.30975E+00,-0.31382E+00, & + -0.31776E+00,-0.32159E+00,-0.32530E+00,-0.32891E+00,-0.33243E+00, & + -0.33585E+00,-0.33918E+00,-0.34243E+00,-0.34561E+00,-0.34871E+00, & + -0.35175E+00,-0.35472E+00,-0.35762E+00,-0.36047E+00,-0.36326E+00, & + -0.36599E+00,-0.36868E+00,-0.37131E+00,-0.37389E+00,-0.37643E+00, & + -0.37893E+00,-0.38138E+00,-0.38379E+00,-0.38617E+00,-0.38850E+00, & + -0.39080E+00,-0.39307E+00,-0.39530E+00,-0.39749E+00,-0.39966E+00, & + -0.40180E+00,-0.40391E+00,-0.40598E+00,-0.40804E+00,-0.41006E+00, & + -0.41206E+00,-0.41404E+00,-0.41599E+00,-0.41792E+00,-0.41983E+00, & + -0.42172E+00,-0.42359E+00,-0.42543E+00,-0.42726E+00,-0.42907E+00, & + -0.43087E+00,-0.43264E+00,-0.43440E+00,-0.43615E+00,-0.43787E+00, & + -0.43959E+00,-0.44129E+00,-0.44298E+00,-0.44465E+00,-0.44631E+00, & + -0.44796E+00,-0.44959E+00,-0.45122E+00,-0.45283E+00,-0.45444E+00, & + -0.45603E+00,-0.45761E+00,-0.45918E+00,-0.46075E+00,-0.46230E+00, & + -0.46385E+00,-0.46538E+00,-0.46691E+00,-0.46843E+00,-0.46994E+00, & + -0.47145E+00,-0.47294E+00,-0.47443E+00,-0.47591E+00,-0.47739E+00/ + + DATA (BNC03M (I),I=101,200)/ & + -0.47885E+00,-0.48031E+00,-0.48176E+00,-0.48321E+00,-0.48465E+00, & + -0.48608E+00,-0.48750E+00,-0.48892E+00,-0.49033E+00,-0.49174E+00, & + -0.49314E+00,-0.49453E+00,-0.49591E+00,-0.49729E+00,-0.49867E+00, & + -0.50003E+00,-0.50139E+00,-0.50275E+00,-0.50410E+00,-0.50544E+00, & + -0.50673E+00,-0.50806E+00,-0.50939E+00,-0.51071E+00,-0.51203E+00, & + -0.51334E+00,-0.51465E+00,-0.51594E+00,-0.51724E+00,-0.51852E+00, & + -0.51980E+00,-0.52108E+00,-0.52235E+00,-0.52361E+00,-0.52487E+00, & + -0.52612E+00,-0.52737E+00,-0.52861E+00,-0.52985E+00,-0.53108E+00, & + -0.53230E+00,-0.53353E+00,-0.53474E+00,-0.53595E+00,-0.53716E+00, & + -0.53836E+00,-0.53956E+00,-0.54075E+00,-0.54194E+00,-0.54312E+00, & + -0.54430E+00,-0.54548E+00,-0.54664E+00,-0.54781E+00,-0.54897E+00, & + -0.55013E+00,-0.55128E+00,-0.55243E+00,-0.55357E+00,-0.55471E+00, & + -0.55585E+00,-0.55698E+00,-0.55811E+00,-0.55923E+00,-0.56035E+00, & + -0.56147E+00,-0.56258E+00,-0.56369E+00,-0.56480E+00,-0.56590E+00, & + -0.56699E+00,-0.56809E+00,-0.56918E+00,-0.57027E+00,-0.57135E+00, & + -0.57243E+00,-0.57351E+00,-0.57458E+00,-0.57565E+00,-0.57671E+00, & + -0.57778E+00,-0.57884E+00,-0.57989E+00,-0.58095E+00,-0.58200E+00, & + -0.58304E+00,-0.58409E+00,-0.58513E+00,-0.58617E+00,-0.58720E+00, & + -0.58823E+00,-0.58926E+00,-0.59029E+00,-0.59131E+00,-0.59233E+00, & + -0.59334E+00,-0.59436E+00,-0.59537E+00,-0.59638E+00,-0.59738E+00/ + + DATA (BNC03M (I),I=201,300)/ & + -0.59839E+00,-0.59939E+00,-0.60038E+00,-0.60138E+00,-0.60237E+00, & + -0.60336E+00,-0.60434E+00,-0.60533E+00,-0.60631E+00,-0.60729E+00, & + -0.60826E+00,-0.60924E+00,-0.61021E+00,-0.61118E+00,-0.61214E+00, & + -0.61311E+00,-0.61407E+00,-0.61503E+00,-0.61598E+00,-0.61694E+00, & + -0.61789E+00,-0.61884E+00,-0.61979E+00,-0.62073E+00,-0.62167E+00, & + -0.62261E+00,-0.62355E+00,-0.62449E+00,-0.62542E+00,-0.62635E+00, & + -0.62728E+00,-0.62821E+00,-0.62913E+00,-0.63005E+00,-0.63097E+00, & + -0.63189E+00,-0.63281E+00,-0.63372E+00,-0.63463E+00,-0.63554E+00, & + -0.63645E+00,-0.63736E+00,-0.63826E+00,-0.63916E+00,-0.64006E+00, & + -0.64096E+00,-0.64186E+00,-0.64275E+00,-0.64364E+00,-0.64453E+00, & + -0.64542E+00,-0.64631E+00,-0.64719E+00,-0.64807E+00,-0.64896E+00, & + -0.64983E+00,-0.65071E+00,-0.65159E+00,-0.65246E+00,-0.65333E+00, & + -0.65420E+00,-0.65507E+00,-0.65594E+00,-0.65680E+00,-0.65766E+00, & + -0.65852E+00,-0.65938E+00,-0.66024E+00,-0.66110E+00,-0.66195E+00, & + -0.66281E+00,-0.66366E+00,-0.66451E+00,-0.66535E+00,-0.66620E+00, & + -0.66704E+00,-0.66789E+00,-0.66873E+00,-0.66957E+00,-0.67041E+00, & + -0.67124E+00,-0.67208E+00,-0.67291E+00,-0.67374E+00,-0.67457E+00, & + -0.67540E+00,-0.67623E+00,-0.67705E+00,-0.67788E+00,-0.67870E+00, & + -0.67952E+00,-0.68034E+00,-0.68116E+00,-0.68198E+00,-0.68279E+00, & + -0.68361E+00,-0.68442E+00,-0.68523E+00,-0.68604E+00,-0.68685E+00/ + + DATA (BNC03M (I),I=301,400)/ & + -0.68766E+00,-0.68846E+00,-0.68927E+00,-0.69007E+00,-0.69087E+00, & + -0.69167E+00,-0.69247E+00,-0.69327E+00,-0.69406E+00,-0.69486E+00, & + -0.69565E+00,-0.69644E+00,-0.69723E+00,-0.69802E+00,-0.69881E+00, & + -0.69960E+00,-0.70038E+00,-0.70117E+00,-0.70195E+00,-0.70273E+00, & + -0.70351E+00,-0.70429E+00,-0.70507E+00,-0.70585E+00,-0.70662E+00, & + -0.70740E+00,-0.70817E+00,-0.70894E+00,-0.70971E+00,-0.71048E+00, & + -0.71125E+00,-0.71202E+00,-0.71278E+00,-0.71355E+00,-0.71431E+00, & + -0.71507E+00,-0.71583E+00,-0.71659E+00,-0.71735E+00,-0.71811E+00, & + -0.71887E+00,-0.71962E+00,-0.72038E+00,-0.72113E+00,-0.72188E+00, & + -0.72263E+00,-0.72338E+00,-0.72413E+00,-0.72488E+00,-0.72563E+00, & + -0.72637E+00,-0.72712E+00,-0.72786E+00,-0.72860E+00,-0.72935E+00, & + -0.73009E+00,-0.73083E+00,-0.73156E+00,-0.73230E+00,-0.73304E+00, & + -0.73377E+00,-0.73451E+00,-0.73524E+00,-0.73597E+00,-0.73670E+00, & + -0.73743E+00,-0.73816E+00,-0.73889E+00,-0.73962E+00,-0.74034E+00, & + -0.74107E+00,-0.74179E+00,-0.74252E+00,-0.74324E+00,-0.74396E+00, & + -0.74468E+00,-0.74540E+00,-0.74612E+00,-0.74683E+00,-0.74755E+00, & + -0.74827E+00,-0.74898E+00,-0.74969E+00,-0.75041E+00,-0.75112E+00, & + -0.75183E+00,-0.75254E+00,-0.75325E+00,-0.75396E+00,-0.75467E+00, & + -0.75537E+00,-0.75608E+00,-0.75678E+00,-0.75749E+00,-0.75819E+00, & + -0.75889E+00,-0.75959E+00,-0.76029E+00,-0.76099E+00,-0.76169E+00/ + + DATA (BNC03M (I),I=401,500)/ & + -0.76239E+00,-0.76308E+00,-0.76378E+00,-0.76447E+00,-0.76517E+00, & + -0.76586E+00,-0.76655E+00,-0.76725E+00,-0.76794E+00,-0.76863E+00, & + -0.76932E+00,-0.77001E+00,-0.77069E+00,-0.77138E+00,-0.77207E+00, & + -0.77275E+00,-0.77344E+00,-0.77412E+00,-0.77480E+00,-0.77548E+00, & + -0.77616E+00,-0.77684E+00,-0.77752E+00,-0.77820E+00,-0.77888E+00, & + -0.77956E+00,-0.78024E+00,-0.78091E+00,-0.78159E+00,-0.78226E+00, & + -0.78293E+00,-0.78361E+00,-0.78428E+00,-0.78495E+00,-0.78562E+00, & + -0.78629E+00,-0.78696E+00,-0.78763E+00,-0.78829E+00,-0.78896E+00, & + -0.78963E+00,-0.79029E+00,-0.79096E+00,-0.79162E+00,-0.79228E+00, & + -0.79295E+00,-0.79361E+00,-0.79427E+00,-0.79493E+00,-0.79559E+00, & + -0.79625E+00,-0.79691E+00,-0.79756E+00,-0.79822E+00,-0.79888E+00, & + -0.79953E+00,-0.80019E+00,-0.80084E+00,-0.80149E+00,-0.80215E+00, & + -0.80280E+00,-0.80345E+00,-0.80410E+00,-0.80475E+00,-0.80540E+00, & + -0.80605E+00,-0.80670E+00,-0.80734E+00,-0.80799E+00,-0.80864E+00, & + -0.80928E+00,-0.80993E+00,-0.81057E+00,-0.81121E+00,-0.81186E+00, & + -0.81250E+00,-0.81314E+00,-0.81378E+00,-0.81442E+00,-0.81506E+00, & + -0.81570E+00,-0.81634E+00,-0.81698E+00,-0.81761E+00,-0.81825E+00, & + -0.81888E+00,-0.81952E+00,-0.82015E+00,-0.82079E+00,-0.82142E+00, & + -0.82205E+00,-0.82269E+00,-0.82332E+00,-0.82395E+00,-0.82458E+00, & + -0.82521E+00,-0.82584E+00,-0.82647E+00,-0.82710E+00,-0.82772E+00/ + + DATA (BNC03M (I),I=501,600)/ & + -0.82835E+00,-0.82898E+00,-0.82960E+00,-0.83023E+00,-0.83085E+00, & + -0.83147E+00,-0.83210E+00,-0.83272E+00,-0.83334E+00,-0.83397E+00, & + -0.83459E+00,-0.83521E+00,-0.83583E+00,-0.83645E+00,-0.83706E+00, & + -0.83768E+00,-0.83830E+00,-0.83892E+00,-0.83953E+00,-0.84015E+00, & + -0.84077E+00,-0.84138E+00,-0.84200E+00,-0.84261E+00,-0.84322E+00, & + -0.84384E+00,-0.84445E+00,-0.84506E+00,-0.84567E+00,-0.84628E+00, & + -0.84689E+00,-0.84750E+00,-0.84811E+00,-0.84872E+00,-0.84933E+00, & + -0.84993E+00,-0.85054E+00,-0.85115E+00,-0.85175E+00,-0.85236E+00, & + -0.85296E+00,-0.85357E+00,-0.85417E+00,-0.85478E+00,-0.85538E+00, & + -0.85598E+00,-0.85658E+00,-0.85718E+00,-0.85779E+00,-0.85839E+00, & + -0.85899E+00,-0.85959E+00,-0.86018E+00,-0.86078E+00,-0.86138E+00, & + -0.86198E+00,-0.86257E+00,-0.86317E+00,-0.86377E+00,-0.86436E+00, & + -0.86496E+00,-0.86555E+00,-0.86615E+00,-0.86674E+00,-0.86733E+00, & + -0.86793E+00,-0.86852E+00,-0.86911E+00,-0.86970E+00,-0.87029E+00, & + -0.87088E+00,-0.87147E+00,-0.87206E+00,-0.87265E+00,-0.87324E+00, & + -0.87383E+00,-0.87441E+00,-0.87500E+00,-0.87559E+00,-0.87617E+00, & + -0.87676E+00,-0.87734E+00,-0.87793E+00,-0.87851E+00,-0.87910E+00, & + -0.87968E+00,-0.88026E+00,-0.88085E+00,-0.88143E+00,-0.88201E+00, & + -0.88259E+00,-0.88317E+00,-0.88375E+00,-0.88433E+00,-0.88491E+00, & + -0.88549E+00,-0.88607E+00,-0.88665E+00,-0.88723E+00,-0.88939E+00/ + + DATA (BNC03M (I),I=601,700)/ & + -0.89413E+00,-0.89983E+00,-0.90549E+00,-0.91112E+00,-0.91671E+00, & + -0.92226E+00,-0.92777E+00,-0.93325E+00,-0.93869E+00,-0.94410E+00, & + -0.94948E+00,-0.95483E+00,-0.96015E+00,-0.96543E+00,-0.97069E+00, & + -0.97592E+00,-0.98112E+00,-0.98629E+00,-0.99143E+00,-0.99655E+00, & + -0.10016E+01,-0.10067E+01,-0.10118E+01,-0.10168E+01,-0.10218E+01, & + -0.10267E+01,-0.10317E+01,-0.10366E+01,-0.10415E+01,-0.10464E+01, & + -0.10513E+01,-0.10561E+01,-0.10609E+01,-0.10658E+01,-0.10705E+01, & + -0.10753E+01,-0.10801E+01,-0.10848E+01,-0.10895E+01,-0.10942E+01, & + -0.10989E+01,-0.11035E+01,-0.11082E+01,-0.11128E+01,-0.11174E+01, & + -0.11220E+01,-0.11266E+01,-0.11311E+01,-0.11357E+01,-0.11402E+01, & + -0.11447E+01,-0.11493E+01,-0.11537E+01,-0.11582E+01,-0.11627E+01, & + -0.11671E+01,-0.11716E+01,-0.11760E+01,-0.11804E+01,-0.11848E+01, & + -0.11892E+01,-0.11936E+01,-0.11979E+01,-0.12023E+01,-0.12066E+01, & + -0.12109E+01,-0.12153E+01,-0.12196E+01,-0.12239E+01,-0.12281E+01, & + -0.12324E+01,-0.12367E+01,-0.12409E+01,-0.12452E+01,-0.12494E+01, & + -0.12536E+01,-0.12578E+01,-0.12620E+01,-0.12662E+01,-0.12704E+01, & + -0.12746E+01,-0.12787E+01,-0.12829E+01,-0.12870E+01,-0.12912E+01, & + -0.12953E+01,-0.12994E+01,-0.13035E+01,-0.13076E+01,-0.13117E+01, & + -0.13158E+01,-0.13199E+01,-0.13239E+01,-0.13280E+01,-0.13320E+01, & + -0.13361E+01,-0.13401E+01,-0.13441E+01,-0.13482E+01,-0.13522E+01/ + + DATA (BNC03M(I),I=701,741)/ & + -0.13562E+01,-0.13602E+01,-0.13642E+01,-0.13682E+01,-0.13721E+01, & + -0.13761E+01,-0.13801E+01,-0.13840E+01,-0.13880E+01,-0.13919E+01, & + -0.13959E+01,-0.13998E+01,-0.14037E+01,-0.14076E+01,-0.14115E+01, & + -0.14154E+01,-0.14193E+01,-0.14232E+01,-0.14271E+01,-0.14310E+01, & + -0.14349E+01,-0.14387E+01,-0.14426E+01,-0.14464E+01,-0.14503E+01, & + -0.14541E+01,-0.14580E+01,-0.14618E+01,-0.14656E+01,-0.14695E+01, & + -0.14733E+01,-0.14771E+01,-0.14809E+01,-0.14847E+01,-0.14885E+01, & + -0.14923E+01,-0.14961E+01,-0.14998E+01,-0.15036E+01,-0.15074E+01, & + -0.15112E+01 & + / +! +! *** (NH4)2SO4 +! + DATA (BNC04M (I),I= 1,100)/ & + -0.10856E+00,-0.19872E+00,-0.26292E+00,-0.30708E+00,-0.34142E+00, & + -0.36979E+00,-0.39407E+00,-0.41538E+00,-0.43441E+00,-0.45164E+00, & + -0.46739E+00,-0.48193E+00,-0.49544E+00,-0.50808E+00,-0.51994E+00, & + -0.53114E+00,-0.54176E+00,-0.55184E+00,-0.56146E+00,-0.57065E+00, & + -0.57946E+00,-0.58792E+00,-0.59606E+00,-0.60391E+00,-0.61148E+00, & + -0.61880E+00,-0.62590E+00,-0.63277E+00,-0.63944E+00,-0.64593E+00, & + -0.65223E+00,-0.65837E+00,-0.66435E+00,-0.67019E+00,-0.67588E+00, & + -0.68144E+00,-0.68688E+00,-0.69219E+00,-0.69739E+00,-0.70249E+00, & + -0.70748E+00,-0.71237E+00,-0.71716E+00,-0.72187E+00,-0.72648E+00, & + -0.73102E+00,-0.73548E+00,-0.73985E+00,-0.74416E+00,-0.74840E+00, & + -0.75256E+00,-0.75666E+00,-0.76070E+00,-0.76468E+00,-0.76860E+00, & + -0.77246E+00,-0.77627E+00,-0.78002E+00,-0.78373E+00,-0.78739E+00, & + -0.79099E+00,-0.79456E+00,-0.79808E+00,-0.80155E+00,-0.80499E+00, & + -0.80839E+00,-0.81175E+00,-0.81507E+00,-0.81835E+00,-0.82160E+00, & + -0.82482E+00,-0.82801E+00,-0.83116E+00,-0.83428E+00,-0.83738E+00, & + -0.84045E+00,-0.84349E+00,-0.84650E+00,-0.84949E+00,-0.85245E+00, & + -0.85539E+00,-0.85831E+00,-0.86120E+00,-0.86407E+00,-0.86692E+00, & + -0.86975E+00,-0.87256E+00,-0.87535E+00,-0.87812E+00,-0.88088E+00, & + -0.88361E+00,-0.88633E+00,-0.88903E+00,-0.89172E+00,-0.89438E+00, & + -0.89704E+00,-0.89967E+00,-0.90229E+00,-0.90490E+00,-0.90749E+00/ + + DATA (BNC04M (I),I=101,200)/ & + -0.91007E+00,-0.91263E+00,-0.91518E+00,-0.91772E+00,-0.92024E+00, & + -0.92275E+00,-0.92524E+00,-0.92772E+00,-0.93019E+00,-0.93265E+00, & + -0.93509E+00,-0.93752E+00,-0.93994E+00,-0.94235E+00,-0.94475E+00, & + -0.94713E+00,-0.94950E+00,-0.95186E+00,-0.95421E+00,-0.95655E+00, & + -0.95881E+00,-0.96113E+00,-0.96344E+00,-0.96574E+00,-0.96803E+00, & + -0.97031E+00,-0.97257E+00,-0.97483E+00,-0.97707E+00,-0.97930E+00, & + -0.98153E+00,-0.98374E+00,-0.98594E+00,-0.98813E+00,-0.99032E+00, & + -0.99249E+00,-0.99465E+00,-0.99681E+00,-0.99895E+00,-0.10011E+01, & + -0.10032E+01,-0.10053E+01,-0.10074E+01,-0.10095E+01,-0.10116E+01, & + -0.10137E+01,-0.10158E+01,-0.10179E+01,-0.10199E+01,-0.10220E+01, & + -0.10240E+01,-0.10260E+01,-0.10281E+01,-0.10301E+01,-0.10321E+01, & + -0.10341E+01,-0.10361E+01,-0.10381E+01,-0.10401E+01,-0.10420E+01, & + -0.10440E+01,-0.10460E+01,-0.10479E+01,-0.10499E+01,-0.10518E+01, & + -0.10537E+01,-0.10556E+01,-0.10576E+01,-0.10595E+01,-0.10614E+01, & + -0.10633E+01,-0.10652E+01,-0.10671E+01,-0.10689E+01,-0.10708E+01, & + -0.10727E+01,-0.10746E+01,-0.10764E+01,-0.10783E+01,-0.10801E+01, & + -0.10819E+01,-0.10838E+01,-0.10856E+01,-0.10874E+01,-0.10892E+01, & + -0.10911E+01,-0.10929E+01,-0.10947E+01,-0.10965E+01,-0.10983E+01, & + -0.11000E+01,-0.11018E+01,-0.11036E+01,-0.11054E+01,-0.11071E+01, & + -0.11089E+01,-0.11106E+01,-0.11124E+01,-0.11141E+01,-0.11159E+01/ + + DATA (BNC04M (I),I=201,300)/ & + -0.11176E+01,-0.11193E+01,-0.11211E+01,-0.11228E+01,-0.11245E+01, & + -0.11262E+01,-0.11279E+01,-0.11296E+01,-0.11313E+01,-0.11330E+01, & + -0.11347E+01,-0.11364E+01,-0.11381E+01,-0.11398E+01,-0.11414E+01, & + -0.11431E+01,-0.11448E+01,-0.11464E+01,-0.11481E+01,-0.11497E+01, & + -0.11514E+01,-0.11530E+01,-0.11547E+01,-0.11563E+01,-0.11579E+01, & + -0.11596E+01,-0.11612E+01,-0.11628E+01,-0.11644E+01,-0.11660E+01, & + -0.11677E+01,-0.11693E+01,-0.11709E+01,-0.11725E+01,-0.11741E+01, & + -0.11757E+01,-0.11772E+01,-0.11788E+01,-0.11804E+01,-0.11820E+01, & + -0.11836E+01,-0.11851E+01,-0.11867E+01,-0.11883E+01,-0.11898E+01, & + -0.11914E+01,-0.11929E+01,-0.11945E+01,-0.11960E+01,-0.11976E+01, & + -0.11991E+01,-0.12007E+01,-0.12022E+01,-0.12037E+01,-0.12053E+01, & + -0.12068E+01,-0.12083E+01,-0.12098E+01,-0.12114E+01,-0.12129E+01, & + -0.12144E+01,-0.12159E+01,-0.12174E+01,-0.12189E+01,-0.12204E+01, & + -0.12219E+01,-0.12234E+01,-0.12249E+01,-0.12264E+01,-0.12278E+01, & + -0.12293E+01,-0.12308E+01,-0.12323E+01,-0.12338E+01,-0.12352E+01, & + -0.12367E+01,-0.12382E+01,-0.12396E+01,-0.12411E+01,-0.12426E+01, & + -0.12440E+01,-0.12455E+01,-0.12469E+01,-0.12484E+01,-0.12498E+01, & + -0.12513E+01,-0.12527E+01,-0.12541E+01,-0.12556E+01,-0.12570E+01, & + -0.12584E+01,-0.12599E+01,-0.12613E+01,-0.12627E+01,-0.12641E+01, & + -0.12655E+01,-0.12670E+01,-0.12684E+01,-0.12698E+01,-0.12712E+01/ + + DATA (BNC04M (I),I=301,400)/ & + -0.12726E+01,-0.12740E+01,-0.12754E+01,-0.12768E+01,-0.12782E+01, & + -0.12796E+01,-0.12810E+01,-0.12824E+01,-0.12838E+01,-0.12852E+01, & + -0.12866E+01,-0.12879E+01,-0.12893E+01,-0.12907E+01,-0.12921E+01, & + -0.12934E+01,-0.12948E+01,-0.12962E+01,-0.12976E+01,-0.12989E+01, & + -0.13003E+01,-0.13016E+01,-0.13030E+01,-0.13044E+01,-0.13057E+01, & + -0.13071E+01,-0.13084E+01,-0.13098E+01,-0.13111E+01,-0.13125E+01, & + -0.13138E+01,-0.13152E+01,-0.13165E+01,-0.13178E+01,-0.13192E+01, & + -0.13205E+01,-0.13218E+01,-0.13232E+01,-0.13245E+01,-0.13258E+01, & + -0.13271E+01,-0.13285E+01,-0.13298E+01,-0.13311E+01,-0.13324E+01, & + -0.13337E+01,-0.13351E+01,-0.13364E+01,-0.13377E+01,-0.13390E+01, & + -0.13403E+01,-0.13416E+01,-0.13429E+01,-0.13442E+01,-0.13455E+01, & + -0.13468E+01,-0.13481E+01,-0.13494E+01,-0.13507E+01,-0.13520E+01, & + -0.13533E+01,-0.13546E+01,-0.13558E+01,-0.13571E+01,-0.13584E+01, & + -0.13597E+01,-0.13610E+01,-0.13623E+01,-0.13635E+01,-0.13648E+01, & + -0.13661E+01,-0.13674E+01,-0.13686E+01,-0.13699E+01,-0.13712E+01, & + -0.13724E+01,-0.13737E+01,-0.13750E+01,-0.13762E+01,-0.13775E+01, & + -0.13787E+01,-0.13800E+01,-0.13812E+01,-0.13825E+01,-0.13838E+01, & + -0.13850E+01,-0.13863E+01,-0.13875E+01,-0.13887E+01,-0.13900E+01, & + -0.13912E+01,-0.13925E+01,-0.13937E+01,-0.13950E+01,-0.13962E+01, & + -0.13974E+01,-0.13987E+01,-0.13999E+01,-0.14011E+01,-0.14024E+01/ + + DATA (BNC04M (I),I=401,500)/ & + -0.14036E+01,-0.14048E+01,-0.14060E+01,-0.14073E+01,-0.14085E+01, & + -0.14097E+01,-0.14109E+01,-0.14122E+01,-0.14134E+01,-0.14146E+01, & + -0.14158E+01,-0.14170E+01,-0.14182E+01,-0.14195E+01,-0.14207E+01, & + -0.14219E+01,-0.14231E+01,-0.14243E+01,-0.14255E+01,-0.14267E+01, & + -0.14279E+01,-0.14291E+01,-0.14303E+01,-0.14315E+01,-0.14327E+01, & + -0.14339E+01,-0.14351E+01,-0.14363E+01,-0.14375E+01,-0.14387E+01, & + -0.14399E+01,-0.14411E+01,-0.14422E+01,-0.14434E+01,-0.14446E+01, & + -0.14458E+01,-0.14470E+01,-0.14482E+01,-0.14493E+01,-0.14505E+01, & + -0.14517E+01,-0.14529E+01,-0.14541E+01,-0.14552E+01,-0.14564E+01, & + -0.14576E+01,-0.14587E+01,-0.14599E+01,-0.14611E+01,-0.14623E+01, & + -0.14634E+01,-0.14646E+01,-0.14658E+01,-0.14669E+01,-0.14681E+01, & + -0.14692E+01,-0.14704E+01,-0.14716E+01,-0.14727E+01,-0.14739E+01, & + -0.14750E+01,-0.14762E+01,-0.14773E+01,-0.14785E+01,-0.14797E+01, & + -0.14808E+01,-0.14820E+01,-0.14831E+01,-0.14842E+01,-0.14854E+01, & + -0.14865E+01,-0.14877E+01,-0.14888E+01,-0.14900E+01,-0.14911E+01, & + -0.14923E+01,-0.14934E+01,-0.14945E+01,-0.14957E+01,-0.14968E+01, & + -0.14979E+01,-0.14991E+01,-0.15002E+01,-0.15013E+01,-0.15025E+01, & + -0.15036E+01,-0.15047E+01,-0.15059E+01,-0.15070E+01,-0.15081E+01, & + -0.15092E+01,-0.15104E+01,-0.15115E+01,-0.15126E+01,-0.15137E+01, & + -0.15149E+01,-0.15160E+01,-0.15171E+01,-0.15182E+01,-0.15193E+01/ + + DATA (BNC04M (I),I=501,600)/ & + -0.15204E+01,-0.15216E+01,-0.15227E+01,-0.15238E+01,-0.15249E+01, & + -0.15260E+01,-0.15271E+01,-0.15282E+01,-0.15293E+01,-0.15305E+01, & + -0.15316E+01,-0.15327E+01,-0.15338E+01,-0.15349E+01,-0.15360E+01, & + -0.15371E+01,-0.15382E+01,-0.15393E+01,-0.15404E+01,-0.15415E+01, & + -0.15426E+01,-0.15437E+01,-0.15448E+01,-0.15459E+01,-0.15470E+01, & + -0.15481E+01,-0.15492E+01,-0.15502E+01,-0.15513E+01,-0.15524E+01, & + -0.15535E+01,-0.15546E+01,-0.15557E+01,-0.15568E+01,-0.15579E+01, & + -0.15590E+01,-0.15600E+01,-0.15611E+01,-0.15622E+01,-0.15633E+01, & + -0.15644E+01,-0.15655E+01,-0.15665E+01,-0.15676E+01,-0.15687E+01, & + -0.15698E+01,-0.15708E+01,-0.15719E+01,-0.15730E+01,-0.15741E+01, & + -0.15751E+01,-0.15762E+01,-0.15773E+01,-0.15784E+01,-0.15794E+01, & + -0.15805E+01,-0.15816E+01,-0.15826E+01,-0.15837E+01,-0.15848E+01, & + -0.15858E+01,-0.15869E+01,-0.15880E+01,-0.15890E+01,-0.15901E+01, & + -0.15912E+01,-0.15922E+01,-0.15933E+01,-0.15943E+01,-0.15954E+01, & + -0.15965E+01,-0.15975E+01,-0.15986E+01,-0.15996E+01,-0.16007E+01, & + -0.16017E+01,-0.16028E+01,-0.16038E+01,-0.16049E+01,-0.16059E+01, & + -0.16070E+01,-0.16080E+01,-0.16091E+01,-0.16101E+01,-0.16112E+01, & + -0.16122E+01,-0.16133E+01,-0.16143E+01,-0.16154E+01,-0.16164E+01, & + -0.16175E+01,-0.16185E+01,-0.16196E+01,-0.16206E+01,-0.16216E+01, & + -0.16227E+01,-0.16237E+01,-0.16248E+01,-0.16258E+01,-0.16297E+01/ + + DATA (BNC04M (I),I=601,700)/ & + -0.16382E+01,-0.16485E+01,-0.16587E+01,-0.16688E+01,-0.16789E+01, & + -0.16890E+01,-0.16989E+01,-0.17088E+01,-0.17187E+01,-0.17285E+01, & + -0.17383E+01,-0.17480E+01,-0.17576E+01,-0.17673E+01,-0.17768E+01, & + -0.17863E+01,-0.17958E+01,-0.18053E+01,-0.18146E+01,-0.18240E+01, & + -0.18333E+01,-0.18426E+01,-0.18518E+01,-0.18610E+01,-0.18702E+01, & + -0.18793E+01,-0.18884E+01,-0.18974E+01,-0.19065E+01,-0.19154E+01, & + -0.19244E+01,-0.19333E+01,-0.19422E+01,-0.19511E+01,-0.19599E+01, & + -0.19687E+01,-0.19775E+01,-0.19862E+01,-0.19949E+01,-0.20036E+01, & + -0.20123E+01,-0.20209E+01,-0.20295E+01,-0.20381E+01,-0.20466E+01, & + -0.20552E+01,-0.20637E+01,-0.20722E+01,-0.20806E+01,-0.20890E+01, & + -0.20975E+01,-0.21058E+01,-0.21142E+01,-0.21226E+01,-0.21309E+01, & + -0.21392E+01,-0.21475E+01,-0.21557E+01,-0.21640E+01,-0.21722E+01, & + -0.21804E+01,-0.21886E+01,-0.21968E+01,-0.22049E+01,-0.22130E+01, & + -0.22211E+01,-0.22292E+01,-0.22373E+01,-0.22454E+01,-0.22534E+01, & + -0.22614E+01,-0.22694E+01,-0.22774E+01,-0.22854E+01,-0.22933E+01, & + -0.23013E+01,-0.23092E+01,-0.23171E+01,-0.23250E+01,-0.23329E+01, & + -0.23408E+01,-0.23486E+01,-0.23564E+01,-0.23643E+01,-0.23721E+01, & + -0.23799E+01,-0.23876E+01,-0.23954E+01,-0.24032E+01,-0.24109E+01, & + -0.24186E+01,-0.24263E+01,-0.24340E+01,-0.24417E+01,-0.24494E+01, & + -0.24570E+01,-0.24647E+01,-0.24723E+01,-0.24800E+01,-0.24876E+01/ + + DATA (BNC04M(I),I=701,741)/ & + -0.24952E+01,-0.25028E+01,-0.25103E+01,-0.25179E+01,-0.25255E+01, & + -0.25330E+01,-0.25405E+01,-0.25481E+01,-0.25556E+01,-0.25631E+01, & + -0.25706E+01,-0.25780E+01,-0.25855E+01,-0.25930E+01,-0.26004E+01, & + -0.26079E+01,-0.26153E+01,-0.26227E+01,-0.26301E+01,-0.26375E+01, & + -0.26449E+01,-0.26523E+01,-0.26597E+01,-0.26670E+01,-0.26744E+01, & + -0.26817E+01,-0.26891E+01,-0.26964E+01,-0.27037E+01,-0.27110E+01, & + -0.27183E+01,-0.27256E+01,-0.27329E+01,-0.27401E+01,-0.27474E+01, & + -0.27547E+01,-0.27619E+01,-0.27692E+01,-0.27764E+01,-0.27836E+01, & + -0.27908E+01 & + / +! +! *** NH4NO3 +! + DATA (BNC05M (I),I= 1,100)/ & + -0.55115E-01,-0.10248E+00,-0.13740E+00,-0.16216E+00,-0.18192E+00, & + -0.19861E+00,-0.21320E+00,-0.22626E+00,-0.23813E+00,-0.24905E+00, & + -0.25921E+00,-0.26872E+00,-0.27769E+00,-0.28619E+00,-0.29428E+00, & + -0.30201E+00,-0.30943E+00,-0.31655E+00,-0.32341E+00,-0.33004E+00, & + -0.33646E+00,-0.34268E+00,-0.34871E+00,-0.35458E+00,-0.36029E+00, & + -0.36586E+00,-0.37128E+00,-0.37658E+00,-0.38176E+00,-0.38682E+00, & + -0.39178E+00,-0.39663E+00,-0.40138E+00,-0.40603E+00,-0.41060E+00, & + -0.41508E+00,-0.41948E+00,-0.42380E+00,-0.42805E+00,-0.43222E+00, & + -0.43632E+00,-0.44035E+00,-0.44432E+00,-0.44823E+00,-0.45207E+00, & + -0.45585E+00,-0.45958E+00,-0.46325E+00,-0.46687E+00,-0.47044E+00, & + -0.47395E+00,-0.47742E+00,-0.48084E+00,-0.48422E+00,-0.48755E+00, & + -0.49084E+00,-0.49409E+00,-0.49730E+00,-0.50048E+00,-0.50361E+00, & + -0.50671E+00,-0.50978E+00,-0.51282E+00,-0.51582E+00,-0.51880E+00, & + -0.52174E+00,-0.52466E+00,-0.52755E+00,-0.53041E+00,-0.53326E+00, & + -0.53607E+00,-0.53887E+00,-0.54164E+00,-0.54440E+00,-0.54713E+00, & + -0.54985E+00,-0.55255E+00,-0.55523E+00,-0.55790E+00,-0.56055E+00, & + -0.56319E+00,-0.56581E+00,-0.56842E+00,-0.57102E+00,-0.57360E+00, & + -0.57617E+00,-0.57874E+00,-0.58129E+00,-0.58383E+00,-0.58636E+00, & + -0.58888E+00,-0.59139E+00,-0.59389E+00,-0.59638E+00,-0.59887E+00, & + -0.60134E+00,-0.60381E+00,-0.60627E+00,-0.60872E+00,-0.61116E+00/ + + DATA (BNC05M (I),I=101,200)/ & + -0.61360E+00,-0.61602E+00,-0.61844E+00,-0.62085E+00,-0.62325E+00, & + -0.62565E+00,-0.62803E+00,-0.63041E+00,-0.63278E+00,-0.63514E+00, & + -0.63749E+00,-0.63983E+00,-0.64217E+00,-0.64449E+00,-0.64681E+00, & + -0.64912E+00,-0.65142E+00,-0.65371E+00,-0.65599E+00,-0.65827E+00, & + -0.66039E+00,-0.66266E+00,-0.66492E+00,-0.66718E+00,-0.66942E+00, & + -0.67165E+00,-0.67387E+00,-0.67608E+00,-0.67828E+00,-0.68047E+00, & + -0.68265E+00,-0.68482E+00,-0.68698E+00,-0.68914E+00,-0.69128E+00, & + -0.69341E+00,-0.69554E+00,-0.69765E+00,-0.69976E+00,-0.70186E+00, & + -0.70395E+00,-0.70603E+00,-0.70810E+00,-0.71016E+00,-0.71222E+00, & + -0.71426E+00,-0.71630E+00,-0.71833E+00,-0.72035E+00,-0.72237E+00, & + -0.72437E+00,-0.72637E+00,-0.72836E+00,-0.73034E+00,-0.73232E+00, & + -0.73428E+00,-0.73624E+00,-0.73820E+00,-0.74014E+00,-0.74208E+00, & + -0.74401E+00,-0.74593E+00,-0.74784E+00,-0.74975E+00,-0.75165E+00, & + -0.75355E+00,-0.75544E+00,-0.75732E+00,-0.75919E+00,-0.76106E+00, & + -0.76292E+00,-0.76477E+00,-0.76662E+00,-0.76846E+00,-0.77029E+00, & + -0.77212E+00,-0.77394E+00,-0.77575E+00,-0.77756E+00,-0.77936E+00, & + -0.78116E+00,-0.78295E+00,-0.78473E+00,-0.78651E+00,-0.78828E+00, & + -0.79005E+00,-0.79180E+00,-0.79356E+00,-0.79531E+00,-0.79705E+00, & + -0.79878E+00,-0.80051E+00,-0.80224E+00,-0.80396E+00,-0.80567E+00, & + -0.80738E+00,-0.80908E+00,-0.81078E+00,-0.81247E+00,-0.81416E+00/ + + DATA (BNC05M (I),I=201,300)/ & + -0.81584E+00,-0.81751E+00,-0.81918E+00,-0.82085E+00,-0.82251E+00, & + -0.82416E+00,-0.82581E+00,-0.82746E+00,-0.82910E+00,-0.83073E+00, & + -0.83236E+00,-0.83398E+00,-0.83560E+00,-0.83722E+00,-0.83883E+00, & + -0.84043E+00,-0.84203E+00,-0.84363E+00,-0.84522E+00,-0.84680E+00, & + -0.84839E+00,-0.84996E+00,-0.85153E+00,-0.85310E+00,-0.85466E+00, & + -0.85622E+00,-0.85778E+00,-0.85932E+00,-0.86087E+00,-0.86241E+00, & + -0.86395E+00,-0.86548E+00,-0.86700E+00,-0.86853E+00,-0.87005E+00, & + -0.87156E+00,-0.87307E+00,-0.87458E+00,-0.87608E+00,-0.87758E+00, & + -0.87907E+00,-0.88056E+00,-0.88204E+00,-0.88353E+00,-0.88500E+00, & + -0.88648E+00,-0.88794E+00,-0.88941E+00,-0.89087E+00,-0.89233E+00, & + -0.89378E+00,-0.89523E+00,-0.89668E+00,-0.89812E+00,-0.89956E+00, & + -0.90099E+00,-0.90242E+00,-0.90385E+00,-0.90527E+00,-0.90669E+00, & + -0.90811E+00,-0.90952E+00,-0.91093E+00,-0.91233E+00,-0.91373E+00, & + -0.91513E+00,-0.91653E+00,-0.91792E+00,-0.91930E+00,-0.92069E+00, & + -0.92207E+00,-0.92344E+00,-0.92482E+00,-0.92619E+00,-0.92755E+00, & + -0.92892E+00,-0.93028E+00,-0.93163E+00,-0.93299E+00,-0.93434E+00, & + -0.93568E+00,-0.93703E+00,-0.93837E+00,-0.93970E+00,-0.94104E+00, & + -0.94237E+00,-0.94369E+00,-0.94502E+00,-0.94634E+00,-0.94765E+00, & + -0.94897E+00,-0.95028E+00,-0.95159E+00,-0.95289E+00,-0.95420E+00, & + -0.95549E+00,-0.95679E+00,-0.95808E+00,-0.95937E+00,-0.96066E+00/ + + DATA (BNC05M (I),I=301,400)/ & + -0.96194E+00,-0.96323E+00,-0.96450E+00,-0.96578E+00,-0.96705E+00, & + -0.96832E+00,-0.96959E+00,-0.97085E+00,-0.97211E+00,-0.97337E+00, & + -0.97463E+00,-0.97588E+00,-0.97713E+00,-0.97837E+00,-0.97962E+00, & + -0.98086E+00,-0.98210E+00,-0.98333E+00,-0.98457E+00,-0.98580E+00, & + -0.98703E+00,-0.98825E+00,-0.98947E+00,-0.99069E+00,-0.99191E+00, & + -0.99312E+00,-0.99434E+00,-0.99554E+00,-0.99675E+00,-0.99796E+00, & + -0.99916E+00,-0.10004E+01,-0.10016E+01,-0.10027E+01,-0.10039E+01, & + -0.10051E+01,-0.10063E+01,-0.10075E+01,-0.10087E+01,-0.10099E+01, & + -0.10110E+01,-0.10122E+01,-0.10134E+01,-0.10145E+01,-0.10157E+01, & + -0.10169E+01,-0.10180E+01,-0.10192E+01,-0.10204E+01,-0.10215E+01, & + -0.10227E+01,-0.10238E+01,-0.10250E+01,-0.10261E+01,-0.10273E+01, & + -0.10284E+01,-0.10295E+01,-0.10307E+01,-0.10318E+01,-0.10329E+01, & + -0.10341E+01,-0.10352E+01,-0.10363E+01,-0.10374E+01,-0.10386E+01, & + -0.10397E+01,-0.10408E+01,-0.10419E+01,-0.10430E+01,-0.10441E+01, & + -0.10452E+01,-0.10464E+01,-0.10475E+01,-0.10486E+01,-0.10497E+01, & + -0.10508E+01,-0.10519E+01,-0.10529E+01,-0.10540E+01,-0.10551E+01, & + -0.10562E+01,-0.10573E+01,-0.10584E+01,-0.10595E+01,-0.10605E+01, & + -0.10616E+01,-0.10627E+01,-0.10638E+01,-0.10648E+01,-0.10659E+01, & + -0.10670E+01,-0.10680E+01,-0.10691E+01,-0.10702E+01,-0.10712E+01, & + -0.10723E+01,-0.10733E+01,-0.10744E+01,-0.10754E+01,-0.10765E+01/ + + DATA (BNC05M (I),I=401,500)/ & + -0.10775E+01,-0.10786E+01,-0.10796E+01,-0.10807E+01,-0.10817E+01, & + -0.10827E+01,-0.10838E+01,-0.10848E+01,-0.10859E+01,-0.10869E+01, & + -0.10879E+01,-0.10889E+01,-0.10900E+01,-0.10910E+01,-0.10920E+01, & + -0.10930E+01,-0.10941E+01,-0.10951E+01,-0.10961E+01,-0.10971E+01, & + -0.10981E+01,-0.10991E+01,-0.11001E+01,-0.11011E+01,-0.11021E+01, & + -0.11031E+01,-0.11041E+01,-0.11051E+01,-0.11061E+01,-0.11071E+01, & + -0.11081E+01,-0.11091E+01,-0.11101E+01,-0.11111E+01,-0.11121E+01, & + -0.11131E+01,-0.11141E+01,-0.11150E+01,-0.11160E+01,-0.11170E+01, & + -0.11180E+01,-0.11190E+01,-0.11199E+01,-0.11209E+01,-0.11219E+01, & + -0.11229E+01,-0.11238E+01,-0.11248E+01,-0.11258E+01,-0.11267E+01, & + -0.11277E+01,-0.11286E+01,-0.11296E+01,-0.11306E+01,-0.11315E+01, & + -0.11325E+01,-0.11334E+01,-0.11344E+01,-0.11353E+01,-0.11363E+01, & + -0.11372E+01,-0.11382E+01,-0.11391E+01,-0.11401E+01,-0.11410E+01, & + -0.11419E+01,-0.11429E+01,-0.11438E+01,-0.11448E+01,-0.11457E+01, & + -0.11466E+01,-0.11476E+01,-0.11485E+01,-0.11494E+01,-0.11503E+01, & + -0.11513E+01,-0.11522E+01,-0.11531E+01,-0.11540E+01,-0.11549E+01, & + -0.11559E+01,-0.11568E+01,-0.11577E+01,-0.11586E+01,-0.11595E+01, & + -0.11604E+01,-0.11614E+01,-0.11623E+01,-0.11632E+01,-0.11641E+01, & + -0.11650E+01,-0.11659E+01,-0.11668E+01,-0.11677E+01,-0.11686E+01, & + -0.11695E+01,-0.11704E+01,-0.11713E+01,-0.11722E+01,-0.11731E+01/ + + DATA (BNC05M (I),I=501,600)/ & + -0.11740E+01,-0.11748E+01,-0.11757E+01,-0.11766E+01,-0.11775E+01, & + -0.11784E+01,-0.11793E+01,-0.11802E+01,-0.11810E+01,-0.11819E+01, & + -0.11828E+01,-0.11837E+01,-0.11846E+01,-0.11854E+01,-0.11863E+01, & + -0.11872E+01,-0.11881E+01,-0.11889E+01,-0.11898E+01,-0.11907E+01, & + -0.11915E+01,-0.11924E+01,-0.11933E+01,-0.11941E+01,-0.11950E+01, & + -0.11958E+01,-0.11967E+01,-0.11976E+01,-0.11984E+01,-0.11993E+01, & + -0.12001E+01,-0.12010E+01,-0.12018E+01,-0.12027E+01,-0.12035E+01, & + -0.12044E+01,-0.12052E+01,-0.12061E+01,-0.12069E+01,-0.12078E+01, & + -0.12086E+01,-0.12095E+01,-0.12103E+01,-0.12111E+01,-0.12120E+01, & + -0.12128E+01,-0.12137E+01,-0.12145E+01,-0.12153E+01,-0.12162E+01, & + -0.12170E+01,-0.12178E+01,-0.12186E+01,-0.12195E+01,-0.12203E+01, & + -0.12211E+01,-0.12220E+01,-0.12228E+01,-0.12236E+01,-0.12244E+01, & + -0.12252E+01,-0.12261E+01,-0.12269E+01,-0.12277E+01,-0.12285E+01, & + -0.12293E+01,-0.12302E+01,-0.12310E+01,-0.12318E+01,-0.12326E+01, & + -0.12334E+01,-0.12342E+01,-0.12350E+01,-0.12358E+01,-0.12366E+01, & + -0.12374E+01,-0.12383E+01,-0.12391E+01,-0.12399E+01,-0.12407E+01, & + -0.12415E+01,-0.12423E+01,-0.12431E+01,-0.12439E+01,-0.12447E+01, & + -0.12455E+01,-0.12462E+01,-0.12470E+01,-0.12478E+01,-0.12486E+01, & + -0.12494E+01,-0.12502E+01,-0.12510E+01,-0.12518E+01,-0.12526E+01, & + -0.12534E+01,-0.12541E+01,-0.12549E+01,-0.12557E+01,-0.12586E+01/ + + DATA (BNC05M (I),I=601,700)/ & + -0.12650E+01,-0.12727E+01,-0.12803E+01,-0.12878E+01,-0.12952E+01, & + -0.13026E+01,-0.13098E+01,-0.13170E+01,-0.13241E+01,-0.13312E+01, & + -0.13381E+01,-0.13450E+01,-0.13519E+01,-0.13586E+01,-0.13654E+01, & + -0.13720E+01,-0.13786E+01,-0.13851E+01,-0.13916E+01,-0.13980E+01, & + -0.14044E+01,-0.14107E+01,-0.14169E+01,-0.14231E+01,-0.14293E+01, & + -0.14354E+01,-0.14415E+01,-0.14475E+01,-0.14534E+01,-0.14594E+01, & + -0.14652E+01,-0.14711E+01,-0.14769E+01,-0.14827E+01,-0.14884E+01, & + -0.14941E+01,-0.14997E+01,-0.15053E+01,-0.15109E+01,-0.15164E+01, & + -0.15219E+01,-0.15274E+01,-0.15328E+01,-0.15382E+01,-0.15436E+01, & + -0.15490E+01,-0.15543E+01,-0.15595E+01,-0.15648E+01,-0.15700E+01, & + -0.15752E+01,-0.15804E+01,-0.15855E+01,-0.15906E+01,-0.15957E+01, & + -0.16008E+01,-0.16058E+01,-0.16108E+01,-0.16158E+01,-0.16208E+01, & + -0.16257E+01,-0.16306E+01,-0.16355E+01,-0.16404E+01,-0.16452E+01, & + -0.16500E+01,-0.16548E+01,-0.16596E+01,-0.16644E+01,-0.16691E+01, & + -0.16739E+01,-0.16786E+01,-0.16832E+01,-0.16879E+01,-0.16926E+01, & + -0.16972E+01,-0.17018E+01,-0.17064E+01,-0.17110E+01,-0.17155E+01, & + -0.17201E+01,-0.17246E+01,-0.17291E+01,-0.17336E+01,-0.17381E+01, & + -0.17425E+01,-0.17470E+01,-0.17514E+01,-0.17558E+01,-0.17602E+01, & + -0.17646E+01,-0.17690E+01,-0.17733E+01,-0.17777E+01,-0.17820E+01, & + -0.17863E+01,-0.17906E+01,-0.17949E+01,-0.17992E+01,-0.18035E+01/ + + DATA (BNC05M(I),I=701,741)/ & + -0.18077E+01,-0.18119E+01,-0.18162E+01,-0.18204E+01,-0.18246E+01, & + -0.18288E+01,-0.18330E+01,-0.18371E+01,-0.18413E+01,-0.18454E+01, & + -0.18496E+01,-0.18537E+01,-0.18578E+01,-0.18619E+01,-0.18660E+01, & + -0.18701E+01,-0.18742E+01,-0.18782E+01,-0.18823E+01,-0.18863E+01, & + -0.18903E+01,-0.18944E+01,-0.18984E+01,-0.19024E+01,-0.19064E+01, & + -0.19104E+01,-0.19144E+01,-0.19183E+01,-0.19223E+01,-0.19262E+01, & + -0.19302E+01,-0.19341E+01,-0.19380E+01,-0.19419E+01,-0.19459E+01, & + -0.19498E+01,-0.19537E+01,-0.19575E+01,-0.19614E+01,-0.19653E+01, & + -0.19691E+01 & + / +! +! *** NH4Cl +! + DATA (BNC06M (I),I= 1,100)/ & + -0.53384E-01,-0.96046E-01,-0.12518E+00,-0.14446E+00,-0.15894E+00, & + -0.17052E+00,-0.18011E+00,-0.18828E+00,-0.19534E+00,-0.20155E+00, & + -0.20706E+00,-0.21199E+00,-0.21644E+00,-0.22048E+00,-0.22416E+00, & + -0.22754E+00,-0.23064E+00,-0.23350E+00,-0.23615E+00,-0.23861E+00, & + -0.24090E+00,-0.24303E+00,-0.24503E+00,-0.24689E+00,-0.24864E+00, & + -0.25028E+00,-0.25183E+00,-0.25329E+00,-0.25466E+00,-0.25596E+00, & + -0.25718E+00,-0.25834E+00,-0.25944E+00,-0.26049E+00,-0.26148E+00, & + -0.26242E+00,-0.26332E+00,-0.26418E+00,-0.26499E+00,-0.26577E+00, & + -0.26651E+00,-0.26722E+00,-0.26790E+00,-0.26856E+00,-0.26918E+00, & + -0.26978E+00,-0.27035E+00,-0.27091E+00,-0.27144E+00,-0.27195E+00, & + -0.27244E+00,-0.27291E+00,-0.27337E+00,-0.27380E+00,-0.27422E+00, & + -0.27463E+00,-0.27502E+00,-0.27540E+00,-0.27576E+00,-0.27611E+00, & + -0.27645E+00,-0.27677E+00,-0.27708E+00,-0.27738E+00,-0.27767E+00, & + -0.27794E+00,-0.27821E+00,-0.27846E+00,-0.27870E+00,-0.27892E+00, & + -0.27914E+00,-0.27935E+00,-0.27954E+00,-0.27972E+00,-0.27989E+00, & + -0.28005E+00,-0.28020E+00,-0.28034E+00,-0.28047E+00,-0.28058E+00, & + -0.28069E+00,-0.28078E+00,-0.28086E+00,-0.28093E+00,-0.28099E+00, & + -0.28104E+00,-0.28108E+00,-0.28111E+00,-0.28112E+00,-0.28113E+00, & + -0.28113E+00,-0.28111E+00,-0.28109E+00,-0.28106E+00,-0.28101E+00, & + -0.28096E+00,-0.28090E+00,-0.28083E+00,-0.28075E+00,-0.28066E+00/ + + DATA (BNC06M (I),I=101,200)/ & + -0.28057E+00,-0.28046E+00,-0.28035E+00,-0.28023E+00,-0.28010E+00, & + -0.27997E+00,-0.27983E+00,-0.27968E+00,-0.27953E+00,-0.27937E+00, & + -0.27920E+00,-0.27903E+00,-0.27886E+00,-0.27868E+00,-0.27849E+00, & + -0.27830E+00,-0.27810E+00,-0.27790E+00,-0.27770E+00,-0.27749E+00, & + -0.27738E+00,-0.27716E+00,-0.27693E+00,-0.27670E+00,-0.27647E+00, & + -0.27623E+00,-0.27600E+00,-0.27576E+00,-0.27552E+00,-0.27528E+00, & + -0.27503E+00,-0.27479E+00,-0.27454E+00,-0.27430E+00,-0.27405E+00, & + -0.27380E+00,-0.27355E+00,-0.27329E+00,-0.27304E+00,-0.27279E+00, & + -0.27253E+00,-0.27227E+00,-0.27201E+00,-0.27176E+00,-0.27149E+00, & + -0.27123E+00,-0.27097E+00,-0.27071E+00,-0.27044E+00,-0.27018E+00, & + -0.26991E+00,-0.26965E+00,-0.26938E+00,-0.26911E+00,-0.26885E+00, & + -0.26858E+00,-0.26831E+00,-0.26804E+00,-0.26777E+00,-0.26750E+00, & + -0.26723E+00,-0.26695E+00,-0.26668E+00,-0.26641E+00,-0.26614E+00, & + -0.26586E+00,-0.26559E+00,-0.26531E+00,-0.26504E+00,-0.26477E+00, & + -0.26449E+00,-0.26422E+00,-0.26394E+00,-0.26366E+00,-0.26339E+00, & + -0.26311E+00,-0.26284E+00,-0.26256E+00,-0.26228E+00,-0.26201E+00, & + -0.26173E+00,-0.26146E+00,-0.26118E+00,-0.26090E+00,-0.26063E+00, & + -0.26035E+00,-0.26007E+00,-0.25980E+00,-0.25952E+00,-0.25924E+00, & + -0.25897E+00,-0.25869E+00,-0.25841E+00,-0.25814E+00,-0.25786E+00, & + -0.25759E+00,-0.25731E+00,-0.25703E+00,-0.25676E+00,-0.25648E+00/ + + DATA (BNC06M (I),I=201,300)/ & + -0.25621E+00,-0.25593E+00,-0.25566E+00,-0.25538E+00,-0.25511E+00, & + -0.25483E+00,-0.25456E+00,-0.25429E+00,-0.25401E+00,-0.25374E+00, & + -0.25347E+00,-0.25319E+00,-0.25292E+00,-0.25265E+00,-0.25238E+00, & + -0.25211E+00,-0.25183E+00,-0.25156E+00,-0.25129E+00,-0.25102E+00, & + -0.25075E+00,-0.25048E+00,-0.25021E+00,-0.24994E+00,-0.24967E+00, & + -0.24941E+00,-0.24914E+00,-0.24887E+00,-0.24860E+00,-0.24834E+00, & + -0.24807E+00,-0.24780E+00,-0.24754E+00,-0.24727E+00,-0.24701E+00, & + -0.24674E+00,-0.24648E+00,-0.24622E+00,-0.24595E+00,-0.24569E+00, & + -0.24543E+00,-0.24517E+00,-0.24491E+00,-0.24464E+00,-0.24438E+00, & + -0.24412E+00,-0.24386E+00,-0.24360E+00,-0.24335E+00,-0.24309E+00, & + -0.24283E+00,-0.24257E+00,-0.24232E+00,-0.24206E+00,-0.24180E+00, & + -0.24155E+00,-0.24129E+00,-0.24104E+00,-0.24078E+00,-0.24053E+00, & + -0.24028E+00,-0.24002E+00,-0.23977E+00,-0.23952E+00,-0.23927E+00, & + -0.23902E+00,-0.23877E+00,-0.23852E+00,-0.23827E+00,-0.23802E+00, & + -0.23777E+00,-0.23753E+00,-0.23728E+00,-0.23703E+00,-0.23679E+00, & + -0.23654E+00,-0.23630E+00,-0.23605E+00,-0.23581E+00,-0.23556E+00, & + -0.23532E+00,-0.23508E+00,-0.23484E+00,-0.23460E+00,-0.23436E+00, & + -0.23412E+00,-0.23388E+00,-0.23364E+00,-0.23340E+00,-0.23316E+00, & + -0.23292E+00,-0.23269E+00,-0.23245E+00,-0.23221E+00,-0.23198E+00, & + -0.23174E+00,-0.23151E+00,-0.23128E+00,-0.23104E+00,-0.23081E+00/ + + DATA (BNC06M (I),I=301,400)/ & + -0.23058E+00,-0.23035E+00,-0.23012E+00,-0.22988E+00,-0.22965E+00, & + -0.22943E+00,-0.22920E+00,-0.22897E+00,-0.22874E+00,-0.22851E+00, & + -0.22829E+00,-0.22806E+00,-0.22784E+00,-0.22761E+00,-0.22739E+00, & + -0.22716E+00,-0.22694E+00,-0.22672E+00,-0.22649E+00,-0.22627E+00, & + -0.22605E+00,-0.22583E+00,-0.22561E+00,-0.22539E+00,-0.22517E+00, & + -0.22495E+00,-0.22474E+00,-0.22452E+00,-0.22430E+00,-0.22409E+00, & + -0.22387E+00,-0.22366E+00,-0.22344E+00,-0.22323E+00,-0.22301E+00, & + -0.22280E+00,-0.22259E+00,-0.22238E+00,-0.22217E+00,-0.22196E+00, & + -0.22175E+00,-0.22154E+00,-0.22133E+00,-0.22112E+00,-0.22091E+00, & + -0.22070E+00,-0.22050E+00,-0.22029E+00,-0.22008E+00,-0.21988E+00, & + -0.21968E+00,-0.21947E+00,-0.21927E+00,-0.21906E+00,-0.21886E+00, & + -0.21866E+00,-0.21846E+00,-0.21826E+00,-0.21806E+00,-0.21786E+00, & + -0.21766E+00,-0.21746E+00,-0.21726E+00,-0.21707E+00,-0.21687E+00, & + -0.21667E+00,-0.21648E+00,-0.21628E+00,-0.21609E+00,-0.21589E+00, & + -0.21570E+00,-0.21551E+00,-0.21531E+00,-0.21512E+00,-0.21493E+00, & + -0.21474E+00,-0.21455E+00,-0.21436E+00,-0.21417E+00,-0.21398E+00, & + -0.21379E+00,-0.21360E+00,-0.21342E+00,-0.21323E+00,-0.21304E+00, & + -0.21286E+00,-0.21267E+00,-0.21249E+00,-0.21230E+00,-0.21212E+00, & + -0.21194E+00,-0.21176E+00,-0.21157E+00,-0.21139E+00,-0.21121E+00, & + -0.21103E+00,-0.21085E+00,-0.21067E+00,-0.21049E+00,-0.21032E+00/ + + DATA (BNC06M (I),I=401,500)/ & + -0.21014E+00,-0.20996E+00,-0.20978E+00,-0.20961E+00,-0.20943E+00, & + -0.20926E+00,-0.20908E+00,-0.20891E+00,-0.20873E+00,-0.20856E+00, & + -0.20839E+00,-0.20822E+00,-0.20804E+00,-0.20787E+00,-0.20770E+00, & + -0.20753E+00,-0.20736E+00,-0.20720E+00,-0.20703E+00,-0.20686E+00, & + -0.20669E+00,-0.20652E+00,-0.20636E+00,-0.20619E+00,-0.20603E+00, & + -0.20586E+00,-0.20570E+00,-0.20553E+00,-0.20537E+00,-0.20521E+00, & + -0.20504E+00,-0.20488E+00,-0.20472E+00,-0.20456E+00,-0.20440E+00, & + -0.20424E+00,-0.20408E+00,-0.20392E+00,-0.20376E+00,-0.20361E+00, & + -0.20345E+00,-0.20329E+00,-0.20313E+00,-0.20298E+00,-0.20282E+00, & + -0.20267E+00,-0.20251E+00,-0.20236E+00,-0.20221E+00,-0.20205E+00, & + -0.20190E+00,-0.20175E+00,-0.20160E+00,-0.20145E+00,-0.20130E+00, & + -0.20114E+00,-0.20100E+00,-0.20085E+00,-0.20070E+00,-0.20055E+00, & + -0.20040E+00,-0.20025E+00,-0.20011E+00,-0.19996E+00,-0.19982E+00, & + -0.19967E+00,-0.19952E+00,-0.19938E+00,-0.19924E+00,-0.19909E+00, & + -0.19895E+00,-0.19881E+00,-0.19867E+00,-0.19852E+00,-0.19838E+00, & + -0.19824E+00,-0.19810E+00,-0.19796E+00,-0.19782E+00,-0.19768E+00, & + -0.19755E+00,-0.19741E+00,-0.19727E+00,-0.19713E+00,-0.19700E+00, & + -0.19686E+00,-0.19672E+00,-0.19659E+00,-0.19646E+00,-0.19632E+00, & + -0.19619E+00,-0.19605E+00,-0.19592E+00,-0.19579E+00,-0.19566E+00, & + -0.19552E+00,-0.19539E+00,-0.19526E+00,-0.19513E+00,-0.19500E+00/ + + DATA (BNC06M (I),I=501,600)/ & + -0.19487E+00,-0.19474E+00,-0.19462E+00,-0.19449E+00,-0.19436E+00, & + -0.19423E+00,-0.19411E+00,-0.19398E+00,-0.19386E+00,-0.19373E+00, & + -0.19361E+00,-0.19348E+00,-0.19336E+00,-0.19323E+00,-0.19311E+00, & + -0.19299E+00,-0.19286E+00,-0.19274E+00,-0.19262E+00,-0.19250E+00, & + -0.19238E+00,-0.19226E+00,-0.19214E+00,-0.19202E+00,-0.19190E+00, & + -0.19178E+00,-0.19167E+00,-0.19155E+00,-0.19143E+00,-0.19131E+00, & + -0.19120E+00,-0.19108E+00,-0.19097E+00,-0.19085E+00,-0.19074E+00, & + -0.19062E+00,-0.19051E+00,-0.19040E+00,-0.19028E+00,-0.19017E+00, & + -0.19006E+00,-0.18995E+00,-0.18984E+00,-0.18972E+00,-0.18961E+00, & + -0.18950E+00,-0.18939E+00,-0.18929E+00,-0.18918E+00,-0.18907E+00, & + -0.18896E+00,-0.18885E+00,-0.18875E+00,-0.18864E+00,-0.18853E+00, & + -0.18843E+00,-0.18832E+00,-0.18822E+00,-0.18811E+00,-0.18801E+00, & + -0.18790E+00,-0.18780E+00,-0.18770E+00,-0.18759E+00,-0.18749E+00, & + -0.18739E+00,-0.18729E+00,-0.18719E+00,-0.18709E+00,-0.18699E+00, & + -0.18689E+00,-0.18679E+00,-0.18669E+00,-0.18659E+00,-0.18649E+00, & + -0.18639E+00,-0.18629E+00,-0.18620E+00,-0.18610E+00,-0.18600E+00, & + -0.18591E+00,-0.18581E+00,-0.18572E+00,-0.18562E+00,-0.18553E+00, & + -0.18543E+00,-0.18534E+00,-0.18525E+00,-0.18515E+00,-0.18506E+00, & + -0.18497E+00,-0.18488E+00,-0.18478E+00,-0.18469E+00,-0.18460E+00, & + -0.18451E+00,-0.18442E+00,-0.18433E+00,-0.18424E+00,-0.18391E+00/ + + DATA (BNC06M (I),I=601,700)/ & + -0.18320E+00,-0.18237E+00,-0.18158E+00,-0.18083E+00,-0.18010E+00, & + -0.17942E+00,-0.17876E+00,-0.17814E+00,-0.17755E+00,-0.17700E+00, & + -0.17647E+00,-0.17597E+00,-0.17551E+00,-0.17507E+00,-0.17467E+00, & + -0.17429E+00,-0.17394E+00,-0.17362E+00,-0.17333E+00,-0.17306E+00, & + -0.17282E+00,-0.17260E+00,-0.17241E+00,-0.17225E+00,-0.17211E+00, & + -0.17200E+00,-0.17190E+00,-0.17184E+00,-0.17179E+00,-0.17177E+00, & + -0.17177E+00,-0.17180E+00,-0.17184E+00,-0.17191E+00,-0.17200E+00, & + -0.17210E+00,-0.17223E+00,-0.17238E+00,-0.17255E+00,-0.17274E+00, & + -0.17295E+00,-0.17318E+00,-0.17342E+00,-0.17369E+00,-0.17397E+00, & + -0.17427E+00,-0.17459E+00,-0.17493E+00,-0.17528E+00,-0.17565E+00, & + -0.17604E+00,-0.17644E+00,-0.17687E+00,-0.17730E+00,-0.17775E+00, & + -0.17822E+00,-0.17871E+00,-0.17921E+00,-0.17972E+00,-0.18025E+00, & + -0.18079E+00,-0.18135E+00,-0.18193E+00,-0.18251E+00,-0.18311E+00, & + -0.18373E+00,-0.18436E+00,-0.18500E+00,-0.18565E+00,-0.18632E+00, & + -0.18700E+00,-0.18770E+00,-0.18840E+00,-0.18912E+00,-0.18985E+00, & + -0.19060E+00,-0.19135E+00,-0.19212E+00,-0.19290E+00,-0.19369E+00, & + -0.19450E+00,-0.19531E+00,-0.19614E+00,-0.19697E+00,-0.19782E+00, & + -0.19868E+00,-0.19955E+00,-0.20043E+00,-0.20132E+00,-0.20222E+00, & + -0.20313E+00,-0.20405E+00,-0.20498E+00,-0.20592E+00,-0.20687E+00, & + -0.20783E+00,-0.20880E+00,-0.20978E+00,-0.21077E+00,-0.21177E+00/ + + DATA (BNC06M(I),I=701,741)/ & + -0.21278E+00,-0.21379E+00,-0.21482E+00,-0.21585E+00,-0.21690E+00, & + -0.21795E+00,-0.21901E+00,-0.22008E+00,-0.22116E+00,-0.22224E+00, & + -0.22334E+00,-0.22444E+00,-0.22555E+00,-0.22667E+00,-0.22780E+00, & + -0.22893E+00,-0.23007E+00,-0.23122E+00,-0.23238E+00,-0.23355E+00, & + -0.23472E+00,-0.23590E+00,-0.23709E+00,-0.23828E+00,-0.23949E+00, & + -0.24070E+00,-0.24191E+00,-0.24314E+00,-0.24437E+00,-0.24561E+00, & + -0.24685E+00,-0.24810E+00,-0.24936E+00,-0.25062E+00,-0.25189E+00, & + -0.25317E+00,-0.25446E+00,-0.25575E+00,-0.25704E+00,-0.25835E+00, & + -0.25966E+00 & + / +! +! *** (2H, SO4) +! + DATA (BNC07M (I),I= 1,100)/ & + -0.10830E+00,-0.19774E+00,-0.26106E+00,-0.30438E+00,-0.33792E+00, & + -0.36551E+00,-0.38903E+00,-0.40959E+00,-0.42789E+00,-0.44440E+00, & + -0.45945E+00,-0.47329E+00,-0.48612E+00,-0.49807E+00,-0.50926E+00, & + -0.51980E+00,-0.52976E+00,-0.53920E+00,-0.54817E+00,-0.55673E+00, & + -0.56491E+00,-0.57275E+00,-0.58028E+00,-0.58752E+00,-0.59449E+00, & + -0.60122E+00,-0.60772E+00,-0.61401E+00,-0.62011E+00,-0.62602E+00, & + -0.63176E+00,-0.63734E+00,-0.64277E+00,-0.64805E+00,-0.65321E+00, & + -0.65823E+00,-0.66313E+00,-0.66792E+00,-0.67261E+00,-0.67718E+00, & + -0.68166E+00,-0.68605E+00,-0.69035E+00,-0.69456E+00,-0.69869E+00, & + -0.70275E+00,-0.70673E+00,-0.71063E+00,-0.71447E+00,-0.71824E+00, & + -0.72195E+00,-0.72560E+00,-0.72919E+00,-0.73272E+00,-0.73620E+00, & + -0.73963E+00,-0.74301E+00,-0.74633E+00,-0.74961E+00,-0.75285E+00, & + -0.75604E+00,-0.75919E+00,-0.76230E+00,-0.76537E+00,-0.76840E+00, & + -0.77139E+00,-0.77435E+00,-0.77727E+00,-0.78016E+00,-0.78302E+00, & + -0.78584E+00,-0.78863E+00,-0.79140E+00,-0.79414E+00,-0.79684E+00, & + -0.79952E+00,-0.80218E+00,-0.80481E+00,-0.80741E+00,-0.80999E+00, & + -0.81255E+00,-0.81509E+00,-0.81760E+00,-0.82009E+00,-0.82256E+00, & + -0.82501E+00,-0.82744E+00,-0.82985E+00,-0.83224E+00,-0.83461E+00, & + -0.83697E+00,-0.83930E+00,-0.84162E+00,-0.84393E+00,-0.84621E+00, & + -0.84848E+00,-0.85074E+00,-0.85298E+00,-0.85520E+00,-0.85741E+00/ + + DATA (BNC07M (I),I=101,200)/ & + -0.85961E+00,-0.86179E+00,-0.86396E+00,-0.86611E+00,-0.86825E+00, & + -0.87038E+00,-0.87249E+00,-0.87459E+00,-0.87668E+00,-0.87876E+00, & + -0.88082E+00,-0.88287E+00,-0.88491E+00,-0.88694E+00,-0.88896E+00, & + -0.89097E+00,-0.89296E+00,-0.89495E+00,-0.89692E+00,-0.89888E+00, & + -0.90081E+00,-0.90275E+00,-0.90469E+00,-0.90661E+00,-0.90853E+00, & + -0.91043E+00,-0.91233E+00,-0.91421E+00,-0.91609E+00,-0.91795E+00, & + -0.91981E+00,-0.92166E+00,-0.92349E+00,-0.92532E+00,-0.92715E+00, & + -0.92896E+00,-0.93076E+00,-0.93256E+00,-0.93435E+00,-0.93613E+00, & + -0.93790E+00,-0.93966E+00,-0.94142E+00,-0.94317E+00,-0.94491E+00, & + -0.94664E+00,-0.94837E+00,-0.95009E+00,-0.95180E+00,-0.95351E+00, & + -0.95521E+00,-0.95690E+00,-0.95858E+00,-0.96026E+00,-0.96193E+00, & + -0.96360E+00,-0.96525E+00,-0.96691E+00,-0.96855E+00,-0.97019E+00, & + -0.97183E+00,-0.97345E+00,-0.97508E+00,-0.97669E+00,-0.97830E+00, & + -0.97991E+00,-0.98150E+00,-0.98310E+00,-0.98469E+00,-0.98627E+00, & + -0.98784E+00,-0.98942E+00,-0.99098E+00,-0.99254E+00,-0.99410E+00, & + -0.99565E+00,-0.99719E+00,-0.99873E+00,-0.10003E+01,-0.10018E+01, & + -0.10033E+01,-0.10048E+01,-0.10064E+01,-0.10079E+01,-0.10094E+01, & + -0.10109E+01,-0.10124E+01,-0.10139E+01,-0.10154E+01,-0.10168E+01, & + -0.10183E+01,-0.10198E+01,-0.10213E+01,-0.10227E+01,-0.10242E+01, & + -0.10257E+01,-0.10271E+01,-0.10286E+01,-0.10300E+01,-0.10315E+01/ + + DATA (BNC07M (I),I=201,300)/ & + -0.10329E+01,-0.10343E+01,-0.10358E+01,-0.10372E+01,-0.10386E+01, & + -0.10400E+01,-0.10415E+01,-0.10429E+01,-0.10443E+01,-0.10457E+01, & + -0.10471E+01,-0.10485E+01,-0.10499E+01,-0.10513E+01,-0.10527E+01, & + -0.10540E+01,-0.10554E+01,-0.10568E+01,-0.10582E+01,-0.10595E+01, & + -0.10609E+01,-0.10623E+01,-0.10636E+01,-0.10650E+01,-0.10663E+01, & + -0.10677E+01,-0.10690E+01,-0.10704E+01,-0.10717E+01,-0.10731E+01, & + -0.10744E+01,-0.10757E+01,-0.10771E+01,-0.10784E+01,-0.10797E+01, & + -0.10810E+01,-0.10824E+01,-0.10837E+01,-0.10850E+01,-0.10863E+01, & + -0.10876E+01,-0.10889E+01,-0.10902E+01,-0.10915E+01,-0.10928E+01, & + -0.10941E+01,-0.10954E+01,-0.10967E+01,-0.10980E+01,-0.10993E+01, & + -0.11005E+01,-0.11018E+01,-0.11031E+01,-0.11044E+01,-0.11056E+01, & + -0.11069E+01,-0.11082E+01,-0.11094E+01,-0.11107E+01,-0.11120E+01, & + -0.11132E+01,-0.11145E+01,-0.11157E+01,-0.11170E+01,-0.11182E+01, & + -0.11195E+01,-0.11207E+01,-0.11220E+01,-0.11232E+01,-0.11244E+01, & + -0.11257E+01,-0.11269E+01,-0.11281E+01,-0.11294E+01,-0.11306E+01, & + -0.11318E+01,-0.11330E+01,-0.11342E+01,-0.11355E+01,-0.11367E+01, & + -0.11379E+01,-0.11391E+01,-0.11403E+01,-0.11415E+01,-0.11427E+01, & + -0.11439E+01,-0.11451E+01,-0.11463E+01,-0.11475E+01,-0.11487E+01, & + -0.11499E+01,-0.11511E+01,-0.11523E+01,-0.11535E+01,-0.11547E+01, & + -0.11559E+01,-0.11570E+01,-0.11582E+01,-0.11594E+01,-0.11606E+01/ + + DATA (BNC07M (I),I=301,400)/ & + -0.11617E+01,-0.11629E+01,-0.11641E+01,-0.11653E+01,-0.11664E+01, & + -0.11676E+01,-0.11688E+01,-0.11699E+01,-0.11711E+01,-0.11722E+01, & + -0.11734E+01,-0.11746E+01,-0.11757E+01,-0.11769E+01,-0.11780E+01, & + -0.11792E+01,-0.11803E+01,-0.11815E+01,-0.11826E+01,-0.11837E+01, & + -0.11849E+01,-0.11860E+01,-0.11872E+01,-0.11883E+01,-0.11894E+01, & + -0.11906E+01,-0.11917E+01,-0.11928E+01,-0.11940E+01,-0.11951E+01, & + -0.11962E+01,-0.11973E+01,-0.11985E+01,-0.11996E+01,-0.12007E+01, & + -0.12018E+01,-0.12029E+01,-0.12041E+01,-0.12052E+01,-0.12063E+01, & + -0.12074E+01,-0.12085E+01,-0.12096E+01,-0.12107E+01,-0.12118E+01, & + -0.12129E+01,-0.12140E+01,-0.12151E+01,-0.12162E+01,-0.12173E+01, & + -0.12184E+01,-0.12195E+01,-0.12206E+01,-0.12217E+01,-0.12228E+01, & + -0.12239E+01,-0.12250E+01,-0.12261E+01,-0.12272E+01,-0.12283E+01, & + -0.12293E+01,-0.12304E+01,-0.12315E+01,-0.12326E+01,-0.12337E+01, & + -0.12348E+01,-0.12358E+01,-0.12369E+01,-0.12380E+01,-0.12391E+01, & + -0.12401E+01,-0.12412E+01,-0.12423E+01,-0.12433E+01,-0.12444E+01, & + -0.12455E+01,-0.12465E+01,-0.12476E+01,-0.12487E+01,-0.12497E+01, & + -0.12508E+01,-0.12519E+01,-0.12529E+01,-0.12540E+01,-0.12550E+01, & + -0.12561E+01,-0.12571E+01,-0.12582E+01,-0.12592E+01,-0.12603E+01, & + -0.12613E+01,-0.12624E+01,-0.12634E+01,-0.12645E+01,-0.12655E+01, & + -0.12666E+01,-0.12676E+01,-0.12687E+01,-0.12697E+01,-0.12708E+01/ + + DATA (BNC07M (I),I=401,500)/ & + -0.12718E+01,-0.12728E+01,-0.12739E+01,-0.12749E+01,-0.12759E+01, & + -0.12770E+01,-0.12780E+01,-0.12790E+01,-0.12801E+01,-0.12811E+01, & + -0.12821E+01,-0.12832E+01,-0.12842E+01,-0.12852E+01,-0.12862E+01, & + -0.12873E+01,-0.12883E+01,-0.12893E+01,-0.12903E+01,-0.12914E+01, & + -0.12924E+01,-0.12934E+01,-0.12944E+01,-0.12954E+01,-0.12964E+01, & + -0.12975E+01,-0.12985E+01,-0.12995E+01,-0.13005E+01,-0.13015E+01, & + -0.13025E+01,-0.13035E+01,-0.13045E+01,-0.13055E+01,-0.13066E+01, & + -0.13076E+01,-0.13086E+01,-0.13096E+01,-0.13106E+01,-0.13116E+01, & + -0.13126E+01,-0.13136E+01,-0.13146E+01,-0.13156E+01,-0.13166E+01, & + -0.13176E+01,-0.13186E+01,-0.13196E+01,-0.13206E+01,-0.13216E+01, & + -0.13226E+01,-0.13235E+01,-0.13245E+01,-0.13255E+01,-0.13265E+01, & + -0.13275E+01,-0.13285E+01,-0.13295E+01,-0.13305E+01,-0.13315E+01, & + -0.13324E+01,-0.13334E+01,-0.13344E+01,-0.13354E+01,-0.13364E+01, & + -0.13374E+01,-0.13383E+01,-0.13393E+01,-0.13403E+01,-0.13413E+01, & + -0.13423E+01,-0.13432E+01,-0.13442E+01,-0.13452E+01,-0.13462E+01, & + -0.13471E+01,-0.13481E+01,-0.13491E+01,-0.13500E+01,-0.13510E+01, & + -0.13520E+01,-0.13530E+01,-0.13539E+01,-0.13549E+01,-0.13559E+01, & + -0.13568E+01,-0.13578E+01,-0.13588E+01,-0.13597E+01,-0.13607E+01, & + -0.13617E+01,-0.13626E+01,-0.13636E+01,-0.13645E+01,-0.13655E+01, & + -0.13665E+01,-0.13674E+01,-0.13684E+01,-0.13693E+01,-0.13703E+01/ + + DATA (BNC07M (I),I=501,600)/ & + -0.13712E+01,-0.13722E+01,-0.13732E+01,-0.13741E+01,-0.13751E+01, & + -0.13760E+01,-0.13770E+01,-0.13779E+01,-0.13789E+01,-0.13798E+01, & + -0.13808E+01,-0.13817E+01,-0.13827E+01,-0.13836E+01,-0.13846E+01, & + -0.13855E+01,-0.13865E+01,-0.13874E+01,-0.13883E+01,-0.13893E+01, & + -0.13902E+01,-0.13912E+01,-0.13921E+01,-0.13931E+01,-0.13940E+01, & + -0.13949E+01,-0.13959E+01,-0.13968E+01,-0.13978E+01,-0.13987E+01, & + -0.13996E+01,-0.14006E+01,-0.14015E+01,-0.14024E+01,-0.14034E+01, & + -0.14043E+01,-0.14052E+01,-0.14062E+01,-0.14071E+01,-0.14080E+01, & + -0.14090E+01,-0.14099E+01,-0.14108E+01,-0.14118E+01,-0.14127E+01, & + -0.14136E+01,-0.14145E+01,-0.14155E+01,-0.14164E+01,-0.14173E+01, & + -0.14182E+01,-0.14192E+01,-0.14201E+01,-0.14210E+01,-0.14219E+01, & + -0.14229E+01,-0.14238E+01,-0.14247E+01,-0.14256E+01,-0.14265E+01, & + -0.14275E+01,-0.14284E+01,-0.14293E+01,-0.14302E+01,-0.14311E+01, & + -0.14321E+01,-0.14330E+01,-0.14339E+01,-0.14348E+01,-0.14357E+01, & + -0.14366E+01,-0.14375E+01,-0.14385E+01,-0.14394E+01,-0.14403E+01, & + -0.14412E+01,-0.14421E+01,-0.14430E+01,-0.14439E+01,-0.14448E+01, & + -0.14457E+01,-0.14467E+01,-0.14476E+01,-0.14485E+01,-0.14494E+01, & + -0.14503E+01,-0.14512E+01,-0.14521E+01,-0.14530E+01,-0.14539E+01, & + -0.14548E+01,-0.14557E+01,-0.14566E+01,-0.14575E+01,-0.14584E+01, & + -0.14593E+01,-0.14602E+01,-0.14611E+01,-0.14620E+01,-0.14654E+01/ + + DATA (BNC07M (I),I=601,700)/ & + -0.14728E+01,-0.14817E+01,-0.14906E+01,-0.14994E+01,-0.15082E+01, & + -0.15170E+01,-0.15257E+01,-0.15343E+01,-0.15430E+01,-0.15515E+01, & + -0.15601E+01,-0.15686E+01,-0.15771E+01,-0.15856E+01,-0.15940E+01, & + -0.16024E+01,-0.16107E+01,-0.16191E+01,-0.16274E+01,-0.16356E+01, & + -0.16439E+01,-0.16521E+01,-0.16603E+01,-0.16684E+01,-0.16766E+01, & + -0.16847E+01,-0.16928E+01,-0.17008E+01,-0.17089E+01,-0.17169E+01, & + -0.17249E+01,-0.17328E+01,-0.17408E+01,-0.17487E+01,-0.17566E+01, & + -0.17645E+01,-0.17723E+01,-0.17802E+01,-0.17880E+01,-0.17958E+01, & + -0.18036E+01,-0.18114E+01,-0.18191E+01,-0.18268E+01,-0.18346E+01, & + -0.18423E+01,-0.18499E+01,-0.18576E+01,-0.18652E+01,-0.18729E+01, & + -0.18805E+01,-0.18881E+01,-0.18957E+01,-0.19032E+01,-0.19108E+01, & + -0.19183E+01,-0.19258E+01,-0.19334E+01,-0.19409E+01,-0.19483E+01, & + -0.19558E+01,-0.19633E+01,-0.19707E+01,-0.19781E+01,-0.19855E+01, & + -0.19929E+01,-0.20003E+01,-0.20077E+01,-0.20151E+01,-0.20224E+01, & + -0.20298E+01,-0.20371E+01,-0.20444E+01,-0.20517E+01,-0.20590E+01, & + -0.20663E+01,-0.20736E+01,-0.20808E+01,-0.20881E+01,-0.20953E+01, & + -0.21026E+01,-0.21098E+01,-0.21170E+01,-0.21242E+01,-0.21314E+01, & + -0.21386E+01,-0.21457E+01,-0.21529E+01,-0.21601E+01,-0.21672E+01, & + -0.21743E+01,-0.21815E+01,-0.21886E+01,-0.21957E+01,-0.22028E+01, & + -0.22099E+01,-0.22169E+01,-0.22240E+01,-0.22311E+01,-0.22381E+01/ + + DATA (BNC07M(I),I=701,741)/ & + -0.22452E+01,-0.22522E+01,-0.22593E+01,-0.22663E+01,-0.22733E+01, & + -0.22803E+01,-0.22873E+01,-0.22943E+01,-0.23013E+01,-0.23082E+01, & + -0.23152E+01,-0.23222E+01,-0.23291E+01,-0.23361E+01,-0.23430E+01, & + -0.23499E+01,-0.23569E+01,-0.23638E+01,-0.23707E+01,-0.23776E+01, & + -0.23845E+01,-0.23914E+01,-0.23983E+01,-0.24052E+01,-0.24120E+01, & + -0.24189E+01,-0.24258E+01,-0.24326E+01,-0.24395E+01,-0.24463E+01, & + -0.24531E+01,-0.24600E+01,-0.24668E+01,-0.24736E+01,-0.24804E+01, & + -0.24872E+01,-0.24940E+01,-0.25008E+01,-0.25076E+01,-0.25144E+01, & + -0.25211E+01 & + / +! +! *** (H, HSO4) +! + DATA (BNC08M (I),I= 1,100)/ & + -0.50088E-01,-0.84806E-01,-0.10501E+00,-0.11624E+00,-0.12318E+00, & + -0.12753E+00,-0.13011E+00,-0.13139E+00,-0.13166E+00,-0.13112E+00, & + -0.12989E+00,-0.12809E+00,-0.12579E+00,-0.12304E+00,-0.11990E+00, & + -0.11640E+00,-0.11257E+00,-0.10844E+00,-0.10403E+00,-0.99358E-01, & + -0.94441E-01,-0.89293E-01,-0.83928E-01,-0.78356E-01,-0.72588E-01, & + -0.66634E-01,-0.60502E-01,-0.54201E-01,-0.47738E-01,-0.41119E-01, & + -0.34352E-01,-0.27443E-01,-0.20397E-01,-0.13221E-01,-0.59198E-02, & + 0.15015E-02, 0.90380E-02, 0.16685E-01, 0.24437E-01, 0.32290E-01, & + 0.40241E-01, 0.48284E-01, 0.56416E-01, 0.64634E-01, 0.72933E-01, & + 0.81310E-01, 0.89763E-01, 0.98287E-01, 0.10688E+00, 0.11554E+00, & + 0.12426E+00, 0.13304E+00, 0.14189E+00, 0.15078E+00, 0.15974E+00, & + 0.16874E+00, 0.17780E+00, 0.18691E+00, 0.19606E+00, 0.20527E+00, & + 0.21452E+00, 0.22381E+00, 0.23315E+00, 0.24254E+00, 0.25197E+00, & + 0.26144E+00, 0.27096E+00, 0.28052E+00, 0.29013E+00, 0.29978E+00, & + 0.30948E+00, 0.31922E+00, 0.32902E+00, 0.33885E+00, 0.34874E+00, & + 0.35868E+00, 0.36866E+00, 0.37870E+00, 0.38878E+00, 0.39892E+00, & + 0.40911E+00, 0.41936E+00, 0.42965E+00, 0.44000E+00, 0.45041E+00, & + 0.46087E+00, 0.47138E+00, 0.48195E+00, 0.49257E+00, 0.50325E+00, & + 0.51398E+00, 0.52476E+00, 0.53560E+00, 0.54648E+00, 0.55742E+00, & + 0.56840E+00, 0.57944E+00, 0.59052E+00, 0.60164E+00, 0.61281E+00/ + + DATA (BNC08M (I),I=101,200)/ & + 0.62402E+00, 0.63527E+00, 0.64656E+00, 0.65788E+00, 0.66924E+00, & + 0.68062E+00, 0.69204E+00, 0.70349E+00, 0.71496E+00, 0.72646E+00, & + 0.73797E+00, 0.74951E+00, 0.76106E+00, 0.77263E+00, 0.78421E+00, & + 0.79581E+00, 0.80741E+00, 0.81902E+00, 0.83063E+00, 0.84225E+00, & + 0.85289E+00, 0.86463E+00, 0.87635E+00, 0.88806E+00, 0.89976E+00, & + 0.91145E+00, 0.92312E+00, 0.93477E+00, 0.94641E+00, 0.95804E+00, & + 0.96965E+00, 0.98124E+00, 0.99282E+00, 0.10044E+01, 0.10159E+01, & + 0.10274E+01, 0.10390E+01, 0.10504E+01, 0.10619E+01, 0.10734E+01, & + 0.10848E+01, 0.10962E+01, 0.11076E+01, 0.11190E+01, 0.11303E+01, & + 0.11417E+01, 0.11530E+01, 0.11643E+01, 0.11756E+01, 0.11868E+01, & + 0.11980E+01, 0.12093E+01, 0.12204E+01, 0.12316E+01, 0.12428E+01, & + 0.12539E+01, 0.12650E+01, 0.12761E+01, 0.12871E+01, 0.12982E+01, & + 0.13092E+01, 0.13202E+01, 0.13311E+01, 0.13421E+01, 0.13530E+01, & + 0.13639E+01, 0.13748E+01, 0.13857E+01, 0.13965E+01, 0.14073E+01, & + 0.14181E+01, 0.14289E+01, 0.14396E+01, 0.14504E+01, 0.14611E+01, & + 0.14717E+01, 0.14824E+01, 0.14930E+01, 0.15036E+01, 0.15142E+01, & + 0.15248E+01, 0.15353E+01, 0.15458E+01, 0.15563E+01, 0.15668E+01, & + 0.15773E+01, 0.15877E+01, 0.15981E+01, 0.16085E+01, 0.16188E+01, & + 0.16292E+01, 0.16395E+01, 0.16498E+01, 0.16600E+01, 0.16703E+01, & + 0.16805E+01, 0.16907E+01, 0.17009E+01, 0.17110E+01, 0.17212E+01/ + + DATA (BNC08M (I),I=201,300)/ & + 0.17313E+01, 0.17414E+01, 0.17514E+01, 0.17615E+01, 0.17715E+01, & + 0.17815E+01, 0.17915E+01, 0.18014E+01, 0.18114E+01, 0.18213E+01, & + 0.18312E+01, 0.18410E+01, 0.18509E+01, 0.18607E+01, 0.18705E+01, & + 0.18803E+01, 0.18901E+01, 0.18998E+01, 0.19095E+01, 0.19192E+01, & + 0.19289E+01, 0.19385E+01, 0.19482E+01, 0.19578E+01, 0.19674E+01, & + 0.19769E+01, 0.19865E+01, 0.19960E+01, 0.20055E+01, 0.20150E+01, & + 0.20244E+01, 0.20339E+01, 0.20433E+01, 0.20527E+01, 0.20621E+01, & + 0.20715E+01, 0.20808E+01, 0.20901E+01, 0.20994E+01, 0.21087E+01, & + 0.21179E+01, 0.21272E+01, 0.21364E+01, 0.21456E+01, 0.21548E+01, & + 0.21639E+01, 0.21731E+01, 0.21822E+01, 0.21913E+01, 0.22004E+01, & + 0.22094E+01, 0.22185E+01, 0.22275E+01, 0.22365E+01, 0.22455E+01, & + 0.22545E+01, 0.22634E+01, 0.22723E+01, 0.22812E+01, 0.22901E+01, & + 0.22990E+01, 0.23078E+01, 0.23167E+01, 0.23255E+01, 0.23343E+01, & + 0.23431E+01, 0.23518E+01, 0.23606E+01, 0.23693E+01, 0.23780E+01, & + 0.23867E+01, 0.23953E+01, 0.24040E+01, 0.24126E+01, 0.24212E+01, & + 0.24298E+01, 0.24384E+01, 0.24470E+01, 0.24555E+01, 0.24640E+01, & + 0.24725E+01, 0.24810E+01, 0.24895E+01, 0.24980E+01, 0.25064E+01, & + 0.25148E+01, 0.25232E+01, 0.25316E+01, 0.25400E+01, 0.25483E+01, & + 0.25567E+01, 0.25650E+01, 0.25733E+01, 0.25816E+01, 0.25898E+01, & + 0.25981E+01, 0.26063E+01, 0.26145E+01, 0.26227E+01, 0.26309E+01/ + + DATA (BNC08M (I),I=301,400)/ & + 0.26391E+01, 0.26472E+01, 0.26554E+01, 0.26635E+01, 0.26716E+01, & + 0.26797E+01, 0.26877E+01, 0.26958E+01, 0.27038E+01, 0.27119E+01, & + 0.27199E+01, 0.27279E+01, 0.27358E+01, 0.27438E+01, 0.27517E+01, & + 0.27597E+01, 0.27676E+01, 0.27755E+01, 0.27834E+01, 0.27912E+01, & + 0.27991E+01, 0.28069E+01, 0.28148E+01, 0.28226E+01, 0.28304E+01, & + 0.28381E+01, 0.28459E+01, 0.28536E+01, 0.28614E+01, 0.28691E+01, & + 0.28768E+01, 0.28845E+01, 0.28922E+01, 0.28998E+01, 0.29075E+01, & + 0.29151E+01, 0.29227E+01, 0.29303E+01, 0.29379E+01, 0.29455E+01, & + 0.29530E+01, 0.29606E+01, 0.29681E+01, 0.29756E+01, 0.29831E+01, & + 0.29906E+01, 0.29981E+01, 0.30055E+01, 0.30130E+01, 0.30204E+01, & + 0.30278E+01, 0.30353E+01, 0.30426E+01, 0.30500E+01, 0.30574E+01, & + 0.30647E+01, 0.30721E+01, 0.30794E+01, 0.30867E+01, 0.30940E+01, & + 0.31013E+01, 0.31086E+01, 0.31158E+01, 0.31231E+01, 0.31303E+01, & + 0.31375E+01, 0.31447E+01, 0.31519E+01, 0.31591E+01, 0.31663E+01, & + 0.31734E+01, 0.31806E+01, 0.31877E+01, 0.31948E+01, 0.32019E+01, & + 0.32090E+01, 0.32161E+01, 0.32231E+01, 0.32302E+01, 0.32372E+01, & + 0.32443E+01, 0.32513E+01, 0.32583E+01, 0.32653E+01, 0.32722E+01, & + 0.32792E+01, 0.32862E+01, 0.32931E+01, 0.33000E+01, 0.33069E+01, & + 0.33139E+01, 0.33207E+01, 0.33276E+01, 0.33345E+01, 0.33414E+01, & + 0.33482E+01, 0.33550E+01, 0.33619E+01, 0.33687E+01, 0.33755E+01/ + + DATA (BNC08M (I),I=401,500)/ & + 0.33823E+01, 0.33890E+01, 0.33958E+01, 0.34026E+01, 0.34093E+01, & + 0.34160E+01, 0.34227E+01, 0.34294E+01, 0.34361E+01, 0.34428E+01, & + 0.34495E+01, 0.34562E+01, 0.34628E+01, 0.34695E+01, 0.34761E+01, & + 0.34827E+01, 0.34893E+01, 0.34959E+01, 0.35025E+01, 0.35091E+01, & + 0.35156E+01, 0.35222E+01, 0.35287E+01, 0.35352E+01, 0.35418E+01, & + 0.35483E+01, 0.35548E+01, 0.35612E+01, 0.35677E+01, 0.35742E+01, & + 0.35806E+01, 0.35871E+01, 0.35935E+01, 0.35999E+01, 0.36064E+01, & + 0.36128E+01, 0.36192E+01, 0.36255E+01, 0.36319E+01, 0.36383E+01, & + 0.36446E+01, 0.36510E+01, 0.36573E+01, 0.36636E+01, 0.36699E+01, & + 0.36762E+01, 0.36825E+01, 0.36888E+01, 0.36951E+01, 0.37013E+01, & + 0.37076E+01, 0.37138E+01, 0.37200E+01, 0.37262E+01, 0.37325E+01, & + 0.37387E+01, 0.37448E+01, 0.37510E+01, 0.37572E+01, 0.37634E+01, & + 0.37695E+01, 0.37757E+01, 0.37818E+01, 0.37879E+01, 0.37940E+01, & + 0.38001E+01, 0.38062E+01, 0.38123E+01, 0.38184E+01, 0.38244E+01, & + 0.38305E+01, 0.38365E+01, 0.38426E+01, 0.38486E+01, 0.38546E+01, & + 0.38606E+01, 0.38666E+01, 0.38726E+01, 0.38786E+01, 0.38846E+01, & + 0.38906E+01, 0.38965E+01, 0.39025E+01, 0.39084E+01, 0.39143E+01, & + 0.39202E+01, 0.39261E+01, 0.39320E+01, 0.39379E+01, 0.39438E+01, & + 0.39497E+01, 0.39556E+01, 0.39614E+01, 0.39673E+01, 0.39731E+01, & + 0.39789E+01, 0.39847E+01, 0.39906E+01, 0.39964E+01, 0.40022E+01/ + + DATA (BNC08M (I),I=501,600)/ & + 0.40079E+01, 0.40137E+01, 0.40195E+01, 0.40253E+01, 0.40310E+01, & + 0.40368E+01, 0.40425E+01, 0.40482E+01, 0.40539E+01, 0.40596E+01, & + 0.40653E+01, 0.40710E+01, 0.40767E+01, 0.40824E+01, 0.40881E+01, & + 0.40937E+01, 0.40994E+01, 0.41050E+01, 0.41107E+01, 0.41163E+01, & + 0.41219E+01, 0.41275E+01, 0.41331E+01, 0.41387E+01, 0.41443E+01, & + 0.41499E+01, 0.41554E+01, 0.41610E+01, 0.41666E+01, 0.41721E+01, & + 0.41776E+01, 0.41832E+01, 0.41887E+01, 0.41942E+01, 0.41997E+01, & + 0.42052E+01, 0.42107E+01, 0.42162E+01, 0.42217E+01, 0.42271E+01, & + 0.42326E+01, 0.42381E+01, 0.42435E+01, 0.42489E+01, 0.42544E+01, & + 0.42598E+01, 0.42652E+01, 0.42706E+01, 0.42760E+01, 0.42814E+01, & + 0.42868E+01, 0.42922E+01, 0.42975E+01, 0.43029E+01, 0.43082E+01, & + 0.43136E+01, 0.43189E+01, 0.43243E+01, 0.43296E+01, 0.43349E+01, & + 0.43402E+01, 0.43455E+01, 0.43508E+01, 0.43561E+01, 0.43614E+01, & + 0.43667E+01, 0.43719E+01, 0.43772E+01, 0.43824E+01, 0.43877E+01, & + 0.43929E+01, 0.43982E+01, 0.44034E+01, 0.44086E+01, 0.44138E+01, & + 0.44190E+01, 0.44242E+01, 0.44294E+01, 0.44346E+01, 0.44397E+01, & + 0.44449E+01, 0.44501E+01, 0.44552E+01, 0.44604E+01, 0.44655E+01, & + 0.44706E+01, 0.44758E+01, 0.44809E+01, 0.44860E+01, 0.44911E+01, & + 0.44962E+01, 0.45013E+01, 0.45064E+01, 0.45115E+01, 0.45165E+01, & + 0.45216E+01, 0.45267E+01, 0.45317E+01, 0.45368E+01, 0.45556E+01/ + + DATA (BNC08M (I),I=601,700)/ & + 0.45968E+01, 0.46461E+01, 0.46948E+01, 0.47428E+01, 0.47903E+01, & + 0.48372E+01, 0.48835E+01, 0.49293E+01, 0.49745E+01, 0.50191E+01, & + 0.50633E+01, 0.51069E+01, 0.51500E+01, 0.51927E+01, 0.52349E+01, & + 0.52765E+01, 0.53178E+01, 0.53586E+01, 0.53989E+01, 0.54388E+01, & + 0.54783E+01, 0.55174E+01, 0.55560E+01, 0.55943E+01, 0.56322E+01, & + 0.56696E+01, 0.57067E+01, 0.57435E+01, 0.57799E+01, 0.58159E+01, & + 0.58515E+01, 0.58869E+01, 0.59218E+01, 0.59565E+01, 0.59908E+01, & + 0.60248E+01, 0.60585E+01, 0.60919E+01, 0.61249E+01, 0.61577E+01, & + 0.61902E+01, 0.62224E+01, 0.62543E+01, 0.62859E+01, 0.63172E+01, & + 0.63483E+01, 0.63791E+01, 0.64096E+01, 0.64399E+01, 0.64699E+01, & + 0.64997E+01, 0.65292E+01, 0.65585E+01, 0.65875E+01, 0.66163E+01, & + 0.66449E+01, 0.66733E+01, 0.67014E+01, 0.67293E+01, 0.67569E+01, & + 0.67844E+01, 0.68116E+01, 0.68387E+01, 0.68655E+01, 0.68921E+01, & + 0.69185E+01, 0.69447E+01, 0.69707E+01, 0.69966E+01, 0.70222E+01, & + 0.70477E+01, 0.70729E+01, 0.70980E+01, 0.71229E+01, 0.71476E+01, & + 0.71721E+01, 0.71965E+01, 0.72207E+01, 0.72447E+01, 0.72686E+01, & + 0.72922E+01, 0.73158E+01, 0.73391E+01, 0.73623E+01, 0.73854E+01, & + 0.74082E+01, 0.74310E+01, 0.74536E+01, 0.74760E+01, 0.74983E+01, & + 0.75204E+01, 0.75424E+01, 0.75642E+01, 0.75859E+01, 0.76075E+01, & + 0.76289E+01, 0.76502E+01, 0.76714E+01, 0.76924E+01, 0.77132E+01/ + + DATA (BNC08M(I),I=701,741)/ & + 0.77340E+01, 0.77546E+01, 0.77751E+01, 0.77955E+01, 0.78157E+01, & + 0.78358E+01, 0.78558E+01, 0.78757E+01, 0.78955E+01, 0.79151E+01, & + 0.79346E+01, 0.79540E+01, 0.79733E+01, 0.79925E+01, 0.80115E+01, & + 0.80305E+01, 0.80493E+01, 0.80680E+01, 0.80867E+01, 0.81052E+01, & + 0.81236E+01, 0.81419E+01, 0.81601E+01, 0.81782E+01, 0.81961E+01, & + 0.82140E+01, 0.82318E+01, 0.82495E+01, 0.82671E+01, 0.82846E+01, & + 0.83020E+01, 0.83193E+01, 0.83365E+01, 0.83536E+01, 0.83706E+01, & + 0.83876E+01, 0.84044E+01, 0.84212E+01, 0.84378E+01, 0.84544E+01, & + 0.84709E+01 & + / +! +! *** NH4HSO4 +! + DATA (BNC09M (I),I= 1,100)/ & + -0.52941E-01,-0.94844E-01,-0.12343E+00,-0.14239E+00,-0.15668E+00, & + -0.16813E+00,-0.17763E+00,-0.18572E+00,-0.19272E+00,-0.19884E+00, & + -0.20425E+00,-0.20906E+00,-0.21335E+00,-0.21720E+00,-0.22065E+00, & + -0.22375E+00,-0.22654E+00,-0.22903E+00,-0.23127E+00,-0.23327E+00, & + -0.23504E+00,-0.23660E+00,-0.23797E+00,-0.23915E+00,-0.24017E+00, & + -0.24102E+00,-0.24171E+00,-0.24226E+00,-0.24267E+00,-0.24294E+00, & + -0.24309E+00,-0.24311E+00,-0.24302E+00,-0.24281E+00,-0.24250E+00, & + -0.24208E+00,-0.24156E+00,-0.24094E+00,-0.24023E+00,-0.23943E+00, & + -0.23854E+00,-0.23757E+00,-0.23652E+00,-0.23539E+00,-0.23418E+00, & + -0.23290E+00,-0.23155E+00,-0.23014E+00,-0.22866E+00,-0.22711E+00, & + -0.22551E+00,-0.22384E+00,-0.22212E+00,-0.22034E+00,-0.21851E+00, & + -0.21663E+00,-0.21470E+00,-0.21272E+00,-0.21069E+00,-0.20862E+00, & + -0.20650E+00,-0.20434E+00,-0.20214E+00,-0.19990E+00,-0.19762E+00, & + -0.19530E+00,-0.19294E+00,-0.19054E+00,-0.18811E+00,-0.18564E+00, & + -0.18314E+00,-0.18060E+00,-0.17803E+00,-0.17542E+00,-0.17278E+00, & + -0.17011E+00,-0.16741E+00,-0.16467E+00,-0.16191E+00,-0.15911E+00, & + -0.15628E+00,-0.15342E+00,-0.15053E+00,-0.14761E+00,-0.14466E+00, & + -0.14168E+00,-0.13867E+00,-0.13563E+00,-0.13256E+00,-0.12947E+00, & + -0.12635E+00,-0.12321E+00,-0.12003E+00,-0.11684E+00,-0.11361E+00, & + -0.11037E+00,-0.10710E+00,-0.10381E+00,-0.10049E+00,-0.97158E-01/ + + DATA (BNC09M (I),I=101,200)/ & + -0.93803E-01,-0.90429E-01,-0.87037E-01,-0.83628E-01,-0.80202E-01, & + -0.76760E-01,-0.73304E-01,-0.69834E-01,-0.66351E-01,-0.62857E-01, & + -0.59352E-01,-0.55836E-01,-0.52311E-01,-0.48778E-01,-0.45238E-01, & + -0.41691E-01,-0.38138E-01,-0.34580E-01,-0.31018E-01,-0.27452E-01, & + -0.24230E-01,-0.20619E-01,-0.17011E-01,-0.13406E-01,-0.98032E-02, & + -0.62041E-02,-0.26086E-02, 0.98318E-03, 0.45710E-02, 0.81547E-02, & + 0.11734E-01, 0.15308E-01, 0.18878E-01, 0.22443E-01, 0.26003E-01, & + 0.29557E-01, 0.33105E-01, 0.36648E-01, 0.40186E-01, 0.43717E-01, & + 0.47242E-01, 0.50762E-01, 0.54274E-01, 0.57781E-01, 0.61281E-01, & + 0.64774E-01, 0.68261E-01, 0.71740E-01, 0.75213E-01, 0.78679E-01, & + 0.82138E-01, 0.85590E-01, 0.89034E-01, 0.92472E-01, 0.95902E-01, & + 0.99324E-01, 0.10274E+00, 0.10615E+00, 0.10955E+00, 0.11294E+00, & + 0.11633E+00, 0.11970E+00, 0.12307E+00, 0.12643E+00, 0.12979E+00, & + 0.13314E+00, 0.13647E+00, 0.13981E+00, 0.14313E+00, 0.14644E+00, & + 0.14975E+00, 0.15305E+00, 0.15634E+00, 0.15963E+00, 0.16290E+00, & + 0.16617E+00, 0.16943E+00, 0.17268E+00, 0.17593E+00, 0.17917E+00, & + 0.18239E+00, 0.18562E+00, 0.18883E+00, 0.19203E+00, 0.19523E+00, & + 0.19842E+00, 0.20160E+00, 0.20478E+00, 0.20794E+00, 0.21110E+00, & + 0.21425E+00, 0.21739E+00, 0.22053E+00, 0.22366E+00, 0.22677E+00, & + 0.22989E+00, 0.23299E+00, 0.23609E+00, 0.23917E+00, 0.24226E+00/ + + DATA (BNC09M (I),I=201,300)/ & + 0.24533E+00, 0.24839E+00, 0.25145E+00, 0.25450E+00, 0.25755E+00, & + 0.26058E+00, 0.26361E+00, 0.26663E+00, 0.26964E+00, 0.27265E+00, & + 0.27565E+00, 0.27864E+00, 0.28162E+00, 0.28460E+00, 0.28756E+00, & + 0.29053E+00, 0.29348E+00, 0.29643E+00, 0.29937E+00, 0.30230E+00, & + 0.30522E+00, 0.30814E+00, 0.31105E+00, 0.31396E+00, 0.31685E+00, & + 0.31974E+00, 0.32263E+00, 0.32550E+00, 0.32837E+00, 0.33123E+00, & + 0.33409E+00, 0.33694E+00, 0.33978E+00, 0.34261E+00, 0.34544E+00, & + 0.34826E+00, 0.35108E+00, 0.35388E+00, 0.35668E+00, 0.35948E+00, & + 0.36227E+00, 0.36505E+00, 0.36782E+00, 0.37059E+00, 0.37335E+00, & + 0.37610E+00, 0.37885E+00, 0.38159E+00, 0.38433E+00, 0.38706E+00, & + 0.38978E+00, 0.39250E+00, 0.39521E+00, 0.39791E+00, 0.40061E+00, & + 0.40330E+00, 0.40598E+00, 0.40866E+00, 0.41133E+00, 0.41400E+00, & + 0.41666E+00, 0.41931E+00, 0.42196E+00, 0.42460E+00, 0.42724E+00, & + 0.42987E+00, 0.43249E+00, 0.43511E+00, 0.43772E+00, 0.44033E+00, & + 0.44293E+00, 0.44552E+00, 0.44811E+00, 0.45069E+00, 0.45327E+00, & + 0.45584E+00, 0.45841E+00, 0.46097E+00, 0.46352E+00, 0.46607E+00, & + 0.46861E+00, 0.47115E+00, 0.47368E+00, 0.47620E+00, 0.47872E+00, & + 0.48124E+00, 0.48375E+00, 0.48625E+00, 0.48875E+00, 0.49124E+00, & + 0.49373E+00, 0.49621E+00, 0.49869E+00, 0.50116E+00, 0.50362E+00, & + 0.50608E+00, 0.50854E+00, 0.51099E+00, 0.51343E+00, 0.51587E+00/ + + DATA (BNC09M (I),I=301,400)/ & + 0.51831E+00, 0.52073E+00, 0.52316E+00, 0.52558E+00, 0.52799E+00, & + 0.53040E+00, 0.53280E+00, 0.53520E+00, 0.53759E+00, 0.53998E+00, & + 0.54236E+00, 0.54474E+00, 0.54711E+00, 0.54948E+00, 0.55184E+00, & + 0.55420E+00, 0.55655E+00, 0.55890E+00, 0.56125E+00, 0.56358E+00, & + 0.56592E+00, 0.56825E+00, 0.57057E+00, 0.57289E+00, 0.57520E+00, & + 0.57751E+00, 0.57982E+00, 0.58212E+00, 0.58442E+00, 0.58671E+00, & + 0.58899E+00, 0.59127E+00, 0.59355E+00, 0.59582E+00, 0.59809E+00, & + 0.60036E+00, 0.60261E+00, 0.60487E+00, 0.60712E+00, 0.60936E+00, & + 0.61160E+00, 0.61384E+00, 0.61607E+00, 0.61830E+00, 0.62052E+00, & + 0.62274E+00, 0.62495E+00, 0.62716E+00, 0.62937E+00, 0.63157E+00, & + 0.63377E+00, 0.63596E+00, 0.63815E+00, 0.64033E+00, 0.64251E+00, & + 0.64469E+00, 0.64686E+00, 0.64902E+00, 0.65119E+00, 0.65334E+00, & + 0.65550E+00, 0.65765E+00, 0.65979E+00, 0.66194E+00, 0.66407E+00, & + 0.66621E+00, 0.66834E+00, 0.67046E+00, 0.67258E+00, 0.67470E+00, & + 0.67681E+00, 0.67892E+00, 0.68103E+00, 0.68313E+00, 0.68523E+00, & + 0.68732E+00, 0.68941E+00, 0.69150E+00, 0.69358E+00, 0.69565E+00, & + 0.69773E+00, 0.69980E+00, 0.70186E+00, 0.70393E+00, 0.70598E+00, & + 0.70804E+00, 0.71009E+00, 0.71214E+00, 0.71418E+00, 0.71622E+00, & + 0.71825E+00, 0.72028E+00, 0.72231E+00, 0.72434E+00, 0.72636E+00, & + 0.72837E+00, 0.73039E+00, 0.73240E+00, 0.73440E+00, 0.73640E+00/ + + DATA (BNC09M (I),I=401,500)/ & + 0.73840E+00, 0.74040E+00, 0.74239E+00, 0.74438E+00, 0.74636E+00, & + 0.74834E+00, 0.75032E+00, 0.75229E+00, 0.75426E+00, 0.75623E+00, & + 0.75819E+00, 0.76015E+00, 0.76210E+00, 0.76405E+00, 0.76600E+00, & + 0.76795E+00, 0.76989E+00, 0.77183E+00, 0.77376E+00, 0.77569E+00, & + 0.77762E+00, 0.77955E+00, 0.78147E+00, 0.78338E+00, 0.78530E+00, & + 0.78721E+00, 0.78912E+00, 0.79102E+00, 0.79292E+00, 0.79482E+00, & + 0.79671E+00, 0.79861E+00, 0.80049E+00, 0.80238E+00, 0.80426E+00, & + 0.80614E+00, 0.80801E+00, 0.80988E+00, 0.81175E+00, 0.81361E+00, & + 0.81548E+00, 0.81733E+00, 0.81919E+00, 0.82104E+00, 0.82289E+00, & + 0.82474E+00, 0.82658E+00, 0.82842E+00, 0.83025E+00, 0.83209E+00, & + 0.83392E+00, 0.83574E+00, 0.83757E+00, 0.83939E+00, 0.84121E+00, & + 0.84302E+00, 0.84483E+00, 0.84664E+00, 0.84845E+00, 0.85025E+00, & + 0.85205E+00, 0.85384E+00, 0.85564E+00, 0.85743E+00, 0.85921E+00, & + 0.86100E+00, 0.86278E+00, 0.86456E+00, 0.86633E+00, 0.86811E+00, & + 0.86988E+00, 0.87164E+00, 0.87341E+00, 0.87517E+00, 0.87692E+00, & + 0.87868E+00, 0.88043E+00, 0.88218E+00, 0.88393E+00, 0.88567E+00, & + 0.88741E+00, 0.88915E+00, 0.89088E+00, 0.89262E+00, 0.89434E+00, & + 0.89607E+00, 0.89779E+00, 0.89952E+00, 0.90123E+00, 0.90295E+00, & + 0.90466E+00, 0.90637E+00, 0.90808E+00, 0.90978E+00, 0.91148E+00, & + 0.91318E+00, 0.91488E+00, 0.91657E+00, 0.91826E+00, 0.91995E+00/ + + DATA (BNC09M (I),I=501,600)/ & + 0.92163E+00, 0.92332E+00, 0.92500E+00, 0.92667E+00, 0.92835E+00, & + 0.93002E+00, 0.93169E+00, 0.93335E+00, 0.93502E+00, 0.93668E+00, & + 0.93834E+00, 0.93999E+00, 0.94165E+00, 0.94330E+00, 0.94495E+00, & + 0.94659E+00, 0.94823E+00, 0.94987E+00, 0.95151E+00, 0.95315E+00, & + 0.95478E+00, 0.95641E+00, 0.95804E+00, 0.95966E+00, 0.96128E+00, & + 0.96290E+00, 0.96452E+00, 0.96614E+00, 0.96775E+00, 0.96936E+00, & + 0.97097E+00, 0.97257E+00, 0.97417E+00, 0.97577E+00, 0.97737E+00, & + 0.97897E+00, 0.98056E+00, 0.98215E+00, 0.98374E+00, 0.98532E+00, & + 0.98690E+00, 0.98848E+00, 0.99006E+00, 0.99164E+00, 0.99321E+00, & + 0.99478E+00, 0.99635E+00, 0.99792E+00, 0.99948E+00, 0.10010E+01, & + 0.10026E+01, 0.10042E+01, 0.10057E+01, 0.10073E+01, 0.10088E+01, & + 0.10104E+01, 0.10119E+01, 0.10134E+01, 0.10150E+01, 0.10165E+01, & + 0.10181E+01, 0.10196E+01, 0.10211E+01, 0.10227E+01, 0.10242E+01, & + 0.10257E+01, 0.10272E+01, 0.10287E+01, 0.10303E+01, 0.10318E+01, & + 0.10333E+01, 0.10348E+01, 0.10363E+01, 0.10378E+01, 0.10393E+01, & + 0.10408E+01, 0.10423E+01, 0.10438E+01, 0.10453E+01, 0.10468E+01, & + 0.10483E+01, 0.10498E+01, 0.10513E+01, 0.10528E+01, 0.10542E+01, & + 0.10557E+01, 0.10572E+01, 0.10587E+01, 0.10601E+01, 0.10616E+01, & + 0.10631E+01, 0.10646E+01, 0.10660E+01, 0.10675E+01, 0.10689E+01, & + 0.10704E+01, 0.10719E+01, 0.10733E+01, 0.10748E+01, 0.10802E+01/ + + DATA (BNC09M (I),I=601,700)/ & + 0.10920E+01, 0.11062E+01, 0.11202E+01, 0.11339E+01, 0.11475E+01, & + 0.11609E+01, 0.11741E+01, 0.11872E+01, 0.12000E+01, 0.12127E+01, & + 0.12252E+01, 0.12376E+01, 0.12498E+01, 0.12619E+01, 0.12738E+01, & + 0.12855E+01, 0.12971E+01, 0.13086E+01, 0.13199E+01, 0.13311E+01, & + 0.13421E+01, 0.13531E+01, 0.13638E+01, 0.13745E+01, 0.13850E+01, & + 0.13954E+01, 0.14057E+01, 0.14159E+01, 0.14259E+01, 0.14359E+01, & + 0.14457E+01, 0.14554E+01, 0.14650E+01, 0.14745E+01, 0.14839E+01, & + 0.14932E+01, 0.15024E+01, 0.15115E+01, 0.15205E+01, 0.15294E+01, & + 0.15382E+01, 0.15469E+01, 0.15555E+01, 0.15641E+01, 0.15725E+01, & + 0.15808E+01, 0.15891E+01, 0.15973E+01, 0.16054E+01, 0.16134E+01, & + 0.16213E+01, 0.16292E+01, 0.16370E+01, 0.16447E+01, 0.16523E+01, & + 0.16598E+01, 0.16673E+01, 0.16747E+01, 0.16820E+01, 0.16893E+01, & + 0.16965E+01, 0.17036E+01, 0.17106E+01, 0.17176E+01, 0.17245E+01, & + 0.17314E+01, 0.17381E+01, 0.17449E+01, 0.17515E+01, 0.17581E+01, & + 0.17646E+01, 0.17711E+01, 0.17775E+01, 0.17839E+01, 0.17902E+01, & + 0.17964E+01, 0.18026E+01, 0.18087E+01, 0.18148E+01, 0.18208E+01, & + 0.18268E+01, 0.18327E+01, 0.18385E+01, 0.18443E+01, 0.18501E+01, & + 0.18558E+01, 0.18614E+01, 0.18671E+01, 0.18726E+01, 0.18781E+01, & + 0.18836E+01, 0.18890E+01, 0.18943E+01, 0.18997E+01, 0.19049E+01, & + 0.19102E+01, 0.19153E+01, 0.19205E+01, 0.19256E+01, 0.19306E+01/ + + DATA (BNC09M(I),I=701,741)/ & + 0.19356E+01, 0.19406E+01, 0.19455E+01, 0.19504E+01, 0.19552E+01, & + 0.19600E+01, 0.19648E+01, 0.19695E+01, 0.19742E+01, 0.19788E+01, & + 0.19835E+01, 0.19880E+01, 0.19925E+01, 0.19970E+01, 0.20015E+01, & + 0.20059E+01, 0.20103E+01, 0.20146E+01, 0.20190E+01, 0.20232E+01, & + 0.20275E+01, 0.20317E+01, 0.20359E+01, 0.20400E+01, 0.20441E+01, & + 0.20482E+01, 0.20522E+01, 0.20562E+01, 0.20602E+01, 0.20641E+01, & + 0.20681E+01, 0.20719E+01, 0.20758E+01, 0.20796E+01, 0.20834E+01, & + 0.20872E+01, 0.20909E+01, 0.20946E+01, 0.20983E+01, 0.21019E+01, & + 0.21055E+01 & + / +! +! *** (H, NO3) +! + DATA (BNC10M (I),I= 1,100)/ & + -0.52126E-01,-0.91475E-01,-0.11662E+00,-0.13216E+00,-0.14305E+00, & + -0.15115E+00,-0.15736E+00,-0.16220E+00,-0.16600E+00,-0.16898E+00, & + -0.17131E+00,-0.17309E+00,-0.17442E+00,-0.17536E+00,-0.17597E+00, & + -0.17629E+00,-0.17637E+00,-0.17622E+00,-0.17588E+00,-0.17536E+00, & + -0.17469E+00,-0.17388E+00,-0.17294E+00,-0.17189E+00,-0.17074E+00, & + -0.16950E+00,-0.16817E+00,-0.16677E+00,-0.16530E+00,-0.16377E+00, & + -0.16218E+00,-0.16054E+00,-0.15885E+00,-0.15712E+00,-0.15535E+00, & + -0.15355E+00,-0.15172E+00,-0.14986E+00,-0.14797E+00,-0.14606E+00, & + -0.14413E+00,-0.14218E+00,-0.14022E+00,-0.13824E+00,-0.13625E+00, & + -0.13425E+00,-0.13223E+00,-0.13021E+00,-0.12818E+00,-0.12615E+00, & + -0.12410E+00,-0.12206E+00,-0.12000E+00,-0.11795E+00,-0.11588E+00, & + -0.11382E+00,-0.11175E+00,-0.10968E+00,-0.10760E+00,-0.10552E+00, & + -0.10344E+00,-0.10135E+00,-0.99254E-01,-0.97155E-01,-0.95051E-01, & + -0.92942E-01,-0.90825E-01,-0.88702E-01,-0.86572E-01,-0.84433E-01, & + -0.82285E-01,-0.80128E-01,-0.77962E-01,-0.75784E-01,-0.73596E-01, & + -0.71395E-01,-0.69182E-01,-0.66957E-01,-0.64717E-01,-0.62464E-01, & + -0.60196E-01,-0.57913E-01,-0.55615E-01,-0.53301E-01,-0.50971E-01, & + -0.48625E-01,-0.46262E-01,-0.43883E-01,-0.41487E-01,-0.39075E-01, & + -0.36646E-01,-0.34200E-01,-0.31738E-01,-0.29259E-01,-0.26764E-01, & + -0.24254E-01,-0.21728E-01,-0.19186E-01,-0.16630E-01,-0.14060E-01/ + + DATA (BNC10M (I),I=101,200)/ & + -0.11475E-01,-0.88771E-02,-0.62662E-02,-0.36428E-02,-0.10075E-02, & + 0.16391E-02, 0.42964E-02, 0.69640E-02, 0.96412E-02, 0.12327E-01, & + 0.15022E-01, 0.17725E-01, 0.20434E-01, 0.23151E-01, 0.25874E-01, & + 0.28602E-01, 0.31336E-01, 0.34074E-01, 0.36816E-01, 0.39562E-01, & + 0.41991E-01, 0.44780E-01, 0.47568E-01, 0.50354E-01, 0.53138E-01, & + 0.55921E-01, 0.58702E-01, 0.61482E-01, 0.64259E-01, 0.67035E-01, & + 0.69808E-01, 0.72580E-01, 0.75349E-01, 0.78117E-01, 0.80882E-01, & + 0.83644E-01, 0.86404E-01, 0.89162E-01, 0.91917E-01, 0.94670E-01, & + 0.97420E-01, 0.10017E+00, 0.10291E+00, 0.10565E+00, 0.10839E+00, & + 0.11113E+00, 0.11386E+00, 0.11659E+00, 0.11932E+00, 0.12205E+00, & + 0.12477E+00, 0.12749E+00, 0.13020E+00, 0.13291E+00, 0.13562E+00, & + 0.13833E+00, 0.14103E+00, 0.14373E+00, 0.14643E+00, 0.14912E+00, & + 0.15181E+00, 0.15449E+00, 0.15718E+00, 0.15985E+00, 0.16253E+00, & + 0.16520E+00, 0.16787E+00, 0.17053E+00, 0.17320E+00, 0.17585E+00, & + 0.17851E+00, 0.18116E+00, 0.18380E+00, 0.18645E+00, 0.18909E+00, & + 0.19172E+00, 0.19435E+00, 0.19698E+00, 0.19961E+00, 0.20223E+00, & + 0.20484E+00, 0.20745E+00, 0.21006E+00, 0.21267E+00, 0.21527E+00, & + 0.21787E+00, 0.22046E+00, 0.22305E+00, 0.22564E+00, 0.22822E+00, & + 0.23079E+00, 0.23337E+00, 0.23594E+00, 0.23850E+00, 0.24107E+00, & + 0.24362E+00, 0.24618E+00, 0.24873E+00, 0.25127E+00, 0.25382E+00/ + + DATA (BNC10M (I),I=201,300)/ & + 0.25635E+00, 0.25889E+00, 0.26142E+00, 0.26394E+00, 0.26647E+00, & + 0.26898E+00, 0.27150E+00, 0.27401E+00, 0.27651E+00, 0.27901E+00, & + 0.28151E+00, 0.28401E+00, 0.28649E+00, 0.28898E+00, 0.29146E+00, & + 0.29394E+00, 0.29641E+00, 0.29888E+00, 0.30135E+00, 0.30381E+00, & + 0.30626E+00, 0.30872E+00, 0.31117E+00, 0.31361E+00, 0.31605E+00, & + 0.31849E+00, 0.32092E+00, 0.32335E+00, 0.32577E+00, 0.32819E+00, & + 0.33061E+00, 0.33302E+00, 0.33543E+00, 0.33783E+00, 0.34023E+00, & + 0.34263E+00, 0.34502E+00, 0.34741E+00, 0.34979E+00, 0.35217E+00, & + 0.35455E+00, 0.35692E+00, 0.35929E+00, 0.36165E+00, 0.36401E+00, & + 0.36637E+00, 0.36872E+00, 0.37107E+00, 0.37341E+00, 0.37575E+00, & + 0.37808E+00, 0.38041E+00, 0.38274E+00, 0.38507E+00, 0.38738E+00, & + 0.38970E+00, 0.39201E+00, 0.39432E+00, 0.39662E+00, 0.39892E+00, & + 0.40122E+00, 0.40351E+00, 0.40580E+00, 0.40808E+00, 0.41036E+00, & + 0.41264E+00, 0.41491E+00, 0.41718E+00, 0.41944E+00, 0.42170E+00, & + 0.42396E+00, 0.42621E+00, 0.42846E+00, 0.43070E+00, 0.43294E+00, & + 0.43518E+00, 0.43741E+00, 0.43964E+00, 0.44186E+00, 0.44409E+00, & + 0.44630E+00, 0.44852E+00, 0.45073E+00, 0.45293E+00, 0.45513E+00, & + 0.45733E+00, 0.45953E+00, 0.46172E+00, 0.46390E+00, 0.46609E+00, & + 0.46827E+00, 0.47044E+00, 0.47261E+00, 0.47478E+00, 0.47695E+00, & + 0.47911E+00, 0.48126E+00, 0.48342E+00, 0.48556E+00, 0.48771E+00/ + + DATA (BNC10M (I),I=301,400)/ & + 0.48985E+00, 0.49199E+00, 0.49412E+00, 0.49625E+00, 0.49838E+00, & + 0.50050E+00, 0.50262E+00, 0.50474E+00, 0.50685E+00, 0.50896E+00, & + 0.51107E+00, 0.51317E+00, 0.51526E+00, 0.51736E+00, 0.51945E+00, & + 0.52154E+00, 0.52362E+00, 0.52570E+00, 0.52778E+00, 0.52985E+00, & + 0.53192E+00, 0.53398E+00, 0.53604E+00, 0.53810E+00, 0.54016E+00, & + 0.54221E+00, 0.54426E+00, 0.54630E+00, 0.54834E+00, 0.55038E+00, & + 0.55241E+00, 0.55444E+00, 0.55647E+00, 0.55849E+00, 0.56051E+00, & + 0.56253E+00, 0.56454E+00, 0.56655E+00, 0.56856E+00, 0.57056E+00, & + 0.57256E+00, 0.57455E+00, 0.57654E+00, 0.57853E+00, 0.58052E+00, & + 0.58250E+00, 0.58448E+00, 0.58645E+00, 0.58843E+00, 0.59040E+00, & + 0.59236E+00, 0.59432E+00, 0.59628E+00, 0.59824E+00, 0.60019E+00, & + 0.60214E+00, 0.60408E+00, 0.60602E+00, 0.60796E+00, 0.60990E+00, & + 0.61183E+00, 0.61376E+00, 0.61569E+00, 0.61761E+00, 0.61953E+00, & + 0.62144E+00, 0.62336E+00, 0.62527E+00, 0.62717E+00, 0.62907E+00, & + 0.63097E+00, 0.63287E+00, 0.63476E+00, 0.63666E+00, 0.63854E+00, & + 0.64043E+00, 0.64231E+00, 0.64418E+00, 0.64606E+00, 0.64793E+00, & + 0.64980E+00, 0.65166E+00, 0.65353E+00, 0.65539E+00, 0.65724E+00, & + 0.65909E+00, 0.66094E+00, 0.66279E+00, 0.66463E+00, 0.66647E+00, & + 0.66831E+00, 0.67015E+00, 0.67198E+00, 0.67381E+00, 0.67563E+00, & + 0.67745E+00, 0.67927E+00, 0.68109E+00, 0.68290E+00, 0.68471E+00/ + + DATA (BNC10M (I),I=401,500)/ & + 0.68652E+00, 0.68832E+00, 0.69013E+00, 0.69192E+00, 0.69372E+00, & + 0.69551E+00, 0.69730E+00, 0.69909E+00, 0.70087E+00, 0.70265E+00, & + 0.70443E+00, 0.70621E+00, 0.70798E+00, 0.70975E+00, 0.71151E+00, & + 0.71328E+00, 0.71504E+00, 0.71680E+00, 0.71855E+00, 0.72030E+00, & + 0.72205E+00, 0.72380E+00, 0.72554E+00, 0.72728E+00, 0.72902E+00, & + 0.73075E+00, 0.73249E+00, 0.73422E+00, 0.73594E+00, 0.73767E+00, & + 0.73939E+00, 0.74111E+00, 0.74282E+00, 0.74453E+00, 0.74624E+00, & + 0.74795E+00, 0.74966E+00, 0.75136E+00, 0.75306E+00, 0.75475E+00, & + 0.75645E+00, 0.75814E+00, 0.75983E+00, 0.76151E+00, 0.76319E+00, & + 0.76487E+00, 0.76655E+00, 0.76823E+00, 0.76990E+00, 0.77157E+00, & + 0.77324E+00, 0.77490E+00, 0.77656E+00, 0.77822E+00, 0.77988E+00, & + 0.78153E+00, 0.78318E+00, 0.78483E+00, 0.78648E+00, 0.78812E+00, & + 0.78976E+00, 0.79140E+00, 0.79303E+00, 0.79467E+00, 0.79630E+00, & + 0.79792E+00, 0.79955E+00, 0.80117E+00, 0.80279E+00, 0.80441E+00, & + 0.80603E+00, 0.80764E+00, 0.80925E+00, 0.81086E+00, 0.81246E+00, & + 0.81406E+00, 0.81566E+00, 0.81726E+00, 0.81886E+00, 0.82045E+00, & + 0.82204E+00, 0.82363E+00, 0.82521E+00, 0.82679E+00, 0.82837E+00, & + 0.82995E+00, 0.83153E+00, 0.83310E+00, 0.83467E+00, 0.83624E+00, & + 0.83781E+00, 0.83937E+00, 0.84093E+00, 0.84249E+00, 0.84405E+00, & + 0.84560E+00, 0.84715E+00, 0.84870E+00, 0.85025E+00, 0.85179E+00/ + + DATA (BNC10M (I),I=501,600)/ & + 0.85333E+00, 0.85487E+00, 0.85641E+00, 0.85794E+00, 0.85948E+00, & + 0.86101E+00, 0.86254E+00, 0.86406E+00, 0.86558E+00, 0.86711E+00, & + 0.86862E+00, 0.87014E+00, 0.87165E+00, 0.87317E+00, 0.87468E+00, & + 0.87618E+00, 0.87769E+00, 0.87919E+00, 0.88069E+00, 0.88219E+00, & + 0.88369E+00, 0.88518E+00, 0.88667E+00, 0.88816E+00, 0.88965E+00, & + 0.89113E+00, 0.89261E+00, 0.89409E+00, 0.89557E+00, 0.89705E+00, & + 0.89852E+00, 0.89999E+00, 0.90146E+00, 0.90293E+00, 0.90439E+00, & + 0.90586E+00, 0.90732E+00, 0.90878E+00, 0.91023E+00, 0.91169E+00, & + 0.91314E+00, 0.91459E+00, 0.91604E+00, 0.91748E+00, 0.91893E+00, & + 0.92037E+00, 0.92181E+00, 0.92324E+00, 0.92468E+00, 0.92611E+00, & + 0.92754E+00, 0.92897E+00, 0.93040E+00, 0.93182E+00, 0.93324E+00, & + 0.93466E+00, 0.93608E+00, 0.93750E+00, 0.93891E+00, 0.94032E+00, & + 0.94173E+00, 0.94314E+00, 0.94455E+00, 0.94595E+00, 0.94735E+00, & + 0.94875E+00, 0.95015E+00, 0.95155E+00, 0.95294E+00, 0.95433E+00, & + 0.95572E+00, 0.95711E+00, 0.95850E+00, 0.95988E+00, 0.96126E+00, & + 0.96264E+00, 0.96402E+00, 0.96539E+00, 0.96677E+00, 0.96814E+00, & + 0.96951E+00, 0.97088E+00, 0.97224E+00, 0.97361E+00, 0.97497E+00, & + 0.97633E+00, 0.97769E+00, 0.97904E+00, 0.98040E+00, 0.98175E+00, & + 0.98310E+00, 0.98445E+00, 0.98580E+00, 0.98714E+00, 0.98848E+00, & + 0.98982E+00, 0.99116E+00, 0.99250E+00, 0.99383E+00, 0.99882E+00/ + + DATA (BNC10M (I),I=601,700)/ & + 0.10097E+01, 0.10227E+01, 0.10356E+01, 0.10483E+01, 0.10608E+01, & + 0.10731E+01, 0.10852E+01, 0.10972E+01, 0.11091E+01, 0.11208E+01, & + 0.11323E+01, 0.11437E+01, 0.11549E+01, 0.11660E+01, 0.11770E+01, & + 0.11878E+01, 0.11985E+01, 0.12090E+01, 0.12195E+01, 0.12298E+01, & + 0.12399E+01, 0.12500E+01, 0.12599E+01, 0.12697E+01, 0.12794E+01, & + 0.12889E+01, 0.12984E+01, 0.13077E+01, 0.13170E+01, 0.13261E+01, & + 0.13351E+01, 0.13441E+01, 0.13529E+01, 0.13616E+01, 0.13702E+01, & + 0.13788E+01, 0.13872E+01, 0.13955E+01, 0.14038E+01, 0.14119E+01, & + 0.14200E+01, 0.14280E+01, 0.14359E+01, 0.14437E+01, 0.14514E+01, & + 0.14590E+01, 0.14666E+01, 0.14741E+01, 0.14815E+01, 0.14888E+01, & + 0.14961E+01, 0.15032E+01, 0.15103E+01, 0.15174E+01, 0.15243E+01, & + 0.15312E+01, 0.15380E+01, 0.15448E+01, 0.15515E+01, 0.15581E+01, & + 0.15646E+01, 0.15711E+01, 0.15775E+01, 0.15839E+01, 0.15901E+01, & + 0.15964E+01, 0.16025E+01, 0.16086E+01, 0.16147E+01, 0.16207E+01, & + 0.16266E+01, 0.16325E+01, 0.16383E+01, 0.16441E+01, 0.16498E+01, & + 0.16554E+01, 0.16610E+01, 0.16666E+01, 0.16721E+01, 0.16775E+01, & + 0.16829E+01, 0.16882E+01, 0.16935E+01, 0.16988E+01, 0.17040E+01, & + 0.17091E+01, 0.17142E+01, 0.17193E+01, 0.17243E+01, 0.17292E+01, & + 0.17342E+01, 0.17390E+01, 0.17439E+01, 0.17486E+01, 0.17534E+01, & + 0.17581E+01, 0.17627E+01, 0.17674E+01, 0.17719E+01, 0.17765E+01/ + + DATA (BNC10M(I),I=701,741)/ & + 0.17810E+01, 0.17854E+01, 0.17898E+01, 0.17942E+01, 0.17985E+01, & + 0.18028E+01, 0.18071E+01, 0.18113E+01, 0.18155E+01, 0.18196E+01, & + 0.18238E+01, 0.18278E+01, 0.18319E+01, 0.18359E+01, 0.18399E+01, & + 0.18438E+01, 0.18477E+01, 0.18516E+01, 0.18554E+01, 0.18592E+01, & + 0.18630E+01, 0.18667E+01, 0.18704E+01, 0.18741E+01, 0.18777E+01, & + 0.18814E+01, 0.18849E+01, 0.18885E+01, 0.18920E+01, 0.18955E+01, & + 0.18990E+01, 0.19024E+01, 0.19058E+01, 0.19092E+01, 0.19125E+01, & + 0.19158E+01, 0.19191E+01, 0.19224E+01, 0.19256E+01, 0.19288E+01, & + 0.19320E+01 & + / +! +! *** (H, Cl) +! + DATA (BNC11M (I),I= 1,100)/ & + -0.50531E-01,-0.86008E-01,-0.10676E+00,-0.11831E+00,-0.12545E+00, & + -0.12992E+00,-0.13259E+00,-0.13394E+00,-0.13429E+00,-0.13382E+00, & + -0.13270E+00,-0.13103E+00,-0.12888E+00,-0.12633E+00,-0.12342E+00, & + -0.12019E+00,-0.11668E+00,-0.11291E+00,-0.10891E+00,-0.10470E+00, & + -0.10030E+00,-0.95726E-01,-0.90985E-01,-0.86094E-01,-0.81063E-01, & + -0.75902E-01,-0.70620E-01,-0.65226E-01,-0.59728E-01,-0.54132E-01, & + -0.48445E-01,-0.42673E-01,-0.36822E-01,-0.30897E-01,-0.24903E-01, & + -0.18845E-01,-0.12727E-01,-0.65528E-02,-0.32679E-03, 0.59476E-02, & + 0.12267E-01, 0.18628E-01, 0.25028E-01, 0.31464E-01, 0.37933E-01, & + 0.44433E-01, 0.50963E-01, 0.57519E-01, 0.64099E-01, 0.70704E-01, & + 0.77329E-01, 0.83976E-01, 0.90641E-01, 0.97325E-01, 0.10403E+00, & + 0.11074E+00, 0.11748E+00, 0.12423E+00, 0.13099E+00, 0.13777E+00, & + 0.14457E+00, 0.15138E+00, 0.15821E+00, 0.16505E+00, 0.17191E+00, & + 0.17879E+00, 0.18569E+00, 0.19260E+00, 0.19954E+00, 0.20650E+00, & + 0.21347E+00, 0.22048E+00, 0.22750E+00, 0.23455E+00, 0.24163E+00, & + 0.24873E+00, 0.25587E+00, 0.26303E+00, 0.27022E+00, 0.27745E+00, & + 0.28470E+00, 0.29200E+00, 0.29932E+00, 0.30668E+00, 0.31407E+00, & + 0.32150E+00, 0.32897E+00, 0.33647E+00, 0.34402E+00, 0.35159E+00, & + 0.35921E+00, 0.36686E+00, 0.37454E+00, 0.38226E+00, 0.39002E+00, & + 0.39781E+00, 0.40564E+00, 0.41349E+00, 0.42138E+00, 0.42931E+00/ + + DATA (BNC11M (I),I=101,200)/ & + 0.43726E+00, 0.44524E+00, 0.45324E+00, 0.46128E+00, 0.46933E+00, & + 0.47741E+00, 0.48552E+00, 0.49364E+00, 0.50178E+00, 0.50994E+00, & + 0.51812E+00, 0.52631E+00, 0.53452E+00, 0.54273E+00, 0.55096E+00, & + 0.55920E+00, 0.56744E+00, 0.57570E+00, 0.58395E+00, 0.59221E+00, & + 0.59974E+00, 0.60809E+00, 0.61644E+00, 0.62477E+00, 0.63310E+00, & + 0.64142E+00, 0.64973E+00, 0.65803E+00, 0.66632E+00, 0.67461E+00, & + 0.68288E+00, 0.69114E+00, 0.69939E+00, 0.70764E+00, 0.71587E+00, & + 0.72409E+00, 0.73230E+00, 0.74050E+00, 0.74869E+00, 0.75686E+00, & + 0.76502E+00, 0.77318E+00, 0.78132E+00, 0.78944E+00, 0.79756E+00, & + 0.80566E+00, 0.81375E+00, 0.82183E+00, 0.82990E+00, 0.83795E+00, & + 0.84599E+00, 0.85401E+00, 0.86202E+00, 0.87002E+00, 0.87801E+00, & + 0.88598E+00, 0.89394E+00, 0.90188E+00, 0.90981E+00, 0.91773E+00, & + 0.92563E+00, 0.93352E+00, 0.94139E+00, 0.94925E+00, 0.95710E+00, & + 0.96493E+00, 0.97275E+00, 0.98055E+00, 0.98834E+00, 0.99611E+00, & + 0.10039E+01, 0.10116E+01, 0.10193E+01, 0.10271E+01, 0.10348E+01, & + 0.10424E+01, 0.10501E+01, 0.10578E+01, 0.10654E+01, 0.10730E+01, & + 0.10807E+01, 0.10883E+01, 0.10958E+01, 0.11034E+01, 0.11110E+01, & + 0.11185E+01, 0.11260E+01, 0.11335E+01, 0.11410E+01, 0.11485E+01, & + 0.11560E+01, 0.11634E+01, 0.11708E+01, 0.11782E+01, 0.11857E+01, & + 0.11930E+01, 0.12004E+01, 0.12078E+01, 0.12151E+01, 0.12224E+01/ + + DATA (BNC11M (I),I=201,300)/ & + 0.12298E+01, 0.12370E+01, 0.12443E+01, 0.12516E+01, 0.12589E+01, & + 0.12661E+01, 0.12733E+01, 0.12805E+01, 0.12877E+01, 0.12949E+01, & + 0.13021E+01, 0.13092E+01, 0.13163E+01, 0.13235E+01, 0.13306E+01, & + 0.13377E+01, 0.13447E+01, 0.13518E+01, 0.13588E+01, 0.13659E+01, & + 0.13729E+01, 0.13799E+01, 0.13869E+01, 0.13939E+01, 0.14008E+01, & + 0.14078E+01, 0.14147E+01, 0.14216E+01, 0.14285E+01, 0.14354E+01, & + 0.14423E+01, 0.14491E+01, 0.14560E+01, 0.14628E+01, 0.14696E+01, & + 0.14764E+01, 0.14832E+01, 0.14900E+01, 0.14968E+01, 0.15035E+01, & + 0.15103E+01, 0.15170E+01, 0.15237E+01, 0.15304E+01, 0.15370E+01, & + 0.15437E+01, 0.15504E+01, 0.15570E+01, 0.15636E+01, 0.15702E+01, & + 0.15768E+01, 0.15834E+01, 0.15900E+01, 0.15965E+01, 0.16031E+01, & + 0.16096E+01, 0.16161E+01, 0.16226E+01, 0.16291E+01, 0.16356E+01, & + 0.16421E+01, 0.16485E+01, 0.16549E+01, 0.16614E+01, 0.16678E+01, & + 0.16742E+01, 0.16806E+01, 0.16869E+01, 0.16933E+01, 0.16996E+01, & + 0.17060E+01, 0.17123E+01, 0.17186E+01, 0.17249E+01, 0.17312E+01, & + 0.17374E+01, 0.17437E+01, 0.17499E+01, 0.17562E+01, 0.17624E+01, & + 0.17686E+01, 0.17748E+01, 0.17810E+01, 0.17872E+01, 0.17933E+01, & + 0.17995E+01, 0.18056E+01, 0.18117E+01, 0.18178E+01, 0.18239E+01, & + 0.18300E+01, 0.18361E+01, 0.18421E+01, 0.18482E+01, 0.18542E+01, & + 0.18602E+01, 0.18663E+01, 0.18723E+01, 0.18783E+01, 0.18842E+01/ + + DATA (BNC11M (I),I=301,400)/ & + 0.18902E+01, 0.18962E+01, 0.19021E+01, 0.19080E+01, 0.19139E+01, & + 0.19199E+01, 0.19258E+01, 0.19316E+01, 0.19375E+01, 0.19434E+01, & + 0.19492E+01, 0.19551E+01, 0.19609E+01, 0.19667E+01, 0.19725E+01, & + 0.19783E+01, 0.19841E+01, 0.19899E+01, 0.19956E+01, 0.20014E+01, & + 0.20071E+01, 0.20129E+01, 0.20186E+01, 0.20243E+01, 0.20300E+01, & + 0.20357E+01, 0.20413E+01, 0.20470E+01, 0.20527E+01, 0.20583E+01, & + 0.20639E+01, 0.20696E+01, 0.20752E+01, 0.20808E+01, 0.20864E+01, & + 0.20919E+01, 0.20975E+01, 0.21031E+01, 0.21086E+01, 0.21142E+01, & + 0.21197E+01, 0.21252E+01, 0.21307E+01, 0.21362E+01, 0.21417E+01, & + 0.21472E+01, 0.21526E+01, 0.21581E+01, 0.21635E+01, 0.21690E+01, & + 0.21744E+01, 0.21798E+01, 0.21852E+01, 0.21906E+01, 0.21960E+01, & + 0.22014E+01, 0.22068E+01, 0.22121E+01, 0.22175E+01, 0.22228E+01, & + 0.22281E+01, 0.22335E+01, 0.22388E+01, 0.22441E+01, 0.22494E+01, & + 0.22546E+01, 0.22599E+01, 0.22652E+01, 0.22704E+01, 0.22757E+01, & + 0.22809E+01, 0.22861E+01, 0.22913E+01, 0.22965E+01, 0.23017E+01, & + 0.23069E+01, 0.23121E+01, 0.23173E+01, 0.23224E+01, 0.23276E+01, & + 0.23327E+01, 0.23379E+01, 0.23430E+01, 0.23481E+01, 0.23532E+01, & + 0.23583E+01, 0.23634E+01, 0.23685E+01, 0.23735E+01, 0.23786E+01, & + 0.23837E+01, 0.23887E+01, 0.23937E+01, 0.23988E+01, 0.24038E+01, & + 0.24088E+01, 0.24138E+01, 0.24188E+01, 0.24238E+01, 0.24288E+01/ + + DATA (BNC11M (I),I=401,500)/ & + 0.24337E+01, 0.24387E+01, 0.24436E+01, 0.24486E+01, 0.24535E+01, & + 0.24584E+01, 0.24633E+01, 0.24682E+01, 0.24731E+01, 0.24780E+01, & + 0.24829E+01, 0.24878E+01, 0.24927E+01, 0.24975E+01, 0.25024E+01, & + 0.25072E+01, 0.25120E+01, 0.25169E+01, 0.25217E+01, 0.25265E+01, & + 0.25313E+01, 0.25361E+01, 0.25409E+01, 0.25457E+01, 0.25504E+01, & + 0.25552E+01, 0.25599E+01, 0.25647E+01, 0.25694E+01, 0.25742E+01, & + 0.25789E+01, 0.25836E+01, 0.25883E+01, 0.25930E+01, 0.25977E+01, & + 0.26024E+01, 0.26071E+01, 0.26117E+01, 0.26164E+01, 0.26210E+01, & + 0.26257E+01, 0.26303E+01, 0.26350E+01, 0.26396E+01, 0.26442E+01, & + 0.26488E+01, 0.26534E+01, 0.26580E+01, 0.26626E+01, 0.26672E+01, & + 0.26717E+01, 0.26763E+01, 0.26809E+01, 0.26854E+01, 0.26900E+01, & + 0.26945E+01, 0.26990E+01, 0.27035E+01, 0.27081E+01, 0.27126E+01, & + 0.27171E+01, 0.27216E+01, 0.27260E+01, 0.27305E+01, 0.27350E+01, & + 0.27395E+01, 0.27439E+01, 0.27484E+01, 0.27528E+01, 0.27572E+01, & + 0.27617E+01, 0.27661E+01, 0.27705E+01, 0.27749E+01, 0.27793E+01, & + 0.27837E+01, 0.27881E+01, 0.27925E+01, 0.27969E+01, 0.28012E+01, & + 0.28056E+01, 0.28099E+01, 0.28143E+01, 0.28186E+01, 0.28230E+01, & + 0.28273E+01, 0.28316E+01, 0.28359E+01, 0.28402E+01, 0.28445E+01, & + 0.28488E+01, 0.28531E+01, 0.28574E+01, 0.28617E+01, 0.28660E+01, & + 0.28702E+01, 0.28745E+01, 0.28787E+01, 0.28830E+01, 0.28872E+01/ + + DATA (BNC11M (I),I=501,600)/ & + 0.28914E+01, 0.28957E+01, 0.28999E+01, 0.29041E+01, 0.29083E+01, & + 0.29125E+01, 0.29167E+01, 0.29209E+01, 0.29251E+01, 0.29292E+01, & + 0.29334E+01, 0.29376E+01, 0.29417E+01, 0.29459E+01, 0.29500E+01, & + 0.29541E+01, 0.29583E+01, 0.29624E+01, 0.29665E+01, 0.29706E+01, & + 0.29747E+01, 0.29788E+01, 0.29829E+01, 0.29870E+01, 0.29911E+01, & + 0.29952E+01, 0.29993E+01, 0.30033E+01, 0.30074E+01, 0.30114E+01, & + 0.30155E+01, 0.30195E+01, 0.30236E+01, 0.30276E+01, 0.30316E+01, & + 0.30356E+01, 0.30396E+01, 0.30437E+01, 0.30477E+01, 0.30517E+01, & + 0.30556E+01, 0.30596E+01, 0.30636E+01, 0.30676E+01, 0.30715E+01, & + 0.30755E+01, 0.30795E+01, 0.30834E+01, 0.30874E+01, 0.30913E+01, & + 0.30952E+01, 0.30992E+01, 0.31031E+01, 0.31070E+01, 0.31109E+01, & + 0.31148E+01, 0.31187E+01, 0.31226E+01, 0.31265E+01, 0.31304E+01, & + 0.31343E+01, 0.31381E+01, 0.31420E+01, 0.31459E+01, 0.31497E+01, & + 0.31536E+01, 0.31574E+01, 0.31613E+01, 0.31651E+01, 0.31689E+01, & + 0.31727E+01, 0.31766E+01, 0.31804E+01, 0.31842E+01, 0.31880E+01, & + 0.31918E+01, 0.31956E+01, 0.31994E+01, 0.32032E+01, 0.32069E+01, & + 0.32107E+01, 0.32145E+01, 0.32182E+01, 0.32220E+01, 0.32257E+01, & + 0.32295E+01, 0.32332E+01, 0.32370E+01, 0.32407E+01, 0.32444E+01, & + 0.32482E+01, 0.32519E+01, 0.32556E+01, 0.32593E+01, 0.32630E+01, & + 0.32667E+01, 0.32704E+01, 0.32741E+01, 0.32778E+01, 0.32915E+01/ + + DATA (BNC11M (I),I=601,700)/ & + 0.33216E+01, 0.33575E+01, 0.33930E+01, 0.34281E+01, 0.34627E+01, & + 0.34969E+01, 0.35306E+01, 0.35640E+01, 0.35969E+01, 0.36294E+01, & + 0.36616E+01, 0.36933E+01, 0.37247E+01, 0.37557E+01, 0.37864E+01, & + 0.38167E+01, 0.38467E+01, 0.38764E+01, 0.39057E+01, 0.39347E+01, & + 0.39633E+01, 0.39917E+01, 0.40198E+01, 0.40475E+01, 0.40750E+01, & + 0.41022E+01, 0.41291E+01, 0.41558E+01, 0.41821E+01, 0.42082E+01, & + 0.42341E+01, 0.42596E+01, 0.42850E+01, 0.43100E+01, 0.43349E+01, & + 0.43595E+01, 0.43838E+01, 0.44080E+01, 0.44319E+01, 0.44556E+01, & + 0.44790E+01, 0.45023E+01, 0.45253E+01, 0.45481E+01, 0.45707E+01, & + 0.45932E+01, 0.46154E+01, 0.46374E+01, 0.46592E+01, 0.46809E+01, & + 0.47023E+01, 0.47236E+01, 0.47447E+01, 0.47656E+01, 0.47863E+01, & + 0.48069E+01, 0.48273E+01, 0.48475E+01, 0.48675E+01, 0.48874E+01, & + 0.49071E+01, 0.49267E+01, 0.49461E+01, 0.49654E+01, 0.49845E+01, & + 0.50034E+01, 0.50222E+01, 0.50409E+01, 0.50594E+01, 0.50778E+01, & + 0.50960E+01, 0.51141E+01, 0.51321E+01, 0.51499E+01, 0.51676E+01, & + 0.51851E+01, 0.52025E+01, 0.52198E+01, 0.52370E+01, 0.52541E+01, & + 0.52710E+01, 0.52878E+01, 0.53044E+01, 0.53210E+01, 0.53374E+01, & + 0.53538E+01, 0.53700E+01, 0.53861E+01, 0.54021E+01, 0.54179E+01, & + 0.54337E+01, 0.54494E+01, 0.54649E+01, 0.54804E+01, 0.54957E+01, & + 0.55109E+01, 0.55261E+01, 0.55411E+01, 0.55560E+01, 0.55709E+01/ + + DATA (BNC11M(I),I=701,741)/ & + 0.55856E+01, 0.56002E+01, 0.56148E+01, 0.56292E+01, 0.56436E+01, & + 0.56579E+01, 0.56720E+01, 0.56861E+01, 0.57001E+01, 0.57140E+01, & + 0.57278E+01, 0.57416E+01, 0.57552E+01, 0.57688E+01, 0.57822E+01, & + 0.57956E+01, 0.58089E+01, 0.58222E+01, 0.58353E+01, 0.58484E+01, & + 0.58614E+01, 0.58743E+01, 0.58871E+01, 0.58999E+01, 0.59126E+01, & + 0.59252E+01, 0.59377E+01, 0.59501E+01, 0.59625E+01, 0.59748E+01, & + 0.59871E+01, 0.59993E+01, 0.60114E+01, 0.60234E+01, 0.60353E+01, & + 0.60472E+01, 0.60591E+01, 0.60708E+01, 0.60825E+01, 0.60941E+01, & + 0.61057E+01 & + / +! +! *** NaHSO4 +! + DATA (BNC12M (I),I= 1,100)/ & + -0.51921E-01,-0.91127E-01,-0.11645E+00,-0.13236E+00,-0.14371E+00, & + -0.15232E+00,-0.15906E+00,-0.16443E+00,-0.16876E+00,-0.17225E+00, & + -0.17506E+00,-0.17730E+00,-0.17905E+00,-0.18038E+00,-0.18133E+00, & + -0.18195E+00,-0.18227E+00,-0.18232E+00,-0.18213E+00,-0.18171E+00, & + -0.18108E+00,-0.18026E+00,-0.17926E+00,-0.17809E+00,-0.17676E+00, & + -0.17528E+00,-0.17365E+00,-0.17190E+00,-0.17001E+00,-0.16801E+00, & + -0.16589E+00,-0.16366E+00,-0.16133E+00,-0.15889E+00,-0.15636E+00, & + -0.15374E+00,-0.15103E+00,-0.14824E+00,-0.14536E+00,-0.14241E+00, & + -0.13939E+00,-0.13629E+00,-0.13313E+00,-0.12990E+00,-0.12661E+00, & + -0.12326E+00,-0.11985E+00,-0.11638E+00,-0.11286E+00,-0.10930E+00, & + -0.10568E+00,-0.10201E+00,-0.98298E-01,-0.94541E-01,-0.90742E-01, & + -0.86901E-01,-0.83019E-01,-0.79099E-01,-0.75141E-01,-0.71146E-01, & + -0.67114E-01,-0.63048E-01,-0.58946E-01,-0.54810E-01,-0.50641E-01, & + -0.46438E-01,-0.42202E-01,-0.37933E-01,-0.33632E-01,-0.29299E-01, & + -0.24933E-01,-0.20535E-01,-0.16104E-01,-0.11641E-01,-0.71452E-02, & + -0.26167E-02, 0.19444E-02, 0.65385E-02, 0.11166E-01, 0.15826E-01, & + 0.20520E-01, 0.25246E-01, 0.30007E-01, 0.34800E-01, 0.39627E-01, & + 0.44487E-01, 0.49381E-01, 0.54307E-01, 0.59265E-01, 0.64256E-01, & + 0.69279E-01, 0.74333E-01, 0.79418E-01, 0.84533E-01, 0.89677E-01, & + 0.94851E-01, 0.10005E+00, 0.10528E+00, 0.11054E+00, 0.11582E+00/ + + DATA (BNC12M (I),I=101,200)/ & + 0.12112E+00, 0.12645E+00, 0.13180E+00, 0.13717E+00, 0.14256E+00, & + 0.14797E+00, 0.15339E+00, 0.15884E+00, 0.16429E+00, 0.16977E+00, & + 0.17525E+00, 0.18075E+00, 0.18625E+00, 0.19177E+00, 0.19729E+00, & + 0.20283E+00, 0.20836E+00, 0.21391E+00, 0.21946E+00, 0.22501E+00, & + 0.23004E+00, 0.23565E+00, 0.24126E+00, 0.24687E+00, 0.25246E+00, & + 0.25805E+00, 0.26364E+00, 0.26922E+00, 0.27479E+00, 0.28035E+00, & + 0.28591E+00, 0.29146E+00, 0.29700E+00, 0.30253E+00, 0.30806E+00, & + 0.31357E+00, 0.31908E+00, 0.32458E+00, 0.33007E+00, 0.33555E+00, & + 0.34103E+00, 0.34649E+00, 0.35194E+00, 0.35739E+00, 0.36282E+00, & + 0.36825E+00, 0.37367E+00, 0.37907E+00, 0.38447E+00, 0.38985E+00, & + 0.39523E+00, 0.40060E+00, 0.40595E+00, 0.41130E+00, 0.41663E+00, & + 0.42196E+00, 0.42727E+00, 0.43257E+00, 0.43787E+00, 0.44315E+00, & + 0.44842E+00, 0.45368E+00, 0.45893E+00, 0.46417E+00, 0.46940E+00, & + 0.47462E+00, 0.47982E+00, 0.48502E+00, 0.49021E+00, 0.49538E+00, & + 0.50054E+00, 0.50570E+00, 0.51084E+00, 0.51597E+00, 0.52109E+00, & + 0.52620E+00, 0.53130E+00, 0.53638E+00, 0.54146E+00, 0.54652E+00, & + 0.55158E+00, 0.55662E+00, 0.56165E+00, 0.56668E+00, 0.57169E+00, & + 0.57669E+00, 0.58168E+00, 0.58665E+00, 0.59162E+00, 0.59658E+00, & + 0.60152E+00, 0.60646E+00, 0.61138E+00, 0.61630E+00, 0.62120E+00, & + 0.62609E+00, 0.63097E+00, 0.63584E+00, 0.64070E+00, 0.64555E+00/ + + DATA (BNC12M (I),I=201,300)/ & + 0.65039E+00, 0.65522E+00, 0.66004E+00, 0.66484E+00, 0.66964E+00, & + 0.67443E+00, 0.67920E+00, 0.68397E+00, 0.68872E+00, 0.69347E+00, & + 0.69820E+00, 0.70293E+00, 0.70764E+00, 0.71234E+00, 0.71704E+00, & + 0.72172E+00, 0.72639E+00, 0.73105E+00, 0.73571E+00, 0.74035E+00, & + 0.74498E+00, 0.74960E+00, 0.75422E+00, 0.75882E+00, 0.76341E+00, & + 0.76799E+00, 0.77257E+00, 0.77713E+00, 0.78168E+00, 0.78623E+00, & + 0.79076E+00, 0.79528E+00, 0.79980E+00, 0.80430E+00, 0.80880E+00, & + 0.81328E+00, 0.81776E+00, 0.82223E+00, 0.82668E+00, 0.83113E+00, & + 0.83557E+00, 0.84000E+00, 0.84442E+00, 0.84883E+00, 0.85323E+00, & + 0.85762E+00, 0.86200E+00, 0.86638E+00, 0.87074E+00, 0.87509E+00, & + 0.87944E+00, 0.88378E+00, 0.88810E+00, 0.89242E+00, 0.89673E+00, & + 0.90103E+00, 0.90533E+00, 0.90961E+00, 0.91388E+00, 0.91815E+00, & + 0.92240E+00, 0.92665E+00, 0.93089E+00, 0.93512E+00, 0.93934E+00, & + 0.94356E+00, 0.94776E+00, 0.95196E+00, 0.95614E+00, 0.96032E+00, & + 0.96449E+00, 0.96865E+00, 0.97281E+00, 0.97695E+00, 0.98109E+00, & + 0.98522E+00, 0.98934E+00, 0.99345E+00, 0.99755E+00, 0.10016E+01, & + 0.10057E+01, 0.10098E+01, 0.10139E+01, 0.10179E+01, 0.10220E+01, & + 0.10260E+01, 0.10301E+01, 0.10341E+01, 0.10381E+01, 0.10422E+01, & + 0.10462E+01, 0.10502E+01, 0.10541E+01, 0.10581E+01, 0.10621E+01, & + 0.10661E+01, 0.10700E+01, 0.10740E+01, 0.10779E+01, 0.10819E+01/ + + DATA (BNC12M (I),I=301,400)/ & + 0.10858E+01, 0.10897E+01, 0.10936E+01, 0.10975E+01, 0.11014E+01, & + 0.11053E+01, 0.11092E+01, 0.11131E+01, 0.11170E+01, 0.11208E+01, & + 0.11247E+01, 0.11285E+01, 0.11324E+01, 0.11362E+01, 0.11400E+01, & + 0.11438E+01, 0.11476E+01, 0.11514E+01, 0.11552E+01, 0.11590E+01, & + 0.11628E+01, 0.11666E+01, 0.11703E+01, 0.11741E+01, 0.11779E+01, & + 0.11816E+01, 0.11853E+01, 0.11891E+01, 0.11928E+01, 0.11965E+01, & + 0.12002E+01, 0.12039E+01, 0.12076E+01, 0.12113E+01, 0.12150E+01, & + 0.12187E+01, 0.12224E+01, 0.12260E+01, 0.12297E+01, 0.12333E+01, & + 0.12370E+01, 0.12406E+01, 0.12442E+01, 0.12479E+01, 0.12515E+01, & + 0.12551E+01, 0.12587E+01, 0.12623E+01, 0.12659E+01, 0.12695E+01, & + 0.12730E+01, 0.12766E+01, 0.12802E+01, 0.12837E+01, 0.12873E+01, & + 0.12908E+01, 0.12944E+01, 0.12979E+01, 0.13014E+01, 0.13050E+01, & + 0.13085E+01, 0.13120E+01, 0.13155E+01, 0.13190E+01, 0.13225E+01, & + 0.13259E+01, 0.13294E+01, 0.13329E+01, 0.13364E+01, 0.13398E+01, & + 0.13433E+01, 0.13467E+01, 0.13502E+01, 0.13536E+01, 0.13570E+01, & + 0.13604E+01, 0.13639E+01, 0.13673E+01, 0.13707E+01, 0.13741E+01, & + 0.13775E+01, 0.13809E+01, 0.13842E+01, 0.13876E+01, 0.13910E+01, & + 0.13943E+01, 0.13977E+01, 0.14011E+01, 0.14044E+01, 0.14077E+01, & + 0.14111E+01, 0.14144E+01, 0.14177E+01, 0.14210E+01, 0.14244E+01, & + 0.14277E+01, 0.14310E+01, 0.14343E+01, 0.14376E+01, 0.14408E+01/ + + DATA (BNC12M (I),I=401,500)/ & + 0.14441E+01, 0.14474E+01, 0.14507E+01, 0.14539E+01, 0.14572E+01, & + 0.14604E+01, 0.14637E+01, 0.14669E+01, 0.14701E+01, 0.14734E+01, & + 0.14766E+01, 0.14798E+01, 0.14830E+01, 0.14862E+01, 0.14894E+01, & + 0.14926E+01, 0.14958E+01, 0.14990E+01, 0.15022E+01, 0.15054E+01, & + 0.15086E+01, 0.15117E+01, 0.15149E+01, 0.15180E+01, 0.15212E+01, & + 0.15243E+01, 0.15275E+01, 0.15306E+01, 0.15337E+01, 0.15369E+01, & + 0.15400E+01, 0.15431E+01, 0.15462E+01, 0.15493E+01, 0.15524E+01, & + 0.15555E+01, 0.15586E+01, 0.15617E+01, 0.15648E+01, 0.15678E+01, & + 0.15709E+01, 0.15740E+01, 0.15770E+01, 0.15801E+01, 0.15831E+01, & + 0.15862E+01, 0.15892E+01, 0.15923E+01, 0.15953E+01, 0.15983E+01, & + 0.16014E+01, 0.16044E+01, 0.16074E+01, 0.16104E+01, 0.16134E+01, & + 0.16164E+01, 0.16194E+01, 0.16224E+01, 0.16254E+01, 0.16283E+01, & + 0.16313E+01, 0.16343E+01, 0.16372E+01, 0.16402E+01, 0.16432E+01, & + 0.16461E+01, 0.16491E+01, 0.16520E+01, 0.16549E+01, 0.16579E+01, & + 0.16608E+01, 0.16637E+01, 0.16666E+01, 0.16696E+01, 0.16725E+01, & + 0.16754E+01, 0.16783E+01, 0.16812E+01, 0.16841E+01, 0.16870E+01, & + 0.16898E+01, 0.16927E+01, 0.16956E+01, 0.16985E+01, 0.17013E+01, & + 0.17042E+01, 0.17071E+01, 0.17099E+01, 0.17128E+01, 0.17156E+01, & + 0.17185E+01, 0.17213E+01, 0.17241E+01, 0.17269E+01, 0.17298E+01, & + 0.17326E+01, 0.17354E+01, 0.17382E+01, 0.17410E+01, 0.17438E+01/ + + DATA (BNC12M (I),I=501,600)/ & + 0.17466E+01, 0.17494E+01, 0.17522E+01, 0.17550E+01, 0.17578E+01, & + 0.17606E+01, 0.17633E+01, 0.17661E+01, 0.17689E+01, 0.17716E+01, & + 0.17744E+01, 0.17771E+01, 0.17799E+01, 0.17826E+01, 0.17854E+01, & + 0.17881E+01, 0.17908E+01, 0.17936E+01, 0.17963E+01, 0.17990E+01, & + 0.18017E+01, 0.18044E+01, 0.18072E+01, 0.18099E+01, 0.18126E+01, & + 0.18153E+01, 0.18180E+01, 0.18206E+01, 0.18233E+01, 0.18260E+01, & + 0.18287E+01, 0.18314E+01, 0.18340E+01, 0.18367E+01, 0.18394E+01, & + 0.18420E+01, 0.18447E+01, 0.18473E+01, 0.18500E+01, 0.18526E+01, & + 0.18553E+01, 0.18579E+01, 0.18605E+01, 0.18632E+01, 0.18658E+01, & + 0.18684E+01, 0.18710E+01, 0.18736E+01, 0.18763E+01, 0.18789E+01, & + 0.18815E+01, 0.18841E+01, 0.18867E+01, 0.18892E+01, 0.18918E+01, & + 0.18944E+01, 0.18970E+01, 0.18996E+01, 0.19022E+01, 0.19047E+01, & + 0.19073E+01, 0.19099E+01, 0.19124E+01, 0.19150E+01, 0.19175E+01, & + 0.19201E+01, 0.19226E+01, 0.19252E+01, 0.19277E+01, 0.19302E+01, & + 0.19328E+01, 0.19353E+01, 0.19378E+01, 0.19403E+01, 0.19428E+01, & + 0.19454E+01, 0.19479E+01, 0.19504E+01, 0.19529E+01, 0.19554E+01, & + 0.19579E+01, 0.19604E+01, 0.19629E+01, 0.19653E+01, 0.19678E+01, & + 0.19703E+01, 0.19728E+01, 0.19753E+01, 0.19777E+01, 0.19802E+01, & + 0.19827E+01, 0.19851E+01, 0.19876E+01, 0.19900E+01, 0.19925E+01, & + 0.19949E+01, 0.19974E+01, 0.19998E+01, 0.20022E+01, 0.20114E+01/ + + DATA (BNC12M (I),I=601,700)/ & + 0.20312E+01, 0.20550E+01, 0.20785E+01, 0.21017E+01, 0.21246E+01, & + 0.21472E+01, 0.21695E+01, 0.21916E+01, 0.22134E+01, 0.22349E+01, & + 0.22561E+01, 0.22771E+01, 0.22978E+01, 0.23183E+01, 0.23386E+01, & + 0.23586E+01, 0.23784E+01, 0.23980E+01, 0.24173E+01, 0.24364E+01, & + 0.24553E+01, 0.24740E+01, 0.24925E+01, 0.25108E+01, 0.25289E+01, & + 0.25468E+01, 0.25646E+01, 0.25821E+01, 0.25994E+01, 0.26166E+01, & + 0.26336E+01, 0.26504E+01, 0.26670E+01, 0.26835E+01, 0.26998E+01, & + 0.27160E+01, 0.27320E+01, 0.27478E+01, 0.27635E+01, 0.27790E+01, & + 0.27943E+01, 0.28096E+01, 0.28247E+01, 0.28396E+01, 0.28544E+01, & + 0.28690E+01, 0.28836E+01, 0.28980E+01, 0.29122E+01, 0.29263E+01, & + 0.29403E+01, 0.29542E+01, 0.29680E+01, 0.29816E+01, 0.29951E+01, & + 0.30085E+01, 0.30217E+01, 0.30349E+01, 0.30479E+01, 0.30609E+01, & + 0.30737E+01, 0.30864E+01, 0.30990E+01, 0.31115E+01, 0.31239E+01, & + 0.31362E+01, 0.31483E+01, 0.31604E+01, 0.31724E+01, 0.31843E+01, & + 0.31961E+01, 0.32078E+01, 0.32194E+01, 0.32309E+01, 0.32423E+01, & + 0.32536E+01, 0.32648E+01, 0.32760E+01, 0.32870E+01, 0.32980E+01, & + 0.33089E+01, 0.33197E+01, 0.33304E+01, 0.33411E+01, 0.33516E+01, & + 0.33621E+01, 0.33725E+01, 0.33828E+01, 0.33931E+01, 0.34032E+01, & + 0.34133E+01, 0.34233E+01, 0.34333E+01, 0.34431E+01, 0.34529E+01, & + 0.34627E+01, 0.34723E+01, 0.34819E+01, 0.34914E+01, 0.35009E+01/ + + DATA (BNC12M(I),I=701,741)/ & + 0.35103E+01, 0.35196E+01, 0.35288E+01, 0.35380E+01, 0.35471E+01, & + 0.35562E+01, 0.35652E+01, 0.35741E+01, 0.35830E+01, 0.35918E+01, & + 0.36005E+01, 0.36092E+01, 0.36178E+01, 0.36264E+01, 0.36349E+01, & + 0.36434E+01, 0.36518E+01, 0.36601E+01, 0.36684E+01, 0.36766E+01, & + 0.36848E+01, 0.36929E+01, 0.37010E+01, 0.37090E+01, 0.37169E+01, & + 0.37248E+01, 0.37327E+01, 0.37405E+01, 0.37483E+01, 0.37560E+01, & + 0.37636E+01, 0.37712E+01, 0.37788E+01, 0.37863E+01, 0.37938E+01, & + 0.38012E+01, 0.38085E+01, 0.38159E+01, 0.38231E+01, 0.38304E+01, & + 0.38376E+01 & + / +! +! *** (NH4)3H(SO4)2 +! + DATA (BNC13M (I),I= 1,100)/ & + -0.86312E-01,-0.15717E+00,-0.20713E+00,-0.24120E+00,-0.26753E+00, & + -0.28912E+00,-0.30750E+00,-0.32352E+00,-0.33773E+00,-0.35052E+00, & + -0.36214E+00,-0.37278E+00,-0.38261E+00,-0.39173E+00,-0.40023E+00, & + -0.40819E+00,-0.41567E+00,-0.42272E+00,-0.42938E+00,-0.43570E+00, & + -0.44169E+00,-0.44739E+00,-0.45282E+00,-0.45800E+00,-0.46295E+00, & + -0.46769E+00,-0.47222E+00,-0.47657E+00,-0.48073E+00,-0.48473E+00, & + -0.48858E+00,-0.49227E+00,-0.49582E+00,-0.49924E+00,-0.50253E+00, & + -0.50570E+00,-0.50875E+00,-0.51169E+00,-0.51453E+00,-0.51726E+00, & + -0.51990E+00,-0.52245E+00,-0.52490E+00,-0.52727E+00,-0.52956E+00, & + -0.53177E+00,-0.53391E+00,-0.53597E+00,-0.53796E+00,-0.53988E+00, & + -0.54174E+00,-0.54353E+00,-0.54527E+00,-0.54694E+00,-0.54856E+00, & + -0.55013E+00,-0.55164E+00,-0.55310E+00,-0.55451E+00,-0.55588E+00, & + -0.55720E+00,-0.55847E+00,-0.55970E+00,-0.56089E+00,-0.56204E+00, & + -0.56315E+00,-0.56422E+00,-0.56526E+00,-0.56625E+00,-0.56722E+00, & + -0.56815E+00,-0.56904E+00,-0.56991E+00,-0.57074E+00,-0.57154E+00, & + -0.57231E+00,-0.57305E+00,-0.57377E+00,-0.57445E+00,-0.57511E+00, & + -0.57574E+00,-0.57635E+00,-0.57693E+00,-0.57748E+00,-0.57802E+00, & + -0.57852E+00,-0.57900E+00,-0.57946E+00,-0.57990E+00,-0.58032E+00, & + -0.58071E+00,-0.58108E+00,-0.58143E+00,-0.58176E+00,-0.58208E+00, & + -0.58237E+00,-0.58264E+00,-0.58290E+00,-0.58314E+00,-0.58336E+00/ + + DATA (BNC13M (I),I=101,200)/ & + -0.58356E+00,-0.58375E+00,-0.58392E+00,-0.58408E+00,-0.58422E+00, & + -0.58435E+00,-0.58447E+00,-0.58457E+00,-0.58466E+00,-0.58473E+00, & + -0.58480E+00,-0.58485E+00,-0.58489E+00,-0.58492E+00,-0.58494E+00, & + -0.58495E+00,-0.58496E+00,-0.58495E+00,-0.58493E+00,-0.58491E+00, & + -0.58498E+00,-0.58493E+00,-0.58487E+00,-0.58481E+00,-0.58474E+00, & + -0.58467E+00,-0.58459E+00,-0.58450E+00,-0.58441E+00,-0.58432E+00, & + -0.58422E+00,-0.58412E+00,-0.58401E+00,-0.58390E+00,-0.58379E+00, & + -0.58367E+00,-0.58355E+00,-0.58342E+00,-0.58330E+00,-0.58316E+00, & + -0.58303E+00,-0.58289E+00,-0.58275E+00,-0.58261E+00,-0.58246E+00, & + -0.58232E+00,-0.58217E+00,-0.58201E+00,-0.58186E+00,-0.58170E+00, & + -0.58154E+00,-0.58138E+00,-0.58122E+00,-0.58106E+00,-0.58089E+00, & + -0.58072E+00,-0.58056E+00,-0.58039E+00,-0.58021E+00,-0.58004E+00, & + -0.57987E+00,-0.57969E+00,-0.57951E+00,-0.57934E+00,-0.57916E+00, & + -0.57898E+00,-0.57880E+00,-0.57862E+00,-0.57844E+00,-0.57825E+00, & + -0.57807E+00,-0.57789E+00,-0.57770E+00,-0.57752E+00,-0.57733E+00, & + -0.57715E+00,-0.57696E+00,-0.57677E+00,-0.57658E+00,-0.57640E+00, & + -0.57621E+00,-0.57602E+00,-0.57583E+00,-0.57564E+00,-0.57546E+00, & + -0.57527E+00,-0.57508E+00,-0.57489E+00,-0.57470E+00,-0.57451E+00, & + -0.57432E+00,-0.57413E+00,-0.57394E+00,-0.57375E+00,-0.57356E+00, & + -0.57338E+00,-0.57319E+00,-0.57300E+00,-0.57281E+00,-0.57262E+00/ + + DATA (BNC13M (I),I=201,300)/ & + -0.57243E+00,-0.57225E+00,-0.57206E+00,-0.57187E+00,-0.57168E+00, & + -0.57150E+00,-0.57131E+00,-0.57112E+00,-0.57094E+00,-0.57075E+00, & + -0.57057E+00,-0.57038E+00,-0.57020E+00,-0.57002E+00,-0.56983E+00, & + -0.56965E+00,-0.56947E+00,-0.56928E+00,-0.56910E+00,-0.56892E+00, & + -0.56874E+00,-0.56856E+00,-0.56838E+00,-0.56820E+00,-0.56802E+00, & + -0.56784E+00,-0.56766E+00,-0.56749E+00,-0.56731E+00,-0.56713E+00, & + -0.56696E+00,-0.56678E+00,-0.56661E+00,-0.56643E+00,-0.56626E+00, & + -0.56609E+00,-0.56591E+00,-0.56574E+00,-0.56557E+00,-0.56540E+00, & + -0.56523E+00,-0.56506E+00,-0.56489E+00,-0.56472E+00,-0.56456E+00, & + -0.56439E+00,-0.56422E+00,-0.56406E+00,-0.56389E+00,-0.56373E+00, & + -0.56356E+00,-0.56340E+00,-0.56324E+00,-0.56308E+00,-0.56292E+00, & + -0.56276E+00,-0.56260E+00,-0.56244E+00,-0.56228E+00,-0.56212E+00, & + -0.56196E+00,-0.56181E+00,-0.56165E+00,-0.56150E+00,-0.56134E+00, & + -0.56119E+00,-0.56103E+00,-0.56088E+00,-0.56073E+00,-0.56058E+00, & + -0.56043E+00,-0.56028E+00,-0.56013E+00,-0.55998E+00,-0.55983E+00, & + -0.55969E+00,-0.55954E+00,-0.55940E+00,-0.55925E+00,-0.55911E+00, & + -0.55896E+00,-0.55882E+00,-0.55868E+00,-0.55854E+00,-0.55840E+00, & + -0.55826E+00,-0.55812E+00,-0.55798E+00,-0.55784E+00,-0.55770E+00, & + -0.55757E+00,-0.55743E+00,-0.55730E+00,-0.55716E+00,-0.55703E+00, & + -0.55690E+00,-0.55676E+00,-0.55663E+00,-0.55650E+00,-0.55637E+00/ + + DATA (BNC13M (I),I=301,400)/ & + -0.55624E+00,-0.55611E+00,-0.55599E+00,-0.55586E+00,-0.55573E+00, & + -0.55561E+00,-0.55548E+00,-0.55536E+00,-0.55523E+00,-0.55511E+00, & + -0.55499E+00,-0.55487E+00,-0.55475E+00,-0.55463E+00,-0.55451E+00, & + -0.55439E+00,-0.55427E+00,-0.55415E+00,-0.55404E+00,-0.55392E+00, & + -0.55380E+00,-0.55369E+00,-0.55358E+00,-0.55346E+00,-0.55335E+00, & + -0.55324E+00,-0.55313E+00,-0.55302E+00,-0.55291E+00,-0.55280E+00, & + -0.55269E+00,-0.55258E+00,-0.55248E+00,-0.55237E+00,-0.55226E+00, & + -0.55216E+00,-0.55206E+00,-0.55195E+00,-0.55185E+00,-0.55175E+00, & + -0.55165E+00,-0.55155E+00,-0.55145E+00,-0.55135E+00,-0.55125E+00, & + -0.55115E+00,-0.55105E+00,-0.55096E+00,-0.55086E+00,-0.55077E+00, & + -0.55067E+00,-0.55058E+00,-0.55048E+00,-0.55039E+00,-0.55030E+00, & + -0.55021E+00,-0.55012E+00,-0.55003E+00,-0.54994E+00,-0.54985E+00, & + -0.54976E+00,-0.54968E+00,-0.54959E+00,-0.54951E+00,-0.54942E+00, & + -0.54934E+00,-0.54925E+00,-0.54917E+00,-0.54909E+00,-0.54900E+00, & + -0.54892E+00,-0.54884E+00,-0.54876E+00,-0.54868E+00,-0.54861E+00, & + -0.54853E+00,-0.54845E+00,-0.54838E+00,-0.54830E+00,-0.54822E+00, & + -0.54815E+00,-0.54808E+00,-0.54800E+00,-0.54793E+00,-0.54786E+00, & + -0.54779E+00,-0.54772E+00,-0.54765E+00,-0.54758E+00,-0.54751E+00, & + -0.54744E+00,-0.54737E+00,-0.54731E+00,-0.54724E+00,-0.54717E+00, & + -0.54711E+00,-0.54705E+00,-0.54698E+00,-0.54692E+00,-0.54686E+00/ + + DATA (BNC13M (I),I=401,500)/ & + -0.54679E+00,-0.54673E+00,-0.54667E+00,-0.54661E+00,-0.54655E+00, & + -0.54650E+00,-0.54644E+00,-0.54638E+00,-0.54632E+00,-0.54627E+00, & + -0.54621E+00,-0.54616E+00,-0.54610E+00,-0.54605E+00,-0.54600E+00, & + -0.54594E+00,-0.54589E+00,-0.54584E+00,-0.54579E+00,-0.54574E+00, & + -0.54569E+00,-0.54564E+00,-0.54559E+00,-0.54555E+00,-0.54550E+00, & + -0.54545E+00,-0.54541E+00,-0.54536E+00,-0.54532E+00,-0.54527E+00, & + -0.54523E+00,-0.54519E+00,-0.54515E+00,-0.54510E+00,-0.54506E+00, & + -0.54502E+00,-0.54498E+00,-0.54494E+00,-0.54491E+00,-0.54487E+00, & + -0.54483E+00,-0.54479E+00,-0.54476E+00,-0.54472E+00,-0.54469E+00, & + -0.54465E+00,-0.54462E+00,-0.54458E+00,-0.54455E+00,-0.54452E+00, & + -0.54449E+00,-0.54446E+00,-0.54443E+00,-0.54440E+00,-0.54437E+00, & + -0.54434E+00,-0.54431E+00,-0.54428E+00,-0.54426E+00,-0.54423E+00, & + -0.54420E+00,-0.54418E+00,-0.54415E+00,-0.54413E+00,-0.54411E+00, & + -0.54408E+00,-0.54406E+00,-0.54404E+00,-0.54402E+00,-0.54400E+00, & + -0.54397E+00,-0.54395E+00,-0.54394E+00,-0.54392E+00,-0.54390E+00, & + -0.54388E+00,-0.54386E+00,-0.54385E+00,-0.54383E+00,-0.54382E+00, & + -0.54380E+00,-0.54379E+00,-0.54377E+00,-0.54376E+00,-0.54375E+00, & + -0.54373E+00,-0.54372E+00,-0.54371E+00,-0.54370E+00,-0.54369E+00, & + -0.54368E+00,-0.54367E+00,-0.54366E+00,-0.54366E+00,-0.54365E+00, & + -0.54364E+00,-0.54364E+00,-0.54363E+00,-0.54362E+00,-0.54362E+00/ + + DATA (BNC13M (I),I=501,600)/ & + -0.54362E+00,-0.54361E+00,-0.54361E+00,-0.54361E+00,-0.54360E+00, & + -0.54360E+00,-0.54360E+00,-0.54360E+00,-0.54360E+00,-0.54360E+00, & + -0.54360E+00,-0.54360E+00,-0.54360E+00,-0.54361E+00,-0.54361E+00, & + -0.54361E+00,-0.54362E+00,-0.54362E+00,-0.54363E+00,-0.54363E+00, & + -0.54364E+00,-0.54365E+00,-0.54365E+00,-0.54366E+00,-0.54367E+00, & + -0.54368E+00,-0.54369E+00,-0.54369E+00,-0.54370E+00,-0.54371E+00, & + -0.54373E+00,-0.54374E+00,-0.54375E+00,-0.54376E+00,-0.54377E+00, & + -0.54379E+00,-0.54380E+00,-0.54382E+00,-0.54383E+00,-0.54385E+00, & + -0.54386E+00,-0.54388E+00,-0.54390E+00,-0.54391E+00,-0.54393E+00, & + -0.54395E+00,-0.54397E+00,-0.54399E+00,-0.54401E+00,-0.54403E+00, & + -0.54405E+00,-0.54407E+00,-0.54409E+00,-0.54411E+00,-0.54413E+00, & + -0.54416E+00,-0.54418E+00,-0.54420E+00,-0.54423E+00,-0.54425E+00, & + -0.54428E+00,-0.54430E+00,-0.54433E+00,-0.54436E+00,-0.54438E+00, & + -0.54441E+00,-0.54444E+00,-0.54447E+00,-0.54450E+00,-0.54453E+00, & + -0.54456E+00,-0.54459E+00,-0.54462E+00,-0.54465E+00,-0.54468E+00, & + -0.54471E+00,-0.54475E+00,-0.54478E+00,-0.54481E+00,-0.54485E+00, & + -0.54488E+00,-0.54492E+00,-0.54495E+00,-0.54499E+00,-0.54502E+00, & + -0.54506E+00,-0.54510E+00,-0.54513E+00,-0.54517E+00,-0.54521E+00, & + -0.54525E+00,-0.54529E+00,-0.54533E+00,-0.54537E+00,-0.54541E+00, & + -0.54545E+00,-0.54549E+00,-0.54553E+00,-0.54558E+00,-0.54574E+00/ + + DATA (BNC13M (I),I=601,700)/ & + -0.54612E+00,-0.54661E+00,-0.54715E+00,-0.54773E+00,-0.54835E+00, & + -0.54901E+00,-0.54971E+00,-0.55044E+00,-0.55121E+00,-0.55202E+00, & + -0.55286E+00,-0.55374E+00,-0.55466E+00,-0.55560E+00,-0.55658E+00, & + -0.55760E+00,-0.55864E+00,-0.55972E+00,-0.56083E+00,-0.56196E+00, & + -0.56313E+00,-0.56433E+00,-0.56556E+00,-0.56681E+00,-0.56809E+00, & + -0.56940E+00,-0.57074E+00,-0.57210E+00,-0.57349E+00,-0.57491E+00, & + -0.57635E+00,-0.57782E+00,-0.57931E+00,-0.58082E+00,-0.58236E+00, & + -0.58392E+00,-0.58551E+00,-0.58712E+00,-0.58875E+00,-0.59040E+00, & + -0.59207E+00,-0.59377E+00,-0.59549E+00,-0.59722E+00,-0.59898E+00, & + -0.60076E+00,-0.60256E+00,-0.60438E+00,-0.60621E+00,-0.60807E+00, & + -0.60994E+00,-0.61183E+00,-0.61375E+00,-0.61567E+00,-0.61762E+00, & + -0.61959E+00,-0.62157E+00,-0.62357E+00,-0.62558E+00,-0.62761E+00, & + -0.62966E+00,-0.63173E+00,-0.63381E+00,-0.63590E+00,-0.63801E+00, & + -0.64014E+00,-0.64228E+00,-0.64444E+00,-0.64661E+00,-0.64879E+00, & + -0.65099E+00,-0.65321E+00,-0.65544E+00,-0.65768E+00,-0.65993E+00, & + -0.66220E+00,-0.66448E+00,-0.66678E+00,-0.66909E+00,-0.67141E+00, & + -0.67374E+00,-0.67609E+00,-0.67845E+00,-0.68082E+00,-0.68320E+00, & + -0.68560E+00,-0.68800E+00,-0.69042E+00,-0.69285E+00,-0.69529E+00, & + -0.69774E+00,-0.70021E+00,-0.70268E+00,-0.70516E+00,-0.70766E+00, & + -0.71017E+00,-0.71268E+00,-0.71521E+00,-0.71775E+00,-0.72030E+00/ + + DATA (BNC13M(I),I=701,741)/ & + -0.72285E+00,-0.72542E+00,-0.72800E+00,-0.73059E+00,-0.73318E+00, & + -0.73579E+00,-0.73840E+00,-0.74103E+00,-0.74366E+00,-0.74631E+00, & + -0.74896E+00,-0.75162E+00,-0.75429E+00,-0.75697E+00,-0.75966E+00, & + -0.76235E+00,-0.76505E+00,-0.76777E+00,-0.77049E+00,-0.77322E+00, & + -0.77595E+00,-0.77870E+00,-0.78145E+00,-0.78421E+00,-0.78698E+00, & + -0.78976E+00,-0.79254E+00,-0.79534E+00,-0.79814E+00,-0.80094E+00, & + -0.80376E+00,-0.80658E+00,-0.80941E+00,-0.81224E+00,-0.81509E+00, & + -0.81794E+00,-0.82079E+00,-0.82366E+00,-0.82653E+00,-0.82940E+00, & + -0.83229E+00 & + / + END Module KMC248 diff --git a/wrfv2_fire/chem/module_data_isrpia_kmc273.F b/wrfv2_fire/chem/module_data_isrpia_kmc273.F new file mode 100755 index 00000000..667d58a9 --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_kmc273.F @@ -0,0 +1,2193 @@ + + MODULE kmc273 + DOUBLE PRECISION :: & + BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & + BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & + BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & + BNC13M( 741) + +! +! *** NaCl +! + DATA (BNC01M (I),I= 1,100)/ & + -0.51181E-01,-0.90341E-01,-0.11577E+00,-0.13175E+00,-0.14316E+00, & + -0.15182E+00,-0.15860E+00,-0.16404E+00,-0.16845E+00,-0.17205E+00, & + -0.17501E+00,-0.17742E+00,-0.17939E+00,-0.18097E+00,-0.18222E+00, & + -0.18320E+00,-0.18392E+00,-0.18442E+00,-0.18473E+00,-0.18487E+00, & + -0.18485E+00,-0.18470E+00,-0.18442E+00,-0.18402E+00,-0.18353E+00, & + -0.18294E+00,-0.18227E+00,-0.18153E+00,-0.18071E+00,-0.17983E+00, & + -0.17889E+00,-0.17790E+00,-0.17686E+00,-0.17578E+00,-0.17466E+00, & + -0.17350E+00,-0.17231E+00,-0.17109E+00,-0.16984E+00,-0.16856E+00, & + -0.16726E+00,-0.16594E+00,-0.16461E+00,-0.16325E+00,-0.16188E+00, & + -0.16050E+00,-0.15910E+00,-0.15769E+00,-0.15627E+00,-0.15484E+00, & + -0.15340E+00,-0.15196E+00,-0.15050E+00,-0.14904E+00,-0.14757E+00, & + -0.14610E+00,-0.14462E+00,-0.14313E+00,-0.14164E+00,-0.14014E+00, & + -0.13863E+00,-0.13712E+00,-0.13560E+00,-0.13408E+00,-0.13255E+00, & + -0.13101E+00,-0.12947E+00,-0.12792E+00,-0.12636E+00,-0.12479E+00, & + -0.12321E+00,-0.12163E+00,-0.12003E+00,-0.11843E+00,-0.11681E+00, & + -0.11518E+00,-0.11355E+00,-0.11189E+00,-0.11023E+00,-0.10856E+00, & + -0.10687E+00,-0.10517E+00,-0.10346E+00,-0.10173E+00,-0.99989E-01, & + -0.98234E-01,-0.96465E-01,-0.94683E-01,-0.92886E-01,-0.91075E-01, & + -0.89250E-01,-0.87411E-01,-0.85558E-01,-0.83692E-01,-0.81812E-01, & + -0.79919E-01,-0.78013E-01,-0.76094E-01,-0.74163E-01,-0.72220E-01/ + + DATA (BNC01M (I),I=101,200)/ & + -0.70265E-01,-0.68299E-01,-0.66323E-01,-0.64335E-01,-0.62338E-01, & + -0.60331E-01,-0.58315E-01,-0.56291E-01,-0.54258E-01,-0.52218E-01, & + -0.50171E-01,-0.48116E-01,-0.46056E-01,-0.43989E-01,-0.41917E-01, & + -0.39840E-01,-0.37759E-01,-0.35673E-01,-0.33583E-01,-0.31490E-01, & + -0.29641E-01,-0.27514E-01,-0.25387E-01,-0.23261E-01,-0.21135E-01, & + -0.19010E-01,-0.16886E-01,-0.14763E-01,-0.12640E-01,-0.10519E-01, & + -0.83981E-02,-0.62786E-02,-0.41603E-02,-0.20431E-02, 0.72873E-04, & + 0.21874E-02, 0.43007E-02, 0.64126E-02, 0.85231E-02, 0.10632E-01, & + 0.12740E-01, 0.14845E-01, 0.16950E-01, 0.19052E-01, 0.21153E-01, & + 0.23252E-01, 0.25350E-01, 0.27446E-01, 0.29539E-01, 0.31631E-01, & + 0.33721E-01, 0.35809E-01, 0.37895E-01, 0.39979E-01, 0.42061E-01, & + 0.44141E-01, 0.46219E-01, 0.48295E-01, 0.50369E-01, 0.52440E-01, & + 0.54509E-01, 0.56576E-01, 0.58641E-01, 0.60703E-01, 0.62764E-01, & + 0.64821E-01, 0.66877E-01, 0.68930E-01, 0.70981E-01, 0.73029E-01, & + 0.75075E-01, 0.77119E-01, 0.79160E-01, 0.81199E-01, 0.83235E-01, & + 0.85268E-01, 0.87299E-01, 0.89328E-01, 0.91354E-01, 0.93378E-01, & + 0.95399E-01, 0.97417E-01, 0.99433E-01, 0.10145E+00, 0.10346E+00, & + 0.10546E+00, 0.10747E+00, 0.10947E+00, 0.11147E+00, 0.11347E+00, & + 0.11546E+00, 0.11746E+00, 0.11944E+00, 0.12143E+00, 0.12341E+00, & + 0.12540E+00, 0.12737E+00, 0.12935E+00, 0.13132E+00, 0.13329E+00/ + + DATA (BNC01M (I),I=201,300)/ & + 0.13526E+00, 0.13722E+00, 0.13919E+00, 0.14114E+00, 0.14310E+00, & + 0.14505E+00, 0.14700E+00, 0.14895E+00, 0.15090E+00, 0.15284E+00, & + 0.15478E+00, 0.15671E+00, 0.15865E+00, 0.16058E+00, 0.16251E+00, & + 0.16443E+00, 0.16635E+00, 0.16827E+00, 0.17019E+00, 0.17210E+00, & + 0.17402E+00, 0.17592E+00, 0.17783E+00, 0.17973E+00, 0.18163E+00, & + 0.18353E+00, 0.18542E+00, 0.18731E+00, 0.18920E+00, 0.19109E+00, & + 0.19297E+00, 0.19485E+00, 0.19672E+00, 0.19860E+00, 0.20047E+00, & + 0.20234E+00, 0.20420E+00, 0.20606E+00, 0.20792E+00, 0.20978E+00, & + 0.21164E+00, 0.21349E+00, 0.21533E+00, 0.21718E+00, 0.21902E+00, & + 0.22086E+00, 0.22270E+00, 0.22453E+00, 0.22636E+00, 0.22819E+00, & + 0.23002E+00, 0.23184E+00, 0.23366E+00, 0.23548E+00, 0.23729E+00, & + 0.23910E+00, 0.24091E+00, 0.24272E+00, 0.24452E+00, 0.24632E+00, & + 0.24812E+00, 0.24991E+00, 0.25170E+00, 0.25349E+00, 0.25528E+00, & + 0.25706E+00, 0.25884E+00, 0.26062E+00, 0.26239E+00, 0.26417E+00, & + 0.26594E+00, 0.26770E+00, 0.26947E+00, 0.27123E+00, 0.27299E+00, & + 0.27474E+00, 0.27649E+00, 0.27824E+00, 0.27999E+00, 0.28173E+00, & + 0.28348E+00, 0.28522E+00, 0.28695E+00, 0.28869E+00, 0.29042E+00, & + 0.29214E+00, 0.29387E+00, 0.29559E+00, 0.29731E+00, 0.29903E+00, & + 0.30074E+00, 0.30245E+00, 0.30416E+00, 0.30587E+00, 0.30757E+00, & + 0.30927E+00, 0.31097E+00, 0.31267E+00, 0.31436E+00, 0.31605E+00/ + + DATA (BNC01M (I),I=301,400)/ & + 0.31774E+00, 0.31942E+00, 0.32111E+00, 0.32279E+00, 0.32446E+00, & + 0.32614E+00, 0.32781E+00, 0.32948E+00, 0.33115E+00, 0.33281E+00, & + 0.33447E+00, 0.33613E+00, 0.33779E+00, 0.33944E+00, 0.34109E+00, & + 0.34274E+00, 0.34438E+00, 0.34603E+00, 0.34767E+00, 0.34930E+00, & + 0.35094E+00, 0.35257E+00, 0.35420E+00, 0.35583E+00, 0.35746E+00, & + 0.35908E+00, 0.36070E+00, 0.36232E+00, 0.36393E+00, 0.36554E+00, & + 0.36715E+00, 0.36876E+00, 0.37037E+00, 0.37197E+00, 0.37357E+00, & + 0.37517E+00, 0.37676E+00, 0.37835E+00, 0.37994E+00, 0.38153E+00, & + 0.38312E+00, 0.38470E+00, 0.38628E+00, 0.38786E+00, 0.38943E+00, & + 0.39100E+00, 0.39257E+00, 0.39414E+00, 0.39571E+00, 0.39727E+00, & + 0.39883E+00, 0.40039E+00, 0.40195E+00, 0.40350E+00, 0.40505E+00, & + 0.40660E+00, 0.40814E+00, 0.40969E+00, 0.41123E+00, 0.41277E+00, & + 0.41431E+00, 0.41584E+00, 0.41737E+00, 0.41890E+00, 0.42043E+00, & + 0.42195E+00, 0.42348E+00, 0.42500E+00, 0.42651E+00, 0.42803E+00, & + 0.42954E+00, 0.43105E+00, 0.43256E+00, 0.43407E+00, 0.43557E+00, & + 0.43707E+00, 0.43857E+00, 0.44007E+00, 0.44157E+00, 0.44306E+00, & + 0.44455E+00, 0.44604E+00, 0.44752E+00, 0.44901E+00, 0.45049E+00, & + 0.45197E+00, 0.45344E+00, 0.45492E+00, 0.45639E+00, 0.45786E+00, & + 0.45933E+00, 0.46079E+00, 0.46226E+00, 0.46372E+00, 0.46518E+00, & + 0.46664E+00, 0.46809E+00, 0.46954E+00, 0.47099E+00, 0.47244E+00/ + + DATA (BNC01M (I),I=401,500)/ & + 0.47389E+00, 0.47533E+00, 0.47677E+00, 0.47821E+00, 0.47965E+00, & + 0.48108E+00, 0.48252E+00, 0.48395E+00, 0.48538E+00, 0.48680E+00, & + 0.48823E+00, 0.48965E+00, 0.49107E+00, 0.49249E+00, 0.49391E+00, & + 0.49532E+00, 0.49673E+00, 0.49814E+00, 0.49955E+00, 0.50095E+00, & + 0.50236E+00, 0.50376E+00, 0.50516E+00, 0.50656E+00, 0.50795E+00, & + 0.50934E+00, 0.51074E+00, 0.51213E+00, 0.51351E+00, 0.51490E+00, & + 0.51628E+00, 0.51766E+00, 0.51904E+00, 0.52042E+00, 0.52179E+00, & + 0.52317E+00, 0.52454E+00, 0.52591E+00, 0.52727E+00, 0.52864E+00, & + 0.53000E+00, 0.53136E+00, 0.53272E+00, 0.53408E+00, 0.53543E+00, & + 0.53678E+00, 0.53814E+00, 0.53949E+00, 0.54083E+00, 0.54218E+00, & + 0.54352E+00, 0.54486E+00, 0.54620E+00, 0.54754E+00, 0.54888E+00, & + 0.55021E+00, 0.55154E+00, 0.55287E+00, 0.55420E+00, 0.55552E+00, & + 0.55685E+00, 0.55817E+00, 0.55949E+00, 0.56081E+00, 0.56213E+00, & + 0.56344E+00, 0.56475E+00, 0.56606E+00, 0.56737E+00, 0.56868E+00, & + 0.56999E+00, 0.57129E+00, 0.57259E+00, 0.57389E+00, 0.57519E+00, & + 0.57649E+00, 0.57778E+00, 0.57907E+00, 0.58036E+00, 0.58165E+00, & + 0.58294E+00, 0.58422E+00, 0.58551E+00, 0.58679E+00, 0.58807E+00, & + 0.58935E+00, 0.59062E+00, 0.59190E+00, 0.59317E+00, 0.59444E+00, & + 0.59571E+00, 0.59698E+00, 0.59824E+00, 0.59951E+00, 0.60077E+00, & + 0.60203E+00, 0.60329E+00, 0.60454E+00, 0.60580E+00, 0.60705E+00/ + + DATA (BNC01M (I),I=501,600)/ & + 0.60830E+00, 0.60955E+00, 0.61080E+00, 0.61205E+00, 0.61329E+00, & + 0.61454E+00, 0.61578E+00, 0.61702E+00, 0.61825E+00, 0.61949E+00, & + 0.62072E+00, 0.62196E+00, 0.62319E+00, 0.62442E+00, 0.62565E+00, & + 0.62687E+00, 0.62810E+00, 0.62932E+00, 0.63054E+00, 0.63176E+00, & + 0.63298E+00, 0.63419E+00, 0.63541E+00, 0.63662E+00, 0.63783E+00, & + 0.63904E+00, 0.64025E+00, 0.64145E+00, 0.64266E+00, 0.64386E+00, & + 0.64506E+00, 0.64626E+00, 0.64746E+00, 0.64866E+00, 0.64985E+00, & + 0.65104E+00, 0.65223E+00, 0.65342E+00, 0.65461E+00, 0.65580E+00, & + 0.65698E+00, 0.65817E+00, 0.65935E+00, 0.66053E+00, 0.66171E+00, & + 0.66289E+00, 0.66406E+00, 0.66524E+00, 0.66641E+00, 0.66758E+00, & + 0.66875E+00, 0.66992E+00, 0.67108E+00, 0.67225E+00, 0.67341E+00, & + 0.67457E+00, 0.67573E+00, 0.67689E+00, 0.67805E+00, 0.67920E+00, & + 0.68036E+00, 0.68151E+00, 0.68266E+00, 0.68381E+00, 0.68496E+00, & + 0.68610E+00, 0.68725E+00, 0.68839E+00, 0.68953E+00, 0.69068E+00, & + 0.69181E+00, 0.69295E+00, 0.69409E+00, 0.69522E+00, 0.69636E+00, & + 0.69749E+00, 0.69862E+00, 0.69975E+00, 0.70087E+00, 0.70200E+00, & + 0.70312E+00, 0.70425E+00, 0.70537E+00, 0.70649E+00, 0.70760E+00, & + 0.70872E+00, 0.70984E+00, 0.71095E+00, 0.71206E+00, 0.71317E+00, & + 0.71428E+00, 0.71539E+00, 0.71650E+00, 0.71761E+00, 0.71871E+00, & + 0.71981E+00, 0.72091E+00, 0.72201E+00, 0.72311E+00, 0.72722E+00/ + + DATA (BNC01M (I),I=601,700)/ & + 0.73618E+00, 0.74693E+00, 0.75754E+00, 0.76801E+00, 0.77836E+00, & + 0.78859E+00, 0.79869E+00, 0.80867E+00, 0.81853E+00, 0.82827E+00, & + 0.83790E+00, 0.84742E+00, 0.85682E+00, 0.86613E+00, 0.87532E+00, & + 0.88441E+00, 0.89340E+00, 0.90229E+00, 0.91108E+00, 0.91978E+00, & + 0.92838E+00, 0.93688E+00, 0.94530E+00, 0.95363E+00, 0.96187E+00, & + 0.97002E+00, 0.97808E+00, 0.98607E+00, 0.99397E+00, 0.10018E+01, & + 0.10095E+01, 0.10172E+01, 0.10248E+01, 0.10323E+01, 0.10397E+01, & + 0.10471E+01, 0.10544E+01, 0.10616E+01, 0.10688E+01, 0.10758E+01, & + 0.10828E+01, 0.10898E+01, 0.10967E+01, 0.11035E+01, 0.11102E+01, & + 0.11169E+01, 0.11236E+01, 0.11301E+01, 0.11366E+01, 0.11431E+01, & + 0.11495E+01, 0.11558E+01, 0.11621E+01, 0.11683E+01, 0.11745E+01, & + 0.11806E+01, 0.11867E+01, 0.11927E+01, 0.11986E+01, 0.12045E+01, & + 0.12104E+01, 0.12162E+01, 0.12220E+01, 0.12277E+01, 0.12333E+01, & + 0.12389E+01, 0.12445E+01, 0.12500E+01, 0.12555E+01, 0.12609E+01, & + 0.12663E+01, 0.12717E+01, 0.12770E+01, 0.12822E+01, 0.12874E+01, & + 0.12926E+01, 0.12977E+01, 0.13028E+01, 0.13079E+01, 0.13129E+01, & + 0.13179E+01, 0.13228E+01, 0.13277E+01, 0.13325E+01, 0.13374E+01, & + 0.13421E+01, 0.13469E+01, 0.13516E+01, 0.13563E+01, 0.13609E+01, & + 0.13655E+01, 0.13701E+01, 0.13746E+01, 0.13792E+01, 0.13836E+01, & + 0.13881E+01, 0.13925E+01, 0.13968E+01, 0.14012E+01, 0.14055E+01/ + + DATA (BNC01M(I),I=701,741)/ & + 0.14098E+01, 0.14140E+01, 0.14183E+01, 0.14224E+01, 0.14266E+01, & + 0.14307E+01, 0.14348E+01, 0.14389E+01, 0.14430E+01, 0.14470E+01, & + 0.14510E+01, 0.14549E+01, 0.14589E+01, 0.14628E+01, 0.14666E+01, & + 0.14705E+01, 0.14743E+01, 0.14781E+01, 0.14819E+01, 0.14856E+01, & + 0.14894E+01, 0.14931E+01, 0.14967E+01, 0.15004E+01, 0.15040E+01, & + 0.15076E+01, 0.15112E+01, 0.15147E+01, 0.15183E+01, 0.15218E+01, & + 0.15253E+01, 0.15287E+01, 0.15322E+01, 0.15356E+01, 0.15390E+01, & + 0.15424E+01, 0.15457E+01, 0.15490E+01, 0.15524E+01, 0.15556E+01, & + 0.15589E+01 & + / +! +! *** Na2SO4 +! + DATA (BNC02M (I),I= 1,100)/ & + -0.10572E+00,-0.19298E+00,-0.25472E+00,-0.29692E+00,-0.32958E+00, & + -0.35641E+00,-0.37928E+00,-0.39926E+00,-0.41702E+00,-0.43303E+00, & + -0.44762E+00,-0.46103E+00,-0.47344E+00,-0.48500E+00,-0.49582E+00, & + -0.50599E+00,-0.51560E+00,-0.52470E+00,-0.53334E+00,-0.54158E+00, & + -0.54945E+00,-0.55698E+00,-0.56420E+00,-0.57114E+00,-0.57782E+00, & + -0.58426E+00,-0.59048E+00,-0.59649E+00,-0.60231E+00,-0.60795E+00, & + -0.61341E+00,-0.61872E+00,-0.62388E+00,-0.62890E+00,-0.63378E+00, & + -0.63854E+00,-0.64318E+00,-0.64771E+00,-0.65213E+00,-0.65644E+00, & + -0.66066E+00,-0.66479E+00,-0.66882E+00,-0.67278E+00,-0.67665E+00, & + -0.68044E+00,-0.68416E+00,-0.68780E+00,-0.69138E+00,-0.69489E+00, & + -0.69834E+00,-0.70173E+00,-0.70505E+00,-0.70833E+00,-0.71154E+00, & + -0.71471E+00,-0.71782E+00,-0.72089E+00,-0.72391E+00,-0.72688E+00, & + -0.72981E+00,-0.73269E+00,-0.73554E+00,-0.73834E+00,-0.74111E+00, & + -0.74384E+00,-0.74654E+00,-0.74920E+00,-0.75183E+00,-0.75442E+00, & + -0.75698E+00,-0.75952E+00,-0.76202E+00,-0.76450E+00,-0.76695E+00, & + -0.76937E+00,-0.77176E+00,-0.77414E+00,-0.77648E+00,-0.77881E+00, & + -0.78111E+00,-0.78339E+00,-0.78564E+00,-0.78788E+00,-0.79010E+00, & + -0.79229E+00,-0.79447E+00,-0.79663E+00,-0.79877E+00,-0.80090E+00, & + -0.80300E+00,-0.80509E+00,-0.80717E+00,-0.80922E+00,-0.81127E+00, & + -0.81329E+00,-0.81530E+00,-0.81730E+00,-0.81928E+00,-0.82125E+00/ + + DATA (BNC02M (I),I=101,200)/ & + -0.82321E+00,-0.82515E+00,-0.82707E+00,-0.82899E+00,-0.83089E+00, & + -0.83278E+00,-0.83466E+00,-0.83652E+00,-0.83837E+00,-0.84021E+00, & + -0.84204E+00,-0.84386E+00,-0.84566E+00,-0.84746E+00,-0.84924E+00, & + -0.85101E+00,-0.85277E+00,-0.85452E+00,-0.85626E+00,-0.85799E+00, & + -0.85967E+00,-0.86138E+00,-0.86309E+00,-0.86478E+00,-0.86646E+00, & + -0.86813E+00,-0.86980E+00,-0.87145E+00,-0.87309E+00,-0.87473E+00, & + -0.87635E+00,-0.87797E+00,-0.87957E+00,-0.88117E+00,-0.88276E+00, & + -0.88434E+00,-0.88591E+00,-0.88747E+00,-0.88902E+00,-0.89057E+00, & + -0.89211E+00,-0.89364E+00,-0.89516E+00,-0.89667E+00,-0.89818E+00, & + -0.89968E+00,-0.90117E+00,-0.90266E+00,-0.90413E+00,-0.90560E+00, & + -0.90707E+00,-0.90852E+00,-0.90997E+00,-0.91141E+00,-0.91285E+00, & + -0.91428E+00,-0.91570E+00,-0.91711E+00,-0.91852E+00,-0.91992E+00, & + -0.92132E+00,-0.92271E+00,-0.92410E+00,-0.92547E+00,-0.92685E+00, & + -0.92821E+00,-0.92957E+00,-0.93093E+00,-0.93228E+00,-0.93362E+00, & + -0.93496E+00,-0.93629E+00,-0.93761E+00,-0.93894E+00,-0.94025E+00, & + -0.94156E+00,-0.94287E+00,-0.94417E+00,-0.94546E+00,-0.94675E+00, & + -0.94804E+00,-0.94932E+00,-0.95059E+00,-0.95186E+00,-0.95313E+00, & + -0.95439E+00,-0.95565E+00,-0.95690E+00,-0.95815E+00,-0.95939E+00, & + -0.96063E+00,-0.96186E+00,-0.96309E+00,-0.96431E+00,-0.96553E+00, & + -0.96675E+00,-0.96796E+00,-0.96917E+00,-0.97037E+00,-0.97157E+00/ + + DATA (BNC02M (I),I=201,300)/ & + -0.97277E+00,-0.97396E+00,-0.97514E+00,-0.97633E+00,-0.97751E+00, & + -0.97868E+00,-0.97985E+00,-0.98102E+00,-0.98218E+00,-0.98334E+00, & + -0.98450E+00,-0.98565E+00,-0.98680E+00,-0.98795E+00,-0.98909E+00, & + -0.99023E+00,-0.99136E+00,-0.99249E+00,-0.99362E+00,-0.99474E+00, & + -0.99586E+00,-0.99698E+00,-0.99809E+00,-0.99920E+00,-0.10003E+01, & + -0.10014E+01,-0.10025E+01,-0.10036E+01,-0.10047E+01,-0.10058E+01, & + -0.10069E+01,-0.10080E+01,-0.10091E+01,-0.10101E+01,-0.10112E+01, & + -0.10123E+01,-0.10133E+01,-0.10144E+01,-0.10155E+01,-0.10165E+01, & + -0.10176E+01,-0.10187E+01,-0.10197E+01,-0.10208E+01,-0.10218E+01, & + -0.10228E+01,-0.10239E+01,-0.10249E+01,-0.10260E+01,-0.10270E+01, & + -0.10280E+01,-0.10291E+01,-0.10301E+01,-0.10311E+01,-0.10321E+01, & + -0.10331E+01,-0.10341E+01,-0.10352E+01,-0.10362E+01,-0.10372E+01, & + -0.10382E+01,-0.10392E+01,-0.10402E+01,-0.10412E+01,-0.10422E+01, & + -0.10432E+01,-0.10442E+01,-0.10451E+01,-0.10461E+01,-0.10471E+01, & + -0.10481E+01,-0.10491E+01,-0.10500E+01,-0.10510E+01,-0.10520E+01, & + -0.10530E+01,-0.10539E+01,-0.10549E+01,-0.10559E+01,-0.10568E+01, & + -0.10578E+01,-0.10587E+01,-0.10597E+01,-0.10606E+01,-0.10616E+01, & + -0.10625E+01,-0.10635E+01,-0.10644E+01,-0.10654E+01,-0.10663E+01, & + -0.10672E+01,-0.10682E+01,-0.10691E+01,-0.10700E+01,-0.10710E+01, & + -0.10719E+01,-0.10728E+01,-0.10737E+01,-0.10747E+01,-0.10756E+01/ + + DATA (BNC02M (I),I=301,400)/ & + -0.10765E+01,-0.10774E+01,-0.10783E+01,-0.10792E+01,-0.10801E+01, & + -0.10811E+01,-0.10820E+01,-0.10829E+01,-0.10838E+01,-0.10847E+01, & + -0.10856E+01,-0.10865E+01,-0.10874E+01,-0.10883E+01,-0.10891E+01, & + -0.10900E+01,-0.10909E+01,-0.10918E+01,-0.10927E+01,-0.10936E+01, & + -0.10945E+01,-0.10953E+01,-0.10962E+01,-0.10971E+01,-0.10980E+01, & + -0.10988E+01,-0.10997E+01,-0.11006E+01,-0.11015E+01,-0.11023E+01, & + -0.11032E+01,-0.11040E+01,-0.11049E+01,-0.11058E+01,-0.11066E+01, & + -0.11075E+01,-0.11083E+01,-0.11092E+01,-0.11101E+01,-0.11109E+01, & + -0.11118E+01,-0.11126E+01,-0.11134E+01,-0.11143E+01,-0.11151E+01, & + -0.11160E+01,-0.11168E+01,-0.11177E+01,-0.11185E+01,-0.11193E+01, & + -0.11202E+01,-0.11210E+01,-0.11218E+01,-0.11227E+01,-0.11235E+01, & + -0.11243E+01,-0.11252E+01,-0.11260E+01,-0.11268E+01,-0.11276E+01, & + -0.11284E+01,-0.11293E+01,-0.11301E+01,-0.11309E+01,-0.11317E+01, & + -0.11325E+01,-0.11333E+01,-0.11342E+01,-0.11350E+01,-0.11358E+01, & + -0.11366E+01,-0.11374E+01,-0.11382E+01,-0.11390E+01,-0.11398E+01, & + -0.11406E+01,-0.11414E+01,-0.11422E+01,-0.11430E+01,-0.11438E+01, & + -0.11446E+01,-0.11454E+01,-0.11462E+01,-0.11470E+01,-0.11478E+01, & + -0.11486E+01,-0.11493E+01,-0.11501E+01,-0.11509E+01,-0.11517E+01, & + -0.11525E+01,-0.11533E+01,-0.11541E+01,-0.11548E+01,-0.11556E+01, & + -0.11564E+01,-0.11572E+01,-0.11579E+01,-0.11587E+01,-0.11595E+01/ + + DATA (BNC02M (I),I=401,500)/ & + -0.11603E+01,-0.11610E+01,-0.11618E+01,-0.11626E+01,-0.11633E+01, & + -0.11641E+01,-0.11649E+01,-0.11656E+01,-0.11664E+01,-0.11672E+01, & + -0.11679E+01,-0.11687E+01,-0.11694E+01,-0.11702E+01,-0.11710E+01, & + -0.11717E+01,-0.11725E+01,-0.11732E+01,-0.11740E+01,-0.11747E+01, & + -0.11755E+01,-0.11762E+01,-0.11770E+01,-0.11777E+01,-0.11785E+01, & + -0.11792E+01,-0.11800E+01,-0.11807E+01,-0.11815E+01,-0.11822E+01, & + -0.11829E+01,-0.11837E+01,-0.11844E+01,-0.11852E+01,-0.11859E+01, & + -0.11866E+01,-0.11874E+01,-0.11881E+01,-0.11888E+01,-0.11896E+01, & + -0.11903E+01,-0.11910E+01,-0.11918E+01,-0.11925E+01,-0.11932E+01, & + -0.11940E+01,-0.11947E+01,-0.11954E+01,-0.11961E+01,-0.11969E+01, & + -0.11976E+01,-0.11983E+01,-0.11990E+01,-0.11997E+01,-0.12005E+01, & + -0.12012E+01,-0.12019E+01,-0.12026E+01,-0.12033E+01,-0.12040E+01, & + -0.12048E+01,-0.12055E+01,-0.12062E+01,-0.12069E+01,-0.12076E+01, & + -0.12083E+01,-0.12090E+01,-0.12097E+01,-0.12104E+01,-0.12111E+01, & + -0.12118E+01,-0.12126E+01,-0.12133E+01,-0.12140E+01,-0.12147E+01, & + -0.12154E+01,-0.12161E+01,-0.12168E+01,-0.12175E+01,-0.12182E+01, & + -0.12189E+01,-0.12196E+01,-0.12203E+01,-0.12209E+01,-0.12216E+01, & + -0.12223E+01,-0.12230E+01,-0.12237E+01,-0.12244E+01,-0.12251E+01, & + -0.12258E+01,-0.12265E+01,-0.12272E+01,-0.12279E+01,-0.12285E+01, & + -0.12292E+01,-0.12299E+01,-0.12306E+01,-0.12313E+01,-0.12320E+01/ + + DATA (BNC02M (I),I=501,600)/ & + -0.12327E+01,-0.12333E+01,-0.12340E+01,-0.12347E+01,-0.12354E+01, & + -0.12361E+01,-0.12367E+01,-0.12374E+01,-0.12381E+01,-0.12388E+01, & + -0.12394E+01,-0.12401E+01,-0.12408E+01,-0.12415E+01,-0.12421E+01, & + -0.12428E+01,-0.12435E+01,-0.12441E+01,-0.12448E+01,-0.12455E+01, & + -0.12462E+01,-0.12468E+01,-0.12475E+01,-0.12482E+01,-0.12488E+01, & + -0.12495E+01,-0.12501E+01,-0.12508E+01,-0.12515E+01,-0.12521E+01, & + -0.12528E+01,-0.12535E+01,-0.12541E+01,-0.12548E+01,-0.12554E+01, & + -0.12561E+01,-0.12568E+01,-0.12574E+01,-0.12581E+01,-0.12587E+01, & + -0.12594E+01,-0.12600E+01,-0.12607E+01,-0.12613E+01,-0.12620E+01, & + -0.12626E+01,-0.12633E+01,-0.12639E+01,-0.12646E+01,-0.12652E+01, & + -0.12659E+01,-0.12665E+01,-0.12672E+01,-0.12678E+01,-0.12685E+01, & + -0.12691E+01,-0.12698E+01,-0.12704E+01,-0.12711E+01,-0.12717E+01, & + -0.12724E+01,-0.12730E+01,-0.12736E+01,-0.12743E+01,-0.12749E+01, & + -0.12756E+01,-0.12762E+01,-0.12768E+01,-0.12775E+01,-0.12781E+01, & + -0.12788E+01,-0.12794E+01,-0.12800E+01,-0.12807E+01,-0.12813E+01, & + -0.12819E+01,-0.12826E+01,-0.12832E+01,-0.12838E+01,-0.12845E+01, & + -0.12851E+01,-0.12857E+01,-0.12864E+01,-0.12870E+01,-0.12876E+01, & + -0.12882E+01,-0.12889E+01,-0.12895E+01,-0.12901E+01,-0.12908E+01, & + -0.12914E+01,-0.12920E+01,-0.12926E+01,-0.12933E+01,-0.12939E+01, & + -0.12945E+01,-0.12951E+01,-0.12957E+01,-0.12964E+01,-0.12987E+01/ + + DATA (BNC02M (I),I=601,700)/ & + -0.13038E+01,-0.13099E+01,-0.13160E+01,-0.13220E+01,-0.13280E+01, & + -0.13340E+01,-0.13399E+01,-0.13457E+01,-0.13515E+01,-0.13573E+01, & + -0.13631E+01,-0.13688E+01,-0.13744E+01,-0.13801E+01,-0.13856E+01, & + -0.13912E+01,-0.13967E+01,-0.14022E+01,-0.14077E+01,-0.14131E+01, & + -0.14185E+01,-0.14239E+01,-0.14292E+01,-0.14345E+01,-0.14398E+01, & + -0.14451E+01,-0.14503E+01,-0.14555E+01,-0.14607E+01,-0.14659E+01, & + -0.14710E+01,-0.14761E+01,-0.14812E+01,-0.14862E+01,-0.14913E+01, & + -0.14963E+01,-0.15013E+01,-0.15063E+01,-0.15112E+01,-0.15161E+01, & + -0.15211E+01,-0.15260E+01,-0.15308E+01,-0.15357E+01,-0.15405E+01, & + -0.15453E+01,-0.15501E+01,-0.15549E+01,-0.15597E+01,-0.15644E+01, & + -0.15692E+01,-0.15739E+01,-0.15786E+01,-0.15833E+01,-0.15880E+01, & + -0.15926E+01,-0.15972E+01,-0.16019E+01,-0.16065E+01,-0.16111E+01, & + -0.16157E+01,-0.16202E+01,-0.16248E+01,-0.16293E+01,-0.16338E+01, & + -0.16384E+01,-0.16429E+01,-0.16473E+01,-0.16518E+01,-0.16563E+01, & + -0.16607E+01,-0.16652E+01,-0.16696E+01,-0.16740E+01,-0.16784E+01, & + -0.16828E+01,-0.16872E+01,-0.16915E+01,-0.16959E+01,-0.17003E+01, & + -0.17046E+01,-0.17089E+01,-0.17132E+01,-0.17175E+01,-0.17218E+01, & + -0.17261E+01,-0.17304E+01,-0.17347E+01,-0.17389E+01,-0.17432E+01, & + -0.17474E+01,-0.17516E+01,-0.17559E+01,-0.17601E+01,-0.17643E+01, & + -0.17685E+01,-0.17726E+01,-0.17768E+01,-0.17810E+01,-0.17851E+01/ + + DATA (BNC02M(I),I=701,741)/ & + -0.17893E+01,-0.17934E+01,-0.17976E+01,-0.18017E+01,-0.18058E+01, & + -0.18099E+01,-0.18140E+01,-0.18181E+01,-0.18222E+01,-0.18263E+01, & + -0.18304E+01,-0.18344E+01,-0.18385E+01,-0.18425E+01,-0.18466E+01, & + -0.18506E+01,-0.18547E+01,-0.18587E+01,-0.18627E+01,-0.18667E+01, & + -0.18707E+01,-0.18747E+01,-0.18787E+01,-0.18827E+01,-0.18866E+01, & + -0.18906E+01,-0.18946E+01,-0.18985E+01,-0.19025E+01,-0.19064E+01, & + -0.19104E+01,-0.19143E+01,-0.19182E+01,-0.19222E+01,-0.19261E+01, & + -0.19300E+01,-0.19339E+01,-0.19378E+01,-0.19417E+01,-0.19456E+01, & + -0.19495E+01 & + / +! +! *** NaNO3 +! + DATA (BNC03M (I),I= 1,100)/ & + -0.53018E-01,-0.97087E-01,-0.12849E+00,-0.15010E+00,-0.16692E+00, & + -0.18081E+00,-0.19271E+00,-0.20315E+00,-0.21248E+00,-0.22092E+00, & + -0.22865E+00,-0.23578E+00,-0.24240E+00,-0.24860E+00,-0.25441E+00, & + -0.25991E+00,-0.26511E+00,-0.27005E+00,-0.27476E+00,-0.27927E+00, & + -0.28358E+00,-0.28773E+00,-0.29171E+00,-0.29555E+00,-0.29926E+00, & + -0.30284E+00,-0.30631E+00,-0.30967E+00,-0.31293E+00,-0.31609E+00, & + -0.31917E+00,-0.32216E+00,-0.32508E+00,-0.32792E+00,-0.33069E+00, & + -0.33340E+00,-0.33604E+00,-0.33862E+00,-0.34115E+00,-0.34361E+00, & + -0.34603E+00,-0.34840E+00,-0.35072E+00,-0.35299E+00,-0.35522E+00, & + -0.35741E+00,-0.35956E+00,-0.36167E+00,-0.36374E+00,-0.36578E+00, & + -0.36778E+00,-0.36974E+00,-0.37168E+00,-0.37358E+00,-0.37546E+00, & + -0.37730E+00,-0.37912E+00,-0.38091E+00,-0.38268E+00,-0.38442E+00, & + -0.38613E+00,-0.38783E+00,-0.38950E+00,-0.39115E+00,-0.39278E+00, & + -0.39439E+00,-0.39597E+00,-0.39754E+00,-0.39910E+00,-0.40063E+00, & + -0.40215E+00,-0.40365E+00,-0.40514E+00,-0.40661E+00,-0.40807E+00, & + -0.40951E+00,-0.41094E+00,-0.41236E+00,-0.41376E+00,-0.41515E+00, & + -0.41653E+00,-0.41790E+00,-0.41926E+00,-0.42061E+00,-0.42194E+00, & + -0.42327E+00,-0.42459E+00,-0.42590E+00,-0.42720E+00,-0.42849E+00, & + -0.42977E+00,-0.43104E+00,-0.43231E+00,-0.43356E+00,-0.43481E+00, & + -0.43605E+00,-0.43729E+00,-0.43852E+00,-0.43974E+00,-0.44095E+00/ + + DATA (BNC03M (I),I=101,200)/ & + -0.44215E+00,-0.44335E+00,-0.44455E+00,-0.44573E+00,-0.44691E+00, & + -0.44808E+00,-0.44925E+00,-0.45041E+00,-0.45156E+00,-0.45271E+00, & + -0.45385E+00,-0.45499E+00,-0.45611E+00,-0.45724E+00,-0.45836E+00, & + -0.45947E+00,-0.46057E+00,-0.46167E+00,-0.46277E+00,-0.46385E+00, & + -0.46489E+00,-0.46597E+00,-0.46705E+00,-0.46812E+00,-0.46918E+00, & + -0.47024E+00,-0.47129E+00,-0.47234E+00,-0.47338E+00,-0.47442E+00, & + -0.47545E+00,-0.47647E+00,-0.47749E+00,-0.47850E+00,-0.47951E+00, & + -0.48052E+00,-0.48152E+00,-0.48251E+00,-0.48350E+00,-0.48448E+00, & + -0.48546E+00,-0.48644E+00,-0.48741E+00,-0.48837E+00,-0.48934E+00, & + -0.49029E+00,-0.49124E+00,-0.49219E+00,-0.49313E+00,-0.49407E+00, & + -0.49501E+00,-0.49594E+00,-0.49687E+00,-0.49779E+00,-0.49871E+00, & + -0.49962E+00,-0.50053E+00,-0.50144E+00,-0.50234E+00,-0.50324E+00, & + -0.50414E+00,-0.50503E+00,-0.50592E+00,-0.50680E+00,-0.50768E+00, & + -0.50856E+00,-0.50943E+00,-0.51030E+00,-0.51117E+00,-0.51203E+00, & + -0.51289E+00,-0.51375E+00,-0.51460E+00,-0.51545E+00,-0.51630E+00, & + -0.51714E+00,-0.51798E+00,-0.51882E+00,-0.51965E+00,-0.52048E+00, & + -0.52131E+00,-0.52213E+00,-0.52295E+00,-0.52377E+00,-0.52459E+00, & + -0.52540E+00,-0.52621E+00,-0.52702E+00,-0.52782E+00,-0.52862E+00, & + -0.52942E+00,-0.53022E+00,-0.53101E+00,-0.53180E+00,-0.53259E+00, & + -0.53337E+00,-0.53416E+00,-0.53493E+00,-0.53571E+00,-0.53649E+00/ + + DATA (BNC03M (I),I=201,300)/ & + -0.53726E+00,-0.53803E+00,-0.53879E+00,-0.53956E+00,-0.54032E+00, & + -0.54108E+00,-0.54184E+00,-0.54259E+00,-0.54334E+00,-0.54409E+00, & + -0.54484E+00,-0.54559E+00,-0.54633E+00,-0.54707E+00,-0.54781E+00, & + -0.54854E+00,-0.54928E+00,-0.55001E+00,-0.55074E+00,-0.55147E+00, & + -0.55219E+00,-0.55291E+00,-0.55363E+00,-0.55435E+00,-0.55507E+00, & + -0.55578E+00,-0.55650E+00,-0.55721E+00,-0.55791E+00,-0.55862E+00, & + -0.55932E+00,-0.56003E+00,-0.56073E+00,-0.56142E+00,-0.56212E+00, & + -0.56282E+00,-0.56351E+00,-0.56420E+00,-0.56489E+00,-0.56557E+00, & + -0.56626E+00,-0.56694E+00,-0.56762E+00,-0.56830E+00,-0.56898E+00, & + -0.56966E+00,-0.57033E+00,-0.57100E+00,-0.57167E+00,-0.57234E+00, & + -0.57301E+00,-0.57367E+00,-0.57434E+00,-0.57500E+00,-0.57566E+00, & + -0.57632E+00,-0.57697E+00,-0.57763E+00,-0.57828E+00,-0.57893E+00, & + -0.57958E+00,-0.58023E+00,-0.58088E+00,-0.58153E+00,-0.58217E+00, & + -0.58281E+00,-0.58345E+00,-0.58409E+00,-0.58473E+00,-0.58537E+00, & + -0.58600E+00,-0.58663E+00,-0.58726E+00,-0.58789E+00,-0.58852E+00, & + -0.58915E+00,-0.58978E+00,-0.59040E+00,-0.59102E+00,-0.59164E+00, & + -0.59226E+00,-0.59288E+00,-0.59350E+00,-0.59411E+00,-0.59473E+00, & + -0.59534E+00,-0.59595E+00,-0.59656E+00,-0.59717E+00,-0.59778E+00, & + -0.59838E+00,-0.59899E+00,-0.59959E+00,-0.60019E+00,-0.60079E+00, & + -0.60139E+00,-0.60199E+00,-0.60259E+00,-0.60318E+00,-0.60378E+00/ + + DATA (BNC03M (I),I=301,400)/ & + -0.60437E+00,-0.60496E+00,-0.60555E+00,-0.60614E+00,-0.60673E+00, & + -0.60732E+00,-0.60790E+00,-0.60849E+00,-0.60907E+00,-0.60965E+00, & + -0.61023E+00,-0.61081E+00,-0.61139E+00,-0.61197E+00,-0.61254E+00, & + -0.61312E+00,-0.61369E+00,-0.61426E+00,-0.61484E+00,-0.61541E+00, & + -0.61597E+00,-0.61654E+00,-0.61711E+00,-0.61767E+00,-0.61824E+00, & + -0.61880E+00,-0.61936E+00,-0.61993E+00,-0.62049E+00,-0.62104E+00, & + -0.62160E+00,-0.62216E+00,-0.62272E+00,-0.62327E+00,-0.62382E+00, & + -0.62438E+00,-0.62493E+00,-0.62548E+00,-0.62603E+00,-0.62658E+00, & + -0.62712E+00,-0.62767E+00,-0.62822E+00,-0.62876E+00,-0.62930E+00, & + -0.62985E+00,-0.63039E+00,-0.63093E+00,-0.63147E+00,-0.63201E+00, & + -0.63254E+00,-0.63308E+00,-0.63362E+00,-0.63415E+00,-0.63468E+00, & + -0.63522E+00,-0.63575E+00,-0.63628E+00,-0.63681E+00,-0.63734E+00, & + -0.63787E+00,-0.63839E+00,-0.63892E+00,-0.63945E+00,-0.63997E+00, & + -0.64049E+00,-0.64102E+00,-0.64154E+00,-0.64206E+00,-0.64258E+00, & + -0.64310E+00,-0.64362E+00,-0.64413E+00,-0.64465E+00,-0.64516E+00, & + -0.64568E+00,-0.64619E+00,-0.64671E+00,-0.64722E+00,-0.64773E+00, & + -0.64824E+00,-0.64875E+00,-0.64926E+00,-0.64977E+00,-0.65027E+00, & + -0.65078E+00,-0.65129E+00,-0.65179E+00,-0.65229E+00,-0.65280E+00, & + -0.65330E+00,-0.65380E+00,-0.65430E+00,-0.65480E+00,-0.65530E+00, & + -0.65580E+00,-0.65630E+00,-0.65679E+00,-0.65729E+00,-0.65778E+00/ + + DATA (BNC03M (I),I=401,500)/ & + -0.65828E+00,-0.65877E+00,-0.65926E+00,-0.65976E+00,-0.66025E+00, & + -0.66074E+00,-0.66123E+00,-0.66172E+00,-0.66221E+00,-0.66269E+00, & + -0.66318E+00,-0.66367E+00,-0.66415E+00,-0.66464E+00,-0.66512E+00, & + -0.66560E+00,-0.66609E+00,-0.66657E+00,-0.66705E+00,-0.66753E+00, & + -0.66801E+00,-0.66849E+00,-0.66897E+00,-0.66944E+00,-0.66992E+00, & + -0.67040E+00,-0.67087E+00,-0.67135E+00,-0.67182E+00,-0.67229E+00, & + -0.67277E+00,-0.67324E+00,-0.67371E+00,-0.67418E+00,-0.67465E+00, & + -0.67512E+00,-0.67559E+00,-0.67606E+00,-0.67652E+00,-0.67699E+00, & + -0.67746E+00,-0.67792E+00,-0.67839E+00,-0.67885E+00,-0.67931E+00, & + -0.67978E+00,-0.68024E+00,-0.68070E+00,-0.68116E+00,-0.68162E+00, & + -0.68208E+00,-0.68254E+00,-0.68300E+00,-0.68346E+00,-0.68391E+00, & + -0.68437E+00,-0.68483E+00,-0.68528E+00,-0.68574E+00,-0.68619E+00, & + -0.68664E+00,-0.68710E+00,-0.68755E+00,-0.68800E+00,-0.68845E+00, & + -0.68890E+00,-0.68935E+00,-0.68980E+00,-0.69025E+00,-0.69070E+00, & + -0.69115E+00,-0.69159E+00,-0.69204E+00,-0.69249E+00,-0.69293E+00, & + -0.69338E+00,-0.69382E+00,-0.69426E+00,-0.69471E+00,-0.69515E+00, & + -0.69559E+00,-0.69603E+00,-0.69647E+00,-0.69691E+00,-0.69735E+00, & + -0.69779E+00,-0.69823E+00,-0.69867E+00,-0.69911E+00,-0.69954E+00, & + -0.69998E+00,-0.70042E+00,-0.70085E+00,-0.70129E+00,-0.70172E+00, & + -0.70216E+00,-0.70259E+00,-0.70302E+00,-0.70345E+00,-0.70389E+00/ + + DATA (BNC03M (I),I=501,600)/ & + -0.70432E+00,-0.70475E+00,-0.70518E+00,-0.70561E+00,-0.70604E+00, & + -0.70646E+00,-0.70689E+00,-0.70732E+00,-0.70775E+00,-0.70817E+00, & + -0.70860E+00,-0.70903E+00,-0.70945E+00,-0.70987E+00,-0.71030E+00, & + -0.71072E+00,-0.71115E+00,-0.71157E+00,-0.71199E+00,-0.71241E+00, & + -0.71283E+00,-0.71325E+00,-0.71367E+00,-0.71409E+00,-0.71451E+00, & + -0.71493E+00,-0.71535E+00,-0.71577E+00,-0.71618E+00,-0.71660E+00, & + -0.71702E+00,-0.71743E+00,-0.71785E+00,-0.71826E+00,-0.71868E+00, & + -0.71909E+00,-0.71951E+00,-0.71992E+00,-0.72033E+00,-0.72074E+00, & + -0.72116E+00,-0.72157E+00,-0.72198E+00,-0.72239E+00,-0.72280E+00, & + -0.72321E+00,-0.72362E+00,-0.72403E+00,-0.72443E+00,-0.72484E+00, & + -0.72525E+00,-0.72566E+00,-0.72606E+00,-0.72647E+00,-0.72687E+00, & + -0.72728E+00,-0.72768E+00,-0.72809E+00,-0.72849E+00,-0.72890E+00, & + -0.72930E+00,-0.72970E+00,-0.73010E+00,-0.73050E+00,-0.73091E+00, & + -0.73131E+00,-0.73171E+00,-0.73211E+00,-0.73251E+00,-0.73291E+00, & + -0.73330E+00,-0.73370E+00,-0.73410E+00,-0.73450E+00,-0.73490E+00, & + -0.73529E+00,-0.73569E+00,-0.73609E+00,-0.73648E+00,-0.73688E+00, & + -0.73727E+00,-0.73766E+00,-0.73806E+00,-0.73845E+00,-0.73885E+00, & + -0.73924E+00,-0.73963E+00,-0.74002E+00,-0.74041E+00,-0.74081E+00, & + -0.74120E+00,-0.74159E+00,-0.74198E+00,-0.74237E+00,-0.74276E+00, & + -0.74314E+00,-0.74353E+00,-0.74392E+00,-0.74431E+00,-0.74576E+00/ + + DATA (BNC03M (I),I=601,700)/ & + -0.74893E+00,-0.75275E+00,-0.75652E+00,-0.76027E+00,-0.76398E+00, & + -0.76765E+00,-0.77130E+00,-0.77492E+00,-0.77850E+00,-0.78206E+00, & + -0.78558E+00,-0.78908E+00,-0.79256E+00,-0.79600E+00,-0.79942E+00, & + -0.80282E+00,-0.80619E+00,-0.80954E+00,-0.81286E+00,-0.81616E+00, & + -0.81944E+00,-0.82270E+00,-0.82594E+00,-0.82915E+00,-0.83235E+00, & + -0.83552E+00,-0.83868E+00,-0.84181E+00,-0.84493E+00,-0.84803E+00, & + -0.85111E+00,-0.85417E+00,-0.85722E+00,-0.86025E+00,-0.86326E+00, & + -0.86626E+00,-0.86924E+00,-0.87221E+00,-0.87515E+00,-0.87809E+00, & + -0.88101E+00,-0.88391E+00,-0.88681E+00,-0.88968E+00,-0.89255E+00, & + -0.89540E+00,-0.89823E+00,-0.90106E+00,-0.90387E+00,-0.90666E+00, & + -0.90945E+00,-0.91222E+00,-0.91499E+00,-0.91773E+00,-0.92047E+00, & + -0.92320E+00,-0.92592E+00,-0.92862E+00,-0.93131E+00,-0.93400E+00, & + -0.93667E+00,-0.93933E+00,-0.94198E+00,-0.94462E+00,-0.94726E+00, & + -0.94988E+00,-0.95249E+00,-0.95509E+00,-0.95769E+00,-0.96027E+00, & + -0.96285E+00,-0.96541E+00,-0.96797E+00,-0.97052E+00,-0.97306E+00, & + -0.97559E+00,-0.97812E+00,-0.98063E+00,-0.98314E+00,-0.98564E+00, & + -0.98813E+00,-0.99062E+00,-0.99309E+00,-0.99556E+00,-0.99802E+00, & + -0.10005E+01,-0.10029E+01,-0.10054E+01,-0.10078E+01,-0.10102E+01, & + -0.10126E+01,-0.10150E+01,-0.10175E+01,-0.10198E+01,-0.10222E+01, & + -0.10246E+01,-0.10270E+01,-0.10294E+01,-0.10317E+01,-0.10341E+01/ + + DATA (BNC03M(I),I=701,741)/ & + -0.10365E+01,-0.10388E+01,-0.10411E+01,-0.10435E+01,-0.10458E+01, & + -0.10481E+01,-0.10505E+01,-0.10528E+01,-0.10551E+01,-0.10574E+01, & + -0.10597E+01,-0.10620E+01,-0.10642E+01,-0.10665E+01,-0.10688E+01, & + -0.10711E+01,-0.10733E+01,-0.10756E+01,-0.10778E+01,-0.10801E+01, & + -0.10823E+01,-0.10846E+01,-0.10868E+01,-0.10890E+01,-0.10913E+01, & + -0.10935E+01,-0.10957E+01,-0.10979E+01,-0.11001E+01,-0.11023E+01, & + -0.11045E+01,-0.11067E+01,-0.11089E+01,-0.11111E+01,-0.11133E+01, & + -0.11154E+01,-0.11176E+01,-0.11198E+01,-0.11219E+01,-0.11241E+01, & + -0.11263E+01 & + / +! +! *** (NH4)2SO4 +! + DATA (BNC04M (I),I= 1,100)/ & + -0.10581E+00,-0.19334E+00,-0.25539E+00,-0.29790E+00,-0.33085E+00, & + -0.35796E+00,-0.38111E+00,-0.40135E+00,-0.41938E+00,-0.43565E+00, & + -0.45050E+00,-0.46416E+00,-0.47682E+00,-0.48862E+00,-0.49969E+00, & + -0.51010E+00,-0.51994E+00,-0.52928E+00,-0.53815E+00,-0.54662E+00, & + -0.55471E+00,-0.56247E+00,-0.56992E+00,-0.57708E+00,-0.58397E+00, & + -0.59063E+00,-0.59706E+00,-0.60328E+00,-0.60931E+00,-0.61515E+00, & + -0.62082E+00,-0.62634E+00,-0.63169E+00,-0.63691E+00,-0.64199E+00, & + -0.64694E+00,-0.65178E+00,-0.65649E+00,-0.66110E+00,-0.66560E+00, & + -0.67000E+00,-0.67431E+00,-0.67853E+00,-0.68266E+00,-0.68670E+00, & + -0.69067E+00,-0.69456E+00,-0.69838E+00,-0.70212E+00,-0.70580E+00, & + -0.70942E+00,-0.71297E+00,-0.71646E+00,-0.71989E+00,-0.72326E+00, & + -0.72659E+00,-0.72986E+00,-0.73308E+00,-0.73625E+00,-0.73937E+00, & + -0.74245E+00,-0.74549E+00,-0.74848E+00,-0.75143E+00,-0.75435E+00, & + -0.75722E+00,-0.76006E+00,-0.76287E+00,-0.76564E+00,-0.76837E+00, & + -0.77108E+00,-0.77375E+00,-0.77640E+00,-0.77901E+00,-0.78160E+00, & + -0.78416E+00,-0.78670E+00,-0.78921E+00,-0.79169E+00,-0.79415E+00, & + -0.79659E+00,-0.79901E+00,-0.80140E+00,-0.80378E+00,-0.80613E+00, & + -0.80847E+00,-0.81078E+00,-0.81308E+00,-0.81536E+00,-0.81762E+00, & + -0.81986E+00,-0.82209E+00,-0.82430E+00,-0.82649E+00,-0.82867E+00, & + -0.83083E+00,-0.83298E+00,-0.83512E+00,-0.83724E+00,-0.83934E+00/ + + DATA (BNC04M (I),I=101,200)/ & + -0.84143E+00,-0.84351E+00,-0.84558E+00,-0.84763E+00,-0.84967E+00, & + -0.85169E+00,-0.85371E+00,-0.85571E+00,-0.85770E+00,-0.85967E+00, & + -0.86164E+00,-0.86359E+00,-0.86553E+00,-0.86746E+00,-0.86938E+00, & + -0.87129E+00,-0.87319E+00,-0.87507E+00,-0.87695E+00,-0.87881E+00, & + -0.88061E+00,-0.88246E+00,-0.88430E+00,-0.88612E+00,-0.88794E+00, & + -0.88975E+00,-0.89154E+00,-0.89333E+00,-0.89510E+00,-0.89687E+00, & + -0.89862E+00,-0.90037E+00,-0.90211E+00,-0.90383E+00,-0.90555E+00, & + -0.90726E+00,-0.90896E+00,-0.91065E+00,-0.91233E+00,-0.91401E+00, & + -0.91567E+00,-0.91733E+00,-0.91897E+00,-0.92061E+00,-0.92225E+00, & + -0.92387E+00,-0.92549E+00,-0.92710E+00,-0.92870E+00,-0.93029E+00, & + -0.93188E+00,-0.93345E+00,-0.93502E+00,-0.93659E+00,-0.93814E+00, & + -0.93969E+00,-0.94124E+00,-0.94277E+00,-0.94430E+00,-0.94582E+00, & + -0.94734E+00,-0.94885E+00,-0.95035E+00,-0.95185E+00,-0.95334E+00, & + -0.95482E+00,-0.95630E+00,-0.95777E+00,-0.95923E+00,-0.96069E+00, & + -0.96215E+00,-0.96359E+00,-0.96504E+00,-0.96647E+00,-0.96790E+00, & + -0.96933E+00,-0.97075E+00,-0.97216E+00,-0.97357E+00,-0.97497E+00, & + -0.97637E+00,-0.97776E+00,-0.97915E+00,-0.98053E+00,-0.98190E+00, & + -0.98327E+00,-0.98464E+00,-0.98600E+00,-0.98736E+00,-0.98871E+00, & + -0.99006E+00,-0.99140E+00,-0.99274E+00,-0.99407E+00,-0.99540E+00, & + -0.99672E+00,-0.99804E+00,-0.99935E+00,-0.10007E+01,-0.10020E+01/ + + DATA (BNC04M (I),I=201,300)/ & + -0.10033E+01,-0.10046E+01,-0.10059E+01,-0.10071E+01,-0.10084E+01, & + -0.10097E+01,-0.10110E+01,-0.10123E+01,-0.10135E+01,-0.10148E+01, & + -0.10160E+01,-0.10173E+01,-0.10186E+01,-0.10198E+01,-0.10210E+01, & + -0.10223E+01,-0.10235E+01,-0.10248E+01,-0.10260E+01,-0.10272E+01, & + -0.10284E+01,-0.10296E+01,-0.10309E+01,-0.10321E+01,-0.10333E+01, & + -0.10345E+01,-0.10357E+01,-0.10369E+01,-0.10381E+01,-0.10393E+01, & + -0.10404E+01,-0.10416E+01,-0.10428E+01,-0.10440E+01,-0.10451E+01, & + -0.10463E+01,-0.10475E+01,-0.10486E+01,-0.10498E+01,-0.10510E+01, & + -0.10521E+01,-0.10533E+01,-0.10544E+01,-0.10556E+01,-0.10567E+01, & + -0.10578E+01,-0.10590E+01,-0.10601E+01,-0.10612E+01,-0.10624E+01, & + -0.10635E+01,-0.10646E+01,-0.10657E+01,-0.10668E+01,-0.10679E+01, & + -0.10690E+01,-0.10702E+01,-0.10713E+01,-0.10724E+01,-0.10735E+01, & + -0.10745E+01,-0.10756E+01,-0.10767E+01,-0.10778E+01,-0.10789E+01, & + -0.10800E+01,-0.10811E+01,-0.10821E+01,-0.10832E+01,-0.10843E+01, & + -0.10853E+01,-0.10864E+01,-0.10875E+01,-0.10885E+01,-0.10896E+01, & + -0.10907E+01,-0.10917E+01,-0.10928E+01,-0.10938E+01,-0.10949E+01, & + -0.10959E+01,-0.10969E+01,-0.10980E+01,-0.10990E+01,-0.11001E+01, & + -0.11011E+01,-0.11021E+01,-0.11031E+01,-0.11042E+01,-0.11052E+01, & + -0.11062E+01,-0.11072E+01,-0.11083E+01,-0.11093E+01,-0.11103E+01, & + -0.11113E+01,-0.11123E+01,-0.11133E+01,-0.11143E+01,-0.11153E+01/ + + DATA (BNC04M (I),I=301,400)/ & + -0.11163E+01,-0.11173E+01,-0.11183E+01,-0.11193E+01,-0.11203E+01, & + -0.11213E+01,-0.11223E+01,-0.11232E+01,-0.11242E+01,-0.11252E+01, & + -0.11262E+01,-0.11272E+01,-0.11281E+01,-0.11291E+01,-0.11301E+01, & + -0.11311E+01,-0.11320E+01,-0.11330E+01,-0.11340E+01,-0.11349E+01, & + -0.11359E+01,-0.11368E+01,-0.11378E+01,-0.11388E+01,-0.11397E+01, & + -0.11407E+01,-0.11416E+01,-0.11426E+01,-0.11435E+01,-0.11444E+01, & + -0.11454E+01,-0.11463E+01,-0.11473E+01,-0.11482E+01,-0.11491E+01, & + -0.11501E+01,-0.11510E+01,-0.11519E+01,-0.11529E+01,-0.11538E+01, & + -0.11547E+01,-0.11556E+01,-0.11566E+01,-0.11575E+01,-0.11584E+01, & + -0.11593E+01,-0.11602E+01,-0.11612E+01,-0.11621E+01,-0.11630E+01, & + -0.11639E+01,-0.11648E+01,-0.11657E+01,-0.11666E+01,-0.11675E+01, & + -0.11684E+01,-0.11693E+01,-0.11702E+01,-0.11711E+01,-0.11720E+01, & + -0.11729E+01,-0.11738E+01,-0.11747E+01,-0.11756E+01,-0.11764E+01, & + -0.11773E+01,-0.11782E+01,-0.11791E+01,-0.11800E+01,-0.11809E+01, & + -0.11817E+01,-0.11826E+01,-0.11835E+01,-0.11844E+01,-0.11852E+01, & + -0.11861E+01,-0.11870E+01,-0.11879E+01,-0.11887E+01,-0.11896E+01, & + -0.11905E+01,-0.11913E+01,-0.11922E+01,-0.11930E+01,-0.11939E+01, & + -0.11948E+01,-0.11956E+01,-0.11965E+01,-0.11973E+01,-0.11982E+01, & + -0.11990E+01,-0.11999E+01,-0.12007E+01,-0.12016E+01,-0.12024E+01, & + -0.12033E+01,-0.12041E+01,-0.12050E+01,-0.12058E+01,-0.12067E+01/ + + DATA (BNC04M (I),I=401,500)/ & + -0.12075E+01,-0.12083E+01,-0.12092E+01,-0.12100E+01,-0.12108E+01, & + -0.12117E+01,-0.12125E+01,-0.12133E+01,-0.12142E+01,-0.12150E+01, & + -0.12158E+01,-0.12166E+01,-0.12175E+01,-0.12183E+01,-0.12191E+01, & + -0.12199E+01,-0.12208E+01,-0.12216E+01,-0.12224E+01,-0.12232E+01, & + -0.12240E+01,-0.12248E+01,-0.12257E+01,-0.12265E+01,-0.12273E+01, & + -0.12281E+01,-0.12289E+01,-0.12297E+01,-0.12305E+01,-0.12313E+01, & + -0.12321E+01,-0.12329E+01,-0.12337E+01,-0.12345E+01,-0.12353E+01, & + -0.12361E+01,-0.12369E+01,-0.12377E+01,-0.12385E+01,-0.12393E+01, & + -0.12401E+01,-0.12409E+01,-0.12417E+01,-0.12425E+01,-0.12433E+01, & + -0.12441E+01,-0.12449E+01,-0.12456E+01,-0.12464E+01,-0.12472E+01, & + -0.12480E+01,-0.12488E+01,-0.12496E+01,-0.12503E+01,-0.12511E+01, & + -0.12519E+01,-0.12527E+01,-0.12535E+01,-0.12542E+01,-0.12550E+01, & + -0.12558E+01,-0.12566E+01,-0.12573E+01,-0.12581E+01,-0.12589E+01, & + -0.12596E+01,-0.12604E+01,-0.12612E+01,-0.12619E+01,-0.12627E+01, & + -0.12635E+01,-0.12642E+01,-0.12650E+01,-0.12658E+01,-0.12665E+01, & + -0.12673E+01,-0.12680E+01,-0.12688E+01,-0.12696E+01,-0.12703E+01, & + -0.12711E+01,-0.12718E+01,-0.12726E+01,-0.12733E+01,-0.12741E+01, & + -0.12748E+01,-0.12756E+01,-0.12763E+01,-0.12771E+01,-0.12778E+01, & + -0.12786E+01,-0.12793E+01,-0.12801E+01,-0.12808E+01,-0.12816E+01, & + -0.12823E+01,-0.12830E+01,-0.12838E+01,-0.12845E+01,-0.12853E+01/ + + DATA (BNC04M (I),I=501,600)/ & + -0.12860E+01,-0.12867E+01,-0.12875E+01,-0.12882E+01,-0.12890E+01, & + -0.12897E+01,-0.12904E+01,-0.12912E+01,-0.12919E+01,-0.12926E+01, & + -0.12933E+01,-0.12941E+01,-0.12948E+01,-0.12955E+01,-0.12963E+01, & + -0.12970E+01,-0.12977E+01,-0.12984E+01,-0.12992E+01,-0.12999E+01, & + -0.13006E+01,-0.13013E+01,-0.13021E+01,-0.13028E+01,-0.13035E+01, & + -0.13042E+01,-0.13049E+01,-0.13057E+01,-0.13064E+01,-0.13071E+01, & + -0.13078E+01,-0.13085E+01,-0.13092E+01,-0.13099E+01,-0.13107E+01, & + -0.13114E+01,-0.13121E+01,-0.13128E+01,-0.13135E+01,-0.13142E+01, & + -0.13149E+01,-0.13156E+01,-0.13163E+01,-0.13170E+01,-0.13177E+01, & + -0.13184E+01,-0.13191E+01,-0.13198E+01,-0.13206E+01,-0.13213E+01, & + -0.13220E+01,-0.13227E+01,-0.13234E+01,-0.13241E+01,-0.13248E+01, & + -0.13254E+01,-0.13261E+01,-0.13268E+01,-0.13275E+01,-0.13282E+01, & + -0.13289E+01,-0.13296E+01,-0.13303E+01,-0.13310E+01,-0.13317E+01, & + -0.13324E+01,-0.13331E+01,-0.13338E+01,-0.13345E+01,-0.13351E+01, & + -0.13358E+01,-0.13365E+01,-0.13372E+01,-0.13379E+01,-0.13386E+01, & + -0.13393E+01,-0.13399E+01,-0.13406E+01,-0.13413E+01,-0.13420E+01, & + -0.13427E+01,-0.13434E+01,-0.13440E+01,-0.13447E+01,-0.13454E+01, & + -0.13461E+01,-0.13467E+01,-0.13474E+01,-0.13481E+01,-0.13488E+01, & + -0.13495E+01,-0.13501E+01,-0.13508E+01,-0.13515E+01,-0.13521E+01, & + -0.13528E+01,-0.13535E+01,-0.13542E+01,-0.13548E+01,-0.13573E+01/ + + DATA (BNC04M (I),I=601,700)/ & + -0.13628E+01,-0.13694E+01,-0.13760E+01,-0.13825E+01,-0.13889E+01, & + -0.13953E+01,-0.14016E+01,-0.14079E+01,-0.14142E+01,-0.14204E+01, & + -0.14265E+01,-0.14327E+01,-0.14387E+01,-0.14448E+01,-0.14507E+01, & + -0.14567E+01,-0.14626E+01,-0.14685E+01,-0.14743E+01,-0.14801E+01, & + -0.14859E+01,-0.14916E+01,-0.14973E+01,-0.15030E+01,-0.15087E+01, & + -0.15143E+01,-0.15198E+01,-0.15254E+01,-0.15309E+01,-0.15364E+01, & + -0.15419E+01,-0.15473E+01,-0.15527E+01,-0.15581E+01,-0.15635E+01, & + -0.15688E+01,-0.15741E+01,-0.15794E+01,-0.15846E+01,-0.15899E+01, & + -0.15951E+01,-0.16003E+01,-0.16055E+01,-0.16106E+01,-0.16157E+01, & + -0.16208E+01,-0.16259E+01,-0.16310E+01,-0.16360E+01,-0.16411E+01, & + -0.16461E+01,-0.16511E+01,-0.16560E+01,-0.16610E+01,-0.16659E+01, & + -0.16708E+01,-0.16757E+01,-0.16806E+01,-0.16855E+01,-0.16903E+01, & + -0.16952E+01,-0.17000E+01,-0.17048E+01,-0.17096E+01,-0.17143E+01, & + -0.17191E+01,-0.17238E+01,-0.17285E+01,-0.17333E+01,-0.17379E+01, & + -0.17426E+01,-0.17473E+01,-0.17520E+01,-0.17566E+01,-0.17612E+01, & + -0.17658E+01,-0.17704E+01,-0.17750E+01,-0.17796E+01,-0.17842E+01, & + -0.17887E+01,-0.17933E+01,-0.17978E+01,-0.18023E+01,-0.18068E+01, & + -0.18113E+01,-0.18158E+01,-0.18203E+01,-0.18247E+01,-0.18292E+01, & + -0.18336E+01,-0.18380E+01,-0.18425E+01,-0.18469E+01,-0.18513E+01, & + -0.18556E+01,-0.18600E+01,-0.18644E+01,-0.18687E+01,-0.18731E+01/ + + DATA (BNC04M(I),I=701,741)/ & + -0.18774E+01,-0.18818E+01,-0.18861E+01,-0.18904E+01,-0.18947E+01, & + -0.18990E+01,-0.19033E+01,-0.19075E+01,-0.19118E+01,-0.19161E+01, & + -0.19203E+01,-0.19245E+01,-0.19288E+01,-0.19330E+01,-0.19372E+01, & + -0.19414E+01,-0.19456E+01,-0.19498E+01,-0.19540E+01,-0.19582E+01, & + -0.19623E+01,-0.19665E+01,-0.19707E+01,-0.19748E+01,-0.19789E+01, & + -0.19831E+01,-0.19872E+01,-0.19913E+01,-0.19954E+01,-0.19995E+01, & + -0.20036E+01,-0.20077E+01,-0.20118E+01,-0.20159E+01,-0.20199E+01, & + -0.20240E+01,-0.20280E+01,-0.20321E+01,-0.20361E+01,-0.20402E+01, & + -0.20442E+01 & + / +! +! *** NH4NO3 +! + DATA (BNC05M (I),I= 1,100)/ & + -0.53657E-01,-0.99475E-01,-0.13304E+00,-0.15671E+00,-0.17551E+00, & + -0.19133E+00,-0.20511E+00,-0.21739E+00,-0.22852E+00,-0.23874E+00, & + -0.24821E+00,-0.25706E+00,-0.26538E+00,-0.27325E+00,-0.28072E+00, & + -0.28785E+00,-0.29466E+00,-0.30120E+00,-0.30749E+00,-0.31356E+00, & + -0.31941E+00,-0.32508E+00,-0.33057E+00,-0.33590E+00,-0.34108E+00, & + -0.34612E+00,-0.35103E+00,-0.35582E+00,-0.36049E+00,-0.36505E+00, & + -0.36951E+00,-0.37386E+00,-0.37813E+00,-0.38230E+00,-0.38639E+00, & + -0.39040E+00,-0.39433E+00,-0.39818E+00,-0.40197E+00,-0.40568E+00, & + -0.40933E+00,-0.41291E+00,-0.41643E+00,-0.41989E+00,-0.42330E+00, & + -0.42664E+00,-0.42994E+00,-0.43318E+00,-0.43637E+00,-0.43952E+00, & + -0.44261E+00,-0.44566E+00,-0.44867E+00,-0.45164E+00,-0.45456E+00, & + -0.45744E+00,-0.46029E+00,-0.46310E+00,-0.46587E+00,-0.46861E+00, & + -0.47132E+00,-0.47400E+00,-0.47664E+00,-0.47926E+00,-0.48184E+00, & + -0.48440E+00,-0.48694E+00,-0.48945E+00,-0.49193E+00,-0.49440E+00, & + -0.49684E+00,-0.49926E+00,-0.50166E+00,-0.50404E+00,-0.50640E+00, & + -0.50875E+00,-0.51108E+00,-0.51339E+00,-0.51569E+00,-0.51797E+00, & + -0.52024E+00,-0.52250E+00,-0.52474E+00,-0.52697E+00,-0.52919E+00, & + -0.53140E+00,-0.53360E+00,-0.53579E+00,-0.53797E+00,-0.54014E+00, & + -0.54229E+00,-0.54444E+00,-0.54659E+00,-0.54872E+00,-0.55084E+00, & + -0.55296E+00,-0.55507E+00,-0.55717E+00,-0.55926E+00,-0.56135E+00/ + + DATA (BNC05M (I),I=101,200)/ & + -0.56342E+00,-0.56549E+00,-0.56755E+00,-0.56961E+00,-0.57165E+00, & + -0.57369E+00,-0.57572E+00,-0.57775E+00,-0.57976E+00,-0.58177E+00, & + -0.58377E+00,-0.58576E+00,-0.58774E+00,-0.58972E+00,-0.59169E+00, & + -0.59364E+00,-0.59560E+00,-0.59754E+00,-0.59947E+00,-0.60140E+00, & + -0.60319E+00,-0.60512E+00,-0.60703E+00,-0.60894E+00,-0.61083E+00, & + -0.61272E+00,-0.61459E+00,-0.61646E+00,-0.61832E+00,-0.62017E+00, & + -0.62201E+00,-0.62384E+00,-0.62566E+00,-0.62748E+00,-0.62928E+00, & + -0.63108E+00,-0.63287E+00,-0.63465E+00,-0.63642E+00,-0.63819E+00, & + -0.63994E+00,-0.64169E+00,-0.64343E+00,-0.64516E+00,-0.64689E+00, & + -0.64860E+00,-0.65031E+00,-0.65201E+00,-0.65371E+00,-0.65539E+00, & + -0.65707E+00,-0.65875E+00,-0.66041E+00,-0.66207E+00,-0.66372E+00, & + -0.66536E+00,-0.66700E+00,-0.66863E+00,-0.67025E+00,-0.67187E+00, & + -0.67348E+00,-0.67508E+00,-0.67668E+00,-0.67827E+00,-0.67985E+00, & + -0.68143E+00,-0.68300E+00,-0.68456E+00,-0.68612E+00,-0.68767E+00, & + -0.68922E+00,-0.69076E+00,-0.69229E+00,-0.69382E+00,-0.69534E+00, & + -0.69686E+00,-0.69837E+00,-0.69987E+00,-0.70137E+00,-0.70286E+00, & + -0.70435E+00,-0.70583E+00,-0.70731E+00,-0.70878E+00,-0.71024E+00, & + -0.71170E+00,-0.71316E+00,-0.71460E+00,-0.71605E+00,-0.71749E+00, & + -0.71892E+00,-0.72035E+00,-0.72177E+00,-0.72319E+00,-0.72460E+00, & + -0.72600E+00,-0.72741E+00,-0.72880E+00,-0.73020E+00,-0.73158E+00/ + + DATA (BNC05M (I),I=201,300)/ & + -0.73297E+00,-0.73434E+00,-0.73572E+00,-0.73708E+00,-0.73845E+00, & + -0.73980E+00,-0.74116E+00,-0.74251E+00,-0.74385E+00,-0.74519E+00, & + -0.74653E+00,-0.74786E+00,-0.74918E+00,-0.75051E+00,-0.75182E+00, & + -0.75314E+00,-0.75445E+00,-0.75575E+00,-0.75705E+00,-0.75835E+00, & + -0.75964E+00,-0.76092E+00,-0.76221E+00,-0.76349E+00,-0.76476E+00, & + -0.76603E+00,-0.76730E+00,-0.76856E+00,-0.76982E+00,-0.77107E+00, & + -0.77232E+00,-0.77357E+00,-0.77481E+00,-0.77605E+00,-0.77729E+00, & + -0.77852E+00,-0.77974E+00,-0.78097E+00,-0.78219E+00,-0.78340E+00, & + -0.78461E+00,-0.78582E+00,-0.78703E+00,-0.78823E+00,-0.78943E+00, & + -0.79062E+00,-0.79181E+00,-0.79300E+00,-0.79418E+00,-0.79536E+00, & + -0.79653E+00,-0.79771E+00,-0.79887E+00,-0.80004E+00,-0.80120E+00, & + -0.80236E+00,-0.80351E+00,-0.80467E+00,-0.80581E+00,-0.80696E+00, & + -0.80810E+00,-0.80924E+00,-0.81037E+00,-0.81150E+00,-0.81263E+00, & + -0.81376E+00,-0.81488E+00,-0.81600E+00,-0.81711E+00,-0.81823E+00, & + -0.81934E+00,-0.82044E+00,-0.82155E+00,-0.82264E+00,-0.82374E+00, & + -0.82484E+00,-0.82593E+00,-0.82701E+00,-0.82810E+00,-0.82918E+00, & + -0.83026E+00,-0.83133E+00,-0.83241E+00,-0.83348E+00,-0.83454E+00, & + -0.83561E+00,-0.83667E+00,-0.83773E+00,-0.83878E+00,-0.83984E+00, & + -0.84089E+00,-0.84193E+00,-0.84298E+00,-0.84402E+00,-0.84506E+00, & + -0.84609E+00,-0.84713E+00,-0.84816E+00,-0.84918E+00,-0.85021E+00/ + + DATA (BNC05M (I),I=301,400)/ & + -0.85123E+00,-0.85225E+00,-0.85327E+00,-0.85428E+00,-0.85529E+00, & + -0.85630E+00,-0.85731E+00,-0.85831E+00,-0.85932E+00,-0.86031E+00, & + -0.86131E+00,-0.86230E+00,-0.86330E+00,-0.86428E+00,-0.86527E+00, & + -0.86625E+00,-0.86724E+00,-0.86821E+00,-0.86919E+00,-0.87016E+00, & + -0.87114E+00,-0.87210E+00,-0.87307E+00,-0.87404E+00,-0.87500E+00, & + -0.87596E+00,-0.87691E+00,-0.87787E+00,-0.87882E+00,-0.87977E+00, & + -0.88072E+00,-0.88167E+00,-0.88261E+00,-0.88355E+00,-0.88449E+00, & + -0.88542E+00,-0.88636E+00,-0.88729E+00,-0.88822E+00,-0.88915E+00, & + -0.89007E+00,-0.89100E+00,-0.89192E+00,-0.89284E+00,-0.89375E+00, & + -0.89467E+00,-0.89558E+00,-0.89649E+00,-0.89740E+00,-0.89830E+00, & + -0.89921E+00,-0.90011E+00,-0.90101E+00,-0.90191E+00,-0.90280E+00, & + -0.90370E+00,-0.90459E+00,-0.90548E+00,-0.90636E+00,-0.90725E+00, & + -0.90813E+00,-0.90901E+00,-0.90989E+00,-0.91077E+00,-0.91165E+00, & + -0.91252E+00,-0.91339E+00,-0.91426E+00,-0.91513E+00,-0.91599E+00, & + -0.91686E+00,-0.91772E+00,-0.91858E+00,-0.91944E+00,-0.92029E+00, & + -0.92115E+00,-0.92200E+00,-0.92285E+00,-0.92370E+00,-0.92455E+00, & + -0.92539E+00,-0.92623E+00,-0.92707E+00,-0.92791E+00,-0.92875E+00, & + -0.92959E+00,-0.93042E+00,-0.93125E+00,-0.93208E+00,-0.93291E+00, & + -0.93374E+00,-0.93456E+00,-0.93539E+00,-0.93621E+00,-0.93703E+00, & + -0.93785E+00,-0.93866E+00,-0.93948E+00,-0.94029E+00,-0.94110E+00/ + + DATA (BNC05M (I),I=401,500)/ & + -0.94191E+00,-0.94272E+00,-0.94353E+00,-0.94433E+00,-0.94513E+00, & + -0.94594E+00,-0.94673E+00,-0.94753E+00,-0.94833E+00,-0.94912E+00, & + -0.94992E+00,-0.95071E+00,-0.95150E+00,-0.95229E+00,-0.95307E+00, & + -0.95386E+00,-0.95464E+00,-0.95542E+00,-0.95620E+00,-0.95698E+00, & + -0.95776E+00,-0.95853E+00,-0.95931E+00,-0.96008E+00,-0.96085E+00, & + -0.96162E+00,-0.96239E+00,-0.96316E+00,-0.96392E+00,-0.96468E+00, & + -0.96545E+00,-0.96621E+00,-0.96696E+00,-0.96772E+00,-0.96848E+00, & + -0.96923E+00,-0.96999E+00,-0.97074E+00,-0.97149E+00,-0.97224E+00, & + -0.97298E+00,-0.97373E+00,-0.97447E+00,-0.97522E+00,-0.97596E+00, & + -0.97670E+00,-0.97744E+00,-0.97817E+00,-0.97891E+00,-0.97964E+00, & + -0.98038E+00,-0.98111E+00,-0.98184E+00,-0.98257E+00,-0.98329E+00, & + -0.98402E+00,-0.98474E+00,-0.98547E+00,-0.98619E+00,-0.98691E+00, & + -0.98763E+00,-0.98835E+00,-0.98906E+00,-0.98978E+00,-0.99049E+00, & + -0.99121E+00,-0.99192E+00,-0.99263E+00,-0.99334E+00,-0.99404E+00, & + -0.99475E+00,-0.99546E+00,-0.99616E+00,-0.99686E+00,-0.99756E+00, & + -0.99826E+00,-0.99896E+00,-0.99966E+00,-0.10004E+01,-0.10011E+01, & + -0.10017E+01,-0.10024E+01,-0.10031E+01,-0.10038E+01,-0.10045E+01, & + -0.10052E+01,-0.10059E+01,-0.10066E+01,-0.10072E+01,-0.10079E+01, & + -0.10086E+01,-0.10093E+01,-0.10100E+01,-0.10106E+01,-0.10113E+01, & + -0.10120E+01,-0.10127E+01,-0.10133E+01,-0.10140E+01,-0.10147E+01/ + + DATA (BNC05M (I),I=501,600)/ & + -0.10154E+01,-0.10160E+01,-0.10167E+01,-0.10174E+01,-0.10180E+01, & + -0.10187E+01,-0.10194E+01,-0.10200E+01,-0.10207E+01,-0.10213E+01, & + -0.10220E+01,-0.10227E+01,-0.10233E+01,-0.10240E+01,-0.10246E+01, & + -0.10253E+01,-0.10259E+01,-0.10266E+01,-0.10272E+01,-0.10279E+01, & + -0.10285E+01,-0.10292E+01,-0.10298E+01,-0.10305E+01,-0.10311E+01, & + -0.10317E+01,-0.10324E+01,-0.10330E+01,-0.10337E+01,-0.10343E+01, & + -0.10349E+01,-0.10356E+01,-0.10362E+01,-0.10368E+01,-0.10375E+01, & + -0.10381E+01,-0.10387E+01,-0.10394E+01,-0.10400E+01,-0.10406E+01, & + -0.10412E+01,-0.10419E+01,-0.10425E+01,-0.10431E+01,-0.10437E+01, & + -0.10444E+01,-0.10450E+01,-0.10456E+01,-0.10462E+01,-0.10468E+01, & + -0.10474E+01,-0.10481E+01,-0.10487E+01,-0.10493E+01,-0.10499E+01, & + -0.10505E+01,-0.10511E+01,-0.10517E+01,-0.10523E+01,-0.10530E+01, & + -0.10536E+01,-0.10542E+01,-0.10548E+01,-0.10554E+01,-0.10560E+01, & + -0.10566E+01,-0.10572E+01,-0.10578E+01,-0.10584E+01,-0.10590E+01, & + -0.10596E+01,-0.10602E+01,-0.10608E+01,-0.10614E+01,-0.10620E+01, & + -0.10626E+01,-0.10631E+01,-0.10637E+01,-0.10643E+01,-0.10649E+01, & + -0.10655E+01,-0.10661E+01,-0.10667E+01,-0.10673E+01,-0.10678E+01, & + -0.10684E+01,-0.10690E+01,-0.10696E+01,-0.10702E+01,-0.10708E+01, & + -0.10713E+01,-0.10719E+01,-0.10725E+01,-0.10731E+01,-0.10737E+01, & + -0.10742E+01,-0.10748E+01,-0.10754E+01,-0.10759E+01,-0.10781E+01/ + + DATA (BNC05M (I),I=601,700)/ & + -0.10828E+01,-0.10883E+01,-0.10939E+01,-0.10993E+01,-0.11047E+01, & + -0.11099E+01,-0.11152E+01,-0.11203E+01,-0.11254E+01,-0.11304E+01, & + -0.11354E+01,-0.11403E+01,-0.11451E+01,-0.11499E+01,-0.11546E+01, & + -0.11593E+01,-0.11639E+01,-0.11685E+01,-0.11730E+01,-0.11775E+01, & + -0.11819E+01,-0.11863E+01,-0.11906E+01,-0.11949E+01,-0.11991E+01, & + -0.12033E+01,-0.12075E+01,-0.12116E+01,-0.12156E+01,-0.12197E+01, & + -0.12237E+01,-0.12276E+01,-0.12316E+01,-0.12355E+01,-0.12393E+01, & + -0.12431E+01,-0.12469E+01,-0.12507E+01,-0.12544E+01,-0.12581E+01, & + -0.12618E+01,-0.12654E+01,-0.12690E+01,-0.12726E+01,-0.12761E+01, & + -0.12797E+01,-0.12831E+01,-0.12866E+01,-0.12901E+01,-0.12935E+01, & + -0.12969E+01,-0.13002E+01,-0.13036E+01,-0.13069E+01,-0.13102E+01, & + -0.13135E+01,-0.13167E+01,-0.13200E+01,-0.13232E+01,-0.13264E+01, & + -0.13295E+01,-0.13327E+01,-0.13358E+01,-0.13389E+01,-0.13420E+01, & + -0.13451E+01,-0.13481E+01,-0.13512E+01,-0.13542E+01,-0.13572E+01, & + -0.13601E+01,-0.13631E+01,-0.13661E+01,-0.13690E+01,-0.13719E+01, & + -0.13748E+01,-0.13777E+01,-0.13806E+01,-0.13834E+01,-0.13863E+01, & + -0.13891E+01,-0.13919E+01,-0.13947E+01,-0.13975E+01,-0.14002E+01, & + -0.14030E+01,-0.14057E+01,-0.14085E+01,-0.14112E+01,-0.14139E+01, & + -0.14166E+01,-0.14192E+01,-0.14219E+01,-0.14246E+01,-0.14272E+01, & + -0.14298E+01,-0.14325E+01,-0.14351E+01,-0.14377E+01,-0.14402E+01/ + + DATA (BNC05M(I),I=701,741)/ & + -0.14428E+01,-0.14454E+01,-0.14479E+01,-0.14505E+01,-0.14530E+01, & + -0.14555E+01,-0.14581E+01,-0.14606E+01,-0.14631E+01,-0.14655E+01, & + -0.14680E+01,-0.14705E+01,-0.14729E+01,-0.14754E+01,-0.14778E+01, & + -0.14803E+01,-0.14827E+01,-0.14851E+01,-0.14875E+01,-0.14899E+01, & + -0.14923E+01,-0.14947E+01,-0.14970E+01,-0.14994E+01,-0.15017E+01, & + -0.15041E+01,-0.15064E+01,-0.15088E+01,-0.15111E+01,-0.15134E+01, & + -0.15157E+01,-0.15180E+01,-0.15203E+01,-0.15226E+01,-0.15249E+01, & + -0.15272E+01,-0.15294E+01,-0.15317E+01,-0.15340E+01,-0.15362E+01, & + -0.15385E+01 & + / +! +! *** NH4Cl +! + DATA (BNC06M (I),I= 1,100)/ & + -0.52099E-01,-0.93686E-01,-0.12205E+00,-0.14078E+00,-0.15483E+00, & + -0.16604E+00,-0.17532E+00,-0.18320E+00,-0.19002E+00,-0.19599E+00, & + -0.20128E+00,-0.20600E+00,-0.21026E+00,-0.21411E+00,-0.21762E+00, & + -0.22082E+00,-0.22376E+00,-0.22646E+00,-0.22896E+00,-0.23127E+00, & + -0.23341E+00,-0.23540E+00,-0.23725E+00,-0.23898E+00,-0.24060E+00, & + -0.24211E+00,-0.24353E+00,-0.24485E+00,-0.24610E+00,-0.24727E+00, & + -0.24837E+00,-0.24941E+00,-0.25039E+00,-0.25131E+00,-0.25218E+00, & + -0.25300E+00,-0.25378E+00,-0.25452E+00,-0.25521E+00,-0.25587E+00, & + -0.25650E+00,-0.25709E+00,-0.25766E+00,-0.25819E+00,-0.25870E+00, & + -0.25918E+00,-0.25963E+00,-0.26007E+00,-0.26048E+00,-0.26088E+00, & + -0.26125E+00,-0.26160E+00,-0.26194E+00,-0.26226E+00,-0.26257E+00, & + -0.26285E+00,-0.26313E+00,-0.26339E+00,-0.26363E+00,-0.26386E+00, & + -0.26408E+00,-0.26429E+00,-0.26448E+00,-0.26466E+00,-0.26483E+00, & + -0.26499E+00,-0.26513E+00,-0.26527E+00,-0.26539E+00,-0.26550E+00, & + -0.26560E+00,-0.26569E+00,-0.26576E+00,-0.26583E+00,-0.26588E+00, & + -0.26593E+00,-0.26596E+00,-0.26598E+00,-0.26600E+00,-0.26600E+00, & + -0.26599E+00,-0.26597E+00,-0.26594E+00,-0.26590E+00,-0.26584E+00, & + -0.26578E+00,-0.26571E+00,-0.26563E+00,-0.26553E+00,-0.26543E+00, & + -0.26532E+00,-0.26520E+00,-0.26507E+00,-0.26492E+00,-0.26477E+00, & + -0.26462E+00,-0.26445E+00,-0.26427E+00,-0.26409E+00,-0.26390E+00/ + + DATA (BNC06M (I),I=101,200)/ & + -0.26370E+00,-0.26349E+00,-0.26327E+00,-0.26305E+00,-0.26282E+00, & + -0.26258E+00,-0.26234E+00,-0.26209E+00,-0.26184E+00,-0.26158E+00, & + -0.26131E+00,-0.26104E+00,-0.26076E+00,-0.26048E+00,-0.26020E+00, & + -0.25991E+00,-0.25961E+00,-0.25931E+00,-0.25901E+00,-0.25870E+00, & + -0.25848E+00,-0.25816E+00,-0.25783E+00,-0.25751E+00,-0.25718E+00, & + -0.25684E+00,-0.25651E+00,-0.25617E+00,-0.25584E+00,-0.25550E+00, & + -0.25516E+00,-0.25481E+00,-0.25447E+00,-0.25412E+00,-0.25378E+00, & + -0.25343E+00,-0.25308E+00,-0.25273E+00,-0.25237E+00,-0.25202E+00, & + -0.25167E+00,-0.25131E+00,-0.25095E+00,-0.25060E+00,-0.25024E+00, & + -0.24988E+00,-0.24951E+00,-0.24915E+00,-0.24879E+00,-0.24843E+00, & + -0.24806E+00,-0.24770E+00,-0.24733E+00,-0.24696E+00,-0.24659E+00, & + -0.24623E+00,-0.24586E+00,-0.24549E+00,-0.24512E+00,-0.24475E+00, & + -0.24438E+00,-0.24400E+00,-0.24363E+00,-0.24326E+00,-0.24289E+00, & + -0.24251E+00,-0.24214E+00,-0.24176E+00,-0.24139E+00,-0.24101E+00, & + -0.24064E+00,-0.24026E+00,-0.23988E+00,-0.23951E+00,-0.23913E+00, & + -0.23875E+00,-0.23838E+00,-0.23800E+00,-0.23762E+00,-0.23724E+00, & + -0.23687E+00,-0.23649E+00,-0.23611E+00,-0.23573E+00,-0.23535E+00, & + -0.23498E+00,-0.23460E+00,-0.23422E+00,-0.23384E+00,-0.23346E+00, & + -0.23308E+00,-0.23270E+00,-0.23232E+00,-0.23195E+00,-0.23157E+00, & + -0.23119E+00,-0.23081E+00,-0.23043E+00,-0.23005E+00,-0.22968E+00/ + + DATA (BNC06M (I),I=201,300)/ & + -0.22930E+00,-0.22892E+00,-0.22854E+00,-0.22816E+00,-0.22779E+00, & + -0.22741E+00,-0.22703E+00,-0.22665E+00,-0.22628E+00,-0.22590E+00, & + -0.22552E+00,-0.22515E+00,-0.22477E+00,-0.22439E+00,-0.22402E+00, & + -0.22364E+00,-0.22327E+00,-0.22289E+00,-0.22252E+00,-0.22214E+00, & + -0.22177E+00,-0.22139E+00,-0.22102E+00,-0.22064E+00,-0.22027E+00, & + -0.21990E+00,-0.21953E+00,-0.21915E+00,-0.21878E+00,-0.21841E+00, & + -0.21804E+00,-0.21767E+00,-0.21729E+00,-0.21692E+00,-0.21655E+00, & + -0.21618E+00,-0.21581E+00,-0.21544E+00,-0.21508E+00,-0.21471E+00, & + -0.21434E+00,-0.21397E+00,-0.21360E+00,-0.21324E+00,-0.21287E+00, & + -0.21250E+00,-0.21214E+00,-0.21177E+00,-0.21141E+00,-0.21104E+00, & + -0.21068E+00,-0.21031E+00,-0.20995E+00,-0.20958E+00,-0.20922E+00, & + -0.20886E+00,-0.20850E+00,-0.20814E+00,-0.20777E+00,-0.20741E+00, & + -0.20705E+00,-0.20669E+00,-0.20633E+00,-0.20597E+00,-0.20561E+00, & + -0.20526E+00,-0.20490E+00,-0.20454E+00,-0.20418E+00,-0.20383E+00, & + -0.20347E+00,-0.20312E+00,-0.20276E+00,-0.20241E+00,-0.20205E+00, & + -0.20170E+00,-0.20134E+00,-0.20099E+00,-0.20064E+00,-0.20029E+00, & + -0.19993E+00,-0.19958E+00,-0.19923E+00,-0.19888E+00,-0.19853E+00, & + -0.19818E+00,-0.19783E+00,-0.19749E+00,-0.19714E+00,-0.19679E+00, & + -0.19644E+00,-0.19610E+00,-0.19575E+00,-0.19541E+00,-0.19506E+00, & + -0.19472E+00,-0.19437E+00,-0.19403E+00,-0.19369E+00,-0.19334E+00/ + + DATA (BNC06M (I),I=301,400)/ & + -0.19300E+00,-0.19266E+00,-0.19232E+00,-0.19198E+00,-0.19164E+00, & + -0.19130E+00,-0.19096E+00,-0.19062E+00,-0.19028E+00,-0.18994E+00, & + -0.18961E+00,-0.18927E+00,-0.18893E+00,-0.18860E+00,-0.18826E+00, & + -0.18793E+00,-0.18759E+00,-0.18726E+00,-0.18692E+00,-0.18659E+00, & + -0.18626E+00,-0.18593E+00,-0.18560E+00,-0.18526E+00,-0.18493E+00, & + -0.18460E+00,-0.18427E+00,-0.18395E+00,-0.18362E+00,-0.18329E+00, & + -0.18296E+00,-0.18263E+00,-0.18231E+00,-0.18198E+00,-0.18166E+00, & + -0.18133E+00,-0.18101E+00,-0.18068E+00,-0.18036E+00,-0.18004E+00, & + -0.17971E+00,-0.17939E+00,-0.17907E+00,-0.17875E+00,-0.17843E+00, & + -0.17811E+00,-0.17779E+00,-0.17747E+00,-0.17715E+00,-0.17683E+00, & + -0.17652E+00,-0.17620E+00,-0.17588E+00,-0.17557E+00,-0.17525E+00, & + -0.17493E+00,-0.17462E+00,-0.17431E+00,-0.17399E+00,-0.17368E+00, & + -0.17337E+00,-0.17305E+00,-0.17274E+00,-0.17243E+00,-0.17212E+00, & + -0.17181E+00,-0.17150E+00,-0.17119E+00,-0.17088E+00,-0.17057E+00, & + -0.17027E+00,-0.16996E+00,-0.16965E+00,-0.16934E+00,-0.16904E+00, & + -0.16873E+00,-0.16843E+00,-0.16812E+00,-0.16782E+00,-0.16752E+00, & + -0.16721E+00,-0.16691E+00,-0.16661E+00,-0.16631E+00,-0.16601E+00, & + -0.16571E+00,-0.16540E+00,-0.16511E+00,-0.16481E+00,-0.16451E+00, & + -0.16421E+00,-0.16391E+00,-0.16361E+00,-0.16332E+00,-0.16302E+00, & + -0.16273E+00,-0.16243E+00,-0.16213E+00,-0.16184E+00,-0.16155E+00/ + + DATA (BNC06M (I),I=401,500)/ & + -0.16125E+00,-0.16096E+00,-0.16067E+00,-0.16038E+00,-0.16008E+00, & + -0.15979E+00,-0.15950E+00,-0.15921E+00,-0.15892E+00,-0.15863E+00, & + -0.15834E+00,-0.15806E+00,-0.15777E+00,-0.15748E+00,-0.15719E+00, & + -0.15691E+00,-0.15662E+00,-0.15634E+00,-0.15605E+00,-0.15577E+00, & + -0.15548E+00,-0.15520E+00,-0.15492E+00,-0.15463E+00,-0.15435E+00, & + -0.15407E+00,-0.15379E+00,-0.15351E+00,-0.15323E+00,-0.15295E+00, & + -0.15267E+00,-0.15239E+00,-0.15211E+00,-0.15183E+00,-0.15155E+00, & + -0.15127E+00,-0.15100E+00,-0.15072E+00,-0.15045E+00,-0.15017E+00, & + -0.14990E+00,-0.14962E+00,-0.14935E+00,-0.14907E+00,-0.14880E+00, & + -0.14853E+00,-0.14825E+00,-0.14798E+00,-0.14771E+00,-0.14744E+00, & + -0.14717E+00,-0.14690E+00,-0.14663E+00,-0.14636E+00,-0.14609E+00, & + -0.14582E+00,-0.14555E+00,-0.14529E+00,-0.14502E+00,-0.14475E+00, & + -0.14449E+00,-0.14422E+00,-0.14396E+00,-0.14369E+00,-0.14343E+00, & + -0.14316E+00,-0.14290E+00,-0.14264E+00,-0.14237E+00,-0.14211E+00, & + -0.14185E+00,-0.14159E+00,-0.14133E+00,-0.14107E+00,-0.14081E+00, & + -0.14055E+00,-0.14029E+00,-0.14003E+00,-0.13977E+00,-0.13951E+00, & + -0.13925E+00,-0.13900E+00,-0.13874E+00,-0.13848E+00,-0.13823E+00, & + -0.13797E+00,-0.13772E+00,-0.13746E+00,-0.13721E+00,-0.13695E+00, & + -0.13670E+00,-0.13645E+00,-0.13619E+00,-0.13594E+00,-0.13569E+00, & + -0.13544E+00,-0.13519E+00,-0.13494E+00,-0.13469E+00,-0.13444E+00/ + + DATA (BNC06M (I),I=501,600)/ & + -0.13419E+00,-0.13394E+00,-0.13369E+00,-0.13344E+00,-0.13319E+00, & + -0.13295E+00,-0.13270E+00,-0.13245E+00,-0.13221E+00,-0.13196E+00, & + -0.13172E+00,-0.13147E+00,-0.13123E+00,-0.13098E+00,-0.13074E+00, & + -0.13050E+00,-0.13025E+00,-0.13001E+00,-0.12977E+00,-0.12953E+00, & + -0.12929E+00,-0.12904E+00,-0.12880E+00,-0.12856E+00,-0.12832E+00, & + -0.12808E+00,-0.12785E+00,-0.12761E+00,-0.12737E+00,-0.12713E+00, & + -0.12689E+00,-0.12666E+00,-0.12642E+00,-0.12618E+00,-0.12595E+00, & + -0.12571E+00,-0.12548E+00,-0.12524E+00,-0.12501E+00,-0.12477E+00, & + -0.12454E+00,-0.12431E+00,-0.12407E+00,-0.12384E+00,-0.12361E+00, & + -0.12338E+00,-0.12315E+00,-0.12292E+00,-0.12269E+00,-0.12246E+00, & + -0.12223E+00,-0.12200E+00,-0.12177E+00,-0.12154E+00,-0.12131E+00, & + -0.12108E+00,-0.12086E+00,-0.12063E+00,-0.12040E+00,-0.12017E+00, & + -0.11995E+00,-0.11972E+00,-0.11950E+00,-0.11927E+00,-0.11905E+00, & + -0.11882E+00,-0.11860E+00,-0.11838E+00,-0.11815E+00,-0.11793E+00, & + -0.11771E+00,-0.11749E+00,-0.11726E+00,-0.11704E+00,-0.11682E+00, & + -0.11660E+00,-0.11638E+00,-0.11616E+00,-0.11594E+00,-0.11572E+00, & + -0.11550E+00,-0.11529E+00,-0.11507E+00,-0.11485E+00,-0.11463E+00, & + -0.11441E+00,-0.11420E+00,-0.11398E+00,-0.11377E+00,-0.11355E+00, & + -0.11333E+00,-0.11312E+00,-0.11291E+00,-0.11269E+00,-0.11248E+00, & + -0.11226E+00,-0.11205E+00,-0.11184E+00,-0.11163E+00,-0.11083E+00/ + + DATA (BNC06M (I),I=601,700)/ & + -0.10910E+00,-0.10704E+00,-0.10500E+00,-0.10300E+00,-0.10104E+00, & + -0.99099E-01,-0.97194E-01,-0.95319E-01,-0.93474E-01,-0.91659E-01, & + -0.89872E-01,-0.88115E-01,-0.86385E-01,-0.84682E-01,-0.83007E-01, & + -0.81358E-01,-0.79736E-01,-0.78139E-01,-0.76568E-01,-0.75022E-01, & + -0.73500E-01,-0.72002E-01,-0.70529E-01,-0.69079E-01,-0.67651E-01, & + -0.66247E-01,-0.64865E-01,-0.63505E-01,-0.62167E-01,-0.60850E-01, & + -0.59554E-01,-0.58278E-01,-0.57024E-01,-0.55789E-01,-0.54574E-01, & + -0.53379E-01,-0.52203E-01,-0.51046E-01,-0.49908E-01,-0.48788E-01, & + -0.47686E-01,-0.46602E-01,-0.45536E-01,-0.44487E-01,-0.43456E-01, & + -0.42441E-01,-0.41444E-01,-0.40462E-01,-0.39497E-01,-0.38548E-01, & + -0.37615E-01,-0.36698E-01,-0.35795E-01,-0.34909E-01,-0.34037E-01, & + -0.33180E-01,-0.32337E-01,-0.31509E-01,-0.30696E-01,-0.29896E-01, & + -0.29110E-01,-0.28338E-01,-0.27580E-01,-0.26835E-01,-0.26103E-01, & + -0.25384E-01,-0.24679E-01,-0.23986E-01,-0.23305E-01,-0.22637E-01, & + -0.21981E-01,-0.21338E-01,-0.20706E-01,-0.20086E-01,-0.19479E-01, & + -0.18882E-01,-0.18297E-01,-0.17724E-01,-0.17161E-01,-0.16610E-01, & + -0.16070E-01,-0.15540E-01,-0.15021E-01,-0.14513E-01,-0.14015E-01, & + -0.13528E-01,-0.13050E-01,-0.12583E-01,-0.12126E-01,-0.11679E-01, & + -0.11242E-01,-0.10814E-01,-0.10396E-01,-0.99873E-02,-0.95880E-02, & + -0.91981E-02,-0.88174E-02,-0.84457E-02,-0.80831E-02,-0.77294E-02/ + + DATA (BNC06M(I),I=701,741)/ & + -0.73845E-02,-0.70483E-02,-0.67207E-02,-0.64018E-02,-0.60913E-02, & + -0.57891E-02,-0.54953E-02,-0.52096E-02,-0.49322E-02,-0.46628E-02, & + -0.44013E-02,-0.41478E-02,-0.39020E-02,-0.36641E-02,-0.34337E-02, & + -0.32110E-02,-0.29958E-02,-0.27881E-02,-0.25878E-02,-0.23947E-02, & + -0.22090E-02,-0.20303E-02,-0.18589E-02,-0.16944E-02,-0.15369E-02, & + -0.13864E-02,-0.12427E-02,-0.11058E-02,-0.97562E-03,-0.85213E-03, & + -0.73527E-03,-0.62494E-03,-0.52106E-03,-0.42366E-03,-0.33266E-03, & + -0.24793E-03,-0.16948E-03,-0.97253E-04,-0.31242E-04, 0.28753E-04, & + 0.82669E-04 & + / +! +! *** (2H, SO4) +! + DATA (BNC07M (I),I= 1,100)/ & + -0.10557E+00,-0.19245E+00,-0.25372E+00,-0.29547E+00,-0.32770E+00, & + -0.35411E+00,-0.37657E+00,-0.39614E+00,-0.41351E+00,-0.42914E+00, & + -0.44335E+00,-0.45638E+00,-0.46842E+00,-0.47961E+00,-0.49007E+00, & + -0.49989E+00,-0.50915E+00,-0.51790E+00,-0.52620E+00,-0.53409E+00, & + -0.54162E+00,-0.54882E+00,-0.55571E+00,-0.56233E+00,-0.56868E+00, & + -0.57480E+00,-0.58070E+00,-0.58640E+00,-0.59191E+00,-0.59724E+00, & + -0.60240E+00,-0.60741E+00,-0.61227E+00,-0.61699E+00,-0.62158E+00, & + -0.62605E+00,-0.63041E+00,-0.63465E+00,-0.63879E+00,-0.64283E+00, & + -0.64677E+00,-0.65063E+00,-0.65440E+00,-0.65808E+00,-0.66169E+00, & + -0.66522E+00,-0.66869E+00,-0.67208E+00,-0.67540E+00,-0.67867E+00, & + -0.68187E+00,-0.68501E+00,-0.68810E+00,-0.69113E+00,-0.69411E+00, & + -0.69704E+00,-0.69992E+00,-0.70275E+00,-0.70554E+00,-0.70829E+00, & + -0.71099E+00,-0.71365E+00,-0.71628E+00,-0.71886E+00,-0.72141E+00, & + -0.72392E+00,-0.72640E+00,-0.72885E+00,-0.73126E+00,-0.73364E+00, & + -0.73600E+00,-0.73832E+00,-0.74061E+00,-0.74288E+00,-0.74512E+00, & + -0.74733E+00,-0.74952E+00,-0.75169E+00,-0.75383E+00,-0.75594E+00, & + -0.75804E+00,-0.76011E+00,-0.76216E+00,-0.76419E+00,-0.76621E+00, & + -0.76820E+00,-0.77017E+00,-0.77212E+00,-0.77406E+00,-0.77598E+00, & + -0.77788E+00,-0.77976E+00,-0.78163E+00,-0.78348E+00,-0.78532E+00, & + -0.78714E+00,-0.78894E+00,-0.79073E+00,-0.79251E+00,-0.79427E+00/ + + DATA (BNC07M (I),I=101,200)/ & + -0.79602E+00,-0.79775E+00,-0.79948E+00,-0.80118E+00,-0.80288E+00, & + -0.80456E+00,-0.80623E+00,-0.80789E+00,-0.80954E+00,-0.81117E+00, & + -0.81280E+00,-0.81441E+00,-0.81601E+00,-0.81760E+00,-0.81918E+00, & + -0.82074E+00,-0.82230E+00,-0.82385E+00,-0.82538E+00,-0.82691E+00, & + -0.82841E+00,-0.82992E+00,-0.83142E+00,-0.83291E+00,-0.83439E+00, & + -0.83586E+00,-0.83732E+00,-0.83877E+00,-0.84022E+00,-0.84165E+00, & + -0.84308E+00,-0.84449E+00,-0.84590E+00,-0.84730E+00,-0.84870E+00, & + -0.85008E+00,-0.85146E+00,-0.85283E+00,-0.85419E+00,-0.85554E+00, & + -0.85689E+00,-0.85823E+00,-0.85956E+00,-0.86088E+00,-0.86220E+00, & + -0.86351E+00,-0.86481E+00,-0.86611E+00,-0.86740E+00,-0.86868E+00, & + -0.86996E+00,-0.87123E+00,-0.87249E+00,-0.87375E+00,-0.87500E+00, & + -0.87625E+00,-0.87749E+00,-0.87872E+00,-0.87995E+00,-0.88117E+00, & + -0.88239E+00,-0.88360E+00,-0.88480E+00,-0.88600E+00,-0.88720E+00, & + -0.88839E+00,-0.88957E+00,-0.89075E+00,-0.89192E+00,-0.89309E+00, & + -0.89425E+00,-0.89541E+00,-0.89656E+00,-0.89771E+00,-0.89885E+00, & + -0.89999E+00,-0.90112E+00,-0.90225E+00,-0.90337E+00,-0.90449E+00, & + -0.90561E+00,-0.90672E+00,-0.90783E+00,-0.90893E+00,-0.91002E+00, & + -0.91112E+00,-0.91221E+00,-0.91329E+00,-0.91437E+00,-0.91545E+00, & + -0.91652E+00,-0.91759E+00,-0.91865E+00,-0.91971E+00,-0.92077E+00, & + -0.92182E+00,-0.92287E+00,-0.92392E+00,-0.92496E+00,-0.92600E+00/ + + DATA (BNC07M (I),I=201,300)/ & + -0.92703E+00,-0.92806E+00,-0.92909E+00,-0.93011E+00,-0.93113E+00, & + -0.93215E+00,-0.93316E+00,-0.93417E+00,-0.93518E+00,-0.93618E+00, & + -0.93718E+00,-0.93817E+00,-0.93917E+00,-0.94016E+00,-0.94114E+00, & + -0.94213E+00,-0.94311E+00,-0.94408E+00,-0.94506E+00,-0.94603E+00, & + -0.94700E+00,-0.94796E+00,-0.94892E+00,-0.94988E+00,-0.95084E+00, & + -0.95179E+00,-0.95274E+00,-0.95369E+00,-0.95463E+00,-0.95557E+00, & + -0.95651E+00,-0.95745E+00,-0.95838E+00,-0.95931E+00,-0.96024E+00, & + -0.96117E+00,-0.96209E+00,-0.96301E+00,-0.96393E+00,-0.96484E+00, & + -0.96576E+00,-0.96667E+00,-0.96758E+00,-0.96848E+00,-0.96938E+00, & + -0.97028E+00,-0.97118E+00,-0.97208E+00,-0.97297E+00,-0.97386E+00, & + -0.97475E+00,-0.97563E+00,-0.97652E+00,-0.97740E+00,-0.97828E+00, & + -0.97916E+00,-0.98003E+00,-0.98090E+00,-0.98177E+00,-0.98264E+00, & + -0.98351E+00,-0.98437E+00,-0.98523E+00,-0.98609E+00,-0.98695E+00, & + -0.98780E+00,-0.98866E+00,-0.98951E+00,-0.99036E+00,-0.99120E+00, & + -0.99205E+00,-0.99289E+00,-0.99373E+00,-0.99457E+00,-0.99541E+00, & + -0.99625E+00,-0.99708E+00,-0.99791E+00,-0.99874E+00,-0.99957E+00, & + -0.10004E+01,-0.10012E+01,-0.10020E+01,-0.10029E+01,-0.10037E+01, & + -0.10045E+01,-0.10053E+01,-0.10061E+01,-0.10069E+01,-0.10077E+01, & + -0.10086E+01,-0.10094E+01,-0.10102E+01,-0.10110E+01,-0.10118E+01, & + -0.10126E+01,-0.10134E+01,-0.10142E+01,-0.10150E+01,-0.10157E+01/ + + DATA (BNC07M (I),I=301,400)/ & + -0.10165E+01,-0.10173E+01,-0.10181E+01,-0.10189E+01,-0.10197E+01, & + -0.10205E+01,-0.10212E+01,-0.10220E+01,-0.10228E+01,-0.10236E+01, & + -0.10244E+01,-0.10251E+01,-0.10259E+01,-0.10267E+01,-0.10274E+01, & + -0.10282E+01,-0.10290E+01,-0.10297E+01,-0.10305E+01,-0.10313E+01, & + -0.10320E+01,-0.10328E+01,-0.10335E+01,-0.10343E+01,-0.10351E+01, & + -0.10358E+01,-0.10366E+01,-0.10373E+01,-0.10381E+01,-0.10388E+01, & + -0.10396E+01,-0.10403E+01,-0.10410E+01,-0.10418E+01,-0.10425E+01, & + -0.10433E+01,-0.10440E+01,-0.10447E+01,-0.10455E+01,-0.10462E+01, & + -0.10469E+01,-0.10477E+01,-0.10484E+01,-0.10491E+01,-0.10499E+01, & + -0.10506E+01,-0.10513E+01,-0.10520E+01,-0.10528E+01,-0.10535E+01, & + -0.10542E+01,-0.10549E+01,-0.10557E+01,-0.10564E+01,-0.10571E+01, & + -0.10578E+01,-0.10585E+01,-0.10592E+01,-0.10599E+01,-0.10606E+01, & + -0.10614E+01,-0.10621E+01,-0.10628E+01,-0.10635E+01,-0.10642E+01, & + -0.10649E+01,-0.10656E+01,-0.10663E+01,-0.10670E+01,-0.10677E+01, & + -0.10684E+01,-0.10691E+01,-0.10698E+01,-0.10705E+01,-0.10712E+01, & + -0.10719E+01,-0.10726E+01,-0.10733E+01,-0.10739E+01,-0.10746E+01, & + -0.10753E+01,-0.10760E+01,-0.10767E+01,-0.10774E+01,-0.10781E+01, & + -0.10787E+01,-0.10794E+01,-0.10801E+01,-0.10808E+01,-0.10815E+01, & + -0.10821E+01,-0.10828E+01,-0.10835E+01,-0.10842E+01,-0.10848E+01, & + -0.10855E+01,-0.10862E+01,-0.10869E+01,-0.10875E+01,-0.10882E+01/ + + DATA (BNC07M (I),I=401,500)/ & + -0.10889E+01,-0.10895E+01,-0.10902E+01,-0.10909E+01,-0.10915E+01, & + -0.10922E+01,-0.10929E+01,-0.10935E+01,-0.10942E+01,-0.10948E+01, & + -0.10955E+01,-0.10962E+01,-0.10968E+01,-0.10975E+01,-0.10981E+01, & + -0.10988E+01,-0.10994E+01,-0.11001E+01,-0.11008E+01,-0.11014E+01, & + -0.11021E+01,-0.11027E+01,-0.11034E+01,-0.11040E+01,-0.11047E+01, & + -0.11053E+01,-0.11059E+01,-0.11066E+01,-0.11072E+01,-0.11079E+01, & + -0.11085E+01,-0.11092E+01,-0.11098E+01,-0.11104E+01,-0.11111E+01, & + -0.11117E+01,-0.11124E+01,-0.11130E+01,-0.11136E+01,-0.11143E+01, & + -0.11149E+01,-0.11155E+01,-0.11162E+01,-0.11168E+01,-0.11174E+01, & + -0.11181E+01,-0.11187E+01,-0.11193E+01,-0.11200E+01,-0.11206E+01, & + -0.11212E+01,-0.11218E+01,-0.11225E+01,-0.11231E+01,-0.11237E+01, & + -0.11243E+01,-0.11250E+01,-0.11256E+01,-0.11262E+01,-0.11268E+01, & + -0.11274E+01,-0.11281E+01,-0.11287E+01,-0.11293E+01,-0.11299E+01, & + -0.11305E+01,-0.11312E+01,-0.11318E+01,-0.11324E+01,-0.11330E+01, & + -0.11336E+01,-0.11342E+01,-0.11348E+01,-0.11355E+01,-0.11361E+01, & + -0.11367E+01,-0.11373E+01,-0.11379E+01,-0.11385E+01,-0.11391E+01, & + -0.11397E+01,-0.11403E+01,-0.11409E+01,-0.11415E+01,-0.11421E+01, & + -0.11427E+01,-0.11433E+01,-0.11439E+01,-0.11445E+01,-0.11451E+01, & + -0.11457E+01,-0.11463E+01,-0.11469E+01,-0.11475E+01,-0.11481E+01, & + -0.11487E+01,-0.11493E+01,-0.11499E+01,-0.11505E+01,-0.11511E+01/ + + DATA (BNC07M (I),I=501,600)/ & + -0.11517E+01,-0.11523E+01,-0.11529E+01,-0.11535E+01,-0.11541E+01, & + -0.11547E+01,-0.11553E+01,-0.11559E+01,-0.11565E+01,-0.11570E+01, & + -0.11576E+01,-0.11582E+01,-0.11588E+01,-0.11594E+01,-0.11600E+01, & + -0.11606E+01,-0.11612E+01,-0.11617E+01,-0.11623E+01,-0.11629E+01, & + -0.11635E+01,-0.11641E+01,-0.11647E+01,-0.11652E+01,-0.11658E+01, & + -0.11664E+01,-0.11670E+01,-0.11676E+01,-0.11681E+01,-0.11687E+01, & + -0.11693E+01,-0.11699E+01,-0.11704E+01,-0.11710E+01,-0.11716E+01, & + -0.11722E+01,-0.11728E+01,-0.11733E+01,-0.11739E+01,-0.11745E+01, & + -0.11750E+01,-0.11756E+01,-0.11762E+01,-0.11768E+01,-0.11773E+01, & + -0.11779E+01,-0.11785E+01,-0.11790E+01,-0.11796E+01,-0.11802E+01, & + -0.11807E+01,-0.11813E+01,-0.11819E+01,-0.11824E+01,-0.11830E+01, & + -0.11836E+01,-0.11841E+01,-0.11847E+01,-0.11853E+01,-0.11858E+01, & + -0.11864E+01,-0.11870E+01,-0.11875E+01,-0.11881E+01,-0.11886E+01, & + -0.11892E+01,-0.11898E+01,-0.11903E+01,-0.11909E+01,-0.11914E+01, & + -0.11920E+01,-0.11925E+01,-0.11931E+01,-0.11937E+01,-0.11942E+01, & + -0.11948E+01,-0.11953E+01,-0.11959E+01,-0.11964E+01,-0.11970E+01, & + -0.11975E+01,-0.11981E+01,-0.11987E+01,-0.11992E+01,-0.11998E+01, & + -0.12003E+01,-0.12009E+01,-0.12014E+01,-0.12020E+01,-0.12025E+01, & + -0.12031E+01,-0.12036E+01,-0.12042E+01,-0.12047E+01,-0.12053E+01, & + -0.12058E+01,-0.12063E+01,-0.12069E+01,-0.12074E+01,-0.12095E+01/ + + DATA (BNC07M (I),I=601,700)/ & + -0.12140E+01,-0.12193E+01,-0.12247E+01,-0.12300E+01,-0.12353E+01, & + -0.12405E+01,-0.12457E+01,-0.12509E+01,-0.12560E+01,-0.12611E+01, & + -0.12662E+01,-0.12712E+01,-0.12763E+01,-0.12812E+01,-0.12862E+01, & + -0.12911E+01,-0.12960E+01,-0.13009E+01,-0.13058E+01,-0.13106E+01, & + -0.13154E+01,-0.13202E+01,-0.13250E+01,-0.13297E+01,-0.13344E+01, & + -0.13391E+01,-0.13438E+01,-0.13484E+01,-0.13531E+01,-0.13577E+01, & + -0.13623E+01,-0.13669E+01,-0.13714E+01,-0.13760E+01,-0.13805E+01, & + -0.13850E+01,-0.13895E+01,-0.13940E+01,-0.13984E+01,-0.14029E+01, & + -0.14073E+01,-0.14117E+01,-0.14161E+01,-0.14205E+01,-0.14249E+01, & + -0.14292E+01,-0.14336E+01,-0.14379E+01,-0.14422E+01,-0.14465E+01, & + -0.14508E+01,-0.14551E+01,-0.14593E+01,-0.14636E+01,-0.14678E+01, & + -0.14720E+01,-0.14763E+01,-0.14805E+01,-0.14847E+01,-0.14888E+01, & + -0.14930E+01,-0.14972E+01,-0.15013E+01,-0.15055E+01,-0.15096E+01, & + -0.15137E+01,-0.15178E+01,-0.15219E+01,-0.15260E+01,-0.15301E+01, & + -0.15341E+01,-0.15382E+01,-0.15423E+01,-0.15463E+01,-0.15503E+01, & + -0.15544E+01,-0.15584E+01,-0.15624E+01,-0.15664E+01,-0.15704E+01, & + -0.15744E+01,-0.15783E+01,-0.15823E+01,-0.15863E+01,-0.15902E+01, & + -0.15941E+01,-0.15981E+01,-0.16020E+01,-0.16059E+01,-0.16098E+01, & + -0.16138E+01,-0.16176E+01,-0.16215E+01,-0.16254E+01,-0.16293E+01, & + -0.16332E+01,-0.16370E+01,-0.16409E+01,-0.16448E+01,-0.16486E+01/ + + DATA (BNC07M(I),I=701,741)/ & + -0.16524E+01,-0.16563E+01,-0.16601E+01,-0.16639E+01,-0.16677E+01, & + -0.16715E+01,-0.16753E+01,-0.16791E+01,-0.16829E+01,-0.16867E+01, & + -0.16905E+01,-0.16943E+01,-0.16980E+01,-0.17018E+01,-0.17055E+01, & + -0.17093E+01,-0.17130E+01,-0.17168E+01,-0.17205E+01,-0.17243E+01, & + -0.17280E+01,-0.17317E+01,-0.17354E+01,-0.17391E+01,-0.17428E+01, & + -0.17465E+01,-0.17502E+01,-0.17539E+01,-0.17576E+01,-0.17613E+01, & + -0.17650E+01,-0.17686E+01,-0.17723E+01,-0.17760E+01,-0.17796E+01, & + -0.17833E+01,-0.17869E+01,-0.17906E+01,-0.17942E+01,-0.17978E+01, & + -0.18015E+01 & + / +! +! *** (H, HSO4) +! + DATA (BNC08M (I),I= 1,100)/ & + -0.49133E-01,-0.83570E-01,-0.10389E+00,-0.11538E+00,-0.12265E+00, & + -0.12736E+00,-0.13032E+00,-0.13201E+00,-0.13270E+00,-0.13259E+00, & + -0.13182E+00,-0.13049E+00,-0.12867E+00,-0.12642E+00,-0.12378E+00, & + -0.12080E+00,-0.11750E+00,-0.11391E+00,-0.11005E+00,-0.10594E+00, & + -0.10160E+00,-0.97035E-01,-0.92266E-01,-0.87301E-01,-0.82151E-01, & + -0.76825E-01,-0.71330E-01,-0.65676E-01,-0.59869E-01,-0.53917E-01, & + -0.47824E-01,-0.41599E-01,-0.35245E-01,-0.28770E-01,-0.22177E-01, & + -0.15472E-01,-0.86592E-02,-0.17436E-02, 0.52706E-02, 0.12379E-01, & + 0.19579E-01, 0.26864E-01, 0.34233E-01, 0.41682E-01, 0.49206E-01, & + 0.56803E-01, 0.64470E-01, 0.72204E-01, 0.80002E-01, 0.87862E-01, & + 0.95780E-01, 0.10376E+00, 0.11179E+00, 0.11987E+00, 0.12800E+00, & + 0.13618E+00, 0.14441E+00, 0.15269E+00, 0.16101E+00, 0.16938E+00, & + 0.17779E+00, 0.18624E+00, 0.19473E+00, 0.20327E+00, 0.21184E+00, & + 0.22046E+00, 0.22912E+00, 0.23782E+00, 0.24656E+00, 0.25534E+00, & + 0.26416E+00, 0.27303E+00, 0.28194E+00, 0.29089E+00, 0.29989E+00, & + 0.30893E+00, 0.31802E+00, 0.32715E+00, 0.33633E+00, 0.34556E+00, & + 0.35483E+00, 0.36415E+00, 0.37353E+00, 0.38295E+00, 0.39242E+00, & + 0.40194E+00, 0.41151E+00, 0.42113E+00, 0.43079E+00, 0.44051E+00, & + 0.45028E+00, 0.46009E+00, 0.46995E+00, 0.47986E+00, 0.48982E+00, & + 0.49981E+00, 0.50986E+00, 0.51994E+00, 0.53006E+00, 0.54023E+00/ + + DATA (BNC08M (I),I=101,200)/ & + 0.55043E+00, 0.56067E+00, 0.57094E+00, 0.58125E+00, 0.59158E+00, & + 0.60195E+00, 0.61234E+00, 0.62276E+00, 0.63320E+00, 0.64367E+00, & + 0.65415E+00, 0.66465E+00, 0.67516E+00, 0.68569E+00, 0.69624E+00, & + 0.70679E+00, 0.71735E+00, 0.72792E+00, 0.73849E+00, 0.74907E+00, & + 0.75876E+00, 0.76945E+00, 0.78012E+00, 0.79078E+00, 0.80143E+00, & + 0.81207E+00, 0.82269E+00, 0.83330E+00, 0.84390E+00, 0.85449E+00, & + 0.86506E+00, 0.87561E+00, 0.88616E+00, 0.89668E+00, 0.90719E+00, & + 0.91769E+00, 0.92817E+00, 0.93863E+00, 0.94908E+00, 0.95951E+00, & + 0.96993E+00, 0.98032E+00, 0.99070E+00, 0.10011E+01, 0.10114E+01, & + 0.10217E+01, 0.10320E+01, 0.10423E+01, 0.10526E+01, 0.10629E+01, & + 0.10731E+01, 0.10833E+01, 0.10935E+01, 0.11037E+01, 0.11138E+01, & + 0.11240E+01, 0.11341E+01, 0.11442E+01, 0.11543E+01, 0.11644E+01, & + 0.11744E+01, 0.11844E+01, 0.11944E+01, 0.12044E+01, 0.12144E+01, & + 0.12243E+01, 0.12342E+01, 0.12441E+01, 0.12540E+01, 0.12639E+01, & + 0.12737E+01, 0.12835E+01, 0.12933E+01, 0.13031E+01, 0.13129E+01, & + 0.13226E+01, 0.13323E+01, 0.13420E+01, 0.13517E+01, 0.13614E+01, & + 0.13710E+01, 0.13806E+01, 0.13902E+01, 0.13998E+01, 0.14093E+01, & + 0.14189E+01, 0.14284E+01, 0.14379E+01, 0.14474E+01, 0.14568E+01, & + 0.14662E+01, 0.14756E+01, 0.14850E+01, 0.14944E+01, 0.15038E+01, & + 0.15131E+01, 0.15224E+01, 0.15317E+01, 0.15410E+01, 0.15502E+01/ + + DATA (BNC08M (I),I=201,300)/ & + 0.15594E+01, 0.15687E+01, 0.15778E+01, 0.15870E+01, 0.15962E+01, & + 0.16053E+01, 0.16144E+01, 0.16235E+01, 0.16326E+01, 0.16416E+01, & + 0.16507E+01, 0.16597E+01, 0.16687E+01, 0.16776E+01, 0.16866E+01, & + 0.16955E+01, 0.17044E+01, 0.17133E+01, 0.17222E+01, 0.17311E+01, & + 0.17399E+01, 0.17487E+01, 0.17575E+01, 0.17663E+01, 0.17751E+01, & + 0.17838E+01, 0.17925E+01, 0.18012E+01, 0.18099E+01, 0.18186E+01, & + 0.18272E+01, 0.18359E+01, 0.18445E+01, 0.18531E+01, 0.18616E+01, & + 0.18702E+01, 0.18787E+01, 0.18872E+01, 0.18958E+01, 0.19042E+01, & + 0.19127E+01, 0.19211E+01, 0.19296E+01, 0.19380E+01, 0.19464E+01, & + 0.19548E+01, 0.19631E+01, 0.19715E+01, 0.19798E+01, 0.19881E+01, & + 0.19964E+01, 0.20046E+01, 0.20129E+01, 0.20211E+01, 0.20293E+01, & + 0.20375E+01, 0.20457E+01, 0.20539E+01, 0.20620E+01, 0.20702E+01, & + 0.20783E+01, 0.20864E+01, 0.20945E+01, 0.21025E+01, 0.21106E+01, & + 0.21186E+01, 0.21266E+01, 0.21346E+01, 0.21426E+01, 0.21506E+01, & + 0.21585E+01, 0.21665E+01, 0.21744E+01, 0.21823E+01, 0.21902E+01, & + 0.21980E+01, 0.22059E+01, 0.22137E+01, 0.22215E+01, 0.22294E+01, & + 0.22371E+01, 0.22449E+01, 0.22527E+01, 0.22604E+01, 0.22681E+01, & + 0.22759E+01, 0.22835E+01, 0.22912E+01, 0.22989E+01, 0.23065E+01, & + 0.23142E+01, 0.23218E+01, 0.23294E+01, 0.23370E+01, 0.23446E+01, & + 0.23521E+01, 0.23597E+01, 0.23672E+01, 0.23747E+01, 0.23822E+01/ + + DATA (BNC08M (I),I=301,400)/ & + 0.23897E+01, 0.23972E+01, 0.24046E+01, 0.24121E+01, 0.24195E+01, & + 0.24269E+01, 0.24343E+01, 0.24417E+01, 0.24490E+01, 0.24564E+01, & + 0.24637E+01, 0.24711E+01, 0.24784E+01, 0.24857E+01, 0.24930E+01, & + 0.25002E+01, 0.25075E+01, 0.25147E+01, 0.25220E+01, 0.25292E+01, & + 0.25364E+01, 0.25436E+01, 0.25507E+01, 0.25579E+01, 0.25650E+01, & + 0.25722E+01, 0.25793E+01, 0.25864E+01, 0.25935E+01, 0.26006E+01, & + 0.26076E+01, 0.26147E+01, 0.26217E+01, 0.26288E+01, 0.26358E+01, & + 0.26428E+01, 0.26498E+01, 0.26567E+01, 0.26637E+01, 0.26706E+01, & + 0.26776E+01, 0.26845E+01, 0.26914E+01, 0.26983E+01, 0.27052E+01, & + 0.27121E+01, 0.27189E+01, 0.27258E+01, 0.27326E+01, 0.27394E+01, & + 0.27463E+01, 0.27531E+01, 0.27598E+01, 0.27666E+01, 0.27734E+01, & + 0.27801E+01, 0.27869E+01, 0.27936E+01, 0.28003E+01, 0.28070E+01, & + 0.28137E+01, 0.28204E+01, 0.28270E+01, 0.28337E+01, 0.28403E+01, & + 0.28470E+01, 0.28536E+01, 0.28602E+01, 0.28668E+01, 0.28734E+01, & + 0.28799E+01, 0.28865E+01, 0.28930E+01, 0.28996E+01, 0.29061E+01, & + 0.29126E+01, 0.29191E+01, 0.29256E+01, 0.29321E+01, 0.29386E+01, & + 0.29450E+01, 0.29515E+01, 0.29579E+01, 0.29643E+01, 0.29708E+01, & + 0.29772E+01, 0.29835E+01, 0.29899E+01, 0.29963E+01, 0.30027E+01, & + 0.30090E+01, 0.30153E+01, 0.30217E+01, 0.30280E+01, 0.30343E+01, & + 0.30406E+01, 0.30469E+01, 0.30531E+01, 0.30594E+01, 0.30657E+01/ + + DATA (BNC08M (I),I=401,500)/ & + 0.30719E+01, 0.30781E+01, 0.30844E+01, 0.30906E+01, 0.30968E+01, & + 0.31030E+01, 0.31091E+01, 0.31153E+01, 0.31215E+01, 0.31276E+01, & + 0.31338E+01, 0.31399E+01, 0.31460E+01, 0.31521E+01, 0.31582E+01, & + 0.31643E+01, 0.31704E+01, 0.31764E+01, 0.31825E+01, 0.31886E+01, & + 0.31946E+01, 0.32006E+01, 0.32066E+01, 0.32127E+01, 0.32187E+01, & + 0.32246E+01, 0.32306E+01, 0.32366E+01, 0.32426E+01, 0.32485E+01, & + 0.32545E+01, 0.32604E+01, 0.32663E+01, 0.32722E+01, 0.32781E+01, & + 0.32840E+01, 0.32899E+01, 0.32958E+01, 0.33017E+01, 0.33075E+01, & + 0.33134E+01, 0.33192E+01, 0.33250E+01, 0.33309E+01, 0.33367E+01, & + 0.33425E+01, 0.33483E+01, 0.33540E+01, 0.33598E+01, 0.33656E+01, & + 0.33713E+01, 0.33771E+01, 0.33828E+01, 0.33886E+01, 0.33943E+01, & + 0.34000E+01, 0.34057E+01, 0.34114E+01, 0.34171E+01, 0.34228E+01, & + 0.34284E+01, 0.34341E+01, 0.34397E+01, 0.34454E+01, 0.34510E+01, & + 0.34567E+01, 0.34623E+01, 0.34679E+01, 0.34735E+01, 0.34791E+01, & + 0.34847E+01, 0.34902E+01, 0.34958E+01, 0.35014E+01, 0.35069E+01, & + 0.35124E+01, 0.35180E+01, 0.35235E+01, 0.35290E+01, 0.35345E+01, & + 0.35400E+01, 0.35455E+01, 0.35510E+01, 0.35565E+01, 0.35620E+01, & + 0.35674E+01, 0.35729E+01, 0.35783E+01, 0.35837E+01, 0.35892E+01, & + 0.35946E+01, 0.36000E+01, 0.36054E+01, 0.36108E+01, 0.36162E+01, & + 0.36216E+01, 0.36269E+01, 0.36323E+01, 0.36377E+01, 0.36430E+01/ + + DATA (BNC08M (I),I=501,600)/ & + 0.36483E+01, 0.36537E+01, 0.36590E+01, 0.36643E+01, 0.36696E+01, & + 0.36749E+01, 0.36802E+01, 0.36855E+01, 0.36908E+01, 0.36961E+01, & + 0.37013E+01, 0.37066E+01, 0.37118E+01, 0.37171E+01, 0.37223E+01, & + 0.37275E+01, 0.37328E+01, 0.37380E+01, 0.37432E+01, 0.37484E+01, & + 0.37536E+01, 0.37588E+01, 0.37639E+01, 0.37691E+01, 0.37743E+01, & + 0.37794E+01, 0.37846E+01, 0.37897E+01, 0.37948E+01, 0.38000E+01, & + 0.38051E+01, 0.38102E+01, 0.38153E+01, 0.38204E+01, 0.38255E+01, & + 0.38305E+01, 0.38356E+01, 0.38407E+01, 0.38458E+01, 0.38508E+01, & + 0.38559E+01, 0.38609E+01, 0.38659E+01, 0.38710E+01, 0.38760E+01, & + 0.38810E+01, 0.38860E+01, 0.38910E+01, 0.38960E+01, 0.39010E+01, & + 0.39059E+01, 0.39109E+01, 0.39159E+01, 0.39208E+01, 0.39258E+01, & + 0.39307E+01, 0.39357E+01, 0.39406E+01, 0.39455E+01, 0.39504E+01, & + 0.39554E+01, 0.39603E+01, 0.39652E+01, 0.39701E+01, 0.39749E+01, & + 0.39798E+01, 0.39847E+01, 0.39896E+01, 0.39944E+01, 0.39993E+01, & + 0.40041E+01, 0.40090E+01, 0.40138E+01, 0.40186E+01, 0.40234E+01, & + 0.40283E+01, 0.40331E+01, 0.40379E+01, 0.40427E+01, 0.40475E+01, & + 0.40522E+01, 0.40570E+01, 0.40618E+01, 0.40665E+01, 0.40713E+01, & + 0.40761E+01, 0.40808E+01, 0.40855E+01, 0.40903E+01, 0.40950E+01, & + 0.40997E+01, 0.41044E+01, 0.41091E+01, 0.41138E+01, 0.41185E+01, & + 0.41232E+01, 0.41279E+01, 0.41326E+01, 0.41373E+01, 0.41547E+01/ + + DATA (BNC08M (I),I=601,700)/ & + 0.41929E+01, 0.42386E+01, 0.42837E+01, 0.43283E+01, 0.43723E+01, & + 0.44159E+01, 0.44588E+01, 0.45013E+01, 0.45433E+01, 0.45849E+01, & + 0.46259E+01, 0.46665E+01, 0.47066E+01, 0.47463E+01, 0.47856E+01, & + 0.48244E+01, 0.48628E+01, 0.49008E+01, 0.49384E+01, 0.49757E+01, & + 0.50125E+01, 0.50490E+01, 0.50851E+01, 0.51208E+01, 0.51562E+01, & + 0.51912E+01, 0.52259E+01, 0.52603E+01, 0.52943E+01, 0.53280E+01, & + 0.53614E+01, 0.53945E+01, 0.54273E+01, 0.54598E+01, 0.54919E+01, & + 0.55238E+01, 0.55554E+01, 0.55868E+01, 0.56178E+01, 0.56486E+01, & + 0.56791E+01, 0.57094E+01, 0.57394E+01, 0.57691E+01, 0.57986E+01, & + 0.58279E+01, 0.58569E+01, 0.58856E+01, 0.59142E+01, 0.59425E+01, & + 0.59705E+01, 0.59984E+01, 0.60260E+01, 0.60534E+01, 0.60807E+01, & + 0.61076E+01, 0.61344E+01, 0.61610E+01, 0.61874E+01, 0.62136E+01, & + 0.62396E+01, 0.62653E+01, 0.62909E+01, 0.63164E+01, 0.63416E+01, & + 0.63666E+01, 0.63915E+01, 0.64162E+01, 0.64407E+01, 0.64650E+01, & + 0.64892E+01, 0.65132E+01, 0.65370E+01, 0.65607E+01, 0.65842E+01, & + 0.66076E+01, 0.66308E+01, 0.66538E+01, 0.66767E+01, 0.66994E+01, & + 0.67220E+01, 0.67444E+01, 0.67667E+01, 0.67889E+01, 0.68108E+01, & + 0.68327E+01, 0.68544E+01, 0.68760E+01, 0.68974E+01, 0.69188E+01, & + 0.69399E+01, 0.69610E+01, 0.69819E+01, 0.70027E+01, 0.70233E+01, & + 0.70439E+01, 0.70643E+01, 0.70846E+01, 0.71047E+01, 0.71248E+01/ + + DATA (BNC08M(I),I=701,741)/ & + 0.71447E+01, 0.71645E+01, 0.71842E+01, 0.72038E+01, 0.72233E+01, & + 0.72426E+01, 0.72619E+01, 0.72810E+01, 0.73000E+01, 0.73189E+01, & + 0.73378E+01, 0.73565E+01, 0.73751E+01, 0.73936E+01, 0.74120E+01, & + 0.74303E+01, 0.74484E+01, 0.74665E+01, 0.74845E+01, 0.75024E+01, & + 0.75203E+01, 0.75380E+01, 0.75556E+01, 0.75731E+01, 0.75905E+01, & + 0.76079E+01, 0.76251E+01, 0.76423E+01, 0.76593E+01, 0.76763E+01, & + 0.76932E+01, 0.77100E+01, 0.77268E+01, 0.77434E+01, 0.77600E+01, & + 0.77764E+01, 0.77928E+01, 0.78091E+01, 0.78253E+01, 0.78415E+01, & + 0.78576E+01 & + / +! +! *** NH4HSO4 +! + DATA (BNC09M (I),I= 1,100)/ & + -0.51701E-01,-0.92605E-01,-0.12047E+00,-0.13892E+00,-0.15280E+00, & + -0.16389E+00,-0.17309E+00,-0.18091E+00,-0.18765E+00,-0.19355E+00, & + -0.19875E+00,-0.20336E+00,-0.20748E+00,-0.21116E+00,-0.21445E+00, & + -0.21741E+00,-0.22006E+00,-0.22244E+00,-0.22456E+00,-0.22646E+00, & + -0.22813E+00,-0.22961E+00,-0.23090E+00,-0.23202E+00,-0.23297E+00, & + -0.23377E+00,-0.23442E+00,-0.23493E+00,-0.23531E+00,-0.23556E+00, & + -0.23569E+00,-0.23570E+00,-0.23561E+00,-0.23540E+00,-0.23510E+00, & + -0.23469E+00,-0.23419E+00,-0.23360E+00,-0.23293E+00,-0.23217E+00, & + -0.23132E+00,-0.23040E+00,-0.22941E+00,-0.22834E+00,-0.22720E+00, & + -0.22599E+00,-0.22471E+00,-0.22338E+00,-0.22198E+00,-0.22052E+00, & + -0.21901E+00,-0.21744E+00,-0.21582E+00,-0.21415E+00,-0.21242E+00, & + -0.21065E+00,-0.20884E+00,-0.20697E+00,-0.20507E+00,-0.20312E+00, & + -0.20113E+00,-0.19910E+00,-0.19703E+00,-0.19493E+00,-0.19278E+00, & + -0.19060E+00,-0.18839E+00,-0.18614E+00,-0.18386E+00,-0.18154E+00, & + -0.17919E+00,-0.17681E+00,-0.17440E+00,-0.17196E+00,-0.16948E+00, & + -0.16698E+00,-0.16445E+00,-0.16188E+00,-0.15929E+00,-0.15667E+00, & + -0.15402E+00,-0.15134E+00,-0.14864E+00,-0.14590E+00,-0.14314E+00, & + -0.14035E+00,-0.13754E+00,-0.13470E+00,-0.13183E+00,-0.12894E+00, & + -0.12602E+00,-0.12308E+00,-0.12011E+00,-0.11713E+00,-0.11411E+00, & + -0.11108E+00,-0.10803E+00,-0.10495E+00,-0.10186E+00,-0.98742E-01/ + + DATA (BNC09M (I),I=101,200)/ & + -0.95609E-01,-0.92458E-01,-0.89291E-01,-0.86108E-01,-0.82909E-01, & + -0.79696E-01,-0.76469E-01,-0.73230E-01,-0.69979E-01,-0.66717E-01, & + -0.63445E-01,-0.60163E-01,-0.56873E-01,-0.53575E-01,-0.50270E-01, & + -0.46959E-01,-0.43642E-01,-0.40321E-01,-0.36995E-01,-0.33666E-01, & + -0.30646E-01,-0.27276E-01,-0.23908E-01,-0.20542E-01,-0.17179E-01, & + -0.13818E-01,-0.10461E-01,-0.71064E-02,-0.37554E-02,-0.40779E-03, & + 0.29358E-02, 0.62756E-02, 0.96112E-02, 0.12942E-01, 0.16269E-01, & + 0.19592E-01, 0.22909E-01, 0.26221E-01, 0.29529E-01, 0.32832E-01, & + 0.36129E-01, 0.39420E-01, 0.42706E-01, 0.45987E-01, 0.49262E-01, & + 0.52531E-01, 0.55794E-01, 0.59051E-01, 0.62303E-01, 0.65548E-01, & + 0.68786E-01, 0.72019E-01, 0.75245E-01, 0.78465E-01, 0.81678E-01, & + 0.84885E-01, 0.88086E-01, 0.91279E-01, 0.94466E-01, 0.97647E-01, & + 0.10082E+00, 0.10399E+00, 0.10715E+00, 0.11030E+00, 0.11345E+00, & + 0.11659E+00, 0.11972E+00, 0.12285E+00, 0.12596E+00, 0.12908E+00, & + 0.13218E+00, 0.13528E+00, 0.13837E+00, 0.14146E+00, 0.14453E+00, & + 0.14760E+00, 0.15067E+00, 0.15372E+00, 0.15677E+00, 0.15981E+00, & + 0.16285E+00, 0.16588E+00, 0.16890E+00, 0.17191E+00, 0.17492E+00, & + 0.17792E+00, 0.18091E+00, 0.18390E+00, 0.18688E+00, 0.18985E+00, & + 0.19281E+00, 0.19577E+00, 0.19872E+00, 0.20167E+00, 0.20460E+00, & + 0.20753E+00, 0.21046E+00, 0.21338E+00, 0.21629E+00, 0.21919E+00/ + + DATA (BNC09M (I),I=201,300)/ & + 0.22208E+00, 0.22497E+00, 0.22786E+00, 0.23073E+00, 0.23360E+00, & + 0.23647E+00, 0.23932E+00, 0.24217E+00, 0.24501E+00, 0.24785E+00, & + 0.25068E+00, 0.25350E+00, 0.25632E+00, 0.25913E+00, 0.26193E+00, & + 0.26473E+00, 0.26752E+00, 0.27030E+00, 0.27308E+00, 0.27585E+00, & + 0.27861E+00, 0.28137E+00, 0.28412E+00, 0.28687E+00, 0.28961E+00, & + 0.29234E+00, 0.29506E+00, 0.29778E+00, 0.30050E+00, 0.30321E+00, & + 0.30591E+00, 0.30860E+00, 0.31129E+00, 0.31397E+00, 0.31665E+00, & + 0.31932E+00, 0.32199E+00, 0.32465E+00, 0.32730E+00, 0.32995E+00, & + 0.33259E+00, 0.33522E+00, 0.33785E+00, 0.34047E+00, 0.34309E+00, & + 0.34570E+00, 0.34831E+00, 0.35091E+00, 0.35350E+00, 0.35609E+00, & + 0.35867E+00, 0.36125E+00, 0.36382E+00, 0.36639E+00, 0.36895E+00, & + 0.37150E+00, 0.37405E+00, 0.37659E+00, 0.37913E+00, 0.38166E+00, & + 0.38419E+00, 0.38671E+00, 0.38923E+00, 0.39174E+00, 0.39424E+00, & + 0.39674E+00, 0.39924E+00, 0.40173E+00, 0.40421E+00, 0.40669E+00, & + 0.40916E+00, 0.41163E+00, 0.41409E+00, 0.41655E+00, 0.41900E+00, & + 0.42145E+00, 0.42389E+00, 0.42632E+00, 0.42876E+00, 0.43118E+00, & + 0.43360E+00, 0.43602E+00, 0.43843E+00, 0.44084E+00, 0.44324E+00, & + 0.44563E+00, 0.44803E+00, 0.45041E+00, 0.45279E+00, 0.45517E+00, & + 0.45754E+00, 0.45991E+00, 0.46227E+00, 0.46463E+00, 0.46698E+00, & + 0.46933E+00, 0.47167E+00, 0.47401E+00, 0.47634E+00, 0.47867E+00/ + + DATA (BNC09M (I),I=301,400)/ & + 0.48099E+00, 0.48331E+00, 0.48563E+00, 0.48794E+00, 0.49024E+00, & + 0.49254E+00, 0.49484E+00, 0.49713E+00, 0.49942E+00, 0.50170E+00, & + 0.50398E+00, 0.50625E+00, 0.50852E+00, 0.51079E+00, 0.51305E+00, & + 0.51530E+00, 0.51755E+00, 0.51980E+00, 0.52204E+00, 0.52428E+00, & + 0.52651E+00, 0.52874E+00, 0.53097E+00, 0.53319E+00, 0.53540E+00, & + 0.53762E+00, 0.53983E+00, 0.54203E+00, 0.54423E+00, 0.54642E+00, & + 0.54862E+00, 0.55080E+00, 0.55299E+00, 0.55516E+00, 0.55734E+00, & + 0.55951E+00, 0.56168E+00, 0.56384E+00, 0.56600E+00, 0.56815E+00, & + 0.57030E+00, 0.57245E+00, 0.57459E+00, 0.57673E+00, 0.57886E+00, & + 0.58099E+00, 0.58312E+00, 0.58524E+00, 0.58736E+00, 0.58947E+00, & + 0.59158E+00, 0.59369E+00, 0.59579E+00, 0.59789E+00, 0.59999E+00, & + 0.60208E+00, 0.60416E+00, 0.60625E+00, 0.60833E+00, 0.61040E+00, & + 0.61248E+00, 0.61455E+00, 0.61661E+00, 0.61867E+00, 0.62073E+00, & + 0.62278E+00, 0.62483E+00, 0.62688E+00, 0.62892E+00, 0.63096E+00, & + 0.63300E+00, 0.63503E+00, 0.63706E+00, 0.63908E+00, 0.64110E+00, & + 0.64312E+00, 0.64513E+00, 0.64714E+00, 0.64915E+00, 0.65115E+00, & + 0.65316E+00, 0.65515E+00, 0.65714E+00, 0.65913E+00, 0.66112E+00, & + 0.66310E+00, 0.66508E+00, 0.66706E+00, 0.66903E+00, 0.67100E+00, & + 0.67296E+00, 0.67492E+00, 0.67688E+00, 0.67884E+00, 0.68079E+00, & + 0.68274E+00, 0.68468E+00, 0.68663E+00, 0.68856E+00, 0.69050E+00/ + + DATA (BNC09M (I),I=401,500)/ & + 0.69243E+00, 0.69436E+00, 0.69629E+00, 0.69821E+00, 0.70013E+00, & + 0.70204E+00, 0.70396E+00, 0.70587E+00, 0.70777E+00, 0.70967E+00, & + 0.71157E+00, 0.71347E+00, 0.71536E+00, 0.71725E+00, 0.71914E+00, & + 0.72103E+00, 0.72291E+00, 0.72478E+00, 0.72666E+00, 0.72853E+00, & + 0.73040E+00, 0.73226E+00, 0.73413E+00, 0.73599E+00, 0.73784E+00, & + 0.73970E+00, 0.74155E+00, 0.74339E+00, 0.74524E+00, 0.74708E+00, & + 0.74892E+00, 0.75075E+00, 0.75258E+00, 0.75441E+00, 0.75624E+00, & + 0.75806E+00, 0.75988E+00, 0.76170E+00, 0.76352E+00, 0.76533E+00, & + 0.76714E+00, 0.76894E+00, 0.77074E+00, 0.77255E+00, 0.77434E+00, & + 0.77614E+00, 0.77793E+00, 0.77972E+00, 0.78150E+00, 0.78329E+00, & + 0.78507E+00, 0.78684E+00, 0.78862E+00, 0.79039E+00, 0.79216E+00, & + 0.79393E+00, 0.79569E+00, 0.79745E+00, 0.79921E+00, 0.80096E+00, & + 0.80272E+00, 0.80447E+00, 0.80621E+00, 0.80796E+00, 0.80970E+00, & + 0.81144E+00, 0.81318E+00, 0.81491E+00, 0.81664E+00, 0.81837E+00, & + 0.82009E+00, 0.82182E+00, 0.82354E+00, 0.82526E+00, 0.82697E+00, & + 0.82868E+00, 0.83039E+00, 0.83210E+00, 0.83381E+00, 0.83551E+00, & + 0.83721E+00, 0.83890E+00, 0.84060E+00, 0.84229E+00, 0.84398E+00, & + 0.84567E+00, 0.84735E+00, 0.84903E+00, 0.85071E+00, 0.85239E+00, & + 0.85406E+00, 0.85573E+00, 0.85740E+00, 0.85907E+00, 0.86074E+00, & + 0.86240E+00, 0.86406E+00, 0.86571E+00, 0.86737E+00, 0.86902E+00/ + + DATA (BNC09M (I),I=501,600)/ & + 0.87067E+00, 0.87232E+00, 0.87396E+00, 0.87560E+00, 0.87724E+00, & + 0.87888E+00, 0.88052E+00, 0.88215E+00, 0.88378E+00, 0.88541E+00, & + 0.88703E+00, 0.88865E+00, 0.89028E+00, 0.89189E+00, 0.89351E+00, & + 0.89512E+00, 0.89674E+00, 0.89834E+00, 0.89995E+00, 0.90156E+00, & + 0.90316E+00, 0.90476E+00, 0.90635E+00, 0.90795E+00, 0.90954E+00, & + 0.91113E+00, 0.91272E+00, 0.91431E+00, 0.91589E+00, 0.91747E+00, & + 0.91905E+00, 0.92063E+00, 0.92221E+00, 0.92378E+00, 0.92535E+00, & + 0.92692E+00, 0.92848E+00, 0.93005E+00, 0.93161E+00, 0.93317E+00, & + 0.93472E+00, 0.93628E+00, 0.93783E+00, 0.93938E+00, 0.94093E+00, & + 0.94248E+00, 0.94402E+00, 0.94556E+00, 0.94710E+00, 0.94864E+00, & + 0.95018E+00, 0.95171E+00, 0.95324E+00, 0.95477E+00, 0.95630E+00, & + 0.95782E+00, 0.95935E+00, 0.96087E+00, 0.96239E+00, 0.96390E+00, & + 0.96542E+00, 0.96693E+00, 0.96844E+00, 0.96995E+00, 0.97145E+00, & + 0.97296E+00, 0.97446E+00, 0.97596E+00, 0.97746E+00, 0.97896E+00, & + 0.98045E+00, 0.98194E+00, 0.98343E+00, 0.98492E+00, 0.98641E+00, & + 0.98789E+00, 0.98937E+00, 0.99085E+00, 0.99233E+00, 0.99380E+00, & + 0.99528E+00, 0.99675E+00, 0.99822E+00, 0.99969E+00, 0.10012E+01, & + 0.10026E+01, 0.10041E+01, 0.10055E+01, 0.10070E+01, 0.10085E+01, & + 0.10099E+01, 0.10114E+01, 0.10128E+01, 0.10143E+01, 0.10157E+01, & + 0.10172E+01, 0.10186E+01, 0.10200E+01, 0.10215E+01, 0.10269E+01/ + + DATA (BNC09M (I),I=601,700)/ & + 0.10386E+01, 0.10527E+01, 0.10666E+01, 0.10803E+01, 0.10938E+01, & + 0.11072E+01, 0.11204E+01, 0.11334E+01, 0.11463E+01, 0.11591E+01, & + 0.11717E+01, 0.11841E+01, 0.11964E+01, 0.12086E+01, 0.12206E+01, & + 0.12325E+01, 0.12442E+01, 0.12558E+01, 0.12673E+01, 0.12787E+01, & + 0.12900E+01, 0.13011E+01, 0.13121E+01, 0.13230E+01, 0.13338E+01, & + 0.13444E+01, 0.13550E+01, 0.13655E+01, 0.13758E+01, 0.13860E+01, & + 0.13962E+01, 0.14062E+01, 0.14162E+01, 0.14260E+01, 0.14358E+01, & + 0.14454E+01, 0.14550E+01, 0.14645E+01, 0.14738E+01, 0.14831E+01, & + 0.14923E+01, 0.15015E+01, 0.15105E+01, 0.15195E+01, 0.15284E+01, & + 0.15372E+01, 0.15459E+01, 0.15545E+01, 0.15631E+01, 0.15716E+01, & + 0.15800E+01, 0.15884E+01, 0.15966E+01, 0.16049E+01, 0.16130E+01, & + 0.16211E+01, 0.16291E+01, 0.16370E+01, 0.16449E+01, 0.16527E+01, & + 0.16604E+01, 0.16681E+01, 0.16757E+01, 0.16833E+01, 0.16908E+01, & + 0.16982E+01, 0.17056E+01, 0.17129E+01, 0.17201E+01, 0.17273E+01, & + 0.17345E+01, 0.17416E+01, 0.17486E+01, 0.17556E+01, 0.17625E+01, & + 0.17694E+01, 0.17763E+01, 0.17830E+01, 0.17898E+01, 0.17964E+01, & + 0.18031E+01, 0.18097E+01, 0.18162E+01, 0.18227E+01, 0.18291E+01, & + 0.18355E+01, 0.18418E+01, 0.18481E+01, 0.18544E+01, 0.18606E+01, & + 0.18668E+01, 0.18729E+01, 0.18790E+01, 0.18850E+01, 0.18910E+01, & + 0.18970E+01, 0.19029E+01, 0.19088E+01, 0.19146E+01, 0.19204E+01/ + + DATA (BNC09M(I),I=701,741)/ & + 0.19262E+01, 0.19319E+01, 0.19376E+01, 0.19432E+01, 0.19488E+01, & + 0.19544E+01, 0.19599E+01, 0.19654E+01, 0.19709E+01, 0.19763E+01, & + 0.19817E+01, 0.19871E+01, 0.19924E+01, 0.19977E+01, 0.20029E+01, & + 0.20082E+01, 0.20133E+01, 0.20185E+01, 0.20236E+01, 0.20287E+01, & + 0.20338E+01, 0.20388E+01, 0.20438E+01, 0.20488E+01, 0.20537E+01, & + 0.20586E+01, 0.20635E+01, 0.20683E+01, 0.20731E+01, 0.20779E+01, & + 0.20827E+01, 0.20874E+01, 0.20921E+01, 0.20968E+01, 0.21014E+01, & + 0.21061E+01, 0.21107E+01, 0.21152E+01, 0.21198E+01, 0.21243E+01, & + 0.21288E+01 & + / +! +! *** (H, NO3) +! + DATA (BNC10M (I),I= 1,100)/ & + -0.50967E-01,-0.89573E-01,-0.11434E+00,-0.12971E+00,-0.14053E+00, & + -0.14861E+00,-0.15484E+00,-0.15973E+00,-0.16360E+00,-0.16667E+00, & + -0.16910E+00,-0.17099E+00,-0.17243E+00,-0.17350E+00,-0.17424E+00, & + -0.17470E+00,-0.17491E+00,-0.17491E+00,-0.17471E+00,-0.17434E+00, & + -0.17382E+00,-0.17316E+00,-0.17238E+00,-0.17148E+00,-0.17049E+00, & + -0.16940E+00,-0.16823E+00,-0.16699E+00,-0.16567E+00,-0.16430E+00, & + -0.16287E+00,-0.16138E+00,-0.15985E+00,-0.15828E+00,-0.15667E+00, & + -0.15502E+00,-0.15334E+00,-0.15163E+00,-0.14989E+00,-0.14814E+00, & + -0.14635E+00,-0.14456E+00,-0.14274E+00,-0.14090E+00,-0.13906E+00, & + -0.13720E+00,-0.13533E+00,-0.13344E+00,-0.13155E+00,-0.12965E+00, & + -0.12775E+00,-0.12583E+00,-0.12392E+00,-0.12199E+00,-0.12006E+00, & + -0.11812E+00,-0.11618E+00,-0.11424E+00,-0.11229E+00,-0.11033E+00, & + -0.10837E+00,-0.10640E+00,-0.10443E+00,-0.10246E+00,-0.10047E+00, & + -0.98485E-01,-0.96489E-01,-0.94485E-01,-0.92474E-01,-0.90455E-01, & + -0.88427E-01,-0.86389E-01,-0.84342E-01,-0.82285E-01,-0.80216E-01, & + -0.78136E-01,-0.76044E-01,-0.73940E-01,-0.71822E-01,-0.69692E-01, & + -0.67547E-01,-0.65389E-01,-0.63216E-01,-0.61028E-01,-0.58825E-01, & + -0.56607E-01,-0.54374E-01,-0.52125E-01,-0.49861E-01,-0.47581E-01, & + -0.45285E-01,-0.42974E-01,-0.40648E-01,-0.38307E-01,-0.35950E-01, & + -0.33579E-01,-0.31194E-01,-0.28794E-01,-0.26380E-01,-0.23953E-01/ + + DATA (BNC10M (I),I=101,200)/ & + -0.21514E-01,-0.19061E-01,-0.16597E-01,-0.14121E-01,-0.11634E-01, & + -0.91364E-02,-0.66288E-02,-0.41117E-02,-0.15855E-02, 0.94906E-03, & + 0.34915E-02, 0.60415E-02, 0.85982E-02, 0.11161E-01, 0.13730E-01, & + 0.16305E-01, 0.18884E-01, 0.21468E-01, 0.24056E-01, 0.26647E-01, & + 0.28953E-01, 0.31584E-01, 0.34213E-01, 0.36841E-01, 0.39469E-01, & + 0.42094E-01, 0.44719E-01, 0.47342E-01, 0.49964E-01, 0.52584E-01, & + 0.55203E-01, 0.57820E-01, 0.60435E-01, 0.63049E-01, 0.65661E-01, & + 0.68270E-01, 0.70878E-01, 0.73484E-01, 0.76088E-01, 0.78689E-01, & + 0.81289E-01, 0.83886E-01, 0.86481E-01, 0.89073E-01, 0.91664E-01, & + 0.94252E-01, 0.96837E-01, 0.99420E-01, 0.10200E+00, 0.10458E+00, & + 0.10715E+00, 0.10973E+00, 0.11230E+00, 0.11486E+00, 0.11743E+00, & + 0.11999E+00, 0.12255E+00, 0.12510E+00, 0.12766E+00, 0.13021E+00, & + 0.13276E+00, 0.13530E+00, 0.13784E+00, 0.14038E+00, 0.14291E+00, & + 0.14545E+00, 0.14798E+00, 0.15050E+00, 0.15303E+00, 0.15555E+00, & + 0.15806E+00, 0.16058E+00, 0.16309E+00, 0.16559E+00, 0.16810E+00, & + 0.17060E+00, 0.17309E+00, 0.17559E+00, 0.17808E+00, 0.18057E+00, & + 0.18305E+00, 0.18553E+00, 0.18801E+00, 0.19048E+00, 0.19295E+00, & + 0.19542E+00, 0.19788E+00, 0.20034E+00, 0.20280E+00, 0.20525E+00, & + 0.20770E+00, 0.21015E+00, 0.21259E+00, 0.21503E+00, 0.21747E+00, & + 0.21990E+00, 0.22233E+00, 0.22475E+00, 0.22718E+00, 0.22959E+00/ + + DATA (BNC10M (I),I=201,300)/ & + 0.23201E+00, 0.23442E+00, 0.23683E+00, 0.23923E+00, 0.24163E+00, & + 0.24403E+00, 0.24642E+00, 0.24881E+00, 0.25120E+00, 0.25358E+00, & + 0.25596E+00, 0.25833E+00, 0.26070E+00, 0.26307E+00, 0.26544E+00, & + 0.26780E+00, 0.27016E+00, 0.27251E+00, 0.27486E+00, 0.27721E+00, & + 0.27955E+00, 0.28189E+00, 0.28422E+00, 0.28655E+00, 0.28888E+00, & + 0.29121E+00, 0.29353E+00, 0.29585E+00, 0.29816E+00, 0.30047E+00, & + 0.30278E+00, 0.30508E+00, 0.30738E+00, 0.30967E+00, 0.31197E+00, & + 0.31425E+00, 0.31654E+00, 0.31882E+00, 0.32110E+00, 0.32337E+00, & + 0.32564E+00, 0.32791E+00, 0.33017E+00, 0.33243E+00, 0.33469E+00, & + 0.33694E+00, 0.33919E+00, 0.34143E+00, 0.34367E+00, 0.34591E+00, & + 0.34815E+00, 0.35038E+00, 0.35260E+00, 0.35483E+00, 0.35705E+00, & + 0.35926E+00, 0.36148E+00, 0.36369E+00, 0.36589E+00, 0.36809E+00, & + 0.37029E+00, 0.37249E+00, 0.37468E+00, 0.37687E+00, 0.37905E+00, & + 0.38123E+00, 0.38341E+00, 0.38558E+00, 0.38775E+00, 0.38992E+00, & + 0.39208E+00, 0.39424E+00, 0.39640E+00, 0.39855E+00, 0.40070E+00, & + 0.40285E+00, 0.40499E+00, 0.40713E+00, 0.40927E+00, 0.41140E+00, & + 0.41353E+00, 0.41565E+00, 0.41777E+00, 0.41989E+00, 0.42201E+00, & + 0.42412E+00, 0.42623E+00, 0.42833E+00, 0.43043E+00, 0.43253E+00, & + 0.43463E+00, 0.43672E+00, 0.43880E+00, 0.44089E+00, 0.44297E+00, & + 0.44505E+00, 0.44712E+00, 0.44919E+00, 0.45126E+00, 0.45332E+00/ + + DATA (BNC10M (I),I=301,400)/ & + 0.45539E+00, 0.45744E+00, 0.45950E+00, 0.46155E+00, 0.46360E+00, & + 0.46564E+00, 0.46768E+00, 0.46972E+00, 0.47175E+00, 0.47378E+00, & + 0.47581E+00, 0.47784E+00, 0.47986E+00, 0.48188E+00, 0.48389E+00, & + 0.48590E+00, 0.48791E+00, 0.48992E+00, 0.49192E+00, 0.49392E+00, & + 0.49591E+00, 0.49790E+00, 0.49989E+00, 0.50188E+00, 0.50386E+00, & + 0.50584E+00, 0.50782E+00, 0.50979E+00, 0.51176E+00, 0.51373E+00, & + 0.51569E+00, 0.51765E+00, 0.51961E+00, 0.52156E+00, 0.52352E+00, & + 0.52546E+00, 0.52741E+00, 0.52935E+00, 0.53129E+00, 0.53323E+00, & + 0.53516E+00, 0.53709E+00, 0.53901E+00, 0.54094E+00, 0.54286E+00, & + 0.54478E+00, 0.54669E+00, 0.54860E+00, 0.55051E+00, 0.55241E+00, & + 0.55432E+00, 0.55622E+00, 0.55811E+00, 0.56001E+00, 0.56190E+00, & + 0.56378E+00, 0.56567E+00, 0.56755E+00, 0.56943E+00, 0.57130E+00, & + 0.57318E+00, 0.57505E+00, 0.57691E+00, 0.57878E+00, 0.58064E+00, & + 0.58249E+00, 0.58435E+00, 0.58620E+00, 0.58805E+00, 0.58990E+00, & + 0.59174E+00, 0.59358E+00, 0.59542E+00, 0.59725E+00, 0.59909E+00, & + 0.60092E+00, 0.60274E+00, 0.60457E+00, 0.60639E+00, 0.60820E+00, & + 0.61002E+00, 0.61183E+00, 0.61364E+00, 0.61545E+00, 0.61725E+00, & + 0.61905E+00, 0.62085E+00, 0.62265E+00, 0.62444E+00, 0.62623E+00, & + 0.62802E+00, 0.62980E+00, 0.63158E+00, 0.63336E+00, 0.63514E+00, & + 0.63691E+00, 0.63868E+00, 0.64045E+00, 0.64222E+00, 0.64398E+00/ + + DATA (BNC10M (I),I=401,500)/ & + 0.64574E+00, 0.64750E+00, 0.64925E+00, 0.65100E+00, 0.65275E+00, & + 0.65450E+00, 0.65624E+00, 0.65798E+00, 0.65972E+00, 0.66146E+00, & + 0.66319E+00, 0.66492E+00, 0.66665E+00, 0.66838E+00, 0.67010E+00, & + 0.67182E+00, 0.67354E+00, 0.67526E+00, 0.67697E+00, 0.67868E+00, & + 0.68039E+00, 0.68209E+00, 0.68379E+00, 0.68549E+00, 0.68719E+00, & + 0.68889E+00, 0.69058E+00, 0.69227E+00, 0.69396E+00, 0.69564E+00, & + 0.69732E+00, 0.69900E+00, 0.70068E+00, 0.70236E+00, 0.70403E+00, & + 0.70570E+00, 0.70736E+00, 0.70903E+00, 0.71069E+00, 0.71235E+00, & + 0.71401E+00, 0.71567E+00, 0.71732E+00, 0.71897E+00, 0.72062E+00, & + 0.72226E+00, 0.72390E+00, 0.72555E+00, 0.72718E+00, 0.72882E+00, & + 0.73045E+00, 0.73208E+00, 0.73371E+00, 0.73534E+00, 0.73696E+00, & + 0.73858E+00, 0.74020E+00, 0.74182E+00, 0.74344E+00, 0.74505E+00, & + 0.74666E+00, 0.74826E+00, 0.74987E+00, 0.75147E+00, 0.75307E+00, & + 0.75467E+00, 0.75627E+00, 0.75786E+00, 0.75945E+00, 0.76104E+00, & + 0.76263E+00, 0.76421E+00, 0.76580E+00, 0.76738E+00, 0.76895E+00, & + 0.77053E+00, 0.77210E+00, 0.77367E+00, 0.77524E+00, 0.77681E+00, & + 0.77837E+00, 0.77993E+00, 0.78149E+00, 0.78305E+00, 0.78461E+00, & + 0.78616E+00, 0.78771E+00, 0.78926E+00, 0.79081E+00, 0.79235E+00, & + 0.79389E+00, 0.79543E+00, 0.79697E+00, 0.79851E+00, 0.80004E+00, & + 0.80157E+00, 0.80310E+00, 0.80463E+00, 0.80615E+00, 0.80768E+00/ + + DATA (BNC10M (I),I=501,600)/ & + 0.80920E+00, 0.81072E+00, 0.81223E+00, 0.81375E+00, 0.81526E+00, & + 0.81677E+00, 0.81828E+00, 0.81978E+00, 0.82129E+00, 0.82279E+00, & + 0.82429E+00, 0.82579E+00, 0.82728E+00, 0.82878E+00, 0.83027E+00, & + 0.83176E+00, 0.83324E+00, 0.83473E+00, 0.83621E+00, 0.83769E+00, & + 0.83917E+00, 0.84065E+00, 0.84213E+00, 0.84360E+00, 0.84507E+00, & + 0.84654E+00, 0.84801E+00, 0.84947E+00, 0.85093E+00, 0.85240E+00, & + 0.85385E+00, 0.85531E+00, 0.85677E+00, 0.85822E+00, 0.85967E+00, & + 0.86112E+00, 0.86257E+00, 0.86401E+00, 0.86546E+00, 0.86690E+00, & + 0.86834E+00, 0.86977E+00, 0.87121E+00, 0.87264E+00, 0.87408E+00, & + 0.87551E+00, 0.87693E+00, 0.87836E+00, 0.87978E+00, 0.88121E+00, & + 0.88263E+00, 0.88404E+00, 0.88546E+00, 0.88688E+00, 0.88829E+00, & + 0.88970E+00, 0.89111E+00, 0.89251E+00, 0.89392E+00, 0.89532E+00, & + 0.89672E+00, 0.89812E+00, 0.89952E+00, 0.90092E+00, 0.90231E+00, & + 0.90370E+00, 0.90510E+00, 0.90648E+00, 0.90787E+00, 0.90926E+00, & + 0.91064E+00, 0.91202E+00, 0.91340E+00, 0.91478E+00, 0.91615E+00, & + 0.91753E+00, 0.91890E+00, 0.92027E+00, 0.92164E+00, 0.92301E+00, & + 0.92437E+00, 0.92573E+00, 0.92710E+00, 0.92846E+00, 0.92981E+00, & + 0.93117E+00, 0.93252E+00, 0.93388E+00, 0.93523E+00, 0.93658E+00, & + 0.93793E+00, 0.93927E+00, 0.94062E+00, 0.94196E+00, 0.94330E+00, & + 0.94464E+00, 0.94598E+00, 0.94731E+00, 0.94864E+00, 0.95363E+00/ + + DATA (BNC10M (I),I=601,700)/ & + 0.96452E+00, 0.97756E+00, 0.99045E+00, 0.10032E+01, 0.10157E+01, & + 0.10282E+01, 0.10404E+01, 0.10525E+01, 0.10645E+01, 0.10763E+01, & + 0.10880E+01, 0.10996E+01, 0.11110E+01, 0.11223E+01, 0.11335E+01, & + 0.11445E+01, 0.11555E+01, 0.11663E+01, 0.11769E+01, 0.11875E+01, & + 0.11980E+01, 0.12083E+01, 0.12185E+01, 0.12287E+01, 0.12387E+01, & + 0.12486E+01, 0.12584E+01, 0.12681E+01, 0.12777E+01, 0.12872E+01, & + 0.12967E+01, 0.13060E+01, 0.13152E+01, 0.13244E+01, 0.13334E+01, & + 0.13424E+01, 0.13513E+01, 0.13601E+01, 0.13688E+01, 0.13774E+01, & + 0.13860E+01, 0.13944E+01, 0.14028E+01, 0.14111E+01, 0.14194E+01, & + 0.14275E+01, 0.14356E+01, 0.14437E+01, 0.14516E+01, 0.14595E+01, & + 0.14673E+01, 0.14750E+01, 0.14827E+01, 0.14903E+01, 0.14978E+01, & + 0.15053E+01, 0.15127E+01, 0.15201E+01, 0.15274E+01, 0.15346E+01, & + 0.15418E+01, 0.15489E+01, 0.15559E+01, 0.15629E+01, 0.15698E+01, & + 0.15767E+01, 0.15835E+01, 0.15903E+01, 0.15970E+01, 0.16037E+01, & + 0.16103E+01, 0.16168E+01, 0.16233E+01, 0.16298E+01, 0.16362E+01, & + 0.16425E+01, 0.16488E+01, 0.16551E+01, 0.16613E+01, 0.16675E+01, & + 0.16736E+01, 0.16797E+01, 0.16857E+01, 0.16917E+01, 0.16976E+01, & + 0.17035E+01, 0.17093E+01, 0.17152E+01, 0.17209E+01, 0.17266E+01, & + 0.17323E+01, 0.17380E+01, 0.17436E+01, 0.17491E+01, 0.17546E+01, & + 0.17601E+01, 0.17656E+01, 0.17710E+01, 0.17763E+01, 0.17817E+01/ + + DATA (BNC10M(I),I=701,741)/ & + 0.17870E+01, 0.17922E+01, 0.17975E+01, 0.18026E+01, 0.18078E+01, & + 0.18129E+01, 0.18180E+01, 0.18230E+01, 0.18281E+01, 0.18330E+01, & + 0.18380E+01, 0.18429E+01, 0.18478E+01, 0.18526E+01, 0.18575E+01, & + 0.18622E+01, 0.18670E+01, 0.18717E+01, 0.18764E+01, 0.18811E+01, & + 0.18857E+01, 0.18903E+01, 0.18949E+01, 0.18994E+01, 0.19040E+01, & + 0.19085E+01, 0.19129E+01, 0.19174E+01, 0.19218E+01, 0.19261E+01, & + 0.19305E+01, 0.19348E+01, 0.19391E+01, 0.19434E+01, 0.19476E+01, & + 0.19519E+01, 0.19560E+01, 0.19602E+01, 0.19644E+01, 0.19685E+01, & + 0.19726E+01 & + / +! +! *** (H, Cl) +! + DATA (BNC11M (I),I= 1,100)/ & + -0.49531E-01,-0.84652E-01,-0.10547E+00,-0.11724E+00,-0.12469E+00, & + -0.12951E+00,-0.13255E+00,-0.13431E+00,-0.13506E+00,-0.13503E+00, & + -0.13435E+00,-0.13313E+00,-0.13145E+00,-0.12937E+00,-0.12694E+00, & + -0.12420E+00,-0.12119E+00,-0.11793E+00,-0.11444E+00,-0.11075E+00, & + -0.10687E+00,-0.10282E+00,-0.98618E-01,-0.94265E-01,-0.89778E-01, & + -0.85165E-01,-0.80436E-01,-0.75599E-01,-0.70661E-01,-0.65628E-01, & + -0.60508E-01,-0.55306E-01,-0.50028E-01,-0.44679E-01,-0.39262E-01, & + -0.33784E-01,-0.28247E-01,-0.22657E-01,-0.17017E-01,-0.11329E-01, & + -0.55978E-02, 0.17400E-03, 0.59837E-02, 0.11828E-01, 0.17706E-01, & + 0.23614E-01, 0.29550E-01, 0.35513E-01, 0.41500E-01, 0.47510E-01, & + 0.53542E-01, 0.59594E-01, 0.65665E-01, 0.71754E-01, 0.77861E-01, & + 0.83984E-01, 0.90123E-01, 0.96278E-01, 0.10245E+00, 0.10863E+00, & + 0.11483E+00, 0.12105E+00, 0.12728E+00, 0.13353E+00, 0.13979E+00, & + 0.14608E+00, 0.15237E+00, 0.15869E+00, 0.16503E+00, 0.17138E+00, & + 0.17776E+00, 0.18415E+00, 0.19058E+00, 0.19702E+00, 0.20349E+00, & + 0.20998E+00, 0.21650E+00, 0.22305E+00, 0.22962E+00, 0.23623E+00, & + 0.24286E+00, 0.24953E+00, 0.25623E+00, 0.26295E+00, 0.26972E+00, & + 0.27651E+00, 0.28334E+00, 0.29020E+00, 0.29709E+00, 0.30402E+00, & + 0.31098E+00, 0.31798E+00, 0.32500E+00, 0.33206E+00, 0.33916E+00, & + 0.34628E+00, 0.35343E+00, 0.36062E+00, 0.36783E+00, 0.37507E+00/ + + DATA (BNC11M (I),I=101,200)/ & + 0.38234E+00, 0.38964E+00, 0.39696E+00, 0.40431E+00, 0.41167E+00, & + 0.41906E+00, 0.42647E+00, 0.43390E+00, 0.44134E+00, 0.44880E+00, & + 0.45628E+00, 0.46377E+00, 0.47127E+00, 0.47879E+00, 0.48631E+00, & + 0.49384E+00, 0.50138E+00, 0.50893E+00, 0.51648E+00, 0.52403E+00, & + 0.53093E+00, 0.53856E+00, 0.54619E+00, 0.55382E+00, 0.56143E+00, & + 0.56904E+00, 0.57664E+00, 0.58424E+00, 0.59182E+00, 0.59940E+00, & + 0.60697E+00, 0.61453E+00, 0.62208E+00, 0.62962E+00, 0.63715E+00, & + 0.64467E+00, 0.65218E+00, 0.65969E+00, 0.66718E+00, 0.67466E+00, & + 0.68213E+00, 0.68959E+00, 0.69704E+00, 0.70448E+00, 0.71191E+00, & + 0.71933E+00, 0.72674E+00, 0.73413E+00, 0.74152E+00, 0.74889E+00, & + 0.75625E+00, 0.76360E+00, 0.77094E+00, 0.77826E+00, 0.78557E+00, & + 0.79288E+00, 0.80016E+00, 0.80744E+00, 0.81471E+00, 0.82196E+00, & + 0.82920E+00, 0.83642E+00, 0.84364E+00, 0.85084E+00, 0.85803E+00, & + 0.86520E+00, 0.87237E+00, 0.87952E+00, 0.88665E+00, 0.89378E+00, & + 0.90089E+00, 0.90799E+00, 0.91507E+00, 0.92215E+00, 0.92921E+00, & + 0.93625E+00, 0.94328E+00, 0.95030E+00, 0.95731E+00, 0.96430E+00, & + 0.97128E+00, 0.97825E+00, 0.98520E+00, 0.99214E+00, 0.99907E+00, & + 0.10060E+01, 0.10129E+01, 0.10198E+01, 0.10266E+01, 0.10335E+01, & + 0.10403E+01, 0.10472E+01, 0.10540E+01, 0.10608E+01, 0.10676E+01, & + 0.10744E+01, 0.10811E+01, 0.10879E+01, 0.10946E+01, 0.11014E+01/ + + DATA (BNC11M (I),I=201,300)/ & + 0.11081E+01, 0.11148E+01, 0.11214E+01, 0.11281E+01, 0.11348E+01, & + 0.11414E+01, 0.11481E+01, 0.11547E+01, 0.11613E+01, 0.11679E+01, & + 0.11745E+01, 0.11810E+01, 0.11876E+01, 0.11941E+01, 0.12006E+01, & + 0.12071E+01, 0.12136E+01, 0.12201E+01, 0.12266E+01, 0.12331E+01, & + 0.12395E+01, 0.12460E+01, 0.12524E+01, 0.12588E+01, 0.12652E+01, & + 0.12716E+01, 0.12779E+01, 0.12843E+01, 0.12906E+01, 0.12970E+01, & + 0.13033E+01, 0.13096E+01, 0.13159E+01, 0.13222E+01, 0.13284E+01, & + 0.13347E+01, 0.13409E+01, 0.13472E+01, 0.13534E+01, 0.13596E+01, & + 0.13658E+01, 0.13720E+01, 0.13781E+01, 0.13843E+01, 0.13904E+01, & + 0.13966E+01, 0.14027E+01, 0.14088E+01, 0.14149E+01, 0.14210E+01, & + 0.14270E+01, 0.14331E+01, 0.14391E+01, 0.14452E+01, 0.14512E+01, & + 0.14572E+01, 0.14632E+01, 0.14692E+01, 0.14751E+01, 0.14811E+01, & + 0.14871E+01, 0.14930E+01, 0.14989E+01, 0.15048E+01, 0.15107E+01, & + 0.15166E+01, 0.15225E+01, 0.15284E+01, 0.15342E+01, 0.15401E+01, & + 0.15459E+01, 0.15517E+01, 0.15575E+01, 0.15633E+01, 0.15691E+01, & + 0.15749E+01, 0.15807E+01, 0.15864E+01, 0.15922E+01, 0.15979E+01, & + 0.16036E+01, 0.16093E+01, 0.16150E+01, 0.16207E+01, 0.16264E+01, & + 0.16320E+01, 0.16377E+01, 0.16433E+01, 0.16490E+01, 0.16546E+01, & + 0.16602E+01, 0.16658E+01, 0.16714E+01, 0.16770E+01, 0.16825E+01, & + 0.16881E+01, 0.16936E+01, 0.16992E+01, 0.17047E+01, 0.17102E+01/ + + DATA (BNC11M (I),I=301,400)/ & + 0.17157E+01, 0.17212E+01, 0.17267E+01, 0.17321E+01, 0.17376E+01, & + 0.17431E+01, 0.17485E+01, 0.17539E+01, 0.17593E+01, 0.17648E+01, & + 0.17702E+01, 0.17755E+01, 0.17809E+01, 0.17863E+01, 0.17917E+01, & + 0.17970E+01, 0.18023E+01, 0.18077E+01, 0.18130E+01, 0.18183E+01, & + 0.18236E+01, 0.18289E+01, 0.18342E+01, 0.18394E+01, 0.18447E+01, & + 0.18500E+01, 0.18552E+01, 0.18604E+01, 0.18656E+01, 0.18709E+01, & + 0.18761E+01, 0.18813E+01, 0.18864E+01, 0.18916E+01, 0.18968E+01, & + 0.19019E+01, 0.19071E+01, 0.19122E+01, 0.19173E+01, 0.19225E+01, & + 0.19276E+01, 0.19327E+01, 0.19378E+01, 0.19428E+01, 0.19479E+01, & + 0.19530E+01, 0.19580E+01, 0.19631E+01, 0.19681E+01, 0.19731E+01, & + 0.19782E+01, 0.19832E+01, 0.19882E+01, 0.19932E+01, 0.19981E+01, & + 0.20031E+01, 0.20081E+01, 0.20130E+01, 0.20180E+01, 0.20229E+01, & + 0.20278E+01, 0.20328E+01, 0.20377E+01, 0.20426E+01, 0.20475E+01, & + 0.20524E+01, 0.20572E+01, 0.20621E+01, 0.20670E+01, 0.20718E+01, & + 0.20767E+01, 0.20815E+01, 0.20863E+01, 0.20912E+01, 0.20960E+01, & + 0.21008E+01, 0.21056E+01, 0.21104E+01, 0.21151E+01, 0.21199E+01, & + 0.21247E+01, 0.21294E+01, 0.21342E+01, 0.21389E+01, 0.21436E+01, & + 0.21483E+01, 0.21531E+01, 0.21578E+01, 0.21625E+01, 0.21672E+01, & + 0.21718E+01, 0.21765E+01, 0.21812E+01, 0.21858E+01, 0.21905E+01, & + 0.21951E+01, 0.21998E+01, 0.22044E+01, 0.22090E+01, 0.22136E+01/ + + DATA (BNC11M (I),I=401,500)/ & + 0.22182E+01, 0.22228E+01, 0.22274E+01, 0.22320E+01, 0.22366E+01, & + 0.22411E+01, 0.22457E+01, 0.22502E+01, 0.22548E+01, 0.22593E+01, & + 0.22638E+01, 0.22684E+01, 0.22729E+01, 0.22774E+01, 0.22819E+01, & + 0.22864E+01, 0.22908E+01, 0.22953E+01, 0.22998E+01, 0.23043E+01, & + 0.23087E+01, 0.23132E+01, 0.23176E+01, 0.23220E+01, 0.23265E+01, & + 0.23309E+01, 0.23353E+01, 0.23397E+01, 0.23441E+01, 0.23485E+01, & + 0.23529E+01, 0.23572E+01, 0.23616E+01, 0.23660E+01, 0.23703E+01, & + 0.23747E+01, 0.23790E+01, 0.23834E+01, 0.23877E+01, 0.23920E+01, & + 0.23963E+01, 0.24006E+01, 0.24049E+01, 0.24092E+01, 0.24135E+01, & + 0.24178E+01, 0.24221E+01, 0.24263E+01, 0.24306E+01, 0.24349E+01, & + 0.24391E+01, 0.24434E+01, 0.24476E+01, 0.24518E+01, 0.24560E+01, & + 0.24603E+01, 0.24645E+01, 0.24687E+01, 0.24729E+01, 0.24770E+01, & + 0.24812E+01, 0.24854E+01, 0.24896E+01, 0.24937E+01, 0.24979E+01, & + 0.25021E+01, 0.25062E+01, 0.25103E+01, 0.25145E+01, 0.25186E+01, & + 0.25227E+01, 0.25268E+01, 0.25309E+01, 0.25350E+01, 0.25391E+01, & + 0.25432E+01, 0.25473E+01, 0.25514E+01, 0.25554E+01, 0.25595E+01, & + 0.25636E+01, 0.25676E+01, 0.25717E+01, 0.25757E+01, 0.25797E+01, & + 0.25838E+01, 0.25878E+01, 0.25918E+01, 0.25958E+01, 0.25998E+01, & + 0.26038E+01, 0.26078E+01, 0.26118E+01, 0.26158E+01, 0.26198E+01, & + 0.26237E+01, 0.26277E+01, 0.26317E+01, 0.26356E+01, 0.26396E+01/ + + DATA (BNC11M (I),I=501,600)/ & + 0.26435E+01, 0.26474E+01, 0.26514E+01, 0.26553E+01, 0.26592E+01, & + 0.26631E+01, 0.26670E+01, 0.26709E+01, 0.26748E+01, 0.26787E+01, & + 0.26826E+01, 0.26865E+01, 0.26903E+01, 0.26942E+01, 0.26981E+01, & + 0.27019E+01, 0.27058E+01, 0.27096E+01, 0.27135E+01, 0.27173E+01, & + 0.27211E+01, 0.27249E+01, 0.27288E+01, 0.27326E+01, 0.27364E+01, & + 0.27402E+01, 0.27440E+01, 0.27478E+01, 0.27516E+01, 0.27553E+01, & + 0.27591E+01, 0.27629E+01, 0.27667E+01, 0.27704E+01, 0.27742E+01, & + 0.27779E+01, 0.27817E+01, 0.27854E+01, 0.27891E+01, 0.27929E+01, & + 0.27966E+01, 0.28003E+01, 0.28040E+01, 0.28077E+01, 0.28114E+01, & + 0.28151E+01, 0.28188E+01, 0.28225E+01, 0.28262E+01, 0.28299E+01, & + 0.28335E+01, 0.28372E+01, 0.28409E+01, 0.28445E+01, 0.28482E+01, & + 0.28518E+01, 0.28555E+01, 0.28591E+01, 0.28627E+01, 0.28664E+01, & + 0.28700E+01, 0.28736E+01, 0.28772E+01, 0.28808E+01, 0.28844E+01, & + 0.28880E+01, 0.28916E+01, 0.28952E+01, 0.28988E+01, 0.29024E+01, & + 0.29060E+01, 0.29095E+01, 0.29131E+01, 0.29167E+01, 0.29202E+01, & + 0.29238E+01, 0.29273E+01, 0.29309E+01, 0.29344E+01, 0.29379E+01, & + 0.29415E+01, 0.29450E+01, 0.29485E+01, 0.29520E+01, 0.29555E+01, & + 0.29590E+01, 0.29625E+01, 0.29660E+01, 0.29695E+01, 0.29730E+01, & + 0.29765E+01, 0.29800E+01, 0.29834E+01, 0.29869E+01, 0.29904E+01, & + 0.29938E+01, 0.29973E+01, 0.30007E+01, 0.30042E+01, 0.30171E+01/ + + DATA (BNC11M (I),I=601,700)/ & + 0.30452E+01, 0.30789E+01, 0.31122E+01, 0.31450E+01, 0.31775E+01, & + 0.32096E+01, 0.32413E+01, 0.32726E+01, 0.33035E+01, 0.33341E+01, & + 0.33644E+01, 0.33943E+01, 0.34238E+01, 0.34531E+01, 0.34820E+01, & + 0.35106E+01, 0.35389E+01, 0.35668E+01, 0.35945E+01, 0.36219E+01, & + 0.36490E+01, 0.36759E+01, 0.37024E+01, 0.37287E+01, 0.37548E+01, & + 0.37805E+01, 0.38061E+01, 0.38313E+01, 0.38564E+01, 0.38811E+01, & + 0.39057E+01, 0.39300E+01, 0.39541E+01, 0.39780E+01, 0.40016E+01, & + 0.40250E+01, 0.40483E+01, 0.40713E+01, 0.40941E+01, 0.41167E+01, & + 0.41391E+01, 0.41613E+01, 0.41833E+01, 0.42051E+01, 0.42268E+01, & + 0.42482E+01, 0.42695E+01, 0.42906E+01, 0.43116E+01, 0.43323E+01, & + 0.43529E+01, 0.43733E+01, 0.43936E+01, 0.44137E+01, 0.44336E+01, & + 0.44534E+01, 0.44730E+01, 0.44925E+01, 0.45118E+01, 0.45310E+01, & + 0.45500E+01, 0.45689E+01, 0.45877E+01, 0.46063E+01, 0.46247E+01, & + 0.46431E+01, 0.46613E+01, 0.46793E+01, 0.46973E+01, 0.47151E+01, & + 0.47327E+01, 0.47503E+01, 0.47677E+01, 0.47850E+01, 0.48022E+01, & + 0.48193E+01, 0.48362E+01, 0.48530E+01, 0.48698E+01, 0.48864E+01, & + 0.49029E+01, 0.49192E+01, 0.49355E+01, 0.49517E+01, 0.49677E+01, & + 0.49837E+01, 0.49995E+01, 0.50153E+01, 0.50309E+01, 0.50465E+01, & + 0.50619E+01, 0.50773E+01, 0.50925E+01, 0.51077E+01, 0.51227E+01, & + 0.51377E+01, 0.51526E+01, 0.51673E+01, 0.51820E+01, 0.51966E+01/ + + DATA (BNC11M(I),I=701,741)/ & + 0.52112E+01, 0.52256E+01, 0.52399E+01, 0.52542E+01, 0.52683E+01, & + 0.52824E+01, 0.52964E+01, 0.53104E+01, 0.53242E+01, 0.53380E+01, & + 0.53516E+01, 0.53652E+01, 0.53788E+01, 0.53922E+01, 0.54056E+01, & + 0.54189E+01, 0.54321E+01, 0.54453E+01, 0.54583E+01, 0.54713E+01, & + 0.54843E+01, 0.54971E+01, 0.55099E+01, 0.55226E+01, 0.55353E+01, & + 0.55479E+01, 0.55604E+01, 0.55729E+01, 0.55852E+01, 0.55976E+01, & + 0.56098E+01, 0.56220E+01, 0.56341E+01, 0.56462E+01, 0.56582E+01, & + 0.56701E+01, 0.56820E+01, 0.56938E+01, 0.57056E+01, 0.57173E+01, & + 0.57289E+01 & + / +! +! *** NaHSO4 +! + DATA (BNC12M (I),I= 1,100)/ & + -0.50782E-01,-0.89259E-01,-0.11419E+00,-0.12989E+00,-0.14113E+00, & + -0.14967E+00,-0.15637E+00,-0.16174E+00,-0.16609E+00,-0.16962E+00, & + -0.17248E+00,-0.17478E+00,-0.17660E+00,-0.17801E+00,-0.17906E+00, & + -0.17979E+00,-0.18023E+00,-0.18040E+00,-0.18034E+00,-0.18006E+00, & + -0.17958E+00,-0.17891E+00,-0.17806E+00,-0.17706E+00,-0.17590E+00, & + -0.17460E+00,-0.17317E+00,-0.17160E+00,-0.16992E+00,-0.16812E+00, & + -0.16621E+00,-0.16420E+00,-0.16208E+00,-0.15987E+00,-0.15758E+00, & + -0.15519E+00,-0.15272E+00,-0.15017E+00,-0.14755E+00,-0.14485E+00, & + -0.14209E+00,-0.13925E+00,-0.13636E+00,-0.13340E+00,-0.13038E+00, & + -0.12731E+00,-0.12418E+00,-0.12100E+00,-0.11777E+00,-0.11449E+00, & + -0.11116E+00,-0.10779E+00,-0.10438E+00,-0.10093E+00,-0.97430E-01, & + -0.93896E-01,-0.90324E-01,-0.86716E-01,-0.83072E-01,-0.79393E-01, & + -0.75680E-01,-0.71935E-01,-0.68156E-01,-0.64346E-01,-0.60504E-01, & + -0.56631E-01,-0.52728E-01,-0.48793E-01,-0.44829E-01,-0.40834E-01, & + -0.36810E-01,-0.32755E-01,-0.28670E-01,-0.24555E-01,-0.20411E-01, & + -0.16235E-01,-0.12030E-01,-0.77941E-02,-0.35277E-02, 0.76915E-03, & + 0.50967E-02, 0.94548E-02, 0.13844E-01, 0.18263E-01, 0.22713E-01, & + 0.27194E-01, 0.31705E-01, 0.36246E-01, 0.40817E-01, 0.45417E-01, & + 0.50047E-01, 0.54705E-01, 0.59392E-01, 0.64106E-01, 0.68847E-01, & + 0.73615E-01, 0.78408E-01, 0.83227E-01, 0.88069E-01, 0.92934E-01/ + + DATA (BNC12M (I),I=101,200)/ & + 0.97821E-01, 0.10273E+00, 0.10766E+00, 0.11261E+00, 0.11757E+00, & + 0.12256E+00, 0.12756E+00, 0.13257E+00, 0.13760E+00, 0.14264E+00, & + 0.14770E+00, 0.15276E+00, 0.15784E+00, 0.16292E+00, 0.16801E+00, & + 0.17311E+00, 0.17821E+00, 0.18332E+00, 0.18843E+00, 0.19355E+00, & + 0.19820E+00, 0.20337E+00, 0.20854E+00, 0.21370E+00, 0.21886E+00, & + 0.22401E+00, 0.22916E+00, 0.23430E+00, 0.23944E+00, 0.24457E+00, & + 0.24969E+00, 0.25481E+00, 0.25992E+00, 0.26502E+00, 0.27012E+00, & + 0.27521E+00, 0.28029E+00, 0.28536E+00, 0.29043E+00, 0.29548E+00, & + 0.30053E+00, 0.30558E+00, 0.31061E+00, 0.31563E+00, 0.32065E+00, & + 0.32566E+00, 0.33066E+00, 0.33565E+00, 0.34063E+00, 0.34560E+00, & + 0.35057E+00, 0.35552E+00, 0.36047E+00, 0.36541E+00, 0.37033E+00, & + 0.37525E+00, 0.38016E+00, 0.38506E+00, 0.38995E+00, 0.39483E+00, & + 0.39971E+00, 0.40457E+00, 0.40942E+00, 0.41426E+00, 0.41910E+00, & + 0.42392E+00, 0.42873E+00, 0.43354E+00, 0.43833E+00, 0.44312E+00, & + 0.44789E+00, 0.45266E+00, 0.45742E+00, 0.46216E+00, 0.46690E+00, & + 0.47163E+00, 0.47634E+00, 0.48105E+00, 0.48575E+00, 0.49043E+00, & + 0.49511E+00, 0.49978E+00, 0.50444E+00, 0.50909E+00, 0.51373E+00, & + 0.51836E+00, 0.52298E+00, 0.52759E+00, 0.53219E+00, 0.53678E+00, & + 0.54136E+00, 0.54593E+00, 0.55049E+00, 0.55504E+00, 0.55959E+00, & + 0.56412E+00, 0.56864E+00, 0.57316E+00, 0.57766E+00, 0.58216E+00/ + + DATA (BNC12M (I),I=201,300)/ & + 0.58664E+00, 0.59112E+00, 0.59558E+00, 0.60004E+00, 0.60449E+00, & + 0.60893E+00, 0.61336E+00, 0.61778E+00, 0.62219E+00, 0.62659E+00, & + 0.63098E+00, 0.63536E+00, 0.63973E+00, 0.64410E+00, 0.64845E+00, & + 0.65280E+00, 0.65714E+00, 0.66146E+00, 0.66578E+00, 0.67009E+00, & + 0.67439E+00, 0.67869E+00, 0.68297E+00, 0.68724E+00, 0.69151E+00, & + 0.69576E+00, 0.70001E+00, 0.70425E+00, 0.70848E+00, 0.71270E+00, & + 0.71691E+00, 0.72111E+00, 0.72531E+00, 0.72950E+00, 0.73367E+00, & + 0.73784E+00, 0.74200E+00, 0.74616E+00, 0.75030E+00, 0.75443E+00, & + 0.75856E+00, 0.76268E+00, 0.76679E+00, 0.77089E+00, 0.77498E+00, & + 0.77907E+00, 0.78314E+00, 0.78721E+00, 0.79127E+00, 0.79532E+00, & + 0.79937E+00, 0.80340E+00, 0.80743E+00, 0.81145E+00, 0.81546E+00, & + 0.81946E+00, 0.82346E+00, 0.82745E+00, 0.83143E+00, 0.83540E+00, & + 0.83936E+00, 0.84332E+00, 0.84726E+00, 0.85120E+00, 0.85514E+00, & + 0.85906E+00, 0.86298E+00, 0.86689E+00, 0.87079E+00, 0.87468E+00, & + 0.87857E+00, 0.88245E+00, 0.88632E+00, 0.89018E+00, 0.89404E+00, & + 0.89788E+00, 0.90173E+00, 0.90556E+00, 0.90939E+00, 0.91320E+00, & + 0.91702E+00, 0.92082E+00, 0.92462E+00, 0.92840E+00, 0.93219E+00, & + 0.93596E+00, 0.93973E+00, 0.94349E+00, 0.94724E+00, 0.95099E+00, & + 0.95473E+00, 0.95846E+00, 0.96219E+00, 0.96590E+00, 0.96961E+00, & + 0.97332E+00, 0.97702E+00, 0.98071E+00, 0.98439E+00, 0.98807E+00/ + + DATA (BNC12M (I),I=301,400)/ & + 0.99173E+00, 0.99540E+00, 0.99905E+00, 0.10027E+01, 0.10063E+01, & + 0.10100E+01, 0.10136E+01, 0.10172E+01, 0.10208E+01, 0.10245E+01, & + 0.10281E+01, 0.10316E+01, 0.10352E+01, 0.10388E+01, 0.10424E+01, & + 0.10460E+01, 0.10495E+01, 0.10531E+01, 0.10566E+01, 0.10602E+01, & + 0.10637E+01, 0.10672E+01, 0.10708E+01, 0.10743E+01, 0.10778E+01, & + 0.10813E+01, 0.10848E+01, 0.10883E+01, 0.10918E+01, 0.10953E+01, & + 0.10987E+01, 0.11022E+01, 0.11057E+01, 0.11091E+01, 0.11126E+01, & + 0.11160E+01, 0.11194E+01, 0.11229E+01, 0.11263E+01, 0.11297E+01, & + 0.11331E+01, 0.11365E+01, 0.11399E+01, 0.11433E+01, 0.11467E+01, & + 0.11501E+01, 0.11535E+01, 0.11569E+01, 0.11602E+01, 0.11636E+01, & + 0.11669E+01, 0.11703E+01, 0.11736E+01, 0.11770E+01, 0.11803E+01, & + 0.11836E+01, 0.11869E+01, 0.11902E+01, 0.11935E+01, 0.11969E+01, & + 0.12001E+01, 0.12034E+01, 0.12067E+01, 0.12100E+01, 0.12133E+01, & + 0.12165E+01, 0.12198E+01, 0.12231E+01, 0.12263E+01, 0.12296E+01, & + 0.12328E+01, 0.12360E+01, 0.12393E+01, 0.12425E+01, 0.12457E+01, & + 0.12489E+01, 0.12521E+01, 0.12553E+01, 0.12585E+01, 0.12617E+01, & + 0.12649E+01, 0.12681E+01, 0.12713E+01, 0.12744E+01, 0.12776E+01, & + 0.12808E+01, 0.12839E+01, 0.12871E+01, 0.12902E+01, 0.12934E+01, & + 0.12965E+01, 0.12996E+01, 0.13028E+01, 0.13059E+01, 0.13090E+01, & + 0.13121E+01, 0.13152E+01, 0.13183E+01, 0.13214E+01, 0.13245E+01/ + + DATA (BNC12M (I),I=401,500)/ & + 0.13276E+01, 0.13307E+01, 0.13337E+01, 0.13368E+01, 0.13399E+01, & + 0.13429E+01, 0.13460E+01, 0.13490E+01, 0.13521E+01, 0.13551E+01, & + 0.13581E+01, 0.13612E+01, 0.13642E+01, 0.13672E+01, 0.13702E+01, & + 0.13733E+01, 0.13763E+01, 0.13793E+01, 0.13823E+01, 0.13853E+01, & + 0.13882E+01, 0.13912E+01, 0.13942E+01, 0.13972E+01, 0.14001E+01, & + 0.14031E+01, 0.14061E+01, 0.14090E+01, 0.14120E+01, 0.14149E+01, & + 0.14179E+01, 0.14208E+01, 0.14237E+01, 0.14267E+01, 0.14296E+01, & + 0.14325E+01, 0.14354E+01, 0.14383E+01, 0.14412E+01, 0.14441E+01, & + 0.14470E+01, 0.14499E+01, 0.14528E+01, 0.14557E+01, 0.14586E+01, & + 0.14614E+01, 0.14643E+01, 0.14672E+01, 0.14700E+01, 0.14729E+01, & + 0.14758E+01, 0.14786E+01, 0.14815E+01, 0.14843E+01, 0.14871E+01, & + 0.14900E+01, 0.14928E+01, 0.14956E+01, 0.14984E+01, 0.15012E+01, & + 0.15041E+01, 0.15069E+01, 0.15097E+01, 0.15125E+01, 0.15153E+01, & + 0.15180E+01, 0.15208E+01, 0.15236E+01, 0.15264E+01, 0.15292E+01, & + 0.15319E+01, 0.15347E+01, 0.15375E+01, 0.15402E+01, 0.15430E+01, & + 0.15457E+01, 0.15485E+01, 0.15512E+01, 0.15539E+01, 0.15567E+01, & + 0.15594E+01, 0.15621E+01, 0.15648E+01, 0.15676E+01, 0.15703E+01, & + 0.15730E+01, 0.15757E+01, 0.15784E+01, 0.15811E+01, 0.15838E+01, & + 0.15865E+01, 0.15892E+01, 0.15918E+01, 0.15945E+01, 0.15972E+01, & + 0.15999E+01, 0.16025E+01, 0.16052E+01, 0.16079E+01, 0.16105E+01/ + + DATA (BNC12M (I),I=501,600)/ & + 0.16132E+01, 0.16158E+01, 0.16185E+01, 0.16211E+01, 0.16237E+01, & + 0.16264E+01, 0.16290E+01, 0.16316E+01, 0.16342E+01, 0.16369E+01, & + 0.16395E+01, 0.16421E+01, 0.16447E+01, 0.16473E+01, 0.16499E+01, & + 0.16525E+01, 0.16551E+01, 0.16577E+01, 0.16603E+01, 0.16628E+01, & + 0.16654E+01, 0.16680E+01, 0.16706E+01, 0.16731E+01, 0.16757E+01, & + 0.16783E+01, 0.16808E+01, 0.16834E+01, 0.16859E+01, 0.16885E+01, & + 0.16910E+01, 0.16935E+01, 0.16961E+01, 0.16986E+01, 0.17011E+01, & + 0.17037E+01, 0.17062E+01, 0.17087E+01, 0.17112E+01, 0.17137E+01, & + 0.17162E+01, 0.17188E+01, 0.17213E+01, 0.17238E+01, 0.17263E+01, & + 0.17287E+01, 0.17312E+01, 0.17337E+01, 0.17362E+01, 0.17387E+01, & + 0.17412E+01, 0.17436E+01, 0.17461E+01, 0.17486E+01, 0.17510E+01, & + 0.17535E+01, 0.17559E+01, 0.17584E+01, 0.17608E+01, 0.17633E+01, & + 0.17657E+01, 0.17682E+01, 0.17706E+01, 0.17730E+01, 0.17755E+01, & + 0.17779E+01, 0.17803E+01, 0.17827E+01, 0.17851E+01, 0.17876E+01, & + 0.17900E+01, 0.17924E+01, 0.17948E+01, 0.17972E+01, 0.17996E+01, & + 0.18020E+01, 0.18044E+01, 0.18068E+01, 0.18091E+01, 0.18115E+01, & + 0.18139E+01, 0.18163E+01, 0.18187E+01, 0.18210E+01, 0.18234E+01, & + 0.18258E+01, 0.18281E+01, 0.18305E+01, 0.18328E+01, 0.18352E+01, & + 0.18375E+01, 0.18399E+01, 0.18422E+01, 0.18446E+01, 0.18469E+01, & + 0.18492E+01, 0.18516E+01, 0.18539E+01, 0.18562E+01, 0.18649E+01/ + + DATA (BNC12M (I),I=601,700)/ & + 0.18839E+01, 0.19066E+01, 0.19291E+01, 0.19513E+01, 0.19732E+01, & + 0.19949E+01, 0.20163E+01, 0.20374E+01, 0.20583E+01, 0.20790E+01, & + 0.20994E+01, 0.21196E+01, 0.21396E+01, 0.21594E+01, 0.21789E+01, & + 0.21982E+01, 0.22174E+01, 0.22363E+01, 0.22550E+01, 0.22735E+01, & + 0.22918E+01, 0.23100E+01, 0.23279E+01, 0.23457E+01, 0.23633E+01, & + 0.23807E+01, 0.23979E+01, 0.24150E+01, 0.24319E+01, 0.24487E+01, & + 0.24653E+01, 0.24817E+01, 0.24980E+01, 0.25141E+01, 0.25301E+01, & + 0.25459E+01, 0.25616E+01, 0.25771E+01, 0.25925E+01, 0.26078E+01, & + 0.26229E+01, 0.26379E+01, 0.26527E+01, 0.26675E+01, 0.26821E+01, & + 0.26965E+01, 0.27109E+01, 0.27251E+01, 0.27393E+01, 0.27532E+01, & + 0.27671E+01, 0.27809E+01, 0.27945E+01, 0.28081E+01, 0.28215E+01, & + 0.28349E+01, 0.28481E+01, 0.28612E+01, 0.28742E+01, 0.28871E+01, & + 0.28999E+01, 0.29126E+01, 0.29252E+01, 0.29378E+01, 0.29502E+01, & + 0.29625E+01, 0.29747E+01, 0.29869E+01, 0.29989E+01, 0.30109E+01, & + 0.30228E+01, 0.30346E+01, 0.30463E+01, 0.30579E+01, 0.30694E+01, & + 0.30809E+01, 0.30923E+01, 0.31036E+01, 0.31148E+01, 0.31259E+01, & + 0.31370E+01, 0.31480E+01, 0.31589E+01, 0.31697E+01, 0.31805E+01, & + 0.31912E+01, 0.32018E+01, 0.32123E+01, 0.32228E+01, 0.32332E+01, & + 0.32436E+01, 0.32538E+01, 0.32640E+01, 0.32742E+01, 0.32842E+01, & + 0.32943E+01, 0.33042E+01, 0.33141E+01, 0.33239E+01, 0.33336E+01/ + + DATA (BNC12M(I),I=701,741)/ & + 0.33433E+01, 0.33530E+01, 0.33626E+01, 0.33721E+01, 0.33815E+01, & + 0.33909E+01, 0.34003E+01, 0.34095E+01, 0.34188E+01, 0.34279E+01, & + 0.34371E+01, 0.34461E+01, 0.34551E+01, 0.34641E+01, 0.34730E+01, & + 0.34819E+01, 0.34907E+01, 0.34994E+01, 0.35081E+01, 0.35167E+01, & + 0.35253E+01, 0.35339E+01, 0.35424E+01, 0.35508E+01, 0.35592E+01, & + 0.35676E+01, 0.35759E+01, 0.35842E+01, 0.35924E+01, 0.36006E+01, & + 0.36087E+01, 0.36168E+01, 0.36248E+01, 0.36328E+01, 0.36408E+01, & + 0.36487E+01, 0.36565E+01, 0.36644E+01, 0.36721E+01, 0.36799E+01, & + 0.36876E+01 & + / +! +! *** (NH4)3H(SO4)2 +! + DATA (BNC13M (I),I= 1,100)/ & + -0.84167E-01,-0.15304E+00,-0.20142E+00,-0.23431E+00,-0.25963E+00, & + -0.28033E+00,-0.29790E+00,-0.31317E+00,-0.32669E+00,-0.33881E+00, & + -0.34980E+00,-0.35984E+00,-0.36908E+00,-0.37764E+00,-0.38559E+00, & + -0.39302E+00,-0.39999E+00,-0.40654E+00,-0.41272E+00,-0.41855E+00, & + -0.42408E+00,-0.42933E+00,-0.43431E+00,-0.43905E+00,-0.44357E+00, & + -0.44789E+00,-0.45200E+00,-0.45594E+00,-0.45971E+00,-0.46332E+00, & + -0.46677E+00,-0.47008E+00,-0.47326E+00,-0.47631E+00,-0.47923E+00, & + -0.48204E+00,-0.48474E+00,-0.48734E+00,-0.48983E+00,-0.49223E+00, & + -0.49453E+00,-0.49675E+00,-0.49888E+00,-0.50093E+00,-0.50290E+00, & + -0.50480E+00,-0.50662E+00,-0.50838E+00,-0.51007E+00,-0.51169E+00, & + -0.51325E+00,-0.51476E+00,-0.51620E+00,-0.51759E+00,-0.51893E+00, & + -0.52021E+00,-0.52145E+00,-0.52263E+00,-0.52378E+00,-0.52487E+00, & + -0.52592E+00,-0.52693E+00,-0.52790E+00,-0.52883E+00,-0.52972E+00, & + -0.53058E+00,-0.53139E+00,-0.53218E+00,-0.53292E+00,-0.53364E+00, & + -0.53432E+00,-0.53498E+00,-0.53560E+00,-0.53619E+00,-0.53675E+00, & + -0.53729E+00,-0.53780E+00,-0.53828E+00,-0.53873E+00,-0.53916E+00, & + -0.53956E+00,-0.53994E+00,-0.54030E+00,-0.54063E+00,-0.54094E+00, & + -0.54122E+00,-0.54148E+00,-0.54173E+00,-0.54195E+00,-0.54215E+00, & + -0.54232E+00,-0.54248E+00,-0.54262E+00,-0.54275E+00,-0.54285E+00, & + -0.54293E+00,-0.54300E+00,-0.54305E+00,-0.54308E+00,-0.54310E+00/ + + DATA (BNC13M (I),I=101,200)/ & + -0.54310E+00,-0.54309E+00,-0.54306E+00,-0.54302E+00,-0.54296E+00, & + -0.54289E+00,-0.54281E+00,-0.54272E+00,-0.54261E+00,-0.54249E+00, & + -0.54236E+00,-0.54222E+00,-0.54207E+00,-0.54191E+00,-0.54174E+00, & + -0.54156E+00,-0.54137E+00,-0.54117E+00,-0.54097E+00,-0.54075E+00, & + -0.54062E+00,-0.54039E+00,-0.54014E+00,-0.53989E+00,-0.53964E+00, & + -0.53937E+00,-0.53911E+00,-0.53884E+00,-0.53856E+00,-0.53828E+00, & + -0.53800E+00,-0.53771E+00,-0.53742E+00,-0.53712E+00,-0.53682E+00, & + -0.53652E+00,-0.53621E+00,-0.53590E+00,-0.53559E+00,-0.53527E+00, & + -0.53495E+00,-0.53463E+00,-0.53430E+00,-0.53397E+00,-0.53364E+00, & + -0.53331E+00,-0.53297E+00,-0.53264E+00,-0.53230E+00,-0.53195E+00, & + -0.53161E+00,-0.53126E+00,-0.53092E+00,-0.53057E+00,-0.53022E+00, & + -0.52986E+00,-0.52951E+00,-0.52915E+00,-0.52879E+00,-0.52844E+00, & + -0.52808E+00,-0.52771E+00,-0.52735E+00,-0.52699E+00,-0.52662E+00, & + -0.52626E+00,-0.52589E+00,-0.52552E+00,-0.52515E+00,-0.52479E+00, & + -0.52442E+00,-0.52404E+00,-0.52367E+00,-0.52330E+00,-0.52293E+00, & + -0.52255E+00,-0.52218E+00,-0.52181E+00,-0.52143E+00,-0.52106E+00, & + -0.52068E+00,-0.52030E+00,-0.51993E+00,-0.51955E+00,-0.51918E+00, & + -0.51880E+00,-0.51842E+00,-0.51804E+00,-0.51767E+00,-0.51729E+00, & + -0.51691E+00,-0.51653E+00,-0.51615E+00,-0.51577E+00,-0.51540E+00, & + -0.51502E+00,-0.51464E+00,-0.51426E+00,-0.51388E+00,-0.51351E+00/ + + DATA (BNC13M (I),I=201,300)/ & + -0.51313E+00,-0.51275E+00,-0.51237E+00,-0.51199E+00,-0.51162E+00, & + -0.51124E+00,-0.51086E+00,-0.51049E+00,-0.51011E+00,-0.50973E+00, & + -0.50936E+00,-0.50898E+00,-0.50860E+00,-0.50823E+00,-0.50785E+00, & + -0.50748E+00,-0.50710E+00,-0.50673E+00,-0.50636E+00,-0.50598E+00, & + -0.50561E+00,-0.50524E+00,-0.50486E+00,-0.50449E+00,-0.50412E+00, & + -0.50375E+00,-0.50338E+00,-0.50301E+00,-0.50264E+00,-0.50227E+00, & + -0.50190E+00,-0.50153E+00,-0.50116E+00,-0.50079E+00,-0.50043E+00, & + -0.50006E+00,-0.49969E+00,-0.49933E+00,-0.49896E+00,-0.49860E+00, & + -0.49823E+00,-0.49787E+00,-0.49750E+00,-0.49714E+00,-0.49678E+00, & + -0.49642E+00,-0.49606E+00,-0.49569E+00,-0.49533E+00,-0.49497E+00, & + -0.49461E+00,-0.49426E+00,-0.49390E+00,-0.49354E+00,-0.49318E+00, & + -0.49283E+00,-0.49247E+00,-0.49211E+00,-0.49176E+00,-0.49141E+00, & + -0.49105E+00,-0.49070E+00,-0.49035E+00,-0.48999E+00,-0.48964E+00, & + -0.48929E+00,-0.48894E+00,-0.48859E+00,-0.48824E+00,-0.48789E+00, & + -0.48755E+00,-0.48720E+00,-0.48685E+00,-0.48651E+00,-0.48616E+00, & + -0.48581E+00,-0.48547E+00,-0.48513E+00,-0.48478E+00,-0.48444E+00, & + -0.48410E+00,-0.48376E+00,-0.48342E+00,-0.48308E+00,-0.48274E+00, & + -0.48240E+00,-0.48206E+00,-0.48172E+00,-0.48138E+00,-0.48105E+00, & + -0.48071E+00,-0.48038E+00,-0.48004E+00,-0.47971E+00,-0.47938E+00, & + -0.47904E+00,-0.47871E+00,-0.47838E+00,-0.47805E+00,-0.47772E+00/ + + DATA (BNC13M (I),I=301,400)/ & + -0.47739E+00,-0.47706E+00,-0.47673E+00,-0.47640E+00,-0.47608E+00, & + -0.47575E+00,-0.47542E+00,-0.47510E+00,-0.47477E+00,-0.47445E+00, & + -0.47413E+00,-0.47380E+00,-0.47348E+00,-0.47316E+00,-0.47284E+00, & + -0.47252E+00,-0.47220E+00,-0.47188E+00,-0.47156E+00,-0.47124E+00, & + -0.47093E+00,-0.47061E+00,-0.47029E+00,-0.46998E+00,-0.46966E+00, & + -0.46935E+00,-0.46903E+00,-0.46872E+00,-0.46841E+00,-0.46810E+00, & + -0.46779E+00,-0.46748E+00,-0.46717E+00,-0.46686E+00,-0.46655E+00, & + -0.46624E+00,-0.46593E+00,-0.46563E+00,-0.46532E+00,-0.46502E+00, & + -0.46471E+00,-0.46441E+00,-0.46410E+00,-0.46380E+00,-0.46350E+00, & + -0.46320E+00,-0.46289E+00,-0.46259E+00,-0.46229E+00,-0.46200E+00, & + -0.46170E+00,-0.46140E+00,-0.46110E+00,-0.46080E+00,-0.46051E+00, & + -0.46021E+00,-0.45992E+00,-0.45962E+00,-0.45933E+00,-0.45904E+00, & + -0.45874E+00,-0.45845E+00,-0.45816E+00,-0.45787E+00,-0.45758E+00, & + -0.45729E+00,-0.45700E+00,-0.45671E+00,-0.45642E+00,-0.45614E+00, & + -0.45585E+00,-0.45556E+00,-0.45528E+00,-0.45499E+00,-0.45471E+00, & + -0.45442E+00,-0.45414E+00,-0.45386E+00,-0.45358E+00,-0.45330E+00, & + -0.45302E+00,-0.45274E+00,-0.45246E+00,-0.45218E+00,-0.45190E+00, & + -0.45162E+00,-0.45134E+00,-0.45107E+00,-0.45079E+00,-0.45051E+00, & + -0.45024E+00,-0.44997E+00,-0.44969E+00,-0.44942E+00,-0.44915E+00, & + -0.44887E+00,-0.44860E+00,-0.44833E+00,-0.44806E+00,-0.44779E+00/ + + DATA (BNC13M (I),I=401,500)/ & + -0.44752E+00,-0.44725E+00,-0.44699E+00,-0.44672E+00,-0.44645E+00, & + -0.44619E+00,-0.44592E+00,-0.44565E+00,-0.44539E+00,-0.44513E+00, & + -0.44486E+00,-0.44460E+00,-0.44434E+00,-0.44408E+00,-0.44381E+00, & + -0.44355E+00,-0.44329E+00,-0.44303E+00,-0.44277E+00,-0.44252E+00, & + -0.44226E+00,-0.44200E+00,-0.44174E+00,-0.44149E+00,-0.44123E+00, & + -0.44098E+00,-0.44072E+00,-0.44047E+00,-0.44021E+00,-0.43996E+00, & + -0.43971E+00,-0.43946E+00,-0.43921E+00,-0.43896E+00,-0.43870E+00, & + -0.43846E+00,-0.43821E+00,-0.43796E+00,-0.43771E+00,-0.43746E+00, & + -0.43721E+00,-0.43697E+00,-0.43672E+00,-0.43648E+00,-0.43623E+00, & + -0.43599E+00,-0.43574E+00,-0.43550E+00,-0.43526E+00,-0.43502E+00, & + -0.43477E+00,-0.43453E+00,-0.43429E+00,-0.43405E+00,-0.43381E+00, & + -0.43357E+00,-0.43333E+00,-0.43310E+00,-0.43286E+00,-0.43262E+00, & + -0.43238E+00,-0.43215E+00,-0.43191E+00,-0.43168E+00,-0.43144E+00, & + -0.43121E+00,-0.43098E+00,-0.43074E+00,-0.43051E+00,-0.43028E+00, & + -0.43005E+00,-0.42982E+00,-0.42959E+00,-0.42936E+00,-0.42913E+00, & + -0.42890E+00,-0.42867E+00,-0.42844E+00,-0.42821E+00,-0.42799E+00, & + -0.42776E+00,-0.42754E+00,-0.42731E+00,-0.42708E+00,-0.42686E+00, & + -0.42664E+00,-0.42641E+00,-0.42619E+00,-0.42597E+00,-0.42575E+00, & + -0.42552E+00,-0.42530E+00,-0.42508E+00,-0.42486E+00,-0.42464E+00, & + -0.42442E+00,-0.42421E+00,-0.42399E+00,-0.42377E+00,-0.42355E+00/ + + DATA (BNC13M (I),I=501,600)/ & + -0.42334E+00,-0.42312E+00,-0.42290E+00,-0.42269E+00,-0.42248E+00, & + -0.42226E+00,-0.42205E+00,-0.42183E+00,-0.42162E+00,-0.42141E+00, & + -0.42120E+00,-0.42099E+00,-0.42077E+00,-0.42056E+00,-0.42035E+00, & + -0.42014E+00,-0.41994E+00,-0.41973E+00,-0.41952E+00,-0.41931E+00, & + -0.41910E+00,-0.41890E+00,-0.41869E+00,-0.41849E+00,-0.41828E+00, & + -0.41808E+00,-0.41787E+00,-0.41767E+00,-0.41746E+00,-0.41726E+00, & + -0.41706E+00,-0.41686E+00,-0.41665E+00,-0.41645E+00,-0.41625E+00, & + -0.41605E+00,-0.41585E+00,-0.41565E+00,-0.41545E+00,-0.41526E+00, & + -0.41506E+00,-0.41486E+00,-0.41466E+00,-0.41447E+00,-0.41427E+00, & + -0.41407E+00,-0.41388E+00,-0.41368E+00,-0.41349E+00,-0.41329E+00, & + -0.41310E+00,-0.41291E+00,-0.41272E+00,-0.41252E+00,-0.41233E+00, & + -0.41214E+00,-0.41195E+00,-0.41176E+00,-0.41157E+00,-0.41138E+00, & + -0.41119E+00,-0.41100E+00,-0.41081E+00,-0.41062E+00,-0.41044E+00, & + -0.41025E+00,-0.41006E+00,-0.40988E+00,-0.40969E+00,-0.40950E+00, & + -0.40932E+00,-0.40914E+00,-0.40895E+00,-0.40877E+00,-0.40858E+00, & + -0.40840E+00,-0.40822E+00,-0.40804E+00,-0.40785E+00,-0.40767E+00, & + -0.40749E+00,-0.40731E+00,-0.40713E+00,-0.40695E+00,-0.40677E+00, & + -0.40659E+00,-0.40642E+00,-0.40624E+00,-0.40606E+00,-0.40588E+00, & + -0.40571E+00,-0.40553E+00,-0.40535E+00,-0.40518E+00,-0.40500E+00, & + -0.40483E+00,-0.40466E+00,-0.40448E+00,-0.40431E+00,-0.40366E+00/ + + DATA (BNC13M (I),I=601,700)/ & + -0.40226E+00,-0.40059E+00,-0.39896E+00,-0.39738E+00,-0.39582E+00, & + -0.39431E+00,-0.39283E+00,-0.39138E+00,-0.38998E+00,-0.38860E+00, & + -0.38726E+00,-0.38595E+00,-0.38467E+00,-0.38343E+00,-0.38221E+00, & + -0.38103E+00,-0.37988E+00,-0.37876E+00,-0.37766E+00,-0.37660E+00, & + -0.37556E+00,-0.37455E+00,-0.37357E+00,-0.37261E+00,-0.37169E+00, & + -0.37078E+00,-0.36991E+00,-0.36906E+00,-0.36823E+00,-0.36743E+00, & + -0.36665E+00,-0.36590E+00,-0.36516E+00,-0.36446E+00,-0.36377E+00, & + -0.36311E+00,-0.36247E+00,-0.36185E+00,-0.36125E+00,-0.36067E+00, & + -0.36012E+00,-0.35958E+00,-0.35907E+00,-0.35857E+00,-0.35809E+00, & + -0.35764E+00,-0.35720E+00,-0.35678E+00,-0.35638E+00,-0.35600E+00, & + -0.35563E+00,-0.35529E+00,-0.35496E+00,-0.35465E+00,-0.35435E+00, & + -0.35407E+00,-0.35381E+00,-0.35357E+00,-0.35334E+00,-0.35313E+00, & + -0.35293E+00,-0.35275E+00,-0.35258E+00,-0.35243E+00,-0.35229E+00, & + -0.35217E+00,-0.35206E+00,-0.35197E+00,-0.35189E+00,-0.35183E+00, & + -0.35178E+00,-0.35174E+00,-0.35172E+00,-0.35171E+00,-0.35171E+00, & + -0.35173E+00,-0.35176E+00,-0.35180E+00,-0.35186E+00,-0.35193E+00, & + -0.35201E+00,-0.35210E+00,-0.35220E+00,-0.35232E+00,-0.35245E+00, & + -0.35258E+00,-0.35274E+00,-0.35290E+00,-0.35307E+00,-0.35326E+00, & + -0.35345E+00,-0.35366E+00,-0.35387E+00,-0.35410E+00,-0.35434E+00, & + -0.35459E+00,-0.35485E+00,-0.35512E+00,-0.35540E+00,-0.35569E+00/ + + DATA (BNC13M(I),I=701,741)/ & + -0.35599E+00,-0.35629E+00,-0.35661E+00,-0.35694E+00,-0.35728E+00, & + -0.35763E+00,-0.35798E+00,-0.35835E+00,-0.35872E+00,-0.35911E+00, & + -0.35950E+00,-0.35990E+00,-0.36031E+00,-0.36073E+00,-0.36116E+00, & + -0.36159E+00,-0.36204E+00,-0.36249E+00,-0.36295E+00,-0.36342E+00, & + -0.36390E+00,-0.36438E+00,-0.36487E+00,-0.36538E+00,-0.36588E+00, & + -0.36640E+00,-0.36692E+00,-0.36746E+00,-0.36799E+00,-0.36854E+00, & + -0.36909E+00,-0.36966E+00,-0.37022E+00,-0.37080E+00,-0.37138E+00, & + -0.37197E+00,-0.37257E+00,-0.37317E+00,-0.37378E+00,-0.37440E+00, & + -0.37502E+00 & + / + END Module kmc273 diff --git a/wrfv2_fire/chem/module_data_isrpia_kmc298.F b/wrfv2_fire/chem/module_data_isrpia_kmc298.F new file mode 100755 index 00000000..37779d78 --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_kmc298.F @@ -0,0 +1,2193 @@ + + MODULE KMC298 + DOUBLE PRECISION :: & + BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & + BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & + BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & + BNC13M( 741) + +! +! *** NaCl +! + DATA (BNC01M (I),I= 1,100)/ & + -0.49998E-01,-0.88352E-01,-0.11333E+00,-0.12907E+00,-0.14035E+00, & + -0.14892E+00,-0.15567E+00,-0.16110E+00,-0.16552E+00,-0.16915E+00, & + -0.17214E+00,-0.17461E+00,-0.17663E+00,-0.17828E+00,-0.17961E+00, & + -0.18066E+00,-0.18146E+00,-0.18205E+00,-0.18245E+00,-0.18268E+00, & + -0.18276E+00,-0.18270E+00,-0.18252E+00,-0.18222E+00,-0.18183E+00, & + -0.18134E+00,-0.18077E+00,-0.18013E+00,-0.17941E+00,-0.17864E+00, & + -0.17780E+00,-0.17691E+00,-0.17598E+00,-0.17500E+00,-0.17397E+00, & + -0.17292E+00,-0.17182E+00,-0.17070E+00,-0.16955E+00,-0.16837E+00, & + -0.16717E+00,-0.16594E+00,-0.16470E+00,-0.16343E+00,-0.16215E+00, & + -0.16086E+00,-0.15955E+00,-0.15823E+00,-0.15690E+00,-0.15555E+00, & + -0.15420E+00,-0.15283E+00,-0.15146E+00,-0.15008E+00,-0.14869E+00, & + -0.14729E+00,-0.14589E+00,-0.14448E+00,-0.14306E+00,-0.14163E+00, & + -0.14020E+00,-0.13877E+00,-0.13732E+00,-0.13587E+00,-0.13441E+00, & + -0.13294E+00,-0.13147E+00,-0.12999E+00,-0.12850E+00,-0.12700E+00, & + -0.12549E+00,-0.12397E+00,-0.12245E+00,-0.12091E+00,-0.11936E+00, & + -0.11781E+00,-0.11624E+00,-0.11466E+00,-0.11307E+00,-0.11147E+00, & + -0.10985E+00,-0.10823E+00,-0.10659E+00,-0.10493E+00,-0.10327E+00, & + -0.10159E+00,-0.99900E-01,-0.98196E-01,-0.96479E-01,-0.94748E-01, & + -0.93005E-01,-0.91248E-01,-0.89479E-01,-0.87697E-01,-0.85902E-01, & + -0.84096E-01,-0.82277E-01,-0.80446E-01,-0.78604E-01,-0.76751E-01/ + + DATA (BNC01M (I),I=101,200)/ & + -0.74887E-01,-0.73013E-01,-0.71128E-01,-0.69234E-01,-0.67331E-01, & + -0.65418E-01,-0.63498E-01,-0.61569E-01,-0.59633E-01,-0.57689E-01, & + -0.55739E-01,-0.53782E-01,-0.51819E-01,-0.49851E-01,-0.47877E-01, & + -0.45899E-01,-0.43917E-01,-0.41930E-01,-0.39940E-01,-0.37946E-01, & + -0.36169E-01,-0.34144E-01,-0.32120E-01,-0.30095E-01,-0.28071E-01, & + -0.26048E-01,-0.24024E-01,-0.22002E-01,-0.19979E-01,-0.17958E-01, & + -0.15937E-01,-0.13916E-01,-0.11897E-01,-0.98784E-02,-0.78606E-02, & + -0.58439E-02,-0.38280E-02,-0.18133E-02, 0.20048E-03, 0.22131E-02, & + 0.42245E-02, 0.62347E-02, 0.82436E-02, 0.10251E-01, 0.12258E-01, & + 0.14263E-01, 0.16266E-01, 0.18268E-01, 0.20269E-01, 0.22268E-01, & + 0.24266E-01, 0.26262E-01, 0.28256E-01, 0.30249E-01, 0.32240E-01, & + 0.34229E-01, 0.36217E-01, 0.38203E-01, 0.40187E-01, 0.42170E-01, & + 0.44150E-01, 0.46129E-01, 0.48106E-01, 0.50081E-01, 0.52054E-01, & + 0.54025E-01, 0.55994E-01, 0.57961E-01, 0.59926E-01, 0.61889E-01, & + 0.63850E-01, 0.65809E-01, 0.67766E-01, 0.69721E-01, 0.71674E-01, & + 0.73625E-01, 0.75573E-01, 0.77519E-01, 0.79464E-01, 0.81406E-01, & + 0.83345E-01, 0.85283E-01, 0.87218E-01, 0.89152E-01, 0.91082E-01, & + 0.93011E-01, 0.94937E-01, 0.96862E-01, 0.98783E-01, 0.10070E+00, & + 0.10262E+00, 0.10453E+00, 0.10645E+00, 0.10836E+00, 0.11027E+00, & + 0.11217E+00, 0.11407E+00, 0.11597E+00, 0.11787E+00, 0.11977E+00/ + + DATA (BNC01M (I),I=201,300)/ & + 0.12166E+00, 0.12355E+00, 0.12544E+00, 0.12733E+00, 0.12921E+00, & + 0.13109E+00, 0.13297E+00, 0.13485E+00, 0.13672E+00, 0.13860E+00, & + 0.14047E+00, 0.14233E+00, 0.14420E+00, 0.14606E+00, 0.14792E+00, & + 0.14978E+00, 0.15163E+00, 0.15348E+00, 0.15533E+00, 0.15718E+00, & + 0.15902E+00, 0.16087E+00, 0.16271E+00, 0.16454E+00, 0.16638E+00, & + 0.16821E+00, 0.17004E+00, 0.17187E+00, 0.17369E+00, 0.17551E+00, & + 0.17733E+00, 0.17915E+00, 0.18097E+00, 0.18278E+00, 0.18459E+00, & + 0.18640E+00, 0.18820E+00, 0.19000E+00, 0.19180E+00, 0.19360E+00, & + 0.19540E+00, 0.19719E+00, 0.19898E+00, 0.20076E+00, 0.20255E+00, & + 0.20433E+00, 0.20611E+00, 0.20789E+00, 0.20966E+00, 0.21144E+00, & + 0.21321E+00, 0.21497E+00, 0.21674E+00, 0.21850E+00, 0.22026E+00, & + 0.22202E+00, 0.22377E+00, 0.22553E+00, 0.22727E+00, 0.22902E+00, & + 0.23077E+00, 0.23251E+00, 0.23425E+00, 0.23599E+00, 0.23772E+00, & + 0.23946E+00, 0.24119E+00, 0.24291E+00, 0.24464E+00, 0.24636E+00, & + 0.24808E+00, 0.24980E+00, 0.25152E+00, 0.25323E+00, 0.25494E+00, & + 0.25665E+00, 0.25835E+00, 0.26006E+00, 0.26176E+00, 0.26346E+00, & + 0.26515E+00, 0.26684E+00, 0.26854E+00, 0.27022E+00, 0.27191E+00, & + 0.27360E+00, 0.27528E+00, 0.27696E+00, 0.27863E+00, 0.28031E+00, & + 0.28198E+00, 0.28365E+00, 0.28532E+00, 0.28698E+00, 0.28864E+00, & + 0.29030E+00, 0.29196E+00, 0.29362E+00, 0.29527E+00, 0.29692E+00/ + + DATA (BNC01M (I),I=301,400)/ & + 0.29857E+00, 0.30021E+00, 0.30186E+00, 0.30350E+00, 0.30514E+00, & + 0.30677E+00, 0.30841E+00, 0.31004E+00, 0.31167E+00, 0.31330E+00, & + 0.31492E+00, 0.31654E+00, 0.31816E+00, 0.31978E+00, 0.32140E+00, & + 0.32301E+00, 0.32462E+00, 0.32623E+00, 0.32784E+00, 0.32944E+00, & + 0.33104E+00, 0.33264E+00, 0.33424E+00, 0.33584E+00, 0.33743E+00, & + 0.33902E+00, 0.34061E+00, 0.34219E+00, 0.34378E+00, 0.34536E+00, & + 0.34694E+00, 0.34852E+00, 0.35009E+00, 0.35166E+00, 0.35323E+00, & + 0.35480E+00, 0.35637E+00, 0.35793E+00, 0.35949E+00, 0.36105E+00, & + 0.36261E+00, 0.36417E+00, 0.36572E+00, 0.36727E+00, 0.36882E+00, & + 0.37036E+00, 0.37191E+00, 0.37345E+00, 0.37499E+00, 0.37653E+00, & + 0.37806E+00, 0.37960E+00, 0.38113E+00, 0.38266E+00, 0.38419E+00, & + 0.38571E+00, 0.38723E+00, 0.38875E+00, 0.39027E+00, 0.39179E+00, & + 0.39330E+00, 0.39482E+00, 0.39633E+00, 0.39783E+00, 0.39934E+00, & + 0.40084E+00, 0.40235E+00, 0.40384E+00, 0.40534E+00, 0.40684E+00, & + 0.40833E+00, 0.40982E+00, 0.41131E+00, 0.41280E+00, 0.41429E+00, & + 0.41577E+00, 0.41725E+00, 0.41873E+00, 0.42021E+00, 0.42168E+00, & + 0.42315E+00, 0.42463E+00, 0.42609E+00, 0.42756E+00, 0.42903E+00, & + 0.43049E+00, 0.43195E+00, 0.43341E+00, 0.43487E+00, 0.43632E+00, & + 0.43778E+00, 0.43923E+00, 0.44068E+00, 0.44212E+00, 0.44357E+00, & + 0.44501E+00, 0.44645E+00, 0.44789E+00, 0.44933E+00, 0.45077E+00/ + + DATA (BNC01M (I),I=401,500)/ & + 0.45220E+00, 0.45363E+00, 0.45506E+00, 0.45649E+00, 0.45792E+00, & + 0.45934E+00, 0.46076E+00, 0.46218E+00, 0.46360E+00, 0.46502E+00, & + 0.46643E+00, 0.46784E+00, 0.46926E+00, 0.47066E+00, 0.47207E+00, & + 0.47348E+00, 0.47488E+00, 0.47628E+00, 0.47768E+00, 0.47908E+00, & + 0.48047E+00, 0.48187E+00, 0.48326E+00, 0.48465E+00, 0.48604E+00, & + 0.48743E+00, 0.48881E+00, 0.49019E+00, 0.49157E+00, 0.49295E+00, & + 0.49433E+00, 0.49571E+00, 0.49708E+00, 0.49845E+00, 0.49982E+00, & + 0.50119E+00, 0.50256E+00, 0.50392E+00, 0.50529E+00, 0.50665E+00, & + 0.50801E+00, 0.50937E+00, 0.51072E+00, 0.51208E+00, 0.51343E+00, & + 0.51478E+00, 0.51613E+00, 0.51748E+00, 0.51882E+00, 0.52017E+00, & + 0.52151E+00, 0.52285E+00, 0.52419E+00, 0.52553E+00, 0.52686E+00, & + 0.52819E+00, 0.52953E+00, 0.53086E+00, 0.53218E+00, 0.53351E+00, & + 0.53484E+00, 0.53616E+00, 0.53748E+00, 0.53880E+00, 0.54012E+00, & + 0.54144E+00, 0.54275E+00, 0.54406E+00, 0.54538E+00, 0.54669E+00, & + 0.54799E+00, 0.54930E+00, 0.55061E+00, 0.55191E+00, 0.55321E+00, & + 0.55451E+00, 0.55581E+00, 0.55711E+00, 0.55840E+00, 0.55970E+00, & + 0.56099E+00, 0.56228E+00, 0.56357E+00, 0.56485E+00, 0.56614E+00, & + 0.56742E+00, 0.56870E+00, 0.56999E+00, 0.57126E+00, 0.57254E+00, & + 0.57382E+00, 0.57509E+00, 0.57637E+00, 0.57764E+00, 0.57891E+00, & + 0.58017E+00, 0.58144E+00, 0.58271E+00, 0.58397E+00, 0.58523E+00/ + + DATA (BNC01M (I),I=501,600)/ & + 0.58649E+00, 0.58775E+00, 0.58901E+00, 0.59026E+00, 0.59152E+00, & + 0.59277E+00, 0.59402E+00, 0.59527E+00, 0.59652E+00, 0.59776E+00, & + 0.59901E+00, 0.60025E+00, 0.60149E+00, 0.60273E+00, 0.60397E+00, & + 0.60521E+00, 0.60645E+00, 0.60768E+00, 0.60891E+00, 0.61014E+00, & + 0.61137E+00, 0.61260E+00, 0.61383E+00, 0.61506E+00, 0.61628E+00, & + 0.61750E+00, 0.61872E+00, 0.61994E+00, 0.62116E+00, 0.62238E+00, & + 0.62359E+00, 0.62481E+00, 0.62602E+00, 0.62723E+00, 0.62844E+00, & + 0.62965E+00, 0.63085E+00, 0.63206E+00, 0.63326E+00, 0.63446E+00, & + 0.63567E+00, 0.63687E+00, 0.63806E+00, 0.63926E+00, 0.64045E+00, & + 0.64165E+00, 0.64284E+00, 0.64403E+00, 0.64522E+00, 0.64641E+00, & + 0.64760E+00, 0.64878E+00, 0.64997E+00, 0.65115E+00, 0.65233E+00, & + 0.65351E+00, 0.65469E+00, 0.65587E+00, 0.65704E+00, 0.65822E+00, & + 0.65939E+00, 0.66056E+00, 0.66173E+00, 0.66290E+00, 0.66407E+00, & + 0.66523E+00, 0.66640E+00, 0.66756E+00, 0.66872E+00, 0.66988E+00, & + 0.67104E+00, 0.67220E+00, 0.67336E+00, 0.67452E+00, 0.67567E+00, & + 0.67682E+00, 0.67797E+00, 0.67912E+00, 0.68027E+00, 0.68142E+00, & + 0.68257E+00, 0.68371E+00, 0.68486E+00, 0.68600E+00, 0.68714E+00, & + 0.68828E+00, 0.68942E+00, 0.69056E+00, 0.69169E+00, 0.69283E+00, & + 0.69396E+00, 0.69509E+00, 0.69622E+00, 0.69735E+00, 0.69848E+00, & + 0.69961E+00, 0.70073E+00, 0.70186E+00, 0.70298E+00, 0.70718E+00/ + + DATA (BNC01M (I),I=601,700)/ & + 0.71636E+00, 0.72738E+00, 0.73828E+00, 0.74906E+00, 0.75972E+00, & + 0.77027E+00, 0.78071E+00, 0.79104E+00, 0.80127E+00, 0.81139E+00, & + 0.82141E+00, 0.83133E+00, 0.84115E+00, 0.85087E+00, 0.86050E+00, & + 0.87004E+00, 0.87948E+00, 0.88883E+00, 0.89810E+00, 0.90728E+00, & + 0.91638E+00, 0.92539E+00, 0.93432E+00, 0.94316E+00, 0.95193E+00, & + 0.96063E+00, 0.96924E+00, 0.97778E+00, 0.98625E+00, 0.99464E+00, & + 0.10030E+01, 0.10112E+01, 0.10194E+01, 0.10275E+01, 0.10356E+01, & + 0.10435E+01, 0.10515E+01, 0.10593E+01, 0.10671E+01, 0.10748E+01, & + 0.10825E+01, 0.10901E+01, 0.10977E+01, 0.11051E+01, 0.11126E+01, & + 0.11200E+01, 0.11273E+01, 0.11345E+01, 0.11418E+01, 0.11489E+01, & + 0.11560E+01, 0.11631E+01, 0.11701E+01, 0.11770E+01, 0.11839E+01, & + 0.11908E+01, 0.11976E+01, 0.12044E+01, 0.12111E+01, 0.12177E+01, & + 0.12244E+01, 0.12309E+01, 0.12375E+01, 0.12440E+01, 0.12504E+01, & + 0.12568E+01, 0.12632E+01, 0.12695E+01, 0.12758E+01, 0.12820E+01, & + 0.12882E+01, 0.12943E+01, 0.13005E+01, 0.13065E+01, 0.13126E+01, & + 0.13186E+01, 0.13246E+01, 0.13305E+01, 0.13364E+01, 0.13422E+01, & + 0.13481E+01, 0.13539E+01, 0.13596E+01, 0.13653E+01, 0.13710E+01, & + 0.13767E+01, 0.13823E+01, 0.13879E+01, 0.13934E+01, 0.13990E+01, & + 0.14044E+01, 0.14099E+01, 0.14153E+01, 0.14207E+01, 0.14261E+01, & + 0.14314E+01, 0.14368E+01, 0.14420E+01, 0.14473E+01, 0.14525E+01/ + + DATA (BNC01M(I),I=701,741)/ & + 0.14577E+01, 0.14629E+01, 0.14680E+01, 0.14731E+01, 0.14782E+01, & + 0.14833E+01, 0.14883E+01, 0.14933E+01, 0.14983E+01, 0.15033E+01, & + 0.15082E+01, 0.15131E+01, 0.15180E+01, 0.15228E+01, 0.15277E+01, & + 0.15325E+01, 0.15372E+01, 0.15420E+01, 0.15467E+01, 0.15515E+01, & + 0.15561E+01, 0.15608E+01, 0.15655E+01, 0.15701E+01, 0.15747E+01, & + 0.15793E+01, 0.15838E+01, 0.15884E+01, 0.15929E+01, 0.15974E+01, & + 0.16018E+01, 0.16063E+01, 0.16107E+01, 0.16151E+01, 0.16195E+01, & + 0.16239E+01, 0.16282E+01, 0.16326E+01, 0.16369E+01, 0.16412E+01, & + 0.16454E+01 & + / +! +! *** Na2SO4 +! + DATA (BNC02M (I),I= 1,100)/ & + -0.10298E+00,-0.18764E+00,-0.24726E+00,-0.28786E+00,-0.31914E+00, & + -0.34476E+00,-0.36652E+00,-0.38546E+00,-0.40225E+00,-0.41734E+00, & + -0.43104E+00,-0.44360E+00,-0.45519E+00,-0.46595E+00,-0.47599E+00, & + -0.48541E+00,-0.49427E+00,-0.50264E+00,-0.51057E+00,-0.51811E+00, & + -0.52529E+00,-0.53214E+00,-0.53869E+00,-0.54497E+00,-0.55100E+00, & + -0.55680E+00,-0.56238E+00,-0.56776E+00,-0.57295E+00,-0.57797E+00, & + -0.58283E+00,-0.58753E+00,-0.59209E+00,-0.59651E+00,-0.60081E+00, & + -0.60498E+00,-0.60904E+00,-0.61298E+00,-0.61683E+00,-0.62058E+00, & + -0.62423E+00,-0.62779E+00,-0.63127E+00,-0.63466E+00,-0.63798E+00, & + -0.64123E+00,-0.64440E+00,-0.64750E+00,-0.65054E+00,-0.65351E+00, & + -0.65642E+00,-0.65928E+00,-0.66208E+00,-0.66482E+00,-0.66751E+00, & + -0.67015E+00,-0.67275E+00,-0.67529E+00,-0.67779E+00,-0.68025E+00, & + -0.68267E+00,-0.68504E+00,-0.68738E+00,-0.68968E+00,-0.69194E+00, & + -0.69416E+00,-0.69636E+00,-0.69852E+00,-0.70064E+00,-0.70274E+00, & + -0.70481E+00,-0.70685E+00,-0.70886E+00,-0.71084E+00,-0.71280E+00, & + -0.71473E+00,-0.71663E+00,-0.71852E+00,-0.72038E+00,-0.72221E+00, & + -0.72403E+00,-0.72583E+00,-0.72760E+00,-0.72935E+00,-0.73109E+00, & + -0.73281E+00,-0.73450E+00,-0.73618E+00,-0.73785E+00,-0.73949E+00, & + -0.74112E+00,-0.74274E+00,-0.74434E+00,-0.74592E+00,-0.74749E+00, & + -0.74904E+00,-0.75058E+00,-0.75210E+00,-0.75361E+00,-0.75511E+00/ + + DATA (BNC02M (I),I=101,200)/ & + -0.75660E+00,-0.75807E+00,-0.75953E+00,-0.76097E+00,-0.76241E+00, & + -0.76383E+00,-0.76524E+00,-0.76664E+00,-0.76803E+00,-0.76940E+00, & + -0.77077E+00,-0.77212E+00,-0.77346E+00,-0.77479E+00,-0.77612E+00, & + -0.77743E+00,-0.77873E+00,-0.78002E+00,-0.78130E+00,-0.78257E+00, & + -0.78379E+00,-0.78505E+00,-0.78629E+00,-0.78753E+00,-0.78876E+00, & + -0.78997E+00,-0.79118E+00,-0.79238E+00,-0.79357E+00,-0.79475E+00, & + -0.79592E+00,-0.79708E+00,-0.79824E+00,-0.79939E+00,-0.80052E+00, & + -0.80165E+00,-0.80277E+00,-0.80389E+00,-0.80499E+00,-0.80609E+00, & + -0.80718E+00,-0.80827E+00,-0.80934E+00,-0.81041E+00,-0.81147E+00, & + -0.81253E+00,-0.81358E+00,-0.81462E+00,-0.81565E+00,-0.81668E+00, & + -0.81770E+00,-0.81871E+00,-0.81972E+00,-0.82072E+00,-0.82172E+00, & + -0.82270E+00,-0.82369E+00,-0.82466E+00,-0.82563E+00,-0.82660E+00, & + -0.82756E+00,-0.82851E+00,-0.82946E+00,-0.83040E+00,-0.83133E+00, & + -0.83227E+00,-0.83319E+00,-0.83411E+00,-0.83503E+00,-0.83593E+00, & + -0.83684E+00,-0.83774E+00,-0.83863E+00,-0.83952E+00,-0.84040E+00, & + -0.84128E+00,-0.84216E+00,-0.84303E+00,-0.84389E+00,-0.84475E+00, & + -0.84561E+00,-0.84646E+00,-0.84731E+00,-0.84815E+00,-0.84898E+00, & + -0.84982E+00,-0.85065E+00,-0.85147E+00,-0.85229E+00,-0.85311E+00, & + -0.85392E+00,-0.85473E+00,-0.85553E+00,-0.85633E+00,-0.85712E+00, & + -0.85792E+00,-0.85870E+00,-0.85949E+00,-0.86027E+00,-0.86104E+00/ + + DATA (BNC02M (I),I=201,300)/ & + -0.86182E+00,-0.86258E+00,-0.86335E+00,-0.86411E+00,-0.86487E+00, & + -0.86562E+00,-0.86637E+00,-0.86712E+00,-0.86786E+00,-0.86860E+00, & + -0.86934E+00,-0.87007E+00,-0.87080E+00,-0.87153E+00,-0.87225E+00, & + -0.87297E+00,-0.87369E+00,-0.87440E+00,-0.87511E+00,-0.87582E+00, & + -0.87652E+00,-0.87722E+00,-0.87792E+00,-0.87862E+00,-0.87931E+00, & + -0.88000E+00,-0.88068E+00,-0.88136E+00,-0.88204E+00,-0.88272E+00, & + -0.88340E+00,-0.88407E+00,-0.88473E+00,-0.88540E+00,-0.88606E+00, & + -0.88672E+00,-0.88738E+00,-0.88804E+00,-0.88869E+00,-0.88934E+00, & + -0.88998E+00,-0.89063E+00,-0.89127E+00,-0.89191E+00,-0.89254E+00, & + -0.89318E+00,-0.89381E+00,-0.89444E+00,-0.89506E+00,-0.89569E+00, & + -0.89631E+00,-0.89693E+00,-0.89754E+00,-0.89816E+00,-0.89877E+00, & + -0.89938E+00,-0.89998E+00,-0.90059E+00,-0.90119E+00,-0.90179E+00, & + -0.90239E+00,-0.90299E+00,-0.90358E+00,-0.90417E+00,-0.90476E+00, & + -0.90535E+00,-0.90593E+00,-0.90651E+00,-0.90709E+00,-0.90767E+00, & + -0.90825E+00,-0.90882E+00,-0.90939E+00,-0.90996E+00,-0.91053E+00, & + -0.91110E+00,-0.91166E+00,-0.91222E+00,-0.91278E+00,-0.91334E+00, & + -0.91389E+00,-0.91445E+00,-0.91500E+00,-0.91555E+00,-0.91610E+00, & + -0.91664E+00,-0.91719E+00,-0.91773E+00,-0.91827E+00,-0.91881E+00, & + -0.91935E+00,-0.91988E+00,-0.92042E+00,-0.92095E+00,-0.92148E+00, & + -0.92201E+00,-0.92253E+00,-0.92306E+00,-0.92358E+00,-0.92410E+00/ + + DATA (BNC02M (I),I=301,400)/ & + -0.92462E+00,-0.92514E+00,-0.92565E+00,-0.92617E+00,-0.92668E+00, & + -0.92719E+00,-0.92770E+00,-0.92821E+00,-0.92871E+00,-0.92922E+00, & + -0.92972E+00,-0.93022E+00,-0.93072E+00,-0.93122E+00,-0.93171E+00, & + -0.93221E+00,-0.93270E+00,-0.93319E+00,-0.93368E+00,-0.93417E+00, & + -0.93466E+00,-0.93515E+00,-0.93563E+00,-0.93611E+00,-0.93659E+00, & + -0.93707E+00,-0.93755E+00,-0.93803E+00,-0.93850E+00,-0.93898E+00, & + -0.93945E+00,-0.93992E+00,-0.94039E+00,-0.94086E+00,-0.94133E+00, & + -0.94179E+00,-0.94226E+00,-0.94272E+00,-0.94318E+00,-0.94364E+00, & + -0.94410E+00,-0.94456E+00,-0.94501E+00,-0.94547E+00,-0.94592E+00, & + -0.94637E+00,-0.94682E+00,-0.94727E+00,-0.94772E+00,-0.94817E+00, & + -0.94861E+00,-0.94906E+00,-0.94950E+00,-0.94994E+00,-0.95038E+00, & + -0.95082E+00,-0.95126E+00,-0.95170E+00,-0.95213E+00,-0.95257E+00, & + -0.95300E+00,-0.95343E+00,-0.95386E+00,-0.95429E+00,-0.95472E+00, & + -0.95515E+00,-0.95557E+00,-0.95600E+00,-0.95642E+00,-0.95685E+00, & + -0.95727E+00,-0.95769E+00,-0.95811E+00,-0.95853E+00,-0.95894E+00, & + -0.95936E+00,-0.95977E+00,-0.96019E+00,-0.96060E+00,-0.96101E+00, & + -0.96142E+00,-0.96183E+00,-0.96224E+00,-0.96265E+00,-0.96305E+00, & + -0.96346E+00,-0.96386E+00,-0.96427E+00,-0.96467E+00,-0.96507E+00, & + -0.96547E+00,-0.96587E+00,-0.96627E+00,-0.96666E+00,-0.96706E+00, & + -0.96745E+00,-0.96785E+00,-0.96824E+00,-0.96863E+00,-0.96902E+00/ + + DATA (BNC02M (I),I=401,500)/ & + -0.96941E+00,-0.96980E+00,-0.97019E+00,-0.97058E+00,-0.97096E+00, & + -0.97135E+00,-0.97173E+00,-0.97211E+00,-0.97250E+00,-0.97288E+00, & + -0.97326E+00,-0.97364E+00,-0.97402E+00,-0.97439E+00,-0.97477E+00, & + -0.97515E+00,-0.97552E+00,-0.97589E+00,-0.97627E+00,-0.97664E+00, & + -0.97701E+00,-0.97738E+00,-0.97775E+00,-0.97812E+00,-0.97849E+00, & + -0.97885E+00,-0.97922E+00,-0.97958E+00,-0.97995E+00,-0.98031E+00, & + -0.98067E+00,-0.98104E+00,-0.98140E+00,-0.98176E+00,-0.98212E+00, & + -0.98247E+00,-0.98283E+00,-0.98319E+00,-0.98354E+00,-0.98390E+00, & + -0.98425E+00,-0.98461E+00,-0.98496E+00,-0.98531E+00,-0.98566E+00, & + -0.98601E+00,-0.98636E+00,-0.98671E+00,-0.98706E+00,-0.98741E+00, & + -0.98775E+00,-0.98810E+00,-0.98844E+00,-0.98879E+00,-0.98913E+00, & + -0.98947E+00,-0.98981E+00,-0.99015E+00,-0.99049E+00,-0.99083E+00, & + -0.99117E+00,-0.99151E+00,-0.99185E+00,-0.99218E+00,-0.99252E+00, & + -0.99285E+00,-0.99319E+00,-0.99352E+00,-0.99385E+00,-0.99419E+00, & + -0.99452E+00,-0.99485E+00,-0.99518E+00,-0.99551E+00,-0.99584E+00, & + -0.99616E+00,-0.99649E+00,-0.99682E+00,-0.99714E+00,-0.99747E+00, & + -0.99779E+00,-0.99812E+00,-0.99844E+00,-0.99876E+00,-0.99908E+00, & + -0.99940E+00,-0.99972E+00,-0.10000E+01,-0.10004E+01,-0.10007E+01, & + -0.10010E+01,-0.10013E+01,-0.10016E+01,-0.10019E+01,-0.10023E+01, & + -0.10026E+01,-0.10029E+01,-0.10032E+01,-0.10035E+01,-0.10038E+01/ + + DATA (BNC02M (I),I=501,600)/ & + -0.10041E+01,-0.10044E+01,-0.10048E+01,-0.10051E+01,-0.10054E+01, & + -0.10057E+01,-0.10060E+01,-0.10063E+01,-0.10066E+01,-0.10069E+01, & + -0.10072E+01,-0.10075E+01,-0.10078E+01,-0.10081E+01,-0.10084E+01, & + -0.10087E+01,-0.10090E+01,-0.10093E+01,-0.10096E+01,-0.10099E+01, & + -0.10102E+01,-0.10105E+01,-0.10108E+01,-0.10111E+01,-0.10114E+01, & + -0.10117E+01,-0.10120E+01,-0.10123E+01,-0.10126E+01,-0.10129E+01, & + -0.10132E+01,-0.10135E+01,-0.10138E+01,-0.10141E+01,-0.10144E+01, & + -0.10146E+01,-0.10149E+01,-0.10152E+01,-0.10155E+01,-0.10158E+01, & + -0.10161E+01,-0.10164E+01,-0.10167E+01,-0.10169E+01,-0.10172E+01, & + -0.10175E+01,-0.10178E+01,-0.10181E+01,-0.10184E+01,-0.10187E+01, & + -0.10189E+01,-0.10192E+01,-0.10195E+01,-0.10198E+01,-0.10201E+01, & + -0.10203E+01,-0.10206E+01,-0.10209E+01,-0.10212E+01,-0.10215E+01, & + -0.10217E+01,-0.10220E+01,-0.10223E+01,-0.10226E+01,-0.10228E+01, & + -0.10231E+01,-0.10234E+01,-0.10237E+01,-0.10239E+01,-0.10242E+01, & + -0.10245E+01,-0.10247E+01,-0.10250E+01,-0.10253E+01,-0.10256E+01, & + -0.10258E+01,-0.10261E+01,-0.10264E+01,-0.10266E+01,-0.10269E+01, & + -0.10272E+01,-0.10274E+01,-0.10277E+01,-0.10280E+01,-0.10282E+01, & + -0.10285E+01,-0.10288E+01,-0.10290E+01,-0.10293E+01,-0.10296E+01, & + -0.10298E+01,-0.10301E+01,-0.10303E+01,-0.10306E+01,-0.10309E+01, & + -0.10311E+01,-0.10314E+01,-0.10316E+01,-0.10319E+01,-0.10329E+01/ + + DATA (BNC02M (I),I=601,700)/ & + -0.10350E+01,-0.10375E+01,-0.10400E+01,-0.10424E+01,-0.10448E+01, & + -0.10471E+01,-0.10495E+01,-0.10517E+01,-0.10540E+01,-0.10562E+01, & + -0.10584E+01,-0.10605E+01,-0.10627E+01,-0.10647E+01,-0.10668E+01, & + -0.10688E+01,-0.10708E+01,-0.10728E+01,-0.10748E+01,-0.10767E+01, & + -0.10786E+01,-0.10805E+01,-0.10823E+01,-0.10841E+01,-0.10860E+01, & + -0.10877E+01,-0.10895E+01,-0.10912E+01,-0.10930E+01,-0.10947E+01, & + -0.10963E+01,-0.10980E+01,-0.10996E+01,-0.11013E+01,-0.11029E+01, & + -0.11044E+01,-0.11060E+01,-0.11076E+01,-0.11091E+01,-0.11106E+01, & + -0.11121E+01,-0.11136E+01,-0.11151E+01,-0.11165E+01,-0.11180E+01, & + -0.11194E+01,-0.11208E+01,-0.11222E+01,-0.11236E+01,-0.11250E+01, & + -0.11263E+01,-0.11277E+01,-0.11290E+01,-0.11303E+01,-0.11316E+01, & + -0.11329E+01,-0.11342E+01,-0.11355E+01,-0.11368E+01,-0.11380E+01, & + -0.11392E+01,-0.11405E+01,-0.11417E+01,-0.11429E+01,-0.11441E+01, & + -0.11453E+01,-0.11464E+01,-0.11476E+01,-0.11488E+01,-0.11499E+01, & + -0.11510E+01,-0.11522E+01,-0.11533E+01,-0.11544E+01,-0.11555E+01, & + -0.11566E+01,-0.11577E+01,-0.11587E+01,-0.11598E+01,-0.11609E+01, & + -0.11619E+01,-0.11630E+01,-0.11640E+01,-0.11650E+01,-0.11660E+01, & + -0.11670E+01,-0.11680E+01,-0.11690E+01,-0.11700E+01,-0.11710E+01, & + -0.11720E+01,-0.11729E+01,-0.11739E+01,-0.11749E+01,-0.11758E+01, & + -0.11767E+01,-0.11777E+01,-0.11786E+01,-0.11795E+01,-0.11804E+01/ + + DATA (BNC02M(I),I=701,741)/ & + -0.11813E+01,-0.11822E+01,-0.11831E+01,-0.11840E+01,-0.11849E+01, & + -0.11858E+01,-0.11867E+01,-0.11875E+01,-0.11884E+01,-0.11893E+01, & + -0.11901E+01,-0.11909E+01,-0.11918E+01,-0.11926E+01,-0.11934E+01, & + -0.11943E+01,-0.11951E+01,-0.11959E+01,-0.11967E+01,-0.11975E+01, & + -0.11983E+01,-0.11991E+01,-0.11999E+01,-0.12007E+01,-0.12015E+01, & + -0.12022E+01,-0.12030E+01,-0.12038E+01,-0.12045E+01,-0.12053E+01, & + -0.12060E+01,-0.12068E+01,-0.12075E+01,-0.12083E+01,-0.12090E+01, & + -0.12097E+01,-0.12105E+01,-0.12112E+01,-0.12119E+01,-0.12126E+01, & + -0.12133E+01 & + / +! +! *** NaNO3 +! + DATA (BNC03M (I),I= 1,100)/ & + -0.51631E-01,-0.94349E-01,-0.12464E+00,-0.14539E+00,-0.16147E+00, & + -0.17470E+00,-0.18599E+00,-0.19586E+00,-0.20466E+00,-0.21259E+00, & + -0.21982E+00,-0.22648E+00,-0.23265E+00,-0.23839E+00,-0.24378E+00, & + -0.24884E+00,-0.25363E+00,-0.25817E+00,-0.26248E+00,-0.26659E+00, & + -0.27052E+00,-0.27428E+00,-0.27789E+00,-0.28136E+00,-0.28470E+00, & + -0.28792E+00,-0.29103E+00,-0.29403E+00,-0.29694E+00,-0.29976E+00, & + -0.30249E+00,-0.30515E+00,-0.30772E+00,-0.31023E+00,-0.31267E+00, & + -0.31505E+00,-0.31736E+00,-0.31962E+00,-0.32182E+00,-0.32397E+00, & + -0.32607E+00,-0.32812E+00,-0.33013E+00,-0.33209E+00,-0.33401E+00, & + -0.33590E+00,-0.33774E+00,-0.33954E+00,-0.34131E+00,-0.34305E+00, & + -0.34475E+00,-0.34642E+00,-0.34806E+00,-0.34967E+00,-0.35125E+00, & + -0.35281E+00,-0.35434E+00,-0.35584E+00,-0.35732E+00,-0.35877E+00, & + -0.36021E+00,-0.36162E+00,-0.36300E+00,-0.36437E+00,-0.36572E+00, & + -0.36705E+00,-0.36836E+00,-0.36965E+00,-0.37093E+00,-0.37219E+00, & + -0.37343E+00,-0.37466E+00,-0.37588E+00,-0.37707E+00,-0.37826E+00, & + -0.37943E+00,-0.38059E+00,-0.38174E+00,-0.38287E+00,-0.38400E+00, & + -0.38511E+00,-0.38621E+00,-0.38730E+00,-0.38838E+00,-0.38945E+00, & + -0.39051E+00,-0.39157E+00,-0.39261E+00,-0.39364E+00,-0.39467E+00, & + -0.39569E+00,-0.39670E+00,-0.39770E+00,-0.39869E+00,-0.39968E+00, & + -0.40066E+00,-0.40163E+00,-0.40260E+00,-0.40356E+00,-0.40451E+00/ + + DATA (BNC03M (I),I=101,200)/ & + -0.40545E+00,-0.40639E+00,-0.40733E+00,-0.40825E+00,-0.40917E+00, & + -0.41009E+00,-0.41099E+00,-0.41190E+00,-0.41279E+00,-0.41368E+00, & + -0.41457E+00,-0.41544E+00,-0.41632E+00,-0.41718E+00,-0.41804E+00, & + -0.41890E+00,-0.41975E+00,-0.42060E+00,-0.42143E+00,-0.42227E+00, & + -0.42306E+00,-0.42389E+00,-0.42471E+00,-0.42553E+00,-0.42634E+00, & + -0.42714E+00,-0.42794E+00,-0.42874E+00,-0.42953E+00,-0.43031E+00, & + -0.43109E+00,-0.43187E+00,-0.43264E+00,-0.43340E+00,-0.43416E+00, & + -0.43492E+00,-0.43567E+00,-0.43641E+00,-0.43715E+00,-0.43789E+00, & + -0.43862E+00,-0.43935E+00,-0.44007E+00,-0.44079E+00,-0.44151E+00, & + -0.44222E+00,-0.44293E+00,-0.44363E+00,-0.44433E+00,-0.44503E+00, & + -0.44572E+00,-0.44640E+00,-0.44709E+00,-0.44777E+00,-0.44844E+00, & + -0.44912E+00,-0.44978E+00,-0.45045E+00,-0.45111E+00,-0.45177E+00, & + -0.45242E+00,-0.45307E+00,-0.45372E+00,-0.45437E+00,-0.45501E+00, & + -0.45565E+00,-0.45628E+00,-0.45691E+00,-0.45754E+00,-0.45816E+00, & + -0.45879E+00,-0.45940E+00,-0.46002E+00,-0.46063E+00,-0.46124E+00, & + -0.46185E+00,-0.46245E+00,-0.46305E+00,-0.46365E+00,-0.46425E+00, & + -0.46484E+00,-0.46543E+00,-0.46601E+00,-0.46660E+00,-0.46718E+00, & + -0.46776E+00,-0.46833E+00,-0.46891E+00,-0.46948E+00,-0.47005E+00, & + -0.47061E+00,-0.47117E+00,-0.47173E+00,-0.47229E+00,-0.47285E+00, & + -0.47340E+00,-0.47395E+00,-0.47450E+00,-0.47505E+00,-0.47559E+00/ + + DATA (BNC03M (I),I=201,300)/ & + -0.47613E+00,-0.47667E+00,-0.47721E+00,-0.47774E+00,-0.47827E+00, & + -0.47880E+00,-0.47933E+00,-0.47985E+00,-0.48038E+00,-0.48090E+00, & + -0.48142E+00,-0.48193E+00,-0.48245E+00,-0.48296E+00,-0.48347E+00, & + -0.48398E+00,-0.48449E+00,-0.48499E+00,-0.48549E+00,-0.48599E+00, & + -0.48649E+00,-0.48699E+00,-0.48748E+00,-0.48797E+00,-0.48847E+00, & + -0.48895E+00,-0.48944E+00,-0.48993E+00,-0.49041E+00,-0.49089E+00, & + -0.49137E+00,-0.49185E+00,-0.49232E+00,-0.49280E+00,-0.49327E+00, & + -0.49374E+00,-0.49421E+00,-0.49468E+00,-0.49514E+00,-0.49560E+00, & + -0.49607E+00,-0.49653E+00,-0.49699E+00,-0.49744E+00,-0.49790E+00, & + -0.49835E+00,-0.49880E+00,-0.49925E+00,-0.49970E+00,-0.50015E+00, & + -0.50060E+00,-0.50104E+00,-0.50148E+00,-0.50192E+00,-0.50236E+00, & + -0.50280E+00,-0.50324E+00,-0.50367E+00,-0.50411E+00,-0.50454E+00, & + -0.50497E+00,-0.50540E+00,-0.50582E+00,-0.50625E+00,-0.50668E+00, & + -0.50710E+00,-0.50752E+00,-0.50794E+00,-0.50836E+00,-0.50878E+00, & + -0.50919E+00,-0.50961E+00,-0.51002E+00,-0.51043E+00,-0.51085E+00, & + -0.51126E+00,-0.51166E+00,-0.51207E+00,-0.51248E+00,-0.51288E+00, & + -0.51328E+00,-0.51369E+00,-0.51409E+00,-0.51449E+00,-0.51488E+00, & + -0.51528E+00,-0.51568E+00,-0.51607E+00,-0.51646E+00,-0.51686E+00, & + -0.51725E+00,-0.51764E+00,-0.51802E+00,-0.51841E+00,-0.51880E+00, & + -0.51918E+00,-0.51956E+00,-0.51995E+00,-0.52033E+00,-0.52071E+00/ + + DATA (BNC03M (I),I=301,400)/ & + -0.52109E+00,-0.52146E+00,-0.52184E+00,-0.52222E+00,-0.52259E+00, & + -0.52296E+00,-0.52334E+00,-0.52371E+00,-0.52408E+00,-0.52445E+00, & + -0.52482E+00,-0.52518E+00,-0.52555E+00,-0.52591E+00,-0.52628E+00, & + -0.52664E+00,-0.52700E+00,-0.52736E+00,-0.52772E+00,-0.52808E+00, & + -0.52844E+00,-0.52879E+00,-0.52915E+00,-0.52950E+00,-0.52986E+00, & + -0.53021E+00,-0.53056E+00,-0.53091E+00,-0.53126E+00,-0.53161E+00, & + -0.53196E+00,-0.53230E+00,-0.53265E+00,-0.53299E+00,-0.53334E+00, & + -0.53368E+00,-0.53402E+00,-0.53436E+00,-0.53470E+00,-0.53504E+00, & + -0.53538E+00,-0.53572E+00,-0.53605E+00,-0.53639E+00,-0.53672E+00, & + -0.53706E+00,-0.53739E+00,-0.53772E+00,-0.53805E+00,-0.53838E+00, & + -0.53871E+00,-0.53904E+00,-0.53937E+00,-0.53970E+00,-0.54002E+00, & + -0.54035E+00,-0.54067E+00,-0.54100E+00,-0.54132E+00,-0.54164E+00, & + -0.54196E+00,-0.54228E+00,-0.54260E+00,-0.54292E+00,-0.54324E+00, & + -0.54355E+00,-0.54387E+00,-0.54419E+00,-0.54450E+00,-0.54481E+00, & + -0.54513E+00,-0.54544E+00,-0.54575E+00,-0.54606E+00,-0.54637E+00, & + -0.54668E+00,-0.54699E+00,-0.54730E+00,-0.54760E+00,-0.54791E+00, & + -0.54821E+00,-0.54852E+00,-0.54882E+00,-0.54913E+00,-0.54943E+00, & + -0.54973E+00,-0.55003E+00,-0.55033E+00,-0.55063E+00,-0.55093E+00, & + -0.55123E+00,-0.55152E+00,-0.55182E+00,-0.55212E+00,-0.55241E+00, & + -0.55271E+00,-0.55300E+00,-0.55329E+00,-0.55359E+00,-0.55388E+00/ + + DATA (BNC03M (I),I=401,500)/ & + -0.55417E+00,-0.55446E+00,-0.55475E+00,-0.55504E+00,-0.55533E+00, & + -0.55561E+00,-0.55590E+00,-0.55619E+00,-0.55647E+00,-0.55676E+00, & + -0.55704E+00,-0.55733E+00,-0.55761E+00,-0.55789E+00,-0.55817E+00, & + -0.55845E+00,-0.55874E+00,-0.55902E+00,-0.55929E+00,-0.55957E+00, & + -0.55985E+00,-0.56013E+00,-0.56041E+00,-0.56068E+00,-0.56096E+00, & + -0.56123E+00,-0.56151E+00,-0.56178E+00,-0.56205E+00,-0.56233E+00, & + -0.56260E+00,-0.56287E+00,-0.56314E+00,-0.56341E+00,-0.56368E+00, & + -0.56395E+00,-0.56422E+00,-0.56449E+00,-0.56475E+00,-0.56502E+00, & + -0.56529E+00,-0.56555E+00,-0.56582E+00,-0.56608E+00,-0.56634E+00, & + -0.56661E+00,-0.56687E+00,-0.56713E+00,-0.56739E+00,-0.56766E+00, & + -0.56792E+00,-0.56818E+00,-0.56843E+00,-0.56869E+00,-0.56895E+00, & + -0.56921E+00,-0.56947E+00,-0.56972E+00,-0.56998E+00,-0.57024E+00, & + -0.57049E+00,-0.57075E+00,-0.57100E+00,-0.57125E+00,-0.57151E+00, & + -0.57176E+00,-0.57201E+00,-0.57226E+00,-0.57251E+00,-0.57276E+00, & + -0.57301E+00,-0.57326E+00,-0.57351E+00,-0.57376E+00,-0.57401E+00, & + -0.57425E+00,-0.57450E+00,-0.57475E+00,-0.57499E+00,-0.57524E+00, & + -0.57548E+00,-0.57573E+00,-0.57597E+00,-0.57622E+00,-0.57646E+00, & + -0.57670E+00,-0.57694E+00,-0.57719E+00,-0.57743E+00,-0.57767E+00, & + -0.57791E+00,-0.57815E+00,-0.57839E+00,-0.57862E+00,-0.57886E+00, & + -0.57910E+00,-0.57934E+00,-0.57958E+00,-0.57981E+00,-0.58005E+00/ + + DATA (BNC03M (I),I=501,600)/ & + -0.58028E+00,-0.58052E+00,-0.58075E+00,-0.58099E+00,-0.58122E+00, & + -0.58145E+00,-0.58169E+00,-0.58192E+00,-0.58215E+00,-0.58238E+00, & + -0.58261E+00,-0.58284E+00,-0.58307E+00,-0.58330E+00,-0.58353E+00, & + -0.58376E+00,-0.58399E+00,-0.58422E+00,-0.58445E+00,-0.58467E+00, & + -0.58490E+00,-0.58513E+00,-0.58535E+00,-0.58558E+00,-0.58580E+00, & + -0.58603E+00,-0.58625E+00,-0.58648E+00,-0.58670E+00,-0.58692E+00, & + -0.58714E+00,-0.58737E+00,-0.58759E+00,-0.58781E+00,-0.58803E+00, & + -0.58825E+00,-0.58847E+00,-0.58869E+00,-0.58891E+00,-0.58913E+00, & + -0.58935E+00,-0.58957E+00,-0.58978E+00,-0.59000E+00,-0.59022E+00, & + -0.59044E+00,-0.59065E+00,-0.59087E+00,-0.59108E+00,-0.59130E+00, & + -0.59151E+00,-0.59173E+00,-0.59194E+00,-0.59215E+00,-0.59237E+00, & + -0.59258E+00,-0.59279E+00,-0.59300E+00,-0.59322E+00,-0.59343E+00, & + -0.59364E+00,-0.59385E+00,-0.59406E+00,-0.59427E+00,-0.59448E+00, & + -0.59469E+00,-0.59490E+00,-0.59511E+00,-0.59531E+00,-0.59552E+00, & + -0.59573E+00,-0.59594E+00,-0.59614E+00,-0.59635E+00,-0.59655E+00, & + -0.59676E+00,-0.59696E+00,-0.59717E+00,-0.59737E+00,-0.59758E+00, & + -0.59778E+00,-0.59799E+00,-0.59819E+00,-0.59839E+00,-0.59859E+00, & + -0.59880E+00,-0.59900E+00,-0.59920E+00,-0.59940E+00,-0.59960E+00, & + -0.59980E+00,-0.60000E+00,-0.60020E+00,-0.60040E+00,-0.60060E+00, & + -0.60080E+00,-0.60100E+00,-0.60119E+00,-0.60139E+00,-0.60213E+00/ + + DATA (BNC03M (I),I=601,700)/ & + -0.60374E+00,-0.60566E+00,-0.60755E+00,-0.60942E+00,-0.61125E+00, & + -0.61305E+00,-0.61483E+00,-0.61658E+00,-0.61831E+00,-0.62001E+00, & + -0.62169E+00,-0.62334E+00,-0.62497E+00,-0.62658E+00,-0.62816E+00, & + -0.62973E+00,-0.63127E+00,-0.63279E+00,-0.63429E+00,-0.63578E+00, & + -0.63724E+00,-0.63869E+00,-0.64012E+00,-0.64153E+00,-0.64292E+00, & + -0.64430E+00,-0.64566E+00,-0.64700E+00,-0.64833E+00,-0.64964E+00, & + -0.65094E+00,-0.65222E+00,-0.65349E+00,-0.65475E+00,-0.65599E+00, & + -0.65721E+00,-0.65843E+00,-0.65963E+00,-0.66082E+00,-0.66199E+00, & + -0.66315E+00,-0.66431E+00,-0.66544E+00,-0.66657E+00,-0.66769E+00, & + -0.66879E+00,-0.66989E+00,-0.67097E+00,-0.67204E+00,-0.67310E+00, & + -0.67415E+00,-0.67520E+00,-0.67623E+00,-0.67725E+00,-0.67826E+00, & + -0.67927E+00,-0.68026E+00,-0.68124E+00,-0.68222E+00,-0.68319E+00, & + -0.68415E+00,-0.68510E+00,-0.68604E+00,-0.68697E+00,-0.68790E+00, & + -0.68881E+00,-0.68972E+00,-0.69062E+00,-0.69152E+00,-0.69241E+00, & + -0.69329E+00,-0.69416E+00,-0.69502E+00,-0.69588E+00,-0.69673E+00, & + -0.69758E+00,-0.69841E+00,-0.69924E+00,-0.70007E+00,-0.70089E+00, & + -0.70170E+00,-0.70250E+00,-0.70330E+00,-0.70410E+00,-0.70488E+00, & + -0.70566E+00,-0.70644E+00,-0.70721E+00,-0.70797E+00,-0.70873E+00, & + -0.70948E+00,-0.71023E+00,-0.71097E+00,-0.71171E+00,-0.71244E+00, & + -0.71317E+00,-0.71389E+00,-0.71460E+00,-0.71531E+00,-0.71602E+00/ + + DATA (BNC03M(I),I=701,741)/ & + -0.71672E+00,-0.71742E+00,-0.71811E+00,-0.71880E+00,-0.71948E+00, & + -0.72016E+00,-0.72083E+00,-0.72150E+00,-0.72216E+00,-0.72282E+00, & + -0.72348E+00,-0.72413E+00,-0.72478E+00,-0.72542E+00,-0.72606E+00, & + -0.72670E+00,-0.72733E+00,-0.72795E+00,-0.72858E+00,-0.72920E+00, & + -0.72981E+00,-0.73042E+00,-0.73103E+00,-0.73163E+00,-0.73223E+00, & + -0.73283E+00,-0.73342E+00,-0.73401E+00,-0.73460E+00,-0.73518E+00, & + -0.73576E+00,-0.73634E+00,-0.73691E+00,-0.73748E+00,-0.73805E+00, & + -0.73861E+00,-0.73917E+00,-0.73972E+00,-0.74028E+00,-0.74083E+00, & + -0.74137E+00 & + / +! +! *** (NH4)2SO4 +! + DATA (BNC04M (I),I= 1,100)/ & + -0.10306E+00,-0.18795E+00,-0.24786E+00,-0.28872E+00,-0.32027E+00, & + -0.34614E+00,-0.36814E+00,-0.38733E+00,-0.40435E+00,-0.41967E+00, & + -0.43360E+00,-0.44638E+00,-0.45819E+00,-0.46917E+00,-0.47943E+00, & + -0.48906E+00,-0.49813E+00,-0.50671E+00,-0.51485E+00,-0.52259E+00, & + -0.52997E+00,-0.53702E+00,-0.54377E+00,-0.55025E+00,-0.55647E+00, & + -0.56246E+00,-0.56823E+00,-0.57380E+00,-0.57918E+00,-0.58438E+00, & + -0.58942E+00,-0.59430E+00,-0.59904E+00,-0.60363E+00,-0.60810E+00, & + -0.61245E+00,-0.61668E+00,-0.62079E+00,-0.62480E+00,-0.62872E+00, & + -0.63253E+00,-0.63626E+00,-0.63989E+00,-0.64345E+00,-0.64692E+00, & + -0.65032E+00,-0.65365E+00,-0.65690E+00,-0.66009E+00,-0.66321E+00, & + -0.66627E+00,-0.66927E+00,-0.67221E+00,-0.67510E+00,-0.67793E+00, & + -0.68071E+00,-0.68344E+00,-0.68613E+00,-0.68876E+00,-0.69136E+00, & + -0.69391E+00,-0.69641E+00,-0.69888E+00,-0.70131E+00,-0.70370E+00, & + -0.70606E+00,-0.70838E+00,-0.71067E+00,-0.71292E+00,-0.71514E+00, & + -0.71734E+00,-0.71950E+00,-0.72164E+00,-0.72374E+00,-0.72582E+00, & + -0.72788E+00,-0.72991E+00,-0.73191E+00,-0.73390E+00,-0.73586E+00, & + -0.73780E+00,-0.73971E+00,-0.74161E+00,-0.74349E+00,-0.74534E+00, & + -0.74718E+00,-0.74900E+00,-0.75080E+00,-0.75259E+00,-0.75436E+00, & + -0.75611E+00,-0.75784E+00,-0.75956E+00,-0.76127E+00,-0.76296E+00, & + -0.76463E+00,-0.76629E+00,-0.76794E+00,-0.76957E+00,-0.77119E+00/ + + DATA (BNC04M (I),I=101,200)/ & + -0.77280E+00,-0.77439E+00,-0.77597E+00,-0.77754E+00,-0.77910E+00, & + -0.78064E+00,-0.78218E+00,-0.78370E+00,-0.78520E+00,-0.78670E+00, & + -0.78819E+00,-0.78966E+00,-0.79113E+00,-0.79258E+00,-0.79402E+00, & + -0.79545E+00,-0.79687E+00,-0.79828E+00,-0.79968E+00,-0.80107E+00, & + -0.80241E+00,-0.80378E+00,-0.80515E+00,-0.80650E+00,-0.80785E+00, & + -0.80918E+00,-0.81051E+00,-0.81183E+00,-0.81313E+00,-0.81443E+00, & + -0.81572E+00,-0.81700E+00,-0.81827E+00,-0.81953E+00,-0.82078E+00, & + -0.82203E+00,-0.82327E+00,-0.82449E+00,-0.82571E+00,-0.82692E+00, & + -0.82813E+00,-0.82932E+00,-0.83051E+00,-0.83169E+00,-0.83287E+00, & + -0.83403E+00,-0.83519E+00,-0.83634E+00,-0.83748E+00,-0.83862E+00, & + -0.83975E+00,-0.84087E+00,-0.84199E+00,-0.84310E+00,-0.84420E+00, & + -0.84530E+00,-0.84639E+00,-0.84747E+00,-0.84855E+00,-0.84962E+00, & + -0.85068E+00,-0.85174E+00,-0.85280E+00,-0.85384E+00,-0.85488E+00, & + -0.85592E+00,-0.85695E+00,-0.85797E+00,-0.85899E+00,-0.86000E+00, & + -0.86101E+00,-0.86201E+00,-0.86301E+00,-0.86400E+00,-0.86498E+00, & + -0.86596E+00,-0.86694E+00,-0.86791E+00,-0.86887E+00,-0.86983E+00, & + -0.87079E+00,-0.87174E+00,-0.87268E+00,-0.87362E+00,-0.87456E+00, & + -0.87549E+00,-0.87642E+00,-0.87734E+00,-0.87826E+00,-0.87917E+00, & + -0.88008E+00,-0.88098E+00,-0.88188E+00,-0.88278E+00,-0.88367E+00, & + -0.88456E+00,-0.88544E+00,-0.88632E+00,-0.88719E+00,-0.88806E+00/ + + DATA (BNC04M (I),I=201,300)/ & + -0.88893E+00,-0.88979E+00,-0.89065E+00,-0.89151E+00,-0.89236E+00, & + -0.89320E+00,-0.89405E+00,-0.89489E+00,-0.89572E+00,-0.89655E+00, & + -0.89738E+00,-0.89821E+00,-0.89903E+00,-0.89984E+00,-0.90066E+00, & + -0.90147E+00,-0.90227E+00,-0.90308E+00,-0.90388E+00,-0.90467E+00, & + -0.90547E+00,-0.90626E+00,-0.90704E+00,-0.90783E+00,-0.90861E+00, & + -0.90938E+00,-0.91016E+00,-0.91093E+00,-0.91169E+00,-0.91246E+00, & + -0.91322E+00,-0.91398E+00,-0.91473E+00,-0.91548E+00,-0.91623E+00, & + -0.91698E+00,-0.91772E+00,-0.91846E+00,-0.91920E+00,-0.91993E+00, & + -0.92066E+00,-0.92139E+00,-0.92211E+00,-0.92284E+00,-0.92356E+00, & + -0.92427E+00,-0.92499E+00,-0.92570E+00,-0.92641E+00,-0.92712E+00, & + -0.92782E+00,-0.92852E+00,-0.92922E+00,-0.92991E+00,-0.93061E+00, & + -0.93130E+00,-0.93199E+00,-0.93267E+00,-0.93336E+00,-0.93404E+00, & + -0.93471E+00,-0.93539E+00,-0.93606E+00,-0.93674E+00,-0.93740E+00, & + -0.93807E+00,-0.93873E+00,-0.93940E+00,-0.94005E+00,-0.94071E+00, & + -0.94137E+00,-0.94202E+00,-0.94267E+00,-0.94332E+00,-0.94396E+00, & + -0.94460E+00,-0.94525E+00,-0.94589E+00,-0.94652E+00,-0.94716E+00, & + -0.94779E+00,-0.94842E+00,-0.94905E+00,-0.94967E+00,-0.95030E+00, & + -0.95092E+00,-0.95154E+00,-0.95216E+00,-0.95277E+00,-0.95339E+00, & + -0.95400E+00,-0.95461E+00,-0.95522E+00,-0.95582E+00,-0.95643E+00, & + -0.95703E+00,-0.95763E+00,-0.95823E+00,-0.95882E+00,-0.95942E+00/ + + DATA (BNC04M (I),I=301,400)/ & + -0.96001E+00,-0.96060E+00,-0.96119E+00,-0.96178E+00,-0.96236E+00, & + -0.96294E+00,-0.96353E+00,-0.96411E+00,-0.96468E+00,-0.96526E+00, & + -0.96583E+00,-0.96641E+00,-0.96698E+00,-0.96755E+00,-0.96811E+00, & + -0.96868E+00,-0.96924E+00,-0.96981E+00,-0.97037E+00,-0.97092E+00, & + -0.97148E+00,-0.97204E+00,-0.97259E+00,-0.97314E+00,-0.97369E+00, & + -0.97424E+00,-0.97479E+00,-0.97534E+00,-0.97588E+00,-0.97642E+00, & + -0.97696E+00,-0.97750E+00,-0.97804E+00,-0.97858E+00,-0.97911E+00, & + -0.97965E+00,-0.98018E+00,-0.98071E+00,-0.98124E+00,-0.98176E+00, & + -0.98229E+00,-0.98281E+00,-0.98334E+00,-0.98386E+00,-0.98438E+00, & + -0.98490E+00,-0.98541E+00,-0.98593E+00,-0.98644E+00,-0.98696E+00, & + -0.98747E+00,-0.98798E+00,-0.98849E+00,-0.98899E+00,-0.98950E+00, & + -0.99000E+00,-0.99051E+00,-0.99101E+00,-0.99151E+00,-0.99201E+00, & + -0.99251E+00,-0.99300E+00,-0.99350E+00,-0.99399E+00,-0.99448E+00, & + -0.99497E+00,-0.99546E+00,-0.99595E+00,-0.99644E+00,-0.99693E+00, & + -0.99741E+00,-0.99789E+00,-0.99838E+00,-0.99886E+00,-0.99934E+00, & + -0.99982E+00,-0.10003E+01,-0.10008E+01,-0.10012E+01,-0.10017E+01, & + -0.10022E+01,-0.10027E+01,-0.10031E+01,-0.10036E+01,-0.10041E+01, & + -0.10045E+01,-0.10050E+01,-0.10055E+01,-0.10059E+01,-0.10064E+01, & + -0.10068E+01,-0.10073E+01,-0.10078E+01,-0.10082E+01,-0.10087E+01, & + -0.10091E+01,-0.10096E+01,-0.10100E+01,-0.10105E+01,-0.10109E+01/ + + DATA (BNC04M (I),I=401,500)/ & + -0.10114E+01,-0.10118E+01,-0.10123E+01,-0.10127E+01,-0.10132E+01, & + -0.10136E+01,-0.10141E+01,-0.10145E+01,-0.10149E+01,-0.10154E+01, & + -0.10158E+01,-0.10163E+01,-0.10167E+01,-0.10171E+01,-0.10176E+01, & + -0.10180E+01,-0.10184E+01,-0.10189E+01,-0.10193E+01,-0.10197E+01, & + -0.10202E+01,-0.10206E+01,-0.10210E+01,-0.10214E+01,-0.10219E+01, & + -0.10223E+01,-0.10227E+01,-0.10231E+01,-0.10236E+01,-0.10240E+01, & + -0.10244E+01,-0.10248E+01,-0.10252E+01,-0.10256E+01,-0.10261E+01, & + -0.10265E+01,-0.10269E+01,-0.10273E+01,-0.10277E+01,-0.10281E+01, & + -0.10285E+01,-0.10289E+01,-0.10293E+01,-0.10298E+01,-0.10302E+01, & + -0.10306E+01,-0.10310E+01,-0.10314E+01,-0.10318E+01,-0.10322E+01, & + -0.10326E+01,-0.10330E+01,-0.10334E+01,-0.10338E+01,-0.10342E+01, & + -0.10346E+01,-0.10350E+01,-0.10354E+01,-0.10357E+01,-0.10361E+01, & + -0.10365E+01,-0.10369E+01,-0.10373E+01,-0.10377E+01,-0.10381E+01, & + -0.10385E+01,-0.10389E+01,-0.10393E+01,-0.10396E+01,-0.10400E+01, & + -0.10404E+01,-0.10408E+01,-0.10412E+01,-0.10416E+01,-0.10419E+01, & + -0.10423E+01,-0.10427E+01,-0.10431E+01,-0.10435E+01,-0.10438E+01, & + -0.10442E+01,-0.10446E+01,-0.10450E+01,-0.10453E+01,-0.10457E+01, & + -0.10461E+01,-0.10464E+01,-0.10468E+01,-0.10472E+01,-0.10476E+01, & + -0.10479E+01,-0.10483E+01,-0.10487E+01,-0.10490E+01,-0.10494E+01, & + -0.10498E+01,-0.10501E+01,-0.10505E+01,-0.10508E+01,-0.10512E+01/ + + DATA (BNC04M (I),I=501,600)/ & + -0.10516E+01,-0.10519E+01,-0.10523E+01,-0.10526E+01,-0.10530E+01, & + -0.10534E+01,-0.10537E+01,-0.10541E+01,-0.10544E+01,-0.10548E+01, & + -0.10551E+01,-0.10555E+01,-0.10558E+01,-0.10562E+01,-0.10565E+01, & + -0.10569E+01,-0.10572E+01,-0.10576E+01,-0.10579E+01,-0.10583E+01, & + -0.10586E+01,-0.10590E+01,-0.10593E+01,-0.10597E+01,-0.10600E+01, & + -0.10604E+01,-0.10607E+01,-0.10611E+01,-0.10614E+01,-0.10617E+01, & + -0.10621E+01,-0.10624E+01,-0.10628E+01,-0.10631E+01,-0.10634E+01, & + -0.10638E+01,-0.10641E+01,-0.10644E+01,-0.10648E+01,-0.10651E+01, & + -0.10655E+01,-0.10658E+01,-0.10661E+01,-0.10665E+01,-0.10668E+01, & + -0.10671E+01,-0.10674E+01,-0.10678E+01,-0.10681E+01,-0.10684E+01, & + -0.10688E+01,-0.10691E+01,-0.10694E+01,-0.10697E+01,-0.10701E+01, & + -0.10704E+01,-0.10707E+01,-0.10710E+01,-0.10714E+01,-0.10717E+01, & + -0.10720E+01,-0.10723E+01,-0.10727E+01,-0.10730E+01,-0.10733E+01, & + -0.10736E+01,-0.10739E+01,-0.10743E+01,-0.10746E+01,-0.10749E+01, & + -0.10752E+01,-0.10755E+01,-0.10758E+01,-0.10762E+01,-0.10765E+01, & + -0.10768E+01,-0.10771E+01,-0.10774E+01,-0.10777E+01,-0.10780E+01, & + -0.10783E+01,-0.10787E+01,-0.10790E+01,-0.10793E+01,-0.10796E+01, & + -0.10799E+01,-0.10802E+01,-0.10805E+01,-0.10808E+01,-0.10811E+01, & + -0.10814E+01,-0.10817E+01,-0.10820E+01,-0.10823E+01,-0.10827E+01, & + -0.10830E+01,-0.10833E+01,-0.10836E+01,-0.10839E+01,-0.10850E+01/ + + DATA (BNC04M (I),I=601,700)/ & + -0.10874E+01,-0.10904E+01,-0.10933E+01,-0.10961E+01,-0.10989E+01, & + -0.11017E+01,-0.11044E+01,-0.11070E+01,-0.11097E+01,-0.11123E+01, & + -0.11148E+01,-0.11173E+01,-0.11198E+01,-0.11223E+01,-0.11247E+01, & + -0.11271E+01,-0.11294E+01,-0.11317E+01,-0.11340E+01,-0.11363E+01, & + -0.11385E+01,-0.11407E+01,-0.11429E+01,-0.11450E+01,-0.11471E+01, & + -0.11492E+01,-0.11513E+01,-0.11534E+01,-0.11554E+01,-0.11574E+01, & + -0.11593E+01,-0.11613E+01,-0.11632E+01,-0.11651E+01,-0.11670E+01, & + -0.11689E+01,-0.11707E+01,-0.11726E+01,-0.11744E+01,-0.11762E+01, & + -0.11779E+01,-0.11797E+01,-0.11814E+01,-0.11831E+01,-0.11848E+01, & + -0.11865E+01,-0.11882E+01,-0.11898E+01,-0.11915E+01,-0.11931E+01, & + -0.11947E+01,-0.11963E+01,-0.11978E+01,-0.11994E+01,-0.12009E+01, & + -0.12025E+01,-0.12040E+01,-0.12055E+01,-0.12070E+01,-0.12084E+01, & + -0.12099E+01,-0.12114E+01,-0.12128E+01,-0.12142E+01,-0.12156E+01, & + -0.12170E+01,-0.12184E+01,-0.12198E+01,-0.12212E+01,-0.12225E+01, & + -0.12238E+01,-0.12252E+01,-0.12265E+01,-0.12278E+01,-0.12291E+01, & + -0.12304E+01,-0.12317E+01,-0.12329E+01,-0.12342E+01,-0.12355E+01, & + -0.12367E+01,-0.12379E+01,-0.12391E+01,-0.12404E+01,-0.12416E+01, & + -0.12428E+01,-0.12439E+01,-0.12451E+01,-0.12463E+01,-0.12474E+01, & + -0.12486E+01,-0.12497E+01,-0.12509E+01,-0.12520E+01,-0.12531E+01, & + -0.12542E+01,-0.12553E+01,-0.12564E+01,-0.12575E+01,-0.12586E+01/ + + DATA (BNC04M(I),I=701,741)/ & + -0.12597E+01,-0.12607E+01,-0.12618E+01,-0.12629E+01,-0.12639E+01, & + -0.12649E+01,-0.12660E+01,-0.12670E+01,-0.12680E+01,-0.12690E+01, & + -0.12700E+01,-0.12710E+01,-0.12720E+01,-0.12730E+01,-0.12740E+01, & + -0.12750E+01,-0.12760E+01,-0.12769E+01,-0.12779E+01,-0.12788E+01, & + -0.12798E+01,-0.12807E+01,-0.12816E+01,-0.12826E+01,-0.12835E+01, & + -0.12844E+01,-0.12853E+01,-0.12862E+01,-0.12871E+01,-0.12880E+01, & + -0.12889E+01,-0.12898E+01,-0.12907E+01,-0.12916E+01,-0.12924E+01, & + -0.12933E+01,-0.12942E+01,-0.12950E+01,-0.12959E+01,-0.12967E+01, & + -0.12976E+01 & + / +! +! *** NH4NO3 +! + DATA (BNC05M (I),I= 1,100)/ & + -0.52199E-01,-0.96472E-01,-0.12869E+00,-0.15126E+00,-0.16910E+00, & + -0.18404E+00,-0.19701E+00,-0.20852E+00,-0.21891E+00,-0.22842E+00, & + -0.23721E+00,-0.24540E+00,-0.25307E+00,-0.26031E+00,-0.26716E+00, & + -0.27368E+00,-0.27990E+00,-0.28586E+00,-0.29157E+00,-0.29707E+00, & + -0.30237E+00,-0.30748E+00,-0.31243E+00,-0.31723E+00,-0.32188E+00, & + -0.32639E+00,-0.33078E+00,-0.33506E+00,-0.33922E+00,-0.34328E+00, & + -0.34724E+00,-0.35110E+00,-0.35488E+00,-0.35857E+00,-0.36218E+00, & + -0.36571E+00,-0.36917E+00,-0.37256E+00,-0.37588E+00,-0.37914E+00, & + -0.38233E+00,-0.38547E+00,-0.38854E+00,-0.39156E+00,-0.39452E+00, & + -0.39743E+00,-0.40030E+00,-0.40311E+00,-0.40587E+00,-0.40860E+00, & + -0.41127E+00,-0.41391E+00,-0.41650E+00,-0.41905E+00,-0.42157E+00, & + -0.42404E+00,-0.42649E+00,-0.42890E+00,-0.43127E+00,-0.43361E+00, & + -0.43593E+00,-0.43821E+00,-0.44046E+00,-0.44269E+00,-0.44489E+00, & + -0.44707E+00,-0.44922E+00,-0.45135E+00,-0.45345E+00,-0.45554E+00, & + -0.45760E+00,-0.45964E+00,-0.46167E+00,-0.46368E+00,-0.46567E+00, & + -0.46764E+00,-0.46960E+00,-0.47154E+00,-0.47347E+00,-0.47539E+00, & + -0.47729E+00,-0.47918E+00,-0.48106E+00,-0.48293E+00,-0.48478E+00, & + -0.48663E+00,-0.48846E+00,-0.49029E+00,-0.49211E+00,-0.49391E+00, & + -0.49571E+00,-0.49750E+00,-0.49928E+00,-0.50105E+00,-0.50282E+00, & + -0.50458E+00,-0.50633E+00,-0.50807E+00,-0.50980E+00,-0.51153E+00/ + + DATA (BNC05M (I),I=101,200)/ & + -0.51325E+00,-0.51496E+00,-0.51667E+00,-0.51837E+00,-0.52006E+00, & + -0.52174E+00,-0.52342E+00,-0.52508E+00,-0.52675E+00,-0.52840E+00, & + -0.53005E+00,-0.53169E+00,-0.53332E+00,-0.53494E+00,-0.53656E+00, & + -0.53817E+00,-0.53977E+00,-0.54137E+00,-0.54295E+00,-0.54453E+00, & + -0.54599E+00,-0.54757E+00,-0.54914E+00,-0.55070E+00,-0.55225E+00, & + -0.55379E+00,-0.55532E+00,-0.55685E+00,-0.55836E+00,-0.55987E+00, & + -0.56137E+00,-0.56286E+00,-0.56435E+00,-0.56582E+00,-0.56729E+00, & + -0.56875E+00,-0.57020E+00,-0.57165E+00,-0.57308E+00,-0.57451E+00, & + -0.57594E+00,-0.57735E+00,-0.57876E+00,-0.58016E+00,-0.58156E+00, & + -0.58294E+00,-0.58432E+00,-0.58570E+00,-0.58706E+00,-0.58842E+00, & + -0.58977E+00,-0.59112E+00,-0.59246E+00,-0.59379E+00,-0.59512E+00, & + -0.59644E+00,-0.59775E+00,-0.59906E+00,-0.60036E+00,-0.60166E+00, & + -0.60295E+00,-0.60423E+00,-0.60551E+00,-0.60678E+00,-0.60805E+00, & + -0.60931E+00,-0.61056E+00,-0.61181E+00,-0.61305E+00,-0.61429E+00, & + -0.61552E+00,-0.61675E+00,-0.61797E+00,-0.61918E+00,-0.62039E+00, & + -0.62160E+00,-0.62280E+00,-0.62399E+00,-0.62518E+00,-0.62636E+00, & + -0.62754E+00,-0.62872E+00,-0.62988E+00,-0.63105E+00,-0.63221E+00, & + -0.63336E+00,-0.63451E+00,-0.63565E+00,-0.63679E+00,-0.63792E+00, & + -0.63905E+00,-0.64018E+00,-0.64130E+00,-0.64241E+00,-0.64352E+00, & + -0.64463E+00,-0.64573E+00,-0.64683E+00,-0.64792E+00,-0.64901E+00/ + + DATA (BNC05M (I),I=201,300)/ & + -0.65009E+00,-0.65117E+00,-0.65225E+00,-0.65332E+00,-0.65438E+00, & + -0.65545E+00,-0.65650E+00,-0.65756E+00,-0.65861E+00,-0.65965E+00, & + -0.66069E+00,-0.66173E+00,-0.66276E+00,-0.66379E+00,-0.66482E+00, & + -0.66584E+00,-0.66686E+00,-0.66787E+00,-0.66888E+00,-0.66989E+00, & + -0.67089E+00,-0.67189E+00,-0.67288E+00,-0.67387E+00,-0.67486E+00, & + -0.67584E+00,-0.67682E+00,-0.67780E+00,-0.67877E+00,-0.67974E+00, & + -0.68070E+00,-0.68166E+00,-0.68262E+00,-0.68358E+00,-0.68453E+00, & + -0.68548E+00,-0.68642E+00,-0.68736E+00,-0.68830E+00,-0.68923E+00, & + -0.69016E+00,-0.69109E+00,-0.69201E+00,-0.69293E+00,-0.69385E+00, & + -0.69476E+00,-0.69567E+00,-0.69658E+00,-0.69749E+00,-0.69839E+00, & + -0.69928E+00,-0.70018E+00,-0.70107E+00,-0.70196E+00,-0.70284E+00, & + -0.70373E+00,-0.70461E+00,-0.70548E+00,-0.70636E+00,-0.70723E+00, & + -0.70809E+00,-0.70896E+00,-0.70982E+00,-0.71068E+00,-0.71153E+00, & + -0.71238E+00,-0.71323E+00,-0.71408E+00,-0.71492E+00,-0.71577E+00, & + -0.71660E+00,-0.71744E+00,-0.71827E+00,-0.71910E+00,-0.71993E+00, & + -0.72075E+00,-0.72158E+00,-0.72239E+00,-0.72321E+00,-0.72402E+00, & + -0.72484E+00,-0.72564E+00,-0.72645E+00,-0.72725E+00,-0.72805E+00, & + -0.72885E+00,-0.72965E+00,-0.73044E+00,-0.73123E+00,-0.73202E+00, & + -0.73280E+00,-0.73359E+00,-0.73437E+00,-0.73514E+00,-0.73592E+00, & + -0.73669E+00,-0.73746E+00,-0.73823E+00,-0.73899E+00,-0.73976E+00/ + + DATA (BNC05M (I),I=301,400)/ & + -0.74052E+00,-0.74128E+00,-0.74203E+00,-0.74279E+00,-0.74354E+00, & + -0.74429E+00,-0.74503E+00,-0.74578E+00,-0.74652E+00,-0.74726E+00, & + -0.74800E+00,-0.74873E+00,-0.74946E+00,-0.75019E+00,-0.75092E+00, & + -0.75165E+00,-0.75237E+00,-0.75309E+00,-0.75381E+00,-0.75453E+00, & + -0.75525E+00,-0.75596E+00,-0.75667E+00,-0.75738E+00,-0.75809E+00, & + -0.75879E+00,-0.75949E+00,-0.76019E+00,-0.76089E+00,-0.76159E+00, & + -0.76228E+00,-0.76297E+00,-0.76366E+00,-0.76435E+00,-0.76504E+00, & + -0.76572E+00,-0.76641E+00,-0.76709E+00,-0.76776E+00,-0.76844E+00, & + -0.76911E+00,-0.76979E+00,-0.77046E+00,-0.77112E+00,-0.77179E+00, & + -0.77246E+00,-0.77312E+00,-0.77378E+00,-0.77444E+00,-0.77509E+00, & + -0.77575E+00,-0.77640E+00,-0.77705E+00,-0.77770E+00,-0.77835E+00, & + -0.77900E+00,-0.77964E+00,-0.78028E+00,-0.78092E+00,-0.78156E+00, & + -0.78220E+00,-0.78283E+00,-0.78347E+00,-0.78410E+00,-0.78473E+00, & + -0.78536E+00,-0.78598E+00,-0.78661E+00,-0.78723E+00,-0.78785E+00, & + -0.78847E+00,-0.78909E+00,-0.78970E+00,-0.79032E+00,-0.79093E+00, & + -0.79154E+00,-0.79215E+00,-0.79276E+00,-0.79336E+00,-0.79397E+00, & + -0.79457E+00,-0.79517E+00,-0.79577E+00,-0.79637E+00,-0.79696E+00, & + -0.79756E+00,-0.79815E+00,-0.79874E+00,-0.79933E+00,-0.79992E+00, & + -0.80051E+00,-0.80109E+00,-0.80168E+00,-0.80226E+00,-0.80284E+00, & + -0.80342E+00,-0.80399E+00,-0.80457E+00,-0.80514E+00,-0.80572E+00/ + + DATA (BNC05M (I),I=401,500)/ & + -0.80629E+00,-0.80686E+00,-0.80743E+00,-0.80799E+00,-0.80856E+00, & + -0.80912E+00,-0.80968E+00,-0.81025E+00,-0.81081E+00,-0.81136E+00, & + -0.81192E+00,-0.81248E+00,-0.81303E+00,-0.81358E+00,-0.81413E+00, & + -0.81468E+00,-0.81523E+00,-0.81578E+00,-0.81632E+00,-0.81687E+00, & + -0.81741E+00,-0.81795E+00,-0.81849E+00,-0.81903E+00,-0.81956E+00, & + -0.82010E+00,-0.82063E+00,-0.82117E+00,-0.82170E+00,-0.82223E+00, & + -0.82276E+00,-0.82329E+00,-0.82381E+00,-0.82434E+00,-0.82486E+00, & + -0.82538E+00,-0.82590E+00,-0.82642E+00,-0.82694E+00,-0.82746E+00, & + -0.82798E+00,-0.82849E+00,-0.82900E+00,-0.82952E+00,-0.83003E+00, & + -0.83054E+00,-0.83104E+00,-0.83155E+00,-0.83206E+00,-0.83256E+00, & + -0.83307E+00,-0.83357E+00,-0.83407E+00,-0.83457E+00,-0.83507E+00, & + -0.83556E+00,-0.83606E+00,-0.83656E+00,-0.83705E+00,-0.83754E+00, & + -0.83803E+00,-0.83852E+00,-0.83901E+00,-0.83950E+00,-0.83999E+00, & + -0.84047E+00,-0.84096E+00,-0.84144E+00,-0.84192E+00,-0.84240E+00, & + -0.84288E+00,-0.84336E+00,-0.84384E+00,-0.84432E+00,-0.84479E+00, & + -0.84527E+00,-0.84574E+00,-0.84621E+00,-0.84668E+00,-0.84715E+00, & + -0.84762E+00,-0.84809E+00,-0.84855E+00,-0.84902E+00,-0.84948E+00, & + -0.84995E+00,-0.85041E+00,-0.85087E+00,-0.85133E+00,-0.85179E+00, & + -0.85225E+00,-0.85270E+00,-0.85316E+00,-0.85361E+00,-0.85407E+00, & + -0.85452E+00,-0.85497E+00,-0.85542E+00,-0.85587E+00,-0.85632E+00/ + + DATA (BNC05M (I),I=501,600)/ & + -0.85677E+00,-0.85721E+00,-0.85766E+00,-0.85810E+00,-0.85855E+00, & + -0.85899E+00,-0.85943E+00,-0.85987E+00,-0.86031E+00,-0.86075E+00, & + -0.86119E+00,-0.86162E+00,-0.86206E+00,-0.86249E+00,-0.86293E+00, & + -0.86336E+00,-0.86379E+00,-0.86422E+00,-0.86465E+00,-0.86508E+00, & + -0.86551E+00,-0.86593E+00,-0.86636E+00,-0.86678E+00,-0.86721E+00, & + -0.86763E+00,-0.86805E+00,-0.86848E+00,-0.86890E+00,-0.86931E+00, & + -0.86973E+00,-0.87015E+00,-0.87057E+00,-0.87098E+00,-0.87140E+00, & + -0.87181E+00,-0.87222E+00,-0.87264E+00,-0.87305E+00,-0.87346E+00, & + -0.87387E+00,-0.87428E+00,-0.87468E+00,-0.87509E+00,-0.87550E+00, & + -0.87590E+00,-0.87630E+00,-0.87671E+00,-0.87711E+00,-0.87751E+00, & + -0.87791E+00,-0.87831E+00,-0.87871E+00,-0.87911E+00,-0.87951E+00, & + -0.87990E+00,-0.88030E+00,-0.88069E+00,-0.88109E+00,-0.88148E+00, & + -0.88187E+00,-0.88226E+00,-0.88265E+00,-0.88304E+00,-0.88343E+00, & + -0.88382E+00,-0.88421E+00,-0.88459E+00,-0.88498E+00,-0.88537E+00, & + -0.88575E+00,-0.88613E+00,-0.88651E+00,-0.88690E+00,-0.88728E+00, & + -0.88766E+00,-0.88804E+00,-0.88841E+00,-0.88879E+00,-0.88917E+00, & + -0.88955E+00,-0.88992E+00,-0.89030E+00,-0.89067E+00,-0.89104E+00, & + -0.89141E+00,-0.89179E+00,-0.89216E+00,-0.89253E+00,-0.89290E+00, & + -0.89326E+00,-0.89363E+00,-0.89400E+00,-0.89436E+00,-0.89473E+00, & + -0.89509E+00,-0.89546E+00,-0.89582E+00,-0.89618E+00,-0.89754E+00/ + + DATA (BNC05M (I),I=601,700)/ & + -0.90048E+00,-0.90398E+00,-0.90741E+00,-0.91077E+00,-0.91407E+00, & + -0.91731E+00,-0.92048E+00,-0.92360E+00,-0.92666E+00,-0.92966E+00, & + -0.93261E+00,-0.93551E+00,-0.93835E+00,-0.94115E+00,-0.94389E+00, & + -0.94659E+00,-0.94924E+00,-0.95185E+00,-0.95441E+00,-0.95693E+00, & + -0.95941E+00,-0.96185E+00,-0.96425E+00,-0.96661E+00,-0.96893E+00, & + -0.97121E+00,-0.97346E+00,-0.97568E+00,-0.97786E+00,-0.98000E+00, & + -0.98212E+00,-0.98420E+00,-0.98625E+00,-0.98827E+00,-0.99026E+00, & + -0.99222E+00,-0.99415E+00,-0.99605E+00,-0.99793E+00,-0.99978E+00, & + -0.10016E+01,-0.10034E+01,-0.10052E+01,-0.10069E+01,-0.10087E+01, & + -0.10104E+01,-0.10120E+01,-0.10137E+01,-0.10153E+01,-0.10169E+01, & + -0.10185E+01,-0.10201E+01,-0.10216E+01,-0.10232E+01,-0.10247E+01, & + -0.10262E+01,-0.10276E+01,-0.10291E+01,-0.10305E+01,-0.10319E+01, & + -0.10333E+01,-0.10347E+01,-0.10361E+01,-0.10374E+01,-0.10388E+01, & + -0.10401E+01,-0.10414E+01,-0.10427E+01,-0.10439E+01,-0.10452E+01, & + -0.10464E+01,-0.10477E+01,-0.10489E+01,-0.10501E+01,-0.10513E+01, & + -0.10524E+01,-0.10536E+01,-0.10547E+01,-0.10559E+01,-0.10570E+01, & + -0.10581E+01,-0.10592E+01,-0.10603E+01,-0.10613E+01,-0.10624E+01, & + -0.10635E+01,-0.10645E+01,-0.10655E+01,-0.10665E+01,-0.10675E+01, & + -0.10685E+01,-0.10695E+01,-0.10705E+01,-0.10715E+01,-0.10724E+01, & + -0.10734E+01,-0.10743E+01,-0.10752E+01,-0.10761E+01,-0.10770E+01/ + + DATA (BNC05M(I),I=701,741)/ & + -0.10779E+01,-0.10788E+01,-0.10797E+01,-0.10806E+01,-0.10814E+01, & + -0.10823E+01,-0.10831E+01,-0.10840E+01,-0.10848E+01,-0.10856E+01, & + -0.10865E+01,-0.10873E+01,-0.10881E+01,-0.10889E+01,-0.10896E+01, & + -0.10904E+01,-0.10912E+01,-0.10920E+01,-0.10927E+01,-0.10935E+01, & + -0.10942E+01,-0.10949E+01,-0.10957E+01,-0.10964E+01,-0.10971E+01, & + -0.10978E+01,-0.10985E+01,-0.10992E+01,-0.10999E+01,-0.11006E+01, & + -0.11013E+01,-0.11020E+01,-0.11026E+01,-0.11033E+01,-0.11039E+01, & + -0.11046E+01,-0.11052E+01,-0.11059E+01,-0.11065E+01,-0.11071E+01, & + -0.11078E+01 & + / +! +! *** NH4Cl +! + DATA (BNC06M (I),I= 1,100)/ & + -0.50814E-01,-0.91326E-01,-0.11891E+00,-0.13710E+00,-0.15072E+00, & + -0.16157E+00,-0.17053E+00,-0.17813E+00,-0.18469E+00,-0.19042E+00, & + -0.19549E+00,-0.20001E+00,-0.20407E+00,-0.20774E+00,-0.21107E+00, & + -0.21410E+00,-0.21687E+00,-0.21942E+00,-0.22176E+00,-0.22392E+00, & + -0.22592E+00,-0.22777E+00,-0.22948E+00,-0.23108E+00,-0.23256E+00, & + -0.23394E+00,-0.23522E+00,-0.23642E+00,-0.23754E+00,-0.23858E+00, & + -0.23956E+00,-0.24048E+00,-0.24133E+00,-0.24213E+00,-0.24288E+00, & + -0.24359E+00,-0.24424E+00,-0.24486E+00,-0.24544E+00,-0.24598E+00, & + -0.24649E+00,-0.24696E+00,-0.24741E+00,-0.24782E+00,-0.24821E+00, & + -0.24858E+00,-0.24892E+00,-0.24923E+00,-0.24953E+00,-0.24980E+00, & + -0.25006E+00,-0.25030E+00,-0.25052E+00,-0.25072E+00,-0.25091E+00, & + -0.25108E+00,-0.25123E+00,-0.25137E+00,-0.25150E+00,-0.25161E+00, & + -0.25171E+00,-0.25180E+00,-0.25188E+00,-0.25194E+00,-0.25199E+00, & + -0.25203E+00,-0.25206E+00,-0.25207E+00,-0.25208E+00,-0.25207E+00, & + -0.25205E+00,-0.25203E+00,-0.25199E+00,-0.25194E+00,-0.25188E+00, & + -0.25180E+00,-0.25172E+00,-0.25163E+00,-0.25153E+00,-0.25141E+00, & + -0.25129E+00,-0.25116E+00,-0.25101E+00,-0.25086E+00,-0.25070E+00, & + -0.25052E+00,-0.25034E+00,-0.25015E+00,-0.24994E+00,-0.24973E+00, & + -0.24951E+00,-0.24928E+00,-0.24904E+00,-0.24879E+00,-0.24854E+00, & + -0.24827E+00,-0.24800E+00,-0.24772E+00,-0.24743E+00,-0.24713E+00/ + + DATA (BNC06M (I),I=101,200)/ & + -0.24683E+00,-0.24651E+00,-0.24620E+00,-0.24587E+00,-0.24554E+00, & + -0.24520E+00,-0.24485E+00,-0.24450E+00,-0.24415E+00,-0.24379E+00, & + -0.24342E+00,-0.24305E+00,-0.24267E+00,-0.24229E+00,-0.24190E+00, & + -0.24151E+00,-0.24112E+00,-0.24072E+00,-0.24032E+00,-0.23991E+00, & + -0.23958E+00,-0.23916E+00,-0.23874E+00,-0.23831E+00,-0.23788E+00, & + -0.23745E+00,-0.23702E+00,-0.23659E+00,-0.23615E+00,-0.23572E+00, & + -0.23528E+00,-0.23484E+00,-0.23439E+00,-0.23395E+00,-0.23350E+00, & + -0.23306E+00,-0.23261E+00,-0.23216E+00,-0.23171E+00,-0.23126E+00, & + -0.23080E+00,-0.23035E+00,-0.22989E+00,-0.22944E+00,-0.22898E+00, & + -0.22852E+00,-0.22806E+00,-0.22760E+00,-0.22713E+00,-0.22667E+00, & + -0.22621E+00,-0.22574E+00,-0.22528E+00,-0.22481E+00,-0.22434E+00, & + -0.22388E+00,-0.22341E+00,-0.22294E+00,-0.22247E+00,-0.22200E+00, & + -0.22153E+00,-0.22105E+00,-0.22058E+00,-0.22011E+00,-0.21963E+00, & + -0.21916E+00,-0.21869E+00,-0.21821E+00,-0.21773E+00,-0.21726E+00, & + -0.21678E+00,-0.21631E+00,-0.21583E+00,-0.21535E+00,-0.21487E+00, & + -0.21440E+00,-0.21392E+00,-0.21344E+00,-0.21296E+00,-0.21248E+00, & + -0.21200E+00,-0.21152E+00,-0.21104E+00,-0.21056E+00,-0.21008E+00, & + -0.20960E+00,-0.20912E+00,-0.20864E+00,-0.20816E+00,-0.20768E+00, & + -0.20720E+00,-0.20672E+00,-0.20624E+00,-0.20576E+00,-0.20527E+00, & + -0.20479E+00,-0.20431E+00,-0.20383E+00,-0.20335E+00,-0.20287E+00/ + + DATA (BNC06M (I),I=201,300)/ & + -0.20239E+00,-0.20191E+00,-0.20143E+00,-0.20094E+00,-0.20046E+00, & + -0.19998E+00,-0.19950E+00,-0.19902E+00,-0.19854E+00,-0.19806E+00, & + -0.19758E+00,-0.19710E+00,-0.19662E+00,-0.19614E+00,-0.19566E+00, & + -0.19518E+00,-0.19470E+00,-0.19422E+00,-0.19374E+00,-0.19326E+00, & + -0.19278E+00,-0.19230E+00,-0.19182E+00,-0.19135E+00,-0.19087E+00, & + -0.19039E+00,-0.18991E+00,-0.18943E+00,-0.18896E+00,-0.18848E+00, & + -0.18800E+00,-0.18753E+00,-0.18705E+00,-0.18657E+00,-0.18610E+00, & + -0.18562E+00,-0.18515E+00,-0.18467E+00,-0.18420E+00,-0.18372E+00, & + -0.18325E+00,-0.18277E+00,-0.18230E+00,-0.18183E+00,-0.18135E+00, & + -0.18088E+00,-0.18041E+00,-0.17994E+00,-0.17946E+00,-0.17899E+00, & + -0.17852E+00,-0.17805E+00,-0.17758E+00,-0.17711E+00,-0.17664E+00, & + -0.17617E+00,-0.17570E+00,-0.17523E+00,-0.17476E+00,-0.17430E+00, & + -0.17383E+00,-0.17336E+00,-0.17289E+00,-0.17243E+00,-0.17196E+00, & + -0.17149E+00,-0.17103E+00,-0.17056E+00,-0.17010E+00,-0.16963E+00, & + -0.16917E+00,-0.16871E+00,-0.16824E+00,-0.16778E+00,-0.16732E+00, & + -0.16685E+00,-0.16639E+00,-0.16593E+00,-0.16547E+00,-0.16501E+00, & + -0.16455E+00,-0.16409E+00,-0.16363E+00,-0.16317E+00,-0.16271E+00, & + -0.16225E+00,-0.16179E+00,-0.16134E+00,-0.16088E+00,-0.16042E+00, & + -0.15997E+00,-0.15951E+00,-0.15905E+00,-0.15860E+00,-0.15814E+00, & + -0.15769E+00,-0.15724E+00,-0.15678E+00,-0.15633E+00,-0.15588E+00/ + + DATA (BNC06M (I),I=301,400)/ & + -0.15542E+00,-0.15497E+00,-0.15452E+00,-0.15407E+00,-0.15362E+00, & + -0.15317E+00,-0.15272E+00,-0.15227E+00,-0.15182E+00,-0.15137E+00, & + -0.15092E+00,-0.15048E+00,-0.15003E+00,-0.14958E+00,-0.14914E+00, & + -0.14869E+00,-0.14825E+00,-0.14780E+00,-0.14736E+00,-0.14691E+00, & + -0.14647E+00,-0.14602E+00,-0.14558E+00,-0.14514E+00,-0.14470E+00, & + -0.14425E+00,-0.14381E+00,-0.14337E+00,-0.14293E+00,-0.14249E+00, & + -0.14205E+00,-0.14161E+00,-0.14118E+00,-0.14074E+00,-0.14030E+00, & + -0.13986E+00,-0.13943E+00,-0.13899E+00,-0.13855E+00,-0.13812E+00, & + -0.13768E+00,-0.13725E+00,-0.13681E+00,-0.13638E+00,-0.13595E+00, & + -0.13551E+00,-0.13508E+00,-0.13465E+00,-0.13422E+00,-0.13379E+00, & + -0.13336E+00,-0.13292E+00,-0.13249E+00,-0.13207E+00,-0.13164E+00, & + -0.13121E+00,-0.13078E+00,-0.13035E+00,-0.12992E+00,-0.12950E+00, & + -0.12907E+00,-0.12865E+00,-0.12822E+00,-0.12779E+00,-0.12737E+00, & + -0.12695E+00,-0.12652E+00,-0.12610E+00,-0.12568E+00,-0.12525E+00, & + -0.12483E+00,-0.12441E+00,-0.12399E+00,-0.12357E+00,-0.12315E+00, & + -0.12273E+00,-0.12231E+00,-0.12189E+00,-0.12147E+00,-0.12105E+00, & + -0.12063E+00,-0.12022E+00,-0.11980E+00,-0.11938E+00,-0.11897E+00, & + -0.11855E+00,-0.11814E+00,-0.11772E+00,-0.11731E+00,-0.11689E+00, & + -0.11648E+00,-0.11607E+00,-0.11565E+00,-0.11524E+00,-0.11483E+00, & + -0.11442E+00,-0.11401E+00,-0.11360E+00,-0.11319E+00,-0.11278E+00/ + + DATA (BNC06M (I),I=401,500)/ & + -0.11237E+00,-0.11196E+00,-0.11155E+00,-0.11114E+00,-0.11074E+00, & + -0.11033E+00,-0.10992E+00,-0.10952E+00,-0.10911E+00,-0.10871E+00, & + -0.10830E+00,-0.10790E+00,-0.10749E+00,-0.10709E+00,-0.10668E+00, & + -0.10628E+00,-0.10588E+00,-0.10548E+00,-0.10507E+00,-0.10467E+00, & + -0.10427E+00,-0.10387E+00,-0.10347E+00,-0.10307E+00,-0.10267E+00, & + -0.10227E+00,-0.10188E+00,-0.10148E+00,-0.10108E+00,-0.10068E+00, & + -0.10029E+00,-0.99891E-01,-0.99495E-01,-0.99100E-01,-0.98704E-01, & + -0.98310E-01,-0.97915E-01,-0.97522E-01,-0.97128E-01,-0.96735E-01, & + -0.96342E-01,-0.95950E-01,-0.95558E-01,-0.95167E-01,-0.94776E-01, & + -0.94385E-01,-0.93995E-01,-0.93605E-01,-0.93216E-01,-0.92827E-01, & + -0.92438E-01,-0.92050E-01,-0.91662E-01,-0.91274E-01,-0.90887E-01, & + -0.90501E-01,-0.90114E-01,-0.89729E-01,-0.89343E-01,-0.88958E-01, & + -0.88573E-01,-0.88189E-01,-0.87805E-01,-0.87422E-01,-0.87039E-01, & + -0.86656E-01,-0.86274E-01,-0.85892E-01,-0.85510E-01,-0.85129E-01, & + -0.84748E-01,-0.84368E-01,-0.83988E-01,-0.83608E-01,-0.83229E-01, & + -0.82850E-01,-0.82472E-01,-0.82094E-01,-0.81716E-01,-0.81339E-01, & + -0.80962E-01,-0.80585E-01,-0.80209E-01,-0.79833E-01,-0.79458E-01, & + -0.79083E-01,-0.78708E-01,-0.78334E-01,-0.77960E-01,-0.77586E-01, & + -0.77213E-01,-0.76840E-01,-0.76468E-01,-0.76096E-01,-0.75724E-01, & + -0.75353E-01,-0.74982E-01,-0.74612E-01,-0.74242E-01,-0.73872E-01/ + + DATA (BNC06M (I),I=501,600)/ & + -0.73502E-01,-0.73133E-01,-0.72765E-01,-0.72396E-01,-0.72028E-01, & + -0.71661E-01,-0.71294E-01,-0.70927E-01,-0.70560E-01,-0.70194E-01, & + -0.69829E-01,-0.69463E-01,-0.69098E-01,-0.68734E-01,-0.68369E-01, & + -0.68005E-01,-0.67642E-01,-0.67279E-01,-0.66916E-01,-0.66553E-01, & + -0.66191E-01,-0.65829E-01,-0.65468E-01,-0.65107E-01,-0.64746E-01, & + -0.64386E-01,-0.64026E-01,-0.63666E-01,-0.63307E-01,-0.62948E-01, & + -0.62590E-01,-0.62232E-01,-0.61874E-01,-0.61516E-01,-0.61159E-01, & + -0.60802E-01,-0.60446E-01,-0.60090E-01,-0.59734E-01,-0.59379E-01, & + -0.59024E-01,-0.58669E-01,-0.58315E-01,-0.57961E-01,-0.57607E-01, & + -0.57254E-01,-0.56901E-01,-0.56548E-01,-0.56196E-01,-0.55844E-01, & + -0.55492E-01,-0.55141E-01,-0.54790E-01,-0.54439E-01,-0.54089E-01, & + -0.53739E-01,-0.53390E-01,-0.53040E-01,-0.52692E-01,-0.52343E-01, & + -0.51995E-01,-0.51647E-01,-0.51299E-01,-0.50952E-01,-0.50605E-01, & + -0.50259E-01,-0.49913E-01,-0.49567E-01,-0.49221E-01,-0.48876E-01, & + -0.48531E-01,-0.48187E-01,-0.47842E-01,-0.47498E-01,-0.47155E-01, & + -0.46812E-01,-0.46469E-01,-0.46126E-01,-0.45784E-01,-0.45442E-01, & + -0.45100E-01,-0.44759E-01,-0.44418E-01,-0.44078E-01,-0.43737E-01, & + -0.43397E-01,-0.43058E-01,-0.42718E-01,-0.42379E-01,-0.42041E-01, & + -0.41702E-01,-0.41364E-01,-0.41027E-01,-0.40689E-01,-0.40352E-01, & + -0.40015E-01,-0.39679E-01,-0.39343E-01,-0.39007E-01,-0.37750E-01/ + + DATA (BNC06M (I),I=601,700)/ & + -0.35001E-01,-0.31698E-01,-0.28424E-01,-0.25181E-01,-0.21967E-01, & + -0.18782E-01,-0.15626E-01,-0.12497E-01,-0.93963E-02,-0.63224E-02, & + -0.32753E-02,-0.25450E-03, 0.27406E-02, 0.57102E-02, 0.86547E-02, & + 0.11575E-01, 0.14470E-01, 0.17342E-01, 0.20191E-01, 0.23016E-01, & + 0.25819E-01, 0.28599E-01, 0.31357E-01, 0.34093E-01, 0.36808E-01, & + 0.39502E-01, 0.42175E-01, 0.44827E-01, 0.47460E-01, 0.50072E-01, & + 0.52665E-01, 0.55239E-01, 0.57793E-01, 0.60329E-01, 0.62847E-01, & + 0.65346E-01, 0.67827E-01, 0.70291E-01, 0.72737E-01, 0.75165E-01, & + 0.77577E-01, 0.79972E-01, 0.82351E-01, 0.84713E-01, 0.87059E-01, & + 0.89390E-01, 0.91704E-01, 0.94003E-01, 0.96287E-01, 0.98556E-01, & + 0.10081E+00, 0.10305E+00, 0.10527E+00, 0.10749E+00, 0.10968E+00, & + 0.11186E+00, 0.11403E+00, 0.11619E+00, 0.11833E+00, 0.12046E+00, & + 0.12257E+00, 0.12468E+00, 0.12677E+00, 0.12884E+00, 0.13091E+00, & + 0.13296E+00, 0.13500E+00, 0.13703E+00, 0.13904E+00, 0.14105E+00, & + 0.14304E+00, 0.14502E+00, 0.14699E+00, 0.14895E+00, 0.15090E+00, & + 0.15283E+00, 0.15476E+00, 0.15668E+00, 0.15858E+00, 0.16047E+00, & + 0.16236E+00, 0.16423E+00, 0.16609E+00, 0.16795E+00, 0.16979E+00, & + 0.17162E+00, 0.17345E+00, 0.17526E+00, 0.17706E+00, 0.17886E+00, & + 0.18064E+00, 0.18242E+00, 0.18419E+00, 0.18595E+00, 0.18769E+00, & + 0.18944E+00, 0.19117E+00, 0.19289E+00, 0.19460E+00, 0.19631E+00/ + + DATA (BNC06M(I),I=701,741)/ & + 0.19801E+00, 0.19970E+00, 0.20138E+00, 0.20305E+00, 0.20471E+00, & + 0.20637E+00, 0.20802E+00, 0.20966E+00, 0.21129E+00, 0.21292E+00, & + 0.21453E+00, 0.21614E+00, 0.21775E+00, 0.21934E+00, 0.22093E+00, & + 0.22251E+00, 0.22408E+00, 0.22565E+00, 0.22721E+00, 0.22876E+00, & + 0.23030E+00, 0.23184E+00, 0.23337E+00, 0.23490E+00, 0.23641E+00, & + 0.23792E+00, 0.23943E+00, 0.24093E+00, 0.24242E+00, 0.24390E+00, & + 0.24538E+00, 0.24685E+00, 0.24832E+00, 0.24978E+00, 0.25123E+00, & + 0.25268E+00, 0.25412E+00, 0.25555E+00, 0.25698E+00, 0.25840E+00, & + 0.25982E+00 & + / +! +! *** (2H, SO4) +! + DATA (BNC07M (I),I= 1,100)/ & + -0.10285E+00,-0.18717E+00,-0.24637E+00,-0.28657E+00,-0.31747E+00, & + -0.34271E+00,-0.36411E+00,-0.38270E+00,-0.39914E+00,-0.41388E+00, & + -0.42725E+00,-0.43947E+00,-0.45073E+00,-0.46116E+00,-0.47088E+00, & + -0.47998E+00,-0.48853E+00,-0.49659E+00,-0.50422E+00,-0.51145E+00, & + -0.51833E+00,-0.52489E+00,-0.53115E+00,-0.53714E+00,-0.54288E+00, & + -0.54839E+00,-0.55369E+00,-0.55879E+00,-0.56371E+00,-0.56845E+00, & + -0.57304E+00,-0.57747E+00,-0.58177E+00,-0.58593E+00,-0.58996E+00, & + -0.59388E+00,-0.59768E+00,-0.60138E+00,-0.60497E+00,-0.60847E+00, & + -0.61188E+00,-0.61521E+00,-0.61845E+00,-0.62161E+00,-0.62469E+00, & + -0.62770E+00,-0.63065E+00,-0.63352E+00,-0.63634E+00,-0.63909E+00, & + -0.64178E+00,-0.64442E+00,-0.64700E+00,-0.64953E+00,-0.65201E+00, & + -0.65445E+00,-0.65683E+00,-0.65917E+00,-0.66147E+00,-0.66373E+00, & + -0.66594E+00,-0.66812E+00,-0.67026E+00,-0.67236E+00,-0.67443E+00, & + -0.67646E+00,-0.67846E+00,-0.68043E+00,-0.68237E+00,-0.68427E+00, & + -0.68615E+00,-0.68800E+00,-0.68983E+00,-0.69162E+00,-0.69339E+00, & + -0.69514E+00,-0.69686E+00,-0.69856E+00,-0.70024E+00,-0.70189E+00, & + -0.70352E+00,-0.70514E+00,-0.70673E+00,-0.70830E+00,-0.70985E+00, & + -0.71139E+00,-0.71290E+00,-0.71440E+00,-0.71588E+00,-0.71734E+00, & + -0.71879E+00,-0.72022E+00,-0.72164E+00,-0.72304E+00,-0.72442E+00, & + -0.72579E+00,-0.72715E+00,-0.72849E+00,-0.72982E+00,-0.73113E+00/ + + DATA (BNC07M (I),I=101,200)/ & + -0.73243E+00,-0.73372E+00,-0.73500E+00,-0.73626E+00,-0.73751E+00, & + -0.73875E+00,-0.73998E+00,-0.74119E+00,-0.74240E+00,-0.74359E+00, & + -0.74477E+00,-0.74594E+00,-0.74710E+00,-0.74825E+00,-0.74939E+00, & + -0.75052E+00,-0.75164E+00,-0.75275E+00,-0.75385E+00,-0.75494E+00, & + -0.75600E+00,-0.75708E+00,-0.75814E+00,-0.75920E+00,-0.76025E+00, & + -0.76128E+00,-0.76231E+00,-0.76333E+00,-0.76435E+00,-0.76535E+00, & + -0.76634E+00,-0.76733E+00,-0.76831E+00,-0.76928E+00,-0.77025E+00, & + -0.77120E+00,-0.77215E+00,-0.77310E+00,-0.77403E+00,-0.77496E+00, & + -0.77588E+00,-0.77679E+00,-0.77770E+00,-0.77860E+00,-0.77949E+00, & + -0.78038E+00,-0.78126E+00,-0.78213E+00,-0.78300E+00,-0.78386E+00, & + -0.78472E+00,-0.78557E+00,-0.78641E+00,-0.78725E+00,-0.78808E+00, & + -0.78890E+00,-0.78972E+00,-0.79054E+00,-0.79135E+00,-0.79215E+00, & + -0.79295E+00,-0.79374E+00,-0.79453E+00,-0.79531E+00,-0.79609E+00, & + -0.79686E+00,-0.79763E+00,-0.79840E+00,-0.79915E+00,-0.79991E+00, & + -0.80065E+00,-0.80140E+00,-0.80214E+00,-0.80287E+00,-0.80360E+00, & + -0.80433E+00,-0.80505E+00,-0.80577E+00,-0.80648E+00,-0.80719E+00, & + -0.80789E+00,-0.80859E+00,-0.80929E+00,-0.80998E+00,-0.81067E+00, & + -0.81135E+00,-0.81203E+00,-0.81271E+00,-0.81338E+00,-0.81405E+00, & + -0.81471E+00,-0.81537E+00,-0.81603E+00,-0.81669E+00,-0.81734E+00, & + -0.81798E+00,-0.81863E+00,-0.81926E+00,-0.81990E+00,-0.82053E+00/ + + DATA (BNC07M (I),I=201,300)/ & + -0.82116E+00,-0.82179E+00,-0.82241E+00,-0.82303E+00,-0.82365E+00, & + -0.82426E+00,-0.82487E+00,-0.82548E+00,-0.82608E+00,-0.82668E+00, & + -0.82728E+00,-0.82787E+00,-0.82846E+00,-0.82905E+00,-0.82963E+00, & + -0.83022E+00,-0.83080E+00,-0.83137E+00,-0.83195E+00,-0.83252E+00, & + -0.83309E+00,-0.83365E+00,-0.83421E+00,-0.83477E+00,-0.83533E+00, & + -0.83589E+00,-0.83644E+00,-0.83699E+00,-0.83753E+00,-0.83808E+00, & + -0.83862E+00,-0.83916E+00,-0.83970E+00,-0.84023E+00,-0.84076E+00, & + -0.84129E+00,-0.84182E+00,-0.84234E+00,-0.84286E+00,-0.84338E+00, & + -0.84390E+00,-0.84442E+00,-0.84493E+00,-0.84544E+00,-0.84595E+00, & + -0.84645E+00,-0.84696E+00,-0.84746E+00,-0.84796E+00,-0.84846E+00, & + -0.84895E+00,-0.84945E+00,-0.84994E+00,-0.85043E+00,-0.85091E+00, & + -0.85140E+00,-0.85188E+00,-0.85236E+00,-0.85284E+00,-0.85332E+00, & + -0.85379E+00,-0.85426E+00,-0.85473E+00,-0.85520E+00,-0.85567E+00, & + -0.85614E+00,-0.85660E+00,-0.85706E+00,-0.85752E+00,-0.85798E+00, & + -0.85843E+00,-0.85889E+00,-0.85934E+00,-0.85979E+00,-0.86024E+00, & + -0.86069E+00,-0.86113E+00,-0.86157E+00,-0.86202E+00,-0.86246E+00, & + -0.86289E+00,-0.86333E+00,-0.86377E+00,-0.86420E+00,-0.86463E+00, & + -0.86506E+00,-0.86549E+00,-0.86592E+00,-0.86634E+00,-0.86676E+00, & + -0.86719E+00,-0.86761E+00,-0.86803E+00,-0.86844E+00,-0.86886E+00, & + -0.86927E+00,-0.86969E+00,-0.87010E+00,-0.87051E+00,-0.87091E+00/ + + DATA (BNC07M (I),I=301,400)/ & + -0.87132E+00,-0.87173E+00,-0.87213E+00,-0.87253E+00,-0.87293E+00, & + -0.87333E+00,-0.87373E+00,-0.87413E+00,-0.87452E+00,-0.87492E+00, & + -0.87531E+00,-0.87570E+00,-0.87609E+00,-0.87648E+00,-0.87687E+00, & + -0.87725E+00,-0.87764E+00,-0.87802E+00,-0.87840E+00,-0.87878E+00, & + -0.87916E+00,-0.87954E+00,-0.87992E+00,-0.88029E+00,-0.88067E+00, & + -0.88104E+00,-0.88141E+00,-0.88178E+00,-0.88215E+00,-0.88252E+00, & + -0.88289E+00,-0.88325E+00,-0.88362E+00,-0.88398E+00,-0.88434E+00, & + -0.88470E+00,-0.88506E+00,-0.88542E+00,-0.88578E+00,-0.88614E+00, & + -0.88649E+00,-0.88685E+00,-0.88720E+00,-0.88755E+00,-0.88790E+00, & + -0.88825E+00,-0.88860E+00,-0.88895E+00,-0.88929E+00,-0.88964E+00, & + -0.88998E+00,-0.89033E+00,-0.89067E+00,-0.89101E+00,-0.89135E+00, & + -0.89169E+00,-0.89203E+00,-0.89236E+00,-0.89270E+00,-0.89303E+00, & + -0.89337E+00,-0.89370E+00,-0.89403E+00,-0.89436E+00,-0.89469E+00, & + -0.89502E+00,-0.89535E+00,-0.89568E+00,-0.89600E+00,-0.89633E+00, & + -0.89665E+00,-0.89697E+00,-0.89730E+00,-0.89762E+00,-0.89794E+00, & + -0.89826E+00,-0.89857E+00,-0.89889E+00,-0.89921E+00,-0.89952E+00, & + -0.89984E+00,-0.90015E+00,-0.90047E+00,-0.90078E+00,-0.90109E+00, & + -0.90140E+00,-0.90171E+00,-0.90202E+00,-0.90232E+00,-0.90263E+00, & + -0.90294E+00,-0.90324E+00,-0.90355E+00,-0.90385E+00,-0.90415E+00, & + -0.90445E+00,-0.90475E+00,-0.90505E+00,-0.90535E+00,-0.90565E+00/ + + DATA (BNC07M (I),I=401,500)/ & + -0.90595E+00,-0.90625E+00,-0.90654E+00,-0.90684E+00,-0.90713E+00, & + -0.90743E+00,-0.90772E+00,-0.90801E+00,-0.90830E+00,-0.90859E+00, & + -0.90888E+00,-0.90917E+00,-0.90946E+00,-0.90975E+00,-0.91003E+00, & + -0.91032E+00,-0.91060E+00,-0.91089E+00,-0.91117E+00,-0.91145E+00, & + -0.91174E+00,-0.91202E+00,-0.91230E+00,-0.91258E+00,-0.91286E+00, & + -0.91314E+00,-0.91341E+00,-0.91369E+00,-0.91397E+00,-0.91424E+00, & + -0.91452E+00,-0.91479E+00,-0.91507E+00,-0.91534E+00,-0.91561E+00, & + -0.91588E+00,-0.91615E+00,-0.91642E+00,-0.91669E+00,-0.91696E+00, & + -0.91723E+00,-0.91750E+00,-0.91776E+00,-0.91803E+00,-0.91830E+00, & + -0.91856E+00,-0.91883E+00,-0.91909E+00,-0.91935E+00,-0.91961E+00, & + -0.91988E+00,-0.92014E+00,-0.92040E+00,-0.92066E+00,-0.92092E+00, & + -0.92117E+00,-0.92143E+00,-0.92169E+00,-0.92195E+00,-0.92220E+00, & + -0.92246E+00,-0.92271E+00,-0.92297E+00,-0.92322E+00,-0.92347E+00, & + -0.92373E+00,-0.92398E+00,-0.92423E+00,-0.92448E+00,-0.92473E+00, & + -0.92498E+00,-0.92523E+00,-0.92548E+00,-0.92572E+00,-0.92597E+00, & + -0.92622E+00,-0.92646E+00,-0.92671E+00,-0.92695E+00,-0.92720E+00, & + -0.92744E+00,-0.92768E+00,-0.92793E+00,-0.92817E+00,-0.92841E+00, & + -0.92865E+00,-0.92889E+00,-0.92913E+00,-0.92937E+00,-0.92961E+00, & + -0.92985E+00,-0.93009E+00,-0.93032E+00,-0.93056E+00,-0.93080E+00, & + -0.93103E+00,-0.93127E+00,-0.93150E+00,-0.93174E+00,-0.93197E+00/ + + DATA (BNC07M (I),I=501,600)/ & + -0.93220E+00,-0.93243E+00,-0.93267E+00,-0.93290E+00,-0.93313E+00, & + -0.93336E+00,-0.93359E+00,-0.93382E+00,-0.93405E+00,-0.93428E+00, & + -0.93450E+00,-0.93473E+00,-0.93496E+00,-0.93519E+00,-0.93541E+00, & + -0.93564E+00,-0.93586E+00,-0.93609E+00,-0.93631E+00,-0.93653E+00, & + -0.93676E+00,-0.93698E+00,-0.93720E+00,-0.93742E+00,-0.93765E+00, & + -0.93787E+00,-0.93809E+00,-0.93831E+00,-0.93853E+00,-0.93875E+00, & + -0.93896E+00,-0.93918E+00,-0.93940E+00,-0.93962E+00,-0.93983E+00, & + -0.94005E+00,-0.94027E+00,-0.94048E+00,-0.94070E+00,-0.94091E+00, & + -0.94112E+00,-0.94134E+00,-0.94155E+00,-0.94176E+00,-0.94198E+00, & + -0.94219E+00,-0.94240E+00,-0.94261E+00,-0.94282E+00,-0.94303E+00, & + -0.94324E+00,-0.94345E+00,-0.94366E+00,-0.94387E+00,-0.94408E+00, & + -0.94428E+00,-0.94449E+00,-0.94470E+00,-0.94491E+00,-0.94511E+00, & + -0.94532E+00,-0.94552E+00,-0.94573E+00,-0.94593E+00,-0.94614E+00, & + -0.94634E+00,-0.94654E+00,-0.94675E+00,-0.94695E+00,-0.94715E+00, & + -0.94735E+00,-0.94755E+00,-0.94775E+00,-0.94795E+00,-0.94815E+00, & + -0.94835E+00,-0.94855E+00,-0.94875E+00,-0.94895E+00,-0.94915E+00, & + -0.94935E+00,-0.94954E+00,-0.94974E+00,-0.94994E+00,-0.95014E+00, & + -0.95033E+00,-0.95053E+00,-0.95072E+00,-0.95092E+00,-0.95111E+00, & + -0.95131E+00,-0.95150E+00,-0.95169E+00,-0.95189E+00,-0.95208E+00, & + -0.95227E+00,-0.95246E+00,-0.95265E+00,-0.95285E+00,-0.95356E+00/ + + DATA (BNC07M (I),I=601,700)/ & + -0.95511E+00,-0.95697E+00,-0.95879E+00,-0.96057E+00,-0.96233E+00, & + -0.96406E+00,-0.96576E+00,-0.96743E+00,-0.96907E+00,-0.97069E+00, & + -0.97228E+00,-0.97385E+00,-0.97539E+00,-0.97691E+00,-0.97841E+00, & + -0.97989E+00,-0.98134E+00,-0.98277E+00,-0.98418E+00,-0.98558E+00, & + -0.98695E+00,-0.98830E+00,-0.98964E+00,-0.99096E+00,-0.99226E+00, & + -0.99354E+00,-0.99481E+00,-0.99606E+00,-0.99730E+00,-0.99852E+00, & + -0.99972E+00,-0.10009E+01,-0.10021E+01,-0.10032E+01,-0.10044E+01, & + -0.10055E+01,-0.10067E+01,-0.10078E+01,-0.10089E+01,-0.10099E+01, & + -0.10110E+01,-0.10121E+01,-0.10131E+01,-0.10142E+01,-0.10152E+01, & + -0.10162E+01,-0.10172E+01,-0.10182E+01,-0.10192E+01,-0.10201E+01, & + -0.10211E+01,-0.10221E+01,-0.10230E+01,-0.10239E+01,-0.10249E+01, & + -0.10258E+01,-0.10267E+01,-0.10276E+01,-0.10285E+01,-0.10293E+01, & + -0.10302E+01,-0.10311E+01,-0.10319E+01,-0.10328E+01,-0.10336E+01, & + -0.10345E+01,-0.10353E+01,-0.10361E+01,-0.10369E+01,-0.10377E+01, & + -0.10385E+01,-0.10393E+01,-0.10401E+01,-0.10409E+01,-0.10416E+01, & + -0.10424E+01,-0.10432E+01,-0.10439E+01,-0.10447E+01,-0.10454E+01, & + -0.10461E+01,-0.10469E+01,-0.10476E+01,-0.10483E+01,-0.10490E+01, & + -0.10497E+01,-0.10504E+01,-0.10511E+01,-0.10518E+01,-0.10525E+01, & + -0.10532E+01,-0.10538E+01,-0.10545E+01,-0.10552E+01,-0.10558E+01, & + -0.10565E+01,-0.10571E+01,-0.10578E+01,-0.10584E+01,-0.10591E+01/ + + DATA (BNC07M(I),I=701,741)/ & + -0.10597E+01,-0.10603E+01,-0.10609E+01,-0.10616E+01,-0.10622E+01, & + -0.10628E+01,-0.10634E+01,-0.10640E+01,-0.10646E+01,-0.10652E+01, & + -0.10658E+01,-0.10663E+01,-0.10669E+01,-0.10675E+01,-0.10681E+01, & + -0.10687E+01,-0.10692E+01,-0.10698E+01,-0.10703E+01,-0.10709E+01, & + -0.10714E+01,-0.10720E+01,-0.10725E+01,-0.10731E+01,-0.10736E+01, & + -0.10742E+01,-0.10747E+01,-0.10752E+01,-0.10757E+01,-0.10763E+01, & + -0.10768E+01,-0.10773E+01,-0.10778E+01,-0.10783E+01,-0.10788E+01, & + -0.10793E+01,-0.10798E+01,-0.10803E+01,-0.10808E+01,-0.10813E+01, & + -0.10818E+01 & + / +! +! *** (H, HSO4) +! + DATA (BNC08M (I),I= 1,100)/ & + -0.48178E-01,-0.82334E-01,-0.10277E+00,-0.11452E+00,-0.12211E+00, & + -0.12718E+00,-0.13053E+00,-0.13262E+00,-0.13374E+00,-0.13407E+00, & + -0.13376E+00,-0.13289E+00,-0.13155E+00,-0.12979E+00,-0.12766E+00, & + -0.12519E+00,-0.12242E+00,-0.11937E+00,-0.11607E+00,-0.11252E+00, & + -0.10875E+00,-0.10478E+00,-0.10060E+00,-0.96246E-01,-0.91714E-01, & + -0.87015E-01,-0.82158E-01,-0.77151E-01,-0.72001E-01,-0.66714E-01, & + -0.61297E-01,-0.55755E-01,-0.50094E-01,-0.44319E-01,-0.38434E-01, & + -0.32445E-01,-0.26356E-01,-0.20172E-01,-0.13895E-01,-0.75315E-02, & + -0.10835E-02, 0.54448E-02, 0.12050E-01, 0.18729E-01, 0.25479E-01, & + 0.32296E-01, 0.39178E-01, 0.46121E-01, 0.53125E-01, 0.60185E-01, & + 0.67299E-01, 0.74467E-01, 0.81685E-01, 0.88951E-01, 0.96265E-01, & + 0.10362E+00, 0.11103E+00, 0.11847E+00, 0.12596E+00, 0.13349E+00, & + 0.14106E+00, 0.14866E+00, 0.15631E+00, 0.16400E+00, 0.17172E+00, & + 0.17948E+00, 0.18727E+00, 0.19511E+00, 0.20298E+00, 0.21089E+00, & + 0.21884E+00, 0.22683E+00, 0.23486E+00, 0.24293E+00, 0.25103E+00, & + 0.25918E+00, 0.26737E+00, 0.27560E+00, 0.28387E+00, 0.29219E+00, & + 0.30055E+00, 0.30895E+00, 0.31740E+00, 0.32589E+00, 0.33443E+00, & + 0.34301E+00, 0.35163E+00, 0.36030E+00, 0.36901E+00, 0.37777E+00, & + 0.38658E+00, 0.39542E+00, 0.40431E+00, 0.41324E+00, 0.42221E+00, & + 0.43122E+00, 0.44027E+00, 0.44936E+00, 0.45849E+00, 0.46765E+00/ + + DATA (BNC08M (I),I=101,200)/ & + 0.47684E+00, 0.48607E+00, 0.49533E+00, 0.50462E+00, 0.51393E+00, & + 0.52328E+00, 0.53264E+00, 0.54203E+00, 0.55144E+00, 0.56087E+00, & + 0.57032E+00, 0.57979E+00, 0.58926E+00, 0.59876E+00, 0.60826E+00, & + 0.61777E+00, 0.62729E+00, 0.63682E+00, 0.64635E+00, 0.65589E+00, & + 0.66464E+00, 0.67427E+00, 0.68389E+00, 0.69350E+00, 0.70310E+00, & + 0.71269E+00, 0.72227E+00, 0.73184E+00, 0.74139E+00, 0.75094E+00, & + 0.76047E+00, 0.76999E+00, 0.77950E+00, 0.78899E+00, 0.79847E+00, & + 0.80794E+00, 0.81739E+00, 0.82683E+00, 0.83625E+00, 0.84566E+00, & + 0.85506E+00, 0.86444E+00, 0.87380E+00, 0.88315E+00, 0.89249E+00, & + 0.90181E+00, 0.91111E+00, 0.92039E+00, 0.92966E+00, 0.93892E+00, & + 0.94816E+00, 0.95738E+00, 0.96658E+00, 0.97577E+00, 0.98494E+00, & + 0.99409E+00, 0.10032E+01, 0.10123E+01, 0.10215E+01, 0.10305E+01, & + 0.10396E+01, 0.10487E+01, 0.10577E+01, 0.10667E+01, 0.10757E+01, & + 0.10847E+01, 0.10936E+01, 0.11026E+01, 0.11115E+01, 0.11204E+01, & + 0.11293E+01, 0.11382E+01, 0.11470E+01, 0.11559E+01, 0.11647E+01, & + 0.11735E+01, 0.11823E+01, 0.11910E+01, 0.11998E+01, 0.12085E+01, & + 0.12172E+01, 0.12259E+01, 0.12346E+01, 0.12432E+01, 0.12519E+01, & + 0.12605E+01, 0.12691E+01, 0.12777E+01, 0.12862E+01, 0.12948E+01, & + 0.13033E+01, 0.13118E+01, 0.13203E+01, 0.13288E+01, 0.13372E+01, & + 0.13457E+01, 0.13541E+01, 0.13625E+01, 0.13709E+01, 0.13793E+01/ + + DATA (BNC08M (I),I=201,300)/ & + 0.13876E+01, 0.13959E+01, 0.14043E+01, 0.14126E+01, 0.14208E+01, & + 0.14291E+01, 0.14373E+01, 0.14456E+01, 0.14538E+01, 0.14620E+01, & + 0.14701E+01, 0.14783E+01, 0.14864E+01, 0.14945E+01, 0.15027E+01, & + 0.15107E+01, 0.15188E+01, 0.15269E+01, 0.15349E+01, 0.15429E+01, & + 0.15509E+01, 0.15589E+01, 0.15669E+01, 0.15748E+01, 0.15828E+01, & + 0.15907E+01, 0.15986E+01, 0.16065E+01, 0.16143E+01, 0.16222E+01, & + 0.16300E+01, 0.16378E+01, 0.16456E+01, 0.16534E+01, 0.16612E+01, & + 0.16689E+01, 0.16767E+01, 0.16844E+01, 0.16921E+01, 0.16998E+01, & + 0.17075E+01, 0.17151E+01, 0.17227E+01, 0.17304E+01, 0.17380E+01, & + 0.17456E+01, 0.17531E+01, 0.17607E+01, 0.17683E+01, 0.17758E+01, & + 0.17833E+01, 0.17908E+01, 0.17983E+01, 0.18057E+01, 0.18132E+01, & + 0.18206E+01, 0.18281E+01, 0.18355E+01, 0.18429E+01, 0.18502E+01, & + 0.18576E+01, 0.18649E+01, 0.18723E+01, 0.18796E+01, 0.18869E+01, & + 0.18942E+01, 0.19014E+01, 0.19087E+01, 0.19159E+01, 0.19232E+01, & + 0.19304E+01, 0.19376E+01, 0.19448E+01, 0.19519E+01, 0.19591E+01, & + 0.19662E+01, 0.19734E+01, 0.19805E+01, 0.19876E+01, 0.19947E+01, & + 0.20017E+01, 0.20088E+01, 0.20158E+01, 0.20229E+01, 0.20299E+01, & + 0.20369E+01, 0.20439E+01, 0.20509E+01, 0.20578E+01, 0.20648E+01, & + 0.20717E+01, 0.20786E+01, 0.20855E+01, 0.20924E+01, 0.20993E+01, & + 0.21062E+01, 0.21130E+01, 0.21199E+01, 0.21267E+01, 0.21335E+01/ + + DATA (BNC08M (I),I=301,400)/ & + 0.21403E+01, 0.21471E+01, 0.21539E+01, 0.21606E+01, 0.21674E+01, & + 0.21741E+01, 0.21808E+01, 0.21875E+01, 0.21942E+01, 0.22009E+01, & + 0.22076E+01, 0.22143E+01, 0.22209E+01, 0.22275E+01, 0.22342E+01, & + 0.22408E+01, 0.22474E+01, 0.22540E+01, 0.22605E+01, 0.22671E+01, & + 0.22737E+01, 0.22802E+01, 0.22867E+01, 0.22932E+01, 0.22997E+01, & + 0.23062E+01, 0.23127E+01, 0.23192E+01, 0.23256E+01, 0.23321E+01, & + 0.23385E+01, 0.23449E+01, 0.23513E+01, 0.23577E+01, 0.23641E+01, & + 0.23705E+01, 0.23768E+01, 0.23832E+01, 0.23895E+01, 0.23958E+01, & + 0.24021E+01, 0.24084E+01, 0.24147E+01, 0.24210E+01, 0.24273E+01, & + 0.24335E+01, 0.24398E+01, 0.24460E+01, 0.24522E+01, 0.24585E+01, & + 0.24647E+01, 0.24709E+01, 0.24770E+01, 0.24832E+01, 0.24894E+01, & + 0.24955E+01, 0.25016E+01, 0.25078E+01, 0.25139E+01, 0.25200E+01, & + 0.25261E+01, 0.25322E+01, 0.25382E+01, 0.25443E+01, 0.25504E+01, & + 0.25564E+01, 0.25624E+01, 0.25685E+01, 0.25745E+01, 0.25805E+01, & + 0.25865E+01, 0.25924E+01, 0.25984E+01, 0.26044E+01, 0.26103E+01, & + 0.26163E+01, 0.26222E+01, 0.26281E+01, 0.26340E+01, 0.26399E+01, & + 0.26458E+01, 0.26517E+01, 0.26576E+01, 0.26634E+01, 0.26693E+01, & + 0.26751E+01, 0.26809E+01, 0.26868E+01, 0.26926E+01, 0.26984E+01, & + 0.27042E+01, 0.27099E+01, 0.27157E+01, 0.27215E+01, 0.27272E+01, & + 0.27330E+01, 0.27387E+01, 0.27444E+01, 0.27501E+01, 0.27559E+01/ + + DATA (BNC08M (I),I=401,500)/ & + 0.27615E+01, 0.27672E+01, 0.27729E+01, 0.27786E+01, 0.27842E+01, & + 0.27899E+01, 0.27955E+01, 0.28012E+01, 0.28068E+01, 0.28124E+01, & + 0.28180E+01, 0.28236E+01, 0.28292E+01, 0.28348E+01, 0.28403E+01, & + 0.28459E+01, 0.28515E+01, 0.28570E+01, 0.28625E+01, 0.28681E+01, & + 0.28736E+01, 0.28791E+01, 0.28846E+01, 0.28901E+01, 0.28956E+01, & + 0.29010E+01, 0.29065E+01, 0.29119E+01, 0.29174E+01, 0.29228E+01, & + 0.29283E+01, 0.29337E+01, 0.29391E+01, 0.29445E+01, 0.29499E+01, & + 0.29553E+01, 0.29607E+01, 0.29660E+01, 0.29714E+01, 0.29768E+01, & + 0.29821E+01, 0.29874E+01, 0.29928E+01, 0.29981E+01, 0.30034E+01, & + 0.30087E+01, 0.30140E+01, 0.30193E+01, 0.30246E+01, 0.30299E+01, & + 0.30351E+01, 0.30404E+01, 0.30456E+01, 0.30509E+01, 0.30561E+01, & + 0.30613E+01, 0.30666E+01, 0.30718E+01, 0.30770E+01, 0.30822E+01, & + 0.30874E+01, 0.30925E+01, 0.30977E+01, 0.31029E+01, 0.31080E+01, & + 0.31132E+01, 0.31183E+01, 0.31235E+01, 0.31286E+01, 0.31337E+01, & + 0.31388E+01, 0.31439E+01, 0.31490E+01, 0.31541E+01, 0.31592E+01, & + 0.31643E+01, 0.31693E+01, 0.31744E+01, 0.31794E+01, 0.31845E+01, & + 0.31895E+01, 0.31945E+01, 0.31996E+01, 0.32046E+01, 0.32096E+01, & + 0.32146E+01, 0.32196E+01, 0.32246E+01, 0.32296E+01, 0.32345E+01, & + 0.32395E+01, 0.32444E+01, 0.32494E+01, 0.32543E+01, 0.32593E+01, & + 0.32642E+01, 0.32691E+01, 0.32740E+01, 0.32790E+01, 0.32839E+01/ + + DATA (BNC08M (I),I=501,600)/ & + 0.32888E+01, 0.32936E+01, 0.32985E+01, 0.33034E+01, 0.33083E+01, & + 0.33131E+01, 0.33180E+01, 0.33228E+01, 0.33277E+01, 0.33325E+01, & + 0.33373E+01, 0.33421E+01, 0.33470E+01, 0.33518E+01, 0.33566E+01, & + 0.33614E+01, 0.33662E+01, 0.33709E+01, 0.33757E+01, 0.33805E+01, & + 0.33852E+01, 0.33900E+01, 0.33947E+01, 0.33995E+01, 0.34042E+01, & + 0.34089E+01, 0.34137E+01, 0.34184E+01, 0.34231E+01, 0.34278E+01, & + 0.34325E+01, 0.34372E+01, 0.34419E+01, 0.34465E+01, 0.34512E+01, & + 0.34559E+01, 0.34605E+01, 0.34652E+01, 0.34698E+01, 0.34745E+01, & + 0.34791E+01, 0.34837E+01, 0.34884E+01, 0.34930E+01, 0.34976E+01, & + 0.35022E+01, 0.35068E+01, 0.35114E+01, 0.35160E+01, 0.35205E+01, & + 0.35251E+01, 0.35297E+01, 0.35342E+01, 0.35388E+01, 0.35433E+01, & + 0.35479E+01, 0.35524E+01, 0.35569E+01, 0.35615E+01, 0.35660E+01, & + 0.35705E+01, 0.35750E+01, 0.35795E+01, 0.35840E+01, 0.35885E+01, & + 0.35930E+01, 0.35975E+01, 0.36019E+01, 0.36064E+01, 0.36109E+01, & + 0.36153E+01, 0.36198E+01, 0.36242E+01, 0.36286E+01, 0.36331E+01, & + 0.36375E+01, 0.36419E+01, 0.36463E+01, 0.36508E+01, 0.36552E+01, & + 0.36596E+01, 0.36639E+01, 0.36683E+01, 0.36727E+01, 0.36771E+01, & + 0.36815E+01, 0.36858E+01, 0.36902E+01, 0.36945E+01, 0.36989E+01, & + 0.37032E+01, 0.37076E+01, 0.37119E+01, 0.37162E+01, 0.37206E+01, & + 0.37249E+01, 0.37292E+01, 0.37335E+01, 0.37378E+01, 0.37539E+01/ + + DATA (BNC08M (I),I=601,700)/ & + 0.37890E+01, 0.38311E+01, 0.38727E+01, 0.39138E+01, 0.39544E+01, & + 0.39945E+01, 0.40342E+01, 0.40734E+01, 0.41122E+01, 0.41506E+01, & + 0.41885E+01, 0.42261E+01, 0.42632E+01, 0.42999E+01, 0.43363E+01, & + 0.43722E+01, 0.44078E+01, 0.44431E+01, 0.44780E+01, 0.45125E+01, & + 0.45467E+01, 0.45806E+01, 0.46141E+01, 0.46473E+01, 0.46802E+01, & + 0.47128E+01, 0.47451E+01, 0.47771E+01, 0.48088E+01, 0.48402E+01, & + 0.48713E+01, 0.49022E+01, 0.49327E+01, 0.49630E+01, 0.49931E+01, & + 0.50229E+01, 0.50524E+01, 0.50817E+01, 0.51107E+01, 0.51395E+01, & + 0.51681E+01, 0.51964E+01, 0.52245E+01, 0.52524E+01, 0.52800E+01, & + 0.53074E+01, 0.53346E+01, 0.53616E+01, 0.53884E+01, 0.54150E+01, & + 0.54414E+01, 0.54676E+01, 0.54936E+01, 0.55194E+01, 0.55450E+01, & + 0.55704E+01, 0.55956E+01, 0.56206E+01, 0.56455E+01, 0.56702E+01, & + 0.56947E+01, 0.57191E+01, 0.57432E+01, 0.57672E+01, 0.57911E+01, & + 0.58148E+01, 0.58383E+01, 0.58616E+01, 0.58848E+01, 0.59079E+01, & + 0.59308E+01, 0.59535E+01, 0.59761E+01, 0.59986E+01, 0.60209E+01, & + 0.60430E+01, 0.60650E+01, 0.60869E+01, 0.61087E+01, 0.61303E+01, & + 0.61517E+01, 0.61731E+01, 0.61943E+01, 0.62154E+01, 0.62363E+01, & + 0.62572E+01, 0.62779E+01, 0.62984E+01, 0.63189E+01, 0.63392E+01, & + 0.63595E+01, 0.63796E+01, 0.63996E+01, 0.64194E+01, 0.64392E+01, & + 0.64588E+01, 0.64784E+01, 0.64978E+01, 0.65171E+01, 0.65363E+01/ + + DATA (BNC08M(I),I=701,741)/ & + 0.65554E+01, 0.65744E+01, 0.65933E+01, 0.66121E+01, 0.66308E+01, & + 0.66494E+01, 0.66679E+01, 0.66863E+01, 0.67046E+01, 0.67228E+01, & + 0.67409E+01, 0.67589E+01, 0.67768E+01, 0.67947E+01, 0.68124E+01, & + 0.68300E+01, 0.68476E+01, 0.68651E+01, 0.68824E+01, 0.68997E+01, & + 0.69169E+01, 0.69341E+01, 0.69511E+01, 0.69680E+01, 0.69849E+01, & + 0.70017E+01, 0.70184E+01, 0.70350E+01, 0.70516E+01, 0.70681E+01, & + 0.70845E+01, 0.71008E+01, 0.71170E+01, 0.71332E+01, 0.71493E+01, & + 0.71653E+01, 0.71812E+01, 0.71971E+01, 0.72129E+01, 0.72286E+01, & + 0.72442E+01 & + / +! +! *** NH4HSO4 +! + DATA (BNC09M (I),I= 1,100)/ & + -0.50460E-01,-0.90365E-01,-0.11751E+00,-0.13545E+00,-0.14891E+00, & + -0.15966E+00,-0.16855E+00,-0.17609E+00,-0.18259E+00,-0.18826E+00, & + -0.19325E+00,-0.19767E+00,-0.20160E+00,-0.20511E+00,-0.20826E+00, & + -0.21107E+00,-0.21359E+00,-0.21585E+00,-0.21786E+00,-0.21965E+00, & + -0.22123E+00,-0.22262E+00,-0.22384E+00,-0.22488E+00,-0.22578E+00, & + -0.22652E+00,-0.22713E+00,-0.22760E+00,-0.22795E+00,-0.22817E+00, & + -0.22829E+00,-0.22829E+00,-0.22819E+00,-0.22799E+00,-0.22770E+00, & + -0.22731E+00,-0.22683E+00,-0.22627E+00,-0.22563E+00,-0.22491E+00, & + -0.22411E+00,-0.22324E+00,-0.22230E+00,-0.22129E+00,-0.22021E+00, & + -0.21907E+00,-0.21788E+00,-0.21662E+00,-0.21530E+00,-0.21394E+00, & + -0.21251E+00,-0.21104E+00,-0.20952E+00,-0.20795E+00,-0.20634E+00, & + -0.20468E+00,-0.20297E+00,-0.20123E+00,-0.19944E+00,-0.19762E+00, & + -0.19576E+00,-0.19386E+00,-0.19192E+00,-0.18995E+00,-0.18795E+00, & + -0.18591E+00,-0.18384E+00,-0.18174E+00,-0.17961E+00,-0.17744E+00, & + -0.17525E+00,-0.17303E+00,-0.17078E+00,-0.16849E+00,-0.16619E+00, & + -0.16385E+00,-0.16149E+00,-0.15910E+00,-0.15668E+00,-0.15423E+00, & + -0.15176E+00,-0.14927E+00,-0.14675E+00,-0.14420E+00,-0.14163E+00, & + -0.13903E+00,-0.13641E+00,-0.13376E+00,-0.13110E+00,-0.12840E+00, & + -0.12569E+00,-0.12295E+00,-0.12020E+00,-0.11742E+00,-0.11462E+00, & + -0.11180E+00,-0.10896E+00,-0.10610E+00,-0.10322E+00,-0.10033E+00/ + + DATA (BNC09M (I),I=101,200)/ & + -0.97415E-01,-0.94487E-01,-0.91545E-01,-0.88587E-01,-0.85616E-01, & + -0.82631E-01,-0.79634E-01,-0.76626E-01,-0.73606E-01,-0.70577E-01, & + -0.67538E-01,-0.64490E-01,-0.61435E-01,-0.58371E-01,-0.55302E-01, & + -0.52227E-01,-0.49147E-01,-0.46061E-01,-0.42972E-01,-0.39880E-01, & + -0.37062E-01,-0.33933E-01,-0.30805E-01,-0.27679E-01,-0.24555E-01, & + -0.21433E-01,-0.18313E-01,-0.15196E-01,-0.12082E-01,-0.89703E-02, & + -0.58621E-02,-0.27572E-02, 0.34429E-03, 0.34421E-02, 0.65364E-02, & + 0.96264E-02, 0.12713E-01, 0.15795E-01, 0.18873E-01, 0.21946E-01, & + 0.25015E-01, 0.28079E-01, 0.31139E-01, 0.34193E-01, 0.37243E-01, & + 0.40288E-01, 0.43328E-01, 0.46362E-01, 0.49392E-01, 0.52416E-01, & + 0.55435E-01, 0.58448E-01, 0.61456E-01, 0.64458E-01, 0.67455E-01, & + 0.70446E-01, 0.73432E-01, 0.76411E-01, 0.79385E-01, 0.82354E-01, & + 0.85316E-01, 0.88272E-01, 0.91223E-01, 0.94168E-01, 0.97106E-01, & + 0.10004E+00, 0.10297E+00, 0.10589E+00, 0.10880E+00, 0.11171E+00, & + 0.11461E+00, 0.11751E+00, 0.12040E+00, 0.12328E+00, 0.12616E+00, & + 0.12903E+00, 0.13190E+00, 0.13476E+00, 0.13761E+00, 0.14046E+00, & + 0.14330E+00, 0.14614E+00, 0.14896E+00, 0.15179E+00, 0.15460E+00, & + 0.15741E+00, 0.16022E+00, 0.16302E+00, 0.16581E+00, 0.16859E+00, & + 0.17138E+00, 0.17415E+00, 0.17692E+00, 0.17968E+00, 0.18243E+00, & + 0.18518E+00, 0.18793E+00, 0.19066E+00, 0.19340E+00, 0.19612E+00/ + + DATA (BNC09M (I),I=201,300)/ & + 0.19884E+00, 0.20155E+00, 0.20426E+00, 0.20696E+00, 0.20966E+00, & + 0.21235E+00, 0.21503E+00, 0.21771E+00, 0.22038E+00, 0.22305E+00, & + 0.22571E+00, 0.22837E+00, 0.23101E+00, 0.23366E+00, 0.23629E+00, & + 0.23893E+00, 0.24155E+00, 0.24417E+00, 0.24679E+00, 0.24940E+00, & + 0.25200E+00, 0.25460E+00, 0.25719E+00, 0.25978E+00, 0.26236E+00, & + 0.26493E+00, 0.26750E+00, 0.27007E+00, 0.27262E+00, 0.27518E+00, & + 0.27772E+00, 0.28027E+00, 0.28280E+00, 0.28534E+00, 0.28786E+00, & + 0.29038E+00, 0.29290E+00, 0.29541E+00, 0.29791E+00, 0.30041E+00, & + 0.30291E+00, 0.30540E+00, 0.30788E+00, 0.31036E+00, 0.31283E+00, & + 0.31530E+00, 0.31776E+00, 0.32022E+00, 0.32268E+00, 0.32512E+00, & + 0.32757E+00, 0.33000E+00, 0.33244E+00, 0.33486E+00, 0.33729E+00, & + 0.33971E+00, 0.34212E+00, 0.34453E+00, 0.34693E+00, 0.34933E+00, & + 0.35172E+00, 0.35411E+00, 0.35649E+00, 0.35887E+00, 0.36125E+00, & + 0.36362E+00, 0.36598E+00, 0.36834E+00, 0.37070E+00, 0.37305E+00, & + 0.37539E+00, 0.37773E+00, 0.38007E+00, 0.38240E+00, 0.38473E+00, & + 0.38705E+00, 0.38937E+00, 0.39168E+00, 0.39399E+00, 0.39630E+00, & + 0.39860E+00, 0.40089E+00, 0.40318E+00, 0.40547E+00, 0.40775E+00, & + 0.41003E+00, 0.41230E+00, 0.41457E+00, 0.41684E+00, 0.41910E+00, & + 0.42136E+00, 0.42361E+00, 0.42585E+00, 0.42810E+00, 0.43034E+00, & + 0.43257E+00, 0.43480E+00, 0.43703E+00, 0.43925E+00, 0.44147E+00/ + + DATA (BNC09M (I),I=301,400)/ & + 0.44368E+00, 0.44589E+00, 0.44810E+00, 0.45030E+00, 0.45250E+00, & + 0.45469E+00, 0.45688E+00, 0.45906E+00, 0.46124E+00, 0.46342E+00, & + 0.46559E+00, 0.46776E+00, 0.46993E+00, 0.47209E+00, 0.47425E+00, & + 0.47640E+00, 0.47855E+00, 0.48070E+00, 0.48284E+00, 0.48497E+00, & + 0.48711E+00, 0.48924E+00, 0.49136E+00, 0.49349E+00, 0.49561E+00, & + 0.49772E+00, 0.49983E+00, 0.50194E+00, 0.50404E+00, 0.50614E+00, & + 0.50824E+00, 0.51033E+00, 0.51242E+00, 0.51450E+00, 0.51658E+00, & + 0.51866E+00, 0.52074E+00, 0.52281E+00, 0.52487E+00, 0.52694E+00, & + 0.52900E+00, 0.53105E+00, 0.53311E+00, 0.53515E+00, 0.53720E+00, & + 0.53924E+00, 0.54128E+00, 0.54331E+00, 0.54535E+00, 0.54737E+00, & + 0.54940E+00, 0.55142E+00, 0.55344E+00, 0.55545E+00, 0.55746E+00, & + 0.55947E+00, 0.56147E+00, 0.56347E+00, 0.56547E+00, 0.56747E+00, & + 0.56946E+00, 0.57144E+00, 0.57343E+00, 0.57541E+00, 0.57738E+00, & + 0.57936E+00, 0.58133E+00, 0.58330E+00, 0.58526E+00, 0.58722E+00, & + 0.58918E+00, 0.59113E+00, 0.59309E+00, 0.59503E+00, 0.59698E+00, & + 0.59892E+00, 0.60086E+00, 0.60279E+00, 0.60473E+00, 0.60666E+00, & + 0.60858E+00, 0.61050E+00, 0.61242E+00, 0.61434E+00, 0.61625E+00, & + 0.61817E+00, 0.62007E+00, 0.62198E+00, 0.62388E+00, 0.62578E+00, & + 0.62767E+00, 0.62957E+00, 0.63145E+00, 0.63334E+00, 0.63522E+00, & + 0.63710E+00, 0.63898E+00, 0.64086E+00, 0.64273E+00, 0.64460E+00/ + + DATA (BNC09M (I),I=401,500)/ & + 0.64646E+00, 0.64833E+00, 0.65019E+00, 0.65204E+00, 0.65390E+00, & + 0.65575E+00, 0.65760E+00, 0.65944E+00, 0.66128E+00, 0.66312E+00, & + 0.66496E+00, 0.66680E+00, 0.66863E+00, 0.67046E+00, 0.67228E+00, & + 0.67410E+00, 0.67592E+00, 0.67774E+00, 0.67956E+00, 0.68137E+00, & + 0.68318E+00, 0.68498E+00, 0.68679E+00, 0.68859E+00, 0.69039E+00, & + 0.69218E+00, 0.69398E+00, 0.69577E+00, 0.69755E+00, 0.69934E+00, & + 0.70112E+00, 0.70290E+00, 0.70468E+00, 0.70645E+00, 0.70822E+00, & + 0.70999E+00, 0.71176E+00, 0.71352E+00, 0.71528E+00, 0.71704E+00, & + 0.71880E+00, 0.72055E+00, 0.72230E+00, 0.72405E+00, 0.72580E+00, & + 0.72754E+00, 0.72928E+00, 0.73102E+00, 0.73275E+00, 0.73449E+00, & + 0.73622E+00, 0.73794E+00, 0.73967E+00, 0.74139E+00, 0.74311E+00, & + 0.74483E+00, 0.74655E+00, 0.74826E+00, 0.74997E+00, 0.75168E+00, & + 0.75339E+00, 0.75509E+00, 0.75679E+00, 0.75849E+00, 0.76019E+00, & + 0.76188E+00, 0.76357E+00, 0.76526E+00, 0.76695E+00, 0.76863E+00, & + 0.77031E+00, 0.77199E+00, 0.77367E+00, 0.77534E+00, 0.77702E+00, & + 0.77869E+00, 0.78035E+00, 0.78202E+00, 0.78368E+00, 0.78534E+00, & + 0.78700E+00, 0.78866E+00, 0.79031E+00, 0.79197E+00, 0.79362E+00, & + 0.79526E+00, 0.79691E+00, 0.79855E+00, 0.80019E+00, 0.80183E+00, & + 0.80347E+00, 0.80510E+00, 0.80673E+00, 0.80836E+00, 0.80999E+00, & + 0.81161E+00, 0.81323E+00, 0.81486E+00, 0.81647E+00, 0.81809E+00/ + + DATA (BNC09M (I),I=501,600)/ & + 0.81970E+00, 0.82132E+00, 0.82293E+00, 0.82453E+00, 0.82614E+00, & + 0.82774E+00, 0.82934E+00, 0.83094E+00, 0.83254E+00, 0.83413E+00, & + 0.83573E+00, 0.83732E+00, 0.83890E+00, 0.84049E+00, 0.84207E+00, & + 0.84366E+00, 0.84524E+00, 0.84681E+00, 0.84839E+00, 0.84996E+00, & + 0.85154E+00, 0.85311E+00, 0.85467E+00, 0.85624E+00, 0.85780E+00, & + 0.85936E+00, 0.86092E+00, 0.86248E+00, 0.86404E+00, 0.86559E+00, & + 0.86714E+00, 0.86869E+00, 0.87024E+00, 0.87178E+00, 0.87333E+00, & + 0.87487E+00, 0.87641E+00, 0.87795E+00, 0.87948E+00, 0.88101E+00, & + 0.88255E+00, 0.88408E+00, 0.88560E+00, 0.88713E+00, 0.88865E+00, & + 0.89017E+00, 0.89169E+00, 0.89321E+00, 0.89473E+00, 0.89624E+00, & + 0.89776E+00, 0.89927E+00, 0.90077E+00, 0.90228E+00, 0.90379E+00, & + 0.90529E+00, 0.90679E+00, 0.90829E+00, 0.90979E+00, 0.91128E+00, & + 0.91277E+00, 0.91427E+00, 0.91576E+00, 0.91724E+00, 0.91873E+00, & + 0.92021E+00, 0.92170E+00, 0.92318E+00, 0.92466E+00, 0.92613E+00, & + 0.92761E+00, 0.92908E+00, 0.93055E+00, 0.93202E+00, 0.93349E+00, & + 0.93496E+00, 0.93642E+00, 0.93788E+00, 0.93935E+00, 0.94080E+00, & + 0.94226E+00, 0.94372E+00, 0.94517E+00, 0.94662E+00, 0.94807E+00, & + 0.94952E+00, 0.95097E+00, 0.95241E+00, 0.95386E+00, 0.95530E+00, & + 0.95674E+00, 0.95818E+00, 0.95961E+00, 0.96105E+00, 0.96248E+00, & + 0.96391E+00, 0.96534E+00, 0.96677E+00, 0.96820E+00, 0.97353E+00/ + + DATA (BNC09M (I),I=601,700)/ & + 0.98518E+00, 0.99915E+00, 0.10130E+01, 0.10266E+01, 0.10401E+01, & + 0.10535E+01, 0.10667E+01, 0.10797E+01, 0.10927E+01, 0.11054E+01, & + 0.11181E+01, 0.11306E+01, 0.11430E+01, 0.11553E+01, 0.11674E+01, & + 0.11794E+01, 0.11913E+01, 0.12031E+01, 0.12148E+01, 0.12263E+01, & + 0.12378E+01, 0.12491E+01, 0.12604E+01, 0.12715E+01, 0.12825E+01, & + 0.12934E+01, 0.13043E+01, 0.13150E+01, 0.13257E+01, 0.13362E+01, & + 0.13467E+01, 0.13570E+01, 0.13673E+01, 0.13775E+01, 0.13876E+01, & + 0.13976E+01, 0.14075E+01, 0.14174E+01, 0.14272E+01, 0.14369E+01, & + 0.14465E+01, 0.14560E+01, 0.14655E+01, 0.14749E+01, 0.14842E+01, & + 0.14935E+01, 0.15027E+01, 0.15118E+01, 0.15208E+01, 0.15298E+01, & + 0.15387E+01, 0.15476E+01, 0.15563E+01, 0.15651E+01, 0.15737E+01, & + 0.15823E+01, 0.15908E+01, 0.15993E+01, 0.16077E+01, 0.16161E+01, & + 0.16244E+01, 0.16326E+01, 0.16408E+01, 0.16489E+01, 0.16570E+01, & + 0.16650E+01, 0.16730E+01, 0.16809E+01, 0.16888E+01, 0.16966E+01, & + 0.17044E+01, 0.17121E+01, 0.17197E+01, 0.17274E+01, 0.17349E+01, & + 0.17424E+01, 0.17499E+01, 0.17574E+01, 0.17647E+01, 0.17721E+01, & + 0.17794E+01, 0.17866E+01, 0.17938E+01, 0.18010E+01, 0.18081E+01, & + 0.18152E+01, 0.18222E+01, 0.18292E+01, 0.18362E+01, 0.18431E+01, & + 0.18500E+01, 0.18568E+01, 0.18636E+01, 0.18704E+01, 0.18771E+01, & + 0.18838E+01, 0.18905E+01, 0.18971E+01, 0.19037E+01, 0.19102E+01/ + + DATA (BNC09M(I),I=701,741)/ & + 0.19167E+01, 0.19232E+01, 0.19296E+01, 0.19360E+01, 0.19424E+01, & + 0.19488E+01, 0.19551E+01, 0.19613E+01, 0.19676E+01, 0.19738E+01, & + 0.19800E+01, 0.19861E+01, 0.19922E+01, 0.19983E+01, 0.20044E+01, & + 0.20104E+01, 0.20164E+01, 0.20223E+01, 0.20283E+01, 0.20342E+01, & + 0.20401E+01, 0.20459E+01, 0.20517E+01, 0.20575E+01, 0.20633E+01, & + 0.20690E+01, 0.20747E+01, 0.20804E+01, 0.20861E+01, 0.20917E+01, & + 0.20973E+01, 0.21029E+01, 0.21084E+01, 0.21140E+01, 0.21195E+01, & + 0.21249E+01, 0.21304E+01, 0.21358E+01, 0.21412E+01, 0.21466E+01, & + 0.21520E+01 & + / +! +! *** (H, NO3) +! + DATA (BNC10M (I),I= 1,100)/ & + -0.49808E-01,-0.87670E-01,-0.11206E+00,-0.12725E+00,-0.13801E+00, & + -0.14607E+00,-0.15233E+00,-0.15727E+00,-0.16121E+00,-0.16437E+00, & + -0.16689E+00,-0.16889E+00,-0.17045E+00,-0.17164E+00,-0.17251E+00, & + -0.17311E+00,-0.17346E+00,-0.17359E+00,-0.17354E+00,-0.17332E+00, & + -0.17295E+00,-0.17244E+00,-0.17181E+00,-0.17107E+00,-0.17023E+00, & + -0.16931E+00,-0.16829E+00,-0.16721E+00,-0.16605E+00,-0.16483E+00, & + -0.16356E+00,-0.16223E+00,-0.16086E+00,-0.15944E+00,-0.15798E+00, & + -0.15649E+00,-0.15496E+00,-0.15340E+00,-0.15182E+00,-0.15021E+00, & + -0.14858E+00,-0.14693E+00,-0.14526E+00,-0.14357E+00,-0.14187E+00, & + -0.14015E+00,-0.13842E+00,-0.13668E+00,-0.13493E+00,-0.13316E+00, & + -0.13139E+00,-0.12961E+00,-0.12783E+00,-0.12603E+00,-0.12423E+00, & + -0.12243E+00,-0.12061E+00,-0.11880E+00,-0.11697E+00,-0.11514E+00, & + -0.11330E+00,-0.11146E+00,-0.10961E+00,-0.10776E+00,-0.10590E+00, & + -0.10403E+00,-0.10215E+00,-0.10027E+00,-0.98377E-01,-0.96477E-01, & + -0.94568E-01,-0.92650E-01,-0.90723E-01,-0.88785E-01,-0.86836E-01, & + -0.84877E-01,-0.82906E-01,-0.80923E-01,-0.78927E-01,-0.76919E-01, & + -0.74899E-01,-0.72864E-01,-0.70817E-01,-0.68755E-01,-0.66679E-01, & + -0.64590E-01,-0.62485E-01,-0.60367E-01,-0.58234E-01,-0.56087E-01, & + -0.53925E-01,-0.51749E-01,-0.49559E-01,-0.47354E-01,-0.45136E-01, & + -0.42905E-01,-0.40659E-01,-0.38401E-01,-0.36131E-01,-0.33847E-01/ + + DATA (BNC10M (I),I=101,200)/ & + -0.31552E-01,-0.29246E-01,-0.26928E-01,-0.24599E-01,-0.22261E-01, & + -0.19912E-01,-0.17554E-01,-0.15187E-01,-0.12812E-01,-0.10429E-01, & + -0.80390E-02,-0.56417E-02,-0.32380E-02,-0.82822E-03, 0.15871E-02, & + 0.40074E-02, 0.64324E-02, 0.88617E-02, 0.11295E-01, 0.13731E-01, & + 0.15915E-01, 0.18387E-01, 0.20858E-01, 0.23329E-01, 0.25799E-01, & + 0.28268E-01, 0.30736E-01, 0.33203E-01, 0.35669E-01, 0.38134E-01, & + 0.40598E-01, 0.43060E-01, 0.45521E-01, 0.47981E-01, 0.50440E-01, & + 0.52896E-01, 0.55352E-01, 0.57806E-01, 0.60258E-01, 0.62708E-01, & + 0.65157E-01, 0.67604E-01, 0.70049E-01, 0.72492E-01, 0.74934E-01, & + 0.77373E-01, 0.79810E-01, 0.82246E-01, 0.84679E-01, 0.87110E-01, & + 0.89539E-01, 0.91966E-01, 0.94390E-01, 0.96812E-01, 0.99232E-01, & + 0.10165E+00, 0.10407E+00, 0.10648E+00, 0.10889E+00, 0.11130E+00, & + 0.11370E+00, 0.11611E+00, 0.11851E+00, 0.12090E+00, 0.12330E+00, & + 0.12569E+00, 0.12808E+00, 0.13047E+00, 0.13285E+00, 0.13524E+00, & + 0.13762E+00, 0.13999E+00, 0.14237E+00, 0.14474E+00, 0.14711E+00, & + 0.14947E+00, 0.15183E+00, 0.15419E+00, 0.15655E+00, 0.15891E+00, & + 0.16126E+00, 0.16361E+00, 0.16595E+00, 0.16829E+00, 0.17063E+00, & + 0.17297E+00, 0.17530E+00, 0.17764E+00, 0.17996E+00, 0.18229E+00, & + 0.18461E+00, 0.18693E+00, 0.18924E+00, 0.19156E+00, 0.19387E+00, & + 0.19617E+00, 0.19848E+00, 0.20078E+00, 0.20308E+00, 0.20537E+00/ + + DATA (BNC10M (I),I=201,300)/ & + 0.20766E+00, 0.20995E+00, 0.21223E+00, 0.21452E+00, 0.21680E+00, & + 0.21907E+00, 0.22134E+00, 0.22361E+00, 0.22588E+00, 0.22814E+00, & + 0.23040E+00, 0.23266E+00, 0.23491E+00, 0.23717E+00, 0.23941E+00, & + 0.24166E+00, 0.24390E+00, 0.24614E+00, 0.24837E+00, 0.25060E+00, & + 0.25283E+00, 0.25506E+00, 0.25728E+00, 0.25950E+00, 0.26171E+00, & + 0.26393E+00, 0.26614E+00, 0.26834E+00, 0.27054E+00, 0.27274E+00, & + 0.27494E+00, 0.27713E+00, 0.27933E+00, 0.28151E+00, 0.28370E+00, & + 0.28588E+00, 0.28805E+00, 0.29023E+00, 0.29240E+00, 0.29457E+00, & + 0.29673E+00, 0.29890E+00, 0.30105E+00, 0.30321E+00, 0.30536E+00, & + 0.30751E+00, 0.30966E+00, 0.31180E+00, 0.31394E+00, 0.31607E+00, & + 0.31821E+00, 0.32034E+00, 0.32247E+00, 0.32459E+00, 0.32671E+00, & + 0.32883E+00, 0.33094E+00, 0.33305E+00, 0.33516E+00, 0.33727E+00, & + 0.33937E+00, 0.34147E+00, 0.34356E+00, 0.34565E+00, 0.34774E+00, & + 0.34983E+00, 0.35191E+00, 0.35399E+00, 0.35607E+00, 0.35814E+00, & + 0.36021E+00, 0.36228E+00, 0.36435E+00, 0.36641E+00, 0.36847E+00, & + 0.37052E+00, 0.37257E+00, 0.37462E+00, 0.37667E+00, 0.37871E+00, & + 0.38075E+00, 0.38279E+00, 0.38482E+00, 0.38685E+00, 0.38888E+00, & + 0.39091E+00, 0.39293E+00, 0.39495E+00, 0.39696E+00, 0.39898E+00, & + 0.40099E+00, 0.40299E+00, 0.40500E+00, 0.40700E+00, 0.40899E+00, & + 0.41099E+00, 0.41298E+00, 0.41497E+00, 0.41696E+00, 0.41894E+00/ + + DATA (BNC10M (I),I=301,400)/ & + 0.42092E+00, 0.42290E+00, 0.42487E+00, 0.42684E+00, 0.42881E+00, & + 0.43077E+00, 0.43274E+00, 0.43470E+00, 0.43665E+00, 0.43861E+00, & + 0.44056E+00, 0.44251E+00, 0.44445E+00, 0.44639E+00, 0.44833E+00, & + 0.45027E+00, 0.45220E+00, 0.45413E+00, 0.45606E+00, 0.45798E+00, & + 0.45991E+00, 0.46183E+00, 0.46374E+00, 0.46566E+00, 0.46757E+00, & + 0.46947E+00, 0.47138E+00, 0.47328E+00, 0.47518E+00, 0.47708E+00, & + 0.47897E+00, 0.48086E+00, 0.48275E+00, 0.48464E+00, 0.48652E+00, & + 0.48840E+00, 0.49028E+00, 0.49215E+00, 0.49402E+00, 0.49589E+00, & + 0.49776E+00, 0.49962E+00, 0.50148E+00, 0.50334E+00, 0.50520E+00, & + 0.50705E+00, 0.50890E+00, 0.51075E+00, 0.51259E+00, 0.51443E+00, & + 0.51627E+00, 0.51811E+00, 0.51994E+00, 0.52178E+00, 0.52360E+00, & + 0.52543E+00, 0.52725E+00, 0.52907E+00, 0.53089E+00, 0.53271E+00, & + 0.53452E+00, 0.53633E+00, 0.53814E+00, 0.53994E+00, 0.54175E+00, & + 0.54355E+00, 0.54534E+00, 0.54714E+00, 0.54893E+00, 0.55072E+00, & + 0.55251E+00, 0.55429E+00, 0.55607E+00, 0.55785E+00, 0.55963E+00, & + 0.56140E+00, 0.56318E+00, 0.56495E+00, 0.56671E+00, 0.56848E+00, & + 0.57024E+00, 0.57200E+00, 0.57375E+00, 0.57551E+00, 0.57726E+00, & + 0.57901E+00, 0.58076E+00, 0.58250E+00, 0.58424E+00, 0.58598E+00, & + 0.58772E+00, 0.58945E+00, 0.59119E+00, 0.59292E+00, 0.59464E+00, & + 0.59637E+00, 0.59809E+00, 0.59981E+00, 0.60153E+00, 0.60324E+00/ + + DATA (BNC10M (I),I=401,500)/ & + 0.60496E+00, 0.60667E+00, 0.60838E+00, 0.61008E+00, 0.61178E+00, & + 0.61349E+00, 0.61518E+00, 0.61688E+00, 0.61857E+00, 0.62027E+00, & + 0.62196E+00, 0.62364E+00, 0.62533E+00, 0.62701E+00, 0.62869E+00, & + 0.63037E+00, 0.63204E+00, 0.63372E+00, 0.63539E+00, 0.63705E+00, & + 0.63872E+00, 0.64039E+00, 0.64205E+00, 0.64371E+00, 0.64536E+00, & + 0.64702E+00, 0.64867E+00, 0.65032E+00, 0.65197E+00, 0.65362E+00, & + 0.65526E+00, 0.65690E+00, 0.65854E+00, 0.66018E+00, 0.66181E+00, & + 0.66344E+00, 0.66507E+00, 0.66670E+00, 0.66833E+00, 0.66995E+00, & + 0.67157E+00, 0.67319E+00, 0.67481E+00, 0.67643E+00, 0.67804E+00, & + 0.67965E+00, 0.68126E+00, 0.68286E+00, 0.68447E+00, 0.68607E+00, & + 0.68767E+00, 0.68927E+00, 0.69086E+00, 0.69246E+00, 0.69405E+00, & + 0.69564E+00, 0.69723E+00, 0.69881E+00, 0.70040E+00, 0.70198E+00, & + 0.70356E+00, 0.70513E+00, 0.70671E+00, 0.70828E+00, 0.70985E+00, & + 0.71142E+00, 0.71299E+00, 0.71455E+00, 0.71611E+00, 0.71767E+00, & + 0.71923E+00, 0.72079E+00, 0.72234E+00, 0.72390E+00, 0.72545E+00, & + 0.72699E+00, 0.72854E+00, 0.73008E+00, 0.73163E+00, 0.73317E+00, & + 0.73471E+00, 0.73624E+00, 0.73778E+00, 0.73931E+00, 0.74084E+00, & + 0.74237E+00, 0.74389E+00, 0.74542E+00, 0.74694E+00, 0.74846E+00, & + 0.74998E+00, 0.75150E+00, 0.75301E+00, 0.75453E+00, 0.75604E+00, & + 0.75755E+00, 0.75905E+00, 0.76056E+00, 0.76206E+00, 0.76356E+00/ + + DATA (BNC10M (I),I=501,600)/ & + 0.76506E+00, 0.76656E+00, 0.76806E+00, 0.76955E+00, 0.77104E+00, & + 0.77253E+00, 0.77402E+00, 0.77551E+00, 0.77699E+00, 0.77847E+00, & + 0.77995E+00, 0.78143E+00, 0.78291E+00, 0.78439E+00, 0.78586E+00, & + 0.78733E+00, 0.78880E+00, 0.79027E+00, 0.79173E+00, 0.79320E+00, & + 0.79466E+00, 0.79612E+00, 0.79758E+00, 0.79904E+00, 0.80049E+00, & + 0.80195E+00, 0.80340E+00, 0.80485E+00, 0.80630E+00, 0.80774E+00, & + 0.80919E+00, 0.81063E+00, 0.81207E+00, 0.81351E+00, 0.81495E+00, & + 0.81638E+00, 0.81782E+00, 0.81925E+00, 0.82068E+00, 0.82211E+00, & + 0.82353E+00, 0.82496E+00, 0.82638E+00, 0.82780E+00, 0.82923E+00, & + 0.83064E+00, 0.83206E+00, 0.83347E+00, 0.83489E+00, 0.83630E+00, & + 0.83771E+00, 0.83912E+00, 0.84052E+00, 0.84193E+00, 0.84333E+00, & + 0.84473E+00, 0.84613E+00, 0.84753E+00, 0.84893E+00, 0.85032E+00, & + 0.85171E+00, 0.85311E+00, 0.85450E+00, 0.85588E+00, 0.85727E+00, & + 0.85866E+00, 0.86004E+00, 0.86142E+00, 0.86280E+00, 0.86418E+00, & + 0.86555E+00, 0.86693E+00, 0.86830E+00, 0.86968E+00, 0.87105E+00, & + 0.87241E+00, 0.87378E+00, 0.87515E+00, 0.87651E+00, 0.87787E+00, & + 0.87923E+00, 0.88059E+00, 0.88195E+00, 0.88330E+00, 0.88466E+00, & + 0.88601E+00, 0.88736E+00, 0.88871E+00, 0.89006E+00, 0.89141E+00, & + 0.89275E+00, 0.89410E+00, 0.89544E+00, 0.89678E+00, 0.89812E+00, & + 0.89945E+00, 0.90079E+00, 0.90212E+00, 0.90346E+00, 0.90844E+00/ + + DATA (BNC10M (I),I=601,700)/ & + 0.91933E+00, 0.93239E+00, 0.94531E+00, 0.95808E+00, 0.97072E+00, & + 0.98322E+00, 0.99558E+00, 0.10078E+01, 0.10199E+01, 0.10319E+01, & + 0.10438E+01, 0.10555E+01, 0.10671E+01, 0.10786E+01, 0.10900E+01, & + 0.11013E+01, 0.11124E+01, 0.11235E+01, 0.11344E+01, 0.11453E+01, & + 0.11560E+01, 0.11666E+01, 0.11772E+01, 0.11876E+01, 0.11980E+01, & + 0.12082E+01, 0.12184E+01, 0.12285E+01, 0.12385E+01, 0.12484E+01, & + 0.12582E+01, 0.12679E+01, 0.12776E+01, 0.12871E+01, 0.12966E+01, & + 0.13060E+01, 0.13154E+01, 0.13246E+01, 0.13338E+01, 0.13429E+01, & + 0.13519E+01, 0.13609E+01, 0.13698E+01, 0.13786E+01, 0.13874E+01, & + 0.13960E+01, 0.14047E+01, 0.14132E+01, 0.14217E+01, 0.14301E+01, & + 0.14385E+01, 0.14468E+01, 0.14550E+01, 0.14632E+01, 0.14713E+01, & + 0.14794E+01, 0.14874E+01, 0.14954E+01, 0.15033E+01, 0.15111E+01, & + 0.15189E+01, 0.15266E+01, 0.15343E+01, 0.15419E+01, 0.15495E+01, & + 0.15570E+01, 0.15645E+01, 0.15719E+01, 0.15793E+01, 0.15866E+01, & + 0.15939E+01, 0.16012E+01, 0.16084E+01, 0.16155E+01, 0.16226E+01, & + 0.16297E+01, 0.16367E+01, 0.16436E+01, 0.16506E+01, 0.16574E+01, & + 0.16643E+01, 0.16711E+01, 0.16778E+01, 0.16845E+01, 0.16912E+01, & + 0.16979E+01, 0.17045E+01, 0.17110E+01, 0.17175E+01, 0.17240E+01, & + 0.17305E+01, 0.17369E+01, 0.17433E+01, 0.17496E+01, 0.17559E+01, & + 0.17622E+01, 0.17684E+01, 0.17746E+01, 0.17808E+01, 0.17869E+01/ + + DATA (BNC10M(I),I=701,741)/ & + 0.17930E+01, 0.17991E+01, 0.18051E+01, 0.18111E+01, 0.18171E+01, & + 0.18230E+01, 0.18289E+01, 0.18348E+01, 0.18406E+01, 0.18464E+01, & + 0.18522E+01, 0.18580E+01, 0.18637E+01, 0.18694E+01, 0.18751E+01, & + 0.18807E+01, 0.18863E+01, 0.18919E+01, 0.18974E+01, 0.19030E+01, & + 0.19085E+01, 0.19139E+01, 0.19194E+01, 0.19248E+01, 0.19302E+01, & + 0.19356E+01, 0.19409E+01, 0.19462E+01, 0.19515E+01, 0.19568E+01, & + 0.19620E+01, 0.19672E+01, 0.19724E+01, 0.19776E+01, 0.19828E+01, & + 0.19879E+01, 0.19930E+01, 0.19981E+01, 0.20031E+01, 0.20081E+01, & + 0.20131E+01 & + / +! +! *** (H, Cl) +! + DATA (BNC11M (I),I= 1,100)/ & + -0.48532E-01,-0.83296E-01,-0.10417E+00,-0.11618E+00,-0.12392E+00, & + -0.12909E+00,-0.13252E+00,-0.13467E+00,-0.13584E+00,-0.13624E+00, & + -0.13600E+00,-0.13524E+00,-0.13402E+00,-0.13242E+00,-0.13047E+00, & + -0.12822E+00,-0.12570E+00,-0.12295E+00,-0.11997E+00,-0.11680E+00, & + -0.11344E+00,-0.10992E+00,-0.10625E+00,-0.10244E+00,-0.98493E-01, & + -0.94429E-01,-0.90252E-01,-0.85971E-01,-0.81593E-01,-0.77125E-01, & + -0.72571E-01,-0.67939E-01,-0.63234E-01,-0.58460E-01,-0.53621E-01, & + -0.48723E-01,-0.43768E-01,-0.38762E-01,-0.33706E-01,-0.28606E-01, & + -0.23462E-01,-0.18280E-01,-0.13061E-01,-0.78068E-02,-0.25211E-02, & + 0.27943E-02, 0.81376E-02, 0.13507E-01, 0.18900E-01, 0.24317E-01, & + 0.29754E-01, 0.35212E-01, 0.40689E-01, 0.46183E-01, 0.51695E-01, & + 0.57224E-01, 0.62769E-01, 0.68329E-01, 0.73904E-01, 0.79495E-01, & + 0.85100E-01, 0.90721E-01, 0.96357E-01, 0.10201E+00, 0.10768E+00, & + 0.11336E+00, 0.11906E+00, 0.12478E+00, 0.13051E+00, 0.13627E+00, & + 0.14204E+00, 0.14783E+00, 0.15365E+00, 0.15948E+00, 0.16534E+00, & + 0.17123E+00, 0.17713E+00, 0.18307E+00, 0.18902E+00, 0.19501E+00, & + 0.20102E+00, 0.20706E+00, 0.21313E+00, 0.21923E+00, 0.22536E+00, & + 0.23151E+00, 0.23770E+00, 0.24392E+00, 0.25017E+00, 0.25645E+00, & + 0.26276E+00, 0.26910E+00, 0.27546E+00, 0.28186E+00, 0.28829E+00, & + 0.29475E+00, 0.30123E+00, 0.30774E+00, 0.31428E+00, 0.32084E+00/ + + DATA (BNC11M (I),I=101,200)/ & + 0.32743E+00, 0.33404E+00, 0.34068E+00, 0.34734E+00, 0.35401E+00, & + 0.36071E+00, 0.36742E+00, 0.37415E+00, 0.38090E+00, 0.38766E+00, & + 0.39444E+00, 0.40123E+00, 0.40803E+00, 0.41484E+00, 0.42166E+00, & + 0.42848E+00, 0.43532E+00, 0.44216E+00, 0.44900E+00, 0.45585E+00, & + 0.46211E+00, 0.46904E+00, 0.47595E+00, 0.48286E+00, 0.48977E+00, & + 0.49667E+00, 0.50356E+00, 0.51044E+00, 0.51732E+00, 0.52419E+00, & + 0.53105E+00, 0.53791E+00, 0.54476E+00, 0.55160E+00, 0.55843E+00, & + 0.56525E+00, 0.57207E+00, 0.57887E+00, 0.58567E+00, 0.59246E+00, & + 0.59924E+00, 0.60601E+00, 0.61277E+00, 0.61952E+00, 0.62627E+00, & + 0.63300E+00, 0.63972E+00, 0.64643E+00, 0.65314E+00, 0.65983E+00, & + 0.66651E+00, 0.67319E+00, 0.67985E+00, 0.68650E+00, 0.69314E+00, & + 0.69977E+00, 0.70639E+00, 0.71300E+00, 0.71960E+00, 0.72618E+00, & + 0.73276E+00, 0.73933E+00, 0.74588E+00, 0.75242E+00, 0.75896E+00, & + 0.76548E+00, 0.77198E+00, 0.77848E+00, 0.78497E+00, 0.79144E+00, & + 0.79791E+00, 0.80436E+00, 0.81080E+00, 0.81723E+00, 0.82365E+00, & + 0.83005E+00, 0.83645E+00, 0.84283E+00, 0.84920E+00, 0.85556E+00, & + 0.86191E+00, 0.86824E+00, 0.87457E+00, 0.88088E+00, 0.88718E+00, & + 0.89347E+00, 0.89975E+00, 0.90601E+00, 0.91226E+00, 0.91851E+00, & + 0.92473E+00, 0.93095E+00, 0.93716E+00, 0.94335E+00, 0.94953E+00, & + 0.95570E+00, 0.96186E+00, 0.96801E+00, 0.97414E+00, 0.98027E+00/ + + DATA (BNC11M (I),I=201,300)/ & + 0.98638E+00, 0.99248E+00, 0.99857E+00, 0.10046E+01, 0.10107E+01, & + 0.10168E+01, 0.10228E+01, 0.10288E+01, 0.10348E+01, 0.10408E+01, & + 0.10468E+01, 0.10528E+01, 0.10588E+01, 0.10648E+01, 0.10707E+01, & + 0.10766E+01, 0.10826E+01, 0.10885E+01, 0.10944E+01, 0.11003E+01, & + 0.11061E+01, 0.11120E+01, 0.11179E+01, 0.11237E+01, 0.11295E+01, & + 0.11354E+01, 0.11412E+01, 0.11470E+01, 0.11527E+01, 0.11585E+01, & + 0.11643E+01, 0.11700E+01, 0.11758E+01, 0.11815E+01, 0.11872E+01, & + 0.11929E+01, 0.11986E+01, 0.12043E+01, 0.12100E+01, 0.12156E+01, & + 0.12213E+01, 0.12269E+01, 0.12326E+01, 0.12382E+01, 0.12438E+01, & + 0.12494E+01, 0.12550E+01, 0.12605E+01, 0.12661E+01, 0.12717E+01, & + 0.12772E+01, 0.12827E+01, 0.12883E+01, 0.12938E+01, 0.12993E+01, & + 0.13048E+01, 0.13102E+01, 0.13157E+01, 0.13212E+01, 0.13266E+01, & + 0.13320E+01, 0.13375E+01, 0.13429E+01, 0.13483E+01, 0.13537E+01, & + 0.13591E+01, 0.13644E+01, 0.13698E+01, 0.13752E+01, 0.13805E+01, & + 0.13858E+01, 0.13912E+01, 0.13965E+01, 0.14018E+01, 0.14071E+01, & + 0.14123E+01, 0.14176E+01, 0.14229E+01, 0.14281E+01, 0.14334E+01, & + 0.14386E+01, 0.14438E+01, 0.14490E+01, 0.14542E+01, 0.14594E+01, & + 0.14646E+01, 0.14698E+01, 0.14749E+01, 0.14801E+01, 0.14852E+01, & + 0.14904E+01, 0.14955E+01, 0.15006E+01, 0.15057E+01, 0.15108E+01, & + 0.15159E+01, 0.15210E+01, 0.15260E+01, 0.15311E+01, 0.15362E+01/ + + DATA (BNC11M (I),I=301,400)/ & + 0.15412E+01, 0.15462E+01, 0.15512E+01, 0.15563E+01, 0.15613E+01, & + 0.15663E+01, 0.15712E+01, 0.15762E+01, 0.15812E+01, 0.15861E+01, & + 0.15911E+01, 0.15960E+01, 0.16010E+01, 0.16059E+01, 0.16108E+01, & + 0.16157E+01, 0.16206E+01, 0.16255E+01, 0.16303E+01, 0.16352E+01, & + 0.16401E+01, 0.16449E+01, 0.16498E+01, 0.16546E+01, 0.16594E+01, & + 0.16642E+01, 0.16690E+01, 0.16738E+01, 0.16786E+01, 0.16834E+01, & + 0.16882E+01, 0.16930E+01, 0.16977E+01, 0.17025E+01, 0.17072E+01, & + 0.17119E+01, 0.17167E+01, 0.17214E+01, 0.17261E+01, 0.17308E+01, & + 0.17355E+01, 0.17401E+01, 0.17448E+01, 0.17495E+01, 0.17541E+01, & + 0.17588E+01, 0.17634E+01, 0.17681E+01, 0.17727E+01, 0.17773E+01, & + 0.17819E+01, 0.17865E+01, 0.17911E+01, 0.17957E+01, 0.18003E+01, & + 0.18048E+01, 0.18094E+01, 0.18139E+01, 0.18185E+01, 0.18230E+01, & + 0.18276E+01, 0.18321E+01, 0.18366E+01, 0.18411E+01, 0.18456E+01, & + 0.18501E+01, 0.18546E+01, 0.18591E+01, 0.18635E+01, 0.18680E+01, & + 0.18724E+01, 0.18769E+01, 0.18813E+01, 0.18858E+01, 0.18902E+01, & + 0.18946E+01, 0.18990E+01, 0.19034E+01, 0.19078E+01, 0.19122E+01, & + 0.19166E+01, 0.19210E+01, 0.19253E+01, 0.19297E+01, 0.19340E+01, & + 0.19384E+01, 0.19427E+01, 0.19471E+01, 0.19514E+01, 0.19557E+01, & + 0.19600E+01, 0.19643E+01, 0.19686E+01, 0.19729E+01, 0.19772E+01, & + 0.19814E+01, 0.19857E+01, 0.19900E+01, 0.19942E+01, 0.19985E+01/ + + DATA (BNC11M (I),I=401,500)/ & + 0.20027E+01, 0.20069E+01, 0.20112E+01, 0.20154E+01, 0.20196E+01, & + 0.20238E+01, 0.20280E+01, 0.20322E+01, 0.20364E+01, 0.20406E+01, & + 0.20447E+01, 0.20489E+01, 0.20531E+01, 0.20572E+01, 0.20614E+01, & + 0.20655E+01, 0.20697E+01, 0.20738E+01, 0.20779E+01, 0.20820E+01, & + 0.20861E+01, 0.20902E+01, 0.20943E+01, 0.20984E+01, 0.21025E+01, & + 0.21066E+01, 0.21106E+01, 0.21147E+01, 0.21188E+01, 0.21228E+01, & + 0.21269E+01, 0.21309E+01, 0.21349E+01, 0.21390E+01, 0.21430E+01, & + 0.21470E+01, 0.21510E+01, 0.21550E+01, 0.21590E+01, 0.21630E+01, & + 0.21670E+01, 0.21709E+01, 0.21749E+01, 0.21789E+01, 0.21828E+01, & + 0.21868E+01, 0.21907E+01, 0.21947E+01, 0.21986E+01, 0.22026E+01, & + 0.22065E+01, 0.22104E+01, 0.22143E+01, 0.22182E+01, 0.22221E+01, & + 0.22260E+01, 0.22299E+01, 0.22338E+01, 0.22377E+01, 0.22415E+01, & + 0.22454E+01, 0.22493E+01, 0.22531E+01, 0.22570E+01, 0.22608E+01, & + 0.22646E+01, 0.22685E+01, 0.22723E+01, 0.22761E+01, 0.22799E+01, & + 0.22838E+01, 0.22876E+01, 0.22914E+01, 0.22951E+01, 0.22989E+01, & + 0.23027E+01, 0.23065E+01, 0.23103E+01, 0.23140E+01, 0.23178E+01, & + 0.23215E+01, 0.23253E+01, 0.23290E+01, 0.23328E+01, 0.23365E+01, & + 0.23402E+01, 0.23440E+01, 0.23477E+01, 0.23514E+01, 0.23551E+01, & + 0.23588E+01, 0.23625E+01, 0.23662E+01, 0.23699E+01, 0.23736E+01, & + 0.23772E+01, 0.23809E+01, 0.23846E+01, 0.23882E+01, 0.23919E+01/ + + DATA (BNC11M (I),I=501,600)/ & + 0.23955E+01, 0.23992E+01, 0.24028E+01, 0.24065E+01, 0.24101E+01, & + 0.24137E+01, 0.24173E+01, 0.24210E+01, 0.24246E+01, 0.24282E+01, & + 0.24318E+01, 0.24354E+01, 0.24390E+01, 0.24425E+01, 0.24461E+01, & + 0.24497E+01, 0.24533E+01, 0.24568E+01, 0.24604E+01, 0.24640E+01, & + 0.24675E+01, 0.24711E+01, 0.24746E+01, 0.24781E+01, 0.24817E+01, & + 0.24852E+01, 0.24887E+01, 0.24922E+01, 0.24957E+01, 0.24993E+01, & + 0.25028E+01, 0.25063E+01, 0.25097E+01, 0.25132E+01, 0.25167E+01, & + 0.25202E+01, 0.25237E+01, 0.25272E+01, 0.25306E+01, 0.25341E+01, & + 0.25375E+01, 0.25410E+01, 0.25444E+01, 0.25479E+01, 0.25513E+01, & + 0.25548E+01, 0.25582E+01, 0.25616E+01, 0.25650E+01, 0.25684E+01, & + 0.25719E+01, 0.25753E+01, 0.25787E+01, 0.25821E+01, 0.25855E+01, & + 0.25889E+01, 0.25922E+01, 0.25956E+01, 0.25990E+01, 0.26024E+01, & + 0.26057E+01, 0.26091E+01, 0.26125E+01, 0.26158E+01, 0.26192E+01, & + 0.26225E+01, 0.26258E+01, 0.26292E+01, 0.26325E+01, 0.26358E+01, & + 0.26392E+01, 0.26425E+01, 0.26458E+01, 0.26491E+01, 0.26524E+01, & + 0.26557E+01, 0.26590E+01, 0.26623E+01, 0.26656E+01, 0.26689E+01, & + 0.26722E+01, 0.26755E+01, 0.26787E+01, 0.26820E+01, 0.26853E+01, & + 0.26885E+01, 0.26918E+01, 0.26951E+01, 0.26983E+01, 0.27016E+01, & + 0.27048E+01, 0.27080E+01, 0.27113E+01, 0.27145E+01, 0.27177E+01, & + 0.27209E+01, 0.27242E+01, 0.27274E+01, 0.27306E+01, 0.27426E+01/ + + DATA (BNC11M (I),I=601,700)/ & + 0.27688E+01, 0.28002E+01, 0.28313E+01, 0.28620E+01, 0.28923E+01, & + 0.29223E+01, 0.29519E+01, 0.29812E+01, 0.30102E+01, 0.30388E+01, & + 0.30672E+01, 0.30952E+01, 0.31229E+01, 0.31504E+01, 0.31775E+01, & + 0.32044E+01, 0.32310E+01, 0.32573E+01, 0.32834E+01, 0.33092E+01, & + 0.33347E+01, 0.33601E+01, 0.33851E+01, 0.34099E+01, 0.34345E+01, & + 0.34589E+01, 0.34830E+01, 0.35069E+01, 0.35306E+01, 0.35541E+01, & + 0.35773E+01, 0.36004E+01, 0.36232E+01, 0.36459E+01, 0.36683E+01, & + 0.36906E+01, 0.37127E+01, 0.37346E+01, 0.37563E+01, 0.37778E+01, & + 0.37992E+01, 0.38203E+01, 0.38413E+01, 0.38622E+01, 0.38828E+01, & + 0.39033E+01, 0.39237E+01, 0.39439E+01, 0.39639E+01, 0.39838E+01, & + 0.40035E+01, 0.40231E+01, 0.40425E+01, 0.40618E+01, 0.40809E+01, & + 0.40999E+01, 0.41188E+01, 0.41375E+01, 0.41561E+01, 0.41746E+01, & + 0.41929E+01, 0.42111E+01, 0.42292E+01, 0.42472E+01, 0.42650E+01, & + 0.42827E+01, 0.43003E+01, 0.43177E+01, 0.43351E+01, 0.43523E+01, & + 0.43695E+01, 0.43865E+01, 0.44034E+01, 0.44202E+01, 0.44368E+01, & + 0.44534E+01, 0.44699E+01, 0.44862E+01, 0.45025E+01, 0.45187E+01, & + 0.45347E+01, 0.45507E+01, 0.45666E+01, 0.45823E+01, 0.45980E+01, & + 0.46136E+01, 0.46291E+01, 0.46445E+01, 0.46598E+01, 0.46750E+01, & + 0.46901E+01, 0.47051E+01, 0.47201E+01, 0.47350E+01, 0.47497E+01, & + 0.47644E+01, 0.47791E+01, 0.47936E+01, 0.48080E+01, 0.48224E+01/ + + DATA (BNC11M(I),I=701,741)/ & + 0.48367E+01, 0.48509E+01, 0.48651E+01, 0.48791E+01, 0.48931E+01, & + 0.49070E+01, 0.49208E+01, 0.49346E+01, 0.49483E+01, 0.49619E+01, & + 0.49755E+01, 0.49889E+01, 0.50023E+01, 0.50157E+01, 0.50290E+01, & + 0.50422E+01, 0.50553E+01, 0.50684E+01, 0.50814E+01, 0.50943E+01, & + 0.51072E+01, 0.51200E+01, 0.51327E+01, 0.51454E+01, 0.51580E+01, & + 0.51706E+01, 0.51831E+01, 0.51956E+01, 0.52079E+01, 0.52203E+01, & + 0.52325E+01, 0.52447E+01, 0.52569E+01, 0.52690E+01, 0.52810E+01, & + 0.52930E+01, 0.53049E+01, 0.53168E+01, 0.53286E+01, 0.53404E+01, & + 0.53521E+01 & + / +! +! *** NaHSO4 +! + DATA (BNC12M (I),I= 1,100)/ & + -0.49644E-01,-0.87391E-01,-0.11193E+00,-0.12742E+00,-0.13854E+00, & + -0.14701E+00,-0.15369E+00,-0.15906E+00,-0.16342E+00,-0.16698E+00, & + -0.16989E+00,-0.17226E+00,-0.17416E+00,-0.17565E+00,-0.17680E+00, & + -0.17763E+00,-0.17818E+00,-0.17848E+00,-0.17855E+00,-0.17840E+00, & + -0.17807E+00,-0.17755E+00,-0.17687E+00,-0.17603E+00,-0.17505E+00, & + -0.17393E+00,-0.17268E+00,-0.17131E+00,-0.16982E+00,-0.16823E+00, & + -0.16653E+00,-0.16473E+00,-0.16284E+00,-0.16086E+00,-0.15879E+00, & + -0.15664E+00,-0.15441E+00,-0.15211E+00,-0.14974E+00,-0.14729E+00, & + -0.14479E+00,-0.14222E+00,-0.13959E+00,-0.13690E+00,-0.13415E+00, & + -0.13136E+00,-0.12851E+00,-0.12561E+00,-0.12267E+00,-0.11968E+00, & + -0.11665E+00,-0.11358E+00,-0.11046E+00,-0.10731E+00,-0.10412E+00, & + -0.10089E+00,-0.97629E-01,-0.94332E-01,-0.91002E-01,-0.87640E-01, & + -0.84246E-01,-0.80821E-01,-0.77366E-01,-0.73882E-01,-0.70367E-01, & + -0.66825E-01,-0.63253E-01,-0.59653E-01,-0.56026E-01,-0.52370E-01, & + -0.48687E-01,-0.44975E-01,-0.41237E-01,-0.37470E-01,-0.33676E-01, & + -0.29854E-01,-0.26004E-01,-0.22127E-01,-0.18221E-01,-0.14288E-01, & + -0.10326E-01,-0.63369E-02,-0.23194E-02, 0.17259E-02, 0.57993E-02, & + 0.99002E-02, 0.14029E-01, 0.18185E-01, 0.22368E-01, 0.26578E-01, & + 0.30815E-01, 0.35078E-01, 0.39366E-01, 0.43679E-01, 0.48017E-01, & + 0.52379E-01, 0.56764E-01, 0.61172E-01, 0.65602E-01, 0.70053E-01/ + + DATA (BNC12M (I),I=101,200)/ & + 0.74523E-01, 0.79013E-01, 0.83522E-01, 0.88048E-01, 0.92591E-01, & + 0.97150E-01, 0.10172E+00, 0.10631E+00, 0.11091E+00, 0.11552E+00, & + 0.12014E+00, 0.12478E+00, 0.12942E+00, 0.13407E+00, 0.13872E+00, & + 0.14339E+00, 0.14806E+00, 0.15273E+00, 0.15741E+00, 0.16209E+00, & + 0.16635E+00, 0.17109E+00, 0.17581E+00, 0.18054E+00, 0.18526E+00, & + 0.18997E+00, 0.19469E+00, 0.19939E+00, 0.20409E+00, 0.20879E+00, & + 0.21348E+00, 0.21816E+00, 0.22284E+00, 0.22751E+00, 0.23218E+00, & + 0.23684E+00, 0.24149E+00, 0.24614E+00, 0.25078E+00, 0.25542E+00, & + 0.26004E+00, 0.26466E+00, 0.26927E+00, 0.27388E+00, 0.27848E+00, & + 0.28307E+00, 0.28765E+00, 0.29223E+00, 0.29680E+00, 0.30136E+00, & + 0.30591E+00, 0.31045E+00, 0.31499E+00, 0.31952E+00, 0.32404E+00, & + 0.32855E+00, 0.33306E+00, 0.33755E+00, 0.34204E+00, 0.34652E+00, & + 0.35099E+00, 0.35545E+00, 0.35991E+00, 0.36436E+00, 0.36879E+00, & + 0.37322E+00, 0.37764E+00, 0.38206E+00, 0.38646E+00, 0.39086E+00, & + 0.39524E+00, 0.39962E+00, 0.40399E+00, 0.40836E+00, 0.41271E+00, & + 0.41705E+00, 0.42139E+00, 0.42572E+00, 0.43003E+00, 0.43435E+00, & + 0.43865E+00, 0.44294E+00, 0.44722E+00, 0.45150E+00, 0.45577E+00, & + 0.46003E+00, 0.46428E+00, 0.46852E+00, 0.47275E+00, 0.47698E+00, & + 0.48119E+00, 0.48540E+00, 0.48960E+00, 0.49379E+00, 0.49797E+00, & + 0.50215E+00, 0.50631E+00, 0.51047E+00, 0.51462E+00, 0.51876E+00/ + + DATA (BNC12M (I),I=201,300)/ & + 0.52289E+00, 0.52702E+00, 0.53113E+00, 0.53524E+00, 0.53934E+00, & + 0.54343E+00, 0.54751E+00, 0.55158E+00, 0.55565E+00, 0.55971E+00, & + 0.56376E+00, 0.56780E+00, 0.57183E+00, 0.57586E+00, 0.57987E+00, & + 0.58388E+00, 0.58788E+00, 0.59187E+00, 0.59586E+00, 0.59984E+00, & + 0.60381E+00, 0.60777E+00, 0.61172E+00, 0.61566E+00, 0.61960E+00, & + 0.62353E+00, 0.62745E+00, 0.63137E+00, 0.63527E+00, 0.63917E+00, & + 0.64306E+00, 0.64695E+00, 0.65082E+00, 0.65469E+00, 0.65855E+00, & + 0.66240E+00, 0.66625E+00, 0.67008E+00, 0.67391E+00, 0.67774E+00, & + 0.68155E+00, 0.68536E+00, 0.68916E+00, 0.69295E+00, 0.69674E+00, & + 0.70051E+00, 0.70428E+00, 0.70805E+00, 0.71180E+00, 0.71555E+00, & + 0.71929E+00, 0.72303E+00, 0.72676E+00, 0.73048E+00, 0.73419E+00, & + 0.73789E+00, 0.74159E+00, 0.74528E+00, 0.74897E+00, 0.75265E+00, & + 0.75632E+00, 0.75998E+00, 0.76364E+00, 0.76729E+00, 0.77093E+00, & + 0.77457E+00, 0.77819E+00, 0.78182E+00, 0.78543E+00, 0.78904E+00, & + 0.79264E+00, 0.79624E+00, 0.79983E+00, 0.80341E+00, 0.80698E+00, & + 0.81055E+00, 0.81411E+00, 0.81767E+00, 0.82122E+00, 0.82476E+00, & + 0.82830E+00, 0.83183E+00, 0.83535E+00, 0.83886E+00, 0.84237E+00, & + 0.84588E+00, 0.84938E+00, 0.85287E+00, 0.85635E+00, 0.85983E+00, & + 0.86330E+00, 0.86676E+00, 0.87022E+00, 0.87368E+00, 0.87712E+00, & + 0.88056E+00, 0.88400E+00, 0.88743E+00, 0.89085E+00, 0.89426E+00/ + + DATA (BNC12M (I),I=301,400)/ & + 0.89767E+00, 0.90108E+00, 0.90447E+00, 0.90787E+00, 0.91125E+00, & + 0.91463E+00, 0.91801E+00, 0.92137E+00, 0.92473E+00, 0.92809E+00, & + 0.93144E+00, 0.93478E+00, 0.93812E+00, 0.94145E+00, 0.94478E+00, & + 0.94810E+00, 0.95142E+00, 0.95473E+00, 0.95803E+00, 0.96133E+00, & + 0.96462E+00, 0.96791E+00, 0.97119E+00, 0.97446E+00, 0.97773E+00, & + 0.98099E+00, 0.98425E+00, 0.98750E+00, 0.99075E+00, 0.99399E+00, & + 0.99723E+00, 0.10005E+01, 0.10037E+01, 0.10069E+01, 0.10101E+01, & + 0.10133E+01, 0.10165E+01, 0.10197E+01, 0.10229E+01, 0.10261E+01, & + 0.10293E+01, 0.10325E+01, 0.10356E+01, 0.10388E+01, 0.10420E+01, & + 0.10451E+01, 0.10483E+01, 0.10514E+01, 0.10546E+01, 0.10577E+01, & + 0.10608E+01, 0.10639E+01, 0.10671E+01, 0.10702E+01, 0.10733E+01, & + 0.10764E+01, 0.10795E+01, 0.10826E+01, 0.10857E+01, 0.10888E+01, & + 0.10918E+01, 0.10949E+01, 0.10980E+01, 0.11010E+01, 0.11041E+01, & + 0.11071E+01, 0.11102E+01, 0.11132E+01, 0.11163E+01, 0.11193E+01, & + 0.11223E+01, 0.11254E+01, 0.11284E+01, 0.11314E+01, 0.11344E+01, & + 0.11374E+01, 0.11404E+01, 0.11434E+01, 0.11464E+01, 0.11494E+01, & + 0.11524E+01, 0.11553E+01, 0.11583E+01, 0.11613E+01, 0.11642E+01, & + 0.11672E+01, 0.11702E+01, 0.11731E+01, 0.11761E+01, 0.11790E+01, & + 0.11819E+01, 0.11849E+01, 0.11878E+01, 0.11907E+01, 0.11936E+01, & + 0.11965E+01, 0.11994E+01, 0.12023E+01, 0.12052E+01, 0.12081E+01/ + + DATA (BNC12M (I),I=401,500)/ & + 0.12110E+01, 0.12139E+01, 0.12168E+01, 0.12197E+01, 0.12225E+01, & + 0.12254E+01, 0.12283E+01, 0.12311E+01, 0.12340E+01, 0.12368E+01, & + 0.12397E+01, 0.12425E+01, 0.12454E+01, 0.12482E+01, 0.12510E+01, & + 0.12539E+01, 0.12567E+01, 0.12595E+01, 0.12623E+01, 0.12651E+01, & + 0.12679E+01, 0.12707E+01, 0.12735E+01, 0.12763E+01, 0.12791E+01, & + 0.12819E+01, 0.12847E+01, 0.12874E+01, 0.12902E+01, 0.12930E+01, & + 0.12957E+01, 0.12985E+01, 0.13013E+01, 0.13040E+01, 0.13068E+01, & + 0.13095E+01, 0.13122E+01, 0.13150E+01, 0.13177E+01, 0.13204E+01, & + 0.13231E+01, 0.13259E+01, 0.13286E+01, 0.13313E+01, 0.13340E+01, & + 0.13367E+01, 0.13394E+01, 0.13421E+01, 0.13448E+01, 0.13475E+01, & + 0.13502E+01, 0.13528E+01, 0.13555E+01, 0.13582E+01, 0.13609E+01, & + 0.13635E+01, 0.13662E+01, 0.13688E+01, 0.13715E+01, 0.13741E+01, & + 0.13768E+01, 0.13794E+01, 0.13821E+01, 0.13847E+01, 0.13873E+01, & + 0.13900E+01, 0.13926E+01, 0.13952E+01, 0.13978E+01, 0.14004E+01, & + 0.14031E+01, 0.14057E+01, 0.14083E+01, 0.14109E+01, 0.14135E+01, & + 0.14160E+01, 0.14186E+01, 0.14212E+01, 0.14238E+01, 0.14264E+01, & + 0.14290E+01, 0.14315E+01, 0.14341E+01, 0.14367E+01, 0.14392E+01, & + 0.14418E+01, 0.14443E+01, 0.14469E+01, 0.14494E+01, 0.14520E+01, & + 0.14545E+01, 0.14570E+01, 0.14596E+01, 0.14621E+01, 0.14646E+01, & + 0.14671E+01, 0.14697E+01, 0.14722E+01, 0.14747E+01, 0.14772E+01/ + + DATA (BNC12M (I),I=501,600)/ & + 0.14797E+01, 0.14822E+01, 0.14847E+01, 0.14872E+01, 0.14897E+01, & + 0.14922E+01, 0.14947E+01, 0.14971E+01, 0.14996E+01, 0.15021E+01, & + 0.15046E+01, 0.15070E+01, 0.15095E+01, 0.15120E+01, 0.15144E+01, & + 0.15169E+01, 0.15193E+01, 0.15218E+01, 0.15242E+01, 0.15267E+01, & + 0.15291E+01, 0.15315E+01, 0.15340E+01, 0.15364E+01, 0.15388E+01, & + 0.15413E+01, 0.15437E+01, 0.15461E+01, 0.15485E+01, 0.15509E+01, & + 0.15533E+01, 0.15557E+01, 0.15581E+01, 0.15605E+01, 0.15629E+01, & + 0.15653E+01, 0.15677E+01, 0.15701E+01, 0.15725E+01, 0.15749E+01, & + 0.15772E+01, 0.15796E+01, 0.15820E+01, 0.15843E+01, 0.15867E+01, & + 0.15891E+01, 0.15914E+01, 0.15938E+01, 0.15961E+01, 0.15985E+01, & + 0.16008E+01, 0.16032E+01, 0.16055E+01, 0.16079E+01, 0.16102E+01, & + 0.16125E+01, 0.16149E+01, 0.16172E+01, 0.16195E+01, 0.16218E+01, & + 0.16242E+01, 0.16265E+01, 0.16288E+01, 0.16311E+01, 0.16334E+01, & + 0.16357E+01, 0.16380E+01, 0.16403E+01, 0.16426E+01, 0.16449E+01, & + 0.16472E+01, 0.16495E+01, 0.16518E+01, 0.16540E+01, 0.16563E+01, & + 0.16586E+01, 0.16609E+01, 0.16631E+01, 0.16654E+01, 0.16677E+01, & + 0.16699E+01, 0.16722E+01, 0.16744E+01, 0.16767E+01, 0.16790E+01, & + 0.16812E+01, 0.16834E+01, 0.16857E+01, 0.16879E+01, 0.16902E+01, & + 0.16924E+01, 0.16946E+01, 0.16969E+01, 0.16991E+01, 0.17013E+01, & + 0.17035E+01, 0.17058E+01, 0.17080E+01, 0.17102E+01, 0.17185E+01/ + + DATA (BNC12M (I),I=601,700)/ & + 0.17365E+01, 0.17582E+01, 0.17797E+01, 0.18009E+01, 0.18218E+01, & + 0.18425E+01, 0.18630E+01, 0.18833E+01, 0.19033E+01, 0.19232E+01, & + 0.19428E+01, 0.19622E+01, 0.19814E+01, 0.20004E+01, 0.20193E+01, & + 0.20379E+01, 0.20563E+01, 0.20746E+01, 0.20927E+01, 0.21106E+01, & + 0.21283E+01, 0.21459E+01, 0.21633E+01, 0.21806E+01, 0.21976E+01, & + 0.22146E+01, 0.22313E+01, 0.22480E+01, 0.22644E+01, 0.22808E+01, & + 0.22969E+01, 0.23130E+01, 0.23289E+01, 0.23447E+01, 0.23603E+01, & + 0.23758E+01, 0.23912E+01, 0.24064E+01, 0.24215E+01, 0.24365E+01, & + 0.24514E+01, 0.24662E+01, 0.24808E+01, 0.24953E+01, 0.25097E+01, & + 0.25240E+01, 0.25382E+01, 0.25523E+01, 0.25663E+01, 0.25802E+01, & + 0.25939E+01, 0.26076E+01, 0.26211E+01, 0.26346E+01, 0.26480E+01, & + 0.26612E+01, 0.26744E+01, 0.26875E+01, 0.27005E+01, 0.27133E+01, & + 0.27262E+01, 0.27389E+01, 0.27515E+01, 0.27640E+01, 0.27765E+01, & + 0.27889E+01, 0.28012E+01, 0.28134E+01, 0.28255E+01, 0.28375E+01, & + 0.28495E+01, 0.28614E+01, 0.28732E+01, 0.28849E+01, 0.28966E+01, & + 0.29082E+01, 0.29197E+01, 0.29312E+01, 0.29425E+01, 0.29538E+01, & + 0.29651E+01, 0.29762E+01, 0.29873E+01, 0.29984E+01, 0.30093E+01, & + 0.30202E+01, 0.30311E+01, 0.30419E+01, 0.30526E+01, 0.30632E+01, & + 0.30738E+01, 0.30843E+01, 0.30948E+01, 0.31052E+01, 0.31155E+01, & + 0.31258E+01, 0.31361E+01, 0.31462E+01, 0.31564E+01, 0.31664E+01/ + + DATA (BNC12M(I),I=701,741)/ & + 0.31764E+01, 0.31864E+01, 0.31963E+01, 0.32061E+01, 0.32159E+01, & + 0.32257E+01, 0.32354E+01, 0.32450E+01, 0.32546E+01, 0.32641E+01, & + 0.32736E+01, 0.32831E+01, 0.32924E+01, 0.33018E+01, 0.33111E+01, & + 0.33203E+01, 0.33295E+01, 0.33387E+01, 0.33478E+01, 0.33569E+01, & + 0.33659E+01, 0.33749E+01, 0.33838E+01, 0.33927E+01, 0.34016E+01, & + 0.34104E+01, 0.34191E+01, 0.34278E+01, 0.34365E+01, 0.34452E+01, & + 0.34538E+01, 0.34623E+01, 0.34708E+01, 0.34793E+01, 0.34878E+01, & + 0.34962E+01, 0.35045E+01, 0.35128E+01, 0.35211E+01, 0.35294E+01, & + 0.35376E+01 & + / +! +! *** (NH4)3H(SO4)2 +! + DATA (BNC13M (I),I= 1,100)/ & + -0.82022E-01,-0.14892E+00,-0.19572E+00,-0.22741E+00,-0.25173E+00, & + -0.27155E+00,-0.28831E+00,-0.30283E+00,-0.31565E+00,-0.32710E+00, & + -0.33746E+00,-0.34689E+00,-0.35555E+00,-0.36355E+00,-0.37096E+00, & + -0.37786E+00,-0.38431E+00,-0.39036E+00,-0.39605E+00,-0.40141E+00, & + -0.40647E+00,-0.41126E+00,-0.41580E+00,-0.42010E+00,-0.42419E+00, & + -0.42808E+00,-0.43179E+00,-0.43532E+00,-0.43868E+00,-0.44190E+00, & + -0.44496E+00,-0.44790E+00,-0.45070E+00,-0.45338E+00,-0.45594E+00, & + -0.45839E+00,-0.46074E+00,-0.46298E+00,-0.46513E+00,-0.46719E+00, & + -0.46916E+00,-0.47105E+00,-0.47285E+00,-0.47458E+00,-0.47624E+00, & + -0.47782E+00,-0.47934E+00,-0.48079E+00,-0.48217E+00,-0.48350E+00, & + -0.48477E+00,-0.48598E+00,-0.48713E+00,-0.48824E+00,-0.48929E+00, & + -0.49030E+00,-0.49125E+00,-0.49217E+00,-0.49304E+00,-0.49386E+00, & + -0.49465E+00,-0.49539E+00,-0.49610E+00,-0.49677E+00,-0.49740E+00, & + -0.49800E+00,-0.49856E+00,-0.49910E+00,-0.49960E+00,-0.50006E+00, & + -0.50050E+00,-0.50091E+00,-0.50129E+00,-0.50164E+00,-0.50197E+00, & + -0.50227E+00,-0.50254E+00,-0.50279E+00,-0.50301E+00,-0.50321E+00, & + -0.50338E+00,-0.50353E+00,-0.50366E+00,-0.50377E+00,-0.50386E+00, & + -0.50392E+00,-0.50396E+00,-0.50399E+00,-0.50399E+00,-0.50398E+00, & + -0.50394E+00,-0.50389E+00,-0.50382E+00,-0.50373E+00,-0.50362E+00, & + -0.50350E+00,-0.50336E+00,-0.50320E+00,-0.50303E+00,-0.50285E+00/ + + DATA (BNC13M (I),I=101,200)/ & + -0.50265E+00,-0.50243E+00,-0.50220E+00,-0.50196E+00,-0.50171E+00, & + -0.50144E+00,-0.50116E+00,-0.50087E+00,-0.50056E+00,-0.50025E+00, & + -0.49993E+00,-0.49959E+00,-0.49925E+00,-0.49890E+00,-0.49853E+00, & + -0.49816E+00,-0.49778E+00,-0.49739E+00,-0.49700E+00,-0.49660E+00, & + -0.49627E+00,-0.49584E+00,-0.49541E+00,-0.49497E+00,-0.49453E+00, & + -0.49408E+00,-0.49363E+00,-0.49317E+00,-0.49271E+00,-0.49225E+00, & + -0.49178E+00,-0.49130E+00,-0.49082E+00,-0.49034E+00,-0.48986E+00, & + -0.48937E+00,-0.48887E+00,-0.48838E+00,-0.48788E+00,-0.48738E+00, & + -0.48687E+00,-0.48636E+00,-0.48585E+00,-0.48534E+00,-0.48482E+00, & + -0.48430E+00,-0.48378E+00,-0.48326E+00,-0.48273E+00,-0.48221E+00, & + -0.48168E+00,-0.48115E+00,-0.48061E+00,-0.48008E+00,-0.47954E+00, & + -0.47900E+00,-0.47846E+00,-0.47792E+00,-0.47738E+00,-0.47683E+00, & + -0.47628E+00,-0.47574E+00,-0.47519E+00,-0.47464E+00,-0.47409E+00, & + -0.47354E+00,-0.47298E+00,-0.47243E+00,-0.47187E+00,-0.47132E+00, & + -0.47076E+00,-0.47020E+00,-0.46964E+00,-0.46908E+00,-0.46852E+00, & + -0.46796E+00,-0.46740E+00,-0.46684E+00,-0.46628E+00,-0.46572E+00, & + -0.46515E+00,-0.46459E+00,-0.46402E+00,-0.46346E+00,-0.46289E+00, & + -0.46233E+00,-0.46176E+00,-0.46120E+00,-0.46063E+00,-0.46006E+00, & + -0.45950E+00,-0.45893E+00,-0.45836E+00,-0.45780E+00,-0.45723E+00, & + -0.45666E+00,-0.45609E+00,-0.45553E+00,-0.45496E+00,-0.45439E+00/ + + DATA (BNC13M (I),I=201,300)/ & + -0.45382E+00,-0.45325E+00,-0.45269E+00,-0.45212E+00,-0.45155E+00, & + -0.45098E+00,-0.45041E+00,-0.44985E+00,-0.44928E+00,-0.44871E+00, & + -0.44814E+00,-0.44758E+00,-0.44701E+00,-0.44644E+00,-0.44588E+00, & + -0.44531E+00,-0.44474E+00,-0.44418E+00,-0.44361E+00,-0.44305E+00, & + -0.44248E+00,-0.44192E+00,-0.44135E+00,-0.44079E+00,-0.44022E+00, & + -0.43966E+00,-0.43909E+00,-0.43853E+00,-0.43797E+00,-0.43740E+00, & + -0.43684E+00,-0.43628E+00,-0.43572E+00,-0.43515E+00,-0.43459E+00, & + -0.43403E+00,-0.43347E+00,-0.43291E+00,-0.43235E+00,-0.43179E+00, & + -0.43123E+00,-0.43067E+00,-0.43012E+00,-0.42956E+00,-0.42900E+00, & + -0.42844E+00,-0.42789E+00,-0.42733E+00,-0.42678E+00,-0.42622E+00, & + -0.42567E+00,-0.42511E+00,-0.42456E+00,-0.42400E+00,-0.42345E+00, & + -0.42290E+00,-0.42234E+00,-0.42179E+00,-0.42124E+00,-0.42069E+00, & + -0.42014E+00,-0.41959E+00,-0.41904E+00,-0.41849E+00,-0.41794E+00, & + -0.41740E+00,-0.41685E+00,-0.41630E+00,-0.41575E+00,-0.41521E+00, & + -0.41466E+00,-0.41412E+00,-0.41357E+00,-0.41303E+00,-0.41249E+00, & + -0.41194E+00,-0.41140E+00,-0.41086E+00,-0.41032E+00,-0.40977E+00, & + -0.40923E+00,-0.40869E+00,-0.40815E+00,-0.40762E+00,-0.40708E+00, & + -0.40654E+00,-0.40600E+00,-0.40547E+00,-0.40493E+00,-0.40439E+00, & + -0.40386E+00,-0.40332E+00,-0.40279E+00,-0.40225E+00,-0.40172E+00, & + -0.40119E+00,-0.40066E+00,-0.40013E+00,-0.39959E+00,-0.39906E+00/ + + DATA (BNC13M (I),I=301,400)/ & + -0.39853E+00,-0.39800E+00,-0.39747E+00,-0.39695E+00,-0.39642E+00, & + -0.39589E+00,-0.39536E+00,-0.39484E+00,-0.39431E+00,-0.39379E+00, & + -0.39326E+00,-0.39274E+00,-0.39221E+00,-0.39169E+00,-0.39117E+00, & + -0.39065E+00,-0.39013E+00,-0.38961E+00,-0.38908E+00,-0.38857E+00, & + -0.38805E+00,-0.38753E+00,-0.38701E+00,-0.38649E+00,-0.38597E+00, & + -0.38546E+00,-0.38494E+00,-0.38443E+00,-0.38391E+00,-0.38340E+00, & + -0.38288E+00,-0.38237E+00,-0.38186E+00,-0.38135E+00,-0.38083E+00, & + -0.38032E+00,-0.37981E+00,-0.37930E+00,-0.37879E+00,-0.37828E+00, & + -0.37778E+00,-0.37727E+00,-0.37676E+00,-0.37625E+00,-0.37575E+00, & + -0.37524E+00,-0.37474E+00,-0.37423E+00,-0.37373E+00,-0.37322E+00, & + -0.37272E+00,-0.37222E+00,-0.37172E+00,-0.37122E+00,-0.37071E+00, & + -0.37021E+00,-0.36971E+00,-0.36922E+00,-0.36872E+00,-0.36822E+00, & + -0.36772E+00,-0.36722E+00,-0.36673E+00,-0.36623E+00,-0.36574E+00, & + -0.36524E+00,-0.36475E+00,-0.36425E+00,-0.36376E+00,-0.36327E+00, & + -0.36277E+00,-0.36228E+00,-0.36179E+00,-0.36130E+00,-0.36081E+00, & + -0.36032E+00,-0.35983E+00,-0.35934E+00,-0.35886E+00,-0.35837E+00, & + -0.35788E+00,-0.35739E+00,-0.35691E+00,-0.35642E+00,-0.35594E+00, & + -0.35545E+00,-0.35497E+00,-0.35449E+00,-0.35400E+00,-0.35352E+00, & + -0.35304E+00,-0.35256E+00,-0.35208E+00,-0.35160E+00,-0.35112E+00, & + -0.35064E+00,-0.35016E+00,-0.34968E+00,-0.34920E+00,-0.34873E+00/ + + DATA (BNC13M (I),I=401,500)/ & + -0.34825E+00,-0.34777E+00,-0.34730E+00,-0.34682E+00,-0.34635E+00, & + -0.34588E+00,-0.34540E+00,-0.34493E+00,-0.34446E+00,-0.34398E+00, & + -0.34351E+00,-0.34304E+00,-0.34257E+00,-0.34210E+00,-0.34163E+00, & + -0.34116E+00,-0.34069E+00,-0.34023E+00,-0.33976E+00,-0.33929E+00, & + -0.33882E+00,-0.33836E+00,-0.33789E+00,-0.33743E+00,-0.33696E+00, & + -0.33650E+00,-0.33604E+00,-0.33557E+00,-0.33511E+00,-0.33465E+00, & + -0.33419E+00,-0.33373E+00,-0.33327E+00,-0.33281E+00,-0.33235E+00, & + -0.33189E+00,-0.33143E+00,-0.33097E+00,-0.33051E+00,-0.33006E+00, & + -0.32960E+00,-0.32914E+00,-0.32869E+00,-0.32823E+00,-0.32778E+00, & + -0.32732E+00,-0.32687E+00,-0.32642E+00,-0.32596E+00,-0.32551E+00, & + -0.32506E+00,-0.32461E+00,-0.32416E+00,-0.32371E+00,-0.32326E+00, & + -0.32281E+00,-0.32236E+00,-0.32191E+00,-0.32146E+00,-0.32101E+00, & + -0.32057E+00,-0.32012E+00,-0.31967E+00,-0.31923E+00,-0.31878E+00, & + -0.31834E+00,-0.31789E+00,-0.31745E+00,-0.31701E+00,-0.31656E+00, & + -0.31612E+00,-0.31568E+00,-0.31524E+00,-0.31480E+00,-0.31436E+00, & + -0.31392E+00,-0.31348E+00,-0.31304E+00,-0.31260E+00,-0.31216E+00, & + -0.31172E+00,-0.31128E+00,-0.31085E+00,-0.31041E+00,-0.30997E+00, & + -0.30954E+00,-0.30910E+00,-0.30867E+00,-0.30823E+00,-0.30780E+00, & + -0.30737E+00,-0.30693E+00,-0.30650E+00,-0.30607E+00,-0.30564E+00, & + -0.30521E+00,-0.30478E+00,-0.30435E+00,-0.30392E+00,-0.30349E+00/ + + DATA (BNC13M (I),I=501,600)/ & + -0.30306E+00,-0.30263E+00,-0.30220E+00,-0.30177E+00,-0.30135E+00, & + -0.30092E+00,-0.30049E+00,-0.30007E+00,-0.29964E+00,-0.29922E+00, & + -0.29879E+00,-0.29837E+00,-0.29794E+00,-0.29752E+00,-0.29710E+00, & + -0.29668E+00,-0.29625E+00,-0.29583E+00,-0.29541E+00,-0.29499E+00, & + -0.29457E+00,-0.29415E+00,-0.29373E+00,-0.29331E+00,-0.29289E+00, & + -0.29248E+00,-0.29206E+00,-0.29164E+00,-0.29122E+00,-0.29081E+00, & + -0.29039E+00,-0.28997E+00,-0.28956E+00,-0.28914E+00,-0.28873E+00, & + -0.28832E+00,-0.28790E+00,-0.28749E+00,-0.28708E+00,-0.28666E+00, & + -0.28625E+00,-0.28584E+00,-0.28543E+00,-0.28502E+00,-0.28461E+00, & + -0.28420E+00,-0.28379E+00,-0.28338E+00,-0.28297E+00,-0.28256E+00, & + -0.28216E+00,-0.28175E+00,-0.28134E+00,-0.28093E+00,-0.28053E+00, & + -0.28012E+00,-0.27972E+00,-0.27931E+00,-0.27891E+00,-0.27850E+00, & + -0.27810E+00,-0.27770E+00,-0.27729E+00,-0.27689E+00,-0.27649E+00, & + -0.27609E+00,-0.27568E+00,-0.27528E+00,-0.27488E+00,-0.27448E+00, & + -0.27408E+00,-0.27368E+00,-0.27328E+00,-0.27288E+00,-0.27249E+00, & + -0.27209E+00,-0.27169E+00,-0.27129E+00,-0.27090E+00,-0.27050E+00, & + -0.27010E+00,-0.26971E+00,-0.26931E+00,-0.26892E+00,-0.26852E+00, & + -0.26813E+00,-0.26774E+00,-0.26734E+00,-0.26695E+00,-0.26656E+00, & + -0.26616E+00,-0.26577E+00,-0.26538E+00,-0.26499E+00,-0.26460E+00, & + -0.26421E+00,-0.26382E+00,-0.26343E+00,-0.26304E+00,-0.26158E+00/ + + DATA (BNC13M (I),I=601,700)/ & + -0.25840E+00,-0.25457E+00,-0.25078E+00,-0.24702E+00,-0.24330E+00, & + -0.23961E+00,-0.23595E+00,-0.23233E+00,-0.22874E+00,-0.22518E+00, & + -0.22165E+00,-0.21815E+00,-0.21469E+00,-0.21125E+00,-0.20784E+00, & + -0.20447E+00,-0.20112E+00,-0.19779E+00,-0.19450E+00,-0.19123E+00, & + -0.18799E+00,-0.18477E+00,-0.18158E+00,-0.17842E+00,-0.17528E+00, & + -0.17217E+00,-0.16907E+00,-0.16601E+00,-0.16297E+00,-0.15995E+00, & + -0.15695E+00,-0.15397E+00,-0.15102E+00,-0.14809E+00,-0.14518E+00, & + -0.14229E+00,-0.13943E+00,-0.13658E+00,-0.13375E+00,-0.13095E+00, & + -0.12816E+00,-0.12539E+00,-0.12265E+00,-0.11992E+00,-0.11721E+00, & + -0.11452E+00,-0.11184E+00,-0.10919E+00,-0.10655E+00,-0.10393E+00, & + -0.10133E+00,-0.98739E-01,-0.96170E-01,-0.93617E-01,-0.91081E-01, & + -0.88561E-01,-0.86056E-01,-0.83568E-01,-0.81095E-01,-0.78637E-01, & + -0.76195E-01,-0.73767E-01,-0.71355E-01,-0.68957E-01,-0.66573E-01, & + -0.64204E-01,-0.61849E-01,-0.59507E-01,-0.57180E-01,-0.54866E-01, & + -0.52566E-01,-0.50279E-01,-0.48005E-01,-0.45744E-01,-0.43496E-01, & + -0.41260E-01,-0.39037E-01,-0.36827E-01,-0.34628E-01,-0.32442E-01, & + -0.30268E-01,-0.28106E-01,-0.25956E-01,-0.23817E-01,-0.21689E-01, & + -0.19574E-01,-0.17469E-01,-0.15375E-01,-0.13292E-01,-0.11221E-01, & + -0.91598E-02,-0.71093E-02,-0.50696E-02,-0.30402E-02,-0.10212E-02, & + 0.98748E-03, 0.29862E-02, 0.49749E-02, 0.69534E-02, 0.89223E-02/ + + DATA (BNC13M(I),I=701,741)/ & + 0.10881E-01, 0.12831E-01, 0.14771E-01, 0.16702E-01, 0.18623E-01, & + 0.20535E-01, 0.22438E-01, 0.24331E-01, 0.26216E-01, 0.28092E-01, & + 0.29959E-01, 0.31817E-01, 0.33667E-01, 0.35508E-01, 0.37340E-01, & + 0.39165E-01, 0.40981E-01, 0.42788E-01, 0.44588E-01, 0.46379E-01, & + 0.48162E-01, 0.49937E-01, 0.51705E-01, 0.53464E-01, 0.55216E-01, & + 0.56961E-01, 0.58697E-01, 0.60426E-01, 0.62148E-01, 0.63862E-01, & + 0.65569E-01, 0.67268E-01, 0.68960E-01, 0.70645E-01, 0.72323E-01, & + 0.73994E-01, 0.75658E-01, 0.77315E-01, 0.78966E-01, 0.80609E-01, & + 0.82246E-01 & + / + END Module KMC298 diff --git a/wrfv2_fire/chem/module_data_isrpia_kmc323.F b/wrfv2_fire/chem/module_data_isrpia_kmc323.F new file mode 100755 index 00000000..650e0d50 --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_kmc323.F @@ -0,0 +1,2195 @@ + + MODULE KMC323 + DOUBLE PRECISION :: & + BNC01M( 741),BNC02M( 741),BNC03M( 741),BNC04M( 741), & + BNC05M( 741),BNC06M( 741),BNC07M( 741),BNC08M( 741), & + BNC09M( 741),BNC10M( 741),BNC11M( 741),BNC12M( 741), & + BNC13M( 741) + + + +! +! *** NaCl +! + DATA (BNC01M (I),I= 1,100)/ & + -0.48816E-01,-0.86364E-01,-0.11089E+00,-0.12640E+00,-0.13753E+00, & + -0.14603E+00,-0.15274E+00,-0.15816E+00,-0.16259E+00,-0.16624E+00, & + -0.16927E+00,-0.17179E+00,-0.17387E+00,-0.17559E+00,-0.17699E+00, & + -0.17812E+00,-0.17901E+00,-0.17968E+00,-0.18017E+00,-0.18049E+00, & + -0.18066E+00,-0.18070E+00,-0.18061E+00,-0.18042E+00,-0.18013E+00, & + -0.17974E+00,-0.17927E+00,-0.17873E+00,-0.17812E+00,-0.17744E+00, & + -0.17671E+00,-0.17593E+00,-0.17509E+00,-0.17421E+00,-0.17329E+00, & + -0.17233E+00,-0.17134E+00,-0.17031E+00,-0.16926E+00,-0.16817E+00, & + -0.16707E+00,-0.16594E+00,-0.16479E+00,-0.16362E+00,-0.16243E+00, & + -0.16122E+00,-0.16000E+00,-0.15877E+00,-0.15752E+00,-0.15626E+00, & + -0.15499E+00,-0.15371E+00,-0.15242E+00,-0.15112E+00,-0.14981E+00, & + -0.14849E+00,-0.14716E+00,-0.14583E+00,-0.14448E+00,-0.14313E+00, & + -0.14177E+00,-0.14041E+00,-0.13904E+00,-0.13766E+00,-0.13627E+00, & + -0.13487E+00,-0.13347E+00,-0.13206E+00,-0.13063E+00,-0.12920E+00, & + -0.12777E+00,-0.12632E+00,-0.12486E+00,-0.12340E+00,-0.12192E+00, & + -0.12043E+00,-0.11893E+00,-0.11743E+00,-0.11591E+00,-0.11438E+00, & + -0.11283E+00,-0.11128E+00,-0.10972E+00,-0.10814E+00,-0.10655E+00, & + -0.10495E+00,-0.10333E+00,-0.10171E+00,-0.10007E+00,-0.98421E-01, & + -0.96759E-01,-0.95085E-01,-0.93399E-01,-0.91702E-01,-0.89993E-01, & + -0.88272E-01,-0.86541E-01,-0.84798E-01,-0.83045E-01,-0.81282E-01/ + + DATA (BNC01M (I),I=101,200)/ & + -0.79509E-01,-0.77726E-01,-0.75934E-01,-0.74133E-01,-0.72323E-01, & + -0.70506E-01,-0.68680E-01,-0.66847E-01,-0.65007E-01,-0.63160E-01, & + -0.61307E-01,-0.59447E-01,-0.57583E-01,-0.55713E-01,-0.53838E-01, & + -0.51958E-01,-0.50075E-01,-0.48187E-01,-0.46296E-01,-0.44402E-01, & + -0.42697E-01,-0.40775E-01,-0.38852E-01,-0.36930E-01,-0.35007E-01, & + -0.33085E-01,-0.31163E-01,-0.29240E-01,-0.27318E-01,-0.25397E-01, & + -0.23475E-01,-0.21554E-01,-0.19634E-01,-0.17714E-01,-0.15794E-01, & + -0.13875E-01,-0.11957E-01,-0.10039E-01,-0.81222E-02,-0.62060E-02, & + -0.42906E-02,-0.23761E-02,-0.46246E-03, 0.14502E-02, 0.33620E-02, & + 0.52727E-02, 0.71824E-02, 0.90910E-02, 0.10999E-01, 0.12905E-01, & + 0.14810E-01, 0.16714E-01, 0.18617E-01, 0.20518E-01, 0.22419E-01, & + 0.24317E-01, 0.26215E-01, 0.28111E-01, 0.30006E-01, 0.31899E-01, & + 0.33791E-01, 0.35682E-01, 0.37571E-01, 0.39458E-01, 0.41344E-01, & + 0.43228E-01, 0.45111E-01, 0.46992E-01, 0.48871E-01, 0.50749E-01, & + 0.52625E-01, 0.54500E-01, 0.56373E-01, 0.58244E-01, 0.60113E-01, & + 0.61981E-01, 0.63847E-01, 0.65711E-01, 0.67573E-01, 0.69434E-01, & + 0.71292E-01, 0.73149E-01, 0.75004E-01, 0.76857E-01, 0.78709E-01, & + 0.80558E-01, 0.82406E-01, 0.84251E-01, 0.86095E-01, 0.87937E-01, & + 0.89776E-01, 0.91614E-01, 0.93450E-01, 0.95284E-01, 0.97116E-01, & + 0.98946E-01, 0.10077E+00, 0.10260E+00, 0.10442E+00, 0.10625E+00/ + + DATA (BNC01M (I),I=201,300)/ & + 0.10807E+00, 0.10988E+00, 0.11170E+00, 0.11351E+00, 0.11533E+00, & + 0.11714E+00, 0.11894E+00, 0.12075E+00, 0.12255E+00, 0.12435E+00, & + 0.12615E+00, 0.12795E+00, 0.12975E+00, 0.13154E+00, 0.13333E+00, & + 0.13512E+00, 0.13691E+00, 0.13869E+00, 0.14047E+00, 0.14226E+00, & + 0.14403E+00, 0.14581E+00, 0.14758E+00, 0.14936E+00, 0.15113E+00, & + 0.15289E+00, 0.15466E+00, 0.15642E+00, 0.15818E+00, 0.15994E+00, & + 0.16170E+00, 0.16346E+00, 0.16521E+00, 0.16696E+00, 0.16871E+00, & + 0.17045E+00, 0.17220E+00, 0.17394E+00, 0.17568E+00, 0.17742E+00, & + 0.17915E+00, 0.18089E+00, 0.18262E+00, 0.18435E+00, 0.18608E+00, & + 0.18780E+00, 0.18952E+00, 0.19124E+00, 0.19296E+00, 0.19468E+00, & + 0.19639E+00, 0.19811E+00, 0.19982E+00, 0.20152E+00, 0.20323E+00, & + 0.20493E+00, 0.20663E+00, 0.20833E+00, 0.21003E+00, 0.21172E+00, & + 0.21342E+00, 0.21511E+00, 0.21680E+00, 0.21848E+00, 0.22017E+00, & + 0.22185E+00, 0.22353E+00, 0.22521E+00, 0.22688E+00, 0.22856E+00, & + 0.23023E+00, 0.23190E+00, 0.23356E+00, 0.23523E+00, 0.23689E+00, & + 0.23855E+00, 0.24021E+00, 0.24187E+00, 0.24352E+00, 0.24518E+00, & + 0.24683E+00, 0.24847E+00, 0.25012E+00, 0.25176E+00, 0.25341E+00, & + 0.25505E+00, 0.25668E+00, 0.25832E+00, 0.25995E+00, 0.26158E+00, & + 0.26321E+00, 0.26484E+00, 0.26647E+00, 0.26809E+00, 0.26971E+00, & + 0.27133E+00, 0.27295E+00, 0.27456E+00, 0.27618E+00, 0.27779E+00/ + + DATA (BNC01M (I),I=301,400)/ & + 0.27940E+00, 0.28100E+00, 0.28261E+00, 0.28421E+00, 0.28581E+00, & + 0.28741E+00, 0.28901E+00, 0.29060E+00, 0.29219E+00, 0.29378E+00, & + 0.29537E+00, 0.29696E+00, 0.29854E+00, 0.30012E+00, 0.30171E+00, & + 0.30328E+00, 0.30486E+00, 0.30643E+00, 0.30801E+00, 0.30958E+00, & + 0.31115E+00, 0.31271E+00, 0.31428E+00, 0.31584E+00, 0.31740E+00, & + 0.31896E+00, 0.32052E+00, 0.32207E+00, 0.32362E+00, 0.32517E+00, & + 0.32672E+00, 0.32827E+00, 0.32982E+00, 0.33136E+00, 0.33290E+00, & + 0.33444E+00, 0.33598E+00, 0.33751E+00, 0.33904E+00, 0.34058E+00, & + 0.34211E+00, 0.34363E+00, 0.34516E+00, 0.34668E+00, 0.34820E+00, & + 0.34972E+00, 0.35124E+00, 0.35276E+00, 0.35427E+00, 0.35579E+00, & + 0.35730E+00, 0.35881E+00, 0.36031E+00, 0.36182E+00, 0.36332E+00, & + 0.36482E+00, 0.36632E+00, 0.36782E+00, 0.36931E+00, 0.37081E+00, & + 0.37230E+00, 0.37379E+00, 0.37528E+00, 0.37677E+00, 0.37825E+00, & + 0.37973E+00, 0.38121E+00, 0.38269E+00, 0.38417E+00, 0.38565E+00, & + 0.38712E+00, 0.38859E+00, 0.39006E+00, 0.39153E+00, 0.39300E+00, & + 0.39446E+00, 0.39593E+00, 0.39739E+00, 0.39885E+00, 0.40030E+00, & + 0.40176E+00, 0.40321E+00, 0.40467E+00, 0.40612E+00, 0.40757E+00, & + 0.40901E+00, 0.41046E+00, 0.41190E+00, 0.41334E+00, 0.41478E+00, & + 0.41622E+00, 0.41766E+00, 0.41909E+00, 0.42053E+00, 0.42196E+00, & + 0.42339E+00, 0.42482E+00, 0.42624E+00, 0.42767E+00, 0.42909E+00/ + + DATA (BNC01M (I),I=401,500)/ & + 0.43051E+00, 0.43193E+00, 0.43335E+00, 0.43477E+00, 0.43618E+00, & + 0.43759E+00, 0.43901E+00, 0.44042E+00, 0.44182E+00, 0.44323E+00, & + 0.44463E+00, 0.44604E+00, 0.44744E+00, 0.44884E+00, 0.45024E+00, & + 0.45163E+00, 0.45303E+00, 0.45442E+00, 0.45581E+00, 0.45720E+00, & + 0.45859E+00, 0.45998E+00, 0.46136E+00, 0.46274E+00, 0.46413E+00, & + 0.46551E+00, 0.46689E+00, 0.46826E+00, 0.46964E+00, 0.47101E+00, & + 0.47238E+00, 0.47375E+00, 0.47512E+00, 0.47649E+00, 0.47786E+00, & + 0.47922E+00, 0.48058E+00, 0.48194E+00, 0.48330E+00, 0.48466E+00, & + 0.48602E+00, 0.48737E+00, 0.48873E+00, 0.49008E+00, 0.49143E+00, & + 0.49278E+00, 0.49412E+00, 0.49547E+00, 0.49681E+00, 0.49816E+00, & + 0.49950E+00, 0.50084E+00, 0.50217E+00, 0.50351E+00, 0.50485E+00, & + 0.50618E+00, 0.50751E+00, 0.50884E+00, 0.51017E+00, 0.51150E+00, & + 0.51282E+00, 0.51415E+00, 0.51547E+00, 0.51679E+00, 0.51811E+00, & + 0.51943E+00, 0.52075E+00, 0.52206E+00, 0.52338E+00, 0.52469E+00, & + 0.52600E+00, 0.52731E+00, 0.52862E+00, 0.52993E+00, 0.53123E+00, & + 0.53254E+00, 0.53384E+00, 0.53514E+00, 0.53644E+00, 0.53774E+00, & + 0.53904E+00, 0.54033E+00, 0.54162E+00, 0.54292E+00, 0.54421E+00, & + 0.54550E+00, 0.54679E+00, 0.54807E+00, 0.54936E+00, 0.55064E+00, & + 0.55193E+00, 0.55321E+00, 0.55449E+00, 0.55577E+00, 0.55704E+00, & + 0.55832E+00, 0.55959E+00, 0.56087E+00, 0.56214E+00, 0.56341E+00/ + + DATA (BNC01M (I),I=501,600)/ & + 0.56468E+00, 0.56594E+00, 0.56721E+00, 0.56848E+00, 0.56974E+00, & + 0.57100E+00, 0.57226E+00, 0.57352E+00, 0.57478E+00, 0.57604E+00, & + 0.57729E+00, 0.57855E+00, 0.57980E+00, 0.58105E+00, 0.58230E+00, & + 0.58355E+00, 0.58480E+00, 0.58604E+00, 0.58729E+00, 0.58853E+00, & + 0.58977E+00, 0.59101E+00, 0.59225E+00, 0.59349E+00, 0.59473E+00, & + 0.59596E+00, 0.59720E+00, 0.59843E+00, 0.59966E+00, 0.60089E+00, & + 0.60212E+00, 0.60335E+00, 0.60458E+00, 0.60580E+00, 0.60703E+00, & + 0.60825E+00, 0.60947E+00, 0.61069E+00, 0.61191E+00, 0.61313E+00, & + 0.61435E+00, 0.61556E+00, 0.61678E+00, 0.61799E+00, 0.61920E+00, & + 0.62041E+00, 0.62162E+00, 0.62283E+00, 0.62403E+00, 0.62524E+00, & + 0.62644E+00, 0.62765E+00, 0.62885E+00, 0.63005E+00, 0.63125E+00, & + 0.63245E+00, 0.63364E+00, 0.63484E+00, 0.63603E+00, 0.63723E+00, & + 0.63842E+00, 0.63961E+00, 0.64080E+00, 0.64199E+00, 0.64318E+00, & + 0.64436E+00, 0.64555E+00, 0.64673E+00, 0.64791E+00, 0.64909E+00, & + 0.65027E+00, 0.65145E+00, 0.65263E+00, 0.65381E+00, 0.65498E+00, & + 0.65616E+00, 0.65733E+00, 0.65850E+00, 0.65967E+00, 0.66084E+00, & + 0.66201E+00, 0.66318E+00, 0.66435E+00, 0.66551E+00, 0.66667E+00, & + 0.66784E+00, 0.66900E+00, 0.67016E+00, 0.67132E+00, 0.67248E+00, & + 0.67363E+00, 0.67479E+00, 0.67595E+00, 0.67710E+00, 0.67825E+00, & + 0.67940E+00, 0.68055E+00, 0.68170E+00, 0.68285E+00, 0.68715E+00/ + + DATA (BNC01M (I),I=601,700)/ & + 0.69654E+00, 0.70783E+00, 0.71902E+00, 0.73010E+00, 0.74108E+00, & + 0.75196E+00, 0.76274E+00, 0.77342E+00, 0.78402E+00, 0.79451E+00, & + 0.80492E+00, 0.81524E+00, 0.82547E+00, 0.83562E+00, 0.84568E+00, & + 0.85566E+00, 0.86556E+00, 0.87538E+00, 0.88512E+00, 0.89478E+00, & + 0.90437E+00, 0.91389E+00, 0.92333E+00, 0.93270E+00, 0.94200E+00, & + 0.95123E+00, 0.96040E+00, 0.96949E+00, 0.97852E+00, 0.98749E+00, & + 0.99639E+00, 0.10052E+01, 0.10140E+01, 0.10227E+01, 0.10314E+01, & + 0.10400E+01, 0.10485E+01, 0.10570E+01, 0.10654E+01, 0.10738E+01, & + 0.10821E+01, 0.10904E+01, 0.10986E+01, 0.11068E+01, 0.11149E+01, & + 0.11230E+01, 0.11310E+01, 0.11389E+01, 0.11469E+01, 0.11547E+01, & + 0.11625E+01, 0.11703E+01, 0.11780E+01, 0.11857E+01, 0.11934E+01, & + 0.12010E+01, 0.12085E+01, 0.12160E+01, 0.12235E+01, 0.12309E+01, & + 0.12383E+01, 0.12457E+01, 0.12530E+01, 0.12602E+01, 0.12675E+01, & + 0.12747E+01, 0.12818E+01, 0.12889E+01, 0.12960E+01, 0.13031E+01, & + 0.13101E+01, 0.13170E+01, 0.13240E+01, 0.13309E+01, 0.13378E+01, & + 0.13446E+01, 0.13514E+01, 0.13582E+01, 0.13649E+01, 0.13716E+01, & + 0.13783E+01, 0.13849E+01, 0.13915E+01, 0.13981E+01, 0.14047E+01, & + 0.14112E+01, 0.14177E+01, 0.14241E+01, 0.14306E+01, 0.14370E+01, & + 0.14434E+01, 0.14497E+01, 0.14560E+01, 0.14623E+01, 0.14686E+01, & + 0.14748E+01, 0.14810E+01, 0.14872E+01, 0.14934E+01, 0.14995E+01/ + + DATA (BNC01M(I),I=701,741)/ & + 0.15056E+01, 0.15117E+01, 0.15178E+01, 0.15238E+01, 0.15298E+01, & + 0.15358E+01, 0.15418E+01, 0.15477E+01, 0.15536E+01, 0.15595E+01, & + 0.15654E+01, 0.15713E+01, 0.15771E+01, 0.15829E+01, 0.15887E+01, & + 0.15944E+01, 0.16002E+01, 0.16059E+01, 0.16116E+01, 0.16173E+01, & + 0.16229E+01, 0.16286E+01, 0.16342E+01, 0.16398E+01, 0.16453E+01, & + 0.16509E+01, 0.16564E+01, 0.16620E+01, 0.16675E+01, 0.16729E+01, & + 0.16784E+01, 0.16838E+01, 0.16893E+01, 0.16947E+01, 0.17000E+01, & + 0.17054E+01, 0.17108E+01, 0.17161E+01, 0.17214E+01, 0.17267E+01, & + 0.17320E+01 & + / +! +! *** Na2SO4 +! + DATA (BNC02M (I),I= 1,100)/ & + -0.10024E+00,-0.18230E+00,-0.23981E+00,-0.27879E+00,-0.30871E+00, & + -0.33311E+00,-0.35376E+00,-0.37167E+00,-0.38749E+00,-0.40165E+00, & + -0.41447E+00,-0.42617E+00,-0.43693E+00,-0.44690E+00,-0.45616E+00, & + -0.46482E+00,-0.47294E+00,-0.48058E+00,-0.48780E+00,-0.49464E+00, & + -0.50113E+00,-0.50730E+00,-0.51318E+00,-0.51880E+00,-0.52418E+00, & + -0.52933E+00,-0.53428E+00,-0.53903E+00,-0.54360E+00,-0.54800E+00, & + -0.55224E+00,-0.55634E+00,-0.56030E+00,-0.56412E+00,-0.56783E+00, & + -0.57141E+00,-0.57489E+00,-0.57826E+00,-0.58153E+00,-0.58471E+00, & + -0.58779E+00,-0.59080E+00,-0.59371E+00,-0.59655E+00,-0.59932E+00, & + -0.60201E+00,-0.60464E+00,-0.60720E+00,-0.60969E+00,-0.61213E+00, & + -0.61451E+00,-0.61683E+00,-0.61910E+00,-0.62131E+00,-0.62348E+00, & + -0.62560E+00,-0.62767E+00,-0.62970E+00,-0.63168E+00,-0.63362E+00, & + -0.63553E+00,-0.63739E+00,-0.63922E+00,-0.64101E+00,-0.64276E+00, & + -0.64449E+00,-0.64618E+00,-0.64784E+00,-0.64946E+00,-0.65106E+00, & + -0.65263E+00,-0.65417E+00,-0.65569E+00,-0.65718E+00,-0.65865E+00, & + -0.66009E+00,-0.66150E+00,-0.66290E+00,-0.66427E+00,-0.66562E+00, & + -0.66695E+00,-0.66826E+00,-0.66956E+00,-0.67083E+00,-0.67208E+00, & + -0.67332E+00,-0.67454E+00,-0.67574E+00,-0.67692E+00,-0.67809E+00, & + -0.67924E+00,-0.68038E+00,-0.68150E+00,-0.68261E+00,-0.68371E+00, & + -0.68479E+00,-0.68585E+00,-0.68691E+00,-0.68795E+00,-0.68897E+00/ + + DATA (BNC02M (I),I=101,200)/ & + -0.68999E+00,-0.69099E+00,-0.69198E+00,-0.69296E+00,-0.69393E+00, & + -0.69488E+00,-0.69582E+00,-0.69676E+00,-0.69768E+00,-0.69859E+00, & + -0.69949E+00,-0.70038E+00,-0.70126E+00,-0.70213E+00,-0.70299E+00, & + -0.70384E+00,-0.70468E+00,-0.70551E+00,-0.70633E+00,-0.70715E+00, & + -0.70792E+00,-0.70871E+00,-0.70950E+00,-0.71028E+00,-0.71105E+00, & + -0.71181E+00,-0.71257E+00,-0.71331E+00,-0.71405E+00,-0.71477E+00, & + -0.71549E+00,-0.71620E+00,-0.71691E+00,-0.71760E+00,-0.71829E+00, & + -0.71897E+00,-0.71964E+00,-0.72031E+00,-0.72097E+00,-0.72162E+00, & + -0.72226E+00,-0.72290E+00,-0.72353E+00,-0.72415E+00,-0.72477E+00, & + -0.72538E+00,-0.72598E+00,-0.72658E+00,-0.72717E+00,-0.72775E+00, & + -0.72833E+00,-0.72890E+00,-0.72947E+00,-0.73003E+00,-0.73058E+00, & + -0.73113E+00,-0.73168E+00,-0.73221E+00,-0.73274E+00,-0.73327E+00, & + -0.73379E+00,-0.73431E+00,-0.73482E+00,-0.73532E+00,-0.73582E+00, & + -0.73632E+00,-0.73681E+00,-0.73729E+00,-0.73778E+00,-0.73825E+00, & + -0.73872E+00,-0.73919E+00,-0.73965E+00,-0.74011E+00,-0.74056E+00, & + -0.74100E+00,-0.74145E+00,-0.74189E+00,-0.74232E+00,-0.74275E+00, & + -0.74318E+00,-0.74360E+00,-0.74402E+00,-0.74443E+00,-0.74484E+00, & + -0.74524E+00,-0.74564E+00,-0.74604E+00,-0.74644E+00,-0.74683E+00, & + -0.74721E+00,-0.74759E+00,-0.74797E+00,-0.74835E+00,-0.74872E+00, & + -0.74908E+00,-0.74945E+00,-0.74981E+00,-0.75016E+00,-0.75052E+00/ + + DATA (BNC02M (I),I=201,300)/ & + -0.75087E+00,-0.75121E+00,-0.75155E+00,-0.75189E+00,-0.75223E+00, & + -0.75256E+00,-0.75289E+00,-0.75322E+00,-0.75354E+00,-0.75386E+00, & + -0.75418E+00,-0.75449E+00,-0.75480E+00,-0.75511E+00,-0.75542E+00, & + -0.75572E+00,-0.75602E+00,-0.75631E+00,-0.75661E+00,-0.75690E+00, & + -0.75718E+00,-0.75747E+00,-0.75775E+00,-0.75803E+00,-0.75830E+00, & + -0.75858E+00,-0.75885E+00,-0.75912E+00,-0.75938E+00,-0.75964E+00, & + -0.75990E+00,-0.76016E+00,-0.76042E+00,-0.76067E+00,-0.76092E+00, & + -0.76117E+00,-0.76141E+00,-0.76165E+00,-0.76189E+00,-0.76213E+00, & + -0.76237E+00,-0.76260E+00,-0.76283E+00,-0.76306E+00,-0.76328E+00, & + -0.76351E+00,-0.76373E+00,-0.76395E+00,-0.76417E+00,-0.76438E+00, & + -0.76459E+00,-0.76480E+00,-0.76501E+00,-0.76522E+00,-0.76542E+00, & + -0.76562E+00,-0.76582E+00,-0.76602E+00,-0.76621E+00,-0.76641E+00, & + -0.76660E+00,-0.76679E+00,-0.76698E+00,-0.76716E+00,-0.76734E+00, & + -0.76753E+00,-0.76770E+00,-0.76788E+00,-0.76806E+00,-0.76823E+00, & + -0.76840E+00,-0.76857E+00,-0.76874E+00,-0.76891E+00,-0.76907E+00, & + -0.76923E+00,-0.76940E+00,-0.76955E+00,-0.76971E+00,-0.76987E+00, & + -0.77002E+00,-0.77017E+00,-0.77032E+00,-0.77047E+00,-0.77062E+00, & + -0.77076E+00,-0.77091E+00,-0.77105E+00,-0.77119E+00,-0.77133E+00, & + -0.77146E+00,-0.77160E+00,-0.77173E+00,-0.77186E+00,-0.77199E+00, & + -0.77212E+00,-0.77225E+00,-0.77238E+00,-0.77250E+00,-0.77262E+00/ + + DATA (BNC02M (I),I=301,400)/ & + -0.77274E+00,-0.77286E+00,-0.77298E+00,-0.77310E+00,-0.77321E+00, & + -0.77333E+00,-0.77344E+00,-0.77355E+00,-0.77366E+00,-0.77377E+00, & + -0.77387E+00,-0.77398E+00,-0.77408E+00,-0.77418E+00,-0.77428E+00, & + -0.77438E+00,-0.77448E+00,-0.77458E+00,-0.77467E+00,-0.77477E+00, & + -0.77486E+00,-0.77495E+00,-0.77504E+00,-0.77513E+00,-0.77522E+00, & + -0.77530E+00,-0.77539E+00,-0.77547E+00,-0.77555E+00,-0.77563E+00, & + -0.77571E+00,-0.77579E+00,-0.77587E+00,-0.77595E+00,-0.77602E+00, & + -0.77609E+00,-0.77617E+00,-0.77624E+00,-0.77631E+00,-0.77638E+00, & + -0.77644E+00,-0.77651E+00,-0.77657E+00,-0.77664E+00,-0.77670E+00, & + -0.77676E+00,-0.77682E+00,-0.77688E+00,-0.77694E+00,-0.77700E+00, & + -0.77705E+00,-0.77711E+00,-0.77716E+00,-0.77722E+00,-0.77727E+00, & + -0.77732E+00,-0.77737E+00,-0.77742E+00,-0.77746E+00,-0.77751E+00, & + -0.77755E+00,-0.77760E+00,-0.77764E+00,-0.77768E+00,-0.77772E+00, & + -0.77776E+00,-0.77780E+00,-0.77784E+00,-0.77788E+00,-0.77791E+00, & + -0.77795E+00,-0.77798E+00,-0.77802E+00,-0.77805E+00,-0.77808E+00, & + -0.77811E+00,-0.77814E+00,-0.77817E+00,-0.77819E+00,-0.77822E+00, & + -0.77825E+00,-0.77827E+00,-0.77829E+00,-0.77832E+00,-0.77834E+00, & + -0.77836E+00,-0.77838E+00,-0.77840E+00,-0.77841E+00,-0.77843E+00, & + -0.77845E+00,-0.77846E+00,-0.77848E+00,-0.77849E+00,-0.77850E+00, & + -0.77851E+00,-0.77852E+00,-0.77853E+00,-0.77854E+00,-0.77855E+00/ + + DATA (BNC02M (I),I=401,500)/ & + -0.77856E+00,-0.77857E+00,-0.77857E+00,-0.77858E+00,-0.77858E+00, & + -0.77858E+00,-0.77859E+00,-0.77859E+00,-0.77859E+00,-0.77859E+00, & + -0.77859E+00,-0.77859E+00,-0.77858E+00,-0.77858E+00,-0.77858E+00, & + -0.77857E+00,-0.77856E+00,-0.77856E+00,-0.77855E+00,-0.77854E+00, & + -0.77853E+00,-0.77852E+00,-0.77851E+00,-0.77850E+00,-0.77849E+00, & + -0.77848E+00,-0.77847E+00,-0.77845E+00,-0.77844E+00,-0.77842E+00, & + -0.77840E+00,-0.77839E+00,-0.77837E+00,-0.77835E+00,-0.77833E+00, & + -0.77831E+00,-0.77829E+00,-0.77827E+00,-0.77825E+00,-0.77823E+00, & + -0.77820E+00,-0.77818E+00,-0.77815E+00,-0.77813E+00,-0.77810E+00, & + -0.77807E+00,-0.77805E+00,-0.77802E+00,-0.77799E+00,-0.77796E+00, & + -0.77793E+00,-0.77790E+00,-0.77787E+00,-0.77784E+00,-0.77780E+00, & + -0.77777E+00,-0.77773E+00,-0.77770E+00,-0.77766E+00,-0.77763E+00, & + -0.77759E+00,-0.77755E+00,-0.77752E+00,-0.77748E+00,-0.77744E+00, & + -0.77740E+00,-0.77736E+00,-0.77732E+00,-0.77727E+00,-0.77723E+00, & + -0.77719E+00,-0.77714E+00,-0.77710E+00,-0.77706E+00,-0.77701E+00, & + -0.77696E+00,-0.77692E+00,-0.77687E+00,-0.77682E+00,-0.77677E+00, & + -0.77672E+00,-0.77668E+00,-0.77663E+00,-0.77657E+00,-0.77652E+00, & + -0.77647E+00,-0.77642E+00,-0.77637E+00,-0.77631E+00,-0.77626E+00, & + -0.77620E+00,-0.77615E+00,-0.77609E+00,-0.77604E+00,-0.77598E+00, & + -0.77592E+00,-0.77586E+00,-0.77580E+00,-0.77575E+00,-0.77569E+00/ + + DATA (BNC02M (I),I=501,600)/ & + -0.77563E+00,-0.77556E+00,-0.77550E+00,-0.77544E+00,-0.77538E+00, & + -0.77532E+00,-0.77525E+00,-0.77519E+00,-0.77512E+00,-0.77506E+00, & + -0.77499E+00,-0.77493E+00,-0.77486E+00,-0.77479E+00,-0.77473E+00, & + -0.77466E+00,-0.77459E+00,-0.77452E+00,-0.77445E+00,-0.77438E+00, & + -0.77431E+00,-0.77424E+00,-0.77417E+00,-0.77410E+00,-0.77402E+00, & + -0.77395E+00,-0.77388E+00,-0.77380E+00,-0.77373E+00,-0.77365E+00, & + -0.77358E+00,-0.77350E+00,-0.77343E+00,-0.77335E+00,-0.77327E+00, & + -0.77319E+00,-0.77312E+00,-0.77304E+00,-0.77296E+00,-0.77288E+00, & + -0.77280E+00,-0.77272E+00,-0.77264E+00,-0.77256E+00,-0.77247E+00, & + -0.77239E+00,-0.77231E+00,-0.77223E+00,-0.77214E+00,-0.77206E+00, & + -0.77197E+00,-0.77189E+00,-0.77180E+00,-0.77172E+00,-0.77163E+00, & + -0.77154E+00,-0.77146E+00,-0.77137E+00,-0.77128E+00,-0.77119E+00, & + -0.77110E+00,-0.77102E+00,-0.77093E+00,-0.77084E+00,-0.77074E+00, & + -0.77065E+00,-0.77056E+00,-0.77047E+00,-0.77038E+00,-0.77029E+00, & + -0.77019E+00,-0.77010E+00,-0.77001E+00,-0.76991E+00,-0.76982E+00, & + -0.76972E+00,-0.76963E+00,-0.76953E+00,-0.76943E+00,-0.76934E+00, & + -0.76924E+00,-0.76914E+00,-0.76904E+00,-0.76895E+00,-0.76885E+00, & + -0.76875E+00,-0.76865E+00,-0.76855E+00,-0.76845E+00,-0.76835E+00, & + -0.76825E+00,-0.76815E+00,-0.76804E+00,-0.76794E+00,-0.76784E+00, & + -0.76774E+00,-0.76763E+00,-0.76753E+00,-0.76743E+00,-0.76703E+00/ + + DATA (BNC02M (I),I=601,700)/ & + -0.76615E+00,-0.76505E+00,-0.76391E+00,-0.76274E+00,-0.76154E+00, & + -0.76031E+00,-0.75905E+00,-0.75775E+00,-0.75643E+00,-0.75509E+00, & + -0.75371E+00,-0.75231E+00,-0.75089E+00,-0.74944E+00,-0.74797E+00, & + -0.74647E+00,-0.74496E+00,-0.74342E+00,-0.74186E+00,-0.74028E+00, & + -0.73868E+00,-0.73706E+00,-0.73542E+00,-0.73376E+00,-0.73209E+00, & + -0.73040E+00,-0.72869E+00,-0.72696E+00,-0.72522E+00,-0.72346E+00, & + -0.72169E+00,-0.71990E+00,-0.71810E+00,-0.71628E+00,-0.71445E+00, & + -0.71261E+00,-0.71075E+00,-0.70888E+00,-0.70699E+00,-0.70510E+00, & + -0.70319E+00,-0.70127E+00,-0.69934E+00,-0.69739E+00,-0.69544E+00, & + -0.69347E+00,-0.69150E+00,-0.68951E+00,-0.68751E+00,-0.68551E+00, & + -0.68349E+00,-0.68146E+00,-0.67943E+00,-0.67738E+00,-0.67533E+00, & + -0.67326E+00,-0.67119E+00,-0.66911E+00,-0.66702E+00,-0.66493E+00, & + -0.66282E+00,-0.66071E+00,-0.65859E+00,-0.65646E+00,-0.65432E+00, & + -0.65218E+00,-0.65003E+00,-0.64787E+00,-0.64571E+00,-0.64354E+00, & + -0.64136E+00,-0.63917E+00,-0.63698E+00,-0.63478E+00,-0.63258E+00, & + -0.63037E+00,-0.62815E+00,-0.62593E+00,-0.62370E+00,-0.62147E+00, & + -0.61923E+00,-0.61699E+00,-0.61474E+00,-0.61248E+00,-0.61022E+00, & + -0.60795E+00,-0.60568E+00,-0.60341E+00,-0.60113E+00,-0.59884E+00, & + -0.59655E+00,-0.59425E+00,-0.59195E+00,-0.58965E+00,-0.58734E+00, & + -0.58503E+00,-0.58271E+00,-0.58039E+00,-0.57806E+00,-0.57573E+00/ + + DATA (BNC02M(I),I=701,741)/ & + -0.57339E+00,-0.57106E+00,-0.56871E+00,-0.56637E+00,-0.56402E+00, & + -0.56166E+00,-0.55930E+00,-0.55694E+00,-0.55458E+00,-0.55221E+00, & + -0.54984E+00,-0.54746E+00,-0.54508E+00,-0.54270E+00,-0.54031E+00, & + -0.53792E+00,-0.53553E+00,-0.53313E+00,-0.53073E+00,-0.52833E+00, & + -0.52593E+00,-0.52352E+00,-0.52111E+00,-0.51870E+00,-0.51628E+00, & + -0.51386E+00,-0.51144E+00,-0.50901E+00,-0.50658E+00,-0.50415E+00, & + -0.50172E+00,-0.49928E+00,-0.49684E+00,-0.49440E+00,-0.49196E+00, & + -0.48951E+00,-0.48706E+00,-0.48461E+00,-0.48216E+00,-0.47970E+00, & + -0.47725E+00 & + / +! +! *** NaNO3 +! + DATA (BNC03M (I),I= 1,100)/ & + -0.50245E-01,-0.91612E-01,-0.12079E+00,-0.14067E+00,-0.15601E+00, & + -0.16858E+00,-0.17927E+00,-0.18858E+00,-0.19683E+00,-0.20425E+00, & + -0.21100E+00,-0.21718E+00,-0.22289E+00,-0.22819E+00,-0.23314E+00, & + -0.23778E+00,-0.24215E+00,-0.24628E+00,-0.25020E+00,-0.25391E+00, & + -0.25745E+00,-0.26083E+00,-0.26407E+00,-0.26716E+00,-0.27014E+00, & + -0.27300E+00,-0.27575E+00,-0.27840E+00,-0.28095E+00,-0.28343E+00, & + -0.28582E+00,-0.28813E+00,-0.29037E+00,-0.29254E+00,-0.29465E+00, & + -0.29669E+00,-0.29868E+00,-0.30062E+00,-0.30250E+00,-0.30433E+00, & + -0.30611E+00,-0.30785E+00,-0.30954E+00,-0.31119E+00,-0.31281E+00, & + -0.31438E+00,-0.31592E+00,-0.31742E+00,-0.31889E+00,-0.32032E+00, & + -0.32173E+00,-0.32310E+00,-0.32444E+00,-0.32576E+00,-0.32705E+00, & + -0.32832E+00,-0.32955E+00,-0.33077E+00,-0.33196E+00,-0.33313E+00, & + -0.33428E+00,-0.33540E+00,-0.33651E+00,-0.33760E+00,-0.33867E+00, & + -0.33972E+00,-0.34075E+00,-0.34176E+00,-0.34276E+00,-0.34375E+00, & + -0.34472E+00,-0.34567E+00,-0.34661E+00,-0.34754E+00,-0.34845E+00, & + -0.34935E+00,-0.35024E+00,-0.35112E+00,-0.35198E+00,-0.35284E+00, & + -0.35368E+00,-0.35452E+00,-0.35534E+00,-0.35615E+00,-0.35696E+00, & + -0.35775E+00,-0.35854E+00,-0.35932E+00,-0.36009E+00,-0.36085E+00, & + -0.36161E+00,-0.36235E+00,-0.36309E+00,-0.36382E+00,-0.36455E+00, & + -0.36527E+00,-0.36598E+00,-0.36668E+00,-0.36738E+00,-0.36807E+00/ + + DATA (BNC03M (I),I=101,200)/ & + -0.36876E+00,-0.36943E+00,-0.37011E+00,-0.37077E+00,-0.37143E+00, & + -0.37209E+00,-0.37274E+00,-0.37338E+00,-0.37402E+00,-0.37465E+00, & + -0.37528E+00,-0.37590E+00,-0.37652E+00,-0.37713E+00,-0.37773E+00, & + -0.37833E+00,-0.37893E+00,-0.37952E+00,-0.38010E+00,-0.38068E+00, & + -0.38123E+00,-0.38180E+00,-0.38237E+00,-0.38293E+00,-0.38349E+00, & + -0.38404E+00,-0.38459E+00,-0.38513E+00,-0.38567E+00,-0.38621E+00, & + -0.38674E+00,-0.38726E+00,-0.38778E+00,-0.38830E+00,-0.38881E+00, & + -0.38931E+00,-0.38981E+00,-0.39031E+00,-0.39081E+00,-0.39130E+00, & + -0.39178E+00,-0.39226E+00,-0.39274E+00,-0.39321E+00,-0.39368E+00, & + -0.39415E+00,-0.39461E+00,-0.39507E+00,-0.39553E+00,-0.39598E+00, & + -0.39642E+00,-0.39687E+00,-0.39731E+00,-0.39775E+00,-0.39818E+00, & + -0.39861E+00,-0.39904E+00,-0.39946E+00,-0.39988E+00,-0.40030E+00, & + -0.40071E+00,-0.40112E+00,-0.40153E+00,-0.40193E+00,-0.40233E+00, & + -0.40273E+00,-0.40313E+00,-0.40352E+00,-0.40391E+00,-0.40430E+00, & + -0.40468E+00,-0.40506E+00,-0.40544E+00,-0.40582E+00,-0.40619E+00, & + -0.40656E+00,-0.40693E+00,-0.40729E+00,-0.40765E+00,-0.40801E+00, & + -0.40837E+00,-0.40872E+00,-0.40907E+00,-0.40942E+00,-0.40977E+00, & + -0.41011E+00,-0.41046E+00,-0.41080E+00,-0.41113E+00,-0.41147E+00, & + -0.41180E+00,-0.41213E+00,-0.41246E+00,-0.41278E+00,-0.41311E+00, & + -0.41343E+00,-0.41375E+00,-0.41407E+00,-0.41438E+00,-0.41469E+00/ + + DATA (BNC03M (I),I=201,300)/ & + -0.41500E+00,-0.41531E+00,-0.41562E+00,-0.41592E+00,-0.41622E+00, & + -0.41652E+00,-0.41682E+00,-0.41712E+00,-0.41741E+00,-0.41770E+00, & + -0.41799E+00,-0.41828E+00,-0.41857E+00,-0.41885E+00,-0.41914E+00, & + -0.41942E+00,-0.41970E+00,-0.41997E+00,-0.42025E+00,-0.42052E+00, & + -0.42079E+00,-0.42106E+00,-0.42133E+00,-0.42160E+00,-0.42186E+00, & + -0.42213E+00,-0.42239E+00,-0.42265E+00,-0.42290E+00,-0.42316E+00, & + -0.42342E+00,-0.42367E+00,-0.42392E+00,-0.42417E+00,-0.42442E+00, & + -0.42466E+00,-0.42491E+00,-0.42515E+00,-0.42539E+00,-0.42564E+00, & + -0.42587E+00,-0.42611E+00,-0.42635E+00,-0.42658E+00,-0.42681E+00, & + -0.42705E+00,-0.42728E+00,-0.42751E+00,-0.42773E+00,-0.42796E+00, & + -0.42818E+00,-0.42841E+00,-0.42863E+00,-0.42885E+00,-0.42907E+00, & + -0.42928E+00,-0.42950E+00,-0.42971E+00,-0.42993E+00,-0.43014E+00, & + -0.43035E+00,-0.43056E+00,-0.43077E+00,-0.43098E+00,-0.43118E+00, & + -0.43139E+00,-0.43159E+00,-0.43179E+00,-0.43199E+00,-0.43219E+00, & + -0.43239E+00,-0.43259E+00,-0.43278E+00,-0.43298E+00,-0.43317E+00, & + -0.43336E+00,-0.43355E+00,-0.43374E+00,-0.43393E+00,-0.43412E+00, & + -0.43430E+00,-0.43449E+00,-0.43467E+00,-0.43486E+00,-0.43504E+00, & + -0.43522E+00,-0.43540E+00,-0.43558E+00,-0.43576E+00,-0.43593E+00, & + -0.43611E+00,-0.43628E+00,-0.43645E+00,-0.43663E+00,-0.43680E+00, & + -0.43697E+00,-0.43714E+00,-0.43730E+00,-0.43747E+00,-0.43764E+00/ + + DATA (BNC03M (I),I=301,400)/ & + -0.43780E+00,-0.43797E+00,-0.43813E+00,-0.43829E+00,-0.43845E+00, & + -0.43861E+00,-0.43877E+00,-0.43893E+00,-0.43909E+00,-0.43924E+00, & + -0.43940E+00,-0.43955E+00,-0.43971E+00,-0.43986E+00,-0.44001E+00, & + -0.44016E+00,-0.44031E+00,-0.44046E+00,-0.44061E+00,-0.44075E+00, & + -0.44090E+00,-0.44104E+00,-0.44119E+00,-0.44133E+00,-0.44147E+00, & + -0.44161E+00,-0.44176E+00,-0.44190E+00,-0.44203E+00,-0.44217E+00, & + -0.44231E+00,-0.44245E+00,-0.44258E+00,-0.44272E+00,-0.44285E+00, & + -0.44298E+00,-0.44312E+00,-0.44325E+00,-0.44338E+00,-0.44351E+00, & + -0.44364E+00,-0.44377E+00,-0.44389E+00,-0.44402E+00,-0.44415E+00, & + -0.44427E+00,-0.44439E+00,-0.44452E+00,-0.44464E+00,-0.44476E+00, & + -0.44488E+00,-0.44500E+00,-0.44512E+00,-0.44524E+00,-0.44536E+00, & + -0.44548E+00,-0.44560E+00,-0.44571E+00,-0.44583E+00,-0.44594E+00, & + -0.44606E+00,-0.44617E+00,-0.44628E+00,-0.44639E+00,-0.44650E+00, & + -0.44661E+00,-0.44672E+00,-0.44683E+00,-0.44694E+00,-0.44705E+00, & + -0.44716E+00,-0.44726E+00,-0.44737E+00,-0.44747E+00,-0.44758E+00, & + -0.44768E+00,-0.44778E+00,-0.44789E+00,-0.44799E+00,-0.44809E+00, & + -0.44819E+00,-0.44829E+00,-0.44839E+00,-0.44848E+00,-0.44858E+00, & + -0.44868E+00,-0.44878E+00,-0.44887E+00,-0.44897E+00,-0.44906E+00, & + -0.44915E+00,-0.44925E+00,-0.44934E+00,-0.44943E+00,-0.44952E+00, & + -0.44961E+00,-0.44970E+00,-0.44979E+00,-0.44988E+00,-0.44997E+00/ + + DATA (BNC03M (I),I=401,500)/ & + -0.45006E+00,-0.45015E+00,-0.45023E+00,-0.45032E+00,-0.45040E+00, & + -0.45049E+00,-0.45057E+00,-0.45066E+00,-0.45074E+00,-0.45082E+00, & + -0.45091E+00,-0.45099E+00,-0.45107E+00,-0.45115E+00,-0.45123E+00, & + -0.45131E+00,-0.45139E+00,-0.45146E+00,-0.45154E+00,-0.45162E+00, & + -0.45170E+00,-0.45177E+00,-0.45185E+00,-0.45192E+00,-0.45200E+00, & + -0.45207E+00,-0.45214E+00,-0.45222E+00,-0.45229E+00,-0.45236E+00, & + -0.45243E+00,-0.45250E+00,-0.45257E+00,-0.45264E+00,-0.45271E+00, & + -0.45278E+00,-0.45285E+00,-0.45291E+00,-0.45298E+00,-0.45305E+00, & + -0.45311E+00,-0.45318E+00,-0.45325E+00,-0.45331E+00,-0.45337E+00, & + -0.45344E+00,-0.45350E+00,-0.45356E+00,-0.45363E+00,-0.45369E+00, & + -0.45375E+00,-0.45381E+00,-0.45387E+00,-0.45393E+00,-0.45399E+00, & + -0.45405E+00,-0.45411E+00,-0.45417E+00,-0.45422E+00,-0.45428E+00, & + -0.45434E+00,-0.45439E+00,-0.45445E+00,-0.45450E+00,-0.45456E+00, & + -0.45461E+00,-0.45467E+00,-0.45472E+00,-0.45477E+00,-0.45483E+00, & + -0.45488E+00,-0.45493E+00,-0.45498E+00,-0.45503E+00,-0.45508E+00, & + -0.45513E+00,-0.45518E+00,-0.45523E+00,-0.45528E+00,-0.45533E+00, & + -0.45538E+00,-0.45542E+00,-0.45547E+00,-0.45552E+00,-0.45556E+00, & + -0.45561E+00,-0.45566E+00,-0.45570E+00,-0.45575E+00,-0.45579E+00, & + -0.45583E+00,-0.45588E+00,-0.45592E+00,-0.45596E+00,-0.45600E+00, & + -0.45605E+00,-0.45609E+00,-0.45613E+00,-0.45617E+00,-0.45621E+00/ + + DATA (BNC03M (I),I=501,600)/ & + -0.45625E+00,-0.45629E+00,-0.45633E+00,-0.45637E+00,-0.45641E+00, & + -0.45644E+00,-0.45648E+00,-0.45652E+00,-0.45655E+00,-0.45659E+00, & + -0.45663E+00,-0.45666E+00,-0.45670E+00,-0.45673E+00,-0.45677E+00, & + -0.45680E+00,-0.45684E+00,-0.45687E+00,-0.45690E+00,-0.45693E+00, & + -0.45697E+00,-0.45700E+00,-0.45703E+00,-0.45706E+00,-0.45709E+00, & + -0.45712E+00,-0.45715E+00,-0.45718E+00,-0.45721E+00,-0.45724E+00, & + -0.45727E+00,-0.45730E+00,-0.45733E+00,-0.45736E+00,-0.45738E+00, & + -0.45741E+00,-0.45744E+00,-0.45746E+00,-0.45749E+00,-0.45751E+00, & + -0.45754E+00,-0.45757E+00,-0.45759E+00,-0.45761E+00,-0.45764E+00, & + -0.45766E+00,-0.45769E+00,-0.45771E+00,-0.45773E+00,-0.45775E+00, & + -0.45778E+00,-0.45780E+00,-0.45782E+00,-0.45784E+00,-0.45786E+00, & + -0.45788E+00,-0.45790E+00,-0.45792E+00,-0.45794E+00,-0.45796E+00, & + -0.45798E+00,-0.45800E+00,-0.45802E+00,-0.45803E+00,-0.45805E+00, & + -0.45807E+00,-0.45809E+00,-0.45810E+00,-0.45812E+00,-0.45814E+00, & + -0.45815E+00,-0.45817E+00,-0.45818E+00,-0.45820E+00,-0.45821E+00, & + -0.45823E+00,-0.45824E+00,-0.45825E+00,-0.45827E+00,-0.45828E+00, & + -0.45829E+00,-0.45831E+00,-0.45832E+00,-0.45833E+00,-0.45834E+00, & + -0.45835E+00,-0.45836E+00,-0.45838E+00,-0.45839E+00,-0.45840E+00, & + -0.45841E+00,-0.45842E+00,-0.45843E+00,-0.45843E+00,-0.45844E+00, & + -0.45845E+00,-0.45846E+00,-0.45847E+00,-0.45848E+00,-0.45850E+00/ + + DATA (BNC03M (I),I=601,700)/ & + -0.45855E+00,-0.45858E+00,-0.45858E+00,-0.45856E+00,-0.45852E+00, & + -0.45845E+00,-0.45836E+00,-0.45825E+00,-0.45812E+00,-0.45796E+00, & + -0.45779E+00,-0.45759E+00,-0.45738E+00,-0.45715E+00,-0.45690E+00, & + -0.45663E+00,-0.45634E+00,-0.45604E+00,-0.45573E+00,-0.45539E+00, & + -0.45504E+00,-0.45468E+00,-0.45430E+00,-0.45390E+00,-0.45350E+00, & + -0.45307E+00,-0.45264E+00,-0.45219E+00,-0.45173E+00,-0.45126E+00, & + -0.45077E+00,-0.45027E+00,-0.44976E+00,-0.44924E+00,-0.44871E+00, & + -0.44817E+00,-0.44762E+00,-0.44705E+00,-0.44648E+00,-0.44589E+00, & + -0.44530E+00,-0.44470E+00,-0.44408E+00,-0.44346E+00,-0.44283E+00, & + -0.44219E+00,-0.44154E+00,-0.44088E+00,-0.44022E+00,-0.43954E+00, & + -0.43886E+00,-0.43817E+00,-0.43747E+00,-0.43676E+00,-0.43605E+00, & + -0.43533E+00,-0.43460E+00,-0.43387E+00,-0.43313E+00,-0.43238E+00, & + -0.43162E+00,-0.43086E+00,-0.43009E+00,-0.42932E+00,-0.42854E+00, & + -0.42775E+00,-0.42695E+00,-0.42616E+00,-0.42535E+00,-0.42454E+00, & + -0.42372E+00,-0.42290E+00,-0.42207E+00,-0.42124E+00,-0.42040E+00, & + -0.41956E+00,-0.41871E+00,-0.41786E+00,-0.41700E+00,-0.41613E+00, & + -0.41527E+00,-0.41439E+00,-0.41351E+00,-0.41263E+00,-0.41175E+00, & + -0.41085E+00,-0.40996E+00,-0.40906E+00,-0.40815E+00,-0.40724E+00, & + -0.40633E+00,-0.40542E+00,-0.40449E+00,-0.40357E+00,-0.40264E+00, & + -0.40171E+00,-0.40077E+00,-0.39983E+00,-0.39889E+00,-0.39794E+00/ + + DATA (BNC03M(I),I=701,741)/ & + -0.39699E+00,-0.39604E+00,-0.39508E+00,-0.39412E+00,-0.39315E+00, & + -0.39218E+00,-0.39121E+00,-0.39024E+00,-0.38926E+00,-0.38828E+00, & + -0.38729E+00,-0.38630E+00,-0.38531E+00,-0.38432E+00,-0.38332E+00, & + -0.38232E+00,-0.38132E+00,-0.38032E+00,-0.37931E+00,-0.37830E+00, & + -0.37729E+00,-0.37627E+00,-0.37525E+00,-0.37423E+00,-0.37320E+00, & + -0.37218E+00,-0.37115E+00,-0.37012E+00,-0.36908E+00,-0.36804E+00, & + -0.36701E+00,-0.36596E+00,-0.36492E+00,-0.36387E+00,-0.36282E+00, & + -0.36177E+00,-0.36072E+00,-0.35967E+00,-0.35861E+00,-0.35755E+00, & + -0.35649E+00 & + / +! +! *** (NH4)2SO4 +! + DATA (BNC04M (I),I= 1,100)/ & + -0.10031E+00,-0.18257E+00,-0.24033E+00,-0.27955E+00,-0.30969E+00, & + -0.33432E+00,-0.35518E+00,-0.37330E+00,-0.38932E+00,-0.40369E+00, & + -0.41670E+00,-0.42860E+00,-0.43956E+00,-0.44971E+00,-0.45917E+00, & + -0.46801E+00,-0.47632E+00,-0.48414E+00,-0.49154E+00,-0.49856E+00, & + -0.50522E+00,-0.51157E+00,-0.51763E+00,-0.52342E+00,-0.52897E+00, & + -0.53428E+00,-0.53939E+00,-0.54431E+00,-0.54904E+00,-0.55361E+00, & + -0.55801E+00,-0.56226E+00,-0.56638E+00,-0.57036E+00,-0.57421E+00, & + -0.57795E+00,-0.58157E+00,-0.58509E+00,-0.58851E+00,-0.59183E+00, & + -0.59506E+00,-0.59820E+00,-0.60126E+00,-0.60424E+00,-0.60714E+00, & + -0.60997E+00,-0.61273E+00,-0.61542E+00,-0.61805E+00,-0.62062E+00, & + -0.62312E+00,-0.62557E+00,-0.62796E+00,-0.63030E+00,-0.63259E+00, & + -0.63484E+00,-0.63703E+00,-0.63918E+00,-0.64128E+00,-0.64334E+00, & + -0.64536E+00,-0.64734E+00,-0.64928E+00,-0.65119E+00,-0.65306E+00, & + -0.65489E+00,-0.65670E+00,-0.65847E+00,-0.66021E+00,-0.66191E+00, & + -0.66360E+00,-0.66525E+00,-0.66687E+00,-0.66847E+00,-0.67004E+00, & + -0.67159E+00,-0.67312E+00,-0.67462E+00,-0.67610E+00,-0.67756E+00, & + -0.67900E+00,-0.68042E+00,-0.68181E+00,-0.68319E+00,-0.68455E+00, & + -0.68590E+00,-0.68722E+00,-0.68853E+00,-0.68982E+00,-0.69109E+00, & + -0.69235E+00,-0.69360E+00,-0.69483E+00,-0.69604E+00,-0.69724E+00, & + -0.69843E+00,-0.69960E+00,-0.70076E+00,-0.70191E+00,-0.70304E+00/ + + DATA (BNC04M (I),I=101,200)/ & + -0.70417E+00,-0.70527E+00,-0.70637E+00,-0.70746E+00,-0.70853E+00, & + -0.70959E+00,-0.71064E+00,-0.71168E+00,-0.71271E+00,-0.71373E+00, & + -0.71473E+00,-0.71573E+00,-0.71672E+00,-0.71769E+00,-0.71866E+00, & + -0.71961E+00,-0.72056E+00,-0.72150E+00,-0.72242E+00,-0.72334E+00, & + -0.72420E+00,-0.72511E+00,-0.72600E+00,-0.72688E+00,-0.72776E+00, & + -0.72862E+00,-0.72948E+00,-0.73033E+00,-0.73116E+00,-0.73199E+00, & + -0.73282E+00,-0.73363E+00,-0.73443E+00,-0.73523E+00,-0.73602E+00, & + -0.73680E+00,-0.73757E+00,-0.73834E+00,-0.73909E+00,-0.73984E+00, & + -0.74059E+00,-0.74132E+00,-0.74205E+00,-0.74277E+00,-0.74348E+00, & + -0.74419E+00,-0.74489E+00,-0.74559E+00,-0.74627E+00,-0.74695E+00, & + -0.74763E+00,-0.74829E+00,-0.74896E+00,-0.74961E+00,-0.75026E+00, & + -0.75090E+00,-0.75154E+00,-0.75217E+00,-0.75280E+00,-0.75342E+00, & + -0.75403E+00,-0.75464E+00,-0.75524E+00,-0.75584E+00,-0.75643E+00, & + -0.75702E+00,-0.75760E+00,-0.75817E+00,-0.75874E+00,-0.75931E+00, & + -0.75987E+00,-0.76042E+00,-0.76098E+00,-0.76152E+00,-0.76206E+00, & + -0.76260E+00,-0.76313E+00,-0.76366E+00,-0.76418E+00,-0.76470E+00, & + -0.76521E+00,-0.76572E+00,-0.76622E+00,-0.76672E+00,-0.76722E+00, & + -0.76771E+00,-0.76820E+00,-0.76868E+00,-0.76916E+00,-0.76963E+00, & + -0.77010E+00,-0.77057E+00,-0.77103E+00,-0.77149E+00,-0.77194E+00, & + -0.77239E+00,-0.77284E+00,-0.77328E+00,-0.77372E+00,-0.77416E+00/ + + DATA (BNC04M (I),I=201,300)/ & + -0.77459E+00,-0.77502E+00,-0.77544E+00,-0.77587E+00,-0.77628E+00, & + -0.77670E+00,-0.77711E+00,-0.77751E+00,-0.77792E+00,-0.77832E+00, & + -0.77872E+00,-0.77911E+00,-0.77950E+00,-0.77989E+00,-0.78027E+00, & + -0.78065E+00,-0.78103E+00,-0.78140E+00,-0.78178E+00,-0.78214E+00, & + -0.78251E+00,-0.78287E+00,-0.78323E+00,-0.78359E+00,-0.78394E+00, & + -0.78429E+00,-0.78464E+00,-0.78498E+00,-0.78532E+00,-0.78566E+00, & + -0.78600E+00,-0.78633E+00,-0.78666E+00,-0.78699E+00,-0.78732E+00, & + -0.78764E+00,-0.78796E+00,-0.78827E+00,-0.78859E+00,-0.78890E+00, & + -0.78921E+00,-0.78952E+00,-0.78982E+00,-0.79012E+00,-0.79042E+00, & + -0.79072E+00,-0.79101E+00,-0.79130E+00,-0.79159E+00,-0.79188E+00, & + -0.79216E+00,-0.79245E+00,-0.79273E+00,-0.79300E+00,-0.79328E+00, & + -0.79355E+00,-0.79382E+00,-0.79409E+00,-0.79436E+00,-0.79462E+00, & + -0.79488E+00,-0.79514E+00,-0.79540E+00,-0.79566E+00,-0.79591E+00, & + -0.79616E+00,-0.79641E+00,-0.79666E+00,-0.79690E+00,-0.79714E+00, & + -0.79738E+00,-0.79762E+00,-0.79786E+00,-0.79809E+00,-0.79832E+00, & + -0.79855E+00,-0.79878E+00,-0.79901E+00,-0.79923E+00,-0.79946E+00, & + -0.79968E+00,-0.79990E+00,-0.80011E+00,-0.80033E+00,-0.80054E+00, & + -0.80075E+00,-0.80096E+00,-0.80117E+00,-0.80138E+00,-0.80158E+00, & + -0.80178E+00,-0.80198E+00,-0.80218E+00,-0.80238E+00,-0.80258E+00, & + -0.80277E+00,-0.80296E+00,-0.80315E+00,-0.80334E+00,-0.80353E+00/ + + DATA (BNC04M (I),I=301,400)/ & + -0.80371E+00,-0.80390E+00,-0.80408E+00,-0.80426E+00,-0.80444E+00, & + -0.80461E+00,-0.80479E+00,-0.80496E+00,-0.80513E+00,-0.80530E+00, & + -0.80547E+00,-0.80564E+00,-0.80581E+00,-0.80597E+00,-0.80613E+00, & + -0.80630E+00,-0.80646E+00,-0.80661E+00,-0.80677E+00,-0.80693E+00, & + -0.80708E+00,-0.80723E+00,-0.80738E+00,-0.80753E+00,-0.80768E+00, & + -0.80783E+00,-0.80797E+00,-0.80812E+00,-0.80826E+00,-0.80840E+00, & + -0.80854E+00,-0.80868E+00,-0.80881E+00,-0.80895E+00,-0.80908E+00, & + -0.80922E+00,-0.80935E+00,-0.80948E+00,-0.80961E+00,-0.80974E+00, & + -0.80986E+00,-0.80999E+00,-0.81011E+00,-0.81023E+00,-0.81035E+00, & + -0.81047E+00,-0.81059E+00,-0.81071E+00,-0.81082E+00,-0.81094E+00, & + -0.81105E+00,-0.81117E+00,-0.81128E+00,-0.81139E+00,-0.81150E+00, & + -0.81160E+00,-0.81171E+00,-0.81181E+00,-0.81192E+00,-0.81202E+00, & + -0.81212E+00,-0.81222E+00,-0.81232E+00,-0.81242E+00,-0.81252E+00, & + -0.81261E+00,-0.81271E+00,-0.81280E+00,-0.81289E+00,-0.81298E+00, & + -0.81307E+00,-0.81316E+00,-0.81325E+00,-0.81334E+00,-0.81342E+00, & + -0.81351E+00,-0.81359E+00,-0.81368E+00,-0.81376E+00,-0.81384E+00, & + -0.81392E+00,-0.81399E+00,-0.81407E+00,-0.81415E+00,-0.81422E+00, & + -0.81430E+00,-0.81437E+00,-0.81444E+00,-0.81451E+00,-0.81459E+00, & + -0.81465E+00,-0.81472E+00,-0.81479E+00,-0.81486E+00,-0.81492E+00, & + -0.81499E+00,-0.81505E+00,-0.81511E+00,-0.81517E+00,-0.81523E+00/ + + DATA (BNC04M (I),I=401,500)/ & + -0.81529E+00,-0.81535E+00,-0.81541E+00,-0.81547E+00,-0.81552E+00, & + -0.81558E+00,-0.81563E+00,-0.81568E+00,-0.81573E+00,-0.81579E+00, & + -0.81584E+00,-0.81589E+00,-0.81593E+00,-0.81598E+00,-0.81603E+00, & + -0.81607E+00,-0.81612E+00,-0.81616E+00,-0.81621E+00,-0.81625E+00, & + -0.81629E+00,-0.81633E+00,-0.81637E+00,-0.81641E+00,-0.81645E+00, & + -0.81648E+00,-0.81652E+00,-0.81656E+00,-0.81659E+00,-0.81662E+00, & + -0.81666E+00,-0.81669E+00,-0.81672E+00,-0.81675E+00,-0.81678E+00, & + -0.81681E+00,-0.81684E+00,-0.81687E+00,-0.81689E+00,-0.81692E+00, & + -0.81694E+00,-0.81697E+00,-0.81699E+00,-0.81701E+00,-0.81704E+00, & + -0.81706E+00,-0.81708E+00,-0.81710E+00,-0.81711E+00,-0.81713E+00, & + -0.81715E+00,-0.81717E+00,-0.81718E+00,-0.81720E+00,-0.81721E+00, & + -0.81723E+00,-0.81724E+00,-0.81725E+00,-0.81726E+00,-0.81727E+00, & + -0.81728E+00,-0.81729E+00,-0.81730E+00,-0.81731E+00,-0.81732E+00, & + -0.81732E+00,-0.81733E+00,-0.81733E+00,-0.81734E+00,-0.81734E+00, & + -0.81734E+00,-0.81735E+00,-0.81735E+00,-0.81735E+00,-0.81735E+00, & + -0.81735E+00,-0.81735E+00,-0.81734E+00,-0.81734E+00,-0.81734E+00, & + -0.81734E+00,-0.81733E+00,-0.81733E+00,-0.81732E+00,-0.81731E+00, & + -0.81731E+00,-0.81730E+00,-0.81729E+00,-0.81728E+00,-0.81727E+00, & + -0.81726E+00,-0.81725E+00,-0.81724E+00,-0.81723E+00,-0.81721E+00, & + -0.81720E+00,-0.81719E+00,-0.81717E+00,-0.81716E+00,-0.81714E+00/ + + DATA (BNC04M (I),I=501,600)/ & + -0.81712E+00,-0.81711E+00,-0.81709E+00,-0.81707E+00,-0.81705E+00, & + -0.81703E+00,-0.81701E+00,-0.81699E+00,-0.81697E+00,-0.81695E+00, & + -0.81693E+00,-0.81690E+00,-0.81688E+00,-0.81686E+00,-0.81683E+00, & + -0.81681E+00,-0.81678E+00,-0.81675E+00,-0.81673E+00,-0.81670E+00, & + -0.81667E+00,-0.81664E+00,-0.81661E+00,-0.81658E+00,-0.81655E+00, & + -0.81652E+00,-0.81649E+00,-0.81646E+00,-0.81642E+00,-0.81639E+00, & + -0.81636E+00,-0.81632E+00,-0.81629E+00,-0.81625E+00,-0.81622E+00, & + -0.81618E+00,-0.81614E+00,-0.81611E+00,-0.81607E+00,-0.81603E+00, & + -0.81599E+00,-0.81595E+00,-0.81591E+00,-0.81587E+00,-0.81583E+00, & + -0.81579E+00,-0.81575E+00,-0.81570E+00,-0.81566E+00,-0.81562E+00, & + -0.81557E+00,-0.81553E+00,-0.81548E+00,-0.81544E+00,-0.81539E+00, & + -0.81534E+00,-0.81530E+00,-0.81525E+00,-0.81520E+00,-0.81515E+00, & + -0.81510E+00,-0.81505E+00,-0.81500E+00,-0.81495E+00,-0.81490E+00, & + -0.81485E+00,-0.81480E+00,-0.81475E+00,-0.81469E+00,-0.81464E+00, & + -0.81459E+00,-0.81453E+00,-0.81448E+00,-0.81442E+00,-0.81437E+00, & + -0.81431E+00,-0.81425E+00,-0.81420E+00,-0.81414E+00,-0.81408E+00, & + -0.81402E+00,-0.81396E+00,-0.81391E+00,-0.81385E+00,-0.81379E+00, & + -0.81372E+00,-0.81366E+00,-0.81360E+00,-0.81354E+00,-0.81348E+00, & + -0.81341E+00,-0.81335E+00,-0.81329E+00,-0.81322E+00,-0.81316E+00, & + -0.81309E+00,-0.81303E+00,-0.81296E+00,-0.81290E+00,-0.81264E+00/ + + DATA (BNC04M (I),I=601,700)/ & + -0.81207E+00,-0.81133E+00,-0.81056E+00,-0.80975E+00,-0.80890E+00, & + -0.80801E+00,-0.80709E+00,-0.80614E+00,-0.80515E+00,-0.80414E+00, & + -0.80309E+00,-0.80201E+00,-0.80090E+00,-0.79977E+00,-0.79861E+00, & + -0.79742E+00,-0.79620E+00,-0.79496E+00,-0.79370E+00,-0.79241E+00, & + -0.79110E+00,-0.78976E+00,-0.78841E+00,-0.78703E+00,-0.78563E+00, & + -0.78421E+00,-0.78277E+00,-0.78131E+00,-0.77984E+00,-0.77834E+00, & + -0.77683E+00,-0.77529E+00,-0.77374E+00,-0.77218E+00,-0.77060E+00, & + -0.76900E+00,-0.76738E+00,-0.76575E+00,-0.76411E+00,-0.76245E+00, & + -0.76077E+00,-0.75908E+00,-0.75738E+00,-0.75566E+00,-0.75393E+00, & + -0.75219E+00,-0.75044E+00,-0.74867E+00,-0.74689E+00,-0.74510E+00, & + -0.74329E+00,-0.74148E+00,-0.73965E+00,-0.73781E+00,-0.73596E+00, & + -0.73411E+00,-0.73224E+00,-0.73036E+00,-0.72847E+00,-0.72657E+00, & + -0.72466E+00,-0.72274E+00,-0.72081E+00,-0.71887E+00,-0.71692E+00, & + -0.71497E+00,-0.71300E+00,-0.71103E+00,-0.70905E+00,-0.70706E+00, & + -0.70506E+00,-0.70306E+00,-0.70104E+00,-0.69902E+00,-0.69699E+00, & + -0.69496E+00,-0.69291E+00,-0.69086E+00,-0.68880E+00,-0.68674E+00, & + -0.68467E+00,-0.68259E+00,-0.68050E+00,-0.67841E+00,-0.67631E+00, & + -0.67421E+00,-0.67210E+00,-0.66998E+00,-0.66786E+00,-0.66573E+00, & + -0.66359E+00,-0.66145E+00,-0.65930E+00,-0.65715E+00,-0.65499E+00, & + -0.65283E+00,-0.65066E+00,-0.64849E+00,-0.64631E+00,-0.64413E+00/ + + DATA (BNC04M(I),I=701,741)/ & + -0.64194E+00,-0.63974E+00,-0.63755E+00,-0.63534E+00,-0.63313E+00, & + -0.63092E+00,-0.62870E+00,-0.62648E+00,-0.62425E+00,-0.62202E+00, & + -0.61979E+00,-0.61755E+00,-0.61530E+00,-0.61305E+00,-0.61080E+00, & + -0.60854E+00,-0.60628E+00,-0.60402E+00,-0.60175E+00,-0.59948E+00, & + -0.59720E+00,-0.59492E+00,-0.59264E+00,-0.59035E+00,-0.58806E+00, & + -0.58576E+00,-0.58346E+00,-0.58116E+00,-0.57886E+00,-0.57655E+00, & + -0.57424E+00,-0.57192E+00,-0.56960E+00,-0.56728E+00,-0.56496E+00, & + -0.56263E+00,-0.56030E+00,-0.55796E+00,-0.55562E+00,-0.55328E+00, & + -0.55094E+00 & + / +! +! *** NH4NO3 +! + DATA (BNC05M (I),I= 1,100)/ & + -0.50742E-01,-0.93469E-01,-0.12433E+00,-0.14581E+00,-0.16269E+00, & + -0.17676E+00,-0.18891E+00,-0.19965E+00,-0.20931E+00,-0.21811E+00, & + -0.22621E+00,-0.23373E+00,-0.24076E+00,-0.24737E+00,-0.25360E+00, & + -0.25952E+00,-0.26514E+00,-0.27051E+00,-0.27565E+00,-0.28058E+00, & + -0.28532E+00,-0.28989E+00,-0.29429E+00,-0.29855E+00,-0.30267E+00, & + -0.30666E+00,-0.31053E+00,-0.31429E+00,-0.31795E+00,-0.32150E+00, & + -0.32497E+00,-0.32834E+00,-0.33163E+00,-0.33484E+00,-0.33797E+00, & + -0.34103E+00,-0.34402E+00,-0.34694E+00,-0.34980E+00,-0.35260E+00, & + -0.35534E+00,-0.35802E+00,-0.36065E+00,-0.36322E+00,-0.36575E+00, & + -0.36823E+00,-0.37065E+00,-0.37304E+00,-0.37538E+00,-0.37767E+00, & + -0.37993E+00,-0.38215E+00,-0.38433E+00,-0.38647E+00,-0.38857E+00, & + -0.39065E+00,-0.39269E+00,-0.39469E+00,-0.39667E+00,-0.39861E+00, & + -0.40053E+00,-0.40242E+00,-0.40429E+00,-0.40613E+00,-0.40794E+00, & + -0.40973E+00,-0.41150E+00,-0.41324E+00,-0.41497E+00,-0.41668E+00, & + -0.41836E+00,-0.42003E+00,-0.42168E+00,-0.42332E+00,-0.42493E+00, & + -0.42654E+00,-0.42812E+00,-0.42970E+00,-0.43126E+00,-0.43281E+00, & + -0.43434E+00,-0.43587E+00,-0.43738E+00,-0.43888E+00,-0.44037E+00, & + -0.44186E+00,-0.44333E+00,-0.44479E+00,-0.44625E+00,-0.44769E+00, & + -0.44913E+00,-0.45056E+00,-0.45198E+00,-0.45339E+00,-0.45480E+00, & + -0.45619E+00,-0.45758E+00,-0.45897E+00,-0.46034E+00,-0.46171E+00/ + + DATA (BNC05M (I),I=101,200)/ & + -0.46308E+00,-0.46443E+00,-0.46578E+00,-0.46712E+00,-0.46846E+00, & + -0.46979E+00,-0.47111E+00,-0.47242E+00,-0.47373E+00,-0.47503E+00, & + -0.47633E+00,-0.47761E+00,-0.47889E+00,-0.48017E+00,-0.48144E+00, & + -0.48270E+00,-0.48395E+00,-0.48519E+00,-0.48643E+00,-0.48766E+00, & + -0.48879E+00,-0.49002E+00,-0.49124E+00,-0.49245E+00,-0.49366E+00, & + -0.49486E+00,-0.49605E+00,-0.49723E+00,-0.49840E+00,-0.49957E+00, & + -0.50073E+00,-0.50188E+00,-0.50303E+00,-0.50416E+00,-0.50529E+00, & + -0.50642E+00,-0.50753E+00,-0.50864E+00,-0.50975E+00,-0.51084E+00, & + -0.51193E+00,-0.51301E+00,-0.51409E+00,-0.51516E+00,-0.51622E+00, & + -0.51728E+00,-0.51833E+00,-0.51938E+00,-0.52042E+00,-0.52145E+00, & + -0.52247E+00,-0.52350E+00,-0.52451E+00,-0.52552E+00,-0.52652E+00, & + -0.52752E+00,-0.52851E+00,-0.52950E+00,-0.53048E+00,-0.53145E+00, & + -0.53242E+00,-0.53339E+00,-0.53434E+00,-0.53530E+00,-0.53625E+00, & + -0.53719E+00,-0.53813E+00,-0.53906E+00,-0.53999E+00,-0.54091E+00, & + -0.54183E+00,-0.54274E+00,-0.54365E+00,-0.54455E+00,-0.54545E+00, & + -0.54634E+00,-0.54723E+00,-0.54811E+00,-0.54899E+00,-0.54986E+00, & + -0.55073E+00,-0.55160E+00,-0.55246E+00,-0.55332E+00,-0.55417E+00, & + -0.55502E+00,-0.55586E+00,-0.55670E+00,-0.55753E+00,-0.55836E+00, & + -0.55919E+00,-0.56001E+00,-0.56083E+00,-0.56164E+00,-0.56245E+00, & + -0.56325E+00,-0.56405E+00,-0.56485E+00,-0.56565E+00,-0.56643E+00/ + + DATA (BNC05M (I),I=201,300)/ & + -0.56722E+00,-0.56800E+00,-0.56878E+00,-0.56955E+00,-0.57032E+00, & + -0.57109E+00,-0.57185E+00,-0.57261E+00,-0.57336E+00,-0.57411E+00, & + -0.57486E+00,-0.57561E+00,-0.57635E+00,-0.57708E+00,-0.57782E+00, & + -0.57854E+00,-0.57927E+00,-0.57999E+00,-0.58071E+00,-0.58143E+00, & + -0.58214E+00,-0.58285E+00,-0.58356E+00,-0.58426E+00,-0.58496E+00, & + -0.58565E+00,-0.58634E+00,-0.58703E+00,-0.58772E+00,-0.58840E+00, & + -0.58908E+00,-0.58976E+00,-0.59043E+00,-0.59110E+00,-0.59177E+00, & + -0.59243E+00,-0.59309E+00,-0.59375E+00,-0.59441E+00,-0.59506E+00, & + -0.59571E+00,-0.59635E+00,-0.59700E+00,-0.59764E+00,-0.59827E+00, & + -0.59891E+00,-0.59954E+00,-0.60017E+00,-0.60079E+00,-0.60141E+00, & + -0.60203E+00,-0.60265E+00,-0.60327E+00,-0.60388E+00,-0.60449E+00, & + -0.60509E+00,-0.60570E+00,-0.60630E+00,-0.60690E+00,-0.60749E+00, & + -0.60808E+00,-0.60868E+00,-0.60926E+00,-0.60985E+00,-0.61043E+00, & + -0.61101E+00,-0.61159E+00,-0.61216E+00,-0.61274E+00,-0.61331E+00, & + -0.61387E+00,-0.61444E+00,-0.61500E+00,-0.61556E+00,-0.61612E+00, & + -0.61667E+00,-0.61723E+00,-0.61778E+00,-0.61832E+00,-0.61887E+00, & + -0.61941E+00,-0.61995E+00,-0.62049E+00,-0.62103E+00,-0.62156E+00, & + -0.62209E+00,-0.62262E+00,-0.62315E+00,-0.62368E+00,-0.62420E+00, & + -0.62472E+00,-0.62524E+00,-0.62575E+00,-0.62627E+00,-0.62678E+00, & + -0.62729E+00,-0.62780E+00,-0.62830E+00,-0.62880E+00,-0.62931E+00/ + + DATA (BNC05M (I),I=301,400)/ & + -0.62980E+00,-0.63030E+00,-0.63080E+00,-0.63129E+00,-0.63178E+00, & + -0.63227E+00,-0.63275E+00,-0.63324E+00,-0.63372E+00,-0.63420E+00, & + -0.63468E+00,-0.63516E+00,-0.63563E+00,-0.63610E+00,-0.63657E+00, & + -0.63704E+00,-0.63751E+00,-0.63797E+00,-0.63844E+00,-0.63890E+00, & + -0.63936E+00,-0.63981E+00,-0.64027E+00,-0.64072E+00,-0.64117E+00, & + -0.64162E+00,-0.64207E+00,-0.64252E+00,-0.64296E+00,-0.64340E+00, & + -0.64385E+00,-0.64428E+00,-0.64472E+00,-0.64516E+00,-0.64559E+00, & + -0.64602E+00,-0.64645E+00,-0.64688E+00,-0.64731E+00,-0.64773E+00, & + -0.64815E+00,-0.64857E+00,-0.64899E+00,-0.64941E+00,-0.64983E+00, & + -0.65024E+00,-0.65066E+00,-0.65107E+00,-0.65148E+00,-0.65188E+00, & + -0.65229E+00,-0.65269E+00,-0.65310E+00,-0.65350E+00,-0.65390E+00, & + -0.65430E+00,-0.65469E+00,-0.65509E+00,-0.65548E+00,-0.65587E+00, & + -0.65626E+00,-0.65665E+00,-0.65704E+00,-0.65742E+00,-0.65781E+00, & + -0.65819E+00,-0.65857E+00,-0.65895E+00,-0.65933E+00,-0.65971E+00, & + -0.66008E+00,-0.66045E+00,-0.66083E+00,-0.66120E+00,-0.66157E+00, & + -0.66193E+00,-0.66230E+00,-0.66266E+00,-0.66303E+00,-0.66339E+00, & + -0.66375E+00,-0.66411E+00,-0.66447E+00,-0.66482E+00,-0.66518E+00, & + -0.66553E+00,-0.66588E+00,-0.66623E+00,-0.66658E+00,-0.66693E+00, & + -0.66727E+00,-0.66762E+00,-0.66796E+00,-0.66831E+00,-0.66865E+00, & + -0.66899E+00,-0.66932E+00,-0.66966E+00,-0.67000E+00,-0.67033E+00/ + + DATA (BNC05M (I),I=401,500)/ & + -0.67066E+00,-0.67100E+00,-0.67133E+00,-0.67166E+00,-0.67198E+00, & + -0.67231E+00,-0.67263E+00,-0.67296E+00,-0.67328E+00,-0.67360E+00, & + -0.67392E+00,-0.67424E+00,-0.67456E+00,-0.67488E+00,-0.67519E+00, & + -0.67551E+00,-0.67582E+00,-0.67613E+00,-0.67644E+00,-0.67675E+00, & + -0.67706E+00,-0.67736E+00,-0.67767E+00,-0.67797E+00,-0.67828E+00, & + -0.67858E+00,-0.67888E+00,-0.67918E+00,-0.67948E+00,-0.67977E+00, & + -0.68007E+00,-0.68037E+00,-0.68066E+00,-0.68095E+00,-0.68124E+00, & + -0.68153E+00,-0.68182E+00,-0.68211E+00,-0.68240E+00,-0.68268E+00, & + -0.68297E+00,-0.68325E+00,-0.68353E+00,-0.68382E+00,-0.68410E+00, & + -0.68438E+00,-0.68465E+00,-0.68493E+00,-0.68521E+00,-0.68548E+00, & + -0.68576E+00,-0.68603E+00,-0.68630E+00,-0.68657E+00,-0.68684E+00, & + -0.68711E+00,-0.68738E+00,-0.68764E+00,-0.68791E+00,-0.68817E+00, & + -0.68844E+00,-0.68870E+00,-0.68896E+00,-0.68922E+00,-0.68948E+00, & + -0.68974E+00,-0.69000E+00,-0.69025E+00,-0.69051E+00,-0.69076E+00, & + -0.69102E+00,-0.69127E+00,-0.69152E+00,-0.69177E+00,-0.69202E+00, & + -0.69227E+00,-0.69252E+00,-0.69276E+00,-0.69301E+00,-0.69325E+00, & + -0.69350E+00,-0.69374E+00,-0.69398E+00,-0.69422E+00,-0.69446E+00, & + -0.69470E+00,-0.69494E+00,-0.69517E+00,-0.69541E+00,-0.69565E+00, & + -0.69588E+00,-0.69611E+00,-0.69635E+00,-0.69658E+00,-0.69681E+00, & + -0.69704E+00,-0.69727E+00,-0.69749E+00,-0.69772E+00,-0.69795E+00/ + + DATA (BNC05M (I),I=501,600)/ & + -0.69817E+00,-0.69840E+00,-0.69862E+00,-0.69884E+00,-0.69907E+00, & + -0.69929E+00,-0.69951E+00,-0.69973E+00,-0.69994E+00,-0.70016E+00, & + -0.70038E+00,-0.70059E+00,-0.70081E+00,-0.70102E+00,-0.70124E+00, & + -0.70145E+00,-0.70166E+00,-0.70187E+00,-0.70208E+00,-0.70229E+00, & + -0.70250E+00,-0.70271E+00,-0.70291E+00,-0.70312E+00,-0.70332E+00, & + -0.70353E+00,-0.70373E+00,-0.70393E+00,-0.70413E+00,-0.70434E+00, & + -0.70454E+00,-0.70474E+00,-0.70493E+00,-0.70513E+00,-0.70533E+00, & + -0.70552E+00,-0.70572E+00,-0.70592E+00,-0.70611E+00,-0.70630E+00, & + -0.70649E+00,-0.70669E+00,-0.70688E+00,-0.70707E+00,-0.70726E+00, & + -0.70744E+00,-0.70763E+00,-0.70782E+00,-0.70801E+00,-0.70819E+00, & + -0.70838E+00,-0.70856E+00,-0.70874E+00,-0.70893E+00,-0.70911E+00, & + -0.70929E+00,-0.70947E+00,-0.70965E+00,-0.70983E+00,-0.71001E+00, & + -0.71018E+00,-0.71036E+00,-0.71054E+00,-0.71071E+00,-0.71089E+00, & + -0.71106E+00,-0.71123E+00,-0.71141E+00,-0.71158E+00,-0.71175E+00, & + -0.71192E+00,-0.71209E+00,-0.71226E+00,-0.71243E+00,-0.71259E+00, & + -0.71276E+00,-0.71293E+00,-0.71309E+00,-0.71326E+00,-0.71342E+00, & + -0.71359E+00,-0.71375E+00,-0.71391E+00,-0.71407E+00,-0.71423E+00, & + -0.71439E+00,-0.71455E+00,-0.71471E+00,-0.71487E+00,-0.71503E+00, & + -0.71519E+00,-0.71534E+00,-0.71550E+00,-0.71565E+00,-0.71581E+00, & + -0.71596E+00,-0.71611E+00,-0.71627E+00,-0.71642E+00,-0.71698E+00/ + + DATA (BNC05M (I),I=601,700)/ & + -0.71819E+00,-0.71960E+00,-0.72096E+00,-0.72225E+00,-0.72349E+00, & + -0.72467E+00,-0.72581E+00,-0.72689E+00,-0.72792E+00,-0.72891E+00, & + -0.72985E+00,-0.73074E+00,-0.73159E+00,-0.73240E+00,-0.73316E+00, & + -0.73389E+00,-0.73457E+00,-0.73522E+00,-0.73583E+00,-0.73640E+00, & + -0.73694E+00,-0.73744E+00,-0.73791E+00,-0.73835E+00,-0.73875E+00, & + -0.73912E+00,-0.73947E+00,-0.73978E+00,-0.74006E+00,-0.74032E+00, & + -0.74055E+00,-0.74075E+00,-0.74093E+00,-0.74107E+00,-0.74120E+00, & + -0.74130E+00,-0.74137E+00,-0.74142E+00,-0.74145E+00,-0.74146E+00, & + -0.74144E+00,-0.74141E+00,-0.74135E+00,-0.74127E+00,-0.74117E+00, & + -0.74105E+00,-0.74092E+00,-0.74076E+00,-0.74058E+00,-0.74039E+00, & + -0.74018E+00,-0.73995E+00,-0.73971E+00,-0.73945E+00,-0.73917E+00, & + -0.73887E+00,-0.73856E+00,-0.73824E+00,-0.73790E+00,-0.73754E+00, & + -0.73717E+00,-0.73679E+00,-0.73639E+00,-0.73598E+00,-0.73555E+00, & + -0.73512E+00,-0.73466E+00,-0.73420E+00,-0.73372E+00,-0.73324E+00, & + -0.73273E+00,-0.73222E+00,-0.73170E+00,-0.73116E+00,-0.73062E+00, & + -0.73006E+00,-0.72949E+00,-0.72891E+00,-0.72832E+00,-0.72772E+00, & + -0.72711E+00,-0.72649E+00,-0.72587E+00,-0.72523E+00,-0.72458E+00, & + -0.72392E+00,-0.72325E+00,-0.72258E+00,-0.72190E+00,-0.72120E+00, & + -0.72050E+00,-0.71979E+00,-0.71908E+00,-0.71835E+00,-0.71762E+00, & + -0.71687E+00,-0.71613E+00,-0.71537E+00,-0.71460E+00,-0.71383E+00/ + + DATA (BNC05M(I),I=701,741)/ & + -0.71305E+00,-0.71227E+00,-0.71148E+00,-0.71068E+00,-0.70987E+00, & + -0.70906E+00,-0.70824E+00,-0.70741E+00,-0.70658E+00,-0.70574E+00, & + -0.70490E+00,-0.70404E+00,-0.70319E+00,-0.70232E+00,-0.70146E+00, & + -0.70058E+00,-0.69970E+00,-0.69882E+00,-0.69792E+00,-0.69703E+00, & + -0.69613E+00,-0.69522E+00,-0.69431E+00,-0.69339E+00,-0.69247E+00, & + -0.69154E+00,-0.69061E+00,-0.68967E+00,-0.68873E+00,-0.68778E+00, & + -0.68683E+00,-0.68588E+00,-0.68492E+00,-0.68395E+00,-0.68298E+00, & + -0.68201E+00,-0.68103E+00,-0.68005E+00,-0.67907E+00,-0.67808E+00, & + -0.67708E+00 & + / +! +! *** NH4Cl +! + DATA (BNC06M (I),I= 1,100)/ & + -0.49530E-01,-0.88966E-01,-0.11577E+00,-0.13342E+00,-0.14661E+00, & + -0.15709E+00,-0.16574E+00,-0.17306E+00,-0.17936E+00,-0.18486E+00, & + -0.18971E+00,-0.19402E+00,-0.19789E+00,-0.20137E+00,-0.20452E+00, & + -0.20738E+00,-0.20999E+00,-0.21238E+00,-0.21457E+00,-0.21658E+00, & + -0.21843E+00,-0.22014E+00,-0.22171E+00,-0.22317E+00,-0.22451E+00, & + -0.22576E+00,-0.22692E+00,-0.22799E+00,-0.22898E+00,-0.22990E+00, & + -0.23075E+00,-0.23154E+00,-0.23228E+00,-0.23295E+00,-0.23358E+00, & + -0.23417E+00,-0.23470E+00,-0.23520E+00,-0.23566E+00,-0.23608E+00, & + -0.23647E+00,-0.23683E+00,-0.23716E+00,-0.23746E+00,-0.23773E+00, & + -0.23797E+00,-0.23820E+00,-0.23840E+00,-0.23857E+00,-0.23873E+00, & + -0.23887E+00,-0.23899E+00,-0.23909E+00,-0.23918E+00,-0.23925E+00, & + -0.23930E+00,-0.23934E+00,-0.23936E+00,-0.23937E+00,-0.23936E+00, & + -0.23935E+00,-0.23932E+00,-0.23927E+00,-0.23922E+00,-0.23915E+00, & + -0.23907E+00,-0.23898E+00,-0.23888E+00,-0.23877E+00,-0.23864E+00, & + -0.23851E+00,-0.23836E+00,-0.23821E+00,-0.23804E+00,-0.23787E+00, & + -0.23768E+00,-0.23748E+00,-0.23727E+00,-0.23706E+00,-0.23683E+00, & + -0.23659E+00,-0.23635E+00,-0.23609E+00,-0.23582E+00,-0.23555E+00, & + -0.23526E+00,-0.23497E+00,-0.23466E+00,-0.23435E+00,-0.23403E+00, & + -0.23370E+00,-0.23336E+00,-0.23302E+00,-0.23266E+00,-0.23230E+00, & + -0.23193E+00,-0.23155E+00,-0.23116E+00,-0.23076E+00,-0.23036E+00/ + + DATA (BNC06M (I),I=101,200)/ & + -0.22995E+00,-0.22954E+00,-0.22912E+00,-0.22869E+00,-0.22825E+00, & + -0.22781E+00,-0.22737E+00,-0.22692E+00,-0.22646E+00,-0.22600E+00, & + -0.22553E+00,-0.22506E+00,-0.22458E+00,-0.22410E+00,-0.22361E+00, & + -0.22312E+00,-0.22263E+00,-0.22213E+00,-0.22163E+00,-0.22112E+00, & + -0.22068E+00,-0.22017E+00,-0.21964E+00,-0.21912E+00,-0.21859E+00, & + -0.21807E+00,-0.21754E+00,-0.21700E+00,-0.21647E+00,-0.21594E+00, & + -0.21540E+00,-0.21486E+00,-0.21432E+00,-0.21378E+00,-0.21323E+00, & + -0.21269E+00,-0.21214E+00,-0.21159E+00,-0.21104E+00,-0.21049E+00, & + -0.20994E+00,-0.20939E+00,-0.20883E+00,-0.20828E+00,-0.20772E+00, & + -0.20716E+00,-0.20660E+00,-0.20604E+00,-0.20548E+00,-0.20492E+00, & + -0.20435E+00,-0.20379E+00,-0.20322E+00,-0.20266E+00,-0.20209E+00, & + -0.20152E+00,-0.20096E+00,-0.20039E+00,-0.19982E+00,-0.19925E+00, & + -0.19867E+00,-0.19810E+00,-0.19753E+00,-0.19696E+00,-0.19638E+00, & + -0.19581E+00,-0.19523E+00,-0.19466E+00,-0.19408E+00,-0.19351E+00, & + -0.19293E+00,-0.19235E+00,-0.19177E+00,-0.19119E+00,-0.19062E+00, & + -0.19004E+00,-0.18946E+00,-0.18888E+00,-0.18830E+00,-0.18772E+00, & + -0.18714E+00,-0.18656E+00,-0.18597E+00,-0.18539E+00,-0.18481E+00, & + -0.18423E+00,-0.18365E+00,-0.18306E+00,-0.18248E+00,-0.18190E+00, & + -0.18131E+00,-0.18073E+00,-0.18015E+00,-0.17956E+00,-0.17898E+00, & + -0.17840E+00,-0.17781E+00,-0.17723E+00,-0.17665E+00,-0.17606E+00/ + + DATA (BNC06M (I),I=201,300)/ & + -0.17548E+00,-0.17489E+00,-0.17431E+00,-0.17372E+00,-0.17314E+00, & + -0.17256E+00,-0.17197E+00,-0.17139E+00,-0.17080E+00,-0.17022E+00, & + -0.16964E+00,-0.16905E+00,-0.16847E+00,-0.16788E+00,-0.16730E+00, & + -0.16672E+00,-0.16613E+00,-0.16555E+00,-0.16496E+00,-0.16438E+00, & + -0.16380E+00,-0.16321E+00,-0.16263E+00,-0.16205E+00,-0.16146E+00, & + -0.16088E+00,-0.16030E+00,-0.15972E+00,-0.15913E+00,-0.15855E+00, & + -0.15797E+00,-0.15739E+00,-0.15681E+00,-0.15622E+00,-0.15564E+00, & + -0.15506E+00,-0.15448E+00,-0.15390E+00,-0.15332E+00,-0.15274E+00, & + -0.15216E+00,-0.15158E+00,-0.15100E+00,-0.15042E+00,-0.14984E+00, & + -0.14926E+00,-0.14868E+00,-0.14810E+00,-0.14752E+00,-0.14695E+00, & + -0.14637E+00,-0.14579E+00,-0.14521E+00,-0.14464E+00,-0.14406E+00, & + -0.14348E+00,-0.14291E+00,-0.14233E+00,-0.14175E+00,-0.14118E+00, & + -0.14060E+00,-0.14003E+00,-0.13945E+00,-0.13888E+00,-0.13831E+00, & + -0.13773E+00,-0.13716E+00,-0.13658E+00,-0.13601E+00,-0.13544E+00, & + -0.13487E+00,-0.13429E+00,-0.13372E+00,-0.13315E+00,-0.13258E+00, & + -0.13201E+00,-0.13144E+00,-0.13087E+00,-0.13030E+00,-0.12973E+00, & + -0.12916E+00,-0.12859E+00,-0.12802E+00,-0.12746E+00,-0.12689E+00, & + -0.12632E+00,-0.12575E+00,-0.12519E+00,-0.12462E+00,-0.12405E+00, & + -0.12349E+00,-0.12292E+00,-0.12236E+00,-0.12179E+00,-0.12123E+00, & + -0.12066E+00,-0.12010E+00,-0.11954E+00,-0.11897E+00,-0.11841E+00/ + + DATA (BNC06M (I),I=301,400)/ & + -0.11785E+00,-0.11729E+00,-0.11672E+00,-0.11616E+00,-0.11560E+00, & + -0.11504E+00,-0.11448E+00,-0.11392E+00,-0.11336E+00,-0.11280E+00, & + -0.11224E+00,-0.11169E+00,-0.11113E+00,-0.11057E+00,-0.11001E+00, & + -0.10945E+00,-0.10890E+00,-0.10834E+00,-0.10779E+00,-0.10723E+00, & + -0.10668E+00,-0.10612E+00,-0.10557E+00,-0.10501E+00,-0.10446E+00, & + -0.10391E+00,-0.10335E+00,-0.10280E+00,-0.10225E+00,-0.10170E+00, & + -0.10114E+00,-0.10059E+00,-0.10004E+00,-0.99493E-01,-0.98943E-01, & + -0.98393E-01,-0.97844E-01,-0.97295E-01,-0.96747E-01,-0.96199E-01, & + -0.95651E-01,-0.95104E-01,-0.94557E-01,-0.94010E-01,-0.93464E-01, & + -0.92918E-01,-0.92373E-01,-0.91828E-01,-0.91283E-01,-0.90739E-01, & + -0.90195E-01,-0.89652E-01,-0.89109E-01,-0.88566E-01,-0.88023E-01, & + -0.87481E-01,-0.86940E-01,-0.86399E-01,-0.85858E-01,-0.85317E-01, & + -0.84777E-01,-0.84238E-01,-0.83698E-01,-0.83159E-01,-0.82621E-01, & + -0.82083E-01,-0.81545E-01,-0.81007E-01,-0.80470E-01,-0.79934E-01, & + -0.79397E-01,-0.78861E-01,-0.78326E-01,-0.77791E-01,-0.77256E-01, & + -0.76722E-01,-0.76188E-01,-0.75654E-01,-0.75121E-01,-0.74588E-01, & + -0.74055E-01,-0.73523E-01,-0.72992E-01,-0.72460E-01,-0.71929E-01, & + -0.71399E-01,-0.70868E-01,-0.70339E-01,-0.69809E-01,-0.69280E-01, & + -0.68751E-01,-0.68223E-01,-0.67695E-01,-0.67167E-01,-0.66640E-01, & + -0.66113E-01,-0.65587E-01,-0.65061E-01,-0.64535E-01,-0.64010E-01/ + + DATA (BNC06M (I),I=401,500)/ & + -0.63485E-01,-0.62960E-01,-0.62436E-01,-0.61912E-01,-0.61389E-01, & + -0.60866E-01,-0.60343E-01,-0.59821E-01,-0.59299E-01,-0.58777E-01, & + -0.58256E-01,-0.57735E-01,-0.57214E-01,-0.56694E-01,-0.56174E-01, & + -0.55655E-01,-0.55136E-01,-0.54617E-01,-0.54099E-01,-0.53581E-01, & + -0.53064E-01,-0.52547E-01,-0.52030E-01,-0.51513E-01,-0.50997E-01, & + -0.50482E-01,-0.49966E-01,-0.49451E-01,-0.48937E-01,-0.48422E-01, & + -0.47908E-01,-0.47395E-01,-0.46882E-01,-0.46369E-01,-0.45857E-01, & + -0.45345E-01,-0.44833E-01,-0.44321E-01,-0.43811E-01,-0.43300E-01, & + -0.42790E-01,-0.42280E-01,-0.41770E-01,-0.41261E-01,-0.40752E-01, & + -0.40244E-01,-0.39736E-01,-0.39228E-01,-0.38720E-01,-0.38213E-01, & + -0.37707E-01,-0.37200E-01,-0.36694E-01,-0.36189E-01,-0.35684E-01, & + -0.35179E-01,-0.34674E-01,-0.34170E-01,-0.33666E-01,-0.33163E-01, & + -0.32659E-01,-0.32157E-01,-0.31654E-01,-0.31152E-01,-0.30650E-01, & + -0.30149E-01,-0.29648E-01,-0.29147E-01,-0.28647E-01,-0.28147E-01, & + -0.27647E-01,-0.27148E-01,-0.26649E-01,-0.26150E-01,-0.25652E-01, & + -0.25154E-01,-0.24657E-01,-0.24159E-01,-0.23662E-01,-0.23166E-01, & + -0.22670E-01,-0.22174E-01,-0.21678E-01,-0.21183E-01,-0.20688E-01, & + -0.20194E-01,-0.19700E-01,-0.19206E-01,-0.18712E-01,-0.18219E-01, & + -0.17726E-01,-0.17234E-01,-0.16742E-01,-0.16250E-01,-0.15758E-01, & + -0.15267E-01,-0.14777E-01,-0.14286E-01,-0.13796E-01,-0.13306E-01/ + + DATA (BNC06M (I),I=501,600)/ & + -0.12817E-01,-0.12328E-01,-0.11839E-01,-0.11350E-01,-0.10862E-01, & + -0.10374E-01,-0.98870E-02,-0.93998E-02,-0.89130E-02,-0.84266E-02, & + -0.79404E-02,-0.74546E-02,-0.69691E-02,-0.64839E-02,-0.59991E-02, & + -0.55146E-02,-0.50304E-02,-0.45465E-02,-0.40630E-02,-0.35797E-02, & + -0.30969E-02,-0.26142E-02,-0.21320E-02,-0.16501E-02,-0.11685E-02, & + -0.68724E-03,-0.20627E-03, 0.27439E-03, 0.75471E-03, 0.12347E-02, & + 0.17144E-02, 0.21938E-02, 0.26728E-02, 0.31515E-02, 0.36300E-02, & + 0.41080E-02, 0.45858E-02, 0.50633E-02, 0.55405E-02, 0.60173E-02, & + 0.64938E-02, 0.69700E-02, 0.74459E-02, 0.79215E-02, 0.83968E-02, & + 0.88718E-02, 0.93464E-02, 0.98208E-02, 0.10295E-01, 0.10768E-01, & + 0.11242E-01, 0.11715E-01, 0.12188E-01, 0.12660E-01, 0.13132E-01, & + 0.13604E-01, 0.14076E-01, 0.14547E-01, 0.15018E-01, 0.15489E-01, & + 0.15959E-01, 0.16429E-01, 0.16899E-01, 0.17368E-01, 0.17837E-01, & + 0.18306E-01, 0.18775E-01, 0.19243E-01, 0.19711E-01, 0.20179E-01, & + 0.20646E-01, 0.21113E-01, 0.21580E-01, 0.22046E-01, 0.22512E-01, & + 0.22978E-01, 0.23444E-01, 0.23909E-01, 0.24374E-01, 0.24838E-01, & + 0.25303E-01, 0.25767E-01, 0.26231E-01, 0.26694E-01, 0.27157E-01, & + 0.27620E-01, 0.28083E-01, 0.28545E-01, 0.29007E-01, 0.29469E-01, & + 0.29930E-01, 0.30391E-01, 0.30852E-01, 0.31313E-01, 0.31773E-01, & + 0.32233E-01, 0.32693E-01, 0.33152E-01, 0.33611E-01, 0.35330E-01/ + + DATA (BNC06M (I),I=601,700)/ & + 0.39099E-01, 0.43640E-01, 0.48154E-01, 0.52641E-01, 0.57101E-01, & + 0.61535E-01, 0.65943E-01, 0.70325E-01, 0.74682E-01, 0.79014E-01, & + 0.83322E-01, 0.87606E-01, 0.91866E-01, 0.96102E-01, 0.10032E+00, & + 0.10451E+00, 0.10868E+00, 0.11282E+00, 0.11695E+00, 0.12105E+00, & + 0.12514E+00, 0.12920E+00, 0.13324E+00, 0.13726E+00, 0.14127E+00, & + 0.14525E+00, 0.14921E+00, 0.15316E+00, 0.15709E+00, 0.16099E+00, & + 0.16488E+00, 0.16876E+00, 0.17261E+00, 0.17645E+00, 0.18027E+00, & + 0.18407E+00, 0.18786E+00, 0.19163E+00, 0.19538E+00, 0.19912E+00, & + 0.20284E+00, 0.20655E+00, 0.21024E+00, 0.21391E+00, 0.21757E+00, & + 0.22122E+00, 0.22485E+00, 0.22847E+00, 0.23207E+00, 0.23566E+00, & + 0.23924E+00, 0.24280E+00, 0.24634E+00, 0.24988E+00, 0.25340E+00, & + 0.25691E+00, 0.26040E+00, 0.26389E+00, 0.26735E+00, 0.27081E+00, & + 0.27426E+00, 0.27769E+00, 0.28111E+00, 0.28452E+00, 0.28792E+00, & + 0.29130E+00, 0.29468E+00, 0.29804E+00, 0.30139E+00, 0.30473E+00, & + 0.30806E+00, 0.31138E+00, 0.31469E+00, 0.31799E+00, 0.32127E+00, & + 0.32455E+00, 0.32782E+00, 0.33107E+00, 0.33432E+00, 0.33756E+00, & + 0.34078E+00, 0.34400E+00, 0.34721E+00, 0.35040E+00, 0.35359E+00, & + 0.35677E+00, 0.35994E+00, 0.36310E+00, 0.36625E+00, 0.36940E+00, & + 0.37253E+00, 0.37565E+00, 0.37877E+00, 0.38188E+00, 0.38498E+00, & + 0.38807E+00, 0.39115E+00, 0.39422E+00, 0.39729E+00, 0.40035E+00/ + + DATA (BNC06M(I),I=701,741)/ & + 0.40340E+00, 0.40644E+00, 0.40947E+00, 0.41250E+00, 0.41552E+00, & + 0.41853E+00, 0.42153E+00, 0.42453E+00, 0.42752E+00, 0.43050E+00, & + 0.43347E+00, 0.43644E+00, 0.43939E+00, 0.44235E+00, 0.44529E+00, & + 0.44823E+00, 0.45116E+00, 0.45408E+00, 0.45700E+00, 0.45991E+00, & + 0.46281E+00, 0.46571E+00, 0.46860E+00, 0.47148E+00, 0.47436E+00, & + 0.47723E+00, 0.48010E+00, 0.48296E+00, 0.48581E+00, 0.48865E+00, & + 0.49149E+00, 0.49433E+00, 0.49715E+00, 0.49998E+00, 0.50279E+00, & + 0.50560E+00, 0.50840E+00, 0.51120E+00, 0.51399E+00, 0.51678E+00, & + 0.51956E+00 & + / +! +! *** (2H, SO4) +! + DATA (BNC07M (I),I= 1,100)/ & + -0.10013E+00,-0.18189E+00,-0.23903E+00,-0.27766E+00,-0.30724E+00, & + -0.33132E+00,-0.35165E+00,-0.36925E+00,-0.38476E+00,-0.39862E+00, & + -0.41114E+00,-0.42256E+00,-0.43303E+00,-0.44271E+00,-0.45169E+00, & + -0.46007E+00,-0.46792E+00,-0.47529E+00,-0.48224E+00,-0.48881E+00, & + -0.49504E+00,-0.50095E+00,-0.50658E+00,-0.51195E+00,-0.51707E+00, & + -0.52197E+00,-0.52667E+00,-0.53118E+00,-0.53551E+00,-0.53967E+00, & + -0.54368E+00,-0.54754E+00,-0.55127E+00,-0.55486E+00,-0.55834E+00, & + -0.56170E+00,-0.56495E+00,-0.56811E+00,-0.57116E+00,-0.57412E+00, & + -0.57699E+00,-0.57978E+00,-0.58249E+00,-0.58513E+00,-0.58769E+00, & + -0.59018E+00,-0.59261E+00,-0.59497E+00,-0.59727E+00,-0.59951E+00, & + -0.60169E+00,-0.60383E+00,-0.60591E+00,-0.60794E+00,-0.60992E+00, & + -0.61185E+00,-0.61374E+00,-0.61559E+00,-0.61740E+00,-0.61916E+00, & + -0.62089E+00,-0.62258E+00,-0.62424E+00,-0.62586E+00,-0.62744E+00, & + -0.62900E+00,-0.63052E+00,-0.63201E+00,-0.63347E+00,-0.63490E+00, & + -0.63631E+00,-0.63769E+00,-0.63904E+00,-0.64037E+00,-0.64167E+00, & + -0.64295E+00,-0.64420E+00,-0.64544E+00,-0.64665E+00,-0.64784E+00, & + -0.64901E+00,-0.65016E+00,-0.65129E+00,-0.65240E+00,-0.65350E+00, & + -0.65457E+00,-0.65563E+00,-0.65667E+00,-0.65770E+00,-0.65871E+00, & + -0.65970E+00,-0.66068E+00,-0.66164E+00,-0.66259E+00,-0.66352E+00, & + -0.66444E+00,-0.66535E+00,-0.66624E+00,-0.66712E+00,-0.66799E+00/ + + DATA (BNC07M (I),I=101,200)/ & + -0.66884E+00,-0.66968E+00,-0.67051E+00,-0.67133E+00,-0.67214E+00, & + -0.67293E+00,-0.67372E+00,-0.67449E+00,-0.67525E+00,-0.67600E+00, & + -0.67674E+00,-0.67748E+00,-0.67820E+00,-0.67891E+00,-0.67961E+00, & + -0.68030E+00,-0.68098E+00,-0.68165E+00,-0.68232E+00,-0.68297E+00, & + -0.68360E+00,-0.68424E+00,-0.68487E+00,-0.68549E+00,-0.68610E+00, & + -0.68671E+00,-0.68731E+00,-0.68789E+00,-0.68848E+00,-0.68905E+00, & + -0.68961E+00,-0.69017E+00,-0.69072E+00,-0.69126E+00,-0.69180E+00, & + -0.69233E+00,-0.69285E+00,-0.69336E+00,-0.69387E+00,-0.69437E+00, & + -0.69487E+00,-0.69536E+00,-0.69584E+00,-0.69631E+00,-0.69678E+00, & + -0.69724E+00,-0.69770E+00,-0.69815E+00,-0.69860E+00,-0.69904E+00, & + -0.69947E+00,-0.69990E+00,-0.70032E+00,-0.70074E+00,-0.70115E+00, & + -0.70156E+00,-0.70196E+00,-0.70235E+00,-0.70274E+00,-0.70313E+00, & + -0.70351E+00,-0.70389E+00,-0.70426E+00,-0.70463E+00,-0.70499E+00, & + -0.70534E+00,-0.70570E+00,-0.70604E+00,-0.70639E+00,-0.70673E+00, & + -0.70706E+00,-0.70739E+00,-0.70772E+00,-0.70804E+00,-0.70836E+00, & + -0.70867E+00,-0.70898E+00,-0.70928E+00,-0.70958E+00,-0.70988E+00, & + -0.71018E+00,-0.71047E+00,-0.71075E+00,-0.71103E+00,-0.71131E+00, & + -0.71159E+00,-0.71186E+00,-0.71213E+00,-0.71239E+00,-0.71265E+00, & + -0.71291E+00,-0.71316E+00,-0.71341E+00,-0.71366E+00,-0.71390E+00, & + -0.71414E+00,-0.71438E+00,-0.71461E+00,-0.71484E+00,-0.71507E+00/ + + DATA (BNC07M (I),I=201,300)/ & + -0.71529E+00,-0.71552E+00,-0.71573E+00,-0.71595E+00,-0.71616E+00, & + -0.71637E+00,-0.71658E+00,-0.71678E+00,-0.71698E+00,-0.71718E+00, & + -0.71737E+00,-0.71757E+00,-0.71776E+00,-0.71794E+00,-0.71813E+00, & + -0.71831E+00,-0.71849E+00,-0.71866E+00,-0.71884E+00,-0.71901E+00, & + -0.71918E+00,-0.71934E+00,-0.71950E+00,-0.71967E+00,-0.71982E+00, & + -0.71998E+00,-0.72013E+00,-0.72029E+00,-0.72043E+00,-0.72058E+00, & + -0.72073E+00,-0.72087E+00,-0.72101E+00,-0.72114E+00,-0.72128E+00, & + -0.72141E+00,-0.72154E+00,-0.72167E+00,-0.72180E+00,-0.72192E+00, & + -0.72205E+00,-0.72217E+00,-0.72228E+00,-0.72240E+00,-0.72251E+00, & + -0.72263E+00,-0.72274E+00,-0.72284E+00,-0.72295E+00,-0.72305E+00, & + -0.72316E+00,-0.72326E+00,-0.72335E+00,-0.72345E+00,-0.72355E+00, & + -0.72364E+00,-0.72373E+00,-0.72382E+00,-0.72391E+00,-0.72399E+00, & + -0.72407E+00,-0.72416E+00,-0.72424E+00,-0.72432E+00,-0.72439E+00, & + -0.72447E+00,-0.72454E+00,-0.72461E+00,-0.72468E+00,-0.72475E+00, & + -0.72482E+00,-0.72488E+00,-0.72494E+00,-0.72501E+00,-0.72507E+00, & + -0.72513E+00,-0.72518E+00,-0.72524E+00,-0.72529E+00,-0.72534E+00, & + -0.72539E+00,-0.72544E+00,-0.72549E+00,-0.72554E+00,-0.72558E+00, & + -0.72563E+00,-0.72567E+00,-0.72571E+00,-0.72575E+00,-0.72579E+00, & + -0.72582E+00,-0.72586E+00,-0.72589E+00,-0.72592E+00,-0.72595E+00, & + -0.72598E+00,-0.72601E+00,-0.72604E+00,-0.72606E+00,-0.72609E+00/ + + DATA (BNC07M (I),I=301,400)/ & + -0.72611E+00,-0.72613E+00,-0.72615E+00,-0.72617E+00,-0.72619E+00, & + -0.72620E+00,-0.72622E+00,-0.72623E+00,-0.72624E+00,-0.72626E+00, & + -0.72627E+00,-0.72627E+00,-0.72628E+00,-0.72629E+00,-0.72629E+00, & + -0.72630E+00,-0.72630E+00,-0.72630E+00,-0.72630E+00,-0.72630E+00, & + -0.72630E+00,-0.72630E+00,-0.72629E+00,-0.72629E+00,-0.72628E+00, & + -0.72628E+00,-0.72627E+00,-0.72626E+00,-0.72625E+00,-0.72624E+00, & + -0.72622E+00,-0.72621E+00,-0.72619E+00,-0.72618E+00,-0.72616E+00, & + -0.72614E+00,-0.72612E+00,-0.72610E+00,-0.72608E+00,-0.72606E+00, & + -0.72604E+00,-0.72601E+00,-0.72599E+00,-0.72596E+00,-0.72594E+00, & + -0.72591E+00,-0.72588E+00,-0.72585E+00,-0.72582E+00,-0.72579E+00, & + -0.72575E+00,-0.72572E+00,-0.72569E+00,-0.72565E+00,-0.72561E+00, & + -0.72558E+00,-0.72554E+00,-0.72550E+00,-0.72546E+00,-0.72542E+00, & + -0.72538E+00,-0.72533E+00,-0.72529E+00,-0.72524E+00,-0.72520E+00, & + -0.72515E+00,-0.72511E+00,-0.72506E+00,-0.72501E+00,-0.72496E+00, & + -0.72491E+00,-0.72486E+00,-0.72481E+00,-0.72475E+00,-0.72470E+00, & + -0.72464E+00,-0.72459E+00,-0.72453E+00,-0.72448E+00,-0.72442E+00, & + -0.72436E+00,-0.72430E+00,-0.72424E+00,-0.72418E+00,-0.72412E+00, & + -0.72406E+00,-0.72399E+00,-0.72393E+00,-0.72386E+00,-0.72380E+00, & + -0.72373E+00,-0.72367E+00,-0.72360E+00,-0.72353E+00,-0.72346E+00, & + -0.72339E+00,-0.72332E+00,-0.72325E+00,-0.72318E+00,-0.72310E+00/ + + DATA (BNC07M (I),I=401,500)/ & + -0.72303E+00,-0.72296E+00,-0.72288E+00,-0.72281E+00,-0.72273E+00, & + -0.72265E+00,-0.72258E+00,-0.72250E+00,-0.72242E+00,-0.72234E+00, & + -0.72226E+00,-0.72218E+00,-0.72210E+00,-0.72201E+00,-0.72193E+00, & + -0.72185E+00,-0.72176E+00,-0.72168E+00,-0.72159E+00,-0.72151E+00, & + -0.72142E+00,-0.72133E+00,-0.72124E+00,-0.72116E+00,-0.72107E+00, & + -0.72098E+00,-0.72089E+00,-0.72080E+00,-0.72070E+00,-0.72061E+00, & + -0.72052E+00,-0.72042E+00,-0.72033E+00,-0.72024E+00,-0.72014E+00, & + -0.72004E+00,-0.71995E+00,-0.71985E+00,-0.71975E+00,-0.71966E+00, & + -0.71956E+00,-0.71946E+00,-0.71936E+00,-0.71926E+00,-0.71916E+00, & + -0.71905E+00,-0.71895E+00,-0.71885E+00,-0.71875E+00,-0.71864E+00, & + -0.71854E+00,-0.71843E+00,-0.71833E+00,-0.71822E+00,-0.71812E+00, & + -0.71801E+00,-0.71790E+00,-0.71779E+00,-0.71768E+00,-0.71758E+00, & + -0.71747E+00,-0.71736E+00,-0.71724E+00,-0.71713E+00,-0.71702E+00, & + -0.71691E+00,-0.71680E+00,-0.71668E+00,-0.71657E+00,-0.71646E+00, & + -0.71634E+00,-0.71623E+00,-0.71611E+00,-0.71599E+00,-0.71588E+00, & + -0.71576E+00,-0.71564E+00,-0.71552E+00,-0.71541E+00,-0.71529E+00, & + -0.71517E+00,-0.71505E+00,-0.71493E+00,-0.71481E+00,-0.71468E+00, & + -0.71456E+00,-0.71444E+00,-0.71432E+00,-0.71419E+00,-0.71407E+00, & + -0.71395E+00,-0.71382E+00,-0.71370E+00,-0.71357E+00,-0.71345E+00, & + -0.71332E+00,-0.71319E+00,-0.71307E+00,-0.71294E+00,-0.71281E+00/ + + DATA (BNC07M (I),I=501,600)/ & + -0.71268E+00,-0.71255E+00,-0.71242E+00,-0.71229E+00,-0.71216E+00, & + -0.71203E+00,-0.71190E+00,-0.71177E+00,-0.71164E+00,-0.71150E+00, & + -0.71137E+00,-0.71124E+00,-0.71111E+00,-0.71097E+00,-0.71084E+00, & + -0.71070E+00,-0.71057E+00,-0.71043E+00,-0.71030E+00,-0.71016E+00, & + -0.71002E+00,-0.70988E+00,-0.70975E+00,-0.70961E+00,-0.70947E+00, & + -0.70933E+00,-0.70919E+00,-0.70905E+00,-0.70891E+00,-0.70877E+00, & + -0.70863E+00,-0.70849E+00,-0.70835E+00,-0.70821E+00,-0.70807E+00, & + -0.70792E+00,-0.70778E+00,-0.70764E+00,-0.70749E+00,-0.70735E+00, & + -0.70721E+00,-0.70706E+00,-0.70692E+00,-0.70677E+00,-0.70662E+00, & + -0.70648E+00,-0.70633E+00,-0.70618E+00,-0.70604E+00,-0.70589E+00, & + -0.70574E+00,-0.70559E+00,-0.70544E+00,-0.70530E+00,-0.70515E+00, & + -0.70500E+00,-0.70485E+00,-0.70470E+00,-0.70455E+00,-0.70439E+00, & + -0.70424E+00,-0.70409E+00,-0.70394E+00,-0.70379E+00,-0.70363E+00, & + -0.70348E+00,-0.70333E+00,-0.70317E+00,-0.70302E+00,-0.70287E+00, & + -0.70271E+00,-0.70256E+00,-0.70240E+00,-0.70225E+00,-0.70209E+00, & + -0.70193E+00,-0.70178E+00,-0.70162E+00,-0.70146E+00,-0.70131E+00, & + -0.70115E+00,-0.70099E+00,-0.70083E+00,-0.70067E+00,-0.70051E+00, & + -0.70035E+00,-0.70019E+00,-0.70003E+00,-0.69987E+00,-0.69971E+00, & + -0.69955E+00,-0.69939E+00,-0.69923E+00,-0.69907E+00,-0.69891E+00, & + -0.69874E+00,-0.69858E+00,-0.69842E+00,-0.69826E+00,-0.69764E+00/ + + DATA (BNC07M (I),I=601,700)/ & + -0.69627E+00,-0.69459E+00,-0.69289E+00,-0.69115E+00,-0.68939E+00, & + -0.68761E+00,-0.68581E+00,-0.68398E+00,-0.68213E+00,-0.68026E+00, & + -0.67837E+00,-0.67646E+00,-0.67453E+00,-0.67259E+00,-0.67062E+00, & + -0.66864E+00,-0.66664E+00,-0.66463E+00,-0.66260E+00,-0.66055E+00, & + -0.65849E+00,-0.65641E+00,-0.65433E+00,-0.65222E+00,-0.65011E+00, & + -0.64798E+00,-0.64584E+00,-0.64368E+00,-0.64152E+00,-0.63934E+00, & + -0.63715E+00,-0.63495E+00,-0.63274E+00,-0.63052E+00,-0.62829E+00, & + -0.62605E+00,-0.62380E+00,-0.62154E+00,-0.61927E+00,-0.61700E+00, & + -0.61471E+00,-0.61242E+00,-0.61011E+00,-0.60780E+00,-0.60548E+00, & + -0.60316E+00,-0.60082E+00,-0.59848E+00,-0.59613E+00,-0.59378E+00, & + -0.59141E+00,-0.58904E+00,-0.58667E+00,-0.58428E+00,-0.58189E+00, & + -0.57950E+00,-0.57710E+00,-0.57469E+00,-0.57228E+00,-0.56986E+00, & + -0.56743E+00,-0.56500E+00,-0.56257E+00,-0.56013E+00,-0.55768E+00, & + -0.55523E+00,-0.55278E+00,-0.55032E+00,-0.54785E+00,-0.54538E+00, & + -0.54291E+00,-0.54043E+00,-0.53795E+00,-0.53546E+00,-0.53297E+00, & + -0.53047E+00,-0.52797E+00,-0.52547E+00,-0.52296E+00,-0.52045E+00, & + -0.51793E+00,-0.51541E+00,-0.51289E+00,-0.51037E+00,-0.50784E+00, & + -0.50530E+00,-0.50277E+00,-0.50023E+00,-0.49769E+00,-0.49514E+00, & + -0.49259E+00,-0.49004E+00,-0.48749E+00,-0.48493E+00,-0.48237E+00, & + -0.47980E+00,-0.47724E+00,-0.47467E+00,-0.47210E+00,-0.46952E+00/ + + DATA (BNC07M(I),I=701,741)/ & + -0.46694E+00,-0.46436E+00,-0.46178E+00,-0.45920E+00,-0.45661E+00, & + -0.45402E+00,-0.45143E+00,-0.44884E+00,-0.44624E+00,-0.44364E+00, & + -0.44104E+00,-0.43844E+00,-0.43583E+00,-0.43322E+00,-0.43062E+00, & + -0.42800E+00,-0.42539E+00,-0.42278E+00,-0.42016E+00,-0.41754E+00, & + -0.41492E+00,-0.41230E+00,-0.40967E+00,-0.40704E+00,-0.40442E+00, & + -0.40179E+00,-0.39916E+00,-0.39652E+00,-0.39389E+00,-0.39125E+00, & + -0.38861E+00,-0.38597E+00,-0.38333E+00,-0.38069E+00,-0.37805E+00, & + -0.37540E+00,-0.37275E+00,-0.37010E+00,-0.36746E+00,-0.36480E+00, & + -0.36215E+00 & + / +! +! *** (H, HSO4) +! + DATA (BNC08M (I),I= 1,100)/ & + -0.47223E-01,-0.81099E-01,-0.10165E+00,-0.11366E+00,-0.12158E+00, & + -0.12700E+00,-0.13074E+00,-0.13324E+00,-0.13478E+00,-0.13555E+00, & + -0.13569E+00,-0.13529E+00,-0.13443E+00,-0.13316E+00,-0.13154E+00, & + -0.12959E+00,-0.12735E+00,-0.12484E+00,-0.12208E+00,-0.11910E+00, & + -0.11591E+00,-0.11252E+00,-0.10894E+00,-0.10519E+00,-0.10128E+00, & + -0.97205E-01,-0.92986E-01,-0.88626E-01,-0.84132E-01,-0.79512E-01, & + -0.74769E-01,-0.69911E-01,-0.64942E-01,-0.59867E-01,-0.54691E-01, & + -0.49419E-01,-0.44054E-01,-0.38600E-01,-0.33062E-01,-0.27442E-01, & + -0.21746E-01,-0.15975E-01,-0.10133E-01,-0.42230E-02, 0.17517E-02, & + 0.77886E-02, 0.13885E-01, 0.20039E-01, 0.26247E-01, 0.32508E-01, & + 0.38819E-01, 0.45178E-01, 0.51584E-01, 0.58035E-01, 0.64529E-01, & + 0.71064E-01, 0.77640E-01, 0.84256E-01, 0.90910E-01, 0.97601E-01, & + 0.10433E+00, 0.11109E+00, 0.11789E+00, 0.12472E+00, 0.13159E+00, & + 0.13850E+00, 0.14543E+00, 0.15240E+00, 0.15941E+00, 0.16645E+00, & + 0.17353E+00, 0.18064E+00, 0.18778E+00, 0.19496E+00, 0.20218E+00, & + 0.20943E+00, 0.21672E+00, 0.22405E+00, 0.23142E+00, 0.23882E+00, & + 0.24627E+00, 0.25375E+00, 0.26127E+00, 0.26883E+00, 0.27643E+00, & + 0.28407E+00, 0.29175E+00, 0.29947E+00, 0.30724E+00, 0.31503E+00, & + 0.32287E+00, 0.33075E+00, 0.33867E+00, 0.34662E+00, 0.35461E+00, & + 0.36263E+00, 0.37069E+00, 0.37878E+00, 0.38691E+00, 0.39507E+00/ + + DATA (BNC08M (I),I=101,200)/ & + 0.40325E+00, 0.41147E+00, 0.41972E+00, 0.42799E+00, 0.43628E+00, & + 0.44460E+00, 0.45294E+00, 0.46130E+00, 0.46968E+00, 0.47808E+00, & + 0.48650E+00, 0.49492E+00, 0.50337E+00, 0.51182E+00, 0.52028E+00, & + 0.52875E+00, 0.53723E+00, 0.54572E+00, 0.55421E+00, 0.56270E+00, & + 0.57051E+00, 0.57908E+00, 0.58765E+00, 0.59621E+00, 0.60477E+00, & + 0.61331E+00, 0.62184E+00, 0.63037E+00, 0.63888E+00, 0.64739E+00, & + 0.65588E+00, 0.66436E+00, 0.67283E+00, 0.68130E+00, 0.68975E+00, & + 0.69818E+00, 0.70661E+00, 0.71502E+00, 0.72342E+00, 0.73181E+00, & + 0.74019E+00, 0.74855E+00, 0.75690E+00, 0.76524E+00, 0.77356E+00, & + 0.78187E+00, 0.79017E+00, 0.79845E+00, 0.80672E+00, 0.81497E+00, & + 0.82321E+00, 0.83144E+00, 0.83965E+00, 0.84785E+00, 0.85603E+00, & + 0.86420E+00, 0.87235E+00, 0.88049E+00, 0.88861E+00, 0.89672E+00, & + 0.90481E+00, 0.91289E+00, 0.92095E+00, 0.92900E+00, 0.93703E+00, & + 0.94505E+00, 0.95305E+00, 0.96103E+00, 0.96900E+00, 0.97696E+00, & + 0.98490E+00, 0.99282E+00, 0.10007E+01, 0.10086E+01, 0.10165E+01, & + 0.10244E+01, 0.10322E+01, 0.10400E+01, 0.10478E+01, 0.10556E+01, & + 0.10634E+01, 0.10712E+01, 0.10789E+01, 0.10867E+01, 0.10944E+01, & + 0.11021E+01, 0.11098E+01, 0.11175E+01, 0.11251E+01, 0.11328E+01, & + 0.11404E+01, 0.11480E+01, 0.11556E+01, 0.11632E+01, 0.11707E+01, & + 0.11783E+01, 0.11858E+01, 0.11933E+01, 0.12008E+01, 0.12083E+01/ + + DATA (BNC08M (I),I=201,300)/ & + 0.12158E+01, 0.12232E+01, 0.12307E+01, 0.12381E+01, 0.12455E+01, & + 0.12529E+01, 0.12603E+01, 0.12676E+01, 0.12750E+01, 0.12823E+01, & + 0.12896E+01, 0.12969E+01, 0.13042E+01, 0.13115E+01, 0.13187E+01, & + 0.13260E+01, 0.13332E+01, 0.13404E+01, 0.13476E+01, 0.13548E+01, & + 0.13619E+01, 0.13691E+01, 0.13762E+01, 0.13834E+01, 0.13905E+01, & + 0.13975E+01, 0.14046E+01, 0.14117E+01, 0.14187E+01, 0.14258E+01, & + 0.14328E+01, 0.14398E+01, 0.14468E+01, 0.14538E+01, 0.14607E+01, & + 0.14677E+01, 0.14746E+01, 0.14815E+01, 0.14884E+01, 0.14953E+01, & + 0.15022E+01, 0.15091E+01, 0.15159E+01, 0.15228E+01, 0.15296E+01, & + 0.15364E+01, 0.15432E+01, 0.15500E+01, 0.15567E+01, 0.15635E+01, & + 0.15702E+01, 0.15769E+01, 0.15837E+01, 0.15904E+01, 0.15970E+01, & + 0.16037E+01, 0.16104E+01, 0.16170E+01, 0.16237E+01, 0.16303E+01, & + 0.16369E+01, 0.16435E+01, 0.16501E+01, 0.16566E+01, 0.16632E+01, & + 0.16697E+01, 0.16763E+01, 0.16828E+01, 0.16893E+01, 0.16958E+01, & + 0.17022E+01, 0.17087E+01, 0.17152E+01, 0.17216E+01, 0.17280E+01, & + 0.17345E+01, 0.17409E+01, 0.17472E+01, 0.17536E+01, 0.17600E+01, & + 0.17663E+01, 0.17727E+01, 0.17790E+01, 0.17853E+01, 0.17916E+01, & + 0.17979E+01, 0.18042E+01, 0.18105E+01, 0.18167E+01, 0.18230E+01, & + 0.18292E+01, 0.18354E+01, 0.18416E+01, 0.18478E+01, 0.18540E+01, & + 0.18602E+01, 0.18664E+01, 0.18725E+01, 0.18787E+01, 0.18848E+01/ + + DATA (BNC08M (I),I=301,400)/ & + 0.18909E+01, 0.18970E+01, 0.19031E+01, 0.19092E+01, 0.19153E+01, & + 0.19213E+01, 0.19274E+01, 0.19334E+01, 0.19394E+01, 0.19455E+01, & + 0.19515E+01, 0.19575E+01, 0.19634E+01, 0.19694E+01, 0.19754E+01, & + 0.19813E+01, 0.19873E+01, 0.19932E+01, 0.19991E+01, 0.20050E+01, & + 0.20109E+01, 0.20168E+01, 0.20227E+01, 0.20286E+01, 0.20344E+01, & + 0.20403E+01, 0.20461E+01, 0.20519E+01, 0.20577E+01, 0.20635E+01, & + 0.20693E+01, 0.20751E+01, 0.20809E+01, 0.20866E+01, 0.20924E+01, & + 0.20981E+01, 0.21039E+01, 0.21096E+01, 0.21153E+01, 0.21210E+01, & + 0.21267E+01, 0.21324E+01, 0.21380E+01, 0.21437E+01, 0.21494E+01, & + 0.21550E+01, 0.21606E+01, 0.21663E+01, 0.21719E+01, 0.21775E+01, & + 0.21831E+01, 0.21887E+01, 0.21942E+01, 0.21998E+01, 0.22054E+01, & + 0.22109E+01, 0.22164E+01, 0.22220E+01, 0.22275E+01, 0.22330E+01, & + 0.22385E+01, 0.22440E+01, 0.22495E+01, 0.22549E+01, 0.22604E+01, & + 0.22658E+01, 0.22713E+01, 0.22767E+01, 0.22822E+01, 0.22876E+01, & + 0.22930E+01, 0.22984E+01, 0.23038E+01, 0.23092E+01, 0.23145E+01, & + 0.23199E+01, 0.23252E+01, 0.23306E+01, 0.23359E+01, 0.23413E+01, & + 0.23466E+01, 0.23519E+01, 0.23572E+01, 0.23625E+01, 0.23678E+01, & + 0.23730E+01, 0.23783E+01, 0.23836E+01, 0.23888E+01, 0.23941E+01, & + 0.23993E+01, 0.24045E+01, 0.24097E+01, 0.24150E+01, 0.24202E+01, & + 0.24254E+01, 0.24305E+01, 0.24357E+01, 0.24409E+01, 0.24460E+01/ + + DATA (BNC08M (I),I=401,500)/ & + 0.24512E+01, 0.24563E+01, 0.24615E+01, 0.24666E+01, 0.24717E+01, & + 0.24768E+01, 0.24819E+01, 0.24870E+01, 0.24921E+01, 0.24972E+01, & + 0.25023E+01, 0.25073E+01, 0.25124E+01, 0.25174E+01, 0.25225E+01, & + 0.25275E+01, 0.25325E+01, 0.25375E+01, 0.25426E+01, 0.25476E+01, & + 0.25526E+01, 0.25575E+01, 0.25625E+01, 0.25675E+01, 0.25725E+01, & + 0.25774E+01, 0.25824E+01, 0.25873E+01, 0.25922E+01, 0.25972E+01, & + 0.26021E+01, 0.26070E+01, 0.26119E+01, 0.26168E+01, 0.26217E+01, & + 0.26266E+01, 0.26314E+01, 0.26363E+01, 0.26412E+01, 0.26460E+01, & + 0.26509E+01, 0.26557E+01, 0.26605E+01, 0.26653E+01, 0.26702E+01, & + 0.26750E+01, 0.26798E+01, 0.26846E+01, 0.26894E+01, 0.26941E+01, & + 0.26989E+01, 0.27037E+01, 0.27084E+01, 0.27132E+01, 0.27179E+01, & + 0.27227E+01, 0.27274E+01, 0.27321E+01, 0.27369E+01, 0.27416E+01, & + 0.27463E+01, 0.27510E+01, 0.27557E+01, 0.27604E+01, 0.27650E+01, & + 0.27697E+01, 0.27744E+01, 0.27790E+01, 0.27837E+01, 0.27883E+01, & + 0.27930E+01, 0.27976E+01, 0.28022E+01, 0.28068E+01, 0.28115E+01, & + 0.28161E+01, 0.28207E+01, 0.28253E+01, 0.28298E+01, 0.28344E+01, & + 0.28390E+01, 0.28436E+01, 0.28481E+01, 0.28527E+01, 0.28572E+01, & + 0.28618E+01, 0.28663E+01, 0.28708E+01, 0.28754E+01, 0.28799E+01, & + 0.28844E+01, 0.28889E+01, 0.28934E+01, 0.28979E+01, 0.29024E+01, & + 0.29068E+01, 0.29113E+01, 0.29158E+01, 0.29203E+01, 0.29247E+01/ + + DATA (BNC08M (I),I=501,600)/ & + 0.29292E+01, 0.29336E+01, 0.29380E+01, 0.29425E+01, 0.29469E+01, & + 0.29513E+01, 0.29557E+01, 0.29601E+01, 0.29645E+01, 0.29689E+01, & + 0.29733E+01, 0.29777E+01, 0.29821E+01, 0.29865E+01, 0.29908E+01, & + 0.29952E+01, 0.29995E+01, 0.30039E+01, 0.30082E+01, 0.30126E+01, & + 0.30169E+01, 0.30212E+01, 0.30255E+01, 0.30299E+01, 0.30342E+01, & + 0.30385E+01, 0.30428E+01, 0.30471E+01, 0.30514E+01, 0.30556E+01, & + 0.30599E+01, 0.30642E+01, 0.30684E+01, 0.30727E+01, 0.30770E+01, & + 0.30812E+01, 0.30854E+01, 0.30897E+01, 0.30939E+01, 0.30981E+01, & + 0.31024E+01, 0.31066E+01, 0.31108E+01, 0.31150E+01, 0.31192E+01, & + 0.31234E+01, 0.31276E+01, 0.31317E+01, 0.31359E+01, 0.31401E+01, & + 0.31443E+01, 0.31484E+01, 0.31526E+01, 0.31567E+01, 0.31609E+01, & + 0.31650E+01, 0.31692E+01, 0.31733E+01, 0.31774E+01, 0.31815E+01, & + 0.31856E+01, 0.31898E+01, 0.31939E+01, 0.31980E+01, 0.32021E+01, & + 0.32061E+01, 0.32102E+01, 0.32143E+01, 0.32184E+01, 0.32224E+01, & + 0.32265E+01, 0.32306E+01, 0.32346E+01, 0.32387E+01, 0.32427E+01, & + 0.32468E+01, 0.32508E+01, 0.32548E+01, 0.32588E+01, 0.32629E+01, & + 0.32669E+01, 0.32709E+01, 0.32749E+01, 0.32789E+01, 0.32829E+01, & + 0.32869E+01, 0.32909E+01, 0.32948E+01, 0.32988E+01, 0.33028E+01, & + 0.33068E+01, 0.33107E+01, 0.33147E+01, 0.33186E+01, 0.33226E+01, & + 0.33265E+01, 0.33304E+01, 0.33344E+01, 0.33383E+01, 0.33530E+01/ + + DATA (BNC08M (I),I=601,700)/ & + 0.33851E+01, 0.34236E+01, 0.34616E+01, 0.34992E+01, 0.35364E+01, & + 0.35732E+01, 0.36095E+01, 0.36455E+01, 0.36811E+01, 0.37163E+01, & + 0.37511E+01, 0.37856E+01, 0.38198E+01, 0.38535E+01, 0.38870E+01, & + 0.39201E+01, 0.39529E+01, 0.39854E+01, 0.40175E+01, 0.40494E+01, & + 0.40809E+01, 0.41122E+01, 0.41432E+01, 0.41738E+01, 0.42043E+01, & + 0.42344E+01, 0.42643E+01, 0.42939E+01, 0.43232E+01, 0.43523E+01, & + 0.43812E+01, 0.44098E+01, 0.44382E+01, 0.44663E+01, 0.44942E+01, & + 0.45219E+01, 0.45494E+01, 0.45766E+01, 0.46036E+01, 0.46304E+01, & + 0.46570E+01, 0.46834E+01, 0.47096E+01, 0.47356E+01, 0.47614E+01, & + 0.47870E+01, 0.48124E+01, 0.48377E+01, 0.48627E+01, 0.48876E+01, & + 0.49122E+01, 0.49368E+01, 0.49611E+01, 0.49853E+01, 0.50093E+01, & + 0.50331E+01, 0.50568E+01, 0.50803E+01, 0.51036E+01, 0.51268E+01, & + 0.51499E+01, 0.51728E+01, 0.51955E+01, 0.52181E+01, 0.52406E+01, & + 0.52629E+01, 0.52850E+01, 0.53071E+01, 0.53290E+01, 0.53507E+01, & + 0.53723E+01, 0.53938E+01, 0.54152E+01, 0.54364E+01, 0.54575E+01, & + 0.54785E+01, 0.54993E+01, 0.55200E+01, 0.55406E+01, 0.55611E+01, & + 0.55815E+01, 0.56017E+01, 0.56219E+01, 0.56419E+01, 0.56618E+01, & + 0.56816E+01, 0.57013E+01, 0.57209E+01, 0.57404E+01, 0.57597E+01, & + 0.57790E+01, 0.57982E+01, 0.58172E+01, 0.58362E+01, 0.58550E+01, & + 0.58738E+01, 0.58925E+01, 0.59110E+01, 0.59295E+01, 0.59479E+01/ + + DATA (BNC08M(I),I=701,741)/ & + 0.59661E+01, 0.59843E+01, 0.60024E+01, 0.60204E+01, 0.60384E+01, & + 0.60562E+01, 0.60739E+01, 0.60916E+01, 0.61091E+01, 0.61266E+01, & + 0.61440E+01, 0.61614E+01, 0.61786E+01, 0.61957E+01, 0.62128E+01, & + 0.62298E+01, 0.62467E+01, 0.62636E+01, 0.62803E+01, 0.62970E+01, & + 0.63136E+01, 0.63301E+01, 0.63466E+01, 0.63630E+01, 0.63793E+01, & + 0.63955E+01, 0.64117E+01, 0.64278E+01, 0.64438E+01, 0.64598E+01, & + 0.64757E+01, 0.64915E+01, 0.65073E+01, 0.65229E+01, 0.65386E+01, & + 0.65541E+01, 0.65696E+01, 0.65850E+01, 0.66004E+01, 0.66157E+01, & + 0.66309E+01 & + / +! +! *** NH4HSO4 +! + DATA (BNC09M (I),I= 1,100)/ & + -0.49220E-01,-0.88125E-01,-0.11455E+00,-0.13197E+00,-0.14502E+00, & + -0.15542E+00,-0.16401E+00,-0.17127E+00,-0.17752E+00,-0.18296E+00, & + -0.18774E+00,-0.19197E+00,-0.19572E+00,-0.19907E+00,-0.20206E+00, & + -0.20473E+00,-0.20712E+00,-0.20925E+00,-0.21115E+00,-0.21284E+00, & + -0.21433E+00,-0.21563E+00,-0.21677E+00,-0.21775E+00,-0.21858E+00, & + -0.21927E+00,-0.21983E+00,-0.22027E+00,-0.22058E+00,-0.22079E+00, & + -0.22089E+00,-0.22088E+00,-0.22078E+00,-0.22058E+00,-0.22030E+00, & + -0.21992E+00,-0.21947E+00,-0.21894E+00,-0.21833E+00,-0.21764E+00, & + -0.21689E+00,-0.21607E+00,-0.21519E+00,-0.21424E+00,-0.21323E+00, & + -0.21216E+00,-0.21104E+00,-0.20986E+00,-0.20863E+00,-0.20735E+00, & + -0.20602E+00,-0.20464E+00,-0.20322E+00,-0.20175E+00,-0.20025E+00, & + -0.19870E+00,-0.19711E+00,-0.19548E+00,-0.19382E+00,-0.19212E+00, & + -0.19038E+00,-0.18862E+00,-0.18681E+00,-0.18498E+00,-0.18311E+00, & + -0.18122E+00,-0.17929E+00,-0.17734E+00,-0.17536E+00,-0.17334E+00, & + -0.17131E+00,-0.16924E+00,-0.16715E+00,-0.16503E+00,-0.16289E+00, & + -0.16072E+00,-0.15853E+00,-0.15631E+00,-0.15406E+00,-0.15180E+00, & + -0.14951E+00,-0.14719E+00,-0.14486E+00,-0.14250E+00,-0.14011E+00, & + -0.13771E+00,-0.13528E+00,-0.13283E+00,-0.13036E+00,-0.12787E+00, & + -0.12536E+00,-0.12283E+00,-0.12028E+00,-0.11771E+00,-0.11512E+00, & + -0.11251E+00,-0.10988E+00,-0.10724E+00,-0.10458E+00,-0.10191E+00/ + + DATA (BNC09M (I),I=101,200)/ & + -0.99221E-01,-0.96517E-01,-0.93798E-01,-0.91067E-01,-0.88323E-01, & + -0.85567E-01,-0.82800E-01,-0.80022E-01,-0.77234E-01,-0.74437E-01, & + -0.71631E-01,-0.68817E-01,-0.65996E-01,-0.63168E-01,-0.60334E-01, & + -0.57495E-01,-0.54651E-01,-0.51802E-01,-0.48950E-01,-0.46094E-01, & + -0.43478E-01,-0.40589E-01,-0.37702E-01,-0.34815E-01,-0.31930E-01, & + -0.29047E-01,-0.26165E-01,-0.23286E-01,-0.20408E-01,-0.17533E-01, & + -0.14660E-01,-0.11790E-01,-0.89226E-02,-0.60582E-02,-0.31967E-02, & + -0.33866E-03, 0.25164E-02, 0.53678E-02, 0.82159E-02, 0.11060E-01, & + 0.13901E-01, 0.16738E-01, 0.19571E-01, 0.22399E-01, 0.25224E-01, & + 0.28045E-01, 0.30861E-01, 0.33673E-01, 0.36481E-01, 0.39284E-01, & + 0.42083E-01, 0.44877E-01, 0.47667E-01, 0.50452E-01, 0.53232E-01, & + 0.56007E-01, 0.58778E-01, 0.61543E-01, 0.64304E-01, 0.67060E-01, & + 0.69811E-01, 0.72557E-01, 0.75298E-01, 0.78034E-01, 0.80765E-01, & + 0.83490E-01, 0.86211E-01, 0.88926E-01, 0.91637E-01, 0.94342E-01, & + 0.97042E-01, 0.99736E-01, 0.10243E+00, 0.10511E+00, 0.10779E+00, & + 0.11046E+00, 0.11313E+00, 0.11579E+00, 0.11845E+00, 0.12111E+00, & + 0.12375E+00, 0.12639E+00, 0.12903E+00, 0.13166E+00, 0.13429E+00, & + 0.13691E+00, 0.13953E+00, 0.14214E+00, 0.14474E+00, 0.14734E+00, & + 0.14994E+00, 0.15253E+00, 0.15511E+00, 0.15769E+00, 0.16026E+00, & + 0.16283E+00, 0.16540E+00, 0.16795E+00, 0.17051E+00, 0.17305E+00/ + + DATA (BNC09M (I),I=201,300)/ & + 0.17560E+00, 0.17814E+00, 0.18067E+00, 0.18319E+00, 0.18572E+00, & + 0.18823E+00, 0.19075E+00, 0.19325E+00, 0.19575E+00, 0.19825E+00, & + 0.20074E+00, 0.20323E+00, 0.20571E+00, 0.20819E+00, 0.21066E+00, & + 0.21313E+00, 0.21559E+00, 0.21805E+00, 0.22050E+00, 0.22294E+00, & + 0.22539E+00, 0.22782E+00, 0.23026E+00, 0.23268E+00, 0.23511E+00, & + 0.23752E+00, 0.23994E+00, 0.24235E+00, 0.24475E+00, 0.24715E+00, & + 0.24954E+00, 0.25193E+00, 0.25432E+00, 0.25670E+00, 0.25907E+00, & + 0.26144E+00, 0.26381E+00, 0.26617E+00, 0.26853E+00, 0.27088E+00, & + 0.27323E+00, 0.27557E+00, 0.27791E+00, 0.28024E+00, 0.28257E+00, & + 0.28490E+00, 0.28722E+00, 0.28954E+00, 0.29185E+00, 0.29416E+00, & + 0.29646E+00, 0.29876E+00, 0.30105E+00, 0.30334E+00, 0.30563E+00, & + 0.30791E+00, 0.31019E+00, 0.31246E+00, 0.31473E+00, 0.31699E+00, & + 0.31925E+00, 0.32151E+00, 0.32376E+00, 0.32601E+00, 0.32825E+00, & + 0.33049E+00, 0.33273E+00, 0.33496E+00, 0.33718E+00, 0.33941E+00, & + 0.34162E+00, 0.34384E+00, 0.34605E+00, 0.34826E+00, 0.35046E+00, & + 0.35266E+00, 0.35485E+00, 0.35704E+00, 0.35923E+00, 0.36141E+00, & + 0.36359E+00, 0.36577E+00, 0.36794E+00, 0.37010E+00, 0.37227E+00, & + 0.37443E+00, 0.37658E+00, 0.37874E+00, 0.38088E+00, 0.38303E+00, & + 0.38517E+00, 0.38731E+00, 0.38944E+00, 0.39157E+00, 0.39369E+00, & + 0.39582E+00, 0.39793E+00, 0.40005E+00, 0.40216E+00, 0.40427E+00/ + + DATA (BNC09M (I),I=301,400)/ & + 0.40637E+00, 0.40847E+00, 0.41057E+00, 0.41266E+00, 0.41475E+00, & + 0.41684E+00, 0.41892E+00, 0.42100E+00, 0.42307E+00, 0.42514E+00, & + 0.42721E+00, 0.42928E+00, 0.43134E+00, 0.43339E+00, 0.43545E+00, & + 0.43750E+00, 0.43955E+00, 0.44159E+00, 0.44363E+00, 0.44567E+00, & + 0.44770E+00, 0.44973E+00, 0.45176E+00, 0.45378E+00, 0.45581E+00, & + 0.45782E+00, 0.45984E+00, 0.46185E+00, 0.46385E+00, 0.46586E+00, & + 0.46786E+00, 0.46986E+00, 0.47185E+00, 0.47384E+00, 0.47583E+00, & + 0.47782E+00, 0.47980E+00, 0.48178E+00, 0.48375E+00, 0.48572E+00, & + 0.48769E+00, 0.48966E+00, 0.49162E+00, 0.49358E+00, 0.49554E+00, & + 0.49749E+00, 0.49944E+00, 0.50139E+00, 0.50333E+00, 0.50528E+00, & + 0.50721E+00, 0.50915E+00, 0.51108E+00, 0.51301E+00, 0.51494E+00, & + 0.51686E+00, 0.51878E+00, 0.52070E+00, 0.52261E+00, 0.52453E+00, & + 0.52643E+00, 0.52834E+00, 0.53024E+00, 0.53214E+00, 0.53404E+00, & + 0.53593E+00, 0.53782E+00, 0.53971E+00, 0.54160E+00, 0.54348E+00, & + 0.54536E+00, 0.54724E+00, 0.54911E+00, 0.55099E+00, 0.55285E+00, & + 0.55472E+00, 0.55658E+00, 0.55844E+00, 0.56030E+00, 0.56216E+00, & + 0.56401E+00, 0.56586E+00, 0.56770E+00, 0.56955E+00, 0.57139E+00, & + 0.57323E+00, 0.57507E+00, 0.57690E+00, 0.57873E+00, 0.58056E+00, & + 0.58238E+00, 0.58421E+00, 0.58603E+00, 0.58784E+00, 0.58966E+00, & + 0.59147E+00, 0.59328E+00, 0.59509E+00, 0.59689E+00, 0.59869E+00/ + + DATA (BNC09M (I),I=401,500)/ & + 0.60049E+00, 0.60229E+00, 0.60408E+00, 0.60588E+00, 0.60766E+00, & + 0.60945E+00, 0.61124E+00, 0.61302E+00, 0.61480E+00, 0.61657E+00, & + 0.61835E+00, 0.62012E+00, 0.62189E+00, 0.62366E+00, 0.62542E+00, & + 0.62718E+00, 0.62894E+00, 0.63070E+00, 0.63245E+00, 0.63421E+00, & + 0.63596E+00, 0.63770E+00, 0.63945E+00, 0.64119E+00, 0.64293E+00, & + 0.64467E+00, 0.64640E+00, 0.64814E+00, 0.64987E+00, 0.65160E+00, & + 0.65332E+00, 0.65505E+00, 0.65677E+00, 0.65849E+00, 0.66020E+00, & + 0.66192E+00, 0.66363E+00, 0.66534E+00, 0.66705E+00, 0.66875E+00, & + 0.67046E+00, 0.67216E+00, 0.67386E+00, 0.67555E+00, 0.67725E+00, & + 0.67894E+00, 0.68063E+00, 0.68232E+00, 0.68400E+00, 0.68568E+00, & + 0.68737E+00, 0.68904E+00, 0.69072E+00, 0.69240E+00, 0.69407E+00, & + 0.69574E+00, 0.69741E+00, 0.69907E+00, 0.70073E+00, 0.70240E+00, & + 0.70405E+00, 0.70571E+00, 0.70737E+00, 0.70902E+00, 0.71067E+00, & + 0.71232E+00, 0.71397E+00, 0.71561E+00, 0.71725E+00, 0.71889E+00, & + 0.72053E+00, 0.72217E+00, 0.72380E+00, 0.72543E+00, 0.72706E+00, & + 0.72869E+00, 0.73032E+00, 0.73194E+00, 0.73356E+00, 0.73518E+00, & + 0.73680E+00, 0.73842E+00, 0.74003E+00, 0.74164E+00, 0.74325E+00, & + 0.74486E+00, 0.74646E+00, 0.74807E+00, 0.74967E+00, 0.75127E+00, & + 0.75287E+00, 0.75446E+00, 0.75606E+00, 0.75765E+00, 0.75924E+00, & + 0.76083E+00, 0.76241E+00, 0.76400E+00, 0.76558E+00, 0.76716E+00/ + + DATA (BNC09M (I),I=501,600)/ & + 0.76874E+00, 0.77032E+00, 0.77189E+00, 0.77346E+00, 0.77503E+00, & + 0.77660E+00, 0.77817E+00, 0.77973E+00, 0.78130E+00, 0.78286E+00, & + 0.78442E+00, 0.78598E+00, 0.78753E+00, 0.78909E+00, 0.79064E+00, & + 0.79219E+00, 0.79374E+00, 0.79529E+00, 0.79683E+00, 0.79837E+00, & + 0.79991E+00, 0.80145E+00, 0.80299E+00, 0.80453E+00, 0.80606E+00, & + 0.80759E+00, 0.80912E+00, 0.81065E+00, 0.81218E+00, 0.81371E+00, & + 0.81523E+00, 0.81675E+00, 0.81827E+00, 0.81979E+00, 0.82131E+00, & + 0.82282E+00, 0.82433E+00, 0.82584E+00, 0.82735E+00, 0.82886E+00, & + 0.83037E+00, 0.83187E+00, 0.83337E+00, 0.83487E+00, 0.83637E+00, & + 0.83787E+00, 0.83937E+00, 0.84086E+00, 0.84235E+00, 0.84384E+00, & + 0.84533E+00, 0.84682E+00, 0.84831E+00, 0.84979E+00, 0.85127E+00, & + 0.85275E+00, 0.85423E+00, 0.85571E+00, 0.85719E+00, 0.85866E+00, & + 0.86013E+00, 0.86160E+00, 0.86307E+00, 0.86454E+00, 0.86601E+00, & + 0.86747E+00, 0.86893E+00, 0.87039E+00, 0.87185E+00, 0.87331E+00, & + 0.87477E+00, 0.87622E+00, 0.87768E+00, 0.87913E+00, 0.88058E+00, & + 0.88203E+00, 0.88347E+00, 0.88492E+00, 0.88636E+00, 0.88780E+00, & + 0.88924E+00, 0.89068E+00, 0.89212E+00, 0.89356E+00, 0.89499E+00, & + 0.89642E+00, 0.89786E+00, 0.89929E+00, 0.90071E+00, 0.90214E+00, & + 0.90357E+00, 0.90499E+00, 0.90641E+00, 0.90783E+00, 0.90925E+00, & + 0.91067E+00, 0.91209E+00, 0.91350E+00, 0.91491E+00, 0.92020E+00/ + + DATA (BNC09M (I),I=601,700)/ & + 0.93176E+00, 0.94563E+00, 0.95937E+00, 0.97296E+00, 0.98643E+00, & + 0.99976E+00, 0.10130E+01, 0.10260E+01, 0.10390E+01, 0.10518E+01, & + 0.10645E+01, 0.10771E+01, 0.10896E+01, 0.11020E+01, 0.11142E+01, & + 0.11264E+01, 0.11384E+01, 0.11504E+01, 0.11622E+01, 0.11740E+01, & + 0.11856E+01, 0.11972E+01, 0.12086E+01, 0.12200E+01, 0.12313E+01, & + 0.12425E+01, 0.12536E+01, 0.12646E+01, 0.12755E+01, 0.12864E+01, & + 0.12971E+01, 0.13078E+01, 0.13184E+01, 0.13290E+01, 0.13394E+01, & + 0.13498E+01, 0.13601E+01, 0.13704E+01, 0.13805E+01, 0.13906E+01, & + 0.14006E+01, 0.14106E+01, 0.14205E+01, 0.14303E+01, 0.14401E+01, & + 0.14498E+01, 0.14594E+01, 0.14690E+01, 0.14785E+01, 0.14880E+01, & + 0.14974E+01, 0.15067E+01, 0.15160E+01, 0.15252E+01, 0.15344E+01, & + 0.15435E+01, 0.15526E+01, 0.15616E+01, 0.15706E+01, 0.15795E+01, & + 0.15883E+01, 0.15971E+01, 0.16059E+01, 0.16146E+01, 0.16233E+01, & + 0.16319E+01, 0.16404E+01, 0.16489E+01, 0.16574E+01, 0.16658E+01, & + 0.16742E+01, 0.16825E+01, 0.16908E+01, 0.16991E+01, 0.17073E+01, & + 0.17155E+01, 0.17236E+01, 0.17317E+01, 0.17397E+01, 0.17477E+01, & + 0.17557E+01, 0.17636E+01, 0.17715E+01, 0.17793E+01, 0.17871E+01, & + 0.17949E+01, 0.18026E+01, 0.18103E+01, 0.18180E+01, 0.18256E+01, & + 0.18332E+01, 0.18408E+01, 0.18483E+01, 0.18558E+01, 0.18632E+01, & + 0.18707E+01, 0.18780E+01, 0.18854E+01, 0.18927E+01, 0.19000E+01/ + + DATA (BNC09M(I),I=701,741)/ & + 0.19073E+01, 0.19145E+01, 0.19217E+01, 0.19289E+01, 0.19360E+01, & + 0.19431E+01, 0.19502E+01, 0.19572E+01, 0.19643E+01, 0.19713E+01, & + 0.19782E+01, 0.19852E+01, 0.19921E+01, 0.19989E+01, 0.20058E+01, & + 0.20126E+01, 0.20194E+01, 0.20262E+01, 0.20329E+01, 0.20397E+01, & + 0.20464E+01, 0.20530E+01, 0.20597E+01, 0.20663E+01, 0.20729E+01, & + 0.20794E+01, 0.20860E+01, 0.20925E+01, 0.20990E+01, 0.21055E+01, & + 0.21119E+01, 0.21184E+01, 0.21248E+01, 0.21311E+01, 0.21375E+01, & + 0.21438E+01, 0.21502E+01, 0.21564E+01, 0.21627E+01, 0.21690E+01, & + 0.21752E+01 & + / +! +! *** (H, NO3) +! + DATA (BNC10M (I),I= 1,100)/ & + -0.48649E-01,-0.85767E-01,-0.10978E+00,-0.12480E+00,-0.13548E+00, & + -0.14354E+00,-0.14981E+00,-0.15480E+00,-0.15882E+00,-0.16206E+00, & + -0.16468E+00,-0.16679E+00,-0.16847E+00,-0.16978E+00,-0.17078E+00, & + -0.17151E+00,-0.17200E+00,-0.17228E+00,-0.17237E+00,-0.17230E+00, & + -0.17208E+00,-0.17173E+00,-0.17125E+00,-0.17067E+00,-0.16998E+00, & + -0.16921E+00,-0.16835E+00,-0.16742E+00,-0.16643E+00,-0.16536E+00, & + -0.16425E+00,-0.16308E+00,-0.16186E+00,-0.16060E+00,-0.15929E+00, & + -0.15795E+00,-0.15658E+00,-0.15518E+00,-0.15375E+00,-0.15229E+00, & + -0.15080E+00,-0.14930E+00,-0.14778E+00,-0.14623E+00,-0.14468E+00, & + -0.14310E+00,-0.14151E+00,-0.13991E+00,-0.13830E+00,-0.13667E+00, & + -0.13504E+00,-0.13339E+00,-0.13174E+00,-0.13008E+00,-0.12841E+00, & + -0.12673E+00,-0.12505E+00,-0.12335E+00,-0.12166E+00,-0.11995E+00, & + -0.11824E+00,-0.11652E+00,-0.11479E+00,-0.11306E+00,-0.11132E+00, & + -0.10957E+00,-0.10782E+00,-0.10605E+00,-0.10428E+00,-0.10250E+00, & + -0.10071E+00,-0.98911E-01,-0.97103E-01,-0.95285E-01,-0.93457E-01, & + -0.91617E-01,-0.89767E-01,-0.87906E-01,-0.86032E-01,-0.84147E-01, & + -0.82250E-01,-0.80340E-01,-0.78418E-01,-0.76482E-01,-0.74534E-01, & + -0.72572E-01,-0.70597E-01,-0.68609E-01,-0.66607E-01,-0.64593E-01, & + -0.62565E-01,-0.60523E-01,-0.58469E-01,-0.56402E-01,-0.54322E-01, & + -0.52230E-01,-0.50125E-01,-0.48009E-01,-0.45881E-01,-0.43741E-01/ + + DATA (BNC10M (I),I=101,200)/ & + -0.41591E-01,-0.39430E-01,-0.37259E-01,-0.35077E-01,-0.32887E-01, & + -0.30687E-01,-0.28479E-01,-0.26263E-01,-0.24039E-01,-0.21808E-01, & + -0.19569E-01,-0.17325E-01,-0.15074E-01,-0.12818E-01,-0.10556E-01, & + -0.82900E-02,-0.60192E-02,-0.37444E-02,-0.14659E-02, 0.81591E-03, & + 0.28768E-02, 0.51902E-02, 0.75034E-02, 0.98163E-02, 0.12129E-01, & + 0.14441E-01, 0.16752E-01, 0.19063E-01, 0.21374E-01, 0.23683E-01, & + 0.25992E-01, 0.28300E-01, 0.30607E-01, 0.32913E-01, 0.35219E-01, & + 0.37523E-01, 0.39826E-01, 0.42127E-01, 0.44428E-01, 0.46727E-01, & + 0.49025E-01, 0.51322E-01, 0.53617E-01, 0.55911E-01, 0.58203E-01, & + 0.60494E-01, 0.62784E-01, 0.65071E-01, 0.67357E-01, 0.69642E-01, & + 0.71924E-01, 0.74205E-01, 0.76484E-01, 0.78761E-01, 0.81037E-01, & + 0.83310E-01, 0.85582E-01, 0.87852E-01, 0.90120E-01, 0.92385E-01, & + 0.94649E-01, 0.96911E-01, 0.99170E-01, 0.10143E+00, 0.10368E+00, & + 0.10594E+00, 0.10819E+00, 0.11044E+00, 0.11268E+00, 0.11493E+00, & + 0.11717E+00, 0.11941E+00, 0.12165E+00, 0.12388E+00, 0.12612E+00, & + 0.12835E+00, 0.13058E+00, 0.13280E+00, 0.13503E+00, 0.13725E+00, & + 0.13947E+00, 0.14168E+00, 0.14390E+00, 0.14611E+00, 0.14832E+00, & + 0.15052E+00, 0.15273E+00, 0.15493E+00, 0.15713E+00, 0.15932E+00, & + 0.16152E+00, 0.16371E+00, 0.16590E+00, 0.16808E+00, 0.17027E+00, & + 0.17245E+00, 0.17463E+00, 0.17680E+00, 0.17898E+00, 0.18115E+00/ + + DATA (BNC10M (I),I=201,300)/ & + 0.18332E+00, 0.18548E+00, 0.18764E+00, 0.18980E+00, 0.19196E+00, & + 0.19412E+00, 0.19627E+00, 0.19842E+00, 0.20056E+00, 0.20271E+00, & + 0.20485E+00, 0.20699E+00, 0.20912E+00, 0.21126E+00, 0.21339E+00, & + 0.21552E+00, 0.21764E+00, 0.21976E+00, 0.22188E+00, 0.22400E+00, & + 0.22611E+00, 0.22823E+00, 0.23033E+00, 0.23244E+00, 0.23454E+00, & + 0.23664E+00, 0.23874E+00, 0.24084E+00, 0.24293E+00, 0.24502E+00, & + 0.24711E+00, 0.24919E+00, 0.25127E+00, 0.25335E+00, 0.25543E+00, & + 0.25750E+00, 0.25957E+00, 0.26164E+00, 0.26370E+00, 0.26577E+00, & + 0.26783E+00, 0.26988E+00, 0.27194E+00, 0.27399E+00, 0.27604E+00, & + 0.27808E+00, 0.28013E+00, 0.28217E+00, 0.28420E+00, 0.28624E+00, & + 0.28827E+00, 0.29030E+00, 0.29233E+00, 0.29435E+00, 0.29637E+00, & + 0.29839E+00, 0.30041E+00, 0.30242E+00, 0.30443E+00, 0.30644E+00, & + 0.30844E+00, 0.31044E+00, 0.31244E+00, 0.31444E+00, 0.31644E+00, & + 0.31843E+00, 0.32042E+00, 0.32240E+00, 0.32439E+00, 0.32637E+00, & + 0.32834E+00, 0.33032E+00, 0.33229E+00, 0.33426E+00, 0.33623E+00, & + 0.33819E+00, 0.34016E+00, 0.34211E+00, 0.34407E+00, 0.34603E+00, & + 0.34798E+00, 0.34993E+00, 0.35187E+00, 0.35382E+00, 0.35576E+00, & + 0.35769E+00, 0.35963E+00, 0.36156E+00, 0.36349E+00, 0.36542E+00, & + 0.36735E+00, 0.36927E+00, 0.37119E+00, 0.37310E+00, 0.37502E+00, & + 0.37693E+00, 0.37884E+00, 0.38075E+00, 0.38265E+00, 0.38455E+00/ + + DATA (BNC10M (I),I=301,400)/ & + 0.38645E+00, 0.38835E+00, 0.39024E+00, 0.39213E+00, 0.39402E+00, & + 0.39591E+00, 0.39779E+00, 0.39968E+00, 0.40155E+00, 0.40343E+00, & + 0.40530E+00, 0.40717E+00, 0.40904E+00, 0.41091E+00, 0.41277E+00, & + 0.41463E+00, 0.41649E+00, 0.41835E+00, 0.42020E+00, 0.42205E+00, & + 0.42390E+00, 0.42575E+00, 0.42759E+00, 0.42943E+00, 0.43127E+00, & + 0.43311E+00, 0.43494E+00, 0.43677E+00, 0.43860E+00, 0.44043E+00, & + 0.44225E+00, 0.44407E+00, 0.44589E+00, 0.44771E+00, 0.44952E+00, & + 0.45134E+00, 0.45315E+00, 0.45495E+00, 0.45676E+00, 0.45856E+00, & + 0.46036E+00, 0.46216E+00, 0.46395E+00, 0.46575E+00, 0.46754E+00, & + 0.46932E+00, 0.47111E+00, 0.47289E+00, 0.47467E+00, 0.47645E+00, & + 0.47823E+00, 0.48000E+00, 0.48178E+00, 0.48355E+00, 0.48531E+00, & + 0.48708E+00, 0.48884E+00, 0.49060E+00, 0.49236E+00, 0.49411E+00, & + 0.49587E+00, 0.49762E+00, 0.49937E+00, 0.50111E+00, 0.50286E+00, & + 0.50460E+00, 0.50634E+00, 0.50808E+00, 0.50981E+00, 0.51154E+00, & + 0.51327E+00, 0.51500E+00, 0.51673E+00, 0.51845E+00, 0.52017E+00, & + 0.52189E+00, 0.52361E+00, 0.52533E+00, 0.52704E+00, 0.52875E+00, & + 0.53046E+00, 0.53216E+00, 0.53387E+00, 0.53557E+00, 0.53727E+00, & + 0.53897E+00, 0.54066E+00, 0.54236E+00, 0.54405E+00, 0.54574E+00, & + 0.54742E+00, 0.54911E+00, 0.55079E+00, 0.55247E+00, 0.55415E+00, & + 0.55583E+00, 0.55750E+00, 0.55917E+00, 0.56084E+00, 0.56251E+00/ + + DATA (BNC10M (I),I=401,500)/ & + 0.56418E+00, 0.56584E+00, 0.56750E+00, 0.56916E+00, 0.57082E+00, & + 0.57247E+00, 0.57413E+00, 0.57578E+00, 0.57743E+00, 0.57907E+00, & + 0.58072E+00, 0.58236E+00, 0.58400E+00, 0.58564E+00, 0.58728E+00, & + 0.58891E+00, 0.59055E+00, 0.59218E+00, 0.59380E+00, 0.59543E+00, & + 0.59706E+00, 0.59868E+00, 0.60030E+00, 0.60192E+00, 0.60354E+00, & + 0.60515E+00, 0.60676E+00, 0.60837E+00, 0.60998E+00, 0.61159E+00, & + 0.61319E+00, 0.61480E+00, 0.61640E+00, 0.61800E+00, 0.61959E+00, & + 0.62119E+00, 0.62278E+00, 0.62437E+00, 0.62596E+00, 0.62755E+00, & + 0.62914E+00, 0.63072E+00, 0.63230E+00, 0.63388E+00, 0.63546E+00, & + 0.63704E+00, 0.63861E+00, 0.64018E+00, 0.64175E+00, 0.64332E+00, & + 0.64489E+00, 0.64645E+00, 0.64802E+00, 0.64958E+00, 0.65114E+00, & + 0.65269E+00, 0.65425E+00, 0.65580E+00, 0.65735E+00, 0.65890E+00, & + 0.66045E+00, 0.66200E+00, 0.66354E+00, 0.66509E+00, 0.66663E+00, & + 0.66817E+00, 0.66970E+00, 0.67124E+00, 0.67277E+00, 0.67431E+00, & + 0.67584E+00, 0.67736E+00, 0.67889E+00, 0.68042E+00, 0.68194E+00, & + 0.68346E+00, 0.68498E+00, 0.68650E+00, 0.68801E+00, 0.68953E+00, & + 0.69104E+00, 0.69255E+00, 0.69406E+00, 0.69557E+00, 0.69707E+00, & + 0.69858E+00, 0.70008E+00, 0.70158E+00, 0.70308E+00, 0.70457E+00, & + 0.70607E+00, 0.70756E+00, 0.70905E+00, 0.71054E+00, 0.71203E+00, & + 0.71352E+00, 0.71500E+00, 0.71649E+00, 0.71797E+00, 0.71945E+00/ + + DATA (BNC10M (I),I=501,600)/ & + 0.72093E+00, 0.72240E+00, 0.72388E+00, 0.72535E+00, 0.72682E+00, & + 0.72829E+00, 0.72976E+00, 0.73123E+00, 0.73269E+00, 0.73416E+00, & + 0.73562E+00, 0.73708E+00, 0.73854E+00, 0.74000E+00, 0.74145E+00, & + 0.74290E+00, 0.74436E+00, 0.74581E+00, 0.74726E+00, 0.74870E+00, & + 0.75015E+00, 0.75159E+00, 0.75304E+00, 0.75448E+00, 0.75592E+00, & + 0.75735E+00, 0.75879E+00, 0.76022E+00, 0.76166E+00, 0.76309E+00, & + 0.76452E+00, 0.76595E+00, 0.76737E+00, 0.76880E+00, 0.77022E+00, & + 0.77164E+00, 0.77307E+00, 0.77448E+00, 0.77590E+00, 0.77732E+00, & + 0.77873E+00, 0.78015E+00, 0.78156E+00, 0.78297E+00, 0.78437E+00, & + 0.78578E+00, 0.78719E+00, 0.78859E+00, 0.78999E+00, 0.79139E+00, & + 0.79279E+00, 0.79419E+00, 0.79559E+00, 0.79698E+00, 0.79838E+00, & + 0.79977E+00, 0.80116E+00, 0.80255E+00, 0.80393E+00, 0.80532E+00, & + 0.80671E+00, 0.80809E+00, 0.80947E+00, 0.81085E+00, 0.81223E+00, & + 0.81361E+00, 0.81498E+00, 0.81636E+00, 0.81773E+00, 0.81910E+00, & + 0.82047E+00, 0.82184E+00, 0.82321E+00, 0.82457E+00, 0.82594E+00, & + 0.82730E+00, 0.82866E+00, 0.83002E+00, 0.83138E+00, 0.83274E+00, & + 0.83409E+00, 0.83545E+00, 0.83680E+00, 0.83815E+00, 0.83950E+00, & + 0.84085E+00, 0.84220E+00, 0.84355E+00, 0.84489E+00, 0.84624E+00, & + 0.84758E+00, 0.84892E+00, 0.85026E+00, 0.85160E+00, 0.85293E+00, & + 0.85427E+00, 0.85560E+00, 0.85693E+00, 0.85827E+00, 0.86325E+00/ + + DATA (BNC10M (I),I=601,700)/ & + 0.87414E+00, 0.88722E+00, 0.90017E+00, 0.91300E+00, 0.92570E+00, & + 0.93828E+00, 0.95075E+00, 0.96310E+00, 0.97533E+00, 0.98746E+00, & + 0.99947E+00, 0.10114E+01, 0.10232E+01, 0.10349E+01, 0.10465E+01, & + 0.10580E+01, 0.10694E+01, 0.10807E+01, 0.10919E+01, 0.11030E+01, & + 0.11141E+01, 0.11250E+01, 0.11358E+01, 0.11466E+01, 0.11573E+01, & + 0.11679E+01, 0.11784E+01, 0.11889E+01, 0.11992E+01, 0.12095E+01, & + 0.12197E+01, 0.12299E+01, 0.12399E+01, 0.12499E+01, 0.12598E+01, & + 0.12697E+01, 0.12795E+01, 0.12892E+01, 0.12988E+01, 0.13084E+01, & + 0.13179E+01, 0.13274E+01, 0.13367E+01, 0.13461E+01, 0.13553E+01, & + 0.13645E+01, 0.13737E+01, 0.13828E+01, 0.13918E+01, 0.14008E+01, & + 0.14097E+01, 0.14186E+01, 0.14274E+01, 0.14362E+01, 0.14449E+01, & + 0.14535E+01, 0.14621E+01, 0.14707E+01, 0.14792E+01, 0.14876E+01, & + 0.14960E+01, 0.15044E+01, 0.15127E+01, 0.15210E+01, 0.15292E+01, & + 0.15374E+01, 0.15455E+01, 0.15536E+01, 0.15616E+01, 0.15696E+01, & + 0.15776E+01, 0.15855E+01, 0.15934E+01, 0.16012E+01, 0.16090E+01, & + 0.16168E+01, 0.16245E+01, 0.16322E+01, 0.16398E+01, 0.16474E+01, & + 0.16550E+01, 0.16625E+01, 0.16700E+01, 0.16774E+01, 0.16849E+01, & + 0.16922E+01, 0.16996E+01, 0.17069E+01, 0.17142E+01, 0.17214E+01, & + 0.17286E+01, 0.17358E+01, 0.17430E+01, 0.17501E+01, 0.17572E+01, & + 0.17642E+01, 0.17712E+01, 0.17782E+01, 0.17852E+01, 0.17921E+01/ + + DATA (BNC10M(I),I=701,741)/ & + 0.17990E+01, 0.18059E+01, 0.18127E+01, 0.18195E+01, 0.18263E+01, & + 0.18331E+01, 0.18398E+01, 0.18465E+01, 0.18532E+01, 0.18598E+01, & + 0.18664E+01, 0.18730E+01, 0.18796E+01, 0.18861E+01, 0.18926E+01, & + 0.18991E+01, 0.19056E+01, 0.19120E+01, 0.19184E+01, 0.19248E+01, & + 0.19312E+01, 0.19375E+01, 0.19439E+01, 0.19502E+01, 0.19564E+01, & + 0.19627E+01, 0.19689E+01, 0.19751E+01, 0.19813E+01, 0.19874E+01, & + 0.19936E+01, 0.19997E+01, 0.20058E+01, 0.20118E+01, 0.20179E+01, & + 0.20239E+01, 0.20299E+01, 0.20359E+01, 0.20419E+01, 0.20478E+01, & + 0.20537E+01 & + / +! +! *** (H, Cl) +! + DATA (BNC11M (I),I= 1,100)/ & + -0.47533E-01,-0.81940E-01,-0.10288E+00,-0.11511E+00,-0.12316E+00, & + -0.12868E+00,-0.13248E+00,-0.13503E+00,-0.13662E+00,-0.13745E+00, & + -0.13766E+00,-0.13734E+00,-0.13659E+00,-0.13546E+00,-0.13399E+00, & + -0.13224E+00,-0.13022E+00,-0.12796E+00,-0.12550E+00,-0.12284E+00, & + -0.12001E+00,-0.11702E+00,-0.11388E+00,-0.11061E+00,-0.10721E+00, & + -0.10369E+00,-0.10007E+00,-0.96344E-01,-0.92526E-01,-0.88621E-01, & + -0.84635E-01,-0.80573E-01,-0.76440E-01,-0.72241E-01,-0.67980E-01, & + -0.63661E-01,-0.59289E-01,-0.54866E-01,-0.50396E-01,-0.45882E-01, & + -0.41327E-01,-0.36734E-01,-0.32105E-01,-0.27442E-01,-0.22748E-01, & + -0.18025E-01,-0.13275E-01,-0.84990E-02,-0.36992E-02, 0.11231E-02, & + 0.59666E-02, 0.10830E-01, 0.15712E-01, 0.20613E-01, 0.25530E-01, & + 0.30464E-01, 0.35414E-01, 0.40380E-01, 0.45360E-01, 0.50356E-01, & + 0.55366E-01, 0.60391E-01, 0.65431E-01, 0.70486E-01, 0.75557E-01, & + 0.80642E-01, 0.85744E-01, 0.90863E-01, 0.95998E-01, 0.10115E+00, & + 0.10632E+00, 0.11151E+00, 0.11672E+00, 0.12195E+00, 0.12720E+00, & + 0.13247E+00, 0.13777E+00, 0.14308E+00, 0.14843E+00, 0.15379E+00, & + 0.15918E+00, 0.16460E+00, 0.17004E+00, 0.17550E+00, 0.18100E+00, & + 0.18652E+00, 0.19207E+00, 0.19764E+00, 0.20324E+00, 0.20887E+00, & + 0.21453E+00, 0.22022E+00, 0.22593E+00, 0.23166E+00, 0.23743E+00, & + 0.24322E+00, 0.24903E+00, 0.25487E+00, 0.26073E+00, 0.26661E+00/ + + DATA (BNC11M (I),I=101,200)/ & + 0.27252E+00, 0.27845E+00, 0.28440E+00, 0.29037E+00, 0.29635E+00, & + 0.30235E+00, 0.30838E+00, 0.31441E+00, 0.32046E+00, 0.32652E+00, & + 0.33260E+00, 0.33869E+00, 0.34478E+00, 0.35089E+00, 0.35701E+00, & + 0.36313E+00, 0.36926E+00, 0.37539E+00, 0.38153E+00, 0.38767E+00, & + 0.39330E+00, 0.39951E+00, 0.40571E+00, 0.41191E+00, 0.41810E+00, & + 0.42429E+00, 0.43047E+00, 0.43665E+00, 0.44282E+00, 0.44898E+00, & + 0.45514E+00, 0.46129E+00, 0.46744E+00, 0.47358E+00, 0.47971E+00, & + 0.48583E+00, 0.49195E+00, 0.49806E+00, 0.50417E+00, 0.51026E+00, & + 0.51635E+00, 0.52243E+00, 0.52850E+00, 0.53456E+00, 0.54062E+00, & + 0.54667E+00, 0.55271E+00, 0.55874E+00, 0.56476E+00, 0.57077E+00, & + 0.57678E+00, 0.58277E+00, 0.58876E+00, 0.59474E+00, 0.60071E+00, & + 0.60667E+00, 0.61262E+00, 0.61856E+00, 0.62449E+00, 0.63041E+00, & + 0.63633E+00, 0.64223E+00, 0.64812E+00, 0.65401E+00, 0.65988E+00, & + 0.66575E+00, 0.67160E+00, 0.67745E+00, 0.68328E+00, 0.68911E+00, & + 0.69493E+00, 0.70073E+00, 0.70653E+00, 0.71231E+00, 0.71809E+00, & + 0.72386E+00, 0.72961E+00, 0.73536E+00, 0.74109E+00, 0.74682E+00, & + 0.75253E+00, 0.75824E+00, 0.76393E+00, 0.76962E+00, 0.77529E+00, & + 0.78096E+00, 0.78661E+00, 0.79226E+00, 0.79789E+00, 0.80351E+00, & + 0.80913E+00, 0.81473E+00, 0.82032E+00, 0.82590E+00, 0.83148E+00, & + 0.83704E+00, 0.84259E+00, 0.84813E+00, 0.85366E+00, 0.85918E+00/ + + DATA (BNC11M (I),I=201,300)/ & + 0.86469E+00, 0.87019E+00, 0.87568E+00, 0.88116E+00, 0.88663E+00, & + 0.89209E+00, 0.89754E+00, 0.90298E+00, 0.90841E+00, 0.91383E+00, & + 0.91923E+00, 0.92463E+00, 0.93002E+00, 0.93540E+00, 0.94077E+00, & + 0.94612E+00, 0.95147E+00, 0.95681E+00, 0.96213E+00, 0.96745E+00, & + 0.97276E+00, 0.97806E+00, 0.98334E+00, 0.98862E+00, 0.99389E+00, & + 0.99914E+00, 0.10044E+01, 0.10096E+01, 0.10149E+01, 0.10201E+01, & + 0.10253E+01, 0.10305E+01, 0.10357E+01, 0.10408E+01, 0.10460E+01, & + 0.10512E+01, 0.10563E+01, 0.10615E+01, 0.10666E+01, 0.10717E+01, & + 0.10768E+01, 0.10819E+01, 0.10870E+01, 0.10921E+01, 0.10972E+01, & + 0.11022E+01, 0.11073E+01, 0.11123E+01, 0.11174E+01, 0.11224E+01, & + 0.11274E+01, 0.11324E+01, 0.11374E+01, 0.11424E+01, 0.11474E+01, & + 0.11523E+01, 0.11573E+01, 0.11622E+01, 0.11672E+01, 0.11721E+01, & + 0.11770E+01, 0.11819E+01, 0.11868E+01, 0.11917E+01, 0.11966E+01, & + 0.12015E+01, 0.12064E+01, 0.12112E+01, 0.12161E+01, 0.12209E+01, & + 0.12258E+01, 0.12306E+01, 0.12354E+01, 0.12402E+01, 0.12450E+01, & + 0.12498E+01, 0.12546E+01, 0.12593E+01, 0.12641E+01, 0.12688E+01, & + 0.12736E+01, 0.12783E+01, 0.12831E+01, 0.12878E+01, 0.12925E+01, & + 0.12972E+01, 0.13019E+01, 0.13066E+01, 0.13112E+01, 0.13159E+01, & + 0.13206E+01, 0.13252E+01, 0.13299E+01, 0.13345E+01, 0.13391E+01, & + 0.13437E+01, 0.13483E+01, 0.13529E+01, 0.13575E+01, 0.13621E+01/ + + DATA (BNC11M (I),I=301,400)/ & + 0.13667E+01, 0.13713E+01, 0.13758E+01, 0.13804E+01, 0.13849E+01, & + 0.13895E+01, 0.13940E+01, 0.13985E+01, 0.14030E+01, 0.14075E+01, & + 0.14120E+01, 0.14165E+01, 0.14210E+01, 0.14255E+01, 0.14299E+01, & + 0.14344E+01, 0.14388E+01, 0.14433E+01, 0.14477E+01, 0.14521E+01, & + 0.14565E+01, 0.14610E+01, 0.14654E+01, 0.14698E+01, 0.14741E+01, & + 0.14785E+01, 0.14829E+01, 0.14873E+01, 0.14916E+01, 0.14960E+01, & + 0.15003E+01, 0.15047E+01, 0.15090E+01, 0.15133E+01, 0.15176E+01, & + 0.15219E+01, 0.15262E+01, 0.15305E+01, 0.15348E+01, 0.15391E+01, & + 0.15433E+01, 0.15476E+01, 0.15519E+01, 0.15561E+01, 0.15604E+01, & + 0.15646E+01, 0.15688E+01, 0.15730E+01, 0.15773E+01, 0.15815E+01, & + 0.15857E+01, 0.15899E+01, 0.15940E+01, 0.15982E+01, 0.16024E+01, & + 0.16066E+01, 0.16107E+01, 0.16149E+01, 0.16190E+01, 0.16231E+01, & + 0.16273E+01, 0.16314E+01, 0.16355E+01, 0.16396E+01, 0.16437E+01, & + 0.16478E+01, 0.16519E+01, 0.16560E+01, 0.16601E+01, 0.16642E+01, & + 0.16682E+01, 0.16723E+01, 0.16763E+01, 0.16804E+01, 0.16844E+01, & + 0.16884E+01, 0.16925E+01, 0.16965E+01, 0.17005E+01, 0.17045E+01, & + 0.17085E+01, 0.17125E+01, 0.17165E+01, 0.17205E+01, 0.17245E+01, & + 0.17284E+01, 0.17324E+01, 0.17363E+01, 0.17403E+01, 0.17442E+01, & + 0.17482E+01, 0.17521E+01, 0.17560E+01, 0.17599E+01, 0.17639E+01, & + 0.17678E+01, 0.17717E+01, 0.17756E+01, 0.17795E+01, 0.17833E+01/ + + DATA (BNC11M (I),I=401,500)/ & + 0.17872E+01, 0.17911E+01, 0.17950E+01, 0.17988E+01, 0.18027E+01, & + 0.18065E+01, 0.18104E+01, 0.18142E+01, 0.18180E+01, 0.18218E+01, & + 0.18257E+01, 0.18295E+01, 0.18333E+01, 0.18371E+01, 0.18409E+01, & + 0.18447E+01, 0.18485E+01, 0.18522E+01, 0.18560E+01, 0.18598E+01, & + 0.18635E+01, 0.18673E+01, 0.18710E+01, 0.18748E+01, 0.18785E+01, & + 0.18823E+01, 0.18860E+01, 0.18897E+01, 0.18934E+01, 0.18971E+01, & + 0.19008E+01, 0.19045E+01, 0.19082E+01, 0.19119E+01, 0.19156E+01, & + 0.19193E+01, 0.19230E+01, 0.19266E+01, 0.19303E+01, 0.19340E+01, & + 0.19376E+01, 0.19413E+01, 0.19449E+01, 0.19485E+01, 0.19522E+01, & + 0.19558E+01, 0.19594E+01, 0.19630E+01, 0.19666E+01, 0.19702E+01, & + 0.19738E+01, 0.19774E+01, 0.19810E+01, 0.19846E+01, 0.19882E+01, & + 0.19918E+01, 0.19953E+01, 0.19989E+01, 0.20025E+01, 0.20060E+01, & + 0.20096E+01, 0.20131E+01, 0.20167E+01, 0.20202E+01, 0.20237E+01, & + 0.20272E+01, 0.20308E+01, 0.20343E+01, 0.20378E+01, 0.20413E+01, & + 0.20448E+01, 0.20483E+01, 0.20518E+01, 0.20553E+01, 0.20587E+01, & + 0.20622E+01, 0.20657E+01, 0.20692E+01, 0.20726E+01, 0.20761E+01, & + 0.20795E+01, 0.20830E+01, 0.20864E+01, 0.20899E+01, 0.20933E+01, & + 0.20967E+01, 0.21001E+01, 0.21036E+01, 0.21070E+01, 0.21104E+01, & + 0.21138E+01, 0.21172E+01, 0.21206E+01, 0.21240E+01, 0.21274E+01, & + 0.21308E+01, 0.21341E+01, 0.21375E+01, 0.21409E+01, 0.21442E+01/ + + DATA (BNC11M (I),I=501,600)/ & + 0.21476E+01, 0.21510E+01, 0.21543E+01, 0.21577E+01, 0.21610E+01, & + 0.21643E+01, 0.21677E+01, 0.21710E+01, 0.21743E+01, 0.21776E+01, & + 0.21810E+01, 0.21843E+01, 0.21876E+01, 0.21909E+01, 0.21942E+01, & + 0.21975E+01, 0.22008E+01, 0.22041E+01, 0.22073E+01, 0.22106E+01, & + 0.22139E+01, 0.22172E+01, 0.22204E+01, 0.22237E+01, 0.22269E+01, & + 0.22302E+01, 0.22334E+01, 0.22367E+01, 0.22399E+01, 0.22432E+01, & + 0.22464E+01, 0.22496E+01, 0.22528E+01, 0.22561E+01, 0.22593E+01, & + 0.22625E+01, 0.22657E+01, 0.22689E+01, 0.22721E+01, 0.22753E+01, & + 0.22785E+01, 0.22817E+01, 0.22849E+01, 0.22880E+01, 0.22912E+01, & + 0.22944E+01, 0.22975E+01, 0.23007E+01, 0.23039E+01, 0.23070E+01, & + 0.23102E+01, 0.23133E+01, 0.23165E+01, 0.23196E+01, 0.23227E+01, & + 0.23259E+01, 0.23290E+01, 0.23321E+01, 0.23352E+01, 0.23384E+01, & + 0.23415E+01, 0.23446E+01, 0.23477E+01, 0.23508E+01, 0.23539E+01, & + 0.23570E+01, 0.23601E+01, 0.23632E+01, 0.23662E+01, 0.23693E+01, & + 0.23724E+01, 0.23755E+01, 0.23785E+01, 0.23816E+01, 0.23847E+01, & + 0.23877E+01, 0.23908E+01, 0.23938E+01, 0.23969E+01, 0.23999E+01, & + 0.24029E+01, 0.24060E+01, 0.24090E+01, 0.24120E+01, 0.24150E+01, & + 0.24181E+01, 0.24211E+01, 0.24241E+01, 0.24271E+01, 0.24301E+01, & + 0.24331E+01, 0.24361E+01, 0.24391E+01, 0.24421E+01, 0.24451E+01, & + 0.24481E+01, 0.24511E+01, 0.24540E+01, 0.24570E+01, 0.24681E+01/ + + DATA (BNC11M (I),I=601,700)/ & + 0.24924E+01, 0.25216E+01, 0.25504E+01, 0.25789E+01, 0.26071E+01, & + 0.26349E+01, 0.26625E+01, 0.26898E+01, 0.27168E+01, 0.27435E+01, & + 0.27699E+01, 0.27961E+01, 0.28220E+01, 0.28477E+01, 0.28731E+01, & + 0.28982E+01, 0.29231E+01, 0.29478E+01, 0.29722E+01, 0.29965E+01, & + 0.30205E+01, 0.30442E+01, 0.30678E+01, 0.30911E+01, 0.31143E+01, & + 0.31372E+01, 0.31599E+01, 0.31825E+01, 0.32048E+01, 0.32270E+01, & + 0.32490E+01, 0.32708E+01, 0.32924E+01, 0.33138E+01, 0.33351E+01, & + 0.33562E+01, 0.33771E+01, 0.33979E+01, 0.34185E+01, 0.34389E+01, & + 0.34592E+01, 0.34794E+01, 0.34993E+01, 0.35192E+01, 0.35389E+01, & + 0.35584E+01, 0.35778E+01, 0.35971E+01, 0.36162E+01, 0.36352E+01, & + 0.36541E+01, 0.36728E+01, 0.36914E+01, 0.37099E+01, 0.37282E+01, & + 0.37465E+01, 0.37646E+01, 0.37826E+01, 0.38004E+01, 0.38182E+01, & + 0.38358E+01, 0.38533E+01, 0.38707E+01, 0.38880E+01, 0.39052E+01, & + 0.39223E+01, 0.39393E+01, 0.39562E+01, 0.39729E+01, 0.39896E+01, & + 0.40062E+01, 0.40226E+01, 0.40390E+01, 0.40553E+01, 0.40715E+01, & + 0.40876E+01, 0.41035E+01, 0.41194E+01, 0.41353E+01, 0.41510E+01, & + 0.41666E+01, 0.41822E+01, 0.41976E+01, 0.42130E+01, 0.42283E+01, & + 0.42435E+01, 0.42586E+01, 0.42737E+01, 0.42886E+01, 0.43035E+01, & + 0.43183E+01, 0.43330E+01, 0.43477E+01, 0.43623E+01, 0.43768E+01, & + 0.43912E+01, 0.44056E+01, 0.44198E+01, 0.44341E+01, 0.44482E+01/ + + DATA (BNC11M(I),I=701,741)/ & + 0.44623E+01, 0.44763E+01, 0.44902E+01, 0.45041E+01, 0.45179E+01, & + 0.45316E+01, 0.45453E+01, 0.45589E+01, 0.45724E+01, 0.45859E+01, & + 0.45993E+01, 0.46126E+01, 0.46259E+01, 0.46391E+01, 0.46523E+01, & + 0.46654E+01, 0.46785E+01, 0.46915E+01, 0.47044E+01, 0.47173E+01, & + 0.47301E+01, 0.47428E+01, 0.47555E+01, 0.47682E+01, 0.47808E+01, & + 0.47933E+01, 0.48058E+01, 0.48183E+01, 0.48306E+01, 0.48430E+01, & + 0.48552E+01, 0.48675E+01, 0.48797E+01, 0.48918E+01, 0.49039E+01, & + 0.49159E+01, 0.49279E+01, 0.49398E+01, 0.49517E+01, 0.49635E+01, & + 0.49753E+01 & + / +! +! *** NaHSO4 +! + DATA (BNC12M (I),I= 1,100)/ & + -0.48506E-01,-0.85523E-01,-0.10966E+00,-0.12495E+00,-0.13595E+00, & + -0.14436E+00,-0.15100E+00,-0.15637E+00,-0.16075E+00,-0.16435E+00, & + -0.16731E+00,-0.16974E+00,-0.17171E+00,-0.17329E+00,-0.17453E+00, & + -0.17547E+00,-0.17613E+00,-0.17655E+00,-0.17675E+00,-0.17675E+00, & + -0.17656E+00,-0.17620E+00,-0.17567E+00,-0.17500E+00,-0.17419E+00, & + -0.17325E+00,-0.17219E+00,-0.17101E+00,-0.16973E+00,-0.16834E+00, & + -0.16685E+00,-0.16526E+00,-0.16359E+00,-0.16184E+00,-0.16000E+00, & + -0.15809E+00,-0.15610E+00,-0.15405E+00,-0.15192E+00,-0.14973E+00, & + -0.14749E+00,-0.14518E+00,-0.14281E+00,-0.14040E+00,-0.13793E+00, & + -0.13541E+00,-0.13284E+00,-0.13023E+00,-0.12757E+00,-0.12488E+00, & + -0.12214E+00,-0.11936E+00,-0.11654E+00,-0.11369E+00,-0.11081E+00, & + -0.10789E+00,-0.10493E+00,-0.10195E+00,-0.98933E-01,-0.95887E-01, & + -0.92812E-01,-0.89708E-01,-0.86577E-01,-0.83417E-01,-0.80231E-01, & + -0.77018E-01,-0.73779E-01,-0.70513E-01,-0.67222E-01,-0.63906E-01, & + -0.60563E-01,-0.57196E-01,-0.53803E-01,-0.50385E-01,-0.46941E-01, & + -0.43472E-01,-0.39979E-01,-0.36459E-01,-0.32915E-01,-0.29345E-01, & + -0.25749E-01,-0.22128E-01,-0.18482E-01,-0.14811E-01,-0.11115E-01, & + -0.73934E-02,-0.36468E-02, 0.12404E-03, 0.39196E-02, 0.77393E-02, & + 0.11583E-01, 0.15450E-01, 0.19340E-01, 0.23253E-01, 0.27187E-01, & + 0.31143E-01, 0.35121E-01, 0.39118E-01, 0.43135E-01, 0.47171E-01/ + + DATA (BNC12M (I),I=101,200)/ & + 0.51225E-01, 0.55297E-01, 0.59385E-01, 0.63489E-01, 0.67608E-01, & + 0.71741E-01, 0.75888E-01, 0.80047E-01, 0.84217E-01, 0.88399E-01, & + 0.92590E-01, 0.96791E-01, 0.10100E+00, 0.10522E+00, 0.10944E+00, & + 0.11367E+00, 0.11790E+00, 0.12214E+00, 0.12638E+00, 0.13063E+00, & + 0.13451E+00, 0.13880E+00, 0.14309E+00, 0.14737E+00, 0.15166E+00, & + 0.15593E+00, 0.16021E+00, 0.16448E+00, 0.16874E+00, 0.17301E+00, & + 0.17726E+00, 0.18151E+00, 0.18576E+00, 0.19000E+00, 0.19424E+00, & + 0.19847E+00, 0.20270E+00, 0.20692E+00, 0.21114E+00, 0.21535E+00, & + 0.21955E+00, 0.22375E+00, 0.22794E+00, 0.23213E+00, 0.23630E+00, & + 0.24048E+00, 0.24464E+00, 0.24881E+00, 0.25296E+00, 0.25711E+00, & + 0.26125E+00, 0.26538E+00, 0.26951E+00, 0.27363E+00, 0.27774E+00, & + 0.28185E+00, 0.28595E+00, 0.29004E+00, 0.29413E+00, 0.29821E+00, & + 0.30228E+00, 0.30634E+00, 0.31040E+00, 0.31445E+00, 0.31849E+00, & + 0.32253E+00, 0.32656E+00, 0.33058E+00, 0.33459E+00, 0.33860E+00, & + 0.34260E+00, 0.34659E+00, 0.35057E+00, 0.35455E+00, 0.35852E+00, & + 0.36248E+00, 0.36644E+00, 0.37038E+00, 0.37432E+00, 0.37826E+00, & + 0.38218E+00, 0.38610E+00, 0.39001E+00, 0.39391E+00, 0.39781E+00, & + 0.40170E+00, 0.40558E+00, 0.40945E+00, 0.41332E+00, 0.41718E+00, & + 0.42103E+00, 0.42487E+00, 0.42871E+00, 0.43254E+00, 0.43636E+00, & + 0.44018E+00, 0.44398E+00, 0.44778E+00, 0.45158E+00, 0.45536E+00/ + + DATA (BNC12M (I),I=201,300)/ & + 0.45914E+00, 0.46291E+00, 0.46668E+00, 0.47043E+00, 0.47418E+00, & + 0.47793E+00, 0.48166E+00, 0.48539E+00, 0.48911E+00, 0.49283E+00, & + 0.49653E+00, 0.50023E+00, 0.50393E+00, 0.50761E+00, 0.51129E+00, & + 0.51496E+00, 0.51863E+00, 0.52228E+00, 0.52594E+00, 0.52958E+00, & + 0.53322E+00, 0.53685E+00, 0.54047E+00, 0.54409E+00, 0.54770E+00, & + 0.55130E+00, 0.55490E+00, 0.55849E+00, 0.56207E+00, 0.56564E+00, & + 0.56921E+00, 0.57278E+00, 0.57633E+00, 0.57988E+00, 0.58342E+00, & + 0.58696E+00, 0.59049E+00, 0.59401E+00, 0.59753E+00, 0.60104E+00, & + 0.60454E+00, 0.60804E+00, 0.61153E+00, 0.61501E+00, 0.61849E+00, & + 0.62196E+00, 0.62543E+00, 0.62888E+00, 0.63234E+00, 0.63578E+00, & + 0.63922E+00, 0.64265E+00, 0.64608E+00, 0.64950E+00, 0.65292E+00, & + 0.65632E+00, 0.65973E+00, 0.66312E+00, 0.66651E+00, 0.66990E+00, & + 0.67327E+00, 0.67664E+00, 0.68001E+00, 0.68337E+00, 0.68672E+00, & + 0.69007E+00, 0.69341E+00, 0.69675E+00, 0.70008E+00, 0.70340E+00, & + 0.70672E+00, 0.71003E+00, 0.71334E+00, 0.71664E+00, 0.71993E+00, & + 0.72322E+00, 0.72650E+00, 0.72978E+00, 0.73305E+00, 0.73632E+00, & + 0.73958E+00, 0.74283E+00, 0.74608E+00, 0.74932E+00, 0.75256E+00, & + 0.75579E+00, 0.75902E+00, 0.76224E+00, 0.76546E+00, 0.76867E+00, & + 0.77187E+00, 0.77507E+00, 0.77826E+00, 0.78145E+00, 0.78463E+00, & + 0.78781E+00, 0.79098E+00, 0.79415E+00, 0.79731E+00, 0.80046E+00/ + + DATA (BNC12M (I),I=301,400)/ & + 0.80361E+00, 0.80676E+00, 0.80990E+00, 0.81303E+00, 0.81616E+00, & + 0.81928E+00, 0.82240E+00, 0.82552E+00, 0.82862E+00, 0.83173E+00, & + 0.83483E+00, 0.83792E+00, 0.84101E+00, 0.84409E+00, 0.84717E+00, & + 0.85024E+00, 0.85331E+00, 0.85637E+00, 0.85943E+00, 0.86248E+00, & + 0.86553E+00, 0.86857E+00, 0.87160E+00, 0.87464E+00, 0.87766E+00, & + 0.88069E+00, 0.88371E+00, 0.88672E+00, 0.88973E+00, 0.89273E+00, & + 0.89573E+00, 0.89872E+00, 0.90171E+00, 0.90469E+00, 0.90767E+00, & + 0.91065E+00, 0.91362E+00, 0.91658E+00, 0.91954E+00, 0.92250E+00, & + 0.92545E+00, 0.92840E+00, 0.93134E+00, 0.93427E+00, 0.93721E+00, & + 0.94014E+00, 0.94306E+00, 0.94598E+00, 0.94889E+00, 0.95180E+00, & + 0.95471E+00, 0.95761E+00, 0.96050E+00, 0.96339E+00, 0.96628E+00, & + 0.96916E+00, 0.97204E+00, 0.97492E+00, 0.97779E+00, 0.98065E+00, & + 0.98351E+00, 0.98637E+00, 0.98922E+00, 0.99207E+00, 0.99491E+00, & + 0.99775E+00, 0.10006E+01, 0.10034E+01, 0.10062E+01, 0.10091E+01, & + 0.10119E+01, 0.10147E+01, 0.10175E+01, 0.10203E+01, 0.10231E+01, & + 0.10259E+01, 0.10287E+01, 0.10315E+01, 0.10343E+01, 0.10370E+01, & + 0.10398E+01, 0.10426E+01, 0.10454E+01, 0.10481E+01, 0.10509E+01, & + 0.10536E+01, 0.10564E+01, 0.10591E+01, 0.10619E+01, 0.10646E+01, & + 0.10674E+01, 0.10701E+01, 0.10728E+01, 0.10755E+01, 0.10783E+01, & + 0.10810E+01, 0.10837E+01, 0.10864E+01, 0.10891E+01, 0.10918E+01/ + + DATA (BNC12M (I),I=401,500)/ & + 0.10945E+01, 0.10972E+01, 0.10999E+01, 0.11026E+01, 0.11052E+01, & + 0.11079E+01, 0.11106E+01, 0.11133E+01, 0.11159E+01, 0.11186E+01, & + 0.11212E+01, 0.11239E+01, 0.11265E+01, 0.11292E+01, 0.11318E+01, & + 0.11345E+01, 0.11371E+01, 0.11397E+01, 0.11424E+01, 0.11450E+01, & + 0.11476E+01, 0.11502E+01, 0.11528E+01, 0.11554E+01, 0.11581E+01, & + 0.11607E+01, 0.11633E+01, 0.11658E+01, 0.11684E+01, 0.11710E+01, & + 0.11736E+01, 0.11762E+01, 0.11788E+01, 0.11813E+01, 0.11839E+01, & + 0.11865E+01, 0.11890E+01, 0.11916E+01, 0.11942E+01, 0.11967E+01, & + 0.11993E+01, 0.12018E+01, 0.12044E+01, 0.12069E+01, 0.12094E+01, & + 0.12120E+01, 0.12145E+01, 0.12170E+01, 0.12195E+01, 0.12221E+01, & + 0.12246E+01, 0.12271E+01, 0.12296E+01, 0.12321E+01, 0.12346E+01, & + 0.12371E+01, 0.12396E+01, 0.12421E+01, 0.12446E+01, 0.12471E+01, & + 0.12495E+01, 0.12520E+01, 0.12545E+01, 0.12570E+01, 0.12594E+01, & + 0.12619E+01, 0.12644E+01, 0.12668E+01, 0.12693E+01, 0.12717E+01, & + 0.12742E+01, 0.12766E+01, 0.12791E+01, 0.12815E+01, 0.12839E+01, & + 0.12864E+01, 0.12888E+01, 0.12912E+01, 0.12937E+01, 0.12961E+01, & + 0.12985E+01, 0.13009E+01, 0.13033E+01, 0.13057E+01, 0.13081E+01, & + 0.13106E+01, 0.13130E+01, 0.13153E+01, 0.13177E+01, 0.13201E+01, & + 0.13225E+01, 0.13249E+01, 0.13273E+01, 0.13297E+01, 0.13320E+01, & + 0.13344E+01, 0.13368E+01, 0.13392E+01, 0.13415E+01, 0.13439E+01/ + + DATA (BNC12M (I),I=501,600)/ & + 0.13462E+01, 0.13486E+01, 0.13509E+01, 0.13533E+01, 0.13556E+01, & + 0.13580E+01, 0.13603E+01, 0.13627E+01, 0.13650E+01, 0.13673E+01, & + 0.13697E+01, 0.13720E+01, 0.13743E+01, 0.13766E+01, 0.13789E+01, & + 0.13813E+01, 0.13836E+01, 0.13859E+01, 0.13882E+01, 0.13905E+01, & + 0.13928E+01, 0.13951E+01, 0.13974E+01, 0.13997E+01, 0.14020E+01, & + 0.14042E+01, 0.14065E+01, 0.14088E+01, 0.14111E+01, 0.14134E+01, & + 0.14156E+01, 0.14179E+01, 0.14202E+01, 0.14224E+01, 0.14247E+01, & + 0.14270E+01, 0.14292E+01, 0.14315E+01, 0.14337E+01, 0.14360E+01, & + 0.14382E+01, 0.14405E+01, 0.14427E+01, 0.14449E+01, 0.14472E+01, & + 0.14494E+01, 0.14516E+01, 0.14539E+01, 0.14561E+01, 0.14583E+01, & + 0.14605E+01, 0.14628E+01, 0.14650E+01, 0.14672E+01, 0.14694E+01, & + 0.14716E+01, 0.14738E+01, 0.14760E+01, 0.14782E+01, 0.14804E+01, & + 0.14826E+01, 0.14848E+01, 0.14870E+01, 0.14892E+01, 0.14913E+01, & + 0.14935E+01, 0.14957E+01, 0.14979E+01, 0.15001E+01, 0.15022E+01, & + 0.15044E+01, 0.15066E+01, 0.15087E+01, 0.15109E+01, 0.15130E+01, & + 0.15152E+01, 0.15174E+01, 0.15195E+01, 0.15217E+01, 0.15238E+01, & + 0.15260E+01, 0.15281E+01, 0.15302E+01, 0.15324E+01, 0.15345E+01, & + 0.15366E+01, 0.15388E+01, 0.15409E+01, 0.15430E+01, 0.15451E+01, & + 0.15473E+01, 0.15494E+01, 0.15515E+01, 0.15536E+01, 0.15557E+01, & + 0.15578E+01, 0.15599E+01, 0.15621E+01, 0.15642E+01, 0.15720E+01/ + + DATA (BNC12M (I),I=601,700)/ & + 0.15892E+01, 0.16098E+01, 0.16302E+01, 0.16504E+01, 0.16704E+01, & + 0.16902E+01, 0.17098E+01, 0.17291E+01, 0.17483E+01, 0.17673E+01, & + 0.17861E+01, 0.18047E+01, 0.18232E+01, 0.18415E+01, 0.18596E+01, & + 0.18775E+01, 0.18953E+01, 0.19129E+01, 0.19304E+01, 0.19477E+01, & + 0.19648E+01, 0.19818E+01, 0.19987E+01, 0.20154E+01, 0.20320E+01, & + 0.20484E+01, 0.20647E+01, 0.20809E+01, 0.20969E+01, 0.21128E+01, & + 0.21286E+01, 0.21443E+01, 0.21598E+01, 0.21752E+01, 0.21905E+01, & + 0.22057E+01, 0.22208E+01, 0.22357E+01, 0.22506E+01, 0.22653E+01, & + 0.22800E+01, 0.22945E+01, 0.23089E+01, 0.23232E+01, 0.23374E+01, & + 0.23515E+01, 0.23656E+01, 0.23795E+01, 0.23933E+01, 0.24071E+01, & + 0.24207E+01, 0.24343E+01, 0.24477E+01, 0.24611E+01, 0.24744E+01, & + 0.24876E+01, 0.25007E+01, 0.25138E+01, 0.25267E+01, 0.25396E+01, & + 0.25524E+01, 0.25651E+01, 0.25778E+01, 0.25903E+01, 0.26028E+01, & + 0.26152E+01, 0.26276E+01, 0.26398E+01, 0.26520E+01, 0.26642E+01, & + 0.26762E+01, 0.26882E+01, 0.27001E+01, 0.27120E+01, 0.27238E+01, & + 0.27355E+01, 0.27472E+01, 0.27588E+01, 0.27703E+01, 0.27818E+01, & + 0.27932E+01, 0.28045E+01, 0.28158E+01, 0.28270E+01, 0.28382E+01, & + 0.28493E+01, 0.28604E+01, 0.28714E+01, 0.28823E+01, 0.28932E+01, & + 0.29040E+01, 0.29148E+01, 0.29256E+01, 0.29362E+01, 0.29468E+01, & + 0.29574E+01, 0.29679E+01, 0.29784E+01, 0.29888E+01, 0.29992E+01/ + + DATA (BNC12M(I),I=701,741)/ & + 0.30095E+01, 0.30198E+01, 0.30300E+01, 0.30402E+01, 0.30503E+01, & + 0.30604E+01, 0.30705E+01, 0.30804E+01, 0.30904E+01, 0.31003E+01, & + 0.31102E+01, 0.31200E+01, 0.31298E+01, 0.31395E+01, 0.31492E+01, & + 0.31588E+01, 0.31684E+01, 0.31780E+01, 0.31875E+01, 0.31970E+01, & + 0.32065E+01, 0.32159E+01, 0.32252E+01, 0.32346E+01, 0.32439E+01, & + 0.32531E+01, 0.32623E+01, 0.32715E+01, 0.32807E+01, 0.32898E+01, & + 0.32988E+01, 0.33079E+01, 0.33169E+01, 0.33258E+01, 0.33348E+01, & + 0.33436E+01, 0.33525E+01, 0.33613E+01, 0.33701E+01, 0.33789E+01, & + 0.33876E+01 & + / +! +! *** (NH4)3H(SO4)2 +! + DATA (BNC13M (I),I= 1,100)/ & + -0.79876E-01,-0.14479E+00,-0.19002E+00,-0.22052E+00,-0.24382E+00, & + -0.26276E+00,-0.27871E+00,-0.29249E+00,-0.30460E+00,-0.31540E+00, & + -0.32512E+00,-0.33395E+00,-0.34203E+00,-0.34946E+00,-0.35632E+00, & + -0.36270E+00,-0.36864E+00,-0.37419E+00,-0.37939E+00,-0.38427E+00, & + -0.38886E+00,-0.39320E+00,-0.39728E+00,-0.40115E+00,-0.40481E+00, & + -0.40828E+00,-0.41157E+00,-0.41469E+00,-0.41766E+00,-0.42048E+00, & + -0.42316E+00,-0.42571E+00,-0.42814E+00,-0.43045E+00,-0.43265E+00, & + -0.43474E+00,-0.43673E+00,-0.43863E+00,-0.44044E+00,-0.44216E+00, & + -0.44379E+00,-0.44535E+00,-0.44683E+00,-0.44824E+00,-0.44958E+00, & + -0.45085E+00,-0.45205E+00,-0.45320E+00,-0.45428E+00,-0.45531E+00, & + -0.45628E+00,-0.45720E+00,-0.45807E+00,-0.45888E+00,-0.45966E+00, & + -0.46038E+00,-0.46106E+00,-0.46170E+00,-0.46230E+00,-0.46285E+00, & + -0.46337E+00,-0.46385E+00,-0.46430E+00,-0.46471E+00,-0.46508E+00, & + -0.46542E+00,-0.46574E+00,-0.46602E+00,-0.46627E+00,-0.46649E+00, & + -0.46668E+00,-0.46684E+00,-0.46698E+00,-0.46710E+00,-0.46718E+00, & + -0.46724E+00,-0.46728E+00,-0.46730E+00,-0.46729E+00,-0.46726E+00, & + -0.46720E+00,-0.46713E+00,-0.46703E+00,-0.46691E+00,-0.46678E+00, & + -0.46662E+00,-0.46644E+00,-0.46625E+00,-0.46604E+00,-0.46580E+00, & + -0.46556E+00,-0.46529E+00,-0.46501E+00,-0.46471E+00,-0.46439E+00, & + -0.46406E+00,-0.46372E+00,-0.46335E+00,-0.46298E+00,-0.46259E+00/ + + DATA (BNC13M (I),I=101,200)/ & + -0.46219E+00,-0.46177E+00,-0.46134E+00,-0.46090E+00,-0.46045E+00, & + -0.45998E+00,-0.45951E+00,-0.45902E+00,-0.45852E+00,-0.45801E+00, & + -0.45749E+00,-0.45697E+00,-0.45643E+00,-0.45588E+00,-0.45533E+00, & + -0.45477E+00,-0.45420E+00,-0.45362E+00,-0.45303E+00,-0.45244E+00, & + -0.45191E+00,-0.45130E+00,-0.45068E+00,-0.45006E+00,-0.44943E+00, & + -0.44879E+00,-0.44815E+00,-0.44751E+00,-0.44686E+00,-0.44621E+00, & + -0.44555E+00,-0.44489E+00,-0.44423E+00,-0.44356E+00,-0.44289E+00, & + -0.44221E+00,-0.44154E+00,-0.44085E+00,-0.44017E+00,-0.43948E+00, & + -0.43879E+00,-0.43810E+00,-0.43740E+00,-0.43670E+00,-0.43600E+00, & + -0.43530E+00,-0.43459E+00,-0.43388E+00,-0.43317E+00,-0.43246E+00, & + -0.43174E+00,-0.43103E+00,-0.43031E+00,-0.42959E+00,-0.42886E+00, & + -0.42814E+00,-0.42741E+00,-0.42669E+00,-0.42596E+00,-0.42523E+00, & + -0.42449E+00,-0.42376E+00,-0.42302E+00,-0.42229E+00,-0.42155E+00, & + -0.42081E+00,-0.42007E+00,-0.41933E+00,-0.41859E+00,-0.41785E+00, & + -0.41711E+00,-0.41636E+00,-0.41562E+00,-0.41487E+00,-0.41412E+00, & + -0.41337E+00,-0.41263E+00,-0.41188E+00,-0.41113E+00,-0.41038E+00, & + -0.40962E+00,-0.40887E+00,-0.40812E+00,-0.40737E+00,-0.40661E+00, & + -0.40586E+00,-0.40511E+00,-0.40435E+00,-0.40360E+00,-0.40284E+00, & + -0.40209E+00,-0.40133E+00,-0.40057E+00,-0.39982E+00,-0.39906E+00, & + -0.39830E+00,-0.39755E+00,-0.39679E+00,-0.39603E+00,-0.39527E+00/ + + DATA (BNC13M (I),I=201,300)/ & + -0.39452E+00,-0.39376E+00,-0.39300E+00,-0.39224E+00,-0.39148E+00, & + -0.39072E+00,-0.38997E+00,-0.38921E+00,-0.38845E+00,-0.38769E+00, & + -0.38693E+00,-0.38617E+00,-0.38542E+00,-0.38466E+00,-0.38390E+00, & + -0.38314E+00,-0.38238E+00,-0.38162E+00,-0.38087E+00,-0.38011E+00, & + -0.37935E+00,-0.37859E+00,-0.37784E+00,-0.37708E+00,-0.37632E+00, & + -0.37556E+00,-0.37481E+00,-0.37405E+00,-0.37329E+00,-0.37254E+00, & + -0.37178E+00,-0.37103E+00,-0.37027E+00,-0.36952E+00,-0.36876E+00, & + -0.36801E+00,-0.36725E+00,-0.36650E+00,-0.36574E+00,-0.36499E+00, & + -0.36423E+00,-0.36348E+00,-0.36273E+00,-0.36198E+00,-0.36122E+00, & + -0.36047E+00,-0.35972E+00,-0.35897E+00,-0.35822E+00,-0.35747E+00, & + -0.35672E+00,-0.35597E+00,-0.35522E+00,-0.35447E+00,-0.35372E+00, & + -0.35297E+00,-0.35222E+00,-0.35147E+00,-0.35072E+00,-0.34998E+00, & + -0.34923E+00,-0.34848E+00,-0.34774E+00,-0.34699E+00,-0.34624E+00, & + -0.34550E+00,-0.34475E+00,-0.34401E+00,-0.34327E+00,-0.34252E+00, & + -0.34178E+00,-0.34104E+00,-0.34029E+00,-0.33955E+00,-0.33881E+00, & + -0.33807E+00,-0.33733E+00,-0.33659E+00,-0.33585E+00,-0.33511E+00, & + -0.33437E+00,-0.33363E+00,-0.33289E+00,-0.33216E+00,-0.33142E+00, & + -0.33068E+00,-0.32994E+00,-0.32921E+00,-0.32847E+00,-0.32774E+00, & + -0.32700E+00,-0.32627E+00,-0.32553E+00,-0.32480E+00,-0.32407E+00, & + -0.32334E+00,-0.32260E+00,-0.32187E+00,-0.32114E+00,-0.32041E+00/ + + DATA (BNC13M (I),I=301,400)/ & + -0.31968E+00,-0.31895E+00,-0.31822E+00,-0.31749E+00,-0.31676E+00, & + -0.31603E+00,-0.31531E+00,-0.31458E+00,-0.31385E+00,-0.31313E+00, & + -0.31240E+00,-0.31167E+00,-0.31095E+00,-0.31023E+00,-0.30950E+00, & + -0.30878E+00,-0.30805E+00,-0.30733E+00,-0.30661E+00,-0.30589E+00, & + -0.30517E+00,-0.30445E+00,-0.30373E+00,-0.30301E+00,-0.30229E+00, & + -0.30157E+00,-0.30085E+00,-0.30013E+00,-0.29941E+00,-0.29870E+00, & + -0.29798E+00,-0.29726E+00,-0.29655E+00,-0.29583E+00,-0.29512E+00, & + -0.29440E+00,-0.29369E+00,-0.29298E+00,-0.29226E+00,-0.29155E+00, & + -0.29084E+00,-0.29013E+00,-0.28942E+00,-0.28871E+00,-0.28800E+00, & + -0.28729E+00,-0.28658E+00,-0.28587E+00,-0.28516E+00,-0.28445E+00, & + -0.28375E+00,-0.28304E+00,-0.28233E+00,-0.28163E+00,-0.28092E+00, & + -0.28022E+00,-0.27951E+00,-0.27881E+00,-0.27811E+00,-0.27740E+00, & + -0.27670E+00,-0.27600E+00,-0.27530E+00,-0.27459E+00,-0.27389E+00, & + -0.27319E+00,-0.27249E+00,-0.27179E+00,-0.27110E+00,-0.27040E+00, & + -0.26970E+00,-0.26900E+00,-0.26831E+00,-0.26761E+00,-0.26691E+00, & + -0.26622E+00,-0.26552E+00,-0.26483E+00,-0.26413E+00,-0.26344E+00, & + -0.26275E+00,-0.26205E+00,-0.26136E+00,-0.26067E+00,-0.25998E+00, & + -0.25929E+00,-0.25860E+00,-0.25791E+00,-0.25722E+00,-0.25653E+00, & + -0.25584E+00,-0.25515E+00,-0.25446E+00,-0.25378E+00,-0.25309E+00, & + -0.25240E+00,-0.25172E+00,-0.25103E+00,-0.25035E+00,-0.24966E+00/ + + DATA (BNC13M (I),I=401,500)/ & + -0.24898E+00,-0.24829E+00,-0.24761E+00,-0.24693E+00,-0.24625E+00, & + -0.24556E+00,-0.24488E+00,-0.24420E+00,-0.24352E+00,-0.24284E+00, & + -0.24216E+00,-0.24148E+00,-0.24080E+00,-0.24013E+00,-0.23945E+00, & + -0.23877E+00,-0.23809E+00,-0.23742E+00,-0.23674E+00,-0.23607E+00, & + -0.23539E+00,-0.23472E+00,-0.23404E+00,-0.23337E+00,-0.23270E+00, & + -0.23202E+00,-0.23135E+00,-0.23068E+00,-0.23001E+00,-0.22934E+00, & + -0.22867E+00,-0.22800E+00,-0.22733E+00,-0.22666E+00,-0.22599E+00, & + -0.22532E+00,-0.22465E+00,-0.22398E+00,-0.22332E+00,-0.22265E+00, & + -0.22198E+00,-0.22132E+00,-0.22065E+00,-0.21999E+00,-0.21932E+00, & + -0.21866E+00,-0.21799E+00,-0.21733E+00,-0.21667E+00,-0.21601E+00, & + -0.21534E+00,-0.21468E+00,-0.21402E+00,-0.21336E+00,-0.21270E+00, & + -0.21204E+00,-0.21138E+00,-0.21072E+00,-0.21006E+00,-0.20941E+00, & + -0.20875E+00,-0.20809E+00,-0.20743E+00,-0.20678E+00,-0.20612E+00, & + -0.20547E+00,-0.20481E+00,-0.20416E+00,-0.20350E+00,-0.20285E+00, & + -0.20219E+00,-0.20154E+00,-0.20089E+00,-0.20024E+00,-0.19958E+00, & + -0.19893E+00,-0.19828E+00,-0.19763E+00,-0.19698E+00,-0.19633E+00, & + -0.19568E+00,-0.19503E+00,-0.19438E+00,-0.19374E+00,-0.19309E+00, & + -0.19244E+00,-0.19179E+00,-0.19115E+00,-0.19050E+00,-0.18986E+00, & + -0.18921E+00,-0.18857E+00,-0.18792E+00,-0.18728E+00,-0.18663E+00, & + -0.18599E+00,-0.18535E+00,-0.18470E+00,-0.18406E+00,-0.18342E+00/ + + DATA (BNC13M (I),I=501,600)/ & + -0.18278E+00,-0.18214E+00,-0.18150E+00,-0.18086E+00,-0.18022E+00, & + -0.17958E+00,-0.17894E+00,-0.17830E+00,-0.17766E+00,-0.17703E+00, & + -0.17639E+00,-0.17575E+00,-0.17511E+00,-0.17448E+00,-0.17384E+00, & + -0.17321E+00,-0.17257E+00,-0.17194E+00,-0.17130E+00,-0.17067E+00, & + -0.17004E+00,-0.16940E+00,-0.16877E+00,-0.16814E+00,-0.16751E+00, & + -0.16687E+00,-0.16624E+00,-0.16561E+00,-0.16498E+00,-0.16435E+00, & + -0.16372E+00,-0.16309E+00,-0.16247E+00,-0.16184E+00,-0.16121E+00, & + -0.16058E+00,-0.15995E+00,-0.15933E+00,-0.15870E+00,-0.15807E+00, & + -0.15745E+00,-0.15682E+00,-0.15620E+00,-0.15557E+00,-0.15495E+00, & + -0.15432E+00,-0.15370E+00,-0.15308E+00,-0.15245E+00,-0.15183E+00, & + -0.15121E+00,-0.15059E+00,-0.14997E+00,-0.14935E+00,-0.14873E+00, & + -0.14811E+00,-0.14749E+00,-0.14687E+00,-0.14625E+00,-0.14563E+00, & + -0.14501E+00,-0.14439E+00,-0.14377E+00,-0.14316E+00,-0.14254E+00, & + -0.14192E+00,-0.14131E+00,-0.14069E+00,-0.14007E+00,-0.13946E+00, & + -0.13885E+00,-0.13823E+00,-0.13762E+00,-0.13700E+00,-0.13639E+00, & + -0.13578E+00,-0.13516E+00,-0.13455E+00,-0.13394E+00,-0.13333E+00, & + -0.13272E+00,-0.13211E+00,-0.13149E+00,-0.13088E+00,-0.13027E+00, & + -0.12966E+00,-0.12906E+00,-0.12845E+00,-0.12784E+00,-0.12723E+00, & + -0.12662E+00,-0.12601E+00,-0.12541E+00,-0.12480E+00,-0.12419E+00, & + -0.12359E+00,-0.12298E+00,-0.12238E+00,-0.12177E+00,-0.11951E+00/ + + DATA (BNC13M (I),I=601,700)/ & + -0.11454E+00,-0.10855E+00,-0.10259E+00,-0.96662E-01,-0.90768E-01, & + -0.84905E-01,-0.79073E-01,-0.73271E-01,-0.67500E-01,-0.61758E-01, & + -0.56045E-01,-0.50361E-01,-0.44704E-01,-0.39075E-01,-0.33474E-01, & + -0.27900E-01,-0.22352E-01,-0.16830E-01,-0.11333E-01,-0.58624E-02, & + -0.41641E-03, 0.50053E-02, 0.10403E-01, 0.15776E-01, 0.21127E-01, & + 0.26453E-01, 0.31758E-01, 0.37040E-01, 0.42299E-01, 0.47537E-01, & + 0.52753E-01, 0.57948E-01, 0.63123E-01, 0.68276E-01, 0.73409E-01, & + 0.78522E-01, 0.83615E-01, 0.88689E-01, 0.93744E-01, 0.98779E-01, & + 0.10380E+00, 0.10879E+00, 0.11377E+00, 0.11874E+00, 0.12368E+00, & + 0.12861E+00, 0.13352E+00, 0.13841E+00, 0.14328E+00, 0.14814E+00, & + 0.15298E+00, 0.15781E+00, 0.16262E+00, 0.16741E+00, 0.17219E+00, & + 0.17695E+00, 0.18170E+00, 0.18643E+00, 0.19115E+00, 0.19585E+00, & + 0.20054E+00, 0.20521E+00, 0.20987E+00, 0.21452E+00, 0.21915E+00, & + 0.22376E+00, 0.22837E+00, 0.23296E+00, 0.23753E+00, 0.24210E+00, & + 0.24665E+00, 0.25119E+00, 0.25571E+00, 0.26022E+00, 0.26472E+00, & + 0.26921E+00, 0.27369E+00, 0.27815E+00, 0.28260E+00, 0.28704E+00, & + 0.29147E+00, 0.29589E+00, 0.30029E+00, 0.30468E+00, 0.30907E+00, & + 0.31344E+00, 0.31780E+00, 0.32215E+00, 0.32649E+00, 0.33081E+00, & + 0.33513E+00, 0.33944E+00, 0.34374E+00, 0.34802E+00, 0.35230E+00, & + 0.35656E+00, 0.36082E+00, 0.36507E+00, 0.36930E+00, 0.37353E+00/ + + DATA (BNC13M(I),I=701,741)/ & + 0.37775E+00, 0.38196E+00, 0.38616E+00, 0.39035E+00, 0.39453E+00, & + 0.39870E+00, 0.40286E+00, 0.40701E+00, 0.41116E+00, 0.41529E+00, & + 0.41942E+00, 0.42354E+00, 0.42764E+00, 0.43175E+00, 0.43584E+00, & + 0.43992E+00, 0.44400E+00, 0.44807E+00, 0.45213E+00, 0.45618E+00, & + 0.46022E+00, 0.46426E+00, 0.46828E+00, 0.47230E+00, 0.47632E+00, & + 0.48032E+00, 0.48432E+00, 0.48831E+00, 0.49229E+00, 0.49626E+00, & + 0.50023E+00, 0.50419E+00, 0.50814E+00, 0.51209E+00, 0.51603E+00, & + 0.51996E+00, 0.52388E+00, 0.52780E+00, 0.53171E+00, 0.53562E+00, & + 0.53951E+00 & + / + END Module KMC323 diff --git a/wrfv2_fire/chem/module_data_isrpia_solut.F b/wrfv2_fire/chem/module_data_isrpia_solut.F new file mode 100755 index 00000000..00d1ac4e --- /dev/null +++ b/wrfv2_fire/chem/module_data_isrpia_solut.F @@ -0,0 +1,8 @@ + + MODULE SOLUT + DOUBLE PRECISION :: CHI1, CHI2, CHI3, CHI4, CHI5, CHI6, CHI7, CHI8, & + PSI1, PSI2, PSI3, PSI4, PSI5, PSI6, PSI7, PSI8, & + A1, A2, A3, A4, A5, A6, A7, A8 + + END Module SOLUT + diff --git a/wrfv2_fire/chem/module_data_mgn2mech.F b/wrfv2_fire/chem/module_data_mgn2mech.F index 0f683100..63b80fa7 100644 --- a/wrfv2_fire/chem/module_data_mgn2mech.F +++ b/wrfv2_fire/chem/module_data_mgn2mech.F @@ -56,6 +56,11 @@ MODULE module_data_mgn2mech REAL, DIMENSION (n_megan2mozcart) :: mozcart_per_megan DATA p_of_mozcart / n_megan2mozcart*non_react / + INTEGER, PARAMETER :: n_megan2mozm = 142 + INTEGER, DIMENSION (n_megan2mozm) :: p_of_megan2mozm, p_of_mozm + REAL, DIMENSION (n_megan2mozm) :: mozm_per_megan + DATA p_of_mozm / n_megan2mozm*non_react / + INTEGER, PARAMETER :: n_megan2saprcnov = 138 INTEGER, DIMENSION (n_megan2saprcnov) :: p_of_megan2saprcnov, p_of_saprcnov REAL, DIMENSION (n_megan2saprcnov) :: saprcnov_per_megan @@ -66,6 +71,16 @@ MODULE module_data_mgn2mech REAL, DIMENSION (n_megan2crimech) :: crimech_per_megan DATA p_of_crimech / n_megan2crimech*non_react / + INTEGER, PARAMETER :: n_megan2cb05 = 173 + INTEGER, DIMENSION (n_megan2cb05) :: p_of_megan2cb05, p_of_cb05 + REAL, DIMENSION (n_megan2cb05) :: cb05_per_megan + DATA p_of_cb05 / n_megan2cb05*non_react / + + INTEGER, PARAMETER :: n_megan2cb05vbs = 173 + INTEGER, DIMENSION (n_megan2cb05vbs) :: p_of_megan2cb05vbs, p_of_cb05vbs + REAL, DIMENSION (n_megan2cb05vbs) :: cb05vbs_per_megan + DATA p_of_cb05vbs / n_megan2cb05vbs*non_react / + !-------------------------------------------------------------------- ! Some naming convention in denoting MEGAN species ! _a = alpha , _b = beta , _c = cis , _al = allo , @@ -235,6 +250,163 @@ SUBROUTINE get_megan2mozcart_table END SUBROUTINE get_megan2mozcart_table + SUBROUTINE get_megan2mozm_table +!-------------------------------------------------------------------------- +! For MEGAN v2.04 species conversion to MOZART-MOSAIC species +! updated by Alma Hodzic 2013 for de-lumped mozart mechanism +! checked by J. Orlando's +!-------------------------------------------------------------------------- + +!----------------------------------------------------------------------------------------------------------- +! Index of Index of +! Molar ratio +! MEGAN species MOZCART Species +!----------------------------------------------------------------------------------------------------------- + p_of_megan2mozm( 1) = is_isoprene ; p_of_mozm( 1) = p_isopr ; mozm_per_megan( 1) = 1. + p_of_megan2mozm( 2) = is_myrcene ; p_of_mozm( 2) = p_myrc ; mozm_per_megan( 2) = 1. + p_of_megan2mozm( 3) = is_sabinene ; p_of_mozm( 3) = p_bpin ; mozm_per_megan( 3) = 1. + p_of_megan2mozm( 4) = is_limonene ; p_of_mozm( 4) = p_limon ; mozm_per_megan( 4) = 1. + p_of_megan2mozm( 5) = is_carene_3 ; p_of_mozm( 5) = p_apin ; mozm_per_megan( 5) = 1. + p_of_megan2mozm( 6) = is_ocimene_t_b ; p_of_mozm( 6) = p_myrc ; mozm_per_megan( 6) = 1. + p_of_megan2mozm( 7) = is_pinene_b ; p_of_mozm( 7) = p_bpin ; mozm_per_megan( 7) = 1. + p_of_megan2mozm( 8) = is_pinene_a ; p_of_mozm( 8) = p_apin ; mozm_per_megan( 8) = 1. + p_of_megan2mozm( 9) = is_2met_styrene ; p_of_mozm( 9) = p_limon ; mozm_per_megan( 9) = 1. + p_of_megan2mozm( 10) = is_cymene_p ; p_of_mozm( 10) = p_tol ; mozm_per_megan( 10) = 1.5 + p_of_megan2mozm( 11) = is_cymene_o ; p_of_mozm( 11) = p_tol ; mozm_per_megan( 11) = 1.5 + p_of_megan2mozm( 12) = is_phellandrene_a ; p_of_mozm( 12) = p_limon ; mozm_per_megan( 12) = 1. + p_of_megan2mozm( 13) = is_thujene_a ; p_of_mozm( 13) = p_apin ; mozm_per_megan( 13) = 1. + p_of_megan2mozm( 14) = is_terpinene_a ; p_of_mozm( 14) = p_limon ; mozm_per_megan( 14) = 1. + p_of_megan2mozm( 15) = is_terpinene_g ; p_of_mozm( 15) = p_limon ; mozm_per_megan( 15) = 1. + p_of_megan2mozm( 16) = is_terpinolene ; p_of_mozm( 16) = p_limon ; mozm_per_megan( 16) = 1. + p_of_megan2mozm( 17) = is_phellandrene_b ; p_of_mozm( 17) = p_limon ; mozm_per_megan( 17) = 1. + p_of_megan2mozm( 18) = is_camphene ; p_of_mozm( 18) = p_bpin ; mozm_per_megan( 18) = 1. + p_of_megan2mozm( 19) = is_bornene ; p_of_mozm( 19) = p_apin ; mozm_per_megan( 19) = 1. + p_of_megan2mozm( 20) = is_fenchene_a ; p_of_mozm( 20) = p_apin ; mozm_per_megan( 20) = 1. + p_of_megan2mozm( 21) = is_ocimene_al ; p_of_mozm( 21) = p_limon ; mozm_per_megan( 21) = 1. + p_of_megan2mozm( 22) = is_ocimene_c_b ; p_of_mozm( 22) = p_myrc ; mozm_per_megan( 22) = 1. + p_of_megan2mozm( 23) = is_tricyclene ; p_of_mozm( 23) = non_react ; mozm_per_megan( 23) = 1. + p_of_megan2mozm( 24) = is_estragole ; p_of_mozm( 24) = p_limon ; mozm_per_megan( 24) = 1. + p_of_megan2mozm( 25) = is_camphor ; p_of_mozm( 25) = p_bigalk ; mozm_per_megan( 25) = 2. + p_of_megan2mozm( 26) = is_fenchone ; p_of_mozm( 26) = p_bigalk ; mozm_per_megan( 26) = 2. + p_of_megan2mozm( 27) = is_piperitone ; p_of_mozm( 27) = p_apin ; mozm_per_megan( 27) = 1. + p_of_megan2mozm( 28) = is_thujone_a ; p_of_mozm( 28) = p_bigalk ; mozm_per_megan( 28) = 2. + p_of_megan2mozm( 29) = is_thujone_b ; p_of_mozm( 29) = p_bigalk ; mozm_per_megan( 29) = 2. + p_of_megan2mozm( 30) = is_cineole_1_8 ; p_of_mozm( 30) = p_bigalk ; mozm_per_megan( 30) = 2. + p_of_megan2mozm( 31) = is_borneol ; p_of_mozm( 31) = p_bigalk ; mozm_per_megan( 31) = 2. + p_of_megan2mozm( 32) = is_linalool ; p_of_mozm( 32) = p_limon ; mozm_per_megan( 32) = 1. + p_of_megan2mozm( 33) = is_terpineol_4 ; p_of_mozm( 33) = p_apin ; mozm_per_megan( 33) = 1. + p_of_megan2mozm( 34) = is_terpineol_a ; p_of_mozm( 34) = p_apin ; mozm_per_megan( 34) = 1. + p_of_megan2mozm( 35) = is_linalool_oxd_c ; p_of_mozm( 35) = p_limon ; mozm_per_megan( 35) = 1. + p_of_megan2mozm( 36) = is_linalool_oxd_t ; p_of_mozm( 36) = p_limon ; mozm_per_megan( 36) = 1. + p_of_megan2mozm( 37) = is_ionone_b ; p_of_mozm( 37) = p_limon ; mozm_per_megan( 37) = 1. + p_of_megan2mozm( 38) = is_bornyl_act ; p_of_mozm( 38) = p_bigalk ; mozm_per_megan( 38) = 2.7 + p_of_megan2mozm( 39) = is_farnescene_a ; p_of_mozm( 39) = p_limon ; mozm_per_megan( 39) = 1. + p_of_megan2mozm( 40) = is_caryophyllene_b ; p_of_mozm( 40) = p_limon ; mozm_per_megan( 40) = 1. + p_of_megan2mozm( 41) = is_acoradiene ; p_of_mozm( 41) = p_limon ; mozm_per_megan( 41) = 1. + p_of_megan2mozm( 42) = is_aromadendrene ; p_of_mozm( 42) = p_bcary ; mozm_per_megan( 42) = 1. + p_of_megan2mozm( 43) = is_bergamotene_a ; p_of_mozm( 43) = p_bcary ; mozm_per_megan( 43) = 1. + p_of_megan2mozm( 44) = is_bergamotene_b ; p_of_mozm( 44) = p_bcary ; mozm_per_megan( 44) = 1. + p_of_megan2mozm( 45) = is_bisabolene_a ; p_of_mozm( 45) = p_bcary ; mozm_per_megan( 45) = 1. + p_of_megan2mozm( 46) = is_bisabolene_b ; p_of_mozm( 46) = p_bcary ; mozm_per_megan( 46) = 1. + p_of_megan2mozm( 47) = is_bourbonene_b ; p_of_mozm( 47) = p_bcary ; mozm_per_megan( 47) = 1. + p_of_megan2mozm( 48) = is_cadinene_d ; p_of_mozm( 48) = p_bcary ; mozm_per_megan( 48) = 1. + p_of_megan2mozm( 49) = is_cadinene_g ; p_of_mozm( 49) = p_bcary ; mozm_per_megan( 49) = 1. + p_of_megan2mozm( 50) = is_cedrene_a ; p_of_mozm( 50) = p_bcary ; mozm_per_megan( 50) = 1. + p_of_megan2mozm( 51) = is_copaene_a ; p_of_mozm( 51) = p_bcary ; mozm_per_megan( 51) = 1. + p_of_megan2mozm( 52) = is_cubebene_a ; p_of_mozm( 52) = p_bcary ; mozm_per_megan( 52) = 1. + p_of_megan2mozm( 53) = is_cubebene_b ; p_of_mozm( 53) = p_bcary ; mozm_per_megan( 53) = 1. + p_of_megan2mozm( 54) = is_elemene_b ; p_of_mozm( 54) = p_bcary ; mozm_per_megan( 54) = 1. + p_of_megan2mozm( 55) = is_farnescene_b ; p_of_mozm( 55) = p_bcary ; mozm_per_megan( 55) = 1. + p_of_megan2mozm( 56) = is_germacrene_B ; p_of_mozm( 56) = p_bcary ; mozm_per_megan( 56) = 1. + p_of_megan2mozm( 57) = is_germacrene_D ; p_of_mozm( 57) = p_bcary ; mozm_per_megan( 57) = 1. + p_of_megan2mozm( 58) = is_gurjunene_b ; p_of_mozm( 58) = p_bcary ; mozm_per_megan( 58) = 1. + p_of_megan2mozm( 59) = is_humulene_a ; p_of_mozm( 59) = p_bcary ; mozm_per_megan( 59) = 1. + p_of_megan2mozm( 60) = is_humulene_g ; p_of_mozm( 60) = p_bcary ; mozm_per_megan( 60) = 1. + p_of_megan2mozm( 61) = is_isolongifolene ; p_of_mozm( 61) = p_bcary ; mozm_per_megan( 61) = 1. + p_of_megan2mozm( 62) = is_longifolene ; p_of_mozm( 62) = p_bcary ; mozm_per_megan( 62) = 1. + p_of_megan2mozm( 63) = is_longipinene ; p_of_mozm( 63) = p_bcary ; mozm_per_megan( 63) = 1. + p_of_megan2mozm( 64) = is_muurolene_a ; p_of_mozm( 64) = p_bcary ; mozm_per_megan( 64) = 1. + p_of_megan2mozm( 65) = is_muurolene_g ; p_of_mozm( 65) = p_bcary ; mozm_per_megan( 65) = 1. + p_of_megan2mozm( 66) = is_selinene_b ; p_of_mozm( 66) = p_bcary ; mozm_per_megan( 66) = 1. + p_of_megan2mozm( 67) = is_selinene_d ; p_of_mozm( 67) = p_bcary ; mozm_per_megan( 67) = 1. + p_of_megan2mozm( 68) = is_nerolidol_c ; p_of_mozm( 68) = p_bcary ; mozm_per_megan( 68) = 1. + p_of_megan2mozm( 69) = is_nerolidol_t ; p_of_mozm( 69) = p_bcary ; mozm_per_megan( 69) = 1. + p_of_megan2mozm( 70) = is_cedrol ; p_of_mozm( 70) = p_bigalk ; mozm_per_megan( 70) = 3. + p_of_megan2mozm( 71) = is_mbo_2m3e2ol ; p_of_mozm( 71) = p_mbo ; mozm_per_megan( 71) = 1. + p_of_megan2mozm( 72) = is_methanol ; p_of_mozm( 72) = p_ch3oh ; mozm_per_megan( 72) = 1. + p_of_megan2mozm( 73) = is_acetone ; p_of_mozm( 73) = p_acet ; mozm_per_megan( 73) = 1. + p_of_megan2mozm( 74) = is_methane ; p_of_mozm( 74) = non_react ; mozm_per_megan( 74) = 1. + p_of_megan2mozm( 75) = is_ammonia ; p_of_mozm( 75) = p_nh3 ; mozm_per_megan( 75) = 1. + p_of_megan2mozm( 76) = is_nitrous_oxd ; p_of_mozm( 76) = non_react ; mozm_per_megan( 76) = 1. + p_of_megan2mozm( 77) = is_nitric_oxd ; p_of_mozm( 77) = p_no ; mozm_per_megan( 77) = 1. + p_of_megan2mozm( 78) = is_acetaldehyde ; p_of_mozm( 78) = p_ald ; mozm_per_megan( 78) = 1. + p_of_megan2mozm( 79) = is_ethanol ; p_of_mozm( 79) = p_c2h5oh ; mozm_per_megan( 79) = 1. + p_of_megan2mozm( 80) = is_formic_acid ; p_of_mozm( 80) = non_react ; mozm_per_megan( 80) = 1. + p_of_megan2mozm( 81) = is_formaldehyde ; p_of_mozm( 81) = p_hcho ; mozm_per_megan( 81) = 1. + p_of_megan2mozm( 82) = is_acetic_acid ; p_of_mozm( 82) = p_ch3cooh ; mozm_per_megan( 82) = 1. + p_of_megan2mozm( 83) = is_mbo_3m2e1ol ; p_of_mozm( 83) = p_mbo ; mozm_per_megan( 83) = 1. + p_of_megan2mozm( 84) = is_benzaldehyde ; p_of_mozm( 84) = p_tol ; mozm_per_megan( 84) = 1.1 + p_of_megan2mozm( 85) = is_butanone_2 ; p_of_mozm( 85) = p_mek ; mozm_per_megan( 85) = 1. + p_of_megan2mozm( 86) = is_decanal ; p_of_mozm( 86) = p_bigalk ; mozm_per_megan( 86) = 3. + p_of_megan2mozm( 87) = is_dodecene_1 ; p_of_mozm( 87) = p_bigene ; mozm_per_megan( 87) = 2.25 + p_of_megan2mozm( 88) = is_geranyl_acetone ; p_of_mozm( 88) = p_limon ; mozm_per_megan( 88) = 1. + p_of_megan2mozm( 89) = is_heptanal ; p_of_mozm( 89) = p_bigalk ; mozm_per_megan( 89) = 2. + p_of_megan2mozm( 90) = is_heptane ; p_of_mozm( 90) = p_bigalk ; mozm_per_megan( 90) = 2. + p_of_megan2mozm( 91) = is_hexane ; p_of_mozm( 91) = p_bigalk ; mozm_per_megan( 91) = 1.5 + p_of_megan2mozm( 92) = is_met_benzoate ; p_of_mozm( 92) = p_tol ; mozm_per_megan( 92) = 1.5 + p_of_megan2mozm( 93) = is_met_heptenone ; p_of_mozm( 93) = p_bigene ; mozm_per_megan( 93) = 1.75 + p_of_megan2mozm( 94) = is_neryl_acetone ; p_of_mozm( 94) = p_bigene ; mozm_per_megan( 94) = 2.7 + p_of_megan2mozm( 95) = is_nonanal ; p_of_mozm( 95) = p_bigalk ; mozm_per_megan( 95) = 2.5 + p_of_megan2mozm( 96) = is_nonenal ; p_of_mozm( 96) = p_bigene ; mozm_per_megan( 96) = 2. + p_of_megan2mozm( 97) = is_octanal ; p_of_mozm( 97) = p_bigalk ; mozm_per_megan( 97) = 2.3 + p_of_megan2mozm( 98) = is_octanol ; p_of_mozm( 98) = p_bigalk ; mozm_per_megan( 98) = 2.3 + p_of_megan2mozm( 99) = is_octenol_1e3ol ; p_of_mozm( 99) = p_bigene ; mozm_per_megan( 99) = 1.7 + p_of_megan2mozm(100) = is_oxopentanal ; p_of_mozm(100) = p_mek ; mozm_per_megan(100) = 1.4 + p_of_megan2mozm(101) = is_pentane ; p_of_mozm(101) = p_bigalk ; mozm_per_megan(101) = 1.25 + p_of_megan2mozm(102) = is_phenyl_cco ; p_of_mozm(102) = p_tol ; mozm_per_megan(102) = 1.3 + p_of_megan2mozm(103) = is_pyruvic_acid ; p_of_mozm(103) = non_react ; mozm_per_megan(103) = 1. + p_of_megan2mozm(104) = is_terpinyl_act_a ; p_of_mozm(104) = p_apin ; mozm_per_megan(104) = 1. + p_of_megan2mozm(105) = is_tetradecene_1 ; p_of_mozm(105) = p_bigene ; mozm_per_megan(105) = 3.5 + p_of_megan2mozm(106) = is_toluene ; p_of_mozm(106) = p_tol ; mozm_per_megan(106) = 1. + p_of_megan2mozm(107) = is_carbon_monoxide ; p_of_mozm(107) = p_co ; mozm_per_megan(107) = 1. + p_of_megan2mozm(108) = is_butene ; p_of_mozm(108) = p_bigene ; mozm_per_megan(108) = .8 + p_of_megan2mozm(109) = is_ethane ; p_of_mozm(109) = p_c2h6 ; mozm_per_megan(109) = 1. + p_of_megan2mozm(110) = is_ethene ; p_of_mozm(110) = p_c2h4 ; mozm_per_megan(110) = 1. + p_of_megan2mozm(111) = is_hydrogen_cyanide ; p_of_mozm(111) = non_react ; mozm_per_megan(111) = 1. + p_of_megan2mozm(112) = is_propane ; p_of_mozm(112) = p_c3h8 ; mozm_per_megan(112) = 1. + p_of_megan2mozm(113) = is_propene ; p_of_mozm(113) = p_c3h6 ; mozm_per_megan(113) = 1. + p_of_megan2mozm(114) = is_carbon_2s ; p_of_mozm(114) = non_react ; mozm_per_megan(114) = 1. + p_of_megan2mozm(115) = is_carbonyl_s ; p_of_mozm(115) = non_react ; mozm_per_megan(115) = 1. + p_of_megan2mozm(116) = is_diallyl_2s ; p_of_mozm(116) = p_bigene ; mozm_per_megan(116) = .66 + p_of_megan2mozm(117) = is_diallyl_2s ; p_of_mozm(117) = p_so2 ; mozm_per_megan(117) = 1.53 + p_of_megan2mozm(118) = is_2met_2s ; p_of_mozm(118) = p_c2h6 ; mozm_per_megan(118) = 1. + p_of_megan2mozm(119) = is_2met_2s ; p_of_mozm(119) = p_so2 ; mozm_per_megan(119) = 1. + p_of_megan2mozm(120) = is_met_chloride ; p_of_mozm(120) = non_react ; mozm_per_megan(120) = 1. + p_of_megan2mozm(121) = is_met_bromide ; p_of_mozm(121) = non_react ; mozm_per_megan(121) = 1. + p_of_megan2mozm(122) = is_met_iodide ; p_of_mozm(122) = non_react ; mozm_per_megan(122) = 1. + p_of_megan2mozm(123) = is_hydrogen_s ; p_of_mozm(123) = p_so2 ; mozm_per_megan(123) = .5 + p_of_megan2mozm(124) = is_met_mercaptan ; p_of_mozm(124) = p_so2 ; mozm_per_megan(124) = .75 + p_of_megan2mozm(125) = is_met_propenyl_2s ; p_of_mozm(125) = p_c3h6 ; mozm_per_megan(125) = 2.8 + p_of_megan2mozm(126) = is_met_propenyl_2s ; p_of_mozm(126) = p_so2 ; mozm_per_megan(126) = 1.8 + p_of_megan2mozm(127) = is_pppp_2s ; p_of_mozm(127) = p_c3h6 ; mozm_per_megan(127) = 3.5 + p_of_megan2mozm(128) = is_pppp_2s ; p_of_mozm(128) = p_so2 ; mozm_per_megan(128) = 2.3 + p_of_megan2mozm(129) = is_2met_nonatriene ; p_of_mozm(129) = p_limon ; mozm_per_megan(129) = 1. + p_of_megan2mozm(130) = is_met_salicylate ; p_of_mozm(130) = p_tol ; mozm_per_megan(130) = 1.6 + p_of_megan2mozm(131) = is_indole ; p_of_mozm(131) = non_react ; mozm_per_megan(131) = 1. + p_of_megan2mozm(132) = is_jasmone ; p_of_mozm(132) = p_limon ; mozm_per_megan(132) = 1. + p_of_megan2mozm(133) = is_met_jasmonate ; p_of_mozm(133) = p_limon ; mozm_per_megan(133) = 1. + p_of_megan2mozm(134) = is_3met_3dctt ; p_of_mozm(134) = p_bigene ; mozm_per_megan(134) = 3. + p_of_megan2mozm(135) = is_hexanal ; p_of_mozm(135) = p_bigalk ; mozm_per_megan(135) = 1.8 + p_of_megan2mozm(136) = is_hexanol_1 ; p_of_mozm(136) = p_bigalk ; mozm_per_megan(136) = 1.8 + p_of_megan2mozm(137) = is_hexenal_c3 ; p_of_mozm(137) = p_bigene ; mozm_per_megan(137) = 1.4 + p_of_megan2mozm(138) = is_hexenal_t2 ; p_of_mozm(138) = p_bigene ; mozm_per_megan(138) = 1.4 + p_of_megan2mozm(139) = is_hexenol_c3 ; p_of_mozm(139) = p_bigene ; mozm_per_megan(139) = 1.4 + p_of_megan2mozm(140) = is_hexenyl_act_c3 ; p_of_mozm(140) = p_bigene ; mozm_per_megan(140) = 2. + p_of_megan2mozm(141) = is_mbo_3m3e1ol ; p_of_mozm(141) = p_mbo ; mozm_per_megan(141) = 1. + p_of_megan2mozm(142) = is_2met_s ; p_of_mozm(142) = p_dms ; mozm_per_megan(142) = 1. + + END SUBROUTINE get_megan2mozm_table + SUBROUTINE get_megan2cbmz_table !-------------------------------------------------------------------- ! For MEGAN v2.04 species conversion to CBMZ species @@ -1110,6 +1282,365 @@ SUBROUTINE get_megan2saprcnov_table p_of_megan2saprcnov(138) = is_hexenyl_act_c3 ; p_of_saprcnov(138) = p_ole2 ; saprcnov_per_megan(138) = 1.000 END SUBROUTINE get_megan2saprcnov_table + + SUBROUTINE get_megan2cb05_table + ! MEGAN species CB05 Species Molar ratio + ! + p_of_megan2cb05( 1) = is_isoprene ; p_of_cb05( 1) = p_isop ; cb05_per_megan( 1) = 1. + p_of_megan2cb05( 2) = is_myrcene ; p_of_cb05( 2) = p_oci ; cb05_per_megan( 2) = 1. + p_of_megan2cb05( 3) = is_sabinene ; p_of_cb05( 3) = p_apin ; cb05_per_megan( 3) = 1. + p_of_megan2cb05( 4) = is_limonene ; p_of_cb05( 4) = p_lim ; cb05_per_megan( 4) = 1. + p_of_megan2cb05( 5) = is_carene_3 ; p_of_cb05( 5) = p_bpin ; cb05_per_megan( 5) = 1. + p_of_megan2cb05( 6) = is_ocimene_t_b ; p_of_cb05( 6) = p_oci ; cb05_per_megan( 6) = 1. + p_of_megan2cb05( 7) = is_pinene_b ; p_of_cb05( 7) = p_bpin ; cb05_per_megan( 7) = 1. + p_of_megan2cb05( 8) = is_pinene_a ; p_of_cb05( 8) = p_apin ; cb05_per_megan( 8) = 1. + p_of_megan2cb05( 9) = is_2met_styrene ; p_of_cb05( 9) = p_oci ; cb05_per_megan( 9) = 1. + p_of_megan2cb05( 10) = is_cymene_p ; p_of_cb05( 10) = p_oci ; cb05_per_megan( 10) = 1. + p_of_megan2cb05( 11) = is_cymene_o ; p_of_cb05( 11) = p_oci ; cb05_per_megan( 11) = 1. + p_of_megan2cb05( 12) = is_phellandrene_a ; p_of_cb05( 12) = p_oci ; cb05_per_megan( 12) = 1. + p_of_megan2cb05( 13) = is_thujene_a ; p_of_cb05( 13) = p_oci ; cb05_per_megan( 13) = 1. + p_of_megan2cb05( 14) = is_terpinene_a ; p_of_cb05( 14) = p_ter ; cb05_per_megan( 14) = 1. + p_of_megan2cb05( 15) = is_terpinene_g ; p_of_cb05( 15) = p_ter ; cb05_per_megan( 15) = 1. + p_of_megan2cb05( 16) = is_terpinolene ; p_of_cb05( 16) = p_oci ; cb05_per_megan( 16) = 1. + p_of_megan2cb05( 17) = is_phellandrene_b ; p_of_cb05( 17) = p_oci ; cb05_per_megan( 17) = 1. + p_of_megan2cb05( 18) = is_camphene ; p_of_cb05( 18) = p_oci ; cb05_per_megan( 18) = 1. + p_of_megan2cb05( 19) = is_bornene ; p_of_cb05( 19) = p_oci ; cb05_per_megan( 19) = 1. + p_of_megan2cb05( 20) = is_fenchene_a ; p_of_cb05( 20) = p_oci ; cb05_per_megan( 20) = 1. + p_of_megan2cb05( 21) = is_ocimene_al ; p_of_cb05( 21) = p_oci ; cb05_per_megan( 21) = 1. + p_of_megan2cb05( 22) = is_ocimene_c_b ; p_of_cb05( 22) = p_oci ; cb05_per_megan( 22) = 1. + p_of_megan2cb05( 23) = is_tricyclene ; p_of_cb05( 23) = p_oci ; cb05_per_megan( 23) = 1. + p_of_megan2cb05( 24) = is_estragole ; p_of_cb05( 24) = p_oci ; cb05_per_megan( 24) = 1. + p_of_megan2cb05( 25) = is_camphor ; p_of_cb05( 25) = p_oci ; cb05_per_megan( 25) = 1. + p_of_megan2cb05( 26) = is_fenchone ; p_of_cb05( 26) = p_oci ; cb05_per_megan( 26) = 1. + p_of_megan2cb05( 27) = is_piperitone ; p_of_cb05( 27) = p_oci ; cb05_per_megan( 27) = 1. + p_of_megan2cb05( 28) = is_thujone_a ; p_of_cb05( 28) = p_oci ; cb05_per_megan( 28) = 1. + p_of_megan2cb05( 29) = is_thujone_b ; p_of_cb05( 29) = p_oci ; cb05_per_megan( 29) = 1. + p_of_megan2cb05( 30) = is_cineole_1_8 ; p_of_cb05( 30) = p_oci ; cb05_per_megan( 30) = 1. + p_of_megan2cb05( 31) = is_borneol ; p_of_cb05( 31) = p_oci ; cb05_per_megan( 31) = 1. + p_of_megan2cb05( 32) = is_linalool ; p_of_cb05( 32) = p_oci ; cb05_per_megan( 32) = 1. + p_of_megan2cb05( 33) = is_terpineol_4 ; p_of_cb05( 33) = p_oci ; cb05_per_megan( 33) = 1. + p_of_megan2cb05( 34) = is_terpineol_a ; p_of_cb05( 34) = p_oci ; cb05_per_megan( 34) = 1. + p_of_megan2cb05( 35) = is_linalool_oxd_c ; p_of_cb05( 35) = p_oci ; cb05_per_megan( 35) = 1. + p_of_megan2cb05( 36) = is_linalool_oxd_t ; p_of_cb05( 36) = p_oci ; cb05_per_megan( 36) = 1. + p_of_megan2cb05( 37) = is_ionone_b ; p_of_cb05( 37) = p_hum ; cb05_per_megan( 37) = 1. + p_of_megan2cb05( 38) = is_bornyl_act ; p_of_cb05( 38) = p_oci ; cb05_per_megan( 38) = 1. + p_of_megan2cb05( 39) = is_farnescene_a ; p_of_cb05( 39) = p_hum ; cb05_per_megan( 39) = 1. + p_of_megan2cb05( 40) = is_caryophyllene_b ; p_of_cb05( 40) = p_hum ; cb05_per_megan( 40) = 1. + p_of_megan2cb05( 41) = is_acoradiene ; p_of_cb05( 41) = p_hum ; cb05_per_megan( 41) = 1. + p_of_megan2cb05( 42) = is_aromadendrene ; p_of_cb05( 42) = p_hum ; cb05_per_megan( 42) = 1. + p_of_megan2cb05( 43) = is_bergamotene_a ; p_of_cb05( 43) = p_hum ; cb05_per_megan( 43) = 1. + p_of_megan2cb05( 44) = is_bergamotene_b ; p_of_cb05( 44) = p_hum ; cb05_per_megan( 44) = 1. + p_of_megan2cb05( 45) = is_bisabolene_a ; p_of_cb05( 45) = p_hum ; cb05_per_megan( 45) = 1. + p_of_megan2cb05( 46) = is_bisabolene_b ; p_of_cb05( 46) = p_hum ; cb05_per_megan( 46) = 1. + p_of_megan2cb05( 47) = is_bourbonene_b ; p_of_cb05( 47) = p_hum ; cb05_per_megan( 47) = 1. + p_of_megan2cb05( 48) = is_cadinene_d ; p_of_cb05( 48) = p_hum ; cb05_per_megan( 48) = 1. + p_of_megan2cb05( 49) = is_cadinene_g ; p_of_cb05( 49) = p_hum ; cb05_per_megan( 49) = 1. + p_of_megan2cb05( 50) = is_cedrene_a ; p_of_cb05( 50) = p_hum ; cb05_per_megan( 50) = 1. + p_of_megan2cb05( 51) = is_copaene_a ; p_of_cb05( 51) = p_hum ; cb05_per_megan( 51) = 1. + p_of_megan2cb05( 52) = is_cubebene_a ; p_of_cb05( 52) = p_hum ; cb05_per_megan( 52) = 1. + p_of_megan2cb05( 53) = is_cubebene_b ; p_of_cb05( 53) = p_hum ; cb05_per_megan( 53) = 1. + p_of_megan2cb05( 54) = is_elemene_b ; p_of_cb05( 54) = p_hum ; cb05_per_megan( 54) = 1. + p_of_megan2cb05( 55) = is_farnescene_b ; p_of_cb05( 55) = p_hum ; cb05_per_megan( 55) = 1. + p_of_megan2cb05( 56) = is_germacrene_B ; p_of_cb05( 56) = p_hum ; cb05_per_megan( 56) = 1. + p_of_megan2cb05( 57) = is_germacrene_D ; p_of_cb05( 57) = p_hum ; cb05_per_megan( 57) = 1. + p_of_megan2cb05( 58) = is_gurjunene_b ; p_of_cb05( 58) = p_hum ; cb05_per_megan( 58) = 1. + p_of_megan2cb05( 59) = is_humulene_a ; p_of_cb05( 59) = p_hum ; cb05_per_megan( 59) = 1. + p_of_megan2cb05( 60) = is_humulene_g ; p_of_cb05( 60) = p_hum ; cb05_per_megan( 60) = 1. + p_of_megan2cb05( 61) = is_isolongifolene ; p_of_cb05( 61) = p_hum ; cb05_per_megan( 61) = 1. + p_of_megan2cb05( 62) = is_longifolene ; p_of_cb05( 62) = p_hum ; cb05_per_megan( 62) = 1. + p_of_megan2cb05( 63) = is_longipinene ; p_of_cb05( 63) = p_hum ; cb05_per_megan( 63) = 1. + p_of_megan2cb05( 64) = is_muurolene_a ; p_of_cb05( 64) = p_hum ; cb05_per_megan( 64) = 1. + p_of_megan2cb05( 65) = is_muurolene_g ; p_of_cb05( 65) = p_hum ; cb05_per_megan( 65) = 1. + p_of_megan2cb05( 66) = is_selinene_b ; p_of_cb05( 66) = p_hum ; cb05_per_megan( 66) = 1. + p_of_megan2cb05( 67) = is_selinene_d ; p_of_cb05( 67) = p_hum ; cb05_per_megan( 67) = 1. + p_of_megan2cb05( 68) = is_nerolidol_c ; p_of_cb05( 68) = p_hum ; cb05_per_megan( 68) = 1. + p_of_megan2cb05( 69) = is_nerolidol_t ; p_of_cb05( 69) = p_hum ; cb05_per_megan( 69) = 1. + p_of_megan2cb05( 70) = is_cedrol ; p_of_cb05( 70) = p_hum ; cb05_per_megan( 70) = 1. + p_of_megan2cb05( 71) = is_mbo_2m3e2ol ; p_of_cb05( 71) = p_ole ; cb05_per_megan( 71) = 1. + p_of_megan2cb05( 72) = is_mbo_2m3e2ol ; p_of_cb05( 72) = p_par ; cb05_per_megan( 72) = 3. + p_of_megan2cb05( 73) = is_methanol ; p_of_cb05( 73) = p_meoh ; cb05_per_megan( 73) = 1. + p_of_megan2cb05( 74) = is_acetone ; p_of_cb05( 74) = p_ispd ; cb05_per_megan( 74) = 1. + p_of_megan2cb05( 75) = is_methane ; p_of_cb05( 75) = p_ch4 ; cb05_per_megan( 75) = 1. + p_of_megan2cb05( 76) = is_ammonia ; p_of_cb05( 76) = p_nh3 ; cb05_per_megan( 76) = 1. + p_of_megan2cb05( 77) = is_nitrous_oxd ; p_of_cb05( 77) = non_react ; cb05_per_megan( 77) = 1. + p_of_megan2cb05( 78) = is_nitric_oxd ; p_of_cb05( 78) = p_no ; cb05_per_megan( 78) = 1. + p_of_megan2cb05( 79) = is_acetaldehyde ; p_of_cb05( 79) = p_ald2 ; cb05_per_megan( 79) = 1. + p_of_megan2cb05( 80) = is_ethanol ; p_of_cb05( 80) = p_etoh ; cb05_per_megan( 80) = 1. + p_of_megan2cb05( 81) = is_formic_acid ; p_of_cb05( 81) = p_facd ; cb05_per_megan( 81) = 1. + p_of_megan2cb05( 82) = is_formaldehyde ; p_of_cb05( 82) = p_form ; cb05_per_megan( 82) = 1. + p_of_megan2cb05( 83) = is_acetic_acid ; p_of_cb05( 83) = p_aacd ; cb05_per_megan( 83) = 1. + p_of_megan2cb05( 84) = is_mbo_3m2e1ol ; p_of_cb05( 84) = p_ald2 ; cb05_per_megan( 84) = 1. + p_of_megan2cb05( 85) = is_mbo_3m2e1ol ; p_of_cb05( 85) = p_par ; cb05_per_megan( 85) = 3. + p_of_megan2cb05( 86) = is_mbo_3m3e1ol ; p_of_cb05( 86) = p_form ; cb05_per_megan( 86) = 1. + p_of_megan2cb05( 87) = is_mbo_3m3e1ol ; p_of_cb05( 87) = p_par ; cb05_per_megan( 87) = 4. + p_of_megan2cb05( 88) = is_benzaldehyde ; p_of_cb05( 88) = p_tol ; cb05_per_megan( 88) = 1. + p_of_megan2cb05( 89) = is_butanone_2 ; p_of_cb05( 89) = p_ispd ; cb05_per_megan( 89) = 1. + p_of_megan2cb05( 90) = is_butanone_2 ; p_of_cb05( 90) = p_par ; cb05_per_megan( 90) = 2. + p_of_megan2cb05( 91) = is_decanal ; p_of_cb05( 91) = p_aldx ; cb05_per_megan( 91) = 1. + p_of_megan2cb05( 92) = is_decanal ; p_of_cb05( 92) = p_par ; cb05_per_megan( 92) = 8. + p_of_megan2cb05( 93) = is_dodecene_1 ; p_of_cb05( 93) = p_ole ; cb05_per_megan( 93) = 1. + p_of_megan2cb05( 94) = is_dodecene_1 ; p_of_cb05( 94) = p_par ; cb05_per_megan( 94) = 10. + p_of_megan2cb05( 95) = is_geranyl_acetone ; p_of_cb05( 95) = p_hum ; cb05_per_megan( 95) = 1. + p_of_megan2cb05( 96) = is_heptanal ; p_of_cb05( 96) = p_aldx ; cb05_per_megan( 96) = 1. + p_of_megan2cb05( 97) = is_heptanal ; p_of_cb05( 97) = p_par ; cb05_per_megan( 97) = 5. + p_of_megan2cb05( 98) = is_heptane ; p_of_cb05( 98) = p_par ; cb05_per_megan( 98) = 7. + p_of_megan2cb05( 99) = is_hexane ; p_of_cb05( 99) = p_par ; cb05_per_megan( 99) = 6. + p_of_megan2cb05(100) = is_met_benzoate ; p_of_cb05(100) = p_tol ; cb05_per_megan(100) = 1. + p_of_megan2cb05(101) = is_met_heptenone ; p_of_cb05(101) = p_ispd ; cb05_per_megan(101) = 1. + p_of_megan2cb05(102) = is_met_heptenone ; p_of_cb05(102) = p_par ; cb05_per_megan(102) = 3. + p_of_megan2cb05(103) = is_met_heptenone ; p_of_cb05(103) = p_ole ; cb05_per_megan(103) = 1. + p_of_megan2cb05(104) = is_neryl_acetone ; p_of_cb05(104) = p_ispd ; cb05_per_megan(104) = 1. + p_of_megan2cb05(105) = is_neryl_acetone ; p_of_cb05(105) = p_par ; cb05_per_megan(105) = 8. + p_of_megan2cb05(106) = is_neryl_acetone ; p_of_cb05(106) = p_iole ; cb05_per_megan(106) = 2. + p_of_megan2cb05(107) = is_nonanal ; p_of_cb05(107) = p_aldx ; cb05_per_megan(107) = 1. + p_of_megan2cb05(108) = is_nonanal ; p_of_cb05(108) = p_par ; cb05_per_megan(108) = 7. + p_of_megan2cb05(109) = is_nonenal ; p_of_cb05(109) = p_aldx ; cb05_per_megan(109) = 1. + p_of_megan2cb05(110) = is_nonenal ; p_of_cb05(110) = p_par ; cb05_per_megan(110) = 6. + p_of_megan2cb05(111) = is_nonenal ; p_of_cb05(111) = p_iole ; cb05_per_megan(111) = 1. + p_of_megan2cb05(112) = is_octanal ; p_of_cb05(112) = p_aldx ; cb05_per_megan(112) = 1. + p_of_megan2cb05(113) = is_octanal ; p_of_cb05(113) = p_par ; cb05_per_megan(113) = 6. + p_of_megan2cb05(114) = is_octanol ; p_of_cb05(114) = p_par ; cb05_per_megan(114) = 8. + p_of_megan2cb05(115) = is_octenol_1e3ol ; p_of_cb05(115) = p_par ; cb05_per_megan(115) = 6. + p_of_megan2cb05(116) = is_octenol_1e3ol ; p_of_cb05(116) = p_ole ; cb05_per_megan(116) = 1. + p_of_megan2cb05(117) = is_oxopentanal ; p_of_cb05(117) = p_aldx ; cb05_per_megan(117) = 1. + p_of_megan2cb05(118) = is_oxopentanal ; p_of_cb05(118) = p_par ; cb05_per_megan(118) = 3. + p_of_megan2cb05(119) = is_pentane ; p_of_cb05(119) = p_par ; cb05_per_megan(119) = 5. + p_of_megan2cb05(120) = is_phenyl_cco ; p_of_cb05(120) = p_aldx ; cb05_per_megan(120) = 1 + p_of_megan2cb05(121) = is_phenyl_cco ; p_of_cb05(121) = p_tol ; cb05_per_megan(121) = 1. + p_of_megan2cb05(122) = is_pyruvic_acid ; p_of_cb05(122) = p_aacd ; cb05_per_megan(122) = 1. + p_of_megan2cb05(123) = is_pyruvic_acid ; p_of_cb05(123) = p_ispd ; cb05_per_megan(123) = 1. + p_of_megan2cb05(124) = is_terpinyl_act_a ; p_of_cb05(124) = p_oci ; cb05_per_megan(124) = 1. + p_of_megan2cb05(125) = is_tetradecene_1 ; p_of_cb05(125) = p_par ; cb05_per_megan(125) = 12. + p_of_megan2cb05(126) = is_tetradecene_1 ; p_of_cb05(126) = p_ole ; cb05_per_megan(126) = 1. + p_of_megan2cb05(127) = is_toluene ; p_of_cb05(127) = p_tol ; cb05_per_megan(127) = 1. + p_of_megan2cb05(128) = is_carbon_monoxide ; p_of_cb05(128) = p_co ; cb05_per_megan(128) = 1. + p_of_megan2cb05(129) = is_butene ; p_of_cb05(129) = p_ole ; cb05_per_megan(129) = 1. + p_of_megan2cb05(130) = is_butene ; p_of_cb05(130) = p_par ; cb05_per_megan(130) = 2. + p_of_megan2cb05(131) = is_ethane ; p_of_cb05(131) = p_etha ; cb05_per_megan(131) = 1. + p_of_megan2cb05(132) = is_ethene ; p_of_cb05(132) = p_eth ; cb05_per_megan(132) = 1. + p_of_megan2cb05(133) = is_hydrogen_cyanide ; p_of_cb05(133) = non_react ; cb05_per_megan(133) = 1. + p_of_megan2cb05(134) = is_propane ; p_of_cb05(134) = p_par ; cb05_per_megan(134) = 3. + p_of_megan2cb05(135) = is_propene ; p_of_cb05(135) = p_ole ; cb05_per_megan(135) = 1. + p_of_megan2cb05(136) = is_propene ; p_of_cb05(136) = p_par ; cb05_per_megan(136) = 1. + p_of_megan2cb05(137) = is_carbon_2s ; p_of_cb05(137) = non_react ; cb05_per_megan(137) = 1. + p_of_megan2cb05(138) = is_carbonyl_s ; p_of_cb05(138) = non_react ; cb05_per_megan(138) = 1. + p_of_megan2cb05(139) = is_diallyl_2s ; p_of_cb05(139) = non_react ; cb05_per_megan(139) = 1. + p_of_megan2cb05(140) = is_diallyl_2s ; p_of_cb05(140) = p_par ; cb05_per_megan(140) = 2. + p_of_megan2cb05(141) = is_diallyl_2s ; p_of_cb05(141) = p_ole ; cb05_per_megan(141) = 2. + p_of_megan2cb05(142) = is_2met_2s ; p_of_cb05(142) = non_react ; cb05_per_megan(142) = 1. + p_of_megan2cb05(143) = is_2met_s ; p_of_cb05(143) = non_react ; cb05_per_megan(143) = 1. + p_of_megan2cb05(144) = is_met_chloride ; p_of_cb05(144) = non_react ; cb05_per_megan(144) = 1. + p_of_megan2cb05(145) = is_met_bromide ; p_of_cb05(145) = non_react ; cb05_per_megan(145) = 1. + p_of_megan2cb05(146) = is_met_iodide ; p_of_cb05(146) = non_react ; cb05_per_megan(146) = 1. + p_of_megan2cb05(147) = is_hydrogen_s ; p_of_cb05(147) = non_react ; cb05_per_megan(147) = 1. + p_of_megan2cb05(148) = is_met_mercaptan ; p_of_cb05(148) = p_par ; cb05_per_megan(148) = 1. + p_of_megan2cb05(149) = is_met_propenyl_2s ; p_of_cb05(149) = non_react ; cb05_per_megan(149) = 1. + p_of_megan2cb05(150) = is_met_propenyl_2s ; p_of_cb05(150) = p_iole ; cb05_per_megan(150) = 1. + p_of_megan2cb05(151) = is_pppp_2s ; p_of_cb05(151) = non_react ; cb05_per_megan(151) = 1. + p_of_megan2cb05(152) = is_pppp_2s ; p_of_cb05(152) = p_par ; cb05_per_megan(152) = 2. + p_of_megan2cb05(153) = is_pppp_2s ; p_of_cb05(153) = p_iole ; cb05_per_megan(153) = 1. + p_of_megan2cb05(154) = is_2met_nonatriene ; p_of_cb05(154) = p_oci ; cb05_per_megan(154) = 1. + p_of_megan2cb05(155) = is_met_salicylate ; p_of_cb05(155) = p_tol ; cb05_per_megan(155) = 1. + p_of_megan2cb05(156) = is_indole ; p_of_cb05(156) = p_tol ; cb05_per_megan(156) = 1. + p_of_megan2cb05(157) = is_jasmone ; p_of_cb05(157) = p_oci ; cb05_per_megan(157) = 1. + p_of_megan2cb05(158) = is_met_jasmonate ; p_of_cb05(158) = p_hum ; cb05_per_megan(158) = 1. + p_of_megan2cb05(159) = is_3met_3dctt ; p_of_cb05(159) = p_hum ; cb05_per_megan(159) = 1. + p_of_megan2cb05(160) = is_hexanal ; p_of_cb05(160) = p_aldx ; cb05_per_megan(160) = 1. + p_of_megan2cb05(161) = is_hexanal ; p_of_cb05(161) = p_par ; cb05_per_megan(161) = 4. + p_of_megan2cb05(162) = is_hexanol_1 ; p_of_cb05(162) = p_par ; cb05_per_megan(162) = 6. + p_of_megan2cb05(163) = is_hexenal_c3 ; p_of_cb05(163) = p_aldx ; cb05_per_megan(163) = 1. + p_of_megan2cb05(164) = is_hexenal_c3 ; p_of_cb05(164) = p_par ; cb05_per_megan(164) = 3. + p_of_megan2cb05(165) = is_hexenal_c3 ; p_of_cb05(165) = p_iole ; cb05_per_megan(165) = 1 + p_of_megan2cb05(166) = is_hexenal_t2 ; p_of_cb05(166) = p_aldx ; cb05_per_megan(166) = 1. + p_of_megan2cb05(167) = is_hexenal_t2 ; p_of_cb05(167) = p_par ; cb05_per_megan(167) = 6. + p_of_megan2cb05(168) = is_hexenal_t2 ; p_of_cb05(168) = p_iole ; cb05_per_megan(168) = 1. + p_of_megan2cb05(169) = is_hexenol_c3 ; p_of_cb05(169) = p_par ; cb05_per_megan(169) = 5. + p_of_megan2cb05(170) = is_hexenol_c3 ; p_of_cb05(170) = p_iole ; cb05_per_megan(170) = 1. + p_of_megan2cb05(171) = is_hexenyl_act_c3 ; p_of_cb05(171) = p_ispd ; cb05_per_megan(171) = 1. + p_of_megan2cb05(172) = is_hexenyl_act_c3 ; p_of_cb05(172) = p_par ; cb05_per_megan(172) = 5. + p_of_megan2cb05(173) = is_hexenyl_act_c3 ; p_of_cb05(173) = p_iole ; cb05_per_megan(173) = 1. + + END SUBROUTINE get_megan2cb05_table + + SUBROUTINE get_megan2cb05vbs_table + ! MEGAN species CB05 Species Molar ratio + ! + p_of_megan2cb05vbs( 1) = is_isoprene ; p_of_cb05vbs( 1) = p_isop ; cb05vbs_per_megan( 1) = 1. + p_of_megan2cb05vbs( 2) = is_myrcene ; p_of_cb05vbs( 2) = p_oci ; cb05vbs_per_megan( 2) = 1. + p_of_megan2cb05vbs( 3) = is_sabinene ; p_of_cb05vbs( 3) = p_apin ; cb05vbs_per_megan( 3) = 1. + p_of_megan2cb05vbs( 4) = is_limonene ; p_of_cb05vbs( 4) = p_lim ; cb05vbs_per_megan( 4) = 1. + p_of_megan2cb05vbs( 5) = is_carene_3 ; p_of_cb05vbs( 5) = p_bpin ; cb05vbs_per_megan( 5) = 1. + p_of_megan2cb05vbs( 6) = is_ocimene_t_b ; p_of_cb05vbs( 6) = p_oci ; cb05vbs_per_megan( 6) = 1. + p_of_megan2cb05vbs( 7) = is_pinene_b ; p_of_cb05vbs( 7) = p_bpin ; cb05vbs_per_megan( 7) = 1. + p_of_megan2cb05vbs( 8) = is_pinene_a ; p_of_cb05vbs( 8) = p_apin ; cb05vbs_per_megan( 8) = 1. + p_of_megan2cb05vbs( 9) = is_2met_styrene ; p_of_cb05vbs( 9) = p_oci ; cb05vbs_per_megan( 9) = 1. + p_of_megan2cb05vbs( 10) = is_cymene_p ; p_of_cb05vbs( 10) = p_oci ; cb05vbs_per_megan( 10) = 1. + p_of_megan2cb05vbs( 11) = is_cymene_o ; p_of_cb05vbs( 11) = p_oci ; cb05vbs_per_megan( 11) = 1. + p_of_megan2cb05vbs( 12) = is_phellandrene_a ; p_of_cb05vbs( 12) = p_oci ; cb05vbs_per_megan( 12) = 1. + p_of_megan2cb05vbs( 13) = is_thujene_a ; p_of_cb05vbs( 13) = p_oci ; cb05vbs_per_megan( 13) = 1. + p_of_megan2cb05vbs( 14) = is_terpinene_a ; p_of_cb05vbs( 14) = p_ter ; cb05vbs_per_megan( 14) = 1. + p_of_megan2cb05vbs( 15) = is_terpinene_g ; p_of_cb05vbs( 15) = p_ter ; cb05vbs_per_megan( 15) = 1. + p_of_megan2cb05vbs( 16) = is_terpinolene ; p_of_cb05vbs( 16) = p_oci ; cb05vbs_per_megan( 16) = 1. + p_of_megan2cb05vbs( 17) = is_phellandrene_b ; p_of_cb05vbs( 17) = p_oci ; cb05vbs_per_megan( 17) = 1. + p_of_megan2cb05vbs( 18) = is_camphene ; p_of_cb05vbs( 18) = p_oci ; cb05vbs_per_megan( 18) = 1. + p_of_megan2cb05vbs( 19) = is_bornene ; p_of_cb05vbs( 19) = p_oci ; cb05vbs_per_megan( 19) = 1. + p_of_megan2cb05vbs( 20) = is_fenchene_a ; p_of_cb05vbs( 20) = p_oci ; cb05vbs_per_megan( 20) = 1. + p_of_megan2cb05vbs( 21) = is_ocimene_al ; p_of_cb05vbs( 21) = p_oci ; cb05vbs_per_megan( 21) = 1. + p_of_megan2cb05vbs( 22) = is_ocimene_c_b ; p_of_cb05vbs( 22) = p_oci ; cb05vbs_per_megan( 22) = 1. + p_of_megan2cb05vbs( 23) = is_tricyclene ; p_of_cb05vbs( 23) = p_oci ; cb05vbs_per_megan( 23) = 1. + p_of_megan2cb05vbs( 24) = is_estragole ; p_of_cb05vbs( 24) = p_oci ; cb05vbs_per_megan( 24) = 1. + p_of_megan2cb05vbs( 25) = is_camphor ; p_of_cb05vbs( 25) = p_oci ; cb05vbs_per_megan( 25) = 1. + p_of_megan2cb05vbs( 26) = is_fenchone ; p_of_cb05vbs( 26) = p_oci ; cb05vbs_per_megan( 26) = 1. + p_of_megan2cb05vbs( 27) = is_piperitone ; p_of_cb05vbs( 27) = p_oci ; cb05vbs_per_megan( 27) = 1. + p_of_megan2cb05vbs( 28) = is_thujone_a ; p_of_cb05vbs( 28) = p_oci ; cb05vbs_per_megan( 28) = 1. + p_of_megan2cb05vbs( 29) = is_thujone_b ; p_of_cb05vbs( 29) = p_oci ; cb05vbs_per_megan( 29) = 1. + p_of_megan2cb05vbs( 30) = is_cineole_1_8 ; p_of_cb05vbs( 30) = p_oci ; cb05vbs_per_megan( 30) = 1. + p_of_megan2cb05vbs( 31) = is_borneol ; p_of_cb05vbs( 31) = p_oci ; cb05vbs_per_megan( 31) = 1. + p_of_megan2cb05vbs( 32) = is_linalool ; p_of_cb05vbs( 32) = p_oci ; cb05vbs_per_megan( 32) = 1. + p_of_megan2cb05vbs( 33) = is_terpineol_4 ; p_of_cb05vbs( 33) = p_oci ; cb05vbs_per_megan( 33) = 1. + p_of_megan2cb05vbs( 34) = is_terpineol_a ; p_of_cb05vbs( 34) = p_oci ; cb05vbs_per_megan( 34) = 1. + p_of_megan2cb05vbs( 35) = is_linalool_oxd_c ; p_of_cb05vbs( 35) = p_oci ; cb05vbs_per_megan( 35) = 1. + p_of_megan2cb05vbs( 36) = is_linalool_oxd_t ; p_of_cb05vbs( 36) = p_oci ; cb05vbs_per_megan( 36) = 1. + p_of_megan2cb05vbs( 37) = is_ionone_b ; p_of_cb05vbs( 37) = p_hum ; cb05vbs_per_megan( 37) = 1. + p_of_megan2cb05vbs( 38) = is_bornyl_act ; p_of_cb05vbs( 38) = p_oci ; cb05vbs_per_megan( 38) = 1. + p_of_megan2cb05vbs( 39) = is_farnescene_a ; p_of_cb05vbs( 39) = p_hum ; cb05vbs_per_megan( 39) = 1. + p_of_megan2cb05vbs( 40) = is_caryophyllene_b ; p_of_cb05vbs( 40) = p_hum ; cb05vbs_per_megan( 40) = 1. + p_of_megan2cb05vbs( 41) = is_acoradiene ; p_of_cb05vbs( 41) = p_hum ; cb05vbs_per_megan( 41) = 1. + p_of_megan2cb05vbs( 42) = is_aromadendrene ; p_of_cb05vbs( 42) = p_hum ; cb05vbs_per_megan( 42) = 1. + p_of_megan2cb05vbs( 43) = is_bergamotene_a ; p_of_cb05vbs( 43) = p_hum ; cb05vbs_per_megan( 43) = 1. + p_of_megan2cb05vbs( 44) = is_bergamotene_b ; p_of_cb05vbs( 44) = p_hum ; cb05vbs_per_megan( 44) = 1. + p_of_megan2cb05vbs( 45) = is_bisabolene_a ; p_of_cb05vbs( 45) = p_hum ; cb05vbs_per_megan( 45) = 1. + p_of_megan2cb05vbs( 46) = is_bisabolene_b ; p_of_cb05vbs( 46) = p_hum ; cb05vbs_per_megan( 46) = 1. + p_of_megan2cb05vbs( 47) = is_bourbonene_b ; p_of_cb05vbs( 47) = p_hum ; cb05vbs_per_megan( 47) = 1. + p_of_megan2cb05vbs( 48) = is_cadinene_d ; p_of_cb05vbs( 48) = p_hum ; cb05vbs_per_megan( 48) = 1. + p_of_megan2cb05vbs( 49) = is_cadinene_g ; p_of_cb05vbs( 49) = p_hum ; cb05vbs_per_megan( 49) = 1. + p_of_megan2cb05vbs( 50) = is_cedrene_a ; p_of_cb05vbs( 50) = p_hum ; cb05vbs_per_megan( 50) = 1. + p_of_megan2cb05vbs( 51) = is_copaene_a ; p_of_cb05vbs( 51) = p_hum ; cb05vbs_per_megan( 51) = 1. + p_of_megan2cb05vbs( 52) = is_cubebene_a ; p_of_cb05vbs( 52) = p_hum ; cb05vbs_per_megan( 52) = 1. + p_of_megan2cb05vbs( 53) = is_cubebene_b ; p_of_cb05vbs( 53) = p_hum ; cb05vbs_per_megan( 53) = 1. + p_of_megan2cb05vbs( 54) = is_elemene_b ; p_of_cb05vbs( 54) = p_hum ; cb05vbs_per_megan( 54) = 1. + p_of_megan2cb05vbs( 55) = is_farnescene_b ; p_of_cb05vbs( 55) = p_hum ; cb05vbs_per_megan( 55) = 1. + p_of_megan2cb05vbs( 56) = is_germacrene_B ; p_of_cb05vbs( 56) = p_hum ; cb05vbs_per_megan( 56) = 1. + p_of_megan2cb05vbs( 57) = is_germacrene_D ; p_of_cb05vbs( 57) = p_hum ; cb05vbs_per_megan( 57) = 1. + p_of_megan2cb05vbs( 58) = is_gurjunene_b ; p_of_cb05vbs( 58) = p_hum ; cb05vbs_per_megan( 58) = 1. + p_of_megan2cb05vbs( 59) = is_humulene_a ; p_of_cb05vbs( 59) = p_hum ; cb05vbs_per_megan( 59) = 1. + p_of_megan2cb05vbs( 60) = is_humulene_g ; p_of_cb05vbs( 60) = p_hum ; cb05vbs_per_megan( 60) = 1. + p_of_megan2cb05vbs( 61) = is_isolongifolene ; p_of_cb05vbs( 61) = p_hum ; cb05vbs_per_megan( 61) = 1. + p_of_megan2cb05vbs( 62) = is_longifolene ; p_of_cb05vbs( 62) = p_hum ; cb05vbs_per_megan( 62) = 1. + p_of_megan2cb05vbs( 63) = is_longipinene ; p_of_cb05vbs( 63) = p_hum ; cb05vbs_per_megan( 63) = 1. + p_of_megan2cb05vbs( 64) = is_muurolene_a ; p_of_cb05vbs( 64) = p_hum ; cb05vbs_per_megan( 64) = 1. + p_of_megan2cb05vbs( 65) = is_muurolene_g ; p_of_cb05vbs( 65) = p_hum ; cb05vbs_per_megan( 65) = 1. + p_of_megan2cb05vbs( 66) = is_selinene_b ; p_of_cb05vbs( 66) = p_hum ; cb05vbs_per_megan( 66) = 1. + p_of_megan2cb05vbs( 67) = is_selinene_d ; p_of_cb05vbs( 67) = p_hum ; cb05vbs_per_megan( 67) = 1. + p_of_megan2cb05vbs( 68) = is_nerolidol_c ; p_of_cb05vbs( 68) = p_hum ; cb05vbs_per_megan( 68) = 1. + p_of_megan2cb05vbs( 69) = is_nerolidol_t ; p_of_cb05vbs( 69) = p_hum ; cb05vbs_per_megan( 69) = 1. + p_of_megan2cb05vbs( 70) = is_cedrol ; p_of_cb05vbs( 70) = p_hum ; cb05vbs_per_megan( 70) = 1. + p_of_megan2cb05vbs( 71) = is_mbo_2m3e2ol ; p_of_cb05vbs( 71) = p_ole ; cb05vbs_per_megan( 71) = 1. + p_of_megan2cb05vbs( 72) = is_mbo_2m3e2ol ; p_of_cb05vbs( 72) = p_par ; cb05vbs_per_megan( 72) = 3. + p_of_megan2cb05vbs( 73) = is_methanol ; p_of_cb05vbs( 73) = p_meoh ; cb05vbs_per_megan( 73) = 1. + p_of_megan2cb05vbs( 74) = is_acetone ; p_of_cb05vbs( 74) = p_ispd ; cb05vbs_per_megan( 74) = 1. + p_of_megan2cb05vbs( 75) = is_methane ; p_of_cb05vbs( 75) = p_ch4 ; cb05vbs_per_megan( 75) = 1. + p_of_megan2cb05vbs( 76) = is_ammonia ; p_of_cb05vbs( 76) = p_nh3 ; cb05vbs_per_megan( 76) = 1. + p_of_megan2cb05vbs( 77) = is_nitrous_oxd ; p_of_cb05vbs( 77) = non_react ; cb05vbs_per_megan( 77) = 1. + p_of_megan2cb05vbs( 78) = is_nitric_oxd ; p_of_cb05vbs( 78) = p_no ; cb05vbs_per_megan( 78) = 1. + p_of_megan2cb05vbs( 79) = is_acetaldehyde ; p_of_cb05vbs( 79) = p_ald2 ; cb05vbs_per_megan( 79) = 1. + p_of_megan2cb05vbs( 80) = is_ethanol ; p_of_cb05vbs( 80) = p_etoh ; cb05vbs_per_megan( 80) = 1. + p_of_megan2cb05vbs( 81) = is_formic_acid ; p_of_cb05vbs( 81) = p_facd ; cb05vbs_per_megan( 81) = 1. + p_of_megan2cb05vbs( 82) = is_formaldehyde ; p_of_cb05vbs( 82) = p_form ; cb05vbs_per_megan( 82) = 1. + p_of_megan2cb05vbs( 83) = is_acetic_acid ; p_of_cb05vbs( 83) = p_aacd ; cb05vbs_per_megan( 83) = 1. + p_of_megan2cb05vbs( 84) = is_mbo_3m2e1ol ; p_of_cb05vbs( 84) = p_ald2 ; cb05vbs_per_megan( 84) = 1. + p_of_megan2cb05vbs( 85) = is_mbo_3m2e1ol ; p_of_cb05vbs( 85) = p_par ; cb05vbs_per_megan( 85) = 3. + p_of_megan2cb05vbs( 86) = is_mbo_3m3e1ol ; p_of_cb05vbs( 86) = p_form ; cb05vbs_per_megan( 86) = 1. + p_of_megan2cb05vbs( 87) = is_mbo_3m3e1ol ; p_of_cb05vbs( 87) = p_par ; cb05vbs_per_megan( 87) = 4. + p_of_megan2cb05vbs( 88) = is_benzaldehyde ; p_of_cb05vbs( 88) = p_tol ; cb05vbs_per_megan( 88) = 1. + p_of_megan2cb05vbs( 89) = is_butanone_2 ; p_of_cb05vbs( 89) = p_ispd ; cb05vbs_per_megan( 89) = 1. + p_of_megan2cb05vbs( 90) = is_butanone_2 ; p_of_cb05vbs( 90) = p_par ; cb05vbs_per_megan( 90) = 2. + p_of_megan2cb05vbs( 91) = is_decanal ; p_of_cb05vbs( 91) = p_aldx ; cb05vbs_per_megan( 91) = 1. + p_of_megan2cb05vbs( 92) = is_decanal ; p_of_cb05vbs( 92) = p_par ; cb05vbs_per_megan( 92) = 8. + p_of_megan2cb05vbs( 93) = is_dodecene_1 ; p_of_cb05vbs( 93) = p_ole ; cb05vbs_per_megan( 93) = 1. + p_of_megan2cb05vbs( 94) = is_dodecene_1 ; p_of_cb05vbs( 94) = p_par ; cb05vbs_per_megan( 94) = 10. + p_of_megan2cb05vbs( 95) = is_geranyl_acetone ; p_of_cb05vbs( 95) = p_hum ; cb05vbs_per_megan( 95) = 1. + p_of_megan2cb05vbs( 96) = is_heptanal ; p_of_cb05vbs( 96) = p_aldx ; cb05vbs_per_megan( 96) = 1. + p_of_megan2cb05vbs( 97) = is_heptanal ; p_of_cb05vbs( 97) = p_par ; cb05vbs_per_megan( 97) = 5. + p_of_megan2cb05vbs( 98) = is_heptane ; p_of_cb05vbs( 98) = p_par ; cb05vbs_per_megan( 98) = 7. + p_of_megan2cb05vbs( 99) = is_hexane ; p_of_cb05vbs( 99) = p_par ; cb05vbs_per_megan( 99) = 6. + p_of_megan2cb05vbs(100) = is_met_benzoate ; p_of_cb05vbs(100) = p_tol ; cb05vbs_per_megan(100) = 1. + p_of_megan2cb05vbs(101) = is_met_heptenone ; p_of_cb05vbs(101) = p_ispd ; cb05vbs_per_megan(101) = 1. + p_of_megan2cb05vbs(102) = is_met_heptenone ; p_of_cb05vbs(102) = p_par ; cb05vbs_per_megan(102) = 3. + p_of_megan2cb05vbs(103) = is_met_heptenone ; p_of_cb05vbs(103) = p_ole ; cb05vbs_per_megan(103) = 1. + p_of_megan2cb05vbs(104) = is_neryl_acetone ; p_of_cb05vbs(104) = p_ispd ; cb05vbs_per_megan(104) = 1. + p_of_megan2cb05vbs(105) = is_neryl_acetone ; p_of_cb05vbs(105) = p_par ; cb05vbs_per_megan(105) = 8. + p_of_megan2cb05vbs(106) = is_neryl_acetone ; p_of_cb05vbs(106) = p_iole ; cb05vbs_per_megan(106) = 2. + p_of_megan2cb05vbs(107) = is_nonanal ; p_of_cb05vbs(107) = p_aldx ; cb05vbs_per_megan(107) = 1. + p_of_megan2cb05vbs(108) = is_nonanal ; p_of_cb05vbs(108) = p_par ; cb05vbs_per_megan(108) = 7. + p_of_megan2cb05vbs(109) = is_nonenal ; p_of_cb05vbs(109) = p_aldx ; cb05vbs_per_megan(109) = 1. + p_of_megan2cb05vbs(110) = is_nonenal ; p_of_cb05vbs(110) = p_par ; cb05vbs_per_megan(110) = 6. + p_of_megan2cb05vbs(111) = is_nonenal ; p_of_cb05vbs(111) = p_iole ; cb05vbs_per_megan(111) = 1. + p_of_megan2cb05vbs(112) = is_octanal ; p_of_cb05vbs(112) = p_aldx ; cb05vbs_per_megan(112) = 1. + p_of_megan2cb05vbs(113) = is_octanal ; p_of_cb05vbs(113) = p_par ; cb05vbs_per_megan(113) = 6. + p_of_megan2cb05vbs(114) = is_octanol ; p_of_cb05vbs(114) = p_par ; cb05vbs_per_megan(114) = 8. + p_of_megan2cb05vbs(115) = is_octenol_1e3ol ; p_of_cb05vbs(115) = p_par ; cb05vbs_per_megan(115) = 6. + p_of_megan2cb05vbs(116) = is_octenol_1e3ol ; p_of_cb05vbs(116) = p_ole ; cb05vbs_per_megan(116) = 1. + p_of_megan2cb05vbs(117) = is_oxopentanal ; p_of_cb05vbs(117) = p_aldx ; cb05vbs_per_megan(117) = 1. + p_of_megan2cb05vbs(118) = is_oxopentanal ; p_of_cb05vbs(118) = p_par ; cb05vbs_per_megan(118) = 3. + p_of_megan2cb05vbs(119) = is_pentane ; p_of_cb05vbs(119) = p_par ; cb05vbs_per_megan(119) = 5. + p_of_megan2cb05vbs(120) = is_phenyl_cco ; p_of_cb05vbs(120) = p_aldx ; cb05vbs_per_megan(120) = 1 + p_of_megan2cb05vbs(121) = is_phenyl_cco ; p_of_cb05vbs(121) = p_tol ; cb05vbs_per_megan(121) = 1. + p_of_megan2cb05vbs(122) = is_pyruvic_acid ; p_of_cb05vbs(122) = p_aacd ; cb05vbs_per_megan(122) = 1. + p_of_megan2cb05vbs(123) = is_pyruvic_acid ; p_of_cb05vbs(123) = p_ispd ; cb05vbs_per_megan(123) = 1. + p_of_megan2cb05vbs(124) = is_terpinyl_act_a ; p_of_cb05vbs(124) = p_oci ; cb05vbs_per_megan(124) = 1. + p_of_megan2cb05vbs(125) = is_tetradecene_1 ; p_of_cb05vbs(125) = p_par ; cb05vbs_per_megan(125) = 12. + p_of_megan2cb05vbs(126) = is_tetradecene_1 ; p_of_cb05vbs(126) = p_ole ; cb05vbs_per_megan(126) = 1. + p_of_megan2cb05vbs(127) = is_toluene ; p_of_cb05vbs(127) = p_tol ; cb05vbs_per_megan(127) = 1. + p_of_megan2cb05vbs(128) = is_carbon_monoxide ; p_of_cb05vbs(128) = p_co ; cb05vbs_per_megan(128) = 1. + p_of_megan2cb05vbs(129) = is_butene ; p_of_cb05vbs(129) = p_ole ; cb05vbs_per_megan(129) = 1. + p_of_megan2cb05vbs(130) = is_butene ; p_of_cb05vbs(130) = p_par ; cb05vbs_per_megan(130) = 2. + p_of_megan2cb05vbs(131) = is_ethane ; p_of_cb05vbs(131) = p_etha ; cb05vbs_per_megan(131) = 1. + p_of_megan2cb05vbs(132) = is_ethene ; p_of_cb05vbs(132) = p_eth ; cb05vbs_per_megan(132) = 1. + p_of_megan2cb05vbs(133) = is_hydrogen_cyanide ; p_of_cb05vbs(133) = non_react ; cb05vbs_per_megan(133) = 1. + p_of_megan2cb05vbs(134) = is_propane ; p_of_cb05vbs(134) = p_par ; cb05vbs_per_megan(134) = 3. + p_of_megan2cb05vbs(135) = is_propene ; p_of_cb05vbs(135) = p_ole ; cb05vbs_per_megan(135) = 1. + p_of_megan2cb05vbs(136) = is_propene ; p_of_cb05vbs(136) = p_par ; cb05vbs_per_megan(136) = 1. + p_of_megan2cb05vbs(137) = is_carbon_2s ; p_of_cb05vbs(137) = non_react ; cb05vbs_per_megan(137) = 1. + p_of_megan2cb05vbs(138) = is_carbonyl_s ; p_of_cb05vbs(138) = non_react ; cb05vbs_per_megan(138) = 1. + p_of_megan2cb05vbs(139) = is_diallyl_2s ; p_of_cb05vbs(139) = non_react ; cb05vbs_per_megan(139) = 1. + p_of_megan2cb05vbs(140) = is_diallyl_2s ; p_of_cb05vbs(140) = p_par ; cb05vbs_per_megan(140) = 2. + p_of_megan2cb05vbs(141) = is_diallyl_2s ; p_of_cb05vbs(141) = p_ole ; cb05vbs_per_megan(141) = 2. + p_of_megan2cb05vbs(142) = is_2met_2s ; p_of_cb05vbs(142) = non_react ; cb05vbs_per_megan(142) = 1. + p_of_megan2cb05vbs(143) = is_2met_s ; p_of_cb05vbs(143) = non_react ; cb05vbs_per_megan(143) = 1. + p_of_megan2cb05vbs(144) = is_met_chloride ; p_of_cb05vbs(144) = non_react ; cb05vbs_per_megan(144) = 1. + p_of_megan2cb05vbs(145) = is_met_bromide ; p_of_cb05vbs(145) = non_react ; cb05vbs_per_megan(145) = 1. + p_of_megan2cb05vbs(146) = is_met_iodide ; p_of_cb05vbs(146) = non_react ; cb05vbs_per_megan(146) = 1. + p_of_megan2cb05vbs(147) = is_hydrogen_s ; p_of_cb05vbs(147) = non_react ; cb05vbs_per_megan(147) = 1. + p_of_megan2cb05vbs(148) = is_met_mercaptan ; p_of_cb05vbs(148) = p_par ; cb05vbs_per_megan(148) = 1. + p_of_megan2cb05vbs(149) = is_met_propenyl_2s ; p_of_cb05vbs(149) = non_react ; cb05vbs_per_megan(149) = 1. + p_of_megan2cb05vbs(150) = is_met_propenyl_2s ; p_of_cb05vbs(150) = p_iole ; cb05vbs_per_megan(150) = 1. + p_of_megan2cb05vbs(151) = is_pppp_2s ; p_of_cb05vbs(151) = non_react ; cb05vbs_per_megan(151) = 1. + p_of_megan2cb05vbs(152) = is_pppp_2s ; p_of_cb05vbs(152) = p_par ; cb05vbs_per_megan(152) = 2. + p_of_megan2cb05vbs(153) = is_pppp_2s ; p_of_cb05vbs(153) = p_iole ; cb05vbs_per_megan(153) = 1. + p_of_megan2cb05vbs(154) = is_2met_nonatriene ; p_of_cb05vbs(154) = p_oci ; cb05vbs_per_megan(154) = 1. + p_of_megan2cb05vbs(155) = is_met_salicylate ; p_of_cb05vbs(155) = p_tol ; cb05vbs_per_megan(155) = 1. + p_of_megan2cb05vbs(156) = is_indole ; p_of_cb05vbs(156) = p_tol ; cb05vbs_per_megan(156) = 1. + p_of_megan2cb05vbs(157) = is_jasmone ; p_of_cb05vbs(157) = p_oci ; cb05vbs_per_megan(157) = 1. + p_of_megan2cb05vbs(158) = is_met_jasmonate ; p_of_cb05vbs(158) = p_hum ; cb05vbs_per_megan(158) = 1. + p_of_megan2cb05vbs(159) = is_3met_3dctt ; p_of_cb05vbs(159) = p_hum ; cb05vbs_per_megan(159) = 1. + p_of_megan2cb05vbs(160) = is_hexanal ; p_of_cb05vbs(160) = p_aldx ; cb05vbs_per_megan(160) = 1. + p_of_megan2cb05vbs(161) = is_hexanal ; p_of_cb05vbs(161) = p_par ; cb05vbs_per_megan(161) = 4. + p_of_megan2cb05vbs(162) = is_hexanol_1 ; p_of_cb05vbs(162) = p_par ; cb05vbs_per_megan(162) = 6. + p_of_megan2cb05vbs(163) = is_hexenal_c3 ; p_of_cb05vbs(163) = p_aldx ; cb05vbs_per_megan(163) = 1. + p_of_megan2cb05vbs(164) = is_hexenal_c3 ; p_of_cb05vbs(164) = p_par ; cb05vbs_per_megan(164) = 3. + p_of_megan2cb05vbs(165) = is_hexenal_c3 ; p_of_cb05vbs(165) = p_iole ; cb05vbs_per_megan(165) = 1 + p_of_megan2cb05vbs(166) = is_hexenal_t2 ; p_of_cb05vbs(166) = p_aldx ; cb05vbs_per_megan(166) = 1. + p_of_megan2cb05vbs(167) = is_hexenal_t2 ; p_of_cb05vbs(167) = p_par ; cb05vbs_per_megan(167) = 6. + p_of_megan2cb05vbs(168) = is_hexenal_t2 ; p_of_cb05vbs(168) = p_iole ; cb05vbs_per_megan(168) = 1. + p_of_megan2cb05vbs(169) = is_hexenol_c3 ; p_of_cb05vbs(169) = p_par ; cb05vbs_per_megan(169) = 5. + p_of_megan2cb05vbs(170) = is_hexenol_c3 ; p_of_cb05vbs(170) = p_iole ; cb05vbs_per_megan(170) = 1. + p_of_megan2cb05vbs(171) = is_hexenyl_act_c3 ; p_of_cb05vbs(171) = p_ispd ; cb05vbs_per_megan(171) = 1. + p_of_megan2cb05vbs(172) = is_hexenyl_act_c3 ; p_of_cb05vbs(172) = p_par ; cb05vbs_per_megan(172) = 5. + p_of_megan2cb05vbs(173) = is_hexenyl_act_c3 ; p_of_cb05vbs(173) = p_iole ; cb05vbs_per_megan(173) = 1. + + END SUBROUTINE get_megan2cb05vbs_table + !-------------------------------------------------------------------- SUBROUTINE get_megan2crimech_table diff --git a/wrfv2_fire/chem/module_data_mosaic_asect.F b/wrfv2_fire/chem/module_data_mosaic_asect.F index 8c2c4742..b2ceff86 100644 --- a/wrfv2_fire/chem/module_data_mosaic_asect.F +++ b/wrfv2_fire/chem/module_data_mosaic_asect.F @@ -193,7 +193,8 @@ module module_data_mosaic_asect integer, parameter :: maxd_atype = 1 integer, parameter :: maxd_asize = 8 - integer, parameter :: maxd_acomp = 120 ! for additional SOA species changed by Manish Shrivastava on 01/25/10 +! integer, parameter :: maxd_acomp = 120 ! for additional SOA species changed by Manish Shrivastava on 01/25/10 + integer, parameter :: maxd_acomp = 400 ! for additional SOA species changed by Manish Shrivastava on 01/25/10 integer, parameter :: maxd_aphase = 2 integer, save :: ai_phase = -999888777 @@ -304,6 +305,13 @@ module module_data_mosaic_asect integer, save :: mastercompindx_opcg8_f_o_aer = -999888777 integer, save :: mastercompindx_smpa_aer = -999888777 integer, save :: mastercompindx_smpbb_aer = -999888777 + + integer, save :: mastercompindx_glysoa_r1_aer = -999888777 + integer, save :: mastercompindx_glysoa_r2_aer = -999888777 + integer, save :: mastercompindx_glysoa_oh_aer = -999888777 + integer, save :: mastercompindx_glysoa_nh4_aer = -999888777 + integer, save :: mastercompindx_glysoa_sfc_aer = -999888777 + integer, save :: mastercompindx_ant1_c_aer = -999888777 integer, save :: mastercompindx_ant2_c_aer = -999888777 integer, save :: mastercompindx_ant3_c_aer = -999888777 @@ -321,6 +329,16 @@ module module_data_mosaic_asect integer, save :: mastercompindx_biog3_o_aer = -999888777 integer, save :: mastercompindx_biog4_o_aer = -999888777 + integer, save :: mastercompindx_asoaX_aer = -999888777 + integer, save :: mastercompindx_asoa1_aer = -999888777 + integer, save :: mastercompindx_asoa2_aer = -999888777 + integer, save :: mastercompindx_asoa3_aer = -999888777 + integer, save :: mastercompindx_asoa4_aer = -999888777 + integer, save :: mastercompindx_bsoaX_aer = -999888777 + integer, save :: mastercompindx_bsoa1_aer = -999888777 + integer, save :: mastercompindx_bsoa2_aer = -999888777 + integer, save :: mastercompindx_bsoa3_aer = -999888777 + integer, save :: mastercompindx_bsoa4_aer = -999888777 real, save :: & dens_aer( maxd_acomp, maxd_atype ), & @@ -425,6 +443,13 @@ module module_data_mosaic_asect lptr_opcg8_f_o_aer(maxd_asize, maxd_atype, maxd_aphase), & lptr_smpa_aer(maxd_asize, maxd_atype, maxd_aphase), & lptr_smpbb_aer(maxd_asize, maxd_atype, maxd_aphase), & + + lptr_glysoa_r1_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_glysoa_r2_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_glysoa_oh_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_glysoa_nh4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_glysoa_sfc_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_ant1_c_aer(maxd_asize, maxd_atype, maxd_aphase), & lptr_ant2_c_aer(maxd_asize, maxd_atype, maxd_aphase), & lptr_ant3_c_aer(maxd_asize, maxd_atype, maxd_aphase), & @@ -440,8 +465,18 @@ module module_data_mosaic_asect lptr_biog1_o_aer(maxd_asize, maxd_atype, maxd_aphase), & lptr_biog2_o_aer(maxd_asize, maxd_atype, maxd_aphase), & lptr_biog3_o_aer(maxd_asize, maxd_atype, maxd_aphase), & - lptr_biog4_o_aer(maxd_asize, maxd_atype, maxd_aphase) + lptr_biog4_o_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_asoaX_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_asoa1_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_asoa2_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_asoa3_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_asoa4_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_bsoaX_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_bsoa1_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_bsoa2_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_bsoa3_aer(maxd_asize, maxd_atype, maxd_aphase), & + lptr_bsoa4_aer(maxd_asize, maxd_atype, maxd_aphase) @@ -533,16 +568,23 @@ module module_data_mosaic_asect real, parameter :: mw_opcg6_f_o_aer = 250.0 real, parameter :: mw_opcg7_f_o_aer = 250.0 real, parameter :: mw_opcg8_f_o_aer = 250.0 - real, parameter :: mw_smpa_aer = 250 - real, parameter :: mw_smpbb_aer = 250 - real, parameter :: mw_ant1_c_aer = 250 - real, parameter :: mw_ant2_c_aer = 250 - real, parameter :: mw_ant3_c_aer = 250 - real, parameter :: mw_ant4_c_aer = 250 - real, parameter :: mw_ant1_o_aer = 250 - real, parameter :: mw_ant2_o_aer = 250 - real, parameter :: mw_ant3_o_aer = 250 - real, parameter :: mw_ant4_o_aer = 250 + real, parameter :: mw_smpa_aer = 250.0 + real, parameter :: mw_smpbb_aer = 250.0 + + real, parameter :: mw_glysoa_r1_aer = 250.0 + real, parameter :: mw_glysoa_r2_aer = 250.0 + real, parameter :: mw_glysoa_oh_aer = 250.0 + real, parameter :: mw_glysoa_nh4_aer = 250.0 + real, parameter :: mw_glysoa_sfc_aer = 250.0 + + real, parameter :: mw_ant1_c_aer = 250.0 + real, parameter :: mw_ant2_c_aer = 250.0 + real, parameter :: mw_ant3_c_aer = 250.0 + real, parameter :: mw_ant4_c_aer = 250.0 + real, parameter :: mw_ant1_o_aer = 250.0 + real, parameter :: mw_ant2_o_aer = 250.0 + real, parameter :: mw_ant3_o_aer = 250.0 + real, parameter :: mw_ant4_o_aer = 250.0 real, parameter :: mw_biog1_c_aer = 250.0 real, parameter :: mw_biog2_c_aer = 250.0 real, parameter :: mw_biog3_c_aer = 250.0 @@ -552,6 +594,16 @@ module module_data_mosaic_asect real, parameter :: mw_biog3_o_aer = 250.0 real, parameter :: mw_biog4_o_aer = 250.0 + real, parameter :: mw_asoaX_aer = 250.0 + real, parameter :: mw_asoa1_aer = 250.0 + real, parameter :: mw_asoa2_aer = 250.0 + real, parameter :: mw_asoa3_aer = 250.0 + real, parameter :: mw_asoa4_aer = 250.0 + real, parameter :: mw_bsoaX_aer = 250.0 + real, parameter :: mw_bsoa1_aer = 250.0 + real, parameter :: mw_bsoa2_aer = 250.0 + real, parameter :: mw_bsoa3_aer = 250.0 + real, parameter :: mw_bsoa4_aer = 250.0 @@ -637,6 +689,13 @@ module module_data_mosaic_asect real, parameter :: dens_opcg8_f_o_aer = 1.0 real, parameter :: dens_smpa_aer = 1.0 real, parameter :: dens_smpbb_aer = 1.0 + + real, parameter :: dens_glysoa_r1_aer = 1.0 + real, parameter :: dens_glysoa_r2_aer = 1.0 + real, parameter :: dens_glysoa_oh_aer = 1.0 + real, parameter :: dens_glysoa_nh4_aer = 1.0 + real, parameter :: dens_glysoa_sfc_aer = 1.0 + real, parameter :: dens_ant1_c_aer = 1.0 real, parameter :: dens_ant2_c_aer = 1.0 real, parameter :: dens_ant3_c_aer = 1.0 @@ -654,6 +713,17 @@ module module_data_mosaic_asect real, parameter :: dens_biog3_o_aer = 1.0 real, parameter :: dens_biog4_o_aer = 1.0 +! dens based on Murphy and Pandis, ES&T, 2009 + real, parameter :: dens_asoaX_aer = 1.5 + real, parameter :: dens_asoa1_aer = 1.5 + real, parameter :: dens_asoa2_aer = 1.5 + real, parameter :: dens_asoa3_aer = 1.5 + real, parameter :: dens_asoa4_aer = 1.5 + real, parameter :: dens_bsoaX_aer = 1.5 + real, parameter :: dens_bsoa1_aer = 1.5 + real, parameter :: dens_bsoa2_aer = 1.5 + real, parameter :: dens_bsoa3_aer = 1.5 + real, parameter :: dens_bsoa4_aer = 1.5 ! water density (g/cm3) @@ -670,95 +740,112 @@ module module_data_mosaic_asect real, parameter :: hygro_cl_aer = 1.16 real, parameter :: hygro_na_aer = 1.16 real, parameter :: hygro_oin_aer = 0.14 - real, parameter :: hygro_oc_aer = 0.14 + real, parameter :: hygro_oc_aer = 0.20 real, parameter :: hygro_bc_aer = 1.e-6 - real, parameter :: hygro_pcg1_b_c_aer = 0.14 - real, parameter :: hygro_pcg2_b_c_aer = 0.14 - real, parameter :: hygro_pcg3_b_c_aer = 0.14 - real, parameter :: hygro_pcg4_b_c_aer = 0.14 - real, parameter :: hygro_pcg5_b_c_aer = 0.14 - real, parameter :: hygro_pcg6_b_c_aer = 0.14 - real, parameter :: hygro_pcg7_b_c_aer = 0.14 - real, parameter :: hygro_pcg8_b_c_aer = 0.14 - real, parameter :: hygro_pcg9_b_c_aer = 0.14 - real, parameter :: hygro_pcg1_b_o_aer = 0.14 - real, parameter :: hygro_pcg2_b_o_aer = 0.14 - real, parameter :: hygro_pcg3_b_o_aer = 0.14 - real, parameter :: hygro_pcg4_b_o_aer = 0.14 - real, parameter :: hygro_pcg5_b_o_aer = 0.14 - real, parameter :: hygro_pcg6_b_o_aer = 0.14 - real, parameter :: hygro_pcg7_b_o_aer = 0.14 - real, parameter :: hygro_pcg8_b_o_aer = 0.14 - real, parameter :: hygro_pcg9_b_o_aer = 0.14 - real, parameter :: hygro_opcg1_b_c_aer = 0.14 - real, parameter :: hygro_opcg2_b_c_aer = 0.14 - real, parameter :: hygro_opcg3_b_c_aer = 0.14 - real, parameter :: hygro_opcg4_b_c_aer = 0.14 - real, parameter :: hygro_opcg5_b_c_aer = 0.14 - real, parameter :: hygro_opcg6_b_c_aer = 0.14 - real, parameter :: hygro_opcg7_b_c_aer = 0.14 - real, parameter :: hygro_opcg8_b_c_aer = 0.14 - real, parameter :: hygro_opcg1_b_o_aer = 0.14 - real, parameter :: hygro_opcg2_b_o_aer = 0.14 - real, parameter :: hygro_opcg3_b_o_aer = 0.14 - real, parameter :: hygro_opcg4_b_o_aer = 0.14 - real, parameter :: hygro_opcg5_b_o_aer = 0.14 - real, parameter :: hygro_opcg6_b_o_aer = 0.14 - real, parameter :: hygro_opcg7_b_o_aer = 0.14 - real, parameter :: hygro_opcg8_b_o_aer = 0.14 - real, parameter :: hygro_pcg1_f_c_aer = 0.14 - real, parameter :: hygro_pcg2_f_c_aer = 0.14 - real, parameter :: hygro_pcg3_f_c_aer = 0.14 - real, parameter :: hygro_pcg4_f_c_aer = 0.14 - real, parameter :: hygro_pcg5_f_c_aer = 0.14 - real, parameter :: hygro_pcg6_f_c_aer = 0.14 - real, parameter :: hygro_pcg7_f_c_aer = 0.14 - real, parameter :: hygro_pcg8_f_c_aer = 0.14 - real, parameter :: hygro_pcg9_f_c_aer = 0.14 - real, parameter :: hygro_pcg1_f_o_aer = 0.14 - real, parameter :: hygro_pcg2_f_o_aer = 0.14 - real, parameter :: hygro_pcg3_f_o_aer = 0.14 - real, parameter :: hygro_pcg4_f_o_aer = 0.14 - real, parameter :: hygro_pcg5_f_o_aer = 0.14 - real, parameter :: hygro_pcg6_f_o_aer = 0.14 - real, parameter :: hygro_pcg7_f_o_aer = 0.14 - real, parameter :: hygro_pcg8_f_o_aer = 0.14 - real, parameter :: hygro_pcg9_f_o_aer = 0.14 - real, parameter :: hygro_opcg1_f_c_aer = 0.14 - real, parameter :: hygro_opcg2_f_c_aer = 0.14 - real, parameter :: hygro_opcg3_f_c_aer = 0.14 - real, parameter :: hygro_opcg4_f_c_aer = 0.14 - real, parameter :: hygro_opcg5_f_c_aer = 0.14 - real, parameter :: hygro_opcg6_f_c_aer = 0.14 - real, parameter :: hygro_opcg7_f_c_aer = 0.14 - real, parameter :: hygro_opcg8_f_c_aer = 0.14 - real, parameter :: hygro_opcg1_f_o_aer = 0.14 - real, parameter :: hygro_opcg2_f_o_aer = 0.14 - real, parameter :: hygro_opcg3_f_o_aer = 0.14 - real, parameter :: hygro_opcg4_f_o_aer = 0.14 - real, parameter :: hygro_opcg5_f_o_aer = 0.14 - real, parameter :: hygro_opcg6_f_o_aer = 0.14 - real, parameter :: hygro_opcg7_f_o_aer = 0.14 - real, parameter :: hygro_opcg8_f_o_aer = 0.14 - real, parameter :: hygro_smpa_aer = 0.14 - real, parameter :: hygro_smpbb_aer = 0.14 - real, parameter :: hygro_ant1_c_aer = 0.14 - real, parameter :: hygro_ant2_c_aer = 0.14 - real, parameter :: hygro_ant3_c_aer = 0.14 - real, parameter :: hygro_ant4_c_aer = 0.14 - real, parameter :: hygro_ant1_o_aer = 0.14 - real, parameter :: hygro_ant2_o_aer = 0.14 - real, parameter :: hygro_ant3_o_aer = 0.14 - real, parameter :: hygro_ant4_o_aer = 0.14 - real, parameter :: hygro_biog1_c_aer = 0.14 - real, parameter :: hygro_biog2_c_aer = 0.14 - real, parameter :: hygro_biog3_c_aer = 0.14 - real, parameter :: hygro_biog4_c_aer = 0.14 - real, parameter :: hygro_biog1_o_aer = 0.14 - real, parameter :: hygro_biog2_o_aer = 0.14 - real, parameter :: hygro_biog3_o_aer = 0.14 - real, parameter :: hygro_biog4_o_aer = 0.14 - + real, parameter :: hygro_pcg1_b_c_aer = 0.04 + real, parameter :: hygro_pcg2_b_c_aer = 0.04 + real, parameter :: hygro_pcg3_b_c_aer = 0.04 + real, parameter :: hygro_pcg4_b_c_aer = 0.04 + real, parameter :: hygro_pcg5_b_c_aer = 0.04 + real, parameter :: hygro_pcg6_b_c_aer = 0.04 + real, parameter :: hygro_pcg7_b_c_aer = 0.04 + real, parameter :: hygro_pcg8_b_c_aer = 0.04 + real, parameter :: hygro_pcg9_b_c_aer = 0.04 + real, parameter :: hygro_pcg1_b_o_aer = 0.04 + real, parameter :: hygro_pcg2_b_o_aer = 0.04 + real, parameter :: hygro_pcg3_b_o_aer = 0.04 + real, parameter :: hygro_pcg4_b_o_aer = 0.04 + real, parameter :: hygro_pcg5_b_o_aer = 0.04 + real, parameter :: hygro_pcg6_b_o_aer = 0.04 + real, parameter :: hygro_pcg7_b_o_aer = 0.04 + real, parameter :: hygro_pcg8_b_o_aer = 0.04 + real, parameter :: hygro_pcg9_b_o_aer = 0.04 + real, parameter :: hygro_opcg1_b_c_aer = 0.10 + real, parameter :: hygro_opcg2_b_c_aer = 0.10 + real, parameter :: hygro_opcg3_b_c_aer = 0.10 + real, parameter :: hygro_opcg4_b_c_aer = 0.10 + real, parameter :: hygro_opcg5_b_c_aer = 0.10 + real, parameter :: hygro_opcg6_b_c_aer = 0.10 + real, parameter :: hygro_opcg7_b_c_aer = 0.10 + real, parameter :: hygro_opcg8_b_c_aer = 0.10 + real, parameter :: hygro_opcg1_b_o_aer = 0.10 + real, parameter :: hygro_opcg2_b_o_aer = 0.10 + real, parameter :: hygro_opcg3_b_o_aer = 0.10 + real, parameter :: hygro_opcg4_b_o_aer = 0.10 + real, parameter :: hygro_opcg5_b_o_aer = 0.10 + real, parameter :: hygro_opcg6_b_o_aer = 0.10 + real, parameter :: hygro_opcg7_b_o_aer = 0.10 + real, parameter :: hygro_opcg8_b_o_aer = 0.10 + real, parameter :: hygro_pcg1_f_c_aer = 1.0e-6 + real, parameter :: hygro_pcg2_f_c_aer = 1.0e-6 + real, parameter :: hygro_pcg3_f_c_aer = 1.0e-6 + real, parameter :: hygro_pcg4_f_c_aer = 1.0e-6 + real, parameter :: hygro_pcg5_f_c_aer = 1.0e-6 + real, parameter :: hygro_pcg6_f_c_aer = 1.0e-6 + real, parameter :: hygro_pcg7_f_c_aer = 1.0e-6 + real, parameter :: hygro_pcg8_f_c_aer = 1.0e-6 + real, parameter :: hygro_pcg9_f_c_aer = 1.0e-6 + real, parameter :: hygro_pcg1_f_o_aer = 1.0e-6 + real, parameter :: hygro_pcg2_f_o_aer = 1.0e-6 + real, parameter :: hygro_pcg3_f_o_aer = 1.0e-6 + real, parameter :: hygro_pcg4_f_o_aer = 1.0e-6 + real, parameter :: hygro_pcg5_f_o_aer = 1.0e-6 + real, parameter :: hygro_pcg6_f_o_aer = 1.0e-6 + real, parameter :: hygro_pcg7_f_o_aer = 1.0e-6 + real, parameter :: hygro_pcg8_f_o_aer = 1.0e-6 + real, parameter :: hygro_pcg9_f_o_aer = 1.0e-6 + real, parameter :: hygro_opcg1_f_c_aer = 0.10 + real, parameter :: hygro_opcg2_f_c_aer = 0.10 + real, parameter :: hygro_opcg3_f_c_aer = 0.10 + real, parameter :: hygro_opcg4_f_c_aer = 0.10 + real, parameter :: hygro_opcg5_f_c_aer = 0.10 + real, parameter :: hygro_opcg6_f_c_aer = 0.10 + real, parameter :: hygro_opcg7_f_c_aer = 0.10 + real, parameter :: hygro_opcg8_f_c_aer = 0.10 + real, parameter :: hygro_opcg1_f_o_aer = 0.10 + real, parameter :: hygro_opcg2_f_o_aer = 0.10 + real, parameter :: hygro_opcg3_f_o_aer = 0.10 + real, parameter :: hygro_opcg4_f_o_aer = 0.10 + real, parameter :: hygro_opcg5_f_o_aer = 0.10 + real, parameter :: hygro_opcg6_f_o_aer = 0.10 + real, parameter :: hygro_opcg7_f_o_aer = 0.10 + real, parameter :: hygro_opcg8_f_o_aer = 0.10 + real, parameter :: hygro_smpa_aer = 0.10 + real, parameter :: hygro_smpbb_aer = 0.140 + + real, parameter :: hygro_glysoa_r1_aer = 0.14 + real, parameter :: hygro_glysoa_r2_aer = 0.14 + real, parameter :: hygro_glysoa_oh_aer = 0.14 + real, parameter :: hygro_glysoa_nh4_aer = 0.14 + real, parameter :: hygro_glysoa_sfc_aer = 0.14 + + real, parameter :: hygro_ant1_c_aer = 0.10 + real, parameter :: hygro_ant2_c_aer = 0.10 + real, parameter :: hygro_ant3_c_aer = 0.10 + real, parameter :: hygro_ant4_c_aer = 0.10 + real, parameter :: hygro_ant1_o_aer = 0.10 + real, parameter :: hygro_ant2_o_aer = 0.10 + real, parameter :: hygro_ant3_o_aer = 0.10 + real, parameter :: hygro_ant4_o_aer = 0.10 + real, parameter :: hygro_biog1_c_aer = 0.10 + real, parameter :: hygro_biog2_c_aer = 0.10 + real, parameter :: hygro_biog3_c_aer = 0.10 + real, parameter :: hygro_biog4_c_aer = 0.10 + real, parameter :: hygro_biog1_o_aer = 0.10 + real, parameter :: hygro_biog2_o_aer = 0.10 + real, parameter :: hygro_biog3_o_aer = 0.10 + real, parameter :: hygro_biog4_o_aer = 0.10 + + real, parameter :: hygro_asoaX_aer = 0.14 + real, parameter :: hygro_asoa1_aer = 0.14 + real, parameter :: hygro_asoa2_aer = 0.14 + real, parameter :: hygro_asoa3_aer = 0.14 + real, parameter :: hygro_asoa4_aer = 0.14 + real, parameter :: hygro_bsoaX_aer = 0.14 + real, parameter :: hygro_bsoa1_aer = 0.14 + real, parameter :: hygro_bsoa2_aer = 0.14 + real, parameter :: hygro_bsoa3_aer = 0.14 + real, parameter :: hygro_bsoa4_aer = 0.14 integer, save :: & diff --git a/wrfv2_fire/chem/module_data_mosaic_other.F b/wrfv2_fire/chem/module_data_mosaic_other.F index d83889e9..38068575 100644 --- a/wrfv2_fire/chem/module_data_mosaic_other.F +++ b/wrfv2_fire/chem/module_data_mosaic_other.F @@ -127,7 +127,18 @@ module module_data_mosaic_other integer, save :: kbiog2_o = -999888777 integer, save :: kbiog3_o = -999888777 integer, save :: kbiog4_o = -999888777 - + integer, save :: kasoaX = -999888777 + integer, save :: kasoa1 = -999888777 + integer, save :: kasoa2 = -999888777 + integer, save :: kasoa3 = -999888777 + integer, save :: kasoa4 = -999888777 + integer, save :: kbsoaX = -999888777 + integer, save :: kbsoa1 = -999888777 + integer, save :: kbsoa2 = -999888777 + integer, save :: kbsoa3 = -999888777 + integer, save :: kbsoa4 = -999888777 + + integer, save :: kgly = -999888777 diff --git a/wrfv2_fire/chem/module_data_mosaic_therm.F b/wrfv2_fire/chem/module_data_mosaic_therm.F index 4324b53f..b643efaf 100644 --- a/wrfv2_fire/chem/module_data_mosaic_therm.F +++ b/wrfv2_fire/chem/module_data_mosaic_therm.F @@ -44,11 +44,19 @@ module module_data_mosaic_therm naer, naercomp, nelectrolyte, nsalt, & nsoluble, ncation, nanion parameter(ngas_ioa = 5) ! inorganic volatile aerosol species that have a gaseous counterpart - parameter(ngas_soa = 68+2+16) ! volatile soa species that have a gaseous counterpart - parameter(ngas_volatile = ngas_ioa + ngas_soa) +! parameter(ngas_soa = 68+2+16) ! volatile soa species that have a gaseous counterpart +! parameter(ngas_volatile = ngas_ioa + ngas_soa) +! parameter(ngas_het = 2) ! gas species only involved in heterogeneous reactions ! DL - 9/9/2011 +! parameter(naer = 11+68+2+16) ! num of chemical species per bin (inorg + oc + bc + oin + soa) +! parameter(naercomp = 26+68+2+16) ! num of electrolytes + oc, bc, oin, & soa +! 10 new VBS species + parameter(ngas_soa = 68+2+16+10) ! volatile soa species that have a gaseous counterpart +! OH and glyoxal at the end + parameter(ngas_volatile = ngas_ioa + ngas_soa + 1 + 1) parameter(ngas_het = 2) ! gas species only involved in heterogeneous reactions ! DL - 9/9/2011 - parameter(naer = 11+68+2+16) ! num of chemical species per bin (inorg + oc + bc + oin + soa) - parameter(naercomp = 26+68+2+16) ! num of electrolytes + oc, bc, oin, & soa +! 5 glyoxal SOA species, 10 VBS species + parameter(naer = 11+68+2+16+5+10) ! num of chemical species per bin (inorg + oc + bc + oin + soa) + 5*glysoa + 10*VBS + parameter(naercomp = 26+68+2+16+5+10) ! num of electrolytes + oc, bc, oin, & soa + 5*glysoa + 10*VBS parameter(nelectrolyte = 22) ! num of electrolytes parameter(nsalt = 15) ! num of soluble salts parameter(nsoluble = 20) ! num of soluble electrolytes @@ -124,11 +132,12 @@ module module_data_mosaic_therm iant4_c_g,ibiog1_c_g,ibiog2_c_g,ibiog3_c_g,ibiog4_c_g, & iant1_o_g,iant2_o_g,iant3_o_g, & iant4_o_g,ibiog1_o_g,ibiog2_o_g,ibiog3_o_g,ibiog4_o_g, & - ismpa_g,ismpbb_g + ismpa_g,ismpbb_g, & + iasoaX_g, iasoa1_g, iasoa2_g, iasoa3_g, iasoa4_g, & + ibsoaX_g, ibsoa1_g, ibsoa2_g, ibsoa3_g, ibsoa4_g, & + igly, iho - - ! aerosol generic integer, save :: & iso4_a, ino3_a, icl_a, inh4_a, ico3_a, & @@ -155,12 +164,13 @@ module module_data_mosaic_therm iopcg3_f_o_a,iopcg4_f_o_a,iopcg5_f_o_a,iopcg6_f_o_a,& iopcg7_f_o_a,iopcg8_f_o_a, & ismpa_a,ismpbb_a, & + iglysoa_r1_a, iglysoa_r2_a, iglysoa_oh_a, iglysoa_sfc_a, iglysoa_nh4_a, & iant1_c_a,iant2_c_a,iant3_c_a, & iant4_c_a,ibiog1_c_a,ibiog2_c_a,ibiog3_c_a,ibiog4_c_a, & iant1_o_a,iant2_o_a,iant3_o_a, & - iant4_o_a,ibiog1_o_a,ibiog2_o_a,ibiog3_o_a,ibiog4_o_a - - + iant4_o_a,ibiog1_o_a,ibiog2_o_a,ibiog3_o_a,ibiog4_o_a, & + iasoaX_a, iasoa1_a,iasoa2_a,iasoa3_a,iasoa4_a,& + ibsoaX_a, ibsoa1_a,ibsoa2_a,ibsoa3_a,ibsoa4_a ! aerosol elecctrolytes/compounds @@ -192,12 +202,13 @@ module module_data_mosaic_therm jopcg3_f_o,jopcg4_f_o,jopcg5_f_o,jopcg6_f_o,& jopcg7_f_o,jopcg8_f_o, & jsmpa,jsmpbb, & + jglysoa_r1, jglysoa_r2, jglysoa_oh, jglysoa_sfc, jglysoa_nh4, & jant1_c,jant2_c,jant3_c, & jant4_c,jbiog1_c,jbiog2_c,jbiog3_c,jbiog4_c, & jant1_o,jant2_o,jant3_o, & - jant4_o,jbiog1_o,jbiog2_o,jbiog3_o,jbiog4_o - - + jant4_o,jbiog1_o,jbiog2_o,jbiog3_o,jbiog4_o, & + jasoaX,jasoa1,jasoa2,jasoa3,jasoa4,& + jbsoaX,jbsoa1,jbsoa2,jbsoa3,jbsoa4 ! aerosol ions @@ -268,6 +279,9 @@ module module_data_mosaic_therm water_a_hyst(nbin_a_maxd), & ! kg(water)/m^3(air) hysteresis (at 60% rh) water_a_up(nbin_a_maxd), & ! kg(water)/m^3(air) at 60% rh ph(nbin_a_maxd), & ! ph + c_as(nbin_a_maxd), & ! ammonium sulfate concentration (mol/kg water) + c_an(nbin_a_maxd), & ! ammonium nitrate concentration (mol/kg water) + a_nh4(nbin_a_maxd), & ! ammonium sulfate activity (mol/kg water) aer(naer,3,nbin_a_maxd), & ! nmol/m^3 aer_sum(3,nbin_a_maxd), & ! nmol/m^3 aer_percent(naer,3,nbin_a_maxd), & ! % @@ -349,6 +363,11 @@ module module_data_mosaic_therm ptol_mol_astem, & ! 0.01 to 1.0 nsteps_astem_avg ! + integer, parameter :: glysoa_param_off = 0, & + glysoa_param_simple = 1, & + glysoa_param_complex = 2 + integer, save :: glysoa_param + !---------------------------------------------------------------------- ! mesa variables integer, save :: & diff --git a/wrfv2_fire/chem/module_data_sorgam_vbs.F b/wrfv2_fire/chem/module_data_sorgam_vbs.F new file mode 100644 index 00000000..88bd0413 --- /dev/null +++ b/wrfv2_fire/chem/module_data_sorgam_vbs.F @@ -0,0 +1,1098 @@ +MODULE module_data_sorgam_vbs +! This module is based on module_data_soa_vbs.F, it has been updated to use +! for the new SOA scheme - SOA_VBS + +! USE module_data_radm2 +! +! param.inc start + IMPLICIT NONE + INTEGER NP !bs maximum expected value of N + PARAMETER (NP = 8) +! integer numaer +! parameter (numaer=50) + + INTEGER MAXITS !bs maximum number of iterations + PARAMETER (MAXITS = 100) + + REAL TOLF !bs convergence criterion on function values + PARAMETER (TOLF = 1.E-09) + + REAL TOLMIN !bs criterion whether superios convergence to + PARAMETER (TOLMIN = 1.E-12) !bs a minimum of fmin has occurred + + REAL TOLX !bs convergence criterion on delta_x + PARAMETER (TOLX = 1.E-10) + + REAL STPMX !bs scaled maximum step length allowed + PARAMETER (STPMX = 100.) + + REAL c303, c302 + PARAMETER (c303=19.83, c302=5417.4) + + INTEGER lcva, lcvb, lspcv, ldesn + PARAMETER (lcva=4,lcvb=4, lspcv=lcva+lcvb) + PARAMETER (ldesn=13) +!mh ldesn is number of deposition species +!mh true number of deposited species may be larger since there +!mh are species which are deposited with the same rate + + INTEGER laerdvc, lnonaerdvc, l1ae, laero, imodes, aspec + PARAMETER (laerdvc=39,lnonaerdvc=8+lspcv) + PARAMETER (l1ae=laerdvc+lnonaerdvc) + PARAMETER (laero=4,imodes=4,aspec=1) +! LAERDVC number of advected aerosol dynamic parameters for a given +! component species +!ia L1AE advected parameters+non-advected parameters +!ia LAERO number of aerosol component species +!ia imodes number of aerosol modes +!ia ASPEC number of gas phase comp. that are added dynamically +!ia currently only sulfate (=1) +!bs +!bs * BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** BS ** +!bs + INTEGER aemiss + PARAMETER (aemiss=4) +!bs * AEMISS # of aerosol species with emissions link to gas phase +!bs currently ECI, ECJ, BCI, BCJ + ! updated ldrog numbers for the new SOA mechanism + INTEGER, PARAMETER :: ldroga=6 ! anthropogenic: ALK4,ALK5,OLE1,OLE2,ARO1,ARO2 + INTEGER, PARAMETER :: ldrogb=3 ! biogenic: ISOP,SESQ,TERP + INTEGER, PARAMETER :: ldrogr=1 ! for branching ratio + INTEGER, PARAMETER :: ldrog_vbs=ldroga+ldrogb+ldrogr ! I've renamed this parameter to separate from "ldrog" for MADE/SORGAM + +! INTEGER ldroga +! PARAMETER (ldroga=11) +! INTEGER ldrogb +! PARAMETER (ldrogb=6) +! INTEGER ldrog +!bs * LDROGA # of anthropogenic organic aerosol precursor gases (DR +!bs * LDROGB # of biogenic organic aerosol precursor gases (DROG) +!bs * LSPCV # of condensable organic vapor interacting between gas +!bs aerosol phase with SORGAM +!bs +! param.inc stop + +! ////////////////////////////////////////////////////////////////////// +! FSB include file + +! *** declare and set flag for organic aerosol production method +! *** Two method are available: + +! *** The method of Pandis,Harley, Cass, and Seinfeld, 1992, +! Secondary aerosol formation and transport, Atmos. Environ., 26A, +! pp 2453-2466 +! Bowman et al. Atmospheric Environment +! Vol 29, pp 579-589, 1995. +! *** and +! *** The method of Odum, Hoffmann, Bowman, Collins, Flagen and +! Seinfeld, 1996, Gas/particle partitioning and secondary organic ae +! yields, Environ. Sci, Technol, 30, pp 2580-2585. + ! 1 = Pandis et al. 1992 method is used + INTEGER orgaer + ! 2 = Pankow 1994/Odum et al. 1996 method is +! *** +! switch for organic aerosol method + PARAMETER (orgaer=2) + +! *** information about visibility variables +! number of visibility variables + INTEGER n_ae_vis_spc + PARAMETER (n_ae_vis_spc=2) + +! index for visual range in deciview + INTEGER idcvw + PARAMETER (idcvw=1) +! index for extinction [ 1/km ] + INTEGER ibext + PARAMETER (ibext=2) + +! *** set up indices for array CBLK + +! index for Accumulation mode sulfate aerosol + INTEGER vso4aj + PARAMETER (vso4aj=1) + +! index for Aitken mode sulfate concentration + INTEGER vso4ai + PARAMETER (vso4ai=2) + +! index for Accumulation mode aerosol ammonium + INTEGER vnh4aj + PARAMETER (vnh4aj=3) + +! index for Aitken mode ammonium concentration + INTEGER vnh4ai + PARAMETER (vnh4ai=4) + +! index for Accumulation mode aerosol nitrate + INTEGER vno3aj + PARAMETER (vno3aj=5) + +! index for Aitken mode nitrate concentration + INTEGER vno3ai + PARAMETER (vno3ai=6) + +! index for Accumulation mode aerosol sodium + INTEGER vnaaj + PARAMETER (vnaaj=7) + +! index for Aitken mode sodium concentration + INTEGER vnaai + PARAMETER (vnaai=8) + +! index for Accumulation mode aerosol chloride + INTEGER vclaj + PARAMETER (vclaj=9) + +! index for Aitken mode chloride concentration + INTEGER vclai + PARAMETER (vclai=10) + +! I've changed the names and simplified +! indices for accumulation and aitken modes of anthropogenic SOA + INTEGER, PARAMETER :: vasoa1j=11 + INTEGER, PARAMETER :: vasoa1i=12 + + INTEGER, PARAMETER :: vasoa2j=13 + INTEGER, PARAMETER :: vasoa2i=14 + + INTEGER, PARAMETER :: vasoa3j=15 + INTEGER, PARAMETER :: vasoa3i=16 + + INTEGER, PARAMETER :: vasoa4j=17 + INTEGER, PARAMETER :: vasoa4i=18 + +! indices for accumulation and aitken modes of biogenic SOA + INTEGER, PARAMETER :: vbsoa1j=19 + INTEGER, PARAMETER :: vbsoa1i=20 + + INTEGER, PARAMETER :: vbsoa2j=21 + INTEGER, PARAMETER :: vbsoa2i=22 + + INTEGER, PARAMETER :: vbsoa3j=23 + INTEGER, PARAMETER :: vbsoa3i=24 + + INTEGER, PARAMETER :: vbsoa4j=25 + INTEGER, PARAMETER :: vbsoa4i=26 +!------------------------------------------------------------------------------ + +! index for Accumulation mode primary anthropogenic + INTEGER vorgpaj + PARAMETER (vorgpaj=27) + +! index for Aitken mode primary anthropogenic + INTEGER vorgpai + PARAMETER (vorgpai=28) + +! index for Accumulation mode aerosol elemen + INTEGER vecj + PARAMETER (vecj=29) + +! index for Aitken mode elemental carbon + INTEGER veci + PARAMETER (veci=30) + +! index for Accumulation mode primary PM2.5 + INTEGER vp25aj + PARAMETER (vp25aj=31) + +! index for Aitken mode primary PM2.5 concentration + INTEGER vp25ai + PARAMETER (vp25ai=32) + +! index for coarse mode anthropogenic aerososol + INTEGER vantha + PARAMETER (vantha=33) + +! index for coarse mode marine aerosol concentration + INTEGER vseas + PARAMETER (vseas=34) + +! index for coarse mode soil-derived aerosol + INTEGER vsoila + PARAMETER (vsoila=35) + +! index for Aitken mode number + INTEGER vnu0 + PARAMETER (vnu0=36) + +! index for accum mode number + INTEGER vac0 + PARAMETER (vac0=37) + +! index for coarse mode number + INTEGER vcorn + PARAMETER (vcorn=38) + +! index for Accumulation mode aerosol water + INTEGER vh2oaj + PARAMETER (vh2oaj=39) + +! index for Aitken mode aerosol water concentration + INTEGER vh2oai + PARAMETER (vh2oai=40) + +! index for Aitken mode 3'rd moment + INTEGER vnu3 + PARAMETER (vnu3=41) + +! index for Accumulation mode 3'rd moment + INTEGER vac3 + PARAMETER (vac3=42) + +! index for coarse mode 3rd moment + INTEGER vcor3 + PARAMETER (vcor3=43) + +! index for sulfuric acid vapor concentration + INTEGER vsulf + PARAMETER (vsulf=44) + +! index for nitric acid vapor concentration + INTEGER vhno3 + PARAMETER (vhno3=45) + +! index for ammonia gas concentration + INTEGER vnh3 + PARAMETER (vnh3=46) + +! index for HCL gas concentration + INTEGER vhcl + PARAMETER (vhcl=47) + +INTEGER, PARAMETER :: vcvasoa1=48 +INTEGER, PARAMETER :: vcvasoa2=49 +INTEGER, PARAMETER :: vcvasoa3=50 +INTEGER, PARAMETER :: vcvasoa4=51 +INTEGER, PARAMETER :: vcvbsoa1=52 +INTEGER, PARAMETER :: vcvbsoa2=53 +INTEGER, PARAMETER :: vcvbsoa3=54 +INTEGER, PARAMETER :: vcvbsoa4=55 +!----------------------------------------------------------------------------- + +! *** set up species dimension and indices for sedimentation +! velocity array VSED + +! number of sedimentation velocities + INTEGER naspcssed + PARAMETER (naspcssed=6) + +! index for Aitken mode number + INTEGER vsnnuc + PARAMETER (vsnnuc=1) + +! index for Accumulation mode number + INTEGER vsnacc + PARAMETER (vsnacc=2) + +! index for coarse mode number + INTEGER vsncor + PARAMETER (vsncor=3) + +! index for Aitken mode mass + INTEGER vsmnuc + PARAMETER (vsmnuc=4) + +! index for accumulation mode mass + INTEGER vsmacc + PARAMETER (vsmacc=5) + +! index for coarse mass + INTEGER vsmcor + PARAMETER (vsmcor=6) + +! *** set up species dimension and indices for deposition +! velocity array VDEP + +! number of deposition velocities + INTEGER naspcsdep + PARAMETER (naspcsdep=7) + +! index for Aitken mode number + INTEGER vdnnuc + PARAMETER (vdnnuc=1) + +! index for accumulation mode number + INTEGER vdnacc + PARAMETER (vdnacc=2) + +! index for coarse mode number + INTEGER vdncor + PARAMETER (vdncor=3) + +! index for Aitken mode mass + INTEGER vdmnuc + PARAMETER (vdmnuc=4) + +! index for accumulation mode + INTEGER vdmacc + PARAMETER (vdmacc=5) + +! index for fine mode mass (Aitken + accumulation) + INTEGER vdmfine + PARAMETER (vdmfine=6) + +! index for coarse mode mass + INTEGER vdmcor + PARAMETER (vdmcor=7) + +! SOA precursors + OH, O3, NO3 +! anthropogenic +INTEGER, PARAMETER :: palk4=1 +INTEGER, PARAMETER :: palk5=2 +INTEGER, PARAMETER :: pole1=3 +INTEGER, PARAMETER :: pole2=4 +INTEGER, PARAMETER :: paro1=5 +INTEGER, PARAMETER :: paro2=6 + +! biogenic +INTEGER, PARAMETER :: pisop=7 +INTEGER, PARAMETER :: pterp=8 +INTEGER, PARAMETER :: psesq=9 + +! for branching +INTEGER, PARAMETER :: pbrch=10 + + ! new indices +INTEGER, PARAMETER :: pasoa1=1 +INTEGER, PARAMETER :: pasoa2=2 +INTEGER, PARAMETER :: pasoa3=3 +INTEGER, PARAMETER :: pasoa4=4 + +INTEGER, PARAMETER :: pbsoa1=5 +INTEGER, PARAMETER :: pbsoa2=6 +INTEGER, PARAMETER :: pbsoa3=7 +INTEGER, PARAMETER :: pbsoa4=8 +!----------------------------------------------- + +!bs +!bs * end of AERO_SOA.EXT * +!bs + +! *** include file for aerosol routines + + +!.................................................................... + +! CONTAINS: Fundamental constants for air quality modeling + +! DEPENDENT UPON: none + +! REVISION HISTORY: + +! Adapted 6/92 by CJC from ROM's PI.EXT. + +! Revised 3/1/93 John McHenry to include constants needed by +! LCM aqueous chemistry +! Revised 9/93 by John McHenry to include additional constants +! needed for FMEM clouds and aqueous chemistry + +! Revised 3/4/96 by Dr. Francis S. Binkowski to reflect current +! Models3 view that MKS units should be used wherever possible, +! and that sources be documentated. Some variables have been added +! names changed, and values revised. + +! Revised 3/7/96 to have universal gas constant input and compute +! gas constant is chemical form. TWOPI is now calculated rather than + +! Revised 3/13/96 to group declarations and parameter statements. + +! Revised 9/13/96 to include more physical constants. +! Revised 12/24/96 eliminate silly EPSILON, AMISS + +! Revised 1/06/97 to eliminate most derived constants +! 10/12/11- Modified to use with soa_vbs, by Ravan Ahmadov + +! Revised 10/08/14-Modified to use with CB05-MADE/VBS, by Kai Wang + +! FSB REFERENCES: + +! CRC76, CRC Handbook of Chemistry and Physics (76th Ed), +! CRC Press, 1995 +! Hobbs, P.V. Basic Physical Chemistry for the Atmospheric Scien +! Cambridge Univ. Press, 206 pp, 1995. +! Snyder, J.P., Map Projections-A Working Manual, U.S. Geological +! Paper 1395 U.S.GPO, Washington, DC, 1987. +! Stull, R. B., An Introduction to Bounday Layer Meteorology, Klu +! Dordrecht, 1988 + +! Geometric Constants: + + REAL*8 & ! PI (single precision 3.141593) + pirs + PARAMETER (pirs=3.14159265358979324) +! REAL PIRS ! PI (single precision 3.141593) +! PARAMETER ( PIRS = 3.141593 ) +! Fundamental Constants: ( Source: CRC76, pp 1-1 to 1-6) + +! Avogadro's Constant [ 1/mol ] + REAL avo + PARAMETER (avo=6.0221367E23) + +! universal gas constant [ J/mol-K ] + REAL rgasuniv + PARAMETER (rgasuniv=8.314510) + +! standard atmosphere [ Pa ] + REAL stdatmpa + PARAMETER (stdatmpa=101325.0) + +! Standard Temperature [ K ] + REAL stdtemp + PARAMETER (stdtemp=273.15) + +! Stefan-Boltzmann [ W/(m**2 K**4) ] + REAL stfblz + PARAMETER (stfblz=5.67051E-8) + + +! mean gravitational acceleration [ m/sec**2 ] + REAL grav + PARAMETER (grav=9.80622) +! FSB Non MKS qualtities: + +! Molar volume at STP [ L/mol ] Non MKS units + REAL molvol + PARAMETER (molvol=22.41410) + + +! Atmospheric Constants: + +! FSB 78.06% N2, 21% O2 and 0.943% A on a mole + REAL mwair + ! fraction basis. ( Source : Hobbs, 1995) pp 69- +! mean molecular weight for dry air [ g/mol ] + PARAMETER (mwair=28.9628) + +! dry-air gas constant [ J / kg-K ] + REAL rdgas + PARAMETER (rdgas=1.0E3*rgasuniv/mwair) + +! 3*PI + REAL threepi + PARAMETER (threepi=3.0*pirs) + +! 6/PI + REAL f6dpi + PARAMETER (f6dpi=6.0/pirs) + +! 1.0e9 * 6/PIRS + REAL f6dpi9 + PARAMETER (f6dpi9=1.0E9*f6dpi) + +! 1.0e-9 * 6/PIRS + REAL f6dpim9 + PARAMETER (f6dpim9=1.0E-9*f6dpi) + +! SQRT( PI ) + REAL sqrtpi + PARAMETER (sqrtpi=1.7724539) + +! SQRT( 2 ) + REAL sqrt2 + PARAMETER (sqrt2=1.4142135623731) + +! ln( sqrt( 2 ) ) + REAL lgsqt2 + PARAMETER (lgsqt2=0.34657359027997) + +! 1/ln( sqrt( 2 ) ) + REAL dlgsqt2 + PARAMETER (dlgsqt2=1.0/lgsqt2) + +! 1/3 + REAL one3 + PARAMETER (one3=1.0/3.0) + +! 2/3 + REAL two3 + PARAMETER (two3=2.0/3.0) + + +! *** physical constants: + +! Boltzmann's Constant [ J / K ] + REAL boltz + PARAMETER (boltz=rgasuniv/avo) + + +! *** component densities [ kg/m**3 ] : + + +! bulk density of aerosol sulfate + REAL rhoso4 + PARAMETER (rhoso4=1.8E3) + +! bulk density of aerosol ammonium + REAL rhonh4 + PARAMETER (rhonh4=1.8E3) + +! bulk density of aerosol nitrate + REAL rhono3 + PARAMETER (rhono3=1.8E3) + +! bulk density of aerosol water + REAL rhoh2o + PARAMETER (rhoh2o=1.0E3) + +! bulk density for aerosol organics + REAL rhoorg + PARAMETER (rhoorg=1.0E3) + +! bulk density for aerosol soil dust + REAL rhosoil + PARAMETER (rhosoil=2.6E3) + +! bulk density for marine aerosol + REAL rhoseas + PARAMETER (rhoseas=2.2E3) + +! bulk density for anthropogenic aerosol + REAL rhoanth + PARAMETER (rhoanth=2.2E3) + +! bulk density of aerosol sodium + REAL rhona + PARAMETER (rhona=2.2E3) + +! bulk density of aerosol chloride + REAL rhocl + PARAMETER (rhocl=2.2E3) + +! *** Factors for converting aerosol mass concentration [ ug m**-3] to +! to 3rd moment concentration [ m**3 m^-3] + + REAL so4fac + PARAMETER (so4fac=f6dpim9/rhoso4) + + REAL nh4fac + PARAMETER (nh4fac=f6dpim9/rhonh4) + + REAL h2ofac + PARAMETER (h2ofac=f6dpim9/rhoh2o) + + REAL no3fac + PARAMETER (no3fac=f6dpim9/rhono3) + + REAL orgfac + PARAMETER (orgfac=f6dpim9/rhoorg) + + REAL soilfac + PARAMETER (soilfac=f6dpim9/rhosoil) + + REAL seasfac + PARAMETER (seasfac=f6dpim9/rhoseas) + + REAL anthfac + PARAMETER (anthfac=f6dpim9/rhoanth) + + REAL nafac + PARAMETER (nafac=f6dpim9/rhona) + + REAL clfac + PARAMETER (clfac=f6dpim9/rhocl) + +! starting standard surface pressure [ Pa ] + REAL pss0 + PARAMETER (pss0=101325.0) + +! starting standard surface temperature [ K ] + REAL tss0 + PARAMETER (tss0=288.15) + +! initial sigma-G for nucleimode + REAL sginin + PARAMETER (sginin=1.70) + +! initial sigma-G for accumulation mode + REAL sginia + PARAMETER (sginia=2.00) + +! initial sigma-G for coarse mode + REAL sginic + PARAMETER (sginic=2.5) + +! initial mean diameter for nuclei mode [ m ] + REAL dginin + PARAMETER (dginin=0.01E-6) + +! initial mean diameter for accumulation mode [ m ] + REAL dginia + PARAMETER (dginia=0.07E-6) + +! initial mean diameter for coarse mode [ m ] + REAL dginic + PARAMETER (dginic=1.0E-6) + +!................ end AERO3box.EXT ............................... +!/////////////////////////////////////////////////////////////////////// + +! LOGICAL diagnostics +! *** Scalar variables for fixed standard deviations. + +! Flag for writing diagnostics to file +! nuclei mode exp( log^2( sigmag )/8 ) + REAL en1 +! accumulation mode exp( log^2( sigmag ) + REAL ea1 + + REAL ec1 +! coarse mode exp( log^2( sigmag )/8 ) +! nuclei **4 + REAL esn04 +! accumulation + REAL esa04 + + REAL esc04 +! coarse +! nuclei **5 + REAL esn05 + + REAL esa05 +! accumulation +! nuclei **8 + REAL esn08 +! accumulation + REAL esa08 + + REAL esc08 +! coarse +! nuclei **9 + REAL esn09 + + REAL esa09 +! accumulation +! nuclei **12 + REAL esn12 +! accumulation + REAL esa12 + + REAL esc12 +! coarse mode +! nuclei **16 + REAL esn16 +! accumulation + REAL esa16 + + REAL esc16 +! coarse +! nuclei **20 + REAL esn20 +! accumulation + REAL esa20 + + REAL esc20 +! coarse +! nuclei **25 + REAL esn25 + + REAL esa25 +! accumulation +! nuclei **24 + REAL esn24 +! accumulation + REAL esa24 + + REAL esc24 +! coarse +! nuclei **28 + REAL esn28 +! accumulation + REAL esa28 + + REAL esc28 +! coarse +! nuclei **32 + REAL esn32 +! accumulation + REAL esa32 + + REAL esc32 +! coarese +! nuclei **36 + REAL esn36 +! accumulation + REAL esa36 + + REAL esc36 +! coarse +! nuclei **49 + REAL esn49 + + REAL esa49 +! accumulation +! nuclei **52 + REAL esn52 + + REAL esa52 +! accumulation +! nuclei **64 + REAL esn64 +! accumulation + REAL esa64 + + REAL esc64 +! coarse + + REAL esn100 +! nuclei **100 +! nuclei **(-20) + REAL esnm20 +! accumulation + REAL esam20 + + REAL escm20 +! coarse +! nuclei **(-32) + REAL esnm32 +! accumulation + REAL esam32 + + REAL escm32 +! coarse +! log(sginin) + REAL xxlsgn +! log(sginia) + REAL xxlsga + + REAL xxlsgc +! log(sginic ) +! log(sginin ) ** 2 + REAL l2sginin +! log(sginia ) ** 2 + REAL l2sginia + + REAL l2sginic + +! *** set up COMMON blocks for esg's: + +! log(sginic ) ** 2 + +! *** SET NUCLEATION FLAG: + + ! INUCL = 0, Kerminen & Wexler Mechanism + INTEGER inucl + ! INUCL = 1, Youngblood and Kreidenweis mech + ! INUCL = 2, Kulmala et al. mechanism +! Flag for Choice of nucleation Mechanism + PARAMETER (inucl=2) + +! *** Set flag for sedimentation velocities: + + LOGICAL icoarse + PARAMETER (icoarse=.FALSE.) ! *** END AERO_INTERNAL.EXT +! *** Diameters and standard deviations for emissions +! the diameters are the volume (mass) geometric mean diameters + +! *** Aitken mode: +! special factor to compute mass transfer + REAL dgvem_i + PARAMETER (dgvem_i=0.03E-6) ! [ m ] + REAL sgem_i + PARAMETER (sgem_i=1.7) + +! *** Accumulation mode: + REAL dgvem_j + PARAMETER (dgvem_j=0.3E-6) ! [ m ] + REAL sgem_j + PARAMETER (sgem_j=2.0) + +! *** Coarse mode + REAL dgvem_c + PARAMETER (dgvem_c=6.0E-6) ! [ m ] <<< Corrected 11/19/97 + REAL sgem_c + PARAMETER (sgem_c=2.2) + +! *** factors for getting number emissions rate from mass emissions rate +! Aitken mode + REAL factnumn +! accumulation mode + REAL factnuma + + REAL factnumc +! coarse mode + REAL facatkn_min, facacc_min + PARAMETER (facatkn_min=0.04,facacc_min=1.0-facatkn_min) + REAL xxm3 + REAL, PARAMETER :: conmin = 1.E-16 + REAL, PARAMETER :: epsilc = 1.E-16 +! [ ug/m**3 ] ! changed 1/6/98 + REAL*8 & ! factor to set minimum for Aitken mode number + nummin_i + REAL*8 & ! factor to set minimum for accumulation mode nu + nummin_j + REAL*8 & + nummin_c +! factor to set minimum for coarse mode number +!bs +!bs REAL ALPHSULF ! Accommodation coefficient for sulfuric acid +!bs PARAMETER ( ALPHSULF = 0.05 ) ! my be set to one in future +!bs +!bs REAL DIFFSULF ! molecular diffusivity for sulfuric acid [ m**2 +!bs PARAMETER( DIFFSULF = 0.08E-4 ) ! may be changed in future +!bs +!bs * 23/03/99 updates of ALPHSULF and DIFFSULF adopted fro new code fro +!bs * DIFFSULF is calculated from Reid, Prausnitz, and Poling, The prope +!bs * of gases and liquids, 4th edition, McGraw-Hill, 1987, pp 587-588. +!bs * Equation (11-4.4) was used. +!bs * The value is at T = 273.16 K and P = 1.01325E05 Pa +!bs * Temperature dependence is included for DIFFSULF via DIFFCORR (see +!bs +! Accommodation coefficient for sulfuric + REAL alphsulf + PARAMETER (alphsulf=1.0) +!bs updated from code of FSB +! molecular weight for sulfuric acid [ kg/mole ] MKS + REAL mwh2so4 + PARAMETER (mwh2so4=98.07354E-3) +!cia corrected error 24/11/97 +! molecular diffusivity for sulfuric acid [ m**2 /se + REAL diffsulf + PARAMETER (diffsulf=9.362223E-06) +!bs updated from code of FSB +!bs Accomodation coefficient for organic + REAL alphaorg + PARAMETER (alphaorg=1.0) !bs Kleeman et al. '99 propose alpha +!bs Bowman et al. '97 uses alpha = 1. +!bs mean molecular weight of organics [k + REAL mworg + PARAMETER (mworg=175.0E-03) +!bs +!bs * DIFFORG is calculated from the same formula as DIFFSULF. +!bs * An average elemental composition of C=8, O=3, N=1, H=17 is asuumed +!bs * to calculate DIFFORG at T = 273.16K and P = 1.01325E05 Pa. +!bs * Temperature dependence is included below. +!bs molecular diffusivity for organics [ + REAL difforg + PARAMETER (difforg=5.151174E-06) +! *** CCONC is the factor for near-continuum condensation. +! ccofm * sqrt( ta ) + REAL cconc + PARAMETER (cconc=2.0*pirs*diffsulf) +!bs * factor for NC condensation for organics +! [ m**2 / sec ] + REAL cconc_org + PARAMETER (cconc_org=2.0*pirs*difforg) +! [ m**2 / sec ] +!bs analogue to CCOFM but for organics + REAL ccofm_org +! FSB CCOFM is the accommodation coefficient +! times the mean molecular velocity for h2so4 without the temperatu +! after some algebra + +!bs CCOFM_ORG * sqrt(TA) +! set to a value below + REAL ccofm +! minimum aerosol sulfate concentration + REAL aeroconcmin + PARAMETER (aeroconcmin=0.0001) + +!******************************************************************* +!* * +!* start parameters and variables for aerosol-cloud interactions * +!* * +!******************************************************************* +! +! maxd_atype = maximum allowable number of aerosol types +! maxd_asize = maximum allowable number of aerosol size bins +! maxd_acomp = maximum allowable number of chemical components +! in each aerosol size bin +! maxd_aphase = maximum allowable number of aerosol phases (gas, cloud, ice, rain, ...) +! +! ntype_aer = number of aerosol types +! nsize_aer(t) = number of aerosol size bins for aerosol type t. each bin w/ same set of components +! nphase_aer = number of aerosol phases +! +! msectional - if positive, moving-center sectional code is utilized, +! and each mode is actually a section. +! maerosolincw - if positive, both unactivated/interstitial and activated +! aerosol species are simulated. if zero/negative, only the +! unactivated are simulated. +! +! ncomp_aer(t) = number of chemical components for aerosol type t +! ncomp_aer_nontracer(t) = number of "non-tracer" chemical components while in gchm code +! mastercompptr_aer(c,t) = mastercomp type/i.d. for chemical component c +! (1=sulfate, others to be defined) and aerosol type t. +! massptr_aer(c,s,t,p) = gchm r-array index for the mixing ratio +! (moles-x/mole-air) for chemical component c in size bin s for type t and phase p +! +! waterptr_aer(s,t) = mixing ratio (moles-water/mole-air) for water +! associated with aerosol size bin s and type t +! hygroptr_aer(s,t) = gchm r-array index for the bulk hygroscopicity of the size bin and type +! numptr_aer(s,t,p) = gchm r-array index for the number mixing ratio +! (particles/mole-air) for aerosol size bin s, type t, and phase p +! If zero or negative, then number is not being simulated. +! +! mprognum_aer(s,t,p) - if positive, number mixing-ratio for size s, type t, +! and phase p will be prognosed. Otherwise, no. +! +! ntot_mastercomp_aer = number of aerosol chemical components defined +! dens_mastercomp_aer(mc) = dry density (g/cm^3) of aerosol master chemical component type c +! mw_mastercomp_aer(mc) = molecular weight of aerosol master chemical component type mc +! name_mastercomp_aer(mc) = name of aerosol master chemical component type mc +! mc=mastercompptr_aer(c,t) +! dens_aer(c,t) = dry density (g/cm^3) of aerosol chemical component type c and type t +! mw_aer(c,t) = molecular weight of aerosol chemical component type c and type t +! name_aer(c,t) = name of aerosol chemical component type c and type t +! +! lptr_so4_aer(s,t,p) = gchm r-array index for the +! mixing ratio for sulfate associated with aerosol size bin s, type t, and phase p +! (similar for msa, oc, bc, nacl, dust) +! +!----------------------------------------------------------------------- +! +! volumcen_sect(s,t)= volume (cm^3) at center of section m +! volumlo_sect(s,t) = volume (cm^3) at lower boundary of section m +! volumhi_sect(s,t) = volume (cm^3) at upper boundary of section m +! +! dlo_sect(s,t) = diameter (cm) at lower boundary of section m +! dhi_sect(s,t) = diameter (cm) at upper boundary of section m +! dcen_sect(s,t) = volume arithmetic-mean diameter (cm) of section m +! (corresponds to volumcen_sect == 0.5*(volumlo_sect + volumhi_sect) +! +!----------------------------------------------------------------------- +! nov-04 sg ! replaced amode with aer and expanded aerosol dimension to include type and phase + + integer, parameter :: maxd_atype = 2 + integer, parameter :: maxd_asize = 2 + integer, parameter :: maxd_acomp = 19 + integer, parameter :: maxd_aphase = 2 + integer, save :: ai_phase ! interstitial phase of aerosol + integer, save :: cw_phase ! cloud water phase of aerosol + integer, save :: ci_phase ! cloud ice phase of aerosol + integer, save :: cr_phase ! rain phase of aerosol + integer, save :: cs_phase ! snow phase of aerosol + integer, save :: cg_phase ! graupel phase of aerosol + + integer, save :: ntype_aer = 0 ! number of types + integer, save :: ntot_mastercomp_aer = 0 ! number of master components + integer, save :: nphase_aer = 0 ! number of phases + + integer, save :: & + msectional, maerosolincw, & + nsize_aer( maxd_atype ), & ! number of size bins + ncomp_aer( maxd_atype ), & ! number of chemical components + ncomp_aer_nontracer( maxd_atype ), & + mastercompptr_aer(maxd_acomp, maxd_atype), & ! mastercomp index + massptr_aer( maxd_acomp, maxd_asize, maxd_atype, maxd_aphase ), & ! index for mixing ratio + waterptr_aer( maxd_asize, maxd_atype ), & ! index for aerosol water + hygroptr_aer( maxd_asize, maxd_atype ), & ! index for aerosol hygroscopicity + numptr_aer( maxd_asize, maxd_atype, maxd_aphase ), & ! index for the number mixing ratio + mprognum_aer(maxd_asize,maxd_atype,maxd_aphase) + + real, save :: & + dens_aer( maxd_acomp, maxd_atype ), & + dens_mastercomp_aer( maxd_acomp ), & + mw_mastercomp_aer( maxd_acomp ), & + mw_aer( maxd_acomp, maxd_atype ), & + hygro_mastercomp_aer( maxd_acomp ), & + hygro_aer( maxd_acomp, maxd_atype ) + character*10, save :: & + name_mastercomp_aer( maxd_acomp ), & + name_aer( maxd_acomp, maxd_atype ) + + real, save :: & + volumcen_sect( maxd_asize, maxd_atype ), & + volumlo_sect( maxd_asize, maxd_atype ), & + volumhi_sect( maxd_asize, maxd_atype ), & + dcen_sect( maxd_asize, maxd_atype ), & + dlo_sect( maxd_asize, maxd_atype ), & + dhi_sect( maxd_asize, maxd_atype ), & + sigmag_aer(maxd_asize, maxd_atype) + + integer, save :: & + lptr_so4_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_nh4_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_no3_aer(maxd_asize,maxd_atype,maxd_aphase), & + + lptr_asoa1_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_asoa2_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_asoa3_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_asoa4_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_bsoa1_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_bsoa2_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_bsoa3_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_bsoa4_aer(maxd_asize,maxd_atype,maxd_aphase), & + +! lptr_orgaro1_aer(maxd_asize,maxd_atype,maxd_aphase), & +! lptr_orgaro2_aer(maxd_asize,maxd_atype,maxd_aphase), & +! lptr_orgalk_aer(maxd_asize,maxd_atype,maxd_aphase), & +! lptr_orgole_aer(maxd_asize,maxd_atype,maxd_aphase), & +! lptr_orgba1_aer(maxd_asize,maxd_atype,maxd_aphase), & +! lptr_orgba2_aer(maxd_asize,maxd_atype,maxd_aphase), & +! lptr_orgba3_aer(maxd_asize,maxd_atype,maxd_aphase), & +! lptr_orgba4_aer(maxd_asize,maxd_atype,maxd_aphase), & + + lptr_orgpa_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_ec_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_p25_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_anth_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_cl_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_na_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_seas_aer(maxd_asize,maxd_atype,maxd_aphase), & + lptr_soil_aer(maxd_asize,maxd_atype,maxd_aphase) + + logical, save :: & + do_cloudchem_aer(maxd_asize,maxd_atype) + + +! molecular weights (g/mol) + real, parameter :: mw_so4_aer = 96.066 + real, parameter :: mw_no3_aer = 62.007 + real, parameter :: mw_nh4_aer = 18.042 + real, parameter :: mw_oc_aer = 250.0 + real, parameter :: mw_ec_aer = 1.0 + real, parameter :: mw_oin_aer = 1.0 + real, parameter :: mw_dust_aer = 100.087 + real, parameter :: mw_seas_aer = 58.440 + real, parameter :: mw_cl_aer = 35.450 + real, parameter :: mw_na_aer = 22.990 + real, parameter :: mw_water_aer = 18.016 + +! dry densities (g/cm3) + real, parameter :: dens_so4_aer = 1.80 ! = rhoso4 + real, parameter :: dens_no3_aer = 1.80 ! = rhono3 + real, parameter :: dens_nh4_aer = 1.80 ! = rhonh4 + real, parameter :: dens_oc_aer = 1.5 ! = rhoorg ! changed from 1.0 + real, parameter :: dens_ec_aer = 1.70 + real, parameter :: dens_dust_aer = 2.60 ! = rhosoil + real, parameter :: dens_oin_aer = 2.20 ! = rhoanth + real, parameter :: dens_seas_aer = 2.20 ! = rhoseas + real, parameter :: dens_cl_aer = 2.20 + real, parameter :: dens_na_aer = 2.20 + +! water density (g/cm3) + real, parameter :: dens_water_aer = 1.0 + +! hygroscopicity (dimensionless) + real, parameter :: hygro_so4_aer = 0.5 + real, parameter :: hygro_no3_aer = 0.5 + real, parameter :: hygro_nh4_aer = 0.5 + real, parameter :: hygro_oc_aer = 0.14 + real, parameter :: hygro_ec_aer = 1.e-6 + real, parameter :: hygro_oin_aer = 0.14 + real, parameter :: hygro_dust_aer = 0.1 + real, parameter :: hygro_seas_aer = 1.16 + real, parameter :: hygro_cl_aer = 1.16 + real, parameter :: hygro_na_aer = 1.16 + +! table lookup of aerosol impaction/interception scavenging rates + real dlndg_nimptblgrow + integer nimptblgrow_mind, nimptblgrow_maxd + parameter (nimptblgrow_mind=-14, nimptblgrow_maxd=24) + real scavimptblnum(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype), & + scavimptblvol(4, nimptblgrow_mind:nimptblgrow_maxd, maxd_asize, maxd_atype) + +!SAM 10/08 Gaussian quadrature constants for SOA_VBS deposition numerical integration + INTEGER NGAUSdv + PARAMETER( NGAUSdv = 7 ) ! Number of Gaussian Quadrature Points - constants defined in aerosols_sorgam_init + REAL Y_GQ(NGAUSdv), WGAUS(NGAUSdv) + +!***************************************************************** +!* * +!* end parameters and variables for aerosol-cloud interactions * +!* * +!***************************************************************** + + +END Module module_data_sorgam_vbs diff --git a/wrfv2_fire/chem/module_dep_simple.F b/wrfv2_fire/chem/module_dep_simple.F index 0af69ffd..45fd3d67 100755 --- a/wrfv2_fire/chem/module_dep_simple.F +++ b/wrfv2_fire/chem/module_dep_simple.F @@ -167,7 +167,8 @@ SUBROUTINE wesely_driver( id, ktau, dtstep, config_flags, current_month, & if( config_flags%chem_opt /= MOZART_KPP .and. & config_flags%chem_opt /= MOZCART_KPP .and. & - config_flags%chem_opt /= MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt /= MOZART_MOSAIC_4BIN_KPP .and. & + config_flags%chem_opt /= MOZART_MOSAIC_4BIN_AQ_KPP) then if( julday < 90 .or. julday > 270 ) then iseason = 2 CALL wrf_debug(15,'setting iseason to 2') @@ -188,7 +189,8 @@ SUBROUTINE wesely_driver( id, ktau, dtstep, config_flags, current_month, & if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then if( snowh(i,j) < .01 ) then iseason = seasonal_pft(id)%seasonal_wes(i,j,iland,current_month) else @@ -234,7 +236,8 @@ SUBROUTINE wesely_driver( id, ktau, dtstep, config_flags, current_month, & iprt, moist(i,kts,j,p_qv), p8w(i,kts,j), config_flags%chem_opt ) if( config_flags%chem_opt /= MOZART_KPP .and. & config_flags%chem_opt /= MOZCART_KPP .and. & - config_flags%chem_opt /= MOZART_MOSAIC_4BIN_VBS0_KPP) then + config_flags%chem_opt /= MOZART_MOSAIC_4BIN_KPP .and. & + config_flags%chem_opt /= MOZART_MOSAIC_4BIN_AQ_KPP) then srfres(1:numgas-2) = rcx(1:numgas-2) srfres(numgas-1:numgas) = 0. else @@ -270,7 +273,6 @@ SUBROUTINE wesely_driver( id, ktau, dtstep, config_flags, current_month, & (config_flags%chem_opt == CBMZ_BB ) .or. & (config_flags%chem_opt == CBMZ_BB_KPP ) .or. & (config_flags%chem_opt == CBMZ_MOSAIC_KPP ) .or. & - (config_flags%chem_opt == CBMZ_MOSAIC_4BIN_VBS2_KPP).or.& (config_flags%chem_opt == CBMZ_MOSAIC_4BIN_AQ) .or. & (config_flags%chem_opt == CBMZ_MOSAIC_8BIN_AQ) .or. & (config_flags%chem_opt == CBMZ_MOSAIC_4BIN) .or. & @@ -392,7 +394,6 @@ SUBROUTINE wesely_driver( id, ktau, dtstep, config_flags, current_month, & ! For gocartracm,radm !----------------------------------------------------------- if ((config_flags%chem_opt == GOCARTRACM_KPP) .OR. & - (config_flags%chem_opt == GOCARTRADM2_KPP) .OR. & (config_flags%chem_opt == GOCARTRADM2)) then do j=jts,jte do i=its,ite @@ -422,7 +423,8 @@ SUBROUTINE wesely_driver( id, ktau, dtstep, config_flags, current_month, & !----------------------------------------------------------- if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then do j=jts,jte do i=its,ite ddvel(i,j,p_mpan) = ddvel(i,j,p_mpan)/3. @@ -445,7 +447,8 @@ SUBROUTINE wesely_driver( id, ktau, dtstep, config_flags, current_month, & ddvel(i,j,p_c3h6) = 0. ddvel(i,j,p_c3h8) = 0. ddvel(i,j,p_aco3) = 0. - ddvel(i,j,p_gly) = 0. + ddvel(i,j,p_gly) = 0.2 / 100. ! from Washenfelder et al., 2011 + ddvel(i,j,p_mgly) = 0. ! ddvel(i,j,p_macr) = 0. ddvel(i,j,p_mek) = 0. ddvel(i,j,p_eto2) = 0. @@ -471,12 +474,46 @@ SUBROUTINE wesely_driver( id, ktau, dtstep, config_flags, current_month, & ddvel(i,j,p_meko2) = 0. ! ddvel(i,j,p_sulf) = 0. ddvel(i,j,p_dms) = 0. - if ( config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then - ddvel(i,j,p_voca) = 0. - ddvel(i,j,p_vocbb) = 0. - ddvel(i,j,p_smpa) = 0 - ddvel(i,j,p_smpbb) = 0 - end if + IF ( config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .OR. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) THEN + ddvel(i,j,p_benzene) = 0. + ddvel(i,j,p_phen) = 0. + ddvel(i,j,p_bepomuc) = 0. + ddvel(i,j,p_benzo2) = 0. + ddvel(i,j,p_pheno2) = 0. + ddvel(i,j,p_pheno) = 0. + ddvel(i,j,p_phenooh) = ddvel(i,j,p_h2o2) + ddvel(i,j,p_c6h5o2) = 0. + ddvel(i,j,p_c6h5ooh) = ddvel(i,j,p_h2o2) + ddvel(i,j,p_benzooh) = ddvel(i,j,p_h2o2) + ddvel(i,j,p_bigald1) = 0. + ddvel(i,j,p_bigald2) = 0. + ddvel(i,j,p_bigald3) = 0. + ddvel(i,j,p_bigald4) = 0. + ddvel(i,j,p_malo2) = 0. + ddvel(i,j,p_pbznit) = 0. + ddvel(i,j,p_tepomuc) = 0. + ddvel(i,j,p_bzoo) = 0. + ddvel(i,j,p_bzooh) = ddvel(i,j,p_h2o2) + ddvel(i,j,p_bald) = 0. + ddvel(i,j,p_acbzo2) = 0. + ddvel(i,j,p_dicarbo2) = 0. + ddvel(i,j,p_mdialo2) = 0. + ddvel(i,j,p_xyl) = 0. + ddvel(i,j,p_xylol) = 0. + ddvel(i,j,p_xylolo2) = 0. + ddvel(i,j,p_xylolooh) = ddvel(i,j,p_h2o2) + ddvel(i,j,p_xyleno2) = 0. + ddvel(i,j,p_xylenooh) = ddvel(i,j,p_h2o2) + + IF ( config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP) THEN + ddvel(i,j,p_voca) = 0. + ddvel(i,j,p_vocbb) = 0. + ddvel(i,j,p_smpa) = 0. + ddvel(i,j,p_smpbb) = 0. + ENDIF + + ENDIF end do if ( config_flags%chem_opt == MOZCART_KPP ) then ddvel(its:ite,j,p_sulf) = 0. @@ -615,6 +652,165 @@ SUBROUTINE wesely_driver( id, ktau, dtstep, config_flags, current_month, & end do end if +!----------------------------------------------------------- +! For cb05 +!----------------------------------------------------------- +! +! For the additional CB05 species, assign similar RADM counter parts for +! now. Short lived species get a zero velocity since dry dep should be +! unimportant. **ALSO**, treat p_sulf as h2so4 vapor, not aerosol sulfate +! + if ( (config_flags%chem_opt == CB05_SORG_AQ_KPP) ) then + do j=jts,jte + do i=its,ite + ddvel(i,j,p_sulf) = ddvel(i,j,p_hno3) + ddvel(i,j,p_hcl) = ddvel(i,j,p_hno3) + ddvel(i,j,p_meo2) = 0. + ddvel(i,j,p_meoh) = ddvel(i,j,p_form) + ddvel(i,j,p_etoh) = ddvel(i,j,p_form) + ddvel(i,j,p_to2) = 0. + ddvel(i,j,p_cro) = 0. + ddvel(i,j,p_open) = ddvel(i,j,p_xyl) + ddvel(i,j,p_c2o3) = 0. + ddvel(i,j,p_xo2n) = 0. + ddvel(i,j,p_xo2) = 0. + ddvel(i,j,p_ispd) = 0. + ddvel(i,j,p_o1d) = 0. + ddvel(i,j,p_o) = 0. + ddvel(i,j,p_terp) = ddvel(i,j,p_isop) + ddvel(i,j,p_terpaer) = ddvel(i,j,p_isop) + ddvel(i,j,p_hum) = ddvel(i,j,p_isop) + ddvel(i,j,p_humaer) = ddvel(i,j,p_isop) + ddvel(i,j,p_lim) = ddvel(i,j,p_isop) + ddvel(i,j,p_limaer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_limaer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_oci) = ddvel(i,j,p_isop) + ddvel(i,j,p_ociaer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_ociaer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_apin) = ddvel(i,j,p_isop) + ddvel(i,j,p_apinaer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_apinaer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_apinaer3) = ddvel(i,j,p_isop) + ddvel(i,j,p_apinaer4) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpin) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpinaer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpinaer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpinaer3) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpinaer4) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpinaer5) = ddvel(i,j,p_isop) + ddvel(i,j,p_ter) = ddvel(i,j,p_isop) + ddvel(i,j,p_teraer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_teraer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_tolaer1) = ddvel(i,j,p_tol) + ddvel(i,j,p_tolaer2) = ddvel(i,j,p_tol) + ddvel(i,j,p_cslaer) = ddvel(i,j,p_cres) + ddvel(i,j,p_xylaer1) = ddvel(i,j,p_xyl) + ddvel(i,j,p_xylaer2) = ddvel(i,j,p_xyl) + ddvel(i,j,p_isoaer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_isoaer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_sulaer) = ddvel(i,j,p_hno3) + ddvel(i,j,p_panx) = ddvel(i,j,p_pan) + ddvel(i,j,p_hco3) = 0. + ddvel(i,j,p_ror) = 0. + ddvel(i,j,p_alkh) = ddvel(i,j,p_par) + ddvel(i,j,p_alkhaer1) = ddvel(i,j,p_par) + ddvel(i,j,p_pah) = 0. + ddvel(i,j,p_pahaer1) = 0. + ddvel(i,j,p_pahaer2) = 0. + ddvel(i,j,p_cl2) = 0. + ddvel(i,j,p_cl) = 0. + ddvel(i,j,p_hocl) = 0. + ddvel(i,j,p_clo) = 0. + ddvel(i,j,p_fmcl) = 0. + if (ivgtyp(i,j).eq.iswater_temp) then + ddvel(i,j,p_hg0) = 0.00e-2 + else + ddvel(i,j,p_hg0) = 0.01e-2 + end if + ddvel(i,j,p_hg2) = 0.50e-2 + end do + end do + else if ( (config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP) ) then + do j=jts,jte + do i=its,ite + ddvel(i,j,p_sulf) = ddvel(i,j,p_hno3) + ddvel(i,j,p_hcl) = ddvel(i,j,p_hno3) + ddvel(i,j,p_meo2) = 0. + ddvel(i,j,p_meoh) = ddvel(i,j,p_form) + ddvel(i,j,p_etoh) = ddvel(i,j,p_form) + ddvel(i,j,p_to2) = 0. + ddvel(i,j,p_cro) = 0. + ddvel(i,j,p_open) = ddvel(i,j,p_xyl) + ddvel(i,j,p_c2o3) = 0. + ddvel(i,j,p_xo2n) = 0. + ddvel(i,j,p_xo2) = 0. + ddvel(i,j,p_ispd) = 0. + ddvel(i,j,p_o1d) = 0. + ddvel(i,j,p_o) = 0. + ddvel(i,j,p_terp) = ddvel(i,j,p_isop) + ddvel(i,j,p_terpaer) = ddvel(i,j,p_isop) + ddvel(i,j,p_hum) = ddvel(i,j,p_isop) + ddvel(i,j,p_humaer) = ddvel(i,j,p_isop) + ddvel(i,j,p_lim) = ddvel(i,j,p_isop) + ddvel(i,j,p_limaer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_limaer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_oci) = ddvel(i,j,p_isop) + ddvel(i,j,p_ociaer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_ociaer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_apin) = ddvel(i,j,p_isop) + ddvel(i,j,p_apinaer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_apinaer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_apinaer3) = ddvel(i,j,p_isop) + ddvel(i,j,p_apinaer4) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpin) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpinaer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpinaer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpinaer3) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpinaer4) = ddvel(i,j,p_isop) + ddvel(i,j,p_bpinaer5) = ddvel(i,j,p_isop) + ddvel(i,j,p_ter) = ddvel(i,j,p_isop) + ddvel(i,j,p_teraer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_teraer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_tolaer1) = ddvel(i,j,p_tol) + ddvel(i,j,p_tolaer2) = ddvel(i,j,p_tol) + ddvel(i,j,p_cslaer) = ddvel(i,j,p_cres) + ddvel(i,j,p_xylaer1) = ddvel(i,j,p_xyl) + ddvel(i,j,p_xylaer2) = ddvel(i,j,p_xyl) + ddvel(i,j,p_isoaer1) = ddvel(i,j,p_isop) + ddvel(i,j,p_isoaer2) = ddvel(i,j,p_isop) + ddvel(i,j,p_sulaer) = ddvel(i,j,p_hno3) + ddvel(i,j,p_panx) = ddvel(i,j,p_pan) + ddvel(i,j,p_hco3) = 0. + ddvel(i,j,p_ror) = 0. + ddvel(i,j,p_alkh) = ddvel(i,j,p_par) + ddvel(i,j,p_alkhaer1) = ddvel(i,j,p_par) + ddvel(i,j,p_pah) = 0. + ddvel(i,j,p_pahaer1) = 0. + ddvel(i,j,p_pahaer2) = 0. + ddvel(i,j,p_cl2) = 0. + ddvel(i,j,p_cl) = 0. + ddvel(i,j,p_hocl) = 0. + ddvel(i,j,p_clo) = 0. + ddvel(i,j,p_fmcl) = 0. + if (ivgtyp(i,j).eq.iswater_temp) then + ddvel(i,j,p_hg0) = 0.00e-2 + else + ddvel(i,j,p_hg0) = 0.01e-2 + end if + ddvel(i,j,p_hg2) = 0.50e-2 + ddvel(i,j,p_cvasoa1) = ddvel(i,j,p_hno3) + ddvel(i,j,p_cvasoa2) = ddvel(i,j,p_hno3) + ddvel(i,j,p_cvasoa3) = ddvel(i,j,p_hno3) + ddvel(i,j,p_cvasoa4) = ddvel(i,j,p_hno3) + + ddvel(i,j,p_cvbsoa1) = ddvel(i,j,p_hno3) + ddvel(i,j,p_cvbsoa2) = ddvel(i,j,p_hno3) + ddvel(i,j,p_cvbsoa3) = ddvel(i,j,p_hno3) + ddvel(i,j,p_cvbsoa4) = ddvel(i,j,p_hno3) + end do + end do + end if + END SUBROUTINE wesely_driver @@ -704,7 +900,10 @@ SUBROUTINE rc( rcx, t, rad, rh, iland, & !---------------------------------------------------------------------- ! SPECIAL TREATMENT FOR HNO3, HNO4, H2O2, PAA !---------------------------------------------------------------------- -is_mozart : if( chem_opt == MOZART_KPP .or. chem_opt == MOZCART_KPP ) then +is_mozart : if( chem_opt == MOZART_KPP .or. & + chem_opt == MOZCART_KPP .or. & + chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then if( n == p_hno3 ) then hstary(n) = 2.6e6*exp( 8700.*wrk )*1.e5 else if( n == p_hno4 ) then @@ -717,7 +916,10 @@ SUBROUTINE rc( rcx, t, rad, rh, iland, & endif is_mozart rmx = 1./(hstary(n)/3000. + 100.*f0(n)) rsmx = rs*dratio(n) + rmx - if( (chem_opt == MOZART_KPP .or. chem_opt == MOZCART_KPP .or. chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) .and. & + if( (chem_opt == MOZART_KPP .or. & + chem_opt == MOZCART_KPP .or. & + chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) .and. & iseason /= 4 .and. p_pan > 1 ) then if( iland /= iswater_temp .and. n == p_pan ) then !------------------------------------------------------------------------------------- @@ -1403,7 +1605,10 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & include 'netcdf.inc' #else - if( config_flags%chem_opt == MOZART_KPP .or. config_flags%chem_opt == MOZCART_KPP .or. config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + if( config_flags%chem_opt == MOZART_KPP .or. & + config_flags%chem_opt == MOZCART_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then call wrf_message( 'dep_init: mozart,mozcart chem option requires netcdf' ) call wrf_abort end if @@ -1688,7 +1893,7 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & if( allocated (luse2usgs) ) deallocate (luse2usgs) allocate( luse2usgs(config_flags%num_land_cat),stat=astat ) if( astat /= 0 ) then - CALL wrf_message( 'ftuv_init: failed to allocate luse2usgs array' ) + CALL wrf_message( 'dep_init: failed to allocate luse2usgs array' ) CALL wrf_abort end if if( trim(mminlu_loc) == 'USGS' ) then @@ -1708,10 +1913,13 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & !-------------------------------------------------- is_cbm4_kpp : & - if (config_flags%chem_opt /= CBM4_KPP) then + if (config_flags%chem_opt /= CBM4_KPP .or. & + config_flags%chem_opt /= CB05_SORG_AQ_KPP .or. & + config_flags%chem_opt /= CB05_SORG_VBS_AQ_KPP) then if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then hstar(p_o3) = 1.15E-2 hstar(p_co) = 1.e-3 hstar(p_h2o2) = 8.33E+4 @@ -1737,6 +1945,23 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & hstar(p_mekooh) = 311. hstar(p_tolooh) = 311. hstar(p_terpooh) = 311. + + if( config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then + hstar(p_sulf) = 2.600E+06 + end if + if ( config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then + hstar(p_cvasoaX) = 0.0 + hstar(p_cvasoa1) = 1.06E+08 + hstar(p_cvasoa2) = 1.84E+07 + hstar(p_cvasoa3) = 3.18E+06 + hstar(p_cvasoa4) = 5.50E+05 + hstar(p_cvbsoaX) = 0.0 + hstar(p_cvbsoa1) = 5.25E+09 + hstar(p_cvbsoa2) = 7.00E+08 + hstar(p_cvbsoa3) = 9.33E+07 + hstar(p_cvbsoa4) = 1.24E+07 + endif else if( config_flags%chem_opt == crimech_kpp .or. & config_flags%chem_opt == cri_mosaic_8bin_aq_kpp .or. & @@ -1956,7 +2181,8 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & !-------------------------------------------------- if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then dhr(p_o3) = 2560. dhr(p_h2o2) = 7379. dhr(p_hcho) = 6425. @@ -1981,7 +2207,25 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & dhr(p_mekooh) = 5241. dhr(p_tolooh) = 5241. dhr(p_terpooh) = 5241. - + + if( config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then + dhr(p_sulf) = 0.000E+00 + end if + + if (config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then + dhr(p_cvasoaX) = 0. + dhr(p_cvasoa1) = 6014. + dhr(p_cvasoa2) = 6014. + dhr(p_cvasoa3) = 6014. + dhr(p_cvasoa4) = 6014. + dhr(p_cvbsoaX) = 0. + dhr(p_cvbsoa1) = 6014. + dhr(p_cvbsoa2) = 6014. + dhr(p_cvbsoa3) = 6014. + dhr(p_cvbsoa4) = 6014. + endif + else if( config_flags%chem_opt == crimech_kpp .or. & config_flags%chem_opt == cri_mosaic_8bin_aq_kpp .or. & config_flags%chem_opt == cri_mosaic_4bin_aq_kpp ) then @@ -2155,7 +2399,8 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & !-------------------------------------------------- if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then f0(p_hcho) = small_value f0(p_ch3ooh) = .1 f0(p_ch3oh) = small_value @@ -2177,6 +2422,24 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & f0(p_tolooh) = .1 f0(p_terpooh) = .1 + if( config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then + f0(p_sulf) = 0. + end if + + if (config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then + f0(p_cvasoaX) = 0. + f0(p_cvasoa1) = 0. + f0(p_cvasoa2) = 0. + f0(p_cvasoa3) = 0. + f0(p_cvasoa4) = 0. + f0(p_cvbsoaX) = 0. + f0(p_cvbsoa1) = 0. + f0(p_cvbsoa2) = 0. + f0(p_cvbsoa3) = 0. + f0(p_cvbsoa4) = 0. + endif + else if( config_flags%chem_opt == crimech_kpp .or. & config_flags%chem_opt == cri_mosaic_8bin_aq_kpp .or. & config_flags%chem_opt == cri_mosaic_4bin_aq_kpp ) then @@ -2349,7 +2612,8 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & !-------------------------------------------------- if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then dvj(p_o3) = 0.144 dvj(p_h2o2) = 0.1715 dvj(p_hcho) = 0.1825 @@ -2374,6 +2638,24 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & dvj(p_tolooh) = 0.084 dvj(p_terpooh) = 0.073 + if( config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then + dvj(p_sulf) = 1.200E-01 + end if + + if (config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then + dvj(p_cvasoaX) = 0.120 ! ?? + dvj(p_cvasoa1) = 0.120 ! ?? + dvj(p_cvasoa2) = 0.120 ! ?? + dvj(p_cvasoa3) = 0.120 ! ?? + dvj(p_cvasoa4) = 0.120 ! ?? + dvj(p_cvbsoaX) = 0.120 ! ?? + dvj(p_cvbsoa1) = 0.120 ! ?? + dvj(p_cvbsoa2) = 0.120 ! ?? + dvj(p_cvbsoa3) = 0.120 ! ?? + dvj(p_cvbsoa4) = 0.120 ! ?? + endif + else if( config_flags%chem_opt == crimech_kpp .or. & config_flags%chem_opt == cri_mosaic_8bin_aq_kpp .or. & config_flags%chem_opt == cri_mosaic_4bin_aq_kpp ) then @@ -3097,6 +3379,307 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & scpr23(l) = (sc/0.72)**(2./3.) ! (Schmidt # / Prandtl #)** END DO +! start of addition + else if ( (config_flags%chem_opt == CB05_SORG_AQ_KPP) ) then + + hstar(p_no2) = 6.40E-3 + hstar(p_no) = 1.90E-3 + hstar(p_pan) = 2.97E+0 + hstar(p_o3) = 1.13E-2 + hstar(p_form) = 2.97E+3 + hstar(p_cxo3) = 1.14E+1 + hstar(p_hono) = 3.47E+5 + hstar(p_no3) = 1.50E+1 + hstar(p_pna) = 2.00E+13 + hstar(p_h2o2) = 7.45E+4 + hstar(p_co) = 8.20E-3 + hstar(p_ald2) = 1.14E+1 + hstar(p_aldx) = 1.14E+1 + hstar(p_mepx) = 2.21E+2 + hstar(p_rooh) = 1.68E+6 + hstar(p_pacd) = 4.73E+2 + hstar(p_mgly) = 3.71E+3 + hstar(p_ntr) = 1.13E+0 + hstar(p_so2) = 2.53E+5 + hstar(p_etha) = 2.00E-3 + hstar(p_ole) = 4.76E-3 + hstar(p_iole) = 1.35E-3 + hstar(p_tol) = 1.51E-1 + hstar(p_cres) = 4.00E+5 + hstar(p_xyl) = 1.45E-1 + hstar(p_isop) = 4.76E-3 + hstar(p_hno3) = 2.69E+13 + hstar(p_facd) = 9.85E+6 + hstar(p_aacd) = 9.63E+5 + hstar(p_nh3) = 1.04E+4 + hstar(p_n2o5) = 1.00E+10 + hstar(p_eth) = 4.67E-3 + hstar(p_par) = 1.13E-3 !wig, 1-May-2007: for CB05 + + dhr(p_no2) = 2500. + dhr(p_no) = 1480. + dhr(p_pan) = 5760. + dhr(p_o3) = 2300. + dhr(p_form) = 7190. + dhr(p_cxo3) = 6266. + dhr(p_hono) = 3775. + dhr(p_no3) = 0. + dhr(p_pna) = 0. + dhr(p_h2o2) = 6615. + dhr(p_co) = 0. + dhr(p_ald2) = 6266. + dhr(p_aldx) = 6266. + dhr(p_mepx) = 5607. + dhr(p_rooh) = 10240. + dhr(p_pacd) = 6170. + dhr(p_mgly) = 7541. + dhr(p_ntr) = 5487. + dhr(p_so2) = 5816. + dhr(p_etha) = 0. + dhr(p_ole) = 0. + dhr(p_iole) = 0. + dhr(p_tol) = 0. + dhr(p_cres) = 0. + dhr(p_xyl) = 0. + dhr(p_isop) = 0. + dhr(p_hno3) = 8684. + dhr(p_facd) = 5716. + dhr(p_aacd) = 8374. + dhr(p_nh3) = 3660. + dhr(p_n2o5) = 0. + dhr(p_eth) = 0. + dhr(p_par) = 0. !wig, 1-May-2007: for CB05 + + f0(p_no2) = 0.1 + f0(p_no) = 0. + f0(p_pan) = 0.1 + f0(p_o3) = 1. + f0(p_form) = 0. + f0(p_cxo3) = 1. + f0(p_hono) = 0.1 + f0(p_no3) = 1. + f0(p_pna) = 0.1 + f0(p_h2o2) = 1. + f0(p_co) = 0. + f0(p_ald2) = 0. + f0(p_aldx) = 0. + f0(p_mepx) = 0.1 + f0(p_rooh) = 0.1 + f0(p_pacd) = 0.1 + f0(p_mgly) = 0. + f0(p_ntr) = 0. + f0(p_so2) = 0. + f0(p_etha) = 0. + f0(p_ole) = 0. + f0(p_iole) = 0. + f0(p_tol) = 0. + f0(p_cres) = 0. + f0(p_xyl) = 0. + f0(p_isop) = 0. + f0(p_hno3) = 0. + f0(p_facd) = 0. + f0(p_aacd) = 0. + f0(p_nh3) = 0. + f0(p_n2o5) = 1. + f0(p_eth) = 0. + f0(p_par) = 0. !wig, 1-May-2007: for CB05 + dvj(p_no2) = 0.147 + dvj(p_no) = 0.183 + dvj(p_pan) = 0.091 + dvj(p_o3) = 0.175 + dvj(p_form) = 0.183 + dvj(p_cxo3) = 0.115 + dvj(p_hono) = 0.153 + dvj(p_no3) = 0.127 + dvj(p_pna) = 0.113 + dvj(p_h2o2) = 0.171 + dvj(p_co) = 0.189 + dvj(p_ald2) = 0.151 + dvj(p_aldx) = 0.151 + dvj(p_mepx) = 0.144 + dvj(p_rooh) = 0.127 + dvj(p_pacd) = 0.115 + dvj(p_mgly) = 0.118 + dvj(p_ntr) = 0.092 + dvj(p_so2) = 0.126 + dvj(p_etha) = 0.183 + dvj(p_ole) = 0.154 + dvj(p_iole) = 0.121 + dvj(p_tol) = 0.104 + dvj(p_cres) = 0.096 + dvj(p_xyl) = 0.097 + dvj(p_isop) = 0.121 + dvj(p_hno3) = 0.126 + dvj(p_facd) = 0.153 + dvj(p_aacd) = 0.124 + dvj(p_nh3) = 0.227 + dvj(p_n2o5) = 0.110 + dvj(p_ho) = 0.243 + dvj(p_ho2) = 0.174 + dvj(p_eth) = 0.189 + dvj(p_par) = 0.118 !wig, 1-May-2007: for CB05 + + DO l = 1, numgas + hstar4(l) = hstar(l) ! preliminary +! Correction of diff. coeff + dvj(l) = dvj(l)*(293.15/298.15)**1.75 + sc = 0.15/dvj(l) ! Schmidt Number at 20degC + dratio(l) = 0.242/dvj(l) ! ! of water vapor and gas at +! Ratio of diffusion coeffi + scpr23(l) = (sc/0.72)**(2./3.) ! (Schmidt # / Prandtl #)** + END DO + + else if ( (config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP) ) then + + hstar(p_no2) = 6.40E-3 + hstar(p_no) = 1.90E-3 + hstar(p_pan) = 2.97E+0 + hstar(p_o3) = 1.13E-2 + hstar(p_form) = 2.97E+3 + hstar(p_cxo3) = 1.14E+1 + hstar(p_hono) = 3.47E+5 + hstar(p_no3) = 1.50E+1 + hstar(p_pna) = 2.00E+13 + hstar(p_h2o2) = 7.45E+4 + hstar(p_co) = 8.20E-3 + hstar(p_ald2) = 1.14E+1 + hstar(p_aldx) = 1.14E+1 + hstar(p_mepx) = 2.21E+2 + hstar(p_rooh) = 1.68E+6 + hstar(p_pacd) = 4.73E+2 + hstar(p_mgly) = 3.71E+3 + hstar(p_ntr) = 1.13E+0 + hstar(p_so2) = 2.53E+5 + hstar(p_etha) = 2.00E-3 + hstar(p_ole) = 4.76E-3 + hstar(p_iole) = 1.35E-3 + hstar(p_tol) = 1.51E-1 + hstar(p_cres) = 4.00E+5 + hstar(p_xyl) = 1.45E-1 + hstar(p_isop) = 4.76E-3 + hstar(p_hno3) = 2.69E+13 + hstar(p_facd) = 9.85E+6 + hstar(p_aacd) = 9.63E+5 + hstar(p_nh3) = 1.04E+4 + hstar(p_n2o5) = 1.00E+10 + hstar(p_eth) = 4.67E-3 + hstar(p_par) = 1.13E-3 !wig, 1-May-2007: for CB05 + + dhr(p_no2) = 2500. + dhr(p_no) = 1480. + dhr(p_pan) = 5760. + dhr(p_o3) = 2300. + dhr(p_form) = 7190. + dhr(p_cxo3) = 6266. + dhr(p_hono) = 3775. + dhr(p_no3) = 0. + dhr(p_pna) = 0. + dhr(p_h2o2) = 6615. + dhr(p_co) = 0. + dhr(p_ald2) = 6266. + dhr(p_aldx) = 6266. + dhr(p_mepx) = 5607. + dhr(p_rooh) = 10240. + dhr(p_pacd) = 6170. + dhr(p_mgly) = 7541. + dhr(p_ntr) = 5487. + dhr(p_so2) = 5816. + dhr(p_etha) = 0. + dhr(p_ole) = 0. + dhr(p_iole) = 0. + dhr(p_tol) = 0. + dhr(p_cres) = 0. + dhr(p_xyl) = 0. + dhr(p_isop) = 0. + dhr(p_hno3) = 8684. + dhr(p_facd) = 5716. + dhr(p_aacd) = 8374. + dhr(p_nh3) = 3660. + dhr(p_n2o5) = 0. + dhr(p_eth) = 0. + dhr(p_par) = 0. !wig, 1-May-2007: for CB05 + + f0(p_no2) = 0.1 + f0(p_no) = 0. + f0(p_pan) = 0.1 + f0(p_o3) = 1. + f0(p_form) = 0. + f0(p_cxo3) = 1. + f0(p_hono) = 0.1 + f0(p_no3) = 1. + f0(p_pna) = 0.1 + f0(p_h2o2) = 1. + f0(p_co) = 0. + f0(p_ald2) = 0. + f0(p_aldx) = 0. + f0(p_mepx) = 0.1 + f0(p_rooh) = 0.1 + f0(p_pacd) = 0.1 + f0(p_mgly) = 0. + f0(p_ntr) = 0. + f0(p_so2) = 0. + f0(p_etha) = 0. + f0(p_ole) = 0. + f0(p_iole) = 0. + f0(p_tol) = 0. + f0(p_cres) = 0. + f0(p_xyl) = 0. + f0(p_isop) = 0. + f0(p_hno3) = 0. + f0(p_facd) = 0. + f0(p_aacd) = 0. + f0(p_nh3) = 0. + f0(p_n2o5) = 1. + f0(p_eth) = 0. + f0(p_par) = 0. !wig, 1-May-2007: for CB05 + dvj(p_no2) = 0.147 + dvj(p_no) = 0.183 + dvj(p_pan) = 0.091 + dvj(p_o3) = 0.175 + dvj(p_form) = 0.183 + dvj(p_cxo3) = 0.115 + dvj(p_hono) = 0.153 + dvj(p_no3) = 0.127 + dvj(p_pna) = 0.113 + dvj(p_h2o2) = 0.171 + dvj(p_co) = 0.189 + dvj(p_ald2) = 0.151 + dvj(p_aldx) = 0.151 + dvj(p_mepx) = 0.144 + dvj(p_rooh) = 0.127 + dvj(p_pacd) = 0.115 + dvj(p_mgly) = 0.118 + dvj(p_ntr) = 0.092 + dvj(p_so2) = 0.126 + dvj(p_etha) = 0.183 + dvj(p_ole) = 0.154 + dvj(p_iole) = 0.121 + dvj(p_tol) = 0.104 + dvj(p_cres) = 0.096 + dvj(p_xyl) = 0.097 + dvj(p_isop) = 0.121 + dvj(p_hno3) = 0.126 + dvj(p_facd) = 0.153 + dvj(p_aacd) = 0.124 + dvj(p_nh3) = 0.227 + dvj(p_n2o5) = 0.110 + dvj(p_ho) = 0.243 + dvj(p_ho2) = 0.174 + dvj(p_eth) = 0.189 + dvj(p_par) = 0.118 !wig, 1-May-2007: for CB05 + + DO l = 1, numgas + hstar4(l) = hstar(l) ! preliminary +! Correction of diff. coeff + dvj(l) = dvj(l)*(293.15/298.15)**1.75 + sc = 0.15/dvj(l) ! Schmidt Number at 20degC + dratio(l) = 0.242/dvj(l) ! ! of water vapor and gas at +! Ratio of diffusion coeffi + scpr23(l) = (sc/0.72)**(2./3.) ! (Schmidt # / Prandtl #)** + END DO + +! end of addition + else is_cbm4_kpp hstar(p_no2) = 6.40E-3 @@ -3400,7 +3983,8 @@ SUBROUTINE dep_init( id, config_flags, numgas, mminlu_loc, & is_mozart : & if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then !--------------------------------------------------------------------- ! ... allocate column_density type !--------------------------------------------------------------------- diff --git a/wrfv2_fire/chem/module_emissions_anthropogenics.F b/wrfv2_fire/chem/module_emissions_anthropogenics.F index f17799a9..deb81f8c 100755 --- a/wrfv2_fire/chem/module_emissions_anthropogenics.F +++ b/wrfv2_fire/chem/module_emissions_anthropogenics.F @@ -116,7 +116,8 @@ subroutine add_anthropogenics(id,dtstep,dz8w,config_flags,rho_phy,alt, & +emis_ant(i,k,j,p_e_nh3)*conv_rho if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then conv_rho_aer = alt(i,k,j)*dtstep/dz8w(i,k,j) chem(i,k,j,p_bigalk) = chem(i,k,j,p_bigalk) + emis_ant(i,k,j,p_e_bigalk)*conv_rho chem(i,k,j,p_bigene) = chem(i,k,j,p_bigene) + emis_ant(i,k,j,p_e_bigene)*conv_rho @@ -129,8 +130,19 @@ subroutine add_anthropogenics(id,dtstep,dz8w,config_flags,rho_phy,alt, & chem(i,k,j,p_ald) = chem(i,k,j,p_ald) + emis_ant(i,k,j,p_e_ch3cho)*conv_rho chem(i,k,j,p_acet) = chem(i,k,j,p_acet) + emis_ant(i,k,j,p_e_ch3coch3)*conv_rho chem(i,k,j,p_ch3oh) = chem(i,k,j,p_ch3oh) + emis_ant(i,k,j,p_e_ch3oh)*conv_rho + chem(i,k,j,p_gly) = chem(i,k,j,p_gly) + emis_ant(i,k,j,p_e_gly)*conv_rho + chem(i,k,j,p_macr) = chem(i,k,j,p_macr) + emis_ant(i,k,j,p_e_macr)*conv_rho + chem(i,k,j,p_mgly) = chem(i,k,j,p_mgly) + emis_ant(i,k,j,p_e_mgly)*conv_rho + chem(i,k,j,p_mvk) = chem(i,k,j,p_mvk) + emis_ant(i,k,j,p_e_mvk)*conv_rho + chem(i,k,j,p_c2h2) = chem(i,k,j,p_c2h2) + emis_ant(i,k,j,p_e_c2h2)*conv_rho + chem(i,k,j,p_hcooh) = chem(i,k,j,p_hcooh) + emis_ant(i,k,j,p_e_hcooh)*conv_rho chem(i,k,j,p_mek) = chem(i,k,j,p_mek) + emis_ant(i,k,j,p_e_mek)*conv_rho chem(i,k,j,p_tol) = chem(i,k,j,p_tol) + emis_ant(i,k,j,p_e_toluene)*conv_rho + chem(i,k,j,p_benzene) = chem(i,k,j,p_benzene) + emis_ant(i,k,j,p_e_benzene)*conv_rho + chem(i,k,j,p_xyl) = chem(i,k,j,p_xyl) + emis_ant(i,k,j,p_e_xylene)*conv_rho + chem(i,k,j,p_cres) = chem(i,k,j,p_cres) + emis_ant(i,k,j,p_e_cres)*conv_rho + chem(i,k,j,p_bald) = chem(i,k,j,p_bald) + emis_ant(i,k,j,p_e_bald)*conv_rho + chem(i,k,j,p_hono) = chem(i,k,j,p_hono) +emis_ant(i,k,j,p_e_hono)*conv_rho chem(i,k,j,p_isopr) = chem(i,k,j,p_isopr) + emis_ant(i,k,j,p_e_isop)*conv_rho chem(i,k,j,p_c10h16) = chem(i,k,j,p_c10h16) + emis_ant(i,k,j,p_e_c10h16)*conv_rho chem(i,k,j,p_sulf) = chem(i,k,j,p_sulf) + conv_rho_aer*emis_ant(i,k,j,p_e_sulf)*mwdry/mw_so4_aer*1.e-3 @@ -139,14 +151,14 @@ subroutine add_anthropogenics(id,dtstep,dz8w,config_flags,rho_phy,alt, & chem(i,k,j,p_p25) = chem(i,k,j,p_p25) + conv_rho_aer*emis_ant(i,k,j,p_e_pm_25) chem(i,k,j,p_oc1) = chem(i,k,j,p_oc1) + conv_rho_aer*emis_ant(i,k,j,p_e_oc) chem(i,k,j,p_bc1) = chem(i,k,j,p_bc1) + conv_rho_aer*emis_ant(i,k,j,p_e_bc) - elseif( config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then -! 20130730 acd_ck_bugfix start + elseif( config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP ) then ! emissions should be CO_A and CO_BB with yields instead of VOC_A and VOC_BB ! chem(i,k,j,p_voca) = chem(i,k,j,p_voca) + conv_rho*emis_ant(i,k,j,p_e_voca) ! chem(i,k,j,p_vocbb) = chem(i,k,j,p_vocbb) + conv_rho*emis_ant(i,k,j,p_e_vocbb) - chem(i,k,j,p_voca) = chem(i,k,j,p_voca) + conv_rho_aer*emis_ant(i,k,j,p_e_co_a)*0.04*28./250. - chem(i,k,j,p_vocbb) = chem(i,k,j,p_vocbb) + conv_rho_aer*emis_ant(i,k,j,p_e_co_bb)*0.04*28./250. -! 20130730 acd_ck_bugfix end +! chem(i,k,j,p_voca) = chem(i,k,j,p_voca) + conv_rho_aer*emis_ant(i,k,j,p_e_co_a)*0.04*28./250. +! chem(i,k,j,p_vocbb) = chem(i,k,j,p_vocbb) + conv_rho_aer*emis_ant(i,k,j,p_e_co_bb)*0.04*28./250. + chem(i,k,j,p_voca) = chem(i,k,j,p_voca) + conv_rho*emis_ant(i,k,j,p_e_co_a)*0.04*28./250. + chem(i,k,j,p_vocbb) = chem(i,k,j,p_vocbb) + conv_rho*emis_ant(i,k,j,p_e_co_bb)*0.04*28./250. endif else if( config_flags%chem_opt == CRIMECH_KPP & .or. config_flags%chem_opt == CRI_MOSAIC_8BIN_AQ_KPP & @@ -197,6 +209,8 @@ subroutine add_anthropogenics(id,dtstep,dz8w,config_flags,rho_phy,alt, & +emis_ant(i,k,j,p_e_hc8)*conv_rho chem(i,k,j,p_eth) = chem(i,k,j,p_eth) & +emis_ant(i,k,j,p_e_eth)*conv_rho + if(p_ch4.gt.1)chem(i,k,j,p_ch4) = chem(i,k,j,p_ch4) & + +emis_ant(i,k,j,p_e_ch4)*conv_rho if(p_ol2.gt.1)chem(i,k,j,p_ol2) = chem(i,k,j,p_ol2) & +emis_ant(i,k,j,p_e_ol2)*conv_rho if(p_ete.gt.1)chem(i,k,j,p_ete) = chem(i,k,j,p_ete) & @@ -212,8 +226,7 @@ subroutine add_anthropogenics(id,dtstep,dz8w,config_flags,rho_phy,alt, & chem(i,k,j,p_ket) = chem(i,k,j,p_ket) & +emis_ant(i,k,j,p_e_ket)*conv_rho if( config_flags%chem_opt == GOCARTRACM_KPP & - .or. config_flags%chem_opt == GOCARTRADM2 & - .or. config_flags%chem_opt == GOCARTRADM2_KPP) then + .or. config_flags%chem_opt == GOCARTRADM2 ) then conv_rho_aer = alt(i,k,j)*dtstep/dz8w(i,k,j) chem(i,k,j,p_p10) = chem(i,k,j,p_p10) + conv_rho_aer*emis_ant(i,k,j,p_e_pm_10) chem(i,k,j,p_p25) = chem(i,k,j,p_p25) + conv_rho_aer*emis_ant(i,k,j,p_e_pm_25) diff --git a/wrfv2_fire/chem/module_ftuv_driver.F b/wrfv2_fire/chem/module_ftuv_driver.F index 2f9440d6..2e8df984 100644 --- a/wrfv2_fire/chem/module_ftuv_driver.F +++ b/wrfv2_fire/chem/module_ftuv_driver.F @@ -116,6 +116,11 @@ module module_ftuv_driver integer, private, parameter :: pid_hyac = 29 integer, private, parameter :: pid_glyald= 30 +! added for CB05CL +! These numbers are referred to from module_wave_data.F (sjref(ii,XX)) + integer, private, parameter :: pid_cl2 = 56 + integer, private, parameter :: pid_hocl = 57 + integer, private, parameter :: pid_fmcl = 58 contains @@ -135,7 +140,9 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & ph_pooh,ph_rooh,ph_xooh,ph_isopooh, & ph_alkooh,ph_mekooh,ph_tolooh, & ph_terpooh,ph_n2o5,ph_mvk,ph_glyald, & - ph_hyac, ivgtyp, & + ph_hyac, & + ph_cl2,ph_hocl,ph_fmcl, & + ivgtyp, & ph_radfld, ph_adjcoe, ph_prate, & wc_x, zref_x, & tauaer1, tauaer2, tauaer3, tauaer4, & !rajesh @@ -207,7 +214,8 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & ph_bigald, ph_mek, ph_c2h5ooh, ph_c3h7ooh,& ph_pooh,ph_rooh,ph_xooh,ph_isopooh, & ph_alkooh,ph_mekooh,ph_tolooh,ph_terpooh, & - ph_n2o5,ph_mvk,ph_glyald,ph_hyac + ph_n2o5,ph_mvk,ph_glyald,ph_hyac, & + ph_cl2,ph_hocl,ph_fmcl real, dimension( ims:ime, nref, jms:jme, nw-1 ), & intent(out ) :: ph_radfld @@ -271,7 +279,8 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & !---------------------------------------------------- if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then p_jtop(its:ite,jts:jte) = Pa2hPa * p_phy(its:ite,kte,jts:jte) call p_interp( o2_exo_col, o3_exo_col, p_jtop, & id, its, ite, jts, jte ) @@ -283,13 +292,12 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & isorg=0 aer_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2SORG,RADM2SORG_KPP,RACMSORG_KPP,RADM2SORG_AQCHEM,RACM_ESRLSORG_KPP,RACMSORG_AQ,RACMSORG_AQCHEM_KPP, & - RACM_ESRLSORG_AQCHEM_KPP,CBMZSORG,CBMZSORG_AQ) + RACM_ESRLSORG_AQCHEM_KPP,CBMZSORG,CBMZSORG_AQ, & + CB05_SORG_AQ_KPP,CB05_SORG_VBS_AQ_KPP) isorg=1 CALL wrf_debug(15,'SORGAM aerosols initialization ') -! 20130128 acd_ck_bugfix start - CASE (MOZART_MOSAIC_4BIN_VBS0_KPP) - CALL wrf_debug(15,'MOZART_MOSAIC_4BIN_VBS0_KPP aerosols initialization ') -! 20130128 acd_ck_bugfix end + CASE (MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP) + CALL wrf_debug(15,'MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP aerosols initialization ') CASE DEFAULT CALL wrf_debug(15,'no aerosols initialization yet') CALL wrf_message('no aerosols initialization yet') @@ -317,7 +325,8 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & !---------------------------------------------------- if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then !++alma 2012-12-01 modis landuse from sw ! if( ivgtyp(i,j) /= 16 ) then @@ -334,7 +343,8 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then o3top = o3_exo_col(i,j) o2top = o2_exo_col(i,j) endif @@ -402,11 +412,21 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & acb1(kp1) = chem(i,k,j,p_ecj) ! acb2(kp1) = 0.0_dp ! aoc1(kp1) = chem(i,k,j,p_orgpaj) + chem(i,k,j,p_orgbaj) + chem(i,k,j,p_orgaj) + + if(config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP) then + aoc1(kp1) = chem(i,k,j,p_orgpaj)+chem(i,k,j,p_asoa1j)+chem(i,k,j,p_asoa2j) & + + chem(i,k,j,p_asoa3j)+chem(i,k,j,p_asoa4j) & + + chem(i,k,j,p_bsoa1j)+chem(i,k,j,p_bsoa2j) & + + chem(i,k,j,p_bsoa3j)+chem(i,k,j,p_bsoa4j) + else aoc1(kp1) = chem(i,k,j,p_orgpaj) -! aoc2(kp1) = 0.0_dp + endif +! aoc1(kp1) = chem(i,k,j,p_orgpaj) +! aoc2(kp1) = 0.0_dp aant(kp1) = chem(i,k,j,p_no3aj) + chem(i,k,j,p_nh4aj) aso4(kp1) = chem(i,k,j,p_so4aj) - asal(kp1) = chem(i,k,j,p_seas) +! asal(kp1) = chem(i,k,j,p_seas) + asal(kp1) = chem(i,k,j,p_seas) + chem(i,k,j,p_naaj) + chem(i,k,j,p_claj) elseif( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP ) then aso4(kp1) = chem(i,k,j,p_sulf)*air(kp1)*real(mw_so4_aer,kind=dp)*kg_per_amu*1.e-9_dp @@ -543,6 +563,11 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & ph_onit(i,k,j) = max( 0._dp,prate(k,pid_onit)*m2s ) ph_macr(i,k,j) = max( 0._dp,prate(k,pid_macr) *m2s ) ph_ch3coc2h5(i,k,j) = max( 0._dp,prate(k,23)*m2s ) + ph_cl2(i,k,j) = max( 0._dp,prate(k,pid_cl2)*m2s ) + ph_hocl(i,k,j) = max( 0._dp,prate(k,pid_hocl)*m2s ) + ph_fmcl(i,k,j) = max( 0._dp,prate(k,pid_fmcl)*m2s ) + ph_pan(i,k,j) = max( 0._dp,prate(k,pid_pan)*m2s ) + ph_n2o5(i,k,j) = max( 0._dp,prate(k,pid_n2o5)*m2s ) enddo do m = 1,nw-1 @@ -563,7 +588,8 @@ subroutine ftuv_driver( id, curr_secs, dtstep, config_flags, & if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then do k = kts, kte ph_n2o(i,k,j) = max( 0._dp,prate(k,pid_n2o)*m2s ) ph_n2o5(i,k,j) = max( 0._dp,prate(k,pid_n2o5)*m2s ) @@ -596,7 +622,9 @@ subroutine ftuv_init( id,ips, ipe, jps, jpe, kte, & ! ... new initialization routine for ftuv !--------------------------------------------------------------------- - use module_state_description, only : mozart_kpp, mozcart_kpp, mozart_mosaic_4bin_vbs0_kpp + use module_state_description, only : mozart_kpp, mozcart_kpp, & + mozart_mosaic_4bin_kpp,& + mozart_mosaic_4bin_aq_kpp use module_ftuv_subs, only : aer_init use module_configure, only : grid_config_rec_type @@ -643,8 +671,9 @@ subroutine ftuv_init( id,ips, ipe, jps, jpe, kte, & #else if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then - call wrf_message( 'ftuv_init: mozart,mozcart requires netcdf' ) + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then + call wrf_message( 'ftuv_init: mozart,mozcart,mozart_mosaic_* chem option requires netcdf' ) call wrf_abort end if #endif @@ -661,7 +690,8 @@ subroutine ftuv_init( id,ips, ipe, jps, jpe, kte, & is_mozart : & if( config_flags%chem_opt == MOZART_KPP .or. & config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then !--------------------------------------------------------------------- ! ... allocate column_density type !--------------------------------------------------------------------- @@ -807,9 +837,7 @@ subroutine ftuv_init( id,ips, ipe, jps, jpe, kte, & !++alma 2012-12-01 modis landuse from sw ! if( id == 1 ) then -! 20130807 acd_mbela_bugfix start if( id == 1 .and. .not. allocated(luse2usgs) ) then -! 20130807 acd_mbela_bugfix end !allocate( luse2usgs(config_flags%num_land_cat),stat=astat ) print*,"num_land_cat: ", num_land_cat allocate( luse2usgs(num_land_cat),stat=astat ) @@ -871,7 +899,9 @@ subroutine photo_inti( chem_opt, nlev, ztopin ) use module_wave_data, only : nw, wl, wave_data_inti use module_ftuv_subs, only : nwint, wlint, schu_inti, inter_inti - use module_state_description, only : mozart_kpp, mozcart_kpp, mozart_mosaic_4bin_vbs0_kpp + use module_state_description, only : mozart_kpp, mozcart_kpp, & + mozart_mosaic_4bin_kpp,& + mozart_mosaic_4bin_aq_kpp implicit none @@ -890,7 +920,8 @@ subroutine photo_inti( chem_opt, nlev, ztopin ) if( chem_opt /= MOZART_KPP .and. & chem_opt /= MOZCART_KPP .and. & - chem_opt /= MOZART_MOSAIC_4BIN_VBS0_KPP ) then + chem_opt /= MOZART_MOSAIC_4BIN_KPP .and. & + chem_opt /= MOZART_MOSAIC_4BIN_AQ_KPP ) then !--------------------------------------------------------------------- ! change unit from m to km !--------------------------------------------------------------------- @@ -956,7 +987,8 @@ subroutine photo_inti( chem_opt, nlev, ztopin ) !--------------------------------------------------------------------- if( chem_opt == MOZART_KPP .or. & chem_opt == MOZCART_KPP .or. & - chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then albedo(1:17,2) = (/ 0.0747_dp, 0.0755_dp, 0.0767_dp, 0.0783_dp, 0.0802_dp, & 0.0825_dp, 0.0852_dp, 0.0882_dp, 0.0914_dp, 0.0908_dp, & 0.0763_dp, 0.0725_dp, 0.0689_dp, 0.0632_dp, 0.0570_dp, & diff --git a/wrfv2_fire/chem/module_ftuv_subs.F b/wrfv2_fire/chem/module_ftuv_subs.F index ff84b487..ccd3ad08 100644 --- a/wrfv2_fire/chem/module_ftuv_subs.F +++ b/wrfv2_fire/chem/module_ftuv_subs.F @@ -9,9 +9,9 @@ MODULE module_ftuv_subs !----------------------------------------------------------------------------- ! data for inter2, inter3 and interi !----------------------------------------------------------------------------- - integer, private :: nintervals - integer, private, allocatable :: xi(:), xcnt(:) - real(dp), private, allocatable :: xfrac(:,:) + integer, private, save :: nintervals + integer, private, allocatable, save :: xi(:), xcnt(:) + real(dp), private, allocatable, save :: xfrac(:,:) real(dp), private, parameter :: km2cm = 1.e5_dp @@ -32,11 +32,11 @@ MODULE module_ftuv_subs real(dp), private, parameter :: t_del = 5._dp/(tdim_real-1._dp)!BSINGH(PNNL)-redefined t_del and t_fac real(dp), private, parameter :: t_fac = (tdim_real-1._dp)/5._dp - integer, private :: ii, jj - real(dp), private :: d_table(0:tdim,ngast-1) - real(dp), private :: x_table(0:tdim,ngast-1) - real(dp), private :: o2_table(tdim) - real(dp), private, dimension(12,ngast-1) :: a_schu, b_schu + integer, private :: ii, jj + real(dp), private, save :: d_table(0:tdim,ngast-1) + real(dp), private, save :: x_table(0:tdim,ngast-1) + real(dp), private, save :: o2_table(tdim) + real(dp), private, dimension(12,ngast-1), save :: a_schu, b_schu !----------------------------------------------------------------------------- ! a_schu(16,12) coefficients for rj(m) (table 1 in kockarts 1994) ! b_schu(16,12) rj(o2)(table 2 in kockarts 1994) @@ -147,10 +147,10 @@ MODULE module_ftuv_subs !----------------------------------------------------------------------------- integer, public, parameter :: nwint = 105 - real(dp), public :: wlint(nwint) - real(dp), private :: xso2int(nwint) - real(dp), private :: wlla(nla) - real(dp), private :: wlgast(ngast) + real(dp), public, save :: wlint(nwint) + real(dp), private, save :: xso2int(nwint) + real(dp), private, save :: wlla(nla) + real(dp), private, save :: wlgast(ngast) !----------------------------------------------------------------------------- ! o2 parameters @@ -1514,9 +1514,7 @@ subroutine setz( nz, cz, tlev, c, ndx, adjcoe ) tt = tlev(1)/281._dp do m = 1,tuv_jmax adjin = 1._dp -!acd_sw_bugfix 20131205 if( m == 2 ) then -!acd_sw_bugfix 20131205 !---------------------------------------------------------------------- ! ... temperature modification ! t0.9 (1.05) t0.95(1.025) t1.0(1.0) t1.15(1.02) t1.1(1.04) @@ -1621,23 +1619,20 @@ subroutine setozo( nz, z, tlay, dto3, & o3den(1:nz) = o3(1:nz)*airlev(1:nz) cz(1:nz-1) = 0.5_dp*(o3den(2:nz) + o3den(1:nz-1))*km2cm*(z(2:nz) - z(1:nz-1)) -!acd_sw_bugfix 20131205 - cz(nz-1) = cz(nz-1) + o3top -!acd_sw_bugfix 20131205 to3(nz) = o3top do k = nz-1,1,-1 to3(k) = to3(k+1) + cz(k) end do +! Do not double count o3top + cz(nz-1) = cz(nz-1) + o3top !----------------------------------------------------------------------------- ! ... scale o3 using toms data !----------------------------------------------------------------------------- if( o3toms > 0.0_dp ) then scale = o3toms/(to3(1)/2.687e16_dp) -!acd_sw_bugfix 20131205 cz(1:nz) = cz(1:nz)*scale -!acd_sw_bugfix 20131205 to3(1:nz) = to3(1:nz)*scale endif !----------------------------------------------------------------------------- @@ -2650,7 +2645,8 @@ end subroutine ps2str subroutine pchem( chem_opt, nz, tlev, airlev ) - use module_state_description, only : MOZART_KPP, MOZCART_KPP, MOZART_MOSAIC_4BIN_VBS0_KPP + use module_state_description, only : MOZART_KPP, MOZCART_KPP, & + MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP use module_wave_data, only : r01, r04, r44, r08, r06, r10, & r11, r14, r15, r17, r18, & xs_mvk, xs_macr, xs_hyac, xs_glyald, nj @@ -2800,7 +2796,8 @@ subroutine pchem( chem_opt, nz, tlev, airlev ) !----------------------------------------------------------------------------- is_mozart : & if( chem_opt == MOZART_KPP .or. chem_opt == MOZCART_KPP .or. & - chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) then call xs_mvk( nz, tlev, airlev ) call xs_macr( nz, tlev, airlev ) call xs_hyac( nz, tlev, airlev ) @@ -2949,12 +2946,24 @@ subroutine pchem( chem_opt, nz, tlev, airlev ) j = j + 1 jlabel(j)='cf2brcl (halon-1211) + hv -> products ' !----------------------------------------------------------------------------- -! (56) cl2 + hc -> cl + cl +! (56) cl2 + hv -> cl + cl +!----------------------------------------------------------------------------- + j = j + 1 + jlabel(j)='cl2 + hv -> cl + cl ' +!----------------------------------------------------------------------------- +! (57) hocl + hv -> oh + cl !----------------------------------------------------------------------------- j = j + 1 - jlabel(j)='cl2 + hc -> cl + cl ' + jlabel(j)='hocl + hv -> oh + cl' +!----------------------------------------------------------------------------- +! (58) fmcl + hv -> cl + co + ho2 +!----------------------------------------------------------------------------- + j = j + 1 + jlabel(j)='fmcl + hv -> cl + co + ho2' + end if is_mozart + end subroutine pchem subroutine lymana( nz, o2col, secchi, dto2la, xso2la ) diff --git a/wrfv2_fire/chem/module_ghg_fluxes.F b/wrfv2_fire/chem/module_ghg_fluxes.F index f9871468..478d8c2a 100644 --- a/wrfv2_fire/chem/module_ghg_fluxes.F +++ b/wrfv2_fire/chem/module_ghg_fluxes.F @@ -156,6 +156,9 @@ SUBROUTINE VPRM ( ids,ide, jds,jde, & DO j=jts,min(jte,jde-1) DO i=its,min(ite,ide-1) + GEE_frac= 0. + RESP_frac= 0. + Tair= T2(i,j)-273.15 veg_frac_loop: DO m=1,7 @@ -202,13 +205,15 @@ SUBROUTINE VPRM ( ids,ide, jds,jde, & end if RADscale= 1./(1. + RAD(i,j)/rad0(m)) - GEE_frac= lambda(m)*Tscale*Pscale*Wscale*RADscale* vprm_in(i,m,j,p_evi)* RAD(i,j)*vprm_in(i,m,j,p_vegfra_vprm) - eghg_bio(i,1,j,p_ebio_gee)= min(0.0,const*GEE_frac) + GEE_frac= lambda(m)*Tscale*Pscale*Wscale*RADscale* vprm_in(i,m,j,p_evi)* RAD(i,j)*vprm_in(i,m,j,p_vegfra_vprm) + GEE_frac + + RESP_frac= (alpha(m)*Tair + RESP0(m))*vprm_in(i,m,j,p_vegfra_vprm) + RESP_frac - RESP_frac= (alpha(m)*Tair + RESP0(m))*vprm_in(i,m,j,p_vegfra_vprm) - eghg_bio(i,1,j,p_ebio_res)= max(0.0,const*RESP_frac) ENDDO veg_frac_loop + + eghg_bio(i,1,j,p_ebio_gee)= min(0.0,const*GEE_frac) + eghg_bio(i,1,j,p_ebio_res)= max(0.0,const*RESP_frac) ENDDO ENDDO diff --git a/wrfv2_fire/chem/module_gocart_chem.F b/wrfv2_fire/chem/module_gocart_chem.F index 3e2e1676..a784bd85 100644 --- a/wrfv2_fire/chem/module_gocart_chem.F +++ b/wrfv2_fire/chem/module_gocart_chem.F @@ -137,7 +137,7 @@ subroutine gocart_chem_driver(curr_secs,dt,config_flags, & enddo enddo enddo - CASE (GOCARTRACM_KPP,GOCARTRADM2_KPP,GOCARTRADM2) + CASE (GOCARTRACM_KPP,GOCARTRADM2) CALL wrf_debug(15,'calling gocart chemistry in addition to racm_kpp') do j=jts,jte do i=its,ite diff --git a/wrfv2_fire/chem/module_gocart_dust_afwa.F b/wrfv2_fire/chem/module_gocart_dust_afwa.F index a113cfde..92cfcf41 100755 --- a/wrfv2_fire/chem/module_gocart_dust_afwa.F +++ b/wrfv2_fire/chem/module_gocart_dust_afwa.F @@ -1,6 +1,7 @@ MODULE GOCART_DUST_AFWA ! -! AFWA dust routine created by Sandra Jones (AER and AFWA) and Glenn Creighton (AFWA). +! AFWA dust routine +! Created by Sandra Jones (AER and AFWA) and Glenn Creighton (AFWA). ! USE module_data_gocart_dust @@ -10,15 +11,17 @@ MODULE GOCART_DUST_AFWA INTRINSIC max, min CONTAINS - subroutine gocart_dust_afwa_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u_phy, & - v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod,dustin,snowh,zs, & - ivgtyp,isltyp,vegfra,xland,xlat,xlong,gsw,dx,g,emis_dust, & - ust,znt,clay,sand,alpha,gamma,smtune, & + SUBROUTINE gocart_dust_afwa_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u_phy, & + v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod,erod_dri,dustin,snowh,zs, & + ivgtyp,isltyp,vegfra,lai_vegmask,xland,xlat,xlong,gsw,dx,g,emis_dust, & + ust,znt,clay_wrf,sand_wrf,clay_nga,sand_nga,afwa_dustloft, & + tot_dust,tot_edust,vis_dust,alpha,gamma,smtune,ustune, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) USE module_configure USE module_state_description + USE module_data_sorgam, ONLY: factnuma,factnumc,soilfac TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags @@ -42,7 +45,7 @@ subroutine gocart_dust_afwa_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u REAL, DIMENSION( config_flags%num_soil_layers ) , & INTENT(IN ) :: zs REAL, DIMENSION( ims:ime , jms:jme, ndcls ) , & - INTENT(IN ) :: erod + INTENT(IN ) :: erod,erod_dri REAL, DIMENSION( ims:ime , jms:jme, 5 ) , & INTENT(INOUT) :: dustin REAL, DIMENSION( ims:ime , jms:jme ) , & @@ -51,13 +54,16 @@ subroutine gocart_dust_afwa_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u v10, & gsw, & vegfra, & + lai_vegmask, & xland, & xlat, & xlong, & ust, & znt, & - clay, & - sand, & + clay_wrf, & + sand_wrf, & + clay_nga, & + sand_nga, & snowh REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & INTENT(IN ) :: & @@ -65,27 +71,38 @@ subroutine gocart_dust_afwa_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u t_phy, & dz8w,p8w, & u_phy,v_phy,rho_phy + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT( OUT) :: afwa_dustloft, & + tot_edust + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT( OUT) :: tot_dust, & + vis_dust REAL, INTENT(IN ) :: dt,dx,g -! Local variables + ! Local variables INTEGER :: nmx,smx,i,j,k,imx,jmx,lmx,lhave INTEGER,DIMENSION (1,1) :: ilwi REAL*8, DIMENSION (1,1) :: erodtot + REAL*8, DIMENSION (1,1) :: vegmask REAL*8, DIMENSION (1,1) :: gravsm + REAL, DIMENSION( ims:ime , jms:jme ) :: clay,sand REAL*8, DIMENSION (1,1) :: drylimit REAL*8, DIMENSION (5) :: tc,bems REAL*8, DIMENSION (1,1) :: airden,airmas,ustar REAL*8, DIMENSION (1) :: dxy REAL*8, DIMENSION (3) :: massfrac - REAL :: conver,converi,volsm + REAL*8 :: volsm + REAL :: conver,converi + REAL :: psi,ustart,w10 REAL*8 :: zwant - REAL, INTENT(IN ) :: alpha, gamma, smtune + REAL, INTENT(IN ) :: alpha, gamma, smtune, ustune + INTEGER :: smois_opt conver=1.e-9 converi=1.e9 -! Number of dust bins + ! Number of dust bins imx=1 jmx=1 @@ -97,90 +114,210 @@ subroutine gocart_dust_afwa_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u DO j=jts,jte DO i=its,ite -! Don't do dust over water!!! + ! Masked value for afwa_dustloft + + afwa_dustloft(i,j)=-99. + + ! Don't do dust over water!!! IF (xland(i,j) .lt. 1.5) THEN ilwi(1,1)=1 -! Total concentration at lowest model level. This is still hardcoded for 5 bins. + ! Total concentration at lowest model level. This is still hardcoded + ! for 5 bins. - tc(1)=chem(i,kts,j,p_dust_1)*conver - tc(2)=chem(i,kts,j,p_dust_2)*conver - tc(3)=chem(i,kts,j,p_dust_3)*conver - tc(4)=chem(i,kts,j,p_dust_4)*conver - tc(5)=chem(i,kts,j,p_dust_5)*conver + IF(config_flags%chem_opt == CB05_SORG_AQ_KPP .or. & + config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP ) then + tc(1)=0.0 + tc(2)=0.0 + tc(3)=0.0 + tc(4)=0.0 + tc(5)=0.0 + ELSE + tc(1)=chem(i,kts,j,p_dust_1)*conver + tc(2)=chem(i,kts,j,p_dust_2)*conver + tc(3)=chem(i,kts,j,p_dust_3)*conver + tc(4)=chem(i,kts,j,p_dust_4)*conver + tc(5)=chem(i,kts,j,p_dust_5)*conver + END IF -! Air mass and density at lowest model level. + ! Air mass and density at lowest model level. airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g airden(1,1)=rho_phy(i,kts,j) ustar(1,1)=ust(i,j) dxy(1)=dx*dx + + ! Friction velocity tuning constant (Note: recommend 0.7 for PXLSM, + ! else use 1.0. This was created due to make the scheme compatible + ! with the much stronger friction velocities coming out of PXLSM). + + ustar(1,1)=ustar(1,1) * ustune -! Total erodibility. + ! Total erodibility. Determine what DSR we're using. + ! Note, the DRI erodibility dataset is an optional 1km resolution dataset + ! but currently is only available over southwest Asia. If running + ! a domain outside of SWA, this will fill in the missing data from + ! DRI with the Ginoux dataset, but there will be inconsistencies. GAC + ! Erodibility is broken up into 3 bins, sum them up here. + + IF (config_flags%dust_dsr .eq. 1) then ! DRI DSR + IF (erod_dri(i,j,1).ge.0) THEN ! Where DRI is defined + erodtot(1,1) = SUM(erod_dri(i,j,:)) + ELSE ! Outside where DRI not defined, use Ginoux + erodtot(1,1)=SUM(erod(i,j,:)) + ENDIF + ELSE ! Ginoux DSR + erodtot(1,1)=SUM(erod(i,j,:)) + ENDIF + + ! Set the vegmask variable to the desired vegation mask at this gridpoint + + IF (config_flags%dust_veg .eq. 1) then + + ! 12-month vegetation fraction + ! If user chose this 12-month greenfrac vegetation mask option, + ! cut off everything above 5% + + IF (vegfra(i,j) .ge. 5.) then + vegmask(1,1) = 0.0 + ELSE + vegmask(1,1) = 1.0 + ENDIF + ELSE IF (config_flags%dust_veg .eq. 2) then + + ! 8-day MODIS LAI vegmask + ! 1 = no veg, produce dust; 0 = vegation, do not produce dust + + vegmask(1,1) = lai_vegmask(i,j) + ELSE + + ! Default choice = static ginoux vegmask + + IF (erod(i,j,1) .eq. 0) THEN + vegmask(1,1) = 0.0 + ELSE + vegmask(1,1) = 1.0 + ENDIF + ENDIF - erodtot(1,1)=SUM(erod(i,j,:)) + ! Remove vegetated areas (vegmask=0) from total erodibility. + + erodtot(1,1) = erodtot(1,1) * vegmask(1,1) + + ! Option to use an optional high resolution soil type database from NGA. + ! Option 0 = WRF (default); Option 1 = NGA + ! Note NGA dataset is currently only available over southwest Asia + ! Until a global dataset becomes available, option 0 is recommended + ! for consistency. If option 1 is chosen for a domain outside of + ! SWA, this logic will fill in the areas missing from NGA with the + ! defaults from WRF. It will work, but it will be inconsistent. GAC + + IF (config_flags%dust_soils .eq. 1) then + IF (clay_nga(i,j) .ge.0) then + clay(i,j) = clay_nga(i,j) + sand(i,j) = sand_nga(i,j) + ELSE + clay(i,j) =clay_wrf(i,j) + sand(i,j) =sand_wrf(i,j) + ENDIF + ELSE + clay(i,j) =clay_wrf(i,j) + sand(i,j) =sand_wrf(i,j) + ENDIF -! Mass fractions of clay, silt, and sand. + ! Mass fractions of clay, silt, and sand. massfrac(1)=clay(i,j) massfrac(2)=1-(clay(i,j)+sand(i,j)) massfrac(3)=sand(i,j) -! Don't allow roughness lengths greater than 20 cm to be lofted. -! This kludge accounts for land use types like urban areas and -! forests which would otherwise show up as high dust emitters. -! This is a placeholder for a more widely accepted kludge -! factor in the literature, which reduces lofting for rough areas. -! Forthcoming... + ! Don't allow roughness lengths greater than 20 cm to be lofted. + ! This kludge accounts for land use types like urban areas and + ! forests which would otherwise show up as high dust emitters. + ! This is a placeholder for a more widely accepted kludge + ! factor in the literature, which reduces lofting for rough areas. + ! Forthcoming... IF (znt(i,j) .gt. 0.2) then ilwi(1,1)=0 ENDIF -! Do not allow areas with bedrock, lava, or land-ice to loft. + ! Do not allow areas with bedrock, lava, or land-ice to loft. IF (isltyp(i,j) .eq. 15 .or. isltyp(i,j) .eq. 16. .or. & isltyp(i,j) .eq. 18) then ilwi(1,1)=0 ENDIF -! Another hack to ensure dust does not loft from areas with snow -! cover...because, well, that doesn't make sense. + ! Another hack to ensure dust does not loft from areas with snow + ! cover...because, well, that doesn't make sense. IF (snowh(i,j) .gt. 0.01) then ilwi(1,1)=0 ENDIF -! Check LSM scheme. If RUC, add drypoint back to smois to get back to volumetric soil -! moisture. If not RUC, smois is volumetric soil moisture. Volumetric soil moisture -! can be tuned here with a multiple (dust_smtune) set in the namelist. Note: There -! can be a significant difference between the volumetric soil moisture calculated -! here between RUC and NOAA, even from the same input soil moisture. This is due to -! fact that RUC subtracts hygroscopic water (drypoint) and rounds any value less -! than 0.005 to 0.005. When we add drypoint back to the RUC soil moisture, we are -! artificially moistening any areas with initial values less than 0.005. + ! Volumetric soil moisture can be tuned here with a dust_smtune + ! set in the namelist. - sfc_select: SELECT CASE(config_flags%sf_surface_physics) - CASE (RUCLSMSCHEME) - volsm=max((smois(i,1,j)+drypoint(isltyp(i,j)))*smtune,0.) - CASE DEFAULT - volsm=max(smois(i,1,j)*smtune,0.) - END SELECT sfc_select + volsm=max(smois(i,1,j)*smtune,0.) -! Calculate gravimetric soil moisture and drylimit. + ! Calculate gravimetric soil moisture. gravsm(1,1)=100*volsm/((1.-porosity(isltyp(i,j)))*(2.65*(1-clay(i,j))+2.50*clay(i,j))) - drylimit(1,1)=14.0*clay(i,j)*clay(i,j)+17.0*clay(i,j) + + ! Choose an LSM option and drylimit option. + ! Drylimit calculations based on look-up table in + ! Clapp and Hornberger (1978) for RUC and PXLSM and + ! Cosby et al. (1984) for Noah LSM. + + smois_opt = 0 + IF (config_flags%dust_smois == 1) then + sfc_select: SELECT CASE(config_flags%sf_surface_physics) + CASE ( RUCLSMSCHEME, PXLSMSCHEME ) + drylimit(1,1) =0.035*(13.52*clay(i,j)+3.53)**2.68 + smois_opt = 1 + CASE ( LSMSCHEME ) + drylimit(1,1) =0.0756*(15.127*clay(i,j)+3.09)**2.3211 + smois_opt = 1 + CASE DEFAULT + + ! Don't currently support volumetric soil moisture + ! for this scheme, use drylimit based on gravimetric + + drylimit(1,1)=14.0*clay(i,j)*clay(i,j)+17.0*clay(i,j) + END SELECT sfc_select + ELSE + + ! use drylimit based on gravimetric soil moisture + + drylimit(1,1)=14.0*clay(i,j)*clay(i,j)+17.0*clay(i,j) + END IF -! Call dust emission routine. + ! Call dust emission routine. call source_dust(imx, jmx, lmx, nmx, smx, dt, tc, ustar, massfrac, & - erodtot, ilwi, dxy, gravsm, airden, airmas, & - bems, g, drylimit, alpha, gamma) + erodtot, ilwi, dxy, gravsm, volsm, airden, airmas, & + bems, ustart, g, drylimit, alpha, gamma, smois_opt) IF(config_flags%chem_opt == 2 .or. config_flags%chem_opt == 11 ) then dustin(i,j,1:5)=tc(1:5)*converi + ELSE IF(config_flags%chem_opt == CB05_SORG_AQ_KPP .or. & + config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP) then +!KW chem(i,kts,j,p_p25i)=chem(i,kts,j,p_p25i) & +! +.25*(tc(1)+.286*tc(2))*converi +! chem(i,kts,j,p_p25i)=max(chem(i,kts,j,p_p25i),1.e-16) +! chem(i,kts,j,p_p25j)=chem(i,kts,j,p_p25j) & +! +.75*(tc(1)+.286*tc(2))*converi +! chem(i,kts,j,p_p25j)=max(chem(i,kts,j,p_p25j),1.e-16) +! chem(i,kts,j,p_soila)=chem(i,kts,j,p_soila) & +! +(.714*tc(2)+tc(3))*converi +! chem(i,kts,j,p_soila)=max(chem(i,kts,j,p_soila),1.e-16) + chem(i,kts,j,p_p25j)=chem(i,kts,j,p_p25j) + 0.03*sum(tc(1:5))*converi + chem(i,kts,j,p_soila)=chem(i,kts,j,p_soila) + 0.97*1.02*sum(tc(1:5))*converi + + chem(i,kts,j,p_ac0) = chem(i,kts,j,p_ac0) + 0.03*sum(tc(1:5))*converi*factnuma*soilfac + chem(i,kts,j,p_corn) = chem(i,kts,j,p_corn) + 0.97*1.02*sum(tc(1:5))*converi*factnumc*soilfac ELSE chem(i,kts,j,p_dust_1)=tc(1)*converi chem(i,kts,j,p_dust_2)=tc(2)*converi @@ -189,7 +326,18 @@ subroutine gocart_dust_afwa_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u chem(i,kts,j,p_dust_5)=tc(5)*converi ENDIF -! For output diagnostics + ! Diagnostic dust lofting potential diagnostic calculation + + psi=0. + w10=(u10(i,j)**2.+v10(i,j)**2.)**0.5 + IF (ustar(1,1) .ne. 0. .and. znt(i,j) .ne. 0.) THEN + psi=0.4*w10/ustar(1,1)-LOG(10.0/znt(i,j)) + ENDIF + IF (erodtot(1,1) .gt. 0.) then + afwa_dustloft(i,j)=ustune*w10-ustart*(LOG(10.0/znt(i,j))+psi)/0.4 + ENDIF + + ! For output diagnostics (g m^-2 s^-1) emis_dust(i,1,j,p_edust1)=bems(1) emis_dust(i,1,j,p_edust2)=bems(2) @@ -197,81 +345,109 @@ subroutine gocart_dust_afwa_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u emis_dust(i,1,j,p_edust4)=bems(4) emis_dust(i,1,j,p_edust5)=bems(5) + ! Diagnostic total emitted dust (g m^-2 s^-1) + + tot_edust(i,j)=(bems(1)+bems(2)+bems(3)+bems(4)+bems(5)) + ENDIF + + ! Cumulative dust concentration (ug m^-3) and visibility (m) diagnostics + ! Note visibility is capped at 20 km. Simple visibility algorithm based + ! on mean particle diameter for each dust bin - perfect spheres - perfect + ! blackbodies. + + DO k=kts,kte + tot_dust(i,k,j)=(chem(i,k,j,p_dust_1)+chem(i,k,j,p_dust_2)+ & + chem(i,k,j,p_dust_3)+chem(i,k,j,p_dust_4)+ & + chem(i,k,j,p_dust_5))*rho_phy(i,k,j) + IF ( tot_dust(i,k,j) .gt. 0. ) THEN + vis_dust(i,k,j)=MIN(3.912/ & + ((1.470E-6*chem(i,k,j,p_dust_1)+ & + 7.877E-7*chem(i,k,j,p_dust_2)+ & + 4.623E-7*chem(i,k,j,p_dust_3)+ & + 2.429E-7*chem(i,k,j,p_dust_4)+ & + 1.387E-7*chem(i,k,j,p_dust_5))* & + rho_phy(i,k,j)),999999.) + ELSE + vis_dust(i,k,j)=999999. + ENDIF + ENDDO + ENDDO ENDDO -end subroutine gocart_dust_afwa_driver + END SUBROUTINE gocart_dust_afwa_driver - SUBROUTINE source_dust(imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac,& - erod, ilwi, dxy, gravsm, airden, airmas, & - bems, g0, drylimit, alpha, gamma) - -! **************************************************************************** -! * Evaluate the source of each dust particles size bin by soil emission -! * -! * Input: -! * EROD Fraction of erodible grid cell (-) -! * ILWI Land/water flag (-) -! * GRAVSM Gravimetric soil moisture (g/g) -! * DRYLIMIT Upper GRAVSM limit for air-dry soil (g/g) -! * ALPHA Constant to fudge the total emission of dust (1/m) -! * GAMMA Exponential tuning constant for erodibility (-) -! * DXY Surface of each grid cell (m2) -! * AIRMAS Mass of air for each grid box (kg) -! * AIRDEN Density of air for each grid box (kg/m3) -! * USTAR Friction velocity (m/s) -! * MASSFRAC Fraction of mass in each of 3 soil classes (-) -! * DT1 Time step (s) -! * NMX Number of dust bins (-) -! * SMX Number of saltation bins (-) -! * IMX Number of I points (-) -! * JMX Number of J points (-) -! * LMX Number of L points (-) -! * -! * Data (see module_data_gocart_dust): -! * SPOINT Pointer to 3 soil classes (-) -! * DEN_DUST Dust density (kg/m3) -! * DEN_SALT Saltation particle density (kg/m3) -! * REFF_SALT Reference saltation particle diameter (m) -! * REFF_DUST Reference dust particle diameter (m) -! * LO_DUST Lower diameter limits for dust bins (m) -! * UP_DUST Upper diameter limits for dust bins (m) -! * FRAC_SALT Soil class mass fraction for saltation bins (-) -! * -! * Parameters: -! * BETAMAX Maximum sandblasting mass efficiency (-) -! * CMB Constant of proportionality (-) -! * MMD_DUST Mass median diameter of dust (m) -! * GSD_DUST Geometric standard deviation of dust (-) -! * LAMBDA Side crack propogation length (m) -! * CV Normalization constant (-) -! * G0 Gravitational acceleration (m/s2) -! * G Gravitational acceleration in cgs (cm/s2) -! * -! * Working: -! * BETA Sandblasting mass efficiency (-) -! * U_TS0 "Dry" threshold friction velocity (m/s) -! * U_TS Moisture-adjusted threshold friction velocity (m/s) -! * RHOA Density of air in cgs (g/cm3) -! * DEN Dust density in cgs (g/cm3) -! * DIAM Dust diameter in cgs (cm) -! * DMASS Saltation mass distribution (-) -! * DSURFACE Saltation surface area per unit mass (m2/kg) -! * DS_REL Saltation surface area distribution (-) -! * SALT Saltation flux (kg/m/s) -! * DLNDP Dust bin width (-) -! * EMIT Total vertical mass flux (kg/m2/s) -! * EMIT_VOL Total vertical volume flux (m/s) -! * DSRC Mass of emitted dust (kg/timestep/cell) -! * -! * Output: -! * TC Total concentration of dust (kg/kg/timestep/cell) -! * BEMS Source of each dust type (kg/timestep/cell) -! * USTART Threshold friction vel. (bin 7) (m/s) -! * -! **************************************************************************** + erod, ilwi, dxy, gravsm, volsm, airden, airmas, & + bems, ustart, g0, drylimit, alpha, gamma, smois_opt) + + ! **************************************************************************** + ! * Evaluate the source of each dust particles size bin by soil emission + ! * + ! * Input: + ! * EROD Fraction of erodible grid cell (-) + ! * ILWI Land/water flag (-) + ! * GRAVSM Gravimetric soil moisture (g/g) + ! * VOLSM Volumetric soil moisture (g/g) + ! * SOILM_OPT Soil moisture option (1:Use GRAVSM 2:VOLSM) (-) + ! * DRYLIMIT Upper GRAVSM (VOLSM) limit for air-dry soil (g/g) + ! * ALPHA Constant to fudge the total emission of dust (1/m) + ! * GAMMA Exponential tuning constant for erodibility (-) + ! * DXY Surface of each grid cell (m2) + ! * AIRMAS Mass of air for each grid box (kg) + ! * AIRDEN Density of air for each grid box (kg/m3) + ! * USTAR Friction velocity (m/s) + ! * MASSFRAC Fraction of mass in each of 3 soil classes (-) + ! * DT1 Time step (s) + ! * NMX Number of dust bins (-) + ! * SMX Number of saltation bins (-) + ! * IMX Number of I points (-) + ! * JMX Number of J points (-) + ! * LMX Number of L points (-) + ! * + ! * Data (see module_data_gocart_dust): + ! * SPOINT Pointer to 3 soil classes (-) + ! * DEN_DUST Dust density (kg/m3) + ! * DEN_SALT Saltation particle density (kg/m3) + ! * REFF_SALT Reference saltation particle diameter (m) + ! * REFF_DUST Reference dust particle diameter (m) + ! * LO_DUST Lower diameter limits for dust bins (m) + ! * UP_DUST Upper diameter limits for dust bins (m) + ! * FRAC_SALT Soil class mass fraction for saltation bins (-) + ! * + ! * Parameters: + ! * BETAMAX Maximum sandblasting mass efficiency (-) + ! * CMB Constant of proportionality (-) + ! * MMD_DUST Mass median diameter of dust (m) + ! * GSD_DUST Geometric standard deviation of dust (-) + ! * LAMBDA Side crack propogation length (m) + ! * CV Normalization constant (-) + ! * G0 Gravitational acceleration (m/s2) + ! * G Gravitational acceleration in cgs (cm/s2) + ! * + ! * Working: + ! * BETA Sandblasting mass efficiency (-) + ! * U_TS0 "Dry" threshold friction velocity (m/s) + ! * U_TS Moisture-adjusted threshold friction velocity (m/s) + ! * RHOA Density of air in cgs (g/cm3) + ! * DEN Dust density in cgs (g/cm3) + ! * DIAM Dust diameter in cgs (cm) + ! * DMASS Saltation mass distribution (-) + ! * DSURFACE Saltation surface area per unit mass (m2/kg) + ! * DS_REL Saltation surface area distribution (-) + ! * SALT Saltation flux (kg/m/s) + ! * DLNDP Dust bin width (-) + ! * EMIT Total vertical mass flux (kg/m2/s) + ! * EMIT_VOL Total vertical volume flux (m/s) + ! * DSRC Mass of emitted dust (kg/timestep/cell) + ! * + ! * Output: + ! * TC Total concentration of dust (kg/kg/timestep/cell) + ! * BEMS Source of each dust type (kg/timestep/cell) + ! * USTART Threshold friction vel. (bin 7) (m/s) + ! * + ! **************************************************************************** INTEGER, INTENT(IN) :: nmx,imx,jmx,lmx,smx INTEGER, INTENT(IN) :: ilwi(imx,jmx) @@ -284,6 +460,9 @@ SUBROUTINE source_dust(imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac,& REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) REAL*8, INTENT(OUT) :: bems(imx,jmx,nmx) REAL, INTENT(IN) :: g0,dt1 + REAL, INTENT(OUT) :: ustart + INTEGER, INTENT(IN) :: smois_opt + REAL*8, INTENT(IN) :: volsm REAL*8 :: den(smx), diam(smx) REAL*8 :: dvol(nmx), dlndp(nmx) @@ -356,106 +535,134 @@ SUBROUTINE source_dust(imx, jmx, lmx, nmx, smx, dt1, tc, ustar, massfrac,& ! calculate saltation flux (salt) where ustar has exceeded u_ts. Finally, ! calculate total dust emission (tot_emit), taking into account erodibility. - g = g0*1.0E2 ! (cm s^-2) - emit=0.0 - - DO n = 1, smx ! Loop over saltation bins - den(n) = den_salt(n)*1.0D-3 ! (g cm^-3) - diam(n) = 2.0*reff_salt(n)*1.0D2 ! (cm) - DO i = 1,imx - DO j = 1,jmx - rhoa = airden(i,j,1)*1.0D-3 ! (g cm^-3) - - ! Threshold friction velocity as a function of the dust density and - ! diameter from Bagnold (1941) (m s^-1). - - u_ts0 = 0.13*1.0D-2*SQRT(den(n)*g*diam(n)/rhoa)* & - SQRT(1.0+0.006/den(n)/g/(diam(n))**2.5)/ & - SQRT(1.928*(1331.0*(diam(n))**1.56+0.38)**0.092-1.0) - - ! Friction velocity threshold correction function based on physical - ! properties related to moisture tension. Soil moisture greater than - ! dry limit serves to increase threshold friction velocity (making - ! it more difficult to loft dust). When soil moisture has not reached - ! dry limit, treat as dry (no correction to threshold friction - ! velocity). GC - - IF (gravsm(i,j) > drylimit(i,j)) THEN - u_ts = MAX(0.0D+0,u_ts0*(sqrt(1.0+1.21*(gravsm(i,j)-drylimit(i,j))**0.68))) - ELSE - u_ts = u_ts0 - END IF - - ! Saltation flux from Marticorena & Bergametti 1995 (MB95). ds_rel is - ! the relative surface area distribution - - IF (ustar(i,j) .gt. u_ts .and. erod(i,j) .gt. 0.0 .and. ilwi(i,j) == 1) THEN - salt = cmb*ds_rel(n)*(airden(i,j,1)/g0)*(ustar(i,j)**3)* & - (1. + u_ts/ustar(i,j))*(1. - (u_ts**2)/(ustar(i,j)**2)) ! (kg m^-1 s^-1) - ELSE - salt = 0.D0 - ENDIF - - ! Calculate total vertical mass flux (note beta has units of m^-1) - ! Beta acts to tone down dust in areas with so few dust-sized particles that the - ! lofting efficiency decreases. Otherwise, super sandy zones would be huge dust - ! producers, which is generally not the case. Equation derived from wind-tunnel - ! experiments (see MB95). - - beta=10**(13.6*massfrac(1)-6.0) ! (unitless) - if (beta .gt. betamax) then - beta=betamax - endif - emit=emit+salt*(erod(i,j)**gamma)*alpha*beta ! (kg m^-2 s^-1) - END DO - END DO - END DO ! End do over saltation bins - -! Now that we have the total dust emission, distribute into dust bins using -! lognormal distribution (Dr. Jasper Kok, 2010), and -! calculate total mass emitted over the grid box over the timestep. -! -! In calculating the Kok distribution, we assume upper and lower limits to each bin. -! For reff_dust=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) (default), -! lower limits were ASSUMED at lo_dust=(/0.1D-6,1.0D-6,1.8D-6,3.0D-6,6.0D-6/) -! upper limits were ASSUMED at up_dust=(/1.0D-6,1.8D-6,3.0D-6,6.0D-6,10.0D-6/) -! These may be changed within module_data_gocart_dust.F, but make sure it is -! consistent with reff_dust values. These values were taken from the original -! GOCART bin configuration. We use them here to calculate dust bin width, dlndp. -! dvol is the volume distribution. You know...if you were wondering. GC - -! dvol_tot=0. -! DO n=1,nmx ! Loop over all dust bins -! dlndp(n)=LOG(up_dust(n)/lo_dust(n)) -! dvol(n)=(2.0*reff_dust(n)/cv)*(1.+ERF(LOG(2.0*reff_dust(n)/mmd_dust)/(SQRT(2.)*LOG(gsd_dust))))*& -! EXP(-(2.0*reff_dust(n)/lambda)**3.0)*dlndp(n) -! dvol_tot=dvol_tot+dvol(n) + g = g0*1.0E2 ! (cm s^-2) + emit=0.0 + + DO n = 1, smx ! Loop over saltation bins + den(n) = den_salt(n)*1.0D-3 ! (g cm^-3) + diam(n) = 2.0*reff_salt(n)*1.0D2 ! (cm) + DO i = 1,imx + DO j = 1,jmx + rhoa = airden(i,j,1)*1.0D-3 ! (g cm^-3) + + ! Threshold friction velocity as a function of the dust density and + ! diameter from Bagnold (1941) (m s^-1). + + u_ts0 = 0.13*1.0D-2*SQRT(den(n)*g*diam(n)/rhoa)* & + SQRT(1.0+0.006/den(n)/g/(diam(n))**2.5)/ & + SQRT(1.928*(1331.0*(diam(n))**1.56+0.38)**0.092-1.0) + + ! Friction velocity threshold correction function based on physical + ! properties related to moisture tension. Soil moisture greater than + ! dry limit serves to increase threshold friction velocity (making + ! it more difficult to loft dust). When soil moisture has not reached + ! dry limit, treat as dry (no correction to threshold friction + ! velocity). GAC + + ! Calculate threshold friction velocity. If volumetric (gravimetric) + ! water content is less than the drylimit, then the threshold friction + ! velocity (u_ts) will be equal to the dry threshold friction velocity + ! (u_ts0). EDH + + IF (smois_opt .EQ. 1) THEN + IF (100.*volsm > drylimit(i,j)) THEN + u_ts = MAX(0.0D+0,u_ts0*(sqrt(1.0+1.21*((100.*volsm)-drylimit(i,j))**0.68))) + ELSE + u_ts = u_ts0 + ENDIF + ELSE + IF (gravsm(i,j) > drylimit(i,j)) THEN + u_ts = MAX(0.0D+0,u_ts0*(sqrt(1.0+1.21*(gravsm(i,j)-drylimit(i,j))**0.68))) + ELSE + u_ts = u_ts0 + END IF + END IF + + ! Bin 7 threshold friction velocity for diagnostic dust lofting + ! potential product + + IF (n .eq. 7) THEN ! Saltation bin 7 is small sand + ustart = u_ts + ENDIF + + ! Saltation flux (kg m^-1 s^-1) from MB95 + ! ds_rel is the relative surface area distribution + + IF (ustar(i,j) .gt. u_ts .and. erod(i,j) .gt. 0.0 .and. ilwi(i,j) == 1) THEN + salt = cmb*ds_rel(n)*(airden(i,j,1)/g0)*(ustar(i,j)**3)* & + (1. + u_ts/ustar(i,j))*(1. - (u_ts**2)/(ustar(i,j)**2)) + ELSE + salt = 0.D0 + ENDIF + + ! Calculate total vertical mass flux (note beta has units of m^-1) + ! Beta acts to tone down dust in areas with so few dust-sized particles + ! that the lofting efficiency decreases. Otherwise, super sandy zones + ! would be huge dust producers, which is generally not the case. + ! Equation derived from wind-tunnel experiments (see MB95). + + beta=10**(13.6*massfrac(1)-6.0) ! (unitless) + IF (beta .gt. betamax) THEN + beta=betamax + ENDIF + emit=emit+salt*(erod(i,j)**gamma)*alpha*beta ! (kg m^-2 s^-1) + END DO + END DO + END DO ! End do over saltation bins + + ! Now that we have the total dust emission, distribute into dust bins using + ! lognormal distribution (Dr. Jasper Kok, 2010), and + ! calculate total mass emitted over the grid box over the timestep. + ! + ! In calculating the Kok distribution, we assume upper and lower limits to + ! each bin. For reff_dust=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) (default), + ! lower limits were ASSUMED at lo_dust=(/0.1D-6,1.0D-6,1.8D-6,3.0D-6,6.0D-6/) + ! upper limits were ASSUMED at up_dust=(/1.0D-6,1.8D-6,3.0D-6,6.0D-6,10.0D-6/) + ! These may be changed within module_data_gocart_dust.F, but make sure it is + ! consistent with reff_dust values. These values were taken from the original + ! GOCART bin configuration. We use them here to calculate dust bin width, + ! dlndp. dvol is the volume distribution. GAC + ! + ! UPDATE: We bypass the calculation below and instead hardcode distr_dust for + ! the five dust bins we are using here since this distribution is static and + ! unnecessary to calculate at every time step. Keeping everything here to + ! document the steps in obtaining distr_dust. GAC 20140320 + +! dvol_tot=0. +! DO n=1,nmx ! Loop over all dust bins +! dlndp(n)=LOG(up_dust(n)/lo_dust(n)) +! dvol(n)=(2.0*reff_dust(n)/cv)*(1.+ERF(LOG(2.0*reff_dust(n)/mmd_dust)/(SQRT(2.)*LOG(gsd_dust))))*& +! EXP(-(2.0*reff_dust(n)/lambda)**3.0)*dlndp(n) +! dvol_tot=dvol_tot+dvol(n) ! -! ! Convert mass flux to volume flux -! emit_vol=emit/den_dust(n) ! (m s^-1) -! END DO -! DO n=1,nmx ! Loop over all dust bins -! distr_dust(n)=dvol(n)/dvol_tot -! END DO +! ! Convert mass flux to volume flux +! emit_vol=emit/den_dust(n) ! (m s^-1) +! END DO +! DO n=1,nmx ! Loop over all dust bins +! distr_dust(n)=dvol(n)/dvol_tot +! END DO -! Now distribute total vertical emission into dust bins and update concentration. + ! Now distribute total vertical emission into dust bins and update + ! concentration. + + DO n=1,nmx ! Loop over all dust bins + DO i=1,imx + DO j=1,jmx + + ! Calculate total mass emitted - DO n=1,nmx ! Loop over all dust bins - DO i=1,imx - DO j=1,jmx - ! Calculate total mass emitted dsrc = emit*distr_dust(n)*dxy(j)*dt1 ! (kg) IF (dsrc < 0.0) dsrc = 0.0 - ! Update dust mixing ratio at first model level. + ! Update dust mixing ratio at first model level. + tc(i,j,1,n) = tc(i,j,1,n) + dsrc / airmas(i,j,1) ! (kg/kg) - !bems(i,j,n) = dsrc ! diagnostic bems(i,j,n) = 1000.*dsrc/(dxy(j)*dt1) ! diagnostic (g/m2/s) - END DO - END DO - END DO + END DO + END DO + END DO -END SUBROUTINE source_dust + END SUBROUTINE source_dust END MODULE GOCART_DUST_AFWA diff --git a/wrfv2_fire/chem/module_input_chem_data.F b/wrfv2_fire/chem/module_input_chem_data.F index ec775824..c0ba7fc1 100755 --- a/wrfv2_fire/chem/module_input_chem_data.F +++ b/wrfv2_fire/chem/module_input_chem_data.F @@ -80,7 +80,7 @@ MODULE module_input_chem_data REAL :: so4vaptoaer DATA so4vaptoaer/.999/ - CHARACTER (LEN=4), DIMENSION(logg) :: ggnam + CHARACTER (LEN=20), DIMENSION(logg) :: ggnam !BSINGH(12/04/13): changed length(LEN) from 4 to 20 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! @@ -322,16 +322,17 @@ SUBROUTINE setup_gasprofile_maps(chem_opt, numgas) case (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & RACM_ESRLSORG_AQCHEM_KPP, RACM_ESRLSORG_KPP, RACMSORG_KPP, RACM_SOA_VBS_KPP,& - GOCARTRACM_KPP, GOCARTRADM2,GOCARTRADM2_KPP,CHEM_TRACER, CHEM_TRACE2) + GOCARTRACM_KPP, GOCARTRADM2,CHEM_TRACER, CHEM_TRACE2) call setup_gasprofile_map_radm_racm - case (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP) + case (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, SAPRC99_MOSAIC_8BIN_VBS2_KPP)!BSINGH(12/04/2013): Added SAPRC 8 bin and non-aq on 04/03/2014) call setup_gasprofile_map_saprcnov case (CBMZ, CBMZ_BB, CBMZ_BB_KPP, & - CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_4BIN_VBS2_KPP, & + CBMZ_MOSAIC_KPP, CBMZ_MOSAIC_4BIN, & CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ,CBMZSORG, & CBMZSORG_AQ, CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & @@ -347,7 +348,8 @@ SUBROUTINE setup_gasprofile_maps(chem_opt, numgas) case (CBM4_KPP) call setup_gasprofile_map_cbm4(numgas) - + case (CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP) + call wrf_debug("setup_profile_maps: nothing done for cb05") case (GOCART_SIMPLE) call wrf_debug("setup_profile_maps: nothing done for gocart simple") case (CHEM_VASH) @@ -367,8 +369,11 @@ SUBROUTINE setup_gasprofile_maps(chem_opt, numgas) case (MOZCART_KPP) call wrf_debug("setup_profile_maps: nothing done for mozcart_kpp") - case (MOZART_MOSAIC_4BIN_VBS0_KPP) - call wrf_debug("setup_profile_maps: nothing done for mozart_mosaic_4bin_vbs0__kpp") + case (MOZART_MOSAIC_4BIN_KPP) + call wrf_debug("setup_profile_maps: nothing done for mozart_mosaic_4bin_kpp") + + case (MOZART_MOSAIC_4BIN_AQ_KPP) + call wrf_debug("setup_profile_maps: nothing done for mozart_mosaic_4bin_aq_kpp") case (CO2_TRACER,GHG_TRACER) call wrf_debug("setup_profile_maps: nothing done for the GHG options") @@ -835,7 +840,7 @@ SUBROUTINE make_chem_profile ( nx1, nx2, ny1, ny2, nz1, nz2, nch, numgas, & ! SELECT CASE(chem_opt) CASE (CBMZ,CBMZ_BB,CBMZ_BB_KPP, CBMZ_MOSAIC_KPP, & - CBMZ_MOSAIC_4BIN,CBMZ_MOSAIC_8BIN,CBMZ_MOSAIC_4BIN_VBS2_KPP, & + CBMZ_MOSAIC_4BIN,CBMZ_MOSAIC_8BIN, & CBMZ_MOSAIC_4BIN_AQ,CBMZ_MOSAIC_8BIN_AQ, & CBMZSORG,CBMZSORG_AQ, CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & @@ -876,6 +881,41 @@ SUBROUTINE make_chem_profile ( nx1, nx2, ny1, ny2, nz1, nz2, nch, numgas, & end do end do end do + + CASE (CB05_SORG_AQ_KPP) + do j = ny1,ny2 + do k = nz1,nz2 + do i = nx1,nx2 + !Construct the sum of the profiles for hc3, hc5, & hc8 + hc358 = ( 2.9*fracref(numgas+1)*stor(i,k,j,iref(numgas+1)) & + +4.8*fracref(numgas+2)*stor(i,k,j,iref(numgas+2)) & + +7.9*fracref(numgas+3)*stor(i,k,j,iref(numgas+3)) & + )*1.E6 + chem(i,k,j,p_par) = & + 0.4*chem(i,k,j,p_ald2) + hc358 & + +0.4*chem(i,k,j,p_aldx) + 2.8*chem(i,k,j,p_ole) & + + 1.8*chem(i,k,j,p_iole) + 1.0*chem(i,k,j,p_aacd) + end do + end do + end do + + CASE (CB05_SORG_VBS_AQ_KPP) + do j = ny1,ny2 + do k = nz1,nz2 + do i = nx1,nx2 + !Construct the sum of the profiles for hc3, hc5, & hc8 + hc358 = ( 2.9*fracref(numgas+1)*stor(i,k,j,iref(numgas+1)) & + +4.8*fracref(numgas+2)*stor(i,k,j,iref(numgas+2)) & + +7.9*fracref(numgas+3)*stor(i,k,j,iref(numgas+3)) & + )*1.E6 + chem(i,k,j,p_par) = & + 0.4*chem(i,k,j,p_ald2) + hc358 & + +0.4*chem(i,k,j,p_aldx) + 2.8*chem(i,k,j,p_ole) & + + 1.8*chem(i,k,j,p_iole) + 1.0*chem(i,k,j,p_aacd) + end do + end do + end do + END SELECT RETURN @@ -921,9 +961,14 @@ SUBROUTINE bdy_chem_value_sorgam (chem, z, nch, config_flags, & ! ! method for bc calculation is determined by aer_bc_opt ! - if (config_flags%aer_bc_opt == AER_BC_PNNL) then + if (config_flags%aer_bc_opt == AER_BC_PNNL .and. & + config_flags%chem_opt .ne. CB05_SORG_VBS_AQ_KPP) then call sorgam_set_aer_bc_pnnl( chem, z, nch, config_flags ) return + else if (config_flags%aer_bc_opt == AER_BC_PNNL .and. & + config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP) then + call sorgam_vbs_set_aer_bc_pnnl( chem, z, nch, config_flags ) + return else if (config_flags%aer_bc_opt == AER_BC_DEFAULT) then continue else @@ -1467,6 +1512,14 @@ SUBROUTINE flow_dep_bdy_chem ( chem, & i_bdy_method = 5 else if (config_flags%chem_opt == GOCART_SIMPLE) then i_bdy_method = 7 + else if (config_flags%chem_opt == CB05_SORG_AQ_KPP) then + if (ic .le. numgas) then + i_bdy_method = 15 + end if + else if (config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP) then + if (ic .le. numgas) then + i_bdy_method = 17 + end if else if (config_flags%chem_opt == DUST) then i_bdy_method = 7 else if (config_flags%chem_opt == CHEM_VASH) then @@ -1550,6 +1603,12 @@ SUBROUTINE flow_dep_bdy_chem ( chem, & CALL bdy_chem_value_gcm ( chem(i,k,j),chem_bys(i,k,1),chem_btys(i,k,1),dt,ic) else if (i_bdy_method .eq. 16) then CALL bdy_chem_value_ghg ( chem(i,k,j), ic ) + else if (i_bdy_method .eq. 15) then + CALL bdy_chem_value_cb05 ( & + 1, chem(i,k,j), k, ic, config_flags, numgas ) + else if (i_bdy_method .eq. 17) then + CALL bdy_chem_value_cb05_vbs ( & + 1, chem(i,k,j), k, ic, config_flags, numgas ) else if (i_bdy_method .eq. 501) then tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac @@ -1602,6 +1661,12 @@ SUBROUTINE flow_dep_bdy_chem ( chem, & chem(i,k,j) = 0. else if (i_bdy_method .eq. 16) then CALL bdy_chem_value_ghg ( chem(i,k,j), ic ) ! For GHGs + else if (i_bdy_method .eq. 15) then + CALL bdy_chem_value_cb05 ( & + 2, chem(i,k,j), k, ic, config_flags, numgas ) + else if (i_bdy_method .eq. 17) then + CALL bdy_chem_value_cb05_vbs ( & + 2, chem(i,k,j), k, ic, config_flags, numgas ) else if (i_bdy_method .eq. 501) then tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac @@ -1655,6 +1720,12 @@ SUBROUTINE flow_dep_bdy_chem ( chem, & chem(i,k,j) = 0. else if (i_bdy_method .eq. 16) then CALL bdy_chem_value_ghg ( chem(i,k,j), ic ) ! For GHGs + else if (i_bdy_method .eq. 15) then + CALL bdy_chem_value_cb05 ( & + 3, chem(i,k,j), k, ic, config_flags, numgas ) + else if (i_bdy_method .eq. 17) then + CALL bdy_chem_value_cb05_vbs ( & + 3, chem(i,k,j), k, ic, config_flags, numgas ) else if (i_bdy_method .eq. 501) then tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac @@ -1708,6 +1779,12 @@ SUBROUTINE flow_dep_bdy_chem ( chem, & chem(i,k,j) = 0. else if (i_bdy_method .eq. 16) then CALL bdy_chem_value_ghg ( chem(i,k,j), ic ) ! For GHGs + else if (i_bdy_method .eq. 15) then + CALL bdy_chem_value_cb05 ( & + 4, chem(i,k,j), k, ic, config_flags, numgas ) + else if (i_bdy_method .eq. 17) then + CALL bdy_chem_value_cb05_vbs ( & + 4, chem(i,k,j), k, ic, config_flags, numgas ) else if (i_bdy_method .eq. 501) then tempfac=(t(i,k,j)+t0)*((p(i,k,j) + pb(i,k,j))/p1000mb)**rcp convfac=(p(i,k,j)+pb(i,k,j))/rgasuniv/tempfac @@ -2099,10 +2176,11 @@ integer FUNCTION get_last_gas(chem_opt) case (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & RACM_ESRLSORG_AQCHEM_KPP, RACM_ESRLSORG_KPP, RACMSORG_KPP, RACM_SOA_VBS_KPP,& - GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP) + GOCARTRACM_KPP,GOCARTRADM2) get_last_gas = p_ho2 - case (CBMZ_MOSAIC_4BIN_VBS2_KPP, SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP) + case (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_KPP )!BSINGH(12/13/2013): Added SAPRC 8 bin AQ case and non-aq on 04/03/2014 get_last_gas = p_ch4 @@ -2124,6 +2202,10 @@ integer FUNCTION get_last_gas(chem_opt) case (CBM4_KPP) get_last_gas = p_ho2 + + case (CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP) + get_last_gas = p_nh3 + case (CHEM_VASH) get_last_gas = 0 case (CHEM_VOLC) @@ -2141,7 +2223,10 @@ integer FUNCTION get_last_gas(chem_opt) case (MOZCART_KPP) get_last_gas = p_meko2 - case (MOZART_MOSAIC_4BIN_VBS0_KPP) + case (MOZART_MOSAIC_4BIN_KPP) + get_last_gas = p_meko2 + + case (MOZART_MOSAIC_4BIN_AQ_KPP) get_last_gas = p_meko2 case (CO2_TRACER,GHG_TRACER) ! No gas chemistry or deposition for GHGs @@ -2285,6 +2370,36 @@ SUBROUTINE sorgam_set_aer_bc_pnnl( chem, z, nch, config_flags ) bv_seas = mult*1.75 bv_soila = conmin +#if (CASENAME == 4) + if( z <= 2000. ) then + mult = 1.0 + elseif( z > 2000. & + .and. z <= 3000. ) then + mult = 1.0 - 0.00075*(z-2000.) + elseif( z > 3000. & + .and. z <= 5000. ) then + mult = 0.25 - 4.166666667e-5*(z-3000.) + else + mult = 0.125 + end if + bv_so4aj = mult*(0.0004810001+0.7271175)*0.97 + bv_so4ai = mult*(0.0004810001+0.7271175)*0.03 + bv_nh4aj = mult*0.2133708*0.97 + bv_nh4ai = mult*0.2133708*0.03 + bv_no3aj = mult*0.01399485*0.97 + bv_no3ai = mult*0.01399485*0.03 + bv_ecj = mult*0.04612048*0.97 + bv_eci = mult*0.04612048*0.03 + bv_p25j = mult*1.890001e-05*0.97 + bv_p25i = mult*1.890001e-05*0.03 + bv_antha = conmin + bv_orgpaj = mult*0.5844942*0.97 + bv_orgpai = mult*0.5844942*0.03 + bv_seas = conmin + bv_soila = conmin + +#endif + ! m3... calculations should match the very end of module_aerosols_sorgam.F !... i-mode (note that the 8 SOA species have bv=conmin) m3nuc = so4fac*bv_so4ai + nh4fac*bv_nh4ai + & @@ -2348,6 +2463,148 @@ SUBROUTINE sorgam_set_aer_bc_pnnl( chem, z, nch, config_flags ) END SUBROUTINE sorgam_set_aer_bc_pnnl !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE sorgam_vbs_set_aer_bc_pnnl( chem, z, nch, config_flags ) + USE module_data_sorgam_vbs, ONLY : dginia, dginin, dginic, esn36, esc36, esa36, seasfac, no3fac, nh4fac, so4fac, soilfac, anthfac, orgfac + + implicit none + + INTEGER,INTENT(IN ) :: nch + real,intent(in ) :: z + REAL,INTENT(INOUT ) :: chem + TYPE (grid_config_rec_type) , INTENT (in) :: config_flags + + REAL :: mult, & + m3acc, m3cor, m3nuc, & + bv_so4ai, bv_so4aj, & + bv_nh4ai, bv_nh4aj, & + bv_no3ai, bv_no3aj, & + bv_eci, bv_ecj, & + bv_p25i, bv_p25j, & + bv_orgpai,bv_orgpaj, & + bv_antha, bv_seas, bv_soila + + if( z <= 500. ) then + mult = 1.0 + elseif( z > 500. & + .and. z <= 1000. ) then + mult = 1.0 - 0.001074*(z-500.) + elseif( z > 1000. & + .and. z <= 5000. ) then + mult = 0.463 - 0.000111*(z-1000.) + else + mult = 0.019 + end if + + bv_so4aj = mult*0.300*0.97 + bv_so4ai = mult*0.300*0.03 + bv_nh4aj = mult*0.094*0.97 + bv_nh4ai = mult*0.094*0.03 + bv_no3aj = mult*0.001*0.97 + bv_no3ai = mult*0.001*0.03 + bv_ecj = mult*0.013*0.97 + bv_eci = mult*0.013*0.03 + bv_p25j = mult*4.500*0.97 + bv_p25i = mult*4.500*0.03 + bv_antha = mult*4.500/2.0 + bv_orgpaj = mult*0.088*0.97 + bv_orgpai = mult*0.088*0.03 + bv_seas = mult*1.75 + bv_soila = conmin + +#if (CASENAME == 4) + if( z <= 2000. ) then + mult = 1.0 + elseif( z > 2000. & + .and. z <= 3000. ) then + mult = 1.0 - 0.00075*(z-2000.) + elseif( z > 3000. & + .and. z <= 5000. ) then + mult = 0.25 - 4.166666667e-5*(z-3000.) + else + mult = 0.125 + end if + bv_so4aj = mult*(0.0004810001+0.7271175)*0.97 + bv_so4ai = mult*(0.0004810001+0.7271175)*0.03 + bv_nh4aj = mult*0.2133708*0.97 + bv_nh4ai = mult*0.2133708*0.03 + bv_no3aj = mult*0.01399485*0.97 + bv_no3ai = mult*0.01399485*0.03 + bv_ecj = mult*0.04612048*0.97 + bv_eci = mult*0.04612048*0.03 + bv_p25j = mult*1.890001e-05*0.97 + bv_p25i = mult*1.890001e-05*0.03 + bv_antha = conmin + bv_orgpaj = mult*0.5844942*0.97 + bv_orgpai = mult*0.5844942*0.03 + bv_seas = conmin + bv_soila = conmin + +#endif + +! m3... calculations should match the very end of module_aerosols_sorgam.F +!... i-mode (note that the 8 SOA species have bv=conmin) + m3nuc = so4fac*bv_so4ai + nh4fac*bv_nh4ai + & + no3fac*bv_no3ai + & + orgfac*8.0*conmin + orgfac*bv_orgpai + & + anthfac*bv_p25i + anthfac*bv_eci + +!... j-mode (note that the 8 SOA species have bv=conmin) + m3acc = so4fac*bv_so4aj + nh4fac*bv_nh4aj + & + no3fac*bv_no3aj + & + orgfac*8.0*conmin + orgfac*bv_orgpaj + & + anthfac*bv_p25j + anthfac*bv_ecj + +!...c-mode + m3cor = soilfac*bv_soila + seasfac*bv_seas + & + anthfac*bv_antha + +! Cannot set_sulf here because it is a "radm2" species whose bc value +! is set via bdy_chem_value. Instead, xl(iref(p_sulf-1),:) is set to +! the value conmin in subroutine gasprofile_init_pnnl +! if( nch == p_sulf ) chem = conmin !as per rce's 0 recommendation + + if( nch == p_so4aj ) chem = bv_so4aj + if( nch == p_so4ai ) chem = bv_so4ai + if( nch == p_nh4aj ) chem = bv_nh4aj + if( nch == p_nh4ai ) chem = bv_nh4ai + if( nch == p_no3aj ) chem = bv_no3aj + if( nch == p_no3ai ) chem = bv_no3ai + if( nch == p_ecj ) chem = bv_ecj + if( nch == p_eci ) chem = bv_eci + if( nch == p_p25j ) chem = bv_p25j + if( nch == p_p25i ) chem = bv_p25i + if( nch == p_orgpaj ) chem = bv_orgpaj + if( nch == p_orgpai ) chem = bv_orgpai + + if( nch == p_asoa1j) chem = conmin + if( nch == p_asoa1i) chem = conmin + if( nch == p_asoa2j) chem = conmin + if( nch == p_asoa2i) chem = conmin + if( nch == p_asoa3j) chem = conmin + if( nch == p_asoa3i) chem = conmin + if( nch == p_asoa4j) chem = conmin + if( nch == p_asoa4i) chem = conmin + if( nch == p_bsoa1j ) chem = conmin + if( nch == p_bsoa1i ) chem = conmin + if( nch == p_bsoa2j ) chem = conmin + if( nch == p_bsoa2i ) chem = conmin + if( nch == p_bsoa3j ) chem = conmin + if( nch == p_bsoa3i ) chem = conmin + if( nch == p_bsoa4j ) chem = conmin + if( nch == p_bsoa4i ) chem = conmin + + if( nch == p_antha ) chem = bv_antha + if( nch == p_soila ) chem = bv_soila + if( nch == p_seas ) chem = bv_seas + + if( nch == p_nu0 ) chem = m3nuc/((dginin**3)*esn36) + if( nch == p_ac0 ) chem = m3acc/((dginia**3)*esa36) + if( nch == p_corn ) chem = m3cor/((dginic**3)*esc36) + + END SUBROUTINE sorgam_vbs_set_aer_bc_pnnl + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !**************************************************************** ! * ! SUBROUTINE TO OVERWRITE THE PREDEFINED OZONE PROFILE * diff --git a/wrfv2_fire/chem/module_input_tracer.F b/wrfv2_fire/chem/module_input_tracer.F index 9c403682..aa1ca339 100755 --- a/wrfv2_fire/chem/module_input_tracer.F +++ b/wrfv2_fire/chem/module_input_tracer.F @@ -34,7 +34,7 @@ MODULE module_input_tracer USE module_input_tracer_data -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_state_description, only:tracer_smoke,tracer_test1,tracer_test2,param_first_scalar,p_tr17_1,p_tr17_2,p_tr17_3,p_tr17_4,p_tr17_5,p_tr17_6,p_tr17_7,p_tr17_8 #else USE module_state_description, only:tracer_test1,tracer_test2,param_first_scalar,p_tr17_1,p_tr17_2,p_tr17_3,p_tr17_4,p_tr17_5,p_tr17_6,p_tr17_7,p_tr17_8 @@ -52,12 +52,12 @@ SUBROUTINE initialize_tracer (chem,chem_in_opt, & INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte REAL, DIMENSION(ims:ime,kms:kme,jms:jme,num_chem ), INTENT(INOUT) :: chem -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) if(chem_in_opt == 1 )return #endif if (tracer_opt == TRACER_TEST1)then chem(:,:,:,:)=.0 -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) else if(tracer_opt == TRACER_TEST2)then chem(:,:,:,:)=.0 else if(tracer_opt == TRACER_SMOKE)then @@ -133,7 +133,7 @@ SUBROUTINE flow_dep_bdy_tracer ( chem, & if (tracer_opt == TRACER_TEST1 ) then i_bdy_method = 2 end if -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) if (tracer_opt == TRACER_TEST2 ) then i_bdy_method = 2 end if @@ -165,7 +165,7 @@ SUBROUTINE flow_dep_bdy_tracer ( chem, & else chem(i,k,j)= tracer_bv_def endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) else if (i_bdy_method .eq. 6) then CALL bdy_tracer_value ( chem(i,k,j),chem_bys(i,k,1),chem_btys(i,k,1),dt,ic) #endif @@ -198,7 +198,7 @@ SUBROUTINE flow_dep_bdy_tracer ( chem, & else chem(i,k,j)= tracer_bv_def endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) else if (i_bdy_method .eq. 6) then CALL bdy_tracer_value ( chem(i,k,j),chem_bye(i,k,1),chem_btye(i,k,1),dt,ic) #endif @@ -232,7 +232,7 @@ SUBROUTINE flow_dep_bdy_tracer ( chem, & else chem(i,k,j)= tracer_bv_def endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) else if (i_bdy_method .eq. 6) then CALL bdy_tracer_value ( chem(i,k,j),chem_bxs(j,k,1),chem_btxs(j,k,1),dt,ic) #endif @@ -266,7 +266,7 @@ SUBROUTINE flow_dep_bdy_tracer ( chem, & else chem(i,k,j)= tracer_bv_def endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) else if (i_bdy_method .eq. 6) then CALL bdy_tracer_value ( chem(i,k,j),chem_bxe(j,k,1),chem_btxe(j,k,1),dt,ic) #endif @@ -281,7 +281,7 @@ SUBROUTINE flow_dep_bdy_tracer ( chem, & END SUBROUTINE flow_dep_bdy_tracer #else -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) SUBROUTINE flow_dep_bdy_tracer ( chem, chem_b,chem_bt,dt, & spec_bdy_width,z, & ijds, ijde,have_bcs_chem, & diff --git a/wrfv2_fire/chem/module_lightning_nox_decaria.F b/wrfv2_fire/chem/module_lightning_nox_decaria.F index 4b61cff4..2f544a75 100644 --- a/wrfv2_fire/chem/module_lightning_nox_decaria.F +++ b/wrfv2_fire/chem/module_lightning_nox_decaria.F @@ -93,10 +93,10 @@ SUBROUTINE lightning_nox_decaria ( & INTEGER :: ktop,kbtm,kupper,klower REAL :: ic_fr, cg_fr, delta ! reconsolidated flashrates REAL :: reflmax, cellmax - REAL :: term2, B + REAL :: term2, B, B_denom CHARACTER (LEN=250) :: message REAL, DIMENSION( kps:kpe ) :: cellcount - REAL, DIMENSION( kps:kpe ) :: z_average, t_average, p_average, rho_average, molesofair + REAL, DIMENSION( kps:kpe ) :: z_average, t_average, p_average, rho_average, conv REAL, DIMENSION( kps:kpe ) :: fd, fd2, dz ! fd = distribution REAL, PARAMETER :: refl_threshold = 20. @@ -134,12 +134,15 @@ SUBROUTINE lightning_nox_decaria ( & ! Average z, t, p, rho CALL horizontalAverage( z( ips:ipe,kps:kpe,jps:jpe ), ips, ipe, kps, kpe, jps, jpe, z_average ) CALL horizontalAverage( t( ips:ipe,kps:kpe,jps:jpe ), ips, ipe, kps, kpe, jps, jpe, t_average ) + CALL horizontalAverage( p( ips:ipe,kps:kpe,jps:jpe ), ips, ipe, kps, kpe, jps, jpe, p_average ) CALL horizontalAverage( rho( ips:ipe,kps:kpe,jps:jpe ), ips, ipe, kps, kpe, jps, jpe, rho_average ) - molesofair(kps:kpe) = rho_average(kps:kpe) * 1E3 * dx * dy / .02897 ! # moles per km in z - +! molesofair(kps:kpe) = rho_average(kps:kpe) * 1E3 * dx * dy / .02897 ! # moles per km in z ! term2 = 30 * 8.3145E6/dx/dy/28.96/100./100. + conv(kps:kpe) = 8.314 *t_average(kps:kpe) / (dx * dy) ! conversion term with units J/(mol-m2) + + CALL kfind ( cellcount, t_average, & ltng_temp_upper,ltng_temp_lower, cellcount_method, & ips, ipe, jps, jpe, kps, kpe, & @@ -147,24 +150,30 @@ SUBROUTINE lightning_nox_decaria ( & ktop,kbtm,kupper,klower ) ! Calculates IC distribution - IF (( ic_fr .gt. 0 ) .and. (( ktop .gt. klower ) .and. (kbtm .lt. ktop) ) )THEN +!IF (( ic_fr .gt. 0 ) .and. (( ktop .gt. klower ) .and. (kbtm .lt. ktop) ) )THEN + IF (( ic_fr > 0 ) .and. (( ktop > klower ) .and. (kbtm < klower) ) )THEN call bellcurve(kbtm,ktop,klower,z_average, kps,kpe, fd, dz) if (ktop .gt. kupper) then call bellcurve(kbtm,ktop,kupper,z_average, kps,kpe, fd2, dz) - fd(kbtm:ktop) = 0.5*( fd(kbtm:ktop) + fd2(kbtm:ktop) ) + fd(kbtm:ktop) = 0.5*( fd(kbtm:ktop) + fd2(kbtm:ktop) ) ! unitless endif -! B = N_IC/sum(f(kbtm:ktop)*p_average(kbtm:ktop)) +! B = N_IC/sum(f(kbtm:ktop)*p_average(kbtm:ktop)) ! *** used in calculating NO + B_denom = DOT_PRODUCT( fd(kbtm:ktop),p_average(kbtm:ktop) ) ! N/m2 + DO k=kbtm,ktop if ( cellcount(k) .gt. 0. ) THEN ! delta = term2*B*fd(k)*t_average(k)*ic_fr/cellcount(k)/dz(k)/100. !* implementation note: 1) ic_fr * N_IC/cellcount gives moles of NO in the column !* 2) Multiplying by fd gives the # moles per level - !* 3) Divide by moles of air gives mixing ratio + !* 3) Convert to mol NO/mol air per minute !* 4) Multiply by 1E6 gives ppmv - delta = (ic_fr * N_IC / cellcount(k)) * fd(k) / (molesofair(k)*dz(k)) * 1E6 - WRITE(message, * ) ' LNOx_driver: k, delta, cellcount, fd = ', k, delta, cellcount(k), fd(k) - CALL wrf_debug ( 100, message ) + + delta = (ic_fr * N_IC / cellcount(k)) * fd(k) / B_denom * conv(k)/dz(k) * 1E6 +!units: flash/sec * mol/flash /() * m2/ N * J/(mol-m2) / m * ppmv/(mol NO/mol air) +!units: flash/sec * mol/flash * m2/ N * N-m/(mol-m3) * ppmv/(mol NO/mol air) +!units: ppmv/sec + where(refl(ips:ipe,k,jps:jpe) .gt. refl_threshold ) lnox_ic_tend(ips:ipe,k,jps:jpe) = delta endwhere @@ -175,33 +184,34 @@ SUBROUTINE lightning_nox_decaria ( & !----------------------------------------------------------------- ! Calculates CG distribution - IF ((cg_fr .gt. 0 ) .and. (( ktop .gt. klower ) .and. (kbtm .lt. ktop) ) ) THEN +!IF ((cg_fr .gt. 0 ) .and. (( ktop .gt. klower ) .and. (kbtm .lt. ktop) ) ) THEN + IF ((cg_fr > 0 ) .and. (( ktop > klower ) .and. (kbtm < klower) ) ) THEN call bellcurve(kps,ktop,klower,z_average, kps,kpe, fd, dz) ! B = N_CG/(sum(fd(kps:ktop)*p_average(kps:ktop))) -! delta = term2*B*fd(k)*t_average(k)*cg_fr/cellcount(kbtm)/dz(k)/100. - delta = (cg_fr * N_CG / cellcount(kbtm)) * fd(k) / (molesofair(k)*dz(k)) * 1E6 - ! below cloud - !* implementation note: previously, between kps & kbtm is practically excluded because of - !* the test for refl > 20 - !* implementation note: using "where" here would end up reevaluating refl(ips:ipe,kbtm,jps:jpe) - !* multiple times because of the kps,kbtm-1 loop. - do i=ips,ipe - do j=jps,jpe - if ( refl(i,kbtm,j) .gt. refl_threshold ) THEN - lnox_cg_tend(i,kps:(kbtm-1),j) = delta - ENDIF - enddo - enddo - - ! within cloud - do k = kbtm,ktop - !delta = term2*B*fd(k)*t_average(k)*cg_fr/cellcount(k)/dz(k)/100. - delta = (cg_fr * N_CG / cellcount(k)) * fd(k) / (molesofair(k)*dz(k)) * 1E6 - where( refl(ips:ipe,k,jps:jpe) .gt. refl_threshold ) - lnox_cg_tend(ips:ipe,k,jps:jpe) = delta - endwhere - enddo + B_denom = DOT_PRODUCT( fd(kbtm:ktop),p_average(kbtm:ktop) ) ! N/m2 + + k = ktop + + DO WHILE (k .ge. kps) + IF (cellcount(k) .gt. 0) THEN + +! delta = (cg_fr * N_CG / cellcount(k)) * fd(k) / (molesofair(k)*dz(k)) * 1E6 + delta = (cg_fr * N_CG / cellcount(k)) * fd(k) / B_denom * conv(k)/dz(k) * 1E6 +!units: flash/sec * mol/flash /() * m2/ N * J/(mol-m2) / m * ppmv/(mol NO/mol air) +!units: flash/sec * mol/flash * m2/ N * N-m/(mol-m3) * ppmv/(mol NO/mol air) +!units: ppmv/sec + + where( refl(ips:ipe,k,jps:jpe) .gt. refl_threshold ) + lnox_cg_tend(ips:ipe,k,jps:jpe) = delta + endwhere + + ENDIF + + k = k - 1 !07/23/14 KAC added + + ENDDO + ENDIF END SUBROUTINE lightning_nox_decaria @@ -258,7 +268,7 @@ SUBROUTINE bellcurve ( k_min, k_max, k_mu, z, kps,kpe, f, dz ) ENDDO ! Normalize - cuml_f_dist = sum(f(k_min:k_max) * dz(k_min:k_max)) + cuml_f_dist = DOT_PRODUCT(dz(k_min:k_max),f(k_min:k_max)) f(k_min:k_max) = f(k_min:k_max)*dz(k_min:k_max)/cuml_f_dist END SUBROUTINE bellcurve diff --git a/wrfv2_fire/chem/module_mixactivate_wrappers.F b/wrfv2_fire/chem/module_mixactivate_wrappers.F index e5bb8830..f3ccfcb1 100644 --- a/wrfv2_fire/chem/module_mixactivate_wrappers.F +++ b/wrfv2_fire/chem/module_mixactivate_wrappers.F @@ -25,6 +25,7 @@ subroutine mosaic_mixactivate ( & ddvel, z, dz8w, p_at_w, t_at_w, exch_h, & qv, qc, qi, qndrop3d, f_qc, f_qi, chem, & ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + qsrflx, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -76,12 +77,14 @@ subroutine mosaic_mixactivate ( & ccn1,ccn2,ccn3,ccn4,ccn5,ccn6 ! number conc of aerosols activated at supersat type(grid_config_rec_type), intent(in) :: config_flags + real, intent(out) :: qsrflx(ims:ime, jms:jme, num_chem) ! wet deposition flux of aerosol ! local vars - real qsrflx(ims:ime, jms:jme, num_chem) ! dry deposition flux of aerosol +! real qsrflx(ims:ime, jms:jme, num_chem) ! wet deposition flux of aerosol real sumhygro,sumvol integer i,j,k,l,m,n real hygro( its:ite, kts:kte, jts:jte, maxd_asize, maxd_atype ) ! bulk + qsrflx(:,:,:) = 0.0 ! calculate volume-weighted bulk hygroscopicity for each type and size do 100 j=jts,jte @@ -128,6 +131,7 @@ end subroutine mosaic_mixactivate subroutine mosaic_mixactivate_init( & config_flags, chem, scalar, & + chem_in_opt, & !BSINGH(12/04/13): Added for SAPRC 8 bin vbs ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -143,7 +147,7 @@ subroutine mosaic_mixactivate_init( & integer, intent(in) :: & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte - + INTEGER, INTENT(IN ) :: chem_in_opt !BSINGH(12/04/13): Added for SAPRC 8 bin vbs real, intent(inout), & dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & chem @@ -164,14 +168,32 @@ subroutine mosaic_mixactivate_init( & if( cw_phase > 0 ) then !sanity check in case using prognostic !drop number without aq. chemistry - do n=1,ntype_aer - do m=1,nsize_aer(n) - chem(its:ite,kts:kte,jts:jte,numptr_aer(m,n,cw_phase)) = 0. - do l=1,ncomp_aer(n) - chem(its:ite,kts:kte,jts:jte,massptr_aer(l,m,n,cw_phase)) = 0. - end do ! comp - end do ! size - end do ! type + if (config_flags%chem_in_opt == 1) then !added by MS to transfer cloud borne species to interstitial species when using chem_in_opt=1 + do n=1,ntype_aer + do m=1,nsize_aer(n) + chem(its:ite,kts:kte,jts:jte,numptr_aer(m,n,cw_phase)) = 0. + do l=1,ncomp_aer(n) + if( ai_phase > 0 ) then + ! add cloud borne aerosol mass to interstitial aerosol mass + chem(its:ite,kts:kte,jts:jte,massptr_aer(l,m,n,ai_phase))= & + chem(its:ite,kts:kte,jts:jte,massptr_aer(l,m,n,ai_phase)) + & + chem(its:ite,kts:kte,jts:jte,massptr_aer(l,m,n,cw_phase)) + + endif ! for ai_phase>0 + chem(its:ite,kts:kte,jts:jte,massptr_aer(l,m,n,cw_phase)) = 0. + end do ! comp + end do ! size + end do + else + do n=1,ntype_aer + do m=1,nsize_aer(n) + chem(its:ite,kts:kte,jts:jte,numptr_aer(m,n,cw_phase)) = 0. + do l=1,ncomp_aer(n) + chem(its:ite,kts:kte,jts:jte,massptr_aer(l,m,n,cw_phase)) = 0. + end do ! comp + end do ! size + end do ! type + endif !chem_in_opt end if end subroutine mosaic_mixactivate_init @@ -286,5 +308,109 @@ subroutine sorgam_mixactivate ( & end subroutine sorgam_mixactivate + subroutine sorgam_vbs_mixactivate ( & + id, ktau, dtstep, config_flags, idrydep_onoff, & + rho_phy, t_phy, w, cldfra, cldfra_old, & + ddvel, z, dz8w, p_at_w, t_at_w, exch_h, & + qv, qc, qi, qndrop3d, f_qc, f_qi, chem, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure, only: grid_config_rec_type + use module_state_description, only: num_chem + use module_data_sorgam_vbs + use module_mixactivate, only: mixactivate + +! wrapper to call mixactivate for sorgam description of aerosol + + implicit none + +! subr arguments + integer, intent(in) :: & + id, ktau, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + idrydep_onoff + + real, intent(in) :: dtstep + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + rho_phy, t_phy, w, & + z, dz8w, p_at_w, t_at_w, exch_h + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme ) :: cldfra, cldfra_old + + real, intent(in), & + dimension( its:ite, jts:jte, num_chem ) :: ddvel + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + qv, qc, qi + + LOGICAL, intent(in) :: f_qc, f_qi + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + qndrop3d + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem + real, intent(out), dimension(ims:ime,kms:kme,jms:jme) :: nsource, & + ccn1,ccn2,ccn3,ccn4,ccn5,ccn6 ! number conc of aerosols activated at supersat + + type(grid_config_rec_type), intent(in) :: config_flags + +! local vars + real qsrflx(ims:ime, jms:jme, num_chem) ! dry deposition flux of aerosol + real sumhygro,sumvol + integer i,j,k,l,m,n + real hygro( its:ite, kts:kte, jts:jte,maxd_asize, maxd_atype ) + +! calculate volume-weighted bulk hygroscopicity for each type and size + + do 100 j=jts,jte + do 100 k=kts,kte + do 100 i=its,ite + do n=1,ntype_aer + do m=1,nsize_aer(n) + sumhygro=0 + sumvol=0 + do l=1,ncomp_aer(n) + sumhygro = sumhygro+hygro_aer(l,n)* & + chem(i,k,j,massptr_aer(l,m,n,ai_phase))/dens_aer(l,n) + sumvol = sumvol+chem(i,k,j,massptr_aer(l,m,n,ai_phase))/dens_aer(l,n) + end do ! comp + hygro(i,k,j,m,n)=sumhygro/sumvol + end do ! size + end do ! type + 100 continue + + +! check arguments of mixactivate for consistency between send, receive +! 06-nov-2005 rce - id & ktau added to arg list + call mixactivate( msectional, & + chem, num_chem, qv, qc, qi, qndrop3d, & + t_phy, w, ddvel, idrydep_onoff, & + maxd_acomp, maxd_asize, maxd_atype, maxd_aphase, & + ncomp_aer, nsize_aer, ntype_aer, nphase_aer, & + numptr_aer, massptr_aer, dlo_sect, dhi_sect, sigmag_aer, dcen_sect, & + dens_aer, mw_aer, & + waterptr_aer, hygro, ai_phase, cw_phase, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + rho_phy, z, dz8w, p_at_w, t_at_w, exch_h, & + cldfra, cldfra_old, qsrflx, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + id, ktau, dtstep, & + f_qc, f_qi ) + + end subroutine sorgam_vbs_mixactivate END MODULE module_mixactivate_wrappers diff --git a/wrfv2_fire/chem/module_mosaic_addemiss.F b/wrfv2_fire/chem/module_mosaic_addemiss.F index 38378c76..ac52cb28 100644 --- a/wrfv2_fire/chem/module_mosaic_addemiss.F +++ b/wrfv2_fire/chem/module_mosaic_addemiss.F @@ -34,6 +34,7 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & !czhao ktau,p8w, u_phy,v_phy,rho_phy,g,dx,erod, & ! GOCART DUST dust_emiss_active, seasalt_emiss_active, & + dust_flux, seas_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -60,6 +61,8 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & INTEGER, INTENT(IN) :: dust_emiss_active, seasalt_emiss_active, biom_active, dust_opt + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: dust_flux, seas_flux + !czhao INTEGER, INTENT(IN) :: ktau REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & @@ -389,7 +392,8 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_oc_25_10) chem_select_1 : SELECT CASE( config_flags%chem_opt ) - CASE(CBMZ_MOSAIC_4BIN_VBS2_KPP, SAPRC99_MOSAIC_4BIN_VBS2_KPP) ! Set the oc to zero for VBS + CASE(SAPRC99_MOSAIC_4BIN_VBS2_KPP, SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_KPP)!BSINGH(12/04/2013): Added SAPRC 8 bin and non-aq on 04/03/2014! Set the oc to zero for VBS aem_oc = 0.0 END SELECT chem_select_1 @@ -417,6 +421,24 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & aem_co3 = 0.0 aem_msa = 0.0 + chem_select_2 : SELECT CASE( config_flags%chem_opt ) + CASE(MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP) + aem_nh4 = fr_aem_mosaic_f(n)*emis_ant(i,k,j,p_e_nh4j) & + + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_nh4c) & + + fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_nh4i) & + + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_nh4j) + + aem_na = fr_aem_mosaic_f(n)*emis_ant(i,k,j,p_e_naj) & + + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_nac) & + + fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_nai) & + + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_naj) + + aem_cl = fr_aem_mosaic_f(n)*emis_ant(i,k,j,p_e_clj) & + + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_clc) & + + fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_cli) & + + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_clj) + END SELECT chem_select_2 + ! compute number emissions ! first sum the mass-emissions/density aem_num = & @@ -504,6 +526,7 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & if (seasalt_emiss_active > 0) & call mosaic_seasalt_emiss( & id, dtstep, u10, v10, alt, dz8w, xland, config_flags, chem, & + seas_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, seasalt_emiss_active ) @@ -528,6 +551,7 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & call mosaic_dust_gocartemis (ktau,dtstep,config_flags%num_soil_layers,alt,u_phy, & v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, & ivgtyp,isltyp,xland,dx,g, & + dust_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -544,6 +568,7 @@ END subroutine mosaic_addemiss !---------------------------------------------------------------------- subroutine mosaic_seasalt_emiss( & id, dtstep, u10, v10, alt, dz8w, xland, config_flags, chem, & + seas_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, seasalt_emiss_active ) @@ -582,6 +607,8 @@ subroutine mosaic_seasalt_emiss( & REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & INTENT(IN ) :: alt, dz8w + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: seas_flux + ! local variables integer i, j, k, l, l_na, l_cl, n, l_oc integer iphase, itype @@ -660,6 +687,7 @@ subroutine mosaic_seasalt_emiss( & ssemfact_mass(n,itype) = ssemfact_mass(n,itype)*1.0e6 end do + seas_flux(:,:) = 0.0 ! loop over i,j and apply seasalt emissions k = kts @@ -685,6 +713,9 @@ subroutine mosaic_seasalt_emiss( & factbb = factaa * dumspd10 if(seasalt_emiss_active == 1)then + + seas_flux(i,j) = dumspd10*SUM(ssemfact_mass(1:nsize_aer(itype),itype)) + ! apportion seasalt mass emissions assumming that seasalt is pure nacl fracna = mw_na_aer / (mw_na_aer + mw_cl_aer) fraccl = 1.0 - fracna @@ -1560,19 +1591,36 @@ subroutine mosaic_dust_emiss( slai,ust, smois, ivgtyp, isltyp, & ! sz(4)=0.84 itype=1 if (nsize_aer(itype) .eq. 8) then - sz(1)=0.0 - sz(2)=0.0 - sz(3)=0.0005 - sz(4)=0.0095 - sz(5)=0.01 - sz(6)=0.06 - sz(7)=0.20 - sz(8)=0.72 + !BSINGH(12/11/2013): Based on the suggestions by Manish Shrivastva, sz variable is modified below. + !Original values are commented out + !sz(1)=0.0 + !sz(2)=0.0 + !sz(3)=0.0005 + !sz(4)=0.0095 + !sz(5)=0.01 + !sz(6)=0.06 + !sz(7)=0.20 + !sz(8)=0.72 + + sz(1)=0 + sz(2)=1.78751e-06 + sz(3)=0.000273786 + sz(4)=0.00847978 + sz(5)=0.056055 + sz(6)=0.0951896 + sz(7)=0.17 + sz(8)=0.67 else if (nsize_aer(itype) .eq. 4) then - sz(1)=0.0 - sz(2)=0.01 - sz(3)=0.07 - sz(4)=0.92 + !BSINGH(12/11/2013): Based on the suggestions by Manish Shrivastva, sz variable is modified below. + !Original values are commented out + !sz(1)=0.0 + !sz(2)=0.01 + !sz(3)=0.07 + !sz(4)=0.92 + sz(1)=1.78751e-06 + sz(2)=0.00875357 + sz(3)=0.1512446 + sz(4)=0.84 sz(5)=0.0 sz(6)=0.0 sz(7)=0.0 @@ -1772,6 +1820,7 @@ END subroutine mosaic_dust_emiss subroutine mosaic_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, & ivgtyp,isltyp,xland,dx,g, & + dust_flux, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -1808,6 +1857,7 @@ subroutine mosaic_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & u_phy,v_phy,rho_phy REAL, INTENT(IN ) :: dt,dx,g + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: dust_flux ! ! local variables ! @@ -1869,7 +1919,6 @@ subroutine mosaic_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & itype = 1 iphase = ai_phase -! 20130603 acd_ck_emiss start ! added option for 4bin WRF IF (nsize_aer(itype) == 4) THEN sz(1) = sz(1) + sz(2) @@ -1877,10 +1926,12 @@ subroutine mosaic_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & sz(3) = sz(5) + sz(6) sz(4) = sz(7) + sz(8) ENDIF -! 20130603 acd_ck_emiss end conver=1.e-9 converi=1.e9 + + dust_flux(:,:) = 0.0 + ! ! number of dust bins nmx=5 @@ -1922,6 +1973,9 @@ subroutine mosaic_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & !sum up the dust emission from 0.1-10 um in radius ! unit change from kg/timestep/cell to ug/m2/s totalemis=(sum(bems(1:5))/dt)*converi/dxy + + dust_flux(i,j) = totalemis + !totalemis=totalemis*rscale !to account for the particles larger than 10 um ! based on assumed size distribution jdustemis = totalemis*accfrac ! accumulation mode @@ -1946,13 +2000,11 @@ subroutine mosaic_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & ! mass1part is mass of a single particle in ug, density of dust ~2.5 g cm-3 if (n <= 5) densdust=2.5 if (n > 5 ) densdust=2.65 -! 20130603 acd_ck_emiss start ! added option for 4bin WRF if (nsize_aer(itype) == 4) then if (n <= 2) densdust=2.5 if (n > 2 ) densdust=2.65 endif -! 20130603 acd_ck_emiss end mass1part=0.523598*(dcen_sect(n,itype)**3)*densdust*1.0e06 l = numptr_aer(n,itype,iphase) if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + & diff --git a/wrfv2_fire/chem/module_mosaic_cloudchem.F b/wrfv2_fire/chem/module_mosaic_cloudchem.F index 9938dece..351eaf83 100644 --- a/wrfv2_fire/chem/module_mosaic_cloudchem.F +++ b/wrfv2_fire/chem/module_mosaic_cloudchem.F @@ -411,7 +411,9 @@ subroutine interface_to_aqoperator1( & p_nh3, p_hno3, p_hcl, p_sulf, p_h2so4, p_hcho, & p_ora1, p_so2, p_h2o2, p_o3, p_ho, & p_ho2, p_no3, p_no, p_no2, p_hono, & - p_pan, p_ch3o2, p_ch3oh, p_op1 +! p_pan, p_ch3o2, p_ch3oh, p_op1 + p_pan, p_ch3o2, p_ch3oh, p_op1, & + p_hcooh, p_ch3ooh use module_data_cmu_bulkaqchem, only: & meqn1max, naers, ngas, & @@ -568,13 +570,14 @@ subroutine interface_to_aqoperator1( & gas(nga ) = rbox(p_nh3 ) * factgas gas(ngn ) = rbox(p_hno3 ) * factgas - gas(ngc ) = rbox(p_hcl ) * factgas + if(p_hcl > param_first_scalar ) gas(ngc ) = rbox(p_hcl ) * factgas if(p_sulf > param_first_scalar ) gas(ng4 ) = rbox(p_sulf ) * factgas if(p_h2so4 > param_first_scalar ) gas(ng4 ) = rbox(p_h2so4 ) * factgas gas(nghcho ) = rbox(p_hcho ) * factgas - gas(nghcooh ) = rbox(p_ora1 ) * factgas + if(p_ora1 > param_first_scalar ) gas(nghcooh ) = rbox(p_ora1 ) * factgas + if(p_hcooh > param_first_scalar ) gas(nghcooh ) = rbox(p_hcooh ) * factgas gas(ngso2 ) = rbox(p_so2 ) * factgas gas(ngh2o2 ) = rbox(p_h2o2 ) * factgas gas(ngo3 ) = rbox(p_o3 ) * factgas @@ -588,7 +591,8 @@ subroutine interface_to_aqoperator1( & gas(ngpan ) = rbox(p_pan ) * factgas gas(ngch3o2 ) = rbox(p_ch3o2 ) * factgas gas(ngch3oh ) = rbox(p_ch3oh ) * factgas - gas(ngch3o2h) = rbox(p_op1 ) * factgas + if(p_op1 > param_first_scalar ) gas(ngch3o2h) = rbox(p_op1 ) * factgas + if(p_ch3ooh > param_first_scalar ) gas(ngch3o2h) = rbox(p_ch3ooh) * factgas ! compute bulk activated-aerosol mixing ratios aerosol(:) = 0.0 @@ -815,13 +819,14 @@ subroutine interface_to_aqoperator1( & ! rbox(p_nh3 ) = gas(nga ) / factgas rbox(p_hno3 ) = gas(ngn ) / factgas - rbox(p_hcl ) = gas(ngc ) / factgas + if(p_hcl .gt. param_first_scalar) rbox(p_hcl ) = gas(ngc ) / factgas if(p_sulf .gt. param_first_scalar) rbox(p_sulf ) = gas(ng4) / factgas if(p_h2so4 .gt. param_first_scalar) rbox(p_h2so4 ) = gas(ng4) / factgas rbox(p_hcho ) = gas(nghcho ) / factgas - rbox(p_ora1 ) = gas(nghcooh ) / factgas + if(p_ora1 > param_first_scalar ) rbox(p_ora1 ) = gas(nghcooh ) / factgas + if(p_hcooh > param_first_scalar ) rbox(p_hcooh) = gas(nghcooh ) / factgas rbox(p_so2 ) = gas(ngso2 ) / factgas rbox(p_h2o2 ) = gas(ngh2o2 ) / factgas rbox(p_o3 ) = gas(ngo3 ) / factgas @@ -835,7 +840,8 @@ subroutine interface_to_aqoperator1( & rbox(p_pan ) = gas(ngpan ) / factgas rbox(p_ch3o2 ) = gas(ngch3o2 ) / factgas rbox(p_ch3oh ) = gas(ngch3oh ) / factgas - rbox(p_op1 ) = gas(ngch3o2h) / factgas + if(p_op1 > param_first_scalar ) rbox(p_op1 ) = gas(ngch3o2h) / factgas + if(p_ch3ooh > param_first_scalar ) rbox(p_ch3ooh) = gas(ngch3o2h) / factgas gas_aqfrac_box(:) = 0.0 @@ -843,7 +849,7 @@ subroutine interface_to_aqoperator1( & gas_aqfrac_box(p_nh3 ) = gas_aqfrac_cmu(nga ) if (p_hno3 .le. numgas_aqfrac) & gas_aqfrac_box(p_hno3 ) = gas_aqfrac_cmu(ngn ) - if (p_hcl .le. numgas_aqfrac) & + if (p_hcl .le. numgas_aqfrac .and. p_hcl .gt. param_first_scalar) & gas_aqfrac_box(p_hcl ) = gas_aqfrac_cmu(ngc ) if (p_sulf .le. numgas_aqfrac .and. p_sulf .gt. param_first_scalar) & gas_aqfrac_box(p_sulf ) = gas_aqfrac_cmu(ng4 ) @@ -852,8 +858,10 @@ subroutine interface_to_aqoperator1( & if (p_hcho .le. numgas_aqfrac) & gas_aqfrac_box(p_hcho ) = gas_aqfrac_cmu(nghcho ) - if (p_ora1 .le. numgas_aqfrac) & + if (p_ora1 .le. numgas_aqfrac .and. p_ora1 .gt. param_first_scalar) & gas_aqfrac_box(p_ora1 ) = gas_aqfrac_cmu(nghcooh ) + if (p_hcooh .le. numgas_aqfrac .and. p_hcooh .gt. param_first_scalar) & + gas_aqfrac_box(p_hcooh ) = gas_aqfrac_cmu(nghcooh ) if (p_so2 .le. numgas_aqfrac) & gas_aqfrac_box(p_so2 ) = gas_aqfrac_cmu(ngso2 ) if (p_h2o2 .le. numgas_aqfrac) & @@ -879,8 +887,10 @@ subroutine interface_to_aqoperator1( & gas_aqfrac_box(p_ch3o2 ) = gas_aqfrac_cmu(ngch3o2 ) if (p_ch3oh .le. numgas_aqfrac) & gas_aqfrac_box(p_ch3oh ) = gas_aqfrac_cmu(ngch3oh ) - if (p_op1 .le. numgas_aqfrac) & + if (p_op1 .le. numgas_aqfrac .and. p_op1 .gt. param_first_scalar) & gas_aqfrac_box(p_op1 ) = gas_aqfrac_cmu(ngch3o2h) + if (p_ch3ooh.le. numgas_aqfrac .and. p_ch3ooh .gt. param_first_scalar) & + gas_aqfrac_box(p_ch3ooh) = gas_aqfrac_cmu(ngch3o2h) rbulk_cwaer(l_so4_aqyy,2) = aerosol(na4) / factaerso4 rbulk_cwaer(l_no3_aqyy,2) = aerosol(nan) / factaerno3 diff --git a/wrfv2_fire/chem/module_mosaic_driver.F b/wrfv2_fire/chem/module_mosaic_driver.F index 17cca424..421c9b8c 100644 --- a/wrfv2_fire/chem/module_mosaic_driver.F +++ b/wrfv2_fire/chem/module_mosaic_driver.F @@ -154,6 +154,11 @@ subroutine mosaic_aerchem_driver( & use module_mosaic_coag, only: mosaic_coag_1clm use module_peg_util, only: peg_error_fatal, peg_message + use module_data_mosaic_therm, only: glysoa_param, & + glysoa_param_off, glysoa_param_simple, glysoa_param_complex + use module_state_description, only: mozart_mosaic_4bin_kpp, & + mozart_mosaic_4bin_aq_kpp + implicit none !----------------------------------------------------------------------- @@ -290,6 +295,11 @@ subroutine mosaic_aerchem_driver( & iprint_mosaic_input_ok = 0 end if + glysoa_param = glysoa_param_off + if (config_flags%chem_opt == mozart_mosaic_4bin_kpp) & + glysoa_param = glysoa_param_simple + if (config_flags%chem_opt == mozart_mosaic_4bin_aq_kpp) & + glysoa_param = glysoa_param_complex ! ktmaps,ktmape = first/last wrf kt for which aer chem is done ktmaps = kts @@ -508,7 +518,79 @@ subroutine sum_pm_mosaic ( & + chem(i,k,j,lptr_na_aer(n,itype,iphase)) & + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) & + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) & - + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) + + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg3_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg4_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg5_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg6_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg7_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg3_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg4_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg5_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg6_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg7_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg2_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg3_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg4_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg5_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg6_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg7_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg2_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg3_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg4_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg5_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg6_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg7_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg3_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg4_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg5_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg6_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg7_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg3_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg4_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg5_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg6_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg7_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg2_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg3_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg4_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg5_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg6_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg7_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg2_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg3_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg4_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg5_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg6_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg7_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant2_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant3_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant4_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant2_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant3_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant4_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog2_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog3_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog4_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog2_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog3_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog4_o_aer(n,itype,iphase)) @@ -534,13 +616,85 @@ subroutine sum_pm_mosaic ( & do i=its,imax pm10(i,k,j) = pm10(i,k,j) & + chem(i,k,j,lptr_so4_aer(n,itype,iphase)) & - + chem(i,k,j,lptr_no3_aer(n,itype,iphase)) & - + chem(i,k,j,lptr_cl_aer(n,itype,iphase)) & - + chem(i,k,j,lptr_nh4_aer(n,itype,iphase)) & - + chem(i,k,j,lptr_na_aer(n,itype,iphase)) & - + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) & - + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) + + chem(i,k,j,lptr_no3_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_cl_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_nh4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_na_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg3_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg4_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg5_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg6_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg7_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg3_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg4_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg5_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg6_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg7_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg2_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg3_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg4_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg5_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg6_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg7_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg2_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg3_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg4_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg5_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg6_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg7_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg3_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg4_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg5_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg6_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg7_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg3_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg4_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg5_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg6_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_pcg7_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg2_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg3_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg4_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg5_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg6_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg7_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg2_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg3_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg4_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg5_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg6_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg7_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant2_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant3_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant4_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant2_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant3_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_ant4_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog2_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog3_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog4_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog2_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog3_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_biog4_o_aer(n,itype,iphase)) @@ -761,6 +915,11 @@ subroutine sum_pm_mosaic_vbs0 ( & + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) & + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) & + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(n,itype,iphase)) & + chem(i,k,j,lptr_smpa_aer(n,itype,iphase)) & + chem(i,k,j,lptr_smpbb_aer(n,itype,iphase)) & + chem(i,k,j,lptr_biog1_c_aer(n,itype,iphase)) & @@ -793,6 +952,11 @@ subroutine sum_pm_mosaic_vbs0 ( & + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) & + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) & + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(n,itype,iphase)) & + chem(i,k,j,lptr_smpa_aer(n,itype,iphase)) & + chem(i,k,j,lptr_smpbb_aer(n,itype,iphase)) & + chem(i,k,j,lptr_biog1_c_aer(n,itype,iphase)) & @@ -822,6 +986,146 @@ end subroutine sum_pm_mosaic_vbs0 +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + subroutine sum_pm_mosaic_vbs4 ( & + alt, chem, & + pm2_5_dry, pm2_5_water, pm2_5_dry_ec, pm10, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_state_description, only: num_chem + USE module_data_mosaic_asect + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: alt + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(OUT) :: pm2_5_dry,pm2_5_water,pm2_5_dry_ec,pm10 + + REAL :: mass + + INTEGER :: i,imax,j,jmax,k,kmax,n,itype,iphase + + imax = min(ite,ide-1) + jmax = min(jte,jde-1) + kmax = kte +! +! +! Sum over bins with center diameter < 2.5e-4 cm for pm2_5_dry, +! pm2_5_dry_ec, and pm2_5_water. All bins go into pm10 +! + pm2_5_dry(its:imax,kts:kmax,jts:jmax) = 0. + pm2_5_dry_ec(its:imax,kts:kmax,jts:jmax) = 0. + pm2_5_water(its:imax,kts:kmax,jts:jmax) = 0. + pm10(its:imax,kts:kmax,jts:jmax) = 0. + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + if (dcen_sect(n,itype) .le. 2.5e-4) then + do j=jts,jmax + do k=kts,kmax + do i=its,imax + mass = chem(i,k,j,lptr_so4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_no3_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_cl_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_nh4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_na_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoaX_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(n,itype,iphase)) + +! SMPA and SMPBB do not participate to pm2.5 mass + + pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j) + mass + + pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j) & + + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) + + pm2_5_water(i,k,j) = pm2_5_water(i,k,j) & + + chem(i,k,j,waterptr_aer(n,itype)) + + pm10(i,k,j) = pm10(i,k,j) + mass + enddo + enddo + enddo + else + do j=jts,jmax + do k=kts,kmax + do i=its,imax + pm10(i,k,j) = pm10(i,k,j) & + + chem(i,k,j,lptr_so4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_no3_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_cl_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_nh4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_na_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_oin_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoaX_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(n,itype,iphase)) + +! SMPA and SMPBB do not participate to pm10 mass + + enddo + enddo + enddo + endif + enddo ! size + enddo ! type + enddo ! phase + + !Convert the units from mixing ratio to concentration (ug m^-3) + pm2_5_dry(its:imax,kts:kmax,jts:jmax) = pm2_5_dry(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + pm2_5_dry_ec(its:imax,kts:kmax,jts:jmax) = pm2_5_dry_ec(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + pm2_5_water(its:imax,kts:kmax,jts:jmax) = pm2_5_water(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + pm10(its:imax,kts:kmax,jts:jmax) = pm10(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + + end subroutine sum_pm_mosaic_vbs4 + + !----------------------------------------------------------------------- @@ -968,30 +1272,69 @@ subroutine sum_vbs0 ( & do j=jts,jmax do k=kts,kmax do i=its,imax - hoa_a01(i,k,j)= chem(i,k,j,lptr_oc_aer(1,itype,iphase)) +! missing summation! (hoa = hoa + x ...) +! hoa_a01(i,k,j)= chem(i,k,j,lptr_oc_aer(1,itype,iphase)) +! +! +! soa_a01(i,k,j)= (chem(i,k,j,lptr_smpa_aer(1,itype,iphase)) & +! + chem(i,k,j,lptr_smpbb_aer(1,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase))) +! +! +! bbsoa_a01(i,k,j)= chem(i,k,j,lptr_smpbb_aer(1,itype,iphase)) +! +! +! biog_a01(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase))) +! +! asmpsoa_a01(i,k,j)= chem(i,k,j,lptr_smpa_aer(1,itype,iphase)) +! +! totoa_a01(i,k,j)= ( & +! + chem(i,k,j,lptr_smpa_aer(1,itype,iphase)) & +! + chem(i,k,j,lptr_smpbb_aer(1,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase)) & +! + chem(i,k,j,lptr_oc_aer(1,itype,iphase))) + + hoa_a01(i,k,j)= hoa_a01(i,k,j) & + + chem(i,k,j,lptr_oc_aer(1,itype,iphase)) - soa_a01(i,k,j)= (chem(i,k,j,lptr_smpa_aer(1,itype,iphase)) & + soa_a01(i,k,j)= soa_a01(i,k,j) & + + chem(i,k,j,lptr_smpa_aer(1,itype,iphase)) & + chem(i,k,j,lptr_smpbb_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(1,itype,iphase)) & + chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase))) + + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase)) - bbsoa_a01(i,k,j)= chem(i,k,j,lptr_smpbb_aer(1,itype,iphase)) + bbsoa_a01(i,k,j)= bbsoa_a01(i,k,j) & + + chem(i,k,j,lptr_smpbb_aer(1,itype,iphase)) - biog_a01(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase))) + biog_a01(i,k,j)= biog_a01(i,k,j) & + + chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase)) - asmpsoa_a01(i,k,j)= chem(i,k,j,lptr_smpa_aer(1,itype,iphase)) + asmpsoa_a01(i,k,j)= asmpsoa_a01(i,k,j) & + + chem(i,k,j,lptr_smpa_aer(1,itype,iphase)) - totoa_a01(i,k,j)= ( & + totoa_a01(i,k,j)= totoa_a01(i,k,j) & + chem(i,k,j,lptr_smpa_aer(1,itype,iphase)) & + chem(i,k,j,lptr_smpbb_aer(1,itype,iphase)) & + chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(1,itype,iphase))) - + + chem(i,k,j,lptr_glysoa_r1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(1,itype,iphase)) enddo enddo @@ -1004,30 +1347,69 @@ subroutine sum_vbs0 ( & do j=jts,jmax do k=kts,kmax do i=its,imax - hoa_a02(i,k,j)= (chem(i,k,j,lptr_oc_aer(2,itype,iphase))) +! missing summation! (hoa = hoa + x ...) +! hoa_a02(i,k,j)= (chem(i,k,j,lptr_oc_aer(2,itype,iphase))) +! +! +! soa_a02(i,k,j)= (chem(i,k,j,lptr_smpa_aer(2,itype,iphase)) & +! + chem(i,k,j,lptr_smpbb_aer(2,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase))) +! +! +! bbsoa_a02(i,k,j)= (chem(i,k,j,lptr_smpbb_aer(2,itype,iphase))) +! +! +! biog_a02(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase))) +! +! +! asmpsoa_a02(i,k,j)= chem(i,k,j,lptr_smpa_aer(2,itype,iphase)) +! +! totoa_a02(i,k,j)= ( chem(i,k,j,lptr_oc_aer(2,itype,iphase)) & +! + chem(i,k,j,lptr_smpa_aer(2,itype,iphase)) & +! + chem(i,k,j,lptr_smpbb_aer(2,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase))) + hoa_a02(i,k,j)= hoa_a02(i,k,j) & + + chem(i,k,j,lptr_oc_aer(2,itype,iphase)) - soa_a02(i,k,j)= (chem(i,k,j,lptr_smpa_aer(2,itype,iphase)) & + soa_a02(i,k,j)= soa_a02(i,k,j) & + + chem(i,k,j,lptr_smpa_aer(2,itype,iphase)) & + chem(i,k,j,lptr_smpbb_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(2,itype,iphase)) & + chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase))) + + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase)) - bbsoa_a02(i,k,j)= (chem(i,k,j,lptr_smpbb_aer(2,itype,iphase))) + bbsoa_a02(i,k,j)= bbsoa_a02(i,k,j) & + + chem(i,k,j,lptr_smpbb_aer(2,itype,iphase)) - biog_a02(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase))) + biog_a02(i,k,j)= biog_a02(i,k,j) & + + chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase)) - asmpsoa_a02(i,k,j)= chem(i,k,j,lptr_smpa_aer(2,itype,iphase)) + asmpsoa_a02(i,k,j)= asmpsoa_a02(i,k,j) & + + chem(i,k,j,lptr_smpa_aer(2,itype,iphase)) - totoa_a02(i,k,j)= ( chem(i,k,j,lptr_oc_aer(2,itype,iphase)) & + totoa_a02(i,k,j)= totoa_a02(i,k,j) & + + chem(i,k,j,lptr_oc_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(2,itype,iphase)) & + chem(i,k,j,lptr_smpa_aer(2,itype,iphase)) & + chem(i,k,j,lptr_smpbb_aer(2,itype,iphase)) & + chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase))) - + + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase)) enddo enddo @@ -1040,28 +1422,66 @@ subroutine sum_vbs0 ( & do j=jts,jmax do k=kts,kmax do i=its,imax - hoa_a03(i,k,j)= (chem(i,k,j,lptr_oc_aer(3,itype,iphase))) - - soa_a03(i,k,j)= (chem(i,k,j,lptr_smpa_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_smpbb_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase))) - - - bbsoa_a03(i,k,j)= (chem(i,k,j,lptr_smpbb_aer(3,itype,iphase))) - - biog_a03(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase))) +! missing summation! (hoa = hoa + x ...) +! hoa_a03(i,k,j)= (chem(i,k,j,lptr_oc_aer(3,itype,iphase))) +! +! soa_a03(i,k,j)= (chem(i,k,j,lptr_smpa_aer(3,itype,iphase)) & +! + chem(i,k,j,lptr_smpbb_aer(3,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase))) +! +! +! bbsoa_a03(i,k,j)= (chem(i,k,j,lptr_smpbb_aer(3,itype,iphase))) +! +! biog_a03(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase))) +! +! asmpsoa_a03(i,k,j)= chem(i,k,j,lptr_smpa_aer(3,itype,iphase)) +! +! +! totoa_a03(i,k,j)= ( & +! + chem(i,k,j,lptr_smpa_aer(3,itype,iphase)) & +! + chem(i,k,j,lptr_smpbb_aer(3,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase)) & +! + chem(i,k,j,lptr_oc_aer(3,itype,iphase))) + hoa_a03(i,k,j)= hoa_a03(i,k,j) & + + (chem(i,k,j,lptr_oc_aer(3,itype,iphase))) + + soa_a03(i,k,j)= soa_a03(i,k,j) & + + chem(i,k,j,lptr_smpa_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_smpbb_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase)) + + + bbsoa_a03(i,k,j)= bbsoa_a03(i,k,j) & + + chem(i,k,j,lptr_smpbb_aer(3,itype,iphase)) + + biog_a03(i,k,j)= biog_a03(i,k,j) & + + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase)) - asmpsoa_a03(i,k,j)= chem(i,k,j,lptr_smpa_aer(3,itype,iphase)) + asmpsoa_a03(i,k,j)= asmpsoa_a03(i,k,j) & + + chem(i,k,j,lptr_smpa_aer(3,itype,iphase)) - totoa_a03(i,k,j)= ( & + totoa_a03(i,k,j)= totoa_a03(i,k,j) & + chem(i,k,j,lptr_smpa_aer(3,itype,iphase)) & + chem(i,k,j,lptr_smpbb_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(3,itype,iphase)) & + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(3,itype,iphase))) + + chem(i,k,j,lptr_oc_aer(3,itype,iphase)) enddo @@ -1075,31 +1495,73 @@ subroutine sum_vbs0 ( & do j=jts,jmax do k=kts,kmax do i=its,imax - hoa_a04(i,k,j)= (chem(i,k,j,lptr_oc_aer(4,itype,iphase))) +! missing summation! (hoa = hoa + x ...) +! hoa_a04(i,k,j)= (chem(i,k,j,lptr_oc_aer(4,itype,iphase))) +! +! +! soa_a04(i,k,j)= (chem(i,k,j,lptr_smpa_aer(4,itype,iphase)) & +! + chem(i,k,j,lptr_smpbb_aer(4,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase))) +! +! +! bbsoa_a04(i,k,j)= (chem(i,k,j,lptr_smpbb_aer(4,itype,iphase))) +! +! +! biog_a04(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase))) +! +! asmpsoa_a04(i,k,j)= chem(i,k,j,lptr_smpa_aer(4,itype,iphase)) +! +! +! +! totoa_a04(i,k,j)= ( & +! + chem(i,k,j,lptr_smpa_aer(4,itype,iphase)) & +! + chem(i,k,j,lptr_smpbb_aer(4,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & +! + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase)) & +! + chem(i,k,j,lptr_oc_aer(4,itype,iphase))) + hoa_a04(i,k,j)= hoa_a04(i,k,j) & + + chem(i,k,j,lptr_oc_aer(4,itype,iphase)) - soa_a04(i,k,j)= (chem(i,k,j,lptr_smpa_aer(4,itype,iphase)) & + soa_a04(i,k,j)= soa_a04(i,k,j) & + + chem(i,k,j,lptr_smpa_aer(4,itype,iphase)) & + chem(i,k,j,lptr_smpbb_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(4,itype,iphase)) & + chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase))) + + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase)) - bbsoa_a04(i,k,j)= (chem(i,k,j,lptr_smpbb_aer(4,itype,iphase))) + bbsoa_a04(i,k,j)= bbsoa_a04(i,k,j) & + + chem(i,k,j,lptr_smpbb_aer(4,itype,iphase)) - biog_a04(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase))) + biog_a04(i,k,j)= biog_a04(i,k,j) & + + chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase)) - asmpsoa_a04(i,k,j)= chem(i,k,j,lptr_smpa_aer(4,itype,iphase)) + asmpsoa_a04(i,k,j)= asmpsoa_a04(i,k,j) & + + chem(i,k,j,lptr_smpa_aer(4,itype,iphase)) - totoa_a04(i,k,j)= ( & + totoa_a04(i,k,j)= totoa_a04(i,k,j) & + chem(i,k,j,lptr_smpa_aer(4,itype,iphase)) & + chem(i,k,j,lptr_smpbb_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(4,itype,iphase)) & + chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(4,itype,iphase))) + + chem(i,k,j,lptr_oc_aer(4,itype,iphase)) + enddo @@ -1189,13 +1651,21 @@ end subroutine sum_vbs0 subroutine sum_vbs2 ( & alt, chem, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & + hoa_a05,hoa_a06,hoa_a07,hoa_a08, & !BSINGH(12/04/2013): Added 4 more bins(5 to 8) for all apecies bboa_a01,bboa_a02,bboa_a03,bboa_a04, & + bboa_a05,bboa_a06,bboa_a07,bboa_a08, & soa_a01,soa_a02,soa_a03,soa_a04, & + soa_a05,soa_a06,soa_a07,soa_a08, & bbsoa_a01,bbsoa_a02,bbsoa_a03,bbsoa_a04, & + bbsoa_a05,bbsoa_a06,bbsoa_a07,bbsoa_a08, & hsoa_a01,hsoa_a02,hsoa_a03,hsoa_a04, & + hsoa_a05,hsoa_a06,hsoa_a07,hsoa_a08, & biog_a01,biog_a02,biog_a03,biog_a04, & + biog_a05,biog_a06,biog_a07,biog_a08, & arosoa_a01,arosoa_a02,arosoa_a03,arosoa_a04, & + arosoa_a05,arosoa_a06,arosoa_a07,arosoa_a08, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & hsoa_c,hsoa_o,bbsoa_c,bbsoa_o, & biog_v1,biog_v2,biog_v3,biog_v4, & ant_v1,ant_v2,ant_v3,ant_v4, & @@ -1219,13 +1689,21 @@ subroutine sum_vbs2 ( & INTENT(IN ) :: chem REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(OUT) :: hoa_a01,hoa_a02,hoa_a03,hoa_a04, & + hoa_a05,hoa_a06,hoa_a07,hoa_a08, & bboa_a01,bboa_a02,bboa_a03,bboa_a04, & + bboa_a05,bboa_a06,bboa_a07,bboa_a08, & soa_a01,soa_a02,soa_a03,soa_a04, & + soa_a05,soa_a06,soa_a07,soa_a08, & bbsoa_a01,bbsoa_a02,bbsoa_a03,bbsoa_a04, & + bbsoa_a05,bbsoa_a06,bbsoa_a07,bbsoa_a08, & biog_a01,biog_a02,biog_a03,biog_a04, & + biog_a05,biog_a06,biog_a07,biog_a08, & hsoa_a01,hsoa_a02,hsoa_a03,hsoa_a04, & - arosoa_a01,arosoa_a02,arosoa_a03,arosoa_a04, & + hsoa_a05,hsoa_a06,hsoa_a07,hsoa_a08, & + arosoa_a01,arosoa_a02,arosoa_a03,arosoa_a04, & + arosoa_a05,arosoa_a06,arosoa_a07,arosoa_a08, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & hsoa_c,hsoa_o,bbsoa_c,bbsoa_o, & biog_v1,biog_v2,biog_v3,biog_v4, & ant_v1,ant_v2,ant_v3,ant_v4 @@ -1274,6 +1752,45 @@ subroutine sum_vbs2 ( & biog_a04(its:imax,kts:kmax,jts:jmax) = 0. totoa_a04(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_a05(its:imax,kts:kmax,jts:jmax) = 0. + soa_a05(its:imax,kts:kmax,jts:jmax) = 0. + bboa_a05(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_a05(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_a05(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_a05(its:imax,kts:kmax,jts:jmax) = 0. + biog_a05(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a05(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_a06(its:imax,kts:kmax,jts:jmax) = 0. + soa_a06(its:imax,kts:kmax,jts:jmax) = 0. + bboa_a06(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_a06(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_a06(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_a06(its:imax,kts:kmax,jts:jmax) = 0. + biog_a06(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a06(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_a07(its:imax,kts:kmax,jts:jmax) = 0. + soa_a07(its:imax,kts:kmax,jts:jmax) = 0. + bboa_a07(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_a07(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_a07(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_a07(its:imax,kts:kmax,jts:jmax) = 0. + biog_a07(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a07(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_a08(its:imax,kts:kmax,jts:jmax) = 0. + soa_a08(its:imax,kts:kmax,jts:jmax) = 0. + bboa_a08(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_a08(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_a08(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_a08(its:imax,kts:kmax,jts:jmax) = 0. + biog_a08(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a08(its:imax,kts:kmax,jts:jmax) = 0. + + + ! Species to calculate O:C ratios hsoa_c(its:imax,kts:kmax,jts:jmax) = 0. hsoa_o(its:imax,kts:kmax,jts:jmax) = 0. @@ -1289,7 +1806,8 @@ subroutine sum_vbs2 ( & ant_v4(its:imax,kts:kmax,jts:jmax) = 0. - do iphase=1,nphase_aer + !do iphase=1,nphase_aer!BSINGH - Commented out as we need to add only phase 1 (interstitial) values species + iphase = 1 do itype=1,ntype_aer do n = 1, nsize_aer(itype) !The 4th bin is 2.5-10um and outside the AMS measurements do j=jts,jmax @@ -1329,9 +1847,12 @@ subroutine sum_vbs2 ( & enddo enddo enddo - enddo - do iphase=1,nphase_aer + +! NOTE - summation also wrong for code below, but not my code so did not fix... + + !do iphase=1,nphase_aer !BSINGH - Commented out as we need to add only phase 1 (interstitial) values species + iphase = 1 do itype=1,ntype_aer do j=jts,jmax do k=kts,kmax @@ -1393,9 +1914,10 @@ subroutine sum_vbs2 ( & enddo enddo enddo ! type - enddo ! phase - do iphase=1,nphase_aer + + !do iphase=1,nphase_aer!BSINGH - Commented out as we need to add only phase 1 (interstitial) values species + iphase = 1 do itype=1,ntype_aer do j=jts,jmax do k=kts,kmax @@ -1457,9 +1979,10 @@ subroutine sum_vbs2 ( & enddo enddo enddo ! type - enddo ! phase - do iphase=1,nphase_aer + + !do iphase=1,nphase_aer!BSINGH - Commented out as we need to add only phase 1 (interstitial) values species + iphase = 1 do itype=1,ntype_aer do j=jts,jmax do k=kts,kmax @@ -1521,9 +2044,10 @@ subroutine sum_vbs2 ( & enddo enddo enddo ! type - enddo ! phase - do iphase=1,nphase_aer + + !do iphase=1,nphase_aer!BSINGH - Commented out as we need to add only phase 1 (interstitial) values species + iphase = 1 do itype=1,ntype_aer do j=jts,jmax do k=kts,kmax @@ -1585,14 +2109,995 @@ subroutine sum_vbs2 ( & enddo enddo enddo ! type + + + + end subroutine sum_vbs2 + +!BSINGH(12/12/2013): Added following function for SAPRC 8 bin + !---------------------------------------------------------------------- + + + subroutine sum_aq_vbs2 ( & + alt, chem, & + hoa_cw01,hoa_cw02,hoa_cw03,hoa_cw04,hoa_cw05,hoa_cw06,hoa_cw07,hoa_cw08, & + bboa_cw01,bboa_cw02,bboa_cw03,bboa_cw04,bboa_cw05,bboa_cw06,bboa_cw07,bboa_cw08, & + soa_cw01,soa_cw02,soa_cw03,soa_cw04,soa_cw05,soa_cw06,soa_cw07,soa_cw08, & + bbsoa_cw01,bbsoa_cw02,bbsoa_cw03,bbsoa_cw04,bbsoa_cw05,bbsoa_cw06,bbsoa_cw07,bbsoa_cw08, & + hsoa_cw01,hsoa_cw02,hsoa_cw03,hsoa_cw04,hsoa_cw05,hsoa_cw06,hsoa_cw07,hsoa_cw08, & + biog_cw01,biog_cw02,biog_cw03,biog_cw04,biog_cw05,biog_cw06,biog_cw07,biog_cw08, & + arosoa_cw01,arosoa_cw02,arosoa_cw03,arosoa_cw04,arosoa_cw05,arosoa_cw06,arosoa_cw07,arosoa_cw08, & + totoa_cw01,totoa_cw02,totoa_cw03,totoa_cw04,totoa_cw05,totoa_cw06,totoa_cw07,totoa_cw08, & + hsoa_cw_c,hsoa_cw_o,bbsoa_cw_c,bbsoa_cw_o, & + biog_cw_v1, & + ant_cw_v1, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_state_description, only: num_chem + USE module_data_mosaic_asect + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: alt + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(OUT) :: hoa_cw01,hoa_cw02,hoa_cw03,hoa_cw04, & + hoa_cw05,hoa_cw06,hoa_cw07,hoa_cw08, & + bboa_cw01,bboa_cw02,bboa_cw03,bboa_cw04, & + bboa_cw05,bboa_cw06,bboa_cw07,bboa_cw08, & + soa_cw01,soa_cw02,soa_cw03,soa_cw04, & + soa_cw05,soa_cw06,soa_cw07,soa_cw08, & + bbsoa_cw01,bbsoa_cw02,bbsoa_cw03,bbsoa_cw04, & + bbsoa_cw05,bbsoa_cw06,bbsoa_cw07,bbsoa_cw08, & + biog_cw01,biog_cw02,biog_cw03,biog_cw04, & + biog_cw05,biog_cw06,biog_cw07,biog_cw08, & + hsoa_cw01,hsoa_cw02,hsoa_cw03,hsoa_cw04, & + hsoa_cw05,hsoa_cw06,hsoa_cw07,hsoa_cw08, & + arosoa_cw01,arosoa_cw02,arosoa_cw03,arosoa_cw04, & + arosoa_cw05,arosoa_cw06,arosoa_cw07,arosoa_cw08, & + totoa_cw01,totoa_cw02,totoa_cw03,totoa_cw04, & + totoa_cw05,totoa_cw06,totoa_cw07,totoa_cw08, & + hsoa_cw_c,hsoa_cw_o,bbsoa_cw_c,bbsoa_cw_o, & + biog_cw_v1, & + ant_cw_v1 + + + + INTEGER :: i,imax,j,jmax,k,kmax,n,itype,iphase + + imax = min(ite,ide-1) + jmax = min(jte,jde-1) + kmax = kte + + hoa_cw01(its:imax,kts:kmax,jts:jmax) = 0. + soa_cw01(its:imax,kts:kmax,jts:jmax) = 0. + bboa_cw01(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_cw01(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_cw01(its:imax,kts:kmax,jts:jmax) = 0. + biog_cw01(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_cw01(its:imax,kts:kmax,jts:jmax) = 0. + totoa_cw01(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_cw02(its:imax,kts:kmax,jts:jmax) = 0. + soa_cw02(its:imax,kts:kmax,jts:jmax) = 0. + bboa_cw02(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_cw02(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_cw02(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_cw02(its:imax,kts:kmax,jts:jmax) = 0. + biog_cw02(its:imax,kts:kmax,jts:jmax) = 0. + totoa_cw02(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_cw03(its:imax,kts:kmax,jts:jmax) = 0. + soa_cw03(its:imax,kts:kmax,jts:jmax) = 0. + bboa_cw03(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_cw03(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_cw03(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_cw03(its:imax,kts:kmax,jts:jmax) = 0. + biog_cw03(its:imax,kts:kmax,jts:jmax) = 0. + totoa_cw03(its:imax,kts:kmax,jts:jmax) = 0. + hoa_cw04(its:imax,kts:kmax,jts:jmax) = 0. + soa_cw04(its:imax,kts:kmax,jts:jmax) = 0. + bboa_cw04(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_cw04(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_cw04(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_cw04(its:imax,kts:kmax,jts:jmax) = 0. + biog_cw04(its:imax,kts:kmax,jts:jmax) = 0. + totoa_cw04(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_cw05(its:imax,kts:kmax,jts:jmax) = 0. + soa_cw05(its:imax,kts:kmax,jts:jmax) = 0. + bboa_cw05(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_cw05(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_cw05(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_cw05(its:imax,kts:kmax,jts:jmax) = 0. + biog_cw05(its:imax,kts:kmax,jts:jmax) = 0. + totoa_cw05(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_cw06(its:imax,kts:kmax,jts:jmax) = 0. + soa_cw06(its:imax,kts:kmax,jts:jmax) = 0. + bboa_cw06(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_cw06(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_cw06(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_cw06(its:imax,kts:kmax,jts:jmax) = 0. + biog_cw06(its:imax,kts:kmax,jts:jmax) = 0. + totoa_cw06(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_cw07(its:imax,kts:kmax,jts:jmax) = 0. + soa_cw07(its:imax,kts:kmax,jts:jmax) = 0. + bboa_cw07(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_cw07(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_cw07(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_cw07(its:imax,kts:kmax,jts:jmax) = 0. + biog_cw07(its:imax,kts:kmax,jts:jmax) = 0. + totoa_cw07(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_cw08(its:imax,kts:kmax,jts:jmax) = 0. + soa_cw08(its:imax,kts:kmax,jts:jmax) = 0. + bboa_cw08(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_cw08(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_cw08(its:imax,kts:kmax,jts:jmax) = 0. + arosoa_cw08(its:imax,kts:kmax,jts:jmax) = 0. + biog_cw08(its:imax,kts:kmax,jts:jmax) = 0. + totoa_cw08(its:imax,kts:kmax,jts:jmax) = 0. + + + +! Species to calculate O:C ratios + hsoa_cw_c(its:imax,kts:kmax,jts:jmax) = 0. + hsoa_cw_o(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_cw_c(its:imax,kts:kmax,jts:jmax) = 0. + bbsoa_cw_o(its:imax,kts:kmax,jts:jmax) = 0. + biog_cw_v1(its:imax,kts:kmax,jts:jmax) = 0. + ant_cw_v1(its:imax,kts:kmax,jts:jmax) = 0. + + + !do iphase=2,2 !set nphase_aer=2 for cloud-borne aerosols !BSINGH - Commented out + iphase = 2 + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) !The 4th bin is 2.5-10um and outside the AMS measurements + do j=jts,jmax + do k=kts,kmax + do i=its,imax + + hsoa_cw_c(i,k,j)=hsoa_cw_c(i,k,j) & + + (chem(i,k,j,lptr_pcg1_f_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(n,itype,iphase)))*180/211 + + hsoa_cw_o(i,k,j)= hsoa_cw_o(i,k,j) & + + (chem(i,k,j,lptr_pcg1_f_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(n,itype,iphase))) + + bbsoa_cw_c(i,k,j)= bbsoa_cw_c(i,k,j) & + + (chem(i,k,j,lptr_pcg1_b_c_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(n,itype,iphase)))*180/211 + + bbsoa_cw_o(i,k,j)=bbsoa_cw_o(i,k,j) & + +(chem(i,k,j,lptr_pcg1_b_o_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(n,itype,iphase))) + + biog_cw_v1(i,k,j)= biog_cw_v1(i,k,j) & + + chem(i,k,j,lptr_biog1_c_aer(n,itype,iphase)) + + ant_cw_v1(i,k,j)= ant_cw_v1(i,k,j) & + + chem(i,k,j,lptr_ant1_c_aer(n,itype,iphase)) + + enddo + enddo + enddo + enddo + enddo + + + + + + !do iphase=2,2 !set nphase_aer=2 for cloud-borne aerosols !BSINGH - Commented out + iphase = 2 + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_cw01(i,k,j)= chem(i,k,j,lptr_pcg1_f_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(1,itype,iphase)) + + bboa_cw01(i,k,j)= chem(i,k,j,lptr_pcg1_b_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(1,itype,iphase)) + + soa_cw01(i,k,j)= chem(i,k,j,lptr_opcg1_b_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) + + arosoa_cw01(i,k,j)= chem(i,k,j,lptr_ant1_c_aer(1,itype,iphase)) + + + bbsoa_cw01(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(1,itype,iphase))) + + hsoa_cw01(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(1,itype,iphase))) + + biog_cw01(i,k,j)= chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) + + + + totoa_cw01(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(1,itype,iphase))) + + + enddo + enddo + enddo + enddo ! type + + + + !do iphase=2,2 !set nphase_aer=2 for cloud-borne aerosols!BSINGH - Commented out + iphase = 2 + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_cw02(i,k,j)= chem(i,k,j,lptr_pcg1_f_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(2,itype,iphase)) + + bboa_cw02(i,k,j)= chem(i,k,j,lptr_pcg1_b_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(2,itype,iphase)) + + soa_cw02(i,k,j)= chem(i,k,j,lptr_opcg1_b_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) + + arosoa_cw02(i,k,j)= chem(i,k,j,lptr_ant1_c_aer(2,itype,iphase)) + + + bbsoa_cw02(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(2,itype,iphase))) + + hsoa_cw02(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(2,itype,iphase))) + + biog_cw02(i,k,j)= chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) + + + + totoa_cw02(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(2,itype,iphase))) + + + enddo + enddo + enddo + enddo ! type + + + + !do iphase=2,2 !set nphase_aer=2 for cloud-borne aerosols!BSINGH - Commented out + iphase = 2 + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_cw03(i,k,j)= chem(i,k,j,lptr_pcg1_f_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(3,itype,iphase)) + + bboa_cw03(i,k,j)= chem(i,k,j,lptr_pcg1_b_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(3,itype,iphase)) + + soa_cw03(i,k,j)= chem(i,k,j,lptr_opcg1_b_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) + + arosoa_cw03(i,k,j)= chem(i,k,j,lptr_ant1_c_aer(3,itype,iphase)) + + + bbsoa_cw03(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(3,itype,iphase))) + + hsoa_cw03(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(3,itype,iphase))) + + biog_cw03(i,k,j)= chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) + + + + totoa_cw03(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(3,itype,iphase))) + + + enddo + enddo + enddo + enddo ! type + + + + !do iphase=2,2 !set nphase_aer=2 for cloud-borne aerosols!BSINGH - Commented out + iphase = 2 + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_cw04(i,k,j)= chem(i,k,j,lptr_pcg1_f_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(4,itype,iphase)) + + bboa_cw04(i,k,j)= chem(i,k,j,lptr_pcg1_b_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(4,itype,iphase)) + + soa_cw04(i,k,j)= chem(i,k,j,lptr_opcg1_b_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) + + arosoa_cw04(i,k,j)= chem(i,k,j,lptr_ant1_c_aer(4,itype,iphase)) + + + bbsoa_cw04(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(4,itype,iphase))) + + hsoa_cw04(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(4,itype,iphase))) + + biog_cw04(i,k,j)= chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) + + + + totoa_cw04(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(4,itype,iphase))) + + + enddo + enddo + enddo + enddo ! type + + + !do iphase=2,2 !set nphase_aer=1 for interstitial aerosols!BSINGH - Commented out + iphase = 2 + do itype=1,ntype_aer + if(nsize_aer(itype).ge.5) then + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_cw05(i,k,j)= chem(i,k,j,lptr_pcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(5,itype,iphase)) + + bboa_cw05(i,k,j)= chem(i,k,j,lptr_pcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(5,itype,iphase)) + + soa_cw05(i,k,j)= chem(i,k,j,lptr_opcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(5,itype,iphase)) + + arosoa_cw05(i,k,j)= chem(i,k,j,lptr_ant1_c_aer(5,itype,iphase)) + + + bbsoa_cw05(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(5,itype,iphase))) + + hsoa_cw05(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(5,itype,iphase))) + + biog_cw05(i,k,j)= chem(i,k,j,lptr_biog1_c_aer(5,itype,iphase)) + + + + totoa_cw05(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(5,itype,iphase))) + + + enddo + enddo + enddo + endif ! check for number of size bins + enddo ! type + + + + !do iphase=2,2 !set nphase_aer=1 for interstitial aerosols!BSINGH - Commented out + iphase = 2 + do itype=1,ntype_aer + if(nsize_aer(itype).ge.6) then + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_cw06(i,k,j)= chem(i,k,j,lptr_pcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(6,itype,iphase)) + + bboa_cw06(i,k,j)= chem(i,k,j,lptr_pcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(6,itype,iphase)) + + soa_cw06(i,k,j)= chem(i,k,j,lptr_opcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(6,itype,iphase)) + + arosoa_cw06(i,k,j)= chem(i,k,j,lptr_ant1_c_aer(6,itype,iphase)) + + + bbsoa_cw06(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(6,itype,iphase))) + + hsoa_cw06(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(6,itype,iphase))) + + biog_cw06(i,k,j)= chem(i,k,j,lptr_biog1_c_aer(6,itype,iphase)) + + + + totoa_cw06(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(6,itype,iphase))) + + + enddo + enddo + enddo + endif ! size bins + enddo ! type + + + !do iphase=2,2 !set nphase_aer=1 for interstitial aerosols!BSINGH - Commented out + iphase = 2 + do itype=1,ntype_aer + if(nsize_aer(itype).ge.7) then + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_cw07(i,k,j)= chem(i,k,j,lptr_pcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(7,itype,iphase)) + + bboa_cw07(i,k,j)= chem(i,k,j,lptr_pcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(7,itype,iphase)) + + soa_cw07(i,k,j)= chem(i,k,j,lptr_opcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(7,itype,iphase)) + + arosoa_cw07(i,k,j)= chem(i,k,j,lptr_ant1_c_aer(7,itype,iphase)) + + + bbsoa_cw07(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(7,itype,iphase))) + + hsoa_cw07(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(7,itype,iphase))) + + biog_cw07(i,k,j)= chem(i,k,j,lptr_biog1_c_aer(7,itype,iphase)) + + + + totoa_cw07(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(7,itype,iphase))) + + + enddo + enddo + enddo + endif ! size bins + enddo ! type + + + !do iphase=2,2 !set nphase_aer=1 for interstitial aerosols!BSINGH - Commented out + iphase = 2 + do itype=1,ntype_aer + if(nsize_aer(itype).ge.8) then + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_cw08(i,k,j)= chem(i,k,j,lptr_pcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(8,itype,iphase)) + + bboa_cw08(i,k,j)= chem(i,k,j,lptr_pcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(8,itype,iphase)) + + soa_cw08(i,k,j)= chem(i,k,j,lptr_opcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(8,itype,iphase)) + + arosoa_cw08(i,k,j)= chem(i,k,j,lptr_ant1_c_aer(8,itype,iphase)) + + + bbsoa_cw08(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(8,itype,iphase))) + + hsoa_cw08(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(8,itype,iphase))) + + biog_cw08(i,k,j)= chem(i,k,j,lptr_biog1_c_aer(8,itype,iphase)) + + + + totoa_cw08(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(8,itype,iphase))) + + + enddo + enddo + enddo + endif ! size bins + enddo ! type + + + + + + + end subroutine sum_aq_vbs2 + +!BSINGH -ENDS + +!---------------------------------------------------------------------- + +!----------------------------------------------------------------------- + + + subroutine sum_vbs4 ( & + alt, chem, & + hoa_a01,hoa_a02,hoa_a03,hoa_a04, & + soa_a01,soa_a02,soa_a03,soa_a04, & + biog_a01,biog_a02,biog_a03,biog_a04, & + totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + biog_v1,biog_v2,biog_v3,biog_v4, & + ant_v1,ant_v2,ant_v3,ant_v4, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_state_description, only: num_chem + USE module_data_mosaic_asect + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: alt + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(OUT) :: hoa_a01,hoa_a02,hoa_a03,hoa_a04, & + soa_a01,soa_a02,soa_a03,soa_a04, & + biog_a01,biog_a02,biog_a03,biog_a04, & + totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + biog_v1,biog_v2,biog_v3,biog_v4, & + ant_v1,ant_v2,ant_v3,ant_v4 + + + + INTEGER :: i,imax,j,jmax,k,kmax,n,itype,iphase + + imax = min(ite,ide-1) + jmax = min(jte,jde-1) + kmax = kte + + hoa_a01(its:imax,kts:kmax,jts:jmax) = 0. + soa_a01(its:imax,kts:kmax,jts:jmax) = 0. + biog_a01(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a01(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_a02(its:imax,kts:kmax,jts:jmax) = 0. + soa_a02(its:imax,kts:kmax,jts:jmax) = 0. + biog_a02(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a02(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_a03(its:imax,kts:kmax,jts:jmax) = 0. + soa_a03(its:imax,kts:kmax,jts:jmax) = 0. + biog_a03(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a03(its:imax,kts:kmax,jts:jmax) = 0. + + hoa_a04(its:imax,kts:kmax,jts:jmax) = 0. + soa_a04(its:imax,kts:kmax,jts:jmax) = 0. + biog_a04(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a04(its:imax,kts:kmax,jts:jmax) = 0. + +! Species to calculate O:C ratios + biog_v1(its:imax,kts:kmax,jts:jmax) = 0. + biog_v2(its:imax,kts:kmax,jts:jmax) = 0. + biog_v3(its:imax,kts:kmax,jts:jmax) = 0. + biog_v4(its:imax,kts:kmax,jts:jmax) = 0. + ant_v1(its:imax,kts:kmax,jts:jmax) = 0. + ant_v2(its:imax,kts:kmax,jts:jmax) = 0. + ant_v3(its:imax,kts:kmax,jts:jmax) = 0. + ant_v4(its:imax,kts:kmax,jts:jmax) = 0. + + + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) !The 4th bin is 2.5-10um and outside the AMS measurements + do j=jts,jmax + do k=kts,kmax + do i=its,imax + + biog_v1(i,k,j)= biog_v1(i,k,j) & + + chem(i,k,j,lptr_bsoaX_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(n,itype,iphase)) + + ant_v1(i,k,j)= ant_v1(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(n,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(n,itype,iphase)) + + enddo + enddo + enddo + enddo + enddo + enddo + + biog_v1(its:imax,kts:kmax,jts:jmax) = biog_v1(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + ant_v1(its:imax,kts:kmax,jts:jmax) = ant_v1(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_a01(i,k,j)= hoa_a01(i,k,j) & + +chem(i,k,j,lptr_oc_aer(1,itype,iphase)) + + soa_a01(i,k,j)= soa_a01(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(1,itype,iphase)) + + biog_a01(i,k,j)= biog_a01(i,k,j) & + + chem(i,k,j,lptr_bsoa1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(1,itype,iphase)) + + totoa_a01(i,k,j)= totoa_a01(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(1,itype,iphase)) + + + enddo + enddo + enddo + enddo ! type + enddo ! phase + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_a02(i,k,j)= hoa_a02(i,k,j) & + +chem(i,k,j,lptr_oc_aer(2,itype,iphase)) + + soa_a02(i,k,j)= soa_a02(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(2,itype,iphase)) + + biog_a02(i,k,j)= biog_a02(i,k,j) & + + chem(i,k,j,lptr_bsoa1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(2,itype,iphase)) + + totoa_a02(i,k,j)= totoa_a02(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(2,itype,iphase)) + + + enddo + enddo + enddo + enddo ! type + enddo ! phase + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_a03(i,k,j)= hoa_a03(i,k,j) & + + chem(i,k,j,lptr_oc_aer(3,itype,iphase)) + + soa_a03(i,k,j)= soa_a03(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(3,itype,iphase)) + + biog_a03(i,k,j)= biog_a03(i,k,j) & + + chem(i,k,j,lptr_bsoa1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(3,itype,iphase)) + + totoa_a03(i,k,j)= totoa_a03(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(3,itype,iphase)) + enddo + enddo + enddo + enddo ! type + enddo ! phase + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_a04(i,k,j)= hoa_a04(i,k,j) & + + chem(i,k,j,lptr_oc_aer(4,itype,iphase)) + + soa_a04(i,k,j)= soa_a04(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(4,itype,iphase)) + + biog_a04(i,k,j)= biog_a04(i,k,j) & + + chem(i,k,j,lptr_bsoa1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(4,itype,iphase)) + + totoa_a04(i,k,j)= totoa_a04(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(4,itype,iphase)) + enddo + enddo + enddo + enddo ! type enddo ! phase +!Factor of 1.4 used below to convert OC to OA + hoa_a01(its:imax,kts:kmax,jts:jmax) =hoa_a01(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + soa_a01(its:imax,kts:kmax,jts:jmax) =soa_a01(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + biog_a01(its:imax,kts:kmax,jts:jmax) =biog_a01(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + totoa_a01(its:imax,kts:kmax,jts:jmax) =totoa_a01(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) - end subroutine sum_vbs2 + hoa_a02(its:imax,kts:kmax,jts:jmax) =hoa_a02(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + soa_a02(its:imax,kts:kmax,jts:jmax) =soa_a02(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + biog_a02(its:imax,kts:kmax,jts:jmax) =biog_a02(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + totoa_a02(its:imax,kts:kmax,jts:jmax) =totoa_a02(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) -!---------------------------------------------------------------------- + hoa_a03(its:imax,kts:kmax,jts:jmax) =hoa_a03(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + soa_a03(its:imax,kts:kmax,jts:jmax) =soa_a03(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + biog_a03(its:imax,kts:kmax,jts:jmax) =biog_a03(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + totoa_a03(its:imax,kts:kmax,jts:jmax) =totoa_a03(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + + hoa_a04(its:imax,kts:kmax,jts:jmax) =hoa_a04(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + soa_a04(its:imax,kts:kmax,jts:jmax) =soa_a04(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + biog_a04(its:imax,kts:kmax,jts:jmax) =biog_a04(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + totoa_a04(its:imax,kts:kmax,jts:jmax) =totoa_a04(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + end subroutine sum_vbs4 @@ -1806,6 +3311,8 @@ subroutine sum_vbs9 ( & enddo enddo +! NOTE - summation also wrong for code below, but not my code so did not fix... + do iphase=1,nphase_aer do itype=1,ntype_aer do j=jts,jmax @@ -2685,10 +4192,24 @@ subroutine mapaer_tofrom_host( imap, & p_pcg8_f_o,p_pcg9_f_o,p_opcg1_f_o,p_opcg2_f_o,p_opcg3_f_o,p_opcg4_f_o,& p_opcg5_f_o,p_opcg6_f_o,p_opcg7_f_o,p_opcg8_f_o, & p_smpa,p_smpbb, & + p_gly, & p_ant1_c,p_ant2_c,p_ant3_c,p_ant4_c,p_ant1_o,p_ant2_o,p_ant3_o,p_ant4_o,& p_biog1_c,p_biog2_c,p_biog3_c,p_biog4_c,p_biog1_o, & p_biog2_o,p_biog3_o,p_biog4_o, & - p_n2o5, p_clno2 +! p_n2o5, p_clno2 + p_n2o5, p_clno2, & + p_asoaX_a01, p_asoaX_a02, p_asoaX_a03, p_asoaX_a04, & + p_asoa1_a01, p_asoa1_a02, p_asoa1_a03, p_asoa1_a04, & + p_asoa2_a01, p_asoa2_a02, p_asoa2_a03, p_asoa2_a04, & + p_asoa3_a01, p_asoa3_a02, p_asoa3_a03, p_asoa3_a04, & + p_asoa4_a01, p_asoa4_a02, p_asoa4_a03, p_asoa4_a04, & + p_bsoaX_a01, p_bsoaX_a02, p_bsoaX_a03, p_bsoaX_a04, & + p_bsoa1_a01, p_bsoa1_a02, p_bsoa1_a03, p_bsoa1_a04, & + p_bsoa2_a01, p_bsoa2_a02, p_bsoa2_a03, p_bsoa2_a04, & + p_bsoa3_a01, p_bsoa3_a02, p_bsoa3_a03, p_bsoa3_a04, & + p_bsoa4_a01, p_bsoa4_a02, p_bsoa4_a03, p_bsoa4_a04, & + p_cvasoaX, p_cvasoa1, p_cvasoa2, p_cvasoa3, p_cvasoa4, & + p_cvbsoaX, p_cvbsoa1, p_cvbsoa2, p_cvbsoa3, p_cvbsoa4 use module_state_description, only: param_first_scalar use module_data_mosaic_asect @@ -2743,10 +4264,13 @@ subroutine mapaer_tofrom_host( imap, & factaerpcg8_f_o,factaerpcg9_f_o,factaeropcg1_f_o,factaeropcg2_f_o,factaeropcg3_f_o,factaeropcg4_f_o,& factaeropcg5_f_o,factaeropcg6_f_o,factaeropcg7_f_o,factaeropcg8_f_o,& factaersmpa,factaersmpbb, & + factaerglyr1, factaerglyr2, factaerglysfc, factaerglynh4, factaerglyoh, & factaerant1_c,factaerant2_c,factaerant3_c,factaerant4_c, & factaerant1_o,factaerant2_o,factaerant3_o,factaerant4_o, & factaerbiog1_c,factaerbiog2_c,factaerbiog3_c,factaerbiog4_c, & factaerbiog1_o,factaerbiog2_o,factaerbiog3_o,factaerbiog4_o, & + factaerasoaX,factaerasoa1,factaerasoa2,factaerasoa3,factaerasoa4, & + factaerbsoaX,factaerbsoa1,factaerbsoa2,factaerbsoa3,factaerbsoa4, & factaerhysw, factaerwater, factaernum real, parameter :: eps=0.622 @@ -2853,6 +4377,11 @@ subroutine mapaer_tofrom_host( imap, & factaeropcg8_f_o=dum*mw_opcg8_f_o_aer factaersmpa=dum*mw_smpa_aer factaersmpbb=dum*mw_smpbb_aer + factaerglyr1=dum*mw_glysoa_r1_aer + factaerglyr2=dum*mw_glysoa_r2_aer + factaerglysfc=dum*mw_glysoa_sfc_aer + factaerglynh4=dum*mw_glysoa_nh4_aer + factaerglyoh=dum*mw_glysoa_oh_aer factaerant1_c=dum*mw_ant1_c_aer factaerant2_c=dum*mw_ant2_c_aer factaerant3_c=dum*mw_ant3_c_aer @@ -2869,6 +4398,16 @@ subroutine mapaer_tofrom_host( imap, & factaerbiog2_o=dum*mw_biog2_o_aer factaerbiog3_o=dum*mw_biog3_o_aer factaerbiog4_o=dum*mw_biog4_o_aer + factaerasoaX=dum*mw_asoaX_aer + factaerasoa1=dum*mw_asoa1_aer + factaerasoa2=dum*mw_asoa2_aer + factaerasoa3=dum*mw_asoa3_aer + factaerasoa4=dum*mw_asoa4_aer + factaerbsoaX=dum*mw_bsoaX_aer + factaerbsoa1=dum*mw_bsoa1_aer + factaerbsoa2=dum*mw_bsoa2_aer + factaerbsoa3=dum*mw_bsoa3_aer + factaerbsoa4=dum*mw_bsoa4_aer @@ -2964,6 +4503,11 @@ subroutine mapaer_tofrom_host( imap, & factaeropcg8_f_o=1.0 factaersmpa=1.0 factaersmpbb=1.0 + factaerglyr1=1.0 + factaerglyr2=1.0 + factaerglysfc=1.0 + factaerglynh4=1.0 + factaerglyoh=1.0 factaerant1_c=1.0 factaerant2_c=1.0 factaerant3_c=1.0 @@ -2980,6 +4524,16 @@ subroutine mapaer_tofrom_host( imap, & factaerbiog2_o=1.0 factaerbiog3_o=1.0 factaerbiog4_o=1.0 + factaerasoaX=1.0 + factaerasoa1=1.0 + factaerasoa2=1.0 + factaerasoa3=1.0 + factaerasoa4=1.0 + factaerbsoaX=1.0 + factaerbsoa1=1.0 + factaerbsoa2=1.0 + factaerbsoa3=1.0 + factaerbsoa4=1.0 @@ -3228,6 +4782,8 @@ subroutine mapaer_tofrom_host( imap, & rsub(ksmpa,k1:k2,1) = chem(it,kt1:kt2,jt,p_smpa)/factgas if (p_smpbb .ge. p1st) & rsub(ksmpbb,k1:k2,1) = chem(it,kt1:kt2,jt,p_smpbb)/factgas + if (p_gly .ge. p1st) & + rsub(kgly,k1:k2,1) = chem(it,kt1:kt2,jt,p_gly)/factgas if (p_ant1_c .ge. p1st) & rsub(kant1_c,k1:k2,1) = chem(it,kt1:kt2,jt,p_ant1_c)/factgas if (p_ant2_c .ge. p1st) & @@ -3260,6 +4816,26 @@ subroutine mapaer_tofrom_host( imap, & rsub(kbiog3_o,k1:k2,1) = chem(it,kt1:kt2,jt,p_biog3_o)/factgas if (p_biog4_o .ge. p1st) & rsub(kbiog4_o,k1:k2,1) = chem(it,kt1:kt2,jt,p_biog4_o)/factgas + if (p_cvasoaX .ge. p1st) & + rsub(kasoaX,k1:k2,1) = chem(it,kt1:kt2,jt,p_cvasoaX)/factgas + if (p_cvasoa1 .ge. p1st) & + rsub(kasoa1,k1:k2,1) = chem(it,kt1:kt2,jt,p_cvasoa1)/factgas + if (p_cvasoa2 .ge. p1st) & + rsub(kasoa2,k1:k2,1) = chem(it,kt1:kt2,jt,p_cvasoa2)/factgas + if (p_cvasoa3 .ge. p1st) & + rsub(kasoa3,k1:k2,1) = chem(it,kt1:kt2,jt,p_cvasoa3)/factgas + if (p_cvasoa4 .ge. p1st) & + rsub(kasoa4,k1:k2,1) = chem(it,kt1:kt2,jt,p_cvasoa4)/factgas + if (p_cvbsoaX .ge. p1st) & + rsub(kbsoaX,k1:k2,1) = chem(it,kt1:kt2,jt,p_cvbsoaX)/factgas + if (p_cvbsoa1 .ge. p1st) & + rsub(kbsoa1,k1:k2,1) = chem(it,kt1:kt2,jt,p_cvbsoa1)/factgas + if (p_cvbsoa2 .ge. p1st) & + rsub(kbsoa2,k1:k2,1) = chem(it,kt1:kt2,jt,p_cvbsoa2)/factgas + if (p_cvbsoa3 .ge. p1st) & + rsub(kbsoa3,k1:k2,1) = chem(it,kt1:kt2,jt,p_cvbsoa3)/factgas + if (p_cvbsoa4 .ge. p1st) & + rsub(kbsoa4,k1:k2,1) = chem(it,kt1:kt2,jt,p_cvbsoa4)/factgas do iphase=1,nphase_aer @@ -3516,6 +5092,21 @@ subroutine mapaer_tofrom_host( imap, & if (lptr_smpbb_aer(n,itype,iphase) .ge. p1st) & rsub(lptr_smpbb_aer(n,itype,iphase),k1:k2,1) = & chem(it,kt1:kt2,jt,lptr_smpbb_aer(n,itype,iphase))/factaersmpbb + if (lptr_glysoa_r1_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_glysoa_r1_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_glysoa_r1_aer(n,itype,iphase))/factaerglyr1 + if (lptr_glysoa_r2_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_glysoa_r2_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_glysoa_r2_aer(n,itype,iphase))/factaerglyr2 + if (lptr_glysoa_sfc_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_glysoa_sfc_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_glysoa_sfc_aer(n,itype,iphase))/factaerglysfc + if (lptr_glysoa_oh_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_glysoa_oh_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_glysoa_oh_aer(n,itype,iphase))/factaerglyoh + if (lptr_glysoa_nh4_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_glysoa_nh4_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_glysoa_nh4_aer(n,itype,iphase))/factaerglynh4 if (lptr_ant1_c_aer(n,itype,iphase) .ge. p1st) & rsub(lptr_ant1_c_aer(n,itype,iphase),k1:k2,1) = & chem(it,kt1:kt2,jt,lptr_ant1_c_aer(n,itype,iphase))/factaerant1_c @@ -3564,6 +5155,36 @@ subroutine mapaer_tofrom_host( imap, & if (lptr_biog4_o_aer(n,itype,iphase) .ge. p1st) & rsub(lptr_biog4_o_aer(n,itype,iphase),k1:k2,1) = & chem(it,kt1:kt2,jt,lptr_biog4_o_aer(n,itype,iphase))/factaerbiog4_o + if (lptr_asoaX_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_asoaX_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_asoaX_aer(n,itype,iphase))/factaerasoaX + if (lptr_asoa1_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_asoa1_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_asoa1_aer(n,itype,iphase))/factaerasoa1 + if (lptr_asoa2_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_asoa2_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_asoa2_aer(n,itype,iphase))/factaerasoa2 + if (lptr_asoa3_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_asoa3_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_asoa3_aer(n,itype,iphase))/factaerasoa3 + if (lptr_asoa4_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_asoa4_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_asoa4_aer(n,itype,iphase))/factaerasoa4 + if (lptr_bsoaX_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_bsoaX_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_bsoaX_aer(n,itype,iphase))/factaerbsoaX + if (lptr_bsoa1_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_bsoa1_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_bsoa1_aer(n,itype,iphase))/factaerbsoa1 + if (lptr_bsoa2_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_bsoa2_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_bsoa2_aer(n,itype,iphase))/factaerbsoa2 + if (lptr_bsoa3_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_bsoa3_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_bsoa3_aer(n,itype,iphase))/factaerbsoa3 + if (lptr_bsoa4_aer(n,itype,iphase) .ge. p1st) & + rsub(lptr_bsoa4_aer(n,itype,iphase),k1:k2,1) = & + chem(it,kt1:kt2,jt,lptr_bsoa4_aer(n,itype,iphase))/factaerbsoa4 end do ! size end do ! type @@ -3702,6 +5323,7 @@ subroutine mapaer_tofrom_host( imap, & (l .eq. kopcg5_f_o ) .or. (l .eq. kopcg6_f_o ) .or. & (l .eq. kopcg7_f_o ) .or. (l .eq. kopcg8_f_o ) .or. & (l .eq. ksmpa ) .or. (l .eq. ksmpbb ) .or. & + (l .eq. kgly ) .or. & (l .eq. kant1_c ) .or. (l .eq. kant2_c ) .or. & (l .eq. kant3_c ) .or. (l .eq. kant4_c ) .or. & (l .eq. kant1_o ) .or. (l .eq. kant2_o ) .or. & @@ -3709,7 +5331,13 @@ subroutine mapaer_tofrom_host( imap, & (l .eq. kbiog1_c ) .or. (l .eq. kbiog2_c ) .or. & (l .eq. kbiog3_c ) .or. (l .eq. kbiog4_c ) .or. & (l .eq. kbiog1_o ) .or. (l .eq. kbiog2_o ) .or. & - (l .eq. kbiog3_o ) .or. (l .eq. kbiog4_o )) then + (l .eq. kbiog3_o ) .or. (l .eq. kbiog4_o ) .or. & + (l .eq. kasoaX ) .or. & + (l .eq. kasoa1 ) .or. (l .eq. kasoa2 ) .or. & + (l .eq. kasoa3 ) .or. (l .eq. kasoa4 ) .or. & + (l .eq. kbsoaX ) .or. & + (l .eq. kbsoa1 ) .or. (l .eq. kbsoa2 ) .or. & + (l .eq. kbsoa3 ) .or. (l .eq. kbsoa4 )) then ido_l = 0 end if end if @@ -3900,6 +5528,8 @@ subroutine mapaer_tofrom_host( imap, & chem(it,kt1:kt2,jt,p_smpa) = rsub(ksmpa,k1:k2,1)*factgas if (p_smpbb .ge. p1st) & chem(it,kt1:kt2,jt,p_smpbb) = rsub(ksmpbb,k1:k2,1)*factgas + if (p_gly .ge. p1st) & + chem(it,kt1:kt2,jt,p_gly) = rsub(kgly,k1:k2,1)*factgas if (p_ant1_c .ge. p1st) & chem(it,kt1:kt2,jt,p_ant1_c) = rsub(kant1_c,k1:k2,1)*factgas if (p_ant2_c .ge. p1st) & @@ -3932,7 +5562,26 @@ subroutine mapaer_tofrom_host( imap, & chem(it,kt1:kt2,jt,p_biog3_o) = rsub(kbiog3_o,k1:k2,1)*factgas if (p_biog4_o .ge. p1st) & chem(it,kt1:kt2,jt,p_biog4_o) = rsub(kbiog4_o,k1:k2,1)*factgas - + if (p_cvasoaX .ge. p1st) & + chem(it,kt1:kt2,jt,p_cvasoaX) = rsub(kasoaX,k1:k2,1)*factgas + if (p_cvasoa1 .ge. p1st) & + chem(it,kt1:kt2,jt,p_cvasoa1) = rsub(kasoa1,k1:k2,1)*factgas + if (p_cvasoa2 .ge. p1st) & + chem(it,kt1:kt2,jt,p_cvasoa2) = rsub(kasoa2,k1:k2,1)*factgas + if (p_cvasoa3 .ge. p1st) & + chem(it,kt1:kt2,jt,p_cvasoa3) = rsub(kasoa3,k1:k2,1)*factgas + if (p_cvasoa4 .ge. p1st) & + chem(it,kt1:kt2,jt,p_cvasoa4) = rsub(kasoa4,k1:k2,1)*factgas + if (p_cvbsoaX .ge. p1st) & + chem(it,kt1:kt2,jt,p_cvbsoaX) = rsub(kbsoaX,k1:k2,1)*factgas + if (p_cvbsoa1 .ge. p1st) & + chem(it,kt1:kt2,jt,p_cvbsoa1) = rsub(kbsoa1,k1:k2,1)*factgas + if (p_cvbsoa2 .ge. p1st) & + chem(it,kt1:kt2,jt,p_cvbsoa2) = rsub(kbsoa2,k1:k2,1)*factgas + if (p_cvbsoa3 .ge. p1st) & + chem(it,kt1:kt2,jt,p_cvbsoa3) = rsub(kbsoa3,k1:k2,1)*factgas + if (p_cvbsoa4 .ge. p1st) & + chem(it,kt1:kt2,jt,p_cvbsoa4) = rsub(kbsoa4,k1:k2,1)*factgas end if do iphase=1,nphase_aer @@ -4189,6 +5838,21 @@ subroutine mapaer_tofrom_host( imap, & if (lptr_smpbb_aer(n,itype,iphase) .ge. p1st) & chem(it,kt1:kt2,jt,lptr_smpbb_aer(n,itype,iphase)) = & rsub(lptr_smpbb_aer(n,itype,iphase),k1:k2,1)*factaersmpbb + if (lptr_glysoa_r1_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_glysoa_r1_aer(n,itype,iphase)) = & + rsub(lptr_glysoa_r1_aer(n,itype,iphase),k1:k2,1)*factaerglyr1 + if (lptr_glysoa_r2_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_glysoa_r2_aer(n,itype,iphase)) = & + rsub(lptr_glysoa_r2_aer(n,itype,iphase),k1:k2,1)*factaerglyr2 + if (lptr_glysoa_sfc_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_glysoa_sfc_aer(n,itype,iphase)) = & + rsub(lptr_glysoa_sfc_aer(n,itype,iphase),k1:k2,1)*factaerglysfc + if (lptr_glysoa_oh_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_glysoa_oh_aer(n,itype,iphase)) = & + rsub(lptr_glysoa_oh_aer(n,itype,iphase),k1:k2,1)*factaerglyoh + if (lptr_glysoa_nh4_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_glysoa_nh4_aer(n,itype,iphase)) = & + rsub(lptr_glysoa_nh4_aer(n,itype,iphase),k1:k2,1)*factaerglynh4 if (lptr_ant1_c_aer(n,itype,iphase) .ge. p1st) & chem(it,kt1:kt2,jt,lptr_ant1_c_aer(n,itype,iphase)) = & rsub(lptr_ant1_c_aer(n,itype,iphase),k1:k2,1)*factaerant1_c @@ -4237,6 +5901,36 @@ subroutine mapaer_tofrom_host( imap, & if (lptr_biog4_o_aer(n,itype,iphase) .ge. p1st) & chem(it,kt1:kt2,jt,lptr_biog4_o_aer(n,itype,iphase)) = & rsub(lptr_biog4_o_aer(n,itype,iphase),k1:k2,1)*factaerbiog4_o + if (lptr_asoaX_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_asoaX_aer(n,itype,iphase)) = & + rsub(lptr_asoaX_aer(n,itype,iphase),k1:k2,1)*factaerasoaX + if (lptr_asoa1_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_asoa1_aer(n,itype,iphase)) = & + rsub(lptr_asoa1_aer(n,itype,iphase),k1:k2,1)*factaerasoa1 + if (lptr_asoa2_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_asoa2_aer(n,itype,iphase)) = & + rsub(lptr_asoa2_aer(n,itype,iphase),k1:k2,1)*factaerasoa2 + if (lptr_asoa3_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_asoa3_aer(n,itype,iphase)) = & + rsub(lptr_asoa3_aer(n,itype,iphase),k1:k2,1)*factaerasoa3 + if (lptr_asoa4_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_asoa4_aer(n,itype,iphase)) = & + rsub(lptr_asoa4_aer(n,itype,iphase),k1:k2,1)*factaerasoa4 + if (lptr_bsoaX_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_bsoaX_aer(n,itype,iphase)) = & + rsub(lptr_bsoaX_aer(n,itype,iphase),k1:k2,1)*factaerbsoaX + if (lptr_bsoa1_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_bsoa1_aer(n,itype,iphase)) = & + rsub(lptr_bsoa1_aer(n,itype,iphase),k1:k2,1)*factaerbsoa1 + if (lptr_bsoa2_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_bsoa2_aer(n,itype,iphase)) = & + rsub(lptr_bsoa2_aer(n,itype,iphase),k1:k2,1)*factaerbsoa2 + if (lptr_bsoa3_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_bsoa3_aer(n,itype,iphase)) = & + rsub(lptr_bsoa3_aer(n,itype,iphase),k1:k2,1)*factaerbsoa3 + if (lptr_bsoa4_aer(n,itype,iphase) .ge. p1st) & + chem(it,kt1:kt2,jt,lptr_bsoa4_aer(n,itype,iphase)) = & + rsub(lptr_bsoa4_aer(n,itype,iphase),k1:k2,1)*factaerbsoa4 @@ -4253,7 +5947,7 @@ end subroutine mapaer_tofrom_host !----------------------------------------------------------------------- ! *** note - eventually is_aerosol will be a subr argument - subroutine init_data_mosaic_asect( n2o5_hetchem, is_aerosol ) + subroutine init_data_mosaic_asect(id, n2o5_hetchem, is_aerosol ) ! subroutine init_data_mosaic_asect( ) use module_data_mosaic_asect @@ -4288,7 +5982,43 @@ subroutine init_data_mosaic_asect( n2o5_hetchem, is_aerosol ) p_oin_cw05, p_oc_cw05, p_bc_cw05, p_num_cw05, & p_oin_cw06, p_oc_cw06, p_bc_cw06, p_num_cw06, & p_oin_cw07, p_oc_cw07, p_bc_cw07, p_num_cw07, & - p_oin_cw08, p_oc_cw08, p_bc_cw08, p_num_cw08 + p_oin_cw08, p_oc_cw08, p_bc_cw08, p_num_cw08, & + p_glysoa_r1_cw01, p_glysoa_r2_cw01, p_glysoa_sfc_cw01, p_glysoa_nh4_cw01, p_glysoa_oh_cw01, & + p_glysoa_r1_cw02, p_glysoa_r2_cw02, p_glysoa_sfc_cw02, p_glysoa_nh4_cw02, p_glysoa_oh_cw02, & + p_glysoa_r1_cw03, p_glysoa_r2_cw03, p_glysoa_sfc_cw03, p_glysoa_nh4_cw03, p_glysoa_oh_cw03, & + p_glysoa_r1_cw04, p_glysoa_r2_cw04, p_glysoa_sfc_cw04, p_glysoa_nh4_cw04, p_glysoa_oh_cw04, & + p_asoaX_cw01, p_asoa1_cw01, p_asoa2_cw01, p_asoa3_cw01, p_asoa4_cw01, & + p_bsoaX_cw01, p_bsoa1_cw01, p_bsoa2_cw01, p_bsoa3_cw01, p_bsoa4_cw01, & + p_asoaX_cw02, p_asoa1_cw02, p_asoa2_cw02, p_asoa3_cw02, p_asoa4_cw02, & + p_bsoaX_cw02, p_bsoa1_cw02, p_bsoa2_cw02, p_bsoa3_cw02, p_bsoa4_cw02, & + p_asoaX_cw03, p_asoa1_cw03, p_asoa2_cw03, p_asoa3_cw03, p_asoa4_cw03, & + p_bsoaX_cw03, p_bsoa1_cw03, p_bsoa2_cw03, p_bsoa3_cw03, p_bsoa4_cw03, & + p_asoaX_cw04, p_asoa1_cw04, p_asoa2_cw04, p_asoa3_cw04, p_asoa4_cw04, & + p_bsoaX_cw04, p_bsoa1_cw04, p_bsoa2_cw04, p_bsoa3_cw04, p_bsoa4_cw04, & + p_pcg1_b_c_cw01,p_pcg1_b_o_cw01,p_opcg1_b_c_cw01,p_opcg1_b_o_cw01, & + p_pcg1_f_c_cw01,p_pcg1_f_o_cw01,p_opcg1_f_c_cw01,p_opcg1_f_o_cw01, & + p_ant1_c_cw01,p_biog1_c_cw01, & + p_pcg1_b_c_cw02,p_pcg1_b_o_cw02,p_opcg1_b_c_cw02,p_opcg1_b_o_cw02, & + p_pcg1_f_c_cw02,p_pcg1_f_o_cw02,p_opcg1_f_c_cw02,p_opcg1_f_o_cw02, & + p_ant1_c_cw02,p_biog1_c_cw02, & + p_pcg1_b_c_cw03,p_pcg1_b_o_cw03,p_opcg1_b_c_cw03,p_opcg1_b_o_cw03, & + p_pcg1_f_c_cw03,p_pcg1_f_o_cw03,p_opcg1_f_c_cw03,p_opcg1_f_o_cw03, & + p_ant1_c_cw03,p_biog1_c_cw03, & + p_pcg1_b_c_cw04,p_pcg1_b_o_cw04,p_opcg1_b_c_cw04,p_opcg1_b_o_cw04, & + p_pcg1_f_c_cw04,p_pcg1_f_o_cw04,p_opcg1_f_c_cw04,p_opcg1_f_o_cw04, & + p_ant1_c_cw04,p_biog1_c_cw04, & + p_pcg1_b_c_cw05,p_pcg1_b_o_cw05,p_opcg1_b_c_cw05,p_opcg1_b_o_cw05, & + p_pcg1_f_c_cw05,p_pcg1_f_o_cw05,p_opcg1_f_c_cw05,p_opcg1_f_o_cw05, & + p_ant1_c_cw05,p_biog1_c_cw05, & + p_pcg1_b_c_cw06,p_pcg1_b_o_cw06,p_opcg1_b_c_cw06,p_opcg1_b_o_cw06, & + p_pcg1_f_c_cw06,p_pcg1_f_o_cw06,p_opcg1_f_c_cw06,p_opcg1_f_o_cw06, & + p_ant1_c_cw06,p_biog1_c_cw06, & + p_pcg1_b_c_cw07,p_pcg1_b_o_cw07,p_opcg1_b_c_cw07,p_opcg1_b_o_cw07, & + p_pcg1_f_c_cw07,p_pcg1_f_o_cw07,p_opcg1_f_c_cw07,p_opcg1_f_o_cw07, & + p_ant1_c_cw07,p_biog1_c_cw07, & + p_pcg1_b_c_cw08,p_pcg1_b_o_cw08,p_opcg1_b_c_cw08,p_opcg1_b_o_cw08, & + p_pcg1_f_c_cw08,p_pcg1_f_o_cw08,p_opcg1_f_c_cw08,p_opcg1_f_o_cw08, & + p_ant1_c_cw08,p_biog1_c_cw08 #endif use module_state_description, only: param_first_scalar, num_chem @@ -4298,7 +6028,7 @@ subroutine init_data_mosaic_asect( n2o5_hetchem, is_aerosol ) ! *** note - eventually is_aerosol will be a subr argument logical, intent(out) :: is_aerosol(num_chem) ! control flag for N2O5 het chem scheme - integer, intent(in) :: n2o5_hetchem + integer, intent(in) :: id,n2o5_hetchem ! local variables integer idum, itype, l, ldum, n, nhi, nsize_aer_dum @@ -4403,7 +6133,8 @@ subroutine init_data_mosaic_asect( n2o5_hetchem, is_aerosol ) ! ! set master aerosol chemical types ! - ntot_mastercomp_aer = 96 +! ntot_mastercomp_aer = 96 + ntot_mastercomp_aer = 111 l = 1 mastercompindx_so4_aer = l @@ -5078,7 +6809,110 @@ subroutine init_data_mosaic_asect( n2o5_hetchem, is_aerosol ) mw_mastercomp_aer( l ) = mw_smpbb_aer hygro_mastercomp_aer(l ) = hygro_smpbb_aer - + l = 97 + mastercompindx_glysoa_r1_aer = l + name_mastercomp_aer( l ) = 'glysoa_r1' + dens_mastercomp_aer( l ) = dens_glysoa_r1_aer + mw_mastercomp_aer( l ) = mw_glysoa_r1_aer + hygro_mastercomp_aer(l ) = hygro_glysoa_r1_aer + + l = 98 + mastercompindx_glysoa_r2_aer = l + name_mastercomp_aer( l ) = 'glysoa_r2' + dens_mastercomp_aer( l ) = dens_glysoa_r2_aer + mw_mastercomp_aer( l ) = mw_glysoa_r2_aer + hygro_mastercomp_aer(l ) = hygro_glysoa_r2_aer + + l = 99 + mastercompindx_glysoa_sfc_aer = l + name_mastercomp_aer( l ) = 'glysoa_sfc' + dens_mastercomp_aer( l ) = dens_glysoa_sfc_aer + mw_mastercomp_aer( l ) = mw_glysoa_sfc_aer + hygro_mastercomp_aer(l ) = hygro_glysoa_sfc_aer + + l = 100 + mastercompindx_glysoa_nh4_aer = l + name_mastercomp_aer( l ) = 'glysoa_nh4' + dens_mastercomp_aer( l ) = dens_glysoa_nh4_aer + mw_mastercomp_aer( l ) = mw_glysoa_nh4_aer + hygro_mastercomp_aer(l ) = hygro_glysoa_nh4_aer + + l = 101 + mastercompindx_glysoa_oh_aer = l + name_mastercomp_aer( l ) = 'glysoa_oh' + dens_mastercomp_aer( l ) = dens_glysoa_oh_aer + mw_mastercomp_aer( l ) = mw_glysoa_oh_aer + hygro_mastercomp_aer(l ) = hygro_glysoa_oh_aer + + l = 102 + mastercompindx_asoaX_aer = l + name_mastercomp_aer( l ) = 'asoaX' + dens_mastercomp_aer( l ) = dens_asoaX_aer + mw_mastercomp_aer( l ) = mw_asoaX_aer + hygro_mastercomp_aer(l ) = hygro_asoaX_aer + + l = 103 + mastercompindx_asoa1_aer = l + name_mastercomp_aer( l ) = 'asoa1' + dens_mastercomp_aer( l ) = dens_asoa1_aer + mw_mastercomp_aer( l ) = mw_asoa1_aer + hygro_mastercomp_aer(l ) = hygro_asoa1_aer + + l = 104 + mastercompindx_asoa2_aer = l + name_mastercomp_aer( l ) = 'asoa2' + dens_mastercomp_aer( l ) = dens_asoa2_aer + mw_mastercomp_aer( l ) = mw_asoa2_aer + hygro_mastercomp_aer(l ) = hygro_asoa2_aer + + l = 105 + mastercompindx_asoa3_aer = l + name_mastercomp_aer( l ) = 'asoa3' + dens_mastercomp_aer( l ) = dens_asoa3_aer + mw_mastercomp_aer( l ) = mw_asoa3_aer + hygro_mastercomp_aer(l ) = hygro_asoa3_aer + + l = 106 + mastercompindx_asoa4_aer = l + name_mastercomp_aer( l ) = 'asoa4' + dens_mastercomp_aer( l ) = dens_asoa4_aer + mw_mastercomp_aer( l ) = mw_asoa4_aer + hygro_mastercomp_aer(l ) = hygro_asoa4_aer + + l = 107 + mastercompindx_bsoaX_aer = l + name_mastercomp_aer( l ) = 'bsoaX' + dens_mastercomp_aer( l ) = dens_bsoaX_aer + mw_mastercomp_aer( l ) = mw_bsoaX_aer + hygro_mastercomp_aer(l ) = hygro_bsoaX_aer + + l = 108 + mastercompindx_bsoa1_aer = l + name_mastercomp_aer( l ) = 'bsoa1' + dens_mastercomp_aer( l ) = dens_bsoa1_aer + mw_mastercomp_aer( l ) = mw_bsoa1_aer + hygro_mastercomp_aer(l ) = hygro_bsoa1_aer + + l = 109 + mastercompindx_bsoa2_aer = l + name_mastercomp_aer( l ) = 'bsoa2' + dens_mastercomp_aer( l ) = dens_bsoa2_aer + mw_mastercomp_aer( l ) = mw_bsoa2_aer + hygro_mastercomp_aer(l ) = hygro_bsoa2_aer + + l = 110 + mastercompindx_bsoa3_aer = l + name_mastercomp_aer( l ) = 'bsoa3' + dens_mastercomp_aer( l ) = dens_bsoa3_aer + mw_mastercomp_aer( l ) = mw_bsoa3_aer + hygro_mastercomp_aer(l ) = hygro_bsoa3_aer + + l = 111 + mastercompindx_bsoa4_aer = l + name_mastercomp_aer( l ) = 'bsoa4' + dens_mastercomp_aer( l ) = dens_bsoa4_aer + mw_mastercomp_aer( l ) = mw_bsoa4_aer + hygro_mastercomp_aer(l ) = hygro_bsoa4_aer ! ! set section size arrays @@ -5088,7 +6922,7 @@ subroutine init_data_mosaic_asect( n2o5_hetchem, is_aerosol ) dlo_sect(1,itype) = 3.90625e-6 dhi_sect(nhi,itype) = 10.0e-4 - dum = alog( dhi_sect(nhi,itype)/dlo_sect(1,itype) ) / nhi + dum = log( dhi_sect(nhi,itype)/dlo_sect(1,itype) ) / nhi !replaced alog by log by Manish Shrivastava on 11/28/2011. alog denoted natural log in fortran 77. log(x) is natural log in fortran 90 do n = 2, nhi dlo_sect(n,itype) = dlo_sect(1,itype) * exp( (n-1)*dum ) dhi_sect(n-1,itype) = dlo_sect(n,itype) @@ -5105,7 +6939,7 @@ subroutine init_data_mosaic_asect( n2o5_hetchem, is_aerosol ) ! ! set pointers to wrf chem-array species ! - call init_data_mosaic_ptr( is_aerosol ) + call init_data_mosaic_ptr( id,is_aerosol ) ! ! csuesat initialization @@ -5125,7 +6959,7 @@ end subroutine init_data_mosaic_asect !----------------------------------------------------------------------- - subroutine init_data_mosaic_ptr( is_aerosol ) + subroutine init_data_mosaic_ptr( id,is_aerosol ) use module_configure use module_state_description, only: param_first_scalar,num_chem @@ -5154,19 +6988,24 @@ subroutine init_data_mosaic_ptr( is_aerosol ) kopcg3_f_o,kopcg4_f_o,kopcg5_f_o,kopcg6_f_o,& kopcg7_f_o,kopcg8_f_o, & ksmpa,ksmpbb, & + kgly, & kant1_c,kant2_c,kant3_c,kant4_c,kant1_o,kant2_o, & kant3_o,kant4_o, & kbiog1_c,kbiog2_c,kbiog3_c,kbiog4_c,kbiog1_o,kbiog2_o, & kbiog3_o,kbiog4_o, & - kn2o5, kclno2 +! kn2o5, kclno2 + kn2o5, kclno2, & + kasoaX,kasoa1,kasoa2,kasoa3,kasoa4,& + kbsoaX,kbsoa1,kbsoa2,kbsoa3,kbsoa4 use module_peg_util, only: peg_error_fatal, peg_message use module_mosaic_wetscav, only: initwet - + use module_scalar_tables, only: chem_dname_table implicit none ! subr arguments logical, intent(out) :: is_aerosol(num_chem) + integer, intent(in) :: id ! local variables integer l, ll, n, p1st integer iaddto_ncomp, iaddto_ncomp_plustracer @@ -5199,10 +7038,13 @@ subroutine init_data_mosaic_ptr( is_aerosol ) y_opcg3_f_o,y_opcg4_f_o,y_opcg5_f_o,y_opcg6_f_o,& y_opcg7_f_o,y_opcg8_f_o, & y_smpa,y_smpbb, & + y_glysoa_r1, y_glysoa_r2, y_glysoa_sfc, y_glysoa_nh4, y_glysoa_oh, & y_ant1_c,y_ant2_c,y_ant3_c,y_ant4_c, & y_ant1_o,y_ant2_o,y_ant3_o,y_ant4_o, & y_biog1_c,y_biog2_c,y_biog3_c,y_biog4_c, & - y_biog1_o,y_biog2_o,y_biog3_o,y_biog4_o + y_biog1_o,y_biog2_o,y_biog3_o,y_biog4_o, & + y_asoaX, y_asoa1, y_asoa2, y_asoa3, y_asoa4, & + y_bsoaX, y_bsoa1, y_bsoa2, y_bsoa3, y_bsoa4 integer y_cw_so4, y_cw_no3, y_cw_cl, y_cw_msa, y_cw_co3, & y_cw_nh4, y_cw_na, & @@ -5302,6 +7144,11 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_opcg8_f_o_aer(:,itype,:) = 1 lptr_smpa_aer(:,itype,:) = 1 lptr_smpbb_aer(:,itype,:) = 1 + lptr_glysoa_r1_aer(:,itype,:) = 1 + lptr_glysoa_r2_aer(:,itype,:) = 1 + lptr_glysoa_sfc_aer(:,itype,:) = 1 + lptr_glysoa_nh4_aer(:,itype,:) = 1 + lptr_glysoa_oh_aer(:,itype,:) = 1 lptr_ant1_c_aer(:,itype,:) = 1 lptr_ant2_c_aer(:,itype,:) = 1 lptr_ant3_c_aer(:,itype,:) = 1 @@ -5318,6 +7165,16 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_biog2_o_aer(:,itype,:) = 1 lptr_biog3_o_aer(:,itype,:) = 1 lptr_biog4_o_aer(:,itype,:) = 1 + lptr_asoaX_aer(:,itype,:) = 1 + lptr_asoa1_aer(:,itype,:) = 1 + lptr_asoa2_aer(:,itype,:) = 1 + lptr_asoa3_aer(:,itype,:) = 1 + lptr_asoa4_aer(:,itype,:) = 1 + lptr_bsoaX_aer(:,itype,:) = 1 + lptr_bsoa1_aer(:,itype,:) = 1 + lptr_bsoa2_aer(:,itype,:) = 1 + lptr_bsoa3_aer(:,itype,:) = 1 + lptr_bsoa4_aer(:,itype,:) = 1 if (nsize_aer(itype) .ge. 1) then @@ -5405,6 +7262,11 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (p_opcg8_f_o_a01 .ge. p1st) lptr_opcg8_f_o_aer(01,itype,ai_phase) = p_opcg8_f_o_a01 if (p_smpa_a01 .ge. p1st) lptr_smpa_aer(01,itype,ai_phase) = p_smpa_a01 if (p_smpbb_a01 .ge. p1st) lptr_smpbb_aer(01,itype,ai_phase) = p_smpbb_a01 + if (p_glysoa_r1_a01 .ge. p1st) lptr_glysoa_r1_aer (01,itype,ai_phase) = p_glysoa_r1_a01 + if (p_glysoa_r2_a01 .ge. p1st) lptr_glysoa_r2_aer (01,itype,ai_phase) = p_glysoa_r2_a01 + if (p_glysoa_sfc_a01 .ge. p1st) lptr_glysoa_sfc_aer (01,itype,ai_phase) = p_glysoa_sfc_a01 + if (p_glysoa_nh4_a01 .ge. p1st) lptr_glysoa_nh4_aer (01,itype,ai_phase) = p_glysoa_nh4_a01 + if (p_glysoa_oh_a01 .ge. p1st) lptr_glysoa_oh_aer (01,itype,ai_phase) = p_glysoa_oh_a01 if (p_ant1_c_a01 .ge. p1st) lptr_ant1_c_aer(01,itype,ai_phase) = p_ant1_c_a01 if (p_ant2_c_a01 .ge. p1st) lptr_ant2_c_aer(01,itype,ai_phase) = p_ant2_c_a01 if (p_ant3_c_a01 .ge. p1st) lptr_ant3_c_aer(01,itype,ai_phase) = p_ant3_c_a01 @@ -5421,6 +7283,16 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (p_biog2_o_a01 .ge. p1st) lptr_biog2_o_aer(01,itype,ai_phase) = p_biog2_o_a01 if (p_biog3_o_a01 .ge. p1st) lptr_biog3_o_aer(01,itype,ai_phase) = p_biog3_o_a01 if (p_biog4_o_a01 .ge. p1st) lptr_biog4_o_aer(01,itype,ai_phase) = p_biog4_o_a01 + if (p_asoaX_a01 .ge. p1st) lptr_asoaX_aer(01,itype,ai_phase) = p_asoaX_a01 + if (p_asoa1_a01 .ge. p1st) lptr_asoa1_aer(01,itype,ai_phase) = p_asoa1_a01 + if (p_asoa2_a01 .ge. p1st) lptr_asoa2_aer(01,itype,ai_phase) = p_asoa2_a01 + if (p_asoa3_a01 .ge. p1st) lptr_asoa3_aer(01,itype,ai_phase) = p_asoa3_a01 + if (p_asoa4_a01 .ge. p1st) lptr_asoa4_aer(01,itype,ai_phase) = p_asoa4_a01 + if (p_bsoaX_a01 .ge. p1st) lptr_bsoaX_aer(01,itype,ai_phase) = p_bsoaX_a01 + if (p_bsoa1_a01 .ge. p1st) lptr_bsoa1_aer(01,itype,ai_phase) = p_bsoa1_a01 + if (p_bsoa2_a01 .ge. p1st) lptr_bsoa2_aer(01,itype,ai_phase) = p_bsoa2_a01 + if (p_bsoa3_a01 .ge. p1st) lptr_bsoa3_aer(01,itype,ai_phase) = p_bsoa3_a01 + if (p_bsoa4_a01 .ge. p1st) lptr_bsoa4_aer(01,itype,ai_phase) = p_bsoa4_a01 if (p_num_a01 .ge. p1st) numptr_aer(01,itype,ai_phase) = p_num_a01 end if @@ -5508,6 +7380,11 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (p_opcg8_f_o_a02 .ge. p1st) lptr_opcg8_f_o_aer(02,itype,ai_phase) = p_opcg8_f_o_a02 if (p_smpa_a02 .ge. p1st) lptr_smpa_aer(02,itype,ai_phase) = p_smpa_a02 if (p_smpbb_a02 .ge. p1st) lptr_smpbb_aer(02,itype,ai_phase) = p_smpbb_a02 + if (p_glysoa_r1_a02 .ge. p1st) lptr_glysoa_r1_aer (02,itype,ai_phase) = p_glysoa_r1_a02 + if (p_glysoa_r2_a02 .ge. p1st) lptr_glysoa_r2_aer (02,itype,ai_phase) = p_glysoa_r2_a02 + if (p_glysoa_sfc_a02 .ge. p1st) lptr_glysoa_sfc_aer(02,itype,ai_phase) = p_glysoa_sfc_a02 + if (p_glysoa_nh4_a02 .ge. p1st) lptr_glysoa_nh4_aer(02,itype,ai_phase) = p_glysoa_nh4_a02 + if (p_glysoa_oh_a02 .ge. p1st) lptr_glysoa_oh_aer(02,itype,ai_phase) = p_glysoa_oh_a02 if (p_ant1_c_a02 .ge. p1st) lptr_ant1_c_aer(02,itype,ai_phase) = p_ant1_c_a02 if (p_ant2_c_a02 .ge. p1st) lptr_ant2_c_aer(02,itype,ai_phase) = p_ant2_c_a02 if (p_ant3_c_a02 .ge. p1st) lptr_ant3_c_aer(02,itype,ai_phase) = p_ant3_c_a02 @@ -5524,6 +7401,16 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (p_biog2_o_a02 .ge. p1st) lptr_biog2_o_aer(02,itype,ai_phase) = p_biog2_o_a02 if (p_biog3_o_a02 .ge. p1st) lptr_biog3_o_aer(02,itype,ai_phase) = p_biog3_o_a02 if (p_biog4_o_a02 .ge. p1st) lptr_biog4_o_aer(02,itype,ai_phase) = p_biog4_o_a02 + if (p_asoaX_a02 .ge. p1st) lptr_asoaX_aer(02,itype,ai_phase) = p_asoaX_a02 + if (p_asoa1_a02 .ge. p1st) lptr_asoa1_aer(02,itype,ai_phase) = p_asoa1_a02 + if (p_asoa2_a02 .ge. p1st) lptr_asoa2_aer(02,itype,ai_phase) = p_asoa2_a02 + if (p_asoa3_a02 .ge. p1st) lptr_asoa3_aer(02,itype,ai_phase) = p_asoa3_a02 + if (p_asoa4_a02 .ge. p1st) lptr_asoa4_aer(02,itype,ai_phase) = p_asoa4_a02 + if (p_bsoaX_a02 .ge. p1st) lptr_bsoaX_aer(02,itype,ai_phase) = p_bsoaX_a02 + if (p_bsoa1_a02 .ge. p1st) lptr_bsoa1_aer(02,itype,ai_phase) = p_bsoa1_a02 + if (p_bsoa2_a02 .ge. p1st) lptr_bsoa2_aer(02,itype,ai_phase) = p_bsoa2_a02 + if (p_bsoa3_a02 .ge. p1st) lptr_bsoa3_aer(02,itype,ai_phase) = p_bsoa3_a02 + if (p_bsoa4_a02 .ge. p1st) lptr_bsoa4_aer(02,itype,ai_phase) = p_bsoa4_a02 if (p_num_a02 .ge. p1st) numptr_aer(02,itype,ai_phase) = p_num_a02 end if @@ -5611,6 +7498,11 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (p_opcg8_f_o_a03 .ge. p1st) lptr_opcg8_f_o_aer(03,itype,ai_phase) = p_opcg8_f_o_a03 if (p_smpa_a03 .ge. p1st) lptr_smpa_aer(03,itype,ai_phase) = p_smpa_a03 if (p_smpbb_a03 .ge. p1st) lptr_smpbb_aer(03,itype,ai_phase) = p_smpbb_a03 + if (p_glysoa_r1_a03 .ge. p1st) lptr_glysoa_r1_aer (03,itype,ai_phase) = p_glysoa_r1_a03 + if (p_glysoa_r2_a03 .ge. p1st) lptr_glysoa_r2_aer (03,itype,ai_phase) = p_glysoa_r2_a03 + if (p_glysoa_sfc_a03 .ge. p1st) lptr_glysoa_sfc_aer(03,itype,ai_phase) = p_glysoa_sfc_a03 + if (p_glysoa_nh4_a03 .ge. p1st) lptr_glysoa_nh4_aer(03,itype,ai_phase) = p_glysoa_nh4_a03 + if (p_glysoa_oh_a03 .ge. p1st) lptr_glysoa_oh_aer(03,itype,ai_phase) = p_glysoa_oh_a03 if (p_ant1_c_a03 .ge. p1st) lptr_ant1_c_aer(03,itype,ai_phase) = p_ant1_c_a03 if (p_ant2_c_a03 .ge. p1st) lptr_ant2_c_aer(03,itype,ai_phase) = p_ant2_c_a03 if (p_ant3_c_a03 .ge. p1st) lptr_ant3_c_aer(03,itype,ai_phase) = p_ant3_c_a03 @@ -5627,6 +7519,16 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (p_biog2_o_a03 .ge. p1st) lptr_biog2_o_aer(03,itype,ai_phase) = p_biog2_o_a03 if (p_biog3_o_a03 .ge. p1st) lptr_biog3_o_aer(03,itype,ai_phase) = p_biog3_o_a03 if (p_biog4_o_a03 .ge. p1st) lptr_biog4_o_aer(03,itype,ai_phase) = p_biog4_o_a03 + if (p_asoaX_a03 .ge. p1st) lptr_asoaX_aer(03,itype,ai_phase) = p_asoaX_a03 + if (p_asoa1_a03 .ge. p1st) lptr_asoa1_aer(03,itype,ai_phase) = p_asoa1_a03 + if (p_asoa2_a03 .ge. p1st) lptr_asoa2_aer(03,itype,ai_phase) = p_asoa2_a03 + if (p_asoa3_a03 .ge. p1st) lptr_asoa3_aer(03,itype,ai_phase) = p_asoa3_a03 + if (p_asoa4_a03 .ge. p1st) lptr_asoa4_aer(03,itype,ai_phase) = p_asoa4_a03 + if (p_bsoaX_a03 .ge. p1st) lptr_bsoaX_aer(03,itype,ai_phase) = p_bsoaX_a03 + if (p_bsoa1_a03 .ge. p1st) lptr_bsoa1_aer(03,itype,ai_phase) = p_bsoa1_a03 + if (p_bsoa2_a03 .ge. p1st) lptr_bsoa2_aer(03,itype,ai_phase) = p_bsoa2_a03 + if (p_bsoa3_a03 .ge. p1st) lptr_bsoa3_aer(03,itype,ai_phase) = p_bsoa3_a03 + if (p_bsoa4_a03 .ge. p1st) lptr_bsoa4_aer(03,itype,ai_phase) = p_bsoa4_a03 if (p_num_a03 .ge. p1st) numptr_aer(03,itype,ai_phase) = p_num_a03 end if @@ -5715,6 +7617,11 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (p_opcg8_f_o_a04 .ge. p1st) lptr_opcg8_f_o_aer(04,itype,ai_phase) = p_opcg8_f_o_a04 if (p_smpa_a04 .ge. p1st) lptr_smpa_aer(04,itype,ai_phase) = p_smpa_a04 if (p_smpbb_a04 .ge. p1st) lptr_smpbb_aer(04,itype,ai_phase) = p_smpbb_a04 + if (p_glysoa_r1_a04 .ge. p1st) lptr_glysoa_r1_aer (04,itype,ai_phase) = p_glysoa_r1_a04 + if (p_glysoa_r2_a04 .ge. p1st) lptr_glysoa_r2_aer (04,itype,ai_phase) = p_glysoa_r2_a04 + if (p_glysoa_sfc_a04 .ge. p1st) lptr_glysoa_sfc_aer(04,itype,ai_phase) = p_glysoa_sfc_a04 + if (p_glysoa_nh4_a04 .ge. p1st) lptr_glysoa_nh4_aer(04,itype,ai_phase) = p_glysoa_nh4_a04 + if (p_glysoa_oh_a04 .ge. p1st) lptr_glysoa_oh_aer(04,itype,ai_phase) = p_glysoa_oh_a04 if (p_ant1_c_a04 .ge. p1st) lptr_ant1_c_aer(04,itype,ai_phase) = p_ant1_c_a04 if (p_ant2_c_a04 .ge. p1st) lptr_ant2_c_aer(04,itype,ai_phase) = p_ant2_c_a04 if (p_ant3_c_a04 .ge. p1st) lptr_ant3_c_aer(04,itype,ai_phase) = p_ant3_c_a04 @@ -5731,6 +7638,16 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (p_biog2_o_a04 .ge. p1st) lptr_biog2_o_aer(04,itype,ai_phase) = p_biog2_o_a04 if (p_biog3_o_a04 .ge. p1st) lptr_biog3_o_aer(04,itype,ai_phase) = p_biog3_o_a04 if (p_biog4_o_a04 .ge. p1st) lptr_biog4_o_aer(04,itype,ai_phase) = p_biog4_o_a04 + if (p_asoaX_a04 .ge. p1st) lptr_asoaX_aer(04,itype,ai_phase) = p_asoaX_a04 + if (p_asoa1_a04 .ge. p1st) lptr_asoa1_aer(04,itype,ai_phase) = p_asoa1_a04 + if (p_asoa2_a04 .ge. p1st) lptr_asoa2_aer(04,itype,ai_phase) = p_asoa2_a04 + if (p_asoa3_a04 .ge. p1st) lptr_asoa3_aer(04,itype,ai_phase) = p_asoa3_a04 + if (p_asoa4_a04 .ge. p1st) lptr_asoa4_aer(04,itype,ai_phase) = p_asoa4_a04 + if (p_bsoaX_a04 .ge. p1st) lptr_bsoaX_aer(04,itype,ai_phase) = p_bsoaX_a04 + if (p_bsoa1_a04 .ge. p1st) lptr_bsoa1_aer(04,itype,ai_phase) = p_bsoa1_a04 + if (p_bsoa2_a04 .ge. p1st) lptr_bsoa2_aer(04,itype,ai_phase) = p_bsoa2_a04 + if (p_bsoa3_a04 .ge. p1st) lptr_bsoa3_aer(04,itype,ai_phase) = p_bsoa3_a04 + if (p_bsoa4_a04 .ge. p1st) lptr_bsoa4_aer(04,itype,ai_phase) = p_bsoa4_a04 if (p_num_a04 .ge. p1st) numptr_aer(04,itype,ai_phase) = p_num_a04 end if @@ -5749,76 +7666,91 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_bc_aer(05,itype,ai_phase) = p_bc_a05 hyswptr_aer(05,itype) = p_hysw_a05 waterptr_aer(05,itype) = p_water_a05 - lptr_pcg1_b_c_aer(05,itype,ai_phase) = p_pcg1_b_c_a05 - lptr_pcg2_b_c_aer(05,itype,ai_phase) = p_pcg2_b_c_a05 - lptr_pcg3_b_c_aer(05,itype,ai_phase) = p_pcg3_b_c_a05 - lptr_pcg4_b_c_aer(05,itype,ai_phase) = p_pcg4_b_c_a05 - lptr_pcg5_b_c_aer(05,itype,ai_phase) = p_pcg5_b_c_a05 - lptr_pcg6_b_c_aer(05,itype,ai_phase) = p_pcg6_b_c_a05 - lptr_pcg7_b_c_aer(05,itype,ai_phase) = p_pcg7_b_c_a05 - lptr_pcg8_b_c_aer(05,itype,ai_phase) = p_pcg8_b_c_a05 - lptr_pcg9_b_c_aer(05,itype,ai_phase) = p_pcg9_b_c_a05 - lptr_pcg1_b_o_aer(05,itype,ai_phase) = p_pcg1_b_o_a05 - lptr_pcg2_b_o_aer(05,itype,ai_phase) = p_pcg2_b_o_a05 - lptr_pcg3_b_o_aer(05,itype,ai_phase) = p_pcg3_b_o_a05 - lptr_pcg4_b_o_aer(05,itype,ai_phase) = p_pcg4_b_o_a05 - lptr_pcg5_b_o_aer(05,itype,ai_phase) = p_pcg5_b_o_a05 - lptr_pcg6_b_o_aer(05,itype,ai_phase) = p_pcg6_b_o_a05 - lptr_pcg7_b_o_aer(05,itype,ai_phase) = p_pcg7_b_o_a05 - lptr_pcg8_b_o_aer(05,itype,ai_phase) = p_pcg8_b_o_a05 - lptr_pcg9_b_o_aer(05,itype,ai_phase) = p_pcg9_b_o_a05 - lptr_opcg1_b_c_aer(05,itype,ai_phase) = p_opcg1_b_c_a05 - lptr_opcg2_b_c_aer(05,itype,ai_phase) = p_opcg2_b_c_a05 - lptr_opcg3_b_c_aer(05,itype,ai_phase) = p_opcg3_b_c_a05 - lptr_opcg4_b_c_aer(05,itype,ai_phase) = p_opcg4_b_c_a05 - lptr_opcg5_b_c_aer(05,itype,ai_phase) = p_opcg5_b_c_a05 - lptr_opcg6_b_c_aer(05,itype,ai_phase) = p_opcg6_b_c_a05 - lptr_opcg7_b_c_aer(05,itype,ai_phase) = p_opcg7_b_c_a05 - lptr_opcg8_b_c_aer(05,itype,ai_phase) = p_opcg8_b_c_a05 - lptr_opcg1_b_o_aer(05,itype,ai_phase) = p_opcg1_b_o_a05 - lptr_opcg2_b_o_aer(05,itype,ai_phase) = p_opcg2_b_o_a05 - lptr_opcg3_b_o_aer(05,itype,ai_phase) = p_opcg3_b_o_a05 - lptr_opcg4_b_o_aer(05,itype,ai_phase) = p_opcg4_b_o_a05 - lptr_opcg5_b_o_aer(05,itype,ai_phase) = p_opcg5_b_o_a05 - lptr_opcg6_b_o_aer(05,itype,ai_phase) = p_opcg6_b_o_a05 - lptr_opcg7_b_o_aer(05,itype,ai_phase) = p_opcg7_b_o_a05 - lptr_opcg8_b_o_aer(05,itype,ai_phase) = p_opcg8_b_o_a05 - lptr_pcg1_f_c_aer(05,itype,ai_phase) = p_pcg1_f_c_a05 - lptr_pcg2_f_c_aer(05,itype,ai_phase) = p_pcg2_f_c_a05 - lptr_pcg3_f_c_aer(05,itype,ai_phase) = p_pcg3_f_c_a05 - lptr_pcg4_f_c_aer(05,itype,ai_phase) = p_pcg4_f_c_a05 - lptr_pcg5_f_c_aer(05,itype,ai_phase) = p_pcg5_f_c_a05 - lptr_pcg6_f_c_aer(05,itype,ai_phase) = p_pcg6_f_c_a05 - lptr_pcg7_f_c_aer(05,itype,ai_phase) = p_pcg7_f_c_a05 - lptr_pcg8_f_c_aer(05,itype,ai_phase) = p_pcg8_f_c_a05 - lptr_pcg9_f_c_aer(05,itype,ai_phase) = p_pcg9_f_c_a05 - lptr_pcg1_f_o_aer(05,itype,ai_phase) = p_pcg1_f_o_a05 - lptr_pcg2_f_o_aer(05,itype,ai_phase) = p_pcg2_f_o_a05 - lptr_pcg3_f_o_aer(05,itype,ai_phase) = p_pcg3_f_o_a05 - lptr_pcg4_f_o_aer(05,itype,ai_phase) = p_pcg4_f_o_a05 - lptr_pcg5_f_o_aer(05,itype,ai_phase) = p_pcg5_f_o_a05 - lptr_pcg6_f_o_aer(05,itype,ai_phase) = p_pcg6_f_o_a05 - lptr_pcg7_f_o_aer(05,itype,ai_phase) = p_pcg7_f_o_a05 - lptr_pcg8_f_o_aer(05,itype,ai_phase) = p_pcg8_f_o_a05 - lptr_pcg9_f_o_aer(05,itype,ai_phase) = p_pcg9_f_o_a05 - lptr_opcg1_f_c_aer(05,itype,ai_phase) = p_opcg1_f_c_a05 - lptr_opcg2_f_c_aer(05,itype,ai_phase) = p_opcg2_f_c_a05 - lptr_opcg3_f_c_aer(05,itype,ai_phase) = p_opcg3_f_c_a05 - lptr_opcg4_f_c_aer(05,itype,ai_phase) = p_opcg4_f_c_a05 - lptr_opcg5_f_c_aer(05,itype,ai_phase) = p_opcg5_f_c_a05 - lptr_opcg6_f_c_aer(05,itype,ai_phase) = p_opcg6_f_c_a05 - lptr_opcg7_f_c_aer(05,itype,ai_phase) = p_opcg7_f_c_a05 - lptr_opcg8_f_c_aer(05,itype,ai_phase) = p_opcg8_f_c_a05 - lptr_opcg1_f_o_aer(05,itype,ai_phase) = p_opcg1_f_o_a05 - lptr_opcg2_f_o_aer(05,itype,ai_phase) = p_opcg2_f_o_a05 - lptr_opcg3_f_o_aer(05,itype,ai_phase) = p_opcg3_f_o_a05 - lptr_opcg4_f_o_aer(05,itype,ai_phase) = p_opcg4_f_o_a05 - lptr_opcg5_f_o_aer(05,itype,ai_phase) = p_opcg5_f_o_a05 - lptr_opcg6_f_o_aer(05,itype,ai_phase) = p_opcg6_f_o_a05 - lptr_opcg7_f_o_aer(05,itype,ai_phase) = p_opcg7_f_o_a05 - lptr_opcg8_f_o_aer(05,itype,ai_phase) = p_opcg8_f_o_a05 - + if (p_pcg1_b_c_a05 .ge. p1st) lptr_pcg1_b_c_aer(05,itype,ai_phase) = p_pcg1_b_c_a05 + if (p_pcg2_b_c_a05 .ge. p1st) lptr_pcg2_b_c_aer(05,itype,ai_phase) = p_pcg2_b_c_a05 + if (p_pcg3_b_c_a05 .ge. p1st) lptr_pcg3_b_c_aer(05,itype,ai_phase) = p_pcg3_b_c_a05 + if (p_pcg4_b_c_a05 .ge. p1st) lptr_pcg4_b_c_aer(05,itype,ai_phase) = p_pcg4_b_c_a05 + if (p_pcg5_b_c_a05 .ge. p1st) lptr_pcg5_b_c_aer(05,itype,ai_phase) = p_pcg5_b_c_a05 + if (p_pcg6_b_c_a05 .ge. p1st) lptr_pcg6_b_c_aer(05,itype,ai_phase) = p_pcg6_b_c_a05 + if (p_pcg7_b_c_a05 .ge. p1st) lptr_pcg7_b_c_aer(05,itype,ai_phase) = p_pcg7_b_c_a05 + if (p_pcg8_b_c_a05 .ge. p1st) lptr_pcg8_b_c_aer(05,itype,ai_phase) = p_pcg8_b_c_a05 + if (p_pcg9_b_c_a05 .ge. p1st) lptr_pcg9_b_c_aer(05,itype,ai_phase) = p_pcg9_b_c_a05 + if (p_pcg1_b_o_a05 .ge. p1st) lptr_pcg1_b_o_aer(05,itype,ai_phase) = p_pcg1_b_o_a05 + if (p_pcg2_b_o_a05 .ge. p1st) lptr_pcg2_b_o_aer(05,itype,ai_phase) = p_pcg2_b_o_a05 + if (p_pcg3_b_o_a05 .ge. p1st) lptr_pcg3_b_o_aer(05,itype,ai_phase) = p_pcg3_b_o_a05 + if (p_pcg4_b_o_a05 .ge. p1st) lptr_pcg4_b_o_aer(05,itype,ai_phase) = p_pcg4_b_o_a05 + if (p_pcg5_b_o_a05 .ge. p1st) lptr_pcg5_b_o_aer(05,itype,ai_phase) = p_pcg5_b_o_a05 + if (p_pcg6_b_o_a05 .ge. p1st) lptr_pcg6_b_o_aer(05,itype,ai_phase) = p_pcg6_b_o_a05 + if (p_pcg7_b_o_a05 .ge. p1st) lptr_pcg7_b_o_aer(05,itype,ai_phase) = p_pcg7_b_o_a05 + if (p_pcg8_b_o_a05 .ge. p1st) lptr_pcg8_b_o_aer(05,itype,ai_phase) = p_pcg8_b_o_a05 + if (p_pcg9_b_o_a05 .ge. p1st) lptr_pcg9_b_o_aer(05,itype,ai_phase) = p_pcg9_b_o_a05 + if (p_opcg1_b_c_a05 .ge. p1st) lptr_opcg1_b_c_aer(05,itype,ai_phase) = p_opcg1_b_c_a05 + if (p_opcg2_b_c_a05 .ge. p1st) lptr_opcg2_b_c_aer(05,itype,ai_phase) = p_opcg2_b_c_a05 + if (p_opcg3_b_c_a05 .ge. p1st) lptr_opcg3_b_c_aer(05,itype,ai_phase) = p_opcg3_b_c_a05 + if (p_opcg4_b_c_a05 .ge. p1st) lptr_opcg4_b_c_aer(05,itype,ai_phase) = p_opcg4_b_c_a05 + if (p_opcg5_b_c_a05 .ge. p1st) lptr_opcg5_b_c_aer(05,itype,ai_phase) = p_opcg5_b_c_a05 + if (p_opcg6_b_c_a05 .ge. p1st) lptr_opcg6_b_c_aer(05,itype,ai_phase) = p_opcg6_b_c_a05 + if (p_opcg7_b_c_a05 .ge. p1st) lptr_opcg7_b_c_aer(05,itype,ai_phase) = p_opcg7_b_c_a05 + if (p_opcg8_b_c_a05 .ge. p1st) lptr_opcg8_b_c_aer(05,itype,ai_phase) = p_opcg8_b_c_a05 + if (p_opcg1_b_o_a05 .ge. p1st) lptr_opcg1_b_o_aer(05,itype,ai_phase) = p_opcg1_b_o_a05 + if (p_opcg2_b_o_a05 .ge. p1st) lptr_opcg2_b_o_aer(05,itype,ai_phase) = p_opcg2_b_o_a05 + if (p_opcg3_b_o_a05 .ge. p1st) lptr_opcg3_b_o_aer(05,itype,ai_phase) = p_opcg3_b_o_a05 + if (p_opcg4_b_o_a05 .ge. p1st) lptr_opcg4_b_o_aer(05,itype,ai_phase) = p_opcg4_b_o_a05 + if (p_opcg5_b_o_a05 .ge. p1st) lptr_opcg5_b_o_aer(05,itype,ai_phase) = p_opcg5_b_o_a05 + if (p_opcg6_b_o_a05 .ge. p1st) lptr_opcg6_b_o_aer(05,itype,ai_phase) = p_opcg6_b_o_a05 + if (p_opcg7_b_o_a05 .ge. p1st) lptr_opcg7_b_o_aer(05,itype,ai_phase) = p_opcg7_b_o_a05 + if (p_opcg8_b_o_a05 .ge. p1st) lptr_opcg8_b_o_aer(05,itype,ai_phase) = p_opcg8_b_o_a05 + if (p_pcg1_f_c_a05 .ge. p1st) lptr_pcg1_f_c_aer(05,itype,ai_phase) = p_pcg1_f_c_a05 + if (p_pcg2_f_c_a05 .ge. p1st) lptr_pcg2_f_c_aer(05,itype,ai_phase) = p_pcg2_f_c_a05 + if (p_pcg3_f_c_a05 .ge. p1st) lptr_pcg3_f_c_aer(05,itype,ai_phase) = p_pcg3_f_c_a05 + if (p_pcg4_f_c_a05 .ge. p1st) lptr_pcg4_f_c_aer(05,itype,ai_phase) = p_pcg4_f_c_a05 + if (p_pcg5_f_c_a05 .ge. p1st) lptr_pcg5_f_c_aer(05,itype,ai_phase) = p_pcg5_f_c_a05 + if (p_pcg6_f_c_a05 .ge. p1st) lptr_pcg6_f_c_aer(05,itype,ai_phase) = p_pcg6_f_c_a05 + if (p_pcg7_f_c_a05 .ge. p1st) lptr_pcg7_f_c_aer(05,itype,ai_phase) = p_pcg7_f_c_a05 + if (p_pcg8_f_c_a05 .ge. p1st) lptr_pcg8_f_c_aer(05,itype,ai_phase) = p_pcg8_f_c_a05 + if (p_pcg9_f_c_a05 .ge. p1st) lptr_pcg9_f_c_aer(05,itype,ai_phase) = p_pcg9_f_c_a05 + if (p_pcg1_f_o_a05 .ge. p1st) lptr_pcg1_f_o_aer(05,itype,ai_phase) = p_pcg1_f_o_a05 + if (p_pcg2_f_o_a05 .ge. p1st) lptr_pcg2_f_o_aer(05,itype,ai_phase) = p_pcg2_f_o_a05 + if (p_pcg3_f_o_a05 .ge. p1st) lptr_pcg3_f_o_aer(05,itype,ai_phase) = p_pcg3_f_o_a05 + if (p_pcg4_f_o_a05 .ge. p1st) lptr_pcg4_f_o_aer(05,itype,ai_phase) = p_pcg4_f_o_a05 + if (p_pcg5_f_o_a05 .ge. p1st) lptr_pcg5_f_o_aer(05,itype,ai_phase) = p_pcg5_f_o_a05 + if (p_pcg6_f_o_a05 .ge. p1st) lptr_pcg6_f_o_aer(05,itype,ai_phase) = p_pcg6_f_o_a05 + if (p_pcg7_f_o_a05 .ge. p1st) lptr_pcg7_f_o_aer(05,itype,ai_phase) = p_pcg7_f_o_a05 + if (p_pcg8_f_o_a05 .ge. p1st) lptr_pcg8_f_o_aer(05,itype,ai_phase) = p_pcg8_f_o_a05 + if (p_pcg9_f_o_a05 .ge. p1st) lptr_pcg9_f_o_aer(05,itype,ai_phase) = p_pcg9_f_o_a05 + if (p_opcg1_f_c_a05 .ge. p1st) lptr_opcg1_f_c_aer(05,itype,ai_phase) = p_opcg1_f_c_a05 + if (p_opcg2_f_c_a05 .ge. p1st) lptr_opcg2_f_c_aer(05,itype,ai_phase) = p_opcg2_f_c_a05 + if (p_opcg3_f_c_a05 .ge. p1st) lptr_opcg3_f_c_aer(05,itype,ai_phase) = p_opcg3_f_c_a05 + if (p_opcg4_f_c_a05 .ge. p1st) lptr_opcg4_f_c_aer(05,itype,ai_phase) = p_opcg4_f_c_a05 + if (p_opcg5_f_c_a05 .ge. p1st) lptr_opcg5_f_c_aer(05,itype,ai_phase) = p_opcg5_f_c_a05 + if (p_opcg6_f_c_a05 .ge. p1st) lptr_opcg6_f_c_aer(05,itype,ai_phase) = p_opcg6_f_c_a05 + if (p_opcg7_f_c_a05 .ge. p1st) lptr_opcg7_f_c_aer(05,itype,ai_phase) = p_opcg7_f_c_a05 + if (p_opcg8_f_c_a05 .ge. p1st) lptr_opcg8_f_c_aer(05,itype,ai_phase) = p_opcg8_f_c_a05 + if (p_opcg1_f_o_a05 .ge. p1st) lptr_opcg1_f_o_aer(05,itype,ai_phase) = p_opcg1_f_o_a05 + if (p_opcg2_f_o_a05 .ge. p1st) lptr_opcg2_f_o_aer(05,itype,ai_phase) = p_opcg2_f_o_a05 + if (p_opcg3_f_o_a05 .ge. p1st) lptr_opcg3_f_o_aer(05,itype,ai_phase) = p_opcg3_f_o_a05 + if (p_opcg4_f_o_a05 .ge. p1st) lptr_opcg4_f_o_aer(05,itype,ai_phase) = p_opcg4_f_o_a05 + if (p_opcg5_f_o_a05 .ge. p1st) lptr_opcg5_f_o_aer(05,itype,ai_phase) = p_opcg5_f_o_a05 + if (p_opcg6_f_o_a05 .ge. p1st) lptr_opcg6_f_o_aer(05,itype,ai_phase) = p_opcg6_f_o_a05 + if (p_opcg7_f_o_a05 .ge. p1st) lptr_opcg7_f_o_aer(05,itype,ai_phase) = p_opcg7_f_o_a05 + if (p_opcg8_f_o_a05 .ge. p1st) lptr_opcg8_f_o_aer(05,itype,ai_phase) = p_opcg8_f_o_a05 + if (p_ant1_c_a05 .ge. p1st) lptr_ant1_c_aer(05,itype,ai_phase) = p_ant1_c_a05 + if (p_ant2_c_a05 .ge. p1st) lptr_ant2_c_aer(05,itype,ai_phase) = p_ant2_c_a05 + if (p_ant3_c_a05 .ge. p1st) lptr_ant3_c_aer(05,itype,ai_phase) = p_ant3_c_a05 + if (p_ant4_c_a05 .ge. p1st) lptr_ant4_c_aer(05,itype,ai_phase) = p_ant4_c_a05 + if (p_biog1_c_a05 .ge. p1st) lptr_biog1_c_aer(05,itype,ai_phase) = p_biog1_c_a05 + if (p_biog2_c_a05 .ge. p1st) lptr_biog2_c_aer(05,itype,ai_phase) = p_biog2_c_a05 + if (p_biog3_c_a05 .ge. p1st) lptr_biog3_c_aer(05,itype,ai_phase) = p_biog3_c_a05 + if (p_biog4_c_a05 .ge. p1st) lptr_biog4_c_aer(05,itype,ai_phase) = p_biog4_c_a05 + if (p_ant1_o_a05 .ge. p1st) lptr_ant1_o_aer(05,itype,ai_phase) = p_ant1_o_a05 + if (p_ant2_o_a05 .ge. p1st) lptr_ant2_o_aer(05,itype,ai_phase) = p_ant2_o_a05 + if (p_ant3_o_a05 .ge. p1st) lptr_ant3_o_aer(05,itype,ai_phase) = p_ant3_o_a05 + if (p_ant4_o_a05 .ge. p1st) lptr_ant4_o_aer(05,itype,ai_phase) = p_ant4_o_a05 + if (p_biog1_o_a05 .ge. p1st) lptr_biog1_o_aer(05,itype,ai_phase) = p_biog1_o_a05 + if (p_biog2_o_a05 .ge. p1st) lptr_biog2_o_aer(05,itype,ai_phase) = p_biog2_o_a05 + if (p_biog3_o_a05 .ge. p1st) lptr_biog3_o_aer(05,itype,ai_phase) = p_biog3_o_a05 + if (p_biog4_o_a05 .ge. p1st) lptr_biog4_o_aer(05,itype,ai_phase) = p_biog4_o_a05 numptr_aer(05,itype,ai_phase) = p_num_a05 end if @@ -5837,76 +7769,91 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_bc_aer(06,itype,ai_phase) = p_bc_a06 hyswptr_aer(06,itype) = p_hysw_a06 waterptr_aer(06,itype) = p_water_a06 - lptr_pcg1_b_c_aer(06,itype,ai_phase) = p_pcg1_b_c_a06 - lptr_pcg2_b_c_aer(06,itype,ai_phase) = p_pcg2_b_c_a06 - lptr_pcg3_b_c_aer(06,itype,ai_phase) = p_pcg3_b_c_a06 - lptr_pcg4_b_c_aer(06,itype,ai_phase) = p_pcg4_b_c_a06 - lptr_pcg5_b_c_aer(06,itype,ai_phase) = p_pcg5_b_c_a06 - lptr_pcg6_b_c_aer(06,itype,ai_phase) = p_pcg6_b_c_a06 - lptr_pcg7_b_c_aer(06,itype,ai_phase) = p_pcg7_b_c_a06 - lptr_pcg8_b_c_aer(06,itype,ai_phase) = p_pcg8_b_c_a06 - lptr_pcg9_b_c_aer(06,itype,ai_phase) = p_pcg9_b_c_a06 - lptr_pcg1_b_o_aer(06,itype,ai_phase) = p_pcg1_b_o_a06 - lptr_pcg2_b_o_aer(06,itype,ai_phase) = p_pcg2_b_o_a06 - lptr_pcg3_b_o_aer(06,itype,ai_phase) = p_pcg3_b_o_a06 - lptr_pcg4_b_o_aer(06,itype,ai_phase) = p_pcg4_b_o_a06 - lptr_pcg5_b_o_aer(06,itype,ai_phase) = p_pcg5_b_o_a06 - lptr_pcg6_b_o_aer(06,itype,ai_phase) = p_pcg6_b_o_a06 - lptr_pcg7_b_o_aer(06,itype,ai_phase) = p_pcg7_b_o_a06 - lptr_pcg8_b_o_aer(06,itype,ai_phase) = p_pcg8_b_o_a06 - lptr_pcg9_b_o_aer(06,itype,ai_phase) = p_pcg9_b_o_a06 - lptr_opcg1_b_c_aer(06,itype,ai_phase) = p_opcg1_b_c_a06 - lptr_opcg2_b_c_aer(06,itype,ai_phase) = p_opcg2_b_c_a06 - lptr_opcg3_b_c_aer(06,itype,ai_phase) = p_opcg3_b_c_a06 - lptr_opcg4_b_c_aer(06,itype,ai_phase) = p_opcg4_b_c_a06 - lptr_opcg5_b_c_aer(06,itype,ai_phase) = p_opcg5_b_c_a06 - lptr_opcg6_b_c_aer(06,itype,ai_phase) = p_opcg6_b_c_a06 - lptr_opcg7_b_c_aer(06,itype,ai_phase) = p_opcg7_b_c_a06 - lptr_opcg8_b_c_aer(06,itype,ai_phase) = p_opcg8_b_c_a06 - lptr_opcg1_b_o_aer(06,itype,ai_phase) = p_opcg1_b_o_a06 - lptr_opcg2_b_o_aer(06,itype,ai_phase) = p_opcg2_b_o_a06 - lptr_opcg3_b_o_aer(06,itype,ai_phase) = p_opcg3_b_o_a06 - lptr_opcg4_b_o_aer(06,itype,ai_phase) = p_opcg4_b_o_a06 - lptr_opcg5_b_o_aer(06,itype,ai_phase) = p_opcg5_b_o_a06 - lptr_opcg6_b_o_aer(06,itype,ai_phase) = p_opcg6_b_o_a06 - lptr_opcg7_b_o_aer(06,itype,ai_phase) = p_opcg7_b_o_a06 - lptr_opcg8_b_o_aer(06,itype,ai_phase) = p_opcg8_b_o_a06 - lptr_pcg1_f_c_aer(06,itype,ai_phase) = p_pcg1_f_c_a06 - lptr_pcg2_f_c_aer(06,itype,ai_phase) = p_pcg2_f_c_a06 - lptr_pcg3_f_c_aer(06,itype,ai_phase) = p_pcg3_f_c_a06 - lptr_pcg4_f_c_aer(06,itype,ai_phase) = p_pcg4_f_c_a06 - lptr_pcg5_f_c_aer(06,itype,ai_phase) = p_pcg5_f_c_a06 - lptr_pcg6_f_c_aer(06,itype,ai_phase) = p_pcg6_f_c_a06 - lptr_pcg7_f_c_aer(06,itype,ai_phase) = p_pcg7_f_c_a06 - lptr_pcg8_f_c_aer(06,itype,ai_phase) = p_pcg8_f_c_a06 - lptr_pcg9_f_c_aer(06,itype,ai_phase) = p_pcg9_f_c_a06 - lptr_pcg1_f_o_aer(06,itype,ai_phase) = p_pcg1_f_o_a06 - lptr_pcg2_f_o_aer(06,itype,ai_phase) = p_pcg2_f_o_a06 - lptr_pcg3_f_o_aer(06,itype,ai_phase) = p_pcg3_f_o_a06 - lptr_pcg4_f_o_aer(06,itype,ai_phase) = p_pcg4_f_o_a06 - lptr_pcg5_f_o_aer(06,itype,ai_phase) = p_pcg5_f_o_a06 - lptr_pcg6_f_o_aer(06,itype,ai_phase) = p_pcg6_f_o_a06 - lptr_pcg7_f_o_aer(06,itype,ai_phase) = p_pcg7_f_o_a06 - lptr_pcg8_f_o_aer(06,itype,ai_phase) = p_pcg8_f_o_a06 - lptr_pcg9_f_o_aer(06,itype,ai_phase) = p_pcg9_f_o_a06 - lptr_opcg1_f_c_aer(06,itype,ai_phase) = p_opcg1_f_c_a06 - lptr_opcg2_f_c_aer(06,itype,ai_phase) = p_opcg2_f_c_a06 - lptr_opcg3_f_c_aer(06,itype,ai_phase) = p_opcg3_f_c_a06 - lptr_opcg4_f_c_aer(06,itype,ai_phase) = p_opcg4_f_c_a06 - lptr_opcg5_f_c_aer(06,itype,ai_phase) = p_opcg5_f_c_a06 - lptr_opcg6_f_c_aer(06,itype,ai_phase) = p_opcg6_f_c_a06 - lptr_opcg7_f_c_aer(06,itype,ai_phase) = p_opcg7_f_c_a06 - lptr_opcg8_f_c_aer(06,itype,ai_phase) = p_opcg8_f_c_a06 - lptr_opcg1_f_o_aer(06,itype,ai_phase) = p_opcg1_f_o_a06 - lptr_opcg2_f_o_aer(06,itype,ai_phase) = p_opcg2_f_o_a06 - lptr_opcg3_f_o_aer(06,itype,ai_phase) = p_opcg3_f_o_a06 - lptr_opcg4_f_o_aer(06,itype,ai_phase) = p_opcg4_f_o_a06 - lptr_opcg5_f_o_aer(06,itype,ai_phase) = p_opcg5_f_o_a06 - lptr_opcg6_f_o_aer(06,itype,ai_phase) = p_opcg6_f_o_a06 - lptr_opcg7_f_o_aer(06,itype,ai_phase) = p_opcg7_f_o_a06 - lptr_opcg8_f_o_aer(06,itype,ai_phase) = p_opcg8_f_o_a06 - + if (p_pcg1_b_c_a06 .ge. p1st) lptr_pcg1_b_c_aer(06,itype,ai_phase) = p_pcg1_b_c_a06 + if (p_pcg2_b_c_a06 .ge. p1st) lptr_pcg2_b_c_aer(06,itype,ai_phase) = p_pcg2_b_c_a06 + if (p_pcg3_b_c_a06 .ge. p1st) lptr_pcg3_b_c_aer(06,itype,ai_phase) = p_pcg3_b_c_a06 + if (p_pcg4_b_c_a06 .ge. p1st) lptr_pcg4_b_c_aer(06,itype,ai_phase) = p_pcg4_b_c_a06 + if (p_pcg5_b_c_a06 .ge. p1st) lptr_pcg5_b_c_aer(06,itype,ai_phase) = p_pcg5_b_c_a06 + if (p_pcg6_b_c_a06 .ge. p1st) lptr_pcg6_b_c_aer(06,itype,ai_phase) = p_pcg6_b_c_a06 + if (p_pcg7_b_c_a06 .ge. p1st) lptr_pcg7_b_c_aer(06,itype,ai_phase) = p_pcg7_b_c_a06 + if (p_pcg8_b_c_a06 .ge. p1st) lptr_pcg8_b_c_aer(06,itype,ai_phase) = p_pcg8_b_c_a06 + if (p_pcg9_b_c_a06 .ge. p1st) lptr_pcg9_b_c_aer(06,itype,ai_phase) = p_pcg9_b_c_a06 + if (p_pcg1_b_o_a06 .ge. p1st) lptr_pcg1_b_o_aer(06,itype,ai_phase) = p_pcg1_b_o_a06 + if (p_pcg2_b_o_a06 .ge. p1st) lptr_pcg2_b_o_aer(06,itype,ai_phase) = p_pcg2_b_o_a06 + if (p_pcg3_b_o_a06 .ge. p1st) lptr_pcg3_b_o_aer(06,itype,ai_phase) = p_pcg3_b_o_a06 + if (p_pcg4_b_o_a06 .ge. p1st) lptr_pcg4_b_o_aer(06,itype,ai_phase) = p_pcg4_b_o_a06 + if (p_pcg5_b_o_a06 .ge. p1st) lptr_pcg5_b_o_aer(06,itype,ai_phase) = p_pcg5_b_o_a06 + if (p_pcg6_b_o_a06 .ge. p1st) lptr_pcg6_b_o_aer(06,itype,ai_phase) = p_pcg6_b_o_a06 + if (p_pcg7_b_o_a06 .ge. p1st) lptr_pcg7_b_o_aer(06,itype,ai_phase) = p_pcg7_b_o_a06 + if (p_pcg8_b_o_a06 .ge. p1st) lptr_pcg8_b_o_aer(06,itype,ai_phase) = p_pcg8_b_o_a06 + if (p_pcg9_b_o_a06 .ge. p1st) lptr_pcg9_b_o_aer(06,itype,ai_phase) = p_pcg9_b_o_a06 + if (p_opcg1_b_c_a06 .ge. p1st) lptr_opcg1_b_c_aer(06,itype,ai_phase) = p_opcg1_b_c_a06 + if (p_opcg2_b_c_a06 .ge. p1st) lptr_opcg2_b_c_aer(06,itype,ai_phase) = p_opcg2_b_c_a06 + if (p_opcg3_b_c_a06 .ge. p1st) lptr_opcg3_b_c_aer(06,itype,ai_phase) = p_opcg3_b_c_a06 + if (p_opcg4_b_c_a06 .ge. p1st) lptr_opcg4_b_c_aer(06,itype,ai_phase) = p_opcg4_b_c_a06 + if (p_opcg5_b_c_a06 .ge. p1st) lptr_opcg5_b_c_aer(06,itype,ai_phase) = p_opcg5_b_c_a06 + if (p_opcg6_b_c_a06 .ge. p1st) lptr_opcg6_b_c_aer(06,itype,ai_phase) = p_opcg6_b_c_a06 + if (p_opcg7_b_c_a06 .ge. p1st) lptr_opcg7_b_c_aer(06,itype,ai_phase) = p_opcg7_b_c_a06 + if (p_opcg8_b_c_a06 .ge. p1st) lptr_opcg8_b_c_aer(06,itype,ai_phase) = p_opcg8_b_c_a06 + if (p_opcg1_b_o_a06 .ge. p1st) lptr_opcg1_b_o_aer(06,itype,ai_phase) = p_opcg1_b_o_a06 + if (p_opcg2_b_o_a06 .ge. p1st) lptr_opcg2_b_o_aer(06,itype,ai_phase) = p_opcg2_b_o_a06 + if (p_opcg3_b_o_a06 .ge. p1st) lptr_opcg3_b_o_aer(06,itype,ai_phase) = p_opcg3_b_o_a06 + if (p_opcg4_b_o_a06 .ge. p1st) lptr_opcg4_b_o_aer(06,itype,ai_phase) = p_opcg4_b_o_a06 + if (p_opcg5_b_o_a06 .ge. p1st) lptr_opcg5_b_o_aer(06,itype,ai_phase) = p_opcg5_b_o_a06 + if (p_opcg6_b_o_a06 .ge. p1st) lptr_opcg6_b_o_aer(06,itype,ai_phase) = p_opcg6_b_o_a06 + if (p_opcg7_b_o_a06 .ge. p1st) lptr_opcg7_b_o_aer(06,itype,ai_phase) = p_opcg7_b_o_a06 + if (p_opcg8_b_o_a06 .ge. p1st) lptr_opcg8_b_o_aer(06,itype,ai_phase) = p_opcg8_b_o_a06 + if (p_pcg1_f_c_a06 .ge. p1st) lptr_pcg1_f_c_aer(06,itype,ai_phase) = p_pcg1_f_c_a06 + if (p_pcg2_f_c_a06 .ge. p1st) lptr_pcg2_f_c_aer(06,itype,ai_phase) = p_pcg2_f_c_a06 + if (p_pcg3_f_c_a06 .ge. p1st) lptr_pcg3_f_c_aer(06,itype,ai_phase) = p_pcg3_f_c_a06 + if (p_pcg4_f_c_a06 .ge. p1st) lptr_pcg4_f_c_aer(06,itype,ai_phase) = p_pcg4_f_c_a06 + if (p_pcg5_f_c_a06 .ge. p1st) lptr_pcg5_f_c_aer(06,itype,ai_phase) = p_pcg5_f_c_a06 + if (p_pcg6_f_c_a06 .ge. p1st) lptr_pcg6_f_c_aer(06,itype,ai_phase) = p_pcg6_f_c_a06 + if (p_pcg7_f_c_a06 .ge. p1st) lptr_pcg7_f_c_aer(06,itype,ai_phase) = p_pcg7_f_c_a06 + if (p_pcg8_f_c_a06 .ge. p1st) lptr_pcg8_f_c_aer(06,itype,ai_phase) = p_pcg8_f_c_a06 + if (p_pcg9_f_c_a06 .ge. p1st) lptr_pcg9_f_c_aer(06,itype,ai_phase) = p_pcg9_f_c_a06 + if (p_pcg1_f_o_a06 .ge. p1st) lptr_pcg1_f_o_aer(06,itype,ai_phase) = p_pcg1_f_o_a06 + if (p_pcg2_f_o_a06 .ge. p1st) lptr_pcg2_f_o_aer(06,itype,ai_phase) = p_pcg2_f_o_a06 + if (p_pcg3_f_o_a06 .ge. p1st) lptr_pcg3_f_o_aer(06,itype,ai_phase) = p_pcg3_f_o_a06 + if (p_pcg4_f_o_a06 .ge. p1st) lptr_pcg4_f_o_aer(06,itype,ai_phase) = p_pcg4_f_o_a06 + if (p_pcg5_f_o_a06 .ge. p1st) lptr_pcg5_f_o_aer(06,itype,ai_phase) = p_pcg5_f_o_a06 + if (p_pcg6_f_o_a06 .ge. p1st) lptr_pcg6_f_o_aer(06,itype,ai_phase) = p_pcg6_f_o_a06 + if (p_pcg7_f_o_a06 .ge. p1st) lptr_pcg7_f_o_aer(06,itype,ai_phase) = p_pcg7_f_o_a06 + if (p_pcg8_f_o_a06 .ge. p1st) lptr_pcg8_f_o_aer(06,itype,ai_phase) = p_pcg8_f_o_a06 + if (p_pcg9_f_o_a06 .ge. p1st) lptr_pcg9_f_o_aer(06,itype,ai_phase) = p_pcg9_f_o_a06 + if (p_opcg1_f_c_a06 .ge. p1st) lptr_opcg1_f_c_aer(06,itype,ai_phase) = p_opcg1_f_c_a06 + if (p_opcg2_f_c_a06 .ge. p1st) lptr_opcg2_f_c_aer(06,itype,ai_phase) = p_opcg2_f_c_a06 + if (p_opcg3_f_c_a06 .ge. p1st) lptr_opcg3_f_c_aer(06,itype,ai_phase) = p_opcg3_f_c_a06 + if (p_opcg4_f_c_a06 .ge. p1st) lptr_opcg4_f_c_aer(06,itype,ai_phase) = p_opcg4_f_c_a06 + if (p_opcg5_f_c_a06 .ge. p1st) lptr_opcg5_f_c_aer(06,itype,ai_phase) = p_opcg5_f_c_a06 + if (p_opcg6_f_c_a06 .ge. p1st) lptr_opcg6_f_c_aer(06,itype,ai_phase) = p_opcg6_f_c_a06 + if (p_opcg7_f_c_a06 .ge. p1st) lptr_opcg7_f_c_aer(06,itype,ai_phase) = p_opcg7_f_c_a06 + if (p_opcg8_f_c_a06 .ge. p1st) lptr_opcg8_f_c_aer(06,itype,ai_phase) = p_opcg8_f_c_a06 + if (p_opcg1_f_o_a06 .ge. p1st) lptr_opcg1_f_o_aer(06,itype,ai_phase) = p_opcg1_f_o_a06 + if (p_opcg2_f_o_a06 .ge. p1st) lptr_opcg2_f_o_aer(06,itype,ai_phase) = p_opcg2_f_o_a06 + if (p_opcg3_f_o_a06 .ge. p1st) lptr_opcg3_f_o_aer(06,itype,ai_phase) = p_opcg3_f_o_a06 + if (p_opcg4_f_o_a06 .ge. p1st) lptr_opcg4_f_o_aer(06,itype,ai_phase) = p_opcg4_f_o_a06 + if (p_opcg5_f_o_a06 .ge. p1st) lptr_opcg5_f_o_aer(06,itype,ai_phase) = p_opcg5_f_o_a06 + if (p_opcg6_f_o_a06 .ge. p1st) lptr_opcg6_f_o_aer(06,itype,ai_phase) = p_opcg6_f_o_a06 + if (p_opcg7_f_o_a06 .ge. p1st) lptr_opcg7_f_o_aer(06,itype,ai_phase) = p_opcg7_f_o_a06 + if (p_opcg8_f_o_a06 .ge. p1st) lptr_opcg8_f_o_aer(06,itype,ai_phase) = p_opcg8_f_o_a06 + if (p_ant1_c_a06 .ge. p1st) lptr_ant1_c_aer(06,itype,ai_phase) = p_ant1_c_a06 + if (p_ant2_c_a06 .ge. p1st) lptr_ant2_c_aer(06,itype,ai_phase) = p_ant2_c_a06 + if (p_ant3_c_a06 .ge. p1st) lptr_ant3_c_aer(06,itype,ai_phase) = p_ant3_c_a06 + if (p_ant4_c_a06 .ge. p1st) lptr_ant4_c_aer(06,itype,ai_phase) = p_ant4_c_a06 + if (p_biog1_c_a06 .ge. p1st) lptr_biog1_c_aer(06,itype,ai_phase) = p_biog1_c_a06 + if (p_biog2_c_a06 .ge. p1st) lptr_biog2_c_aer(06,itype,ai_phase) = p_biog2_c_a06 + if (p_biog3_c_a06 .ge. p1st) lptr_biog3_c_aer(06,itype,ai_phase) = p_biog3_c_a06 + if (p_biog4_c_a06 .ge. p1st) lptr_biog4_c_aer(06,itype,ai_phase) = p_biog4_c_a06 + if (p_ant1_o_a06 .ge. p1st) lptr_ant1_o_aer(06,itype,ai_phase) = p_ant1_o_a06 + if (p_ant2_o_a06 .ge. p1st) lptr_ant2_o_aer(06,itype,ai_phase) = p_ant2_o_a06 + if (p_ant3_o_a06 .ge. p1st) lptr_ant3_o_aer(06,itype,ai_phase) = p_ant3_o_a06 + if (p_ant4_o_a06 .ge. p1st) lptr_ant4_o_aer(06,itype,ai_phase) = p_ant4_o_a06 + if (p_biog1_o_a06 .ge. p1st) lptr_biog1_o_aer(06,itype,ai_phase) = p_biog1_o_a06 + if (p_biog2_o_a06 .ge. p1st) lptr_biog2_o_aer(06,itype,ai_phase) = p_biog2_o_a06 + if (p_biog3_o_a06 .ge. p1st) lptr_biog3_o_aer(06,itype,ai_phase) = p_biog3_o_a06 + if (p_biog4_o_a06 .ge. p1st) lptr_biog4_o_aer(06,itype,ai_phase) = p_biog4_o_a06 numptr_aer(06,itype,ai_phase) = p_num_a06 end if @@ -5925,79 +7872,94 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_bc_aer(07,itype,ai_phase) = p_bc_a07 hyswptr_aer(07,itype) = p_hysw_a07 waterptr_aer(07,itype) = p_water_a07 - lptr_pcg1_b_c_aer(07,itype,ai_phase) = p_pcg1_b_c_a07 - lptr_pcg2_b_c_aer(07,itype,ai_phase) = p_pcg2_b_c_a07 - lptr_pcg3_b_c_aer(07,itype,ai_phase) = p_pcg3_b_c_a07 - lptr_pcg4_b_c_aer(07,itype,ai_phase) = p_pcg4_b_c_a07 - lptr_pcg5_b_c_aer(07,itype,ai_phase) = p_pcg5_b_c_a07 - lptr_pcg6_b_c_aer(07,itype,ai_phase) = p_pcg6_b_c_a07 - lptr_pcg7_b_c_aer(07,itype,ai_phase) = p_pcg7_b_c_a07 - lptr_pcg8_b_c_aer(07,itype,ai_phase) = p_pcg8_b_c_a07 - lptr_pcg9_b_c_aer(07,itype,ai_phase) = p_pcg9_b_c_a07 - lptr_pcg1_b_o_aer(07,itype,ai_phase) = p_pcg1_b_o_a07 - lptr_pcg2_b_o_aer(07,itype,ai_phase) = p_pcg2_b_o_a07 - lptr_pcg3_b_o_aer(07,itype,ai_phase) = p_pcg3_b_o_a07 - lptr_pcg4_b_o_aer(07,itype,ai_phase) = p_pcg4_b_o_a07 - lptr_pcg5_b_o_aer(07,itype,ai_phase) = p_pcg5_b_o_a07 - lptr_pcg6_b_o_aer(07,itype,ai_phase) = p_pcg6_b_o_a07 - lptr_pcg7_b_o_aer(07,itype,ai_phase) = p_pcg7_b_o_a07 - lptr_pcg8_b_o_aer(07,itype,ai_phase) = p_pcg8_b_o_a07 - lptr_pcg9_b_o_aer(07,itype,ai_phase) = p_pcg9_b_o_a07 - lptr_opcg1_b_c_aer(07,itype,ai_phase) = p_opcg1_b_c_a07 - lptr_opcg2_b_c_aer(07,itype,ai_phase) = p_opcg2_b_c_a07 - lptr_opcg3_b_c_aer(07,itype,ai_phase) = p_opcg3_b_c_a07 - lptr_opcg4_b_c_aer(07,itype,ai_phase) = p_opcg4_b_c_a07 - lptr_opcg5_b_c_aer(07,itype,ai_phase) = p_opcg5_b_c_a07 - lptr_opcg6_b_c_aer(07,itype,ai_phase) = p_opcg6_b_c_a07 - lptr_opcg7_b_c_aer(07,itype,ai_phase) = p_opcg7_b_c_a07 - lptr_opcg8_b_c_aer(07,itype,ai_phase) = p_opcg8_b_c_a07 - lptr_opcg1_b_o_aer(07,itype,ai_phase) = p_opcg1_b_o_a07 - lptr_opcg2_b_o_aer(07,itype,ai_phase) = p_opcg2_b_o_a07 - lptr_opcg3_b_o_aer(07,itype,ai_phase) = p_opcg3_b_o_a07 - lptr_opcg4_b_o_aer(07,itype,ai_phase) = p_opcg4_b_o_a07 - lptr_opcg5_b_o_aer(07,itype,ai_phase) = p_opcg5_b_o_a07 - lptr_opcg6_b_o_aer(07,itype,ai_phase) = p_opcg6_b_o_a07 - lptr_opcg7_b_o_aer(07,itype,ai_phase) = p_opcg7_b_o_a07 - lptr_opcg8_b_o_aer(07,itype,ai_phase) = p_opcg8_b_o_a07 - lptr_pcg1_f_c_aer(07,itype,ai_phase) = p_pcg1_f_c_a07 - lptr_pcg2_f_c_aer(07,itype,ai_phase) = p_pcg2_f_c_a07 - lptr_pcg3_f_c_aer(07,itype,ai_phase) = p_pcg3_f_c_a07 - lptr_pcg4_f_c_aer(07,itype,ai_phase) = p_pcg4_f_c_a07 - lptr_pcg5_f_c_aer(07,itype,ai_phase) = p_pcg5_f_c_a07 - lptr_pcg6_f_c_aer(07,itype,ai_phase) = p_pcg6_f_c_a07 - lptr_pcg7_f_c_aer(07,itype,ai_phase) = p_pcg7_f_c_a07 - lptr_pcg8_f_c_aer(07,itype,ai_phase) = p_pcg8_f_c_a07 - lptr_pcg9_f_c_aer(07,itype,ai_phase) = p_pcg9_f_c_a07 - lptr_pcg1_f_o_aer(07,itype,ai_phase) = p_pcg1_f_o_a07 - lptr_pcg2_f_o_aer(07,itype,ai_phase) = p_pcg2_f_o_a07 - lptr_pcg3_f_o_aer(07,itype,ai_phase) = p_pcg3_f_o_a07 - lptr_pcg4_f_o_aer(07,itype,ai_phase) = p_pcg4_f_o_a07 - lptr_pcg5_f_o_aer(07,itype,ai_phase) = p_pcg5_f_o_a07 - lptr_pcg6_f_o_aer(07,itype,ai_phase) = p_pcg6_f_o_a07 - lptr_pcg7_f_o_aer(07,itype,ai_phase) = p_pcg7_f_o_a07 - lptr_pcg8_f_o_aer(07,itype,ai_phase) = p_pcg8_f_o_a07 - lptr_pcg9_f_o_aer(07,itype,ai_phase) = p_pcg9_f_o_a07 - lptr_opcg1_f_c_aer(07,itype,ai_phase) = p_opcg1_f_c_a07 - lptr_opcg2_f_c_aer(07,itype,ai_phase) = p_opcg2_f_c_a07 - lptr_opcg3_f_c_aer(07,itype,ai_phase) = p_opcg3_f_c_a07 - lptr_opcg4_f_c_aer(07,itype,ai_phase) = p_opcg4_f_c_a07 - lptr_opcg5_f_c_aer(07,itype,ai_phase) = p_opcg5_f_c_a07 - lptr_opcg6_f_c_aer(07,itype,ai_phase) = p_opcg6_f_c_a07 - lptr_opcg7_f_c_aer(07,itype,ai_phase) = p_opcg7_f_c_a07 - lptr_opcg8_f_c_aer(07,itype,ai_phase) = p_opcg8_f_c_a07 - lptr_opcg1_f_o_aer(07,itype,ai_phase) = p_opcg1_f_o_a07 - lptr_opcg2_f_o_aer(07,itype,ai_phase) = p_opcg2_f_o_a07 - lptr_opcg3_f_o_aer(07,itype,ai_phase) = p_opcg3_f_o_a07 - lptr_opcg4_f_o_aer(07,itype,ai_phase) = p_opcg4_f_o_a07 - lptr_opcg5_f_o_aer(07,itype,ai_phase) = p_opcg5_f_o_a07 - lptr_opcg6_f_o_aer(07,itype,ai_phase) = p_opcg6_f_o_a07 - lptr_opcg7_f_o_aer(07,itype,ai_phase) = p_opcg7_f_o_a07 - lptr_opcg8_f_o_aer(07,itype,ai_phase) = p_opcg8_f_o_a07 - + if (p_pcg1_b_c_a07 .ge. p1st) lptr_pcg1_b_c_aer(07,itype,ai_phase) = p_pcg1_b_c_a07 + if (p_pcg2_b_c_a07 .ge. p1st) lptr_pcg2_b_c_aer(07,itype,ai_phase) = p_pcg2_b_c_a07 + if (p_pcg3_b_c_a07 .ge. p1st) lptr_pcg3_b_c_aer(07,itype,ai_phase) = p_pcg3_b_c_a07 + if (p_pcg4_b_c_a07 .ge. p1st) lptr_pcg4_b_c_aer(07,itype,ai_phase) = p_pcg4_b_c_a07 + if (p_pcg5_b_c_a07 .ge. p1st) lptr_pcg5_b_c_aer(07,itype,ai_phase) = p_pcg5_b_c_a07 + if (p_pcg6_b_c_a07 .ge. p1st) lptr_pcg6_b_c_aer(07,itype,ai_phase) = p_pcg6_b_c_a07 + if (p_pcg7_b_c_a07 .ge. p1st) lptr_pcg7_b_c_aer(07,itype,ai_phase) = p_pcg7_b_c_a07 + if (p_pcg8_b_c_a07 .ge. p1st) lptr_pcg8_b_c_aer(07,itype,ai_phase) = p_pcg8_b_c_a07 + if (p_pcg9_b_c_a07 .ge. p1st) lptr_pcg9_b_c_aer(07,itype,ai_phase) = p_pcg9_b_c_a07 + if (p_pcg1_b_o_a07 .ge. p1st) lptr_pcg1_b_o_aer(07,itype,ai_phase) = p_pcg1_b_o_a07 + if (p_pcg2_b_o_a07 .ge. p1st) lptr_pcg2_b_o_aer(07,itype,ai_phase) = p_pcg2_b_o_a07 + if (p_pcg3_b_o_a07 .ge. p1st) lptr_pcg3_b_o_aer(07,itype,ai_phase) = p_pcg3_b_o_a07 + if (p_pcg4_b_o_a07 .ge. p1st) lptr_pcg4_b_o_aer(07,itype,ai_phase) = p_pcg4_b_o_a07 + if (p_pcg5_b_o_a07 .ge. p1st) lptr_pcg5_b_o_aer(07,itype,ai_phase) = p_pcg5_b_o_a07 + if (p_pcg6_b_o_a07 .ge. p1st) lptr_pcg6_b_o_aer(07,itype,ai_phase) = p_pcg6_b_o_a07 + if (p_pcg7_b_o_a07 .ge. p1st) lptr_pcg7_b_o_aer(07,itype,ai_phase) = p_pcg7_b_o_a07 + if (p_pcg8_b_o_a07 .ge. p1st) lptr_pcg8_b_o_aer(07,itype,ai_phase) = p_pcg8_b_o_a07 + if (p_pcg9_b_o_a07 .ge. p1st) lptr_pcg9_b_o_aer(07,itype,ai_phase) = p_pcg9_b_o_a07 + if (p_opcg1_b_c_a07 .ge. p1st) lptr_opcg1_b_c_aer(07,itype,ai_phase) = p_opcg1_b_c_a07 + if (p_opcg2_b_c_a07 .ge. p1st) lptr_opcg2_b_c_aer(07,itype,ai_phase) = p_opcg2_b_c_a07 + if (p_opcg3_b_c_a07 .ge. p1st) lptr_opcg3_b_c_aer(07,itype,ai_phase) = p_opcg3_b_c_a07 + if (p_opcg4_b_c_a07 .ge. p1st) lptr_opcg4_b_c_aer(07,itype,ai_phase) = p_opcg4_b_c_a07 + if (p_opcg5_b_c_a07 .ge. p1st) lptr_opcg5_b_c_aer(07,itype,ai_phase) = p_opcg5_b_c_a07 + if (p_opcg6_b_c_a07 .ge. p1st) lptr_opcg6_b_c_aer(07,itype,ai_phase) = p_opcg6_b_c_a07 + if (p_opcg7_b_c_a07 .ge. p1st) lptr_opcg7_b_c_aer(07,itype,ai_phase) = p_opcg7_b_c_a07 + if (p_opcg8_b_c_a07 .ge. p1st) lptr_opcg8_b_c_aer(07,itype,ai_phase) = p_opcg8_b_c_a07 + if (p_opcg1_b_o_a07 .ge. p1st) lptr_opcg1_b_o_aer(07,itype,ai_phase) = p_opcg1_b_o_a07 + if (p_opcg2_b_o_a07 .ge. p1st) lptr_opcg2_b_o_aer(07,itype,ai_phase) = p_opcg2_b_o_a07 + if (p_opcg3_b_o_a07 .ge. p1st) lptr_opcg3_b_o_aer(07,itype,ai_phase) = p_opcg3_b_o_a07 + if (p_opcg4_b_o_a07 .ge. p1st) lptr_opcg4_b_o_aer(07,itype,ai_phase) = p_opcg4_b_o_a07 + if (p_opcg5_b_o_a07 .ge. p1st) lptr_opcg5_b_o_aer(07,itype,ai_phase) = p_opcg5_b_o_a07 + if (p_opcg6_b_o_a07 .ge. p1st) lptr_opcg6_b_o_aer(07,itype,ai_phase) = p_opcg6_b_o_a07 + if (p_opcg7_b_o_a07 .ge. p1st) lptr_opcg7_b_o_aer(07,itype,ai_phase) = p_opcg7_b_o_a07 + if (p_opcg8_b_o_a07 .ge. p1st) lptr_opcg8_b_o_aer(07,itype,ai_phase) = p_opcg8_b_o_a07 + if (p_pcg1_f_c_a07 .ge. p1st) lptr_pcg1_f_c_aer(07,itype,ai_phase) = p_pcg1_f_c_a07 + if (p_pcg2_f_c_a07 .ge. p1st) lptr_pcg2_f_c_aer(07,itype,ai_phase) = p_pcg2_f_c_a07 + if (p_pcg3_f_c_a07 .ge. p1st) lptr_pcg3_f_c_aer(07,itype,ai_phase) = p_pcg3_f_c_a07 + if (p_pcg4_f_c_a07 .ge. p1st) lptr_pcg4_f_c_aer(07,itype,ai_phase) = p_pcg4_f_c_a07 + if (p_pcg5_f_c_a07 .ge. p1st) lptr_pcg5_f_c_aer(07,itype,ai_phase) = p_pcg5_f_c_a07 + if (p_pcg6_f_c_a07 .ge. p1st) lptr_pcg6_f_c_aer(07,itype,ai_phase) = p_pcg6_f_c_a07 + if (p_pcg7_f_c_a07 .ge. p1st) lptr_pcg7_f_c_aer(07,itype,ai_phase) = p_pcg7_f_c_a07 + if (p_pcg8_f_c_a07 .ge. p1st) lptr_pcg8_f_c_aer(07,itype,ai_phase) = p_pcg8_f_c_a07 + if (p_pcg9_f_c_a07 .ge. p1st) lptr_pcg9_f_c_aer(07,itype,ai_phase) = p_pcg9_f_c_a07 + if (p_pcg1_f_o_a07 .ge. p1st) lptr_pcg1_f_o_aer(07,itype,ai_phase) = p_pcg1_f_o_a07 + if (p_pcg2_f_o_a07 .ge. p1st) lptr_pcg2_f_o_aer(07,itype,ai_phase) = p_pcg2_f_o_a07 + if (p_pcg3_f_o_a07 .ge. p1st) lptr_pcg3_f_o_aer(07,itype,ai_phase) = p_pcg3_f_o_a07 + if (p_pcg4_f_o_a07 .ge. p1st) lptr_pcg4_f_o_aer(07,itype,ai_phase) = p_pcg4_f_o_a07 + if (p_pcg5_f_o_a07 .ge. p1st) lptr_pcg5_f_o_aer(07,itype,ai_phase) = p_pcg5_f_o_a07 + if (p_pcg6_f_o_a07 .ge. p1st) lptr_pcg6_f_o_aer(07,itype,ai_phase) = p_pcg6_f_o_a07 + if (p_pcg7_f_o_a07 .ge. p1st) lptr_pcg7_f_o_aer(07,itype,ai_phase) = p_pcg7_f_o_a07 + if (p_pcg8_f_o_a07 .ge. p1st) lptr_pcg8_f_o_aer(07,itype,ai_phase) = p_pcg8_f_o_a07 + if (p_pcg9_f_o_a07 .ge. p1st) lptr_pcg9_f_o_aer(07,itype,ai_phase) = p_pcg9_f_o_a07 + if (p_opcg1_f_c_a07 .ge. p1st) lptr_opcg1_f_c_aer(07,itype,ai_phase) = p_opcg1_f_c_a07 + if (p_opcg2_f_c_a07 .ge. p1st) lptr_opcg2_f_c_aer(07,itype,ai_phase) = p_opcg2_f_c_a07 + if (p_opcg3_f_c_a07 .ge. p1st) lptr_opcg3_f_c_aer(07,itype,ai_phase) = p_opcg3_f_c_a07 + if (p_opcg4_f_c_a07 .ge. p1st) lptr_opcg4_f_c_aer(07,itype,ai_phase) = p_opcg4_f_c_a07 + if (p_opcg5_f_c_a07 .ge. p1st) lptr_opcg5_f_c_aer(07,itype,ai_phase) = p_opcg5_f_c_a07 + if (p_opcg6_f_c_a07 .ge. p1st) lptr_opcg6_f_c_aer(07,itype,ai_phase) = p_opcg6_f_c_a07 + if (p_opcg7_f_c_a07 .ge. p1st) lptr_opcg7_f_c_aer(07,itype,ai_phase) = p_opcg7_f_c_a07 + if (p_opcg8_f_c_a07 .ge. p1st) lptr_opcg8_f_c_aer(07,itype,ai_phase) = p_opcg8_f_c_a07 + if (p_opcg1_f_o_a07 .ge. p1st) lptr_opcg1_f_o_aer(07,itype,ai_phase) = p_opcg1_f_o_a07 + if (p_opcg2_f_o_a07 .ge. p1st) lptr_opcg2_f_o_aer(07,itype,ai_phase) = p_opcg2_f_o_a07 + if (p_opcg3_f_o_a07 .ge. p1st) lptr_opcg3_f_o_aer(07,itype,ai_phase) = p_opcg3_f_o_a07 + if (p_opcg4_f_o_a07 .ge. p1st) lptr_opcg4_f_o_aer(07,itype,ai_phase) = p_opcg4_f_o_a07 + if (p_opcg5_f_o_a07 .ge. p1st) lptr_opcg5_f_o_aer(07,itype,ai_phase) = p_opcg5_f_o_a07 + if (p_opcg6_f_o_a07 .ge. p1st) lptr_opcg6_f_o_aer(07,itype,ai_phase) = p_opcg6_f_o_a07 + if (p_opcg7_f_o_a07 .ge. p1st) lptr_opcg7_f_o_aer(07,itype,ai_phase) = p_opcg7_f_o_a07 + if (p_opcg8_f_o_a07 .ge. p1st) lptr_opcg8_f_o_aer(07,itype,ai_phase) = p_opcg8_f_o_a07 + if (p_ant1_c_a07 .ge. p1st) lptr_ant1_c_aer(07,itype,ai_phase) = p_ant1_c_a07 + if (p_ant2_c_a07 .ge. p1st) lptr_ant2_c_aer(07,itype,ai_phase) = p_ant2_c_a07 + if (p_ant3_c_a07 .ge. p1st) lptr_ant3_c_aer(07,itype,ai_phase) = p_ant3_c_a07 + if (p_ant4_c_a07 .ge. p1st) lptr_ant4_c_aer(07,itype,ai_phase) = p_ant4_c_a07 + if (p_biog1_c_a07 .ge. p1st) lptr_biog1_c_aer(07,itype,ai_phase) = p_biog1_c_a07 + if (p_biog2_c_a07 .ge. p1st) lptr_biog2_c_aer(07,itype,ai_phase) = p_biog2_c_a07 + if (p_biog3_c_a07 .ge. p1st) lptr_biog3_c_aer(07,itype,ai_phase) = p_biog3_c_a07 + if (p_biog4_c_a07 .ge. p1st) lptr_biog4_c_aer(07,itype,ai_phase) = p_biog4_c_a07 + if (p_ant1_o_a07 .ge. p1st) lptr_ant1_o_aer(07,itype,ai_phase) = p_ant1_o_a07 + if (p_ant2_o_a07 .ge. p1st) lptr_ant2_o_aer(07,itype,ai_phase) = p_ant2_o_a07 + if (p_ant3_o_a07 .ge. p1st) lptr_ant3_o_aer(07,itype,ai_phase) = p_ant3_o_a07 + if (p_ant4_o_a07 .ge. p1st) lptr_ant4_o_aer(07,itype,ai_phase) = p_ant4_o_a07 + if (p_biog1_o_a07 .ge. p1st) lptr_biog1_o_aer(07,itype,ai_phase) = p_biog1_o_a07 + if (p_biog2_o_a07 .ge. p1st) lptr_biog2_o_aer(07,itype,ai_phase) = p_biog2_o_a07 + if (p_biog3_o_a07 .ge. p1st) lptr_biog3_o_aer(07,itype,ai_phase) = p_biog3_o_a07 + if (p_biog4_o_a07 .ge. p1st) lptr_biog4_o_aer(07,itype,ai_phase) = p_biog4_o_a07 numptr_aer(07,itype,ai_phase) = p_num_a07 - end if + end if if (nsize_aer(itype) .ge. 8) then lptr_so4_aer(08,itype,ai_phase) = p_so4_a08 @@ -6013,77 +7975,92 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_bc_aer(08,itype,ai_phase) = p_bc_a08 hyswptr_aer(08,itype) = p_hysw_a08 waterptr_aer(08,itype) = p_water_a08 - lptr_pcg1_b_c_aer(08,itype,ai_phase) = p_pcg1_b_c_a08 - lptr_pcg2_b_c_aer(08,itype,ai_phase) = p_pcg2_b_c_a08 - lptr_pcg3_b_c_aer(08,itype,ai_phase) = p_pcg3_b_c_a08 - lptr_pcg4_b_c_aer(08,itype,ai_phase) = p_pcg4_b_c_a08 - lptr_pcg5_b_c_aer(08,itype,ai_phase) = p_pcg5_b_c_a08 - lptr_pcg6_b_c_aer(08,itype,ai_phase) = p_pcg6_b_c_a08 - lptr_pcg7_b_c_aer(08,itype,ai_phase) = p_pcg7_b_c_a08 - lptr_pcg8_b_c_aer(08,itype,ai_phase) = p_pcg8_b_c_a08 - lptr_pcg9_b_c_aer(08,itype,ai_phase) = p_pcg9_b_c_a08 - lptr_pcg1_b_o_aer(08,itype,ai_phase) = p_pcg1_b_o_a08 - lptr_pcg2_b_o_aer(08,itype,ai_phase) = p_pcg2_b_o_a08 - lptr_pcg3_b_o_aer(08,itype,ai_phase) = p_pcg3_b_o_a08 - lptr_pcg4_b_o_aer(08,itype,ai_phase) = p_pcg4_b_o_a08 - lptr_pcg5_b_o_aer(08,itype,ai_phase) = p_pcg5_b_o_a08 - lptr_pcg6_b_o_aer(08,itype,ai_phase) = p_pcg6_b_o_a08 - lptr_pcg7_b_o_aer(08,itype,ai_phase) = p_pcg7_b_o_a08 - lptr_pcg8_b_o_aer(08,itype,ai_phase) = p_pcg8_b_o_a08 - lptr_pcg9_b_o_aer(08,itype,ai_phase) = p_pcg9_b_o_a08 - lptr_opcg1_b_c_aer(08,itype,ai_phase) = p_opcg1_b_c_a08 - lptr_opcg2_b_c_aer(08,itype,ai_phase) = p_opcg2_b_c_a08 - lptr_opcg3_b_c_aer(08,itype,ai_phase) = p_opcg3_b_c_a08 - lptr_opcg4_b_c_aer(08,itype,ai_phase) = p_opcg4_b_c_a08 - lptr_opcg5_b_c_aer(08,itype,ai_phase) = p_opcg5_b_c_a08 - lptr_opcg6_b_c_aer(08,itype,ai_phase) = p_opcg6_b_c_a08 - lptr_opcg7_b_c_aer(08,itype,ai_phase) = p_opcg7_b_c_a08 - lptr_opcg8_b_c_aer(08,itype,ai_phase) = p_opcg8_b_c_a08 - lptr_opcg1_b_o_aer(08,itype,ai_phase) = p_opcg1_b_o_a08 - lptr_opcg2_b_o_aer(08,itype,ai_phase) = p_opcg2_b_o_a08 - lptr_opcg3_b_o_aer(08,itype,ai_phase) = p_opcg3_b_o_a08 - lptr_opcg4_b_o_aer(08,itype,ai_phase) = p_opcg4_b_o_a08 - lptr_opcg5_b_o_aer(08,itype,ai_phase) = p_opcg5_b_o_a08 - lptr_opcg6_b_o_aer(08,itype,ai_phase) = p_opcg6_b_o_a08 - lptr_opcg7_b_o_aer(08,itype,ai_phase) = p_opcg7_b_o_a08 - lptr_opcg8_b_o_aer(08,itype,ai_phase) = p_opcg8_b_o_a08 - lptr_pcg1_f_c_aer(08,itype,ai_phase) = p_pcg1_f_c_a08 - lptr_pcg2_f_c_aer(08,itype,ai_phase) = p_pcg2_f_c_a08 - lptr_pcg3_f_c_aer(08,itype,ai_phase) = p_pcg3_f_c_a08 - lptr_pcg4_f_c_aer(08,itype,ai_phase) = p_pcg4_f_c_a08 - lptr_pcg5_f_c_aer(08,itype,ai_phase) = p_pcg5_f_c_a08 - lptr_pcg6_f_c_aer(08,itype,ai_phase) = p_pcg6_f_c_a08 - lptr_pcg7_f_c_aer(08,itype,ai_phase) = p_pcg7_f_c_a08 - lptr_pcg8_f_c_aer(08,itype,ai_phase) = p_pcg8_f_c_a08 - lptr_pcg9_f_c_aer(08,itype,ai_phase) = p_pcg9_f_c_a08 - lptr_pcg1_f_o_aer(08,itype,ai_phase) = p_pcg1_f_o_a08 - lptr_pcg2_f_o_aer(08,itype,ai_phase) = p_pcg2_f_o_a08 - lptr_pcg3_f_o_aer(08,itype,ai_phase) = p_pcg3_f_o_a08 - lptr_pcg4_f_o_aer(08,itype,ai_phase) = p_pcg4_f_o_a08 - lptr_pcg5_f_o_aer(08,itype,ai_phase) = p_pcg5_f_o_a08 - lptr_pcg6_f_o_aer(08,itype,ai_phase) = p_pcg6_f_o_a08 - lptr_pcg7_f_o_aer(08,itype,ai_phase) = p_pcg7_f_o_a08 - lptr_pcg8_f_o_aer(08,itype,ai_phase) = p_pcg8_f_o_a08 - lptr_pcg9_f_o_aer(08,itype,ai_phase) = p_pcg9_f_o_a08 - lptr_opcg1_f_c_aer(08,itype,ai_phase) = p_opcg1_f_c_a08 - lptr_opcg2_f_c_aer(08,itype,ai_phase) = p_opcg2_f_c_a08 - lptr_opcg3_f_c_aer(08,itype,ai_phase) = p_opcg3_f_c_a08 - lptr_opcg4_f_c_aer(08,itype,ai_phase) = p_opcg4_f_c_a08 - lptr_opcg5_f_c_aer(08,itype,ai_phase) = p_opcg5_f_c_a08 - lptr_opcg6_f_c_aer(08,itype,ai_phase) = p_opcg6_f_c_a08 - lptr_opcg7_f_c_aer(08,itype,ai_phase) = p_opcg7_f_c_a08 - lptr_opcg8_f_c_aer(08,itype,ai_phase) = p_opcg8_f_c_a08 - lptr_opcg1_f_o_aer(08,itype,ai_phase) = p_opcg1_f_o_a08 - lptr_opcg2_f_o_aer(08,itype,ai_phase) = p_opcg2_f_o_a08 - lptr_opcg3_f_o_aer(08,itype,ai_phase) = p_opcg3_f_o_a08 - lptr_opcg4_f_o_aer(08,itype,ai_phase) = p_opcg4_f_o_a08 - lptr_opcg5_f_o_aer(08,itype,ai_phase) = p_opcg5_f_o_a08 - lptr_opcg6_f_o_aer(08,itype,ai_phase) = p_opcg6_f_o_a08 - lptr_opcg7_f_o_aer(08,itype,ai_phase) = p_opcg7_f_o_a08 - lptr_opcg8_f_o_aer(08,itype,ai_phase) = p_opcg8_f_o_a08 - - + if (p_pcg1_b_c_a08 .ge. p1st) lptr_pcg1_b_c_aer(08,itype,ai_phase) = p_pcg1_b_c_a08 + if (p_pcg2_b_c_a08 .ge. p1st) lptr_pcg2_b_c_aer(08,itype,ai_phase) = p_pcg2_b_c_a08 + if (p_pcg3_b_c_a08 .ge. p1st) lptr_pcg3_b_c_aer(08,itype,ai_phase) = p_pcg3_b_c_a08 + if (p_pcg4_b_c_a08 .ge. p1st) lptr_pcg4_b_c_aer(08,itype,ai_phase) = p_pcg4_b_c_a08 + if (p_pcg5_b_c_a08 .ge. p1st) lptr_pcg5_b_c_aer(08,itype,ai_phase) = p_pcg5_b_c_a08 + if (p_pcg6_b_c_a08 .ge. p1st) lptr_pcg6_b_c_aer(08,itype,ai_phase) = p_pcg6_b_c_a08 + if (p_pcg7_b_c_a08 .ge. p1st) lptr_pcg7_b_c_aer(08,itype,ai_phase) = p_pcg7_b_c_a08 + if (p_pcg8_b_c_a08 .ge. p1st) lptr_pcg8_b_c_aer(08,itype,ai_phase) = p_pcg8_b_c_a08 + if (p_pcg9_b_c_a08 .ge. p1st) lptr_pcg9_b_c_aer(08,itype,ai_phase) = p_pcg9_b_c_a08 + if (p_pcg1_b_o_a08 .ge. p1st) lptr_pcg1_b_o_aer(08,itype,ai_phase) = p_pcg1_b_o_a08 + if (p_pcg2_b_o_a08 .ge. p1st) lptr_pcg2_b_o_aer(08,itype,ai_phase) = p_pcg2_b_o_a08 + if (p_pcg3_b_o_a08 .ge. p1st) lptr_pcg3_b_o_aer(08,itype,ai_phase) = p_pcg3_b_o_a08 + if (p_pcg4_b_o_a08 .ge. p1st) lptr_pcg4_b_o_aer(08,itype,ai_phase) = p_pcg4_b_o_a08 + if (p_pcg5_b_o_a08 .ge. p1st) lptr_pcg5_b_o_aer(08,itype,ai_phase) = p_pcg5_b_o_a08 + if (p_pcg6_b_o_a08 .ge. p1st) lptr_pcg6_b_o_aer(08,itype,ai_phase) = p_pcg6_b_o_a08 + if (p_pcg7_b_o_a08 .ge. p1st) lptr_pcg7_b_o_aer(08,itype,ai_phase) = p_pcg7_b_o_a08 + if (p_pcg8_b_o_a08 .ge. p1st) lptr_pcg8_b_o_aer(08,itype,ai_phase) = p_pcg8_b_o_a08 + if (p_pcg9_b_o_a08 .ge. p1st) lptr_pcg9_b_o_aer(08,itype,ai_phase) = p_pcg9_b_o_a08 + if (p_opcg1_b_c_a08 .ge. p1st) lptr_opcg1_b_c_aer(08,itype,ai_phase) = p_opcg1_b_c_a08 + if (p_opcg2_b_c_a08 .ge. p1st) lptr_opcg2_b_c_aer(08,itype,ai_phase) = p_opcg2_b_c_a08 + if (p_opcg3_b_c_a08 .ge. p1st) lptr_opcg3_b_c_aer(08,itype,ai_phase) = p_opcg3_b_c_a08 + if (p_opcg4_b_c_a08 .ge. p1st) lptr_opcg4_b_c_aer(08,itype,ai_phase) = p_opcg4_b_c_a08 + if (p_opcg5_b_c_a08 .ge. p1st) lptr_opcg5_b_c_aer(08,itype,ai_phase) = p_opcg5_b_c_a08 + if (p_opcg6_b_c_a08 .ge. p1st) lptr_opcg6_b_c_aer(08,itype,ai_phase) = p_opcg6_b_c_a08 + if (p_opcg7_b_c_a08 .ge. p1st) lptr_opcg7_b_c_aer(08,itype,ai_phase) = p_opcg7_b_c_a08 + if (p_opcg8_b_c_a08 .ge. p1st) lptr_opcg8_b_c_aer(08,itype,ai_phase) = p_opcg8_b_c_a08 + if (p_opcg1_b_o_a08 .ge. p1st) lptr_opcg1_b_o_aer(08,itype,ai_phase) = p_opcg1_b_o_a08 + if (p_opcg2_b_o_a08 .ge. p1st) lptr_opcg2_b_o_aer(08,itype,ai_phase) = p_opcg2_b_o_a08 + if (p_opcg3_b_o_a08 .ge. p1st) lptr_opcg3_b_o_aer(08,itype,ai_phase) = p_opcg3_b_o_a08 + if (p_opcg4_b_o_a08 .ge. p1st) lptr_opcg4_b_o_aer(08,itype,ai_phase) = p_opcg4_b_o_a08 + if (p_opcg5_b_o_a08 .ge. p1st) lptr_opcg5_b_o_aer(08,itype,ai_phase) = p_opcg5_b_o_a08 + if (p_opcg6_b_o_a08 .ge. p1st) lptr_opcg6_b_o_aer(08,itype,ai_phase) = p_opcg6_b_o_a08 + if (p_opcg7_b_o_a08 .ge. p1st) lptr_opcg7_b_o_aer(08,itype,ai_phase) = p_opcg7_b_o_a08 + if (p_opcg8_b_o_a08 .ge. p1st) lptr_opcg8_b_o_aer(08,itype,ai_phase) = p_opcg8_b_o_a08 + if (p_pcg1_f_c_a08 .ge. p1st) lptr_pcg1_f_c_aer(08,itype,ai_phase) = p_pcg1_f_c_a08 + if (p_pcg2_f_c_a08 .ge. p1st) lptr_pcg2_f_c_aer(08,itype,ai_phase) = p_pcg2_f_c_a08 + if (p_pcg3_f_c_a08 .ge. p1st) lptr_pcg3_f_c_aer(08,itype,ai_phase) = p_pcg3_f_c_a08 + if (p_pcg4_f_c_a08 .ge. p1st) lptr_pcg4_f_c_aer(08,itype,ai_phase) = p_pcg4_f_c_a08 + if (p_pcg5_f_c_a08 .ge. p1st) lptr_pcg5_f_c_aer(08,itype,ai_phase) = p_pcg5_f_c_a08 + if (p_pcg6_f_c_a08 .ge. p1st) lptr_pcg6_f_c_aer(08,itype,ai_phase) = p_pcg6_f_c_a08 + if (p_pcg7_f_c_a08 .ge. p1st) lptr_pcg7_f_c_aer(08,itype,ai_phase) = p_pcg7_f_c_a08 + if (p_pcg8_f_c_a08 .ge. p1st) lptr_pcg8_f_c_aer(08,itype,ai_phase) = p_pcg8_f_c_a08 + if (p_pcg9_f_c_a08 .ge. p1st) lptr_pcg9_f_c_aer(08,itype,ai_phase) = p_pcg9_f_c_a08 + if (p_pcg1_f_o_a08 .ge. p1st) lptr_pcg1_f_o_aer(08,itype,ai_phase) = p_pcg1_f_o_a08 + if (p_pcg2_f_o_a08 .ge. p1st) lptr_pcg2_f_o_aer(08,itype,ai_phase) = p_pcg2_f_o_a08 + if (p_pcg3_f_o_a08 .ge. p1st) lptr_pcg3_f_o_aer(08,itype,ai_phase) = p_pcg3_f_o_a08 + if (p_pcg4_f_o_a08 .ge. p1st) lptr_pcg4_f_o_aer(08,itype,ai_phase) = p_pcg4_f_o_a08 + if (p_pcg5_f_o_a08 .ge. p1st) lptr_pcg5_f_o_aer(08,itype,ai_phase) = p_pcg5_f_o_a08 + if (p_pcg6_f_o_a08 .ge. p1st) lptr_pcg6_f_o_aer(08,itype,ai_phase) = p_pcg6_f_o_a08 + if (p_pcg7_f_o_a08 .ge. p1st) lptr_pcg7_f_o_aer(08,itype,ai_phase) = p_pcg7_f_o_a08 + if (p_pcg8_f_o_a08 .ge. p1st) lptr_pcg8_f_o_aer(08,itype,ai_phase) = p_pcg8_f_o_a08 + if (p_pcg9_f_o_a08 .ge. p1st) lptr_pcg9_f_o_aer(08,itype,ai_phase) = p_pcg9_f_o_a08 + if (p_opcg1_f_c_a08 .ge. p1st) lptr_opcg1_f_c_aer(08,itype,ai_phase) = p_opcg1_f_c_a08 + if (p_opcg2_f_c_a08 .ge. p1st) lptr_opcg2_f_c_aer(08,itype,ai_phase) = p_opcg2_f_c_a08 + if (p_opcg3_f_c_a08 .ge. p1st) lptr_opcg3_f_c_aer(08,itype,ai_phase) = p_opcg3_f_c_a08 + if (p_opcg4_f_c_a08 .ge. p1st) lptr_opcg4_f_c_aer(08,itype,ai_phase) = p_opcg4_f_c_a08 + if (p_opcg5_f_c_a08 .ge. p1st) lptr_opcg5_f_c_aer(08,itype,ai_phase) = p_opcg5_f_c_a08 + if (p_opcg6_f_c_a08 .ge. p1st) lptr_opcg6_f_c_aer(08,itype,ai_phase) = p_opcg6_f_c_a08 + if (p_opcg7_f_c_a08 .ge. p1st) lptr_opcg7_f_c_aer(08,itype,ai_phase) = p_opcg7_f_c_a08 + if (p_opcg8_f_c_a08 .ge. p1st) lptr_opcg8_f_c_aer(08,itype,ai_phase) = p_opcg8_f_c_a08 + if (p_opcg1_f_o_a08 .ge. p1st) lptr_opcg1_f_o_aer(08,itype,ai_phase) = p_opcg1_f_o_a08 + if (p_opcg2_f_o_a08 .ge. p1st) lptr_opcg2_f_o_aer(08,itype,ai_phase) = p_opcg2_f_o_a08 + if (p_opcg3_f_o_a08 .ge. p1st) lptr_opcg3_f_o_aer(08,itype,ai_phase) = p_opcg3_f_o_a08 + if (p_opcg4_f_o_a08 .ge. p1st) lptr_opcg4_f_o_aer(08,itype,ai_phase) = p_opcg4_f_o_a08 + if (p_opcg5_f_o_a08 .ge. p1st) lptr_opcg5_f_o_aer(08,itype,ai_phase) = p_opcg5_f_o_a08 + if (p_opcg6_f_o_a08 .ge. p1st) lptr_opcg6_f_o_aer(08,itype,ai_phase) = p_opcg6_f_o_a08 + if (p_opcg7_f_o_a08 .ge. p1st) lptr_opcg7_f_o_aer(08,itype,ai_phase) = p_opcg7_f_o_a08 + if (p_opcg8_f_o_a08 .ge. p1st) lptr_opcg8_f_o_aer(08,itype,ai_phase) = p_opcg8_f_o_a08 + if (p_ant1_c_a08 .ge. p1st) lptr_ant1_c_aer(08,itype,ai_phase) = p_ant1_c_a08 + if (p_ant2_c_a08 .ge. p1st) lptr_ant2_c_aer(08,itype,ai_phase) = p_ant2_c_a08 + if (p_ant3_c_a08 .ge. p1st) lptr_ant3_c_aer(08,itype,ai_phase) = p_ant3_c_a08 + if (p_ant4_c_a08 .ge. p1st) lptr_ant4_c_aer(08,itype,ai_phase) = p_ant4_c_a08 + if (p_biog1_c_a08 .ge. p1st) lptr_biog1_c_aer(08,itype,ai_phase) = p_biog1_c_a08 + if (p_biog2_c_a08 .ge. p1st) lptr_biog2_c_aer(08,itype,ai_phase) = p_biog2_c_a08 + if (p_biog3_c_a08 .ge. p1st) lptr_biog3_c_aer(08,itype,ai_phase) = p_biog3_c_a08 + if (p_biog4_c_a08 .ge. p1st) lptr_biog4_c_aer(08,itype,ai_phase) = p_biog4_c_a08 + if (p_ant1_o_a08 .ge. p1st) lptr_ant1_o_aer(08,itype,ai_phase) = p_ant1_o_a08 + if (p_ant2_o_a08 .ge. p1st) lptr_ant2_o_aer(08,itype,ai_phase) = p_ant2_o_a08 + if (p_ant3_o_a08 .ge. p1st) lptr_ant3_o_aer(08,itype,ai_phase) = p_ant3_o_a08 + if (p_ant4_o_a08 .ge. p1st) lptr_ant4_o_aer(08,itype,ai_phase) = p_ant4_o_a08 + if (p_biog1_o_a08 .ge. p1st) lptr_biog1_o_aer(08,itype,ai_phase) = p_biog1_o_a08 + if (p_biog2_o_a08 .ge. p1st) lptr_biog2_o_aer(08,itype,ai_phase) = p_biog2_o_a08 + if (p_biog3_o_a08 .ge. p1st) lptr_biog3_o_aer(08,itype,ai_phase) = p_biog3_o_a08 + if (p_biog4_o_a08 .ge. p1st) lptr_biog4_o_aer(08,itype,ai_phase) = p_biog4_o_a08 + numptr_aer(08,itype,ai_phase) = p_num_a08 end if @@ -6103,6 +8080,34 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_oin_aer(01,itype,cw_phase) = p_oin_cw01 lptr_oc_aer(01,itype,cw_phase) = p_oc_cw01 lptr_bc_aer(01,itype,cw_phase) = p_bc_cw01 + + lptr_pcg1_b_c_aer(01,itype,cw_phase) = p_pcg1_b_c_cw01 + lptr_opcg1_b_c_aer(01,itype,cw_phase) = p_opcg1_b_c_cw01 + lptr_pcg1_b_o_aer(01,itype,cw_phase) = p_pcg1_b_o_cw01 + lptr_opcg1_b_o_aer(01,itype,cw_phase) = p_opcg1_b_o_cw01 + lptr_pcg1_f_c_aer(01,itype,cw_phase) = p_pcg1_f_c_cw01 + lptr_opcg1_f_c_aer(01,itype,cw_phase) = p_opcg1_f_c_cw01 + lptr_pcg1_f_o_aer(01,itype,cw_phase) = p_pcg1_f_o_cw01 + lptr_opcg1_f_o_aer(01,itype,cw_phase) = p_opcg1_f_o_cw01 + lptr_ant1_c_aer(01,itype,cw_phase) = p_ant1_c_cw01 + lptr_biog1_c_aer(01,itype,cw_phase) = p_biog1_c_cw01 + + if (p_glysoa_r1_cw01 .ge. p1st) lptr_glysoa_r1_aer(01,itype,cw_phase) = p_glysoa_r1_cw01 + if (p_glysoa_r2_cw01 .ge. p1st) lptr_glysoa_r2_aer(01,itype,cw_phase) = p_glysoa_r2_cw01 + if (p_glysoa_sfc_cw01 .ge. p1st) lptr_glysoa_sfc_aer(01,itype,cw_phase) = p_glysoa_sfc_cw01 + if (p_glysoa_nh4_cw01 .ge. p1st) lptr_glysoa_nh4_aer(01,itype,cw_phase) = p_glysoa_nh4_cw01 + if (p_glysoa_oh_cw01 .ge. p1st) lptr_glysoa_oh_aer(01,itype,cw_phase) = p_glysoa_oh_cw01 + if (p_asoaX_cw01 .ge. p1st) lptr_asoaX_aer(01,itype,cw_phase) = p_asoaX_cw01 + if (p_asoa1_cw01 .ge. p1st) lptr_asoa1_aer(01,itype,cw_phase) = p_asoa1_cw01 + if (p_asoa2_cw01 .ge. p1st) lptr_asoa2_aer(01,itype,cw_phase) = p_asoa2_cw01 + if (p_asoa3_cw01 .ge. p1st) lptr_asoa3_aer(01,itype,cw_phase) = p_asoa3_cw01 + if (p_asoa4_cw01 .ge. p1st) lptr_asoa4_aer(01,itype,cw_phase) = p_asoa4_cw01 + if (p_bsoaX_cw01 .ge. p1st) lptr_bsoaX_aer(01,itype,cw_phase) = p_bsoaX_cw01 + if (p_bsoa1_cw01 .ge. p1st) lptr_bsoa1_aer(01,itype,cw_phase) = p_bsoa1_cw01 + if (p_bsoa2_cw01 .ge. p1st) lptr_bsoa2_aer(01,itype,cw_phase) = p_bsoa2_cw01 + if (p_bsoa3_cw01 .ge. p1st) lptr_bsoa3_aer(01,itype,cw_phase) = p_bsoa3_cw01 + if (p_bsoa4_cw01 .ge. p1st) lptr_bsoa4_aer(01,itype,cw_phase) = p_bsoa4_cw01 + numptr_aer(01,itype,cw_phase) = p_num_cw01 end if end if @@ -6120,6 +8125,33 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_oin_aer(02,itype,cw_phase) = p_oin_cw02 lptr_oc_aer(02,itype,cw_phase) = p_oc_cw02 lptr_bc_aer(02,itype,cw_phase) = p_bc_cw02 + + lptr_pcg1_b_c_aer(02,itype,cw_phase) = p_pcg1_b_c_cw02 + lptr_opcg1_b_c_aer(02,itype,cw_phase) = p_opcg1_b_c_cw02 + lptr_pcg1_b_o_aer(02,itype,cw_phase) = p_pcg1_b_o_cw02 + lptr_opcg1_b_o_aer(02,itype,cw_phase) = p_opcg1_b_o_cw02 + lptr_pcg1_f_c_aer(02,itype,cw_phase) = p_pcg1_f_c_cw02 + lptr_opcg1_f_c_aer(02,itype,cw_phase) = p_opcg1_f_c_cw02 + lptr_pcg1_f_o_aer(02,itype,cw_phase) = p_pcg1_f_o_cw02 + lptr_opcg1_f_o_aer(02,itype,cw_phase) = p_opcg1_f_o_cw02 + lptr_ant1_c_aer(02,itype,cw_phase) = p_ant1_c_cw02 + lptr_biog1_c_aer(02,itype,cw_phase) = p_biog1_c_cw02 + + if (p_glysoa_r1_cw02 .ge. p1st) lptr_glysoa_r1_aer(02,itype,cw_phase) = p_glysoa_r1_cw02 + if (p_glysoa_r2_cw02 .ge. p1st) lptr_glysoa_r2_aer(02,itype,cw_phase) = p_glysoa_r2_cw02 + if (p_glysoa_sfc_cw02 .ge. p1st) lptr_glysoa_sfc_aer(02,itype,cw_phase) = p_glysoa_sfc_cw02 + if (p_glysoa_nh4_cw02 .ge. p1st) lptr_glysoa_nh4_aer(02,itype,cw_phase) = p_glysoa_nh4_cw02 + if (p_glysoa_oh_cw02 .ge. p1st) lptr_glysoa_oh_aer(02,itype,cw_phase) = p_glysoa_oh_cw02 + if (p_asoaX_cw02 .ge. p1st) lptr_asoaX_aer(02,itype,cw_phase) = p_asoaX_cw02 + if (p_asoa1_cw02 .ge. p1st) lptr_asoa1_aer(02,itype,cw_phase) = p_asoa1_cw02 + if (p_asoa2_cw02 .ge. p1st) lptr_asoa2_aer(02,itype,cw_phase) = p_asoa2_cw02 + if (p_asoa3_cw02 .ge. p1st) lptr_asoa3_aer(02,itype,cw_phase) = p_asoa3_cw02 + if (p_asoa4_cw02 .ge. p1st) lptr_asoa4_aer(02,itype,cw_phase) = p_asoa4_cw02 + if (p_bsoaX_cw02 .ge. p1st) lptr_bsoaX_aer(02,itype,cw_phase) = p_bsoaX_cw02 + if (p_bsoa1_cw02 .ge. p1st) lptr_bsoa1_aer(02,itype,cw_phase) = p_bsoa1_cw02 + if (p_bsoa2_cw02 .ge. p1st) lptr_bsoa2_aer(02,itype,cw_phase) = p_bsoa2_cw02 + if (p_bsoa3_cw02 .ge. p1st) lptr_bsoa3_aer(02,itype,cw_phase) = p_bsoa3_cw02 + if (p_bsoa4_cw02 .ge. p1st) lptr_bsoa4_aer(02,itype,cw_phase) = p_bsoa4_cw02 numptr_aer(02,itype,cw_phase) = p_num_cw02 end if end if @@ -6137,6 +8169,33 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_oin_aer(03,itype,cw_phase) = p_oin_cw03 lptr_oc_aer(03,itype,cw_phase) = p_oc_cw03 lptr_bc_aer(03,itype,cw_phase) = p_bc_cw03 + + lptr_pcg1_b_c_aer(03,itype,cw_phase) = p_pcg1_b_c_cw03 + lptr_opcg1_b_c_aer(03,itype,cw_phase) = p_opcg1_b_c_cw03 + lptr_pcg1_b_o_aer(03,itype,cw_phase) = p_pcg1_b_o_cw03 + lptr_opcg1_b_o_aer(03,itype,cw_phase) = p_opcg1_b_o_cw03 + lptr_pcg1_f_c_aer(03,itype,cw_phase) = p_pcg1_f_c_cw03 + lptr_opcg1_f_c_aer(03,itype,cw_phase) = p_opcg1_f_c_cw03 + lptr_pcg1_f_o_aer(03,itype,cw_phase) = p_pcg1_f_o_cw03 + lptr_opcg1_f_o_aer(03,itype,cw_phase) = p_opcg1_f_o_cw03 + lptr_ant1_c_aer(03,itype,cw_phase) = p_ant1_c_cw03 + lptr_biog1_c_aer(03,itype,cw_phase) = p_biog1_c_cw03 + + if (p_glysoa_r1_cw03 .ge. p1st) lptr_glysoa_r1_aer(03,itype,cw_phase) = p_glysoa_r1_cw03 + if (p_glysoa_r2_cw03 .ge. p1st) lptr_glysoa_r2_aer(03,itype,cw_phase) = p_glysoa_r2_cw03 + if (p_glysoa_sfc_cw03 .ge. p1st) lptr_glysoa_sfc_aer(03,itype,cw_phase) = p_glysoa_sfc_cw03 + if (p_glysoa_nh4_cw03 .ge. p1st) lptr_glysoa_nh4_aer(03,itype,cw_phase) = p_glysoa_nh4_cw03 + if (p_glysoa_oh_cw03 .ge. p1st) lptr_glysoa_oh_aer(03,itype,cw_phase) = p_glysoa_oh_cw03 + if (p_asoaX_cw03 .ge. p1st) lptr_asoaX_aer(03,itype,cw_phase) = p_asoaX_cw03 + if (p_asoa1_cw03 .ge. p1st) lptr_asoa1_aer(03,itype,cw_phase) = p_asoa1_cw03 + if (p_asoa2_cw03 .ge. p1st) lptr_asoa2_aer(03,itype,cw_phase) = p_asoa2_cw03 + if (p_asoa3_cw03 .ge. p1st) lptr_asoa3_aer(03,itype,cw_phase) = p_asoa3_cw03 + if (p_asoa4_cw03 .ge. p1st) lptr_asoa4_aer(03,itype,cw_phase) = p_asoa4_cw03 + if (p_bsoaX_cw03 .ge. p1st) lptr_bsoaX_aer(03,itype,cw_phase) = p_bsoaX_cw03 + if (p_bsoa1_cw03 .ge. p1st) lptr_bsoa1_aer(03,itype,cw_phase) = p_bsoa1_cw03 + if (p_bsoa2_cw03 .ge. p1st) lptr_bsoa2_aer(03,itype,cw_phase) = p_bsoa2_cw03 + if (p_bsoa3_cw03 .ge. p1st) lptr_bsoa3_aer(03,itype,cw_phase) = p_bsoa3_cw03 + if (p_bsoa4_cw03 .ge. p1st) lptr_bsoa4_aer(03,itype,cw_phase) = p_bsoa4_cw03 numptr_aer(03,itype,cw_phase) = p_num_cw03 end if end if @@ -6154,6 +8213,33 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_oin_aer(04,itype,cw_phase) = p_oin_cw04 lptr_oc_aer(04,itype,cw_phase) = p_oc_cw04 lptr_bc_aer(04,itype,cw_phase) = p_bc_cw04 + + lptr_pcg1_b_c_aer(04,itype,cw_phase) = p_pcg1_b_c_cw04 + lptr_opcg1_b_c_aer(04,itype,cw_phase) = p_opcg1_b_c_cw04 + lptr_pcg1_b_o_aer(04,itype,cw_phase) = p_pcg1_b_o_cw04 + lptr_opcg1_b_o_aer(04,itype,cw_phase) = p_opcg1_b_o_cw04 + lptr_pcg1_f_c_aer(04,itype,cw_phase) = p_pcg1_f_c_cw04 + lptr_opcg1_f_c_aer(04,itype,cw_phase) = p_opcg1_f_c_cw04 + lptr_pcg1_f_o_aer(04,itype,cw_phase) = p_pcg1_f_o_cw04 + lptr_opcg1_f_o_aer(04,itype,cw_phase) = p_opcg1_f_o_cw04 + lptr_ant1_c_aer(04,itype,cw_phase) = p_ant1_c_cw04 + lptr_biog1_c_aer(04,itype,cw_phase) = p_biog1_c_cw04 + + if (p_glysoa_r1_cw04 .ge. p1st) lptr_glysoa_r1_aer(04,itype,cw_phase) = p_glysoa_r1_cw04 + if (p_glysoa_r2_cw04 .ge. p1st) lptr_glysoa_r2_aer(04,itype,cw_phase) = p_glysoa_r2_cw04 + if (p_glysoa_sfc_cw04 .ge. p1st) lptr_glysoa_sfc_aer(04,itype,cw_phase) = p_glysoa_sfc_cw04 + if (p_glysoa_nh4_cw04 .ge. p1st) lptr_glysoa_nh4_aer(04,itype,cw_phase) = p_glysoa_nh4_cw04 + if (p_glysoa_oh_cw04 .ge. p1st) lptr_glysoa_oh_aer(04,itype,cw_phase) = p_glysoa_oh_cw04 + if (p_asoaX_cw04 .ge. p1st) lptr_asoaX_aer(04,itype,cw_phase) = p_asoaX_cw04 + if (p_asoa1_cw04 .ge. p1st) lptr_asoa1_aer(04,itype,cw_phase) = p_asoa1_cw04 + if (p_asoa2_cw04 .ge. p1st) lptr_asoa2_aer(04,itype,cw_phase) = p_asoa2_cw04 + if (p_asoa3_cw04 .ge. p1st) lptr_asoa3_aer(04,itype,cw_phase) = p_asoa3_cw04 + if (p_asoa4_cw04 .ge. p1st) lptr_asoa4_aer(04,itype,cw_phase) = p_asoa4_cw04 + if (p_bsoaX_cw04 .ge. p1st) lptr_bsoaX_aer(04,itype,cw_phase) = p_bsoaX_cw04 + if (p_bsoa1_cw04 .ge. p1st) lptr_bsoa1_aer(04,itype,cw_phase) = p_bsoa1_cw04 + if (p_bsoa2_cw04 .ge. p1st) lptr_bsoa2_aer(04,itype,cw_phase) = p_bsoa2_cw04 + if (p_bsoa3_cw04 .ge. p1st) lptr_bsoa3_aer(04,itype,cw_phase) = p_bsoa3_cw04 + if (p_bsoa4_cw04 .ge. p1st) lptr_bsoa4_aer(04,itype,cw_phase) = p_bsoa4_cw04 numptr_aer(04,itype,cw_phase) = p_num_cw04 end if end if @@ -6171,6 +8257,18 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_oin_aer(05,itype,cw_phase) = p_oin_cw05 lptr_oc_aer(05,itype,cw_phase) = p_oc_cw05 lptr_bc_aer(05,itype,cw_phase) = p_bc_cw05 + + lptr_pcg1_b_c_aer(05,itype,cw_phase) = p_pcg1_b_c_cw05 + lptr_opcg1_b_c_aer(05,itype,cw_phase) = p_opcg1_b_c_cw05 + lptr_pcg1_b_o_aer(05,itype,cw_phase) = p_pcg1_b_o_cw05 + lptr_opcg1_b_o_aer(05,itype,cw_phase) = p_opcg1_b_o_cw05 + lptr_pcg1_f_c_aer(05,itype,cw_phase) = p_pcg1_f_c_cw05 + lptr_opcg1_f_c_aer(05,itype,cw_phase) = p_opcg1_f_c_cw05 + lptr_pcg1_f_o_aer(05,itype,cw_phase) = p_pcg1_f_o_cw05 + lptr_opcg1_f_o_aer(05,itype,cw_phase) = p_opcg1_f_o_cw05 + lptr_ant1_c_aer(05,itype,cw_phase) = p_ant1_c_cw05 + lptr_biog1_c_aer(05,itype,cw_phase) = p_biog1_c_cw05 + numptr_aer(05,itype,cw_phase) = p_num_cw05 end if end if @@ -6188,6 +8286,18 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_oin_aer(06,itype,cw_phase) = p_oin_cw06 lptr_oc_aer(06,itype,cw_phase) = p_oc_cw06 lptr_bc_aer(06,itype,cw_phase) = p_bc_cw06 + + lptr_pcg1_b_c_aer(06,itype,cw_phase) = p_pcg1_b_c_cw06 + lptr_opcg1_b_c_aer(06,itype,cw_phase) = p_opcg1_b_c_cw06 + lptr_pcg1_b_o_aer(06,itype,cw_phase) = p_pcg1_b_o_cw06 + lptr_opcg1_b_o_aer(06,itype,cw_phase) = p_opcg1_b_o_cw06 + lptr_pcg1_f_c_aer(06,itype,cw_phase) = p_pcg1_f_c_cw06 + lptr_opcg1_f_c_aer(06,itype,cw_phase) = p_opcg1_f_c_cw06 + lptr_pcg1_f_o_aer(06,itype,cw_phase) = p_pcg1_f_o_cw06 + lptr_opcg1_f_o_aer(06,itype,cw_phase) = p_opcg1_f_o_cw06 + lptr_ant1_c_aer(06,itype,cw_phase) = p_ant1_c_cw06 + lptr_biog1_c_aer(06,itype,cw_phase) = p_biog1_c_cw06 + numptr_aer(06,itype,cw_phase) = p_num_cw06 end if end if @@ -6205,6 +8315,18 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_oin_aer(07,itype,cw_phase) = p_oin_cw07 lptr_oc_aer(07,itype,cw_phase) = p_oc_cw07 lptr_bc_aer(07,itype,cw_phase) = p_bc_cw07 + + lptr_pcg1_b_c_aer(07,itype,cw_phase) = p_pcg1_b_c_cw07 + lptr_opcg1_b_c_aer(07,itype,cw_phase) = p_opcg1_b_c_cw07 + lptr_pcg1_b_o_aer(07,itype,cw_phase) = p_pcg1_b_o_cw07 + lptr_opcg1_b_o_aer(07,itype,cw_phase) = p_opcg1_b_o_cw07 + lptr_pcg1_f_c_aer(07,itype,cw_phase) = p_pcg1_f_c_cw07 + lptr_opcg1_f_c_aer(07,itype,cw_phase) = p_opcg1_f_c_cw07 + lptr_pcg1_f_o_aer(07,itype,cw_phase) = p_pcg1_f_o_cw07 + lptr_opcg1_f_o_aer(07,itype,cw_phase) = p_opcg1_f_o_cw07 + lptr_ant1_c_aer(07,itype,cw_phase) = p_ant1_c_cw07 + lptr_biog1_c_aer(07,itype,cw_phase) = p_biog1_c_cw07 + numptr_aer(07,itype,cw_phase) = p_num_cw07 end if end if @@ -6222,6 +8344,18 @@ subroutine init_data_mosaic_ptr( is_aerosol ) lptr_oin_aer(08,itype,cw_phase) = p_oin_cw08 lptr_oc_aer(08,itype,cw_phase) = p_oc_cw08 lptr_bc_aer(08,itype,cw_phase) = p_bc_cw08 + + lptr_pcg1_b_c_aer(08,itype,cw_phase) = p_pcg1_b_c_cw08 + lptr_opcg1_b_c_aer(08,itype,cw_phase) = p_opcg1_b_c_cw08 + lptr_pcg1_b_o_aer(08,itype,cw_phase) = p_pcg1_b_o_cw08 + lptr_opcg1_b_o_aer(08,itype,cw_phase) = p_opcg1_b_o_cw08 + lptr_pcg1_f_c_aer(08,itype,cw_phase) = p_pcg1_f_c_cw08 + lptr_opcg1_f_c_aer(08,itype,cw_phase) = p_opcg1_f_c_cw08 + lptr_pcg1_f_o_aer(08,itype,cw_phase) = p_pcg1_f_o_cw08 + lptr_opcg1_f_o_aer(08,itype,cw_phase) = p_opcg1_f_o_cw08 + lptr_ant1_c_aer(08,itype,cw_phase) = p_ant1_c_cw08 + lptr_biog1_c_aer(08,itype,cw_phase) = p_biog1_c_cw08 + numptr_aer(08,itype,cw_phase) = p_num_cw08 end if end if @@ -6867,7 +9001,108 @@ subroutine init_data_mosaic_ptr( is_aerosol ) mcindx_dum = mastercompindx_biog4_o_aer spectxt = 'biog4_o_' nspectxt = 8 + else if (l_mastercomp .eq. mastercompindx_smpa_aer) then + lptr_dum = lptr_smpa_aer(n,itype,iphase) + mcindx_dum = mastercompindx_smpa_aer + spectxt = 'smpa_' + nspectxt = 5 + + else if (l_mastercomp .eq. mastercompindx_smpbb_aer) then + lptr_dum = lptr_smpbb_aer(n,itype,iphase) + mcindx_dum = mastercompindx_smpbb_aer + spectxt = 'smpbb_' + nspectxt = 5 + + else if (l_mastercomp .eq. mastercompindx_glysoa_r1_aer) then + lptr_dum = lptr_glysoa_r1_aer(n,itype,iphase) + mcindx_dum = mastercompindx_glysoa_r1_aer + spectxt = 'glysoa_r1_' + nspectxt = 10 + + else if (l_mastercomp .eq. mastercompindx_glysoa_r2_aer) then + lptr_dum = lptr_glysoa_r2_aer(n,itype,iphase) + mcindx_dum = mastercompindx_glysoa_r2_aer + spectxt = 'glysoa_r2_' + nspectxt = 10 + + else if (l_mastercomp .eq. mastercompindx_glysoa_sfc_aer) then + lptr_dum = lptr_glysoa_sfc_aer(n,itype,iphase) + mcindx_dum = mastercompindx_glysoa_sfc_aer + spectxt = 'glysoa_sfc_' + nspectxt = 11 + + else if (l_mastercomp .eq. mastercompindx_glysoa_nh4_aer) then + lptr_dum = lptr_glysoa_nh4_aer(n,itype,iphase) + mcindx_dum = mastercompindx_glysoa_nh4_aer + spectxt = 'glysoa_nh4_' + nspectxt = 11 + + else if (l_mastercomp .eq. mastercompindx_glysoa_oh_aer) then + lptr_dum = lptr_glysoa_oh_aer(n,itype,iphase) + mcindx_dum = mastercompindx_glysoa_oh_aer + spectxt = 'glysoa_oh_' + nspectxt = 10 + + else if (l_mastercomp .eq. mastercompindx_asoaX_aer) then + lptr_dum = lptr_asoaX_aer(n,itype,iphase) + mcindx_dum = mastercompindx_asoaX_aer + spectxt = 'asoaX_' + nspectxt = 6 + + else if (l_mastercomp .eq. mastercompindx_asoa1_aer) then + lptr_dum = lptr_asoa1_aer(n,itype,iphase) + mcindx_dum = mastercompindx_asoa1_aer + spectxt = 'asoa1_' + nspectxt = 6 + + else if (l_mastercomp .eq. mastercompindx_asoa2_aer) then + lptr_dum = lptr_asoa2_aer(n,itype,iphase) + mcindx_dum = mastercompindx_asoa2_aer + spectxt = 'asoa2_' + nspectxt = 6 + + else if (l_mastercomp .eq. mastercompindx_asoa3_aer) then + lptr_dum = lptr_asoa3_aer(n,itype,iphase) + mcindx_dum = mastercompindx_asoa3_aer + spectxt = 'asoa3_' + nspectxt = 6 + + else if (l_mastercomp .eq. mastercompindx_asoa4_aer) then + lptr_dum = lptr_asoa4_aer(n,itype,iphase) + mcindx_dum = mastercompindx_asoa4_aer + spectxt = 'asoa4_' + nspectxt = 6 + + else if (l_mastercomp .eq. mastercompindx_bsoaX_aer) then + lptr_dum = lptr_bsoaX_aer(n,itype,iphase) + mcindx_dum = mastercompindx_bsoaX_aer + spectxt = 'bsoaX_' + nspectxt = 6 + + else if (l_mastercomp .eq. mastercompindx_bsoa1_aer) then + lptr_dum = lptr_bsoa1_aer(n,itype,iphase) + mcindx_dum = mastercompindx_bsoa1_aer + spectxt = 'bsoa1_' + nspectxt = 6 + + else if (l_mastercomp .eq. mastercompindx_bsoa2_aer) then + lptr_dum = lptr_bsoa2_aer(n,itype,iphase) + mcindx_dum = mastercompindx_bsoa2_aer + spectxt = 'bsoa2_' + nspectxt = 6 + + else if (l_mastercomp .eq. mastercompindx_bsoa3_aer) then + lptr_dum = lptr_bsoa3_aer(n,itype,iphase) + mcindx_dum = mastercompindx_bsoa3_aer + spectxt = 'bsoa3_' + nspectxt = 6 + + else if (l_mastercomp .eq. mastercompindx_bsoa4_aer) then + lptr_dum = lptr_bsoa4_aer(n,itype,iphase) + mcindx_dum = mastercompindx_bsoa4_aer + spectxt = 'bsoa4_' + nspectxt = 6 else goto 2500 end if @@ -6985,6 +9220,9 @@ subroutine init_data_mosaic_ptr( is_aerosol ) write(msg,9350) 'ntype_aer = ', ntype_aer call peg_message( lunout, msg ) + write(msg,9350) 'ncomp_aer = ', ncomp_aer + call peg_message( lunout, msg ) + do itype=1,ntype_aer write(msg,9350) 'itype = ', itype @@ -7033,186 +9271,323 @@ subroutine init_data_mosaic_ptr( is_aerosol ) write(msg,9350) 'numptr_aer ', & (numptr_aer(n,itype,iphase), n=1,nsize_aer(itype)) call peg_message( lunout, msg ) + +! for all "write(msg)..." lines below: added missing CALL peg_message to actually write out the message write(msg,9350) 'lptr_pcg1_b_c_aer ', & (lptr_pcg1_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg2_b_c_aer ', & (lptr_pcg2_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg3_b_c_aer ', & (lptr_pcg3_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg4_b_c_aer ', & (lptr_pcg4_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg5_b_c_aer ', & (lptr_pcg5_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg6_b_c_aer ', & (lptr_pcg6_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg7_b_c_aer ', & (lptr_pcg7_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg8_b_c_aer ', & (lptr_pcg8_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg9_b_c_aer ', & (lptr_pcg9_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg1_b_o_aer ', & (lptr_pcg1_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg2_b_o_aer ', & (lptr_pcg2_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg3_b_o_aer ', & (lptr_pcg3_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg4_b_o_aer ', & (lptr_pcg4_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg5_b_o_aer ', & (lptr_pcg5_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg6_b_o_aer ', & (lptr_pcg6_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg7_b_o_aer ', & (lptr_pcg7_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg8_b_o_aer ', & (lptr_pcg8_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg9_b_o_aer ', & (lptr_pcg9_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg1_b_c_aer ', & (lptr_opcg1_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg2_b_c_aer ', & (lptr_opcg2_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg3_b_c_aer ', & (lptr_opcg3_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg4_b_c_aer ', & (lptr_opcg4_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg5_b_c_aer ', & (lptr_opcg5_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg6_b_c_aer ', & (lptr_opcg6_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg7_b_c_aer ', & (lptr_opcg7_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg8_b_c_aer ', & (lptr_opcg8_b_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg1_b_o_aer ', & (lptr_opcg1_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg2_b_o_aer ', & (lptr_opcg2_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg3_b_o_aer ', & (lptr_opcg3_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg4_b_o_aer ', & (lptr_opcg4_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg5_b_o_aer ', & (lptr_opcg5_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg6_b_o_aer ', & (lptr_opcg6_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg7_b_o_aer ', & (lptr_opcg7_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg8_b_o_aer ', & (lptr_opcg8_b_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg1_f_c_aer ', & (lptr_pcg1_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg2_f_c_aer ', & (lptr_pcg2_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg3_f_c_aer ', & (lptr_pcg3_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg4_f_c_aer ', & (lptr_pcg4_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg5_f_c_aer ', & (lptr_pcg5_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg6_f_c_aer ', & (lptr_pcg6_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg7_f_c_aer ', & (lptr_pcg7_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg8_f_c_aer ', & (lptr_pcg8_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg9_f_c_aer ', & (lptr_pcg9_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg1_f_o_aer ', & (lptr_pcg1_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg2_f_o_aer ', & (lptr_pcg2_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg3_f_o_aer ', & (lptr_pcg3_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg4_f_o_aer ', & (lptr_pcg4_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg5_f_o_aer ', & (lptr_pcg5_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg6_f_o_aer ', & (lptr_pcg6_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg7_f_o_aer ', & (lptr_pcg7_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg8_f_o_aer ', & (lptr_pcg8_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_pcg9_f_o_aer ', & (lptr_pcg9_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg1_f_c_aer ', & (lptr_opcg1_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg2_f_c_aer ', & (lptr_opcg2_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg3_f_c_aer ', & (lptr_opcg3_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg4_f_c_aer ', & (lptr_opcg4_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg5_f_c_aer ', & (lptr_opcg5_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg6_f_c_aer ', & (lptr_opcg6_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg7_f_c_aer ', & (lptr_opcg7_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg8_f_c_aer ', & (lptr_opcg8_f_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg1_f_o_aer ', & (lptr_opcg1_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg2_f_o_aer ', & (lptr_opcg2_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg3_f_o_aer ', & (lptr_opcg3_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg4_f_o_aer ', & (lptr_opcg4_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg5_f_o_aer ', & (lptr_opcg5_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg6_f_o_aer ', & (lptr_opcg6_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg7_f_o_aer ', & (lptr_opcg7_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'lptr_opcg8_f_o_aer ', & (lptr_opcg8_f_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'ant1_c_aer ', & (lptr_ant1_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'ant2_c_aer ', & (lptr_ant2_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'ant3_c_aer ', & (lptr_ant3_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'ant4_c_aer ', & (lptr_ant4_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'ant1_o_aer ', & (lptr_ant1_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'ant2_o_aer ', & (lptr_ant2_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'ant3_o_aer ', & (lptr_ant3_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'ant4_o_aer ', & (lptr_ant4_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'biog1_c_aer ', & (lptr_biog1_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'biog2_c_aer ', & (lptr_biog2_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'biog3_c_aer ', & (lptr_biog3_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'biog4_c_aer ', & (lptr_biog4_c_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'biog1_o_aer ', & (lptr_biog1_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'biog2_o_aer ', & (lptr_biog2_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'biog3_o_aer ', & (lptr_biog3_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) write(msg,9350) 'biog4_o_aer ', & (lptr_biog4_o_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'smpa_aer ', & + (lptr_smpa_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'smpbb_aer ', & + (lptr_smpbb_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'glysoa_r1_aer ', & + (lptr_glysoa_r1_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'glysoa_r2_aer ', & + (lptr_glysoa_r2_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'glysoa_sfc_aer ', & + (lptr_glysoa_sfc_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'glysoa_nh4_aer ', & + (lptr_glysoa_nh4_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'glysoa_oh_aer ', & + (lptr_glysoa_oh_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'asoaX_aer ', & + (lptr_asoaX_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'asoa1_aer ', & + (lptr_asoa1_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'asoa2_aer ', & + (lptr_asoa2_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'asoa3_aer ', & + (lptr_asoa3_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'asoa4_aer ', & + (lptr_asoa4_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'bsoaX_aer ', & + (lptr_bsoaX_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'bsoa1_aer ', & + (lptr_bsoa1_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'bsoa2_aer ', & + (lptr_bsoa2_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'bsoa3_aer ', & + (lptr_bsoa3_aer(n,itype,iphase), n=1,nsize_aer(itype)) + call peg_message( lunout, msg ) + write(msg,9350) 'bsoa4_aer ', & + (lptr_bsoa4_aer(n,itype,iphase), n=1,nsize_aer(itype)) call peg_message( lunout, msg ) + write(*,*) " ---------------------- " + + do ll = 1, ncomp_plustracer_aer(itype) -! 20130116 acd_ck_bugfix start ! added writeout of name_aer to understand which mastercomps are used ! write(msg,9350) 'massptr_aer(), ll', & write(msg,9350) name_aer(ll,itype), & -! 20130116 acd_ck_bugfix end (massptr_aer(ll,n,itype,iphase), n=1,nsize_aer(itype)), ll call peg_message( lunout, msg ) end do @@ -7322,10 +9697,23 @@ subroutine init_data_mosaic_ptr( is_aerosol ) y_biog2_o=0 y_biog3_o=0 y_biog4_o=0 -! 20130807 acd_alma_bugfix start y_smpa=0 y_smpbb=0 -! 20130807 acd_alma_bugfix end + y_glysoa_r1=0 + y_glysoa_r2=0 + y_glysoa_sfc=0 + y_glysoa_nh4=0 + y_glysoa_oh=0 + y_asoaX=0 + y_asoa1=0 + y_asoa2=0 + y_asoa3=0 + y_asoa4=0 + y_bsoaX=0 + y_bsoa1=0 + y_bsoa2=0 + y_bsoa3=0 + y_bsoa4=0 @@ -7428,10 +9816,23 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (lptr_biog2_o_aer(n,itype,iphase) .ge. p1st) y_biog2_o = y_biog2_o + 1 if (lptr_biog3_o_aer(n,itype,iphase) .ge. p1st) y_biog3_o = y_biog3_o + 1 if (lptr_biog4_o_aer(n,itype,iphase) .ge. p1st) y_biog4_o = y_biog4_o + 1 -! 20130807 acd_alma_bugfix start if (lptr_smpa_aer(n,itype,iphase) .ge. p1st) y_smpa = y_smpa + 1 if (lptr_smpbb_aer(n,itype,iphase) .ge. p1st) y_smpbb = y_smpbb + 1 -! 20130807 acd_alma_bugfix end + if (lptr_glysoa_r1_aer(n,itype,iphase) .ge. p1st) y_glysoa_r1 = y_glysoa_r1 + 1 + if (lptr_glysoa_r2_aer(n,itype,iphase) .ge. p1st) y_glysoa_r2 = y_glysoa_r2 + 1 + if (lptr_glysoa_sfc_aer(n,itype,iphase) .ge. p1st) y_glysoa_sfc = y_glysoa_sfc + 1 + if (lptr_glysoa_nh4_aer(n,itype,iphase) .ge. p1st) y_glysoa_nh4 = y_glysoa_nh4 + 1 + if (lptr_glysoa_oh_aer(n,itype,iphase) .ge. p1st) y_glysoa_oh = y_glysoa_oh + 1 + if (lptr_asoaX_aer(n,itype,iphase) .ge. p1st) y_asoaX = y_asoaX + 1 + if (lptr_asoa1_aer(n,itype,iphase) .ge. p1st) y_asoa1 = y_asoa1 + 1 + if (lptr_asoa2_aer(n,itype,iphase) .ge. p1st) y_asoa2 = y_asoa2 + 1 + if (lptr_asoa3_aer(n,itype,iphase) .ge. p1st) y_asoa3 = y_asoa3 + 1 + if (lptr_asoa4_aer(n,itype,iphase) .ge. p1st) y_asoa4 = y_asoa4 + 1 + if (lptr_bsoaX_aer(n,itype,iphase) .ge. p1st) y_bsoaX = y_bsoaX + 1 + if (lptr_bsoa1_aer(n,itype,iphase) .ge. p1st) y_bsoa1 = y_bsoa1 + 1 + if (lptr_bsoa2_aer(n,itype,iphase) .ge. p1st) y_bsoa2 = y_bsoa2 + 1 + if (lptr_bsoa3_aer(n,itype,iphase) .ge. p1st) y_bsoa3 = y_bsoa3 + 1 + if (lptr_bsoa4_aer(n,itype,iphase) .ge. p1st) y_bsoa4 = y_bsoa4 + 1 end do @@ -7992,6 +10393,125 @@ subroutine init_data_mosaic_ptr( is_aerosol ) write(msg,9350) 'phase, type=', iphase,itype call peg_error_fatal( lunerr, msg ) + else if ((y_smpa .ne. 0) .and. & + (y_smpa .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for smpa' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_smpbb .ne. 0) .and. & + (y_smpbb .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for smpbb' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_glysoa_r1 .ne. 0) .and. & + (y_glysoa_r1 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for glysoa_r1' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_glysoa_r2 .ne. 0) .and. & + (y_glysoa_r2 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for glysoa_r2' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_glysoa_sfc .ne. 0) .and. & + (y_glysoa_sfc .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for glysoa_sfc' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_glysoa_nh4 .ne. 0) .and. & + (y_glysoa_nh4 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for glysoa_nh4' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_glysoa_oh .ne. 0) .and. & + (y_glysoa_oh .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for glysoa_oh' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + + else if ((y_asoaX .ne. 0) .and. & + (y_asoaX .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for y_asoaX' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_asoa1 .ne. 0) .and. & + (y_asoa1 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for y_asoa1' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_asoa2 .ne. 0) .and. & + (y_asoa2 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for y_asoa2' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_asoa3 .ne. 0) .and. & + (y_asoa3 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for y_asoa3' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_asoa4 .ne. 0) .and. & + (y_asoa4 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for y_asoa4' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_bsoaX .ne. 0) .and. & + (y_bsoaX .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for y_bsoaX' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_bsoa1 .ne. 0) .and. & + (y_bsoa1 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for y_bsoa1' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_bsoa2 .ne. 0) .and. & + (y_bsoa2 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for y_bsoa2' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_bsoa3 .ne. 0) .and. & + (y_bsoa3 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for y_bsoa3' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) + + else if ((y_bsoa4 .ne. 0) .and. & + (y_bsoa4 .ne. nsize_aer(itype))) then + msg = '*** subr init_data_mosaic_ptr - ptr error for y_bsoa4' + call peg_message( lunerr, msg ) + write(msg,9350) 'phase, type=', iphase,itype + call peg_error_fatal( lunerr, msg ) else if ((y_msa .ne. 0) .and. & (y_msa .ne. nsize_aer(itype))) then msg = '*** subr init_data_mosaic_ptr - ptr error for msa' @@ -8280,6 +10800,49 @@ subroutine init_data_mosaic_ptr( is_aerosol ) ksmpbb = p_smpbb endif + if (p_gly .ge. p1st) then + kgly = p_gly + endif + + if (p_cvasoaX .ge. p1st) then + kasoaX = p_cvasoaX + endif + + if (p_cvasoa1 .ge. p1st) then + kasoa1 = p_cvasoa1 + endif + + if (p_cvasoa2 .ge. p1st) then + kasoa2 = p_cvasoa2 + endif + + if (p_cvasoa3 .ge. p1st) then + kasoa3 = p_cvasoa3 + endif + + if (p_cvasoa4 .ge. p1st) then + kasoa4 = p_cvasoa4 + endif + + if (p_cvbsoaX .ge. p1st) then + kbsoaX = p_cvbsoaX + endif + + if (p_cvbsoa1 .ge. p1st) then + kbsoa1 = p_cvbsoa1 + endif + + if (p_cvbsoa2 .ge. p1st) then + kbsoa2 = p_cvbsoa2 + endif + + if (p_cvbsoa3 .ge. p1st) then + kbsoa3 = p_cvbsoa3 + endif + + if (p_cvbsoa4 .ge. p1st) then + kbsoa4 = p_cvbsoa4 + endif if (p_ant1_c .ge. p1st) then kant1_c = p_ant1_c endif @@ -8474,6 +11037,7 @@ subroutine init_data_mosaic_ptr( is_aerosol ) ltot = max( ltot, kopcg8_f_o ) ltot = max( ltot, ksmpa ) ltot = max( ltot, ksmpbb ) + ltot = max( ltot, kgly ) ltot = max( ltot, kant1_c ) ltot = max( ltot, kant2_c ) ltot = max( ltot, kant3_c ) @@ -8490,6 +11054,16 @@ subroutine init_data_mosaic_ptr( is_aerosol ) ltot = max( ltot, kbiog2_o ) ltot = max( ltot, kbiog3_o ) ltot = max( ltot, kbiog4_o ) + ltot = max( ltot, kasoaX ) + ltot = max( ltot, kasoa1 ) + ltot = max( ltot, kasoa2 ) + ltot = max( ltot, kasoa3 ) + ltot = max( ltot, kasoa4 ) + ltot = max( ltot, kbsoaX ) + ltot = max( ltot, kbsoa1 ) + ltot = max( ltot, kbsoa2 ) + ltot = max( ltot, kbsoa3 ) + ltot = max( ltot, kbsoa4 ) do iphase=1,nphase_aer do itype=1,ntype_aer @@ -8599,6 +11173,7 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (p_opcg8_f_o .ge. p1st) name(kopcg8_f_o ) = 'opcg8_f_o' if (p_smpa .ge. p1st) name(ksmpa ) = 'smpa' if (p_smpbb .ge. p1st) name(ksmpbb ) = 'smpbb' + if (p_gly .ge. p1st) name(kgly ) = 'gly' if (p_ant1_c .ge. p1st) name(kant1_c ) = 'ant1_c' if (p_ant2_c .ge. p1st) name(kant2_c ) = 'ant2_c' if (p_ant3_c .ge. p1st) name(kant3_c ) = 'ant3_c' @@ -8615,6 +11190,16 @@ subroutine init_data_mosaic_ptr( is_aerosol ) if (p_biog2_o .ge. p1st) name(kbiog2_o ) = 'biog2_o' if (p_biog3_o .ge. p1st) name(kbiog3_o ) = 'biog3_o' if (p_biog4_o .ge. p1st) name(kbiog4_o ) = 'biog4_o' + if (p_cvasoaX .ge. p1st) name(kasoaX ) = 'cvasoaX' + if (p_cvasoa1 .ge. p1st) name(kasoa1 ) = 'cvasoa1' + if (p_cvasoa2 .ge. p1st) name(kasoa2 ) = 'cvasoa2' + if (p_cvasoa3 .ge. p1st) name(kasoa3 ) = 'cvasoa3' + if (p_cvasoa4 .ge. p1st) name(kasoa4 ) = 'cvasoa4' + if (p_cvbsoaX .ge. p1st) name(kbsoaX ) = 'cvbsoaX' + if (p_cvbsoa1 .ge. p1st) name(kbsoa1 ) = 'cvbsoa1' + if (p_cvbsoa2 .ge. p1st) name(kbsoa2 ) = 'cvbsoa2' + if (p_cvbsoa3 .ge. p1st) name(kbsoa3 ) = 'cvbsoa3' + if (p_cvbsoa4 .ge. p1st) name(kbsoa4 ) = 'cvbsoa4' if (p_hcl .ge. p1st) name(khcl ) = 'hcl' if (p_nh3 .ge. p1st) name(knh3 ) = 'nh3' if (p_n2o5 .ge. p1st) name(kn2o5 ) = 'n2o5' @@ -8766,6 +11351,11 @@ subroutine aerchem_debug_dump( & lptr_opcg6_f_o_aer(n,itype,iphase), lptr_opcg7_f_o_aer(n,itype,iphase),& lptr_opcg8_f_o_aer(n,itype,iphase), & lptr_smpa_aer(n,itype,iphase),lptr_smpbb_aer(n,itype,iphase), & + lptr_glysoa_r1_aer(n,itype,iphase), & + lptr_glysoa_r2_aer(n,itype,iphase), & + lptr_glysoa_sfc_aer(n,itype,iphase), & + lptr_glysoa_nh4_aer(n,itype,iphase), & + lptr_glysoa_oh_aer(n,itype,iphase), & lptr_ant1_c_aer(n,itype,iphase),lptr_ant2_c_aer(n,itype,iphase), & lptr_ant3_c_aer(n,itype,iphase),lptr_ant4_c_aer(n,itype,iphase), & lptr_ant1_o_aer(n,itype,iphase),lptr_ant2_o_aer(n,itype,iphase), & @@ -8773,7 +11363,13 @@ subroutine aerchem_debug_dump( & lptr_biog1_c_aer(n,itype,iphase),lptr_biog2_c_aer(n,itype,iphase), & lptr_biog3_c_aer(n,itype,iphase),lptr_biog4_c_aer(n,itype,iphase), & lptr_biog1_o_aer(n,itype,iphase),lptr_biog2_o_aer(n,itype,iphase), & - lptr_biog3_o_aer(n,itype,iphase),lptr_biog4_o_aer(n,itype,iphase) + lptr_biog3_o_aer(n,itype,iphase),lptr_biog4_o_aer(n,itype,iphase), & + lptr_asoaX_aer(n,itype,iphase), & + lptr_asoa1_aer(n,itype,iphase),lptr_asoa2_aer(n,itype,iphase), & + lptr_asoa3_aer(n,itype,iphase),lptr_asoa4_aer(n,itype,iphase), & + lptr_bsoaX_aer(n,itype,iphase), & + lptr_bsoa1_aer(n,itype,iphase),lptr_bsoa2_aer(n,itype,iphase), & + lptr_bsoa3_aer(n,itype,iphase),lptr_bsoa4_aer(n,itype,iphase) end do ! size end do ! type diff --git a/wrfv2_fire/chem/module_mosaic_gly.F b/wrfv2_fire/chem/module_mosaic_gly.F new file mode 100644 index 00000000..df34437e --- /dev/null +++ b/wrfv2_fire/chem/module_mosaic_gly.F @@ -0,0 +1,480 @@ + !---------------------------------------------------------------- + ! SOA formation from glyoxal with complex formulation including + ! * reversible formation (Kampf et al., ES&T, submitted) + ! * dark/ammonium-catalyzed formation (Noziere, J. Phys. Chem., 2009) + ! * OH chemistry (Ervens and Volkamer, ACP, 2010) + ! * surface uptake (Ervens and Volkamer, ACP, 2010) + ! Christoph Knote, ACD, NCAR, 20130326 + !---------------------------------------------------------------- + + MODULE module_mosaic_gly + + IMPLICIT NONE + + INTEGER, PARAMETER :: nspecs = 13, & + igly_g = 1, & + igly_r1 = 2, & + igly_r2 = 3, & + igly_nh4 = 4, & + igly_sfc = 5, & + igly_oh = 6, & + ic_as = 7, & + ic_an = 8, & + ia_nh4 = 9, & + ioh_g = 10, & + iph = 11, & + iwater = 12, & + iarea = 13 + + ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + LOGICAL, PARAMETER :: lfast_tau1 = .FALSE. + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + CONTAINS + + ! adapted from Numerical Recipes, Second Edition, p. 706-707 + ! changes: added "h" (timestep) argument to DERIVS calls + SUBROUTINE rk4(y, dydx, n, x, h, yout, derivs) + + INTEGER n + REAL(kind=8) :: h, x, dydx(n), y(n), yout(n) + EXTERNAL derivs + INTEGER i + REAL(kind=8) :: h6, hh, xh, dym(nspecs), dyt(nspecs), yt(nspecs) + + hh=h*0.5 + h6=h/6. + xh=x+hh + + DO i=1, n + yt(i) = y(i) + hh * dydx(i) + ENDDO + + CALL derivs(xh, yt, h, dyt) + + DO i=1, n + yt(i) = y(i) + hh * dyt(i) + ENDDO + + CALL derivs(xh, yt, h, dym) + + DO i=1, n + yt(i) = y(i) + h * dym(i) + dym(i) = dyt(i) + dym(i) + ENDDO + + CALL derivs(x+h, yt, h, dyt) + + DO i=1, n + yout(i) = y(i) + h6 * ( dydx(i) + dyt(i) + 2. * dym(i)) + ENDDO + + RETURN + + END SUBROUTINE rk4 + + ! Simple SOA formation from glyoxal as presented in + ! Washenfelder et al, JGR, 2011 + SUBROUTINE glysoa_simple(dtchem) + + USE module_data_mosaic_therm, ONLY: t_k, area_wet_a, gas, aer, & + jtotal, igly, iglysoa_sfc_a, nbin_a + + IMPLICIT NONE + + REAL(kind=8), INTENT(IN) :: dtchem + REAL(kind=8) :: omega, gamma_gly, A, delta_gly, frac_A + INTEGER :: ibin + + ! mean molecular velocity of glyoxal (cm/s) + omega = 1.455e4 * sqrt(t_k / 58.0_8) + + ! aerosol uptake coefficient for glyoxal (-) + ! Washenfelder et al., 2011: + ! 0 - 8 x 10^-4 + ! 2 x 10^-4 (+/- 1 x 10^-4) + ! Volkamer et al., 2007 + ! 3.7 x 10^-3 + ! B. Ervens, pers. comm., 2010 + gamma_gly = 3.3E-3 + + ! get total aerosol surface area (cm^2 / cm^3) + A = 0.0 + DO ibin = 1, nbin_a + A = A + area_wet_a(ibin) + ENDDO + + ! no aerosol surface area - no uptake + IF (A > 0.0) THEN + ! first order uptake, Fuchs and Sutugin, 1971 + ! dCg = 1/4 * gamma * A * |v_mol| * Cg * dt + delta_gly = 0.25 * gamma_gly * A * omega * gas(igly) * dtchem + + ! avoid negative concentrations + delta_gly = MIN(gas(igly), delta_gly) + + ! update partitioning + gas(igly) = gas(igly) - delta_gly + + ! distribute onto bins according to fraction of surface area + DO ibin = 1, nbin_a + frac_A = area_wet_a(ibin) / A + ! we take the "photochemical" glysoa aerosol as surrogate + aer(iglysoa_sfc_a, jtotal, ibin) = aer(iglysoa_sfc_a, jtotal, ibin) & + + frac_A * delta_gly + ENDDO + ENDIF + + END SUBROUTINE glysoa_simple + + SUBROUTINE glysoa_complex_derivs(x, y, dt, dydx) + + USE module_data_mosaic_therm, ONLY: conv1a, & ! converts q/mol(air) to nq/m^3 (q = mol or g) + p_atm, & ! pressure (atm) + t_k ! temperature (K) + + REAL(kind=8), INTENT(IN) :: x, y(nspecs), dt + REAL(kind=8), INTENT(OUT) :: dydx(nspecs) + + REAL(kind=8), PARAMETER :: eps = 1.e-16 , & ! minimum allowed concentration in reservoirs + Kh_water = 4.19e5 , & ! effective Henry's law constant of glyoxal in pure water (M atm-1) (Ip et al., GRL, 2011) + Kh_oh = 25.0, & ! Henry's law constant of OH in pure water (M atm-1) (Klaening et al., 1985) + k_oh = 1.1e9 ! OH reaction rate (mol L-1 s-1) (Ervens and Volkamer, ACP, 2010) + + REAL(kind=8) :: gly_g_atm, & ! gas-phase concentration in atm + f_A1, & ! fraction of glyoxal in reservoir 1 + tau1, & ! characteristical timescale reservoir 1 + tau2, & ! characteristical timescale reservoir 2 + oh_g_atm, & ! gas-phase OH concentration in atm + oh_a, & ! liquid-phase OH concentration + c_tot, & ! total concentration of dissolved salts (M) + Kh_eq, & ! Henry's law constant at equilibrium (M atm-1) + gly_ptot_eq,& ! total glyoxal concentration (reservoirs 1 and 2) at equilibrium + gly_r1_eq, & ! glyoxal concentration (reservoir 1) at equilibrium + gly_r2_eq, & ! glyoxal concentration (reservoir 2) at equilibrium + anh4, & ! ammonium-ion activity (constrained) + kII, kI, & ! second and first order dark rate constants + omega ! mean molecular velocity of glyoxal (cm/s) + + ! tendencies + REAL(kind=8) :: dg_r1, & ! from gas-phase to reservoir 1 + dr1_r2, & ! reservoir 1 to reservoir 2 (or vice versa) + dr1_nh4, & ! reservoir 1 to nh4 + dr1_oh, & ! reservoir 1 to oh + dg_sfc ! gas-phase to surface uptake + + REAL(kind=8) :: accloss, & ! acc. loss + scaling ! tendency scaling + + dg_r1 = 0.0 + dr1_r2 = 0.0 + dr1_nh4 = 0.0 + dr1_oh = 0.0 + dg_sfc = 0.0 + + ! convert gas-phase glyoxal concentration + ! ------------------------------------------------------------- + + gly_g_atm = y(igly_g) / conv1a ! mole / mole + gly_g_atm = gly_g_atm * p_atm ! atm + + ! with A2/A1 = Kolig, and Kolig is 1 + f_A1 = 0.5 + tau1 = 2.5e2 ! s + tau2 = 5.5e3 ! s + IF ( y(ic_as) + y(ic_an) .GT. 12.0 ) THEN + ! with A2/A1 = Kolig, and Kolig is 0.5 + f_A1 = 0.6667 + tau1 = 4.4e4 ! s + tau2 = 4.7e4 ! s + ENDIF + + ! Kampff et al., ES&T, 2013, submitted: kinetic limitation of + ! salting-in for SO4 concentrations > 12 M. + c_tot = MIN( 12.0, y(ic_as) + y(ic_an) ) + + ! effective Henry's law constant including salting-in effect (Kampff et al.) + ! at equilibrium + ! derived from eqn. 3 in Kampff et al., -0.24 is "salting-in" constant + Kh_eq = Kh_water / 10**(-0.24D0 * c_tot) ! mol L-1 atm-1 == mol kg-1 atm-1 + + ! gly_g_atm in atm, Kh_eq in mol kg-1 atm-1, water in kg m-3 air + ! total glyoxal concentration (reservoirs 1 and 2) at equilibrium + gly_ptot_eq = gly_g_atm * Kh_eq * y(iwater) * 1e9 ! nmol / m3 air + + gly_r1_eq = gly_ptot_eq * f_A1 ! in reservoir 1 at equilibrium + gly_r2_eq = gly_ptot_eq * (1.0 - f_A1) ! in reservoir 2 at equilibrium + + ! process tendencies in nmol m-3 s-1 + ! from gas-phase to reservoir 1 + ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF (.NOT. lfast_tau1) THEN + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + dg_r1 = (1.0/tau1) * (gly_r1_eq - y(igly_r1)) + ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ENDIF + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! reservoir 1 to reservoir 2 + dr1_r2 = (1.0/tau2) * (gly_r2_eq - y(igly_r2)) + + ! OH reaction (Ervens and Volkamer, Atm. Chem. Phys., 2010) + ! ------------------------------------------------------------- + + oh_g_atm = y(ioh_g) / conv1a ! now its in mole / mole + oh_g_atm = oh_g_atm * p_atm ! partial pressure (atm) + oh_a = oh_g_atm * Kh_oh * y(iwater) * 1e9 ! nmol / m3 air + + dr1_oh = k_oh * y(igly_r1) * oh_a ! nmole m-3 s-1 + + ! dark pathway (Noziere et al., J. Phys. Chem., 2009) + ! ------------------------------------------------------------- + + ! second-order rate constant (mol-1 kg s-1): + anh4 = MAX( 0.0, MIN( 4.0, y(ia_nh4)) ) ! restrict to measured range + kII = 2.e-10 * exp(1.5 * anh4) * exp(2.5 * y(iph)) + + ! dark process uses reservoir 1 + kI = kII * y(igly_r1) / y(iwater) * 1e-9 ! s-1 + + dr1_nh4 = kI * y(igly_r1) ! nmol m-3 s-1 + + ! surface uptake (Ervens and Volkamer, ACP, 2010) + ! ------------------------------------------------------------- + + ! mean molecular velocity of glyoxal (cm/s) + omega = 1.455e4 * sqrt(t_k / 58.0D0) + + ! first order uptake, Fuchs and Sutugin, 1971 + ! dCg = 1/4 * gamma * A * |v_mol| * Cg * dt, + ! gamma downscaled to 1.0e-3 according to Waxman et al., 2013 + dg_sfc = 0.25D0 * 1.e-3 * y(iarea) * omega * y(igly_g) + + ! Numerical integration + ! ------------------------------------------------------------- + + ! check for undershoots, avoid negative concentrations + ! while ensuring we don't loose mass + IF ( y(igly_g) < eps ) THEN + dg_r1 = 0.0 + dg_sfc = 0.0 + ELSE + accloss = (dg_r1 + dg_sfc) * dt + IF ( ( y(igly_g) - accloss ) < eps ) THEN + scaling = y(igly_g) / (accloss + eps) + dg_r1 = dg_r1 * scaling + dg_sfc = dg_sfc * scaling + ENDIF + ENDIF + + IF ( y(igly_r1) < eps ) THEN + dr1_r2 = 0.0 + dr1_nh4 = 0.0 + dr1_oh = 0.0 + ELSE + accloss = (-dg_r1 + dr1_r2 + dr1_nh4 + dr1_oh) * dt + IF ( ( y(igly_r1) - accloss ) < eps) THEN + scaling = y(igly_r1) / (accloss + eps) + dr1_r2 = dr1_r2 * scaling + dr1_nh4 = dr1_nh4 * scaling + dr1_oh = dr1_oh * scaling + ENDIF + ENDIF + + IF ( y(igly_r2) < eps ) THEN + dr1_r2 = MAX( 0.0, dr1_r2 ) + ELSE + accloss = -dr1_r2 * dt + IF ( ( y(igly_r2) - accloss ) < eps ) THEN + scaling = y(igly_r2) / (accloss + eps) + dr1_r2 = dr1_r2 * scaling + ENDIF + ENDIF + + ! sum tendencies + dydx(igly_g) = -dg_r1 -dg_sfc + dydx(igly_r1) = dg_r1 -dr1_r2 -dr1_nh4 -dr1_oh + dydx(igly_r2) = dr1_r2 + dydx(igly_nh4) = +dr1_nh4 + dydx(igly_oh) = dr1_oh + dydx(igly_sfc) = dg_sfc + + END SUBROUTINE glysoa_complex_derivs + + SUBROUTINE glysoa_complex(dtchem) + + USE module_data_mosaic_therm, ONLY : jaerosolstate, all_liquid, mixed, & + jtotal, jliquid, nbin_a, & + area_wet_a, gas, water_a, aer, mc, & + ph, a_nh4, c_as, c_an, & + igly, iho, & + iglysoa_r1_a, iglysoa_r2_a, & + iglysoa_oh_a, & + iglysoa_nh4_a, iglysoa_sfc_a, & + iso4_a, ino3_a, inh4_a, jc_h + + ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + USE module_data_mosaic_therm, ONLY: conv1a, & ! converts q/mol(air) to nq/m^3 (q = mol or g) + p_atm ! pressure (atm) + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + REAL(kind=8), INTENT(IN) :: dtchem + + REAL(kind=8) :: A, conv, y(nspecs), yout(nspecs), & + dydx(nspecs), gly_g + + INTEGER :: i, ii, nbin_proc, bin_proc(nbin_a) + + ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + REAL(kind=8), PARAMETER :: Kh_water = 4.19e5 ! effective Henry's law constant of glyoxal in pure water (M atm-1) (Ip et al., GRL, 2011) + + REAL(kind=8) :: gly_g_atm, & ! gas-phase concentration in atm + f_A1, & ! fraction of glyoxal in reservoir 1 + c_tot, & ! total concentration of dissolved salts (M) + Kh_eq, & ! Henry's law constant at equilibrium (M atm-1) + gly_ptot_eq,& ! total glyoxal concentration (reservoirs 1 and 2) at equilibrium + gly_r1_eq, & ! glyoxal concentration (reservoir 1) at equilibrium + deltagly ! delta to bring r1 in equilibrium + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + + ! liquid / mixed phase bins available? + ! --------------------------------------------------------------- + nbin_proc = 0 + bin_proc(:) = -1 ! see which bins are either mixed, + ! or all_liquid (only these are to be processed) + DO i = 1, nbin_a + IF (jaerosolstate(i) == all_liquid .OR. & + jaerosolstate(i) == mixed) THEN + nbin_proc = nbin_proc + 1 + bin_proc(nbin_proc) = i + ENDIF + ENDDO + IF (nbin_proc == 0) RETURN + + ! aerosol surface area available? + ! --------------------------------------------------------------- + + A = 0.0 ! total aerosol surface area (cm^2 / cm^3) + DO i = 1, nbin_proc + ii = bin_proc(i) + A = A + area_wet_a(ii) + ENDDO + IF (A <= 0) RETURN + + ! clean diagnostic arrays + ! --------------------------------------------------------------- + + ph(:) = -9999.0 ! aerosol pH + a_nh4(:) = 0.0 ! ammonium ion activity (M, mol/m^3) + c_as(:) = 0.0 ! ammonium sulfate concentration (M, mol/kg) + c_an(:) = 0.0 ! ammonium nitrate concentration (M, mol/kg) + + ! get gas-phase + ! --------------------------------------------------------------- + + ! gly_g will be re-used for all bins + gly_g = gas(igly) ! nmol / m3 + + DO i = 1, nbin_proc + + ii = bin_proc(i) + + ! load concentrations array + ! ------------------------------------------------------------- + + conv = 1.e-9 / water_a(ii) ! nmol/m^3 (air) -> mol/kg (water) + + y(:) = 0.0 + + ! nmol/m^3 + y(igly_g) = gly_g + y(igly_r1) = aer(iglysoa_r1_a,jtotal,ii) + y(igly_r2) = aer(iglysoa_r2_a,jtotal,ii) + y(igly_nh4) = aer(iglysoa_nh4_a,jtotal,ii) + y(igly_sfc) = aer(iglysoa_sfc_a,jtotal,ii) + y(igly_oh) = aer(iglysoa_oh_a,jtotal,ii) + + y(ic_as) = aer(iso4_a,jliquid,ii) * conv ! assume we can only form (NH4)2SO4 + y(ic_an) = aer(ino3_a,jliquid,ii) * conv ! assume we can only form NH4NO3 + y(ia_nh4) = aer(inh4_a,jliquid,ii) * conv ! set activity == concentration + + y(iph) = MIN(14.0D0, MAX(0.0D0, -log10(mc(jc_h,ii)) )) + + y(iwater) = water_a(ii) ! kg m-3 + + y(ioh_g) = gas(iho) ! nmol m-3 + + y(iarea) = area_wet_a(ii) ! cm^2 / cm^3 + + ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + IF (lfast_tau1) THEN + ! instantaneous Henry's law equilibrium + ! for fast partitioning (in case characteristic timescale + ! of Kampf et al. is only artefact...) + gly_g_atm = y(igly_g) / conv1a ! mole / mole + gly_g_atm = gly_g_atm * p_atm ! atm + + ! with A2/A1 = Kolig, and Kolig is 1 + f_A1 = 0.5 + IF ( y(ic_as) + y(ic_an) .GT. 12.0 ) THEN + f_A1 = 0.6667 + ENDIF + + ! Kampff et al., ES&T, 2013, submitted: kinetic limitation of + ! salting-in for SO4 concentrations > 12 M. + c_tot = MIN( 12.0, y(ic_as) + y(ic_an) ) + + ! effective Henry's law constant including salting-in effect (Kampff et al.) + ! at equilibrium + ! derived from eqn. 3 in Kampff et al., -0.24 is "salting-in" constant + Kh_eq = Kh_water / 10**(-0.24D0 * c_tot) ! mol L-1 atm-1 == mol kg-1 atm-1 + + ! gly_g_atm in atm, Kh_eq in mol kg-1 atm-1, water in kg m-3 air + ! total glyoxal concentration (reservoirs 1 and 2) at equilibrium + gly_ptot_eq = gly_g_atm * Kh_eq * y(iwater) * 1e9 ! nmol / m3 air + + gly_r1_eq = gly_ptot_eq * f_A1 ! in reservoir 1 at equilibrium + + deltagly = gly_r1_eq - y(igly_r1) + + y(igly_g) = y(igly_g) - deltagly + y(igly_r1) = y(igly_r1) + deltagly + + IF (y(igly_g) < 0.0 .OR. y(igly_r1) < 0.0) THEN + WRITE(*,*) "THIS IS NOT RIGHT: ",y(igly_g), y(igly_r1),deltagly + ENDIF + ENDIF + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + ! integrate system + ! ------------------------------------------------------------- + CALL glysoa_complex_derivs(1._8, y, dtchem, dydx) + CALL rk4(y, dydx, nspecs, 1._8, dtchem, yout, glysoa_complex_derivs) + + ! update transported fields + aer(iglysoa_r1_a,jtotal,ii) = yout(igly_r1) + aer(iglysoa_r2_a,jtotal,ii) = yout(igly_r2) + aer(iglysoa_nh4_a,jtotal,ii) = yout(igly_nh4) + aer(iglysoa_sfc_a,jtotal,ii) = yout(igly_sfc) + aer(iglysoa_oh_a,jtotal,ii) = yout(igly_oh) + + ! do not put gas-phase glyoxal back yet, as we will use it + ! for the next bin as well... + gly_g = yout(igly_g) + + ! save diagnostics + c_as(ii) = yout(ic_as) + c_an(ii) = yout(ic_an) + ph(ii) = yout(iph) + a_nh4(ii) = yout(ia_nh4) + + ENDDO + + ! update gas-phase reservoir, after all bins have been treated. + gas(igly) = gly_g + + END SUBROUTINE glysoa_complex + + + END MODULE module_mosaic_gly + diff --git a/wrfv2_fire/chem/module_mosaic_therm.F b/wrfv2_fire/chem/module_mosaic_therm.F index e10d5e7e..7c17b52c 100644 --- a/wrfv2_fire/chem/module_mosaic_therm.F +++ b/wrfv2_fire/chem/module_mosaic_therm.F @@ -968,6 +968,16 @@ subroutine map_mosaic_species(k, m, imap) else gas(ismpbb_g) = 0.0 end if + if (kgly .ge. p1st) then + gas(igly) = rsub(kgly,k,m)*conv1a + else + gas(igly) = 0.0 + end if + if (koh .ge. p1st) then + gas(iho) = rsub(koh,k,m)*conv1a + else + gas(koh) = 0.0 + end if if (kant1_c .ge. p1st) then @@ -1054,7 +1064,65 @@ subroutine map_mosaic_species(k, m, imap) gas(ibiog4_o_g) = 0.0 end if + if (kasoaX .ge. p1st) then + gas(iasoaX_g) = rsub(kasoaX,k,m)*conv1a + else + gas(iasoaX_g) = 0.0 + end if + + if (kasoa1 .ge. p1st) then + gas(iasoa1_g) = rsub(kasoa1,k,m)*conv1a + else + gas(iasoa1_g) = 0.0 + end if + + if (kasoa2 .ge. p1st) then + gas(iasoa2_g) = rsub(kasoa2,k,m)*conv1a + else + gas(iasoa2_g) = 0.0 + end if + + if (kasoa3 .ge. p1st) then + gas(iasoa3_g) = rsub(kasoa3,k,m)*conv1a + else + gas(iasoa3_g) = 0.0 + end if + + if (kasoa4 .ge. p1st) then + gas(iasoa4_g) = rsub(kasoa4,k,m)*conv1a + else + gas(iasoa4_g) = 0.0 + end if + + if (kbsoaX .ge. p1st) then + gas(ibsoaX_g) = rsub(kbsoaX,k,m)*conv1a + else + gas(ibsoaX_g) = 0.0 + end if + + if (kbsoa1 .ge. p1st) then + gas(ibsoa1_g) = rsub(kbsoa1,k,m)*conv1a + else + gas(ibsoa1_g) = 0.0 + end if + + if (kbsoa2 .ge. p1st) then + gas(ibsoa2_g) = rsub(kbsoa2,k,m)*conv1a + else + gas(ibsoa2_g) = 0.0 + end if + if (kbsoa3 .ge. p1st) then + gas(ibsoa3_g) = rsub(kbsoa3,k,m)*conv1a + else + gas(ibsoa3_g) = 0.0 + end if + + if (kbsoa4 .ge. p1st) then + gas(ibsoa4_g) = rsub(kbsoa4,k,m)*conv1a + else + gas(ibsoa4_g) = 0.0 + end if @@ -1573,6 +1641,40 @@ subroutine map_mosaic_species(k, m, imap) aer(ismpbb_a,jtotal,ibin)=0.0 end if + l = lptr_glysoa_r1_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iglysoa_r1_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iglysoa_r1_a,jtotal,ibin)=0.0 + end if + + l = lptr_glysoa_r2_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iglysoa_r2_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iglysoa_r2_a,jtotal,ibin)=0.0 + end if + + l = lptr_glysoa_sfc_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iglysoa_sfc_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iglysoa_sfc_a,jtotal,ibin)=0.0 + end if + + l = lptr_glysoa_nh4_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iglysoa_nh4_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iglysoa_nh4_a,jtotal,ibin)=0.0 + end if + + l = lptr_glysoa_oh_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iglysoa_oh_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iglysoa_oh_a,jtotal,ibin)=0.0 + end if l = lptr_ant1_c_aer(isize,itype,iphase) if (l .ge. p1st) then @@ -1686,6 +1788,75 @@ subroutine map_mosaic_species(k, m, imap) aer(ibiog4_o_a,jtotal,ibin)=0.0 end if + l = lptr_asoaX_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iasoaX_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iasoaX_a,jtotal,ibin)=0.0 + end if + + l = lptr_asoa1_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iasoa1_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iasoa1_a,jtotal,ibin)=0.0 + end if + + l = lptr_asoa2_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iasoa2_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iasoa2_a,jtotal,ibin)=0.0 + end if + + l = lptr_asoa3_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iasoa3_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iasoa3_a,jtotal,ibin)=0.0 + end if + + l = lptr_asoa4_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(iasoa4_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(iasoa4_a,jtotal,ibin)=0.0 + end if + + l = lptr_bsoaX_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ibsoaX_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ibsoaX_a,jtotal,ibin)=0.0 + end if + + l = lptr_bsoa1_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ibsoa1_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ibsoa1_a,jtotal,ibin)=0.0 + end if + + l = lptr_bsoa2_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ibsoa2_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ibsoa2_a,jtotal,ibin)=0.0 + end if + + l = lptr_bsoa3_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ibsoa3_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ibsoa3_a,jtotal,ibin)=0.0 + end if + + l = lptr_bsoa4_aer(isize,itype,iphase) + if (l .ge. p1st) then + aer(ibsoa4_a,jtotal,ibin)=rsub(l,k,m)*conv1a + else + aer(ibsoa4_a,jtotal,ibin)=0.0 + end if ! water_a and water_a_hyst units are kg/(m^3 air) l = hyswptr_aer(isize,itype) @@ -1875,6 +2046,11 @@ subroutine map_mosaic_species(k, m, imap) rsub(kopcg8_f_o,k,m) = gas(iopcg8_f_o_g)*conv1b if (ksmpa .ge. p1st) & rsub(ksmpa,k,m) = gas(ismpa_g)*conv1b + if (kgly .ge. p1st) & + rsub(kgly,k,m) = gas(igly)*conv1b + ! CK 20120913 OH is only used as scaling quantity, not returned to gas array +!! if (koh .ge. p1st) & +!! rsub(koh,k,m) = gas(iho)*conv1b if (ksmpbb .ge. p1st) & rsub(ksmpbb,k,m) = gas(ismpbb_g)*conv1b if (kant1_c .ge. p1st) & @@ -1909,6 +2085,27 @@ subroutine map_mosaic_species(k, m, imap) rsub(kbiog3_o,k,m) = gas(ibiog3_o_g)*conv1b if (kbiog4_o .ge. p1st) & rsub(kbiog4_o,k,m) = gas(ibiog4_o_g)*conv1b + if (kasoaX .ge. p1st) & + rsub(kasoaX,k,m) = gas(iasoaX_g)*conv1b + if (kasoa1 .ge. p1st) & + rsub(kasoa1,k,m) = gas(iasoa1_g)*conv1b + if (kasoa2 .ge. p1st) & + rsub(kasoa2,k,m) = gas(iasoa2_g)*conv1b + if (kasoa3 .ge. p1st) & + rsub(kasoa3,k,m) = gas(iasoa3_g)*conv1b + if (kasoa4 .ge. p1st) & + rsub(kasoa4,k,m) = gas(iasoa4_g)*conv1b + if (kbsoaX .ge. p1st) & + rsub(kbsoaX,k,m) = gas(ibsoaX_g)*conv1b + if (kbsoa1 .ge. p1st) & + rsub(kbsoa1,k,m) = gas(ibsoa1_g)*conv1b + if (kbsoa2 .ge. p1st) & + rsub(kbsoa2,k,m) = gas(ibsoa2_g)*conv1b + if (kbsoa3 .ge. p1st) & + rsub(kbsoa3,k,m) = gas(ibsoa3_g)*conv1b + if (kbsoa4 .ge. p1st) & + rsub(kbsoa4,k,m) = gas(ibsoa4_g)*conv1b + ! aerosol iphase = ai_phase ibin = 0 @@ -2095,6 +2292,16 @@ subroutine map_mosaic_species(k, m, imap) if (l .ge. p1st) rsub(l,k,m) = aer(ismpa_a,jtotal,ibin)*conv1b l = lptr_smpbb_aer(isize,itype,iphase) if (l .ge. p1st) rsub(l,k,m) = aer(ismpbb_a,jtotal,ibin)*conv1b + l = lptr_glysoa_r1_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(iglysoa_r1_a,jtotal,ibin)*conv1b + l = lptr_glysoa_r2_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(iglysoa_r2_a,jtotal,ibin)*conv1b + l = lptr_glysoa_sfc_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(iglysoa_sfc_a,jtotal,ibin)*conv1b + l = lptr_glysoa_nh4_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(iglysoa_nh4_a,jtotal,ibin)*conv1b + l = lptr_glysoa_oh_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(iglysoa_oh_a,jtotal,ibin)*conv1b l = lptr_ant1_c_aer(isize,itype,iphase) if (l .ge. p1st) rsub(l,k,m) = aer(iant1_c_a,jtotal,ibin)*conv1b @@ -2129,6 +2336,26 @@ subroutine map_mosaic_species(k, m, imap) l = lptr_biog4_o_aer(isize,itype,iphase) if (l .ge. p1st) rsub(l,k,m) = aer(ibiog4_o_a,jtotal,ibin)*conv1b + l = lptr_asoaX_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(iasoaX_a,jtotal,ibin)*conv1b + l = lptr_asoa1_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(iasoa1_a,jtotal,ibin)*conv1b + l = lptr_asoa2_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(iasoa2_a,jtotal,ibin)*conv1b + l = lptr_asoa3_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(iasoa3_a,jtotal,ibin)*conv1b + l = lptr_asoa4_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(iasoa4_a,jtotal,ibin)*conv1b + l = lptr_bsoaX_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ibsoaX_a,jtotal,ibin)*conv1b + l = lptr_bsoa1_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ibsoa1_a,jtotal,ibin)*conv1b + l = lptr_bsoa2_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ibsoa2_a,jtotal,ibin)*conv1b + l = lptr_bsoa3_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ibsoa3_a,jtotal,ibin)*conv1b + l = lptr_bsoa4_aer(isize,itype,iphase) + if (l .ge. p1st) rsub(l,k,m) = aer(ibsoa4_a,jtotal,ibin)*conv1b @@ -3068,6 +3295,11 @@ subroutine do_full_deliquescence(ibin) ! touch aer(iopcg8_f_o_a,jsolid,ibin)= aer(iopcg8_f_o_a,jtotal,ibin) aer(ismpa_a,jsolid,ibin)= aer(ismpa_a,jtotal,ibin) aer(ismpbb_a,jsolid,ibin)= aer(ismpbb_a,jtotal,ibin) + aer(iglysoa_r1_a,jsolid,ibin)= aer(iglysoa_r1_a,jtotal,ibin) + aer(iglysoa_r2_a,jsolid,ibin)= aer(iglysoa_r2_a,jtotal,ibin) + aer(iglysoa_sfc_a,jsolid,ibin)= aer(iglysoa_sfc_a,jtotal,ibin) + aer(iglysoa_nh4_a,jsolid,ibin)= aer(iglysoa_nh4_a,jtotal,ibin) + aer(iglysoa_oh_a,jsolid,ibin)= aer(iglysoa_oh_a,jtotal,ibin) aer(iant1_c_a,jsolid,ibin)= aer(iant1_c_a,jtotal,ibin) aer(iant2_c_a,jsolid,ibin)= aer(iant2_c_a,jtotal,ibin) aer(iant3_c_a,jsolid,ibin)= aer(iant3_c_a,jtotal,ibin) @@ -3084,6 +3316,16 @@ subroutine do_full_deliquescence(ibin) ! touch aer(ibiog2_o_a,jsolid,ibin)= aer(ibiog2_o_a,jtotal,ibin) aer(ibiog3_o_a,jsolid,ibin)= aer(ibiog3_o_a,jtotal,ibin) aer(ibiog4_o_a,jsolid,ibin)= aer(ibiog4_o_a,jtotal,ibin) + aer(iasoaX_a,jsolid,ibin)= aer(iasoaX_a,jtotal,ibin) + aer(iasoa1_a,jsolid,ibin)= aer(iasoa1_a,jtotal,ibin) + aer(iasoa2_a,jsolid,ibin)= aer(iasoa2_a,jtotal,ibin) + aer(iasoa3_a,jsolid,ibin)= aer(iasoa3_a,jtotal,ibin) + aer(iasoa4_a,jsolid,ibin)= aer(iasoa4_a,jtotal,ibin) + aer(ibsoaX_a,jsolid,ibin)= aer(ibsoaX_a,jtotal,ibin) + aer(ibsoa1_a,jsolid,ibin)= aer(ibsoa1_a,jtotal,ibin) + aer(ibsoa2_a,jsolid,ibin)= aer(ibsoa2_a,jtotal,ibin) + aer(ibsoa3_a,jsolid,ibin)= aer(ibsoa3_a,jtotal,ibin) + aer(ibsoa4_a,jsolid,ibin)= aer(ibsoa4_a,jtotal,ibin) ! liquid-phase aer(iso4_a,jliquid,ibin) = aer(iso4_a,jtotal,ibin) - & @@ -3169,6 +3411,11 @@ subroutine do_full_deliquescence(ibin) ! touch aer(iopcg8_f_o_a,jliquid,ibin)= 0.0 aer(ismpa_a,jliquid,ibin)= 0.0 aer(ismpbb_a,jliquid,ibin)= 0.0 + aer(iglysoa_r1_a,jliquid,ibin)= 0.0 + aer(iglysoa_r2_a,jliquid,ibin)= 0.0 + aer(iglysoa_sfc_a,jliquid,ibin)= 0.0 + aer(iglysoa_nh4_a,jliquid,ibin)= 0.0 + aer(iglysoa_oh_a,jliquid,ibin)= 0.0 aer(iant1_c_a,jliquid,ibin)= 0.0 aer(iant2_c_a,jliquid,ibin)= 0.0 aer(iant3_c_a,jliquid,ibin)= 0.0 @@ -3185,6 +3432,16 @@ subroutine do_full_deliquescence(ibin) ! touch aer(ibiog2_o_a,jliquid,ibin)= 0.0 aer(ibiog3_o_a,jliquid,ibin)= 0.0 aer(ibiog4_o_a,jliquid,ibin)= 0.0 + aer(iasoaX_a,jliquid,ibin)= 0.0 + aer(iasoa1_a,jliquid,ibin)= 0.0 + aer(iasoa2_a,jliquid,ibin)= 0.0 + aer(iasoa3_a,jliquid,ibin)= 0.0 + aer(iasoa4_a,jliquid,ibin)= 0.0 + aer(ibsoaX_a,jliquid,ibin)= 0.0 + aer(ibsoa1_a,jliquid,ibin)= 0.0 + aer(ibsoa2_a,jliquid,ibin)= 0.0 + aer(ibsoa3_a,jliquid,ibin)= 0.0 + aer(ibsoa4_a,jliquid,ibin)= 0.0 @@ -4510,6 +4767,11 @@ subroutine adjust_liquid_aerosol(ibin) aer(iopcg8_f_o_a,jsolid,ibin)= aer(iopcg8_f_o_a,jtotal,ibin) aer(ismpa_a,jsolid,ibin)= aer(ismpa_a,jtotal,ibin) aer(ismpbb_a,jsolid,ibin)= aer(ismpbb_a,jtotal,ibin) + aer(iglysoa_r1_a,jsolid,ibin)= aer(iglysoa_r1_a,jtotal,ibin) + aer(iglysoa_r2_a,jsolid,ibin)= aer(iglysoa_r2_a,jtotal,ibin) + aer(iglysoa_sfc_a,jsolid,ibin)= aer(iglysoa_sfc_a,jtotal,ibin) + aer(iglysoa_nh4_a,jsolid,ibin)= aer(iglysoa_nh4_a,jtotal,ibin) + aer(iglysoa_oh_a,jsolid,ibin)= aer(iglysoa_oh_a,jtotal,ibin) aer(iant1_c_a,jsolid,ibin)= aer(iant1_c_a,jtotal,ibin) aer(iant2_c_a,jsolid,ibin)= aer(iant2_c_a,jtotal,ibin) aer(iant3_c_a,jsolid,ibin)= aer(iant3_c_a,jtotal,ibin) @@ -4526,6 +4788,16 @@ subroutine adjust_liquid_aerosol(ibin) aer(ibiog2_o_a,jsolid,ibin)= aer(ibiog2_o_a,jtotal,ibin) aer(ibiog3_o_a,jsolid,ibin)= aer(ibiog3_o_a,jtotal,ibin) aer(ibiog4_o_a,jsolid,ibin)= aer(ibiog4_o_a,jtotal,ibin) + aer(iasoaX_a,jsolid,ibin)= aer(iasoaX_a,jtotal,ibin) + aer(iasoa1_a,jsolid,ibin)= aer(iasoa1_a,jtotal,ibin) + aer(iasoa2_a,jsolid,ibin)= aer(iasoa2_a,jtotal,ibin) + aer(iasoa3_a,jsolid,ibin)= aer(iasoa3_a,jtotal,ibin) + aer(iasoa4_a,jsolid,ibin)= aer(iasoa4_a,jtotal,ibin) + aer(ibsoaX_a,jsolid,ibin)= aer(ibsoaX_a,jtotal,ibin) + aer(ibsoa1_a,jsolid,ibin)= aer(ibsoa1_a,jtotal,ibin) + aer(ibsoa2_a,jsolid,ibin)= aer(ibsoa2_a,jtotal,ibin) + aer(ibsoa3_a,jsolid,ibin)= aer(ibsoa3_a,jtotal,ibin) + aer(ibsoa4_a,jsolid,ibin)= aer(ibsoa4_a,jtotal,ibin) @@ -4616,6 +4888,11 @@ subroutine adjust_liquid_aerosol(ibin) aer(iopcg8_f_o_a,jliquid,ibin)= 0.0 aer(ismpa_a,jliquid,ibin)= 0.0 aer(ismpbb_a,jliquid,ibin)= 0.0 + aer(iglysoa_r1_a,jliquid,ibin)= 0.0 + aer(iglysoa_r2_a,jliquid,ibin)= 0.0 + aer(iglysoa_sfc_a,jliquid,ibin)= 0.0 + aer(iglysoa_nh4_a,jliquid,ibin)= 0.0 + aer(iglysoa_oh_a,jliquid,ibin)= 0.0 aer(iant1_c_a,jliquid,ibin)= 0.0 aer(iant2_c_a,jliquid,ibin)= 0.0 aer(iant3_c_a,jliquid,ibin)= 0.0 @@ -4632,6 +4909,16 @@ subroutine adjust_liquid_aerosol(ibin) aer(ibiog2_o_a,jliquid,ibin)= 0.0 aer(ibiog3_o_a,jliquid,ibin)= 0.0 aer(ibiog4_o_a,jliquid,ibin)= 0.0 + aer(iasoaX_a,jliquid,ibin)= 0.0 + aer(iasoa1_a,jliquid,ibin)= 0.0 + aer(iasoa2_a,jliquid,ibin)= 0.0 + aer(iasoa3_a,jliquid,ibin)= 0.0 + aer(iasoa4_a,jliquid,ibin)= 0.0 + aer(ibsoaX_a,jliquid,ibin)= 0.0 + aer(ibsoa1_a,jliquid,ibin)= 0.0 + aer(ibsoa2_a,jliquid,ibin)= 0.0 + aer(ibsoa3_a,jliquid,ibin)= 0.0 + aer(ibsoa4_a,jliquid,ibin)= 0.0 @@ -4663,6 +4950,9 @@ end subroutine adjust_liquid_aerosol ! update: jan 2007 !----------------------------------------------------------------------- subroutine ASTEM(dtchem,vbs_nbin) + + USE module_mosaic_gly, only : glysoa_complex, glysoa_simple + ! implicit none ! include 'chemistry.com' ! include 'mosaic.h' @@ -4672,9 +4962,7 @@ subroutine ASTEM(dtchem,vbs_nbin) integer ibin real(kind=8) dumdum integer vbs_nbin(1) -! 20130807 acd_alma_bugfix start integer start_svoc, Nsoa -! 20130807 acd_alma_bugfix end ! logical first ! save first ! data first/.true./ @@ -4739,21 +5027,26 @@ subroutine ASTEM(dtchem,vbs_nbin) call ASTEM_semi_volatiles(dtchem) ! semi-implicit + explicit euler if (istat_mosaic_fe1 .lt. 0) return + if (glysoa_param == glysoa_param_simple) call glysoa_simple(dtchem) + if (glysoa_param == glysoa_param_complex) call glysoa_complex(dtchem) + ! condense secondary organic gases (8 sorgam species) if (istat_mosaic_fe1 .lt. 0) return -! 20130807 acd_alma_bugfix start start_svoc = 1 Nsoa = 0 ! simple version, Hodzic and Jimenez, GMD, 2011 if (vbs_nbin(1).eq.0) then start_svoc = ismpa_g - Nsoa = ngas_volatile-start_svoc + ! 4-bin version, Knote et al., ACPD, 2014 + else if (vbs_nbin(1).eq.4) then + start_svoc = iasoaX_g ! 9-bin version else start_svoc = ipcg1_b_c_g - Nsoa = ngas_volatile-start_svoc +! Nsoa = ngas_volatile-start_svoc end if + Nsoa = ngas_ioa + ngas_soa - start_svoc + 1 call equilibrium(start_svoc,Nsoa) @@ -4764,7 +5057,6 @@ subroutine ASTEM(dtchem,vbs_nbin) ! call equilibrium ! !Bend if ! -! 20130807 acd_alma_bugfix end ! template for error status checking ! if (iprint_mosaic_fe1 .gt. 0) then @@ -4870,14 +5162,10 @@ end subroutine print_mosaic_stats ! Calculates the equilibrium gas-particle partitioning for SOA species -! 20130807 acd_alma_bugfix start subroutine equilibrium(start_ind,N) ! subroutine equilibrium -! 20130807 acd_alma_bugfix end ! This routine was implemented by Manish Shrivastava on 12/24/2009 to do gas-particle partitioning of SOA assuming thermodynamic equilibrium. -! 20130807 acd_alma_bugfix start ! Modified by Alma Hodzic 12/2012 to implement the partitioning for mozart-mosaic species (based on the initial code implemented by Manish Shrivastava and originated from CAMx) -! 20130807 acd_alma_bugfix end ! This would give MOSAIC cpabilities of running both dynamic and equilibrium gas-particle partitioning ! Calls the subroutine soap. Subroutine soap calls subroutine spfcn ! use module_data_mosaic_main @@ -4885,10 +5173,8 @@ subroutine equilibrium(start_ind,N) implicit none real(kind=8), parameter :: tinys=1.0d-15 -! 20130807 acd_alma_bugfix start integer, intent(in) :: start_ind, N ! integer, parameter :: N=ngas_soa !Total number of soa species -! 20130807 acd_alma_bugfix end integer, parameter :: itermax=2000 integer idxfresh(N),idxaged(N) !counter for fresh and aged soa species real(kind=8) :: dq,frqfresh(nbin_a),frqaged(nbin_a) @@ -4933,7 +5219,6 @@ subroutine equilibrium(start_ind,N) ! Initialize flagsoap do i=1,N flagsoap(i)=1 -! 20130807 acd_alma_bugfix start Ctot(i) = 0.0 Ctotaged(i) = 0.0 Ctotfresh(i) = 0.0 @@ -4946,13 +5231,11 @@ subroutine equilibrium(start_ind,N) Csat(i) = 0.0 Csataged(i) = 0.0 Csatfresh(i) = 0.0 -! 20130807 acd_alma_bugfix end enddo -! 20130807 acd_alma_bugfix start ! Calculate Ctot and Paer ! do iv = ipcg1_b_c_g, ngas_volatile - do iv = start_ind, ngas_ioa + ngas_soa -! 20130807 acd_alma_bugfix end +! do iv = start_ind, ngas_ioa + ngas_soa + do iv = start_ind, (start_ind + N - 1) total_species(iv) = gas(iv) do ibin = 1, nbin_a total_species(iv) = total_species(iv) + aer(iv,jtotal,ibin) @@ -4964,7 +5247,6 @@ subroutine equilibrium(start_ind,N) cpxaged= cpxaged+aer(ioc_a,jp,ibin) enddo -! 20130807 acd_alma_bugfix start ! Maps arrays starting from start_ind or ipcg1_b_c_g on to corresponding arrays starting from 1 for just soa species do i=1,N Ctot(i)=total_species(start_ind+i-1) @@ -4981,7 +5263,6 @@ subroutine equilibrium(start_ind,N) ! Seperate the fresh and aged species and treat them as 2 different solutions. Note this approach differes from PMCAMx ! In PMCAMx if flagsoap(i) was set to zero those species were not considered solution forming. -! 20130807 acd_alma_bugfix start do i=1,N flagsoap(i)=1 ! Biomass burning(carbon and oxygen species) +traditional soa species enddo @@ -5014,7 +5295,6 @@ subroutine equilibrium(start_ind,N) ! do i=69,84 ! flagsoap(i)=1 !Oxidized fossil oxygen ! enddo -! 20130807 acd_alma_bugfix end do i=1,N if (flagsoap(i).eq.2) then ! fresh primary species forming 1 solution @@ -5078,8 +5358,8 @@ subroutine equilibrium(start_ind,N) xsumfresh(ibin)=0.0 xsumaged(ibin)=0.0 xsumaged(ibin)= xsumaged(ibin)+aer(ioc_a,jp,ibin)!Caluclate pre-existing primary in each bin for aged aerosol -! 20130807 acd_alma_bugfix start - do iv = start_ind, ngas_ioa + ngas_soa +! do iv = start_ind, ngas_ioa + ngas_soa + do iv = start_ind, (start_ind + N - 1) if (flagsoap(iv-start_ind+1).eq.2) then xsumfresh(ibin)= xsumfresh(ibin)+aer(iv,jtotal,ibin) elseif (flagsoap(iv-start_ind+1).eq.1) then @@ -5097,7 +5377,6 @@ subroutine equilibrium(start_ind,N) ! print *, 'Error in mapping flagsoap to ipcg1_b_c_g' ! endif ! enddo -! 20130807 acd_alma_bugfix end ! Give a small non-zero value to xsum if it is zero in the section if (xsumfresh(ibin).eq.0.0) xsumfresh(ibin)=tinys @@ -5107,14 +5386,13 @@ subroutine equilibrium(start_ind,N) ! Calculate dq as (gas concentration) G(t)-G(t+h): ! Caluclate driving force at previous time step (Cgas,i-XiCsati) for both fresh and aged solutions -! 20130807 acd_alma_bugfix start - do iv = start_ind, ngas_ioa + ngas_soa +! do iv = start_ind, ngas_ioa + ngas_soa + do iv = start_ind, (start_ind + N - 1) if (Ctot(iv-start_ind+1).lt.1d-10) goto 120 ! If a given species concentration is too low skip dq=gas(iv)-Cgas(iv-start_ind+1) !Since both fresh and aged species have been remapped to an array going from 1 to N ! do iv = ipcg1_b_c_g, ngas_volatile ! if (Ctot(iv-ipcg1_b_c_g+1).lt.1d-10) goto 120 ! If a given species concentration is too low skip ! dq=gas(iv)-Cgas(iv-ipcg1_b_c_g+1) !Since both fresh and aged species have been remapped to an array going from 1 to N -! 20130807 acd_alma_bugfix end frqtotfresh=0.0d0 frqtotaged=0.0d0 mnkfresh=0.0d0 @@ -5125,7 +5403,6 @@ subroutine equilibrium(start_ind,N) ! fraceq(iv,ibin) is calculated as the rate of mass transfer ! The weighting fractions frqfresh(ibin) amd frqaged(ibin) are caluclated assuming mole fractions from previous time step ! This assumtion could be relaxed by iterativetely solving this equation -! 20130807 acd_alma_bugfix start if (flagsoap(iv-start_ind+1).eq.2) then frqfresh(ibin)= kg(iv,ibin)*(gas(iv) & ! replaced fraceq(iv,ibin) by kg(iv,ibin) on 01/19/10 -(aer(iv,jtotal,ibin))/xsumfresh(ibin) & @@ -5149,18 +5426,15 @@ subroutine equilibrium(start_ind,N) ! -(aer(iv,jtotal,ibin))/xsumaged(ibin) & ! *Csat(iv-ipcg1_b_c_g+1)) ! endif -! 20130807 acd_alma_bugfix end mnkfresh=min(mnkfresh,frqfresh(ibin)) mnkaged=min(mnkaged,frqaged(ibin)) mxkfresh=max(mxkfresh,frqfresh(ibin)) mxkaged=max(mxkaged,frqaged(ibin)) enddo ! for ibin -! 20130807 acd_alma_bugfix start ! Repeat code from this point on for aged aerosol species if (flagsoap(iv-start_ind+1).eq.2) then ! if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then -! 20130807 acd_alma_bugfix end ! Condensation is favored in the next time step in this bin if(dq.gt.0.and.mnkfresh.lt.0.and.mxkfresh.gt.0) then do ibin=1,nbin_a @@ -5183,10 +5457,8 @@ subroutine equilibrium(start_ind,N) frqfresh(ibin)=frqfresh(ibin)/frqtotfresh enddo -! 20130807 acd_alma_bugfix start elseif(flagsoap(iv-start_ind+1).eq.1) then ! elseif(flagsoap(iv-ipcg1_b_c_g+1).eq.1) then -! 20130807 acd_alma_bugfix end if(dq.gt.0.and.mnkaged.lt.0.and.mxkaged.gt.0) then do ibin=1,nbin_a frqaged(ibin)=max(frqaged(ibin)-mnkaged,0.0d0) @@ -5209,7 +5481,6 @@ subroutine equilibrium(start_ind,N) ! Condense all condensing species if(dq.gt.0.0d0) then -! 20130807 acd_alma_bugfix start ! Map the species back into the original MOSAIC arrays do ibin=1,nbin_a if (flagsoap(iv-start_ind+1).eq.2) then @@ -5232,24 +5503,19 @@ subroutine equilibrium(start_ind,N) ! enddo !! Set the gas phase species to equilibrium value ! gas(iv)=Cgas(iv-ipcg1_b_c_g+1) -! 20130807 acd_alma_bugfix end ! Evaporate all evaporating species elseif(dq.lt.0.0d0) then iter=0 100 frt=1.0d0 do ibin=1,nbin_a -! 20130807 acd_alma_bugfix start if (flagsoap(iv-start_ind+1).eq.2) then ! if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then -! 20130807 acd_alma_bugfix end ! Cannot evaporate more than whats in the bin ie ratio (aer(iv,jtotal,ibin)/dq*frqfresh(ibin)) should be less than equal to 1 if(frqfresh(ibin).gt.0.0d0) & frt=MAX(MIN(aer(iv,jtotal,ibin)/abs(-dq*frqfresh(ibin)),frt),0.0d0) -! 20130807 acd_alma_bugfix start ! elseif(flagsoap(iv-ipcg1_b_c_g+1).eq.1) then elseif(flagsoap(iv-start_ind+1).eq.1) then -! 20130807 acd_alma_bugfix end if(frqaged(ibin).gt.0.0d0) & frt=MAX(MIN(aer(iv,jtotal,ibin)/abs(-dq*frqaged(ibin)),frt),0.0d0) endif ! for flagsoap @@ -5261,19 +5527,15 @@ subroutine equilibrium(start_ind,N) frqtotaged=0.0d0 do ibin=1,nbin_a -! 20130807 acd_alma_bugfix start if (flagsoap(iv-start_ind+1).eq.2) then ! if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then -! 20130807 acd_alma_bugfix end aer(iv,jtotal,ibin)= & ! Since dq is negative this is evaporating aerosols MAX(aer(iv,jtotal,ibin)+frt*dq*frqfresh(ibin),0.0d0) if(aer(iv,jtotal,ibin).lt.tinys) frqfresh(ibin)=0.0d0 frqtotfresh=frqtotfresh+frqfresh(ibin) -! 20130807 acd_alma_bugfix start ! elseif (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then elseif (flagsoap(iv-start_ind+1).eq.1) then -! 20130807 acd_alma_bugfix end aer(iv,jtotal,ibin)= & MAX(aer(iv,jtotal,ibin)+frt*dq*frqaged(ibin),0.0d0) if(aer(iv,jtotal,ibin).lt.tinys) frqaged(ibin)=0.0d0 @@ -5283,10 +5545,8 @@ subroutine equilibrium(start_ind,N) ! Check if we should evaporate more dq=(1.0d0-frt)*dq -! 20130807 acd_alma_bugfix start ! if (flagsoap(iv-ipcg1_b_c_g+1).eq.2) then if (flagsoap(iv-start_ind+1).eq.2) then -! 20130807 acd_alma_bugfix end if(dq.lt.-1.d-8) then ! check if d-8 is better if(frqtotfresh.gt.tinys) then ! we have sections which are not empty if(iter.le.itermax) then ! check infinite loop @@ -5298,10 +5558,8 @@ subroutine equilibrium(start_ind,N) endif ! for iter endif ! frqtotfresh.gt.tinys endif ! dq.lt.-1.d-7 -! 20130807 acd_alma_bugfix start ! elseif (flagsoap(iv-ipcg1_b_c_g+1).eq.1) then elseif (flagsoap(iv-start_ind+1).eq.1) then -! 20130807 acd_alma_bugfix end if(dq.lt.-1.d-8) then if(frqtotaged.gt.tinys) then ! we have sections which are not empty if(iter.le.itermax) then ! check infinite loop @@ -5320,10 +5578,8 @@ subroutine equilibrium(start_ind,N) endif ! for flagsoap ! now set the gas species concentration conservatively -! 20130807 acd_alma_bugfix start ! gas(iv)=Ctot(iv-ipcg1_b_c_g+1) gas(iv)=Ctot(iv-start_ind+1) -! 20130807 acd_alma_bugfix end do ibin=1,nbin_a gas(iv)=gas(iv)-aer(iv,jtotal,ibin) enddo @@ -5336,7 +5592,7 @@ end subroutine equilibrium !--------------------------------- -! Calculates the equilibrium gas-particle partitioning for SOA species when MOZART_MOSAIC_4BIN_VBS0_KPP is used +! Calculates the equilibrium gas-particle partitioning for SOA species when MOZART_MOSAIC_4BIN_KPP is used ! This routine was modified by Alma Hodzic based on the initial code implemented by Manish Shrivastava and originated from CAMx !++ alma - removed the subroutine equilibrium_smp @@ -7987,9 +8243,7 @@ subroutine aerosolmtc(vbs_nbin) ! include 'mosaic.h' ! local variables integer nghq,vbs_nbin(1) -! 20130618 acd_ck_vbsmoz start integer start_ind -! 20130618 acd_ck_vbsmoz end parameter (nghq = 2) ! gauss-hermite quadrature order integer ibin, iq, iv real(kind=8) tworootpi, root2, beta @@ -8086,6 +8340,8 @@ subroutine aerosolmtc(vbs_nbin) mw_vol(iopcg8_f_o_g)=250.0 mw_vol(ismpa_g)=250.0 mw_vol(ismpbb_g)=250.0 + mw_vol(igly)=58.0 + mw_vol(iho)=17.0 mw_vol(iant1_c_g)=250.0 mw_vol(iant2_c_g)=250.0 mw_vol(iant3_c_g)=250.0 @@ -8102,6 +8358,16 @@ subroutine aerosolmtc(vbs_nbin) mw_vol(ibiog2_o_g)=250.0 mw_vol(ibiog3_o_g)=250.0 mw_vol(ibiog4_o_g)=250.0 + mw_vol(iasoaX_g)=250.0 + mw_vol(iasoa1_g)=250.0 + mw_vol(iasoa2_g)=250.0 + mw_vol(iasoa3_g)=250.0 + mw_vol(iasoa4_g)=250.0 + mw_vol(ibsoaX_g)=250.0 + mw_vol(ibsoa1_g)=250.0 + mw_vol(ibsoa2_g)=250.0 + mw_vol(ibsoa3_g)=250.0 + mw_vol(ibsoa4_g)=250.0 @@ -8193,6 +8459,9 @@ subroutine aerosolmtc(vbs_nbin) accom(iopcg8_f_o_g)=0.1 accom(ismpa_g)=0.1 accom(ismpbb_g)=0.1 + ! added glyoxal, but only for completeness - is hopefully never used + accom(igly)=0.1 + accom(iho)=0.1 accom(iant1_c_g)=0.1 accom(iant2_c_g)=0.1 accom(iant3_c_g)=0.1 @@ -8209,6 +8478,16 @@ subroutine aerosolmtc(vbs_nbin) accom(ibiog2_o_g)=0.1 accom(ibiog3_o_g)=0.1 accom(ibiog4_o_g)=0.1 + accom(iasoaX_g)=0.1 + accom(iasoa1_g)=0.1 + accom(iasoa2_g)=0.1 + accom(iasoa3_g)=0.1 + accom(iasoa4_g)=0.1 + accom(ibsoaX_g)=0.1 + accom(ibsoa1_g)=0.1 + accom(ibsoa2_g)=0.1 + accom(ibsoa3_g)=0.1 + accom(ibsoa4_g)=0.1 @@ -8230,10 +8509,11 @@ subroutine aerosolmtc(vbs_nbin) enddo ! soa -! 20130618 acd_ck_vbsmoz start start_ind = 1 if(vbs_nbin(1) .eq. 0) then start_ind = ismpa_g + else if (vbs_nbin(1) .eq. 4) then + start_ind = iasoaX_g else start_ind = ipcg1_b_c_g end if @@ -8243,7 +8523,6 @@ subroutine aerosolmtc(vbs_nbin) dg(iv) = 0.1 ! cm^2/s (increased from 0.2 to 0.035 by Manish Shrivastava) freepath(iv) = 3.*dg(iv)/speed enddo -! 20130618 acd_ck_vbsmoz end ! het-rct gases ! DL 9/9/2011 do iv = (ngas_volatile+1), (ngas_volatile+ngas_het) @@ -8521,6 +8800,11 @@ subroutine calc_dry_n_wet_aerosol_props(ibin) comp_a(jopcg8_f_o)= aer(iopcg8_f_o_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) comp_a(jsmpa)= aer(ismpa_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) comp_a(jsmpbb)= aer(ismpbb_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jglysoa_r1)= aer(iglysoa_r1_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jglysoa_r2)= aer(iglysoa_r2_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jglysoa_sfc)= aer(iglysoa_sfc_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jglysoa_nh4)= aer(iglysoa_nh4_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jglysoa_oh)= aer(iglysoa_oh_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) comp_a(jant1_c)= aer(iant1_c_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) comp_a(jant2_c)= aer(iant2_c_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) comp_a(jant3_c)= aer(iant3_c_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) @@ -8537,6 +8821,16 @@ subroutine calc_dry_n_wet_aerosol_props(ibin) comp_a(jbiog2_o)= aer(ibiog2_o_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) comp_a(jbiog3_o)= aer(ibiog3_o_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) comp_a(jbiog4_o)= aer(ibiog4_o_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jasoaX)= aer(iasoaX_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jasoa1)= aer(iasoa1_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jasoa2)= aer(iasoa2_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jasoa3)= aer(iasoa3_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jasoa4)= aer(iasoa4_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jbsoaX)= aer(ibsoaX_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jbsoa1)= aer(ibsoa1_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jbsoa2)= aer(ibsoa2_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jbsoa3)= aer(ibsoa3_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) + comp_a(jbsoa4)= aer(ibsoa4_a,jtotal,ibin)*mw_comp_a(je)*1.e-15 ! g/cc(air) @@ -11650,8 +11944,26 @@ subroutine load_mosaic_parameters ibiog2_o_g =89 ibiog3_o_g =90 ibiog4_o_g =91 - in2o5_g =92 ! ioa --> NO3- - iclno2_g =93 ! ioa N2O5+Cl- --> +! in2o5_g =92 ! ioa --> NO3- +! iclno2_g =93 ! ioa N2O5+Cl- --> +! the order of species is ngas_ioa, then ngas_soa, then the rest... +! for the "equilibrium" routine i*_a and i*_g species +! have to have the same index. + iasoaX_g=92 + iasoa1_g=93 + iasoa2_g=94 + iasoa3_g=95 + iasoa4_g=96 + ibsoaX_g=97 + ibsoa1_g=98 + ibsoa2_g=99 + ibsoa3_g=100 + ibsoa4_g=101 + in2o5_g =102 ! ioa --> NO3- + iclno2_g =103 ! ioa N2O5+Cl- --> + + igly =104 + iho =105 ! ico2_g = 14 ! currently not used @@ -11748,12 +12060,36 @@ subroutine load_mosaic_parameters ibiog2_o_a =89 ibiog3_o_a =90 ibiog4_o_a =91 - ico3_a = 92 ! <-> ico2_g ! ico3_a was 14 earlier, changed to 82 by Manish Shrivastava - ina_a = 93 - ica_a = 94 - ioin_a = 95 - ioc_a = 96 - ibc_a = 97 +! for the "equilibrium" routine, +! i*_g and i*_a species have to have the same index... +! ico3_a = 92 ! <-> ico2_g ! ico3_a was 14 earlier, changed to 82 by Manish Shrivastava +! ina_a = 93 +! ica_a = 94 +! ioin_a = 95 +! ioc_a = 96 +! ibc_a = 97 + iasoaX_a=92 + iasoa1_a=93 + iasoa2_a=94 + iasoa3_a=95 + iasoa4_a=96 + ibsoaX_a=97 + ibsoa1_a=98 + ibsoa2_a=99 + ibsoa3_a=100 + ibsoa4_a=101 + iglysoa_r1_a = 102 + iglysoa_r2_a = 103 + iglysoa_sfc_a = 104 + iglysoa_nh4_a = 105 + iglysoa_oh_a = 106 + + ico3_a = 107 ! <-> ico2_g ! ico3_a was 14 earlier, changed to 82 by Manish Shrivastava + ina_a = 108 + ica_a = 109 + ioin_a = 110 + ioc_a = 111 + ibc_a = 112 ! electrolyte indices (used for water content calculations) ! these indices are order sensitive @@ -11869,7 +12205,23 @@ subroutine load_mosaic_parameters jbiog2_o =109 jbiog3_o =110 jbiog4_o =111 - jh2o = 112 ! water - part of naercomp +! jh2o = 112 ! water - part of naercomp + jasoaX=112 + jasoa1=113 + jasoa2=114 + jasoa3=115 + jasoa4=116 + jbsoaX=117 + jbsoa1=118 + jbsoa2=119 + jbsoa3=120 + jbsoa4=121 + jglysoa_r1 = 122 + jglysoa_r2 = 123 + jglysoa_sfc = 124 + jglysoa_nh4 = 125 + jglysoa_oh = 126 + jh2o = 127 ! water - part of naercomp ! local aerosol ions ! cations @@ -11975,6 +12327,11 @@ subroutine load_mosaic_parameters aer_name(iopcg8_f_o_a)="opcg8_f_o" aer_name(ismpa_a)="smpa" aer_name(ismpbb_a)="smpbb" + aer_name(iglysoa_r1_a)="glysoa_r1" + aer_name(iglysoa_r2_a)="glysoa_r2" + aer_name(iglysoa_sfc_a)="glysoa_sfc" + aer_name(iglysoa_nh4_a)="glysoa_nh4" + aer_name(iglysoa_oh_a)="glysoa_oh" aer_name(iant1_c_a)="ant1_c" aer_name(iant2_c_a)="ant2_c" aer_name(iant3_c_a)="ant3_c" @@ -11991,6 +12348,16 @@ subroutine load_mosaic_parameters aer_name(ibiog2_o_a)="biog2_o" aer_name(ibiog3_o_a)="biog3_o" aer_name(ibiog4_o_a)="biog4_o" + aer_name(iasoaX_a)="asoaX" + aer_name(iasoa1_a)="asoa1" + aer_name(iasoa2_a)="asoa2" + aer_name(iasoa3_a)="asoa3" + aer_name(iasoa4_a)="asoa4" + aer_name(ibsoaX_a)="bsoaX" + aer_name(ibsoa1_a)="bsoa1" + aer_name(ibsoa2_a)="bsoa2" + aer_name(ibsoa3_a)="bsoa3" + aer_name(ibsoa4_a)="bsoa4" ! names of gas species gas_name(ih2so4_g) = 'h2so4' @@ -12086,6 +12453,18 @@ subroutine load_mosaic_parameters gas_name(ibiog4_o_g)="biog4_o" gas_name(in2o5_g) = "n2o5 " gas_name(iclno2_g)= "clno2" + gas_name(iasoaX_g)="asoaX" + gas_name(iasoa1_g)="asoa1" + gas_name(iasoa2_g)="asoa2" + gas_name(iasoa3_g)="asoa3" + gas_name(iasoa4_g)="asoa4" + gas_name(ibsoaX_g)="bsoaX" + gas_name(ibsoa1_g)="bsoa1" + gas_name(ibsoa2_g)="bsoa2" + gas_name(ibsoa3_g)="bsoa3" + gas_name(ibsoa4_g)="bsoa4" + gas_name(igly)="gly" + gas_name(iho)="ho" ! names of electrolytes ename(jnh4so4) = 'amso4' @@ -12283,6 +12662,11 @@ subroutine load_mosaic_parameters dens_comp_a(iopcg8_f_o_a)=1.0 dens_comp_a(ismpa_a)=1.0 dens_comp_a(ismpbb_a)=1.0 + dens_comp_a(iglysoa_r1_a)=1.0 + dens_comp_a(iglysoa_r2_a)=1.0 + dens_comp_a(iglysoa_sfc_a)=1.0 + dens_comp_a(iglysoa_nh4_a)=1.0 + dens_comp_a(iglysoa_oh_a)=1.0 dens_comp_a(iant1_c_a)=1.0 dens_comp_a(iant2_c_a)=1.0 dens_comp_a(iant3_c_a)=1.0 @@ -12299,6 +12683,16 @@ subroutine load_mosaic_parameters dens_comp_a(ibiog2_o_a)=1.0 dens_comp_a(ibiog3_o_a)=1.0 dens_comp_a(ibiog4_o_a)=1.0 + dens_comp_a(iasoaX_a)=1.5 + dens_comp_a(iasoa1_a)=1.5 + dens_comp_a(iasoa2_a)=1.5 + dens_comp_a(iasoa3_a)=1.5 + dens_comp_a(iasoa4_a)=1.5 + dens_comp_a(ibsoaX_a)=1.5 + dens_comp_a(ibsoa1_a)=1.5 + dens_comp_a(ibsoa2_a)=1.5 + dens_comp_a(ibsoa3_a)=1.5 + dens_comp_a(ibsoa4_a)=1.5 ! molecular weights of generic aerosol species mw_aer_mac(iso4_a) = 96.0 @@ -12382,6 +12776,11 @@ subroutine load_mosaic_parameters mw_aer_mac(iopcg8_f_o_a)=250.0 mw_aer_mac(ismpa_a) = 250.0 mw_aer_mac(ismpbb_a) = 250.0 + mw_aer_mac(iglysoa_r1_a) = 250.0 + mw_aer_mac(iglysoa_r2_a) = 250.0 + mw_aer_mac(iglysoa_sfc_a) = 250.0 + mw_aer_mac(iglysoa_nh4_a) = 250.0 + mw_aer_mac(iglysoa_oh_a) = 250.0 mw_aer_mac(iant1_c_a) = 250.0 mw_aer_mac(iant2_c_a) = 250.0 mw_aer_mac(iant3_c_a) = 250.0 @@ -12398,6 +12797,16 @@ subroutine load_mosaic_parameters mw_aer_mac(ibiog2_o_a) = 250.0 mw_aer_mac(ibiog3_o_a) = 250.0 mw_aer_mac(ibiog4_o_a) = 250.0 + mw_aer_mac(iasoaX_a) = 250.0 + mw_aer_mac(iasoa1_a) = 250.0 + mw_aer_mac(iasoa2_a) = 250.0 + mw_aer_mac(iasoa3_a) = 250.0 + mw_aer_mac(iasoa4_a) = 250.0 + mw_aer_mac(ibsoaX_a) = 250.0 + mw_aer_mac(ibsoa1_a) = 250.0 + mw_aer_mac(ibsoa2_a) = 250.0 + mw_aer_mac(ibsoa3_a) = 250.0 + mw_aer_mac(ibsoa4_a) = 250.0 ! molecular weights of compounds @@ -12497,6 +12906,11 @@ subroutine load_mosaic_parameters mw_comp_a(jopcg8_f_o)=250.0 mw_comp_a(jsmpa)=250.0 mw_comp_a(jsmpbb)=250.0 + mw_comp_a(jglysoa_r1)=250.0 + mw_comp_a(jglysoa_r2)=250.0 + mw_comp_a(jglysoa_sfc)=250.0 + mw_comp_a(jglysoa_nh4)=250.0 + mw_comp_a(jglysoa_oh)=250.0 mw_comp_a(jant1_c)=250.0 mw_comp_a(jant2_c)=250.0 mw_comp_a(jant3_c)=250.0 @@ -12513,6 +12927,16 @@ subroutine load_mosaic_parameters mw_comp_a(jbiog2_o)=250.0 mw_comp_a(jbiog3_o)=250.0 mw_comp_a(jbiog4_o)=250.0 + mw_comp_a(jasoaX)=250.0 + mw_comp_a(jasoa1)=250.0 + mw_comp_a(jasoa2)=250.0 + mw_comp_a(jasoa3)=250.0 + mw_comp_a(jasoa4)=250.0 + mw_comp_a(jbsoaX)=250.0 + mw_comp_a(jbsoa1)=250.0 + mw_comp_a(jbsoa2)=250.0 + mw_comp_a(jbsoa3)=250.0 + mw_comp_a(jbsoa4)=250.0 ! densities of generic aerosol species dens_aer_mac(iso4_a) = 1.8 ! used @@ -12596,6 +13020,11 @@ subroutine load_mosaic_parameters dens_aer_mac(iopcg8_f_o_a)=1.0 dens_aer_mac(ismpa_a)=1.0 dens_aer_mac(ismpbb_a)=1.0 + dens_aer_mac(iglysoa_r1_a)=1.0 + dens_aer_mac(iglysoa_r2_a)=1.0 + dens_aer_mac(iglysoa_sfc_a)=1.0 + dens_aer_mac(iglysoa_nh4_a)=1.0 + dens_aer_mac(iglysoa_oh_a)=1.0 dens_aer_mac(iant1_c_a)=1.0 dens_aer_mac(iant2_c_a)=1.0 dens_aer_mac(iant3_c_a)=1.0 @@ -12612,6 +13041,16 @@ subroutine load_mosaic_parameters dens_aer_mac(ibiog2_o_a)=1.0 dens_aer_mac(ibiog3_o_a)=1.0 dens_aer_mac(ibiog4_o_a)=1.0 + dens_aer_mac(iasoaX_a)=1.5 + dens_aer_mac(iasoa1_a)=1.5 + dens_aer_mac(iasoa2_a)=1.5 + dens_aer_mac(iasoa3_a)=1.5 + dens_aer_mac(iasoa4_a)=1.5 + dens_aer_mac(ibsoaX_a)=1.5 + dens_aer_mac(ibsoa1_a)=1.5 + dens_aer_mac(ibsoa2_a)=1.5 + dens_aer_mac(ibsoa3_a)=1.5 + dens_aer_mac(ibsoa4_a)=1.5 ! partial molar volumes of condensing species partial_molar_vol(ih2so4_g) = 51.83 @@ -12707,6 +13146,18 @@ subroutine load_mosaic_parameters partial_molar_vol(ibiog4_o_g)=250.0 partial_molar_vol(in2o5_g) = 200.0 ! assumed... partial_molar_vol(iclno2_g) = 200.0 ! assumed... + partial_molar_vol(iasoaX_g)=250.0 + partial_molar_vol(iasoa1_g)=250.0 + partial_molar_vol(iasoa2_g)=250.0 + partial_molar_vol(iasoa3_g)=250.0 + partial_molar_vol(iasoa4_g)=250.0 + partial_molar_vol(ibsoaX_g)=250.0 + partial_molar_vol(ibsoa1_g)=250.0 + partial_molar_vol(ibsoa2_g)=250.0 + partial_molar_vol(ibsoa3_g)=250.0 + partial_molar_vol(ibsoa4_g)=250.0 + partial_molar_vol(igly)=58.0 + partial_molar_vol(iho)=17.0 ! refractive index ref_index_a(jnh4so4) = cmplx(1.52,0.) @@ -15191,9 +15642,7 @@ subroutine update_thermodynamic_constants(vbs_nbin) ! include 'mosaic.h' ! local variables integer iv, j_index, ibin, je,vbs_nbin(1) -! 20130816 acd_ck_vbsmoz start integer start_ind -! 20130816 acd_ck_vbsmoz end real(kind=8) :: tr, rt, term real(kind=8) :: gam_nh4no3_0, gam_nh4cl_0, m_nh4no3_0, m_nh4cl_0 ! raz update 6/25/2008 ! function @@ -15242,10 +15691,11 @@ subroutine update_thermodynamic_constants(vbs_nbin) keq_sl(jcano3) = fn_keq(4.31d5, 7.83d0,42.01d0, t_k)*1.e5 ! ca(no3)2(s) = ca++ + 2no3- keq_sl(jcamsa2) = 1.e15 ! CaMSA2(s)= Ca+ + 2MSA- -! 20130816 acd_ck_vbsmoz start start_ind = 1 if (vbs_nbin(1).eq.0) then start_ind = ismpa_g + else if (vbs_nbin(1) .eq. 4) then + start_ind = iasoaX_g else start_ind = ipcg1_b_c_g endif @@ -15253,7 +15703,6 @@ subroutine update_thermodynamic_constants(vbs_nbin) do iv = start_ind, ngas_ioa + ngas_soa sat_soa(iv) = 0.0 ! [nmol/m^3(air)] enddo -! 20130816 acd_ck_vbsmoz end if (vbs_nbin(1).eq.9) then ! vapor pressures of soa species @@ -15344,6 +15793,19 @@ subroutine update_thermodynamic_constants(vbs_nbin) po_soa(ibiog4_o_g) = fn_po(9.91d-3, 82.0d0, T_K) ! [Pascal] endif + if (vbs_nbin(1).eq.4) then + po_soa(iasoaX_g) = fn_po(9.91d-10, 40.0d0, T_K) ! [Pascal] + po_soa(iasoa1_g) = fn_po(9.91d-6, dhr_approx(0.0d0), T_K) ! [Pascal] + po_soa(iasoa2_g) = fn_po(9.91d-5, dhr_approx(1.0d0), T_K) ! [Pascal] + po_soa(iasoa3_g) = fn_po(9.91d-4, dhr_approx(2.0d0), T_K) ! [Pascal] + po_soa(iasoa4_g) = fn_po(9.91d-3, dhr_approx(3.0d0), T_K) ! [Pascal] + po_soa(ibsoaX_g) = fn_po(9.91d-10, 40.0d0, T_K) ! [Pascal] + po_soa(ibsoa1_g) = fn_po(9.91d-6, dhr_approx(0.0d0), T_K) ! [Pascal] + po_soa(ibsoa2_g) = fn_po(9.91d-5, dhr_approx(1.0d0), T_K) ! [Pascal] + po_soa(ibsoa3_g) = fn_po(9.91d-4, dhr_approx(2.0d0), T_K) ! [Pascal] + po_soa(ibsoa4_g) = fn_po(9.91d-3, dhr_approx(3.0d0), T_K) ! [Pascal] + endif + if (vbs_nbin(1).eq.2) then po_soa(ipcg1_b_c_g) = fn_po(9.91d-8, 83.0d0, T_K) ! [Pascal] po_soa(ipcg2_b_c_g) = fn_po(9.91d-1, 83.0d0, T_K) ! [Pascal] @@ -15369,10 +15831,11 @@ subroutine update_thermodynamic_constants(vbs_nbin) po_soa(ibiog1_o_g) = fn_po(9.91d-6, 83.0d0, T_K) ! [Pascal] endif -! 20130716 acd_ck_vbsmoz start start_ind = 1 if (vbs_nbin(1).eq.0) then start_ind = ismpa_g + else if (vbs_nbin(1).eq.4) then + start_ind = iasoaX_g else start_ind = ipcg1_b_c_g end if @@ -15380,7 +15843,6 @@ subroutine update_thermodynamic_constants(vbs_nbin) do iv = start_ind, ngas_ioa + ngas_soa sat_soa(iv) = 1.e9*po_soa(iv)/(8.314*t_k) ! [nmol/m^3(air)] enddo -! 20130716 acd_ck_vbsmoz end ! water surface tension term = (647.15 - t_k)/647.15 @@ -15416,6 +15878,17 @@ subroutine update_thermodynamic_constants(vbs_nbin) return end subroutine update_thermodynamic_constants + ! Function to approximate enthalpy of vaporization for + ! semi-volatile organic aerosols as a function of volatility + ! from Epstein et al., ES&T, 2010 + ! http://pubs.acs.org/doi/abs/10.1021/es902497z + real(kind=8) function dhr_approx(log10_Csat_298) + + real(kind=8), intent(in) :: log10_Csat_298 + + dhr_approx = -11.0 * log10_Csat_298 + 131.0 ! kJ/mol + + end function dhr_approx diff --git a/wrfv2_fire/chem/module_mosaic_wetscav.F b/wrfv2_fire/chem/module_mosaic_wetscav.F index 5d46b150..0afa3434 100644 --- a/wrfv2_fire/chem/module_mosaic_wetscav.F +++ b/wrfv2_fire/chem/module_mosaic_wetscav.F @@ -74,6 +74,76 @@ subroutine wetscav_cbmz_mosaic (id,ktau,dtstep,ktauc,config_flags, & end subroutine wetscav_cbmz_mosaic +!=========================================================================== +!=========================================================================== + subroutine wetscav_mozart_mosaic (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg,qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! wet removal by grid-resolved precipitation +! scavenging of cloud-phase aerosols and gases by collection, freezing, ... +! scavenging of interstitial-phase aerosols by impaction +! scavenging of gas-phase gases by mass transfer and reaction + +!---------------------------------------------------------------------- + USE module_configure, only: grid_config_rec_type + USE module_state_description + USE module_data_mosaic_asect + +!---------------------------------------------------------------------- + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + id, ktau, ktauc, numgas_aqfrac + REAL, INTENT(IN ) :: dtstep,dtstepc +! +! all advected chemical species +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! fraction of gas species in cloud water + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), & + INTENT(IN ) :: gas_aqfrac + +! +! +! input from meteorology + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t_phy, & + p_phy, & + t8w,p8w, & + qlsink,precr,preci,precs,precg, & + rho_phy,cldfra + REAL, DIMENSION( ims:ime, jms:jme, num_chem ), & + INTENT(OUT ) :: qsrflx ! column change due to scavening + + call wetscav (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg,qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ntype_aer, nsize_aer, ncomp_aer, & + massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, & + volumcen_sect, volumlo_sect, volumhi_sect, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd, dlndg_nimptblgrow, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + end subroutine wetscav_mozart_mosaic !=========================================================================== !=========================================================================== @@ -223,6 +293,8 @@ subroutine wetscav (id,ktau,dtstep,ktauc,config_flags, & ! scavenging of gases in cloud-water +! only if not MOZART (--> Neu and Prather used) + if ( .NOT. (config_flags%chem_opt == mozart_mosaic_4bin_aq_kpp) ) then do 290 l = param_first_scalar, min( num_chem, numgas_aqfrac ) if ( is_aerosol(l) ) goto 290 do 270 j = jts,jte @@ -238,6 +310,7 @@ subroutine wetscav (id,ktau,dtstep,ktauc,config_flags, & end if 270 continue 290 continue + end if ! below-cloud scavenging @@ -375,11 +448,14 @@ subroutine wetscav (id,ktau,dtstep,ktauc,config_flags, & isprx, fapx, pfx, pfx_inrain, & dqdt, dotend, qsrflx ) +! only if not MOZART (--> Neu and Prather used) + if ( .NOT. (config_flags%chem_opt == mozart_mosaic_4bin_aq_kpp) ) then call gasrainscav (ims,ime,kms,kme,jms,jme,its,ite,kts,kte,jts,jte, num_chem, & config_flags, & dtstepc, t_phy, p_phy, pdel, chem, & isprx, fapx, pfx, pfx_inrain, & dqdt, dotend, qsrflx ) + end if ! update chem diff --git a/wrfv2_fire/chem/module_mozcart_wetscav.F b/wrfv2_fire/chem/module_mozcart_wetscav.F index b8593f80..6bab3008 100644 --- a/wrfv2_fire/chem/module_mozcart_wetscav.F +++ b/wrfv2_fire/chem/module_mozcart_wetscav.F @@ -12,7 +12,9 @@ MODULE module_mozcart_wetscav save - integer, parameter :: wetscav_tab_cnt = 37 +! added OVOC washout +! integer, parameter :: wetscav_tab_cnt = 37 + integer, parameter :: wetscav_tab_cnt = 37 + 10 real, parameter :: zero = 0. real, parameter :: one = 1. real, parameter :: four = 4. @@ -78,9 +80,10 @@ subroutine wetscav_mozcart_init( id, numgas, config_flags ) call wrf_error_fatal("mozcart_wetscav_init: failed to allocate wet_scav_tab") endif -!---------------------------------------------------------------------- -! NOTE: this table does NOT include an entry for SO4 -!---------------------------------------------------------------------- +! not true anymore, comment can be removed +!!---------------------------------------------------------------------- +!! NOTE: this table does NOT include an entry for SO4 +!!---------------------------------------------------------------------- wet_scav_tab(1) = wet_scav( 'h2o2', p_h2o2, (/8.33e+04, 7379., 2.2e-12, -3730., 0., 0./), 34.0135994, .false. ) wet_scav_tab(2) = wet_scav( 'hno3', p_hno3, (/0., 0., 2.6e+06, 8700., 0., 0./), 63.0123405, .true. ) wet_scav_tab(3) = wet_scav( 'hcho', p_hcho, (/6.30e+03, 6425., 0., 0., 0., 0./), 30.0251999, .false. ) @@ -116,9 +119,22 @@ subroutine wetscav_mozcart_init( id, numgas, config_flags ) wet_scav_tab(33) = wet_scav( 'xonitr', -1, (/7.51e+03, 6485., 0., 0., 0., 0./), 147.125946, .false. ) wet_scav_tab(34) = wet_scav( 'xooh', p_xooh, (/90.5, 5607., 0., 0., 0., 0./), 134.126602, .false. ) wet_scav_tab(35) = wet_scav( 'ch3cooh', p_ch3cooh, (/4.1e3, 6300., 0., 0., 0., 0./), 60.0503998, .false. ) - wet_scav_tab(36) = wet_scav( 'so2', p_so2, (/8.33e+04, 7379., 2.2e-12, -3730., 0., 0./), 34.0135994, .false. ) - wet_scav_tab(37) = wet_scav( 'h2so4', p_h2so4, (/0., 0., 2.6e+06, 8700., 0., 0./), 98.0784, .false. ) - + wet_scav_tab(36) = wet_scav( 'so2', p_so2, (/1.2, 3100., 1.3e-02, 1965., 0., 0./), 63.961901, .false. ) + wet_scav_tab(37) = wet_scav( 'sulf', p_sulf, (/1e+11, 0., 0., 0., 0., 0./), 98.078, .false. ) ! order of magnitude approx. (Gmitro and Vermeulen, 1964) + + IF (config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) THEN + wet_scav_tab(38) = wet_scav( 'cvasoaX', p_cvasoaX, (/0.0e+00, 0., 0., 0., 0., 0./), 150.0, .false. ) + wet_scav_tab(39) = wet_scav( 'cvasoa1', p_cvasoa1, (/1.06E+08, 6014., 0., 0., 0., 0./), 150.0, .false. ) + wet_scav_tab(40) = wet_scav( 'cvasoa2', p_cvasoa2, (/1.84E+07, 6014., 0., 0., 0., 0./), 150.0, .false. ) + wet_scav_tab(41) = wet_scav( 'cvasoa3', p_cvasoa3, (/3.18E+06, 6014., 0., 0., 0., 0./), 150.0, .false. ) + wet_scav_tab(42) = wet_scav( 'cvasoa4', p_cvasoa4, (/5.50E+05, 6014., 0., 0., 0., 0./), 150.0, .false. ) + wet_scav_tab(43) = wet_scav( 'cvbsoaX', p_cvbsoaX, (/0.0e+00, 0., 0., 0., 0., 0./), 180.0, .false. ) + wet_scav_tab(44) = wet_scav( 'cvbsoa1', p_cvbsoa1, (/5.25E+09, 6014., 0., 0., 0., 0./), 180.0, .false. ) + wet_scav_tab(45) = wet_scav( 'cvbsoa2', p_cvbsoa2, (/7.00E+08, 6014., 0., 0., 0., 0./), 180.0, .false. ) + wet_scav_tab(46) = wet_scav( 'cvbsoa3', p_cvbsoa3, (/9.33E+07, 6014., 0., 0., 0., 0./), 180.0, .false. ) + wet_scav_tab(47) = wet_scav( 'cvbsoa4', p_cvbsoa4, (/1.24E+07, 6014., 0., 0., 0., 0./), 180.0, .false. ) + ENDIF + hetcnt = 0 do m = param_first_scalar,numgas wrf_spc_name = chem_dname_table(id,m) @@ -183,7 +199,8 @@ subroutine wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, qv_b4mp, qc_b4mp, qi_b4mp, qs_b4mp, & gas_aqfrac, numgas_aqfrac, dz8w, dx, dy, & qv, qc, qi, qs, & - hno3_col_mdel, & +! hno3_col_mdel, & + delta_mass_col, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -243,8 +260,11 @@ subroutine wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & INTENT(INOUT ) :: cldfra - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(INOUT ) :: hno3_col_mdel +! REAL, DIMENSION( ims:ime , jms:jme ) , & +! INTENT(INOUT ) :: hno3_col_mdel + + REAL, DIMENSION( ims:ime , jms:jme, num_chem ) , & + INTENT(OUT ) :: delta_mass_col !---------------------------------------------------------------------- ! local variables @@ -306,7 +326,8 @@ subroutine wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, diff(:,:,:) = 0. cld_col_cnt = 0 precip_col_cnt = 0 - hno3_col_mdel(:,:) = 0. +! hno3_col_mdel(:,:) = 0. + delta_mass_col(:,:,:) = 0. max_rls = 0. jloop : & do j = jts,jte @@ -395,9 +416,11 @@ subroutine wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, m1 = wrf2tab(m) pndx = wet_scav_tab(m1)%p_ndx is_hno3 = pndx == p_hno3 - if( is_hno3 ) then - hno3_col_mdel(i,j) = sum( trc_mass(kts:ktem1,m) ) - wrk_mass(m) - endif +! if( is_hno3 ) then +! hno3_col_mdel(i,j) = sum( trc_mass(kts:ktem1,m) ) - wrk_mass(m) +! endif + delta_mass_col(i,j,pndx) = sum( trc_mass(kts:ktem1,m) ) - wrk_mass(m) + wrk(kts:ktem1) = 1.e6*mwdry*trc_mass(kts:ktem1,m)/mol_wght(m) chem(i,kts:ktem1,j,pndx) = wrk(kts:ktem1)/layer_mass(kts:ktem1) if( is_hno3 ) then diff --git a/wrfv2_fire/chem/module_optical_averaging.F b/wrfv2_fire/chem/module_optical_averaging.F index 15bb1e58..e8ff7332 100644 --- a/wrfv2_fire/chem/module_optical_averaging.F +++ b/wrfv2_fire/chem/module_optical_averaging.F @@ -112,6 +112,7 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & tauaersw,extaersw,gaersw,waersw,bscoefsw, & l2aer,l3aer,l4aer,l5aer,l6aer,l7aer, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & tauaerlw,extaerlw, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -139,7 +140,8 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(IN ) :: relhum,dz8w, alt, h2oai, h2oaj, & - totoa_a01, totoa_a02, totoa_a03, totoa_a04 + totoa_a01, totoa_a02, totoa_a03, totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08 integer nspint parameter ( nspint = 4 ) ! number of spectral interval shortwave bands @@ -225,9 +227,20 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & RACM_SOA_VBS_KPP, & RACM_ESRLSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP, & - CBMZSORG, CBMZSORG_AQ ) + CBMZSORG, CBMZSORG_AQ, & + CB05_SORG_AQ_KPP) call optical_prep_modal(nbin_o, chem, alt, & ! h2oai, h2oaj, refindx, radius_wet, number_bin, & +! radius_core, refindx_core, refindx_shell, & + h2oai, h2oaj, radius_core,radius_wet, number_bin, & + swrefindx,swrefindx_core, swrefindx_shell, & + lwrefindx,lwrefindx_core, lwrefindx_shell, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CASE (CB05_SORG_VBS_AQ_KPP) + call optical_prep_modal_vbs(nbin_o, chem, alt, & +! h2oai, h2oaj, refindx, radius_wet, number_bin, & ! radius_core, refindx_core, refindx_shell, & h2oai, h2oaj, radius_core,radius_wet, number_bin, & swrefindx,swrefindx_core, swrefindx_shell, & @@ -250,11 +263,13 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & - MOZART_MOSAIC_4BIN_VBS0_KPP,CRI_MOSAIC_8BIN_AQ_KPP, & - CRI_MOSAIC_4BIN_AQ_KPP ) + SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + MOZART_MOSAIC_4BIN_KPP,MOZART_MOSAIC_4BIN_AQ_KPP, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_KPP)!BSINGH(12/05/2013): Added for SAPRC 8 bin vbs and non-aq on (04/07/2014) call optical_prep_sectional(nbin_o, chem, alt, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & ! refindx, radius_wet, number_bin, & ! radius_core, refindx_core, refindx_shell, & radius_core, radius_wet, number_bin, & @@ -263,7 +278,7 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (GOCART_SIMPLE, GOCARTRACM_KPP, GOCARTRADM2_KPP, GOCARTRADM2, & + CASE (GOCART_SIMPLE, GOCARTRACM_KPP, GOCARTRADM2, & MOZCART_KPP ) call optical_prep_gocart(nbin_o, chem, alt,relhum, & radius_core,radius_wet, number_bin, & @@ -509,6 +524,7 @@ end subroutine optical_averaging ! subroutine optical_prep_sectional(nbin_o, chem, alt, & totoa_a01, totoa_a02, totoa_a03, totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & ! refindx, radius_wet, number_bin, & ! radius_core, refindx_core, refindx_shell, & radius_core,radius_wet, number_bin, & @@ -533,7 +549,8 @@ subroutine optical_prep_sectional(nbin_o, chem, alt, & INTENT(IN ) :: chem REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(IN ) :: alt, & - totoa_a01, totoa_a02, totoa_a03, totoa_a04 + totoa_a01, totoa_a02, totoa_a03, totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08 REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & INTENT(OUT ) :: & radius_wet, number_bin, radius_core @@ -783,6 +800,10 @@ subroutine optical_prep_sectional(nbin_o, chem, alt, & if (totoa_a02(i,k,j) .gt. 1.0e-12 .and. isize .eq. 2) mass_oc=totoa_a02(i,k,j)*conv1a if (totoa_a03(i,k,j) .gt. 1.0e-12 .and. isize .eq. 3) mass_oc=totoa_a03(i,k,j)*conv1a if (totoa_a04(i,k,j) .gt. 1.0e-12 .and. isize .eq. 4) mass_oc=totoa_a04(i,k,j)*conv1a + if (totoa_a05(i,k,j) .gt. 1.0e-12 .and. isize .eq. 5) mass_oc=totoa_a05(i,k,j)*conv1a + if (totoa_a06(i,k,j) .gt. 1.0e-12 .and. isize .eq. 6) mass_oc=totoa_a06(i,k,j)*conv1a + if (totoa_a07(i,k,j) .gt. 1.0e-12 .and. isize .eq. 7) mass_oc=totoa_a07(i,k,j)*conv1a + if (totoa_a08(i,k,j) .gt. 1.0e-12 .and. isize .eq. 8) mass_oc=totoa_a08(i,k,j)*conv1a ! l=lptr_bc_aer(isize,itype,iphase) if (l .ge. p1st) mass_bc= chem(i,k,j,l)*conv1a @@ -1431,19 +1452,19 @@ subroutine optical_prep_modal(nbin_o, chem, alt, & ! * sect02 expects input in um ! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins ! - ss1=alog(sginin) + ss1=log(sginin) ss2=exp(ss1*ss1*36.0/8.0) ss3=(sixpi*vol_ai/(num_ai*ss2))**0.3333333 dgnum_um=amax1(dgmin,ss3)*1.0e+04 call sect02(dgnum_um,sginin,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & xnum_secti,xmas_secti) - ss1=alog(sginia) + ss1=log(sginia) ss2=exp(ss1*ss1*36.0/8.0) ss3=(sixpi*vol_aj/(num_aj*ss2))**0.3333333 dgnum_um=amax1(dgmin,ss3)*1.0e+04 call sect02(dgnum_um,sginia,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & xnum_sectj,xmas_sectj) - ss1=alog(sginic) + ss1=log(sginic) ss2=exp(ss1*ss1*36.0/8.0) ss3=(sixpi*vol_ac/(num_ac*ss2))**0.3333333 dgnum_um=amax1(dgmin,ss3)*1.0e+04 @@ -1646,6 +1667,657 @@ subroutine optical_prep_modal(nbin_o, chem, alt, & end subroutine optical_prep_modal +!---------------------------------------------------------------------------------- +! This subroutine computes volume-averaged refractive index and wet radius needed +! by the mie calculations. Aerosol number is also passed into the mie calculations +! in terms of other units. +! + subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & +! h2oai, h2oaj, refindx, radius_wet, number_bin, & +! radius_core, refindx_core, refindx_shell, & + h2oai, h2oaj, radius_core,radius_wet, number_bin, & + swrefindx, swrefindx_core, swrefindx_shell, & + lwrefindx, lwrefindx_core, lwrefindx_shell, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! + USE module_configure +! USE module_state_description + USE module_model_constants + USE module_state_description, only: param_first_scalar + USE module_data_sorgam_vbs +! + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte, nbin_o + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: alt, h2oai, h2oaj + REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & + INTENT(OUT ) :: & + radius_wet, number_bin, radius_core +! COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & +! INTENT(OUT ) :: & +! refindx, refindx_core, refindx_shell + COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nswbands), & + INTENT(OUT ) :: swrefindx, swrefindx_core, swrefindx_shell + COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nlwbands), & + INTENT(OUT ) :: lwrefindx, lwrefindx_core, lwrefindx_shell +! +! local variables +! + integer i, j, k, l, isize, itype, iphase + integer p1st + complex ref_index_lvcite , ref_index_nh4hso4, & + ref_index_nh4msa , ref_index_nh4no3 , ref_index_nh4cl , & + ref_index_nano3 , ref_index_na2so4, & + ref_index_na3hso4, ref_index_nahso4 , ref_index_namsa, & + ref_index_caso4 , ref_index_camsa2 , ref_index_cano3, & + ref_index_cacl2 , ref_index_caco3 , ref_index_h2so4, & + ref_index_hhso4 , ref_index_hno3 , ref_index_hcl, & + ref_index_msa , ref_index_bc, & + ref_index_oin , ref_index_aro1 , ref_index_aro2, & + ref_index_alk1 , ref_index_ole1 , ref_index_api1, & + ref_index_api2 , ref_index_lim1 , ref_index_lim2, & + ri_dum , ri_ave_a + COMPLEX, DIMENSION(nswbands) :: & ! now only 5 aerosols have wave-dependent refr + swref_index_oc , swref_index_dust , swref_index_nh4so4, swref_index_nacl,swref_index_h2o + COMPLEX, DIMENSION(nlwbands) :: & ! now only 5 aerosols have wave-dependent refr + lwref_index_oc , lwref_index_dust , lwref_index_nh4so4, lwref_index_nacl,lwref_index_h2o + + real dens_so4 , dens_no3 , dens_cl , dens_msa , dens_co3 , & + dens_nh4 , dens_na , dens_ca , dens_oin , dens_oc , & + dens_bc , dens_aro1 , dens_aro2 , dens_alk1 , dens_ole1, & + dens_api1 , dens_api2 , dens_lim1 , dens_lim2 , dens_h2o , & + dens_dust + real mass_so4 , mass_no3 , mass_cl , mass_msa , mass_co3 , & + mass_nh4 , mass_na , mass_ca , mass_oin , mass_oc , & + mass_bc , mass_aro1 , mass_aro2 , mass_alk1 , mass_ole1, & + mass_api1 , mass_api2 , mass_lim1 , mass_lim2 , mass_h2o, & + mass_dust + real mass_so4i , mass_no3i , mass_cli , mass_msai , mass_co3i, & + mass_nh4i , mass_nai , mass_cai , mass_oini , mass_oci , & + mass_bci , mass_aro1i, mass_aro2i, mass_alk1i, mass_ole1i, & + mass_ba1i , mass_ba2i, mass_ba3i , mass_ba4i , mass_pai, & + mass_h2oi , mass_dusti + real mass_so4j , mass_no3j , mass_clj , mass_msaj , mass_co3j, & + mass_nh4j , mass_naj , mass_caj , mass_oinj , mass_ocj , & + mass_bcj , mass_aro1j, mass_aro2j, mass_alk1j, mass_ole1j, & + mass_ba1j , mass_ba2j, mass_ba3j , mass_ba4j , mass_paj, & + mass_h2oj , mass_dustj + real mass_antha, mass_seas, mass_soil + real num_ai, num_aj, num_ac, vol_ai, vol_aj, vol_ac + real vol_so4 , vol_no3 , vol_cl , vol_msa , vol_co3 , & + vol_nh4 , vol_na , vol_ca , vol_oin , vol_oc , & + vol_bc , vol_aro1 , vol_aro2 , vol_alk1 , vol_ole1 , & + vol_api1 , vol_api2 , vol_lim1 , vol_lim2 , vol_h2o , & + vol_dust + real conv1a, conv1b + real mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell, & + dp_dry_a , dp_wet_a , num_a , dp_bc_a + real ifac, jfac, cfac + real refr + integer ns + real dgnum_um,drydens,duma,dlo_um,dhi_um,dgmin,sixpi,ss1,ss2,ss3,dtemp + integer iflag + real, dimension(1:nbin_o) :: xnum_secti,xnum_sectj,xnum_sectc + real, dimension(1:nbin_o) :: xmas_secti,xmas_sectj,xmas_sectc + real, dimension(1:nbin_o) :: xdia_um, xdia_cm +! +! real sginin,sginia,sginic from module_data_sorgam.F +! +! Mass from modal distribution is divided into individual sections before +! being passed back into the Mie routine. +! * currently use the same size bins as 8 default MOSAIC size bins +! * dlo_um and dhi_um define the lower and upper bounds of individual sections +! used to compute optical properties +! * sigmas for 3 modes taken from module_sorgan_data.F +! * these parameters are needed by sect02 that is called later +! * sginin=1.7, sginia=2.0, sginic=2.5 +! + sixpi=6.0/3.14159265359 + dlo_um=0.0390625 + dhi_um=10.0 + drydens=1.8 + iflag=2 + duma=1.0 + dgmin=1.0e-07 ! in (cm) + dtemp=dlo_um + do isize=1,nbin_o + xdia_um(isize)=(dtemp+dtemp*2.0)/2.0 + dtemp=dtemp*2.0 + enddo +! +! Define refractive indicies +! * assume na and cl are the same as nacl +! * assume so4, no3, and nh4 are the same as nh4no3 +! * assume ca and co3 are the same as caco3 +! * assume msa is just msa +! Further work: +! * to be more precise, need to compute electrolytes to apportion +! so4, no3, nh4, na, cl, msa, ca, co3 among various componds +! as was done previously in module_mosaic_therm.F +! + do ns = 1, nswbands + swref_index_nh4so4(ns) = cmplx(refrsw_sulf(ns),refisw_sulf(ns)) + swref_index_oc(ns) = cmplx(refrsw_oc(ns),refisw_oc(ns)) + swref_index_dust(ns) = cmplx(refrsw_dust(ns),refisw_dust(ns)) + swref_index_nacl(ns) = cmplx(refrsw_seas(ns),refisw_seas(ns)) + swref_index_h2o(ns) = cmplx(refrwsw(ns),refiwsw(ns)) + enddo + do ns = 1, nlwbands + lwref_index_nh4so4(ns) = cmplx(refrlw_sulf(ns),refilw_sulf(ns)) + lwref_index_oc(ns) = cmplx(refrlw_oc(ns),refilw_oc(ns)) + lwref_index_dust(ns) = cmplx(refrlw_dust(ns),refilw_dust(ns)) + lwref_index_nacl(ns) = cmplx(refrlw_seas(ns),refilw_seas(ns)) + lwref_index_h2o(ns) = cmplx(refrwlw(ns),refiwlw(ns)) + enddo + +! ref_index_nh4so4 = cmplx(1.52,0.) + ref_index_lvcite = cmplx(1.50,0.) + ref_index_nh4hso4= cmplx(1.47,0.) + ref_index_nh4msa = cmplx(1.50,0.) ! assumed + ref_index_nh4no3 = cmplx(1.50,0.) + ref_index_nh4cl = cmplx(1.50,0.) +! ref_index_nacl = cmplx(1.45,0.) + ref_index_nano3 = cmplx(1.50,0.) + ref_index_na2so4 = cmplx(1.50,0.) + ref_index_na3hso4= cmplx(1.50,0.) + ref_index_nahso4 = cmplx(1.50,0.) + ref_index_namsa = cmplx(1.50,0.) ! assumed + ref_index_caso4 = cmplx(1.56,0.006) + ref_index_camsa2 = cmplx(1.56,0.006) ! assumed + ref_index_cano3 = cmplx(1.56,0.006) + ref_index_cacl2 = cmplx(1.52,0.006) + ref_index_caco3 = cmplx(1.68,0.006) + ref_index_h2so4 = cmplx(1.43,0.) + ref_index_hhso4 = cmplx(1.43,0.) + ref_index_hno3 = cmplx(1.50,0.) + ref_index_hcl = cmplx(1.50,0.) + ref_index_msa = cmplx(1.43,0.) ! assumed +! ref_index_oc = cmplx(1.45,0.) ! JCB, Feb. 20, 2008: no complex part? +! JCB, Feb. 20, 2008: set the refractive index of BC equal to the +! midpoint of ranges given in Bond and Bergstrom, Light absorption by +! carboneceous particles: an investigative review 2006, Aerosol Sci. +! and Tech., 40:27-67. +! ref_index_bc = cmplx(1.82,0.74) old value + ref_index_bc = cmplx(1.85,0.71) + ref_index_oin = cmplx(1.55,0.006) ! JCB, Feb. 20, 2008: "other inorganics" +! ref_index_dust = cmplx(1.55,0.003) ! czhao, this refractive index should be wavelength depedent + ref_index_aro1 = cmplx(1.45,0.) + ref_index_aro2 = cmplx(1.45,0.) + ref_index_alk1 = cmplx(1.45,0.) + ref_index_ole1 = cmplx(1.45,0.) + ref_index_api1 = cmplx(1.45,0.) + ref_index_api2 = cmplx(1.45,0.) + ref_index_lim1 = cmplx(1.45,0.) + ref_index_lim2 = cmplx(1.45,0.) +! ref_index_h2o = cmplx(1.33,0.) +! +! densities in g/cc +! + dens_so4 = 1.8 ! used + dens_no3 = 1.8 ! used + dens_cl = 2.2 ! used + dens_msa = 1.8 ! used + dens_co3 = 2.6 ! used + dens_nh4 = 1.8 ! used + dens_na = 2.2 ! used + dens_ca = 2.6 ! used + dens_oin = 2.6 ! used + dens_dust = 2.6 ! used + dens_oc = 1.0 ! used +! JCB, Feb. 20, 2008: the density of BC is updated to reflect values +! published by Bond and Bergstrom, Light absorption by carboneceous +! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67. +! dens_bc = 1.7 ! used, old value + dens_bc = 1.8 ! midpoint of Bond and Bergstrom value + dens_aro1 = 1.0 + dens_aro2 = 1.0 + dens_alk1 = 1.0 + dens_ole1 = 1.0 + dens_api1 = 1.0 + dens_api2 = 1.0 + dens_lim1 = 1.0 + dens_lim2 = 1.0 + dens_h2o = 1.0 +! + p1st = param_first_scalar +! + swrefindx=0.0 + lwrefindx=0.0 + radius_wet=0.0 + number_bin=0.0 + radius_core=0.0 + swrefindx_core=0.0 + swrefindx_shell=0.0 + lwrefindx_core=0.0 + lwrefindx_shell=0.0 +! +! units: +! * mass - g/cc(air) +! * number - #/cc(air) +! * volume - cc(air)/cc(air) +! * diameter - cm +! + itype=1 + iphase=1 + do j = jts, jte + do k = kts, kte + do i = its, ite + mass_so4i = 0.0 + mass_so4j = 0.0 + mass_no3i = 0.0 + mass_no3j = 0.0 + mass_nh4i = 0.0 + mass_nh4j = 0.0 + mass_oini = 0.0 + mass_oinj = 0.0 + mass_dusti = 0.0 + mass_dustj = 0.0 + mass_aro1i = 0.0 + mass_aro1j = 0.0 + mass_aro2i = 0.0 + mass_aro2j = 0.0 + mass_alk1i = 0.0 + mass_alk1j = 0.0 + mass_ole1i = 0.0 + mass_ole1j = 0.0 + mass_ba1i = 0.0 + mass_ba1j = 0.0 + mass_ba2i = 0.0 + mass_ba2j = 0.0 + mass_ba3i = 0.0 + mass_ba3j = 0.0 + mass_ba4i = 0.0 + mass_ba4j = 0.0 + mass_pai = 0.0 + mass_paj = 0.0 + mass_oci = 0.0 + mass_ocj = 0.0 + mass_bci = 0.0 + mass_bcj = 0.0 + mass_cai = 0.0 + mass_caj = 0.0 + mass_co3i = 0.0 + mass_co3j = 0.0 + mass_nai = 0.0 + mass_naj = 0.0 + mass_cli = 0.0 + mass_clj = 0.0 + mass_msai = 0.0 + mass_msaj = 0.0 + mass_nai = 0.0 + mass_naj = 0.0 + mass_cli = 0.0 + mass_clj = 0.0 + mass_h2oi = 0.0 + mass_h2oj = 0.0 + mass_antha = 0.0 + mass_seas = 0.0 + mass_soil = 0.0 + vol_aj = 0.0 + vol_ai = 0.0 + vol_ac = 0.0 + num_aj = 0.0 + num_ai = 0.0 + num_ac = 0.0 + +! convert ug / kg dry air to g / cc air + conv1a = (1.0/alt(i,k,j)) * 1.0e-12 +! convert # / kg dry air to # / cc air + conv1b = (1.0/alt(i,k,j)) * 1.0e-6 + +! Accumulation mode... +! isize = 1 ; itype = 1 ! before march-2008 ordering + isize = 2 ; itype = 1 ! after march-2008 ordering + l=lptr_so4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_so4j= chem(i,k,j,l)*conv1a + l=lptr_no3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_no3j= chem(i,k,j,l)*conv1a + l=lptr_nh4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_nh4j= chem(i,k,j,l)*conv1a + l=lptr_p25_aer(isize,itype,iphase) + if (l .ge. p1st) mass_oinj= chem(i,k,j,l)*conv1a +!jdfcz l=lptr_dust_aer(isize,itype,iphase) +!jdfcz if (l .ge. p1st) mass_dustj= chem(i,k,j,l)*conv1a + l=lptr_asoa1_aer(isize,itype,iphase) + if (l .ge. p1st) mass_aro1j= chem(i,k,j,l)*conv1a + l=lptr_asoa2_aer(isize,itype,iphase) + if (l .ge. p1st) mass_aro2j= chem(i,k,j,l)*conv1a + l=lptr_asoa3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_alk1j= chem(i,k,j,l)*conv1a + l=lptr_asoa4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ole1j= chem(i,k,j,l)*conv1a + l=lptr_bsoa1_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba1j= chem(i,k,j,l)*conv1a + l=lptr_bsoa2_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba2j= chem(i,k,j,l)*conv1a + l=lptr_bsoa3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba3j= chem(i,k,j,l)*conv1a + l=lptr_bsoa4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba4j= chem(i,k,j,l)*conv1a + l=lptr_orgpa_aer(isize,itype,iphase) + if (l .ge. p1st) mass_paj= chem(i,k,j,l)*conv1a + l=lptr_ec_aer(isize,itype,iphase) + if (l .ge. p1st) mass_bcj= chem(i,k,j,l)*conv1a + l=lptr_na_aer(isize,itype,iphase) + if (l .ge. p1st) mass_naj= chem(i,k,j,l)*conv1a + l=lptr_cl_aer(isize,itype,iphase) + if (l .ge. p1st) mass_clj= chem(i,k,j,l)*conv1a + l=numptr_aer(isize,itype,iphase) + if (l .ge. p1st) num_aj= chem(i,k,j,l)*conv1b + mass_h2oj= h2oaj(i,k,j) * 1.0e-12 + mass_ocj=mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ & + mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j+mass_paj + +! Aitken mode... +! isize = 1 ; itype = 2 ! before march-2008 ordering + isize = 1 ; itype = 1 ! after march-2008 ordering + l=lptr_so4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_so4i= chem(i,k,j,l)*conv1a + l=lptr_no3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_no3i= chem(i,k,j,l)*conv1a + l=lptr_nh4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_nh4i= chem(i,k,j,l)*conv1a + l=lptr_p25_aer(isize,itype,iphase) + if (l .ge. p1st) mass_oini= chem(i,k,j,l)*conv1a +!jdfcz l=lptr_dust_aer(isize,itype,iphase) +!jdfcz if (l .ge. p1st) mass_dusti= chem(i,k,j,l)*conv1a + l=lptr_asoa1_aer(isize,itype,iphase) + if (l .ge. p1st) mass_aro1i= chem(i,k,j,l)*conv1a + l=lptr_asoa2_aer(isize,itype,iphase) + if (l .ge. p1st) mass_aro2i= chem(i,k,j,l)*conv1a + l=lptr_asoa3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_alk1i= chem(i,k,j,l)*conv1a + l=lptr_asoa4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ole1i= chem(i,k,j,l)*conv1a + l=lptr_bsoa1_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba1i= chem(i,k,j,l)*conv1a + l=lptr_bsoa2_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba2i= chem(i,k,j,l)*conv1a + l=lptr_bsoa3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba3i= chem(i,k,j,l)*conv1a + l=lptr_bsoa4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba4i= chem(i,k,j,l)*conv1a + l=lptr_orgpa_aer(isize,itype,iphase) + if (l .ge. p1st) mass_pai= chem(i,k,j,l)*conv1a + l=lptr_ec_aer(isize,itype,iphase) + if (l .ge. p1st) mass_bci= chem(i,k,j,l)*conv1a + l=lptr_na_aer(isize,itype,iphase) + if (l .ge. p1st) mass_nai= chem(i,k,j,l)*conv1a + l=lptr_cl_aer(isize,itype,iphase) + if (l .ge. p1st) mass_cli= chem(i,k,j,l)*conv1a + l=numptr_aer(isize,itype,iphase) + if (l .ge. p1st) num_ai= chem(i,k,j,l)*conv1b + mass_h2oi= h2oai(i,k,j) * 1.0e-12 + mass_oci=mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ & + mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i+mass_pai + +! Coarse mode... +! isize = 1 ; itype = 3 ! before march-2008 ordering + isize = 1 ; itype = 2 ! after march-2008 ordering + l=lptr_anth_aer(isize,itype,iphase) + if (l .ge. p1st) mass_antha= chem(i,k,j,l)*conv1a + l=lptr_seas_aer(isize,itype,iphase) + if (l .ge. p1st) mass_seas= chem(i,k,j,l)*conv1a + l=lptr_soil_aer(isize,itype,iphase) + if (l .ge. p1st) mass_soil= chem(i,k,j,l)*conv1a + l=numptr_aer(isize,itype,iphase) + if (l .ge. p1st) num_ac= chem(i,k,j,l)*conv1b + + vol_ai = (mass_so4i/dens_so4)+(mass_no3i/dens_no3)+ & + (mass_nh4i/dens_nh4)+(mass_oini/dens_oin)+ & + (mass_aro1i/dens_oc)+(mass_alk1i/dens_oc)+ & + (mass_ole1i/dens_oc)+(mass_ba1i/dens_oc)+ & + (mass_ba2i/dens_oc)+(mass_ba3i/dens_oc)+ & + (mass_ba4i/dens_oc)+(mass_pai/dens_oc)+ & + (mass_aro2i/dens_oc)+(mass_bci/dens_bc)+ & + (mass_nai/dens_na)+(mass_cli/dens_cl) +!jdfcz (mass_nai/dens_na)+(mass_cli/dens_cl) + & +!jdfcz (mass_dusti/dens_dust) + vol_aj = (mass_so4j/dens_so4)+(mass_no3j/dens_no3)+ & + (mass_nh4j/dens_nh4)+(mass_oinj/dens_oin)+ & + (mass_aro1j/dens_oc)+(mass_alk1j/dens_oc)+ & + (mass_ole1j/dens_oc)+(mass_ba1j/dens_oc)+ & + (mass_ba2j/dens_oc)+(mass_ba3j/dens_oc)+ & + (mass_ba4j/dens_oc)+(mass_paj/dens_oc)+ & + (mass_aro2j/dens_oc)+(mass_bcj/dens_bc)+ & + (mass_naj/dens_na)+(mass_clj/dens_cl) +!jdfcz (mass_naj/dens_na)+(mass_clj/dens_cl) + & +!jdfcz (mass_dustj/dens_dust) + vol_ac = (mass_antha/dens_oin)+ & + (mass_seas*(22.9897/58.4428)/dens_na)+ & + (mass_seas*(35.4270/58.4428)/dens_cl)+ & + (mass_soil/dens_dust) + +! +! Now divide mass into sections which is done by sect02: +! * xmas_secti is for aiken mode +! * xmas_sectj is for accumulation mode +! * xmas_sectc is for coarse mode +! * sect02 expects input in um +! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins +! + ss1=alog(sginin) + ss2=exp(ss1*ss1*36.0/8.0) + ss3=(sixpi*vol_ai/(num_ai*ss2))**0.3333333 + dgnum_um=amax1(dgmin,ss3)*1.0e+04 + call sect02(dgnum_um,sginin,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & + xnum_secti,xmas_secti) + ss1=alog(sginia) + ss2=exp(ss1*ss1*36.0/8.0) + ss3=(sixpi*vol_aj/(num_aj*ss2))**0.3333333 + dgnum_um=amax1(dgmin,ss3)*1.0e+04 + call sect02(dgnum_um,sginia,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & + xnum_sectj,xmas_sectj) + ss1=alog(sginic) + ss2=exp(ss1*ss1*36.0/8.0) + ss3=(sixpi*vol_ac/(num_ac*ss2))**0.3333333 + dgnum_um=amax1(dgmin,ss3)*1.0e+04 + call sect02(dgnum_um,sginic,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & + xnum_sectc,xmas_sectc) + + do isize = 1, nbin_o + xdia_cm(isize)=xdia_um(isize)*1.0e-04 + mass_so4 = mass_so4i*xmas_secti(isize) + mass_so4j*xmas_sectj(isize) + mass_no3 = mass_no3i*xmas_secti(isize) + mass_no3j*xmas_sectj(isize) + mass_nh4 = mass_nh4i*xmas_secti(isize) + mass_nh4j*xmas_sectj(isize) + mass_oin = mass_oini*xmas_secti(isize) + mass_oinj*xmas_sectj(isize) + & + mass_antha*xmas_sectc(isize) +!jdfcz mass_dust= mass_dusti*xmas_secti(isize) + mass_dustj*xmas_sectj(isize) + & +!jdfcz mass_soil*xmas_sectc(isize) + mass_oc = (mass_pai+mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ & + mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i)*xmas_secti(isize) + & + (mass_paj+mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ & + mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j)*xmas_sectj(isize) + mass_bc = mass_bci*xmas_secti(isize) + mass_bcj*xmas_sectj(isize) + mass_na = mass_nai*xmas_secti(isize) + mass_naj*xmas_sectj(isize)+ & + mass_seas*xmas_sectc(isize)*(22.9897/58.4428) + mass_cl = mass_cli*xmas_secti(isize) + mass_clj*xmas_sectj(isize)+ & + mass_seas*xmas_sectc(isize)*(35.4270/58.4428) + mass_h2o = mass_h2oi*xmas_secti(isize) + mass_h2oj*xmas_sectj(isize) +! mass_h2o = 0.0 ! testing purposes only + vol_so4 = mass_so4 / dens_so4 + vol_no3 = mass_no3 / dens_no3 + vol_nh4 = mass_nh4 / dens_nh4 + vol_oin = mass_oin / dens_oin +!jdfcz vol_dust = mass_dust / dens_dust + vol_oc = mass_oc / dens_oc + vol_bc = mass_bc / dens_bc + vol_na = mass_na / dens_na + vol_cl = mass_cl / dens_cl + vol_h2o = mass_h2o / dens_h2o +!!$ if(i.eq.50.and.j.eq.40.and.k.eq.1) then +!!$ print*,'jdf print bin',isize +!!$ print*,'so4',mass_so4,vol_so4 +!!$ print*,'no3',mass_no3,vol_no3 +!!$ print*,'nh4',mass_nh4,vol_nh4 +!!$ print*,'oin',mass_oin,vol_oin +!!$!jdfcz print*,'dust',mass_dust,vol_dust +!!$ print*,'oc ',mass_oc,vol_oc +!!$ print*,'bc ',mass_bc,vol_bc +!!$ print*,'na ',mass_na,vol_na +!!$ print*,'cl ',mass_cl,vol_cl +!!$ print*,'h2o',mass_h2o,vol_h2o +!!$ endif + mass_dry_a = mass_so4 + mass_no3 + mass_nh4 + mass_oin + & +!jdfcz mass_oc + mass_bc + mass_na + mass_cl + mass_dust + mass_oc + mass_bc + mass_na + mass_cl + mass_wet_a = mass_dry_a + mass_h2o + vol_dry_a = vol_so4 + vol_no3 + vol_nh4 + vol_oin + & +!jdfcz vol_oc + vol_bc + vol_na + vol_cl + vol_dust + vol_oc + vol_bc + vol_na + vol_cl + vol_wet_a = vol_dry_a + vol_h2o + vol_shell = vol_wet_a - vol_bc + !num_a = vol_wet_a / (0.52359877*xdia_cm(isize)*xdia_cm(isize)*xdia_cm(isize)) + !czhao + num_a = num_ai*xnum_secti(isize)+num_aj*xnum_sectj(isize)+num_ac*xnum_sectc(isize) + + + !shortwave + do ns=1,nswbands + ri_dum = (0.0,0.0) + ri_dum = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) + & + (ref_index_nh4no3 * mass_no3 / dens_no3) + & + (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & +!jdf (ref_index_oin * mass_oin / dens_oin) + & +!jdfcz (swref_index_dust(ns) * mass_dust / dens_dust) + & + (swref_index_dust(ns) * mass_oin / dens_dust) + & + (swref_index_oc(ns) * mass_oc / dens_oc) + & + (ref_index_bc * mass_bc / dens_bc) + & + (swref_index_nacl(ns) * mass_na / dens_na) + & + (swref_index_nacl(ns) * mass_cl / dens_cl) + & + (swref_index_h2o(ns) * mass_h2o / dens_h2o) +! +! for some reason MADE/SORGAM occasionally produces zero aerosols so +! need to add a check here to avoid divide by zero +! + IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then + dp_dry_a = xdia_cm(isize) + dp_wet_a = xdia_cm(isize) + dp_bc_a = xdia_cm(isize) + ri_ave_a = 0.0 + ri_dum = 0.0 + else + dp_dry_a = (1.90985*vol_dry_a/num_a)**0.3333333 + dp_wet_a = (1.90985*vol_wet_a/num_a)**0.3333333 + dp_bc_a = (1.90985*vol_bc/num_a)**0.3333333 + ri_ave_a = ri_dum/vol_wet_a + ri_dum = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) + & + (ref_index_nh4no3 * mass_no3 / dens_no3) + & + (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & +!jdf (ref_index_oin * mass_oin / dens_oin) + & +!jdfcz (swref_index_dust(ns) * mass_dust / dens_dust) + & + (swref_index_dust(ns) * mass_oin / dens_dust) + & + (swref_index_oc(ns) * mass_oc / dens_oc) + & + (swref_index_nacl(ns) * mass_na / dens_na) + & + (swref_index_nacl(ns) * mass_cl / dens_cl) + & + (swref_index_h2o(ns) * mass_h2o / dens_h2o) + endif + if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then + swrefindx(i,k,j,isize,ns) = (1.5,0.0) + radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =0.0 + swrefindx_core(i,k,j,isize,ns) = ref_index_bc + swrefindx_shell(i,k,j,isize,ns) = ref_index_oin + elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then + swrefindx(i,k,j,isize,ns) = (1.5,0.0) + radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =0.0 + swrefindx_core(i,k,j,isize,ns) = ref_index_bc + swrefindx_shell(i,k,j,isize,ns) = ref_index_oin + else + swrefindx(i,k,j,isize,ns) =ri_ave_a + radius_wet(i,k,j,isize) =dp_wet_a/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =dp_bc_a/2.0 + swrefindx_core(i,k,j,isize,ns) =ref_index_bc + swrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell + endif + enddo ! ns shortwave + + !longwave + do ns=1,nlwbands + ri_dum = (0.0,0.0) + ri_dum = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) + & + (ref_index_nh4no3 * mass_no3 / dens_no3) + & + (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & +!jdf (ref_index_oin * mass_oin / dens_oin) + & +!jdfcz (lwref_index_dust(ns) * mass_dust / dens_dust) + & + (lwref_index_dust(ns) * mass_oin / dens_dust) + & + (lwref_index_oc(ns) * mass_oc / dens_oc) + & + (ref_index_bc * mass_bc / dens_bc) + & + (lwref_index_nacl(ns) * mass_na / dens_na) + & + (lwref_index_nacl(ns) * mass_cl / dens_cl) + & + (lwref_index_h2o(ns) * mass_h2o / dens_h2o) +! +! for some reason MADE/SORGAM occasionally produces zero aerosols so +! need to add a check here to avoid divide by zero +! + IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then + dp_dry_a = xdia_cm(isize) + dp_wet_a = xdia_cm(isize) + dp_bc_a = xdia_cm(isize) + ri_ave_a = 0.0 + ri_dum = 0.0 + else + dp_dry_a = (1.90985*vol_dry_a/num_a)**0.3333333 + dp_wet_a = (1.90985*vol_wet_a/num_a)**0.3333333 + dp_bc_a = (1.90985*vol_bc/num_a)**0.3333333 + ri_ave_a = ri_dum/vol_wet_a + ri_dum = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) + & + (ref_index_nh4no3 * mass_no3 / dens_no3) + & + (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & +!jdf (ref_index_oin * mass_oin / dens_oin) + & +!jdfcz (lwref_index_dust(ns) * mass_dust / dens_dust) + & + (lwref_index_dust(ns) * mass_oin / dens_dust) + & + (lwref_index_oc(ns) * mass_oc / dens_oc) + & + (lwref_index_nacl(ns) * mass_na / dens_na) + & + (lwref_index_nacl(ns) * mass_cl / dens_cl) + & + (lwref_index_h2o(ns) * mass_h2o / dens_h2o) + endif + if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then + lwrefindx(i,k,j,isize,ns) = (1.5,0.0) + radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =0.0 + lwrefindx_core(i,k,j,isize,ns) = ref_index_bc + lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin + elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then + lwrefindx(i,k,j,isize,ns) = (1.5,0.0) + radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =0.0 + lwrefindx_core(i,k,j,isize,ns) = ref_index_bc + lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin + else + lwrefindx(i,k,j,isize,ns) =ri_ave_a + radius_wet(i,k,j,isize) =dp_wet_a/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =dp_bc_a/2.0 + lwrefindx_core(i,k,j,isize,ns) =ref_index_bc + lwrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell + endif + enddo ! ns longwave + +! refr=real(refindx(i,k,j,isize)) + + enddo !isize + enddo !i + enddo !j + enddo !k + + return + + end subroutine optical_prep_modal_vbs + +!------------------------------------------------------------------ subroutine optical_prep_mam(nbin_o, chem, alt, & radius_core,radius_wet, number_bin, & swrefindx, swrefindx_core, swrefindx_shell, & @@ -1929,19 +2601,19 @@ subroutine optical_prep_mam(nbin_o, chem, alt, & ! * sect02 expects input in um ! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins ! - ss1=alog(sigmag_aer(1,2)) + ss1=log(sigmag_aer(1,2)) ss2=exp(ss1*ss1*36.0/8.0) ss3=(sixpi*vol_a2/(num_a2*ss2))**0.3333333 dgnum_um=amax1(dgmin,ss3)*1.0e+04 call sect02(dgnum_um,sigmag_aer(1,2),drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & xnum_secti,xmas_secti) - ss1=alog(sigmag_aer(1,1)) + ss1=log(sigmag_aer(1,1)) ss2=exp(ss1*ss1*36.0/8.0) ss3=(sixpi*vol_a1/(num_a1*ss2))**0.3333333 dgnum_um=amax1(dgmin,ss3)*1.0e+04 call sect02(dgnum_um,sigmag_aer(1,1),drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & xnum_sectj,xmas_sectj) - ss1=alog(sigmag_aer(1,3)) + ss1=log(sigmag_aer(1,3)) ss2=exp(ss1*ss1*36.0/8.0) ss3=(sixpi*vol_a3/(num_a3*ss2))**0.3333333 dgnum_um=amax1(dgmin,ss3)*1.0e+04 @@ -2526,21 +3198,21 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & ! * sect02 expects input in um ! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins ! -!! ss1=alog(sginin) +!! ss1=log(sginin) !! ss2=exp(ss1*ss1*36.0/8.0) !! ss3=(sixpi*vol_ai/(num_ai*ss2))**0.3333333 !! dgnum_um=amax1(dgmin,ss3)*1.0e+04 dgnum_um=dginin*1.E6 call sect02(dgnum_um,sginin,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & xnum_secti,xmas_secti) -!! ss1=alog(sginia) +!! ss1=log(sginia) !! ss2=exp(ss1*ss1*36.0/8.0) !! ss3=(sixpi*vol_aj/(num_aj*ss2))**0.3333333 !! dgnum_um=amax1(dgmin,ss3)*1.0e+04 dgnum_um=dginia*1.E6 call sect02(dgnum_um,sginia,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & xnum_sectj,xmas_sectj) -!! ss1=alog(sginic) +!! ss1=log(sginic) !! ss2=exp(ss1*ss1*36.0/8.0) !! ss3=(sixpi*vol_ac/(num_ac*ss2))**0.3333333 dgnum_um=dginic*1.E6 @@ -3020,8 +3692,8 @@ subroutine mieaer( & nrefi=1 endif - bma=0.5*alog(rmax/rmin) ! JCB - bpa=0.5*alog(rmax*rmin) ! JCB + bma=0.5*log(rmax/rmin) ! JCB + bpa=0.5*log(rmax*rmin) ! JCB do 120 nr=1,nrefr do 120 ni=1,nrefi @@ -3136,8 +3808,8 @@ subroutine mieaer( & nrefi=1 endif - bma=0.5*alog(rmax/rmin) ! JCB - bpa=0.5*alog(rmax*rmin) ! JCB + bma=0.5*log(rmax/rmin) ! JCB + bpa=0.5*log(rmax*rmin) ! JCB do 121 nr=1,nrefr do 121 ni=1,nrefi @@ -3183,8 +3855,8 @@ subroutine mieaer( & endif !ini_fit - xrmin=alog(rmin) - xrmax=alog(rmax) + xrmin=log(rmin) + xrmax=log(rmax) !###################################################################### !parameterization of mie calculation for shortwave @@ -3245,7 +3917,7 @@ subroutine mieaer( & endif !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - x=alog(radius_wet_col(m,klevel)) ! radius in cm + x=log(radius_wet_col(m,klevel)) ! radius in cm crefin=swrefindx_col(m,klevel,ns) refr=real(crefin) refi=-imag(crefin) @@ -3502,7 +4174,7 @@ subroutine mieaer( & do m=1,nbin_a ! nbin_a is number of bins ! here's the size sizem=radius_wet_col(m,klevel) ! radius in cm - x=alog(radius_wet_col(m,klevel)) ! radius in cm + x=log(radius_wet_col(m,klevel)) ! radius in cm crefin=lwrefindx_col(m,klevel,ns) refr=real(crefin) refi=-imag(crefin) @@ -3610,8 +4282,11 @@ subroutine fitcurv(rs,yin,coef,ncoef,maxm) !!$ endif do 100 m=1,maxm - x(m)=alog(rs(m)) - y(m)=alog(yin(m)) +! To prevent the log of 0 or negative values, as the code was blowing up when compile with intel +! Added by Manish Shrivastava +! Need to be checked + x(m)=log(max(rs(m),1d-20)) + y(m)=log(max(yin(m),1d-20)) 100 continue xmin=x(1) @@ -3656,8 +4331,8 @@ subroutine fitcurv_nolog(rs,yin,coef,ncoef,maxm) !!$ endif do 100 m=1,maxm - x(m)=alog(rs(m)) - y(m)=yin(m) ! note, no "alog" here + x(m)=log(rs(m)) + y(m)=yin(m) ! note, no "log" here 100 continue xmin=x(1) @@ -5406,8 +6081,8 @@ subroutine sect02(dgnum_um,sigmag,drydens,iflag,duma,nbin,dlo_um,dhi_um, & end if ! compute total volume and number for mode ! dgnum = dgnum_um*1.0e-4 -! sx = alog( sigmag ) -! x0 = alog( dgnum ) +! sx = log( sigmag ) +! x0 = log( dgnum ) ! x3 = x0 + 3.*sx*sx ! dstar = dgnum * exp(1.5*sx*sx) ! if (iflag .le. 1) then @@ -5429,8 +6104,8 @@ subroutine sect02(dgnum_um,sigmag,drydens,iflag,duma,nbin,dlo_um,dhi_um, & end do ! compute modal "working" parameters including total num/vol/mass dgnum = dgnum_um*1.0e-4 - sx = alog( sigmag ) - x0 = alog( dgnum ) + sx = log( sigmag ) + x0 = log( dgnum ) x3 = x0 + 3.*sx*sx dstar = dgnum * exp(1.5*sx*sx) if (iflag .le. 1) then @@ -5455,8 +6130,8 @@ subroutine sect02(dgnum_um,sigmag,drydens,iflag,duma,nbin,dlo_um,dhi_um, & !9230 format( / 'sum over all sections ', 2(1pe13.4) ) !9231 format( 'modal totals ', 2(1pe13.4) ) do n = 1, nbin - xlo = alog( dlo_sect(n) ) - xhi = alog( dhi_sect(n) ) + xlo = log( dlo_sect(n) ) + xhi = log( dhi_sect(n) ) tlo = (xlo - x0)/sxroot2 thi = (xhi - x0)/sxroot2 if (tlo .le. 0.) then diff --git a/wrfv2_fire/chem/module_phot_fastj.F b/wrfv2_fire/chem/module_phot_fastj.F index b089c900..25684dbe 100644 --- a/wrfv2_fire/chem/module_phot_fastj.F +++ b/wrfv2_fire/chem/module_phot_fastj.F @@ -233,12 +233,12 @@ subroutine fastj_driver(id,curr_secs,dtstep,config_flags, & ! SORGAM aerosols. select case (config_flags%chem_opt) case ( CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_KPP, & - CBMZ_MOSAIC_4BIN_VBS2_KPP, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - MOZART_MOSAIC_4BIN_VBS0_KPP, CRI_MOSAIC_8BIN_AQ_KPP, & - CRI_MOSAIC_4BIN_AQ_KPP ) + MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, &!BSINGH(12/05/2013): Added for SAPRC 8 bin vbs + SAPRC99_MOSAIC_8BIN_VBS2_KPP )!BSINGH(04/07/2014): Added for SAPRC 8 bin vbs non-aq processingAerosols = .true. case default processingAerosols = .false. diff --git a/wrfv2_fire/chem/module_plumerise1.F b/wrfv2_fire/chem/module_plumerise1.F index 93a31b50..64a51048 100644 --- a/wrfv2_fire/chem/module_plumerise1.F +++ b/wrfv2_fire/chem/module_plumerise1.F @@ -97,7 +97,8 @@ subroutine plumerise_driver (id,ktau,dtstep, & if( scale_fire_emiss ) then if( config_flags%chem_opt /= MOZCART_KPP .and. & config_flags%chem_opt /= MOZART_KPP .and. & - config_flags%chem_opt /= MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt /= MOZART_MOSAIC_4BIN_KPP .and. & + config_flags%chem_opt /= MOZART_MOSAIC_4BIN_AQ_KPP ) then call wrf_error_fatal("Fire emission scaling only supported for MOZART_KPP, MOZCART_KPP chem options") endif endif @@ -279,7 +280,9 @@ subroutine plumerise_driver (id,ktau,dtstep, & config_flags%biomass_burn_opt == BIOMASSB_MOZC) .or. & (config_flags%chem_opt == MOZART_KPP .and. & config_flags%biomass_burn_opt == BIOMASSB_MOZ) .or. & - (config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP .and. & + (config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .and. & + config_flags%biomass_burn_opt == BIOMASSB_MOZC) .or. & + (config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP .and. & config_flags%biomass_burn_opt == BIOMASSB_MOZC) ) then !------------------------------------------------------------------- ! we input total emissions instead of smoldering emissions: @@ -327,7 +330,8 @@ subroutine plumerise_driver (id,ktau,dtstep, & ebu(i,k,j,p_ebu_mvk) = ebu(i,k,j,p_ebu_mvk)*ratio end do if( config_flags%chem_opt == MOZCART_KPP .or. & - config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then + config_flags%chem_opt == MOZART_MOSAIC_4BIN_KPP .or. & + config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then do k = kts,kte ebu(i,k,j,p_ebu_pm10) = ebu(i,k,j,p_ebu_pm10)*ratio ebu(i,k,j,p_ebu_pm25) = ebu(i,k,j,p_ebu_pm25)*ratio diff --git a/wrfv2_fire/chem/module_sorgam_aqchem.F b/wrfv2_fire/chem/module_sorgam_aqchem.F index 1c9e0d4d..004e2e6a 100644 --- a/wrfv2_fire/chem/module_sorgam_aqchem.F +++ b/wrfv2_fire/chem/module_sorgam_aqchem.F @@ -13,8 +13,8 @@ module module_sorgam_aqchem REAL, PARAMETER :: mwso4 = 96.00 ! Molecular mass of SO4-- (g/mol) REAL, PARAMETER :: mwno3 = 62.0 ! Molecular mass of NO3- (g/mol) REAL, PARAMETER :: mwnh4 = 18.0985 ! Molecular mass of NH4+ (g/mol) -! REAL, PARAMETER :: mwna = 22.990 ! Molecular mass of NH4+ (g/mol) -! REAL, PARAMETER :: mwcl = 35.453 ! Molecular mass of NH4+ (g/mol) + REAL, PARAMETER :: mwna = 22.990 ! Molecular mass of NH4+ (g/mol) + REAL, PARAMETER :: mwcl = 35.453 ! Molecular mass of NH4+ (g/mol) ! AQCHEM parameters @@ -157,14 +157,18 @@ subroutine sorgam_aqchem_driver( & p_so4cwj, & p_nh4cwj, & p_no3cwj, & -! p_nacwi, & -! p_nacwj, & -! p_clcwi, & -! p_clcwj, & + p_nacwi, & + p_nacwj, & + p_clcwi, & + p_clcwj, & ! p_so4cwk, & ! p_no3cwk, & p_qv, & - p_qc + p_qc, & + p_facd, & + p_mepx, & + p_pacd, & + CB05_SORG_AQ_KPP use module_data_sorgam, only: cw_phase, nphase_aer @@ -304,7 +308,8 @@ subroutine sorgam_aqchem_driver( & ! if (p_co2 .gt. 1) then ! gas(lco2) = chem(it,kt,jt,p_co2)*1.0e-6 ! else - gas(lco2) = 380.0 +! gas(lco2) = 380.0 + gas(lco2) = 380.0e-6 ! endif if (p_so2 .gt. 1) gas(lso2) = chem(it,kt,jt,p_so2)*1.0e-6 @@ -313,10 +318,17 @@ subroutine sorgam_aqchem_driver( & if (p_nh3 .gt. 1) gas(lnh3) = chem(it,kt,jt,p_nh3)*1.0e-6 if (p_h2o2 .gt. 1) gas(lh2o2) = chem(it,kt,jt,p_h2o2)*1.0e-6 if (p_o3 .gt. 1) gas(lo3) = chem(it,kt,jt,p_o3)*1.0e-6 - if (p_ora1 .gt. 1) gas(lfoa) = chem(it,kt,jt,p_ora1)*1.0e-6 - if (p_op1 .gt. 1) gas(lmhp) = chem(it,kt,jt,p_op1)*1.0e-6 - if (p_paa .gt. 1) gas(lpaa) = chem(it,kt,jt,p_paa)*1.0e-6 if (p_sulf .gt. 1) gas(lh2so4) = chem(it,kt,jt,p_sulf)*1.0e-6 + + if (config_flags%chem_opt==CB05_SORG_AQ_KPP) then + if (p_facd .gt. 1) gas(lfoa) = chem(it,kt,jt,p_facd)*1.0e-6 + if (p_mepx .gt. 1) gas(lmhp) = chem(it,kt,jt,p_mepx)*1.0e-6 + if (p_pacd .gt. 1) gas(lpaa) = chem(it,kt,jt,p_pacd)*1.0e-6 + else + if (p_ora1 .gt. 1) gas(lfoa) = chem(it,kt,jt,p_ora1)*1.0e-6 + if (p_op1 .gt. 1) gas(lmhp) = chem(it,kt,jt,p_op1)*1.0e-6 + if (p_paa .gt. 1) gas(lpaa) = chem(it,kt,jt,p_paa)*1.0e-6 + end if ! Aerosol mass concentrations before aqueous phase chemistry ! (with units conversion ug/kg -> mol/mol). Although AQCHEM @@ -341,8 +353,8 @@ subroutine sorgam_aqchem_driver( & aerosol(lso4acc) = chem(it,kt,jt,p_so4cwj)*1.0e-9*mwdry/mwso4 ! Accumulation mode sulfate aerosol(lnh4acc) = chem(it,kt,jt,p_nh4cwj)*1.0e-9*mwdry/mwnh4 ! Accumulation mode ammonium aerosol(lno3acc) = chem(it,kt,jt,p_no3cwj)*1.0e-9*mwdry/mwno3 ! Accumulation mode nitrate -! aerosol(lnaacc) = chem(it,kt,jt,p_nacwj)*1.0e-9*mwdry/mwna ! Accumulation mode Na -! aerosol(lclacc) = chem(it,kt,jt,p_clcwj)*1.0e-9*mwdry/mwcl ! Accumulation mode Cl + aerosol(lnaacc) = chem(it,kt,jt,p_nacwj)*1.0e-9*mwdry/mwna ! Accumulation mode Na + aerosol(lclacc) = chem(it,kt,jt,p_clcwj)*1.0e-9*mwdry/mwcl ! Accumulation mode Cl aerosol(lorgaacc) = 0.0 ! Accumulation mode anthropogenic SOA aerosol(lorgpacc) = 0.0 ! Accumulation mode primary organic aerosol @@ -352,10 +364,14 @@ subroutine sorgam_aqchem_driver( & ! aerosol(lso4cor) = chem(it,kt,jt,p_so4cwk)*1.0e-9*mwdry/mwso4 ! Coarse mode sulfate ! aerosol(lno3cor) = chem(it,kt,jt,p_no3cwk)*1.0e-9*mwdry/mwno3 ! Coarse mode nitrate -! aerosol(lnacor) = 0.0 ! Coarse mode Na -! aerosol(lclcor) = 0.0 ! Coarse mode Cl + aerosol(lnacor) = 0.0 ! Coarse mode Na + aerosol(lclcor) = 0.0 ! Coarse mode Cl aerosol(lpricor) = 0.0 ! Coarse mode primary aerosol - + +!based on CMAQ prescribed Fe/Mn + aerosol(LA3FE) = 0.01*alt(it,kt,jt)*1.0e-9*mwdry/55.8 + aerosol(LB2MN) = 0.005*alt(it,kt,jt)*1.0e-9*mwdry/54.9 + ! Liquid phase concentrations liquid(:) = 0.0 @@ -388,19 +404,26 @@ subroutine sorgam_aqchem_driver( & if (p_nh3 .gt. 1) chem(it,kt,jt,p_nh3) = gas(lnh3)*1.0e6 if (p_h2o2 .gt. 1) chem(it,kt,jt,p_h2o2) = gas(lh2o2)*1.0e6 if (p_o3 .gt. 1) chem(it,kt,jt,p_o3) = gas(lo3)*1.0e6 - if (p_ora1 .gt. 1) chem(it,kt,jt,p_ora1) = gas(lfoa)*1.0e6 - if (p_op1 .gt. 1) chem(it,kt,jt,p_op1) = gas(lmhp)*1.0e6 - if (p_paa .gt. 1) chem(it,kt,jt,p_paa) = gas(lpaa)*1.0e6 if (p_sulf .gt. 1) chem(it,kt,jt,p_sulf) = gas(lh2so4)*1.0e6 - + + if (config_flags%chem_opt==CB05_SORG_AQ_KPP) then + if (p_facd .gt. 1) chem(it,kt,jt,p_facd) = gas(lfoa)*1.0e6 + if (p_mepx .gt. 1) chem(it,kt,jt,p_mepx) = gas(lmhp)*1.0e6 + if (p_pacd .gt. 1) chem(it,kt,jt,p_pacd) = gas(lpaa)*1.0e6 + else + if (p_ora1 .gt. 1) chem(it,kt,jt,p_ora1) = gas(lfoa)*1.0e6 + if (p_op1 .gt. 1) chem(it,kt,jt,p_op1) = gas(lmhp)*1.0e6 + if (p_paa .gt. 1) chem(it,kt,jt,p_paa) = gas(lpaa)*1.0e6 + end if + ! Aerosol mass concentrations after aqueous phase chemistry ! (with units conversion mol/mol -> ug/kg) chem(it,kt,jt,p_so4cwi) = aerosol(lso4akn) *1.0e9/mwdry*mwso4 ! Aitken mode sulfate chem(it,kt,jt,p_nh4cwi) = aerosol(lnh4akn) *1.0e9/mwdry*mwnh4 ! Aitken mode ammonium chem(it,kt,jt,p_no3cwi) = aerosol(lno3akn) *1.0e9/mwdry*mwno3 ! Aitken mode nitrate -! chem(it,kt,jt,p_nacwi) = aerosol(lnaakn) *1.0e9/mwdry*mwna ! Aitken mode Na -! chem(it,kt,jt,p_clcwi) = aerosol(lclakn) *1.0e9/mwdry*mwcl ! Aitken mode Cl + chem(it,kt,jt,p_nacwi) = aerosol(lnaakn) *1.0e9/mwdry*mwna ! Aitken mode Na + chem(it,kt,jt,p_clcwi) = aerosol(lclakn) *1.0e9/mwdry*mwcl ! Aitken mode Cl ! chem(it,kt,jt,........) = aerosol(lorgaakn)*1.0e9/mwdry*..... ! Aitken mode anthropogenic SOA ! chem(it,kt,jt,........) = aerosol(lorgpakn)*1.0e9/mwdry*..... ! Aitken mode primary organic aerosol @@ -411,8 +434,8 @@ subroutine sorgam_aqchem_driver( & chem(it,kt,jt,p_so4cwj) = aerosol(lso4acc) *1.0e9/mwdry*mwso4 ! Accumulation mode sulfate chem(it,kt,jt,p_nh4cwj) = aerosol(lnh4acc) *1.0e9/mwdry*mwnh4 ! Accumulation mode ammonium chem(it,kt,jt,p_no3cwj) = aerosol(lno3acc) *1.0e9/mwdry*mwno3 ! Accumulation mode nitrate -! chem(it,kt,jt,p_nacwj) = aerosol(lnaacc) *1.0e9/mwdry*mwna ! Accumulation mode Na -! chem(it,kt,jt,p_clcwj) = aerosol(lclacc) *1.0e9/mwdry*mwcl ! Accumulation mode Cl + chem(it,kt,jt,p_nacwj) = aerosol(lnaacc) *1.0e9/mwdry*mwna ! Accumulation mode Na + chem(it,kt,jt,p_clcwj) = aerosol(lclacc) *1.0e9/mwdry*mwcl ! Accumulation mode Cl ! chem(it,kt,jt,........) = aerosol(lorgaacc)*1.0e9/mwdry*..... ! Accumulation mode anthropogenic SOA ! chem(it,kt,jt,........) = aerosol(lorgpacc)*1.0e9/mwdry*..... ! Accumulation mode primary organic aerosol @@ -438,9 +461,16 @@ subroutine sorgam_aqchem_driver( & if (p_hno3 .gt. 1 .and. gas(lhno3) .gt. epsilc) gas_aqfrac(it,kt,jt,p_hno3) = conv_factor*liquid(lhno3l)/gas(lhno3) if (p_h2o2 .gt. 1 .and. gas(lh2o2) .gt. epsilc) gas_aqfrac(it,kt,jt,p_h2o2) = conv_factor*liquid(lh2o2l)/gas(lh2o2) if (p_o3 .gt. 1 .and. gas(lo3) .gt. epsilc) gas_aqfrac(it,kt,jt,p_o3) = conv_factor*liquid(lo3l)/gas(lo3) - if (p_ora1 .gt. 1 .and. gas(lfoa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_ora1) = conv_factor*liquid(lfoal)/gas(lfoa) - if (p_op1 .gt. 1 .and. gas(lmhp) .gt. epsilc) gas_aqfrac(it,kt,jt,p_op1) = conv_factor*liquid(lmhpl)/gas(lmhp) - if (p_paa .gt. 1 .and. gas(lpaa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_paa) = conv_factor*liquid(lpaal)/gas(lpaa) + + if (config_flags%chem_opt==CB05_SORG_AQ_KPP) then + if (p_facd .gt. 1 .and. gas(lfoa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_facd) = conv_factor*liquid(lfoal)/gas(lfoa) + if (p_mepx .gt. 1 .and. gas(lmhp) .gt. epsilc) gas_aqfrac(it,kt,jt,p_mepx) = conv_factor*liquid(lmhpl)/gas(lmhp) + if (p_pacd .gt. 1 .and. gas(lpaa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_pacd) = conv_factor*liquid(lpaal)/gas(lpaa) + else + if (p_ora1 .gt. 1 .and. gas(lfoa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_ora1) = conv_factor*liquid(lfoal)/gas(lfoa) + if (p_op1 .gt. 1 .and. gas(lmhp) .gt. epsilc) gas_aqfrac(it,kt,jt,p_op1) = conv_factor*liquid(lmhpl)/gas(lmhp) + if (p_paa .gt. 1 .and. gas(lpaa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_paa) = conv_factor*liquid(lpaal)/gas(lpaa) + end if endif diff --git a/wrfv2_fire/chem/module_sorgam_cloudchem.F b/wrfv2_fire/chem/module_sorgam_cloudchem.F index 53f5c10c..a9c9d0a7 100644 --- a/wrfv2_fire/chem/module_sorgam_cloudchem.F +++ b/wrfv2_fire/chem/module_sorgam_cloudchem.F @@ -187,7 +187,8 @@ subroutine sorgam_cloudchem_driver( & ph_aq_box, gas_aqfrac_box, & numgas_aqfrac, it, jt, kt, icase, & rbox, qcldwtr, & - t_phy(it,kt,jt), p_phy(it,kt,jt), rho_phy(it,kt,jt) ) + t_phy(it,kt,jt), p_phy(it,kt,jt), rho_phy(it,kt,jt), & + config_flags) ! map back to wrf-chem 3d arrays chem(it,kt,jt,1:num_chem) = rbox(1:num_chem) @@ -214,8 +215,10 @@ subroutine sorgam_cloudchem_1box( & photol_no2_box, & ph_aq_box, gas_aqfrac_box, & numgas_aqfrac, it, jt, kt, icase, & - rbox, qcw_box, temp_box, pres_box, rho_box ) + rbox, qcw_box, temp_box, pres_box, rho_box, & + config_flags ) + use module_configure, only: grid_config_rec_type use module_state_description, only: & num_moist, num_chem @@ -223,7 +226,8 @@ subroutine sorgam_cloudchem_1box( & msectional, maxd_asize, maxd_atype, & cw_phase, nsize_aer, ntype_aer, do_cloudchem_aer, & lptr_so4_aer, lptr_no3_aer, lptr_nh4_aer, & - lptr_orgpa_aer, lptr_ec_aer, lptr_p25_aer + lptr_orgpa_aer, lptr_ec_aer, lptr_p25_aer, & + lptr_cl_aer, lptr_na_aer use module_data_cmu_bulkaqchem, only: & meqn1max @@ -232,6 +236,8 @@ subroutine sorgam_cloudchem_1box( & implicit none ! subr arguments + + type(grid_config_rec_type), intent(in) :: config_flags integer, intent(in) :: & id, ktau, ktauc, & numgas_aqfrac, it, jt, kt, & @@ -281,8 +287,10 @@ subroutine sorgam_cloudchem_1box( & lptr_yyy_cwaer(:,:,l_oin_aqyy) = lptr_p25_aer(:,:,iphase) lptr_yyy_cwaer(:,:,l_bc_aqyy ) = lptr_ec_aer( :,:,iphase) lptr_yyy_cwaer(:,:,l_oc_aqyy ) = lptr_orgpa_aer( :,:,iphase) - lptr_yyy_cwaer(:,:,l_cl_aqyy ) = -999888777 - lptr_yyy_cwaer(:,:,l_na_aqyy ) = -999888777 +! lptr_yyy_cwaer(:,:,l_cl_aqyy ) = -999888777 +! lptr_yyy_cwaer(:,:,l_na_aqyy ) = -999888777 + lptr_yyy_cwaer(:,:,l_cl_aqyy ) = lptr_cl_aer(:,:,iphase) + lptr_yyy_cwaer(:,:,l_na_aqyy ) = lptr_na_aer(:,:,iphase) ! ! @@ -329,7 +337,8 @@ subroutine sorgam_cloudchem_1box( & co2_mixrat_in, photol_no2_in, xprescribe_ph, & iradical_in, idecomp_hmsa_hso5, & yaq_beg, yaq_end, ph_cmuaq_cur, & - numgas_aqfrac, id, it, jt, kt, ktau, icase_in ) + numgas_aqfrac, id, it, jt, kt, ktau, icase_in, & + config_flags) ph_aq_box = ph_cmuaq_cur @@ -387,14 +396,19 @@ subroutine sorgam_interface_to_aqoperator1( & co2_mixrat_in, photol_no2_in, xprescribe_ph, & iradical_in, idecomp_hmsa_hso5, & yaq_beg, yaq_end, ph_cmuaq_cur, & - numgas_aqfrac, id, it, jt, kt, ktau, icase ) + numgas_aqfrac, id, it, jt, kt, ktau, icase, & + config_flags ) + + use module_configure, only: grid_config_rec_type use module_state_description, only: & num_chem, param_first_scalar, p_qc, & p_nh3, p_hno3, p_hcl, p_sulf, p_hcho, & p_ora1, p_so2, p_h2o2, p_o3, p_ho, & p_ho2, p_no3, p_no, p_no2, p_hono, & - p_pan, p_ch3o2, p_ch3oh, p_op1 + p_pan, p_ch3o2, p_ch3oh, p_op1, & + p_form, p_facd, p_oh, p_meo2, p_meoh, p_mepx, & + CB05_SORG_AQ_KPP use module_data_cmu_bulkaqchem, only: & meqn1max, naers, ngas, & @@ -410,12 +424,15 @@ subroutine sorgam_interface_to_aqoperator1( & maxd_asize, maxd_atype, & cw_phase, nsize_aer, ntype_aer, do_cloudchem_aer, & lptr_so4_aer, lptr_no3_aer, lptr_nh4_aer, & - lptr_orgpa_aer, lptr_ec_aer, lptr_p25_aer - + lptr_orgpa_aer, lptr_ec_aer, lptr_p25_aer, & + lptr_cl_aer, lptr_na_aer implicit none ! subr arguments + + type(grid_config_rec_type), intent(in) :: config_flags + integer, intent(in) :: & iradical_in, idecomp_hmsa_hso5, & numgas_aqfrac, id, it, jt, kt, ktau, icase @@ -550,12 +567,12 @@ subroutine sorgam_interface_to_aqoperator1( & if (p_hcl >= p1st) gas(ngc ) = rbox(p_hcl )*factgas if (p_sulf >= p1st) gas(ng4 ) = rbox(p_sulf )*factgas - if (p_hcho >= p1st) gas(nghcho ) = rbox(p_hcho )*factgas - if (p_ora1 >= p1st) gas(nghcooh ) = rbox(p_ora1 )*factgas +! if (p_hcho >= p1st) gas(nghcho ) = rbox(p_hcho )*factgas +! if (p_ora1 >= p1st) gas(nghcooh ) = rbox(p_ora1 )*factgas if (p_so2 >= p1st) gas(ngso2 ) = rbox(p_so2 )*factgas if (p_h2o2 >= p1st) gas(ngh2o2 ) = rbox(p_h2o2 )*factgas if (p_o3 >= p1st) gas(ngo3 ) = rbox(p_o3 )*factgas - if (p_ho >= p1st) gas(ngoh ) = rbox(p_ho )*factgas +! if (p_ho >= p1st) gas(ngoh ) = rbox(p_ho )*factgas if (p_ho2 >= p1st) gas(ngho2 ) = rbox(p_ho2 )*factgas if (p_no3 >= p1st) gas(ngno3 ) = rbox(p_no3 )*factgas @@ -563,9 +580,29 @@ subroutine sorgam_interface_to_aqoperator1( & if (p_no2 >= p1st) gas(ngno2 ) = rbox(p_no2 )*factgas if (p_hono >= p1st) gas(nghno2 ) = rbox(p_hono )*factgas if (p_pan >= p1st) gas(ngpan ) = rbox(p_pan )*factgas - if (p_ch3o2 >= p1st) gas(ngch3o2 ) = rbox(p_ch3o2)*factgas - if (p_ch3oh >= p1st) gas(ngch3oh ) = rbox(p_ch3oh)*factgas - if (p_op1 >= p1st) gas(ngch3o2h) = rbox(p_op1 )*factgas +! if (p_ch3o2 >= p1st) gas(ngch3o2 ) = rbox(p_ch3o2)*factgas +! if (p_ch3oh >= p1st) gas(ngch3oh ) = rbox(p_ch3oh)*factgas +! if (p_op1 >= p1st) gas(ngch3o2h) = rbox(p_op1 )*factgas + + if ((config_flags%chem_opt == CB05_SORG_AQ_KPP)) then + + if (p_form >= p1st) gas(nghcho ) = rbox(p_form )*factgas + if (p_facd >= p1st) gas(nghcooh ) = rbox(p_facd )*factgas + if (p_oh >= p1st) gas(ngoh ) = rbox(p_oh )*factgas + if (p_meo2 >= p1st) gas(ngch3o2 ) = rbox(p_meo2 )*factgas + if (p_meoh >= p1st) gas(ngch3oh ) = rbox(p_meoh )*factgas + if (p_mepx >= p1st) gas(ngch3o2h) = rbox(p_mepx )*factgas + + else + + if (p_hcho >= p1st) gas(nghcho ) = rbox(p_hcho )*factgas + if (p_ora1 >= p1st) gas(nghcooh ) = rbox(p_ora1 )*factgas + if (p_ho >= p1st) gas(ngoh ) = rbox(p_ho )*factgas + if (p_ch3o2 >= p1st) gas(ngch3o2 ) = rbox(p_ch3o2)*factgas + if (p_ch3oh >= p1st) gas(ngch3oh ) = rbox(p_ch3oh)*factgas + if (p_op1 >= p1st) gas(ngch3o2h) = rbox(p_op1 )*factgas + + endif ! compute bulk activated-aerosol mixing ratios aerosol(:) = 0.0 @@ -815,16 +852,16 @@ subroutine sorgam_interface_to_aqoperator1( & gas_aqfrac_box(p_sulf ) = gas_aqfrac_cmu(ng4 ) end if - if (p_hcho >= p1st) then - rbox(p_hcho ) = gas(nghcho )/factgas - if (p_hcho <= numgas_aqfrac) & - gas_aqfrac_box(p_hcho ) = gas_aqfrac_cmu(nghcho ) - end if - if (p_ora1 >= p1st) then - rbox(p_ora1 ) = gas(nghcooh )/factgas - if (p_ora1 <= numgas_aqfrac) & - gas_aqfrac_box(p_ora1 ) = gas_aqfrac_cmu(nghcooh ) - end if +! if (p_hcho >= p1st) then +! rbox(p_hcho ) = gas(nghcho )/factgas +! if (p_hcho <= numgas_aqfrac) & +! gas_aqfrac_box(p_hcho ) = gas_aqfrac_cmu(nghcho ) +! end if +! if (p_ora1 >= p1st) then +! rbox(p_ora1 ) = gas(nghcooh )/factgas +! if (p_ora1 <= numgas_aqfrac) & +! gas_aqfrac_box(p_ora1 ) = gas_aqfrac_cmu(nghcooh ) +! end if if (p_so2 >= p1st) then rbox(p_so2 ) = gas(ngso2 )/factgas if (p_so2 <= numgas_aqfrac) & @@ -840,11 +877,11 @@ subroutine sorgam_interface_to_aqoperator1( & if (p_o3 <= numgas_aqfrac) & gas_aqfrac_box(p_o3 ) = gas_aqfrac_cmu(ngo3 ) end if - if (p_ho >= p1st) then - rbox(p_ho ) = gas(ngoh )/factgas - if (p_ho <= numgas_aqfrac) & - gas_aqfrac_box(p_ho ) = gas_aqfrac_cmu(ngoh ) - end if +! if (p_ho >= p1st) then +! rbox(p_ho ) = gas(ngoh )/factgas +! if (p_ho <= numgas_aqfrac) & +! gas_aqfrac_box(p_ho ) = gas_aqfrac_cmu(ngoh ) +! end if if (p_ho2 >= p1st) then rbox(p_ho2 ) = gas(ngho2 )/factgas if (p_ho2 <= numgas_aqfrac) & @@ -876,22 +913,88 @@ subroutine sorgam_interface_to_aqoperator1( & if (p_pan <= numgas_aqfrac) & gas_aqfrac_box(p_pan ) = gas_aqfrac_cmu(ngpan ) end if - if (p_ch3o2 >= p1st) then - rbox(p_ch3o2) = gas(ngch3o2 )/factgas - if (p_ch3o2 <= numgas_aqfrac) & - gas_aqfrac_box(p_ch3o2 ) = gas_aqfrac_cmu(ngch3o2 ) - end if - if (p_ch3oh >= p1st) then - rbox(p_ch3oh) = gas(ngch3oh )/factgas - if (p_ch3oh <= numgas_aqfrac) & - gas_aqfrac_box(p_ch3oh ) = gas_aqfrac_cmu(ngch3oh ) - end if - if (p_op1 >= p1st) then - rbox(p_op1 ) = gas(ngch3o2h)/factgas - if (p_op1 <= numgas_aqfrac) & - gas_aqfrac_box(p_op1 ) = gas_aqfrac_cmu(ngch3o2h) - end if - +! if (p_ch3o2 >= p1st) then +! rbox(p_ch3o2) = gas(ngch3o2 )/factgas +! if (p_ch3o2 <= numgas_aqfrac) & +! gas_aqfrac_box(p_ch3o2 ) = gas_aqfrac_cmu(ngch3o2 ) +! end if +! if (p_ch3oh >= p1st) then +! rbox(p_ch3oh) = gas(ngch3oh )/factgas +! if (p_ch3oh <= numgas_aqfrac) & +! gas_aqfrac_box(p_ch3oh ) = gas_aqfrac_cmu(ngch3oh ) +! end if +! if (p_op1 >= p1st) then +! rbox(p_op1 ) = gas(ngch3o2h)/factgas +! if (p_op1 <= numgas_aqfrac) & +! gas_aqfrac_box(p_op1 ) = gas_aqfrac_cmu(ngch3o2h) +! end if + +! + if ( (config_flags%chem_opt == CB05_SORG_AQ_KPP) ) then + + if (p_form >= p1st) then + rbox(p_form ) = gas(nghcho )/factgas + if (p_form <= numgas_aqfrac) & + gas_aqfrac_box(p_form ) = gas_aqfrac_cmu(nghcho ) + end if + if (p_facd >= p1st) then + rbox(p_facd ) = gas(nghcooh )/factgas + if (p_facd <= numgas_aqfrac) & + gas_aqfrac_box(p_facd ) = gas_aqfrac_cmu(nghcooh ) + end if + if (p_oh >= p1st) then + rbox(p_oh ) = gas(ngoh )/factgas + if (p_oh <= numgas_aqfrac) & + gas_aqfrac_box(p_oh ) = gas_aqfrac_cmu(ngoh ) + end if + if (p_meo2 >= p1st) then + rbox(p_meo2 ) = gas(ngch3o2 )/factgas + if (p_meo2 <= numgas_aqfrac) & + gas_aqfrac_box(p_meo2 ) = gas_aqfrac_cmu(ngch3o2 ) + end if + if (p_meoh >= p1st) then + rbox(p_meoh ) = gas(ngch3oh )/factgas + if (p_meoh <= numgas_aqfrac) & + gas_aqfrac_box(p_meoh ) = gas_aqfrac_cmu(ngch3oh ) + end if + if (p_mepx >= p1st) then + rbox(p_mepx ) = gas(ngch3o2h)/factgas + if (p_mepx <= numgas_aqfrac) & + gas_aqfrac_box(p_mepx ) = gas_aqfrac_cmu(ngch3o2h) + end if + else + if (p_hcho >= p1st) then + rbox(p_hcho ) = gas(nghcho )/factgas + if (p_hcho <= numgas_aqfrac) & + gas_aqfrac_box(p_hcho ) = gas_aqfrac_cmu(nghcho ) + end if + if (p_ora1 >= p1st) then + rbox(p_ora1 ) = gas(nghcooh )/factgas + if (p_ora1 <= numgas_aqfrac) & + gas_aqfrac_box(p_ora1 ) = gas_aqfrac_cmu(nghcooh ) + end if + if (p_ho >= p1st) then + rbox(p_ho ) = gas(ngoh )/factgas + if (p_ho <= numgas_aqfrac) & + gas_aqfrac_box(p_ho ) = gas_aqfrac_cmu(ngoh ) + end if + if (p_ch3o2 >= p1st) then + rbox(p_ch3o2) = gas(ngch3o2 )/factgas + if (p_ch3o2 <= numgas_aqfrac) & + gas_aqfrac_box(p_ch3o2 ) = gas_aqfrac_cmu(ngch3o2 ) + end if + if (p_ch3oh >= p1st) then + rbox(p_ch3oh) = gas(ngch3oh )/factgas + if (p_ch3oh <= numgas_aqfrac) & + gas_aqfrac_box(p_ch3oh ) = gas_aqfrac_cmu(ngch3oh ) + end if + if (p_op1 >= p1st) then + rbox(p_op1 ) = gas(ngch3o2h)/factgas + if (p_op1 <= numgas_aqfrac) & + gas_aqfrac_box(p_op1 ) = gas_aqfrac_cmu(ngch3o2h) + end if + + end if rbulk_cwaer(l_so4_aqyy,2) = aerosol(na4)/factaerso4 rbulk_cwaer(l_no3_aqyy,2) = aerosol(nan)/factaerno3 diff --git a/wrfv2_fire/chem/module_sorgam_vbs_aqchem.F b/wrfv2_fire/chem/module_sorgam_vbs_aqchem.F new file mode 100644 index 00000000..5651be05 --- /dev/null +++ b/wrfv2_fire/chem/module_sorgam_vbs_aqchem.F @@ -0,0 +1,500 @@ +module module_sorgam_vbs_aqchem + + ! NOTE: This is an initial attempt at the implementation of AQCHEM with + ! the MADE/SORGAM aerosol scheme. It needs to be checked and tested. + ! + ! jan.kazil@noaa.gov 2011-08-14 17:15:39 -06:00 + + REAL, PARAMETER :: epsilc = 1.0E-16 + + REAL, PARAMETER :: qcldwtr_cutoff = 1.0e-6 ! Cloud threshold (kg/kg) + + REAL, PARAMETER :: mwdry = 28.966 ! Molecular mass of dry air (g/mol) + REAL, PARAMETER :: mwso4 = 96.00 ! Molecular mass of SO4-- (g/mol) + REAL, PARAMETER :: mwno3 = 62.0 ! Molecular mass of NO3- (g/mol) + REAL, PARAMETER :: mwnh4 = 18.0985 ! Molecular mass of NH4+ (g/mol) + REAL, PARAMETER :: mwna = 22.990 ! Molecular mass of NH4+ (g/mol) + REAL, PARAMETER :: mwcl = 35.453 ! Molecular mass of NH4+ (g/mol) + + ! AQCHEM parameters + + INTEGER, PARAMETER :: NGAS = 12 ! number of gas-phase species for AQCHEM + INTEGER, PARAMETER :: NAER = 36 ! number of aerosol species for AQCHEM + INTEGER, PARAMETER :: NLIQS = 41 ! number of liquid-phase species in AQCHEM + + ! Indices for the AQCHEM array GAS + + INTEGER, PARAMETER :: LSO2 = 1 ! Sulfur Dioxide + INTEGER, PARAMETER :: LHNO3 = 2 ! Nitric Acid + INTEGER, PARAMETER :: LN2O5 = 3 ! Dinitrogen Pentoxide + INTEGER, PARAMETER :: LCO2 = 4 ! Carbon Dioxide + INTEGER, PARAMETER :: LNH3 = 5 ! Ammonia + INTEGER, PARAMETER :: LH2O2 = 6 ! Hydrogen Perioxide + INTEGER, PARAMETER :: LO3 = 7 ! Ozone + INTEGER, PARAMETER :: LFOA = 8 ! Formic Acid + INTEGER, PARAMETER :: LMHP = 9 ! Methyl Hydrogen Peroxide + INTEGER, PARAMETER :: LPAA = 10 ! Peroxyacidic Acid + INTEGER, PARAMETER :: LH2SO4 = 11 ! Sulfuric Acid + INTEGER, PARAMETER :: LHCL = 12 ! Hydrogen Chloride + + ! Indices for the AQCHEM array AEROSOL + + INTEGER, PARAMETER :: LSO4AKN = 1 ! Aitken mode Sulfate + INTEGER, PARAMETER :: LSO4ACC = 2 ! Accumulation mode Sulfate + INTEGER, PARAMETER :: LSO4COR = 3 ! Coarse mode Sulfate + INTEGER, PARAMETER :: LNH4AKN = 4 ! Aitken mode Ammonium + INTEGER, PARAMETER :: LNH4ACC = 5 ! Accumulation mode Ammonium + INTEGER, PARAMETER :: LNO3AKN = 6 ! Aitken mode Nitrate + INTEGER, PARAMETER :: LNO3ACC = 7 ! Accumulation mode Nitrate + INTEGER, PARAMETER :: LNO3COR = 8 ! Coarse mode Nitrate + INTEGER, PARAMETER :: LORGAAKN = 9 ! Aitken mode anthropogenic SOA + INTEGER, PARAMETER :: LORGAACC = 10 ! Accumulation mode anthropogenic SOA + INTEGER, PARAMETER :: LORGPAKN = 11 ! Aitken mode primary organic aerosol + INTEGER, PARAMETER :: LORGPACC = 12 ! Accumulation mode primary organic aerosol + INTEGER, PARAMETER :: LORGBAKN = 13 ! Aitken mode biogenic SOA + INTEGER, PARAMETER :: LORGBACC = 14 ! Accumulation mode biogenic SOA + INTEGER, PARAMETER :: LECAKN = 15 ! Aitken mode elemental carbon + INTEGER, PARAMETER :: LECACC = 16 ! Accumulation mode elemental carbon + INTEGER, PARAMETER :: LPRIAKN = 17 ! Aitken mode primary aerosol + INTEGER, PARAMETER :: LPRIACC = 18 ! Accumulation mode primary aerosol + INTEGER, PARAMETER :: LPRICOR = 19 ! Coarse mode primary aerosol + INTEGER, PARAMETER :: LNAAKN = 20 ! Aitken mode Sodium + INTEGER, PARAMETER :: LNAACC = 21 ! Accumulation mode Sodium + INTEGER, PARAMETER :: LNACOR = 22 ! Coarse mode Sodium + INTEGER, PARAMETER :: LCLAKN = 23 ! Aitken mode Chloride ion + INTEGER, PARAMETER :: LCLACC = 24 ! Accumulation mode Chloride ion + INTEGER, PARAMETER :: LCLCOR = 25 ! Coarse mode Chloride ion + INTEGER, PARAMETER :: LNUMAKN = 26 ! Aitken mode number + INTEGER, PARAMETER :: LNUMACC = 27 ! Accumulation mode number + INTEGER, PARAMETER :: LNUMCOR = 28 ! Coarse mode number + INTEGER, PARAMETER :: LSRFAKN = 29 ! Aitken mode surface area + INTEGER, PARAMETER :: LSRFACC = 30 ! Accumulation mode surface area + INTEGER, PARAMETER :: LNACL = 31 ! Sodium Chloride aerosol for AE3 only {depreciated in AE4} + INTEGER, PARAMETER :: LCACO3 = 32 ! Calcium Carbonate aerosol (place holder) + INTEGER, PARAMETER :: LMGCO3 = 33 ! Magnesium Carbonate aerosol (place holder) + INTEGER, PARAMETER :: LA3FE = 34 ! Iron aerosol (place holder) + INTEGER, PARAMETER :: LB2MN = 35 ! Manganese aerosol (place holder) + INTEGER, PARAMETER :: LK = 36 ! Potassium aerosol (Cl- tracked separately) (place holder) + + ! Indices for the AQCHEM arrays LIQUID and WETDEP + + INTEGER, PARAMETER :: LACL = 1 ! Hydrogen ion + INTEGER, PARAMETER :: LNH4L = 2 ! Ammonium + INTEGER, PARAMETER :: LCAL = 3 ! Calcium + INTEGER, PARAMETER :: LNAACCL = 4 ! Sodium + INTEGER, PARAMETER :: LOHL = 5 ! Hydroxyl radical ion + INTEGER, PARAMETER :: LSO4ACCL = 6 ! Sulfate (attributed to accumulation mode) + INTEGER, PARAMETER :: LHSO4ACCL = 7 ! bisulfate (attributed to accumulation mode) + INTEGER, PARAMETER :: LSO3L = 8 ! sulfite + INTEGER, PARAMETER :: LHSO3L = 9 ! bisulfite + INTEGER, PARAMETER :: LSO2L = 10 ! sulfur dioxide + INTEGER, PARAMETER :: LCO3L = 11 ! carbonate + INTEGER, PARAMETER :: LHCO3L = 12 ! bicarbonate + INTEGER, PARAMETER :: LCO2L = 13 ! carbon dioxide + INTEGER, PARAMETER :: LNO3ACCL = 14 ! nitrate(attributed to accumulation mode) + INTEGER, PARAMETER :: LNH3L = 15 ! ammonia + INTEGER, PARAMETER :: LCLACCL = 16 ! chloride ion (attributed to accumulation mode) + INTEGER, PARAMETER :: LH2O2L = 17 ! hydrogen peroxide + INTEGER, PARAMETER :: LO3L = 18 ! ozone + INTEGER, PARAMETER :: LFEL = 19 ! iron + INTEGER, PARAMETER :: LMNL = 20 ! Manganese + INTEGER, PARAMETER :: LAL = 21 ! generalized anion associated with iron + INTEGER, PARAMETER :: LFOAL = 22 ! Formic acid + INTEGER, PARAMETER :: LHCO2L = 23 ! HCOO- ion + INTEGER, PARAMETER :: LMHPL = 24 ! Methyl hydrogen peroxide + INTEGER, PARAMETER :: LPAAL = 25 ! Peroxyacidic acid + INTEGER, PARAMETER :: LHCLL = 26 ! Hydrogen chloride + INTEGER, PARAMETER :: LPRIML = 27 ! primary aerosol + INTEGER, PARAMETER :: LMGL = 28 ! Magnesium + INTEGER, PARAMETER :: LKL = 29 ! potassium + INTEGER, PARAMETER :: LBL = 30 ! generalized anion associated with manganese + INTEGER, PARAMETER :: LHNO3L = 31 ! nitric acid + INTEGER, PARAMETER :: LPRIMCORL = 32 ! coarse-mode primary aerosol + INTEGER, PARAMETER :: LNUMCORL = 33 ! coarse-mode number + INTEGER, PARAMETER :: LTS6CORL = 34 ! sulfate (attributed to coarse mode) + INTEGER, PARAMETER :: LNACORL = 35 ! sodium (attributed to coarse mode) + INTEGER, PARAMETER :: LCLCORL = 36 ! chloride ion (attributed to coarse mode) + INTEGER, PARAMETER :: LNO3CORL = 37 ! nitrate (attributed to coarse mode) + INTEGER, PARAMETER :: LORGAL = 38 ! anthropogenic SOA + INTEGER, PARAMETER :: LORGPL = 39 ! primary organic aerosols + INTEGER, PARAMETER :: LORGBL = 40 ! biogenic SOA + INTEGER, PARAMETER :: LECL = 41 ! elemental carbon + + contains + +!------------------------------------------------------------------------------- + + subroutine sorgam_vbs_aqchem_driver( & + id, ktau, ktauc, dtstepc, config_flags, & + p_phy, t_phy, rho_phy, alt, dz8w, & + moist, chem, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + use module_ctrans_aqchem, only: aqchem + + use module_configure, only: grid_config_rec_type + + use module_state_description, only: & + num_chem, & + num_moist, & +! p_co2, & + p_so2, & + p_sulf, & + p_nh3, & + p_h2o2, & + p_o3, & + p_op1, & + p_ora1, & + p_paa, & + p_hno3, & + p_n2o5, & + p_so4cwi, & + p_nh4cwi, & + p_no3cwi, & + p_so4cwj, & + p_nh4cwj, & + p_no3cwj, & + p_nacwi, & + p_nacwj, & + p_clcwi, & + p_clcwj, & +! p_so4cwk, & +! p_no3cwk, & + p_qv, & + p_qc, & +!KW + p_facd, & + p_mepx, & + p_pacd, & + CB05_SORG_VBS_AQ_KPP + + use module_data_sorgam_vbs, only: cw_phase, nphase_aer + + implicit none + + ! + ! Arguments + ! + + ! id - domain index + ! ktau - time step number + ! ktauc - gas and aerosol chemistry time step number + ! numgas_aqfrac - last dimension of gas_aqfrac + + ! [ids:ide, kds:kde, jds:jde] - spatial (x,z,y) indices for 'domain' + ! [ims:ime, kms:kme, jms:jme] - spatial (x,z,y) indices for 'memory' + ! Most arrays that are arguments to chem_driver + ! are dimensioned with these spatial indices. + ! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for 'tile' + ! chem_driver and routines under it do calculations + ! over these spatial indices. + + integer, intent(in) :: & + id, ktau, ktauc, & + numgas_aqfrac, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + ! Configuration and control parameters: + type(grid_config_rec_type), intent(in) :: config_flags + + ! Time step for gas and aerosol chemistry(s): + real, intent(in) :: dtstepc + + ! p_phy - air pressure (Pa) + ! t_phy - temperature (K) + ! rho_phy - moist air density (kg/m^3) + ! alt - dry air specific volume (m^3/kg) + ! dz8w - level height (m) + + real, intent(in), dimension( ims:ime, kms:kme, jms:jme ) :: & + p_phy, t_phy, rho_phy, alt, dz8w + + ! Mixing ratios of moisture species (water vapor, + ! cloud water, ...) (kg/kg for mass species, #/kg for number species): + + real, intent(in), dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: moist + + ! Mixing ratios of trace gas and aerosol species (ppm for gases, + ! ug/kg for aerosol mass species, #/kg for aerosol number species): + + real, intent(inout), dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: chem + + ! Fraction (0-1) of gas that is dissolved in cloud water: + + real, intent(inout), dimension( ims:ime, kms:kme, jms:jme, numgas_aqfrac ) :: gas_aqfrac + + ! + ! I/O for AQCHEM + ! + + real, dimension (ngas) :: gas ! Mixing ratio of gas phase species (in gas + liquid phase) (mol/mol) + real, dimension (naer) :: aerosol ! Mixing ratio of aerosol species (mass/number/surface area in liquid phase) (mol/mol, #/mol) + real, dimension (nliqs) :: liquid ! mol/liter + + real, dimension (ngas) :: gaswdep ! mm mol/liter + real, dimension (naer) :: aerwdep ! mm mol/liter + real :: hpwdep ! mm mol/liter + + real :: precip ! Precipitation rate (mm/h) + real :: airm ! Column air number density (mol/m2) + real :: rho_dry ! Dry air mass density (kg/m3) + real :: h2o_aq ! Liquid water content ! (kg/m3) + real :: h2o_total ! Total water content ! (kg/m3) + + real :: alfa0 ! Scavenging coeffficient for Aitken aerosol number + real :: alfa2 ! Scavenging coeffficient for Aitken aerosol surface area + real :: alfa3 ! Scavenging coeffficient for Aitken aerosol mass + + ! + ! Other local variables + ! + + integer :: it, jt, kt + + real :: conv_factor + + ! Check that cw_phase is active +!KW print*,"in sorgam_vbs_aqchem cw_phase=",cw_phase + if ((cw_phase .le. 0) .or. (cw_phase .gt. nphase_aer)) then + write(*,*) '*** module_sorgam_aqchem - cw_phase not active' + return + endif + + write(*,'(a,8(1x,i6))') 'entering module_sorgam_aqchem - ktau =', ktau + + ! We set the precipitation rate and aerosol scavenging rates to zero, + ! in order to prevent wet scavenging in AQCHEM (it is treated elswhere): + + precip = 0.0 ! mm/hr + + alfa0 = 0.0 + alfa2 = 0.0 + alfa3 = 0.0 + + ! Wet scavenging arrays + + gaswdep(:) = 0.0 + aerwdep(:) = 0.0 + hpwdep = 0.0 + + ! Loop over tile + + do jt = jts, jte + do it = its, ite + do kt = kts, kte + + if (moist(it,kt,jt,p_qc).gt.qcldwtr_cutoff) then + + ! Column air number density in layer: + airm = 1000.0*rho_phy(it,kt,jt)*dz8w(it,kt,jt)/mwdry ! mol/m2 + + ! Dry air mass density + rho_dry = 1.0/alt(it,kt,jt) ! kg/m3 + + ! Liquid water content: + h2o_aq = moist(it,kt,jt,p_qc)*rho_dry ! (kg/m3) + + ! Total water content: + h2o_total = (moist(it,kt,jt,p_qc)+moist(it,kt,jt,p_qv))*rho_dry ! (kg/m3) + + ! Gas phase concentrations before aqueous phase chemistry + ! (with units conversion ppm -> mol/mol) + + gas(:) = 0.0 + +! if (p_co2 .gt. 1) then +! gas(lco2) = chem(it,kt,jt,p_co2)*1.0e-6 +! else + gas(lco2) = 380.0e-6 +! endif + + if (p_so2 .gt. 1) gas(lso2) = chem(it,kt,jt,p_so2)*1.0e-6 + if (p_hno3 .gt. 1) gas(lhno3) = chem(it,kt,jt,p_hno3)*1.0e-6 + if (p_n2o5 .gt. 1) gas(ln2o5) = chem(it,kt,jt,p_n2o5)*1.0e-6 + if (p_nh3 .gt. 1) gas(lnh3) = chem(it,kt,jt,p_nh3)*1.0e-6 + if (p_h2o2 .gt. 1) gas(lh2o2) = chem(it,kt,jt,p_h2o2)*1.0e-6 + if (p_o3 .gt. 1) gas(lo3) = chem(it,kt,jt,p_o3)*1.0e-6 +!KW if (p_ora1 .gt. 1) gas(lfoa) = chem(it,kt,jt,p_ora1)*1.0e-6 +!KW if (p_op1 .gt. 1) gas(lmhp) = chem(it,kt,jt,p_op1)*1.0e-6 +!KW if (p_paa .gt. 1) gas(lpaa) = chem(it,kt,jt,p_paa)*1.0e-6 + if (p_sulf .gt. 1) gas(lh2so4) = chem(it,kt,jt,p_sulf)*1.0e-6 + +!KW + if (config_flags%chem_opt==CB05_SORG_VBS_AQ_KPP) then + if (p_facd .gt. 1) gas(lfoa) = chem(it,kt,jt,p_facd)*1.0e-6 + if (p_mepx .gt. 1) gas(lmhp) = chem(it,kt,jt,p_mepx)*1.0e-6 + if (p_pacd .gt. 1) gas(lpaa) = chem(it,kt,jt,p_pacd)*1.0e-6 +!KW print*,"going for CB05 in AQCHEM" + else + if (p_ora1 .gt. 1) gas(lfoa) = chem(it,kt,jt,p_ora1)*1.0e-6 + if (p_op1 .gt. 1) gas(lmhp) = chem(it,kt,jt,p_op1)*1.0e-6 + if (p_paa .gt. 1) gas(lpaa) = chem(it,kt,jt,p_paa)*1.0e-6 + end if + + ! Aerosol mass concentrations before aqueous phase chemistry + ! (with units conversion ug/kg -> mol/mol). Although AQCHEM + ! accounts for much of the aerosol compounds in MADE, they are + ! not treated at the moment by AQCHEM, as the mapping between + ! the organic compound groups in MADE and AQCHEM is not obvious. + + aerosol(:) = 0.0 + + aerosol(lso4akn) = chem(it,kt,jt,p_so4cwi)*1.0e-9*mwdry/mwso4 ! Aitken mode sulfate + aerosol(lnh4akn) = chem(it,kt,jt,p_nh4cwi)*1.0e-9*mwdry/mwnh4 ! Aitken mode ammonium + aerosol(lno3akn) = chem(it,kt,jt,p_no3cwi)*1.0e-9*mwdry/mwno3 ! Aitken mode nitrate +! aerosol(lnaakn) = chem(it,kt,jt,p_nacwi)*1.0e-9*mwdry/mwna ! Aitken mode Na +! aerosol(lclakn) = chem(it,kt,jt,p_clcwi)*1.0e-9*mwdry/mwcl ! Aitken mode Cl + + aerosol(lorgaakn) = 0.0 ! Aitken mode anthropogenic SOA + aerosol(lorgpakn) = 0.0 ! Aitken mode primary organic aerosol + aerosol(lorgbakn) = 0.0 ! Aitken mode biogenic SOA + aerosol(lecakn) = 0.0 ! Aitken mode elemental carbon + aerosol(lpriakn) = 0.0 ! Aitken mode primary aerosol + + aerosol(lso4acc) = chem(it,kt,jt,p_so4cwj)*1.0e-9*mwdry/mwso4 ! Accumulation mode sulfate + aerosol(lnh4acc) = chem(it,kt,jt,p_nh4cwj)*1.0e-9*mwdry/mwnh4 ! Accumulation mode ammonium + aerosol(lno3acc) = chem(it,kt,jt,p_no3cwj)*1.0e-9*mwdry/mwno3 ! Accumulation mode nitrate + aerosol(lnaacc) = chem(it,kt,jt,p_nacwj)*1.0e-9*mwdry/mwna ! Accumulation mode Na + aerosol(lclacc) = chem(it,kt,jt,p_clcwj)*1.0e-9*mwdry/mwcl ! Accumulation mode Cl + + aerosol(lorgaacc) = 0.0 ! Accumulation mode anthropogenic SOA + aerosol(lorgpacc) = 0.0 ! Accumulation mode primary organic aerosol + aerosol(lorgbacc) = 0.0 ! Accumulation mode biogenic SOA + aerosol(lecacc) = 0.0 ! Accumulation mode elemental carbon + aerosol(lpriacc) = 0.0 ! Accumulation mode primary aerosol + +! aerosol(lso4cor) = chem(it,kt,jt,p_so4cwk)*1.0e-9*mwdry/mwso4 ! Coarse mode sulfate +! aerosol(lno3cor) = chem(it,kt,jt,p_no3cwk)*1.0e-9*mwdry/mwno3 ! Coarse mode nitrate + aerosol(lnacor) = 0.0 ! Coarse mode Na + aerosol(lclcor) = 0.0 ! Coarse mode Cl + aerosol(lpricor) = 0.0 ! Coarse mode primary aerosol + +!KW based on CMAQ prescribled Fe/Mn + aerosol(LA3FE) = 0.01*alt(it,kt,jt)*1.0e-9*mwdry/55.8 + aerosol(LB2MN) = 0.005*alt(it,kt,jt)*1.0e-9*mwdry/54.9 + + ! Liquid phase concentrations + + liquid(:) = 0.0 + + call aqchem( & + t_phy(it,kt,jt), & + p_phy(it,kt,jt), & + dtstepc, & + precip, & + h2o_aq, & + h2o_total, & + airm, & + alfa0, & + alfa2, & + alfa3, & + gas, & + aerosol, & + liquid, & + gaswdep, & + aerwdep, & + hpwdep) + + ! Gas phase concentrations after aqueous phase chemistry + ! (with units conversion mol/mol -> ppm) + +! if (p_co2 .gt. 1) chem(it,kt,jt,p_co2) = gas(lco2)*1.0e6 + if (p_so2 .gt. 1) chem(it,kt,jt,p_so2) = gas(lso2)*1.0e6 + if (p_hno3 .gt. 1) chem(it,kt,jt,p_hno3) = gas(lhno3)*1.0e6 + if (p_n2o5 .gt. 1) chem(it,kt,jt,p_n2o5) = gas(ln2o5)*1.0e6 + if (p_nh3 .gt. 1) chem(it,kt,jt,p_nh3) = gas(lnh3)*1.0e6 + if (p_h2o2 .gt. 1) chem(it,kt,jt,p_h2o2) = gas(lh2o2)*1.0e6 + if (p_o3 .gt. 1) chem(it,kt,jt,p_o3) = gas(lo3)*1.0e6 +!KW if (p_ora1 .gt. 1) chem(it,kt,jt,p_ora1) = gas(lfoa)*1.0e6 +! if (p_op1 .gt. 1) chem(it,kt,jt,p_op1) = gas(lmhp)*1.0e6 +! if (p_paa .gt. 1) chem(it,kt,jt,p_paa) = gas(lpaa)*1.0e6 + if (p_sulf .gt. 1) chem(it,kt,jt,p_sulf) = gas(lh2so4)*1.0e6 + +!KW + if (config_flags%chem_opt==CB05_SORG_VBS_AQ_KPP) then + if (p_facd .gt. 1) chem(it,kt,jt,p_facd) = gas(lfoa)*1.0e6 + if (p_mepx .gt. 1) chem(it,kt,jt,p_mepx) = gas(lmhp)*1.0e6 + if (p_pacd .gt. 1) chem(it,kt,jt,p_pacd) = gas(lpaa)*1.0e6 +!KW print*,"going for CB05 in AQCHEM" + else + if (p_ora1 .gt. 1) chem(it,kt,jt,p_ora1) = gas(lfoa)*1.0e6 + if (p_op1 .gt. 1) chem(it,kt,jt,p_op1) = gas(lmhp)*1.0e6 + if (p_paa .gt. 1) chem(it,kt,jt,p_paa) = gas(lpaa)*1.0e6 + end if + + ! Aerosol mass concentrations after aqueous phase chemistry + ! (with units conversion mol/mol -> ug/kg) + + chem(it,kt,jt,p_so4cwi) = aerosol(lso4akn) *1.0e9/mwdry*mwso4 ! Aitken mode sulfate + chem(it,kt,jt,p_nh4cwi) = aerosol(lnh4akn) *1.0e9/mwdry*mwnh4 ! Aitken mode ammonium + chem(it,kt,jt,p_no3cwi) = aerosol(lno3akn) *1.0e9/mwdry*mwno3 ! Aitken mode nitrate + chem(it,kt,jt,p_nacwi) = aerosol(lnaakn) *1.0e9/mwdry*mwna ! Aitken mode Na + chem(it,kt,jt,p_clcwi) = aerosol(lclakn) *1.0e9/mwdry*mwcl ! Aitken mode Cl + +! chem(it,kt,jt,........) = aerosol(lorgaakn)*1.0e9/mwdry*..... ! Aitken mode anthropogenic SOA +! chem(it,kt,jt,........) = aerosol(lorgpakn)*1.0e9/mwdry*..... ! Aitken mode primary organic aerosol +! chem(it,kt,jt,........) = aerosol(lorgbakn)*1.0e9/mwdry*..... ! Aitken mode biogenic SOA +! chem(it,kt,jt,........) = aerosol(lecakn) *1.0e9/mwdry*..... ! Aitken mode elemental carbon +! chem(it,kt,jt,........) = aerosol(lpriakn) *1.0e9/mwdry*..... ! Aitken mode primary aerosol + + chem(it,kt,jt,p_so4cwj) = aerosol(lso4acc) *1.0e9/mwdry*mwso4 ! Accumulation mode sulfate + chem(it,kt,jt,p_nh4cwj) = aerosol(lnh4acc) *1.0e9/mwdry*mwnh4 ! Accumulation mode ammonium + chem(it,kt,jt,p_no3cwj) = aerosol(lno3acc) *1.0e9/mwdry*mwno3 ! Accumulation mode nitrate + chem(it,kt,jt,p_nacwj) = aerosol(lnaacc) *1.0e9/mwdry*mwna ! Accumulation mode Na + chem(it,kt,jt,p_clcwj) = aerosol(lclacc) *1.0e9/mwdry*mwcl ! Accumulation mode Cl + +! chem(it,kt,jt,........) = aerosol(lorgaacc)*1.0e9/mwdry*..... ! Accumulation mode anthropogenic SOA +! chem(it,kt,jt,........) = aerosol(lorgpacc)*1.0e9/mwdry*..... ! Accumulation mode primary organic aerosol +! chem(it,kt,jt,........) = aerosol(lorgbacc)*1.0e9/mwdry*..... ! Accumulation mode biogenic SOA +! chem(it,kt,jt,........) = aerosol(lecacc) *1.0e9/mwdry*..... ! Accumulation mode elemental carbon +! chem(it,kt,jt,........) = aerosol(lpriacc) *1.0e9/mwdry*..... ! Accumulation mode primary aerosol + +! chem(it,kt,jt,p_so4cwk) = aerosol(lso4cor) *1.0e9/mwdry*mwso4 ! Coarse mode sulfate +! chem(it,kt,jt,p_no3cwk) = aerosol(lno3cor) *1.0e9/mwdry*mwno3 ! Coarse mode nitrate +! chem(it,kt,jt,........) = aerosol(lnacor) *1.0e9/mwdry*..... ! Coarse mode Na +! chem(it,kt,jt,........) = aerosol(lclcor) *1.0e9/mwdry*..... ! Coarse mode Cl +! chem(it,kt,jt,........) = aerosol(lpricor) *1.0e9/mwdry*..... ! Coarse mode primary aerosol + + ! Fraction of gas phase species dissolved in liquid water: + + gas_aqfrac(it,kt,jt,:) = 0.0 + + conv_factor = 1.0E-3*moist(it,kt,jt,p_qc)*mwdry ! mol/liter -> mol/mol + +! if (p_co2 .gt. 1 .and. gas(lco2) .gt. epsilc) gas_aqfrac(it,kt,jt,p_co2) = conv_factor*liquid(lco2l)/gas(lco2) + if (p_so2 .gt. 1 .and. gas(lso2) .gt. epsilc) gas_aqfrac(it,kt,jt,p_so2) = conv_factor*liquid(lso2l)/gas(lso2) + if (p_nh3 .gt. 1 .and. gas(lnh3) .gt. epsilc) gas_aqfrac(it,kt,jt,p_nh3) = conv_factor*liquid(lnh3l)/gas(lnh3) + if (p_hno3 .gt. 1 .and. gas(lhno3) .gt. epsilc) gas_aqfrac(it,kt,jt,p_hno3) = conv_factor*liquid(lhno3l)/gas(lhno3) + if (p_h2o2 .gt. 1 .and. gas(lh2o2) .gt. epsilc) gas_aqfrac(it,kt,jt,p_h2o2) = conv_factor*liquid(lh2o2l)/gas(lh2o2) + if (p_o3 .gt. 1 .and. gas(lo3) .gt. epsilc) gas_aqfrac(it,kt,jt,p_o3) = conv_factor*liquid(lo3l)/gas(lo3) +!KW +!KW + if (config_flags%chem_opt==CB05_SORG_VBS_AQ_KPP) then + if (p_facd .gt. 1 .and. gas(lfoa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_facd) = conv_factor*liquid(lfoal)/gas(lfoa) + if (p_mepx .gt. 1 .and. gas(lmhp) .gt. epsilc) gas_aqfrac(it,kt,jt,p_mepx) = conv_factor*liquid(lmhpl)/gas(lmhp) + if (p_pacd .gt. 1 .and. gas(lpaa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_pacd) = conv_factor*liquid(lpaal)/gas(lpaa) +!KW print*,"going for CB05 in AQCHEM" + else + if (p_ora1 .gt. 1 .and. gas(lfoa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_ora1) = conv_factor*liquid(lfoal)/gas(lfoa) + if (p_op1 .gt. 1 .and. gas(lmhp) .gt. epsilc) gas_aqfrac(it,kt,jt,p_op1) = conv_factor*liquid(lmhpl)/gas(lmhp) + if (p_paa .gt. 1 .and. gas(lpaa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_paa) = conv_factor*liquid(lpaal)/gas(lpaa) + end if + +! if (p_ora1 .gt. 1 .and. gas(lfoa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_ora1) = conv_factor*liquid(lfoal)/gas(lfoa) +! if (p_op1 .gt. 1 .and. gas(lmhp) .gt. epsilc) gas_aqfrac(it,kt,jt,p_op1) = conv_factor*liquid(lmhpl)/gas(lmhp) +! if (p_paa .gt. 1 .and. gas(lpaa) .gt. epsilc) gas_aqfrac(it,kt,jt,p_paa) = conv_factor*liquid(lpaal)/gas(lpaa) + + endif + + enddo + enddo + enddo + + end subroutine sorgam_vbs_aqchem_driver + +end module module_sorgam_vbs_aqchem diff --git a/wrfv2_fire/chem/module_sorgam_vbs_cloudchem.F b/wrfv2_fire/chem/module_sorgam_vbs_cloudchem.F new file mode 100644 index 00000000..e63ca538 --- /dev/null +++ b/wrfv2_fire/chem/module_sorgam_vbs_cloudchem.F @@ -0,0 +1,2206 @@ +!********************************************************************************** +! This computer software was prepared by Battelle Memorial Institute, hereinafter +! the Contractor, under Contract No. DE-AC05-76RL0 1830 with the Department of +! Energy (DOE). NEITHER THE GOVERNMENT NOR THE CONTRACTOR MAKES ANY WARRANTY, +! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. +! +! MOSAIC module: see module_mosaic_driver.F for references and terms of use +!********************************************************************************** + + module module_sorgam_vbs_cloudchem + + + + integer, parameter :: l_so4_aqyy = 1 + integer, parameter :: l_no3_aqyy = 2 + integer, parameter :: l_cl_aqyy = 3 + integer, parameter :: l_nh4_aqyy = 4 + integer, parameter :: l_na_aqyy = 5 + integer, parameter :: l_oin_aqyy = 6 + integer, parameter :: l_bc_aqyy = 7 + integer, parameter :: l_oc_aqyy = 8 + + integer, parameter :: nyyy = 8 + +! "negligible volume" = (1 #/kg ~= 1e-6 #/cm3) * ((dp=1e-6 cm)**3 * pi/6) + real, parameter :: smallvolaa = 0.5e-18 + + + + contains + + + +!----------------------------------------------------------------------- + subroutine sorgam_vbs_cloudchem_driver( & + id, ktau, ktauc, dtstepc, config_flags, & + p_phy, t_phy, rho_phy, alt, & + cldfra, ph_no2, & + moist, chem, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + use module_state_description, only: & + num_moist, num_chem, p_qc + + use module_configure, only: grid_config_rec_type + + use module_data_sorgam_vbs, only: cw_phase, nphase_aer + + + implicit none + +! subr arguments + integer, intent(in) :: & + id, ktau, ktauc, & + numgas_aqfrac, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte +! id - domain index +! ktau - time step number +! ktauc - gas and aerosol chemistry time step number +! numgas_aqfrac - last dimension of gas_aqfrac + +! [ids:ide, kds:kde, jds:jde] - spatial (x,z,y) indices for 'domain' +! [ims:ime, kms:kme, jms:jme] - spatial (x,z,y) indices for 'memory' +! Most arrays that are arguments to chem_driver +! are dimensioned with these spatial indices. +! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for 'tile' +! chem_driver and routines under it do calculations +! over these spatial indices. + + type(grid_config_rec_type), intent(in) :: config_flags +! config_flags - configuration and control parameters + + real, intent(in) :: & + dtstepc +! dtstepc - time step for gas and aerosol chemistry(s) + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + p_phy, t_phy, rho_phy, alt, cldfra, ph_no2 +! p_phy - air pressure (Pa) +! t_phy - temperature (K) +! rho_phy - moist air density (kg/m^3) +! alt - dry air specific volume (m^3/kg) +! cldfra - cloud fractional area (0-1) +! ph_no2 - no2 photolysis rate (1/min) + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: & + moist +! moist - mixing ratios of moisture species (water vapor, +! cloud water, ...) (kg/kg for mass species, #/kg for number species) + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem +! chem - mixing ratios of trace gas and aerosol species (ppm for gases, +! ug/kg for aerosol mass species, #/kg for aerosol number species) + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, numgas_aqfrac ) :: & + gas_aqfrac +! gas_aqfrac - fraction (0-1) of gas that is dissolved in cloud water + + +! local variables + integer :: it, jt, kt, l + integer :: icase + integer :: igaschem_onoff, iphotol_onoff, iradical_onoff + + real :: rbox(num_chem) + real :: gas_aqfrac_box(numgas_aqfrac) + real :: ph_aq_box + real, parameter :: qcldwtr_cutoff = 1.0e-6 + real :: qcldwtr + + +! check that cw_phase is active + if ((cw_phase .le. 0) .or. (cw_phase .gt. nphase_aer)) then + print *, '*** sorgam_vbs_cloudchem_driver - cw_phase not active' + return + end if + + print 93010, 'entering sorgam_vbs_cloudchem_driver - ktau =', ktau + + icase = 0 + +! iphotol_onoff = 1 if photolysis rate calcs are on; 0 if off + iphotol_onoff = 0 + if (config_flags%phot_opt .gt. 0) iphotol_onoff = 1 +! igaschem_onoff = 1 if gas-phase chemistry is on; 0 if off + igaschem_onoff = 0 + if (config_flags%gaschem_onoff .gt. 0) igaschem_onoff = 1 + +! iradical_onoff turns aqueous radical chemistry on/off +! set iradical_onoff=0 if either photolysis or gas-phase chem are off + if ((igaschem_onoff .le. 0) .or. (iphotol_onoff .le. 0)) then + iradical_onoff = 0 + else + iradical_onoff = 1 + end if +! following line turns aqueous radical chem off unconditionally + iradical_onoff = 0 + + + do 3920 jt = jts, jte + do 3910 it = its, ite + + do 3800 kt = kts, kte + + qcldwtr = moist(it,kt,jt,p_qc) + if (qcldwtr .le. qcldwtr_cutoff) goto 3800 + + + icase = icase + 1 + +! detailed dump for debugging + if (ktau .eq. -13579) then +! if ((ktau .eq. 30) .and. (it .eq. 23) .and. & +! (jt .eq. 1) .and. (kt .eq. 11)) then + call sorgam_cloudchem_dumpaa( & + id, ktau, ktauc, dtstepc, config_flags, & + p_phy, t_phy, rho_phy, alt, & + cldfra, ph_no2, & + moist, chem, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + qcldwtr_cutoff, & + it, jt, kt ) + end if + +! map from wrf-chem 3d arrays to pegasus clm & sub arrays + rbox(1:num_chem) = chem(it,kt,jt,1:num_chem) + +! make call '1box' cloudchem routine +! print 93010, 'calling sorgam_cloudchem_1 at ijk =', it, jt, kt + call sorgam_cloudchem_1box( & + id, ktau, ktauc, dtstepc, & + iphotol_onoff, iradical_onoff, & + ph_no2(it,kt,jt), & + ph_aq_box, gas_aqfrac_box, & + numgas_aqfrac, it, jt, kt, icase, & + rbox, qcldwtr, & + t_phy(it,kt,jt), p_phy(it,kt,jt), rho_phy(it,kt,jt),& + config_flags) + +! map back to wrf-chem 3d arrays + chem(it,kt,jt,1:num_chem) = rbox(1:num_chem) + gas_aqfrac(it,kt,jt,:) = gas_aqfrac_box(:) + + +3800 continue + +3910 continue +3920 continue + + print 93010, 'leaving sorgam_vbs_cloudchem_driver - ktau =', ktau, icase +93010 format( a, 8(1x,i6) ) + + return + end subroutine sorgam_vbs_cloudchem_driver + + + +!----------------------------------------------------------------------- + subroutine sorgam_cloudchem_1box( & + id, ktau, ktauc, dtstepc, & + iphotol_onoff, iradical_onoff, & + photol_no2_box, & + ph_aq_box, gas_aqfrac_box, & + numgas_aqfrac, it, jt, kt, icase, & + rbox, qcw_box, temp_box, pres_box, rho_box, & + config_flags ) + + use module_configure, only: grid_config_rec_type + + use module_state_description, only: & + num_moist, num_chem + + use module_data_sorgam_vbs, only: & + msectional, maxd_asize, maxd_atype, & + cw_phase, nsize_aer, ntype_aer, do_cloudchem_aer, & + lptr_so4_aer, lptr_no3_aer, lptr_nh4_aer, & + lptr_orgpa_aer, lptr_ec_aer, lptr_p25_aer, & + lptr_cl_aer, lptr_na_aer + + use module_data_cmu_bulkaqchem, only: & + meqn1max + + + implicit none + +! subr arguments + + type(grid_config_rec_type), intent(in) :: config_flags + + integer, intent(in) :: & + id, ktau, ktauc, & + numgas_aqfrac, it, jt, kt, & + icase, iphotol_onoff, iradical_onoff + + real, intent(in) :: & + dtstepc, photol_no2_box, & + qcw_box, & ! cloud water (kg/kg) + temp_box, & ! air temp (K) + pres_box, & ! air pres (Pa) + rho_box ! air dens (kg/m3) + + real, intent(inout) :: ph_aq_box + + real, intent(inout), dimension( num_chem ) :: rbox +! rbox has same units as chem [gas = ppmv, AP mass = ug/kg, AP number = #/kg] + + real, intent(inout), dimension( numgas_aqfrac ) :: gas_aqfrac_box + +! local variables + integer :: iphase + integer :: icase_in, idecomp_hmsa_hso5, & + iradical_in, istat_aqop + + integer :: lptr_yyy_cwaer(maxd_asize,maxd_atype,nyyy) + + real :: co2_mixrat_in + real :: ph_cmuaq_cur + real :: photol_no2_in + real :: xprescribe_ph + + real :: yaq_beg(meqn1max), yaq_end(meqn1max) + real :: rbox_sv1(num_chem) + real :: rbulk_cwaer(nyyy,2) + + real, dimension( maxd_asize, maxd_atype ) :: fr_partit_cw + real, dimension( 2, 3 ) :: xvol_old + + +! +! set the lptr_yyy_cwaer +! + iphase = cw_phase + lptr_yyy_cwaer(:,:,l_so4_aqyy) = lptr_so4_aer(:,:,iphase) + lptr_yyy_cwaer(:,:,l_no3_aqyy) = lptr_no3_aer(:,:,iphase) + lptr_yyy_cwaer(:,:,l_nh4_aqyy) = lptr_nh4_aer(:,:,iphase) + lptr_yyy_cwaer(:,:,l_oin_aqyy) = lptr_p25_aer(:,:,iphase) + lptr_yyy_cwaer(:,:,l_bc_aqyy ) = lptr_ec_aer( :,:,iphase) + lptr_yyy_cwaer(:,:,l_oc_aqyy ) = lptr_orgpa_aer( :,:,iphase) +! na and cl added + lptr_yyy_cwaer(:,:,l_cl_aqyy ) = lptr_cl_aer(:,:,iphase) + lptr_yyy_cwaer(:,:,l_na_aqyy ) = lptr_na_aer(:,:,iphase) +! lptr_yyy_cwaer(:,:,l_cl_aqyy ) = -999888777 +! lptr_yyy_cwaer(:,:,l_na_aqyy ) = -999888777 + +! +! +! do bulk cloud-water chemistry +! +! + icase_in = icase + iradical_in = 1 + idecomp_hmsa_hso5 = 1 + + co2_mixrat_in = 350.0 + + photol_no2_in = photol_no2_box + +! when xprescribe_ph >= 0, ph is forced to its value + xprescribe_ph = -1.0e31 + +! turn off aqueous phase photolytic and radical chemistry +! if either of the iphotol_onoff and iradical_onoff flags are 0 + if ((iphotol_onoff .le. 0) .or. (iradical_onoff .le. 0)) then + photol_no2_in = 0.0 + iradical_in = 0 + end if + +#if defined ( ccboxtest_box_testing_active) +! following is for off-line box testing only + call ccboxtest_extra_args_aa( 'get', & + co2_mixrat_in, iradical_in, & + idecomp_hmsa_hso5, icase_in, & + xprescribe_ph ) +#endif + + rbox_sv1(:) = rbox(:) + gas_aqfrac_box(:) = 0.0 + + +! make call to interface_to_aqoperator1 + call sorgam_interface_to_aqoperator1( & + istat_aqop, & + dtstepc, & + rbox, gas_aqfrac_box, & + qcw_box, temp_box, pres_box, rho_box, & + rbulk_cwaer, lptr_yyy_cwaer, & + co2_mixrat_in, photol_no2_in, xprescribe_ph, & + iradical_in, idecomp_hmsa_hso5, & + yaq_beg, yaq_end, ph_cmuaq_cur, & + numgas_aqfrac, id, it, jt, kt, ktau, icase_in, & + config_flags ) + + ph_aq_box = ph_cmuaq_cur + + +#if defined ( ccboxtest_box_testing_active) +! following is for off-line box testing only + call ccboxtest_extra_args_bb( 'put', & + yaq_beg, yaq_end, ph_cmuaq_cur ) +#endif + + +! +! +! calculate fraction of cloud-water associated with each activated aerosol bin +! +! + call sorgam_partition_cldwtr( & + rbox, fr_partit_cw, xvol_old, & + id, it, jt, kt, icase_in ) + +! +! +! distribute changes in bulk cloud-water composition among size bins +! +! + call sorgam_distribute_bulk_changes( & + rbox, rbox_sv1, fr_partit_cw, & + rbulk_cwaer, lptr_yyy_cwaer, & + id, it, jt, kt, icase_in ) + + +! +! do move-sections +! + if (msectional .lt. 1000000000) then + call sorgam_cloudchem_apply_mode_transfer( & + rbox, rbox_sv1, xvol_old, & + id, it, jt, kt, icase_in ) + end if + + + + return + end subroutine sorgam_cloudchem_1box + + + +!----------------------------------------------------------------------- + subroutine sorgam_interface_to_aqoperator1( & + istat_aqop, & + dtstepc, & + rbox, gas_aqfrac_box, & + qcw_box, temp_box, pres_box, rho_box, & + rbulk_cwaer, lptr_yyy_cwaer, & + co2_mixrat_in, photol_no2_in, xprescribe_ph, & + iradical_in, idecomp_hmsa_hso5, & + yaq_beg, yaq_end, ph_cmuaq_cur, & + numgas_aqfrac, id, it, jt, kt, ktau, icase, & + config_flags ) + + use module_configure, only: grid_config_rec_type + + use module_state_description, only: & + num_chem, param_first_scalar, p_qc, & + p_nh3, p_hno3, p_hcl, p_sulf, p_hcho, & + p_ora1, p_so2, p_h2o2, p_o3, p_ho, & + p_ho2, p_no3, p_no, p_no2, p_hono, & + p_pan, p_ch3o2, p_ch3oh, p_op1, & + p_form, p_facd, p_oh, p_meo2, p_meoh, p_mepx, & + CB05_SORG_VBS_AQ_KPP + + use module_data_cmu_bulkaqchem, only: & + meqn1max, naers, ngas, & + na4, naa, nac, nae, nah, nahmsa, nahso5, & + nan, nao, nar, nas, naw, & + ng4, nga, ngc, ngch3co3h, ngch3o2, ngch3o2h, ngch3oh, & + ngh2o2, nghcho, nghcooh, nghno2, ngho2, & + ngn, ngno, ngno2, ngno3, ngo3, ngoh, ngpan, ngso2 + + use module_cmu_bulkaqchem, only: aqoperator1 + + use module_data_sorgam_vbs, only: & + maxd_asize, maxd_atype, & + cw_phase, nsize_aer, ntype_aer, do_cloudchem_aer, & + lptr_so4_aer, lptr_no3_aer, lptr_nh4_aer, & + lptr_orgpa_aer, lptr_ec_aer, lptr_p25_aer, & + lptr_cl_aer, lptr_na_aer + + + implicit none + +! subr arguments + + type(grid_config_rec_type), intent(in) :: config_flags + + integer, intent(in) :: & + iradical_in, idecomp_hmsa_hso5, & + numgas_aqfrac, id, it, jt, kt, ktau, icase + integer, intent(inout) :: & + istat_aqop + + integer, intent(in) :: lptr_yyy_cwaer(maxd_asize,maxd_atype,nyyy) + + real, intent(in) :: & + dtstepc, co2_mixrat_in, & + photol_no2_in, xprescribe_ph, & + qcw_box, temp_box, pres_box, rho_box + + real, intent(inout) :: ph_cmuaq_cur + + real, intent(inout), dimension( num_chem ) :: rbox ! ppm or ug/kg + + real, intent(inout), dimension( numgas_aqfrac ) :: gas_aqfrac_box + + real, intent(inout), dimension( nyyy, 2 ) :: rbulk_cwaer + + real, intent(inout), dimension( meqn1max ) :: yaq_beg, yaq_end + + +! local variables + integer :: i, iphase, isize, itype + integer :: iaq, istat_fatal, istat_warn + integer :: l, lyyy + integer :: p1st +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) + integer :: lunxx +#endif + + real, parameter :: eps=0.622 ! (mw h2o)/(mw air) + + + real :: cair_moleperm3 + real :: dum, dumb + real :: factgas, factlwc, factpatm, factphoto + real :: factaerbc, factaercl, factaerna, factaernh4, & + factaerno3, factaeroc, factaeroin, factaerso4 + real :: lwc + real :: p_atm, photo_in + real :: rh + real :: temp, tstep_beg_sec, tstep_end_sec + real :: totsulf_beg, totsulf_end + real :: gas(ngas), aerosol(naers) + real :: gas_aqfrac_cmu(ngas) + + double precision tstep_beg_sec_dp, tstep_end_sec_dp, & + temp_dp, p_atm_dp, lwc_dp, rh_dp, & + co2_mixrat_in_dp, photo_in_dp, ph_cmuaq_cur_dp, & + xprescribe_ph_dp + double precision gas_dp(ngas), gas_aqfrac_cmu_dp(ngas), & + aerosol_dp(naers), yaq_beg_dp(meqn1max), yaq_end_dp(meqn1max) + + + + p1st = param_first_scalar + +! +! units conversion factors +! 'cmuaq-bulk' value = pegasus value X factor +! +! [pres in atmospheres] = [pres in pascals] * factpatm + factpatm = 1.0/1.01325e5 +! [cldwtr in g-h2o/m3-air] = [cldwtr in kg-h2o/kg-air] * factlwc + factlwc = 1.0e3*rho_box +! [aq photolysis rate scaling factor in --] = [jno2 in 1/min] * factphoto + factphoto = 1.6 + +! [gas in ppm] = [gas in ppm] * factgas + factgas = 1.0 + +! [aerosol in ug/m3-air] = [aerosol in ug/kg-air] * factaer + dum = rho_box + factaerso4 = dum + factaerno3 = dum + factaercl = dum + factaernh4 = dum + factaerna = dum + factaeroin = dum + factaeroc = dum + factaerbc = dum + +#if defined ( ccboxtest_box_testing_active) +! If aboxtest_units_convert=10, turn off units conversions both here +! and in module_mosaic. This is for testing, to allow exact agreements. + if (aboxtest_units_convert .eq. 10) then + factpatm = 1.0 + factlwc = 1.0 + factphoto = 1.0 + factgas = 1.0 + factaerso4 = 1.0 + factaerno3 = 1.0 + factaercl = 1.0 + factaernh4 = 1.0 + factaerna = 1.0 + factaeroin = 1.0 + factaeroc = 1.0 + factaerbc = 1.0 + end if +#endif + +! +! map from rbox to gas,aerosol +! + temp = temp_box + + lwc = qcw_box * factlwc + p_atm = pres_box * factpatm + +! rce 2005-jul-11 - set p_atm so that cmu code's cair will match cairclm +! p_atm = cairclm(kpeg)*1.0e3*0.082058e0*temp +! for made-sorgam, set p_atm so that cmu code's (cair*28.966e3) +! will match rho_box + p_atm = (rho_box/28.966)*0.082058e0*temp + + photo_in = photol_no2_in * factphoto + + rh = 1.0 + iaq = 1 + + tstep_beg_sec = 0.0 + tstep_end_sec = dtstepc + +! map gases and convert to ppm + gas(:) = 0.0 + + if (p_nh3 >= p1st) gas(nga ) = rbox(p_nh3 )*factgas + if (p_hno3 >= p1st) gas(ngn ) = rbox(p_hno3 )*factgas + if (p_hcl >= p1st) gas(ngc ) = rbox(p_hcl )*factgas + if (p_sulf >= p1st) gas(ng4 ) = rbox(p_sulf )*factgas + +! if (p_hcho >= p1st) gas(nghcho ) = rbox(p_hcho )*factgas +! if (p_ora1 >= p1st) gas(nghcooh ) = rbox(p_ora1 )*factgas + if (p_so2 >= p1st) gas(ngso2 ) = rbox(p_so2 )*factgas + if (p_h2o2 >= p1st) gas(ngh2o2 ) = rbox(p_h2o2 )*factgas + if (p_o3 >= p1st) gas(ngo3 ) = rbox(p_o3 )*factgas +! if (p_ho >= p1st) gas(ngoh ) = rbox(p_ho )*factgas + if (p_ho2 >= p1st) gas(ngho2 ) = rbox(p_ho2 )*factgas + if (p_no3 >= p1st) gas(ngno3 ) = rbox(p_no3 )*factgas + + if (p_no >= p1st) gas(ngno ) = rbox(p_no )*factgas + if (p_no2 >= p1st) gas(ngno2 ) = rbox(p_no2 )*factgas + if (p_hono >= p1st) gas(nghno2 ) = rbox(p_hono )*factgas + if (p_pan >= p1st) gas(ngpan ) = rbox(p_pan )*factgas +! if (p_ch3o2 >= p1st) gas(ngch3o2 ) = rbox(p_ch3o2)*factgas +! if (p_ch3oh >= p1st) gas(ngch3oh ) = rbox(p_ch3oh)*factgas +! if (p_op1 >= p1st) gas(ngch3o2h) = rbox(p_op1 )*factgas + +! CB05 case added below + if ((config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP)) then + + if (p_form >= p1st) gas(nghcho ) = rbox(p_form )*factgas + if (p_facd >= p1st) gas(nghcooh ) = rbox(p_facd )*factgas + if (p_oh >= p1st) gas(ngoh ) = rbox(p_oh )*factgas + if (p_meo2 >= p1st) gas(ngch3o2 ) = rbox(p_meo2 )*factgas + if (p_meoh >= p1st) gas(ngch3oh ) = rbox(p_meoh )*factgas + if (p_mepx >= p1st) gas(ngch3o2h) = rbox(p_mepx )*factgas + + else + + if (p_hcho >= p1st) gas(nghcho ) = rbox(p_hcho )*factgas + if (p_ora1 >= p1st) gas(nghcooh ) = rbox(p_ora1 )*factgas + if (p_ho >= p1st) gas(ngoh ) = rbox(p_ho )*factgas + if (p_ch3o2 >= p1st) gas(ngch3o2 ) = rbox(p_ch3o2)*factgas + if (p_ch3oh >= p1st) gas(ngch3oh ) = rbox(p_ch3oh)*factgas + if (p_op1 >= p1st) gas(ngch3o2h) = rbox(p_op1 )*factgas + + endif + + +! compute bulk activated-aerosol mixing ratios + aerosol(:) = 0.0 + rbulk_cwaer(:,:) = 0.0 + + iphase = cw_phase + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + + do lyyy = 1, nyyy + + l = lptr_yyy_cwaer(isize,itype,lyyy) + if (l .ge. p1st) rbulk_cwaer(lyyy,1) = rbulk_cwaer(lyyy,1) + rbox(l) + + end do + + end do + end do + +! map them to 'aerosol' array and convert to ug/m3 + aerosol(na4) = rbulk_cwaer(l_so4_aqyy,1) * factaerso4 + aerosol(nan) = rbulk_cwaer(l_no3_aqyy,1) * factaerno3 + aerosol(nac) = rbulk_cwaer(l_cl_aqyy, 1) * factaercl + aerosol(naa) = rbulk_cwaer(l_nh4_aqyy,1) * factaernh4 + aerosol(nas) = rbulk_cwaer(l_na_aqyy, 1) * factaerna + aerosol(nar) = rbulk_cwaer(l_oin_aqyy,1) * factaeroin + aerosol(nae) = rbulk_cwaer(l_bc_aqyy, 1) * factaerbc + aerosol(nao) = rbulk_cwaer(l_oc_aqyy, 1) * factaeroc + + +! +! make call to aqoperator1 +! +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) + lunxx = 87 + lunxx = -1 + if ((it==23) .and. (jt==1) .and. (kt<=20)) lunxx = 171 + if (lunxx .gt. 0) then + write(lunxx,*) + write(lunxx,*) + write(lunxx,*) 'interface_to_aqoperator1 - icase, irad, idecomp' + write(lunxx,9870) icase, iradical_in, idecomp_hmsa_hso5 + write(lunxx,*) 'it, jt, kt, ktau' + write(lunxx,9870) it, jt, kt, ktau + write(lunxx,*) 'temp, p_atm, lwc, photo, co2, xprescribe_ph' + write(lunxx,9875) temp, p_atm, lwc, photo_in, co2_mixrat_in, xprescribe_ph + write(lunxx,*) 'pres_box, rho_box, qcw_box, dt_sec' + write(lunxx,9875) pres_box, rho_box, qcw_box, & + (tstep_end_sec-tstep_beg_sec) + write(lunxx,*) 'gas (1=nh3, 2=hno3, 3=hcl, 4=h2so4, 11=so2, 12=h2o2, 18=o3)' + write(lunxx,9875) gas + write(lunxx,*) 'rbox(nh3, hno3, hcl, h2so4, so2, h2o2, o3)' + write(lunxx,9875) rbox(p_nh3), rbox(p_hno3), rbox(p_hcl), & + rbox(p_sulf), rbox(p_so2), rbox(p_h2o2), rbox(p_o3) + write(lunxx,*) 'aerosol (1=na, 3=nh4, 4=no3, 5=cl, 6=so4, 8=ec, 9=oc, 10=crus)' + write(lunxx,9875) aerosol + write(lunxx,*) 'rbulk_cwaer (1=so4, 2=no3, 3-cl, 4=nh4, 5=na, 6=oin, 7=bc, 8=oc)' + write(lunxx,9875) rbulk_cwaer(:,1) + if (icase .le. -5) then + write(*,*) & + '*** stopping in interface_to_aqop1 at icase =', icase + call wrf_error_fatal('*** stopping in interface_to_aqop1') + end if + end if +9870 format( 8i5 ) +9875 format( 5(1pe14.6) ) +#endif + +#if 0 +! Print outs for debugging of aqoperator1... wig, 26-Oct-2005 +!!$ if( (id == 1 .and. ktau >= 207 ) .or. & +!!$ (id == 2 .and. ktau >= 610 ) .or. & +!!$ (id == 3 .and. ktau >= 1830 ) ) then + write(6,'(a)') '---Begin input for aqoperator1---' + write(6,'(a,4i)') 'id, it, jt, kt =', id, it, jt, kt + write(6,'(a,1p,2e20.12)') 'tstep_beg_sec, tstep_end_sec = ', & + tstep_beg_sec, tstep_end_sec + do l=1,ngas + write(6,'("gas(",i2,") = ",1p,1e20.12)') l, gas(l) + end do + do l=1,naers + write(6,'("aerosol(",i2,") = ",1p,1e20.12)') l, aerosol(l) + end do + write(6,'(a,1p,4e20.12)') "temp, p_atm, lwc, rh = ", temp, p_atm, lwc, rh + write(6,'(a,1p,3e20.12)') "co2_mixrat_in, photo_in, xprescribe_ph = ", & + co2_mixrat_in, photo_in, xprescribe_ph + write(6,'(a,3i)') " iradical_in, idecomp_hmsa_hso5, iaq = ", & + iradical_in, idecomp_hmsa_hso5, iaq + write(6,'(a)') "---End input for aqoperator1---" +!!$ end if +#endif + + +! convert arguments to double prec + tstep_beg_sec_dp = 0.0d0 + if (tstep_beg_sec .ne. 0.0) tstep_beg_sec_dp = tstep_beg_sec + tstep_end_sec_dp = 0.0d0 + if (tstep_end_sec .ne. 0.0) tstep_end_sec_dp = tstep_end_sec + temp_dp = 0.0d0 + if (temp .ne. 0.0) temp_dp = temp + p_atm_dp = 0.0d0 + if (p_atm .ne. 0.0) p_atm_dp = p_atm + lwc_dp = 0.0d0 + if (lwc .ne. 0.0) lwc_dp = lwc + rh_dp = 0.0d0 + if (rh .ne. 0.0) rh_dp = rh + co2_mixrat_in_dp = 0.0d0 + if (co2_mixrat_in .ne. 0.0) co2_mixrat_in_dp = co2_mixrat_in + photo_in_dp = 0.0d0 + if (photo_in .ne. 0.0) photo_in_dp = photo_in + xprescribe_ph_dp = 0.0d0 + if (xprescribe_ph .ne. 0.0) xprescribe_ph_dp = xprescribe_ph + ph_cmuaq_cur_dp = 0.0d0 + if (ph_cmuaq_cur .ne. 0.0) ph_cmuaq_cur_dp = ph_cmuaq_cur + + do i = 1, ngas + gas_dp(i) = 0.0d0 + if (gas(i) .ne. 0.0) gas_dp(i) = gas(i) + end do + do i = 1, naers + aerosol_dp(i) = 0.0d0 + if (aerosol(i) .ne. 0.0) aerosol_dp(i) = aerosol(i) + end do + do i = 1, ngas + gas_aqfrac_cmu_dp(i) = 0.0d0 + if (gas_aqfrac_cmu(i) .ne. 0.0) gas_aqfrac_cmu_dp(i) = gas_aqfrac_cmu(i) + end do + do i = 1, meqn1max + yaq_beg_dp(i) = 0.0d0 + if (yaq_beg(i) .ne. 0.0) yaq_beg_dp(i) = yaq_beg(i) + end do + do i = 1, meqn1max + yaq_end_dp(i) = 0.0d0 + if (yaq_end(i) .ne. 0.0) yaq_end_dp(i) = yaq_end(i) + end do + + +! total sulfur species conc as sulfate (ug/m3) + cair_moleperm3 = 1.0e3*p_atm_dp/(0.082058e0*temp_dp) + totsulf_beg = ( aerosol_dp(na4)/96. & + + aerosol_dp(nahso5)/113. + aerosol_dp(nahmsa)/111. & + + (gas_dp(ngso2) + gas_dp(ng4))*cair_moleperm3 )*96.0 + +! call aqoperator1( & +! istat_fatal, istat_warn, & +! tstep_beg_sec, tstep_end_sec, & +! gas, aerosol, gas_aqfrac_cmu, & +! temp, p_atm, lwc, rh, & +! co2_mixrat_in, photo_in, xprescribe_ph, & +! iradical_in, idecomp_hmsa_hso5, iaq, & +! yaq_beg, yaq_end, ph_cmuaq_cur ) + + call aqoperator1( & + istat_fatal, istat_warn, & + tstep_beg_sec_dp, tstep_end_sec_dp, & + gas_dp, aerosol_dp, gas_aqfrac_cmu_dp, & + temp_dp, p_atm_dp, lwc_dp, rh_dp, & + co2_mixrat_in_dp, photo_in_dp, xprescribe_ph_dp, & + iradical_in, idecomp_hmsa_hso5, iaq, & + yaq_beg_dp, yaq_end_dp, ph_cmuaq_cur_dp ) + + totsulf_end = ( aerosol_dp(na4)/96. & + + aerosol_dp(nahso5)/113. + aerosol_dp(nahmsa)/111. & + + (gas_dp(ngso2) + gas_dp(ng4))*cair_moleperm3 )*96.0 + + +! convert arguments back to single prec + tstep_beg_sec = tstep_beg_sec_dp + tstep_end_sec = tstep_end_sec_dp + temp = temp_dp + p_atm = p_atm_dp + lwc = lwc_dp + rh = rh_dp +! co2_mixrat_in = co2_mixrat_in_dp ! this has intent(in) +! photo_in = photo_in_dp ! this has intent(in) +! xprescribe_ph = xprescribe_ph_dp ! this has intent(in) + ph_cmuaq_cur = ph_cmuaq_cur_dp + + do i = 1, ngas + gas(i) = gas_dp(i) + end do + do i = 1, naers + aerosol(i) = aerosol_dp(i) + end do + do i = 1, ngas + gas_aqfrac_cmu(i) = gas_aqfrac_cmu_dp(i) + end do + do i = 1, meqn1max + yaq_beg(i) = yaq_beg_dp(i) + end do + do i = 1, meqn1max + yaq_end(i) = yaq_end_dp(i) + end do + + +! +! warning message when status flags are non-zero +! + istat_aqop = 0 + if (istat_fatal .ne. 0) then + write(6,*) & + '*** sorgam_cloudchem_driver, subr interface_to_aqoperator1' + write(6,'(a,4i5,2i10)') & + ' id,it,jt,kt, istat_fatal, warn =', & + id, it, jt, kt, istat_fatal, istat_warn + istat_aqop = -10 + end if + +! +! warning message when sulfur mass balance error exceeds the greater +! of (1.0e-3 ug/m3) OR (1.0e-3 X total sulfur mixing ratio) +! + dum = totsulf_end - totsulf_beg + dumb = max( totsulf_beg, totsulf_end ) + if (abs(dum) .gt. max(1.0e-3,1.0e-3*dumb)) then + write(6,*) & + '*** sorgam_cloudchem_driver, sulfur balance warning' + write(6,'(a,4i5,1p,3e12.4)') & + ' id,it,jt,kt, total_sulfur_beg, _end, _error =', & + id, it, jt, kt, totsulf_beg, totsulf_end, dum + end if + +! +! map from [gas,aerosol,gas_aqfrac_box] to [rbox,gas_aqfrac_box] +! + gas_aqfrac_box(:) = 0.0 + + if (p_nh3 >= p1st) then + rbox(p_nh3 ) = gas(nga )/factgas + if (p_nh3 <= numgas_aqfrac) & + gas_aqfrac_box(p_nh3 ) = gas_aqfrac_cmu(nga ) + end if + if (p_hno3 >= p1st) then + rbox(p_hno3 ) = gas(ngn )/factgas + if (p_hno3 <= numgas_aqfrac) & + gas_aqfrac_box(p_hno3 ) = gas_aqfrac_cmu(ngn ) + end if + if (p_hcl >= p1st) then + rbox(p_hcl ) = gas(ngc )/factgas + if (p_hcl <= numgas_aqfrac) & + gas_aqfrac_box(p_hcl ) = gas_aqfrac_cmu(ngc ) + end if + if (p_sulf >= p1st) then + rbox(p_sulf ) = gas(ng4 )/factgas + if (p_sulf <= numgas_aqfrac) & + gas_aqfrac_box(p_sulf ) = gas_aqfrac_cmu(ng4 ) + end if + +! if (p_hcho >= p1st) then +! rbox(p_hcho ) = gas(nghcho )/factgas +! if (p_hcho <= numgas_aqfrac) & +! gas_aqfrac_box(p_hcho ) = gas_aqfrac_cmu(nghcho ) +! end if +! if (p_ora1 >= p1st) then +! rbox(p_ora1 ) = gas(nghcooh )/factgas +! if (p_ora1 <= numgas_aqfrac) & +! gas_aqfrac_box(p_ora1 ) = gas_aqfrac_cmu(nghcooh ) +! end if + if (p_so2 >= p1st) then + rbox(p_so2 ) = gas(ngso2 )/factgas + if (p_so2 <= numgas_aqfrac) & + gas_aqfrac_box(p_so2 ) = gas_aqfrac_cmu(ngso2 ) + end if + if (p_h2o2 >= p1st) then + rbox(p_h2o2 ) = gas(ngh2o2 )/factgas + if (p_h2o2 <= numgas_aqfrac) & + gas_aqfrac_box(p_h2o2 ) = gas_aqfrac_cmu(ngh2o2 ) + end if + if (p_o3 >= p1st) then + rbox(p_o3 ) = gas(ngo3 )/factgas + if (p_o3 <= numgas_aqfrac) & + gas_aqfrac_box(p_o3 ) = gas_aqfrac_cmu(ngo3 ) + end if +! if (p_ho >= p1st) then +! rbox(p_ho ) = gas(ngoh )/factgas +! if (p_ho <= numgas_aqfrac) & +! gas_aqfrac_box(p_ho ) = gas_aqfrac_cmu(ngoh ) +! end if + if (p_ho2 >= p1st) then + rbox(p_ho2 ) = gas(ngho2 )/factgas + if (p_ho2 <= numgas_aqfrac) & + gas_aqfrac_box(p_ho2 ) = gas_aqfrac_cmu(ngho2 ) + end if + if (p_no3 >= p1st) then + rbox(p_no3 ) = gas(ngno3 )/factgas + if (p_no3 <= numgas_aqfrac) & + gas_aqfrac_box(p_no3 ) = gas_aqfrac_cmu(ngno3 ) + end if + + if (p_no >= p1st) then + rbox(p_no ) = gas(ngno )/factgas + if (p_no <= numgas_aqfrac) & + gas_aqfrac_box(p_no ) = gas_aqfrac_cmu(ngno ) + end if + if (p_no2 >= p1st) then + rbox(p_no2 ) = gas(ngno2 )/factgas + if (p_no2 <= numgas_aqfrac) & + gas_aqfrac_box(p_no2 ) = gas_aqfrac_cmu(ngno2 ) + end if + if (p_hono >= p1st) then + rbox(p_hono ) = gas(nghno2 )/factgas + if (p_hono <= numgas_aqfrac) & + gas_aqfrac_box(p_hono ) = gas_aqfrac_cmu(nghno2 ) + end if + if (p_pan >= p1st) then + rbox(p_pan ) = gas(ngpan )/factgas + if (p_pan <= numgas_aqfrac) & + gas_aqfrac_box(p_pan ) = gas_aqfrac_cmu(ngpan ) + end if +! if (p_ch3o2 >= p1st) then +! rbox(p_ch3o2) = gas(ngch3o2 )/factgas +! if (p_ch3o2 <= numgas_aqfrac) & +! gas_aqfrac_box(p_ch3o2 ) = gas_aqfrac_cmu(ngch3o2 ) +! end if +! if (p_ch3oh >= p1st) then +! rbox(p_ch3oh) = gas(ngch3oh )/factgas +! if (p_ch3oh <= numgas_aqfrac) & +! gas_aqfrac_box(p_ch3oh ) = gas_aqfrac_cmu(ngch3oh ) +! end if +! if (p_op1 >= p1st) then +! rbox(p_op1 ) = gas(ngch3o2h)/factgas +! if (p_op1 <= numgas_aqfrac) & +! gas_aqfrac_box(p_op1 ) = gas_aqfrac_cmu(ngch3o2h) +! end if + +! CB05 case added + if ( (config_flags%chem_opt == CB05_SORG_VBS_AQ_KPP) ) then + + if (p_form >= p1st) then + rbox(p_form ) = gas(nghcho )/factgas + if (p_form <= numgas_aqfrac) & + gas_aqfrac_box(p_form ) = gas_aqfrac_cmu(nghcho ) + end if + if (p_facd >= p1st) then + rbox(p_facd ) = gas(nghcooh )/factgas + if (p_facd <= numgas_aqfrac) & + gas_aqfrac_box(p_facd ) = gas_aqfrac_cmu(nghcooh ) + end if + if (p_oh >= p1st) then + rbox(p_oh ) = gas(ngoh )/factgas + if (p_oh <= numgas_aqfrac) & + gas_aqfrac_box(p_oh ) = gas_aqfrac_cmu(ngoh ) + end if + if (p_meo2 >= p1st) then + rbox(p_meo2 ) = gas(ngch3o2 )/factgas + if (p_meo2 <= numgas_aqfrac) & + gas_aqfrac_box(p_meo2 ) = gas_aqfrac_cmu(ngch3o2 ) + end if + + if (p_meoh >= p1st) then + rbox(p_meoh ) = gas(ngch3oh )/factgas + if (p_meoh <= numgas_aqfrac) & + gas_aqfrac_box(p_meoh ) = gas_aqfrac_cmu(ngch3oh ) + end if + if (p_mepx >= p1st) then + rbox(p_mepx ) = gas(ngch3o2h)/factgas + if (p_mepx <= numgas_aqfrac) & + gas_aqfrac_box(p_mepx ) = gas_aqfrac_cmu(ngch3o2h) + end if + + else + if (p_hcho >= p1st) then + rbox(p_hcho ) = gas(nghcho )/factgas + if (p_hcho <= numgas_aqfrac) & + gas_aqfrac_box(p_hcho ) = gas_aqfrac_cmu(nghcho ) + end if + if (p_ora1 >= p1st) then + rbox(p_ora1 ) = gas(nghcooh )/factgas + if (p_ora1 <= numgas_aqfrac) & + gas_aqfrac_box(p_ora1 ) = gas_aqfrac_cmu(nghcooh ) + end if + if (p_ho >= p1st) then + rbox(p_ho ) = gas(ngoh )/factgas + if (p_ho <= numgas_aqfrac) & + gas_aqfrac_box(p_ho ) = gas_aqfrac_cmu(ngoh ) + end if + if (p_ch3o2 >= p1st) then + rbox(p_ch3o2) = gas(ngch3o2 )/factgas + if (p_ch3o2 <= numgas_aqfrac) & + gas_aqfrac_box(p_ch3o2 ) = gas_aqfrac_cmu(ngch3o2 ) + end if + if (p_ch3oh >= p1st) then + rbox(p_ch3oh) = gas(ngch3oh )/factgas + if (p_ch3oh <= numgas_aqfrac) & + gas_aqfrac_box(p_ch3oh ) = gas_aqfrac_cmu(ngch3oh ) + end if + if (p_op1 >= p1st) then + rbox(p_op1 ) = gas(ngch3o2h)/factgas + if (p_op1 <= numgas_aqfrac) & + gas_aqfrac_box(p_op1 ) = gas_aqfrac_cmu(ngch3o2h) + end if + + end if + +! end of addition + + rbulk_cwaer(l_so4_aqyy,2) = aerosol(na4)/factaerso4 + rbulk_cwaer(l_no3_aqyy,2) = aerosol(nan)/factaerno3 + rbulk_cwaer(l_cl_aqyy, 2) = aerosol(nac)/factaercl + rbulk_cwaer(l_nh4_aqyy,2) = aerosol(naa)/factaernh4 + rbulk_cwaer(l_na_aqyy, 2) = aerosol(nas)/factaerna + rbulk_cwaer(l_oin_aqyy,2) = aerosol(nar)/factaeroin + rbulk_cwaer(l_bc_aqyy, 2) = aerosol(nae)/factaerbc + rbulk_cwaer(l_oc_aqyy, 2) = aerosol(nao)/factaeroc + + +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) + lunxx = 87 + lunxx = -1 + if ((it==23) .and. (jt==1) .and. (kt<=20)) lunxx = 171 + if (lunxx .gt. 0) then + write(lunxx,*) + write(lunxx,*) 'interface_to_aqoperator1 - after call' + write(lunxx,*) 'gas (1=nh3, 2=hno3, 3=hcl, 4=h2so4, 11=so2, 12=h2o2, 18=o3)' + write(lunxx,9875) gas + write(lunxx,*) 'rbox(nh3, hno3, hcl, h2so4, so2, h2o2, o3)' + write(lunxx,9875) rbox(p_nh3), rbox(p_hno3), rbox(p_hcl), & + rbox(p_sulf), rbox(p_so2), rbox(p_h2o2), rbox(p_o3) + write(lunxx,*) 'aerosol (1=na, 3=nh4, 4=no3, 5=cl, 6=so4, 8=ec, 9=oc, 10=crus)' + write(lunxx,9875) aerosol + write(lunxx,*) 'rbulk_cwaer (1=so4, 2=no3, 3-cl, 4=nh4, 5=na, 6=oin, 7=bc, 8=oc)' + write(lunxx,9875) rbulk_cwaer(:,2) + write(lunxx,*) 'ph_cmuaq_cur' + write(lunxx,9875) ph_cmuaq_cur + if (icase .le. -5) then + write(*,*) & + '*** stopping in interface_to_aqop1 at icase =', icase + call wrf_error_fatal('*** stopping in interface_to_aqop1') + end if + end if +#endif + + + return + end subroutine sorgam_interface_to_aqoperator1 + + + +!----------------------------------------------------------------------- + subroutine sorgam_partition_cldwtr( & + rbox, fr_partit_cw, xvol_old, & + id, it, jt, kt, icase ) + + use module_state_description, only: & + param_first_scalar, num_chem + + use module_data_sorgam_vbs, only: & + maxd_asize, maxd_atype, & + ai_phase, cw_phase, nsize_aer, ntype_aer, ncomp_aer, & + do_cloudchem_aer, massptr_aer, numptr_aer, & + dens_aer, sigmag_aer, & + dcen_sect, dlo_sect, dhi_sect, & + volumcen_sect, volumlo_sect, volumhi_sect + + + implicit none + +! subr arguments + integer, intent(in) :: id, it, jt, kt, icase + + real, intent(inout), dimension( 1:num_chem ) :: rbox + + real, intent(inout), dimension( maxd_asize, maxd_atype ) :: & + fr_partit_cw + + real, intent(inout), dimension( 2, 3 ) :: xvol_old + +! local variables + integer :: isize, itype + integer :: jdone_mass, jdone_numb, jpos, jpos_mass, jpos_numb + integer :: l, ll + integer :: p1st +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) + integer :: lunxx +#endif + + real, parameter :: partit_wght_mass = 0.5 + + real :: tmpa, tmpb, tmpc + real :: tmp_cwvolfrac, tmp_lnsg + real :: tmass, tnumb, umass, unumb, wmass, wnumb + real :: xmass_c, xmass_a, xmass_t, xvolu_c, xvolu_a, xvolu_t + real :: xnumb_c1, xnumb_a1, xnumb_t1, xnumb_c2, xnumb_a2, xnumb_t2 + real, dimension( maxd_asize, maxd_atype ) :: fmass, fnumb, xmass, xnumb, xnumbsv + + + p1st = PARAM_FIRST_SCALAR + + tmass = 0.0 + tnumb = 0.0 + umass = 0.0 + unumb = 0.0 + +! compute +! xmass, xnumb = mass, number mixing ratio for a bin +! tmass, tnumb = sum over all bins of xmass, xnumb +! umass, unumb = max over all bins of xmass, xnumb +! set xmass, xnumb = 0.0 if bin mass, numb < 1.0e-37 +! constrain xnumb so that mean particle volume is +! within bin boundaries +! for made-sorgam, x/t/umass are g/kg-air, x/t/unumb are #/kg-air + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + xmass_c = 0.0 + xvolu_c = 0.0 + xvolu_a = 0.0 + do ll = 1, ncomp_aer(itype) + l = massptr_aer(ll,isize,itype,cw_phase) + if (l .ge. p1st) then + tmpa = max( 0.0, rbox(l) )*1.0e-6 + xmass_c = xmass_c + tmpa + xvolu_c = xvolu_c + tmpa/dens_aer(ll,itype) + end if + l = massptr_aer(ll,isize,itype,ai_phase) + if (l .ge. p1st) then + tmpa = max( 0.0, rbox(l) )*1.0e-6 + xvolu_a = xvolu_a + tmpa/dens_aer(ll,itype) + end if + end do + + xnumb_c1 = max( 0.0, rbox(numptr_aer(isize,itype,cw_phase)) ) + xnumb_a1 = max( 0.0, rbox(numptr_aer(isize,itype,ai_phase)) ) + xnumbsv(isize,itype) = xnumb_c1 + xnumb_t1 = xnumb_a1 + xnumb_c1 + xvolu_t = xvolu_a + xvolu_c + +! do "bounding" activated+interstitial combined number +! and calculate dgnum for activated+interstitial combined + if (xvolu_t < smallvolaa) then + xnumb_t2 = xvolu_t/volumcen_sect(isize,itype) + else if (xnumb_t1 < xvolu_t/volumhi_sect(isize,itype)) then + xnumb_t2 = xvolu_t/volumhi_sect(isize,itype) + else if (xnumb_t1 > xvolu_t/volumlo_sect(isize,itype)) then + xnumb_t2 = xvolu_t/volumlo_sect(isize,itype) + else + xnumb_t2 = xnumb_t1 + end if + +! do "bounding" of activated number +! tmp_cwvolfrac = (cw volume)/(ai + cw volume) + tmp_cwvolfrac = xvolu_c/max(xvolu_t,1.e-30) + tmp_lnsg = log(sigmag_aer(isize,itype)) + if ((xvolu_c < smallvolaa) .or. (tmp_cwvolfrac < 1.0e-10)) then +! for very small cw volume or volume fraction, +! use (ai+cw number)*(cw volume fraction) + xnumb_c2 = xnumb_t2*tmp_cwvolfrac + tmpa = -7.0 ; tmpb = -7.0 ; tmpc = -7.0 + else +! tmpa is value of (ln(dpcut)-ln(dgvol))/ln(sigmag) for which +! "norm01 upper tail" cummulative pdf is equal to tmp_cwvolfrac + tmpa = norm01_uptail_inv( tmp_cwvolfrac ) +! tmpb is corresponding value of (ln(dp)-ln(dgnum))/ln(sigmag) + tmpb = tmpa + 3.0*tmp_lnsg +! tmpc is corresponding "norm01 upper tail" cummulative pdf + tmpc = norm01_uptail( tmpb ) +! minimum number of activated particles occurs when +! activated particles are dp>dpcut and interstitial are dp 0 + lunxx = 86 + lunxx = -1 + if ((it==23) .and. (jt==1) .and. (kt<=20)) lunxx = 171 + if (lunxx > 0) then + if ((isize == 1) .and. (itype == 1)) write(lunxx,'(a)') + write(lunxx,'(a,3i4,4x,2i4,2x,l2)') 'partition-cw i,j,k, is,it', & + it, jt, kt, isize, itype + write(lunxx,'(a,1p,5e12.4)') 'cw vol, num old/adj ', & + xvolu_c, xnumb_c1, xnumb_c2 + write(lunxx,'(a,1p,5e12.4)') 'ai vol, num old/adj ', & + xvolu_a, xnumb_a1, xnumb_a2 + write(lunxx,'(a,1p,5e12.4)') 'a+c vol, num old/adj ', & + xvolu_t, xnumb_t1, xnumb_t2 + write(lunxx,'(a,1p,5e12.4)') 'lnsg, cwvolfr, cwnumfr 1/2', & + tmp_lnsg, tmp_cwvolfrac, & + xnumb_c1/max(xnumb_t1,1.0e-30), & + xnumb_c2/max(xnumb_t2,1.0e-30) + write(lunxx,'(a,1p,5e12.4)') 'tmpa/b/c ', & + tmpa, tmpb, tmpc + write(lunxx,'(a,1p,5e12.4)') 'dlo, dcen, dhi_sect ', & + dlo_sect(isize,itype), dcen_sect(isize,itype), & + dhi_sect(isize,itype) + write(lunxx,'(a,1p,5e12.4)') 'vlo, vcen, vhi_sect ', & + volumlo_sect(isize,itype), volumcen_sect(isize,itype), & + volumhi_sect(isize,itype) + end if +#endif + + if (xmass_c .lt. 1.0e-37) xmass_c = 0.0 + xmass(isize,itype) = xmass_c + if (xnumb_c2 .lt. 1.0e-37) xnumb_c2 = 0.0 + xnumb(isize,itype) = xnumb_c2 + xnumbsv(isize,itype) = xnumb_c1 + + tmass = tmass + xmass(isize,itype) + tnumb = tnumb + xnumb(isize,itype) + umass = max( umass, xmass(isize,itype) ) + unumb = max( unumb, xnumb(isize,itype) ) + + if ((itype == 1) .and. (isize <= 2)) then + xvol_old(isize,1) = xvolu_c + xvol_old(isize,2) = xvolu_a + xvol_old(isize,3) = xvolu_t + end if + end do + end do + +! compute +! fmass, fnumb = fraction of total mass, number that is in a bin +! if tmass<1e-35 and umass>0, set fmass=1 for bin with largest xmass +! if tmass<1e-35 and umass=0, set fmass=0 for all + jdone_mass = 0 + jdone_numb = 0 + jpos_mass = 0 + jpos_numb = 0 + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + fmass(isize,itype) = 0.0 + if (tmass .ge. 1.0e-35) then + fmass(isize,itype) = xmass(isize,itype)/tmass + else if (umass .gt. 0.0) then + if ( (jdone_mass .eq. 0) .and. & + (xmass(isize,itype) .eq. umass) ) then + jdone_mass = 1 + fmass(isize,itype) = 1.0 + end if + end if + if (fmass(isize,itype) .gt. 0) jpos_mass = jpos_mass + 1 + + fnumb(isize,itype) = 0.0 + if (tnumb .ge. 1.0e-35) then + fnumb(isize,itype) = xnumb(isize,itype)/tnumb + else if (unumb .gt. 0.0) then + if ( (jdone_numb .eq. 0) .and. & + (xnumb(isize,itype) .eq. unumb) ) then + jdone_numb = 1 + fnumb(isize,itype) = 1.0 + end if + end if + if (fnumb(isize,itype) .gt. 0) jpos_numb = jpos_numb + 1 + end do + end do + +! if only 1 bin has fmass or fnumb > 0, set value to 1.0 exactly + if ((jpos_mass .eq. 1) .or. (jpos_numb .eq. 1)) then + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + if (jpos_mass .eq. 1) then + if (fmass(isize,itype) .gt. 0) fmass(isize,itype) = 1.0 + end if + if (jpos_numb .eq. 1) then + if (fnumb(isize,itype) .gt. 0) fnumb(isize,itype) = 1.0 + end if + end do + end do + end if + +! +! compute fr_partit_cw as weighted average of fmass & fnumb, except +! if tmass<1e-35 and umass=0, use only fnumb +! if tnumb<1e-35 and unumb=0, use only fmass +! if tmass,tnumb<1e-35 and umass,unumb=0, +! set fr_partit_cw=1 for center bin of itype=1 +! + fr_partit_cw(:,:) = 0.0 + if ((jpos_mass .eq. 0) .and. (jpos_numb .eq. 0)) then + itype = 1 + isize = (nsize_aer(itype)+1)/2 + fr_partit_cw(isize,itype) = 1.0 + + else if (jpos_mass .eq. 0) then + fr_partit_cw(:,:) = fnumb(:,:) + + else if (jpos_numb .eq. 0) then + fr_partit_cw(:,:) = fmass(:,:) + + else + wmass = max( 0.0, min( 1.0, partit_wght_mass ) ) + wnumb = 1.0 - wmass + fr_partit_cw(:,:) = wmass*fmass(:,:) + wnumb*fnumb(:,:) + + jpos = 0 + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + if (fr_partit_cw(isize,itype) .gt. 0.0) jpos = jpos + 1 + end do + end do + +! if only 1 bin has fr_partit_cw > 0, set value to 1.0 exactly + if (jpos .eq. 1) then + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + if (fr_partit_cw(isize,itype) .gt. 0.0) & + fr_partit_cw(isize,itype) = 1.0 + end do + end do + end if + end if + + +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) +! diagnostics when lunxx > 0 + lunxx = 86 + lunxx = -1 + if ((it==23) .and. (jt==1) .and. (kt<=20)) lunxx = 171 +! if (icase .gt. 9) lunxx = -1 + if (lunxx .gt. 0) then + write(lunxx,9800) + write(lunxx,9800) & + 'partition_cldwtr - icase, jpos, jpos_mass, jpos_numb' + write(lunxx,9810) icase, jpos, jpos_mass, jpos_numb + write(lunxx,9800) 'tmass, umass, wmass' + write(lunxx,9820) tmass, umass, wmass + write(lunxx,9800) 'tnumb, unumb, wnumb' + write(lunxx,9820) tnumb, unumb, wnumb + write(lunxx,9800) 'xmass, fmass, xnumb_orig/adj, fnumb, fr_partit_cw' + tmpa = 0.0 + tmpb = 0.0 + tmpc = 0.0 + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + write(lunxx,9820) xmass(isize,itype), fmass(isize,itype), & + xnumbsv(isize,itype), xnumb(isize,itype), & + fnumb(isize,itype), fr_partit_cw(isize,itype) + tmpa = tmpa + fmass(isize,itype) + tmpb = tmpb + fnumb(isize,itype) + tmpc = tmpc + fr_partit_cw(isize,itype) + end do + end do + write(lunxx,9800) & + 'sum_fmass-1.0, sum_fnumb-1.0, sum_fr_partit-1.0' + write(lunxx,9820) (tmpa-1.0), (tmpb-1.0), (tmpc-1.0) + if (icase .le. -5) then + write(*,*) '*** stopping in partition_cldwtr at icase =', icase + call wrf_error_fatal('*** stopping in partition_cldwtr') + end if +9800 format( a ) +9810 format( 5i10 ) +9820 format( 6(1pe10.2) ) + end if +#endif + + + return + end subroutine sorgam_partition_cldwtr + + + +!----------------------------------------------------------------------- + subroutine sorgam_distribute_bulk_changes( & + rbox, rbox_sv1, fr_partit_cw, & + rbulk_cwaer, lptr_yyy_cwaer, & + id, it, jt, kt, icase ) + + use module_state_description, only: & + param_first_scalar, num_chem + + use module_scalar_tables, only: chem_dname_table + + use module_data_sorgam_vbs, only: & + maxd_asize, maxd_atype, & + cw_phase, nsize_aer, ntype_aer, do_cloudchem_aer, & + lptr_so4_aer, lptr_no3_aer, lptr_nh4_aer, & + lptr_orgpa_aer, lptr_ec_aer, lptr_p25_aer + + + implicit none + +! subr arguments + integer, intent(in) :: id, it, jt, kt, icase + + integer, intent(in) :: lptr_yyy_cwaer(maxd_asize,maxd_atype,nyyy) + + real, intent(inout), dimension( 1:num_chem ) :: rbox, rbox_sv1 + + real, intent(in), dimension( maxd_asize, maxd_atype ) :: & + fr_partit_cw + + real, intent(in), dimension( nyyy, 2 ) :: rbulk_cwaer + + +! local variables + integer :: iphase, isize, itype + integer :: idone, icount, ncount + integer :: jpos, jpos_sv + integer :: l, lunxxaa, lunxxbb, lyyy + integer :: p1st +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) + integer :: lunxx +#endif + + real :: duma, dumb, dumc + real :: fr, frsum_cur + real :: fr_cur(maxd_asize,maxd_atype) + real :: del_r_current, del_r_remain + real :: del_rbulk_cwaer(nyyy) + + + p1st = param_first_scalar + + do lyyy = 1, nyyy + del_rbulk_cwaer(lyyy) = rbulk_cwaer(lyyy,2) - rbulk_cwaer(lyyy,1) + end do + + iphase = cw_phase + + + jpos = 0 + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + if (fr_partit_cw(isize,itype) .gt. 0) jpos = jpos + 1 + end do + end do + jpos_sv = jpos + +! +! distribution is trivial when only 1 bin has fr_partit_cw > 0 +! + if (jpos_sv .eq. 1) then + do lyyy = 1, nyyy + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + fr = fr_partit_cw(isize,itype) + if (fr .eq. 1.0) then + l = lptr_yyy_cwaer(isize,itype,lyyy) + if (l .ge. p1st) rbox(l) = rbulk_cwaer(lyyy,2) + end if + end do + end do + + end do + goto 7900 + end if + + + do 3900 lyyy = 1, nyyy + +! +! distribution is simple when del_rbulk_cwaer(lyyy) >= 0 +! + if (del_rbulk_cwaer(lyyy) .eq. 0.0) then + goto 3900 + else if (del_rbulk_cwaer(lyyy) .gt. 0.0) then + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + fr = fr_partit_cw(isize,itype) + if (fr .gt. 0.0) then + l = lptr_yyy_cwaer(isize,itype,lyyy) + if (l .ge. p1st) then + rbox(l) = rbox(l) + fr*del_rbulk_cwaer(lyyy) + end if + end if + end do + end do + + goto 3900 + end if + +! +! distribution is complicated when del_rbulk_cwaer(lyyy) < 0, +! because you cannot produce any negative mixrats +! + del_r_remain = del_rbulk_cwaer(lyyy) + fr_cur(:,:) = fr_partit_cw(:,:) + + ncount = max( 1, jpos_sv*2 ) + icount = 0 + +! iteration loop + do while (icount .le. ncount) + + icount = icount + 1 + del_r_current = del_r_remain + jpos = 0 + frsum_cur = 0.0 + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + + fr = fr_cur(isize,itype) + + if (fr .gt. 0.0) then + l = lptr_yyy_cwaer(isize,itype,lyyy) + if (l .ge. p1st) then + duma = fr*del_r_current + dumb = rbox(l) + duma + if (dumb .gt. 0.0) then + jpos = jpos + 1 + else if (dumb .eq. 0.0) then + fr_cur(isize,itype) = 0.0 + else + duma = -rbox(l) + dumb = 0.0 + fr_cur(isize,itype) = 0.0 + end if + del_r_remain = del_r_remain - duma + rbox(l) = dumb + frsum_cur = frsum_cur + fr_cur(isize,itype) + else + fr_cur(isize,itype) = 0.0 + end if + end if + + end do ! isize = 1, nsize_aer + end do ! itype = 1, ntype_aer + +! done if jpos = jpos_sv, because bins reached zero mixrat + if (jpos .eq. jpos_sv) then + idone = 1 +! del_r_remain starts as negative, so done if non-negative + else if (del_r_remain .ge. 0.0) then + idone = 2 +! del_r_remain starts as negative, so done if non-negative + else if (abs(del_r_remain) .le. 1.0e-7*abs(del_rbulk_cwaer(lyyy))) then + idone = 3 +! done if all bins have fr_cur = 0 + else if (frsum_cur .le. 0.0) then + idone = 4 +! same thing basically + else if (jpos .le. 0) then + idone = 5 + else + idone = 0 + end if + +! check for done, and (conditionally) print message + if (idone .gt. 0) then + lunxxaa = 6 +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) +! lunxxaa = 86 + if ((it==23) .and. (jt==1) .and. (kt<=20)) lunxxaa = 171 +#endif + if ((lunxxaa .gt. 0) .and. (icount .gt. (1+jpos_sv)/2)) then + write(lunxxaa,9800) & + 'distribute_bulk_changes - icount>jpos_sv/2 - i,j,k' + write(lunxxaa,9810) it, jt, kt + write(lunxxaa,9800) 'icase, lyyy, idone, icount, jpos, jpos_sv' + write(lunxxaa,9810) icase, lyyy, idone, icount, jpos, jpos_sv + end if + goto 3900 + end if + +! rescale fr_cur for next iteration + fr_cur(:,:) = fr_cur(:,:)/frsum_cur + + end do ! while (icount .le. ncount) + + +! icount > ncount, so print message + lunxxbb = 6 +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) +! lunxxbb = 86 + if ((it==23) .and. (jt==1) .and. (kt<=20)) lunxxbb = 171 +#endif + if (lunxxbb .gt. 0) then + write(lunxxbb,9800) + write(lunxxbb,9800) & + 'distribute_bulk_changes - icount>ncount - i,j,k' + write(lunxxbb,9810) it, jt, kt + write(lunxxbb,9800) 'icase, lyyy, icount, ncount, jpos_sv, jpos' + write(lunxxbb,9810) icase, lyyy, icount, ncount, jpos_sv, jpos + write(lunxxbb,9800) 'rbulk_cwaer(1), del_rbulk_cwaer, del_r_remain, frsum_cur, (frsum_cur-1.0)' + write(lunxxbb,9820) rbulk_cwaer(lyyy,1), del_rbulk_cwaer(lyyy), & + del_r_remain, frsum_cur, (frsum_cur-1.0) + end if +9800 format( a ) +9801 format( 3a ) +9810 format( 7i10 ) +9820 format( 7(1pe10.2) ) +9840 format( 2i3, 5(1pe14.6) ) + + +3900 continue + +7900 continue + + +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) +! diagnostics for testing + lunxx = 88 + lunxx = -1 + if ((it==23) .and. (jt==1) .and. (kt<=20)) lunxx = 171 + if (lunxx .gt. 0) then + icount = 0 + do lyyy = 1, nyyy + duma = del_rbulk_cwaer(lyyy) + if ( abs(duma) .gt. & + max( 1.0e-35, 1.0e-5*abs(rbulk_cwaer(lyyy,1)) ) ) then + icount = icount + 1 + if (icount .eq. 1) write(lunxx,9800) + if (icount .eq. 1) write(lunxx,9800) + write(lunxx,9800) + l = lptr_yyy_cwaer(1,1,lyyy) + if (l .ge. p1st) then + write(lunxx,9801) 'distribute_bulk_changes - ', & + chem_dname_table(id,l)(1:12), ' - icase, lyyy, l11' + else + write(lunxx,9801) 'distribute_bulk_changes - ', & + 'name = ?????', ' - icase, lyyy, l11' + end if + write(lunxx,9810) icase, lyyy, l + write(lunxx,9800) ' tp sz rbox_sv1, rbox, del_rbox' // & + ', del_rbox/del_rbulk_cwaer, (...-fr_partit_cw)' + write(lunxx,9840) 0, 0, rbulk_cwaer(lyyy,1:2), duma + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) cycle + l = lptr_yyy_cwaer(isize,itype,lyyy) + if (l .lt. p1st) cycle + dumb = rbox(l) - rbox_sv1(l) + dumc = dumb/max( abs(duma), 1.0e-35 ) + if (duma .lt. 0.0) dumc = -dumc + write(lunxx,9840) itype, isize, rbox_sv1(l), rbox(l), & + dumb, dumc, (dumc-fr_partit_cw(isize,itype)) + end do + end do + end if + end do + if (icase .le. -5) then + write(*,*) & + '*** stop in distribute_bulk_changes diags, icase =', icase + call wrf_error_fatal('*** stop in distribute_bulk_changes diags') + end if + end if +#endif + + + return + end subroutine sorgam_distribute_bulk_changes + + + +!----------------------------------------------------------------------- + subroutine sorgam_cloudchem_apply_mode_transfer( & + rbox, rbox_sv1, xvol_old, & + id, it, jt, kt, icase ) + + use module_state_description, only: & + param_first_scalar, num_chem + + use module_scalar_tables, only: chem_dname_table + + use module_data_sorgam_vbs, only: & + pirs, & + msectional, & + maxd_asize, maxd_atype, & + ai_phase, cw_phase, nsize_aer, ntype_aer, ncomp_aer, & + do_cloudchem_aer, massptr_aer, numptr_aer, dens_aer, & + sigmag_aer, dcen_sect, dlo_sect, dhi_sect, & + volumcen_sect, volumlo_sect, volumhi_sect, & + lptr_so4_aer, lptr_nh4_aer, lptr_p25_aer + + use module_aerosols_sorgam_vbs, only: getaf + + + implicit none + +! subr arguments + integer, intent(in) :: id, it, jt, kt, icase + + real, intent(inout), dimension( 1:num_chem ) :: rbox, rbox_sv1 + + real, intent(in), dimension( 2, 3 ) :: xvol_old + + +! local variables + integer :: idum_msect + integer :: ii, isize, isize_ait, isize_acc, itype + integer :: jj + integer :: l, lfrm, ltoo, ll + integer :: lptr_dum(maxd_asize,maxd_atype) + integer :: p1st +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) + integer :: lunxx +#endif + + logical :: skip_xfer + + real :: delvol(2) + real :: fracrem_num, fracrem_vol, fracxfr_num, fracxfr_vol + real :: rbox_sv2(1:num_chem) + real :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf + real :: tmp_cwnumfrac, tmp_cwvolfrac + real :: tmp_dpmeanvol, tmp_lnsg + real :: xcut_num, xcut_vol + real :: xdgnum_aaa(2), xlnsg(2) + real :: xnum_aaa(2,3) + real :: xvol_aaa(2,3) + + +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) +! diagnostics for testing + lunxx = -1 + if ((it==23) .and. (jt==1) .and. (kt<=20)) lunxx = 171 +#endif + + p1st = param_first_scalar + +! +! initial calculations for aitken (ii=1) and accum (ii=2) modes +! + skip_xfer = .false. + + do ii = 1, 2 + itype = 1 + isize = ii + +! calculate new volumes for activated (jj=1), interstitial (jj=2), and combined (jj=3) + tmpa = 0.0 + do ll = 1, ncomp_aer(itype) + l = massptr_aer(ll,isize,itype,cw_phase) + if (l >= p1st) tmpa = tmpa + rbox(l)/dens_aer(ll,itype) + end do + xvol_aaa(ii,1) = tmpa*1.0e-6 + xvol_aaa(ii,2) = xvol_old(ii,2) + xnum_aaa(ii,1) = rbox(numptr_aer(isize,itype,cw_phase)) + xnum_aaa(ii,2) = rbox(numptr_aer(isize,itype,ai_phase)) + + xvol_aaa(ii,3) = xvol_aaa(ii,1) + xvol_aaa(ii,2) + xnum_aaa(ii,3) = xnum_aaa(ii,1) + xnum_aaa(ii,2) + delvol(ii) = xvol_aaa(ii,1) - xvol_old(ii,1) + +! check for negligible number or volume in aitken mode + if (ii == 1) then + if (xvol_aaa(ii,3) < smallvolaa) then + skip_xfer = .true. + exit + end if + end if + +! calculate dgnum for activated+interstitial combined using new volume + if (xvol_aaa(ii,3) < smallvolaa) then + tmp_dpmeanvol = dcen_sect(isize,itype) + else + tmp_dpmeanvol = xvol_aaa(ii,3)/xnum_aaa(ii,3) + tmp_dpmeanvol = (tmp_dpmeanvol*6.0/pirs)**0.33333333 + end if + xlnsg(ii) = log(sigmag_aer(isize,itype)) + xdgnum_aaa(ii) = tmp_dpmeanvol*exp(-1.5*xlnsg(ii)*xlnsg(ii)) +! tmp_cwvolfrac = (cw volume)/(ai + cw volume) + tmp_cwvolfrac = xvol_aaa(ii,1)/max(xvol_aaa(ii,3),1.e-30) + +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) +! diagnostics for testing + if (lunxx > 0) then + if (ii == 1) write(lunxx,'(a)') + write(lunxx,'(a,3i4,i8,2x,l2)') 'merge i,j,k, ii,skip', & + it, jt, kt, ii, skip_xfer + write(lunxx,'(a,1p,5e12.4)') 'cw vol old/aaa, num aaa ', & + xvol_old(ii,1), xvol_aaa(ii,1), xnum_aaa(ii,1) + write(lunxx,'(a,1p,5e12.4)') 'ai vol old/aaa, num aaa ', & + xvol_old(ii,2), xvol_aaa(ii,2), xnum_aaa(ii,2) + write(lunxx,'(a,1p,5e12.4)') 'a+c vol old/aaa, num aaa ', & + xvol_old(ii,3), xvol_aaa(ii,3), xnum_aaa(ii,3) + write(lunxx,'(a,1p,5e12.4)') 'cwnum/volfrac, dpmeanvol, dgnum ', & + (xnum_aaa(ii,1)/max(xnum_aaa(ii,3),1.e-30)), & + tmp_cwvolfrac, tmp_dpmeanvol, xdgnum_aaa(ii) + end if +#endif + + end do ! ii = 1, 2 + + +! check for mode merging + if ( skip_xfer ) return + if (delvol(1) > delvol(2)) then + continue + else if ( (xdgnum_aaa(1) > 0.03e-4) .and. (xnum_aaa(1,3) > xnum_aaa(2,3)) ) then + continue + else + return + end if +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) + if (lunxx > 0) then + if (delvol(1) > delvol(2)) then + write(lunxx,'(a)') 'do merging - criterion 1' + else if ( (xdgnum_aaa(1) > 0.03e-4) .and. (xnum_aaa(1,3) > xnum_aaa(2,3)) ) then + write(lunxx,'(a)') 'do merging - criterion 2' + end if + end if +#endif + +! +! calc transfer fractions for volume/mass and number +! approach follows that in module_aerosols_sorgam (subr aerostep) except +! >> the first steps of the calculation are done using the total +! (interstitial+activated) size distributions +! >> the number and volume (moment-3) transfer amounts are then limited +! to the number/volume of the aitken activated distribution +! +! xcut_num = [ln(dintsect/dgnuc)/xxlsgn], where dintsect is the diameter +! at which the aitken-mode and accum-mode number distribs intersect (overlap). + tmpa = sqrt(2.0) +! aaa = getaf( nu0, ac0, dgnuc, dgacc, xxlsgn, xxlsga, sqrt2 ) + xcut_num = tmpa * getaf( xnum_aaa(1,3), xnum_aaa(2,3), & + xdgnum_aaa(1), xdgnum_aaa(2), xlnsg(1), xlnsg(2), tmpa ) + +! forcing xcut_vol>0 means that no more than half of the aitken volume +! will be transferred + tmpd = xcut_num + tmpc = 3.0*xlnsg(1) + xcut_vol = max( xcut_num-tmpc, 0.0 ) + xcut_num = xcut_vol + tmpc + fracxfr_vol = norm01_uptail( xcut_vol ) + fracxfr_num = norm01_uptail( xcut_num ) + tmpe = fracxfr_vol ; tmpf = fracxfr_num + + tmp_cwvolfrac = xvol_aaa(1,1)/max(xvol_aaa(1,3),1.e-30) + tmp_cwnumfrac = xnum_aaa(1,1)/max(xnum_aaa(1,3),1.e-30) + if ( (fracxfr_vol >= tmp_cwvolfrac) .or. & + (fracxfr_num >= tmp_cwnumfrac) ) then +! limit volume fraction transferred to tmp_cwvolfrac +! limit number fraction transferred to tmp_cwnumfrac + fracxfr_num = 1.0 + fracxfr_vol = 1.0 + else +! at this point, fracxfr_num/vol are fraction of +! interstitial+activated num/vol to be transferred +! convert them to fraction of activated num/vol to be transferred + fracxfr_vol = fracxfr_vol/max(1.0e-10,tmp_cwvolfrac) + fracxfr_num = fracxfr_num/max(1.0e-10,tmp_cwnumfrac) +! number fraction transferred cannot exceed volume fraction + fracxfr_num = min( fracxfr_num, fracxfr_vol ) + end if + fracrem_vol = 1.0 - fracxfr_vol + fracrem_num = 1.0 - fracxfr_num +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) + if (lunxx > 0) then + write(lunxx,'(a,1p,5e12.4)') 'xcut_num1/num2/vol ', & + tmpd, xcut_num, xcut_vol + write(lunxx,'(a,1p,5e12.4)') 'fracxfr_num3/vol3/num1,vol1 ', & + tmpf, tmpe, fracxfr_num, fracxfr_vol + end if +#endif + if ( skip_xfer ) return + +! do the transfer + rbox_sv2(:) = rbox(:) + itype = 1 + isize_ait = 1 + isize_acc = 2 + + lfrm = numptr_aer(isize_ait,itype,cw_phase) + ltoo = numptr_aer(isize_acc,itype,cw_phase) + rbox(ltoo) = rbox(ltoo) + rbox(lfrm)*fracxfr_num + rbox(lfrm) = rbox(lfrm)*fracrem_num + + do ll = 1, ncomp_aer(itype) + lfrm = massptr_aer(ll,isize_ait,itype,cw_phase) + ltoo = massptr_aer(ll,isize_acc,itype,cw_phase) + if (lfrm >= p1st) then + if (ltoo >= p1st) rbox(ltoo) = rbox(ltoo) & + + rbox(lfrm)*fracxfr_vol + rbox(lfrm) = rbox(lfrm)*fracrem_vol + end if + end do + + +#if defined ( ccboxtest_box_testing_active ) || defined ( cctemp_testing_active ) +! more diagnostics for testing + if (lunxx .gt. 0) then + do ll = 1, 4 + if (ll .eq. 1) then + lptr_dum(:,:) = lptr_so4_aer(:,:,cw_phase) + else if (ll .eq. 2) then + lptr_dum(:,:) = lptr_nh4_aer(:,:,cw_phase) + else if (ll .eq. 3) then + lptr_dum(:,:) = lptr_p25_aer(:,:,cw_phase) + else if (ll .eq. 4) then + lptr_dum(:,:) = numptr_aer(:,:,cw_phase) + end if + + if (ll .eq. 1) write(lunxx,'(a)') + write(lunxx,'(2a,i6,i3,2x,a)') 'sorgam_cloudchem_apply_mode_transfer', & + ' - icase, ll', icase, ll, & + chem_dname_table(id,lptr_dum(1,1))(1:12) + write(lunxx,'(a)') ' ty sz rbox_sv1, rbox, rsub' + + itype = 1 + do ii = 1, 2 + if (ii == 1) then + isize = isize_ait + else + isize = isize_acc + end if + l = lptr_dum(isize,itype) + write(lunxx,'(2i3,1p,5e14.6)') & + itype, isize, rbox_sv1(l), rbox_sv2(l), rbox(l) + end do + end do + + if (icase .le. -5) then + write(*,*) & + '*** stop in sorgam_cloudchem_apply_mode_transfer diags, icase =', & + icase + call wrf_error_fatal('*** stop in sorgam_cloudchem_apply_mode_transfer diags') + end if + end if +#endif + + + return + end subroutine sorgam_cloudchem_apply_mode_transfer + + + +!----------------------------------------------------------------------- + real function norm01_uptail( x ) +! +! norm01_uptail = cummulative pdf complement of normal(0,1) pdf +! = integral from x to +infinity of [normal(0,1) pdf] +! +! erfc_num_recipes is from press et al, numerical recipes, 1990, page 164 +! + implicit none + real x, xabs + real*8 erfc_approx, tmpa, t, z + + xabs = abs(x) + if (xabs >= 12.962359) then + if (x > 0.0) then + norm01_uptail = 0.0 + else + norm01_uptail = 1.0 + end if + return + end if + + z = xabs / sqrt(2.0_8) + t = 1.0_8/(1.0_8 + 0.5_8*z) + +! erfc_approx = +! & t*exp( -z*z - 1.26551223 + t*(1.00002368 + t*(0.37409196 + +! & t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 + +! & t*(-1.13520398 + +! & t*(1.48851587 + t*(-0.82215223 + t*0.17087277 ))))))))) + + tmpa = ( -z*z - 1.26551223_8 + t*(1.00002368_8 + t*(0.37409196_8 + & + t*(0.09678418_8 + t*(-0.18628806_8 + t*(0.27886807_8 + & + t*(-1.13520398_8 + & + t*(1.48851587_8 + t*(-0.82215223_8 + t*0.17087277_8 ))))))))) + + erfc_approx = t * exp(tmpa) + if (x .lt. 0.0) erfc_approx = 2.0_8 - erfc_approx + + norm01_uptail = 0.5_8 * erfc_approx + + return + end function norm01_uptail + +!----------------------------------------------------------------------- + real function norm01_uptail_inv( x ) +! +! norm01_uptail_inv = inverse of norm01_uptail +! if y = norm01_uptail_inv( x ), then +! {integral from y to +infinity of [normal(0,1) pdf]} = x +! y is computed using newton's method +! + implicit none + +! fn parameters + real x + +! local variables + integer niter + real dfdyinv, f, pi, sqrt2pi, tmpa, y, ynew + + parameter (pi = 3.1415926535897932384626434) + + if (x .le. 1.0e-38) then + norm01_uptail_inv = 12.962359 + return + else if (x .ge. 1.0) then + norm01_uptail_inv = -12.962359 + return + end if + + sqrt2pi = sqrt( 2.0*pi ) + +! initial guess +! crude +! y = 3.0*(0.5 - x) +! better + tmpa = x + tmpa = max( 0.0, min( 1.0, tmpa ) ) + tmpa = 4.0*tmpa*(1.0 - tmpa) + tmpa = max( 1.0e-38, min( 1.0, tmpa ) ) + y = sqrt( -(pi/2.0)*log(tmpa) ) + if (x > 0.5) y = -y + + f = norm01_uptail(y) - x + do niter = 1, 100 +! iterate - dfdy is computed analytically + dfdyinv = -sqrt2pi * exp( 0.5*y*y ) + ynew = y - f*dfdyinv + f = norm01_uptail(ynew) - x + + if ( (ynew == y) .or. & + (abs(f) <= abs(x)*1.0e-5) ) then + exit + end if + y = ynew + end do +9100 format( 'niter/x/f/y/ynew', i5, 4(1pe16.8) ) + + norm01_uptail_inv = ynew + return + end function norm01_uptail_inv + + + +!----------------------------------------------------------------------- + subroutine sorgam_cloudchem_dumpaa( & + id, ktau, ktauc, dtstepc, config_flags, & + p_phy, t_phy, rho_phy, alt, & + cldfra, ph_no2, & + moist, chem, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + qcldwtr_cutoff, & + itcur, jtcur, ktcur ) + + use module_state_description, only: & + num_moist, num_chem, p_qc + use module_scalar_tables, only: chem_dname_table + use module_configure, only: grid_config_rec_type + use module_data_sorgam_vbs + + + implicit none + +! subr arguments + integer, intent(in) :: & + id, ktau, ktauc, & + numgas_aqfrac, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + itcur, jtcur, ktcur +! id - domain index +! ktau - time step number +! ktauc - gas and aerosol chemistry time step number +! numgas_aqfrac - last dimension of gas_aqfrac + +! [ids:ide, kds:kde, jds:jde] - spatial (x,z,y) indices for 'domain' +! [ims:ime, kms:kme, jms:jme] - spatial (x,z,y) indices for 'memory' +! Most arrays that are arguments to chem_driver +! are dimensioned with these spatial indices. +! [its:ite, kts:kte, jts:jte] - spatial (x,z,y) indices for 'tile' +! chem_driver and routines under it do calculations +! over these spatial indices. + + type(grid_config_rec_type), intent(in) :: config_flags +! config_flags - configuration and control parameters + + real, intent(in) :: & + dtstepc, qcldwtr_cutoff +! dtstepc - time step for gas and aerosol chemistry(s) + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + p_phy, t_phy, rho_phy, alt, cldfra, ph_no2 +! p_phy - air pressure (Pa) +! t_phy - temperature (K) +! rho_phy - moist air density (kg/m^3) +! alt - dry air specific volume (m^3/kg) +! cldfra - cloud fractional area (0-1) +! ph_no2 - no2 photolysis rate (1/min) + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_moist ) :: & + moist +! moist - mixing ratios of moisture species (water vapor, +! cloud water, ...) (kg/kg for mass species, #/kg for number species) + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem +! chem - mixing ratios of trace gas and aerosol species (ppm for gases, +! ug/kg for aerosol mass species, #/kg for aerosol number species) + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, numgas_aqfrac ) :: & + gas_aqfrac +! gas_aqfrac - fraction (0-1) of gas that is dissolved in cloud water + + +! local variables + integer :: it, jt, kt, l, ll, n + integer :: isize, itype + + real :: dumai, dumcw + real :: qcldwtr + + + it = itcur + jt = jtcur + kt = ktcur + + write(*,*) + write(*,*) + write(*,*) + write(*,9100) + write(*,9102) ktau, it, jt, kt +9100 format( 7('----------') ) +9102 format( & + 'sorgam_cloudchem_dumpaa - ktau, i, j, k =', 4i5 ) + + do 2900 itype = 1, ntype_aer + do 2900 isize = 1, nsize_aer(itype) + if ( .not. do_cloudchem_aer(isize,itype) ) goto 2900 + + write(*,9110) isize +9110 format( / 'isize, itype =', 2i3 / & + ' k cldwtr mass-ai numb-ai mass-cw numb-cw' ) + + do 2800 kt = kte, kts, -1 + + dumai = 0.0 + dumcw = 0.0 + do ll = 1, ncomp_aer(itype) + l = massptr_aer(ll,isize,itype,1) + dumai = dumai + chem(it,kt,jt,l) + l = massptr_aer(ll,isize,itype,2) + dumcw = dumcw + chem(it,kt,jt,l) + end do + write(*,9120) kt, & + moist(it,kt,jt,p_qc), & + dumai, chem(it,kt,jt,numptr_aer(isize,itype,1)), & + dumcw, chem(it,kt,jt,numptr_aer(isize,itype,2)) +9120 format( i3, 1p, e10.2, 2(3x, 2e10.2) ) + +2800 continue +2900 continue + + write(*,*) + write(*,9100) + write(*,*) + +! map from wrf-chem 3d arrays to pegasus clm & sub arrays + kt = ktcur + if ((ktau .eq. 30) .and. (it .eq. 23) .and. & + (jt .eq. 1) .and. (kt .eq. 11)) then + qcldwtr = moist(it,kt,jt,p_qc) + write(*,*) + write(*,*) + write(*,9102) ktau, it, jt, kt + write(*,*) + write( *, '(3(1pe10.2,3x,a))' ) & + (chem(it,kt,jt,l), chem_dname_table(id,l)(1:12), l=1,num_chem) + write(*,*) + write( *, '(3(1pe10.2,3x,a))' ) & + p_phy(it,kt,jt), 'p_phy ', & + t_phy(it,kt,jt), 't_phy ', & + rho_phy(it,kt,jt), 'rho_phy ', & + alt(it,kt,jt), 'alt ', & + qcldwtr, 'qcldwtr ', & + qcldwtr_cutoff, 'qcldwtrcut' + write(*,*) + write(*,9100) + write(*,*) + end if + + + return + end subroutine sorgam_cloudchem_dumpaa + + + +!----------------------------------------------------------------------- + end module module_sorgam_vbs_cloudchem diff --git a/wrfv2_fire/chem/module_uoc_dust.F b/wrfv2_fire/chem/module_uoc_dust.F index bfa4ac65..18f4c967 100644 --- a/wrfv2_fire/chem/module_uoc_dust.F +++ b/wrfv2_fire/chem/module_uoc_dust.F @@ -12,7 +12,7 @@ MODULE uoc_dust USE qf03 USE module_soilpsd USE module_sf_noahlsm, ONLY:DRYSMC - USE module_sf_noahmplsm, ONLY: DRYSMC_nmp => DRYSMC + USE NOAHMP_PARAMETERS, ONLY: DRYSMC_nmp => SMCDRY USE module_sf_ruclsm, ONLY:DRYSMC_ruc => DRYSMC CONTAINS diff --git a/wrfv2_fire/chem/module_wave_data.F b/wrfv2_fire/chem/module_wave_data.F index b67522a4..8178f442 100644 --- a/wrfv2_fire/chem/module_wave_data.F +++ b/wrfv2_fire/chem/module_wave_data.F @@ -21,9 +21,13 @@ MODULE module_wave_data ! public variables !------------------------------------------------------- integer, public, parameter :: nw = 18 - integer, public, parameter :: nj = 56 +! integer, public, parameter :: nj = 56 +! species table extended + integer, public, parameter :: nj = 58 ! integer, public, parameter :: tuv_jmax = 28 - integer, public, parameter :: tuv_jmax = 30 +! integer, public, parameter :: tuv_jmax = 30 +! species table extended + integer, public, parameter :: tuv_jmax = 58 real(dp), public :: sflx(nw), wl(nw), wc(nw), wu(nw), deltaw(nw) real(dp), public :: xso3(nw), s226(nw), s263(nw), s298(nw) @@ -785,6 +789,19 @@ MODULE module_wave_data 0.1068E-18, 0.1806E-18, 0.2395E-18, 0.8432E-19, 0.4492E-20, & 0.0000E+00, 0.0000E+00 / +!HOCl + hv -> OH + Cl + data (sjref(ii,57),ii=1,17)/ & + 0.0000E+00, 0.0000E+00, 0.0000E+00, 0.0000E+00, 0.0000E+00, & + 0.4436E-19, 0.5807E-19, 0.8483E-19, 0.1532E-18, 0.1040E-18, & + 0.5762E-19, 0.5963E-19, 0.4075E-19, 0.8082E-20, 0.0000E+00, & + 0.0000E+00, 0.0000E+00 / + +! FMCl + hv -> Cl + CO + HO2 + data (sjref(ii,58),ii=1,17)/ & + 0.0000E+00, 0.0000E+00, 0.0000E+00, 0.0000E+00, 0.0000E+00, & + 0.0000E+00, 0.0000E+00, 0.0000E+00, 0.0000E+00, 0.3344E-19, & + 0.3021E-20, 0.2700E-22, 0.0000E+00, 0.0000E+00, 0.0000E+00, & + 0.0000E+00, 0.0000E+00 / ! acolein cross sections ! data (acrolein_xs(ii),ii=1,18)/ & ! 0.0000E+00, 0.0000E+00, 0.0000E+00, 0.0000E+00, 0.0000E+00, & @@ -803,7 +820,8 @@ MODULE module_wave_data !------------------------------------------------------- ! correction coef. for zenith=20 !------------------------------------------------------- - data ((c20(ii,kk),ii=1,5),kk=1,30)/ & +! extended to 58 + data ((c20(ii,kk),ii=1,5),kk=1,58)/ & 0.7070E+01_dp, 0.3759E+00_dp, -.1308E+01_dp, 0.2779E+00_dp, -.1295E-01_dp, & 0.3696E+02_dp, -.3947E+02_dp, 0.1206E+02_dp, -.1179E+01_dp, 0.3640E-01_dp, & -.2446E+01_dp, -.1012E+01_dp, 0.2398E+00_dp, -.2085E-01_dp, 0.5971E-03_dp, & @@ -834,12 +852,41 @@ MODULE module_wave_data 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp / !------------------------------------------------------- ! correction coef. for zenith=40 !------------------------------------------------------- - data ((c40(ii,kk),ii=1,5),kk=1,30)/ & +! extended to 58 + data ((c40(ii,kk),ii=1,5),kk=1,58)/ & -.1895E+00_dp, 0.1173E+02_dp, -.4908E+01_dp, 0.7820E+00_dp, -.3439E-01_dp, & 0.1962E+02_dp, -.2455E+02_dp, 0.9490E+01_dp, -.1049E+01_dp, 0.3501E-01_dp, & -.3079E+01_dp, -.5048E+00_dp, 0.1277E+00_dp, -.1175E-01_dp, 0.3456E-03_dp, & @@ -870,12 +917,42 @@ MODULE module_wave_data 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp / + !------------------------------------------------------- ! correction coef. for zenith=60 !------------------------------------------------------- - data ((c60(ii,kk),ii=1,5),kk=1,30)/ & +! extended to 58 + data ((c60(ii,kk),ii=1,5),kk=1,58)/ & -.1638E+02_dp, 0.3958E+02_dp, -.1606E+02_dp, 0.2488E+01_dp, -.1077E+00_dp, & -.2315E+02_dp, 0.2426E+02_dp, -.2826E+01_dp, -.3649E-03_dp, 0.5939E-02_dp, & -.3974E+01_dp, 0.3165E+00_dp, -.7318E-01_dp, 0.5292E-02_dp, -.1394E-03_dp, & @@ -906,12 +983,41 @@ MODULE module_wave_data 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp / !------------------------------------------------------- ! correction coef. for zenith=80 !------------------------------------------------------- - data ((c80(ii,kk),ii=1,5),kk=1,30)/ & +! extended to 58 + data ((c80(ii,kk),ii=1,5),kk=1,58)/ & -.1932E+02_dp, 0.4848E+02_dp, -.1816E+02_dp, 0.2644E+01_dp, -.1113E+00_dp, & 0.1728E+02_dp, 0.8264E+01_dp, -.4332E+01_dp, 0.4240E+00_dp, -.1205E-01_dp, & -.3679E+01_dp, 0.3203E+00_dp, -.2073E+00_dp, 0.2292E-01_dp, -.8063E-03_dp, & @@ -942,6 +1048,34 @@ MODULE module_wave_data 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & + 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, & 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp, 0.0000E+00_dp / contains diff --git a/wrfv2_fire/chem/module_wetscav_driver.F b/wrfv2_fire/chem/module_wetscav_driver.F index aca9b7e2..1fe8027f 100644 --- a/wrfv2_fire/chem/module_wetscav_driver.F +++ b/wrfv2_fire/chem/module_wetscav_driver.F @@ -22,10 +22,13 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & t8w, dx, dy, p_phy, chem, & rho_phy, cldfra, cldfra2, rainprod, evapprod, & hno3_col_mdel, qlsink, precr, preci, precs, precg, & + wdflx, & gas_aqfrac, numgas_aqfrac, dz8w, & h2oaj,h2oai,nu3,ac3,cor3,asulf,ahno3,anh3,cvaro1, & cvaro2,cvalk1,cvole1,cvapi1,cvapi2,cvlim1,cvlim2, & - wd_no3,wd_so4, & + wd_no3,wd_so4,wd_nh4,wd_oa, & + wd_so2, wd_sulf, wd_hno3, wd_nh3, & + wd_cvasoa, wd_cvbsoa, wd_asoa, wd_bsoa, & qv_b4mp, qc_b4mp, qi_b4mp, qs_b4mp, & !====================================================================================== !Variables required for CAM_MAM_WETSCAV @@ -59,14 +62,19 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & USE module_model_constants USE modal_aero_data, only: ntot_amode ! For cam_mam_wetscav variables USE module_mozcart_wetscav, only: wetscav_mozcart - USE module_mosaic_wetscav, only: wetscav_cbmz_mosaic - USE modal_aero_data, only: ntot_amode ! For cam_mam_wetscav variables - USE module_mosaic_wetscav, only: wetscav_cbmz_mosaic - USE modal_aero_data, only: ntot_amode ! For cam_mam_wetscav variables - USE module_mosaic_wetscav, only: wetscav_cbmz_mosaic + USE module_mosaic_wetscav, only: wetscav_cbmz_mosaic, wetscav_mozart_mosaic USE module_aerosols_sorgam, only: wetscav_sorgam_driver + USE module_aerosols_sorgam_vbs, only: wetscav_sorgam_vbs_driver USE module_cam_mam_wetscav, only: wetscav_cam_mam_driver USE module_cam_support, only: pcnst =>pcnst_runtime + USE module_data_mosaic_asect, only: mw_so4_aer, mw_no3_aer, mw_nh4_aer, & + mw_smpa_aer, mw_smpbb_aer, mw_oc_aer, & + mw_glysoa_r1_aer, mw_glysoa_r2_aer, & + mw_glysoa_sfc_aer, mw_glysoa_nh4_aer, & + mw_glysoa_oh_aer,& + mw_asoaX_aer, mw_asoa1_aer, mw_asoa2_aer, mw_asoa3_aer, mw_asoa4_aer, & + mw_bsoaX_aer, mw_bsoa1_aer, mw_bsoa2_aer, mw_bsoa3_aer, mw_bsoa4_aer, & + mw_biog1_c_aer, mw_biog1_o_aer IMPLICIT NONE @@ -201,7 +209,12 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & ! ! Accumulated wet deposition ! - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: wd_no3,wd_so4 + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: wd_no3,wd_so4, & + wd_nh4, wd_oa, & + wd_so2, wd_sulf, & + wd_hno3, wd_nh3 + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: & + wd_cvasoa, wd_cvbsoa, wd_asoa, wd_bsoa ! ! input from meteorology(3D) REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & @@ -233,6 +246,10 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & qs_b4mp REAL, DIMENSION( ims:ime , jms:jme ) , & INTENT(INOUT ) :: hno3_col_mdel + + REAL, DIMENSION( ims:ime, jms:jme, num_chem ) , & + INTENT(INOUT) :: & + wdflx !wet deposition mol/m^2 or #/m^2 or ug/m^2 ! !input (4D) REAL, DIMENSION( ims:ime , kms:kme , jms:jme , ntot_amode ), & @@ -246,14 +263,16 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & ! LOCAL VAR integer :: ii,jj,kk - REAL, DIMENSION( ims:ime, jms:jme, num_chem ) :: qsrflx ! column change due to scavening + REAL, DIMENSION( ims:ime, jms:jme, num_chem ) :: qsrflx, delta_mass_col ! column change due to scavening REAL :: tmp_minval = 1.0e7 REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) :: rainrate, evaprate ! ! Wet deposition over the current time step ! - REAL, DIMENSION( ims:ime , jms:jme ) :: wdi_no3,wdi_so4 + REAL, DIMENSION( ims:ime , jms:jme ) :: wdi_no3,wdi_so4,wdi_nh4,wdi_oa, & + wdi_so2, wdi_sulf, wdi_hno3, wdi_nh3 + REAL, DIMENSION( ims:ime , jms:jme ) :: wdi_cvasoa,wdi_cvbsoa,wdi_asoa,wdi_bsoa !----------------------------------------------------------------- @@ -268,7 +287,8 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & ! cps_select: SELECT CASE(config_flags%chem_opt) - CASE ( RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, CBMZSORG_AQ ) + CASE ( RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, CBMZSORG_AQ, & + CB05_SORG_AQ_KPP) CALL wrf_debug(15,'wetscav_driver calling sorgam_wetscav_driver' ) call wetscav_sorgam_driver (id,ktau,dtstep,ktauc,config_flags, & dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & @@ -289,11 +309,32 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & enddo enddo + CASE (CB05_SORG_VBS_AQ_KPP ) + CALL wrf_debug(15,'wetscav_driver calling sorgam_wetscav_driver' ) + call wetscav_sorgam_vbs_driver (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg, qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! not clear if the following is necessary or appropriate + tmp_minval = 1.0e7 + do jj=jts,jte + do kk=kts,kte + do ii=its,ite + if (chem(ii,kk,jj,p_nu0) .lt. tmp_minval) then + chem(ii,kk,jj,p_nu0) = tmp_minval + endif + enddo + enddo + enddo + CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN) CALL wrf_error_fatal('Wet scavenging is currently not possible with MOSAIC unless aqueous aerosols are turned on.') CASE (CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP )!BSINGH(12/05/2013): Added for SAPRC 8 bin vbs ) CALL wrf_debug(15,'wetscav_driver calling mosaic_wetscav_driver') call wetscav_cbmz_mosaic (id,ktau,dtstep,ktauc,config_flags, & dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & @@ -302,7 +343,7 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (MOZART_KPP,MOZCART_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP) + CASE (MOZART_KPP,MOZCART_KPP,MOZART_MOSAIC_4BIN_KPP) CALL wrf_debug(15,'wetscav_driver calling wetscav_mozcart') if( config_flags%mp_physics == THOMPSON ) then rainrate(:,:,:) = rainprod(:,:,:) @@ -310,10 +351,52 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & elseif( config_flags%mp_physics == CAMMGMPSCHEME ) then rainrate(:,:,:) = prain3d(:,:,:) evaprate(:,:,:) = nevapr3d(:,:,:) + elseif( config_flags%mp_physics == MORR_TWO_MOMENT ) then + rainrate(:,:,:) = rainprod(:,:,:) + evaprate(:,:,:) = evapprod(:,:,:) + else + rainrate(:,:,:) = 0. + evaprate(:,:,:) = 0. + endif + call wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, & + dtstepc, t_phy, p8w, t8w, p_phy, & + chem, rho_phy, cldfra2, rainrate, evaprate, & + qv_b4mp, qc_b4mp, qi_b4mp, qs_b4mp, & + gas_aqfrac, numgas_aqfrac, dz8w, dx, dy, & + moist(ims,kms,jms,p_qv), moist(ims,kms,jms,p_qc), & + moist(ims,kms,jms,p_qi), moist(ims,kms,jms,p_qs), & +! hno3_col_mdel, & + delta_mass_col, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + hno3_col_mdel = delta_mass_col(:,:,p_hno3) + ! STUPID - cases have to be unique. We repeat both calls done above + ! (mosaic_wetscav for aerosols, mozcart for gases) + CASE (MOZART_MOSAIC_4BIN_AQ_KPP) + CALL wrf_debug(15,'wetscav_driver calling mosaic_wetscav_driver') + if( config_flags%mp_physics == THOMPSON ) then + rainrate(:,:,:) = rainprod(:,:,:) + evaprate(:,:,:) = evapprod(:,:,:) + elseif( config_flags%mp_physics == CAMMGMPSCHEME ) then + rainrate(:,:,:) = prain3d(:,:,:) + evaprate(:,:,:) = nevapr3d(:,:,:) + elseif( config_flags%mp_physics == MORR_TWO_MOMENT ) then + rainrate(:,:,:) = rainprod(:,:,:) + evaprate(:,:,:) = evapprod(:,:,:) else rainrate(:,:,:) = 0. evaprate(:,:,:) = 0. endif + call wetscav_mozart_mosaic (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg, qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + CALL wrf_debug(15,'wetscav_driver calling wetscav_mozcart') call wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, & dtstepc, t_phy, p8w, t8w, p_phy, & chem, rho_phy, cldfra2, rainrate, evaprate, & @@ -321,10 +404,12 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & gas_aqfrac, numgas_aqfrac, dz8w, dx, dy, & moist(ims,kms,jms,p_qv), moist(ims,kms,jms,p_qc), & moist(ims,kms,jms,p_qi), moist(ims,kms,jms,p_qs), & - hno3_col_mdel, & +! hno3_col_mdel, & + delta_mass_col, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + hno3_col_mdel = delta_mass_col(:,:,p_hno3) CASE (CBMZ_CAM_MAM3_NOAQ,CBMZ_CAM_MAM3_AQ,CBMZ_CAM_MAM7_NOAQ,CBMZ_CAM_MAM7_AQ) CALL wrf_debug(15,'wetscav_driver calling wetscav_cam_mam_driver') @@ -376,9 +461,207 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & enddo enddo + CASE ( MOZART_MOSAIC_4BIN_AQ_KPP) + + do jj=jts,jte + do ii=its,ite + + ! Nitrate wet deposition over the current time step: + wdi_no3(ii,jj) = - 0.001*qsrflx(ii,jj,p_no3_cw01)/mw_no3_aer & + - 0.001*qsrflx(ii,jj,p_no3_cw02)/mw_no3_aer & + - 0.001*qsrflx(ii,jj,p_no3_cw03)/mw_no3_aer & + - 0.001*qsrflx(ii,jj,p_no3_cw04)/mw_no3_aer ! mmol/m2 + + ! Accumulated nitrate wet deposition: + wd_no3(ii,jj) = wd_no3(ii,jj) + wdi_no3(ii,jj) ! mmol/m2 + + ! Sulfate wet deposition over the current time step: + wdi_so4(ii,jj) = - 0.001*qsrflx(ii,jj,p_so4_cw01)/mw_so4_aer & + - 0.001*qsrflx(ii,jj,p_so4_cw02)/mw_so4_aer & + - 0.001*qsrflx(ii,jj,p_so4_cw03)/mw_so4_aer & + - 0.001*qsrflx(ii,jj,p_so4_cw04)/mw_so4_aer ! mmol/m2 + + ! Accumulated sulfate wet deposition: + wd_so4(ii,jj) = wd_so4(ii,jj) + wdi_so4(ii,jj) ! mmol/m2 + + ! Ammoni* wet deposition over the current time step: + wdi_nh4(ii,jj) = - 0.001*qsrflx(ii,jj,p_nh4_cw01)/mw_nh4_aer & + - 0.001*qsrflx(ii,jj,p_nh4_cw02)/mw_nh4_aer & + - 0.001*qsrflx(ii,jj,p_nh4_cw03)/mw_nh4_aer & + - 0.001*qsrflx(ii,jj,p_nh4_cw04)/mw_nh4_aer ! mmol/m2 + + ! Accumulated ammoni* wet deposition: + wd_nh4(ii,jj) = wd_nh4(ii,jj) + wdi_nh4(ii,jj) ! mmol/m2 + + ! Total organics wet deposition over the current time step: + wdi_oa(ii,jj) = - 0.001*qsrflx(ii,jj,p_oc_cw01)/mw_oc_aer & + - 0.001*qsrflx(ii,jj,p_oc_cw02)/mw_oc_aer & + - 0.001*qsrflx(ii,jj,p_oc_cw03)/mw_oc_aer & + - 0.001*qsrflx(ii,jj,p_oc_cw04)/mw_oc_aer & + - 0.001*qsrflx(ii,jj,p_asoaX_cw01)/mw_asoaX_aer & + - 0.001*qsrflx(ii,jj,p_asoaX_cw02)/mw_asoaX_aer & + - 0.001*qsrflx(ii,jj,p_asoaX_cw03)/mw_asoaX_aer & + - 0.001*qsrflx(ii,jj,p_asoaX_cw04)/mw_asoaX_aer & + - 0.001*qsrflx(ii,jj,p_asoa1_cw01)/mw_asoa1_aer & + - 0.001*qsrflx(ii,jj,p_asoa1_cw02)/mw_asoa1_aer & + - 0.001*qsrflx(ii,jj,p_asoa1_cw03)/mw_asoa1_aer & + - 0.001*qsrflx(ii,jj,p_asoa1_cw04)/mw_asoa1_aer & + - 0.001*qsrflx(ii,jj,p_asoa2_cw01)/mw_asoa2_aer & + - 0.001*qsrflx(ii,jj,p_asoa2_cw02)/mw_asoa2_aer & + - 0.001*qsrflx(ii,jj,p_asoa2_cw03)/mw_asoa2_aer & + - 0.001*qsrflx(ii,jj,p_asoa2_cw04)/mw_asoa2_aer & + - 0.001*qsrflx(ii,jj,p_asoa3_cw01)/mw_asoa3_aer & + - 0.001*qsrflx(ii,jj,p_asoa3_cw02)/mw_asoa3_aer & + - 0.001*qsrflx(ii,jj,p_asoa3_cw03)/mw_asoa3_aer & + - 0.001*qsrflx(ii,jj,p_asoa3_cw04)/mw_asoa3_aer & + - 0.001*qsrflx(ii,jj,p_asoa4_cw01)/mw_asoa4_aer & + - 0.001*qsrflx(ii,jj,p_asoa4_cw02)/mw_asoa4_aer & + - 0.001*qsrflx(ii,jj,p_asoa4_cw03)/mw_asoa4_aer & + - 0.001*qsrflx(ii,jj,p_asoa4_cw04)/mw_asoa4_aer & + - 0.001*qsrflx(ii,jj,p_bsoaX_cw01)/mw_bsoaX_aer & + - 0.001*qsrflx(ii,jj,p_bsoaX_cw02)/mw_bsoaX_aer & + - 0.001*qsrflx(ii,jj,p_bsoaX_cw03)/mw_bsoaX_aer & + - 0.001*qsrflx(ii,jj,p_bsoaX_cw04)/mw_bsoaX_aer & + - 0.001*qsrflx(ii,jj,p_bsoa1_cw01)/mw_bsoa1_aer & + - 0.001*qsrflx(ii,jj,p_bsoa1_cw02)/mw_bsoa1_aer & + - 0.001*qsrflx(ii,jj,p_bsoa1_cw03)/mw_bsoa1_aer & + - 0.001*qsrflx(ii,jj,p_bsoa1_cw04)/mw_bsoa1_aer & + - 0.001*qsrflx(ii,jj,p_bsoa2_cw01)/mw_bsoa2_aer & + - 0.001*qsrflx(ii,jj,p_bsoa2_cw02)/mw_bsoa2_aer & + - 0.001*qsrflx(ii,jj,p_bsoa2_cw03)/mw_bsoa2_aer & + - 0.001*qsrflx(ii,jj,p_bsoa2_cw04)/mw_bsoa2_aer & + - 0.001*qsrflx(ii,jj,p_bsoa3_cw01)/mw_bsoa3_aer & + - 0.001*qsrflx(ii,jj,p_bsoa3_cw02)/mw_bsoa3_aer & + - 0.001*qsrflx(ii,jj,p_bsoa3_cw03)/mw_bsoa3_aer & + - 0.001*qsrflx(ii,jj,p_bsoa3_cw04)/mw_bsoa3_aer & + - 0.001*qsrflx(ii,jj,p_bsoa4_cw01)/mw_bsoa4_aer & + - 0.001*qsrflx(ii,jj,p_bsoa4_cw02)/mw_bsoa4_aer & + - 0.001*qsrflx(ii,jj,p_bsoa4_cw03)/mw_bsoa4_aer & + - 0.001*qsrflx(ii,jj,p_bsoa4_cw04)/mw_bsoa4_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_r1_cw01)/mw_glysoa_r1_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_r1_cw02)/mw_glysoa_r1_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_r1_cw03)/mw_glysoa_r1_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_r1_cw04)/mw_glysoa_r1_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_r2_cw01)/mw_glysoa_r2_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_r2_cw02)/mw_glysoa_r2_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_r2_cw03)/mw_glysoa_r2_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_r2_cw04)/mw_glysoa_r2_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_sfc_cw01)/mw_glysoa_sfc_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_sfc_cw02)/mw_glysoa_sfc_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_sfc_cw03)/mw_glysoa_sfc_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_sfc_cw04)/mw_glysoa_sfc_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_nh4_cw01)/mw_glysoa_nh4_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_nh4_cw02)/mw_glysoa_nh4_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_nh4_cw03)/mw_glysoa_nh4_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_nh4_cw04)/mw_glysoa_nh4_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_oh_cw01)/mw_glysoa_oh_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_oh_cw02)/mw_glysoa_oh_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_oh_cw03)/mw_glysoa_oh_aer & + - 0.001*qsrflx(ii,jj,p_glysoa_oh_cw04)/mw_glysoa_oh_aer ! mmol/m2 + + ! Accumulated total organics wet deposition: + wd_oa(ii,jj) = wd_oa(ii,jj) + wdi_oa(ii,jj) ! mmol/m2 + + wdi_asoa(ii,jj)= - 0.001*qsrflx(ii,jj,p_asoaX_cw01)/mw_asoaX_aer & + - 0.001*qsrflx(ii,jj,p_asoaX_cw02)/mw_asoaX_aer & + - 0.001*qsrflx(ii,jj,p_asoaX_cw03)/mw_asoaX_aer & + - 0.001*qsrflx(ii,jj,p_asoaX_cw04)/mw_asoaX_aer & + - 0.001*qsrflx(ii,jj,p_asoa1_cw01)/mw_asoa1_aer & + - 0.001*qsrflx(ii,jj,p_asoa1_cw02)/mw_asoa1_aer & + - 0.001*qsrflx(ii,jj,p_asoa1_cw03)/mw_asoa1_aer & + - 0.001*qsrflx(ii,jj,p_asoa1_cw04)/mw_asoa1_aer & + - 0.001*qsrflx(ii,jj,p_asoa2_cw01)/mw_asoa2_aer & + - 0.001*qsrflx(ii,jj,p_asoa2_cw02)/mw_asoa2_aer & + - 0.001*qsrflx(ii,jj,p_asoa2_cw03)/mw_asoa2_aer & + - 0.001*qsrflx(ii,jj,p_asoa2_cw04)/mw_asoa2_aer & + - 0.001*qsrflx(ii,jj,p_asoa3_cw01)/mw_asoa3_aer & + - 0.001*qsrflx(ii,jj,p_asoa3_cw02)/mw_asoa3_aer & + - 0.001*qsrflx(ii,jj,p_asoa3_cw03)/mw_asoa3_aer & + - 0.001*qsrflx(ii,jj,p_asoa3_cw04)/mw_asoa3_aer & + - 0.001*qsrflx(ii,jj,p_asoa4_cw01)/mw_asoa4_aer & + - 0.001*qsrflx(ii,jj,p_asoa4_cw02)/mw_asoa4_aer & + - 0.001*qsrflx(ii,jj,p_asoa4_cw03)/mw_asoa4_aer & + - 0.001*qsrflx(ii,jj,p_asoa4_cw04)/mw_asoa4_aer ! mmol/m2 + + ! Accumulated total organics wet deposition: + wd_asoa(ii,jj) = wd_asoa(ii,jj) + wdi_asoa(ii,jj) ! mmol/m2 + + wdi_bsoa(ii,jj)= - 0.001*qsrflx(ii,jj,p_bsoaX_cw01)/mw_bsoaX_aer & + - 0.001*qsrflx(ii,jj,p_bsoaX_cw02)/mw_bsoaX_aer & + - 0.001*qsrflx(ii,jj,p_bsoaX_cw03)/mw_bsoaX_aer & + - 0.001*qsrflx(ii,jj,p_bsoaX_cw04)/mw_bsoaX_aer & + - 0.001*qsrflx(ii,jj,p_bsoa1_cw01)/mw_bsoa1_aer & + - 0.001*qsrflx(ii,jj,p_bsoa1_cw02)/mw_bsoa1_aer & + - 0.001*qsrflx(ii,jj,p_bsoa1_cw03)/mw_bsoa1_aer & + - 0.001*qsrflx(ii,jj,p_bsoa1_cw04)/mw_bsoa1_aer & + - 0.001*qsrflx(ii,jj,p_bsoa2_cw01)/mw_bsoa2_aer & + - 0.001*qsrflx(ii,jj,p_bsoa2_cw02)/mw_bsoa2_aer & + - 0.001*qsrflx(ii,jj,p_bsoa2_cw03)/mw_bsoa2_aer & + - 0.001*qsrflx(ii,jj,p_bsoa2_cw04)/mw_bsoa2_aer & + - 0.001*qsrflx(ii,jj,p_bsoa3_cw01)/mw_bsoa3_aer & + - 0.001*qsrflx(ii,jj,p_bsoa3_cw02)/mw_bsoa3_aer & + - 0.001*qsrflx(ii,jj,p_bsoa3_cw03)/mw_bsoa3_aer & + - 0.001*qsrflx(ii,jj,p_bsoa3_cw04)/mw_bsoa3_aer & + - 0.001*qsrflx(ii,jj,p_bsoa4_cw01)/mw_bsoa4_aer & + - 0.001*qsrflx(ii,jj,p_bsoa4_cw02)/mw_bsoa4_aer & + - 0.001*qsrflx(ii,jj,p_bsoa4_cw03)/mw_bsoa4_aer & + - 0.001*qsrflx(ii,jj,p_bsoa4_cw04)/mw_bsoa4_aer ! mmol/m2 + + ! Accumulated total organics wet deposition: + wd_bsoa(ii,jj) = wd_bsoa(ii,jj) + wdi_bsoa(ii,jj) ! mmol/m2 + + wdi_cvasoa(ii,jj) = - delta_mass_col(ii,jj,p_cvasoaX) & + - delta_mass_col(ii,jj,p_cvasoa1) & + - delta_mass_col(ii,jj,p_cvasoa2) & + - delta_mass_col(ii,jj,p_cvasoa3) & + - delta_mass_col(ii,jj,p_cvasoa4) ! kg + + wdi_cvasoa(ii,jj) = wdi_cvasoa(ii,jj) / (dx * dy) / (150.0 * 1e-3) * 1e3 ! mmol/m2 + + ! Accumulated CVASOA wet deposition: + wd_cvasoa(ii,jj) = wd_cvasoa(ii,jj) + wdi_cvasoa(ii,jj) ! mmol/m2 + + wdi_cvbsoa(ii,jj) = - delta_mass_col(ii,jj,p_cvbsoaX) & + - delta_mass_col(ii,jj,p_cvbsoa1) & + - delta_mass_col(ii,jj,p_cvbsoa2) & + - delta_mass_col(ii,jj,p_cvbsoa3) & + - delta_mass_col(ii,jj,p_cvbsoa4) ! kg + + wdi_cvbsoa(ii,jj) = wdi_cvbsoa(ii,jj) / (dx * dy) / (180.0 * 1e-3) * 1e3 ! mmol/m2 + + ! Accumulated CVbsoa wet deposition: + wd_cvbsoa(ii,jj) = wd_cvbsoa(ii,jj) + wdi_cvbsoa(ii,jj) ! mmol/m2 + + ! add inorganic gas washout + + wdi_hno3(ii,jj) = - delta_mass_col(ii,jj,p_hno3) / (63.0123405 * 1e-3) ! kg + wdi_hno3(ii,jj) = wdi_hno3(ii,jj) / (dx * dy) * 1e3 ! mmol/m2 + wd_hno3(ii,jj) = wd_hno3(ii,jj) + wdi_hno3(ii,jj) ! mmol/m2 + + wdi_so2(ii,jj) = - delta_mass_col(ii,jj,p_so2) / (63.961901 * 1e-3) ! kg + wdi_so2(ii,jj) = wdi_so2(ii,jj) / (dx * dy) * 1e3 ! mmol/m2 + wd_so2(ii,jj) = wd_so2(ii,jj) + wdi_so2(ii,jj) ! mmol/m2 + + wdi_sulf(ii,jj) = - delta_mass_col(ii,jj,p_sulf) / (98.078 * 1e-3) ! kg + wdi_sulf(ii,jj) = wdi_sulf(ii,jj) / (dx * dy) * 1e3 ! mmol/m2 + wd_sulf(ii,jj) = wd_sulf(ii,jj) + wdi_sulf(ii,jj) ! mmol/m2 + + wdi_nh3(ii,jj) = - delta_mass_col(ii,jj,p_nh3) / (17.0289402 * 1e-3) ! kg + wdi_nh3(ii,jj) = wdi_nh3(ii,jj) / (dx * dy) * 1e3 ! mmol/m2 + wd_nh3(ii,jj) = wd_nh3(ii,jj) + wdi_nh3(ii,jj) ! mmol/m2 + + enddo + enddo + + CASE DEFAULT END SELECT + + if( config_flags%diagnostic_dep == 1 ) then + wdflx(its:ite,jts:jte,:)=wdflx(its:ite,jts:jte,:)-qsrflx(its:ite,jts:jte,:) + end if + end subroutine wetscav_driver diff --git a/wrfv2_fire/chem/optical_driver.F b/wrfv2_fire/chem/optical_driver.F index 670b3f70..528fd8cf 100755 --- a/wrfv2_fire/chem/optical_driver.F +++ b/wrfv2_fire/chem/optical_driver.F @@ -23,6 +23,7 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& bscoef1,bscoef2,bscoef3,bscoef4, & l2aer,l3aer,l4aer,l5aer,l6aer,l7aer, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & extaerlw1,extaerlw2,extaerlw3,extaerlw4,extaerlw5,extaerlw6, & extaerlw7,extaerlw8,extaerlw9,extaerlw10,extaerlw11,extaerlw12, & extaerlw13,extaerlw14,extaerlw15,extaerlw16, & @@ -57,7 +58,8 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(IN ) :: relhum, dz8w, alt, h2oai, h2oaj, & - totoa_a01, totoa_a02, totoa_a03, totoa_a04 + totoa_a01, totoa_a02, totoa_a03, totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08 ! ! arrays that hold the aerosol optical properties ! @@ -112,15 +114,18 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& case ( RADM2SORG, RADM2SORG_KPP, RADM2SORG_AQ, RADM2SORG_AQCHEM, & GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & RACM_ESRLSORG_AQCHEM_KPP, RACM_SOA_VBS_KPP, & - GOCARTRACM_KPP, GOCARTRADM2_KPP, GOCARTRADM2, & + GOCARTRACM_KPP, GOCARTRADM2, & RACM_ESRLSORG_KPP, MOZCART_KPP, & CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_KPP, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZSORG, CBMZSORG_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP,MOZART_MOSAIC_4BIN_VBS0_KPP , & + SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + MOZART_MOSAIC_4BIN_KPP , MOZART_MOSAIC_4BIN_AQ_KPP, & CBMZ_CAM_MAM3_NOAQ,CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM3_AQ, & - CBMZ_CAM_MAM7_AQ, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) + CBMZ_CAM_MAM7_AQ, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, SAPRC99_MOSAIC_8BIN_VBS2_KPP, & + CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP ) processingAerosols = .true. call wrf_debug(15,'optical driver: process aerosols true') case default @@ -137,18 +142,21 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& ! select case (config_flags%chem_opt) case ( RADM2SORG, RACM_ESRLSORG_KPP, RADM2SORG_KPP, RADM2SORG_AQ, RADM2SORG_AQCHEM, & - GOCARTRACM_KPP, GOCARTRADM2_KPP, GOCARTRADM2, & + GOCARTRACM_KPP, GOCARTRADM2, & GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & RACM_ESRLSORG_AQCHEM_KPP, RACM_SOA_VBS_KPP, & CBMZSORG, CBMZSORG_AQ, MOZCART_KPP, & - CBMZ_CAM_MAM3_NOAQ, CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM3_AQ, CBMZ_CAM_MAM7_AQ) + CBMZ_CAM_MAM3_NOAQ, CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM3_AQ, CBMZ_CAM_MAM7_AQ, & + CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP ) nbin_o = 8 case (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_KPP, & CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, & CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CBMZ_MOSAIC_4BIN_VBS2_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & - MOZART_MOSAIC_4BIN_VBS0_KPP, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) + SAPRC99_MOSAIC_4BIN_VBS2_KPP, & + MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP, & + CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, SAPRC99_MOSAIC_8BIN_VBS2_KPP )!BSINGH(12/05/2013): Added for SAPRC 8 bin vbs and added non-aq on 04/03/2014 nbin_o = nbin_a end select ! @@ -210,6 +218,7 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& tauaersw,extaersw,gaersw,waersw,bscoefsw, & l2aer,l3aer,l4aer,l5aer,l6aer,l7aer, & totoa_a01,totoa_a02,totoa_a03,totoa_a04, & + totoa_a05,totoa_a06,totoa_a07,totoa_a08, & tauaerlw,extaerlw, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & diff --git a/wrfv2_fire/chem/photolysis_driver.F b/wrfv2_fire/chem/photolysis_driver.F index f44884f6..925ae8f1 100755 --- a/wrfv2_fire/chem/photolysis_driver.F +++ b/wrfv2_fire/chem/photolysis_driver.F @@ -15,6 +15,7 @@ SUBROUTINE photolysis_driver (id,curr_secs,ktau,dtstep, & ph_rooh,ph_xooh,ph_isopooh,ph_alkooh, & ph_mekooh,ph_tolooh,ph_terpooh,ph_mvk, & ph_glyald,ph_hyac, & + ph_cl2,ph_hocl,ph_fmcl, & nref0, nw0, tuv_jmax0, & ph_radfld, ph_adjcoe, ph_prate, & wc, zref, & @@ -67,7 +68,8 @@ SUBROUTINE photolysis_driver (id,curr_secs,ktau,dtstep, & ph_n2o5,ph_o2,ph_n2o,ph_pan,ph_mpan,ph_acetol,ph_gly, & ph_bigald,ph_mek,ph_c2h5ooh,ph_c3h7ooh,ph_pooh,ph_rooh, & ph_xooh,ph_isopooh,ph_alkooh,ph_mekooh,ph_tolooh, & - ph_terpooh,ph_mvk,ph_glyald,ph_hyac + ph_terpooh,ph_mvk,ph_glyald,ph_hyac, & + ph_cl2,ph_hocl,ph_fmcl INTEGER, INTENT(IN ) :: nref0, nw0, tuv_jmax0 real, dimension( ims:ime, nref0, jms:jme, nw0 ), & @@ -187,6 +189,7 @@ SUBROUTINE photolysis_driver (id,curr_secs,ktau,dtstep, & ph_pooh,ph_rooh,ph_xooh,ph_isopooh, & ph_alkooh,ph_mekooh,ph_tolooh,ph_terpooh,& ph_n2o5,ph_mvk,ph_glyald,ph_hyac, & + ph_cl2,ph_hocl,ph_fmcl, & ivgtyp, & ph_radfld, ph_adjcoe, ph_prate, & wc,zref, & diff --git a/wrfv2_fire/compile b/wrfv2_fire/compile index 396f60ff..83bee14e 100755 --- a/wrfv2_fire/compile +++ b/wrfv2_fire/compile @@ -5,13 +5,11 @@ setenv START_OF_COMPILE "`date`" cont1: if ( ! -e configure.wrf ) then - if ( $1 == "all_wrfvar" ) then - ./configure wrfda - set dontask - else - ./configure $1 - set dontask - endif + echo "" + echo "You must run the 'configure' script before running the 'compile' script!" + echo "Exiting..." + echo "" + exit 1 endif @@ -63,6 +61,16 @@ foreach a ( $argv ) if ( ! $?WRF_NMM_CORE ) setenv WRF_NMM_CORE 1 endif endif + set ZAP = .foofoo + if ( ( "$a" == "nmm_real" ) || ( "$a" == "nmm_nest" ) || ( "$a" == "nmm_hwrf" ) ) then + set ZAP = ( main/wrf.exe main/real_nmm.exe ) + else if ( `echo $a | cut -c 1-4` == "nmm_" ) then + set ZAP = ( main/wrf.exe main/ideal_nmm.exe ) + else if ( "$a" == "em_real" ) then + set ZAP = ( main/wrf.exe main/real.exe main/ndown.exe main/tc.exe ) + else if ( `echo $a | cut -c 1-3` == "em_" ) then + set ZAP = ( main/wrf.exe main/ideal.exe ) + endif if ( "$a" == "-j" ) then shift argv setenv J "-j $argv[1]" @@ -70,6 +78,12 @@ foreach a ( $argv ) endif end +if ( $?WRF_NMM_CORE ) then + if ( $WRF_NMM_CORE == 1 ) then + setenv WRF_NMM_NEST 1 + endif +endif + if ( "$arglist" == "" ) then goto hlp else @@ -287,13 +301,27 @@ else setenv BUFR 1 endif setenv RTTOV_CPP "-DRTTOV" - setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov11.1.0_coef_io -lrttov11.1.0_emis_atlas -lrttov11.1.0_main" + if ( -e ${RTTOV}/lib/librttov11.1.0_main.a ) then + setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov11.1.0_coef_io -lrttov11.1.0_emis_atlas -lrttov11.1.0_main" + else if ( -e ${RTTOV}/lib/librttov11.2.0_main.a ) then + setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov11.2.0_coef_io -lrttov11.2.0_emis_atlas -lrttov11.2.0_main" + else + echo "Can not find a compatible RTTOV library! Please ensure that your RTTOV build was successful," + echo "your 'RTTOV' environment variable is set correctly, and you are using a supported version of RTTOV." + echo "Currently supported versions are 11.1 and 11.2" + exit 1 + endif setenv RTTOV_SRC "-I${RTTOV}/include -I${RTTOV}/mod" else setenv RTTOV_CPP " " setenv RTTOV_LIB " " setenv RTTOV_SRC " " endif + if ( $?CLOUD_CV ) then + setenv CLOUD_CV_CPP "-DCLOUD_CV" + else + setenv CLOUD_CV_CPP " " + endif if ( $?BUFR ) then setenv BUFR_CPP "-DBUFR" setenv BUFR_LIB "-L../external/bufr -lbufr" @@ -330,21 +358,9 @@ else endif endif if ( $overwrite ) then - if (($WRF_NMM_CORE == 1)&&($WRF_NMM_NEST == 1)) then - if ($HWRF == 1) then - echo copying Registry/Registry.NMM_HWRF to Registry/Registry - echo '## WARNING: this file is autogenerated from Registry/Registry.NMM_HWRF. Changes may be lost' > Registry/Registry - /bin/cat Registry/Registry.NMM_HWRF >> Registry/Registry - else - echo copying Registry/Registry.NMM_NEST to Registry/Registry - echo '## WARNING: this file is autogenerated from Registry/Registry.NMM_NEST. Changes may be lost' > Registry/Registry - /bin/cat Registry/Registry.NMM_NEST >> Registry/Registry - endif - else - echo copying Registry/Registry.NMM to Registry/Registry - echo '## WARNING: this file is autogenerated from Registry/Registry.NMM. Changes may be lost' > Registry/Registry - /bin/cat Registry/Registry.NMM >> Registry/Registry - endif + echo copying Registry/Registry.NMM to Registry/Registry + echo '## WARNING: this file is autogenerated from Registry/Registry.NMM. Changes may be lost' > Registry/Registry + /bin/cat Registry/Registry.NMM >> Registry/Registry endif # integrity check for a kludge where a hard coded value in the # registry must match the same value in arch/preamble_new @@ -426,6 +442,7 @@ else echo not setting parallel make endif + /bin/rm -f $ZAP >& /dev/null make $arglist A2DCASE="$A2DCASE" WRF_SRC_ROOT_DIR="$WRF_SRC_ROOT_DIR" endif @@ -437,16 +454,15 @@ hlp: echo ' ' echo 'Usage:' echo ' ' -echo ' compile [-d] [-j n] wrf compile wrf in run dir (NOTE: no real.exe, ndown.exe, or ideal.exe generated)' +echo ' compile [-j n] wrf compile wrf in run dir (NOTE: no real.exe, ndown.exe, or ideal.exe generated)' echo ' ' echo ' or choose a test case (see README_test_cases for details) :' foreach d ( `/bin/ls test` ) if ( "$d" != "CVS" ) then - echo " compile $d" + echo " compile [-j n] $d" endif end echo ' ' -echo ' compile -d compile without optimization and with debugging' echo ' compile -j n parallel make using n tasks if supported (default 2)' echo ' compile -h help message' diff --git a/wrfv2_fire/configure b/wrfv2_fire/configure index 369a0496..6411ed24 100755 --- a/wrfv2_fire/configure +++ b/wrfv2_fire/configure @@ -6,6 +6,7 @@ thiscmd=$0 FORTRAN_COMPILER_TIMER="" opt_level="-f" +rword="-r4" print_usage="" chemistry="" wrf_core="" @@ -19,6 +20,7 @@ while [ $# -ge 1 ]; do -help) print_usage="yes" ;; -os) shift ; WRF_OS=$1 ;; -mach) shift ; WRF_MACH=$1 ;; + -r8) rword="-r8" ;; -time) shift ; FORTRAN_COMPILER_TIMER=$1 ;; chem) WRF_CHEM=1 ;; kpp) WRF_KPP=1 ;; @@ -36,7 +38,15 @@ while [ $# -ge 1 ]; do shift done if [ -n "$print_usage" ] ; then + echo ' ' + echo '*****************************************************************************' echo usage: $thiscmd '[-d|-D|-s|-f|-os os|-mach mach|-time timecommand] [chem] [kpp]' + echo '-d build with debugging information and no optimization' + echo '-D build with -d AND floating traps, traceback, uninitialized variables' + echo '-r8 build with 8 byte reals' + echo '-help print this message' + echo '*****************************************************************************' + echo ' ' exit fi @@ -328,7 +338,7 @@ if [ -n "$NETCDF4" ] ; then NETCDF=`echo $NETCDF | sed 's/\/$//'` fi buff="`ls -l $NETCDF | sed 's/ */ /g'`" - while [ "`echo $buff | grep '\->'`" != "" ] + while [ "`echo $buff | grep lib`" = "" -a "`echo $buff | grep '\->'`" != "" ] do buff="`echo $buff | sed -e 's/->//' -e 's/ */ /g'`" n=`echo $buff | wc -w` @@ -491,8 +501,13 @@ if [ -n "$WRF_LOG_BUFFERING" ]; then compileflags="${compileflags}!-DWRF_LOG_BUFFERING=1" fi fi +if [ -n "$PNETCDF_QUILT" ]; then + echo Enabling quilt_pnc I/O server implementation. + compileflags="${compileflags}!-DPNETCDF_QUILT=1" +fi if [ -n "$WRF_NMM_CORE" ]; then if [ $WRF_NMM_CORE = 1 ]; then + export WRF_NMM_NEST=1 if [ -n "$HWRF" ]; then if [ $HWRF = 1 ]; then echo building WRF with HWRF option @@ -544,8 +559,24 @@ if [ -n "$WRF_NMM_CORE" -a -n "$WRF_CHEM" ]; then fi fi -if [ `which timex` ] ; then +type m4 > /dev/null +if [ $? -ne 0 ] ; then + echo + echo "ERROR ERROR ERROR ERROR ERROR ERROR ERROR" + echo "'m4' utility not found! Can not configure." + echo + echo "If on an Ubuntu machine, use the command" + echo " sudo apt-get install m4 " + echo "To download and install the 'm4' utility" + exit 1 +fi + +if command -v timex > /dev/null 2>&1; then FORTRAN_COMPILER_TIMER=timex + echo "Will use 'timex' to report timing information" +elif command -v time > /dev/null 2>&1; then + FORTRAN_COMPILER_TIMER=time + echo "Will use 'time' to report timing information" fi # Found perl, so proceed with configuration @@ -557,6 +588,7 @@ if test -n "$PERL" ; then -compileflags=$compileflags -opt_level=$opt_level -USENETCDFF=$USENETCDFF -time=$FORTRAN_COMPILER_TIMER \ -wrf_core=$wrf_core -gpfs=$GPFS_PATH -curl=$CURL_PATH -dep_lib_path="$DEP_LIB_PATH" if test ! -f configure.wrf ; then + echo "configure.wrf not created! Exiting configure script..." exit 1 fi if [ "$opt_level" = "-d" ] ; then @@ -567,6 +599,17 @@ if test -n "$PERL" ; then sed -e 's/FCOPTIM[ ]*=/& # /' -e '/FCDEBUG[ ]*=/s/#//g' configure.wrf > configure.wrf.edit /bin/mv configure.wrf.edit configure.wrf fi + + # GNU has a funny way of doing promotion to real*8 + if [ "$rword" = "-r8" ] ; then + srch=`grep -i "^SFC" configure.wrf | grep -i "gfortran"` + if [ -n "$srch" ] ; then + sed -e '/^PROMOTION/s/#//' configure.wrf > configure.wrf.edit + else + sed -e '/^RWORDSIZE/s/$(NATIVE_RWORDSIZE)/8/' configure.wrf > configure.wrf.edit + fi + /bin/mv configure.wrf.edit configure.wrf + fi else WRF_OS=$os ; export WRF_OS WRF_MACH=$mach ; export WRF_MACH @@ -938,6 +981,48 @@ if [ $retval -ne 0 ] ; then echo "*****************************************************************************" fi +# testing for Fortran 2003 FLUSH features +make fortran_2003_flush_test > tools/fortran_2003_flush_test.log 2>&1 +rm -f tools/fortran_2003_flush_test.log +retval=-1 +if [ -f tools/fortran_2003_flush_test.exe ] ; then + retval=0 +fi +if [ $retval -ne 0 ] ; then + make fortran_2003_fflush_test > tools/fortran_2003_fflush_test.log 2>&1 + rm -f tools/fortran_2003_fflush_test.log + retval=-1 + if [ -f tools/fortran_2003_fflush_test.exe ] ; then + retval=0 + fi + if [ $retval -eq 0 ] ; then + sed -e '/^ARCH_LOCAL/s/$/ -DUSE_FFLUSH/' configure.wrf > configure.wrf.edit + mv configure.wrf.edit configure.wrf + echo " " + echo " " + echo "************************** W A R N I N G ************************************" + echo " " + echo "There are some Fortran 2003 features in WRF that your compiler does not recognize" + echo "The standard FLUSH routine has been replaced by FFLUSH." + echo "That may not be enough." + echo " " + echo "*****************************************************************************" + fi + if [ $retval -ne 0 ] ; then + sed -e '/^ARCH_LOCAL/s/$/ -DNO_FLUSH_SUPPORT/' configure.wrf > configure.wrf.edit + mv configure.wrf.edit configure.wrf + echo " " + echo " " + echo "************************** W A R N I N G ************************************" + echo " " + echo "There are some Fortran 2003 features in WRF that your compiler does not recognize" + echo "The standard FLUSH routine has been stubbed out." + echo "That may not be enough." + echo " " + echo "*****************************************************************************" + fi +fi + # testing for netcdf4 IO features if [ -n "$NETCDF4" ] ; then if [ $NETCDF4 -eq 1 ] ; then diff --git a/wrfv2_fire/configure.nc4 b/wrfv2_fire/configure.nc4 deleted file mode 100755 index bf874bfd..00000000 --- a/wrfv2_fire/configure.nc4 +++ /dev/null @@ -1,932 +0,0 @@ -#!/bin/sh - -# parse argument list - -thiscmd=$0 - -FORTRAN_COMPILER_TIMER="" -opt_level="-f" -print_usage="" -chemistry="" -wrf_core="" -while [ $# -ge 1 ]; do - case $1 in - -d) opt_level="-d" ;; - -D) opt_level="-D" ;; - -s) opt_level="-s" ;; - -f) opt_level="-f" ;; - -h) print_usage="yes" ;; - -help) print_usage="yes" ;; - -os) shift ; WRF_OS=$1 ;; - -mach) shift ; WRF_MACH=$1 ;; - -time) shift ; FORTRAN_COMPILER_TIMER=$1 ;; - chem) WRF_CHEM=1 ;; - kpp) WRF_KPP=1 ;; - radardfi) WRF_DFI_RADAR=1 ;; - wrfda) wrf_core=DA_CORE ;; - 4dvar) wrf_core=4D_DA_CORE ;; - arw) wrf_core=EM_CORE ;; - nmm) wrf_core=NMM_CORE ;; - coamps) wrf_core=COAMPS_CORE ;; - exp) wrf_core=EXP_CORE ;; - titan) WRF_TITAN=1 ; break ;; - mars) WRF_MARS=1 ; break ;; - venus) WRF_VENUS=1 ; break ;; - esac - shift -done -if [ -n "$print_usage" ] ; then - echo usage: $thiscmd '[-d|-D|-s|-f|-os os|-mach mach|-time timecommand] [chem] [kpp]' - exit -fi - -if `pwd | grep ' ' > /dev/null ` ; then - echo '************************** W A R N I N G ************************************' - echo The current working directory has spaces in some components of its path name - echo and this may cause problems for your build. This can occur, for example, on - echo Windows systems. It is strongly recommended that you install WRF and other - echo related software such as NetCDF in directories whose path names contain no - echo white space. On Win, for example, create and install in a directory under C:. - echo '*****************************************************************************' -fi - - -# lifted from the configure file for mpich; 00/03/10 jm -# -# Check for perl and perl version -for p in perl5 perl -do - # Extract the first word of "$p", so it can be a program name with args. - set dummy $p; ac_word=$2 - if test -z "$ac_echo_n" ; then - ac_echo_n=yes - if (echo "testing\c"; echo 1,2,3) | grep c >/dev/null; then - # Stardent Vistra SVR4 grep lacks -e, says ghazi@caip.rutgers.edu. - if (echo -n testing; echo 1,2,3) | sed s/-n/xn/ | grep xn >/dev/null; then - ac_n= ac_c=' -' ac_t=' ' - else - ac_n=-n ac_c= ac_t= - fi - else - ac_n= ac_c='\c' ac_t= - fi - ac_echo_test=`echo foo 1>&1` - if test -z "$ac_echo_test" ; then - print_error "Your sh shell does not handle the output redirection" - print_error "1>&1 correctly. Configure will work around this problem," - print_error "but you should report the problem to your vendor." - fi - fi - if test -z "$ac_echo_test" -a 1 = 1 ; then - echo $ac_n "checking for $ac_word""... $ac_c" - else - echo $ac_n "checking for $ac_word""... $ac_c" 1>&1 - fi - ac_prog_where="" - if test -n "$PERL"; then - ac_pg_PERL="$PERL" # Let the user override the test. - else - ac_first_char=`expr "$p" : "\(.\)"` - if test "$ac_first_char" = "/" -a -x "$p" ; then - ac_pg_PERL="$p" - ac_prog_where=$p - else - IFS="${IFS= }"; ac_save_ifs="$IFS"; IFS="${IFS}:" - for ac_dir in $PATH; do - test -z "$ac_dir" && ac_dir=. - if test -f $ac_dir/$ac_word; then - ac_pg_PERL="$p" - ac_prog_where=$ac_dir/$ac_word - break - fi - done - IFS="$ac_save_ifs" - fi - fi;PERL="$ac_pg_PERL" - if test -n "$ac_prog_where" ; then - if test -z "$ac_echo_test" -a 1 = 1 ; then - echo "$ac_t""found $ac_prog_where ($PERL)" - else - echo "$ac_t""found $ac_prog_where ($PERL)" 1>&1 - fi - PERLFULLPATH=$ac_prog_where - else - if test -z "$ac_echo_test" -a 1 = 1 ; then - echo "$ac_t""no" - else - echo "$ac_t""no" 1>&1 - fi - fi - test -n "$PERL" && break -done - -if test -z "$PERL" ; then - # We have to set this outside of the loop lest the first failure in - # PROGRAM_CHECK set the value (which then terminates the effect of the - # loop, since autoconf macros only set values that are null, they - # don't override them - PERL="" -fi - -if test -n "$PERL" ; then - PERL="$PERL" - - perlversion=`$PERL -v | grep 'This is perl' | \ - sed -e 's/^.*v[a-z ]*\([0-9]\).*$/\1/'` - - # Should do a test first for ch_p4 etc. - if test "$perlversion" -lt 5 ; then - echo "WRF build requires perl version 5, which configure did not find." - echo "You can set the environment variable PERL to contain the " - echo "location of perl version 5." - echo "Configure believes that $PERL is version $perlversion ." - PERL="" - fi - -fi - -# Look for netcdf -if test -z "$NETCDF" ; then - for p in /usr/local/netcdf - do - if test -d $p ; then - NETCDF=$p - break - fi - done -fi -if test -z "$NETCDF" ; then - - if [ `hostname | cut -c 1-2` = "bs" -o \ - `hostname | cut -c 1-2` = "bd" -o \ - `hostname` = "tempest" -o `hostname` = "ute" ] ; then - echo 'Compiling on an NCAR system with weird paths to NetCDF' - echo 'Setting up a local NetCDF directory with symlinks' - if ( test -d ./netcdf_links ) ; then - echo 'A directory ./netcdf_links already exists. Continuing.' - else - mkdir ./netcdf_links - if [ -z "$OBJECT_MODE" ] ; then - OBJECT_MODE=32 - export OBJECT_MODE - fi - if [ $OBJECT_MODE -ne 64 -a \( `hostname | cut -c 1-2` = "bd" -o `hostname | cut -c 1-2` = "bs" \) ] ; then - ( cd ./netcdf_links ; ln -s /usr/local/lib32/r4i4 ./lib ; \ - ln -s /usr/local/include ./include ) - else - ( cd ./netcdf_links ; ln -s /usr/local/lib64/r4i4 ./lib ; \ - ln -s /usr/local/include ./include ) - fi - fi - NETCDF=`pwd`/netcdf_links - export NETCDF - - - else - bedone="" - if [ -d ./netcdf_links ] ; then - echo '** There is an existing ./netcdf_links file. Should I use? [y]' - read resp - if [ "$resp" = "y" ] ; then - NETCDF=`pwd`/netcdf_links - bedone="yes" - else - echo 'Removing existing ./netcdf_links directory' - /bin/rm -fr ./netcdf_links - fi - else - echo '** WARNING: No path to NETCDF and environment variable NETCDF not set.' - echo '** would you like me to try to fix? [y]' - fi - netcdfipath="" - netcdflpath="" - while [ -z "$bedone" ] ; do - read resp - if [ "$resp" = "y" -o -z "$resp" ] ; then - if [ -d ./netcdf_links ] ; then - echo 'There is already a ./netcdf_links directory. Okay to use links' - echo 'in this directory for NetCDF include and lib dirs? [y]' - read resp - if [ "$resp" = "y" ] ; then - NETCDF=`pwd`/netcdf_links - export NETCDF - bedone="yes" - continue - fi - fi - if [ -z "$netcdfipath" ] ; then - echo 'Enter full path to NetCDF include directory on your system' - read resp - if [ ! -d "$resp" ] ; then - echo "invalid path: $resp. Try again? [y]" ; continue - fi - netcdfipath=$resp - fi - if [ -z "$netcdflpath" ] ; then - echo 'Enter full path to NetCDF library directory on your system' - read resp - if [ ! -d "$resp" ] ; then - echo "invalid path: $resp. Try again? [y]" ; continue - fi - netcdflpath=$resp - fi - - if [ -n "$netcdflpath" -a -n "$netcdfipath" ] ; then - if [ -d ./netcdf_links ] ; then - echo 'Existing ./netcdf_links directory. Okay to remove. [y]' - read resp - if [ "$resp" = "y" ] ; then - /bin/rm -fr ./netcdf_links - fi - fi - mkdir ./netcdf_links - cd ./netcdf_links - ln -s "$netcdfipath" include - ln -s "$netcdflpath" lib - cd .. - echo created new ./netcdf_links directory - /bin/ls -lF ./netcdf_links - NETCDF=`pwd`/netcdf_links - export NETCDF - bedone="yes" - fi - else - bedone="yes" - fi - done - fi -fi - -if test -z "$PDHF5" ; then - if [ `hostname | cut -c 1-2` = "bb" -o `hostname | cut -c 1-2` = "bf" -o `hostname | cut -c 1-2` = "bs" -o \ - `hostname` = "dataproc" -o `hostname` = "ute" ] ; then - if [ -d ~michalak/hdf5pbin ] ; then - PHDF5=~michalak/hdf5pbin - export PHDF5 - fi - if [ "$OBJECT_MODE" -eq 64 ] ; then - if [ -d ~michalak/hdf5pbin-64 ] ; then - PHDF5=~michalak/hdf5pbin-64 - export PHDF5 - fi - fi - fi -fi - -USENETCDFF="" # see below -if [ -n "$NETCDF" ] ; then - echo "Will use NETCDF in dir: $NETCDF" -# for 3.6.2 and greater there might be a second library, libnetcdff.a . Check for this and use -# if available - if [ -f "$NETCDF/lib/libnetcdff.a" -o -f "$NETCDF/lib/libnetcdff.so" ] ; then - USENETCDFF="-lnetcdff" - fi -else - echo "Will configure for use without NetCDF" -fi - -if [ -z "$HDF5_PATH" ] ; then HDF5_PATH=''; fi -if [ -z "$ZLIB_PATH" ] ; then ZLIB_PATH=''; fi -if [ -z "$GPFS_PATH" ] ; then GPFS_PATH=''; fi -if [ -z "$CURL_PATH" ] ; then CURL_PATH=''; fi - -if [ -n "$NETCDF4" ] ; then - if [ $NETCDF4 -eq 1 ] ; then - DEP_LIB_PATH='' - if [ -f $NETCDF/bin/nf-config ] ; then - nx_config="$NETCDF/bin/nf-config --flibs" - DEP_LIB_PATH="`$nx_config | awk '{for(i=1;i<=NF;i++){if(match($i, /-L.*/)) {print $i} } }'`" - CURL="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lcurl") {print $i} } }'`" - GPFS="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lgpfs") {print $i} } }'`" - fi - if [ "$DEP_LIB_PATH" = '' ] ; then - if [ -f $NETCDF/bin/nc-config ] ; then - nx_config="$NETCDF/bin/nc-config --libs" - DEP_LIB_PATH="`$nx_config | awk '{for(i=1;i<=NF;i++){if(match($i, /-L.*/)) {print $i} } }'`" - CURL="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lcurl") {print $i} } }'`" - GPFS="`$nx_config | awk '{for(i=1;i<=NF;i++){if($i == "-lgpfs") {print $i} } }'`" - if [ "$CURL" != '' -a "$CURL_PATH" = '' ] ; then - CURL_PATH="DEFAULT" - fi - if [ "$GPFS" != '' -a "$GPFS_PATH" = '' ] ; then - GPFS_PATH="DEFAULT" - fi - fi - fi - for P in "$HDF5_PATH" "$ZLIB_PATH" "$GPFS_PATH" "$CURL_PATH" - do - if [ "$P" != '' -a "$P" != "DEFAULT" ] ; then - if [ "${P#${P%?}}" = "/" ] ; then - P=`echo $P | sed 's/\/$//'` - fi - DEP_LIB_PATH="`echo $DEP_LIB_PATH | awk -v VAR=-L$P/lib '{for(i=1;i<=NF;i++){if ($i != VAR ) {print $i} } }'`" - DEP_LIB_PATH="$DEP_LIB_PATH -L$P/lib" - fi - done - if [ "${DEP_LIB_PATH#${DEP_LIB_PATH%?}}" = "/" ] ; then - DEP_LIB_PATH=`echo $DEP_LIB_PATH | sed 's/\/$//'` - fi - DEP_LIB_PATH="`echo $DEP_LIB_PATH | awk -v VAR=-L$NETCDF/lib '{for(i=1;i<=NF;i++){if ($i != VAR ) {print $i} } }'`" - fi -fi - -if [ -n "$PNETCDF" ] ; then - echo "Will use PNETCDF in dir: $PNETCDF" -# experimental, so don't tease the user if it is not there -#else -# echo "Will configure for use without NetCDF" -fi - -if [ -n "$PHDF5" ] ; then - echo "Will use PHDF5 in dir: $PHDF5" -else - echo "PHDF5 not set in environment. Will configure WRF for use without." -fi - -if [ "$wrf_core" = "DA_CORE" ]; then - if [ -n "$WRFPLUS_DIR" ] ; then - unset WRFPLUS_DIR - fi -fi - -if [ "$wrf_core" = "4D_DA_CORE" ]; then - if [ -n "$WRFPLUS_DIR" ] ; then - echo "Will use WRFPLUS in dir: $WRFPLUS_DIR" - else - echo "WRFPLUS_DIR not set in environment. Please compile WRFPLUS and set WRFPLUS_DIR." - exit - fi -fi -# Users who are cross-compiling can set environment variable -# $WRF_OS to override the value normally obtained from `uname`. -# If $WRF_OS is set, then $WRF_MACH can also be set to override -# the value normally obtained from `uname -m`. If $WRF_OS is -# set and $WRF_MACH is not set, then $WRF_MACH defaults to "ARCH". -# If $WRF_OS is not set then $WRF_MACH is ignored. -if [ -n "$WRF_OS" ] ; then - echo "${0}: WRF operating system set to \"${WRF_OS}\" via environment variable \$WRF_OS" - os=$WRF_OS - mach="ARCH" - if [ -n "$WRF_MACH" ] ; then - echo "${0}: WRF machine set to \"${WRF_MACH}\" via environment variable \$WRF_MACH" - mach=$WRF_MACH - fi -else - # if the uname command exists, give it a shot and see if - # we can narrow the choices; otherwise, spam 'em - os="ARCH" - mach="ARCH" - type uname > /dev/null - if [ $? -eq 0 ] ; then - os=`uname` - if [ "$os" = "AIX" -o "$os" = "IRIX" -o "$os" = "IRIX64" -o "$os" = "SunOS" -o "$os" = "HP-UX" -o "$os" = "Darwin" -o "$os" = "Interix" ] ; then - mach="ARCH" - else - xxx=`expr "$os" : '\(.........\).*'` - if [ "$xxx" = "CYGWIN_NT" ] ; then - os=$xxx - fi - if [ "$os" = "OSF1" -o "$os" = "Linux" -o "$os" = "UNICOS/mp" -o "$os" = "UNIX_System_V" -o "$os" = "CYGWIN_NT" ] ; then - mach=`uname -m` - if [ "$mach" = "ia64" -a -f /etc/sgi-release ] ; then - mach="Altix" - fi - else - os="ARCH" - mach="ARCH" - fi - fi - fi -fi - -# an IBM specific hack to adjust the bmaxstack and bmaxdata options if addressing is 32-bit -if [ "$os" = "AIX" ] ; then - if [ -z "$OBJECT_MODE" ] ; then - OBJECT_MODE=32 - export OBJECT_MODE - fi - if [ "$OBJECT_MODE" = "32" ] ; then -# the bang means nothing to sh in this context; use to represent spaces (perl will unbang) - ldflags=-bmaxstack:256000000!-bmaxdata:2048000000 - fi -fi - -# compile options that come from the environment, such as chemistry -# the "!" is removed by Config_new.pl -if [ -n "$WRF_HYDRO" ] ; then - if [ $WRF_HYDRO = 1 ] ; then - echo building WRF-HYDRO - compileflags="${compileflags}!-DWRF_HYDRO" - echo $compileflags - fi -fi - -# compile options that come from the environment, such as chemistry -# the "!" is removed by Config_new.pl -if [ -n "$WRF_MARS" ] ; then - if [ $WRF_MARS = 1 ] ; then - echo building WRF for Mars - compileflags="${compileflags}!-DPLANET!-DMARS" - echo $compileflags - fi -fi - -if [ -n "$WRF_TITAN" ] ; then - if [ $WRF_TITAN = 1 ] ; then - echo building WRF for Titan - compileflags="${compileflags}!-DPLANET!-DTITAN" - fi -fi - -if [ -n "$WRF_VENUS" ] ; then - if [ $WRF_VENUS = 1 ] ; then - echo building WRF for Venus - compileflags="${compileflags}!-DPLANET!-DVENUS" - fi -fi -if [ -n "$WRF_QUIETLY" ]; then - echo WRF_QUIETLY is now a synonym for WRF_LOG_BUFFERING - echo setting WRF_LOG_BUFFERING to 1... - export WRF_LOG_BUFFERING=1 -fi -if [ -n "$WRF_LOG_BUFFERING" ]; then - if [ $WRF_LOG_BUFFERING = 1 ]; then - echo building WRF with support for buffering of log messages - compileflags="${compileflags}!-DWRF_LOG_BUFFERING=1" - fi -fi -if [ -n "$WRF_NMM_CORE" ]; then - if [ $WRF_NMM_CORE = 1 ]; then - if [ -n "$HWRF" ]; then - if [ $HWRF = 1 ]; then - echo building WRF with HWRF option - compileflags="${compileflags}!-DHWRF=1" - if [ -n "$IDEAL_NMM_TC" ]; then - echo building WRF with NMM Idealized Tropical Cyclone option - compileflags="${compileflags}!-DIDEAL_NMM_TC=1" - fi - fi - fi - if [ -n "$IBM_REDUCE_BUG_WORKAROUND" ]; then - if [ $IBM_REDUCE_BUG_WORKAROUND = 1 ]; then - echo adding IBM_REDUCE_BUG_WORKAROUND flag for some IBM systems - compileflags="${compileflags}!-DIBM_REDUCE_BUG_WORKAROUND" - fi - fi - fi -fi -if [ -n "$WRF_DFI_RADAR" ] ; then - if [ $WRF_DFI_RADAR = 1 ] ; then - echo building WRF with radar dfi option - compileflags="${compileflags}!-DWRF_DFI_RADAR=1" - fi -fi -if [ -n "$WRF_CHEM" ] ; then - if [ $WRF_CHEM = 1 ] ; then - echo building WRF with chemistry option - compileflags="${compileflags}!-DWRF_CHEM!-DBUILD_CHEM=1" - if [ -n "$WRF_KPP" ] ; then - if [ $WRF_KPP = 1 ] ; then - echo building WRF with KPP chemistry option - compileflags="${compileflags}!-DWRF_KPP" - fi - fi - else - compileflags="${compileflags} " - fi -else - compileflags="${compileflags} " -fi - -if [ -n "$WRF_NMM_CORE" -a -n "$WRF_CHEM" ]; then - if [ $WRF_NMM_CORE = 1 -a $WRF_CHEM = 1 ]; then - echo - echo "NMM is no longer compatible with the Chemistry option." - echo - # alphabetically: c=3, o=15, so co2 = 3+15+2 = 20 - exit 20 - fi -fi - -if [ `which timex` ] ; then - FORTRAN_COMPILER_TIMER=timex -fi - -# Found perl, so proceed with configuration -if test -n "$PERL" ; then - srch=`grep -i "^#ARCH.*$os" arch/configure_new.defaults | grep -i "$mach"` - if [ -n "$srch" ] ; then - $PERL arch/Config_new.pl -dmparallel=$COMMLIB -ompparallel=$OMP -perl=$PERL \ - -netcdf=$NETCDF -pnetcdf=$PNETCDF -phdf5=$PHDF5 -os=$os -mach=$mach -ldflags=$ldflags \ - -compileflags=$compileflags -opt_level=$opt_level -USENETCDFF=$USENETCDFF -time=$FORTRAN_COMPILER_TIMER \ - -wrf_core=$wrf_core -gpfs=$GPFS_PATH -curl=$CURL_PATH -dep_lib_path="$DEP_LIB_PATH" - if test ! -f configure.wrf ; then - exit 1 - fi - if [ "$opt_level" = "-d" ] ; then - sed -e 's/FCOPTIM[ ]*=/& # /' -e '/FCDEBUG[ ]*=/s/#//' configure.wrf > configure.wrf.edit - /bin/mv configure.wrf.edit configure.wrf - fi - if [ "$opt_level" = "-D" ] ; then - sed -e 's/FCOPTIM[ ]*=/& # /' -e '/FCDEBUG[ ]*=/s/#//g' configure.wrf > configure.wrf.edit - /bin/mv configure.wrf.edit configure.wrf - fi - else - WRF_OS=$os ; export WRF_OS - WRF_MACH=$mach ; export WRF_MACH - echo '*** Configuration not found in configure_new.defaults; checking configure_old.defaults ***' - - # see if we still have an old setting laying around from v2 - if [ "$opt_level" = "-d" ] ; then - arch/config_old $opt_level - else - arch/config_old - fi - - fi -fi - -# new feb 2005. test whether MPI-2 -if test -f configure.wrf ; then - grep 'DMPARALLEL *= *1' configure.wrf > /dev/null - if [ $? = 0 ] ; then - echo testing for MPI_Comm_f2c and MPI_Comm_c2f - /bin/rm -f tools/mpi2_test - ( make mpi2_test 2> /dev/null ) 1> /dev/null - if test -e tools/mpi2_test.o ; then - echo " " MPI_Comm_f2c and MPI_Comm_c2f are supported - sed '/^DM_CC.*=/s/$/ -DMPI2_SUPPORT/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf - if [ `hostname | cut -c 1-2` = "be" ] ; then - sed '/^ARCH_LOCAL.*=/s/$/ -DUSE_MPI_IN_PLACE/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf - fi - else - echo " " MPI_Comm_f2c and MPI_Comm_c2f are not supported - fi - grep 'OMPCPP *= *-D_OPENMP' configure.wrf > /dev/null - if [ $? = 0 ] ; then - echo testing for MPI_Init_thread - /bin/rm -f tools/mpi2_thread_test - ( make mpi2_thread_test 2> /dev/null ) 1> /dev/null - if test -e tools/mpi2_thread_test.o ; then - echo " " MPI_Init_thread is supported - sed '/^DM_CC.*=/s/$/ -DMPI2_THREAD_SUPPORT/' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf - else - echo " " MPI_Init_thread is not supported - fi - fi - fi -# new dec 2005. test what fseek is supported (needed for share/landread.c to work correctly) - echo testing for fseeko and fseeko64 - /bin/rm -f tools/fseeko_test tools/fseeko64_test - ( make fseek_test 2> /dev/null ) 1> /dev/null - if [ "$os" = "Darwin" ] ; then - # fseeko64 does not exist under Darwin fseeko does. Remove the 0 length executable - # file that might get generated anyway, even though the compiler complains about missing reference. - /bin/rm -f tools/fseeko64_test - fi - if test -x tools/fseeko64_test ; then - ( tools/fseeko64_test 2> /dev/null ) 1> /dev/null - if [ $? = 0 ] ; then - echo fseeko64 is supported - sed '/^CC .*=/s/$/ -DFSEEKO64_OK /' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf - fi - else - if test -x tools/fseeko_test ; then - ( tools/fseeko_test 2> /dev/null ) 1> /dev/null - if [ $? = 0 ] ; then - echo fseeko is supported and handles 64 bit offsets - sed '/^CC .*=/s/$/ -DFSEEKO_OK /' configure.wrf > xx$$ ; /bin/mv xx$$ configure.wrf - else - echo neither fseeko64 nor fseeko with 64 bit offsets works, landread will be compiled with fseek - echo but may not work correctly for very high resolution terrain datasets - fi - else - echo neither fseeko64 nor fseeko with 64 bit offsets works, landread will be compiled with fseek - echo but may not work correctly for very high resolution terrain datasets - fi - fi -fi - -echo "------------------------------------------------------------------------" -sed -e '1,/#### Architecture specific settings ####/d' -e '/^externals/,$d' configure.wrf - -echo "------------------------------------------------------------------------" -echo "Settings listed above are written to configure.wrf." -echo "If you wish to change settings, please edit that file." -echo "If you wish to change the default options, edit the file:" -echo " arch/configure_new.defaults" - -if test -n "$NETCDF" ; then - if [ ! -f $NETCDF/include/netcdf.inc ] ; then - echo - echo "Error : Not found $NETCDF/include/netcdf.inc" - echo " Please check this installation of NetCDF and re-run this configure script" - echo - exit -1 - fi - grep nf_format_64bit $NETCDF/include/netcdf.inc > /dev/null - configure_aaaa=$? ; export configure_aaaa - if [ $configure_aaaa -a -z "$WRFIO_NCD_LARGE_FILE_SUPPORT" ] ; then - echo "NetCDF users note:" - echo " This installation of NetCDF supports large file support. To enable large file" - echo " support in NetCDF, set the environment variable WRFIO_NCD_LARGE_FILE_SUPPORT" - echo " to 1 and run configure again. Set to any other value to avoid this message." - fi -fi -echo " " - -if [ "$wrf_core" = "DA_CORE" -o "$wrf_core" = "4D_DA_CORE" ]; then - if [ "`grep '^SFC' configure.wrf | grep -i 'gfortran'`" != "" -o "`grep '^SFC' configure.wrf | grep -i 'frtpx'`" != "" ]; then - echo "WRFDA using gfortran/frtpx needs realsize=8" - sed -e '/^PROMOTION.*=/s/#//' configure.wrf > configure.wrf.edit - /bin/mv configure.wrf.edit configure.wrf - fi -fi - -#Checking cross-compiling capability for some particular environment -#on Linux and Mac box - -if [ $os = "Linux" -o $os = "Darwin" ]; then - - SFC=`grep '^SFC' configure.wrf | awk '{print $3}'` - SCC=`grep '^SCC' configure.wrf | awk '{print $3}'` - CCOMP=`grep '^CCOMP' configure.wrf | awk '{print $3}'` - - SFC="`type $SFC 2>/dev/null | awk '{print $NF}' | sed -e 's/(//g;s/)//g'`" - SCC="`type $SCC 2>/dev/null | awk '{print $NF}' | sed -e 's/(//g;s/)//g'`" - CCOMP="`type $CCOMP 2>/dev/null | awk '{print $NF}' | sed -e 's/(//g;s/)//g'`" - - foo=foo_$$ - -cat > ${foo}.c < ${foo}.f < /dev/null 2>&1 - if [ $? != 0 ]; then - sed 's/-cc=$(SCC)//' configure.wrf > configure.wrf.edit - mv configure.wrf.edit configure.wrf - fi - rm ${foo} ${foo}.o 2> /dev/null - mpif90 -f90=$SFC -o ${foo} ${foo}.f > /dev/null 2>&1 - if [ $? != 0 ]; then - sed 's/-f90=$(SFC)//' configure.wrf > configure.wrf.edit - mv configure.wrf.edit configure.wrf - fi - rm ${foo} ${foo}.o 2> /dev/null - fi - fi - - if [ -e $NETCDF/lib/libnetcdf.a -a "$SFC" != "" -a "$SCC" != "" -a "$CCOMP" != "" ]; then - - SFC_MULTI_ABI=0 - SCC_MULTI_ABI=0 - CCOMP_MULTI_ABI=0 - CROSS_COMPILING=0 - - echo - echo Testing for NetCDF, C and Fortran compiler - echo - - ar p $NETCDF/lib/libnetcdf.a `ar t $NETCDF/lib/libnetcdf.a | grep -E '\.o' | head -n 1 | sed 's/://'` > ${foo}.o - netcdf_arch="`file ${foo}.o | grep -o -E '[0-9]{2}-bit|i386'`" - rm ${foo}.o - - $SFC -o ${foo} ${foo}.f > /dev/null 2>&1 - SFC_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`" - rm ${foo} ${foo}.o 2> /dev/null - - $SCC -o ${foo} ${foo}.c > /dev/null 2>&1 - SCC_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`" - CCOMP_arch=$SCC_arch - rm ${foo} ${foo}.o 2> /dev/null - - if [ "$SCC" != "$CCOMP" ]; then - $CCOMP -o ${foo} ${foo}.c > /dev/null 2>&1 - CCOMP_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`" - rm ${foo} ${foo}.o 2> /dev/null - fi - - if [ "$SFC_arch" = "" -o "$SCC_arch" = "" -o "$CCOMP_arch" = "" ]; then - echo " One of compilers testing failed!" - echo " Please check your compiler" - echo - rm -f ${foo} ${foo}.[cfo] 2> /dev/null - exit - else - cp configure.wrf configure.wrf.edit - fi - - case $netcdf_arch in - - 32-bit|i386 ) - - if [ "$SFC_arch" = "64-bit" ] ; then - CROSS_COMPILING=1 - $SFC -m32 -o ${foo} ${foo}.f > /dev/null 2>&1 - if [ $? = 0 ]; then - SFC_MULTI_ABI=1 - sed '/^SFC.*=/s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp - mv configure.wrf.tmp configure.wrf.edit - fi - fi - if [ "$SCC_arch" = "64-bit" ] ; then - CROSS_COMPILING=1 - $SCC -m32 -o ${foo} ${foo}.c > /dev/null 2>&1 - if [ $? = 0 ]; then - SCC_MULTI_ABI=1 - sed '/^SCC.*=/s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp - mv configure.wrf.tmp configure.wrf.edit - fi - fi - - if [ "$CCOMP_arch" = "64-bit" ] ; then - CROSS_COMPILING=1 - if [ "$CCOMP" != "$SCC" ]; then - $CCOMP -m32 -o ${foo} ${foo}.c > /dev/null 2>&1 - if [ $? = 0 ]; then - CCOMP_MULTI_ABI=1 - sed '/^CCOMP/ s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp - mv configure.wrf.tmp configure.wrf.edit - fi - else - CCOMP_MULTI_ABI=1 - sed '/^CCOMP/ s/$/ -m32/' configure.wrf.edit > configure.wrf.tmp - mv configure.wrf.tmp configure.wrf.edit - fi - fi - - if [ $CROSS_COMPILING -eq 1 ] ; then - echo NOTE: - echo This installation of NetCDF is 32-bit - if [ \( $SFC_MULTI_ABI -ne 1 -a "$SFC_arch" = "64-bit" \) \ - -o \( $SCC_MULTI_ABI -ne 1 -a "$SCC_arch" = "64-bit" \) \ - -o \( $CCOMP_MULTI_ABI -ne 1 -a "$CCOMP_arch" = "64-bit" \) ] ; then - rm configure.wrf.edit - echo One of compilers is 64-bit and doesn\'t support cross-compiling. - echo Please check your NETCDF lib and compiler - else - echo -m32 is appended to configure.wrf - echo It will be forced to build in 32-bit. - echo If you don\'t want 32-bit binaries, please use 64-bit NetCDF, and re-run the configure script. - fi - fi - ;; - - 64-bit ) - - if [ "$SFC_arch" = "32-bit" -o "$SFC_arch" = "i386" ] ; then - CROSS_COMPILING=1 - $SFC -m64 -o ${foo} ${foo}.f > /dev/null 2>&1 - if [ $? = 0 ]; then - SFC_MULTI_ABI=1 - sed '/^SFC.*=/s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp - mv configure.wrf.tmp configure.wrf.edit - fi - fi - if [ "$SCC_arch" = "32-bit" -o "$SCC_arch" = "i386" ] ; then - CROSS_COMPILING=1 - $SCC -m64 -o ${foo} ${foo}.c > /dev/null 2>&1 - if [ $? = 0 ]; then - SCC_MULTI_ABI=1 - sed '/^SCC.*=/s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp - mv configure.wrf.tmp configure.wrf.edit - fi - fi - - if [ "$CCOMP_arch" = "32-bit" -o "$CCOMP_arch" = "i386" ] ; then - CROSS_COMPILING=1 - if [ "$CCOMP" != "$SCC" ]; then - $CCOMP -m64 -o ${foo} ${foo}.c > /dev/null 2>&1 - if [ $? = 0 ]; then - CCOMP_MULTI_ABI=1 - sed '/^CCOMP/ s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp - mv configure.wrf.tmp configure.wrf.edit - fi - else - CCOMP_MULTI_ABI=1 - sed '/^CCOMP/ s/$/ -m64/' configure.wrf.edit > configure.wrf.tmp - mv configure.wrf.tmp configure.wrf.edit - fi - fi - - if [ $CROSS_COMPILING -eq 1 ] ; then - echo NOTE: - echo This installation of NetCDF is 64-bit - if [ \( $SFC_MULTI_ABI -ne 1 -a "$SFC_arch" != "64-bit" \) \ - -o \( $SCC_MULTI_ABI -ne 1 -a "$SCC_arch" != "64-bit" \) \ - -o \( $CCOMP_MULTI_ABI -ne 1 -a "$CCOMP_arch" != "64-bit" \) ]; then - rm configure.wrf.edit - echo One of Compilers is 32-bit and doesn\'t support cross-compiling. - echo Please check your NetCDF lib and compiler - else - echo -m64 is appended to configure.wrf - echo It will be forced to build in 64-bit. - echo If you don\'t want 64-bit binaries, please use 32-bit NetCDF, and re-run the configure script. - fi - fi - ;; - esac - - if [ -e configure.wrf.edit ]; then - mv configure.wrf.edit configure.wrf - fi - - if [ $CROSS_COMPILING -eq 0 ] ; then - echo "This installation of NetCDF is $netcdf_arch" - echo " C compiler is $SCC_arch" - echo " Fortran compiler is $SFC_arch" - echo " It will build in $netcdf_arch" - fi - echo - fi - rm -f ${foo} ${foo}.[cfo] 2> /dev/null -fi - -# testing for Fortran 2003 IEEE signaling features -make fortran_2003_ieee_test > tools/fortran_2003_ieee_test.log 2>&1 -rm -f tools/fortran_2003_ieee_test.log -retval=-1 -if [ -f tools/fortran_2003_ieee_test.exe ] ; then - retval=0 -fi -if [ $retval -ne 0 ] ; then - sed -e '/^ARCH_LOCAL/s/$/ -DNO_IEEE_MODULE/' configure.wrf > configure.wrf.edit - mv configure.wrf.edit configure.wrf - echo " " - echo " " - echo "************************** W A R N I N G ************************************" - echo " " - echo "There are some Fortran 2003 features in WRF that your compiler does not recognize" - echo "The IEEE signaling call has been removed. That may not be enough." - echo " " - echo "*****************************************************************************" -fi - -# testing for Fortran 2003 ISO_C features -make fortran_2003_iso_c_test > tools/fortran_2003_iso_c_test.log 2>&1 -rm -f tools/fortran_2003_iso_c_test.log -retval=-1 -if [ -f tools/fortran_2003_iso_c_test.exe ] ; then - retval=0 -fi -if [ $retval -ne 0 ] ; then - sed -e '/^ARCH_LOCAL/s/$/ -DNO_ISO_C_SUPPORT/' configure.wrf > configure.wrf.edit - mv configure.wrf.edit configure.wrf - echo " " - echo " " - echo "************************** W A R N I N G ************************************" - echo " " - echo "There are some Fortran 2003 features in WRF that your compiler does not recognize" - echo "The routines that utilize ISO_C support have been stubbed out. " - echo "That may not be enough." - echo " " - echo "*****************************************************************************" -fi - -# testing for netcdf4 IO features -if [ -n "$NETCDF4" ] ; then - if [ $NETCDF4 -eq 1 ] ; then - make nc4_test > tools/nc4_test.log 2>&1 - retval=-1 - if [ -f tools/nc4_test.exe ] ; then - retval=0 - rm -f tools/nc4_test.log - fi - if [ $retval -ne 0 ] ; then - echo "************************** W A R N I N G ************************************" - echo "NETCDF4 IO features are enabled, but this installation of NetCDF " - echo " $NETCDF" - echo "sounds like DO NOT support these IO features. " - echo - echo "Please make sure NETCDF version is 4.1.3 or later and was built with " - echo "--enable-netcdf4 " - echo - echo "OR unset NETCDF4 variable " - echo " bash/ksh : unset NETCDF4 " - echo " csh : unsetenv NETCDF4 " - echo - echo "Then re-run this configure script " - echo - echo "!!! configure.wrf WAS REMOVED !!!" - echo - echo "*****************************************************************************" - rm -f configure.wrf - fi - fi -fi diff --git a/wrfv2_fire/dyn_em/depend.dyn_em b/wrfv2_fire/dyn_em/depend.dyn_em index 7bea8683..907bf708 100644 --- a/wrfv2_fire/dyn_em/depend.dyn_em +++ b/wrfv2_fire/dyn_em/depend.dyn_em @@ -21,7 +21,9 @@ module_advect_em.o: ../share/module_bc.o \ ../share/module_model_constants.o \ ../frame/module_wrf_error.o -module_bc_em.o: ../share/module_bc.o ../frame/module_configure.o \ +module_bc_em.o: ../share/module_bc.o \ + ../share/module_model_constants.o \ + ../frame/module_configure.o \ ../frame/module_wrf_error.o module_big_step_utilities_em.o: \ @@ -153,6 +155,17 @@ module_initialize_seabreeze2d_x.o : \ ../share/module_bc.o \ module_init_utilities.o +module_initialize_convrad.o : \ + ../frame/module_domain.o \ + ../frame/module_configure.o \ + ../frame/module_state_description.o \ + ../frame/module_timing.o \ + ../frame/module_dm.o \ + ../share/module_io_domain.o \ + ../share/module_model_constants.o \ + ../share/module_bc.o \ + module_init_utilities.o + module_initialize_tropical_cyclone.o : \ ../frame/module_domain.o \ ../frame/module_configure.o \ diff --git a/wrfv2_fire/dyn_em/module_after_all_rk_steps.F b/wrfv2_fire/dyn_em/module_after_all_rk_steps.F index 88c7ec46..aa81b0df 100644 --- a/wrfv2_fire/dyn_em/module_after_all_rk_steps.F +++ b/wrfv2_fire/dyn_em/module_after_all_rk_steps.F @@ -43,6 +43,17 @@ SUBROUTINE after_all_rk_steps ( grid, config_flags, & USE module_configure, ONLY : grid_config_rec_type +#ifdef DM_PARALLEL + ! Ensure some of the fancy diagnostics variables that need to + ! talk to other patches can do so. + + USE module_dm, ONLY : & + local_communicator, mytask, ntasks, ntasks_x, ntasks_y & + ,local_communicator_periodic, wrf_dm_maxval + + USE module_comm_dm, ONLY : & + halo_em_phys_w_sub +#endif !============================================================= ! USE Association for the Diagnostic Packages @@ -122,6 +133,12 @@ SUBROUTINE after_all_rk_steps ( grid, config_flags, & imsy,imey,jmsy,jmey,kmsy,kmey, & ipsy,ipey,jpsy,jpey,kpsy,kpey +#ifdef DM_PARALLEL + !============================================================= + ! Include patch communications + !============================================================= +# include "HALO_EM_PHYS_W.inc" +#endif !============================================================= ! Start of executable code diff --git a/wrfv2_fire/dyn_em/module_bc_em.F b/wrfv2_fire/dyn_em/module_bc_em.F index 6334a7e8..97dde121 100644 --- a/wrfv2_fire/dyn_em/module_bc_em.F +++ b/wrfv2_fire/dyn_em/module_bc_em.F @@ -5,6 +5,7 @@ MODULE module_bc_em USE module_bc USE module_configure USE module_wrf_error + USE module_model_constants CONTAINS @@ -535,6 +536,7 @@ SUBROUTINE spec_bdy_dry_perturb ( config_flags, msfu, msfv, msft, & field_u_tend_perturb,field_v_tend_perturb,field_t_tend_perturb, & spec_bdy_width, spec_zone, & + kme_stoch, & ! stoch dims ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims ips,ipe, jps,jpe, kps,kpe, & ! patch dims @@ -548,10 +550,11 @@ SUBROUTINE spec_bdy_dry_perturb ( config_flags, INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe, & - its, ite, jts, jte, kts, kte + its, ite, jts, jte, kts, kte, & + kme_stoch INTEGER , INTENT(IN ) :: spec_bdy_width, spec_zone - REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: ru_tend, & + REAL , DIMENSION( ims:ime , kms:kme ,jms:jme ) , INTENT(INOUT) :: ru_tend, & rv_tend, & t_tend @@ -561,7 +564,7 @@ SUBROUTINE spec_bdy_dry_perturb ( config_flags, REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: msfv REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: msft - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field_u_tend_perturb, & + REAL, DIMENSION( ims:ime , kms:kme_stoch , jms:jme ), INTENT(IN ) :: field_u_tend_perturb, & field_v_tend_perturb, & field_t_tend_perturb @@ -569,6 +572,7 @@ SUBROUTINE spec_bdy_dry_perturb ( config_flags, field_u_tend_perturb, mu_2,mub, & 'u', msfu, config_flags, & spec_bdy_width, spec_zone, & + kme_stoch, & ! stoch dims ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims ips,ipe, jps,jpe, kps,kpe, & ! patch dims @@ -577,6 +581,7 @@ SUBROUTINE spec_bdy_dry_perturb ( config_flags, field_v_tend_perturb,mu_2,mub, & 'v', msfv, config_flags, & spec_bdy_width, spec_zone, & + kme_stoch, & ! stoch dims ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims ips,ipe, jps,jpe, kps,kpe, & ! patch dims @@ -586,6 +591,7 @@ SUBROUTINE spec_bdy_dry_perturb ( config_flags, field_t_tend_perturb,mu_2,mub, & 't', msft, config_flags, & spec_bdy_width, spec_zone, & + kme_stoch, & ! stoch dims ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims ips,ipe, jps,jpe, kps,kpe, & ! patch dims @@ -595,6 +601,48 @@ END SUBROUTINE spec_bdy_dry_perturb +!------------------------------------------------------------------------ + SUBROUTINE spec_bdy_chem_perturb (periodic_x, & + field_bdy_tend_xs, field_bdy_tend_xe, & + field_bdy_tend_ys, field_bdy_tend_ye, & + field_scalar_perturb, & + spec_bdy_width, spec_zone, & + kme_stoch, & ! stoch dims + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its, ite, jts, jte, kts, kte) + IMPLICIT NONE + + + LOGICAL , INTENT(IN ) :: periodic_x + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte, & + kme_stoch + INTEGER , INTENT(IN ) :: spec_bdy_width, spec_zone + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field_scalar_perturb + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(INOUT) :: field_bdy_tend_xs, field_bdy_tend_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(INOUT) :: field_bdy_tend_ys, field_bdy_tend_ye + + + CALL spec_bdytend_perturb_chem ( field_bdy_tend_xs, field_bdy_tend_xe, & + field_bdy_tend_ys, field_bdy_tend_ye, & + field_scalar_perturb, 'c', & + periodic_x, & + spec_bdy_width, spec_zone, & + kme_stoch, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + + END SUBROUTINE spec_bdy_chem_perturb + + + !------------------------------------------------------------------------ SUBROUTINE spec_bdy_scalar ( scalar_tend, & scalar_bxs,scalar_bxe,scalar_bys,scalar_bye, & @@ -1280,5 +1328,240 @@ SUBROUTINE lbc_fcx_gcx ( fcx , gcx , spec_bdy_width , & ENDIF END SUBROUTINE lbc_fcx_gcx + +!------------------------------------------------------------------------ + + SUBROUTINE theta_and_thetam_lbc_only ( & + theta_to_thetam, & + mub, & + mu_bdy_xs, mu_bdy_xe, & + mu_bdy_ys, mu_bdy_ye, & + mu_bdy_tend_xs, mu_bdy_tend_xe, & + mu_bdy_tend_ys, mu_bdy_tend_ye, & + t_bdy_xs, t_bdy_xe, & + t_bdy_ys, t_bdy_ye, & + t_bdy_tend_xs, t_bdy_tend_xe, & + t_bdy_tend_ys, t_bdy_tend_ye, & + moist_bdy_xs, moist_bdy_xe, & + moist_bdy_ys, moist_bdy_ye, & + moist_bdy_tend_xs, moist_bdy_tend_xe, & + moist_bdy_tend_ys, moist_bdy_tend_ye, & + spec_bdy_width, & + dt_interval, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + ! This routine is called from the solve_em routine. The purpose is to + ! convert the thermal lateral boundary conditions between dry potential + ! temperature and moist potential temperature. The first argument is a + ! flag telling us the direction of the conversion: + ! True = convert dry to moist potential temp + ! False = convert moist to dry potential temp + + LOGICAL, INTENT(IN ) :: theta_to_thetam + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: spec_bdy_width + REAL , INTENT(IN ) :: dt_interval + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: mub + + REAL, DIMENSION( jms:jme , 1 , spec_bdy_width ), INTENT(IN ) :: mu_bdy_xs, mu_bdy_xe + REAL, DIMENSION( ims:ime , 1 , spec_bdy_width ), INTENT(IN ) :: mu_bdy_ys, mu_bdy_ye + REAL, DIMENSION( jms:jme , 1 , spec_bdy_width ), INTENT(IN ) :: mu_bdy_tend_xs, mu_bdy_tend_xe + REAL, DIMENSION( ims:ime , 1 , spec_bdy_width ), INTENT(IN ) :: mu_bdy_tend_ys, mu_bdy_tend_ye + + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(INOUT) :: t_bdy_xs, t_bdy_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(INOUT) :: t_bdy_ys, t_bdy_ye + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(INOUT) :: t_bdy_tend_xs, t_bdy_tend_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(INOUT) :: t_bdy_tend_ys, t_bdy_tend_ye + + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: moist_bdy_xs, moist_bdy_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: moist_bdy_ys, moist_bdy_ye + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: moist_bdy_tend_xs, moist_bdy_tend_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: moist_bdy_tend_ys, moist_bdy_tend_ye + + ! Local variables + + INTEGER :: i, j, k, ii, jj + + REAL :: dt_time_until_next_lbc + + REAL :: mu_old_bdy_xs , mu_old_bdy_xe + REAL :: mu_old_bdy_ys , mu_old_bdy_ye + REAL :: mu_new_bdy_xs , mu_new_bdy_xe + REAL :: mu_new_bdy_ys , mu_new_bdy_ye + + REAL :: t_old_bdy_xs , t_old_bdy_xe + REAL :: t_old_bdy_ys , t_old_bdy_ye + REAL :: t_new_bdy_xs , t_new_bdy_xe + REAL :: t_new_bdy_ys , t_new_bdy_ye + REAL :: t_old_bdy_tend_xs , t_old_bdy_tend_xe + REAL :: t_old_bdy_tend_ys , t_old_bdy_tend_ye + + REAL :: moist_old_bdy_xs , moist_old_bdy_xe + REAL :: moist_old_bdy_ys , moist_old_bdy_ye + REAL :: moist_new_bdy_xs , moist_new_bdy_xe + REAL :: moist_new_bdy_ys , moist_new_bdy_ye + REAL :: moist_old_bdy_tend_xs , moist_old_bdy_tend_xe + REAL :: moist_old_bdy_tend_ys , moist_old_bdy_tend_ye + + ! IF ( theta_to_thetam ) THEN + ! Convert dry potential temperature to theta_m + ! Defined as: theta_m = ( theta + T0 ) * ( 1. + (R_v/R_d) Qv ) - T0 + ! ELSE + ! Convert dry potential temperature to theta_m + ! Defined as: theta = ( theta_m + T0 ) / ( 1. + (R_v/R_d) Qv ) - T0 + ! END IF + + ! We want the current value and the tendency, using information mostly + ! from the lateral boundary file. In that file, the thermal variable + ! is a potential temperature with the T0 offset removed (theta-300). Both + ! the moisture variable and the potential temperature are coupled + ! (multiplied by total dry column pressure). And to add one more complication, + ! the MU variable in the lateral boundary array is perturbation only. + + ! Since we need to end up with lateral boundary values that are coupled, + ! we need to first DECOUPLE T and Qv, compute Tm, and then couple that. As + ! there is a need for the lateral tendency also, we compute the T and Qv + ! values at the two boundary times (previous/current and next). These two + ! times are adequate to get us a tendency. For the tendency, we need to have + ! coupled values for the T (or Tm) at both times, which gives us a coupled + ! tendency. We cannot have an uncoupled tendency and somehow multiply that + ! by some intermediate/average column pressure. + + ! This routine's purpose is to manufacture a lateral boundary set of arrays + ! (all eight of them) for the thermal field. Depending on the logical flag + ! passed in, this will either be dry potential temperature or moist potential + ! temperature. + + ! South and north lateral boundaries. This is the i-extent of its through ite, but j only + ! goes to within spec_bdy_width of the top and bottom (north and south) boundaries. + + ! South boundary: i,k,j + ! jj increasing + + DO jj = MAX(jts,1) , MIN(jte,jde-1,spec_bdy_width) + j = jj + DO k = kts , kte-1 + DO i = MAX(1,its-4) , MIN(ite+4,ide-1) + mu_old_bdy_ys = mu_bdy_ys(i,1,j) + mub(i,jj) + t_old_bdy_ys = ( t_bdy_ys(i,k,j) ) / mu_old_bdy_ys + moist_old_bdy_ys = ( moist_bdy_ys(i,k,j) ) / mu_old_bdy_ys + mu_new_bdy_ys = mu_old_bdy_ys + mu_bdy_tend_ys(i,1,j) *dt_interval + t_new_bdy_ys = ( t_bdy_ys(i,k,j) + t_bdy_tend_ys(i,k,j) *dt_interval ) / mu_new_bdy_ys + moist_new_bdy_ys = ( moist_bdy_ys(i,k,j) + moist_bdy_tend_ys(i,k,j)*dt_interval ) / mu_new_bdy_ys + t_old_bdy_tend_ys = ( t_new_bdy_ys - t_old_bdy_ys ) / dt_interval + moist_old_bdy_tend_ys = ( moist_new_bdy_ys - moist_old_bdy_ys ) / dt_interval + IF ( theta_to_thetam ) THEN + t_bdy_ys(i,k,j) = ( ( ( t_old_bdy_ys + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_ys ) ) - T0 ) * mu_old_bdy_ys + t_bdy_tend_ys(i,k,j) = ( ( mu_new_bdy_ys * ( ( t_new_bdy_ys + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_ys ) - T0 ) ) - & + ( mu_old_bdy_ys * ( ( t_old_bdy_ys + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_ys ) - T0 ) ) ) / dt_interval + ELSE + t_bdy_ys(i,k,j) = ( ( ( t_old_bdy_ys + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_ys ) ) - T0 ) * mu_old_bdy_ys + t_bdy_tend_ys(i,k,j) = ( ( mu_new_bdy_ys * ( ( t_new_bdy_ys + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_ys ) - T0 ) ) - & + ( mu_old_bdy_ys * ( ( t_old_bdy_ys + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_ys ) - T0 ) ) ) / dt_interval + END IF + END DO + END DO + END DO + + ! North boundary: i,k,j + ! jj decreasing + + DO jj = MIN(jde-1,jte) , MAX(jde-spec_bdy_width,jts) , -1 + j = jde-jj + DO k = kts , kte-1 + DO i = MAX(1,its-4) , MIN(ite+4,ide-1) + mu_old_bdy_ye = mu_bdy_ye(i,1,j) + mub(i,jj) + t_old_bdy_ye = ( t_bdy_ye(i,k,j) ) / mu_old_bdy_ye + moist_old_bdy_ye = ( moist_bdy_ye(i,k,j) ) / mu_old_bdy_ye + mu_new_bdy_ye = mu_old_bdy_ye + mu_bdy_tend_ye(i,1,j) *dt_interval + t_new_bdy_ye = ( t_bdy_ye(i,k,j) + t_bdy_tend_ye(i,k,j) *dt_interval ) / mu_new_bdy_ye + moist_new_bdy_ye = ( moist_bdy_ye(i,k,j) + moist_bdy_tend_ye(i,k,j)*dt_interval ) / mu_new_bdy_ye + t_old_bdy_tend_ye = ( t_new_bdy_ye - t_old_bdy_ye ) / dt_interval + moist_old_bdy_tend_ye = ( moist_new_bdy_ye - moist_old_bdy_ye ) / dt_interval + IF ( theta_to_thetam ) THEN + t_bdy_ye(i,k,j) = ( ( ( t_old_bdy_ye + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_ye ) ) - T0 ) * mu_old_bdy_ye + t_bdy_tend_ye(i,k,j) = ( ( mu_new_bdy_ye * ( ( t_new_bdy_ye + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_ye ) - T0 ) ) - & + ( mu_old_bdy_ye * ( ( t_old_bdy_ye + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_ye ) - T0 ) ) ) / dt_interval + ELSE + t_bdy_ye(i,k,j) = ( ( ( t_old_bdy_ye + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_ye ) ) - T0 ) * mu_old_bdy_ye + t_bdy_tend_ye(i,k,j) = ( ( mu_new_bdy_ye * ( ( t_new_bdy_ye + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_ye ) - T0 ) ) - & + ( mu_old_bdy_ye * ( ( t_old_bdy_ye + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_ye ) - T0 ) ) ) / dt_interval + END IF + END DO + END DO + END DO + + ! West and east lateral boundaries. This is the j-extent of jts through jte, but i only + ! goes to within spec_bdy_width of the left and right (west and east) boundaries. + + ! West boundary: j,k,i + ! ii increasing + + DO ii = MAX(its,1) , MIN(ite,ide-1,spec_bdy_width) + i = ii + DO k = kts , kte-1 + DO j = MAX(1,jts-4) , MIN(jte+4,jde-1) + mu_old_bdy_xs = mu_bdy_xs(j,1,i) + mub(ii,j) + t_old_bdy_xs = ( t_bdy_xs(j,k,i) ) / mu_old_bdy_xs + moist_old_bdy_xs = ( moist_bdy_xs(j,k,i) ) / mu_old_bdy_xs + mu_new_bdy_xs = mu_old_bdy_xs + mu_bdy_tend_xs(j,1,i) *dt_interval + t_new_bdy_xs = ( t_bdy_xs(j,k,i) + t_bdy_tend_xs(j,k,i) *dt_interval ) / mu_new_bdy_xs + moist_new_bdy_xs = ( moist_bdy_xs(j,k,i) + moist_bdy_tend_xs(j,k,i)*dt_interval ) / mu_new_bdy_xs + t_old_bdy_tend_xs = ( t_new_bdy_xs - t_old_bdy_xs ) / dt_interval + moist_old_bdy_tend_xs = ( moist_new_bdy_xs - moist_old_bdy_xs ) / dt_interval + IF ( theta_to_thetam ) THEN + t_bdy_xs(j,k,i) = ( ( ( t_old_bdy_xs + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_xs ) ) - T0 ) * mu_old_bdy_xs + t_bdy_tend_xs(j,k,i) = ( ( mu_new_bdy_xs * ( ( t_new_bdy_xs + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_xs ) - T0 ) ) - & + ( mu_old_bdy_xs * ( ( t_old_bdy_xs + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_xs ) - T0 ) ) ) / dt_interval + ELSE + t_bdy_xs(j,k,i) = ( ( ( t_old_bdy_xs + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_xs ) ) - T0 ) * mu_old_bdy_xs + t_bdy_tend_xs(j,k,i) = ( ( mu_new_bdy_xs * ( ( t_new_bdy_xs + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_xs ) - T0 ) ) - & + ( mu_old_bdy_xs * ( ( t_old_bdy_xs + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_xs ) - T0 ) ) ) / dt_interval + END IF + END DO + END DO + END DO + + ! East boundary: j,k,i + ! ii decreasing + + DO ii = MIN(ide-1,ite) , MAX(ide-spec_bdy_width,its) , -1 + i = ide-ii + DO k = kts , kte-1 + DO j = MAX(1,jts-4) , MIN(jte+4,jde-1) + mu_old_bdy_xe = mu_bdy_xe(j,1,i) + mub(ii,j) + t_old_bdy_xe = ( t_bdy_xe(j,k,i) ) / mu_old_bdy_xe + moist_old_bdy_xe = ( moist_bdy_xe(j,k,i) ) / mu_old_bdy_xe + mu_new_bdy_xe = mu_old_bdy_xe + mu_bdy_tend_xe(j,1,i) *dt_interval + t_new_bdy_xe = ( t_bdy_xe(j,k,i) + t_bdy_tend_xe(j,k,i) *dt_interval ) / mu_new_bdy_xe + moist_new_bdy_xe = ( moist_bdy_xe(j,k,i) + moist_bdy_tend_xe(j,k,i)*dt_interval ) / mu_new_bdy_xe + t_old_bdy_tend_xe = ( t_new_bdy_xe - t_old_bdy_xe ) / dt_interval + moist_old_bdy_tend_xe = ( moist_new_bdy_xe - moist_old_bdy_xe ) / dt_interval + IF ( theta_to_thetam ) THEN + t_bdy_xe(j,k,i) = ( ( ( t_old_bdy_xe + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_xe ) ) - T0 ) * mu_old_bdy_xe + t_bdy_tend_xe(j,k,i) = ( ( mu_new_bdy_xe * ( ( t_new_bdy_xe + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_xe ) - T0 ) ) - & + ( mu_old_bdy_xe * ( ( t_old_bdy_xe + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_xe ) - T0 ) ) ) / dt_interval + ELSE + t_bdy_xe(j,k,i) = ( ( ( t_old_bdy_xe + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_xe ) ) - T0 ) * mu_old_bdy_xe + t_bdy_tend_xe(j,k,i) = ( ( mu_new_bdy_xe * ( ( t_new_bdy_xe + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_xe ) - T0 ) ) - & + ( mu_old_bdy_xe * ( ( t_old_bdy_xe + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_xe ) - T0 ) ) ) / dt_interval + END IF + END DO + END DO + END DO + + END SUBROUTINE theta_and_thetam_lbc_only + +!------------------------------------------------------------------------ END MODULE module_bc_em diff --git a/wrfv2_fire/dyn_em/module_big_step_utilities_em.F b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F index 2e1a3582..e117a54d 100644 --- a/wrfv2_fire/dyn_em/module_big_step_utilities_em.F +++ b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F @@ -13,8 +13,8 @@ MODULE module_big_step_utilities_em USE module_model_constants - USE module_state_description, only: p_qg, p_qs, p_qi, gdscheme, tiedtkescheme, kfetascheme, g3scheme, & - gfscheme,p_qv, param_first_scalar, p_qr, p_qc, DFI_FWD + USE module_state_description, only: p_qg, p_qs, p_qi, gdscheme, tiedtkescheme, ntiedtkescheme, kfetascheme, mskfscheme, & + g3scheme, gfscheme,p_qv, param_first_scalar, p_qr, p_qc, DFI_FWD USE module_configure, ONLY : grid_config_rec_type USE module_wrf_error @@ -148,7 +148,7 @@ SUBROUTINE calc_mu_uv ( config_flags, & jm = jte-1 if(config_flags%periodic_y) jm = jte DO i=its,itf - muv(i,j) = mu(i,j-1) +mub(i,j-1) +! muv(i,j) = mu(i,j-1) +mub(i,j-1) ! fix for periodic b.c., 13 march 2004, wcs muv(i,j) = 0.5*(mu(i,j-1)+mu(i,jm)+mub(i,j-1)+mub(i,jm)) ENDDO @@ -5140,7 +5140,9 @@ SUBROUTINE phy_prep ( config_flags, & ! input ( config_flags%cu_physics == GFSCHEME ) .OR. & ( config_flags%cu_physics == G3SCHEME ) .OR. & ( config_flags%cu_physics == KFETASCHEME ) .OR. & - ( config_flags%cu_physics == TIEDTKESCHEME ) ) then ! Tiedtke ZCX&YQW + ( config_flags%cu_physics == MSKFSCHEME ) .OR. & + ( config_flags%cu_physics == TIEDTKESCHEME ) .OR. & + ( config_flags%cu_physics == NTIEDTKESCHEME )) then ! Tiedtke ZCX&YQW DO J=j_start,j_end DO I=i_start,i_end @@ -5226,6 +5228,8 @@ SUBROUTINE moist_physics_prep_em( t_new, t_old, t0, rho, al, alb, & th_phy, pii, pf, & z, z_at_w, dz8w, & dt,h_diabatic, & + qv,qv_diabatic, & + qc,qc_diabatic, & config_flags,fzm, fzp, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -5250,7 +5254,9 @@ SUBROUTINE moist_physics_prep_em( t_new, t_old, t0, rho, al, alb, & p, & pb, & ph, & - phb + phb, & + qv, & + qc REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & @@ -5266,8 +5272,10 @@ SUBROUTINE moist_physics_prep_em( t_new, t_old, t0, rho, al, alb, & dz8w, & p8w - REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & - INTENT(INOUT) :: h_diabatic + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: h_diabatic, & + qv_diabatic, & + qc_diabatic REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & INTENT(INOUT) :: t_new, & @@ -5335,6 +5343,8 @@ SUBROUTINE moist_physics_prep_em( t_new, t_old, t0, rho, al, alb, & #endif th_phy(i,k,j) = t_new(i,k,j) + t0 h_diabatic(i,k,j) = th_phy(i,k,j) + qv_diabatic(i,k,j) = qv(i,k,j) + qc_diabatic(i,k,j) = qc(i,k,j) rho(i,k,j) = 1./(al(i,k,j)+alb(i,k,j)) pii(i,k,j) = ((p(i,k,j)+pb(i,k,j))/p0)**rcp z(i,k,j) = 0.5*(z_at_w(i,k,j) +z_at_w(i,k+1,j) ) @@ -5388,6 +5398,8 @@ END SUBROUTINE moist_physics_prep_em SUBROUTINE moist_physics_finish_em( t_new, t_old, t0, mut, & th_phy, h_diabatic, dt, & + qv,qv_diabatic, & + qc,qc_diabatic, & config_flags, & #if ( WRF_DFI_RADAR == 1 ) dfi_tten_rad,dfi_stage, & @@ -5411,7 +5423,14 @@ SUBROUTINE moist_physics_finish_em( t_new, t_old, t0, mut, & INTENT(INOUT) :: t_new, & t_old, & th_phy, & - h_diabatic + h_diabatic, & + qv_diabatic, & + qc_diabatic + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(IN ) :: qv, & + qc + #if ( WRF_DFI_RADAR == 1 ) REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & INTENT(IN), OPTIONAL :: dfi_tten_rad @@ -5420,6 +5439,7 @@ SUBROUTINE moist_physics_finish_em( t_new, t_old, t0, mut, & #endif REAL mpten, mptenmax, mptenmin + REAL :: qvten,qcten REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: mut @@ -5473,6 +5493,8 @@ SUBROUTINE moist_physics_finish_em( t_new, t_old, t0, mut, & DO k = k_start, k_end DO i = i_start, i_end mpten = th_phy(i,k,j)-h_diabatic(i,k,j) + qvten = qv(i,k,j)-qv_diabatic(i,k,j) + qcten = qc(i,k,j)-qc_diabatic(i,k,j) if(mpten.gt.mptenmax) then mptenmax=mpten imax=i @@ -5507,6 +5529,11 @@ SUBROUTINE moist_physics_finish_em( t_new, t_old, t0, mut, & t_new(i,k,j) = t_new(i,k,j) + mpten #endif h_diabatic(i,k,j) = mpten/dt +!!! ! KLUDGE: +!!! qvten = 0.0 +!!! qcten = 0.0 + qv_diabatic(i,k,j) = qvten/dt + qc_diabatic(i,k,j) = qcten/dt ENDDO ENDDO ENDDO @@ -5518,6 +5545,8 @@ SUBROUTINE moist_physics_finish_em( t_new, t_old, t0, mut, & DO i = i_start, i_end ! t_new(i,k,j) = t_new(i,k,j) h_diabatic(i,k,j) = 0. + qv_diabatic(i,k,j) = 0. + qc_diabatic(i,k,j) = 0. ENDDO ENDDO ENDDO @@ -6221,8 +6250,109 @@ SUBROUTINE sixth_order_diffusion( name, field, tendency, mu, dt, & !------------------------------------------------------------------------------ END SUBROUTINE sixth_order_diffusion - + +!============================================================================== + +SUBROUTINE theta_to_thetam ( t_1 , moist_old , & + t_tendf , moist_tend , & + t_2 , moist , & + h_diabatic , & + itimestep , & + rk_step , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + its, ite, jts, jte, kts, kte ) + + ! Convert dry potential temperature to "moist" theta: + ! theta_m = theta ( 1 + Rv/Rd Qv ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: rk_step, itimestep + REAL , INTENT(IN ) , DIMENSION(ims:ime,kms:kme,jms:jme) :: moist, moist_tend + REAL , INTENT(INOUT) , DIMENSION(ims:ime,kms:kme,jms:jme) :: moist_old + REAL , INTENT(INOUT) , DIMENSION(ims:ime,kms:kme,jms:jme) :: t_1, t_tendf, t_2, h_diabatic + + ! Local variables + + INTEGER :: i , j , k + + ! First time step, there is no OLD moisture. + + IF ( ( itimestep .EQ. 1 ) .AND. ( rk_step .EQ. 1 ) ) THEN + DO j = jts , MIN(jte,jde-1) + DO k = kts , kte-1 + DO i = its , MIN(ite,ide-1) + moist_old(i,k,j) = moist(i,k,j) + END DO + END DO + END DO + END IF + + ! First RK loop, this info is from the physics packages. It is modified immediately after the + ! call to the physics schemes, and the remains constant for the remainder of the RK loops. + + IF ( rk_step .EQ. 1 ) THEN + DO j = jts , MIN(jte,jde-1) + DO k = kts , kte-1 + DO i = its , MIN(ite,ide-1) + t_tendf(i,k,j) = (1. + (R_v/R_d) * moist_old(i,k,j))*t_tendf(i,k,j) + (R_v/R_d)*(t_1(i,k,j)+T0)*moist_tend(i,k,j) + h_diabatic(i,k,j) = (1. + (R_v/R_d) * moist_old(i,k,j))*h_diabatic(i,k,j) + END DO + END DO + END DO + END IF + + ! T at time period 1 and 2 are modified in the small steps, so they are each converted from dry to moist. + + DO j = jts , MIN(jte,jde-1) + DO k = kts , kte-1 + DO i = its , MIN(ite,ide-1) + t_1(i,k,j) = t_1(i,k,j) * (1. + (R_v/R_d) * moist_old(i,k,j)) + T0*(R_v/R_d)*moist_old(i,k,j) + t_2(i,k,j) = t_2(i,k,j) * (1. + (R_v/R_d) * moist(i,k,j)) + T0*(R_v/R_d)*moist(i,k,j) + END DO + END DO + END DO + +END SUBROUTINE theta_to_thetam + !============================================================================== + +SUBROUTINE thetam_to_theta ( t_1 , moist_old , & + t_2 , moist , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + its, ite, jts, jte, kts, kte ) + + ! Convert moist potential temperature to dry theta: + ! theta = theta_m / ( 1 + Rv/Rd Qv ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + its, ite, jts, jte, kts, kte + REAL , INTENT(IN ) , DIMENSION(ims:ime,kms:kme,jms:jme) :: moist, moist_old + REAL , INTENT(INOUT) , DIMENSION(ims:ime,kms:kme,jms:jme) :: t_1, t_2 + + ! Local variables + + INTEGER :: i , j , k + + DO j = jts , MIN(jte,jde-1) + DO k = kts , kte-1 + DO i = its , MIN(ite,ide-1) + t_1(i,k,j) = -T0 + (t_1(i,k,j)+T0)/(1. + (R_v/R_d) * moist_old(i,k,j)) + t_2(i,k,j) = -T0 + (t_2(i,k,j)+T0)/(1. + (R_v/R_d) * moist(i,k,j)) + END DO + END DO + END DO + +END SUBROUTINE thetam_to_theta + !============================================================================== END MODULE module_big_step_utilities_em diff --git a/wrfv2_fire/dyn_em/module_diffusion_em.F b/wrfv2_fire/dyn_em/module_diffusion_em.F index 82357b13..f2850acc 100644 --- a/wrfv2_fire/dyn_em/module_diffusion_em.F +++ b/wrfv2_fire/dyn_em/module_diffusion_em.F @@ -1955,7 +1955,7 @@ SUBROUTINE smag2d_km( config_flags,xkmh,xkmv,xkhh,xkhv, & INTEGER :: i_start, i_end, j_start, j_end, ktf, i, j, k REAL :: deltas, tmp, pr, mlen_h, c_s - REAL :: dxm, dym, tmpzx, tmpzy, alpha + REAL :: dxm, dym, tmpzx, tmpzy, alpha, def_limit REAL, DIMENSION( its:ite , kts:kte , jts:jte ) :: def2 @@ -2006,14 +2006,20 @@ SUBROUTINE smag2d_km( config_flags,xkmh,xkmv,xkhh,xkhv, & xkhh(i,k,j)=xkmh(i,k,j)/pr xkhv(i,k,j)=0. IF(config_flags%diff_opt .EQ. 2)THEN -! jd: slope reduce by slope factor +! jd: reduce diffusion coefficient by slope factor (modified by JB August 2014) dxm=dx/msftx(i,j) dym=dy/msfty(i,j) - tmpzx = abs(0.25*( zx(i,k,j)+ zx(i+1,k,j ) + zx(i,k+1,j)+ zx(i+1,k+1,j ))*rdzw(i,k,j)*dxm) - tmpzy = abs(0.25*( zy(i,k,j)+ zy(i ,k,j+1) + zy(i,k+1,j)+ zy(i ,k+1,j+1))*rdzw(i,k,j)*dym) + tmpzx = (0.25*( abs(zx(i,k,j))+ abs(zx(i+1,k,j )) + abs(zx(i,k+1,j))+ abs(zx(i+1,k+1,j )))*rdzw(i,k,j)*dxm) + tmpzy = (0.25*( abs(zy(i,k,j))+ abs(zy(i ,k,j+1)) + abs(zy(i,k+1,j))+ abs(zy(i ,k+1,j+1)))*rdzw(i,k,j)*dym) alpha = max(sqrt(tmpzx*tmpzx+tmpzy*tmpzy),1.0) - xkmh(i,k,j)=xkmh(i,k,j)/alpha - xkhh(i,k,j)=xkhh(i,k,j)/alpha +! If deformation is large, further reduce the diffusion coefficient + def_limit = max(10./mlen_h,1.e-3) + if ( tmp .gt. def_limit ) then + xkmh(i,k,j)=xkmh(i,k,j)/(alpha*alpha) + else + xkmh(i,k,j)=xkmh(i,k,j)/(alpha) + endif + xkhh(i,k,j)=xkmh(i,k,j)/pr ENDIF ENDDO ENDDO @@ -2121,7 +2127,7 @@ SUBROUTINE tke_km( config_flags, xkmh, xkmv, xkhh, xkhv, & DO j = j_start, j_end DO k = kts+1, ktf-1 DO i = i_start, i_end - tmpdz = 1.0 / ( rdz(i,k+1,j) + rdz(i,k,j) ) + tmpdz = 1.0 / rdz(i,k+1,j) + 1.0 / rdz(i,k,j) dthrdn(i,k,j) = ( theta(i,k+1,j) - theta(i,k-1,j) ) / tmpdz END DO END DO @@ -2130,7 +2136,7 @@ SUBROUTINE tke_km( config_flags, xkmh, xkmv, xkhh, xkhv, & k = kts DO j = j_start, j_end DO i = i_start, i_end - tmpdz = 1.0 / ( rdzw(i,k+1,j) + rdzw(i,k,j) ) + tmpdz = 1.0 / rdzw(i,k+1,j) + 1.0 / rdzw(i,k,j) thetasfc = T8w(i,kts,j) / ( p8w(i,k,j) / p1000mb )**( R_d / Cp ) dthrdn(i,k,j) = ( theta(i,k+1,j) - thetasfc ) / tmpdz END DO @@ -3564,9 +3570,11 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & tao_xz=cd0*V0_u*u_2(i,kts,j) ru_tendf(i,kts,j)=ru_tendf(i,kts,j) & -0.25*(mu(i,j)+mu(i-1,j))*tao_xz*(rdzw(i,kts,j)+rdzw(i-1,kts,j)) + IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN + nba_mij(i,kts,j,P_m13) = -tao_xz + ENDIF ENDDO ENDDO - ! DO j = j_start, jte DO i = i_start, i_end @@ -3580,6 +3588,9 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & tao_yz=cd0*V0_v*v_2(i,kts,j) rv_tendf(i,kts,j)=rv_tendf(i,kts,j) & -0.25*(mu(i,j)+mu(i,j-1))*tao_yz*(rdzw(i,kts,j)+rdzw(i,kts,j-1)) + IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN + nba_mij(i,kts,j,P_m23) = -tao_yz + ENDIF ENDDO ENDDO @@ -3597,6 +3608,9 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & tao_xz=ustar*ustar*u_2(i,kts,j)/V0_u ru_tendf(i,kts,j)=ru_tendf(i,kts,j) & -0.25*(mu(i,j)+mu(i-1,j))*tao_xz*(rdzw(i,kts,j)+rdzw(i-1,kts,j)) + IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN + nba_mij(i,kts,j,P_m13) = -tao_xz + ENDIF ENDDO ENDDO @@ -3613,6 +3627,9 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & tao_yz=ustar*ustar*v_2(i,kts,j)/V0_v rv_tendf(i,kts,j)=rv_tendf(i,kts,j) & -0.25*(mu(i,j)+mu(i,j-1))*tao_yz*(rdzw(i,kts,j)+rdzw(i,kts,j-1)) + IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN + nba_mij(i,kts,j,P_m23) = -tao_yz + ENDIF ENDDO ENDDO @@ -5981,28 +5998,28 @@ SUBROUTINE compute_diff_metrics( config_flags, ph, phb, z, rdz, rdzw, & ELSE IF ( jte == jde ) THEN - DO j=j_start, j_end DO k=1, ktf + DO i =i_start, i_end zy(i,k,jde) = rdy * ( phb(i,k,jde) - phb(i,k,jde-1) ) / g END DO END DO - DO j = j_start, j_end DO k = 1, ktf + DO i =i_start, i_end zy(i,k,jde) = zy(i,k,jde) + rdy * ( ph(i,k,jde) - ph(i,k,jde-1) ) / g END DO END DO END IF IF ( jts == jds ) THEN - DO j = j_start, j_end DO k = 1, ktf + DO i =i_start, i_end zy(i,k,jds) = rdy * ( phb(i,k,jds) - phb(i,k,jds-1) ) / g END DO END DO - DO j = j_start, j_end DO k = 1, ktf + DO i =i_start, i_end zy(i,k,jds) = zy(i,k,jds) + rdy * ( ph(i,k,jds) - ph(i,k,jds-1) ) / g END DO END DO diff --git a/wrfv2_fire/dyn_em/module_em.F b/wrfv2_fire/dyn_em/module_em.F index 88083f69..c3d7a890 100644 --- a/wrfv2_fire/dyn_em/module_em.F +++ b/wrfv2_fire/dyn_em/module_em.F @@ -15,8 +15,8 @@ MODULE module_em vertical_diffusion_v, vertical_diffusion, vertical_diffusion_3dmp, sixth_order_diffusion, rk_rayleigh_damp, & theta_relaxation, vertical_diffusion_mp, zero_tend, zero_tend2d - USE module_state_description, only: param_first_scalar, p_qr, p_qv, p_qc, p_qg, p_qi, p_qs, tiedtkescheme, heldsuarez, & - positivedef, gdscheme, g3scheme, gfscheme, kfetascheme, monotonic, wenopd_scalar, weno_scalar, weno_mom + USE module_state_description, only: param_first_scalar, p_qr, p_qv, p_qc, p_qg, p_qi, p_qs, tiedtkescheme,ntiedtkescheme, heldsuarez, & + positivedef, gdscheme, g3scheme, gfscheme, kfetascheme, mskfscheme, monotonic, wenopd_scalar, weno_scalar, weno_mom USE module_damping_em, only: held_suarez_damp @@ -494,7 +494,8 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & IF ( config_flags%cu_physics == GDSCHEME .OR. & config_flags%cu_physics == GFSCHEME .OR. & - config_flags%cu_physics == G3SCHEME ) THEN + config_flags%cu_physics == G3SCHEME .OR. & + config_flags%cu_physics == NTIEDTKESCHEME ) THEN ! NTiedtke ! theta advection only: @@ -1063,8 +1064,8 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & IF((config_flags%cu_physics == GDSCHEME .OR. config_flags%cu_physics == G3SCHEME .OR. & config_flags%cu_physics == GFSCHEME .OR. & - config_flags%cu_physics == KFETASCHEME .OR. & ! new trigger in KF - config_flags%cu_physics == TIEDTKESCHEME ) & ! Tiedtke + config_flags%cu_physics == KFETASCHEME .OR. config_flags%cu_physics == MSKFSCHEME .OR. & + config_flags%cu_physics == TIEDTKESCHEME .OR. config_flags%cu_physics == NTIEDTKESCHEME ) & ! Tiedtke .and. moist_step .and. ( im == P_QV) ) THEN CALL set_tend( RQVFTEN, advect_tend, msfty, & @@ -1130,6 +1131,145 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & END SUBROUTINE rk_scalar_tend +!------------------------------------------------------------------------------- + +SUBROUTINE q_diabatic_add ( scs, sce, & + dt, mu, & + qv_diabatic, qc_diabatic, & + scalar_tends, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data. + + INTEGER , INTENT(IN ) :: scs, sce + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: mu + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: qv_diabatic, qc_diabatic + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce ), & + INTENT(INOUT) :: scalar_tends + + REAL , INTENT(IN ) :: dt + + ! Local data + + INTEGER :: im, i,j,k + +! +! +! + +!!! print *,' q_diab add: ' +!!! print *,its,MIN(ite,ide-1) +!!! print *,jts,MIN(jte,jde-1) +!!! print *,kts,kte-1 + + scalar_loop : DO im = scs, sce + + IF( im.eq.p_qv )THEN +!!! print *,' qv ' + DO j = jts,MIN(jte,jde-1) + DO k = kts,kte-1 + DO i = its,MIN(ite,ide-1) + scalar_tends(i,k,j,im) = scalar_tends(i,k,j,im) + qv_diabatic(i,k,j)*mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + IF( im.eq.p_qc )THEN +!!! print *,' qc ' + DO j = jts,MIN(jte,jde-1) + DO k = kts,kte-1 + DO i = its,MIN(ite,ide-1) + scalar_tends(i,k,j,im) = scalar_tends(i,k,j,im) + qc_diabatic(i,k,j)*mu(I,J) + ENDDO + ENDDO + ENDDO + ENDIF + + END DO scalar_loop + +END SUBROUTINE q_diabatic_add + +!------------------------------------------------------------------------------- + +SUBROUTINE q_diabatic_subtr( scs, sce, & + dt, & + qv_diabatic, qc_diabatic, & + scalar, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IMPLICIT NONE + + ! Input data. + + INTEGER , INTENT(IN ) :: scs, sce + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: qv_diabatic, qc_diabatic + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme , scs:sce ), & + INTENT(INOUT) :: scalar + + REAL , INTENT(IN ) :: dt + + ! Local data + + INTEGER :: im, i,j,k + +! +! +! + + +!!! print *,' q_diab subtr, dt = : ',dt +!!! print *,its,MIN(ite,ide-1) +!!! print *,jts,MIN(jte,jde-1) +!!! print *,kts,kte-1 + + scalar_loop : DO im = scs, sce + + IF( im.eq.p_qv )THEN +!!! print *,' qv ' + DO j = jts,MIN(jte,jde-1) + DO k = kts,kte-1 + DO i = its,MIN(ite,ide-1) + scalar(i,k,j,im) = scalar(i,k,j,im) - dt*qv_diabatic(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + IF( im.eq.p_qc )THEN +!!! print *,' qc ' + DO j = jts,MIN(jte,jde-1) + DO k = kts,kte-1 + DO i = its,MIN(ite,ide-1) + scalar(i,k,j,im) = scalar(i,k,j,im) - dt*qc_diabatic(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + + END DO scalar_loop + +END SUBROUTINE q_diabatic_subtr + + !------------------------------------------------------------------------------- SUBROUTINE rk_update_scalar( scs, sce, & @@ -2109,8 +2249,8 @@ subroutine trajectory ( grid,config_flags, & REAL , DIMENSION( ims:ime , jms:jme ) , & INTENT(IN ) ::xlong, xlat - real, dimension(kms:kme), intent(inout) :: traj_i,traj_j,traj_k - real, dimension(kms:kme), intent(inout) :: traj_long,traj_lat + real, dimension(1:config_flags%num_traj), intent(inout) :: traj_i,traj_j,traj_k + real, dimension(1:config_flags%num_traj), intent(inout) :: traj_long,traj_lat real, dimension(ims:ime,kms:kme,jms:jme),intent(in) :: rdzw real, dimension(ims:ime,kms:kme,jms:jme)::u,v,w real, dimension(ims:ime,jms:jme),intent(in)::msft,msfu,msfv diff --git a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F index 32660ec2..4e13b087 100644 --- a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F +++ b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F @@ -48,7 +48,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & USE module_force_scm USE module_convtrans_prep USE module_big_step_utilities_em, ONLY : phy_prep -use module_scalar_tables +!use module_scalar_tables #ifdef DM_PARALLEL USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, wrf_dm_maxval USE module_comm_dm, ONLY : halo_em_phys_a_sub,halo_em_fdda_sfc_sub,halo_pwp_sub,halo_em_chem_e_3_sub, & @@ -118,6 +118,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & REAL, DIMENSION( ims:ime, jms:jme ) :: exch_temf ! 1/7/09 WA REAL, DIMENSION( ims:ime, jms:jme ) :: ht_loc, mixht + INTEGER :: ij INTEGER num_roof_layers INTEGER num_wall_layers @@ -254,7 +255,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & BENCH_START(rad_driver_tim) CALL radiation_driver( & - & ACFRCV=grid%acfrcv ,ACFRST=grid%acfrst ,ALBEDO=grid%albedo & + & p_top=grid%p_top & !DJW 140312 added p_top for vertical nesting + & ,ACFRCV=grid%acfrcv ,ACFRST=grid%acfrst ,ALBEDO=grid%albedo & & ,CFRACH=grid%cfrach ,CFRACL=grid%cfracl ,CFRACM=grid%cfracm & & ,CUPPT=grid%cuppt ,CZMEAN=grid%czmean ,DT=grid%dt & & ,DZ8W=dz8w ,EMISS=grid%emiss ,GLW=grid%glw & @@ -322,6 +324,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & , TSWDN=grid%tswdn, TSWUP=grid%tswup & ! goddard schemes & , SSWDN=grid%sswdn, SSWUP=grid%sswup & ! goddard schemes !JJS 20101020 ^^^^^ +!ZCX+ cloud fraction for CLWRF + & , CLDT=grid%cldt, ZNU=grid%znu & +!ZCX- & , CLDFRA=grid%cldfra, CLDFRA_MP_ALL=grid%cldfra_mp_all & & , LRADIUS=grid%LRADIUS,IRADIUS=grid%IRADIUS & !BSINGH(01/22/2014) & , CLDFRA_DP=grid%cldfra_dp & ! ckay for subgrid cloud @@ -364,7 +369,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,RADTACTTIME=grid%radtacttime & & ,ICLOUD_CU=config_flags%ICLOUD_CU & & ,QC_CU=grid%QC_CU , QI_CU=grid%QI_CU & -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) & ,AER_RA_FEEDBACK=config_flags%aer_ra_feedback & & ,PM2_5_DRY=grid%pm2_5_dry, PM2_5_WATER=grid%pm2_5_water & & ,PM2_5_DRY_EC=grid%pm2_5_dry_ec & @@ -384,6 +389,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & #endif & ,slope_rad=config_flags%slope_rad,topo_shading=config_flags%topo_shading & & ,shadowmask=grid%shadowmask,ht=grid%ht,dx=grid%dx,dy=grid%dy & + & ,diffuse_frac=grid%diffuse_frac & & ,IS_CAMMGMP_USED = grid%is_CAMMGMP_used ) BENCH_END(rad_driver_tim) @@ -494,9 +500,11 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,USTM=grid%ustm ,CK=grid%ck ,CKA=grid%cka & & ,CD=grid%cd ,CDA=grid%cda & & ,ISFTCFLX=config_flags%isftcflx, IZ0TLND=config_flags%iz0tlnd & - & ,SF_OCEAN_PHYSICS=config_flags%sf_ocean_physics ,OML_HML0=config_flags%oml_hml0 ,OML_GAMMA=config_flags%oml_gamma & - & ,TML=grid%tml, T0ML=grid%t0ml, HML=grid%hml, H0ML=grid%h0ml, HUML=grid%huml, HVML=grid%hvml, F=grid%f & - & ,TMOML=grid%TMOML,ISWATER=iswater & + & ,SF_OCEAN_PHYSICS=config_flags%sf_ocean_physics & + & ,OML_HML0=config_flags%oml_hml0 ,OML_GAMMA=config_flags%oml_gamma & + & ,TML=grid%tml, T0ML=grid%t0ml, HML=grid%hml, H0ML=grid%h0ml & + & ,HUML=grid%huml, HVML=grid%hvml, F=grid%f & + & ,TMOML=grid%TMOML,ISWATER=iswater & & ,lakedepth2d=grid%lakedepth2d, savedtke12d=grid%savedtke12d & & ,snowdp2d=grid%snowdp2d, h2osno2d=grid%h2osno2d & !lake & ,snl2d=grid%snl2d, t_grnd2d=grid%t_grnd2d & @@ -508,41 +516,68 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,zi3d=grid%zi3d, watsat3d=grid%watsat3d & & ,csol3d=grid%csol3d, tkmg3d=grid%tkmg3d & !lake & ,tkdry3d=grid%tkdry3d, tksatu3d=grid%tksatu3d & - & ,LakeModel=grid%sf_lake_physics, lake_min_elev=grid%lake_min_elev & !lake + & ,LakeModel=grid%sf_lake_physics, lake_min_elev=grid%lake_min_elev & !lake #if ( EM_CORE == 1) - & ,LakeMask=grid%LakeMask & ! lake + & ,LakeMask=grid%LakeMask & ! lake #endif ! CLM Varaibles - & ,NUMC=grid%numc,NUMP=grid%nump,SABV=grid%sabv,SABG=grid%sabg,LWUP=grid%lwup,SNL=grid%snl, & - & HISTORY_INTERVAL=config_flags%history_interval , &!ylu add hist inverval for accumulation T max/min - & SNOWDP=grid%snowdp, WTC=grid%wtc,WTP=grid%wtp, H2OSNO=grid%h2osno,T_GRND=grid%t_grnd,T_VEG=grid%t_veg, & - & H2OCAN=grid%h2ocan, H2OCAN_COL=grid%h2ocan_col,T2M_MAX=grid%t2m_max,T2M_MIN=grid%t2m_min,T2CLM=grid%t2clm,& - & T_REF2M=grid%t_ref2m,H2OSOI_LIQ_S1=grid%h2osoi_liq_s1,H2OSOI_LIQ_S2=grid%h2osoi_liq_s2,& - & H2OSOI_LIQ_S3=grid%h2osoi_liq_s3,H2OSOI_LIQ_S4=grid%h2osoi_liq_s4, H2OSOI_LIQ_S5=grid%h2osoi_liq_s5, & - & H2OSOI_LIQ1=grid%h2osoi_liq1,H2OSOI_LIQ2=grid%h2osoi_liq2, H2OSOI_LIQ3=grid%h2osoi_liq3,H2OSOI_LIQ4=grid%h2osoi_liq4,& - & H2OSOI_LIQ5=grid%h2osoi_liq5,H2OSOI_LIQ6=grid%h2osoi_liq6,H2OSOI_LIQ7=grid%h2osoi_liq7,H2OSOI_LIQ8=grid%h2osoi_liq8,& - & H2OSOI_LIQ9=grid%h2osoi_liq9, H2OSOI_LIQ10=grid%h2osoi_liq10, H2OSOI_ICE_S1=grid%h2osoi_ice_s1,H2OSOI_ICE_S2=grid%h2osoi_ice_s2,& - & H2OSOI_ICE_S3=grid%h2osoi_ice_s3, H2OSOI_ICE_S4=grid%h2osoi_ice_s4, H2OSOI_ICE_S5=grid%h2osoi_ice_s5, & - & H2OSOI_ICE1=grid%h2osoi_ice1, H2OSOI_ICE2=grid%h2osoi_ice2, H2OSOI_ICE3=grid%h2osoi_ice3,H2OSOI_ICE4=grid%h2osoi_ice4,& - & H2OSOI_ICE5=grid%h2osoi_ice5, H2OSOI_ICE6=grid%h2osoi_ice6,H2OSOI_ICE7=grid%h2osoi_ice7,H2OSOI_ICE8=grid%h2osoi_ice8,& - & H2OSOI_ICE9=grid%h2osoi_ice9,H2OSOI_ICE10=grid%h2osoi_ice10,T_SOISNO_S1=grid%t_soisno_s1,T_SOISNO_S2=grid%t_soisno_s2, & - & T_SOISNO_S3=grid%t_soisno_s3,T_SOISNO_S4=grid%t_soisno_s4, T_SOISNO_S5=grid%t_soisno_s5,T_SOISNO1=grid%t_soisno1,& - & T_SOISNO2=grid%t_soisno2,T_SOISNO3=grid%t_soisno3,T_SOISNO4=grid%t_soisno4,T_SOISNO5=grid%t_soisno5, & - & T_SOISNO6=grid%t_soisno6,T_SOISNO7=grid%t_soisno7,T_SOISNO8=grid%t_soisno8,T_SOISNO9=grid%t_soisno9,& - & T_SOISNO10=grid%t_soisno10,DZSNOW1=grid%dzsnow1,DZSNOW2=grid%dzsnow2, DZSNOW3=grid%dzsnow3,DZSNOW4=grid%dzsnow4, DZSNOW5=grid%dzsnow5,& - & SNOWRDS1=grid%snowrds1,SNOWRDS2=grid%snowrds2,SNOWRDS3=grid%snowrds3 ,SNOWRDS4=grid%snowrds4,SNOWRDS5=grid%snowrds5, & - & T_LAKE1=grid%t_lake1,T_LAKE2=grid%t_lake2,T_LAKE3=grid%t_lake3,T_LAKE4=grid%t_lake4, & - & T_LAKE5=grid%t_lake5,T_LAKE6=grid%t_lake6, T_LAKE7=grid%t_lake7,T_LAKE8=grid%t_lake8, T_LAKE9=grid%t_lake9,T_LAKE10=grid%t_lake10, & - & H2OSOI_VOL1=grid%h2osoi_vol1,H2OSOI_VOL2=grid%h2osoi_vol2, H2OSOI_VOL3=grid%h2osoi_vol3,H2OSOI_VOL4=grid%h2osoi_vol4, H2OSOI_VOL5=grid%h2osoi_vol5,& - & H2OSOI_VOL6=grid%h2osoi_vol6,H2OSOI_VOL7=grid%h2osoi_vol7,H2OSOI_VOL8=grid%h2osoi_vol8,& - & H2OSOI_VOL9=grid%h2osoi_vol9,H2OSOI_VOL10=grid%h2osoi_vol10,MAXPATCH=config_flags%maxpatch,& - & INEST=grid%id,ALBEDOsubgrid=grid%ALBEDOsubgrid,LHsubgrid=grid%LHsubgrid,& - & HFXsubgrid=grid%HFXsubgrid,LWUPsubgrid=grid%LWUPsubgrid, Q2subgrid=grid%Q2subgrid,SABVsubgrid=grid%SABVsubgrid, & - & SABGsubgrid=grid%SABGsubgrid,NRAsubgrid=grid%NRAsubgrid, SWUPsubgrid=grid%SWUPsubgrid,LHsoi=grid%LHsoi, & - & LHveg=grid%LHveg, LHtran=grid%LHtran & -! end of CLM varaiblies + & ,NUMC=grid%numc,NUMP=grid%nump,SABV=grid%sabv,SABG=grid%sabg, & + & LWUP=grid%lwup,SNL=grid%snl, & + & HISTORY_INTERVAL=config_flags%history_interval , &!ylu add hist inverval for accumulation T max/min + & SNOWDP=grid%snowdp, WTC=grid%wtc,WTP=grid%wtp, H2OSNO=grid%h2osno, & + & T_GRND=grid%t_grnd,T_VEG=grid%t_veg, & + & H2OCAN=grid%h2ocan, H2OCAN_COL=grid%h2ocan_col,T2M_MAX=grid%t2m_max, & + & T2M_MIN=grid%t2m_min,T2CLM=grid%t2clm, & + & T_REF2M=grid%t_ref2m,H2OSOI_LIQ_S1=grid%h2osoi_liq_s1, & + & H2OSOI_LIQ_S2=grid%h2osoi_liq_s2, & + & H2OSOI_LIQ_S3=grid%h2osoi_liq_s3,H2OSOI_LIQ_S4=grid%h2osoi_liq_s4, & + & H2OSOI_LIQ_S5=grid%h2osoi_liq_s5, & + & H2OSOI_LIQ1=grid%h2osoi_liq1,H2OSOI_LIQ2=grid%h2osoi_liq2, & + & H2OSOI_LIQ3=grid%h2osoi_liq3,H2OSOI_LIQ4=grid%h2osoi_liq4, & + & H2OSOI_LIQ5=grid%h2osoi_liq5,H2OSOI_LIQ6=grid%h2osoi_liq6, & + & H2OSOI_LIQ7=grid%h2osoi_liq7,H2OSOI_LIQ8=grid%h2osoi_liq8, & + & H2OSOI_LIQ9=grid%h2osoi_liq9, H2OSOI_LIQ10=grid%h2osoi_liq10, & + & H2OSOI_ICE_S1=grid%h2osoi_ice_s1,H2OSOI_ICE_S2=grid%h2osoi_ice_s2, & + & H2OSOI_ICE_S3=grid%h2osoi_ice_s3, H2OSOI_ICE_S4=grid%h2osoi_ice_s4, & + & H2OSOI_ICE_S5=grid%h2osoi_ice_s5, & + & H2OSOI_ICE1=grid%h2osoi_ice1, H2OSOI_ICE2=grid%h2osoi_ice2, & + & H2OSOI_ICE3=grid%h2osoi_ice3,H2OSOI_ICE4=grid%h2osoi_ice4, & + & H2OSOI_ICE5=grid%h2osoi_ice5, H2OSOI_ICE6=grid%h2osoi_ice6, & + & H2OSOI_ICE7=grid%h2osoi_ice7,H2OSOI_ICE8=grid%h2osoi_ice8, & + & H2OSOI_ICE9=grid%h2osoi_ice9,H2OSOI_ICE10=grid%h2osoi_ice10, & + & T_SOISNO_S1=grid%t_soisno_s1,T_SOISNO_S2=grid%t_soisno_s2, & + & T_SOISNO_S3=grid%t_soisno_s3,T_SOISNO_S4=grid%t_soisno_s4, & + & T_SOISNO_S5=grid%t_soisno_s5,T_SOISNO1=grid%t_soisno1, & + & T_SOISNO2=grid%t_soisno2,T_SOISNO3=grid%t_soisno3, & + & T_SOISNO4=grid%t_soisno4,T_SOISNO5=grid%t_soisno5, & + & T_SOISNO6=grid%t_soisno6,T_SOISNO7=grid%t_soisno7, & + & T_SOISNO8=grid%t_soisno8,T_SOISNO9=grid%t_soisno9, & + & T_SOISNO10=grid%t_soisno10,DZSNOW1=grid%dzsnow1,DZSNOW2=grid%dzsnow2,& + & DZSNOW3=grid%dzsnow3,DZSNOW4=grid%dzsnow4, DZSNOW5=grid%dzsnow5, & + & SNOWRDS1=grid%snowrds1,SNOWRDS2=grid%snowrds2, & + & SNOWRDS3=grid%snowrds3 ,SNOWRDS4=grid%snowrds4, & + & SNOWRDS5=grid%snowrds5, & + & T_LAKE1=grid%t_lake1,T_LAKE2=grid%t_lake2,T_LAKE3=grid%t_lake3, & + & T_LAKE4=grid%t_lake4, & + & T_LAKE5=grid%t_lake5,T_LAKE6=grid%t_lake6, T_LAKE7=grid%t_lake7, & + & T_LAKE8=grid%t_lake8, T_LAKE9=grid%t_lake9,T_LAKE10=grid%t_lake10, & + & H2OSOI_VOL1=grid%h2osoi_vol1,H2OSOI_VOL2=grid%h2osoi_vol2, & + & H2OSOI_VOL3=grid%h2osoi_vol3,H2OSOI_VOL4=grid%h2osoi_vol4, & + & H2OSOI_VOL5=grid%h2osoi_vol5, & + & H2OSOI_VOL6=grid%h2osoi_vol6,H2OSOI_VOL7=grid%h2osoi_vol7, & + & H2OSOI_VOL8=grid%h2osoi_vol8, & + & H2OSOI_VOL9=grid%h2osoi_vol9,H2OSOI_VOL10=grid%h2osoi_vol10, & + & MAXPATCH=config_flags%maxpatch, & + & INEST=grid%id,ALBEDOsubgrid=grid%ALBEDOsubgrid, & + & LHsubgrid=grid%LHsubgrid, & + & HFXsubgrid=grid%HFXsubgrid,LWUPsubgrid=grid%LWUPsubgrid, & + & Q2subgrid=grid%Q2subgrid,SABVsubgrid=grid%SABVsubgrid, & + & SABGsubgrid=grid%SABGsubgrid,NRAsubgrid=grid%NRAsubgrid, & + & SWUPsubgrid=grid%SWUPsubgrid,LHsoi=grid%LHsoi, & + & LHveg=grid%LHveg, LHtran=grid%LHtran & +! end of CLM variables & ,SLOPE_RAD=config_flags%slope_rad,TOPO_SHADING=config_flags%topo_shading & ! solar - & ,SHADOWMASK=grid%shadowmask & ! solar + & ,SHADOWMASK=grid%shadowmask,DIFFUSE_FRAC=grid%diffuse_frac & ! solar & ,SLOPE=grid%slope, SLP_AZI=grid%slp_azi, SWNORM=grid%swnorm & ! solar & ,DECLIN=grid%declin ,SOLCON=grid%solcon ,COSZEN=grid%coszen ,HRANG=grid%hrang & & ,xlat_urb2d=grid%XLAT & !I urban @@ -558,6 +593,14 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,XXXB_URB2D=grid%xxxb_urb2d & !H urban & ,XXXG_URB2D=grid%xxxg_urb2d & & ,XXXC_URB2D=grid%xxxc_urb2d & !H urban + & ,CMCR_URB2D=grid%cmcr_urb2d,TGR_URB2D=grid%tgr_urb2d & !H urban + & ,TGRL_URB3D=grid%tgrl_urb3d,SMR_URB3D=grid%smr_urb3d & !H urban + & ,JULIAN=grid%julday, JULYR=grid%julyr & !I urban + & ,DRELR_URB2D=grid%drelr_urb2d,DRELB_URB2D=grid%drelb_urb2d & !H urban + & ,DRELG_URB2D=grid%drelg_urb2d & !H urban + & ,FLXHUMR_URB2D=grid%flxhumr_urb2d & !H urban + & ,FLXHUMB_URB2D=grid%flxhumb_urb2d & !H urban + & ,FLXHUMG_URB2D=grid%flxhumg_urb2d & !H urban & ,TRL_URB3D=grid%trl_urb3d ,TBL_URB3D=grid%tbl_urb3d & !H urban & ,TGL_URB3D=grid%tgl_urb3d & !H urban & ,SH_URB2D=grid%sh_urb2d ,LH_URB2D=grid%lh_urb2d & @@ -589,7 +632,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,LP_URB2D=grid%lp_urb2d,HI_URB2D=grid%hi_urb2d & !multi-layer urban & ,LB_URB2D=grid%lb_urb2d,HGT_URB2D=grid%hgt_urb2d & !multi-layer urban & ,MH_URB2D=grid%mh_urb2d,STDH_URB2D=grid%stdh_urb2d & !SLUCM - & ,LF_URB2D=grid%lf_urb2d + & ,LF_URB2D=grid%lf_urb2d & & ,GMT=grid%gmt,XLAT=grid%xlat,XLONG=grid%xlong,JULDAY=grid%julday & & ,A_U_BEP=grid%a_u_bep,A_V_BEP=grid%a_v_bep,A_T_BEP=grid%a_t_bep & & ,A_Q_BEP=grid%a_q_bep & @@ -600,11 +643,13 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,DL_U_BEP=grid%dl_u_bep & & ,CMR_SFCDIF=grid%cmr_sfcdif, CHR_SFCDIF=grid%chr_sfcdif & !I/O urban & ,CMC_SFCDIF=grid%cmc_sfcdif, CHC_SFCDIF=grid%chc_sfcdif & !I/O urban + & ,CMGR_SFCDIF=grid%cmgr_sfcdif, CHGR_SFCDIF=grid%chgr_sfcdif & !I/O urban ! P-X LSM Variables & ,LANDUSEF=grid%landusef, SOILCTOP=grid%soilctop & ! P-X LSM & ,SOILCBOT=grid%soilcbot & ! P-X LSM - & ,RA=grid%ra, RS=grid%rs, LAI=grid%lai & ! P-X LSM - & ,NLCAT=grid%num_land_cat, NSCAT=grid%num_soil_cat & ! P-X LSM + & ,RA=grid%ra, RS=grid%rs, LAI=grid%lai, IMPERV=grid%imperv & ! P-X LSM + & ,CANFRA=grid%canfra, NLCAT=grid%num_land_cat & ! P-X LSM + & ,NSCAT=grid%num_soil_cat & ! P-X LSM & ,VEGF_PX=grid%vegf_px, SNOWNCV=grid%snowncv & ! P-X LSM & ,ANAL_INTERVAL=config_flags%auxinput9_interval_s+config_flags%auxinput9_interval_m*60 & ! P-X LSM & ,PXLSM_SMOIS_INIT=config_flags%pxlsm_smois_init & ! P-X LSM @@ -719,11 +764,14 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,CAPG=grid%capg, EMISS=grid%emiss, HOL=hol,MOL=grid%mol & & ,T2OBS=grid%t2obs, Q2OBS=grid%q2obs & & ,RAINBL=grid%rainbl,SR=grid%sr,RAINSHV=grid%rainshv & + & ,GRAUPELNCV=grid%graupelncv, HAILNCV=grid%hailncv & & ,RAINNCV=grid%rainncv,REGIME=grid%regime,T2=grid%t2,THC=grid%thc & & ,QSG=grid%qsg,QVG=grid%qvg,QCG=grid%qcg,SOILT1=grid%soilt1,TSNAV=grid%tsnav & ! ruc lsm & ,SMFR3D=grid%smfr3d,KEEPFR3DFLAG=grid%keepfr3dflag,DEW=grid%dew & ! ruc lsm & ,POTEVP=grid%POTEVP, SNOPCX=grid%SNOPCX, SOILTB=grid%SOILTB & ! ruc lsm - & ,MOSAIC_LU=config_flags%mosaic_lu & ! RUC LSM + & ,rhosnf=grid%rhosnf ,precipfr=grid%precipfr & ! RUC LSM + & ,snowfallac=grid%snowfallac & ! RUC LSM + & ,MOSAIC_LU=config_flags%mosaic_lu & ! RUC LSM & ,MOSAIC_SOIL=config_flags%mosaic_soil & ! RUC LSM & ,ISURBAN=isurban, MMINLU=TRIM(mminlu) & & ,SNOTIME = grid%SNOTIME & @@ -742,11 +790,17 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & , okms = 1, okme=config_flags%ocean_levels & ! cyl:3DPWP & ,rdx=grid%rdx, rdy=grid%rdy,msfu=grid%msfu,msfv=grid%msfv,msft=grid%msft &!cyl: 3DPWP & ,XTIME=grid%xtime,OM_TINI=grid%om_tini,OM_SINI=grid%om_sini,id=grid%id,omdt=config_flags%omdt &!cyl: 3DPWP - & ,sf_surface_mosaic=config_flags%sf_surface_mosaic, mosaic_cat=config_flags%mosaic_cat, mosaic_cat_index=grid%mosaic_cat_index & !danli mosaic - & ,landusef2=grid%landusef2,TSK_mosaic=grid%TSK_mosaic,QSFC_mosaic=grid%QSFC_mosaic, TSLB_mosaic=grid%TSLB_mosaic,SMOIS_mosaic=grid%SMOIS_mosaic,SH2O_mosaic=grid%SH2O_mosaic & !danli mosaic - & ,CANWAT_mosaic=grid%CANWAT_mosaic,SNOW_mosaic=grid%SNOW_mosaic,SNOWH_mosaic=grid%SNOWH_mosaic,SNOWC_mosaic=grid%SNOWC_mosaic & !danli mosaic - & ,ALBEDO_mosaic=grid%ALBEDO_mosaic,ALBBCK_mosaic=grid%ALBBCK_mosaic, EMISS_mosaic=grid%EMISS_mosaic, EMBCK_mosaic=grid%EMBCK_mosaic, ZNT_mosaic=grid%ZNT_mosaic, Z0_mosaic=grid%Z0_mosaic & !danli mosaic - & ,HFX_mosaic=grid%HFX_mosaic,QFX_mosaic=grid%QFX_mosaic, LH_mosaic=grid%LH_mosaic, GRDFLX_mosaic=grid%GRDFLX_mosaic,SNOTIME_mosaic=grid%SNOTIME_mosaic & !danli mosaic + & ,sf_surface_mosaic=config_flags%sf_surface_mosaic, mosaic_cat=config_flags%mosaic_cat & + & ,mosaic_cat_index=grid%mosaic_cat_index & !danli mosaic + & ,landusef2=grid%landusef2,TSK_mosaic=grid%TSK_mosaic,QSFC_mosaic=grid%QSFC_mosaic & + & ,TSLB_mosaic=grid%TSLB_mosaic,SMOIS_mosaic=grid%SMOIS_mosaic,SH2O_mosaic=grid%SH2O_mosaic & !danli mosaic + & ,CANWAT_mosaic=grid%CANWAT_mosaic,SNOW_mosaic=grid%SNOW_mosaic & + & ,SNOWH_mosaic=grid%SNOWH_mosaic,SNOWC_mosaic=grid%SNOWC_mosaic & !danli mosaic + & ,ALBEDO_mosaic=grid%ALBEDO_mosaic,ALBBCK_mosaic=grid%ALBBCK_mosaic & + & ,EMISS_mosaic=grid%EMISS_mosaic, EMBCK_mosaic=grid%EMBCK_mosaic & + & ,ZNT_mosaic=grid%ZNT_mosaic, Z0_mosaic=grid%Z0_mosaic & !danli mosaic + & ,HFX_mosaic=grid%HFX_mosaic,QFX_mosaic=grid%QFX_mosaic, LH_mosaic=grid%LH_mosaic & + & ,GRDFLX_mosaic=grid%GRDFLX_mosaic,SNOTIME_mosaic=grid%SNOTIME_mosaic & !danli mosaic & ,TR_URB2D_mosaic=grid%TR_URB2D_mosaic,TB_URB2D_mosaic=grid%TB_URB2D_mosaic & !danli mosaic & ,TG_URB2D_mosaic=grid%TG_URB2D_mosaic,TC_URB2D_mosaic=grid%TC_URB2D_mosaic & !danli mosaic & ,QC_URB2D_mosaic=grid%QC_URB2D_mosaic,UC_URB2D_mosaic=grid%UC_URB2D_mosaic & !danli mosaic @@ -756,7 +810,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,G_URB2D_mosaic=grid%G_URB2D_mosaic,RN_URB2D_mosaic=grid%RN_URB2D_mosaic & !danli mosaic & ,TS_URB2D_mosaic=grid%TS_URB2D_mosaic & !danli mosaic & ,TS_RUL2D_mosaic=grid%TS_RUL2D_mosaic & !danli mosaic - & ) + & ,ZOL=grid%ZOL ) #ifdef WRF_HYDRO if(HYDRO_dt .gt. 1 ) call wrf_drv_HYDRO(HYDRO_dt, grid, & @@ -778,7 +832,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,BLDT=grid%bldt, CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag & & ,BLDTACTTIME=grid%bldtacttime & & ,BR=br ,CHKLOWQ=chklowq ,CT=grid%ct & - & ,DT=grid%dt ,DX=grid%dx ,DZ8W=dz8w & + & ,DT=grid%dt ,DX=grid%dx ,DY=grid%dy & + & ,DZ8W=dz8w & & ,EXCH_H=grid%exch_h ,EXCH_M=grid%exch_m & & ,FM=grid%fm ,FHH=grid%fh & & ,F=grid%f ,GRDFLX=grid%grdflx & @@ -801,6 +856,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,WARM_RAIN=grid%warm_rain ,WSPD=wspd & & ,XICE=grid%xice ,XLAND=grid%xland ,Z=grid%z & & ,ZNT=grid%znt & + & ,ysu_topdown_pblmix=config_flags%ysu_topdown_pblmix & + & ,shinhong_tke_diag=config_flags%shinhong_tke_diag & ! paj: topo_wind & ,CTOPO=grid%ctopo,CTOPO2=grid%ctopo2 & ! variables added for BEP @@ -816,7 +873,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,SF_URBAN_PHYSICS=config_flags%sf_urban_physics & ! Bep changes end ! add tke_pbl, and turbulent fluxes - & ,TKE_PBL=grid%tke_pbl,EL_PBL=grid%el_pbl,WU_TUR=grid%wu_tur,WV_tur=grid%wv_tur,WT_tur=grid%wt_tur,WQ_tur=grid%wq_tur & + & ,TKE_PBL=grid%tke_pbl,EL_PBL=grid%el_pbl,WU_TUR=grid%wu_tur & + & ,WV_tur=grid%wv_tur,WT_tur=grid%wt_tur,WQ_tur=grid%wq_tur & ! end add tke_pbl, and turbulent fluxes ! GBMPBL change: add exch_tke, rthraten & ,EXCH_TKE=grid%exch_tke, RTHRATEN=grid%rthraten & @@ -906,7 +964,6 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,NUM_VERT_MIX=grid%num_vert_mix & #endif & ) - BENCH_END(pbl_driver_tim) @@ -958,7 +1015,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,CUDTACTTIME=grid%cudtacttime & & ,RAINC=grid%rainc ,RAINCV=grid%raincv ,PRATEC=grid%pratec & & ,NCA=grid%nca & - & ,CLDFRA_DP=grid%cldfra_dp ,CLDFRA_SH=grid%cldfra_sh & ! ckay for subgrid cloud + & ,CLDFRA_DP=grid%cldfra_dp ,CLDFRA_SH=grid%cldfra_sh,W_UP=grid%w_up & ! ckay for subgrid cloud & ,QC_CU=grid%QC_CU ,QI_CU=grid%QI_CU & & ,HTOP=grid%cutop ,HBOT=grid%cubot ,KPBL=grid%kpbl & & ,Z=grid%z ,Z_AT_W=grid%z_at_w ,MAVAIL=grid%mavail ,PBLH=grid%pblh & @@ -982,6 +1039,37 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,CLDFRA=grid%cldfra,CLDFRA_MP_ALL=grid%cldfra_mp_all & & ,TPERT2D=grid%tpert2d & & ,GSW=grid%gsw,cugd_avedx=config_flags%cugd_avedx & + !BSINGH - For WRFCuP scheme + & ,AKPBL=grid%akpbl,BR=br, REGIME=grid%regime, T2=grid%t2, Q2=grid%q2 & !CuP, wig 3-Aug-2006 + & ,SLOPESFC=grid%slopeSfc, SLOPEEZ=grid%slopeEZ & !CuP, wig 7-Aug-2006 + & ,SIGMASFC=grid%sigmaSfc, SIGMAEZ=grid%sigmaEZ & !CuP, wig 7-Aug-2006 + & ,CUPFLAG=grid%cupflag & !CuP, wig 9-Oct-2006 + & ,CLDFRA_CUP=grid%cldfra_cup, CLDFRATEND_CUP=grid%cldfratend_cup & !CuP, wig 18-Sep-2006 + & ,SHALL=grid%shall, TAUCLOUD=grid%taucloud, TACTIVE=grid%tactive & !CuP, wig 18-Sep-2006 + & ,TSTAR=grid%tstar, LNTERMS=grid%lnterms, LNINT=grid%lnint & !CuP, wig 4-Oct-2006 + & ,ACTIVEFRAC=grid%activeFrac & !CuP, lkb + & ,NUMBINS=config_flags%numBins & !CuP, wig + & ,THBINSIZE=config_flags%thBinSize & !CuP, wig + & ,RBINSIZE=config_flags%rBinSize & !CuP, wig + & ,MINDEEPFREQ=config_flags%minDeepFreq & !CuP, wig + & ,MINSHALLOWFREQ=config_flags%minShallowFreq & !CuP, wig + & ,WCLOUDBASE=grid%wCloudBase & !CuP, lkb + & ,WACT_CUP=grid%wact_cup & !CuP, rce 25-aug-2011 + & ,WULCL_CUP=grid%wulcl_cup & !CuP, rce 23-jan-2012 + & ,WUP_CUP=grid%wup_cup & !CuP, rce 15-mar-2013 !BSINGH(12/05/2013) + & ,QC_IC_CUP=grid%qc_ic_cup & !CuP, rce 29-aug-2011 + & ,QNDROP_IC_CUP=grid%qndrop_ic_cup & !CuP, rce 29-aug-2011 + & ,QC_IU_CUP=grid%qc_iu_cup & !CuP, rce 08-feb-2012 + & ,FCVT_QC_TO_PR_CUP=grid%fcvt_qc_to_pr_cup & !CuP, rce 12-apr-2012 + & ,FCVT_QC_TO_QI_CUP=grid%fcvt_qc_to_qi_cup & !CuP, rce 12-apr-2012 + & ,FCVT_QI_TO_PR_CUP=grid%fcvt_qi_to_pr_cup & !CuP, rce 12-apr-2012 + & ,MFUP_CUP=grid%mfup_cup & !CuP, rce 23-jan-2012 + & ,MFUP_ENT_CUP=grid%mfup_ent_cup & !CuP, rce 23-jan-2012 + & ,MFDN_CUP=grid%mfdn_cup & !CuP, rce 12-apr-2012 + & ,MFDN_ENT_CUP=grid%mfdn_ent_cup & !CuP, rce 12-apr-2012 + & ,UPDFRA_CUP=grid%updfra_cup & !CuP, rce 23-jan-2012 + & ,TCLOUD_CUP=grid%tcloud_cup & !CuP, rce 06-feb-2012 + !BSINGH -ENDS & ,k22_shallow=grid%k22_shallow,kbcon_shallow=grid%kbcon_shallow & & ,ktop_shallow=grid%ktop_shallow,xmb_shallow=grid%xmb_shallow & & ,ktop_deep=grid%ktop_deep & @@ -1017,6 +1105,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,CU_PHYSICS=config_flags%cu_physics & & ,BL_PBL_PHYSICS=config_flags%bl_pbl_physics & & ,SF_SFCLAY_PHYSICS=config_flags%sf_sfclay_physics & + !BSINGH - For WRFCuP scheme + & ,SHCU_AEROSOLS_OPT=config_flags%shcu_aerosols_opt & !CuP, rce 22-aug-2011 + !BSINGH -ENDS & ,KFETA_TRIGGER=config_flags%kfeta_trigger & & ,NSAS_DX_FACTOR=config_flags%nsas_dx_factor & ! Dimension arguments @@ -1044,10 +1135,15 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,QI_CURR=moist(ims,kms,jms,P_QI), F_QI=F_QI & & ,QS_CURR=moist(ims,kms,jms,P_QS), F_QS=F_QS & & ,QG_CURR=moist(ims,kms,jms,P_QG), F_QG=F_QG & + & ,ZOL=grid%ZOL,WSTAR=grid%wstar_ysu & !ckay ! Variables for Tiedtke and NSAS schemes & ,ZNU=grid%znu & & ,MP_PHYSICS=config_flags%mp_physics & & ,GD_CLOUD=grid%GD_CLOUD,GD_CLOUD2=grid%GD_CLOUD2 & +#if (WRF_CHEM == 1) + & ,CHEM_OPT=config_flags%chem_opt & !CuP, rce 22-aug-2011 !BSINGH - For WRFCuP scheme +#endif + #if ( WRF_DFI_RADAR == 1 ) & ,DO_CAPSUPPRESS=do_capsupress & #endif @@ -1112,7 +1208,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,QG_CURR=moist(ims,kms,jms,P_QG) & & ,QNC_CURR=scalar(ims,kms,jms,P_QNC) & !BSINGH - Neede for UWSHCU scheme & ,QNI_CURR=scalar(ims,kms,jms,P_QNI) & !BSINGH - Neede for UWSHCU schem -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) & ,CHEM=chem,chem_opt=config_flags%chem_opt & #endif & ,DLF=grid%dlf, RLIQ=grid%rliq, RLIQ2=grid%rliq2 & @@ -1140,7 +1236,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,RAINCV=grid%raincv & & ) -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) #ifdef DM_PARALLEL IF( config_flags%shcu_physics == CAMUWSHCUSCHEME ) THEN CALL wrf_debug ( 200 , ' call HALO CHEM AFTER SHALLOW CUMULUS' ) diff --git a/wrfv2_fire/dyn_em/module_first_rk_step_part2.F b/wrfv2_fire/dyn_em/module_first_rk_step_part2.F index 162e9857..8f6bc7b7 100644 --- a/wrfv2_fire/dyn_em/module_first_rk_step_part2.F +++ b/wrfv2_fire/dyn_em/module_first_rk_step_part2.F @@ -57,8 +57,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & USE module_physics_addtendc, ONLY : update_phy_ten USE module_sfs_driver !JDM - USE module_stoch, ONLY : update_stoch_ten, update_stoch , calculate_stoch_ten, & - do_fftback_along_x,do_fftback_along_y,sp2gp_prep,perturb_physics_tend + USE module_stoch, ONLY : update_stoch_ten, perturb_physics_tend,RAND_PERT_UPDATE IMPLICIT NONE @@ -147,175 +146,102 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & rk_step = 1 - IF (grid%stoch_force_global_opt==1) then - - IF ( grid%id .EQ. 1 ) THEN - - !$OMP PARALLEL DO & - !$OMP PRIVATE ( ij ) - DO ij = 1 , grid%num_tiles - - CALL UPDATE_STOCH(grid%SPSTREAMFORCS,grid%SPSTREAMFORCC, & - grid%SPTFORCS,grid%SPTFORCC, & - grid%SPT_AMP,grid%SPSTREAM_AMP, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - grid%i_start(ij), grid%i_end(ij), grid%j_start(ij), & - grid%j_end(ij), k_start, k_end ) - - call sp2gp_prep( & - grid%SPSTREAMFORCS,grid%SPSTREAMFORCC, & - grid%SPTFORCS,grid%SPTFORCC, & - grid%VERTSTRUCC,grid%VERTSTRUCS, & - grid%VERTAMPT,grid%VERTAMPUV, & - grid%RU_REAL,grid%RV_REAL,grid%RT_REAL, & - grid%RU_IMAG,grid%RV_IMAG,grid%RT_IMAG, & - grid%DX,grid%DY,grid%stoch_vertstruc_opt, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - grid%i_start(ij), grid%i_end(ij), grid%j_start(ij), & - grid%j_end(ij), k_start, k_end) - ENDDO - !$OMP END PARALLEL DO - -! Roll out into latitude bands and perform FFT along latitude bands -#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) -#include "XPOSE_STOCH_BACK_U_REAL_z2x.inc" -#include "XPOSE_STOCH_BACK_U_IMAG_z2x.inc" -#include "XPOSE_STOCH_BACK_V_REAL_z2x.inc" -#include "XPOSE_STOCH_BACK_V_IMAG_z2x.inc" -#include "XPOSE_STOCH_BACK_T_REAL_z2x.inc" -#include "XPOSE_STOCH_BACK_T_IMAG_z2x.inc" - - call do_fftback_along_x( & - grid%RU_REAL_xxx,grid%RU_IMAG_xxx,& - grid%RV_REAL_xxx,grid%RV_IMAG_xxx,& - grid%RT_REAL_xxx,grid%RT_IMAG_xxx,& - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & - imsx,imex,jmsx,jmex,kmsx,kmex, & - ipsx,ipex,jpsx,jpex,kpsx,kpex, & - imsy,imey,jmsy,jmey,kmsy,kmey, & - ipsy,ipey,jpsy,jpey,kpsy,kpey, & - k_start , k_end & - ) - -! Reassemble fields from latitude bands into 3D arrays -! reassemble field X_REAL and X_IMAG -#include "XPOSE_STOCH_BACK_U_REAL_x2z.inc" -#include "XPOSE_STOCH_BACK_U_IMAG_x2z.inc" -#include "XPOSE_STOCH_BACK_V_REAL_x2z.inc" -#include "XPOSE_STOCH_BACK_V_IMAG_x2z.inc" -#include "XPOSE_STOCH_BACK_T_REAL_x2z.inc" -#include "XPOSE_STOCH_BACK_T_IMAG_x2z.inc" - -! Roll out into longitude bands and perform FFT along longitude bands -#include "XPOSE_STOCH_BACK_U_REAL_z2y.inc" -#include "XPOSE_STOCH_BACK_U_IMAG_z2y.inc" -#include "XPOSE_STOCH_BACK_V_REAL_z2y.inc" -#include "XPOSE_STOCH_BACK_V_IMAG_z2y.inc" -#include "XPOSE_STOCH_BACK_T_REAL_z2y.inc" -#include "XPOSE_STOCH_BACK_T_IMAG_z2y.inc" - - call do_fftback_along_y( & - grid%RU_REAL_yyy,grid%RU_IMAG_yyy,& - grid%RV_REAL_yyy,grid%RV_IMAG_yyy,& - grid%RT_REAL_yyy,grid%RT_IMAG_yyy,& - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & - imsx,imex,jmsx,jmex,kmsx,kmex, & - ipsx,ipex,jpsx,jpex,kpsx,kpex, & - imsy,imey,jmsy,jmey,kmsy,kmey, & - ipsy,ipey,jpsy,jpey,kpsy,kpey, & - k_start , k_end & - ) - -! Reassemble fields from longitude bands into 3D arrays -#include "XPOSE_STOCH_BACK_U_REAL_y2z.inc" -#include "XPOSE_STOCH_BACK_U_IMAG_y2z.inc" -#include "XPOSE_STOCH_BACK_V_REAL_y2z.inc" -#include "XPOSE_STOCH_BACK_V_IMAG_y2z.inc" -#include "XPOSE_STOCH_BACK_T_REAL_y2z.inc" -#include "XPOSE_STOCH_BACK_T_IMAG_y2z.inc" - -#else - - call do_fftback_along_x( & - grid%RU_REAL,grid%RU_IMAG,& - grid%RV_REAL,grid%RV_IMAG,& - grid%RT_REAL,grid%RT_IMAG,& - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & - k_start , k_end & - ) - call do_fftback_along_y( & - grid%RU_REAL,grid%RU_IMAG,& - grid%RV_REAL,grid%RV_IMAG,& - grid%RT_REAL,grid%RT_IMAG,& - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & - k_start , k_end & - ) -#endif - - !$OMP PARALLEL DO & - !$OMP PRIVATE ( ij ) - DO ij = 1 , grid%num_tiles - CALL wrf_debug ( 200 , ' call update_stoch_ten' ) - CALL calculate_stoch_ten(ru_tendf, rv_tendf, t_tendf, & - grid%ru_tendf_stoch, & - grid%rv_tendf_stoch, & - grid%rt_tendf_stoch, & - grid%RU_REAL,grid%RV_REAL,grid%RT_REAL, & - grid%mu_2 , grid%mub, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - grid%i_start(ij), grid%i_end(ij), & - grid%j_start(ij), grid%j_end(ij), & - k_start, k_end, & - grid%dt) - - ENDDO - !$OMP END PARALLEL DO - END IF !grid%id==1 - ENDIF !toch_force_global_opt - - stoch_force_select: SELECT CASE(config_flags%stoch_force_opt) - - CASE (STOCH_BACKSCATTER) - - !$OMP PARALLEL DO & - !$OMP PRIVATE ( ij ) - DO ij = 1 , grid%num_tiles - CALL wrf_debug ( 200 , ' call update_stoch_ten' ) - CALL update_stoch_ten(ru_tendf, rv_tendf, t_tendf,& - grid%ru_tendf_stoch, & - grid%rv_tendf_stoch, & - grid%rt_tendf_stoch, & - grid%mu_2 , grid%mub, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - grid%i_start(ij), grid%i_end(ij), & - grid%j_start(ij), grid%j_end(ij), & - k_start, k_end, & - grid%dt ) - - ENDDO - !$OMP END PARALLEL DO - - END SELECT stoch_force_select + IF ((grid%skebs_on==1).and.(grid%id .EQ. 1 )) then + ! update and backtransform T + CALL RAND_PERT_UPDATE(grid,'T', & + grid%SPTFORCS,grid%SPTFORCC, & + grid%SPT_AMP,grid%ALPH_T, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + k_start, k_end, & + imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey, & + grid%num_stoch_levels,grid%num_stoch_levels, & + grid%num_stoch_levels,grid%num_stoch_levels, & + config_flags%restart, grid%iseedarr_skebs, & + grid%DX,grid%DY,grid%skebs_vertstruc, & + grid%rt_tendf_stoch, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPUV ) + ! Update streamfunction, backtransform U + CALL RAND_PERT_UPDATE(grid,'U', & + grid%SPSTREAMFORCS,grid%SPSTREAMFORCC, & + grid%SPSTREAM_AMP,grid%ALPH_PSI, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + k_start, k_end, & + imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey, & + grid% num_stoch_levels,grid% num_stoch_levels, & + grid% num_stoch_levels,grid% num_stoch_levels, & + config_flags%restart, grid%iseedarr_skebs, & + grid%DX,grid%DY,grid%skebs_vertstruc, & + grid%ru_tendf_stoch, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPUV ) + ! Don't update streamfunction, backtransform V + CALL RAND_PERT_UPDATE(grid,'V', & + grid%SPSTREAMFORCS,grid%SPSTREAMFORCC, & + grid%SPSTREAM_AMP,grid%ALPH_PSI, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + k_start, k_end, & + imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey, & + grid% num_stoch_levels,grid% num_stoch_levels, & + grid% num_stoch_levels,grid% num_stoch_levels, & + config_flags%restart, grid%iseedarr_skebs, & + grid%DX,grid%DY,grid%skebs_vertstruc, & + grid%rv_tendf_stoch, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT ) + ENDIF !skebs_on + + if ((grid%sppt_on==1).and.(grid%id .EQ. 1 )) then + CALL RAND_PERT_UPDATE(grid,'T', & + grid%SPPTFORCS,grid%SPPTFORCC, & + grid%SPPT_AMP,grid%ALPH_SPPT, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + k_start, k_end, & + imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey, & + grid%num_stoch_levels,grid%num_stoch_levels, & + grid%num_stoch_levels,grid%num_stoch_levels, & + config_flags%restart, grid%iseedarr_sppt, & + grid%DX,grid%DY,grid%sppt_vertstruc, & + grid%rstoch, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT ) + ENDIF !sppt_on + + if ((grid%rand_perturb_on==1).and.(grid%id .EQ. 1 )) then + CALL RAND_PERT_UPDATE(grid,'T', & + grid%SPFORCS,grid%SPFORCC, & + grid%SP_AMP,grid%ALPH_RAND, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + k_start, k_end, & + imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey, & + grid%num_stoch_levels,grid%num_stoch_levels, & + grid%num_stoch_levels,grid%num_stoch_levels, & + config_flags%restart, grid%iseedarr_rand_pert, & + grid%DX,grid%DY,grid%rand_pert_vertstruc, & + grid%RAND_PERT, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT ) + ENDIF !rand_perturb_on ! calculate_phy_tend @@ -627,6 +553,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & ENDIF IF ( config_flags%cu_physics == SASSCHEME .or. & config_flags%cu_physics == TIEDTKESCHEME .or. & + config_flags%cu_physics == NTIEDTKESCHEME .or. & config_flags%cu_physics == CAMZMSCHEME .or. & config_flags%cu_physics == MESO_SAS .or. & config_flags%cu_physics == NSASSCHEME ) THEN @@ -707,27 +634,44 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & !$OMP END PARALLEL DO BENCH_END(update_phy_ten_tim) - IF (grid%stoch_force_opt== 2) then - !CASE (PERTURB_TENDF) - !$OMP PARALLEL DO & - !$OMP PRIVATE ( ij ) - -! JB comment: P_QV is in moist_tend(ims,kms,jms,2) - DO ij = 1 , grid%num_tiles - call perturb_physics_tend(grid%gridpointvariance,& - grid%sppt_thresh_fact, grid%rt_tendf_stoch, & - ru_tendf,rv_tendf,t_tendf,moist_tend(ims,kms,jms,2), & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - grid%i_start(ij), grid%i_end(ij), & - grid%j_start(ij), grid%j_end(ij), & - k_start, k_end ) - END DO - !$OMP END PARALLEL DO - ENDIF -BENCH_END(update_phy_ten_stoch) + IF (grid%skebs_on==1) then + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + DO ij = 1 , grid%num_tiles + CALL wrf_debug ( 200 , ' call update_stoch_ten' ) + CALL update_stoch_ten(ru_tendf, rv_tendf, t_tendf,& + grid%ru_tendf_stoch, & + grid%rv_tendf_stoch, & + grid%rt_tendf_stoch, & + grid%mu_2 , grid%mub, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end, & + grid%num_stoch_levels,grid%num_stoch_levels ) + ENDDO + !$OMP END PARALLEL DO + ENDIF !skebs_on + IF (grid%sppt_on==1) then + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + ! JB comment: P_QV is in moist_tend(ims,kms,jms,2) + DO ij = 1 , grid%num_tiles + call perturb_physics_tend(grid%gridpt_stddev_sppt, & + grid%stddev_cutoff_sppt,grid%rstoch, & + ru_tendf,rv_tendf,t_tendf,moist_tend(ims,kms,jms,2), & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end, & + grid%num_stoch_levels,grid%num_stoch_levels ) + ENDDO + !$OMP END PARALLEL DO + ENDIF #ifdef PLANET ! do rayleigh (and zonal-average newtonian) damping during diff --git a/wrfv2_fire/dyn_em/module_initialize_convrad.F b/wrfv2_fire/dyn_em/module_initialize_convrad.F new file mode 100644 index 00000000..1ee67639 --- /dev/null +++ b/wrfv2_fire/dyn_em/module_initialize_convrad.F @@ -0,0 +1,810 @@ +!IDEAL:MODEL_LAYER:INITIALIZATION +! + +! This MODULE holds the routines which are used to perform various initializations +! for the individual domains. + +! This MODULE CONTAINS the following routines: + +! initialize_field_test - 1. Set different fields to different constant +! values. This is only a test. If the correct +! domain is not found (based upon the "id") +! then a fatal error is issued. + +!----------------------------------------------------------------------- + +MODULE module_initialize_ideal + + USE module_domain + USE module_io_domain + USE module_state_description + USE module_model_constants + USE module_bc + USE module_timing + USE module_configure + USE module_init_utilities + USE module_soil_pre +#ifdef DM_PARALLEL + USE module_dm +#endif + + +CONTAINS + + +!------------------------------------------------------------------- +! this is a wrapper for the solver-specific init_domain routines. +! Also dereferences the grid variables and passes them down as arguments. +! This is crucial, since the lower level routines may do message passing +! and this will get fouled up on machines that insist on passing down +! copies of assumed-shape arrays (by passing down as arguments, the +! data are treated as assumed-size -- ie. f77 -- arrays and the copying +! business is avoided). Fie on the F90 designers. Fie and a pox. +! NOTE: Modified to remove all but arrays of rank 4 or more from the +! argument list. Arrays with rank>3 are still problematic due to the +! above-noted fie- and pox-ities. TBH 20061129. + + SUBROUTINE init_domain ( grid ) + + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + ! Local data. + INTEGER :: idum1, idum2 + + CALL set_scalar_indices_from_config ( head_grid%id , idum1, idum2 ) + + CALL init_domain_rk( grid & +! +#include +! + ) + END SUBROUTINE init_domain + +!------------------------------------------------------------------- + + SUBROUTINE init_domain_rk ( grid & +! +# include +! +) + IMPLICIT NONE + + ! Input data. + TYPE (domain), POINTER :: grid + +# include + + TYPE (grid_config_rec_type) :: config_flags + + ! Local data + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + i, j, k + + INTEGER, PARAMETER :: nl_max = 1000 + REAL, DIMENSION(nl_max) :: zk, p_in, theta, rho, u, v, qv, pd_in + INTEGER :: nl_in + + INTEGER :: icm,jcm, ii, im1, jj, jm1, loop, error, fid, nxc, nyc, lm + REAL :: u_mean,v_mean, f0, p_surf, p_level, qvf, z_at_v, z_at_u + REAL :: z_scale, xrad, yrad, zrad, rad, delt, cof1, cof2 +! REAL, EXTERNAL :: interp_0 + REAL :: pi, rnd + +! stuff from original initialization that has been dropped from the Registry + REAL :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd, zt + REAL :: qvf1, qvf2, pd_surf, theta_surf + INTEGER :: it + real :: thtmp, ptmp, temp(3) + + LOGICAL :: moisture_init + LOGICAL :: stretch_grid, dry_sounding + character (len=256) :: mminlu2 + +#ifdef DM_PARALLEL +# include +#endif + + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + + stretch_grid = .true. + delt = 1. +! z_scale = .50 + z_scale = .32 + pi = 2.*asin(1.0) + write(6,*) ' pi is ',pi + nxc = (ide-ids)/2 + nyc = jde/2 + icm = ide/2 +! lm is the half width of the land in terms of grid points + lm = 25 + write(6,*) 'lm,icm-lm,icm+lm = ', lm,icm-lm,icm+lm + + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + +! here we check to see if the boundary conditions are set properly + + CALL boundary_condition_check( config_flags, bdyzone, error, grid%id ) + + moisture_init = .true. + + grid%itimestep=0 + +#ifdef DM_PARALLEL + CALL wrf_dm_bcast_bytes( icm , IWORDSIZE ) + CALL wrf_dm_bcast_bytes( jcm , IWORDSIZE ) +#endif + + mminlu2 = ' ' + mminlu2(1:4) = 'USGS' + CALL nl_set_mminlu(1, mminlu2) +! CALL nl_set_mminlu(1, 'USGS') + CALL nl_set_iswater(1,16) + CALL nl_set_isice(1,3) + CALL nl_set_cen_lat(1,20.) + CALL nl_set_cen_lon(1,-105.) + CALL nl_set_truelat1(1,0.) + CALL nl_set_truelat2(1,0.) + CALL nl_set_moad_cen_lat (1,0.) + CALL nl_set_stand_lon (1,0.) + CALL nl_set_pole_lon (1,0.) + CALL nl_set_pole_lat (1,90.) + CALL nl_set_map_proj(1,0) +! CALL model_to_grid_config_rec(1,model_config_rec,config_flags) + CALL nl_get_iswater(1,grid%iswater) + +! here we initialize data that currently is not initialized +! in the input data + + DO j = jts, jte + DO i = its, ite + grid%msft(i,j) = 1. + grid%msfu(i,j) = 1. + grid%msfv(i,j) = 1. + grid%msftx(i,j) = 1. + grid%msfty(i,j) = 1. + grid%msfux(i,j) = 1. + grid%msfuy(i,j) = 1. + grid%msfvx(i,j) = 1. + grid%msfvy(i,j) = 1. + grid%msfvx_inv(i,j)= 1. + grid%sina(i,j) = 0. + grid%cosa(i,j) = 1. + grid%e(i,j) = 0. + grid%xlat(i,j) = 10. + grid%f(i,j) = 2.5e-5 + grid%xlong(i,j) = 0. +! Hard-wire the ocean-land configuration +! all ocean +! if (i .ge. (icm-lm) .and. i .lt. (icm+lm)) then +! grid%xland(i,j) = 1. +! grid%lu_index(i,j) = 18 +!else + grid%xland(i,j) = 2. + grid%lu_index(i,j) = 16 +!end if + END DO + END DO + +! for Noah LSM, additional variables need to be initialized + + other_masked_fields : SELECT CASE ( model_config_rec%sf_surface_physics(grid%id) ) + + CASE (SLABSCHEME) + + CASE (LSMSCHEME) + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF (grid%xland(i,j) .lt. 1.5) THEN + grid%vegfra(i,j) = 0.5 + grid%canwat(i,j) = 0. + grid%ivgtyp(i,j) = 18 + grid%isltyp(i,j) = 8 + grid%xice(i,j) = 0. + grid%snow(i,j) = 0. + ELSE + grid%vegfra(i,j) = 0. + grid%canwat(i,j) = 0. + grid%ivgtyp(i,j) = 16 + grid%isltyp(i,j) = 14 + grid%xice(i,j) = 0. + grid%snow(i,j) = 0. + ENDIF + END DO + END DO + + CASE (RUCLSMSCHEME) + + END SELECT other_masked_fields + + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + grid%ww(i,k,j) = 0. + END DO + END DO + END DO + + grid%step_number = 0 + +! Process the soil; note that there are some things hard-wired into share/module_soil_pre.F + CALL process_soil_ideal(grid%xland,grid%xice,grid%vegfra,grid%snow,grid%canwat, & + grid%ivgtyp,grid%isltyp,grid%tslb,grid%smois, & + grid%tsk,grid%tmn,grid%zs,grid%dzs,model_config_rec%num_soil_layers, & + model_config_rec%sf_surface_physics(grid%id), & + ids,ide, jds,jde, kds,kde,& + ims,ime, jms,jme, kms,kme,& + its,ite, jts,jte, kts,kte ) + +! set up the grid + + IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz) + DO k=1, kde +! grid%znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & +! (1.-exp(-1./z_scale)) +! read eta_levels from namelist (replace with commented code above if not) + grid%znw(k) = model_config_rec%eta_levels(k) + ENDDO + ELSE + DO k=1, kde + grid%znw(k) = 1. - float(k-1)/float(kde-1) + ENDDO + ENDIF + + DO k=1, kde-1 + grid%dnw(k) = grid%znw(k+1) - grid%znw(k) + grid%rdnw(k) = 1./grid%dnw(k) + grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) + ENDDO + DO k=2, kde-1 + grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) + grid%rdn(k) = 1./grid%dn(k) + grid%fnp(k) = .5* grid%dnw(k )/grid%dn(k) + grid%fnm(k) = .5* grid%dnw(k-1)/grid%dn(k) + ENDDO + + cof1 = (2.*grid%dn(2)+grid%dn(3))/(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(2) + cof2 = grid%dn(2) /(grid%dn(2)+grid%dn(3))*grid%dnw(1)/grid%dn(3) + grid%cf1 = grid%fnp(2) + cof1 + grid%cf2 = grid%fnm(2) - cof1 - cof2 + grid%cf3 = cof2 + + grid%cfn = (.5*grid%dnw(kde-1)+grid%dn(kde-1))/grid%dn(kde-1) + grid%cfn1 = -.5*grid%dnw(kde-1)/grid%dn(kde-1) + grid%rdx = 1./config_flags%dx + grid%rdy = 1./config_flags%dy + +! get the sounding from the ascii sounding file, first get dry sounding and +! calculate base state + + write(6,*) ' getting dry sounding for base state ' + dry_sounding = .true. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in, theta_surf ) + + write(6,*) ' returned from reading sounding, nl_in is ',nl_in + +! find ptop for the desired ztop (ztop is input from the namelist), +! and find surface pressure + + grid%p_top = interp_0( p_in, zk, config_flags%ztop, nl_in ) + + DO j=jts,jte + DO i=its,ite ! flat surface + grid%phb(i,1,j) = 0. + grid%php(i,1,j) = 0. + grid%ph0(i,1,j) = 0. + grid%ht(i,j) = 0. + ENDDO + ENDDO + + DO J = jts, jte + DO I = its, ite + + p_surf = interp_0( p_in, zk, grid%phb(i,1,j)/g, nl_in ) + grid%mub(i,j) = p_surf-grid%p_top + +! this is dry hydrostatic sounding (base state), so given grid%p (coordinate), +! interp theta (from interp) and compute 1/rho from eqn. of state + + DO K = 1, kte-1 + p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%pb(i,k,j) = p_level + grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0 + grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm + ENDDO + +! calc hydrostatic balance (alternatively we could interp the geopotential from the +! sounding, but this assures that the base state is in exact hydrostatic balance with +! respect to the model eqns. + + DO k = 2,kte + grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j) + ENDDO + + ENDDO + ENDDO + + write(6,*) ' ptop is ',grid%p_top + write(6,*) ' base state grid%mub(1,1), p_surf is ',grid%mub(1,1),grid%mub(1,1)+grid%p_top + +! calculate full state for each column - this includes moisture. + + write(6,*) ' getting moist sounding for full state ' + dry_sounding = .false. + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in, theta_surf ) + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + +! At this point grid%p_top is already set. find the DRY mass in the column +! by interpolating the DRY pressure. + + pd_surf = interp_0( pd_in, zk, grid%phb(i,1,j)/g, nl_in ) + +! compute the perturbation mass and the full mass + + grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j) + grid%mu_2(i,j) = grid%mu_1(i,j) + grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j) + +! given the dry pressure and coordinate system, interp the potential +! temperature and qv + + do k=1,kde-1 + + p_level = grid%znu(k)*(pd_surf - grid%p_top) + grid%p_top + + moist(i,k,j,P_QV) = interp_0( qv, pd_in, p_level, nl_in ) + grid%t_1(i,k,j) = interp_0( theta, pd_in, p_level, nl_in ) - t0 + grid%t_2(i,k,j) = grid%t_1(i,k,j) + + + enddo + +! integrate the hydrostatic equation (from the RHS of the bigstep +! vertical momentum equation) down from the top to get grid%p. +! first from the top of the model to the top pressure + + k = kte-1 ! top level + + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + +! grid%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k) + grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* & + (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) + grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + +! down the column + + do k=kte-2,1,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* & + (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) + grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + enddo + +! this is the hydrostatic equation used in the model after the +! small timesteps. In the model, grid%al (inverse density) +! is computed from the geopotential. + + + grid%ph_1(i,1,j) = 0. + DO k = 2,kte + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & + grid%mu_1(i,j)*grid%alb(i,k-1,j) ) + + grid%ph_2(i,k,j) = grid%ph_1(i,k,j) + grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j) + ENDDO + + if((i==2) .and. (j==2)) then + write(6,*) ' grid%ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),& + grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), & + grid%alb(2,1,2),grid%al(1,2,1),grid%rdnw(1) + endif + + ENDDO + ENDDO + + +! random low-level thermal perturbation to kick off convection + call random_seed + write(6,*) ' nxc, nyc for perturbation ',nxc,nyc + write(6,*) ' delt for perturbation ',delt + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + DO K = 1, 10 + + call RANDOM_NUMBER(rnd) + grid%t_1(i,k,j)=grid%t_1(i,k,j)+delt*(rnd-0.5) + ! grid%t_1(i,k,j)=grid%t_1(i,k,j)+delt*COS(.5*PI*RAD)**2 + grid%t_2(i,k,j)=grid%t_1(i,k,j) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* & + (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) + grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + ENDDO + +! rebalance hydrostatically + + DO k = 2,kte + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & + grid%mu_1(i,j)*grid%alb(i,k-1,j) ) + + grid%ph_2(i,k,j) = grid%ph_1(i,k,j) + grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j) + ENDDO + + ENDDO + ENDDO + + write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1) + write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1)+grid%phb(1,k,1), & + grid%p(1,k,1)+grid%pb(1,k,1), grid%alt(1,k,1), & + grid%t_1(1,k,1)+t0, moist(1,k,1,P_QV) + enddo + + write(6,*) ' pert state sounding from comp, grid%ph_1, pp, alp, grid%t_1, qv ' + do k=1,kde-1 + write(6,'(i3,1x,5(1x,1pe10.3))') k, grid%ph_1(1,k,1), & + grid%p(1,k,1), grid%al(1,k,1), & + grid%t_1(1,k,1), moist(1,k,1,P_QV) + enddo + +! interp v + + DO J = jts, jte + DO I = its, min(ide-1,ite) + + IF (j == jds) THEN + z_at_v = grid%phb(i,1,j)/g + ELSE IF (j == jde) THEN + z_at_v = grid%phb(i,1,j-1)/g + ELSE + z_at_v = 0.5*(grid%phb(i,1,j)+grid%phb(i,1,j-1))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_v, nl_in ) + + DO K = 1, kte + p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in ) + grid%v_2(i,k,j) = grid%v_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! interp u + + DO J = jts, min(jde-1,jte) + DO I = its, ite + + IF (i == ids) THEN + z_at_u = grid%phb(i,1,j)/g + ELSE IF (i == ide) THEN + z_at_u = grid%phb(i-1,1,j)/g + ELSE + z_at_u = 0.5*(grid%phb(i,1,j)+grid%phb(i-1,1,j))/g + END IF + + p_surf = interp_0( p_in, zk, z_at_u, nl_in ) + + DO K = 1, kte + p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in ) + grid%u_2(i,k,j) = grid%u_1(i,k,j) + ENDDO + + ENDDO + ENDDO + +! set w + + DO J = jts, min(jde-1,jte) + DO K = kts, kte + DO I = its, min(ide-1,ite) + grid%w_1(i,k,j) = 0. + grid%w_2(i,k,j) = 0. + ENDDO + ENDDO + ENDDO + +! set a few more things + + DO J = jts, min(jde-1,jte) + DO K = kts, kte-1 + DO I = its, min(ide-1,ite) + grid%h_diabatic(i,k,j) = 0. +! if(k.eq.kts)tracer(i,k,j,p_tr17_1)=1. +! if(k.eq.kts.and.grid%xland(i,j).lt.1.5)tracer(i,k,j,p_tr17_2)=1. +! if(k.eq.kts.and.grid%xland(i,j).gt.1.5)tracer(i,k,j,p_tr17_3)=1. +! if(k.le.5)tracer(i,k,j,p_tr17_4)=1. +! if(k.le.5.and.grid%xland(i,j).lt.1.5)tracer(i,k,j,p_tr17_5)=1. +! if(k.le.5.and.grid%xland(i,j).gt.1.5)tracer(i,k,j,p_tr17_6)=1. +! if(k.le.10)tracer(i,k,j,p_tr17_7)=1. +! if(k.le.10.and.k.gt.5)tracer(i,k,j,p_tr17_8)=1. + ENDDO + ENDDO + ENDDO + + DO k=1,kte-1 + grid%t_base(k) = grid%t_1(1,k,1) + grid%qv_base(k) = moist(1,k,1,P_QV) + grid%u_base(k) = grid%u_1(1,k,1) + grid%v_base(k) = grid%v_1(1,k,1) + grid%z_base(k) = 0.5*(grid%phb(1,k,1)+grid%phb(1,k+1,1)+grid%ph_1(1,k,1)+grid%ph_1(1,k+1,1))/g + ENDDO + + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + grid%tsk(i,j) = theta_surf * (p_surf/p1000mb)**rcp + grid%tmn(i,j) = grid%tsk(i,j) + ENDDO + ENDDO + + RETURN + + END SUBROUTINE init_domain_rk + + SUBROUTINE init_module_initialize + END SUBROUTINE init_module_initialize + +!--------------------------------------------------------------------- + +! test driver for get_sounding +! +! implicit none +! integer n +! parameter(n = 1000) +! real zk(n),p(n),theta(n),rho(n),u(n),v(n),qv(n),pd(n) +! logical dry +! integer nl,k +! +! dry = .false. +! dry = .true. +! call get_sounding( zk, p, pd, theta, rho, u, v, qv, dry, n, nl ) +! write(6,*) ' input levels ',nl +! write(6,*) ' sounding ' +! write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' +! do k=1,nl +! write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), pd(k), theta(k), rho(k), u(k), v(k), qv(k) +! enddo +! end +! +!--------------------------------------------------------------------------- + + subroutine get_sounding( zk, p, p_dry, theta, rho, & + u, v, qv, dry, nl_max, nl_in, th_surf ) + implicit none + + integer nl_max, nl_in + real zk(nl_max), p(nl_max), theta(nl_max), rho(nl_max), & + u(nl_max), v(nl_max), qv(nl_max), p_dry(nl_max) + logical dry + + integer n + parameter(n=3000) + logical debug + parameter( debug = .true.) + +! input sounding data + + real p_surf, th_surf, qv_surf + real pi_surf, pi(n) + real h_input(n), th_input(n), qv_input(n), u_input(n), v_input(n) + +! diagnostics + + real rho_surf, p_input(n), rho_input(n) + real pm_input(n) ! this are for full moist sounding + +! local data + + real r + parameter (r = r_d) + integer k, it, nl + real qvf, qvf1, dz + +! first, read the sounding + + call read_sounding( p_surf, th_surf, qv_surf, & + h_input, th_input, qv_input, u_input, v_input,n, nl, debug ) + + if(dry) then + do k=1,nl + qv_input(k) = 0. + enddo + endif + + if(debug) write(6,*) ' number of input levels = ',nl + + nl_in = nl + if(nl_in .gt. nl_max ) then + write(6,*) ' too many levels for input arrays ',nl_in,nl_max + call wrf_error_fatal ( ' too many levels for input arrays ' ) + end if + +! compute diagnostics, +! first, convert qv(g/kg) to qv(g/g) + + do k=1,nl + qv_input(k) = 0.001*qv_input(k) + enddo + + p_surf = 100.*p_surf ! convert to pascals + qvf = 1. + rvovrd*qv_input(1) + rho_surf = 1./((r/p1000mb)*th_surf*qvf*((p_surf/p1000mb)**cvpm)) + pi_surf = (p_surf/p1000mb)**(r/cp) + + if(debug) then + write(6,*) ' surface density is ',rho_surf + write(6,*) ' surface pi is ',pi_surf + end if + + +! integrate moist sounding hydrostatically, starting from the +! specified surface pressure +! -> first, integrate from surface to lowest level + + qvf = 1. + rvovrd*qv_input(1) + qvf1 = 1. + qv_input(1) + rho_input(1) = rho_surf + dz = h_input(1) + do it=1,10 + pm_input(1) = p_surf & + - 0.5*dz*(rho_surf+rho_input(1))*g*qvf1 + rho_input(1) = 1./((r/p1000mb)*th_input(1)*qvf*((pm_input(1)/p1000mb)**cvpm)) + enddo + +! integrate up the column + + do k=2,nl + rho_input(k) = rho_input(k-1) + dz = h_input(k)-h_input(k-1) + qvf1 = 0.5*(2.+(qv_input(k-1)+qv_input(k))) + qvf = 1. + rvovrd*qv_input(k) ! qv is in g/kg here + + do it=1,10 + pm_input(k) = pm_input(k-1) & + - 0.5*dz*(rho_input(k)+rho_input(k-1))*g*qvf1 + rho_input(k) = 1./((r/p1000mb)*th_input(k)*qvf*((pm_input(k)/p1000mb)**cvpm)) + enddo + enddo + +! we have the moist sounding + +! next, compute the dry sounding using p at the highest level from the +! moist sounding and integrating down. + + p_input(nl) = pm_input(nl) + + do k=nl-1,1,-1 + dz = h_input(k+1)-h_input(k) + p_input(k) = p_input(k+1) + 0.5*dz*(rho_input(k)+rho_input(k+1))*g + enddo + + + do k=1,nl +! For the convrad case, we can hard-wire the initial (geostrophic) winds and qv fields + zk(k) = h_input(k) + p(k) = pm_input(k) + p_dry(k) = p_input(k) + theta(k) = th_input(k) + rho(k) = rho_input(k) + u(k) = u_input(k) + v(k) = v_input(k) + qv(k) = qv_input(k) + + enddo + + if(debug) then + write(6,*) ' sounding ' + write(6,*) ' k height(m) press (Pa) pd(Pa) theta (K) den(kg/m^3) u(m/s) v(m/s) qv(g/g) ' + do k=1,nl + write(6,'(1x,i3,8(1x,1pe10.3))') k, zk(k), p(k), p_dry(k), theta(k), rho(k), u(k), v(k), qv(k) + enddo + + end if + + end subroutine get_sounding + +!------------------------------------------------------- + + subroutine read_sounding( ps,ts,qvs,h,th,qv,u,v,n,nl,debug ) + implicit none + integer n,nl + real ps,ts,qvs,h(n),th(n),qv(n),u(n),v(n) + logical end_of_file + logical debug + + integer k + + open(unit=10,file='input_sounding',form='formatted',status='old') + rewind(10) + read(10,*) ps, ts, qvs + if(debug) then + write(6,*) ' input sounding surface parameters ' + write(6,*) ' surface pressure (mb) ',ps + write(6,*) ' surface pot. temp (K) ',ts + write(6,*) ' surface mixing ratio (g/kg) ',qvs + end if + + end_of_file = .false. + k = 0 + + do while (.not. end_of_file) + + read(10,*,end=100) h(k+1), th(k+1), qv(k+1), u(k+1), v(k+1) + k = k+1 + if(debug) write(6,'(1x,i3,5(1x,e10.3))') k, h(k), th(k), qv(k), u(k), v(k) + go to 110 + 100 end_of_file = .true. + 110 continue + enddo + + nl = k + + close(unit=10,status = 'keep') + + end subroutine read_sounding + +END MODULE module_initialize_ideal diff --git a/wrfv2_fire/dyn_em/module_initialize_les.F b/wrfv2_fire/dyn_em/module_initialize_les.F index 7876c4cd..4fcc04fd 100644 --- a/wrfv2_fire/dyn_em/module_initialize_les.F +++ b/wrfv2_fire/dyn_em/module_initialize_les.F @@ -98,7 +98,7 @@ SUBROUTINE init_domain_rk ( grid & ! stuff from original initialization that has been dropped from the Registry REAL :: vnu, xnu, xnus, dinit0, cbh, p0_temp, t0_temp, zd, zt - REAL :: qvf1, qvf2, pd_surf + REAL :: qvf1, qvf2, pd_surf, theta_surf INTEGER :: it real :: thtmp, ptmp, temp(3) @@ -270,7 +270,7 @@ SUBROUTINE init_domain_rk ( grid & IF ( wrf_dm_on_monitor() ) THEN write(6,*) ' getting dry sounding for base state ' - CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in, theta_surf ) ENDIF CALL wrf_dm_bcast_real( zk , nl_max ) CALL wrf_dm_bcast_real( p_in , nl_max ) @@ -369,7 +369,7 @@ SUBROUTINE init_domain_rk ( grid & write(6,*) ' getting moist sounding for full state ' dry_sounding = .false. - CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in ) + CALL get_sounding( zk, p_in, pd_in, theta, rho, u, v, qv, dry_sounding, nl_max, nl_in, theta_surf ) DO J = jts, min(jde-1,jte) DO I = its, min(ide-1,ite) @@ -629,8 +629,9 @@ SUBROUTINE init_domain_rk ( grid & ! For LES-CBL, add 5 degrees to the surface temperature! ! - Removed in 3.6 ! - grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3) +! grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3) ! grid%tsk(I,J)=grid%cf1*temp(1)+grid%cf2*temp(2)+grid%cf3*temp(3)+5. + grid%tsk(I,J)=theta_surf * (p_surf/p1000mb)**rcp grid%tmn(I,J)=grid%tsk(I,J)-0.5 ENDDO ENDDO @@ -665,7 +666,7 @@ END SUBROUTINE init_module_initialize !--------------------------------------------------------------------------- subroutine get_sounding( zk, p, p_dry, theta, rho, & - u, v, qv, dry, nl_max, nl_in ) + u, v, qv, dry, nl_max, nl_in, th_surf ) implicit none integer nl_max, nl_in diff --git a/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F b/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F index 50e1d04d..a2a8081c 100644 --- a/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F +++ b/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F @@ -693,6 +693,7 @@ subroutine get_sounding( zk, p, p_dry, theta, rho, & parameter(n=1000) logical debug parameter( debug = .true.) + character*256 message ! input sounding data @@ -774,6 +775,11 @@ subroutine get_sounding( zk, p, p_dry, theta, rho, & do it=1,10 pm_input(k) = pm_input(k-1) & - 0.5*dz*(rho_input(k)+rho_input(k-1))*g*qvf1 + IF(pm_input(k) .LE. 0. )THEN + CALL wrf_message("Integrated pressure has gone negative - too cold for chosen height") + WRITE(message,*)'k,pm_input(k),h_input(k),th_input(k) = ',k,pm_input(k),h_input(k),th_input(k) + CALL wrf_error_fatal ( message ) + ENDIF rho_input(k) = 1./((r/p1000mb)*th_input(k)*qvf*((pm_input(k)/p1000mb)**cvpm)) enddo enddo diff --git a/wrfv2_fire/dyn_em/module_initialize_real.F b/wrfv2_fire/dyn_em/module_initialize_real.F index 90ec96f1..4e8ec5cb 100644 --- a/wrfv2_fire/dyn_em/module_initialize_real.F +++ b/wrfv2_fire/dyn_em/module_initialize_real.F @@ -105,7 +105,7 @@ SUBROUTINE init_domain_rk ( grid & REAL :: p_surf, p_level REAL :: cof1, cof2 REAL :: qvf , qvf1 , qvf2 , qtot, pd_surf - REAL :: p00 , t00 , a , tiso + REAL :: p00 , t00 , a , tiso, p_strat, a_strat REAL :: hold_znw , ptemp REAL :: vap_pres_mb , sat_vap_pres_mb LOGICAL :: were_bad @@ -153,9 +153,16 @@ SUBROUTINE init_domain_rk ( grid & !-- Carsel and Parrish [1988] REAL , DIMENSION(100) :: lqmi + REAL , DIMENSION(100) :: thickness , levels REAL :: t_start , t_end REAL , ALLOCATABLE , DIMENSION(:,:) :: clat_glob + ! multiple specified sets of eta_levels + INTEGER :: ks, ke, id + LOGICAL :: vnest ! T if using vertical nesting, otherwise F + + INTEGER :: j_save + ! Dimension information stored in grid data structure. CALL cpu_time(t_start) @@ -192,15 +199,15 @@ SUBROUTINE init_domain_rk ( grid & IF ( flag_lake_depth .EQ. 0 ) THEN CALL wrf_message ( " Warning: Please rerun WPS to get lake_depth information for lake model" ) - ! Set lake depth over the ocean to be -2 m, and set the lake depth over land to be -1 m. + ! Set lake depth over the ocean to be -3 m, and set the lake depth over land to be -2 m. ELSE DO j = jts, MIN(jde-1,jte) DO i = its, MIN(ide-1,ite) IF ( ( grid%lu_index(i,j) .NE. grid%islake ) .AND. ( grid%lu_index(i,j) .NE. grid%iswater ) ) THEN - grid%lake_depth(i,j) = -1 - ELSE IF ( grid%lu_index(i,j) .NE. grid%islake ) THEN grid%lake_depth(i,j) = -2 + ELSE IF ( grid%lu_index(i,j) .NE. grid%islake ) THEN + grid%lake_depth(i,j) = -3 END IF END DO END DO @@ -243,7 +250,7 @@ SUBROUTINE init_domain_rk ( grid & ! necessary constants: p00 (sea level pressure, Pa), t00 (sea level temperature, K), ! and A (temperature difference, from 1000 mb to 300 mb, K). - CALL const_module_initialize ( p00 , t00 , a , tiso ) + CALL const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat ) ! Save these constants to write out in model output file @@ -251,6 +258,8 @@ SUBROUTINE init_domain_rk ( grid & grid%p00 = p00 grid%tlp = a grid%tiso = tiso + grid%p_strat = p_strat + grid%tlp_strat = a_strat ! Are there any hold-ups to us bypassing the middle of the domain? These ! holdups would be situations where we need data in the middle of the domain. @@ -340,6 +349,17 @@ SUBROUTINE init_domain_rk ( grid & END DO END IF + ! Replace traditional seaice field with optional seaice percent (AFWA source) + + IF ( flag_icepct .EQ. 1 ) THEN + DO j=jts,MIN(jde-1,jte) + DO i=its,MIN(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + grid%xice(i,j) = grid%icepct(i,j)/100. + END DO + END DO + END IF + ! Fix the snow (water equivalent depth, kg/m^2) and the snowh (physical snow ! depth, m) fields. @@ -618,7 +638,33 @@ SUBROUTINE init_domain_rk ( grid & grid%clat_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex) + find_j_index_of_fft_filter : DO j = jds , jde-1 + IF ( ABS(clat_glob(ids,j)) .LE. config_flags%fft_filter_lat ) THEN + j_save = j + EXIT find_j_index_of_fft_filter + END IF + END DO find_j_index_of_fft_filter + + CALL wrf_patch_to_global_real ( grid%msft, clat_glob, grid%domdesc, 'xy', 'xy', & + ids, ide, jds, jde, 1, 1, & + ims, ime, jms, jme, 1, 1, & + its, ite, jts, jte, 1, 1 ) + + CALL wrf_dm_bcast_real ( clat_glob , (ide-ids+1)*(jde-jds+1) ) + + grid%mf_fft = clat_glob(ids,j_save) + + grid%mf_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex) + DEALLOCATE( clat_glob ) +#else + find_j_index_of_fft_filter : DO j = jds , jde-1 + IF ( ABS(grid%clat(ids,j)) .LE. config_flags%fft_filter_lat ) THEN + j_save = j + EXIT find_j_index_of_fft_filter + END IF + END DO find_j_index_of_fft_filter + grid%mf_fft = grid%msft(ids,j_save) #endif CALL pxft ( grid=grid & @@ -634,7 +680,9 @@ SUBROUTINE init_domain_rk ( grid & ,flag_chem = 0 & ,flag_tracer = 0 & ,flag_scalar = 0 & - ,positive_definite = .FALSE. & + ,actual_distance_average = .TRUE. & + ,pos_def = .FALSE. & + ,swap_pole_with_next_j = .FALSE. & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -643,6 +691,7 @@ SUBROUTINE init_domain_rk ( grid & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe & ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) + DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) grid%ht(i,j) = grid%t_2(i,1,j) @@ -659,7 +708,6 @@ SUBROUTINE init_domain_rk ( grid & ! "how many" values are used to compute the mean. We want a number ! that is consistent with the original grid resolution. - DO j = jts, MIN(jte,jde-1) DO k = kts, kte DO i = its, MIN(ite,ide-1) @@ -690,7 +738,8 @@ SUBROUTINE init_domain_rk ( grid & ! distance on each computational latitude loop. CALL filter_topo ( grid%ht_xxx , grid%clat_xxx , grid%mf_xxx , & - grid%fft_filter_lat , & + grid%fft_filter_lat , grid%mf_fft , & + .FALSE. , .FALSE. , & ids, ide, jds, jde, 1 , 1 , & imsx, imex, jmsx, jmex, 1, 1, & ipsx, ipex, jpsx, jpex, 1, 1 ) @@ -715,7 +764,8 @@ SUBROUTINE init_domain_rk ( grid & END DO #else CALL filter_topo ( grid%ht , grid%clat , grid%msftx , & - grid%fft_filter_lat , & + grid%fft_filter_lat , grid%mf_fft , & + .FALSE. , .FALSE. , & ids, ide, jds, jde, 1,1, & ims, ime, jms, jme, 1,1, & its, ite, jts, jte, 1,1 ) @@ -757,7 +807,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels = grid%num_metgrid_levels - ! For UM data, swap incoming extra (theta-based) pressure with the standardly + ! For AFWA UM data, swap incoming extra (theta-based) pressure with the standardly ! named (rho-based) pressure. IF ( flag_ptheta .EQ. 1 ) THEN @@ -771,21 +821,70 @@ SUBROUTINE init_domain_rk ( grid & END DO END DO END DO + END IF - ! For UM data, the "surface" and the "first hybrid" level for the theta-level data fields are the same. - ! Average the surface (k=1) and the second hybrid level (k=num_metgrid_levels-1) to get the first hybrid - ! layer. We only do this for the theta-level data: pressure, temperature, specific humidity, and - ! geopotential height (i.e. we do not modify u, v, or the rho-based pressure). + ! For UM data, the "surface" and the "first hybrid" level for the theta-level data fields are the same. + ! Average the surface (k=1) and the second hybrid level (k=num_metgrid_levels-1) to get the first hybrid + ! layer. We only do this for the theta-level data: pressure, temperature, specific humidity, and + ! geopotential height (i.e. we do not modify u, v, or the rho-based pressure). + IF ( ( flag_ptheta .EQ. 1 ) .OR. ( flag_prho .EQ. 1 ) ) THEN DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid% p_gc(i,num_metgrid_levels,j) = ( grid% p_gc(i,1,j) + grid% p_gc(i,num_metgrid_levels-1,j) ) * 0.5 grid% t_gc(i,num_metgrid_levels,j) = ( grid% t_gc(i,1,j) + grid% t_gc(i,num_metgrid_levels-1,j) ) * 0.5 - grid% sh_gc(i,num_metgrid_levels,j) = ( grid% sh_gc(i,1,j) + grid% sh_gc(i,num_metgrid_levels-1,j) ) * 0.5 grid%ght_gc(i,num_metgrid_levels,j) = ( grid%ght_gc(i,1,j) + grid%ght_gc(i,num_metgrid_levels-1,j) ) * 0.5 END DO END DO + + IF ( grid%sh_gc(its,1,jts) .LT. 0 ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + grid% sh_gc(i,1,j) = 2. * grid% sh_gc(i,num_metgrid_levels,j) - grid% sh_gc(i,num_metgrid_levels-1,j) + END DO + END DO + END IF + IF ( grid%cl_gc(its,1,jts) .LT. 0 ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + grid% cl_gc(i,1,j) = 2. * grid% cl_gc(i,num_metgrid_levels,j) - grid% cl_gc(i,num_metgrid_levels-1,j) + END DO + END DO + END IF + IF ( grid%cf_gc(its,1,jts) .LT. 0 ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + grid% cf_gc(i,1,j) = 2. * grid% cf_gc(i,num_metgrid_levels,j) - grid% cf_gc(i,num_metgrid_levels-1,j) + END DO + END DO + END IF + END IF + + ! For UM data, the soil moisture comes in as kg / m^2. Divide by 1000 and layer thickness to get m^3 / m^3. + + IF ( flag_prho .EQ. 1 ) THEN + + levels(1) = 0. + levels(2) = ( 2. * sm_levels_input(1) ) + DO k = 2 , num_sm_levels_input + levels(k+1) = ( 2. * sm_levels_input(k) ) - levels(k) + END DO + DO k = 1 , num_sm_levels_input + thickness(k) = ( levels(k+1) - levels(k) ) / 100. + END DO + + DO j = jts, MIN(jte,jde-1) + DO k = 1 , num_sm_levels_input + DO i = its, MIN(ite,ide-1) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + sm_input(i,k+1,j) = MAX ( 0. , sm_input(i,k+1,j) / 1000. / thickness(k) ) + END DO + END DO + END DO END IF IF ( any_valid_points ) THEN @@ -1043,12 +1142,19 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) - IF ( config_flags%rdlai2d ) THEN CALL monthly_interp_to_date ( grid%lai12m , current_date , grid%lai , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) - ENDIF + +#if ( WRF_CHEM == 1 ) + ! Chose the appropriate LAI veg mask for this date (used in the AFWA dust model) + + CALL eightday_selector ( grid%lai_veg_8day , current_date , grid%lai_vegmask , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) +#endif ! Get the min/max of each i,j for the monthly green-ness fraction. @@ -1057,10 +1163,11 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) - ! The model expects the green-ness values in percent, not fraction. + ! The model expects the green-ness and vegetation fraction values to be in percent, not fraction. DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%vegfra(i,j) = grid%vegfra(i,j) * 100. grid%shdmax(i,j) = grid%shdmax(i,j) * 100. grid%shdmin(i,j) = grid%shdmin(i,j) * 100. @@ -1086,6 +1193,8 @@ SUBROUTINE init_domain_rk ( grid & ! Interpolate monthly aerosol climatology data to specific date/time. ! Since data are 3D, do over a loop of vertical levels using temporary array space. + if( .not. config_flags%use_rap_aero_icbc) then +! for models initialized from GFS IF (config_flags%mp_physics.eq.THOMPSONAERO .and. P_QNWFA.gt.1 .and. config_flags%use_aero_icbc) then CALL wrf_debug ( 0 , 'Using Thompson_aerosol_aware so using QNWFA monthly climo arrays to create QNWFA_now') DO k = 1, num_metgrid_levels @@ -1156,6 +1265,7 @@ SUBROUTINE init_domain_rk ( grid & ENDDO ENDDO ENDIF + endif ! Two ways to get the surface pressure. 1) If we have the low-res input surface ! pressure and the low-res topography, then we can do a simple hydrostatic @@ -1256,13 +1366,74 @@ SUBROUTINE init_domain_rk ( grid & ! Compute the eta levels if not defined already. IF ( grid%znw(1) .NE. 1.0 ) THEN + vnest = .FALSE. + DO id=1,model_config_rec%max_dom + IF (model_config_rec%vert_refine_method(id) .NE. 0) THEN + vnest = .TRUE. + ENDIF + ENDDO + IF (vnest) THEN + + !Added code for specifying multiple domains' eta_levels. + !First check to make sure that we've not specified more + !eta_levels than the dimensionality of eta_levels can handle! This + !issue will most likely cause a break sometime before we real this + !check, however it doesn't hurt to include it. To increase max_eta, + !go to frame/module_driver_constants.F. + + CALL wrf_debug ( 0, "using vertical nesting, reading in eta_levels specified in namelist.input" ) + ks = 0 + DO id=1,grid%id + ks = ks+model_config_rec%e_vert(id) + ENDDO + IF (ks .GT. max_eta) THEN + CALL wrf_error_fatal("too many vertical levels, increase max_eta in frame/module_driver_constants.F") + ENDIF + !Now set the eta_levels to what we specified in the namelist. We've + !packed all the domains' eta_levels into a 'vector' and now we need + !to pull only the section of the vector associated with our domain + !of interest, which is between indicies ks and ke. + IF (grid%id .EQ. 1) THEN + ks = 1 + ke = model_config_rec%e_vert(1) + ELSE + id = 1 + ks = 1 + ke = 0 + DO WHILE (grid%id .GT. id) + id = id+1 + ks = ks+model_config_rec%e_vert(id-1) + ke = ks+model_config_rec%e_vert(id) + ENDDO + ENDIF + eta_levels(1:kde) = model_config_rec%eta_levels(ks:ke) + !Check the value of the first and last eta level for our domain, + !then check that the vector of eta levels is only decreasing + IF (eta_levels(1) .NE. 1.0) THEN + CALL wrf_error_fatal("error with specified eta_levels, first level is not 1.0") + ENDIF + IF (eta_levels(kde) .NE. 0.0) THEN + CALL wrf_error_fatal("error with specified eta_levels, last level is not 0.0") + ENDIF + DO k=2,kde + IF (eta_levels(k) .GT. eta_levels(k-1)) THEN + CALL wrf_error_fatal("eta_levels are not uniformly decreasing from 1.0 to 0.0") + ENDIF + ENDDO + DO k=1,kde + write(a_message,'(A,I3,A,F5.3)') "eta_levels(",k,")=",eta_levels(k) + CALL wrf_message ( a_message ) + ENDDO + ELSE !We're not using vertical nesting + eta_levels(1:kde) = model_config_rec%eta_levels(1:kde) + ENDIF - eta_levels(1:kde) = model_config_rec%eta_levels(1:kde) max_dz = model_config_rec%max_dz CALL compute_eta ( grid%znw , & eta_levels , max_eta , max_dz , & - grid%p_top , g , p00 , cvpm , a , r_d , cp , t00 , p1000mb , t0 , tiso , & + grid%p_top , g , p00 , cvpm , a , r_d , cp , & + t00 , p1000mb , t0 , tiso , p_strat , a_strat , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1318,7 +1489,20 @@ SUBROUTINE init_domain_rk ( grid & END DO END DO +#ifdef DM_PARALLEL + ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte + + ! Stencil for pressure is required for the pressure difference for the max_wind + ! and trop level data. + +# include "HALO_EM_VINTERP_UV_1.inc" +#endif + CALL vert_interp ( grid%ght_gc , grid%pd_gc , grid%ph0 , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + flag_hgtmaxw , flag_hgttrop , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Z' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1356,10 +1540,23 @@ SUBROUTINE init_domain_rk ( grid & t_extrap_type = grid%t_extrap_type extrap_type = grid%extrap_type +#ifdef DM_PARALLEL + ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte + + ! Stencil for pressure is required for the pressure difference for the max_wind + ! and trop level data. + +# include "HALO_EM_VINTERP_UV_1.inc" +#endif + ! Interpolate RH, diagnose Qv later when have temp and pressure. Temporarily ! store this in the u_1 space, for later diagnosis into Qv and stored into moist. CALL vert_interp ( grid%rh_gc , grid%pd_gc , grid%u_1 , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1368,6 +1565,23 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) + ! If this is theta being interpolated, AND we have extra levels for temperature, + ! convert those extra levels (trop and max wind) to potential temp. + + IF ( ( config_flags%interp_theta ) .AND. ( flag_tmaxw .EQ. 1 ) ) THEN + CALL t_to_theta ( grid%tmaxw , grid%pmaxw , p00 , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + its , ite , jts , jte , 1 , 1 ) + END IF + + IF ( ( config_flags%interp_theta ) .AND. ( flag_ttrop .EQ. 1 ) ) THEN + CALL t_to_theta ( grid%ttrop , grid%ptrop , p00 , & + ids , ide , jds , jde , 1 , 1 , & + ims , ime , jms , jme , 1 , 1 , & + its , ite , jts , jte , 1 , 1 ) + END IF + ! Depending on the setting of interp_theta = T/F, t_gc is is either theta Xor ! temperature, and that means that the t_2 field is also the associated field. ! It is better to interpolate temperature and potential temperature in LOG(p), @@ -1375,6 +1589,10 @@ SUBROUTINE init_domain_rk ( grid & interp_type = 2 CALL vert_interp ( grid%t_gc , grid%pd_gc , grid%t_2 , grid%pb , & + grid%tmaxw , grid%ttrop , grid%pmaxw , grid%ptrop , & + flag_tmaxw , flag_ttrop , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'T' , & interp_type , lagrange_order , t_extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1388,6 +1606,10 @@ SUBROUTINE init_domain_rk ( grid & interp_type = 1 CALL vert_interp ( grid%p_gc , grid%pd_gc , grid%p , grid%pb , & + grid%pmaxw , grid%ptrop , grid%pmaxw , grid%ptrop , & + flag_pmaxw , flag_ptrop , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'T' , & interp_type , lagrange_order , t_extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1447,6 +1669,10 @@ SUBROUTINE init_domain_rk ( grid & DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QR ) THEN CALL vert_interp ( grid%qr_gc , grid%pd_gc , moist(:,:,:,P_QR) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1458,10 +1684,24 @@ SUBROUTINE init_domain_rk ( grid & END DO END IF - IF ( flag_qc .EQ. 1 ) THEN + IF ( ( flag_qc .EQ. 1 ) .OR. ( flag_speccldl .EQ. 1 ) ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QC ) THEN + IF ( flag_speccldl .EQ. 1 ) THEN + DO j = jts, MIN(jte,jde-1) + DO k = 1 , num_metgrid_levels + DO i = its, MIN(ite,ide-1) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + grid%qc_gc(i,k,j) = grid%cl_gc(i,k,j) /( 1. - grid%cl_gc(i,k,j) ) + END DO + END DO + END DO + END IF CALL vert_interp ( grid%qc_gc , grid%pd_gc , moist(:,:,:,P_QC) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1473,10 +1713,24 @@ SUBROUTINE init_domain_rk ( grid & END DO END IF - IF ( flag_qi .EQ. 1 ) THEN + IF ( ( flag_qi .EQ. 1 ) .OR. ( flag_speccldf .EQ. 1 ) ) THEN DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QI ) THEN + IF ( flag_speccldf .EQ. 1 ) THEN + DO j = jts, MIN(jte,jde-1) + DO k = 1 , num_metgrid_levels + DO i = its, MIN(ite,ide-1) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + grid%qi_gc(i,k,j) = grid%cf_gc(i,k,j) /( 1. - grid%cf_gc(i,k,j) ) + END DO + END DO + END DO + END IF CALL vert_interp ( grid%qi_gc , grid%pd_gc , moist(:,:,:,P_QI) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1492,6 +1746,10 @@ SUBROUTINE init_domain_rk ( grid & DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QS ) THEN CALL vert_interp ( grid%qs_gc , grid%pd_gc , moist(:,:,:,P_QS) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1507,6 +1765,10 @@ SUBROUTINE init_domain_rk ( grid & DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QG ) THEN CALL vert_interp ( grid%qg_gc , grid%pd_gc , moist(:,:,:,P_QG) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1522,6 +1784,10 @@ SUBROUTINE init_domain_rk ( grid & DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( im .EQ. P_QH ) THEN CALL vert_interp ( grid%qh_gc , grid%pd_gc , moist(:,:,:,P_QH) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1537,6 +1803,10 @@ SUBROUTINE init_domain_rk ( grid & DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNI ) THEN CALL vert_interp ( grid%qni_gc , grid%pd_gc , scalar(:,:,:,P_QNI) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1552,6 +1822,10 @@ SUBROUTINE init_domain_rk ( grid & DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNR ) THEN CALL vert_interp ( grid%qnr_gc , grid%pd_gc , scalar(:,:,:,P_QNR) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1570,7 +1844,27 @@ SUBROUTINE init_domain_rk ( grid & DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNWFA ) THEN CALL wrf_debug ( 0 , 'Using Thompson_aerosol_aware so vertically-interpolating QNWFA monthly climo arrays to fill scalar') + if(config_flags%use_rap_aero_icbc) then +!HRRR - aerosol input from WPS + CALL vert_interp ( grid%qnwfa_gc , grid%pd_gc , scalar(:,:,:,P_QNWFA) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , & + lowest_lev_from_sfc , use_levels_below_ground , use_surface , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + else CALL vert_interp ( grid%QNWFA_now , grid%pd_gc , scalar(:,:,:,P_QNWFA) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1578,6 +1872,7 @@ SUBROUTINE init_domain_rk ( grid & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) + endif END IF END DO ELSEIF ( flag_qnwfa .EQ. 1 .and. (.NOT. config_flags%use_aero_icbc)) THEN @@ -1598,7 +1893,27 @@ SUBROUTINE init_domain_rk ( grid & IF ( flag_qnifa .EQ. 1 .and. config_flags%use_aero_icbc) THEN DO im = PARAM_FIRST_SCALAR, num_3d_s IF ( im .EQ. P_QNIFA ) THEN + if(config_flags%use_rap_aero_icbc) then +! HRRR - aerosol input from WPS + CALL vert_interp ( grid%qnifa_gc , grid%pd_gc , scalar(:,:,:,P_QNIFA) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & + num_metgrid_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , & + lowest_lev_from_sfc , use_levels_below_ground , use_surface , & + zap_close_levels , force_sfc_in_vinterp , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + else CALL vert_interp ( grid%QNIFA_now , grid%pd_gc , scalar(:,:,:,P_QNIFA) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1606,6 +1921,7 @@ SUBROUTINE init_domain_rk ( grid & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) + endif END IF END DO ELSEIF ( flag_qnifa .EQ. 1 .and. (.NOT. config_flags%use_aero_icbc)) THEN @@ -1643,12 +1959,19 @@ SUBROUTINE init_domain_rk ( grid & ! at both the locations for the horizontal momentum, which we get by ! averaging two pressure values (i and i-1 for U, j and j-1 for V). The ! pressure field on input (grid%pd_gc) and the pressure of the new coordinate - ! (grid%pb) are both communicated with an 8 stencil. + ! (grid%pb) would only need an 8 point stencil. However, the i+1 i-1 and + ! j+1 j-1 for the pressure difference for the max_wind and trop level data + ! require an 8 stencil for all of the mass point variables and a 24-point + ! stencil for U and V. # include "HALO_EM_VINTERP_UV_1.inc" #endif CALL vert_interp ( grid%u_gc , grid%pd_gc , grid%u_2 , grid%pb , & + grid%umaxw , grid%utrop , grid%pmaxw , grid%ptrop , & + flag_umaxw , flag_utrop , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'U' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1658,6 +1981,10 @@ SUBROUTINE init_domain_rk ( grid & its , ite , jts , jte , kts , kte ) CALL vert_interp ( grid%v_gc , grid%pd_gc , grid%v_2 , grid%pb , & + grid%vmaxw , grid%vtrop , grid%pmaxw , grid%ptrop , & + flag_vmaxw , flag_vtrop , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & num_metgrid_levels , 'V' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -1846,6 +2173,9 @@ SUBROUTINE init_domain_rk ( grid & IF ( num_st_levels_input .LT. 2 ) THEN CALL wrf_error_fatal ( 'Not enough soil temperature data for SSIB LSM scheme.') END IF + IF ( eta_levels(2) .GT. 0.982 ) THEN + CALL wrf_error_fatal ( 'The first two eta levels are too shallow for SSIB LSM scheme.') + END IF !-------------------------------------------------------- END SELECT enough_data @@ -2179,6 +2509,15 @@ SUBROUTINE init_domain_rk ( grid & 0.004, 0.065 /) ! 0.004, 0.065, 0.020, 0.004, 0.008 /) ! has extra levels for playa, lava, and white sand + ! If Unified Model soil moisture input, add lqmi since UM gives us available soil moisture, not total (AFWA source) + IF ( flag_um_soil == 1 ) THEN + DO j = jts, MIN(jde-1,jte) + DO i = its, MIN(ide-1,ite) + grid%smois(i,:,j)=grid%smois(i,:,j)+lqmi(grid%isltyp(i,j)) + END DO + END DO + END IF + ! At the initial time we care about values of soil moisture and temperature, other times are ! ignored by the model, so we ignore them, too. @@ -2231,15 +2570,15 @@ SUBROUTINE init_domain_rk ( grid & ( grid%tslb(i,1,j) .lt. 400 ) .and. ( grid%smois(i,1,j) .lt. 0.005 ) ) then print *,'RUC -> Noah: bad soil moisture at i,j = ',i,j,grid%smois(i,:,j) iicount = iicount + 1 -! grid%smois(i,:,j) = 0.005 + grid%smois(i,:,j) = 0.005 !+---+-----------------------------------------------------------------+ ! Same comment as above. - grid%smois(i,:,j) = 0.499 - ELSEIF ( (grid%landmask(i,j).gt.0.5) .and. (grid%tslb(i,1,j) .gt. 170 ) .and. & - ( grid%tslb(i,1,j) .lt. 400 ) .and. (grid%smois(i,1,j) .gt. 1.005 ) ) then - print *,'Noah -> Noah: bad soil moisture at i,j =',i,j,grid%smois(i,:,j) - iicount = iicount + 1 - grid%smois(i,:,j) = 0.499 +! grid%smois(i,:,j) = 0.499 +! ELSEIF ( (grid%landmask(i,j).gt.0.5) .and. (grid%tslb(i,1,j) .gt. 170 ) .and. & +! ( grid%tslb(i,1,j) .lt. 400 ) .and. (grid%smois(i,1,j) .gt. 1.005 ) ) then +! print *,'Noah -> Noah: bad soil moisture at i,j =',i,j,grid%smois(i,:,j) +! iicount = iicount + 1 +! grid%smois(i,:,j) = 0.499 !+---+-----------------------------------------------------------------+ END IF END DO @@ -2613,6 +2952,9 @@ SUBROUTINE init_domain_rk ( grid & grid%php(i,k,j) = grid%znw(k)*(p_surf - grid%p_top) + grid%p_top ! temporary, full lev base pressure grid%pb(i,k,j) = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) ) + IF ( grid%pb(i,k,j) .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat ) + ENDIF ! temp = t00 + A*LOG(grid%pb(i,k,j)/p00) grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0 grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm @@ -2812,6 +3154,34 @@ SUBROUTINE init_domain_rk ( grid & END DO #endif + ! Recompute density, simlar to what the model does. + + IF (grid%hypsometric_opt == 1) THEN + DO k=kts,kte-1 + grid%al(i,k,j)=-1./(grid%mub(i,j)+grid%mu_2(i,j))*(grid%alb(i,k,j)*grid%mu_2(i,j) & + +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j))) + ENDDO + ELSE IF (grid%hypsometric_opt == 2) THEN + DO k=kts,kte-1 + pfu = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k+1)+grid%p_top + pfd = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k) +grid%p_top + phm = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k) +grid%p_top + grid%al(i,k,j) = (grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)) & + /phm/LOG(pfd/pfu)-grid%alb(i,k,j) + ENDDO + END IF + + ! Compute pressure similarly to how computed within model. + + DO k=kts,kte-1 + qvf = 1.+rvovrd*moist(i,k,j,P_QV) + grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/ & + (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv & + -grid%pb(i,k,j) + grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + grid%alt(i,k,j) = grid%al(i,k,j) + grid%alb(i,k,j) + ENDDO + ! Adjust the column pressure so that the computed 500 mb height is close to the ! input value (of course, not when we are doing hybrid input). @@ -2913,6 +3283,20 @@ SUBROUTINE init_domain_rk ( grid & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte-1 ) END IF + + ! Compute pressure similarly to how computed within model, with final Qv. + + DO j = jts, min(jde-1,jte) + DO k=kts,kte-1 + DO i = its, min(ide,ite) + qvf = 1.+rvovrd*moist(i,k,j,P_QV) + grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/ & + (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv & + -grid%pb(i,k,j) + grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + ENDDO + ENDDO + ENDDO ! If this is data from the SI, then we probably do not have the original ! surface data laying around. Note that these are all the lowest levels @@ -2987,7 +3371,6 @@ SUBROUTINE init_domain_rk ( grid & IF (config_flags%tracer_opt .eq. 2) THEN DO j = (jde + jds)/2 - 4, (jde + jds)/2 + 4, 1 DO i = (ide + ids)/2 - 4, (ide + ids)/2 + 4, 1 - tracer(i, 1, j, im) = 1. IF ( its .LE. i .and. ite .GE. i .and. jts .LE. j .and. jte .GE. j ) THEN tracer(i, 1, j, P_tr17_1) = 1. tracer(i, 1, j, P_tr17_2) = 1. @@ -3127,15 +3510,17 @@ END SUBROUTINE init_domain_rk !--------------------------------------------------------------------- - SUBROUTINE const_module_initialize ( p00 , t00 , a , tiso ) + SUBROUTINE const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat ) USE module_configure IMPLICIT NONE ! For the real-data-cases only. - REAL , INTENT(OUT) :: p00 , t00 , a , tiso - CALL nl_get_base_pres ( 1 , p00 ) - CALL nl_get_base_temp ( 1 , t00 ) - CALL nl_get_base_lapse ( 1 , a ) - CALL nl_get_iso_temp ( 1 , tiso ) + REAL , INTENT(OUT) :: p00 , t00 , a , tiso , p_strat , a_strat + CALL nl_get_base_pres ( 1 , p00 ) + CALL nl_get_base_temp ( 1 , t00 ) + CALL nl_get_base_lapse ( 1 , a ) + CALL nl_get_iso_temp ( 1 , tiso ) + CALL nl_get_base_pres_strat ( 1 , p_strat ) + CALL nl_get_base_lapse_strat ( 1 , a_strat ) END SUBROUTINE const_module_initialize !------------------------------------------------------------------- @@ -3171,7 +3556,7 @@ SUBROUTINE rebalance ( grid & REAL :: p_surf , pd_surf, p_surf_int , pb_int , ht_hold REAL :: qvf , qvf1 , qvf2 - REAL :: p00 , t00 , a , tiso + REAL :: p00 , t00 , a , tiso , p_strat , a_strat REAL , DIMENSION(:,:,:) , ALLOCATABLE :: t_init_int ! Local domain indices and counters. @@ -3256,14 +3641,16 @@ SUBROUTINE rebalance ( grid & IF ( config_flags%use_baseparam_fr_nml ) then ! get these from namelist CALL wrf_message('ndown: using namelist constants') - CALL const_module_initialize ( p00 , t00 , a , tiso ) + CALL const_module_initialize ( p00 , t00 , a , tiso , p_strat , a_strat ) ELSE ! get these constants from model data CALL wrf_debug(99,'ndown: using base-state profile constants from input file') - t00 = grid%t00 - p00 = grid%p00 - a = grid%tlp - tiso = grid%tiso + t00 = grid%t00 + p00 = grid%p00 + a = grid%tlp + tiso = grid%tiso + p_strat = grid%p_strat + a_strat = grid%tlp_strat IF (t00 .LT. 100. .or. p00 .LT. 10000.) THEN WRITE(wrf_err_message,*)& @@ -3293,10 +3680,16 @@ SUBROUTINE rebalance ( grid & grid%pb(i,k,j) = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top pb_int = grid%znu(k)*(p_surf_int - grid%p_top) + grid%p_top temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) ) + IF ( grid%pb(i,k,j) .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat ) + ENDIF ! temp = t00 + A*LOG(pb/p00) grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0 ! grid%t_init(i,k,j) = (t00 + A*LOG(grid%pb(i,k,j)/p00))*(p00/grid%pb(i,k,j))**(r_d/cp) - t0 temp_int = MAX ( tiso, t00 + A*LOG(pb_int /p00) ) + IF ( pb_int .LT. p_strat ) THEN + temp_int = tiso + A_strat * LOG ( pb_int/p_strat ) + ENDIF t_init_int(i,k,j)= temp_int*(p00/pb_int )**(r_d/cp) - t0 ! t_init_int(i,k,j)= (t00 + A*LOG(pb_int /p00))*(p00/pb_int )**(r_d/cp) - t0 grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm @@ -3762,6 +4155,10 @@ end subroutine fillitup !--------------------------------------------------------------------- SUBROUTINE vert_interp ( fo , po , fnew , pnu , & + fo_maxw , fo_trop , po_maxw , po_trop , & + flag_maxw , flag_trop , & + maxw_horiz_pres_diff , trop_horiz_pres_diff , & + maxw_above_this_level , & generic , var_type , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & @@ -3778,19 +4175,23 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & INTEGER , INTENT(IN) :: interp_type , lagrange_order , extrap_type LOGICAL , INTENT(IN) :: lowest_lev_from_sfc , use_levels_below_ground , use_surface REAL , INTENT(IN) :: zap_close_levels + REAL , INTENT(IN) :: maxw_horiz_pres_diff , trop_horiz_pres_diff , maxw_above_this_level INTEGER , INTENT(IN) :: force_sfc_in_vinterp INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte INTEGER , INTENT(IN) :: generic + INTEGER , INTENT(IN) :: flag_maxw , flag_trop CHARACTER (LEN=1) :: var_type REAL , DIMENSION(ims:ime,generic,jms:jme) , INTENT(IN) :: fo , po + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: fo_maxw , fo_trop , po_maxw , po_trop REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: pnu REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: fnew REAL , DIMENSION(ims:ime,generic,jms:jme) :: forig , porig + REAL , DIMENSION(ims:ime,jms:jme) :: forig_maxw , forig_trop , porig_maxw , porig_trop REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: pnew ! Local vars @@ -3805,8 +4206,8 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & LOGICAL :: any_below_ground - REAL :: p1 , p2 , pn, hold - REAL , DIMENSION(1:generic) :: ordered_porig , ordered_forig + REAL :: p1 , p2 , pn, hold , zap_close_extra_levels + REAL , DIMENSION(1:generic+flag_maxw+flag_trop) :: ordered_porig , ordered_forig REAL , DIMENSION(kts:kte) :: ordered_pnew , ordered_fnew ! Excluded middle. @@ -3815,35 +4216,46 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & INTEGER :: i_valid , j_valid LOGICAL :: flip_data_required + zap_close_extra_levels = 500 + ! Horiontal loop bounds for different variable types. IF ( var_type .EQ. 'U' ) THEN istart = its iend = ite - jstart = jts - jend = MIN(jde-1,jte) + jstart = MAX(jds ,jts-1) + jend = MIN(jde-1,jte+1) kstart = kts kend = kte-1 DO j = jstart,jend DO k = 1,generic - DO i = MAX(ids+1,its) , MIN(ide-1,ite) + DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE porig(i,k,j) = ( po(i,k,j) + po(i-1,k,j) ) * 0.5 END DO END DO + DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + porig_maxw(i,j) = ( po_maxw(i,j) + po_maxw(i-1,j) ) * 0.5 + porig_trop(i,j) = ( po_trop(i,j) + po_trop(i-1,j) ) * 0.5 + END DO IF ( ids .EQ. its ) THEN DO k = 1,generic porig(its,k,j) = po(its,k,j) END DO + porig_maxw(its,j) = po_maxw(its,j) + porig_trop(its,j) = po_trop(its,j) END IF IF ( ide .EQ. ite ) THEN DO k = 1,generic porig(ite,k,j) = po(ite-1,k,j) END DO + porig_maxw(ite,j) = po_maxw(ite-1,j) + porig_trop(ite,j) = po_trop(ite-1,j) END IF DO k = kstart,kend - DO i = MAX(ids+1,its) , MIN(ide-1,ite) + DO i = MAX(ids+1,its-1) , MIN(ide-1,ite+1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pnew(i,k,j) = ( pnu(i,k,j) + pnu(i-1,k,j) ) * 0.5 END DO @@ -3860,32 +4272,41 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & END IF END DO ELSE IF ( var_type .EQ. 'V' ) THEN - istart = its - iend = MIN(ide-1,ite) + istart = MAX(ids ,its-1) + iend = MIN(ide-1,ite+1) jstart = jts jend = jte kstart = kts kend = kte-1 DO i = istart,iend DO k = 1,generic - DO j = MAX(jds+1,jts) , MIN(jde-1,jte) + DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE porig(i,k,j) = ( po(i,k,j) + po(i,k,j-1) ) * 0.5 END DO END DO + DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + porig_maxw(i,j) = ( po_maxw(i,j) + po_maxw(i,j-1) ) * 0.5 + porig_trop(i,j) = ( po_trop(i,j) + po_trop(i,j-1) ) * 0.5 + END DO IF ( jds .EQ. jts ) THEN DO k = 1,generic porig(i,k,jts) = po(i,k,jts) END DO + porig_maxw(i,jts) = po_maxw(i,jts) + porig_trop(i,jts) = po_trop(i,jts) END IF IF ( jde .EQ. jte ) THEN DO k = 1,generic porig(i,k,jte) = po(i,k,jte-1) END DO + porig_maxw(i,jte) = po_maxw(i,jte-1) + porig_trop(i,jte) = po_trop(i,jte-1) END IF DO k = kstart,kend - DO j = MAX(jds+1,jts) , MIN(jde-1,jte) + DO j = MAX(jds+1,jts-1) , MIN(jde-1,jte+1) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE pnew(i,k,j) = ( pnu(i,k,j) + pnu(i,k,j-1) ) * 0.5 END DO @@ -3902,10 +4323,10 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & END IF END DO ELSE IF ( ( var_type .EQ. 'W' ) .OR. ( var_type .EQ. 'Z' ) ) THEN - istart = its - iend = MIN(ide-1,ite) - jstart = jts - jend = MIN(jde-1,jte) + istart = MAX(ids ,its-1) + iend = MIN(ide-1,ite+1) + jstart = MAX(jds ,jts-1) + jend = MIN(jde-1,jte+1) kstart = kts kend = kte DO j = jstart,jend @@ -3915,6 +4336,11 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & porig(i,k,j) = po(i,k,j) END DO END DO + DO i = istart,iend + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + porig_maxw(i,j) = po_maxw(i,j) + porig_trop(i,j) = po_trop(i,j) + END DO DO k = kstart,kend DO i = istart,iend @@ -3924,10 +4350,10 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & END DO END DO ELSE IF ( ( var_type .EQ. 'T' ) .OR. ( var_type .EQ. 'Q' ) ) THEN - istart = its - iend = MIN(ide-1,ite) - jstart = jts - jend = MIN(jde-1,jte) + istart = MAX(ids ,its-1) + iend = MIN(ide-1,ite+1) + jstart = MAX(jds ,jts-1) + jend = MIN(jde-1,jte+1) kstart = kts kend = kte-1 DO j = jstart,jend @@ -3937,6 +4363,11 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & porig(i,k,j) = po(i,k,j) END DO END DO + DO i = istart,iend + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + porig_maxw(i,j) = po_maxw(i,j) + porig_trop(i,j) = po_trop(i,j) + END DO DO k = kstart,kend DO i = istart,iend @@ -3946,10 +4377,10 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & END DO END DO ELSE - istart = its - iend = MIN(ide-1,ite) - jstart = jts - jend = MIN(jde-1,jte) + istart = MAX(ids ,its-1) + iend = MIN(ide-1,ite+1) + jstart = MAX(jds ,jts-1) + jend = MIN(jde-1,jte+1) kstart = kts kend = kte-1 DO j = jstart,jend @@ -4285,19 +4716,72 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & END IF + ! If we have additional levels (for example, some arrays have a "level of max winds" + ! or a "level of the tropopause"), we insert them here. + + IF ( ( flag_maxw .EQ. 1 ) .AND. ( porig_maxw(i,j) .LE. maxw_above_this_level ) .AND. & + ( ( ( ABS(porig_maxw(MIN(i+1, ide ),j )-porig_maxw(MAX(i-1,ids),j )) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'U' ) ) .OR. & + ( ( ABS(porig_maxw(i ,MIN(j+1, jde-1))-porig_maxw(i ,MAX(j-1,jds))) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'U' ) ) .OR. & + ( ( ABS(porig_maxw(MIN(i+1, ide-1),j )-porig_maxw(MAX(i-1,ids),j )) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'V' ) ) .OR. & + ( ( ABS(porig_maxw(i ,MIN(j+1, jde ))-porig_maxw(i ,MAX(j-1,jds))) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'V' ) ) .OR. & + ( ( ABS(porig_maxw(MIN(i+1, ide-1),j )-porig_maxw(MAX(i-1,ids),j )) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'T' ) ) .OR. & + ( ( ABS(porig_maxw(i ,MIN(j+1, jde-1))-porig_maxw(i ,MAX(j-1,jds))) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'T' ) ) .OR. & + ( ( ABS(porig_maxw(MIN(i+1, ide-1),j )-porig_maxw(MAX(i-1,ids),j )) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'Z' ) ) .OR. & + ( ( ABS(porig_maxw(i ,MIN(j+1, jde-1))-porig_maxw(i ,MAX(j-1,jds))) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'Z' ) ) ) ) THEN + insert_maxw : DO ko = kinterp_start , kinterp_end-1 + IF ( ( ( ( ordered_porig(ko)-porig_maxw(i,j) ) * ( ordered_porig(ko+1)-porig_maxw(i,j) ) ) .LT. 0 ) .AND. & + ( ( ABS(ordered_porig(ko )-porig_maxw(i,j)) .GT. zap_close_extra_levels ) .AND. & + ( ABS(ordered_porig(ko+1)-porig_maxw(i,j)) .GT. zap_close_extra_levels ) ) ) THEN + DO kcount = kinterp_end , ko+1 , -1 + ordered_porig(kcount+1) = ordered_porig(kcount) + ordered_forig(kcount+1) = ordered_forig(kcount) + END DO + ordered_porig(ko+1) = porig_maxw(i,j) + ordered_forig(ko+1) = fo_maxw(i,j) + kinterp_end = kinterp_end + 1 + EXIT insert_maxw + END IF + END DO insert_maxw + END IF + + IF ( ( flag_trop .EQ. 1 ) .AND. & + ( ( ( ABS(porig_trop(MIN(i+1, ide ),j )-porig_trop(MAX(i-1,ids),j )) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'U' ) ) .OR. & + ( ( ABS(porig_trop(i ,MIN(j+1, jde-1))-porig_trop(i ,MAX(j-1,jds))) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'U' ) ) .OR. & + ( ( ABS(porig_trop(MIN(i+1, ide-1),j )-porig_trop(MAX(i-1,ids),j )) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'V' ) ) .OR. & + ( ( ABS(porig_trop(i ,MIN(j+1, jde ))-porig_trop(i ,MAX(j-1,jds))) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'V' ) ) .OR. & + ( ( ABS(porig_trop(MIN(i+1, ide-1),j )-porig_trop(MAX(i-1,ids),j )) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'T' ) ) .OR. & + ( ( ABS(porig_trop(i ,MIN(j+1, jde-1))-porig_trop(i ,MAX(j-1,jds))) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'T' ) ) .OR. & + ( ( ABS(porig_trop(MIN(i+1, ide-1),j )-porig_trop(MAX(i-1,ids),j )) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'Z' ) ) .OR. & + ( ( ABS(porig_trop(i ,MIN(j+1, jde-1))-porig_trop(i ,MAX(j-1,jds))) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'Z' ) ) ) ) THEN + insert_trop : DO ko = kinterp_start , kinterp_end-1 + IF ( ( ( ( ordered_porig(ko)-porig_trop(i,j) ) * ( ordered_porig(ko+1)-porig_trop(i,j) ) ) .LT. 0 ) .AND. & + ( ( ABS(ordered_porig(ko )-porig_trop(i,j)) .GT. zap_close_extra_levels ) .AND. & + ( ABS(ordered_porig(ko+1)-porig_trop(i,j)) .GT. zap_close_extra_levels ) ) ) THEN + DO kcount = kinterp_end , ko+1 , -1 + ordered_porig(kcount+1) = ordered_porig(kcount) + ordered_forig(kcount+1) = ordered_forig(kcount) + END DO + ordered_porig(ko+1) = porig_trop(i,j) + ordered_forig(ko+1) = fo_trop(i,j) + kinterp_end = kinterp_end + 1 + EXIT insert_trop + END IF + END DO insert_trop + END IF + ! The polynomials are either in pressure or LOG(pressure). IF ( interp_type .EQ. 1 ) THEN CALL lagrange_setup ( var_type , interp_type , & ordered_porig(kinterp_start:kinterp_end) , & ordered_forig(kinterp_start:kinterp_end) , & - count , lagrange_order , extrap_type , & + kinterp_end-kinterp_start+1 , lagrange_order , extrap_type , & ordered_pnew(kstart:kend) , ordered_fnew , kend-kstart+1 ,i,j) ELSE CALL lagrange_setup ( var_type , interp_type , & LOG(ordered_porig(kinterp_start:kinterp_end)) , & ordered_forig(kinterp_start:kinterp_end) , & - count , lagrange_order , extrap_type , & + kinterp_end-kinterp_start+1 , lagrange_order , extrap_type , & LOG(ordered_pnew(kstart:kend)) , ordered_fnew , kend-kstart+1 ,i,j) END IF @@ -4876,9 +5360,8 @@ SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n ! an odd order interpolator. For the even guys, we'll do it twice ! and shift the range one index, then get an average. -! cubic spline IF ( n .EQ. 9 ) THEN - CALL cubic_spline (all_dim-1, all_x, all_y, P2) + CALL cubic_spline (all_dim, all_x, all_y, P2) ! ! Find the value of function f(x) ! @@ -4894,9 +5377,6 @@ SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n +GAMMA*(target_x(target_loop)-all_x(loc_center_left)) & +ETA*(target_x(target_loop)-all_x(loc_center_right)) -! IF ( MOD(n,2) .NE. 0 ) THEN -! end cubic spline block - ELSE IF ( MOD(n,2) .NE. 0 ) THEN IF ( ( loc_center_left -(((n+1)/2)-1) .GE. 1 ) .AND. & ( loc_center_right+(((n+1)/2)-1) .LE. all_dim ) ) THEN @@ -4966,11 +5446,16 @@ SUBROUTINE cubic_spline (N, XI, FI, P2) ! ! Assign the intervals and function differences ! - DO I = 1, N + DO I = 1, N-1 H(I) = XI(I+1) - XI(I) G(I) = FI(I+1) - FI(I) END DO ! +! The top vertical derivative is zero +! + H(N) = H(N-1) + G(N) = 0 +! ! Evaluate the coefficient matrix elements DO I = 1, N-1 D(I) = 2*(H(I+1)+H(I)) @@ -4982,7 +5467,6 @@ SUBROUTINE cubic_spline (N, XI, FI, P2) ! CALL TRIDIAGONAL_LINEAR_EQ (N-1, D, C, C, B, G) P2(1) = 0 - P2(N+1) = 0 DO I = 2, N P2(I) = G(I-1) END DO @@ -5884,9 +6368,57 @@ END SUBROUTINE rh_to_mxrat1 !--------------------------------------------------------------------- +#if 0 +program foo + +integer , parameter :: max_eta = 1000 + +INTEGER :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + +real :: max_dz = 1000 +real :: p_top = 100 +real :: g = 9.81 +real :: p00 = 100000 +real :: cvpm = -0.714285731 +real :: a = 50 +real :: r_d = 287 +real :: cp = 1004.5 +real :: t00 = 290 +real :: p1000mb = 100000 +real :: t0 = 300 +real :: tiso = 216.649994 +real :: p_strat = 5500 +real :: a_strat = -12 + +real , dimension(max_eta) :: znw , eta_levels + +eta_levels = -1 + +kds=1 +kms=1 +kts=1 +kde=70 +kme=70 +kte=70 + + +call compute_eta ( znw , & + eta_levels , max_eta , max_dz , & + p_top , g , p00 , cvpm , a , r_d , cp , & + t00 , p1000mb , t0 , tiso , p_strat , a_strat , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + +end program foo +#endif + SUBROUTINE compute_eta ( znw , & eta_levels , max_eta , max_dz , & - p_top , g , p00 , cvpm , a , r_d , cp , t00 , p1000mb , t0 , tiso , & + p_top , g , p00 , cvpm , a , r_d , cp , & + t00 , p1000mb , t0 , tiso , p_strat , a_strat , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -5902,21 +6434,26 @@ SUBROUTINE compute_eta ( znw , & its , ite , jts , jte , kts , kte REAL , INTENT(IN) :: max_dz REAL , INTENT(IN) :: p_top , g , p00 , cvpm , a , r_d , cp , t00 , p1000mb , t0 , tiso + REAL , INTENT(IN) :: p_strat , a_strat INTEGER , INTENT(IN) :: max_eta - REAL , DIMENSION (max_eta) , INTENT(IN) :: eta_levels + REAL , DIMENSION (max_eta) :: eta_levels REAL , DIMENSION (kts:kte) , INTENT(OUT) :: znw ! Local vars - INTEGER :: k - REAL :: mub , t_init , p_surf , pb, ztop, ztop_pbl , dz , temp - REAL , DIMENSION(kts:kte) :: dnw + INTEGER :: k , kk + REAL(KIND=8) :: mub , t_init , p_surf , pb, ztop, ztop_pbl , dz , temp + REAL(KIND=8) , DIMENSION(kts:kte) :: dnw - INTEGER , PARAMETER :: prac_levels = 17 + INTEGER , PARAMETER :: prac_levels = 59 INTEGER :: loop , loop1 - REAL , DIMENSION(prac_levels) :: znw_prac , znu_prac , dnw_prac - REAL , DIMENSION(kts:kte) :: alb , phb + REAL(KIND=8) , DIMENSION(prac_levels) :: znw_prac , znu_prac , dnw_prac + REAL(KIND=8) , DIMENSION(MAX(prac_levels,kde)) :: alb , phb + REAL(KIND=8) :: alb_max, t_init_max, pb_max, phb_max + REAL(KIND=8) :: p00_r8, t00_r8, a_r8, tiso_r8 + + CHARACTER(LEN=256) :: message ! Gee, do the eta levels come in from the namelist? @@ -5964,18 +6501,32 @@ SUBROUTINE compute_eta ( znw , & p_surf = p00 - znw_prac = (/ 1.000 , 0.993 , 0.983 , 0.970 , 0.954 , 0.934 , 0.909 , & - 0.88 , 0.8 , 0.7 , 0.6 , 0.5 , 0.4 , 0.3 , 0.2 , 0.1 , 0.0 /) + znw_prac = (/ 1.0000_8 , 0.9930_8 , 0.9830_8 , 0.9700_8 , 0.9540_8 , 0.9340_8 , 0.9090_8 , 0.8800_8 , & + 0.8500_8 , 0.8000_8 , 0.7500_8 , 0.7000_8 , 0.6500_8 , 0.6000_8 , 0.5500_8 , 0.5000_8 , & + 0.4500_8 , 0.4000_8 , 0.3500_8 , 0.3000_8 , 0.2500_8 , 0.2000_8 , 0.1500_8 , 0.1000_8 , & + 0.0800_8 , 0.0600_8 , 0.0400_8 , 0.0200_8 , & + 0.0150_8 , 0.0100_8 , 0.0090_8 , 0.0080_8 , 0.0070_8 , 0.0060_8 , 0.0050_8 , 0.0040_8 , & + 0.0035_8 , 0.0030_8 , & + 0.0028_8 , 0.0026_8 , 0.0024_8 , 0.0022_8 , 0.0020_8 , & + 0.0018_8 , 0.0016_8 , 0.0014_8 , 0.0012_8 , 0.0010_8 , & + 0.0009_8 , 0.0008_8 , 0.0007_8 , 0.0006_8 , 0.0005_8 , 0.0004_8 , 0.0003_8 , & + 0.0002_8 , 0.0001_8 , 0.00005_8, 0.0000_8 /) DO k = 1 , prac_levels - 1 - znu_prac(k) = ( znw_prac(k) + znw_prac(k+1) ) * 0.5 + znu_prac(k) = ( znw_prac(k) + znw_prac(k+1) ) * 0.5_8 dnw_prac(k) = znw_prac(k+1) - znw_prac(k) END DO + tiso_r8 = tiso + t00_r8 = t00 + a_r8 = a + p00_r8 = p00 DO k = 1, prac_levels-1 pb = znu_prac(k)*(p_surf - p_top) + p_top - temp = MAX ( tiso, t00 + A*LOG(pb/p00) ) -! temp = t00 + A*LOG(pb/p00) + temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat*LOG(pb/p_strat) + END IF t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm END DO @@ -5986,7 +6537,7 @@ SUBROUTINE compute_eta ( znw , & ! Integrate base geopotential, starting at terrain elevation. - phb(1) = 0. + phb(1) = 0._8 DO k = 2,prac_levels phb(k) = phb(k-1) - dnw_prac(k-1)*mub*alb(k-1) END DO @@ -5998,10 +6549,20 @@ SUBROUTINE compute_eta ( znw , & ztop_pbl = phb(8 ) / g dz = ( ztop - ztop_pbl ) / REAL ( kde - 8 ) + IF ( dz .GE. max_dz ) THEN + WRITE (message,FMT='("With a requested ",F7.1," Pa model top, the model lid will be about ",F7.1," m.")') p_top, ztop + CALL wrf_message ( message ) + WRITE (message,FMT='("With ",I3," levels above the PBL, the level thickness will be about ",F6.1," m.")') kde-8, dz + CALL wrf_message ( message ) + WRITE (message,FMT='("Thicknesses greater than ",F7.1," m are not recommended.")') max_dz + CALL wrf_message ( message ) + CALL wrf_error_fatal ( 'Add more levels to namelist.input for e_vert' ) + END IF + ! Standard levels near the surface so no one gets in trouble. DO k = 1 , 8 - znw(k) = znw_prac(k) + eta_levels(k) = znw_prac(k) END DO ! Using d phb(k)/ d eta(k) = -mub * alb(k), eqn 2.9 @@ -6009,12 +6570,45 @@ SUBROUTINE compute_eta ( znw , & ! use twice the thickness. DO k = 8, kte-1-2 - pb = znw(k) * (p_surf - p_top) + p_top - temp = MAX ( tiso, t00 + A*LOG(pb/p00) ) + + find_prac : DO kk = 1 , prac_levels + IF (znw_prac(kk) .LT. eta_levels(k) ) THEN + EXIT find_prac + END IF + end do find_prac + + pb = 0.5*(eta_levels(k)+znw_prac(kk)) * (p_surf - p_top) + p_top + + temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( pb/p_strat ) + END IF +! temp = t00 + A*LOG(pb/p00) + t_init = temp*(p00/pb)**(r_d/cp) - t0 + alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm + eta_levels(k+1) = eta_levels(k) - dz*g / ( mub*alb(k) ) + pb = 0.5*(eta_levels(k)+eta_levels(k+1)) * (p_surf - p_top) + p_top + + temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( pb/p_strat ) + END IF ! temp = t00 + A*LOG(pb/p00) t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm - znw(k+1) = znw(k) - dz*g / ( mub*alb(k) ) + eta_levels(k+1) = eta_levels(k) - dz*g / ( mub*alb(k) ) + pb = 0.5*(eta_levels(k)+eta_levels(k+1)) * (p_surf - p_top) + p_top + + phb(k+1) = phb(k) - (eta_levels(k+1)-eta_levels(k)) * mub*alb(k) + END DO + + alb_max = alb(kte-1-2) + t_init_max = t_init + pb_max = pb + phb_max = phb(kte-1) + + DO k = 1 , kte-1-2 + znw(k) = eta_levels(k) END DO znw(kte-2) = 0.000 @@ -6026,14 +6620,20 @@ SUBROUTINE compute_eta ( znw , & DO loop1 = 1 , 5 DO loop = 1 , 10 - DO k = 8, kte-1-2 + DO k = 8, kte-1-2-1 pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top - temp = MAX ( tiso, t00 + A*LOG(pb/p00) ) -! temp = t00 + A*LOG(pb/p00) + temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( pb/p_strat ) + END IF t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm znw(k+1) = znw(k) - dz*g / ( mub*alb(k) ) END DO + pb = pb_max + t_init = t_init_max + alb(kte-1-2) = alb_max + znw(kte-2) = znw(kte-1-2) - dz*g / ( mub*alb(kte-1-2) ) IF ( ( loop1 .EQ. 5 ) .AND. ( loop .EQ. 10 ) ) THEN print *,'Converged znw(kte) should be about 0.0 = ',znw(kte-2) END IF @@ -6044,15 +6644,17 @@ SUBROUTINE compute_eta ( znw , & DO k = 1, kde-1-2 pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top - temp = MAX ( tiso, t00 + A*LOG(pb/p00) ) -! temp = t00 + A*LOG(pb/p00) + temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( pb/p_strat ) + END IF t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm END DO phb(1) = 0. DO k = 2,kde-2 - phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1) + phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1) END DO ! Reset the model top and the dz, and iterate. @@ -6096,7 +6698,10 @@ SUBROUTINE compute_eta ( znw , & DO k = 8, kte-1 pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top - temp = MAX ( tiso, t00 + A*LOG(pb/p00) ) + temp = MAX ( tiso_r8, t00_r8 + A_r8*LOG(pb/p00_r8) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( pb/p_strat ) + END IF t_init = temp*(p00/pb)**(r_d/cp) - t0 alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1) @@ -6104,9 +6709,9 @@ SUBROUTINE compute_eta ( znw , & phb(kte) = phb(kte-1) - (znw(kte)-znw(kte-1)) * mub*alb(kte-1) k=1 -print *,k,' z (m) = ',phb(1)/g +WRITE (*,FMT='("Full level index = ",I4," Height = ",F7.1," m")') k,phb(1)/g do k = 2 ,kte -print *,k,' z (m) and dz (m) = ',phb(k)/g,(phb(k)-phb(k-1))/g +WRITE (*,FMT='("Full level index = ",I4," Height = ",F7.1," m Thickness = ",F6.1," m")') k,phb(k)/g,(phb(k)-phb(k-1))/g end do END IF @@ -6225,6 +6830,46 @@ SUBROUTINE monthly_interp_to_date ( field_in , date_str , field_out , & END SUBROUTINE monthly_interp_to_date +!--------------------------------------------------------------------- + + SUBROUTINE eightday_selector ( field_in , date_str , field_out , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Given current date, select time-matching monthly entry from grid. + ! No interpolation. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + CHARACTER (LEN=24) , INTENT(IN) :: date_str + REAL , DIMENSION(ims:ime,46,jms:jme) , INTENT(IN) :: field_in !46 + REAL , DIMENSION(ims:ime, jms:jme) , INTENT(OUT) :: field_out + + ! Local vars + + INTEGER :: i , j + INTEGER :: julyr, julday, eightday + REAL :: gmt + + CALL get_julgmt ( date_str , julyr , julday , gmt ) + eightday = ((julday-1) / 8) + 1 +! print *, 'date_str: ', date_str +! print *, 'julyr, julday: ', julyr, julday +! print *, 'eightday: ', eightday + + DO j = jts , MIN ( jde-1 , jte ) + DO i = its , MIN (ide-1 , ite ) + field_out(i,j) = field_in(i,eightday,j) + END DO + END DO + + END SUBROUTINE eightday_selector + !--------------------------------------------------------------------- SUBROUTINE sfcprs (t, q, height, pslv, ter, avgsfct, p, & @@ -6702,9 +7347,12 @@ SUBROUTINE sfcprs3( height , p , ter , slp , psfc , & END DO END SUBROUTINE sfcprs3 + !--------------------------------------------------------------------- - SUBROUTINE filter_topo ( ht_in , xlat , msftx , fft_filter_lat , & + SUBROUTINE filter_topo ( ht_in , xlat , msftx , & + fft_filter_lat , mf_fft , & + pos_def , swap_pole_with_next_j , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -6715,7 +7363,143 @@ SUBROUTINE filter_topo ( ht_in , xlat , msftx , fft_filter_lat , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte - REAL , INTENT(IN) :: fft_filter_lat + REAL , INTENT(IN) :: fft_filter_lat , mf_fft + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: ht_in + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: xlat , msftx + LOGICAL :: pos_def , swap_pole_with_next_j + + ! Local vars + + INTEGER :: i , j , j_lat_pos , j_lat_neg , k + INTEGER :: i_kicker , ik , i1, i2, i3, i4 + INTEGER :: i_left , i_right , ii + REAL :: length_scale , sum + REAL , DIMENSION(its:ite,jts:jte) :: ht_out + CHARACTER (LEN=256) :: message + + ! The filtering is a simple average on a latitude loop. Possibly a LONG list of + ! numbers. We assume that ALL of the 2d arrays have been transposed so that + ! each patch has the entire domain size of the i-dim local. + + IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN + CALL wrf_error_fatal ( 'filtering assumes all values on X' ) + END IF + + ! Starting at the south pole, we find where the + ! grid distance is big enough, then go back a point. Continuing to the + ! north pole, we find the first small grid distance. These are the + ! computational latitude loops and the associated computational poles. + + j_lat_neg = 0 + j_lat_pos = jde + 1 + loop_neg : DO j = MIN(jde-1,jte) , jts , -1 + IF ( xlat(its,j) .LT. 0.0 ) THEN + IF ( ABS(xlat(its,j)) .GE. fft_filter_lat ) THEN + j_lat_neg = j + EXIT loop_neg + END IF + END IF + END DO loop_neg + + loop_pos : DO j = jts , MIN(jde-1,jte) + IF ( xlat(its,j) .GT. 0.0 ) THEN + IF ( xlat(its,j) .GE. fft_filter_lat ) THEN + j_lat_pos = j + EXIT loop_pos + END IF + END IF + END DO loop_pos + + ! Set output values to initial input topo values for whole patch. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + ht_out(i,j) = ht_in(i,j) + END DO + END DO + + ! Filter the topo at the negative lats. + + DO j = MIN(j_lat_neg,jte) , jts , -1 +! i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 ) + i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 ) + WRITE (message,*) 'SOUTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j) + CALL wrf_debug(10,TRIM(message)) + DO i = its , MIN(ide-1,ite) + sum = 0. + DO ik = 1 , i_kicker + ii = i-ik + IF ( ii .GE. ids ) THEN + i_left = ii + ELSE + i_left = ( ii - ids ) + (ide-1)+1 + END IF + ii = i+ik + IF ( ii .LE. ide-1 ) THEN + i_right = ii + ELSE + i_right = ( ii - (ide-1) ) + its-1 + END IF + sum = sum + ht_in(i_left,j) + ht_in(i_right,j) + END DO + ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) + END DO + END DO + + ! Filter the topo at the positive lats. + + DO j = MAX(j_lat_pos,jts) , MIN(jde-1,jte) +! i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 ) + i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 ) + WRITE (message,*) 'NORTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j) + CALL wrf_debug(10,TRIM(message)) + DO i = its , MIN(ide-1,ite) + sum = 0. + DO ik = 1 , i_kicker + ii = i-ik + IF ( ii .GE. ids ) THEN + i_left = ii + ELSE + i_left = ( ii - ids ) + (ide-1)+1 + END IF + ii = i+ik + IF ( ii .LE. ide-1 ) THEN + i_right = ii + ELSE + i_right = ( ii - (ide-1) ) + its-1 + END IF + sum = sum + ht_in(i_left,j) + ht_in(i_right,j) + END DO + ht_out(i,j) = ( ht_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) + END DO + END DO + + ! Set output values to initial input topo values for whole patch. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + ht_in(i,j) = ht_out(i,j) + END DO + END DO + + END SUBROUTINE filter_topo + +!--------------------------------------------------------------------- +!--------------------------------------------------------------------- + + SUBROUTINE filter_topo_old ( ht_in , xlat , msftx , fft_filter_lat , & + dummy , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , INTENT(IN) :: fft_filter_lat , dummy REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: ht_in REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: xlat , msftx @@ -6872,7 +7656,7 @@ SUBROUTINE filter_topo ( ht_in , xlat , msftx , fft_filter_lat , & END DO END DO - END SUBROUTINE filter_topo + END SUBROUTINE filter_topo_old !--------------------------------------------------------------------- diff --git a/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F b/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F index 561bca3f..92ee5af6 100644 --- a/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F +++ b/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F @@ -677,6 +677,7 @@ subroutine get_sounding( zk, p, p_dry, theta, rho, & parameter(n=3000) logical debug parameter( debug = .true.) + character*256 message ! input sounding data @@ -758,6 +759,11 @@ subroutine get_sounding( zk, p, p_dry, theta, rho, & do it=1,10 pm_input(k) = pm_input(k-1) & - 0.5*dz*(rho_input(k)+rho_input(k-1))*g*qvf1 + IF(pm_input(k) .LE. 0. )THEN + CALL wrf_message("Integrated pressure has gone negative - too cold for chosen height") + WRITE(message,*)'k,pm_input(k),h_input(k),th_input(k) = ',k,pm_input(k),h_input(k),th_input(k) + CALL wrf_error_fatal ( message ) + ENDIF rho_input(k) = 1./((r/p1000mb)*th_input(k)*qvf*((pm_input(k)/p1000mb)**cvpm)) enddo enddo diff --git a/wrfv2_fire/dyn_em/module_polarfft.F b/wrfv2_fire/dyn_em/module_polarfft.F index 21c645f6..a89bd532 100644 --- a/wrfv2_fire/dyn_em/module_polarfft.F +++ b/wrfv2_fire/dyn_em/module_polarfft.F @@ -65,7 +65,9 @@ SUBROUTINE pxft ( grid & ,flag_tracer & ,flag_scalar & ,fft_filter_lat, dclat & - ,positive_definite & + ,actual_distance_average & + ,pos_def & + ,swap_pole_with_next_j & ,moist,chem,tracer,scalar & ,ids,ide,jds,jde,kds,kde & ,ims,ime,jms,jme,kms,kme & @@ -114,7 +116,9 @@ SUBROUTINE pxft ( grid & TYPE(domain) , TARGET :: grid integer, intent(in) :: lineno integer myproc, i, j, k - LOGICAL, INTENT(IN) :: positive_definite + LOGICAL, INTENT(IN) :: actual_distance_average + LOGICAL, INTENT(IN) :: pos_def + LOGICAL, INTENT(IN) :: swap_pole_with_next_j INTEGER, INTENT(IN) :: ids,ide,jds,jde,kds,kde & ,ims,ime,jms,jme,kms,kme & ,ips,ipe,jps,jpe,kps,kpe & @@ -253,6 +257,15 @@ SUBROUTINE pxft ( grid & imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, k_end ) + IF ( actual_distance_average ) THEN + CALL filter_tracer ( grid%t_xxx , grid%clat_xxx , grid%mf_xxx , & + grid%fft_filter_lat , grid%mf_fft , & + pos_def, swap_pole_with_next_j , & + ids, ide, jds, jde, kds, kde , & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex ) + END IF + # include "XPOSE_POLAR_FILTER_T_x2z.inc" #else k_end = MIN(kde-1,kpe) @@ -264,6 +277,15 @@ SUBROUTINE pxft ( grid & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, k_end ) + IF ( actual_distance_average ) THEN + CALL filter_tracer ( grid%t_2 , grid%clat , grid%msft , & + grid%fft_filter_lat , grid%mf_fft , & + pos_def, swap_pole_with_next_j , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, k_end ) + END IF + #endif IF ( piggyback_mu ) THEN grid%mu_2(ips:ipe,jps:jpe) = grid%t_2(ips:ipe,kde,jps:jpe) @@ -389,16 +411,32 @@ SUBROUTINE pxft ( grid & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & imsx, imex, jmsx, jmex, kmsx, kmex, & - ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1), & - positive_definite = positive_definite ) + ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1) ) + + IF ( actual_distance_average ) THEN + CALL filter_tracer ( grid%fourd_xxx , grid%clat_xxx , grid%mf_xxx , & + grid%fft_filter_lat , grid%mf_fft , & + pos_def, swap_pole_with_next_j , & + ids, ide, jds, jde, kds, kde , & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex ) + END IF # include "XPOSE_POLAR_FILTER_MOIST_x2z.inc" #else CALL polar_filter_3d( moist(ims,kms,jms,itrace), grid%clat, .false., & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, MIN(kpe,kde-1), & - positive_definite = positive_definite ) + ips, ipe, jps, jpe, kps, MIN(kpe,kde-1) ) + + IF ( actual_distance_average ) THEN + CALL filter_tracer ( moist(ims,kms,jms,itrace) , grid%clat , grid%msft , & + grid%fft_filter_lat , grid%mf_fft , & + pos_def, swap_pole_with_next_j , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, MIN(kpe,kde-1) ) + END IF #endif ENDIF @@ -412,16 +450,32 @@ SUBROUTINE pxft ( grid & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & imsx, imex, jmsx, jmex, kmsx, kmex, & - ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1), & - positive_definite = positive_definite ) + ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1) ) + + IF ( actual_distance_average ) THEN + CALL filter_tracer ( grid%fourd_xxx , grid%clat_xxx , grid%mf_xxx , & + grid%fft_filter_lat , grid%mf_fft , & + pos_def, swap_pole_with_next_j , & + ids, ide, jds, jde, kds, kde , & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex ) + END IF # include "XPOSE_POLAR_FILTER_CHEM_x2z.inc" #else CALL polar_filter_3d( chem(ims,kms,jms,itrace), grid%clat, .false. , & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, MIN(kpe,kde-1), & - positive_definite = positive_definite ) + ips, ipe, jps, jpe, kps, MIN(kpe,kde-1) ) + + IF ( actual_distance_average ) THEN + CALL filter_tracer ( chem(ims,kms,jms,itrace) , grid%clat , grid%msft , & + grid%fft_filter_lat , grid%mf_fft , & + pos_def, swap_pole_with_next_j , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, MIN(kpe,kde-1) ) + END IF #endif ENDIF @@ -436,8 +490,16 @@ SUBROUTINE pxft ( grid & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & imsx, imex, jmsx, jmex, kmsx, kmex, & - ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1), & - positive_definite = positive_definite ) + ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1) ) + + IF ( actual_distance_average ) THEN + CALL filter_tracer ( grid%fourd_xxx , grid%clat_xxx , grid%mf_xxx , & + grid%fft_filter_lat , grid%mf_fft , & + pos_def, swap_pole_with_next_j , & + ids, ide, jds, jde, kds, kde , & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex ) + END IF # include "XPOSE_POLAR_FILTER_TRACER_x2z.inc" #else @@ -445,8 +507,16 @@ SUBROUTINE pxft ( grid & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, MIN(kpe,kde-1), & - positive_definite = positive_definite ) + ips, ipe, jps, jpe, kps, MIN(kpe,kde-1) ) + + IF ( actual_distance_average ) THEN + CALL filter_tracer ( tracer(ims,kms,jms,itrace) , grid%clat , grid%msft , & + grid%fft_filter_lat , grid%mf_fft , & + pos_def, swap_pole_with_next_j , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, MIN(kpe,kde-1) ) + END IF #endif ENDIF @@ -460,16 +530,32 @@ SUBROUTINE pxft ( grid & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & imsx, imex, jmsx, jmex, kmsx, kmex, & - ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1), & - positive_definite = positive_definite ) + ipsx, ipex, jpsx, jpex, kpsx, MIN(kpex,kde-1) ) + + IF ( actual_distance_average ) THEN + CALL filter_tracer ( grid%fourd_xxx , grid%clat_xxx , grid%mf_xxx , & + grid%fft_filter_lat , grid%mf_fft , & + pos_def, swap_pole_with_next_j , & + ids, ide, jds, jde, kds, kde , & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex ) + END IF # include "XPOSE_POLAR_FILTER_SCALAR_x2z.inc" #else CALL polar_filter_3d( scalar(ims,kms,jms,itrace) , grid%clat, .false. , & fft_filter_lat, 0., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, MIN(kpe,kde-1), & - positive_definite = positive_definite ) + ips, ipe, jps, jpe, kps, MIN(kpe,kde-1) ) + + IF ( actual_distance_average ) THEN + CALL filter_tracer ( scalar(ims,kms,jms,itrace) , grid%clat , grid%msft , & + grid%fft_filter_lat , grid%mf_fft , & + pos_def, swap_pole_with_next_j , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, MIN(kpe,kde-1) ) + END IF #endif ENDIF @@ -487,8 +573,7 @@ END SUBROUTINE pxft SUBROUTINE polar_filter_3d( f, xlat, piggyback, fft_filter_lat, dvlat, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte, & - positive_definite ) + its, ite, jts, jte, kts, kte ) IMPLICIT NONE @@ -500,7 +585,6 @@ SUBROUTINE polar_filter_3d( f, xlat, piggyback, fft_filter_lat, dvlat, & REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(INOUT) :: f REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: xlat REAL , INTENT(IN) :: dvlat - LOGICAL , INTENT(IN), OPTIONAL :: positive_definite LOGICAL , INTENT(IN) :: piggyback REAL , DIMENSION(1:ide-ids,1:kte-kts+1) :: sheet @@ -723,7 +807,352 @@ SUBROUTINE polar_filter_fft_2d_ncar(nx,ny,fin,lat,filter_latitude,piggyback,fftf END SUBROUTINE polar_filter_fft_2d_ncar -!------------------------------------------------------------------------------ - +!--------------------------------------------------------------------- + + SUBROUTINE filter_tracer ( tr3d_in , xlat , msftx , & + fft_filter_lat , mf_fft , & + pos_def , swap_pole_with_next_j , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , INTENT(IN) :: fft_filter_lat , mf_fft + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: tr3d_in + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: xlat , msftx + LOGICAL , INTENT(IN) :: pos_def , swap_pole_with_next_j + + + ! Local vars + + INTEGER :: i , j , j_lat_pos , j_lat_neg , k + INTEGER :: i_kicker , ik , i1, i2, i3, i4 + INTEGER :: i_left , i_right , ii , count + REAL :: length_scale , sum + REAL , DIMENSION(its:ite,jts:jte) :: tr_in, tr_out + CHARACTER (LEN=256) :: message + + ! The filtering is a simple average on a latitude loop. Possibly a LONG list of + ! numbers. We assume that ALL of the 2d arrays have been transposed so that + ! each patch has the entire domain size of the i-dimension available. + + IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN + CALL wrf_error_fatal ( 'filtering assumes all values on X' ) + END IF + + ! Starting at the south pole, we find where the + ! grid distance is big enough, then go back a point. Continuing to the + ! north pole, we find the first small grid distance. These are the + ! computational latitude loops and the associated computational poles. + + j_lat_neg = 0 + j_lat_pos = jde + 1 + loop_neg : DO j = MIN(jde-1,jte) , jts , -1 + IF ( xlat(its,j) .LT. 0.0 ) THEN + IF ( ABS(xlat(its,j)) .GE. fft_filter_lat ) THEN + j_lat_neg = j + EXIT loop_neg + END IF + END IF + END DO loop_neg + + loop_pos : DO j = jts , MIN(jde-1,jte) + IF ( xlat(its,j) .GT. 0.0 ) THEN + IF ( xlat(its,j) .GE. fft_filter_lat ) THEN + j_lat_pos = j + EXIT loop_pos + END IF + END IF + END DO loop_pos + + ! Initialize the starting values for the averages. + + DO k = kts, kte + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tr_in(i,j) = tr3d_in(i,k,j) + tr_out(i,j) = tr_in(i,j) + END DO + END DO + + ! Filter the fields at the negative lats. + + DO j = MIN(j_lat_neg,jte) , jts , -1 +! i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 ) + i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 ) +! WRITE (message,FMT='(a,i4,a,i4,f6.2,1x,f6.1,f6.1)') 'DAVE SOUTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j),mf_fft +! CALL wrf_debug ( 0 , TRIM(message) ) + DO i = its , MIN(ide-1,ite) + sum = 0. + count = 0 + DO ik = 1 , i_kicker/2 + ii = i-ik + IF ( ii .GE. ids ) THEN + i_left = ii + ELSE + i_left = ( ii - ids ) + (ide-1)+1 + END IF + ii = i+ik + IF ( ii .LE. ide-1 ) THEN + i_right = ii + ELSE + i_right = ( ii - (ide-1) ) + its-1 + END IF + sum = sum + tr_in(i_left,j) + tr_in(i_right,j) + count = count + 1 + END DO + tr_out(i,j) = ( tr_in(i,j) + sum ) / REAL ( 2 * count + 1 ) + END DO + END DO + + ! Filter the fields at the positive lats. + + DO j = MAX(j_lat_pos,jts) , MIN(jde-1,jte) +! i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 ) + i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 ) +! WRITE (message,FMT='(a,i4,a,i4,f6.2,1x,f6.1,f6.1)') 'DAVE NORTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j),mf_fft +! CALL wrf_debug ( 0 , TRIM(message) ) + DO i = its , MIN(ide-1,ite) + count = 0 + sum = 0. + DO ik = 1 , i_kicker/2 + ii = i-ik + IF ( ii .GE. ids ) THEN + i_left = ii + ELSE + i_left = ( ii - ids ) + (ide-1)+1 + END IF + ii = i+ik + IF ( ii .LE. ide-1 ) THEN + i_right = ii + ELSE + i_right = ( ii - (ide-1) ) + its-1 + END IF + sum = sum + tr_in(i_left,j) + tr_in(i_right,j) + count = count + 1 + END DO + tr_out(i,j) = ( tr_in(i,j) + sum ) / REAL ( 2 * count + 1 ) + END DO + END DO + + ! Set output values for whole patch. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tr3d_in(i,k,j) = tr_out(i,j) + END DO + END DO + + ! Positive definite on scalars? + + IF ( pos_def ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tr3d_in(i,k,j) = MAX( tr3d_in(i,k,j) , 0. ) + END DO + END DO + END IF + + ! Remove values at j=1 and j=jde-1 locations, set them to the rows just next to them. + + IF ( swap_pole_with_next_j ) THEN + IF ( jts .EQ. jds ) THEN + DO i = its , MIN(ide-1,ite) + tr3d_in(i,k,jts) = tr3d_in(i,k,jts+1) + END DO + END IF + + IF ( jte .EQ. jde ) THEN + DO i = its , MIN(ide-1,ite) + tr3d_in(i,k,jte-1) = tr3d_in(i,k,jte-2) + END DO + END IF + END IF + + END DO ! k-loop + + END SUBROUTINE filter_tracer + +!--------------------------------------------------------------------- + + SUBROUTINE filter_tracer_old ( tr3d_in , xlat , msftx , fft_filter_lat , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + + REAL , INTENT(IN) :: fft_filter_lat + REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: tr3d_in + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: xlat , msftx + + + ! Local vars + + INTEGER :: i , j , j_lat_pos , j_lat_neg , k + INTEGER :: i_kicker , ik , i1, i2, i3, i4 + REAL :: length_scale , sum + REAL , DIMENSION(its:ite,jts:jte) :: tr_in, tr_out + + ! The filtering is a simple average on a latitude loop. Possibly a LONG list of + ! numbers. We assume that ALL of the 2d arrays have been transposed so that + ! each patch has the entire domain size of the i-dim local. + + IF ( ( its .NE. ids ) .OR. ( ite .NE. ide ) ) THEN + CALL wrf_error_fatal ( 'filtering assumes all values on X' ) + END IF + + ! Starting at the south pole, we find where the + ! grid distance is big enough, then go back a point. Continuing to the + ! north pole, we find the first small grid distance. These are the + ! computational latitude loops and the associated computational poles. + + j_lat_neg = 0 + j_lat_pos = jde + 1 + loop_neg : DO j = jts , MIN(jde-1,jte) + IF ( xlat(its,j) .LT. 0.0 ) THEN + IF ( ABS(xlat(its,j)) .LT. fft_filter_lat ) THEN + j_lat_neg = j - 1 + EXIT loop_neg + END IF + END IF + END DO loop_neg + + loop_pos : DO j = jts , MIN(jde-1,jte) + IF ( xlat(its,j) .GT. 0.0 ) THEN + IF ( xlat(its,j) .GE. fft_filter_lat ) THEN + j_lat_pos = j + EXIT loop_pos + END IF + END IF + END DO loop_pos + + ! Set output values to initial input topo values for whole patch. + + DO k = kts, kte + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tr_in(i,j) = tr3d_in(i,k,j) + tr_out(i,j) = tr_in(i,j) + END DO + END DO + + ! Filter the topo at the negative lats. + + DO j = j_lat_neg , jts , -1 + i_kicker = MIN( MAX ( NINT(msftx(its,j)) , 1 ) , (ide - ids) / 2 ) +! print *,'j = ' , j, ', kicker = ',i_kicker + DO i = its , MIN(ide-1,ite) + IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN + sum = 0.0 + DO ik = 1 , i_kicker + sum = sum + tr_in(i+ik,j) + tr_in(i-ik,j) + END DO + tr_out(i,j) = ( tr_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) + ELSE IF ( ( i - i_kicker .LT. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN + sum = 0.0 + DO ik = 1 , i_kicker + sum = sum + tr_in(i+ik,j) + END DO + i1 = i - i_kicker + ide -1 + i2 = ide-1 + i3 = ids + i4 = i-1 + DO ik = i1 , i2 + sum = sum + tr_in(ik,j) + END DO + DO ik = i3 , i4 + sum = sum + tr_in(ik,j) + END DO + tr_out(i,j) = ( tr_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) + ELSE IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .GT. ide-1 ) ) THEN + sum = 0.0 + DO ik = 1 , i_kicker + sum = sum + tr_in(i-ik,j) + END DO + i1 = i+1 + i2 = ide-1 + i3 = ids + i4 = ids + ( i_kicker+i ) - ide + DO ik = i1 , i2 + sum = sum + tr_in(ik,j) + END DO + DO ik = i3 , i4 + sum = sum + tr_in(ik,j) + END DO + tr_out(i,j) = ( tr_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) + END IF + END DO + END DO + + ! Filter the topo at the positive lats. + + DO j = j_lat_pos , MIN(jde-1,jte) + i_kicker = MIN( MAX ( NINT(msftx(its,j)) , 1 ) , (ide - ids) / 2 ) +! print *,'j = ' , j, ', kicker = ',i_kicker + DO i = its , MIN(ide-1,ite) + IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN + sum = 0.0 + DO ik = 1 , i_kicker + sum = sum + tr_in(i+ik,j) + tr_in(i-ik,j) + END DO + tr_out(i,j) = ( tr_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) + ELSE IF ( ( i - i_kicker .LT. its ) .AND. ( i + i_kicker .LE. ide-1 ) ) THEN + sum = 0.0 + DO ik = 1 , i_kicker + sum = sum + tr_in(i+ik,j) + END DO + i1 = i - i_kicker + ide -1 + i2 = ide-1 + i3 = ids + i4 = i-1 + DO ik = i1 , i2 + sum = sum + tr_in(ik,j) + END DO + DO ik = i3 , i4 + sum = sum + tr_in(ik,j) + END DO + tr_out(i,j) = ( tr_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) + ELSE IF ( ( i - i_kicker .GE. its ) .AND. ( i + i_kicker .GT. ide-1 ) ) THEN + sum = 0.0 + DO ik = 1 , i_kicker + sum = sum + tr_in(i-ik,j) + END DO + i1 = i+1 + i2 = ide-1 + i3 = ids + i4 = ids + ( i_kicker+i ) - ide + DO ik = i1 , i2 + sum = sum + tr_in(ik,j) + END DO + DO ik = i3 , i4 + sum = sum + tr_in(ik,j) + END DO + tr_out(i,j) = ( tr_in(i,j) + sum ) / REAL ( 2 * i_kicker + 1 ) + END IF + END DO + END DO + + ! Set output values to initial input topo values for whole patch. + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + tr3d_in(i,k,j) = tr_out(i,j) + END DO + END DO + END DO ! k-loop + + END SUBROUTINE filter_tracer_old + +!--------------------------------------------------------------------- END MODULE module_polarfft diff --git a/wrfv2_fire/dyn_em/module_small_step_em.F b/wrfv2_fire/dyn_em/module_small_step_em.F index ef563918..b5eae643 100644 --- a/wrfv2_fire/dyn_em/module_small_step_em.F +++ b/wrfv2_fire/dyn_em/module_small_step_em.F @@ -22,7 +22,7 @@ SUBROUTINE small_step_prep( u_1, u_2, v_1, v_2, w_1, w_2, & u_save, v_save, w_save, & t_save, ph_save, mu_save, & ww, ww_save, & - dnw, c2a, pb, p, alt, & + c2a, pb, p, alt, & msfux, msfuy, msfvx, & msfvx_inv, & msfvy, msftx, msfty, & @@ -89,8 +89,6 @@ SUBROUTINE small_step_prep( u_1, u_2, v_1, v_2, w_1, w_2, & REAL, DIMENSION(ims:ime, jms:jme) , INTENT( OUT) :: mu_save - REAL, DIMENSION(kms:kme, jms:jme) , INTENT(IN ) :: dnw - REAL, INTENT(IN) :: rdx,rdy ! local variables diff --git a/wrfv2_fire/dyn_em/module_stoch.F b/wrfv2_fire/dyn_em/module_stoch.F index b0f4bb4b..3a88664a 100644 --- a/wrfv2_fire/dyn_em/module_stoch.F +++ b/wrfv2_fire/dyn_em/module_stoch.F @@ -16,7 +16,7 @@ module module_stoch ! ! Berner, J., S.-Y. Ha, J. P. Hacker, A. Fournier and C. Snyder 2011: ! "Model uncertainty in a mesoscale ensemble prediction system: Stochastic -! versus multi-physics representations", 2011, Mon. Wea. Rev., 139, 1972—1995 +! versus multi-physics representations", 2011, Mon. Wea. Rev., 139, 1972-1995 ! http://journals.ametsoc.org/doi/abs/10.1175/2010MWR3595.1 ! ! Features: @@ -28,7 +28,7 @@ module module_stoch ! Optional namelist parameters: ! stoch_force_opt = 0, 0, 0: No stochastic parameterization ! = 1, 1, 1: Use SKEB scheme -! stoch_vertstruc_opt = 0, 0, 0: Constant vertical structure of random pattern generator +! skebs_vertstruc = 0, 0, 0: Constant vertical structure of random pattern generator ! = 1, 1, 1: Random phase vertical structure random pattern generator ! tot_backscat_psi : Total backscattered dissipation rate for streamfunction; Controls ! amplitude of rotational wind perturbations Default value is 1.0E-5 m2/s3. @@ -65,8 +65,9 @@ module module_stoch !************** DECLARE FIELDS AND VARIABLES FOR STOCHASTIC BACKSCATTER ! ------------------------------------------------------------------ implicit none - public :: SETUP_STOCH_SKEBS, SETUP_STOCH_SPPT, UPDATE_STOCH,& - do_fftback_along_x,do_fftback_along_y, SP2GP_prep + public :: SETUP_RAND_PERTURB, UPDATE_STOCH,& + do_fftback_along_x,do_fftback_along_y,& + rand_pert_update INTEGER :: LMINFORC, LMAXFORC, KMINFORC, KMAXFORC, & & LMINFORCT, LMAXFORCT, KMINFORCT, KMAXFORCT @@ -75,7 +76,7 @@ module module_stoch ! ----------Fields for spectral transform ----------- INTEGER :: LENSAV - INTEGER,ALLOCATABLE:: wavenumber_k(:), wavenumber_l(:),ISEED(:) + INTEGER,ALLOCATABLE:: wavenumber_k(:), wavenumber_l(:) REAL, ALLOCATABLE :: WSAVE1(:),WSAVE2(:) ! --------- Others ------------------------------------------------- @@ -89,324 +90,225 @@ module module_stoch !======================================================================= contains !======================================================================= - -! ------------------------------------------------------------------ -!!******** INITIALIZE STOCHASTIC KINETIC ENERGY BACKSCATTER (SKEB) ***** ! ------------------------------------------------------------------ - - subroutine SETUP_STOCH_SKEBS( & - VERTSTRUCC,VERTSTRUCS, & - SPT_AMP,SPSTREAM_AMP, & - VERTAMPT,VERTAMPUV, & - stoch_vertstruc_opt, & - ISEED1,ISEED2,itime_step,DX,DY, & - TOT_BACKSCAT_PSI,TOT_BACKSCAT_T, & - ZTAU_PSI,ZTAU_T,REXPONENT_PSI,REXPONENT_T, & - KMINFORC,KMAXFORCH,LMINFORC,LMAXFORCH, & - KMINFORCT,KMAXFORCTH,LMINFORCT,LMAXFORCTH, & - KMAXFORC,LMAXFORC,KMAXFORCT,LMAXFORCT, & - ZSIGMA2_EPSH,ZSIGMA2_ETAH, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) +! This subroutine drives the initialization of the stochastic schemes + + SUBROUTINE INITIALIZE_STOCH (grid, config_flags, & + first_trip_for_this_domain, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + imsx, imex, jmsx, jmex, kmsx, kmex, & + ipsx, ipex, jpsx, jpex, kpsx, kpex, & + imsy, imey, jmsy, jmey, kmsy, kmey, & + ipsy, ipey, jpsy, jpey, kpsy, kpey ) + + + USE module_configure + USE module_domain, ONLY : domain +#ifdef DM_PARALLEL + USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, & + wrf_dm_maxval, wrf_err_message, local_communicator_x, local_communicator_y, data_order_xzy +#endif IMPLICIT NONE - INTEGER :: IER,IK,IL,iseed1,iseed2,I,J - INTEGER :: itime_step,stoch_vertstruc_opt - INTEGER :: KMAX,LMAX,LENSAV,ILEV - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - INTEGER :: KMINFORC,LMINFORC,KMINFORCT,LMINFORCT - INTEGER :: KMAXFORC,LMAXFORC,KMAXFORCT,LMAXFORCT - INTEGER :: KMAXFORCH,LMAXFORCH,KMAXFORCTH,LMAXFORCTH - REAL :: ZSIGMA2_EPSH,ZSIGMA2_ETAH - REAL :: DX,DY,RY,RX,RATIO_BACKSCAT,TOT_BACKSCAT_PSI,TOT_BACKSCAT_T - REAL :: ZGAMMAN,ZGAMMAT,ZTAU_PSI,ZTAU_T,ZCONSTF0,ZCONSTF0T,ZSIGMA2_EPS,ZSIGMA2_ETA,RHOKLMAX,ZREF,RHOKL,EPS - REAL :: REXPONENT_PSI,REXPONENT_T - REAL :: ZNORM1,ZNORM2 - REAL, DIMENSION (ims:ime,kms:kme,jms:jme) :: VERTSTRUCC,VERTSTRUCS - REAL, DIMENSION (ims:ime,jms:jme) :: SPSTREAM_AMP,SPT_AMP - REAL, DIMENSION (ids:ide,jds:jde) :: ZCHI,ZCHIT - REAL, DIMENSION (kms:kme ) :: VERTAMPT,VERTAMPUV - LOGICAL :: is_print = .true. - INTEGER , ALLOCATABLE , DIMENSION(:) :: iseed - INTEGER :: how_many - LOGICAL , EXTERNAL :: wrf_dm_on_monitor + TYPE (grid_config_rec_type) :: config_flags + TYPE ( domain ), INTENT(INOUT) :: grid - -! --------- SETUP PARAMETERS --------------------------------------- - KMAX=(jde-jds)+1 !NLAT - LMAX=(ide-ids)+1 !NLON - RY= KMAX*DY - RX= LMAX*DX - LENSAV= 4*(KMAX+LMAX)+INT(LOG(REAL(KMAX))) + INT(LOG(REAL(LMAX))) + 8 + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey -! --------- ALLOCATE FIELDS FOR FFTPACK---------------------------- - IF ( ALLOCATED(WSAVE1) ) DEALLOCATE(WSAVE1) - IF ( ALLOCATED(WSAVE2) ) DEALLOCATE(WSAVE2) - ALLOCATE(WSAVE1(LENSAV),WSAVE2(LENSAV)) + LOGICAL :: first_trip_for_this_domain + INTEGER :: K - IF ( ALLOCATED(WAVENUMBER_K)) DEALLOCATE(WAVENUMBER_K) - IF ( ALLOCATED(WAVENUMBER_L)) DEALLOCATE(WAVENUMBER_L) - ALLOCATE (wavenumber_k(jds:jde),wavenumber_l(ids:ide)) -! -------- INITIALIZE FFTPACK ROUTINES ----------------------------- - call CFFT1I (LMAX, WSAVE1, LENSAV, IER) - if(ier.ne. 0) write(*,95) ier + IF ( first_trip_for_this_domain ) THEN + grid%did_stoch = .FALSE. + END IF - call CFFT1I (KMAX, WSAVE2, LENSAV, IER) - if(ier.ne. 0) write(*,95) ier - 95 format('error in cFFT2I= 'i5) + IF ((( grid%id == 1) .AND. (.NOT. grid%did_stoch)) .AND. & + (( grid%skebs_on== 1) .OR.( grid%sppt_on== 1) .OR. ( grid%rand_perturb_on== 1))) THEN - call findindex( wavenumber_k, wavenumber_l, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) + grid%did_stoch = .TRUE. -! ---------- INITIAIZE STOCHASTIC KINETIC ENERGY BACKSCATTER PARAMETERS----------- -! REXPONENT_PSI=-1.83 !produces 2(p+1) kinetic energy spectra % p=-11/6=1.83 => k=-5/3 -! REXPONENT_T=-1.83 ! - KMAXFORC =min0(((ide-ids)+1)/2,((jde-jds)+1 )/2)-5 - LMAXFORC =KMAXFORC - KMAXFORCT=min0(((ide-ids)+1)/2,((jde-jds)+1 )/2)-5 - LMAXFORCT=KMAXFORCT - if (KMAXFORC > KMAXFORCH) then - KMAXFORC=KMAXFORCH - endif - if (LMAXFORC > LMAXFORCH) then - LMAXFORC=LMAXFORCH + IF (grid%skebs_on==1) then + +! Initialize SKEBS +! Initialize streamfunction (1) + if (.not.config_flags%restart) then + call rand_seed (config_flags, grid%ISEED_SKEBS, grid%iseedarr_skebs , kms, kme) endif - if (KMAXFORCT > KMAXFORCTH) then - KMAXFORCT=KMAXFORCTH + call SETUP_RAND_PERTURB('W', & + grid%skebs_vertstruc,config_flags%restart, & + grid%SPSTREAM_AMP, & + grid%SPSTREAMFORCS,grid%SPSTREAMFORCC,grid%ALPH_PSI,& + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPUV, & + grid%KMINFORCT,grid%KMAXFORCT, & + grid%LMINFORCT,grid%LMAXFORCT, & + grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%time_step,grid%DX,grid%DY, & + grid%gridpt_stddev_sppt, & + grid%lengthscale_sppt, & + grid%timescale_sppt, & + grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI, & + grid%REXPONENT_PSI, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +! Initialize potential temperature (2) + call SETUP_RAND_PERTURB('T', & + grid%skebs_vertstruc,config_flags%restart, & + grid%SPT_AMP, & + grid%SPTFORCS,grid%SPTFORCC,grid%ALPH_T, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT, & + grid%KMINFORCT,grid%KMAXFORCT, & + grid%LMINFORCT,grid%LMAXFORCT, & + grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%time_step,grid%DX,grid%DY, & + grid%gridpt_stddev_sppt, & + grid%lengthscale_sppt, & + grid%timescale_sppt, & + grid%TOT_BACKSCAT_T,grid%ZTAU_T, & + grid%REXPONENT_T, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF + +IF (grid%sppt_on==1) then +! Initialize SPPT (3) + if (.not.config_flags%restart) then ! set random number seed (else iseedarray is read in from restart files) + call rand_seed (config_flags, grid%ISEED_SPPT, grid%iseedarr_sppt , kms, kme) endif - if (LMAXFORCT > LMAXFORCTH) then - LMAXFORCT=LMAXFORCTH + call SETUP_RAND_PERTURB('P', & + grid%sppt_vertstruc,config_flags%restart, & + grid%SPPT_AMP, & + grid%SPPTFORCC,grid%SPPTFORCS,grid%ALPH_SPPT, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT, & + grid%KMINFORCT,grid%KMAXFORCT, & + grid%LMINFORCT,grid%LMAXFORCT, & + grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%time_step,grid%DX,grid%DY, & + grid%gridpt_stddev_sppt, & + grid%lengthscale_sppt, & + grid%timescale_sppt, & + grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI, & + grid%REXPONENT_PSI, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF + +! Initialize RAND_PERTURB (4) + IF (grid%rand_perturb_on==1) then + if (.not.config_flags%restart) then ! set random number seed (else iseedarray is read in from restart files) + call rand_seed (config_flags, grid%ISEED_RAND_PERT, grid%iseedarr_rand_pert , kms, kme) endif - - - ALPH_PSI = float(itime_step)/ZTAU_PSI ! approximation of 1.-exp(-itime_step/ZTAU_PSI) - ALPH_T = float(itime_step)/ZTAU_PSI ! approximation of 1.-exp(-itime_step/ZTAU_T) - ZSIGMA2_EPS=1./(12.0*ALPH_PSI) - ZSIGMA2_ETA=1./(12.0*ALPH_T) - -! Output of stochastic settings - if (is_print) then - WRITE(*,'('' '')') - WRITE(*,'('' =============================================='')') - WRITE(*,'('' >> Initializing stochastic kinetic-energy backscatter scheme << '')') - WRITE(*,'('' Total backscattered energy, TOT_BACKSCAT_PSI '',E12.5)') TOT_BACKSCAT_PSI - WRITE(*,'('' Total backscattered temperature, TOT_BACKSCAT_T '',E12.5)') TOT_BACKSCAT_T - WRITE(*,'('' Exponent for energy spectra, REXPONENT_PSI ='',E12.5)') REXPONENT_PSI - WRITE(*,'('' Exponent for temperature spectra, REXPONENT_T ='',E12.5)') REXPONENT_T - WRITE(*,'('' Minimal wavenumber of streamfunction forcing, LMINFORC ='',I10)') LMINFORC - WRITE(*,'('' Maximal wavenumber of streamfunction forcing, LMAXFORC ='',I10)') LMAXFORC - WRITE(*,'('' Minimal wavenumber of streamfunction forcing, KMINFORC ='',I10)') KMINFORC - WRITE(*,'('' Maximal wavenumber of streamfunction forcing, KMAXFORC ='',I10)') KMAXFORC - WRITE(*,'('' Minimal wavenumber of temperature forcing, LMINFORCT ='',I10)') LMINFORCT - WRITE(*,'('' Maximal wavenumber of temperature forcing, LMAXFORCT ='',I10)') LMAXFORCT - WRITE(*,'('' Minimal wavenumber of temperature forcing, KMINFORCT ='',I10)') KMINFORCT - WRITE(*,'('' Maximal wavenumber of temperature forcing, KMAXFORCT ='',I10)') KMAXFORCT - WRITE(*,'('' stoch_vertstruc_opt '',I10)') stoch_vertstruc_opt - WRITE(*,'('' Time step: itime_step='',I10)') itime_step - WRITE(*,'('' Decorrelation time of noise, ZTAU_PSI ='',E12.5)') ZTAU_PSI - WRITE(*,'('' Decorrelation time of noise, ZTAU_T ='',E12.5)') ZTAU_T - WRITE(*,'('' Variance of noise, ZSIGMA2_EPS ='',E12.5)') ZSIGMA2_EPS - WRITE(*,'('' Variance of noise, ZSIGMA2_ETA ='',E12.5)') ZSIGMA2_ETA - WRITE(*,'('' Autoregressive parameter 1-ALPH_PSI ='',E12.5)') 1.-ALPH_PSI - WRITE(*,'('' Autoregressive parameter 1-ALPH_T ='',E12.5)') 1.-ALPH_T - WRITE(*,'('' =============================================='')') - endif - -! ---------- INITIALIZE NOISE AMPLITUDES ---------------------------------- -! Amplitudes for streamfunction and temperature perturbations: SPSTREAM_AMP , SPT_AMP -! Unit of SPSTREAM_AMP: sqrt(m^2/s^3 1/s m**2(p+1)) m**-2(p/2) = m^/s^2 * m**[(p+1)-p] = m^2/s^2 m - -! First the constants: - ZCHI = 0.0 - ZGAMMAN = 0.0 - ! Fill lower left quadrant of ZCHI. For this range the indeces IK,IL - DO IK=jds-1,jde ! These are now wavenumbers - DO IL=ids-1,ide - if (((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((KMAXFORC+0.5)/RX)).and.& - (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((KMINFORC-0.5)/RX))) .or. & - ((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((LMAXFORC+0.5)/RX)).and.& - (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((LMINFORC-0.5)/RX))))then - if ((IK>0).or.(IL>0)) then - ZCHI(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT_PSI/2.) - ZGAMMAN= ZGAMMAN + ((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT_PSI+1) - endif - endif - enddo - enddo - ZGAMMAN=4.0*ZGAMMAN !account for all quadrants, although only one is Filled - ZCONSTF0=SQRT(ALPH_PSI*TOT_BACKSCAT_PSI/(float(itime_step)*ZSIGMA2_EPS*ZGAMMAN))/(2*RPI) - - ZCHIT = 0.0 - ZGAMMAT = 0.0 - ! Fill lower left quadrant of ZCHI. For this range the indeces IK,IL - DO IK=jds-1,jde ! These are now wavenumbers - DO IL=ids-1,ide - if (((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((KMAXFORCT+0.5)/RX)).and.& - (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((KMINFORCT-0.5)/RX))) .or. & - ((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((LMAXFORCT+0.5)/RX)).and.& - (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((LMINFORCT-0.5)/RX))))then - if ((IK>0).or.(IL>0)) then - ZCHIT(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT_T/2.) - ZGAMMAT= ZGAMMAT + ((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT_T) - endif - endif - enddo - enddo - ZGAMMAT=4.0*ZGAMMAT !account for all quadrants, although only one is Filled - - -! A value TOT_BACKSCAT_T= xx m^2/S^3 means that in each gridbox and on average, -! a dissipation rate of D=TOT_BACKSCAT_T m^2/s^3 is backscattered onto the resolved temperture pattern -! The resulting units for ZCONSTF0T are m^2/s^3* (K* s^2)/m^2 = K/s , which is the unit of dT/dt - - ZCONSTF0T=SQRT(T0*ALPH_T*TOT_BACKSCAT_T/(float(itime_step)*cp*ZSIGMA2_ETA*ZGAMMAT)) + call SETUP_RAND_PERTURB('R', & + grid%rand_pert_vertstruc,config_flags%restart, & + grid%SP_AMP, & + grid%SPFORCC,grid%SPFORCS,grid%ALPH_RAND, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT, & + grid%KMINFORCT,grid%KMAXFORCT, & + grid%LMINFORCT,grid%LMAXFORCT, & + grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%time_step,grid%DX,grid%DY, & + grid%gridpt_stddev_rand_pert, & + grid%lengthscale_rand_pert, & + grid%timescale_rand_pert, & + grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI, & + grid%REXPONENT_PSI, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (.not.config_flags%restart) then ! spin up + do k = 1,10 + CALL RAND_PERT_UPDATE(grid,'R', & + grid%SPFORCS,grid%SPFORCC, & + grid%SP_AMP,grid%ALPH_RAND, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + kts, kte, & + imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey, & + grid%num_stoch_levels,grid%num_stoch_levels, & + grid%num_stoch_levels,grid%num_stoch_levels, & + config_flags%restart, grid%iseedarr_rand_pert, & + grid%DX,grid%DY,grid%rand_pert_vertstruc, & + grid%RAND_PERT, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT ) + enddo + ENDIF !rand_perturb_on + ENDIF + + ENDIF ! skebs or sppt or rand_perturb -! Now the wavenumber-dependent amplitudes -! Note: There are symmetries and anti-symmetries to ensure real-valued back transforms -! Fill lower left quadrant of matrix of noise amplitudes for wavenumbers K=0,KMAX/2 - SPSTREAM_AMP=0.0 - SPT_AMP=0.0 - DO IK=jts,jte - DO IL=its,ite - if ((IL .le. (LMAX/2+1)) .and. (IK .le. (KMAX/2+1)) ) then - SPSTREAM_AMP(IL,IK) = ZCONSTF0 *ZCHI(IL,IK) - SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(IL,IK) - endif - ENDDO - ENDDO - - ! Fill other quadrants: - ! Upper left quadrant - DO IK=jts,jte - DO IL=its,ite - if ( (IL .gt. (LMAX/2+1)) .and. (IK .le. (KMAX/2+1)) ) then - SPSTREAM_AMP(IL,IK) = ZCONSTF0 *ZCHI(LMAX-IL+2,IK) - SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(LMAX-IL+2,IK) - endif - ENDDO - ENDDO - -! Lower right quadrant - DO IK=jts,jte - DO IL=its,ite - !if ((IK .gt. (KMAX/2+1)) .and. (IL.le.(LMAX/2)) ) then - if ((IK .gt. (KMAX/2+1)) .and. (IL.le.(LMAX/2+1)) ) then - SPSTREAM_AMP(IL,IK) = ZCONSTF0 *ZCHI(IL,KMAX-IK+2) - SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(IL,KMAX-IK+2) - endif - ENDDO - ENDDO - -! Upper right quadrant - DO IK=jts,jte - DO IL=its,ite - !if ((IK .gt. (KMAX/2+1)) .and. (IL.gt.(LMAX/2)) ) then - if ((IK .gt. (KMAX/2+1)) .and. (IL.gt.(LMAX/2+1)) ) then - SPSTREAM_AMP(IL,IK) = ZCONSTF0 *ZCHI(LMAX-IL+2,KMAX-IK+2) - SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(LMAX-IL+2,KMAX-IK+2) - endif - ENDDO - ENDDO - - - -! Array for vertical structure if desired - IF (stoch_vertstruc_opt==1) then - VERTSTRUCC=0.0 - VERTSTRUCS=0.0 - RHOKLMAX= sqrt(KMAX**2/DY**2 + LMAX**2/DX**2) - ZREF=32.0 - DO ILEV=kts,kte - DO IK=jts,jte - DO IL=its,ite - if (IL.le.(LMAX/2)) then - RHOKL = sqrt((IK+1)**2/DY**2 + (IL+1)**2/DX**2) - EPS = ((RHOKLMAX - RHOKL)/ RHOKLMAX) * (ILEV/ZREF) * RPI - VERTSTRUCC(IL,ILEV,IK) = cos ( eps* (IL+1) ) - VERTSTRUCS(IL,ILEV,IK) = sin ( eps* (IL+1) ) - else - RHOKL = sqrt((IK+1)**2/DY**2 + (LMAX-IL+2)**2/DX**2) - EPS = ((RHOKLMAX - RHOKL)/ RHOKLMAX) * (ILEV/ZREF) * RPI - VERTSTRUCC (IL,ILEV,IK) = cos ( eps* (LMAX-IL+2) ) - VERTSTRUCS (IL,ILEV,IK) = - sin ( eps* (LMAX-IL+2) ) - endif - ENDDO - ENDDO - ENDDO - ELSEIF (stoch_vertstruc_opt==2) then - VERTAMPT=1.0 ! Define vertical amplitude here. - VERTAMPUV=1.0 ! Define vertical amplitude here. - ENDIF - -! Set seed for random number generator - - CALL random_seed(size=how_many) - IF ( ALLOCATED(iseed)) DEALLOCATE(iseed) - ALLOCATE(iseed(how_many)) - IF ( wrf_dm_on_monitor() ) THEN - iseed=0 - iseed(1) = iseed1 - iseed(2) = iseed2 - call random_seed(put=iseed(1:how_many)) ! set random seed on monitor. - call random_seed(get=iseed(1:how_many)) - END IF -#ifdef DM_PARALLEL - CALL wrf_dm_bcast_integer ( iseed , how_many ) - CALL random_seed(put=iseed(1:how_many)) ! set random seed on each proc -#endif - - END subroutine SETUP_STOCH_SKEBS + END SUBROUTINE INITIALIZE_STOCH ! ------------------------------------------------------------------ -!!******** INITIALIZE STOCHASTICALLY PERTURBED PHYSICAL TENDENCY (SPPT) scheme ***** +!!******** INITIALIZE STOCHASTIC SCHEMES **************************** ! ------------------------------------------------------------------ - subroutine SETUP_STOCH_SPPT( & - VERTSTRUCC,VERTSTRUCS, & - SPT_AMP, & - SPTFORCC,SPTFORCS, & - VERTAMPT,VERTAMPUV, & - stoch_vertstruc_opt, & - ISEED1,ISEED2,itime_step,DX,DY, & - gridpointvariance, l_sppt, tau_sppt, & + subroutine SETUP_RAND_PERTURB( variable_in,& + skebs_vertstruc,restart, & + SP_AMP,SPFORCC,SPFORCS,ALPH, & + VERTSTRUCC,VERTSTRUCS,VERTAMP, & KMINFORCT,KMAXFORCTH,LMINFORCT,LMAXFORCTH, & KMAXFORCT,LMAXFORCT, & + itime_step,DX,DY, & + gridpt_stddev_rand_perturb, l_rand_perturb, & + tau_rand_perturb, & + TOT_BACKSCAT,ZTAU,REXPONENT, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) + IMPLICIT NONE - INTEGER :: IER,IK,IL,iseed1,iseed2,I,J - INTEGER :: itime_step,stoch_vertstruc_opt - INTEGER :: KMAX,LMAX,LENSAV,ILEV - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - REAL :: DX,DY,RY,RX,RATIO_BACKSCAT,TOT_BACKSCAT_PSI,TOT_BACKSCAT_T - REAL :: ZGAMMAN,ZCONSTF0,ZCONSTF0T,ZSIGMA2_EPS, RHOKLMAX,ZREF,RHOKL,EPS - REAL :: z,phi,gridpointvariance,kappat,tau_sppt,l_sppt,sum - INTEGER :: KMINFORCT,LMINFORCT,KMAXFORCT,LMAXFORCT,KMAXFORCTH,LMAXFORCTH - REAL, DIMENSION (kms:kme ) :: VERTAMPT,VERTAMPUV + +! General control + LOGICAL :: restart + REAL, PARAMETER :: RPI= 3.141592653589793 !4.0*atan(1.0) + CHARACTER, INTENT(IN) :: variable_in ! W=SKEBS_PSI, T=SKEBS_T, P=SPPT, R=RAND_PERTURB + CHARACTER :: variable + +! Common to all schemes + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER :: IER,IK,IL,I,J,itime_step,skebs_vertstruc, & + KMINFORCT,LMINFORCT,KMAXFORCT,LMAXFORCT,KMAXFORCTH,LMAXFORCTH, & + KMAX,LMAX,LENSAV,ILEV + REAL :: DX,DY,RY,RX,ALPH,RHOKLMAX,ZREF,RHOKL,EPS + REAL, DIMENSION (ims:ime,jms:jme) :: SPFORCS,SPFORCC,SP_AMP REAL, DIMENSION (ims:ime,kms:kme,jms:jme) :: VERTSTRUCC,VERTSTRUCS - REAL, DIMENSION (ims:ime,jms:jme) :: SPSTREAM_AMP,SPT_AMP - REAL, DIMENSION (ids:ide,jds:jde) :: ZCHI,ZCHIT - REAL, DIMENSION (ims:ime,jms:jme) :: SPTFORCS,SPTFORCC - REAL, DIMENSION (ims:ime,jms:jme) :: var_sigma1 - LOGICAL :: is_print = .true. - INTEGER , ALLOCATABLE , DIMENSION(:) :: iseed - INTEGER :: how_many + REAL, DIMENSION (kms:kme) :: VERTAMP + REAL, DIMENSION (ids:ide,jds:jde) :: ZCHI - LOGICAL , EXTERNAL :: wrf_dm_on_monitor +! SPPT and perturb_rand specific + REAL :: gridpt_stddev_rand_perturb,kappat,tau_rand_perturb,l_rand_perturb + REAL, DIMENSION (ims:ime,jms:jme) :: var_sigma1 - + +! SKEBS specific + REAL :: z,phi,ZGAMMAN,ZCONSTF0,TOT_BACKSCAT,ZTAU,REXPONENT,ZSIGMA2 + LOGICAL :: is_print = .true. + + + variable = variable_in ! --------- SETUP PARAMETERS --------------------------------------- KMAX=(jde-jds)+1 !NLAT LMAX=(ide-ids)+1 !NLON @@ -431,19 +333,14 @@ subroutine SETUP_STOCH_SPPT( & call CFFT1I (KMAX, WSAVE2, LENSAV, IER) if(ier.ne. 0) write(*,95) ier - 95 format('error in cFFT2I= 'i5) + 95 format('error in cFFT2I= ',i5) call findindex( wavenumber_k, wavenumber_l, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) -! ---------- INITIALIZE STOCHASTICALLY PERTURBED PHYSICAL TENDENCY PARAMETERS----------- - - kappat= L_sppt**2 ! L^2= kappa*T, where L is a length scale in m; set to for L=100km - phi = exp (-float(itime_step)/tau_sppt) - alph = 1.-phi - +! set maximal perturbed wavenumber based on gridpoints in domain KMAXFORCT=min0(((ide-ids)+1)/2,((jde-jds)+1 )/2)-5 LMAXFORCT=KMAXFORCT if (KMAXFORCT > KMAXFORCTH) then @@ -453,39 +350,95 @@ subroutine SETUP_STOCH_SPPT( & LMAXFORCT=LMAXFORCTH endif -! Output of stochastic settings + +! -------------------------------------------------------------------------------------- +! ---------- INITIALIZE STOCHASTIC KINETIC-ENERGY BACKSCATTER SCHEME (SKEBS) ---------- +! -------------------------------------------------------------------------------------- + ALPH = float(itime_step)/ZTAU ! approximation of 1.-exp(-itime_step/ZTAU_PSI) + ZSIGMA2=1./(12.0*ALPH) + if (is_print) then + IF (variable == 'W') then WRITE(*,'('' '')') WRITE(*,'('' =============================================='')') - WRITE(*,'('' >> Initializing stochastically perturbed physical tendencies (SPPT) scheme << '')') - WRITE(*,'('' Minimal wavenumber of temperature forcing, KMINFORCT ='',I10)') KMINFORCT - WRITE(*,'('' Maximal wavenumber of temperature forcing, KMAXFORCT ='',I10)') KMAXFORCT - WRITE(*,'('' stoch_vertstruc_opt '',I10)') stoch_vertstruc_opt + WRITE(*,'('' >> Initializing STREAMFUNCTION forcing pattern of << '')') + WRITE(*,'('' >> stochastic kinetic-energy backscatter scheme << '')') + WRITE(*,'('' Total backscattered energy, TOT_BACKSCAT_PSI '',E12.5)') TOT_BACKSCAT + WRITE(*,'('' Exponent for energy spectra, REXPONENT_PSI ='',E12.5)') REXPONENT + WRITE(*,'('' Minimal wavenumber of streamfunction forcing, LMINFORC ='',I10)') LMINFORCT + WRITE(*,'('' Maximal wavenumber of streamfunction forcing, LMAXFORC ='',I10)') LMAXFORCT + WRITE(*,'('' Minimal wavenumber of streamfunction forcing, KMINFORC ='',I10)') KMINFORCT + WRITE(*,'('' Maximal wavenumber of streamfunction forcing, KMAXFORC ='',I10)') KMAXFORCT + WRITE(*,'('' skebs_vertstruc '',I10)') skebs_vertstruc WRITE(*,'('' Time step: itime_step='',I10)') itime_step - WRITE(*,'('' Decorrelation time of noise, tau_sppt ='',E12.5)') TAU_sppt - WRITE(*,'('' Autoregressive parameter phi ='',E12.5)') phi - WRITE(*,'('' Length Scale l_sppt'',E12.5)') l_sppt - WRITE(*,'('' Variance in gridpoint space'',E12.5)') gridpointvariance + WRITE(*,'('' Decorrelation time of noise, ZTAU_PSI ='',E12.5)') ZTAU + WRITE(*,'('' Variance of noise, ZSIGMA2_EPS ='',E12.5)') ZSIGMA2 + WRITE(*,'('' Autoregressive parameter 1-ALPH_PSI ='',E12.5)') 1.-ALPH + WRITE(*,'('' =============================================='')') + +! Unit of SPSTREAM_AMP: sqrt(m^2/s^3 1/s m**2(p+1)) m**-2(p/2) = m^/s^2 * m**[(p+1)-p] = m^2/s^2 m + ELSEIF (variable == 'T') then + WRITE(*,'('' '')') + WRITE(*,'('' =============================================='')') + WRITE(*,'('' >> Initializing TEMPERATURE forcing pattern of << '')') + WRITE(*,'('' >> stochastic kinetic-energy backscatter scheme << '')') + WRITE(*,'('' Total backscattered energy, TOT_BACKSCAT_T '',E12.5)') TOT_BACKSCAT + WRITE(*,'('' Exponent for energy spectra, REXPONENT_T ='',E12.5)') REXPONENT + WRITE(*,'('' Minimal wavenumber of tempearature forcing, LMINFORC ='',I10)') LMINFORCT + WRITE(*,'('' Maximal wavenumber of tempearature forcing, LMAXFORC ='',I10)') LMAXFORCT + WRITE(*,'('' Minimal wavenumber of tempearature forcing, KMINFORC ='',I10)') KMINFORCT + WRITE(*,'('' Maximal wavenumber of tempearature forcing, KMAXFORC ='',I10)') KMAXFORCT + WRITE(*,'('' skebs_vertstruc '',I10)') skebs_vertstruc + WRITE(*,'('' Decorrelation time of noise, ZTAU_T ='',E12.5)') ZTAU + WRITE(*,'('' Variance of noise, ZSIGMA2_ETA ='',E12.5)') ZSIGMA2 + WRITE(*,'('' Autoregressive parameter 1-ALPH_T ='',E12.5)') 1.-ALPH WRITE(*,'('' =============================================='')') endif -! Modify ZGAMMAN,ZCONSTF0,ZCHIT for SPPT: -! Constants for spherical harmonics (Palmer et al. 2009) -! ZCONSTF0T= F_0= (var(r)*(1-phi^2)/( 2* sum_n=1^N (2n+1) exp(−κTn(n+1)))^(1./2.) -! ZCHIT(IL,IK) = sigma_n/F_0= exp(−κTn(n+1)/2) + IF ((variable == 'P') .or. (variable == 'R')) then + kappat= L_rand_perturb**2 ! L^2= kappa*T, where L is a length scale in m; set to for L=100km + phi = exp (-float(itime_step)/tau_rand_perturb) + alph = 1.-phi + endif -! Constants for double period boundary domain -! gridpointvariance=1.0 -! ZCONSTF0T=F0= sqrt((gridpointvariance*(1 − phi**2))/ZGAMMAN) -! ZCHIT(IL,IK) =ZCONSTF0T * exp( -2*RPI**2*kappat*((IK/RY*IK/RY)+(IL/RX*IL/RX)) ) +! -------------------------------------------------------------------------------------- +! ---------- INITIALIZE STOCHASTICALLY PERTURBED PHYSICAL TENDENCY SCHEME -------------- +! -------------------------------------------------------------------------------------- + if (variable == 'P') then + WRITE(*,'('' '')') + WRITE(*,'('' =============================================='')') + WRITE(*,'('' >> Initializing Stochastically Perturbed Physics Tendency scheme << '')') + WRITE(*,'('' sppt_vertstruc '',I10)') skebs_vertstruc + WRITE(*,'('' Time step: itime_step='',I10)') itime_step + WRITE(*,'('' Decorrelation time of noise, Tau ='',E12.5)') tau_rand_perturb + WRITE(*,'('' Autoregressive parameter Phi ='',E12.5)') phi + WRITE(*,'('' Length Scale L'',E12.5)') l_rand_perturb + WRITE(*,'('' Variance in gridpoint space'',E12.5)') gridpt_stddev_rand_perturb + WRITE(*,'('' =============================================='')') + endif ! variable -! Use existing code and inteprete in the following manner: -! SPT_AMP(IL,IK) (set in line 287) is sigma_kl in eq. 14 of Palmer et al 2009 -! (1-alph) is phi in eq. 14 of Palmer et al 2009 -! for propagator see line 416 : -! SPTFORCC(IL,IK) = (1.-ALPH)*SPTFORCC(IL,IK) + SPT_AMP(IL,IK) *(ZRANDNOSC2(IL,IK)) +! -------------------------------------------------------------------------------------- +! -------------------- INITIALIZE RANDOM PERTUBATIONS ------------------------------- +! -------------------------------------------------------------------------------------- + if (variable == 'R') then + WRITE(*,'('' '')') + WRITE(*,'('' =============================================='')') + WRITE(*,'('' >> Initializing random pertubations << '')') + WRITE(*,'('' rand_pert_vertstruc '',I10)') skebs_vertstruc + WRITE(*,'('' Time step: itime_step='',I10)') itime_step + WRITE(*,'('' Decorrelation time of noise, Tau ='',E12.5)') tau_rand_perturb + WRITE(*,'('' Autoregressive parameter Phi ='',E12.5)') phi + WRITE(*,'('' Length Scale L'',E12.5)') l_rand_perturb + WRITE(*,'('' Variance in gridpoint space'',E12.5)') gridpt_stddev_rand_perturb + WRITE(*,'('' =============================================='')') + endif ! variable + endif !is print - ZCHIT = 0.0 +! -------------------------------------------------------------------------------------- +! Compute Normalization constants +! -------------------------------------------------------------------------------------- + + ZCHI = 0.0 ZGAMMAN = 0.0 ! Fill lower left quadrant of ZCHI. For this range the indeces IK,IL DO IK=jds-1,jde ! These are now wavenumbers @@ -495,24 +448,40 @@ subroutine SETUP_STOCH_SPPT( & ((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((LMAXFORCT+0.5)/RX)).and.& (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((LMINFORCT-0.5)/RX))))then if ((IK>0).or.(IL>0)) then - ZCHIT(IL+1,IK+1)=exp( -2*RPI**2*kappat*((IK/RY*IK/RY)+(IL/RX*IL/RX)) ) !SPPT - ZGAMMAN= ZGAMMAN + exp( -4*RPI**2*kappat*((IK/RY*IK/RY)+(IL/RX*IL/RX)) ) !SPPT + if (variable == 'W') then + ZCHI(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT/2.) ! SKEBS :U + ZGAMMAN= ZGAMMAN + ((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT+1) + else if (variable == 'T') then + ZCHI(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT/2.) ! SKEBS :T + ZGAMMAN= ZGAMMAN + ((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT) + else if ((variable == 'P') .or. (variable == 'R')) then + ZCHI(IL+1,IK+1)=exp( -2*RPI**2*kappat*((IK/RY*IK/RY)+(IL/RX*IL/RX)) ) !SPPT + ZGAMMAN= ZGAMMAN + exp( -4*RPI**2*kappat*((IK/RY*IK/RY)+(IL/RX*IL/RX)) ) !SPPT + endif endif endif enddo enddo ZGAMMAN=4.0*ZGAMMAN !account for all quadrants, although only one is Filled - ZCONSTF0T= sqrt(gridpointvariance*(1.-phi**2)/(2.*ZGAMMAN)) - + if (variable == 'W') then + ZCONSTF0=SQRT(ALPH*TOT_BACKSCAT/(float(itime_step)*ZSIGMA2*ZGAMMAN))/(2*RPI) + elseif (variable == 'T') then + ZCONSTF0=SQRT(T0*ALPH*TOT_BACKSCAT/(float(itime_step)*cp*ZSIGMA2*ZGAMMAN)) + elseif ((variable == 'P') .or. (variable == 'R')) then + ZCONSTF0= gridpt_stddev_rand_perturb*sqrt((1.-phi**2)/(2.*ZGAMMAN)) + endif + +! -------------------------------------------------------------------------------------- ! Now the wavenumber-dependent amplitudes +! -------------------------------------------------------------------------------------- ! Note: There are symmetries and anti-symmetries to ensure real-valued back transforms ! Fill lower left quadrant of matrix of noise amplitudes for wavenumbers K=0,KMAX/2 - SPT_AMP=0.0 + SP_AMP=0.0 DO IK=jts,jte DO IL=its,ite if ((IL .le. (LMAX/2+1)) .and. (IK .le. (KMAX/2+1)) ) then - SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(IL,IK) + SP_AMP(IL,IK) = ZCONSTF0*ZCHI(IL,IK) endif ENDDO ENDDO @@ -522,7 +491,7 @@ subroutine SETUP_STOCH_SPPT( & DO IK=jts,jte DO IL=its,ite if ( (IL .gt. (LMAX/2+1)) .and. (IK .le. (KMAX/2+1)) ) then - SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(LMAX-IL+2,IK) + SP_AMP(IL,IK) = ZCONSTF0*ZCHI(LMAX-IL+2,IK) endif ENDDO ENDDO @@ -531,7 +500,7 @@ subroutine SETUP_STOCH_SPPT( & DO IK=jts,jte DO IL=its,ite if ((IK .gt. (KMAX/2+1)) .and. (IL.le.LMAX/2) ) then - SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(IL,KMAX-IK+2) + SP_AMP(IL,IK) = ZCONSTF0*ZCHI(IL,KMAX-IK+2) endif ENDDO ENDDO @@ -540,141 +509,102 @@ subroutine SETUP_STOCH_SPPT( & DO IK=jts,jte DO IL=its,ite if ((IK .gt. (KMAX/2+1)) .and. (IL.gt.LMAX/2) ) then - SPT_AMP(IL,IK) = ZCONSTF0T*ZCHIT(LMAX-IL+2,KMAX-IK+2) + SP_AMP(IL,IK) = ZCONSTF0*ZCHI(LMAX-IL+2,KMAX-IK+2) endif ENDDO ENDDO - IF (stoch_vertstruc_opt>0) then - VERTSTRUCC=0.0 - VERTSTRUCS=0.0 - RHOKLMAX= sqrt(KMAX**2/DY**2 + LMAX**2/DX**2) - ZREF=32.0 - DO ILEV=kds,kde - DO IK=jts,jte - DO IL=its,ite - if (IL.le.(LMAX/2)) then - RHOKL = sqrt((IK+1)**2/DY**2 + (IL+1)**2/DX**2) - EPS = ((RHOKLMAX - RHOKL)/ RHOKLMAX) * (ILEV/ZREF) * RPI - VERTSTRUCC(IL,ILEV,IK) = cos ( eps* (IL+1) ) - VERTSTRUCS(IL,ILEV,IK) = sin ( eps* (IL+1) ) - VERTSTRUCC (LMAX-IL+1,ILEV,IK) = cos ( eps* (IL+1) ) - VERTSTRUCS (LMAX-IL+1,ILEV,IK) = - sin ( eps* (IL+1) ) - endif - ENDDO - ENDDO - ENDDO - ENDIF +! ----------------------------------------- +! Array for vertical structure if desired + VERTAMP=1.0 ! Define vertical amplitude here. - IF (stoch_vertstruc_opt>1) then - ! Taper off below 1300m, 1300m is at about 900hPa (correct?), for 40 levels this pressure is close to level 12 - ! => taper off for levels lower than level 14: tanh(ilev/xnorm) - ! Also taper off top: tanh(kde-ilev) - ! CAREFUL: HARDWIRED TO 40 LEVELS!!! - VERTAMPT=0.0 - VERTAMPUV=0.0 - DO ILEV=1,kde-3 - VERTAMPT(ILEV+3)=tanh(float(kde-ilev-3))+tanh(float(ilev)/2.5)-1.0 + IF (skebs_vertstruc==1) then + VERTSTRUCC=0.0 + VERTSTRUCS=0.0 + RHOKLMAX= sqrt(KMAX**2/DY**2 + LMAX**2/DX**2) + ZREF=32.0 + DO ILEV=kts,kte + DO IK=jts,jte + DO IL=its,ite + if (IL.le.(LMAX/2)) then + RHOKL = sqrt((IK+1)**2/DY**2 + (IL+1)**2/DX**2) + EPS = ((RHOKLMAX - RHOKL)/ RHOKLMAX) * (ILEV/ZREF) * RPI + VERTSTRUCC(IL,ILEV,IK) = cos ( eps* (IL+1) ) + VERTSTRUCS(IL,ILEV,IK) = sin ( eps* (IL+1) ) + else + RHOKL = sqrt((IK+1)**2/DY**2 + (LMAX-IL+2)**2/DX**2) + EPS = ((RHOKLMAX - RHOKL)/ RHOKLMAX) * (ILEV/ZREF) * RPI + VERTSTRUCC (IL,ILEV,IK) = cos ( eps* (LMAX-IL+2) ) + VERTSTRUCS (IL,ILEV,IK) = - sin ( eps* (LMAX-IL+2) ) + endif + ENDDO + ENDDO ENDDO ENDIF -! Set seed for random number generator - - CALL random_seed(size=how_many) - IF ( ALLOCATED(iseed)) DEALLOCATE(iseed) - ALLOCATE(iseed(how_many)) - IF ( wrf_dm_on_monitor() ) THEN - iseed=0 - iseed(1) = iseed1 - iseed(2) = iseed2 - call random_seed(put=iseed(1:how_many)) ! set random seed on monitor. - call random_seed(get=iseed(1:how_many)) - END IF -#ifdef DM_PARALLEL - CALL wrf_dm_bcast_integer ( iseed , how_many ) - CALL random_seed(put=iseed(1:how_many)) ! set random seed on each proc -#endif - -! Initialization of SPTFORCC - DO IK=jts,jte - DO IL=its,ite - call gauss_noise(z) - SPTFORCC(IL,IK) = (1.-phi**2)**(0.5)*SPT_AMP(IL,IK)*z - call gauss_noise(z) - SPTFORCS(IL,IK) = (1.-phi**2)**(0.5)*SPT_AMP(IL,IK)*z - ENDDO - ENDDO - - - END subroutine SETUP_STOCH_SPPT + END subroutine SETUP_RAND_PERTURB ! ------------------------------------------------------------------ -!!************** UPDATE STOCHASTIC PATTERN IN WAVENUMBER SPACE********** +!************** UPDATE STOCHASTIC PATTERN IN WAVENUMBER SPACE********** ! ------------------------------------------------------------------ - subroutine UPDATE_STOCH( & - SPSTREAMFORCS,SPSTREAMFORCC,SPTFORCS,SPTFORCC, & - SPT_AMP,SPSTREAM_AMP, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) - - IMPLICIT NONE - - REAL, DIMENSION( ids:ide,jds:jde) :: ZRANDNOSS1,ZRANDNOSC1,ZRANDNOSS2,ZRANDNOSC2 - REAL, DIMENSION (ims:ime,jms:jme) :: SPSTREAMFORCS,SPSTREAMFORCC,SPTFORCS,SPTFORCc,SPSTREAM_AMP,SPT_AMP - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - - REAL :: Z - REAL, PARAMETER :: thresh = 3.0 - INTEGER ::IL, IK,LMAX,KMAX - LOGICAL :: LGAUSS - - KMAX=(jde-jds)+1 !NLAT - LMAX=(ide-ids)+1 !NATX + subroutine UPDATE_STOCH( & + SPFORCS,SPFORCC,SP_AMP,ALPH, & + restart,iseedarr, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + IMPLICIT NONE + + REAL, DIMENSION( ids:ide,jds:jde) :: ZRANDNOSS,ZRANDNOSC + REAL, DIMENSION (ims:ime,jms:jme) :: SPFORCS,SPFORCC,SP_AMP + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER, DIMENSION (kms:kme), INTENT(INOUT) :: iseedarr + INTEGER , ALLOCATABLE , DIMENSION(:) :: iseed + REAL :: Z,ALPH + REAL, PARAMETER :: thresh = 3.0 + INTEGER ::IL, IK,LMAX,KMAX + INTEGER :: how_many + LOGICAL :: LGAUSS,RESTART + + KMAX=(jde-jds)+1 !NLAT + LMAX=(ide-ids)+1 !NATX + + CALL random_seed(size=how_many) + IF ( ALLOCATED(iseed)) DEALLOCATE(iseed) + ALLOCATE(iseed(how_many)) + iseed=iseedarr(1:how_many) + call random_seed(put=iseed(1:how_many)) ! Pick the distribution of the noise ! Random noise uses global indexes to ensure necessary symmetries and anti-symmetries ! of random forcing when run on multiple processors - LGAUSS=.true. - IF (LGAUSS) then - DO IK=jds,jde - DO IL=ids,ide - do - call gauss_noise(z) - if (abs(z)1)) then ! Upper half DO IL=its,ite - SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK)* ZRANDNOSC1(IL,IK) - SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCS(IL,IK) + SPSTREAM_AMP(IL,IK)* ZRANDNOSS1(IL,IK) - SPTFORCC(IL,IK) = (1.-ALPH_T)*SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2(IL,IK) - SPTFORCS(IL,IK) = (1.-ALPH_T)*SPTFORCS(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSS2(IL,IK) + SPFORCC(IL,IK) = (1.-ALPH)*SPFORCC(IL,IK) + SP_AMP(IL,IK) * ZRANDNOSC(IL,IK) + SPFORCS(IL,IK) = (1.-ALPH)*SPFORCS(IL,IK) + SP_AMP(IL,IK) * ZRANDNOSS(IL,IK) ENDDO ELSEIF (IK==1) then DO IL=its,ite if ((IL.le.(LMAX/2+1))) then - SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK)* ZRANDNOSC1(IL,IK) - SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCS(IL,IK) + SPSTREAM_AMP(IL,IK)* ZRANDNOSS1(IL,IK) - SPTFORCC(IL,IK) = (1.-ALPH_T)*SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2(IL,IK) - SPTFORCS(IL,IK) = (1.-ALPH_T)*SPTFORCS(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSS2(IL,IK) + SPFORCC(IL,IK) = (1.-ALPH)*SPFORCC(IL,IK) + SP_AMP(IL,IK) * ZRANDNOSC(IL,IK) + SPFORCS(IL,IK) = (1.-ALPH)*SPFORCS(IL,IK) + SP_AMP(IL,IK) * ZRANDNOSS(IL,IK) elseif ((IL.gt.(LMAX/2+1))) then - SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK)* ZRANDNOSC1(LMAX-IL+2,IK) - SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)*SPSTREAMFORCS(IL,IK) - SPSTREAM_AMP(IL,IK)* ZRANDNOSS1(LMAX-IL+2,IK) - SPTFORCC(IL,IK) = (1.-ALPH_T)*SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2(LMAX-IL+2,IK) - SPTFORCS(IL,IK) = (1.-ALPH_T)*SPTFORCS(IL,IK) - SPT_AMP(IL,IK) * ZRANDNOSS2(LMAX-IL+2,IK) + SPFORCC(IL,IK) = (1.-ALPH)*SPFORCC(IL,IK) + SP_AMP(IL,IK) * ZRANDNOSC(LMAX-IL+2,IK) + SPFORCS(IL,IK) = (1.-ALPH)*SPFORCS(IL,IK) - SP_AMP(IL,IK) * ZRANDNOSS(LMAX-IL+2,IK) endif ENDDO ENDIF @@ -711,130 +635,74 @@ subroutine UPDATE_STOCH( & if (IK.gt.(KMAX/2+1)) then ! Lower half DO IL=its,ite if (IL.le.(LMAX/2+1).and.(IL.gt.1)) then !lower left - SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK) * ZRANDNOSC1(LMAX-IL+2,KMAX-IK+2) - SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCS(IL,IK) - SPSTREAM_AMP(IL,IK) * ZRANDNOSS1(LMAX-IL+2,KMAX-IK+2) - SPTFORCC(IL,IK) = (1.-ALPH_T)* SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2(LMAX-IL+2,KMAX-IK+2) - SPTFORCS(IL,IK) = (1.-ALPH_T)* SPTFORCS(IL,IK) - SPT_AMP(IL,IK) * ZRANDNOSS2(LMAX-IL+2,KMAX-IK+2) + SPFORCC(IL,IK) = (1.-ALPH)* SPFORCC(IL,IK) + SP_AMP(IL,IK) * ZRANDNOSC(LMAX-IL+2,KMAX-IK+2) + SPFORCS(IL,IK) = (1.-ALPH)* SPFORCS(IL,IK) - SP_AMP(IL,IK) * ZRANDNOSS(LMAX-IL+2,KMAX-IK+2) elseif (IL.eq.1) then !don't exceed index - SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK) * ZRANDNOSC1( 1,KMAX-IK+2) - SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCS(IL,IK) - SPSTREAM_AMP(IL,IK) * ZRANDNOSS1( 1,KMAX-IK+2) - SPTFORCC(IL,IK) = (1.-ALPH_T)* SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2( 1,KMAX-IK+2) - SPTFORCS(IL,IK) = (1.-ALPH_T)* SPTFORCS(IL,IK) - SPT_AMP(IL,IK) * ZRANDNOSS2( 1,KMAX-IK+2) + SPFORCC(IL,IK) = (1.-ALPH)* SPFORCC(IL,IK) + SP_AMP(IL,IK) * ZRANDNOSC( 1,KMAX-IK+2) + SPFORCS(IL,IK) = (1.-ALPH)* SPFORCS(IL,IK) - SP_AMP(IL,IK) * ZRANDNOSS( 1,KMAX-IK+2) elseif (IL.gt.(LMAX/2+1)) then !lower right - SPSTREAMFORCC(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCC(IL,IK) + SPSTREAM_AMP(IL,IK) * ZRANDNOSC1(LMAX-IL+2,KMAX-IK+2) - SPSTREAMFORCS(IL,IK) = (1.-ALPH_PSI)* SPSTREAMFORCS(IL,IK) - SPSTREAM_AMP(IL,IK) * ZRANDNOSS1(LMAX-IL+2,KMAX-IK+2) - SPTFORCC(IL,IK) = (1.-ALPH_T)* SPTFORCC(IL,IK) + SPT_AMP(IL,IK) * ZRANDNOSC2(LMAX-IL+2,KMAX-IK+2) - SPTFORCS(IL,IK) = (1.-ALPH_T)* SPTFORCS(IL,IK) - SPT_AMP(IL,IK) * ZRANDNOSS2(LMAX-IL+2,KMAX-IK+2) + SPFORCC(IL,IK) = (1.-ALPH)* SPFORCC(IL,IK) + SP_AMP(IL,IK) * ZRANDNOSC(LMAX-IL+2,KMAX-IK+2) + SPFORCS(IL,IK) = (1.-ALPH)* SPFORCS(IL,IK) - SP_AMP(IL,IK) * ZRANDNOSS(LMAX-IL+2,KMAX-IK+2) endif ENDDO endif ENDDO + call random_seed(get=iseed(1:how_many)) + iseedarr=0.0 + iseedarr(1:how_many)=iseed END subroutine UPDATE_STOCH ! ------------------------------------------------------------------ -!************** ADD STOCHASTIC TENDENCIES TO PHYSICAL TENDENCIES******** -! ------------------------------------------------------------------ - SUBROUTINE CALCULATE_STOCH_TEN( & - ru_tendf,rv_tendf,t_tendf, & - GPUFORC,GPVFORC,GPTFORC, & - ru_real,rv_real,rt_real, & - mu,mub, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte, & - dt) - - IMPLICIT NONE - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - - REAL , DIMENSION(ims:ime , kms:kme, jms:jme),INTENT(INOUT) :: & - ru_tendf, rv_tendf, t_tendf, & - GPUFORC,GPVFORC,GPTFORC - - REAL , DIMENSION(ims:ime , kms:kme, jms:jme),INTENT(IN) :: & - ru_real,rv_real,rt_real - - - REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: mu,mub - - INTEGER :: I,J,K - REAL :: dt - - DO j = jts,MIN(jde-1,jte) - DO k = kts,kte-1 - DO i = its,ite - GPUFORC(i,k,j)= ru_real(i,k,j) - ENDDO - ENDDO - ENDDO - - DO j = jts,jte - DO k = kts,kte-1 - DO i = its,MIN(ide-1,ite) - GPVFORC(i,k,j)= rv_real(i,k,j) - ENDDO - ENDDO - ENDDO - - DO j = jts,MIN(jde-1,jte) - DO k = kts,kte-1 - DO i = its,MIN(ide-1,ite) - GPTFORC(i,k,j)= rt_real(i,k,j) - ENDDO - ENDDO - ENDDO - - END SUBROUTINE CALCULATE_STOCH_TEN -! ------------------------------------------------------------------ - SUBROUTINE UPDATE_STOCH_TEN(ru_tendf,rv_tendf,t_tendf, & - GPUFORC,GPVFORC,GPTFORC, & + ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch,& mu,mub, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte, & - dt ) + kte_stoch,kme_stoch ) IMPLICIT NONE INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte + its, ite, jts, jte, kts, kte, & + kte_stoch,kme_stoch REAL , DIMENSION(ims:ime , kms:kme, jms:jme),INTENT(INOUT) :: & ru_tendf, rv_tendf, t_tendf - !REAL , DIMENSION(ims:ime , kms:kme, jms:jme),INTENT(IN) :: & - REAL , DIMENSION(ims:ime , kms:kme, jms:jme) :: & - GPUFORC,GPVFORC,GPTFORC + REAL , DIMENSION(ims:ime , kms:kme_stoch, jms:jme) :: & + ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: mu,mub - INTEGER :: I,J,K + INTEGER :: I,J,K,kh REAL :: dt,xm + DO j = jts,MIN(jde-1,jte) DO k = kts,kte-1 + kh=min(k,kte_stoch) DO i = its,ite - ru_tendf(i,k,j) = ru_tendf(i,k,j) + GPUFORC(i,k,j) * (mu(i,j)+mub(i,j)) + ru_tendf(i,k,j) = ru_tendf(i,k,j) + ru_tendf_stoch(i,kh,j) * (mu(i,j)+mub(i,j)) ENDDO ENDDO ENDDO DO j = jts,jte - DO i = its,MIN(ide-1,ite) - DO k = kts,kte-1 - rv_tendf(i,k,j) = rv_tendf(i,k,j) + GPVFORC(i,k,j) * (mu(i,j)+mub(i,j)) + DO k = kts,kte-1 + kh=min(k,kte_stoch) + DO i = its,MIN(ide-1,ite) + rv_tendf(i,k,j) = rv_tendf(i,k,j) + rv_tendf_stoch(i,kh,j) * (mu(i,j)+mub(i,j)) ENDDO ENDDO ENDDO DO j = jts,MIN(jde-1,jte) DO k = kts,kte-1 + kh=min(k,kte_stoch) DO i = its,MIN(ide-1,ite) - t_tendf(i,k,j) = t_tendf(i,k,j) + GPTFORC(i,k,j) * (mu(i,j)+mub(i,j)) + t_tendf(i,k,j) = t_tendf(i,k,j) + rt_tendf_stoch(i,kh,j) * (mu(i,j)+mub(i,j)) ENDDO ENDDO ENDDO @@ -843,12 +711,13 @@ END SUBROUTINE UPDATE_STOCH_TEN ! ------------------------------------------------------------------ !!************** PERTURB PHYSICS TENDENCIES (except T) FOR SPPT ******************* ! ------------------------------------------------------------------ - subroutine perturb_physics_tend(gridpointvariance, & - sppt_thresh_fact,rstoch, & + subroutine perturb_physics_tend(gridpt_stddev_sppt, & + sppt_thresh_fact,rstoch, & ru_tendf,rv_tendf,t_tendf,moist_tend, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) + its, ite, jts, jte, kts, kte, & + kte_stoch,kme_stoch ) ! This subroutine add stochastic perturbations of the form ! @@ -862,27 +731,29 @@ subroutine perturb_physics_tend(gridpointvariance, & IMPLICIT NONE INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte + its, ite, jts, jte, kts, kte, & + kte_stoch,kme_stoch REAL , DIMENSION(ims:ime , kms:kme, jms:jme),INTENT(INOUT) :: & - ru_tendf, rv_tendf, t_tendf,moist_tend, & - rstoch - REAL :: gridpointvariance ,thresh,sppt_thresh_fact + ru_tendf, rv_tendf, t_tendf,moist_tend + REAL , DIMENSION(ims:ime,kms:kme_stoch, jms:jme),INTENT(INOUT) :: rstoch + REAL :: gridpt_stddev_sppt ,thresh,sppt_thresh_fact - INTEGER :: I,J,K + INTEGER :: I,J,K,kh ! Here the random process at each gridpoint is capped if it exceeds a value thresh - thresh=sppt_thresh_fact*sqrt(gridpointvariance) + thresh=sppt_thresh_fact*gridpt_stddev_sppt DO j = jts,jte - DO k = kts,kte-1 + DO k = kts,min(kte-1,kte_stoch-1) DO i = its,ite - if (rstoch(i,k,j).lt.-thresh) then - rstoch(i,k,j)=-thresh - endif - if (rstoch(i,k,j).gt.thresh) then - rstoch(i,k,j)=thresh - endif +! rstoch(i,k,j)=MAX(MIN(rstoch(i,k,j),thresh),-1.*thresh)) + if (rstoch(i,k,j).lt.-thresh) then + rstoch(i,k,j)=-thresh + endif + if (rstoch(i,k,j).gt.thresh) then + rstoch(i,k,j)=thresh + endif ENDDO ENDDO ENDDO @@ -890,25 +761,28 @@ subroutine perturb_physics_tend(gridpointvariance, & ! Perturb the tendencies of u,v,q,t. DO j = jts,MIN(jde-1,jte) DO k = kts,kte-1 + kh = min( k, kte_stoch-1 ) DO i = its,ite - ru_tendf(i,k,j) = ru_tendf(i,k,j)*(1.0 + rstoch(i,k,j)) + ru_tendf(i,k,j) = ru_tendf(i,k,j)*(1.0 + rstoch(i,kh,j)) ENDDO ENDDO ENDDO DO j = jts,jte DO k = kts,kte-1 + kh = min( k, kte_stoch-1 ) DO i = its,MIN(ide-1,ite) - rv_tendf(i,k,j) = rv_tendf(i,k,j)*(1.0 + rstoch(i,k,j)) + rv_tendf(i,k,j) = rv_tendf(i,k,j)*(1.0 + rstoch(i,kh,j)) ENDDO ENDDO ENDDO DO j = jts,MIN(jde-1,jte) DO k = kts,kte-1 + kh = min( k, kte_stoch-1 ) DO i = its,MIN(ide-1,ite) - moist_tend(i,k,j) = moist_tend(i,k,j)*(1.0 + rstoch(i,k,j)) - t_tendf (i,k,j) = t_tendf(i,k,j)*(1.0 + rstoch(i,k,j)) + moist_tend(i,k,j) = moist_tend(i,k,j)*(1.0 + rstoch(i,kh,j)) + t_tendf (i,k,j) = t_tendf(i,k,j)*(1.0 + rstoch(i,kh,j)) ENDDO ENDDO ENDDO @@ -916,127 +790,276 @@ subroutine perturb_physics_tend(gridpointvariance, & end subroutine perturb_physics_tend ! ------------------------------------------------------------------ -!!************** TRANSFORM FROM SPHERICAL HARMONICS TO GRIDPOILT SPACE** +!!************** UPDATE SPECTRAL PATTERN AND TRANFORM GRIDPOINT SPACE*** ! ------------------------------------------------------------------ - subroutine SP2GP_prep( & - SPSTREAMFORCS,SPSTREAMFORCC,SPTFORCS,SPTFORCC, & - VERTSTRUCC,VERTSTRUCS, & - VERTAMPT,VERTAMPUV, & - RU_REAL,RV_REAL,RT_REAL, & - RU_IMAG,RV_IMAG,RT_IMAG, & - dx,dy,stoch_vertstruc_opt, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) - - IMPLICIT NONE - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - REAL, DIMENSION (ims:ime , jms:jme) :: SPSTREAMFORCS,SPSTREAMFORCC,SPTFORCS,SPTFORCC - REAL, DIMENSION (ims:ime , kms:kme, jms:jme) :: RU_REAL,RV_REAL,RT_REAL,RU_IMAG,RV_IMAG,RT_IMAG, & - VERTSTRUCC,VERTSTRUCS - REAL, DIMENSION (kms:kme ) :: VERTAMPT,VERTAMPUV - INTEGER :: IK,IL,ILEV,NLAT,NLON,stoch_vertstruc_opt - REAL :: dx,dy,RY,RX +! This subroutine evolves the spectral pattern and transforms it back to gridpoint space. - NLAT=(jde-jds)+1 !KMAX - NLON=(ide-ids)+1 !LMAX - RY= NLAT*DY - RX= NLON*DX + SUBROUTINE RAND_PERT_UPDATE (grid, variable_in, & + SPFORCS,SPFORCC,SP_AMP,ALPH_RAND, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + kts, kte, & + imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey, & + kpe_stoch,kde_stoch,kme_stoch,kte_stoch, & + restart,iseedarr, & + DX,DY,skebs_vertstruc, & + RAND_PERT, & + VERTSTRUCC,VERTSTRUCS,VERTAMP ) - DO ILEV=kts,kte - if (stoch_vertstruc_opt==0) then - DO IL=its,ite - DO IK=jts,jte - rt_real(IL,ILEV,IK) = SPTFORCC(IL,IK) - rt_imag(IL,ILEV,IK) = SPTFORCS(IL,IK) - ru_real(IL,ILEV,IK) = 2*RPI/RY* wavenumber_k(IK) * SPSTREAMFORCS(IL,IK) - ru_imag(IL,ILEV,IK) =-2*RPI/RY* wavenumber_k(IK) * SPSTREAMFORCC(IL,IK) - rv_real(IL,ILEV,IK) =-2*RPI/RX* wavenumber_l(IL) * SPSTREAMFORCS(IL,IK) - rv_imag(IL,ILEV,IK) = 2*RPI/RX* wavenumber_l(IL) * SPSTREAMFORCC(IL,IK) - ENDDO - ENDDO - elseif (stoch_vertstruc_opt==1) then - - DO IL=its,ite - DO IK=jts,jte - rt_real(IL,ILEV,IK) = SPTFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK) - SPTFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK) - rt_imag(IL,ILEV,IK) = SPTFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK) + SPTFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK) - ru_real(IL,ILEV,IK) = 2*RPI/RY* wavenumber_k(IK) *& - (+SPSTREAMFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK) + SPSTREAMFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK)) - ru_imag(IL,ILEV,IK) = 2*RPI/RY* wavenumber_k(IK) *& - (-SPSTREAMFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK) + SPSTREAMFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK)) - rv_real(IL,ILEV,IK) = 2*RPI/RX* wavenumber_l(IL) *& - (-SPSTREAMFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK) - SPSTREAMFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK)) - rv_imag(IL,ILEV,IK) = 2*RPI/RX* wavenumber_l(IL) *& - (+SPSTREAMFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK) - SPSTREAMFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK)) - - ENDDO - ENDDO + USE module_domain, ONLY : domain +#ifdef DM_PARALLEL + USE module_dm, ONLY : local_communicator, mytask, ntasks, ntasks_x, ntasks_y, local_communicator_periodic, & + wrf_dm_maxval, wrf_err_message, local_communicator_x, local_communicator_y, data_order_xzy +#endif - elseif (stoch_vertstruc_opt==3) then + IMPLICIT NONE - DO IL=its,ite - DO IK=jts,jte - rt_real(IL,ILEV,IK) = SPTFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK) - SPTFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK) - rt_real(IL,ILEV,IK) = rt_real(IL,ILEV,IK) * VERTAMPT(ILEV) - rt_imag(IL,ILEV,IK) = SPTFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK) + SPTFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK) - rt_imag(IL,ILEV,IK) = rt_imag(IL,ILEV,IK) * VERTAMPT(ILEV) - ru_real(IL,ILEV,IK) = 2*RPI/RY* wavenumber_k(IK) *& - (+SPSTREAMFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK) + SPSTREAMFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK)) - ru_real(IL,ILEV,IK) = ru_real(IL,ILEV,IK) * VERTAMPUV(ILEV) - ru_imag(IL,ILEV,IK) = 2*RPI/RY* wavenumber_k(IK) *& - (-SPSTREAMFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK) + SPSTREAMFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK)) - ru_imag(IL,ILEV,IK) = ru_imag(IL,ILEV,IK) * VERTAMPUV(ILEV) - rv_real(IL,ILEV,IK) = 2*RPI/RX* wavenumber_l(IL) *& - (-SPSTREAMFORCC(IL,IK)*VERTSTRUCS(IL,ILEV,IK) - SPSTREAMFORCS(IL,IK)*VERTSTRUCC(IL,ILEV,IK)) - rv_real(IL,ILEV,IK) = rv_real(IL,ILEV,IK) * VERTAMPUV(ILEV) - rv_imag(IL,ILEV,IK) = 2*RPI/RX* wavenumber_l(IL) *& - (+SPSTREAMFORCC(IL,IK)*VERTSTRUCC(IL,ILEV,IK) - SPSTREAMFORCS(IL,IK)*VERTSTRUCS(IL,ILEV,IK)) - rv_imag(IL,ILEV,IK) = rv_imag(IL,ILEV,IK) * VERTAMPUV(ILEV) + TYPE ( domain ), INTENT(INOUT) :: grid + + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + kts, kte + INTEGER , INTENT(IN) :: imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey + INTEGER :: kpe_stoch,kde_stoch,kme_stoch,kte_stoch + + REAL , INTENT(IN) :: ALPH_RAND,dx,dy + INTEGER , INTENT(IN) :: skebs_vertstruc + CHARACTER, INTENT(IN) :: variable_in ! T, U, V + ! T ! random field, T + ! U ! first derivative of streamfunction with regard to y; for skebs: U + ! V ! first derivative of streamfunction with regard to x; for skebs: V + + INTEGER, DIMENSION (kms:kme), INTENT(INOUT) :: iseedarr + REAL, DIMENSION(ims:ime,kms:kme, jms:jme),INTENT(IN) :: VERTSTRUCC,VERTSTRUCS + REAL, DIMENSION(ims:ime,jms:jme) ,INTENT(INOUT) :: SPFORCS,SPFORCC,SP_AMP + REAL, DIMENSION(kms:kme ) ,INTENT(IN) :: VERTAMP + REAL, DIMENSION(ims:ime,kms:kme_stoch, jms:jme) :: RAND_PERT + REAL :: RY,RX + + +! Local Variabels + INTEGER :: IK,IL,ILEV,NLON,NLAT,IJ,I,J,K + INTEGER :: gridsp32y,gridsm32y,gridsp32x,gridsm32x,gridsp32 ,gridsm32 + INTEGER :: gridep32y,gridem32y,gridep32x,gridem32x,gridep32 ,gridem32 + + REAL, DIMENSION(ims:ime,kms:kme_stoch, jms:jme) :: RAND_REAL, RAND_IMAG + LOGICAL :: RESTART + CHARACTER :: variable + + variable = variable_in + + NLAT=(jde-jds)+1 !KMAX + NLON=(ide-ids)+1 !LMAX + RY= NLAT*DY + RX= NLON*DX + +! Update the pattern generator by evolving each spectral coefficients as AR1 + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + DO ij = 1 , grid%num_tiles + IF (variable .ne. 'V') THEN !T, random field, U, don't update for V + CALL UPDATE_STOCH( & + SPFORCS,SPFORCC,SP_AMP,ALPH_RAND, & + restart,iseedarr, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), grid%j_start(ij), grid%j_end(ij), kts, kte ) + endif + +! Put spectral coefficients in arrays RAND_REAL,RAND_IMAG + + IF (variable == 'T') THEN ! T, rand + DO IK=grid%j_start(ij), grid%j_end(ij) + DO ILEV=kts,kte_stoch + DO IL=grid%i_start(ij),grid%i_end(ij) + grid%RAND_REAL(IL,ILEV,IK) = SPFORCC(IL,IK) + grid%RAND_IMAG(IL,ILEV,IK) = SPFORCS(IL,IK) + ENDDO + ENDDO + ENDDO + + ELSEIF (variable == 'U') THEN !U + DO IK=grid%j_start(ij), grid%j_end(ij) + DO ILEV=kts,kte_stoch + DO IL=grid%i_start(ij),grid%i_end(ij) + grid%RAND_REAL(IL,ILEV,IK) = 2*RPI/RY* wavenumber_k(IK) * SPFORCS(IL,IK) + grid%RAND_IMAG(IL,ILEV,IK) = -2*RPI/RY* wavenumber_k(IK) * SPFORCC(IL,IK) + ENDDO + ENDDO + ENDDO + + ELSEIF (variable == 'V') THEN !V + DO IK=grid%j_start(ij), grid%j_end(ij) + DO ILEV=kts,kte_stoch + DO IL=grid%i_start(ij),grid%i_end(ij) + grid%RAND_REAL(IL,ILEV,IK) = -2*RPI/RX* wavenumber_l(IL) * SPFORCS(IL,IK) + grid%RAND_IMAG(IL,ILEV,IK) = 2*RPI/RX* wavenumber_l(IL) * SPFORCC(IL,IK) + ENDDO + ENDDO + ENDDO + endif + + +! Apply vertical structure function + + IF (skebs_vertstruc.ne.0) then + DO ILEV=kts,kte_stoch + DO IL=grid%i_start(ij),grid%i_end(ij) + DO IK=grid%j_start(ij), grid%j_end(ij) + grid%RAND_REAL(IL,ILEV,IK) = VERTAMP(ILEV) * & + (grid%RAND_REAL(IL,ILEV,IK) * VERTSTRUCC(IL,ILEV,IK) - grid%RAND_IMAG(IL,ILEV,IK) * VERTSTRUCS(IL,ILEV,IK)) + grid%RAND_IMAG(IL,ILEV,IK) = VERTAMP(ILEV) * & + (grid%RAND_REAL(IL,ILEV,IK) * VERTSTRUCS(IL,ILEV,IK) + grid%RAND_IMAG(IL,ILEV,IK) * VERTSTRUCC(IL,ILEV,IK)) + ENDDO + ENDDO + ENDDO + ENDIF ENDDO + !$OMP END PARALLEL DO + +! Transform spectral pattern to gridpoint space + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + +! Roll out into latitude bands and perform FFT along latitude bands + +! Save a copy of the indices as we might need them to change when +! doing the "thin" 3d arrays (where the "k" dimension is unity). +! These are the original Z-transposed and X-transposed k-dimensions. + + gridsp32x=grid%sp32x + gridsm32x=grid%sm32x + gridep32x=grid%ep32x + gridem32x=grid%em32x + gridsp32 =grid%sp32 + gridsm32 =grid%sm32 + gridep32 =grid%ep32 + gridem32 =grid%em32 + +! Set number of vertical levels to which ever is smaller: the full number +! of vertical levels, or the number of levels to be transformed into +! gridpoint space. + + grid%sp32x=min(kpsx,grid%num_stoch_levels) + grid%sm32x=min(kmsx,grid%num_stoch_levels) + grid%ep32x=min(kpex,grid%num_stoch_levels) + grid%em32x=min(kmex,grid%num_stoch_levels) + grid%sp32 =min(kps ,grid%num_stoch_levels) + grid%sm32 =min(kms ,grid%num_stoch_levels) + grid%ep32 =min(kpe ,grid%num_stoch_levels) + grid%em32 =min(kme ,grid%num_stoch_levels) + +#include "XPOSE_RAND_REAL_z2x.inc" +#include "XPOSE_RAND_IMAG_z2x.inc" + call do_fftback_along_x(grid%RAND_REAL_xxx,grid%RAND_IMAG_xxx, & + ids,ide,jds,jde, & + imsx,imex,jmsx,jmex,kmsx,min(kmex,grid%num_stoch_levels), & + ipsx,ipex,jpsx,jpex,kpsx,min(kpex,grid%num_stoch_levels)) +#include "XPOSE_RAND_REAL_x2z.inc" +#include "XPOSE_RAND_IMAG_x2z.inc" + +! Roll out into longitude bands and perform FFT along longitude bands + +! Save a copy of the indices as we might need them to change when +! doing the "thin" 3d arrays (where the "k" dimension is unity). +! These are the original Y-transposed k-dimensions. + + gridsp32y=grid%sp32y + gridsm32y=grid%sm32y + gridep32y=grid%ep32y + gridem32y=grid%em32y + +! Again, set number of vertical levels to the min of the number of levels and the +! number of stochastic levels. + + grid%sp32y=min(kpsy,grid%num_stoch_levels) + grid%sm32y=min(kmsy,grid%num_stoch_levels) + grid%ep32y=min(kpey,grid%num_stoch_levels) + grid%em32y=min(kmey,grid%num_stoch_levels) + +#include "XPOSE_RAND_REAL_z2y.inc" +#include "XPOSE_RAND_IMAG_z2y.inc" + call do_fftback_along_y(grid%RAND_REAL_yyy,grid%RAND_IMAG_yyy, & + ids,ide,jds,jde, & + imsy,imey,jmsy,jmey,kmsy,min(kmey,grid%num_stoch_levels), & + ipsy,ipey,jpsy,jpey,kpsy,min(kpey,grid%num_stoch_levels)) +#include "XPOSE_RAND_REAL_y2z.inc" +#include "XPOSE_RAND_IMAG_y2z.inc" + +! Put the original vertical "k" dimensions back. + + grid%sp32x=gridsp32x + grid%sm32x=gridsm32x + grid%ep32x=gridep32x + grid%em32x=gridem32x + grid%sp32y=gridsp32y + grid%sm32y=gridsm32y + grid%ep32y=gridep32y + grid%em32y=gridem32y + grid%sp32 =gridsp32 + grid%sm32 =gridsm32 + grid%ep32 =gridep32 + grid%em32 =gridem32 + +#else + call do_fftback_along_x(grid%RAND_REAL,grid%RAND_IMAG, & + ids,ide,jds,jde, & + ims,ime,jms,jme,kms,min(kme,grid%num_stoch_levels), & + ips,ipe,jps,jpe,kps,min(kpe,grid%num_stoch_levels)) + call do_fftback_along_y(grid%RAND_REAL,grid%RAND_IMAG, & + ids,ide,jds,jde, & + ims,ime,jms,jme,kms,min(kme,grid%num_stoch_levels), & + ips,ipe,jps,jpe,kps,min(kpe,grid%num_stoch_levels)) +#endif + + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + DO ij = 1 , grid%num_tiles + RAND_PERT=0.0 + DO k=kts,min(kte,grid%num_stoch_levels) + DO I=grid%i_start(ij), grid%i_end(ij) + DO j=grid%j_start(ij), grid%j_end(ij) + RAND_PERT(I,K,J)=grid%RAND_REAL(I,K,J) + ENDDO + ENDDO + ENDDO ENDDO + !$OMP END PARALLEL DO - endif - ENDDO !ILEV - - END subroutine SP2GP_prep + END SUBROUTINE RAND_PERT_UPDATE ! ------------------------------------------------------------------ !!************** SUBROUTINE DO_FFTBACK_ALONG_X ! ------------------------------------------------------------------ - subroutine do_fftback_along_x(fieldc_U_xxx,fields_U_xxx, & - fieldc_V_xxx,fields_V_xxx, & - fieldc_T_xxx,fields_T_xxx, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & + subroutine do_fftback_along_x( & + fieldc,fields, & + ids,ide,jds,jde, & imsx,imex,jmsx,jmex,kmsx,kmex, & - ipsx,ipex,jpsx,jpex,kpsx,kpex, & - imsy,imey,jmsy,jmey,kmsy,kmey, & - ipsy,ipey,jpsy,jpey,kpsy,kpey, & - k_start , k_end & - ) + ipsx,ipex,jpsx,jpex,kpsx,kpex ) IMPLICIT NONE - INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & - imsx,imex,jmsx,jmex,kmsx,kmex, & - ipsx,ipex,jpsx,jpex,kpsx,kpex, & - imsy,imey,jmsy,jmey,kmsy,kmey, & - ipsy,ipey,jpsy,jpey,kpsy,kpey, & - k_start , k_end + INTEGER, INTENT(IN):: imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + ids,ide,jds,jde + - REAL, DIMENSION (imsx:imex, kmsx:kmex, jmsx:jmex) :: fieldc_U_xxx,fields_U_xxx, & - fieldc_V_xxx,fields_V_xxx, & - fieldc_T_xxx,fields_T_xxx + REAL, DIMENSION (imsx:imex, kmsx:kmex, jmsx:jmex) :: fieldc,fields COMPLEX, DIMENSION (ipsx:ipex) :: dummy_complex INTEGER :: IER,LENWRK,KMAX,LMAX,I,J,K @@ -1055,7 +1078,7 @@ subroutine do_fftback_along_x(fieldc_U_xxx,fields_U_xxx, & DO k=kpsx,kpex DO j = jpsx, jpex DO i = ipsx, ipex - dummy_complex(i)=cmplx(fieldc_U_xxx(i,k,j),fields_U_xxx(i,k,j)) + dummy_complex(i)=cmplx(fieldc(i,k,j),fields(i,k,j)) ENDDO CALL cFFT1B (LMAX, 1 ,dummy_complex,LMAX, WSAVE1, LENSAV, WORK, LENWRK, IER) if (ier.ne.0) then @@ -1063,80 +1086,32 @@ subroutine do_fftback_along_x(fieldc_U_xxx,fields_U_xxx, & CALL wrf_debug(0,mess) end if DO i = ipsx, ipex - fieldc_U_xxx(i,k,j)=real(dummy_complex(i)) - fields_U_xxx(i,k,j)=imag(dummy_complex(i)) + fieldc(i,k,j)=real(dummy_complex(i)) + fields(i,k,j)=imag(dummy_complex(i)) END DO END DO END DO - DO k=kpsx,kpex - DO j = jpsx, jpex - DO i = ipsx, ipex - dummy_complex(i)=cmplx(fieldc_V_xxx(i,k,j),fields_V_xxx(i,k,j)) - ENDDO - CALL cFFT1B (LMAX, 1 ,dummy_complex,LMAX, WSAVE1, LENSAV, WORK, LENWRK, IER) - if (ier.ne.0) then - WRITE(mess,FMT='(A)') 'error in cFFT1B in do_fftback_along_x, field V' - CALL wrf_debug(0,mess) - end if - DO i = ipsx,ipex - fieldc_V_xxx(i,k,j)=real(dummy_complex(i)) - fields_V_xxx(i,k,j)=imag(dummy_complex(i)) - END DO - END DO - END DO - - DO k=kpsx,kpex - DO j = jpsx, jpex - DO i = ipsx, ipex - dummy_complex(i)=cmplx(fieldc_T_xxx(i,k,j),fields_T_xxx(i,k,j)) - ENDDO - CALL cFFT1B (LMAX, 1 ,dummy_complex,LMAX, WSAVE1, LENSAV, WORK, LENWRK, IER) - if (ier.ne.0) then - WRITE(mess,FMT='(A)') 'error in cFFT1B in do_fftback_along_x, field T' - CALL wrf_debug(0,mess) - end if - DO i = ipsx, ipex - fieldc_T_xxx(i,k,j)=real(dummy_complex(i)) - fields_T_xxx(i,k,j)=imag(dummy_complex(i)) - END DO - END DO - END DO ! - DEALLOCATE(WORK) end subroutine do_fftback_along_x !! ------------------------------------------------------------------ !!!************** SUBROUTINE DO_FFTBACK_ALONG_Y !! ------------------------------------------------------------------ - subroutine do_fftback_along_y(fieldc_U_yyy,fields_U_yyy, & - fieldc_V_yyy,fields_V_yyy, & - fieldc_T_yyy,fields_T_yyy, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & - imsx,imex,jmsx,jmex,kmsx,kmex, & - ipsx,ipex,jpsx,jpex,kpsx,kpex, & + subroutine do_fftback_along_y( & + fieldc,fields, & + ids,ide,jds,jde, & imsy,imey,jmsy,jmey,kmsy,kmey, & - ipsy,ipey,jpsy,jpey,kpsy,kpey, & - k_start , k_end & - ) + ipsy,ipey,jpsy,jpey,kpsy,kpey ) IMPLICIT NONE - INTEGER :: IER,LENWRK,KMAX,LMAX,I,J,K + INTEGER :: IER,LENWRK,KMAX,LMAX,I,J,K,skebs_vertstruc - INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & - imsx,imex,jmsx,jmex,kmsx,kmex, & - ipsx,ipex,jpsx,jpex,kpsx,kpex, & - imsy,imey,jmsy,jmey,kmsy,kmey, & - ipsy,ipey,jpsy,jpey,kpsy,kpey, & - k_start , k_end + INTEGER, INTENT(IN) :: imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey, & + ids,ide,jds,jde - REAL, DIMENSION (imsy:imey, kmsy:kmey, jmsy:jmey) :: fieldc_U_yyy,fields_U_yyy, & - fieldc_V_yyy,fields_V_yyy, & - fieldc_T_yyy,fields_T_yyy + REAL, DIMENSION (imsy:imey, kmsy:kmey, jmsy:jmey) :: fieldc,fields COMPLEX, DIMENSION (jpsy:jpey) :: dummy_complex REAL, ALLOCATABLE :: WORK(:) @@ -1149,10 +1124,12 @@ subroutine do_fftback_along_y(fieldc_U_yyy,fields_U_yyy, & ALLOCATE(WORK(LENWRK)) LENSAV= 4*(KMAX+LMAX)+INT(LOG(REAL(KMAX))) + INT(LOG(REAL(LMAX))) + 8 + + DO k=kpsy,kpey DO i = ipsy, ipey DO j = jpsy,jpey - dummy_complex(j)=cmplx(fieldc_U_yyy(i,k,j),fields_U_yyy(i,k,j)) + dummy_complex(j)=cmplx(fieldc(i,k,j),fields(i,k,j)) ENDDO CALL cFFT1B (KMAX, 1 ,dummy_complex,KMAX, WSAVE2, LENSAV, WORK, LENWRK, IER) if (ier.ne.0) then @@ -1160,46 +1137,13 @@ subroutine do_fftback_along_y(fieldc_U_yyy,fields_U_yyy, & CALL wrf_debug(0,mess) end if DO j = jpsy, jpey - fieldc_U_yyy(i,k,j)=real(dummy_complex(j)) - fields_U_yyy(i,k,j)=imag(dummy_complex(j)) - END DO - END DO - END DO ! k_start-k_end - - DO k=kpsy,kpey - DO i = ipsy, ipey - DO j = jpsy, jpey - dummy_complex(j)=cmplx(fieldc_V_yyy(i,k,j),fields_V_yyy(i,k,j)) - ENDDO - CALL cFFT1B (KMAX, 1 ,dummy_complex,KMAX, WSAVE2, LENSAV, WORK, LENWRK, IER) - if (ier.ne.0) then - WRITE(mess,FMT='(A)') 'error in cFFT1B in do_fftback_along_y, field V' - CALL wrf_debug(0,mess) - end if - DO j = jpsy, jpey - fieldc_V_yyy(i,k,j)=real(dummy_complex(j)) - fields_V_yyy(i,k,j)=imag(dummy_complex(j)) - END DO - END DO - END DO ! k_start-k_end - - DO k=kpsy,kpey - DO i = ipsy, ipey - DO j = jpsy,jpey - dummy_complex(j)=cmplx(fieldc_T_yyy(i,k,j),fields_T_yyy(i,k,j)) - ENDDO - CALL cFFT1B (KMAX, 1 ,dummy_complex,KMAX, WSAVE2, LENSAV, WORK, LENWRK, IER) - if (ier.ne.0) then - WRITE(mess,FMT='(A)') 'error in cFFT1B in do_fftback_along_y, field T' - CALL wrf_debug(0,mess) - end if - DO j = jpsy,jpey - fieldc_T_yyy(i,k,j)=real(dummy_complex(j)) - fields_T_yyy(i,k,j)=imag(dummy_complex(j)) + fieldc(i,k,j)=real(dummy_complex(j)) + fields(i,k,j)=imag(dummy_complex(j)) END DO END DO END DO ! k_start-k_end + DEALLOCATE(WORK) end subroutine do_fftback_along_y ! ------------------------------------------------------------------ @@ -1265,32 +1209,31 @@ subroutine gauss_noise(z) end subroutine gauss_noise ! ------------------------------------------------------------------ - SUBROUTINE rand_seed (config_flags, seed1, seed2,nens ) - USE module_configure - IMPLICIT NONE + SUBROUTINE rand_seed (config_flags, iseed1, iseedarr, kms, kme) + USE module_configure + IMPLICIT NONE ! ! Structure that contains run-time configuration (namelist) data for domain TYPE (grid_config_rec_type) :: config_flags ! ! Arguments - INTEGER, INTENT(OUT) :: seed1, seed2 - INTEGER, INTENT(IN ) :: nens + INTEGER :: kms, kme, iseed1 + INTEGER, DIMENSION (kms:kme), INTENT(OUT) :: iseedarr ! Local - integer :: date_time(8) - integer*8 :: yyyy,mmdd,newtime - integer*8 :: ihr,isc,idiv - character (len=10) :: real_clock(3), time -! - LOGICAL :: is_print = .false. -! - newtime = config_flags%start_year * ( config_flags%start_month*100+config_flags%start_day) + config_flags%start_hour + integer*8 :: fctime + integer :: i - idiv=2; - seed1 = newtime+nens*1000000 - seed2 = mod(newtime+nens*1000000,idiv) - if(is_print) print *,'Rand_seed (newtime/idiv):',newtime,idiv,nens + fctime = config_flags%start_year * ( config_flags%start_month*100+config_flags%start_day) + config_flags%start_hour - end SUBROUTINE rand_seed + iseedarr=0.0 + do i = kms,kme-3,4 + iseedarr(i )= iseed1+config_flags%nens*1000000 + iseedarr(i+1)= mod(fctime+iseed1*1000000,19211) + iseedarr(i+2)= mod(fctime+iseed1*1000000,71209) + iseedarr(i+3)= mod(fctime+iseed1*1000000,11279) + enddo - end module module_stoch + end SUBROUTINE rand_seed +! ------------------------------------------------------------------ + end module module_stoch diff --git a/wrfv2_fire/dyn_em/module_wps_io_arw.F b/wrfv2_fire/dyn_em/module_wps_io_arw.F index a52d4048..2bd8631b 100755 --- a/wrfv2_fire/dyn_em/module_wps_io_arw.F +++ b/wrfv2_fire/dyn_em/module_wps_io_arw.F @@ -1956,7 +1956,8 @@ subroutine retrieve_field(in_unit,wrfges,out,start_block,end_block,start_byte,en integer(i_llong),parameter:: lrecl=2**20 integer(i_byte) buf(lrecl) integer(i_kind) i,ii,k - integer(i_llong) ibegin,iend,ierr + integer(i_llong) ibegin,iend + integer :: ierr open(in_unit,file=trim(wrfges),access='direct',recl=lrecl) diff --git a/wrfv2_fire/dyn_em/nest_init_utils.F b/wrfv2_fire/dyn_em/nest_init_utils.F index 9e385c67..9025aee0 100644 --- a/wrfv2_fire/dyn_em/nest_init_utils.F +++ b/wrfv2_fire/dyn_em/nest_init_utils.F @@ -35,11 +35,14 @@ SUBROUTINE init_domain_constants_em ( parent , nest ) nest%tlp = parent%tlp nest%p00 = parent%p00 nest%t00 = parent%t00 + nest%tlp_strat= parent%tlp_strat + nest%p_strat = parent%p_strat !cyl: variables for trajectory /float nest%traj_k = parent%traj_k nest%traj_long = parent%traj_long nest%traj_lat = parent%traj_lat nest%this_is_an_ideal_run = parent%this_is_an_ideal_run + nest%lake_depth_flag = parent%lake_depth_flag CALL nl_get_mminlu ( 1, char_junk ) CALL nl_get_iswater( 1, iswater ) @@ -113,6 +116,185 @@ SUBROUTINE init_domain_constants_em ( parent , nest ) END SUBROUTINE init_domain_constants_em + +!--------------------------------------------------------------------------------------------------- + +SUBROUTINE init_domain_vert_nesting ( parent, nest) + +!KAL this is a driver to initialize the vertical coordinates for the nest when vertical nesting is used + USE module_domain + IMPLICIT NONE + TYPE(domain), POINTER :: parent, nest + + !local + REAL, DIMENSION(parent%e_vert) :: znw_c + + INTERFACE + + SUBROUTINE vert_cor_vertical_nesting_integer(nest,znw_c,k_dim_c) + USE module_domain + TYPE(domain), POINTER :: nest + integer , intent(in) :: k_dim_c + real , dimension(k_dim_c), INTENT(IN) :: znw_c + END SUBROUTINE vert_cor_vertical_nesting_integer + + SUBROUTINE vert_cor_vertical_nesting_arbitrary(nest,znw_c,kde_c) + USE module_domain + TYPE(domain), POINTER :: nest + INTEGER, INTENT(IN ) :: kde_c + REAL, DIMENSION(kde_c), INTENT(IN ) :: znw_c + END SUBROUTINE vert_cor_vertical_nesting_arbitrary + + END INTERFACE + + + ! save the coarse grid values here + + znw_c = nest%znw(1:parent%e_vert) + + ! calculate the nest (fine) grid values here + ! one of these calls goes to integer refinement in the vertical direction, and one goes to arbitrary refinement. Eventually the call to integer refinement will be obsolete. + if (nest%vert_refine_method .EQ. 1) then !if you are in this subroutine there is vertical nesting- (i.e. nest%e_vert /= parent%e_vert to enter this subroutine) + CALL vert_cor_vertical_nesting_integer(nest,znw_c,parent%e_vert) + elseif (nest%vert_refine_method .EQ. 2) then + CALL vert_cor_vertical_nesting_arbitrary(nest,znw_c,parent%e_vert) + endif + +END SUBROUTINE init_domain_vert_nesting + +!----------------------------------------------------------------------------------------- + + +!this is a direct copy of a subroutine that is in ndown, but I couldn't link to the subroutine in ndown because it is compiled after this file +!so a dependecy on ndown will not work. Additionally, ndown is not compiled for ideal cases. The variable is named parent in ndown, but it is actually operating on the nest. It has been renamed to nest here. + SUBROUTINE vert_cor_vertical_nesting_integer(nest,znw_c,k_dim_c) + USE module_domain + IMPLICIT NONE + TYPE(domain), POINTER :: nest + integer , intent(in) :: k_dim_c + real , dimension(k_dim_c), INTENT(IN) :: znw_c + + integer :: kde_c , kde_n ,n_refine,ii,kkk,k + real :: dznw_m,cof1,cof2 +!KAL this subroutine recalculates the vertical coordinates for the nest when vertical nesting is used. This routine is copied from ndown and allows integer refinement only. + +!KAL znw is eta values on full w levels +!KAL everything else is set from znw +!KAL dnw is delta eta on w levels +!KAL rdn is inverse delta eta on w levels +!KAL fnp + + kde_c = k_dim_c + kde_n = nest%e_vert +! n_refine = nest%vert_refine_fact + n_refine = (kde_n-1)/(kde_c-1) + + kkk = 0 + do k = 1 , kde_c-1 + dznw_m = znw_c(k+1) - znw_c(k) + do ii = 1,n_refine + kkk = kkk + 1 + nest%znw(kkk) = znw_c(k) + float(ii-1)/float(n_refine)*dznw_m + enddo + enddo + nest%znw(kde_n) = znw_c(kde_c) + nest%znw(1) = znw_c(1) + + DO k=1, kde_n-1 + nest%dnw(k) = nest%znw(k+1) - nest%znw(k) + nest%rdnw(k) = 1./nest%dnw(k) + nest%znu(k) = 0.5*(nest%znw(k+1)+nest%znw(k)) + END DO + + DO k=2, kde_n-1 + nest%dn(k) = 0.5*(nest%dnw(k)+nest%dnw(k-1)) + nest%rdn(k) = 1./nest%dn(k) + nest%fnp(k) = .5* nest%dnw(k )/nest%dn(k) + nest%fnm(k) = .5* nest%dnw(k-1)/nest%dn(k) + END DO + + cof1 = (2.*nest%dn(2)+nest%dn(3))/(nest%dn(2)+nest%dn(3))*nest%dnw(1)/nest%dn(2) + cof2 = nest%dn(2) /(nest%dn(2)+nest%dn(3))*nest%dnw(1)/nest%dn(3) + + nest%cf1 = nest%fnp(2) + cof1 + nest%cf2 = nest%fnm(2) - cof1 - cof2 + nest%cf3 = cof2 + + nest%cfn = (.5*nest%dnw(kde_n-1)+nest%dn(kde_n-1))/nest%dn(kde_n-1) + nest%cfn1 = -.5*nest%dnw(kde_n-1)/nest%dn(kde_n-1) + + ! the variables dzs and zs are kept from the parent domain. These are the depths and thickness of the soil layers, which are not included in vertical nesting. + + END SUBROUTINE vert_cor_vertical_nesting_integer + +!----------------------------------------------------------------------------------------- + +SUBROUTINE vert_cor_vertical_nesting_arbitrary(nest,znw_c,kde_c) + USE module_domain + IMPLICIT NONE + TYPE(domain), POINTER :: nest + INTEGER, INTENT(IN ) :: kde_c + REAL, DIMENSION(kde_c), INTENT(IN ) :: znw_c + INTEGER :: k, kde_n, ks, id + REAL :: cof1, cof2 + + kde_n = nest%e_vert + + !DJW 140627 Added code for specifying multiple domains' eta_levels + IF (nest%id .NE. 1) THEN + id = 1 + ks = 1 + DO WHILE (nest%id .GT. id) + id = id+1 + ks = ks+model_config_rec%e_vert(id-1) + ENDDO + ENDIF + DO k=1,kde_n + nest%znw(k) = model_config_rec%eta_levels(ks+k-1) + write(*,'(A,I3,A,F5.3)') "DJW[nest_init_utils]: nest%znw(",k,") = ",nest%znw(k) + ENDDO + !Check the value of the first and last eta level for our domain, + !then check that the vector of eta levels is only decreasing + IF (nest%znw(1) .NE. 1.0) THEN + CALL wrf_error_fatal("error with specified eta_levels, first level is not 1.0") + ENDIF + IF (nest%znw(kde_n) .NE. 0.0) THEN + CALL wrf_error_fatal("error with specified eta_levels, last level is not 0.0") + ENDIF + DO k=2,kde_n + IF (nest%znw(k) .GT. nest%znw(k-1)) THEN + CALL wrf_error_fatal("eta_levels are not uniformly decreasing from 1.0 to 0.0") + ENDIF + ENDDO + !DJW 140627 End of added code for specifying eta_levels + + DO k=1,kde_n-1 + nest%dnw(k) = nest%znw(k+1)-nest%znw(k) + nest%rdnw(k) = 1./nest%dnw(k) + nest%znu(k) = 0.5*(nest%znw(k+1)+nest%znw(k)) + ENDDO + nest%znu(kde_n) = 0.0 + + DO k=2,kde_n-1 + nest%dn(k) = 0.5*(nest%dnw(k)+nest%dnw(k-1)) + nest%rdn(k) = 1./nest%dn(k) + nest%fnp(k) = .5* nest%dnw(k )/nest%dn(k) + nest%fnm(k) = .5* nest%dnw(k-1)/nest%dn(k) + ENDDO + + cof1 = (2.*nest%dn(2)+nest%dn(3))/(nest%dn(2)+nest%dn(3))*nest%dnw(1)/nest%dn(2) + cof2 = nest%dn(2) /(nest%dn(2)+nest%dn(3))*nest%dnw(1)/nest%dn(3) + + nest%cf1 = nest%fnp(2) + cof1 + nest%cf2 = nest%fnm(2) - cof1 - cof2 + nest%cf3 = cof2 + nest%cfn = (.5*nest%dnw(kde_n-1)+nest%dn(kde_n-1))/nest%dn(kde_n-1) + nest%cfn1 = -.5*nest%dnw(kde_n-1)/nest%dn(kde_n-1) + +END SUBROUTINE vert_cor_vertical_nesting_arbitrary + +!----------------------------------------------------------------------------------------- + SUBROUTINE blend_terrain ( ter_interpolated , ter_input , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & diff --git a/wrfv2_fire/dyn_em/solve_em.F b/wrfv2_fire/dyn_em/solve_em.F index 30ba499d..98963f2f 100644 --- a/wrfv2_fire/dyn_em/solve_em.F +++ b/wrfv2_fire/dyn_em/solve_em.F @@ -11,7 +11,8 @@ SUBROUTINE solve_em ( grid , config_flags & domain, get_ijk_from_grid, get_ijk_from_subgrid & ,domain_get_current_time, domain_get_start_time & ,domain_get_sim_start_time, domain_clock_get,is_alarm_tstep - USE module_domain_type, ONLY : history_alarm, restart_alarm, auxinput4_alarm + USE module_domain_type, ONLY : history_alarm, restart_alarm, auxinput4_alarm & + ,boundary_alarm USE module_configure, ONLY : grid_config_rec_type USE module_driver_constants USE module_machine @@ -43,7 +44,7 @@ SUBROUTINE solve_em ( grid , config_flags & ,period_bdy_em_scalar_sub,period_bdy_em_tke_old_sub & ,period_bdy_em_tracer2_sub,period_bdy_em_tracer_old_sub & ,period_bdy_em_tracer_sub,period_em_da_sub,period_em_hydro_uv_sub & - ,halo_em_f_sub,halo_em_init_4_sub + ,halo_em_f_sub,halo_em_init_4_sub,halo_em_thetam_sub,period_em_thetam_sub #endif USE module_utility ! Mediation layer modules @@ -63,7 +64,7 @@ SUBROUTINE solve_em ( grid , config_flags & ! USE module_lightning_driver, ONLY : lightning_driver USE module_fddaobs_driver ! USE module_diagnostics -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) USE module_input_chem_data USE module_input_tracer USE module_chem_utilities @@ -112,7 +113,7 @@ SUBROUTINE solve_em ( grid , config_flags & LOGICAL :: specified_bdy, channel_bdy - REAL :: t_new + REAL :: t_new, time_duration_of_lbcs ! Changes in tendency at this timestep real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) :: h_tendency, & @@ -124,7 +125,7 @@ SUBROUTINE solve_em ( grid , config_flags & ! Flag for producing diagnostic fields (e.g., radar reflectivity) LOGICAL :: diag_flag -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) ! Index cross-referencing array for tendency accumulation INTEGER, DIMENSION( num_chem ) :: adv_ct_indices #endif @@ -242,6 +243,12 @@ SUBROUTINE solve_em ( grid , config_flags & num_3d_c = num_chem num_3d_s = num_scalar +! backward integration needs to advect only QV + if (grid%dfi_stage .EQ. DFI_BCK) then + num_3d_m = P_QV + num_3d_s = PARAM_FIRST_SCALAR - 1 + endif + f_flux = config_flags%do_avgflx_cugd .EQ. 1 ! Compute these starting and stopping locations for each tile and number of tiles. @@ -296,7 +303,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF (config_flags%polar) dclat = 90./REAL(jde-jds) !(0.5 * 180/ny) -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) kte=min(k_end,kde-1) # ifdef DM_PARALLEL @@ -310,18 +317,14 @@ SUBROUTINE solve_em ( grid , config_flags & IF( config_flags%progn > 0 ) THEN # include "HALO_EM_SCALAR_E_3.inc" ENDIF -#ifdef WRF_CHEM IF( config_flags%cu_physics == CAMZMSCHEME ) THEN # include "HALO_EM_SCALAR_E_3.inc" ENDIF -#endif ELSE IF ( config_flags%h_mom_adv_order <= 6 ) THEN # include "HALO_EM_CHEM_E_5.inc" -#ifdef WRF_CHEM IF( config_flags%cu_physics == CAMZMSCHEME ) THEN # include "HALO_EM_SCALAR_E_5.inc" ENDIF -#endif IF( config_flags%progn > 0 ) THEN # include "HALO_EM_SCALAR_E_5.inc" ENDIF @@ -745,6 +748,50 @@ SUBROUTINE solve_em ( grid , config_flags & END IF rk_step_is_one +!************************************************************************************************************************ +! LES_fix convert theta to theta_m: point 1 ! 28 January 2015 + + IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN + CALL theta_to_thetam ( grid%t_1 , moist_old(ims,kms,jms,P_qv) , & + t_tendf , moist_tend(ims,kms,jms,P_qv) , & + grid%t_2 , moist(ims,kms,jms,P_qv) , & + grid%h_diabatic , & + grid%itimestep , & + rk_step , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + ips, ipe, jps, jpe, kps, kpe ) +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) +# include "HALO_EM_THETAM.inc" +# include "PERIOD_EM_THETAM.inc" +#else + its=ips ; ite = ipe + jts=jps ; jte = jpe + CALL set_physical_bc3d( grid%h_diabatic, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, & + k_start , k_end ) + CALL set_physical_bc3d( grid%t_1, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, & + k_start , k_end ) + CALL set_physical_bc3d( grid%t_2, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, & + k_start , k_end ) +#endif + END IF + +! +! end theta_m fix point 1 +!************************************************************************************************************************ + BENCH_START(rk_tend_tim) !$OMP PARALLEL DO & !$OMP PRIVATE ( ij ) @@ -806,7 +853,40 @@ SUBROUTINE solve_em ( grid , config_flags & !$OMP PRIVATE ( ij ) DO ij = 1 , grid%num_tiles - IF( (config_flags%specified .or. config_flags%nested) .and. rk_step == 1 ) THEN + IF ( (config_flags%specified .or. config_flags%nested) .and. ( rk_step == 1 ) ) THEN + +!************************************************************************************************************************ +! LES_fix convert theta to theta_m: nested or specified LBC, only required on the first rk step + + IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN + IF ( grid%grid_id .EQ. 1 ) THEN + time_duration_of_lbcs = grid%interval_seconds + ELSE + time_duration_of_lbcs = grid%parent_time_step_ratio * grid%dt + END IF + CALL theta_and_thetam_lbc_only ( & + .TRUE., & + grid%mub, & + grid%mu_bxs,grid%mu_bxe,grid%mu_bys,grid%mu_bye, & + grid%mu_btxs,grid%mu_btxe,grid%mu_btys,grid%mu_btye, & + grid%t_bxs,grid%t_bxe,grid%t_bys,grid%t_bye, & + grid%t_btxs,grid%t_btxe,grid%t_btys,grid%t_btye, & + moist_bxs(jms,kms,1,P_Qv),moist_bxe(jms,kms,1,P_Qv), & + moist_bys(ims,kms,1,P_Qv),moist_bye(ims,kms,1,P_Qv), & + moist_btxs(jms,kms,1,P_Qv),moist_btxe(jms,kms,1,P_Qv), & + moist_btys(ims,kms,1,P_Qv),moist_btye(ims,kms,1,P_Qv), & + config_flags%spec_bdy_width, & + time_duration_of_lbcs, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + END IF + +! LES_fix convert theta to theta_m: nested or specified LBC +!************************************************************************************************************************ CALL relax_bdy_dry ( config_flags, & grid%u_save, grid%v_save, ph_save, grid%t_save, & @@ -873,7 +953,37 @@ SUBROUTINE solve_em ( grid , config_flags & grid%i_start(ij), grid%i_end(ij), & grid%j_start(ij), grid%j_end(ij), & k_start, k_end ) - + +!************************************************************************************************************************ +! LES_fix convert theta_m to theta: nested or specified LBC, and only in the last rk step +! since we do not need the theta_m lateral boundaries any more. + + IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) .AND. ( rk_step == rk_order ) ) THEN + CALL theta_and_thetam_lbc_only ( & + .FALSE., & + grid%mub, & + grid%mu_bxs,grid%mu_bxe,grid%mu_bys,grid%mu_bye, & + grid%mu_btxs,grid%mu_btxe,grid%mu_btys,grid%mu_btye, & + grid%t_bxs,grid%t_bxe,grid%t_bys,grid%t_bye, & + grid%t_btxs,grid%t_btxe,grid%t_btys,grid%t_btye, & + moist_bxs(jms,kms,1,P_Qv),moist_bxe(jms,kms,1,P_Qv), & + moist_bys(ims,kms,1,P_Qv),moist_bye(ims,kms,1,P_Qv), & + moist_btxs(jms,kms,1,P_Qv),moist_btxe(jms,kms,1,P_Qv), & + moist_btys(ims,kms,1,P_Qv),moist_btye(ims,kms,1,P_Qv), & + config_flags%spec_bdy_width, & + time_duration_of_lbcs, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + END IF + +! LES_fix convert theta_m to theta: nested or specified LBC, and only in the last rk step +! since we do not need the theta_m lateral boundaries any more. +!************************************************************************************************************************ + ENDIF !--------------------------------------------------------------------------------------------- @@ -885,9 +995,10 @@ SUBROUTINE solve_em ( grid , config_flags & CALL spec_bdy_dry_perturb ( config_flags, & grid%ru_tend, grid%rv_tend, t_tend, & grid%mu_2, grid%mub, & - grid%msfu, grid%msfv, grid%msft, & + grid%msfux, grid%msfvx, grid%msft, & grid%ru_tendf_stoch, grid%rv_tendf_stoch, grid%rt_tendf_stoch, & config_flags%spec_bdy_width, grid%spec_zone, & + grid%num_stoch_levels, & ! stoch dims ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims ips,ipe, jps,jpe, kps,kpe, & ! patch dims @@ -901,9 +1012,10 @@ SUBROUTINE solve_em ( grid , config_flags & CALL spec_bdy_dry_perturb ( config_flags, & grid%ru_tend, grid%rv_tend, t_tend, & grid%mu_2, grid%mub, & - grid%msfu, grid%msfv, grid%msft, & + grid%msfux, grid%msfvx, grid%msft, & grid%field_u_tend_perturb, grid%field_v_tend_perturb, grid%field_t_tend_perturb, & config_flags%spec_bdy_width, grid%spec_zone, & + grid%num_stoch_levels, & ! stoch dims ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims ips,ipe, jps,jpe, kps,kpe, & ! patch dims @@ -962,7 +1074,7 @@ SUBROUTINE solve_em ( grid , config_flags & grid%u_save, grid%v_save, w_save, & grid%t_save, ph_save, mu_save, & grid%ww, ww1, & - grid%dnw, c2a, grid%pb, grid%p, grid%alt, & + c2a, grid%pb, grid%p, grid%alt, & grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, & grid%msfvy, grid%msftx,grid%msfty, & grid%rdx, grid%rdy, rk_step, & @@ -1178,7 +1290,9 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_chem = 0 & ,flag_tracer = 0 & ,flag_scalar = 0 & - ,positive_definite = .FALSE. & + ,actual_distance_average = .FALSE. & + ,pos_def = .FALSE. & + ,swap_pole_with_next_j = .FALSE. & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -1285,7 +1399,9 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_chem = 0 & ,flag_tracer = 0 & ,flag_scalar = 0 & - ,positive_definite = .FALSE. & + ,actual_distance_average = .FALSE. & + ,pos_def = .FALSE. & + ,swap_pole_with_next_j = .FALSE. & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -1391,7 +1507,9 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_chem = 0 & ,flag_tracer = 0 & ,flag_scalar = 0 & - ,positive_definite = .FALSE. & + ,actual_distance_average = .FALSE. & + ,pos_def = .FALSE. & + ,swap_pole_with_next_j = .FALSE. & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -1664,7 +1782,9 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_chem = 0 & ,flag_tracer = 0 & ,flag_scalar = 0 & - ,positive_definite = .FALSE. & + ,actual_distance_average = .FALSE. & + ,pos_def = .FALSE. & + ,swap_pole_with_next_j = .FALSE. & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -2068,6 +2188,21 @@ SUBROUTINE solve_em ( grid , config_flags & grid%j_start(ij), grid%j_end(ij), & k_start , k_end ) + IF( rk_step == 1 .AND. config_flags%use_q_diabatic == 1 )THEN + IF( im.eq.p_qv .or. im.eq.p_qc )THEN + CALL q_diabatic_add ( im, im, & + dt_rk, grid%mut, & + grid%qv_diabatic, & + grid%qc_diabatic, & + moist_tend(ims,kms,jms,im), & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + ENDIF + ENDIF + BENCH_END(rk_scalar_tend_tim) BENCH_START(rlx_bdy_scalar_tim) @@ -2133,6 +2268,20 @@ SUBROUTINE solve_em ( grid , config_flags & its=grid%i_start(ij), ite=grid%i_end(ij), & jts=grid%j_start(ij), jte=grid%j_end(ij), & kts=k_start , kte=k_end ) + IF( rk_step == rk_order .AND. config_flags%use_q_diabatic == 1 )THEN + IF( im.eq.p_qv .or. im.eq.p_qc )THEN + CALL q_diabatic_subtr( im, im, & + dt_rk, & + grid%qv_diabatic, & + grid%qc_diabatic, & + moist(ims,kms,jms,im), & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + ENDIF + ENDIF BENCH_END(update_scal_tim) BENCH_START(flow_depbdy_tim) @@ -2251,7 +2400,7 @@ SUBROUTINE solve_em ( grid , config_flags & ENDIF TKE_advance BENCH_END(tke_adv_tim) -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) ! next the chemical species BENCH_START(chem_adv_tim) chem_scalar_advance: IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN @@ -2354,6 +2503,26 @@ SUBROUTINE solve_em ( grid , config_flags & kts=k_start , kte=k_end ) IF( config_flags%specified ) THEN + + IF( config_flags%perturb_chem_bdy==1 ) THEN + + IF(ic.eq.PARAM_FIRST_SCALAR .and. ij.eq.1) & + CALL wrf_debug (10 , ' spec_bdy_chem_perturb' ) + + CALL spec_bdy_chem_perturb ( config_flags%periodic_x, & + chem_btxs(jms,kms,1,ic), chem_btxe(jms,kms,1,ic), & + chem_btys(ims,kms,1,ic), chem_btye(ims,kms,1,ic), & + grid%rand_pert, & + config_flags%spec_bdy_width, grid%spec_zone, & + grid%num_stoch_levels, & ! stoch dims + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end ) + ENDIF + CALL flow_dep_bdy_chem( chem(ims,kms,jms,ic), & chem_bxs(jms,kms,1,ic), chem_btxs(jms,kms,1,ic), & chem_bxe(jms,kms,1,ic), chem_btxe(jms,kms,1,ic), & @@ -2479,7 +2648,7 @@ SUBROUTINE solve_em ( grid , config_flags & kts=k_start , kte=k_end ) IF( config_flags%specified ) THEN -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) CALL flow_dep_bdy_tracer( tracer(ims,kms,jms,ic), & tracer_bxs(jms,kms,1,ic), tracer_btxs(jms,kms,1,ic), & tracer_bxe(jms,kms,1,ic), tracer_btxe(jms,kms,1,ic), & @@ -2619,6 +2788,7 @@ SUBROUTINE solve_em ( grid , config_flags & CALL flow_dep_bdy_qnn ( scalar(ims,kms,jms,is), & grid%ru_m, grid%rv_m, config_flags, & grid%spec_zone, & + grid%ccn_conc, & ! RAS ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims ips,ipe, jps,jpe, kps,kpe, & ! patch dims @@ -2673,6 +2843,24 @@ SUBROUTINE solve_em ( grid , config_flags & ENDIF other_scalar_advance +!************************************************************************************************************************ +! LES_fix: convert theta_m back to theta, point 2 ! 28 January 2015 + + IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN + CALL thetam_to_theta ( grid%t_1 , moist_old(ims,kms,jms,P_qv) , & + grid%t_2 , moist(ims,kms,jms,P_qv) , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + ips, ipe, jps, jpe, kps, kpe ) +# ifdef DM_PARALLEL +# include "HALO_EM_THETAM.inc" +# include "PERIOD_EM_THETAM.inc" +#endif + END IF + +! end theta_m fix point 2 +!************************************************************************************************************************ + ! update the pressure and density at the new time level !$OMP PARALLEL DO & @@ -2711,11 +2899,13 @@ SUBROUTINE solve_em ( grid , config_flags & IF ( num_3d_m >= PARAM_FIRST_SCALAR ) THEN CALL wrf_debug ( 200 , ' call filter moist ' ) DO im = PARAM_FIRST_SCALAR, num_3d_m + IF ( config_flags%coupled_filtering ) THEN CALL couple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) + END IF CALL pxft ( grid=grid & ,lineno=__LINE__ & ,flag_uv = 0 & @@ -2729,7 +2919,9 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_chem = 0 & ,flag_scalar = 0 & ,flag_tracer = 0 & - ,positive_definite=.FALSE. & + ,actual_distance_average=config_flags%actual_distance_average& + ,pos_def = config_flags%pos_def & + ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -2738,22 +2930,26 @@ SUBROUTINE solve_em ( grid , config_flags & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe & ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) - CALL uncouple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im) & + IF ( config_flags%coupled_filtering ) THEN + CALL uncouple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) + END IF END DO END IF IF ( num_3d_c >= PARAM_FIRST_SCALAR ) THEN CALL wrf_debug ( 200 , ' call filter chem ' ) DO im = PARAM_FIRST_SCALAR, num_3d_c + IF ( config_flags%coupled_filtering ) THEN CALL couple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) + END IF CALL pxft ( grid=grid & ,lineno=__LINE__ & ,flag_uv = 0 & @@ -2767,7 +2963,9 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_chem = im & ,flag_tracer = 0 & ,flag_scalar = 0 & - ,positive_definite=.FALSE. & + ,actual_distance_average=config_flags%actual_distance_average& + ,pos_def = config_flags%pos_def & + ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -2776,21 +2974,25 @@ SUBROUTINE solve_em ( grid , config_flags & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe & ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) - CALL uncouple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im) & + IF ( config_flags%coupled_filtering ) THEN + CALL uncouple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) + END IF END DO END IF IF ( num_tracer >= PARAM_FIRST_SCALAR ) THEN CALL wrf_debug ( 200 , ' call filter tracer ' ) DO im = PARAM_FIRST_SCALAR, num_tracer + IF ( config_flags%coupled_filtering ) THEN CALL couple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) + END IF CALL pxft ( grid=grid & ,lineno=__LINE__ & ,flag_uv = 0 & @@ -2802,9 +3004,11 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_mut = 0 & ,flag_moist = 0 & ,flag_chem = 0 & - ,flag_tracer = im & + ,flag_tracer = im & ,flag_scalar = 0 & - ,positive_definite=.FALSE. & + ,actual_distance_average=config_flags%actual_distance_average& + ,pos_def = config_flags%pos_def & + ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -2813,22 +3017,26 @@ SUBROUTINE solve_em ( grid , config_flags & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe & ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) - CALL uncouple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im) & + IF ( config_flags%coupled_filtering ) THEN + CALL uncouple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) + END IF END DO END IF IF ( num_3d_s >= PARAM_FIRST_SCALAR ) THEN CALL wrf_debug ( 200 , ' call filter scalar ' ) DO im = PARAM_FIRST_SCALAR, num_3d_s + IF ( config_flags%coupled_filtering ) THEN CALL couple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) + END IF CALL pxft ( grid=grid & ,lineno=__LINE__ & ,flag_uv = 0 & @@ -2842,7 +3050,9 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_chem = 0 & ,flag_tracer = 0 & ,flag_scalar = im & - ,positive_definite=.FALSE. & + ,actual_distance_average=config_flags%actual_distance_average& + ,pos_def = config_flags%pos_def & + ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -2851,11 +3061,13 @@ SUBROUTINE solve_em ( grid , config_flags & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe & ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) + IF ( config_flags%coupled_filtering ) THEN CALL uncouple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) + END IF END DO END IF END IF ! polar filter test @@ -3151,19 +3363,19 @@ SUBROUTINE solve_em ( grid , config_flags & !$OMP PRIVATE ( ij ) DO ij = 1 , grid%num_tiles - call trajectory (grid,config_flags, & + call trajectory (grid,config_flags, & grid%dt,grid%itimestep,grid%ru_m, grid%rv_m, grid%ww_m,& grid%mut,grid%muu,grid%muv, & grid%rdx, grid%rdy, grid%rdn, grid%rdnw,grid%rdzw, & grid%traj_i,grid%traj_j,grid%traj_k, & grid%traj_long,grid%traj_lat, & - grid%xlong,grid%xlat, & + grid%xlong,grid%xlat, & grid%msftx,grid%msfux,grid%msfvy, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - grid%i_start(ij), grid%i_end(ij), & - grid%j_start(ij), grid%j_end(ij), & - k_start , k_end ) + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) ENDDO !$OMP END PARALLEL DO ENDIF @@ -3235,6 +3447,7 @@ SUBROUTINE solve_em ( grid , config_flags & BENCH_START(advance_ppt_tim) CALL wrf_debug ( 200 , ' call advance_ppt' ) CALL advance_ppt(grid%rthcuten,grid%rqvcuten,grid%rqccuten,grid%rqrcuten, & + grid%cldfra_cup, & !BSINGH - Added for CuP scheme grid%rqicuten,grid%rqscuten, & grid%rainc,grid%raincv,grid%rainsh,grid%pratec,grid%pratesh, & grid%nca,grid%htop,grid%hbot,grid%cutop,grid%cubot, & @@ -3292,7 +3505,9 @@ SUBROUTINE solve_em ( grid , config_flags & grid%al, grid%alb, grid%p, p8w, p0, grid%pb, & grid%ph_2, grid%phb, th_phy, pi_phy , p_phy, & grid%z, grid%z_at_w, dz8w, & - dtm, grid%h_diabatic, & + dtm, grid%h_diabatic, & + moist(ims,kms,jms,P_QV),grid%qv_diabatic, & + moist(ims,kms,jms,P_QC),grid%qc_diabatic, & config_flags,grid%fnm, grid%fnp, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3345,7 +3560,7 @@ SUBROUTINE solve_em ( grid , config_flags & & ,T8W=t8w & & ,CLDFRA=grid%cldfra, EXCH_H=grid%exch_h & & ,NSOURCE=grid%qndropsource & -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) & ,QLSINK=grid%qlsink,CLDFRA_OLD=grid%cldfra_old & & ,PRECR=grid%precr, PRECI=grid%preci, PRECS=grid%precs, PRECG=grid%precg & & ,CHEM_OPT=config_flags%chem_opt, PROGN=config_flags%progn & @@ -3413,7 +3628,7 @@ SUBROUTINE solve_em ( grid , config_flags & & , QIP_CURR=moist(ims,kms,jms,P_QIP), F_QIP=F_QIP & & , QID_CURR=moist(ims,kms,jms,P_QID), F_QID=F_QID & & , QNDROP_CURR=scalar(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP & -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) & , RAINPROD=grid%rainprod, EVAPPROD=grid%evapprod & & , QV_B4MP=grid%qv_b4mp,QC_B4MP=grid%qc_b4mp & & , QI_B4MP=grid%qi_b4mp, QS_B4MP=grid%qs_b4mp & @@ -3437,7 +3652,8 @@ SUBROUTINE solve_em ( grid , config_flags & ! & , QZS_CURR=scalar(ims,kms,jms,P_QZS), F_QZS=F_QZS & ! " ! & , QZG_CURR=scalar(ims,kms,jms,P_QZG), F_QZG=F_QZG & ! " ! & , QZH_CURR=scalar(ims,kms,jms,P_QZH), F_QZH=F_QZH & ! " - & , QVOLG_CURR=scalar(ims,kms,jms,P_QVOLG), F_QVOLG=F_QVOLG & ! for nssl_2mom + & , QVOLG_CURR=scalar(ims,kms,jms,P_QVOLG), F_QVOLG=F_QVOLG & ! for nssl_2mom + & , QVOLH_CURR=scalar(ims,kms,jms,P_QVOLH), F_QVOLH=F_QVOLH & ! for nssl_2mom & , qrcuten=grid%rqrcuten, qscuten=grid%rqscuten & & , qicuten=grid%rqicuten,mu=grid%mut & & , HAIL=config_flags%gsfcgce_hail & ! for gsfcgce @@ -3476,6 +3692,7 @@ SUBROUTINE solve_em ( grid , config_flags & & ,kext_ft_qg=grid%kext_ft_qg & & ,height=grid%height & & ,tempc=grid%tempc & + & ,ccn_conc=grid%ccn_conc & ! RAS ) BENCH_END(micro_driver_tim) @@ -3570,7 +3787,10 @@ SUBROUTINE solve_em ( grid , config_flags & k_start , k_end ) CALL moist_physics_finish_em( grid%t_2, grid%t_1, t0, grid%muts, th_phy, & - grid%h_diabatic, dtm, config_flags, & + grid%h_diabatic, dtm, & + moist(ims,kms,jms,P_QV),grid%qv_diabatic, & + moist(ims,kms,jms,P_QC),grid%qc_diabatic, & + config_flags, & #if ( WRF_DFI_RADAR == 1 ) grid%dfi_tten_rad,grid%dfi_stage, & #endif @@ -3592,6 +3812,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF ( num_3d_m >= PARAM_FIRST_SCALAR ) THEN CALL wrf_debug ( 200 , ' call filter moist' ) DO im = PARAM_FIRST_SCALAR, num_3d_m + IF ( config_flags%coupled_filtering ) THEN DO jj = jps, MIN(jpe,jde-1) DO kk = kps, MIN(kpe,kde-1) DO ii = ips, MIN(ipe,ide-1) @@ -3599,6 +3820,7 @@ SUBROUTINE solve_em ( grid , config_flags & ENDDO ENDDO ENDDO + END IF CALL pxft ( grid=grid & ,lineno=__LINE__ & @@ -3613,7 +3835,9 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_chem = 0 & ,flag_tracer = 0 & ,flag_scalar = 0 & - ,positive_definite=.FALSE. & + ,actual_distance_average=config_flags%actual_distance_average& + ,pos_def = config_flags%pos_def & + ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -3623,6 +3847,7 @@ SUBROUTINE solve_em ( grid , config_flags & ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) + IF ( config_flags%coupled_filtering ) THEN DO jj = jps, MIN(jpe,jde-1) DO kk = kps, MIN(kpe,kde-1) DO ii = ips, MIN(ipe,ide-1) @@ -3630,6 +3855,7 @@ SUBROUTINE solve_em ( grid , config_flags & ENDDO ENDDO ENDDO + END IF ENDDO ENDIF ENDIF @@ -3699,6 +3925,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF ( num_3d_c >= PARAM_FIRST_SCALAR ) then chem_filter_loop: DO im = PARAM_FIRST_SCALAR, num_3d_c + IF ( config_flags%coupled_filtering ) THEN DO jj = jps, MIN(jpe,jde-1) DO kk = kps, MIN(kpe,kde-1) DO ii = ips, MIN(ipe,ide-1) @@ -3706,6 +3933,7 @@ SUBROUTINE solve_em ( grid , config_flags & ENDDO ENDDO ENDDO + END IF CALL pxft ( grid=grid & ,lineno=__LINE__ & @@ -3720,7 +3948,9 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_chem = im & ,flag_tracer = 0 & ,flag_scalar = 0 & - ,positive_definite=.FALSE. & + ,actual_distance_average=config_flags%actual_distance_average& + ,pos_def = config_flags%pos_def & + ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -3730,6 +3960,7 @@ SUBROUTINE solve_em ( grid , config_flags & ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) + IF ( config_flags%coupled_filtering ) THEN DO jj = jps, MIN(jpe,jde-1) DO kk = kps, MIN(kpe,kde-1) DO ii = ips, MIN(ipe,ide-1) @@ -3737,10 +3968,12 @@ SUBROUTINE solve_em ( grid , config_flags & ENDDO ENDDO ENDDO + END IF ENDDO chem_filter_loop ENDIF IF ( num_tracer >= PARAM_FIRST_SCALAR ) then tracer_filter_loop: DO im = PARAM_FIRST_SCALAR, num_tracer + IF ( config_flags%coupled_filtering ) THEN DO jj = jps, MIN(jpe,jde-1) DO kk = kps, MIN(kpe,kde-1) DO ii = ips, MIN(ipe,ide-1) @@ -3748,6 +3981,7 @@ SUBROUTINE solve_em ( grid , config_flags & ENDDO ENDDO ENDDO + END IF CALL pxft ( grid=grid & ,lineno=__LINE__ & @@ -3760,9 +3994,11 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_mut = 0 & ,flag_moist = 0 & ,flag_chem = 0 & - ,flag_tracer = im & + ,flag_tracer = im & ,flag_scalar = 0 & - ,positive_definite=.FALSE. & + ,actual_distance_average=config_flags%actual_distance_average& + ,pos_def = config_flags%pos_def & + ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -3772,6 +4008,7 @@ SUBROUTINE solve_em ( grid , config_flags & ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) + IF ( config_flags%coupled_filtering ) THEN DO jj = jps, MIN(jpe,jde-1) DO kk = kps, MIN(kpe,kde-1) DO ii = ips, MIN(ipe,ide-1) @@ -3779,11 +4016,13 @@ SUBROUTINE solve_em ( grid , config_flags & ENDDO ENDDO ENDDO + END IF ENDDO tracer_filter_loop ENDIF IF ( num_3d_s >= PARAM_FIRST_SCALAR ) then scalar_filter_loop: DO im = PARAM_FIRST_SCALAR, num_3d_s + IF ( config_flags%coupled_filtering ) THEN DO jj = jps, MIN(jpe,jde-1) DO kk = kps, MIN(kpe,kde-1) DO ii = ips, MIN(ipe,ide-1) @@ -3791,6 +4030,7 @@ SUBROUTINE solve_em ( grid , config_flags & ENDDO ENDDO ENDDO + END IF CALL pxft ( grid=grid & ,lineno=__LINE__ & @@ -3805,7 +4045,9 @@ SUBROUTINE solve_em ( grid , config_flags & ,flag_chem = 0 & ,flag_tracer = 0 & ,flag_scalar = im & - ,positive_definite=.FALSE. & + ,actual_distance_average=config_flags%actual_distance_average& + ,pos_def = config_flags%pos_def & + ,swap_pole_with_next_j = config_flags%swap_pole_with_next_j & ,moist=moist,chem=chem,tracer=tracer,scalar=scalar & ,fft_filter_lat = config_flags%fft_filter_lat & ,dclat = dclat & @@ -3815,6 +4057,7 @@ SUBROUTINE solve_em ( grid , config_flags & ,imsx=imsx,imex=imex,jmsx=jmsx,jmex=jmex,kmsx=kmsx,kmex=kmex & ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex ) + IF ( config_flags%coupled_filtering ) THEN DO jj = jps, MIN(jpe,jde-1) DO kk = kps, MIN(kpe,kde-1) DO ii = ips, MIN(ipe,ide-1) @@ -3822,6 +4065,7 @@ SUBROUTINE solve_em ( grid , config_flags & ENDDO ENDDO ENDDO + END IF ENDDO scalar_filter_loop ENDIF ENDIF @@ -3983,7 +4227,189 @@ SUBROUTINE solve_em ( grid , config_flags & !$OMP END PARALLEL DO BENCH_END(bc_2d_tim) +! this code forces boundary values to specified values to avoid drift + IF( config_flags%specified .or. config_flags%nested ) THEN + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + tile_bc_loop_3: DO ij = 1 , grid%num_tiles + + CALL wrf_debug ( 200 , ' call spec_bdy_final' ) + + CALL spec_bdy_final ( grid%u_2, muus, grid%msfuy, & + grid%u_bxs, grid%u_bxe, grid%u_bys, grid%u_bye, & + grid%u_btxs,grid%u_btxe,grid%u_btys,grid%u_btye, & + 'u', config_flags, & + config_flags%spec_bdy_width, grid%spec_zone, & + grid%dtbc, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + + CALL spec_bdy_final ( grid%v_2, muvs, grid%msfvx, & + grid%v_bxs, grid%v_bxe, grid%v_bys, grid%v_bye, & + grid%v_btxs,grid%v_btxe,grid%v_btys,grid%v_btye, & + 'v', config_flags, & + config_flags%spec_bdy_width, grid%spec_zone, & + grid%dtbc, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + + IF( config_flags%nested) THEN + CALL spec_bdy_final ( grid%w_2, grid%muts, grid%msfty, & + grid%w_bxs, grid%w_bxe, grid%w_bys, grid%w_bye, & + grid%w_btxs,grid%w_btxe,grid%w_btys,grid%w_btye, & + 'w', config_flags, & + config_flags%spec_bdy_width, grid%spec_zone, & + grid%dtbc, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + ENDIF + + CALL spec_bdy_final ( grid%t_2, grid%muts, grid%msfty, & + grid%t_bxs, grid%t_bxe, grid%t_bys, grid%t_bye, & + grid%t_btxs,grid%t_btxe,grid%t_btys,grid%t_btye, & + 't', config_flags, & + config_flags%spec_bdy_width, grid%spec_zone, & + grid%dtbc, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + + CALL spec_bdy_final ( grid%ph_2, grid%muts, grid%msfty, & + grid%ph_bxs, grid%ph_bxe, grid%ph_bys, grid%ph_bye, & + grid%ph_btxs,grid%ph_btxe,grid%ph_btys,grid%ph_btye, & + 'h', config_flags, & + config_flags%spec_bdy_width, grid%spec_zone, & + grid%dtbc, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + + IF( config_flags%spec_bdy_final_mu .EQ. 1 ) THEN + CALL spec_bdy_final ( grid%mu_2, grid%muts, grid%msfty, & + grid%mu_bxs, grid%mu_bxe, grid%mu_bys, grid%mu_bye, & + grid%mu_btxs,grid%mu_btxe,grid%mu_btys,grid%mu_btye, & + 'm', config_flags, & + config_flags%spec_bdy_width, grid%spec_zone, & + grid%dtbc, & + ids,ide, jds,jde, 1, 1, & ! domain dims + ims,ime, jms,jme, 1, 1, & ! memory dims + ips,ipe, jps,jpe, 1, 1, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + 1 , 1 ) + ENDIF + + moisture_loop_bdy_3 : DO im = PARAM_FIRST_SCALAR , num_3d_m + + IF ( im .EQ. P_QV .OR. config_flags%nested .OR. & + ( config_flags%specified .AND. config_flags%have_bcs_moist ) ) THEN + CALL spec_bdy_final ( moist(ims,kms,jms,im), grid%muts, grid%msfty, & + moist_bxs(jms,kms,1,im),moist_bxe(jms,kms,1,im), & + moist_bys(ims,kms,1,im),moist_bye(ims,kms,1,im), & + moist_btxs(jms,kms,1,im),moist_btxe(jms,kms,1,im), & + moist_btys(ims,kms,1,im),moist_btye(ims,kms,1,im), & + 't', config_flags, & + config_flags%spec_bdy_width, grid%spec_zone, & + grid%dtbc, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + ENDIF + + END DO moisture_loop_bdy_3 + +#if (WRF_CHEM == 1) + IF (num_3d_c >= PARAM_FIRST_SCALAR) THEN + chem_species_bdy_loop_3 : DO ic = PARAM_FIRST_SCALAR , num_3d_c + + IF( ( config_flags%nested ) ) THEN + CALL spec_bdy_final ( chem(ims,kms,jms,ic), grid%muts, grid%msfty, & + chem_bxs(jms,kms,1,ic),chem_bxe(jms,kms,1,ic), & + chem_bys(ims,kms,1,ic),chem_bye(ims,kms,1,ic), & + chem_btxs(jms,kms,1,ic),chem_btxe(jms,kms,1,ic), & + chem_btys(ims,kms,1,ic),chem_btye(ims,kms,1,ic), & + 't', config_flags, & + config_flags%spec_bdy_width, grid%spec_zone, & + grid%dtbc, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + ENDIF + + END DO chem_species_bdy_loop_3 + ENDIF +#endif + + tracer_species_bdy_loop_3 : DO im = PARAM_FIRST_SCALAR , num_tracer + + IF( ( config_flags%nested ) ) THEN + CALL spec_bdy_final ( tracer(ims,kms,jms,im), grid%muts, grid%msfty, & + tracer_bxs(jms,kms,1,im),tracer_bxe(jms,kms,1,im), & + tracer_bys(ims,kms,1,im),tracer_bye(ims,kms,1,im), & + tracer_btxs(jms,kms,1,im),tracer_btxe(jms,kms,1,im), & + tracer_btys(ims,kms,1,im),tracer_btye(ims,kms,1,im), & + 't', config_flags, & + config_flags%spec_bdy_width, grid%spec_zone, & + grid%dtbc, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + ENDIF + + END DO tracer_species_bdy_loop_3 + + scalar_species_bdy_loop_3 : DO is = PARAM_FIRST_SCALAR , num_3d_s + + IF( ( config_flags%nested ) ) THEN + CALL spec_bdy_final ( scalar(ims,kms,jms,is), grid%muts, grid%msfty, & + scalar_bxs(jms,kms,1,is),scalar_bxe(jms,kms,1,is), & + scalar_bys(ims,kms,1,is),scalar_bye(ims,kms,1,is), & + scalar_btxs(jms,kms,1,is),scalar_btxe(jms,kms,1,is), & + scalar_btys(ims,kms,1,is),scalar_btye(ims,kms,1,is), & + 't', config_flags, & + config_flags%spec_bdy_width, grid%spec_zone, & + grid%dtbc, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + ENDIF + + END DO scalar_species_bdy_loop_3 + + END DO tile_bc_loop_3 + !$OMP END PARALLEL DO + grid%dtbc = grid%dtbc + grid%dt ENDIF @@ -4120,6 +4546,9 @@ SUBROUTINE solve_em ( grid , config_flags & ! for use in fractional merging of external/coupled SST and input SST. IF ( coupler_on ) grid%just_read_auxinput4 = Is_alarm_tstep(grid%domain_clock, grid%alarms(AUXINPUT4_ALARM)) +! Are we about to read the lateral boundary file? This is a domain one action only. + IF ( grid%id .EQ. 1 ) grid%just_read_boundary = Is_alarm_tstep(grid%domain_clock, grid%alarms(BOUNDARY_ALARM)) + ! Finish timers if compiled with -DBENCH. #include diff --git a/wrfv2_fire/dyn_em/start_em.F b/wrfv2_fire/dyn_em/start_em.F index 9b9e183c..69973f97 100644 --- a/wrfv2_fire/dyn_em/start_em.F +++ b/wrfv2_fire/dyn_em/start_em.F @@ -26,8 +26,8 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & USE module_physics_init USE module_lightning_driver, ONLY : lightning_init USE module_fr_fire_driver_wrf, ONLY : fire_driver_em_init - USE module_stoch, ONLY : SETUP_STOCH_SPPT,SETUP_STOCH_SKEBS,rand_seed, update_stoch -#ifdef WRF_CHEM + USE module_stoch, ONLY : setup_rand_perturb, rand_seed, update_stoch +#if (WRF_CHEM == 1) USE module_aerosols_sorgam, ONLY: sum_pm_sorgam USE module_gocart_aerosols, ONLY: sum_pm_gocart USE module_mosaic_driver, ONLY: sum_pm_mosaic @@ -69,8 +69,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & INTEGER :: i_m - REAL :: p00, t00, a, tiso, p_surf, pd_surf, temp, tiso_tmp -#ifdef WRF_CHEM + REAL :: p_top_test, p00, t00, a, tiso, p_surf, pd_surf, temp, tiso_tmp + REAL :: p_strat, a_strat +#if (WRF_CHEM == 1) REAL RGASUNIV ! universal gas constant [ J/mol-K ] PARAMETER ( RGASUNIV = 8.314510 ) REAL,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) :: & @@ -85,7 +86,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & LOGICAL :: first_trip_for_this_domain, start_of_simulation, fill_w_flag LOGICAL, EXTERNAL :: wrf_dm_on_monitor -#ifndef WRF_CHEM +#if (WRF_CHEM != 1) REAL,ALLOCATABLE,DIMENSION(:,:,:) :: cldfra_old #endif @@ -106,6 +107,12 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ! ! Define variables local (topo_wind local vars) REAL :: alpha, vfac + INTEGER :: j_save + + ! For a global domain + + INTEGER :: alloc_status + CHARACTER (LEN=256) :: alloc_err_message !..Need to fill special height var for setting up initial condition. G. Thompson REAL, ALLOCATABLE, DIMENSION(:,:,:) :: z_at_q @@ -122,7 +129,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & kts = kps ; kte = kpe ! note that tile is entire patch its = ips ; ite = ipe ! note that tile is entire patch jts = jps ; jte = jpe ! note that tile is entire patch -#ifndef WRF_CHEM +#if (WRF_CHEM != 1) ALLOCATE(CLDFRA_OLD(IMS:IME,KMS:KME,JMS:JME),STAT=I) ; CLDFRA_OLD = 0. #endif ALLOCATE(z_at_q(IMS:IME,KMS:KME,JMS:JME),STAT=I) ; z_at_q = 0. @@ -144,7 +151,19 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & #ifdef DM_PARALLEL ! WARNING: this might present scaling issues on very large numbers of processors - ALLOCATE( clat_glob(ids:ide,jds:jde) ) + alloc_err_message = ' ' + alloc_err_message(1:12) = 'NO PROBLEMOS' +#if 0 + ALLOCATE( clat_glob(ids:ide,jds:jde), STAT=alloc_status, ERRMSG=alloc_err_message ) +#else + ALLOCATE( clat_glob(ids:ide,jds:jde), STAT=alloc_status) + alloc_err_message = 'Allocation of space for a global field failed.' +#endif + + IF ( alloc_status .NE. 0 ) THEN + CALL wrf_message ( TRIM(alloc_err_message) ) + CALL wrf_error_fatal ( 'Error allocating entire domain size of 2d array CLAT for global domain' ) + END IF CALL wrf_patch_to_global_real ( grid%clat, clat_glob, grid%domdesc, 'xy', 'xy', & ids, ide, jds, jde, 1, 1, & @@ -155,6 +174,24 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%clat_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex) + find_j_index_of_fft_filter : DO j = jds , jde-1 + IF ( ABS(clat_glob(ids,j)) .LE. config_flags%fft_filter_lat ) THEN + j_save = j + EXIT find_j_index_of_fft_filter + END IF + END DO find_j_index_of_fft_filter + + CALL wrf_patch_to_global_real ( grid%msft, clat_glob, grid%domdesc, 'xy', 'xy', & + ids, ide, jds, jde, 1, 1, & + ims, ime, jms, jme, 1, 1, & + its, ite, jts, jte, 1, 1 ) + + CALL wrf_dm_bcast_real ( clat_glob , (ide-ids+1)*(jde-jds+1) ) + + grid%mf_fft = clat_glob(ids,j_save) + + grid%mf_xxx(ipsx:ipex,jpsx:jpex) = clat_glob(ipsx:ipex,jpsx:jpex) + DEALLOCATE( clat_glob ) #endif ENDIF @@ -178,7 +215,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%itimestep=0 ENDIF - IF ( config_flags%restart .or. grid%moved ) THEN + IF ( config_flags%restart .or. grid%moved .or. config_flags%cycling) THEN first_trip_for_this_domain = .TRUE. ENDIF @@ -188,65 +225,103 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%did_stoch = .FALSE. END IF - IF ( ( grid%id == 1 ) .AND. & - ( grid%stoch_force_global_opt == 1 ) .AND. & - ( .NOT. grid%did_stoch ) ) THEN + IF ((( grid%id == 1) .AND. (.NOT. grid%did_stoch)) .AND. & + (( grid%skebs_on== 1) .OR.( grid%sppt_on== 1) .OR. ( grid%rand_perturb_on== 1))) THEN grid%did_stoch = .TRUE. - IF ( wrf_dm_on_monitor () ) THEN - CALL rand_seed ( config_flags, grid%SEED1, grid%SEED2, grid%NENS ) - ENDIF -#ifdef DM_PARALLEL - CALL wrf_dm_bcast_bytes ( grid%SEED1, IWORDSIZE ) - CALL wrf_dm_bcast_bytes ( grid%SEED2, IWORDSIZE ) -#endif - - IF (grid%stoch_force_opt==1) then - grid%SPTFORCC=0.0 - grid%SPTFORCS=0.0 - call SETUP_STOCH_SKEBS(grid%VERTSTRUCC,grid%VERTSTRUCS, & - grid%SPT_AMP,grid%SPSTREAM_AMP, & - grid%VERTAMPT,grid%VERTAMPUV, & - grid%stoch_vertstruc_opt, & - grid%SEED1,grid%SEED2,grid%time_step, & - grid%DX,grid%DY, & - grid%TOT_BACKSCAT_PSI,grid%TOT_BACKSCAT_T, & - grid%ZTAU_PSI,grid%ZTAU_T,grid%REXPONENT_PSI,grid%REXPONENT_T, & - grid%KMINFORC,grid%KMAXFORC,grid%LMINFORC,grid%LMAXFORC, & - grid%KMINFORCT,grid%KMAXFORCT,grid%LMINFORCT,grid%LMAXFORCT, & - grid%KMAXFORCH,grid%LMAXFORCH,grid%KMAXFORCTH,grid%LMAXFORCTH, & - grid%ZSIGMA2_EPS,grid%ZSIGMA2_ETA, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) - END IF - IF (grid%stoch_force_opt==2) then - call SETUP_STOCH_SPPT(grid%VERTSTRUCC,grid%VERTSTRUCS, & + IF (grid%skebs_on==1) then + +! Initialize SKEBS +! Initialize streamfunction (1) + if (.not.config_flags%restart) then + call rand_seed (config_flags, grid%ISEED_SKEBS, grid%iseedarr_skebs , kms, kme) + endif + call SETUP_RAND_PERTURB('W', & + grid%skebs_vertstruc,config_flags%restart, & + grid%SPSTREAM_AMP, & + grid%SPSTREAMFORCS,grid%SPSTREAMFORCC,grid%ALPH_PSI,& + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPUV, & + grid%KMINFORCT,grid%KMAXFORCT, & + grid%LMINFORCT,grid%LMAXFORCT, & + grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%time_step,grid%DX,grid%DY, & + grid%gridpt_stddev_sppt, & + grid%lengthscale_sppt, & + grid%timescale_sppt, & + grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI, & + grid%REXPONENT_PSI, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +! Initialize potential temperature (2) + call SETUP_RAND_PERTURB('T', & + grid%skebs_vertstruc,config_flags%restart, & grid%SPT_AMP, & - grid%SPTFORCC,grid%SPTFORCS, & - grid%VERTAMPT,grid%VERTAMPUV, & - grid%stoch_vertstruc_opt, & - grid%SEED1,grid%SEED2,grid%time_step, & - grid%DX,grid%DY, & - grid%gridpointvariance,grid%l_sppt,grid%tau_sppt, & - grid%KMINFORCT,grid%KMAXFORCT,grid%LMINFORCT,grid%LMAXFORCT, & - grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%SPTFORCS,grid%SPTFORCC,grid%ALPH_T, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT, & + grid%KMINFORCT,grid%KMAXFORCT, & + grid%LMINFORCT,grid%LMAXFORCT, & + grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%time_step,grid%DX,grid%DY, & + grid%gridpt_stddev_sppt, & + grid%lengthscale_sppt, & + grid%timescale_sppt, & + grid%TOT_BACKSCAT_T,grid%ZTAU_T, & + grid%REXPONENT_T, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - ENDIF - do i=1,600 - CALL UPDATE_STOCH(grid%SPSTREAMFORCS,grid%SPSTREAMFORCC, & - grid%SPTFORCS,grid%SPTFORCC, & - grid%SPT_AMP,grid%SPSTREAM_AMP, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) - enddo + ENDIF +IF (grid%sppt_on==1) then +! Initialize SPPT (3) + if (.not.config_flags%restart) then ! set random number seed (else iseedarray is read in from restart files) + call rand_seed (config_flags, grid%ISEED_SPPT, grid%iseedarr_sppt , kms, kme) + endif + call SETUP_RAND_PERTURB('P', & + grid%sppt_vertstruc,config_flags%restart, & + grid%SPPT_AMP, & + grid%SPPTFORCC,grid%SPPTFORCS,grid%ALPH_SPPT, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT, & + grid%KMINFORCT,grid%KMAXFORCT, & + grid%LMINFORCT,grid%LMAXFORCT, & + grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%time_step,grid%DX,grid%DY, & + grid%gridpt_stddev_sppt, & + grid%lengthscale_sppt, & + grid%timescale_sppt, & + grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI, & + grid%REXPONENT_PSI, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF - END IF +! Initialize RAND_PERTURB (4) + IF (grid%rand_perturb_on==1) then + if (.not.config_flags%restart) then ! set random number seed (else iseedarray is read in from restart files) + call rand_seed (config_flags, grid%ISEED_RAND_PERT, grid%iseedarr_rand_pert , kms, kme) + endif + call SETUP_RAND_PERTURB('R', & + grid%rand_pert_vertstruc,config_flags%restart, & + grid%SP_AMP, & + grid%SPFORCC,grid%SPFORCS,grid%ALPH_RAND, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT, & + grid%KMINFORCT,grid%KMAXFORCT, & + grid%LMINFORCT,grid%LMAXFORCT, & + grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%time_step,grid%DX,grid%DY, & + grid%gridpt_stddev_rand_pert, & + grid%lengthscale_rand_pert, & + grid%timescale_rand_pert, & + grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI, & + grid%REXPONENT_PSI, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF + ENDIF ! skebs or sppt or rand_perturb ! --- END SETUP STOCHASTIC PERTURBATION SCHEMES ---------- @@ -412,11 +487,23 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & END IF END IF + ! Make sure that the base-state vales have not changed between what is in the input file + ! and the namelist file. + + IF ( .NOT. grid%this_is_an_ideal_run ) THEN + CALL nl_get_p_top_requested ( 1 , p_top_test ) + IF ( grid%p_top .NE. p_top_test ) THEN + CALL wrf_error_fatal ( 'start_em: p_top from the namelist does not match p_top from the input file.' ) + END IF + END IF + IF ( config_flags%use_baseparam_fr_nml ) then - CALL nl_get_base_pres ( 1 , p00 ) - CALL nl_get_base_temp ( 1 , t00 ) - CALL nl_get_base_lapse ( 1 , a ) - CALL nl_get_iso_temp ( 1 , tiso ) + CALL nl_get_base_pres ( 1 , p00 ) + CALL nl_get_base_temp ( 1 , t00 ) + CALL nl_get_base_lapse ( 1 , a ) + CALL nl_get_iso_temp ( 1 , tiso ) + CALL nl_get_base_lapse_strat ( 1 , a_strat ) + CALL nl_get_base_pres_strat ( 1 , p_strat ) IF ( ( t00 .LT. 100. .or. p00 .LT. 10000.) .AND. ( .NOT. grid%this_is_an_ideal_run ) ) THEN WRITE(wrf_err_message,*) 'start_em: BAD BASE STATE for T00 or P00 in namelist.input file' CALL wrf_error_fatal(TRIM(wrf_err_message)) @@ -425,10 +512,12 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ELSE ! get these constants from model data - t00 = grid%t00 - p00 = grid%p00 - a = grid%tlp - tiso = grid%tiso + t00 = grid%t00 + p00 = grid%p00 + a = grid%tlp + tiso = grid%tiso + a_strat = grid%tlp_strat + p_strat = grid%p_strat IF ( ( t00 .LT. 100. .or. p00 .LT. 10000.) .AND. ( .NOT. grid%this_is_an_ideal_run ) ) THEN WRITE(wrf_err_message,*)& 'start_em: did not find base state parameters in wrfinput. Add use_baseparam_fr_nml = .t. in &dynamics and rerun' @@ -462,13 +551,19 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ! Base state pressure is a function of eta level and terrain, only, plus ! the hand full of constants: p00 (sea level pressure, Pa), t00 (sea level - ! temperature, K), and A (temperature difference, from 1000 mb to 300 mb, K). + ! temperature, K), A (temperature difference, from 1000 mb to 300 mb, K), + ! tiso (isothermal temperature at tropopause/lower stratosphere), + ! p_strat (pressure at top of isothermal layer), A_strat (lapse rate in + ! stratosphere above isothermal layer) p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 ) DO k = 1, kte-1 grid%pb(i,k,j) = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) ) + IF ( grid%pb(i,k,j) .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat ) + ENDIF grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0 ! grid%t_init(i,k,j) = (t00 + A*LOG(grid%pb(i,k,j)/p00))*(p00/grid%pb(i,k,j))**(r_d/cp) - t0 grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm @@ -560,6 +655,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN grid%pb(i,k,j) = grid%znu(k)*grid%mub(i,j)+grid%p_top temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) ) + IF ( grid%pb(i,k,j) .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat ) + ENDIF grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0 grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm ENDIF @@ -582,6 +680,25 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ENDIF ! Use equations from calc_p_rho_phi to derive p and al from ph: linear in log p +!----------------------------------------------------------------------------- +!tgs - rebalance if the model is cycled but does not run DFI +! For HRRR application +! Rebalance recomputes 1/rho, p, ph_2, ph0, p_hyd + + IF ( ( grid%dfi_opt .EQ. DFI_NODFI ) .and. config_flags%cycling ) then + call rebalance_driver_cycl (grid ) + + DO j = jts,min(jte,jde-1) + DO k = kts,kte + DO i = its, min(ite,ide-1) + grid%ph_1(i,k,j)=grid%ph_2(i,k,j) + ENDDO + ENDDO + ENDDO + +! ENDIF + ELSE +!------------------------------------------------------------------------------ IF ( config_flags%hypsometric_opt .EQ. 1 ) THEN DO j=jts,min(jte,jde-1) @@ -617,6 +734,8 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ENDDO ENDDO ENDDO + ENDIF ! rebalance +!------------------------------------------------------------------------------------- IF ( .NOT. grid%this_is_an_ideal_run ) THEN DO j=jts,min(jte,jde-1) @@ -679,9 +798,12 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & MPDT = 0. !tgs - IF(config_flags%cycling) start_of_simulation = .true. + IF(config_flags%cycling) THEN + start_of_simulation = .true. ! print *,'cycling, start_of_simulation -->',config_flags%cycling, start_of_simulation - + grid%xtime=0. +! print *,'xtime=',grid%xtime + ENDIF !----------------------------------------------------------------------------- ! Adaptive time step: Added by T. Hutchinson, WSI 11/6/07 ! @@ -777,6 +899,11 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%rublten,grid%rvblten,grid%rthblten, & grid%rqvblten,grid%rqcblten,grid%rqiblten, & grid%rthraten,grid%rthratenlw,grid%rthratensw, & + !BSINGH - For WRFCuP scheme(11/12/2013) + grid%cupflag,grid%cldfra_cup,grid%cldfratend_cup, & !wig, 18-Sep-2006 + grid%shall, & !wig, 18-Sep-2006 + grid%tcloud_cup, & !rce, 18-apr-2012 + !BSINGH - ENDS grid%stepbl,grid%stepra,grid%stepcu, & grid%w0avg, grid%rainnc, grid%rainc, grid%raincv, grid%rainncv, & grid%snownc, grid%snowncv, grid%graupelnc, grid%graupelncv, & @@ -788,10 +915,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%mass_flux, & grid%rthften, grid%rqvften, & grid%cldfra, & -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) grid%cldfra_old, & -#endif -#ifndef WRF_CHEM +#else cldfra_old, & #endif grid%glw,grid%gsw,grid%emiss,grid%embck, & @@ -840,7 +966,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%CHXY, grid%FWETXY, grid%SNEQVOXY, grid%ALBOLDXY, grid%QSNOWXY, & ! Optional Noah-MP grid%WSLAKEXY, grid%ZWTXY, grid%WAXY, grid%WTXY, grid%LFMASSXY, grid%RTMASSXY, & ! Optional Noah-MP grid%STMASSXY, grid%WOODXY, grid%STBLCPXY, grid%FASTCPXY, & ! Optional Noah-MP - grid%XSAIXY, & ! Optional Noah-MP + grid%XSAIXY,grid%LAI, & ! Optional Noah-MP grid%T2MVXY, grid%T2MBXY, grid%CHSTARXY, & ! Optional Noah-MP grid%SMOISEQ ,grid%SMCWTDXY ,grid%RECHXY, grid%DEEPRECHXY, grid%AREAXY, & ! Optional Noah-MP config_flags%wtddt ,grid%stepwtd ,grid%QRFSXY ,grid%QSPRINGSXY ,grid%QSLATXY, & ! Optional Noah-MP @@ -853,6 +979,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%TRL_URB3D, grid%TBL_URB3D, grid%TGL_URB3D, & !Optional urban grid%SH_URB2D, grid%LH_URB2D, grid%G_URB2D, grid%RN_URB2D, & !Optional urban grid%TS_URB2D, grid%FRC_URB2D, grid%UTYPE_URB2D, & !Optional urban + grid%CMCR_URB2D,grid%TGR_URB2D,grid%TGRL_URB3D,grid%SMR_URB3D, & !Optional urban + grid%DRELR_URB2D,grid%DRELB_URB2D,grid%DRELG_URB2D, & !Optional urban + grid%FLXHUMR_URB2D,grid%FLXHUMB_URB2D,grid%FLXHUMG_URB2D, & !Optional urban grid%TRB_URB4D,grid%TW1_URB4D,grid%TW2_URB4D,grid%TGB_URB4D,grid%TLEV_URB3D, & !multi-layer urban grid%QLEV_URB3D,grid%TW1LEV_URB3D,grid%TW2LEV_URB3D, & !multi-layer urban grid%TGLEV_URB3D,grid%TFLEV_URB3D,grid%SF_AC_URB3D, & !multi-layer urban @@ -946,6 +1075,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ,grid%massflux_EDKF, grid%entr_EDKF, grid%detr_EDKF & ,grid%thl_up,grid%thv_up,grid%rt_up & ,grid%rv_up,grid%rc_up,grid%u_up,grid%v_up,grid%frac_up & + ,grid%ccn_conc & ! RAS ,grid%QKE &!JOE-for mynn ,grid%landusef,grid%landusef2,grid%mosaic_cat_index & ! danli mosaic ,grid%TSK_mosaic,grid%TSLB_mosaic,grid%SMOIS_mosaic,grid%SH2O_mosaic & ! danli mosaic @@ -1009,7 +1139,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ! IC and CG flash rates and accumulated flash count ,ic_flashcount=grid%ic_flashcount, ic_flashrate=grid%ic_flashrate & ,cg_flashcount=grid%cg_flashcount, cg_flashrate=grid%cg_flashrate & -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) ,lnox_opt=config_flags%lnox_opt & ,lnox_passive=config_flags%lnox_passive & ,lnox_total=tracer(:,:,:,p_lnox_total) & @@ -1417,7 +1547,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ENDIF -#ifdef WRF_CHEM +#if (WRF_CHEM == 1) if(config_flags%tracer_opt > 0 )then call initialize_tracer (tracer,config_flags%chem_in_opt, & config_flags%tracer_opt,num_tracer, & @@ -1464,6 +1594,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%dgnum4d, grid%dgnumwet4d, grid%dgnum_a1, grid%dgnum_a2, & grid%dgnum_a3, grid%dgnumwet_a1, grid%dgnumwet_a2, grid%dgnumwet_a3, & grid%pm2_5_dry,grid%pm2_5_water,grid%pm2_5_dry_ec, & + grid%tsoa,grid%asoa,grid%bsoa, & grid%last_chem_time_year,grid%last_chem_time_month, & grid%last_chem_time_day,grid%last_chem_time_hour, & grid%last_chem_time_minute,grid%last_chem_time_second, & @@ -1477,7 +1608,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ! ! print *,'calculating initial pm' select case (config_flags%chem_opt) - case (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP) + case (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2) call sum_pm_gocart ( & grid%alt, chem, grid%pm2_5_dry, grid%pm2_5_dry_ec,grid%pm10,& ids,ide, jds,jde, kds,kde, & @@ -1517,6 +1648,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%pm2_5_water(i,k,j) = 0. grid%pm2_5_dry_ec(i,k,j) = 0. grid%pm10(i,k,j) = 0. + grid%tsoa(i,k,j) = 0. enddo enddo enddo @@ -1599,7 +1731,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & its , ite , jts , jte , & its , ite , jts , jte ) -#ifndef WRF_CHEM +#if (WRF_CHEM != 1) DEALLOCATE(CLDFRA_OLD) #endif #ifdef DM_PARALLEL @@ -1643,6 +1775,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ,e=grid%e & ! Namelist info ,use_tot_or_hyd_p=config_flags%use_tot_or_hyd_p & + ,extrap_below_grnd=config_flags%extrap_below_grnd & ,missing=config_flags%p_lev_missing & ! The diagnostics, mostly output variables ,num_press_levels=config_flags%num_press_levels & @@ -1656,6 +1789,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ,ght_pl= grid%ght_pl & ,s_pl = grid%s_pl & ,td_pl = grid%td_pl & + ,q_pl = grid%q_pl & ! Dimension arguments ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & @@ -1681,3 +1815,290 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & END SUBROUTINE start_domain_em +!------------------------------------------------------------------- + + SUBROUTINE rebalance_driver_cycl ( grid ) + + USE module_domain, ONLY : domain + IMPLICIT NONE + + TYPE (domain) :: grid + + CALL rebalance_cycl( grid & +! +#include "actual_new_args.inc" +! + ) + + END SUBROUTINE rebalance_driver_cycl + +!--------------------------------------------------------------------- + + SUBROUTINE rebalance_cycl ( grid & +! +#include "dummy_new_args.inc" +! + ) + USE module_domain, ONLY : domain + USE module_configure, ONLY : grid_config_rec_type, model_config_rec + USE module_model_constants + USE module_state_description + USE module_driver_constants, ONLY: DATA_ORDER_XYZ, DATA_ORDER_YXZ, DATA_ORDER_ZXY, & + DATA_ORDER_ZYX, DATA_ORDER_XZY, DATA_ORDER_YZX, & + DATA_ORDER_XY, DATA_ORDER_YX, model_data_order + +#ifdef DM_PARALLEL + USE module_comm_dm, ONLY : & + HALO_EM_INIT_1_sub & + ,HALO_EM_INIT_2_sub & + ,HALO_EM_INIT_3_sub & + ,HALO_EM_INIT_4_sub & + ,HALO_EM_INIT_5_sub & + ,HALO_EM_VINTERP_UV_1_sub +#endif +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + USE module_dm, ONLY : ntasks_x, ntasks_y, ntasks, mytask, local_communicator +#endif + + IMPLICIT NONE + + TYPE (domain) :: grid + +#include "dummy_new_decl.inc" + + TYPE (grid_config_rec_type) :: config_flags + + REAL :: p_surf , pd_surf, p_surf_int , pb_int , ht_hold + REAL :: qvf , qvf1 , qvf2, qtot + REAL :: pfu, pfd, phm + + ! Local domain indices and counters. + + INTEGER :: n_moist + + INTEGER :: & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + ips, ipe, jps, jpe, kps, kpe, & + i, j, k, ispe, ktf + + SELECT CASE ( model_data_order ) + CASE ( DATA_ORDER_ZXY ) + kds = grid%sd31 ; kde = grid%ed31 ; + ids = grid%sd32 ; ide = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + kms = grid%sm31 ; kme = grid%em31 ; + ims = grid%sm32 ; ime = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + kts = grid%sp31 ; kte = grid%ep31 ; ! note that tile is entire patch + its = grid%sp32 ; ite = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + CASE ( DATA_ORDER_XYZ ) + ids = grid%sd31 ; ide = grid%ed31 ; + jds = grid%sd32 ; jde = grid%ed32 ; + kds = grid%sd33 ; kde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + jms = grid%sm32 ; jme = grid%em32 ; + kms = grid%sm33 ; kme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + jts = grid%sp32 ; jte = grid%ep32 ; ! note that tile is entire patch + kts = grid%sp33 ; kte = grid%ep33 ; ! note that tile is entire patch + + CASE ( DATA_ORDER_XZY ) + ids = grid%sd31 ; ide = grid%ed31 ; + kds = grid%sd32 ; kde = grid%ed32 ; + jds = grid%sd33 ; jde = grid%ed33 ; + + ims = grid%sm31 ; ime = grid%em31 ; + kms = grid%sm32 ; kme = grid%em32 ; + jms = grid%sm33 ; jme = grid%em33 ; + + its = grid%sp31 ; ite = grid%ep31 ; ! note that tile is entire patch + kts = grid%sp32 ; kte = grid%ep32 ; ! note that tile is entire patch + jts = grid%sp33 ; jte = grid%ep33 ; ! note that tile is entire patch + + END SELECT + + ktf=MIN(kte,kde-1) + + DO j=jts,jte + DO i=its,ite + grid%ph_2(i,1,j) = 0. + END DO + END DO + + ! Base state potential temperature and inverse density (alpha = 1/rho) from + ! the half eta levels and the base-profile surface pressure. Compute 1/rho + ! from equation of state. The potential temperature is a perturbation from t0. + + n_moist = num_moist + + print *,'n_moist,PARAM_FIRST_SCALAR',n_moist,PARAM_FIRST_SCALAR + + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + + IF (n_moist >= PARAM_FIRST_SCALAR ) THEN + ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum + ! equation) down from the top to get the pressure perturbation. First get the pressure + ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. + + k = kte - 1 + + qtot = 0. + DO ispe=PARAM_FIRST_SCALAR,n_moist + qtot = qtot + 0.5*(moist(i,k,j,ispe)+moist(i,k,j,ispe)) + ENDDO + qvf2 = 1./(1.+qtot) + qvf1 = qtot*qvf2 + + grid%p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2 + qvf = 1.+rvovrd*moist(i,k,j,P_QV) + grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* & + (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) + grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + + + ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two + ! inverse density fields (total and perturbation). + + DO k=kte-2,kts,-1 + + qtot = 0. + DO ispe=PARAM_FIRST_SCALAR,n_moist + qtot = qtot + 0.5*( moist(i,k ,j,ispe) + moist(i,k+1,j,ispe) ) + ENDDO + qvf2 = 1./(1.+qtot) + qvf1 = qtot*qvf2 + grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_2(i,j) + & + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* & + (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) + grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + ENDDO + + ! This is the hydrostatic equation used in the model after the + ! small timesteps. In + ! the model, grid%al (inverse density) is computed from the + ! geopotential. + + IF (grid%hypsometric_opt == 1) THEN + DO k = 2,kte + grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - & + grid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,k-1,j) & + + grid%mu_2(i,j)*grid%alb(i,k-1,j) ) + grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j) + END DO + ELSE IF (grid%hypsometric_opt == 2) THEN + ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is + ! dry pressure. + ! Note that al*p approximates Rd*T and dLOG(p) does z. + ! Here T varies mostly linear with z, the first-order + ! integration produces better result. + + grid%ph_2(i,1,j) = grid%phb(i,1,j) + DO k = 2,kte + pfu = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k) + grid%p_top + pfd = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k-1) + grid%p_top + phm = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k-1) + grid%p_top + grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu) + END DO + + DO k = 1,kte + grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j) + END DO + + DO k = 1,kte + grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j) + END DO + END IF ! hypsometric option + + ELSE ! n_moist + + k = kte - 1 + + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + + grid%p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf & + *(((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) + grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + + ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two + ! inverse density fields (total and perturbation). + + DO k=kte-2,kts,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_2(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* & + (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) + grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + ENDDO + ! This is the hydrostatic equation used in the model after the small timesteps. In + ! the model, grid%al (inverse density) is computed from the geopotential. + + IF (grid%hypsometric_opt == 1) THEN + DO k = 2,kte + grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - & + grid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,k-1,j) & + + grid%mu_2(i,j)*grid%alb(i,k-1,j) ) + grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j) + END DO + ELSE IF (grid%hypsometric_opt == 2) THEN + + ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry + ! pressure. + ! Note that al*p approximates Rd*T and dLOG(p) does z. + ! Here T varies mostly linear with z, the first-order integration + ! produces better result. + + grid%ph_2(i,1,j) = grid%phb(i,1,j) + DO k = 2,kte + pfu = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k) + grid%p_top + pfd = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k-1) + grid%p_top + phm = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k-1) + grid%p_top + grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu) + END DO + + DO k = 1,kte + grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j) + END DO + + DO k = 1,kte + grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j) + END DO + + END IF ! hypsometric + ENDIF ! nmoist + + END DO !i + ENDDO !j + + ips = its ; ipe = ite ; jps = jts ; jpe = jte ; kps = kts ; kpe = kte +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) +# include "HALO_EM_INIT_1.inc" +# include "HALO_EM_INIT_2.inc" +# include "HALO_EM_INIT_3.inc" +# include "HALO_EM_INIT_4.inc" +# include "HALO_EM_INIT_5.inc" +#endif + END SUBROUTINE rebalance_cycl + +!--------------------------------------------------------------------- diff --git a/wrfv2_fire/dyn_nmm/Makefile b/wrfv2_fire/dyn_nmm/Makefile index 69f2142e..e68ec778 100644 --- a/wrfv2_fire/dyn_nmm/Makefile +++ b/wrfv2_fire/dyn_nmm/Makefile @@ -26,8 +26,11 @@ MODULES = \ module_PHYSICS_CALLS.o \ module_IGWAVE_ADJUST.o \ module_membrane_mslp.o \ + module_swath.o \ module_tracker.o \ + module_tornado_genesis.o \ module_relax.o \ + nmm_get_cpu.o \ $(CASE_MODULE) # moved into share/Makefile diff --git a/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F b/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F index f98a9b64..f25843c1 100644 --- a/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F +++ b/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F @@ -80,9 +80,13 @@ SUBROUTINE med_nest_egrid_configure ( parent , nest ) if (parent%parent_id == 0 ) then ! Dusan's doing parent%wbd0 = -(IDE-2)*parent%dx ! WBD0: in degrees;factor 2 takes care of dummy last column parent%sbd0 = -((JDE-1)/2)*parent%dy ! SBD0: in degrees; note that JDE-1 should be odd + parent%wbd0var = parent%wbd0 + parent%sbd0var = parent%sbd0 end if nest%wbd0 = parent%wbd0 + (nest%i_parent_start-1)*2.*parent%dx + mod(nest%j_parent_start+1,2)*parent%dx nest%sbd0 = parent%sbd0 + (nest%j_parent_start-1)*parent%dy + nest%wbd0var = nest%wbd0 + nest%sbd0var = nest%sbd0 nest%dx = parent%dx/nest%parent_grid_ratio nest%dy = parent%dy/nest%parent_grid_ratio @@ -415,6 +419,7 @@ SUBROUTINE EARTH_LATLON ( HLAT,HLON,VLAT,VLON, & !Earth lat,lon at H and V p ! local + INTEGER,PARAMETER :: KNUM=SELECTED_REAL_KIND(13) INTEGER :: I,J REAL(KIND=KNUM) :: WB,SB,DLM,DPH,TPH0,STPH0,CTPH0 @@ -422,21 +427,28 @@ SUBROUTINE EARTH_LATLON ( HLAT,HLON,VLAT,VLON, & !Earth lat,lon at H and V p REAL(KIND=KNUM) :: STPH,CTPH,STPV,CTPV,PI_2 REAL(KIND=KNUM) :: SPHH,CLMH,FACTH,SPHV,CLMV,FACTV REAL(KIND=KNUM), DIMENSION(IMS:IME,JMS:JME) :: GLATH,GLONH,GLATV,GLONV + REAL(KIND=KNUM) :: DLMD8,DPHD8,WBD8,SBD8,CLAT8,CLON8 + REAL(KIND=KNUM) :: CPHH, CPHV !------------------------------------------------------------------------- - + DLMD8=DLMD1 + DPHD8=DPHD1 + WBD8=WBD1 + SBD8=SBD1 + CLAT8=CENTRAL_LAT + CLON8=CENTRAL_LON ! PI_2 = ACOS(0.) DTR = PI_2/90. - WB = WBD1 * DTR ! WB: western boundary in radians - SB = SBD1 * DTR ! SB: southern boundary in radians - DLM = DLMD1 * DTR ! DLM: dlamda in radians - DPH = DPHD1 * DTR ! DPH: dphi in radians + WB = WBD8 * DTR ! WB: western boundary in radians + SB = SBD8 * DTR ! SB: southern boundary in radians + DLM = DLMD8 * DTR ! DLM: dlamda in radians + DPH = DPHD8 * DTR ! DPH: dphi in radians TDLM = DLM + DLM ! TDLM: 2.0*dlamda TDPH = DPH + DPH ! TDPH: 2.0*DPH ! For earth lat lon only - TPH0 = CENTRAL_LAT*DTR ! TPH0: central lat in radians + TPH0 = CLAT8*DTR ! TPH0: central lat in radians STPH0 = SIN(TPH0) CTPH0 = COS(TPH0) @@ -451,34 +463,37 @@ SUBROUTINE EARTH_LATLON ( HLAT,HLON,VLAT,VLON, & !Earth lat,lon at H and V p CTPH = COS(TPHH) STPV = SIN(TPHV) CTPV = COS(TPHV) - ! .H DO I = ITS,MIN(ITE,IDE-1) ! / TLMH = TLMH0 + I*TDLM ! \.H .U .H ! !H./ ----><---- SPHH = CTPH0 * STPH + STPH0 * CTPH * COS(TLMH) ! DLM + DLM + CPHH = sqrt(1-SPHH**2) GLATH(I,J)=ASIN(SPHH) ! GLATH: Earth Lat in radians - CLMH = CTPH*COS(TLMH)/(COS(GLATH(I,J))*CTPH0) & - - TAN(GLATH(I,J))*TAN(TPH0) + !CLMH = CTPH*COS(TLMH)/(COS(GLATH(I,J))*CTPH0) & + ! - TAN(GLATH(I,J))*TAN(TPH0) + CLMH = (CTPH*COS(TLMH)-SPHH*STPH0) / (CPHH*CTPH0) IF(CLMH .GT. 1.) CLMH = 1.0 IF(CLMH .LT. -1.) CLMH = -1.0 FACTH = 1. IF(TLMH .GT. 0.) FACTH = -1. - GLONH(I,J) = -CENTRAL_LON*DTR + FACTH*ACOS(CLMH) + GLONH(I,J) = -CLON8*DTR + FACTH*ACOS(CLMH) ENDDO DO I = ITS,MIN(ITE,IDE-1) TLMV = TLMV0 + I*TDLM SPHV = CTPH0 * STPV + STPH0 * CTPV * COS(TLMV) + CPHV = sqrt(1-SPHV**2) GLATV(I,J) = ASIN(SPHV) - CLMV = CTPV*COS(TLMV)/(COS(GLATV(I,J))*CTPH0) & - - TAN(GLATV(I,J))*TAN(TPH0) + !CLMV = CTPV*COS(TLMV)/(COS(GLATV(I,J))*CTPH0) & + ! - TAN(GLATV(I,J))*TAN(TPH0) + CLMV = (CTPV*COS(TLMV)-SPHV*STPH0) / (CPHV*CTPH0) IF(CLMV .GT. 1.) CLMV = 1. IF(CLMV .LT. -1.) CLMV = -1. FACTV = 1. IF(TLMV .GT. 0.) FACTV = -1. - GLONV(I,J) = -CENTRAL_LON*DTR + FACTV*ACOS(CLMV) + GLONV(I,J) = -CLON8*DTR + FACTV*ACOS(CLMV) ENDDO @@ -2767,7 +2782,7 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) integer, parameter :: IO_BIN=1, IO_NET=2 - integer :: io_form_input + integer :: io_form_auxinput2 integer :: itsok,iteok,jtsok,jteok CHARACTER(LEN=512) :: message @@ -2777,12 +2792,15 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) call START_TIMING() - write(message,*)"in NEST_TERRAIN config_flags%io_form_input = ", config_flags%io_form_input + write(message,*)"in NEST_TERRAIN config_flags%io_form_auxinput2 = ", config_flags%io_form_auxinput2 CALL wrf_debug(2,trim(message)) - write(message,*)"in NEST_TERRAIN config_flags%auxinput1_inname = ", config_flags%auxinput1_inname + write(message,*)"in NEST_TERRAIN config_flags%auxinput2_inname = ", config_flags%auxinput2_inname CALL wrf_debug(2,trim(message)) - io_form_input = config_flags%io_form_input + io_form_auxinput2 = config_flags%io_form_auxinput2 + ! NOTE: input_type (WRFSI vs. WPS) triggers based on auxinput1 + ! (metgrid) because that is the only way we have of differentiating + ! between WRFSI and WPS if (config_flags%auxinput1_inname(1:7) == "met_nmm") then input_type = 2 else @@ -2870,6 +2888,10 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) write(message,'("Nest d",I0," nest_terrain")') nest%id call END_TIMING(trim(message)) +#ifdef IDEAL_NMM_TC + return ! move return after end_timing to prevent cnmax KWON +#endif + CONTAINS #ifdef DM_PARALLEL SUBROUTINE SLAVE(IDS,IDE,JDS,JDE) @@ -2901,7 +2923,7 @@ SUBROUTINE MASTER(IDS,IDE,JDS,JDE) avc_nest = 0.0 lnd_nest = 0.0 - tr=>terrain_for(level,input_type,io_form_input) + tr=>terrain_for(level,input_type,io_form_auxinput2) ! select subdomain from big fine grid i_add = mod(j_start+1,2) diff --git a/wrfv2_fire/dyn_nmm/depend.dyn_nmm b/wrfv2_fire/dyn_nmm/depend.dyn_nmm index 2d8aa707..15ad8511 100644 --- a/wrfv2_fire/dyn_nmm/depend.dyn_nmm +++ b/wrfv2_fire/dyn_nmm/depend.dyn_nmm @@ -5,8 +5,19 @@ solve_nmm.o: module_BC_NMM.o module_STATS_FOR_MOVE.o \ module_NONHY_DYNAM.o module_DIFFUSION_NMM.o \ module_BNDRY_COND.o module_PHYSICS_CALLS.o \ module_CTLBLK.o module_HIFREQ.o \ - ../phys/module_diag_refl.o \ - ../share/module_random.o ../frame/hires_timer.o + module_swath.o \ + ../share/module_random.o ../frame/hires_timer.o \ + module_tornado_genesis.o nmm_get_cpu.o + +mediation_integrate.o: module_tornado_genesis.o + +module_swath.o: module_tracker.o ../frame/module_dm.o ../frame/module_domain.o \ + ../frame/module_configure.o + +mediation_nest_move.o: ../dyn_nmm/module_tracker.o + +module_tornado_genesis.o: ../frame/module_dm.o ../frame/module_domain.o \ + $(ESMF_MOD_DEPENDENCE) ../frame/module_configure.o module_membrane_mslp.o: module_relax.o ../frame/module_dm.o ../frame/module_domain.o module_tracker.o: module_relax.o ../frame/module_dm.o ../frame/module_domain.o @@ -18,7 +29,8 @@ NMM_NEST_UTILS1.o: module_TERRAIN.o module_SMOOTH_TERRAIN.o \ module_STATS_FOR_MOVE.o: ../frame/module_dm.o ../frame/module_domain.o \ ../frame/module_configure.o module_membrane_mslp.o module_tracker.o -start_domain_nmm.o: module_HIFREQ.o ../share/module_random.o module_STATS_FOR_MOVE.o +start_domain_nmm.o: module_HIFREQ.o ../share/module_random.o module_STATS_FOR_MOVE.o \ + module_tornado_genesis.o module_swath.o ../frame/module_clear_halos.o module_ADVECTION.o: ../share/module_MPP.o module_INDX.o diff --git a/wrfv2_fire/dyn_nmm/module_ADVECTION.F b/wrfv2_fire/dyn_nmm/module_ADVECTION.F index 4272cbd8..27736b52 100644 --- a/wrfv2_fire/dyn_nmm/module_ADVECTION.F +++ b/wrfv2_fire/dyn_nmm/module_ADVECTION.F @@ -1394,6 +1394,7 @@ SUBROUTINE HAD2( & & ,N_IUP_ADH,N_IUP_ADV & & ,IUP_H,IUP_V,IUP_ADH,IUP_ADV & & ,IHE,IHW,IVE,IVW & + & ,advect_Q2 & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1443,6 +1444,7 @@ SUBROUTINE HAD2( & ! !----------------------------------------------------------------------- ! + LOGICAL, INTENT(IN) :: advect_Q2 INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE @@ -1534,10 +1536,18 @@ SUBROUTINE HAD2( & DO I=MYIS_P2,MYIE_P2 EMH (I,J)=ADDT/(08.*DX(I,J)) DARE(I,J)=HBM3(I,J)*DX(I,J)*DY - E1(I,J,KTE)=MAX(Q2(I,J,KTE)*0.5,EPSQ2) - E2(I,J,KTE)=E1(I,J,KTE) ENDDO ENDDO +!$omp parallel do & +!$omp& private(i,j) + if(advect_Q2) then + DO J=MYJS_P3,MYJE_P3 + DO I=MYIS_P2,MYIE_P2 + E1(I,J,KTE)=MAX(Q2(I,J,KTE)*0.5,EPSQ2) + E2(I,J,KTE)=E1(I,J,KTE) + ENDDO + ENDDO + endif !----------------------------------------------------------------------- !$omp parallel do & !$omp& private(dza,dzb,e1x,fpq,hm,i,j,jfp,jfq,k,pp,qp,ssa,ssb,spp,sqp & @@ -1558,15 +1568,17 @@ SUBROUTINE HAD2( & ENDDO ENDDO ! - IF(K0.)THEN - XSUMS_L(I,J,K,5)=DESTIJ - ELSE - XSUMS_L(I,J,K,6)=DESTIJ - ENDIF + if(advect_q2) then + IF(DESTIJ>0.)THEN + XSUMS_L(I,J,K,5)=DESTIJ + ELSE + XSUMS_L(I,J,K,6)=DESTIJ + ENDIF + endif !----------------------------------------------------------------------- #else !----------------------------------------------------------------------- @@ -1826,11 +1847,13 @@ SUBROUTINE HAD2( & XSUMS(4,K)=XSUMS(4,K)+DWSTIJ ENDIF ! - IF(DESTIJ>0.)THEN - XSUMS(5,K)=XSUMS(5,K)+DESTIJ - ELSE - XSUMS(6,K)=XSUMS(6,K)+DESTIJ - ENDIF + if(advect_q2) then + IF(DESTIJ>0.)THEN + XSUMS(5,K)=XSUMS(5,K)+DESTIJ + ELSE + XSUMS(6,K)=XSUMS(6,K)+DESTIJ + ENDIF + endif !----------------------------------------------------------------------- #endif !----------------------------------------------------------------------- @@ -2013,6 +2036,7 @@ SUBROUTINE HAD2( & !----------------------------------------------------------------------- ! + if(advect_Q2) then if(rface<1.)then do j=MYJS2,MYJE2 DO I=MYIS1,MYIE1 @@ -2032,6 +2056,7 @@ SUBROUTINE HAD2( & ENDDO enddo endif + endif ! !----------------------------------------------------------------------- ! @@ -2048,6 +2073,7 @@ SUBROUTINE HAD2( & ! !----------------------------------------------------------------------- ! + if(advect_Q2) then !$omp parallel do & !$omp& private(i,j) DO J=MYJS,MYJE @@ -2071,6 +2097,7 @@ SUBROUTINE HAD2( & ENDDO ENDDO ENDDO + endif !----------------------------------------------------------------------- ! END SUBROUTINE HAD2 diff --git a/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F b/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F index dbe8d73a..b37188de 100644 --- a/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F +++ b/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F @@ -36,9 +36,6 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH & & ,V_BTXS, V_BTXE, V_BTYS, V_BTYE & & ,Q2_BTXS, Q2_BTXE, Q2_BTYS, Q2_BTYE & & ,PD,T,Q,Q2,PINT & -#ifdef WRF_CHEM - & ,CHEM,NUMG,CONFIG_FLAGS & -#endif & ,SPEC_BDY_WIDTH,Z & & ,IHE,IHW,IVE,IVW & & ,IDS,IDE,JDS,JDE,KDS,KDE & @@ -96,9 +93,6 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH & !$$$ !*********************************************************************** !----------------------------------------------------------------------- -#ifdef WRF_CHEM - USE MODULE_INPUT_CHEM_DATA -#endif !----------------------------------------------------------------------- ! IMPLICIT NONE @@ -110,9 +104,6 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE INTEGER,INTENT(IN) :: SPEC_BDY_WIDTH -#ifdef WRF_CHEM - INTEGER,INTENT(IN) :: NUMG -#endif ! INTEGER,DIMENSION(JMS:JME),INTENT(IN) :: IHE,IHW,IVE,IVW ! @@ -165,11 +156,6 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH & & PINT,Q & & ,Q2,T,Z ! -#ifdef WRF_CHEM - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME,NUM_CHEM) & - & ,INTENT(INOUT) :: CHEM - TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS -#endif ! !----------------------------------------------------------------------- ! @@ -189,13 +175,6 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH & !*********************************************************************** !----------------------------------------------------------------------- ! -#ifdef WRF_CHEM -!*** DETERMINE THE INDEX OF THE LAST GAS SPECIES - NUMGAS=P_HO2 - NUMGAS=NUMG -! NUMGAS = GET_LAST_GAS(CONFIG_FLAGS%CHEM_OPT) -! -#endif IM=IDE-IDS+1 JM=JDE-JDS+1 IIM=IM @@ -289,33 +268,6 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH & ENDDO ENDIF ns_if - ns_activate: IF(activate) THEN -#ifdef WRF_CHEM -!$omp parallel do & -!$omp& private(i,k,nv) - DO NV=2,NUMG - DO K=KTS,KTE - DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE) - CALL BDY_CHEM_VALUE (CHEM(I,K,JJ,NV),Z(I,JJ,K),NV,NUMG) - ENDDO - ENDDO - ENDDO -!$omp parallel do & -!$omp& private(i,k,nv) - DO NV=NUMG+1,NUM_CHEM - DO K=KTS,KTE - KK=MIN(K+1,KTE) - DO I=MAX(ITS-1,IDS),MIN(ITE+1,IDE) - PLYR=(PINT(I,JJ,K)+PINT(I,JJ,KK))*0.5 - RRI=R_D*T(I,JJ,K)*(1.+.608*Q(I,JJ,K))/PLYR - CONVFAC=PLYR/RGASUNIV/T(I,JJ,K) - CALL BDY_CHEM_VALUE_SORGAM (CHEM(I,K,JJ,NV),Z(I,JJ,K),NV, & - CONFIG_FLAGS,RRI,CONVFAC,G) - ENDDO - ENDDO - ENDDO -#endif - ENDIF ns_activate ENDDO ns_do ! !----------------------------------------------------------------------- @@ -393,33 +345,6 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH & ENDIF ew_if - ew_activate: IF(activate) THEN -! -#ifdef WRF_CHEM -!$omp parallel do & -!$omp& private(nv,j,k) - DO K=KTS,KTE - KK=MIN(K+1,KTE) - DO J=MAX(JTS-1,JDS+3-1),MIN(JTE+1,JDE-2) - IF(MOD(J,2)==1)THEN - DO NV=2,NUMG - CALL BDY_CHEM_VALUE (CHEM(II,K,J,NV),Z(II,J,K),NV,NUMG) - ENDDO -!$omp parallel do & -!$omp& private(nv) - DO NV=NUMG+1,NUM_CHEM - PLYR=(PINT(II,J,K)+PINT(II,J,KK))*0.5 - RRI=R_D*T(II,J,K)*(1.+P608*Q(II,J,K))/PLYR - CONVFAC=PLYR/RGASUNIV/T(II,J,K) - CALL BDY_CHEM_VALUE_SORGAM (CHEM(II,K,J,NV),Z(II,J,K),NV, & - & CONFIG_FLAGS,RRI,CONVFAC,G) - ENDDO - ENDIF - ENDDO - ENDDO - -#endif - ENDIF ew_activate ENDDO ew_do ! !----------------------------------------------------------------------- @@ -705,9 +630,6 @@ SUBROUTINE MP_BULK_BOUNDARY(GRIDID,NTSD,DT0 & !$$$ !*********************************************************************** !----------------------------------------------------------------------- -#ifdef WRF_CHEM - USE MODULE_INPUT_CHEM_DATA -#endif !----------------------------------------------------------------------- ! IMPLICIT NONE @@ -718,9 +640,6 @@ SUBROUTINE MP_BULK_BOUNDARY(GRIDID,NTSD,DT0 & & ,ITS,ITE,JTS,JTE,KTS,KTE INTEGER,INTENT(IN) :: SPEC_BDY_WIDTH INTEGER,INTENT(IN) :: N_MOIST, N_SCALAR -#ifdef WRF_CHEM - INTEGER,INTENT(IN) :: NUMG -#endif ! INTEGER,INTENT(IN) :: GRIDID INTEGER,INTENT(IN) :: LB,NTSD @@ -764,13 +683,6 @@ SUBROUTINE MP_BULK_BOUNDARY(GRIDID,NTSD,DT0 & !*********************************************************************** !----------------------------------------------------------------------- ! -#ifdef WRF_CHEM -!*** DETERMINE THE INDEX OF THE LAST GAS SPECIES - NUMGAS=P_HO2 - NUMGAS=NUMG -! NUMGAS = GET_LAST_GAS(CONFIG_FLAGS%CHEM_OPT) -! -#endif IM=IDE-IDS+1 JM=JDE-JDS+1 IIM=IM diff --git a/wrfv2_fire/dyn_nmm/module_GWD.F b/wrfv2_fire/dyn_nmm/module_GWD.F index 387d3755..cecd3a47 100644 --- a/wrfv2_fire/dyn_nmm/module_GWD.F +++ b/wrfv2_fire/dyn_nmm/module_GWD.F @@ -136,12 +136,16 @@ SUBROUTINE GWD_init (DTPHS,DELX,DELY,CEN_LAT,CEN_LON,RESTRT & ENDDO !-- I ENDDO !-- J IF (.NOT.RESTRT) THEN -!-- Convert from radians to degrees for WRF input files only - DO J=JTS,JTE - DO I=ITS,ITE - HANGL(I,J)=DTR*HANGL(I,J) !-- convert to degrees (+/-90 deg) - ENDDO !-- I - ENDDO !-- J +!-- Convert from radians to degrees for WRF input files only. +! There should have ano further conversion from rad to degree at this +! point since HANGL read from wrfinput_d01 already in degree even in +! the non restart mode... Chanh +! +! DO J=JTS,JTE +! DO I=ITS,ITE +! HANGL(I,J)=DTR*HANGL(I,J) !-- convert to degrees (+/-90 deg) +! ENDDO !-- I +! ENDDO !-- J ENDIF !dbg !dbg dumin=-1. @@ -1761,7 +1765,7 @@ SUBROUTINE GWD_col (A,B, DUsfc,DVsfc & !-- Output DTAUY = TAUD(I,K) * YN(I) ! --- lm mb (*j*) changes overwrite GWD if ( K .lt. IDXZB(I) .AND. IDXZB(I) .ne. 0 ) then - DBIM = DB(I,K) / (1.+DB(I,K)*DELTIM) + DBIM = DB(I,K) / (1.+ abs(DB(I,K))*DELTIM) A(J,K) = - DBIM * V1(J,K) + A(J,K) B(J,K) = - DBIM * U1(J,K) + B(J,K) DUsfc(J) = DUsfc(J) - DBIM * V1(J,K) * DEL(J,K) diff --git a/wrfv2_fire/dyn_nmm/module_HIFREQ.F b/wrfv2_fire/dyn_nmm/module_HIFREQ.F index 4c2a8b78..7f534d45 100644 --- a/wrfv2_fire/dyn_nmm/module_HIFREQ.F +++ b/wrfv2_fire/dyn_nmm/module_HIFREQ.F @@ -233,7 +233,7 @@ SUBROUTINE HIFREQ_WRITE (LUN,NTSD,DT,HLAT,HLON & END SUBROUTINE hifreq_write - SUBROUTINE hifreq_open ( grid , config_flags ) + SUBROUTINE hifreq_open ( grid , config_flags, atcf ) ! Driver layer USE module_domain , ONLY : domain, domain_clock_get USE module_configure , ONLY : grid_config_rec_type @@ -241,6 +241,7 @@ SUBROUTINE hifreq_open ( grid , config_flags ) IMPLICIT NONE LOGICAL, EXTERNAL :: wrf_dm_on_monitor + logical, intent(in), optional :: atcf ! Arguments TYPE(domain) :: grid TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags @@ -251,9 +252,10 @@ SUBROUTINE hifreq_open ( grid , config_flags ) LOGICAL :: opened CHARACTER*80 :: timestr - character*256 :: message + character*255 :: message integer, parameter :: unitbase = 93, giveup=unitbase+1000 + logical is_atcf INTERFACE SUBROUTINE construct_filename2a( result , basename , fld1 , len1 , date_char ) @@ -265,8 +267,20 @@ SUBROUTINE construct_filename2a( result , basename , fld1 , len1 , date_char ) END SUBROUTINE construct_filename2a END INTERFACE + if(present(atcf)) then + is_atcf=atcf + call wrf_message('hifreq open: is atcf') + else + is_atcf=.false. + call wrf_message('hifreq open: is not atcf') + endif + CALL domain_clock_get( grid, current_timestr=timestr ) - CALL construct_filename2a ( outname ,config_flags%high_freq_outname, grid%id , 2 , timestr ) + if(is_atcf) then + CALL construct_filename2a ( outname ,config_flags%partial_atcf_outname, grid%id , 2 , timestr ) + else + CALL construct_filename2a ( outname ,config_flags%high_freq_outname, grid%id , 2 , timestr ) + endif #ifdef DM_PARALLEL if(wrf_dm_on_monitor()) then @@ -291,10 +305,23 @@ END SUBROUTINE construct_filename2a write(message,'("HIFREQ APPEND ",A1,A80,A1)') '"',trim(outname),'"' call wrf_message(message) open(unit=fid,file=trim(outname),position='append',form='formatted') - grid%hifreq_lun=fid + +308 format(A,' output unit is now ',I0) + if(is_atcf) then + grid%outatcf_lun=fid + write(message,308) 'Partial ATCF',grid%outatcf_lun + else + grid%hifreq_lun=fid + write(message,308) 'Partial ATCF',grid%outatcf_lun + endif + call wrf_message(message) #ifdef DM_PARALLEL else - grid%hifreq_lun=-99 ! must be non-zero but invalid + if(is_atcf) then + grid%outatcf_lun=-99 ! must be non-zero but invalid + else + grid%hifreq_lun=-99 ! must be non-zero but invalid + endif endif #endif END SUBROUTINE hifreq_open diff --git a/wrfv2_fire/dyn_nmm/module_NEST_UTIL.F b/wrfv2_fire/dyn_nmm/module_NEST_UTIL.F index cf1795a7..db1370b4 100644 --- a/wrfv2_fire/dyn_nmm/module_NEST_UTIL.F +++ b/wrfv2_fire/dyn_nmm/module_NEST_UTIL.F @@ -316,7 +316,7 @@ END SUBROUTINE NESTBC_PATCH !---------------------------------------------------------------------------------- SUBROUTINE MSLP_DIAG (MSLP,PINT,T,Q & ,FIS,PD,DETA1,DETA2,PDTOP & - ,IDS,IDE,JDS,JDE,KDS,KDE & + ,IDS,IDF,JDS,JDF,KDS,KDE & ,IMS,IME,JMS,JME,KMS,KME & ,ITS,ITE,JTS,JTE,KTS,KTE ) @@ -329,8 +329,13 @@ SUBROUTINE MSLP_DIAG (MSLP,PINT,T,Q & ! ! ABSTRACT: ! THIS ROUTINE COMPUTES MSLP OVER THE PARENT DOMAIN FOR DIAGONOSTIC PURPOSE +! +! Note: domain I & J end bounds are NOT the usual bounds. They are +! IDE-1 and JDE-1. +! ! PROGRAM HISTORY LOG: ! 07-21-2005 : gopal +! 01-23-2012 : sam: removed 3D Z calculation, updated comments ! ! USAGE: CALL MSLP_DIAG FROM THE SOLVER ! @@ -346,7 +351,7 @@ SUBROUTINE MSLP_DIAG (MSLP,PINT,T,Q & ! global variables - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + INTEGER,INTENT(IN) :: IDS,IDF,JDS,JDF,KDS,KDE & ,IMS,IME,JMS,JME,KMS,KME & ,ITS,ITE,JTS,JTE,KTS,KTE @@ -361,40 +366,70 @@ SUBROUTINE MSLP_DIAG (MSLP,PINT,T,Q & REAL, PARAMETER :: LAPSR=6.5E-3, GI=1./G,D608=0.608 REAL, PARAMETER :: COEF3=287.05*GI*LAPSR, COEF2=-1./COEF3 REAL, PARAMETER :: TRG=2.0*R_D*GI,LAPSI=1.0/LAPSR - REAL :: RTOPP,APELP,DZ,SFCT,A - REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME) :: Z + REAL :: RTOPP,APELP,DZ,SFCT,A,Z1,Z2 INTEGER :: I,J,K !----------------------------------------------------------------------------------------------------- - - DO J = JTS, MIN(JTE,JDE) - DO I = ITS, MIN(ITE,IDE) - Z(I,J,1)=FIS(I,J)*GI - ENDDO - ENDDO - - DO K = KTS,KTE - DO J = JTS, MIN(JTE,JDE) - DO I = ITS, MIN(ITE,IDE) + MSLP=-9999.99 + K=1 + DO J = JTS, MIN(JTE,JDF) + DO I = ITS, MIN(ITE,IDF) + Z1 = FIS(I,J)*GI APELP = (PINT(I,J,K+1)+PINT(I,J,K)) RTOPP = TRG*T(I,J,K)*(1.0+Q(I,J,K)*P608)/APELP DZ = RTOPP*(DETA1(K)*PDTOP+DETA2(K)*PD(I,J)) - Z(I,J,K+1) = Z(I,J,K) + DZ - ENDDO - ENDDO - ENDDO + Z2 = Z1 + DZ - MSLP=-9999.99 - DO J = JTS, MIN(JTE,JDE) - DO I = ITS, MIN(ITE,IDE) - SFCT = T(I,J,1)*(1.+D608*Q(I,J,1)) + LAPSR*(Z(I,J,1)+Z(I,J,2))*0.5 - A = LAPSR*Z(I,J,1)/SFCT + SFCT = T(I,J,1)*(1.+D608*Q(I,J,1)) + LAPSR*(Z1+Z2)*0.5 + A = LAPSR*Z1/SFCT MSLP(I,J) = PINT(I,J,1)*(1-A)**COEF2 ENDDO ENDDO - END SUBROUTINE MSLP_DIAG !------------------------------------------------------------------------------------------------------ +SUBROUTINE CALC_BEST_MSLP(BEST_MSLP,MSLP,MEMBRANE_MSLP,FIS & + ,IDS,IDE,JDS,JDE,KDS,KDE & + ,IMS,IME,JMS,JME,KMS,KME & + ,ITS,ITE,JTS,JTE,KTS,KTE ) + ! Author: Sam Trahan, January 2014 + + ! Calculates a "best estimate" BEST_MSLP from the low-quality MSLP + ! (updated every timestep) and high-quality MEMBRANE_MSLP (updated + ! infrequently). The MSLP is generally bad over high or sharp + ! terrain. + ! Cases: + ! invalid membrane_mslp: use mslp (leading edge of nest after move) + ! height>200m: use membrane_mslp, which is better over terrain + ! height<=0m: use mslp, which should be identical to membrane_mslp here + ! 01) then + do j=max(jts,jds),min(jte,jde-1) + do i=max(its,ids),min(ite,ide-1) + if(grid%interesting(i,j)==0) cycle + wind=u10(i,j)**2 + v10(i,j)**2 + if(wind>grid%windsq_swath(i,j)) grid%windsq_swath(i,j)=wind + enddo + enddo + endif +#endif + IF(CONFIG_FLAGS%SF_SFCLAY_PHYSICS==1)THEN ! non-NMM package !$omp parallel do & !$omp& private(i,j) @@ -2078,9 +2074,9 @@ SUBROUTINE UV_H_TO_V(NTSD,DT,NPHS,UZ0H,VZ0H,UZ0,VZ0 & ! REAL,INTENT(IN) :: DT ! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: HBM2,UZ0H,VZ0H + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: HBM2,UZ0H,VZ0H ! - REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: DUDT,DVDT + REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) :: DUDT,DVDT ! REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: UZ0,VZ0 ! @@ -2162,9 +2158,6 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & & ,MASS_FLUX ,XF_ENS & & ,PR_ENS,GSW & & ,GD_CLOUD,GD_CLOUD2,KTOP_DEEP & -#ifdef WRF_CHEM - & ,RAINCV & -#endif & ,PDTOP,PT,PD,RES,PINT,T,Q,CWM,TCUCN & & ,OMGALF,U,V,W,Z,FIS,W0AVG & & ,PREC,ACPREC,CUPREC,CUPPT,CPRATE & @@ -2290,9 +2283,6 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: GD_CLOUD & & ,GD_CLOUD2 INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: KTOP_DEEP -#ifdef WRF_CHEM - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: RAINCV -#endif ! LOGICAL,INTENT(IN) :: HYDRO,RESTRT LOGICAL :: IS_CAMMGMP_USED=.FALSE. @@ -2318,9 +2308,7 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & ! REAL,DIMENSION(IMS:IME,JMS:JME) :: CUBOT,CUTOP,NCA,PDSL & & ,RAINC,SFCZ,XLAND -#ifndef WRF_CHEM REAL,DIMENSION(IMS:IME,JMS:JME) :: RAINCV -#endif ! REAL,DIMENSION(ITS:ITE,JTS:JTE) :: WMID_L ! @@ -2338,7 +2326,7 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: CLDFRA_DP, CLDFRA_SH REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: QC_CU, QI_CU ! - LOGICAL :: RESTART,WARM_RAIN,ETAMP_Regional + LOGICAL :: RESTART,WARM_RAIN,ETAMP_Regional, have_tg_tp, have_swath LOGICAL,DIMENSION(IMS:IME,JMS:JME) :: CU_ACT_FLAG ! CHARACTER(LEN=255) :: message @@ -2737,6 +2725,13 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & ! !----------------------------------------------------------------------- ! + + have_tg_tp = .false. + have_swath = .false. + have_tg_tp = (size(grid%tg_total_precip)>1) +#ifdef HWRF + have_swath = ( size(grid%precip_swath)>1 ) +#endif !$omp parallel do & !$omp& private(i,iendx,j,ncubot,ncutop,pcpcol) pcp_cloud: DO J=MYJS2,MYJE2 @@ -2752,6 +2747,15 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & CUPREC(I,J)=CUPREC(I,J)+PCPCOL CUPPT(I,J)=CUPPT(I,J)+PCPCOL CPRATE(I,J)=PCPCOL + if(have_tg_tp) then + grid%tg_total_precip(i,j) = grid%tg_total_precip(i,j) + PCPCOL + endif +#ifdef HWRF + if(have_swath) then + if(grid%interesting(i,j)/=0) & + grid%precip_swath(i,j) = grid%precip_swath(i,j) + PCPCOL + endif +#endif ! !*** SAVE CLOUD TOP AND BOTTOM FOR RADIATION (HTOP/HBOT) AND !*** FOR OUTPUT (CNVTOP/CNVBOT, HTOPS/HBOTS, HTOPD/HBOTD) ARRAYS. @@ -2792,11 +2796,11 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & !*** UPDATE TEMPERATURE, SPECIFIC HUMIDITY, AND HEATING. !----------------------------------------------------------------------- ! -!-- ETAMP_Regional logical is true for regional NAM (ETAMPOLD) or HRW (ETAMPNEW) microphysics +!-- ETAMP_Regional logical is true for regional NAM (ETAMPNEW) or HRW (ETAMPNEW) microphysics ! ETAMP_Regional=.FALSE. IF (CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW .OR. & - & CONFIG_FLAGS%MP_PHYSICS==ETAMPOLD) ETAMP_Regional=.TRUE. + & CONFIG_FLAGS%MP_PHYSICS==ETAMP_HR) ETAMP_Regional=.TRUE. ! !$omp parallel do & !$omp& private(dqdt,dtdt,i,iendx,j,k,tchange) @@ -2977,9 +2981,10 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & ! REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: MOIST_TRANS REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: SCALAR_TRANS + REAL,DIMENSION(:,:,:), ALLOCATABLE :: W_TRANS ! LOGICAL :: diag_flag - LOGICAL :: E_BDY,F_QT,QT_PRESENT,WARM_RAIN + LOGICAL :: E_BDY,F_QT,QT_PRESENT,WARM_RAIN, have_tg_tp, have_swath ! !----------------------------------------------------------------------- !*********************************************************************** @@ -2987,6 +2992,7 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & ! ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT) ALLOCATE(SCALAR_TRANS(IMS:IME,KMS:KME,JMS:JME,N_SCALAR),STAT=ISTAT) + ALLOCATE(W_TRANS(IMS:IME,KMS:KME,JMS:JME)) ! !----------------------------------------------------------------------- !*** TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ). @@ -3003,15 +3009,22 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & ENDDO ENDDO ENDDO + do k=kts,kte + do j=jts,jte + do i=its,ite + w_trans(i,k,j)=max(grid%w(i,j,k),grid%w_tot(i,j,k)) + enddo + enddo + enddo ! !----------------------------------------------------------------------- ! -!-- QT_PRESENT logical is true for regional NAM (ETAMPOLD), HRW (ETAMPNEW), +!-- QT_PRESENT logical is true for regional NAM (ETAMPNEW), HRW (ETAMPNEW), ! or HWRF (ETAMP_HWRF) microphysics ! QT_PRESENT=.FALSE. IF (CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW .OR. & - & CONFIG_FLAGS%MP_PHYSICS==ETAMPOLD .OR. & + & CONFIG_FLAGS%MP_PHYSICS==ETAMP_HR .OR. & & CONFIG_FLAGS%MP_PHYSICS==ETAMP_HWRF) QT_PRESENT=.TRUE. ! micro_check1: IF(.NOT.QT_PRESENT) THEN @@ -3100,12 +3113,8 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & & TH=TH_PHY,RHO=RR,PI_PHY=PI_PHY,P=P_PHY & & ,RAINNC=RAINNC,RAINNCV=RAINNCV & & ,DZ8W=DZ,P8W=P8W,DT=DTPHS,DX=DX,DY=DY & - & ,W=grid%W & + & ,W=w_trans & & ,MP_PHYSICS=CONFIG_FLAGS%MP_PHYSICS & -#ifdef WRF_CHEM - & ,CHEM_OPT=CONFIG_FLAGS%CHEM_OPT & - & ,PROGN=CONFIG_FLAGS%PROGN & -#endif & ,SPECIFIED=CONFIG_FLAGS%SPECIFIED & & .OR.CONFIG_FLAGS%NESTED & & ,SPEC_ZONE=0,WARM_RAIN=WARM_RAIN & @@ -3141,6 +3150,7 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & & ,has_reqc=has_reqc & ! G. Thompson & ,has_reqi=has_reqi & ! G. Thompson & ,has_reqs=has_reqs & ! G. Thompson + & ,ccn_conc=config_flags%ccn_conc & ) !$omp parallel do & @@ -3187,6 +3197,10 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & !*** OUT ABOVE SINCE IT IS ONLY A LOCAL ARRAY FOR NOW. !----------------------------------------------------------------------- ! +#ifdef HWRF + have_swath = ( size(grid%precip_swath)>1 ) +#endif + have_tg_tp = (size(grid%tg_total_precip)>1) !$omp parallel do & !$omp& private(i,iendx,j,pcpcol) DO J=MYJS2,MYJE2 @@ -3196,6 +3210,15 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & PCPCOL=RAINNCV(I,J)*1.E-3 PREC(I,J)=PREC(I,J)+PCPCOL ACPREC(I,J)=ACPREC(I,J)+PCPCOL + if(have_tg_tp) then + grid%tg_total_precip(i,j) = grid%tg_total_precip(i,j) + PCPCOL + endif +#ifdef HWRF + if(have_swath) then + if(grid%interesting(i,j)/=0) & + grid%precip_swath(i,j) = grid%precip_swath(i,j) + PCPCOL + endif +#endif ENDDO ENDDO ! diff --git a/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F b/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F index bae15ca9..f9ac2c1a 100644 --- a/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F +++ b/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F @@ -45,11 +45,57 @@ SUBROUTINE VORTTRAK_INIT(grid,config_flags,init, & #ifdef HWRF vortex_tracker=grid%vortex_tracker - if(vortex_tracker<1 .or. vortex_tracker>6) then - write(message,*)' domain ',grid%id,' has an invalid value ',vortex_tracker,' for vortex_tracker. It must be 1, 2, 3, 4 or 5.' + if(vortex_tracker<1 .or. vortex_tracker>7) then +31 format('Domain ',I0,' has invalid value ',I0,' for vortex_tracker: it must be an integer from 1-7') + write(message,31) grid%id,vortex_tracker call wrf_error_fatal(message) endif + if(grid%swath_mode==1) then + ! Check swath area of interest configuration, correct errors and + ! give meaningful error messages: + if(grid%interest_storms/=0 .and. vortex_tracker/=6 .and. vortex_tracker/=7) then + grid%interest_storms=0 + if(vortex_tracker==2) then + if(grid%interest_kids/=0) then + ! User set up vortex_tracker 2 and is requesting a storm + ! area of interest, and not a kid area of interest. + ! Switch to kid interest and warn them: + grid%interest_kids=1 +39 format('Grid ',I0,' switching from interest_storms to interest_kids due to vortex_tracker==2 (nest following)') + write(message,39) grid%id + call wrf_message(message) + else + ! User set things up correctly: vortex_tracker==2, and + ! it has interest_kids, but they also turned on + ! interest_storms, probably because it is on by + ! default in the registry. Disable interest_storms + ! and warn them in a level 2 debug message: +37 format('Grid ',I0,' using nest area of interest (already enabled) instead of storm area of interest due to vortex_tracker==2 (nest following).') + write(message,37) grid%id + call wrf_debug(2,message) + endif + elseif(grid%interest_self==0) then + ! User requested a tracker other than 2, 6 and 7, but wants + ! a storm area of interest. Not possible. Switch to + ! interest_kids if there are nests, and interest_self + ! otherwise. + if(grid%num_nests<1) then + grid%interest_self=1 + grid%interest_rad_self=grid%interest_rad_storm +38 format('Grid ',I0,' switching from interest_storm to interest_self due to lack of vortex information. You must use vortex tracker 6 or 7 to get a storm area of interest.') + write(message,38) grid%id + call wrf_message(message) + else + grid%interest_kids=1 +35 format('Grid ',I0,' switching from interest_storm to interest_kids due to lack of vortex information, and presence of nests. You must use vortex tracker 6 and 7 to get a storm area of interest.') + write(message,35) grid%id + call wrf_message(message) + endif + endif + endif + endif + ! Signify that the pdyn smooth and parent smooth are invalid in ! this domain: grid%pdyn_parent_age=0 @@ -109,7 +155,7 @@ SUBROUTINE VORTTRAK_INIT(grid,config_flags,init, & #endif #ifdef HWRF - if(init .and. vortex_tracker==6) then + if(init .and. (vortex_tracker==6 .or. vortex_tracker==7) ) then call ncep_tracker_init(grid) endif #endif @@ -215,6 +261,12 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, & ! noise removal. Plus, it only searches within X km of the nest ! center to avoid other nearby systems. ! vortex_tracker=5 -- track average of parent and grandparent PDYN + ! vortex_tracker=6 -- simplified version of Tim Marchok's tracker + ! + ! vortex_tracker=7 -- nearly the full storm tracking algorithm + ! from Tim Marchok's tracker. The only part that is missing + ! is the part that gives up when the storm dissipates. That + ! is left out intentionally. ! ! HISTORY: ! 2004? - initial implementation by gopal @@ -223,6 +275,9 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, & ! late 2010 - sam added a new child tracker (vortex_tracker=2) ! Nov 08 2011 - sam split implementation into several functions and ! added the vortex_tracker=4 option + ! Mar 2013 - sam added options 5 & 6 + ! Sep 2013 - sam added option 7 + ! Feb 2014 - sam added hooks for area of interest #ifdef HWRF USE module_tracker, only: ncep_tracker_center #endif @@ -320,16 +375,29 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, & ,ITS,ITE,JTS,JTE,KTS,KTE) RETURN #ifdef HWRF - elseif(vortex_tracker==6) then - ! Tracker #6: do whatever the inline NCEP Tracker says + elseif(vortex_tracker==6 .or. vortex_tracker==7) then + ! Tracker #6 and #7: do whatever the inline NCEP Tracker says call ncep_tracker_center(grid) - call vt6_move(grid%tracker_ifix,grid%tracker_jfix, & + call vt67_move(grid%tracker_ifix,grid%tracker_jfix, & grid%tracker_gave_up,grid%tracker_havefix, & grid%xloc_2,grid%yloc_2, grid%id, & grid%xloc_1,grid%yloc_1, grid%mvnest, & IDS,IDE,JDS,JDE,KDS,KDE, & IMS,IME,JMS,JME,KMS,KME, & ITS,ITE,JTS,JTE,KTS,KTE) + + ! Update area of interest after storm moves if the storm is an + ! area of interest: + if(grid%interest_storms/=0) then +38 format('grid ',I2,' updating area of interest due to storm motion') + write(message,38) grid%id + call wrf_message(trim(message)) + grid%update_interest=.true. + else +39 format('grid ',I2,' not updating area of interest after storm motion because grid%interest_storms is 0') + write(message,39) grid%id + call wrf_message(trim(message)) + endif elseif(vortex_tracker==5) then ! Tracker #5: follow average of grandparent and parent PDYN call vt5_move(grid%pdyn_parent,grid%distsq,grid%vt5searchrad, & @@ -619,11 +687,13 @@ SUBROUTINE vt5_move(PDYN,distsq,searchrad,xloc,yloc,gridid,cx,cy,mvnest, & call wrf_debug(1,'Not moving: PDYN minimum is near nest center') endif END SUBROUTINE vt5_move - SUBROUTINE vt6_move(ifix,jfix,gaveup,havefix, & + SUBROUTINE vt67_move(ifix,jfix,gaveup,havefix, & xloc,yloc,gridid,cx,cy,mvnest, & IDS,IDE,JDS,JDE,KDS,KDE, & IMS,IME,JMS,JME,KMS,KME, & ITS,ITE,JTS,JTE,KTS,KTE) + ! This is for trackers 6 & 7, which just do what the NCEP tracker + ! (module_tracker) tell us to do. use module_dm, only: wrf_dm_minval_real implicit none integer, intent(in) :: ifix,jfix @@ -674,7 +744,7 @@ SUBROUTINE vt6_move(ifix,jfix,gaveup,havefix, & yloc=cy call wrf_debug(1,'Not moving: tracker center is near nest center') endif - END SUBROUTINE vt6_move + END SUBROUTINE vt67_move SUBROUTINE vt4_move(MSLP,WEIGHTOUT,DISTSQ,NOISY,DX_NMM,DY_NMM, & xloc,yloc,cx,cy,mvnest, & searchrad,searchpow,searchpmax, & diff --git a/wrfv2_fire/dyn_nmm/module_initialize_real.F b/wrfv2_fire/dyn_nmm/module_initialize_real.F index 03e512cd..8400876e 100644 --- a/wrfv2_fire/dyn_nmm/module_initialize_real.F +++ b/wrfv2_fire/dyn_nmm/module_initialize_real.F @@ -162,6 +162,8 @@ SUBROUTINE init_domain_nmm ( grid & INTEGER:: KHH,KVH,JAM,JA, IHL, IHH, L INTEGER:: II,JJ,ISRCH,ISUM,ITER,Ilook,Jlook + REAL :: NDLMD,NDPHD,NWBD,NSBD + INTEGER :: NIDE,NJDE REAL, PARAMETER:: DTR=0.01745329 REAL, PARAMETER:: W_NMM=0.08 @@ -195,9 +197,6 @@ SUBROUTINE init_domain_nmm ( grid & ! gopal's doing for ocean coupling !============================================================================ - REAL, DIMENSION(:,:), ALLOCATABLE :: NHLAT,NHLON,NVLAT,NVLON,HRES_SM - REAL :: NDLMD,NDPHD,NWBD,NSBD - INTEGER :: NIDE,NJDE,ILOC,JLOC INTEGER fid, ierr, nprocs CHARACTER*255 f65name, SysString @@ -2030,81 +2029,28 @@ SUBROUTINE init_domain_nmm ( grid & NDPHD=grid%dphd/3. NIDE=3*(IDE-1)-2 NJDE=3*(JDE-1)-2 - ILOC=1 - JLOC=1 NWBD= WBD ! + (ILOC -1)*2.*grid%dlmd + MOD(JLOC+1,2)*grid%dlmd NSBD= SBD ! + (JLOC -1)*grid%dphd - ALLOCATE (NHLAT(NIDE,NJDE)) - ALLOCATE (NHLON(NIDE,NJDE)) - ALLOCATE (NVLAT(NIDE,NJDE)) - ALLOCATE (NVLON(NIDE,NJDE)) - ALLOCATE (HRES_SM(NIDE,NJDE)) -#if defined(DM_PARALLEL) - if(wrf_dm_on_monitor()) then - ! Only the monitor process does the actual work (kinda - ! stupid; should be parallelized, but it's better than - ! writing garbage like it did before with >1 process) - - ! Get high-res lat & lon: - CALL EARTH_LATLON_hwrf ( NHLAT,NHLON,NVLAT,NVLON, & ! rotated lat,lon at H and V points - NDLMD,NDPHD,NWBD,NSBD, & - tph0d,tlm0d, & - 1,NIDE,1,NJDE,1,1, & - 1,NIDE,1,NJDE,1,1, & - 1,NIDE,1,NJDE,1,1 ) - - ! Interpolate landmask to high-res grid: - CALL G2T2H_hwrf ( SM_G,HRES_SM, & ! output grid index and weights - NHLAT,NHLON, & ! target (hres) input lat lon in degrees - grid%DLMD,grid%DPHD,WBD,SBD, & ! parent res, west and south boundaries - tph0d,tlm0d, & ! parent central lat,lon, all in degrees - IDE,JDE,IDS,IDE,JDS,JDE, & ! parent imax and jmax, ime,jme - 1,NIDE,1,NJDE,1,1, & - 1,NIDE,1,NJDE,1,1, & - 1,NIDE,1,NJDE,1,1 ) - - ! We're done with the low-res sm grid now: - deallocate(SM_G) - - ! Write out high-res grid for coupler: - WRITE(65)NHLAT(1:NIDE,1:NJDE) - WRITE(65)NHLON(1:NIDE,1:NJDE) - WRITE(65)NVLAT(1:NIDE,1:NJDE) - WRITE(65)NVLON(1:NIDE,1:NJDE) - WRITE(65)HRES_SM(1:NIDE,1:NJDE) - endif -#else - ! This code is the same as above, but for the non-mpi version: - CALL EARTH_LATLON_hwrf ( NHLAT,NHLON,NVLAT,NVLON, & ! rotated lat,lon at H and V points - NDLMD,NDPHD,NWBD,NSBD, & - tph0d,tlm0d, & - 1,NIDE,1,NJDE,1,1, & - 1,NIDE,1,NJDE,1,1, & - 1,NIDE,1,NJDE,1,1 ) - CALL G2T2H_hwrf ( grid%SM,HRES_SM, & ! output grid index and weights - NHLAT,NHLON, & ! target (hres) input lat lon in degrees - grid%DLMD,grid%DPHD,WBD,SBD, & ! parent res, west and south boundaries - tph0d,tlm0d, & ! parent central lat,lon, all in degrees - IDE,JDE,IMS,IME,JMS,JME, & ! parent imax and jmax, ime,jme - 1,NIDE,1,NJDE,1,1, & - 1,NIDE,1,NJDE,1,1, & - 1,NIDE,1,NJDE,1,1 ) - - WRITE(65)NHLAT(1:NIDE,1:NJDE) - WRITE(65)NHLON(1:NIDE,1:NJDE) - WRITE(65)NVLAT(1:NIDE,1:NJDE) - WRITE(65)NVLON(1:NIDE,1:NJDE) - WRITE(65)HRES_SM(1:NIDE,1:NJDE) -#endif - DEALLOCATE (NHLAT) - DEALLOCATE (NHLON) - DEALLOCATE (NVLAT) - DEALLOCATE (NVLON) - DEALLOCATE (HRES_SM) +#ifdef HWRF + CALL EARTH_LATLON ( grid%HLAT,grid%HLON,grid%VLAT,grid%VLON, & !output + grid%DLMD,grid%DPHD,WBD,SBD, & !inputs + tph0d,tlm0d, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) +#if defined(DM_PARALLEL) + master65: if(wrf_dm_on_monitor()) then +#endif + call make_coupler_fort65(grid,NDLMD,NDPHD,NWBD,NSBD,& + NIDE,NJDE,IDE-1,JDE-1,tph0d,tlm0d) +#if defined(DM_PARALLEL) + endif master65 +#endif +#endif endif !Kwon's doing !================================================================================== @@ -2118,6 +2064,156 @@ SUBROUTINE init_domain_nmm ( grid & END SUBROUTINE init_domain_nmm + real function greatarc(lat1,lon1,lat2,lon2) + ! greatarc -- gets the great arc distance (along-Earth distance) + ! between two points. The earth radius used in the + ! calculation is the average of the radius at the two + ! points. + ! lat1,lon1 -- the first point's latitude + ! lat2,lon2 -- the second point's latitude + ! returns -- the distance in meters. + implicit none + real, parameter :: Requator = 6378137.0000 + real, parameter :: pi = 3.141592653589793238 + real, parameter :: flattening = 1/298.257223563 + real, parameter :: DEGRAD = pi/180 + real, intent(in) :: lat1,lon1, lat2,lon2 + real :: rlat1,rlon1, rlat2,rlon2 + real :: Rearth1,Rearth2 + real, parameter :: deg2rad=DEGRAD + real, parameter :: flattening_inv=1/flattening + + rlat1=lat1*deg2rad ; rlon1=lon1*deg2rad + rlat2=lat2*deg2rad ; rlon2=lon2*deg2rad + + Rearth1=Requator*(1-sin(rlat1)**2/flattening_inv) + Rearth2=Requator*(1-sin(rlat2)**2/flattening_inv) + + greatarc=(Rearth1+Rearth2)*asin(min(1.0,sqrt( & + sin((rlat1-rlat2)/2)**2+ & + cos(rlat1)*cos(rlat2)*sin((rlon1-rlon2)/2)**2))) + end function greatarc + + SUBROUTINE make_coupler_fort65(grid,& + NDLMD,NDPHD,NWBD,NSBD,& + NIDE,NJDE,PIDE,PJDE,tph0d,tlm0d) + implicit none + type(domain), intent(in) :: grid + REAL, DIMENSION(:,:), ALLOCATABLE :: NHLAT,NHLON,NVLAT,NVLON,HRES_SM,& + HBWGT1, HBWGT2, HBWGT3, HBWGT4 + INTEGER, DIMENSION(:,:), ALLOCATABLE :: IIH, JJH, HNEAR_I,HNEAR_J,CENFLAG + REAL, INTENT(IN) :: NDLMD,NDPHD,NWBD,NSBD,tph0d,tlm0d + INTEGER, INTENT(IN) :: NIDE,NJDE,PIDE,PJDE + INTEGER :: ci,cj, ni,nj, bad + character(len=255) :: message + INTEGER :: count, bigcount, noncount + REAL :: dlon, mindist,maxdist,dist,maxweight + + allocate(NHLAT(nide,njde),NHLON(nide,njde),NVLAT(nide,njde)) + allocate(NVLON(nide,njde),HRES_SM(nide,njde)) + allocate(IIH(nide,njde),JJH(nide,njde),HBWGT1(nide,njde)) + allocate(HBWGT2(nide,njde),HBWGT3(nide,njde),HBWGT4(nide,njde)) + allocate(HNEAR_I(nide,njde),HNEAR_J(nide,njde),CENFLAG(nide,njde)) + + CALL EARTH_LATLON ( NHLAT,NHLON,NVLAT,NVLON, & ! rotated lat,lon at H&V + NDLMD,NDPHD,NWBD,NSBD, & ! resolution & SW corner + tph0d,tlm0d, & ! projection center + 1,NIDE+1,1,NJDE+1,1,1, & ! WRF domain size + 1,NIDE,1,NJDE,1,1, & ! memory size + 1,NIDE,1,NJDE,1,1 ) ! patch size + + HBWGT1=999 + HBWGT2=999 + HBWGT3=999 + HBWGT4=999 + CALL G2T2H_new( IIH,JJH, & ! output grid index in parent grid + HBWGT1,HBWGT2, & ! output weights in terms of + HBWGT3,HBWGT4, & ! parent grid + 1,1, & ! nest start I, J in parent domain + 3, & ! Ratio of parent and child grid ( + ! always = 3 for NMM) + 1,NIDE+1,1,NJDE+1,1,1, & ! WRF domain size + 1,NIDE,1,NJDE,1,1, & ! memory size + 1,NIDE,1,NJDE,1,1 ) ! patch size + + call INIT_HNEAR(IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,HNEAR_I,HNEAR_J,& + 1,NIDE+1,1,NJDE+1,1,1, & ! WRF domain size + 1,NIDE,1,NJDE,1,1, & ! memory size + 1,NIDE,1,NJDE,1,1 ) ! patch size + + ! Land sea mask nearest neighbor interpolation: + bad=0 + maxdist=-1e9 + mindist=1e9 + noncount=0 + bigcount=0 + count=0 + do nj=1,njde + do ni=1,nide + ci=HNEAR_I(ni,nj) + cj=HNEAR_J(ni,nj) + if(ci<1 .or. ci>pide .or. cj<1 .or. cj>pjde) then +33 format('ERROR: Invalid HNEAR nest ',I0,',',I0,' parent ',& + I0,',',I0,' outside parent bounds ',I0,',',I0) + write(message,33) ni,nj,ci,cj,pide,pjde + call wrf_message(trim(message)) + bad=bad+1 + endif + HRES_SM(ni,nj)=grid%SM(ci,cj) + maxweight=max(HBWGT1(ni,nj),HBWGT2(ni,nj),HBWGT3(ni,nj),HBWGT4(ni,nj)) + if(maxweight>0.9999 .and. maxweight<1.03) then + cenflag(ni,nj)=1 + dist=greatarc(grid%HLAT(ci,cj),grid%HLON(ci,cj),& + NHLAT(ni,nj),NHLON(ni,nj)) + if(dist>100) then + bigcount=bigcount+1 + endif + mindist=min(dist,mindist) + maxdist=max(dist,maxdist) + count=count+1 + elseif(maxweight>=1.03) then + call wrf_error_fatal('Big weights.') + elseif(maxweight<0.03) then + call wrf_error_fatal('Zero weights.') + else + noncount=noncount+1 + cenflag(ni,nj)=0 + endif +! dlon=mod(3600.+180.+NHLON(ni,nj)-grid%HLON(ci,cj),360.)-180 +! if(dlon<0.004 .and. dlon>1e-3) then +! 44 format('Big nest-parent longitude difference: lat,lon at ',& +! 'Parent ',I0,',',I0,' ',F0.7,',',F0.7, & +! ' Nest ',I0,',',I0,' ',F0.7,',',F0.7) +! write(message,44) ci,cj,grid%HLAT(ci,cj),grid%HLON(ci,cj), & +! ni,nj,NHLAT(ni,nj),NHLON(ni,nj) +! call wrf_message(trim(message)) +! !bad=bad+1 +! endif + enddo + enddo +48 format('Dist min=',F0.7,' max=',F0.7,' count of >100m = ',I0,'/',I0,' skipping ',I0) + write(message,48) mindist,maxdist,bigcount,count,noncount + call wrf_message(message) + if(bad>0) then +55 format('Errors in coupler prep (bad count = ',I0,'). Aborting.') + write(message,55) bad + call wrf_error_fatal(message) + endif + + WRITE(65)NHLAT(1:NIDE,1:NJDE) + WRITE(65)NHLON(1:NIDE,1:NJDE) + WRITE(65)NVLAT(1:NIDE,1:NJDE) + WRITE(65)NVLON(1:NIDE,1:NJDE) + WRITE(65)HRES_SM(1:NIDE,1:NJDE) + !WRITE(65)HNEAR_I(1:NIDE,1:NJDE) + !WRITE(65)HNEAR_J(1:NIDE,1:NJDE) + !WRITE(65)CENFLAG(1:NIDE,1:NJDE) + + deallocate(NHLAT,NHLON,NVLAT,NVLON,HRES_SM,IIH,JJH) + deallocate(HBWGT1,HBWGT2,HBWGT3,HBWGT4,HNEAR_I,HNEAR_J) + + END SUBROUTINE make_coupler_fort65 + !------------------------------------------------------ SUBROUTINE define_nmm_vertical_coord ( LM, PTSGM, pt, pdtop,HYBLEVS, & @@ -4582,657 +4678,4 @@ END SUBROUTINE init_module_initialize !--------------------------------------------------------------------- -#ifdef HWRF -! compute earth lat-lons for before interpolations. This is gopal's doing for ocean coupling -!============================================================================================ - -SUBROUTINE EARTH_LATLON_hwrf ( HLAT,HLON,VLAT,VLON, & !Earth lat,lon at H and V points - DLMD1,DPHD1,WBD1,SBD1, & !input res,west & south boundaries, - CENTRAL_LAT,CENTRAL_LON, & ! central lat,lon, all in degrees - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - ITS,ITE,JTS,JTE,KTS,KTE ) -!============================================================================ -! - IMPLICIT NONE - INTEGER, INTENT(IN ) :: IDS,IDE,JDS,JDE,KDS,KDE - INTEGER, INTENT(IN ) :: IMS,IME,JMS,JME,KMS,KME - INTEGER, INTENT(IN ) :: ITS,ITE,JTS,JTE,KTS,KTE - REAL, INTENT(IN ) :: DLMD1,DPHD1,WBD1,SBD1 - REAL, INTENT(IN ) :: CENTRAL_LAT,CENTRAL_LON - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: HLAT,HLON,VLAT,VLON - -! local - - INTEGER,PARAMETER :: KNUM=SELECTED_REAL_KIND(13) - INTEGER :: I,J - REAL(KIND=KNUM) :: WB,SB,DLM,DPH,TPH0,STPH0,CTPH0 - REAL(KIND=KNUM) :: TDLM,TDPH,TLMH,TLMV,TLMH0,TLMV0,TPHH,TPHV,DTR - REAL(KIND=KNUM) :: STPH,CTPH,STPV,CTPV,PI_2 - REAL(KIND=KNUM) :: SPHH,CLMH,FACTH,SPHV,CLMV,FACTV - REAL(KIND=KNUM), DIMENSION(IMS:IME,JMS:JME) :: GLATH,GLONH,GLATV,GLONV -!------------------------------------------------------------------------- - -! - PI_2 = ACOS(0.) - DTR = PI_2/90. - WB = WBD1 * DTR ! WB: western boundary in radians - SB = SBD1 * DTR ! SB: southern boundary in radians - DLM = DLMD1 * DTR ! DLM: dlamda in radians - DPH = DPHD1 * DTR ! DPH: dphi in radians - TDLM = DLM + DLM ! TDLM: 2.0*dlamda - TDPH = DPH + DPH ! TDPH: 2.0*DPH - -! For earth lat lon only - - TPH0 = CENTRAL_LAT*DTR ! TPH0: central lat in radians - STPH0 = SIN(TPH0) - CTPH0 = COS(TPH0) - - DO J = JTS,MIN(JTE,JDE) !-1) ! H./ This loop takes care of zig-zag -! ! \.H starting points along j - TLMH0 = WB - TDLM + MOD(J+1,2) * DLM ! ./ TLMH (rotated lats at H points) - TLMV0 = WB - TDLM + MOD(J,2) * DLM ! H (//ly for V points) - TPHH = SB + (J-1)*DPH ! TPHH (rotated lons at H points) are simple trans. - TPHV = TPHH ! TPHV (rotated lons at V points) are simple trans. - STPH = SIN(TPHH) - CTPH = COS(TPHH) - STPV = SIN(TPHV) - CTPV = COS(TPHV) - - ! .H - DO I = ITS,MIN(ITE,IDE) !-1) ! / - TLMH = TLMH0 + I*TDLM ! \.H .U .H -! !H./ ----><---- - SPHH = CTPH0 * STPH + STPH0 * CTPH * COS(TLMH) ! DLM + DLM - GLATH(I,J)=ASIN(SPHH) ! GLATH: Earth Lat in radians - CLMH = CTPH*COS(TLMH)/(COS(GLATH(I,J))*CTPH0) & - - TAN(GLATH(I,J))*TAN(TPH0) - IF(CLMH .GT. 1.) CLMH = 1.0 - IF(CLMH .LT. -1.) CLMH = -1.0 - FACTH = 1. - IF(TLMH .GT. 0.) FACTH = -1. - GLONH(I,J) = -CENTRAL_LON*DTR + FACTH*ACOS(CLMH) - - ENDDO - - DO I = ITS,MIN(ITE,IDE) !-1) - TLMV = TLMV0 + I*TDLM - SPHV = CTPH0 * STPV + STPH0 * CTPV * COS(TLMV) - GLATV(I,J) = ASIN(SPHV) - CLMV = CTPV*COS(TLMV)/(COS(GLATV(I,J))*CTPH0) & - - TAN(GLATV(I,J))*TAN(TPH0) - IF(CLMV .GT. 1.) CLMV = 1. - IF(CLMV .LT. -1.) CLMV = -1. - FACTV = 1. - IF(TLMV .GT. 0.) FACTV = -1. - GLONV(I,J) = -CENTRAL_LON*DTR + FACTV*ACOS(CLMV) - - ENDDO - - ENDDO - -! Conversion to degrees (may not be required, eventually) - - DO J = JTS, MIN(JTE,JDE) !-1) - DO I = ITS, MIN(ITE,IDE) !-1) - HLAT(I,J) = GLATH(I,J) / DTR - HLON(I,J)= -GLONH(I,J)/DTR - IF(HLON(I,J) .GT. 180.) HLON(I,J) = HLON(I,J) - 360. - IF(HLON(I,J) .LT. -180.) HLON(I,J) = HLON(I,J) + 360. -! - VLAT(I,J) = GLATV(I,J) / DTR - VLON(I,J) = -GLONV(I,J) / DTR - IF(VLON(I,J) .GT. 180.) VLON(I,J) = VLON(I,J) - 360. - IF(VLON(I,J) .LT. -180.) VLON(I,J) = VLON(I,J) + 360. - - ENDDO - ENDDO - -END SUBROUTINE EARTH_LATLON_hwrf - - SUBROUTINE G2T2H_hwrf( SM,HRES_SM, & ! output grid index and weights - HLAT,HLON, & ! target (nest) input lat lon in degrees - DLMD1,DPHD1,WBD1,SBD1, & ! parent res, west and south boundaries - CENTRAL_LAT,CENTRAL_LON, & ! parent central lat,lon, all in degrees - P_IDE,P_JDE,P_IMS,P_IME,P_JMS,P_JME, & ! parent imax and jmax - IDS,IDE,JDS,JDE,KDS,KDE, & ! target (nest) dIMEnsions - IMS,IME,JMS,JME,KMS,KME, & - ITS,ITE,JTS,JTE,KTS,KTE ) - -! -!*** Tom Black - Initial Version -!*** Gopal - Revised Version for WRF (includes coincident grid points) -!*** -!*** GIVEN PARENT CENTRAL LAT-LONS, RESOLUTION AND WESTERN AND SOUTHERN BOUNDARY, -!*** AND THE NESTED GRID LAT-LONS AT H POINTS, THIS ROUTINE FIRST LOCATES THE -!*** INDICES,IIH,JJH, OF THE PARENT DOMAIN'S H POINTS THAT LIES CLOSEST TO THE -!*** h POINTS OF THE NESTED DOMAIN -! -!============================================================================ -! - IMPLICIT NONE - INTEGER, INTENT(IN ) :: IDS,IDE,JDS,JDE,KDS,KDE - INTEGER, INTENT(IN ) :: IMS,IME,JMS,JME,KMS,KME - INTEGER, INTENT(IN ) :: ITS,ITE,JTS,JTE,KTS,KTE - INTEGER, INTENT(IN ) :: P_IDE,P_JDE,P_IMS,P_IME,P_JMS,P_JME - REAL, INTENT(IN ) :: DLMD1,DPHD1,WBD1,SBD1 - REAL, INTENT(IN ) :: CENTRAL_LAT,CENTRAL_LON - REAL, DIMENSION(P_IMS:P_IME,P_JMS:P_JME), INTENT(IN) :: SM - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(IN) :: HLAT,HLON - REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(OUT) :: HRES_SM - -! local - - INTEGER,PARAMETER :: KNUM=SELECTED_REAL_KIND(13) - INTEGER :: IMT,JMT,N2R,MK,K,I,J,DSLP0,DSLOPE,N - INTEGER :: NROW,NCOL,KROWS - REAL(KIND=KNUM) :: X,Y,Z,TLAT,TLON - REAL(KIND=KNUM) :: PI_2,D2R,R2D,GLAT,GLON,DPH,DLM,TPH0,TLM0,WB,SB - REAL(KIND=KNUM) :: ROW,COL,SLP0,TLATHC,TLONHC,DENOM,SLOPE - REAL(KIND=KNUM) :: TLAT1,TLAT2,TLON1,TLON2,DLM1,DLM2,DLM3,DLM4,D1,D2 - REAL(KIND=KNUM) :: DLA1,DLA2,DLA3,DLA4,S1,R1,DS1,AN1,AN2,AN3 ! Q - REAL(KIND=KNUM) :: DL1,DL2,DL3,DL4,DL1I,DL2I,DL3I,DL4I,SUMDL,TLONO,TLATO - REAL(KIND=KNUM) :: DTEMP - REAL , DIMENSION(IMS:IME,JMS:JME) :: TLATHX,TLONHX - INTEGER, DIMENSION(IMS:IME,JMS:JME) :: KOUTB - REAL SUM,AMAXVAL - REAL, DIMENSION (4, ims:ime, jms:jme ) :: NBWGT - LOGICAL FLIP - REAL, DIMENSION(IMS:IME,JMS:JME) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 - INTEGER, DIMENSION(IMS:IME,JMS:JME) :: IIH,JJH -!------------------------------------------------------------------------------- - - IMT=2*P_IDE-2 ! parent i dIMEnsions - JMT=P_JDE/2 ! parent j dIMEnsions - PI_2=ACOS(0.) - D2R=PI_2/90. - R2D=1./D2R - DPH=DPHD1*D2R - DLM=DLMD1*D2R - TPH0= CENTRAL_LAT*D2R - TLM0=-CENTRAL_LON*D2R ! NOTE THE MINUS HERE - WB=WBD1*D2R ! CONVERT NESTED GRID H POINTS FROM GEODETIC - SB=SBD1*D2R - SLP0=DPHD1/DLMD1 - DSLP0=NINT(R2D*ATAN(SLP0)) - DS1=SQRT(DPH*DPH+DLM*DLM) ! Q - AN1=ASIN(DLM/DS1) - AN2=ASIN(DPH/DS1) - - - DO J = JTS,MIN(JTE,JDE) !-1) - DO I = ITS,MIN(ITE,IDE) !-1) - -!*** -!*** LOCATE TARGET h POINTS (HLAT AND HLON) ON THE PARENT DOMAIN AND -!*** DETERMINE THE INDICES IN TERMS OF THE PARENT DOMAIN. FIRST -!*** CONVERT NESTED GRID h POINTS FROM GEODETIC TO TRANSFORMED -!*** COORDINATE ON THE PARENT GRID -! - - GLAT=HLAT(I,J)*D2R - GLON= (360. - HLON(I,J))*D2R - X=COS(TPH0)*COS(GLAT)*COS(GLON-TLM0)+SIN(TPH0)*SIN(GLAT) - Y=-COS(GLAT)*SIN(GLON-TLM0) - Z=COS(TPH0)*SIN(GLAT)-SIN(TPH0)*COS(GLAT)*COS(GLON-TLM0) - TLAT=R2D*ATAN(Z/SQRT(X*X+Y*Y)) - TLON=R2D*ATAN(Y/X) - -! - ROW=TLAT/DPHD1+JMT ! JMT IS THE CENTRAL ROW OF THE PARENT DOMAIN - COL=TLON/DLMD1+P_IDE-1 ! (P_IDE-1) IS THE CENTRAL COLUMN OF THE PARENT DOMAIN - NROW=INT(ROW + 0.001) ! ROUND-OFF IS AVOIDED WITHOUT USING NINT ON PURPOSE - NCOL=INT(COL + 0.001) - TLAT=TLAT*D2R - TLON=TLON*D2R - -! WRITE(60,*)'============================================================' -! WRITE(60,*)' ','i=',i,'j=',j -!*** -!*** -!*** FIRST CONSIDER THE SITUATION WHERE THE POINT h IS AT -!*** -!*** V H -!*** -!*** -!*** h -!*** H V -!*** -!*** THEN LOCATE THE NEAREST H POINT ON THE PARENT GRID -!*** - IF(MOD(NROW,2).EQ.1.AND.MOD(NCOL,2).EQ.1.OR. & - MOD(NROW,2).EQ.0.AND.MOD(NCOL,2).EQ.0)THEN - TLAT1=(NROW-JMT)*DPH - TLAT2=TLAT1+DPH - TLON1=(NCOL-(P_IDE-1))*DLM - TLON2=TLON1+DLM - DLM1=TLON-TLON1 - DLM2=TLON-TLON2 -! D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1)) -! D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2)) - DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1)) - D1=ACOS(DTEMP) - DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2)) - D2=ACOS(DTEMP) - IF(D1.GT.D2)THEN - NROW=NROW+1 ! FIND THE NEAREST H ROW - NCOL=NCOL+1 ! FIND THE NEAREST H COLUMN - ENDIF -! WRITE(60,*)'NEAREST PARENT IS:','col=',COL,'row=',ROW,'ncol=',NCOL,'nrow=',NROW - ELSE -!*** -!*** NOW CONSIDER THE SITUATION WHERE THE POINT h IS AT -!*** -!*** H V -!*** -!*** -!*** h -!*** V H -!*** -!*** THEN LOCATE THE NEAREST H POINT ON THE PARENT GRID -!*** -!*** - TLAT1=(NROW+1-JMT)*DPH - TLAT2=TLAT1-DPH - TLON1=(NCOL-(P_IDE-1))*DLM - TLON2=TLON1+DLM - DLM1=TLON-TLON1 - DLM2=TLON-TLON2 -! D1=ACOS(COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1)) -! D2=ACOS(COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2)) - DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT1)*COS(DLM1)+SIN(TLAT)*SIN(TLAT1)) - D1=ACOS(DTEMP) - DTEMP=MIN(1.0_KNUM,COS(TLAT)*COS(TLAT2)*COS(DLM2)+SIN(TLAT)*SIN(TLAT2)) - D2=ACOS(DTEMP) - IF(D1.LT.D2)THEN - NROW=NROW+1 ! FIND THE NEAREST H ROW - ELSE - NCOL=NCOL+1 ! FIND THE NEAREST H COLUMN - ENDIF -! WRITE(60,*)'NEAREST PARENT IS:','col=',COL,'row=',ROW,'ncol=',NCOL,'nrow=',NROW - ENDIF - - KROWS=((NROW-1)/2)*IMT - IF(MOD(NROW,2).EQ.1)THEN - K=KROWS+(NCOL+1)/2 - ELSE - K=KROWS+P_IDE-1+NCOL/2 - ENDIF - -!*** -!*** WE NOW KNOW THAT THE INNER GRID POINT IN QUESTION IS -!*** NEAREST TO THE CENTER K AS SEEN BELOW. WE MUST FIND -!*** WHICH OF THE FOUR H-BOXES (OF WHICH THIS H POINT IS -!*** A VERTEX) SURROUNDS THE INNER GRID h POINT IN QUESTION. -!*** -!** -!*** H -!*** -!*** -!*** -!*** H V H -!*** -!*** -!*** h -!*** H V H V H -!*** -!*** -!*** -!*** H V H -!*** -!*** -!*** -!*** H -!*** -!*** -!*** FIND THE SLOPE OF THE LINE CONNECTING h AND THE CENTER H. -!*** - N2R=K/IMT - MK=MOD(K,IMT) -! - IF(MK.EQ.0)THEN - TLATHC=SB+(2*N2R-1)*DPH - ELSE - TLATHC=SB+(2*N2R+(MK-1)/(P_IDE-1))*DPH - ENDIF -! - IF(MK.LE.(P_IDE-1))THEN - TLONHC=WB+2*(MK-1)*DLM - ELSE - TLONHC=WB+(2*(MK-(P_IDE-1))-1)*DLM - ENDIF - -! -!*** EXECUTE CAUTION IF YOU NEED TO CHANGE THESE CONDITIONS. SINCE WE ARE -!*** DEALING WITH SLOPES TO GENERATE DIAMOND SHAPE H BOXES, WE NEED TO BE -!*** CAREFUL HERE -! - - IF(ABS(TLON-TLONHC) .LE. 1.E-4)TLONHC=TLON - IF(ABS(TLAT-TLATHC) .LE. 1.E-4)TLATHC=TLAT - DENOM=(TLON-TLONHC) -! -!*** -!***STORE THE LOCATION OF THE WESTERNMOST VERTEX OF THE H-BOX ON -!***THE OUTER GRID THAT SURROUNDS THE h POINT ON THE INNER GRID. -!*** -!*** COINCIDENT CONDITIONS - - IF(DENOM.EQ.0.0)THEN - - IF(TLATHC.EQ.TLAT)THEN - KOUTB(I,J)=K - IIH(I,J) = NCOL - JJH(I,J) = NROW - TLATHX(I,J)=TLATHC - TLONHX(I,J)=TLONHC - HBWGT1(I,J)=1.0 - HBWGT2(I,J)=0.0 - HBWGT3(I,J)=0.0 - HBWGT4(I,J)=0.0 -! WRITE(60,*)'TRIVIAL SOLUTION' - ELSE ! SAME LONGITUDE BUT DIFFERENT LATS -! - IF(TLATHC .GT. TLAT)THEN ! NESTED POINT SOUTH OF PARENT - KOUTB(I,J)=K-(P_IDE-1) - IIH(I,J) = NCOL-1 - JJH(I,J) = NROW-1 - TLATHX(I,J)=TLATHC-DPH - TLONHX(I,J)=TLONHC-DLM -! WRITE(60,*)'VANISHING SLOPE, -ve: TLATHC-DPH, TLONHC-DLM' - ELSE ! NESTED POINT NORTH OF PARENT - KOUTB(I,J)=K+(P_IDE-1)-1 - IIH(I,J) = NCOL-1 - JJH(I,J) = NROW+1 - TLATHX(I,J)=TLATHC+DPH - TLONHX(I,J)=TLONHC-DLM -! WRITE(60,*)'VANISHING SLOPE, +ve: TLATHC+DPH, TLONHC-DLM' - ENDIF -!*** -!*** -!*** 4 -!*** -!*** h -!*** 1 2 -!*** -!*** 3 -!*** DL 1-4 ARE THE ANGULAR DISTANCES FROM h TO EACH VERTEX - - TLATO=TLATHX(I,J) - TLONO=TLONHX(I,J) - DLM1=TLON-TLONO - DLA1=TLAT-TLATO ! Q -! DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q - DL1=SQRT(DLM1*DLM1+DLA1*DLA1) ! Q -! - TLATO=TLATHX(I,J) - TLONO=TLONHX(I,J)+2.*DLM - DLM2=TLON-TLONO - DLA2=TLAT-TLATO ! Q -! DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q - DL2=SQRT(DLM2*DLM2+DLA2*DLA2) ! Q -! - TLATO=TLATHX(I,J)-DPH - TLONO=TLONHX(I,J)+DLM - DLM3=TLON-TLONO - DLA3=TLAT-TLATO ! Q -! DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q - DL3=SQRT(DLM3*DLM3+DLA3*DLA3) ! Q - - TLATO=TLATHX(I,J)+DPH - TLONO=TLONHX(I,J)+DLM - DLM4=TLON-TLONO - DLA4=TLAT-TLATO ! Q -! DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q - DL4=SQRT(DLM4*DLM4+DLA4*DLA4) ! Q - - -! THE BILINEAR WEIGHTS -!*** -!*** - AN3=ATAN2(DLA1,DLM1) ! Q - R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1) - S1=DL1*SIN(2.*PI_2-2*AN1-AN2+AN3)/SIN(2.*AN1) - R1=R1/DS1 - S1=S1/DS1 - DL1I=(1.-R1)*(1.-S1) - DL2I=R1*S1 - DL3I=R1*(1.-S1) - DL4I=(1.-R1)*S1 -! - HBWGT1(I,J)=DL1I - HBWGT2(I,J)=DL2I - HBWGT3(I,J)=DL3I - HBWGT4(I,J)=DL4I -! - ENDIF - - ELSE -! -!*** NON-COINCIDENT POINTS -! - SLOPE=(TLAT-TLATHC)/DENOM - DSLOPE=NINT(R2D*ATAN(SLOPE)) - - IF(DSLOPE.LE.DSLP0.AND.DSLOPE.GE.-DSLP0)THEN - IF(TLON.GT.TLONHC)THEN -! IF(TLONHC.GE.-WB-DLM)CALL wrf_error_fatal("1H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT") - KOUTB(I,J)=K - IIH(I,J) = NCOL - JJH(I,J) = NROW - TLATHX(I,J)=TLATHC - TLONHX(I,J)=TLONHC -! WRITE(60,*)'HERE WE GO1: TLATHC, TLONHC' - ELSE -! IF(TLONHC.LE.WB+DLM)CALL wrf_error_fatal("2H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT") - KOUTB(I,J)=K-1 - IIH(I,J) = NCOL-2 - JJH(I,J) = NROW - TLATHX(I,J)=TLATHC - TLONHX(I,J)=TLONHC -2.*DLM -! WRITE(60,*)'HERE WE GO2: TLATHC, TLONHC -2.*DLM' - ENDIF - -! - ELSEIF(DSLOPE.GT.DSLP0)THEN - IF(TLON.GT.TLONHC)THEN -! IF(TLATHC.GE.-SB-DPH)CALL wrf_error_fatal("3H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT") - KOUTB(I,J)=K+(P_IDE-1)-1 - IIH(I,J) = NCOL-1 - JJH(I,J) = NROW+1 - TLATHX(I,J)=TLATHC+DPH - TLONHX(I,J)=TLONHC-DLM -! WRITE(60,*)'HERE WE GO3: TLATHC+DPH, TLONHC-DLM' - ELSE -! IF(TLATHC.LE.SB+DPH)CALL wrf_error_fatal("4H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT") - KOUTB(I,J)=K-(P_IDE-1) - IIH(I,J) = NCOL-1 - JJH(I,J) = NROW-1 - TLATHX(I,J)=TLATHC-DPH - TLONHX(I,J)=TLONHC-DLM -! WRITE(60,*)'HERE WE GO4: TLATHC-DPH, TLONHC-DLM' - ENDIF - -! - ELSEIF(DSLOPE.LT.-DSLP0)THEN - IF(TLON.GT.TLONHC)THEN -! IF(TLATHC.LE.SB+DPH)CALL wrf_error_fatal("5H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT") - KOUTB(I,J)=K-(P_IDE-1) - IIH(I,J) = NCOL-1 - JJH(I,J) = NROW-1 - TLATHX(I,J)=TLATHC-DPH - TLONHX(I,J)=TLONHC-DLM -! WRITE(60,*)'HERE WE GO5: TLATHC-DPH, TLONHC-DLM' - ELSE -! IF(TLATHC.GE.-SB-DPH)CALL wrf_error_fatal("6H:NESTED DOMAIN TOO CLOSE TO THE BOUNDARY OF PARENT") - KOUTB(I,J)=K+(P_IDE-1)-1 - IIH(I,J) = NCOL-1 - JJH(I,J) = NROW+1 - TLATHX(I,J)=TLATHC+DPH - TLONHX(I,J)=TLONHC-DLM -! WRITE(60,*)'HERE WE GO6: TLATHC+DPH, TLONHC-DLM' - ENDIF - ENDIF - -! -!*** NOW WE WILL MOVE AS FOLLOWS: -!*** -!*** -!*** 4 -!*** -!*** -!*** -!*** h -!*** 1 2 -!*** -!*** -!*** -!*** -!*** 3 -!*** -!*** -!*** -!*** DL 1-4 ARE THE ANGULAR DISTANCES FROM h TO EACH VERTEX - - TLATO=TLATHX(I,J) - TLONO=TLONHX(I,J) - DLM1=TLON-TLONO - DLA1=TLAT-TLATO ! Q -! DL1=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM1)+SIN(TLAT)*SIN(TLATO)) ! Q - DL1=SQRT(DLM1*DLM1+DLA1*DLA1) ! Q -! - TLATO=TLATHX(I,J) ! redundant computations - TLONO=TLONHX(I,J)+2.*DLM - DLM2=TLON-TLONO - DLA2=TLAT-TLATO ! Q -! DL2=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM2)+SIN(TLAT)*SIN(TLATO)) ! Q - DL2=SQRT(DLM2*DLM2+DLA2*DLA2) ! Q -! - TLATO=TLATHX(I,J)-DPH - TLONO=TLONHX(I,J)+DLM - DLM3=TLON-TLONO - DLA3=TLAT-TLATO ! Q -! DL3=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM3)+SIN(TLAT)*SIN(TLATO)) ! Q - DL3=SQRT(DLM3*DLM3+DLA3*DLA3) ! Q -! - TLATO=TLATHX(I,J)+DPH - TLONO=TLONHX(I,J)+DLM - DLM4=TLON-TLONO - DLA4=TLAT-TLATO ! Q -! DL4=ACOS(COS(TLAT)*COS(TLATO)*COS(DLM4)+SIN(TLAT)*SIN(TLATO)) ! Q - DL4=SQRT(DLM4*DLM4+DLA4*DLA4) ! Q - -! THE BILINEAR WEIGHTS -!*** - AN3=ATAN2(DLA1,DLM1) ! Q - R1=DL1*SIN(AN2-AN3)/SIN(2.*AN1) - S1=DL1*SIN(2.*PI_2-2*AN1-AN2+AN3)/SIN(2.*AN1) - R1=R1/DS1 - S1=S1/DS1 - DL1I=(1.-R1)*(1.-S1) - DL2I=R1*S1 - DL3I=R1*(1.-S1) - DL4I=(1.-R1)*S1 -! - HBWGT1(I,J)=DL1I - HBWGT2(I,J)=DL2I - HBWGT3(I,J)=DL3I - HBWGT4(I,J)=DL4I -! - ENDIF -! -!*** FINALLY STORE IIH IN TERMS OF E-GRID INDEX -! - IIH(I,J)=NINT(0.5*IIH(I,J)) - - ENDDO - ENDDO - -! -!*** EXTENSION TO NEAREST NEIGHBOR -! - DO J = JTS,MIN(JTE,JDE) !-1) - DO I = ITS,MIN(ITE,IDE) !-1) - NBWGT(1,I,J)=HBWGT1(I,J) - NBWGT(2,I,J)=HBWGT2(I,J) - NBWGT(3,I,J)=HBWGT3(I,J) - NBWGT(4,I,J)=HBWGT4(I,J) - ENDDO - ENDDO - - DO J = JTS,MIN(JTE,JDE) !-1) - DO I = ITS,MIN(ITE,IDE) !-1) - AMAXVAL=0. - DO N=1,4 - AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL) - ENDDO -! - FLIP=.TRUE. - SUM=0.0 - DO N=1,4 - IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN - NBWGT(N,I,J)=1.0 - FLIP=.FALSE. - ELSE - NBWGT(N,I,J)=0.0 - ENDIF - SUM=SUM+NBWGT(N,I,J) - IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" ) - ENDDO - - - IF((NBWGT(1,I,J)+NBWGT(2,I,J)+NBWGT(3,I,J)+NBWGT(4,I,J)) .NE. 1)THEN - WRITE(0,*)'------------------------------------------------------------------------' - WRITE(0,*)'FATAL: SOMETHING IS WRONG WITH THE WEIGHTS IN module_initialize_real.F' - WRITE(0,*)'------------------------------------------------------------------------' - STOP - ENDIF - -! WRITE(66,*)I,J,NBWGT(1,I,J),NBWGT(2,I,J),NBWGT(3,I,J),NBWGT(4,I,J) - - ENDDO - ENDDO - - - DO J=MAX(3,JTS),MIN(JTE,JDE) !-1) - DO I=MAX(3,ITS),MIN(ITE,IDE) !-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - HRES_SM(I,J) = NBWGT(1,I,J)*SM(IIH(I,J),JJH(I,J) ) & - + NBWGT(2,I,J)*SM(IIH(I,J)+1, JJH(I,J) ) & - + NBWGT(3,I,J)*SM(IIH(I,J), JJH(I,J)-1) & - + NBWGT(4,I,J)*SM(IIH(I,J), JJH(I,J)+1) -! WRITE(68,*)I,J,SM(IIH(I,J),JJH(I,J)),SM(IIH(I,J)+1, JJH(I,J)), & -! SM(IIH(I,J), JJH(I,J)-1),SM(IIH(I,J), JJH(I,J)+1),HRES_SM(I,J) - ELSE - HRES_SM(I,J) = NBWGT(1,I,J)*SM(IIH(I,J), JJH(I,J) ) & - + NBWGT(2,I,J)*SM(IIH(I,J)+1, JJH(I,J) ) & - + NBWGT(3,I,J)*SM(IIH(I,J)+1, JJH(I,J)-1) & - + NBWGT(4,I,J)*SM(IIH(I,J)+1, JJH(I,J)+1) - -! WRITE(68,*)I,J,SM(IIH(I,J),JJH(I,J)),SM(IIH(I,J)+1, JJH(I,J)), & -! SM(IIH(I,J)+1, JJH(I,J)-1),SM(IIH(I,J)+1, JJH(I,J)+1),HRES_SM(I,J) - - ENDIF - - ENDDO - ENDDO -! Boundary treatment in J direction - DO J=MAX(3,JTS),MIN(JTE,JDE) - HRES_SM(2,J)=HRES_SM(3,J) - HRES_SM(1,J)=HRES_SM(2,J) - END DO -! Boundary treatment in J direction and 4 corners - DO I=ITS,MIN(ITE,IDE) - HRES_SM(I,2)=HRES_SM(I,3) - HRES_SM(I,1)=HRES_SM(I,2) - END DO - - - RETURN - END SUBROUTINE G2T2H_hwrf -!======================================================================================== -! end gopal's doing for ocean coupling -!============================================================================================ -#endif END MODULE module_initialize_real diff --git a/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F b/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F index 78a49a83..1ad665b0 100644 --- a/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F +++ b/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F @@ -5876,14 +5876,15 @@ subroutine env(t,ps,f,lq,lp,ds,ty0,up1,km,end_z1) 8 continue ! do 15 k=1,km -! +! Bug fix for idealized simulation by Lin Zhu. forc2. The bug is associated with +! thermal wind relationship in sheared environment. do 9 i=1,lp forc1=tt(i,k)*alpy(i) if(k.eq.1) then - forc2=f(i)*(up1(3)-up1(2))/(rgas*log(sig(3)/sig(2))) + forc2= - f(i)*(up1(3)-up1(2))/(rgas*log(sig(3)/sig(2))) forc3=(t6(2)-tk(1))*alpy(i)/log(sig(2)/sig1(1)) else - forc2=f(i)*(up1(k+1)-up1(k))/(rgas*log(sig(k+1)/sig(k))) + forc2= - f(i)*(up1(3)-up1(2))/(rgas*log(sig(3)/sig(2))) forc3=(t6(k+1)-t6(k))*alpy(i)/log(sig(k+1)/sig(k)) endif forc(i)=forc1+forc2+forc3 diff --git a/wrfv2_fire/dyn_nmm/module_membrane_mslp.F b/wrfv2_fire/dyn_nmm/module_membrane_mslp.F index 226a33f1..0d627295 100644 --- a/wrfv2_fire/dyn_nmm/module_membrane_mslp.F +++ b/wrfv2_fire/dyn_nmm/module_membrane_mslp.F @@ -18,8 +18,9 @@ module module_membrane_mslp 62500., 65000., 67500., 70000., 72500., 75000., 77500., 80000., & 82500., 85000., 87500., 90000., 92500., 95000., 97500.,100000./) - ! index within post_stdpres of the 850mbar and 700mbar levels, respectively: - integer, parameter :: k850 = 27, k700=21 + ! index within post_stdpres of the 850mbar, 700mbar and 500mbar + ! levels, respectively: + integer, parameter :: k850 = 27, k700=21, k500=13 ! Pressure "interface" levels, used only for interpolation. These ! are half-way between pressure levels (post_stdpres) in pressure @@ -264,7 +265,11 @@ subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & IMS,IME,JMS,JME,KMS,KME, & IPS,IPE,JPS,JPE,KPS,KPE) USE MODULE_DOMAIN, ONLY : domain - +#ifdef DM_PARALLEL + USE MODULE_DM, ONLY: ntasks_x, ntasks_y, mytask, ntasks, local_communicator + USE MODULE_COMM_DM, ONLY : HALO_NMM_MEMBRANE_INTERP_sub + use module_dm, only: wrf_dm_maxval_integer +#endif implicit none type(domain), intent(inout) :: grid @@ -283,13 +288,20 @@ subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & integer :: i,j,ks,a,kd,k real :: weight, TL,QL,PL, tempT, RHL, TVRL, TVRBLO, TBLO,QBLO - integer,target, dimension(ips:ipe,jps:jpe) :: ks850,ks700 + integer,target, dimension(ips:ipe,jps:jpe) :: ks850,ks700,ks500 + real, target,dimension(ips:ipe,jps:jpe) :: dummy1,dummy2 integer, pointer, dimension(:,:) :: ksX - - real, pointer, dimension(:,:) :: preswind,presrv + integer :: nanfound + real, pointer, dimension(:,:) :: preswind,presrv,presu,presv real :: Pmass(ips:ipe,jps:jpe,kds:kde) real :: numsum,densum,modelP1,modelP2,pdiff,presQ,presT,ZL,QSAT, U1, V1, U2, V2, dudy1,dvdx1, dudy2,dvdx2 + character*255 :: message + logical :: wantuv + +#ifdef DM_PARALLEL +# include "HALO_NMM_MEMBRANE_INTERP.inc" +#endif ! ks: k in source (model level) array ! kd: k in destination (pressure level) array @@ -301,6 +313,7 @@ subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & ks850=0 ks700=0 + ks500=0 ! Interpolate geopotential height to post_stdpres pressure levels ! and create a temporary array with non-hydrostatic pressure @@ -337,6 +350,8 @@ subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & ks850(i,j)=ks elseif(kd==k700) then ks700(i,j)=ks + elseif(kd==k500) then + ks500(i,j)=ks endif 103 format('interp ks=',I0,' kd=',I0,' presT(i=',I0,',j=',I0,',kd)=',F0.3, & @@ -387,22 +402,51 @@ subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & end do iTQ2 end do - ifwind: if(size(grid%p700rv)>1) then +1234 format('grid ',I0,': size(',A,') = ',I0) + write(message,1234) grid%id,'grid%p700rv',size(grid%p700rv) + call wrf_message(trim(message)) + write(message,1234) grid%id,'grid%p700u',size(grid%p700u) + call wrf_message(trim(message)) + + wantuv=(grid%vortex_tracker == 7) ! do I need to calc. presu & presv? + + ifwind: if(size(grid%p700rv)>1 .or. size(grid%p700u)>1) then ! Interpolate wind to H points on pressure levels, calculating ! horizontal wind vector magnitude and vertical component of - ! vorticity. Interpolate only to 700 and 850 mbar. - windloop: do k=1,2 - if(k==1) then + ! vorticity. Interpolate only to 700 and 850 mbar, except for U & + ! V which are also interpolated to 500mbar. + nullify(presu) + nullify(presv) + windloop: do k=0,2 + if(k==0) then + ! Only need wind components at 500 mbar + kd=k500 + ksX=>ks500 + preswind=>dummy1 + presrv=>dummy2 + if(wantuv) then + presu=>grid%p500u + presv=>grid%p500v + endif + elseif(k==1) then ksX=>ks700 preswind=>grid%p700wind presrv=>grid%p700rv kd=k700 + if(wantuv) then + presu=>grid%p700u + presv=>grid%p700v + endif elseif(k==2) then ksX=>ks850 kd=k850 preswind=>grid%p850wind presrv=>grid%p850rv - endif + if(wantuv) then + presu=>grid%p850u + presv=>grid%p850v + endif + endif ! No wind on boundaries: if(jps<=jds) then @@ -410,24 +454,48 @@ subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & preswind(i,jds)=0 presrv(i,jds)=0 enddo + if(wantuv) then + do i=ips,min(ide-1,ipe) + presu(i,jds)=0 + presv(i,jds)=0 + enddo + endif endif if(jpe>=jde-1) then do i=ips,min(ide-1,ipe) preswind(i,jde-1)=0 presrv(i,jde-1)=0 enddo + if(wantuv) then + do i=ips,min(ide-1,ipe) + presu(i,jde-1)=0 + presv(i,jde-1)=0 + enddo + endif endif if(ips<=ids) then do j=jps,min(jde-1,jpe) preswind(ids,j)=0 presrv(ids,j)=0 enddo + if(wantuv) then + do j=jps,min(jde-1,jpe) + presu(ids,j)=0 + presv(ids,j)=0 + enddo + endif endif if(ipe>=ide-1) then do j=jps,min(jde-1,jpe) preswind(ide-1,j)=0 presrv(ide-1,j)=0 enddo + if(wantuv) then + do j=jps,min(jde-1,jpe) + presu(ide-1,j)=0 + presv(ide-1,j)=0 + enddo + endif endif ! Interpolate winds: @@ -448,7 +516,11 @@ subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & dudy1 = (grid%u(i,j+1,ks)-grid%u(i,j-1,ks))/(2.*grid%dy_nmm) dvdx2 = (grid%v(i+1-a,j,ks-1)-grid%v(i-a,j,ks-1))/(2.*grid%dx_nmm(i,j)) dudy2 = (grid%u(i,j+1,ks-1)-grid%u(i,j-1,ks-1))/(2.*grid%dy_nmm) - + + if(wantuv) then + presu(i,j)=weight*u2+(1.-weight)*u1 + presv(i,j)=weight*v2+(1.-weight)*v1 + endif preswind(i,j)=weight*sqrt(u2*u2+v2*v2) + (1.-weight)*sqrt(u1*u1+v1*v1) presrv(i,j)=(dvdx2-dudy2)*weight + (dvdx1-dudy1)*(1.-weight) elseif(post_stdpres(kd)>=Pmass(i,j,kds)) then @@ -462,6 +534,10 @@ subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & preswind(i,j)=sqrt(u1*u1 + v1*v1) presrv(i,j)=dvdx1-dudy1 + if(wantuv) then + presu(i,j)=u1 + presv(i,j)=v1 + endif endif end do end do @@ -469,6 +545,7 @@ subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & ! Calculate 10m wind magnitude and vorticity ! NOTE: u10 and v10 are already on H points + nanfound=0 do j=max(jps,jds+1),min(jpe,jde-2) a=mod(j,2) do i=max(ips,ids+1),min(ipe,ide-2) @@ -478,8 +555,27 @@ subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, & dudy1 = 0.5*(grid%u10(i-a,j+1)-grid%u10(i-a,j-1) + & grid%u10(i-a+1,j+1)-grid%u10(i-a+1,j-1)) / (2*grid%dy_nmm) grid%m10rv(i,j) = dvdx1 - dudy1 + if(grid%m10rv(i,j) == grid%m10rv(i,j)) then + call wrf_debug(1000,'FIXME: REMOVE THIS CHECK') + else +3088 format('NaN m10rv at i=',I0,' j=',I0,': a=',I0,' dx=',F0.3,' dy=',F0.3) + write(message,3088) i,j,a,grid%dx_nmm(i,j),grid%dy_nmm + call wrf_message2(trim(message)) +3089 format('NaN m10rv at i=',I0,' j=',I0,': dvdx1=',F0.5,' dudy=',F0.5) + write(message,3089) i,j,dvdx1,dudy1 + call wrf_message2(trim(message)) + nanfound=1 + endif enddo enddo +#ifdef DM_PARALLEL + call wrf_dm_maxval_integer(nanfound,i,j) +#endif + if(nanfound/=0) then + call wrf_error_fatal('ERROR: NaN m10rv seen; aborting.') + endif + elseif(grid%id==3) then + call wrf_error_fatal('ERROR: NOT INTERPOLATING WIND') endif ifwind do j=jps,min(jde-1,jpe) diff --git a/wrfv2_fire/dyn_nmm/module_swath.F b/wrfv2_fire/dyn_nmm/module_swath.F new file mode 100644 index 00000000..8e5943b2 --- /dev/null +++ b/wrfv2_fire/dyn_nmm/module_swath.F @@ -0,0 +1,261 @@ +module module_swath +#ifdef HWRF + +#ifdef DM_PARALLEL + use module_dm, only: wrf_dm_sum_integer, local_communicator, & + getrealmpitype +#endif + use module_domain, only : domain,get_ijk_from_grid + use module_state_description, only: vt_ncep_2013, vt_ncep_2014 + + implicit none + + private + + public :: update_interest, init_swath + +contains + + subroutine init_swath(grid,config_flags,init) + USE MODULE_CONFIGURE, ONLY : grid_config_rec_type + type(domain), intent(inout) :: grid + type(grid_config_rec_type), intent(in) :: config_flags + logical, intent(in) :: init ! .true. = first initialization in wrf.exe + character*255 :: message + if(init) then +3088 format('Grid ',I0,' is resetting swath data.') + write(message,3088) grid%id + call wrf_message(message) + if(size(grid%interesting)>1) grid%interesting=0 + if(size(grid%precip_swath)>1) grid%precip_swath=0 + if(size(grid%windsq_swath)>1) grid%windsq_swath=0 + endif + end subroutine init_swath + + function dx_at(grid, i,j, ips,ipe,jps,jpe) result(dx) + include 'mpif.h' + type(domain), intent(inout) :: grid + real :: dx, dx_local + integer, intent(in) :: ips,ipe,jps,jpe, i,j + integer :: in,jn,ierr + if(i>=ips .and. i<=ipe .and. j>=jps .and. j<=jpe) then + dx_local=max(0.,grid%dx_nmm(i,j)) + else + dx_local=0 + endif +#ifdef DM_PARALLEL + call mpi_allreduce(dx_local,dx,1,getrealmpitype(),MPI_MAX,local_communicator,ierr) +#else + dx=dx_local +#endif + end function dx_at + + subroutine storm_interest(grid) + use module_tracker, only: update_tracker_post_move + type(domain), intent(inout) :: grid + integer :: ids,ide,jds,jde,kds,kde + integer :: ims,ime,jms,jme,kms,kme + integer :: ips,ipe,jps,jpe,kps,kpe + integer :: i,j + real :: sdistsq + + call get_ijk_from_grid(grid, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + ips,ipe,jps,jpe,kps,kpe ) + + sdistsq=grid%interest_rad_storm**2*1e6 + do j=max(jps,jds),min(jpe,jde) + do i=max(ips,ids),min(ipe,ide) + if(grid%tracker_distsq(i,j)<=sdistsq .and. grid%tracker_distsq(i,j)>1e-5) then + grid%interesting(i,j) = ior(grid%interesting(i,j),1) + endif + enddo + enddo + end subroutine storm_interest + + subroutine kid_scanner(parent,nest) + ! Sets parent%interest to 1 within nest%intrest_rad_parent + ! kilometers of the nest parent center. + type(domain), intent(inout) :: parent,nest + integer :: ni1,nj1,ni2,nj2, nimid, njmid + integer :: nims,nime,njms,njme,nkms,nkme + integer :: nids,nide,njds,njde,nkds,nkde + integer :: nips,nipe,njps,njpe,nkps,nkpe + integer :: pims,pime,pjms,pjme,pkms,pkme + integer :: pids,pide,pjds,pjde,pkds,pkde + integer :: pips,pipe,pjps,pjpe,pkps,pkpe + real :: dx,dy, dy2dx2, maxflatdist,flatdist, xshift, xfar,yfar,far + integer :: ispan,istart,iend, jspan,jstart,jend, orwhat + integer :: ki1,ki2,kj1,kj2,i,j + character*255 :: message + +#ifdef DM_PARALLEL + integer :: yin,yang ! dummy variables for wrf_dm_maxval_real + yin=-1 + yang=1 +#endif + + call get_ijk_from_grid(nest, & + nids,nide,njds,njde,nkds,nkde, & + nims,nime,njms,njme,nkms,nkme, & + nips,nipe,njps,njpe,nkps,nkpe ) + + call get_ijk_from_grid(parent, & + pids,pide,pjds,pjde,pkds,pkde, & + pims,pime,pjms,pjme,pkms,pkme, & + pips,pipe,pjps,pjpe,pkps,pkpe ) + + ki1=nest%i_parent_start + kj1=nest%j_parent_start + ki2=ki1 + (nide-nids+1)/3 + kj2=kj1 + (njde-njds+1)/3 + nimid = (ki1 + ki2) / 2 + njmid = (kj1 + kj2) / 2 + + dy=parent%dy_nmm + dx=dx_at(parent,nimid,njmid, pips,pipe,pjps,pjpe) + if(dx<1e-5) then + write(message,30) nest%id, nimid,njmid, parent%id, ki1,kj1,ki2,kj2 + call wrf_error_fatal(message) +30 format("Nest ",I0," middle point ",I0,",",I0," is not inside parent ", & + I0," (ki1=",I0," kj1=",I0," ki2=",I0," kj2=",I0,")") + endif + + ispan =ceiling(1e3*nest%interest_rad_parent/dx)+1 + istart=max(pids, nimid-ispan) + iend =min(pide-1,nimid+ispan) + + jspan =ceiling(1e3*nest%interest_rad_parent/dy)+1 + jstart=max(pjds, njmid-jspan) + jend =min(pjde-1,njmid+jspan) + + dy2dx2 = dy*dy / (dx*dx) + maxflatdist=nest%interest_rad_parent**2*1e6 + if(nest%id>0 .and. nest%id<=20) then + orwhat=ishft(1,nest%id) + else + orwhat=ishft(1,21) + endif + + if(jstart<=pjpe .or. jend>=pjps .or. istart<=pipe .or. iend>=pipe) then + do j=pjps,min(pjpe,pjde-1) + if(mod(j,2)==1) then + xshift=1. + else + xshift=-1. + endif + do i=pips,min(pipe,pide-1) + xfar=(i-nimid)*parent%dx_nmm(i,j)*2 + yfar=(j-njmid)*dy + if(mod(njmid-j,2) /= 0) then + xfar=xfar + parent%dx_nmm(i,j)*xshift + endif + far = xfar*xfar + yfar*yfar + if(far0 .and. grid%id<=20) then + orwhat=ishft(1,grid%id) + else + orwhat=ishft(1,21) + endif + + do j=jps,min(jpe,jde-1) + do i=ips,min(ipe,ide-1) + if(grid%distsq(i,j) <= maxflatdist) & + grid%interesting(i,j) = ior(grid%interesting(i,j),orwhat) + enddo + enddo + end subroutine self_interest + + subroutine update_interest(grid,config_flags) + USE MODULE_CONFIGURE, ONLY : grid_config_rec_type + type(domain), intent(inout) :: grid + type(grid_config_rec_type), intent(in) :: config_flags + integer :: max_dom, nestid, parent_id, ikid, ki0,kj0,kni,knj + logical :: nestless + + grid%interesting=0 + + likes_kids: if(config_flags%interest_kids==1) then + do ikid=1,grid%num_nests + if(associated(grid%nests(ikid)%ptr)) & + call kid_scanner(grid,grid%nests(ikid)%ptr) + enddo + endif likes_kids + + likes_storms: if(config_flags%interest_storms==1 .and. & + ( grid%vortex_tracker == vt_ncep_2013 .or. & + grid%vortex_tracker == vt_ncep_2014 ) ) then + ! Region near cyclone is flagged as "interesting" + call storm_interest(grid) + endif likes_storms + + if(config_flags%interest_self==1) & + call self_interest(grid) + + call print_interest(grid) + end subroutine update_interest +#else + ! Make sure the module is not empty in non-HWRF mode. +contains + subroutine swath_dummy() + end subroutine swath_dummy +#endif +end module module_swath diff --git a/wrfv2_fire/dyn_nmm/module_tornado_genesis.F b/wrfv2_fire/dyn_nmm/module_tornado_genesis.F new file mode 100644 index 00000000..5a6845fc --- /dev/null +++ b/wrfv2_fire/dyn_nmm/module_tornado_genesis.F @@ -0,0 +1,465 @@ +module module_tornado_genesis + implicit none + private + + public :: init_tornado_genesis, calc_tornado_genesis, & + reset_tornado_genesis, request_tg_reset + + real, parameter :: wwind_cutoff = 40000.0 ! pascals + +contains + + subroutine update_tg_time(grid,init) + ! Helper function that updates the three time interval variables + ! based on the grid's clock. If init=.true. then both times + ! (interval start and end) are set to the current time, otherwise + ! only the interval end is updated. In either case, tg_duration + ! is set to the length in seconds of the interval. + use module_domain, only: domain, domain_get_time_since_sim_start + use module_symbols_util, only: WRFU_TimeIntervalGet, WRFU_TimeInterval + type(domain), intent(inout) :: grid + type(WRFU_TimeInterval) :: since_start + logical, intent(in) :: init + integer :: s_i, s_n, s_d + + since_start=domain_get_time_since_sim_start(grid) + s_i=0 + s_n=0 + s_d=1 + call WRFU_TimeIntervalGet(since_start,S=s_i,Sn=s_n,Sd=s_d) + if(s_d==0) s_d=1 + grid%tg_interval_end=real(s_i) + real(s_n)/real(s_d) + if(init) grid%tg_interval_start=grid%tg_interval_end + grid%tg_duration=grid%tg_interval_end-grid%tg_interval_start + end subroutine update_tg_time + + subroutine init_tg_vars(grid,config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + ! Helper function that resets all min/max accumulation arrays to 0 + use module_domain, only: domain, get_ijk_from_grid + use module_configure, only : grid_config_rec_type + use module_state_description, only: tg_emc2014spc + type(domain), intent(inout) :: grid + type(grid_config_rec_type), intent(in) :: config_flags + integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE + integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME + integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE + integer :: i,j, istart,iend, jstart,jend + character*255 message + + if(config_flags%tg_option/=tg_emc2014spc) return + jstart=max(jds,jps) + jend=min(jpe,jde-1) + istart=max(ids,ips) + iend=min(ipe,ide-1) + +3012 format("Grid ",I2,": filling tornado genesis data with zeros") + write(message,3012) grid%id + call wrf_debug(1,message) + + do j=jstart,jend + do i=istart,iend + grid%tg_max_m10wind(i,j)=0 + grid%tg_max_wwind(i,j)=0 + grid%tg_min_wwind(i,j)=0 + grid%tg_max_zhel_25(i,j)=0 + grid%tg_min_zhel_25(i,j)=0 + grid%tg_max_zhel_03(i,j)=0 + grid%tg_min_zhel_03(i,j)=0 + grid%tg_max_updhel03(i,j)=0 + grid%tg_max_updhel25(i,j)=0 + grid%tg_updhel03(i,j)=0 + grid%tg_updhel25(i,j)=0 + grid%tg_total_precip(i,j)=0 + enddo + enddo + + if(size(grid%tlow)>1 .and. size(grid%zlow)>1) then + do j=jstart,jend + do i=istart,iend + grid%tlow(i,j)=0 + grid%zlow(i,j)=0 + enddo + enddo + endif + + if(size(grid%rotangle)>1) then + do j=jstart,jend + do i=istart,iend + grid%rotangle(i,j)=0 + end do + end do + endif + + grid%tg_interval_end=grid%tg_interval_start + grid%tg_duration=0.0 + grid%tg_want_reset=0 + end subroutine init_tg_vars + + subroutine init_tornado_genesis(grid,config_flags) + ! Called to initialize tornado genesis data arrays. Should only + ! be called at initial time. + use module_domain, only: domain, get_ijk_from_grid + use module_state_description, only: tg_emc2014spc + use module_configure, only : grid_config_rec_type + type(domain), intent(inout) :: grid + type(grid_config_rec_type), intent(in) :: config_flags + integer :: IDS,IDE,JDS,JDE,KDS,KDE + integer :: IMS,IME,JMS,JME,KMS,KME + integer :: IPS,IPE,JPS,JPE,KPS,KPE + + grid%tg_want_reset=0 ! to avoid needless calls to reset_tornado_genesis + if(config_flags%tg_option/=tg_emc2014spc) return + + if(grid%hydro) then + call wrf_error_fatal('Tornado genesis products require non-hydrostatic integration.') + endif + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + call init_tg_vars(grid,config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + call update_tg_time(grid,.true.) + end subroutine init_tornado_genesis + + subroutine request_tg_reset(grid,config_flags,stream) + use module_state_description, only: tg_emc2014spc + use module_domain, only: domain, get_ijk_from_grid + use module_configure, only : grid_config_rec_type + use module_io_domain, only: first_history + type(domain), intent(inout) :: grid + type(grid_config_rec_type), intent(in) :: config_flags + integer, intent(in) :: stream + character*255 :: message + integer :: histnum + + if(config_flags%tg_option/=tg_emc2014spc) return + + histnum=stream-first_history + if(config_flags%tg_reset_stream == histnum) then +3012 format('Grid ',I2,': resetting tornado genesis data after stream ',I0,' output') + write(message,3012) grid%id,histnum + call wrf_message(trim(message)) + grid%tg_want_reset=1 + endif + end subroutine request_tg_reset + + subroutine reset_tornado_genesis(grid,config_flags) + ! Called after writing output for a given stream. Resets all + ! min/max information for all fields if the stream is the + ! tg_reset_stream. + use module_state_description, only: tg_emc2014spc + use module_domain, only: domain, get_ijk_from_grid + use module_configure, only : grid_config_rec_type + use module_io_domain, only: first_history + type(domain), intent(inout) :: grid + type(grid_config_rec_type), intent(in) :: config_flags + integer :: IDS,IDE,JDS,JDE,KDS,KDE + integer :: IMS,IME,JMS,JME,KMS,KME + integer :: IPS,IPE,JPS,JPE,KPS,KPE + character*255 :: message + integer :: histnum + + if(config_flags%tg_option/=tg_emc2014spc) return + if(grid%tg_want_reset==0) return + +3012 format('Grid ',I2,': resetting tornado genesis data') + write(message,3012) grid%id + call wrf_message(trim(message)) + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + ! Previous interval end time is now this interval's start time + ! since we're entering the next interval: + grid%tg_interval_start=grid%tg_interval_end + + call init_tg_vars(grid,config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + end subroutine reset_tornado_genesis + + subroutine rotate_winds(grid,config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + ! Compute wind rotation angle + use module_model_constants, only: DEGRAD + use module_domain, only: domain + use module_configure, only : grid_config_rec_type + type(domain), intent(inout) :: grid + type(grid_config_rec_type), intent(in) :: config_flags + integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE + integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME + integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE + integer :: i,j + real :: cenlat,cenlon, lmbd0,phi0, cos_phi0,sin_phi0 + real :: big_denom, relm, lat, lon, cos_alpha, sin_alpha + + ! Get the projection center from the MOAD center: + call nl_get_cen_lat(1,cenlat) + call nl_get_cen_lon(1,cenlon) + if(cenlon<0) cenlon=cenlon+360. + lmbd0=cenlon*DEGRAD + phi0=cenlat*DEGRAD + + cos_phi0=cos(phi0) + sin_phi0=sin(phi0) + do j=max(jps,jds),min(jpe,jde-1) + do i=max(ips,ids),min(ipe,ide-1) + lon=grid%GLON(i,j) + lat=grid%GLAT(i,j) + relm=lon-lmbd0 + big_denom=cos(asin( cos_phi0*sin(lat) - sin_phi0*cos(lat)*cos(relm) )) + sin_alpha=sin_phi0*sin(relm)/big_denom + cos_alpha=(cos_phi0*cos(lat)+sin_phi0*sin(lat)*cos(relm))/big_denom + grid%rotangle(i,j) = atan2(sin_alpha,cos_alpha) + enddo + enddo + end subroutine rotate_winds + + subroutine calc_tornado_genesis(grid,config_flags) + ! Updates max/min information for tornado genesis wind fields from + ! grid data at the current time. The tg_total_precip is handled + ! in module_PHYSICS_CALLS instead. + use module_comm_dm, only: HALO_NMM_C_sub + use module_state_description, only: tg_emc2014spc + use module_domain, only: domain, get_ijk_from_grid + use module_configure, only : grid_config_rec_type +#ifdef DM_PARALLEL + use module_dm, only: wrf_dm_maxval_real, wrf_dm_minval_real, & + ntasks_x, ntasks_y, mytask, ntasks, local_communicator +#endif + type(domain), intent(inout) :: grid + type(grid_config_rec_type), intent(in) :: config_flags + integer :: IDS,IDE,JDS,JDE,KDS,KDE + integer :: IMS,IME,JMS,JME,KMS,KME + integer :: IPS,IPE,JPS,JPE,KPS,KPE + integer :: i,j,k, istart,iend, jstart,jend, a, imin,imax + real :: dudy, dvdx, w, zhel, maxmaxwind, minminw, maxmaxw, sec, updhel03, updhel25 + real :: height, height1, height2, height0, maxmaxzhel, minminzhel, updhelpart + character*255 :: message + + if(config_flags%tg_option/=tg_emc2014spc) return + if(grid%hydro) then + call wrf_error_fatal('Tornado genesis products require non-hydrostatic integration.') + endif + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + jstart=max(jps,jds+1) + jend=min(jpe,jde-2) + istart=max(ips,ids+1) + iend=min(ipe,ide-2) + imin=max(ips,ids) + imax=min(ipe,ide-1) + +#ifdef DM_PARALLEL +# include "HALO_NMM_C.inc" +#endif + + if(size(grid%tlow)>1 .and. size(grid%zlow)>1) then + ! Near surface Z & T for wave model: + do j=max(jps,jds),min(jpe,jde-1) + do i=max(ips,ids),min(ipe,ide-1) + grid%tlow(i,j)=grid%T(i,j,kds) + grid%zlow(i,j)=(grid%Z(i,j,kds+1)-grid%Z(i,j,kds))/2 + enddo + enddo + endif + + if(size(grid%rotangle)>1) then + call rotate_winds(grid,config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + endif + + ! Maximum 10m wind vector magnitude: + maxmaxwind=0.0 + do j=jstart,jend + do i=istart,iend + grid%tg_max_m10wind(i,j)=max(grid%tg_max_m10wind(i,j), & + sqrt(grid%u10(i,j)*grid%u10(i,j) + grid%v10(i,j)*grid%v10(i,j))) + maxmaxwind=max(maxmaxwind,grid%tg_max_m10wind(i,j)) + enddo + enddo + +#ifdef DM_PARALLEL + call wrf_dm_maxval_real(maxmaxwind,i,j) +#endif + + ! Min/max vertical wind below 400mbar: + minminw=0.0 + maxmaxw=0.0 + do j=jstart,jend + do i=istart,iend + kloop: do k=kds+1,kde-1 + if(grid%pint(i,j,k)0) then + updhel03=updhel03+updhelpart + endif + endif + if(height2>2000.0) then + grid%tg_max_zhel_25(i,j)=max(grid%tg_max_zhel_25(i,j),zhel) + grid%tg_min_zhel_25(i,j)=min(grid%tg_min_zhel_25(i,j),zhel) + minminzhel=min(grid%tg_min_zhel_25(i,j),minminzhel) + maxmaxzhel=max(grid%tg_max_zhel_25(i,j),maxmaxzhel) + updhelpart=max(zhel*(height2-height1),0.) + if(grid%glat(i,j)<0) updhelpart=-updhelpart + if(updhelpart>0) then + updhel25=updhel25+updhelpart + endif + endif + + k=k+1 + height1=height2 + enddo + grid%tg_updhel25(i,j)=updhel25 + grid%tg_updhel03(i,j)=updhel03 + if(updhel25>grid%tg_max_updhel25(i,j)) & + grid%tg_max_updhel25(i,j)=updhel25 + if(updhel03>grid%tg_max_updhel03(i,j)) & + grid%tg_max_updhel03(i,j)=updhel03 + enddo + enddo + +#ifdef DM_PARALLEL + call wrf_dm_maxval_real(maxmaxzhel,i,j) + call wrf_dm_minval_real(minminzhel,i,j) +#endif + + ! I boundaries copy from nearest point that has data, excluding corner points: + if(ips<=ids) then + grid%tg_max_zhel_25(ids,jstart:jend)=grid%tg_max_zhel_25(ids+1,jstart:jend) + grid%tg_max_zhel_03(ids,jstart:jend)=grid%tg_max_zhel_03(ids+1,jstart:jend) + grid%tg_min_zhel_25(ids,jstart:jend)=grid%tg_min_zhel_25(ids+1,jstart:jend) + grid%tg_min_zhel_03(ids,jstart:jend)=grid%tg_min_zhel_03(ids+1,jstart:jend) + grid%tg_updhel25(ids,jstart:jend)=grid%tg_updhel25(ids+1,jstart:jend) + grid%tg_updhel03(ids,jstart:jend)=grid%tg_updhel03(ids+1,jstart:jend) + grid%tg_max_updhel25(ids,jstart:jend)=grid%tg_max_updhel25(ids+1,jstart:jend) + grid%tg_max_updhel03(ids,jstart:jend)=grid%tg_max_updhel03(ids+1,jstart:jend) + grid%tg_max_wwind(ids,jstart:jend)=grid%tg_max_wwind(ids+1,jstart:jend) + grid%tg_min_wwind(ids,jstart:jend)=grid%tg_min_wwind(ids+1,jstart:jend) + grid%tg_max_m10wind(ids,jstart:jend)=grid%tg_max_m10wind(ids+1,jstart:jend) + endif + + if(ipe>=ide-2) then + grid%tg_max_zhel_25(ide-1,jstart:jend)=grid%tg_max_zhel_25(ide-2,jstart:jend) + grid%tg_max_zhel_03(ide-1,jstart:jend)=grid%tg_max_zhel_03(ide-2,jstart:jend) + grid%tg_min_zhel_25(ide-1,jstart:jend)=grid%tg_min_zhel_25(ide-2,jstart:jend) + grid%tg_min_zhel_03(ide-1,jstart:jend)=grid%tg_min_zhel_03(ide-2,jstart:jend) + grid%tg_updhel25(ide-1,jstart:jend)=grid%tg_updhel25(ide-2,jstart:jend) + grid%tg_updhel03(ide-1,jstart:jend)=grid%tg_updhel03(ide-2,jstart:jend) + grid%tg_max_updhel25(ide-1,jstart:jend)=grid%tg_max_updhel25(ide-2,jstart:jend) + grid%tg_max_updhel03(ide-1,jstart:jend)=grid%tg_max_updhel03(ide-2,jstart:jend) + grid%tg_max_wwind(ide-1,jstart:jend)=grid%tg_max_wwind(ide-2,jstart:jend) + grid%tg_min_wwind(ide-1,jstart:jend)=grid%tg_min_wwind(ide-2,jstart:jend) + grid%tg_max_m10wind(ide-1,jstart:jend)=grid%tg_max_m10wind(ide-2,jstart:jend) + endif + + ! J boundaries: copy from nearest point that has data. We use + ! imin:imax instead of istart:iend to get the corner points. + if(jps<=jds) then + grid%tg_max_zhel_25(imin:imax,jds)=grid%tg_max_zhel_25(imin:imax,jds+1) + grid%tg_max_zhel_03(imin:imax,jds)=grid%tg_max_zhel_03(imin:imax,jds+1) + grid%tg_min_zhel_25(imin:imax,jds)=grid%tg_min_zhel_25(imin:imax,jds+1) + grid%tg_min_zhel_03(imin:imax,jds)=grid%tg_min_zhel_03(imin:imax,jds+1) + grid%tg_updhel25(imin:imax,jds)=grid%tg_updhel25(imin:imax,jds+1) + grid%tg_updhel03(imin:imax,jds)=grid%tg_updhel03(imin:imax,jds+1) + grid%tg_max_updhel25(imin:imax,jds)=grid%tg_max_updhel25(imin:imax,jds+1) + grid%tg_max_updhel03(imin:imax,jds)=grid%tg_max_updhel03(imin:imax,jds+1) + grid%tg_max_wwind(imin:imax,jds)=grid%tg_max_wwind(imin:imax,jds+1) + grid%tg_min_wwind(imin:imax,jds)=grid%tg_min_wwind(imin:imax,jds+1) + grid%tg_max_m10wind(imin:imax,jds)=grid%tg_max_m10wind(imin:imax,jds+1) + endif + + if(jpe>=jde-2) then + grid%tg_max_zhel_25(imin:imax,jde-1)=grid%tg_max_zhel_25(imin:imax,jde-2) + grid%tg_max_zhel_03(imin:imax,jde-1)=grid%tg_max_zhel_03(imin:imax,jde-2) + grid%tg_min_zhel_25(imin:imax,jde-1)=grid%tg_min_zhel_25(imin:imax,jde-2) + grid%tg_min_zhel_03(imin:imax,jde-1)=grid%tg_min_zhel_03(imin:imax,jde-2) + grid%tg_updhel25(imin:imax,jde-1)=grid%tg_updhel25(imin:imax,jde-2) + grid%tg_updhel03(imin:imax,jde-1)=grid%tg_updhel03(imin:imax,jde-2) + grid%tg_max_updhel25(imin:imax,jde-1)=grid%tg_max_updhel25(imin:imax,jde-2) + grid%tg_max_updhel03(imin:imax,jde-1)=grid%tg_max_updhel03(imin:imax,jde-2) + grid%tg_max_wwind(imin:imax,jde-1)=grid%tg_max_wwind(imin:imax,jde-2) + grid%tg_min_wwind(imin:imax,jde-1)=grid%tg_min_wwind(imin:imax,jde-2) + grid%tg_max_m10wind(imin:imax,jde-1)=grid%tg_max_m10wind(imin:imax,jde-2) + endif + + call update_tg_time(grid,.false.) + +3313 format('TG extrema: max(wind)=',F0.2,' max(w)=',F0.2,' min(w)=',F0.2,' max(zhel)=',F0.4,' min(zhel)=',F0.4) + write(message,3313) maxmaxwind,maxmaxw,minminw,maxmaxzhel,minminzhel + call wrf_debug(1,message) + end subroutine calc_tornado_genesis + +end module module_tornado_genesis + +subroutine nmm_request_tg_reset(grid,config_flags,stream) + ! This subroutine is a wrapper kludge to work around the WRF build + ! order and limitations of make. The module_tornado_genesis module + ! file does not exist when mediation_integrate is compiled, so + ! med_hist_out has to call a non-module function instead. + use module_domain, only: domain + use module_configure, only : grid_config_rec_type + use module_tornado_genesis, only: request_tg_reset + implicit none + integer, intent(in) :: stream + type(domain), intent(inout) :: grid + type(grid_config_rec_type), intent(in) :: config_flags + call request_tg_reset(grid,config_flags,stream) +end subroutine nmm_request_tg_reset diff --git a/wrfv2_fire/dyn_nmm/module_tracker.F b/wrfv2_fire/dyn_nmm/module_tracker.F index 7c37dc1c..bd85f726 100644 --- a/wrfv2_fire/dyn_nmm/module_tracker.F +++ b/wrfv2_fire/dyn_nmm/module_tracker.F @@ -2,12 +2,13 @@ module module_tracker implicit none private #ifdef HWRF - public :: ncep_tracker_center, ncep_tracker_init + public :: ncep_tracker_center, ncep_tracker_init, update_tracker_post_move real, parameter :: invE=0.36787944117 ! 1/e ! Copied from tracker: - real,parameter :: searchrad=250.0 ! km - ignore data more than this far from domain center + real,parameter :: searchrad_6=250.0 ! km - ignore data more than this far from domain center + real,parameter :: searchrad_7=200.0 ! km - ignore data more than this far from domain center integer, parameter :: maxtp=11 ! number of tracker parameters real, parameter :: uverrmax = 225.0 ! For use in get_uv_guess real, parameter :: ecircum = 40030.2 ! Earth's circumference @@ -19,8 +20,37 @@ module module_tracker real, parameter :: errpmax=485.0 ! max stddev of track parameters real, parameter :: errpgro=1.25 ! stddev multiplier + real, parameter :: max_wind_search_radius=searchrad_7 ! max radius for vmax search + real, parameter :: min_mlsp_search_radius=searchrad_7 ! max radius for pmin search + + ! Also used: + real, parameter :: km2nmi = 0.539957, kn2mps=0.514444, mps2kn=1./kn2mps, pi180=0.01745329251 contains + !---------------------------------------------------------------------------------- + ! These two simple routines return an N, S, E or W for the + ! hemisphere of a latitude or longitude. They are copied from + ! module_HIFREQ to avoid a relatively pointless compiler dependency. + + character(1) function get_lat_ns(lat) + ! This could be written simply as merge('N','S',lat>=0) if WRF allowed F95 + implicit none ; real lat + if(lat>=0) then + get_lat_ns='N' + else + get_lat_ns='S' + endif + end function get_lat_ns + character(1) function get_lon_ew(lon) + ! This could be written simply as merge('E','W',lon>=0) if WRF allowed F95 + implicit none ; real lon + if(lon>=0) then + get_lon_ew='E' + else + get_lon_ew='W' + endif + end function get_lon_ew + subroutine ncep_tracker_init(grid) ! Initialize tracker variables in the grid structure. use module_domain, only: domain @@ -30,12 +60,25 @@ subroutine ncep_tracker_init(grid) grid%track_stderr_m1=-99.9 grid%track_stderr_m2=-99.9 grid%track_stderr_m3=-99.9 + grid%track_n_old=0 + grid%track_old_lon=0 + grid%track_old_lat=0 + grid%track_old_ntsd=0 + + grid%tracker_angle=0 grid%tracker_fixlon=-999.0 grid%tracker_fixlat=-999.0 grid%tracker_ifix=-99 grid%tracker_jfix=-99 grid%tracker_havefix=.false. grid%tracker_gave_up=.false. + grid%tracker_pmin=-99999. + grid%tracker_vmax=-99. + grid%tracker_rmw=-99. + + grid%track_have_guess=.false. + grid%track_guess_lat=-999.0 + grid%track_guess_lon=-999.0 end subroutine ncep_tracker_init subroutine ncep_tracker_center(grid) @@ -68,11 +111,15 @@ subroutine ntc_impl(grid, & IDS,IDE,JDS,JDE,KDS,KDE, & IMS,IME,JMS,JME,KMS,KME, & IPS,IPE,JPS,JPE,KPS,KPE) + ! This is the main entry point to the tracker. It is most similar + ! to the function "tracker" in the GFDL/NCEP vortex tracker. + USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid #ifdef DM_PARALLEL use module_dm, only: wrf_dm_sum_real #endif implicit none + logical, external :: wrf_dm_on_monitor type(domain), intent(inout) :: grid integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME @@ -93,9 +140,13 @@ subroutine ntc_impl(grid, & integer :: icen(maxtp), jcen(maxtp) ! center locations for each parameter real :: loncen(maxtp), latcen(maxtp) ! lat, lon locations in degrees logical :: calcparm(maxtp) ! do we have a valid center location for this parameter? + real :: max_wind,min_pres ! for ATCF output real :: rcen(maxtp) ! center value (max wind, min mslp, etc.) - + character*255 :: message logical :: north_hemi ! true = northern hemisphere + logical :: have_guess ! first guess is available + real :: guessdist,guessdeg ! first guess distance to nearest point on grid + real :: latnear, lonnear ! nearest point in grid to first guess ! icen,jcen: Same meaning as clon, clat in tracker, but uses i and ! j indexes of the center instead of lat/lon. Tracker comment: @@ -124,18 +175,71 @@ subroutine ntc_impl(grid, & loncen=9e9 rcen=9e9 calcparm=.false. - srsq=searchrad*searchrad*1e6 + if(grid%vortex_tracker==6) then + srsq=searchrad_6*searchrad_6*1e6 + else + srsq=searchrad_7*searchrad_7*1e6 + endif - ! Hard coded first-guess center is domain center: - iguess=ide/2 - jguess=jde/2 - call get_lonlat(grid,iguess,jguess,longuess,latguess,ierr, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - ips,ipe, jps,jpe, kps,kpe) - if(ierr/=0) then - call wrf_error_fatal("ERROR: center of domain is not inside the domain") + ! Get the first guess from the prior nest motion timestep: + have_guess=grid%track_have_guess + if(have_guess) then + ! We have a first guess center. We have to translate it to gridpoint space. + longuess=grid%track_guess_lon + latguess=grid%track_guess_lat + call get_nearest_lonlat(grid,iguess,jguess,ierr,longuess,latguess, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, lonnear, latnear) + if(ierr==0) then + call calcdist(longuess,latguess, lonnear,latnear, guessdist,guessdeg) + if(guessdist*1e3>3*grid%dy) then +108 format('WARNING: guess lon=',F0.3,',lat=',F0.3, & + ' too far (',F0.3,'km) from nearest point lon=',F0.3,',lat=',F0.3, & + '. Will use domain center as first guess.') + write(message,108) grid%track_guess_lon,grid%track_guess_lat, & + guessdist,lonnear,latnear + call wrf_message(message) + have_guess=.false. ! indicate that the first guess is unusable + else + latguess=latnear + longuess=lonnear + endif + else + have_guess=.false. ! indicate that the first guess is unusable. +109 format('WARNING: guess lon=',F0.3,',lat=',F0.3, & + ' does not exist in this domain. Will use domain center as first guess.') + write(message,109) grid%track_guess_lon,grid%track_guess_lat + call wrf_message(message) + endif + endif + + ! If we could not get the first guess from the prior nest motion + ! timestep, then use the default first guess: the domain center. + if(grid%vortex_tracker==6 .or. .not.have_guess) then + ! vt=6: hard coded first-guess center is domain center: + ! vt=7: first guess comes from prior timestep + ! Initial first guess is domain center. + ! Backup first guess is domain center if first guess is unusable. + iguess=ide/2 + jguess=jde/2 + if(grid%vortex_tracker==7) then + call wrf_message('Using domain center as first guess since no valid first guess is available.') + endif + call get_lonlat(grid,iguess,jguess,longuess,latguess,ierr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe) + if(ierr/=0) then + call wrf_error_fatal("ERROR: center of domain is not inside the domain") + endif + have_guess=.true. + endif + + if(.not.have_guess) then + call wrf_error_fatal("INTERNAL ERROR: No first guess is available (should never happen).") endif + north_hemi = latguess>0.0 ! Get the mean V-to-H point-to-point distance: @@ -193,24 +297,45 @@ subroutine ntc_impl(grid, & IPS,IPE,JPS,JPE,KPS,KPE) ! Find wind minima. Requires a first guess center: - call find_center(grid,grid%p850wind,grid%sp850wind,srsq, & - icen(3),jcen(3),rcen(3),calcparm(3),loncen(3),latcen(3),dxdymean,'wind', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE, & - iuvguess=iuvguess, juvguess=juvguess) - call find_center(grid,grid%p700wind,grid%sp700wind,srsq, & - icen(5),jcen(5),rcen(5),calcparm(5),loncen(5),latcen(5),dxdymean,'wind', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE, & - iuvguess=iuvguess, juvguess=juvguess) - call find_center(grid,grid%m10wind,grid%sm10wind,srsq, & - icen(10),jcen(10),rcen(10),calcparm(10),loncen(10),latcen(10),dxdymean,'wind', & - IDS,IDE,JDS,JDE,KDS,KDE, & - IMS,IME,JMS,JME,KMS,KME, & - IPS,IPE,JPS,JPE,KPS,KPE, & - iuvguess=iuvguess, juvguess=juvguess) + windmin: if(grid%vortex_tracker==6) then + call find_center(grid,grid%p850wind,grid%sp850wind,srsq, & + icen(3),jcen(3),rcen(3),calcparm(3),loncen(3),latcen(3),dxdymean,'wind', & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE, & + iuvguess=iuvguess, juvguess=juvguess) + call find_center(grid,grid%p700wind,grid%sp700wind,srsq, & + icen(5),jcen(5),rcen(5),calcparm(5),loncen(5),latcen(5),dxdymean,'wind', & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE, & + iuvguess=iuvguess, juvguess=juvguess) + call find_center(grid,grid%m10wind,grid%sm10wind,srsq, & + icen(10),jcen(10),rcen(10),calcparm(10),loncen(10),latcen(10),dxdymean,'wind', & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE, & + iuvguess=iuvguess, juvguess=juvguess) + else + call get_uv_center(grid,grid%p850wind, & + icen(3),jcen(3),rcen(3),calcparm(3),loncen(3),latcen(3),dxdymean,'wind', & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE, & + iuvguess=iuvguess, juvguess=juvguess) + call get_uv_center(grid,grid%p700wind, & + icen(5),jcen(5),rcen(5),calcparm(5),loncen(5),latcen(5),dxdymean,'wind', & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE, & + iuvguess=iuvguess, juvguess=juvguess) + call get_uv_center(grid,grid%m10wind, & + icen(10),jcen(10),rcen(10),calcparm(10),loncen(10),latcen(10),dxdymean,'wind', & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE, & + iuvguess=iuvguess, juvguess=juvguess) + endif windmin ! Get a final guess center location: call fixcenter(grid,icen,jcen,calcparm,loncen,latcen, & @@ -257,18 +382,574 @@ subroutine ntc_impl(grid, & !write(0,201) ifinal,jfinal,lonfinal,latfinal endif + call get_tracker_distsq(grid, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE) + + call get_wind_pres_intensity(grid, & + grid%tracker_pmin,grid%tracker_vmax,grid%tracker_rmw, & + max_wind_search_radius, min_mlsp_search_radius, & + lonfinal,latfinal, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE) + +#ifdef DM_PARALLEL + if(wrf_dm_on_monitor()) then +#endif + call output_partial_atcfunix(grid, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE) +#ifdef DM_PARALLEL + endif +#endif + +! if(grid%vortex_tracker==7) then +! call get_first_ges(grid,iguess,jguess,longuess,latguess, & +! IDS,IDE,JDS,JDE,KDS,KDE, & +! IMS,IME,JMS,JME,KMS,KME, & +! IPS,IPE,JPS,JPE,KPS,KPE) + +! call store_old_fixes(grid, & +! IDS,IDE,JDS,JDE,KDS,KDE, & +! IMS,IME,JMS,JME,KMS,KME, & +! IPS,IPE,JPS,JPE,KPS,KPE) + +! ! Store the first guess: +! grid%track_have_guess=.true. +! grid%track_guess_lat=latguess +! grid%track_guess_lon=longuess +! 3011 format('First guess: lon=',F0.3,' lat=',F0.3) +! write(message,3011) grid%track_guess_lon,grid%track_guess_lat +! call wrf_debug(1,message) +! endif + + end subroutine ntc_impl + + subroutine get_first_ges(grid, & + iguess,jguess,longuess,latguess, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE) + ! This replicates the functionality of the tracker get_first_ges + ! routine, whose purpose is to analyze the storm and guess where + ! it will be at the next nest motion timestep. It does that using + ! two different methods, similar to the GFDL/NCEP Tracker's + ! methods: + ! + ! 1. Use the present, and past few, fix locations and extrapolate + ! to the next location. + ! + ! 2. Calculate the mean motion and extrapolate to get the + ! location at the next nest motion timestep. + ! + ! The average of the two results is used. + +#ifdef DM_PARALLEL + use module_dm, only: wrf_dm_maxval_real +#endif + USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid + use module_wrf_error, only: wrf_at_debug_level + implicit none + type(domain), intent(inout) :: grid + integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE + integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME + integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE + integer, intent(out) :: iguess,jguess + real, intent(out) :: longuess,latguess + + character*255 message + integer :: iold, inew, jold, jnew + integer :: ifix,jfix,jrot,irot,ierr, pinky,brain, n, tsum, ntsd_plus_1, i, told + real :: motion_grideast, motion_gridnorth, fixdx + real :: dxeast,dynorth, xeast, ynorth + real :: dxrot, dyrot, tracker_dt, xsum, ysum, ytsum, xtsum, xxsum, yysum, ttsum + real :: mx, my, bx, by ! x=mx*t+bx ; y=my*t+by + real :: xrot,yrot + logical :: have_motion_guess, have_line_guess + + have_motion_guess=.false. + have_line_guess=.false. + + if(grid%tracker_havefix) then + ifix=grid%tracker_ifix + jfix=grid%tracker_jfix + + call mean_motion(grid, motion_grideast, motion_gridnorth, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE) + +#ifdef DM_PARALLEL + fixdx=0 + if(ifix>=ips .and. ifix<=ipe .and. jfix>=jps .and. jfix<=jpe) then + fixdx=grid%dx_nmm(ifix,jfix) + endif + pinky=2 ; brain=308 + call wrf_dm_maxval_real(fixdx,pinky,brain) +#else + fixdx=grid%dx_nmm(ifix,jfix) +#endif + + ! Rotated east and north motion in gridpoints per second, on the combined H+V grid: + tracker_dt=grid%dt*grid%nphs*grid%movemin + dxeast = motion_grideast * tracker_dt / fixdx + dynorth = motion_gridnorth * tracker_dt / grid%dy_nmm + + ! Combine the H & V coordinate systems and rotate 45 degrees. + ! This puts the H points on a rectangular grid. Add storm motion + ! to the rotated coordinates and round to nearest H point + xeast=ifix*2 + ynorth=jfix + if(mod(jfix,2)==0) xeast=xeast+1 + jrot=nint((xeast+ynorth)/2 + (dxeast+dynorth)/2) + irot=nint((ynorth-xeast)/2 + ((jde-1)/2) + (dynorth-dxeast)/2) + + ! Translate back to usual E grid H points + iguess=irot-jrot+((jde-1)/2) + jguess=irot+jrot-((jde-1)/2) + if(mod(jguess,2)==0) then + iguess=(iguess-1)/2 + else + iguess=iguess/2 + endif + + ! This last step should not be necessary but done just in case: + have_motion_guess = .not.(iguesside*3/4 .or. jguessjde*3/4) + + !print *,'got have_motion_guess=',have_motion_guess + endif + + if(.not.have_motion_guess) then + ! Could not find the storm, so give the domain center as the + ! next first guess location. + iguess=ide/2 + jguess=jde/2 + !print *,'cannot find storm, so using domain center for motion guess' + endif + + if(grid%track_n_old>0) then + !print *,'line guess: have old' + n=1 + call to_rot45_grid(grid%tracker_ifix,grid%tracker_jfix,jde,xrot,yrot) + xsum=xrot + ysum=yrot + tsum=grid%ntsd + xtsum=xsum*tsum + xxsum=xsum*xsum + yysum=ysum*ysum + ytsum=ysum*tsum + ttsum=tsum*tsum + + do i=1,grid%track_n_old + call get_nearest_lonlat(grid,iold,jold,ierr, & + grid%track_old_lon(i),grid%track_old_lat(i), & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe) + if(ierr==0) then + !print *,'insert: i=',iold,' j=',jold,' lon=',grid%track_old_lon(i),' lat=',grid%track_old_lat(i),' t=',grid%track_old_ntsd(i) + call to_rot45_grid(iold,jold,jde,xrot,yrot) + n=n+1 + xsum=xsum+xrot + ysum=ysum+yrot + told=grid%track_old_ntsd(i) + tsum=tsum+told + xtsum=xtsum+xrot*told + xxsum=xxsum+xrot*xrot + ytsum=ytsum+yrot*told + yysum=xxsum+yrot*yrot + ttsum=ttsum+told*told + endif + enddo + !print *,'line guess: n=',n + + if(n>1) then + ntsd_plus_1 = grid%ntsd + grid%movemin*grid%nphs + mx=(xtsum-(xsum*tsum)/real(n))/(ttsum-(tsum*tsum)/real(n)) + my=(ytsum-(ysum*tsum)/real(n))/(ttsum-(tsum*tsum)/real(n)) + bx=(xsum-mx*tsum)/real(n) + by=(ysum-my*tsum)/real(n) + !print *,'mx=',mx,' my=',my,' bx=',bx,' by=',by,' t+1=',ntsd_plus_1 + xrot=nint(mx*ntsd_plus_1+bx) + yrot=nint(my*ntsd_plus_1+by) + call from_rot45_grid(inew,jnew,jde,xrot,yrot) + !print *,'inew=',inew,' jnew=',jnew,' xrot=',xrot,' yrot=',yrot + have_line_guess=.not.(inewide*3/4 & + .or. jnewjde*3/4) + else + have_line_guess=.false. + endif + endif + + print_locs: if(wrf_at_debug_level(2)) then + call get_lonlat(grid,iguess,jguess,longuess,latguess,ierr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe) + if(ierr==0) then + if(have_motion_guess) then +3088 format('Motion Guess: lon=',F0.3,' lat=',F0.3) + write(message,3088) longuess,latguess + call wrf_debug(2,message) + else +3089 format('Motion Guess failed; use domain center: lon=',F0.3,' lat=',F0.3) + write(message,3089) longuess,latguess + call wrf_debug(2,message) + endif + else +3090 format('Motion guess ierr=',I0) + write(message,3090) ierr + call wrf_debug(2,message) + endif + if(have_line_guess) then + call get_lonlat(grid,inew,jnew,longuess,latguess,ierr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe) + if(ierr==0) then +3091 format('Line guess: lon=',F0.3,' lat=',F0.3) + write(message,3091) longuess,latguess + call wrf_debug(2,message) + else +3092 format('Line guess ierr=',I0) + write(message,3092) ierr + call wrf_debug(2,message) + endif + endif + endif print_locs + + if(have_line_guess) then + if(have_motion_guess) then + call wrf_debug(1,'get_first_ges: have MOTION and LINE guesses') + iguess=(iguess+inew)/2 + jguess=(jguess+jnew)/2 + else + call wrf_debug(1,'get_first_ges: have LINE guess only') + iguess=inew + jguess=jnew + endif + elseif(have_motion_guess) then + call wrf_debug(1,'get_first_ges: have MOTION guess only') + else + call wrf_debug(1,'get_first_ges: have no guesses; will use domain center') + endif + + ! Now get lats & lons: + call get_lonlat(grid,iguess,jguess,longuess,latguess,ierr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe) + if(ierr/=0) then + ! Should never get here due to max/min check before. + call wrf_error_fatal("ERROR: domain is not inside the domain in get_first_ges (!?)") + endif + +38 format('First guess: i=',I0,' j=',I0,' lat=',F8.3,' lon=',F8.3) + write(message,38) iguess,jguess,latguess,longuess + call wrf_message(message) + end subroutine get_first_ges + + subroutine store_old_fixes(grid, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE) + ! This stores old fix locations for later use in the get_first_ges + ! routine's line of best fit. + USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid + implicit none + type(domain), intent(inout) :: grid + integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE + integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME + integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE + integer i + if(grid%tracker_havefix) then + !print *,'in store old, have fix' + if(grid%track_n_old>0) then + !print *,'in store old, shifting old' + do i=1,grid%num_old_fixes-1 + grid%track_old_lon(i+1)=grid%track_old_lon(i) + grid%track_old_lat(i+1)=grid%track_old_lat(i) + grid%track_old_ntsd(i+1)=grid%track_old_ntsd(i) + enddo + endif + grid%track_old_lon(1)=grid%tracker_fixlon + grid%track_old_lat(1)=grid%tracker_fixlat + grid%track_old_ntsd(1)=grid%ntsd + grid%track_n_old=min(grid%num_old_fixes,grid%track_n_old+1) + !print *,'in store old, now have ',grid%track_n_old + endif + end subroutine store_old_fixes + + subroutine to_rot45_grid(i,j,jde,x,y) + implicit none + integer, intent(in) :: i,j,jde + real, intent(inout) :: x,y + real :: a,b + a=i*2 + b=j + if(mod(j,2)==0) a=a+1 + x=(a+b)/2 + y=(b-a)/2+((jde-1)/2) + end subroutine to_rot45_grid + + subroutine from_rot45_grid(i,j,jde,x,y) + implicit none + integer, intent(inout) :: i,j + integer, intent(in) :: jde + real, intent(in) :: x,y + i=x-y+((jde-1)/2) + j=x+y-((jde-1)/2) + if(mod(j,2)==0) then + i=(i-1)/2 + else + i=i/2 + endif + end subroutine from_rot45_grid + + subroutine get_nearest_lonlat(grid,iloc,jloc,ierr,lon,lat, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + lonnear, latnear) + ! Finds the nearest point in the domain to the specified lon,lat + ! location. +#ifdef DM_PARALLEL + use module_dm, only: wrf_dm_minloc_real +#endif + USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid + implicit none + type(domain), intent(inout) :: grid + integer, intent(in) :: IDS,IDE,JDS,JDE,KDS,KDE + integer, intent(in) :: IMS,IME,JMS,JME,KMS,KME + integer, intent(in) :: IPS,IPE,JPS,JPE,KPS,KPE + integer, intent(out) :: iloc,jloc,ierr + real, intent(in) :: lon,lat + real :: dx,dy,d,dmin, zdummy, latmin,lonmin + integer :: i,j,imin,jmin + real, intent(out), optional :: latnear, lonnear + + zdummy=42 + dmin=9e9 + imin=-99 + jmin=-99 + latmin=9e9 + lonmin=9e9 + ierr=0 + do j=jps,min(jde-1,jpe) + do i=ips,min(ide-1,ipe) + dy=abs(lat-grid%hlat(i,j)) + dx=abs(mod(3600.+180.+(lon-grid%hlon(i,j)),360.)-180.) + d=dx*dx+dy*dy + if(dlocalextreme) then + localextreme=windsq + locali=i + localj=j + endif + endif + enddo + enddo + if(localextreme>0) localextreme=sqrt(localextreme) + + globalextreme=localextreme + globali=locali + globalj=localj +#ifdef DM_PARALLEL + call wrf_dm_maxval_real(globalextreme,globali,globalj) +#endif - !FIXME: INSERT CODE HERE + call get_lonlat(grid,globali,globalj,globallon,globallat,ierr, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + if(ierr/=0) then + call wrf_message("WARNING: Unable to find location of wind maximum.") + rmw=-99 + else + call calcdist(clon,clat,globallon,globallat,rmw,degrees) + end if ! Get the guess location for the next time: + max_wind=globalextreme + if(globali<0 .or. globalj<0) then + call wrf_message("WARNING: No wind values found that were greater than -9*10^9.") + min_mslp=-999 + endif - end subroutine ntc_impl + end subroutine get_wind_pres_intensity + + subroutine mean_motion(grid,motion_grideast,motion_gridnorth, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) + ! This calculates the mean motion of the storm by calculating the + ! average wind vector at 850, 700 and 500 mbars. + +#ifdef DM_PARALLEL + use module_dm, only: wrf_dm_sum_real8, wrf_dm_sum_integer +#endif + use module_wrf_error + USE MODULE_DOMAIN, ONLY : domain, domain_clock_get + implicit none + integer, intent(in) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + type(domain), intent(in) :: grid + real, intent(out) :: motion_grideast,motion_gridnorth + integer :: count,i,j,ierr + real :: distsq, dist + real*8 :: e,n + + e=0 ; n=0 ; count=0 ! east sum, north sum, count + + dist = min(grid%tracker_edge_dist, max(50e3, 3e3*grid%tracker_rmw)) + distsq = dist * dist + + ! print *,'motion search radius (m) = ',dist + ! print *,' considered edge dist = ',grid%tracker_edge_dist + ! print *,' considered 3e3*rmw = ',3e3*grid%tracker_rmw + ! print *,' considered 50e3.' + + do j=jts,min(jte,jde-1) + do i=its,min(ite,ide-1) + if(grid%tracker_distsq(i,j)90.) then + ylat1=180.-ylat1 + xlon1=mod(xlon1+360.,360.)-180. + elseif(ylat1<-90.) then + ylat1=-180. - ylat1 + xlon1=mod(xlon1+360.,360.)-180. + endif + end subroutine clean_lon_lat + subroutine calcdist(rlonb,rlatb,rlonc,rlatc,xdist,degrees) ! Copied from gettrk_main.f ! @@ -857,11 +1760,11 @@ subroutine calcdist(rlonb,rlatb,rlonc,rlatc,xdist,degrees) ! x circle distance that angle represents. ! / \ ! b/ \ cos(a) = (cos b)(cos c) + (sin b)(sin c)(cos A) - ! / \ + ! / \ . ! pt./<--A-->\c NOTE: The latitude arguments passed to the ! B / \ subr are the actual lat vals, but in ! \ the calculation we use 90-lat. - ! a \ + ! a \ . ! \pt. NOTE: You may get strange results if you: ! C (1) use positive values for SH lats AND ! you try computing distances across the @@ -986,5 +1889,49 @@ subroutine get_lonlat(grid,iguess,jguess,longuess,latguess,ierr, & ierr=95 endif end subroutine get_lonlat + + subroutine update_tracker_post_move(grid) + ! This updates the tracker i/j fix location and square of the + ! distance to the tracker center after a nest move. + USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid + type(domain), intent(inout) :: grid + integer :: ierr, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE + + ! Get the grid bounds: + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + ! Get the i/j center location from the fix location: + ierr=0 + call get_nearest_lonlat(grid,grid%tracker_ifix,grid%tracker_jfix, & + ierr,grid%tracker_fixlon,grid%tracker_fixlat, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE) + + ! Get the square of the approximate distance to the tracker center + ! at all points: + if(ierr==0) & + call get_tracker_distsq(grid, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + IPS,IPE,JPS,JPE,KPS,KPE) + end subroutine update_tracker_post_move #endif end module module_tracker + +#if (HWRF == 1) +subroutine nmm_med_tracker_post_move(grid) + ! This updates the tracker i/j fix location and square of the + ! distance to the tracker center after a nest move. + use module_tracker, only: update_tracker_post_move + use module_domain, only : domain + type(domain), intent(inout) :: grid + call update_tracker_post_move(grid) +end subroutine nmm_med_tracker_post_move +#endif diff --git a/wrfv2_fire/dyn_nmm/nmm_get_cpu.c b/wrfv2_fire/dyn_nmm/nmm_get_cpu.c new file mode 100644 index 00000000..e728b325 --- /dev/null +++ b/wrfv2_fire/dyn_nmm/nmm_get_cpu.c @@ -0,0 +1,20 @@ +#if defined(__linux) && defined(NMM_FIND_LOAD_IMBALANCE) +#define _GNU_SOURCE +#include + +void nmm_get_cpu(int *cpu,int *ierr) { + *cpu=sched_getcpu(); + *ierr = (*cpu>=0); +} +#else +void nmm_get_cpu(int *cpu,int *ierr) { + *cpu=0; + *ierr=0; +} +#endif + +void nmm_get_cpu_(int *c,int*i) { nmm_get_cpu(c,i); } +void nmm_get_cpu__(int *c,int*i) { nmm_get_cpu(c,i); } +void NMM_GET_CPU(int *c,int*i) { nmm_get_cpu(c,i); } +void NMM_GET_CPU_(int *c,int*i) { nmm_get_cpu(c,i); } +void NMM_GET_CPU__(int *c,int*i) { nmm_get_cpu(c,i); } diff --git a/wrfv2_fire/dyn_nmm/solve_nmm.F b/wrfv2_fire/dyn_nmm/solve_nmm.F index eb7009d5..b028e75c 100644 --- a/wrfv2_fire/dyn_nmm/solve_nmm.F +++ b/wrfv2_fire/dyn_nmm/solve_nmm.F @@ -16,7 +16,6 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & use module_timing USE MODULE_DOMAIN, ONLY : DOMAIN, GET_IJK_FROM_GRID & ,domain_clock_get,is_alarm_tstep_nphs - USE MODULE_CONFIGURE, ONLY : GRID_CONFIG_REC_TYPE USE MODULE_MODEL_CONSTANTS USE MODULE_STATE_DESCRIPTION @@ -29,8 +28,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & USE MODULE_COMM_DM #endif #ifdef HWRF + USE MODULE_SWATH, ONLY : UPDATE_INTEREST USE MODULE_HIFREQ, ONLY: HIFREQ_WRITE, HIFREQ_OPEN #endif + USE MODULE_TORNADO_GENESIS, ONLY: CALC_TORNADO_GENESIS, RESET_TORNADO_GENESIS USE MODULE_IGWAVE_ADJUST, ONLY: PDTE,PFDHT,DDAMP,VTOA USE MODULE_ADVECTION, ONLY: ADVE,VAD2,HAD2 & ,ADV2,MONO & @@ -45,9 +46,6 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & USE MODULE_NEST_UTIL ! USEs module_MPP (contains MYPE,NPES,MPI_COMM_COMP) #ifdef MOVE_NESTS USE MODULE_STATS_FOR_MOVE, ONLY: STATS_FOR_MOVE -#endif -#ifdef WRF_CHEM - USE MODULE_INPUT_CHEM_DATA, ONLY: GET_LAST_GAS #endif USE MODULE_DIAG_REFL @@ -80,9 +78,6 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !*** STRUCTURE THAT CONTAINS RUN-TIME CONFIGURATION (NAMELIST) DATA FOR DOMAIN ! TYPE(GRID_CONFIG_REC_TYPE),INTENT(IN) :: CONFIG_FLAGS -#ifdef WRF_CHEM - INTEGER :: NUMGAS -#endif ! !----------------------------------------------------------------------- ! @@ -95,6 +90,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IPS,IPE,JPS,JPE,KPS,KPE & & ,ITS,ITE,JTS,JTE,KTS,KTE ! + LOGICAL :: advect_q2 INTEGER :: I,ICLTEND,IDF,IRTN,J,JC,JDF,K,KDF,LB,N_MOIST & & ,NTSD_current,L #ifdef HWRF @@ -107,6 +103,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !zhang's doing INTEGER,SAVE :: NTSD_restart1,NTSD_restart2,NTSD_restart3 #endif +#endif +#ifdef NMM_FIND_LOAD_IMBALANCE + integer, save :: cpu + integer :: newcpu #endif integer :: ierr,nrand,idt INTEGER,SAVE :: NTSD_restart @@ -147,10 +147,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & &, cucnvc_tim,gsmdrive_tim,hdiff_tim,bocoh_tim & &, pfdht_tim,ddamp_tim,bocov_tim,uv_htov_tim,sum_tim & #ifdef HWRF - &, adjppt_tim,sst_tim,flux_tim -#else - &, adjppt_tim + &, sst_tim,flux_tim,hifreq_tim & #endif + &, diag_tim,adjppt_tim,tornado_tim ! Flag for producing diagnostic fields (e.g., radar reflectivity) LOGICAL :: diag_flag @@ -159,17 +158,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & real,save :: loadimbal_tim,previmbal_tim #endif real,save :: exch_tim_max - real :: btim,btimx + real :: ttim,btimx real :: et_max,this_tim integer :: n_print_time ! -#ifdef RSL - integer rsl_internal_milliclock - external rsl_internal_milliclock -# define timef rsl_internal_milliclock -#else - real*8 :: timef -#endif !----------------------------------------------------------------------- ! !#ifdef DEREF_KLUDGE @@ -190,13 +182,6 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! REAL,SAVE :: SUMDRRW ! -#ifdef WRF_CHEM - REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:,:) :: & ! i,j,k,ks - CHE & ! 4d i,j,k chem tracers - ,CH1 & ! intermediate tracer variable - ,CHP & ! ch1 at previous time level - ,TCC ! time change of tracers -#endif !----------------------------------------------------------------------- ! ! LIMIT THE NUMBER OF ARGUMENTS IF COMPILED WITH -DLIMIT_ARGS BY COPYING @@ -242,6 +227,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !*** !----------------------------------------------------------------------- ! + ttim=now_time() ! used to calculate total time spent in solver CALL DOMAIN_CLOCK_GET(GRID,ADVANCEcOUNT=NTSD_current) ! IF(NTSD_current==0)THEN @@ -299,10 +285,15 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! ! Set diagnostic flag value at history output time !----------------------------------------------------------------------------- - diag_flag = .false. - if ( Is_alarm_tstep_nphs(grid%domain_clock, grid%alarms(HISTORY_ALARM), grid%nphs) ) then - diag_flag = .true. - endif + + diag_flag = & + is_alarm_tstep_nphs(grid%domain_clock, grid%alarms(HISTORY_ALARM), grid%nphs) & + .or. & + is_alarm_tstep_nphs(grid%domain_clock, grid%alarms(AUXHIST1_ALARM), grid%nphs) & + .or. & + is_alarm_tstep_nphs(grid%domain_clock, grid%alarms(AUXHIST2_ALARM), grid%nphs) & + .or. & + is_alarm_tstep_nphs(grid%domain_clock, grid%alarms(AUXHIST3_ALARM), grid%nphs) ! !----------------------------------------------------------------------- @@ -348,14 +339,18 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ETAMP_PHYSICS=.FALSE. ! IF (CONFIG_FLAGS%MP_PHYSICS == ETAMPNEW .OR. & - & CONFIG_FLAGS%MP_PHYSICS == ETAMPOLD .OR. & + & CONFIG_FLAGS%MP_PHYSICS == ETAMP_HR .OR. & & CONFIG_FLAGS%MP_PHYSICS == ETAMP_HWRF ) THEN ! ETAMP_PHYSICS=.TRUE. ! ENDIF - + ADVECT_Q2=.TRUE. + if(CONFIG_FLAGS%BL_PBL_PHYSICS == GFSSCHEME .OR. & + CONFIG_FLAGS%BL_PBL_PHYSICS == GFS2011SCHEME) THEN + ADVECT_Q2=.FALSE. + endif ! !----------------------------------------------------------------------- @@ -388,9 +383,6 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ALLOCATE(RTHBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT) ALLOCATE(RQVBLTEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT) ALLOCATE(RTHRATEN(IMS:IME,KMS:KME,JMS:JME),STAT=ISTAT) -#ifdef WRF_CHEM - NUMGAS = GET_LAST_GAS(CONFIG_FLAGS%CHEM_OPT) -#endif ! IF(CONFIG_FLAGS%CU_PHYSICS==GDSCHEME.OR. & & CONFIG_FLAGS%CU_PHYSICS==TIEDTKESCHEME.OR. & @@ -439,18 +431,13 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & write(message,*)' kts=',kts,' kte=',kte call wrf_message(trim(message)) ! -#ifdef WRF_CHEM - ALLOCATE (CHE(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT) - ALLOCATE (CH1(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT) - ALLOCATE (CHP(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT) - ALLOCATE (TCC(IMS:IME,JMS:JME,KMS:KME,1:NUM_CHEM),STAT=ISTAT) -#endif !----------------------------------------------------------------------- endif !----------------------------------------------------------------------- !*** SET TIMING VARIABLES TO ZERO AT START OF FORECAST. !----------------------------------------------------------------------- if(grid%ntsd==0)then + sum_tim=0. solve_tim=0. exch_tim=0. pdte_tim=0. @@ -475,16 +462,31 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & uv_htov_tim=0. exch_tim_max=0. adjppt_tim=0. + diag_tim=0. + tornado_tim=0. +#ifdef HWRF + sst_tim=0. + flux_tim=0. + hifreq_tim=0. +#endif #ifdef NMM_FIND_LOAD_IMBALANCE previmbal_tim=0. loadimbal_tim=0. + call nmm_get_cpu(cpu,ierr) #endif endif !----------------------------------------------------------------------- N_MOIST=NUM_MOIST #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(previmbal_tim) + call blockf(previmbal_tim,'top of solve_nmm') + call nmm_get_cpu(newcpu,ierr) + if(cpu/=newcpu) then +3011 format('warning: CPU changed from ',I0,' to ',I0) + write(message,3011) cpu,newcpu + call wrf_message(message) + cpu=newcpu + endif #endif ! DO J=MYJS_P4,MYJE_P4 @@ -507,8 +509,8 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! !*** APPROXIMATE GRIDPOINT SPACING (METERS) ! - JC=JMS+(JME-JMS)/2 - GPS=SQRT(grid%dx_nmm(IMS,JC)**2+grid%dy_nmm**2) + JC=jps+(jpe-jps)/2 + GPS=SQRT(grid%dx_nmm(ips,JC)**2+grid%dy_nmm**2) ! !*** TIMESTEPS PER HOUR ! @@ -528,9 +530,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! CALL wrf_debug ( 100 , 'nmm: in patch' ) #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after alloc and init') #endif - btimx=timef() + btimx=now_time() !#ifdef DM_PARALLEL !# include "HALO_NMM_ZZ.inc" !#endif @@ -578,7 +580,6 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ENDIF !----------------------------------------------------------------------- ! - btim=timef() ! !----------------------------------------------------------------------- !*** UPDATE RANDOM NUMBERS IF REQUIRED @@ -615,6 +616,23 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ENDIF ! for IF(IDT.EQ.0 .OR. NTSD .EQ. 0) ENDIF randif !----------------------------------------------------------------------- +!*** RESET TORNADO GENESIS ACCUMULATORS WHEN NEEDED. +!----------------------------------------------------------------------- + IF(grid%tg_want_reset/=0) THEN + btimx=now_time() + CALL RESET_TORNADO_GENESIS(GRID,CONFIG_FLAGS) + tornado_tim=tornado_tim+now_time()-btimx + ENDIF +!----------------------------------------------------------------------- +!*** UPDATE AREA OF INTEREST +!----------------------------------------------------------------------- +#ifdef HWRF + if(size(grid%precip_swath)>1 .and. grid%update_interest) then + call update_interest(grid,config_flags) + grid%update_interest=.false. + endif +#endif +!----------------------------------------------------------------------- !*** ZERO OUT ACCUMULATED QUANTITIES WHEN NEEDED. !----------------------------------------------------------------------- ! @@ -645,9 +663,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & FIRST=.TRUE. ! call hpm_init() #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'before halo & init stuff') #endif - btimx=timef() + btimx=now_time() !emc_2010_bugfix_h50 grid%mommix=amin1(grid%mommix,1.0) !emc_2010_bugfix_h50 @@ -691,25 +709,6 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! !----------------------------------------------------------------------- ! -#ifdef WRF_CHEM - DO KS=1,NUM_CHEM - DO K=KMS,KME - DO J=JMS,JME - DO I=IMS,IME - CHE(I,J,K,KS)=0. - CH1(I,J,K,KS)=0. - CHP(I,J,K,KS)=0. - TCC(I,J,K,KS)=0. - ENDDO - ENDDO - ENDDO - ENDDO -#endif -! -!----------------------------------------------------------------------- -#ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) -#endif #ifdef DM_PARALLEL # include "HALO_NMM_A.inc" #endif @@ -753,34 +752,13 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ENDIF ! !----------------------------------------------------------------------- -! -#ifdef WRF_CHEM - DO KS=1,NUM_CHEM - DO K=KMS,KME - DO J=JMS,JME - DO I=IMS,IME - CHP(I,J,K,KS)=SQRT(MAX(CHEM(I,K,J,KS),0. )) - ENDDO - ENDDO - ENDDO - ENDDO -#endif -! -!----------------------------------------------------------------------- -! -!*** Only for chemistry: -! -#ifdef WRF_CHEM -#ifdef DM_PARALLEL -# include "HALO_NMM_A_2.inc" -#endif -#endif -! -!----------------------------------------------------------------------- !*** USE THE FOLLOWING VARIABLES TO KEEP TRACK OF EXCHANGE TIMES. !----------------------------------------------------------------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo and init stuff') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max @@ -810,12 +788,14 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & call wrf_message(trim(message)) #else ! Coupling insertion:-> + btimx=now_time() call ATM_TSTEP_INIT(NTSD_current,grid%NPHS,GRID%ID,grid%NPHS*grid%dt, & ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme, & kds,kde,kts,kte,kms,kme, & grid%HLON,grid%HLAT,grid%VLON,grid%VLAT,grid%sm, & grid%i_parent_start,grid%j_parent_start, & grid%guessdtc,grid%dtc) + sst_tim=sst_tim+now_time()-btimx !<-:coupling insertion ! #endif @@ -825,22 +805,29 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !----------------------------------------------------------------------- ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after atm_tstep_init') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_D.inc" #endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo d') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! - btimx=timef() + btimx=now_time() ! + call check_grid(grid,config_flags,'before PDTE', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL PDTE( & #ifdef DM_PARALLEL & GRID,MYPE,MPI_COMM_COMP, & @@ -854,29 +841,36 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,ITS,ITE,JTS,JTE,KTS,KTE) - pdte_tim=pdte_tim+timef()-btimx + pdte_tim=pdte_tim+now_time()-btimx ! !----------------------------------------------------------------------- !*** ADVECTION OF grid%t, grid%u, AND grid%v !----------------------------------------------------------------------- ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after pdte') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_F.inc" # include "HALO_NMM_F1.inc" #endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo F & F1') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max - btimx=timef() + btimx=now_time() ! + call check_grid(grid,config_flags,'before ADVE', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL ADVE(grid%ntsd,GRID%DT,grid%deta1,grid%deta2,grid%pdtop & & ,grid%curv,grid%f,grid%fad,grid%f4d,grid%em_loc,grid%emt_loc,grid%en,grid%ent,grid%dx_nmm,grid%dy_nmm & & ,grid%hbm2,grid%vbm2 & @@ -892,7 +886,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! - adve_tim=adve_tim+timef()-btimx + adve_tim=adve_tim+now_time()-btimx ! !----------------------------------------------------------------------- !*** PASSIVE SUBSTANCE WORKING PART @@ -912,15 +906,18 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & idtadt_block: IF(MOD(grid%ntsd,IDTADT)==0) THEN !----------------------------------------------------------------------- #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after adve') #endif - btimx=timef() + btimx=now_time() #ifdef DM_PARALLEL # include "HALO_NMM_I.inc" #endif - exch_tim=exch_tim+timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo I') +#endif ! - btimx=timef() + btimx=now_time() ! DO K=KTS,KTE DO J=JMS,JME @@ -949,6 +946,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & #ifdef DM_PARALLEL # include "HALO_TRACERS.inc" #endif + call check_grid(grid,config_flags,'before ADV2', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL ADV2 & (grid%upstrm & ,MYPE,PARAM_FIRST_SCALAR,NUM_SZJ & @@ -974,6 +975,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & #ifdef DM_PARALLEL # include "HALO_TRACERS.inc" #endif + call check_grid(grid,config_flags,'before MONO', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL MONO & ( & #if defined(DM_PARALLEL) @@ -1083,7 +1088,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ENDDO ENDIF ! - had2_tim=had2_tim+timef()-btimx + had2_tim=had2_tim+now_time()-btimx !----------------------------------------------------------------------- ! ENDIF idtadt_block @@ -1094,96 +1099,17 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! !----------------------------------------------------------------------- ! -#ifdef WRF_CHEM -!----------------------------------------------------------------------- -! - idtadc_block: IF(MOD(grid%ntsd,IDTADC)==0) THEN -! -!----------------------------------------------------------------------- -#ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) -#endif - btimx=timef() -#ifdef DM_PARALLEL -# include "HALO_NMM_I_2.inc" -#endif - exch_tim=exch_tim+timef()-btimx -! - btimx=timef() -! - do KS=1,NUM_CHEM - DO K=KTS,KTE - DO J=JMS,JME - DO I=IMS,IME - CHE(I,J,K,KS)=MAX(CHEM(I,K,J,KS),0. ) - ENDDO - ENDDO - ENDDO - ENDDO -! - CALL ADV2 & - (grid%upstrm & - ,MYPE,1,NUM_CHEM & - ,IDS,IDE,JDS,JDE,KDS,KDE & - ,IMS,IME,JMS,JME,KMS,KME & - ,ITS,ITE,JTS,JTE,KTS,KTE & - ,grid%n_iup_h & - ,grid%n_iup_adh & - ,grid%iup_h,grid%iup_adh & - ,grid%ent & - ,IDTADC & - ,grid%DT,grid%pdtop & - ,grid%ihe,grid%ihw,grid%ive,grid%ivw & - ,grid%deta1,grid%deta2 & - ,grid%emt_loc & - ,grid%fad,grid%hbm2,grid%pdsl,grid%pdslo & - ,grid%petdt & - ,grid%uold,grid%vold & - ,CHE,CHP & - !temporary arguments - ,grid%fne,grid%fse,grid%few,grid%fns,CH1,TCC) -! - CALL MONO & - ( & -#if defined(DM_PARALLEL) - GRID%DOMDESC, & -#endif - MYPE,grid%ntsd,grid%ntsd*GRID%DT/3600.,1,NUM_CHEM & - ,IDS,IDE,JDS,JDE,KDS,KDE & - ,IMS,IME,JMS,JME,KMS,KME & - ,ITS,ITE,JTS,JTE,KTS,KTE & - ,IDTADT & - ,grid%dy_nmm,grid%pdtop & - ,SUMDRRW & - ,grid%ihe,grid%ihw & - ,grid%deta1,grid%deta2 & - ,grid%dx_nmm,grid%hbm2,grid%pdsl & - ,CHE & - !temporary arguments - ,CH1,TCC) -! - DO KS=1,NUM_CHEM - DO K=KTS,KTE - DO J=JMS,JME - DO I=IMS,IME - CHEM(I,K,J,KS)=CHE(I,J,K,KS)+TCC(I,J,K,KS) - ENDDO - ENDDO - ENDDO - ENDDO -!----------------------------------------------------------------------- -! - ENDIF idtadc_block -! -!----------------------------------------------------------------------- -#endif ! !----------------------------------------------------------------------- !*** PRESSURE TENDENCY, ETA/SIGMADOT, VERTICAL PART OF OMEGA-ALPHA TERM !----------------------------------------------------------------------- ! - btimx=timef() + btimx=now_time() ! + call check_grid(grid,config_flags,'before VTOA', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL VTOA( & & grid%ntsd,GRID%DT,grid%pt,grid%eta2 & & ,grid%hbm2,grid%ef4t & @@ -1194,17 +1120,21 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! - vtoa_tim=vtoa_tim+timef()-btimx + vtoa_tim=vtoa_tim+now_time()-btimx ! !----------------------------------------------------------------------- !*** VERTICAL ADVECTION OF HEIGHT !----------------------------------------------------------------------- ! - btimx=timef() + btimx=now_time() ! + call check_grid(grid,config_flags,'before VADZ', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL VADZ(grid%ntsd,GRID%DT,grid%fis,GRID%SIGMA,grid%dfl,grid%hbm2 & & ,grid%deta1,grid%deta2,grid%pdtop & & ,grid%pint,grid%pdsl,grid%pdslo,grid%petdt & @@ -1214,29 +1144,36 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) - vadz_tim=vadz_tim+timef()-btimx + vadz_tim=vadz_tim+now_time()-btimx ! !----------------------------------------------------------------------- !*** HORIZONTAL ADVECTION OF HEIGHT !----------------------------------------------------------------------- ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after vadz') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_G.inc" #endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo G') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! - btimx=timef() + btimx=now_time() ! + call check_grid(grid,config_flags,'before HADZ', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL HADZ(grid%ntsd,GRID%DT,grid%hydro,grid%hbm2,grid%deta1,grid%deta2,grid%pdtop & & ,grid%dx_nmm,grid%dy_nmm,grid%fad & & ,grid%few,grid%fns,grid%fne,grid%fse & @@ -1246,29 +1183,36 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! - hadz_tim=hadz_tim+timef()-btimx + hadz_tim=hadz_tim+now_time()-btimx ! !----------------------------------------------------------------------- !*** ADVECTION OF grid%w !----------------------------------------------------------------------- ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after hadz') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_H.inc" #endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo H') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! - btimx=timef() + btimx=now_time() ! + call check_grid(grid,config_flags,'before EPS', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL EPS(grid%ntsd,GRID%DT,grid%hydro,grid%dx_nmm,grid%dy_nmm,grid%fad & & ,grid%aeta1,grid%deta1,grid%deta2,grid%pdtop,grid%pt & @@ -1284,7 +1228,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! - eps_tim=eps_tim+timef()-btimx + eps_tim=eps_tim+now_time()-btimx ! !----------------------------------------------------------------------- ! @@ -1294,8 +1238,12 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !*** VERTICAL ADVECTION OF grid%q, TKE, AND CLOUD WATER !----------------------------------------------------------------------- ! + call check_grid(grid,config_flags,'before VAD2', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) IF(MOD(grid%ntsd,GRID%IDTAD)==0)THEN - btimx=timef() + btimx=now_time() ! vad2_micro_check: IF (ETAMP_PHYSICS) THEN CALL VAD2(grid%ntsd,GRID%DT,GRID%IDTAD,grid%dx_nmm,grid%dy_nmm & @@ -1360,7 +1308,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! ENDIF vad2_micro_check ! - vad2_tim=vad2_tim+timef()-btimx + vad2_tim=vad2_tim+now_time()-btimx ! ENDIF ! @@ -1370,9 +1318,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! idtad_block: IF(MOD(grid%ntsd,GRID%IDTAD)==0)THEN #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after vad2') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_I.inc" @@ -1385,15 +1333,22 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & #endif ! !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo I & I3') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! - btimx=timef() + btimx=now_time() ! !----------------------------------------------------------------------- + call check_grid(grid,config_flags,'before HAD2', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) had2_micro_check: IF (ETAMP_PHYSICS) THEN !----------------------------------------------------------------------- ! @@ -1409,6 +1364,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,grid%n_iup_adh,grid%n_iup_adv & & ,grid%iup_h,grid%iup_v,grid%iup_adh,grid%iup_adv & & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & + & ,advect_Q2 & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) @@ -1535,7 +1491,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !----------------------------------------------------------------------- ENDIF had2_micro_check !----------------------------------------------------------------------- - had2_tim=had2_tim+timef()-btimx + had2_tim=had2_tim+now_time()-btimx !----------------------------------------------------------------------- ! ENDIF idtad_block @@ -1571,10 +1527,14 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !emc_2010_bugfix_h50 #endif + call check_grid(grid,config_flags,'before RADIATION', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) IF(MOD(NTSD_rad,GRID%NRADS)==0.OR. & & MOD(NTSD_rad,GRID%NRADL)==0)THEN ! - btimx=timef() + btimx=now_time() IF(OPERATIONAL_PHYSICS)THEN CALL UPDATE_MOIST(MOIST,grid%q,grid%cwm,grid%f_ice,grid%f_rain,N_MOIST & & ,IDS,IDF,JDS,JDF,KDS,KDE & @@ -1611,40 +1571,52 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,grid%ACLWUPB,grid%ACLWUPBC,grid%ACLWDNB,grid%ACLWDNBC & & ,grid%swvisdir ,grid%swvisdif & !ssib & ,grid%swnirdir ,grid%swnirdif & !ssib -#ifdef WRF_CHEM - & ,PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC & - & ,TAUAER1, TAUAER2, TAUAER3, TAUAER4 & - & ,GAER1, GAER2, GAER3, GAER4 & - & ,WAER1, WAER2, WAER3, WAER4 & -#endif & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! - DO J=JMS,JME - DO I=IMS,IME + DO J=jts,min(jde-1,jte) + DO I=its,min(ide-1,ite) grid%gsw(I,J)=grid%rswin(I,J)-grid%rswout(I,J) ENDDO ENDDO +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after rad') +#endif + btimx=now_time() +!----------------- +#ifdef DM_PARALLEL +# include "HALO_NMM_RAD.inc" +#endif +!----------------- + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after rad halo') +#endif + ! ! *** NOTE *** ! grid%rlwin/grid%rswin - downward longwave/shortwave at the surface (formerly TOTLWDN/TOTSWDN) ! grid%rswinc - CLEAR-SKY downward shortwave at the surface (new for AQ) ! *** NOTE *** ! - radiation_tim=radiation_tim+timef()-btimx + radiation_tim=radiation_tim+now_time()-btimx ENDIF ! !---------------------------------------------------------------------- !*** APPLY TEMPERATURE TENDENCY DUE TO RADIATION !---------------------------------------------------------------------- ! - btimx=timef() + btimx=now_time() ! ! Pass in XTIME (elapsed time from start of parent) to compute ! the time passed into the zenith angle code consistently between ! RDTEMP and RADIATION. + call check_grid(grid,config_flags,'before RDTEMP', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL RDTEMP(grid%ntsd,GRID%DT,GRID%JULDAY,GRID%JULYR & & ,GRID%XTIME,IHRST,grid%glat,grid%glon & & ,grid%czen,grid%czmean,grid%t,grid%rswtt,grid%rlwtt,grid%hbm2 & @@ -1652,7 +1624,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! - rdtemp_tim=rdtemp_tim+timef()-btimx + rdtemp_tim=rdtemp_tim+now_time()-btimx ! ! #ifdef HWRF @@ -1665,13 +1637,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & call wrf_message(trim(message)) #else ! Coupling insertion:-> + btimx=now_time() CALL ATM_GETSST(grid%sst,grid%sm) + sst_tim=sst_tim+now_time()-btimx !<-:Coupling insertion - IF(GRID%ID .EQ. 1 .AND. MOD(grid%ntsd,grid%NPHS)==0)THEN - btimx=timef() - sst_tim=sst_tim+timef()-btimx - ENDIF - #endif #endif !---------------------------------------------------------------------- @@ -1680,7 +1649,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! IF(MOD(grid%ntsd,GRID%NPHS)==0)THEN ! - btimx=timef() + btimx=now_time() ! IF(OPERATIONAL_PHYSICS & & .AND.MOD(NTSD_rad,GRID%NRADS)/=0 & @@ -1691,6 +1660,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,ITS,ITE,JTS,JTE,KTS,KTE) ENDIF ! + call check_grid(grid,config_flags,'before TURBL', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL TURBL(grid%ntsd,GRID%DT,GRID%NPHS,RESTRT & & ,N_MOIST,GRID%NUM_SOIL_LAYERS,grid%sldpth,grid%dzsoil & & ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2,grid%pdtop,grid%pt & @@ -1744,7 +1717,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! grid%rlwin/grid%rswin - downward longwave/shortwave at the surface ! *** NOTE *** ! - turbl_tim=turbl_tim+timef()-btimx + turbl_tim=turbl_tim+now_time()-btimx #ifdef HWRF @@ -1771,23 +1744,25 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & call wrf_message(trim(message)) #else ! Coupling insertion:-> + btimx=now_time() call ATM_DOFLUXES(grid%twbs,grid%qwbs,grid%rlwin,grid%rswin,grid%radot,grid%rswout, & - grid%taux,grid%tauy,grid%pint(:,:,1),grid%prec,grid%u10,grid%v10) + grid%taux,grid%tauy,grid%pint,grid%prec,grid%u10,grid%v10) + flux_tim=flux_tim+now_time()-btimx !<-:Coupling insertion ! IF(GRID%ID .EQ. 1 .AND. MOD(grid%ntsd,grid%NPHS)==0)THEN - btimx=timef() - flux_tim=flux_tim+timef()-btimx + btimx=now_time() + flux_tim=flux_tim+now_time()-btimx ENDIF #endif #endif ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after atm_dofluxes') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_TURBL_A.inc" @@ -1797,30 +1772,33 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & # include "HALO_NMM_TURBL_B.inc" #endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo TURBL A & B') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! !*** INTERPOLATE WINDS FROM H POINTS BACK TO grid%v POINTS. ! - btimx=timef() + btimx=now_time() CALL UV_H_TO_V(grid%ntsd,GRID%DT,GRID%NPHS,grid%uz0h,grid%vz0h,grid%uz0,grid%vz0 & & ,grid%dudt,grid%dvdt,grid%u,grid%v,grid%hbm2,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) - uv_htov_tim=uv_htov_tim+timef()-btimx + uv_htov_tim=uv_htov_tim+now_time()-btimx ! !---------------------------------------------------------------------- !*** STORE ORIGINAL TEMPERATURE ARRAY !---------------------------------------------------------------------- ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after uv_h_to_v') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_J.inc" @@ -1832,27 +1810,29 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ENDIF #endif ! -#ifdef WRF_CHEM -#ifdef DM_PARALLEL -# include "HALO_NMM_J_2.inc" -#endif -#endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo J, J2 & J3') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! ICLTEND=-1 - btimx=timef() + btimx=now_time() ! + call check_grid(grid,config_flags,'before CLTEND', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL CLTEND(ICLTEND,GRID%NPHS,grid%t,grid%t_old,grid%t_adj & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! - cltend_tim=cltend_tim+timef()-btimx + cltend_tim=cltend_tim+now_time()-btimx ENDIF ! !---------------------------------------------------------------------- @@ -1867,23 +1847,26 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & CONFIG_FLAGS%CU_PHYSICS.eq.SASSCHEME))THEN ! ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after cltend') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_C.inc" #endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo C') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ENDIF ! convection: IF(CONFIG_FLAGS%CU_PHYSICS/=0)THEN - btimx=timef() + btimx=now_time() ! !*** GET TENDENCIES FOR GD SCHEME. ! @@ -1916,6 +1899,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !---------------------------------------------------------------------- call wrf_message('call cucnvc') call start_timing + call check_grid(grid,config_flags,'before CUCNVC', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL CUCNVC(grid%ntsd,GRID%DT,GRID%NCNVC,GRID%NRADS,GRID%NRADL & & ,GPS,RESTRT,grid%hydro,grid%cldefi,N_MOIST,GRID%ENSDIM & & ,MOIST & @@ -1928,9 +1915,6 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,grid%mass_flux,grid%xf_ens & & ,grid%pr_ens,grid%gsw & & ,grid%GD_CLOUD,grid%GD_CLOUD2,grid%ktop_deep & -#ifdef WRF_CHEM - & ,RAINCV & -#endif & ,grid%pdtop,grid%pt,grid%pd,grid%res,grid%pint,grid%t,grid%q,grid%cwm,grid%tcucn & & ,grid%omgalf,grid%u,grid%v,grid%w,grid%z,grid%fis,grid%w0avg & & ,grid%prec,grid%acprec,grid%cuprec,grid%cuppt,grid%cprate & @@ -1948,10 +1932,14 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IMS,IME,JMS,JME,KMS,KME & & ,IPS,IPE,JPS,JPE,KPS,KPE & & ,ITS,ITE,JTS,JTE,KTS,KTE) + call check_grid(grid,config_flags,'after CUCNVC', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) call end_timing('cucnvc') !---------------------------------------------------------------------- ! - cucnvc_tim=cucnvc_tim+timef()-btimx + cucnvc_tim=cucnvc_tim+now_time()-btimx ! @@ -1972,9 +1960,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !emc_2010_bugfix_h50 ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after cucnvc') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_SAS_A.inc" @@ -1984,12 +1972,15 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & # include "HALO_NMM_SAS_B.inc" #endif !----------------- - exch_tim=exch_tim+timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo SAS A & B') +#endif ! !*** INTERPOLATE WINDS FROM H POINTS BACK TO V POINTS AFTER SAS ! - btimx=timef() + btimx=now_time() !emc_2010_bugfix_h50 CALL UV_H_TO_V(grid%NTSD,GRID%DT,GRID%NCNVC,grid%UZ0H,grid%VZ0H,grid%UZ0,grid%VZ0 & @@ -1997,7 +1988,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) - uv_htov_tim=uv_htov_tim+timef()-btimx + uv_htov_tim=uv_htov_tim+now_time()-btimx !emc_2010_bugfix_h50 ENDIF ! for SAS only @@ -2012,8 +2003,12 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !---------------------------------------------------------------------- ! IF(MOD(grid%ntsd,GRID%NPHS)==0)THEN - btimx=timef() + btimx=now_time() ! + call check_grid(grid,config_flags,'before GSMDRIVE', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL GSMDRIVE(grid%ntsd,GRID%DT,GRID%NPHS,N_MOIST & & ,grid%dx_nmm(ITS,JC),GRID%DY,grid%sm,grid%hbm2,grid%fis & & ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2 & @@ -2031,15 +2026,19 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) + call check_grid(grid,config_flags,'after GSMDRIVE', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) ! - gsmdrive_tim=gsmdrive_tim+timef()-btimx + gsmdrive_tim=gsmdrive_tim+now_time()-btimx ! !----------------------------------------------------------------------- !---------PRECIPITATION ASSIMILATION------------------------------------ !----------------------------------------------------------------------- ! IF (GRID%PCPFLG) THEN - btimx=timef() + btimx=now_time() ! CALL CHKSNOW(grid%ntsd,GRID%DT,GRID%NPHS,grid%sr,PPTDAT & & ,IDS,IDE,JDS,JDE,KDS,KDE & @@ -2050,7 +2049,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! - adjppt_tim=adjppt_tim+timef()-btimx + adjppt_tim=adjppt_tim+now_time()-btimx ENDIF ! !---------------------------------------------------------------------- @@ -2058,14 +2057,14 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !---------------------------------------------------------------------- ! ICLTEND=0 - btimx=timef() + btimx=now_time() ! CALL CLTEND(ICLTEND,GRID%NPHS,grid%t,grid%t_old,grid%t_adj & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! - cltend_tim=cltend_tim+timef()-btimx + cltend_tim=cltend_tim+now_time()-btimx ENDIF ! !---------------------------------------------------------------------- @@ -2073,35 +2072,38 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !---------------------------------------------------------------------- ! ICLTEND=1 - btimx=timef() + btimx=now_time() ! CALL CLTEND(ICLTEND,GRID%NPHS,grid%t,grid%t_old,grid%t_adj & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! - cltend_tim=cltend_tim+timef()-btimx + cltend_tim=cltend_tim+now_time()-btimx ! !---------------------------------------------------------------------- !*** LATERAL DIFFUSION !---------------------------------------------------------------------- ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after GSMDRIVE and a few other things') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_K.inc" #endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo K') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! - btimx=timef() + btimx=now_time() ! CALL HDIFF(grid%ntsd,GRID%DT,grid%fis,grid%dy_nmm,grid%hdac,grid%hdacv & & ,grid%hbm2,grid%deta1,GRID%SIGMA & @@ -2117,6 +2119,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) ! + call check_grid(grid,config_flags,'after HDIFF', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) IF(.NOT.OPERATIONAL_PHYSICS)THEN DO K=KTS,KTE DO J=MYJS,MYJE @@ -2128,16 +2134,16 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ENDDO ENDIF ! - hdiff_tim=hdiff_tim+timef()-btimx + hdiff_tim=hdiff_tim+now_time()-btimx ! !---------------------------------------------------------------------- !*** UPDATING BOUNDARY VALUES AT HEIGHT POINTS !---------------------------------------------------------------------- ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after hdiff') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_L.inc" @@ -2147,20 +2153,22 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & # include "HALO_NMM_L_3.inc" #endif ! -#ifdef WRF_CHEM -#ifdef DM_PARALLEL -# include "HALO_NMM_L_2.inc" -#endif -#endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo L, L2 & L3') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! - btimx=timef() + btimx=now_time() ! + call check_grid(grid,config_flags,'before mass_boundary', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL MASS_BOUNDARY(GRID%ID,grid%ntsd,GRID%DT,NEST,NUNIT_NBC,NBOCO,LAST_TIME,TSPH & & ,LB,grid%eta1,grid%eta2,grid%pdtop,grid%pt,grid%res & & ,grid%PD_BXS,grid%PD_BXE,grid%PD_BYS,grid%PD_BYE,grid%T_BXS,grid%T_BXE,grid%T_BYS,grid%T_BYE & @@ -2171,14 +2179,15 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,grid%Q_BTYS,grid%Q_BTYE,grid%U_BTXS,grid%U_BTXE,grid%U_BTYS,grid%U_BTYE,grid%V_BTXS & & ,grid%V_BTXE,grid%V_BTYS,grid%V_BTYE,grid%Q2_BTXS,grid%Q2_BTXE,grid%Q2_BTYS,grid%Q2_BTYE & & ,grid%pd,grid%t,grid%q,grid%q2,grid%pint & -#ifdef WRF_CHEM - & ,CHEM,NUMGAS,CONFIG_FLAGS & -#endif & ,GRID%SPEC_BDY_WIDTH,grid%z & & ,grid%ihe,grid%ihw,grid%ive,grid%ivw & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) + call check_grid(grid,config_flags,'after MASS_BOUNDARY', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) #if (NMM_NEST==1) if(ETAMP_PHYSICS) then #endif @@ -2208,8 +2217,12 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & its,ite,jts,jte,kts,kte) endif #endif + call check_grid(grid,config_flags,'after boundaries', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) ! - bocoh_tim=bocoh_tim+timef()-btimx + bocoh_tim=bocoh_tim+now_time()-btimx ! if(mod(grid%ntsd,n_print_time)==0)then ! call twr(grid%t,0,'grid%t',grid%ntsd,mype,npes,mpi_comm_comp & ! & ,ids,ide,jds,jde,kds,kde & @@ -2228,9 +2241,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !---------------------------------------------------------------------- ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after h bdy') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_A.inc" @@ -2242,20 +2255,22 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ENDIF #endif ! -#ifdef WRF_CHEM -#ifdef DM_PARALLEL -# include "HALO_NMM_A_2.inc" -#endif -#endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo A, A2 and A3 after h bdy') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! - btimx=timef() + btimx=now_time() ! + call check_grid(grid,config_flags,'before PFDHT', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL PFDHT(grid%ntsd,LAST_TIME,grid%pt,grid%deta1,grid%deta2,grid%pdtop,grid%res,grid%fis & & ,grid%hydro,GRID%SIGMA,FIRST,grid%dx_nmm,grid%dy_nmm & & ,grid%hbm2,grid%vbm2,grid%vbm3 & @@ -2266,31 +2281,42 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) + call check_grid(grid,config_flags,'after PFDHT', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) ! - pfdht_tim=pfdht_tim+timef()-btimx + pfdht_tim=pfdht_tim+now_time()-btimx ! !---------------------------------------------------------------------- !*** DIVERGENCE DAMPING !---------------------------------------------------------------------- ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after pfdht') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_B.inc" #endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo B after pfdht') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! - btimx=timef() + btimx=now_time() ! + call check_grid(grid,config_flags,'before DDAMP', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL DDAMP(grid%ntsd,GRID%DT,grid%deta1,grid%deta2,grid%pdsl & & ,grid%pdtop,grid%div,grid%hbm2 & & ,grid%t,grid%u,grid%v,grid%ddmpu,grid%ddmpv & @@ -2298,8 +2324,12 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) + call check_grid(grid,config_flags,'after DDAMP', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) ! - ddamp_tim=ddamp_tim+timef()-btimx + ddamp_tim=ddamp_tim+now_time()-btimx ! !---------------------------------------------------------------------- !---------------------------------------------------------------------- @@ -2307,21 +2337,19 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & IF(FIRST.AND.grid%ntsd==0)THEN FIRST=.FALSE. #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after ddamp') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_A.inc" #endif -#ifdef WRF_CHEM -#ifdef DM_PARALLEL -# include "HALO_NMM_A_2.inc" -#endif -#endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo A & A2 after ddamp') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max @@ -2334,21 +2362,24 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !---------------------------------------------------------------------- ! #ifdef NMM_FIND_LOAD_IMBALANCE - call blockf(loadimbal_tim) + call blockf(loadimbal_tim,'after ddamp again') #endif - btimx=timef() + btimx=now_time() !----------------- #ifdef DM_PARALLEL # include "HALO_NMM_C.inc" #endif !----------------- - exch_tim=exch_tim+timef()-btimx -! this_tim=timef()-btimx + exch_tim=exch_tim+now_time()-btimx +#ifdef NMM_FIND_LOAD_IMBALANCE + call blockf(loadimbal_tim,'after halo C after ddamp') +#endif +! this_tim=now_time()-btimx ! call mpi_allreduce(this_tim,et_max,1,mpi_real,mpi_max & ! & ,mpi_comm_comp,irtn) ! exch_tim_max=exch_tim_max+et_max ! - btimx=timef() + btimx=now_time() ! CALL BOCOV(GRID%ID,grid%ntsd,GRID%DT,LB,grid%U_BXS,grid%U_BXE,grid%U_BYS,grid%U_BYE,grid%V_BXS & & ,grid%V_BXE,grid%V_BYS,grid%V_BYE,grid%U_BTXS,grid%U_BTXE,grid%U_BTYS,grid%U_BTYE,grid%V_BTXS & @@ -2360,7 +2391,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,ITS,ITE,JTS,JTE,KTS,KTE ) ! - bocov_tim=bocov_tim+timef()-btimx + bocov_tim=bocov_tim+now_time()-btimx ! !---------------------------------------------------------------------- !*** COPY THE NMM VARIABLE grid%q2 TO THE WRF VARIABLE grid%tke_pbl @@ -2373,10 +2404,16 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ENDDO ENDDO ENDDO + ! calculate some model diagnostics. + IF ( config_flags%compute_radar_ref .EQ. 1 ) THEN CALL wrf_debug ( 200 , ' call diagnostic_driver' ) + call check_grid(grid,config_flags,'before diag o c r', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) CALL diagnostic_output_calc_refl( & & DIAGFLAG=diag_flag & & ,REFD_MAX=grid%refd_max & @@ -2385,6 +2422,11 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & & ) + call check_grid(grid,config_flags,'after diag o c r', & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) + END IF ! !---------------------------------------------------------------------- @@ -2395,7 +2437,8 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! !---------------------------------------------------------------------- ! - solve_tim=solve_tim+timef()-btim + solve_tim=solve_tim+now_time()-ttim + ttim=now_time() ! !---------------------------------------------------------------------- !*** PRINT TIMING VARIABLES WHEN DESIRED. @@ -2411,62 +2454,92 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & #endif ! if(mod(grid%ntsd,n_print_time)==0)then - write(message,*)' grid%ntsd=',grid%ntsd,' solve_tim=',solve_tim*1.e-3 & - & ,' sum_tim=',sum_tim*1.e-3 + sum_tim = adjppt_tim + exch_tim + pdte_tim + adve_tim + vtoa_tim + & + vadz_tim + hadz_tim + eps_tim + vad2_tim + had2_tim + & + radiation_tim + rdtemp_tim + turbl_tim + cltend_tim + & + cucnvc_tim + gsmdrive_tim + hdiff_tim + bocoh_tim + & + pfdht_tim + ddamp_tim + bocov_tim + uv_htov_tim + diag_tim + & + tornado_tim +#ifdef HWRF + sum_tim = sum_tim + sst_tim + flux_tim + hifreq_tim +#endif +#if defined(NMM_FIND_LOAD_IMBALANCE) + sum_tim=sum_tim + loadimbal_tim + previmbal_tim +#endif +! +17 format(A16,F13.6,A5,F7.3,'%') + write(message,*)' grid%ntsd=',grid%ntsd,' solve_tim=',solve_tim & + & ,' sum_tim=',sum_tim call wrf_message(trim(message)) - write(message,*)' pdte_tim=',pdte_tim*1.e-3,' pct=',pdte_tim/sum_tim*100. +#ifdef NMM_FIND_LOAD_IMBALANCE + write(message,*)' running on cpu ',cpu call wrf_message(trim(message)) - write(message,*)' adve_tim=',adve_tim*1.e-3,' pct=',adve_tim/sum_tim*100. +#endif + write(message,17)' pdte_tim=',pdte_tim,' pct=',pdte_tim/sum_tim*100. + call wrf_message(trim(message)) + write(message,17)' adve_tim=',adve_tim,' pct=',adve_tim/sum_tim*100. + call wrf_message(trim(message)) + write(message,17)' vtoa_tim=',vtoa_tim,' pct=',vtoa_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' vtoa_tim=',vtoa_tim*1.e-3,' pct=',vtoa_tim/sum_tim*100. + write(message,17)' vadz_tim=',vadz_tim,' pct=',vadz_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' vadz_tim=',vadz_tim*1.e-3,' pct=',vadz_tim/sum_tim*100. + write(message,17)' hadz_tim=',hadz_tim,' pct=',hadz_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' hadz_tim=',hadz_tim*1.e-3,' pct=',hadz_tim/sum_tim*100. + write(message,17)' eps_tim=',eps_tim,' pct=',eps_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' eps_tim=',eps_tim*1.e-3,' pct=',eps_tim/sum_tim*100. + write(message,17)' vad2_tim=',vad2_tim,' pct=',vad2_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' vad2_tim=',vad2_tim*1.e-3,' pct=',vad2_tim/sum_tim*100. + write(message,17)' had2_tim=',had2_tim,' pct=',had2_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' had2_tim=',had2_tim*1.e-3,' pct=',had2_tim/sum_tim*100. + write(message,17)' radiation_tim=',radiation_tim,' pct=',radiation_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' radiation_tim=',radiation_tim*1.e-3,' pct=',radiation_tim/sum_tim*100. + write(message,17)' rdtemp_tim=',rdtemp_tim,' pct=',rdtemp_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' rdtemp_tim=',rdtemp_tim*1.e-3,' pct=',rdtemp_tim/sum_tim*100. + write(message,17)' turbl_tim=',turbl_tim,' pct=',turbl_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' turbl_tim=',turbl_tim*1.e-3,' pct=',turbl_tim/sum_tim*100. + write(message,17)' cltend_tim=',cltend_tim,' pct=',cltend_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' cltend_tim=',cltend_tim*1.e-3,' pct=',cltend_tim/sum_tim*100. + write(message,17)' cucnvc_tim=',cucnvc_tim,' pct=',cucnvc_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' cucnvc_tim=',cucnvc_tim*1.e-3,' pct=',cucnvc_tim/sum_tim*100. + write(message,17)' gsmdrive_tim=',gsmdrive_tim,' pct=',gsmdrive_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' gsmdrive_tim=',gsmdrive_tim*1.e-3,' pct=',gsmdrive_tim/sum_tim*100. + write(message,17)' adjppt_tim=',adjppt_tim,' pct=',adjppt_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' adjppt_tim=',adjppt_tim*1.e-3,' pct=',adjppt_tim/sum_tim*100. + write(message,17)' hdiff_tim=',hdiff_tim,' pct=',hdiff_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' hdiff_tim=',hdiff_tim*1.e-3,' pct=',hdiff_tim/sum_tim*100. + write(message,17)' bocoh_tim=',bocoh_tim,' pct=',bocoh_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' bocoh_tim=',bocoh_tim*1.e-3,' pct=',bocoh_tim/sum_tim*100. + write(message,17)' pfdht_tim=',pfdht_tim,' pct=',pfdht_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' pfdht_tim=',pfdht_tim*1.e-3,' pct=',pfdht_tim/sum_tim*100. + write(message,17)' ddamp_tim=',ddamp_tim,' pct=',ddamp_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' ddamp_tim=',ddamp_tim*1.e-3,' pct=',ddamp_tim/sum_tim*100. + write(message,17)' bocov_tim=',bocov_tim,' pct=',bocov_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' bocov_tim=',bocov_tim*1.e-3,' pct=',bocov_tim/sum_tim*100. + write(message,17)' uv_h_to_v_tim=',uv_htov_tim,' pct=',uv_htov_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' uv_h_to_v_tim=',uv_htov_tim*1.e-3,' pct=',uv_htov_tim/sum_tim*100. + write(message,17)' exch_tim=',exch_tim,' pct=',exch_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' exch_tim=',exch_tim*1.e-3,' pct=',exch_tim/sum_tim*100. + write(message,17)' diag_tim=',diag_tim,' pct=',diag_tim/sum_tim*100. call wrf_message(trim(message)) + write(message,17)' tornado_tim=',tornado_tim,' pct=',tornado_tim/sum_tim*100. + call wrf_message(trim(message)) +#ifdef HWRF + write(message,17)' sst_tim=',sst_tim,' pct=',sst_tim/sum_tim*100. + call wrf_message(trim(message)) + write(message,17)' flux_tim=',flux_tim,' pct=',flux_tim/sum_tim*100. + call wrf_message(trim(message)) + write(message,17)' hifreq_tim=',hifreq_tim,' pct=',hifreq_tim/sum_tim*100. + call wrf_message(trim(message)) +#endif #ifdef NMM_FIND_LOAD_IMBALANCE - write(message,*)' loadimbal_tim=',loadimbal_tim*1.e-3,' pct=',loadimbal_tim/sum_tim*100. + write(message,17)' loadimbal_tim=',loadimbal_tim,' pct=',loadimbal_tim/sum_tim*100. call wrf_message(trim(message)) - write(message,*)' previmbal_tim=',previmbal_tim*1.e-3,' pct=',previmbal_tim/sum_tim*100. + write(message,17)' previmbal_tim=',previmbal_tim,' pct=',previmbal_tim/sum_tim*100. call wrf_message(trim(message)) #endif ! call time_stats(exch_tim,'exchange',grid%ntsd,mype,npes,mpi_comm_comp) -! write(message,*)' exch_tim_max=',exch_tim_max*1.e-3 +! write(message,17)' exch_tim_max=',exch_tim_max ! call wrf_message(trim(message)) ! call field_stats(grid%t,mype,mpi_comm_comp & @@ -2481,17 +2554,19 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & DEALLOCATE(RTHRATEN,STAT=ISTAT) DEALLOCATE(RTHBLTEN,STAT=ISTAT) DEALLOCATE(RQVBLTEN,STAT=ISTAT) -#ifdef WRF_CHEM -#endif ! ! FOR VORTEX FOLLOWING MOVING NEST ! + + + !----------------------------------------------------------------------------- !*** CRITERIA SET FOR GRID MOTION. This is gopal's doing !----------------------------------------------------------------------------- ! #ifdef MOVE_NESTS IF ( grid%num_moves.EQ.-99 ) THEN + btimx=now_time() call start_timing() call stats_for_move(grid,config_flags & ,IDS,IDE,JDS,JDE,KDS,KDE & @@ -2502,10 +2577,12 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & write(message,3303) grid%id call end_timing(message) CALL wrf_debug ( 100 , 'nmm stats_for_move: after advection' ) + diag_tim=diag_tim+now_time()-btimx ENDIF #endif #ifdef HWRF hwrfx_mlsp: if(grid%vortex_tracker /= 1) then + btimx=now_time() ! output MSLP over parent domain for diagonostic purposes. outputs are hourly. ! This is gopal's doing @@ -2518,9 +2595,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ,IDS,IDF,JDS,JDF,KDS,KDE & ,IMS,IME,JMS,JME,KMS,KME & ,ITS,ITE,JTS,JTE,KTS,KTE ) - - ENDIF + + diag_tim=diag_tim+now_time()-btimx endif hwrfx_mlsp #endif @@ -2538,7 +2615,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & call wrf_message(trim(message)) #else ! Coupling insertion:-> + btimx=now_time() call ATM_SENDFLUXES + flux_tim=flux_tim+now_time()-btimx !<-:Coupling insertion ! ! Kwon's doing to check heat flux @@ -2550,25 +2629,54 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !-------------------------------------------------------------------------------------------------------------- ! -! HIGH FREQUENCY OUTPUT (STORM CENTER, MIN MSLP, MAX WINDS) -! FOR NEST DOMAIN (9KM) KWON 2011.4, TRAHAN 2011.6 +! HIGH FREQUENCY OUTPUT (STORM CENTER, MIN MSLP, MAX WINDS, TG products) +! FOR NEST DOMAIN (9KM) KWON 2011.4, TRAHAN 2011.6, 2014.1 ! !-------------------------------------------------------------------------------------------------------------- ! + IF(mod(grid%NTSD,grid%ntornado)==0) then + btimx=now_time() + CALL CALC_TORNADO_GENESIS(GRID,CONFIG_FLAGS) + tornado_tim=tornado_tim+now_time()-btimx + ENDIF + #ifdef HWRF + IF(mod(grid%NTSD,grid%ntornado)==0) then + have_best: if(size(grid%best_mslp)>1) then + have_membrane: if(size(grid%membrane_mslp)>1) then + call CALC_BEST_MSLP(grid%best_mslp,grid%mslp, & + grid%membrane_mslp,grid%fis, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE) + else + ! In absence of the Membrane MSLP, the Schuell is all we + ! have, so it is the best by proxy: + do j=jps,min(jde-1,jpe) + do i=ips,min(ide-1,ipe) + grid%best_mslp(i,j)=grid%mslp(i,j) + enddo + enddo + endif have_membrane + endif have_best + ENDIF + IF(grid%hifreq_lun /= 0) THEN + btimx=now_time() CALL HIFREQ_WRITE(grid%hifreq_lun,GRID%NTSD,GRID%DT,GRID%HLAT,GRID%HLON & ,GRID%U10,GRID%V10,grid%pint,grid%t,grid%q & ,grid%fis,grid%pd,grid%pdtop,grid%deta1,grid%deta2 & ,IDS,IDF,JDS,JDF,KDS,KDE & ,IMS,IME,JMS,JME,KMS,KME & ,ITS,ITE,JTS,JTE,KTS,KTE ) + hifreq_tim=hifreq_tim+now_time()-btimx ENDIF #endif ! !------------------- END OF HIGH FREQUENCY OUTPUT MODULE ---------------------------- + solve_tim=solve_tim+now_time()-ttim Return !---------------------------------------------------------------------- !********************************************************************** @@ -2944,7 +3052,7 @@ END SUBROUTINE VWR !---------------------------------------------------------------------- !********************************************************************** !---------------------------------------------------------------------- - SUBROUTINE TIME_STATS(TIME_LCL,NAME,ntsd,MYPE,NPES,MPI_COMM_COMP) + SUBROUTINE TIME_STATS(TIME_LCL_IN,NAME,ntsd,MYPE,NPES,MPI_COMM_COMP) !---------------------------------------------------------------------- !********************************************************************** USE MODULE_EXT_INTERNAL @@ -2957,7 +3065,7 @@ SUBROUTINE TIME_STATS(TIME_LCL,NAME,ntsd,MYPE,NPES,MPI_COMM_COMP) #endif !---------------------------------------------------------------------- INTEGER,INTENT(IN) :: MPI_COMM_COMP,MYPE,NPES,ntsd - REAL,INTENT(IN) :: TIME_LCL + REAL,INTENT(IN) :: TIME_LCL_IN ! CHARACTER(*),INTENT(IN) :: NAME ! @@ -2974,7 +3082,7 @@ SUBROUTINE TIME_STATS(TIME_LCL,NAME,ntsd,MYPE,NPES,MPI_COMM_COMP) ! REAL,ALLOCATABLE,DIMENSION(:) :: TIME,SORT_TIME REAL,DIMENSION(2) :: REMOTE - REAL :: TIME_MAX,TIME_MEAN,TIME_MEDIAN,TIME_MIN + REAL :: TIME_MAX,TIME_MEAN,TIME_MEDIAN,TIME_MIN,TIME_LCL ! CHARACTER(5) :: TIMESTEP CHARACTER(6) :: FMT @@ -2984,6 +3092,7 @@ SUBROUTINE TIME_STATS(TIME_LCL,NAME,ntsd,MYPE,NPES,MPI_COMM_COMP) !********************************************************************** !---------------------------------------------------------------------- ! + TIME_LCL=TIME_LCL_IN*1000. IF(ntsd<=9)THEN FMT='(I1.1)' NLEN=1 @@ -3320,35 +3429,88 @@ SUBROUTINE FIELD_STATS(FIELD,MYPE,MPI_COMM_COMP & #endif !---------------------------------------------------------------------- END SUBROUTINE FIELD_STATS -!---------------------------------------------------------------------- - FUNCTION TIMEF() - implicit none - REAL*8 TIMEF -#if defined(OLD_TIMERS) - INTEGER :: IC,IR - CALL SYSTEM_CLOCK(COUNT=IC,COUNT_RATE=IR) - TIMEF=REAL(IC)/REAL(IR)*1000.0 -#else - call hires_timer(timef) - timef=timef*1000 + + SUBROUTINE check_grid(grid,config_flags,where, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE) + use module_domain, only : domain + use module_configure, only : grid_config_rec_type +#ifndef NO_IEEE_MODULE + use, intrinsic :: ieee_arithmetic #endif - END FUNCTION TIMEF + implicit none + LOGICAL ISNAN, EXTERNAL ! NaN values detection + character*(*), intent(in) :: where + type(grid_config_rec_type),intent(in) :: config_flags + type(domain), intent(in) :: grid + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE + ! - locals - ! + character(len=255) :: message + integer :: i,j,k + + if(config_flags%halo_debug/=2 .and. config_flags%halo_debug/=3) then + return + endif +#ifndef NO_IEEE_MODULE + call wrf_debug(2,'Check for NaN') + + do k=kts,kte-1 + do j=jts,jte + do i=its,ite + if(ieee_is_nan(grid%w(i,j,k))) then + write(message,303) where,'W',i,j,k + call wrf_error_fatal(message) + endif + if(ieee_is_nan(grid%u(i,j,k))) then + write(message,303) where,'U',i,j,k + call wrf_error_fatal(message) + endif + if(ieee_is_nan(grid%v(i,j,k))) then + write(message,303) where,'V',i,j,k + call wrf_error_fatal(message) + endif + if(ieee_is_nan(grid%t(i,j,k))) then + write(message,303) where,'T',i,j,k + call wrf_error_fatal(message) + endif + if(ieee_is_nan(grid%q(i,j,k))) then + write(message,303) where,'Q',i,j,k + call wrf_error_fatal(message) + endif + if(ieee_is_nan(grid%cwm(i,j,k))) then + write(message,303) where,'CWM',i,j,k + call wrf_error_fatal(message) + endif +303 format('check_grid(...,"',A,'",...): NaN at ',A,'(',I0,',',I0,',',I0,')') + enddo + enddo + enddo +#endif + END SUBROUTINE check_grid +!---------------------------------------------------------------------- #if defined(NMM_FIND_LOAD_IMBALANCE) - SUBROUTINE BLOCKF(block_tim) + SUBROUTINE BLOCKF(block_tim,what) #if defined(DM_PARALLEL) + use module_timing, only: now_time use module_dm, only : local_communicator implicit none - interface - function timef() - real*8 timef - end function timef - end interface integer :: ierr real, intent(inout) :: block_tim - real*8 :: when - when=timef() + character*(*), intent(in) :: what + real*8 :: when, len + character*255 :: message + when=now_time() call mpi_barrier(local_communicator,ierr) - block_tim=real(block_tim+(timef()-when)) + len=now_time()-when + if(len>1.0) then +100 format(A,': large load imbalance: ',F0.5) + write(message,100) trim(what),len + call wrf_message(trim(message)) + endif + block_tim=real(block_tim+len) #else return #endif diff --git a/wrfv2_fire/dyn_nmm/start_domain_nmm.F b/wrfv2_fire/dyn_nmm/start_domain_nmm.F index 391a9565..05929613 100644 --- a/wrfv2_fire/dyn_nmm/start_domain_nmm.F +++ b/wrfv2_fire/dyn_nmm/start_domain_nmm.F @@ -63,7 +63,9 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & !---------------------------------------------------------------------- ! #ifdef HWRF + USE MODULE_CLEAR_HALOS, only: clear_ij_halos USE MODULE_STATS_FOR_MOVE, only: vorttrak_init + USE MODULE_SWATH, only: init_swath #endif USE MODULE_TIMING #ifdef HWRF @@ -97,11 +99,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! USE MODULE_EXT_INTERNAL ! -#ifdef WRF_CHEM - USE MODULE_AEROSOLS_SORGAM, ONLY: SUM_PM_SORGAM - USE MODULE_GOCART_AEROSOLS, ONLY: SUM_PM_GOCART - USE MODULE_MOSAIC_DRIVER, ONLY: SUM_PM_MOSAIC -#endif + USE module_tornado_genesis, only: init_tornado_genesis ! !---------------------------------------------------------------------- @@ -119,17 +117,11 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! TYPE(GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS ! -#ifdef WRF_CHEM - REAL RGASUNIV ! universal gas constant [ J/mol-K ] - PARAMETER ( RGASUNIV = 8.314510 ) -#endif ! !*** !*** LOCAL DATA !*** -#ifdef HWRF - LOGICAL :: ANAL !zhang's doing, added for analysis option -#endif + LOGICAL :: ANAL !added for analysis option integer(kind=4) :: random_seed INTEGER :: parent_id, nestid, max_dom,one @@ -171,8 +163,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! !!! REAL :: BLDT,CWML,EXNSFC,G_INV,PLYR,PSFC,ROG,SFCZ,THSIJ,TL REAL :: CWML,EXNSFC,G_INV,PLYR,PSURF,ROG,SFCZ,THSIJ,TL,ZOQING - REAL :: TEND - REAL :: TEMPDX, TEMPDY + REAL :: TEND, TEMPDX,TEMPDY #ifdef HWRF !zhang's doing REAL :: TSTART @@ -218,9 +209,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & REAL,ALLOCATABLE,DIMENSION(:,:,:) :: T_TRANS,PINT_TRANS REAL,ALLOCATABLE,DIMENSION(:,:,:) :: CLDFRA_TRANS REAL,DIMENSION(:,:,:,:),ALLOCATABLE :: SCALAR_TRANS -#ifndef WRF_CHEM REAL,ALLOCATABLE,DIMENSION(:,:,:) :: CLDFRA_OLD -#endif !..Need to fill special height var for setting up initial condition. G. Thompson REAL,ALLOCATABLE,DIMENSION(:,:,:) :: z_at_q @@ -279,6 +268,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & call start_timing #ifdef HWRF + call clear_ij_halos(grid,config_flags%halo_debug) if(grid%id==3) then grid%force_sst=1 else @@ -307,11 +297,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & & ,config_flags) ! RESTRT=config_flags%restart -#ifdef HWRF -!zhang's doing added for analysis option - ANAL=config_flags%analysis ! gopal's doing -!zhang's doing ends -#endif + ANAL=config_flags%analysis #ifdef HWRF ! Sam's doing for hour 0 & 6 nest movement safeguards @@ -364,7 +350,6 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & write(message,3011) grid%id,tempdx,tempdy,grid%wbd0var,grid%sbd0var call wrf_debug(2,message) 3011 format('Grid ',I0,': dx=',F0.3,' dy=',F0.3,' wbd0=',F0.3,' sbd0=',F0.3) - #if 1 IF(IME>NMM_MAX_DIM )THEN WRITE(wrf_err_message,*) & @@ -594,6 +579,22 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & # include #endif ! + if((allowed_to_read .and. .not. restrt) .or. anal) then + call wrf_message("Fill REFL_10CM with -35 dBZ") + if(size(grid%refl_10cm,1)*size(grid%refl_10cm,3)>1) then + do J=JPS,JPE + do K=KPS,KPE + do I=IPS,IPE + grid%refl_10cm(i,k,j)=-35.0 + enddo + enddo + do I=IPS,IPE + grid%refd_max(i,j)=-35.0 + enddo + enddo + endif + endif + DO J=MYJS_P4,MYJE_P4 grid%iheg(J)=MOD(J+1,2) grid%ihwg(J)=grid%iheg(J)-1 @@ -648,7 +649,10 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & #ifdef HWRF if(allowed_to_read .and. config_flags%high_freq) then if(grid%id==config_flags%high_dom) then + ! Open HTCF LUN: call HIFREQ_OPEN(grid,config_flags) + ! Open per-nest-move ATCF LUN: + call HIFREQ_OPEN(grid,config_flags,atcf=.true.) elseif(config_flags%high_dom==-99) then nestless=.true. CALL nl_get_max_dom( 1, max_dom ) @@ -664,7 +668,10 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & endif enddo nestdo if(nestless) then - call HIFREQ_OPEN(grid,config_flags) + ! Open HTCF LUN: + call HIFREQ_OPEN(grid,config_flags) + ! Open per-nest-move ATCF LUN: + call HIFREQ_OPEN(grid,config_flags,atcf=.true.) endif else write(message,'("Domain ",I0," does not have hifreq out.")') grid%id @@ -674,6 +681,13 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & endif ! end of high-freq output #endif + +! Begin Sam Trahan's doing for Tornado Genesis (SPC) products + if(anal .or. (allowed_to_read .and. .not. restrt)) then + call init_tornado_genesis(grid,config_flags) + endif +! End Sam Trahan's doing for Tornado Genesis (SPC) products + #ifdef HWRF ! Begin Sam Trahan's doing for vortex tracker initialization IF ( program_name(1:8) .NE. "REAL_NMM" ) THEN @@ -682,7 +696,12 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & IDS,IDE,JDS,JDE,KDS,KDE, & IMS,IME,JMS,JME,KMS,KME, & ITS,ITE,JTS,JTE,KTS,KTE) - ENDIF + call init_swath(grid, config_flags, & + (allowed_to_read .and. .not. restrt) ) + ENDIF + IF(ANAL .or. allowed_to_read) THEN + grid%update_interest=.true. + ENDIF ! End Sam Trahan's doing for vortex tracker initialization #endif #ifdef HWRF @@ -784,7 +803,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & !*** !*** INITIALIZE CLOUD FIELDS !*** - IF (MAXVAL(grid%cwm) .gt. 0. .and. MAXVAL(grid%cwm) .lt. 1.) then + IF (MAXVAL(grid%cwm(ips:ipe,jps:jpe,:)) .gt. 0. .and. MAXVAL(grid%cwm(ips:ipe,jps:jpe,:)) .lt. 1.) then CALL wrf_message('appear to have grid%cwm values...do not zero') ELSE IF(allowed_to_read)THEN ! This is gopal's inclusion for moving nest @@ -857,7 +876,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & !*** !***EROGERS: add check for realistic values of grid%q2 ! - IF (MAXVAL(grid%q2) .gt. epsq2 .and. MAXVAL(grid%q2) .lt. 200.) then + IF (MAXVAL(grid%q2(ips:ipe,jps:jpe,:)) .gt. epsq2 .and. MAXVAL(grid%q2(ips:ipe,jps:jpe,:)) .lt. 200.) then CALL wrf_message('appear to have grid%q2 values...do not zero') ELSE IF(allowed_to_read)THEN ! This is gopal's inclusion for moving nest @@ -1847,9 +1866,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ALLOCATE(RRI(IMS:IME,KMS:KME,JMS:JME),STAT=I) ; RRI = 0. ALLOCATE(CLDFRA_TRANS(IMS:IME,KMS:KME,JMS:JME),STAT=I); CLDFRA_TRANS = 0. ALLOCATE(SCALAR_TRANS(IMS:IME,KMS:KME,JMS:JME,NUM_SCALAR),STAT=I) -#ifndef WRF_CHEM ALLOCATE(CLDFRA_OLD(IMS:IME,KMS:KME,JMS:JME),STAT=I) ; CLDFRA_OLD = 0. -#endif ALLOCATE(Z_AT_Q(IMS:IME,KMS:KME,JMS:JME),STAT=I) ; z_at_q = 0. #if 0 ALLOCATE(w0avg(IMS:IME,KMS:KME,JMS:JME),STAT=I) ; w0avg = 0. @@ -1955,6 +1972,11 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! !*** Always define the quantity grid%z0base +4041 format('Bounds: ip=',I0,',',I0,' jp=',I0,',',I0,' myi=',I0,',',I0,& + ' myj=',I0,',',I0) + write(message,4041) ips,ipe,jps,jpe,myis,myie,myjs,myje + call wrf_message(message) + IF(.NOT.RESTRT)THEN DO J=MYJS,MYJE DO I=MYIS,MYIE @@ -2080,7 +2102,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & & WTXY=grid%WTXY, LFMASSXY=grid%LFMASSXY, RTMASSXY=grid%RTMASSXY, & ! Optional Noah-MP & STMASSXY=grid%STMASSXY, WOODXY=grid%WOODXY, & ! Optional Noah-MP & STBLCPXY=grid%STBLCPXY, FASTCPXY=grid%FASTCPXY, & ! Optional Noah-MP - & XSAIXY=grid%XSAIXY, & ! Optional Noah-MP + & XSAIXY=grid%XSAIXY,LAI=grid%LAI, & ! Optional Noah-MP & T2MVXY=grid%T2MVXY, T2MBXY=grid%T2MBXY, CHSTARXY=grid%CHSTARXY, & ! Optional Noah-MP & smoiseq=grid%smoiseq, smcwtdxy=grid%smcwtdxy, rechxy=grid%rechxy, & & deeprechxy=grid%deeprechxy, & @@ -2093,7 +2115,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & & lakedepth_default=config_flags%lakedepth_default, lake_min_elev=config_flags%lake_min_elev, lake_depth=grid%lake_depth, & !lake & lake_depth_flag=grid%LAKE_DEPTH_FLAG, use_lakedepth=grid%use_lakedepth, & !lake & sf_surface_mosaic=config_flags%sf_surface_mosaic, mosaic_cat=config_flags%mosaic_cat, nlcat=1, & ! Noah tiling - & MAXPATCH=1 & ! CLM + & MAXPATCH=1,ccn_conc=config_flags%ccn_conc & ! CLM & ) #ifdef HWRF @@ -2192,7 +2214,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! array (if any hydrometeors found and non-zero from initialization ! package). Then, determine fractions ice and rain from species. - IF (.not. (MAXVAL(grid%cwm).gt.0. .and. MAXVAL(grid%cwm).lt.1.) ) then + IF (.not. (MAXVAL(grid%cwm(ips:ipe,jps:jpe,:)).gt.0. .and. MAXVAL(grid%cwm(ips:ipe,jps:jpe,:)).lt.1.) ) then do i_m = 2, num_moist if (i_m.ne.p_qv) & & CALL wrf_message(' summing moist(:,:,:,i_m) into cwm array') @@ -2207,9 +2229,11 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & enddo enddo - IF (.not. ( (maxval(grid%f_ice)+maxval(grid%f_rain)) .gt. EPSQ) ) THEN + IF (size(grid%f_ice)>1 .and. size(grid%f_rain)>1) then + IF( .not. ( (maxval(grid%f_ice(ips:ipe,:,jps:jpe)) & + +maxval(grid%f_rain(ips:ipe,:,jps:jpe))) .gt. EPSQ) ) THEN ETAMP_Regional=.FALSE. !-- Regional NAM or HRW (Ferrier) microphysics - if (model_config_rec%mp_physics(grid%id).EQ.ETAMPOLD .OR. & + if (model_config_rec%mp_physics(grid%id).EQ.ETAMP_HR .OR. & & model_config_rec%mp_physics(grid%id).EQ.ETAMPNEW ) & & ETAMP_Regional=.TRUE. CALL wrf_message(' computing grid%f_ice') @@ -2260,13 +2284,14 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & enddo enddo enddo - endif + endif + ENDIF ENDIF ENDIF ! End addition by Greg Thompson if(size(grid%f_ice)>1) then - IF (maxval(grid%f_ice) .gt. 0.) THEN + IF (maxval(grid%f_ice(ips:ipe,:,jps:jpe)) .gt. 0.) THEN do J=JMS,JME do K=KMS,KME do I=IMS,IME @@ -2278,7 +2303,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & endif if(size(grid%f_rain)>1) then - IF (maxval(grid%f_rain) .gt. 0.) THEN + IF (maxval(grid%f_rain(ips:ipe,:,jps:jpe)) .gt. 0.) THEN do J=JMS,JME do K=KMS,KME do I=IMS,IME @@ -2290,7 +2315,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & endif if(size(grid%f_rimef)>1) then - IF (maxval(grid%f_rimef) .gt. 0.) THEN + IF (maxval(grid%f_rimef(ips:ipe,:,jps:jpe)) .gt. 0.) THEN do J=JMS,JME do K=KMS,KME do I=IMS,IME @@ -2304,7 +2329,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! IF (.NOT. RESTRT) THEN !-- Replace albedos if original albedos are nonzero - IF(MAXVAL(ALBEDO_DUM)>0.)THEN + IF(MAXVAL(ALBEDO_DUM(ips:ipe,jps:jpe))>0.)THEN DO J=JMS,JME DO I=IMS,IME grid%albedo(I,J)=ALBEDO_DUM(I,J) @@ -2319,108 +2344,14 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & #else IF(.NOT.RESTRT)THEN #endif - DO J=JMS,JME - DO I=IMS,IME + DO J=jps,min(jpe,jde-1) + DO I=ips,min(ipe,ide-1) grid%aprec(I,J)=RAINNC(I,J)*1.E-3 grid%cuprec(I,J)=grid%raincv(I,J)*1.E-3 ENDDO ENDDO ENDIF -!following will need mods Sep06 ! -#ifdef WRF_CHEM - DO J=JTS,JTE - JJ=MIN(JDE-1,J) - DO K=KTS,KTE-1 - KK=MIN(KDE-1,K) - DO I=ITS,ITE - II=MIN(IDE-1,I) - CONVFAC(I,K,J) = grid%pint(II,JJ,KK)/RGASUNIV/grid%t(II,JJ,KK) - ENDDO - ENDDO - ENDDO - - DO J=JMS,JME - DO K=KMS,KME - DO I=IMS,IME - PINT_TRANS(I,K,J)=grid%pint(I,J,K) - T_TRANS(I,K,J)=grid%t(I,J,K) - ENDDO - ENDDO - ENDDO - DO J=JMS,JME - DO I=IMS,IME - grid%xlat(i,j)=grid%glat(I,J)/DEGRAD - grid%xlong(I,J)=grid%glon(I,J)/DEGRAD - - ENDDO - ENDDO -!!! write(0,*)'now do chem_init' - CALL CHEM_INIT (GRID%ID,CHEM,EMIS_ANT,scalar,GRID%DT,GRID%BIOEMDT,GRID%PHOTDT,GRID%CHEMDT, & - STEPBIOE,STEPPHOT,STEPCHEM,STEPFIREPL,GRID%PLUMERISEFIRE_FRQ, & - ZINT,grid%xlat,grid%xlong,G,AERWRF,CONFIG_FLAGS,grid, & - RRI,T_TRANS,PINT_TRANS,CONVFAC, & - grid%ttday,grid%tcosz,grid%julday,grid%gmt, & - GD_CLOUD,GD_CLOUD2,raincv_a,raincv_b, & - GD_CLOUD_a,GD_CLOUD2_a, & - QC_CU,QI_CU, & - TAUAER1,TAUAER2,TAUAER3,TAUAER4, & - GAER1,GAER2,GAER3,GAER4, & - WAER1,WAER2,WAER3,WAER4, & - l2AER,l3AER,l4AER,l5AER,l6aer,l7aer, & - PM2_5_DRY,PM2_5_WATER,PM2_5_DRY_EC, & - grid%last_chem_time_year,grid%last_chem_time_month, & - grid%last_chem_time_day,grid%last_chem_time_hour, & - grid%last_chem_time_minute,grid%last_chem_time_second, & - GRID%CHEM_IN_OPT, & - GRID%KEMIT, & - IDS , IDE , JDS , JDE , KDS , KDE , & - IMS , IME , JMS , JME , KMS , KME , & - ITS , ITE , JTS , JTE , KTS , KTE ) - -! -! calculate initial pm -! - SELECT CASE (CONFIG_FLAGS%CHEM_OPT) - case (GOCART_SIMPLE,GOCARTRACM_KPP,GOCARTRADM2,GOCARTRADM2_KPP) - call sum_pm_gocart ( & - RRI, CHEM, PM2_5_DRY, PM2_5_DRY_EC, PM10, & - IDS,IDE, JDS,JDE, KDS,KDE, & - IMS,IME, JMS,JME, KMS,KME, & - ITS,ITE, JTS,JTE, KTS,KTE-1 ) - CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RADM2SORG_KPP,RACMSORG_AQ,RACMSORG_AQCHEM_KPP, & - RACM_ESRLSORG_AQCHEM_KPP,RACMSORG_KPP) -!!! write(0,*)'sum pm ' - CALL SUM_PM_SORGAM ( & - RRI, CHEM, H2OAJ, H2OAI, & - PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC, PM10, & - IDS,IDE, JDS,JDE, KDS,KDE, & - IMS,IME, JMS,JME, KMS,KME, & - ITS,ITE, JTS,JTE, KTS,KTE-1 ) - - CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, & - CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP) - CALL SUM_PM_MOSAIC ( & - RRI, CHEM, & - PM2_5_DRY, PM2_5_WATER, PM2_5_DRY_EC, PM10, & - IDS,IDE, JDS,JDE, KDS,KDE, & - IMS,IME, JMS,JME, KMS,KME, & - ITS,ITE, JTS,JTE, KTS,KTE-1 ) - - CASE DEFAULT - DO J=JTS,MIN(JTE,JDE-1) - DO K=KTS,MIN(KTE,KDE-1) - DO I=ITS,MIN(ITE,IDE-1) - PM2_5_DRY(I,K,J) = 0. - PM2_5_WATER(I,K,J) = 0. - PM2_5_DRY_EC(I,K,J) = 0. - PM10(I,K,J) = 0. - ENDDO - ENDDO - ENDDO - END SELECT -#endif DEALLOCATE(SFULL) DEALLOCATE(SMID) DEALLOCATE(DZS) @@ -2471,9 +2402,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & DEALLOCATE(PINT_TRANS) DEALLOCATE(T_TRANS) DEALLOCATE(CLDFRA_TRANS) -#ifndef WRF_CHEM DEALLOCATE(CLDFRA_OLD) -#endif DEALLOCATE(Z_AT_Q) #if 0 DEALLOCATE(w0avg) diff --git a/wrfv2_fire/external/Makefile b/wrfv2_fire/external/Makefile index 2bfe007a..e260a755 100644 --- a/wrfv2_fire/external/Makefile +++ b/wrfv2_fire/external/Makefile @@ -3,6 +3,7 @@ superclean : ( cd esmf_time_f90 ; make superclean ) ( cd io_pnetcdf ; make superclean ) + ( cd io_pio ; make superclean ) ( cd io_int ; make superclean ) ( cd io_netcdf ; make superclean ) ( cd io_mcel ; make superclean ) diff --git a/wrfv2_fire/external/RSL_LITE/gen_comms.c b/wrfv2_fire/external/RSL_LITE/gen_comms.c index da95a08a..18ed6f97 100644 --- a/wrfv2_fire/external/RSL_LITE/gen_comms.c +++ b/wrfv2_fire/external/RSL_LITE/gen_comms.c @@ -226,6 +226,7 @@ gen_halos ( char * dirname , char * incname , node_t * halos, int split ) char name_4d[MAX_4DARRAYS][NAMELEN] ; #define FRAC 4 int num_halos, fraction, ihalo, j ; + int always_interp_mp = 1; if ( dirname == NULL ) return(1) ; @@ -245,6 +246,14 @@ gen_halos ( char * dirname , char * incname , node_t * halos, int split ) } } +#if (NMM_CORE==1) + if ( !strcmp(commname,"HALO_INTERP_DOWN") + || !strcmp(commname,"HALO_FORCE_DOWN") + || !strcmp(commname,"HALO_INTERP_UP") + || !strcmp(commname,"HALO_INTERP_SMOOTH") ) + always_interp_mp=0; +#endif + ihalo = 0 ; for ( p = halos ; p != NULL ; p = p->next ) { @@ -499,12 +508,12 @@ fprintf(fp,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %s for Y %s')\n",maxste } /* generate packs prior to stencil exchange in Y */ - gen_packs_halo( fp, p, maxstenwidth, 0, 0, "RSL_LITE_PACK", "local_communicator" ) ; + gen_packs_halo( fp, p, maxstenwidth, 0, 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ; /* generate stencil exchange in Y */ fprintf(fp," CALL RSL_LITE_EXCH_Y ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ; fprintf(fp," rsl_sendw_m, rsl_sendw_p, rsl_recvw_m, rsl_recvw_p )\n" ) ; /* generate unpacks after stencil exchange in Y */ - gen_packs_halo( fp, p, maxstenwidth, 0, 1 , "RSL_LITE_PACK", "local_communicator" ) ; + gen_packs_halo( fp, p, maxstenwidth, 0, 1 , "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ; fprintf(fp,"ENDDO\n") ; /* generate the stencil init statement for X transfer */ @@ -539,12 +548,12 @@ fprintf(fp,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %s for Y %s')\n",maxste fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ; } /* generate packs prior to stencil exchange in X */ - gen_packs_halo( fp, p, maxstenwidth, 1, 0, "RSL_LITE_PACK", "local_communicator" ) ; + gen_packs_halo( fp, p, maxstenwidth, 1, 0, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ; /* generate stencil exchange in X */ fprintf(fp," CALL RSL_LITE_EXCH_X ( local_communicator , mytask, ntasks, ntasks_x, ntasks_y, &\n") ; fprintf(fp," rsl_sendw_m, rsl_sendw_p, rsl_recvw_m, rsl_recvw_p )\n" ) ; /* generate unpacks after stencil exchange in X */ - gen_packs_halo( fp, p, maxstenwidth, 1, 1, "RSL_LITE_PACK", "local_communicator" ) ; + gen_packs_halo( fp, p, maxstenwidth, 1, 1, "RSL_LITE_PACK", "local_communicator", always_interp_mp ) ; fprintf(fp," ENDDO\n") ; if ( subgrid != 0 ) { fprintf(fp,"ENDIF\n") ; @@ -564,7 +573,7 @@ fprintf(fp,"CALL wrf_debug(3,'calling RSL_LITE_INIT_EXCH %s for Y %s')\n",maxste return(0) ; } -gen_packs_halo ( FILE *fp , node_t *p, char *shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname ) +gen_packs_halo ( FILE *fp , node_t *p, char *shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname, int always_interp_mp ) { node_t * q ; node_t * dimd ; @@ -605,6 +614,10 @@ gen_packs_halo ( FILE *fp , node_t *p, char *shw, int xy /* 0=y,1=x */ , int pu else if ( q->boundary_array ) { ; } else { + if(!always_interp_mp && p->mp_var) { + fprintf(fp,"if(interp_mp) then\n"); + } + if ( ! strcmp( q->type->name, "real") ) { wordsize = "RWORDSIZE" ; } else if ( ! strcmp( q->type->name, "integer") ) { wordsize = "IWORDSIZE" ; } else if ( ! strcmp( q->type->name, "doubleprecision") ) { wordsize = "DWORDSIZE" ; } @@ -748,8 +761,10 @@ fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%s fprintf(fp,"ENDIF\n") ; } } + if(!always_interp_mp && p->mp_var) { + fprintf(fp,"endif\n"); + } } - } t2 = strtok_rentr( NULL , "," , &pos2 ) ; } @@ -2138,6 +2153,7 @@ gen_nest_packunpack ( FILE *fp , node_t * node , int dir, int down_path ) int d2, d3, xdex, ydex, zdex ; int nest_mask ; char * grid ; + const char * feed="NEST_INFLUENCE"; char ddim[3][2][NAMELEN] ; char mdim[3][2][NAMELEN] ; char pdim[3][2][NAMELEN] ; @@ -2267,10 +2283,18 @@ fprintf(fp,"IF ( cd_feedback_mask%s( pig, ips_save, ipe_save , pjg, jps_save, jp fprintf(fp,"IF(feedback_flag%s) THEN\n",sjl); } #endif + +#if ( NMM_CORE == 1) + if ( node->full_feedback ) { + feed="NEST_FULL_INFLUENCE"; + } else { + feed="NEST_INFLUENCE"; + } +#endif if ( zdex >= 0 ) { -fprintf(fp,"DO k = %s,%s\nNEST_INFLUENCE(%s%s,xv(k))\nENDDO\n", ddim[zdex][0], ddim[zdex][1], grid, vname ) ; +fprintf(fp,"DO k = %s,%s\n%s(%s%s,xv(k))\nENDDO\n", ddim[zdex][0], ddim[zdex][1], feed, grid, vname ) ; } else { -fprintf(fp,"NEST_INFLUENCE(%s%s,xv(1))\n", grid, vname ) ; +fprintf(fp,"%s(%s%s,xv(1))\n", feed, grid, vname ) ; } fprintf(fp,"ENDIF\n") ; } diff --git a/wrfv2_fire/external/RSL_LITE/module_dm.F b/wrfv2_fire/external/RSL_LITE/module_dm.F index f7367ac1..8a6e1879 100644 --- a/wrfv2_fire/external/RSL_LITE/module_dm.F +++ b/wrfv2_fire/external/RSL_LITE/module_dm.F @@ -1,3 +1,11 @@ +#if NMM_CORE==1 +#define copy_fcnm UpNear +#define copy_fcn UpCopy +#define interp_fcn DownCopy +#define copy_fcni UpINear +#endif + +#define NEST_FULL_INFLUENCE(A,B) A=B MODULE module_dm USE module_machine @@ -10,7 +18,7 @@ MODULE module_dm IMPLICIT NONE -#if ( NMM_CORE == 1 ) || defined( WRF_CHEM ) +#if ( NMM_CORE == 1 ) || ( WRF_CHEM == 1 ) INTEGER, PARAMETER :: max_halo_width = 6 #else INTEGER, PARAMETER :: max_halo_width = 6 ! 5 @@ -1292,6 +1300,22 @@ SUBROUTINE wrf_dm_min_reals ( inval, retval, n ) #endif END SUBROUTINE wrf_dm_min_reals + FUNCTION wrf_dm_sum_real8 ( inval ) + ! Forced eight byte real sum needed for calculating an accurate + ! mean motion in HWRF moduel_tracker. + IMPLICIT NONE +#ifndef STUBMPI + INCLUDE 'mpif.h' + REAL*8 inval, retval, wrf_dm_sum_real8 + INTEGER ierr + CALL mpi_allreduce ( inval, retval , 1, MPI_REAL8, MPI_SUM, local_communicator, ierr ) + wrf_dm_sum_real8 = retval +#else + REAL*8 wrf_dm_sum_real8,inval + wrf_dm_sum_real8 = inval +#endif + END FUNCTION wrf_dm_sum_real8 + REAL FUNCTION wrf_dm_sum_real ( inval ) IMPLICIT NONE #ifndef STUBMPI @@ -3482,7 +3506,7 @@ END SUBROUTINE outbuf_2_patch_l !------------------------------------------------------------------ - SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags & + SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags & ! #include "dummy_new_args.inc" ! @@ -3496,11 +3520,12 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags & ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid + TYPE(domain), POINTER :: pgrid !KAL added for vertical nesting #include INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -3513,10 +3538,27 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags & INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7,itrace REAL dummy_xs, dummy_xe, dummy_ys, dummy_ye - CALL get_ijk_from_grid ( grid , & + !KAL variables for vertical nesting + REAL :: p_top_m , p_surf_m , mu_m , hsca_m , pre_c ,pre_n + REAL, DIMENSION(pgrid%s_vert:pgrid%e_vert) :: alt_w_c + REAL, DIMENSION(pgrid%s_vert:pgrid%e_vert+1) :: alt_u_c + REAL, DIMENSION(ngrid%s_vert:ngrid%e_vert) :: alt_w_n + REAL, DIMENSION(ngrid%s_vert:ngrid%e_vert+1) :: alt_u_n + + !KAL change this for vertical nesting + ! force_domain_em_part1 packs up the interpolation onto the coarse (vertical) grid + ! therefore the message size is based on the coarse grid number of levels + ! here it is unpacked onto the intermediate grid + CALL get_ijk_from_grid ( pgrid , & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe ) + + !KAL this is the original WRF code + !CALL get_ijk_from_grid ( grid , & + ! cids, cide, cjds, cjde, ckds, ckde, & + ! cims, cime, cjms, cjme, ckms, ckme, & + ! cips, cipe, cjps, cjpe, ckps, ckpe ) CALL get_ijk_from_grid ( ngrid , & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & @@ -3526,11 +3568,63 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, config_flags & #include "nest_interpdown_unpack.inc" +if (ngrid%vert_refine_method .NE. 0) then + + !KAL calculating the vertical coordinate for parent and nest grid (code from ndown) + ! assume that the parent and nest have the same p_top value (as in ndown) + +!KAL ckde is equal to e_vert of the coarse grid. There are e_vert-1 u points. The coarse 1D grid here is e_vert+1, +! so it is the e_vert-1 points from the coarse grid, plus a surface point plus a top point. Extrapolation coefficients +! are used to get the surface and top points to fill out the pro_u_c 1D array of u values from the coarse grid. + + hsca_m = 6.7 !KAL scale height of the atmosphere + p_top_m = ngrid%p_top + p_surf_m = 1.e5 + mu_m = p_surf_m - p_top_m +! parent + do k = 1,ckde + pre_c = mu_m * pgrid%znw(k) + p_top_m + alt_w_c(k) = -hsca_m * alog(pre_c/p_surf_m) + enddo + do k = 1,ckde-1 + pre_c = mu_m * pgrid%znu(k) + p_top_m + alt_u_c(k+1) = -hsca_m * alog(pre_c/p_surf_m) + enddo + alt_u_c(1) = alt_w_c(1) + alt_u_c(ckde+1) = alt_w_c(ckde) +! nest + do k = 1,nkde + pre_n = mu_m * ngrid%znw(k) + p_top_m + alt_w_n(k) = -hsca_m * alog(pre_n/p_surf_m) + enddo + do k = 1,nkde-1 + pre_n = mu_m * ngrid%znu(k) + p_top_m + alt_u_n(k+1) = -hsca_m * alog(pre_n/p_surf_m) + enddo + alt_u_n(1) = alt_w_n(1) + alt_u_n(nkde+1) = alt_w_n(nkde) + +endif + + !KAL added this call for vertical nesting (return coarse grid dimensions to intended values) + CALL get_ijk_from_grid ( grid , & + cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cips, cipe, cjps, cjpe, ckps, ckpe ) + CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) +if (ngrid%vert_refine_method .NE. 0) then + +!KAL added this code (the include file) for the vertical nesting +#include "nest_forcedown_interp_vert.inc" + +endif + + #include "HALO_FORCE_DOWN.inc" ! code here to interpolate the data into the nested domain @@ -3562,7 +3656,7 @@ SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k INTEGER iparstrt,jparstrt,sw TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -3619,7 +3713,7 @@ END SUBROUTINE interp_domain_em_part1 !------------------------------------------------------------------ - SUBROUTINE interp_domain_em_part2 ( grid, ngrid, config_flags & + SUBROUTINE interp_domain_em_part2 ( grid, ngrid, pgrid, config_flags & ! #include "dummy_new_args.inc" ! @@ -3634,11 +3728,12 @@ SUBROUTINE interp_domain_em_part2 ( grid, ngrid, config_flags & ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid + TYPE(domain), POINTER :: pgrid !KAL added for vertical nesting #include INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -3655,10 +3750,27 @@ SUBROUTINE interp_domain_em_part2 ( grid, ngrid, config_flags & INTEGER ierr INTEGER thisdomain_max_halo_width - CALL get_ijk_from_grid ( grid , & + !KAL variables for vertical nesting + REAL :: p_top_m , p_surf_m , mu_m , hsca_m , pre_c ,pre_n + REAL, DIMENSION(pgrid%s_vert:pgrid%e_vert) :: alt_w_c + REAL, DIMENSION(pgrid%s_vert:pgrid%e_vert+1) :: alt_u_c + REAL, DIMENSION(ngrid%s_vert:ngrid%e_vert) :: alt_w_n + REAL, DIMENSION(ngrid%s_vert:ngrid%e_vert+1) :: alt_u_n + + + !KAL change this for vertical nesting + ! interp_domain_em_part1 packs up the interpolation onto the coarse (vertical) grid + ! therefore the message size is based on the coarse grid number of levels + ! here it is unpacked onto the intermediate grid + CALL get_ijk_from_grid ( pgrid , & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe ) + !KAL this is the original WRF code + !CALL get_ijk_from_grid ( grid , & + ! cids, cide, cjds, cjde, ckds, ckde, & + ! cims, cime, cjms, cjme, ckms, ckme, & + ! cips, cipe, cjps, cjpe, ckps, ckpe ) CALL get_ijk_from_grid ( ngrid , & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & @@ -3670,11 +3782,109 @@ SUBROUTINE interp_domain_em_part2 ( grid, ngrid, config_flags & #include "nest_interpdown_unpack.inc" + +if (ngrid%vert_refine_method .NE. 0) then + + !KAL calculating the vertical coordinate for parent and nest grid (code from ndown) + ! assume that the parent and nest have the same p_top value (as in ndown) + +!KAL ckde is equal to e_vert of the coarse grid. There are e_vert-1 u points. The coarse 1D grid here is e_vert+1, +! so it is the e_vert-1 points from the coarse grid, plus a surface point plus a top point. Extrapolation coefficients +! are used to get the surface and top points to fill out the pro_u_c 1D array of u values from the coarse grid. + + hsca_m = 6.7 !KAL scale height of the atmosphere + p_top_m = ngrid%p_top + p_surf_m = 1.e5 + mu_m = p_surf_m - p_top_m +! parent + do k = 1,ckde + pre_c = mu_m * pgrid%znw(k) + p_top_m + alt_w_c(k) = -hsca_m * alog(pre_c/p_surf_m) + enddo + do k = 1,ckde-1 + pre_c = mu_m * pgrid%znu(k) + p_top_m + alt_u_c(k+1) = -hsca_m * alog(pre_c/p_surf_m) + enddo + alt_u_c(1) = alt_w_c(1) + alt_u_c(ckde+1) = alt_w_c(ckde) +! nest + do k = 1,nkde + pre_n = mu_m * ngrid%znw(k) + p_top_m + alt_w_n(k) = -hsca_m * alog(pre_n/p_surf_m) + enddo + do k = 1,nkde-1 + pre_n = mu_m * ngrid%znu(k) + p_top_m + alt_u_n(k+1) = -hsca_m * alog(pre_n/p_surf_m) + enddo + alt_u_n(1) = alt_w_n(1) + alt_u_n(nkde+1) = alt_w_n(nkde) +endif + + + + !KAL added this call for vertical nesting (return coarse grid dimensions to intended values) + CALL get_ijk_from_grid ( grid , & + cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cips, cipe, cjps, cjpe, ckps, ckpe ) + CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) + +if (ngrid%vert_refine_method .NE. 0) then + +!KAL added this code (the include file) for the vertical nesting +#include "nest_interpdown_interp_vert.inc" + + + !KAL finish off the 1-D variables (t_base, u_base, v_base, qv_base, and z_base) (move this out of here if alt_u_c and alt_u_n are calculated elsewhere) + CALL vert_interp_vert_nesting_1d ( & + ngrid%t_base, & ! CD field + ids, ide, kds, kde, jds, jde, & ! CD dims + ims, ime, kms, kme, jms, jme, & ! CD dims + ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims + pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid + pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) ! coordinates for parent and nest + CALL vert_interp_vert_nesting_1d ( & + ngrid%u_base, & ! CD field + ids, ide, kds, kde, jds, jde, & ! CD dims + ims, ime, kms, kme, jms, jme, & ! CD dims + ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims + pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid + pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) ! coordinates for parent and nest + CALL vert_interp_vert_nesting_1d ( & + ngrid%v_base, & ! CD field + ids, ide, kds, kde, jds, jde, & ! CD dims + ims, ime, kms, kme, jms, jme, & ! CD dims + ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims + pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid + pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) ! coordinates for parent and nest + CALL vert_interp_vert_nesting_1d ( & + ngrid%qv_base, & ! CD field + ids, ide, kds, kde, jds, jde, & ! CD dims + ims, ime, kms, kme, jms, jme, & ! CD dims + ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims + pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid + pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) ! coordinates for parent and nest + CALL vert_interp_vert_nesting_1d ( & + ngrid%z_base, & ! CD field + ids, ide, kds, kde, jds, jde, & ! CD dims + ims, ime, kms, kme, jms, jme, & ! CD dims + ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims + pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid + pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) ! coordinates for parent and nest + +endif + + #include "HALO_INTERP_DOWN.inc" # include "nest_interpdown_interp.inc" @@ -3706,7 +3916,7 @@ SUBROUTINE interp_domain_em_small_part1 ( grid, intermediate_grid, ngrid, config INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k INTEGER iparstrt,jparstrt,sw TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe @@ -3885,7 +4095,7 @@ SUBROUTINE interp_domain_em_small_part2 ( grid, ngrid, config_flags & INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -4086,7 +4296,7 @@ SUBROUTINE feedback_domain_em_part1 ( grid, ngrid, config_flags & INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE(domain), POINTER :: xgrid TYPE (grid_config_rec_type) :: config_flags, nconfig_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -4197,7 +4407,7 @@ SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_fl INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -4335,7 +4545,7 @@ SUBROUTINE before_interp_halos_nmm(grid,config_flags & USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width - USE module_comm_dm_3, ONLY : HALO_NMM_WEIGHTS_sub + USE module_comm_dm, ONLY : HALO_NMM_WEIGHTS_sub IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") @@ -4390,7 +4600,7 @@ SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flag INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k INTEGER iparstrt,jparstrt,sw TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -4472,7 +4682,7 @@ SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags & INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -4568,7 +4778,7 @@ SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k INTEGER iparstrt,jparstrt,sw TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -4628,61 +4838,6 @@ SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags RETURN END SUBROUTINE force_domain_nmm_part1 -!------------------------------------------------------------------ - - SUBROUTINE old_force_domain_nmm_part1 ( grid, intermediate_grid, config_flags & -! -#include "dummy_new_args.inc" -! - ) - USE module_state_description - USE module_domain, ONLY : domain, get_ijk_from_grid - USE module_configure, ONLY : grid_config_rec_type - USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width - USE module_timing -! - TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") - TYPE(domain), POINTER :: intermediate_grid -#include - INTEGER nlev, msize - INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k - TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) - INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & - cims, cime, cjms, cjme, ckms, ckme, & - cips, cipe, cjps, cjpe, ckps, ckpe - INTEGER :: nids, nide, njds, njde, nkds, nkde, & - nims, nime, njms, njme, nkms, nkme, & - nips, nipe, njps, njpe, nkps, nkpe - LOGICAL feedback_flag, feedback_flag_v - LOGICAL interp_mp - INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7 - -!#define COPY_IN -!#include -! - CALL get_ijk_from_grid ( grid , & - cids, cide, cjds, cjde, ckds, ckde, & - cims, cime, cjms, cjme, ckms, ckme, & - cips, cipe, cjps, cjpe, ckps, ckpe ) - - CALL get_ijk_from_grid ( intermediate_grid , & - nids, nide, njds, njde, nkds, nkde, & - nims, nime, njms, njme, nkms, nkme, & - nips, nipe, njps, njpe, nkps, nkpe ) - - nlev = ckde - ckds + 1 - -#include "nest_forcedown_pack.inc" - -! WRITE(0,*)'I have completed PACKING of BCs data successfully' - -!#define COPY_OUT -!#include - RETURN - END SUBROUTINE old_force_domain_nmm_part1 - !============================================================================================== SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags & @@ -4696,8 +4851,11 @@ SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags & USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width #if (NMM_NEST == 1) - USE module_comm_dm, ONLY : HALO_NMM_FORCE_DOWN1_sub, HALO_NMM_FORCE_DOWN1M_sub, & - HALO_NMM_FORCE_DOWN_SST_sub, HALO_NMM_INTERP_INFO_sub + USE module_comm_nesting_dm, ONLY : halo_force_down_sub + use module_comm_dm, only: HALO_NMM_INTERP_INFO_sub +#ifdef HWRF + use module_comm_dm, only: HALO_NMM_FORCE_DOWN_SST_sub +#endif #endif IMPLICIT NONE ! @@ -4707,7 +4865,7 @@ SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags & INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -4764,10 +4922,7 @@ SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags & ENDIF #endif -#include "HALO_NMM_FORCE_DOWN1.inc" - if(interp_mp .eqv. .true.) then -#include "HALO_NMM_FORCE_DOWN1M.inc" - endif +#include "HALO_FORCE_DOWN.inc" call store_interp_info(ngrid,grid) call ext_c2b_fulldom(ngrid%IIH,ngrid%JJH,ngrid%HBWGT1, & @@ -4854,7 +5009,8 @@ SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags & INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7 INTEGER :: idum1, idum2 - + LOGICAL :: interp_mp + interp_mp=.true. !#ifdef DEREF_KLUDGE !! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm @@ -4898,8 +5054,7 @@ SUBROUTINE force_intermediate_nmm ( grid, ngrid, config_flags & USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width #if ( NMM_NEST == 1 ) - USE module_comm_dm, ONLY : HALO_NMM_FORCE_DOWN1_sub, HALO_NMM_FORCE_DOWN1M_sub, & - HALO_NMM_INTERP_INFO_sub,HALO_NMM_FORCE_DOWN_SST_sub + USE module_comm_nesting_dm, ONLY : halo_force_down_sub #endif IMPLICIT NONE ! @@ -4910,7 +5065,7 @@ SUBROUTINE force_intermediate_nmm ( grid, ngrid, config_flags & INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -4959,10 +5114,7 @@ SUBROUTINE force_intermediate_nmm ( grid, ngrid, config_flags & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) -#include "HALO_NMM_FORCE_DOWN1.inc" -if(interp_mp .eqv. .true.) then -#include "HALO_NMM_FORCE_DOWN1M.inc" -endif +#include "HALO_FORCE_DOWN.inc" RETURN END SUBROUTINE force_intermediate_nmm @@ -4988,7 +5140,7 @@ SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags & INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE(domain), POINTER :: xgrid TYPE (grid_config_rec_type) :: config_flags, nconfig_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe @@ -5133,7 +5285,7 @@ SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_f INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags - REAL xv(500) + REAL xv(2000) INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe diff --git a/wrfv2_fire/external/RSL_LITE/rsl_lite.h b/wrfv2_fire/external/RSL_LITE/rsl_lite.h index 03a47fca..17f519ed 100644 --- a/wrfv2_fire/external/RSL_LITE/rsl_lite.h +++ b/wrfv2_fire/external/RSL_LITE/rsl_lite.h @@ -128,7 +128,7 @@ #define RSL_MALLOC(T,N) (T *)rsl_malloc(__FILE__,__LINE__,(sizeof(T))*(N)) -#define RSL_FREE(P) rsl_free(P) +#define RSL_FREE(P) rsl_free(&(P)) char * buffer_for_proc ( int P, int size, int code ) ; void * rsl_malloc( char * f, int l, int s ) ; diff --git a/wrfv2_fire/external/RSL_LITE/rsl_malloc.c b/wrfv2_fire/external/RSL_LITE/rsl_malloc.c index c759f39f..80acb037 100755 --- a/wrfv2_fire/external/RSL_LITE/rsl_malloc.c +++ b/wrfv2_fire/external/RSL_LITE/rsl_malloc.c @@ -241,14 +241,14 @@ RSL_FATAL(2) ; } rsl_free( p ) - char * p ; + char **p ; { - if ( p == zero_length_storage ) return ; /* fix from ANU */ + if ( *p == zero_length_storage ) return ; /* fix from ANU */ #ifdef STUG for ( bbb = 0 ; bbb < MAXSTUG ; bbb++ ) { - if ( stug[bbb].ddr == p ) { + if ( stug[bbb].ddr == *p ) { outy -= stug[bbb].sz ; /* fprintf(stderr,"- %10d. %08x %10d %10d\n", bbb, stug[bbb].ddr, stug[bbb].sz, outy ) ; */ nouty -- ; @@ -259,11 +259,11 @@ for ( bbb = 0 ; bbb < MAXSTUG ; bbb++ ) #endif #ifdef PADIT - BASE_FREE ( p-512 ) ; + BASE_FREE ( *p-512 ) ; #else - BASE_FREE ( p ) ; + BASE_FREE ( *p ) ; #endif - p = NULL ; + *p = NULL ; } #ifdef MS_SUA diff --git a/wrfv2_fire/external/atm_ocn/Makefile b/wrfv2_fire/external/atm_ocn/Makefile index 07794010..4f5537ee 100644 --- a/wrfv2_fire/external/atm_ocn/Makefile +++ b/wrfv2_fire/external/atm_ocn/Makefile @@ -16,7 +16,7 @@ library: $(OBJ) $(RANLIB) $(TARGET) .F.o: - $(CPP) -traditional $(CPPFLAGS) -DDM_PARALLEL $*.F > $*.f90 + $(CPP) $(CPPFLAGS) -DDM_PARALLEL $*.F > $*.f90 $(FC) -o $@ -c $(FFLAGS) $*.f90 clean: diff --git a/wrfv2_fire/external/atm_ocn/atm_comm.F b/wrfv2_fire/external/atm_ocn/atm_comm.F index d005e4b8..b4216240 100644 --- a/wrfv2_fire/external/atm_ocn/atm_comm.F +++ b/wrfv2_fire/external/atm_ocn/atm_comm.F @@ -580,8 +580,10 @@ SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, & implicit none + real(kind=kind_sfcflux),dimension(ims:ime,jms:jme,kms:kme):: PINT + real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: & - &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,TX,TY,PINT,PREC,U10,V10 + &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,TX,TY,PREC,U10,V10 !c &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,USTAR,U10,V10,PINT,PREC ! Act. arg. for PINT is a 3d array - so this only is OK if ! Ps=Act.arg.(:,:.1) - actually, Ps=PINT(:,1,:) @@ -607,7 +609,7 @@ SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, & if (zeroSF) sf(gid)%a=0. - SWR=-RSWIN+RSWOUT ! Check sign! here SWR is meant to be + SWR(its:ite,jts:jte)=-RSWIN(its:ite,jts:jte)+RSWOUT(its:ite,jts:jte) ! Check sign! here SWR is meant to be ! positive upward !c sf(gid)%a(:,:,NSF-1)=sf(gid)%a(:,:,NSF-1)-TX !c sf(gid)%a(:,:,NSF)=sf(gid)%a(:,:,NSF)-TY @@ -620,29 +622,29 @@ SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, & !oooooooooooooooooooooooooooooo IF (Ocean_spec.eq.1) THEN !oooooooooooooooooooooooooooooo - sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)-TWBS-QWBS+RADOT-RLWIN + sf(gid)%a(its:ite,jts:jte,1)=sf(gid)%a(its:ite,jts:jte,1)-TWBS(its:ite,jts:jte)-QWBS(its:ite,jts:jte)+RADOT(its:ite,jts:jte)-RLWIN(its:ite,jts:jte) ! -TWBS (-QWBS) is supposed to ! be sensible (latent) heat flux, ! positive upward - sf(gid)%a(:,:,2)=sf(gid)%a(:,:,2)+SWR - sf(gid)%a(:,:,NSF-NSF_WM-1)=sf(gid)%a(:,:,NSF-NSF_WM-1)-TX - sf(gid)%a(:,:,NSF-NSF_WM)=sf(gid)%a(:,:,NSF-NSF_WM)-TY + sf(gid)%a(its:ite,jts:jte,2)=sf(gid)%a(its:ite,jts:jte,2)+SWR(its:ite,jts:jte) + sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)-TX(its:ite,jts:jte) + sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)-TY(its:ite,jts:jte) ! <- signs for stress components are changed !ooooooooooooooooooooooooooooooooooo ELSE IF (Ocean_spec.eq.2) THEN !ooooooooooooooooooooooooooooooooooo - sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)+PREC - sf(gid)%a(:,:,2)=sf(gid)%a(:,:,2)-TWBS - sf(gid)%a(:,:,3)=sf(gid)%a(:,:,3)-QWBS - sf(gid)%a(:,:,4)=sf(gid)%a(:,:,4)+PINT-101300. - sf(gid)%a(:,:,5)=sf(gid)%a(:,:,5)-SWR-RADOT+RLWIN - sf(gid)%a(:,:,6)=sf(gid)%a(:,:,6)-SWR - - sf(gid)%a(:,:,NSF-NSF_WM-1)=sf(gid)%a(:,:,NSF-NSF_WM-1)+TX - sf(gid)%a(:,:,NSF-NSF_WM)=sf(gid)%a(:,:,NSF-NSF_WM)+TY + sf(gid)%a(its:ite,jts:jte,1)=sf(gid)%a(its:ite,jts:jte,1)+PREC(its:ite,jts:jte) + sf(gid)%a(its:ite,jts:jte,2)=sf(gid)%a(its:ite,jts:jte,2)-TWBS(its:ite,jts:jte) + sf(gid)%a(its:ite,jts:jte,3)=sf(gid)%a(its:ite,jts:jte,3)-QWBS(its:ite,jts:jte) + sf(gid)%a(its:ite,jts:jte,4)=sf(gid)%a(its:ite,jts:jte,4)+PINT(its:ite,jts:jte,1)-101300. + sf(gid)%a(its:ite,jts:jte,5)=sf(gid)%a(its:ite,jts:jte,5)-SWR(its:ite,jts:jte)-RADOT(its:ite,jts:jte)+RLWIN(its:ite,jts:jte) + sf(gid)%a(its:ite,jts:jte,6)=sf(gid)%a(its:ite,jts:jte,6)-SWR(its:ite,jts:jte) + + sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)+TX(its:ite,jts:jte) + sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)+TY(its:ite,jts:jte) ! <- signs for stress components are NOT changed if (nrmSF) then - sf(gid)%a(:,:,1)=sf(gid)%a(:,:,1)*dtainv + sf(gid)%a(its:ite,jts:jte,1)=sf(gid)%a(its:ite,jts:jte,1)*dtainv ! so this will be m/s; check what OM wants end if !ooooooooooo @@ -653,8 +655,8 @@ SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, & !wwwwwwwwwwwwwwwwwwwwwwwww IF (WM_id.gt.0) THEN !wwwwwwwwwwwwwwwwwwwwwwwww - sf(gid)%a(:,:,NSF-1)=sf(gid)%a(:,:,NSF-1)+U10 - sf(gid)%a(:,:,NSF)=sf(gid)%a(:,:,NSF)+V10 + sf(gid)%a(its:ite,jts:jte,NSF-1)=sf(gid)%a(its:ite,jts:jte,NSF-1)+U10(its:ite,jts:jte) + sf(gid)%a(its:ite,jts:jte,NSF)=sf(gid)%a(its:ite,jts:jte,NSF)+V10(its:ite,jts:jte) !wwwwwwwwwww END IF !wwwwwwwwwww diff --git a/wrfv2_fire/external/atm_ocn/cmpcomm.F b/wrfv2_fire/external/atm_ocn/cmpcomm.F index 5ac26298..a6ad1f89 100644 --- a/wrfv2_fire/external/atm_ocn/cmpcomm.F +++ b/wrfv2_fire/external/atm_ocn/cmpcomm.F @@ -954,7 +954,7 @@ SUBROUTINE CMP_FLUSH(nunit) call MPI_BARRIER(COMM_local,ierr) call GLOB_ABORT(ierr,'CMP_FLUSH: MPI_BARRIER failed, aborting', & & rc) - if (i.eq.process_rank_local) call FLUSH(nunit) + if (i.eq.process_rank_local) FLUSH(nunit) end do return diff --git a/wrfv2_fire/external/esmf_time_f90/Makefile b/wrfv2_fire/external/esmf_time_f90/Makefile index 4ef918fb..ade1199d 100644 --- a/wrfv2_fire/external/esmf_time_f90/Makefile +++ b/wrfv2_fire/external/esmf_time_f90/Makefile @@ -39,7 +39,7 @@ libesmf_time.a : $(OBJS) Test1_ESMF.f : Test1.F90 $(RM) Test1_ESMF.b Test1_ESMF.f cp Test1.F90 Test1_ESMF.b - $(CPP) -P -traditional -I. Test1_ESMF.b > Test1_ESMF.f + $(CPP) -I. Test1_ESMF.b > Test1_ESMF.f Test1_ESMF.exe : libesmf_time.a Test1_ESMF.o $(FC) -o Test1_ESMF.exe Test1_ESMF.o libesmf_time.a @@ -47,7 +47,7 @@ Test1_ESMF.exe : libesmf_time.a Test1_ESMF.o Test1_WRFU.f : Test1.F90 $(RM) Test1_WRFU.b Test1_WRFU.f sed -e "s/ESMF_Mod/module_utility/g" -e "s/ESMF_/WRFU_/g" Test1.F90 > Test1_WRFU.b - $(CPP) -P -traditional -I. Test1_WRFU.b > Test1_WRFU.f + $(CPP) -I. Test1_WRFU.b > Test1_WRFU.f Test1_WRFU.exe : libesmf_time.a Test1_WRFU.o $(FC) -o Test1_WRFU.exe Test1_WRFU.o libesmf_time.a @@ -55,7 +55,7 @@ Test1_WRFU.exe : libesmf_time.a Test1_WRFU.o .F90.o : $(RM) $@ $(SED_FTN) $*.F90 > $*.b - $(CPP) -P -traditional -I. $*.b > $*.f + $(CPP) -I. $*.b > $*.f $(RM) $*.b @ if echo $(CPP) | $(FGREP) 'DVAR4D'; then \ echo COMPILING $*.F90 for 4DVAR ; \ @@ -67,7 +67,7 @@ Test1_WRFU.exe : libesmf_time.a Test1_WRFU.o .F90.f : $(RM) $@ $(SED_FTN) $*.F90 > $*.b - $(CPP) -P -traditional -I. $*.b > $*.f + $(CPP) -I. $*.b > $*.f $(RM) $*.b @ if echo $(CPP) | $(FGREP) 'DVAR4D'; then \ echo COMPILING $*.F90 for 4DVAR ; \ diff --git a/wrfv2_fire/external/io_grib1/io_grib1.F b/wrfv2_fire/external/io_grib1/io_grib1.F index a7b87e45..05864e26 100644 --- a/wrfv2_fire/external/io_grib1/io_grib1.F +++ b/wrfv2_fire/external/io_grib1/io_grib1.F @@ -30,6 +30,8 @@ module gr1_data_info integer , parameter :: maxFileHandles = 30 integer , parameter :: maxLevels = 1000 integer , parameter :: maxSoilLevels = 100 + integer , parameter :: maxPressLevels = 100 + integer , parameter :: maxTurbLayers = 100 integer , parameter :: maxDomains = 500 logical , dimension(maxFileHandles) :: committed, opened, used @@ -38,6 +40,9 @@ module gr1_data_info integer, dimension(maxFileHandles) :: FileStatus REAL, dimension(maxLevels) :: half_eta, full_eta REAL, dimension(maxSoilLevels) :: soil_depth, soil_thickness + REAL, dimension(maxPressLevels) :: press_levels + REAL, dimension(maxTurbLayers) :: turb_layer_bot + REAL, dimension(maxTurbLayers) :: turb_layer_top character*24 :: StartDate = '' character*24 :: InputProgramName = '' integer :: projection @@ -612,7 +617,7 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & MemoryStart(2):MemoryEnd(2), & MemoryStart(3):MemoryEnd(3) ) :: Field real :: fcst_secs - logical :: soil_layers, fraction + logical :: soil_layers, fraction, is_press_levels,is_turb_layers integer :: vert_unit integer :: abc(2,2,2) integer :: def(8) @@ -686,6 +691,8 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & xsize = 1 ysize = 1 OutName = VarName + is_press_levels = .false. + is_turb_layers = .false. soil_layers = .false. fraction = .false. @@ -701,6 +708,12 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & if ((MemoryOrder(idx:idx) .eq. 'Z') .and. & (DimNames(idx) .eq. 'soil_layers_stag')) then soil_layers = .true. + else if ((MemoryOrder(idx:idx) .eq. 'Z') .and. & + (DimNames(idx) .eq. 'num_press_levels_stag')) then + is_press_levels = .true. + else if ((MemoryOrder(idx:idx) .eq. 'Z') .and. & + (DimNames(idx) .eq. 'num_turb_layers')) then + is_turb_layers = .true. else if ((OutName .eq. 'LANDUSEF') .or. (OutName .eq. 'SOILCBOT') .or. & (OutName .eq. 'SOILCTOP')) then fraction = .true. @@ -759,7 +772,23 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & enddo endif + if (OutName .eq. 'P_PL') then + do idx = 1, zsize + press_levels(idx) = Field(1,idx,1,1) + enddo + endif + + if (OutName .eq. 'AFWA_TLYRBOT') then + do idx = 1, zsize + turb_layer_bot(idx) = Field(1,idx,1,1) + enddo + endif + if (OutName .eq. 'AFWA_TLYRTOP') then + do idx = 1, zsize + turb_layer_top(idx) = Field(1,idx,1,1) + enddo + endif if ((xsize .lt. 1) .or. (ysize .lt. 1)) then write(msg,*) 'Cannot output field with memory order: ', & MemoryOrder,Varname @@ -771,7 +800,7 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & do idx = 1, zsize call gr1_get_levels(OutName, idx, zsize, soil_layers, vert_stag, fraction, & - vert_unit, level1(idx), level2(idx)) + is_press_levels, is_turb_layers, vert_unit, level1(idx), level2(idx)) enddo ! @@ -1039,15 +1068,10 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & ! ! Potential temperature is sometimes passed in as perturbation - ! potential temperature (i.e., POT-300). Other times (i.e., from - ! WRF SI), it is passed in as full potential temperature. - ! Here, we convert to full potential temperature by adding 300 - ! only if POT < 200 K. + ! potential temperature (i.e., POT-300). ! if (OutName == 'T') then - if (data(1,1) < 200) then - data = data + 300 - endif + data = data + 300 endif ! @@ -1061,6 +1085,16 @@ SUBROUTINE ext_gr1_write_field( DataHandle , DateStrIn , VarName , & else accum_period = 0 endif + + if ((OutName .eq. 'AFWA_TOTPRECIP') .or. & + (OutName .eq. 'AFWA_RAIN') .or. & + (OutName .eq. 'AFWA_FZRA') .or. & + (OutName .eq. 'AFWA_SNOW') .or. & + (OutName .eq. 'AFWA_SNOWFALL') .or. & + (OutName .eq. 'RAINC') .or. & + (OutName .eq. 'AFWA_ICE')) then + accum_period = fcst_secs + endif #ifdef OUTPUT_FULL_PRESSURE ! @@ -1245,6 +1279,7 @@ SUBROUTINE ext_gr1_read_field ( DataHandle , DateStr , VarName , Field , & integer :: tablenum integer :: di integer :: last_grb_index + logical :: fraction call wrf_debug ( DEBUG , 'Entering ext_gr1_read_field') @@ -1277,8 +1312,14 @@ SUBROUTINE ext_gr1_read_field ( DataHandle , DateStr , VarName , Field , & last_grb_index = -1 do zidx = z_start,z_end - CALL gr1_get_levels(VarName,zidx,z_end-z_start,soil_layers,vert_stag, & - .false., vert_unit,level1,level2) + IF ((VarName .eq. 'LANDUSEF') .or. (VarName .eq. 'SOILCBOT') .or. & + (VarName .eq. 'SOILCTOP')) then + fraction = .true. + ELSE + fraction = .false. + END IF + CALL gr1_get_levels(VarName,zidx,z_end-z_start,soil_layers,vert_stag,fraction, & + .false., .false., vert_unit,level1,level2) CALL GET_GRIB_INDEX_VALIDTIME_GUESS(fileinfo(DataHandle)%fileindex(:), center, & subcenter, parmtbl, parmid,DateStr,vert_unit,level1, & @@ -1443,7 +1484,7 @@ END SUBROUTINE ext_gr1_inquire_filename !***************************************************************************** SUBROUTINE ext_gr1_get_var_info ( DataHandle , VarName , NDim , & - MemoryOrder , Stagger , DomainStart , DomainEnd , WrfType, Status ) + MemoryOrder , Stagger , DomainStart , DomainEnd , Status ) USE gr1_data_info IMPLICIT NONE @@ -1454,7 +1495,6 @@ SUBROUTINE ext_gr1_get_var_info ( DataHandle , VarName , NDim , & character*(*) ,intent(out) :: MemoryOrder character*(*) ,intent(out) :: Stagger integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd - integer ,intent(out) :: WrfType integer ,intent(out) :: Status call wrf_debug ( DEBUG , 'Entering ext_gr1_get_var_info') @@ -3428,7 +3468,7 @@ END SUBROUTINE gr1_get_new_handle SUBROUTINE gr1_get_levels(VarName, zidx, zsize, soil_layers, vert_stag, fraction, & - vert_unit, level1, level2) + is_press_levels, is_turb_layers, vert_unit, level1, level2) use gr1_data_info IMPLICIT NONE @@ -3438,6 +3478,8 @@ SUBROUTINE gr1_get_levels(VarName, zidx, zsize, soil_layers, vert_stag, fraction logical :: soil_layers logical :: vert_stag logical :: fraction + logical :: is_press_levels + logical :: is_turb_layers integer :: vert_unit integer :: level1 integer :: level2 @@ -3450,8 +3492,8 @@ SUBROUTINE gr1_get_levels(VarName, zidx, zsize, soil_layers, vert_stag, fraction vert_unit = 109; level1 = zidx level2 = 0 - else if ((zsize .gt. 1) .and. (.not. soil_layers) .and. (.not. fraction)) & - then + else if ((zsize .gt. 1) .and. (.not. soil_layers) .and. (.not. fraction) & + .and. (.not. is_press_levels) .and. (.not. is_turb_layers)) then vert_unit = 119; if (vert_stag) then level1 = (10000*full_eta(zidx)+0.5) @@ -3469,6 +3511,15 @@ SUBROUTINE gr1_get_levels(VarName, zidx, zsize, soil_layers, vert_stag, fraction vert_unit = 112 level1 = 100*(soil_depth(zidx) - 0.5*soil_thickness(zidx))+0.5 level2 = 100*(soil_depth(zidx) + 0.5*soil_thickness(zidx))+0.5 + ! Added pressure level as vertical unit - GAC 20140402 + else if (is_press_levels) then + vert_unit = 100 + level1 = press_levels(zidx)/100. + level2 = 0 + else if (is_turb_layers) then + vert_unit = 106 + level1 = turb_layer_top(zidx)/100. + level2 = turb_layer_bot(zidx)/100. else if (VarName .eq. 'mu') then vert_unit = 200 level1 = 0 @@ -3483,6 +3534,71 @@ SUBROUTINE gr1_get_levels(VarName, zidx, zsize, soil_layers, vert_stag, fraction vert_unit = 105 level1 = 10 level2 = 0 + ! Until a more sophisticated way to do this becomes clear, + ! adding AFWA diagnostic variable vertical unit and level info + ! here. GAC 20140402 + else if ((VarName .eq. 'TCOLI_MAX') .or. & + (Varname .eq. 'GRPL_FLX_MAX') .or. & + (Varname .eq. 'VIL') .or. & + (Varname .eq. 'RADARVIL') .or. & + (Varname .eq. 'FZLEV') .or. & + (Varname .eq. 'REFD_COM') .or. & + (Varname .eq. 'ICINGTOP') .or. & + (Varname .eq. 'ICINGBOT') .or. & + (Varname .eq. 'ICING_LG') .or. & + (Varname .eq. 'ICING_SM') .or. & + (Varname .eq. 'AFWA_CLOUD') .or. & + (Varname .eq. 'AFWA_CLOUD_CEIL') .or. & + (Varname .eq. 'AFWA_HAIL') .or. & + (Varname .eq. 'AFWA_TORNADO') .or. & + (Varname .eq. 'AFWA_PWAT') .or. & + (Varname .eq. 'QICING_LG_MAX') .or. & + (Varname .eq. 'QICING_SM_MAX')) then + vert_unit = 200 + level1 = 0 + level2 = 0 + else if (VarName .eq. 'REFD_MAX') then + vert_unit = 105 + level1 = 1000 + level2 = 0 + else if (VarName .eq. 'WSPD10MAX') then + vert_unit = 105 + level1 = 10 + level2 = 0 + else if (VarName .eq. 'UP_HELI_MAX') then + vert_unit = 106 + level1 = 50 !5000 m + level2 = 20 !2000 m + else if (Varname .eq. 'AFWA_LLWS') then + vert_unit = 106 + level1 = 20 !2000 m + level2 = 0 !0 m + else if ((Varname .eq. 'AFWA_LLTURB') .or. & + (Varname .eq. 'AFWA_LLTURBLGT') .or. & + (Varname .eq. 'AFWA_LLTURBMDT') .or. & + (Varname .eq. 'AFWA_LLTURBSVR')) then + vert_unit = 106 + level1 = 15 !1500 m + level2 = 0 !0 m + else if ((VarName .eq. 'W_UP_MAX') .or. (VarName .eq. 'W_DN_MAX')) then + vert_unit = 101 + level1 = 40 !400 mb + level2 = 100 !1000 mb + else if (VarName .eq. 'AFWA_LIDX') then + vert_unit = 101 + level1 = 50 !500 mb + level2 = 100 !1000 mb + else if (VarName .eq. 'AFWA_MSLP') then + vert_unit = 102 ! Mean sea level + level1 = 0 + level2 = 0 + else if ((VarName .eq. 'AFWA_CAPE_MU') .or. & + (VarName .eq. 'AFWA_CIN_MU')) then + vert_unit = 116 ! Pressure above ground + !level1 = 180 ! 180 mb AGL + !level2 = 0 + level1 = 0 ! 180 mb AGL + level2 = 180 else vert_unit = 1 level1 = 0 diff --git a/wrfv2_fire/external/io_int/makefile b/wrfv2_fire/external/io_int/makefile index 41cae782..22516948 100644 --- a/wrfv2_fire/external/io_int/makefile +++ b/wrfv2_fire/external/io_int/makefile @@ -36,7 +36,7 @@ io_int_idx_tags.h: ../../inc/intio_tags.h awk '{print "#define", toupper($$4), $$6}' < ../../inc/intio_tags.h > $@ io_int_idx.o: io_int_idx.c io_int_idx.h io_int_idx_tags.h - $(CC) -o $@ -c $*.c + $(CC) -o $@ -c -w $*.c module_io_int_idx.o: module_io_int_idx.f $(FC) $(FCFLAGS) -o $@ -c $*.f diff --git a/wrfv2_fire/external/io_netcdf/makefile b/wrfv2_fire/external/io_netcdf/makefile index af7f162a..d4e6facb 100644 --- a/wrfv2_fire/external/io_netcdf/makefile +++ b/wrfv2_fire/external/io_netcdf/makefile @@ -5,7 +5,7 @@ OBJS = $(OBJSL) CODE = ext_ncd_get_dom_ti.code ext_ncd_get_var_td.code ext_ncd_get_var_ti.code ext_ncd_put_dom_ti.code ext_ncd_put_var_td.code ext_ncd_put_var_ti.code transpose.code FFLAGS = $(FCFLAGS) -I$(NETCDFPATH)/include -I../ioapi_share LIBS = $(LIB_LOCAL) -L$(NETCDFPATH)/lib -lnetcdf -LIBFFS = $(LIB_LOCAL) -L$(NETCDFPATH)/lib -lnetcdff -lnetcdf +LIBFFS = $(LIB_LOCAL) -L$(NETCDFPATH)/lib -lnetcdff -lnetcdf $(NETCDF4_DEP_LIB) CPP1 = $(CPP) -P $(TRADFLAG) M4 = m4 -Uinclude -Uindex -Ulen AR = ar diff --git a/wrfv2_fire/external/io_netcdf/wrf_io.F90 b/wrfv2_fire/external/io_netcdf/wrf_io.F90 index 8f5e1e3c..5ee038f8 100644 --- a/wrfv2_fire/external/io_netcdf/wrf_io.F90 +++ b/wrfv2_fire/external/io_netcdf/wrf_io.F90 @@ -40,7 +40,7 @@ module wrf_data integer , parameter :: WARN = 1 integer , parameter :: WrfDataHandleMax = 99 integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS -#ifdef WRF_CHEM +#if(WRF_CHEM == 1) integer , parameter :: MaxVars = 8000 #else integer , parameter :: MaxVars = 3000 @@ -901,6 +901,22 @@ LOGICAL FUNCTION ncd_is_first_operation( DataHandle ) RETURN END FUNCTION ncd_is_first_operation +subroutine upgrade_filename(FileName) + implicit none + + character*(*), intent(inout) :: FileName + integer :: i + + do i = 1, len(trim(FileName)) + if(FileName(i:i) == '-') then + FileName(i:i) = '_' + else if(FileName(i:i) == ':') then + FileName(i:i) = '_' + endif + enddo + +end subroutine upgrade_filename + end module ext_ncd_support_routines subroutine TransposeToR4(IO,MemoryOrder,di, Field,l1,l2,m1,m2,n1,n2 & @@ -1015,7 +1031,7 @@ subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, Data implicit none include 'wrf_status_codes.h' include 'netcdf.inc' - character*(*) ,intent(IN) :: FileName + character*(*) ,intent(INOUT) :: FileName integer ,intent(IN) :: Comm integer ,intent(IN) :: IOComm character*(*) ,intent(in) :: SysDepInfo @@ -1040,6 +1056,8 @@ subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, Data integer :: open_mode #endif + !call upgrade_filename(FileName) + if(WrfIOnotInitialized) then Status = WRF_IO_NOT_INITIALIZED write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ @@ -1139,7 +1157,7 @@ subroutine ext_ncd_open_for_read_begin( FileName, Comm, IOComm, SysDepInfo, Data DH%NumVars = NumVars DH%NumberTimes = VLen(2) DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = FileName + DH%FileName = trim(FileName) DH%CurrentVariable = 0 DH%CurrentTime = 0 DH%TimesVarID = VarID @@ -1153,7 +1171,7 @@ subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHand implicit none include 'wrf_status_codes.h' include 'netcdf.inc' - character*(*) ,intent(IN) :: FileName + character*(*) ,intent(INOUT) :: FileName integer ,intent(IN) :: Comm integer ,intent(IN) :: IOComm character*(*) ,intent(in) :: SysDepInfo @@ -1178,6 +1196,8 @@ subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHand integer :: open_mode #endif + !call upgrade_filename(FileName) + if(WrfIOnotInitialized) then Status = WRF_IO_NOT_INITIALIZED write(msg,*) 'ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ @@ -1276,7 +1296,7 @@ subroutine ext_ncd_open_for_update( FileName, Comm, IOComm, SysDepInfo, DataHand DH%NumVars = NumVars DH%NumberTimes = VLen(2) DH%FileStatus = WRF_FILE_OPENED_FOR_UPDATE - DH%FileName = FileName + DH%FileName = trim(FileName) DH%CurrentVariable = 0 DH%CurrentTime = 0 DH%TimesVarID = VarID @@ -1291,7 +1311,7 @@ SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHand implicit none include 'wrf_status_codes.h' include 'netcdf.inc' - character*(*) ,intent(in) :: FileName + character*(*) ,intent(inout) :: FileName integer ,intent(in) :: Comm integer ,intent(in) :: IOComm character*(*) ,intent(in) :: SysDepInfo @@ -1310,6 +1330,8 @@ SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHand cache_preemption = 100 #endif + !call upgrade_filename(FileName) + if(WrfIOnotInitialized) then Status = WRF_IO_NOT_INITIALIZED write(msg,*) 'ext_ncd_open_for_write_begin: ext_ncd_ioinit was not called ',__FILE__,', line', __LINE__ @@ -1353,7 +1375,7 @@ SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHand return endif DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - DH%FileName = FileName + DH%FileName = trim(FileName) stat = NF_DEF_DIM(DH%NCID,DH%DimUnlimName,NF_UNLIMITED,DH%DimUnlimID) call netcdf_err(stat,Status) if(Status /= WRF_NO_ERR) then @@ -3020,17 +3042,19 @@ subroutine ext_ncd_inquire_opened( DataHandle, FileName , FileStatus, Status ) implicit none include 'wrf_status_codes.h' integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: FileName + character*(*) ,intent(inout) :: FileName integer ,intent(out) :: FileStatus integer ,intent(out) :: Status type(wrf_data_handle) ,pointer :: DH + !call upgrade_filename(FileName) + call GetDH(DataHandle,DH,Status) if(Status /= WRF_NO_ERR) then FileStatus = WRF_FILE_NOT_OPENED return endif - if(FileName /= DH%FileName) then + if(trim(FileName) /= trim(DH%FileName)) then FileStatus = WRF_FILE_NOT_OPENED else FileStatus = DH%FileStatus @@ -3056,7 +3080,7 @@ subroutine ext_ncd_inquire_filename( Datahandle, FileName, FileStatus, Status ) call wrf_debug ( WARN , TRIM(msg)) return endif - FileName = DH%FileName + FileName = trim(DH%FileName) FileStatus = DH%FileStatus Status = WRF_NO_ERR return diff --git a/wrfv2_fire/external/io_pio/Makefile b/wrfv2_fire/external/io_pio/Makefile new file mode 100644 index 00000000..2f0a8163 --- /dev/null +++ b/wrfv2_fire/external/io_pio/Makefile @@ -0,0 +1,70 @@ +#makefile to build a wrf_io with PIO +#$Id: Makefile 7668 2014-09-29 16:48:30Z huangwei@ucar.edu $ + +FCOPTIM = -O0 -g +FCNOOPT = -O0 -fno-inline -fno-ip -g +FCDEBUG = -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u +FORMAT_FIXED = -FI +FORMAT_FREE = -FR +FCSUFFIX = +BYTESWAPIO = -convert big_endian +FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +FCFLAGS = $(FCOPTIM) $(FCBASEOPTS) + +TRADFLAG = -traditional +CPP = /lib/cpp -P +AR = ar +ARFLAGS = ru +M4 = m4 +RANLIB = ranlib +DM_FC = mpiifort +FC = $(DM_FC) + +OBJS = wrf_data_pio.o pio_routines.o wrf_io.o field_routines.o read_bdy_routines.o module_wrfsi_static.o + +PIOPATH = /glade/p/work/huangwei/lib/intel +FFLAGS = $(FCFLAGS) -I. -I$(PIOPATH)/include -I../ioapi_share -I../../frame -I../esmf_time_f90 +LIBS = -L$(PIOPATH)/lib -lpio +CPP1 = $(CPP) -P $(TRADFLAG) -DINTSPECIAL +M4 = m4 -Uinclude -Uindex -Ulen +AR = ar + +.SUFFIXES: .F90 .f .o + +all : libwrfio_pio.a + +libwrfio_pio.a: $(OBJS) $(CODE) + /bin/rm -f libwrfio_pio.a + $(AR) cr libwrfio_pio.a $(OBJS) + $(RANLIB) libwrfio_pio.a + +wrf_data_pio.o: wrf_data_pio.F90 $(CODE) + $(CPP1) -I. -I$(PIOPATH)/include -I../ioapi_share wrf_data_pio.F90 > wrf_data_pio.f + $(FC) $(FFLAGS) -c wrf_data_pio.f + +pio_routines.o: pio_routines.F90 $(CODE) wrf_data_pio.o + $(CPP1) -I. -I$(PIOPATH)/include -I../ioapi_share pio_routines.F90 > pio_routines.f + $(FC) $(FFLAGS) -c pio_routines.f + +wrf_io.o: wrf_io.F90 $(CODE) wrf_data_pio.o read_bdy_routines.o field_routines.o + $(CPP1) -I. -I$(PIOPATH)/include -I../ioapi_share wrf_io.F90 > wrf_io.f + $(FC) $(FFLAGS) -c wrf_io.f + +module_wrfsi_static.o: module_wrfsi_static.F90 + $(CPP1) -I. -I$(PIOPATH)/include -I../ioapi_share module_wrfsi_static.F90 > module_wrfsi_static.f + $(FC) $(FFLAGS) -c module_wrfsi_static.f + +field_routines.o: field_routines.F90 wrf_data_pio.o pio_routines.o + $(CPP1) -I. -I$(PIOPATH)/include -I../ioapi_share field_routines.F90 > field_routines.f + $(FC) $(FFLAGS) -c field_routines.f + +read_bdy_routines.o: read_bdy_routines.F90 wrf_data_pio.o pio_routines.o + $(CPP1) -I. -I$(PIOPATH)/include -I../ioapi_share read_bdy_routines.F90 > read_bdy_routines.f + $(FC) $(FFLAGS) -c read_bdy_routines.f + +clean: superclean + +superclean: + /bin/rm -f *.f *.o \ + *.mod libwrfio_pio.a diff --git a/wrfv2_fire/external/io_pio/field_routines.F90 b/wrfv2_fire/external/io_pio/field_routines.F90 new file mode 100644 index 00000000..9dd01afa --- /dev/null +++ b/wrfv2_fire/external/io_pio/field_routines.F90 @@ -0,0 +1,190 @@ +!------------------------------------------------------------------ +!$Id: field_routines.F90 7668 2014-09-29 16:48:30Z huangwei@ucar.edu $ +!------------------------------------------------------------------ + +subroutine ext_pio_RealFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Data,Status) + use pio + use pio_kinds + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + logical ,intent(in) :: whole + character (*) ,intent(in) :: IO + type(wrf_data_handle) :: DH + integer,dimension(NVarDims) ,intent(in) :: Starts + integer,dimension(NVarDims) ,intent(in) :: Counts + integer ,intent(in) :: fldsize, datasize + real, dimension(1:fldsize) ,intent(inout) :: Data + integer ,intent(out) :: Status + integer :: stat + real, parameter :: fillvalue = 9.96921e+36 + + if(IO == 'write') then + if(whole)then + stat = pio_put_var(DH%file_handle,DH%descVar(DH%CurrentVariable), & + Starts,Counts,Data(1:datasize)) + else + call pio_write_darray(DH%file_handle, DH%descVar(DH%CurrentVariable), & + DH%ioVar(DH%CurrentVariable), Data, stat, fillvalue) + end if + else + if(whole)then + stat = pio_get_var(DH%file_handle,DH%descVar(DH%CurrentVariable),Data(1:datasize)) + else + call pio_read_darray(DH%file_handle, DH%descVar(DH%CurrentVariable), & + DH%ioVar(DH%CurrentVariable), Data, stat) + end if + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + + return +end subroutine ext_pio_RealFieldIO + +subroutine ext_pio_DoubleFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Data,Status) + use pio + use pio_kinds + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + logical ,intent(in) :: whole + character (*) ,intent(in) :: IO + type(wrf_data_handle) ,pointer :: DH + integer,dimension(NVarDims) ,intent(in) :: Starts + integer,dimension(NVarDims) ,intent(in) :: Counts + integer ,intent(in) :: fldsize, datasize + real*8,dimension(1:fldsize), intent(inout) :: Data + integer ,intent(out) :: Status + integer :: stat + + if(IO == 'write') then + if(whole)then + stat = pio_put_var(DH%file_handle,DH%descVar(DH%CurrentVariable), & + Starts,Counts,Data(1:datasize)) + else + call pio_write_darray(DH%file_handle, DH%descVar(DH%CurrentVariable), & + DH%ioVar(DH%CurrentVariable), Data, stat) + end if + else + if(whole)then + stat = pio_get_var(DH%file_handle,DH%descVar(DH%CurrentVariable),Data) + else + call pio_read_darray(DH%file_handle, DH%descVar(DH%CurrentVariable), & + DH%ioVar(DH%CurrentVariable), Data, stat) + end if + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + return +end subroutine ext_pio_DoubleFieldIO + +subroutine ext_pio_IntFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Data,Status) + use pio + use pio_kinds + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + logical ,intent(in) :: whole + character (*) ,intent(in) :: IO + type(wrf_data_handle) ,pointer :: DH + integer,dimension(NVarDims) ,intent(in) :: Starts + integer,dimension(NVarDims) ,intent(in) :: Counts + integer ,intent(in) :: fldsize, datasize + integer,dimension(1:fldsize),intent(inout) :: Data + integer ,intent(out) :: Status + integer :: stat + integer, parameter :: fillvalue = 20140822 + integer :: Buffer(1) + + !call pio_setdebuglevel(1) + + if(IO == 'write') then + if(whole)then + stat = pio_put_var(DH%file_handle,DH%descVar(DH%CurrentVariable), & + Starts,Counts,Data(1:datasize)) + else + call pio_write_darray(DH%file_handle, DH%descVar(DH%CurrentVariable), & + DH%ioVar(DH%CurrentVariable), Data, stat, fillvalue) + end if + else + if(whole)then + if(1 == fldsize) then + stat = pio_get_var(DH%file_handle,DH%descVar(DH%CurrentVariable),Buffer) + Data(1) = Buffer(1) + else + stat = pio_get_var(DH%file_handle,DH%descVar(DH%CurrentVariable),Data) + endif + else + call pio_read_darray(DH%file_handle, DH%descVar(DH%CurrentVariable), & + DH%ioVar(DH%CurrentVariable), Data, stat) + end if + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + return +end subroutine ext_pio_IntFieldIO + +subroutine ext_pio_LogicalFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Data,Status) + use pio + use pio_kinds + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + logical ,intent(in) :: whole + character (*) ,intent(in) :: IO + type(wrf_data_handle) ,pointer :: DH + integer,dimension(NVarDims) ,intent(in) :: Starts + integer,dimension(NVarDims) ,intent(in) :: Counts + integer ,intent(in) :: fldsize, datasize + logical,dimension(1:fldsize),intent(inout) :: Data + integer ,intent(out) :: Status + integer,dimension(1:fldsize) :: Buffer + integer :: stat + integer :: n + + if(IO == 'write') then + do n=1,fldsize + if(data(n)) then + Buffer(n)=1 + else + Buffer(n)=0 + endif + enddo + if(whole)then + stat = pio_put_var(DH%file_handle,DH%descVar(DH%CurrentVariable), & + Starts,Counts,Buffer(1:datasize)) + else + call pio_write_darray(DH%file_handle, DH%descVar(DH%CurrentVariable), & + DH%ioVar(DH%CurrentVariable), Buffer, stat) + end if + else + if(whole)then + stat = pio_get_var(DH%file_handle,DH%descVar(DH%CurrentVariable),Buffer) + else + call pio_read_darray(DH%file_handle, DH%descVar(DH%CurrentVariable), & + DH%ioVar(DH%CurrentVariable), Buffer, stat) + end if + Data = Buffer == 1 + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + return +end subroutine ext_pio_LogicalFieldIO + diff --git a/wrfv2_fire/external/io_pio/module_wrfsi_static.F90 b/wrfv2_fire/external/io_pio/module_wrfsi_static.F90 new file mode 100644 index 00000000..da408bf5 --- /dev/null +++ b/wrfv2_fire/external/io_pio/module_wrfsi_static.F90 @@ -0,0 +1,102 @@ +MODULE wrfsi_static + use wrf_data_pio + include 'wrf_status_codes.h' + type (iosystem_desc_t), pointer :: iosystem + +CONTAINS + SUBROUTINE open_wrfsi_static(dataroot, FileDesc) + use pio + use pio_kinds + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: dataroot + type(file_desc_t), INTENT(OUT) :: FileDesc + CHARACTER(LEN=255) :: staticfile + LOGICAL :: static_exists + INTEGER :: status + + allocate(iosystem) + + staticfile = TRIM(dataroot) // '/static/static.wrfsi' + INQUIRE(FILE=staticfile, EXIST=static_exists) + IF (static_exists) THEN + status = PIO_openfile(iosystem, FileDesc, & + PIO_iotype_pnetcdf, TRIM(staticfile)) + IF (status .NE. PIO_NOERR) THEN + PRINT '(A,I5)', 'NetCDF error opening WRF static file: ',status + STOP 'open_wrfsi_static' + END IF + ELSE + staticfile = TRIM(dataroot) // '/static/static.wrfsi.rotlat' + INQUIRE(FILE=staticfile, EXIST=static_exists) + IF(static_exists) THEN + status = PIO_openfile(iosystem, FileDesc, & + PIO_iotype_pnetcdf, TRIM(staticfile)) + IF(status .NE. PIO_NOERR) THEN + PRINT '(A,I5)', 'NetCDF error opening WRF static file: ',status + STOP 'open_wrfsi_static' + END IF + ELSE + PRINT '(A)', 'rotlat Static file not found, either: ', staticfile + STOP 'open_wrfsi_static' + ENDIF + + ENDIF + + RETURN + END SUBROUTINE open_wrfsi_static + +!-------------------------------------------------------------------- + SUBROUTINE get_wrfsi_static_dims(dataroot, nx, ny) + + ! Subroutine to return the horizontal dimensions of WRF static file + ! contained in the input dataroot + + use pio + use pio_kinds + + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: dataroot + INTEGER , INTENT(OUT) :: nx + INTEGER , INTENT(OUT) :: ny + + INTEGER :: vid, status + type (file_desc_t) :: FileDesc + + CALL open_wrfsi_static(dataroot, FileDesc) + status = pio_inq_dimid(FileDesc, 'x', vid) + status = pio_inq_dimlen(FileDesc, vid, nx) + status = pio_inq_dimid(FileDesc, 'y', vid) + status = pio_inq_dimlen(FileDesc, vid, ny) + write(unit=*, fmt='(2(A,I5))') 'WRF X-dimension = ',nx, & + ', WRF Y-dimension = ',ny + call pio_closefile(FileDesc) + deallocate(iosystem) + RETURN + END SUBROUTINE get_wrfsi_static_dims + +!-------------------------------------------------------------------- + SUBROUTINE get_wrfsi_static_2d(dataroot, varname, data) + use pio + use pio_kinds + IMPLICIT NONE + !Gets any 2D variable from the static file + CHARACTER(LEN=*), INTENT(IN) :: dataroot + CHARACTER(LEN=*), INTENT(IN) :: varname + REAL, INTENT(OUT) :: data(:,:) + + INTEGER :: vid, status + type (file_desc_t) :: FileDesc + + CALL open_wrfsi_static(dataroot, FileDesc) + status = pio_inq_varid(FileDesc, varname, vid) + status = pio_get_var(FileDesc, vid, data) + !status = get_var_2d_real(FileDesc, vid, data) + IF(status .NE. PIO_NOERR) THEN + write(unit=*, fmt='(A)') 'Problem getting 2D data.' + ENDIF + call pio_closefile(FileDesc) + deallocate(iosystem) + RETURN + END SUBROUTINE get_wrfsi_static_2d +END MODULE wrfsi_static + diff --git a/wrfv2_fire/external/io_pio/pio_routines.F90 b/wrfv2_fire/external/io_pio/pio_routines.F90 new file mode 100644 index 00000000..200c8cd3 --- /dev/null +++ b/wrfv2_fire/external/io_pio/pio_routines.F90 @@ -0,0 +1,2145 @@ +!--------------------------------------------------------------------------- +! +! WRF Parallel I/O +! Author: Wei Huang huangwei@ucar.edu +! Date: June 01, 2014 +! +!--------------------------------------------------------------------------- +!$Id: pio_routines.F90 7687 2014-10-10 04:12:05Z huangwei@ucar.edu $ +!--------------------------------------------------------------------------- + +module pio_routines + + use pio_kinds + use pio + + use module_domain + + use wrf_data_pio + + implicit none + + include 'mpif.h' + + integer(i4) :: nprocs, myrank + integer :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + +CONTAINS + +subroutine allocHandle(DataHandle,DH,Status) + implicit none + include 'wrf_status_codes.h' + integer ,intent(out) :: DataHandle + type(wrf_data_handle),pointer :: DH + integer ,intent(out) :: Status + integer :: i, n + integer :: stat + + do i=1,WrfDataHandleMax + if(WrfDataHandles(i)%Free) then + DH => WrfDataHandles(i) + DataHandle = i + do n = 1, MaxVars + DH%vartype(n) = NOT_LAND_SOIL_VAR + end do + exit + endif + if(i==WrfDataHandleMax) then + Status = WRF_WARN_TOO_MANY_FILES + write(msg,*) 'Warning TOO MANY FILES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + write(msg,*) 'Did you call ext_pio_ioinit?' + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + DH%Free =.false. + DH%Write =.false. + DH%first_operation = .TRUE. + DH%CurrentVariable = 0 + Status = WRF_NO_ERR +end subroutine allocHandle + +subroutine deallocHandle(DataHandle, Status) + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN + if(.NOT. WrfDataHandles(DataHandle)%Free) then + DH => WrfDataHandles(DataHandle) + DH%Free =.TRUE. + endif + + !deallocate(DH%iosystem) + ENDIF + Status = WRF_NO_ERR +end subroutine deallocHandle + +subroutine GetDH(DataHandle,DH,Status) + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + type(wrf_data_handle) ,pointer :: DH + integer ,intent(out) :: Status + + if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then + Status = WRF_WARN_BAD_DATA_HANDLE + return + endif + DH => WrfDataHandles(DataHandle) + if(DH%Free) then + Status = WRF_WARN_BAD_DATA_HANDLE + return + endif + Status = WRF_NO_ERR + return +end subroutine GetDH + +subroutine DateCheck(Date,Status) + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: Date + integer ,intent(out) :: Status + + if(len(Date) /= DateStrLen) then + Status = WRF_WARN_DATESTR_BAD_LENGTH + else + Status = WRF_NO_ERR + endif + return +end subroutine DateCheck + +subroutine GetName(Element,Var,Name,Status) + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + character*(*) ,intent(out) :: Name + integer ,intent(out) :: Status + character (VarNameLen) :: VarName + character (1) :: c + integer :: i + integer, parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') + + VarName = Var + Name = 'MD___'//trim(Element)//VarName + do i=1,len(Name) + c=Name(i:i) + if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower) + if(c=='-'.or.c==':') Name(i:i)='_' + enddo + Status = WRF_NO_ERR + return +end subroutine GetName + +subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) + implicit none + include 'wrf_status_codes.h' + character (*) ,intent(in) :: IO + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + integer ,intent(out) :: TimeIndex + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: VStart(2) + integer :: VCount(2) + integer :: stat + integer :: i + character(len=DateStrLen) :: tmpdatestr(1) + + if(len(Datestr) == DateStrLen) then + tmpdatestr = DateStr + else + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a)') 'IO: <', trim(IO), '>' + write(unit=0, fmt='(a,i3)') 'DataHandle = ', DataHandle + write(unit=0, fmt='(3a)') 'DateStr: <', trim(DateStr), '>' + write(unit=0, fmt='(a,i6,a,i6)') 'DateStrLen = ', DateStrLen, & + ' did not equal len(DateStr): ', len(DateStr) + Status = WRF_WARN_DATESTR_ERROR + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + end if + + DH => WrfDataHandles(DataHandle) + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + Status = WRF_WARN_DATESTR_ERROR + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(IO == 'write') then + TimeIndex = DH%TimeIndex + if(TimeIndex <= 0) then + TimeIndex = 1 + elseif(DateStr == DH%Times(TimeIndex)) then + Status = WRF_NO_ERR + return + else + TimeIndex = TimeIndex + 1 + if(TimeIndex > MaxTimes) then + Status = WRF_WARN_TIME_EOF + write(msg,*) 'Warning TIME EOF in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + endif + DH%TimeIndex = TimeIndex + DH%Times(TimeIndex) = DateStr + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = DateStrLen + VCount(2) = 1 + !write(unit=0, fmt='(3a,i6)') 'DateStr: <', trim(DateStr), '>, TimeIndex =', TimeIndex + stat = pio_put_var(DH%file_handle, DH%vtime, VStart, VCount, tmpdatestr) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + !call pio_advanceframe(DH%vtime) + else + do i=1,MaxTimes + if(DH%Times(i)==DateStr) then + Status = WRF_NO_ERR + TimeIndex = i + exit + endif + if(i==MaxTimes) then + Status = WRF_WARN_TIME_NF + write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + endif + return +end subroutine GetTimeIndex + +subroutine GetDim(MemoryOrder,NDim,Status) + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + integer ,intent(out) :: NDim + integer ,intent(out) :: Status + character*3 :: MemOrd + + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) + case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') + NDim = 3 + case ('xy','yx','xs','xe','ys','ye') + NDim = 2 + case ('z','c') + NDim = 1 + case ('0') ! NDim=0 for scalars. TBH: 20060502 + NDim = 0 + case default + print *, 'memory order = ',MemOrd,' ',MemoryOrder + Status = WRF_WARN_BAD_MEMORYORDER + return + end select + Status = WRF_NO_ERR + return +end subroutine GetDim + +subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2) + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: NDim + integer ,dimension(*),intent(in) :: Start,End + integer ,intent(out) :: i1,i2,j1,j2,k1,k2 + + i1=1 + i2=1 + j1=1 + j2=1 + k1=1 + k2=1 + if(NDim == 0) return ! NDim=0 for scalars. TBH: 20060502 + i1 = Start(1) + i2 = End (1) + if(NDim == 1) return + j1 = Start(2) + j2 = End (2) + if(NDim == 2) return + k1 = Start(3) + k2 = End (3) + return +end subroutine GetIndices + +logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status) + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + integer,dimension(*) ,intent(in) :: Vector + integer ,intent(out) :: Status + integer :: NDim + integer,dimension(NVarDims) :: temp + character*3 :: MemOrd + logical zero_length + + call GetDim(MemoryOrder,NDim,Status) + temp(1:NDim) = Vector(1:NDim) + call LowerCase(MemoryOrder,MemOrd) + zero_length = .false. + select case (MemOrd) + case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c') + continue + case ('0') + continue ! NDim=0 for scalars. TBH: 20060502 + case ('xzy','yzx') + zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1 + case ('xy','yx','xyz','yxz') + zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1 + case ('zxy','zyx') + zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1 + case default + Status = WRF_WARN_BAD_MEMORYORDER + ZeroLengthHorzDim = .true. + return + end select + Status = WRF_NO_ERR + ZeroLengthHorzDim = zero_length + return +end function ZeroLengthHorzDim + +subroutine ExtOrder(MemoryOrder,Vector,Status) + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + integer,dimension(*) ,intent(inout) :: Vector + integer ,intent(out) :: Status + integer :: NDim + integer,dimension(NVarDims) :: temp + character*3 :: MemOrd + + call GetDim(MemoryOrder,NDim,Status) + temp(1:NDim) = Vector(1:NDim) + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) + + case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') + continue + case ('0') + continue ! NDim=0 for scalars. TBH: 20060502 + case ('xzy') + Vector(2) = temp(3) + Vector(3) = temp(2) + case ('yxz') + Vector(1) = temp(2) + Vector(2) = temp(1) + case ('yzx') + Vector(1) = temp(3) + Vector(2) = temp(1) + Vector(3) = temp(2) + case ('zxy') + Vector(1) = temp(2) + Vector(2) = temp(3) + Vector(3) = temp(1) + case ('zyx') + Vector(1) = temp(3) + Vector(3) = temp(1) + case ('yx') + Vector(1) = temp(2) + Vector(2) = temp(1) + case default + Status = WRF_WARN_BAD_MEMORYORDER + return + end select + Status = WRF_NO_ERR + return +end subroutine ExtOrder + +subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status) + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + character*(*),dimension(*) ,intent(in) :: Vector + character(80),dimension(NVarDims),intent(out) :: ROVector + integer ,intent(out) :: Status + integer :: NDim + character*3 :: MemOrd + + call GetDim(MemoryOrder,NDim,Status) + ROVector(1:NDim) = Vector(1:NDim) + call LowerCase(MemoryOrder,MemOrd) + select case (MemOrd) + + case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') + continue + case ('0') + continue ! NDim=0 for scalars. TBH: 20060502 + case ('xzy') + ROVector(2) = Vector(3) + ROVector(3) = Vector(2) + case ('yxz') + ROVector(1) = Vector(2) + ROVector(2) = Vector(1) + case ('yzx') + ROVector(1) = Vector(3) + ROVector(2) = Vector(1) + ROVector(3) = Vector(2) + case ('zxy') + ROVector(1) = Vector(2) + ROVector(2) = Vector(3) + ROVector(3) = Vector(1) + case ('zyx') + ROVector(1) = Vector(3) + ROVector(3) = Vector(1) + case ('yx') + ROVector(1) = Vector(2) + ROVector(2) = Vector(1) + case default + Status = WRF_WARN_BAD_MEMORYORDER + return + end select + Status = WRF_NO_ERR + return +end subroutine ExtOrderStr + + +subroutine LowerCase(MemoryOrder,MemOrd) + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(out) :: MemOrd + character*1 :: c + integer ,parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') + integer :: i,N + + MemOrd = ' ' + N = len(MemoryOrder) + MemOrd(1:N) = MemoryOrder(1:N) + do i=1,N + c = MemoryOrder(i:i) + if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower) + enddo + return +end subroutine LowerCase + +subroutine UpperCase(MemoryOrder,MemOrd) + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(out) :: MemOrd + character*1 :: c + integer ,parameter :: lower_to_upper =IACHAR('A')-IACHAR('a') + integer :: i,N + + MemOrd = ' ' + N = len(MemoryOrder) + MemOrd(1:N) = MemoryOrder(1:N) + do i=1,N + c = MemoryOrder(i:i) + if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper) + enddo + return +end subroutine UpperCase + +subroutine netcdf_err(err,Status) + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: err + integer ,intent(out) :: Status + character(len=80) :: errmsg + integer :: stat + + if(err == PIO_NOERR)then + Status = WRF_NO_ERR + else + write(msg,*) 'NetCDF error: ', 'from PIO' + call wrf_debug ( WARN , TRIM(msg)) + Status = WRF_WARN_NETCDF + endif + return +end subroutine netcdf_err + +subroutine find_iodesc(DH,MemoryOrder,Stagger,FieldTYpe,whole) + implicit none + type(wrf_data_handle), pointer :: DH + character*(*), intent(in) :: MemoryOrder + character*(*), intent(in) :: Stagger + integer, intent(in) :: FieldType + logical, intent(out) :: whole + character*3 :: MemOrd + character*1 :: Stag + integer ,parameter :: MaxUpperCase=IACHAR('Z') + + whole = .false. + + call LowerCase(MemoryOrder,MemOrd) + call LowerCase(Stagger,Stag) + + select case (MemOrd) + case ('xzy') + select case (FieldType) + case (WRF_REAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_u_real + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_v_real + case ('z') + if(LAND_CAT_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_land_real + else if(SOIL_CAT_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_real + else if(SOIL_LAYERS_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_layers_real + else if(MDL_CPL_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_mdl_cpl_real + else if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_real + else + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_w_real + endif + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_real + end select + case (WRF_DOUBLE) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_u_double + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_v_double + case ('z') + if(LAND_CAT_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_land_double + else if(SOIL_CAT_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_double + else if(SOIL_LAYERS_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_layers_double + else if(MDL_CPL_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_mdl_cpl_double + else if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_double + else + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_w_double + endif + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_double + end select + case (WRF_INTEGER) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_v_int + case ('z') + if(LAND_CAT_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_land_int + else if(SOIL_CAT_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_int + else if(SOIL_LAYERS_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_layers_int + else if(MDL_CPL_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_mdl_cpl_int + else if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_int + else + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_w_int + endif + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_int + end select + case (WRF_LOGICAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_v_int + case ('z') + if(LAND_CAT_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_land_int + else if(SOIL_CAT_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_int + else if(SOIL_LAYERS_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_layers_int + else if(MDL_CPL_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_mdl_cpl_int + else if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_int + else + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_w_int + endif + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_int + end select + case default + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + whole = .true. + return + end select + case ('xy') + select case (FieldType) + case (WRF_REAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_u_real + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_v_real + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_m_real + end select + case (WRF_DOUBLE) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_u_double + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_v_double + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_m_double + end select + case (WRF_INTEGER) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_v_int + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_m_int + end select + case (WRF_LOGICAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_v_int + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_m_int + end select + case default + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + whole = .true. + return + end select + case ('xsz') + DH%vartype(DH%CurrentVariable) = BDY_VAR + select case (FieldType) + case (WRF_REAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_u_real + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_v_real + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_w_real + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_m_real + end select + case (WRF_DOUBLE) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_u_double + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_v_double + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_w_double + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_m_double + end select + case (WRF_INTEGER) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_v_int + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_w_int + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_m_int + end select + case (WRF_LOGICAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_v_int + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_w_int + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_m_int + end select + case default + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + whole = .true. + return + end select + case ('xez') + DH%vartype(DH%CurrentVariable) = BDY_VAR + select case (FieldType) + case (WRF_REAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_u_real + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_v_real + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_w_real + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_m_real + end select + case (WRF_DOUBLE) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_u_double + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_v_double + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_w_double + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_m_double + end select + case (WRF_INTEGER) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_v_int + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_w_int + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_m_int + end select + case (WRF_LOGICAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_v_int + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_w_int + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_m_int + end select + case default + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + whole = .true. + return + end select + case ('ysz') + DH%vartype(DH%CurrentVariable) = BDY_VAR + select case (FieldType) + case (WRF_REAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_u_real + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_v_real + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_w_real + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_m_real + end select + case (WRF_DOUBLE) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_u_double + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_v_double + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_w_double + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_m_double + end select + case (WRF_INTEGER) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_v_int + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_w_int + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_m_int + end select + case (WRF_LOGICAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_v_int + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_w_int + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_m_int + end select + case default + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + whole = .true. + return + end select + case ('yez') + DH%vartype(DH%CurrentVariable) = BDY_VAR + select case (FieldType) + case (WRF_REAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_u_real + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_v_real + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_w_real + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_m_real + end select + case (WRF_DOUBLE) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_u_double + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_v_double + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_w_double + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_m_double + end select + case (WRF_INTEGER) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_v_int + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_w_int + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_m_int + end select + case (WRF_LOGICAL) + select case (Stag) + case ('x') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_u_int + case ('y') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_v_int + case ('z') + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_w_int + case default + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_m_int + end select + case default + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + whole = .true. + return + end select + case ('xs') + DH%vartype(DH%CurrentVariable) = BDY_VAR + select case (FieldType) + case (WRF_REAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xs_m_real + case (WRF_DOUBLE) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xs_m_double + case (WRF_INTEGER) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xs_m_int + case (WRF_LOGICAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xs_m_int + case default + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + whole = .true. + return + end select + case ('xe') + DH%vartype(DH%CurrentVariable) = BDY_VAR + select case (FieldType) + case (WRF_REAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xe_m_real + case (WRF_DOUBLE) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xe_m_double + case (WRF_INTEGER) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xe_m_int + case (WRF_LOGICAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xe_m_int + case default + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + whole = .true. + return + end select + case ('ys') + DH%vartype(DH%CurrentVariable) = BDY_VAR + select case (FieldType) + case (WRF_REAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ys_m_real + case (WRF_DOUBLE) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ys_m_double + case (WRF_INTEGER) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ys_m_int + case (WRF_LOGICAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ys_m_int + case default + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + whole = .true. + return + end select + case ('ye') + DH%vartype(DH%CurrentVariable) = BDY_VAR + select case (FieldType) + case (WRF_REAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ye_m_real + case (WRF_DOUBLE) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ye_m_double + case (WRF_INTEGER) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ye_m_int + case (WRF_LOGICAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ye_m_int + case default + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + whole = .true. + return + end select + case ('xyz') + select case (Stag) + case ('z') + if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then + select case (FieldType) + case (WRF_REAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_real + case (WRF_DOUBLE) + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_double + case (WRF_INTEGER) + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_int + case (WRF_LOGICAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_int + case default + write(msg,*) 'Warning DO NOT KNOW HOW TO HANDLE this FieldType in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_real + end select + else + write(msg,*) 'Warning DO NOT KNOW HOW TO HANDLE THIS VAR KIND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_w_double + end if + case default + write(msg,*) 'Warning DO NOT KNOW HOW TO HANDLE THIS STAG in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_real + end select + !case ('z','c') + ! whole = .true. + case default + whole = .true. + if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then + whole = .false. + end if +#if 0 + select case (FieldType) + case (WRF_REAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc1d_real + case (WRF_DOUBLE) + DH%ioVar(DH%CurrentVariable) = DH%iodesc1d_double + case (WRF_INTEGER) + DH%ioVar(DH%CurrentVariable) = DH%iodesc1d_int + case (WRF_LOGICAL) + DH%ioVar(DH%CurrentVariable) = DH%iodesc1d_int + case default + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + end select +#endif + end select +end subroutine find_iodesc + +logical function is_boundary(MemoryOrder) + + implicit none + + character*(*), intent(in) :: MemoryOrder + + logical :: isbdy + character*3 :: MemOrd + + isbdy = .false. + + call LowerCase(MemoryOrder,MemOrd) + + select case (MemOrd) + case ('xsz', 'xez', 'ysz', 'yez') + isbdy = .true. + case ('xs', 'xe', 'ys', 'ye') + isbdy = .true. + case default + isbdy = .false. + end select + + is_boundary = isbdy +end function is_boundary + +subroutine FieldIO(IO,DataHandle,DateStr,Dimens,Starts,Counts,Length,MemoryOrder, & + Stagger,FieldType,Field,Status) + implicit none + include 'wrf_status_codes.h' + character (*) ,intent(in) :: IO + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + integer,dimension(NVarDims),intent(inout) :: Dimens + integer,dimension(NVarDims),intent(inout) :: Starts + integer,dimension(NVarDims),intent(inout) :: Counts + integer,dimension(NVarDims),intent(in) :: Length + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(in) :: Stagger + integer ,intent(in) :: FieldType + integer,dimension(*) ,intent(inout) :: Field + integer ,intent(out) :: Status + integer :: TimeIndex + logical :: whole, isbdy + integer :: NDim + integer :: fldsize, datasize + integer :: n + type(wrf_data_handle) ,pointer :: DH + integer(KIND=PIO_OFFSET) :: pioidx + + DH => WrfDataHandles(DataHandle) + call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + write(msg,*) ' Bad time index for DateStr = ',DateStr + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call GetDim(MemoryOrder,NDim,Status) + + fldsize = 1 + datasize = 1 + do n = 1, NDim + fldsize = fldsize * Length(n) + datasize = datasize * Counts(n) + end do + + Starts(NDim+1) = TimeIndex + Counts(NDim+1) = 1 + + call find_iodesc(DH,MemoryOrder,Stagger,FieldTYpe,whole) + isbdy = is_boundary(MemoryOrder) + !isbdy = BDY_VAR == DH%vartype(DH%CurrentVariable) + + pioidx = TimeIndex + call pio_setframe(DH%descVar(DH%CurrentVariable), pioidx) + !DH%descVar(DH%CurrentVariable)%rec = TimeIndex + + !write(unit=0, fmt='(3a,i6)') 'File: ', __FILE__, ', line: ', __LINE__ + !write(unit=0, fmt='(3a,l8)') 'IO = ', trim(IO), ', whole = ', whole + !write(unit=0, fmt='(4a)') 'MemoryOrder = ', trim(MemoryOrder), ', Stagger = ', trim(Stagger) + !write(unit=0, fmt='(a,i4,a,i3)') 'DH%vartype(', DH%CurrentVariable, ') = ', DH%vartype(DH%CurrentVariable) + + !if(whole .and. (ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable))) then + ! whole = .false. + !end if + + select case (FieldType) + case (WRF_REAL) + if(isbdy .and. (IO == 'read')) then + Dimens(NDim+1) = TimeIndex + call read_bdy_RealFieldIO(DH,NDim,Dimens,Starts,Counts,Field,Status) + else + call ext_pio_RealFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Field,Status) + endif + case (WRF_DOUBLE) + if(isbdy .and. (IO == 'read')) then + Dimens(NDim+1) = TimeIndex + call read_bdy_DoubleFieldIO(DH,NDim,Dimens,Starts,Counts,Field,Status) + else + call ext_pio_DoubleFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Field,Status) + endif + case (WRF_INTEGER) + call ext_pio_IntFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Field,Status) + case (WRF_LOGICAL) + call ext_pio_LogicalFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Field,Status) + case default + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + end select + + return +end subroutine FieldIO + +subroutine FieldBDY(IO,DataHandle,DateStr,NDim,Domains, & + MemoryStart,MemoryEnd,PatchStart,PatchEnd, & + FieldType,Field,Status) + implicit none + include 'wrf_status_codes.h' + character (*) ,intent(in) :: IO + integer ,intent(in) :: DataHandle,NDim + character*(*) ,intent(in) :: DateStr + integer,dimension(*) ,intent(inout) :: Domains + integer,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer,dimension(*) ,intent(in) :: PatchStart, PatchEnd + integer ,intent(in) :: FieldType + integer,dimension(*) ,intent(inout) :: Field + integer ,intent(out) :: Status + integer :: TimeIndex + type(wrf_data_handle) ,pointer :: DH + integer(KIND=PIO_OFFSET) :: pioidx + + DH => WrfDataHandles(DataHandle) + call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + write(msg,*) ' Bad time index for DateStr = ',DateStr + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + pioidx = TimeIndex + call pio_setframe(DH%descVar(DH%CurrentVariable), pioidx) + !DH%descVar(DH%CurrentVariable)%rec = TimeIndex + Domains(NDim+1) = TimeIndex + + select case (FieldType) + case (WRF_REAL) + call read_bdy_RealFieldIO(DH,NDim,Domains,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Field,Status) + case (WRF_DOUBLE) + call read_bdy_DoubleFieldIO(DH,NDim,Domains,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Field,Status) + case default + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + end select + + return +end subroutine FieldBDY + +! Returns .TRUE. iff it is OK to write time-independent domain metadata to the +! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is +! returned. +LOGICAL FUNCTION ncd_ok_to_put_dom_ti( DataHandle ) + implicit none + include 'wrf_status_codes.h' + INTEGER, INTENT(IN) :: DataHandle + CHARACTER*80 :: fname + INTEGER :: filestate + INTEGER :: Status + LOGICAL :: dryrun, retval + call ext_pio_inquire_filename( DataHandle, fname, filestate, Status ) + IF ( Status /= WRF_NO_ERR ) THEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & + ', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg) ) + retval = .FALSE. + ELSE + dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) + retval = dryrun + ENDIF + ncd_ok_to_put_dom_ti = retval + RETURN +END FUNCTION ncd_ok_to_put_dom_ti + +! Returns .TRUE. iff it is OK to read time-independent domain metadata from the +! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is +! returned. +LOGICAL FUNCTION ncd_ok_to_get_dom_ti( DataHandle ) + implicit none + include 'wrf_status_codes.h' + INTEGER, INTENT(IN) :: DataHandle + CHARACTER*80 :: fname + INTEGER :: filestate + INTEGER :: Status + LOGICAL :: dryrun, retval + call ext_pio_inquire_filename( DataHandle, fname, filestate, Status ) + IF ( Status /= WRF_NO_ERR ) THEN + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & + ', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg) ) + retval = .FALSE. + ELSE + dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) + retval = .NOT. dryrun + ENDIF + ncd_ok_to_get_dom_ti = retval + RETURN +END FUNCTION ncd_ok_to_get_dom_ti + +subroutine initialize_pio(grid, DH) + implicit none + + type(domain) :: grid + type(wrf_data_handle), pointer :: DH + + integer :: ierr + integer(i4) :: communicator, pioprocs, piostart, piostride, pioshift + + communicator = grid%communicator + + if(.not. associated(DH%iosystem)) then + allocate(DH%iosystem) + end if + + DH%Write = 0 + + !call pio_setdebuglevel(1) + + call mpi_comm_size(communicator, nprocs, ierr) + call mpi_comm_rank(communicator, myrank, ierr) + + if(grid%pioprocs > nprocs) then + !Force pioprocs to be nprocs. + pioprocs = nprocs + else if(grid%pioprocs < 1) then + !Force pioprocs to be 1. + pioprocs = 1 + else + pioprocs = grid%pioprocs + endif + + piostride = nprocs / grid%pioprocs + + if((grid%pioprocs * piostride) < nprocs) then + !We expect that: nprocs = piostride * grid%pioprocs + piostride = piostride + 1 + endif + + if(piostride /= grid%piostride) then + !We expect that user's piostride equals what we calculated here. + !If not, override it. + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(a,i6)') 'Calculated piostride = ', piostride, & + 'User provided piostride = ', grid%piostride + endif + + if(grid%pioshift < 0) then + !pioshift can from 0, but can not less than 0, usually, we + if(grid%piostride > 1) then + pioshift = 1 + else + pioshift = 0 + endif + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(a,i6)') 'PIO has forced pioshift to: ', pioshift + else if(grid%pioshift >= grid%piostride) then + !pioshift can not large then piostride + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(a,i6)') 'User provided a pioshift of: ', grid%pioshift + if(grid%piostride > 1) then + pioshift = 1 + else + pioshift = 0 + endif + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(a,i6)') 'PIO has forced pioshift to: ', pioshift + else + pioshift = grid%pioshift + endif + + if(grid%piostart < 0) then + !Force piostart from 0 + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(a,i6)') 'User provided a piostart of: ', grid%piostart + write(unit=0, fmt='(a,i6)') 'PIO has forced piosstart to: ', 0 + piostart = 0 + else + piostart = grid%piostart + endif + + !write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + !write(unit=0, fmt='(2(a,i6))') 'nprocs = ', nprocs, ', myrank = ', myrank + !write(unit=0, fmt='(4(a,i6))') 'pioprocs = ', pioprocs, & + ! ', piostride = ', piostride, & + ! ', piostart = ', piostart, & + ! ', pioshift = ', pioshift + + !call PIO_init to initiate iosystem + !call PIO_init(my_rank, MPI_COMM_WORLD, 4, 0, 4, PIO_rearr_box, iosystem, 1) + !call PIO_init(myrank, MPI_COMM_WORLD, pioprocs, & + + call PIO_init(myrank, communicator, pioprocs, & + piostart, piostride, & + PIO_rearr_box, DH%iosystem, pioshift) + + DH%nprocs = nprocs + DH%myrank = myrank + + DH%piostart = piostart + DH%pioshift = pioshift + DH%pioprocs = pioprocs + DH%piostride = piostride + + call get_ijk_from_grid(grid, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) + +end subroutine initialize_pio + +subroutine define_pio_iodesc(grid, DH) + implicit none + + type(domain) :: grid + type(wrf_data_handle), pointer :: DH + + integer(i4) :: communicator, myrank + integer(i4) :: iostat + + integer(kind=PIO_Offset), & + dimension((ime - ims + 1) * (jme - jms + 1) * (kme - kms + 1)) & + :: compdof_3d + integer(kind=PIO_Offset), & + dimension((ime - ims + 1) * (jme - jms + 1) * grid%num_land_cat) & + :: compdof_3d_land + integer(kind=PIO_Offset), & + dimension((ime - ims + 1) * (jme - jms + 1) * grid%num_soil_cat) & + :: compdof_3d_soil + integer(kind=PIO_Offset), & + dimension((ime - ims + 1) * (jme - jms + 1) * grid%num_soil_layers) & + :: compdof_3d_soil_layers + integer(kind=PIO_Offset), & + dimension((ime - ims + 1) * (jme - jms + 1) * grid%num_ext_model_couple_dom) & + :: compdof_3d_mdl_cpl + integer(kind=PIO_Offset), & + dimension((ime - ims + 1) * (jme - jms + 1) * grid%ensdim) & + :: compdof_3d_ensemble + integer(kind=PIO_Offset), & + dimension((jme - jms + 1) * (kme - kms + 1) * grid%spec_bdy_width ) & + :: compdof_3d_xsz, compdof_3d_xez + integer(kind=PIO_Offset), & + dimension((ime - ims + 1) * (kme - kms + 1) * grid%spec_bdy_width ) & + :: compdof_3d_ysz, compdof_3d_yez + integer(kind=PIO_Offset), & + dimension((jme - jms + 1) * grid%spec_bdy_width ) & + :: compdof_2d_xs, compdof_2d_xe + integer(kind=PIO_Offset), & + dimension((ime - ims + 1) * grid%spec_bdy_width ) & + :: compdof_2d_ys, compdof_2d_ye + integer(kind=PIO_Offset), & + dimension((ime - ims + 1) * (jme - jms + 1)) & + :: compdof_2d + integer :: dims3d(3), dims2d(2), dims2di(3) + integer :: dims3d_xb(3), dims2d_xb(2) + integer :: dims3d_yb(3), dims2d_yb(2) + integer :: dims3d_land(3), dims3d_soil(3), dims3d_soil_layers(3) + integer :: dims3d_mdl_cpl(3) + integer :: dims3d_ensemble(3) + integer :: lite, ljte, lkte + integer :: i, j, k, n, npos + + DH%first_operation = .false. + communicator = grid%communicator + myrank = DH%myrank + +!--For MASS variables + dims3d(1) = ide - 1 + dims3d(2) = jde - 1 + dims3d(3) = kde - 1 + + lite = ite + ljte = jte + lkte = kte + + if(lite > dims3d(1)) lite = dims3d(1) + if(ljte > dims3d(2)) ljte = dims3d(2) + if(lkte > dims3d(3)) lkte = dims3d(3) + + dims3d_land(1) = dims3d(1) + dims3d_land(2) = dims3d(2) + dims3d_land(3) = grid%num_land_cat + + dims3d_soil(1) = dims3d(1) + dims3d_soil(2) = dims3d(2) + dims3d_soil(3) = grid%num_soil_cat + + dims3d_soil_layers(1) = dims3d(1) + dims3d_soil_layers(2) = dims3d(2) + dims3d_soil_layers(3) = grid%num_soil_layers + + dims3d_mdl_cpl(1) = dims3d(1) + dims3d_mdl_cpl(2) = dims3d(2) + dims3d_mdl_cpl(3) = grid%num_ext_model_couple_dom + + dims3d_ensemble(1) = dims3d(1) + dims3d_ensemble(2) = dims3d(2) + dims3d_ensemble(3) = grid%ensdim + + dims2d(1) = dims3d(1) + dims2d(2) = dims3d(2) + + dims2di(1) = dims3d(1) + dims2di(2) = dims3d(2) + dims2di(3) = 1 + + dims3d_xb(1) = dims3d(2) + dims3d_xb(2) = dims3d(3) + dims3d_xb(3) = grid%spec_bdy_width + + dims3d_yb(1) = dims3d(1) + dims3d_yb(2) = dims3d(3) + dims3d_yb(3) = grid%spec_bdy_width + + dims2d_xb(1) = dims2d(2) + dims2d_xb(2) = grid%spec_bdy_width + + dims2d_yb(1) = dims2d(1) + dims2d_yb(2) = grid%spec_bdy_width + + !write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + !write(unit=0, fmt='(a, 6i6)') 'dims2d = ', dims2d + !write(unit=0, fmt='(a, 6i6)') 'dims3d = ', dims3d + !write(unit=0, fmt='(a, 6i6)') 'dims3d_land = ', dims3d_land + !write(unit=0, fmt='(a, 6i6)') 'dims3d_soil = ', dims3d_soil + !write(unit=0, fmt='(a, 6i6)') 'grid%num_land_cat = ', grid%num_land_cat + !write(unit=0, fmt='(a, 6i6)') 'grid%num_soil_cat = ', grid%num_soil_cat + !write(unit=0, fmt='(a, 6i6)') 'grid%num_soil_layers = ', grid%num_soil_layers + !write(unit=0, fmt='(a, 6i6)') 'grid%num_ext_model_couple_dom = ', grid%num_ext_model_couple_dom + !write(unit=0, fmt='(a, 6i6)') 'grid%spec_bdy_width = ', grid%spec_bdy_width + + do j = jms, jme + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) + compdof_2d(npos) = 0 + enddo + + do k = kms, kme + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) + compdof_3d(npos) = 0 + enddo + enddo + + do k = 1, dims3d_land(3) + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_land(3) * (j - jms)) + compdof_3d_land(npos) = 0 + enddo + enddo + + do k = 1, dims3d_soil(3) + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_soil(3) * (j - jms)) + compdof_3d_soil(npos) = 0 + enddo + enddo + + do k = 1, dims3d_soil_layers(3) + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_soil_layers(3) * (j - jms)) + compdof_3d_soil_layers(npos) = 0 + enddo + enddo + + do k = 1, dims3d_mdl_cpl(3) + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_mdl_cpl(3) * (j - jms)) + compdof_3d_mdl_cpl(npos) = 0 + enddo + enddo + enddo + + do n = 1, grid%spec_bdy_width + do i = ims, ime + npos = i - ims + 1 + (ime - ims + 1) * (n - 1) + compdof_2d_ys(npos) = 0 + compdof_2d_ye(npos) = 0 + enddo + + do j = jms, jme + npos = j - jms + 1 + (jme - jms + 1) * (n - 1) + compdof_2d_xs(npos) = 0 + compdof_2d_xe(npos) = 0 + enddo + + do k = kms, kme + do i = ims, ime + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_ysz(npos) = 0 + compdof_3d_yez(npos) = 0 + enddo + enddo + + do k = kms, kme + do j = jms, jme + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xsz(npos) = 0 + compdof_3d_xez(npos) = 0 + enddo + enddo + enddo + + do j = jts, ljte + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) + compdof_2d(npos) = i + dims2d(1) * (j - 1) + end do + + do k = kts, lkte + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) + compdof_3d(npos) = i + dims3d(1) * (j - 1 + dims3d(2) * (k - 1)) + enddo + enddo + + do k = 1, dims3d_land(3) + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_land(3) * (j - jms)) + compdof_3d_land(npos) = i + dims3d_land(1) * (j - 1 + dims3d_land(2) * (k - 1)) + enddo + enddo + + do k = 1, dims3d_soil(3) + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_soil(3) * (j - jms)) + compdof_3d_soil(npos) = i + dims3d_soil(1) * (j - 1 + dims3d_soil(2) * (k - 1)) + enddo + enddo + + do k = 1, dims3d_soil_layers(3) + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_soil_layers(3) * (j - jms)) + compdof_3d_soil_layers(npos) = i + dims3d_soil_layers(1) * (j - 1 + dims3d_soil_layers(2) * (k - 1)) + enddo + enddo + + do k = 1, dims3d_mdl_cpl(3) + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_mdl_cpl(3) * (j - jms)) + compdof_3d_mdl_cpl(npos) = i + dims3d_mdl_cpl(1) * (j - 1 + dims3d_mdl_cpl(2) * (k - 1)) + enddo + enddo + enddo + + do k = 1, dims3d_ensemble(3) + do j = jms, jme + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (j - jms + (jme - jms + 1) * (k - 1)) + compdof_3d_ensemble(npos) = 0 + enddo + enddo + + do j = jts, ljte + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (j - jms + (jme - jms + 1) * (k - 1)) + compdof_3d_ensemble(npos) = i + dims3d_ensemble(1) * (j - 1 + dims3d_ensemble(2) * (k - 1)) + enddo + enddo + enddo + + !write(unit=0, fmt='(3a,i6)') 'File: ', __FILE__, ', line: ', __LINE__ + !write(unit=0, fmt='(4x,a,i6)') 'npos = ', npos + !write(unit=0, fmt='(4x,a,i16)') 'compdof_3d_ensemble(npos) = ', compdof_3d_ensemble(npos) + + if(1 == its) then + do n = 1, grid%spec_bdy_width + do j = jts, ljte + npos = j - jms + 1 + (jme - jms + 1) * (n - 1) + compdof_2d_xs(npos) = j + dims2d_xb(1) * (n - 1) + enddo + enddo + endif + + if(1 == jts) then + do n = 1, grid%spec_bdy_width + do i = its, lite + npos = i - ims + 1 + (ime - ims + 1) * (n - 1) + compdof_2d_ys(npos) = i + dims2d_yb(1) * (n - 1) + enddo + enddo + endif + + if(dims2d(1) == lite) then + do n = 1, grid%spec_bdy_width + do j = jts, ljte + npos = j - jms + 1 + (jme - jms + 1) * (n - 1) + compdof_2d_xe(npos) = j + dims2d_xb(1) * (n - 1) + enddo + enddo + endif + + if(dims2d(2) == ljte) then + do n = 1, grid%spec_bdy_width + do i = its, lite + npos = i - ims + 1 + (ime - ims + 1) * (n - 1) + compdof_2d_ye(npos) = i + dims2d_yb(1) * (n - 1) + enddo + enddo + endif + + if(1 == its) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do j = jts, ljte + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xsz(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(1 == jts) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do i = its, lite + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_ysz(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(dims2d(1) == lite) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do j = jts, ljte + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xez(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(dims2d(2) == ljte) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do i = its, lite + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_yez(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) + enddo + enddo + enddo + endif + +!--call init_decomp in order to setup the IO decomposition with PIO + !call pio_setdebuglevel(1) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d, compdof_3d, DH%iodesc3d_m_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d, compdof_3d, DH%iodesc3d_m_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d, compdof_3d, DH%iodesc3d_m_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_land, compdof_3d_land, DH%iodesc3d_land_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_land, compdof_3d_land, DH%iodesc3d_land_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_land, compdof_3d_land, DH%iodesc3d_land_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_soil, compdof_3d_soil, DH%iodesc3d_soil_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_soil, compdof_3d_soil, DH%iodesc3d_soil_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_soil, compdof_3d_soil, DH%iodesc3d_soil_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_soil_layers, compdof_3d_soil_layers, DH%iodesc3d_soil_layers_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_soil_layers, compdof_3d_soil_layers, DH%iodesc3d_soil_layers_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_soil_layers, compdof_3d_soil_layers, DH%iodesc3d_soil_layers_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_mdl_cpl, compdof_3d_mdl_cpl, DH%iodesc3d_mdl_cpl_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_mdl_cpl, compdof_3d_mdl_cpl, DH%iodesc3d_mdl_cpl_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_mdl_cpl, compdof_3d_mdl_cpl, DH%iodesc3d_mdl_cpl_double) + + !call pio_setdebuglevel(1) + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_ensemble, compdof_3d_ensemble, DH%iodesc3d_ensemble_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_ensemble, compdof_3d_ensemble, DH%iodesc3d_ensemble_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_ensemble, compdof_3d_ensemble, DH%iodesc3d_ensemble_double) + !call pio_setdebuglevel(0) + +#ifndef INTSPECIAL + call PIO_initdecomp(DH%iosystem, PIO_int, dims2d, compdof_2d, DH%iodesc2d_m_int) +#else + call PIO_initdecomp(DH%iosystem, PIO_int, dims2di, compdof_2d, DH%iodesc2d_m_int) +#endif + call PIO_initdecomp(DH%iosystem, PIO_real, dims2d, compdof_2d, DH%iodesc2d_m_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims2d, compdof_2d, DH%iodesc2d_m_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_m_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_m_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_m_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_m_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_m_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_m_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_m_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_m_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_m_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_m_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_m_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_m_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims2d_xb, compdof_2d_xs, DH%iodesc2d_xs_m_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims2d_xb, compdof_2d_xs, DH%iodesc2d_xs_m_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims2d_xb, compdof_2d_xs, DH%iodesc2d_xs_m_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims2d_xb, compdof_2d_xe, DH%iodesc2d_xe_m_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims2d_xb, compdof_2d_xe, DH%iodesc2d_xe_m_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims2d_xb, compdof_2d_xe, DH%iodesc2d_xe_m_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims2d_yb, compdof_2d_ys, DH%iodesc2d_ys_m_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims2d_yb, compdof_2d_ys, DH%iodesc2d_ys_m_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims2d_yb, compdof_2d_ys, DH%iodesc2d_ys_m_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims2d_yb, compdof_2d_ye, DH%iodesc2d_ye_m_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims2d_yb, compdof_2d_ye, DH%iodesc2d_ye_m_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims2d_yb, compdof_2d_ye, DH%iodesc2d_ye_m_double) + +!--For X-STAG variables + dims3d(1) = ide + dims3d(2) = jde - 1 + dims3d(3) = kde - 1 + + lite = ite + ljte = jte + lkte = kte + + if(lite > dims3d(1)) lite = dims3d(1) + if(ljte > dims3d(2)) ljte = dims3d(2) + if(lkte > dims3d(3)) lkte = dims3d(3) + + dims2d(1) = dims3d(1) + dims2d(2) = dims3d(2) + + dims3d_xb(1) = dims3d(2) + dims3d_xb(2) = dims3d(3) + dims3d_xb(3) = grid%spec_bdy_width + + dims3d_yb(1) = dims3d(1) + dims3d_yb(2) = dims3d(3) + dims3d_yb(3) = grid%spec_bdy_width + + !compdof_3d = 0 + !compdof_2d = 0 + + do j = jms, jme + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) + compdof_2d(npos) = 0 + enddo + + do k = kms, kme + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) + compdof_3d(npos) = 0 + enddo + enddo + enddo + + do n = 1, grid%spec_bdy_width + do k = kms, kme + do i = ims, ime + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_ysz(npos) = 0 + compdof_3d_yez(npos) = 0 + enddo + enddo + + do k = kms, kme + do j = jms, jme + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xsz(npos) = 0 + compdof_3d_xez(npos) = 0 + enddo + enddo + enddo + + do j = jts, ljte + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) + compdof_2d(npos) = i + dims2d(1) * (j - 1) + end do + + do k = kts, lkte + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) + compdof_3d(npos) = i + dims3d(1) * (j - 1 + dims3d(2) * (k - 1)) + enddo + enddo + enddo + + if(1 == its) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do j = jts, ljte + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xsz(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(1 == jts) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do i = its, lite + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_ysz(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(dims3d(1) == lite) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do j = jts, ljte + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xez(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(dims3d(2) == ljte) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do i = its, lite + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_yez(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) + enddo + enddo + enddo + endif + +!--call init_decomp in order to setup the IO decomposition with PIO + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d, compdof_3d, DH%iodesc3d_u_double) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d, compdof_3d, DH%iodesc3d_u_real) + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d, compdof_3d, DH%iodesc3d_u_int) + + call PIO_initdecomp(DH%iosystem, PIO_double, dims2d, compdof_2d, DH%iodesc2d_u_double) + call PIO_initdecomp(DH%iosystem, PIO_real, dims2d, compdof_2d, DH%iodesc2d_u_real) + call PIO_initdecomp(DH%iosystem, PIO_int, dims2d, compdof_2d, DH%iodesc2d_u_int) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_u_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_u_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_u_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_u_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_u_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_u_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_u_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_u_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_u_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_u_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_u_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_u_double) + +!--For Y-STAG variables + dims3d(1) = ide - 1 + dims3d(2) = jde + dims3d(3) = kde - 1 + + lite = ite + ljte = jte + lkte = kte + + if(lite > dims3d(1)) lite = dims3d(1) + if(ljte > dims3d(2)) ljte = dims3d(2) + if(lkte > dims3d(3)) lkte = dims3d(3) + + dims2d(1) = dims3d(1) + dims2d(2) = dims3d(2) + + dims3d_xb(1) = dims3d(2) + dims3d_xb(2) = dims3d(3) + dims3d_xb(3) = grid%spec_bdy_width + + dims3d_yb(1) = dims3d(1) + dims3d_yb(2) = dims3d(3) + dims3d_yb(3) = grid%spec_bdy_width + + !compdof_3d = 0 + !compdof_2d = 0 + + do j = jms, jme + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) + compdof_2d(npos) = 0 + enddo + + do k = kms, kme + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) + compdof_3d(npos) = 0 + enddo + enddo + enddo + + do n = 1, grid%spec_bdy_width + do k = kms, kme + do i = ims, ime + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_ysz(npos) = 0 + compdof_3d_yez(npos) = 0 + enddo + enddo + + do k = kms, kme + do j = jms, jme + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xsz(npos) = 0 + compdof_3d_xez(npos) = 0 + enddo + enddo + enddo + + do j = jts, ljte + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) + compdof_2d(npos) = i + dims2d(1) * (j - 1) + end do + + do k = kts, lkte + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) + compdof_3d(npos) = i + dims3d(1) * (j - 1 + dims3d(2) * (k - 1)) + enddo + enddo + enddo + + if(1 == its) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do j = jts, ljte + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xsz(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(1 == jts) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do i = its, lite + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_ysz(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(dims3d(1) == lite) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do j = jts, ljte + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xez(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(dims3d(2) == ljte) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do i = its, lite + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_yez(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) + enddo + enddo + enddo + endif + +!--call init_decomp in order to setup the IO decomposition with PIO + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d, compdof_3d, DH%iodesc3d_v_double) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d, compdof_3d, DH%iodesc3d_v_real) + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d, compdof_3d, DH%iodesc3d_v_int) + + call PIO_initdecomp(DH%iosystem, PIO_double, dims2d, compdof_2d, DH%iodesc2d_v_double) + call PIO_initdecomp(DH%iosystem, PIO_real, dims2d, compdof_2d, DH%iodesc2d_v_real) + call PIO_initdecomp(DH%iosystem, PIO_int, dims2d, compdof_2d, DH%iodesc2d_v_int) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_v_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_v_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_v_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_v_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_v_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_v_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_v_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_v_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_v_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_v_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_v_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_v_double) + +!--For Z-STAG variables + dims3d(1) = ide - 1 + dims3d(2) = jde - 1 + dims3d(3) = kde + + dims2d(1) = dims3d(1) + dims2d(2) = dims3d(2) + + dims3d_xb(1) = dims3d(2) + dims3d_xb(2) = dims3d(3) + dims3d_xb(3) = grid%spec_bdy_width + + dims3d_yb(1) = dims3d(1) + dims3d_yb(2) = dims3d(3) + dims3d_yb(3) = grid%spec_bdy_width + + lite = ite + ljte = jte + lkte = kte + + if(lite > dims3d(1)) lite = dims3d(1) + if(ljte > dims3d(2)) ljte = dims3d(2) + if(lkte > dims3d(3)) lkte = dims3d(3) + + !compdof_3d = 0 + + do j = jms, jme + do k = kms, kme + do i = ims, ime + npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) + compdof_3d(npos) = 0 + enddo + enddo + enddo + + do n = 1, grid%spec_bdy_width + do k = kms, kme + do i = ims, ime + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_ysz(npos) = 0 + compdof_3d_yez(npos) = 0 + enddo + enddo + + do k = kms, kme + do j = jms, jme + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xsz(npos) = 0 + compdof_3d_xez(npos) = 0 + enddo + enddo + enddo + + do j = jts, ljte + do k = kts, lkte + do i = its, lite + npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) + compdof_3d(npos) = i + dims3d(1) * (j - 1 + dims3d(2) * (k - 1)) + enddo + enddo + enddo + + if(1 == its) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do j = jts, ljte + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xsz(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(1 == jts) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do i = its, lite + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_ysz(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(dims3d(1) == lite) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do j = jts, ljte + npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_xez(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) + enddo + enddo + enddo + endif + + if(dims3d(2) == ljte) then + do n = 1, grid%spec_bdy_width + do k = kts, lkte + do i = its, lite + npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) + compdof_3d_yez(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) + enddo + enddo + enddo + endif + +!--call init_decomp in order to setup the IO decomposition with PIO + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d, compdof_3d, DH%iodesc3d_w_double) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d, compdof_3d, DH%iodesc3d_w_real) + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d, compdof_3d, DH%iodesc3d_w_int) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_w_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_w_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_w_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_w_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_w_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_w_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_w_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_w_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_w_double) + + call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_w_int) + call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_w_real) + call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_w_double) + +end subroutine define_pio_iodesc + +subroutine reorder (MemoryOrder,MemO) + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(in) :: MemoryOrder + character*3 ,intent(out) :: MemO + character*3 :: MemOrd + integer :: N,i,i1,i2,i3 + + MemO = MemoryOrder + N = len_trim(MemoryOrder) + if(N == 1) return + call lowercase(MemoryOrder,MemOrd) +! never invert the boundary codes + select case ( MemOrd ) + case ( 'xsz','xez','ysz','yez' ) + return + case default + continue + end select + i1 = 1 + i3 = 1 + do i=2,N + if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i + if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i + enddo + if(N == 2) then + i2=i3 + else + i2 = 6-i1-i3 + endif + MemO(1:1) = MemoryOrder(i1:i1) + MemO(2:2) = MemoryOrder(i2:i2) + if(N == 3) MemO(3:3) = MemoryOrder(i3:i3) + if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then + MemO(1:N-1) = MemO(2:N) + MemO(N:N ) = MemoryOrder(i1:i1) + endif + return +end subroutine reorder + +end module pio_routines + diff --git a/wrfv2_fire/external/io_pio/read_bdy_routines.F90 b/wrfv2_fire/external/io_pio/read_bdy_routines.F90 new file mode 100644 index 00000000..f87a8591 --- /dev/null +++ b/wrfv2_fire/external/io_pio/read_bdy_routines.F90 @@ -0,0 +1,186 @@ +!------------------------------------------------------------------ +!$Id: read_bdy_routines.F90 7621 2014-08-14 20:28:51Z huangwei@ucar.edu $ +!------------------------------------------------------------------ + +subroutine transRg2l(ds1,de1,ds2,de2,ds3,de3, & + ms1,me1,ms2,me2,ms3,me3, & + ps1,pe1,ps2,pe2,ps3,pe3, & + dlocal, dglobal) + integer ,intent(in) :: ds1,de1,ds2,de2,ds3,de3 + integer ,intent(in) :: ms1,me1,ms2,me2,ms3,me3 + integer ,intent(in) :: ps1,pe1,ps2,pe2,ps3,pe3 + real ,intent(out) :: dlocal(ms1:me1,ms2:me2,ms3:me3) + real ,intent(in) :: dglobal(ds1:de1,ds2:de2,ds3:de3) + integer :: i,j,k + +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=ps3,pe3 + do j=ps2,pe2 + do i=ps1,pe1 + dlocal(i,j,k) = dglobal(i,j,k) + enddo + enddo + enddo +!$OMP END PARALLEL DO + return +end subroutine transRg2l + +subroutine transDg2l(ds1,de1,ds2,de2,ds3,de3, & + ms1,me1,ms2,me2,ms3,me3, & + ps1,pe1,ps2,pe2,ps3,pe3, & + dlocal, dglobal) + integer ,intent(in) :: ds1,de1,ds2,de2,ds3,de3 + integer ,intent(in) :: ms1,me1,ms2,me2,ms3,me3 + integer ,intent(in) :: ps1,pe1,ps2,pe2,ps3,pe3 + real*8 ,intent(out) :: dlocal(ms1:me1,ms2:me2,ms3:me3) + real*8 ,intent(in) :: dglobal(ds1:de1,ds2:de2,ds3:de3) + integer :: i,j,k + +!$OMP PARALLEL DO SCHEDULE(RUNTIME) PRIVATE(i,j,k) + do k=ps3,pe3 + do j=ps2,pe2 + do i=ps1,pe1 + dlocal(i,j,k) = dglobal(i,j,k) + enddo + enddo + enddo +!$OMP END PARALLEL DO + return +end subroutine transDg2l + +subroutine read_bdy_RealFieldIO(DH,NDim,Dimens,MemoryStart,MemoryEnd, & + PatchStart,PatchEnd,Data,Status) + use pio + use pio_kinds + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + type(wrf_data_handle) :: DH + integer ,intent(in) :: NDim + integer, dimension(*) ,intent(in) :: Dimens + integer, dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer, dimension(*) ,intent(in) :: PatchStart, PatchEnd + real, dimension(*) ,intent(out) :: Data + integer ,intent(out) :: Status + integer,dimension(4) :: Ones + integer :: stat + integer :: i,k,n,nloc,nglb + real,dimension(Dimens(1)*Dimens(2)*Dimens(3)) :: buffer + + !write(unit=0, fmt='(//3a,i6)') 'file: ',__FILE__,', line', __LINE__ + !write(unit=0, fmt='(4x,a,i3,3a,i2)') 'DH%VarNames(', DH%CurrentVariable, ') = ', & + ! trim(DH%VarNames(DH%CurrentVariable)), ', NDim = ', NDim + !write(unit=0, fmt='(4x,5(a,i6))') & + ! 'Dimens(1)=', Dimens(1), & + ! ', MemoryStart(1)=', MemoryStart(1), & + ! ', MemoryEnd(1)=', MemoryEnd(1), & + ! ', PatchStart(1)=', PatchStart(1), & + ! ', PatchEnd(1)=', PatchEnd(1) + + !call pio_setdebuglevel(10) + + Ones = 1 + + if(3 == NDim) then + stat = pio_get_var(DH%file_handle,DH%descVar(DH%CurrentVariable),Ones,Dimens(1:4),buffer) + else if(2 == NDim) then + stat = pio_get_var(DH%file_handle,DH%descVar(DH%CurrentVariable),Ones(1:3),Dimens(1:3),buffer) + else + stat = -1 + end if + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + + if(3 == Ndim) then + call transRg2l(1,Dimens(1),1,Dimens(2),1,Dimens(3), & + MemoryStart(1),MemoryEnd(1),MemoryStart(2),MemoryEnd(2),MemoryStart(3),MemoryEnd(3), & + PatchStart(1), PatchEnd(1), PatchStart(2), PatchEnd(2), PatchStart(3), PatchEnd(3), & + Data, buffer) + else if(2 == Ndim) then + call transRg2l(1,Dimens(1),1,Dimens(2),1,Dimens(3), & + MemoryStart(1),MemoryEnd(1),MemoryStart(2),MemoryEnd(2),1,1, & + PatchStart(1), PatchEnd(1), PatchStart(2), PatchEnd(2),1,1, & + Data, buffer) + else + write(unit=0, fmt='(/3a,i6)') 'file: ',__FILE__,', line', __LINE__ + write(unit=0, fmt='(a,i6)') 'Do not know how handle NDim = ', NDim + write(unit=0, fmt='(4x,a,i4,a,i3,4x,a,i3)') & + 'DH%vartype(', DH%CurrentVariable, ') =', DH%vartype(DH%CurrentVariable), & + 'BDY_VAR =', BDY_VAR + write(unit=0, fmt='(4x,a,i3,3a,i2)') 'DH%VarNames(', DH%CurrentVariable, ') = ', & + trim(DH%VarNames(DH%CurrentVariable)), ', NDim = ', NDim + end if +end subroutine read_bdy_RealFieldIO + +subroutine read_bdy_DoubleFieldIO(DH,NDim,Dimens,MemoryStart,MemoryEnd, & + PatchStart,PatchEnd,Data,Status) + use pio + use pio_kinds + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + type(wrf_data_handle) :: DH + integer ,intent(in) :: NDim + integer, dimension(*) ,intent(in) :: Dimens + integer, dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer, dimension(*) ,intent(in) :: PatchStart, PatchEnd + real*8, dimension(*) ,intent(out) :: Data + integer ,intent(out) :: Status + integer,dimension(4) :: Ones + integer :: stat + integer :: i,k,n,nloc,nglb + real*8,dimension(Dimens(1)*Dimens(2)*Dimens(3)) :: buffer + + !write(unit=0, fmt='(//3a,i6)') 'file: ',__FILE__,', line', __LINE__ + !write(unit=0, fmt='(4x,a,i3,3a,i2)') 'DH%VarNames(', DH%CurrentVariable, ') = ', & + ! trim(DH%VarNames(DH%CurrentVariable)), ', NDim = ', NDim + !write(unit=0, fmt='(4x,5(a,i6))') & + ! 'Dimens(1)=', Dimens(1), & + ! ', MemoryStart(1)=', MemoryStart(1), & + ! ', MemoryEnd(1)=', MemoryEnd(1), & + ! ', PatchStart(1)=', PatchStart(1), & + ! ', PatchEnd(1)=', PatchEnd(1) + + !call pio_setdebuglevel(10) + + Ones = 1 + + if(3 == NDim) then + stat = pio_get_var(DH%file_handle,DH%descVar(DH%CurrentVariable),Ones,Dimens(1:4),buffer) + else if(2 == NDim) then + stat = pio_get_var(DH%file_handle,DH%descVar(DH%CurrentVariable),Ones(1:3),Dimens(1:3),buffer) + else + stat = -1 + end if + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + + if(3 == Ndim) then + call transDg2l(1,Dimens(1),1,Dimens(2),1,Dimens(3), & + MemoryStart(1),MemoryEnd(1),MemoryStart(2),MemoryEnd(2),MemoryStart(3),MemoryEnd(3), & + PatchStart(1), PatchEnd(1), PatchStart(2), PatchEnd(2), PatchStart(3), PatchEnd(3), & + Data, buffer) + else if(2 == Ndim) then + call transDg2l(1,Dimens(1),1,Dimens(2),1,Dimens(3), & + MemoryStart(1),MemoryEnd(1),MemoryStart(2),MemoryEnd(2),1,1, & + PatchStart(1), PatchEnd(1), PatchStart(2), PatchEnd(2),1,1, & + Data, buffer) + else + write(unit=0, fmt='(/3a,i6)') 'file: ',__FILE__,', line', __LINE__ + write(unit=0, fmt='(a,i6)') 'Do not know how handle NDim = ', NDim + write(unit=0, fmt='(4x,a,i4,a,i3,4x,a,i3)') & + 'DH%vartype(', DH%CurrentVariable, ') =', DH%vartype(DH%CurrentVariable), & + 'BDY_VAR =', BDY_VAR + write(unit=0, fmt='(4x,a,i3,3a,i2)') 'DH%VarNames(', DH%CurrentVariable, ') = ', & + trim(DH%VarNames(DH%CurrentVariable)), ', NDim = ', NDim + end if +end subroutine read_bdy_DoubleFieldIO + diff --git a/wrfv2_fire/external/io_pio/wrf_data_pio.F90 b/wrfv2_fire/external/io_pio/wrf_data_pio.F90 new file mode 100644 index 00000000..01a666ed --- /dev/null +++ b/wrfv2_fire/external/io_pio/wrf_data_pio.F90 @@ -0,0 +1,136 @@ +!--------------------------------------------------------------------------- +! +! WRF Parallel I/O +! Author: Wei Huang huangwei@ucar.edu +! Date: May 8, 2014 +! +!--------------------------------------------------------------------------- +!$Id: wrf_data_pio.F90 7681 2014-10-08 21:23:55Z huangwei@ucar.edu $ +!--------------------------------------------------------------------------- + +module wrf_data_pio + + use pio + use pio_kinds + + integer , parameter :: FATAL = 0 + integer , parameter :: WARN = 0 + integer , parameter :: WrfDataHandleMax = 99 + integer , parameter :: MaxDims = 1000 ! = NF_MAX_VARS + integer , parameter :: MaxVars = 3000 + integer , parameter :: MaxTimes = 10000 + integer , parameter :: DateStrLen = 19 + integer , parameter :: VarNameLen = 31 + integer , parameter :: NO_DIM = 0 + integer , parameter :: NVarDims = 5 + integer , parameter :: NMDVarDims = 2 + integer , parameter :: NOT_LAND_SOIL_VAR= 0 + integer , parameter :: LAND_CAT_VAR = 1 + integer , parameter :: SOIL_CAT_VAR = 2 + integer , parameter :: SOIL_LAYERS_VAR = 3 + integer , parameter :: MDL_CPL_VAR = 4 + integer , parameter :: ENSEMBLE_VAR = 5 + integer , parameter :: BDY_VAR = 10 + character (8) , parameter :: NO_NAME = 'NULL' + character (DateStrLen) , parameter :: ZeroDate = '0000-00-00-00:00:00' + +#include "wrf_io_flags.h" + + character (256) :: msg + logical :: WrfIOnotInitialized = .true. + + type :: wrf_data_handle + character (255) :: FileName + integer :: FileStatus + logical :: Free + logical :: Write + character (5) :: TimesName + integer :: TimeIndex + integer :: CurrentTime !Only used for read + integer :: NumberTimes !Only used for read + character (DateStrLen), dimension(MaxTimes) :: Times + integer , dimension(MaxDims) :: DimLengths + integer , dimension(MaxDims) :: DimIDs + character (31) , dimension(MaxDims) :: DimNames + integer :: DimUnlimID + character (9) :: DimUnlimName + integer , dimension(MaxVars) :: VarIDs + integer , dimension(NVarDims-1, MaxVars) :: VarDimLens + character (VarNameLen), dimension(MaxVars) :: VarNames + integer :: CurrentVariable + integer :: NumDims + integer :: NumVars +! first_operation is set to .TRUE. when a new handle is allocated +! or when open-for-write or open-for-read are committed. It is set +! to .FALSE. when the first field is read or written. + logical :: first_operation + +!--PIO specific + type (IOsystem_desc_t), pointer :: iosystem ! PIO type handle to hold PIO-specific information + ! about a file IO decomposition + type (File_desc_t) :: file_handle ! file handle for normal PIO variables + + type (Var_desc_t) :: vtime + + type (io_desc_t) :: iodesc3d_m_double, iodesc3d_u_double, iodesc3d_v_double, iodesc3d_w_double + type (io_desc_t) :: iodesc2d_m_double, iodesc2d_u_double, iodesc2d_v_double, iodesc2d_char_double + type (io_desc_t) :: iodesc3d_m_real, iodesc3d_u_real, iodesc3d_v_real, iodesc3d_w_real + type (io_desc_t) :: iodesc2d_m_real, iodesc2d_u_real, iodesc2d_v_real, iodesc2d_char_real + type (io_desc_t) :: iodesc3d_m_int, iodesc3d_u_int, iodesc3d_v_int, iodesc3d_w_int + type (io_desc_t) :: iodesc2d_m_int, iodesc2d_u_int, iodesc2d_v_int, iodesc2d_char_int + + !type (io_desc_t) :: iodesc1d_double + !type (io_desc_t) :: iodesc1d_real + !type (io_desc_t) :: iodesc1d_int + + type (io_desc_t) :: iodesc3d_land_double, iodesc3d_soil_double, iodesc3d_soil_layers_double + type (io_desc_t) :: iodesc3d_land_real, iodesc3d_soil_real, iodesc3d_soil_layers_real + type (io_desc_t) :: iodesc3d_land_int, iodesc3d_soil_int, iodesc3d_soil_layers_int + + type (io_desc_t) :: iodesc3d_mdl_cpl_double + type (io_desc_t) :: iodesc3d_mdl_cpl_real + type (io_desc_t) :: iodesc3d_mdl_cpl_int + + type (io_desc_t) :: iodesc3d_ensemble_double + type (io_desc_t) :: iodesc3d_ensemble_real + type (io_desc_t) :: iodesc3d_ensemble_int + + type (io_desc_t) :: iodesc3d_xsz_u_real, iodesc3d_xsz_u_double, iodesc3d_xsz_u_int + type (io_desc_t) :: iodesc3d_xsz_v_real, iodesc3d_xsz_v_double, iodesc3d_xsz_v_int + type (io_desc_t) :: iodesc3d_xsz_w_real, iodesc3d_xsz_w_double, iodesc3d_xsz_w_int + type (io_desc_t) :: iodesc3d_xsz_m_real, iodesc3d_xsz_m_double, iodesc3d_xsz_m_int + + type (io_desc_t) :: iodesc3d_xez_u_real, iodesc3d_xez_u_double, iodesc3d_xez_u_int + type (io_desc_t) :: iodesc3d_xez_v_real, iodesc3d_xez_v_double, iodesc3d_xez_v_int + type (io_desc_t) :: iodesc3d_xez_w_real, iodesc3d_xez_w_double, iodesc3d_xez_w_int + type (io_desc_t) :: iodesc3d_xez_m_real, iodesc3d_xez_m_double, iodesc3d_xez_m_int + + type (io_desc_t) :: iodesc3d_ysz_u_real, iodesc3d_ysz_u_double, iodesc3d_ysz_u_int + type (io_desc_t) :: iodesc3d_ysz_v_real, iodesc3d_ysz_v_double, iodesc3d_ysz_v_int + type (io_desc_t) :: iodesc3d_ysz_w_real, iodesc3d_ysz_w_double, iodesc3d_ysz_w_int + type (io_desc_t) :: iodesc3d_ysz_m_real, iodesc3d_ysz_m_double, iodesc3d_ysz_m_int + + type (io_desc_t) :: iodesc3d_yez_u_real, iodesc3d_yez_u_double, iodesc3d_yez_u_int + type (io_desc_t) :: iodesc3d_yez_v_real, iodesc3d_yez_v_double, iodesc3d_yez_v_int + type (io_desc_t) :: iodesc3d_yez_w_real, iodesc3d_yez_w_double, iodesc3d_yez_w_int + type (io_desc_t) :: iodesc3d_yez_m_real, iodesc3d_yez_m_double, iodesc3d_yez_m_int + + type (io_desc_t) :: iodesc2d_xs_m_real, iodesc2d_xs_m_double, iodesc2d_xs_m_int + type (io_desc_t) :: iodesc2d_xe_m_real, iodesc2d_xe_m_double, iodesc2d_xe_m_int + type (io_desc_t) :: iodesc2d_ys_m_real, iodesc2d_ys_m_double, iodesc2d_ys_m_int + type (io_desc_t) :: iodesc2d_ye_m_real, iodesc2d_ye_m_double, iodesc2d_ye_m_int + + type (Var_desc_t), dimension(MaxVars) :: descVar + type (io_desc_t), dimension(MaxVars) :: ioVar + integer, dimension(MaxVars) :: vartype + + integer(i4) :: iostat ! PIO-specific io status + integer(i4) :: myrank, nprocs + integer(i4) :: pioprocs, piostart, piostride, pioshift + ! the 3D grid size used to write VDC data + end type wrf_data_handle + + type(wrf_data_handle),target :: WrfDataHandles(WrfDataHandleMax) + +end module wrf_data_pio + diff --git a/wrfv2_fire/external/io_pio/wrf_io.F90 b/wrfv2_fire/external/io_pio/wrf_io.F90 new file mode 100644 index 00000000..a55ecc8b --- /dev/null +++ b/wrfv2_fire/external/io_pio/wrf_io.F90 @@ -0,0 +1,9163 @@ +!------------------------------------------------------------------ +!$Id: wrf_io.F90 7685 2014-10-10 01:58:54Z huangwei@ucar.edu $ +!------------------------------------------------------------------ + +subroutine ext_pio_open_for_read(DatasetName, grid, SysDepInfo, DataHandle, Status) + use wrf_data_pio + use pio_routines + use module_domain + implicit none + include 'wrf_status_codes.h' + character *(*), INTENT(IN) :: DatasetName + TYPE(domain) :: grid + character *(*), INTENT(IN) :: SysDepInfo + integer , INTENT(OUT) :: DataHandle + integer , INTENT(OUT) :: Status + DataHandle = 0 ! dummy setting to quiet warning message + CALL ext_pio_open_for_read_begin( DatasetName, grid, SysDepInfo, DataHandle, Status ) + IF ( Status .EQ. WRF_NO_ERR ) THEN + CALL ext_pio_open_for_read_commit( DataHandle, Status ) + ENDIF + return +end subroutine ext_pio_open_for_read + +!ends training phase; switches internal flag to enable input +!must be paired with call to ext_pio_open_for_read_begin +subroutine ext_pio_open_for_read_commit(DataHandle, Status) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer, intent(in) :: DataHandle + integer, intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_pio_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_FOR_READ + Status = WRF_NO_ERR + return +end subroutine ext_pio_open_for_read_commit + +subroutine upgrade_filename(FileName) + implicit none + + character*(*), intent(inout) :: FileName + integer :: i + + do i = 1, len(trim(FileName)) + if(FileName(i:i) == '-') then + FileName(i:i) = '_' + else if(FileName(i:i) == ':') then + FileName(i:i) = '_' + endif + enddo + +end subroutine upgrade_filename + +subroutine ext_pio_open_for_read_begin( FileName, grid, SysDepInfo, DataHandle, Status) + use wrf_data_pio + use pio_routines + use module_domain + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(INOUT) :: FileName + TYPE(domain) :: grid + character*(*) ,intent(in) :: SysDepInfo + integer ,intent(out) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: stat + integer :: StoredDim + integer :: NAtts + integer :: DimIDs(2) + integer :: VStart(2) + integer :: VLen(2) + integer :: TotalNumVars + integer :: NumVars + integer :: i + integer :: ndims, unlimitedDimID + character(PIO_MAX_NAME) :: Name + + call upgrade_filename(FileName) + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_pio_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call allocHandle(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + if(DH%first_operation) then + call initialize_pio(grid, DH) + call define_pio_iodesc(grid, DH) + DH%first_operation = .false. + end if + + stat = pio_openfile(DH%iosystem, DH%file_handle, pio_iotype_pnetcdf, FileName) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + stat = pio_inq_varid(DH%file_handle, DH%TimesName, DH%vtime) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + stat = pio_inquire_variable(DH%file_handle, DH%vtime, DH%TimesName, XType, StoredDim, DimIDs, NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(XType/=PIO_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = pio_inq_dimlen(DH%file_handle, DimIDs(1), VLen(1)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(1) /= DateStrLen) then + Status = WRF_WARN_DATESTR_BAD_LENGTH + write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + stat = pio_inq_dimlen(DH%file_handle, DimIDs(2), VLen(2)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(2) > MaxTimes) then + Status = WRF_ERR_FATAL_TOO_MANY_TIMES + write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + + VStart(1) = 1 + VStart(2) = 1 + stat = pio_get_var(DH%file_handle, DH%vtime, DH%Times(1:VLen(2))) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + stat = pio_inquire(DH%file_handle, ndims, TotalNumVars, NAtts, unlimitedDimID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + NumVars = 0 + do i=1,TotalNumVars + stat = pio_inq_varname(DH%file_handle,i,Name) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then + NumVars = NumVars+1 + DH%VarNames(NumVars) = Name + DH%VarIDs(NumVars) = i + endif + enddo + DH%NumVars = NumVars + DH%NumberTimes = VLen(2) + DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + DH%FileName = trim(FileName) + DH%CurrentVariable = 0 + DH%CurrentTime = 0 + DH%TimeIndex = 0 + + do i = 1, ndims + DH%DimIDs(i) = i + stat = pio_inq_dimname(DH%file_handle,i,DH%DimNames(i)) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + if(unlimitedDimID == i) then + DH%DimUnlimID = unlimitedDimID + DH%DimUnlimName = DH%DimNames(i) + endif + enddo + DH%NumDims = ndims + return +end subroutine ext_pio_open_for_read_begin + +subroutine ext_pio_open_for_update( FileName, grid, SysDepInfo, DataHandle, Status) + use wrf_data_pio + use pio_routines + use module_domain + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(INOUT) :: FileName + TYPE(domain) :: grid + character*(*) ,intent(in) :: SysDepInfo + integer ,intent(out) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: stat + integer :: StoredDim + integer :: NAtts + integer :: DimIDs(2) + integer :: VStart(2) + integer :: VLen(2) + integer :: TotalNumVars + integer :: NumVars + integer :: i + integer :: ndims, unlimitedDimID + character(PIO_MAX_NAME) :: Name + + call upgrade_filename(FileName) + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_pio_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call allocHandle(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + if(DH%first_operation) then + call initialize_pio(grid, DH) + call define_pio_iodesc(grid, DH) + DH%first_operation = .false. + end if + + stat = pio_openfile(DH%iosystem, DH%file_handle, pio_iotype_pnetcdf, FileName) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = pio_inq_varid(DH%file_handle, DH%TimesName, DH%vtime) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = pio_inquire_variable(DH%file_handle, DH%vtime, DH%TimesName, & + XType, StoredDim, DimIDs, NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(XType/=PIO_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = pio_inq_dimlen(DH%file_handle, DimIDs(1), VLen(1)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(1) /= DateStrLen) then + Status = WRF_WARN_DATESTR_BAD_LENGTH + write(msg,*) 'Warning DATESTR BAD LENGTH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = pio_inq_dimlen(DH%file_handle, DimIDs(2), VLen(2)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VLen(2) > MaxTimes) then + Status = WRF_ERR_FATAL_TOO_MANY_TIMES + write(msg,*) 'Fatal TOO MANY TIME VALUES in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + VStart(1) = 1 + VStart(2) = 1 + !stat = pio_get_var(DH%file_handle, DH%vtime, VStart, VLen, DH%Times) + stat = pio_get_var(DH%file_handle, DH%vtime, DH%Times) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = pio_inquire(DH%file_handle, ndims, TotalNumVars, NAtts, unlimitedDimID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + NumVars = 0 + do i=1,TotalNumVars + stat = pio_inq_varname(DH%file_handle, i, Name) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(Name(1:5) /= 'md___' .and. Name /= DH%TimesName) then + NumVars = NumVars+1 + DH%VarNames(NumVars) = Name + DH%VarIDs(NumVars) = i + endif + enddo + DH%NumVars = NumVars + DH%NumberTimes = VLen(2) + DH%FileStatus = WRF_FILE_OPENED_FOR_UPDATE + DH%FileName = trim(FileName) + DH%CurrentVariable = 0 + DH%CurrentTime = 0 + DH%TimeIndex = 0 + return +end subroutine ext_pio_open_for_update + + +SUBROUTINE ext_pio_open_for_write_begin(FileName,grid,SysDepInfo,DataHandle,Status) + use pio_types + use pio + use wrf_data_pio + use pio_routines + use module_domain + implicit none + include 'wrf_status_codes.h' + character*(*) ,intent(inout) :: FileName + TYPE(domain) :: grid + character*(*) ,intent(in) :: SysDepInfo + integer ,intent(out) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + character (7) :: Buffer + integer :: VDimIDs(2) + integer :: info, ierr ! added for Blue Gene (see PIO_CREAT below) + character*128 :: idstr,ntasks_x_str,loccomm_str + integer :: gridid + integer local_communicator_x, ntasks_x + + call upgrade_filename(FileName) + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_pio_open_for_write_begin: ext_pio_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call allocHandle(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Fatal ALLOCATION ERROR in ext_pio_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + DH%TimeIndex = 0 + DH%Times = ZeroDate + + if(DH%first_operation) then + call initialize_pio(grid, DH) + call define_pio_iodesc(grid, DH) + DH%first_operation = .false. + end if + + !call mpi_info_create( info, ierr ) + stat = pio_CreateFile(DH%iosystem, DH%file_handle, & + pio_iotype_pnetcdf, FileName, PIO_64BIT_OFFSET) + !call mpi_info_free( info, ierr) + + call netcdf_err(stat,Status) + + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_pio_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + !JPE added for performance + !stat = nf90_set_fill(DH%file_handle, NF90_NOFILL, i) + + DH%FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + DH%FileName = trim(FileName) + stat = pio_def_dim(DH%file_handle, DH%DimUnlimName, PIO_UNLIMITED, DH%DimUnlimID) + !stat = pio_def_dim(DH%file_handle, DH%DimUnlimName, 1, DH%DimUnlimID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_pio_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + DH%VarNames (1:MaxVars) = NO_NAME + do i=1,MaxDims + write(Buffer,FMT="('DIM',i4.4)") i + DH%DimNames (i) = Buffer + DH%DimLengths(i) = NO_DIM + enddo + + DH%DimNames(1) = 'DateStrLen' + stat = pio_def_dim(DH%file_handle, DH%DimNames(1), DateStrLen, DH%DimIDs(1)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_pio_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + VDimIDs(1) = DH%DimIDs(1) + VDimIDs(2) = DH%DimUnlimID + stat = pio_def_var(DH%file_handle,DH%TimesName,PIO_CHAR,VDimIDs,DH%vtime) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_pio_open_for_write_begin ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%DimLengths(1) = DateStrLen + + return +end subroutine ext_pio_open_for_write_begin + +!opens a file for writing or coupler datastream for sending messages. +!no training phase for this version of the open stmt. +subroutine ext_pio_open_for_write (DatasetName, grid, & + SysDepInfo, DataHandle, Status) + use wrf_data_pio + use pio_routines + use module_domain + implicit none + include 'wrf_status_codes.h' + character *(*), intent(in) :: DatasetName + type(domain) :: grid + character *(*), intent(in) :: SysDepInfo + integer , intent(out) :: DataHandle + integer , intent(out) :: Status + Status=WRF_WARN_NOOP + DataHandle = 0 ! dummy setting to quiet warning message + return +end subroutine ext_pio_open_for_write + +SUBROUTINE ext_pio_open_for_write_commit(DataHandle, Status) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_pio_open_for_write_commit: ext_pio_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_pio_open_for_write_commit ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%Write = .true. + stat = pio_enddef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error (',stat,') from pio_enddef in ext_pio_open_for_write_commit ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + DH%FileStatus = WRF_FILE_OPENED_FOR_WRITE + + return +end subroutine ext_pio_open_for_write_commit + +subroutine ext_pio_ioclose(DataHandle, Status) + use wrf_data_pio + use pio_routines + use pio + use pio_kinds + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: stat + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_pio_ioclose ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ext_pio_ioclose ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_CLOSE + write(msg,*) 'Warning TRY TO CLOSE DRYRUN in ext_pio_ioclose ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + continue + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ext_pio_ioclose ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + + call pio_closefile(DH%file_handle) + CALL deallocHandle( DataHandle, Status ) + DH%Free=.true. + return +end subroutine ext_pio_ioclose + +subroutine ext_pio_iosync( DataHandle, Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle),pointer :: DH + integer :: stat + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_pio_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ext_pio_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_FILE_NOT_COMMITTED + write(msg,*) 'Warning FILE NOT COMMITTED in ext_pio_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + continue + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + continue + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ext_pio_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + return + endif + call pio_syncfile(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ext_pio_iosync ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + return +end subroutine ext_pio_iosync + +subroutine ext_pio_ioinit(SysDepInfo, Status) + use wrf_data_pio + implicit none + include 'wrf_status_codes.h' + CHARACTER*(*), INTENT(IN) :: SysDepInfo + INTEGER ,INTENT(INOUT) :: Status + + WrfIOnotInitialized = .false. + WrfDataHandles(1:WrfDataHandleMax)%Free = .true. + WrfDataHandles(1:WrfDataHandleMax)%TimesName = 'Times' + WrfDataHandles(1:WrfDataHandleMax)%DimUnlimName = 'Time' + WrfDataHandles(1:WrfDataHandleMax)%FileStatus = WRF_FILE_NOT_OPENED + Status = WRF_NO_ERR + return +end subroutine ext_pio_ioinit + +subroutine ext_pio_inquiry (Inquiry, Result, Status) + use wrf_data_pio + implicit none + include 'wrf_status_codes.h' + character *(*), INTENT(IN) :: Inquiry + character *(*), INTENT(OUT) :: Result + integer ,INTENT(INOUT) :: Status + SELECT CASE (Inquiry) + CASE ("RANDOM_WRITE","RANDOM_READ","SEQUENTIAL_WRITE","SEQUENTIAL_READ") + Result='ALLOW' + CASE ("OPEN_READ","OPEN_COMMIT_WRITE") + Result='REQUIRE' + CASE ("OPEN_WRITE","OPEN_COMMIT_READ","PARALLEL_IO") + Result='NO' + CASE ("SELF_DESCRIBING","SUPPORT_METADATA","SUPPORT_3D_FIELDS") + Result='YES' + CASE ("MEDIUM") + Result ='FILE' + CASE DEFAULT + Result = 'No Result for that inquiry!' + END SELECT + Status=WRF_NO_ERR + return +end subroutine ext_pio_inquiry + +subroutine ext_pio_ioexit(Status) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer , INTENT(INOUT) ::Status + integer :: error + type(wrf_data_handle),pointer :: DH + integer :: i + integer :: stat + if(WrfIOnotInitialized) then + Status = WRF_IO_NOT_INITIALIZED + write(msg,*) 'ext_pio_ioinit was not called ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + do i=1,WrfDataHandleMax + CALL deallocHandle( i , stat ) + enddo + return +end subroutine ext_pio_ioexit + +subroutine ext_pio_get_dom_ti_real_arr(DataHandle,Element,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + + implicit none + + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real, intent(out) :: Data(:) + integer, intent(in) :: Count + integer, intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + real, allocatable :: Buffer(:) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to read time-independent domain metadata. + IF(.not. ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_att(DH%file_handle, PIO_GLOBAL, Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if( XType/=PIO_REAL) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) 'Warning LENGTH < 1 in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att (DH%file_handle,PIO_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_dom_ti_real_arr + +subroutine ext_pio_get_dom_ti_real_sca(DataHandle,Element,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + + implicit none + + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real, intent(out) :: Data + integer, intent(in) :: Count + integer, intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + real, allocatable :: Buffer(:) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to read time-independent domain metadata. + IF(.not. ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_att(DH%file_handle, PIO_GLOBAL, Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if( XType/=PIO_REAL) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) 'Warning LENGTH < 1 in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att (DH%file_handle,PIO_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_dom_ti_real_sca + +subroutine ext_pio_get_dom_ti_integer_arr(DataHandle,Element,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + + implicit none + + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + integer, intent(out) :: Data(:) + integer, intent(in) :: Count + integer, intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + integer, allocatable :: Buffer(:) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to read time-independent domain metadata. + IF(.not. ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_att(DH%file_handle, PIO_GLOBAL, Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if( XType/=PIO_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) 'Warning LENGTH < 1 in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att (DH%file_handle,PIO_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_dom_ti_integer_arr + +subroutine ext_pio_get_dom_ti_integer_sca(DataHandle,Element,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + + implicit none + + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + integer, intent(out) :: Data + integer, intent(in) :: Count + integer, intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + integer, allocatable :: Buffer(:) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to read time-independent domain metadata. + IF(.not. ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_att(DH%file_handle, PIO_GLOBAL, Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if( XType/=PIO_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) 'Warning LENGTH < 1 in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att (DH%file_handle,PIO_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_dom_ti_integer_sca + +subroutine ext_pio_get_dom_ti_double_arr(DataHandle,Element,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + + implicit none + + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real*8, intent(out) :: Data(:) + integer, intent(in) :: Count + integer, intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + real*8, allocatable :: Buffer(:) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to read time-independent domain metadata. + IF(.not. ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_att(DH%file_handle, PIO_GLOBAL, Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) 'Warning LENGTH < 1 in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att (DH%file_handle,PIO_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len,Count)) = Buffer(1:min(Len,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_dom_ti_double_arr + +subroutine ext_pio_get_dom_ti_double_sca(DataHandle,Element,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + + implicit none + + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real*8, intent(out) :: Data + integer, intent(in) :: Count + integer, intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + real*8, allocatable :: Buffer(:) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to read time-independent domain metadata. + IF(.not. ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_att(DH%file_handle, PIO_GLOBAL, Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) 'Warning LENGTH < 1 in ',__FILE__,', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att (DH%file_handle,PIO_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_dom_ti_double_sca + +subroutine ext_pio_get_dom_ti_logical_arr(DataHandle,Element,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + + implicit none + + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + logical, intent(out) :: Data(:) + integer, intent(in) :: Count + integer, intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + integer, allocatable :: Buffer(:) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to read time-independent domain metadata. + IF(.not. ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_att(DH%file_handle, PIO_GLOBAL, Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if ( PIO_INT == PIO_DOUBLE .OR. PIO_INT == PIO_REAL ) then + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + else + if( XType/=PIO_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) 'Warning LENGTH < 1 in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att (DH%file_handle,PIO_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len,Count)) = Buffer(1:min(Len,Count))==1 + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_dom_ti_logical_arr + +subroutine ext_pio_get_dom_ti_logical_sca(DataHandle,Element,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + + implicit none + + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + logical, intent(out) :: Data + integer, intent(in) :: Count + integer, intent(out) :: OutCOunt + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + integer, allocatable :: Buffer(:) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to read time-independent domain metadata. + IF(.not. ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_att(DH%file_handle, PIO_GLOBAL, Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if ( PIO_INT == PIO_DOUBLE .OR. PIO_INT == PIO_REAL ) then + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + else + if( XType/=PIO_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) 'Warning LENGTH < 1 in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(Len), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att (DH%file_handle,PIO_GLOBAL,Element,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= WRF_NO_ERR) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_dom_ti_logical_sca + +subroutine ext_pio_get_dom_ti_char_arr(DataHandle,Element,Data,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + + implicit none + + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*), intent(out) :: Data + + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Do nothing unless it is time to read time-independent domain metadata. + IF(.not. ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','CHAR',', line', __LINE__ + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_att(DH%file_handle, PIO_GLOBAL, Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) 'Warning LENGTH < 1 in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + Data = '' + stat = pio_get_att(DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + + return +end subroutine ext_pio_get_dom_ti_char_arr + +subroutine ext_pio_get_dom_ti_char_sca(DataHandle,Element,Data,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + + implicit none + + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*), intent(out) :: Data + + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XType + integer :: Len + integer :: stat + + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + ! Do nothing unless it is time to read time-independent domain metadata. + IF(.not. ncd_ok_to_get_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','CHAR',', line', __LINE__ + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_att(DH%file_handle, PIO_GLOBAL, Element, XType, Len) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',trim(Element) + call wrf_debug ( WARN , msg) + return + endif + if(Len<=0) then + Status = WRF_WARN_LENGTH_LESS_THAN_1 + write(msg,*) 'Warning LENGTH < 1 in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ', trim(Element) + call wrf_debug ( WARN , msg) + return + endif + Data = '' + stat = pio_get_att(DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + + return +end subroutine ext_pio_get_dom_ti_char_sca + +subroutine ext_pio_put_dom_ti_real_arr(DataHandle,Element,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real, intent(in) :: Data(*) + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: i + real, dimension(1:Count) :: tmparr + + tmparr(1:Count) = Data(1:Count) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to write time-independent domain metadata. + IF(.not. ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + !stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,tmparr) + if(1 == Count) then + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,tmparr(1)) + else + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,tmparr(1:Count)) + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + + if(1 == Count) then + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,tmparr(1)) + else + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,tmparr(1:Count)) + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_put_dom_ti_real_arr + +subroutine ext_pio_put_dom_ti_real_sca(DataHandle,Element,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real, intent(in) :: Data + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: i + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to write time-independent domain metadata. + IF(.not. ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_put_dom_ti_real_sca + +subroutine ext_pio_put_dom_ti_integer_arr(DataHandle,Element,Data,Count,Status) + use pio_kinds + use pio + + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + integer, intent(in) :: Data(*) + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: i + integer, dimension(Count) :: tmparr + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + + tmparr(1:Count) = Data(1:Count) + +!-Do nothing unless it is time to write time-independent domain metadata. + IF(.not. ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + stat = pio_put_att (DH%file_handle,PIO_GLOBAL,Element,tmparr) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + tmparr(1:Count) = Data(1:Count) + if(1 == Count) then + stat = pio_put_att (DH%file_handle,PIO_GLOBAL,Element,tmparr(1)) + else + stat = pio_put_att (DH%file_handle,PIO_GLOBAL,Element,tmparr(1:Count)) + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_put_dom_ti_integer_arr + +subroutine ext_pio_put_dom_ti_integer_sca(DataHandle,Element,Data,Count,Status) + use pio_kinds + use pio + + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + integer, intent(in) :: Data + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: i + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to write time-independent domain metadata. + IF(.not. ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + stat = pio_put_att (DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + if(DH%Write) then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + endif + stat = pio_put_att (DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_put_dom_ti_integer_sca + +subroutine ext_pio_put_dom_ti_double_arr(DataHandle,Element,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real*8, intent(in) :: Data(:) + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: i + real*8, dimension(1:Count) :: tmparr + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + tmparr(1:Count) = Data(1:Count) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to write time-independent domain metadata. + IF(.not. ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + stat = pio_put_att (DH%file_handle,PIO_GLOBAL,Element,tmparr(1:Count)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + if(DH%Write) then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + endif + + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,tmparr(1:Count)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif +#endif + return +end subroutine ext_pio_put_dom_ti_double_arr + +subroutine ext_pio_put_dom_ti_double_sca(DataHandle,Element,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + real*8, intent(in) :: Data + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: i + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to write time-independent domain metadata. + IF(.not. ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + stat = pio_put_att (DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + if(DH%Write) then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + endif + + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif +#endif + return +end subroutine ext_pio_put_dom_ti_double_sca + +subroutine ext_pio_put_dom_ti_logical_arr(DataHandle,Element,Data,Count,Status) + use pio + use pio_kinds + + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + logical, intent(in) :: Data(:) + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to write time-independent domain metadata. + IF(.not. ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,Buffer) + deallocate(Buffer, STAT=stat) + if(stat /= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + if(DH%Write) then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + endif + + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,Buffer) + deallocate(Buffer, STAT=stat) + if(stat /= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif +#endif + return +end subroutine ext_pio_put_dom_ti_logical_arr + +subroutine ext_pio_put_dom_ti_logical_sca(DataHandle,Element,Data,Count,Status) + use pio + use pio_kinds + + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + logical, intent(in) :: Data + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to write time-independent domain metadata. + IF(.not. ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(data) then + Buffer(1)=1 + else + Buffer(1)=0 + endif + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,Buffer) + deallocate(Buffer, STAT=stat) + if(stat /= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + if(DH%Write) then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + endif + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(data) then + Buffer(1)=1 + else + Buffer(1)=0 + endif + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,Buffer) + deallocate(Buffer, STAT=stat) + if(stat /= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif +#endif + return +end subroutine ext_pio_put_dom_ti_logical_sca + +subroutine ext_pio_put_dom_ti_char_arr(DataHandle,Element,Data,Status) + use pio + use pio_kinds + + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*), intent(in) :: Data + integer, parameter :: Count=1 + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: i + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to write time-independent domain metadata. + IF(.not. ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + if(DH%Write) then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + endif + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_put_dom_ti_char_arr + +subroutine ext_pio_put_dom_ti_char_sca(DataHandle,Element,Data,Status) + use pio + use pio_kinds + + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*), intent(in) :: Data + integer, parameter :: Count=1 + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + integer :: i + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +! Do nothing unless it is time to write time-independent domain metadata. + IF(.not. ncd_ok_to_put_dom_ti( DataHandle ) ) THEN + return + ENDIF + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + STATUS = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif (DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + if(DH%Write) then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + endif + stat = pio_put_att(DH%file_handle,PIO_GLOBAL,Element,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif +#endif + return +end subroutine ext_pio_put_dom_ti_char_sca + +subroutine ext_pio_put_var_ti_real_arr(DataHandle,Element,Var,Data,Count,Status) + use pio + use pio_kinds + + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real, intent(in) :: Data(:) + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer :: i + integer :: NVar + character*1 :: null + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) 'Warning WRITE METADATA AFTER OPEN in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_ti_real_arr + +subroutine ext_pio_put_var_ti_real_sca(DataHandle,Element,Var,Data,Count,Status) + use pio + use pio_kinds + + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real, intent(in) :: Data + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer :: i + integer :: NVar + character*1 :: null + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) 'Warning WRITE METADATA AFTER OPEN in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_ti_real_sca + +subroutine ext_pio_put_var_td_real_arr(DataHandle,Element,DateStr,Var,Data,Count,Status) + use pio + use pio_kinds + + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real ,intent(in) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do i=1,MaxVars + if(DH%VarNames(i) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + NVar=i + return + elseif(DH%VarNames(i) == NO_NAME) then + DH%VarNames(i) = Name + exit + elseif(i == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = pio_def_dim(DH%file_handle,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%VarDimLens(1, NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') '2 Define Var <', trim(Var), '> as NVar:', NVar + stat = pio_def_var(DH%file_handle,Name,PIO_REAL,DH%descVar(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do i=1,MaxVars + if(DH%VarNames(i) == Name) then + NVar=i + exit + elseif(DH%VarNames(i) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) 'Warning METADATA NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(i == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%VarDimLens(1,NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) 'Warning COUNT TOO LONG in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) 'Warning ZERO LENGTH PUT in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),VStart,VCount,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_td_real_arr + +subroutine ext_pio_put_var_td_real_sca(DataHandle,Element,DateStr,Var,Data,Count,Status) + use pio + use pio_kinds + + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real ,intent(in) :: Data + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: Buffer(1) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do i=1,MaxVars + if(DH%VarNames(i) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + NVar=i + return + elseif(DH%VarNames(i) == NO_NAME) then + DH%VarNames(i) = Name + exit + elseif(i == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = pio_def_dim(DH%file_handle,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%VarDimLens(1,NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') '3 Define Var <', trim(Var), '> as NVar:', NVar + stat = pio_def_var(DH%file_handle,Name,PIO_REAL,DH%descVar(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + exit + elseif(DH%VarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) 'Warning METADATA NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%VarDimLens(1,NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) 'Warning COUNT TOO LONG in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) 'Warning ZERO LENGTH PUT in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + Buffer(1) = Data + !stat = pio_put_var(DH%file_handle,DH%descMDVar(NVar),VStart,VCount,Buffer) + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_td_real_sca + +subroutine ext_pio_put_var_ti_double_arr(DataHandle,Element,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real*8 ,intent(in) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer :: i + integer :: NVar + character*1 :: null + + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) 'Warning WRITE METADATA AFTER OPEN in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),Data ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_put_var_ti_double_arr + +subroutine ext_pio_put_var_ti_double_sca(DataHandle,Element,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real*8 ,intent(in) :: Data + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + real*8 :: Buffer(1) + integer :: i + integer :: NVar + character*1 :: null + + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) 'Warning WRITE METADATA AFTER OPEN in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + Buffer(1) = Data + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_put_var_ti_double_sca + +subroutine ext_pio_put_var_td_double_arr(DataHandle,Element,DateStr,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real*8 ,intent(in) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%VarNames(NVar) == NO_NAME) then + DH%VarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = pio_def_dim(DH%file_handle,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%VarDimLens(1,NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') '4 Define Var <', trim(Var), '> as NVvar:', NVar + stat = pio_def_var(DH%file_handle,Name,PIO_DOUBLE,DH%descVar(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + exit + elseif(DH%VarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) 'Warning METADATA NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%VarDimLens(1,NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) 'Warning COUNT TOO LONG in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) 'Warning ZERO LENGTH PUT in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + !stat = pio_put_var(DH%file_handle,DH%descMDVar(NVar),VStart,VCount,Data) + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),VStart,VCount,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_td_double_arr + +subroutine ext_pio_put_var_td_double_sca(DataHandle,Element,DateStr,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real*8 ,intent(in) :: Data + integer ,intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + real*8 :: Buffer(1) + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%VarNames(NVar) == NO_NAME) then + DH%VarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = pio_def_dim(DH%file_handle,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%VarDimLens(1,NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') '5 Define Var <', trim(Var), '> as NVar:', NVar + stat = pio_def_var(DH%file_handle,Name,PIO_DOUBLE,DH%descVar(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + exit + elseif(DH%VarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) 'Warning METADATA NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%VarDimLens(1,NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) 'Warning COUNT TOO LONG in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) 'Warning ZERO LENGTH PUT in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + Buffer(1) = Data + !stat = pio_put_var(DH%file_handle,DH%descMDVar(NVar),VStart,VCount,Buffer) + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_td_double_sca + +subroutine ext_pio_put_var_ti_integer_arr(DataHandle,Element,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + integer, intent(in) :: Data(:) + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer :: i + integer :: NVar + character*1 :: null + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) 'Warning WRITE METADATA AFTER OPEN in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_ti_integer_arr + +subroutine ext_pio_put_var_ti_integer_sca(DataHandle,Element,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + integer, intent(in) :: Data + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer :: Buffer(1) + integer :: i + integer :: NVar + character*1 :: null + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) 'Warning WRITE METADATA AFTER OPEN in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + Buffer(1) = Data + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_ti_integer_sca + +subroutine ext_pio_put_var_td_integer_arr(DataHandle,Element,DateStr,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer, intent(in) :: Data(:) + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%VarNames(NVar) == NO_NAME) then + DH%VarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = pio_def_dim(DH%file_handle,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%VarDimLens(1,NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') '6 Define Var <', trim(Var), '> as NVar:', NVar + stat = pio_def_var(DH%file_handle,Name,PIO_INT,DH%descVar(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + exit + elseif(DH%VarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) 'Warning METADATA NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%VarDimLens(1,NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) 'Warning COUNT TOO LONG in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) 'Warning ZERO LENGTH PUT in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + !stat = pio_put_var(DH%file_handle,DH%MDVarIDs(NVar),VStart,VCount,Data) + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),VStart,VCount,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_td_integer_arr + +subroutine ext_pio_put_var_td_integer_sca(DataHandle,Element,DateStr,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer, intent(in) :: Data + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: Buffer(1) + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%VarNames(NVar) == NO_NAME) then + DH%VarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = pio_def_dim(DH%file_handle,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%VarDimLens(1,NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') '7 Define Var <', trim(Var), '> as NVar:', NVar + stat = pio_def_var(DH%file_handle,Name,PIO_INT,DH%descVar(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + exit + elseif(DH%VarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) 'Warning METADATA NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%VarDimLens(1,NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) 'Warning COUNT TOO LONG in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) 'Warning ZERO LENGTH PUT in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + Buffer(1) = Data + !stat = pio_put_var(DH%file_handle,DH%MDVarIDs(NVar),VStart,VCount,Buffer) + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_td_integer_sca + +subroutine ext_pio_put_var_ti_logical_arr(DataHandle,Element,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + logical, intent(in) :: Data(:) + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: NVar + character*1 :: null + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) 'Warning WRITE METADATA AFTER OPEN in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,' ','LOGICAL',', line', __LINE__ & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_ti_logical_arr + +subroutine ext_pio_put_var_ti_logical_sca(DataHandle,Element,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + logical, intent(in) :: Data + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer :: Buffer(1) + integer :: i + integer :: NVar + character*1 :: null + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) 'Warning WRITE METADATA AFTER OPEN in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,' ','LOGICAL',', line', __LINE__ & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Data) then + Buffer(1)=1 + else + Buffer(1)=0 + endif + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_ti_logical_sca + +subroutine ext_pio_put_var_td_logical_arr(DataHandle,Element,DateStr,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + logical, intent(in) :: Data(:) + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%VarNames(NVar) == NO_NAME) then + DH%VarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = pio_def_dim(DH%file_handle,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%VarDimLens(1,NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') '8 Define Var <', trim(Var), '> as NVar:', NVar + stat = pio_def_var(DH%file_handle,Name,PIO_INT,DH%descVar(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + exit + elseif(DH%VarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) 'Warning METADATA NOT FOUND in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%VarDimLens(1,NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) 'Warning COUNT TOO LONG in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) 'Warning ZERO LENGTH PUT in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + allocate(Buffer(Count), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + do i=1,Count + if(data(i)) then + Buffer(i)=1 + else + Buffer(i)=0 + endif + enddo + !stat = pio_put_var(DH%file_handle,DH%MDVarIDs(NVar),VStart,VCount,Buffer) + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),VStart,VCount,Buffer) + deallocate(Buffer, STAT=stat) + if(stat /= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_td_logical_arr + +subroutine ext_pio_put_var_td_logical_sca(DataHandle,Element,DateStr,Var,Data,Count,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + logical, intent(in) :: Data + integer, intent(in) :: Count + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: Buffer(1) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%VarNames(NVar) == NO_NAME) then + DH%VarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == Count) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = pio_def_dim(DH%file_handle,DH%DimNames(i),Count,DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = Count + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%VarDimLens(1,NVar) = Count + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') '9 Define Var <', trim(Var), '> as NVar:', NVar + stat = pio_def_var(DH%file_handle,Name,PIO_INT,DH%descVar(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + exit + elseif(DH%VarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) 'Warning METADATA NOT FOUND in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + if(Count > DH%VarDimLens(1,NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) 'Warning COUNT TOO LONG in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(Count < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) 'Warning ZERO LENGTH PUT in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Count + VCount(2) = 1 + if(Data) then + Buffer(1)=1 + else + Buffer(1)=0 + endif + !stat = pio_put_var(DH%file_handle,DH%MDVarIDs(NVar),VStart,VCount,Buffer) + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_td_logical_sca + +subroutine ext_pio_put_var_ti_char_arr(DataHandle,Element,Var,Data,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + character*(*) ,intent(in) :: Data + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer :: i + integer :: NVar + character(len=1) :: null + character(len=4096) :: tmpdata + integer :: length + + length = len(Data) + if(1 > length) then + length = 0 + null = char(0) + else if(4096 < length) then + length = 4096 + tmpdata = Data(1:4096) + else + tmpdata = trim(Data) + end if + + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) 'Warning WRITE METADATA AFTER OPEN in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do i=1,MaxVars + if(TRIM(DH%VarNames(i)) == TRIM(VarName)) then + NVar = i + exit + elseif(i == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,' ','CHAR',', line', __LINE__ & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + + !write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + !write(unit=0, fmt='(6a)') 'Var: ', trim(Var), ', Data: ', trim(Data), ', tmpdata: ', trim(tmpdata) + !write(unit=0, fmt='(3a,i6)') 'Element = ', trim(Element), ', NVar = ', NVar + !write(unit=0, fmt='(2(a,i6))') 'DH%descVar(NVar)%VarID = ', DH%descVar(NVar)%VarID, & + ! ', length = ', length + + if(DH%Write) then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + endif + + if(1 > length) then + !write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + !write(unit=0, fmt='(6a)') 'Var: ', trim(Var), ', Element: ', trim(Element), ', tmpdata: ', trim(tmpdata) + !write(unit=0, fmt='(2(a,i6))') 'DH%descVar(NVar)%VarID = ', DH%descVar(NVar)%VarID, & + ! ', length = ', length + stat = pio_put_att(DH%file_handle,DH%descVar(NVar),trim(Element),null) + else + !write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + !write(unit=0, fmt='(6a)') 'Var: ', trim(Var), ', Element: ', trim(Element), ', tmpdata: ', trim(tmpdata) + !write(unit=0, fmt='(2(a,i6))') 'DH%descVar(NVar)%VarID = ', DH%descVar(NVar)%VarID, & + ! ', length = ', length + stat = pio_put_att(DH%file_handle,DH%descVar(NVar),trim(Element),tmpdata) + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_put_var_ti_char_arr + +subroutine ext_pio_put_var_ti_char_sca(DataHandle,Element,Var,Data,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + character*(*) ,intent(in) :: Data + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + integer :: stat + integer :: i + integer :: NVar + character*1 :: null + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + null=char(0) + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_MD_AFTER_OPEN + write(msg,*) 'Warning WRITE METADATA AFTER OPEN in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + do NVar=1,MaxVars + if(TRIM(DH%VarNames(NVar)) == TRIM(VarName)) then + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,' ','CHAR',', line', __LINE__ & + ,NVar,VarName + call wrf_debug ( WARN , msg) + return + endif + enddo + if(len_trim(Data).le.0) then + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),null) + else + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),trim(Data)) + endif + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error for Var ',TRIM(Var),& + ' Element ',trim(Element),' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_ti_char_sca + +subroutine ext_pio_put_var_td_char_arr(DataHandle,Element,DateStr,Var,Data,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character*(*) ,intent(in) :: Data + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + character(len=4096) :: tmpdata(1) + integer :: length + + length = len(Data) + if(1 > length) then + length = 1 + tmpdata(1) = "" + else if(4096 < length) then + length = 4096 + tmpdata(1) = Data(1:4096) + else + tmpdata(1) = trim(Data) + end if + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(4a)') 'Var: ', trim(Var), ', Data: ', tmpdata(1) + write(unit=0, fmt='(4a)') 'Name: ', trim(Name), ', Element = ', trim(Element) + + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(len(Data) < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%VarNames(NVar) == NO_NAME) then + DH%VarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == len(Data)) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = pio_def_dim(DH%file_handle,DH%DimNames(i),len(Data),DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = len(Data) + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%VarDimLens(1,NVar) = len(Data) + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') '10 Define Var <', trim(Var), '> as NVar:', NVar + stat = pio_def_var(DH%file_handle,Name,PIO_CHAR,DH%descVar(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + exit + elseif(DH%VarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) 'Warning METADATA NOT FOUND in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + if(len(Data) > DH%VarDimLens(1,NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) 'Warning COUNT TOO LONG in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(len(Data) < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) 'Warning ZERO LENGTH PUT in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = length + VCount(2) = 1 + tmpdata = Data + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),VStart,VCount,tmpdata) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line: ', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_put_var_td_char_arr + +subroutine ext_pio_put_var_td_char_sca(DataHandle,Element,DateStr,Var,Data,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character*(*) ,intent(in) :: Data + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + integer :: stat + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + character(len=DateStrLen) :: tmpdata(1) + integer :: length + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + +#if 0 + length = len(Data) + if(1 > length) then + length = 1 + tmpdata(1) = "" + else if(4096 < length) then + length = 4096 + tmpdata(1) = Data(1:4096) + else + tmpdata(1) = trim(Data) + end if + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(4a)') 'Var: ', trim(Var), ', Data: ', tmpdata(1) + + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(4a)') 'Var: ', trim(Var), ', Data: ', tmpdata(1) + write(unit=0, fmt='(4a)') 'Name: ', trim(Name), ', Element = ', trim(Element) + + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + if(len(Data) < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + return + endif + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + return + elseif(DH%VarNames(NVar) == NO_NAME) then + DH%VarNames(NVar) = Name + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + do i=1,MaxDims + if(DH%DimLengths(i) == len(Data)) then + exit + elseif(DH%DimLengths(i) == NO_DIM) then + stat = pio_def_dim(DH%file_handle,DH%DimNames(i),len(Data),DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + DH%DimLengths(i) = len(Data) + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + DH%VarDimLens(1,NVar) = len(Data) + VDims(1) = DH%DimIDs(i) + VDims(2) = DH%DimUnlimID + write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + write(unit=0, fmt='(3a,i6)') '11 Define Var <', trim(Var), '> as NVar:', NVar + stat = pio_def_var(DH%file_handle,Name,PIO_CHAR,DH%descVar(NVar)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + do NVar=1,MaxVars + if(DH%VarNames(NVar) == Name) then + exit + elseif(DH%VarNames(NVar) == NO_NAME) then + Status = WRF_WARN_MD_NF + write(msg,*) 'Warning METADATA NOT FOUND in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + if(len(Data) > DH%VarDimLens(1,NVar)) then + Status = WRF_WARN_COUNT_TOO_LONG + write(msg,*) 'Warning COUNT TOO LONG in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + elseif(len(Data) < 1) then + Status = WRF_WARN_ZERO_LENGTH_PUT + write(msg,*) 'Warning ZERO LENGTH PUT in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('write',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = len(Data) + VCount(2) = 1 + tmpdata = Data + !stat = pio_put_var(DH%file_handle,DH%descMDVar(NVar),VStart,VCount,Data) + stat = pio_put_var(DH%file_handle,DH%descVar(NVar),VStart,VCount,tmpdata) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line: ', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif +#endif + return +end subroutine ext_pio_put_var_td_char_sca + +subroutine ext_pio_get_var_ti_real_arr(DataHandle,Element,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real, intent(out) :: Data(:) + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + real, allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line: ', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line: ', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line: ', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_inq_att(DH%file_handle,DH%descVar(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if(XType /= PIO_REAL) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att(DH%file_handle,DH%descVar(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_get_var_ti_real_arr + +subroutine ext_pio_get_var_ti_real_sca(DataHandle,Element,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real, intent(out) :: Data + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + real, allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line: ', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line: ', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line: ', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_inq_att(DH%file_handle,DH%descVar(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if(XType /= PIO_REAL) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att(DH%file_handle,DH%descVar(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_get_var_ti_real_sca + +subroutine ext_pio_get_var_td_real_arr(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real ,intent(out) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + real ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_varid(DH%file_handle,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + !stat = NFMPI_INQ_VAR(file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + stat = pio_inquire_variable(DH%file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) 'Fatal MDVAR DIM NOT 1D in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_inq_dimlen(DH%file_handle,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_var(DH%file_handle,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_var_td_real_arr + +subroutine ext_pio_get_var_td_real_sca(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real ,intent(out) :: Data + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + real ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_varid(DH%file_handle,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + !stat = NFMPI_INQ_VAR(file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + stat = pio_inquire_variable(DH%file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) 'Fatal MDVAR DIM NOT 1D in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_inq_dimlen(DH%file_handle,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_var(DH%file_handle,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_var_td_real_sca + +subroutine ext_pio_get_var_ti_double_arr(DataHandle,Element,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real*8, intent(out) :: Data(:) + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + real*8, allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_inq_att(DH%file_handle,DH%descVar(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att(DH%file_handle,DH%descVar(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_get_var_ti_double_arr + +subroutine ext_pio_get_var_ti_double_sca(DataHandle,Element,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + real*8, intent(out) :: Data + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + real*8, allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_inq_att(DH%file_handle,DH%descVar(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att(DH%file_handle,DH%descVar(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_get_var_ti_double_sca + +subroutine ext_pio_get_var_td_double_arr(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real*8, intent(out) :: Data(:) + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + real*8, allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_varid(DH%file_handle,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + !stat = NFMPI_INQ_VAR(file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + stat = pio_inquire_variable(DH%file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) 'Fatal MDVAR DIM NOT 1D in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_inq_dimlen(DH%file_handle,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_var(DH%file_handle,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_var_td_double_arr + +subroutine ext_pio_get_var_td_double_sca(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + real*8, intent(out) :: Data + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + real*8, allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_varid(DH%file_handle,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + !stat = NFMPI_INQ_VAR(file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + stat = pio_inquire_variable(DH%file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) 'Fatal MDVAR DIM NOT 1D in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_inq_dimlen(DH%file_handle,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_var(DH%file_handle,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_var_td_double_sca + +subroutine ext_pio_get_var_ti_integer_arr(DataHandle,Element,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + integer, intent(out) :: Data(:) + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + integer, allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_inq_att(DH%file_handle,DH%descVar(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att(DH%file_handle,DH%descVar(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_get_var_ti_integer_arr + +subroutine ext_pio_get_var_ti_integer_sca(DataHandle,Element,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + integer, intent(out) :: Data + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + integer, allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_inq_att(DH%file_handle,DH%descVar(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att(DH%file_handle,DH%descVar(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_get_var_ti_integer_sca + +subroutine ext_pio_get_var_td_integer_arr(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer, intent(out) :: Data(:) + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_varid(DH%file_handle,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + !stat = NFMPI_INQ_VAR(file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + stat = pio_inquire_variable(DH%file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) 'Fatal MDVAR DIM NOT 1D in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_inq_dimlen(DH%file_handle,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_var(DH%file_handle,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count)) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_var_td_integer_arr + +subroutine ext_pio_get_var_td_integer_sca(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer, intent(out) :: Data + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_varid(DH%file_handle,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + !stat = NFMPI_INQ_VAR(file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + stat = pio_inquire_variable(DH%file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if( .NOT. ( XType==PIO_REAL .OR. XType==PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) 'Fatal MDVAR DIM NOT 1D in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_inq_dimlen(DH%file_handle,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_var(DH%file_handle,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_var_td_integer_sca + +subroutine ext_pio_get_var_ti_logical_arr(DataHandle,Element,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + logical, intent(out) :: Data(:) + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + integer, allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_inq_att(DH%file_handle,DH%descVar(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if(XType /= PIO_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att(DH%file_handle,DH%descVar(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data(1:min(XLen,Count)) = Buffer(1:min(XLen,Count))==1 + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_get_var_ti_logical_arr + +subroutine ext_pio_get_var_ti_logical_sca(DataHandle,Element,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + logical, intent(out) :: Data + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + integer, allocatable :: Buffer(:) + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_inq_att(DH%file_handle,DH%descVar(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if(XType /= PIO_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + allocate(Buffer(XLen), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_att(DH%file_handle,DH%descVar(NVar),trim(Element), Buffer ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(XLen > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = XLen + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_get_var_ti_logical_sca + +subroutine ext_pio_get_var_td_logical_arr(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + logical, intent(out) :: Data(:) + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_varid(DH%file_handle,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = pio_inquire_variable(DH%file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if(XType /= PIO_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) 'Fatal MDVAR DIM NOT 1D in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_inq_dimlen(DH%file_handle,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_var(DH%file_handle,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data(1:min(Len1,Count)) = Buffer(1:min(Len1,Count))==1 + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_var_td_logical_arr + +subroutine ext_pio_get_var_td_logical_sca(DataHandle,Element,DateStr,Var,Data,Count,OutCount,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + logical, intent(out) :: Data + integer, intent(in) :: Count + integer, intent(out) :: OutCount + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + integer ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_varid(DH%file_handle,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = pio_inquire_variable(DH%file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if(XType /= PIO_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) 'Fatal MDVAR DIM NOT 1D in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_inq_dimlen(DH%file_handle,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = min(Count,Len1) + VCount(2) = 1 + allocate(Buffer(VCount(1)), STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_ALLOCATION_ERROR + write(msg,*) 'Fatal ALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_get_var(DH%file_handle,VarID,VStart,VCount,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data = Buffer(1) + deallocate(Buffer, STAT=stat) + if(stat/= 0) then + Status = WRF_ERR_FATAL_DEALLOCATION_ERR + write(msg,*) 'Fatal DEALLOCATION ERROR in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + if(Len1 > Count) then + OutCount = Count + Status = WRF_WARN_MORE_DATA_IN_FILE + else + OutCount = Len1 + Status = WRF_NO_ERR + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','LOGICAL',', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_var_td_logical_sca + +subroutine ext_pio_get_var_ti_char_arr(DataHandle,Element,Var,Data,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + character*(*) ,intent(out) :: Data + integer :: Count = 1 + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_inq_att(DH%file_handle,DH%descVar(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if(XType /= PIO_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','CHAR',', line', __LINE__ + return + endif + if(XLen > len(Data)) then + Status = WRF_WARN_CHARSTR_GT_LENDATA + write(msg,*) 'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + stat = pio_get_att(DH%file_handle,DH%descVar(NVar),trim(Element), Data ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_get_var_ti_char_arr + +subroutine ext_pio_get_var_ti_char_sca(DataHandle,Element,Var,Data,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: Var + character*(*) ,intent(out) :: Data + integer :: Count = 1 + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: XLen + + character (VarNameLen) :: VarName + integer :: stat + integer :: NVar + integer :: XType + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + enddo + stat = pio_inq_att(DH%file_handle,DH%descVar(NVar),trim(Element),XType,XLen) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + if(XType /= PIO_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','CHAR',', line', __LINE__ + return + endif + if(XLen > len(Data)) then + Status = WRF_WARN_CHARSTR_GT_LENDATA + write(msg,*) 'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + stat = pio_get_att(DH%file_handle,DH%descVar(NVar),trim(Element), Data ) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + endif + + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + return +end subroutine ext_pio_get_var_ti_char_sca + +subroutine ext_pio_get_var_td_char_arr(DataHandle,Element,DateStr,Var,Data,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character*(*) ,intent(out) :: Data + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + integer, parameter :: Count = 1 + character(DateStrLen) :: Buffer(1) + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_varid(DH%file_handle,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + stat = pio_inquire_variable(DH%file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if(XType /= PIO_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) 'Fatal MDVAR DIM NOT 1D in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_inq_dimlen(DH%file_handle,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Len1 + VCount(2) = 1 + if(Len1 > len(Data)) then + Status = WRF_WARN_CHARSTR_GT_LENDATA + write(msg,*) 'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data = '' + stat = pio_get_var(DH%file_handle,VarID,VStart,VCount,Buffer) + !stat = pio_get_var(DH%file_handle,VarID,Buffer) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data = Buffer(1) + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line', __LINE__ + endif + return +end subroutine ext_pio_get_var_td_char_arr + +subroutine ext_pio_get_var_td_char_sca(DataHandle,Element,DateStr,Var,Data,Status) + use pio_kinds + use pio + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character (DateStrLen),intent(in) :: DateStr + character*(*) ,intent(in) :: Var + character*(*) ,intent(out) :: Data + + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + character (VarNameLen) :: VarName + character (40+len(Element)) :: Name + character (40+len(Element)) :: FName + integer :: stat + character (80) ,allocatable :: Buffer(:) + integer :: i + integer :: VDims (2) + integer :: VStart(2) + integer :: VCount(2) + integer :: NVar + integer :: TimeIndex + integer :: DimIDs(2) + integer :: VarID + integer :: XType + integer :: NDims + integer :: NAtts + integer :: Len1 + integer, parameter :: Count = 1 + + if(Count <= 0) then + Status = WRF_WARN_ZERO_LENGTH_GET + write(msg,*) 'Warning ZERO LENGTH GET in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VarName = Var + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + call GetName(Element, VarName, Name, Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WONLY FILE in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + stat = pio_inq_varid(DH%file_handle,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + !stat = NFMPI_INQ_VAR(file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + stat = pio_inquire_variable(DH%file_handle,VarID,FName,XType,NDims,DimIDs,NAtts) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' Element ',Element + call wrf_debug ( WARN , msg) + return + endif + if(XType /= PIO_CHAR) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + if(NDims /= NMDVarDims) then + Status = WRF_ERR_FATAL_MDVAR_DIM_NOT_1D + write(msg,*) 'Fatal MDVAR DIM NOT 1D in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( FATAL , msg) + return + endif + stat = pio_inq_dimlen(DH%file_handle,DimIDs(1),Len1) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__,' DimIDs(1) ',DimIDs(1) + call wrf_debug ( WARN , msg) + return + endif + call GetTimeIndex('read',DataHandle,DateStr,TimeIndex,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + VStart(1) = 1 + VStart(2) = TimeIndex + VCount(1) = Len1 + VCount(2) = 1 + if(Len1 > len(Data)) then + Status = WRF_WARN_CHARSTR_GT_LENDATA + write(msg,*) 'Warning LEN CHAR STRING > LEN DATA in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + Data = '' + !stat = pio_get_var(DH%file_handle,VarID,VStart,VCount,Data) + stat = pio_get_var(DH%file_handle,VarID,Data) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,' ','CHAR',', line', __LINE__ + endif + return +end subroutine ext_pio_get_var_td_char_sca + +subroutine ext_pio_put_dom_td_real_arr(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real ,intent(in) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_pio_put_var_td_real_arr(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_pio_put_dom_td_real_arr + +subroutine ext_pio_put_dom_td_real_sca(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real ,intent(in) :: Data + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_pio_put_var_td_real_sca(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_pio_put_dom_td_real_sca + +subroutine ext_pio_put_dom_td_integer_arr(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + integer ,intent(in) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_pio_put_var_td_integer_arr(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_pio_put_dom_td_integer_arr + +subroutine ext_pio_put_dom_td_integer_sca(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + integer ,intent(in) :: Data + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_pio_put_var_td_integer_sca(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_pio_put_dom_td_integer_sca + +subroutine ext_pio_put_dom_td_double_arr(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real*8 ,intent(in) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_pio_put_var_td_double_arr(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_pio_put_dom_td_double_arr + +subroutine ext_pio_put_dom_td_double_sca(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real*8 ,intent(in) :: Data + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_pio_put_var_td_double_sca(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_pio_put_dom_td_double_sca + +subroutine ext_pio_put_dom_td_logical_arr(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + logical ,intent(in) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_pio_put_var_td_logical_arr(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_pio_put_dom_td_logical_arr + +subroutine ext_pio_put_dom_td_logical_sca(DataHandle,Element,DateStr,Data,Count,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + logical ,intent(in) :: Data + integer ,intent(in) :: Count + integer ,intent(out) :: Status + + call ext_pio_put_var_td_logical_sca(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,Status) + return +end subroutine ext_pio_put_dom_td_logical_sca + +subroutine ext_pio_put_dom_td_char_arr(DataHandle,Element,DateStr,Data,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Data + integer ,intent(out) :: Status + + call ext_pio_put_var_td_char_arr(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) + return +end subroutine ext_pio_put_dom_td_char_arr + +subroutine ext_pio_put_dom_td_char_sca(DataHandle,Element,DateStr,Data,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Data + integer ,intent(out) :: Status + + call ext_pio_put_var_td_char_sca(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) + return +end subroutine ext_pio_put_dom_td_char_sca + +subroutine ext_pio_get_dom_td_real_arr(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real ,intent(out) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_pio_get_var_td_real_arr(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_pio_get_dom_td_real_arr + +subroutine ext_pio_get_dom_td_real_sca(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real ,intent(out) :: Data + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_pio_get_var_td_real_sca(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_pio_get_dom_td_real_sca + +subroutine ext_pio_get_dom_td_integer_arr(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + integer ,intent(out) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_pio_get_var_td_integer_arr(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_pio_get_dom_td_integer_arr + +subroutine ext_pio_get_dom_td_integer_sca(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + integer ,intent(out) :: Data + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_pio_get_var_td_integer_sca(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_pio_get_dom_td_integer_sca + +subroutine ext_pio_get_dom_td_double_arr(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real*8 ,intent(out) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_pio_get_var_td_double_arr(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_pio_get_dom_td_double_arr + +subroutine ext_pio_get_dom_td_double_sca(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + real*8 ,intent(out) :: Data + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_pio_get_var_td_double_sca(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_pio_get_dom_td_double_sca + +subroutine ext_pio_get_dom_td_logical_arr(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + logical ,intent(out) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_pio_get_var_td_logical_arr(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_pio_get_dom_td_logical_arr + +subroutine ext_pio_get_dom_td_logical_sca(DataHandle,Element,DateStr,Data,Count,OutCount,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + logical ,intent(out) :: Data(:) + integer ,intent(in) :: Count + integer ,intent(out) :: OutCount + integer ,intent(out) :: Status + call ext_pio_get_var_td_logical_sca(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Count,OutCount,Status) + return +end subroutine ext_pio_get_dom_td_logical_sca + +subroutine ext_pio_get_dom_td_char_arr(DataHandle,Element,DateStr,Data,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(out) :: Data + integer ,intent(out) :: Status + call ext_pio_get_var_td_char_arr(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) + return +end subroutine ext_pio_get_dom_td_char_arr + +subroutine ext_pio_get_dom_td_char_sca(DataHandle,Element,DateStr,Data,Status) + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Element + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(out) :: Data + integer ,intent(out) :: Status + call ext_pio_get_var_td_char_sca(DataHandle,Element,DateStr, & + 'E_X_T_D_O_M_A_I_N_M_E_T_A_DATA_' ,Data,Status) + return +end subroutine ext_pio_get_dom_td_char_sca + +subroutine ext_pio_write_field(DataHandle,DateStr,Var,Field,FieldType,grid, & + DomainDesc, MemoryOrdIn, Stagger, DimNames, & + DomainStart, DomainEnd, MemoryStart, MemoryEnd, & + PatchStart, PatchEnd, Status) + use wrf_data_pio + use pio_routines + use module_domain + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer ,intent(inout) :: Field(*) + integer ,intent(in) :: FieldType + type(domain) :: grid + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrdIn + character*(*) ,intent(in) :: Stagger + character*(*) ,dimension(*) ,intent(in) :: DimNames + integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd + integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd + integer ,intent(out) :: Status + character (3) :: MemoryOrder + type(wrf_data_handle) ,pointer :: DH + integer :: NDim + character (VarNameLen) :: VarName + character (3) :: MemO + character (3) :: UCMemO + integer ,dimension(NVarDims) :: Length_global + integer ,dimension(NVarDims) :: Length + integer ,dimension(NVarDims) :: VDimIDs + character(80),dimension(NVarDims) :: RODimNames + integer ,dimension(NVarDims) :: VStart + integer ,dimension(NVarDims) :: VCount + integer :: stat + integer :: NVar + integer :: i,j,n,fldsize + integer :: XType + character (80) :: NullName + logical :: NotFound + integer, dimension(1,1) :: tmp0dint + integer, dimension(:,:,:), allocatable :: tmp2dint + + !Local, possibly adjusted, copies of MemoryStart and MemoryEnd + MemoryOrder = trim(adjustl(MemoryOrdIn)) + NullName=char(0) + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER |',MemoryOrder,'| in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + !call pio_setdebuglevel(1) + + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR |',DateStr,'| in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + VarName = Var + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + write(msg,*)'ext_pio_write_field: called for ',TRIM(Var) + CALL wrf_debug( 100, msg ) + + VCount(1:NDim) = PatchEnd(1:NDim)-PatchStart(1:NDim)+1 + Length_global(1:NDim) = DomainEnd(1:NDim)-DomainStart(1:NDim)+1 + + call ExtOrder(MemoryOrder,VCount,Status) + call ExtOrder(MemoryOrder,Length_global,Status) + + call ExtOrderStr(MemoryOrder,DimNames,RODimNames,Status) + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + Status = WRF_WARN_WRITE_RONLY_FILE + write(msg,*) 'Warning WRITE READ ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + + do NVar=1,MaxVars + if(DH%VarNames(NVar) == VarName ) then + Status = WRF_WARN_2DRYRUNS_1VARIABLE + write(msg,*) 'Warning 2 DRYRUNS 1 VARIABLE (',TRIM(VarName),') in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%VarNames(NVar) == NO_NAME) then + DH%VarNames(NVar) = VarName + DH%NumVars = NVar + DH%CurrentVariable= NVar + exit + elseif(NVar == MaxVars) then + Status = WRF_WARN_TOO_MANY_VARIABLES + write(msg,*) 'Warning TOO MANY VARIABLES in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + + if(DH%Write)then + DH%Write = .false. + stat = pio_redef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + endif + + do j = 1,NDim + VDimIDs(j) = 0 + if(RODimNames(j) == NullName .or. RODimNames(j) == '') then + do i=1,MaxDims + if(DH%DimLengths(i) == Length_global(j)) then + VDimIDs(j) = DH%DimIDs(i) + exit + elseif(DH%DimLengths(i) == NO_DIM) then + DH%DimLengths(i) = Length_global(j) + stat = pio_def_dim(DH%file_handle, DH%DimNames(i), DH%DimLengths(i), DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + VDimIDs(j) = DH%DimIDs(i) + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS (',i,') in (',TRIM(VarName),') ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + else !look for input name and check if already defined + NotFound = .true. + do i=1,MaxDims + if (DH%DimNames(i) == RODimNames(j)) then + if (DH%DimLengths(i) == Length_global(j)) then + VDimIDs(j) = DH%DimIDs(i) + NotFound = .false. + exit + else + Status = WRF_WARN_DIMNAME_REDEFINED + write(msg,*) 'Warning DIM ',i,', NAME ',TRIM(DH%DimNames(i)),' REDEFINED by var ', & + TRIM(Var),' ',DH%DimLengths(i),Length_global(j) ,' in ', __FILE__ ,' line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + endif + enddo + if (NotFound) then + do i=1,MaxDims + if (DH%DimLengths(i) == NO_DIM) then + DH%DimNames(i) = RODimNames(j) + DH%DimLengths(i) = Length_global(j) + stat = pio_def_dim(DH%file_handle, DH%DimNames(i), DH%DimLengths(i), DH%DimIDs(i)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + VDimIDs(j) = DH%DimIDs(i) + exit + elseif(i == MaxDims) then + Status = WRF_WARN_TOO_MANY_DIMS + write(msg,*) 'Warning TOO MANY DIMENSIONS in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + endif + endif + DH%VarDimLens(j,DH%NumVars) = Length_global(j) + enddo + + select case (FieldType) + case (WRF_REAL) + XType = PIO_REAL + case (WRF_DOUBLE) + Xtype = PIO_DOUBLE + case (WRF_INTEGER) + XType = PIO_INT + case (WRF_LOGICAL) + XType = PIO_INT + case default + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + end select + + VDimIDs(NDim+1) = DH%DimUnlimID + !write(unit=0, fmt='(/3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + !write(unit=0, fmt='(3a,i6)') '1 Define Var <', trim(Var), '> as NVar:', DH%NumVars + stat = pio_def_var(DH%file_handle,VarName,XType,VDimIDs(1:NDim+1),DH%descVar(DH%NumVars)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_pio_write_field: NetCDF error for ',TRIM(VarName),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + !write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ + !write(unit=0, fmt='(a,i6)') 'DH%descVar(DH%NumVars)%VarID = ', DH%descVar(DH%NumVars)%VarID + + stat = pio_put_att(DH%file_handle,DH%descVar(DH%NumVars),'FieldType',FieldType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_pio_write_field: NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call reorder(MemoryOrder,MemO) + call uppercase(MemO,UCMemO) + stat = pio_put_att(DH%file_handle,DH%descVar(DH%NumVars),'MemoryOrder',UCMemO) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'ext_pio_write_field: NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + if(.not. DH%Write) then + DH%Write = .true. + stat = pio_enddef(DH%file_handle) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error (',stat,') in file ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + endif + + do NVar=1,DH%NumVars + if(DH%VarNames(NVar) == VarName) then + DH%CurrentVariable = NVar + exit + elseif(NVar == DH%NumVars) then + Status = WRF_WARN_VAR_NF + write(msg,*) 'Warning VARIABLE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + + DH%vartype(DH%CurrentVariable) = NOT_LAND_SOIL_VAR + fldsize = 1 + + do j=1,NDim + if(Length_global(j) /= DH%VarDimLens(j,DH%CurrentVariable) .AND. DH%FileStatus /= WRF_FILE_OPENED_FOR_UPDATE ) then + Status = WRF_WARN_WRTLEN_NE_DRRUNLEN + write(msg,*) 'Warning LENGTH != DRY RUN LENGTH for |', & + VarName,'| dim ',j,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + write(msg,*) ' LENGTH ',Length_global(j),' DRY RUN LENGTH ',DH%VarDimLens(j,DH%CurrentVariable) + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(PatchStart(j) < MemoryStart(j)) then + Status = WRF_WARN_DIMENSION_ERROR + write(msg,*) 'Warning DIMENSION ERROR for |',VarName, & + '| in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + + VStart = 1 + VStart(1:NDim) = PatchStart(1:NDim) + call ExtOrder(MemoryOrder,VStart,Status) + + do n = 1, NDim + VDimIDs(n) = 0 + do i=1,MaxDims + if(DH%DimLengths(i) == Length_global(n)) then + VDimIDs(n) = DH%DimIDs(i) + exit + end if + end do + + Length(n) = MemoryEnd(n) - MemoryStart(n) + 1 + fldsize = fldsize * Length(n) + + if("land_cat_stag" == DimNames(n)) then + DH%vartype(DH%CurrentVariable) = LAND_CAT_VAR + else if("soil_cat_stag" == DimNames(n)) then + DH%vartype(DH%CurrentVariable) = SOIL_CAT_VAR + else if("soil_layers_stag" == DimNames(n)) then + DH%vartype(DH%CurrentVariable) = SOIL_LAYERS_VAR + else if("num_ext_model_couple_dom_stag" == DimNames(n)) then + DH%vartype(DH%CurrentVariable) = MDL_CPL_VAR + else if("ensemble_stag" == DimNames(n)) then + DH%vartype(DH%CurrentVariable) = ENSEMBLE_VAR + endif + end do + +#ifndef INTSPECIAL + call FieldIO('write',DataHandle,DateStr,Length_global,VStart,VCount,Length,MemoryOrder, & + Stagger,FieldType,Field,Status) +#else + if(WRF_INTEGER == FieldType) then + if(1 == fldsize) then + tmp0dint(1,1) = Field(1) + stat = pio_put_var(DH%file_handle,DH%descVar(DH%CurrentVariable),tmp0dint) + call netcdf_err(stat,Status) + else if(2 == Ndim) then + allocate(tmp2dint(Length(1),Length(2),1), stat=Status) + n = 0 + do j=1,Length(2) + do i=1,Length(1) + n=n+1 + tmp2dint(i,j,1) = Field(n) + enddo + enddo + call pio_write_darray(DH%file_handle, DH%descVar(DH%CurrentVariable), & + DH%iodesc2d_m_int, tmp2dint, Status) + deallocate(tmp2dint) + else + call FieldIO('write',DataHandle,DateStr,Length_global,VStart,VCount,Length,MemoryOrder, & + Stagger,FieldType,Field,Status) + endif + else + call FieldIO('write',DataHandle,DateStr,Length_global,VStart,VCount,Length,MemoryOrder, & + Stagger,FieldType,Field,Status) + end if +#endif + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , TRIM(msg)) + endif + return +end subroutine ext_pio_write_field + +subroutine ext_pio_read_field(DataHandle,DateStr,Var,Field,FieldType,grid, & + DomainDesc, MemoryOrdIn, Stagger, DimNames, & + DomainStart,DomainEnd,MemoryStart,MemoryEnd, & + PatchStart,PatchEnd,Status) + use wrf_data_pio + use pio_routines + use module_utility + use module_domain + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + character*(*) ,intent(in) :: Var + integer ,intent(out) :: Field(*) + integer ,intent(in) :: FieldType + type(domain) :: grid + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrdIn + character*(*) ,intent(in) :: Stagger ! Dummy for now + character*(*) , dimension (*) ,intent(in) :: DimNames + integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd + integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd + integer ,intent(out) :: Status + character (3) :: MemoryOrder + character(PIO_MAX_NAME) :: dimname + type(wrf_data_handle) ,pointer :: DH + integer :: NDim + character (VarNameLen) :: VarName + integer ,dimension(NVarDims) :: VCount + integer ,dimension(NVarDims) :: VStart + integer ,dimension(NVarDims) :: VDimen + integer ,dimension(NVarDims) :: Length +#if 0 + integer ,dimension(NVarDims) :: StoredLen +#endif + integer ,dimension(NVarDims) :: VDimIDs + integer ,dimension(NVarDims) :: MemS + integer ,dimension(NVarDims) :: MemE + integer :: NVar + character (VarNameLen) :: Name + integer :: XType + integer :: StoredDim + integer :: VarID + integer :: NDims + integer :: NAtts + integer(KIND=PIO_OFFSET) :: Len + integer :: stat + integer :: i, j, n, fldsize + integer :: FType + logical :: isbdy + integer, dimension(:,:,:), allocatable :: tmp2dint + character (len=2) :: readinStagger + + MemoryOrder = trim(adjustl(MemoryOrdIn)) + + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER |',TRIM(MemoryOrder),'| for |', & + TRIM(Var),'| in ext_pio_read_field ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR |',TRIM(DateStr),'| for |',TRIM(Var), & + '| in ext_pio_read_field ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ext_pio_read_field ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + VarName = Var + DH%CurrentVariable = DH%CurrentVariable + 1 + DH%VarNames(DH%CurrentVariable) = VarName + + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + RETURN + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then + !call pio_seterrorhandling(DH%file_handle, PIO_BCAST_ERROR) + stat = pio_inq_varid(DH%file_handle,VarName,DH%descVar(DH%CurrentVariable)) + !call pio_seterrorhandling(DH%file_handle, PIO_INTERNAL_ERROR) + !if(stat /= PIO_NOERR) then + ! DH%descVar(DH%CurrentVariable)%varID = 0 + ! write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Varname, ',Varname, ' not found in file.' + ! call wrf_debug ( WARN , TRIM(msg)) + ! return + !endif + + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__,' Varname ',Varname + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + stat = pio_inquire_variable(DH%file_handle,DH%descVar(DH%CurrentVariable), & + Name,XType,StoredDim,VDimIDs,NAtts) + + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = pio_get_att(DH%file_handle,DH%descVar(DH%CurrentVariable),'FieldType',FType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + + readinStagger = '' + stat = pio_get_att(DH%file_handle,DH%descVar(DH%CurrentVariable),'stagger',readinStagger) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,' ','CHAR',', line', __LINE__ + call wrf_debug ( WARN , msg) + return + endif + +!---allow coercion between double and single prec real + if( (FieldType == WRF_REAL .OR. FieldType == WRF_DOUBLE) ) then + if ( .NOT. (Ftype == WRF_REAL .OR. Ftype == WRF_DOUBLE )) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + else if(FieldType /= Ftype) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning TYPE MISMATCH in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + select case (FieldType) + case (WRF_REAL) + !allow coercion between double and single prec real + if(.NOT. (XType == PIO_REAL .OR. XType == PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning REAL TYPE MISMATCH in ',__FILE__,', line', __LINE__ + endif + case (WRF_DOUBLE) + !allow coercion between double and single prec real + if(.NOT. (XType == PIO_REAL .OR. XType == PIO_DOUBLE) ) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning DOUBLE TYPE MISMATCH in ',__FILE__,', line', __LINE__ + endif + case (WRF_INTEGER) + if(XType /= PIO_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning INTEGER TYPE MISMATCH in ',__FILE__,', line', __LINE__ + endif + case (WRF_LOGICAL) + if(XType /= PIO_INT) then + Status = WRF_WARN_TYPE_MISMATCH + write(msg,*) 'Warning LOGICAL TYPE MISMATCH in ',__FILE__,', line', __LINE__ + endif + case default + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + end select + if(Status /= WRF_NO_ERR) then + call wrf_debug ( WARN , TRIM(msg)) + return + endif + ! NDim=0 for scalars. Handle read of old NDim=1 files. TBH: 20060502 + IF ( ( NDim == 0 ) .AND. ( StoredDim == 2 ) ) THEN + stat = pio_inq_dimname(DH%file_handle,VDimIDs(1),dimname) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + IF ( dimname(1:10) == 'ext_scalar' ) THEN + NDim = 1 + VCount(1) = 1 + ENDIF + ENDIF + if(StoredDim /= NDim+1) then + Status = WRF_ERR_FATAL_BAD_VARIABLE_DIM + write(msg,*) 'Fatal error BAD VARIABLE DIMENSION in ext_pio_read_field ',TRIM(Var),TRIM(DateStr) + call wrf_debug ( FATAL , msg) + write(msg,*) ' StoredDim ', StoredDim, ' .NE. NDim+1 ', NDim+1 + call wrf_debug ( FATAL , msg) + return + endif +#if 0 + do n=1,NDim + stat = pio_inq_dimlen(DH%file_handle,VDimIDs(n),StoredLen(n)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(VCount(n) > StoredLen(n)) then + Status = WRF_WARN_READ_PAST_EOF + write(msg,*) 'Warning READ PAST EOF in ext_pio_read_field of ',TRIM(Var),VCount(n),'>',StoredLen(n) + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(VCount(n) <= 0) then + Status = WRF_WARN_ZERO_LENGTH_READ + write(msg,*) 'Warning ZERO LENGTH READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo +#endif + !write(unit=0, fmt='(//3a,i6)') 'file: ',__FILE__,', line', __LINE__ + !write(unit=0, fmt='(4x,a,i6,2a)') 'DH%CurrentVariable = ', DH%CurrentVariable, ', name: ', trim(VarName) + + VStart(1:NDim) = PatchStart(1:NDim) + VCount(1:NDim) = PatchEnd(1:NDim) - PatchStart(1:NDim) + 1 + VDimen(1:NDim) = DomainEnd(1:NDim) - DomainStart(1:NDim) + 1 + + !do n = 1, NDim + ! write(unit=0, fmt='(4x,8(a,i2,a,i6))') & + ! 'DomainStart(', n, ')=', DomainStart(n), ', DomainEnd(', n, ')=', DomainEnd(n), & + ! ', MemoryStart(', n, ')=', MemoryStart(n), ', MemoryEnd(', n, ')=', MemoryEnd(n), & + ! ', PatchStart(', n, ')=', PatchStart(n), ', PatchEnd(', n, ')=', PatchEnd(n), & + ! ', VStart(', n, ')=', VStart(n), ', VCount(', n, ')=', VCount(n) + !end do + + call ExtOrder(MemoryOrder,VStart,Status) + call ExtOrder(MemoryOrder,VCount,Status) + call ExtOrder(MemoryOrder,VDimen,Status) + + DH%vartype(DH%CurrentVariable) = NOT_LAND_SOIL_VAR + fldsize = 1 + do n = 1, NDim + Length(n) = MemoryEnd(n) - MemoryStart(n) + 1 + fldsize = fldsize * Length(n) + + !write(unit=0, fmt='(4x,2(a,i2,a,i6))') & + ! 'VStart(', n, ')=', VStart(n), ', VCount(', n, ')=', VCount(n) + + if("land_cat_stag" == DH%DimNames(VDimIDs(n))) then + DH%vartype(DH%CurrentVariable) = LAND_CAT_VAR + else if("soil_cat_stag" == DH%DimNames(VDimIDs(n))) then + DH%vartype(DH%CurrentVariable) = SOIL_CAT_VAR + else if("soil_layers_stag" == DH%DimNames(VDimIDs(n))) then + DH%vartype(DH%CurrentVariable) = SOIL_LAYERS_VAR + else if("num_ext_model_couple_dom_stag" == DH%DimNames(VDimIDs(n))) then + DH%vartype(DH%CurrentVariable) = MDL_CPL_VAR + else if("ensemble_stag" == DH%DimNames(VDimIDs(n))) then + DH%vartype(DH%CurrentVariable) = ENSEMBLE_VAR + endif + end do + +#ifndef INTSPECIAL + isbdy = is_boundary(MemoryOrder) + if(isbdy) then + !write(unit=0, fmt='(//3a,i6)') 'file: ',__FILE__,', line', __LINE__ + !write(unit=0, fmt='(4x,a,i6,2a)') 'DH%CurrentVariable = ', + !DH%CurrentVariable, ', name: ', trim(VarName) + + call FieldBDY('read',DataHandle,DateStr,NDim,VDimen, & + MemoryStart,MemoryEnd,PatchStart,PatchEnd, & + FieldType,Field,Status) + else + !if((WRF_INTEGER == FieldType) .and. (1 == fldsize)) then + ! Status = pio_get_var(DH%file_handle,DH%descVar(DH%CurrentVariable),VCount(1:1)) + ! Field(1) = VCount(1) + !else + call FieldIO('read',DataHandle,DateStr,VDimen,VStart,VCount,Length,MemoryOrder, & + readinStagger,FieldType,Field,Status) + !endif + endif +#else + if(WRF_INTEGER == FieldType) then + if(1 == fldsize) then + Status = pio_get_var(DH%file_handle,DH%descVar(DH%CurrentVariable),VCount(1:1)) + Field(1) = VCount(1) + else if(2 == Ndim) then + allocate(tmp2dint(Length(1),Length(2),1), stat=Status) + call pio_read_darray(DH%file_handle, DH%descVar(DH%CurrentVariable), & + DH%iodesc2d_m_int, tmp2dint, Status) +! DH%ioVar(DH%CurrentVariable), tmp2dint, Status) + n = 0 + do j=1,Length(2) + do i=1,Length(1) + n=n+1 + Field(n) = tmp2dint(i,j,1) + enddo + enddo + deallocate(tmp2dint) + else + call FieldIO('read',DataHandle,DateStr,VDimen,VStart,VCount,Length,MemoryOrder, & + readinStagger,FieldType,Field,Status) + endif + else + isbdy = is_boundary(MemoryOrder) + if(isbdy) then + !write(unit=0, fmt='(//3a,i6)') 'file: ',__FILE__,', line', __LINE__ + !write(unit=0, fmt='(4x,a,i6,2a)') 'DH%CurrentVariable = ', DH%CurrentVariable, ', name: ', trim(VarName) + + call FieldBDY('read',DataHandle,DateStr,NDim,VDimen, & + MemoryStart,MemoryEnd,PatchStart,PatchEnd, & + FieldType,Field,Status) + else + call FieldIO('read',DataHandle,DateStr,VDimen,VStart,VCount,Length,MemoryOrder, & + readinStagger,FieldType,Field,Status) + endif + endif +#endif + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_read_field + +subroutine ext_pio_inquire_opened( DataHandle, FileName , FileStatus, Status ) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(inout) :: FileName + integer ,intent(out) :: FileStatus + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + + call upgrade_filename(FileName) + !call upgrade_filename(DH%FileName) + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + FileStatus = WRF_FILE_NOT_OPENED + return + endif + if(trim(FileName) /= trim(DH%FileName)) then + FileStatus = WRF_FILE_NOT_OPENED + else + FileStatus = DH%FileStatus + endif + Status = WRF_NO_ERR + return +end subroutine ext_pio_inquire_opened + +subroutine ext_pio_inquire_filename( Datahandle, FileName, FileStatus, Status ) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: FileName + integer ,intent(out) :: FileStatus + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + FileStatus = WRF_FILE_NOT_OPENED + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + FileName = trim(DH%FileName) + !call upgrade_filename(FileName) + FileStatus = DH%FileStatus + Status = WRF_NO_ERR + return +end subroutine ext_pio_inquire_filename + +subroutine ext_pio_set_time(DataHandle, DateStr, Status) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: DateStr + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: i + + call DateCheck(DateStr,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_FILE_NOT_COMMITTED + write(msg,*) 'Warning FILE NOT COMMITTED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + do i=1,MaxTimes + if(DH%Times(i)==DateStr) then + DH%CurrentTime = i + exit + endif + if(i==MaxTimes) then + Status = WRF_WARN_TIME_NF + return + endif + enddo + DH%CurrentVariable = 0 + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_set_time + +subroutine ext_pio_get_next_time(DataHandle, DateStr, Status) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: DateStr + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE ) then + if(DH%CurrentTime >= DH%NumberTimes) then + write(msg,*) 'Warning ext_pio_get_next_time: DH%CurrentTime >= DH%NumberTimes ',DH%CurrentTime,DH%NumberTimes + call wrf_debug ( WARN , TRIM(msg)) + Status = WRF_WARN_TIME_EOF + return + endif + DH%CurrentTime = DH%CurrentTime +1 + DateStr = DH%Times(DH%CurrentTime) + DH%CurrentVariable = 0 + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_next_time + +subroutine ext_pio_get_previous_time(DataHandle, DateStr, Status) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: DateStr + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ) then + if(DH%CurrentTime.GT.0) then + DH%CurrentTime = DH%CurrentTime -1 + endif + DateStr = DH%Times(DH%CurrentTime) + DH%CurrentVariable = 0 + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_previous_time + +subroutine ext_pio_get_next_var(DataHandle, VarName, Status) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(out) :: VarName + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + character (80) :: Name + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + + DH%CurrentVariable = DH%CurrentVariable +1 + if(DH%CurrentVariable > DH%NumVars) then + Status = WRF_WARN_VAR_EOF + return + endif + VarName = DH%VarNames(DH%CurrentVariable) + Status = WRF_NO_ERR + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_next_var + +subroutine ext_pio_end_of_frame(DataHandle, Status) + use pio_kinds + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + + call GetDH(DataHandle,DH,Status) + return +end subroutine ext_pio_end_of_frame + +! NOTE: For scalar variables NDim is set to zero and DomainStart and +! NOTE: DomainEnd are left unmodified. +subroutine ext_pio_get_var_info(DataHandle,Name,NDim,MemoryOrder,Stagger,DomainStart,DomainEnd,WrfType,Status) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: Name + integer ,intent(out) :: NDim + character*(*) ,intent(out) :: MemoryOrder + character*(*) :: Stagger ! Dummy for now + integer ,dimension(*) ,intent(out) :: DomainStart, DomainEnd + integer ,intent(out) :: WrfType + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: VarID + integer ,dimension(NVarDims) :: VDimIDs + integer :: j + integer :: stat + integer :: XType + + call GetDH(DataHandle,DH,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning Status = ',Status,' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + if(DH%FileStatus == WRF_FILE_NOT_OPENED) then + Status = WRF_WARN_FILE_NOT_OPENED + write(msg,*) 'Warning FILE NOT OPENED in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_NOT_COMMITTED) then + Status = WRF_WARN_DRYRUN_READ + write(msg,*) 'Warning DRYRUN READ in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_WRITE) then + Status = WRF_WARN_READ_WONLY_FILE + write(msg,*) 'Warning READ WRITE ONLY FILE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + elseif(DH%FileStatus == WRF_FILE_OPENED_FOR_READ .OR. DH%FileStatus == WRF_FILE_OPENED_FOR_UPDATE) then + stat = pio_inq_varid(DH%file_handle,Name,VarID) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = pio_inq_vartype(DH%file_handle,VarID,XType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = pio_get_att(DH%file_handle,VarID,'FieldType',WrfType) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + select case (XType) + !case (PIO_BYTE) + ! Status = WRF_WARN_BAD_DATA_TYPE + ! write(msg,*) 'Warning BYTE IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ + ! call wrf_debug ( WARN , TRIM(msg)) + ! return + case (PIO_CHAR) + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning CHAR IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + !case (PIO_SHORT) + ! Status = WRF_WARN_BAD_DATA_TYPE + ! write(msg,*) 'Warning SHORT IS BAD DATA TYPE in ',__FILE__,', line', __LINE__ + ! call wrf_debug ( WARN , TRIM(msg)) + ! return + case (PIO_INT) + if(WrfType /= WRF_INTEGER .and. WrfType /= WRF_LOGICAL) then + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + case (PIO_REAL) + if(WrfType /= WRF_REAL) then + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + case (PIO_DOUBLE) + if(WrfType /= WRF_DOUBLE) then + Status = WRF_WARN_BAD_DATA_TYPE + write(msg,*) 'Warning BAD DATA TYPE in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + case default + Status = WRF_WARN_DATA_TYPE_NOT_FOUND + write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + end select + + stat = pio_get_att(DH%file_handle,VarID,'MemoryOrder',MemoryOrder) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + call GetDim(MemoryOrder,NDim,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'Warning BAD MEMORY ORDER ',TRIM(MemoryOrder),' in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + stat = pio_inq_vardimid(DH%file_handle,VarID,VDimIDs) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + do j = 1, NDim + DomainStart(j) = 1 + stat = pio_inq_dimlen(DH%file_handle,VDimIDs(j),DomainEnd(j)) + call netcdf_err(stat,Status) + if(Status /= WRF_NO_ERR) then + write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ + call wrf_debug ( WARN , TRIM(msg)) + return + endif + enddo + else + Status = WRF_ERR_FATAL_BAD_FILE_STATUS + write(msg,*) 'Fatal error BAD FILE STATUS in ',__FILE__,', line', __LINE__ + call wrf_debug ( FATAL , msg) + endif + return +end subroutine ext_pio_get_var_info + +subroutine ext_pio_warning_str( Code, ReturnString, Status) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + + integer , intent(in) ::Code + character *(*), intent(out) :: ReturnString + integer, intent(out) ::Status + + SELECT CASE (Code) + CASE (0) + ReturnString='No error' + Status=WRF_NO_ERR + return + CASE (-1) + ReturnString= 'File not found (or file is incomplete)' + Status=WRF_NO_ERR + return + CASE (-2) + ReturnString='Metadata not found' + Status=WRF_NO_ERR + return + CASE (-3) + ReturnString= 'Timestamp not found' + Status=WRF_NO_ERR + return + CASE (-4) + ReturnString= 'No more timestamps' + Status=WRF_NO_ERR + return + CASE (-5) + ReturnString= 'Variable not found' + Status=WRF_NO_ERR + return + CASE (-6) + ReturnString= 'No more variables for the current time' + Status=WRF_NO_ERR + return + CASE (-7) + ReturnString= 'Too many open files' + Status=WRF_NO_ERR + return + CASE (-8) + ReturnString= 'Data type mismatch' + Status=WRF_NO_ERR + return + CASE (-9) + ReturnString= 'Attempt to write read-only file' + Status=WRF_NO_ERR + return + CASE (-10) + ReturnString= 'Attempt to read write-only file' + Status=WRF_NO_ERR + return + CASE (-11) + ReturnString= 'Attempt to access unopened file' + Status=WRF_NO_ERR + return + CASE (-12) + ReturnString= 'Attempt to do 2 trainings for 1 variable' + Status=WRF_NO_ERR + return + CASE (-13) + ReturnString= 'Attempt to read past EOF' + Status=WRF_NO_ERR + return + CASE (-14) + ReturnString= 'Bad data handle' + Status=WRF_NO_ERR + return + CASE (-15) + ReturnString= 'Write length not equal to training length' + Status=WRF_NO_ERR + return + CASE (-16) + ReturnString= 'More dimensions requested than training' + Status=WRF_NO_ERR + return + CASE (-17) + ReturnString= 'Attempt to read more data than exists' + Status=WRF_NO_ERR + return + CASE (-18) + ReturnString= 'Input dimensions inconsistent' + Status=WRF_NO_ERR + return + CASE (-19) + ReturnString= 'Input MemoryOrder not recognized' + Status=WRF_NO_ERR + return + CASE (-20) + ReturnString= 'A dimension name with 2 different lengths' + Status=WRF_NO_ERR + return + CASE (-21) + ReturnString= 'String longer than provided storage' + Status=WRF_NO_ERR + return + CASE (-22) + ReturnString= 'Function not supportable' + Status=WRF_NO_ERR + return + CASE (-23) + ReturnString= 'Package implements this routine as NOOP' + Status=WRF_NO_ERR + return + +!netcdf-specific warning messages + CASE (-1007) + ReturnString= 'Bad data type' + Status=WRF_NO_ERR + return + CASE (-1008) + ReturnString= 'File not committed' + Status=WRF_NO_ERR + return + CASE (-1009) + ReturnString= 'File is opened for reading' + Status=WRF_NO_ERR + return + CASE (-1011) + ReturnString= 'Attempt to write metadata after open commit' + Status=WRF_NO_ERR + return + CASE (-1010) + ReturnString= 'I/O not initialized' + Status=WRF_NO_ERR + return + CASE (-1012) + ReturnString= 'Too many variables requested' + Status=WRF_NO_ERR + return + CASE (-1013) + ReturnString= 'Attempt to close file during a dry run' + Status=WRF_NO_ERR + return + CASE (-1014) + ReturnString= 'Date string not 19 characters in length' + Status=WRF_NO_ERR + return + CASE (-1015) + ReturnString= 'Attempt to read zero length words' + Status=WRF_NO_ERR + return + CASE (-1016) + ReturnString= 'Data type not found' + Status=WRF_NO_ERR + return + CASE (-1017) + ReturnString= 'Badly formatted date string' + Status=WRF_NO_ERR + return + CASE (-1018) + ReturnString= 'Attempt at read during a dry run' + Status=WRF_NO_ERR + return + CASE (-1019) + ReturnString= 'Attempt to get zero words' + Status=WRF_NO_ERR + return + CASE (-1020) + ReturnString= 'Attempt to put zero length words' + Status=WRF_NO_ERR + return + CASE (-1021) + ReturnString= 'NetCDF error' + Status=WRF_NO_ERR + return + CASE (-1022) + ReturnString= 'Requested length <= 1' + Status=WRF_NO_ERR + return + CASE (-1023) + ReturnString= 'More data available than requested' + Status=WRF_NO_ERR + return + CASE (-1024) + ReturnString= 'New date less than previous date' + Status=WRF_NO_ERR + return + + CASE DEFAULT + ReturnString= 'This warning code is not supported or handled directly by WRF and NetCDF. & + & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & + & to be calling a package-specific routine to return a message for this warning code.' + Status=WRF_NO_ERR + END SELECT + + return +end subroutine ext_pio_warning_str + + +!returns message string for all WRF and netCDF warning/error status codes +!Other i/o packages must provide their own routines to return their own status messages +subroutine ext_pio_error_str( Code, ReturnString, Status) + use wrf_data_pio + use pio_routines + implicit none + include 'wrf_status_codes.h' + + integer , intent(in) ::Code + character *(*), intent(out) :: ReturnString + integer, intent(out) ::Status + + SELECT CASE (Code) + CASE (-100) + ReturnString= 'Allocation Error' + Status=WRF_NO_ERR + return + CASE (-101) + ReturnString= 'Deallocation Error' + Status=WRF_NO_ERR + return + CASE (-102) + ReturnString= 'Bad File Status' + Status=WRF_NO_ERR + return + CASE (-1004) + ReturnString= 'Variable on disk is not 3D' + Status=WRF_NO_ERR + return + CASE (-1005) + ReturnString= 'Metadata on disk is not 1D' + Status=WRF_NO_ERR + return + CASE (-1006) + ReturnString= 'Time dimension too small' + Status=WRF_NO_ERR + return + CASE DEFAULT + ReturnString= 'This error code is not supported or handled directly by WRF and NetCDF. & + & Might be an erroneous number, or specific to an i/o package other than NetCDF; you may need & + & to be calling a package-specific routine to return a message for this error code.' + Status=WRF_NO_ERR + END SELECT + + return +end subroutine ext_pio_error_str + + +subroutine ext_pio_end_independent_mode(DataHandle, Status) + use wrf_data_pio + use pio_routines + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + + DH => WrfDataHandles(DataHandle) + return +end subroutine ext_pio_end_independent_mode + +subroutine ext_pio_start_independent_mode(DataHandle, Status) + use wrf_data_pio + use pio_routines + include 'wrf_status_codes.h' + integer ,intent(in) :: DataHandle + integer ,intent(out) :: Status + type(wrf_data_handle) ,pointer :: DH + integer :: stat + + DH => WrfDataHandles(DataHandle) + return +end subroutine ext_pio_start_independent_mode + diff --git a/wrfv2_fire/external/io_pnetcdf/makefile b/wrfv2_fire/external/io_pnetcdf/Makefile similarity index 73% rename from wrfv2_fire/external/io_pnetcdf/makefile rename to wrfv2_fire/external/io_pnetcdf/Makefile index b29510bc..e8b019d3 100644 --- a/wrfv2_fire/external/io_pnetcdf/makefile +++ b/wrfv2_fire/external/io_pnetcdf/Makefile @@ -1,10 +1,16 @@ -#makefile to build a wrf_io with netCDF +#makefile to build a wrf_io with pnetCDF OBJSL = wrf_io.o field_routines.o module_wrfsi_static.o OBJS = $(OBJSL) -CODE = ext_pnc_get_dom_ti.code ext_pnc_get_var_td.code ext_pnc_get_var_ti.code ext_pnc_put_dom_ti.code ext_pnc_put_var_td.code ext_pnc_put_var_ti.code transpose.code -FFLAGS = $(FCFLAGS) -I$(NETCDFPATH)/include -I../ioapi_share -LIBS = -L$(NETCDFPATH)/lib -lnetcdf +CODE = ext_pnc_get_dom_ti.code \ + ext_pnc_get_var_td.code \ + ext_pnc_get_var_ti.code \ + ext_pnc_put_dom_ti.code \ + ext_pnc_put_var_td.code \ + ext_pnc_put_var_ti.code \ + transpose.code +FFLAGS = $(FCFLAGS) -I$(NETCDFPATH)/include -I../ioapi_share +LIBS = -L$(NETCDFPATH)/lib -lpnetcdf CPP1 = $(CPP) -P $(TRADFLAG) M4 = m4 -Uinclude -Uindex -Ulen AR = ar diff --git a/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 b/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 index 3d0debb0..175d6a04 100644 --- a/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 +++ b/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 @@ -1224,7 +1224,7 @@ SUBROUTINE ext_pnc_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHand character (7) :: Buffer integer :: VDimIDs(2) integer :: info, ierr ! added for Blue Gene (see NF_CREAT below) - character*128 :: idstr,ntasks_x_str,loccomm_str + character*1024 :: newFileName integer :: gridid integer local_communicator_x, ntasks_x @@ -1249,7 +1249,14 @@ SUBROUTINE ext_pnc_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHand CALL mpi_info_set(info,"romio_ds_write","disable", ierr) ; write(0,*)'mpi_info_set write returns ',ierr CALL mpi_info_set(info,"romio_ds_read","disable", ierr) ; write(0,*)'mpi_info_set read returns ',ierr # endif - stat = NFMPI_CREATE(Comm, FileName, IOR(NF_CLOBBER, NF_64BIT_OFFSET), info, DH%NCID) + + write(newFileName, fmt="(2a)") FileName, ".nc" + do i = 1, len_trim(newFileName) + if(newFileName(i:i) == '-') newFileName(i:i) = '_' + if(newFileName(i:i) == ':') newFileName(i:i) = '_' + enddo + stat = NFMPI_CREATE(Comm, newFileName, IOR(NF_CLOBBER, NF_64BIT_OFFSET), info, DH%NCID) +! stat = NFMPI_CREATE(Comm, newFileName, NF_64BIT_OFFSET, info, DH%NCID) call mpi_info_free( info, ierr) #else !!!!!!!!!!!!!!! diff --git a/wrfv2_fire/frame/Makefile b/wrfv2_fire/frame/Makefile index a4168fac..4eb0a7b8 100644 --- a/wrfv2_fire/frame/Makefile +++ b/wrfv2_fire/frame/Makefile @@ -32,7 +32,8 @@ MODULES = module_driver_constants.o \ module_io_quilt.o \ module_intermediate_nmm.o \ module_cpl.o \ - module_cpl_oasis3.o + module_cpl_oasis3.o \ + module_clear_halos.o ALOBJS =\ module_alloc_space_0.o \ module_alloc_space_1.o \ diff --git a/wrfv2_fire/frame/hires_timer.c b/wrfv2_fire/frame/hires_timer.c index 4bb8ec00..163f5e3b 100644 --- a/wrfv2_fire/frame/hires_timer.c +++ b/wrfv2_fire/frame/hires_timer.c @@ -76,13 +76,16 @@ void init_hires_timer() { void hires_timer(double *d) { + struct timeval tv; #if ( USE_HIRES == 1 ) struct timespec when; +#endif + if(!initialized) init_hires_timer(); +#if ( USE_HIRES == 1 ) if(!clock_gettime(CLOCK_REALTIME,&when)) { *d=(double)(when.tv_sec-start_ipart) + ( ((double)when.tv_nsec)/1e9 - start_fpart ); } else { /* clock_gettime failed */ #endif - struct timeval tv; if(!gettimeofday(&tv,NULL)) { *d=(double)(tv.tv_sec-start_ipart) + ( ((double)tv.tv_usec)/1e6 - start_fpart ); } else { diff --git a/wrfv2_fire/frame/md_calls.m4 b/wrfv2_fire/frame/md_calls.m4 index 84b6debb..307bb8bb 100644 --- a/wrfv2_fire/frame/md_calls.m4 +++ b/wrfv2_fire/frame/md_calls.m4 @@ -42,10 +42,10 @@ INTEGER , INTENT(OUT) :: Status INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package -LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers +LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for INTEGER :: locCount - -INTEGER io_form , Hndl +INTEGER :: io_form +INTEGER :: Hndl CALL wrf_debug( DEBUG_LVL, "module_io.F (md_calls.m4) : in wrf_$1_$2_$6_$3$4_$5 " ) @@ -56,7 +56,7 @@ ifelse($3,logical,`locCount = Count') Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -97,6 +97,19 @@ ifelse($3,real, ` CALL ext_pnc_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )' ) #endif +#ifdef PIO + CASE ( IO_PIO ) +ifelse($3,real, +`# if ( RWORDSIZE == DWORDSIZE ) + CALL ext_pio_$1_$2_$6_double$4_$5 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# else + CALL ext_pio_$1_$2_$6_real$4_$5 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) +# endif', +` CALL ext_pio_$1_$2_$6_$3$4_$5 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & + ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status )' ) +#endif #ifdef PHDF5 CASE ( IO_PHDF5 ) ifelse($3,real, @@ -229,7 +242,7 @@ ifelse($3,real, #endif CASE DEFAULT END SELECT - ELSE IF ( for_out .AND. use_output_servers() ) THEN + ELSE IF ( for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_$1_$2_$6_$3$4 ( Hndl, Element, ifelse($6,td,`DateStr,') ifelse($2,var,`Varname,') Data, & ifelse($4,char,,`locCount, ifelse($1,get,`Outcount,')') Status ) ELSE diff --git a/wrfv2_fire/frame/module_clear_halos.F b/wrfv2_fire/frame/module_clear_halos.F new file mode 100644 index 00000000..6adc9530 --- /dev/null +++ b/wrfv2_fire/frame/module_clear_halos.F @@ -0,0 +1,396 @@ +module module_clear_halos + implicit none +contains + ! -------------------------------------------------------------------- + subroutine clear_ij_full_domain(grid,how) + ! Convenience function - wrapper around clear_ij_halos. Clears + ! full domain with badval. See clear_ij_halos for details. + use module_domain, only: domain,get_ijk_from_grid,fieldlist + type(domain), intent(inout) :: grid + integer, intent(in) :: how + ! + call clear_ij_halos(grid,how,full_domain=.true.) + end subroutine clear_ij_full_domain + ! -------------------------------------------------------------------- + subroutine clear_ij_halos(grid,how,full_domain) + ! Clears halo regions OR full domain with badval. Select full + ! domain with full_domain=.true. Select badval type with "how" + ! parameter: + + ! how=1 -- badval=0 + ! how=2 -- badval=quiet NaN or -maxint + ! how=3 -- badval=signaling NaN or -maxint + + ! Fills outside domain with 0 UNLESS fill_domain=.true. If + ! fill_domain=true., entire array is filled with badval. + + use module_domain, only: domain,get_ijk_from_grid,fieldlist + use module_configure, only: PARAM_FIRST_SCALAR +#ifndef NO_IEEE_MODULE + use,intrinsic :: ieee_arithmetic +#endif + implicit none + + logical, intent(in), optional :: full_domain + integer, intent(in) :: how + type(domain), intent(inout) :: grid + + type( fieldlist ), pointer :: p + integer :: itrace, i,j, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + logical :: fulldom + real :: badR, badR_N,badR_NE,badR_NW,badR_S,badR_SW,badR_SE,badR_E,badR_W + double precision :: badD, badD_N,badD_NE,badD_NW,badD_S,badD_SW,badD_SE,badD_E,badD_W + integer :: badI, badI_N,badI_NE,badI_NW,badI_S,badI_SW,badI_SE,badI_E,badI_W + + select case(how) + case(0) + return + case(1) + call wrf_message('Fill I and J halos with 0.') + badR = 0 + badD = 0 + badI = 0 + case(2) + call wrf_message('Fill I and J halos with -maxint or quiet NaN.') +#ifndef NO_IEEE_MODULE + badR = ieee_value(badR,ieee_quiet_nan) + badD = ieee_value(badD,ieee_quiet_nan) + badI = -huge(badI) +#else + badR = -huge(badR) + badD = -huge(badD) + badI = -huge(badI) +#endif + case(3) + call wrf_message('Fill I and J halos with -maxint or signalling NaN.') +#ifndef NO_IEEE_MODULE + badR = ieee_value(badR,ieee_signaling_nan) + badD = ieee_value(badD,ieee_signaling_nan) + badI = -huge(badI) +#else + badR = -huge(badR) + badD = -huge(badD) + badI = -huge(badI) +#endif + case default + if(fulldom) then + call wrf_message('Invalid value for clear_ij_full_domain/clear_ij_halos "how" parameter. Will not clear domain.') + else + call wrf_message('Invalid value for clear_ij_halos "how" parameter. Will not clear halos.') + endif + return + end select + + fulldom=.false. + if(present(full_domain)) fulldom=full_domain + if(fulldom) then + call wrf_message('Filling entire memory area, not just halos.') + endif + + badR_N =badR ; badD_N =badD ; badI_N =badI + badR_NE=badR ; badD_NE=badD ; badI_NE=badI + badR_NW=badR ; badD_NW=badD ; badI_NW=badI + badR_S =badR ; badD_S =badD ; badI_S =badI + badR_SE=badR ; badD_SE=badD ; badI_SE=badI + badR_SW=badR ; badD_SW=badD ; badI_SW=badI + badR_E =badR ; badD_E =badD ; badI_E =badI + badR_W =badR ; badD_W =badD ; badI_W =badI + + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + + if(ips==ids) then + badR_S =0 ; badD_S =0 ; badI_S =0 + badR_SE=0 ; badD_SE=0 ; badI_SE=0 + badR_SW=0 ; badD_SW=0 ; badI_SW=0 + endif + if(ipe==ide) then + badR_N =0 ; badD_N =0 ; badI_N =0 + badR_NE=0 ; badD_NE=0 ; badI_NE=0 + badR_NW=0 ; badD_NW=0 ; badI_NW=0 + endif + if(jps==jds) then + badR_NW=0 ; badD_NW=0 ; badI_NW=0 + badR_SW=0 ; badD_SW=0 ; badI_SW=0 + badR_W =0 ; badD_W =0 ; badI_W =0 + endif + if(jpe==jde) then + badR_NE=0 ; badD_NE=0 ; badI_NE=0 + badR_SE=0 ; badD_SE=0 ; badI_SE=0 + badR_E =0 ; badD_E =0 ; badI_E =0 + endif + + if(.not.associated(grid%head_statevars)) then + call wrf_message('grid%head_statevars is not associated') + return + elseif(.not.associated(grid%head_statevars%next)) then + call wrf_message('grid%head_statevars%next is not associated') + return + endif + p => grid%head_statevars%next + DO WHILE ( ASSOCIATED( p ) ) + IF ( p%ProcOrient .NE. 'X' .AND. p%ProcOrient .NE. 'Y' ) THEN + IF ( p%Ndim .EQ. 2 ) THEN + IF ( p%MemoryOrder(1:1) .EQ. 'X' .AND. p%MemoryOrder(2:2) .EQ. 'Y' ) THEN + IF ( p%Type .EQ. 'r' ) THEN + IF ( SIZE(p%rfield_2d,1)*SIZE(p%rfield_2d,2) .GT. 1 ) THEN + if(fulldom) then + p%rfield_2d=badR + else + p%rfield_2d(ims:ips-1,jps:jpe) = badR_S + p%rfield_2d(ims:ips-1,jms:jps-1) = badR_SW + p%rfield_2d(ims:ips-1,jpe+1:jme) = badR_SE + p%rfield_2d(ipe+1:ime,jps:jpe) = badR_N + p%rfield_2d(ipe+1:ime,jms:jps-1) = badR_NW + p%rfield_2d(ipe+1:ime,jpe+1:jme) = badR_NE + p%rfield_2d(ips:ipe,jms:jps-1) = badR_W + p%rfield_2d(ips:ipe,jpe+1:jme) = badR_E + endif + ENDIF + ELSE IF ( p%Type .EQ. 'd' ) THEN + IF ( SIZE(p%dfield_2d,1)*SIZE(p%dfield_2d,2) .GT. 1 ) THEN + if(fulldom) then + p%dfield_2d=badD + else + p%dfield_2d(ims:ips-1,jps:jpe) = badD_S + p%dfield_2d(ims:ips-1,jms:jps-1) = badD_SW + p%dfield_2d(ims:ips-1,jpe+1:jme) = badD_SE + p%dfield_2d(ipe+1:ime,jps:jpe) = badD_N + p%dfield_2d(ipe+1:ime,jms:jps-1) = badD_NW + p%dfield_2d(ipe+1:ime,jpe+1:jme) = badD_NE + p%dfield_2d(ips:ipe,jms:jps-1) = badD_W + p%dfield_2d(ips:ipe,jpe+1:jme) = badD_E + endif + ENDIF + ELSE IF ( p%Type .EQ. 'i' ) THEN + IF ( SIZE(p%ifield_2d,1)*SIZE(p%ifield_2d,2) .GT. 1 ) THEN + if(fulldom) then + p%ifield_2d=badI + else + p%ifield_2d(ims:ips-1,jps:jpe) = badI_S + p%ifield_2d(ims:ips-1,jms:jps-1) = badI_SW + p%ifield_2d(ims:ips-1,jpe+1:jme) = badI_SE + p%ifield_2d(ipe+1:ime,jps:jpe) = badI_N + p%ifield_2d(ipe+1:ime,jms:jps-1) = badI_NW + p%ifield_2d(ipe+1:ime,jpe+1:jme) = badI_NE + p%ifield_2d(ips:ipe,jms:jps-1) = badI_W + p%ifield_2d(ips:ipe,jpe+1:jme) = badI_E + endif + ENDIF + ENDIF + ENDIF + ELSE IF ( p%Ndim .EQ. 3 ) THEN + IF ( p%MemoryOrder(1:1) .EQ. 'X' .AND. p%MemoryOrder(3:3) .EQ. 'Y' ) THEN + IF ( p%Type .EQ. 'r' ) THEN + IF ( SIZE(p%rfield_3d,1)*SIZE(p%rfield_3d,3) .GT. 1 ) THEN + if(fulldom) then + p%rfield_3d=badR + else + p%rfield_3d(ims:ips-1,:,jps:jpe) = badR_S + p%rfield_3d(ims:ips-1,:,jms:jps-1) = badR_SW + p%rfield_3d(ims:ips-1,:,jpe+1:jme) = badR_SE + p%rfield_3d(ipe+1:ime,:,jps:jpe) = badR_N + p%rfield_3d(ipe+1:ime,:,jms:jps-1) = badR_NW + p%rfield_3d(ipe+1:ime,:,jpe+1:jme) = badR_NE + p%rfield_3d(ips:ipe,:,jms:jps-1) = badR_W + p%rfield_3d(ips:ipe,:,jpe+1:jme) = badR_E + endif + ENDIF + ELSE IF ( p%Type .EQ. 'd' ) THEN + IF ( SIZE(p%dfield_3d,1)*SIZE(p%dfield_3d,3) .GT. 1 ) THEN + if(fulldom) then + p%dfield_3d=badD + else + p%dfield_3d(ims:ips-1,:,jps:jpe) = badD_S + p%dfield_3d(ims:ips-1,:,jms:jps-1) = badD_SW + p%dfield_3d(ims:ips-1,:,jpe+1:jme) = badD_SE + p%dfield_3d(ipe+1:ime,:,jps:jpe) = badD_N + p%dfield_3d(ipe+1:ime,:,jms:jps-1) = badD_NW + p%dfield_3d(ipe+1:ime,:,jpe+1:jme) = badD_NE + p%dfield_3d(ips:ipe,:,jms:jps-1) = badD_W + p%dfield_3d(ips:ipe,:,jpe+1:jme) = badD_E + endif + ENDIF + ELSE IF ( p%Type .EQ. 'i' ) THEN + IF ( SIZE(p%ifield_3d,1)*SIZE(p%ifield_3d,3) .GT. 1 ) THEN + if(fulldom) then + p%ifield_3d=badI + else + p%ifield_3d(ims:ips-1,:,jps:jpe) = badI_S + p%ifield_3d(ims:ips-1,:,jms:jps-1) = badI_SW + p%ifield_3d(ims:ips-1,:,jpe+1:jme) = badI_SE + p%ifield_3d(ipe+1:ime,:,jps:jpe) = badI_N + p%ifield_3d(ipe+1:ime,:,jms:jps-1) = badI_NW + p%ifield_3d(ipe+1:ime,:,jpe+1:jme) = badI_NE + p%ifield_3d(ips:ipe,:,jms:jps-1) = badI_W + p%ifield_3d(ips:ipe,:,jpe+1:jme) = badI_E + endif + ENDIF + ENDIF + ELSE IF ( p%MemoryOrder(1:2) .EQ. 'XY' ) THEN + IF ( p%Type .EQ. 'r' ) THEN + IF ( SIZE(p%rfield_3d,1)*SIZE(p%rfield_3d,2) .GT. 1 ) THEN + if(fulldom) then + p%rfield_3d=badR + else + p%rfield_3d(ims:ips-1,jps:jpe,:) = badR_S + p%rfield_3d(ims:ips-1,jms:jps-1,:) = badR_SW + p%rfield_3d(ims:ips-1,jpe+1:jme,:) = badR_SE + p%rfield_3d(ipe+1:ime,jps:jpe,:) = badR_N + p%rfield_3d(ipe+1:ime,jms:jps-1,:) = badR_NW + p%rfield_3d(ipe+1:ime,jpe+1:jme,:) = badR_NE + p%rfield_3d(ips:ipe,jms:jps-1,:) = badR_W + p%rfield_3d(ips:ipe,jpe+1:jme,:) = badR_E + endif + ENDIF + ELSE IF ( p%Type .EQ. 'd' ) THEN + IF ( SIZE(p%dfield_3d,1)*SIZE(p%dfield_3d,2) .GT. 1 ) THEN + if(fulldom) then + p%dfield_3d=badD + else + p%dfield_3d(ims:ips-1,jps:jpe,:) = badD_S + p%dfield_3d(ims:ips-1,jms:jps-1,:) = badD_SW + p%dfield_3d(ims:ips-1,jpe+1:jme,:) = badD_SE + p%dfield_3d(ipe+1:ime,jps:jpe,:) = badD_N + p%dfield_3d(ipe+1:ime,jms:jps-1,:) = badD_NW + p%dfield_3d(ipe+1:ime,jpe+1:jme,:) = badD_NE + p%dfield_3d(ips:ipe,jms:jps-1,:) = badD_W + p%dfield_3d(ips:ipe,jpe+1:jme,:) = badD_E + endif + ENDIF + ELSE IF ( p%Type .EQ. 'i' ) THEN + IF ( SIZE(p%ifield_3d,1)*SIZE(p%ifield_3d,2) .GT. 1 ) THEN + if(fulldom) then + p%ifield_3d=badI + else + p%ifield_3d(ims:ips-1,jps:jpe,:) = badI_S + p%ifield_3d(ims:ips-1,jms:jps-1,:) = badI_SW + p%ifield_3d(ims:ips-1,jpe+1:jme,:) = badI_SE + p%ifield_3d(ipe+1:ime,jps:jpe,:) = badI_N + p%ifield_3d(ipe+1:ime,jms:jps-1,:) = badI_NW + p%ifield_3d(ipe+1:ime,jpe+1:jme,:) = badI_NE + p%ifield_3d(ips:ipe,jms:jps-1,:) = badI_W + p%ifield_3d(ips:ipe,jpe+1:jme,:) = badI_E + endif + ENDIF + ENDIF + ENDIF + ELSE IF ( p%Ndim .EQ. 4 ) THEN + IF ( p%MemoryOrder(1:1) .EQ. 'X' .AND. p%MemoryOrder(3:3) .EQ. 'Y' ) THEN + IF ( p%Type .EQ. 'r' ) THEN + IF ( SIZE(p%rfield_4d,1)*SIZE(p%rfield_4d,3) .GT. 1 ) THEN + DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id) + if(fulldom) then + p%rfield_4d(:,:,:,itrace)=badR + else + p%rfield_4d(ims:ips-1,:,jps:jpe,itrace) = badR_S + p%rfield_4d(ims:ips-1,:,jms:jps-1,itrace) = badR_SW + p%rfield_4d(ims:ips-1,:,jpe+1:jme,itrace) = badR_SE + p%rfield_4d(ipe+1:ime,:,jps:jpe,itrace) = badR_N + p%rfield_4d(ipe+1:ime,:,jms:jps-1,itrace) = badR_NW + p%rfield_4d(ipe+1:ime,:,jpe+1:jme,itrace) = badR_NE + p%rfield_4d(ips:ipe,:,jms:jps-1,itrace) = badR_W + p%rfield_4d(ips:ipe,:,jpe+1:jme,itrace) = badR_E + endif + ENDDO + ENDIF + ELSE IF ( p%Type .EQ. 'd' ) THEN + IF ( SIZE(p%dfield_4d,1)*SIZE(p%dfield_4d,3) .GT. 1 ) THEN + DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id) + if(fulldom) then + p%dfield_4d(:,:,:,itrace)=badD + else + p%dfield_4d(ims:ips-1,:,jps:jpe,itrace) = badD_S + p%dfield_4d(ims:ips-1,:,jms:jps-1,itrace) = badD_SW + p%dfield_4d(ims:ips-1,:,jpe+1:jme,itrace) = badD_SE + p%dfield_4d(ipe+1:ime,:,jps:jpe,itrace) = badD_N + p%dfield_4d(ipe+1:ime,:,jms:jps-1,itrace) = badD_NW + p%dfield_4d(ipe+1:ime,:,jpe+1:jme,itrace) = badD_NE + p%dfield_4d(ips:ipe,:,jms:jps-1,itrace) = badD_W + p%dfield_4d(ips:ipe,:,jpe+1:jme,itrace) = badD_E + endif + ENDDO + ENDIF + ELSE IF ( p%Type .EQ. 'i' ) THEN + IF ( SIZE(p%ifield_4d,1)*SIZE(p%ifield_4d,3) .GT. 1 ) THEN + DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id) + if(fulldom) then + p%ifield_4d(:,:,:,itrace)=badI + else + p%ifield_4d(ims:ips-1,:,jps:jpe,itrace) = badI_S + p%ifield_4d(ims:ips-1,:,jms:jps-1,itrace) = badI_SW + p%ifield_4d(ims:ips-1,:,jpe+1:jme,itrace) = badI_SE + p%ifield_4d(ipe+1:ime,:,jps:jpe,itrace) = badI_N + p%ifield_4d(ipe+1:ime,:,jms:jps-1,itrace) = badI_NW + p%ifield_4d(ipe+1:ime,:,jpe+1:jme,itrace) = badI_NE + p%ifield_4d(ips:ipe,:,jms:jps-1,itrace) = badI_W + p%ifield_4d(ips:ipe,:,jpe+1:jme,itrace) = badI_E + endif + ENDDO + ENDIF + ENDIF + ELSE IF ( p%MemoryOrder(1:2) .EQ. 'XY' ) THEN + IF ( p%Type .EQ. 'r' ) THEN + IF ( SIZE(p%rfield_4d,1)*SIZE(p%rfield_4d,2) .GT. 1 ) THEN + DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id) + if(fulldom) then + p%rfield_4d(:,:,:,itrace)=badR + else + p%rfield_4d(ims:ips-1,jps:jpe,:,itrace) = badR_S + p%rfield_4d(ims:ips-1,jms:jps-1,:,itrace) = badR_SW + p%rfield_4d(ims:ips-1,jpe+1:jme,:,itrace) = badR_SE + p%rfield_4d(ipe+1:ime,jps:jpe,:,itrace) = badR_N + p%rfield_4d(ipe+1:ime,jms:jps-1,:,itrace) = badR_NW + p%rfield_4d(ipe+1:ime,jpe+1:jme,:,itrace) = badR_NE + p%rfield_4d(ips:ipe,jms:jps-1,:,itrace) = badR_W + p%rfield_4d(ips:ipe,jpe+1:jme,:,itrace) = badR_E + endif + ENDDO + ENDIF + ELSE IF ( p%Type .EQ. 'd' ) THEN + IF ( SIZE(p%dfield_4d,1)*SIZE(p%dfield_4d,2) .GT. 1 ) THEN + DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id) + if(fulldom) then + p%dfield_4d(:,:,:,itrace)=badD + else + p%dfield_4d(ims:ips-1,jps:jpe,:,itrace) = badD_S + p%dfield_4d(ims:ips-1,jms:jps-1,:,itrace) = badD_SW + p%dfield_4d(ims:ips-1,jpe+1:jme,:,itrace) = badD_SE + p%dfield_4d(ipe+1:ime,jps:jpe,:,itrace) = badD_N + p%dfield_4d(ipe+1:ime,jms:jps-1,:,itrace) = badD_NW + p%dfield_4d(ipe+1:ime,jpe+1:jme,:,itrace) = badD_NE + p%dfield_4d(ips:ipe,jms:jps-1,:,itrace) = badD_W + p%dfield_4d(ips:ipe,jpe+1:jme,:,itrace) = badD_E + endif + ENDDO + ENDIF + ELSE IF ( p%Type .EQ. 'i' ) THEN + IF ( SIZE(p%ifield_4d,1)*SIZE(p%ifield_4d,2) .GT. 1 ) THEN + DO itrace = PARAM_FIRST_SCALAR , p%num_table(grid%id) + if(fulldom) then + p%ifield_4d(:,:,:,itrace)=badI + else + p%ifield_4d(ims:ips-1,jps:jpe,:,itrace) = badI_S + p%ifield_4d(ims:ips-1,jms:jps-1,:,itrace) = badI_SW + p%ifield_4d(ims:ips-1,jpe+1:jme,:,itrace) = badI_SE + p%ifield_4d(ipe+1:ime,jps:jpe,:,itrace) = badI_N + p%ifield_4d(ipe+1:ime,jms:jps-1,:,itrace) = badI_NW + p%ifield_4d(ipe+1:ime,jpe+1:jme,:,itrace) = badI_NE + p%ifield_4d(ips:ipe,jms:jps-1,:,itrace) = badI_W + p%ifield_4d(ips:ipe,jpe+1:jme,:,itrace) = badI_E + endif + ENDDO + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + p => p%next + ENDDO + end subroutine clear_ij_halos +end module module_clear_halos diff --git a/wrfv2_fire/frame/module_driver_constants.F b/wrfv2_fire/frame/module_driver_constants.F index 7a117e37..19653987 100644 --- a/wrfv2_fire/frame/module_driver_constants.F +++ b/wrfv2_fire/frame/module_driver_constants.F @@ -46,8 +46,13 @@ MODULE module_driver_constants INTEGER , PARAMETER :: max_moves = 50 ! The maximum number of eta levels + !DJW 140701 Increased from 501 to 1001 since I can imagine using more than + !501 total vertical levels across multiple nested domains. Now that the + !code is modified to allow specification of all domains eta_levels using a + !array of length max_eta, this will need to be larger. I'll also add a check + !in module_initialize_real to ensure we don't exceed this value. - INTEGER , PARAMETER :: max_eta = 501 + INTEGER , PARAMETER :: max_eta = 1001 ! The maximum number of ocean levels in the 3d U Miami ocean. @@ -63,7 +68,7 @@ MODULE module_driver_constants ! The maximum number of outer iterations (for DA minimisation) - INTEGER , PARAMETER :: max_outer_iterations = 10 + INTEGER , PARAMETER :: max_outer_iterations = 100 ! The maximum number of instruments (for radiance DA) diff --git a/wrfv2_fire/frame/module_io.F b/wrfv2_fire/frame/module_io.F index edc6e489..3c740740 100644 --- a/wrfv2_fire/frame/module_io.F +++ b/wrfv2_fire/frame/module_io.F @@ -30,7 +30,8 @@ MODULE module_io LOGICAL :: is_inited = .FALSE. INTEGER, PARAMETER, PRIVATE :: MAX_WRF_IO_HANDLE = 1000 - INTEGER :: wrf_io_handles(MAX_WRF_IO_HANDLE), how_opened(MAX_WRF_IO_HANDLE) + INTEGER :: wrf_io_handles(MAX_WRF_IO_HANDLE) + INTEGER :: how_opened(MAX_WRF_IO_HANDLE) LOGICAL :: for_output(MAX_WRF_IO_HANDLE), first_operation(MAX_WRF_IO_HANDLE) INTEGER :: filtno = 0 LOGICAL, PRIVATE :: bdy_dist_flag = .TRUE. ! false is old style undecomposed boundary data structs, @@ -82,7 +83,7 @@ SUBROUTINE wrf_ioinit( Status ) INTEGER, INTENT(INOUT) :: Status !Local CHARACTER(len=80) :: SysDepInfo - INTEGER :: ierr(10), minerr, maxerr + INTEGER :: ierr(100), minerr, maxerr ! Status = 0 ierr = 0 @@ -91,38 +92,41 @@ SUBROUTINE wrf_ioinit( Status ) CALL init_io_handles ! defined below #ifdef NETCDF if ( model_config_rec%use_netcdf_classic ) SysDepInfo="use_netcdf_classic" - CALL ext_ncd_ioinit( SysDepInfo, ierr(1) ) + CALL ext_ncd_ioinit ( SysDepInfo, ierr( 1) ) SysDepInfo = " " #endif #ifdef INTIO - CALL ext_int_ioinit( SysDepInfo, ierr(2) ) + CALL ext_int_ioinit ( SysDepInfo, ierr( 2) ) #endif #ifdef PHDF5 - CALL ext_phdf5_ioinit( SysDepInfo, ierr(3) ) -#endif -#ifdef PNETCDF - CALL ext_pnc_ioinit( SysDepInfo, ierr(3) ) + CALL ext_phdf5_ioinit( SysDepInfo, ierr( 3) ) #endif #ifdef MCELIO - CALL ext_mcel_ioinit( SysDepInfo, ierr(4) ) + CALL ext_mcel_ioinit ( SysDepInfo, ierr( 4) ) #endif #ifdef XXX - CALL ext_xxx_ioinit( SysDepInfo, ierr(5) ) + CALL ext_xxx_ioinit ( SysDepInfo, ierr( 5) ) #endif #ifdef YYY - CALL ext_yyy_ioinit( SysDepInfo, ierr(6) ) + CALL ext_yyy_ioinit ( SysDepInfo, ierr( 6) ) #endif #ifdef ZZZ - CALL ext_zzz_ioinit( SysDepInfo, ierr(7) ) + CALL ext_zzz_ioinit ( SysDepInfo, ierr( 7) ) #endif #ifdef ESMFIO - CALL ext_esmf_ioinit( SysDepInfo, ierr(8) ) + CALL ext_esmf_ioinit ( SysDepInfo, ierr( 8) ) #endif #ifdef GRIB1 - CALL ext_gr1_ioinit( SysDepInfo, ierr(9) ) + CALL ext_gr1_ioinit ( SysDepInfo, ierr( 9) ) #endif #ifdef GRIB2 - CALL ext_gr2_ioinit( SysDepInfo, ierr(10) ) + CALL ext_gr2_ioinit ( SysDepInfo, ierr(10) ) +#endif +#ifdef PNETCDF + CALL ext_pnc_ioinit ( SysDepInfo, ierr(11) ) +#endif +#ifdef PIO + CALL ext_pio_ioinit ( SysDepInfo, ierr(12) ) #endif minerr = MINVAL(ierr) maxerr = MAXVAL(ierr) @@ -147,43 +151,46 @@ SUBROUTINE wrf_ioexit( Status ) INTEGER, INTENT(INOUT) :: Status !Local LOGICAL, EXTERNAL :: use_output_servers - INTEGER :: ierr(11), minerr, maxerr + INTEGER :: ierr(100), minerr, maxerr ! Status = 0 ierr = 0 CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioexit' ) #ifdef NETCDF - CALL ext_ncd_ioexit( ierr(1) ) + CALL ext_ncd_ioexit ( ierr( 1) ) #endif #ifdef INTIO - CALL ext_int_ioexit( ierr(2) ) + CALL ext_int_ioexit ( ierr( 2) ) #endif #ifdef PHDF5 - CALL ext_phdf5_ioexit(ierr(3) ) -#endif -#ifdef PNETCDF - CALL ext_pnc_ioexit(ierr(3) ) + CALL ext_phdf5_ioexit( ierr( 3) ) #endif #ifdef MCELIO - CALL ext_mcel_ioexit( ierr(4) ) + CALL ext_mcel_ioexit ( ierr( 4) ) #endif #ifdef XXX - CALL ext_xxx_ioexit( ierr(5) ) + CALL ext_xxx_ioexit ( ierr( 5) ) #endif #ifdef YYY - CALL ext_yyy_ioexit( ierr(6) ) + CALL ext_yyy_ioexit ( ierr( 6) ) #endif #ifdef ZZZ - CALL ext_zzz_ioexit( ierr(7) ) + CALL ext_zzz_ioexit ( ierr( 7) ) #endif #ifdef ESMFIO - CALL ext_esmf_ioexit( ierr(8) ) + CALL ext_esmf_ioexit ( ierr( 8) ) #endif #ifdef GRIB1 - CALL ext_gr1_ioexit( ierr(9) ) + CALL ext_gr1_ioexit ( ierr( 9) ) #endif #ifdef GRIB2 - CALL ext_gr2_ioexit( ierr(10) ) + CALL ext_gr2_ioexit ( ierr(10) ) +#endif +#ifdef PNETCDF + CALL ext_pnc_ioexit ( ierr(11) ) +#endif +#ifdef PIO + CALL ext_pio_ioexit ( ierr(12) ) #endif IF ( use_output_servers() ) CALL wrf_quilt_ioexit( ierr(11) ) @@ -200,7 +207,7 @@ END SUBROUTINE wrf_ioexit !--- open_for_write_begin -SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, & +SUBROUTINE wrf_open_for_write_begin( FileName , grid, SysDepInfo, & DataHandle , Status ) ! !
@@ -209,13 +216,14 @@ SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInf
 !
! USE module_state_description + USE module_domain #ifdef DM_PARALLEL USE module_dm, ONLY : ntasks_x, mytask_x, local_communicator_x #endif IMPLICIT NONE #include "wrf_io_flags.h" CHARACTER*(*) :: FileName - INTEGER , INTENT(IN) :: Comm_compute , Comm_io + type(domain) :: grid CHARACTER*(*), INTENT(INOUT):: SysDepInfo INTEGER , INTENT(OUT) :: DataHandle INTEGER , INTENT(OUT) :: Status @@ -224,16 +232,21 @@ SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInf INTEGER :: io_form INTEGER :: Hndl INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files + LOGICAL, EXTERNAL :: use_output_servers_for CHARACTER*128 :: LocFilename ! for appending the process ID if necessary INTEGER :: myproc CHARACTER*128 :: mess CHARACTER*1028 :: tstr, t1 - INTEGER i,j + INTEGER :: i,j + INTEGER :: Comm_compute , Comm_io LOGICAL ncd_nofill WRITE(mess,*) 'module_io.F: in wrf_open_for_write_begin, FileName = ',TRIM(FileName) - CALL wrf_debug( DEBUG_LVL, mess ) + CALL wrf_debug( 100, mess ) + + Comm_compute = grid%communicator + Comm_io = grid%iocommunicator CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet ) @@ -243,7 +256,7 @@ SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInf Status = 0 Hndl = -1 - IF ( multi_files( io_form ) .OR. .NOT. use_output_servers() ) THEN + IF ( .not. use_output_servers_for(io_form) ) THEN SELECT CASE ( use_package(io_form) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -274,7 +287,8 @@ SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInf #endif #ifdef PNETCDF CASE (IO_PNETCDF ) - WRITE(tstr,"(A,',NTASKS_X=',i10,',MYTASK_X=',i10,',LOCAL_COMMUNICATOR_X=',i10)") TRIM(SysDepInfo),ntasks_x,mytask_x,local_communicator_x + WRITE(tstr,"(A,',NTASKS_X=',i10,',MYTASK_X=',i10,',LOCAL_COMMUNICATOR_X=',i10)") & + TRIM(SysDepInfo),ntasks_x,mytask_x,local_communicator_x j=1 t1 = " " DO i=1,len(TRIM(tstr)) @@ -287,6 +301,21 @@ SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInf CALL ext_pnc_open_for_write_begin( FileName, Comm_compute, Comm_io, tstr, & Hndl, Status) #endif +#ifdef PIO + CASE ( IO_PIO ) + WRITE(tstr,"(A,',NTASKS_X=',i10,',MYTASK_X=',i10,',LOCAL_COMMUNICATOR_X=',i10)") & + TRIM(SysDepInfo),ntasks_x,mytask_x,local_communicator_x + j=1 + t1 = " " + DO i=1,len(TRIM(tstr)) + IF ( tstr(i:i) .NE. ' ' ) THEN + t1(j:j) = tstr(i:i) + j = j + 1 + ENDIF + ENDDO + tstr = t1 + CALL ext_pio_open_for_write_begin( FileName, grid, tstr, Hndl, Status) +#endif #ifdef XXX CASE ( IO_XXX ) CALL ext_xxx_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & @@ -387,7 +416,7 @@ SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInf Status = WRF_FILE_NOT_OPENED ENDIF END SELECT - ELSE IF ( use_output_servers() ) THEN + ELSE ! use_output_servers_for(io_form) IF ( io_form .GT. 0 ) THEN IF ( ncd_nofill ) THEN CALL wrf_quilt_open_for_write_begin ( FileName , Comm_compute, Comm_io, TRIM(SysDepInfo) // ",NOFILL=.TRUE.", & @@ -397,8 +426,6 @@ SUBROUTINE wrf_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInf Hndl , io_form, Status ) ENDIF ENDIF - ELSE - Status = 0 ENDIF CALL add_new_handle( Hndl, io_form, .TRUE., DataHandle ) END SUBROUTINE wrf_open_for_write_begin @@ -423,7 +450,7 @@ SUBROUTINE wrf_open_for_write_commit( DataHandle , Status ) INTEGER :: Hndl LOGICAL :: for_out INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for #include "wrf_io_flags.h" CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_write_commit' ) @@ -432,7 +459,7 @@ SUBROUTINE wrf_open_for_write_commit( DataHandle , Status ) CALL get_handle ( Hndl, io_form , for_out, DataHandle ) CALL set_first_operation( DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package(io_form) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -460,6 +487,10 @@ SUBROUTINE wrf_open_for_write_commit( DataHandle , Status ) CASE ( IO_PNETCDF ) CALL ext_pnc_open_for_write_commit ( Hndl , Status ) #endif +#ifdef PIO + CASE ( IO_PIO ) + CALL ext_pio_open_for_write_commit ( Hndl , Status ) +#endif #ifdef XXX CASE ( IO_XXX ) CALL ext_xxx_open_for_write_commit ( Hndl , Status ) @@ -496,7 +527,7 @@ SUBROUTINE wrf_open_for_write_commit( DataHandle , Status ) CASE DEFAULT Status = 0 END SELECT - ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_open_for_write_commit ( Hndl , Status ) ELSE Status = 0 @@ -509,7 +540,7 @@ END SUBROUTINE wrf_open_for_write_commit !--- open_for_read_begin -SUBROUTINE wrf_open_for_read_begin( FileName , Comm_compute, Comm_io, SysDepInfo, & +SUBROUTINE wrf_open_for_read_begin( FileName , grid, SysDepInfo, & DataHandle , Status ) ! !
@@ -518,10 +549,11 @@ SUBROUTINE wrf_open_for_read_begin( FileName , Comm_compute, Comm_io, SysDepInfo
 !
! USE module_state_description + USE module_domain IMPLICIT NONE #include "wrf_io_flags.h" CHARACTER*(*) :: FileName - INTEGER , INTENT(IN) :: Comm_compute , Comm_io + TYPE (domain) :: grid CHARACTER*(*) :: SysDepInfo INTEGER , INTENT(OUT) :: DataHandle INTEGER , INTENT(OUT) :: Status @@ -531,15 +563,19 @@ SUBROUTINE wrf_open_for_read_begin( FileName , Comm_compute, Comm_io, SysDepInfo INTEGER :: Hndl LOGICAL :: also_for_out INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for CHARACTER*128 :: LocFilename ! for appending the process ID if necessary INTEGER myproc CHARACTER*128 :: mess, fhand CHARACTER*1028 :: tstr + INTEGER :: Comm_compute , Comm_io CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read_begin' ) + Comm_compute = grid%communicator + Comm_io = grid%iocommunicator + CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet ) io_form = io_form_for_dataset( DataSet ) @@ -547,7 +583,7 @@ SUBROUTINE wrf_open_for_read_begin( FileName , Comm_compute, Comm_io, SysDepInfo Status = 0 Hndl = -1 also_for_out = .FALSE. -! IF ( .NOT. use_output_servers() ) THEN +! IF ( .NOT. use_output_servers_for(io_form) ) THEN SELECT CASE ( use_package(io_form) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -571,6 +607,11 @@ SUBROUTINE wrf_open_for_read_begin( FileName , Comm_compute, Comm_io, SysDepInfo CALL ext_pnc_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & Hndl , Status ) #endif +#ifdef PIO + CASE ( IO_PIO ) + CALL ext_pio_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & + Hndl , Status ) +#endif #ifdef XXX CASE ( IO_XXX ) CALL ext_xxx_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & @@ -676,7 +717,7 @@ SUBROUTINE wrf_open_for_read_commit( DataHandle , Status ) INTEGER :: Hndl LOGICAL :: for_out INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for #include "wrf_io_flags.h" CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read_commit' ) @@ -685,7 +726,7 @@ SUBROUTINE wrf_open_for_read_commit( DataHandle , Status ) CALL get_handle ( Hndl, io_form , for_out, DataHandle ) CALL set_first_operation( DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package(io_form) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -709,6 +750,10 @@ SUBROUTINE wrf_open_for_read_commit( DataHandle , Status ) CASE ( IO_PNETCDF ) CALL ext_pnc_open_for_read_commit ( Hndl , Status ) #endif +#ifdef PIO + CASE ( IO_PIO ) + CALL ext_pio_open_for_read_commit ( Hndl , Status ) +#endif #ifdef XXX CASE ( IO_XXX ) CALL ext_xxx_open_for_read_commit ( Hndl , Status ) @@ -746,7 +791,7 @@ END SUBROUTINE wrf_open_for_read_commit !--- open_for_read -SUBROUTINE wrf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & +SUBROUTINE wrf_open_for_read ( FileName , grid, SysDepInfo, & DataHandle , Status ) ! !
@@ -754,9 +799,10 @@ SUBROUTINE wrf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 !
! USE module_state_description + USE module_domain IMPLICIT NONE CHARACTER*(*) :: FileName - INTEGER , INTENT(IN) :: Comm_compute , Comm_io + TYPE (domain) :: grid CHARACTER*(*) :: SysDepInfo INTEGER , INTENT(OUT) :: DataHandle INTEGER , INTENT(OUT) :: Status @@ -765,10 +811,14 @@ SUBROUTINE wrf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & INTEGER :: io_form, myproc INTEGER :: Hndl INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for + INTEGER :: Comm_compute, Comm_io CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read' ) + Comm_compute = grid%communicator + Comm_io = grid%iocommunicator + CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet ) io_form = io_form_for_dataset( DataSet ) @@ -799,6 +849,10 @@ SUBROUTINE wrf_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & CALL ext_pnc_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & Hndl , Status ) #endif +#ifdef PIO + CASE ( IO_PIO ) + CALL ext_pio_open_for_read ( FileName , grid, SysDepInfo, Hndl , Status ) +#endif #ifdef PHDF5 CASE ( IO_PHDF5 ) CALL ext_phdf5_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & @@ -908,18 +962,19 @@ SUBROUTINE wrf_inquire_opened ( DataHandle, FileName , FileStatus, Status ) INTEGER , INTENT(OUT) :: Status LOGICAL :: for_out INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for #include "wrf_io_flags.h" #include "wrf_status_codes.h" - INTEGER io_form , Hndl + INTEGER io_form + INTEGER :: Hndl CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_inquire_opened' ) Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package(io_form) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -935,6 +990,10 @@ SUBROUTINE wrf_inquire_opened ( DataHandle, FileName , FileStatus, Status ) CASE ( IO_PNETCDF ) CALL ext_pnc_inquire_opened ( Hndl, FileName , FileStatus, Status ) #endif +#ifdef PIO + CASE ( IO_PIO ) + CALL ext_pio_inquire_opened ( Hndl, FileName , FileStatus, Status ) +#endif #ifdef XXX CASE ( IO_XXX ) CALL ext_xxx_inquire_opened ( Hndl, FileName , FileStatus, Status ) @@ -971,7 +1030,7 @@ SUBROUTINE wrf_inquire_opened ( DataHandle, FileName , FileStatus, Status ) FileStatus = WRF_FILE_NOT_OPENED Status = 0 END SELECT - ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_inquire_opened ( Hndl, FileName , FileStatus, Status ) ENDIF ELSE @@ -998,18 +1057,20 @@ SUBROUTINE wrf_inquire_filename ( DataHandle, FileName , FileStatus, Status ) INTEGER , INTENT(OUT) :: Status #include "wrf_status_codes.h" INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for LOGICAL :: for_out - INTEGER io_form , Hndl + INTEGER :: io_form INTEGER :: str_length , str_count + INTEGER :: Hndl - CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_inquire_filename' ) + CALL wrf_debug( 300, 'module_io.F: in wrf_inquire_filename' ) Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) + IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1029,6 +1090,10 @@ SUBROUTINE wrf_inquire_filename ( DataHandle, FileName , FileStatus, Status ) CASE ( IO_PNETCDF ) CALL ext_pnc_inquire_filename ( Hndl, FileName , FileStatus, Status ) #endif +#ifdef PIO + CASE ( IO_PIO ) + CALL ext_pio_inquire_filename ( Hndl, FileName , FileStatus, Status ) +#endif #ifdef XXX CASE ( IO_XXX ) CALL ext_xxx_inquire_filename ( Hndl, FileName , FileStatus, Status ) @@ -1064,7 +1129,7 @@ SUBROUTINE wrf_inquire_filename ( DataHandle, FileName , FileStatus, Status ) CASE DEFAULT Status = 0 END SELECT - ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_inquire_filename ( Hndl, FileName , FileStatus, Status ) ENDIF ELSE @@ -1088,17 +1153,18 @@ SUBROUTINE wrf_iosync ( DataHandle, Status ) INTEGER , INTENT(OUT) :: Status #include "wrf_status_codes.h" INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for LOGICAL :: for_out - INTEGER io_form , Hndl + INTEGER :: io_form + INTEGER :: Hndl CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_iosync' ) Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package(io_form) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1136,7 +1202,7 @@ SUBROUTINE wrf_iosync ( DataHandle, Status ) CASE DEFAULT Status = 0 END SELECT - ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_iosync( Hndl, Status ) ELSE Status = 0 @@ -1161,9 +1227,10 @@ SUBROUTINE wrf_ioclose ( DataHandle, Status ) INTEGER , INTENT(OUT) :: Status #include "wrf_status_codes.h" INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers - INTEGER io_form , Hndl + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for + INTEGER :: io_form LOGICAL :: for_out + INTEGER :: Hndl CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioclose' ) @@ -1171,7 +1238,7 @@ SUBROUTINE wrf_ioclose ( DataHandle, Status ) CALL get_handle ( Hndl, io_form , for_out, DataHandle ) CALL free_handle( DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package(io_form) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1186,6 +1253,10 @@ SUBROUTINE wrf_ioclose ( DataHandle, Status ) CASE ( IO_PNETCDF ) CALL ext_pnc_ioclose( Hndl, Status ) #endif +#ifdef PIO + CASE ( IO_PIO ) + CALL ext_pio_ioclose( Hndl, Status ) +#endif #ifdef XXX CASE ( IO_XXX ) CALL ext_xxx_ioclose( Hndl, Status ) @@ -1225,7 +1296,7 @@ SUBROUTINE wrf_ioclose ( DataHandle, Status ) CASE DEFAULT Status = 0 END SELECT - ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_ioclose( Hndl, Status ) ELSE Status = 0 @@ -1252,16 +1323,17 @@ SUBROUTINE wrf_get_next_time ( DataHandle, DateStr, Status ) #include "wrf_status_codes.h" INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers - INTEGER io_form , Hndl, len_of_str + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for + INTEGER :: io_form, len_of_str LOGICAL :: for_out + INTEGER :: Hndl CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_next_time' ) Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package(io_form) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1272,14 +1344,38 @@ SUBROUTINE wrf_get_next_time ( DataHandle, DateStr, Status ) CALL wrf_dm_bcast_string ( DateStr , len_of_str ) ENDIF #endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + IF ( multi_files(io_form) ) THEN + CALL ext_pnc_get_next_time( Hndl, DateStr, Status ) + ELSE + IF ( wrf_dm_on_monitor() ) THEN + CALL ext_pnc_get_next_time( Hndl, DateStr, Status ) + ENDIF + + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + len_of_str = LEN(DateStr) + CALL wrf_dm_bcast_string ( DateStr , len_of_str ) + ENDIF +#endif +#ifdef PIO + CASE ( IO_PIO ) + IF ( multi_files(io_form) ) THEN + CALL ext_pio_get_next_time( Hndl, DateStr, Status ) + ELSE + IF ( wrf_dm_on_monitor() ) THEN + CALL ext_pio_get_next_time( Hndl, DateStr, Status ) + ENDIF + + CALL wrf_dm_bcast_bytes( Status, IWORDSIZE ) + len_of_str = LEN(DateStr) + CALL wrf_dm_bcast_string ( DateStr , len_of_str ) + ENDIF +#endif #ifdef PHDF5 CASE ( IO_PHDF5 ) CALL ext_phdf5_get_next_time( Hndl, DateStr, Status ) #endif -#ifdef PNETCDF - CASE ( IO_PNETCDF ) - CALL ext_pnc_get_next_time( Hndl, DateStr, Status ) -#endif #ifdef XXX CASE ( IO_XXX ) CALL ext_xxx_get_next_time( Hndl, DateStr, Status ) @@ -1327,7 +1423,7 @@ SUBROUTINE wrf_get_next_time ( DataHandle, DateStr, Status ) CASE DEFAULT Status = 0 END SELECT - ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_next_time( Hndl, DateStr, Status ) ELSE Status = 0 @@ -1354,16 +1450,17 @@ SUBROUTINE wrf_get_previous_time ( DataHandle, DateStr, Status ) #include "wrf_status_codes.h" INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers - INTEGER io_form , Hndl, len_of_str + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for + INTEGER :: io_form, len_of_str LOGICAL :: for_out + INTEGER :: Hndl CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_previous_time' ) Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package(io_form) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1374,14 +1471,18 @@ SUBROUTINE wrf_get_previous_time ( DataHandle, DateStr, Status ) CALL wrf_dm_bcast_string ( DateStr , len_of_str ) ENDIF #endif -#ifdef PHDF5 - CASE ( IO_PHDF5 ) - CALL ext_phdf5_get_previous_time( Hndl, DateStr, Status ) -#endif #ifdef PNETCDF CASE ( IO_PNETCDF ) CALL ext_pnc_get_previous_time( Hndl, DateStr, Status ) #endif +#ifdef PIO + CASE ( IO_PIO ) + CALL ext_pio_get_previous_time( Hndl, DateStr, Status ) +#endif +#ifdef PHDF5 + CASE ( IO_PHDF5 ) + CALL ext_phdf5_get_previous_time( Hndl, DateStr, Status ) +#endif #ifdef XXX CASE ( IO_XXX ) CALL ext_xxx_get_previous_time( Hndl, DateStr, Status ) @@ -1422,7 +1523,7 @@ SUBROUTINE wrf_get_previous_time ( DataHandle, DateStr, Status ) CASE DEFAULT Status = 0 END SELECT - ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_previous_time( Hndl, DateStr, Status ) ELSE Status = 0 @@ -1449,16 +1550,17 @@ SUBROUTINE wrf_set_time ( DataHandle, DateStr, Status ) #include "wrf_status_codes.h" INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers - INTEGER io_form , Hndl + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for + INTEGER :: io_form LOGICAL :: for_out + INTEGER :: Hndl CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_set_time' ) Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1473,6 +1575,10 @@ SUBROUTINE wrf_set_time ( DataHandle, DateStr, Status ) CASE ( IO_PNETCDF ) CALL ext_pnc_set_time( Hndl, DateStr, Status ) #endif +#ifdef PIO + CASE ( IO_PIO ) + CALL ext_pio_set_time( Hndl, DateStr, Status ) +#endif #ifdef XXX CASE ( IO_XXX ) CALL ext_xxx_set_time( Hndl, DateStr, Status ) @@ -1504,7 +1610,7 @@ SUBROUTINE wrf_set_time ( DataHandle, DateStr, Status ) CASE DEFAULT Status = 0 END SELECT - ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_set_time( Hndl, DateStr, Status ) ELSE Status = 0 @@ -1532,16 +1638,17 @@ SUBROUTINE wrf_get_next_var ( DataHandle, VarName, Status ) #include "wrf_status_codes.h" INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers - INTEGER io_form , Hndl + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for + INTEGER :: io_form LOGICAL :: for_out + INTEGER :: Hndl CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_next_var' ) Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1579,7 +1686,7 @@ SUBROUTINE wrf_get_next_var ( DataHandle, VarName, Status ) CASE DEFAULT Status = 0 END SELECT - ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_next_var( Hndl, VarName, Status ) ELSE Status = 0 @@ -1611,17 +1718,18 @@ SUBROUTINE wrf_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagge INTEGER ,dimension(*) ,INTENT(OUT) :: DomainStart, DomainEnd INTEGER ,INTENT(OUT) :: Status #include "wrf_status_codes.h" - INTEGER io_form , Hndl + INTEGER :: io_form LOGICAL :: for_out INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers_for + INTEGER :: Hndl CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_var_info' ) Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF (( multi_files(io_form) .OR. wrf_dm_on_monitor() ) .AND. .NOT. (for_out .AND. use_output_servers()) ) THEN + IF (( multi_files(io_form) .OR. wrf_dm_on_monitor() ) .AND. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -1644,6 +1752,13 @@ SUBROUTINE wrf_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagge DomainStart , DomainEnd , & Status ) #endif +#ifdef PIO + CASE ( IO_PIO ) + CALL ext_pio_get_var_info ( Hndl , VarName , NDim , & + MemoryOrder , Stagger , & + DomainStart , DomainEnd , & + Status ) +#endif #ifdef XXX CASE ( IO_XXX ) CALL ext_xxx_get_var_info ( Hndl , VarName , NDim , & @@ -1675,7 +1790,7 @@ SUBROUTINE wrf_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagge CASE DEFAULT Status = 0 END SELECT - ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers() ) THEN + ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN CALL wrf_quilt_get_var_info ( Hndl , VarName , NDim , & MemoryOrder , Stagger , & DomainStart , DomainEnd , & @@ -1735,10 +1850,18 @@ SUBROUTINE add_new_handle( Hndl, Hopened, for_out, DataHandle ) ENDIF IF ( multi_files( Hopened ) ) THEN SELECT CASE ( use_package( Hopened ) ) +#ifdef PHDF5 CASE ( IO_PHDF5 ) CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for PHDF5' ) +#endif +#ifdef PNETCDF CASE ( IO_PNETCDF ) CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for PNETCDF' ) +#endif +#ifdef PIO + CASE ( IO_PIO ) + CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for PIO' ) +#endif #ifdef MCELIO CASE ( IO_MCEL ) CALL wrf_error_fatal( 'add_new_handle: multiple output files not supported for MCEL' ) @@ -1917,8 +2040,8 @@ END MODULE module_io ! ! SUBROUTINE wrf_read_field ( DataHandle , DateStr , VarName , Field , FieldType , & - Comm , IOComm , & - DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + grid , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & DomainStart , DomainEnd , & MemoryStart , MemoryEnd , & PatchStart , PatchEnd , & @@ -1932,14 +2055,14 @@ SUBROUTINE wrf_read_field ( DataHandle , DateStr , VarName , Field , FieldType , ! USE module_state_description USE module_configure + USE module_domain IMPLICIT NONE INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: DateStr CHARACTER*(*) :: VarName LOGICAL , INTENT(INOUT) :: Field(*) INTEGER ,INTENT(IN) :: FieldType - INTEGER ,INTENT(INOUT) :: Comm - INTEGER ,INTENT(INOUT) :: IOComm + TYPE(domain) :: grid INTEGER ,INTENT(IN) :: DomainDesc LOGICAL, DIMENSION(4) :: bdy_mask CHARACTER*(*) ,INTENT(IN) :: MemoryOrder @@ -1956,9 +2079,9 @@ SUBROUTINE wrf_read_field ( DataHandle , DateStr , VarName , Field , FieldType , IF ( FieldType .EQ. WRF_LOGICAL ) THEN ALLOCATE(ICAST((MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1))) - CALL wrf_read_field1 ( DataHandle , DateStr , VarName , ICAST , WRF_INTEGER , & - Comm , IOComm , & - DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + CALL wrf_read_field1 ( DataHandle , DateStr , VarName , ICAST , WRF_INTEGER , & + grid , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & DomainStart , DomainEnd , & MemoryStart , MemoryEnd , & PatchStart , PatchEnd , & @@ -1967,8 +2090,8 @@ SUBROUTINE wrf_read_field ( DataHandle , DateStr , VarName , Field , FieldType , DEALLOCATE(ICAST) ELSE CALL wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType , & - Comm , IOComm , & - DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & + grid , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & DomainStart , DomainEnd , & MemoryStart , MemoryEnd , & PatchStart , PatchEnd , & @@ -1982,9 +2105,9 @@ SUBROUTINE wrf_read_field ( DataHandle , DateStr , VarName , Field , FieldType , ENDIF END SUBROUTINE wrf_read_field -SUBROUTINE wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType , & - Comm , IOComm , & - DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & +SUBROUTINE wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType , & + grid , & + DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & DomainStart , DomainEnd , & MemoryStart , MemoryEnd , & PatchStart , PatchEnd , & @@ -1998,14 +2121,14 @@ SUBROUTINE wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType USE module_state_description USE module_configure USE module_io + USE module_domain IMPLICIT NONE INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: DateStr CHARACTER*(*) :: VarName INTEGER , INTENT(INOUT) :: Field(*) INTEGER ,INTENT(IN) :: FieldType - INTEGER ,INTENT(INOUT) :: Comm - INTEGER ,INTENT(INOUT) :: IOComm + TYPE(domain) :: grid INTEGER ,INTENT(IN) :: DomainDesc LOGICAL, DIMENSION(4) :: bdy_mask CHARACTER*(*) ,INTENT(IN) :: MemoryOrder @@ -2016,13 +2139,19 @@ SUBROUTINE wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType INTEGER ,dimension(*) ,INTENT(IN) :: PatchStart, PatchEnd INTEGER ,INTENT(OUT) :: Status #include "wrf_status_codes.h" - INTEGER io_form , Hndl + INTEGER :: io_form LOGICAL :: for_out INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers, use_input_servers + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers, use_input_servers, use_output_servers_for #ifdef NETCDF EXTERNAL ext_ncd_read_field #endif +#ifdef PNETCDF + EXTERNAL ext_pnc_read_field +#endif +#ifdef PIO + EXTERNAL ext_pio_read_field +#endif #ifdef MCELIO EXTERNAL ext_mcel_read_field #endif @@ -2045,6 +2174,13 @@ SUBROUTINE wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType EXTERNAL ext_gr2_read_field #endif + INTEGER :: Hndl + INTEGER :: Comm + INTEGER :: IOComm + + Comm = grid%communicator + IOComm = grid%iocommunicator + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_read_field' ) Status = 0 @@ -2087,6 +2223,15 @@ SUBROUTINE wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType PatchStart , PatchEnd , & Status ) #endif +#ifdef PIO + CASE ( IO_PIO) + CALL ext_pio_read_field(Hndl , DateStr , VarName , Field , FieldType , grid , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status) +#endif #ifdef MCELIO CASE ( IO_MCEL ) CALL call_pkg_and_dist ( ext_mcel_read_field, multi_files(io_form), .true. , & @@ -2169,7 +2314,7 @@ SUBROUTINE wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType END SUBROUTINE wrf_read_field1 SUBROUTINE wrf_write_field ( DataHandle , DateStr , VarName , Field , FieldType , & - Comm , IOComm , & + grid , & DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & DomainStart , DomainEnd , & MemoryStart , MemoryEnd , & @@ -2184,14 +2329,14 @@ SUBROUTINE wrf_write_field ( DataHandle , DateStr , VarName , Field , FieldType ! USE module_state_description USE module_configure + USE module_domain IMPLICIT NONE INTEGER , INTENT(IN) :: DataHandle CHARACTER*(*) :: DateStr CHARACTER*(*) :: VarName LOGICAL , INTENT(IN) :: Field(*) INTEGER ,INTENT(IN) :: FieldType - INTEGER ,INTENT(INOUT) :: Comm - INTEGER ,INTENT(INOUT) :: IOComm + TYPE(domain) :: grid INTEGER ,INTENT(IN) :: DomainDesc LOGICAL, DIMENSION(4) ,INTENT(IN) :: bdy_mask CHARACTER*(*) ,INTENT(IN) :: MemoryOrder @@ -2211,7 +2356,7 @@ SUBROUTINE wrf_write_field ( DataHandle , DateStr , VarName , Field , FieldType ICAST = 1 END WHERE CALL wrf_write_field1 ( DataHandle , DateStr , VarName , ICAST , WRF_INTEGER , & - Comm , IOComm , & + grid , & DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & DomainStart , DomainEnd , & MemoryStart , MemoryEnd , & @@ -2220,7 +2365,7 @@ SUBROUTINE wrf_write_field ( DataHandle , DateStr , VarName , Field , FieldType DEALLOCATE(ICAST) ELSE CALL wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType , & - Comm , IOComm , & + grid , & DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & DomainStart , DomainEnd , & MemoryStart , MemoryEnd , & @@ -2230,7 +2375,7 @@ SUBROUTINE wrf_write_field ( DataHandle , DateStr , VarName , Field , FieldType END SUBROUTINE wrf_write_field SUBROUTINE wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType , & - Comm , IOComm , & + grid , & DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames , & DomainStart , DomainEnd , & MemoryStart , MemoryEnd , & @@ -2245,6 +2390,7 @@ SUBROUTINE wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType USE module_state_description USE module_configure + USE module_domain USE module_io IMPLICIT NONE INTEGER , INTENT(IN) :: DataHandle @@ -2252,8 +2398,7 @@ SUBROUTINE wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType CHARACTER*(*) :: VarName INTEGER , INTENT(IN) :: Field(*) INTEGER ,INTENT(IN) :: FieldType - INTEGER ,INTENT(INOUT) :: Comm - INTEGER ,INTENT(INOUT) :: IOComm + TYPE(domain) :: grid INTEGER ,INTENT(IN) :: DomainDesc LOGICAL, DIMENSION(4) ,INTENT(IN) :: bdy_mask CHARACTER*(*) ,INTENT(IN) :: MemoryOrder @@ -2265,14 +2410,20 @@ SUBROUTINE wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType INTEGER ,INTENT(OUT) :: Status #include "wrf_status_codes.h" INTEGER, DIMENSION(3) :: starts, ends - INTEGER io_form , Hndl + INTEGER :: io_form CHARACTER*3 MemOrd LOGICAL :: for_out, okay_to_call INTEGER, EXTERNAL :: use_package - LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers + LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files, use_output_servers, use_output_servers_for #ifdef NETCDF EXTERNAL ext_ncd_write_field #endif +#ifdef PNETCDF + EXTERNAL ext_pnc_write_field +#endif +#ifdef PIO + EXTERNAL ext_pio_write_field +#endif #ifdef MCELIO EXTERNAL ext_mcel_write_field #endif @@ -2295,13 +2446,20 @@ SUBROUTINE wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType EXTERNAL ext_gr2_write_field #endif + INTEGER :: Hndl + INTEGER :: Comm + INTEGER :: IOComm + + Comm = grid%communicator + IOComm = grid%iocommunicator + CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_write_field' ) Status = 0 CALL get_handle ( Hndl, io_form , for_out, DataHandle ) CALL reset_first_operation ( DataHandle ) IF ( Hndl .GT. -1 ) THEN - IF ( multi_files( io_form ) .OR. .NOT. use_output_servers() ) THEN + IF ( multi_files( io_form ) .OR. .NOT. use_output_servers_for(io_form) ) THEN SELECT CASE ( use_package( io_form ) ) #ifdef NETCDF CASE ( IO_NETCDF ) @@ -2364,6 +2522,26 @@ SUBROUTINE wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType starts , ends , & Status ) #endif +#ifdef PIO + CASE ( IO_PIO ) + CALL lower_case( MemoryOrder, MemOrd ) + okay_to_call = .TRUE. + IF ((TRIM(MemOrd).EQ.'xsz' .OR. TRIM(MemOrd).EQ.'xs').AND. .NOT. bdy_mask(P_XSB)) okay_to_call = .FALSE. + IF ((TRIM(MemOrd).EQ.'xez' .OR. TRIM(MemOrd).EQ.'xe').AND. .NOT. bdy_mask(P_XEB)) okay_to_call = .FALSE. + IF ((TRIM(MemOrd).EQ.'ysz' .OR. TRIM(MemOrd).EQ.'ys').AND. .NOT. bdy_mask(P_YSB)) okay_to_call = .FALSE. + IF ((TRIM(MemOrd).EQ.'yez' .OR. TRIM(MemOrd).EQ.'ye').AND. .NOT. bdy_mask(P_YEB)) okay_to_call = .FALSE. + IF ( okay_to_call ) THEN + starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchEnd(1:3) + ELSE + starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchStart(1:3)-1 + ENDIF + + CALL ext_pio_write_field( Hndl , DateStr , VarName , Field , FieldType , grid , & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + starts , ends , Status ) +#endif #ifdef XXX CASE ( IO_XXX ) CALL collect_fld_and_call_pkg ( ext_xxx_write_field, multi_files(io_form), & @@ -2417,7 +2595,7 @@ SUBROUTINE wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType CASE DEFAULT Status = 0 END SELECT - ELSE IF ( use_output_servers() ) THEN + ELSE IF ( use_output_servers_for(io_form) ) THEN IF ( io_form .GT. 0 ) THEN CALL wrf_quilt_write_field ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , & DomainDesc , MemoryOrder , Stagger , DimNames , & @@ -2500,12 +2678,16 @@ LOGICAL FUNCTION multi_files ( io_form ) ! of tasks that were used to write it. This feature can be useful for ! speeding up restarts on machines that support efficient parallel I/O. ! Multi-file formats cannot be used with I/O quilt servers. +! +! Note: multi-file is selected by adding 100 to the standard WRF I/O +! form. If you add 200 instead, then single-file I/O is still done, +! but without I/O servers. ! ! IMPLICIT NONE INTEGER, INTENT(IN) :: io_form #ifdef DM_PARALLEL - multi_files = io_form > 99 + multi_files = ( io_form >= 100 .and. io_form<200 ) #else multi_files = .FALSE. #endif diff --git a/wrfv2_fire/frame/module_io_quilt.F b/wrfv2_fire/frame/module_io_quilt.F index 6f300f5c..fa29ffa3 100644 --- a/wrfv2_fire/frame/module_io_quilt.F +++ b/wrfv2_fire/frame/module_io_quilt.F @@ -1265,6 +1265,13 @@ SUBROUTINE quilt END SELECT ENDIF +! If desired, outputs a ready flag after quilting subroutine closes the data handle for history (wrfout) file. + + IF (fname(1:6) .EQ. 'wrfout' .AND. config_flags%output_ready_flag ) THEN + OPEN (unit=99,file='wrfoutReady' // fname(7:30), status='unknown', access='sequential') + CLOSE (99) + ENDIF + ! The I/O server "root" handles the "open_for_write_begin" request. CASE ( int_open_for_write_begin ) @@ -2613,7 +2620,7 @@ SUBROUTINE init_module_wrf_quilt CALL wrf_get_dm_communicator( mpi_comm_here ) CALL MPI_Comm_rank ( mpi_comm_here, mytask, ierr ) ; - CALL mpi_x_comm_size ( mpi_comm_here, ntasks, ierr ) ; + CALL mpi_x_comm_size( mpi_comm_here, ntasks, ierr ) ; IF ( mytask .EQ. 0 ) THEN OPEN ( unit=27, file="namelist.input", form="formatted", status="old" ) @@ -2897,6 +2904,21 @@ SUBROUTINE disable_quilting RETURN END SUBROUTINE disable_quilting +LOGICAL FUNCTION use_output_servers_for(ioform) +! +! Returns .TRUE. if I/O quilt servers are in-use for write operations +! AND the output servers can handle the given I/O form. If the I/O +! form is 0, then the io form is not considered and the result is the +! same as calling use_output_servers. +! This routine is called only by client (compute) tasks. +! + USE module_wrf_quilt + integer, intent(in) :: ioform + use_output_servers_for = quilting_enabled + use_output_servers_for = ( use_output_servers_for .and. ioform<100 ) + RETURN +END FUNCTION use_output_servers_for + LOGICAL FUNCTION use_output_servers() ! ! Returns .TRUE. if I/O quilt servers are in-use for write operations. diff --git a/wrfv2_fire/frame/module_quilt_outbuf_ops.F b/wrfv2_fire/frame/module_quilt_outbuf_ops.F index d056908e..1b4116b2 100644 --- a/wrfv2_fire/frame/module_quilt_outbuf_ops.F +++ b/wrfv2_fire/frame/module_quilt_outbuf_ops.F @@ -90,11 +90,11 @@ SUBROUTINE init_outbuf ! We don't free any memory here - that is done immediately after the ! write of each patch is completed DO j = 1, outpatch_table(i)%npatch - outpatch_table(i)%PatchList(j)%forDeletion = .FALSE. - outpatch_table(i)%PatchList(j)%PatchStart(:) = 0 - outpatch_table(i)%PatchList(j)%PatchEnd(:) = 0 - outpatch_table(i)%PatchList(j)%PatchExtent(:)= 0 IF (ALLOCATED(outpatch_table(i)%PatchList)) THEN + outpatch_table(i)%PatchList(j)%forDeletion = .FALSE. + outpatch_table(i)%PatchList(j)%PatchStart(:) = 0 + outpatch_table(i)%PatchList(j)%PatchEnd(:) = 0 + outpatch_table(i)%PatchList(j)%PatchExtent(:)= 0 IF (ASSOCIATED(outpatch_table(i)%PatchList(j)%rptr)) & NULLIFY( outpatch_table(i)%PatchList(j)%rptr ) IF (ASSOCIATED(outpatch_table(i)%PatchList(j)%iptr)) & diff --git a/wrfv2_fire/frame/module_timing.F b/wrfv2_fire/frame/module_timing.F index 435a69ff..e8dfe883 100644 --- a/wrfv2_fire/frame/module_timing.F +++ b/wrfv2_fire/frame/module_timing.F @@ -102,5 +102,21 @@ SUBROUTINE end_timing ( string ) END SUBROUTINE end_timing + FUNCTION now_time() result(timef) + ! This is a simple subroutine that returns the current time in + ! seconds since some arbitrary reference point. This routine is + ! meant to be used to accumulate timing information. See solve_nmm + ! for examples. + implicit none + real*8 :: timef +#if defined(OLD_TIMERS) + integer :: ic,ir + call system_clock(count=ic,count_rate=ir) + timef=real(ic)/real(ir) +#else + call hires_timer(timef) +#endif + END FUNCTION now_time + END MODULE module_timing diff --git a/wrfv2_fire/frame/module_wrf_error.F b/wrfv2_fire/frame/module_wrf_error.F index dcf1bb13..ff5fe666 100644 --- a/wrfv2_fire/frame/module_wrf_error.F +++ b/wrfv2_fire/frame/module_wrf_error.F @@ -103,7 +103,7 @@ SUBROUTINE init_module_wrf_error(on_io_server) #else stderr_logging=0 #endif - +500 format(A) ! Open namelist.input using the same unit used by module_io_wrf ! since we know nobody will screw up that unit: OPEN(unit=27, file="namelist.input", form="formatted", status="old") @@ -134,15 +134,15 @@ SUBROUTINE init_module_wrf_error(on_io_server) endif #else if(buffer_size>=min_allowed_buffer_size) then - write(0,*) 'Forcing disabling of buffering due to compile-time configuration.' - write(6,*) 'Forcing disabling of buffering due to compile-time configuration.' + write(0,500) 'Forcing disabling of buffering due to compile-time configuration.' + write(6,500) 'Forcing disabling of buffering due to compile-time configuration.' endif #endif stderrlog=stderr_logging if(buffered/=0 .and. stderrlog/=0) then - write(0,*) 'Disabling stderr logging since buffering is enabled.' - write(6,*) 'Disabling stderr logging since buffering is enabled.' + write(0,500) 'Disabling stderr logging since buffering is enabled.' + write(6,500) 'Disabling stderr logging since buffering is enabled.' # ifdef _WIN32 FLUSH(0) # endif @@ -216,12 +216,13 @@ SUBROUTINE wrf_message( str ) else !$OMP MASTER if(stderrlog/=0) then - write(0,*) trim(str) +300 format(A) + write(0,300) trim(str) # ifdef _WIN32 FLUSH(0) # endif endif - print *,trim(str) + print 300,trim(str) !$OMP END MASTER endif @@ -244,7 +245,8 @@ SUBROUTINE wrf_message2( str ) IMPLICIT NONE CHARACTER*(*) str !$OMP MASTER - write(0,*) str +400 format(A) + write(0,400) str # ifdef _WIN32 FLUSH(0) # endif @@ -337,4 +339,29 @@ SUBROUTINE wrf_check_error( expected, actual, str, file_str, line ) ENDIF END SUBROUTINE wrf_check_error +! ------------------------------------------------------------------------------ + +! Some compilers do not yet support the entirety of the Fortran 2003 standard. +! This is a small patch to pick up the two most common events. Most xlf +! compilers have an extension fflush. That is available here. For other older +! compilers with no flush capability at all, we just stub it out completely. +! These CPP ifdefs are defined in the configure file. + +#ifdef USE_FFLUSH +SUBROUTINE flush ( iunit ) + IMPLICIT NONE + INTEGER :: iunit + CALL fflush ( iunit ) +END SUBROUTINE flush +#endif + +#ifdef NO_FLUSH_SUPPORT +SUBROUTINE flush ( iunit ) + IMPLICIT NONE + INTEGER :: iunit + RETURN +END SUBROUTINE flush +#endif + + diff --git a/wrfv2_fire/hydro/.svn/all-wcprops b/wrfv2_fire/hydro/.svn/all-wcprops new file mode 100644 index 00000000..dc82d41c --- /dev/null +++ b/wrfv2_fire/hydro/.svn/all-wcprops @@ -0,0 +1,17 @@ +K 25 +svn:wc:ra_dav:version-url +V 52 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro +END +configure +K 25 +svn:wc:ra_dav:version-url +V 62 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/configure +END +wrf_hydro_config +K 25 +svn:wc:ra_dav:version-url +V 69 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/wrf_hydro_config +END diff --git a/wrfv2_fire/hydro/.svn/entries b/wrfv2_fire/hydro/.svn/entries new file mode 100644 index 00000000..7bfa1a21 --- /dev/null +++ b/wrfv2_fire/hydro/.svn/entries @@ -0,0 +1,117 @@ +10 + +dir +9105 +https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro +https://kkeene@svn-wrf-model.cgd.ucar.edu + + + +2015-02-13T18:35:30.360105Z +8075 +weiyu@ucar.edu + + + + + + + + + + + + + + +b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d + +HYDRO_drv +dir + +configure +file + + + + +2016-02-11T20:37:50.236264Z +3f7003464a22be1e14d86f1ef73867eb +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu +has-props + + + + + + + + + + + + + + + + + + + + +3506 + +Data_Rec +dir + +Run +dir + +arc +dir + +Routing +dir + +wrf_hydro_config +file + + + + +2016-02-11T20:37:50.234759Z +cdded48ac3d16f3ab131ea7500240998 +2013-02-22T21:30:52.969349Z +6386 +weiyu@ucar.edu +has-props + + + + + + + + + + + + + + + + + + + + +948 + +MPP +dir + +CPL +dir + diff --git a/wrfv2_fire/hydro/.svn/prop-base/configure.svn-base b/wrfv2_fire/hydro/.svn/prop-base/configure.svn-base new file mode 100644 index 00000000..869ac71c --- /dev/null +++ b/wrfv2_fire/hydro/.svn/prop-base/configure.svn-base @@ -0,0 +1,5 @@ +K 14 +svn:executable +V 1 +* +END diff --git a/wrfv2_fire/hydro/.svn/prop-base/wrf_hydro_config.svn-base b/wrfv2_fire/hydro/.svn/prop-base/wrf_hydro_config.svn-base new file mode 100644 index 00000000..869ac71c --- /dev/null +++ b/wrfv2_fire/hydro/.svn/prop-base/wrf_hydro_config.svn-base @@ -0,0 +1,5 @@ +K 14 +svn:executable +V 1 +* +END diff --git a/wrfv2_fire/hydro/.svn/text-base/configure.svn-base b/wrfv2_fire/hydro/.svn/text-base/configure.svn-base new file mode 100644 index 00000000..5848f116 --- /dev/null +++ b/wrfv2_fire/hydro/.svn/text-base/configure.svn-base @@ -0,0 +1,107 @@ +#!/usr/bin/perl + + if(! defined($ENV{NETCDF_INC})){ + if(defined($ENV{NETCDF})) { + $tt = `echo "NETCDF_INC = \${NETCDF}/include" > macros.tmp` ; + } else { + print"Error: environment variable NETCDF_INC not defined. \n"; + exit(0); + } + } + + ${NETCDF_LIB} = $ENV{NETCDF_LIB}; + if(! defined($ENV{NETCDF_LIB})){ + if(defined($ENV{NETCDF})) { + $tt = `echo "NETCDF_LIB = \${NETCDF}/lib" >> macros.tmp` ; + ${NETCDF_LIB} = $ENV{NETCDF}."/lib"; + } else { + print"Error: environment variable NETCDF_LIB not defined. \n"; + exit(0); + } + } + + if(! -e "${NETCDF_LIB}/libnetcdff.a"){ + $tt = `echo "NETCDFLIB = -L${NETCDF_LIB} -lnetcdf" >> macros.tmp `; + } + + if(-e macros) {system (rm -f macros);} +# if(-e Makefile) {system "rm -f Makefile" ;} + +# system("cp arc/Makefile ."); + + if($#ARGV == 0) { + $response = shift(@ARGV) ; + print("Configure hydro: $response \n"); + }else { + print "Please select from following supported options. \n\n"; + + print " 1. Linux PGI compiler sequential \n"; + print " 2. Linux PGI compiler dmpar \n"; + print " 3. IBM AIX compiler sequential, xlf90_r\n"; + print " 4. IBM AIX compiler dmpar \n"; + print " 5. Linux gfort compiler sequential \n"; + print " 6. Linux gfort compiler dmpar \n"; + print " 7. Linux ifort compiler sequential \n"; + print " 8. Linux ifort compiler dmpar \n"; + print " 0. exit only \n"; + + printf "\nEnter selection [%d-%d] : ",1,5 ; + + $response = ; + chop($response); + } + + use Switch; + switch ($response) { + case 1 { + # sequential linux + system "cp arc/macros.seq.linux macros"; + system "cp arc/Makefile.seq Makefile.comm"; + } + + case 2 { + # mpp linux + system "cp arc/macros.mpp.linux macros"; + system "cp arc/Makefile.mpp Makefile.comm"; + } + + case 3 { + # sequential IBM AIX + system "cp arc/macros.seq.IBM.xlf90_r macros"; + system "cp arc/Makefile.seq Makefile.comm"; + } + + case 4 { + # mpp IBM AIX + system "cp arc/macros.mpp.IBM.xlf90_r macros"; + system "cp arc/Makefile.mpp Makefile.comm"; + } + + case 5 { + # GFORTRAN only + system "cp arc/macros.seq.gfort macros"; + system "cp arc/Makefile.seq Makefile.comm"; + } + + case 6 { + # GFORTRAN dmpar only + system "cp arc/macros.mpp.gfort macros"; + system "cp arc/Makefile.mpp Makefile.comm"; + } + case 7 { + # ifort sequential + system "cp arc/macros.seq.ifort macros"; + system "cp arc/Makefile.seq Makefile.comm"; + } + case 8 { + # ifort dmpar only + system "cp arc/macros.mpp.ifort macros"; + system "cp arc/Makefile.mpp Makefile.comm"; + } + + else {print "no selection $response\n"; last} + } + if(! (-e lib)) {mkdir lib;} + if(! (-e mod)) {mkdir mod;} + if(-e "macros.tmp") { system("cat macros macros.tmp > macros.a; rm -f macros.tmp; mv macros.a macros");} + if((-d "LandModel") ) {system "cat macros LandModel/user_build_options.bak > LandModel/user_build_options";} diff --git a/wrfv2_fire/hydro/.svn/text-base/wrf_hydro_config.svn-base b/wrfv2_fire/hydro/.svn/text-base/wrf_hydro_config.svn-base new file mode 100644 index 00000000..47548324 --- /dev/null +++ b/wrfv2_fire/hydro/.svn/text-base/wrf_hydro_config.svn-base @@ -0,0 +1,28 @@ +#!/usr/bin/perl +#input argument: Compiler/System sequential/parallel +#This is called by WRF configuration only. +if($#ARGV ne 1) { + print("Error: No such configuration for Hydro \n"); + exit(1); +} + $x = lc(shift(@ARGV)); + $paropt = lc(shift(@ARGV)); + + print("Configure option for Hydro : $x $paropt \n"); + if($x =~ "pgi") { + if($paropt eq 'serial') { system("./configure 1");} + else {system("./configure 2");} + } + if($x =~ "aix") { + if($paropt eq 'serial') { system("./configure 3");} + else {system("./configure 4");} + } + if($x =~ "gfortran") { + if($paropt eq 'serial') { system("./configure 5");} + else {system("./configure 6");} + } + if($x =~ "ifort") { + if($paropt eq 'serial') { system("./configure 7");} + else {system("./configure 8");} + } + diff --git a/wrfv2_fire/hydro/CPL/.svn/all-wcprops b/wrfv2_fire/hydro/CPL/.svn/all-wcprops new file mode 100644 index 00000000..17be25a2 --- /dev/null +++ b/wrfv2_fire/hydro/CPL/.svn/all-wcprops @@ -0,0 +1,5 @@ +K 25 +svn:wc:ra_dav:version-url +V 56 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL +END diff --git a/wrfv2_fire/hydro/CPL/.svn/entries b/wrfv2_fire/hydro/CPL/.svn/entries new file mode 100644 index 00000000..b6a09ea6 --- /dev/null +++ b/wrfv2_fire/hydro/CPL/.svn/entries @@ -0,0 +1,31 @@ +10 + +dir +9105 +https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/CPL +https://kkeene@svn-wrf-model.cgd.ucar.edu + + + +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + +b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d + +WRF_cpl +dir + diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/all-wcprops b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/all-wcprops new file mode 100644 index 00000000..781d2007 --- /dev/null +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/all-wcprops @@ -0,0 +1,29 @@ +K 25 +svn:wc:ra_dav:version-url +V 64 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl +END +wrf_drv_HYDRO.F +K 25 +svn:wc:ra_dav:version-url +V 80 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F +END +Makefile.cpl +K 25 +svn:wc:ra_dav:version-url +V 77 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl/Makefile.cpl +END +module_wrf_HYDRO.F +K 25 +svn:wc:ra_dav:version-url +V 83 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F +END +Makefile +K 25 +svn:wc:ra_dav:version-url +V 73 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl/Makefile +END diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/entries b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/entries new file mode 100644 index 00000000..44158a6c --- /dev/null +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/entries @@ -0,0 +1,164 @@ +10 + +dir +9105 +https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl +https://kkeene@svn-wrf-model.cgd.ucar.edu + + + +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + +b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d + +wrf_drv_HYDRO.F +file + + + + +2016-02-11T20:37:50.172606Z +6e1e076f2e8b1e1efb225f08dde43a2b +2012-12-07T20:01:45.900797Z +6094 +gill + + + + + + + + + + + + + + + + + + + + + +909 + +Makefile.cpl +file + + + + +2016-02-11T20:37:50.169433Z +ae2c681e0c2a0970fc2beb3d446630b5 +2013-11-15T19:40:36.446206Z +6964 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +132 + +module_wrf_HYDRO.F +file + + + + +2016-02-11T20:37:50.170735Z +bf29748e6330d3d497a4ca9714d98296 +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +10480 + +Makefile +file + + + + +2016-02-11T20:37:50.171667Z +ea417729522d5ddb60fafaacd56dda2b +2013-11-15T19:40:36.446206Z +6964 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +673 + diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.cpl.svn-base b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.cpl.svn-base new file mode 100644 index 00000000..64550bdb --- /dev/null +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.cpl.svn-base @@ -0,0 +1,9 @@ +# Makefile + +all: + (cd ../../; make -f Makefile.comm BASIC) + (make) + +clean: + (make clean) + (cd ../../; make -f Makefile.comm clean) diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.svn-base b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.svn-base new file mode 100644 index 00000000..a37fbe0d --- /dev/null +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.svn-base @@ -0,0 +1,34 @@ +# Makefile +# +.SUFFIXES: +.SUFFIXES: .o .F + + + +include ../../macros + +MODFLAG = -I./ -I ../../MPP -I ../../mod + +WRF_ROOT = ../../.. +OBJS = \ + module_wrf_HYDRO.o \ + wrf_drv_HYDRO.o +all: $(OBJS) + +.F.o: + @echo "" + $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f + $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I$(WRF_ROOT)/frame -I$(WRF_ROOT)/main -I$(WRF_ROOT)/external/esmf_time_f90 $(*).f + $(RMD) $(*).f + @echo "" + ar -r ../../lib/libHYDRO.a $(@) + +# +# Dependencies: +# +module_wrf_HYDRO.o: ../../Data_Rec/module_RT_data.o ../../Data_Rec/module_namelist.o ../../HYDRO_drv/module_HYDRO_drv.o + +wrf_drv_HYDRO.o: module_wrf_HYDRO.o + +clean: + rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/module_wrf_HYDRO.F.svn-base b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/module_wrf_HYDRO.F.svn-base new file mode 100644 index 00000000..700ca2a1 --- /dev/null +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/module_wrf_HYDRO.F.svn-base @@ -0,0 +1,341 @@ +module module_WRF_HYDRO + +#ifdef MPP_LAND + use module_mpp_land, only: global_nx, global_ny, decompose_data_real, & + write_io_real, my_id, mpp_land_bcast_real1, IO_id, & + mpp_land_bcast_real, mpp_land_bcast_int1 +#endif + use module_HYDRO_drv, only: HYDRO_ini, HYDRO_exe + + use module_rt_data, only: rt_domain + use module_CPL_LAND, only: CPL_LAND_INIT, cpl_outdate + use module_namelist, only: nlst_rt + USE module_domain, ONLY : domain, domain_clock_get + !yw USE module_configure, only : config_flags + USE module_configure, only: model_config_rec + + + implicit none + + !yw added for check soil moisture and soiltype + integer :: checkSOIL_flag + +! +! added to consider the adaptive time step from WRF model. + real :: dtrt0 + integer :: mm0 + + + + +CONTAINS + +!wrf_cpl_HYDRO will not call the off-line lsm + subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) + + implicit none + TYPE ( domain ), INTENT(INOUT) :: grid + integer its, ite, jts, jte, ij + real :: HYDRO_dt + + + integer k, ix,jx, mm, nn + + integer :: did + + integer ntime + + integer :: i,j + + +!output flux and state variable + + did = 1 + ix = ite - its + 1 + jx = jte - jts + 1 + + if(HYDRO_dt .le. 0) then + write(6,*) "Warning: HYDRO_dt <= 0 from land input. set it to be 1 seconds." + HYDRO_dt = 1 + endif + + ntime = 1 + + + nlst_rt(did)%dt = HYDRO_dt + + + if(.not. RT_DOMAIN(did)%initialized) then + + + !yw nlst_rt(did)%nsoil = config_flags%num_soil_layers + !nlst_rt(did)%nsoil = model_config_rec%num_metgrid_soil_levels + nlst_rt(did)%nsoil = grid%num_soil_layers + + +#ifdef MPP_LAND + call mpp_land_bcast_int1 (nlst_rt(did)%nsoil) +#endif + allocate(nlst_rt(did)%zsoil8(nlst_rt(did)%nsoil)) + if(grid%zs(1) < 0) then + nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = grid%zs(1:nlst_rt(did)%nsoil) + else + nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = -1*grid%zs(1:nlst_rt(did)%nsoil) + endif + + CALL domain_clock_get( grid, current_timestr=cpl_outdate) + nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19) + nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19) + + + call CPL_LAND_INIT(its,ite,jts,jte) + +#ifdef HYDRO_D + write(6,*) "sf_surface_physics is ", grid%sf_surface_physics +#endif + + if(grid%sf_surface_physics .eq. 5) then + ! clm4 + call HYDRO_ini(ntime,did=did,ix0=1,jx0=1) + else + call HYDRO_ini(ntime,did,ix0=ix,jx0=jx,vegtyp=grid%IVGTYP(its:ite,jts:jte),soltyp=grid%isltyp(its:ite,jts:jte)) + endif + + + + if(nlst_rt(did)%sys_cpl .ne. 2) then + write(6,*) "Error: sys_cpl should be 2." + call hydro_stop() + endif + + + nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19) + nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19) + + nlst_rt(did)%dt = HYDRO_dt + if(nlst_rt(did)%dtrt .lt. HYDRO_dt) then + nlst_rt(did)%dtrt = HYDRO_dt + mm0 = 1 + else + mm = HYDRO_dt/nlst_rt(did)%dtrt + if(mm*nlst_rt(did)%dtrt .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm + mm0 = mm + endif + + dtrt0 = nlst_rt(did)%dtrt + endif + + if((mm0*nlst_rt(did)%dtrt) .ne. HYDRO_dt) then ! WRF model time step changed. + if(dtrt0 .lt. HYDRO_dt) then + nlst_rt(did)%dtrt = HYDRO_dt + mm0 = 1 + else + mm = HYDRO_dt/dtrt0 + if(mm*dtrt0 .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm + mm0 = mm + endif + endif + +#ifdef HYDRO_D + write(6,*) "mm, nlst_rt(did)%dt = ",mm, nlst_rt(did)%dt +#endif + + if(nlst_rt(did)%SUBRTSWCRT .eq.0 & + .and. nlst_rt(did)%OVRTSWCRT .eq. 0 .and. nlst_rt(did)%GWBASESWCRT .eq. 0) return + + nn = nlst_rt(did)%nsoil + + ! get the data from WRF + + + if((.not. RT_DOMAIN(did)%initialized) .and. (nlst_rt(did)%rst_typ .eq. 1) ) then +#ifdef HYDRO_D + write(6,*) "restart initial data from offline file" +#endif + else + do k = 1, nlst_rt(did)%nsoil + RT_DOMAIN(did)%STC(:,:,k) = grid%TSLB(its:ite,k,jts:jte) + RT_DOMAIN(did)%smc(:,:,k) = grid%smois(its:ite,k,jts:jte) + RT_DOMAIN(did)%sh2ox(:,:,k) = grid%sh2o(its:ite,k,jts:jte) + end do + rt_domain(did)%infxsrt = grid%infxsrt(its:ite,jts:jte) + rt_domain(did)%soldrain = grid%soldrain(its:ite,jts:jte) + endif + + +!yw if(checkSOIL_flag .ne. 99) then +!yw call checkSoil(did) +!yw checkSOIL_flag = 99 +!yw endif + + call HYDRO_exe(did) + + +! add for update the WRF state variable. + do k = 1, nlst_rt(did)%nsoil + ! grid%TSLB(its:ite,k,jts:jte) = RT_DOMAIN(did)%STC(:,:,k) + grid%smois(its:ite,k,jts:jte) = RT_DOMAIN(did)%smc(:,:,k) + grid%sh2o(its:ite,k,jts:jte) = RT_DOMAIN(did)%sh2ox(:,:,k) + end do + +! update WRF variable after running routing model. + grid%sfcheadrt(its:ite,jts:jte) = rt_domain(did)%sfcheadrt + +!yw not sure for the following +! grid%xice(its:ite,jts:jte) = rt_domain(did)%sice + + RT_DOMAIN(did)%initialized = .true. + end subroutine wrf_cpl_HYDRO + + + + + +!program drive rtland +! This subroutine will be used if the 4-layer Noah lsm is not used. + subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) +! input: z1,v1,kk1,z,ix,jx,kk +! output: vout +! interpolate based on soil layer: z1 and z +! z : soil layer of output variable. +! z1: array of soil layers of input variable. + implicit none + integer:: i,j,k + integer:: kk1, ix,jx,kk, vegtyp(ix,jx) + real :: z1(kk1), z(kk), v1(ix,kk1,jx),vout(ix,jx,kk) + + + do j = 1, jx + do i = 1, ix + do k = 1, kk + call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) + end do + end do + end do + end subroutine wrf2lsm + +! This subroutine will be used if the 4-layer Noah lsm is not used. + subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) +! input: z1,v1,kk1,z,ix,jx,kk +! output: vout +! interpolate based on soil layer: z1 and z +! z : soil layer of output variable. +! z1: array of soil layers of input variable. + implicit none + integer:: i,j,k + integer:: kk1, ix,jx,kk, vegtyp(ix,jx) + real :: z1(kk1), z(kk), v1(ix,jx,kk1),vout(ix,kk,jx) + + + do j = 1, jx + do i = 1, ix + do k = 1, kk + call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) + end do + end do + end do + end subroutine lsm2wrf + + subroutine interpLayer(inZ,inV,inK,outZ,outV) + implicit none + integer:: k, k1, k2 + integer :: inK + real:: inV(inK),inZ(inK) + real:: outV, outZ, w1, w2 + + if(outZ .le. inZ(1)) then + w1 = (inZ(2)-outZ)/(inZ(2)-inZ(1)) + w2 = (inZ(1)-outZ)/(inZ(2)-inZ(1)) + outV = inV(1)*w1-inV(2)*w2 + return + elseif(outZ .ge. inZ(inK)) then + w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) + w2 = (outZ-inZ(inK)) /(inZ(inK)-inZ(inK-1)) + outV = inV(inK)*w1 -inV(inK-1)* w2 + return + else + do k = 2, inK + if((inZ(k) .ge. outZ).and.(inZ(k-1) .le. outZ) ) then + k1 = k-1 + k2 = k + w1 = (outZ-inZ(k1))/(inZ(k2)-inZ(k1)) + w2 = (inZ(k2)-outZ)/(inZ(k2)-inZ(k1)) + outV = inV(k2)*w1 + inV(k1)*w2 + return + end if + end do + endif + end subroutine interpLayer + + subroutine lsm_wrf_input(did,vegtyp,soltyp,ix,jx) + implicit none + integer did, leng + parameter(leng=100) + integer :: i,j, nn, ix,jx + integer, dimension(ix,jx) :: soltyp, vegtyp + real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc + + + where(soltyp == 14) VEGTYP = 16 + where(VEGTYP == 16 ) soltyp = 14 + + RT_DOMAIN(did)%VEGTYP = vegtyp + +! input OV_ROUGH from OVROUGH.TBL +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + + open(71,file="HYDRO.TBL", form="formatted") +!read OV_ROUGH first + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do +!read parameter for LKSAT + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(71) + +#ifdef MPP_LAND + endif + call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) + call mpp_land_bcast_real(leng,xdum1) + call mpp_land_bcast_real(leng,MAXSMC) + call mpp_land_bcast_real(leng,refsmc) + call mpp_land_bcast_real(leng,wltsmc) +#endif + + rt_domain(did)%lksat = 0.0 + do j = 1, RT_DOMAIN(did)%jx + do i = 1, RT_DOMAIN(did)%ix + rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 + IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN ! urban + rt_domain(did)%SMCMAX1(i,j) = 0.45 + rt_domain(did)%SMCREF1(i,j) = 0.42 + rt_domain(did)%SMCWLT1(i,j) = 0.40 + else + rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) + rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) + rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) + ENDIF + end do + end do + + + end subroutine lsm_wrf_input + + subroutine checkSoil(did) + implicit none + integer :: did + where(rt_domain(did)%smc(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16 + where(rt_domain(did)%sh2ox(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16 + where(rt_domain(did)%smc(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16 + where(rt_domain(did)%sh2ox(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16 + end subroutine checkSoil + +end module module_wrf_HYDRO diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/wrf_drv_HYDRO.F.svn-base b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/wrf_drv_HYDRO.F.svn-base new file mode 100644 index 00000000..70939c26 --- /dev/null +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/wrf_drv_HYDRO.F.svn-base @@ -0,0 +1,31 @@ +!2345678 + subroutine wrf_drv_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) + use module_wrf_HYDRO, only: wrf_cpl_HYDRO + USE module_domain, ONLY : domain + implicit none + integer:: its,ite,jts,jte + real :: HYDRO_dt + TYPE ( domain ), INTENT(INOUT) :: grid +! return + + if(grid%num_nests .lt. 1) then + + call wrf_cpl_HYDRO(HYDRO_dt, grid,its,ite,jts,jte) + + endif + end subroutine wrf_drv_HYDRO + + + subroutine wrf_drv_HYDRO_ini(grid,its,ite,jts,jte) + use module_wrf_HYDRO, only: wrf_cpl_HYDRO + USE module_domain, ONLY : domain + implicit none + integer:: its,ite,jts,jte + TYPE ( domain ), INTENT(INOUT) :: grid + + if(grid%num_nests .lt. 1) then +! call wrf_cpl_HYDRO_ini(grid,its,ite,jts,jte) + endif + + end subroutine wrf_drv_HYDRO_ini + diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F index d238acaa..700ca2a1 100644 --- a/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F +++ b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F @@ -20,6 +20,11 @@ module module_WRF_HYDRO !yw added for check soil moisture and soiltype integer :: checkSOIL_flag +! +! added to consider the adaptive time step from WRF model. + real :: dtrt0 + integer :: mm0 + @@ -107,14 +112,29 @@ subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19) nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19) - endif - nlst_rt(did)%dt = HYDRO_dt + if(nlst_rt(did)%dtrt .lt. HYDRO_dt) then + nlst_rt(did)%dtrt = HYDRO_dt + mm0 = 1 + else + mm = HYDRO_dt/nlst_rt(did)%dtrt + if(mm*nlst_rt(did)%dtrt .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm + mm0 = mm + endif + dtrt0 = nlst_rt(did)%dtrt + endif - - mm = HYDRO_dt/nlst_rt(did)%dtrt - if(mm*nlst_rt(did)%dtrt .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm + if((mm0*nlst_rt(did)%dtrt) .ne. HYDRO_dt) then ! WRF model time step changed. + if(dtrt0 .lt. HYDRO_dt) then + nlst_rt(did)%dtrt = HYDRO_dt + mm0 = 1 + else + mm = HYDRO_dt/dtrt0 + if(mm*dtrt0 .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm + mm0 = mm + endif + endif #ifdef HYDRO_D write(6,*) "mm, nlst_rt(did)%dt = ",mm, nlst_rt(did)%dt diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/all-wcprops b/wrfv2_fire/hydro/Data_Rec/.svn/all-wcprops new file mode 100644 index 00000000..c89eceae --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/.svn/all-wcprops @@ -0,0 +1,47 @@ +K 25 +svn:wc:ra_dav:version-url +V 61 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec +END +rt_include.inc +K 25 +svn:wc:ra_dav:version-url +V 76 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/rt_include.inc +END +module_GW_baseflow_data.F +K 25 +svn:wc:ra_dav:version-url +V 87 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/module_GW_baseflow_data.F +END +namelist.inc +K 25 +svn:wc:ra_dav:version-url +V 74 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/namelist.inc +END +module_namelist.F +K 25 +svn:wc:ra_dav:version-url +V 79 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/module_namelist.F +END +module_RT_data.F +K 25 +svn:wc:ra_dav:version-url +V 78 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/module_RT_data.F +END +gw_field_include.inc +K 25 +svn:wc:ra_dav:version-url +V 82 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/gw_field_include.inc +END +Makefile +K 25 +svn:wc:ra_dav:version-url +V 70 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/Makefile +END diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/entries b/wrfv2_fire/hydro/Data_Rec/.svn/entries new file mode 100644 index 00000000..d0ea24bc --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/.svn/entries @@ -0,0 +1,266 @@ +10 + +dir +9105 +https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec +https://kkeene@svn-wrf-model.cgd.ucar.edu + + + +2014-12-12T18:07:14.337132Z +7861 +weiyu@ucar.edu + + + + + + + + + + + + + + +b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d + +rt_include.inc +file + + + + +2016-02-11T20:37:50.204451Z +087b67574a7caabe012a182d53d7270d +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +9622 + +module_GW_baseflow_data.F +file + + + + +2016-02-11T20:37:50.205460Z +db442816e357cf353326bceafc35ce7b +2012-12-07T20:01:45.900797Z +6094 +gill + + + + + + + + + + + + + + + + + + + + + +213 + +namelist.inc +file + + + + +2016-02-11T20:37:50.206409Z +03b4ff65d943316bc221efa52fe15135 +2014-12-12T18:07:14.337132Z +7861 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +1447 + +module_namelist.F +file + + + + +2016-02-11T20:37:50.207508Z +d31143270f44e10a00de79054d0f66cf +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +6421 + +module_RT_data.F +file + + + + +2016-02-11T20:37:50.208511Z +114f65d6653c6fd42aae69007ff9f955 +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +250 + +gw_field_include.inc +file + + + + +2016-02-11T20:37:50.209358Z +d134109b5ab189ab9ca998823dc6c577 +2012-12-07T20:01:45.900797Z +6094 +gill + + + + + + + + + + + + + + + + + + + + + +817 + +Makefile +file + + + + +2016-02-11T20:37:50.203321Z +85c9c22506fa9f10e82cc612f727766c +2012-12-07T20:01:45.900797Z +6094 +gill + + + + + + + + + + + + + + + + + + + + + +413 + diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/Makefile.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/Makefile.svn-base new file mode 100644 index 00000000..398ba2fe --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/Makefile.svn-base @@ -0,0 +1,28 @@ +# Makefile +# +.SUFFIXES: +.SUFFIXES: .o .F + +include ../macros + +OBJS = \ + module_namelist.o \ + module_RT_data.o \ + module_GW_baseflow_data.o + +all: $(OBJS) + +.F.o: + @echo "" + $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f + $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I../mod $(*).f + $(RMD) $(*).f + @echo "" + ar -r ../lib/libHYDRO.a $(@) + cp *.mod ../mod + +# Dependencies: +# + +clean: + rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/gw_field_include.inc.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/gw_field_include.inc.svn-base new file mode 100644 index 00000000..99c79886 --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/gw_field_include.inc.svn-base @@ -0,0 +1,26 @@ + + type gw_field + integer :: ix, jx + integer :: allo_status = -99 + + real :: dx, dt + + integer, allocatable, dimension(:,:) :: ltype ! land-sfc type + real, allocatable, dimension(:,:) :: & + elev, & ! elev/bathymetry of sfc rel to sl (m) + bot, & ! elev. aquifer bottom rel to sl (m) + hycond, & ! hydraulic conductivity (m/s per m/m) + poros, & ! porosity (m3/m3) + compres, & ! compressibility (1/Pa) + ho ! head at start of timestep (m) + + real, allocatable, dimension(:,:) :: & + h, & ! head, after ghmcompute (m) + convgw ! convergence due to gw flow (m/s) + + real :: ebot, eocn + integer ::istep = 0 + + + end type gw_field + diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_GW_baseflow_data.F.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_GW_baseflow_data.F.svn-base new file mode 100644 index 00000000..4b171683 --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_GW_baseflow_data.F.svn-base @@ -0,0 +1,9 @@ +Module module_GW_baseflow_data + IMPLICIT NONE + INTEGER, PARAMETER :: max_domain=5 + +#include "gw_field_include.inc" + type (gw_field) :: gw2d(max_domain) + save gw2d + +end module module_GW_baseflow_data diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_RT_data.F.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_RT_data.F.svn-base new file mode 100644 index 00000000..2fd80414 --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_RT_data.F.svn-base @@ -0,0 +1,10 @@ +Module module_RT_data + IMPLICIT NONE + INTEGER, PARAMETER :: max_domain=5 + +! define Routing data +#include "rt_include.inc" + TYPE ( RT_FIELD ), DIMENSION (max_domain) :: RT_DOMAIN + save RT_DOMAIN + integer :: cur_did +end module module_RT_data diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_namelist.F.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_namelist.F.svn-base new file mode 100644 index 00000000..936b7ba6 --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_namelist.F.svn-base @@ -0,0 +1,203 @@ +Module module_namelist + +#ifdef MPP_LAND + USE module_mpp_land +#endif + + IMPLICIT NONE + INTEGER, PARAMETER :: max_domain=5 + +#include "namelist.inc" + TYPE(namelist_rt_field) , dimension(max_domain) :: nlst_rt + save nlst_rt + +CONTAINS + + subroutine read_rt_nlst(nlst) + implicit none + + TYPE(namelist_rt_field) nlst + + integer ierr + integer:: RT_OPTION, CHANRTSWCRT, channel_option, & + SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, & + GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & + sys_cpl, rst_typ + real:: DTRT,dxrt + character(len=256) :: route_topo_f="" + character(len=256) :: route_chan_f="" + character(len=256) :: route_link_f="" + character(len=256) :: route_lake_f="" + character(len=256) :: route_direction_f="" + character(len=256) :: route_order_f="" + character(len=256) :: gwbasmskfil ="" + character(len=256) :: gwstrmfil ="" + character(len=256) :: geo_finegrid_flnm ="" + integer :: SOLVEG_INITSWC + real out_dt, rst_dt + character(len=256) :: RESTART_FILE = "" + logical :: history_output + integer :: split_output_count, order_to_write + integer :: igrid + character(len=256) :: geo_static_flnm = "" + integer :: DEEPGWSPIN + + integer :: HIRES_OUT + integer :: i + +!!! add the following two dummy variables + integer :: NSOIL + real :: ZSOIL8(8) + + namelist /HYDRO_nlist/ NSOIL, ZSOIL8,& + RESTART_FILE,HISTORY_OUTPUT,SPLIT_OUTPUT_COUNT,IGRID,& + geo_static_flnm, & + out_dt, rst_dt, & + HIRES_OUT, & + DEEPGWSPIN, SOLVEG_INITSWC, & + RT_OPTION, CHANRTSWCRT, channel_option, & + SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, dtrt,dxrt,& + GWBASESWCRT,route_topo_f,route_chan_f,route_link_f,route_lake_f, & + route_direction_f,route_order_f,gwbasmskfil, geo_finegrid_flnm,& + gwstrmfil,GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, sys_cpl, & + order_to_write , rst_typ +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif + open(30, file="hydro.namelist", form="FORMATTED") + read(30, HYDRO_nlist, iostat=ierr) + close(30) +#ifdef MPP_LAND + endif +#endif + + +#ifdef MPP_LAND +! call mpp_land_bcast_real1(DT) + call mpp_land_bcast_int1(SPLIT_OUTPUT_COUNT) + call mpp_land_bcast_int1(IGRID) + call mpp_land_bcast_real1(out_dt) + call mpp_land_bcast_real1(rst_dt) + call mpp_land_bcast_int1(HIRES_OUT) + call mpp_land_bcast_int1(DEEPGWSPIN) + call mpp_land_bcast_int1(SOLVEG_INITSWC) +#endif + + +#ifdef MPP_LAND + call mpp_land_bcast_int1(nlst%NSOIL) + do i = 1, nlst%NSOIL + call mpp_land_bcast_real1(nlst%ZSOIL8(i)) + end do +#ifdef HYDRO_D + write(6,*) "nlst%NSOIL = ", nlst%NSOIL + write(6,*) "nlst%ZSOIL8 = ",nlst%ZSOIL8 +#endif +#endif + +! nlst%DT = DT + nlst%RESTART_FILE = RESTART_FILE + nlst%HISTORY_OUTPUT = HISTORY_OUTPUT + nlst%SPLIT_OUTPUT_COUNT = SPLIT_OUTPUT_COUNT + nlst%IGRID = IGRID + nlst%geo_static_flnm = geo_static_flnm + nlst%out_dt = out_dt + nlst%rst_dt = rst_dt + nlst%HIRES_OUT = HIRES_OUT + nlst%DEEPGWSPIN = DEEPGWSPIN + nlst%SOLVEG_INITSWC = SOLVEG_INITSWC + + write(nlst%hgrid,'(I1)') igrid + + + if(RESTART_FILE .eq. "") rst_typ = 0 + +#ifdef MPP_LAND + !bcast namelist variable. + call mpp_land_bcast_int1(rt_option) + call mpp_land_bcast_int1(CHANRTSWCRT) + call mpp_land_bcast_int1(channel_option) + call mpp_land_bcast_int1(SUBRTSWCRT) + call mpp_land_bcast_int1(OVRTSWCRT) + call mpp_land_bcast_int1(AGGFACTRT) + call mpp_land_bcast_real1(DTRT) + call mpp_land_bcast_real1(DXRT) + call mpp_land_bcast_int1(GWBASESWCRT) + call mpp_land_bcast_int1(GW_RESTART) + call mpp_land_bcast_int1(RSTRT_SWC ) + call mpp_land_bcast_int1(TERADJ_SOLAR) + call mpp_land_bcast_int1(sys_cpl) + call mpp_land_bcast_int1(rst_typ) + call mpp_land_bcast_int1(order_to_write) +#endif + nlst%RT_OPTION = RT_OPTION + nlst%CHANRTSWCRT = CHANRTSWCRT + nlst%GW_RESTART = GW_RESTART + nlst%RSTRT_SWC = RSTRT_SWC + nlst%channel_option = channel_option + nlst%DTRT = DTRT + nlst%DTCT = DTRT + nlst%SUBRTSWCRT = SUBRTSWCRT + nlst%OVRTSWCRT = OVRTSWCRT + nlst%dxrt0 = dxrt + nlst%AGGFACTRT = AGGFACTRT + nlst%GWBASESWCRT = GWBASESWCRT + nlst%TERADJ_SOLAR = TERADJ_SOLAR + nlst%sys_cpl = sys_cpl + nlst%rst_typ = rst_typ + nlst%order_to_write = order_to_write +! files + nlst%route_topo_f = route_topo_f + nlst%route_chan_f = route_chan_f + nlst%route_link_f = route_link_f + nlst%route_lake_f =route_lake_f + nlst%route_direction_f = route_direction_f + nlst%route_order_f = route_order_f + nlst%gwbasmskfil = gwbasmskfil + nlst%gwstrmfil = gwstrmfil + nlst%geo_finegrid_flnm = geo_finegrid_flnm + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif +#ifdef HYDRO_D + write(6,*) "output of the namelist file " + + write(6,*) " nlst%RT_OPTION ", RT_OPTION + write(6,*) " nlst%CHANRTSWCRT ", CHANRTSWCRT + write(6,*) " nlst%GW_RESTART ", GW_RESTART + write(6,*) " nlst%RSTRT_SWC ", RSTRT_SWC + write(6,*) " nlst%channel_option ", channel_option + write(6,*) " nlst%DTRT ", DTRT + write(6,*) " nlst%SUBRTSWCRT ", SUBRTSWCRT + write(6,*) " nlst%OVRTSWCRT ", OVRTSWCRT + write(6,*) " nlst%dxrt0 ", dxrt + write(6,*) " nlst%AGGFACTRT ", AGGFACTRT + write(6,*) " nlst%GWBASESWCRT ", GWBASESWCRT + write(6,*) " nlst%TERADJ_SOLAR ", TERADJ_SOLAR + write(6,*) " nlst%sys_cpl ", sys_cpl + write(6,*) " nlst%rst_typ ", rst_typ + write(6,*) " nlst%order_to_write ", order_to_write + write(6,*) " nlst%route_topo_f ", route_topo_f + write(6,*) " nlst%route_chan_f ", route_chan_f + write(6,*) " nlst%route_link_f ", route_link_f + write(6,*) " nlst%route_lake_f ",route_lake_f + write(6,*) " nlst%route_direction_f ", route_direction_f + write(6,*) " nlst%route_order_f ", route_order_f + write(6,*) " nlst%gwbasmskfil ", gwbasmskfil + write(6,*) " nlst%gwstrmfil ", gwstrmfil + write(6,*) " nlst%geo_finegrid_flnm ", geo_finegrid_flnm +#endif +#ifdef MPP_LAND + endif +#endif + +#ifdef MPP_LAND + !bcast other variable. + call mpp_land_bcast_real1(nlst%dt) +#endif + return + end subroutine read_rt_nlst + + +end module module_namelist diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/namelist.inc.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/namelist.inc.svn-base new file mode 100644 index 00000000..79a5ab7d --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/namelist.inc.svn-base @@ -0,0 +1,39 @@ + TYPE namelist_rt_field + + integer :: nsoil, SOLVEG_INITSWC + real,allocatable,dimension(:) :: ZSOIL8 + real out_dt, rst_dt, dt + integer :: START_YEAR, START_MONTH, START_DAY, START_HOUR, START_MIN + character(len=256) :: restart_file = "" + logical :: history_output + integer :: split_output_count + integer :: igrid + character(len=256) :: geo_static_flnm = "" + integer :: DEEPGWSPIN + integer :: HIRES_OUT, order_to_write, rst_typ + +! additional character + character :: hgrid + character(len=19) :: olddate="123456" + character(len=19) :: startdate="123456" + character(len=19) :: sincedate="123456" + + + + integer:: RT_OPTION, CHANRTSWCRT, channel_option, & + SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, & + GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & + sys_cpl + real:: DTRT,dxrt0, DTCT + character(len=256) :: route_topo_f="" + character(len=256) :: route_chan_f="" + character(len=256) :: route_link_f="" + character(len=256) :: route_lake_f="" + character(len=256) :: route_direction_f="" + character(len=256) :: route_order_f="" + character(len=256) :: gwbasmskfil ="" + character(len=256) :: gwstrmfil ="" + character(len=256) :: geo_finegrid_flnm ="" + + END TYPE namelist_rt_field + diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/rt_include.inc.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/rt_include.inc.svn-base new file mode 100644 index 00000000..1557bc00 --- /dev/null +++ b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/rt_include.inc.svn-base @@ -0,0 +1,178 @@ + TYPE RT_FIELD + INTEGER :: IX, JX + logical initialized + REAL :: DX,GRDAREART,SUBFLORT,WATAVAILRT,QSUBDRYRT + REAL :: SFHEAD1RT,INFXS1RT,QSTRMVOLTRT,QBDRYTRT,SFHEADRT,ETPND1,INFXSRTOT + REAL :: LAKE_INFLOTRT,accsuminfxs,diffsuminfxs,RETDEPFRAC + REAL :: VERTKSAT,l3temp,l4temp,l3moist,l4moist,RNOF1TOT,RNOF2TOT,RNOF3TOT + INTEGER :: IXRT,JXRT,vegct + INTEGER :: AGGFACYRT, AGGFACXRT, KRTel_option, FORC_TYP + INTEGER :: SATLYRCHKRT,DT_FRACRT + INTEGER :: LAKE_CT, STRM_CT + REAL :: RETDEP_CHAN ! Channel retention depth + INTEGER :: NLINKS !maximum number of unique links in channel + INTEGER :: GNLINKS !maximum number of unique links in channel for parallel computation + INTEGER :: NLAKES !number of lakes + INTEGER :: MAXORDER !maximum stream order + integer :: timestep_flag ! 1 cold start run else continue run + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR ROUTING + INTEGER, allocatable, DIMENSION(:,:) :: CH_NETRT !-- keeps track of the 0-1 channel network + INTEGER, allocatable, DIMENSION(:,:) :: CH_NETLNK, GCH_NETLNK !-- assigns a unique value to each channel gridpoint, called links + REAL, allocatable, DIMENSION(:,:) :: LATVAL,LONVAL !-- lat lon + REAL, allocatable, DIMENSION(:,:) :: TERRAIN + REAL, allocatable, DIMENSION(:) :: CHLAT,CHLON ! channel lat and lon + ! INTEGER, allocatable, DIMENSION(:,:) :: LAKE_MSKRT, BASIN_MSK,LAK_1K + INTEGER, allocatable, DIMENSION(:,:) :: LAKE_MSKRT, LAK_1K + INTEGER, allocatable, DIMENSION(:,:) :: g_LAK_1K + ! REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT, QSUBBDRYTRT + REAL :: QSUBBDRYTRT + REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT + REAL, allocatable, DIMENSION(:,:,:) :: SO8RT + INTEGER, allocatable, DIMENSION(:,:,:) :: SO8RT_D, SO8LD_D + REAL, allocatable, DIMENSION(:,:) :: SO8LD_Vmax + REAL Vmax + REAL, allocatable, DIMENSION(:,:) :: SFCHEADRT,INFXSRT,LKSAT,LKSATRT + REAL, allocatable, DIMENSION(:,:) :: SFCHEADSUBRT,INFXSUBRT,LKSATFAC + REAL, allocatable, DIMENSION(:,:) :: QSUBRT,ZWATTABLRT,QSUBBDRYRT,SOLDEPRT + REAL, allocatable, DIMENSION(:,:) :: SUB_RESID + REAL, allocatable, DIMENSION(:,:) :: q_sfcflx_x,q_sfcflx_y + INTEGER, allocatable, DIMENSION(:) :: map_l2g, map_g2l + +! temp arrary cwatavail + real, allocatable, DIMENSION(:,:,:) :: SMCREFRT +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR GW/Baseflow + INTEGER :: numbasns + INTEGER, allocatable, DIMENSION(:,:) :: GWSUBBASMSK !GW basin mask grid + REAL, allocatable, DIMENSION(:,:) :: qinflowbase !strm inflow/baseflow from GW + REAL, allocatable, DIMENSION(:,:) :: SOLDRAIN !time-step drainage + INTEGER, allocatable, DIMENSION(:,:) :: gw_strm_msk !GW basin mask grid + REAL, allocatable, DIMENSION(:) :: z_gwsubbas !depth in GW bucket + REAL, allocatable, DIMENSION(:) :: qin_gwsubbas !flow to GW bucket + REAL, allocatable, DIMENSION(:) :: qout_gwsubbas!flow from GW bucket + REAL, allocatable, DIMENSION(:) :: gwbas_pix_ct !ct of strm pixels in + REAL, allocatable, DIMENSION(:) :: basns_area !basin area + REAL, allocatable, DIMENSION(:) :: node_area !nodes area + + REAL, allocatable, DIMENSION(:) :: z_q_bas_parm !GW bucket disch params + INTEGER, allocatable, DIMENSION(:) :: ct2_bas !ct of lnd pixels in basn + REAL, allocatable, DIMENSION(:) :: bas_pcp !sub-basin avg'd pcp + INTEGER :: bas,bas_id + CHARACTER(len=19) :: header + CHARACTER(len=1) :: jnk + REAL, allocatable, DIMENSION(:) :: gw_buck_coeff,gw_buck_exp,z_max !GW bucket parameters +!DJG Switch for Deep Sat GW Init: + INTEGER :: DEEPGWSPIN !Switch to setup deep GW spinp + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG,DNY VARIABLES FOR CHANNEL ROUTING +!-- channel params + INTEGER, allocatable, DIMENSION(:) :: LINK !channel link + INTEGER, allocatable, DIMENSION(:) :: TO_NODE !link's to node + INTEGER, allocatable, DIMENSION(:) :: FROM_NODE !link's from node + INTEGER, allocatable, DIMENSION(:) :: ORDER !link's order + INTEGER, allocatable, DIMENSION(:) :: STRMFRXSTPTS !frxst point flag + INTEGER, allocatable, DIMENSION(:) :: TYPEL !type of link Muskingum: 0 strm 1 lake + !-- Diffusion: 0 edge or pour; 1 interior; 2 lake + INTEGER, allocatable, DIMENSION(:) :: TYPEN !type of link 0 strm 1 lake + REAL, allocatable, DIMENSION(:) :: QLAKEI !lake inflow in difussion scheme + REAL, allocatable, DIMENSION(:) :: QLAKEO !lake outflow in difussion scheme + INTEGER, allocatable, DIMENSION(:) :: LAKENODE !which nodes flow into which lakes + REAL, allocatable, DIMENSION(:) :: CVOL ! channel volume + INTEGER, allocatable, DIMENSION(:,:) :: pnode !parent nodes : start from 2 + integer :: maxv_p ! array size for second column of the pnode + + + REAL, allocatable, DIMENSION(:) :: MUSK, MUSX !muskingum params + REAL, allocatable, DIMENSION(:) :: CHANLEN !link length + REAL, allocatable, DIMENSION(:) :: MannN !mannings N + REAL, allocatable, DIMENSION(:) :: So !link slope + REAL, allocatable, DIMENSION(:) :: ChSSlp, Bw !trapezoid link params + REAL, allocatable, DIMENSION(:,:) :: QLINK !flow in link + REAL, allocatable, DIMENSION(:) :: HLINK !head in link + REAL, allocatable, DIMENSION(:) :: ZELEV !elevation of nodes for channel + INTEGER, allocatable, DIMENSION(:) :: CHANXI,CHANYJ !map chan to fine grid + REAL, DIMENSION(50) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann !Channel parms from table + + REAL, allocatable, DIMENSION(:) :: RESHT !reservoir height +!-- lake params + REAL, allocatable, DIMENSION(:) :: HRZAREA !horizontal extent of lake, km^2 + REAL, allocatable, DIMENSION(:) :: WEIRL !overtop weir length (m) + REAL, allocatable, DIMENSION(:) :: ORIFICEC !coefficient of orifice + REAL, allocatable, DIMENSION(:) :: ORIFICEA !orifice opening area (m^2) + REAL, allocatable, DIMENSION(:) :: ORIFICEE !orifice elevation (m) + REAL, allocatable, DIMENSION(:) :: LATLAKE, LONLAKE,ELEVLAKE ! lake info +#ifdef MPP_LAND + INTEGER, allocatable, DIMENSION(:) :: lake_index,nlinks_index + INTEGER, allocatable, DIMENSION(:,:) :: Link_location + integer mpp_nlinks, yw_mpp_nlinks +#endif + + REAL, allocatable, DIMENSION(:,:) :: OVROUGHRTFAC,RETDEPRTFAC + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR AGGREGATION/DISAGGREGATION + REAL, allocatable, DIMENSION(:,:,:) :: SMCRT,SMCMAXRT,SMCWLTRT,SH2OWGT,SICE + REAL, allocatable, DIMENSION(:,:) :: INFXSAGGRT + REAL, allocatable, DIMENSION(:,:) :: DHRT,QSTRMVOLRT,QBDRYRT,LAKE_INFLORT + REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_TS,LAKE_INFLORT_TS + REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_DUM,LAKE_INFLORT_DUM + REAL, allocatable, DIMENSION(:,:) :: INFXSWGT, ywtmp + REAL, allocatable, DIMENSION(:) :: SMCAGGRT,STCAGGRT,SH2OAGGRT + REAL :: INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT + REAL, allocatable, DIMENSION(:,:,:) :: dist ! 8 direction of distance +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!DJG VARIABLES FOR ONLINE MASS BALANCE CALCULATION + REAL(KIND=8) :: DCMC,DSWE,DACRAIN,DSFCEVP,DCANEVP,DEDIR,DETT,DEPND,DESNO,DSFCRNFF + REAL(KIND=8) :: DSMCTOT,RESID,SUMEVP,DUG1RNFF,DUG2RNFF,SMCTOT1,SMCTOT2,DETP + REAL(KIND=8) :: suminfxsrt,suminfxs1,suminfxs2,dprcp_ts + REAL(KIND=8) :: CHAN_IN1,CHAN_IN2,LAKE_IN1,LAKE_IN2,zzz, CHAN_STOR,CHAN_OUT + REAL(KIND=8) :: CHAN_INV,LAKE_INV !-channel and lake inflow in volume + REAL(KIND=8) :: DQBDRY + REAL :: QSTRMVOLTRT1,LAKE_INFLOTRT1,QBDRYTOT1,LSMVOL + REAL(KIND=8), allocatable, DIMENSION(:) :: DSMC,SMCRTCHK + REAL(KIND=8), allocatable, DIMENSION(:,:) :: CMC_INIT,SWE_INIT +! REAL(KIND=8), allocatable, DIMENSION(:,:,:) :: SMC_INIT + REAL(KIND=8) :: SMC_INIT,SMC_FINAL,resid2,resid1 + REAL(KIND=8) :: chcksm1,chcksm2,CMC1,CMC2,prcp_in,ETATOT,dsmctot_av + + integer :: g_ixrt,g_jxrt,flag + integer :: allo_status = -99 + integer iywtmp + + +!-- lake params + REAL, allocatable, DIMENSION(:) :: LAKEMAXH !maximum depth (m) + REAL, allocatable, DIMENSION(:) :: WEIRC !coeff of overtop weir + + + + +!DJG Modified namelist for routing and agg. variables + real Z_tmp + + !!! define land surface grid variables + REAL, allocatable, DIMENSION(:,:,:) :: SMC,STC,SH2OX + REAL, allocatable, DIMENSION(:,:) :: SMCMAX1,SMCWLT1,SMCREF1 + INTEGER, allocatable, DIMENSION(:,:) :: VEGTYP + REAL, allocatable, DIMENSION(:) :: SLDPTH + +!!! define constant/parameter + real :: ov_rough(50), ZSOIL(100) +! out_counts: couput counts for current run. +! his_out_counts: used for channel routing output and special for restart. +! his_out_counts = previous run + out_counts + integer :: out_counts, rst_counts, his_out_counts + + REAL, allocatable, DIMENSION(:,:) :: lat_lsm, lon_lsm + REAL, allocatable, DIMENSION(:,:,:) :: dist_lsm + + END TYPE RT_FIELD diff --git a/wrfv2_fire/hydro/Data_Rec/module_RT_data.F b/wrfv2_fire/hydro/Data_Rec/module_RT_data.F index 951e33de..2fd80414 100644 --- a/wrfv2_fire/hydro/Data_Rec/module_RT_data.F +++ b/wrfv2_fire/hydro/Data_Rec/module_RT_data.F @@ -6,5 +6,5 @@ Module module_RT_data #include "rt_include.inc" TYPE ( RT_FIELD ), DIMENSION (max_domain) :: RT_DOMAIN save RT_DOMAIN - + integer :: cur_did end module module_RT_data diff --git a/wrfv2_fire/hydro/Data_Rec/module_namelist.F b/wrfv2_fire/hydro/Data_Rec/module_namelist.F index 806b2831..936b7ba6 100644 --- a/wrfv2_fire/hydro/Data_Rec/module_namelist.F +++ b/wrfv2_fire/hydro/Data_Rec/module_namelist.F @@ -110,7 +110,7 @@ subroutine read_rt_nlst(nlst) write(nlst%hgrid,'(I1)') igrid - + if(RESTART_FILE .eq. "") rst_typ = 0 #ifdef MPP_LAND !bcast namelist variable. @@ -136,6 +136,7 @@ subroutine read_rt_nlst(nlst) nlst%RSTRT_SWC = RSTRT_SWC nlst%channel_option = channel_option nlst%DTRT = DTRT + nlst%DTCT = DTRT nlst%SUBRTSWCRT = SUBRTSWCRT nlst%OVRTSWCRT = OVRTSWCRT nlst%dxrt0 = dxrt diff --git a/wrfv2_fire/hydro/Data_Rec/namelist.inc b/wrfv2_fire/hydro/Data_Rec/namelist.inc index 6f81617c..79a5ab7d 100644 --- a/wrfv2_fire/hydro/Data_Rec/namelist.inc +++ b/wrfv2_fire/hydro/Data_Rec/namelist.inc @@ -16,6 +16,7 @@ character :: hgrid character(len=19) :: olddate="123456" character(len=19) :: startdate="123456" + character(len=19) :: sincedate="123456" @@ -23,7 +24,7 @@ SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, & GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & sys_cpl - real:: DTRT,dxrt0 + real:: DTRT,dxrt0, DTCT character(len=256) :: route_topo_f="" character(len=256) :: route_chan_f="" character(len=256) :: route_link_f="" diff --git a/wrfv2_fire/hydro/Data_Rec/rt_include.inc b/wrfv2_fire/hydro/Data_Rec/rt_include.inc index 0441a485..1557bc00 100644 --- a/wrfv2_fire/hydro/Data_Rec/rt_include.inc +++ b/wrfv2_fire/hydro/Data_Rec/rt_include.inc @@ -1,7 +1,7 @@ TYPE RT_FIELD INTEGER :: IX, JX logical initialized - REAL :: DX,GRDAREART,SUBFLORT,WATAVAILRT,QSUBDRYRT,QSUBBDRYTRT + REAL :: DX,GRDAREART,SUBFLORT,WATAVAILRT,QSUBDRYRT REAL :: SFHEAD1RT,INFXS1RT,QSTRMVOLTRT,QBDRYTRT,SFHEADRT,ETPND1,INFXSRTOT REAL :: LAKE_INFLOTRT,accsuminfxs,diffsuminfxs,RETDEPFRAC REAL :: VERTKSAT,l3temp,l4temp,l3moist,l4moist,RNOF1TOT,RNOF2TOT,RNOF3TOT @@ -11,6 +11,7 @@ INTEGER :: LAKE_CT, STRM_CT REAL :: RETDEP_CHAN ! Channel retention depth INTEGER :: NLINKS !maximum number of unique links in channel + INTEGER :: GNLINKS !maximum number of unique links in channel for parallel computation INTEGER :: NLAKES !number of lakes INTEGER :: MAXORDER !maximum stream order integer :: timestep_flag ! 1 cold start run else continue run @@ -19,23 +20,29 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !DJG VARIABLES FOR ROUTING INTEGER, allocatable, DIMENSION(:,:) :: CH_NETRT !-- keeps track of the 0-1 channel network - INTEGER, allocatable, DIMENSION(:,:) :: CH_NETLNK !-- assigns a unique value to each channel gridpoint, called links + INTEGER, allocatable, DIMENSION(:,:) :: CH_NETLNK, GCH_NETLNK !-- assigns a unique value to each channel gridpoint, called links REAL, allocatable, DIMENSION(:,:) :: LATVAL,LONVAL !-- lat lon REAL, allocatable, DIMENSION(:,:) :: TERRAIN REAL, allocatable, DIMENSION(:) :: CHLAT,CHLON ! channel lat and lon ! INTEGER, allocatable, DIMENSION(:,:) :: LAKE_MSKRT, BASIN_MSK,LAK_1K INTEGER, allocatable, DIMENSION(:,:) :: LAKE_MSKRT, LAK_1K INTEGER, allocatable, DIMENSION(:,:) :: g_LAK_1K + ! REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT, QSUBBDRYTRT + REAL :: QSUBBDRYTRT REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT REAL, allocatable, DIMENSION(:,:,:) :: SO8RT INTEGER, allocatable, DIMENSION(:,:,:) :: SO8RT_D, SO8LD_D REAL, allocatable, DIMENSION(:,:) :: SO8LD_Vmax REAL Vmax - REAL, allocatable, DIMENSION(:,:) :: SFCHEADRT,INFXSRT,LKSAT,LKSATRT + REAL, allocatable, DIMENSION(:,:) :: SFCHEADRT,INFXSRT,LKSAT,LKSATRT REAL, allocatable, DIMENSION(:,:) :: SFCHEADSUBRT,INFXSUBRT,LKSATFAC REAL, allocatable, DIMENSION(:,:) :: QSUBRT,ZWATTABLRT,QSUBBDRYRT,SOLDEPRT REAL, allocatable, DIMENSION(:,:) :: SUB_RESID REAL, allocatable, DIMENSION(:,:) :: q_sfcflx_x,q_sfcflx_y + INTEGER, allocatable, DIMENSION(:) :: map_l2g, map_g2l + +! temp arrary cwatavail + real, allocatable, DIMENSION(:,:,:) :: SMCREFRT !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !DJG VARIABLES FOR GW/Baseflow INTEGER :: numbasns @@ -75,6 +82,8 @@ REAL, allocatable, DIMENSION(:) :: QLAKEO !lake outflow in difussion scheme INTEGER, allocatable, DIMENSION(:) :: LAKENODE !which nodes flow into which lakes REAL, allocatable, DIMENSION(:) :: CVOL ! channel volume + INTEGER, allocatable, DIMENSION(:,:) :: pnode !parent nodes : start from 2 + integer :: maxv_p ! array size for second column of the pnode REAL, allocatable, DIMENSION(:) :: MUSK, MUSX !muskingum params @@ -107,11 +116,11 @@ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !DJG VARIABLES FOR AGGREGATION/DISAGGREGATION - REAL, allocatable, DIMENSION(:,:,:) :: SMCRT,SMCMAXRT,SMCWLTRT,SH2OWGT + REAL, allocatable, DIMENSION(:,:,:) :: SMCRT,SMCMAXRT,SMCWLTRT,SH2OWGT,SICE REAL, allocatable, DIMENSION(:,:) :: INFXSAGGRT REAL, allocatable, DIMENSION(:,:) :: DHRT,QSTRMVOLRT,QBDRYRT,LAKE_INFLORT - !yw REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_TS,LAKE_INFLORT_TS -! REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_DUM,LAKE_INFLORT_DUM + REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_TS,LAKE_INFLORT_TS + REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_DUM,LAKE_INFLORT_DUM REAL, allocatable, DIMENSION(:,:) :: INFXSWGT, ywtmp REAL, allocatable, DIMENSION(:) :: SMCAGGRT,STCAGGRT,SH2OAGGRT REAL :: INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT diff --git a/wrfv2_fire/hydro/HYDRO_drv/.svn/all-wcprops b/wrfv2_fire/hydro/HYDRO_drv/.svn/all-wcprops new file mode 100644 index 00000000..c5438960 --- /dev/null +++ b/wrfv2_fire/hydro/HYDRO_drv/.svn/all-wcprops @@ -0,0 +1,17 @@ +K 25 +svn:wc:ra_dav:version-url +V 62 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/HYDRO_drv +END +module_HYDRO_drv.F +K 25 +svn:wc:ra_dav:version-url +V 81 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/HYDRO_drv/module_HYDRO_drv.F +END +Makefile +K 25 +svn:wc:ra_dav:version-url +V 71 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/HYDRO_drv/Makefile +END diff --git a/wrfv2_fire/hydro/HYDRO_drv/.svn/entries b/wrfv2_fire/hydro/HYDRO_drv/.svn/entries new file mode 100644 index 00000000..560b987c --- /dev/null +++ b/wrfv2_fire/hydro/HYDRO_drv/.svn/entries @@ -0,0 +1,96 @@ +10 + +dir +9105 +https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/HYDRO_drv +https://kkeene@svn-wrf-model.cgd.ucar.edu + + + +2015-01-23T18:49:15.035273Z +8003 +gill + + + + + + + + + + + + + + +b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d + +module_HYDRO_drv.F +file + + + + +2016-02-11T20:37:50.184698Z +71edf2c3486d61b615893a754d5d2bf1 +2015-01-23T18:49:15.035273Z +8003 +gill + + + + + + + + + + + + + + + + + + + + + +34924 + +Makefile +file + + + + +2016-02-11T20:37:50.186021Z +d3bd1628a3ed59ae7049226ed358da85 +2012-12-07T20:01:45.900797Z +6094 +gill + + + + + + + + + + + + + + + + + + + + + +609 + diff --git a/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/Makefile.svn-base b/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/Makefile.svn-base new file mode 100644 index 00000000..9a04d9e6 --- /dev/null +++ b/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/Makefile.svn-base @@ -0,0 +1,28 @@ +# Makefile +# +.SUFFIXES: +.SUFFIXES: .o .F + +include ../macros + +OBJS = \ + module_HYDRO_drv.o +all: $(OBJS) + +.F.o: + @echo "" + $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f + $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I../mod $(*).f + $(RMD) $(*).f + @echo "" + ar -r ../lib/libHYDRO.a $(@) + cp *.mod ../mod + +# +# Dependencies: +# +module_HYDRO_drv.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o ../Data_Rec/module_GW_baseflow_data.o \ + ../Routing/module_GW_baseflow.o ../Routing/module_HYDRO_utils.o ../Routing/module_HYDRO_io.o ../Routing/module_RT.o + +clean: + rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/module_HYDRO_drv.F.svn-base b/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/module_HYDRO_drv.F.svn-base new file mode 100644 index 00000000..cc0de91f --- /dev/null +++ b/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/module_HYDRO_drv.F.svn-base @@ -0,0 +1,1071 @@ +module module_HYDRO_drv +#ifdef MPP_LAND + use module_HYDRO_io, only: mpp_output_rt, mpp_output_chrt, mpp_output_lakes, mpp_output_chrtgrd + USE module_mpp_land +#else + use module_HYDRO_io, only: output_rt, output_chrt, output_lakes +#endif + use module_HYDRO_io, only: output_gw, restart_out_nc, restart_in_nc, & + get_file_dimension ,get2d_lsm_real, get2d_lsm_vegtyp, get2d_lsm_soltyp, & + output_lsm + use module_rt_data, only: rt_domain + use module_GW_baseflow_data, only: gw2d + use module_GW_baseflow, only:simp_gw_buck, gwstep, gw2d_allocate, gw2d_ini + use module_channel_routing, only: drive_channel + use module_namelist, only: nlst_rt, read_rt_nlst + use module_routing, only: getChanDim, landrt_ini + use module_HYDRO_utils +! use module_namelist + use module_lsm_forcing, only: geth_newdate + + implicit none + + contains + subroutine HYDRO_rst_out(did) + implicit none + integer:: rst_out + integer did, outflag + character(len=19) out_date + rst_out = -99 +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif + if(nlst_rt(did)%dt .gt. nlst_rt(did)%rst_dt*60) then + call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%rst_counts)) + else + call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%rst_dt*60*rt_domain(did)%rst_counts)) + endif + if ( (nlst_rt(did)%rst_dt .gt. 0) .and. (out_date(1:19) == nlst_rt(did)%olddate(1:19)) ) then + rst_out = 99 + rt_domain(did)%rst_counts = rt_domain(did)%rst_counts + 1 + endif +! restart every month automatically. + if ( (nlst_rt(did)%olddate(9:10) == "01") .and. (nlst_rt(did)%olddate(12:13) == "00") .and. & + (nlst_rt(did)%olddate(15:16) == "00").and. (nlst_rt(did)%olddate(18:19) == "00") .and. & + (nlst_rt(did)%rst_dt .le. 0) ) rst_out = 99 + +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(rst_out) +#endif + if(rst_out .gt. 0) & + call RESTART_OUT_nc(trim("HYDRO_RST."//nlst_rt(did)%olddate(1:16) & + //"_DOMAIN"//trim(nlst_rt(did)%hgrid)), did) + +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif +#ifdef HYDRO_D + write(6,*) "restartFile =", "RESTART."//nlst_rt(did)%olddate(1:16) & + //"_DOMAIN"//trim(nlst_rt(did)%hgrid) +#endif +#ifdef MPP_LAND + endif +#endif + + + end subroutine HYDRO_rst_out + + subroutine HYDRO_out(did) + implicit none + integer did, outflag, rtflag + character(len=19) out_date + integer :: Kt, ounit + +! real, dimension(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx):: soilmx_tmp, & +! runoff1x_tmp, runoff2x_tmp, runoff3x_tmp,etax_tmp, & +! EDIRX_tmp,ECX_tmp,ETTX_tmp,RCX_tmp,HX_tmp,acrain_tmp, & +! ACSNOM_tmp, esnow2d_tmp, drip2d_tmp,dewfall_tmp, fpar_tmp, & +! qfx_tmp, prcp_out_tmp, etpndx_tmp + + outflag = -99 + +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif + if(nlst_rt(did)%olddate(1:19) .eq. nlst_rt(did)%startdate(1:19) .and. rt_domain(did)%his_out_counts .eq. 0) then +#ifdef HYDRO_D + write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19), rt_domain(did)%his_out_counts +#endif + outflag = 99 + else + if(nlst_rt(did)%dt .gt. nlst_rt(did)%out_dt*60) then + call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%out_counts)) + else + call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%out_dt*60*rt_domain(did)%out_counts)) + endif + if ( out_date(1:19) == nlst_rt(did)%olddate(1:19) ) then +#ifdef HYDRO_D + write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19) +#endif + outflag = 99 + endif + endif +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(outflag) +#endif + + call HYDRO_rst_out(did) + + if (outflag .lt. 0) return + + rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1 + rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1 + + if(nlst_rt(did)%out_dt*60 .gt. nlst_rt(did)%DT) then + kt = rt_domain(did)%his_out_counts*nlst_rt(did)%out_dt*60/nlst_rt(did)%DT + else + kt = rt_domain(did)%his_out_counts + endif + + +! jump the ouput for the initial time when it has restart file from routing. + rtflag = -99 +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif + if ( (trim(nlst_rt(did)%restart_file) /= "") .and. ( nlst_rt(did)%startdate(1:19) == nlst_rt(did)%olddate(1:19) ) ) then + print*, "yyyywww restart_file = ", trim(nlst_rt(did)%restart_file) + rtflag = 1 + endif +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(rtflag) +#endif + + +!yw keep the initial time otuput for debug + if(rtflag == 1) return ! jump the initial time output for routing restart + + + + call output_lsm(trim(nlst_rt(did)%olddate(1:4)//nlst_rt(did)%olddate(6:7)//nlst_rt(did)%olddate(9:10) & + //nlst_rt(did)%olddate(12:13)//nlst_rt(did)%olddate(15:16)// & + ".LSMOUT_DOMAIN"//trim(nlst_rt(did)%hgrid)), & + did) + + + + if(nlst_rt(did)%SUBRTSWCRT .gt. 0 & + .or. nlst_rt(did)%OVRTSWCRT .gt. 0 & + .or. nlst_rt(did)%GWBASESWCRT .gt. 0 ) then + if (nlst_rt(did)%HIRES_OUT.ge.1) then + + +! goto 9991 + +#ifdef MPP_LAND + call mpp_output_rt(rt_domain(did)%g_ixrt, rt_domain(did)%g_jxrt, & +#else + call output_rt( & +#endif + nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & + RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & + nlst_rt(did)%nsoil, & +! nlst_rt(did)%startdate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,& + nlst_rt(did)%sincedate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,& + RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SMCRT,& + RT_DOMAIN(did)%SUB_RESID, & + RT_DOMAIN(did)%q_sfcflx_x,RT_DOMAIN(did)%q_sfcflx_y,& + RT_DOMAIN(did)%soxrt,RT_DOMAIN(did)%soyrt,& + RT_DOMAIN(did)%QSTRMVOLRT,RT_DOMAIN(did)%SFCHEADSUBRT, & + nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT,& + RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL,& + RT_DOMAIN(did)%LONVAL,RT_DOMAIN(did)%dist,nlst_rt(did)%HIRES_OUT,& + RT_DOMAIN(did)%QBDRYRT ) + +! 9991 continue + + end if + + + if(nlst_rt(did)%GWBASESWCRT .eq. 3) then + + call output_gw( & + nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & + RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & + nlst_rt(did)%nsoil, & +! nlst_rt(did)%startdate, nlst_rt(did)%olddate, & + nlst_rt(did)%sincedate, nlst_rt(did)%olddate, & + gw2d(did)%h, RT_DOMAIN(did)%SMCRT, & + gw2d(did)%convgw, RT_DOMAIN(did)%SFCHEADSUBRT, & + nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT, & + RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL, & + RT_DOMAIN(did)%LONVAL,rt_domain(did)%dist, & + nlst_rt(did)%HIRES_OUT) + + endif +! BF end gw2d output section + +#ifdef HYDRO_D + write(6,*) "before call output_chrt" +#endif + + if (nlst_rt(did)%CHANRTSWCRT.eq.1.or.nlst_rt(did)%CHANRTSWCRT.eq.2) then + +#ifdef MPP_LAND + call mpp_output_chrt(rt_domain(did)%gnlinks,rt_domain(did)%map_l2g, & +#else + call output_chrt( & +#endif + nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & + RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, & +! nlst_rt(did)%startdate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& + nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& + RT_DOMAIN(did)%CHLAT, & + RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & + RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & + RT_DOMAIN(did)%STRMFRXSTPTS,nlst_rt(did)%order_to_write) + +#ifdef MPP_LAND +! call mpp_output_chrtgrd(nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & +! RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt, RT_DOMAIN(did)%NLINKS, & +! RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%ORDER, & +! nlst_rt(did)%startdate, nlst_rt(did)%olddate, & +! RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm, & +! RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & +! RT_DOMAIN(did)%g_ixrt,RT_DOMAIN(did)%g_jxrt ) +#endif + + if (RT_DOMAIN(did)%NLAKES.gt.0) & +#ifdef MPP_LAND + call mpp_output_lakes( RT_DOMAIN(did)%lake_index, & +#else + call output_lakes( & +#endif + nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & + RT_DOMAIN(did)%NLAKES, & +! trim(nlst_rt(did)%startdate), trim(nlst_rt(did)%olddate), & + trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), & + RT_DOMAIN(did)%LATLAKE,RT_DOMAIN(did)%LONLAKE, & + RT_DOMAIN(did)%ELEVLAKE,RT_DOMAIN(did)%QLAKEI, & + RT_DOMAIN(did)%QLAKEO, & + RT_DOMAIN(did)%RESHT,nlst_rt(did)%DT,Kt) + endif +#ifdef HYDRO_D + write(6,*) "end calling output functions" +#endif + + endif ! end of routing switch + + + end subroutine HYDRO_out + + + subroutine HYDRO_rst_in(did) + integer :: did + integer:: flag + + + + flag = -1 +#ifdef MPP_LAND + if(my_id.eq.IO_id) then +#endif + if (trim(nlst_rt(did)%restart_file) /= "") then + flag = 99 + rt_domain(did)%timestep_flag = 99 ! continue run + endif +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(flag) +#endif + + nlst_rt(did)%sincedate = nlst_rt(did)%startdate + + if (flag.eq.99) then + +#ifdef MPP_LAND + if(my_id.eq.IO_id) then +#endif +#ifdef HYDRO_D + write(6,*) "*** read restart data: ",trim(nlst_rt(did)%restart_file) +#endif +#ifdef MPP_LAND + endif +#endif + call RESTART_IN_nc(trim(nlst_rt(did)%restart_file), did) + +!yw if (trim(nlst_rt(did)%restart_file) /= "") then +!yw nlst_rt(did)%restart_file = "" +!yw endif + + endif + end subroutine HYDRO_rst_in + + subroutine HYDRO_time_adv(did) + implicit none + character(len = 19) :: newdate + integer did + +#ifdef MPP_LAND + if(IO_id.eq.my_id) then +#endif + call geth_newdate(newdate, nlst_rt(did)%olddate, nint( nlst_rt(did)%dt)) + nlst_rt(did)%olddate = newdate +#ifdef HYDRO_D + write(6,*) "current time is ",newdate +#endif +#ifdef MPP_LAND + endif +#endif + end subroutine HYDRO_time_adv + + subroutine HYDRO_exe(did) + + + implicit none + integer:: did + integer:: rst_out + + + call HYDRO_out(did) + + +! running land surface model +! cpl: 0--offline run; +! 1-- coupling with WRF but running offline lsm; +! 2-- coupling with WRF but do not run offline lsm +! 3-- coupling with LIS and do not run offline lsm +! 4: coupling with CLM +! if(nlst_rt(did)%SYS_CPL .eq. 0 .or. nlst_rt(did)%SYS_CPL .eq. 1 )then +! call drive_noahLSF(did,kt) +! else +! ! does not run the NOAH LASF model, only read the parameter +! call read_land_par(did,lsm(did)%ix,lsm(did)%jx) +! endif + + + + + + if (nlst_rt(did)%GWBASESWCRT .ne. 0 & + .or. nlst_rt(did)%SUBRTSWCRT .NE.0 & + .or. nlst_rt(did)%OVRTSWCRT .NE. 0 ) THEN + + + RT_DOMAIN(did)%QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT + RT_DOMAIN(did)%LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT + + + + ! step 1) disaggregate specific fields from LSM to Hydro grid + call disaggregateDomain_drv(did) + + ! step 2) + call SubsurfaceRouting_drv(did) + + ! step 3) todo split + call OverlandRouting_drv(did) + + RT_DOMAIN(did)%QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-RT_DOMAIN(did)%QSTRMVOLRT_DUM + RT_DOMAIN(did)%LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-RT_DOMAIN(did)%LAKE_INFLORT_DUM + + + ! step 4) baseflow or groundwater physics + call driveGwBaseflow(did) + + ! step 5) river channel physics + call driveChannelRouting(did) + + ! step 6) aggregate specific fields from Hydro to LSM grid + call aggregateDomain(did) + + + end if + + + ! advance to next time step + call HYDRO_time_adv(did) + + ! output for history + call HYDRO_out(did) + + +! write(90 + my_id,*) "finish calling hydro_exe" +! flush(90+my_id) +! call mpp_land_sync() + + + + RT_DOMAIN(did)%SOLDRAIN = 0 + RT_DOMAIN(did)%QSUBRT = 0 + + + + end subroutine HYDRO_exe + + + +!---------------------------------------------------- + subroutine driveGwBaseflow(did) + + implicit none + integer, intent(in) :: did + + integer :: i + +!------------------------------------------------------------------ +!DJG Begin GW/Baseflow Routines +!------------------------------------------------------------------- + + IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN ! Switch to activate/specify GW/Baseflow + +! IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow + + If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then ! Call simple bucket baseflow scheme + +#ifdef HYDRO_D + write(6,*) "*****yw******start simp_gw_buck " +#endif + + call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& + RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%basns_area,& + RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & + RT_DOMAIN(did)%SOLDRAIN, & + RT_DOMAIN(did)%z_gwsubbas,& + RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& + RT_DOMAIN(did)%qinflowbase,& + RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & + RT_DOMAIN(did)%dist,nlst_rt(did)%DT,& + RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & + RT_DOMAIN(did)%z_max,& + nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT) + + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + + open (unit=51,file='GW_inflow.txt',form='formatted',& + status='unknown',position='append') + open (unit=52,file='GW_outflow.txt',form='formatted',& + status='unknown',position='append') + open (unit=53,file='GW_zlev.txt',form='formatted',& + status='unknown',position='append') + do i=1,RT_DOMAIN(did)%numbasns + write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i) +951 FORMAT(I3,1X,A19,1X,F11.3) + write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i) + write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i) + end do + close(51) + close(52) + close(53) +#ifdef MPP_LAND + endif +#endif + +#ifdef HYDRO_D + write(6,*) "*****yw******end simp_gw_buck " +#endif + +!!!For parameter setup runs output the percolation for each basin, +!!!otherwise comment out this output... + else if (nlst_rt(did)%GWBASESWCRT .eq. 3) then + +#ifdef HYDRO_D + write(6,*) "*****bf******start 2d_gw_model " +#endif + + call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & + gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & + gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & + gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & + gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & + gw2d(did)%istep) + + +! bftodo head postprocessing block +! GW-SOIL-CHANNEL interaction section + gw2d(did)%ho = gw2d(did)%h + +#ifdef HYDRO_D + write(6,*) "*****bf******end 2d_gw_model " +#endif + + End if + + END IF !DJG (End if for RTE SWC activation) +!------------------------------------------------------------------ +!DJG End GW/Baseflow Routines +!------------------------------------------------------------------- + + + end subroutine driveGwBaseflow + + + + +!------------------------------------------- + subroutine driveChannelRouting(did) + + implicit none + integer, intent(in) :: did + +!------------------------------------------------------------------- +!------------------------------------------------------------------- +!DJG,DNY Begin Channel and Lake Routing Routines +!------------------------------------------------------------------- + IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN + + call drive_CHANNEL(RT_DOMAIN(did)%latval,RT_DOMAIN(did)%lonval, & + RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, & + RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS,& + RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& + RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& + RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT, & + RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTCT,nlst_rt(did)%DTRT,& + RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & + RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& + RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & + RT_DOMAIN(did)%Bw,& + RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,& + RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, & + RT_DOMAIN(did)%ORIFICEA, & + RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & + RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& + RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & + RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, & + RT_DOMAIN(did)%RETDEP_CHAN & + , RT_DOMAIN(did)%node_area & +#ifdef MPP_LAND + ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& + RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & + RT_DOMAIN(did)%yw_mpp_nlinks & +#endif + ) + endif + +#ifdef HYDRO_D + write(6,*) "*****yw******end drive_CHANNEL " +#endif + + end subroutine driveChannelRouting + + + +!------------------------------------------------ + subroutine aggregateDomain(did) + + implicit none + integer, intent(in) :: did + + integer :: i, j, krt, ixxrt, jyyrt, & + AGGFACYRT, AGGFACXRT +#ifdef HYDRO_D + print *, "Beginning Aggregation..." +#endif + + + do J=1,RT_DOMAIN(did)%JX + do I=1,RT_DOMAIN(did)%IX + + RT_DOMAIN(did)%SFCHEADAGGRT = 0. +!DJG Subgrid weighting edit... + RT_DOMAIN(did)%LSMVOL=0. + do KRT=1,nlst_rt(did)%NSOIL +! SMCAGGRT(KRT) = 0. + RT_DOMAIN(did)%SH2OAGGRT(KRT) = 0. + end do + + + do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1 + do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1 + + + IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT + JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#else +!yw ???? +! IXXRT=IXXRT+1 +! JYYRT=JYYRT+1 +#endif + +!State Variables + RT_DOMAIN(did)%SFCHEADAGGRT = RT_DOMAIN(did)%SFCHEADAGGRT & + + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) +!DJG Subgrid weighting edit... + RT_DOMAIN(did)%LSMVOL = RT_DOMAIN(did)%LSMVOL & + + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) & + * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9) + + do KRT=1,nlst_rt(did)%NSOIL +!DJG SMCAGGRT(KRT)=SMCAGGRT(KRT)+SMCRT(IXXRT,JYYRT,KRT) + RT_DOMAIN(did)%SH2OAGGRT(KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & + + RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) + end do + + end do + end do + + + + RT_DOMAIN(did)%SFCHEADRT(I,J) = RT_DOMAIN(did)%SFCHEADAGGRT & + / (nlst_rt(did)%AGGFACTRT**2) + + do KRT=1,nlst_rt(did)%NSOIL +!DJG SMC(I,J,KRT)=SMCAGGRT(KRT)/(AGGFACTRT**2) + RT_DOMAIN(did)%SH2OX(I,J,KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & + / (nlst_rt(did)%AGGFACTRT**2) + end do + + + +!DJG Calculate subgrid weighting array... + + do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1 + do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1 + IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT + JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#else +!yw ??? +! IXXRT=IXXRT+1 +! JYYRT=JYYRT+1 +#endif + if (RT_DOMAIN(did)%LSMVOL.gt.0.) then + RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & + = RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) & + * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9) & + / RT_DOMAIN(did)%LSMVOL + else + RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & + = 1./FLOAT(nlst_rt(did)%AGGFACTRT**2) + end if + + do KRT=1,nlst_rt(did)%NSOIL + +!!!yw added for debug + if(RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .lt. 0) then + print*, "Error negative SMCRT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + endif + if(RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) .lt. 0) then + print *, "Error negative SH2OWGT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + endif + +!end + IF (RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .GT. & + RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT)) THEN +#ifdef HYDRO_D + print *, "SMCMAX exceeded upon aggregation...", & + RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT), & + RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT) + call hydro_stop("aggregateDomain") +#endif + END IF + IF(RT_DOMAIN(did)%SH2OX(I,J,KRT).LE.0.) THEN +#ifdef HYDRO_D + print *, "Erroneous value of SH2O...", & + RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT + print *, "Error negative SH2OX", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + call hydro_stop("aggregateDomain") +#endif + END IF + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) & + = RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) & + / RT_DOMAIN(did)%SH2OX(I,J,KRT) +!?yw + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = max(1.0E-30, RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT)) + end do + + end do + end do + + end do + end do + + +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(RT_DOMAIN(did)%INFXSWGT, & + RT_DOMAIN(did)%IXRT, & + RT_DOMAIN(did)%JXRT, 99) + + do i = 1, nlst_rt(did)%NSOIL + call MPP_LAND_COM_REAL(RT_DOMAIN(did)%SH2OWGT(:,:,i), & + RT_DOMAIN(did)%IXRT, & + RT_DOMAIN(did)%JXRT, 99) + end do +#endif + +!DJG Update SMC with SICE (unchanged) and new value of SH2O from routing... + RT_DOMAIN(did)%SMC = RT_DOMAIN(did)%SH2OX + RT_DOMAIN(did)%SICE +#ifdef HYDRO_D + print *, "Finished Aggregation..." +#endif + + + end subroutine aggregateDomain + + + + subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) + implicit none + integer ntime, did + integer rst_out, ix,jx +! integer, OPTIONAL:: ix0,jx0 + integer:: ix0,jx0 + integer, dimension(ix0,jx0),OPTIONAL :: vegtyp, soltyp + + + +#ifdef MPP_LAND + call MPP_LAND_INIT() +#endif + + +! read the namelist +! the lsm namelist will be read by rtland sequentially again. + call read_rt_nlst(nlst_rt(did) ) + + + IF (nlst_rt(did)%GWBASESWCRT .eq. 0 & + .and. nlst_rt(did)%SUBRTSWCRT .eq.0 & + .and. nlst_rt(did)%OVRTSWCRT .eq. 0 ) return + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! get the dimension + call get_file_dimension(trim(nlst_rt(did)%geo_static_flnm), ix,jx) + + +#ifdef MPP_LAND + + if (nlst_rt(did)%sys_cpl .eq. 1 .or. nlst_rt(did)%sys_cpl .eq. 4) then +!sys_cpl: 1-- coupling with HRLDAS but running offline lsm; +! 2-- coupling with WRF but do not run offline lsm +! 3-- coupling with LIS and do not run offline lsm +! 4: coupling with CLM + +! create 2 dimensiaon logical mapping of the CPUs for coupling with CLM or HRLDAS. + call log_map2d() + + global_nx = ix ! get from land model + global_ny = jx ! get from land model + + call mpp_land_bcast_int1(global_nx) + call mpp_land_bcast_int1(global_ny) + +!!! temp set global_nx to ix + rt_domain(did)%ix = global_nx + rt_domain(did)%jx = global_ny + +! over write the ix and jx + call MPP_LAND_PAR_INI(1,rt_domain(did)%ix,rt_domain(did)%jx,& + nlst_rt(did)%AGGFACTRT) + else +! coupled with WRF, LIS + numprocs = node_info(1,1) + + call wrf_LAND_set_INIT(node_info,numprocs,nlst_rt(did)%AGGFACTRT) + + + rt_domain(did)%ix = local_nx + rt_domain(did)%jx = local_ny + endif + + + + rt_domain(did)%g_IXRT=global_rt_nx + rt_domain(did)%g_JXRT=global_rt_ny + rt_domain(did)%ixrt = local_rt_nx + rt_domain(did)%jxrt = local_rt_ny + +#ifdef HYDRO_D + write(6,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" + write(6,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt + write(6,*) "rt_domain(did)%ix, rt_domain(did)%jx " + write(6,*) rt_domain(did)%ix, rt_domain(did)%jx + write(6,*) "global_nx, global_ny, local_nx, local_ny" + write(6,*) global_nx, global_ny, local_nx, local_ny +#endif +#else +! sequential + rt_domain(did)%ix = ix + rt_domain(did)%jx = jx + rt_domain(did)%ixrt = ix*nlst_rt(did)%AGGFACTRT + rt_domain(did)%jxrt = jx*nlst_rt(did)%AGGFACTRT +#endif + + +! allocate rt arrays + + + call getChanDim(did) + + +#ifdef HYDRO_D + write(6,*) "finish getChanDim " +#endif + + if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then + call gw2d_allocate(did,& + rt_domain(did)%ixrt,& + rt_domain(did)%jxrt,& + nlst_rt(did)%nsoil) +#ifdef HYDRO_D + write(6,*) "finish gw2d_allocate" +#endif + endif + +! calculate the distance between grids for routing. +! decompose the land parameter/data + + +! ix0= rt_domain(did)%ix +! jx0= rt_domain(did)%jx + if(present(vegtyp)) then + call lsm_input(did,ix0=ix0,jx0=jx0,vegtyp0=vegtyp,soltyp0=soltyp) + else + call lsm_input(did,ix0=ix0,jx0=jx0) + endif + + +#ifdef HYDRO_D + write(6,*) "finish decomposion" +#endif + + + call get_dist_lsm(did) + call get_dist_lrt(did) + + +! rt model initilization + call LandRT_ini(did) + +#ifdef HYDRO_D + write(6,*) "finish LandRT_ini" +#endif + + + if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then + + call gw2d_ini(did,& + nlst_rt(did)%dt,& + nlst_rt(did)%dxrt0) +#ifdef HYDRO_D + write(6,*) "finish gw2d_ini" +#endif + endif +#ifdef HYDRO_D + write(6,*) "finish LandRT_ini" +#endif + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IF (nlst_rt(did)%TERADJ_SOLAR.EQ.1 .and. nlst_rt(did)%CHANRTSWCRT.NE.2) THEN ! Perform ter rain adjustment of incoming solar +#ifdef MPP_LAND + call MPP_seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& + rt_domain(did)%TERRAIN, rt_domain(did)%dist_lsm,& + rt_domain(did)%ix,rt_domain(did)%jx,global_nx,global_ny) +#else + call seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& + rt_domain(did)%TERRAIN,rt_domain(did)%dist_lsm,& + rt_domain(did)%ix,rt_domain(did)%jx) +#endif + endif + + + IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2 .or. nlst_rt(did)%GWBASESWCRT .gt. 0) then + call get_basn_area(did) + endif + + IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2 ) then +! call get_basn_area(did) + call get_node_area(did) + endif + + +! if (trim(nlst_rt(did)%restart_file) == "") then +! output at the initial time +! call HYDRO_out(did) +! return +! endif + +! restart the file + + ! jummp the initial time output +! rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1 +! rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1 + + call HYDRO_rst_in(did) + + +! call HYDRO_out(did) + + + end subroutine HYDRO_ini + + subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) + implicit none + integer did, leng + parameter(leng=100) + integer :: i,j, nn + integer, allocatable, dimension(:,:) :: soltyp + real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc + + integer :: ix0,jx0 + integer, dimension(ix0,jx0),OPTIONAL :: vegtyp0, soltyp0 + +#ifdef HYDRO_D + write(6,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx +#endif + + allocate(soltyp(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) ) + + soltyp = 0 + call get2d_lsm_soltyp(soltyp,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) + + + call get2d_lsm_real("HGT",RT_DOMAIN(did)%TERRAIN,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) + + call get2d_lsm_real("XLAT",RT_DOMAIN(did)%lat_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) + call get2d_lsm_real("XLONG",RT_DOMAIN(did)%lon_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) + call get2d_lsm_vegtyp(RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) + + + + if(nlst_rt(did)%sys_cpl .eq. 2 ) then + ! coupling with WRF + if(present(soltyp0) ) then + where(soltyp0 == 14) VEGTYP0 = 16 + where(VEGTYP0 == 16 ) soltyp0 = 14 + soltyp = soltyp0 + RT_DOMAIN(did)%VEGTYP = VEGTYP0 + endif + endif + + where(soltyp == 14) RT_DOMAIN(did)%VEGTYP = 16 + where(RT_DOMAIN(did)%VEGTYP == 16 ) soltyp = 14 + +! LKSAT, +! temporary set + RT_DOMAIN(did)%SMCRTCHK = 0 + RT_DOMAIN(did)%SMCAGGRT = 0 + RT_DOMAIN(did)%STCAGGRT = 0 + RT_DOMAIN(did)%SH2OAGGRT = 0 + + + RT_DOMAIN(did)%zsoil(1:nlst_rt(did)%nsoil) = nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) + + RT_DOMAIN(did)%sldpth(1) = abs( RT_DOMAIN(did)%zsoil(1) ) + do i = 2, nlst_rt(did)%nsoil + RT_DOMAIN(did)%sldpth(i) = RT_DOMAIN(did)%zsoil(i-1)-RT_DOMAIN(did)%zsoil(i) + enddo + RT_DOMAIN(did)%SOLDEPRT = -1.0*RT_DOMAIN(did)%ZSOIL(nlst_rt(did)%NSOIL) + +! input OV_ROUGH from OVROUGH.TBL +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + + open(71,file="HYDRO.TBL", form="formatted") +!read OV_ROUGH first + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) + end do +!read parameter for LKSAT + read(71,*) nn + read(71,*) + do i = 1, nn + read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) + end do + close(71) + +#ifdef MPP_LAND + endif + call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) + call mpp_land_bcast_real(leng,xdum1) + call mpp_land_bcast_real(leng,MAXSMC) + call mpp_land_bcast_real(leng,refsmc) + call mpp_land_bcast_real(leng,wltsmc) +#endif + + rt_domain(did)%lksat = 0.0 + do j = 1, RT_DOMAIN(did)%jx + do i = 1, RT_DOMAIN(did)%ix + !yw rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 + rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) + IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN ! urban + rt_domain(did)%SMCMAX1(i,j) = 0.45 + rt_domain(did)%SMCREF1(i,j) = 0.42 + rt_domain(did)%SMCWLT1(i,j) = 0.40 + else + rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) + rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) + rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) + ENDIF + end do + end do + + deallocate(soltyp) + + + end subroutine lsm_input + + +end module module_HYDRO_drv + +! stop the job due to the fatal error. + subroutine HYDRO_stop(msg) +#ifdef MPP_LAND + use module_mpp_land +#endif + character(len=*) :: msg + integer :: ierr +#ifdef HYDRO_D + write(6,*) "The job is stoped due to the fatal error. ", trim(msg) + flush(6) +#endif +#ifdef MPP_LAND +#ifndef HYDRO_D + print*, "---" + print*, "ERROR! Program stopped. Recompile with environment variable HYDRO_D set to 1 for enhanced debug information." + print*, "" +#endif + +! call mpp_land_sync() +! write(my_id+90,*) msg +! flush(my_id+90) + + call mpp_land_abort() + call MPI_finalize(ierr) +#else + stop "Fatal Error" +#endif + + return + end subroutine HYDRO_stop + + +! stop the job due to the fatal error. + subroutine HYDRO_finish() +#ifdef MPP_LAND + USE module_mpp_land +#endif + integer :: ierr + + print*, "The model finished successfully......." +#ifdef MPP_LAND +! call mpp_land_abort() + flush(6) + call mpp_land_sync() + call MPI_finalize(ierr) + stop +#else + stop +#endif + + return + end subroutine HYDRO_finish diff --git a/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F b/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F index 2157f293..cc0de91f 100644 --- a/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F +++ b/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F @@ -10,11 +10,13 @@ module module_HYDRO_drv output_lsm use module_rt_data, only: rt_domain use module_GW_baseflow_data, only: gw2d - use module_GW_baseflow, only: gw2d_allocate, gw2d_ini - use module_namelist, only: nlst_rt + use module_GW_baseflow, only:simp_gw_buck, gwstep, gw2d_allocate, gw2d_ini + use module_channel_routing, only: drive_channel + use module_namelist, only: nlst_rt, read_rt_nlst use module_routing, only: getChanDim, landrt_ini use module_HYDRO_utils - use module_namelist +! use module_namelist + use module_lsm_forcing, only: geth_newdate implicit none @@ -33,13 +35,15 @@ subroutine HYDRO_rst_out(did) else call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%rst_dt*60*rt_domain(did)%rst_counts)) endif - if ( out_date(1:19) == nlst_rt(did)%olddate(1:19) ) then + if ( (nlst_rt(did)%rst_dt .gt. 0) .and. (out_date(1:19) == nlst_rt(did)%olddate(1:19)) ) then rst_out = 99 rt_domain(did)%rst_counts = rt_domain(did)%rst_counts + 1 endif ! restart every month automatically. - if ((nlst_rt(did)%olddate(9:10) == "01") .and. (nlst_rt(did)%olddate(12:13) == "00") .and. & - (nlst_rt(did)%olddate(15:16) == "00").and. (nlst_rt(did)%olddate(18:19) == "00")) rst_out = 99 + if ( (nlst_rt(did)%olddate(9:10) == "01") .and. (nlst_rt(did)%olddate(12:13) == "00") .and. & + (nlst_rt(did)%olddate(15:16) == "00").and. (nlst_rt(did)%olddate(18:19) == "00") .and. & + (nlst_rt(did)%rst_dt .le. 0) ) rst_out = 99 + #ifdef MPP_LAND endif call mpp_land_bcast_int1(rst_out) @@ -64,8 +68,8 @@ end subroutine HYDRO_rst_out subroutine HYDRO_out(did) implicit none - integer did, outflag - character(len=19) out_date, rt_out_date + integer did, outflag, rtflag + character(len=19) out_date integer :: Kt, ounit ! real, dimension(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx):: soilmx_tmp, & @@ -83,7 +87,6 @@ subroutine HYDRO_out(did) #ifdef HYDRO_D write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19), rt_domain(did)%his_out_counts #endif - call geth_newdate(rt_out_date, nlst_rt(did)%olddate, -1*nint(rt_domain(did)%his_out_counts*nlst_rt(did)%out_dt*60)) outflag = 99 else if(nlst_rt(did)%dt .gt. nlst_rt(did)%out_dt*60) then @@ -96,7 +99,6 @@ subroutine HYDRO_out(did) write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19) #endif outflag = 99 - call geth_newdate(rt_out_date, nlst_rt(did)%olddate, -1*nint(rt_domain(did)%his_out_counts*nlst_rt(did)%out_dt*60)) endif endif #ifdef MPP_LAND @@ -118,6 +120,24 @@ subroutine HYDRO_out(did) endif +! jump the ouput for the initial time when it has restart file from routing. + rtflag = -99 +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif + if ( (trim(nlst_rt(did)%restart_file) /= "") .and. ( nlst_rt(did)%startdate(1:19) == nlst_rt(did)%olddate(1:19) ) ) then + print*, "yyyywww restart_file = ", trim(nlst_rt(did)%restart_file) + rtflag = 1 + endif +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(rtflag) +#endif + + +!yw keep the initial time otuput for debug + if(rtflag == 1) return ! jump the initial time output for routing restart + call output_lsm(trim(nlst_rt(did)%olddate(1:4)//nlst_rt(did)%olddate(6:7)//nlst_rt(did)%olddate(9:10) & @@ -132,6 +152,8 @@ subroutine HYDRO_out(did) .or. nlst_rt(did)%GWBASESWCRT .gt. 0 ) then if (nlst_rt(did)%HIRES_OUT.ge.1) then + +! goto 9991 #ifdef MPP_LAND call mpp_output_rt(rt_domain(did)%g_ixrt, rt_domain(did)%g_jxrt, & @@ -142,7 +164,7 @@ subroutine HYDRO_out(did) RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & nlst_rt(did)%nsoil, & ! nlst_rt(did)%startdate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,& - rt_out_date, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,& + nlst_rt(did)%sincedate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,& RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SMCRT,& RT_DOMAIN(did)%SUB_RESID, & RT_DOMAIN(did)%q_sfcflx_x,RT_DOMAIN(did)%q_sfcflx_y,& @@ -153,6 +175,11 @@ subroutine HYDRO_out(did) RT_DOMAIN(did)%LONVAL,RT_DOMAIN(did)%dist,nlst_rt(did)%HIRES_OUT,& RT_DOMAIN(did)%QBDRYRT ) +! 9991 continue + + end if + + if(nlst_rt(did)%GWBASESWCRT .eq. 3) then call output_gw( & @@ -160,7 +187,7 @@ subroutine HYDRO_out(did) RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & nlst_rt(did)%nsoil, & ! nlst_rt(did)%startdate, nlst_rt(did)%olddate, & - rt_out_date, nlst_rt(did)%olddate, & + nlst_rt(did)%sincedate, nlst_rt(did)%olddate, & gw2d(did)%h, RT_DOMAIN(did)%SMCRT, & gw2d(did)%convgw, RT_DOMAIN(did)%SFCHEADSUBRT, & nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT, & @@ -171,7 +198,6 @@ subroutine HYDRO_out(did) endif ! BF end gw2d output section - end if #ifdef HYDRO_D write(6,*) "before call output_chrt" #endif @@ -179,27 +205,27 @@ subroutine HYDRO_out(did) if (nlst_rt(did)%CHANRTSWCRT.eq.1.or.nlst_rt(did)%CHANRTSWCRT.eq.2) then #ifdef MPP_LAND - call mpp_output_chrt(rt_domain(did)%mpp_nlinks,rt_domain(did)%nlinks_index, & + call mpp_output_chrt(rt_domain(did)%gnlinks,rt_domain(did)%map_l2g, & #else call output_chrt( & #endif nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, & ! nlst_rt(did)%startdate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& - rt_out_date,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& + nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& RT_DOMAIN(did)%CHLAT, & RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & RT_DOMAIN(did)%STRMFRXSTPTS,nlst_rt(did)%order_to_write) #ifdef MPP_LAND - call mpp_output_chrtgrd(nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & - RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt, RT_DOMAIN(did)%NLINKS, & - RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%ORDER, & - nlst_rt(did)%startdate, nlst_rt(did)%olddate, & - RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm, & - RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & - RT_DOMAIN(did)%g_ixrt,RT_DOMAIN(did)%g_jxrt ) +! call mpp_output_chrtgrd(nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & +! RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt, RT_DOMAIN(did)%NLINKS, & +! RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%ORDER, & +! nlst_rt(did)%startdate, nlst_rt(did)%olddate, & +! RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm, & +! RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & +! RT_DOMAIN(did)%g_ixrt,RT_DOMAIN(did)%g_jxrt ) #endif if (RT_DOMAIN(did)%NLAKES.gt.0) & @@ -211,7 +237,7 @@ subroutine HYDRO_out(did) nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & RT_DOMAIN(did)%NLAKES, & ! trim(nlst_rt(did)%startdate), trim(nlst_rt(did)%olddate), & - trim(rt_out_date), trim(nlst_rt(did)%olddate), & + trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), & RT_DOMAIN(did)%LATLAKE,RT_DOMAIN(did)%LONLAKE, & RT_DOMAIN(did)%ELEVLAKE,RT_DOMAIN(did)%QLAKEI, & RT_DOMAIN(did)%QLAKEO, & @@ -246,7 +272,8 @@ subroutine HYDRO_rst_in(did) call mpp_land_bcast_int1(flag) #endif - + nlst_rt(did)%sincedate = nlst_rt(did)%startdate + if (flag.eq.99) then #ifdef MPP_LAND @@ -260,9 +287,10 @@ subroutine HYDRO_rst_in(did) #endif call RESTART_IN_nc(trim(nlst_rt(did)%restart_file), did) - if (trim(nlst_rt(did)%restart_file) /= "") then - nlst_rt(did)%restart_file = "" - endif +!yw if (trim(nlst_rt(did)%restart_file) /= "") then +!yw nlst_rt(did)%restart_file = "" +!yw endif + endif end subroutine HYDRO_rst_in @@ -283,532 +311,401 @@ subroutine HYDRO_time_adv(did) endif #endif end subroutine HYDRO_time_adv + + subroutine HYDRO_exe(did) - integer function nfeb_yw(year) - ! - ! Compute the number of days in February for the given year. - ! - implicit none - integer, intent(in) :: year ! Four-digit year - - nfeb_yw = 28 ! By default, February has 28 days ... - if (mod(year,4).eq.0) then - nfeb_yw = 29 ! But every four years, it has 29 days ... - if (mod(year,100).eq.0) then - nfeb_yw = 28 ! Except every 100 years, when it has 28 days ... - if (mod(year,400).eq.0) then - nfeb_yw = 29 ! Except every 400 years, when it has 29 days ... - if (mod(year,3600).eq.0) then - nfeb_yw = 28 ! Except every 3600 years, when it has 28 days. - endif - endif - endif - endif - end function nfeb_yw - - subroutine geth_newdate (ndate, odate, idt) - implicit none - - ! From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and - ! delta-time, compute the new date. - - ! on entry - odate - the old hdate. - ! idt - the change in time - - ! on exit - ndate - the new hdate. - - integer, intent(in) :: idt - character (len=*), intent(out) :: ndate - character (len=*), intent(in) :: odate - - ! Local Variables - - ! yrold - indicates the year associated with "odate" - ! moold - indicates the month associated with "odate" - ! dyold - indicates the day associated with "odate" - ! hrold - indicates the hour associated with "odate" - ! miold - indicates the minute associated with "odate" - ! scold - indicates the second associated with "odate" - - ! yrnew - indicates the year associated with "ndate" - ! monew - indicates the month associated with "ndate" - ! dynew - indicates the day associated with "ndate" - ! hrnew - indicates the hour associated with "ndate" - ! minew - indicates the minute associated with "ndate" - ! scnew - indicates the second associated with "ndate" - - ! mday - a list assigning the number of days in each month - - ! i - loop counter - ! nday - the integer number of days represented by "idt" - ! nhour - the integer number of hours in "idt" after taking out - ! all the whole days - ! nmin - the integer number of minutes in "idt" after taking out - ! all the whole days and whole hours. - ! nsec - the integer number of minutes in "idt" after taking out - ! all the whole days, whole hours, and whole minutes. - - integer :: newlen, oldlen - integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew - integer :: yrold, moold, dyold, hrold, miold, scold, frold - integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc - logical :: opass - character (len=10) :: hfrc - character (len=1) :: sp - logical :: punct - integer :: yrstart, yrend, mostart, moend, dystart, dyend - integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart - integer :: units - integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) -!yw integer nfeb_yw - - ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...." - if (odate(5:5) == "-") then - punct = .TRUE. - else - punct = .FALSE. - endif - ! Break down old hdate into parts - - hrold = 0 - miold = 0 - scold = 0 - frold = 0 - oldlen = LEN(odate) - if (punct) then - yrstart = 1 - yrend = 4 - mostart = 6 - moend = 7 - dystart = 9 - dyend = 10 - hrstart = 12 - hrend = 13 - mistart = 15 - miend = 16 - scstart = 18 - scend = 19 - frstart = 21 - select case (oldlen) - case (10) - ! Days - units = 1 - case (13) - ! Hours - units = 2 - case (16) - ! Minutes - units = 3 - case (19) - ! Seconds - units = 4 - case (21) - ! Tenths - units = 5 - case (22) - ! Hundredths - units = 6 - case (23) - ! Thousandths - units = 7 - case (24) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - stop -#endif - end select - - if (oldlen.ge.11) then - sp = odate(11:11) - else - sp = ' ' - end if - - else - - yrstart = 1 - yrend = 4 - mostart = 5 - moend = 6 - dystart = 7 - dyend = 8 - hrstart = 9 - hrend = 10 - mistart = 11 - miend = 12 - scstart = 13 - scend = 14 - frstart = 15 - - select case (oldlen) - case (8) - ! Days - units = 1 - case (10) - ! Hours - units = 2 - case (12) - ! Minutes - units = 3 - case (14) - ! Seconds - units = 4 - case (15) - ! Tenths - units = 5 - case (16) - ! Hundredths - units = 6 - case (17) - ! Thousandths - units = 7 - case (18) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - stop -#endif - end select - endif + implicit none + integer:: did + integer:: rst_out - ! Use internal READ statements to convert the CHARACTER string - ! date into INTEGER components. - read(odate(yrstart:yrend), '(i4)') yrold - read(odate(mostart:moend), '(i2)') moold - read(odate(dystart:dyend), '(i2)') dyold - if (units.ge.2) then - read(odate(hrstart:hrend),'(i2)') hrold - if (units.ge.3) then - read(odate(mistart:miend),'(i2)') miold - if (units.ge.4) then - read(odate(scstart:scend),'(i2)') scold - if (units.ge.5) then - read(odate(frstart:oldlen),*) frold - end if - end if - end if - end if + call HYDRO_out(did) - ! Set the number of days in February for that year. - mday(2) = nfeb_yw(yrold) +! running land surface model +! cpl: 0--offline run; +! 1-- coupling with WRF but running offline lsm; +! 2-- coupling with WRF but do not run offline lsm +! 3-- coupling with LIS and do not run offline lsm +! 4: coupling with CLM +! if(nlst_rt(did)%SYS_CPL .eq. 0 .or. nlst_rt(did)%SYS_CPL .eq. 1 )then +! call drive_noahLSF(did,kt) +! else +! ! does not run the NOAH LASF model, only read the parameter +! call read_land_par(did,lsm(did)%ix,lsm(did)%jx) +! endif - ! Check that ODATE makes sense. - opass = .TRUE. - ! Check that the month of ODATE makes sense. - if ((moold.gt.12).or.(moold.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold -#endif - opass = .FALSE. - end if - ! Check that the day of ODATE makes sense. + if (nlst_rt(did)%GWBASESWCRT .ne. 0 & + .or. nlst_rt(did)%SUBRTSWCRT .NE.0 & + .or. nlst_rt(did)%OVRTSWCRT .NE. 0 ) THEN - if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold -#endif - opass = .FALSE. - end if - ! Check that the hour of ODATE makes sense. + RT_DOMAIN(did)%QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT + RT_DOMAIN(did)%LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT - if ((hrold.gt.23).or.(hrold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold -#endif - opass = .FALSE. - end if - ! Check that the minute of ODATE makes sense. - if ((miold.gt.59).or.(miold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold -#endif - opass = .FALSE. - end if + ! step 1) disaggregate specific fields from LSM to Hydro grid + call disaggregateDomain_drv(did) - ! Check that the second of ODATE makes sense. + ! step 2) + call SubsurfaceRouting_drv(did) + + ! step 3) todo split + call OverlandRouting_drv(did) - if ((scold.gt.59).or.(scold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold -#endif - opass = .FALSE. - end if + RT_DOMAIN(did)%QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-RT_DOMAIN(did)%QSTRMVOLRT_DUM + RT_DOMAIN(did)%LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-RT_DOMAIN(did)%LAKE_INFLORT_DUM - ! Check that the fractional part of ODATE makes sense. - if (.not.opass) then -#ifdef HYDRO_D - write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen - stop -#endif - end if - - ! Date Checks are completed. Continue. - - - ! Compute the number of days, hours, minutes, and seconds in idt - - if (units.ge.5) then !idt should be in fractions of seconds - ifrc = oldlen-(frstart)+1 - ifrc = 10**ifrc - nday = abs(idt)/(86400*ifrc) - nhour = mod(abs(idt),86400*ifrc)/(3600*ifrc) - nmin = mod(abs(idt),3600*ifrc)/(60*ifrc) - nsec = mod(abs(idt),60*ifrc)/(ifrc) - nfrac = mod(abs(idt), ifrc) - else if (units.eq.4) then !idt should be in seconds - ifrc = 1 - nday = abs(idt)/86400 ! integer number of days in delta-time - nhour = mod(abs(idt),86400)/3600 - nmin = mod(abs(idt),3600)/60 - nsec = mod(abs(idt),60) - nfrac = 0 - else if (units.eq.3) then !idt should be in minutes - ifrc = 1 - nday = abs(idt)/1440 ! integer number of days in delta-time - nhour = mod(abs(idt),1440)/60 - nmin = mod(abs(idt),60) - nsec = 0 - nfrac = 0 - else if (units.eq.2) then !idt should be in hours - ifrc = 1 - nday = abs(idt)/24 ! integer number of days in delta-time - nhour = mod(abs(idt),24) - nmin = 0 - nsec = 0 - nfrac = 0 - else if (units.eq.1) then !idt should be in days - ifrc = 1 - nday = abs(idt) ! integer number of days in delta-time - nhour = 0 - nmin = 0 - nsec = 0 - nfrac = 0 - else -#ifdef HYDRO_D - write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & - oldlen - write(*,*) '#'//odate(1:oldlen)//'#' - stop -#endif - end if - - if (idt.ge.0) then - - frnew = frold + nfrac - if (frnew.ge.ifrc) then - frnew = frnew - ifrc - nsec = nsec + 1 - end if - - scnew = scold + nsec - if (scnew .ge. 60) then - scnew = scnew - 60 - nmin = nmin + 1 - end if - - minew = miold + nmin - if (minew .ge. 60) then - minew = minew - 60 - nhour = nhour + 1 - end if - - hrnew = hrold + nhour - if (hrnew .ge. 24) then - hrnew = hrnew - 24 - nday = nday + 1 - end if - - dynew = dyold - monew = moold - yrnew = yrold - do i = 1, nday - dynew = dynew + 1 - if (dynew.gt.mday(monew)) then - dynew = dynew - mday(monew) - monew = monew + 1 - if (monew .gt. 12) then - monew = 1 - yrnew = yrnew + 1 - ! If the year changes, recompute the number of days in February - mday(2) = nfeb_yw(yrnew) - end if - end if - end do + + ! step 4) baseflow or groundwater physics + call driveGwBaseflow(did) + + ! step 5) river channel physics + call driveChannelRouting(did) + + ! step 6) aggregate specific fields from Hydro to LSM grid + call aggregateDomain(did) - else if (idt.lt.0) then - - frnew = frold - nfrac - if (frnew .lt. 0) then - frnew = frnew + ifrc - nsec = nsec + 1 - end if - - scnew = scold - nsec - if (scnew .lt. 00) then - scnew = scnew + 60 - nmin = nmin + 1 - end if - - minew = miold - nmin - if (minew .lt. 00) then - minew = minew + 60 - nhour = nhour + 1 - end if - - hrnew = hrold - nhour - if (hrnew .lt. 00) then - hrnew = hrnew + 24 - nday = nday + 1 - end if - - dynew = dyold - monew = moold - yrnew = yrold - do i = 1, nday - dynew = dynew - 1 - if (dynew.eq.0) then - monew = monew - 1 - if (monew.eq.0) then - monew = 12 - yrnew = yrnew - 1 - ! If the year changes, recompute the number of days in February - mday(2) = nfeb_yw(yrnew) - end if - dynew = mday(monew) - end if - end do - end if - ! Now construct the new mdate + end if - newlen = LEN(ndate) - if (punct) then + ! advance to next time step + call HYDRO_time_adv(did) - if (newlen.gt.frstart) then - write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew - write(hfrc,'(i10)') frnew+1000000000 - ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + ! output for history + call HYDRO_out(did) - else if (newlen.eq.scend) then - write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew -19 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2) - else if (newlen.eq.miend) then - write(ndate,16) yrnew, monew, dynew, hrnew, minew -16 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2) +! write(90 + my_id,*) "finish calling hydro_exe" +! flush(90+my_id) +! call mpp_land_sync() - else if (newlen.eq.hrend) then - write(ndate,13) yrnew, monew, dynew, hrnew -13 format(i4,'-',i2.2,'-',i2.2,'_',i2.2) - else if (newlen.eq.dyend) then - write(ndate,10) yrnew, monew, dynew -10 format(i4,'-',i2.2,'-',i2.2) + + RT_DOMAIN(did)%SOLDRAIN = 0 + RT_DOMAIN(did)%QSUBRT = 0 - end if - else - if (newlen.gt.frstart) then - write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew - write(hfrc,'(i10)') frnew+1000000000 - ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + end subroutine HYDRO_exe - else if (newlen.eq.scend) then - write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew -119 format(i4,i2.2,i2.2,i2.2,i2.2,i2.2) + + +!---------------------------------------------------- + subroutine driveGwBaseflow(did) + + implicit none + integer, intent(in) :: did + + integer :: i - else if (newlen.eq.miend) then - write(ndate,116) yrnew, monew, dynew, hrnew, minew -116 format(i4,i2.2,i2.2,i2.2,i2.2) +!------------------------------------------------------------------ +!DJG Begin GW/Baseflow Routines +!------------------------------------------------------------------- - else if (newlen.eq.hrend) then - write(ndate,113) yrnew, monew, dynew, hrnew -113 format(i4,i2.2,i2.2,i2.2) + IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN ! Switch to activate/specify GW/Baseflow - else if (newlen.eq.dyend) then - write(ndate,110) yrnew, monew, dynew -110 format(i4,i2.2,i2.2) +! IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow - end if + If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then ! Call simple bucket baseflow scheme - endif +#ifdef HYDRO_D + write(6,*) "*****yw******start simp_gw_buck " +#endif - if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp + call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& + RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%basns_area,& + RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & + RT_DOMAIN(did)%SOLDRAIN, & + RT_DOMAIN(did)%z_gwsubbas,& + RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& + RT_DOMAIN(did)%qinflowbase,& + RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & + RT_DOMAIN(did)%dist,nlst_rt(did)%DT,& + RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & + RT_DOMAIN(did)%z_max,& + nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT) - end subroutine geth_newdate - - subroutine HYDRO_exe(did) +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif - implicit none - integer:: did - integer:: rst_out + open (unit=51,file='GW_inflow.txt',form='formatted',& + status='unknown',position='append') + open (unit=52,file='GW_outflow.txt',form='formatted',& + status='unknown',position='append') + open (unit=53,file='GW_zlev.txt',form='formatted',& + status='unknown',position='append') + do i=1,RT_DOMAIN(did)%numbasns + write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i) +951 FORMAT(I3,1X,A19,1X,F11.3) + write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i) + write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i) + end do + close(51) + close(52) + close(53) +#ifdef MPP_LAND + endif +#endif +#ifdef HYDRO_D + write(6,*) "*****yw******end simp_gw_buck " +#endif - call HYDRO_out(did) +!!!For parameter setup runs output the percolation for each basin, +!!!otherwise comment out this output... + else if (nlst_rt(did)%GWBASESWCRT .eq. 3) then +#ifdef HYDRO_D + write(6,*) "*****bf******start 2d_gw_model " +#endif -! running land surface model -! cpl: 0--offline run; -! 1-- coupling with WRF but running offline lsm; -! 2-- coupling with WRF but do not run offline lsm -! 3-- coupling with LIS and do not run offline lsm -! 4: coupling with CLM -! if(nlst_rt(did)%SYS_CPL .eq. 0 .or. nlst_rt(did)%SYS_CPL .eq. 1 )then -! call drive_noahLSF(did,kt) -! else -! ! does not run the NOAH LASF model, only read the parameter -! call read_land_par(did,lsm(did)%ix,lsm(did)%jx) -! endif + call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & + gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & + gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & + gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & + gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & + gw2d(did)%istep) + + +! bftodo head postprocessing block +! GW-SOIL-CHANNEL interaction section + gw2d(did)%ho = gw2d(did)%h +#ifdef HYDRO_D + write(6,*) "*****bf******end 2d_gw_model " +#endif + + End if + END IF !DJG (End if for RTE SWC activation) +!------------------------------------------------------------------ +!DJG End GW/Baseflow Routines +!------------------------------------------------------------------- + + + end subroutine driveGwBaseflow + + + + +!------------------------------------------- + subroutine driveChannelRouting(did) + + implicit none + integer, intent(in) :: did + +!------------------------------------------------------------------- +!------------------------------------------------------------------- +!DJG,DNY Begin Channel and Lake Routing Routines +!------------------------------------------------------------------- + IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN + + call drive_CHANNEL(RT_DOMAIN(did)%latval,RT_DOMAIN(did)%lonval, & + RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, & + RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS,& + RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& + RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& + RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT, & + RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTCT,nlst_rt(did)%DTRT,& + RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & + RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& + RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & + RT_DOMAIN(did)%Bw,& + RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,& + RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, & + RT_DOMAIN(did)%ORIFICEA, & + RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & + RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& + RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & + RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, & + RT_DOMAIN(did)%RETDEP_CHAN & + , RT_DOMAIN(did)%node_area & +#ifdef MPP_LAND + ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& + RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & + RT_DOMAIN(did)%yw_mpp_nlinks & +#endif + ) + endif +#ifdef HYDRO_D + write(6,*) "*****yw******end drive_CHANNEL " +#endif + + end subroutine driveChannelRouting + + + +!------------------------------------------------ + subroutine aggregateDomain(did) + + implicit none + integer, intent(in) :: did + integer :: i, j, krt, ixxrt, jyyrt, & + AGGFACYRT, AGGFACXRT +#ifdef HYDRO_D + print *, "Beginning Aggregation..." +#endif - IF (nlst_rt(did)%GWBASESWCRT .ne. 0 & - .or. nlst_rt(did)%SUBRTSWCRT .NE.0 & - .or. nlst_rt(did)%OVRTSWCRT .NE. 0 ) THEN + do J=1,RT_DOMAIN(did)%JX + do I=1,RT_DOMAIN(did)%IX -! running routing model - call exeRouting(did) + RT_DOMAIN(did)%SFCHEADAGGRT = 0. +!DJG Subgrid weighting edit... + RT_DOMAIN(did)%LSMVOL=0. + do KRT=1,nlst_rt(did)%NSOIL +! SMCAGGRT(KRT) = 0. + RT_DOMAIN(did)%SH2OAGGRT(KRT) = 0. + end do - END IF ! End if for channel routing option + do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1 + do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1 -! advance to next time step -! if( - call HYDRO_time_adv(did) - ! output for history - call HYDRO_out(did) + IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT + JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#else +!yw ???? +! IXXRT=IXXRT+1 +! JYYRT=JYYRT+1 +#endif + +!State Variables + RT_DOMAIN(did)%SFCHEADAGGRT = RT_DOMAIN(did)%SFCHEADAGGRT & + + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) +!DJG Subgrid weighting edit... + RT_DOMAIN(did)%LSMVOL = RT_DOMAIN(did)%LSMVOL & + + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) & + * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9) + + do KRT=1,nlst_rt(did)%NSOIL +!DJG SMCAGGRT(KRT)=SMCAGGRT(KRT)+SMCRT(IXXRT,JYYRT,KRT) + RT_DOMAIN(did)%SH2OAGGRT(KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & + + RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) + end do + + end do + end do - - RT_DOMAIN(did)%SOLDRAIN = 0 - RT_DOMAIN(did)%QSUBRT = 0 + RT_DOMAIN(did)%SFCHEADRT(I,J) = RT_DOMAIN(did)%SFCHEADAGGRT & + / (nlst_rt(did)%AGGFACTRT**2) + + do KRT=1,nlst_rt(did)%NSOIL +!DJG SMC(I,J,KRT)=SMCAGGRT(KRT)/(AGGFACTRT**2) + RT_DOMAIN(did)%SH2OX(I,J,KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & + / (nlst_rt(did)%AGGFACTRT**2) + end do - end subroutine HYDRO_exe +!DJG Calculate subgrid weighting array... + + do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1 + do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1 + IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT + JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#else +!yw ??? +! IXXRT=IXXRT+1 +! JYYRT=JYYRT+1 +#endif + if (RT_DOMAIN(did)%LSMVOL.gt.0.) then + RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & + = RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) & + * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9) & + / RT_DOMAIN(did)%LSMVOL + else + RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & + = 1./FLOAT(nlst_rt(did)%AGGFACTRT**2) + end if + + do KRT=1,nlst_rt(did)%NSOIL + +!!!yw added for debug + if(RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .lt. 0) then + print*, "Error negative SMCRT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + endif + if(RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) .lt. 0) then + print *, "Error negative SH2OWGT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + endif + +!end + IF (RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .GT. & + RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT)) THEN +#ifdef HYDRO_D + print *, "SMCMAX exceeded upon aggregation...", & + RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT), & + RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT) + call hydro_stop("aggregateDomain") +#endif + END IF + IF(RT_DOMAIN(did)%SH2OX(I,J,KRT).LE.0.) THEN +#ifdef HYDRO_D + print *, "Erroneous value of SH2O...", & + RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT + print *, "Error negative SH2OX", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) + call hydro_stop("aggregateDomain") +#endif + END IF + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) & + = RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) & + / RT_DOMAIN(did)%SH2OX(I,J,KRT) +!?yw + RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = max(1.0E-30, RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT)) + end do + + end do + end do + + end do + end do + + +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(RT_DOMAIN(did)%INFXSWGT, & + RT_DOMAIN(did)%IXRT, & + RT_DOMAIN(did)%JXRT, 99) + + do i = 1, nlst_rt(did)%NSOIL + call MPP_LAND_COM_REAL(RT_DOMAIN(did)%SH2OWGT(:,:,i), & + RT_DOMAIN(did)%IXRT, & + RT_DOMAIN(did)%JXRT, 99) + end do +#endif + +!DJG Update SMC with SICE (unchanged) and new value of SH2O from routing... + RT_DOMAIN(did)%SMC = RT_DOMAIN(did)%SH2OX + RT_DOMAIN(did)%SICE +#ifdef HYDRO_D + print *, "Finished Aggregation..." +#endif + + + end subroutine aggregateDomain + + subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) implicit none @@ -962,6 +859,7 @@ subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) write(6,*) "finish LandRT_ini" #endif + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! IF (nlst_rt(did)%TERADJ_SOLAR.EQ.1 .and. nlst_rt(did)%CHANRTSWCRT.NE.2) THEN ! Perform ter rain adjustment of incoming solar @@ -987,13 +885,22 @@ subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) endif +! if (trim(nlst_rt(did)%restart_file) == "") then +! output at the initial time +! call HYDRO_out(did) +! return +! endif -! if(rt_domain(did)%rst_flag .eq. -99 ) return ! restart the file + + ! jummp the initial time output +! rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1 +! rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1 + call HYDRO_rst_in(did) -! output at the initial time - call HYDRO_out(did) + +! call HYDRO_out(did) end subroutine HYDRO_ini @@ -1088,7 +995,8 @@ subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) rt_domain(did)%lksat = 0.0 do j = 1, RT_DOMAIN(did)%jx do i = 1, RT_DOMAIN(did)%ix - rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 + !yw rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 + rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN ! urban rt_domain(did)%SMCMAX1(i,j) = 0.45 rt_domain(did)%SMCREF1(i,j) = 0.42 @@ -1110,10 +1018,15 @@ end subroutine lsm_input end module module_HYDRO_drv ! stop the job due to the fatal error. - subroutine HYDRO_stop() + subroutine HYDRO_stop(msg) +#ifdef MPP_LAND + use module_mpp_land +#endif + character(len=*) :: msg integer :: ierr #ifdef HYDRO_D - write(6,*) "The job is stoped due to the fatal error." + write(6,*) "The job is stoped due to the fatal error. ", trim(msg) + flush(6) #endif #ifdef MPP_LAND #ifndef HYDRO_D @@ -1121,6 +1034,11 @@ subroutine HYDRO_stop() print*, "ERROR! Program stopped. Recompile with environment variable HYDRO_D set to 1 for enhanced debug information." print*, "" #endif + +! call mpp_land_sync() +! write(my_id+90,*) msg +! flush(my_id+90) + call mpp_land_abort() call MPI_finalize(ierr) #else @@ -1130,6 +1048,7 @@ subroutine HYDRO_stop() return end subroutine HYDRO_stop + ! stop the job due to the fatal error. subroutine HYDRO_finish() #ifdef MPP_LAND @@ -1140,6 +1059,7 @@ subroutine HYDRO_finish() print*, "The model finished successfully......." #ifdef MPP_LAND ! call mpp_land_abort() + flush(6) call mpp_land_sync() call MPI_finalize(ierr) stop @@ -1149,4 +1069,3 @@ subroutine HYDRO_finish() return end subroutine HYDRO_finish - diff --git a/wrfv2_fire/hydro/MPP/.svn/all-wcprops b/wrfv2_fire/hydro/MPP/.svn/all-wcprops new file mode 100644 index 00000000..b62c0e7b --- /dev/null +++ b/wrfv2_fire/hydro/MPP/.svn/all-wcprops @@ -0,0 +1,23 @@ +K 25 +svn:wc:ra_dav:version-url +V 56 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/MPP +END +CPL_WRF.F +K 25 +svn:wc:ra_dav:version-url +V 66 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/MPP/CPL_WRF.F +END +Makefile +K 25 +svn:wc:ra_dav:version-url +V 65 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/MPP/Makefile +END +mpp_land.F +K 25 +svn:wc:ra_dav:version-url +V 67 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/MPP/mpp_land.F +END diff --git a/wrfv2_fire/hydro/MPP/.svn/entries b/wrfv2_fire/hydro/MPP/.svn/entries new file mode 100644 index 00000000..8cffcbf8 --- /dev/null +++ b/wrfv2_fire/hydro/MPP/.svn/entries @@ -0,0 +1,130 @@ +10 + +dir +9105 +https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/MPP +https://kkeene@svn-wrf-model.cgd.ucar.edu + + + +2015-01-23T18:49:15.035273Z +8003 +gill + + + + + + + + + + + + + + +b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d + +CPL_WRF.F +file + + + + +2016-02-11T20:37:50.152130Z +7185bcd723e0f65d8c6f376749eef4c5 +2013-11-15T19:40:36.446206Z +6964 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +4481 + +Makefile +file + + + + +2016-02-11T20:37:50.149954Z +80b086e907e5a44f1bc069d50007290a +2012-12-07T20:01:45.900797Z +6094 +gill + + + + + + + + + + + + + + + + + + + + + +529 + +mpp_land.F +file + + + + +2016-02-11T20:37:50.151125Z +69e53e4ef44c840d3da76d9faec33837 +2015-01-23T18:49:15.035273Z +8003 +gill + + + + + + + + + + + + + + + + + + + + + +62275 + diff --git a/wrfv2_fire/hydro/MPP/.svn/text-base/CPL_WRF.F.svn-base b/wrfv2_fire/hydro/MPP/.svn/text-base/CPL_WRF.F.svn-base new file mode 100644 index 00000000..45876b9b --- /dev/null +++ b/wrfv2_fire/hydro/MPP/.svn/text-base/CPL_WRF.F.svn-base @@ -0,0 +1,159 @@ +! This is used as a coupler with the WRF model. +MODULE MODULE_CPL_LAND + + + IMPLICIT NONE + + integer my_global_id + + integer total_pe_num + integer global_ix,global_jx + + integer,allocatable,dimension(:,:) :: node_info + + logical initialized, cpl_land, time_step_read_rstart, & + time_step_write_rstart, time_step_output + character(len=19) cpl_outdate, cpl_rstdate + + + + contains + + subroutine CPL_LAND_INIT(istart,iend,jstart,jend) + implicit none + include "mpif.h" + integer ierr + logical mpi_inited + integer istart,iend,jstart,jend + + CALL mpi_initialized( mpi_inited, ierr ) + if ( .NOT. mpi_inited ) then + call mpi_init(ierr) + endif + + call MPI_COMM_RANK( MPI_COMM_WORLD, my_global_id, ierr ) + call MPI_COMM_SIZE( MPI_COMM_WORLD, total_pe_num, ierr ) + + allocate(node_info(9,total_pe_num)) + + node_info = -99 + +! send node info to node 0 + node_info(1,my_global_id+1) = total_pe_num + node_info(6,my_global_id+1) = istart + node_info(7,my_global_id+1) = iend + node_info(8,my_global_id+1) = jstart + node_info(9,my_global_id+1) = jend + + + call send_info() + call find_left() + call find_right() + call find_up() + call find_down() + + call send_info() + + initialized = .false. ! land model need to be initialized. + return + END subroutine CPL_LAND_INIT + + subroutine send_info() + implicit none + include "mpif.h" + integer,allocatable,dimension(:,:) :: tmp_info + integer ierr, i,size, tag + integer mpp_status(MPI_STATUS_SIZE) + tag = 9 + size = 9 + + if(my_global_id .eq. 0) then + do i = 1, total_pe_num-1 + call mpi_recv(node_info(:,i+1),size,MPI_INTEGER, & + i,tag,MPI_COMM_WORLD,mpp_status,ierr) + enddo + else + call mpi_send(node_info(:,my_global_id+1),size, & + MPI_INTEGER,0,tag,MPI_COMM_WORLD,ierr) + endif + + call MPI_barrier( MPI_COMM_WORLD ,ierr) + + size = 9 * total_pe_num + call mpi_bcast(node_info,size,MPI_INTEGER, & + 0,MPI_COMM_WORLD,ierr) + + call MPI_barrier( MPI_COMM_WORLD ,ierr) + + return + end subroutine send_info + + subroutine find_left() + implicit none + integer i + + node_info(2,my_global_id+1) = -1 + + do i = 1, total_pe_num + if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. & + (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. & + ((node_info(7,i)+1).eq.node_info(6,my_global_id+1)) ) then + node_info(2,my_global_id+1) = i - 1 + return + endif + end do + return + end subroutine find_left + + subroutine find_right() + implicit none + integer i + + node_info(3,my_global_id+1) = -1 + + do i = 1, total_pe_num + if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. & + (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. & + ((node_info(6,i)-1).eq.node_info(7,my_global_id+1)) ) then + node_info(3,my_global_id+1) = i - 1 + return + endif + end do + return + end subroutine find_right + + subroutine find_up() + implicit none + integer i + + node_info(4,my_global_id+1) = -1 + + do i = 1, total_pe_num + if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. & + (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. & + ((node_info(8,i)-1).eq.node_info(9,my_global_id+1)) ) then + node_info(4,my_global_id+1) = i - 1 + return + endif + end do + return + end subroutine find_up + + subroutine find_down() + implicit none + integer i + + node_info(5,my_global_id+1) = -1 + + do i = 1, total_pe_num + if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. & + (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. & + ((node_info(9,i)+1).eq.node_info(8,my_global_id+1)) ) then + node_info(5,my_global_id+1) = i - 1 + return + endif + end do + return + end subroutine find_down + +END MODULE MODULE_CPL_LAND diff --git a/wrfv2_fire/hydro/MPP/.svn/text-base/Makefile.svn-base b/wrfv2_fire/hydro/MPP/.svn/text-base/Makefile.svn-base new file mode 100644 index 00000000..abc0b055 --- /dev/null +++ b/wrfv2_fire/hydro/MPP/.svn/text-base/Makefile.svn-base @@ -0,0 +1,26 @@ +# Makefile +# +.SUFFIXES: +.SUFFIXES: .o .F + +include ../macros + +OBJS = CPL_WRF.o mpp_land.o + +all: $(OBJS) +mpp_land.o: mpp_land.F + @echo "" + $(RMD) $(*).o $(*).mod $(*).stb *~ + $(COMPILER90) $(F90FLAGS) -c $(*).F + ar -r ../lib/libHYDRO.a $(@) + +CPL_WRF.o: CPL_WRF.F + @echo "" + $(RMD) $(*).o $(*).mod $(*).stb *~ *.f + $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f + $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f + + $(COMPILER90) $(F90FLAGS) -c $(*).F + ar -r ../lib/libHYDRO.a $(@) +clean: + $(RMD) *.o *.mod *.stb *~ diff --git a/wrfv2_fire/hydro/MPP/.svn/text-base/mpp_land.F.svn-base b/wrfv2_fire/hydro/MPP/.svn/text-base/mpp_land.F.svn-base new file mode 100644 index 00000000..e3935c3c --- /dev/null +++ b/wrfv2_fire/hydro/MPP/.svn/text-base/mpp_land.F.svn-base @@ -0,0 +1,1876 @@ +!#### This is a module for parallel Land model. +MODULE MODULE_MPP_LAND + + use MODULE_CPL_LAND + + IMPLICIT NONE + include "mpif.h" + integer, public :: left_id,right_id,up_id,down_id,my_id + integer, public :: left_right_np,up_down_np ! define total process in two dimensions. + integer, public :: left_right_p ,up_down_p ! the position of the current process in the logical topography. + integer, public :: IO_id ! the number for IO. (Last processor for IO) + integer, public :: global_nx, global_ny, local_nx,local_ny + integer, public :: global_rt_nx, global_rt_ny + integer, public :: local_rt_nx,local_rt_ny,rt_AGGFACTRT + integer, public :: numprocs ! total process, get by mpi initialization. + integer :: local_startx, local_starty + + integer mpp_status(MPI_STATUS_SIZE) + + integer overlap_n + integer, allocatable, DIMENSION(:), public :: local_nx_size,local_ny_size + integer, allocatable, DIMENSION(:), public :: local_rt_nx_size,local_rt_ny_size + integer, allocatable, DIMENSION(:), public :: startx,starty + integer, allocatable, DIMENSION(:), public :: mpp_nlinks + + interface check_land + module procedure check_landreal1 + module procedure check_landreal1d + module procedure check_landreal2d + module procedure check_landreal3d + end interface + interface write_io_land + module procedure write_io_real3d + end interface + interface mpp_land_bcast + module procedure mpp_land_bcast_real2 + module procedure mpp_land_bcast_real_1d + module procedure mpp_land_bcast_real1 + module procedure mpp_land_bcast_char1d + module procedure mpp_land_bcast_char1 + module procedure mpp_land_bcast_int1 + module procedure mpp_land_bcast_int1d + module procedure mpp_land_bcast_int2d + module procedure mpp_land_bcast_logical + end interface + + contains + + subroutine LOG_MAP2d() + implicit none + integer :: ierr + call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) + call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) + + call getNX_NY(numprocs, left_right_np,up_down_np) + if(my_id.eq.IO_id) then +#ifdef HYDRO_D + write(6,*) "" + write(6,*) "total process:",numprocs + write(6,*) "left_right_np =", left_right_np,& + "up_down_np=",up_down_np +#endif + end if + +! ### get the row and column of the current process in the logical topography. +! ### left --> right, 0 -->left_right_np -1 +! ### up --> down, 0 --> up_down_np -1 + left_right_p = mod(my_id , left_right_np) + up_down_p = my_id / left_right_np + +! ### get the neighbors. -1 means no neighbor. + down_id = my_id - left_right_np + up_id = my_id + left_right_np + if( up_down_p .eq. 0) down_id = -1 + if( up_down_p .eq. (up_down_np-1) ) up_id = -1 + + left_id = my_id - 1 + right_id = my_id + 1 + if( left_right_p .eq. 0) left_id = -1 + if( left_right_p .eq. (left_right_np-1) ) right_id =-1 + +! ### the IO node is the last processor. +!yw IO_id = numprocs - 1 + IO_id = 0 + +! print the information for debug. + + call mpp_land_sync() + + return + end subroutine log_map2d +!old subroutine MPP_LAND_INIT(flag, ew_numprocs, sn_numprocs) + subroutine MPP_LAND_INIT() +! ### initialize the land model logically based on the two D method. +! ### Call this function directly if it is nested with WRF. + implicit none + integer :: ierr + integer :: ew_numprocs, sn_numprocs ! input the processors in x and y direction. + logical mpi_inited + +! left_right_np = ew_numprocs +! up_down_np = sn_numprocs + + CALL mpi_initialized( mpi_inited, ierr ) + if ( .NOT. mpi_inited ) then + call MPI_INIT( ierr ) ! stand alone land model. + else + call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) + call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) + return + endif +! create 2d logical mapping of the CPU. + call log_map2d() + + return + end subroutine MPP_LAND_INIT + + + subroutine MPP_LAND_PAR_INI(over_lap,in_global_nx,in_global_ny,AGGFACTRT) + integer in_global_nx,in_global_ny, AGGFACTRT + integer :: over_lap ! the overlaped grid number. (default is 1) + integer :: i + + global_nx = in_global_nx + global_ny = in_global_ny + rt_AGGFACTRT = AGGFACTRT + global_rt_nx = in_global_nx*AGGFACTRT + global_rt_ny = in_global_ny *AGGFACTRT + !overlap_n = 1 +!ywold local_nx = global_nx / left_right_np +!ywold if(left_right_p .eq. (left_right_np-1) ) then +!ywold local_nx = global_nx & +!ywold -int(global_nx/left_right_np)*(left_right_np-1) +!ywold end if +!ywold local_ny = global_ny / up_down_np +!ywold if( up_down_p .eq. (up_down_np-1) ) then +!ywold local_ny = global_ny & +!ywold -int(global_ny/up_down_np)*(up_down_np -1) +!ywold end if + + local_nx = int(global_nx / left_right_np) + !if(global_nx .ne. (local_nx*left_right_np) ) then + if(mod(global_nx, left_right_np) .ne. 0) then + do i = 1, mod(global_nx, left_right_np) + if(left_right_p .eq. i ) then + local_nx = local_nx + 1 + end if + end do + end if + + local_ny = int(global_ny / up_down_np) + !if(global_ny .ne. (local_ny * up_down_np) ) then + if(mod(global_ny,up_down_np) .ne. 0 ) then + do i = 1, mod(global_ny,up_down_np) + if( up_down_p .eq. i) then + local_ny = local_ny + 1 + end if + end do + end if + + local_rt_nx=local_nx*AGGFACTRT+2 + local_rt_ny=local_ny*AGGFACTRT+2 + if(left_id.lt.0) local_rt_nx = local_rt_nx -1 + if(right_id.lt.0) local_rt_nx = local_rt_nx -1 + if(up_id.lt.0) local_rt_ny = local_rt_ny -1 + if(down_id.lt.0) local_rt_ny = local_rt_ny -1 + + call get_local_size(local_nx, local_ny,local_rt_nx,local_rt_ny) + call calculate_start_p() + + in_global_nx = local_nx + in_global_ny = local_ny +#ifdef HYDRO_D + write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_nx + write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_ny + write(6,*) "my_id=",my_id,"global_nx=",global_nx + write(6,*) "my_id=",my_id,"global_nx=",global_ny +#endif + return + end subroutine MPP_LAND_PAR_INI + + subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) +! ### Communicate message on left right direction. + integer NX,NY + real in_out_data(nx,ny),data_r(2,ny) + integer count,size,tag, ierr + integer flag ! 99 replace the boundary, else get the sum. + + if(flag .eq. 99) then ! replace the data + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = ny + call mpi_send(in_out_data(nx-1,:),size,MPI_REAL, & + right_id,tag,MPI_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = ny + call mpi_recv(in_out_data(1,:),size,MPI_REAL, & + left_id,tag,MPI_COMM_WORLD,mpp_status,ierr) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = ny + tag = 21 + call mpi_send(in_out_data(2,:),size,MPI_REAL, & + left_id,tag,MPI_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = ny + call mpi_recv(in_out_data(nx,:),size,MPI_REAL,& + right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) + endif + + else ! get the sum + + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = 2*ny + call mpi_send(in_out_data(nx-1:nx,:),size,MPI_REAL, & + right_id,tag,MPI_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = 2*ny + call mpi_recv(data_r,size,MPI_REAL,left_id,tag, & + MPI_COMM_WORLD,mpp_status,ierr) + in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) + in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = 2*ny + tag = 21 + call mpi_send(in_out_data(1:2,:),size,MPI_REAL, & + left_id,tag,MPI_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = 2*ny + call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_REAL,& + right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) + endif + endif ! end if black for flag. + + return + end subroutine MPP_LAND_LR_COM + + subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) +! ### Communicate message on left right direction. + integer NX,NY + real*8 in_out_data(nx,ny),data_r(2,ny) + integer count,size,tag, ierr + integer flag ! 99 replace the boundary, else get the sum. + + if(flag .eq. 99) then ! replace the data + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = ny + call mpi_send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION, & + right_id,tag,MPI_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = ny + call mpi_recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION, & + left_id,tag,MPI_COMM_WORLD,mpp_status,ierr) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = ny + tag = 21 + call mpi_send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION, & + left_id,tag,MPI_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = ny + call mpi_recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,& + right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) + endif + + else ! get the sum + + if(right_id .ge. 0) then ! ### send to right first. + tag = 11 + size = 2*ny + call mpi_send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION, & + right_id,tag,MPI_COMM_WORLD,ierr) + end if + if(left_id .ge. 0) then ! receive from left + tag = 11 + size = 2*ny + call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, & + MPI_COMM_WORLD,mpp_status,ierr) + in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) + in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) + endif + + if(left_id .ge. 0 ) then ! ### send to left second. + size = 2*ny + tag = 21 + call mpi_send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION, & + left_id,tag,MPI_COMM_WORLD,ierr) + endif + if(right_id .ge. 0) then ! receive from right + tag = 21 + size = 2*ny + call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,& + right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) + endif + endif ! end if black for flag. + + return + end subroutine MPP_LAND_LR_COM8 + + + subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) + integer local_nx, local_ny, rt_nx,rt_ny + integer i,status,ierr, tag + integer tmp_nx,tmp_ny +! ### if it is IO node, get the local_size of the x and y direction +! ### for all other tasks. + integer s_r(2) + +! if(my_id .eq. IO_id) then + allocate(local_nx_size(numprocs),stat = status) + allocate(local_ny_size(numprocs),stat = status) + allocate(local_rt_nx_size(numprocs),stat = status) + allocate(local_rt_ny_size(numprocs),stat = status) +! end if + + call mpp_land_sync() + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 1 + call mpi_recv(s_r,2,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + local_nx_size(i+1) = s_r(1) + local_ny_size(i+1) = s_r(2) + else + local_nx_size(i+1) = local_nx + local_ny_size(i+1) = local_ny + end if + end do + else + tag = 1 + s_r(1) = local_nx + s_r(2) = local_ny + call mpi_send(s_r,2,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + end if + + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 2 + call mpi_recv(s_r,2,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + local_rt_nx_size(i+1) = s_r(1) + local_rt_ny_size(i+1) = s_r(2) + else + local_rt_nx_size(i+1) = rt_nx + local_rt_ny_size(i+1) = rt_ny + end if + end do + else + tag = 2 + s_r(1) = rt_nx + s_r(2) = rt_ny + call mpi_send(s_r,2,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + end if + call mpp_land_sync() + return + end subroutine get_local_size + + + subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) +! ### Communicate message on up down direction. + integer NX,NY + real in_out_data(nx,ny),data_r(nx,2) + integer count,size,tag, status, ierr + integer flag ! 99 replace the boundary , else get the sum of the boundary + + + if(flag .eq. 99) then ! replace the boundary data. + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx + call mpi_send(in_out_data(:,ny-1),size,MPI_REAL, & + up_id,tag,MPI_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx + call mpi_recv(in_out_data(:,1),size,MPI_REAL, & + down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx + call mpi_send(in_out_data(:,2),size,MPI_REAL, & + down_id,tag,MPI_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx + call mpi_recv(in_out_data(:,ny),size,MPI_REAL, & + up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) + endif + + else ! flag = 1 + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx*2 + call mpi_send(in_out_data(:,ny-1:ny),size,MPI_REAL, & + up_id,tag,MPI_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx*2 + call mpi_recv(data_r,size,MPI_REAL, & + down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) + in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) + in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx*2 + call mpi_send(in_out_data(:,1:2),size,MPI_REAL, & + down_id,tag,MPI_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx * 2 + call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_REAL, & + up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) + endif + endif ! end of block flag + return + end subroutine MPP_LAND_UB_COM + + subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) +! ### Communicate message on up down direction. + integer NX,NY + real*8 in_out_data(nx,ny),data_r(nx,2) + integer count,size,tag, status, ierr + integer flag ! 99 replace the boundary , else get the sum of the boundary + + + if(flag .eq. 99) then ! replace the boundary data. + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx + call mpi_send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION, & + up_id,tag,MPI_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx + call mpi_recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, & + down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx + call mpi_send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION, & + down_id,tag,MPI_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx + call mpi_recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, & + up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) + endif + + else ! flag = 1 + + if(up_id .ge. 0 ) then ! ### send to up first. + tag = 31 + size = nx*2 + call mpi_send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & + up_id,tag,MPI_COMM_WORLD,ierr) + endif + if(down_id .ge. 0 ) then ! receive from down + tag = 31 + size = nx*2 + call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION, & + down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) + in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) + in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) + endif + + if(down_id .ge. 0 ) then ! send down. + tag = 41 + size = nx*2 + call mpi_send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION, & + down_id,tag,MPI_COMM_WORLD,ierr) + endif + if(up_id .ge. 0 ) then ! receive from upper + tag = 41 + size = nx * 2 + call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & + up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) + endif + endif ! end of block flag + return + end subroutine MPP_LAND_UB_COM8 + + subroutine calculate_start_p() +! calculate startx and starty + integer :: i,status, ierr, tag + integer :: r_s(2) + integer :: t_nx, t_ny + + allocate(starty(numprocs),stat = ierr) + allocate(startx(numprocs),stat = ierr) + + local_startx = int(global_nx/left_right_np) * left_right_p+1 + local_starty = int(global_ny/up_down_np) * up_down_p+1 + +!ywold + t_nx = 0 + do i = 1, mod(global_nx,left_right_np) + if(left_right_p .gt. i ) then + t_nx = t_nx + 1 + end if + end do + local_startx = local_startx + t_nx + + t_ny = 0 + do i = 1, mod(global_ny,up_down_np) + if( up_down_p .gt. i) then + t_ny = t_ny + 1 + end if + end do + local_starty = local_starty + t_ny + + + if(left_id .lt. 0) local_startx = 1 + if(down_id .lt. 0) local_starty = 1 + + + if(my_id .eq. IO_id) then + startx(my_id+1) = local_startx + starty(my_id+1) = local_starty + end if + + r_s(1) = local_startx + r_s(2) = local_starty + call mpp_land_sync() + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ! block receive from other node. + if(i.ne.my_id) then + tag = 1 + call mpi_recv(r_s,2,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + startx(i+1) = r_s(1) + starty(i+1) = r_s(2) + end if + end do + else + tag = 1 + call mpi_send(r_s,2,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + end if + + call mpp_land_sync() + + return + end subroutine calculate_start_p + + subroutine decompose_data_real3d (in_buff,out_buff,klevel) + implicit none + integer:: klevel, k + real in_buff(global_nx,1:klevel,global_ny),out_buff(local_nx,1:klevel,local_ny) + do k = 1, klevel + call decompose_data_real(in_buff(:,k,:),out_buff(:,k,:)) + end do + end subroutine decompose_data_real3d + + + subroutine decompose_data_real (in_buff,out_buff) +! usage: all of the cpu call this subroutine. +! the IO node will distribute the data to rest of the node. + real in_buff(global_nx,global_ny),out_buff(local_nx,local_ny) + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1) + iend = startx(i+1)+local_nx_size(i+1) -1 + jbegin = starty(i+1) + jend = starty(i+1)+local_ny_size(i+1) -1 + + if(my_id .eq. i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = local_nx_size(i+1)*local_ny_size(i+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_REAL, i,tag,MPI_COMM_WORLD,ierr) + end if + end do + else + size = local_nx*local_ny + call mpi_recv(out_buff,size,MPI_REAL,IO_id, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_data_real + + subroutine decompose_data_int (in_buff,out_buff) +! usage: all of the cpu call this subroutine. +! the IO node will distribute the data to rest of the node. + integer in_buff(global_nx,global_ny),out_buff(local_nx,local_ny) + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1) + iend = startx(i+1)+local_nx_size(i+1) -1 + jbegin = starty(i+1) + jend = starty(i+1)+local_ny_size(i+1) -1 + if(my_id .eq. i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = local_nx_size(i+1)*local_ny_size(i+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER, i,tag,MPI_COMM_WORLD,ierr) + end if + end do + else + size = local_nx*local_ny + call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_data_int + + subroutine write_IO_int(in_buff,out_buff) +! the IO node will receive the data from the rest process. + integer in_buff(1:local_nx,1:local_ny), & + out_buff(global_nx,global_ny) + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + if(my_id .ne. IO_id) then + size = local_nx*local_ny + tag = 2 + call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + ibegin = startx(i+1) + iend = startx(i+1)+local_nx_size(i+1) -1 + jbegin = starty(i+1) + jend = starty(i+1)+local_ny_size(i+1) -1 + if(i .eq. IO_id) then + out_buff(ibegin:iend,jbegin:jend) = in_buff + else + size = local_nx_size(i+1)*local_ny_size(i+1) + tag = 2 + call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + return + end subroutine write_IO_int + + subroutine write_IO_real3d(in_buff,out_buff,klevel) + implicit none +! the IO node will receive the data from the rest process. + integer klevel, k + real in_buff(1:local_nx,1:klevel,1:local_ny), & + out_buff(global_nx,1:klevel,global_ny) + do k = 1, klevel + call write_IO_real(in_buff(:,k,:),out_buff(:,k,:)) + end do + end subroutine write_IO_real3d + + subroutine write_IO_real(in_buff,out_buff) +! the IO node will receive the data from the rest process. + real in_buff(1:local_nx,1:local_ny), & + out_buff(global_nx,global_ny) + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + if(my_id .ne. IO_id) then + size = local_nx*local_ny + tag = 2 + call mpi_send(in_buff,size,MPI_REAL, IO_id, & + tag,MPI_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + ibegin = startx(i+1) + iend = startx(i+1)+local_nx_size(i+1) -1 + jbegin = starty(i+1) + jend = starty(i+1)+local_ny_size(i+1) -1 + if(i .eq. IO_id) then + out_buff(ibegin:iend,jbegin:jend) = in_buff + else + size = local_nx_size(i+1)*local_ny_size(i+1) + tag = 2 + call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + MPI_REAL,i,tag,MPI_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + return + end subroutine write_IO_real + + subroutine write_IO_RT_real(in_buff,out_buff) +! the IO node will receive the data from the rest process. + real in_buff(1:local_rt_nx,1:local_rt_ny), & + out_buff(global_rt_nx,global_rt_ny) + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + if(my_id .ne. IO_id) then + size = local_rt_nx*local_rt_ny + tag = 2 + call mpi_send(in_buff,size,MPI_REAL, IO_id, & + tag,MPI_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin.gt.1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin.gt.1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + if(i .eq. IO_id) then + out_buff(ibegin:iend,jbegin:jend) = in_buff + else + size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) + tag = 2 + call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + MPI_REAL,i,tag,MPI_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + return + end subroutine write_IO_RT_real + + + subroutine write_IO_RT_int (in_buff,out_buff) +! the IO node will receive the data from the rest process. + integer :: in_buff(1:local_rt_nx,1:local_rt_ny), & + out_buff(global_rt_nx,global_rt_ny) + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + if(my_id .ne. IO_id) then + size = local_rt_nx*local_rt_ny + tag = 2 + call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + else + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin.gt.1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin.gt.1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + if(i .eq. IO_id) then + out_buff(ibegin:iend,jbegin:jend) = in_buff + else + size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) + tag = 2 + call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr) + end if + end do + end if + return + end subroutine write_IO_RT_int + + subroutine mpp_land_sync() + integer ierr + call MPI_barrier( MPI_COMM_WORLD ,ierr) + return + end subroutine mpp_land_sync + +! subroutine mpp_land_sync() +! integer tag, i, status, ierr,size +! integer buff(2) +! +! size =2 +! buff = 3 +! if(my_id .ne. IO_id) then +! tag = 2 +! call mpi_send(buff,size,MPI_INTEGER, IO_id, & +! tag,MPI_COMM_WORLD,ierr) +! else +! do i = 0, numprocs - 1 +! tag = 2 +! if(i .ne. IO_id) then +! call mpi_recv(buff,size,& +! MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr) +! end if +! end do +! end if + +! return +! end subroutine mpp_land_sync + + + subroutine mpp_land_bcast_int(size,inout) + integer size + integer inout(size) + integer ierr + call mpi_bcast(inout,size,MPI_INTEGER, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int + + subroutine mpp_land_bcast_int1d(inout) + integer len + integer inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_INTEGER, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int1d + + subroutine mpp_land_bcast_int1(inout) + integer inout + integer ierr + call mpi_bcast(inout,1,MPI_INTEGER, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int1 + + subroutine mpp_land_bcast_logical(inout) + logical :: inout + integer ierr + call mpi_bcast(inout,1,MPI_LOGICAL, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_logical + + subroutine mpp_land_bcast_real1(inout) + real inout + integer ierr + call mpi_bcast(inout,1,MPI_REAL, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real1 + + subroutine mpp_land_bcast_real_1d(inout) + integer len + real inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_real, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real_1d + + subroutine mpp_land_bcast_real(size,inout) + integer size + real inout(size) + integer ierr + call mpi_bcast(inout,size,MPI_real, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real + + subroutine mpp_land_bcast_int2d(inout) + integer length1, k,length2 + integer inout(:,:) + integer ierr + length1 = size(inout,1) + length2 = size(inout,2) + do k = 1, length2 + call mpi_bcast(inout(:,k),length1,MPI_INTEGER, & + IO_id,MPI_COMM_WORLD,ierr) + end do + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int2d + + subroutine mpp_land_bcast_real2(inout) + integer length1, k,length2 + real inout(:,:) + integer ierr + length1 = size(inout,1) + length2 = size(inout,2) + do k = 1, length2 + call mpi_bcast(inout(:,k),length1,MPI_real, & + IO_id,MPI_COMM_WORLD,ierr) + end do + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real2 + + subroutine mpp_land_bcast_rd(size,inout) + integer size + real*8 inout(size) + integer ierr + call mpi_bcast(inout,size,MPI_REAL8, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_rd + + subroutine mpp_land_bcast_char(size,inout) + integer size + character inout(*) + integer ierr + call mpi_bcast(inout,size,MPI_CHARACTER, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_char + + subroutine mpp_land_bcast_char1d(inout) + integer len + character inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_CHARACTER, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_char1d + + subroutine mpp_land_bcast_char1(inout) + integer len + character(len=*) inout + integer ierr + len = LEN_TRIM(inout) + call mpi_bcast(inout,len,MPI_CHARACTER, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_char1 + + + subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag) +! ### Communicate message on left right and up bottom directions. + integer NX,NY + integer flag != 99 test only for land model. (replace the boundary). + != 1 get the sum of the boundary value. + real in_out_data(nx,ny) + + call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) + call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) + + return + end subroutine MPP_LAND_COM_REAL + + subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag) +! ### Communicate message on left right and up bottom directions. + integer NX,NY + integer flag != 99 test only for land model. (replace the boundary). + != 1 get the sum of the boundary value. + real*8 in_out_data(nx,ny) + + call MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) + call MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) + + return + end subroutine MPP_LAND_COM_REAL8 + + subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag) +! ### Communicate message on left right and up bottom directions. + integer NX,NY + integer flag != 99 test only for land model. (replace the boundary). + != 1 get the sum of the boundary value. + integer data(nx,ny) + real in_out_data(nx,ny) + + in_out_data = data + 0.0 + call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) + call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) + data = in_out_data + 0 + + return + end subroutine MPP_LAND_COM_INTEGER + + subroutine read_restart_3(unit,nz,out) + integer unit,nz,i + real buf3(global_nx,global_ny,nz),& + out(local_nx,local_ny,3) + if(my_id.eq.IO_id) read(unit) buf3 + do i = 1,nz + call decompose_data_real (buf3(:,:,i),out(:,:,i)) + end do + return + end subroutine read_restart_3 + + subroutine read_restart_2(unit,out) + integer unit,ierr2 + real buf2(global_nx,global_ny),& + out(local_nx,local_ny) + + if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 + call mpp_land_bcast_int1(ierr2) + if(ierr2 .ne. 0) return + + call decompose_data_real (buf2,out) + return + end subroutine read_restart_2 + + subroutine read_restart_rt_2(unit,out) + integer unit,ierr2 + real buf2(global_rt_nx,global_rt_ny),& + out(local_rt_nx,local_rt_ny) + + if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 + call mpp_land_bcast_int1(ierr2) + if(ierr2.ne.0) return + + call decompose_RT_real(buf2,out, & + global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) + return + end subroutine read_restart_rt_2 + + subroutine read_restart_rt_3(unit,nz,out) + integer unit,nz,i,ierr2 + real buf3(global_rt_nx,global_rt_ny,nz),& + out(local_rt_nx,local_rt_ny,3) + + if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf3 + call mpp_land_bcast_int1(ierr2) + if(ierr2.ne.0) return + + do i = 1,nz + call decompose_RT_real (buf3(:,:,i),out(:,:,i),& + global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) + end do + return + end subroutine read_restart_rt_3 + + subroutine write_restart_3(unit,nz,in) + integer unit,nz,i + real buf3(global_nx,global_ny,nz),& + in(local_nx,local_ny,nz) + do i = 1,nz + call write_IO_real(in(:,:,i),buf3(:,:,i)) + end do + if(my_id.eq.IO_id) write(unit) buf3 + return + end subroutine write_restart_3 + + subroutine write_restart_2(unit,in) + integer unit + real buf2(global_nx,global_ny),& + in(local_nx,local_ny) + call write_IO_real(in,buf2) + if(my_id.eq.IO_id) write(unit) buf2 + return + end subroutine write_restart_2 + + subroutine write_restart_rt_2(unit,in) + integer unit + real buf2(global_rt_nx,global_rt_ny), & + in(local_rt_nx,local_rt_ny) + call write_IO_RT_real(in,buf2) + if(my_id.eq.IO_id) write(unit) buf2 + return + end subroutine write_restart_rt_2 + + subroutine write_restart_rt_3(unit,nz,in) + integer unit,nz,i + real buf3(global_rt_nx,global_rt_ny,nz),& + in(local_rt_nx,local_rt_ny,nz) + do i = 1,nz + call write_IO_RT_real(in(:,:,i),buf3(:,:,i)) + end do + if(my_id.eq.IO_id) write(unit) buf3 + return + end subroutine write_restart_rt_3 + + subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny) +! usage: all of the cpu call this subroutine. +! the IO node will distribute the data to rest of the node. + integer g_nx,g_ny,nx,ny + real in_buff(g_nx,g_ny),out_buff(nx,ny) + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin.gt.1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin.gt.1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + + if(my_id .eq. i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = (iend-ibegin+1)*(jend-jbegin+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_REAL, i,tag,MPI_COMM_WORLD,ierr) + end if + end do + else + size = nx*ny + call mpi_recv(out_buff,size,MPI_REAL,IO_id, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_RT_real + + subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny) +! usage: all of the cpu call this subroutine. +! the IO node will distribute the data to rest of the node. + integer g_nx,g_ny,nx,ny + integer in_buff(g_nx,g_ny),out_buff(nx,ny) + integer tag, i, status, ierr,size + integer ibegin,iend,jbegin,jend + + tag = 2 + call mpp_land_sync() + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(ibegin.gt.1) ibegin=ibegin - 1 + iend = ibegin + local_rt_nx_size(i+1) -1 + jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) + if(jbegin.gt.1) jbegin=jbegin - 1 + jend = jbegin + local_rt_ny_size(i+1) -1 + + if(my_id .eq. i) then + out_buff=in_buff(ibegin:iend,jbegin:jend) + else + ! send data to the rest process. + size = (iend-ibegin+1)*(jend-jbegin+1) + call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& + MPI_INTEGER, i,tag,MPI_COMM_WORLD,ierr) + end if + end do + else + size = nx*ny + call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + end if + return + end subroutine decompose_RT_int + + subroutine getNX_NY(nprocs, nx,ny) + ! calculate the nx and ny based on the total nprocs. + integer nprocs, nx, ny + integer i,j, max + max = nprocs + do j = 1, nprocs + if( mod(nprocs,j) .eq. 0 ) then + i = nprocs/j + if( abs(i-j) .lt. max) then + max = abs(i-j) + nx = i + ny = j + end if + end if + end do + return + end subroutine getNX_NY + + subroutine pack_global_22(in, & + out,k) + integer ix,jx,k,i + real out(global_nx,global_ny,k) + real in(local_nx,local_ny,k) + do i = 1, k + call write_IO_real(in(:,:,i),out(:,:,i)) + enddo + return + end subroutine pack_global_22 + + + subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT) + implicit none + integer total_pe + integer info(9,total_pe),AGGFACTRT + integer :: ierr, status + integer i + + call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) + call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) + + if(numprocs .ne. total_pe) then + write(6,*) "Error: numprocs .ne. total_pe ",numprocs, total_pe + call mpp_land_abort() + endif + + +! ### get the neighbors. -1 means no neighbor. + left_id = info(2,my_id+1) + right_id = info(3,my_id+1) + up_id = info(4,my_id+1) + down_id = info(5,my_id+1) + IO_id = 0 + + allocate(local_nx_size(numprocs),stat = status) + allocate(local_ny_size(numprocs),stat = status) + allocate(local_rt_nx_size(numprocs),stat = status) + allocate(local_rt_ny_size(numprocs),stat = status) + allocate(starty(numprocs),stat = ierr) + allocate(startx(numprocs),stat = ierr) + + i = my_id + 1 + local_nx = info(7,i) - info(6,i) + 1 + local_ny = info(9,i) - info(8,i) + 1 + + global_nx = 0 + global_ny = 0 + do i = 1, numprocs + global_nx = max(global_nx,info(7,i)) + global_ny = max(global_ny,info(9,i)) + enddo + + local_rt_nx = local_nx*AGGFACTRT+2 + local_rt_ny = local_ny*AGGFACTRT+2 + if(left_id.lt.0) local_rt_nx = local_rt_nx -1 + if(right_id.lt.0) local_rt_nx = local_rt_nx -1 + if(up_id.lt.0) local_rt_ny = local_rt_ny -1 + if(down_id.lt.0) local_rt_ny = local_rt_ny -1 + + global_rt_nx = global_nx*AGGFACTRT + global_rt_ny = global_ny*AGGFACTRT + rt_AGGFACTRT = AGGFACTRT + + do i =1,numprocs + local_nx_size(i) = info(7,i) - info(6,i) + 1 + local_ny_size(i) = info(9,i) - info(8,i) + 1 + startx(i) = info(6,i) + starty(i) = info(8,i) + + local_rt_nx_size(i) = (info(7,i) - info(6,i) + 1)*AGGFACTRT+2 + local_rt_ny_size(i) = (info(9,i) - info(8,i) + 1 )*AGGFACTRT+2 + if(info(2,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 + if(info(3,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 + if(info(4,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 + if(info(5,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 + enddo + return + end subroutine wrf_LAND_set_INIT + + subroutine getMy_global_id() + integer ierr + call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) + return + end subroutine getMy_global_id + + subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag) + ! communicate the data for channel routine. + implicit none + integer ix,jy,size + integer Link_location(ix,jy) + integer i,j, flag + real Link_V(size), tmp_inout(ix,jy) + + tmp_inout = -999 + + if(size .eq. 0) then + tmp_inout = -999 + else + + ! map the Link_V data to tmp_inout(ix,jy) + do i = 1,ix + if(Link_location(i,1) .gt. 0) & + tmp_inout(i,1) = Link_V(Link_location(i,1)) + if(Link_location(i,2) .gt. 0) & + tmp_inout(i,2) = Link_V(Link_location(i,2)) + if(Link_location(i,jy-1) .gt. 0) & + tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) + if(Link_location(i,jy) .gt. 0) & + tmp_inout(i,jy) = Link_V(Link_location(i,jy)) + enddo + do j = 1,jy + if(Link_location(1,j) .gt. 0) & + tmp_inout(1,j) = Link_V(Link_location(1,j)) + if(Link_location(2,j) .gt. 0) & + tmp_inout(2,j) = Link_V(Link_location(2,j)) + if(Link_location(ix-1,j) .gt. 0) & + tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) + if(Link_location(ix,j) .gt. 0) & + tmp_inout(ix,j) = Link_V(Link_location(ix,j)) + enddo + endif + +! commu nicate tmp_inout + call MPP_LAND_COM_REAL(tmp_inout, ix,jy,flag) + +!map the data back to Link_V + if(size .eq. 0) return + do j = 1,jy + if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & + Link_V(Link_location(1,j)) = tmp_inout(1,j) + if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & + Link_V(Link_location(2,j)) = tmp_inout(2,j) + if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & + Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) + if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& + Link_V(Link_location(ix,j)) = tmp_inout(ix,j) + enddo + do i = 1,ix + if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& + Link_V(Link_location(i,1)) = tmp_inout(i,1) + if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& + Link_V(Link_location(i,2)) = tmp_inout(i,2) + if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & + Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) + if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & + Link_V(Link_location(i,jy)) = tmp_inout(i,jy) + enddo + end subroutine MPP_CHANNEL_COM_REAL + + subroutine MPP_CHANNEL_COM_INT(Link_location,ix,jy,Link_V,size,flag) + ! communicate the data for channel routine. + implicit none + integer ix,jy,size + integer Link_location(ix,jy) + integer i,j, flag + integer Link_V(size), tmp_inout(ix,jy) + + if(size .eq. 0) then + tmp_inout = -999 + else + + ! map the Link_V data to tmp_inout(ix,jy) + do i = 1,ix + if(Link_location(i,1) .gt. 0) & + tmp_inout(i,1) = Link_V(Link_location(i,1)) + if(Link_location(i,2) .gt. 0) & + tmp_inout(i,2) = Link_V(Link_location(i,2)) + if(Link_location(i,jy-1) .gt. 0) & + tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) + if(Link_location(i,jy) .gt. 0) & + tmp_inout(i,jy) = Link_V(Link_location(i,jy)) + enddo + do j = 1,jy + if(Link_location(1,j) .gt. 0) & + tmp_inout(1,j) = Link_V(Link_location(1,j)) + if(Link_location(2,j) .gt. 0) & + tmp_inout(2,j) = Link_V(Link_location(2,j)) + if(Link_location(ix-1,j) .gt. 0) & + tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) + if(Link_location(ix,j) .gt. 0) & + tmp_inout(ix,j) = Link_V(Link_location(ix,j)) + enddo + endif + +! commu nicate tmp_inout + call MPP_LAND_COM_INTEGER(tmp_inout, ix,jy,flag) + +!map the data back to Link_V + if(size .eq. 0) return + do j = 1,jy + if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & + Link_V(Link_location(1,j)) = tmp_inout(1,j) + if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & + Link_V(Link_location(2,j)) = tmp_inout(2,j) + if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & + Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) + if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& + Link_V(Link_location(ix,j)) = tmp_inout(ix,j) + enddo + do i = 1,ix + if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& + Link_V(Link_location(i,1)) = tmp_inout(i,1) + if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& + Link_V(Link_location(i,2)) = tmp_inout(i,2) + if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & + Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) + if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & + Link_V(Link_location(i,jy)) = tmp_inout(i,jy) + enddo + end subroutine MPP_CHANNEL_COM_INT + subroutine print_2(unit,in,fm) + integer unit + character(len=*) fm + real buf2(global_nx,global_ny),& + in(local_nx,local_ny) + call write_IO_real(in,buf2) + if(my_id.eq.IO_id) write(unit,*) buf2 + return + end subroutine print_2 + + subroutine print_rt_2(unit,in) + integer unit + real buf2(global_nx,global_ny),& + in(local_nx,local_ny) + call write_IO_real(in,buf2) + if(my_id.eq.IO_id) write(unit,*) buf2 + return + end subroutine print_rt_2 + + subroutine mpp_land_max_int1(v) + implicit none + integer v, r1, max + integer i, ierr, tag + if(my_id .eq. IO_id) then + max = v + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 101 + call mpi_recv(r1,1,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + if(max <= r1) max = r1 + end if + end do + else + tag = 101 + call mpi_send(v,1,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + end if + call mpp_land_bcast_int1(max) + v = max + return + end subroutine mpp_land_max_int1 + + subroutine mpp_land_max_real1(v) + implicit none + real v, r1, max + integer i, ierr, tag + if(my_id .eq. IO_id) then + max = v + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 101 + call mpi_recv(r1,1,MPI_REAL,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + if(max <= r1) max = r1 + end if + end do + else + tag = 101 + call mpi_send(v,1,MPI_REAL, IO_id, & + tag,MPI_COMM_WORLD,ierr) + end if + call mpp_land_bcast_real1(max) + v = max + return + end subroutine mpp_land_max_real1 + + subroutine mpp_same_int1(v) + implicit none + integer v,r1 + integer i, ierr, tag + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 109 + call mpi_recv(r1,1,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + if(v .ne. r1) v = -99 + end if + end do + else + tag = 109 + call mpi_send(v,1,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + end if + call mpp_land_bcast_int1(v) + end subroutine mpp_same_int1 + + + + subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v) + implicit none + integer gnlinks,nlinks, map_l2g(nlinks),tmp_map(gnlinks) + real recv(nlinks), v(nlinks) + real g_v(gnlinks), tmp_v(gnlinks) + integer i, ierr, tag, k + integer length, node, message_len + + if(nlinks .le. 0) then + tmp_map = -999 + else + tmp_map(1:nlinks) = map_l2g(1:nlinks) + endif + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + message_len = mpp_nlinks(i+1) + if(i .ne. my_id) then + !block receive from other node. + + tag = 109 + call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + tag = 119 + + call mpi_recv(tmp_v(1:message_len),message_len,MPI_REAL,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + + do k = 1,message_len + node = tmp_map(k) + if(node .gt. 0) then + g_v(node) = tmp_v(k) + else + write(6,*) "Maping infor k=",k," node=", node + endif + enddo + else + do k = 1,nlinks + node = map_l2g(k) + if(node .gt. 0) then + g_v(node) = v(k) + else + write(6,*) "local Maping infor k=",k," node=",node + endif + enddo + end if + + end do + else + tag = 109 + call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + tag = 119 + call mpi_send(v,nlinks,MPI_REAL,IO_id, & + tag,MPI_COMM_WORLD,ierr) + + end if + end subroutine write_chanel_real + + subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v) + implicit none + integer gnlinks,nlinks, map_l2g(nlinks),tmp_map(gnlinks) + integer :: recv(nlinks), v(nlinks) + integer :: g_v(gnlinks), tmp_v(gnlinks) + integer i, ierr, tag, k + integer length, node, message_len + + if(nlinks .le. 0) then + tmp_map = -999 + else + tmp_map(1:nlinks) = map_l2g(1:nlinks) + endif + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + message_len = mpp_nlinks(i+1) + if(i .ne. my_id) then + !block receive from other node. + + tag = 109 + call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + tag = 119 + + call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + + do k = 1,message_len + if(tmp_map(k) .gt. 0) then + node = tmp_map(k) + g_v(node) = tmp_v(k) + else + write(6,*) "Maping infor k=",k," node=",tmp_v(k) + endif + enddo + else + do k = 1,nlinks + if(map_l2g(k) .gt. 0) then + node = map_l2g(k) + g_v(node) = v(k) + else + write(6,*) "Maping infor k=",k," node=",map_l2g(k) + endif + enddo + end if + + end do + else + tag = 109 + call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + tag = 119 + call mpi_send(v,nlinks,MPI_INTEGER,IO_id, & + tag,MPI_COMM_WORLD,ierr) + end if + end subroutine write_chanel_int + + + + subroutine write_lake_real(v,nodelist_in,nlakes) + implicit none + real recv(nlakes), v(nlakes) + integer nodelist(nlakes), nlakes, nodelist_in(nlakes) + integer i, ierr, tag, k + integer length, node + + nodelist = nodelist_in + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 129 + call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + tag = 139 + call mpi_recv(recv(:),nlakes,MPI_REAL,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + + do k = 1,nlakes + if(nodelist(k) .gt. -99) then + node = nodelist(k) + v(node) = recv(node) + endif + enddo + end if + + end do + else + tag = 129 + call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + tag = 139 + call mpi_send(v,nlakes,MPI_REAL,IO_id, & + tag,MPI_COMM_WORLD,ierr) + end if + end subroutine write_lake_real + + subroutine read_rst_crt_r(unit,out,size) + implicit none + integer unit, size, ierr,ierr2 + real out(size),out1(size) + if(my_id.eq.IO_id) then + read(unit,IOSTAT=ierr2,end=99) out1 + if(ierr2.eq.0) out=out1 + endif +99 continue + call mpp_land_bcast_int1(ierr2) + if(ierr2 .ne. 0) return + call mpi_bcast(out,size,MPI_REAL, & + IO_id,MPI_COMM_WORLD,ierr) + return + end subroutine read_rst_crt_r + + subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks) + integer :: unit,gnlinks,nlinks,map_l2g(nlinks) + real cd(nlinks) + real g_cd (gnlinks) + call write_chanel_real(cd,map_l2g,gnlinks,nlinks, g_cd) + write(unit) g_cd + return + end subroutine write_rst_crt_r + + subroutine sum_real8(vin,nsize) + implicit none + integer nsize,i,j,tag,ierr + real*8, dimension(nsize):: vin,recv + real, dimension(nsize):: v + tag = 319 + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + call mpi_recv(recv,nsize,MPI_DOUBLE_PRECISION,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + vin(:) = vin(:) + recv(:) + endif + end do + v = vin + else + call mpi_send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id, & + tag,MPI_COMM_WORLD,ierr) + endif + call mpp_land_bcast_real(nsize,v) + vin = v + return + end subroutine sum_real8 + +! subroutine get_globalDim(ix,g_ix) +! implicit none +! integer ix,g_ix, ierr +! include "mpif.h" +! +! if ( my_id .eq. IO_id ) then +! g_ix = ix +! call mpi_reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, & +! MPI_SUM, 0, MPI_COMM_WORLD, ierr ) +! else +! call mpi_reduce( ix, 0, 4, MPI_INTEGER, & +! MPI_SUM, 0, MPI_COMM_WORLD, ierr ) +! endif +! call mpp_land_bcast_int1(g_ix) +! +! return +! +! end subroutine get_globalDim + + subroutine gather_1d_real_tmp(vl,s_in,e_in,vg,sg) + integer sg, s,e, size, s_in, e_in + integer index_s(2) + integer tag, ierr,i +! s: start index, e: end index + real vl(e_in-s_in+1), vg(sg) + s = s_in + e = e_in + + if(my_id .eq. IO_id) then + vg(s:e) = vl + end if + + index_s(1) = s + index_s(2) = e + size = e - s + 1 + + if(my_id .eq. IO_id) then + do i = 0, numprocs - 1 + if(i .ne. my_id) then + !block receive from other node. + tag = 202 + call mpi_recv(index_s,2,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + + tag = 203 + e = index_s(2) + s = index_s(1) + size = e - s + 1 + call mpi_recv(vg(s:e),size,MPI_REAL, & + i,tag,MPI_COMM_WORLD,mpp_status,ierr) + endif + end do + else + tag = 202 + call mpi_send(index_s,2,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + + tag = 203 + call mpi_send(vl,size,MPI_REAL,IO_id, & + tag,MPI_COMM_WORLD,ierr) + end if + + return + end subroutine gather_1d_real_tmp + + subroutine sum_double(inout) + implicit none + real*8:: inout, send + integer :: ierr + send = inout + !yw CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,ierr) + CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr) + end subroutine sum_double + + subroutine mpp_chrt_nlinks_collect(nlinks) + ! collect the nlinks + implicit none + integer :: nlinks + integer :: i, ierr, status, tag + allocate(mpp_nlinks(numprocs),stat = status) + tag = 138 + mpp_nlinks = 0 + if(my_id .eq. IO_id) then + do i = 0,numprocs -1 + if(i .ne. my_id) then + call mpi_recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + else + mpp_nlinks(i+1) = 0 + end if + end do + else + call mpi_send(nlinks,1,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + endif + + + end subroutine mpp_chrt_nlinks_collect + + subroutine getLocalXY(ix,jx,startx,starty,endx,endy) +!!! this is for NoahMP only + implicit none + integer:: ix,jx,startx,starty,endx,endy + startx = local_startx + starty = local_starty + endx = startx + ix -1 + endy = starty + jx -1 + end subroutine getLocalXY + + subroutine check_landreal1(unit, inVar) + implicit none + integer :: unit + real :: inVar + if(my_id .eq. IO_id) then + write(unit,*) inVar + flush(unit) + endif + end subroutine check_landreal1 + + subroutine check_landreal1d(unit, inVar) + implicit none + integer :: unit + real :: inVar(:) + if(my_id .eq. IO_id) then + write(unit,*) inVar + flush(unit) + endif + end subroutine check_landreal1d + subroutine check_landreal2d(unit, inVar) + implicit none + integer :: unit + real :: inVar(:,:) + real :: g_var(global_nx,global_ny) + call write_io_real(inVar,g_var) + if(my_id .eq. IO_id) then + write(unit,*) g_var + flush(unit) + endif + end subroutine check_landreal2d + + subroutine check_landreal3d(unit, inVar) + implicit none + integer :: unit, k, klevel + real :: inVar(:,:,:) + real :: g_var(global_nx,global_ny) + klevel = size(inVar,2) + do k = 1, klevel + call write_io_real(inVar(:,k,:),g_var) + if(my_id .eq. IO_id) then + write(unit,*) g_var + flush(unit) + endif + end do + end subroutine check_landreal3d + +END MODULE MODULE_MPP_LAND + + subroutine mpp_land_abort() + implicit none + include "mpif.h" + integer ierr + CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) + end ! mpp_land_abort + + subroutine mpp_land_sync() + implicit none + include "mpif.h" + integer ierr + call MPI_barrier( MPI_COMM_WORLD ,ierr) + if(ierr .ne. 0) call mpp_land_abort() + return + end ! mpp_land_sync + + + + diff --git a/wrfv2_fire/hydro/MPP/mpp_land.F b/wrfv2_fire/hydro/MPP/mpp_land.F index 78f6cecd..e3935c3c 100644 --- a/wrfv2_fire/hydro/MPP/mpp_land.F +++ b/wrfv2_fire/hydro/MPP/mpp_land.F @@ -13,6 +13,7 @@ MODULE MODULE_MPP_LAND integer, public :: global_rt_nx, global_rt_ny integer, public :: local_rt_nx,local_rt_ny,rt_AGGFACTRT integer, public :: numprocs ! total process, get by mpi initialization. + integer :: local_startx, local_starty integer mpp_status(MPI_STATUS_SIZE) @@ -20,6 +21,28 @@ MODULE MODULE_MPP_LAND integer, allocatable, DIMENSION(:), public :: local_nx_size,local_ny_size integer, allocatable, DIMENSION(:), public :: local_rt_nx_size,local_rt_ny_size integer, allocatable, DIMENSION(:), public :: startx,starty + integer, allocatable, DIMENSION(:), public :: mpp_nlinks + + interface check_land + module procedure check_landreal1 + module procedure check_landreal1d + module procedure check_landreal2d + module procedure check_landreal3d + end interface + interface write_io_land + module procedure write_io_real3d + end interface + interface mpp_land_bcast + module procedure mpp_land_bcast_real2 + module procedure mpp_land_bcast_real_1d + module procedure mpp_land_bcast_real1 + module procedure mpp_land_bcast_char1d + module procedure mpp_land_bcast_char1 + module procedure mpp_land_bcast_int1 + module procedure mpp_land_bcast_int1d + module procedure mpp_land_bcast_int2d + module procedure mpp_land_bcast_logical + end interface contains @@ -96,23 +119,45 @@ end subroutine MPP_LAND_INIT subroutine MPP_LAND_PAR_INI(over_lap,in_global_nx,in_global_ny,AGGFACTRT) integer in_global_nx,in_global_ny, AGGFACTRT integer :: over_lap ! the overlaped grid number. (default is 1) + integer :: i + global_nx = in_global_nx global_ny = in_global_ny rt_AGGFACTRT = AGGFACTRT global_rt_nx = in_global_nx*AGGFACTRT global_rt_ny = in_global_ny *AGGFACTRT !overlap_n = 1 - local_nx = global_nx / left_right_np - if(left_right_p .eq. (left_right_np-1) ) then - local_nx = global_nx & - -int(global_nx/left_right_np)*(left_right_np-1) - end if - local_ny = global_ny / up_down_np - if( up_down_p .eq. (up_down_np-1) ) then - local_ny = global_ny & - -int(global_ny/up_down_np)*(up_down_np -1) +!ywold local_nx = global_nx / left_right_np +!ywold if(left_right_p .eq. (left_right_np-1) ) then +!ywold local_nx = global_nx & +!ywold -int(global_nx/left_right_np)*(left_right_np-1) +!ywold end if +!ywold local_ny = global_ny / up_down_np +!ywold if( up_down_p .eq. (up_down_np-1) ) then +!ywold local_ny = global_ny & +!ywold -int(global_ny/up_down_np)*(up_down_np -1) +!ywold end if + + local_nx = int(global_nx / left_right_np) + !if(global_nx .ne. (local_nx*left_right_np) ) then + if(mod(global_nx, left_right_np) .ne. 0) then + do i = 1, mod(global_nx, left_right_np) + if(left_right_p .eq. i ) then + local_nx = local_nx + 1 + end if + end do end if + local_ny = int(global_ny / up_down_np) + !if(global_ny .ne. (local_ny * up_down_np) ) then + if(mod(global_ny,up_down_np) .ne. 0 ) then + do i = 1, mod(global_ny,up_down_np) + if( up_down_p .eq. i) then + local_ny = local_ny + 1 + end if + end do + end if + local_rt_nx=local_nx*AGGFACTRT+2 local_rt_ny=local_ny*AGGFACTRT+2 if(left_id.lt.0) local_rt_nx = local_rt_nx -1 @@ -477,18 +522,38 @@ end subroutine MPP_LAND_UB_COM8 subroutine calculate_start_p() ! calculate startx and starty - integer :: local_startx, local_starty integer :: i,status, ierr, tag integer :: r_s(2) + integer :: t_nx, t_ny allocate(starty(numprocs),stat = ierr) allocate(startx(numprocs),stat = ierr) local_startx = int(global_nx/left_right_np) * left_right_p+1 local_starty = int(global_ny/up_down_np) * up_down_p+1 + +!ywold + t_nx = 0 + do i = 1, mod(global_nx,left_right_np) + if(left_right_p .gt. i ) then + t_nx = t_nx + 1 + end if + end do + local_startx = local_startx + t_nx + + t_ny = 0 + do i = 1, mod(global_ny,up_down_np) + if( up_down_p .gt. i) then + t_ny = t_ny + 1 + end if + end do + local_starty = local_starty + t_ny + + if(left_id .lt. 0) local_startx = 1 if(down_id .lt. 0) local_starty = 1 + if(my_id .eq. IO_id) then startx(my_id+1) = local_startx starty(my_id+1) = local_starty @@ -520,6 +585,16 @@ subroutine calculate_start_p() return end subroutine calculate_start_p + subroutine decompose_data_real3d (in_buff,out_buff,klevel) + implicit none + integer:: klevel, k + real in_buff(global_nx,1:klevel,global_ny),out_buff(local_nx,1:klevel,local_ny) + do k = 1, klevel + call decompose_data_real(in_buff(:,k,:),out_buff(:,k,:)) + end do + end subroutine decompose_data_real3d + + subroutine decompose_data_real (in_buff,out_buff) ! usage: all of the cpu call this subroutine. ! the IO node will distribute the data to rest of the node. @@ -613,6 +688,17 @@ subroutine write_IO_int(in_buff,out_buff) return end subroutine write_IO_int + subroutine write_IO_real3d(in_buff,out_buff,klevel) + implicit none +! the IO node will receive the data from the rest process. + integer klevel, k + real in_buff(1:local_nx,1:klevel,1:local_ny), & + out_buff(global_nx,1:klevel,global_ny) + do k = 1, klevel + call write_IO_real(in_buff(:,k,:),out_buff(:,k,:)) + end do + end subroutine write_IO_real3d + subroutine write_IO_real(in_buff,out_buff) ! the IO node will receive the data from the rest process. real in_buff(1:local_nx,1:local_ny), & @@ -737,6 +823,7 @@ end subroutine mpp_land_sync ! return ! end subroutine mpp_land_sync + subroutine mpp_land_bcast_int(size,inout) integer size integer inout(size) @@ -747,6 +834,17 @@ subroutine mpp_land_bcast_int(size,inout) return end subroutine mpp_land_bcast_int + subroutine mpp_land_bcast_int1d(inout) + integer len + integer inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_INTEGER, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int1d + subroutine mpp_land_bcast_int1(inout) integer inout integer ierr @@ -756,6 +854,15 @@ subroutine mpp_land_bcast_int1(inout) return end subroutine mpp_land_bcast_int1 + subroutine mpp_land_bcast_logical(inout) + logical :: inout + integer ierr + call mpi_bcast(inout,1,MPI_LOGICAL, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_logical + subroutine mpp_land_bcast_real1(inout) real inout integer ierr @@ -765,6 +872,17 @@ subroutine mpp_land_bcast_real1(inout) return end subroutine mpp_land_bcast_real1 + subroutine mpp_land_bcast_real_1d(inout) + integer len + real inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_real, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real_1d + subroutine mpp_land_bcast_real(size,inout) integer size real inout(size) @@ -775,6 +893,34 @@ subroutine mpp_land_bcast_real(size,inout) return end subroutine mpp_land_bcast_real + subroutine mpp_land_bcast_int2d(inout) + integer length1, k,length2 + integer inout(:,:) + integer ierr + length1 = size(inout,1) + length2 = size(inout,2) + do k = 1, length2 + call mpi_bcast(inout(:,k),length1,MPI_INTEGER, & + IO_id,MPI_COMM_WORLD,ierr) + end do + call mpp_land_sync() + return + end subroutine mpp_land_bcast_int2d + + subroutine mpp_land_bcast_real2(inout) + integer length1, k,length2 + real inout(:,:) + integer ierr + length1 = size(inout,1) + length2 = size(inout,2) + do k = 1, length2 + call mpi_bcast(inout(:,k),length1,MPI_real, & + IO_id,MPI_COMM_WORLD,ierr) + end do + call mpp_land_sync() + return + end subroutine mpp_land_bcast_real2 + subroutine mpp_land_bcast_rd(size,inout) integer size real*8 inout(size) @@ -795,6 +941,28 @@ subroutine mpp_land_bcast_char(size,inout) return end subroutine mpp_land_bcast_char + subroutine mpp_land_bcast_char1d(inout) + integer len + character inout(:) + integer ierr + len = size(inout,1) + call mpi_bcast(inout,len,MPI_CHARACTER, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_char1d + + subroutine mpp_land_bcast_char1(inout) + integer len + character(len=*) inout + integer ierr + len = LEN_TRIM(inout) + call mpi_bcast(inout,len,MPI_CHARACTER, & + IO_id,MPI_COMM_WORLD,ierr) + call mpp_land_sync() + return + end subroutine mpp_land_bcast_char1 + subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag) ! ### Communicate message on left right and up bottom directions. @@ -1045,7 +1213,7 @@ subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT) if(numprocs .ne. total_pe) then write(6,*) "Error: numprocs .ne. total_pe ",numprocs, total_pe - call hydro_stop() + call mpp_land_abort() endif @@ -1115,10 +1283,14 @@ subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag) integer i,j, flag real Link_V(size), tmp_inout(ix,jy) - if(size .eq. 0) return + tmp_inout = -999 -! map the Link_V data to tmp_inout(ix,jy) - do i = 1,ix + if(size .eq. 0) then + tmp_inout = -999 + else + + ! map the Link_V data to tmp_inout(ix,jy) + do i = 1,ix if(Link_location(i,1) .gt. 0) & tmp_inout(i,1) = Link_V(Link_location(i,1)) if(Link_location(i,2) .gt. 0) & @@ -1127,8 +1299,8 @@ subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag) tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) if(Link_location(i,jy) .gt. 0) & tmp_inout(i,jy) = Link_V(Link_location(i,jy)) - enddo - do j = 1,jy + enddo + do j = 1,jy if(Link_location(1,j) .gt. 0) & tmp_inout(1,j) = Link_V(Link_location(1,j)) if(Link_location(2,j) .gt. 0) & @@ -1137,34 +1309,97 @@ subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag) tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) if(Link_location(ix,j) .gt. 0) & tmp_inout(ix,j) = Link_V(Link_location(ix,j)) - enddo + enddo + endif ! commu nicate tmp_inout call MPP_LAND_COM_REAL(tmp_inout, ix,jy,flag) !map the data back to Link_V + if(size .eq. 0) return do j = 1,jy - if(Link_location(1,j) .gt. 0) & + if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & Link_V(Link_location(1,j)) = tmp_inout(1,j) - if(Link_location(2,j) .gt. 0) & + if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & Link_V(Link_location(2,j)) = tmp_inout(2,j) - if(Link_location(ix-1,j) .gt. 0) & + if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) - if(Link_location(ix,j) .gt. 0) & + if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& Link_V(Link_location(ix,j)) = tmp_inout(ix,j) enddo do i = 1,ix - if(Link_location(i,1) .gt. 0) & + if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& Link_V(Link_location(i,1)) = tmp_inout(i,1) - if(Link_location(i,2) .gt. 0) & + if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& Link_V(Link_location(i,2)) = tmp_inout(i,2) - if(Link_location(i,jy-1) .gt. 0) & + if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) - if(Link_location(i,jy) .gt. 0) & + if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & Link_V(Link_location(i,jy)) = tmp_inout(i,jy) enddo end subroutine MPP_CHANNEL_COM_REAL + subroutine MPP_CHANNEL_COM_INT(Link_location,ix,jy,Link_V,size,flag) + ! communicate the data for channel routine. + implicit none + integer ix,jy,size + integer Link_location(ix,jy) + integer i,j, flag + integer Link_V(size), tmp_inout(ix,jy) + + if(size .eq. 0) then + tmp_inout = -999 + else + + ! map the Link_V data to tmp_inout(ix,jy) + do i = 1,ix + if(Link_location(i,1) .gt. 0) & + tmp_inout(i,1) = Link_V(Link_location(i,1)) + if(Link_location(i,2) .gt. 0) & + tmp_inout(i,2) = Link_V(Link_location(i,2)) + if(Link_location(i,jy-1) .gt. 0) & + tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) + if(Link_location(i,jy) .gt. 0) & + tmp_inout(i,jy) = Link_V(Link_location(i,jy)) + enddo + do j = 1,jy + if(Link_location(1,j) .gt. 0) & + tmp_inout(1,j) = Link_V(Link_location(1,j)) + if(Link_location(2,j) .gt. 0) & + tmp_inout(2,j) = Link_V(Link_location(2,j)) + if(Link_location(ix-1,j) .gt. 0) & + tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) + if(Link_location(ix,j) .gt. 0) & + tmp_inout(ix,j) = Link_V(Link_location(ix,j)) + enddo + endif + +! commu nicate tmp_inout + call MPP_LAND_COM_INTEGER(tmp_inout, ix,jy,flag) + +!map the data back to Link_V + if(size .eq. 0) return + do j = 1,jy + if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & + Link_V(Link_location(1,j)) = tmp_inout(1,j) + if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & + Link_V(Link_location(2,j)) = tmp_inout(2,j) + if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & + Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) + if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& + Link_V(Link_location(ix,j)) = tmp_inout(ix,j) + enddo + do i = 1,ix + if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& + Link_V(Link_location(i,1)) = tmp_inout(i,1) + if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& + Link_V(Link_location(i,2)) = tmp_inout(i,2) + if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & + Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) + if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & + Link_V(Link_location(i,jy)) = tmp_inout(i,jy) + enddo + end subroutine MPP_CHANNEL_COM_INT subroutine print_2(unit,in,fm) integer unit character(len=*) fm @@ -1256,69 +1491,51 @@ subroutine mpp_same_int1(v) call mpp_land_bcast_int1(v) end subroutine mpp_same_int1 - subroutine write_chanel_real8(v,nodelist_in,mpp_nlinks,nlinks) - implicit none - real*8 recv(nlinks), v(nlinks) - integer nodelist(nlinks), mpp_nlinks,nlinks, nodelist_in(nlinks) - integer i, ierr, tag, k - integer length, node - - nodelist = nodelist_in - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 109 - call mpi_recv(nodelist,nlinks,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - tag = 119 - call mpi_recv(recv(:),nlinks,MPI_DOUBLE_PRECISION,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - - do k = 1,nodelist(nlinks) - if(nodelist(k) .gt. -99) then - node = nodelist(k) - v(node) = recv(node) - endif - enddo - end if - - end do - else - tag = 109 - nodelist(nlinks) = mpp_nlinks - call mpi_send(nodelist,nlinks,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - tag = 119 - call mpi_send(v,nlinks,MPI_DOUBLE_PRECISION,IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - end subroutine write_chanel_real8 - subroutine write_chanel_real(v,nodelist_in,mpp_nlinks,nlinks) + subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v) implicit none + integer gnlinks,nlinks, map_l2g(nlinks),tmp_map(gnlinks) real recv(nlinks), v(nlinks) - integer nodelist(nlinks), mpp_nlinks,nlinks, nodelist_in(nlinks) + real g_v(gnlinks), tmp_v(gnlinks) integer i, ierr, tag, k - integer length, node + integer length, node, message_len + + if(nlinks .le. 0) then + tmp_map = -999 + else + tmp_map(1:nlinks) = map_l2g(1:nlinks) + endif - nodelist = nodelist_in if(my_id .eq. IO_id) then do i = 0, numprocs - 1 + message_len = mpp_nlinks(i+1) if(i .ne. my_id) then !block receive from other node. + tag = 109 - call mpi_recv(nodelist,nlinks,MPI_INTEGER,i, & + call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & tag,MPI_COMM_WORLD,mpp_status,ierr) tag = 119 - call mpi_recv(recv(:),nlinks,MPI_REAL,i, & + + call mpi_recv(tmp_v(1:message_len),message_len,MPI_REAL,i, & tag,MPI_COMM_WORLD,mpp_status,ierr) - do k = 1,nodelist(nlinks) - if(nodelist(k) .gt. -99) then - node = nodelist(k) - v(node) = recv(node) + do k = 1,message_len + node = tmp_map(k) + if(node .gt. 0) then + g_v(node) = tmp_v(k) + else + write(6,*) "Maping infor k=",k," node=", node + endif + enddo + else + do k = 1,nlinks + node = map_l2g(k) + if(node .gt. 0) then + g_v(node) = v(k) + else + write(6,*) "local Maping infor k=",k," node=",node endif enddo end if @@ -1326,38 +1543,57 @@ subroutine write_chanel_real(v,nodelist_in,mpp_nlinks,nlinks) end do else tag = 109 - nodelist(nlinks) = mpp_nlinks - call mpi_send(nodelist,nlinks,MPI_INTEGER, IO_id, & + call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & tag,MPI_COMM_WORLD,ierr) tag = 119 call mpi_send(v,nlinks,MPI_REAL,IO_id, & tag,MPI_COMM_WORLD,ierr) + end if end subroutine write_chanel_real - subroutine write_chanel_int(v,nodelist_in,mpp_nlinks,nlinks) + subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v) implicit none - integer :: recv(nlinks), v(nlinks) - integer nodelist(nlinks), mpp_nlinks,nlinks, nodelist_in(nlinks) + integer gnlinks,nlinks, map_l2g(nlinks),tmp_map(gnlinks) + integer :: recv(nlinks), v(nlinks) + integer :: g_v(gnlinks), tmp_v(gnlinks) integer i, ierr, tag, k - integer length, node + integer length, node, message_len - nodelist = nodelist_in + if(nlinks .le. 0) then + tmp_map = -999 + else + tmp_map(1:nlinks) = map_l2g(1:nlinks) + endif if(my_id .eq. IO_id) then do i = 0, numprocs - 1 + message_len = mpp_nlinks(i+1) if(i .ne. my_id) then !block receive from other node. + tag = 109 - call mpi_recv(nodelist,nlinks,MPI_INTEGER,i, & + call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & tag,MPI_COMM_WORLD,mpp_status,ierr) tag = 119 - call mpi_recv(recv(:),nlinks,MPI_INTEGER,i, & + + call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i, & tag,MPI_COMM_WORLD,mpp_status,ierr) - do k = 1,nodelist(nlinks) - if(nodelist(k) .gt. -99) then - node = nodelist(k) - v(node) = recv(node) + do k = 1,message_len + if(tmp_map(k) .gt. 0) then + node = tmp_map(k) + g_v(node) = tmp_v(k) + else + write(6,*) "Maping infor k=",k," node=",tmp_v(k) + endif + enddo + else + do k = 1,nlinks + if(map_l2g(k) .gt. 0) then + node = map_l2g(k) + g_v(node) = v(k) + else + write(6,*) "Maping infor k=",k," node=",map_l2g(k) endif enddo end if @@ -1365,8 +1601,7 @@ subroutine write_chanel_int(v,nodelist_in,mpp_nlinks,nlinks) end do else tag = 109 - nodelist(nlinks) = mpp_nlinks - call mpi_send(nodelist,nlinks,MPI_INTEGER, IO_id, & + call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & tag,MPI_COMM_WORLD,ierr) tag = 119 call mpi_send(v,nlinks,MPI_INTEGER,IO_id, & @@ -1375,6 +1610,7 @@ subroutine write_chanel_int(v,nodelist_in,mpp_nlinks,nlinks) end subroutine write_chanel_int + subroutine write_lake_real(v,nodelist_in,nlakes) implicit none real recv(nlakes), v(nlakes) @@ -1429,11 +1665,12 @@ subroutine read_rst_crt_r(unit,out,size) return end subroutine read_rst_crt_r - subroutine write_rst_crt_r(unit,cd,nlinks_index,mpp_nlinks,nlinks) - integer :: unit,mpp_nlinks,nlinks,nlinks_index(nlinks) + subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks) + integer :: unit,gnlinks,nlinks,map_l2g(nlinks) real cd(nlinks) - call write_chanel_real(cd,nlinks_index,mpp_nlinks,nlinks) - write(unit) cd + real g_cd (gnlinks) + call write_chanel_real(cd,map_l2g,gnlinks,nlinks, g_cd) + write(unit) g_cd return end subroutine write_rst_crt_r @@ -1535,6 +1772,86 @@ subroutine sum_double(inout) CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr) end subroutine sum_double + subroutine mpp_chrt_nlinks_collect(nlinks) + ! collect the nlinks + implicit none + integer :: nlinks + integer :: i, ierr, status, tag + allocate(mpp_nlinks(numprocs),stat = status) + tag = 138 + mpp_nlinks = 0 + if(my_id .eq. IO_id) then + do i = 0,numprocs -1 + if(i .ne. my_id) then + call mpi_recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, & + tag,MPI_COMM_WORLD,mpp_status,ierr) + else + mpp_nlinks(i+1) = 0 + end if + end do + else + call mpi_send(nlinks,1,MPI_INTEGER, IO_id, & + tag,MPI_COMM_WORLD,ierr) + endif + + + end subroutine mpp_chrt_nlinks_collect + + subroutine getLocalXY(ix,jx,startx,starty,endx,endy) +!!! this is for NoahMP only + implicit none + integer:: ix,jx,startx,starty,endx,endy + startx = local_startx + starty = local_starty + endx = startx + ix -1 + endy = starty + jx -1 + end subroutine getLocalXY + + subroutine check_landreal1(unit, inVar) + implicit none + integer :: unit + real :: inVar + if(my_id .eq. IO_id) then + write(unit,*) inVar + flush(unit) + endif + end subroutine check_landreal1 + + subroutine check_landreal1d(unit, inVar) + implicit none + integer :: unit + real :: inVar(:) + if(my_id .eq. IO_id) then + write(unit,*) inVar + flush(unit) + endif + end subroutine check_landreal1d + subroutine check_landreal2d(unit, inVar) + implicit none + integer :: unit + real :: inVar(:,:) + real :: g_var(global_nx,global_ny) + call write_io_real(inVar,g_var) + if(my_id .eq. IO_id) then + write(unit,*) g_var + flush(unit) + endif + end subroutine check_landreal2d + + subroutine check_landreal3d(unit, inVar) + implicit none + integer :: unit, k, klevel + real :: inVar(:,:,:) + real :: g_var(global_nx,global_ny) + klevel = size(inVar,2) + do k = 1, klevel + call write_io_real(inVar(:,k,:),g_var) + if(my_id .eq. IO_id) then + write(unit,*) g_var + flush(unit) + endif + end do + end subroutine check_landreal3d END MODULE MODULE_MPP_LAND diff --git a/wrfv2_fire/hydro/Routing/.svn/all-wcprops b/wrfv2_fire/hydro/Routing/.svn/all-wcprops new file mode 100644 index 00000000..5d4775d6 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/.svn/all-wcprops @@ -0,0 +1,71 @@ +K 25 +svn:wc:ra_dav:version-url +V 60 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing +END +module_noah_chan_param_init_rt.F +K 25 +svn:wc:ra_dav:version-url +V 93 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_noah_chan_param_init_rt.F +END +rtFunction.F +K 25 +svn:wc:ra_dav:version-url +V 73 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/rtFunction.F +END +Noah_distr_routing.F +K 25 +svn:wc:ra_dav:version-url +V 81 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/Noah_distr_routing.F +END +module_HYDRO_io.F +K 25 +svn:wc:ra_dav:version-url +V 78 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_HYDRO_io.F +END +module_date_utilities_rt.F +K 25 +svn:wc:ra_dav:version-url +V 87 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_date_utilities_rt.F +END +module_GW_baseflow.F +K 25 +svn:wc:ra_dav:version-url +V 81 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_GW_baseflow.F +END +module_channel_routing.F +K 25 +svn:wc:ra_dav:version-url +V 85 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_channel_routing.F +END +module_lsm_forcing.F +K 25 +svn:wc:ra_dav:version-url +V 81 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_lsm_forcing.F +END +Makefile +K 25 +svn:wc:ra_dav:version-url +V 69 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/Makefile +END +module_HYDRO_utils.F +K 25 +svn:wc:ra_dav:version-url +V 81 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_HYDRO_utils.F +END +module_RT.F +K 25 +svn:wc:ra_dav:version-url +V 72 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_RT.F +END diff --git a/wrfv2_fire/hydro/Routing/.svn/entries b/wrfv2_fire/hydro/Routing/.svn/entries new file mode 100644 index 00000000..44b84ff4 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/.svn/entries @@ -0,0 +1,402 @@ +10 + +dir +9105 +https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/Routing +https://kkeene@svn-wrf-model.cgd.ucar.edu + + + +2015-02-13T18:35:30.360105Z +8075 +weiyu@ucar.edu + + + + + + + + + + + + + + +b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d + +module_noah_chan_param_init_rt.F +file + + + + +2016-02-11T20:37:50.134995Z +630a8feec10d204ea5c17538384988ce +2012-12-07T20:01:45.900797Z +6094 +gill + + + + + + + + + + + + + + + + + + + + + +2719 + +rtFunction.F +file + + + + +2016-02-11T20:37:50.136223Z +66aee92dbadc919da2a278cb6ee6c042 +2013-11-15T19:40:36.446206Z +6964 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +9159 + +Noah_distr_routing.F +file + + + + +2016-02-11T20:37:50.121621Z +ba290baa52dd512dc283c734b1964a7a +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +92153 + +module_HYDRO_io.F +file + + + + +2016-02-11T20:37:50.123186Z +06e5f14906bc1e53f9ae140d0bc3de70 +2015-01-23T18:49:15.035273Z +8003 +gill + + + + + + + + + + + + + + + + + + + + + +241116 + +module_date_utilities_rt.F +file + + + + +2016-02-11T20:37:50.124370Z +49972d35cce17498d1fd4aab9ca6f2dc +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +27903 + +module_GW_baseflow.F +file + + + + +2016-02-11T20:37:50.125453Z +f9022bc6362d306dc881189824307266 +2015-02-13T18:35:30.360105Z +8075 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +26501 + +module_channel_routing.F +file + + + + +2016-02-11T20:37:50.126617Z +02dd8389957051a283142233447cfd58 +2015-01-23T18:49:15.035273Z +8003 +gill + + + + + + + + + + + + + + + + + + + + + +50277 + +module_lsm_forcing.F +file + + + + +2016-02-11T20:37:50.127855Z +ebb3f6b8637055122118f29e2163947b +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +75184 + +Makefile +file + + + + +2016-02-11T20:37:50.131541Z +7524715cf5a742825473c375346ca604 +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +1240 + +module_HYDRO_utils.F +file + + + + +2016-02-11T20:37:50.132710Z +f2ef7f1a0cbceeac8680821c0f6ca117 +2013-03-22T17:14:06.234507Z +6523 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +13813 + +module_RT.F +file + + + + +2016-02-11T20:37:50.133907Z +f6efcd969c8b00048ef85e58db1e6124 +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +40331 + diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/Makefile.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/Makefile.svn-base new file mode 100644 index 00000000..ce785bc1 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/.svn/text-base/Makefile.svn-base @@ -0,0 +1,53 @@ +# Makefile +# +.SUFFIXES: +.SUFFIXES: .o .F + +include ../macros + +OBJS = \ + module_HYDRO_utils.o \ + module_noah_chan_param_init_rt.o \ + module_GW_baseflow.o \ + module_HYDRO_io.o \ + module_RT.o Noah_distr_routing.o \ + module_channel_routing.o \ + module_lsm_forcing.o + +all: $(OBJS) + +#module_RT.o: module_RT.F +# @echo "" +# $(CPP) $(CPPFLAGS) $(*).F > $(*).f +# $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f +# $(RMD) $(*).f +# @echo "" +# cp *.mod ../mod + +.F.o: + @echo "" + $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f + $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f + $(RMD) $(*).f + @echo "" + ar -r ../lib/libHYDRO.a $(@) + cp *.mod ../mod + +# +# Dependencies: +# +module_GW_baseflow.o: ../Data_Rec/module_GW_baseflow_data.o + +module_HYDRO_io.o: module_HYDRO_utils.o ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o + +module_HYDRO_utils.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o + +module_lsm_forcing.o: module_HYDRO_io.o + +module_RT.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o ../Data_Rec/module_GW_baseflow_data.o \ + module_GW_baseflow.o module_HYDRO_utils.o module_HYDRO_io.o\ + module_noah_chan_param_init_rt.o ../Data_Rec/module_GW_baseflow_data.o + + +clean: + rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/Noah_distr_routing.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/Noah_distr_routing.F.svn-base new file mode 100644 index 00000000..0f856caf --- /dev/null +++ b/wrfv2_fire/hydro/Routing/.svn/text-base/Noah_distr_routing.F.svn-base @@ -0,0 +1,2768 @@ +!DJG ------------------------------------------------ +!DJG SUBROUTINE RT_PARM +!DJG ------------------------------------------------ + + SUBROUTINE RT_PARM(IX,JY,IXRT,JXRT,VEGTYP,RETDP,OVRGH, & + AGGFACTR) +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id,& + up_id,mpp_land_com_real,MPP_LAND_UB_COM, & + MPP_LAND_LR_COM,mpp_land_com_integer +#endif + + IMPLICIT NONE + +!DJG -------- DECLARATIONS ----------------------- + + INTEGER, INTENT(IN) :: IX,JY,IXRT,JXRT,AGGFACTR + + INTEGER, INTENT(IN), DIMENSION(IX,JY) :: VEGTYP + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: RETDP + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: OVRGH + + +!DJG Local Variables + + INTEGER :: I,J,IXXRT,JYYRT + INTEGER :: AGGFACYRT,AGGFACXRT + + +!DJG Assign RETDP and OVRGH based on VEGTYP... + + do J=1,JY + do I=1,IX + + do AGGFACYRT=AGGFACTR-1,0,-1 + do AGGFACXRT=AGGFACTR-1,0,-1 + + IXXRT=I*AGGFACTR-AGGFACXRT + JYYRT=J*AGGFACTR-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#else +!yw ???? +! IXXRT=IXXRT+1 +! JYYRT=JYYRT+1 +#endif + + +!DJG Urban, rock, playa, snow/ice... + IF (VEGTYP(I,J).EQ.1.OR.VEGTYP(I,J).EQ.26.OR. & + VEGTYP(I,J).EQ.26.OR.VEGTYP(I,J).EQ.24) THEN + RETDP(IXXRT,JYYRT)=1.3 + OVRGH(IXXRT,JYYRT)=0.1 +!DJG Wetlands and water bodies... + ELSE IF (VEGTYP(I,J).EQ.17.OR.VEGTYP(I,J).EQ.18.OR. & + VEGTYP(I,J).EQ.19.OR.VEGTYP(I,J).EQ.16) THEN + RETDP(IXXRT,JYYRT)=10.0 + OVRGH(IXXRT,JYYRT)=0.2 +!DJG All other natural covers... + ELSE + RETDP(IXXRT,JYYRT)=5.0 + OVRGH(IXXRT,JYYRT)=0.2 + END IF + + end do + end do + + end do + end do +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(RETDP,IXRT,JXRT,99) + call MPP_LAND_COM_REAL(OVRGH,IXRT,JXRT,99) +#endif + +!DJG ---------------------------------------------------------------- + END SUBROUTINE RT_PARM +!DJG ---------------------------------------------------------------- + + + + + +!DJG ------------------------------------------------ +!DJG SUBROUTINE SUBSFC_RTNG +!DJG ------------------------------------------------ + + SUBROUTINE SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT, & + SOYRT,LATKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT, & + NSOIL,SMCRT,INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT, & + SMCWLTRT,SO8RT,SO8RT_D, rt_option,SLDPTH,junk4,CWATAVAIL, & + SATLYRCHK) + +! use module_mpp_land, only: write_restart_rt_3, write_restart_rt_2, & +! my_id +#ifdef MPP_LAND + use module_mpp_land, only: MPP_LAND_COM_REAL +#endif + IMPLICIT NONE + +!DJG -------- DECLARATIONS ------------------------ + + INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL + + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT,junk4 + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOYRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: LATKSATRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOLDEPRT + + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ZWATTABLRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: CWATAVAIL + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: SATLYRCHK + + + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBBDRYRT + + REAL, INTENT(IN) :: dist(ixrt,jxrt,9) + REAL, INTENT(IN) :: DT + REAL, INTENT(IN), DIMENSION(NSOIL) :: ZSOIL + REAL, INTENT(IN), DIMENSION(NSOIL) :: SLDPTH + REAL, INTENT(INOUT) :: QSUBBDRYTRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: INFXSUBRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT + + REAL, DIMENSION(IXRT,JXRT) :: ywtmp +!DJG Local Variables + + INTEGER :: I,J,KK +!djg INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK + + REAL :: GRDAREA + REAL :: SUBFLO + REAL :: WATAVAIL + + INTEGER :: SO8RT_D(IXRT,JXRT,3) + REAL :: SO8RT(IXRT,JXRT,8) + integer :: rt_option, index + + INTEGER :: DT_STEPS !-- number of timestep in routing + REAL :: SUBDT !-- subsurface routing timestep + INTEGER :: KRT !-- routing counter + REAL, DIMENSION(IXRT,JXRT,NSOIL) :: SMCTMP !--temp store of SMC + REAL, DIMENSION(IXRT,JXRT) :: ZWATTABLRTTMP ! temp store of ZWAT + REAL, DIMENSION(IXRT,JXRT) :: INFXSUBRTTMP ! temp store of infilx +!djg REAL, DIMENSION(IXRT,JXRT) :: CWATAVAIL ! temp specif. of wat avial + + + +!DJG Debug Variables... + REAL :: qsubchk,qsubbdrytmp + REAL :: junk1,junk2,junk3,junk5,junk6,junk7 + INTEGER, PARAMETER :: double=8 + REAL (KIND=double) :: smctot1a,smctot2a + INTEGER :: kx,count + + +!DJG ----------------------------------------------------------------- +!DJG SUBSURFACE ROUTING LOOP +!DJG - SUBSURFACE ROUTING RUN ON NOAH TIMESTEP +!DJG - SUBSURFACE ROUITNG ONLY PERFORMED ON SATURATED LAYERS +!DJG ----------------------------------------------------------------- + + !yw GRDAREA=DXRT*DXRT + ! GRDAREA=dist(i,j,9) + + +!DJG debug subsfc... + subflo = 0.0 + +!DJG Set up mass balance checks... +! CWATAVAIL = 0. !-- initialize subsurface watavail + SUBDT = DT !-- initialize the routing timestep to DT + + +!!!! Find saturated layer depth... +! Loop through domain to determine sat. layers and assign wat tbl depth... +! and water available for subsfc routing (CWATAVAIL)... +! +! CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & +! SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, & +! CWATAVAIL,SLDPTH) + + + +!DJG debug variable... + + +!DJG Courant check temp variable setup... + ZWATTABLRTTMP = ZWATTABLRT !-- temporary storage of water table level + + + + +!!!! Call subsurface routing subroutine... +#ifdef HYDRO_D + print *, "calling subsurface routing subroutine...Opt. ",rt_option +#endif + + + if(rt_option .eq. 1) then + CALL ROUTE_SUBSURFACE1(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & + LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT, & + SO8RT,SO8RT_D,CWATAVAIL,SUBDT) + else + CALL ROUTE_SUBSURFACE2(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & + LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT, & + CWATAVAIL,SUBDT) + end if + +#ifdef HYDRO_D + write(6,*) "finish calling ROUTE_SUBSURFACE ", rt_option +#endif + + +!!!! Update soil moisture fields with subsurface flow... + +!!!! Loop through subsurface routing domain... + DO I=1,IXRT + DO J=1,JXRT + +!!DJG Check for courant condition violation...put limit on qsub +!!DJG QSUB HAS units of m^3/s SUBFLO has units of m + + + IF (CWATAVAIL(i,j).le.ABS(qsubrt(i,j))/dist(i,j,9)*SUBDT) THEN + QSUBRT(i,j) = -1.0*CWATAVAIL(i,j) + SUBFLO = QSUBRT(i,j) !Units of qsubrt converted via CWATAVAIL + ELSE + SUBFLO=QSUBRT(I,J)/dist(i,j,9)*SUBDT !Convert qsubrt from m^3/s to m + END IF + + WATAVAIL=0. !Initialize to 0. for every cell... + + +!!DJG Begin loop through soil profile to adjust soil water content +!!DJG based on subsfc flow (SUBFLO)... + + IF (SUBFLO.GT.0) THEN ! Increase soil moist for +SUBFLO (Inflow) + +! Loop through soil layers from bottom to top + DO KK=NSOIL,1,-1 + + +! Check for saturated layers + IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK)) THEN + IF (SMCRT(I,J,KK).GT.SMCMAXRT(I,J,KK)) THEN +#ifdef HYDRO_D + print *, "Subsfc acct. SMCMAX exceeded...", & + SMCRT(I,J,KK), SMCMAXRT(I,J,KK),KK,i,j + call hydro_stop("SUBSFC_RTNG") +#endif + ELSE + END IF + ELSE + WATAVAIL = (SMCMAXRT(I,J,KK)-SMCRT(I,J,KK))*SLDPTH(KK) + IF (WATAVAIL.GE.SUBFLO) THEN + SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK) + SUBFLO = 0. + ELSE + SUBFLO = SUBFLO - WATAVAIL + SMCRT(I,J,KK) = SMCMAXRT(I,J,KK) + END IF + END IF + + IF (SUBFLO.EQ.0.) EXIT +! IF (SUBFLO.EQ.0.) goto 669 + + END DO ! END DO FOR SOIL LAYERS + +669 continue + +! If all layers sat. add remaining subflo to infilt. excess... + IF (KK.eq.0.AND.SUBFLO.gt.0.) then + INFXSUBRT(I,J) = INFXSUBRT(I,J) + SUBFLO*1000. !Units = mm + SUBFLO=0. + END IF + +!DJG Error trap... + if (subflo.ne.0.) then +#ifdef HYDRO_D + print *, "Subflo (+) not expired...:",subflo,i,j,kk,SMCRT(i,j,1), & + SMCRT(i,j,2),SMCRT(i,j,3),SMCRT(i,j,4),SMCRT(i,j,5), & + SMCRT(i,j,6),SMCRT(i,j,7),SMCRT(i,j,8),"SMCMAX",SMCMAXRT(i,j,1) +#endif + end if + + + ELSE IF (SUBFLO.LT.0) THEN ! Decrease soil moist for -SUBFLO (Drainage) + + +!DJG loop from satlyr back down and subtract out subflo as necess... +! now set to SMCREF, 8/24/07 +!DJG and then using unsat cond as opposed to Ksat... + + DO KK=SATLYRCHK(I,J),NSOIL + WATAVAIL = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK) + IF (WATAVAIL.GE.ABS(SUBFLO)) THEN +!?yw mod IF (WATAVAIL.GE.(ABS(SUBFLO)+0.000001) ) THEN + SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK) + SUBFLO=0. + ELSE ! Since subflo is small on a time-step following is unlikely... + SMCRT(I,J,KK)=SMCREFRT(I,J,KK) + SUBFLO=SUBFLO+WATAVAIL + END IF + IF (SUBFLO.EQ.0.) EXIT +! IF (SUBFLO.EQ.0.) goto 668 + + END DO ! END DO FOR SOIL LAYERS +668 continue + + +!DJG Error trap... + if(abs(subflo) .le. 1.E-7 ) subflo = 0.0 !truncate residual to 1E-7 prec. + + if (subflo.ne.0.) then +#ifdef HYDRO_D + print *, "Subflo (-) not expired:",i,j,subflo,CWATAVAIL(i,j) + print *, "zwatabl = ", ZWATTABLRT(I,J) + print *, "QSUBRT(I,J)=",QSUBRT(I,J) + print *, "WATAVAIL = ",WATAVAIL, "kk=",kk + print * +#endif + end if + + + + END IF ! end if for +/- SUBFLO soil moisture accounting... + + + + + END DO ! END DO X dim + END DO ! END DO Y dim +!!!! End loop through subsurface routing domain... + +#ifdef MPP_LAND + do i = 1, NSOIL + call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99) + end DO +#endif + + + +!DJG ---------------------------------------------------------------- + END SUBROUTINE SUBSFC_RTNG +!DJG ---------------------------------------------------------------- + + +!DJG ------------------------------------------------------------------------ +!DJG SUBSURFACE FINDZWAT +!DJG ------------------------------------------------------------------------ + SUBROUTINE FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & + SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT,CWATAVAIL,& + SLDPTH) + + IMPLICIT NONE + +!DJG -------- DECLARATIONS ------------------------ + + INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT + REAL, INTENT(IN), DIMENSION(NSOIL) :: ZSOIL + REAL, INTENT(IN), DIMENSION(NSOIL) :: SLDPTH + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: ZWATTABLRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: CWATAVAIL + INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SATLYRCHK + +!DJG Local Variables + INTEGER :: KK,i,j + + +!!!! Find saturated layer depth... +! Loop through domain to determine sat. layers and assign wat tbl depth... + + + SATLYRCHK = 0 !set flag for sat. layers + CWATAVAIL = 0. !set wat avail for subsfc rtng = 0. + + DO J=1,JXRT + DO I=1,IXRT + +! Loop through soil layers from bottom to top + DO KK=NSOIL,1,-1 + +! Check for saturated layers +! Add additional logical check to ensure water is 'available' for routing, +! (i.e. not 'frozen' or otherwise immobile) +! IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK).AND.SMCMAXRT(I,J,KK) & +! .GT.SMCWLTRT(I,J,KK)) THEN + IF ( (SMCRT(I,J,KK).GE.SMCREFRT(I,J,KK)).AND.(SMCREFRT(I,J,KK) & + .GT.SMCWLTRT(I,J,KK)) ) THEN +! Add additional check to ensure saturation from bottom up only...8/8/05 + IF((SATLYRCHK(I,J).EQ.KK+1) .OR. (KK.EQ.NSOIL) ) SATLYRCHK(I,J) = KK + END IF + + END DO + + +! Designate ZWATTABLRT based on highest sat. layer and +! Define amount of water avail for subsfc routing on each gridcell (CWATAVAIL) +! note: using a 'field capacity' value of SMCREF as lower limit... + + IF (SATLYRCHK(I,J).ne.0) then + IF (SATLYRCHK(I,J).ne.1) then ! soil column is partially sat. + ZWATTABLRT(I,J) = -ZSOIL(SATLYRCHK(I,J)-1) + DO KK=SATLYRCHK(I,J),NSOIL +!old CWATAVAIL(I,J) = (SMCRT(I,J,SATLYRCHK(I,J))-& +!old SMCREFRT(I,J,SATLYRCHK(I,J))) * & +!old (ZSOIL(SATLYRCHK(I,J)-1)-ZSOIL(NSOIL)) + CWATAVAIL(I,J) = CWATAVAIL(I,J)+(SMCRT(I,J,KK)- & + SMCREFRT(I,J,KK))*SLDPTH(KK) + END DO + + + ELSE ! soil column is fully saturated to sfc. + ZWATTABLRT(I,J) = 0. + DO KK=SATLYRCHK(I,J),NSOIL + CWATAVAIL(I,J) = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK) + END DO + END IF + ELSE ! no saturated layers... + ZWATTABLRT(I,J) = -ZSOIL(NSOIL) + SATLYRCHK(I,J) = NSOIL + 1 + END IF + + + END DO + END DO + + +!DJG ---------------------------------------------------------------- + END SUBROUTINE FINDZWAT +!DJG ---------------------------------------------------------------- + + +!DJG ---------------------------------------------------------------- +!DJG ---------------------------------------------------------------- +!DJG SUBROUTINE ROUTE_SUBSURFACE2 +!DJG ---------------------------------------------------------------- + + SUBROUTINE ROUTE_SUBSURFACE2( & + dist,z,qsub,sox,soy, & + latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,CWATAVAIL, & + SUBDT) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Subroutine to route subsurface flow through the watershed +!DJG ---------------------------------------------------------------- +! +! Called from: main.f (Noah_router_driver) +! +! Returns: qsub=DQSUB which in turn becomes SUBFLO in head calc. +! +! Created: D. Gochis 3/27/03 +! Adaptded from Wigmosta, 1994 +! +! Modified: D. Gochis 1/05/04 +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id,& + up_id,mpp_land_com_real,MPP_LAND_UB_COM, & + MPP_LAND_LR_COM,mpp_land_com_integer +#endif + + IMPLICIT NONE + + +!! Declare Passed variables + + INTEGER, INTENT(IN) :: XX,YY + +!! Declare passed arrays + + REAL, INTENT(IN), DIMENSION(XX,YY) :: z + REAL, INTENT(IN), DIMENSION(XX,YY) :: sox + REAL, INTENT(IN), DIMENSION(XX,YY) :: soy + REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat + REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL + REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep + REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY + REAL, INTENT(INOUT) :: QSUBDRYT + REAL, INTENT(IN) :: SUBDT + real, intent(in), dimension(xx,yy,9) :: dist + +!!! Declare Local Variables + + REAL :: dzdx,dzdy,beta,gamma + REAL :: qqsub,hh,ksat, gsize + + INTEGER :: i,j +!!! Initialize variables + REAL, PARAMETER :: nexp=1.0 ! local power law exponent + qsub = 0. ! initialize flux = 0. !DJG 5 May 2014 + +!yw soldep = 2. + + +! Begin Subsurface routing + +!!! Loop to route water in x-direction + do j=1,YY + do i=1,XX +! check for boundary grid point? + if (i.eq.XX) GOTO 998 + gsize = dist(i,j,3) + + dzdx= (z(i,j) - z(i+1,j))/gsize + beta=sox(i,j) + dzdx + 1E-30 + if (abs(beta) .lt. 1E-20) beta=1E-20 + if (beta.lt.0) then +!yw hh=(1-(z(i+1,j)/soldep(i,j)))**nexp + hh=(1-(z(i+1,j)/soldep(i+1,j)))**nexp +! Change later to use mean Ksat of two cells + ksat=latksat(i+1,j) + else + hh=(1-(z(i,j)/soldep(i,j)))**nexp + ksat=latksat(i,j) + end if + + if (hh .lt. 0.) then +#ifdef HYDRO_D + print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), & + soldep(i,j),nexp + call hydro_stop("ROUTE_SUBSURFACE2") +#endif + end if + +!Err. tan slope gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) + gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) +!DJG lacks tan(beta) of original Wigmosta version gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta + + qqsub = gamma * hh + qsub(i,j) = qsub(i,j) + qqsub + qsub(i+1,j) = qsub(i+1,j) - qqsub + +! Boundary adjustments +#ifdef MPP_LAND + if ((i.eq.1).AND.(beta.lt.0.).and.(left_id.lt.0)) then +#else + if ((i.eq.1).AND.(beta.lt.0.)) then +#endif + qsub(i,j) = qsub(i,j) - qqsub + QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub + QSUBDRYT = QSUBDRYT - qqsub +#ifdef MPP_LAND + else if ((i.eq.(xx-1)).AND.(beta.gt.0.) & + .and.(right_id.lt.0) ) then +#else + else if ((i.eq.(xx-1)).AND.(beta.gt.0.)) then +#endif + qsub(i+1,j) = qsub(i+1,j) + qqsub + QSUBDRY(i+1,j) = QSUBDRY(i+1,j) + qqsub + QSUBDRYT = QSUBDRYT + qqsub + end if + +998 continue + +!! End loop to route sfc water in x-direction + end do + end do + +#ifdef MPP_LAND + call MPP_LAND_LR_COM(qsub,XX,YY,99) + call MPP_LAND_LR_COM(QSUBDRY,XX,YY,99) +#endif + + +!!! Loop to route water in y-direction + do j=1,YY + do i=1,XX +! check for boundary grid point? + if (j.eq.YY) GOTO 999 + gsize = dist(i,j,1) + + dzdy= (z(i,j) - z(i,j+1))/gsize + beta=soy(i,j) + dzdy + 1E-30 + if (abs(beta) .lt. 1E-20) beta=1E-20 + if (beta.lt.0) then +!yw hh=(1-(z(i,j+1)/soldep(i,j)))**nexp + hh=(1-(z(i,j+1)/soldep(i,j+1)))**nexp + ksat=latksat(i,j+1) + else + hh=(1-(z(i,j)/soldep(i,j)))**nexp + ksat=latksat(i,j) + end if + + if (hh .lt. 0.) GOTO 999 + +!Err. tan slope gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) + gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta + + qqsub = gamma * hh + qsub(i,j) = qsub(i,j) + qqsub + qsub(i,j+1) = qsub(i,j+1) - qqsub + +! Boundary adjustments + +#ifdef MPP_LAND + if ((j.eq.1).AND.(beta.lt.0.).and.(down_id.lt.0)) then +#else + if ((j.eq.1).AND.(beta.lt.0.)) then +#endif + qsub(i,j) = qsub(i,j) - qqsub + QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub + QSUBDRYT = QSUBDRYT - qqsub +#ifdef MPP_LAND + else if ((j.eq.(yy-1)).AND.(beta.gt.0.) & + .and. (up_id.lt.0) ) then +#else + else if ((j.eq.(yy-1)).AND.(beta.gt.0.)) then +#endif + qsub(i,j+1) = qsub(i,j+1) + qqsub + QSUBDRY(i,j+1) = QSUBDRY(i,j+1) + qqsub + QSUBDRYT = QSUBDRYT + qqsub + end if + +999 continue + +!! End loop to route sfc water in y-direction + end do + end do + +#ifdef MPP_LAND + call MPP_LAND_UB_COM(qsub,XX,YY,99) + call MPP_LAND_UB_COM(QSUBDRY,XX,YY,99) +#endif + + return +!DJG------------------------------------------------------------ + end subroutine ROUTE_SUBSURFACE2 +!DJG------------------------------------------------------------ + + + +!DJG ------------------------------------------------ +!DJG SUBROUTINE OV_RTNG +!DJG ------------------------------------------------ + + SUBROUTINE OV_RTNG(DT,DTRT,IXRT,JXRT,INFXSUBRT, & + SFCHEADSUBRT,DHRT,CH_NETRT,RETDEPRT,OVROUGHRT, & + QSTRMVOLRT,QBDRYRT,QSTRMVOLTRT,QBDRYTRT,SOXRT, & + SOYRT,dist,LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT, & + SO8RT,SO8RT_D,rt_option,q_sfcflx_x,q_sfcflx_y) + +!yyww +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id, & + up_id,mpp_land_com_real, my_id, & + mpp_land_sync +#endif + + IMPLICIT NONE + +!DJG --------DECLARATIONS---------------------------- + + INTEGER, INTENT(IN) :: IXRT,JXRT + REAL, INTENT(IN) :: DT,DTRT + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: INFXSUBRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOYRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: RETDEPRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: OVROUGHRT + + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SFCHEADSUBRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: DHRT + + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_INFLORT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QBDRYRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: q_sfcflx_x,q_sfcflx_y + REAL, INTENT(INOUT) :: QSTRMVOLTRT,QBDRYTRT,LAKE_INFLOTRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8) :: SO8RT + +!DJG Local Variables + + INTEGER :: KRT,I,J,ct + + REAL, DIMENSION(IXRT,JXRT) :: INFXS_FRAC + REAL :: DT_FRAC,SUM_INFXS,sum_head + INTEGER SO8RT_D(IXRT,JXRT,3), rt_option + + + + +!DJG ---------------------------------------------------------------------- +! DJG BEGIN 1-D or 2-D OVERLAND FLOW ROUTING LOOP +!DJG --------------------------------------------------------------------- +!DJG Loop over 'routing time step' +!DJG Compute the number of time steps based on NOAH DT and routing DTRT + + DT_FRAC=INT(DT/DTRT) + +#ifdef HYDRO_D + write(6,*) "OV_RTNG DT_FRAC, DT, DTRT",DT_FRAC, DT, DTRT + write(6,*) "IXRT, JXRT = ",ixrt,jxrt +#endif + +!DJG NOTE: Applying all infiltration excess water at once then routing +!DJG Pre-existing SFHEAD gets combined with Precip. in the +!DJG calculation of INFXS1 during subroutine SRT.f. +!DJG debug + + +!DJG Assign all infiltration excess to surface head... + SFCHEADSUBRT=INFXSUBRT + +!DJG Divide infiltration excess over all routing time-steps +! INFXS_FRAC=INFXSUBRT/(DT/DTRT) + +!DJG Set flux accumulation fields to 0. before each loop... + q_sfcflx_x = 0. + q_sfcflx_y = 0. + ct =0 + + +!DJG Execute routing time-step loop... + + + DO KRT=1,DT_FRAC + + DO J=1,JXRT + DO I=1,IXRT + +!DJG Removed 4_29_05, sfhead now updated in route_overland subroutine... +! SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J) +!! SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J)+INFXS_FRAC(I,J) +! DHRT(I,J)=0. + +!DJG ERROR Check... + + IF (SFCHEADSUBRT(I,J).lt.0.) THEN +#ifdef HYDRO_D + print *, "ywcheck 2 ERROR!!!: Neg. Surface Head Value at (i,j):", & + i,j,SFCHEADSUBRT(I,J) + print *, "RETDEPRT(I,J) = ",RETDEPRT(I,J), "KRT=",KRT + print *, "INFXSUBRT(i,j)=",INFXSUBRT(i,j) + print *, "jxrt=",jxrt," ixrt=",ixrt +#endif + END IF + +!DJG Remove surface water from channel cells +!DJG Channel inflo cells specified as nonzeros from CH_NET +!DJG 9/16/04 Channel Extractions Removed until stream model implemented... + + + + IF (CH_NETRT(I,J).ne.-9999) THEN + ct = ct +1 + +!DJG Temporary test to up the retention depth of channel grid cells to 'soak' +!more water into valleys....set retdep = retdep*100 (=5 mm) + +! RETDEPRT(I,J) = RETDEPRT(I,J) * 100.0 !DJG TEMP HARDWIRE!!!! +! RETDEPRT(I,J) = 10.0 !DJG TEMP HARDWIRE!!!! + + IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN +!! QINFLO(CH_NET(I,J)=QINFLO(CH_NET(I,J)+SFCHEAD(I,J) - RETDEPRT(I,J) + QSTRMVOLTRT = QSTRMVOLTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J)) + QSTRMVOLRT(I,J) = QSTRMVOLRT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J) + SFCHEADSUBRT(I,J) = RETDEPRT(I,J) + END IF + END IF + +!DJG Lake inflow withdrawl from surface head...(4/29/05) + + + IF (LAKE_MSKRT(I,J).gt.0) THEN + IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN + LAKE_INFLOTRT = LAKE_INFLOTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J)) + LAKE_INFLORT(I,J) = LAKE_INFLORT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J) + SFCHEADSUBRT(I,J) = RETDEPRT(I,J) + + END IF + END IF + + + + END DO + END DO + +! call MPP_LAND_COM_REAL(QSTRMVOLRT,IXRT,JXRT,99) +!DJG---------------------------------------------------------------------- +!DJG CALL OVERLAND FLOW ROUTING SUBROUTINE +!DJG---------------------------------------------------------------------- + +!DJG Debug... + + + if(rt_option .eq. 1) then + CALL ROUTE_OVERLAND1(DTRT,dist,SFCHEADSUBRT,DHRT,SOXRT, & + SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT, & + SO8RT,SO8RT_D,q_sfcflx_x,q_sfcflx_y) + else + CALL ROUTE_OVERLAND2(DTRT,dist,SFCHEADSUBRT,DHRT,SOXRT, & + SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT, & + q_sfcflx_x,q_sfcflx_y) + end if + + END DO ! END routing time steps + +#ifdef HYDRO_D + print *, "End of OV_routing call..." +#endif + +!---------------------------------------------------------------------- +! END OVERLAND FLOW ROUTING LOOP +! CHANNEL ROUTING TO FOLLOW +!---------------------------------------------------------------------- + +!DJG ---------------------------------------------------------------- + END SUBROUTINE OV_RTNG +!DJG ---------------------------------------------------------------- + +!DJG SUBROUTINE ROUTE_OVERLAND1 +!DJG ---------------------------------------------------------------- + + SUBROUTINE ROUTE_OVERLAND1(dt, & + & gsize,h,qsfc,sox,soy, & + & retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT,SO8RT,SO8RT_D, & + & q_sfcflx_x,q_sfcflx_y) +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Subroutine to route excess rainfall over the watershed +! using a 2d diffusion routing scheme. +! +! Called from: main.f +! +! Will try to formulate this to be called from NOAH +! +! Returns: qsfc=DQOV which in turn becomes DH in head calc. +! +! Created: Adaptded from CASC2D source code +! NOTE: dh from original code has been replaced by qsfc +! dhh replaced by qqsfc +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id, & + up_id,mpp_land_com_real, my_id, mpp_land_com_real8,& + mpp_land_sync +#endif + + IMPLICIT NONE + + +!! Declare Passed variables + + INTEGER, INTENT(IN) :: XX,YY + REAL, INTENT(IN) :: dt, gsize(xx,yy,9) + +!! Declare passed arrays + + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h + REAL, INTENT(IN), DIMENSION(XX,YY) :: qsfc + REAL, INTENT(IN), DIMENSION(XX,YY) :: sox + REAL, INTENT(IN), DIMENSION(XX,YY) :: soy + REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep + REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x, q_sfcflx_y + REAL, INTENT(INOUT) :: QBDRYT + REAL, INTENT(IN), DIMENSION(XX,YY,8) :: SO8RT + REAL*8, DIMENSION(XX,YY) :: QBDRY_tmp, DH + REAL*8, DIMENSION(XX,YY) :: DH_tmp + +!!! Declare Local Variables + + REAL :: dhdx,dhdy,alfax,alfay + REAL :: hh53,qqsfc,hh,dt_new,hmax + REAL :: sfx,sfy + REAL :: tmp_adjust + + INTEGER :: i,j + REAL IXX8,IYY8 + INTEGER IXX0,JYY0,index, SO8RT_D(XX,YY,3) + REAL tmp_gsize,hsum + +!!! Initialize variables + + + +!!! Begin Routing of Excess Rainfall over the Watershed + + DH=0. + DH_tmp=0. + QBDRY_tmp =0. + +!!! Loop to route water + do j=2,YY-1 + do i=2,XX-1 + if (h(I,J).GT.retent_dep(I,J)) then + IXX0 = SO8RT_D(i,j,1) + JYY0 = SO8RT_D(i,j,2) + index = SO8RT_D(i,j,3) + tmp_gsize = 1.0/gsize(i,j,index) + sfx = so8RT(i,j,index)-(h(IXX0,JYY0)-h(i,j))*0.001*tmp_gsize + hmax = h(i,j)*0.001 !Specify max head for mass flux limit... + if(sfx .lt. 1E-20) then + call GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,so8rt,gsize(i,j,:),sfx,XX,YY) + end if + if(IXX0 > 0) then ! do the rest if the lowest grid can be found. + if(sfx .lt. 1E-20) then +#ifdef HYDRO_D + print*, "Message: sfx reset to 1E-20. sfx =",sfx + print*, "i,j,index,IXX0,JYY0",i,j,index,IXX0,JYY0 + print*, "so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index) ", & + so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index) +#endif + sfx = 1E-20 + end if + alfax = sqrt(sfx) / dist_rough(i,j) + hh=(h(i,j)-retent_dep(i,j)) * 0.001 + hh53=hh**(5./3.) + +! Calculate q-flux... + qqsfc = alfax*hh53*dt * tmp_gsize + +!Courant check (simple mass limit on overland flow)... + if (qqsfc.ge.(hmax*dt*tmp_gsize)) qqsfc = hmax*dt*tmp_gsize + +! Accumulate directional fluxes on routing subgrid... + if (IXX0.gt.i) then + q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc * & + (1.0 - 0.5 * (ABS(j-JYY0))) + else if (IXX0.lt.i) then + q_sfcflx_x(I,J) = q_sfcflx_x(I,J) - 1.0 * & + qqsfc * (1.0 - 0.5 * (ABS(j-JYY0))) + else + q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + 0. + end if + if (JYY0.gt.j) then + q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc * & + (1.0 - 0.5 * (ABS(i-IXX0))) + elseif (JYY0.lt.j) then + q_sfcflx_y(I,J) = q_sfcflx_y(I,J) - 1.0 * & + qqsfc * (1.0 - 0.5 * (ABS(i-IXX0))) + else + q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + 0. + end if + + +!DJG put adjustment in for (h) due to qqsfc + +!yw changed as following: + tmp_adjust=qqsfc*1000 + if((h(i,j) - tmp_adjust) <0 ) then +#ifdef HYDRO_D + print*, "Error Warning: surface head is negative: ",i,j,ixx0,jyy0, & + h(i,j) - tmp_adjust +#endif + tmp_adjust = h(i,j) + end if + DH(i,j) = DH(i,j)-tmp_adjust + DH_tmp(ixx0,jyy0) = DH_tmp(ixx0,jyy0) + tmp_adjust + !yw end change + + !DG Boundary adjustments here + !DG Constant Flux Condition +#ifdef MPP_LAND + if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. & + ((ixx0.eq.1) .and.(left_id .lt. 0)) .or. & + ((jyy0.eq.1) .and.(down_id .lt. 0)) .or. & + ((JYY0.eq.YY).and.(up_id .lt. 0)) ) then + QBDRY_tmp(IXX0,JYY0)=QBDRY_tmp(IXX0,JYY0) - qqsfc*1000. +#else + if ((ixx0.eq.XX).or.(ixx0.eq.1).or.(jyy0.eq.1) & + .or.(JYY0.eq.YY )) then + QBDRY(IXX0,JYY0)=QBDRY(IXX0,JYY0) - qqsfc*1000. +#endif + QBDRYT=QBDRYT - qqsfc + DH_tmp(IXX0,JYY0)= DH_tmp(IXX0,JYY0)-tmp_adjust + end if + end if +!! End loop to route sfc water + end if + end do + end do + +#ifdef MPP_LAND +! use double precision to solve the underflow problem. + call MPP_LAND_COM_REAL8(DH_tmp,XX,YY,1) + call MPP_LAND_COM_REAL8(QBDRY_tmp,XX,YY,1) +#endif + QBDRY = QBDRY + QBDRY_tmp + DH = DH+DH_tmp + +#ifdef MPP_LAND + call MPP_LAND_COM_REAL8(DH,XX,YY,99) + call MPP_LAND_COM_REAL(QBDRY,XX,YY,99) +#endif + + H = H + DH + + return + +!DJG ---------------------------------------------------------------------- + end subroutine ROUTE_OVERLAND1 + + +!DJG ---------------------------------------------------------------- + SUBROUTINE GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,sox,tmp_gsize,max,XX,YY) + implicit none + INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY + INTEGER, INTENT(IN) :: I,J + + REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY,8),tmp_gsize(9) + REAL max + IXX0 = -1 + max = 0 + if (h(I,J).LE.retent_dep(I,J)) return + + IXX8 = I + JYY8 = J+1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY) + + IXX8 = I+1 + JYY8 = J+1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY) + + IXX8 = I+1 + JYY8 = J + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY) + + IXX8 = I+1 + JYY8 = J-1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY) + + IXX8 = I + JYY8 = J-1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY) + + IXX8 = I-1 + JYY8 = J-1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY) + + IXX8 = I-1 + JYY8 = J + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY) + + IXX8 = I-1 + JYY8 = J+1 + call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY) + RETURN + END SUBROUTINE GETMAX8DIR + + SUBROUTINE GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox & + ,IXX0,JYY0,max,tmp_gsize,XX,YY) + implicit none + integer,INTENT(INOUT) ::IXX0,JYY0 + INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY + REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY) + REAL, INTENT(INOUT) ::max + real, INTENT(IN) :: tmp_gsize + real :: sfx + + sfx = sox(i,j)-(h(IXX8,JYY8)-h(i,j))*0.001/tmp_gsize + if(sfx .le. 0 ) return + if(max < sfx ) then + IXX0 = IXX8 + JYY0 = JYY8 + max = sfx + end if + + END SUBROUTINE GET8DIR +!DJG ---------------------------------------------------------------- +!DJG SUBROUTINE ROUTE_SUBSURFACE1 +!DJG ---------------------------------------------------------------- + + SUBROUTINE ROUTE_SUBSURFACE1( & + dist,z,qsub,sox,soy, & + latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,SO8RT,SO8RT_D, & + CWATAVAIL,SUBDT) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Subroutine to route subsurface flow through the watershed +! +! Called from: main.f (Noah_router_driver) +! +! Returns: qsub=DQSUB which in turn becomes SUBFLO in head calc. +! +! Created: D. Gochis 3/27/03 +! Adaptded from Wigmosta, 1994 +! +! Modified: D. Gochis 1/05/04 +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id,& + up_id,mpp_land_com_real8,my_id,mpp_land_com_real +#endif + + IMPLICIT NONE + + +!! Declare Passed variables + + INTEGER, INTENT(IN) :: XX,YY + +!! Declare passed arrays + + REAL, INTENT(IN), DIMENSION(XX,YY) :: z + REAL, INTENT(IN), DIMENSION(XX,YY) :: sox + REAL, INTENT(IN), DIMENSION(XX,YY) :: soy + REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat + REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL + REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep + REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY + REAL, INTENT(INOUT) :: QSUBDRYT + REAL*8, DIMENSION(XX,YY) :: qsub_tmp,QSUBDRY_tmp +!yw INTEGER, INTENT(OUT) :: flag + REAL, INTENT(IN) :: dist(xx,yy,9),SUBDT + +!!! Declare Local Variables + + REAL :: dzdx,dzdy,beta,gamma + REAL :: qqsub,hh,ksat + + REAL :: SO8RT(XX,YY,8) + INTEGER :: SO8RT_D(XX,YY,3), rt_option + + +!!! Initialize variables + + REAL, PARAMETER :: nexp=1.0 ! local power law exponent + integer IXX0,JYY0,index,i,j + real tmp_gsize + +! temporary set it to be 2. Should be passed in. +!yw soldep = 2. +! Begin Subsurface routing + + + +!!! Loop to route water in x-direction + qsub_tmp = 0. + QSUBDRY_tmp = 0. + +#ifdef HYDRO_D + write(6,*) "call subsurface routing xx= , yy =", yy, xx +#endif + + do j=2,YY-1 + do i=2,XX-1 + + + if(i.ge.2.AND.i.le.XX-1.AND.j.ge.2.AND.j.le.YY-1) then !if grdcl chk +! check for boundary grid point? + IXX0 = SO8RT_D(i,j,1) + JYY0 = SO8RT_D(i,j,2) + + index = SO8RT_D(i,j,3) + + if(dist(i,j,index) .le. 0) then +#ifdef HYDRO_D + write(6,*) "Error: dist(i,j,index) is <= zero " + call hydro_stop("ROUTE_SUBSURFACE1") +#endif + endif + if(soldep(i,j) .eq. 0) then +#ifdef HYDRO_D + write(6,*) "Error: soldep is = zero " + call hydro_stop("ROUTE_SUBSURFACE1") +#endif + endif + + tmp_gsize = 1.0/dist(i,j,index) + + + dzdx= (z(i,j) - z(IXX0,JYY0) )* tmp_gsize + beta=so8RT(i,j,index) + dzdx + + if(beta .lt. 1E-20 ) then !if-then for direction... + call GETSUB8(IXX0,JYY0,I,J,Z,so8rt,dist(i,j,:),beta,XX,YY) + end if + if(beta .gt. 0) then !if-then for flux calc + if(beta .lt. 1E-20 ) then +#ifdef HYDRO_D + print*, "Message: beta need to be reset to 1E-20. beta = ",beta +#endif + beta = 1E-20 + end if + +! do the rest if the lowest grid can be found. + hh=(1-(z(i,j)/soldep(i,j)))**nexp + ksat=latksat(i,j) + + if (hh .lt. 0.) then +#ifdef HYDRO_D + print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), & + soldep(i,j) + call hydro_stop("ROUTE_SUBSURFACE1") +#endif + end if + +!err. tan slope gamma=-1.0*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) + gamma=-1.0*((dist(i,j,index)*ksat*soldep(i,j))/nexp)*beta + qqsub = gamma * hh + + qsub(i,j) = qsub(i,j) + qqsub + qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) - qqsub + +!!DJG Error Checks... + if(qqsub .gt. 0) then +#ifdef HYDRO_D + print*, "Error: qqsub should be negative, qqsub =",qqsub,& + "gamma=",gamma,"hh=",hh,"beta=",beta,"dzdx=",dzdx,& + "so8RT=",so8RT(i,j,index),"latksat=",ksat, & + "tan(beta)=",tan(beta),i,j,z(i,j),z(IXX0,JYY0) + print*, "ixx0=",ixx0, "jyy0=",jyy0 + print*, "soldep =", soldep(i,j), "nexp=",nexp + call hydro_stop("ROUTE_SUBSURFACE1") +#endif + end if + + + + +! Boundary adjustments +#ifdef MPP_LAND + if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. & + ((ixx0.eq.1) .and.(left_id .lt. 0)) .or. & + ((jyy0.eq.1) .and.(down_id .lt. 0)) .or. & + ((JYY0.eq.YY).and.(up_id .lt. 0)) ) then +#else + if ((ixx0.eq.1).or.(ixx0.eq.xx).or.(jyy0.eq.1).or.(jyy0.eq.yy)) then +#endif + qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) + qqsub + QSUBDRY_tmp(ixx0,jyy0) = QSUBDRY_tmp(ixx0,jyy0) + qqsub + + QSUBDRYT = QSUBDRYT + qqsub + end if + +998 continue + +!! End loop to route sfc water in x-direction + end if !endif for flux calc + + endif !! Endif for gridcell check... + + + end do !endif for i-dim +!CRNT debug if(flag.eq.-99) exit !exit loop for courant violation... + end do !endif for j-dim + +#ifdef MPP_LAND + + call MPP_LAND_COM_REAL8(qsub_tmp,XX,YY,1) + call MPP_LAND_COM_REAL8(QSUBDRY_tmp,XX,YY,1) +#endif + qsub = qsub + qsub_tmp + QSUBDRY= QSUBDRY + QSUBDRY_tmp + + + do j=2,YY-1 + do i=2,XX-1 + if(dist(i,j,9) .le. 0) then +#ifdef HYDRO_D + write(6,*) "Error: dist(i,j,9) is <= zero " + call hydro_stop("ROUTE_SUBSURFACE1") +#endif + endif + if(CWATAVAIL(i,j).lt.ABS(qsub(i,j))/dist(i,j,9)*SUBDT) THEN + qsub(i,j) = -1.0*CWATAVAIL(i,j) + end if + end do + end do +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(qsub,XX,YY,99) + call MPP_LAND_COM_REAL(QSUBDRY,XX,YY,99) +#endif + + + return +!DJG------------------------------------------------------------ + end subroutine ROUTE_SUBSURFACE1 +!DJG------------------------------------------------------------ + +!DJG------------------------------------------------------------ + + + SUBROUTINE GETSUB8(IXX0,JYY0,I,J,Z,sox,tmp_gsize,max,XX,YY) + implicit none + INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY + INTEGER, INTENT(IN) :: I,J + + REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY,8),tmp_gsize(9) + REAL max + max = -1 + + IXX8 = I + JYY8 = J+1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY) + + IXX8 = I+1 + JYY8 = J+1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY) + + IXX8 = I+1 + JYY8 = J + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY) + + IXX8 = I+1 + JYY8 = J-1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY) + + IXX8 = I + JYY8 = J-1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY) + + IXX8 = I-1 + JYY8 = J-1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY) + + IXX8 = I-1 + JYY8 = J + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY) + + IXX8 = I-1 + JYY8 = J+1 + call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY) + RETURN + END SUBROUTINE GETSUB8 + + SUBROUTINE GETSUB8DIR(IXX8,JYY8,I,J,Z,sox,IXX0,JYY0,max,tmp_gsize,XX,YY) + implicit none + integer,INTENT(INOUT) ::IXX0,JYY0 + INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY + REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY) + REAL, INTENT(INOUT) ::max + real, INTENT(IN) :: tmp_gsize + real :: beta , dzdx + + dzdx= (z(i,j) - z(IXX0,JYY0) )/tmp_gsize + beta=sox(i,j) + dzdx + if(max < beta ) then + IXX0 = IXX8 + JYY0 = JYY8 + max = beta + end if + + END SUBROUTINE GETSUB8DIR +!DJG ---------------------------------------------------------------------- + +!DJG SUBROUTINE ROUTE_OVERLAND2 +!DJG ---------------------------------------------------------------- + + SUBROUTINE ROUTE_OVERLAND2 (dt, & + & dist,h,qsfc,sox,soy, & + & retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT, & + & q_sfcflx_x,q_sfcflx_y) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Subroutine to route excess rainfall over the watershed +! using a 2d diffusion routing scheme. +! +! Called from: main.f +! +! Will try to formulate this to be called from NOAH +! +! Returns: qsfc=DQOV which in turn becomes DH in head calc. +! +! Created: Adaptded from CASC2D source code +! NOTE: dh from original code has been replaced by qsfc +! dhh replaced by qqsfc +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id,& + up_id,mpp_land_com_real,MPP_LAND_UB_COM, & + MPP_LAND_LR_COM,mpp_land_com_integer +#endif + + IMPLICIT NONE + + +!! Declare Passed variables + + real :: gsize + INTEGER, INTENT(IN) :: XX,YY + REAL, INTENT(IN) :: dt , dist(XX,YY,9) + +!! Declare passed arrays + + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: qsfc + REAL, INTENT(IN), DIMENSION(XX,YY) :: sox + REAL, INTENT(IN), DIMENSION(XX,YY) :: soy + REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep + REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY + REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x,q_sfcflx_y + REAL, INTENT(INOUT) :: QBDRYT + REAL :: DH(XX,YY) + +!!! Declare Local Variables + + REAL :: dhdx,dhdy,alfax,alfay + REAL :: hh53,qqsfc,hh,dt_new + REAL :: sfx,sfy + REAL :: tmp_adjust + + INTEGER :: i,j + +!!! Initialize variables + + + + +!!! Begin Routing of Excess Rainfall over the Watershed + + + DH = 0 +!!! Loop to route water in x-direction + do j=1,YY + do i=1,XX + + +! check for boundary gridpoint? + if (i.eq.XX) GOTO 998 + gsize = dist(i,j,3) + + +! check for detention storage? + if (h(i,j).lt.retent_dep(i,j).AND. & + h(i+1,j).lt.retent_dep(i+1,j)) GOTO 998 + + dhdx = (h(i+1,j)/1000. - h(i,j)/1000.) / gsize ! gisze-(m),h-(mm) + + sfx = (sox(i,j)-dhdx+1E-30) + if (abs(sfx).lt.1E-20) sfx=1E-20 + alfax = ((abs(sfx))**0.5)/dist_rough(i,j) + if (sfx.lt.0.) then + hh=(h(i+1,j)-retent_dep(i+1,j))/1000. + else + hh=(h(i,j)-retent_dep(i,j))/1000. + end if + + if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 998 + if (hh.lt.0.) then + GOTO 998 + end if + + hh53=hh**(5./3.) + + +! Calculate q-flux... (units (m)) + qqsfc = (sfx/abs(sfx))*alfax*hh53*dt/gsize + q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc + +!DJG put adjustment in for (h) due to qqsfc + +!yw changed as following: + tmp_adjust=qqsfc*1000 + if(tmp_adjust .le. 0 ) GOTO 998 + if((h(i,j) - tmp_adjust) <0 ) then +#ifdef HYDRO_D + print*, "Error Warning: surface head is negative: ",i,j +#endif + tmp_adjust = h(i,j) + end if + if((h(i+1,j) + tmp_adjust) <0) then +#ifdef HYDRO_D + print*, "Error Warning: surface head is negative: ",i+1,j +#endif + tmp_adjust = -1*h(i+1,j) + end if + Dh(i,j) = Dh(i,j)-tmp_adjust + Dh(i+1,j) = Dh(i+1,j) + tmp_adjust +!yw end change + + + +!DG Boundary adjustments here +!DG Constant Flux Condition +#ifdef MPP_LAND + if ((i.eq.1).AND.(sfx.lt.0).and. & + (left_id .lt. 0) ) then +#else + if ((i.eq.1).AND.(sfx.lt.0)) then +#endif + Dh(i,j) = Dh(i,j) + qqsfc*1000. + QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000. + QBDRYT=QBDRYT + qqsfc*1000. +#ifdef MPP_LAND + else if ( (i.eq.(XX-1)).AND.(sfx.gt.0) & + .and. (right_id .lt. 0) ) then +#else + else if ((i.eq.(XX-1)).AND.(sfx.gt.0)) then +#endif + tmp_adjust = qqsfc*1000. + if(h(i+1,j).lt.tmp_adjust) tmp_adjust = h(i+1,j) + Dh(i+1,j) = Dh(i+1,j) - tmp_adjust +!DJG Re-assign h(i+1) = 0.0 when <0.0 (from rounding/truncation error) + QBDRY(I+1,J)=QBDRY(I+1,J) - tmp_adjust + QBDRYT=QBDRYT - tmp_adjust + end if + + +998 continue + +!! End loop to route sfc water in x-direction + end do + end do + + H = H + DH +#ifdef MPP_LAND + call MPP_LAND_LR_COM(H,XX,YY,99) + call MPP_LAND_LR_COM(QBDRY,XX,YY,99) +#endif + + + DH = 0 +!!!! Loop to route water in y-direction + do j=1,YY + do i=1,XX + +!! check for boundary grid point? + if (j.eq.YY) GOTO 999 + gsize = dist(i,j,1) + + +!! check for detention storage? + if (h(i,j).lt.retent_dep(i,j).AND. & + h(i,j+1).lt.retent_dep(i,j+1)) GOTO 999 + + dhdy = (h(i,j+1)/1000. - h(i,j)/1000.) / gsize + + sfy = (soy(i,j)-dhdy+1E-30) + if (abs(sfy).lt.1E-20) sfy=1E-20 + alfay = ((abs(sfy))**0.5)/dist_rough(i,j) + if (sfy.lt.0.) then + hh=(h(i,j+1)-retent_dep(i,j+1))/1000. + else + hh=(h(i,j)-retent_dep(i,j))/1000. + end if + + if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 999 + if (hh.lt.0.) then + GOTO 999 + end if + + hh53=hh**(5./3.) + +! Calculate q-flux... + qqsfc = (sfy/abs(sfy))*alfay*hh53*dt / gsize + q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc + + +!DJG put adjustment in for (h) due to qqsfc +!yw h(i,j) = h(i,j)-qqsfc*1000. +!yw h(i,j+1) = h(i,j+1) + qqsfc*1000. +!yw changed as following: + tmp_adjust=qqsfc*1000 + if(tmp_adjust .le. 0 ) GOTO 999 + + if((h(i,j) - tmp_adjust) <0 ) then +#ifdef HYDRO_D + print*, "Error Warning: surface head is negative: ",i,j +#endif + tmp_adjust = h(i,j) + end if + if((h(i,j+1) + tmp_adjust) <0) then +#ifdef HYDRO_D + print*, "Error Warning: surface head is negative: ",i,j+1 +#endif + tmp_adjust = -1*h(i,j+1) + end if + Dh(i,j) = Dh(i,j)-tmp_adjust + Dh(i,j+1) = Dh(i,j+1) + tmp_adjust +!yw end change + +! qsfc(i,j) = qsfc(i,j)-qqsfc +! qsfc(i,j+1) = qsfc(i,j+1) + qqsfc +!!DG Boundary adjustments here +!!DG Constant Flux Condition +#ifdef MPP_LAND + if ((j.eq.1).AND.(sfy.lt.0) & + .and. (down_id .lt. 0) ) then +#else + if ((j.eq.1).AND.(sfy.lt.0)) then +#endif + Dh(i,j) = Dh(i,j) + qqsfc*1000. + QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000. + QBDRYT=QBDRYT + qqsfc*1000. +#ifdef MPP_LAND + else if ((j.eq.(YY-1)).AND.(sfy.gt.0) & + .and. (up_id .lt. 0) ) then +#else + else if ((j.eq.(YY-1)).AND.(sfy.gt.0)) then +#endif + tmp_adjust = qqsfc*1000. + if(h(i,j+1).lt.tmp_adjust) tmp_adjust = h(i,j+1) + Dh(i,j+1) = Dh(i,j+1) - tmp_adjust +!DJG Re-assign h(j+1) = 0.0 when <0.0 (from rounding/truncation error) + QBDRY(I,J+1)=QBDRY(I,J+1) - tmp_adjust + QBDRYT=QBDRYT - tmp_adjust + end if + +999 continue + +!!!! End loop to route sfc water in y-direction + end do + end do + + H = H +DH +#ifdef MPP_LAND + call MPP_LAND_UB_COM(H,XX,YY,99) + call MPP_LAND_UB_COM(QBDRY,XX,YY,99) +#endif + return + +!DJG ---------------------------------------------------------------------- + end subroutine ROUTE_OVERLAND2 + + +!DJG ---------------------------------------------------------------------- + + +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE TER_ADJ_SOL - Terrain adjustment of incoming solar radiation +!DJG----------------------------------------------------------------------- + SUBROUTINE TER_ADJ_SOL(IX,JX,SO8LD_D,TSLP,SHORT,XLAT,XLONG,olddate,DT) + +#ifdef MPP_LAND + use module_mpp_land, only: my_id, io_id, & + mpp_land_bcast_int1 +#endif + implicit none + integer,INTENT(IN) :: IX,JX + INTEGER,INTENT(in), DIMENSION(IX,JX,3) :: SO8LD_D + real,INTENT(IN), DIMENSION(IX,JX) :: XLAT,XLONG + real,INTENT(IN) :: DT + real,INTENT(INOUT), DIMENSION(IX,JX) :: SHORT + character(len=19) :: olddate + +! Local Variables... + real, dimension(IX,JX) ::TSLP,TAZI + real, dimension(IX,JX) ::SOLDN + real :: SOLDEC,DGRD,ITIME2,HRANGLE + real :: BINSH,SOLZANG,SOLAZI,INCADJ + real :: TAZIR,TSLPR,LATR,LONR,SOLDNADJ + integer :: JULDAY0,HHTIME0,MMTIME0,YYYY0,MM0,DD0 + integer :: JULDAY,HHTIME,MMTIME,YYYY,MM,DD + integer :: I,J + + +!---------------------------------------------------------------------- +! SPECIFY PARAMETERS and VARIABLES +!---------------------------------------------------------------------- + + JULDAY = 0 + SOLDN = SHORT + DGRD = 3.14159/180. + +! Set up time variables... +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + read(olddate(1:4),"(I4)") YYYY0 ! real-time year (GMT) + read(olddate(6:7),"(I2.2)") MM0 ! real-time month (GMT) + read(olddate(9:10),"(I2.2)") DD0 ! real-time day (GMT) + read(olddate(12:13),"(I2.2)") HHTIME0 ! real-time hour (GMT) + read(olddate(15:16),"(I2.2)") MMTIME0 ! real-time minutes (GMT) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(YYYY0) + call mpp_land_bcast_int1(MM0) + call mpp_land_bcast_int1(DD0) + call mpp_land_bcast_int1(HHTIME0) + call mpp_land_bcast_int1(MMTIME0) +#endif + + +! Set up terrain variables...(returns TSLP&TAZI in radians) + call SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) + +!---------------------------------------------------------------------- +! BEGIN LOOP THROUGH GRID +!---------------------------------------------------------------------- + DO J=1,JX + DO I=1,IX + YYYY = YYYY0 + MM = MM0 + DD = DD0 + HHTIME = HHTIME0 + MMTIME = MMTIME0 + call GMT2LOCAL(1,1,XLONG(i,j),YYYY,MM,DD,HHTIME,MMTIME,DT) + call JULDAY_CALC(YYYY,MM,DD,JULDAY) + +! Convert to radians... + LATR = XLAT(I,J) !send solsub local lat in deg + LONR = XLONG(I,J) !send solsub local lon in deg + TSLPR = TSLP(I,J)/DGRD !send solsub local slp in deg + TAZIR = TAZI(I,J)/DGRD !send solsub local azim in deg + +!Call SOLSUB to return terrain adjusted incoming solar radiation... +! SOLSUB taken from Whiteman and Allwine, 1986, Environ. Software. + + call SOLSUB(LONR,LATR,TAZIR,TSLPR,SOLDN(I,J),YYYY,MM, & + DD,HHTIME,MMTIME,SOLDNADJ,SOLZANG,SOLAZI,INCADJ) + + SOLDN(I,J)=SOLDNADJ + + ENDDO + ENDDO + + SHORT = SOLDN + + return + end SUBROUTINE TER_ADJ_SOL +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE TER_ADJ_SOL +!DJG----------------------------------------------------------------------- + + +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE GMT2LOCAL +!DJG----------------------------------------------------------------------- + subroutine GMT2LOCAL(IX,JX,XLONG,YY,MM,DD,HH,MIN,DT) + + implicit none + +!!! Declare Passed Args. + + INTEGER, INTENT(INOUT) :: yy,mm,dd,hh,min + INTEGER, INTENT(IN) :: IX,JX + REAL,INTENT(IN), DIMENSION(IX,JX) :: XLONG + REAL,INTENT(IN) :: DT + +!!! Declare local variables + + integer :: i,j,minflag,hhflag,ddflag,mmflag,yyflag + integer :: adj_min,lst_adj_min,lst_adj_hh,adj_hh + real, dimension(IX,JX) :: TDIFF + real :: tmp + integer :: yyinit,mminit,ddinit,hhinit,mininit + +!!! Initialize flags + hhflag=0 + ddflag=0 + mmflag=0 + yyflag=0 + +!!! Set up constants... + yyinit = yy + mminit = mm + ddinit = dd + hhinit = hh + mininit = min + + +! Loop through data... + do j=1,JX + do i=1,IX + +! Reset yy,mm,dd... + yy = yyinit + mm = mminit + dd = ddinit + hh = hhinit + min = mininit + +!!! Set up adjustments... +! - assumes +E , -W longitude and 0.06667 hr/deg (=24/360) + TDIFF(I,J) = XLONG(I,J)*0.06667 ! time offset in hr + tmp = TDIFF(I,J) + lst_adj_hh = INT(tmp) + lst_adj_min = NINT(MOD(int(tmp),1)*60.) + int(DT/2./60.) ! w/ 1/2 timestep adjustment... + +!!! Process Minutes... + adj_min = min+lst_adj_min + if (adj_min.lt.0) then + min=60+adj_min + lst_adj_hh = lst_adj_hh - 1 + else if (adj_min.ge.0.AND.adj_min.lt.60) then + min=adj_min + else if (adj_min.ge.60) then + min=adj_min-60 + lst_adj_hh = lst_adj_hh + 1 + end if + +!!! Process Hours + adj_hh = hh+lst_adj_hh + if (adj_hh.lt.0) then + hh = 24+adj_hh + ddflag=1 + else if (adj_hh.ge.0.AND.adj_hh.lt.24) then + hh=adj_hh + else if (adj_hh.ge.24) then + hh=adj_hh-24 + ddflag = 2 + end if + + + +!!! Process Days, Months, Years +! Subtract a day + if (ddflag.eq.1) then + if (dd.gt.1) then + dd=dd-1 + else + if (mm.eq.1) then + mm=12 + yy=yy-1 + else + mm=mm-1 + end if + if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & + (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & + (mm.eq.12)) then + dd=31 + else + +!!! Adjustment for leap years!!! + if(mm.eq.2) then + if(MOD(yy,4).eq.0) then + dd=29 + else + dd=28 + end if + end if + if(mm.ne.2) dd=30 + end if + end if + end if + +! Add a day + if (ddflag.eq.2) then + if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & + (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & + (mm.eq.12)) then + if (dd.eq.31) then + dd=1 + if (mm.eq.12) then + mm=1 + yy=yy+1 + else + mm=mm+1 + end if + else + dd=dd+1 + end if + +!!! Adjustment for leap years!!! + else if (mm.eq.2) then + if(MOD(yy,4).eq.0) then + if (dd.eq.29) then + dd=1 + mm=3 + else + dd=dd+1 + end if + else + if (dd.eq.28) then + dd=1 + mm=3 + else + dd=dd+1 + end if + end if + else + if (dd.eq.30) then + dd=1 + mm=mm+1 + else + dd=dd+1 + end if + end if + + end if + + end do !i-loop + end do !j-loop + + return + end subroutine + +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE GMT2LOCAL +!DJG----------------------------------------------------------------------- + + + +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE JULDAY_CALC +!DJG----------------------------------------------------------------------- + subroutine JULDAY_CALC(YYYY,MM,DD,JULDAY) + + implicit none + integer,intent(in) :: YYYY,MM,DD + integer,intent(out) :: JULDAY + + integer :: resid + integer julm(13) + DATA JULM/0, 31, 59, 90, 120, 151, 181, 212, 243, 273, & + 304, 334, 365 / + + integer LPjulm(13) + DATA LPJULM/0, 31, 60, 91, 121, 152, 182, 213, 244, 274, & + 305, 335, 366 / + + resid = MOD(YYYY,4) !Set up leap year check... + + if (resid.ne.0) then !If not a leap year.... + JULDAY = JULM(MM) + DD + else !If a leap year... + JULDAY = LPJULM(MM) + DD + end if + + RETURN + END subroutine JULDAY_CALC +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE JULDAY +!DJG----------------------------------------------------------------------- + +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE SLOPE_ASPECT +!DJG----------------------------------------------------------------------- + subroutine SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) + + implicit none + integer, INTENT(IN) :: IX,JX +! real,INTENT(in),DIMENSION(IX,JX) :: TSLP !terrain slope (m/m) + real,INTENT(OUT),DIMENSION(IX,JX) :: TAZI !terrain aspect (deg) + + INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D + real :: DGRD + integer :: i,j + +! TSLP = 0. !Initialize as flat + TAZI = 0. !Initialize as north facing + +! Find steepest descent slope and direction... + do j=1,JX + do i=1,IX +! TSLP(I,J) = TANH(Vmax(i,j)) ! calculate slope in radians... + +! Convert steepest slope and aspect to radians... + IF (SO8LD_D(i,j,3).eq.1) then + TAZI(I,J) = 0.0 + ELSEIF (SO8LD_D(i,j,3).eq.2) then + TAZI(I,J) = 45.0 + ELSEIF (SO8LD_D(i,j,3).eq.3) then + TAZI(I,J) = 90.0 + ELSEIF (SO8LD_D(i,j,3).eq.4) then + TAZI(I,J) = 135.0 + ELSEIF (SO8LD_D(i,j,3).eq.5) then + TAZI(I,J) = 180.0 + ELSEIF (SO8LD_D(i,j,3).eq.6) then + TAZI(I,J) = 225.0 + ELSEIF (SO8LD_D(i,j,3).eq.7) then + TAZI(I,J) = 270.0 + ELSEIF (SO8LD_D(i,j,3).eq.8) then + TAZI(I,J) = 315.0 + END IF + + DGRD = 3.141593/180. + TAZI(I,J) = TAZI(I,J)*DGRD ! convert azimuth to radians... + + END DO + END DO + + RETURN + END subroutine SLOPE_ASPECT +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE SLOPE_ASPECT +!DJG----------------------------------------------------------------------- + +!DJG---------------------------------------------------------------- +!DJG SUBROUTINE SOLSUB +!DJG---------------------------------------------------------------- + SUBROUTINE SOLSUB(LONG,LAT,AZ,IN,SC,YY,MO,IDA,IHR,MM,OUT1, & + OUT2,OUT3,INCADJ) + + +! Notes.... + + implicit none + logical :: daily, first + integer :: yy,mo,ida,ihr,mm,d + integer,dimension(12) :: nday + real :: lat,long,longcor,longsun,in,inslo + real :: az,sc,out1,out2,out3,cosbeta,dzero,eccent,pi,calint + real :: rtod,decmax,omega,onehr,omd,omdzero,rdvecsq,sdec + real :: declin,cdec,arg,declon,sr,stdmrdn,b,em,timnoon,azslo + real :: slat,clat,caz,saz,sinc,cinc,hinc,h,cosz,extra,extslo + real :: t1,z,cosa,a,cosbeta_flat,INCADJ + integer :: HHTIME,MMTIME,i,ik + real, dimension(4) :: ACOF,BCOF + +! Constants + daily=.FALSE. + ACOF(1) = 0.00839 + ACOF(2) = -0.05391 + ACOF(3) = -0.00154 + ACOF(4) = -0.0022 + BCOF(1) = -0.12193 + BCOF(2) = -0.15699 + BCOF(3) = -0.00657 + BCOF(4) = -0.00370 + DZERO = 80. + ECCENT = 0.0167 + PI = 3.14159 + CALINT = 1. + RTOD = PI / 180. + DECMAX=(23.+26./60.)*RTOD + OMEGA=2*PI/365. + ONEHR=15.*RTOD + +! Calculate Julian Day... + D = 0 + call JULDAY_CALC(YY,MO,IDA,D) + +! Ratio of radius vectors squared... + OMD=OMEGA*D + OMDZERO=OMEGA*DZERO +! RDVECSQ=1./(1.-ECCENT*COS(OMD))**2 + RDVECSQ = 1. ! no adjustment for orbital changes when coupled to HRLDAS... + +! Declination of sun... + LONGSUN=OMEGA*(D-Dzero)+2.*ECCENT*(SIN(OMD)-SIN(OMDZERO)) + DECLIN=ASIN(SIN(DECMAX)*SIN(LONGSUN)) + SDEC=SIN(DECLIN) + CDEC=COS(DECLIN) + +! Check for Polar Day/night... + ARG=((PI/2.)-ABS(DECLIN))/RTOD + IF(ABS(LAT).GT.ARG) THEN + IF((LAT.GT.0..AND.DECLIN.LT.0) .OR. & + (LAT.LT.0..AND.DECLON.GT.0.)) THEN + OUT1 = 0. + OUT2 = 0. + OUT3 = 0. + RETURN + ENDIF + SR=-1.*PI + ELSE + +! Calculate sunrise hour angle... + SR=-1.*ABS(ACOS(-1.*TAN(LAT*RTOD)*TAN(DECLIN))) + END IF + +! Find standard meridian for site + STDMRDN=NINT(LONG/15.)*15. + LONGCOR=(LONG-STDMRDN)/15. + +! Compute time correction from equation of time... + B=2.*PI*(D-.4)/365 + EM=0. + DO I=1,4 + EM=EM+(BCOF(I)*SIN(I*B)+ACOF(I)*COS(I*B)) + END DO + +! Compute time of solar noon... + TIMNOON=12.-EM-LONGCOR + +! Set up a few more terms... + AZSLO=AZ*RTOD + INSLO=IN*RTOD + SLAT=SIN(LAT*RTOD) + CLAT=COS(LAT*RTOD) + CAZ=COS(AZSLO) + SAZ=SIN(AZSLO) + SINC=SIN(INSLO) + CINC=COS(INSLO) + +! Begin solar radiation calculations...daily first, else instantaneous... + IF (DAILY) THEN ! compute daily integrated values...(Not used in HRLDAS!) + IHR=0 + MM=0 + HINC=CALINT*ONEHR/60. + IK=(2.*ABS(SR)/HINC)+2. + FIRST=.TRUE. + OUT1=0. + DO I=1,IK + H=SR+HINC*FLOAT(I-1) + COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) + COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & + SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & + SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) + EXTRA=SC*RDVECSQ*COSZ + IF(EXTRA.LE.0.) EXTRA=0. + EXTSLO=SC*RDVECSQ*COSBETA + IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. + IF(FIRST .AND. EXTSLO.GT.0.) THEN + OUT2=(H-HINC)/ONEHR+TIMNOON + FIRST = .FALSE. + END IF + IF(.NOT.FIRST .AND. EXTSLO.LE.0.) OUT3=H/ONEHR+TIMNOON + OUT1=EXTSLO+OUT1 + END DO + OUT1=OUT1*CALINT*60./1000000. + + ELSE ! Compute instantaneous values...(Is used in HRLDAS!) + + T1=FLOAT(IHR)+FLOAT(MM)/60. + H=ONEHR*(T1-TIMNOON) + COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) + +! Assuming HRLDAS forcing already accounts for season, time of day etc, +! subtract out the component of adjustment that would occur for +! a flat surface, this should leave only the sloped component remaining + + COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & + SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & + SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) + + COSBETA_FLAT=CDEC*CLAT*COS(H)+SDEC*SLAT + + INCADJ = COSBETA+(1-COSBETA_FLAT) + + EXTRA=SC*RDVECSQ*COSZ + IF(EXTRA.LE.0.) EXTRA=0. + EXTSLO=SC*RDVECSQ*INCADJ +! IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. !remove check for HRLDAS. + OUT1=EXTSLO + Z=ACOS(COSZ) + COSA=(SLAT*COSZ-SDEC)/(CLAT*SIN(Z)) + IF(COSA.LT.-1.) COSA=-1. + IF(COSA.GT.1.) COSA=1. + A=ABS(ACOS(COSA)) + IF(H.LT.0.) A=-A + OUT2=Z/RTOD + OUT3=A/RTOD+180 + + END IF ! End if for daily vs instantaneous values... + +!DJG----------------------------------------------------------------------- + RETURN + END SUBROUTINE SOLSUB +!DJG----------------------------------------------------------------------- + + subroutine seq_land_SO8(SO8LD_D,Vmax,TERR,dx,ix,jx) + implicit none + integer :: ix,jx,i,j + REAL, DIMENSION(IX,JX,8) :: SO8LD + INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D + real,DIMENSION(IX,JX) :: TERR + real :: dx(ix,jx,9),Vmax(ix,jx) + SO8LD_D = -1 + do j = 2, jx -1 + do i = 2, ix -1 + SO8LD(i,j,1) = (TERR(i,j)-TERR(i,j+1))/dx(i,j,1) + SO8LD_D(i,j,1) = i + SO8LD_D(i,j,2) = j + 1 + SO8LD_D(i,j,3) = 1 + Vmax(i,j) = SO8LD(i,j,1) + + SO8LD(i,j,2) = (TERR(i,j)-TERR(i+1,j+1))/DX(i,j,2) + if(SO8LD(i,j,2) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + 1 + SO8LD_D(i,j,2) = j + 1 + SO8LD_D(i,j,3) = 2 + Vmax(i,j) = SO8LD(i,j,2) + end if + SO8LD(i,j,3) = (TERR(i,j)-TERR(i+1,j))/DX(i,j,3) + if(SO8LD(i,j,3) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + 1 + SO8LD_D(i,j,2) = j + SO8LD_D(i,j,3) = 3 + Vmax(i,j) = SO8LD(i,j,3) + end if + SO8LD(i,j,4) = (TERR(i,j)-TERR(i+1,j-1))/DX(i,j,4) + if(SO8LD(i,j,4) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + 1 + SO8LD_D(i,j,2) = j - 1 + SO8LD_D(i,j,3) = 4 + Vmax(i,j) = SO8LD(i,j,4) + end if + SO8LD(i,j,5) = (TERR(i,j)-TERR(i,j-1))/DX(i,j,5) + if(SO8LD(i,j,5) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + SO8LD_D(i,j,2) = j - 1 + SO8LD_D(i,j,3) = 5 + Vmax(i,j) = SO8LD(i,j,5) + end if + SO8LD(i,j,6) = (TERR(i,j)-TERR(i-1,j-1))/DX(i,j,6) + if(SO8LD(i,j,6) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i - 1 + SO8LD_D(i,j,2) = j - 1 + SO8LD_D(i,j,3) = 6 + Vmax(i,j) = SO8LD(i,j,6) + end if + SO8LD(i,j,7) = (TERR(i,j)-TERR(i-1,j))/DX(i,j,7) + if(SO8LD(i,j,7) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i - 1 + SO8LD_D(i,j,2) = j + SO8LD_D(i,j,3) = 7 + Vmax(i,j) = SO8LD(i,j,7) + end if + SO8LD(i,j,8) = (TERR(i,j)-TERR(i-1,j+1))/DX(i,j,8) + if(SO8LD(i,j,8) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i - 1 + SO8LD_D(i,j,2) = j + 1 + SO8LD_D(i,j,3) = 8 + Vmax(i,j) = SO8LD(i,j,8) + end if + enddo + enddo + Vmax = TANH(Vmax) + return + end subroutine seq_land_SO8 + +#ifdef MPP_LAND + subroutine MPP_seq_land_SO8(SO8LD_D,Vmax,TERRAIN,dx,ix,jx,& + global_nx,global_ny) + + use module_mpp_land, only: my_id, io_id, & + write_io_real,decompose_data_int,decompose_data_real + + implicit none + integer,intent(in) :: ix,jx,global_nx,global_ny + INTEGER, intent(inout),DIMENSION(IX,JX,3) :: SO8LD_D +! real,intent(in), DIMENSION(IX,JX) :: TERRAIN + real,DIMENSION(IX,JX) :: TERRAIN + real,intent(out),dimension(ix,jx) :: Vmax + real,intent(in) :: dx(ix,jx,9) + real :: g_dx(ix,jx,9) + + real,DIMENSION(global_nx,global_ny) :: g_TERRAIN + real,DIMENSION(global_nx,global_ny) :: g_Vmax + integer,DIMENSION(global_nx,global_ny,3) :: g_SO8LD_D + integer :: k + + g_SO8LD_D = 0 + g_Vmax = 0 + + do k = 1, 9 + call write_IO_real(dx(:,:,k),g_dx(:,:,k)) + end do + + call write_IO_real(TERRAIN,g_TERRAIN) + if(my_id .eq. IO_id) then + call seq_land_SO8(g_SO8LD_D,g_Vmax,g_TERRAIN,g_dx,global_nx,global_ny) + endif + call decompose_data_int(g_SO8LD_D(:,:,3),SO8LD_D(:,:,3)) + call decompose_data_real(g_Vmax,Vmax) + return + end subroutine MPP_seq_land_SO8 + +#endif + + + + subroutine disaggregateDomain_drv(did) + use module_RT_data, only: rt_domain + use module_namelist, only: nlst_rt + integer :: did + call disaggregateDomain( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,& + RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT,nlst_rt(did)%AGGFACTRT,RT_DOMAIN(did)%SICE, & + RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%SH2OX,RT_DOMAIN(did)%INFXSRT, & + rt_domain(did)%dist_lsm(:,:,9),RT_DOMAIN(did)%SMCMAX1,RT_DOMAIN(did)%SMCREF1, & + RT_DOMAIN(did)%SMCWLT1,RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%LKSAT,RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%INFXSWGT, RT_DOMAIN(did)%OVROUGHRTFAC,RT_DOMAIN(did)%LKSATFAC, & + RT_DOMAIN(did)%CH_NETRT,RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%SMCREFRT, & + RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%SMCMAXRT, RT_DOMAIN(did)%SMCWLTRT, & + RT_DOMAIN(did)%SMCRT, & + RT_DOMAIN(did)%OVROUGHRT, RT_DOMAIN(did)%LAKE_MSKRT, & + RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%OV_ROUGH,RT_DOMAIN(did)%SLDPTH ) + + end subroutine disaggregateDomain_drv + + subroutine disaggregateDomain(IX,JX,NSOIL,IXRT,JXRT,AGGFACTRT, & + SICE, SMC,SH2OX, INFXSRT, area_lsm, SMCMAX1,SMCREF1, & + SMCWLT1, VEGTYP, LKSAT, dist,INFXSWGT,OVROUGHRTFAC, & + LKSATFAC, CH_NETRT,SH2OWGT,SMCREFRT, INFXSUBRT,SMCMAXRT, & + SMCWLTRT,SMCRT, OVROUGHRT, LAKE_MSKRT, LKSATRT,OV_ROUGH, & + SLDPTH & + ) +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id, & + up_id,mpp_land_com_real, my_id, & + mpp_land_sync,mpp_land_com_integer,mpp_land_max_int1, & + sum_double +#endif + implicit none + integer,INTENT(IN) :: IX,JX,NSOIL,IXRT,JXRT,AGGFACTRT + real,INTENT(OUT),DIMENSION(IX,JX,NSOIL)::SICE + real,INTENT(IN),DIMENSION(IX,JX,NSOIL)::SMC,SH2OX + real,INTENT(IN),DIMENSION(IX,JX)::INFXSRT, area_lsm, SMCMAX1,SMCREF1, & + SMCWLT1, LKSAT + integer,INTENT(IN),DIMENSION(IX,JX) ::VEGTYP + + real,INTENT(IN),DIMENSION(IXRT,JXRT,9)::dist + real,INTENT(IN),DIMENSION(IXRT,JXRT)::INFXSWGT,OVROUGHRTFAC, & + LKSATFAC + integer,INTENT(IN), DIMENSION(IXRT,JXRT) ::CH_NETRT + real,INTENT(IN),DIMENSION(IXRT,JXRT,NSOIL)::SH2OWGT + real,INTENT(OUT),DIMENSION(IXRT,JXRT,NSOIL)::SMCREFRT, SMCMAXRT, & + SMCWLTRT,SMCRT + real,INTENT(OUT),DIMENSION(IXRT,JXRT)::INFXSUBRT + real,INTENT(INOUT),DIMENSION(IXRT,JXRT)::OVROUGHRT, LKSATRT + integer,INTENT(INOUT), DIMENSION(IXRT,JXRT) ::LAKE_MSKRT + + + real,INTENT(IN), DIMENSION(NSOIL) :: SLDPTH + REAL OV_ROUGH(*) + + + + integer :: i, j, AGGFACYRT, AGGFACXRT, IXXRT, JYYRT,KRT, KF + REAL :: LSMVOL,SMCEXCS, WATHOLDCAP +!------------------------------------- + + + + SICE=SMC-SH2OX + SMCREFRT = 0 + +!DJG First, Disaggregate a few key fields for routing... +!DJG Debug... +#ifdef HYDRO_D + print *, "Beginning Disaggregation..." +#endif + +!DJG Mass balance check for disagg... + + +!DJG Weighting alg. alteration...(prescribe wghts if time = 1) + + + do J=1,JX + do I=1,IX + +!DJG Weighting alg. alteration... + LSMVOL=INFXSRT(I,J)*area_lsm(I,J) + + + do AGGFACYRT=AGGFACTRT-1,0,-1 + do AGGFACXRT=AGGFACTRT-1,0,-1 + + IXXRT=I*AGGFACTRT-AGGFACXRT + JYYRT=J*AGGFACTRT-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#else +!yw ???? +! IXXRT=IXXRT+1 +! JYYRT=JYYRT+1 +#endif + + +!DJG Implement subgrid weighting routine... + INFXSUBRT(IXXRT,JYYRT)=LSMVOL* & + INFXSWGT(IXXRT,JYYRT)/dist(IXXRT,JYYRT,9) + + + do KRT=1,NSOIL !Do for soil profile loop + IF(SICE(I,J,KRT).gt.0) then !...adjust for soil ice +!DJG Adjust SMCMAX for SICE when subsfc routing...make 3d variable + SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J)-SICE(I,J,KRT) + SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J)-SICE(I,J,KRT) + WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) + IF (SICE(I,J,KRT).le.WATHOLDCAP) then + SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) + else + if(SICE(I,J,KRT).lt.SMCMAX1(I,J)) & + SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - & + (SICE(I,J,KRT)-WATHOLDCAP) + if(SICE(I,J,KRT).ge.SMCMAX1(I,J)) SMCWLTRT(IXXRT,JYYRT,KRT) = 0. + end if + ELSE + SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J) + SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J) + WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) + SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) + END IF !endif adjust for soil ice... + + +!Now Adjust soil moisture +!DJG Use SH2O instead of SMC for 'liquid' water... + IF(SMCMAXRT(IXXRT,JYYRT,KRT).GT.0) THEN !Check for smcmax data (=0 over water) + SMCRT(IXXRT,JYYRT,KRT)=SH2OX(I,J,KRT)*SH2OWGT(IXXRT,JYYRT,KRT) +!old SMCRT(IXXRT,JYYRT,KRT)=SMC(I,J,KRT) + ELSE + SMCRT(IXXRT,JYYRT,KRT) = 0.001 !will be skipped w/ landmask + SMCMAXRT(IXXRT,JYYRT,KRT) = 0.001 + END IF +!DJG Check/Adjust so that subgrid cells do not exceed saturation... + IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN + SMCEXCS = (SMCRT(IXXRT,JYYRT,KRT) - SMCMAXRT(IXXRT,JYYRT,KRT)) & + * SLDPTH(KRT)*1000. !Excess soil water in units of (mm) + SMCRT(IXXRT,JYYRT,KRT) = SMCMAXRT(IXXRT,JYYRT,KRT) + DO KF = KRT-1,1, -1 !loop back upward to redistribute excess water from disagg. + SMCRT(IXXRT,JYYRT,KF) = SMCRT(IXXRT,JYYRT,KF) + SMCEXCS/(SLDPTH(KF)*1000.) + IF (SMCRT(IXXRT,JYYRT,KF).GT.SMCMAXRT(IXXRT,JYYRT,KF)) THEN !Recheck new lyr sat. + SMCEXCS = (SMCRT(IXXRT,JYYRT,KF) - SMCMAXRT(IXXRT,JYYRT,KF)) & + * SLDPTH(KF)*1000. !Excess soil water in units of (mm) + SMCRT(IXXRT,JYYRT,KF) = SMCMAXRT(IXXRT,JYYRT,KF) + ELSE ! Excess soil water expired + SMCEXCS = 0. + EXIT + END IF + END DO + IF (SMCEXCS.GT.0) THEN !If not expired by sfc then add to Infil. Excess + INFXSUBRT(IXXRT,JYYRT) = INFXSUBRT(IXXRT,JYYRT) + SMCEXCS + SMCEXCS = 0. + END IF + END IF !End if for soil moisture saturation excess + + + end do !End do for soil profile loop + + + + do KRT=1,NSOIL !debug loop + + IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN +#ifdef HYDRO_D + print *, "Err. SMCMAX exceeded upon disaggregation3...", ixxrt,jyyrt,krt,& + SMCRT(IXXRT,JYYRT,KRT),SMCMAXRT(IXXRT,JYYRT,KRT) + call hydro_stop("disaggregateDomain") +#endif + ELSE IF (SMCRT(IXXRT,JYYRT,KRT).LE.0.) THEN +#ifdef HYDRO_D + print *, "Err. SMCRT fully depleted upon disaggregation...", ixxrt,jyyrt,krt,& + SMCRT(IXXRT,JYYRT,KRT),SH2OWGT(IXXRT,JYYRT,KRT),SH2OX(I,J,KRT) + + print*, "SMC=", SMC(i,j,KRT), "SICE =", sice(i,j,KRT) + print *, "VEGTYP = ", VEGTYP(I,J) + print *, "i,j,krt, nsoil",i,j,krt,nsoil + call hydro_stop("disaggregateDomain SMCRT depleted") +#endif + END IF + end do !debug loop + + + +!DJG map ov roughness as function of land use provided in VEGPARM.TBL... +! --- added extra check for VEGTYP for 'masked-out' locations... +! --- out of basin locations (VEGTYP=0) have OVROUGH hardwired to 0.1 + IF (VEGTYP(I,J).LE.0) then + OVROUGHRT(IXXRT,JYYRT) = 0.1 !COWS mask test + ELSE + OVROUGHRT(IXXRT,JYYRT)=OV_ROUGH(VEGTYP(I,J))*OVROUGHRTFAC(IXXRT,JYYRT) ! Distributed calibration...1/17/2012 + END IF + + + +!DJG 6.12.08 Map lateral hydraulic conductivity and apply distributed scaling +! --- factor that will be read in from hires terrain file +! LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) + LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) * LKSATFAC(IXXRT,JYYRT) * & !Apply scaling factor... +! ...and scale from max to 0 when SMC decreases from SMCMAX to SMCREF... +!!DJG error found from KIT,improper scaling ((SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL)) / & + (max(0.,(SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL))) / & + (SMCMAXRT(IXXRT,JYYRT,NSOIL)-SMCREFRT(IXXRT,JYYRT,NSOIL)) ) + + + +!DJG set up lake mask... +!--- modify to make lake mask large here, but not one of the routed lakes!!! +!-- IF (VEGTYP(I,J).eq.16) then + IF (VEGTYP(I,J).eq.16 .and. & + CH_NETRT(IXXRT,JYYRT).le.0) then + !--LAKE_MSKRT(IXXRT,JYYRT) = 1 +!yw LAKE_MSKRT(IXXRT,JYYRT) = 9999 + LAKE_MSKRT(IXXRT,JYYRT) = -9999 + end if + + end do + end do + + end do + end do + + + + +#ifdef HYDRO_D + print *, "After Disaggregation..." +#endif + +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(INFXSUBRT,IXRT,JXRT,99) + call MPP_LAND_COM_REAL(LKSATRT,IXRT,JXRT,99) + call MPP_LAND_COM_REAL(OVROUGHRT,IXRT,JXRT,99) + call MPP_LAND_COM_INTEGER(LAKE_MSKRT,IXRT,JXRT,99) + do i = 1, NSOIL + call MPP_LAND_COM_REAL(SMCMAXRT(:,:,i),IXRT,JXRT,99) + call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99) + call MPP_LAND_COM_REAL(SMCWLTRT(:,:,i),IXRT,JXRT,99) + end DO +#endif + + end subroutine disaggregateDomain + + subroutine SubsurfaceRouting_drv(did) + + use module_RT_data, only: rt_domain + use module_namelist, only: nlst_rt + implicit none + integer :: did + IF (nlst_rt(did)%SUBRTSWCRT.EQ.1) THEN + call subsurfaceRouting (RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt , nlst_rt(did)%nsoil, & + RT_DOMAIN(did)%SMCRT,RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCREFRT,& + RT_DOMAIN(did)%SMCWLTRT, RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SLDPTH, & + nlst_rt(did)%DT,RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SOXRT, & + RT_DOMAIN(did)%SOYRT,RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%SOLDEPRT, & + RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%QSUBBDRYTRT, RT_DOMAIN(did)%QSUBBDRYRT,& + RT_DOMAIN(did)%QSUBRT ,nlst_rt(did)%rt_option, RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%sub_resid,RT_DOMAIN(did)%SO8RT_D, RT_DOMAIN(did)%SO8RT) + endif + end subroutine SubsurfaceRouting_drv + + subroutine subsurfaceRouting (ixrt, jxrt , nsoil, & + SMCRT,SMCMAXRT,SMCREFRT,SMCWLTRT, & + ZSOIL, SLDPTH, & + DT,ZWATTABLRT,SOXRT,SOYRT,LKSATRT,& + SOLDEPRT,INFXSUBRT,QSUBBDRYTRT, QSUBBDRYRT,& + QSUBRT ,rt_option, dist,sub_resid,SO8RT_D, SO8RT) +#ifdef MPP_LAND + use module_mpp_land, only: mpp_land_com_real, mpp_land_com_integer +#endif + implicit none + integer, INTENT(IN) :: ixrt, jxrt , nsoil, rt_option + REAL, INTENT(IN) :: DT + real,INTENT(IN), DIMENSION(NSOIL) :: ZSOIL, SLDPTH + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT,SOYRT,LKSATRT, SOLDEPRT , sub_resid + real,INTENT(INOUT), DIMENSION(IXRT,JXRT)::INFXSUBRT + real,INTENT(INOUT) :: QSUBBDRYTRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBBDRYRT, QSUBRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT, SMCWLTRT, SMCMAXRT,SMCREFRT + + + INTEGER :: SO8RT_D(IXRT,JXRT,3) + REAL :: SO8RT(IXRT,JXRT,8) + REAL, INTENT(IN) :: dist(ixrt,jxrt,9) +! -----local array ---------- + REAL, DIMENSION(IXRT,JXRT) :: ZWATTABLRT + REAL, DIMENSION(IXRT,JXRT) :: CWATAVAIL + INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK + + + + + CWATAVAIL = 0. + CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & + SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, & + CWATAVAIL,SLDPTH) +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(ZWATTABLRT,IXRT,JXRT,99) + call MPP_LAND_COM_REAL(CWATAVAIL,IXRT,JXRT,99) + call MPP_LAND_COM_INTEGER(SATLYRCHK,IXRT,JXRT,99) +#endif + + +!DJG Second, Call subsurface routing routine... +#ifdef HYDRO_D + print *, "Beginning SUB_routing..." + print *, "Routing method is ",rt_option, " direction." +#endif + +!!!! Find saturated layer depth... +! Loop through domain to determine sat. layers and assign wat tbl depth... +! and water available for subsfc routing (CWATAVAIL)... +! This subroutine returns: ZWATTABLRT, CWATAVAIL and SATLYRCHK + + + CALL SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & + LKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT,NSOIL,SMCRT, & + INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT,SMCWLTRT,SO8RT, & + SO8RT_D, rt_option,SLDPTH,SUB_RESID,CWATAVAIL,SATLYRCHK) + +#ifdef HYDRO_D + print *, "SUBROUTE routing called and returned..." +#endif + + end subroutine subsurfaceRouting + + + subroutine OverlandRouting_drv(did) + use module_RT_data, only: rt_domain + use module_namelist, only: nlst_rt + implicit none + integer :: did + if(nlst_rt(did)%OVRTSWCRT .eq. 1) then + call OverlandRouting (nlst_rt(did)%DT, nlst_rt(did)%DTRT, nlst_rt(did)%rt_option, & + rt_domain(did)%ixrt, rt_domain(did)%jxrt,rt_domain(did)%LAKE_MSKRT, & + rt_domain(did)%INFXSUBRT, rt_domain(did)%RETDEPRT,rt_domain(did)%OVROUGHRT, & + rt_domain(did)%SOXRT, rt_domain(did)%SOYRT, rt_domain(did)%SFCHEADSUBRT, & + rt_domain(did)%DHRT, rt_domain(did)%CH_NETRT, rt_domain(did)%QSTRMVOLRT, & + rt_domain(did)%LAKE_INFLORT,rt_domain(did)%QBDRYRT, & + rt_domain(did)%QSTRMVOLTRT,rt_domain(did)%QBDRYTRT, rt_domain(did)%LAKE_INFLOTRT,& + rt_domain(did)%q_sfcflx_x,rt_domain(did)%q_sfcflx_y, & + rt_domain(did)%dist, rt_domain(did)%SO8RT, rt_domain(did)%SO8RT_D , & + rt_domain(did)%SMCTOT2,rt_domain(did)%suminfxs1,rt_domain(did)%suminfxsrt, & + rt_domain(did)%smctot1,rt_domain(did)%dsmctot ) + endif + end subroutine OverlandRouting_drv + + + + subroutine OverlandRouting (DT, DTRT, rt_option, ixrt, jxrt,LAKE_MSKRT, & + INFXSUBRT, RETDEPRT,OVROUGHRT,SOXRT, SOYRT, SFCHEADSUBRT,DHRT, & + CH_NETRT, QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, & + QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y, & + dist, SO8RT, SO8RT_D, & + SMCTOT2,suminfxs1,suminfxsrt,smctot1,dsmctot ) +#ifdef MPP_LAND + use module_mpp_land, only: mpp_land_max_int1, sum_double +#endif + implicit none + + REAL, INTENT(IN) :: DT, DTRT + integer, INTENT(IN) :: ixrt, jxrt, rt_option + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: INFXSUBRT, & + RETDEPRT,OVROUGHRT,SOXRT, SOYRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SFCHEADSUBRT,DHRT + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, & + QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y + + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8) :: SO8RT + INTEGER SO8RT_D(IXRT,JXRT,3) + + integer :: i,j + + + INTEGER, PARAMETER :: double1=8 + real (KIND=double1) :: smctot2,smctot1,dsmctot + real (KIND=double1) :: suminfxsrt,suminfxs1 +! local variable + real (KIND=double1) :: chan_in1,chan_in2 + real (KIND=double1) :: lake_in1,lake_in2 + real (KIND=double1) :: qbdry1,qbdry2 + integer :: sfcrt_flag + + + +!DJG Third, Call Overland Flow Routing Routine... +#ifdef HYDRO_D + print *, "Beginning OV_routing..." + print *, "Routing method is ",rt_option, " direction." +#endif + +!DJG debug...OV Routing... + suminfxs1=0. + chan_in1=0. + lake_in1=0. + qbdry1=0. + do i=1,IXRT + do j=1,JXRT + suminfxs1=suminfxs1+INFXSUBRT(I,J)/float(IXRT*JXRT) + chan_in1=chan_in1+QSTRMVOLRT(I,J)/float(IXRT*JXRT) + lake_in1=lake_in1+LAKE_INFLORT(I,J)/float(IXRT*JXRT) + qbdry1=qbdry1+QBDRYRT(I,J)/float(IXRT*JXRT) + end do + end do + +#ifdef MPP_LAND +! not tested + CALL sum_double(suminfxs1) + CALL sum_double(chan_in1) + CALL sum_double(lake_in1) + CALL sum_double(qbdry1) +#endif + + +!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(set sfcrt_flag) +!DJG.7.20.2007 - this check will skip ov rtng when no flow is present... + + sfcrt_flag = 0 + + do j=1,jxrt + do i=1,ixrt + if(INFXSUBRT(i,j).gt.RETDEPRT(i,j)) then + sfcrt_flag = 1 + exit + end if + end do + if(sfcrt_flag.eq.1) exit + end do + +#ifdef MPP_LAND + call mpp_land_max_int1(sfcrt_flag) +#endif +!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(IF) + + if (sfcrt_flag.eq.1) then !If/then for sfc_rt check... +#ifdef HYDRO_D + write(6,*) "calling OV_RTNG " +#endif + CALL OV_RTNG(DT,DTRT,IXRT,JXRT,INFXSUBRT,SFCHEADSUBRT,DHRT, & + CH_NETRT,RETDEPRT,OVROUGHRT,QSTRMVOLRT,QBDRYRT, & + QSTRMVOLTRT,QBDRYTRT,SOXRT,SOYRT,dist, & + LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT,SO8RT,SO8RT_D,rt_option,& + q_sfcflx_x,q_sfcflx_y) + else +#ifdef HYDRO_D + print *, "No water to route overland..." +#endif + end if !Endif for sfc_rt check... + +!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(ENDIF) + +#ifdef HYDRO_D + print *, "OV routing called and returned..." +#endif + +!DJG Debug...OV Routing... + suminfxsrt=0. + chan_in2=0. + lake_in2=0. + qbdry2=0. + do i=1,IXRT + do j=1,JXRT + suminfxsrt=suminfxsrt+SFCHEADSUBRT(I,J)/float(IXRT*JXRT) + chan_in2=chan_in2+QSTRMVOLRT(I,J)/float(IXRT*JXRT) + lake_in2=lake_in2+LAKE_INFLORT(I,J)/float(IXRT*JXRT) + qbdry2=qbdry2+QBDRYRT(I,J)/float(IXRT*JXRT) + end do + end do +#ifdef MPP_LAND +! not tested + CALL sum_double(suminfxsrt) + CALL sum_double(chan_in2) + CALL sum_double(lake_in2) + CALL sum_double(qbdry2) +#endif + +#ifdef HYDRO_D + print *, "OV Routing Mass Bal: " + print *, "Infil. Excess/Sfc Head: ", suminfxsrt-suminfxs1, & + suminfxsrt,suminfxs1 + print *, "chan_in = ",chan_in2-chan_in1 + print *, "lake_in = ",lake_in2-lake_in1 + print *, "Qbdry = ",qbdry2-qbdry1 + print *, "Residual : ", suminfxs1-suminfxsrt-(chan_in2-chan_in1) & + -(lake_in2-lake_in1)-(qbdry2-qbdry1) +#endif + + + end subroutine OverlandRouting + + + subroutine time_seconds(i3) + integer time_array(8) + real*8 i3 + call date_and_time(values=time_array) + i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + & + time_array(7) + 0.001 * time_array(8) + return + end subroutine time_seconds + diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/module_GW_baseflow.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/module_GW_baseflow.F.svn-base new file mode 100644 index 00000000..7b72ff1e --- /dev/null +++ b/wrfv2_fire/hydro/Routing/.svn/text-base/module_GW_baseflow.F.svn-base @@ -0,0 +1,856 @@ +module module_GW_baseflow + +#ifdef MPP_LAND + use module_mpp_land +#endif + implicit none + +#include "gw_field_include.inc" +#include "rt_include.inc" +!yw #include "namelist.inc" +contains + +!------------------------------------------------------------------------------ +!DJG Simple GW Bucket Model +!------------------------------------------------------------------------------ + + subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,basns_area,& + gwsubbasmsk, runoff1x, runoff2x, z_gwsubbas_tmp, qin_gwsubbas,& + qout_gwsubbas,qinflowbase,gw_strm_msk,gwbas_pix_ct,dist,DT,& + C,ex,z_mx,GWBASESWCRT,OVRTSWCRT) + implicit none + +!!!Declarations... + integer, intent(in) :: ix,jx,ixrt,jxrt + integer, intent(in) :: numbasns + integer, intent(in), dimension(ix,jx) :: gwsubbasmsk + real, intent(in), dimension(ix,jx) :: runoff2x + real, intent(in), dimension(ix,jx) :: runoff1x + real, intent(in) :: basns_area(numbasns),dist(ixrt,jxrt,9),DT + real, intent(in),dimension(numbasns) :: C,ex,z_mx + real, intent(out),dimension(numbasns) :: qout_gwsubbas + real, intent(out),dimension(numbasns) :: qin_gwsubbas + real*8 :: z_gwsubbas(numbasns) + real :: qout_max, qout_spill, z_gw_spill + real, intent(inout),dimension(numbasns) :: z_gwsubbas_tmp + real, intent(out),dimension(ixrt,jxrt) :: qinflowbase + integer, intent(in),dimension(ixrt,jxrt) :: gw_strm_msk + integer, intent(in) :: GWBASESWCRT + integer, intent(in) :: OVRTSWCRT + + + real*8, dimension(numbasns) :: sum_perc8,ct_bas8 + real, dimension(numbasns) :: sum_perc + real, dimension(numbasns) :: net_perc + + real, dimension(numbasns) :: ct_bas + real, dimension(numbasns) :: gwbas_pix_ct + integer :: i,j,bas + character(len=19) :: header + character(len=1) :: jnk + + +!!!Initialize variables... + ct_bas8 = 0 + sum_perc8 = 0. + net_perc = 0. + qout_gwsubbas = 0. + qin_gwsubbas = 0. + z_gwsubbas = z_gwsubbas_tmp + + + +!!!Calculate aggregated percolation from deep runoff into GW basins... + do i=1,ix + do j=1,jx + do bas=1,numbasns + if(gwsubbasmsk(i,j).eq.bas) then + if(OVRTSWCRT.ne.0) then + sum_perc8(bas) = sum_perc8(bas)+runoff2x(i,j) !Add only drainage to bucket...runoff2x in (mm) + else + sum_perc8(bas) = sum_perc8(bas)+runoff1x(i,j)+runoff2x(i,j) !Add sfc water & drainage to bucket...runoff1x and runoff2x in (mm) + end if + ct_bas8(bas) = ct_bas8(bas) + 1 + end if + end do + end do + end do + +#ifdef MPP_LAND + call sum_real8(sum_perc8,numbasns) + call sum_real8(ct_bas8,numbasns) +#endif + sum_perc = sum_perc8 + ct_bas = ct_bas8 + + + + +!!!Loop through GW basins to adjust for inflow/outflow + + DO bas=1,numbasns ! Loop for GW bucket calcs... +! #ifdef MPP_LAND +! if(ct_bas(bas) .gt. 0) then +! #endif + + net_perc(bas) = sum_perc(bas) / ct_bas(bas) !units (mm) +!DJG...old change to cms qin_gwsubbas(bas) = net_perc(bas)/1000. * ct_bas(bas) * basns_area(bas) !units (m^3) + qin_gwsubbas(bas) = net_perc(bas)/1000.* & + ct_bas(bas)*basns_area(bas)/DT !units (m^3/s) + + +!Adjust level of GW depth...(conceptual GW bucket units (mm)) +!DJG...old change to cms inflow... z_gwsubbas(bas) = z_gwsubbas(bas) + net_perc(bas) / 1000.0 ! (m) + +!DJG...debug write (6,*) "DJG...before",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas) + + z_gwsubbas(bas) = z_gwsubbas(bas) + qin_gwsubbas(bas)*DT/( & + ct_bas(bas)*basns_area(bas))*1000. ! units (mm) + + + + + +!Calculate baseflow as a function of GW bucket depth... + + if(GWBASESWCRT.eq.1) then !active exponential bucket... if/then for bucket model discharge type... + +!DJG...Estimation of bucket 'overflow' (qout_spill) if/when bucket gets filled... + qout_spill = 0. + z_gw_spill = 0. + if (z_gwsubbas(bas).gt.z_mx(bas)) then !If/then for bucket overflow case... + z_gw_spill = z_gwsubbas(bas) - z_mx(bas) + z_gwsubbas(bas) = z_mx(bas) + write (6,*) "Bucket spilling...", bas, z_gwsubbas(bas), z_mx(bas), z_gw_spill + else + z_gw_spill = 0. + end if ! End if for bucket overflow case... + + qout_spill = z_gw_spill/1000.*(ct_bas(bas)*basns_area(bas))/DT !amount spilled from bucket overflow...units (cms) + + +!DJG...Maximum estimation of bucket outlfow that is limited by total quantity in bucket... + qout_max = z_gwsubbas(bas)/1000.*(ct_bas(bas)*basns_area(bas))/DT ! Estimate max bucket disharge limit to total volume in bucket...(m^3/s) + + +! Assume exponential relation between z/zmax and Q... +!DJG...old...creates non-asymptotic flow... qout_gwsubbas(bas) = C(bas)*EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas)) !Exp.model. q_out (m^3/s) +!DJG force asymptote to zero to prevent 'overdraft'... +!DJG debug hardwire test... qout_gwsubbas(bas) = 1*(EXP(7.0*10./100.)-1) !Exp.model. q_out (m^3/s) + qout_gwsubbas(bas) = C(bas)*(EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas))-1) !Exp.model. q_out (m^3/s) + +!DJG...Calculation of max bucket outlfow that is limited by total quantity in bucket... + qout_gwsubbas(bas) = MIN(qout_max,qout_gwsubbas(bas)) ! Limit bucket discharge to max. bucket limit + + write (6,*) "DJG-exp bucket...during",C(bas),ex(bas),z_gwsubbas(bas),qin_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max, qout_spill + + + + elseif (GWBASESWCRT.eq.2) then !Pass through/steady-state bucket + +! Assuming a steady-state (inflow=outflow) model... +!DJG convert input and output units to cms... qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3) + qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3/s) + +!DJG...debug write (6,*) "DJG-pass through...during",C(bas),ex(bas),qin_gwsubbas(bas), z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max + + end if ! End if for bucket model discharge type.... + + + + +!Adjust level of GW depth... +!DJG bug adjust output to be mm and correct area bug... z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT & +!DJG bug adjust output to be mm and correct area bug... / (ct_bas(bas)*basns_area(bas)) !units(m) + + z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT/( & + ct_bas(bas)*basns_area(bas))*1000. ! units (mm) + +!DJG...Combine calculated bucket discharge and amount spilled from bucket... + qout_gwsubbas(bas) = qout_gwsubbas(bas) + qout_spill ! units (cms) + + + write (6,*) "DJG...after",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_spill + write (6,*) "DJG...after...calc",bas,ct_bas(bas),ct_bas(bas)*basns_area(bas),basns_area(bas),DT + + + + +! #ifdef MPP_LAND +! endif +! #endif + END DO ! End loop for GW bucket calcs... + + z_gwsubbas_tmp = z_gwsubbas + + +!!!Distribute basin integrated baseflow to stream pixels as stream 'inflow'... + + qinflowbase = 0. + + + do i=1,ixrt + do j=1,jxrt +!!! -simple uniform disaggregation (8.31.06) + if (gw_strm_msk(i,j).gt.0) then + + qinflowbase(i,j) = qout_gwsubbas(gw_strm_msk(i,j))*1000.*DT/ & + gwbas_pix_ct(gw_strm_msk(i,j))/dist(i,j,9) ! units (mm) that gets passed into chan routing as stream inflow + + end if + end do + end do + + +!!! - weighted redistribution...(need to pass accum weights (slope) in...) +! NOT FINISHED just BASIC framework... +! do bas=1,numbasns +! do k=1,gwbas_pix_ct(bas) +! qinflowbase(i,j) = k*slope +! end do +! end do + + z_gwsubbas = z_gwsubbas_tmp + + return + +!------------------------------------------------------------------------------ + End subroutine simp_gw_buck +!------------------------------------------------------------------------------ + + + + +#ifdef MPP_LAND + subroutine pix_ct_1(in_gw_strm_msk,ixrt,jxrt,gwbas_pix_ct,numbasns) + USE module_mpp_land + implicit none + integer :: i,j,ixrt,jxrt,numbasns, bas + integer,dimension(ixrt,jxrt) :: in_gw_strm_msk + integer,dimension(global_rt_nx,global_rt_ny) :: gw_strm_msk + real,dimension(numbasns) :: gwbas_pix_ct + + gw_strm_msk = 0 + call write_IO_rt_int(in_gw_strm_msk, gw_strm_msk) + + if(my_id .eq. IO_id) then + gwbas_pix_ct = 0. + do bas = 1,numbasns + do i=1,global_rt_nx + do j=1,global_rt_ny + if(gw_strm_msk(i,j) .eq. bas) then + gwbas_pix_ct(gw_strm_msk(i,j)) = gwbas_pix_ct(gw_strm_msk(i,j)) & + + 1.0 + endif + end do + end do + end do + end if + call mpp_land_bcast_real(numbasns,gwbas_pix_ct) + + return + end subroutine pix_ct_1 +#endif + + +!------------------------------------------------------------------------------ +! Benjamin Fersch 2d groundwater model +!------------------------------------------------------------------------------ + subroutine gw2d_ini(did,dt,dx) + use module_GW_baseflow_data, only: gw2d + implicit none + integer did + real dt,dx + + gw2d(did)%dx=dx + gw2d(did)%dt=dt + ! bftodo: develop proper landtype mask + + gw2d(did)%compres=0. ! currently not implemented + + return + end subroutine gw2d_ini + + subroutine gw2d_allocate(did, ix, jx, nsoil) + use module_GW_baseflow_data, only: gw2d + implicit none + integer ix, jx, nsoil + integer istatus, did + + if(gw2d(did)%allo_status .eq. 1) return + gw2d(did)%allo_status = 1 + + gw2d(did)%ix = ix + gw2d(did)%jx = jx + + + allocate(gw2d(did)%ltype (ix,jx)) + allocate(gw2d(did)%elev (ix,jx)) + allocate(gw2d(did)%bot (ix,jx)) + allocate(gw2d(did)%hycond (ix,jx)) + allocate(gw2d(did)%poros (ix,jx)) + allocate(gw2d(did)%compres(ix,jx)) + allocate(gw2d(did)%ho (ix,jx)) + allocate(gw2d(did)%h (ix,jx)) + allocate(gw2d(did)%convgw (ix,jx)) +! allocate(gw2d(did)% (ix,jx)) + + end subroutine gw2d_allocate + + + subroutine gwstep(ix, jx, dx, & + ltype, elev, bot, & + hycond, poros, compres, & + ho, h, convgw, & + ebot, eocn, & + dt, istep) +! #else +! dx, istep, dt, & !supplied +! ims,ime,jms,jme,its,ite,jts,jte, & !supplied +! ids,ide,jds,jde,ifs,ife,jfs,jfe) !supplied +! #endif + +! New (volug): calling routines use change in head, convgw = d(h-ho)/dt. + +! Steps ground-water hydrology (head) through one timestep. +! Modified from Prickett and Lonnquist (1971), basic one-layer aquifer +! simulation program, with mods by Zhongbo Yu(1997). +! Solves S.dh/dt = d/dx(T.dh/dx) + d/dy(T.dh/dy) + "external sources" +! for a single layer, where h is head, S is storage coeff and T is +! transmissivity. 3-D arrays in main program (hycond,poros,h,bot) +! are 2-D here, since only a single (uppermost) layer is solved. +! Uses an iterative time-implicit ADI method. + +! use module_hms_constants + + + + integer, intent(in) :: ix, jx + + integer, intent(in), dimension(ix,jx) :: ltype ! land-sfc type (supp) + real, intent(in), dimension(ix,jx) :: & + elev, & ! elev/bathymetry of sfc rel to sl (m) (supp) + bot, & ! elev. aquifer bottom rel to sl (m) (supp) + hycond, & ! hydraulic conductivity (m/s per m/m) (supp) + poros, & ! porosity (m3/m3) (supp) + compres, & ! compressibility (1/Pa) (supp) + ho ! head at start of timestep (m) (supp) + + real, intent(inout), dimension(ix,jx) :: & + h, & ! head, after ghmcompute (m) (ret) + convgw ! convergence due to gw flow (m/s) (ret) + + real, intent(inout) :: ebot, eocn + + + + integer :: istep !, dt + real, intent(in) :: dt, dx + +! #endif +! eocn = mean spurious sink for h_ocn = sealev fix (m/s)(ret) +! This equals the total ground-water flow across +! land->ocean boundaries. +! ebot = mean spurious source for "bot" fix (m/s) (returned) +! time = elapsed time from start of run (sec) +! dt = timestep length (sec) +! istep = timestep counter + +! Local arrays: + + real, dimension(ix,jx) :: sf2 ! storage coefficient (m3 of h2o / bulk m3) + real, dimension(ix,jx,2) :: t ! transmissivity (m2/s)..1 for N-S,..2 for E-W + real, dimension(0:ix+jx) :: b,g ! work arrays + + + real, parameter :: botinc = 0.01 ! re-wetting increment to fix h < bot +! parameter (botinc = 0. ) ! re-wetting increment to fix h < bot + ! (m); else no flow into dry cells + real, parameter :: delskip = 0.005 ! av.|dhead| value for iter.skip out(m) + integer, parameter :: itermax = 10 ! maximum number of iterations + integer, parameter :: itermin = 3 ! minimum number of iterations + real, parameter :: sealev = -1. ! sea-level elevation (m) + + +! die müssen noch sortiert, geprüft und aufgeräumt werden + integer :: & + iter, & + j, & + i, & + jp, & + ip, & + ii, & + n, & + jj, & + ierr, & + ier + +! real :: su, sc, shp, bb, aa, cc, w, zz, tareal, dtoa, dtot + real :: & + dy, & + e, & + su, & + sc, & + shp, & + bb, & + dd, & + aa, & + cc, & + w, & + ha, & + delcur, & + dtot, & + dtoa, & + darea, & + tareal, & + zz + +#ifdef MPP_LAND + real mpiDelcur + integer mpiSize +#endif + + dy = dx + darea = dx*dy + + + call scopy (ix*jx, ho, 1, h, 1) + +! Top of iterative loop for ADI solution + + iter = 0 +!~~~~~~~~~~~~~ + 80 continue +!~~~~~~~~~~~~~ + iter = iter+1 + +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(h, ix, jx, 99) +#endif + + e = 0. ! absolute changes in head (for iteration control) +! eocn = 0. ! accumulated fixes for h = 0 over ocean (diag) +! ebot = 0. ! accumulated fixes for h < bot (diagnostic) + +! Set storage coefficient (sf2) + +! #ifdef HMSWRF +! + tareal = 0. +! +! do j=jfs,jfe +! do i=ifs,ife +! +! +! #else + do j=1,jx + do i=1,ix + if(ltype(i,j) .ge. 1) tareal = tareal + darea + +! #endif +! unconfined water table (h < e): V = poros*(h-b) +! dV/dh = poros +! saturated to surface (h >= e) : V = poros*(e-b) + (h-e) +! dV/dh = 1 +! (compressibility is ignored) +! +! su = poros(i,j)*(1.-theta(i,j)) ! old (pre-volug) + su = poros(i,j) ! new (volug) + sc = 1. + + if (ho(i,j).le.elev(i,j) .and. h(i,j).le.elev(i,j)) then + sf2(i,j) = su + else if (ho(i,j).ge.elev(i,j) .and. h(i,j).ge.elev(i,j)) then + sf2(i,j) = sc + else if (ho(i,j).le.elev(i,j) .and. h(i,j).ge.elev(i,j)) then + shp = sf2(i,j) * (h(i,j) - ho(i,j)) + sf2(i,j) = shp * sc / (shp - (su-sc)*(elev(i,j)-ho(i,j))) + else if (ho(i,j).ge.elev(i,j) .and. h(i,j).le.elev(i,j)) then + shp = sf2(i,j) * (ho(i,j) - h(i,j)) + sf2(i,j) = shp * su / (shp + (su-sc)*(ho(i,j)-elev(i,j))) + endif + + enddo + enddo + +#ifdef MPP_LAND + ! communicate storage coefficient + call MPP_LAND_COM_REAL(sf2, ix, jx, 99) + +#endif + + +!========================== +! Column calculations +!========================== + +! Set transmissivities. Use min(h,elev)-bot instead of h-bot, +! since if h > elev, thickness of groundwater flow is just +! elev-bot. + +! #ifdef HMSWRF +! +! do j=jfs,jfe +! jp = min (j+1,jfe) +! do i=ifs,ife +! ip = min (i+1,ife) +! +! #else + + do j=1,jx + jp = min (j+1,jx) + do i=1,ix + ip = min (i+1,ix) + +! #endif + t(i,j,2) = sqrt( abs( & + hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j)) & + *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j)) & + ) ) & +! #ifdef HMSWRF + * (0.5*(dy+dy)) & ! in WRF the dx and dy are usually equal + / (0.5*(dx+dx)) +! #else +! * (0.5*(dy(i,j)+dy(ip,j))) & +! / (0.5*(dx(i,j)+dx(ip,j))) +! #endif + + t(i,j,1) = sqrt( abs( & + hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j )) & + *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp)) & + ) ) & +! #ifdef HMSWRF + * (0.5*(dx+dx)) & + / (0.5*(dy+dy)) +! #else +! * (0.5*(dx(i,j)+dx(i,jp))) & +! / (0.5*(dy(i,j)+dy(i,jp))) +! #endif + enddo + enddo + +#ifdef MPP_LAND + ! communicate transmissivities in x and y direction + call MPP_LAND_COM_REAL(t(:,:,1), ix, jx, 99) + call MPP_LAND_COM_REAL(t(:,:,2), ix, jx, 99) +#endif + b = 0. + g = 0. + +!------------------- + do 190 ii=1,ix +!------------------- + i=ii + if (mod(istep+iter,2).eq.1) i=ix-i+1 + +! calculate b and g arrays + +!>>>>>>>>>>>>>>>>>>>> + do 170 j=1,jx +!>>>>>>>>>>>>>>>>>>>> +! bb = (sf2(i,j)/dt) * darea(i,j) +! dd = ( ho(i,j)*sf2(i,j)/dt ) * darea(i,j) + bb = (sf2(i,j)/dt) * darea + dd = ( ho(i,j)*sf2(i,j)/dt ) * darea + aa = 0.0 + cc = 0.0 + + if (j-1) 90,100,90 + 90 aa = -t(i,j-1,1) + bb = bb + t(i,j-1,1) + + 100 if (j-jx) 110,120,110 + 110 cc = -t(i,j,1) + bb = bb + t(i,j,1) + + 120 if (i-1) 130,140,130 + 130 bb = bb + t(i-1,j,2) + dd = dd + h(i-1,j)*t(i-1,j,2) + + 140 if (i-ix) 150,160,150 + 150 bb = bb + t(i,j,2) + dd = dd + h(i+1,j)*t(i,j,2) + + 160 w = bb - aa*b(j-1) + b(j) = cc/w + g(j) = (dd-aa*g(j-1))/w +!>>>>>>>>>>>>>>> + 170 continue +!>>>>>>>>>>>>>>> + +! re-estimate heads + + e = e + abs(h(i,jx)-g(jx)) + h(i,jx) = g(jx) + n = jx-1 + 180 if (n.eq.0) goto 185 + ha = g(n) - b(n)*h(i,n+1) + e = e + abs(ha-h(i,n)) + h(i,n) = ha + n = n-1 + goto 180 + 185 continue + +!------------- + 190 continue +!------------- + +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(h, ix, jx, 99) +#endif + + +!======================= +! Row calculations +!======================= + +! set transmissivities (same as above) + + do j=1,jx + jp = min (j+1,jx) + do i=1,ix + ip = min (i+1,ix) + t(i,j,2) = sqrt( abs( & + hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j)) & + *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j)) & + ) ) & +! * (0.5*(dy(i,j)+dy(ip,j))) & +! / (0.5*(dx(i,j)+dx(ip,j))) + * (0.5*(dy+dy)) & + / (0.5*(dx+dx)) + + t(i,j,1) = sqrt( abs( & + hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j )) & + *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp)) & + ) ) & + * (0.5*(dx+dx)) & + / (0.5*(dy+dy)) + enddo + enddo + +#ifdef MPP_LAND + ! communicate transmissivities in x and y direction + call MPP_LAND_COM_REAL(t(:,:,1), ix, jx, 99) + call MPP_LAND_COM_REAL(t(:,:,2), ix, jx, 99) +#endif + b = 0. + g = 0. + +!------------------- + do 300 jj=1,jx +!------------------- + j=jj + if (mod(istep+iter,2).eq.1) j = jx-j+1 + +! calculate b and g arrays + +!>>>>>>>>>>>>>>>>>>>> + do 280 i=1,ix +!>>>>>>>>>>>>>>>>>>>> +! bb = (sf2(i,j)/dt) * darea(i,j) +! dd = ( ho(i,j)*sf2(i,j)/dt ) * darea(i,j) + bb = (sf2(i,j)/dt) * darea + dd = ( ho(i,j)*sf2(i,j)/dt ) * darea + aa = 0.0 + cc = 0.0 + + if (j-1) 200,210,200 + 200 bb = bb + t(i,j-1,1) + dd = dd + h(i,j-1)*t(i,j-1,1) + + 210 if (j-jx) 220,230,220 + 220 dd = dd + h(i,j+1)*t(i,j,1) + bb = bb + t(i,j,1) + + 230 if (i-1) 240,250,240 + 240 bb = bb + t(i-1,j,2) + aa = -t(i-1,j,2) + + 250 if (i-ix) 260,270,260 + 260 bb = bb + t(i,j,2) + cc = -t(i,j,2) + + 270 w = bb - aa*b(i-1) + b(i) = cc/w + g(i) = (dd-aa*g(i-1))/w +!>>>>>>>>>>>>>>> + 280 continue +!>>>>>>>>>>>>>>> + +! re-estimate heads + + e = e + abs(h(ix,j)-g(ix)) + h(ix,j) = g(ix) + n = ix-1 + 290 if (n.eq.0) goto 295 + ha = g(n)-b(n)*h(n+1,j) + e = e + abs(h(n,j)-ha) + h(n,j) = ha + n = n-1 + goto 290 + 295 continue + +!------------- + 300 continue +!------------- + +! fix head < bottom of aquifer +! #endif +! +! #ifdef HMSWRF +! +! do j=jfs,jfe +! do i=ifs,ife +! +! #else + do j=1,jx + do i=1,ix +! #endif + if (ltype(i,j).eq.1 .and. h(i,j).le.bot(i,j)+botinc) then + +! #ifndef HMSWRF + e = e + bot(i,j) + botinc - h(i,j) +! ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea(i,j) + ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea +! #endif + + h(i,j) = bot(i,j) + botinc + endif + enddo + enddo +! maintain head = sea level for ocean (only for adjacent ocean, +! rest has hycond=0) + +! #ifdef HMSWRF +! +! do j=jfs,jfe +! do i=its,ife +! +! #else + do j=1,jx + do i=1,ix +! #endif + if (ltype(i,j).eq.2) then +! #ifndef HMSWRF + eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea +! eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea(i,j) +! #endif + h(i,j) = sealev + endif + enddo + enddo + +! Loop back for next ADI iteration + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! #ifdef HMSWRF +! delcur = e/(xdim*ydim) +! #else + delcur = e/(ix*jx) +! #endif + +#ifdef MPP_LAND + +call mpi_reduce(delcur, mpiDelcur, 1, MPI_REAL, MPI_SUM, 0, MPI_COMM_WORLD, ierr) +call MPI_COMM_SIZE( MPI_COMM_WORLD, mpiSize, ierr ) + +mpiDelcur = mpiDelcur/mpiSize + +call mpi_bcast(delcur, 1, mpi_real, 0, MPI_COMM_WORLD, ierr) + +#endif + + if ( (delcur.gt.delskip*dt/86400. .and. iter.lt.itermax) & + .or. iter.lt.itermin ) then + goto 80 + else + endif + + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +! Compute convergence rate due to ground water flow (returned) + +! #ifdef HMSWRF +! +! do j=jfs,jfe +! do i=ifs,ife +! +! #else + do j=1,jx + do i=1,ix +! #endif + if (ltype(i,j).eq.1) then + convgw(i,j) = sf2(i,j) * (h(i,j)-ho(i,j)) / dt + else + convgw(i,j) = 0. + endif + enddo + enddo + +! Diagnostic water conservation check for this timestep + + dtot = 0. ! total change in water storage (m3) + dtoa = 0. + +! #ifdef HMSWRF +! +! do j=jts,jte +! do i=its,ite +! +! #else + do j=1,jx + do i=1,ix +! #endif + if (ltype(i,j).eq.1) then +! #ifdef HMSWRF + dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea + dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea +! #else +! dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea(i,j) +! dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea(i,j) +! #endif + endif + enddo + enddo + + dtot = (dtot/tareal)/dt ! convert to m/s, rel to land area + dtoa = (dtoa/tareal)/dt + eocn = (eocn/tareal)/dt + ebot = (ebot/tareal)/dt + + zz = 1.e3 * 86400. ! convert printout to mm/day +#ifdef HYDRO_D + write (*,900) & + dtot*zz, dtoa*zz, -eocn*zz, ebot*zz, & + (dtot-(-eocn+ebot))*zz +#endif + 900 format & + (3x,' dh/dt |dh/dt| ocnflx botfix',& + ' ',' ghmerror' & +! /3x,4f9.4,2(9x),e14.4) + /3x,5(e14.4)) + + return + end subroutine gwstep + + + SUBROUTINE SCOPY (NT, ARR, INCA, BRR, INCB) +! +! Copies array ARR to BRR, incrementing by INCA and INCB +! respectively, up to a total length of NT words of ARR. +! (Same as Cray SCOPY.) +! + real, DIMENSION(*) :: ARR, BRR + integer :: ia, nt, inca, incb, ib +! + IB = 1 + DO 10 IA=1,NT,INCA + BRR(IB) = ARR(IA) + IB = IB + INCB + 10 CONTINUE +! + RETURN + END SUBROUTINE SCOPY + +end module module_GW_baseflow diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/module_HYDRO_io.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/module_HYDRO_io.F.svn-base new file mode 100644 index 00000000..54fbdf93 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/.svn/text-base/module_HYDRO_io.F.svn-base @@ -0,0 +1,6340 @@ +module module_HYDRO_io +#ifdef MPP_LAND + use module_mpp_land +#endif + use module_HYDRO_utils, only: get_dist_ll + use module_namelist, only: nlst_rt + use module_RT_data, only: rt_domain + + implicit none +#include + + contains + integer function get2d_real(var_name,out_buff,ix,jx,fileName) + implicit none + integer :: ivar, iret,varid,ncid,ix,jx + real out_buff(ix,jx) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: fileName + get2d_real = -1 + + iret = nf_open(trim(fileName), NF_NOWRITE, ncid) + if (iret .ne. 0) then +#ifdef HYDRO_D + print*,"failed to open the netcdf file: ",trim(fileName) +#endif + out_buff = -9999. + return + endif + ivar = nf_inq_varid(ncid,trim(var_name), varid) + if(ivar .ne. 0) then + ivar = nf_inq_varid(ncid,trim(var_name//"_M"), varid) + if(ivar .ne. 0) then +#ifdef HYDRO_D + write(6,*) "Read Variable Error file: ",trim(fileName) + write(6,*) "Read Error: could not find ",trim(var_name) +#endif + return + endif + end if + iret = nf_get_var_real(ncid, varid, out_buff) + iret = nf_close(ncid) + get2d_real = ivar + end function get2d_real + + subroutine get2d_lsm_real(var_name,out_buff,ix,jx,fileName) + implicit none + integer ix,jx, status + character (len=*),intent(in) :: var_name, fileName + real,dimension(ix,jx):: out_buff +#ifdef MPP_LAND + real,allocatable, dimension(:,:) :: buff_g + +#ifdef HYDRO_D + write(6,*) "start to read variable ", var_name +#endif + allocate(buff_g (global_nx,global_ny) ) + + if(my_id .eq. IO_id) then + status = get2d_real(var_name,buff_g,global_nx,global_ny,fileName) + end if + call decompose_data_real(buff_g,out_buff) + deallocate(buff_g) +#else + status = get2d_real(var_name,out_buff,ix,jx,fileName) +#endif +#ifdef HYDRO_D + write(6,*) "finish reading variable ", var_name +#endif + end subroutine get2d_lsm_real + + subroutine get2d_lsm_vegtyp(out_buff,ix,jx,fileName) + implicit none + integer ix,jx, status,land_cat, iret, dimid,ncid + character (len=*),intent(in) :: fileName + character (len=256) units + integer,dimension(ix,jx):: out_buff + real, dimension(ix,jx) :: xdum +#ifdef MPP_LAND + real,allocatable, dimension(:,:) :: buff_g + + allocate(buff_g (global_nx,global_ny) ) + + if(my_id .eq. IO_id) then +#endif + ! Open the NetCDF file. + iret = nf_open(fileName, NF_NOWRITE, ncid) + if (iret /= 0) then +#ifdef HYDRO_D + write(*,'("Problem opening geo_static file: ''", A, "''")') & + trim(fileName) + call hydro_stop("get2d_lsm_vegtyp") +#endif + endif + + iret = nf_inq_dimid(ncid, "land_cat", dimid) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimid: land_cat" + call hydro_stop("get2d_lsm_vegtyp") +#endif + endif + + iret = nf_inq_dimlen(ncid, dimid, land_cat) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimlen: land_cat" + call hydro_stop("get2d_lsm_vegtyp") +#endif + endif + +#ifdef MPP_LAND + call get_landuse_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat) + iret = nf_close(ncid) + end if + + call decompose_data_real(buff_g,xdum) + deallocate(buff_g) +#else + call get_landuse_netcdf(ncid, xdum, units, ix, jx, land_cat) + iret = nf_close(ncid) +#endif + out_buff = nint(xdum) + end subroutine get2d_lsm_vegtyp + + subroutine get_file_dimension(fileName, ix,jx) + implicit none + character(len=*) fileName + integer ncid , iret, ix,jx, dimid +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + iret = nf_open(fileName, NF_NOWRITE, ncid) + if (iret /= 0) then +#ifdef HYDRO_D + write(*,'("Problem opening geo_static file: ''", A, "''")') & + trim(fileName) + call hydro_stop("get_file_dimension") +#endif + endif + + iret = nf_inq_dimid(ncid, "west_east", dimid) + + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimid: west_east" + call hydro_stop("get_file_dimension") +#endif + endif + + iret = nf_inq_dimlen(ncid, dimid, ix) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimlen: west_east" + call hydro_stop("get_file_dimension") +#endif + endif + + iret = nf_inq_dimid(ncid, "south_north", dimid) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimid: south_north" + call hydro_stop("get_file_dimension") +#endif + endif + + iret = nf_inq_dimlen(ncid, dimid, jx) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimlen: south_north" + call hydro_stop("get_file_dimension") +#endif + endif + iret = nf_close(ncid) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(ix) + call mpp_land_bcast_int1(jx) +#endif + + end subroutine get_file_dimension + + subroutine get2d_lsm_soltyp(out_buff,ix,jx,fileName) + implicit none + integer ix,jx, status,land_cat, iret, dimid,ncid + character (len=*),intent(in) :: fileName + character (len=256) units + integer,dimension(ix,jx):: out_buff + real, dimension(ix,jx) :: xdum +#ifdef MPP_LAND + real,allocatable, dimension(:,:) :: buff_g + + allocate(buff_g (global_nx,global_ny) ) + + if(my_id .eq. IO_id) then +#endif + ! Open the NetCDF file. + iret = nf_open(fileName, NF_NOWRITE, ncid) + if (iret /= 0) then +#ifdef HYDRO_D + write(*,'("Problem opening geo_static file: ''", A, "''")') & + trim(fileName) + call hydro_stop("get2d_lsm_soltyp") +#endif + endif + + iret = nf_inq_dimid(ncid, "soil_cat", dimid) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimid: soil_cat" + call hydro_stop("get2d_lsm_soltyp") +#endif + endif + + iret = nf_inq_dimlen(ncid, dimid, land_cat) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimlen: soil_cat" + call hydro_stop("get2d_lsm_soltyp") +#endif + endif + +#ifdef MPP_LAND + call get_soilcat_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat) + iret = nf_close(ncid) + end if + + call decompose_data_real(buff_g,xdum) + deallocate(buff_g) +#else + call get_soilcat_netcdf(ncid, xdum, units, ix, jx, land_cat) + iret = nf_close(ncid) +#endif + out_buff = nint(xdum) + end subroutine get2d_lsm_soltyp + + + + + + + subroutine get_landuse_netcdf(ncid, array, units, idim, jdim, ldim) + implicit none +#include + integer, intent(in) :: ncid + integer, intent(in) :: idim, jdim, ldim + real, dimension(idim,jdim), intent(out) :: array + character(len=256), intent(out) :: units + integer :: iret, varid + real, dimension(idim,jdim,ldim) :: xtmp + integer, dimension(1) :: mp + integer :: i, j, l + character(len=24), parameter :: name = "LANDUSEF" + + units = "" + + iret = nf_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'name = "', trim(name)//'"' + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_landuse_netcdf: nf_inq_varid" + call hydro_stop("get_landuse_netcdf") +#endif + endif + + iret = nf_get_var_real(ncid, varid, xtmp) + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'name = "', trim(name)//'"' + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_landuse_netcdf: nf_get_var_real" + call hydro_stop("get_landuse_netcdf") +#endif + endif + + do i = 1, idim + do j = 1, jdim + mp = maxloc(xtmp(i,j,:)) + array(i,j) = mp(1) + do l = 1,ldim + if(xtmp(i,j,l).lt.0) array(i,j) = -9999.0 + enddo + enddo + enddo + + end subroutine get_landuse_netcdf + + + subroutine get_soilcat_netcdf(ncid, array, units, idim, jdim, ldim) + implicit none +#include + + integer, intent(in) :: ncid + integer, intent(in) :: idim, jdim, ldim + real, dimension(idim,jdim), intent(out) :: array + character(len=256), intent(out) :: units + integer :: iret, varid + real, dimension(idim,jdim,ldim) :: xtmp + integer, dimension(1) :: mp + integer :: i, j + character(len=24), parameter :: name = "SOILCTOP" + + units = "" + + iret = nf_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'name = "', trim(name)//'"' + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_soilcat_netcdf: nf_inq_varid" + call hydro_stop("get_soilcat_netcdf") +#endif + endif + + iret = nf_get_var_real(ncid, varid, xtmp) + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'name = "', trim(name)//'"' + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_soilcat_netcdf: nf_get_var_real" + call hydro_stop("get_soilcat_netcdf") +#endif + endif + + do i = 1, idim + do j = 1, jdim + mp = maxloc(xtmp(i,j,:)) + array(i,j) = mp(1) + enddo + enddo + + where (array == 14) array = 1 ! DJG remove all 'water' soils... + + end subroutine get_soilcat_netcdf + + +subroutine get_greenfrac_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) + implicit none +#include + integer, intent(in) :: ncid,mm,dd + integer, intent(in) :: idim, jdim, ldim + real, dimension(idim,jdim) :: array + real, dimension(idim,jdim) :: array2 + real, dimension(idim,jdim) :: diff + real, dimension(idim,jdim), intent(out) :: array3 + character(len=256), intent(out) :: units + integer :: iret, varid + real, dimension(idim,jdim,ldim) :: xtmp + integer, dimension(1) :: mp + integer :: i, j, mm2,daytot + real :: ddfrac + character(len=24), parameter :: name = "GREENFRAC" + + units = "fraction" + + iret = nf_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'name = "', trim(name)//'"' + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_greenfrac_netcdf: nf_inq_varid" + call hydro_stop("get_greenfrac_netcdf") +#endif + endif + + iret = nf_get_var_real(ncid, varid, xtmp) + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'name = "', trim(name)//'"' + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_greenfrac_netcdf: nf_get_var_real" + call hydro_stop("get_greenfrac_netcdf") +#endif + endif + + + if (mm.lt.12) then + mm2 = mm+1 + else + mm2 = 1 + end if + +!DJG_DES Set up dates for daily interpolation... + if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then + daytot = 31 + else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then + daytot = 30 + else if (mm.eq.2) then + daytot = 28 + end if + ddfrac = float(dd)/float(daytot) + if (ddfrac.gt.1.0) ddfrac = 1.0 ! Assumes Feb. 29th change is same as Feb 28th + +#ifdef HYDRO_D + print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac +#endif + + do i = 1, idim + do j = 1, jdim + array(i,j) = xtmp(i,j,mm) !GREENFRAC in geogrid in units of fraction from month 1 + array2(i,j) = xtmp(i,j,mm2) !GREENFRAC in geogrid in units of fraction from month 1 + diff(i,j) = array2(i,j) - array(i,j) + array3(i,j) = array(i,j) + ddfrac * diff(i,j) + enddo + enddo + +end subroutine get_greenfrac_netcdf + + + +subroutine get_albedo12m_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) + implicit none +#include + integer, intent(in) :: ncid,mm,dd + integer, intent(in) :: idim, jdim, ldim + real, dimension(idim,jdim) :: array + real, dimension(idim,jdim) :: array2 + real, dimension(idim,jdim) :: diff + real, dimension(idim,jdim), intent(out) :: array3 + character(len=256), intent(out) :: units + integer :: iret, varid + real, dimension(idim,jdim,ldim) :: xtmp + integer, dimension(1) :: mp + integer :: i, j, mm2,daytot + real :: ddfrac + character(len=24), parameter :: name = "ALBEDO12M" + + + units = "fraction" + + iret = nf_inq_varid(ncid, trim(name), varid) + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'name = "', trim(name)//'"' + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_albedo12m_netcdf: nf_inq_varid" + call hydro_stop("get_albedo12m_netcdf") +#endif + endif + + iret = nf_get_var_real(ncid, varid, xtmp) + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'name = "', trim(name)//'"' + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_albedo12m_netcdf: nf_get_var_real" + call hydro_stop("get_albedo12m_netcdf") +#endif + endif + + if (mm.lt.12) then + mm2 = mm+1 + else + mm2 = 1 + end if + +!DJG_DES Set up dates for daily interpolation... + if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then + daytot = 31 + else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then + daytot = 30 + else if (mm.eq.2) then + daytot = 28 + end if + ddfrac = float(dd)/float(daytot) + if (ddfrac.gt.1.0) ddfrac = 1.0 ! Assumes Feb. 29th change is same as Feb 28th + +#ifdef HYDRO_D + print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac +#endif + + do i = 1, idim + do j = 1, jdim + array(i,j) = xtmp(i,j,mm) / 100.0 !Convert ALBEDO12M from % to fraction...month 1 + array2(i,j) = xtmp(i,j,mm2) / 100.0 !Convert ALBEDO12M from % to fraction... month 2 + diff(i,j) = array2(i,j) - array(i,j) + array3(i,j) = array(i,j) + ddfrac * diff(i,j) + enddo + enddo + +end subroutine get_albedo12m_netcdf + + + + subroutine get_2d_netcdf(name, ncid, array, units, idim, jdim, & + fatal_if_error, ierr) + implicit none +#include + character(len=*), intent(in) :: name + integer, intent(in) :: ncid + integer, intent(in) :: idim, jdim + real, dimension(idim,jdim), intent(out) :: array + character(len=256), intent(out) :: units + integer :: iret, varid + ! .TRUE._IF_ERROR: an input code value: + ! .TRUE. if an error in reading the data should stop the program. + ! Otherwise the, IERR error flag is set, but the program continues. + logical, intent(in) :: fatal_if_error + integer, intent(out) :: ierr + + units = "" + + iret = nf_inq_varid(ncid, name, varid) + + if (iret /= 0) then + if (fatal_IF_ERROR) then +#ifdef HYDRO_D + print*, 'name = "', trim(name)//'"' + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf: nf_inq_varid" + call hydro_stop("get_2d_netcdf") +#endif + else + ierr = iret + return + endif + endif + + + iret = nf_get_var_real(ncid, varid, array) + if (iret /= 0) then + if (fatal_IF_ERROR) then +#ifdef HYDRO_D + print*, 'name = "', trim(name)//'"' + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf: nf_get_var_real" + call hydro_stop("get_2d_netcdf") +#endif + else + ierr = iret + return + endif + endif + + ierr = 0; + end subroutine get_2d_netcdf + + subroutine get_2d_netcdf_cows(var_name,ncid,var, & + ix,jx,tlevel,fatal_if_error,ierr) +#include + character(len=*), intent(in) :: var_name + integer,intent(in) :: ncid,ix,jx,tlevel + real, intent(out):: var(ix,jx) + logical, intent(in) :: fatal_if_error + integer ierr, iret + integer varid + integer start(4),count(4) + data count /1,1,1,1/ + data start /1,1,1,1/ + count(1) = ix + count(2) = jx + start(4) = tlevel + iret = nf_inq_varid(ncid, var_name, varid) + + if (iret /= 0) then + if (fatal_IF_ERROR) then +#ifdef HYDRO_D + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid" + call hydro_stop("get_2d_netcdf_cows") +#endif + else + ierr = iret + return + endif + endif + iret = nf_get_vara_real(ncid, varid, start,count,var) + + return + end subroutine get_2d_netcdf_cows + +!--------------------------------------------------------- +!DJG Subroutinesfor inputting routing fields... +!DNY first reads the files to get the size of the +!DNY LINKS arrays +!DJG - Currently only hi-res topo is read +!DJG - At a future time, use this routine to input +!DJG subgrid land-use classification or routing +!DJG parameters 'overland roughness' and 'retention +!DJG depth' +! +!DJG,DNY - Update this subroutine to read in channel and lake +! parameters if activated 11.20.2005 +!--------------------------------------------------------- + + SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, & + route_direction_f, route_lake_f, NLINKS, NLAKES, & + CH_NETLNK, channel_option, geo_finegrid_flnm) + + implicit none +#include + INTEGER :: I,J,channel_option,iret,jj + INTEGER, INTENT(INOUT) :: NLINKS, NLAKES + INTEGER, INTENT(IN) :: IXRT,JXRT + INTEGER :: CHNID,cnt + INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id + INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction + INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + REAL, DIMENSION(IXRT,JXRT) :: LAT, LON + +!!Dummy read in grids for inverted y-axis + + + CHARACTER(len=*) :: route_chan_f, route_link_f,route_direction_f,route_lake_f + CHARACTER(len=256) :: InputLine + CHARACTER(len=256) :: geo_finegrid_flnm + CHARACTER(len=256) :: var_name +! external get2d_real +! integer :: get2d_real + + NLINKS = 0 + NLAKES = 0 + CH_NETRT = -9999 + CH_NETLNK = -9999 + + + cnt = 0 +#ifdef HYDRO_D + print *, "Channel Option in Routedim is ", channel_option +#endif + + IF(channel_option.eq.3) then !get maxnodes and links from grid + + var_name = "CHANNELGRID" + call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + + var_name = "FLOWDIRECTION" + call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + + var_name = "LAKEGRID" + call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + + + var_name = "LATITUDE" + call readRT2d_real(var_name,LAT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + var_name = "LONGITUDE" + call readRT2d_real(var_name,LON,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + +! temp fix for buggy Arc export... + do j=1,jxrt + do i=1,ixrt + if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 + end do + end do + +!DJG inv do j=jxrt,1,-1 + do j=1,jxrt + do i = 1, ixrt + if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then + NLINKS = NLINKS + 1 + endif + end do + end do +#ifdef HYDRO_D + print *, "NLINKS IS ", NLINKS +#endif + + +!DJG inv DO j = JXRT,1,-1 !rows + DO j = 1,JXRT !rows + DO i = 1 ,IXRT !colsumns + If (CH_NETRT(i, j) .ge. 0) then !get its direction + If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT).AND.(CH_NETRT(i,j+1) .ge.0) ) then !North + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1) .ge.0)) then !North East + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT).AND.(CH_NETRT(i+1,j) .ge. 0)) then !East + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & + .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i+1,j-1).ge.0)) then !south east + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0)) then !due south + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & + .AND. (j - 1 .NE. 0).AND. (CH_NETRT(i-1,j-1).ge.0) ) then !south west + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0)) then !West + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0)) then !North West + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else +#ifdef HYDRO_D + write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j +135 FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4) +#endif + if (DIRECTION(i,j) .eq. 0) then +#ifdef HYDRO_D + print *, "Direction i,j ",i,j," of point ", cnt, "is invalid" +#endif + endif + + End If + End If !CH_NETRT check for this node + END DO + END DO +#ifdef HYDRO_D + print *, "found type 0 nodes", cnt +#endif + +!Find out if the boundaries are on an edge or flow into a lake +!DJG inv DO j = JXRT,1,-1 + DO j = 1,JXRT + DO i = 1 ,IXRT + If (CH_NETRT(i, j) .ge. 0) then !get its direction + + If ( ((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) & !-- 64's can only flow north + .OR. ((DIRECTION(i, j) .EQ. 64).and. (j1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) & !-- 4's can only flow due south + .OR. ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west + .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge + .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE. 0)) & !-- 16's can only flow due west + .OR. ((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north + .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge + .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j + INTEGER, INTENT(IN) :: IXRT,JXRT + INTEGER :: CHANRTSWCRT, NLINKS, NLAKES + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT + INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION + INTEGER, DIMENSION(IXRT,JXRT) :: GSTRMFRXSTPTS + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + INTEGER, DIMENSION(IXRT,JXRT) :: GORDER !-- gridded stream orderk + INTEGER, DIMENSION(IXRT,JXRT) :: Link_Location !-- gridded stream orderk + INTEGER :: I,J,channel_option + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LATVAL, LONVAL + CHARACTER(len=28) :: dir +!Dummy inverted grids from arc + + +!----DJG,DNY New variables for channel and lake routing + CHARACTER(len=155) :: header + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: FROM_NODE + REAL, INTENT(OUT), DIMENSION(NLINKS) :: ZELEV + REAL, INTENT(OUT), DIMENSION(NLINKS) :: CHLAT,CHLON + + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: TYPEL + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: TO_NODE,ORDER + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: STRMFRXSTPTS + + INTEGER, INTENT(OUT) :: MAXORDER + REAL, INTENT(OUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum + REAL, INTENT(OUT), DIMENSION(NLINKS,2) :: QLINK !channel flow + REAL, INTENT(OUT), DIMENSION(NLINKS) :: CHANLEN !channel length + REAL, INTENT(OUT), DIMENSION(NLINKS) :: MannN, So !mannings N + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: LAKENODE ! identifies which nodes pour into which lakes + REAL, INTENT(IN) :: dist(ixrt,jxrt,9) + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK + REAL, DIMENSION(IXRT,JXRT) :: ChSSlpG,BwG,MannNG !channel properties on Grid + + +!-- store the location x,y location of the channel element + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ + +!--reservoir/lake attributes + REAL, INTENT(OUT), DIMENSION(NLAKES) :: HRZAREA + REAL, INTENT(OUT), DIMENSION(NLAKES) :: LAKEMAXH + REAL, INTENT(OUT), DIMENSION(NLAKES) :: WEIRC + REAL, INTENT(OUT), DIMENSION(NLAKES) :: WEIRL + REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEC + REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEA + REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEE + REAL, INTENT(OUT), DIMENSION(NLAKES) :: LATLAKE,LONLAKE,ELEVLAKE + REAL, INTENT(OUT), DIMENSION(NLINKS) :: ChSSlp, Bw + + CHARACTER(len=256) :: route_link_f + CHARACTER(len=256) :: route_lake_f + CHARACTER(len=256) :: route_direction_f + CHARACTER(len=256) :: route_order_f + CHARACTER(len=256) :: geo_finegrid_flnm + CHARACTER(len=256) :: var_name + + INTEGER :: tmp, cnt, ncid, iret, jj,ct + real :: gc,n + +!--------------------------------------------------------- +! End Declarations +!--------------------------------------------------------- + MAXORDER = -9999 +!initialize GSTRM + GSTRMFRXSTPTS = -9999 + +!yw initialize the array. + to_node = MAXORDER + from_node = MAXORDER + +#ifdef HYDRO_D + print *, "reading routing initialization files..." + print *, "route direction", route_direction_f + print *, "route order", route_order_f + print *, "route linke",route_link_f + print *, "route lake",route_lake_f + + BwG = 0.0 + ChSSlpG = 0.0 + MannNG = 0.0 + TYPEL = 0 + MannN = 0.0 + Bw = 0.0 + ChSSlp = 0.0 + +#endif + +!DJG Edited code here to retrieve data from hires netcdf file.... + + IF((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then + + var_name = "LATITUDE" + call readRT2d_real(var_name,LATVAL,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + var_name = "LONGITUDE" + call readRT2d_real(var_name,LONVAL,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + + END IF + + + IF(CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2) then +!DJG change filename to LAKEPARM.TBL open(unit=79,file=trim(route_link_f), & + open(unit=79,file='LAKEPARM.TBL', & + form='formatted',status='old') + END IF + + + var_name = "LAKEGRID" + call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + var_name = "FLOWDIRECTION" + call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + var_name = "STREAMORDER" + call readRT2d_int(var_name,GORDER,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + var_name = "frxst_pts" + call readRT2d_int(var_name,GSTRMFRXSTPTS,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + +!--1/13/2011 real hi res sfc calibrtion parameters (...) +! var_name = "LAKEGRID" +! call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& +! trim(geo_finegrid_flnm)) +! var_name = "LAKEGRID" +! call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& +! trim(geo_finegrid_flnm)) + + +!-- real hi res channel properties (not yet implemented...) +! var_name = "MANNINGS" +! iret = get2d_real(var_name,MannNG,ixrt,jxrt,& +! trim(geo_finegrid_flnm)) +! var_name = "SIDE_SLOPE" +! iret = get2d_real(var_name,ChSSlpG,ixrt,jxrt,& +! trim(geo_finegrid_flnm)) +! var_name = "BOTTOM_WIDTH" +! iret = get2d_real(var_name,BwG,ixrt,jxrt,& +! trim(geo_finegrid_flnm)) + + +!!!Flip y-dimension of highres grids from exported Arc files... + + + + + +! temp fix for buggy Arc export... + do j=1,jxrt + do i=1,ixrt + if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 + end do + end do + + cnt =0 + if ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option .ne. 3) then ! not routing on grid, read from file + read(79,*) header + do i=1,NLINKS + read (79,*) tmp, FROM_NODE(i), TO_NODE(i), TYPEL(i),& + ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), & + MannN(i), So(i), ChSSlp(i), Bw(i), HRZAREA(i),& + LAKEMAXH(i), WEIRC(i), WEIRL(i), ORIFICEC(i), & + ORIFICEA(i),ORIFICEE(i) + + !-- hardwire QLINK + QLINK(i,1) = 1.0 + QLINK(i,2) = QLINK(i,1) + + if (So(i).lt.0.005) So(i) = 0.005 !-- impose a minimum slope requireement + + if (ORDER(i) .gt. MAXORDER) then + MAXORDER = ORDER(i) + endif + + end do + + elseif ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then !-- handle setting up topology on the grid for diffusion scheme + + read(79,*) header !-- read the lake file +#ifdef HYDRO_D + write(*,*) "reading lake file ", header + write(6,*) "error check read file ",route_link_f +#endif + + + if (NLAKES.gt.0) then !read in only if there are lakes + do i=1, NLAKES + read (79,*) tmp, HRZAREA(i),LAKEMAXH(i), & + WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),& + LATLAKE(i), LONLAKE(i),ELEVLAKE(i) +#ifdef HYDRO_D + write (*,*) tmp, HRZAREA(i),LAKEMAXH(i), LATLAKE(i), LONLAKE(i),ELEVLAKE(i),NLAKES +#endif + enddo + end if !end if for NLAKES >0 check + + cnt = 0 + +!yw add temperary to initialize the following two variables. + +!yw debug +! write(6,*) "ixrt =",ixrt, "jxrt=",jxrt +! write(18) CH_NETRT +! write(19) DIRECTION +! write(20) GORDER +! write(21) GSTRMFRXSTPTS +! write(22) ELRT +!ywend debug + + BwG = 0.0 + ChSSlpG = 0.0 + +!DJG inv DO j = JXRT,1,-1 !rows + DO j = 1,JXRT !rows + DO i = 1 ,IXRT !colsumns + If (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order + If ((DIRECTION(i, j) .EQ. 64) .AND. (j + 1 .LE. JXRT) .AND. & + (CH_NETRT(i,j+1).ge.0) ) then !North + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i, j + 1) + CHANLEN(cnt) = dist(i,j,1) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1).ge.0) ) then !North East + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1) + CHANLEN(cnt) = dist(i,j,2) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT) & + .AND. (CH_NETRT(i+1,j).ge.0) ) then !East + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j) + CHANLEN(cnt) = dist(i,j,3) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & + .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i+1,j-1).ge.0) ) then !south east + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1) + CHANLEN(cnt) = dist(i,j,4) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0) ) then !due south + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i, j - 1) + CHANLEN(cnt) = dist(i,j,5) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & + .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i-1,j-1).ge.0)) then !south west + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i,j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1) + CHANLEN(cnt) = dist(i,j,6) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0) ) then !West + cnt = cnt + 1 + FROM_NODE(cnt) = CH_NETLNK(i, j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j) + CHANLEN(cnt) = dist(i,j,7) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0) ) then !North West + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1) + CHANLEN(cnt) = dist(i,j,8) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else +#ifdef HYDRO_D + print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east +#endif + End If + + End If !CH_NETRT check for this node + + END DO + END DO + +#ifdef HYDRO_D + print *, "after exiting the channel, this many nodes", cnt + write(*,*) " " +#endif + +!Find out if the boundaries are on an edge +!DJG inv DO j = JXRT,1,-1 + DO j = 1,JXRT + DO i = 1 ,IXRT + If (CH_NETRT(i, j) .ge. 0) then !get its direction + If (((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) .OR. & !-- 64's can only flow north + ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(j+1 .GT. JXRT) then !-- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i,j+1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i,j+1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,1) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + else if ( ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .GT. IXRT)) & !-- 128's can flow out of the North or East edge + .OR. ((DIRECTION(i, j) .EQ. 128) .AND. (j + 1 .GT. JXRT)) & ! this is due north edge + .OR. ((DIRECTION(i, j) .EQ. 128) .AND. (i1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if((i+1 .GT. IXRT) .OR. (j-1 .EQ. 0)) then !an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i+1,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,4) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + else if (((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) .OR. & !-- 4's can only flow due south + ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(j-1 .EQ. 0) then !- an edge + TYPEL(cnt) =1 + elseif(LAKE_MSKRT(i,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,5) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west + .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge + .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if( (i-1 .EQ. 0) .OR. (j-1 .EQ. 0) ) then !- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i-1,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,6) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + else if (((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE.0) ) & !16's can only flow due west + .OR.((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West + cnt = cnt + 1 + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(i-1 .EQ. 0) then !-- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i-1,j).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i-1,j) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,7) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north + .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge + .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j + + integer, intent(in) :: IX,JX,IXRT,JXRT,AGGFACTRT + integer, intent(in), dimension(IXRT,JXRT) :: ch_netrt + integer, intent(out) :: numbasns + integer, intent(out), dimension(IX,JX) :: GWSUBBASMSK + integer, intent(out), dimension(IXRT,JXRT) :: gw_strm_msk + character(len=256) :: gwbasmskfil + integer :: i,j,aggfacxrt,aggfacyrt,ixxrt,jyyrt + + numbasns = 0 + gw_strm_msk = -9999 + +!Open files... + open(unit=91,file=trim(gwbasmskfil), & + form='formatted',status='old') + +!Read in sub-basin mask... + do j=jx,1,-1 + read (91,*) (GWSUBBASMSK(i,j),i=1,ix) + end do + close(91) + + +!Loop through to count number of basins and assign basin indices to chan grid + do J=1,JX + do I=1,IX + +!Determine max number of basins...(assumes basins are numbered +! sequentially from 1 to max number of basins...) + if (GWSUBBASMSK(i,j).gt.numbasns) then + numbasns = GWSUBBASMSK(i,j) ! get count of basins... + end if + +!Assign gw basin index values to channel grid... + do AGGFACYRT=AGGFACTRT-1,0,-1 + do AGGFACXRT=AGGFACTRT-1,0,-1 + + IXXRT=I*AGGFACTRT-AGGFACXRT + JYYRT=J*AGGFACTRT-AGGFACYRT + IF(ch_netrt(IXXRT,JYYRT).ge.0) then !If channel grid cell + gw_strm_msk(IXXRT,JYYRT) = GWSUBBASMSK(i,j) ! assign coarse grid basn indx to chan grid + END IF + + end do !AGGFACXRT + end do !AGGFACYRT + + end do !I-ix + end do !J-jx + +#ifdef HYDRO_D + write(6,*) "numbasns = ", numbasns +#endif + + return + +!DJG ----------------------------------------------------- + END SUBROUTINE READ_SIMP_GW +!DJG ----------------------------------------------------- + + ! BF read the static input fields needed for the 2D GW scheme + subroutine readGW2d(ix, jx, hc, ihead, botelv, por, ltype) + implicit none +#include + integer, intent(in) :: ix, jx + integer, dimension(ix,jx), intent(inout):: ltype + real, dimension(ix,jx), intent(inout) :: hc, ihead, botelv, por + +#ifdef MPP_LAND + integer, dimension(:,:), allocatable :: gLtype + real, dimension(:,:), allocatable :: gHC, gIHEAD, gBOTELV, gPOR +#endif + integer :: i +!, get2d_real + +#ifdef MPP_LAND + allocate(gHC(global_rt_nx, global_rt_ny)) + allocate(gIHEAD(global_rt_nx, global_rt_ny)) + allocate(gBOTELV(global_rt_nx, global_rt_ny)) + allocate(gPOR(global_rt_nx, global_rt_ny)) + allocate(gLtype(global_rt_nx, global_rt_ny)) + + if(my_id .eq. IO_id) then +#ifdef HYDRO_D + print*, "2D GW-Scheme selected, retrieving files from gwhires.nc ..." +#endif +#endif + + + ! hydraulic conductivity + i = get2d_real("HC", & +#ifdef MPP_LAND + gHC, global_nx, global_ny, & +#else + hc, ix, jx, & +#endif + trim("./gwhires.nc")) + + ! initial head + i = get2d_real("IHEAD", & +#ifdef MPP_LAND + gIHEAD, global_nx, global_ny, & +#else + ihead, ix, jx, & +#endif + trim("./gwhires.nc")) + + ! aquifer bottom elevation + i = get2d_real("BOTELV", & +#ifdef MPP_LAND + gBOTELV, global_nx, global_ny, & +#else + botelv, ix, jx, & +#endif + trim("./gwhires.nc")) + + ! aquifer porosity + i = get2d_real("POR", & +#ifdef MPP_LAND + gPOR, global_nx, global_ny, & +#else + por, ix, jx, & +#endif + trim("./gwhires.nc")) + +! bftodo: develop proper landtype mask + +#ifdef MPP_LAND + gLtype=1 + gLtype(1,:) = 2 + gLtype(:,1) = 2 + gLtype(global_rt_nx,:) = 2 + gLtype(:,global_rt_ny) = 2 +#else + ltype=1 + ltype(1,:) =2 + ltype(:,1) =2 + ltype(ix,:)=2 + ltype(:,jx)=2 +#endif + +#ifdef MPP_LAND + endif + call decompose_rt_int (gLtype, ltype, global_rt_nx, global_rt_ny, ix, jx) + call decompose_rt_real(gHC,hc,global_rt_nx, global_rt_ny, ix, jx) + call decompose_rt_real(gIHEAD,ihead,global_rt_nx, global_rt_ny, ix, jx) + call decompose_rt_real(gBOTELV,botelv,global_rt_nx, global_rt_ny, ix, jx) + call decompose_rt_real(gPOR,por,global_rt_nx, global_rt_ny, ix, jx) + deallocate(gHC, gIHEAD, gBOTELV, gPOR) +#endif + !bftodo: make filename accessible in namelist + return + end subroutine readGW2d + !BF + + + + + subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & + startdate, date, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID, & + q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, & + geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,HIRES_OUT, & + QBDRYRT) + +!output the routing variables over routing grid. + implicit none +#include + + integer, intent(in) :: igrid + integer, intent(in) :: split_output_count + integer, intent(in) :: ixrt,jxrt + real, intent(in) :: dt + real, intent(in) :: dist(ixrt,jxrt,9) + integer, intent(in) :: nsoil + integer, intent(in) :: HIRES_OUT + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + character(len=*), intent(in) :: geo_finegrid_flnm + real, dimension(nsoil), intent(in) :: sldpth + real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable + real*8, allocatable, DIMENSION(:) :: xcoord_d, xcoord + real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord + + integer, save :: ncid,ncstatic + integer, save :: output_count + real, dimension(nsoil) :: asldpth + + integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n + integer :: iret, dimid_soil, i,j,ii,jj + character(len=256) :: output_flnm + character(len=19) :: date19 + character(len=32) :: convention + character(len=34) :: sec_since_date + + character(len=30) :: soilm + + real :: long_cm,lat_po,fe,fn, chan_in + real, dimension(2) :: sp + + real, dimension(ixrt,jxrt) :: xdum,QSUBRT,ZWATTABLRT,SUB_RESID + real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y + real, dimension(ixrt,jxrt) :: QSTRMVOLRT + real, dimension(ixrt,jxrt) :: SFCHEADSUBRT + real, dimension(ixrt,jxrt) :: soxrt,soyrt + real, dimension(ixrt,jxrt) :: LATVAL,LONVAL, QBDRYRT + real, dimension(ixrt,jxrt,nsoil) :: SMCRT + + integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag + sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' + seconds_since = int(dt)*output_count + + decimation = 1 !-- decimation factor + ixrtd = int(ixrt/decimation) + jxrtd = int(jxrt/decimation) + allocate(xdumd(ixrtd,jxrtd)) + allocate(xcoord_d(ixrtd)) + allocate(ycoord_d(jxrtd)) + allocate(xcoord(ixrtd)) + allocate(ycoord(jxrtd)) + ii = 0 + jj = 0 + +!DJG Dump timeseries for channel inflow accum. for calibration...(8/28/09) + chan_in = 0.0 + do j=1,jxrt + do i=1,ixrt + chan_in=chan_in+QSTRMVOLRT(I,J)/1000.0*(dist(i,j,9)) !(units m^3) + enddo + enddo + open (unit=46,file='qstrmvolrt_accum.txt',form='formatted',& + status='unknown',position='append') + write (46,713) chan_in +713 FORMAT (F20.7) + close (46) +! return +!DJG end dump of channel inflow for calibration.... + + if (hires_out.eq.1) return ! return if hires flag eq 1, if =2 output full grid + + if (output_count == 0) then + + !-- Open the finemesh static files to obtain projection information +#ifdef HYDRO_D + write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) +#endif + iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic) + + if (iret /= 0) then +#ifdef HYDRO_D + write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & + trim(geo_finegrid_flnm) + write(*,*) "HIRES_OUTPUT will not be georeferenced..." +#endif + + hires_flag = 0 + else + hires_flag = 1 + endif + + if(hires_flag.eq.1) then !if/then hires_georef + ! Get Latitude (X) + iret = NF_INQ_VARID(ncstatic,'x',varid) + if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord) + ! Get Longitude (Y) + iret = NF_INQ_VARID(ncstatic,'y',varid) + if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord) + else + xcoord_d = 0. + ycoord_d = 0. + end if !endif hires_georef + + do j=jxrt,1,-1*decimation + jj = jj+1 + if (jj<= jxrtd) then + ycoord_d(jj) = ycoord(j) + endif + enddo + +!yw do i = 1,ixrt,decimation +!yw ii = ii + 1 +!yw if (ii <= ixrtd) then +!yw xcoord_d(ii) = xcoord(i) + xcoord_d = xcoord +!yw endif +!yw enddo + + + if(hires_flag.eq.1) then !if/then hires_georef + ! Get projection information from finegrid netcdf file + iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) + if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file + end if !endif hires_georef + iret = nf_close(ncstatic) + +!-- create the fine grid routing file + write(output_flnm, '(A12,".RTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif +#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#else + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#endif +#ifdef HYDRO_D + if (iret /= 0) then + print*, "Problem nf_create" + call hydro_stop("output_rt") + endif +#endif + + iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times) + iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx) + iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil) !-- 3-d soils + +!--- define variables +! !- time definition, timeObs + iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) + + !- x-coordinate in cartesian system + iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') + iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') + iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- y-coordinate in cartesian ssystem + iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') + iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') + iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- LATITUDE + iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE') + iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE') + iret = nf_put_att_text(ncid,varid,'units',5,'deg North') + + !- LONGITUDE + iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE') + iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE') + iret = nf_put_att_text(ncid,varid,'units',5,'deg east') + + !-- z-level is soil + iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid) + iret = nf_put_att_text(ncid,varid,'units',2,'cm') + iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer') + + iret = nf_def_var(ncid, "SOIL_M", NF_FLOAT, 4, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',7,'m^3/m^3') + iret = nf_put_att_text(ncid,varid,'description',16,'moisture content') + iret = nf_put_att_text(ncid,varid,'long_name',26,soilm) +! iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"ESNOW2D",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + +! iret = nf_def_var(ncid,"QSUBRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) +! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') +! iret = nf_put_att_text(ncid,varid,'long_name',15,'subsurface flow') +! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') +! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') +! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"ZWATTABLRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',1,'m') + iret = nf_put_att_text(ncid,varid,'long_name',17,'water table depth') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"Q_SFCFLX_X",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) +! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') +! iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux x') +! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') +! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') +! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"Q_SFCFLX_Y",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) +! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') +! iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux y') +! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') +! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') +! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"QSTRMVOLRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',14,'channel inflow') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"SFCHEADSUBRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"SOXRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) +! iret = nf_put_att_text(ncid,varid,'units',1,'1') +! iret = nf_put_att_text(ncid,varid,'long_name',7,'slope x') +! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') +! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') +! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"SOYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) +! iret = nf_put_att_text(ncid,varid,'units',1,'1') +! iret = nf_put_att_text(ncid,varid,'long_name',7,'slope 7') +! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') +! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') +! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +! iret = nf_def_var(ncid,"SUB_RESID",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + + iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',70, & + 'accumulated value of the boundary flux, + into domain, - out of domain') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +!-- place projection information + if(hires_flag.eq.1) then !if/then hires_georef + iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid) + iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm) + iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po) + iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe) + iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn) + iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp) + end if !endif hires_georef + +! iret = nf_def_var(ncid,"Date", NF_CHAR, 2, (/dimid_datelen,dimid_times/), varid) + + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(startdate)) = startdate + convention(1:32) = "CF-1.0" + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19) + iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation) + + iret = nf_enddef(ncid) + +!!-- write latitude and longitude locations +! xdumd = LATVAL + iret = nf_inq_varid(ncid,"x", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array + +! xdumd = LONVAL + iret = nf_inq_varid(ncid,"y", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array + + xdumd = LATVAL + iret = nf_inq_varid(ncid,"LATITUDE", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + + xdumd = LONVAL + iret = nf_inq_varid(ncid,"LONGITUDE", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + + +#ifdef HYDRO_D + write (*,*) "TEST....",LONVAL (1,1),(1,2) + write (*,*) "TEST....",LATVAL (1,1),(1,2) +#endif + + + + + do n = 1,nsoil + if(n == 1) then + asldpth(n) = -sldpth(n) + else + asldpth(n) = asldpth(n-1) - sldpth(n) + endif + enddo + + iret = nf_inq_varid(ncid,"depth", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth) +!yw iret = nf_close(ncstatic) + + endif + + output_count = output_count + 1 + +!!-- time + iret = nf_inq_varid(ncid,"time", varid) + iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since) + +!-- 3-d soils + do n = 1, nsoil +!DJG inv jj = int(jxrt/decimation) + jj = 1 + ii = 0 +!DJG inv do j = jxrt,1,-decimation + do j = 1,jxrt,decimation + do i = 1,ixrt,decimation + ii = ii + 1 + if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then + xdumd(ii,jj) = smcrt(i,j,n) + endif + enddo + ii = 0 +!DJG inv jj = jj -1 + jj = jj + 1 + enddo +! where (vegtyp(:,:) == 16) xdum = -1.E33 + iret = nf_inq_varid(ncid, "SOIL_M", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/), xdumd) + enddo !-n soils + + +!! where (vegtyp(:,:) == 16) xdum = -1.E33 +! jj = int(jxrt/decimation) +! ii = 0 +!! do j = jxrt,1,-decimation +! do j = 1,jxrt,decimation +! do i = 1,ixrt,decimation +! ii = ii + 1 +! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then +! xdumd(ii,jj) = QSUBRT(i,j) +! endif +! enddo +! ii = 0 +! jj = jj - 1 +! enddo +! iret = nf_inq_varid(ncid, "QSUBRT", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + +! xdum = ZWATTABLRT +! where (vegtyp(:,:) == 16) xdum = -1.E33 +!DJG inv jj = int(jxrt/decimation) + jj = 1 + ii = 0 +!DJG inv do j = jxrt,1,-decimation + do j = 1,jxrt,decimation + do i = 1,ixrt,decimation + ii = ii + 1 + if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then + xdumd(ii,jj) = ZWATTABLRT(i,j) + endif + enddo + ii = 0 +!DJG inv jj = jj - 1 + jj = jj + 1 + enddo + iret = nf_inq_varid(ncid, "ZWATTABLRT", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + + +!! xdum = Q_SFCFLX_X +!!! where (vegtyp(:,:) == 16) xdum = -1.E33 +! jj = int(jxrt/decimation) +! ii = 0 +!! do j = jxrt,1,-decimation +! do j = 1,jxrt,decimation +! do i = 1,ixrt,decimation +! ii = ii + 1 +! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then +! xdumd(ii,jj) = Q_SFCFLX_X(i,j) +! endif +! enddo +! ii = 0 +! jj = jj - 1 +! enddo +! iret = nf_inq_varid(ncid, "Q_SFCFLX_X", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) +!! +!! xdum = Q_SFCFLX_Y +!!! where (vegtyp(:,:) == 16) xdum = -1.E33 +! jj = int(jxrt/decimation) +! ii = 0 +!! do j = jxrt,1,-decimation +! do j = 1,jxrt,decimation +! do i = 1,ixrt,decimation +! ii = ii + 1 +! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then +! xdumd(ii,jj) = Q_SFCFLX_Y(i,j) +! endif +! enddo +! ii = 0 +! jj = jj - 1 +! enddo +! iret = nf_inq_varid(ncid, "Q_SFCFLX_Y", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + +! for compareing between sequential and parallel to initialized xdumd + xdumd = 0.0 + jj = 1 + ii = 0 + do j = 1,jxrt,decimation + do i = 1,ixrt,decimation + ii = ii + 1 + if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then + xdumd(ii,jj) = QBDRYRT(i,j) + endif + enddo + ii = 0 + jj = jj + 1 + enddo + iret = nf_inq_varid(ncid, "QBDRYRT", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + + + xdumd = 0.0 +! xdum = QSTRMVOLRT +!! where (vegtyp(:,:) == 16) xdum = -1.E33 +!DJG inv jj = int(jxrt/decimation) + jj = 1 + ii = 0 +!DJG inv do j = jxrt,1,-decimation + do j = 1,jxrt,decimation + do i = 1,ixrt,decimation + ii = ii + 1 + if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then + xdumd(ii,jj) = QSTRMVOLRT(i,j) + endif + enddo + ii = 0 +!DJG inv jj = jj - 1 + jj = jj + 1 + enddo + iret = nf_inq_varid(ncid, "QSTRMVOLRT", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + +! xdum = SFCHEADSUBRT +! where (vegtyp(:,:) == 16) xdum = -1.E33 +!DJG inv jj = int(jxrt/decimation) + jj = 1 + ii = 0 +!DJG inv do j = jxrt,1,-decimation + do j = 1,jxrt,decimation + do i = 1,ixrt,decimation + ii = ii + 1 + if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then + xdumd(ii,jj) = SFCHEADSUBRT(i,j) + endif + enddo + ii = 0 +!DJG inv jj = jj - 1 + jj = jj + 1 + enddo + iret = nf_inq_varid(ncid, "SFCHEADSUBRT", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + + +! iret = nf_inq_varid(ncid, "SOXRT", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + +!!! where (vegtyp(:,:) == 16) xdum = -1.E33 +! iret = nf_inq_varid(ncid, "SOYRT", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) +! +!! xdum = SUB_RESID +!!! where (vegtyp(:,:) == 16) xdum = -1.E33 +!! iret = nf_inq_varid(ncid, "SUB_RESID", varid) +!! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) +! +!!time in seconds since startdate + + iret = nf_redef(ncid) + date19(1:len_trim(date)) = date + iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) + + iret = nf_enddef(ncid) + iret = nf_sync(ncid) + if (output_count == split_output_count) then + output_count = 0 + iret = nf_close(ncid) + endif + + deallocate(xdumd) + deallocate(xcoord_d) + deallocate(xcoord) + deallocate(ycoord_d) + deallocate(ycoord) + +#ifdef HYDRO_D + write(6,*) "end of output_rt" +#endif + + end subroutine output_rt + +!BF output section for gw2d model +!bftodo: clean up an customize for GW usage + subroutine output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, & + startdate, date, HEAD, SMCRT, convgw, SFCHEADSUBRT, & + geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,HIRES_OUT) + +#ifdef MPP_LAND + USE module_mpp_land +#endif +!output the routing variables over routing grid. + implicit none +#include + + integer, intent(in) :: igrid + integer, intent(in) :: split_output_count + integer, intent(in) :: ixrt,jxrt + real, intent(in) :: dt + real, intent(in) :: dist(ixrt,jxrt,9) + integer, intent(in) :: nsoil + integer, intent(in) :: HIRES_OUT + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + character(len=*), intent(in) :: geo_finegrid_flnm + real, dimension(nsoil), intent(in) :: sldpth + real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable + real*8, allocatable, DIMENSION(:) :: xcoord_d, xcoord + real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord + + integer, save :: ncid,ncstatic + integer, save :: output_count + real, dimension(nsoil) :: asldpth + + integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n + integer :: iret, dimid_soil, i,j,ii,jj + character(len=256) :: output_flnm + character(len=19) :: date19 + character(len=32) :: convention + character(len=34) :: sec_since_date + + character(len=30) :: soilm + + real :: long_cm,lat_po,fe,fn, chan_in + real, dimension(2) :: sp + + real, dimension(ixrt,jxrt) :: head, convgw + real, dimension(ixrt,jxrt) :: SFCHEADSUBRT + real, dimension(ixrt,jxrt) :: latval,lonval + real, dimension(ixrt,jxrt,nsoil) :: SMCRT + + integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag + +#ifdef MPP_LAND + real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gSFCHEADSUBRT + real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval + real, dimension(global_rt_nx,global_rt_ny,nsoil) :: gSMCRT +#endif + +#ifdef MPP_LAND + call write_IO_rt_real(latval,gLatval) + call write_IO_rt_real(lonval,gLonval) + call write_IO_rt_real(SFCHEADSUBRT,gSFCHEADSUBRT) + call write_IO_rt_real(head,gHead) + call write_IO_rt_real(convgw,gConvgw) + + do i = 1, NSOIL + call write_IO_rt_real(SMCRT(:,:,i),gSMCRT(:,:,i)) + end do + + if(my_id.eq.IO_id) then + + +#endif + sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' + seconds_since = int(dt)*output_count + + decimation = 1 !-- decimation factor +#ifdef MPP_LAND + ixrtd = int(global_rt_nx/decimation) + jxrtd = int(global_rt_ny/decimation) +#else + ixrtd = int(ixrt/decimation) + jxrtd = int(jxrt/decimation) +#endif + allocate(xdumd(ixrtd,jxrtd)) + allocate(xcoord_d(ixrtd)) + allocate(ycoord_d(jxrtd)) + allocate(xcoord(ixrtd)) + allocate(ycoord(jxrtd)) + ii = 0 + jj = 0 + + if (hires_out.eq.1) return ! return if hires flag eq 1, if =2 output full grid + + if (output_count == 0) then + + !-- Open the finemesh static files to obtain projection information +#ifdef HYDRO_D + write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) + +#endif + iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic) + + if (iret /= 0) then +#ifdef HYDRO_D + write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & + trim(geo_finegrid_flnm) + write(*,*) "HIRES_OUTPUT will not be georeferenced..." +#endif + hires_flag = 0 + else + hires_flag = 1 + endif + + if(hires_flag.eq.1) then !if/then hires_georef + ! Get Latitude (X) + iret = NF_INQ_VARID(ncstatic,'x',varid) + if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord) + ! Get Longitude (Y) + iret = NF_INQ_VARID(ncstatic,'y',varid) + if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord) + else + xcoord_d = 0. + ycoord_d = 0. + end if !endif hires_georef + + do j=jxrt,1,-1*decimation + jj = jj+1 + if (jj<= jxrtd) then + ycoord_d(jj) = ycoord(j) + endif + enddo + +!yw do i = 1,ixrt,decimation +!yw ii = ii + 1 +!yw if (ii <= ixrtd) then +!yw xcoord_d(ii) = xcoord(i) + xcoord_d = xcoord +!yw endif +!yw enddo + + + if(hires_flag.eq.1) then !if/then hires_georef + ! Get projection information from finegrid netcdf file + iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) + if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn) !-- read it from the static file + iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file + end if !endif hires_georef + iret = nf_close(ncstatic) + +!-- create the fine grid routing file + write(output_flnm, '(A12,".GW_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + + +#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#else + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#endif + +#ifdef HYDRO_D + if (iret /= 0) then + print*, "Problem nf_create" + call hydro_stop("output_rt") + endif +#endif + + iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times) + iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx) + iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil) !-- 3-d soils + +!--- define variables + !- time definition, timeObs + iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) + + !- x-coordinate in cartesian system + iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') + iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') + iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- y-coordinate in cartesian ssystem + iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') + iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') + iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- LATITUDE + iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE') + iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE') + iret = nf_put_att_text(ncid,varid,'units',5,'deg North') + + !- LONGITUDE + iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE') + iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE') + iret = nf_put_att_text(ncid,varid,'units',5,'deg east') + + !-- z-level is soil + iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid) + iret = nf_put_att_text(ncid,varid,'units',2,'cm') + iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer') + + iret = nf_def_var(ncid, "SOIL_M", NF_FLOAT, 4, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',6,'kg m-2') + iret = nf_put_att_text(ncid,varid,'description',16,'moisture content') + iret = nf_put_att_text(ncid,varid,'long_name',26,soilm) +! iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"HEAD",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',1,'m') + iret = nf_put_att_text(ncid,varid,'long_name',17,'groundwater head') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"CONVGW",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',12,'channel flux') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + iret = nf_def_var(ncid,"Platzhalter",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) + iret = nf_put_att_text(ncid,varid,'units',2,'mm') + iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + +!-- place projection information + if(hires_flag.eq.1) then !if/then hires_georef + iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid) + iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm) + iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po) + iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe) + iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn) + iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp) + end if !endif hires_georef + +! iret = nf_def_var(ncid,"Date", NF_CHAR, 2, (/dimid_datelen,dimid_times/), varid) + + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(startdate)) = startdate + convention(1:32) = "CF-1.0" + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19) + iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation) + + iret = nf_enddef(ncid) + +!!-- write latitude and longitude locations +! xdumd = LATVAL + iret = nf_inq_varid(ncid,"x", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array + +! xdumd = LONVAL + iret = nf_inq_varid(ncid,"y", varid) +! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array + +#ifdef MPP_LAND + xdumd = gLATVAL +#else + xdumd = LATVAL +#endif + iret = nf_inq_varid(ncid,"LATITUDE", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + +#ifdef MPP_LAND + xdumd = gLONVAL +#else + xdumd = LONVAL +#endif + iret = nf_inq_varid(ncid,"LONGITUDE", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) + + do n = 1,nsoil + if(n == 1) then + asldpth(n) = -sldpth(n) + else + asldpth(n) = asldpth(n-1) - sldpth(n) + endif + enddo + + iret = nf_inq_varid(ncid,"depth", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth) +!yw iret = nf_close(ncstatic) + + endif + + output_count = output_count + 1 + +!!-- time + iret = nf_inq_varid(ncid,"time", varid) + iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since) + +!-- 3-d soils + do n = 1, nsoil +#ifdef MPP_LAND + xdumd = gSMCRT(:,:,n) +#else + xdumd = SMCRT(:,:,n) +#endif +! !DJG inv jj = int(jxrt/decimation) +! jj = 1 +! ii = 0 +! !DJG inv do j = jxrt,1,-decimation +! do j = 1,jxrt,decimation +! do i = 1,ixrt,decimation +! ii = ii + 1 +! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then +! xdumd(ii,jj) = smcrt(i,j,n) +! endif +! enddo +! ii = 0 +! !DJG inv jj = jj -1 +! jj = jj + 1 +! enddo +! where (vegtyp(:,:) == 16) xdum = -1.E33 + iret = nf_inq_varid(ncid, "SOIL_M", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/), xdumd) + enddo !-n soils + +#ifdef MPP_LAND + xdumd = gHead +#else + xdumd = head +#endif + + iret = nf_inq_varid(ncid, "HEAD", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + +#ifdef MPP_LAND + xdumd = gConvgw +#else + xdumd = convgw +#endif + iret = nf_inq_varid(ncid, "CONVGW", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + +!!time in seconds since startdate + + iret = nf_redef(ncid) + date19(1:len_trim(date)) = date + iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) + + iret = nf_enddef(ncid) + iret = nf_sync(ncid) + if (output_count == split_output_count) then + output_count = 0 + iret = nf_close(ncid) + endif + + deallocate(xdumd) + deallocate(xcoord_d) + deallocate(xcoord) + deallocate(ycoord_d) + deallocate(ycoord) + +#ifdef HYDRO_D + write(6,*) "end of output_ge" +#endif +#ifdef MPP_LAND + endif +#endif + + end subroutine output_gw + +!-- output the channel route in an IDV 'station' compatible format + subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER, & + startdate,date,chlon, chlat, hlink,zelev,qlink,dtrt,K, & + STRMFRXSTPTS,order_to_write) + + implicit none +#include +!!output the routing variables over just channel + integer, intent(in) :: igrid,K + integer, intent(in) :: split_output_count + integer, intent(in) :: NLINKS + real, dimension(NLINKS), intent(in) :: chlon,chlat + real, dimension(NLINKS), intent(in) :: hlink,zelev + integer, dimension(NLINKS), intent(in) :: ORDER + integer, dimension(NLINKS), intent(inout) :: STRMFRXSTPTS + + real, intent(in) :: dtrt + real, dimension(NLINKS,2), intent(in) :: qlink + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + real, allocatable, DIMENSION(:) :: chanlat,chanlon + real, allocatable, DIMENSION(:) :: chanlatO,chanlonO + + real, allocatable, DIMENSION(:) :: elevation + real, allocatable, DIMENSION(:) :: elevationO + + integer, allocatable, DIMENSION(:) :: station_id + integer, allocatable, DIMENSION(:) :: station_idO + + integer, allocatable, DIMENSION(:) :: rec_num_of_station + integer, allocatable, DIMENSION(:) :: rec_num_of_stationO + + integer, allocatable, DIMENSION(:) :: lOrder !- local stream order + integer, allocatable, DIMENSION(:) :: lOrderO !- local stream order + + integer, save :: output_count + integer, save :: ncid,ncid2 + + integer :: stationdim, dimdata, varid, charid, n + integer :: obsdim, dimdataO, charidO + + integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output + integer :: start_posO, prev_posO + + integer :: previous_pos !-- used for the station model + character(len=256) :: output_flnm,output_flnm2 + character(len=19) :: date19,date19start + character(len=34) :: sec_since_date + integer :: seconds_since,nstations,cnt,ObsStation,nobs + character(len=32) :: convention + character(len=11),allocatable, DIMENSION(:) :: stname + character(len=11),allocatable, DIMENSION(:) :: stnameO + + !--- all this for writing the station id string + INTEGER TDIMS, TXLEN + PARAMETER (TDIMS=2) ! number of TX dimensions + PARAMETER (TXLEN = 11) ! length of example string + INTEGER TIMEID ! record dimension id + INTEGER TXID ! variable ID + INTEGER TXDIMS(TDIMS) ! variable shape + INTEGER TSTART(TDIMS), TCOUNT(TDIMS) + + !-- observation point ids + INTEGER OTDIMS, OTXLEN + PARAMETER (OTDIMS=2) ! number of TX dimensions + PARAMETER (OTXLEN = 11) ! length of example string + INTEGER OTIMEID ! record dimension id + INTEGER OTXID ! variable ID + INTEGER OTXDIMS(OTDIMS) ! variable shape + INTEGER OTSTART(OTDIMS), OTCOUNT(OTDIMS) + +#ifdef HYDRO_D + write(6,*) "yyww dtrt =", dtrt , "k =", k +#endif + + seconds_since = int(dtrt)*K + +! order_to_write = 2 !-- 1 all; 6 feweest + + nstations = 0 ! total number of channel points to display + nobs = 0 ! number of observation points + +!-- output only the higher oder streamflows and only observation points + do i=1,NLINKS + if(ORDER(i) .ge. order_to_write) then + nstations = nstations + 1 + endif + if(STRMFRXSTPTS(i) .ne. -9999) then + nobs = nobs + 1 + endif + enddo + + if (nobs .eq. 0) then ! let's at least make one obs point + nobs = 1 + STRMFRXSTPTS(1) = 1 + endif + + allocate(chanlat(nstations)) + allocate(chanlon(nstations)) + allocate(elevation(nstations)) + allocate(station_id(nstations)) + allocate(lOrder(nstations)) + allocate(rec_num_of_station(nstations)) + allocate(stname(nstations)) + + allocate(chanlatO(nobs)) + allocate(chanlonO(nobs)) + allocate(elevationO(nobs)) + allocate(station_idO(nobs)) + allocate(lOrderO(nobs)) + allocate(rec_num_of_stationO(nobs)) + allocate(stnameO(nobs)) + + if(output_count == 0) then +!-- have moved sec_since_date from above here.. + sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & + //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' + + date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & + //startdate(12:13)//':'//startdate(15:16)//':00' + + nstations = 0 + nobs = 0 + + write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid + write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid + +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + +#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#else + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#endif +#ifdef HYDRO_D + if (iret /= 0) then + print*, "Problem nf_create points" + call hydro_stop("output_chrt") + endif +#endif + +#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm2), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid2) +#else + iret = nf_create(trim(output_flnm2), NF_CLOBBER, ncid2) +#endif +#ifdef HYDRO_D + if (iret /= 0) then + print*, "Problem nf_create observation" + call hydro_stop("output_chrt") + endif +#endif + + do i=1,NLINKS + if(ORDER(i) .ge. order_to_write) then + nstations = nstations + 1 + chanlat(nstations) = chlat(i) + chanlon(nstations) = chlon(i) + elevation(nstations) = zelev(i) + lOrder(nstations) = ORDER(i) + station_id(nstations) = i + if(STRMFRXSTPTS(nstations) .eq. -9999) then + ObsStation = 0 + else + ObsStation = 1 + endif + write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation + endif + enddo + + + do i=1,NLINKS + if(STRMFRXSTPTS(i) .ne. -9999) then + nobs = nobs + 1 + chanlatO(nobs) = chlat(i) + chanlonO(nobs) = chlon(i) + elevationO(nobs) = zelev(i) + lOrderO(nobs) = ORDER(i) + station_idO(nobs) = i + write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs) +#ifdef HYDRO_D +! print *,"stationobservation name", stnameO(nobs) +#endif + endif + enddo + + iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata) !--for linked list approach + + + iret = nf_def_dim(ncid, "station", nstations, stationdim) + + + + iret = nf_def_dim(ncid2, "recNum", NF_UNLIMITED, dimdataO) !--for linked list approach + iret = nf_def_dim(ncid2, "station", nobs, obsdim) + + + !- station location definition all, lat + iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid) +#ifdef HYDRO_D + write(6,*) "iret 2.1, ", iret, stationdim +#endif + iret = nf_put_att_text(ncid,varid,'long_name',16,'Station latitude') +#ifdef HYDRO_D + write(6,*) "iret 2.2", iret +#endif + iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north') +#ifdef HYDRO_D + write(6,*) "iret 2.3", iret +#endif + + + !- station location definition obs, lat + iret = nf_def_var(ncid2,"latitude",NF_FLOAT, 1, (/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation latitude') + iret = nf_put_att_text(ncid2,varid,'units',13,'degrees_north') + + + !- station location definition, long + iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',17,'Station longitude') + iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east') + + + !- station location definition, obs long + iret = nf_def_var(ncid2,"longitude",NF_FLOAT, 1, (/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',21,'Observation longitude') + iret = nf_put_att_text(ncid2,varid,'units',12,'degrees_east') + + +! !-- elevation is ZELEV + iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',16,'Station altitude') + iret = nf_put_att_text(ncid,varid,'units',6,'meters') + + +! !-- elevation is obs ZELEV + iret = nf_def_var(ncid2,"altitude",NF_FLOAT, 1, (/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation altitude') + iret = nf_put_att_text(ncid2,varid,'units',6,'meters') + + +! !-- gage observation +! iret = nf_def_var(ncid,"gages",NF_FLOAT, 1, (/stationdim/), varid) +! iret = nf_put_att_text(ncid,varid,'long_name',20,'Stream Gage Location') +! iret = nf_put_att_text(ncid,varid,'units',4,'none') + +!-- parent index + iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',36,'index of the station for this record') + + iret = nf_def_var(ncid2,"parent_index",NF_INT,1,(/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',36,'index of the station for this record') + + !-- prevChild + iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',57,'record number of the previous record for the same station') +!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + + iret = nf_def_var(ncid2,"prevChild",NF_INT,1,(/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',57,'record number of the previous record for the same station') +!ywtmp iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1) + + !-- lastChild + iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',30,'latest report for this station') +!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + + iret = nf_def_var(ncid2,"lastChild",NF_INT,1,(/obsdim/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',30,'latest report for this station') +!ywtmp iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1) + +! !- flow definition, var + iret = nf_def_var(ncid, "streamflow", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid,varid,'long_name',10,'River Flow') + + iret = nf_def_var(ncid2, "streamflow", NF_FLOAT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec') + iret = nf_put_att_text(ncid2,varid,'long_name',10,'River Flow') + +! !- flow definition, var +! iret = nf_def_var(ncid, "pos_streamflow", NF_FLOAT, 1, (/dimdata/), varid) +! iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') +! iret = nf_put_att_text(ncid,varid,'long_name',14,'abs streamflow') + +! !- head definition, var + iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',5,'meter') + iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage') + + iret = nf_def_var(ncid2, "head", NF_FLOAT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'units',5,'meter') + iret = nf_put_att_text(ncid2,varid,'long_name',11,'River Stage') + + +! !- order definition, var + iret = nf_def_var(ncid, "order", NF_INT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',21,'Strahler Stream Order') + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + + iret = nf_def_var(ncid2, "order", NF_INT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'long_name',21,'Strahler Stream Order') + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + + + !-- station id + ! define character-position dimension for strings of max length 11 + iret = NF_DEF_DIM(ncid, "id_len", 11, charid) + TXDIMS(1) = charid ! define char-string variable and position dimension first + TXDIMS(2) = stationdim + iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid) + iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id') + + iret = NF_DEF_DIM(ncid2, "id_len", 11, charidO) + OTXDIMS(1) = charidO ! define char-string variable and position dimension first + OTXDIMS(2) = obsdim + iret = nf_def_var(ncid2,"station_id",NF_CHAR, OTDIMS, OTXDIMS, varid) + iret = nf_put_att_text(ncid2,varid,'long_name',14,'Observation id') + + +! !- time definition, timeObs + iret = nf_def_var(ncid,"time_observation",NF_INT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) + iret = nf_put_att_text(ncid,varid,'long_name',19,'time of observation') + + iret = nf_def_var(ncid2,"time_observation",NF_INT, 1, (/dimdataO/), varid) + iret = nf_put_att_text(ncid2,varid,'units',34,sec_since_date) + iret = nf_put_att_text(ncid2,varid,'long_name',19,'time of observation') + + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention) + + convention(1:32) = "Unidata Observation Dataset v1.0" + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19start) + iret = nf_put_att_text(ncid, NF_GLOBAL, "stationDimension",7, "station") + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_int(ncid, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write) + + iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "cdm_datatype",7, "Station") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_max",4, "90.0") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_max",5, "180.0") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") + iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_start",19, date19start) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "stationDimension",7, "station") + iret = nf_put_att_real(ncid2, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_int(ncid2, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write) + + iret = nf_enddef(ncid) + iret = nf_enddef(ncid2) + + !-- write latitudes + iret = nf_inq_varid(ncid,"latitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlat) + + iret = nf_inq_varid(ncid2,"latitude", varid) + iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlatO) + + !-- write longitudes + iret = nf_inq_varid(ncid,"longitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlon) + + iret = nf_inq_varid(ncid2,"longitude", varid) + iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlonO) + + !-- write elevations + iret = nf_inq_varid(ncid,"altitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), elevation) + + iret = nf_inq_varid(ncid2,"altitude", varid) + iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), elevationO) + + !-- write gage location +! iret = nf_inq_varid(ncid,"gages", varid) +! iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), STRMFRXSTPTS) + + !-- write number_of_stations, OPTIONAL + !! iret = nf_inq_varid(ncid,"number_stations", varid) + !! iret = nf_put_var_int(ncid, varid, nstations) + + !-- write station id's + do i=1,nstations + TSTART(1) = 1 + TSTART(2) = i + TCOUNT(1) = TXLEN + TCOUNT(2) = 1 + iret = nf_inq_varid(ncid,"station_id", varid) + iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i)) + enddo + + !-- write observation id's + do i=1, nobs + OTSTART(1) = 1 + OTSTART(2) = i + OTCOUNT(1) = OTXLEN + OTCOUNT(2) = 1 + iret = nf_inq_varid(ncid2,"station_id", varid) + iret = nf_put_vara_text(ncid2, varid, OTSTART, OTCOUNT, stnameO(i)) + enddo + + endif + + output_count = output_count + 1 + + open (unit=999,file='frxst_pts_out.txt',status='unknown',position='append') + + cnt=0 + do i=1,NLINKS + + if(ORDER(i) .ge. order_to_write) then + start_pos = (cnt+1)+(nstations*(output_count-1)) + + !!--time in seconds since startdate + iret = nf_inq_varid(ncid,"time_observation", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since) + + iret = nf_inq_varid(ncid,"streamflow", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlink(i,1)) + +! iret = nf_inq_varid(ncid,"pos_streamflow", varid) +! iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), abs(qlink(i,1))) + + iret = nf_inq_varid(ncid,"head", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), hlink(i)) + + iret = nf_inq_varid(ncid,"order", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), ORDER(i)) + + !-- station index.. will repeat for every timesstep + iret = nf_inq_varid(ncid,"parent_index", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt) + + !--record number of previous record for same station +!obsolete format prev_pos = cnt+(nstations*(output_count-1)) + prev_pos = cnt+(nobs*(output_count-2)) + if(output_count.ne.1) then !-- only write next set of records + iret = nf_inq_varid(ncid,"prevChild", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos) + endif + + cnt=cnt+1 !--indices are 0 based + rec_num_of_station(cnt) = start_pos-1 !-- save position for last child, 0-based!! + + + endif + enddo +! close(999) + + !-- output only observation points + cnt=0 + do i=1,NLINKS + + if(STRMFRXSTPTS(i) .ne. -9999) then + start_posO = (cnt+1)+(nobs * (output_count-1)) +!Write frxst_pts to text file... +!yw write(999,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & + write(999,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), & + qlink(i,1), qlink(i,1)*35.315,hlink(i) +!yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) +!yw 117 FORMAT(I8,1X,A10,1X,A8,1x,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) + 117 FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) + + !!--time in seconds since startdate + iret = nf_inq_varid(ncid2,"time_observation", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), seconds_since) + + iret = nf_inq_varid(ncid2,"streamflow", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1)) + + iret = nf_inq_varid(ncid2,"head", varid) + iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i)) + + iret = nf_inq_varid(ncid,"order", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i)) + + !-- station index.. will repeat for every timesstep + iret = nf_inq_varid(ncid2,"parent_index", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt) + + !--record number of previous record for same station +!obsolete format prev_posO = cnt+(nobs*(output_count-1)) + prev_posO = cnt+(nobs*(output_count-2)) + if(output_count.ne.1) then !-- only write next set of records + iret = nf_inq_varid(ncid2,"prevChild", varid) + iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) + +!IF block to add -1 to last element of prevChild array to designate end of list... +! if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then +! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1) +! else +! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) +! endif + + + endif + + cnt=cnt+1 !--indices are 0 based + rec_num_of_stationO(cnt) = start_posO - 1 !-- save position for last child, 0-based!! + + + endif + + enddo + close(999) + + + !-- lastChild variable gives the record number of the most recent report for the station + iret = nf_inq_varid(ncid,"lastChild", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), rec_num_of_station) + + !-- lastChild variable gives the record number of the most recent report for the station + iret = nf_inq_varid(ncid2,"lastChild", varid) + iret = nf_put_vara_int(ncid2, varid, (/1/), (/nobs/), rec_num_of_stationO) + + iret = nf_redef(ncid) + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(date)) = date + iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) + + iret = nf_redef(ncid2) + iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_end", 19, date19) + + iret = nf_enddef(ncid) + iret = nf_sync(ncid) + + iret = nf_enddef(ncid2) + iret = nf_sync(ncid2) + + if (output_count == split_output_count) then + output_count = 0 + iret = nf_close(ncid) + iret = nf_close(ncid2) + endif + + deallocate(chanlat) + deallocate(chanlon) + deallocate(elevation) + deallocate(station_id) + deallocate(lOrder) + deallocate(rec_num_of_station) + deallocate(stname) + + deallocate(chanlatO) + deallocate(chanlonO) + deallocate(elevationO) + deallocate(station_idO) + deallocate(lOrderO) + deallocate(rec_num_of_stationO) + deallocate(stnameO) +#ifdef HYDRO_D + print *, "Exited Subroutine output_chrt" +#endif + close(16) + +20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3) + +end subroutine output_chrt + +#ifdef MPP_LAND +!-- output the channel route in an IDV 'station' compatible format + subroutine mpp_output_chrt(gnlinks,map_l2g,igrid, & + split_output_count, NLINKS, ORDER, & + startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt, & + K,STRMFRXSTPTS,order_to_write) + + USE module_mpp_land + +!!output the routing variables over just channel + integer, intent(in) :: igrid,K + integer, intent(in) :: split_output_count + integer, intent(in) :: NLINKS + real, dimension(NLINKS), intent(in) :: chlon,chlat + real, dimension(NLINKS), intent(in) :: hlink,zelev + + integer, dimension(NLINKS), intent(in) :: ORDER + integer, dimension(NLINKS), intent(inout) :: STRMFRXSTPTS + + real, intent(in) :: dtrt + real, dimension(NLINKS,2), intent(in) :: qlink + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + integer :: gnlinks, map_l2g(nlinks), order_to_write + real, dimension(gNLINKS) :: g_chlon,g_chlat, g_hlink,g_zelev + real, dimension(gNLINKS,2) :: g_qlink + integer , dimension(gNLINKS) :: g_order,g_STRMFRXSTPTS + + + call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) + call write_chanel_int(STRMFRXSTPTS,map_l2g,gnlinks,nlinks,g_STRMFRXSTPTS) + call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon) + call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat) + call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink) + call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev) + call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) + call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) + + if(my_id .eq. IO_id) then + call output_chrt(igrid, split_output_count, GNLINKS, g_ORDER, & + startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt,K,& + g_STRMFRXSTPTS,order_to_write) + end if + +end subroutine mpp_output_chrt + +!--------- lake netcdf output ----------------------------------------- +!-- output the ilake info an IDV 'station' compatible format ----------- + subroutine mpp_output_lakes(lake_index,igrid, split_output_count, NLAKES, & + startdate, date, latlake, lonlake, elevlake, & + qlakei,qlakeo, resht,dtrt,K) + + USE module_mpp_land + +!!output the routing variables over just channel + integer, intent(in) :: igrid, K + integer, intent(in) :: split_output_count + integer, intent(in) :: NLAKES + real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht + real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake + real, intent(in) :: dtrt + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + integer lake_index(nlakes) + + call write_lake_real(latlake,lake_index,nlakes) + call write_lake_real(lonlake,lake_index,nlakes) + call write_lake_real(elevlake,lake_index,nlakes) + call write_lake_real(resht,lake_index,nlakes) + call write_lake_real(qlakei,lake_index,nlakes) + call write_lake_real(qlakeo,lake_index,nlakes) + if(my_id.eq. IO_id) then + call output_lakes(igrid, split_output_count, NLAKES, & + startdate, date, latlake, lonlake, elevlake, & + qlakei,qlakeo, resht,dtrt,K) + end if + return + end subroutine mpp_output_lakes + +#endif + +!----------------------------------- lake netcdf output +!-- output the ilake info an IDV 'station' compatible format + subroutine output_lakes(igrid, split_output_count, NLAKES, & + startdate, date, latlake, lonlake, elevlake, & + qlakei,qlakeo, resht,dtrt,K) + +!!output the routing variables over just channel + integer, intent(in) :: igrid, K + integer, intent(in) :: split_output_count + integer, intent(in) :: NLAKES + real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht + real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake + real, intent(in) :: dtrt + + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + + integer, allocatable, DIMENSION(:) :: station_id + integer, allocatable, DIMENSION(:) :: rec_num_of_lake + + integer, save :: output_count + integer, save :: ncid + + integer :: stationdim, dimdata, varid, charid, n + integer :: iret,i, start_pos, prev_pos !-- + integer :: previous_pos !-- used for the station model + character(len=256) :: output_flnm + character(len=19) :: date19, date19start + character(len=34) :: sec_since_date + integer :: seconds_since,cnt + character(len=32) :: convention + character(len=6),allocatable, DIMENSION(:) :: stname + + !--- all this for writing the station id string + INTEGER TDIMS, TXLEN + PARAMETER (TDIMS=2) ! number of TX dimensions + PARAMETER (TXLEN = 6) ! length of example string + INTEGER TIMEID ! record dimension id + INTEGER TXID ! variable ID + INTEGER TXDIMS(TDIMS) ! variable shape + INTEGER TSTART(TDIMS), TCOUNT(TDIMS) + +! sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' +! seconds_since = int(dtrt)*output_count + seconds_since = int(dtrt)*K + + allocate(station_id(NLAKES)) + allocate(rec_num_of_lake(NLAKES)) + allocate(stname(NLAKES)) + + if (output_count == 0) then + +!-- have moved sec_since_date from above here.. + sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & + //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' + + date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & + //startdate(12:13)//':'//startdate(15:16)//':00' + + write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + +#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#else + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#endif + +#ifdef HYDRO_D + if (iret /= 0) then + print*, "Problem nf_create" + call hydro_stop("output_lakes") + endif +#endif + + do i=1,NLAKES + station_id(i) = i + write(stname(i),'(I6)') i + enddo + + iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata) !--for linked list approach + iret = nf_def_dim(ncid, "station", nlakes, stationdim) + + !- station location definition, lat + iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake latitude') + iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north') + + !- station location definition, long + iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake longitude') + iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east') + +! !-- lake's phyical elevation + iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake altitude') + iret = nf_put_att_text(ncid,varid,'units',6,'meters') + + !-- parent index + iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',33,'index of the lake for this record') + + !-- prevChild + iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',54,'record number of the previous record for the same lake') +!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + + !-- lastChild + iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid) + iret = nf_put_att_text(ncid,varid,'long_name',27,'latest report for this lake') +!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) + iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) + +! !- water surface elevation + iret = nf_def_var(ncid, "elevation", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',6,'meters') + iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake Elevation') + +! !- inflow to lake + iret = nf_def_var(ncid, "inflow", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + +! !- outflow to lake + iret = nf_def_var(ncid, "outflow", NF_FLOAT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') + + !-- station id + ! define character-position dimension for strings of max length 6 + iret = NF_DEF_DIM(ncid, "id_len", 6, charid) + TXDIMS(1) = charid ! define char-string variable and position dimension first + TXDIMS(2) = stationdim + iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid) + iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id') + +! !- time definition, timeObs + iret = nf_def_var(ncid,"time_observation",NF_INT, 1, (/dimdata/), varid) + iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) + iret = nf_put_att_text(ncid,varid,'long_name',19,'time of observation') + +! date19(1:19) = "0000-00-00_00:00:00" +! date19(1:len_trim(startdate)) = startdate +! iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) +! + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(startdate)) = startdate + convention(1:32) = "Unidata Observation Dataset v1.0" + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") + iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19start) + iret = nf_put_att_text(ncid, NF_GLOBAL, "stationDimension",7, "station") +!! iret = nf_put_att_text(ncid, NF_GLOBAL, "observationDimension",6, "recNum") +!! iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coordinate",16,"time_observation") + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_enddef(ncid) + + !-- write latitudes + iret = nf_inq_varid(ncid,"latitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LATLAKE) + + !-- write longitudes + iret = nf_inq_varid(ncid,"longitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LONLAKE) + + !-- write physical height of lake + iret = nf_inq_varid(ncid,"altitude", varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), elevlake) + + !-- write station id's + do i=1,nlakes + TSTART(1) = 1 + TSTART(2) = i + TCOUNT(1) = TXLEN + TCOUNT(2) = 1 + iret = nf_inq_varid(ncid,"station_id", varid) + iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i)) + enddo + + endif + + output_count = output_count + 1 + + cnt=0 + do i=1,NLAKES + + start_pos = (cnt+1)+(nlakes*(output_count-1)) + + !!--time in seconds since startdate + iret = nf_inq_varid(ncid,"time_observation", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since) + + iret = nf_inq_varid(ncid,"elevation", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), resht(i)) + + iret = nf_inq_varid(ncid,"inflow", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakei(i)) + + iret = nf_inq_varid(ncid,"outflow", varid) + iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakeo(i)) + + !-- station index.. will repeat for every timesstep + iret = nf_inq_varid(ncid,"parent_index", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt) + + !--record number of previous record for same station + prev_pos = cnt+(nlakes*(output_count-1)) + if(output_count.ne.1) then !-- only write next set of records + iret = nf_inq_varid(ncid,"prevChild", varid) + iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos) + endif + + cnt=cnt+1 !--indices are 0 based + rec_num_of_lake(cnt) = start_pos-1 !-- save position for last child, 0-based!! + + enddo + + !-- lastChild variable gives the record number of the most recent report for the station + iret = nf_inq_varid(ncid,"lastChild", varid) + iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake) + + !-- number of children reported for this station, OPTIONAL + !-- iret = nf_inq_varid(ncid,"numChildren", varid) + !-- iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake) + + iret = nf_redef(ncid) + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(date)) = date + iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) + iret = nf_enddef(ncid) + + iret = nf_sync(ncid) + if (output_count == split_output_count) then + output_count = 0 + iret = nf_close(ncid) + endif + + deallocate(station_id) + deallocate(rec_num_of_lake) + deallocate(stname) +#ifdef HYDRO_D + print *, "Exited Subroutine output_lakes" +#endif + close(16) + + end subroutine output_lakes +!----------------------------------- lake netcdf output + +#ifdef MPP_LAND + +!-- output the channel route in an IDV 'grid' compatible format + subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & + NLINKS,CH_NETRT_in, CH_NETLNK_in, ORDER, startdate, date, & + qlink, dt, geo_finegrid_flnm, gnlinks,map_l2g,g_ixrt,g_jxrt ) + + USE module_mpp_land + + implicit none +#include + integer g_ixrt,g_jxrt + integer, intent(in) :: igrid + integer, intent(in) :: split_output_count + integer, intent(in) :: NLINKS,ixrt,jxrt + real, intent(in) :: dt + real, dimension(NLINKS,2), intent(in) :: qlink + integer, dimension(g_IXRT,g_JXRT) :: CH_NETRT,CH_NETLNK + integer, dimension(IXRT,JXRT), intent(in) :: CH_NETRT_in,CH_NETLNK_in + integer, dimension(NLINKS), intent(in) :: ORDER !--currently not used here, see finegrid.f + character(len=*), intent(in) :: geo_finegrid_flnm + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + integer:: gnlinks , map_l2g(nlinks) + + integer,dimension(gnlinks) :: g_order + real, dimension(gNLINKS,2) :: g_qlink + + call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) + call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) + call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) + + call write_IO_rt_int(CH_NETRT_in, CH_NETRT) + call write_IO_rt_int(CH_NETLNK_in, CH_NETLNK) + + if(my_id.eq.IO_id) then + call output_chrtgrd(igrid, split_output_count, g_ixrt,g_jxrt, & + GNLINKS,CH_NETRT, CH_NETLNK, g_ORDER, startdate, date, & + g_qlink, dt, geo_finegrid_flnm) + endif + + return + end subroutine mpp_output_chrtgrd +#endif + +!-- output the channel route in an IDV 'grid' compatible format + subroutine output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & + NLINKS,CH_NETRT, CH_NETLNK, ORDER, startdate, date, & + qlink, dt, geo_finegrid_flnm) + + integer, intent(in) :: igrid + integer, intent(in) :: split_output_count + integer, intent(in) :: NLINKS,ixrt,jxrt + real, intent(in) :: dt + real, dimension(NLINKS,2), intent(in) :: qlink + integer, dimension(IXRT,JXRT), intent(in) :: CH_NETRT,CH_NETLNK + integer, dimension(NLINKS), intent(in) :: ORDER !--currently not used here, see finegrid.f + character(len=*), intent(in) :: geo_finegrid_flnm + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: date + character(len=32) :: convention + integer,save :: output_count + integer, save :: ncid,ncstatic + real, dimension(IXRT,JXRT) :: tmpflow + real, dimension(IXRT) :: xcoord + real, dimension(JXRT) :: ycoord + real :: long_cm,lat_po,fe,fn + real, dimension(2) :: sp + + integer :: varid, n + integer :: jxlatdim,ixlondim,timedim !-- dimension ids + + integer :: iret,i,j + character(len=256) :: output_flnm + character(len=19) :: date19 + character(len=34) :: sec_since_date + + + integer :: seconds_since + + + + + tmpflow = -9E15 + + + write(output_flnm, '(A12,".CHRTOUT_GRID",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid +#ifdef HYDRO_D + print*, 'output_flnm = "'//trim(output_flnm)//'"' +#endif + + +!--- define dimension +#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT + iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#else + iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) +#endif + +#ifdef HYDRO_D + if (iret /= 0) then + print*, "Problem nf_create" + call hydro_stop("output_chrtgrd") + endif +#endif + + + iret = nf_def_dim(ncid, "time", NF_UNLIMITED, timedim) + iret = nf_def_dim(ncid, "x", ixrt, ixlondim) + iret = nf_def_dim(ncid, "y", jxrt, jxlatdim) + +!--- define variables +! !- time definition, timeObs + iret = nf_def_var(ncid,"time",NF_INT, 1, (/timedim/), varid) + + !- x-coordinate in cartesian system +!yw iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/ixlondim/), varid) +!yw iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') +!yw iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') +!yw iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + + !- y-coordinate in cartesian ssystem +!yw iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/jxlatdim/), varid) +!yw iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') +!yw iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') +!yw iret = nf_put_att_text(ncid,varid,'units',5,'Meter') + +! !- flow definition, var + iret = nf_def_var(ncid,"flow",NF_REAL, 3, (/ixlondim,jxlatdim,timedim/), varid) + iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') + iret = nf_put_att_text(ncid,varid,'long_name',15,'water flow rate') + iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') + iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') + iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) + + +!-- place prjection information + + + date19(1:19) = "0000-00-00_00:00:00" + date19(1:len_trim(startdate)) = startdate + convention(1:32) = "CF-1.0" + iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) + iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) + iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19) + + iret = nf_enddef(ncid) + +!!-- write latitude and longitude locations + +!DJG inv do j=jxrt,1,-1 + do j=1,jxrt + do i=1,ixrt + if(CH_NETRT(i,j).GE.0) then + tmpflow(i,j) = qlink(CH_NETLNK(i,j),1) + else + tmpflow(i,j) = -9E15 + endif + enddo + enddo + +!!time in seconds since startdate + + iret = nf_inq_varid(ncid,"flow", varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ixrt,jxrt,1/),tmpflow) + + iret = nf_close(ncid) + + + + end subroutine output_chrtgrd + + + +#ifdef MPP_LAND + subroutine mpp_output_rt(ixrt, jxrt,igrid, split_output_count, & + ixrt_in, jxrt_in,nsoil, startdate, olddate, & + QSUBRT_in,ZWATTABLRT_in,SMCRT_in,SUB_RESID_in, & + q_sfcflx_x_in,q_sfcflx_y_in,soxrt_in,soyrt_in, & + QSTRMVOLRT_in,SFCHEADSUBRT_in, & + geo_finegrid_flnm,dt,sldpth,LATVAL_in,LONVAL_in,dist,HIRES_OUT, & + QBDRYRT_in) + +!output the routing variables over routing grid. + USE module_mpp_land + + implicit none +#include + + integer, intent(in) :: igrid + integer, intent(in) :: split_output_count + +! ixrt and jxrt are global. ixrt_in and jxrt_in are local array index. + integer, intent(in) :: ixrt,jxrt,ixrt_in,jxrt_in + real, intent(in) :: dt + real, intent(in) :: dist(ixrt_in,jxrt_in,9) + integer, intent(in) :: nsoil + integer, intent(in) :: HIRES_OUT + character(len=*), intent(in) :: startdate + character(len=*), intent(in) :: olddate + character(len=*), intent(in) :: geo_finegrid_flnm + real, dimension(nsoil), intent(in) :: sldpth + + real, dimension(ixrt_in,jxrt_in) :: QSUBRT_in,ZWATTABLRT_in,SUB_RESID_in + real, dimension(ixrt_in,jxrt_in) :: q_sfcflx_x_in,q_sfcflx_y_in + real, dimension(ixrt_in,jxrt_in) :: QSTRMVOLRT_in + real, dimension(ixrt_in,jxrt_in) :: SFCHEADSUBRT_in, QBDRYRT_in + real, dimension(ixrt_in,jxrt_in) :: soxrt_in,soyrt_in + real, dimension(ixrt_in,jxrt_in,nsoil) :: SMCRT_in + real, dimension(ixrt_in,jxrt_in) :: LATVAL_in,LONVAL_in + + real, dimension(ixrt,jxrt) :: QSUBRT,ZWATTABLRT,SUB_RESID + real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y + real, dimension(ixrt,jxrt) :: QSTRMVOLRT, QBDRYRT + real, dimension(ixrt,jxrt) :: SFCHEADSUBRT + real, dimension(ixrt,jxrt) :: soxrt,soyrt + real, dimension(ixrt,jxrt,nsoil) :: SMCRT + real, dimension(ixrt,jxrt,9) :: dist_g + real, dimension(ixrt,jxrt) :: LATVAL,LONVAL + integer i + + +#ifdef HYDRO_D + write(6,*) "mpp_output_RT output file: ",trim(geo_finegrid_flnm) +#endif + + call write_IO_rt_real(LATVAL_in,LATVAL) + call write_IO_rt_real(LONVAL_in,LONVAL) + call write_IO_rt_real(QSUBRT_in,QSUBRT) + + + call write_IO_rt_real(ZWATTABLRT_in,ZWATTABLRT) + + + call write_IO_rt_real(SUB_RESID_in,SUB_RESID) + + + call write_IO_rt_real(QSTRMVOLRT_in,QSTRMVOLRT) + + + + call write_IO_rt_real(SFCHEADSUBRT_in,SFCHEADSUBRT) + call write_IO_rt_real(soxrt_in,soxrt) + + call write_IO_rt_real(QBDRYRT_in,QBDRYRT) + + + + call write_IO_rt_real(soyrt_in,soyrt) + call write_IO_rt_real(q_sfcflx_x_in,q_sfcflx_x) + call write_IO_rt_real(q_sfcflx_y_in,q_sfcflx_y) + + + + + do i = 1, NSOIL + call write_IO_rt_real(SMCRT_in(:,:,i),SMCRT(:,:,i)) + end do + do i = 1, 9 + call write_IO_rt_real(dist(:,:,i),dist_g(:,:,i)) + end do + +! yyywwww ! temp test +! if(my_id.eq. IO_id ) write(14,*) dist(:,:,9) +! if(my_id.eq. IO_id ) write(12,*) dist_g(:,:,9) + + + + + if(my_id.eq.IO_id) then + call output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & + startdate, olddate, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID, & + q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, & + geo_finegrid_flnm,DT,SLDPTH,latval,lonval,dist_g,HIRES_OUT, & + QBDRYRT) + end if + +#ifdef HYDRO_D + write(6,*) "return from mpp_output_RT" +#endif + end subroutine mpp_output_rt + +#endif + + subroutine read_chan_forcing( & + indir,olddate,startdate,hgrid,& + ixrt,jxrt,QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT) +! This subrouting is going to read channel forcing for +! channel only simulations (ie when CHANRTSWCRT = 2) + + implicit none +#include + ! in variable + character(len=*) :: olddate,hgrid,indir,startdate + character(len=256) :: filename + integer :: ixrt,jxrt + real,dimension(ixrt,jxrt):: QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT + ! tmp variable + character(len=256) :: inflnm, product + integer :: i,j,mmflag + character(len=256) :: units + integer :: ierr + integer :: ncid + + +!DJG Create filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".RTOUT_DOMAIN"//hgrid +#ifdef HYDRO_D + print *, "Channel forcing file...",inflnm +#endif + + +!DJG Open NetCDF file... + ierr = nf_open(inflnm, NF_NOWRITE, ncid) + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_chan Problem opening netcdf file: ''", A, "''")') trim(inflnm) + call hydro_stop("read_chan_forcing") +#endif + endif + +!DJG read data... + call get_2d_netcdf("QSTRMVOLRT", ncid, QSTRMVOLRT_ACC, units, ixrt, jxrt, .TRUE., ierr) +!DJG TBC call get_2d_netcdf("T2D", ncid, t, units, ixrt, jxrt, .TRUE., ierr) +!DJG TBC call get_2d_netcdf("T2D", ncid, t, units, ixrt, jxrt, .TRUE., ierr) + + ierr = nf_close(ncid) + + end subroutine read_chan_forcing + + + + + subroutine get2d_int(var_name,out_buff,ix,jx,fileName) + implicit none +#include + integer :: iret,varid,ncid,ix,jx + integer out_buff(ix,jx) + character(len=*), intent(in) :: var_name + character(len=*), intent(in) :: fileName + iret = nf_open(trim(fileName), NF_NOWRITE, ncid) + if (iret .ne. 0) then +#ifdef HYDRO_D + print*,"aaa failed to open the netcdf file: ",trim(fileName) + call hydro_stop("get2d_int") +#endif + endif + iret = nf_inq_varid(ncid,trim(var_name), varid) + if(iret .ne. 0) then +#ifdef HYDRO_D + print*,"failed to read the variabe: ",trim(var_name) + print*,"failed to read the netcdf file: ",trim(fileName) +#endif + endif + iret = nf_get_var_int(ncid, varid, out_buff) + iret = nf_close(ncid) + return + end subroutine get2d_int + +#ifdef MPP_LAND + SUBROUTINE MPP_READ_ROUTEDIM(did,g_IXRT,g_JXRT, GCH_NETLNK,GNLINKS,IXRT,JXRT, & + route_chan_f,route_link_f, & + route_direction_f, route_lake_f,NLINKS, NLAKES, & + CH_NETLNK, channel_option, geo_finegrid_flnm) + + + USE module_mpp_land + + implicit none +#include + INTEGER :: channel_option, did + INTEGER :: g_IXRT,g_JXRT + INTEGER, INTENT(INOUT) :: NLINKS, NLAKES, GNLINKS + INTEGER, INTENT(IN) :: IXRT,JXRT + INTEGER :: CHNID,cnt + INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: GCH_NETLNK !- each node gets unique id based on global domain + INTEGER, DIMENSION(g_IXRT,g_JXRT) :: g_CH_NETLNK ! temp array + INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction + INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + REAL, DIMENSION(IXRT,JXRT) :: LAT, LON + integer:: i,j + + CHARACTER(len=256) :: route_chan_f, route_link_f,route_direction_f,route_lake_f + CHARACTER(len=256) :: geo_finegrid_flnm +! CHARACTER(len=*) :: geo_finegrid_flnm + +! integer, allocatable, dimension(:) :: tmp_int + integer :: ywcount + + if(my_id .eq. IO_id) then + CALL READ_ROUTEDIM(g_IXRT, g_JXRT, route_chan_f, route_link_f, & + route_direction_f, route_lake_f, GNLINKS, NLAKES, & + g_CH_NETLNK, channel_option,geo_finegrid_flnm) + endif + + + call mpp_land_bcast_int1(NLAKES) + call mpp_land_bcast_int1(GNLINKS) + + + call decompose_RT_int(g_CH_NETLNK,GCH_NETLNK,g_IXRT,g_JXRT,ixrt,jxrt) + ywcount = 0 + CH_NETLNK = -9999 + do j = 1, jxrt + do i = 1, ixrt + if(GCH_NETLNK(i,j) .gt. 0) then + ywcount = ywcount + 1 + CH_NETLNK(i,j) = ywcount + endif + end do + end do + NLINKS = ywcount + + allocate(rt_domain(did)%map_l2g(NLINKS)) + + rt_domain(did)%map_l2g = -1 + do j = 1, jxrt + do i = 1, ixrt + if(CH_NETLNK(i,j) .gt. 0) then + rt_domain(did)%map_l2g(CH_NETLNK(i,j)) = GCH_NETLNK(i,j) + endif + end do + end do + + call mpp_chrt_nlinks_collect(NLINKS) + return + end SUBROUTINE MPP_READ_ROUTEDIM + + SUBROUTINE MPP_READ_ROUTING(IXRT,JXRT,ELRT, & + CH_NETRT,LKSATFAC,route_topo_f, & + route_chan_f, geo_finegrid_flnm,g_IXRT,g_JXRT, & + OVROUGHRTFAC,RETDEPRTFAC) + + implicit none +#include + INTEGER, INTENT(IN) :: IXRT,JXRT,g_IXRT,g_JXRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC,RETDEPRTFAC + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT + + REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_ELRT + INTEGER,DIMENSION(g_IXRT,g_JXRT) :: g1_CH_NETRT + REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_LKSATFAC + REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_OVROUGHRTFAC + REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_RETDEPRTFAC + + CHARACTER(len=256) :: route_topo_f,route_chan_f,geo_finegrid_flnm + + if(my_id .eq. IO_id) then + CALL READ_ROUTING_seq(g_IXRT,g_JXRT,g1_ELRT,g1_CH_NETRT,g1_LKSATFAC,& + route_topo_f, route_chan_f,geo_finegrid_flnm,g1_OVROUGHRTFAC,& + g1_RETDEPRTFAC) + endif + + call decompose_RT_real(g1_ELRT,ELRT,g_IXRT,g_JXRT,IXRT,JXRT) + call decompose_RT_int(g1_CH_NETRT,CH_NETRT,g_IXRT,g_JXRT,IXRT,JXRT) + call decompose_RT_real(g1_LKSATFAC,LKSATFAC,g_IXRT,g_JXRT,IXRT,JXRT) + call decompose_RT_real(g1_RETDEPRTFAC,RETDEPRTFAC,g_IXRT,g_JXRT,IXRT,JXRT) + call decompose_RT_real(g1_OVROUGHRTFAC,OVROUGHRTFAC,g_IXRT,g_JXRT,IXRT,JXRT) + + return + end SUBROUTINE MPP_READ_ROUTING + + + subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& + global_nX, global_ny,nsoil,out_SMC,out_SH2OX) + implicit none +#include + + integer, intent(in) :: ix,global_nx,global_ny + integer, intent(in) :: jx,nsoil + real, dimension(ix,jx), intent(in) :: in_smcmax + real, dimension(ix,jx,nsoil), intent(out) :: out_smc,out_sh2ox + + real,dimension(global_nX, global_ny,nsoil):: g_smc, g_sh2ox + real,dimension(global_nX, global_ny):: g_smcmax + integer :: i,j,k + + + call write_IO_real(in_smcmax,g_smcmax) ! get global grid of smcmax + + write (*,*) "In deep GW...", nsoil + +!loop to overwrite soils to saturation... + do i=1,global_nx + do j=1,global_ny + g_smc(i,j,1:NSOIL) = g_smcmax(i,j) + g_sh2ox(i,j,1:NSOIL) = g_smcmax(i,j) + end do + end do + +!decompose global grid to parallel tiles... + do k=1,nsoil + call decompose_data_real(g_smc(:,:,k),out_smc(:,:,k)) + call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k)) + end do + + return + end subroutine MPP_DEEPGW_HRLDAS + +#endif + + SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & + route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC) + + +#include + INTEGER, INTENT(IN) :: IXRT,JXRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT +!Dummy inverted grids + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC + + INTEGER :: I,J, iret, jj + CHARACTER(len=256) :: var_name + CHARACTER(len=256) :: route_topo_f + CHARACTER(len=256) :: route_chan_f + CHARACTER(len=256) :: geo_finegrid_flnm + + var_name = "TOPOGRAPHY" + + call readRT2d_real(var_name,ELRT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) +#ifdef HYDRO_D + write(6,*) "read ",var_name +#endif + +!!!DY to be fixed ... 6/27/08 +! var_name = "BED_ELEVATION" +! iret = get2d_real(var_name,ELRT,ixrt,jxrt,& +! trim(geo_finegrid_flnm)) + + var_name = "CHANNELGRID" + call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + +#ifdef HYDRO_D + write(6,*) "read ",var_name +#endif + + var_name = "LKSATFAC" + LKSATFAC = -9999.9 + call readRT2d_real(var_name,LKSATFAC,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + +#ifdef HYDRO_D + write(6,*) "read ",var_name +#endif + + where (LKSATFAC == -9999.9) LKSATFAC = 1000.0 !specify LKSAFAC if no term avail... + + +!1.12.2012...Read in routing calibration factors... + var_name = "RETDEPRTFAC" + call readRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists + + var_name = "OVROUGHRTFAC" + call readRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists + + +#ifdef HYDRO_D + write(6,*) "finish READ_ROUTING_seq" +#endif + + return + +!DJG ----------------------------------------------------- + END SUBROUTINE READ_ROUTING_seq +!DJG _____________________________ + subroutine output_lsm(outFile,did) + + + implicit none + + integer did + + character(len=*) outFile + + integer :: ncid,irt, dimid_ix, dimid_jx, & + dimid_ixrt, dimid_jxrt, varid, & + dimid_links, dimid_basns, dimid_soil + integer :: iret + + + +#ifdef MPP_LAND + if(IO_id.eq.my_id) & +#endif + +#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT + iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#else + iret = nf_create(trim(outFile), NF_CLOBBER, ncid) +#endif + +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + +#ifdef HYDRO_D + if (iret /= 0) then + print*, "Problem nf_create" + call hydro_stop("output_lsm") + endif +#endif + + +#ifdef MPP_LAND + if(IO_id.eq.my_id) then +#endif +#ifdef HYDRO_D + write(6,*) "output file ", outFile +#endif +! define dimension for variables + iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil) !-- 3-d soils + +#ifdef MPP_LAND + iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx) +#else + iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx) +#endif + +!define variables + iret = nf_def_var(ncid,"stc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) + iret = nf_def_var(ncid,"smc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) + iret = nf_def_var(ncid,"sh2ox",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) + iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + + iret = nf_enddef(ncid) + +#ifdef MPP_LAND + endif +#endif + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SFCHEADRT,"sfcheadrt" ) + + +#ifdef MPP_LAND + if(IO_id.eq.my_id) then +#endif + + iret = nf_close(ncid) +#ifdef HYDRO_D + write(6,*) "finish writing outFile : ", outFile +#endif + +#ifdef MPP_LAND + endif +#endif + + return + end subroutine output_lsm + + + subroutine RESTART_OUT_nc(outFile,did) + + + implicit none + + integer did + + character(len=*) outFile + + integer :: ncid,irt, dimid_ix, dimid_jx, & + dimid_ixrt, dimid_jxrt, varid, & + dimid_links, dimid_basns, dimid_soil, dimid_lakes + integer :: iret + + +#ifdef MPP_LAND + if(IO_id.eq.my_id) & +#endif + +#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT + iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) +#else + iret = nf_create(trim(outFile), NF_CLOBBER, ncid) +#endif + + +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + +#ifdef HYDRO_D + if (iret /= 0) then + print*, "Problem nf_create" + call hydro_stop("RESTART_OUT_nc") + endif +#endif + +#ifdef MPP_LAND + if(IO_id.eq.my_id) then +#endif +! define dimension for variables + iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil) !-- 3-d soils + +#ifdef MPP_LAND + iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx) + iret = nf_def_dim(ncid, "ixrt", global_rt_nx , dimid_ixrt) !-- make a decimated grid + iret = nf_def_dim(ncid, "iyrt", global_rt_ny, dimid_jxrt) +#else + iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix) !-- make a decimated grid + iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx) + iret = nf_def_dim(ncid, "ixrt", rt_domain(did)%ixrt , dimid_ixrt) !-- make a decimated grid + iret = nf_def_dim(ncid, "iyrt", rt_domain(did)%jxrt, dimid_jxrt) +#endif + + iret = nf_def_dim(ncid, "links", rt_domain(did)%gnlinks, dimid_links) + if(rt_domain(did)%nlakes .gt. 0) then + iret = nf_def_dim(ncid, "lakes", rt_domain(did)%nlakes, dimid_lakes) + endif + iret = nf_def_dim(ncid, "basns", rt_domain(did)%numbasns, dimid_basns) + +!define variables + iret = nf_def_var(ncid,"stc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) + iret = nf_def_var(ncid,"smc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) + iret = nf_def_var(ncid,"sh2ox",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) + + iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"soldrain",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + + if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then + iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + iret = nf_def_var(ncid,"infxswgt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + iret = nf_def_var(ncid,"SFCHEADSUBRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + iret = nf_def_var(ncid,"sh2owgt",NF_FLOAT,3,(/dimid_ixrt,dimid_jxrt,dimid_soil/),varid) + iret = nf_def_var(ncid,"qstrmvolrt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + iret = nf_def_var(ncid,"RETDEPRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + + + + + + + if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then + iret = nf_def_var(ncid,"hlink",NF_FLOAT,1,(/dimid_links/),varid) + iret = nf_def_var(ncid,"qlink1",NF_FLOAT,1,(/dimid_links/),varid) + iret = nf_def_var(ncid,"qlink2",NF_FLOAT,1,(/dimid_links/),varid) + iret = nf_def_var(ncid,"cvol",NF_FLOAT,1,(/dimid_links/),varid) + if(rt_domain(did)%nlakes .gt. 0) then + iret = nf_def_var(ncid,"resht",NF_FLOAT,1,(/dimid_lakes/),varid) + iret = nf_def_var(ncid,"qlakeo",NF_FLOAT,1,(/dimid_lakes/),varid) + endif + iret = nf_def_var(ncid,"lake_inflort",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + end if + if(nlst_rt(did)%GWBASESWCRT.EQ.1) then + iret = nf_def_var(ncid,"z_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) +!yw test bucket model +! iret = nf_def_var(ncid,"gwbas_pix_ct",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"gw_buck_exp",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"z_max",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"gw_buck_coeff",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"qin_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"qinflowbase",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) +! iret = nf_def_var(ncid,"qout_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) + end if + end if + +! put global attribute + iret = nf_put_att_int(ncid,NF_GLOBAL,"his_out_counts",NF_INT, 1,rt_domain(did)%his_out_counts) + iret = nf_put_att_text(ncid,NF_GLOBAL,"Restart_Time",19,nlst_rt(did)%olddate(1:19)) + iret = nf_put_att_text(ncid,NF_GLOBAL,"Since_Date",19,nlst_rt(did)%sincedate(1:19)) + iret = nf_put_att_real(ncid,NF_GLOBAL,"DTCT",NF_REAL, 1,nlst_rt(did)%DTCT) + iret = nf_enddef(ncid) + +#ifdef MPP_LAND + endif +#endif + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") + call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") + + + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt" ) + + + if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT, "QBDRYRT" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT, "infxswgt" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT, "SFCHEADSUBRT" ) + call w_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT, "sh2owgt" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT, "qstrmvolrt" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT, "RETDEPRT" ) + +!yw test + + +!yw test + + + if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then + call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%HLINK,"hlink" & +#ifdef MPP_LAND + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & +#endif + ) + + call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,1),"qlink1" & +#ifdef MPP_LAND + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & +#endif + ) + + + call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,2),"qlink2" & +#ifdef MPP_LAND + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & +#endif + ) + + + call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%cvol,"cvol" & +#ifdef MPP_LAND + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & +#endif + ) + +! call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%resht,"resht" & +!#ifdef MPP_LAND +! ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & +!#endif +! ) + + call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%resht,"resht" & +#ifdef MPP_LAND + ,rt_domain(did)%lake_index & +#endif + ) + + call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakeo,"qlakeo" & +#ifdef MPP_LAND + ,rt_domain(did)%lake_index & +#endif + ) + + + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort") + + end if + + if(nlst_rt(did)%GWBASESWCRT.EQ.1) then + call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,"z_gwsubbas" ) +!yw test bucket model +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gwbas_pix_ct,"gwbas_pix_ct" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_exp,"gw_buck_exp" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_max,"z_max" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_coeff,"gw_buck_coeff" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,"qin_gwsubbas" ) +! call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%qinflowbase,"qinflowbase") +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,"qout_gwsubbas" ) + end if + end if + +#ifdef MPP_LAND + if(IO_id.eq.my_id) & +#endif + iret = nf_close(ncid) + + return + end subroutine RESTART_OUT_nc + + subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName) + implicit none + integer:: ncid,ix,jx,varid , iret + character(len=*) varName + real, dimension(ix,jx):: inVar +#ifdef MPP_LAND + real, dimension(global_rt_nx, global_rt_ny):: varTmp + call write_IO_rt_real(inVar,varTmp) + if(my_id .eq. IO_id) then + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_rt_nx,global_rt_ny/),varTmp) + endif +#else + iret = nf_inq_varid(ncid,varName, varid) + if(iret .eq. 0) then + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),inVar) + else + write(6,*) "Error : variable not defined in rst file before write: ", varName + endif +#endif + + return + end subroutine w_rst_rt_nc2 + + subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName) + implicit none + integer:: ncid,ix,jx,varid , iret, nsoil + character(len=*) varName + real,dimension(ix,jx,nsoil):: inVar +#ifdef MPP_LAND + integer k + real varTmp(global_rt_nx,global_rt_ny,nsoil) + do k = 1, nsoil + call write_IO_rt_real(inVar(:,:,k),varTmp(:,:,k)) + end do + if(my_id .eq. IO_id) then + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/global_rt_nx,global_rt_ny,nsoil/),varTmp) + endif +#else + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ix,jx,nsoil/),inVar) +#endif + return + end subroutine w_rst_rt_nc3 + + subroutine w_rst_nc2(ncid,ix,jx,inVar,varName) + implicit none + integer:: ncid,ix,jx,varid , iret + character(len=*) varName + real inVar(ix,jx) + +#ifdef MPP_LAND + real varTmp(global_nx,global_ny) + call write_IO_real(inVar,varTmp) + if(my_id .eq. IO_id) then + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_nx,global_ny/),varTmp) + endif +#else + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),invar) +#endif + + return + end subroutine w_rst_nc2 + + subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName) + implicit none + integer:: ncid,ix,jx,varid , iret, nsoil + character(len=*) varName + real inVar(ix,jx,nsoil) + integer k +#ifdef MPP_LAND + real varTmp(global_nx,global_ny,nsoil) + do k = 1, nsoil + call write_IO_real(inVar(:,:,k),varTmp(:,:,k)) + end do + if(my_id .eq. IO_id) then + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/global_nx,global_ny,nsoil/),varTmp) + endif +#else + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ix,jx,nsoil/),inVar) +#endif + return + end subroutine w_rst_nc3 + + subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName & +#ifdef MPP_LAND + ,nodelist & +#endif + ) + implicit none + integer:: ncid,n,varid , iret + character(len=*) varName + real inVar(n) +#ifdef MPP_LAND + integer:: nodelist(n) + if(n .eq. 0) return + + call write_lake_real(inVar,nodelist,n) + if(my_id .eq. IO_id) then +#endif + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) +#ifdef MPP_LAND + endif +#endif + return + end subroutine w_rst_crt_nc1_lake + + subroutine w_rst_crt_nc1(ncid,n,inVar,varName & +#ifdef MPP_LAND + ,map_l2g, gnlinks& +#endif + ) + implicit none + integer:: ncid,n,varid , iret + character(len=*) varName + real inVar(n) +#ifdef MPP_LAND + integer:: gnlinks, map_l2g(n) + real g_var(gnlinks) + call write_chanel_real(inVar,map_l2g,gnlinks,n,g_var) + if(my_id .eq. IO_id) then + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/gnlinks/),g_var) +#else + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) +#endif +#ifdef MPP_LAND + endif +#endif + return + end subroutine w_rst_crt_nc1 + + subroutine w_rst_crt_nc1g(ncid,n,inVar,varName) + implicit none + integer:: ncid,n,varid , iret + character(len=*) varName + real inVar(n) +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) +#ifdef MPP_LAND + endif +#endif + return + end subroutine w_rst_crt_nc1g + + subroutine RESTART_IN_NC(inFile,did) + + + implicit none + character(len=*) inFile + integer :: ierr, iret,ncid, did + + integer :: i, j + + +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif +!open a netcdf file + iret = nf_open(trim(inFile), NF_NOWRITE, ncid) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + write(*,'("Problem opening file: ''", A, "''")') & + trim(inFile) + call hydro_stop("RESTART_IN_NC") +#endif + endif + +#ifdef MPP_LAND + if(IO_id .eq. my_id) then +#endif + iret = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'his_out_counts', rt_domain(did)%his_out_counts) + iret = NF_GET_ATT_REAL(ncid, NF_GLOBAL, 'DTCT', nlst_rt(did)%DTCT) + iret = nf_get_att_text(ncid,NF_GLOBAL,"Since_Date",nlst_rt(did)%sincedate(1:19)) + if(iret /= 0) nlst_rt(did)%sincedate = nlst_rt(did)%startdate + if(nlst_rt(did)%DTCT .gt. 0) then + nlst_rt(did)%DTCT = min(nlst_rt(did)%DTCT, nlst_rt(did)%DTRT) + else + nlst_rt(did)%DTCT = nlst_rt(did)%DTRT + endif +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(rt_domain(did)%out_counts) + call mpp_land_bcast_real1(nlst_rt(did)%DTCT) +#endif + +#ifdef HYDRO_D + write(6,*) "nlst_rt(did)%nsoil=",nlst_rt(did)%nsoil +#endif + + if(nlst_rt(did)%rst_typ .eq. 1 ) then + call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") + call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") + call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt") + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt") + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain") + endif + + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1") + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1") + + + if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT,"infxswgt") + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT,"SFCHEADSUBRT") + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT,"QBDRYRT") + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT,"qstrmvolrt") + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT,"RETDEPRT") + call read_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT,"sh2owgt") + + + if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then + call read_rst_crt_stream_nc(ncid,rt_domain(did)%HLINK,rt_domain(did)%NLINKS,"hlink",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,1),rt_domain(did)%NLINKS,"qlink1",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,2),rt_domain(did)%NLINKS,"qlink2",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + call read_rst_crt_stream_nc(ncid,rt_domain(did)%CVOL,rt_domain(did)%NLINKS,"cvol",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + if(rt_domain(did)%NLAKES .gt. 0) then + call read_rst_crt_nc(ncid,rt_domain(did)%RESHT,rt_domain(did)%NLAKES,"resht") + call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEO,rt_domain(did)%NLAKES,"qlakeo") + endif + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort") + + end if + + if(nlst_rt(did)%GWBASESWCRT.EQ.1.AND.nlst_rt(did)%GW_RESTART.NE.0 .and. rt_domain(did)%numbasns .gt. 0) then + call read_rst_crt_nc(ncid,rt_domain(did)%z_gwsubbas,rt_domain(did)%numbasns,"z_gwsubbas") + end if + end if + + if(nlst_rt(did)%rstrt_swc.eq.1) then !Switch for rest of restart accum vars... +#ifdef HYDRO_D + print *, "1 Resetting RESTART Accumulation Variables to 0...",nlst_rt(did)%rstrt_swc +#endif + rt_domain(did)%INFXSRT=0. + rt_domain(did)%LAKE_INFLORT=0. + rt_domain(did)%QSTRMVOLRT=0. + end if + + +#ifdef MPP_LAND + if(my_id .eq. IO_id) & +#endif + iret = nf_close(ncid) +#ifdef HYDRO_D + write(6,*) "end of RESTART_IN" + flush(6) +#endif + + !call check_channel(81,rt_domain(did)%QLINK(:,1),1,rt_domain(did)%NLINKS) + !call check_channel(83,rt_domain(did)%QLINK(:,2),1,rt_domain(did)%NLINKS) + !call check_channel(84,rt_domain(did)%HLINK,1,rt_domain(did)%NLINKS) + !call check_channel(85,rt_domain(did)%CVOL,1,rt_domain(did)%NLINKS) + !call hydro_stop("666666666666") + + return + end subroutine RESTART_IN_nc + + subroutine read_rst_nc3(ncid,ix,jx,NSOIL,var,varStr) + implicit none + integer :: ix,jx,nsoil, ireg, ncid, varid, iret + real,dimension(ix,jx,nsoil) :: var + character(len=*) :: varStr +#ifdef MPP_LAND + real,dimension(global_nx,global_ny,nsoil) :: xtmp + integer i + + if(my_id .eq. IO_id) & +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) & + iret = nf_get_var_real(ncid, varid, xtmp) + + do i = 1, nsoil + call decompose_data_real(xtmp(:,:,i), var(:,:,i)) + end do +#else + iret = nf_get_var_real(ncid, varid, var) +#endif + + return + end subroutine read_rst_nc3 + + subroutine read_rst_nc2(ncid,ix,jx,var,varStr) + implicit none + integer :: ix,jx,ireg, ncid, varid, iret + real,dimension(ix,jx) :: var + character(len=*) :: varStr +#ifdef MPP_LAND + real,dimension(global_nx,global_ny) :: xtmp + if(my_id .eq. IO_id) & +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) + +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) & + iret = nf_get_var_real(ncid, varid, xtmp) + + call decompose_data_real(xtmp, var) +#else + var = 0.0 + iret = nf_get_var_real(ncid, varid, var) +#endif + return + end subroutine read_rst_nc2 + + subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr) + implicit none + integer :: ix,jx,nsoil, ireg, ncid, varid, iret + real,dimension(ix,jx,nsoil) :: var + character(len=*) :: varStr +#ifdef MPP_LAND + real,dimension(global_rt_nx,global_rt_ny,nsoil) :: xtmp + integer i + if(my_id .eq. IO_id) & +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + iret = nf_get_var_real(ncid, varid, xtmp) + do i = 1, nsoil + call decompose_RT_real(xtmp(:,:,i),var(:,:,i),global_rt_nx,global_rt_ny,ix,jx) + end do +#else + iret = nf_get_var_real(ncid, varid, var) +#endif + return + end subroutine read_rst_rt_nc3 + + subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr) + implicit none + integer :: ix,jx,ireg, ncid, varid, iret + real,dimension(ix,jx) :: var + character(len=*) :: varStr +#ifdef MPP_LAND + real,dimension(global_rt_nx,global_rt_ny) :: xtmp +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) & + iret = nf_get_var_real(ncid, varid, xtmp) + call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx) +#else + iret = nf_get_var_real(ncid, varid, var) +#endif + return + end subroutine read_rst_rt_nc2 + + subroutine read_rt_nc2(ncid,ix,jx,var,varStr) + implicit none + integer :: ix,jx, ncid, varid, iret + real,dimension(ix,jx) :: var + character(len=*) :: varStr + +#ifdef MPP_LAND + real,dimension(global_rt_nx,global_rt_ny) :: xtmp + xtmp = 0.0 +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) then + iret = nf_get_var_real(ncid, varid, xtmp) + endif + call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx) +#else + iret = nf_get_var_real(ncid, varid, var) +#endif + return + end subroutine read_rt_nc2 + + subroutine read_rst_crt_nc(ncid,var,n,varStr) + implicit none + integer :: ireg, ncid, varid, n, iret + real,dimension(n) :: var + character(len=*) :: varStr + + if( n .le. 0) return +#ifdef MPP_LAND + if(my_id .eq. IO_id) & +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + iret = nf_get_var_real(ncid, varid, var) +#ifdef MPP_LAND + endif + call mpp_land_bcast_real(n,var) +#endif + return + end subroutine read_rst_crt_nc + + subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g) + implicit none + integer :: ncid, varid, n, iret, gnlinks + integer, intent(in), dimension(:) :: map_l2g + character(len=*) :: varStr + integer :: l, g + real,intent(out) , dimension(:) :: var_out +#ifdef MPP_LAND + real,dimension(gnlinks) :: var +#else + real,dimension(n) :: var +#endif + + +#ifdef MPP_LAND + if(my_id .eq. IO_id) & +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + var = 0.0 + iret = nf_get_var_real(ncid, varid, var) +#ifdef MPP_LAND + endif + call mpp_land_bcast_real(gnlinks,var) + + if(n .le. 0) return + var_out = 0 + + do l = 1, n + g = map_l2g(l) + var_out(l) = var(g) + end do +#else + var_out = var +#endif + return + end subroutine read_rst_crt_stream_nc + + subroutine hrldas_out() + end subroutine hrldas_out + + SUBROUTINE READ_ROUTING_old(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & + route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC) + + +#include + INTEGER, INTENT(IN) :: IXRT,JXRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT +!Dummy inverted grids + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC + + INTEGER :: I,J, iret, jj + CHARACTER(len=256) :: var_name + CHARACTER(len=256) :: route_topo_f + CHARACTER(len=256) :: route_chan_f + CHARACTER(len=256) :: geo_finegrid_flnm + + var_name = "TOPOGRAPHY" + call readRT2d_real(var_name,ELRT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) +#ifdef HYDRO_D + write(6,*) "read ",var_name +#endif + +!!!DY to be fixed ... 6/27/08 +! var_name = "BED_ELEVATION" +! iret = get2d_real(var_name,ELRT,ixrt,jxrt,& +! trim(geo_finegrid_flnm)) + + var_name = "CHANNELGRID" + call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + +#ifdef HYDRO_D + write(6,*) "read ",var_name +#endif + + var_name = "LKSATFAC" + LKSATFAC = -9999.9 + call readRT2d_real(var_name,LKSATFAC,ixrt,jxrt,& + trim(geo_finegrid_flnm)) +#ifdef HYDRO_D + write(6,*) "read ",var_name +#endif + + where (LKSATFAC == -9999.9) LKSATFAC = 1000.0 !specify LKSAFAC if no term avail... + + +!1.12.2012...Read in routing calibration factors... + var_name = "RETDEPRTFAC" + call readRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists + + var_name = "OVROUGHRTFAC" + call readRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,& + trim(geo_finegrid_flnm)) + where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists + + +#ifdef HYDRO_D + write(6,*) "finish READ_ROUTING_old" +#endif + + return + +!DJG ----------------------------------------------------- + END SUBROUTINE READ_ROUTING_old +!DJG _____________________________ + + +#ifdef MPP_LAND + + SUBROUTINE MPP_READ_CHROUTING(did,IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & + FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, & + NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, & + HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & + ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, & + route_link_f, & + route_lake_f, route_direction_f, route_order_f, & + CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, & + CHANXI, CHANYJ, CHLAT, CHLON, & + channel_option,LATVAL,LONVAL, & + STRMFRXSTPTS,geo_finegrid_flnm,Link_Location) + use module_mpp_land, only: my_id, io_id +#include + INTEGER, INTENT(IN) :: IXRT,JXRT, did + INTEGER :: CHANRTSWCRT, NLINKS, NLAKES + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT + INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION + INTEGER, DIMENSION(IXRT,JXRT) :: GSTRMFRXSTPTS + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + INTEGER, DIMENSION(IXRT,JXRT) :: GORDER !-- gridded stream orderk + INTEGER, DIMENSION(IXRT,JXRT) :: Link_Location !-- gridded stream orderk + INTEGER :: I,J,channel_option + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LATVAL, LONVAL + CHARACTER(len=28) :: dir +!Dummy inverted grids from arc + + +!----DJG,DNY New variables for channel and lake routing + CHARACTER(len=155) :: header + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: FROM_NODE + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ZELEV + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHLAT,CHLON + + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TYPEL + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TO_NODE,ORDER + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: STRMFRXSTPTS + + INTEGER, INTENT(INOUT) :: MAXORDER + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum + REAL, INTENT(INOUT), DIMENSION(NLINKS,2) :: QLINK !channel flow + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHANLEN !channel length + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MannN, So !mannings N + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: LAKENODE ! identifies which nodes pour into which lakes + REAL, INTENT(IN) :: dist(ixrt,jxrt,9) + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK + REAL, DIMENSION(IXRT,JXRT) :: ChSSlpG,BwG,MannNG !channel properties on Grid + + +!-- store the location x,y location of the channel element + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ + +!--reservoir/lake attributes + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: HRZAREA + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: LAKEMAXH + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: WEIRC + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: WEIRL + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEC + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEA + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEE + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: LATLAKE,LONLAKE,ELEVLAKE + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ChSSlp, Bw + + CHARACTER(len=256) :: route_link_f + CHARACTER(len=256) :: route_lake_f + CHARACTER(len=256) :: route_direction_f + CHARACTER(len=256) :: route_order_f + CHARACTER(len=256) :: geo_finegrid_flnm + CHARACTER(len=256) :: var_name + + INTEGER :: tmp, cnt, ncid, iret, jj,ct + real :: gc,n + +!--------------------------------------------------------- +! End Declarations +!--------------------------------------------------------- + MAXORDER = -9999 +!initialize GSTRM + GSTRMFRXSTPTS = -9999 + +!yw initialize the array. + to_node = MAXORDER + from_node = MAXORDER + Link_location = MAXORDER + +#ifdef HYDRO_D + print *, "reading routing initialization files..." + print *, "route direction", route_direction_f + print *, "route order", route_order_f + print *, "route linke",route_link_f + print *, "route lake",route_lake_f +#endif + +!DJG Edited code here to retrieve data from hires netcdf file.... + + IF((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then + + var_name = "LATITUDE" +#ifdef MPP_LAND + call mpp_readRT2d_real (did, & +#else + call readRT2d_real ( & +#endif + var_name,LATVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) + + + var_name = "LONGITUDE" +#ifdef MPP_LAND + call mpp_readRT2d_real(did, & +#else + call readRT2d_real( & +#endif + var_name,LONVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) + + END IF + + + IF(CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2) then +!DJG change filename to LAKEPARM.TBL open(unit=79,file=trim(route_link_f), & +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + open(unit=79,file='LAKEPARM.TBL', & + form='formatted',status='old') +#ifdef MPP_LAND + endif +#endif + END IF + + + var_name = "LAKEGRID" +#ifdef MPP_LAND + call mpp_readRT2d_int(did,& +#else + call readRT2d_int(& +#endif + var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm)) + + var_name = "FLOWDIRECTION" +#ifdef MPP_LAND + call mpp_readRT2d_int(did, & +#else + call readRT2d_int(& +#endif + var_name,DIRECTION,ixrt,jxrt,trim(geo_finegrid_flnm)) + + var_name = "STREAMORDER" +#ifdef MPP_LAND + call mpp_readRT2d_int(did,& +#else + call readRT2d_int(& +#endif + var_name,GORDER,ixrt,jxrt,trim(geo_finegrid_flnm)) + + + var_name = "frxst_pts" +#ifdef MPP_LAND + call mpp_readRT2d_int(did,& +#else + call readRT2d_int(& +#endif + var_name,GSTRMFRXSTPTS,ixrt,jxrt,trim(geo_finegrid_flnm)) + +!!!Flip y-dimension of highres grids from exported Arc files... + + + ct = 0 + +#ifdef HYDRO_D + print *, "Number of frxst pts: ",ct +#endif + + +! temp fix for buggy Arc export... + do j=1,jxrt + do i=1,ixrt + if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 + end do + end do + + cnt =0 + if ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option .ne. 3) then ! not routing on grid, read from file + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + read(79,*) header +#ifdef MPP_LAND + endif +#endif + call hydro_stop("Possible Error for this code") + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + do i=1,NLINKS + read (79,*) tmp, FROM_NODE(i), TO_NODE(i), TYPEL(i),& + ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), & + MannN(i), So(i), ChSSlp(i), Bw(i), HRZAREA(i),& + LAKEMAXH(i), WEIRC(i), WEIRL(i), ORIFICEC(i), & + ORIFICEA(i),ORIFICEE(i) + + !-- hardwire QLINK + QLINK(i,1) = 1.0 + QLINK(i,2) = QLINK(i,1) + + if (So(i).lt.0.005) So(i) = 0.005 !-- impose a minimum slope requireement + + if (ORDER(i) .gt. MAXORDER) then + MAXORDER = ORDER(i) + endif + + end do +#ifdef MPP_LAND + endif + call mpp_land_bcast_int(NLINKS,FROM_NODE) + call mpp_land_bcast_int(NLINKS,TO_NODE) + call mpp_land_bcast_int(NLINKS,TYPEL ) + call mpp_land_bcast_int(NLINKS,ORDER ) + call mpp_land_bcast_real(NLINKS,QLINK ) + call mpp_land_bcast_real(NLINKS,MUSK ) + call mpp_land_bcast_real(NLINKS,MUSX ) + call mpp_land_bcast_real(NLINKS,CHANLEN) + call mpp_land_bcast_real(NLINKS,MannN ) + call mpp_land_bcast_real(NLINKS,So ) + call mpp_land_bcast_real(NLINKS,ChSSlp ) + call mpp_land_bcast_real(NLINKS,Bw ) + call mpp_land_bcast_real(NLINKS,HRZAREA) + call mpp_land_bcast_real(NLINKS,LAKEMAXH) + call mpp_land_bcast_real(NLINKS,WEIRC ) + call mpp_land_bcast_real(NLINKS,WEIRL ) + call mpp_land_bcast_real(NLINKS,ORIFICEC) + call mpp_land_bcast_real(NLINKS,ORIFICEA) + call mpp_land_bcast_real(NLINKS,ORIFICEE) + call mpp_land_bcast_int1(MAXORDER) + +#endif + + elseif ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then !-- handle setting up topology on the grid for diffusion scheme + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + read(79,*) header !-- read the lake file +#ifdef HYDRO_D + write(*,*) "output message: reading lake file ", header + write(6,*) "output message: error check read file ",route_link_f +#endif +#ifdef MPP_LAND + endif +#endif + + + if (NLAKES.gt.0) then !read in only if there are lakes + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + + do i=1, NLAKES + read (79,*) tmp, HRZAREA(i),LAKEMAXH(i), & + WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),& + LATLAKE(i), LONLAKE(i),ELEVLAKE(i) +#ifdef HYDRO_D + write (*,*) tmp, HRZAREA(i),LAKEMAXH(i), LATLAKE(i), LONLAKE(i),ELEVLAKE(i),NLAKES +#endif + enddo + +#ifdef MPP_LAND + endif + call mpp_land_bcast_real(NLAKES,HRZAREA) + call mpp_land_bcast_real(NLAKES,LAKEMAXH) + call mpp_land_bcast_real(NLAKES,WEIRC ) + call mpp_land_bcast_real(NLAKES,WEIRL ) + call mpp_land_bcast_real(NLAKES,ORIFICEC) + call mpp_land_bcast_real(NLAKES,ORIFICEA) + call mpp_land_bcast_real(NLAKES,ORIFICEE) + call mpp_land_bcast_real(NLAKES,LATLAKE ) + call mpp_land_bcast_real(NLAKES,LONLAKE ) + call mpp_land_bcast_real(NLAKES,ELEVLAKE) +#endif + + end if !end if for NLAKES >0 check + + cnt = 0 + + + BwG = 0.0 + ChSSlpG = 0.0 + MannNG = 0.0 + TYPEL = 0 + MannN = 0.0 + Bw = 0.0 + ChSSlp = 0.0 + +!DJG inv DO j = JXRT,1,-1 !rows + DO j = 1,JXRT !rows + DO i = 1 ,IXRT !colsumns + If (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order + If ((DIRECTION(i, j) .EQ. 64) .AND. (j + 1 .LE. JXRT) .AND. & + (CH_NETRT(i,j+1).ge.0) ) then !North + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i, j + 1) + CHANLEN(cnt) = dist(i,j,1) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1).ge.0) ) then !North East + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1) + CHANLEN(cnt) = dist(i,j,2) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT) & + .AND. (CH_NETRT(i+1,j).ge.0) ) then !East + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j) + CHANLEN(cnt) = dist(i,j,3) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & + .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i+1,j-1).ge.0) ) then !south east + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1) + CHANLEN(cnt) = dist(i,j,4) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0) ) then !due south + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i, j - 1) + CHANLEN(cnt) = dist(i,j,5) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & + .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i-1,j-1).ge.0)) then !south west + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i,j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1) + CHANLEN(cnt) = dist(i,j,6) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0) ) then !West + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j) + CHANLEN(cnt) = dist(i,j,7) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0) ) then !North West + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1) + CHANLEN(cnt) = dist(i,j,8) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else +#ifdef HYDRO_D + print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east +#endif + End If + + End If !CH_NETRT check for this node + + END DO + END DO + +#ifdef HYDRO_D + print *, "after exiting the channel, this many nodes", cnt + write(*,*) " " +#endif + +!Find out if the boundaries are on an edge +!DJG inv DO j = JXRT,1,-1 + DO j = 1,JXRT + DO i = 1 ,IXRT + If (CH_NETRT(i, j) .ge. 0) then !get its direction + +!#ifdef MPP_LAND +! If (((DIRECTION(i, j).EQ. 64) .AND. ((j + 1 .GT. JXRT) .and. (up_id < 0)) ) .OR. & !-- 64's can only flow north +! ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North +!#else + If (((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) .OR. & !-- 64's can only flow north + ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North +!#endif + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(j+1 .GT. JXRT) then !-- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i,j+1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i,j+1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,1) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + +!#ifdef MPP_LAND +! else if ( ((DIRECTION(i, j) .EQ. 128) .AND. ((i + 1 .GT. IXRT) .and. (right_id < 0)) ) & !-- 128's can flow out of the North or East edge +! .OR. ((DIRECTION(i, j) .EQ. 128) .AND. ((j + 1 .GT. JXRT) .and. (up_id < 0)) ) & ! this is due north edge +! .OR. ((DIRECTION(i, j) .EQ. 128) .AND. (i1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if((i+1 .GT. IXRT) .OR. (j-1 .EQ. 0)) then !an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i+1,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,4) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + +!#ifdef MPP_LAND +! else if (((DIRECTION(i, j) .EQ. 4) .AND. ((j - 1 .EQ. 0) .and. (down_id <0)) ) .OR. & !-- 4's can only flow due south +! ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south +!#else + else if (((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) .OR. & !-- 4's can only flow due south + ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south +!#endif + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(j-1 .EQ. 0) then !- an edge + TYPEL(cnt) =1 + elseif(LAKE_MSKRT(i,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,5) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + +!#ifdef MPP_LAND +! else if ( ((DIRECTION(i, j) .EQ. 8) .AND. ((i - 1 .LE. 0).and.(left_id <0))) & !-- 8's can flow south or west +! .OR. ((DIRECTION(i, j) .EQ. 8) .AND.( (j - 1 .EQ. 0) .and. (down_id <0)) ) & !-- this is the south edge +! .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west +!#else + else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west + .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge + .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west +!#endif + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if( (i-1 .EQ. 0) .OR. (j-1 .EQ. 0) ) then !- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i-1,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,6) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif +!#ifdef MPP_LAND +! else if (((DIRECTION(i, j) .EQ. 16) .AND. ((i - 1 .LE.0) .and. (left_id <0)) ) & !16's can only flow due west +!#else + else if (((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE.0) ) & !16's can only flow due west +!#endif + .OR.((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(i-1 .EQ. 0) then !-- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i-1,j).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i-1,j) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,7) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + +!#ifdef MPP_LAND +! else if ( ((DIRECTION(i, j) .EQ. 32) .AND. ((i - 1 .LE. 0) .and. (left_id <0)) ) & !-- 32's can flow either west or north +! .OR. ((DIRECTION(i, j) .EQ. 32) .AND. ((j + 1 .GT. JXRT) .and. (up_id <0)) ) & !-- this is the north edge +!#else + else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north + .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge +!#endif + .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j + INTEGER :: I,J,channel_option,iret,jj, did + INTEGER, INTENT(OUT) :: NLINKS + INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id + + INTEGER, INTENT(IN) :: IXRT,JXRT + INTEGER :: CHNID,cnt + INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask + INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction + INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + REAL, DIMENSION(IXRT,JXRT) :: LAT, LON + +!!Dummy read in grids for inverted y-axis + + + CHARACTER(len=*) :: route_chan_f, route_link_f,route_direction_f,route_lake_f + CHARACTER(len=256) :: InputLine + CHARACTER(len=256) :: geo_finegrid_flnm + CHARACTER(len=256) :: var_name +! external get2d_real +! integer :: get2d_real + + NLINKS = 0 + CH_NETRT = -9999 + CH_NETLNK = -9999 + + + cnt = 0 +#ifdef HYDRO_D + print *, "Channel Option in Routedim is ", channel_option +#endif + + IF(channel_option.eq.3) then !get maxnodes and links from grid + + var_name = "CHANNELGRID" +#ifdef MPP_LAND + call mpp_readRT2d_int(did,& +#else + call readRT2d_int(& +#endif + var_name,CH_NETRT,ixrt,jxrt, trim(geo_finegrid_flnm)) + + + var_name = "FLOWDIRECTION" +#ifdef MPP_LAND + call mpp_readRT2d_int(did, & +#else + call readRT2d_int( & +#endif + var_name,DIRECTION,ixrt,jxrt, trim(geo_finegrid_flnm)) + + var_name = "LAKEGRID" +#ifdef MPP_LAND + call mpp_readRT2d_int(did, & +#else + call readRT2d_int( & +#endif + var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm)) + + + var_name = "LATITUDE" +#ifdef MPP_LAND + call mpp_readRT2d_real(did, & +#else + call readRT2d_real( & +#endif + var_name,LAT,ixrt,jxrt,trim(geo_finegrid_flnm)) + + + var_name = "LONGITUDE" +#ifdef MPP_LAND + call mpp_readRT2d_real(did, & +#else + call readRT2d_real( & +#endif + var_name,LON,ixrt,jxrt,trim(geo_finegrid_flnm)) + +! temp fix for buggy Arc export... + do j=1,jxrt + do i=1,ixrt + if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 + end do + end do + +!DJG inv do j=jxrt,1,-1 + do j=1,jxrt + do i = 1, ixrt + if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then + NLINKS = NLINKS + 1 + endif + end do + end do +#ifdef HYDRO_D + print *, "NLINKS IS ", NLINKS +#endif + + +!DJG inv DO j = JXRT,1,-1 !rows + DO j = 1,JXRT !rows + DO i = 1 ,IXRT !colsumns + If (CH_NETRT(i, j) .ge. 0) then !get its direction + If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT).AND.(CH_NETRT(i,j+1) .ge.0) ) then !North + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1) .ge.0)) then !North East + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT).AND.(CH_NETRT(i+1,j) .ge. 0)) then !East + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & + .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i+1,j-1).ge.0)) then !south east + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0)) then !due south + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & + .AND. (j - 1 .NE. 0).AND. (CH_NETRT(i-1,j-1).ge.0) ) then !south west + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0)) then !West + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0)) then !North West + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else +#ifdef HYDRO_D + write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j +135 FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4) +#endif + if (DIRECTION(i,j) .eq. 0) then +#ifdef HYDRO_D + print *, "Direction i,j ",i,j," of point ", cnt, "is invalid" +#endif + endif + + End If + End If !CH_NETRT check for this node + END DO + END DO +#ifdef HYDRO_D + print *, "found type 0 nodes", cnt +#endif + +!Find out if the boundaries are on an edge or flow into a lake +!DJG inv DO j = JXRT,1,-1 + DO j = 1,JXRT + DO i = 1 ,IXRT + If (CH_NETRT(i, j) .ge. 0) then !get its direction + + If ( ((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) & !-- 64's can only flow north + .OR. ((DIRECTION(i, j) .EQ. 64).and. (j1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) & !-- 4's can only flow due south + .OR. ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west + .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge + .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE. 0)) & !-- 16's can only flow due west + .OR. ((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north + .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge + .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. jchannel coefficients" + print *, "nod, n, Cs, Bw", nod, n, Cs, Bw + call hydro_stop("in DIFFUSION") +#endif + endif + +! Sf = ((z1+h1)-(z2+h2))/dx !-- compute the friction slope + !if(z1 .eq. z2) then + ! Sf = ((z1-(z2-0.01))+(h1-h2))/dx !-- compute the friction slope + !else +! Sf = ((z1-z2)+(h1-h2))/dx !-- compute the friction slope + !endif + +!modifieed by Wei Yu for false geography data + if(abs(z1-z2) .gt. 1.0E5) then +#ifdef HYDRO_D + print*, "Warning: huge slope rest to 0 for channel grid.", z1,z2 +#endif + Sf = ((h1-h2))/dx !-- compute the friction slope + else + Sf = ((z1-z2)+(h1-h2))/dx !-- compute the friction slope + endif +!end modfication + + sgn = SGNf(Sf) !-- establish sign + + w = 0.5*(sgn + 1.) !-- compute upstream or downstream weighting + + z = 1/Cs !--channel side distance (m) + R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z**2)) !-- Hyd Radius + AREA = (Bw+z*h1)*h1 !-- Flow area + Ku = (1/n)*(R**(2./3.))*AREA !-- convenyance + + R = ((Bw+z*h2)*h2)/(Bw+2*h2*sqrt(1+z**2)) !-- Hyd Radius + AREA = (Bw+z*h2)*h2 !-- Flow area + Kd = (1/n)*(R**(2./3.))*AREA !-- convenyance + + Kf = (1-w)*Kd + w*Ku !-- conveyance + DIFFUSION = Kf * sqrt(abs(Sf))*sgn + + +100 format('z1,z2,h1,h2,kf,Dif, Sf, sgn ',f8.3,2x,f8.3,2x,f8.4,2x,f8.4,2x,f8.3,2x,f8.3,2x,f8.3,2x,f8.0) + + END FUNCTION DIFFUSION +! ---------------------------------------------------------------- + +! ------------------------------------------------ +! FUNCTION MUSKINGUM CUNGE +! ------------------------------------------------ + REAL FUNCTION MUSKINGCUNGE(index,qup, quc, qdp, ql,& + dt,So,dx,n,Cs,Bw) + IMPLICIT NONE + +!--local variables + REAL :: C1, C2, C3, C4 + REAL :: Km !K travel time in hrs in reach + REAL :: X !weighting factors 0<=X<=0.5 + REAL :: dt !routing period in seconds + REAL :: qup !flow upstream previous timestep + REAL :: quc !flow upstream current timestep + REAL :: qdp !flow downstream previous timestep + REAL :: ql !lateral inflow through reach (m^3/sec) + REAL :: Ck ! wave celerity (m/s) + REAL :: qp ! peak flow + +!-- channel geometry and characteristics + REAL :: Bw ! bottom width (meters) + REAL :: Cs ! Channel side slope slope + REAL :: So ! Channel bottom slope + REAL :: dx ! channel lngth (m) + REAL :: n ! mannings coefficient + REAL :: Tw ! top width at peak flow + REAL :: AREA ! Cross sectional area m^2 + REAL :: Z ! trapezoid distance (m) + REAL :: R ! Hydraulic radius + REAL :: WP ! wetted perimmeter + REAL :: h ! depth of flow + REAL :: Qj ! intermediate flow estimate + REAL :: D,D1 ! diffusion coeff + REAL :: dtr ! required timestep, minutes + REAL :: error,shapefn, sh1, sh2, sh3 + REAL :: hp !courant, previous height + INTEGER :: maxiter !maximum number of iterations + +!-- local variables.. needed if channel is sub-divded + REAL :: c,b + REAL :: dxlocal + INTEGER :: i,index !-- channel segment counter + INTEGER :: ChnSegments !-- number of channel sub-sections + + c = 0.2407 !-- coefficnets for finding dx/Ckdt + b = 1.16065 + + z = 1/Cs !channel side distance (m) + h = sqrt(quc+ql)*0.1 !-- assume a initial depth (m) + qp = quc + ql + + if (n.le.0.or.So.le.0.or.z.le.0.or.Bw.le.0) then +#ifdef HYDRO_D + print*, "error in channel coefficients -> Muskingum cunge" + call hydro_stop("in MUSKINGCUNGE") +#endif + end if + + error = 1.0 + maxiter = 0 + + if (quc .gt.0) then !--top of link must have some water in it + do while (error .gt. 0.01 .and. maxiter < 100) !-- first estimate depth at top of channel + maxiter = maxiter + 1 + !---trapezoidal channel shape function + shapefn = SHAPE(Bw,z,h) + Qj = FLOW(n,So,Bw,h,z) + h = h - (1-quc/Qj)/(shapefn) + error = abs((Qj - quc)/quc) + end do + endif + + maxiter = 0 +!------- approximate flow and depth at the bottom of the channel + if (ql .eq.0 .and. quc .eq. 0) then !-- no water to route + Qj=0.0 + else + error = 1.0 !--reset the error + Tw = Bw + 2*z*h !--top width of the channel inflow + Ck = (sqrt(So)/n)*(5/3)*h**0.667 !-- pg 287 Chow, Mdt, Mays + X = 0.5-(qp/(2*Tw*So*Ck*dx)) + if (X.le.0) then +#ifdef HYDRO_D + print *, "Muskingum weighting factor is less than 0" +#endif + endif + + if ( dx/(Ck*dt) .le. c*LOG(X)+b) then !-- Bedient and Huber pg. 296 + ChnSegments = 1 + dxlocal = dx + else + dxlocal = fnDX(qp,Tw,So, Ck,dx,dt) !-- find appropriate channel length + X = 0.5-(qp/(2*Tw*So*Ck*dxlocal)) + if(FRACTION(dx/dxlocal) .le. 0.5) then !-- round up + ChnSegments = NINT(dx/dxlocal) + 1 + else + ChnSegments = NINT(dx/dxlocal) + endif + dxlocal = dx/ChnSegments !-- compute segment length, which will + endif + + do i = 1, ChnSegments + error = 1.0 !--reset the error + + do while (error .gt. 0.01 .and. maxiter < 500) + + if (qp.gt.2*(2*Tw*So*Ck*dxlocal)) then +#ifdef HYDRO_D + print *, "ERROR IN Musking Cunge,X <0 ", X + print *, "X,Qp,Tw,So,Ck,Dxlocal",X,Qp,Tw,So,Ck,Dxlocal +#endif + endif + + Km = dxlocal/Ck !-- minutes,Muskingum Param + D = (Km*(1 - X) + dt/2) !-- minutes + C1 = (Km*X + dt/2)/D + C2 = (dt/2 - Km*X)/D + C3 = (Km*(1-X)-dt/2)/D + C4 = (ql/ChnSegments*dt)/D !-- lateral inflow is along each channel sub-section + + MUSKINGCUNGE = (C1*qup)+(C2*quc)+(C3*qdp)+C4 !-- pg 295 Bedient huber assume flows from previous + !--previous values same in each segment,a good assumption? + if (MUSKINGCUNGE .lt. 0) then !-- only outflow +#ifdef HYDRO_D + print *, "ERROR: musking cunge is negative" + print *, "D, C1+C2+C3,C4, MsCng",D,C1+C2+C3,C4,Muskingcunge + print *, "qup, quc, qdp, ql",qup,quc,qdp,ql,i,ChnSegments +#endif + Qj = 0.0 + error = 0.001 + else +!---trapezoidal channel shape function + shapefn = SHAPE(Bw,z,h) + Qj = FLOW(n,So,Bw,h,z) + h = h - (1-MUSKINGCUNGE/Qj)/(shapefn) + error = abs((Qj - MUSKINGCUNGE)/MUSKINGCUNGE) + if (h<0.00001) error=0.001 !--very small flow depths to route + Tw = Bw+2*z*h + hp=h + maxiter = maxiter + 1 + endif + enddo !-- while error condtion number of + if (ChnSegments .gt.1) then + quc = MUSKINGCUNGE !-- update condition for next channel length upstream + endif + enddo !-- number of channel segment loops + endif + + MUSKINGCUNGE = Qj + + if(index .eq. 1 .or. index .eq. 2 .or. index .eq. 6) then +#ifdef HYDRO_D + write(*,13) index, ql,quc,qup,Qj,qdp +#endif + endif + +10 format('Tw,h,Z, latflow,usf',f3.1,2x,f8.4,2x,f4.1,2x,f5.4,2x,f5.4) +11 format('h, Qj, Musking, error',f8.4,2x,f8.4,2x,f8.4,2x,f8.4) +12 format('X, Km, Ck, dtcrv',f8.2,2x,f8.1,2x,f8.1,2x,f6.4) +13 format('ql,quc,qup,qdc,qdp',i2,2x,f8.2,2x,f8.2,2x,f8.2,2x,f8.2,2x,f8.2) + +! ---------------------------------------------------------------- + END FUNCTION MUSKINGCUNGE +! ---------------------------------------------------------------- + +! ------------------------------------------------ +! FUNCTION KINEMATIC +! ------------------------------------------------ + REAL FUNCTION KINEMATIC() + + IMPLICIT NONE + +! -------- DECLARATIONS ----------------------- + +! REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: OVRGH + + KINEMATIC = 1 +!---------------------------------------------------------------- + END FUNCTION KINEMATIC +!---------------------------------------------------------------- + + +! ------------------------------------------------ +! SUBROUTINE drive_CHANNEL +! ------------------------------------------------ + Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & + QSUBRT, LAKEINFLORT, QSTRMVOLRT, TO_NODE, FROM_NODE, & + TYPEL, ORDER, MAXORDER, NLINKS, CH_NETLNK, CH_NETRT, & + LAKE_MSKRT, DT, DTCT,DTRT, MUSK, MUSX, QLINK, & + HLINK, ELRT, CHANLEN, MannN, So, ChSSlp, Bw, & + RESHT, HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & + ORIFICEE, ZELEV, CVOL, NLAKES, QLAKEI, QLAKEO, LAKENODE, & + dist, QINFLOWBASE, CHANXI, CHANYJ, channel_option, RETDEP_CHAN & + ,node_area & +#ifdef MPP_LAND + ,lake_index,link_location,mpp_nlinks,nlinks_index,yw_mpp_nlinks & +#endif + ) + + IMPLICIT NONE + +! -------- DECLARATIONS ------------------------ + + INTEGER, INTENT(IN) :: IXRT,JXRT,channel_option + INTEGER, INTENT(IN) :: NLINKS,NLAKES + integer, INTENT(INOUT) :: KT ! flag of cold start (1) or continue run. + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QSUBRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKEINFLORT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QINFLOWBASE + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + + real , dimension(ixrt,jxrt):: latval,lonval + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + INTEGER, INTENT(IN), DIMENSION(NLINKS) :: ORDER, TYPEL !--link + INTEGER, INTENT(IN), DIMENSION(NLINKS) :: TO_NODE, FROM_NODE + INTEGER, INTENT(IN), DIMENSION(NLINKS) :: CHANXI, CHANYJ + REAL, INTENT(IN), DIMENSION(NLINKS) :: ZELEV !--elevation of nodes + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CVOL + REAL, INTENT(IN), DIMENSION(NLINKS) :: MUSK, MUSX + REAL, INTENT(IN), DIMENSION(NLINKS) :: CHANLEN + REAL, INTENT(IN), DIMENSION(NLINKS) :: So, MannN + REAL, INTENT(IN), DIMENSION(NLINKS) :: ChSSlp,Bw !--properties of nodes or links + REAL :: Km, X + REAL , INTENT(INOUT), DIMENSION(NLINKS,2) :: QLINK + REAL , INTENT(INOUT), DIMENSION(NLINKS) :: HLINK + REAL, INTENT(IN) :: DT !-- model timestep + REAL, INTENT(IN) :: DTRT !-- routing timestep + REAL, INTENT(INOUT):: DTCT + REAL :: dist(ixrt,jxrt,9) + REAL :: RETDEP_CHAN + INTEGER, INTENT(IN) :: MAXORDER, SUBRTSWCRT + REAL , INTENT(IN), DIMENSION(NLINKS) :: node_area + + !-- lake params + REAL, INTENT(IN), DIMENSION(NLAKES) :: HRZAREA !-- horizontal area (km^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: LAKEMAXH !-- maximum lake depth (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRC !-- weir coefficient + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRL !-- weir length (m) + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEC !-- orrifice coefficient + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEA !-- orrifice area (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEE !-- orrifce elevation (m) + + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: RESHT !-- reservoir height (m) + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEI !-- lake inflow (cms) + REAL, DIMENSION(NLAKES) :: QLAKEIP !-- lake inflow previous timestep (cms) + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEO !-- outflow from lake used in diffusion scheme + INTEGER, INTENT(IN), DIMENSION(NLINKS) :: LAKENODE !-- outflow from lake used in diffusion scheme + REAL, DIMENSION(NLINKS) :: QLateral !--lateral flux + REAL, DIMENSION(NLINKS) :: QSUM !--mass bal of node + REAL, DIMENSION(NLAKES) :: QLLAKE !-- lateral inflow to lake in diffusion scheme + +!-- Local Variables + INTEGER :: i,j,k,m,kk,KRT,node + INTEGER :: DT_STEPS !-- number of timestep in routing + REAL :: qu,qd !--upstream, downstream flow + REAL :: bo !--critical depth, bnd outflow just for testing + + REAL, DIMENSION(NLINKS,2) :: QLINKPREV !-- temporarily store qlink value + REAL ,DIMENSION(NLINKS) :: HLINKTMP,CVOLTMP !-- temporarily store head values and volume values + REAL ,DIMENSION(NLINKS) :: CD !-- critical depth + real, DIMENSION(IXRT,JXRT) :: tmp + real, dimension(nlinks) :: tmp2 + +#ifdef MPP_LAND + integer lake_index(nlakes) + integer nlinks_index(nlinks) + integer mpp_nlinks, iyw, yw_mpp_nlinks + integer link_location(ixrt,jxrt) + real ywtmp(ixrt,jxrt) +#endif + integer flag + + integer :: kk2 ! tmp + + QLAKEIP = 0 + QLINKPREV = 0 + HLINKTMP = 0 + CVOLTMP = 0 + CD = 0 + + node = 1 + + + QLateral = 0 + QSUM = 0 + QLLAKE = 0 + + + IF(channel_option .ne. 3) then !--muskingum methods ROUTE ON DT timestep, not DTRT!! +#ifdef MPP_LAND +#ifdef HYDRO_D + write(6,*) "Error: not parallelized" + call hydro_stop("in drive_CHANNEL") +#endif +#endif + DT_STEPS = 1 + + DO KRT=1,DT_STEPS !-- route over routing timestep + + do k = 1, NLINKS + QLateral(k)=0 !--initial lateral flux to 0 for this reach + do i = 1, IXRT + do j = 1, JXRT + !--------river grid points + !!!! IS THIS CORREECT BECAUSE CH_NETRT IS JUST A 0,1????? + if ( (CH_NETRT(i,j) .eq. k) .and. (LAKE_MSKRT(i,j) .eq. -9999)) then + !--------river grid points + !-- convert total volume into flow rate across reach (m3/sec) + !-- QSUBRT and QSTRMVOLRT are mm for the DT interval, so + !-- you need to divided by the timestep fraction and + !-- multiply by DXRT^2 1m/1000mmm/DT + QLateral(k) = QLateral(k) + ((QSUBRT(i,j)+QSTRMVOLRT(i,j))/DT_STEPS & + *dist(i,j,9)/1000/DT) + QINFLOWBASE(i,j) + elseif ( (LAKE_MSKRT(i,j) .eq. k)) then !-lake grid + !-- convert total volume into flow rate across reach (m3/sec) + QLateral(k) = QLateral(k) + (LAKEINFLORT(i,j)/DT_STEPS & + *dist(i,j,9)/1000/DT) + QINFLOWBASE(i,j) + endif + end do + end do + end do + +!---------- route order 1 reaches which have no upstream inflow + do k=1, NLINKS + if (ORDER(k) .eq. 1) then !-- first order stream has no headflow + + if (KT .eq. 1) then !-- initial slug of water in unpstream cells + qd = QLINK(k,1) + KT = KT + 1 + else + qd = QLINK(k,2) !-- downstream outflow, previous timestep + QLINK(k,1) = 0 + endif + + if(TYPEL(k) .eq. 1) then !-- level pool route of reservoir + !CALL LEVELPOOL(1,0.0, 0.0, qd, QLINK(k,2), QLateral(k), & + ! DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), & + ! WEIRC(k), WEIRL(k), ORIFICEE(i), ORIFICEC(k), ORIFICEA(k) ) + elseif (channel_option .eq. 1) then + Km = MUSK(k) + X = MUSX(k) + QLINK(k,2) = MUSKING(QLINK(k,1), QLateral(k), qd, DT, Km, X) !--current outflow + elseif (channel_option .eq. 2) then !-- upstream is assumed constant initial condition + QLINK(k,2) = MUSKINGCUNGE(k,QLINK(k,1),QLINK(k,1), qd, & + QLateral(k), DT, So(k), CHANLEN(k), & + MannN(k), ChSSLP(k), Bw(k)) + + else +#ifdef HYDRO_D + print *, "No channel option selected" + call hydro_stop("drive_CHANNEL") +#endif + endif + endif + end do + + !---------- route other reaches, with upstream inflow + do kk = 2, MAXORDER + do k = 1, NLINKS + qu = 0 + if (ORDER(k) .eq. kk) then !--do the orders sequentially + qd = QLINK(k,2) !--downstream flow previous timestep + + do m = 1, NLINKS + if (TO_NODE(m) .eq. FROM_NODE(k)) then + qu = qu + QLINK(m,2) !--upstream previous timestep + endif + end do ! do m + + + if(TYPEL(k) .eq. 1) then !--link is a reservoir + ! CALL LEVELPOOL(1,QLINK(k,1), qu, qd, QLINK(k,2), & + ! QLateral(k), DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), & + ! WEIRC(k), WEIRL(k),ORIFICEE(k), ORIFICEC(k), ORIFICEA(k)) + elseif (channel_option .eq. 1) then !muskingum routing + Km = MUSK(k) + X = MUSX(k) + QLINK(k,2) = MUSKING(QLINK(k,1),qu,qd,DT,Km,X) + elseif (channel_option .eq. 2) then ! muskingum cunge + QLINK(k,2) = MUSKINGCUNGE(k,QLINK(k,1), qu, qd, & + QLateral(k), DT, So(k), CHANLEN(k), & + MannN(k), ChSSlp(k), Bw(k) ) + else +#ifdef HYDRO_D + print *, " no channel option selected" + call hydro_stop("drive_CHANNEL") +#endif + endif + QLINK(k,1) = qu !save inflow to reach at current timestep + !to be used as inflow from previous timestep + !on next iteration + endif !--order == kk + end do !--k links + end do !--kk order + +#ifdef HYDRO_D + print *, "END OF ALL REACHES...",KRT,DT_STEPS +#endif + + END DO !-- krt timestep for muksingumcunge routing + +!yw begin + elseif(channel_option .eq. 3) then !--- route using the diffusion scheme on nodes not links + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINK,NLINKS,99) + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOL,NLINKS,99) +#endif + + KRT = 0 !-- initialize the time counter + + DTCT = min(DTCT*2.0,DTRT) +!yw DTCT = DTRT !-- initialize the routing timestep to the timestep in namelist (s) + + HLINKTMP = HLINK !-- temporary storage of the water elevations (m) + CVOLTMP = CVOL !-- temporary storage of the volume of water in channel (m^3) + QLAKEIP = QLAKEI !-- temporary lake inflow from previous timestep (cms) + +! call check_channel(77,HLINKTMP,1,nlinks) +! call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,ZELEV,NLINKS,99) +! call check_channel(78,ZELEV,1,nlinks) + + +crnt: DO !-- loop on the courant condition + QSUM = 0 !-- initialize the total flow out of each cell to zero + QLAKEI = 0 !-- set the lake inflow as zero + QLLAKE = 0 !-- initialize each lake's lateral inflow to zero + DT_STEPS=INT(DT/DTCT) !-- fix the timestep + QLateral = 0. + + +!-- vectorize +!--------------------- +#ifdef MPP_LAND + DO iyw = 1,yw_MPP_NLINKS + i = nlinks_index(iyw) +#else + DO i = 1,NLINKS +#endif + + if(node_area(i) .eq. 0) then + write(6,*) "Error: node_area(i) is zero. i=", i + call hydro_stop("drive_CHANNEL") + endif + + if((CH_NETRT(CHANXI(i), CHANYJ(i) ) .eq. 0) .and. & + (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .lt.0) ) then !--a reg. node + QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) = & +! await subsfc exchg ((QSUBRT(CHANXI(i),CHANYJ(i))+QSTRMVOLRT(CHANXI(i),CHANYJ(i))+& + ((QSTRMVOLRT(CHANXI(i),CHANYJ(i))+& + QINFLOWBASE(CHANXI(i),CHANYJ(i))) & + /DT_STEPS*node_area(i)/1000/DTCT) + if(Qlateral(CH_NETLNK(CHANXI(i),CHANYJ(i))).lt.0.) then +#ifdef HYDRO_D + print*, "i, CHANXI(i),CHANYJ(i) = ", i, CHANXI(i),CHANYJ(i) + print *, "NEGATIVE Lat inflow...",QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))), & + QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)), & + QINFLOWBASE(CHANXI(i),CHANYJ(i)) + call hydro_stop("drive_CHANNEL") +#endif + end if + elseif(LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .gt. 0 .and. & + (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .ne. -9999)) then !--a lake node + QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) = & + QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) + & + (LAKEINFLORT(CHANXI(i),CHANYJ(i))+ & + QINFLOWBASE(CHANXI(i),CHANYJ(i)) & + /DT_STEPS*node_area(i)/1000/DTCT) + elseif(CH_NETRT(CHANXI(i),CHANYJ(i)) .gt. 0) then !pour out of lake + QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) = & + QLAKEO(CH_NETRT(CHANXI(i),CHANYJ(i))) !-- previous timestep + endif + ENDDO + + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLateral,NLINKS,99) + if(NLAKES .gt. 0) then + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT ,ixrt,jxrt,QLLAKE,NLAKES,99) + endif +#endif + +! call check_channel(79,QLINK(:,1),1,nlinks) + + + !-- compute conveyances, with known depths (just assign to QLINK(,1) + !--QLINK(,2) will not be used), QLINK is the flow across the node face + !-- units should be m3/second.. consistent with QL (lateral flow) + +#ifdef MPP_LAND + DO iyw = 1,yw_MPP_NLINKS + i = nlinks_index(iyw) +#else + DO i = 1,NLINKS +#endif + if (TYPEL(i) .eq. 0 .AND. HLINKTMP(FROM_NODE(i)) .gt. RETDEP_CHAN) then + if(from_node(i) .ne. to_node(i) .and. (to_node(i) .gt. 0) .and.(from_node(i) .gt. 0) ) & ! added by Wei Yu + QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & + HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & + CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) + else !-- we are just computing critical depth for outflow points + QLINK(i,1) =0. + endif + ENDDO + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99) +#endif +! call check_lake(80,QLLAKE,lake_index,nlakes) +! call check_channel(81,QLINK(:,1),1,nlinks) +! call check_channel(82,HLINKTMP,1,nlinks) +! call check_channel(89,HLINKTMP,1,nlinks) +! call check_channel(83,CHANLEN,1,nlinks) +! call check_channel(84,MannN,1,nlinks) +! call check_channel(85,Bw,1,nlinks) +! call check_channel(86,ChSSlp,1,nlinks) +! call check_channel(87,TYPEL*1.0,1,nlinks) + + + !-- compute total flow across face, into node +#ifdef MPP_LAND + DO iyw = 1,yw_mpp_nlinks + i = nlinks_index(iyw) +#else + DO i = 1,NLINKS !-- inflow to node across each face +#endif + if(TYPEL(i) .eq. 0) then !-- only regular nodes have to attribute + QSUM(TO_NODE(i)) = QSUM(TO_NODE(i)) + QLINK(i,1) + endif + END DO + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,0) +#endif + +! call check_channel(79,TYPEL*1.0,1,nlinks) + +! call check_channel(80,QLINK(:,1),1,nlinks) + +! call check_channel(89,qsum,1,nlinks) + + + +#ifdef MPP_LAND + DO iyw = 1,yw_mpp_nlinks + i = nlinks_index(iyw) +#else + DO i = 1,NLINKS !-- outflow from node across each face +#endif + QSUM(FROM_NODE(i)) = QSUM(FROM_NODE(i)) - QLINK(i,1) + END DO +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,99) +#endif +! call check_channel(89,qsum,1,nlinks) + + + flag = 99 + + +#ifdef MPP_LAND + DO iyw = 1,yw_MPP_NLINKS + i = nlinks_index(iyw) +#else + DO i = 1, NLINKS !--- compute volume and depth at each node +#endif + + if( TYPEL(i).eq.0 .and. CVOLTMP(i) .ge. 0.001 .and.(CVOLTMP(i)-QSUM(i)*DTCT)/CVOLTMP(i) .le. -0.01 ) then + flag = -99 +#ifdef HYDRO_D + write(6,*) "******* start diag ***************" + write(6,*) "Unstable at node ",i, "i=",CHANXI(i),"j=",CHANYJ(i) + write(6,*) "Unstatble at node ",i, "lat=",latval(CHANXI(i),CHANYJ(i)), "lon=",lonval(CHANXI(i),CHANYJ(i)) + write(6,*) "TYPEL, CVOLTMP, QSUM, QSUM*DTCT",TYPEL(i), CVOLTMP(i), QSUM(i), QSUM(i)*DTCT + write(6,*) "qsubrt, qstrmvolrt,qlink",QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)),qlink(i,1),qlink(i,2) +! write(6,*) "current nodes, z, h", ZELEV(FROM_NODE(i)),HLINKTMP(FROM_NODE(i)) +! if(TO_NODE(i) .gt. 0) then +! write(6,*) "to nodes, z, h", ZELEV(TO_NODE(i)), HLINKTMP(TO_NODE(i)) +! else +! write(6,*) "no to nodes " +! endif + write(6,*) "CHANLEN(i), MannN(i), Bw(i), ChSSlp(i) ", CHANLEN(i), MannN(i), Bw(i), ChSSlp(i) + write(6,*) "*******end of diag ***************" +#endif + + goto 999 + endif + enddo + +999 continue +#ifdef MPP_LAND + call mpp_same_int1(flag) +#endif + + + if(flag < 0 .and. DTCT >0.1) then + + ! call smoth121(HLINK,nlinks,maxv_p,pnode,to_node) + + if(DTCT .gt. 0.001) then !-- timestep in seconds + DTCT = max(DTCT/2 ,0.1) !-- 1/2 timestep + KRT = 0 !-- restart counter + HLINKTMP = HLINK !-- set head and vol to start value of timestep + CVOLTMP = CVOL + CYCLE crnt !-- start cycle over with smaller timestep + else +#ifdef HYDRO_D + write(6,*) "Error ..... with small DTCT",DTCT + call hydro_stop("drive_CHANNEL") +#endif + DTCT = 0.1 + HLINKTMP = HLINK !-- set head and volume to start values of timestep + CVOLTMP = CVOL + goto 998 + end if + endif + +998 continue + + +#ifdef MPP_LAND + DO iyw = 1,yw_MPP_NLINKS + i = nlinks_index(iyw) +#else + DO i = 1, NLINKS !--- compute volume and depth at each node +#endif + + if(TYPEL(i) .eq. 0) then !-- regular channel grid point, compute volume + CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) )* DTCT + if(CVOLTMP(i) .lt. 0) then +#ifdef HYDRO_D + print *, "warning! channel volume less than 0:i,CVOL,QSUM,QLat", & + i, CVOLTMP(i),QSUM(i),QLateral(i),HLINK(i) +#endif + CVOLTMP(i) =0 + endif + + elseif(TYPEL(i) .eq. 1) then !-- pour point, critical depth downstream + + if (QSUM(i)+QLateral(i) .lt. 0) then + else + +!DJG remove to have const. flux b.c.... CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) + CD(i) = HLINKTMP(i) !This is a temp hardwire for flow depth for the pour point... + endif + + ! change in volume is inflow, lateral flow, and outflow + !yw DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*DXRT),HLINKTMP(i), & + CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & + DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & + CD(i),CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT + elseif (TYPEL(i) .eq. 2) then !--- into a reservoir, assume critical depth + if (QSUM(i)+QLateral(i) .lt. 0) then +#ifdef HYDRO_D + print *, i, 'CrtDpth Qsum+QLat into lake< 0',QSUM(i), QLateral(i) +#endif + else +!DJG remove to have const. flux b.c.... CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) + CD(i) = HLINKTMP(i) !This is a temp hardwire for flow depth for the pour point... + endif + + !-- compute volume in reach (m^3) + CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & + DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & + CD(i) ,CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT + !-- compute flow rate into lake from all contributing nodes (cms) + QLAKEI(LAKENODE(i)) = QLAKEI(LAKENODE(i)) + QLINK(FROM_NODE(i),1) + + else +#ifdef HYDRO_D + print *, "this node does not have a type.. error TYPEL =", TYPEL(i) + call hydro_stop("drive_CHANNEL") +#endif + endif + + if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow + HLINKTMP(i) = HEAD(i, CVOLTMP(i)/CHANLEN(i),Bw(i),1/ChSSlp(i)) !--updated depth + else + HLINKTMP(i) = CD(i) !!! CRITICALDEPTH(i,QSUM(i)+QLateral(i), Bw(i), 1./ChSSlp(i)) !--critical depth is head + endif + + END DO !--- done processing all the links + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOLTMP,NLINKS,99) + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CD,NLINKS,99) + if(NLAKES .gt. 0) then + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) + endif + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINKTMP,NLINKS,99) +#endif +! call check_channel(83,CVOLTMP,1,nlinks) +! call check_channel(84,CD,1,nlinks) +! call check_channel(85,HLINKTMP,1,nlinks) +! call check_lake(86,QLAKEI,lake_index,nlakes) + +! call hydro_stop("88888888") + + + + + do i = 1, NLAKES !-- mass balances of lakes +#ifdef MPP_LAND + if(lake_index(i) .gt. 0) then +#endif + CALL LEVELPOOL(i,QLAKEIP(i), QLAKEI(i), QLAKEO(i), QLLAKE(i), & + DTCT, RESHT(i), HRZAREA(i), LAKEMAXH(i), WEIRC(i), & + WEIRL(i), ORIFICEE(i), ORIFICEC(i), ORIFICEA(i)) + QLAKEIP(i) = QLAKEI(i) !-- store total lake inflow for this timestep +#ifdef MPP_LAND + endif +#endif + enddo +#ifdef MPP_LAND + if(NLAKES .gt. 0) then + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT ,ixrt,jxrt,QLLAKE,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,RESHT,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEO,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEIP,NLAKES,99) + endif +#endif + + +#ifdef MPP_LAND + DO iyw = 1,yw_MPP_NLINKS + i = nlinks_index(iyw) +#else + DO i = 1, NLINKS !--- compute volume and depth at each node +#endif + if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow + QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & + HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & + CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) + endif + enddo + +#ifdef MPP_LAND + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99) +#endif + + KRT = KRT + 1 !-- iterate on the timestep + IF(KRT .eq. DT_STEPS) EXIT crnt !-- up to the maximum time in interval + + END DO crnt !--- DTCT timestep of DT_STEPS + + HLINK = HLINKTMP !-- update head based on final solution in timestep + CVOL = CVOLTMP !-- update volume + else !-- no channel option apparently selected +#ifdef HYDRO_D + print *, "no channel option selected" + call hydro_stop("drive_CHANNEL") +#endif + endif + +#ifdef HYDRO_D + write(6,*) "finished call drive_CHANNEL" +#endif + + if (KT .eq. 1) KT = KT + 1 + + + END SUBROUTINE drive_CHANNEL +! ---------------------------------------------------------------- + +!--================== utility functions + REAL FUNCTION SHAPE(Bw,z,h) + REAL :: Bw, z, h + REAL :: sh1, sh2, sh3 + !---trapezoidal channel shape function + sh1 = (Bw+2*z*h)*(5*Bw + 6*h*sqrt(1+z**2)) + sh2 = 4*z*h**2*sqrt(1+z**2) + sh3 = (3*h*(Bw+z*h)*(Bw+2*h*sqrt(1+z**2))) + if (sh3 .eq. 0) then + SHAPE = 0 + else + SHAPE = (sh1+sh2)/sh3 + endif + END FUNCTION SHAPE + + REAL FUNCTION FLOW(n,So,Bw,h,z) + REAL :: n,So, Bw, z, h + REAL :: WP, AREA + WP = Bw + 2*h*sqrt(1+h**2) !-- wetted perimeter + AREA = (Bw+z*h)*h !-- Flow area + if (WP .le.0) then +#ifdef HYDRO_D + print *, "Wetter perimeter is zero, will get divide by zero error" + call hydro_stop("in SHAPE") +#endif + else + FLOW = (1/n)*sqrt(So)*(AREA**(5./3.)/(WP**(2./3.))) + endif + END FUNCTION FLOW + +!-======================================= + REAL FUNCTION AREAf(AREA,Bw,h,z) + REAL :: AREA, Bw, z, h + AREAf = (Bw+z*h)*h-AREA !-- Flow area + END FUNCTION AREAf + +!-====critical depth function ========== + REAL FUNCTION CDf(Q,Bw,h,z) + REAL :: Q, Bw, z, h + if(h .le. 0) then +#ifdef HYDRO_D + print *, "head is zero, will get division by zero error" + call hydro_stop("in AREAf") +#endif + else + CDf = (Q/((Bw+z*h)*h))/(sqrt(9.81*(((Bw+z*h)*h)/(Bw+2*z*h))))-1 !--critical depth function + endif + END FUNCTION CDf + +!=======find flow depth in channel with bisection Chapra pg. 131 + REAL FUNCTION HEAD(index,AREA,Bw,z) !-- find the water elevation given wetted area, + !--bottom widith and side channel.. index was for debuggin + REAL :: Bw,z,AREA,test + REAL :: hl, hu, hr, hrold + REAL :: fl, fr,error !-- function evaluation + INTEGER :: maxiter,index + + error = 1.0 + maxiter = 0 + hl = 0.00001 !-- minimum depth is small + hu = 30. !-- assume maximum depth is 30 meters + + if (AREA .lt. 0.00001) then + hr = 0. + else + do while ((AREAf(AREA,BW,hl,z)*AREAf(AREA,BW,hu,z)).gt.0 .and. maxiter .lt. 100) + !-- allows for larger , smaller heads + if(AREA .lt. 1.) then + hl=hl/2 + else + hu = hu * 2 + endif + maxiter = maxiter + 1 + + end do + + maxiter =0 + hr = 0 + fl = AREAf(AREA,Bw,hl,z) + do while (error .gt. 0.0001 .and. maxiter < 1000) + hrold = hr + hr = (hl+hu)/2 + fr = AREAf(AREA,Bw,hr,z) + maxiter = maxiter + 1 + if (hr .ne. 0) then + error = abs((hr - hrold)/hr) + endif + test = fl * fr + if (test.lt.0) then + hu = hr + elseif (test.gt.0) then + hl=hr + fl = fr + else + error = 0.0 + endif + end do + endif + HEAD = hr + +22 format("i,hl,hu,Area",i5,2x,f12.8,2x,f6.3,2x,f6.3,2x,f6.3,2x,f9.1,2x,i5) + + END FUNCTION HEAD +!================================= + REAL FUNCTION MANNING(h1,n,Bw,Cs) + + REAL :: Bw,h1,Cs,n + REAL :: z, AREA,R,Kd + + z=1/Cs + R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z**2)) !-- Hyd Radius + AREA = (Bw+z*h1)*h1 !-- Flow area + Kd = (1/n)*(R**(2./3.))*AREA !-- convenyance +#ifdef HYDRO_D + print *,"head, kd", h1,Kd +#endif + MANNING = Kd + + END FUNCTION MANNING + +!=======find flow depth in channel with bisection Chapra pg. 131 + REAL FUNCTION CRITICALDEPTH(lnk,Q,Bw,z) !-- find the critical depth + REAL :: Bw,z,Q,test + REAL :: hl, hu, hr, hrold + REAL :: fl, fr,error !-- function evaluation + INTEGER :: maxiter + INTEGER :: lnk + + error = 1.0 + maxiter = 0 + hl = 1e-5 !-- minimum depth is 0.00001 meters +! hu = 35. !-- assume maximum critical depth 25 m + hu = 100. !-- assume maximum critical depth 25 m + + if(CDf(Q,BW,hl,z)*CDf(Q,BW,hu,z) .gt. 0) then + if(Q .gt. 0.001) then +#ifdef HYDRO_D + print *, "interval won't work to find CD of lnk ", lnk + print *, "Q, hl, hu", Q, hl, hu + print *, "cd lwr, upr", CDf(Q,BW,hl,z), CDf(Q,BW,hu,z) + ! call hydro_stop("in CRITICALDEPTH") + CRITICALDEPTH = -9999 + return +#endif + else + Q = 0.0 + endif + endif + + hr = 0. + fl = CDf(Q,Bw,hl,z) + + if (Q .eq. 0.) then + hr = 0. + else + do while (error .gt. 0.0001 .and. maxiter < 1000) + hrold = hr + hr = (hl+hu)/2 + fr = CDf(Q,Bw,hr,z) + maxiter = maxiter + 1 + if (hr .ne. 0) then + error = abs((hr - hrold)/hr) + endif + test = fl * fr + if (test.lt.0) then + hu = hr + elseif (test.gt.0) then + hl=hr + fl = fr + else + error = 0.0 + endif + + end do + endif + + CRITICALDEPTH = hr + + END FUNCTION CRITICALDEPTH +!================================================ + REAL FUNCTION SGNf(val) !-- function to return the sign of a number + REAL:: val + + if (val .lt. 0) then + SGNf= -1. + elseif (val.gt.0) then + SGNf= 1. + else + SGNf= 0. + endif + + END FUNCTION SGNf +!================================================ + + REAL FUNCTION fnDX(qp,Tw,So,Ck,dx,dt) !-- find channel sub-length for MK method + REAL :: qp,Tw,So,Ck,dx, dt,test + REAL :: dxl, dxu, dxr, dxrold + REAL :: fl, fr, error + REAL :: X + INTEGER :: maxiter + + error = 1.0 + maxiter =0 + dxl = dx*0.9 !-- how to choose dxl??? + dxu = dx + dxr=0 + + do while (fnDXCDT(qp,Tw,So,Ck,dxl,dt)*fnDXCDT(qp,Tw,So,Ck,dxu,dt) .gt. 0 & + .and. dxl .gt. 10) !-- don't let dxl get too small + dxl = dxl/1.1 + end do + + + fl = fnDXCDT(qp,Tw,So,Ck,dxl,dt) + do while (error .gt. 0.0001 .and. maxiter < 1000) + dxrold = dxr + dxr = (dxl+dxu)/2 + fr = fnDXCDT(qp,Tw,So,Ck,dxr,dt) + maxiter = maxiter + 1 + if (dxr .ne. 0) then + error = abs((dxr - dxrold)/dxr) + endif + test = fl * fr + if (test.lt.0) then + dxu = dxr + elseif (test.gt.0) then + dxl=dxr + fl = fr + else + error = 0.0 + endif + end do + FnDX = dxr + + END FUNCTION fnDX +!================================================ + REAL FUNCTION fnDXCDT(qp,Tw,So,Ck,dx,dt) !-- function to help find sub-length for MK method + REAL :: qp,Tw,So,Ck,dx,dt,X + REAL :: c,b !-- coefficients on dx/cdt log approximation function + + c = 0.2407 + b = 1.16065 + X = 0.5-(qp/(2*Tw*So*Ck*dx)) + if (X .le.0) then + fnDXCDT = -1 !0.115 + else + fnDXCDT = (dx/(Ck*dt)) - (c*LOG(X)+b) !-- this function needs to converge to 0 + endif + END FUNCTION fnDXCDT +! ---------------------------------------------------------------------- + + subroutine check_lake(unit,cd,lake_index,nlakes) + use module_RT_data, only: rt_domain + implicit none + integer :: unit,nlakes,i,lake_index(nlakes) + real cd(nlakes) +#ifdef MPP_LAND + call write_lake_real(cd,lake_index,nlakes) +#endif + write(unit,*) cd + flush(unit) + return + end subroutine check_lake + + subroutine check_channel(unit,cd,did,nlinks) + use module_RT_data, only: rt_domain +#ifdef MPP_LAND + USE module_mpp_land +#endif + implicit none + integer :: unit,nlinks,i, did + real cd(nlinks) +#ifdef MPP_LAND + real g_cd(rt_domain(did)%gnlinks) + call write_chanel_real(cd,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,nlinks,g_cd) + if(my_id .eq. IO_id) then + write(unit,*) "rt_domain(did)%gnlinks = ",rt_domain(did)%gnlinks + write(unit,*) g_cd + endif +#else + write(unit,*) cd +#endif + flush(unit) + close(unit) + return + end subroutine check_channel + subroutine smoth121(var,nlinks,maxv_p,from_node,to_node) + implicit none + integer,intent(in) :: nlinks, maxv_p + integer, intent(in), dimension(nlinks):: to_node + integer, intent(in), dimension(nlinks):: from_node(nlinks,maxv_p) + real, intent(inout), dimension(nlinks) :: var + real, dimension(nlinks) :: vartmp + integer :: i,j , k, from,to + integer :: plen + vartmp = 0 + do i = 1, nlinks + to = to_node(i) + plen = from_node(i,1) + if(plen .gt. 1) then + do k = 1, plen-1 + from = from_node(i,k+1) + if(to .gt. 0) then + vartmp(i) = vartmp(i)+0.25*(var(from)+2.*var(i)+var(to)) + else + vartmp(i) = vartmp(i)+(2.*var(i)+var(from))/3.0 + endif + end do + vartmp(i) = vartmp(i) /(plen-1) + else + if(to .gt. 0) then + vartmp(i) = vartmp(i)+(2.*var(i)+var(to)/3.0) + else + vartmp(i) = var(i) + endif + endif + end do + var = vartmp + return + end subroutine smoth121 +END MODULE module_channel_routing diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/module_date_utilities_rt.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/module_date_utilities_rt.F.svn-base new file mode 100644 index 00000000..4ec65dd9 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/.svn/text-base/module_date_utilities_rt.F.svn-base @@ -0,0 +1,1040 @@ +module Module_Date_utilities_rt +contains + subroutine geth_newdate (ndate, odate, idt) + implicit none + + ! From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and + ! delta-time, compute the new date. + + ! on entry - odate - the old hdate. + ! idt - the change in time + + ! on exit - ndate - the new hdate. + + integer, intent(in) :: idt + character (len=*), intent(out) :: ndate + character (len=*), intent(in) :: odate + + ! Local Variables + + ! yrold - indicates the year associated with "odate" + ! moold - indicates the month associated with "odate" + ! dyold - indicates the day associated with "odate" + ! hrold - indicates the hour associated with "odate" + ! miold - indicates the minute associated with "odate" + ! scold - indicates the second associated with "odate" + + ! yrnew - indicates the year associated with "ndate" + ! monew - indicates the month associated with "ndate" + ! dynew - indicates the day associated with "ndate" + ! hrnew - indicates the hour associated with "ndate" + ! minew - indicates the minute associated with "ndate" + ! scnew - indicates the second associated with "ndate" + + ! mday - a list assigning the number of days in each month + + ! i - loop counter + ! nday - the integer number of days represented by "idt" + ! nhour - the integer number of hours in "idt" after taking out + ! all the whole days + ! nmin - the integer number of minutes in "idt" after taking out + ! all the whole days and whole hours. + ! nsec - the integer number of minutes in "idt" after taking out + ! all the whole days, whole hours, and whole minutes. + + integer :: newlen, oldlen + integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew + integer :: yrold, moold, dyold, hrold, miold, scold, frold + integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc + logical :: opass + character (len=10) :: hfrc + character (len=1) :: sp + logical :: punct + integer :: yrstart, yrend, mostart, moend, dystart, dyend + integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart + integer :: units + integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) + + ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...." + if (odate(5:5) == "-") then + punct = .TRUE. + else + punct = .FALSE. + endif + + ! Break down old hdate into parts + + hrold = 0 + miold = 0 + scold = 0 + frold = 0 + oldlen = LEN(odate) + if (punct) then + yrstart = 1 + yrend = 4 + mostart = 6 + moend = 7 + dystart = 9 + dyend = 10 + hrstart = 12 + hrend = 13 + mistart = 15 + miend = 16 + scstart = 18 + scend = 19 + frstart = 21 + select case (oldlen) + case (10) + ! Days + units = 1 + case (13) + ! Hours + units = 2 + case (16) + ! Minutes + units = 3 + case (19) + ! Seconds + units = 4 + case (21) + ! Tenths + units = 5 + case (22) + ! Hundredths + units = 6 + case (23) + ! Thousandths + units = 7 + case (24) + ! Ten thousandths + units = 8 + case default +#ifdef HYDRO_D + write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' + call hydro_stop("geth_newdate") +#endif + end select + + if (oldlen.ge.11) then + sp = odate(11:11) + else + sp = ' ' + end if + + else + + yrstart = 1 + yrend = 4 + mostart = 5 + moend = 6 + dystart = 7 + dyend = 8 + hrstart = 9 + hrend = 10 + mistart = 11 + miend = 12 + scstart = 13 + scend = 14 + frstart = 15 + + select case (oldlen) + case (8) + ! Days + units = 1 + case (10) + ! Hours + units = 2 + case (12) + ! Minutes + units = 3 + case (14) + ! Seconds + units = 4 + case (15) + ! Tenths + units = 5 + case (16) + ! Hundredths + units = 6 + case (17) + ! Thousandths + units = 7 + case (18) + ! Ten thousandths + units = 8 + case default +#ifdef HYDRO_D + write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' + call hydro_stop("geth_newdate") +#endif + end select + endif + + ! Use internal READ statements to convert the CHARACTER string + ! date into INTEGER components. + + read(odate(yrstart:yrend), '(i4)') yrold + read(odate(mostart:moend), '(i2)') moold + read(odate(dystart:dyend), '(i2)') dyold + if (units.ge.2) then + read(odate(hrstart:hrend),'(i2)') hrold + if (units.ge.3) then + read(odate(mistart:miend),'(i2)') miold + if (units.ge.4) then + read(odate(scstart:scend),'(i2)') scold + if (units.ge.5) then + read(odate(frstart:oldlen),*) frold + end if + end if + end if + end if + + ! Set the number of days in February for that year. + + mday(2) = nfeb(yrold) + + ! Check that ODATE makes sense. + + opass = .TRUE. + + ! Check that the month of ODATE makes sense. + + if ((moold.gt.12).or.(moold.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold +#endif + opass = .FALSE. + end if + + ! Check that the day of ODATE makes sense. + + if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold +#endif + opass = .FALSE. + end if + + ! Check that the hour of ODATE makes sense. + + if ((hrold.gt.23).or.(hrold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold +#endif + opass = .FALSE. + end if + + ! Check that the minute of ODATE makes sense. + + if ((miold.gt.59).or.(miold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold +#endif + opass = .FALSE. + end if + + ! Check that the second of ODATE makes sense. + + if ((scold.gt.59).or.(scold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold +#endif + opass = .FALSE. + end if + + ! Check that the fractional part of ODATE makes sense. + + + if (.not.opass) then +#ifdef HYDRO_D + write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen + stop +#endif + end if + + ! Date Checks are completed. Continue. + + + ! Compute the number of days, hours, minutes, and seconds in idt + + if (units.ge.5) then !idt should be in fractions of seconds + ifrc = oldlen-(frstart)+1 + ifrc = 10**ifrc + nday = abs(idt)/(86400*ifrc) + nhour = mod(abs(idt),86400*ifrc)/(3600*ifrc) + nmin = mod(abs(idt),3600*ifrc)/(60*ifrc) + nsec = mod(abs(idt),60*ifrc)/(ifrc) + nfrac = mod(abs(idt), ifrc) + else if (units.eq.4) then !idt should be in seconds + ifrc = 1 + nday = abs(idt)/86400 ! integer number of days in delta-time + nhour = mod(abs(idt),86400)/3600 + nmin = mod(abs(idt),3600)/60 + nsec = mod(abs(idt),60) + nfrac = 0 + else if (units.eq.3) then !idt should be in minutes + ifrc = 1 + nday = abs(idt)/1440 ! integer number of days in delta-time + nhour = mod(abs(idt),1440)/60 + nmin = mod(abs(idt),60) + nsec = 0 + nfrac = 0 + else if (units.eq.2) then !idt should be in hours + ifrc = 1 + nday = abs(idt)/24 ! integer number of days in delta-time + nhour = mod(abs(idt),24) + nmin = 0 + nsec = 0 + nfrac = 0 + else if (units.eq.1) then !idt should be in days + ifrc = 1 + nday = abs(idt) ! integer number of days in delta-time + nhour = 0 + nmin = 0 + nsec = 0 + nfrac = 0 + else +#ifdef HYDRO_D + write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & + oldlen + write(*,*) '#'//odate(1:oldlen)//'#' + call hydro_stop("geth_newdate") +#endif + end if + + if (idt.ge.0) then + + frnew = frold + nfrac + if (frnew.ge.ifrc) then + frnew = frnew - ifrc + nsec = nsec + 1 + end if + + scnew = scold + nsec + if (scnew .ge. 60) then + scnew = scnew - 60 + nmin = nmin + 1 + end if + + minew = miold + nmin + if (minew .ge. 60) then + minew = minew - 60 + nhour = nhour + 1 + end if + + hrnew = hrold + nhour + if (hrnew .ge. 24) then + hrnew = hrnew - 24 + nday = nday + 1 + end if + + dynew = dyold + monew = moold + yrnew = yrold + do i = 1, nday + dynew = dynew + 1 + if (dynew.gt.mday(monew)) then + dynew = dynew - mday(monew) + monew = monew + 1 + if (monew .gt. 12) then + monew = 1 + yrnew = yrnew + 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb(yrnew) + end if + end if + end do + + else if (idt.lt.0) then + + frnew = frold - nfrac + if (frnew .lt. 0) then + frnew = frnew + ifrc + nsec = nsec + 1 + end if + + scnew = scold - nsec + if (scnew .lt. 00) then + scnew = scnew + 60 + nmin = nmin + 1 + end if + + minew = miold - nmin + if (minew .lt. 00) then + minew = minew + 60 + nhour = nhour + 1 + end if + + hrnew = hrold - nhour + if (hrnew .lt. 00) then + hrnew = hrnew + 24 + nday = nday + 1 + end if + + dynew = dyold + monew = moold + yrnew = yrold + do i = 1, nday + dynew = dynew - 1 + if (dynew.eq.0) then + monew = monew - 1 + if (monew.eq.0) then + monew = 12 + yrnew = yrnew - 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb(yrnew) + end if + dynew = mday(monew) + end if + end do + end if + + ! Now construct the new mdate + + newlen = LEN(ndate) + + if (punct) then + + if (newlen.gt.frstart) then + write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew + write(hfrc,'(i10)') frnew+1000000000 + ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + + else if (newlen.eq.scend) then + write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew +19 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2) + + else if (newlen.eq.miend) then + write(ndate,16) yrnew, monew, dynew, hrnew, minew +16 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2) + + else if (newlen.eq.hrend) then + write(ndate,13) yrnew, monew, dynew, hrnew +13 format(i4,'-',i2.2,'-',i2.2,'_',i2.2) + + else if (newlen.eq.dyend) then + write(ndate,10) yrnew, monew, dynew +10 format(i4,'-',i2.2,'-',i2.2) + + end if + + else + + if (newlen.gt.frstart) then + write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew + write(hfrc,'(i10)') frnew+1000000000 + ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + + else if (newlen.eq.scend) then + write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew +119 format(i4,i2.2,i2.2,i2.2,i2.2,i2.2) + + else if (newlen.eq.miend) then + write(ndate,116) yrnew, monew, dynew, hrnew, minew +116 format(i4,i2.2,i2.2,i2.2,i2.2) + + else if (newlen.eq.hrend) then + write(ndate,113) yrnew, monew, dynew, hrnew +113 format(i4,i2.2,i2.2,i2.2) + + else if (newlen.eq.dyend) then + write(ndate,110) yrnew, monew, dynew +110 format(i4,i2.2,i2.2) + + end if + + endif + + if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp + + end subroutine geth_newdate + + subroutine geth_idts (newdate, olddate, idt) + + implicit none + + ! From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'), + ! compute the time difference. + + ! on entry - newdate - the new hdate. + ! olddate - the old hdate. + + ! on exit - idt - the change in time. + ! Units depend on length of date strings. + + character (len=*) , intent(in) :: newdate, olddate + integer , intent(out) :: idt + + + ! Local Variables + + ! yrnew - indicates the year associated with "ndate" + ! yrold - indicates the year associated with "odate" + ! monew - indicates the month associated with "ndate" + ! moold - indicates the month associated with "odate" + ! dynew - indicates the day associated with "ndate" + ! dyold - indicates the day associated with "odate" + ! hrnew - indicates the hour associated with "ndate" + ! hrold - indicates the hour associated with "odate" + ! minew - indicates the minute associated with "ndate" + ! miold - indicates the minute associated with "odate" + ! scnew - indicates the second associated with "ndate" + ! scold - indicates the second associated with "odate" + ! i - loop counter + ! mday - a list assigning the number of days in each month + + ! ndate, odate: local values of newdate and olddate + character(len=24) :: ndate, odate + + integer :: oldlen, newlen + integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew + integer :: yrold, moold, dyold, hrold, miold, scold, frold + integer :: i, newdys, olddys + logical :: npass, opass + integer :: timesign + integer :: ifrc + integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) + logical :: punct + integer :: yrstart, yrend, mostart, moend, dystart, dyend + integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart + integer :: units + + oldlen = len(olddate) + newlen = len(newdate) + if (newlen.ne.oldlen) then +#ifdef HYDRO_D + write(*,'("GETH_IDTS: NEWLEN /= OLDLEN: ", A, 3x, A)') newdate(1:newlen), olddate(1:oldlen) + call hydro_stop("geth_newdate") +#endif + endif + + if (olddate.gt.newdate) then + timesign = -1 + + ifrc = oldlen + oldlen = newlen + newlen = ifrc + + ndate = olddate + odate = newdate + else + timesign = 1 + ndate = newdate + odate = olddate + end if + + ! Break down old hdate into parts + + ! Determine if olddate is punctuated or not + if (odate(5:5) == "-") then + punct = .TRUE. + if (ndate(5:5) /= "-") then +#ifdef HYDRO_D + write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') & + ndate(1:newlen), odate(1:oldlen) + call hydro_stop("geth_idts") +#endif + endif + else + punct = .FALSE. + if (ndate(5:5) == "-") then +#ifdef HYDRO_D + write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') & + ndate(1:newlen), odate(1:oldlen) + call hydro_stop("geth_idts") +#endif + endif + endif + + if (punct) then + yrstart = 1 + yrend = 4 + mostart = 6 + moend = 7 + dystart = 9 + dyend = 10 + hrstart = 12 + hrend = 13 + mistart = 15 + miend = 16 + scstart = 18 + scend = 19 + frstart = 21 + select case (oldlen) + case (10) + ! Days + units = 1 + case (13) + ! Hours + units = 2 + case (16) + ! Minutes + units = 3 + case (19) + ! Seconds + units = 4 + case (21) + ! Tenths + units = 5 + case (22) + ! Hundredths + units = 6 + case (23) + ! Thousandths + units = 7 + case (24) + ! Ten thousandths + units = 8 + case default +#ifdef HYDRO_D + write(*,*) 'ERROR: geth_idts: odd length: #'//trim(odate)//'#' + call hydro_stop("geth_idts") +#endif + end select + else + + yrstart = 1 + yrend = 4 + mostart = 5 + moend = 6 + dystart = 7 + dyend = 8 + hrstart = 9 + hrend = 10 + mistart = 11 + miend = 12 + scstart = 13 + scend = 14 + frstart = 15 + + select case (oldlen) + case (8) + ! Days + units = 1 + case (10) + ! Hours + units = 2 + case (12) + ! Minutes + units = 3 + case (14) + ! Seconds + units = 4 + case (15) + ! Tenths + units = 5 + case (16) + ! Hundredths + units = 6 + case (17) + ! Thousandths + units = 7 + case (18) + ! Ten thousandths + units = 8 + case default +#ifdef HYDRO_D + write(*,*) 'ERROR: geth_idts: odd length: #'//trim(odate)//'#' + call hydro_stop("geth_idts") +#endif + end select + endif + + + hrold = 0 + miold = 0 + scold = 0 + frold = 0 + + read(odate(yrstart:yrend), '(i4)') yrold + read(odate(mostart:moend), '(i2)') moold + read(odate(dystart:dyend), '(i2)') dyold + if (units.ge.2) then + read(odate(hrstart:hrend),'(i2)') hrold + if (units.ge.3) then + read(odate(mistart:miend),'(i2)') miold + if (units.ge.4) then + read(odate(scstart:scend),'(i2)') scold + if (units.ge.5) then + read(odate(frstart:oldlen),*) frold + end if + end if + end if + end if + + ! Break down new hdate into parts + + hrnew = 0 + minew = 0 + scnew = 0 + frnew = 0 + + read(ndate(yrstart:yrend), '(i4)') yrnew + read(ndate(mostart:moend), '(i2)') monew + read(ndate(dystart:dyend), '(i2)') dynew + if (units.ge.2) then + read(ndate(hrstart:hrend),'(i2)') hrnew + if (units.ge.3) then + read(ndate(mistart:miend),'(i2)') minew + if (units.ge.4) then + read(ndate(scstart:scend),'(i2)') scnew + if (units.ge.5) then + read(ndate(frstart:newlen),*) frnew + end if + end if + end if + end if + + ! Check that the dates make sense. + + npass = .true. + opass = .true. + + ! Check that the month of NDATE makes sense. + + if ((monew.gt.12).or.(monew.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_IDTS: Month of NDATE = ', monew +#endif + npass = .false. + end if + + ! Check that the month of ODATE makes sense. + + if ((moold.gt.12).or.(moold.lt.1)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Month of ODATE = ', moold +#endif + opass = .false. + end if + + ! Check that the day of NDATE makes sense. + + if (monew.ne.2) then + ! ...... For all months but February + if ((dynew.gt.mday(monew)).or.(dynew.lt.1)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Day of NDATE = ', dynew +#endif + npass = .false. + end if + else if (monew.eq.2) then + ! ...... For February + if ((dynew > nfeb(yrnew)).or.(dynew < 1)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Day of NDATE = ', dynew +#endif + npass = .false. + end if + endif + + ! Check that the day of ODATE makes sense. + + if (moold.ne.2) then + ! ...... For all months but February + if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Day of ODATE = ', dyold +#endif + opass = .false. + end if + else if (moold.eq.2) then + ! ....... For February + if ((dyold > nfeb(yrold)).or.(dyold < 1)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Day of ODATE = ', dyold +#endif + opass = .false. + end if + end if + + ! Check that the hour of NDATE makes sense. + + if ((hrnew.gt.23).or.(hrnew.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Hour of NDATE = ', hrnew +#endif + npass = .false. + end if + + ! Check that the hour of ODATE makes sense. + + if ((hrold.gt.23).or.(hrold.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Hour of ODATE = ', hrold +#endif + opass = .false. + end if + + ! Check that the minute of NDATE makes sense. + + if ((minew.gt.59).or.(minew.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Minute of NDATE = ', minew +#endif + npass = .false. + end if + + ! Check that the minute of ODATE makes sense. + + if ((miold.gt.59).or.(miold.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Minute of ODATE = ', miold +#endif + opass = .false. + end if + + ! Check that the second of NDATE makes sense. + + if ((scnew.gt.59).or.(scnew.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: SECOND of NDATE = ', scnew +#endif + npass = .false. + end if + + ! Check that the second of ODATE makes sense. + + if ((scold.gt.59).or.(scold.lt.0)) then +#ifdef HYDRO_D + print*, 'GETH_IDTS: Second of ODATE = ', scold +#endif + opass = .false. + end if + + if (.not. npass) then +#ifdef HYDRO_D + print*, 'Screwy NDATE: ', ndate(1:newlen) + call hydro_stop("geth_idts") +#endif + end if + + if (.not. opass) then +#ifdef HYDRO_D + print*, 'Screwy ODATE: ', odate(1:oldlen) + call hydro_stop("geth_idts") +#endif + end if + + ! Date Checks are completed. Continue. + + ! Compute number of days from 1 January ODATE, 00:00:00 until ndate + ! Compute number of hours from 1 January ODATE, 00:00:00 until ndate + ! Compute number of minutes from 1 January ODATE, 00:00:00 until ndate + + newdys = 0 + do i = yrold, yrnew - 1 + newdys = newdys + 337 + nfeb(i) + end do + + if (monew .gt. 1) then + mday(2) = nfeb(yrnew) + do i = 1, monew - 1 + newdys = newdys + mday(i) + end do + mday(2) = 28 + end if + + newdys = newdys + dynew - 1 + + ! Compute number of hours from 1 January ODATE, 00:00:00 until odate + ! Compute number of minutes from 1 January ODATE, 00:00:00 until odate + + olddys = 0 + + if (moold .gt. 1) then + mday(2) = nfeb(yrold) + do i = 1, moold - 1 + olddys = olddys + mday(i) + end do + mday(2) = 28 + end if + + olddys = olddys + dyold -1 + + ! Determine the time difference + + idt = (newdys - olddys) + if (units.ge.2) then + idt = idt*24 + (hrnew - hrold) + if (units.ge.3) then + idt = idt*60 + (minew - miold) + if (units.ge.4) then + idt = idt*60 + (scnew - scold) + if (units.ge.5) then + ifrc = oldlen-(frstart-1) + ifrc = 10**ifrc + idt = idt * ifrc + (frnew-frold) + endif + endif + endif + endif + + if (timesign .eq. -1) then + idt = idt * timesign + end if + + end subroutine geth_idts + + + integer function nfeb(year) + ! + ! Compute the number of days in February for the given year. + ! + implicit none + integer, intent(in) :: year ! Four-digit year + + nfeb = 28 ! By default, February has 28 days ... + if (mod(year,4).eq.0) then + nfeb = 29 ! But every four years, it has 29 days ... + if (mod(year,100).eq.0) then + nfeb = 28 ! Except every 100 years, when it has 28 days ... + if (mod(year,400).eq.0) then + nfeb = 29 ! Except every 400 years, when it has 29 days ... + if (mod(year,3600).eq.0) then + nfeb = 28 ! Except every 3600 years, when it has 28 days. + endif + endif + endif + endif + end function nfeb + + integer function nmdays(hdate) + ! + ! Compute the number of days in the month of given date hdate. + ! + implicit none + character(len=*), intent(in) :: hdate + + integer :: year, month + integer, dimension(12), parameter :: ndays = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) + + read(hdate(1:7), '(I4,1x,I2)') year, month + + if (month == 2) then + nmdays = nfeb(year) + else + nmdays = ndays(month) + endif + end function nmdays + + function monthabbr_to_mm(mon) result(mm) + implicit none + + character(len=3), intent(in) :: mon + + integer :: mm + + if (mon == "Jan") then + mm = 1 + elseif (mon == "Feb") then + mm = 2 + elseif (mon == "Mar") then + mm = 3 + elseif (mon == "Apr") then + mm = 4 + elseif (mon == "May") then + mm = 5 + elseif (mon == "Jun") then + mm = 6 + elseif (mon == "Jul") then + mm = 7 + elseif (mon == "Aug") then + mm = 8 + elseif (mon == "Sep") then + mm = 9 + elseif (mon == "Oct") then + mm = 10 + elseif (mon == "Nov") then + mm = 11 + elseif (mon == "Dec") then + mm = 12 + else +#ifdef HYDRO_D + write(*, '("Function monthabbr_to_mm: mon = <",A,">")') mon + print*, "Function monthabbr_to_mm: Unrecognized mon" + call hydro_stop("monthabbr_to_mm") +#endif + endif + end function monthabbr_to_mm + + subroutine swap_date_format(indate, outdate) + implicit none + character(len=*), intent(in) :: indate + character(len=*), intent(out) :: outdate + integer :: inlen + + inlen = len(indate) + if (indate(5:5) == "-") then + select case (inlen) + case (10) + ! YYYY-MM-DD + outdate = indate(1:4)//indate(6:7)//indate(9:10) + case (13) + ! YYYY-MM-DD_HH + outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13) + case (16) + ! YYYY-MM-DD_HH:mm + outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16) + case (19) + ! YYYY-MM-DD_HH:mm:ss + outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//& + indate(18:19) + case (21,22,23,24) + ! YYYY-MM-DD_HH:mm:ss.f[f[f[f]]] + outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//& + indate(18:19)//indate(21:inlen) + case default +#ifdef HYDRO_D + write(*,'("Unrecognized length: <", A,">")') indate + call hydro_stop("swap_date_format") +#endif + end select + else + select case (inlen) + case (8) + ! YYYYMMDD + outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8) + case (10) + ! YYYYMMDDHH + outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& + indate(9:10) + case (12) + ! YYYYMMDDHHmm + outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& + indate(9:10)//":"//indate(11:12) + case (14) + ! YYYYMMDDHHmmss + outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& + indate(9:10)//":"//indate(11:12)//":"//indate(13:14) + case (15,16,17,18) + ! YYYYMMDDHHmmssf[f[f[f]]] + outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& + indate(9:10)//":"//indate(11:12)//":"//indate(13:14)//"."//indate(15:inlen) + case default +#ifdef HYDRO_D + write(*,'("Unrecognized length: <", A,">")') indate + call hydro_stop("swap_date_format") +#endif + end select + endif + + end subroutine swap_date_format + + character(len=3) function mm_to_monthabbr(ii) result(mon) + implicit none + integer, intent(in) :: ii + character(len=3), parameter, dimension(12) :: month = (/ & + "Jan", "Feb", "Mar", "Apr", "May", "Jun", & + "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" /) + if (ii > 0 .and. ii < 13 ) then + mon = month(ii) + else +#ifdef HYDRO_D + print*, "mm_to_monthabbr" + call hydro_stop("mm_to_monthabbr") +#endif + endif + end function mm_to_monthabbr + +end module Module_Date_utilities_rt diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/module_lsm_forcing.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/module_lsm_forcing.F.svn-base new file mode 100644 index 00000000..f60b0493 --- /dev/null +++ b/wrfv2_fire/hydro/Routing/.svn/text-base/module_lsm_forcing.F.svn-base @@ -0,0 +1,2276 @@ +module module_lsm_forcing + +#ifdef MPP_LAND + use module_mpp_land +#endif + use module_HYDRO_io, only: get_2d_netcdf, get_soilcat_netcdf, get2d_int + +implicit none +#include + integer :: i_forcing +character(len=19) out_date + +interface read_hydro_forcing +#ifdef MPP_LAND + module procedure read_hydro_forcing_mpp +#else + module procedure read_hydro_forcing_seq +#endif +end interface + +Contains + + subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) + + implicit none + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + character(len=*), intent(in) :: target_date + real, dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc, lai,fpar + integer tlevel + + character(len=256) :: units + integer :: ierr + integer :: ncid + + tlevel = 1 + + pcp = 0 + pcpc = 0 + + ! Open the NetCDF file. + ierr = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) +#endif + call hydro_stop("READFORC_WRF") + endif + + call get_2d_netcdf_ruc("T2", ncid, t, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("Q2", ncid, q, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("U10", ncid, u, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("V10", ncid, v, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("PSFC", ncid, p, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("GLW", ncid, lw, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("SWDOWN", ncid, sw, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("VEGFRA", ncid, fpar, ix, jx,tlevel, .true., ierr) + if(ierr == 0) then + if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar/100. + endif + call get_2d_netcdf_ruc("LAI", ncid, lai, ix, jx,tlevel, .true., ierr) + + ierr = nf_close(ncid) + + +!DJG Add the convective and non-convective rain components (note: conv. comp=0 +!for cloud resolving runs...) +!DJG Note that for WRF these are accumulated values to be adjusted to rates in +!driver... + + pcp=pcp+pcpc ! assumes pcpc=0 for resolved convection... + + end subroutine READFORC_WRF + + subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) + ! Simply return the dimensions of the grid. + implicit none + character(len=*), intent(in) :: geo_static_flnm + integer, intent(out) :: ix, jx, land_cat, soil_cat ! dimensions + + integer :: iret, ncid, dimid + + ! Open the NetCDF file. + iret = nf_open(geo_static_flnm, NF_NOWRITE, ncid) + if (iret /= 0) then +#ifdef HYDRO_D + write(*,'("Problem opening geo_static file: ''", A, "''")') & + trim(geo_static_flnm) +#endif + call hydro_stop("read_hrldas_hdrinfo") + endif + + iret = nf_inq_dimid(ncid, "west_east", dimid) + + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimid: west_east" +#endif + call hydro_stop("read_hrldas_hdrinfo") + endif + + iret = nf_inq_dimlen(ncid, dimid, ix) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimlen: west_east" +#endif + call hydro_stop("read_hrldas_hdrinfo") + endif + + iret = nf_inq_dimid(ncid, "south_north", dimid) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimid: south_north" +#endif + call hydro_stop("read_hrldas_hdrinfo") + endif + + iret = nf_inq_dimlen(ncid, dimid, jx) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimlen: south_north" +#endif + call hydro_stop("read_hrldas_hdrinfo") + endif + + iret = nf_inq_dimid(ncid, "land_cat", dimid) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimid: land_cat" +#endif + call hydro_stop("read_hrldas_hdrinfo") + endif + + iret = nf_inq_dimlen(ncid, dimid, land_cat) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimlen: land_cat" +#endif + call hydro_stop("read_hrldas_hdrinfo") + endif + + iret = nf_inq_dimid(ncid, "soil_cat", dimid) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimid: soil_cat" +#endif + call hydro_stop("read_hrldas_hdrinfo") + endif + + iret = nf_inq_dimlen(ncid, dimid, soil_cat) + if (iret /= 0) then +#ifdef HYDRO_D + print*, "nf_inq_dimlen: soil_cat" +#endif + call hydro_stop("read_hrldas_hdrinfo") + endif + + iret = nf_close(ncid) + + end subroutine read_hrldas_hdrinfo + + + + subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp, & + terrain,latitude,longitude,SOLVEG_INITSWC) + implicit none + character(len=*), intent(in) :: geo_static_flnm + integer, intent(in) :: ix, jx, land_cat, soil_cat,SOLVEG_INITSWC + integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp + real, dimension(ix,jx), intent(out) :: terrain, latitude, longitude + + character(len=256) :: units + integer :: ierr,i,j,jj + integer :: ncid,varid + real, dimension(ix,jx) :: xdum + integer, dimension(ix,jx) :: vegtyp_inv, soiltyp_inv,xdum_int + integer flag ! flag = 1 from wrfsi, flag =2 from WPS. + CHARACTER(len=256) :: var_name + + + ! Open the NetCDF file. + ierr = nf_open(geo_static_flnm, NF_NOWRITE, ncid) + + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("Problem opening geo_static file: ''", A, "''")') trim(geo_static_flnm) +#endif + call hydro_stop("readland_hrldas") + endif + + flag = -99 + ierr = nf_inq_varid(ncid,"XLAT", varid) + flag = 1 + if(ierr .ne. 0) then + ierr = nf_inq_varid(ncid,"XLAT_M", varid) + if(ierr .ne. 0) then +#ifdef HYDRO_D + write(6,*) "XLAT not found from wrfstatic file. " +#endif + call hydro_stop("readland_hrldas") + endif + flag = 2 + endif + + ! Get Latitude (lat) + if(flag .eq. 1) then + call get_2d_netcdf("XLAT", ncid, latitude, units, ix, jx, .TRUE., ierr) + else + call get_2d_netcdf("XLAT_M", ncid, latitude, units, ix, jx, .TRUE., ierr) + endif + + ! Get Longitude (lon) + if(flag .eq. 1) then + call get_2d_netcdf("XLONG", ncid, longitude, units, ix, jx, .TRUE., ierr) + else + call get_2d_netcdf("XLONG_M", ncid, longitude, units, ix, jx, .TRUE., ierr) + endif + + ! Get Terrain (avg) + if(flag .eq. 1) then + call get_2d_netcdf("HGT", ncid, terrain, units, ix, jx, .TRUE., ierr) + else + call get_2d_netcdf("HGT_M", ncid, terrain, units, ix, jx, .TRUE., ierr) + endif + + + if (SOLVEG_INITSWC.eq.0) then +! ! Get Dominant Land Use categories (use) +! call get_landuse_netcdf(ncid, xdum , units, ix, jx, land_cat) +! vegtyp = nint(xdum) + + var_name = "LU_INDEX" + call get2d_int(var_name,xdum_int,ix,jx,& + trim(geo_static_flnm)) + vegtyp = xdum_int + + ! Get Dominant Soil Type categories in the top layer (stl) + call get_soilcat_netcdf(ncid, xdum , units, ix, jx, soil_cat) + soltyp = nint(xdum) + + else if (SOLVEG_INITSWC.eq.1) then + var_name = "VEGTYP" + call get2d_int(var_name,VEGTYP_inv,ix,jx,& + trim(geo_static_flnm)) + + var_name = "SOILTYP" + call get2d_int(var_name,SOILTYP_inv,ix,jx,& + trim(geo_static_flnm)) + do i=1,ix + jj=jx + do j=1,jx + VEGTYP(i,j)=VEGTYP_inv(i,jj) + SOLTYP(i,j)=SOILTYP_inv(i,jj) + jj=jx-j + end do + end do + + endif + + + + ! Close the NetCDF file + ierr = nf_close(ncid) + if (ierr /= 0) then +#ifdef HYDRO_D + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: READLAND_HRLDAS: NF_CLOSE" +#endif + call hydro_stop("readland_hrldas") + endif + + ! Make sure vegtyp and soltyp are consistent when it comes to water points, + ! by setting soil category to water when vegetation category is water, and + ! vice-versa. + where (vegtyp == 16) soltyp = 14 + where (soltyp == 14) vegtyp = 16 + +!DJG test for deep gw function... +! where (soltyp <> 14) soltyp = 1 + + end subroutine readland_hrldas + + + subroutine get_2d_netcdf_ruc(var_name,ncid,var, & + ix,jx,tlevel,fatal_if_error,ierr) + character(len=*), intent(in) :: var_name + integer,intent(in) :: ncid,ix,jx,tlevel + real, intent(out):: var(ix,jx) + logical, intent(in) :: fatal_if_error + integer dims(4), dim_len(4) + integer ierr,iret + integer varid + integer start(4),count(4) + data count /1,1,1,1/ + data start /1,1,1,1/ + count(1) = ix + count(2) = jx + start(4) = tlevel + iret = nf_inq_varid(ncid, var_name, varid) + + if (iret /= 0) then + if (fatal_IF_ERROR) then +#ifdef HYDRO_D + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf_inq_varid ", trim(var_name) +#endif + call hydro_stop("get_2d_netcdf_ruc") + else + ierr = iret + return + endif + endif + + iret = nf_get_vara_real(ncid, varid, start,count,var) + + return + end subroutine get_2d_netcdf_ruc + + + subroutine get_2d_netcdf_cows(var_name,ncid,var, & + ix,jx,tlevel,fatal_if_error,ierr) + character(len=*), intent(in) :: var_name + integer,intent(in) :: ncid,ix,jx,tlevel + real, intent(out):: var(ix,jx) + logical, intent(in) :: fatal_if_error + integer ierr, iret + integer varid + integer start(4),count(4) + data count /1,1,1,1/ + data start /1,1,1,1/ + count(1) = ix + count(2) = jx + start(4) = tlevel + iret = nf_inq_varid(ncid, var_name, varid) + + if (iret /= 0) then + if (fatal_IF_ERROR) then +#ifdef HYDRO_D + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid" +#endif + call hydro_stop("get_2d_netcdf_cows") + else + ierr = iret + return + endif + endif + iret = nf_get_vara_real(ncid, varid, start,count,var) + + return + end subroutine get_2d_netcdf_cows + + + + + + subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, & + smc, stc, sh2o, cmc, t1, weasd, snodep) + implicit none + character(len=*), intent(in) :: netcdf_flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + integer, intent(in) :: nsoil + character(len=*), intent(in) :: target_date + real, dimension(ix,jx,nsoil), intent(out) :: smc + real, dimension(ix,jx,nsoil), intent(out) :: stc + real, dimension(ix,jx,nsoil), intent(out) :: sh2o + real, dimension(ix,jx), intent(out) :: cmc + real, dimension(ix,jx), intent(out) :: t1 + real, dimension(ix,jx), intent(out) :: weasd + real, dimension(ix,jx), intent(out) :: snodep + + character(len=256) :: units + character(len=8) :: name + integer :: ix_read, jx_read,i,j + + integer :: ierr, ncid, ierr_snodep + integer :: idx + + logical :: found_canwat, found_skintemp, found_weasd, found_stemp, found_smois + + ! Open the NetCDF file. + ierr = nf_open(netcdf_flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READINIT Problem opening netcdf file: ''", A, "''")') & + trim(netcdf_flnm) +#endif + call hydro_stop("readinit_hrldas") + endif + + call get_2d_netcdf("CANWAT", ncid, cmc, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SKINTEMP", ncid, t1, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("WEASD", ncid, weasd, units, ix, jx, .TRUE., ierr) + + if (trim(units) == "m") then + ! No conversion necessary + else if (trim(units) == "mm") then + ! convert WEASD from mm to m + weasd = weasd * 1.E-3 + else +#ifdef HYDRO_D + print*, 'units = "'//trim(units)//'"' + print*, "Unrecognized units on WEASD" +#endif + call hydro_stop("readinit_hrldas") + endif + + call get_2d_netcdf("SNODEP", ncid, snodep, units, ix, jx, .FALSE., ierr_snodep) + call get_2d_netcdf("STEMP_1", ncid, stc(:,:,1), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("STEMP_2", ncid, stc(:,:,2), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("STEMP_3", ncid, stc(:,:,3), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("STEMP_4", ncid, stc(:,:,4), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SMOIS_1", ncid, smc(:,:,1), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SMOIS_2", ncid, smc(:,:,2), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SMOIS_3", ncid, smc(:,:,3), units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SMOIS_4", ncid, smc(:,:,4), units, ix, jx, .TRUE., ierr) + + + if (ierr_snodep /= 0) then + ! Quick assumption regarding snow depth. + snodep = weasd * 10. + endif + + +!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... + do i=1,ix + do j=1,jx + if (WEASD(i,j).lt.0.) WEASD(i,j)=0.0 !set lower bound to correct bi-lin interp err... + if (snodep(i,j).lt.0.) snodep(i,j)=0.0 !set lower bound to correct bi-lin interp err... + end do + end do + + + sh2o = smc + + ierr = nf_close(ncid) + end subroutine readinit_hrldas + + + + + subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + character(len=*), intent(in) :: target_date + real, dimension(ix,jx), intent(out) :: t + real, dimension(ix,jx), intent(out) :: q + real, dimension(ix,jx), intent(out) :: u + real, dimension(ix,jx), intent(out) :: v + real, dimension(ix,jx), intent(out) :: p + real, dimension(ix,jx), intent(out) :: lw + real, dimension(ix,jx), intent(out) :: sw + real, dimension(ix,jx), intent(out) :: pcp + real, dimension(ix,jx), intent(inout) :: lai + real, dimension(ix,jx), intent(inout) :: fpar + + character(len=256) :: units + integer :: ierr + integer :: ncid + + ! Open the NetCDF file. + ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) +#endif + call hydro_stop("READFORC_HRLDAS") + endif + + call get_2d_netcdf("T2D", ncid, t, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("Q2D", ncid, q, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("U2D", ncid, u, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("V2D", ncid, v, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("PSFC", ncid, p, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("LWDOWN", ncid, lw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("SWDOWN", ncid, sw, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("RAINRATE",ncid, pcp, units, ix, jx, .TRUE., ierr) + call get_2d_netcdf("VEGFRA", ncid, fpar, units, ix, jx, .FALSE., ierr) + if (ierr == 0) then + if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000) fpar = fpar * 1.E-2 + endif + call get_2d_netcdf("LAI", ncid, lai, units, ix, jx, .FALSE., ierr) + + ierr = nf_close(ncid) + + end subroutine READFORC_HRLDAS + + + + subroutine READFORC_DMIP(flnm,ix,jx,var) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + real, dimension(ix,jx), intent(out) :: var + character(len=13) :: head + integer :: ncols, nrows, cellsize + real :: xllc, yllc, no_data + integer :: i,j + character(len=256) ::junk + + open (77,file=trim(flnm),form="formatted",status="old") + +! read(77,732) head,ncols +! read(77,732) head,nrows +!732 FORMAT(A13,I4) +! read(77,733) head,xllc +! read(77,733) head,yllc +!733 FORMAT(A13,F16.9) +! read(77,732) head,cellsize +! read(77,732) head,no_data + + read(77,*) junk + read(77,*) junk + read(77,*) junk + read(77,*) junk + read(77,*) junk + read(77,*) junk + + do j=jx,1,-1 + read(77,*) (var(I,J),I=1,ix) + end do + close(77) + + end subroutine READFORC_DMIP + + + + subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + integer, intent(out) :: ierr_flg + integer :: it,jew,zsn + real, dimension(ix,jx), intent(out) :: pcp + + character(len=256) :: units + integer :: ierr,i,j,i2,j2,varid + integer :: ncid,mmflag + real, dimension(ix,jx) :: temp + + mmflag = 0 ! flag for units spec. (0=mm, 1=mm/s) + + +!open NetCDF file... + ierr_flg = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr_flg /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_MDV Problem opening netcdf file: ''",A,"''")') & + trim(flnm) +#endif + return + end if + + ierr = nf_inq_varid(ncid, "precip", varid) + if(ierr /= 0) ierr_flg = ierr + if (ierr /= 0) then + ierr = nf_inq_varid(ncid, "precip_rate", varid) !recheck variable name... + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & + trim(flnm) +#endif + end if + ierr_flg = ierr + mmflag = 1 + end if + ierr = nf_get_var_real(ncid, varid, pcp) + ierr = nf_close(ncid) + + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm) +#endif + end if + + end subroutine READFORC_MDV + + + + subroutine READFORC_NAMPCP(flnm,ix,jx,pcp,k,product) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + integer, intent(in) :: k + character(len=*), intent(in) :: product + integer :: it,jew,zsn + parameter(it = 496,jew = 449, zsn = 499) ! domain 1 +! parameter(it = 496,jew = 74, zsn = 109) ! domain 2 + real, dimension(it,jew,zsn) :: buf + real, dimension(ix,jx), intent(out) :: pcp + + character(len=256) :: units + integer :: ierr,i,j,i2,j2,varid + integer :: ncid + real, dimension(ix,jx) :: temp + +! varname = trim(product) + +!open NetCDF file... + if (k.eq.1.) then + ierr = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_NAMPCP1 Problem opening netcdf file: ''",A, "''")') & + trim(flnm) +#endif + call hydro_stop("READFORC_NAMPCP") + end if + + ierr = nf_inq_varid(ncid, trim(product), varid) + ierr = nf_get_var_real(ncid, varid, buf) + ierr = nf_close(ncid) + + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_NAMPCP2 Problem reading netcdf file: ''", A,"''")') & + trim(flnm) +#endif + call hydro_stop("READFORC_NAMPCP") + end if + endif +#ifdef HYDRO_D + print *, "Data read in...",it,ix,jx,k +#endif + +! Extract single time slice from dataset... + + do i=1,ix + do j=1,jx + pcp(i,j) = buf(k,i,j) + end do + end do + +! call get_2d_netcdf_ruc("trmm",ncid, pcp, jx, ix,k, .true., ierr) + + end subroutine READFORC_NAMPCP + + + + + subroutine READFORC_COWS(flnm,ix,jx,target_date, t,q,u,p,lw,sw,pcp,tlevel) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + character(len=*), intent(in) :: target_date + real, dimension(ix,jx), intent(out) :: t + real, dimension(ix,jx), intent(out) :: q + real, dimension(ix,jx), intent(out) :: u + real, dimension(ix,jx) :: v + real, dimension(ix,jx), intent(out) :: p + real, dimension(ix,jx), intent(out) :: lw + real, dimension(ix,jx), intent(out) :: sw + real, dimension(ix,jx), intent(out) :: pcp + integer tlevel + + character(len=256) :: units + integer :: ierr + integer :: ncid + + ! Open the NetCDF file. + ierr = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_COWS Problem opening netcdf file: ''", A, "''")') trim(flnm) +#endif + call hydro_stop("READFORC_COWS") + endif + + call get_2d_netcdf_cows("TA2", ncid, t, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("QV2", ncid, q, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("WSPD10", ncid, u, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("PRES", ncid, p, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("GLW", ncid, lw, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("RSD", ncid, sw, ix, jx,tlevel, .TRUE., ierr) + call get_2d_netcdf_cows("RAIN", ncid, pcp, ix, jx,tlevel, .TRUE., ierr) +!yw call get_2d_netcdf_cows("V2D", ncid, v, ix, jx,tlevel, .TRUE., ierr) + + ierr = nf_close(ncid) + + end subroutine READFORC_COWS + + + + + subroutine READFORC_RUC(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) + + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + character(len=*), intent(in) :: target_date + real, dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc + integer tlevel + + character(len=256) :: units + integer :: ierr + integer :: ncid + + tlevel = 1 + + ! Open the NetCDF file. + ierr = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READFORC_RUC Problem opening netcdf file: ''", A, "''")') trim(flnm) +#endif + call hydro_stop("READFORC_RUC") + endif + + call get_2d_netcdf_ruc("T2", ncid, t, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("Q2", ncid, q, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("U10", ncid, u, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("V10", ncid, v, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("PSFC", ncid, p, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("GLW", ncid, lw, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("SWDOWN", ncid, sw, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) + + ierr = nf_close(ncid) + + +!DJG Add the convective and non-convective rain components (note: conv. comp=0 +!for cloud resolving runs...) +!DJG Note that for RUC these are accumulated values to be adjusted to rates in +!driver... + + pcp=pcp+pcpc ! assumes pcpc=0 for resolved convection... + + end subroutine READFORC_RUC + + + + + subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) + implicit none + + character(len=*), intent(in) :: flnm + integer, intent(in) :: ix + integer, intent(in) :: jx + real, dimension(ix,jx), intent(out) :: weasd + real, dimension(ix,jx), intent(out) :: snodep + real, dimension(ix,jx) :: tmp + + character(len=256) :: units + integer :: ierr + integer :: ncid,i,j + + ! Open the NetCDF file. + + ierr = nf_open(flnm, NF_NOWRITE, ncid) + if (ierr /= 0) then +#ifdef HYDRO_D + write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm) +#endif + call hydro_stop("READSNOW_FORC") + endif + + call get_2d_netcdf("WEASD", ncid, tmp, units, ix, jx, .FALSE., ierr) + if (ierr /= 0) then + call get_2d_netcdf("SNOW", ncid, tmp, units, ix, jx, .FALSE., ierr) + if (ierr == 0) then + units = "mm" + print *, "read WEASD from wrfoutput ...... " + weasd = tmp * 1.E-3 + endif + else + weasd = tmp + if (trim(units) == "m") then + ! No conversion necessary + else if (trim(units) == "mm") then + ! convert WEASD from mm to m + weasd = weasd * 1.E-3 + endif + endif + + if (ierr /= 0) then +#ifdef HYDRO_D + print *, "!!!!! NO WEASD present in input file...initialize to 0." +#endif + endif + + + call get_2d_netcdf("SNODEP", ncid, tmp, units, ix, jx, .FALSE., ierr) + if (ierr /= 0) then + ! Quick assumption regarding snow depth. + call get_2d_netcdf("SNOWH", ncid, tmp, units, ix, jx, .FALSE., ierr) + if(ierr .eq. 0) then + print *, "read snow depth from wrfoutput ... " + snodep = tmp + endif + else + snodep = tmp + endif + + if (ierr /= 0) then + ! Quick assumption regarding snow depth. +!yw snodep = weasd * 10. + where(snodep .lt. weasd) snodep = weasd*10 !set lower bound to correct bi-lin interp err... + endif + +!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... + where(snodep .lt. 0) snodep = 0 + where(weasd .lt. 0) weasd = 0 + +!yw do i=1,ix +!yw do j=1,jx +!yw if (WEASD(i,j).lt.0.) WEASD(i,j)=0.0 !set lower bound to correct bi-lin interp err... +!yw if (snodep(i,j).lt.0.) snodep(i,j)=0.0 !set lower bound to correct bi-lin interp err... +!yw end do +!yw end do + + ierr = nf_close(ncid) + + end subroutine READSNOW_FORC + + subroutine get2d_hrldas(inflnm,ix,jx,nsoil,smc,stc,sh2ox,cmc,t1,weasd,snodep) + implicit none + integer :: iret,varid,ncid,ix,jx,nsoil,ierr + real,dimension(ix,jx):: weasd,snodep,cmc,t1 + real,dimension(ix,jx,nsoil):: smc,stc,sh2ox + character(len=*), intent(in) :: inflnm + character(len=256):: units + iret = nf_open(trim(inflnm), NF_NOWRITE, ncid) + if(iret .ne. 0 )then +#ifdef HYDRO_D + write(6,*) "Error: failed to open file :",trim(inflnm) +#endif + call hydro_stop("get2d_hrldas") + endif + + call get2d_hrldas_real("CMC", ncid, cmc, ix, jx) + call get2d_hrldas_real("TSKIN", ncid, t1, ix, jx) + call get2d_hrldas_real("SWE", ncid, weasd, ix, jx) + call get2d_hrldas_real("SNODEP", ncid, snodep, ix, jx) + + call get2d_hrldas_real("SOIL_T_1", ncid, stc(:,:,1), ix, jx) + call get2d_hrldas_real("SOIL_T_2", ncid, stc(:,:,2), ix, jx) + call get2d_hrldas_real("SOIL_T_3", ncid, stc(:,:,3), ix, jx) + call get2d_hrldas_real("SOIL_T_4", ncid, stc(:,:,4), ix, jx) + call get2d_hrldas_real("SOIL_T_5", ncid, stc(:,:,5), ix, jx) + call get2d_hrldas_real("SOIL_T_6", ncid, stc(:,:,6), ix, jx) + call get2d_hrldas_real("SOIL_T_7", ncid, stc(:,:,7), ix, jx) + call get2d_hrldas_real("SOIL_T_8", ncid, stc(:,:,8), ix, jx) + + call get2d_hrldas_real("SOIL_M_1", ncid, SMC(:,:,1), ix, jx) + call get2d_hrldas_real("SOIL_M_2", ncid, SMC(:,:,2), ix, jx) + call get2d_hrldas_real("SOIL_M_3", ncid, SMC(:,:,3), ix, jx) + call get2d_hrldas_real("SOIL_M_4", ncid, SMC(:,:,4), ix, jx) + call get2d_hrldas_real("SOIL_M_5", ncid, SMC(:,:,5), ix, jx) + call get2d_hrldas_real("SOIL_M_6", ncid, SMC(:,:,6), ix, jx) + call get2d_hrldas_real("SOIL_M_7", ncid, SMC(:,:,7), ix, jx) + call get2d_hrldas_real("SOIL_M_8", ncid, SMC(:,:,8), ix, jx) + + call get2d_hrldas_real("SOIL_W_1", ncid, SH2OX(:,:,1), ix, jx) + call get2d_hrldas_real("SOIL_W_2", ncid, SH2OX(:,:,2), ix, jx) + call get2d_hrldas_real("SOIL_W_3", ncid, SH2OX(:,:,3), ix, jx) + call get2d_hrldas_real("SOIL_W_4", ncid, SH2OX(:,:,4), ix, jx) + call get2d_hrldas_real("SOIL_W_5", ncid, SH2OX(:,:,5), ix, jx) + call get2d_hrldas_real("SOIL_W_6", ncid, SH2OX(:,:,6), ix, jx) + call get2d_hrldas_real("SOIL_W_7", ncid, SH2OX(:,:,7), ix, jx) + call get2d_hrldas_real("SOIL_W_8", ncid, SH2OX(:,:,8), ix, jx) + + iret = nf_close(ncid) + return + end subroutine get2d_hrldas + + subroutine get2d_hrldas_real(var_name,ncid,out_buff,ix,jx) + implicit none + integer ::iret,varid,ncid,ix,jx + real out_buff(ix,jx) + character(len=*), intent(in) :: var_name + iret = nf_inq_varid(ncid,trim(var_name), varid) + iret = nf_get_var_real(ncid, varid, out_buff) + return + end subroutine get2d_hrldas_real + + subroutine read_stage4(flnm,IX,JX,pcp) + integer IX,JX,ierr,ncid,i,j + real pcp(IX,JX),buf(ix,jx) + character(len=*), intent(in) :: flnm + character(len=256) :: units + + ierr = nf_open(flnm, NF_NOWRITE, ncid) + + if(ierr .ne. 0) then + call hydro_stop("read_stage4") + endif + + call get_2d_netcdf("RAINRATE",ncid, buf, units, ix, jx, .TRUE., ierr) + ierr = nf_close(ncid) + do j = 1, jx + do i = 1, ix + if(buf(i,j) .lt. 0) then + buf(i,j) = pcp(i,j) + end if + end do + end do + pcp = buf + return + END subroutine read_stage4 + + + + + subroutine read_hydro_forcing_seq( & + indir,olddate,hgrid, & + ix,jx,forc_typ,snow_assim, & + T2,q2x,u,v,pres,xlong,short,prcp1,& + lai,fpar,snodep,dt,k,prcp_old) +! This subrouting is going to read different forcing. + implicit none + ! in variable + character(len=*) :: olddate,hgrid,indir + character(len=256) :: filename + integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop + real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& + prcpnew,weasd,snodep,prcp0,prcp2,prcp_old + real :: dt, wrf_dt + ! tmp variable + character(len=256) :: inflnm, inflnm2, product + integer :: i,j,mmflag,ierr_flg + real,dimension(ix,jx):: lai,fpar + character(len=4) nwxst_t + logical :: fexist + + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + ".LDASIN_DOMAIN"//hgrid + +!!!DJG... Call READFORC_(variable) Subroutine for forcing data... +!!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!) + if(FORC_TYP.eq.1) then +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + ".LDASIN_DOMAIN"//hgrid + + inquire (file=trim(inflnm), exist=fexist) + if ( .not. fexist ) then +#ifdef HYDRO_D + print*, "no forcing data found", inflnm +#endif + call hydro_stop("read_hydro_forcing_seq") + endif + + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + end if + + + + +!!!DJG HRLDAS Forcing with minute format filename (NOTE: precip must be in mm/s!!!) + if(FORC_TYP.eq.2) then +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".LDASIN_DOMAIN"//hgrid + inquire (file=trim(inflnm), exist=fexist) + if ( .not. fexist ) then +#ifdef HYDRO_D + print*, "no forcing data found", inflnm +#endif + call hydro_stop("read_hydro_forcing_seq") + endif + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + end if + + + + + +!!!DJG WRF Output File Direct Ingest Forcing... + if(FORC_TYP.eq.3) then +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//& + "_"//olddate(12:13)//":00:00" + + inquire (file=trim(inflnm), exist=fexist) + if ( .not. fexist ) then +#ifdef HYDRO_D + print*, "no forcing data found", inflnm +#endif + call hydro_stop("read_hydro_forcing_seq") + endif + + do i_forcing = 1, int(24*3600/dt) + wrf_dt = i_forcing*dt + call geth_newdate(out_date,olddate,nint(wrf_dt)) + inflnm2 = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& + "_"//out_date(12:13)//":00:00" + inquire (file=trim(inflnm2), exist=fexist) + if (fexist ) goto 991 + end do +991 continue + +#ifdef HYDRO_D + if(.not. fexist) then + write(6,*) "Error: could not find file ",trim(inflnm2) + call hydro_stop("read_hydro_forcing_seq") + endif + print*, "read WRF forcing data: ", trim(inflnm) + print*, "read WRF forcing data: ", trim(inflnm2) +#endif + CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCPnew,lai,fpar) + CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,prcp0,lai,fpar) + PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) + + end if + + + + + +!!!DJG CONSTant, idealized forcing... + if(FORC_TYP.eq.4) then +! Impose a fixed diurnal cycle... +! assumes model timestep is 1 hr +! assumes K=1 is 12z (Ks or ~ sunrise) +! First Precip... +! IF (K.GE.1 .and. K.LE.2) THEN + IF (K.EQ.1) THEN + PRCP1 =25.4/3600.0 !units mm/s (Simulates 1"/hr for first time step...) +! PRCP1 =0./3600.0 !units mm/s (Simulates 1"/hr for first time step...) + ELSEIF (K.GT.1) THEN +! PRCP1 =0./3600.0 !units mm/s +! ELSE + PRCP1 = 0. + END IF +! PRCP1 = 0. +! PRCP1 =10./3600.0 !units mm/s +! Other Met. Vars... + T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + Q2X = 0.01 + U = 1.0 + V = 1.0 + PRES = 100000.0 + XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + end if + + + + + +!!!DJG Idealized Met. w/ Specified Precip. Forcing Data...(Note: input precip units here are in 'mm/hr') +! This option uses hard-wired met forcing EXCEPT precipitation which is read in +! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' +! + if(FORC_TYP.eq.5) then +! Standard Met. Vars... + T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + Q2X = 0.01 + U = 1.0 + V = 1.0 + PRES = 100000.0 + XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) + +!Get specified precip.... +!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +! product = "trmm" +! inflnm = trim(indir)//"/"//"sat_domain1.nc" +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".PRECIP_FORCING.nc" + inquire (file=trim(inflnm), exist=fexist) + if ( .not. fexist ) then +#ifdef HYDRO_D + print*, "no specified precipitation data found", inflnm +#endif + call hydro_stop("read_hydro_forcing_seq") + endif + + PRCP1 = 0. + PRCP_old = PRCP1 + +#ifdef HYDRO_D + print *, "Opening supplemental precipitation forcing file...",inflnm +#endif + CALL READFORC_MDV(inflnm,IX,JX, & + PRCP2,mmflag,ierr_flg) + +!If radar or spec. data is ok use if not, skip to original NARR data... + IF (ierr_flg.eq.0) then ! use spec. precip +!Convert units if necessary + IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... + PRCP1=PRCP2/DT !convert from mm to mm/s +#ifdef HYDRO_D + print*, "Supplemental pcp is accumulated pcp/dt. " +#endif + else + PRCP1=PRCP2 !assumes PRCP2 is in mm/s +#ifdef HYDRO_D + print*, "Supplemental pcp is rate. " +#endif + END IF ! Endif mmflag + ELSE ! either stop or default to original forcing data... +#ifdef HYDRO_D + print *,"Current RADAR precip data not found !!! Using previous available file..." +#endif + PRCP1 = PRCP_old + END IF ! Endif ierr_flg + +! Loop through data to screen for plausible values + do i=1,ix + do j=1,jx + if (PRCP1(i,j).lt.0.) PRCP1(i,j)= PRCP_old(i,j) + if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889 !set max pcp intens = 500 mm/h + end do + end do + + end if + + + + + +!!!DJG HRLDAS Forcing with hourly format filename with specified precipitation forcing... +! This option uses HRLDAS-formatted met forcing EXCEPT precipitation which is read in +! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' + + if(FORC_TYP.eq.6) then + +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + ".LDASIN_DOMAIN"//hgrid + + inquire (file=trim(inflnm), exist=fexist) + + if ( .not. fexist ) then + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".LDASIN_DOMAIN"//hgrid + inquire (file=trim(inflnm), exist=fexist) + endif + + + if ( .not. fexist ) then +#ifdef HYDRO_D + print*, "no ATM forcing data found at this time", inflnm +#endif + else +#ifdef HYDRO_D + print*, "reading forcing data at this time", inflnm +#endif + + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCP1,LAI,FPAR) + PRCP_old = PRCP1 ! This assigns new precip to last precip as a fallback for missing data... + endif + + +!Get specified precip.... +!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".PRECIP_FORCING.nc" + inquire (file=trim(inflnm), exist=fexist) +#ifdef HYDRO_D + if(fexist) then + print*, "using specified pcp forcing: ",trim(inflnm) + else + print*, "no specified pcp forcing: ",trim(inflnm) + endif +#endif + if ( .not. fexist ) then + prcp1 = PRCP_old ! for missing pcp data use analysis/model input + else + CALL READFORC_MDV(inflnm,IX,JX, & + PRCP2,mmflag,ierr_flg) +!If radar or spec. data is ok use if not, skip to original NARR data... + if(ierr_flg .ne. 0) then +#ifdef HYDRO_D + print*, "Warning: pcp reading problem: ", trim(inflnm) +#endif + PRCP1=PRCP_old + else + PRCP1=PRCP2 !assumes PRCP2 is in mm/s + IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... + PRCP1=PRCP2/DT !convert from mm to mm/s + END IF ! Endif mmflag +#ifdef HYDRO_D + print*, "replace pcp successfully! ",trim(inflnm) +#endif + endif + endif + + +! Loop through data to screen for plausible values + where(PRCP1 .lt. 0) PRCP1=PRCP_old + where(PRCP1 .gt. 10 ) PRCP1= PRCP_old + do i=1,ix + do j=1,jx + if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0 + if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889 !set max pcp intens = 500 mm/h + end do + end do +! write(80,*) prcp1 +! call hydro_stop("9999") + + end if + + +!!!! FORC_TYP 7: uses WRF forcing data plus additional pcp forcing. + + if(FORC_TYP.eq.7) then + +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//& + "_"//olddate(12:13)//":00:00" + + inquire (file=trim(inflnm), exist=fexist) + + + if ( .not. fexist ) then +#ifdef HYDRO_D + print*, "no forcing data found", inflnm +#endif + else + do i_forcing = 1, int(24*3600/dt) + wrf_dt = i_forcing*dt + call geth_newdate(out_date,olddate,nint(wrf_dt)) + inflnm2 = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& + "_"//out_date(12:13)//":00:00" + inquire (file=trim(inflnm2), exist=fexist) + if (fexist ) goto 992 + end do +992 continue + +#ifdef HYDRO_D + print*, "read WRF forcing data: ", trim(inflnm) + print*, "read WRF forcing data: ", trim(inflnm2) +#endif + CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCPnew,lai,fpar) + CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,prcp0,lai,fpar) + PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) + PRCP_old = PRCP1 + endif + +!Get specified precip.... +!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".PRECIP_FORCING.nc" + inquire (file=trim(inflnm), exist=fexist) +#ifdef HYDRO_D + if(fexist) then + print*, "using specified pcp forcing: ",trim(inflnm) + else + print*, "no specified pcp forcing: ",trim(inflnm) + endif +#endif + if ( .not. fexist ) then + prcp1 = PRCP_old ! for missing pcp data use analysis/model input + else + CALL READFORC_MDV(inflnm,IX,JX, & + PRCP2,mmflag,ierr_flg) +!If radar or spec. data is ok use if not, skip to original NARR data... + if(ierr_flg .ne. 0) then +#ifdef HYDRO_D + print*, "Warning: pcp reading problem: ", trim(inflnm) +#endif + PRCP1=PRCP_old + else + PRCP1=PRCP2 !assumes PRCP2 is in mm/s + IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... + write(6,*) "using supplemental pcp time interval ", DT + PRCP1=PRCP2/DT !convert from mm to mm/s + else + write(6,*) "using supplemental pcp rates " + END IF ! Endif mmflag +#ifdef HYDRO_D + print*, "replace pcp successfully! ",trim(inflnm) +#endif + endif + endif + + +! Loop through data to screen for plausible values + where(PRCP1 .lt. 0) PRCP1=PRCP_old + where(PRCP1 .gt. 10 ) PRCP1= PRCP_old ! set maximum to be 500 mm/h + where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h + end if + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!The other forcing data types below here are obsolete and left for reference... +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!DJG HRLDAS Single Input with Multiple Input Times File Forcing... +! if(FORC_TYP.eq.6) then +!!Create forcing data filename... +! if (len_trim(range) == 0) then +! inflnm = trim(indir)//"/"//& +! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& +! olddate(15:16)//".LDASIN_DOMAIN"//hgrid//"_multiple" +!! "MET_LIS_CRO_2D_SANTEE_LU_1KM."//& +!! ".156hrfcst.radar" +! else +! endif +! CALL READFORC_HRLDAS_mult(inflnm,IX,JX,OLDDATE,T2,Q2X,U, & +! PRES,XLONG,SHORT,PRCP1,K) +! +!! IF (K.GT.0.AND.K.LT.10) THEN +!! PRCP1 = 10.0/3600.0 ! units mm/s +!! PRCP1 = 0.254/3600.0 +!! ELSE +!! PRCP1 = 0. +!! END IF +! endif + + + +!!!!!DJG NARR Met. w/ NARR Precip. Forcing Data... +!! Assumes standard 3-hrly NARR data has been resampled to NDHMS grid... +!! Assumes one 3hrly time-step per forcing data file +!! Input precip units here are in 'mm' accumulated over 3 hrs... +! if(FORC_TYP.eq.7) then !NARR Met. w/ NARR Precip. +!!!Create forcing data filename... +! if (len_trim(range) == 0) then +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid +! else +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) +! endif +! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & +! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) +! PRCP1=PRCP1/(3.0*3600.0) ! convert from 3hr accum to mm/s which is what NDHMS expects +! end if !NARR Met. w/ NARR Precip. + + + + + + +!!!!DJG NARR Met. w/ Specified Precip. Forcing Data... +! if(FORC_TYP.eq.8) then !NARR Met. w/ Specified Precip. +! +!!Check to make sure if Noah time step is 3 hrs as is NARR... +! +! PRCP_old = PRCP1 +! +! if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then !if/then 3 hr check +!!!Create forcing data filename... +! if (len_trim(range) == 0) then +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid +!! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& +!! ".48hrfcst.ncf" +! else +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) +! endif +! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & +! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) +!! PRCP1=PRCP1/(3.0*3600.0) !NARR 3hrly precip product in mm +! PRCP1=PRCP1 !NAM model data in mm/s +! end if !3 hr check +! +! +!!Get spec. precip.... +!! NAM Remote sensing... +!!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +!! product = "trmm" +!! inflnm = trim(indir)//"/"//"sat_domain1.nc" +!!! inflnm = trim(indir)//"/"//"sat_domain2.nc" +!! PRCP1 = 0. +!! CALL READFORC_NAMPCP(inflnm,IX,JX, & +!! PRCP2,K,product) +!! ierr_flg = 0 +!! mmflag = 0 +!!!Convert pcp grid to units of mm/s... +!! PRCP1=PRCP1/(3.0*3600.0) !3hrly precip product +! +!!Read from filelist (NAME HE...,others)... +!! if (K.eq.1) then +!! open(unit=93,file="filelist.txt",form="formatted",status="old") +!! end if +!! read (93,*) filename +!! inflnm = trim(indir)//"/"//trim(filename) +!! +!! +!!Front Range MDV Radar... +! +!! inflnm = "/ptmp/weiyu/rt_2008/radar_obs/"//& +!! inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//& +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +!! olddate(15:16)//"_radar.nc" +!! olddate(15:16)//"_chill.nc" +! +!! inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/Big_Thomp_04/"//& +!! inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//& +!! inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//& +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +!! olddate(15:16)//"00_Pcp60min.nc" +!! olddate(15:16)//"00_Pcp30min.nc" +!! olddate(15:16)//"00_30min.nc" +! olddate(15:16)//"00_Pcp5min.nc" +!! olddate(15:16)//"_chill.nc" +! +!! inflnm = "/d2/hydrolab/HRLDAS/forcing/COWS/"//& +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& +!! olddate(15:16)//"00_Pcp5min.nc" +!! olddate(15:16)//"00_5.nc" +! +!! inflnm = "" ! use this for NAM frxst runs with 30 min time-step +!! +! +! +!! if (K.le.6) then ! use for 30min nowcast... +!! if (K.eq.1) then +!! open(unit=94,file="start_file.txt",form="formatted",status="replace") +!!! inflnm2 = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//& +!! inflnm2 = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/"//& +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& +!! olddate(15:16)//"00_" +!! close(94) +!! nwxst_t = "5"! calc minutes from timestep and convert to char... +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! if (K.eq.2) then +!! nwxst_t = "10" ! calc minutes from timestep and convert to char... +!! open(unit=94,file="start_file.txt",form="formatted",status="old") +!! read (94,*) inflnm2 +!! close(94) +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! if (K.eq.3) then +!! nwxst_t = "15" ! calc minutes from timestep and convert to char... +!! open(unit=94,file="start_file.txt",form="formatted",status="old") +!! read (94,*) inflnm +!! close(94) +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! if (K.eq.4) then +!! nwxst_t = "20" ! calc minutes from timestep and convert to char... +!! open(unit=94,file="start_file.txt",form="formatted",status="old") +!! read (94,*) inflnm +!! close(94) +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! if (K.eq.5) then +!! nwxst_t = "25" ! calc minutes from timestep and convert to char... +!! open(unit=94,file="start_file.txt",form="formatted",status="old") +!! read (94,*) inflnm +!! close(94) +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! if (K.eq.6) then +!! nwxst_t = "30" ! calc minutes from timestep and convert to char... +!! open(unit=94,file="start_file.txt",form="formatted",status="old") +!! read (94,*) inflnm +!! close(94) +!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" +!! end if +!! else +!! inflnm = "" ! use this for NAM frxst runs with 30 min time-step +!! end if +! +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& +!! olddate(15:16)//"00_Pcp30minMerge.nc" +! +! CALL READFORC_MDV(inflnm,IX,JX, & +! PRCP2,mmflag,ierr_flg) +! +!!If radar or spec. data is ok use if not, skip to original NARR data... +! IF (ierr_flg.eq.0) then ! use spec. precip +! PRCP1=PRCP2 !assumes PRCP2 is in mm/s +!!Convert units if necessary +! IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... +! PRCP1=PRCP2/DT !convert from mm to mm/s +! END IF ! Endif mmflag +! ELSE ! either stop or default to original forcing data... +! PRCP1 = PRCP_old +! END IF ! Endif ierr_flg +! +!! Loop through data to screen for plausible values +! do i=1,ix +! do j=1,jx +! if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0 +! if (PRCP1(i,j).gt.0.0555) PRCP1(i,j)=0.0555 !set max pcp intens = 200 mm/h +!! PRCP1(i,j) = 0. +!! PRCP1(i,j) = 0.02 !override w/ const. precip for gw testing only... +! end do +! end do +! +!! if (K.eq.1) then ! quick dump for site specific precip... +! open(unit=94,file="Christman_accumpcp.txt",form="formatted",status="new") +! end if +! +! +! end if !NARR Met. w/ Specified Precip. + + + + + +!!!!DJG NLDAS Met. w/ NLDAS Precip. Forcing Data... +!! Assumes standard hrly NLDAS data has been resampled to NDHMS grid... +!! Assumes one 1-hrly time-step per forcing data file +!! Input precip units here are in 'mm' accumulated over 1 hr... +! if(FORC_TYP.eq.9) then !NLDAS Met. w/ NLDAS Precip. +!!!Create forcing data filename... +! if (len_trim(range) == 0) then +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +!!Use this for minute forcing... olddate(15:16)//".LDASIN_DOMAIN"//hgrid +! ".LDASIN_DOMAIN"//hgrid +! else +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) +! endif +! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & +! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) +! PRCP1=PRCP1/(1.0*3600.0) ! convert hourly NLDAS hourly accum pcp to mm/s which is what NDHMS expects +! end if !NLDAS Met. w/ NLDAS Precip. + + + + + +!!!!DJG NARR Met. w/ DMIP Precip. & Temp. Forcing Data... +! if(FORC_TYP.eq.10) then ! If/Then for DMIP forcing data... +!!Check to make sure if Noah time step is 3 hrs as is NARR... +! +! if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then !if/then 3 hr check +!!!Create forcing data filename... +! if (len_trim(range) == 0) then +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid +!! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& +!! ".48hrfcst.ncf" +! else +! inflnm = trim(indir)//"/"//& +! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) +! endif +! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & +! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) +! PRCP1=PRCP1/(3.0*3600.0) ! convert to mm/s which is what HRLDAS expects +! end if !3 hr check +! +!!Get DMIP Precip... +!! inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/PRECIP_HRAP/precip_finished"//"/"//& +! inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/PRECIP_HRAP"//"/"//& +! "proj.xmrg"//& +! olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//& +! "z.asc" +! PRCP1 = 0. +! CALL READFORC_DMIP(inflnm,IX,JX,PRCP1) +! PRCP1 = PRCP1 / 100.0 ! Convert from native hundreths of mm to mm +!! IF (K.LT.34) THEN +!! PRCP1 = 5.0/3600.0 ! units mm/s +!!! ELSE +!!! PRCP1 = 0. +!! END IF +! +!!Get DMIP Temp... +!! inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/TEMP_HRAP/tair_finished"//"/"//& +! inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/TEMP_HRAP"//"/"//& +! "proj.tair"//& +! olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//& +! "z.asc" +! CALL READFORC_DMIP(inflnm,IX,JX,T2) +! T2 = (5./9.)*(T2-32.0) + 273.15 !Convert from deg F to deg K +! +! end if !End if for DMIP forcing data... +! +! +! +!! : add reading forcing precipitation data +!! ywinflnm = "/ptmp/weiyu/hrldas/v2/st4"//"/"//& +!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& +!! ".LDASIN_DOMAIN2" +!! call read_stage4(ywinflnm,IX,JX,PRCP1) +!!end yw +! +! +!!!!DJG Check for snow data assimilation... + + if (SNOW_ASSIM .eq. 1) then + +! Every 24 hours, update the snow field from analyses. + if(forc_typ .ne. 3 .or. forc_typ .ne. 6) then + if ( OLDDATE(12:13) == "00") then + CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP) + endif + else + CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP) + endif + + end if + + + end subroutine read_hydro_forcing_seq + + +#ifdef MPP_LAND + subroutine mpp_readland_hrldas(geo_static_flnm,& + ix,jx,land_cat,soil_cat,& + vegtyp,soltyp,terrain,latitude,longitude,& + global_nx,global_ny,SOLVEG_INITSWC) + implicit none + character(len=*), intent(in) :: geo_static_flnm + integer, intent(in) :: ix, jx, land_cat, soil_cat, & + global_nx,global_ny,SOLVEG_INITSWC + integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp + real, dimension(ix,jx), intent(out) :: terrain, latitude, longitude + real, dimension(global_nx,global_ny) ::g_terrain, g_latitude, g_longitude + integer, dimension(global_nx,global_ny) :: g_vegtyp, g_soltyp + + character(len=256) :: units + integer :: ierr + integer :: ncid,varid + real, dimension(ix,jx) :: xdum + integer flag ! flag = 1 from wrfsi, flag =2 from WPS. + if(my_id.eq.IO_id) then + CALL READLAND_HRLDAS(geo_static_flnm,global_nx, & + global_ny,LAND_CAT,SOIL_CAT, & + g_VEGTYP,g_SOLTYP,g_TERRAIN,g_LATITUDE,g_LONGITUDE, SOLVEG_INITSWC) + end if + ! distribute the data to computation node. + call mpp_land_bcast_int1(LAND_CAT) + call mpp_land_bcast_int1(SOIL_CAT) + call decompose_data_int(g_VEGTYP,VEGTYP) + call decompose_data_int(g_SOLTYP,SOLTYP) + call decompose_data_real(g_TERRAIN,TERRAIN) + call decompose_data_real(g_LATITUDE,LATITUDE) + call decompose_data_real(g_LONGITUDE,LONGITUDE) + return + end subroutine mpp_readland_hrldas + + + subroutine MPP_READSNOW_FORC(flnm,ix,jx,OLDDATE,weasd,snodep,& + global_nX, global_ny) + implicit none + + character(len=*), intent(in) :: flnm,OLDDATE + integer, intent(in) :: ix, global_nx,global_ny + integer, intent(in) :: jx + real, dimension(ix,jx), intent(out) :: weasd + real, dimension(ix,jx), intent(out) :: snodep + + real,dimension(global_nX, global_ny):: g_weasd, g_snodep + + character(len=256) :: units + integer :: ierr + integer :: ncid,i,j + + if(my_id .eq. IO_id) then + CALL READSNOW_FORC(trim(flnm),global_nX, global_ny,g_WEASD,g_SNODEP) + endif + call decompose_data_real(g_WEASD,WEASD) + call decompose_data_real(g_SNODEP,SNODEP) + + return + end subroutine MPP_READSNOW_FORC + + subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& + global_nX, global_ny,nsoil,out_SMC,out_SH2OX) + implicit none + + integer, intent(in) :: ix,global_nx,global_ny + integer, intent(in) :: jx,nsoil + real, dimension(ix,jx), intent(in) :: in_smcmax + real, dimension(ix,jx,nsoil), intent(out) :: out_smc,out_sh2ox + + real,dimension(global_nX, global_ny,nsoil):: g_smc, g_sh2ox + real,dimension(global_nX, global_ny):: g_smcmax + integer :: i,j,k + + + call write_IO_real(in_smcmax,g_smcmax) ! get global grid of smcmax + +#ifdef HYDRO_D + write (*,*) "In deep GW...", nsoil +#endif + +!loop to overwrite soils to saturation... + do i=1,global_nx + do j=1,global_ny + g_smc(i,j,1:NSOIL) = g_smcmax(i,j) + g_sh2ox(i,j,1:NSOIL) = g_smcmax(i,j) + end do + end do + +!decompose global grid to parallel tiles... + do k=1,nsoil + call decompose_data_real(g_smc(:,:,k),out_smc(:,:,k)) + call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k)) + end do + + return + end subroutine MPP_DEEPGW_HRLDAS + + + subroutine read_hydro_forcing_mpp( & + indir,olddate,hgrid, & + ix,jx,forc_typ,snow_assim, & + T2,q2x,u,v,pres,xlong,short,prcp1,& + lai,fpar,snodep,dt,k,prcp_old) +! This subrouting is going to read different forcing. + + + implicit none + ! in variable + character(len=*) :: olddate,hgrid,indir + character(len=256) :: filename + integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop + real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& + prcpnew,lai,fpar,snodep,prcp_old + real :: dt + ! tmp variable + character(len=256) :: inflnm, product + integer :: i,j,mmflag + real,dimension(global_nx,global_ny):: g_T2,g_Q2X,g_U,g_V,g_XLONG, & + g_SHORT,g_PRCP1,g_PRES,g_lai,g_snodep,g_prcp_old, g_fpar + integer flag + + + + call write_io_real(T2,g_T2) + call write_io_real(Q2X,g_Q2X) + call write_io_real(U,g_U) + call write_io_real(V,g_V) + call write_io_real(XLONG,g_XLONG) + call write_io_real(SHORT,g_SHORT) + call write_io_real(PRCP1,g_PRCP1) + call write_io_real(PRES,g_PRES) + call write_io_real(prcp_old,g_PRCP_old) + + call write_io_real(lai,g_lai) + call write_io_real(fpar,g_fpar) + call write_io_real(snodep,g_snodep) + + + + if(my_id .eq. IO_id) then + call read_hydro_forcing_seq( & + indir,olddate,hgrid,& + global_nx,global_ny,forc_typ,snow_assim, & + g_T2,g_q2x,g_u,g_v,g_pres,g_xlong,g_short,g_prcp1,& + g_lai,g_fpar,g_snodep,dt,k,g_prcp_old) +#ifdef HYDRO_D + write(6,*) "finish read forcing,olddate ",olddate +#endif + end if + + call decompose_data_real(g_T2,T2) + call decompose_data_real(g_Q2X,Q2X) + call decompose_data_real(g_U,U) + call decompose_data_real(g_V,V) + call decompose_data_real(g_XLONG,XLONG) + call decompose_data_real(g_SHORT,SHORT) + call decompose_data_real(g_PRCP1,PRCP1) + call decompose_data_real(g_prcp_old,prcp_old) + call decompose_data_real(g_PRES,PRES) + + call decompose_data_real(g_lai,lai) + call decompose_data_real(g_fpar,fpar) + call decompose_data_real(g_snodep,snodep) + + return + end subroutine read_hydro_forcing_mpp +#endif + + integer function nfeb_yw(year) + ! + ! Compute the number of days in February for the given year. + ! + implicit none + integer, intent(in) :: year ! Four-digit year + + nfeb_yw = 28 ! By default, February has 28 days ... + if (mod(year,4).eq.0) then + nfeb_yw = 29 ! But every four years, it has 29 days ... + if (mod(year,100).eq.0) then + nfeb_yw = 28 ! Except every 100 years, when it has 28 days ... + if (mod(year,400).eq.0) then + nfeb_yw = 29 ! Except every 400 years, when it has 29 days ... + if (mod(year,3600).eq.0) then + nfeb_yw = 28 ! Except every 3600 years, when it has 28 days. + endif + endif + endif + endif + end function nfeb_yw + + subroutine geth_newdate (ndate, odate, idt) + implicit none + + ! From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and + ! delta-time, compute the new date. + + ! on entry - odate - the old hdate. + ! idt - the change in time + + ! on exit - ndate - the new hdate. + + integer, intent(in) :: idt + character (len=*), intent(out) :: ndate + character (len=*), intent(in) :: odate + + ! Local Variables + + ! yrold - indicates the year associated with "odate" + ! moold - indicates the month associated with "odate" + ! dyold - indicates the day associated with "odate" + ! hrold - indicates the hour associated with "odate" + ! miold - indicates the minute associated with "odate" + ! scold - indicates the second associated with "odate" + + ! yrnew - indicates the year associated with "ndate" + ! monew - indicates the month associated with "ndate" + ! dynew - indicates the day associated with "ndate" + ! hrnew - indicates the hour associated with "ndate" + ! minew - indicates the minute associated with "ndate" + ! scnew - indicates the second associated with "ndate" + + ! mday - a list assigning the number of days in each month + + ! i - loop counter + ! nday - the integer number of days represented by "idt" + ! nhour - the integer number of hours in "idt" after taking out + ! all the whole days + ! nmin - the integer number of minutes in "idt" after taking out + ! all the whole days and whole hours. + ! nsec - the integer number of minutes in "idt" after taking out + ! all the whole days, whole hours, and whole minutes. + + integer :: newlen, oldlen + integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew + integer :: yrold, moold, dyold, hrold, miold, scold, frold + integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc + logical :: opass + character (len=10) :: hfrc + character (len=1) :: sp + logical :: punct + integer :: yrstart, yrend, mostart, moend, dystart, dyend + integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart + integer :: units + integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) +!yw integer nfeb_yw + + ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...." + if (odate(5:5) == "-") then + punct = .TRUE. + else + punct = .FALSE. + endif + + ! Break down old hdate into parts + + hrold = 0 + miold = 0 + scold = 0 + frold = 0 + oldlen = LEN(odate) + if (punct) then + yrstart = 1 + yrend = 4 + mostart = 6 + moend = 7 + dystart = 9 + dyend = 10 + hrstart = 12 + hrend = 13 + mistart = 15 + miend = 16 + scstart = 18 + scend = 19 + frstart = 21 + select case (oldlen) + case (10) + ! Days + units = 1 + case (13) + ! Hours + units = 2 + case (16) + ! Minutes + units = 3 + case (19) + ! Seconds + units = 4 + case (21) + ! Tenths + units = 5 + case (22) + ! Hundredths + units = 6 + case (23) + ! Thousandths + units = 7 + case (24) + ! Ten thousandths + units = 8 + case default +#ifdef HYDRO_D + write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' + call hydro_stop("in geth_newdate") +#endif + end select + + if (oldlen.ge.11) then + sp = odate(11:11) + else + sp = ' ' + end if + + else + + yrstart = 1 + yrend = 4 + mostart = 5 + moend = 6 + dystart = 7 + dyend = 8 + hrstart = 9 + hrend = 10 + mistart = 11 + miend = 12 + scstart = 13 + scend = 14 + frstart = 15 + + select case (oldlen) + case (8) + ! Days + units = 1 + case (10) + ! Hours + units = 2 + case (12) + ! Minutes + units = 3 + case (14) + ! Seconds + units = 4 + case (15) + ! Tenths + units = 5 + case (16) + ! Hundredths + units = 6 + case (17) + ! Thousandths + units = 7 + case (18) + ! Ten thousandths + units = 8 + case default +#ifdef HYDRO_D + write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' + call hydro_stop("in geth_newdate") +#endif + end select + endif + + ! Use internal READ statements to convert the CHARACTER string + ! date into INTEGER components. + + read(odate(yrstart:yrend), '(i4)') yrold + read(odate(mostart:moend), '(i2)') moold + read(odate(dystart:dyend), '(i2)') dyold + if (units.ge.2) then + read(odate(hrstart:hrend),'(i2)') hrold + if (units.ge.3) then + read(odate(mistart:miend),'(i2)') miold + if (units.ge.4) then + read(odate(scstart:scend),'(i2)') scold + if (units.ge.5) then + read(odate(frstart:oldlen),*) frold + end if + end if + end if + end if + + ! Set the number of days in February for that year. + + mday(2) = nfeb_yw(yrold) + + ! Check that ODATE makes sense. + + opass = .TRUE. + + ! Check that the month of ODATE makes sense. + + if ((moold.gt.12).or.(moold.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold +#endif + opass = .FALSE. + end if + + ! Check that the day of ODATE makes sense. + + if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold +#endif + opass = .FALSE. + end if + + ! Check that the hour of ODATE makes sense. + + if ((hrold.gt.23).or.(hrold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold +#endif + opass = .FALSE. + end if + + ! Check that the minute of ODATE makes sense. + + if ((miold.gt.59).or.(miold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold +#endif + opass = .FALSE. + end if + + ! Check that the second of ODATE makes sense. + + if ((scold.gt.59).or.(scold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold +#endif + opass = .FALSE. + end if + + ! Check that the fractional part of ODATE makes sense. + if (.not.opass) then +#ifdef HYDRO_D + write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen + call hydro_stop("in geth_newdate") +#endif + end if + + ! Date Checks are completed. Continue. + + + ! Compute the number of days, hours, minutes, and seconds in idt + + if (units.ge.5) then !idt should be in fractions of seconds + ifrc = oldlen-(frstart)+1 + ifrc = 10**ifrc + nday = abs(idt)/(86400*ifrc) + nhour = mod(abs(idt),86400*ifrc)/(3600*ifrc) + nmin = mod(abs(idt),3600*ifrc)/(60*ifrc) + nsec = mod(abs(idt),60*ifrc)/(ifrc) + nfrac = mod(abs(idt), ifrc) + else if (units.eq.4) then !idt should be in seconds + ifrc = 1 + nday = abs(idt)/86400 ! integer number of days in delta-time + nhour = mod(abs(idt),86400)/3600 + nmin = mod(abs(idt),3600)/60 + nsec = mod(abs(idt),60) + nfrac = 0 + else if (units.eq.3) then !idt should be in minutes + ifrc = 1 + nday = abs(idt)/1440 ! integer number of days in delta-time + nhour = mod(abs(idt),1440)/60 + nmin = mod(abs(idt),60) + nsec = 0 + nfrac = 0 + else if (units.eq.2) then !idt should be in hours + ifrc = 1 + nday = abs(idt)/24 ! integer number of days in delta-time + nhour = mod(abs(idt),24) + nmin = 0 + nsec = 0 + nfrac = 0 + else if (units.eq.1) then !idt should be in days + ifrc = 1 + nday = abs(idt) ! integer number of days in delta-time + nhour = 0 + nmin = 0 + nsec = 0 + nfrac = 0 + else +#ifdef HYDRO_D + write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & + oldlen + write(*,*) '#'//odate(1:oldlen)//'#' + call hydro_stop("in geth_newdate") +#endif + end if + + if (idt.ge.0) then + + frnew = frold + nfrac + if (frnew.ge.ifrc) then + frnew = frnew - ifrc + nsec = nsec + 1 + end if + + scnew = scold + nsec + if (scnew .ge. 60) then + scnew = scnew - 60 + nmin = nmin + 1 + end if + + minew = miold + nmin + if (minew .ge. 60) then + minew = minew - 60 + nhour = nhour + 1 + end if + + hrnew = hrold + nhour + if (hrnew .ge. 24) then + hrnew = hrnew - 24 + nday = nday + 1 + end if + + dynew = dyold + monew = moold + yrnew = yrold + do i = 1, nday + dynew = dynew + 1 + if (dynew.gt.mday(monew)) then + dynew = dynew - mday(monew) + monew = monew + 1 + if (monew .gt. 12) then + monew = 1 + yrnew = yrnew + 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb_yw(yrnew) + end if + end if + end do + + else if (idt.lt.0) then + + frnew = frold - nfrac + if (frnew .lt. 0) then + frnew = frnew + ifrc + nsec = nsec + 1 + end if + + scnew = scold - nsec + if (scnew .lt. 00) then + scnew = scnew + 60 + nmin = nmin + 1 + end if + + minew = miold - nmin + if (minew .lt. 00) then + minew = minew + 60 + nhour = nhour + 1 + end if + + hrnew = hrold - nhour + if (hrnew .lt. 00) then + hrnew = hrnew + 24 + nday = nday + 1 + end if + + dynew = dyold + monew = moold + yrnew = yrold + do i = 1, nday + dynew = dynew - 1 + if (dynew.eq.0) then + monew = monew - 1 + if (monew.eq.0) then + monew = 12 + yrnew = yrnew - 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb_yw(yrnew) + end if + dynew = mday(monew) + end if + end do + end if + + ! Now construct the new mdate + + newlen = LEN(ndate) + + if (punct) then + + if (newlen.gt.frstart) then + write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew + write(hfrc,'(i10)') frnew+1000000000 + ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + + else if (newlen.eq.scend) then + write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew +19 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2) + + else if (newlen.eq.miend) then + write(ndate,16) yrnew, monew, dynew, hrnew, minew +16 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2) + + else if (newlen.eq.hrend) then + write(ndate,13) yrnew, monew, dynew, hrnew +13 format(i4,'-',i2.2,'-',i2.2,'_',i2.2) + + else if (newlen.eq.dyend) then + write(ndate,10) yrnew, monew, dynew +10 format(i4,'-',i2.2,'-',i2.2) + + end if + + else + + if (newlen.gt.frstart) then + write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew + write(hfrc,'(i10)') frnew+1000000000 + ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + + else if (newlen.eq.scend) then + write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew +119 format(i4,i2.2,i2.2,i2.2,i2.2,i2.2) + + else if (newlen.eq.miend) then + write(ndate,116) yrnew, monew, dynew, hrnew, minew +116 format(i4,i2.2,i2.2,i2.2,i2.2) + + else if (newlen.eq.hrend) then + write(ndate,113) yrnew, monew, dynew, hrnew +113 format(i4,i2.2,i2.2,i2.2) + + else if (newlen.eq.dyend) then + write(ndate,110) yrnew, monew, dynew +110 format(i4,i2.2,i2.2) + + end if + + endif + + if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp + + end subroutine geth_newdate +end module module_lsm_forcing diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/module_noah_chan_param_init_rt.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/module_noah_chan_param_init_rt.F.svn-base new file mode 100644 index 00000000..ba40b76b --- /dev/null +++ b/wrfv2_fire/hydro/Routing/.svn/text-base/module_noah_chan_param_init_rt.F.svn-base @@ -0,0 +1,87 @@ +MODULE module_noah_chan_param_init_rt + + +CONTAINS +! +!----------------------------------------------------------------- + SUBROUTINE CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann) +!----------------------------------------------------------------- + + IMPLICIT NONE + + integer :: IINDEX, CHANCATS + integer :: ORDER + integer, PARAMETER :: NCHANTYPES=50 + real,dimension(NCHANTYPES) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann + character(LEN=11) :: DATATYPE + +!-----SPECIFY CHANNEL RELATED CHARACTERISTICS : +! ORDER: Strahler Stream Order +! BOTWID: Channel Bottom Width (meters) +! HLINK_INIT: Initial depth of flow in channel (meters) +! CHAN_SS: Channel side slope (assuming trapezoidal channel geom) +! CHMann: Channel Manning's N roughness coefficient + + +!-----READ IN CHANNEL PROPERTIES FROM CHANPARM.TBL : + OPEN(19, FILE='CHANPARM.TBL',FORM='FORMATTED',STATUS='OLD') + READ (19,*) + READ (19,2000,END=2002) DATATYPE +#ifdef HYDRO_D + PRINT *, DATATYPE +#endif + READ (19,*)CHANCATS,IINDEX +2000 FORMAT (A11) + +!-----Read in Channel Parameters as functions of stream order... + + IF(DATATYPE.EQ.'StreamOrder')THEN +#ifdef HYDRO_D + PRINT *, 'CHANNEL DATA SOURCE TYPE = ',DATATYPE,' FOUND', & + CHANCATS,' CATEGORIES' +#endif + DO ORDER=1,CHANCATS + READ (19,*)IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER), & + & CHMann(ORDER) + PRINT *, IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER), & + & CHMann(ORDER) + ENDDO + ENDIF + + +!-----Read in Channel Parameters as functions of ???other method??? (TBC)... + + +2002 CONTINUE + + CLOSE (19) + END SUBROUTINE CHAN_PARM_INIT + + + +#ifdef MPP_LAND + SUBROUTINE mpp_CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann) + use module_mpp_land, only: my_id, IO_id,mpp_land_bcast_int1, & + mpp_land_bcast_real,mpp_land_bcast_int,mpp_land_bcast_real1 + implicit none + integer :: IINDEX, CHANCATS + integer :: ORDER + integer, PARAMETER :: NCHANTYPES=50 + real,dimension(NCHANTYPES) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann + character(LEN=11) :: DATATYPE + + if(my_id.eq.io_id) then + call CHAN_PARM_INIT(BOTWID,HLINK_INIT,CHAN_SS,CHMann) + end if + call mpp_land_bcast_real(NCHANTYPES,BOTWID) + call mpp_land_bcast_real(NCHANTYPES,HLINK_INIT) + call mpp_land_bcast_real(NCHANTYPES,CHAN_SS) + call mpp_land_bcast_real(NCHANTYPES,CHMann) + return + END SUBROUTINE mpp_CHAN_PARM_INIT +#endif +!----------------------------------------------------------------- +!----------------------------------------------------------------- + + +END MODULE module_Noah_chan_param_init_rt diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/rtFunction.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/rtFunction.F.svn-base new file mode 100644 index 00000000..9334307f --- /dev/null +++ b/wrfv2_fire/hydro/Routing/.svn/text-base/rtFunction.F.svn-base @@ -0,0 +1,222 @@ + subroutine exeRouting (did) + use module_RT_data, only: rt_domain + use module_GW_baseflow_data, only: gw2d + use module_GW_baseflow, only: simp_gw_buck, gwstep + use module_channel_routing, only: drive_channel + use module_namelist, only: nlst_rt + +#ifdef MPP_LAND + use module_mpp_land +#endif + + + implicit none + integer did, i + real, dimension(RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT):: & + QSTRMVOLRT_DUM,LAKE_INFLORT_DUM, & + QSTRMVOLRT_TS, LAKE_INFLORT_TS + + real :: dx + integer ii,jj,kk + + + IF (nlst_rt(did)%SUBRTSWCRT.EQ.1 .or. nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) THEN + + QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT + LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT + +#ifdef HYDRO_D + write(6,*) "*****yw******start drive_RT " +#endif + + + +! write(6,*) "yyww RT_DOMAIN(did)%SH2OX(15,1,7)= ", RT_DOMAIN(did)%SH2OX(15,1,7) + + call drive_RT( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,& + RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%STC,RT_DOMAIN(did)%SH2OX, & + RT_DOMAIN(did)%INFXSRT,RT_DOMAIN(did)%SFCHEADRT,RT_DOMAIN(did)%SMCMAX1,& + RT_DOMAIN(did)%SMCREF1,RT_DOMAIN(did)%LKSAT, & + RT_DOMAIN(did)%SMCWLT1, RT_DOMAIN(did)%SMCRTCHK,RT_DOMAIN(did)%DSMC,& + RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SMCAGGRT,& + RT_DOMAIN(did)%STCAGGRT,RT_DOMAIN(did)%SH2OAGGRT, & + RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%SOLDEPRT,& + RT_DOMAIN(did)%INFXSAGGRT,RT_DOMAIN(did)%DHRT,RT_DOMAIN(did)%QSTRMVOLRT, & + RT_DOMAIN(did)%QBDRYRT,RT_DOMAIN(did)%LAKE_INFLORT,& + RT_DOMAIN(did)%SFCHEADSUBRT,RT_DOMAIN(did)%INFXSWGT,& + RT_DOMAIN(did)%LKSATRT, & + RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%OVROUGHRT,& + RT_DOMAIN(did)%QSUBRT,RT_DOMAIN(did)%ZWATTABLRT, & + RT_DOMAIN(did)%QSUBBDRYRT, & + RT_DOMAIN(did)%RETDEPRT,RT_DOMAIN(did)%SOXRT,RT_DOMAIN(did)%SOYRT,& + RT_DOMAIN(did)%SUB_RESID,RT_DOMAIN(did)%SMCRT,& + RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCWLTRT, & + RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%LAKE_MSKRT,& + RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%LSMVOL,RT_DOMAIN(did)%DSMCTOT, & + RT_DOMAIN(did)%SMCTOT1,& + RT_DOMAIN(did)%SMCTOT2,RT_DOMAIN(did)%suminfxs1, & + RT_DOMAIN(did)%suminfxsrt,RT_DOMAIN(did)%SO8RT, & + RT_DOMAIN(did)%SO8RT_D,nlst_rt(did)%AGGFACTRT, & + nlst_rt(did)%SUBRTSWCRT,nlst_rt(did)%OVRTSWCRT, & + RT_DOMAIN(did)%LAKE_CT, RT_DOMAIN(did)%STRM_CT, & + nlst_rt(did)%RT_OPTION,RT_DOMAIN(did)%OV_ROUGH, & + RT_DOMAIN(did)%INFXSAGG1RT,RT_DOMAIN(did)%SFCHEADAGG1RT,& + RT_DOMAIN(did)%SFCHEADAGGRT,& + nlst_rt(did)%DTRT, & + nlst_rt(did)%DT,RT_DOMAIN(did)%LAKE_INFLOTRT,& + RT_DOMAIN(did)%QBDRYTRT,RT_DOMAIN(did)%QSUBBDRYTRT,& + RT_DOMAIN(did)%QSTRMVOLTRT,RT_DOMAIN(did)%q_sfcflx_x,& + RT_DOMAIN(did)%q_sfcflx_y,RT_DOMAIN(did)%LKSATFAC,& + RT_DOMAIN(did)%OVROUGHRTFAC,rt_domain(did)%dist_lsm(:,:,9) ) + + QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-QSTRMVOLRT_DUM + LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-LAKE_INFLORT_DUM + +#ifdef HYDRO_D + write(6,*) "*****yw******end drive_RT " +#endif + end if + + + +!------------------------------------------------------------------ +!DJG Begin GW/Baseflow Routines +!------------------------------------------------------------------- + + IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN ! Switch to activate/specify GW/Baseflow + +! IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow + + If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then ! Call simple bucket baseflow scheme + +#ifdef HYDRO_D + write(6,*) "*****yw******start simp_gw_buck " +#endif + + call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& + RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%basns_area,& + RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & + RT_DOMAIN(did)%SOLDRAIN, & + RT_DOMAIN(did)%z_gwsubbas,& + RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& + RT_DOMAIN(did)%qinflowbase,& + RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & + RT_DOMAIN(did)%dist,nlst_rt(did)%DT,& + RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & + RT_DOMAIN(did)%z_max,& + nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT) + + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + + open (unit=51,file='GW_inflow.txt',form='formatted',& + status='unknown',position='append') + open (unit=52,file='GW_outflow.txt',form='formatted',& + status='unknown',position='append') + open (unit=53,file='GW_zlev.txt',form='formatted',& + status='unknown',position='append') + do i=1,RT_DOMAIN(did)%numbasns + write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i) +951 FORMAT(I3,1X,A19,1X,F11.3) + write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i) + write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i) + end do + close(51) + close(52) + close(53) +#ifdef MPP_LAND + endif +#endif + +#ifdef HYDRO_D + write(6,*) "*****yw******end simp_gw_buck " +#endif + +!!!For parameter setup runs output the percolation for each basin, +!!!otherwise comment out this output... + else if (nlst_rt(did)%GWBASESWCRT .eq. 3) then + +#ifdef HYDRO_D + write(6,*) "*****bf******start 2d_gw_model " +#endif + + DX = abs(nlst_rt(did)%DXRT0 * nlst_rt(did)%AGGFACTRT) + + call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & + gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & + gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & + gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & + gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & + gw2d(did)%istep) + + +! bftodo head postprocessing block +! GW-SOIL-CHANNEL interaction section + gw2d(did)%ho = gw2d(did)%h + +#ifdef HYDRO_D + write(6,*) "*****bf******end 2d_gw_model " +#endif + + End if + + END IF !DJG (End if for RTE SWC activation) +!------------------------------------------------------------------ +!DJG End GW/Baseflow Routines +!------------------------------------------------------------------- + +!------------------------------------------------------------------- +!------------------------------------------------------------------- +!DJG,DNY Begin Channel and Lake Routing Routines +!------------------------------------------------------------------- + IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN + + call drive_CHANNEL(RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & + nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, & + LAKE_INFLORT_TS, QSTRMVOLRT_TS,& + RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& + RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& + RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT, & + RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTRT, & + RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & + RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& + RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & + RT_DOMAIN(did)%Bw,& + RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,& + RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, & + RT_DOMAIN(did)%ORIFICEA, & + RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & + RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& + RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & + RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, & + RT_DOMAIN(did)%RETDEP_CHAN & + , RT_DOMAIN(did)%node_area & +#ifdef MPP_LAND + ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& + RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & + RT_DOMAIN(did)%yw_mpp_nlinks & +#endif + ) + endif + +#ifdef HYDRO_D + write(6,*) "*****yw******end drive_CHANNEL " +#endif + + end subroutine exeRouting + + subroutine time_seconds(i3) + integer time_array(8) + real*8 i3 + call date_and_time(values=time_array) + i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + & + time_array(7) + 0.001 * time_array(8) + return + end subroutine time_seconds + + diff --git a/wrfv2_fire/hydro/Routing/Makefile b/wrfv2_fire/hydro/Routing/Makefile index 516344db..ce785bc1 100644 --- a/wrfv2_fire/hydro/Routing/Makefile +++ b/wrfv2_fire/hydro/Routing/Makefile @@ -12,7 +12,7 @@ OBJS = \ module_HYDRO_io.o \ module_RT.o Noah_distr_routing.o \ module_channel_routing.o \ - rtFunction.o module_lsm_forcing.o + module_lsm_forcing.o all: $(OBJS) @@ -48,7 +48,6 @@ module_RT.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o ../Data_ module_GW_baseflow.o module_HYDRO_utils.o module_HYDRO_io.o\ module_noah_chan_param_init_rt.o ../Data_Rec/module_GW_baseflow_data.o -rtFunction.o: ../Data_Rec/module_RT_data.o ../Data_Rec/module_GW_baseflow_data.o ../Data_Rec/module_namelist.o module_channel_routing.o clean: rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/Routing/Noah_distr_routing.F b/wrfv2_fire/hydro/Routing/Noah_distr_routing.F index 1542ff07..0f856caf 100644 --- a/wrfv2_fire/hydro/Routing/Noah_distr_routing.F +++ b/wrfv2_fire/hydro/Routing/Noah_distr_routing.F @@ -251,7 +251,7 @@ SUBROUTINE SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT, & #ifdef HYDRO_D print *, "Subsfc acct. SMCMAX exceeded...", & SMCRT(I,J,KK), SMCMAXRT(I,J,KK),KK,i,j - call hydro_stop() + call hydro_stop("SUBSFC_RTNG") #endif ELSE END IF @@ -275,7 +275,7 @@ SUBROUTINE SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT, & ! If all layers sat. add remaining subflo to infilt. excess... IF (KK.eq.0.AND.SUBFLO.gt.0.) then - INFXSUBRT(I,J) = INFXSUBRT(I,J) + SUBFLO/1000. !Units = mm + INFXSUBRT(I,J) = INFXSUBRT(I,J) + SUBFLO*1000. !Units = mm SUBFLO=0. END IF @@ -299,6 +299,7 @@ SUBROUTINE SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT, & DO KK=SATLYRCHK(I,J),NSOIL WATAVAIL = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK) IF (WATAVAIL.GE.ABS(SUBFLO)) THEN +!?yw mod IF (WATAVAIL.GE.(ABS(SUBFLO)+0.000001) ) THEN SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK) SUBFLO=0. ELSE ! Since subflo is small on a time-step following is unlikely... @@ -393,10 +394,10 @@ SUBROUTINE FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & ! (i.e. not 'frozen' or otherwise immobile) ! IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK).AND.SMCMAXRT(I,J,KK) & ! .GT.SMCWLTRT(I,J,KK)) THEN - IF (SMCRT(I,J,KK).GE.SMCREFRT(I,J,KK).AND.SMCREFRT(I,J,KK) & - .GT.SMCWLTRT(I,J,KK)) THEN + IF ( (SMCRT(I,J,KK).GE.SMCREFRT(I,J,KK)).AND.(SMCREFRT(I,J,KK) & + .GT.SMCWLTRT(I,J,KK)) ) THEN ! Add additional check to ensure saturation from bottom up only...8/8/05 - IF(SATLYRCHK(I,J).EQ.KK+1.OR.KK.EQ.NSOIL) SATLYRCHK(I,J) = KK + IF((SATLYRCHK(I,J).EQ.KK+1) .OR. (KK.EQ.NSOIL) ) SATLYRCHK(I,J) = KK END IF END DO @@ -499,6 +500,7 @@ SUBROUTINE ROUTE_SUBSURFACE2( & INTEGER :: i,j !!! Initialize variables REAL, PARAMETER :: nexp=1.0 ! local power law exponent + qsub = 0. ! initialize flux = 0. !DJG 5 May 2014 !yw soldep = 2. @@ -529,12 +531,13 @@ SUBROUTINE ROUTE_SUBSURFACE2( & #ifdef HYDRO_D print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), & soldep(i,j),nexp - call hydro_stop() + call hydro_stop("ROUTE_SUBSURFACE2") #endif end if !Err. tan slope gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) - gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta + gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) +!DJG lacks tan(beta) of original Wigmosta version gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta qqsub = gamma * hh qsub(i,j) = qsub(i,j) + qqsub @@ -789,6 +792,7 @@ SUBROUTINE OV_RTNG(DT,DTRT,IXRT,JXRT,INFXSUBRT, & END DO END DO +! call MPP_LAND_COM_REAL(QSTRMVOLRT,IXRT,JXRT,99) !DJG---------------------------------------------------------------------- !DJG CALL OVERLAND FLOW ROUTING SUBROUTINE !DJG---------------------------------------------------------------------- @@ -1167,13 +1171,13 @@ SUBROUTINE ROUTE_SUBSURFACE1( & if(dist(i,j,index) .le. 0) then #ifdef HYDRO_D write(6,*) "Error: dist(i,j,index) is <= zero " - call hydro_stop() + call hydro_stop("ROUTE_SUBSURFACE1") #endif endif if(soldep(i,j) .eq. 0) then #ifdef HYDRO_D write(6,*) "Error: soldep is = zero " - call hydro_stop() + call hydro_stop("ROUTE_SUBSURFACE1") #endif endif @@ -1202,7 +1206,7 @@ SUBROUTINE ROUTE_SUBSURFACE1( & #ifdef HYDRO_D print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), & soldep(i,j) - call hydro_stop() + call hydro_stop("ROUTE_SUBSURFACE1") #endif end if @@ -1222,7 +1226,7 @@ SUBROUTINE ROUTE_SUBSURFACE1( & "tan(beta)=",tan(beta),i,j,z(i,j),z(IXX0,JYY0) print*, "ixx0=",ixx0, "jyy0=",jyy0 print*, "soldep =", soldep(i,j), "nexp=",nexp - call hydro_stop() + call hydro_stop("ROUTE_SUBSURFACE1") #endif end if @@ -1270,7 +1274,7 @@ SUBROUTINE ROUTE_SUBSURFACE1( & if(dist(i,j,9) .le. 0) then #ifdef HYDRO_D write(6,*) "Error: dist(i,j,9) is <= zero " - call hydro_stop() + call hydro_stop("ROUTE_SUBSURFACE1") #endif endif if(CWATAVAIL(i,j).lt.ABS(qsub(i,j))/dist(i,j,9)*SUBDT) THEN @@ -1628,1151 +1632,1137 @@ SUBROUTINE ROUTE_OVERLAND2 (dt, & end subroutine ROUTE_OVERLAND2 - Subroutine drive_RT( IX,JX,NSOIL,IXRT,JXRT, & - SMC,STC,SH2OX,INFXSRT,SFCHEADRT,SMCMAX1,SMCREF1,LKSAT, & - SMCWLT1, SMCRTCHK,DSMC,ZSOIL, SMCAGGRT,STCAGGRT,SH2OAGGRT, & - SLDPTH,VEGTYP,SOLDEPRT,INFXSAGGRT,DHRT,QSTRMVOLRT, & - QBDRYRT,LAKE_INFLORT,SFCHEADSUBRT,INFXSWGT,LKSATRT, & - INFXSUBRT,OVROUGHRT,QSUBRT,ZWATTABLRT,QSUBBDRYRT, & - RETDEPRT,SOXRT,SOYRT,SUB_RESID,SMCRT,SMCMAXRT,SMCWLTRT, & - SH2OWGT,LAKE_MSKRT,CH_NETRT,dist,LSMVOL,DSMCTOT,SMCTOT1,& - SMCTOT2,suminfxs1,suminfxsrt,SO8RT,SO8RT_D,AGGFACTRT, & - SUBRTSWCRT,OVRTSWCRT, LAKE_CT, STRM_CT, & - RT_OPTION,OV_ROUGH,INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT,& - DTRT, DT,LAKE_INFLOTRT,QBDRYTRT,QSUBBDRYTRT,& - QSTRMVOLTRT,q_sfcflx_x,q_sfcflx_y,LKSATFAC,& - OVROUGHRTFAC,area_lsm) - +!DJG ---------------------------------------------------------------------- -!DX,SICE,INFXSWGT,SH2OWGT,i,j,AGGFACYRT,AGGFACXRT,IXXRT,JYYRT,INFXSUBRT -! LKSATRT,SMCRT,SMCMAXRT,WATHOLDCAP,SMCWLTRT,OVROUGHRT,LAKE_MSKRT +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE TER_ADJ_SOL - Terrain adjustment of incoming solar radiation +!DJG----------------------------------------------------------------------- + SUBROUTINE TER_ADJ_SOL(IX,JX,SO8LD_D,TSLP,SHORT,XLAT,XLONG,olddate,DT) -!yyww #ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id, & - up_id,mpp_land_com_real, my_id, & - mpp_land_sync,mpp_land_com_integer,mpp_land_max_int1, & - sum_double + use module_mpp_land, only: my_id, io_id, & + mpp_land_bcast_int1 #endif - implicit none - -! Define the variables - integer IX,JX,NSOIL,IXRT,JXRT - real,DIMENSION(IX,JX,NSOIL)::SMC,STC,SH2OX,SICE - real,DIMENSION(IX,JX) ::INFXSRT,SFCHEADRT,SMCMAX1,SMCREF1,LKSAT, & - SMCWLT1, area_lsm - real,DIMENSION(NSOIL) :: ZSOIL, & - SMCAGGRT,STCAGGRT,SH2OAGGRT,SLDPTH - integer,DIMENSION(IX,JX) ::VEGTYP - - real,DIMENSION(IXRT,JXRT) ::SOLDEPRT,INFXSAGGRT,DHRT,QSTRMVOLRT, & - QBDRYRT,LAKE_INFLORT,SFCHEADSUBRT,INFXSWGT,LKSATRT, & - INFXSUBRT,OVROUGHRT,QSUBRT,ZWATTABLRT,QSUBBDRYRT, & - RETDEPRT,SOXRT,SOYRT,SUB_RESID,q_sfcflx_x,q_sfcflx_y, & - LKSATFAC,CWATAVAIL,OVROUGHRTFAC - integer,DIMENSION(IXRT,JXRT) ::SATLYRCHK - - real,DIMENSION(IXRT,JXRT,NSOIL)::SMCRT,SMCMAXRT,SMCREFRT,SMCWLTRT,SH2OWGT - integer,INTENT(IN), DIMENSION(IXRT,JXRT) ::CH_NETRT - integer,INTENT(INOUT), DIMENSION(IXRT,JXRT) ::LAKE_MSKRT - - REAL :: INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT, WATHOLDCAP,DTRT,& - DT,LAKE_INFLOTRT,QBDRYTRT,QSUBBDRYTRT,QSTRMVOLTRT - REAL OV_ROUGH(*) - - REAL :: dx,LSMVOL,SMCEXCS - real, DIMENSION(IXRT,JXRT,9) :: dist - - real, DIMENSION(IXRT,JXRT,8) ::SO8RT - INTEGER, DIMENSION(IXRT,JXRT,3) ::SO8RT_D - - integer :: AGGFACTRT,SUBRTSWCRT,OVRTSWCRT - integer :: sfcrt_flag -!end define variable.s - integer i,j,AGGFACYRT, AGGFACXRT, KRT, kx, KF,& - IXXRT, JYYRT, LAKE_CT, STRM_CT,RT_OPTION - -!DJG Debug variables... - INTEGER, PARAMETER :: double1=8 - real (KIND=double1), DIMENSION(NSOIL) :: SMCRTCHK,DSMC - real (KIND=double1) :: smctot2,smctot1,dsmctot - real (KIND=double1) :: suminfxsrt,suminfxs1 - real (KIND=double1) :: chan_in1,chan_in2 - real (KIND=double1) :: lake_in1,lake_in2 - real (KIND=double1) :: qbdry1,qbdry2 - - + implicit none + integer,INTENT(IN) :: IX,JX + INTEGER,INTENT(in), DIMENSION(IX,JX,3) :: SO8LD_D + real,INTENT(IN), DIMENSION(IX,JX) :: XLAT,XLONG + real,INTENT(IN) :: DT + real,INTENT(INOUT), DIMENSION(IX,JX) :: SHORT + character(len=19) :: olddate +! Local Variables... + real, dimension(IX,JX) ::TSLP,TAZI + real, dimension(IX,JX) ::SOLDN + real :: SOLDEC,DGRD,ITIME2,HRANGLE + real :: BINSH,SOLZANG,SOLAZI,INCADJ + real :: TAZIR,TSLPR,LATR,LONR,SOLDNADJ + integer :: JULDAY0,HHTIME0,MMTIME0,YYYY0,MM0,DD0 + integer :: JULDAY,HHTIME,MMTIME,YYYY,MM,DD + integer :: I,J + -!DJG Use New Var SICE to track diff between SMC and SH2O through routing... - SICE=SMC-SH2OX - SMCREFRT = 0 +!---------------------------------------------------------------------- +! SPECIFY PARAMETERS and VARIABLES +!---------------------------------------------------------------------- -!DJG First, Disaggregate a few key fields for routing... -!DJG Debug... -#ifdef HYDRO_D - print *, "Beginning Disaggregation..." + JULDAY = 0 + SOLDN = SHORT + DGRD = 3.14159/180. + +! Set up time variables... +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + read(olddate(1:4),"(I4)") YYYY0 ! real-time year (GMT) + read(olddate(6:7),"(I2.2)") MM0 ! real-time month (GMT) + read(olddate(9:10),"(I2.2)") DD0 ! real-time day (GMT) + read(olddate(12:13),"(I2.2)") HHTIME0 ! real-time hour (GMT) + read(olddate(15:16),"(I2.2)") MMTIME0 ! real-time minutes (GMT) +#ifdef MPP_LAND + endif + call mpp_land_bcast_int1(YYYY0) + call mpp_land_bcast_int1(MM0) + call mpp_land_bcast_int1(DD0) + call mpp_land_bcast_int1(HHTIME0) + call mpp_land_bcast_int1(MMTIME0) #endif - -!DJG Mass balance check for disagg... - - -!DJG Weighting alg. alteration...(prescribe wghts if time = 1) - - do J=1,JX - do I=1,IX -!DJG Weighting alg. alteration... - LSMVOL=INFXSRT(I,J)*area_lsm(I,J) +! Set up terrain variables...(returns TSLP&TAZI in radians) + call SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) +!---------------------------------------------------------------------- +! BEGIN LOOP THROUGH GRID +!---------------------------------------------------------------------- + DO J=1,JX + DO I=1,IX + YYYY = YYYY0 + MM = MM0 + DD = DD0 + HHTIME = HHTIME0 + MMTIME = MMTIME0 + call GMT2LOCAL(1,1,XLONG(i,j),YYYY,MM,DD,HHTIME,MMTIME,DT) + call JULDAY_CALC(YYYY,MM,DD,JULDAY) - do AGGFACYRT=AGGFACTRT-1,0,-1 - do AGGFACXRT=AGGFACTRT-1,0,-1 +! Convert to radians... + LATR = XLAT(I,J) !send solsub local lat in deg + LONR = XLONG(I,J) !send solsub local lon in deg + TSLPR = TSLP(I,J)/DGRD !send solsub local slp in deg + TAZIR = TAZI(I,J)/DGRD !send solsub local azim in deg - IXXRT=I*AGGFACTRT-AGGFACXRT - JYYRT=J*AGGFACTRT-AGGFACYRT -#ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 -#else -!yw ???? -! IXXRT=IXXRT+1 -! JYYRT=JYYRT+1 -#endif +!Call SOLSUB to return terrain adjusted incoming solar radiation... +! SOLSUB taken from Whiteman and Allwine, 1986, Environ. Software. + call SOLSUB(LONR,LATR,TAZIR,TSLPR,SOLDN(I,J),YYYY,MM, & + DD,HHTIME,MMTIME,SOLDNADJ,SOLZANG,SOLAZI,INCADJ) -!DJG Implement subgrid weighting routine... - INFXSUBRT(IXXRT,JYYRT)=LSMVOL* & - INFXSWGT(IXXRT,JYYRT)/dist(IXXRT,JYYRT,9) - + SOLDN(I,J)=SOLDNADJ - do KRT=1,NSOIL !Do for soil profile loop - IF(SICE(I,J,KRT).gt.0) then !...adjust for soil ice -!DJG Adjust SMCMAX for SICE when subsfc routing...make 3d variable - SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J)-SICE(I,J,KRT) - SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J)-SICE(I,J,KRT) - WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) - IF (SICE(I,J,KRT).le.WATHOLDCAP) then - SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - else - if(SICE(I,J,KRT).lt.SMCMAX1(I,J)) & - SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - & - (SICE(I,J,KRT)-WATHOLDCAP) - if(SICE(I,J,KRT).ge.SMCMAX1(I,J)) SMCWLTRT(IXXRT,JYYRT,KRT) = 0. - end if - ELSE - SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J) - SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J) - WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) - SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - END IF !endif adjust for soil ice... + ENDDO + ENDDO + SHORT = SOLDN -!Now Adjust soil moisture -!DJG Use SH2O instead of SMC for 'liquid' water... - IF(SMCMAXRT(IXXRT,JYYRT,KRT).GT.0) THEN !Check for smcmax data (=0 over water) - SMCRT(IXXRT,JYYRT,KRT)=SH2OX(I,J,KRT)*SH2OWGT(IXXRT,JYYRT,KRT) -!old SMCRT(IXXRT,JYYRT,KRT)=SMC(I,J,KRT) - ELSE - SMCRT(IXXRT,JYYRT,KRT) = 0.001 !will be skipped w/ landmask - SMCMAXRT(IXXRT,JYYRT,KRT) = 0.001 - END IF -!DJG Check/Adjust so that subgrid cells do not exceed saturation... - IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN - SMCEXCS = (SMCRT(IXXRT,JYYRT,KRT) - SMCMAXRT(IXXRT,JYYRT,KRT)) & - * SLDPTH(KRT)*1000. !Excess soil water in units of (mm) - SMCRT(IXXRT,JYYRT,KRT) = SMCMAXRT(IXXRT,JYYRT,KRT) - DO KF = KRT-1,1, -1 !loop back upward to redistribute excess water from disagg. - SMCRT(IXXRT,JYYRT,KF) = SMCRT(IXXRT,JYYRT,KF) + SMCEXCS/(SLDPTH(KF)*1000.) - IF (SMCRT(IXXRT,JYYRT,KF).GT.SMCMAXRT(IXXRT,JYYRT,KF)) THEN !Recheck new lyr sat. - SMCEXCS = (SMCRT(IXXRT,JYYRT,KF) - SMCMAXRT(IXXRT,JYYRT,KF)) & - * SLDPTH(KF) !Excess soil water in units of (mm) - SMCRT(IXXRT,JYYRT,KF) = SMCMAXRT(IXXRT,JYYRT,KF) - ELSE ! Excess soil water expired - SMCEXCS = 0. - EXIT - END IF - END DO - IF (SMCEXCS.GT.0) THEN !If not expired by sfc then add to Infil. Excess - INFXSUBRT(IXXRT,JYYRT) = INFXSUBRT(IXXRT,JYYRT) + SMCEXCS - SMCEXCS = 0. - END IF - END IF !End if for soil moisture saturation excess + return + end SUBROUTINE TER_ADJ_SOL +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE TER_ADJ_SOL +!DJG----------------------------------------------------------------------- - end do !End do for soil profile loop +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE GMT2LOCAL +!DJG----------------------------------------------------------------------- + subroutine GMT2LOCAL(IX,JX,XLONG,YY,MM,DD,HH,MIN,DT) + implicit none +!!! Declare Passed Args. - do KRT=1,NSOIL !debug loop - IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN -#ifdef HYDRO_D - print *, "Err. SMCMAX exceeded upon disaggregation3...", ixxrt,jyyrt,krt,& - SMCRT(IXXRT,JYYRT,KRT),SMCMAXRT(IXXRT,JYYRT,KRT) - call hydro_stop() -#endif - ELSE IF (SMCRT(IXXRT,JYYRT,KRT).LE.0.) THEN -#ifdef HYDRO_D - print *, "Err. SMCRT fully depleted upon disaggregation...", ixxrt,jyyrt,krt,& - SMCRT(IXXRT,JYYRT,KRT),SH2OWGT(IXXRT,JYYRT,KRT),SH2OX(I,J,KRT) - print *, "VEGTYP = ", VEGTYP(I,J) - print *, "i,j,krt, nsoil",i,j,krt,nsoil - call hydro_stop() -#endif - END IF - end do !debug loop + INTEGER, INTENT(INOUT) :: yy,mm,dd,hh,min + INTEGER, INTENT(IN) :: IX,JX + REAL,INTENT(IN), DIMENSION(IX,JX) :: XLONG + REAL,INTENT(IN) :: DT +!!! Declare local variables + integer :: i,j,minflag,hhflag,ddflag,mmflag,yyflag + integer :: adj_min,lst_adj_min,lst_adj_hh,adj_hh + real, dimension(IX,JX) :: TDIFF + real :: tmp + integer :: yyinit,mminit,ddinit,hhinit,mininit -!DJG map ov roughness as function of land use provided in VEGPARM.TBL... -! --- added extra check for VEGTYP for 'masked-out' locations... -! --- out of basin locations (VEGTYP=0) have OVROUGH hardwired to 0.1 - IF (VEGTYP(I,J).LE.0) then - OVROUGHRT(IXXRT,JYYRT) = 0.1 !COWS mask test - ELSE - OVROUGHRT(IXXRT,JYYRT)=OV_ROUGH(VEGTYP(I,J))*OVROUGHRTFAC(IXXRT,JYYRT) ! Distributed calibration...1/17/2012 - END IF +!!! Initialize flags + hhflag=0 + ddflag=0 + mmflag=0 + yyflag=0 +!!! Set up constants... + yyinit = yy + mminit = mm + ddinit = dd + hhinit = hh + mininit = min -!DJG 6.12.08 Map lateral hydraulic conductivity and apply distributed scaling -! --- factor that will be read in from hires terrain file -! LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) - LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) * LKSATFAC(IXXRT,JYYRT) * & !Apply scaling factor... -! ...and scale from max to 0 when SMC decreases from SMCMAX to SMCREF... - ((SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL)) / & - (SMCMAXRT(IXXRT,JYYRT,NSOIL)-SMCREFRT(IXXRT,JYYRT,NSOIL)) ) +! Loop through data... + do j=1,JX + do i=1,IX +! Reset yy,mm,dd... + yy = yyinit + mm = mminit + dd = ddinit + hh = hhinit + min = mininit +!!! Set up adjustments... +! - assumes +E , -W longitude and 0.06667 hr/deg (=24/360) + TDIFF(I,J) = XLONG(I,J)*0.06667 ! time offset in hr + tmp = TDIFF(I,J) + lst_adj_hh = INT(tmp) + lst_adj_min = NINT(MOD(int(tmp),1)*60.) + int(DT/2./60.) ! w/ 1/2 timestep adjustment... -!DJG set up lake mask... -!--- modify to make lake mask large here, but not one of the routed lakes!!! -!-- IF (VEGTYP(I,J).eq.16) then - IF (VEGTYP(I,J).eq.16 .and. & - CH_NETRT(IXXRT,JYYRT).le.0) then - !--LAKE_MSKRT(IXXRT,JYYRT) = 1 - LAKE_MSKRT(IXXRT,JYYRT) = 9999 -!yw LAKE_MSKRT(IXXRT,JYYRT) = -9999 - end if - - end do - end do - - end do - end do - +!!! Process Minutes... + adj_min = min+lst_adj_min + if (adj_min.lt.0) then + min=60+adj_min + lst_adj_hh = lst_adj_hh - 1 + else if (adj_min.ge.0.AND.adj_min.lt.60) then + min=adj_min + else if (adj_min.ge.60) then + min=adj_min-60 + lst_adj_hh = lst_adj_hh + 1 + end if -!!!! Find saturated layer depth... -! Loop through domain to determine sat. layers and assign wat tbl depth... -! and water available for subsfc routing (CWATAVAIL)... -! This subroutine returns: ZWATTABLRT, CWATAVAIL and SATLYRCHK +!!! Process Hours + adj_hh = hh+lst_adj_hh + if (adj_hh.lt.0) then + hh = 24+adj_hh + ddflag=1 + else if (adj_hh.ge.0.AND.adj_hh.lt.24) then + hh=adj_hh + else if (adj_hh.ge.24) then + hh=adj_hh-24 + ddflag = 2 + end if - CWATAVAIL = 0. - CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & - SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, & - CWATAVAIL,SLDPTH) +!!! Process Days, Months, Years +! Subtract a day + if (ddflag.eq.1) then + if (dd.gt.1) then + dd=dd-1 + else + if (mm.eq.1) then + mm=12 + yy=yy-1 + else + mm=mm-1 + end if + if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & + (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & + (mm.eq.12)) then + dd=31 + else +!!! Adjustment for leap years!!! + if(mm.eq.2) then + if(MOD(yy,4).eq.0) then + dd=29 + else + dd=28 + end if + end if + if(mm.ne.2) dd=30 + end if + end if + end if -#ifdef HYDRO_D - print *, "After Disaggregation..." -#endif +! Add a day + if (ddflag.eq.2) then + if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & + (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & + (mm.eq.12)) then + if (dd.eq.31) then + dd=1 + if (mm.eq.12) then + mm=1 + yy=yy+1 + else + mm=mm+1 + end if + else + dd=dd+1 + end if +!!! Adjustment for leap years!!! + else if (mm.eq.2) then + if(MOD(yy,4).eq.0) then + if (dd.eq.29) then + dd=1 + mm=3 + else + dd=dd+1 + end if + else + if (dd.eq.28) then + dd=1 + mm=3 + else + dd=dd+1 + end if + end if + else + if (dd.eq.30) then + dd=1 + mm=mm+1 + else + dd=dd+1 + end if + end if -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(ZWATTABLRT,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(CWATAVAIL,IXRT,JXRT,99) - call MPP_LAND_COM_INTEGER(SATLYRCHK,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(INFXSUBRT,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(LKSATRT,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(OVROUGHRT,IXRT,JXRT,99) - call MPP_LAND_COM_INTEGER(LAKE_MSKRT,IXRT,JXRT,99) - do i = 1, NSOIL - call MPP_LAND_COM_REAL(SMCMAXRT(:,:,i),IXRT,JXRT,99) - call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99) - call MPP_LAND_COM_REAL(SMCWLTRT(:,:,i),IXRT,JXRT,99) - end DO -#endif + end if + end do !i-loop + end do !j-loop -!DJG Second, Call subsurface routing routine... - IF (SUBRTSWCRT.EQ.1) THEN -#ifdef HYDRO_D - print *, "Beginning SUB_routing..." - print *, "Routing method is ",rt_option, " direction." -#endif + return + end subroutine - CALL SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & - LKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT,NSOIL,SMCRT, & - INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT,SMCWLTRT,SO8RT, & - SO8RT_D, rt_option,SLDPTH,SUB_RESID,CWATAVAIL,SATLYRCHK) +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE GMT2LOCAL +!DJG----------------------------------------------------------------------- -#ifdef HYDRO_D - print *, "SUBROUTE routing called and returned..." -#endif +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE JULDAY_CALC +!DJG----------------------------------------------------------------------- + subroutine JULDAY_CALC(YYYY,MM,DD,JULDAY) - ENDIF ! ENDIF SUBRTSWCRT + implicit none + integer,intent(in) :: YYYY,MM,DD + integer,intent(out) :: JULDAY + integer :: resid + integer julm(13) + DATA JULM/0, 31, 59, 90, 120, 151, 181, 212, 243, 273, & + 304, 334, 365 / -!DJG Third, Call Overland Flow Routing Routine... - IF (OVRTSWCRT.EQ.1) THEN -#ifdef HYDRO_D - print *, "Beginning OV_routing..." - print *, "Routing method is ",rt_option, " direction." - print *, "ixrt, jxrt =", ixrt, jxrt -#endif + integer LPjulm(13) + DATA LPJULM/0, 31, 60, 91, 121, 152, 182, 213, 244, 274, & + 305, 335, 366 / -!DJG debug...OV Routing... - suminfxs1=0. - chan_in1=0. - lake_in1=0. - qbdry1=0. - do i=1,IXRT - do j=1,JXRT - suminfxs1=suminfxs1+INFXSUBRT(I,J)/float(IXRT*JXRT) - chan_in1=chan_in1+QSTRMVOLRT(I,J)/float(IXRT*JXRT) - lake_in1=lake_in1+LAKE_INFLORT(I,J)/float(IXRT*JXRT) - qbdry1=qbdry1+QBDRYRT(I,J)/float(IXRT*JXRT) - end do - end do + resid = MOD(YYYY,4) !Set up leap year check... -#ifdef MPP_LAND -! not tested - CALL sum_double(suminfxs1) - CALL sum_double(chan_in1) - CALL sum_double(lake_in1) - CALL sum_double(qbdry1) -#endif + if (resid.ne.0) then !If not a leap year.... + JULDAY = JULM(MM) + DD + else !If a leap year... + JULDAY = LPJULM(MM) + DD + end if + RETURN + END subroutine JULDAY_CALC +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE JULDAY +!DJG----------------------------------------------------------------------- -!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(set sfcrt_flag) -!DJG.7.20.2007 - this check will skip ov rtng when no flow is present... - - sfcrt_flag = 0 - - do j=1,jxrt - do i=1,ixrt - if(INFXSUBRT(i,j).gt.RETDEPRT(i,j)) then - sfcrt_flag = 1 - exit - end if - end do - if(sfcrt_flag.eq.1) exit - end do +!DJG----------------------------------------------------------------------- +!DJG SUBROUTINE SLOPE_ASPECT +!DJG----------------------------------------------------------------------- + subroutine SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) -#ifdef MPP_LAND - call mpp_land_max_int1(sfcrt_flag) -#endif -!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(IF) + implicit none + integer, INTENT(IN) :: IX,JX +! real,INTENT(in),DIMENSION(IX,JX) :: TSLP !terrain slope (m/m) + real,INTENT(OUT),DIMENSION(IX,JX) :: TAZI !terrain aspect (deg) - if (sfcrt_flag.eq.1) then !If/then for sfc_rt check... -#ifdef HYDRO_D - write(6,*) "calling OV_RTNG " -#endif - CALL OV_RTNG(DT,DTRT,IXRT,JXRT,INFXSUBRT,SFCHEADSUBRT,DHRT, & - CH_NETRT,RETDEPRT,OVROUGHRT,QSTRMVOLRT,QBDRYRT, & - QSTRMVOLTRT,QBDRYTRT,SOXRT,SOYRT,dist, & - LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT,SO8RT,SO8RT_D,rt_option,& - q_sfcflx_x,q_sfcflx_y) - else -#ifdef HYDRO_D - print *, "No water to route overland..." -#endif - end if !Endif for sfc_rt check... + INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D + real :: DGRD + integer :: i,j -!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(ENDIF) +! TSLP = 0. !Initialize as flat + TAZI = 0. !Initialize as north facing -#ifdef HYDRO_D - print *, "OV routing called and returned..." -#endif +! Find steepest descent slope and direction... + do j=1,JX + do i=1,IX +! TSLP(I,J) = TANH(Vmax(i,j)) ! calculate slope in radians... -!DJG Debug...OV Routing... - suminfxsrt=0. - chan_in2=0. - lake_in2=0. - qbdry2=0. - do i=1,IXRT - do j=1,JXRT - suminfxsrt=suminfxsrt+SFCHEADSUBRT(I,J)/float(IXRT*JXRT) - chan_in2=chan_in2+QSTRMVOLRT(I,J)/float(IXRT*JXRT) - lake_in2=lake_in2+LAKE_INFLORT(I,J)/float(IXRT*JXRT) - qbdry2=qbdry2+QBDRYRT(I,J)/float(IXRT*JXRT) - end do - end do -#ifdef MPP_LAND -! not tested - CALL sum_double(suminfxsrt) - CALL sum_double(chan_in2) - CALL sum_double(lake_in2) - CALL sum_double(qbdry2) -#endif - -#ifdef HYDRO_D - print *, "OV Routing Mass Bal: " - print *, "Infil. Excess/Sfc Head: ", suminfxsrt-suminfxs1, & - suminfxsrt,suminfxs1 - print *, "chan_in = ",chan_in2-chan_in1 - print *, "lake_in = ",lake_in2-lake_in1 - print *, "Qbdry = ",qbdry2-qbdry1 - print *, "Residual : ", suminfxs1-suminfxsrt-(chan_in2-chan_in1) & - -(lake_in2-lake_in1)-(qbdry2-qbdry1) -#endif - - ENDIF ! ENDIF for OVRTSWCRT - - - - -!DJG Fourth(last), Aggregate a few fields from routing. -#ifdef HYDRO_D - print *, "Beginning Aggregation..." -#endif - - - do J=1,JX - do I=1,IX - - SFCHEADAGGRT= 0. -!DJG Subgrid weighting edit... - LSMVOL=0. - do KRT=1,NSOIL - SMCAGGRT(KRT) = 0. - SH2OAGGRT(KRT) = 0. - end do +! Convert steepest slope and aspect to radians... + IF (SO8LD_D(i,j,3).eq.1) then + TAZI(I,J) = 0.0 + ELSEIF (SO8LD_D(i,j,3).eq.2) then + TAZI(I,J) = 45.0 + ELSEIF (SO8LD_D(i,j,3).eq.3) then + TAZI(I,J) = 90.0 + ELSEIF (SO8LD_D(i,j,3).eq.4) then + TAZI(I,J) = 135.0 + ELSEIF (SO8LD_D(i,j,3).eq.5) then + TAZI(I,J) = 180.0 + ELSEIF (SO8LD_D(i,j,3).eq.6) then + TAZI(I,J) = 225.0 + ELSEIF (SO8LD_D(i,j,3).eq.7) then + TAZI(I,J) = 270.0 + ELSEIF (SO8LD_D(i,j,3).eq.8) then + TAZI(I,J) = 315.0 + END IF + DGRD = 3.141593/180. + TAZI(I,J) = TAZI(I,J)*DGRD ! convert azimuth to radians... - do AGGFACYRT=AGGFACTRT-1,0,-1 - do AGGFACXRT=AGGFACTRT-1,0,-1 + END DO + END DO + RETURN + END subroutine SLOPE_ASPECT +!DJG----------------------------------------------------------------------- +!DJG END SUBROUTINE SLOPE_ASPECT +!DJG----------------------------------------------------------------------- - IXXRT=I*AGGFACTRT-AGGFACXRT - JYYRT=J*AGGFACTRT-AGGFACYRT -#ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 -#else -!yw ???? -! IXXRT=IXXRT+1 -! JYYRT=JYYRT+1 -#endif +!DJG---------------------------------------------------------------- +!DJG SUBROUTINE SOLSUB +!DJG---------------------------------------------------------------- + SUBROUTINE SOLSUB(LONG,LAT,AZ,IN,SC,YY,MO,IDA,IHR,MM,OUT1, & + OUT2,OUT3,INCADJ) -!State Variables - SFCHEADAGGRT=SFCHEADAGGRT+SFCHEADSUBRT(IXXRT,JYYRT) -!DJG Subgrid weighting edit... - LSMVOL=LSMVOL+SFCHEADSUBRT(IXXRT,JYYRT)*dist(IXXRT,JYYRT,9) - do KRT=1,NSOIL -!DJG SMCAGGRT(KRT)=SMCAGGRT(KRT)+SMCRT(IXXRT,JYYRT,KRT) - SH2OAGGRT(KRT)=SH2OAGGRT(KRT)+ & - SMCRT(IXXRT,JYYRT,KRT) - end do +! Notes.... - end do - end do + implicit none + logical :: daily, first + integer :: yy,mo,ida,ihr,mm,d + integer,dimension(12) :: nday + real :: lat,long,longcor,longsun,in,inslo + real :: az,sc,out1,out2,out3,cosbeta,dzero,eccent,pi,calint + real :: rtod,decmax,omega,onehr,omd,omdzero,rdvecsq,sdec + real :: declin,cdec,arg,declon,sr,stdmrdn,b,em,timnoon,azslo + real :: slat,clat,caz,saz,sinc,cinc,hinc,h,cosz,extra,extslo + real :: t1,z,cosa,a,cosbeta_flat,INCADJ + integer :: HHTIME,MMTIME,i,ik + real, dimension(4) :: ACOF,BCOF +! Constants + daily=.FALSE. + ACOF(1) = 0.00839 + ACOF(2) = -0.05391 + ACOF(3) = -0.00154 + ACOF(4) = -0.0022 + BCOF(1) = -0.12193 + BCOF(2) = -0.15699 + BCOF(3) = -0.00657 + BCOF(4) = -0.00370 + DZERO = 80. + ECCENT = 0.0167 + PI = 3.14159 + CALINT = 1. + RTOD = PI / 180. + DECMAX=(23.+26./60.)*RTOD + OMEGA=2*PI/365. + ONEHR=15.*RTOD +! Calculate Julian Day... + D = 0 + call JULDAY_CALC(YY,MO,IDA,D) - SFCHEADRT(I,J) = SFCHEADAGGRT/(AGGFACTRT**2) +! Ratio of radius vectors squared... + OMD=OMEGA*D + OMDZERO=OMEGA*DZERO +! RDVECSQ=1./(1.-ECCENT*COS(OMD))**2 + RDVECSQ = 1. ! no adjustment for orbital changes when coupled to HRLDAS... - do KRT=1,NSOIL -!DJG SMC(I,J,KRT)=SMCAGGRT(KRT)/(AGGFACTRT**2) - SH2OX(I,J,KRT)=SH2OAGGRT(KRT)/(AGGFACTRT**2) - end do +! Declination of sun... + LONGSUN=OMEGA*(D-Dzero)+2.*ECCENT*(SIN(OMD)-SIN(OMDZERO)) + DECLIN=ASIN(SIN(DECMAX)*SIN(LONGSUN)) + SDEC=SIN(DECLIN) + CDEC=COS(DECLIN) +! Check for Polar Day/night... + ARG=((PI/2.)-ABS(DECLIN))/RTOD + IF(ABS(LAT).GT.ARG) THEN + IF((LAT.GT.0..AND.DECLIN.LT.0) .OR. & + (LAT.LT.0..AND.DECLON.GT.0.)) THEN + OUT1 = 0. + OUT2 = 0. + OUT3 = 0. + RETURN + ENDIF + SR=-1.*PI + ELSE +! Calculate sunrise hour angle... + SR=-1.*ABS(ACOS(-1.*TAN(LAT*RTOD)*TAN(DECLIN))) + END IF -!DJG Calculate subgrid weighting array... +! Find standard meridian for site + STDMRDN=NINT(LONG/15.)*15. + LONGCOR=(LONG-STDMRDN)/15. - do AGGFACYRT=AGGFACTRT-1,0,-1 - do AGGFACXRT=AGGFACTRT-1,0,-1 - IXXRT=I*AGGFACTRT-AGGFACXRT - JYYRT=J*AGGFACTRT-AGGFACYRT -#ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 -#else -!yw ??? -! IXXRT=IXXRT+1 -! JYYRT=JYYRT+1 -#endif - if (lsmvol.gt.0.) then - INFXSWGT(IXXRT,JYYRT)=SFCHEADSUBRT(IXXRT,JYYRT)* & - dist(IXXRT,JYYRT,9)/LSMVOL - else - INFXSWGT(IXXRT,JYYRT)=1./FLOAT(AGGFACTRT*AGGFACTRT) - end if +! Compute time correction from equation of time... + B=2.*PI*(D-.4)/365 + EM=0. + DO I=1,4 + EM=EM+(BCOF(I)*SIN(I*B)+ACOF(I)*COS(I*B)) + END DO - do KRT=1,NSOIL - IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN -#ifdef HYDRO_D - print *, "SMCMAX exceeded upon aggregation...", & - SMCRT(IXXRT,JYYRT,KRT), SMCMAXRT(IXXRT,JYYRT,KRT) - call hydro_stop() -#endif - END IF - IF(SH2OX(I,J,KRT).LE.0.) THEN -#ifdef HYDRO_D - print *, "Erroneous value of SH2O...",SH2OX(I,J,KRT),I,J,KRT - call hydro_stop() -#endif - END IF - SH2OWGT(IXXRT,JYYRT,KRT)=SMCRT(IXXRT,JYYRT,KRT)/SH2OX(I,J,KRT) - end do +! Compute time of solar noon... + TIMNOON=12.-EM-LONGCOR - end do - end do +! Set up a few more terms... + AZSLO=AZ*RTOD + INSLO=IN*RTOD + SLAT=SIN(LAT*RTOD) + CLAT=COS(LAT*RTOD) + CAZ=COS(AZSLO) + SAZ=SIN(AZSLO) + SINC=SIN(INSLO) + CINC=COS(INSLO) - end do - end do +! Begin solar radiation calculations...daily first, else instantaneous... + IF (DAILY) THEN ! compute daily integrated values...(Not used in HRLDAS!) + IHR=0 + MM=0 + HINC=CALINT*ONEHR/60. + IK=(2.*ABS(SR)/HINC)+2. + FIRST=.TRUE. + OUT1=0. + DO I=1,IK + H=SR+HINC*FLOAT(I-1) + COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) + COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & + SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & + SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) + EXTRA=SC*RDVECSQ*COSZ + IF(EXTRA.LE.0.) EXTRA=0. + EXTSLO=SC*RDVECSQ*COSBETA + IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. + IF(FIRST .AND. EXTSLO.GT.0.) THEN + OUT2=(H-HINC)/ONEHR+TIMNOON + FIRST = .FALSE. + END IF + IF(.NOT.FIRST .AND. EXTSLO.LE.0.) OUT3=H/ONEHR+TIMNOON + OUT1=EXTSLO+OUT1 + END DO + OUT1=OUT1*CALINT*60./1000000. -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(INFXSWGT,IXRT,JXRT,99) - do i = 1, NSOIL - call MPP_LAND_COM_REAL(SH2OWGT(:,:,i),IXRT,JXRT,99) - end do -#endif + ELSE ! Compute instantaneous values...(Is used in HRLDAS!) + T1=FLOAT(IHR)+FLOAT(MM)/60. + H=ONEHR*(T1-TIMNOON) + COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) +! Assuming HRLDAS forcing already accounts for season, time of day etc, +! subtract out the component of adjustment that would occur for +! a flat surface, this should leave only the sloped component remaining + COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & + SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & + SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) + COSBETA_FLAT=CDEC*CLAT*COS(H)+SDEC*SLAT -!DJG Update SMC with SICE (unchanged) and new value of SH2O from routing... - SMC=SH2OX+SICE -#ifdef HYDRO_D - print *, "Finished Aggregation..." -#endif - return - end Subroutine drive_RT ! drive_RT + INCADJ = COSBETA+(1-COSBETA_FLAT) -!DJG ---------------------------------------------------------------------- + EXTRA=SC*RDVECSQ*COSZ + IF(EXTRA.LE.0.) EXTRA=0. + EXTSLO=SC*RDVECSQ*INCADJ +! IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. !remove check for HRLDAS. + OUT1=EXTSLO + Z=ACOS(COSZ) + COSA=(SLAT*COSZ-SDEC)/(CLAT*SIN(Z)) + IF(COSA.LT.-1.) COSA=-1. + IF(COSA.GT.1.) COSA=1. + A=ABS(ACOS(COSA)) + IF(H.LT.0.) A=-A + OUT2=Z/RTOD + OUT3=A/RTOD+180 + END IF ! End if for daily vs instantaneous values... !DJG----------------------------------------------------------------------- -!DJG SUBROUTINE TER_ADJ_SOL - Terrain adjustment of incoming solar radiation + RETURN + END SUBROUTINE SOLSUB !DJG----------------------------------------------------------------------- - SUBROUTINE TER_ADJ_SOL(IX,JX,SO8LD_D,TSLP,SHORT,XLAT,XLONG,olddate,DT) - -#ifdef MPP_LAND - use module_mpp_land, only: my_id, io_id, & - mpp_land_bcast_int1 -#endif - implicit none - integer,INTENT(IN) :: IX,JX - INTEGER,INTENT(in), DIMENSION(IX,JX,3) :: SO8LD_D - real,INTENT(IN), DIMENSION(IX,JX) :: XLAT,XLONG - real,INTENT(IN) :: DT - real,INTENT(INOUT), DIMENSION(IX,JX) :: SHORT - character(len=19) :: olddate - -! Local Variables... - real, dimension(IX,JX) ::TSLP,TAZI - real, dimension(IX,JX) ::SOLDN - real :: SOLDEC,DGRD,ITIME2,HRANGLE - real :: BINSH,SOLZANG,SOLAZI,INCADJ - real :: TAZIR,TSLPR,LATR,LONR,SOLDNADJ - integer :: JULDAY0,HHTIME0,MMTIME0,YYYY0,MM0,DD0 - integer :: JULDAY,HHTIME,MMTIME,YYYY,MM,DD - integer :: I,J - - -!---------------------------------------------------------------------- -! SPECIFY PARAMETERS and VARIABLES -!---------------------------------------------------------------------- - - JULDAY = 0 - SOLDN = SHORT - DGRD = 3.14159/180. -! Set up time variables... -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - read(olddate(1:4),"(I4)") YYYY0 ! real-time year (GMT) - read(olddate(6:7),"(I2.2)") MM0 ! real-time month (GMT) - read(olddate(9:10),"(I2.2)") DD0 ! real-time day (GMT) - read(olddate(12:13),"(I2.2)") HHTIME0 ! real-time hour (GMT) - read(olddate(15:16),"(I2.2)") MMTIME0 ! real-time minutes (GMT) -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(YYYY0) - call mpp_land_bcast_int1(MM0) - call mpp_land_bcast_int1(DD0) - call mpp_land_bcast_int1(HHTIME0) - call mpp_land_bcast_int1(MMTIME0) -#endif + subroutine seq_land_SO8(SO8LD_D,Vmax,TERR,dx,ix,jx) + implicit none + integer :: ix,jx,i,j + REAL, DIMENSION(IX,JX,8) :: SO8LD + INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D + real,DIMENSION(IX,JX) :: TERR + real :: dx(ix,jx,9),Vmax(ix,jx) + SO8LD_D = -1 + do j = 2, jx -1 + do i = 2, ix -1 + SO8LD(i,j,1) = (TERR(i,j)-TERR(i,j+1))/dx(i,j,1) + SO8LD_D(i,j,1) = i + SO8LD_D(i,j,2) = j + 1 + SO8LD_D(i,j,3) = 1 + Vmax(i,j) = SO8LD(i,j,1) + SO8LD(i,j,2) = (TERR(i,j)-TERR(i+1,j+1))/DX(i,j,2) + if(SO8LD(i,j,2) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + 1 + SO8LD_D(i,j,2) = j + 1 + SO8LD_D(i,j,3) = 2 + Vmax(i,j) = SO8LD(i,j,2) + end if + SO8LD(i,j,3) = (TERR(i,j)-TERR(i+1,j))/DX(i,j,3) + if(SO8LD(i,j,3) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + 1 + SO8LD_D(i,j,2) = j + SO8LD_D(i,j,3) = 3 + Vmax(i,j) = SO8LD(i,j,3) + end if + SO8LD(i,j,4) = (TERR(i,j)-TERR(i+1,j-1))/DX(i,j,4) + if(SO8LD(i,j,4) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + 1 + SO8LD_D(i,j,2) = j - 1 + SO8LD_D(i,j,3) = 4 + Vmax(i,j) = SO8LD(i,j,4) + end if + SO8LD(i,j,5) = (TERR(i,j)-TERR(i,j-1))/DX(i,j,5) + if(SO8LD(i,j,5) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i + SO8LD_D(i,j,2) = j - 1 + SO8LD_D(i,j,3) = 5 + Vmax(i,j) = SO8LD(i,j,5) + end if + SO8LD(i,j,6) = (TERR(i,j)-TERR(i-1,j-1))/DX(i,j,6) + if(SO8LD(i,j,6) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i - 1 + SO8LD_D(i,j,2) = j - 1 + SO8LD_D(i,j,3) = 6 + Vmax(i,j) = SO8LD(i,j,6) + end if + SO8LD(i,j,7) = (TERR(i,j)-TERR(i-1,j))/DX(i,j,7) + if(SO8LD(i,j,7) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i - 1 + SO8LD_D(i,j,2) = j + SO8LD_D(i,j,3) = 7 + Vmax(i,j) = SO8LD(i,j,7) + end if + SO8LD(i,j,8) = (TERR(i,j)-TERR(i-1,j+1))/DX(i,j,8) + if(SO8LD(i,j,8) .gt. Vmax(i,j) ) then + SO8LD_D(i,j,1) = i - 1 + SO8LD_D(i,j,2) = j + 1 + SO8LD_D(i,j,3) = 8 + Vmax(i,j) = SO8LD(i,j,8) + end if + enddo + enddo + Vmax = TANH(Vmax) + return + end subroutine seq_land_SO8 -! Set up terrain variables...(returns TSLP&TAZI in radians) - call SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) +#ifdef MPP_LAND + subroutine MPP_seq_land_SO8(SO8LD_D,Vmax,TERRAIN,dx,ix,jx,& + global_nx,global_ny) -!---------------------------------------------------------------------- -! BEGIN LOOP THROUGH GRID -!---------------------------------------------------------------------- - DO J=1,JX - DO I=1,IX - YYYY = YYYY0 - MM = MM0 - DD = DD0 - HHTIME = HHTIME0 - MMTIME = MMTIME0 - call GMT2LOCAL(1,1,XLONG(i,j),YYYY,MM,DD,HHTIME,MMTIME,DT) - call JULDAY_CALC(YYYY,MM,DD,JULDAY) + use module_mpp_land, only: my_id, io_id, & + write_io_real,decompose_data_int,decompose_data_real -! Convert to radians... - LATR = XLAT(I,J) !send solsub local lat in deg - LONR = XLONG(I,J) !send solsub local lon in deg - TSLPR = TSLP(I,J)/DGRD !send solsub local slp in deg - TAZIR = TAZI(I,J)/DGRD !send solsub local azim in deg + implicit none + integer,intent(in) :: ix,jx,global_nx,global_ny + INTEGER, intent(inout),DIMENSION(IX,JX,3) :: SO8LD_D +! real,intent(in), DIMENSION(IX,JX) :: TERRAIN + real,DIMENSION(IX,JX) :: TERRAIN + real,intent(out),dimension(ix,jx) :: Vmax + real,intent(in) :: dx(ix,jx,9) + real :: g_dx(ix,jx,9) -!Call SOLSUB to return terrain adjusted incoming solar radiation... -! SOLSUB taken from Whiteman and Allwine, 1986, Environ. Software. + real,DIMENSION(global_nx,global_ny) :: g_TERRAIN + real,DIMENSION(global_nx,global_ny) :: g_Vmax + integer,DIMENSION(global_nx,global_ny,3) :: g_SO8LD_D + integer :: k - call SOLSUB(LONR,LATR,TAZIR,TSLPR,SOLDN(I,J),YYYY,MM, & - DD,HHTIME,MMTIME,SOLDNADJ,SOLZANG,SOLAZI,INCADJ) + g_SO8LD_D = 0 + g_Vmax = 0 + + do k = 1, 9 + call write_IO_real(dx(:,:,k),g_dx(:,:,k)) + end do - SOLDN(I,J)=SOLDNADJ + call write_IO_real(TERRAIN,g_TERRAIN) + if(my_id .eq. IO_id) then + call seq_land_SO8(g_SO8LD_D,g_Vmax,g_TERRAIN,g_dx,global_nx,global_ny) + endif + call decompose_data_int(g_SO8LD_D(:,:,3),SO8LD_D(:,:,3)) + call decompose_data_real(g_Vmax,Vmax) + return + end subroutine MPP_seq_land_SO8 - ENDDO - ENDDO +#endif - SHORT = SOLDN - return - end SUBROUTINE TER_ADJ_SOL -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE TER_ADJ_SOL -!DJG----------------------------------------------------------------------- + subroutine disaggregateDomain_drv(did) + use module_RT_data, only: rt_domain + use module_namelist, only: nlst_rt + integer :: did + call disaggregateDomain( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,& + RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT,nlst_rt(did)%AGGFACTRT,RT_DOMAIN(did)%SICE, & + RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%SH2OX,RT_DOMAIN(did)%INFXSRT, & + rt_domain(did)%dist_lsm(:,:,9),RT_DOMAIN(did)%SMCMAX1,RT_DOMAIN(did)%SMCREF1, & + RT_DOMAIN(did)%SMCWLT1,RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%LKSAT,RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%INFXSWGT, RT_DOMAIN(did)%OVROUGHRTFAC,RT_DOMAIN(did)%LKSATFAC, & + RT_DOMAIN(did)%CH_NETRT,RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%SMCREFRT, & + RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%SMCMAXRT, RT_DOMAIN(did)%SMCWLTRT, & + RT_DOMAIN(did)%SMCRT, & + RT_DOMAIN(did)%OVROUGHRT, RT_DOMAIN(did)%LAKE_MSKRT, & + RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%OV_ROUGH,RT_DOMAIN(did)%SLDPTH ) -!DJG----------------------------------------------------------------------- -!DJG SUBROUTINE GMT2LOCAL -!DJG----------------------------------------------------------------------- - subroutine GMT2LOCAL(IX,JX,XLONG,YY,MM,DD,HH,MIN,DT) + end subroutine disaggregateDomain_drv - implicit none + subroutine disaggregateDomain(IX,JX,NSOIL,IXRT,JXRT,AGGFACTRT, & + SICE, SMC,SH2OX, INFXSRT, area_lsm, SMCMAX1,SMCREF1, & + SMCWLT1, VEGTYP, LKSAT, dist,INFXSWGT,OVROUGHRTFAC, & + LKSATFAC, CH_NETRT,SH2OWGT,SMCREFRT, INFXSUBRT,SMCMAXRT, & + SMCWLTRT,SMCRT, OVROUGHRT, LAKE_MSKRT, LKSATRT,OV_ROUGH, & + SLDPTH & + ) +#ifdef MPP_LAND + use module_mpp_land, only: left_id,down_id,right_id, & + up_id,mpp_land_com_real, my_id, & + mpp_land_sync,mpp_land_com_integer,mpp_land_max_int1, & + sum_double +#endif + implicit none + integer,INTENT(IN) :: IX,JX,NSOIL,IXRT,JXRT,AGGFACTRT + real,INTENT(OUT),DIMENSION(IX,JX,NSOIL)::SICE + real,INTENT(IN),DIMENSION(IX,JX,NSOIL)::SMC,SH2OX + real,INTENT(IN),DIMENSION(IX,JX)::INFXSRT, area_lsm, SMCMAX1,SMCREF1, & + SMCWLT1, LKSAT + integer,INTENT(IN),DIMENSION(IX,JX) ::VEGTYP + + real,INTENT(IN),DIMENSION(IXRT,JXRT,9)::dist + real,INTENT(IN),DIMENSION(IXRT,JXRT)::INFXSWGT,OVROUGHRTFAC, & + LKSATFAC + integer,INTENT(IN), DIMENSION(IXRT,JXRT) ::CH_NETRT + real,INTENT(IN),DIMENSION(IXRT,JXRT,NSOIL)::SH2OWGT + real,INTENT(OUT),DIMENSION(IXRT,JXRT,NSOIL)::SMCREFRT, SMCMAXRT, & + SMCWLTRT,SMCRT + real,INTENT(OUT),DIMENSION(IXRT,JXRT)::INFXSUBRT + real,INTENT(INOUT),DIMENSION(IXRT,JXRT)::OVROUGHRT, LKSATRT + integer,INTENT(INOUT), DIMENSION(IXRT,JXRT) ::LAKE_MSKRT + -!!! Declare Passed Args. + real,INTENT(IN), DIMENSION(NSOIL) :: SLDPTH + REAL OV_ROUGH(*) - INTEGER, INTENT(INOUT) :: yy,mm,dd,hh,min - INTEGER, INTENT(IN) :: IX,JX - REAL,INTENT(IN), DIMENSION(IX,JX) :: XLONG - REAL,INTENT(IN) :: DT -!!! Declare local variables - integer :: i,j,minflag,hhflag,ddflag,mmflag,yyflag - integer :: adj_min,lst_adj_min,lst_adj_hh,adj_hh - real, dimension(IX,JX) :: TDIFF - real :: tmp - integer :: yyinit,mminit,ddinit,hhinit,mininit + integer :: i, j, AGGFACYRT, AGGFACXRT, IXXRT, JYYRT,KRT, KF + REAL :: LSMVOL,SMCEXCS, WATHOLDCAP +!------------------------------------- -!!! Initialize flags - hhflag=0 - ddflag=0 - mmflag=0 - yyflag=0 -!!! Set up constants... - yyinit = yy - mminit = mm - ddinit = dd - hhinit = hh - mininit = min + SICE=SMC-SH2OX + SMCREFRT = 0 -! Loop through data... - do j=1,JX - do i=1,IX +!DJG First, Disaggregate a few key fields for routing... +!DJG Debug... +#ifdef HYDRO_D + print *, "Beginning Disaggregation..." +#endif + +!DJG Mass balance check for disagg... -! Reset yy,mm,dd... - yy = yyinit - mm = mminit - dd = ddinit - hh = hhinit - min = mininit -!!! Set up adjustments... -! - assumes +E , -W longitude and 0.06667 hr/deg (=24/360) - TDIFF(I,J) = XLONG(I,J)*0.06667 ! time offset in hr - tmp = TDIFF(I,J) - lst_adj_hh = INT(tmp) - lst_adj_min = NINT(MOD(int(tmp),1)*60.) + int(DT/2./60.) ! w/ 1/2 timestep adjustment... +!DJG Weighting alg. alteration...(prescribe wghts if time = 1) -!!! Process Minutes... - adj_min = min+lst_adj_min - if (adj_min.lt.0) then - min=60+adj_min - lst_adj_hh = lst_adj_hh - 1 - else if (adj_min.ge.0.AND.adj_min.lt.60) then - min=adj_min - else if (adj_min.ge.60) then - min=adj_min-60 - lst_adj_hh = lst_adj_hh + 1 - end if -!!! Process Hours - adj_hh = hh+lst_adj_hh - if (adj_hh.lt.0) then - hh = 24+adj_hh - ddflag=1 - else if (adj_hh.ge.0.AND.adj_hh.lt.24) then - hh=adj_hh - else if (adj_hh.ge.24) then - hh=adj_hh-24 - ddflag = 2 - end if + do J=1,JX + do I=1,IX +!DJG Weighting alg. alteration... + LSMVOL=INFXSRT(I,J)*area_lsm(I,J) -!!! Process Days, Months, Years -! Subtract a day - if (ddflag.eq.1) then - if (dd.gt.1) then - dd=dd-1 - else - if (mm.eq.1) then - mm=12 - yy=yy-1 - else - mm=mm-1 - end if - if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & - (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & - (mm.eq.12)) then - dd=31 - else + do AGGFACYRT=AGGFACTRT-1,0,-1 + do AGGFACXRT=AGGFACTRT-1,0,-1 -!!! Adjustment for leap years!!! - if(mm.eq.2) then - if(MOD(yy,4).eq.0) then - dd=29 - else - dd=28 - end if - end if - if(mm.ne.2) dd=30 - end if - end if - end if + IXXRT=I*AGGFACTRT-AGGFACXRT + JYYRT=J*AGGFACTRT-AGGFACYRT +#ifdef MPP_LAND + if(left_id.ge.0) IXXRT=IXXRT+1 + if(down_id.ge.0) JYYRT=JYYRT+1 +#else +!yw ???? +! IXXRT=IXXRT+1 +! JYYRT=JYYRT+1 +#endif -! Add a day - if (ddflag.eq.2) then - if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & - (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & - (mm.eq.12)) then - if (dd.eq.31) then - dd=1 - if (mm.eq.12) then - mm=1 - yy=yy+1 - else - mm=mm+1 - end if - else - dd=dd+1 - end if -!!! Adjustment for leap years!!! - else if (mm.eq.2) then - if(MOD(yy,4).eq.0) then - if (dd.eq.29) then - dd=1 - mm=3 - else - dd=dd+1 - end if - else - if (dd.eq.28) then - dd=1 - mm=3 - else - dd=dd+1 - end if - end if - else - if (dd.eq.30) then - dd=1 - mm=mm+1 - else - dd=dd+1 - end if - end if +!DJG Implement subgrid weighting routine... + INFXSUBRT(IXXRT,JYYRT)=LSMVOL* & + INFXSWGT(IXXRT,JYYRT)/dist(IXXRT,JYYRT,9) + - end if + do KRT=1,NSOIL !Do for soil profile loop + IF(SICE(I,J,KRT).gt.0) then !...adjust for soil ice +!DJG Adjust SMCMAX for SICE when subsfc routing...make 3d variable + SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J)-SICE(I,J,KRT) + SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J)-SICE(I,J,KRT) + WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) + IF (SICE(I,J,KRT).le.WATHOLDCAP) then + SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) + else + if(SICE(I,J,KRT).lt.SMCMAX1(I,J)) & + SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - & + (SICE(I,J,KRT)-WATHOLDCAP) + if(SICE(I,J,KRT).ge.SMCMAX1(I,J)) SMCWLTRT(IXXRT,JYYRT,KRT) = 0. + end if + ELSE + SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J) + SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J) + WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) + SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) + END IF !endif adjust for soil ice... - end do !i-loop - end do !j-loop - return - end subroutine +!Now Adjust soil moisture +!DJG Use SH2O instead of SMC for 'liquid' water... + IF(SMCMAXRT(IXXRT,JYYRT,KRT).GT.0) THEN !Check for smcmax data (=0 over water) + SMCRT(IXXRT,JYYRT,KRT)=SH2OX(I,J,KRT)*SH2OWGT(IXXRT,JYYRT,KRT) +!old SMCRT(IXXRT,JYYRT,KRT)=SMC(I,J,KRT) + ELSE + SMCRT(IXXRT,JYYRT,KRT) = 0.001 !will be skipped w/ landmask + SMCMAXRT(IXXRT,JYYRT,KRT) = 0.001 + END IF +!DJG Check/Adjust so that subgrid cells do not exceed saturation... + IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN + SMCEXCS = (SMCRT(IXXRT,JYYRT,KRT) - SMCMAXRT(IXXRT,JYYRT,KRT)) & + * SLDPTH(KRT)*1000. !Excess soil water in units of (mm) + SMCRT(IXXRT,JYYRT,KRT) = SMCMAXRT(IXXRT,JYYRT,KRT) + DO KF = KRT-1,1, -1 !loop back upward to redistribute excess water from disagg. + SMCRT(IXXRT,JYYRT,KF) = SMCRT(IXXRT,JYYRT,KF) + SMCEXCS/(SLDPTH(KF)*1000.) + IF (SMCRT(IXXRT,JYYRT,KF).GT.SMCMAXRT(IXXRT,JYYRT,KF)) THEN !Recheck new lyr sat. + SMCEXCS = (SMCRT(IXXRT,JYYRT,KF) - SMCMAXRT(IXXRT,JYYRT,KF)) & + * SLDPTH(KF)*1000. !Excess soil water in units of (mm) + SMCRT(IXXRT,JYYRT,KF) = SMCMAXRT(IXXRT,JYYRT,KF) + ELSE ! Excess soil water expired + SMCEXCS = 0. + EXIT + END IF + END DO + IF (SMCEXCS.GT.0) THEN !If not expired by sfc then add to Infil. Excess + INFXSUBRT(IXXRT,JYYRT) = INFXSUBRT(IXXRT,JYYRT) + SMCEXCS + SMCEXCS = 0. + END IF + END IF !End if for soil moisture saturation excess -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE GMT2LOCAL -!DJG----------------------------------------------------------------------- + end do !End do for soil profile loop -!DJG----------------------------------------------------------------------- -!DJG SUBROUTINE JULDAY_CALC -!DJG----------------------------------------------------------------------- - subroutine JULDAY_CALC(YYYY,MM,DD,JULDAY) - implicit none - integer,intent(in) :: YYYY,MM,DD - integer,intent(out) :: JULDAY + do KRT=1,NSOIL !debug loop - integer :: resid - integer julm(13) - DATA JULM/0, 31, 59, 90, 120, 151, 181, 212, 243, 273, & - 304, 334, 365 / + IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN +#ifdef HYDRO_D + print *, "Err. SMCMAX exceeded upon disaggregation3...", ixxrt,jyyrt,krt,& + SMCRT(IXXRT,JYYRT,KRT),SMCMAXRT(IXXRT,JYYRT,KRT) + call hydro_stop("disaggregateDomain") +#endif + ELSE IF (SMCRT(IXXRT,JYYRT,KRT).LE.0.) THEN +#ifdef HYDRO_D + print *, "Err. SMCRT fully depleted upon disaggregation...", ixxrt,jyyrt,krt,& + SMCRT(IXXRT,JYYRT,KRT),SH2OWGT(IXXRT,JYYRT,KRT),SH2OX(I,J,KRT) - integer LPjulm(13) - DATA LPJULM/0, 31, 60, 91, 121, 152, 182, 213, 244, 274, & - 305, 335, 366 / + print*, "SMC=", SMC(i,j,KRT), "SICE =", sice(i,j,KRT) + print *, "VEGTYP = ", VEGTYP(I,J) + print *, "i,j,krt, nsoil",i,j,krt,nsoil + call hydro_stop("disaggregateDomain SMCRT depleted") +#endif + END IF + end do !debug loop - resid = MOD(YYYY,4) !Set up leap year check... - if (resid.ne.0) then !If not a leap year.... - JULDAY = JULM(MM) + DD - else !If a leap year... - JULDAY = LPJULM(MM) + DD - end if - RETURN - END subroutine JULDAY_CALC -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE JULDAY -!DJG----------------------------------------------------------------------- +!DJG map ov roughness as function of land use provided in VEGPARM.TBL... +! --- added extra check for VEGTYP for 'masked-out' locations... +! --- out of basin locations (VEGTYP=0) have OVROUGH hardwired to 0.1 + IF (VEGTYP(I,J).LE.0) then + OVROUGHRT(IXXRT,JYYRT) = 0.1 !COWS mask test + ELSE + OVROUGHRT(IXXRT,JYYRT)=OV_ROUGH(VEGTYP(I,J))*OVROUGHRTFAC(IXXRT,JYYRT) ! Distributed calibration...1/17/2012 + END IF -!DJG----------------------------------------------------------------------- -!DJG SUBROUTINE SLOPE_ASPECT -!DJG----------------------------------------------------------------------- - subroutine SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) - implicit none - integer, INTENT(IN) :: IX,JX -! real,INTENT(in),DIMENSION(IX,JX) :: TSLP !terrain slope (m/m) - real,INTENT(OUT),DIMENSION(IX,JX) :: TAZI !terrain aspect (deg) - INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D - real :: DGRD - integer :: i,j +!DJG 6.12.08 Map lateral hydraulic conductivity and apply distributed scaling +! --- factor that will be read in from hires terrain file +! LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) + LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) * LKSATFAC(IXXRT,JYYRT) * & !Apply scaling factor... +! ...and scale from max to 0 when SMC decreases from SMCMAX to SMCREF... +!!DJG error found from KIT,improper scaling ((SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL)) / & + (max(0.,(SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL))) / & + (SMCMAXRT(IXXRT,JYYRT,NSOIL)-SMCREFRT(IXXRT,JYYRT,NSOIL)) ) -! TSLP = 0. !Initialize as flat - TAZI = 0. !Initialize as north facing -! Find steepest descent slope and direction... - do j=1,JX - do i=1,IX -! TSLP(I,J) = TANH(Vmax(i,j)) ! calculate slope in radians... -! Convert steepest slope and aspect to radians... - IF (SO8LD_D(i,j,3).eq.1) then - TAZI(I,J) = 0.0 - ELSEIF (SO8LD_D(i,j,3).eq.2) then - TAZI(I,J) = 45.0 - ELSEIF (SO8LD_D(i,j,3).eq.3) then - TAZI(I,J) = 90.0 - ELSEIF (SO8LD_D(i,j,3).eq.4) then - TAZI(I,J) = 135.0 - ELSEIF (SO8LD_D(i,j,3).eq.5) then - TAZI(I,J) = 180.0 - ELSEIF (SO8LD_D(i,j,3).eq.6) then - TAZI(I,J) = 225.0 - ELSEIF (SO8LD_D(i,j,3).eq.7) then - TAZI(I,J) = 270.0 - ELSEIF (SO8LD_D(i,j,3).eq.8) then - TAZI(I,J) = 315.0 - END IF +!DJG set up lake mask... +!--- modify to make lake mask large here, but not one of the routed lakes!!! +!-- IF (VEGTYP(I,J).eq.16) then + IF (VEGTYP(I,J).eq.16 .and. & + CH_NETRT(IXXRT,JYYRT).le.0) then + !--LAKE_MSKRT(IXXRT,JYYRT) = 1 +!yw LAKE_MSKRT(IXXRT,JYYRT) = 9999 + LAKE_MSKRT(IXXRT,JYYRT) = -9999 + end if - DGRD = 3.141593/180. - TAZI(I,J) = TAZI(I,J)*DGRD ! convert azimuth to radians... + end do + end do - END DO - END DO + end do + end do - RETURN - END subroutine SLOPE_ASPECT -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE SLOPE_ASPECT -!DJG----------------------------------------------------------------------- -!DJG---------------------------------------------------------------- -!DJG SUBROUTINE SOLSUB -!DJG---------------------------------------------------------------- - SUBROUTINE SOLSUB(LONG,LAT,AZ,IN,SC,YY,MO,IDA,IHR,MM,OUT1, & - OUT2,OUT3,INCADJ) -! Notes.... +#ifdef HYDRO_D + print *, "After Disaggregation..." +#endif - implicit none - logical :: daily, first - integer :: yy,mo,ida,ihr,mm,d - integer,dimension(12) :: nday - real :: lat,long,longcor,longsun,in,inslo - real :: az,sc,out1,out2,out3,cosbeta,dzero,eccent,pi,calint - real :: rtod,decmax,omega,onehr,omd,omdzero,rdvecsq,sdec - real :: declin,cdec,arg,declon,sr,stdmrdn,b,em,timnoon,azslo - real :: slat,clat,caz,saz,sinc,cinc,hinc,h,cosz,extra,extslo - real :: t1,z,cosa,a,cosbeta_flat,INCADJ - integer :: HHTIME,MMTIME,i,ik - real, dimension(4) :: ACOF,BCOF +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(INFXSUBRT,IXRT,JXRT,99) + call MPP_LAND_COM_REAL(LKSATRT,IXRT,JXRT,99) + call MPP_LAND_COM_REAL(OVROUGHRT,IXRT,JXRT,99) + call MPP_LAND_COM_INTEGER(LAKE_MSKRT,IXRT,JXRT,99) + do i = 1, NSOIL + call MPP_LAND_COM_REAL(SMCMAXRT(:,:,i),IXRT,JXRT,99) + call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99) + call MPP_LAND_COM_REAL(SMCWLTRT(:,:,i),IXRT,JXRT,99) + end DO +#endif -! Constants - daily=.FALSE. - ACOF(1) = 0.00839 - ACOF(2) = -0.05391 - ACOF(3) = -0.00154 - ACOF(4) = -0.0022 - BCOF(1) = -0.12193 - BCOF(2) = -0.15699 - BCOF(3) = -0.00657 - BCOF(4) = -0.00370 - DZERO = 80. - ECCENT = 0.0167 - PI = 3.14159 - CALINT = 1. - RTOD = PI / 180. - DECMAX=(23.+26./60.)*RTOD - OMEGA=2*PI/365. - ONEHR=15.*RTOD + end subroutine disaggregateDomain + + subroutine SubsurfaceRouting_drv(did) + + use module_RT_data, only: rt_domain + use module_namelist, only: nlst_rt + implicit none + integer :: did + IF (nlst_rt(did)%SUBRTSWCRT.EQ.1) THEN + call subsurfaceRouting (RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt , nlst_rt(did)%nsoil, & + RT_DOMAIN(did)%SMCRT,RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCREFRT,& + RT_DOMAIN(did)%SMCWLTRT, RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SLDPTH, & + nlst_rt(did)%DT,RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SOXRT, & + RT_DOMAIN(did)%SOYRT,RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%SOLDEPRT, & + RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%QSUBBDRYTRT, RT_DOMAIN(did)%QSUBBDRYRT,& + RT_DOMAIN(did)%QSUBRT ,nlst_rt(did)%rt_option, RT_DOMAIN(did)%dist, & + RT_DOMAIN(did)%sub_resid,RT_DOMAIN(did)%SO8RT_D, RT_DOMAIN(did)%SO8RT) + endif + end subroutine SubsurfaceRouting_drv + + subroutine subsurfaceRouting (ixrt, jxrt , nsoil, & + SMCRT,SMCMAXRT,SMCREFRT,SMCWLTRT, & + ZSOIL, SLDPTH, & + DT,ZWATTABLRT,SOXRT,SOYRT,LKSATRT,& + SOLDEPRT,INFXSUBRT,QSUBBDRYTRT, QSUBBDRYRT,& + QSUBRT ,rt_option, dist,sub_resid,SO8RT_D, SO8RT) +#ifdef MPP_LAND + use module_mpp_land, only: mpp_land_com_real, mpp_land_com_integer +#endif + implicit none + integer, INTENT(IN) :: ixrt, jxrt , nsoil, rt_option + REAL, INTENT(IN) :: DT + real,INTENT(IN), DIMENSION(NSOIL) :: ZSOIL, SLDPTH + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT,SOYRT,LKSATRT, SOLDEPRT , sub_resid + real,INTENT(INOUT), DIMENSION(IXRT,JXRT)::INFXSUBRT + real,INTENT(INOUT) :: QSUBBDRYTRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBBDRYRT, QSUBRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT, SMCWLTRT, SMCMAXRT,SMCREFRT + + + INTEGER :: SO8RT_D(IXRT,JXRT,3) + REAL :: SO8RT(IXRT,JXRT,8) + REAL, INTENT(IN) :: dist(ixrt,jxrt,9) +! -----local array ---------- + REAL, DIMENSION(IXRT,JXRT) :: ZWATTABLRT + REAL, DIMENSION(IXRT,JXRT) :: CWATAVAIL + INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK + -! Calculate Julian Day... - D = 0 - call JULDAY_CALC(YY,MO,IDA,D) -! Ratio of radius vectors squared... - OMD=OMEGA*D - OMDZERO=OMEGA*DZERO -! RDVECSQ=1./(1.-ECCENT*COS(OMD))**2 - RDVECSQ = 1. ! no adjustment for orbital changes when coupled to HRLDAS... -! Declination of sun... - LONGSUN=OMEGA*(D-Dzero)+2.*ECCENT*(SIN(OMD)-SIN(OMDZERO)) - DECLIN=ASIN(SIN(DECMAX)*SIN(LONGSUN)) - SDEC=SIN(DECLIN) - CDEC=COS(DECLIN) + CWATAVAIL = 0. + CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & + SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, & + CWATAVAIL,SLDPTH) +#ifdef MPP_LAND + call MPP_LAND_COM_REAL(ZWATTABLRT,IXRT,JXRT,99) + call MPP_LAND_COM_REAL(CWATAVAIL,IXRT,JXRT,99) + call MPP_LAND_COM_INTEGER(SATLYRCHK,IXRT,JXRT,99) +#endif -! Check for Polar Day/night... - ARG=((PI/2.)-ABS(DECLIN))/RTOD - IF(ABS(LAT).GT.ARG) THEN - IF((LAT.GT.0..AND.DECLIN.LT.0) .OR. & - (LAT.LT.0..AND.DECLON.GT.0.)) THEN - OUT1 = 0. - OUT2 = 0. - OUT3 = 0. - RETURN - ENDIF - SR=-1.*PI - ELSE -! Calculate sunrise hour angle... - SR=-1.*ABS(ACOS(-1.*TAN(LAT*RTOD)*TAN(DECLIN))) - END IF +!DJG Second, Call subsurface routing routine... +#ifdef HYDRO_D + print *, "Beginning SUB_routing..." + print *, "Routing method is ",rt_option, " direction." +#endif -! Find standard meridian for site - STDMRDN=NINT(LONG/15.)*15. - LONGCOR=(LONG-STDMRDN)/15. +!!!! Find saturated layer depth... +! Loop through domain to determine sat. layers and assign wat tbl depth... +! and water available for subsfc routing (CWATAVAIL)... +! This subroutine returns: ZWATTABLRT, CWATAVAIL and SATLYRCHK -! Compute time correction from equation of time... - B=2.*PI*(D-.4)/365 - EM=0. - DO I=1,4 - EM=EM+(BCOF(I)*SIN(I*B)+ACOF(I)*COS(I*B)) - END DO -! Compute time of solar noon... - TIMNOON=12.-EM-LONGCOR + CALL SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & + LKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT,NSOIL,SMCRT, & + INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT,SMCWLTRT,SO8RT, & + SO8RT_D, rt_option,SLDPTH,SUB_RESID,CWATAVAIL,SATLYRCHK) -! Set up a few more terms... - AZSLO=AZ*RTOD - INSLO=IN*RTOD - SLAT=SIN(LAT*RTOD) - CLAT=COS(LAT*RTOD) - CAZ=COS(AZSLO) - SAZ=SIN(AZSLO) - SINC=SIN(INSLO) - CINC=COS(INSLO) +#ifdef HYDRO_D + print *, "SUBROUTE routing called and returned..." +#endif -! Begin solar radiation calculations...daily first, else instantaneous... - IF (DAILY) THEN ! compute daily integrated values...(Not used in HRLDAS!) - IHR=0 - MM=0 - HINC=CALINT*ONEHR/60. - IK=(2.*ABS(SR)/HINC)+2. - FIRST=.TRUE. - OUT1=0. - DO I=1,IK - H=SR+HINC*FLOAT(I-1) - COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) - COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & - SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & - SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) - EXTRA=SC*RDVECSQ*COSZ - IF(EXTRA.LE.0.) EXTRA=0. - EXTSLO=SC*RDVECSQ*COSBETA - IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. - IF(FIRST .AND. EXTSLO.GT.0.) THEN - OUT2=(H-HINC)/ONEHR+TIMNOON - FIRST = .FALSE. - END IF - IF(.NOT.FIRST .AND. EXTSLO.LE.0.) OUT3=H/ONEHR+TIMNOON - OUT1=EXTSLO+OUT1 - END DO - OUT1=OUT1*CALINT*60./1000000. + end subroutine subsurfaceRouting + + + subroutine OverlandRouting_drv(did) + use module_RT_data, only: rt_domain + use module_namelist, only: nlst_rt + implicit none + integer :: did + if(nlst_rt(did)%OVRTSWCRT .eq. 1) then + call OverlandRouting (nlst_rt(did)%DT, nlst_rt(did)%DTRT, nlst_rt(did)%rt_option, & + rt_domain(did)%ixrt, rt_domain(did)%jxrt,rt_domain(did)%LAKE_MSKRT, & + rt_domain(did)%INFXSUBRT, rt_domain(did)%RETDEPRT,rt_domain(did)%OVROUGHRT, & + rt_domain(did)%SOXRT, rt_domain(did)%SOYRT, rt_domain(did)%SFCHEADSUBRT, & + rt_domain(did)%DHRT, rt_domain(did)%CH_NETRT, rt_domain(did)%QSTRMVOLRT, & + rt_domain(did)%LAKE_INFLORT,rt_domain(did)%QBDRYRT, & + rt_domain(did)%QSTRMVOLTRT,rt_domain(did)%QBDRYTRT, rt_domain(did)%LAKE_INFLOTRT,& + rt_domain(did)%q_sfcflx_x,rt_domain(did)%q_sfcflx_y, & + rt_domain(did)%dist, rt_domain(did)%SO8RT, rt_domain(did)%SO8RT_D , & + rt_domain(did)%SMCTOT2,rt_domain(did)%suminfxs1,rt_domain(did)%suminfxsrt, & + rt_domain(did)%smctot1,rt_domain(did)%dsmctot ) + endif + end subroutine OverlandRouting_drv + + + + subroutine OverlandRouting (DT, DTRT, rt_option, ixrt, jxrt,LAKE_MSKRT, & + INFXSUBRT, RETDEPRT,OVROUGHRT,SOXRT, SOYRT, SFCHEADSUBRT,DHRT, & + CH_NETRT, QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, & + QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y, & + dist, SO8RT, SO8RT_D, & + SMCTOT2,suminfxs1,suminfxsrt,smctot1,dsmctot ) +#ifdef MPP_LAND + use module_mpp_land, only: mpp_land_max_int1, sum_double +#endif + implicit none - ELSE ! Compute instantaneous values...(Is used in HRLDAS!) + REAL, INTENT(IN) :: DT, DTRT + integer, INTENT(IN) :: ixrt, jxrt, rt_option + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - T1=FLOAT(IHR)+FLOAT(MM)/60. - H=ONEHR*(T1-TIMNOON) - COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: INFXSUBRT, & + RETDEPRT,OVROUGHRT,SOXRT, SOYRT + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SFCHEADSUBRT,DHRT + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, & + QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y -! Assuming HRLDAS forcing already accounts for season, time of day etc, -! subtract out the component of adjustment that would occur for -! a flat surface, this should leave only the sloped component remaining + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist + REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8) :: SO8RT + INTEGER SO8RT_D(IXRT,JXRT,3) - COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & - SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & - SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) + integer :: i,j + - COSBETA_FLAT=CDEC*CLAT*COS(H)+SDEC*SLAT + INTEGER, PARAMETER :: double1=8 + real (KIND=double1) :: smctot2,smctot1,dsmctot + real (KIND=double1) :: suminfxsrt,suminfxs1 +! local variable + real (KIND=double1) :: chan_in1,chan_in2 + real (KIND=double1) :: lake_in1,lake_in2 + real (KIND=double1) :: qbdry1,qbdry2 + integer :: sfcrt_flag - INCADJ = COSBETA+(1-COSBETA_FLAT) - EXTRA=SC*RDVECSQ*COSZ - IF(EXTRA.LE.0.) EXTRA=0. - EXTSLO=SC*RDVECSQ*INCADJ -! IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. !remove check for HRLDAS. - OUT1=EXTSLO - Z=ACOS(COSZ) - COSA=(SLAT*COSZ-SDEC)/(CLAT*SIN(Z)) - IF(COSA.LT.-1.) COSA=-1. - IF(COSA.GT.1.) COSA=1. - A=ABS(ACOS(COSA)) - IF(H.LT.0.) A=-A - OUT2=Z/RTOD - OUT3=A/RTOD+180 - END IF ! End if for daily vs instantaneous values... +!DJG Third, Call Overland Flow Routing Routine... +#ifdef HYDRO_D + print *, "Beginning OV_routing..." + print *, "Routing method is ",rt_option, " direction." +#endif -!DJG----------------------------------------------------------------------- - RETURN - END SUBROUTINE SOLSUB -!DJG----------------------------------------------------------------------- - - subroutine seq_land_SO8(SO8LD_D,Vmax,TERR,dx,ix,jx) - implicit none - integer :: ix,jx,i,j - REAL, DIMENSION(IX,JX,8) :: SO8LD - INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D - real,DIMENSION(IX,JX) :: TERR - real :: dx(ix,jx,9),Vmax(ix,jx) - SO8LD_D = -1 - do j = 2, jx -1 - do i = 2, ix -1 - SO8LD(i,j,1) = (TERR(i,j)-TERR(i,j+1))/dx(i,j,1) - SO8LD_D(i,j,1) = i - SO8LD_D(i,j,2) = j + 1 - SO8LD_D(i,j,3) = 1 - Vmax(i,j) = SO8LD(i,j,1) +!DJG debug...OV Routing... + suminfxs1=0. + chan_in1=0. + lake_in1=0. + qbdry1=0. + do i=1,IXRT + do j=1,JXRT + suminfxs1=suminfxs1+INFXSUBRT(I,J)/float(IXRT*JXRT) + chan_in1=chan_in1+QSTRMVOLRT(I,J)/float(IXRT*JXRT) + lake_in1=lake_in1+LAKE_INFLORT(I,J)/float(IXRT*JXRT) + qbdry1=qbdry1+QBDRYRT(I,J)/float(IXRT*JXRT) + end do + end do + +#ifdef MPP_LAND +! not tested + CALL sum_double(suminfxs1) + CALL sum_double(chan_in1) + CALL sum_double(lake_in1) + CALL sum_double(qbdry1) +#endif - SO8LD(i,j,2) = (TERR(i,j)-TERR(i+1,j+1))/DX(i,j,2) - if(SO8LD(i,j,2) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i + 1 - SO8LD_D(i,j,2) = j + 1 - SO8LD_D(i,j,3) = 2 - Vmax(i,j) = SO8LD(i,j,2) - end if - SO8LD(i,j,3) = (TERR(i,j)-TERR(i+1,j))/DX(i,j,3) - if(SO8LD(i,j,3) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i + 1 - SO8LD_D(i,j,2) = j - SO8LD_D(i,j,3) = 3 - Vmax(i,j) = SO8LD(i,j,3) - end if - SO8LD(i,j,4) = (TERR(i,j)-TERR(i+1,j-1))/DX(i,j,4) - if(SO8LD(i,j,4) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i + 1 - SO8LD_D(i,j,2) = j - 1 - SO8LD_D(i,j,3) = 4 - Vmax(i,j) = SO8LD(i,j,4) - end if - SO8LD(i,j,5) = (TERR(i,j)-TERR(i,j-1))/DX(i,j,5) - if(SO8LD(i,j,5) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - SO8LD_D(i,j,2) = j - 1 - SO8LD_D(i,j,3) = 5 - Vmax(i,j) = SO8LD(i,j,5) - end if - SO8LD(i,j,6) = (TERR(i,j)-TERR(i-1,j-1))/DX(i,j,6) - if(SO8LD(i,j,6) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - 1 - SO8LD_D(i,j,2) = j - 1 - SO8LD_D(i,j,3) = 6 - Vmax(i,j) = SO8LD(i,j,6) - end if - SO8LD(i,j,7) = (TERR(i,j)-TERR(i-1,j))/DX(i,j,7) - if(SO8LD(i,j,7) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - 1 - SO8LD_D(i,j,2) = j - SO8LD_D(i,j,3) = 7 - Vmax(i,j) = SO8LD(i,j,7) - end if - SO8LD(i,j,8) = (TERR(i,j)-TERR(i-1,j+1))/DX(i,j,8) - if(SO8LD(i,j,8) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - 1 - SO8LD_D(i,j,2) = j + 1 - SO8LD_D(i,j,3) = 8 - Vmax(i,j) = SO8LD(i,j,8) - end if - enddo - enddo - Vmax = TANH(Vmax) - return - end subroutine seq_land_SO8 + +!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(set sfcrt_flag) +!DJG.7.20.2007 - this check will skip ov rtng when no flow is present... + + sfcrt_flag = 0 + + do j=1,jxrt + do i=1,ixrt + if(INFXSUBRT(i,j).gt.RETDEPRT(i,j)) then + sfcrt_flag = 1 + exit + end if + end do + if(sfcrt_flag.eq.1) exit + end do #ifdef MPP_LAND - subroutine MPP_seq_land_SO8(SO8LD_D,Vmax,TERRAIN,dx,ix,jx,& - global_nx,global_ny) + call mpp_land_max_int1(sfcrt_flag) +#endif +!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(IF) - use module_mpp_land, only: my_id, io_id, & - write_io_real,decompose_data_int,decompose_data_real + if (sfcrt_flag.eq.1) then !If/then for sfc_rt check... +#ifdef HYDRO_D + write(6,*) "calling OV_RTNG " +#endif + CALL OV_RTNG(DT,DTRT,IXRT,JXRT,INFXSUBRT,SFCHEADSUBRT,DHRT, & + CH_NETRT,RETDEPRT,OVROUGHRT,QSTRMVOLRT,QBDRYRT, & + QSTRMVOLTRT,QBDRYTRT,SOXRT,SOYRT,dist, & + LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT,SO8RT,SO8RT_D,rt_option,& + q_sfcflx_x,q_sfcflx_y) + else +#ifdef HYDRO_D + print *, "No water to route overland..." +#endif + end if !Endif for sfc_rt check... - implicit none - integer,intent(in) :: ix,jx,global_nx,global_ny - INTEGER, intent(inout),DIMENSION(IX,JX,3) :: SO8LD_D -! real,intent(in), DIMENSION(IX,JX) :: TERRAIN - real,DIMENSION(IX,JX) :: TERRAIN - real,intent(out),dimension(ix,jx) :: Vmax - real,intent(in) :: dx(ix,jx,9) - real :: g_dx(ix,jx,9) +!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(ENDIF) - real,DIMENSION(global_nx,global_ny) :: g_TERRAIN - real,DIMENSION(global_nx,global_ny) :: g_Vmax - integer,DIMENSION(global_nx,global_ny,3) :: g_SO8LD_D - integer :: k +#ifdef HYDRO_D + print *, "OV routing called and returned..." +#endif - g_SO8LD_D = 0 - g_Vmax = 0 - - do k = 1, 9 - call write_IO_real(dx(:,:,k),g_dx(:,:,k)) +!DJG Debug...OV Routing... + suminfxsrt=0. + chan_in2=0. + lake_in2=0. + qbdry2=0. + do i=1,IXRT + do j=1,JXRT + suminfxsrt=suminfxsrt+SFCHEADSUBRT(I,J)/float(IXRT*JXRT) + chan_in2=chan_in2+QSTRMVOLRT(I,J)/float(IXRT*JXRT) + lake_in2=lake_in2+LAKE_INFLORT(I,J)/float(IXRT*JXRT) + qbdry2=qbdry2+QBDRYRT(I,J)/float(IXRT*JXRT) end do + end do +#ifdef MPP_LAND +! not tested + CALL sum_double(suminfxsrt) + CALL sum_double(chan_in2) + CALL sum_double(lake_in2) + CALL sum_double(qbdry2) +#endif - call write_IO_real(TERRAIN,g_TERRAIN) - if(my_id .eq. IO_id) then - call seq_land_SO8(g_SO8LD_D,g_Vmax,g_TERRAIN,g_dx,global_nx,global_ny) - endif - call decompose_data_int(g_SO8LD_D(:,:,3),SO8LD_D(:,:,3)) - call decompose_data_real(g_Vmax,Vmax) - return - end subroutine MPP_seq_land_SO8 - +#ifdef HYDRO_D + print *, "OV Routing Mass Bal: " + print *, "Infil. Excess/Sfc Head: ", suminfxsrt-suminfxs1, & + suminfxsrt,suminfxs1 + print *, "chan_in = ",chan_in2-chan_in1 + print *, "lake_in = ",lake_in2-lake_in1 + print *, "Qbdry = ",qbdry2-qbdry1 + print *, "Residual : ", suminfxs1-suminfxsrt-(chan_in2-chan_in1) & + -(lake_in2-lake_in1)-(qbdry2-qbdry1) #endif + + end subroutine OverlandRouting + + + subroutine time_seconds(i3) + integer time_array(8) + real*8 i3 + call date_and_time(values=time_array) + i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + & + time_array(7) + 0.001 * time_array(8) + return + end subroutine time_seconds + diff --git a/wrfv2_fire/hydro/Routing/module_GW_baseflow.F b/wrfv2_fire/hydro/Routing/module_GW_baseflow.F index c58c2e37..7b72ff1e 100644 --- a/wrfv2_fire/hydro/Routing/module_GW_baseflow.F +++ b/wrfv2_fire/hydro/Routing/module_GW_baseflow.F @@ -7,7 +7,7 @@ module module_GW_baseflow #include "gw_field_include.inc" #include "rt_include.inc" -#include "namelist.inc" +!yw #include "namelist.inc" contains !------------------------------------------------------------------------------ @@ -15,7 +15,7 @@ module module_GW_baseflow !------------------------------------------------------------------------------ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,basns_area,& - gwsubbasmsk, runoff1x, runoff2x, z_gwsubbas, qin_gwsubbas,& + gwsubbasmsk, runoff1x, runoff2x, z_gwsubbas_tmp, qin_gwsubbas,& qout_gwsubbas,qinflowbase,gw_strm_msk,gwbas_pix_ct,dist,DT,& C,ex,z_mx,GWBASESWCRT,OVRTSWCRT) implicit none @@ -30,11 +30,14 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,basns_area,& real, intent(in),dimension(numbasns) :: C,ex,z_mx real, intent(out),dimension(numbasns) :: qout_gwsubbas real, intent(out),dimension(numbasns) :: qin_gwsubbas - real, intent(out),dimension(numbasns) :: z_gwsubbas + real*8 :: z_gwsubbas(numbasns) + real :: qout_max, qout_spill, z_gw_spill + real, intent(inout),dimension(numbasns) :: z_gwsubbas_tmp real, intent(out),dimension(ixrt,jxrt) :: qinflowbase integer, intent(in),dimension(ixrt,jxrt) :: gw_strm_msk integer, intent(in) :: GWBASESWCRT integer, intent(in) :: OVRTSWCRT + real*8, dimension(numbasns) :: sum_perc8,ct_bas8 real, dimension(numbasns) :: sum_perc @@ -43,7 +46,6 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,basns_area,& real, dimension(numbasns) :: ct_bas real, dimension(numbasns) :: gwbas_pix_ct integer :: i,j,bas - real :: zbastmp character(len=19) :: header character(len=1) :: jnk @@ -54,6 +56,7 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,basns_area,& net_perc = 0. qout_gwsubbas = 0. qin_gwsubbas = 0. + z_gwsubbas = z_gwsubbas_tmp @@ -86,45 +89,99 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,basns_area,& !!!Loop through GW basins to adjust for inflow/outflow DO bas=1,numbasns ! Loop for GW bucket calcs... -#ifdef MPP_LAND - if(ct_bas(bas) .gt. 0) then -#endif +! #ifdef MPP_LAND +! if(ct_bas(bas) .gt. 0) then +! #endif net_perc(bas) = sum_perc(bas) / ct_bas(bas) !units (mm) - qin_gwsubbas(bas) = net_perc(bas)/1000. * ct_bas(bas) * basns_area(bas) !units (m^3) +!DJG...old change to cms qin_gwsubbas(bas) = net_perc(bas)/1000. * ct_bas(bas) * basns_area(bas) !units (m^3) + qin_gwsubbas(bas) = net_perc(bas)/1000.* & + ct_bas(bas)*basns_area(bas)/DT !units (m^3/s) -!Adjust level of GW depth...(conceptual GW bucket units (m)) - z_gwsubbas(bas) = z_gwsubbas(bas) + net_perc(bas) / 1000.0 ! (m) - zbastmp = z_gwsubbas(bas) -!Calculate baseflow as a function of GW depth... +!Adjust level of GW depth...(conceptual GW bucket units (mm)) +!DJG...old change to cms inflow... z_gwsubbas(bas) = z_gwsubbas(bas) + net_perc(bas) / 1000.0 ! (m) - if(GWBASESWCRT.eq.1) then !active exponential bucket... -! Assuming and exponential relation between z and Q... - qout_gwsubbas(bas) = C(bas)*EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas)) !Exp.model. q_out (m^3/s) +!DJG...debug write (6,*) "DJG...before",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas) -!Adjust level of GW depth... - z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT & - / (ct_bas(bas)*basns_area(bas)) !units(m) + z_gwsubbas(bas) = z_gwsubbas(bas) + qin_gwsubbas(bas)*DT/( & + ct_bas(bas)*basns_area(bas))*1000. ! units (mm) + + + + + +!Calculate baseflow as a function of GW bucket depth... + + if(GWBASESWCRT.eq.1) then !active exponential bucket... if/then for bucket model discharge type... + +!DJG...Estimation of bucket 'overflow' (qout_spill) if/when bucket gets filled... + qout_spill = 0. + z_gw_spill = 0. + if (z_gwsubbas(bas).gt.z_mx(bas)) then !If/then for bucket overflow case... + z_gw_spill = z_gwsubbas(bas) - z_mx(bas) + z_gwsubbas(bas) = z_mx(bas) + write (6,*) "Bucket spilling...", bas, z_gwsubbas(bas), z_mx(bas), z_gw_spill + else + z_gw_spill = 0. + end if ! End if for bucket overflow case... + + qout_spill = z_gw_spill/1000.*(ct_bas(bas)*basns_area(bas))/DT !amount spilled from bucket overflow...units (cms) + + +!DJG...Maximum estimation of bucket outlfow that is limited by total quantity in bucket... + qout_max = z_gwsubbas(bas)/1000.*(ct_bas(bas)*basns_area(bas))/DT ! Estimate max bucket disharge limit to total volume in bucket...(m^3/s) + + +! Assume exponential relation between z/zmax and Q... +!DJG...old...creates non-asymptotic flow... qout_gwsubbas(bas) = C(bas)*EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas)) !Exp.model. q_out (m^3/s) +!DJG force asymptote to zero to prevent 'overdraft'... +!DJG debug hardwire test... qout_gwsubbas(bas) = 1*(EXP(7.0*10./100.)-1) !Exp.model. q_out (m^3/s) + qout_gwsubbas(bas) = C(bas)*(EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas))-1) !Exp.model. q_out (m^3/s) + +!DJG...Calculation of max bucket outlfow that is limited by total quantity in bucket... + qout_gwsubbas(bas) = MIN(qout_max,qout_gwsubbas(bas)) ! Limit bucket discharge to max. bucket limit + + write (6,*) "DJG-exp bucket...during",C(bas),ex(bas),z_gwsubbas(bas),qin_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max, qout_spill elseif (GWBASESWCRT.eq.2) then !Pass through/steady-state bucket ! Assuming a steady-state (inflow=outflow) model... - qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3) +!DJG convert input and output units to cms... qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3) + qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3/s) +!DJG...debug write (6,*) "DJG-pass through...during",C(bas),ex(bas),qin_gwsubbas(bas), z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max + end if ! End if for bucket model discharge type.... - end if -#ifdef MPP_LAND - endif -#endif +!Adjust level of GW depth... +!DJG bug adjust output to be mm and correct area bug... z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT & +!DJG bug adjust output to be mm and correct area bug... / (ct_bas(bas)*basns_area(bas)) !units(m) + + z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT/( & + ct_bas(bas)*basns_area(bas))*1000. ! units (mm) + +!DJG...Combine calculated bucket discharge and amount spilled from bucket... + qout_gwsubbas(bas) = qout_gwsubbas(bas) + qout_spill ! units (cms) + + + write (6,*) "DJG...after",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_spill + write (6,*) "DJG...after...calc",bas,ct_bas(bas),ct_bas(bas)*basns_area(bas),basns_area(bas),DT + + + + +! #ifdef MPP_LAND +! endif +! #endif END DO ! End loop for GW bucket calcs... + z_gwsubbas_tmp = z_gwsubbas !!!Distribute basin integrated baseflow to stream pixels as stream 'inflow'... @@ -137,15 +194,8 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,basns_area,& !!! -simple uniform disaggregation (8.31.06) if (gw_strm_msk(i,j).gt.0) then - if(GWBASESWCRT.eq.1) then !calc stream inflow from exponential bucket... (m^3/s to mm) qinflowbase(i,j) = qout_gwsubbas(gw_strm_msk(i,j))*1000.*DT/ & - gwbas_pix_ct(gw_strm_msk(i,j))/dist(i,j,9) !(mm) - - elseif (GWBASESWCRT.eq.2) then !calc stream inflow from passthrough/steady-state bucket (m^3 to mm) - qinflowbase(i,j) = qout_gwsubbas(gw_strm_msk(i,j))*1000./ & - gwbas_pix_ct(gw_strm_msk(i,j))/dist(i,j,9) !(mm) - - end if + gwbas_pix_ct(gw_strm_msk(i,j))/dist(i,j,9) ! units (mm) that gets passed into chan routing as stream inflow end if end do @@ -160,6 +210,8 @@ subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,basns_area,& ! end do ! end do + z_gwsubbas = z_gwsubbas_tmp + return !------------------------------------------------------------------------------ @@ -167,13 +219,8 @@ End subroutine simp_gw_buck !------------------------------------------------------------------------------ -!------------------------------------------------------------------------------ -!DJG Wedge-Aquifer Scheme (TBA) -!------------------------------------------------------------------------------ -!------------------------------------------------------------------------------ -!DJG TOPMODEL Scheme (TBA) -!------------------------------------------------------------------------------ + #ifdef MPP_LAND subroutine pix_ct_1(in_gw_strm_msk,ixrt,jxrt,gwbas_pix_ct,numbasns) USE module_mpp_land diff --git a/wrfv2_fire/hydro/Routing/module_HYDRO_io.F b/wrfv2_fire/hydro/Routing/module_HYDRO_io.F index 6b68dce6..54fbdf93 100644 --- a/wrfv2_fire/hydro/Routing/module_HYDRO_io.F +++ b/wrfv2_fire/hydro/Routing/module_HYDRO_io.F @@ -88,7 +88,7 @@ subroutine get2d_lsm_vegtyp(out_buff,ix,jx,fileName) #ifdef HYDRO_D write(*,'("Problem opening geo_static file: ''", A, "''")') & trim(fileName) - call hydro_stop() + call hydro_stop("get2d_lsm_vegtyp") #endif endif @@ -96,7 +96,7 @@ subroutine get2d_lsm_vegtyp(out_buff,ix,jx,fileName) if (iret /= 0) then #ifdef HYDRO_D print*, "nf_inq_dimid: land_cat" - call hydro_stop() + call hydro_stop("get2d_lsm_vegtyp") #endif endif @@ -104,7 +104,7 @@ subroutine get2d_lsm_vegtyp(out_buff,ix,jx,fileName) if (iret /= 0) then #ifdef HYDRO_D print*, "nf_inq_dimlen: land_cat" - call hydro_stop() + call hydro_stop("get2d_lsm_vegtyp") #endif endif @@ -134,7 +134,7 @@ subroutine get_file_dimension(fileName, ix,jx) #ifdef HYDRO_D write(*,'("Problem opening geo_static file: ''", A, "''")') & trim(fileName) - call hydro_stop() + call hydro_stop("get_file_dimension") #endif endif @@ -143,7 +143,7 @@ subroutine get_file_dimension(fileName, ix,jx) if (iret /= 0) then #ifdef HYDRO_D print*, "nf_inq_dimid: west_east" - call hydro_stop() + call hydro_stop("get_file_dimension") #endif endif @@ -151,7 +151,7 @@ subroutine get_file_dimension(fileName, ix,jx) if (iret /= 0) then #ifdef HYDRO_D print*, "nf_inq_dimlen: west_east" - call hydro_stop() + call hydro_stop("get_file_dimension") #endif endif @@ -159,7 +159,7 @@ subroutine get_file_dimension(fileName, ix,jx) if (iret /= 0) then #ifdef HYDRO_D print*, "nf_inq_dimid: south_north" - call hydro_stop() + call hydro_stop("get_file_dimension") #endif endif @@ -167,7 +167,7 @@ subroutine get_file_dimension(fileName, ix,jx) if (iret /= 0) then #ifdef HYDRO_D print*, "nf_inq_dimlen: south_north" - call hydro_stop() + call hydro_stop("get_file_dimension") #endif endif iret = nf_close(ncid) @@ -199,7 +199,7 @@ subroutine get2d_lsm_soltyp(out_buff,ix,jx,fileName) #ifdef HYDRO_D write(*,'("Problem opening geo_static file: ''", A, "''")') & trim(fileName) - call hydro_stop() + call hydro_stop("get2d_lsm_soltyp") #endif endif @@ -207,7 +207,7 @@ subroutine get2d_lsm_soltyp(out_buff,ix,jx,fileName) if (iret /= 0) then #ifdef HYDRO_D print*, "nf_inq_dimid: soil_cat" - call hydro_stop() + call hydro_stop("get2d_lsm_soltyp") #endif endif @@ -215,7 +215,7 @@ subroutine get2d_lsm_soltyp(out_buff,ix,jx,fileName) if (iret /= 0) then #ifdef HYDRO_D print*, "nf_inq_dimlen: soil_cat" - call hydro_stop() + call hydro_stop("get2d_lsm_soltyp") #endif endif @@ -258,7 +258,7 @@ subroutine get_landuse_netcdf(ncid, array, units, idim, jdim, ldim) #ifdef HYDRO_D print*, 'name = "', trim(name)//'"' print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_landuse_netcdf: nf_inq_varid" - call hydro_stop() + call hydro_stop("get_landuse_netcdf") #endif endif @@ -267,7 +267,7 @@ subroutine get_landuse_netcdf(ncid, array, units, idim, jdim, ldim) #ifdef HYDRO_D print*, 'name = "', trim(name)//'"' print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_landuse_netcdf: nf_get_var_real" - call hydro_stop() + call hydro_stop("get_landuse_netcdf") #endif endif @@ -305,7 +305,7 @@ subroutine get_soilcat_netcdf(ncid, array, units, idim, jdim, ldim) #ifdef HYDRO_D print*, 'name = "', trim(name)//'"' print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_soilcat_netcdf: nf_inq_varid" - call hydro_stop() + call hydro_stop("get_soilcat_netcdf") #endif endif @@ -314,7 +314,7 @@ subroutine get_soilcat_netcdf(ncid, array, units, idim, jdim, ldim) #ifdef HYDRO_D print*, 'name = "', trim(name)//'"' print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_soilcat_netcdf: nf_get_var_real" - call hydro_stop() + call hydro_stop("get_soilcat_netcdf") #endif endif @@ -354,7 +354,7 @@ subroutine get_greenfrac_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) #ifdef HYDRO_D print*, 'name = "', trim(name)//'"' print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_greenfrac_netcdf: nf_inq_varid" - call hydro_stop() + call hydro_stop("get_greenfrac_netcdf") #endif endif @@ -363,7 +363,7 @@ subroutine get_greenfrac_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) #ifdef HYDRO_D print*, 'name = "', trim(name)//'"' print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_greenfrac_netcdf: nf_get_var_real" - call hydro_stop() + call hydro_stop("get_greenfrac_netcdf") #endif endif @@ -427,7 +427,7 @@ subroutine get_albedo12m_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) #ifdef HYDRO_D print*, 'name = "', trim(name)//'"' print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_albedo12m_netcdf: nf_inq_varid" - call hydro_stop() + call hydro_stop("get_albedo12m_netcdf") #endif endif @@ -436,7 +436,7 @@ subroutine get_albedo12m_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) #ifdef HYDRO_D print*, 'name = "', trim(name)//'"' print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_albedo12m_netcdf: nf_get_var_real" - call hydro_stop() + call hydro_stop("get_albedo12m_netcdf") #endif endif @@ -499,7 +499,7 @@ subroutine get_2d_netcdf(name, ncid, array, units, idim, jdim, & #ifdef HYDRO_D print*, 'name = "', trim(name)//'"' print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf: nf_inq_varid" - call hydro_stop() + call hydro_stop("get_2d_netcdf") #endif else ierr = iret @@ -514,7 +514,7 @@ subroutine get_2d_netcdf(name, ncid, array, units, idim, jdim, & #ifdef HYDRO_D print*, 'name = "', trim(name)//'"' print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf: nf_get_var_real" - call hydro_stop() + call hydro_stop("get_2d_netcdf") #endif else ierr = iret @@ -546,7 +546,7 @@ subroutine get_2d_netcdf_cows(var_name,ncid,var, & if (fatal_IF_ERROR) then #ifdef HYDRO_D print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid" - call hydro_stop() + call hydro_stop("get_2d_netcdf_cows") #endif else ierr = iret @@ -571,6 +571,7 @@ end subroutine get_2d_netcdf_cows !DJG,DNY - Update this subroutine to read in channel and lake ! parameters if activated 11.20.2005 !--------------------------------------------------------- + SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, & route_direction_f, route_lake_f, NLINKS, NLAKES, & CH_NETLNK, channel_option, geo_finegrid_flnm) @@ -588,10 +589,6 @@ SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, & REAL, DIMENSION(IXRT,JXRT) :: LAT, LON !!Dummy read in grids for inverted y-axis - INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT_inv !- binary channel mask - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION_inv !- flow direction - INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT_inv - REAL, DIMENSION(IXRT,JXRT) :: LAT_inv, LON_inv CHARACTER(len=*) :: route_chan_f, route_link_f,route_direction_f,route_lake_f @@ -615,39 +612,24 @@ SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, & IF(channel_option.eq.3) then !get maxnodes and links from grid var_name = "CHANNELGRID" - call get2d_int(var_name,CH_NETRT_inv,ixrt,jxrt,& + call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& trim(geo_finegrid_flnm)) var_name = "FLOWDIRECTION" - call get2d_int(var_name,DIRECTION_inv,ixrt,jxrt,& + call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,& trim(geo_finegrid_flnm)) var_name = "LAKEGRID" - call get2d_int(var_name,LAKE_MSKRT_inv,ixrt,jxrt,& + call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& trim(geo_finegrid_flnm)) var_name = "LATITUDE" - iret = get2d_real(var_name,LAT_inv,ixrt,jxrt,& + call readRT2d_real(var_name,LAT,ixrt,jxrt,& trim(geo_finegrid_flnm)) var_name = "LONGITUDE" - iret = get2d_real(var_name,LON_inv,ixrt,jxrt,& + call readRT2d_real(var_name,LON,ixrt,jxrt,& trim(geo_finegrid_flnm)) - -!!!Flip y-dimension of highres grids from exported Arc files... - - - do i=1,ixrt - jj=jxrt - do j=1,jxrt - CH_NETRT(i,j)=CH_NETRT_inv(i,jj) - DIRECTION(i,j)=DIRECTION_inv(i,jj) - LAKE_MSKRT(i,j)=LAKE_MSKRT_inv(i,jj) - LAT(i,j)=LAT_inv(i,jj) - LON(i,j)=LON_inv(i,jj) - jj=jxrt-j - end do - end do ! temp fix for buggy Arc export... do j=1,jxrt @@ -656,7 +638,6 @@ SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, & end do end do - !DJG inv do j=jxrt,1,-1 do j=1,jxrt do i = 1, ixrt @@ -803,8 +784,9 @@ SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, & if (cnt .ne. NLINKS) then #ifdef HYDRO_D print *, "Apparent error in network topology", cnt, NLINKS - call hydro_stop() + print* , "ixrt =", ixrt, "jxrt =", jxrt #endif + call hydro_stop("READ_ROUTEDIM") endif !DJG inv do j=jxrt,1,-1 do j=1,jxrt @@ -840,7 +822,6 @@ SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, & END SUBROUTINE READ_ROUTEDIM -!--------------------------------------------------------- SUBROUTINE READ_CHROUTING(IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, & NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, & @@ -858,37 +839,32 @@ SUBROUTINE READ_CHROUTING(IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION INTEGER, DIMENSION(IXRT,JXRT) :: GSTRMFRXSTPTS - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT INTEGER, DIMENSION(IXRT,JXRT) :: GORDER !-- gridded stream orderk INTEGER, DIMENSION(IXRT,JXRT) :: Link_Location !-- gridded stream orderk INTEGER :: I,J,channel_option REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LATVAL, LONVAL CHARACTER(len=28) :: dir !Dummy inverted grids from arc - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION_inv - INTEGER, DIMENSION(IXRT,JXRT) :: GSTRMFRXSTPTS_inv - INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT_inv - INTEGER, DIMENSION(IXRT,JXRT) :: GORDER_inv !-- gridded stream orderk - REAL, DIMENSION(IXRT,JXRT) :: LATVAL_inv, LONVAL_inv !----DJG,DNY New variables for channel and lake routing CHARACTER(len=155) :: header - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: FROM_NODE - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ZELEV - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHLAT,CHLON - - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TYPEL - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TO_NODE,ORDER - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: STRMFRXSTPTS - - INTEGER, INTENT(INOUT) :: MAXORDER - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum - REAL, INTENT(INOUT), DIMENSION(NLINKS,2) :: QLINK !channel flow - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHANLEN !channel length - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MannN, So !mannings N - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: LAKENODE ! identifies which nodes pour into which lakes + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: FROM_NODE + REAL, INTENT(OUT), DIMENSION(NLINKS) :: ZELEV + REAL, INTENT(OUT), DIMENSION(NLINKS) :: CHLAT,CHLON + + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: TYPEL + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: TO_NODE,ORDER + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: STRMFRXSTPTS + + INTEGER, INTENT(OUT) :: MAXORDER + REAL, INTENT(OUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum + REAL, INTENT(OUT), DIMENSION(NLINKS,2) :: QLINK !channel flow + REAL, INTENT(OUT), DIMENSION(NLINKS) :: CHANLEN !channel length + REAL, INTENT(OUT), DIMENSION(NLINKS) :: MannN, So !mannings N + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: LAKENODE ! identifies which nodes pour into which lakes REAL, INTENT(IN) :: dist(ixrt,jxrt,9) INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK @@ -896,18 +872,18 @@ SUBROUTINE READ_CHROUTING(IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & !-- store the location x,y location of the channel element - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ + INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ !--reservoir/lake attributes - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: HRZAREA - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: LAKEMAXH - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: WEIRC - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: WEIRL - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ORIFICEC - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ORIFICEA - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ORIFICEE - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: LATLAKE,LONLAKE,ELEVLAKE - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ChSSlp, Bw + REAL, INTENT(OUT), DIMENSION(NLAKES) :: HRZAREA + REAL, INTENT(OUT), DIMENSION(NLAKES) :: LAKEMAXH + REAL, INTENT(OUT), DIMENSION(NLAKES) :: WEIRC + REAL, INTENT(OUT), DIMENSION(NLAKES) :: WEIRL + REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEC + REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEA + REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEE + REAL, INTENT(OUT), DIMENSION(NLAKES) :: LATLAKE,LONLAKE,ELEVLAKE + REAL, INTENT(OUT), DIMENSION(NLINKS) :: ChSSlp, Bw CHARACTER(len=256) :: route_link_f CHARACTER(len=256) :: route_lake_f @@ -936,6 +912,15 @@ SUBROUTINE READ_CHROUTING(IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & print *, "route order", route_order_f print *, "route linke",route_link_f print *, "route lake",route_lake_f + + BwG = 0.0 + ChSSlpG = 0.0 + MannNG = 0.0 + TYPEL = 0 + MannN = 0.0 + Bw = 0.0 + ChSSlp = 0.0 + #endif !DJG Edited code here to retrieve data from hires netcdf file.... @@ -943,10 +928,10 @@ SUBROUTINE READ_CHROUTING(IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & IF((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then var_name = "LATITUDE" - iret = get2d_real(var_name,LATVAL_inv,ixrt,jxrt,& + call readRT2d_real(var_name,LATVAL,ixrt,jxrt,& trim(geo_finegrid_flnm)) var_name = "LONGITUDE" - iret = get2d_real(var_name,LONVAL_inv,ixrt,jxrt,& + call readRT2d_real(var_name,LONVAL,ixrt,jxrt,& trim(geo_finegrid_flnm)) END IF @@ -960,24 +945,24 @@ SUBROUTINE READ_CHROUTING(IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & var_name = "LAKEGRID" - call get2d_int(var_name,LAKE_MSKRT_inv,ixrt,jxrt,& + call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& trim(geo_finegrid_flnm)) var_name = "FLOWDIRECTION" - call get2d_int(var_name,DIRECTION_inv,ixrt,jxrt,& + call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,& trim(geo_finegrid_flnm)) var_name = "STREAMORDER" - call get2d_int(var_name,GORDER_inv,ixrt,jxrt,& + call readRT2d_int(var_name,GORDER,ixrt,jxrt,& trim(geo_finegrid_flnm)) var_name = "frxst_pts" - call get2d_int(var_name,GSTRMFRXSTPTS_inv,ixrt,jxrt,& + call readRT2d_int(var_name,GSTRMFRXSTPTS,ixrt,jxrt,& trim(geo_finegrid_flnm)) !--1/13/2011 real hi res sfc calibrtion parameters (...) ! var_name = "LAKEGRID" -! call get2d_int(var_name,LAKE_MSKRT_inv,ixrt,jxrt,& +! call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& ! trim(geo_finegrid_flnm)) ! var_name = "LAKEGRID" -! call get2d_int(var_name,LAKE_MSKRT_inv,ixrt,jxrt,& +! call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& ! trim(geo_finegrid_flnm)) @@ -996,30 +981,8 @@ SUBROUTINE READ_CHROUTING(IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & !!!Flip y-dimension of highres grids from exported Arc files... - ct = 0 - do i=1,ixrt - jj=jxrt - do j=1,jxrt - LAKE_MSKRT(i,j)=LAKE_MSKRT_inv(i,jj) - DIRECTION(i,j)=DIRECTION_inv(i,jj) - GORDER(i,j)=GORDER_inv(i,jj) - GSTRMFRXSTPTS(i,j)=GSTRMFRXSTPTS_inv(i,jj) - if(GSTRMFRXSTPTS(i,j).ne.-9999) ct = ct+1 - LATVAL(i,j)=LATVAL_inv(i,jj) - LONVAL(i,j)=LONVAL_inv(i,jj) - jj=jxrt-j - end do - end do -! if(dist(1,1,1) .eq. -999) then -! call get_dist_ll(dist,latval,lonval,ixrt,jxrt) -! end if - -#ifdef HYDRO_D - print *, "Number of frxst pts: ",ct -#endif - ! temp fix for buggy Arc export... do j=1,jxrt @@ -1073,6 +1036,16 @@ SUBROUTINE READ_CHROUTING(IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & cnt = 0 !yw add temperary to initialize the following two variables. + +!yw debug +! write(6,*) "ixrt =",ixrt, "jxrt=",jxrt +! write(18) CH_NETRT +! write(19) DIRECTION +! write(20) GORDER +! write(21) GSTRMFRXSTPTS +! write(22) ELRT +!ywend debug + BwG = 0.0 ChSSlpG = 0.0 @@ -1467,170 +1440,66 @@ SUBROUTINE READ_CHROUTING(IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & if (cnt .ne. NLINKS) then #ifdef HYDRO_D print *, "Apparent error in network topology", cnt, NLINKS - call hydro_stop() + print* , "ixrt =", ixrt, "jxrt =", jxrt #endif + call hydro_stop("READ_CHROUTING") endif + do i=1,NLINKS #ifdef HYDRO_D if (STRMFRXSTPTS(i).ne.-9999) print *,"Frxst_pt: ",STRMFRXSTPTS(i) #endif end do + return !DJG ----------------------------------------------------- END SUBROUTINE READ_CHROUTING -!DJG ----------------------------------------------------- - -#ifdef MPP_LAND -!this subroutine mapping the channel network and lakes. - subroutine MPP_CHROUTING_CONF(g_ixrt,g_jxrt,ixrt,jxrt, NLAKES,NLINKS,& - lake_mskrt, lake_index,link_location,HRZAREA,LAKEMAXH,WEIRC,WEIRL,& - ORIFICEC,ORIFICEA,ORIFICEE,LATLAKE,LONLAKE,ELEVLAKE, & - FROM_NODE,TO_NODE,ZELEV,CHLAT,CHLON,TYPEL, ORDER,CHANLEN, & - CHANXI,CHANYJ, lakenode,mpp_nlinks, nlinks_index,MAXORDER,yw_mpp_nlinks) - - USE module_mpp_land - implicit none -#include - integer :: i,j,ixrt,g_ixrt,jxrt,g_jxrt, nlakes, nlinks - integer, dimension(ixrt,jxrt) :: LAKE_MSKRT, lakenode - integer, INTENT(OUT) ,dimension(ixrt,jxrt):: link_location - integer, INTENT(OUT) :: mpp_nlinks, yw_mpp_nlinks - integer, INTENT(OUT),dimension(nlinks) :: nlinks_index, lake_index - - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: FROM_NODE,TO_NODE, & - TYPEL,CHANXI,CHANYJ,ORDER - REAL, INTENT(INOUT), DIMENSION(NLINKS) ::CHANLEN, ZELEV - REAL, INTENT(INOUT), DIMENSION(NLINKS) ::CHLAT, CHLON - !yw REAL, DIMENSION(NLINKS) ::CHLAT4, CHLON4 - integer, DIMENSION(NLINKS) :: node_table - integer , dimension(g_ixrt,g_jxrt):: g_tmp - real ywtest(nlinks) - integer maxorder - -! Lake information - REAL, INTENT(INOUT), DIMENSION(*) :: HRZAREA,LAKEMAXH,WEIRC,WEIRL,& - ORIFICEC,ORIFICEA,ORIFICEE,LATLAKE,LONLAKE,ELEVLAKE - - call mpp_land_bcast_int(NLINKS,FROM_NODE) - call mpp_land_bcast_int(NLINKS,TO_NODE) - call mpp_land_bcast_int(NLINKS,TYPEL) - call mpp_land_bcast_int(NLINKS,ORDER) - call mpp_land_bcast_int(NLINKS,LAKENODE) - - call mpp_land_bcast_real(NLINKS,CHANLEN) - call mpp_land_bcast_real(NLINKS,ZELEV) - - call mpp_land_bcast_real(NLINKS,CHLAT) - call mpp_land_bcast_real(NLINKS,CHLON) - - call mpp_land_max_int1(MAXORDER) - if(MAXORDER .eq. 0) MAXORDER = -9999 - - lake_index = -99 - do j = 1, jxrt - do i = 1, ixrt - if (LAKE_MSKRT(i,j) .gt. 0) then - lake_index(LAKE_MSKRT(i,j)) = LAKE_MSKRT(i,j) - endif - enddo - enddo - - link_location = 0 - if(my_id .eq. IO_id) then - g_tmp = -1 - do i = 1, nlinks - g_tmp( CHANXI(i),CHANYJ(i) ) = i - enddo - endif - call decompose_RT_int(g_tmp,link_location,g_ixrt, g_jxrt, ixrt, jxrt) - - CHANXI = 0 - CHANYj = 0 - do j = 1, jxrt - do i = 1, ixrt - if(link_location(i,j) .gt. 0) then - CHANXI(link_location(i,j)) = i - CHANYJ(link_location(i,j)) = j - endif - end do - end do - node_table = 0 - do j = 1, jxrt - do i = 1, ixrt - if(link_location(i,j) .gt. 0) then - if( i.eq.1 .and. left_id > 0) then - continue - elseif ( i.eq. ixrt .and. right_id >0) then - continue - elseif ( j.eq. 1 .and. down_id >0 ) then - continue - elseif ( j.eq. jxrt .and. up_id >0) then - continue - else - node_table(link_location(i,j)) = link_location(i,j) - endif - endif - end do - end do - mpp_nlinks = 0 - do i = 1, nlinks - if(node_table(i) > 0 ) then - mpp_nlinks = mpp_nlinks + 1 - nlinks_index(mpp_nlinks) = i - endif - enddo - -! mpp_nlinks = 0 -! do j = 1, jxrt -! do i = 1, ixrt -! if(link_location(i,j) .gt. 0) then -! mpp_nlinks = mpp_nlinks + 1 -! nlinks_index(mpp_nlinks) = link_location(i,j) -! endif -! enddo -! enddo - -! add the boundary links - yw_mpp_nlinks = mpp_nlinks - do j = 1, jxrt - do i = 1, ixrt - if(link_location(i,j) .gt. 0) then - if( i.eq.1 .and. left_id > 0) then - yw_mpp_nlinks = yw_mpp_nlinks + 1 - nlinks_index(yw_mpp_nlinks) = link_location(i,j) - elseif ( i.eq. ixrt .and. right_id >0) then - yw_mpp_nlinks = yw_mpp_nlinks + 1 - nlinks_index(yw_mpp_nlinks) = link_location(i,j) - elseif ( j.eq. 1 .and. down_id >0 ) then - yw_mpp_nlinks = yw_mpp_nlinks + 1 - nlinks_index(yw_mpp_nlinks) = link_location(i,j) - elseif ( j.eq. jxrt .and. up_id >0) then - yw_mpp_nlinks = yw_mpp_nlinks + 1 - nlinks_index(yw_mpp_nlinks) = link_location(i,j) - else - continue - endif - endif - end do - end do + SUBROUTINE readRT2d_real(var_name, inv, ixrt, jxrt, fileName) + implicit none + INTEGER :: iret + INTEGER, INTENT(IN) :: ixrt,jxrt + INTEGER :: i, j, ii,jj + CHARACTER(len=*):: var_name,fileName + real, INTENT(OUT), dimension(ixrt,jxrt) :: inv + real, dimension(ixrt,jxrt) :: inv_tmp + + inv_tmp = -9999.9 + + iret = get2d_real(var_name,inv_tmp,ixrt,jxrt,& + trim(fileName)) + do i=1,ixrt + jj=jxrt + do j=1,jxrt + inv(i,j)=inv_tmp(i,jj) + jj=jxrt-j + end do + end do + end SUBROUTINE readRT2d_real - call mpp_land_bcast_real(NLAKES,HRZAREA) - call mpp_land_bcast_real(NLAKES,LAKEMAXH) - call mpp_land_bcast_real(NLAKES,WEIRC) - call mpp_land_bcast_real(NLAKES,WEIRL) - call mpp_land_bcast_real(NLAKES,ORIFICEC) - call mpp_land_bcast_real(NLAKES,ORIFICEA) - call mpp_land_bcast_real(NLAKES,ORIFICEE) - call mpp_land_bcast_real(NLAKES,LATLAKE) - call mpp_land_bcast_real(NLAKES,LONLAKE) - call mpp_land_bcast_real(NLAKES,ELEVLAKE) + SUBROUTINE readRT2d_int(var_name, inv, ixrt, jxrt, fileName) + implicit none + INTEGER, INTENT(IN) :: ixrt,jxrt + INTEGER :: i, j, ii,jj + CHARACTER(len=*):: var_name,fileName + integer, INTENT(OUT), dimension(ixrt,jxrt) :: inv + integer, dimension(ixrt,jxrt) :: inv_tmp + call get2d_int(var_name,inv_tmp,ixrt,jxrt,& + trim(fileName)) + do i=1,ixrt + jj=jxrt + do j=1,jxrt + inv(i,j)=inv_tmp(i,jj) + jj=jxrt-j + end do + end do + end SUBROUTINE readRT2d_int +!--------------------------------------------------------- +!DJG ----------------------------------------------------- - end subroutine MPP_CHROUTING_CONF -#endif #ifdef MPP_LAND subroutine MPP_READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,& @@ -1659,6 +1528,7 @@ subroutine MPP_READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,& call decompose_RT_int(g_gw_strm_msk,gw_strm_msk, & global_rt_nx, global_rt_ny,ixrt,jxrt) call mpp_land_bcast_int1(numbasns) + return end subroutine MPP_READ_SIMP_GW #endif @@ -1720,6 +1590,10 @@ subroutine READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,& end do !I-ix end do !J-jx +#ifdef HYDRO_D + write(6,*) "numbasns = ", numbasns +#endif + return !DJG ----------------------------------------------------- @@ -1977,7 +1851,7 @@ subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & #ifdef HYDRO_D if (iret /= 0) then print*, "Problem nf_create" - call hydro_stop() + call hydro_stop("output_rt") endif #endif @@ -2024,7 +1898,7 @@ subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & iret = nf_put_att_text(ncid,varid,'units',7,'m^3/m^3') iret = nf_put_att_text(ncid,varid,'description',16,'moisture content') iret = nf_put_att_text(ncid,varid,'long_name',26,soilm) - iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') +! iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) @@ -2264,6 +2138,8 @@ subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & ! iret = nf_inq_varid(ncid, "Q_SFCFLX_Y", varid) ! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) +! for compareing between sequential and parallel to initialized xdumd + xdumd = 0.0 jj = 1 ii = 0 do j = 1,jxrt,decimation @@ -2280,6 +2156,7 @@ subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) + xdumd = 0.0 ! xdum = QSTRMVOLRT !! where (vegtyp(:,:) == 16) xdum = -1.E33 !DJG inv jj = int(jxrt/decimation) @@ -2300,8 +2177,8 @@ subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & iret = nf_inq_varid(ncid, "QSTRMVOLRT", varid) iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) -! xdum = SFCHEADSUBRT -!! where (vegtyp(:,:) == 16) xdum = -1.E33 +! xdum = SFCHEADSUBRT +! where (vegtyp(:,:) == 16) xdum = -1.E33 !DJG inv jj = int(jxrt/decimation) jj = 1 ii = 0 @@ -2526,7 +2403,7 @@ subroutine output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, & #ifdef HYDRO_D if (iret /= 0) then print*, "Problem nf_create" - call hydro_stop() + call hydro_stop("output_rt") endif #endif @@ -2573,7 +2450,7 @@ subroutine output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, & iret = nf_put_att_text(ncid,varid,'units',6,'kg m-2') iret = nf_put_att_text(ncid,varid,'description',16,'moisture content') iret = nf_put_att_text(ncid,varid,'long_name',26,soilm) - iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') +! iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) @@ -2881,7 +2758,7 @@ subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER, & #ifdef HYDRO_D if (iret /= 0) then print*, "Problem nf_create points" - call hydro_stop() + call hydro_stop("output_chrt") endif #endif @@ -2893,7 +2770,7 @@ subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER, & #ifdef HYDRO_D if (iret /= 0) then print*, "Problem nf_create observation" - call hydro_stop() + call hydro_stop("output_chrt") endif #endif @@ -2925,7 +2802,7 @@ subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER, & station_idO(nobs) = i write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs) #ifdef HYDRO_D - print *,"stationobservation name", stnameO(nobs) +! print *,"stationobservation name", stnameO(nobs) #endif endif enddo @@ -3209,16 +3086,11 @@ subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER, & do i=1,NLINKS if(STRMFRXSTPTS(i) .ne. -9999) then -#ifdef HYDRO_D - print *, "Outputting frxst pt. :",STRMFRXSTPTS(i) - call flush(6) -#endif start_posO = (cnt+1)+(nobs * (output_count-1)) - !Write frxst_pts to text file... !yw write(999,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & write(999,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), & - abs(qlink(i,1)), abs(qlink(i,1))*35.315,hlink(i) + qlink(i,1), qlink(i,1)*35.315,hlink(i) !yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) !yw 117 FORMAT(I8,1X,A10,1X,A8,1x,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) 117 FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) @@ -3321,7 +3193,7 @@ end subroutine output_chrt #ifdef MPP_LAND !-- output the channel route in an IDV 'station' compatible format - subroutine mpp_output_chrt(mpp_nlinks,nlinks_index,igrid, & + subroutine mpp_output_chrt(gnlinks,map_l2g,igrid, & split_output_count, NLINKS, ORDER, & startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt, & K,STRMFRXSTPTS,order_to_write) @@ -3343,21 +3215,26 @@ subroutine mpp_output_chrt(mpp_nlinks,nlinks_index,igrid, & character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date - integer :: mpp_nlinks, nlinks_index(nlinks), order_to_write + + integer :: gnlinks, map_l2g(nlinks), order_to_write + real, dimension(gNLINKS) :: g_chlon,g_chlat, g_hlink,g_zelev + real, dimension(gNLINKS,2) :: g_qlink + integer , dimension(gNLINKS) :: g_order,g_STRMFRXSTPTS - call write_chanel_int(order,nlinks_index,mpp_nlinks,nlinks) - call write_chanel_real(chlon,nlinks_index,mpp_nlinks,nlinks) - call write_chanel_real(chlat,nlinks_index,mpp_nlinks,nlinks) - call write_chanel_real(hlink,nlinks_index,mpp_nlinks,nlinks) - call write_chanel_real(zelev,nlinks_index,mpp_nlinks,nlinks) - call write_chanel_real(qlink(:,1),nlinks_index,mpp_nlinks,nlinks) - call write_chanel_real(qlink(:,2),nlinks_index,mpp_nlinks,nlinks) + call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) + call write_chanel_int(STRMFRXSTPTS,map_l2g,gnlinks,nlinks,g_STRMFRXSTPTS) + call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon) + call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat) + call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink) + call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev) + call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) + call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) if(my_id .eq. IO_id) then - call output_chrt(igrid, split_output_count, NLINKS, ORDER, & - startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt,K,& - STRMFRXSTPTS,order_to_write) + call output_chrt(igrid, split_output_count, GNLINKS, g_ORDER, & + startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt,K,& + g_STRMFRXSTPTS,order_to_write) end if end subroutine mpp_output_chrt @@ -3471,7 +3348,7 @@ subroutine output_lakes(igrid, split_output_count, NLAKES, & #ifdef HYDRO_D if (iret /= 0) then print*, "Problem nf_create" - call hydro_stop() + call hydro_stop("output_lakes") endif #endif @@ -3656,7 +3533,7 @@ end subroutine output_lakes !-- output the channel route in an IDV 'grid' compatible format subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & NLINKS,CH_NETRT_in, CH_NETLNK_in, ORDER, startdate, date, & - qlink, dt, geo_finegrid_flnm, mpp_nlinks,nlinks_index,g_ixrt,g_jxrt ) + qlink, dt, geo_finegrid_flnm, gnlinks,map_l2g,g_ixrt,g_jxrt ) USE module_mpp_land @@ -3674,18 +3551,22 @@ subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & character(len=*), intent(in) :: geo_finegrid_flnm character(len=*), intent(in) :: startdate character(len=*), intent(in) :: date - - integer:: mpp_nlinks , nlinks_index(nlinks) - call write_chanel_real(qlink(:,1),nlinks_index,mpp_nlinks,nlinks) - call write_chanel_real(qlink(:,2),nlinks_index,mpp_nlinks,nlinks) - call write_chanel_int(order,nlinks_index,mpp_nlinks,nlinks) + integer:: gnlinks , map_l2g(nlinks) + + integer,dimension(gnlinks) :: g_order + real, dimension(gNLINKS,2) :: g_qlink + + call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) + call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) + call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) + call write_IO_rt_int(CH_NETRT_in, CH_NETRT) call write_IO_rt_int(CH_NETLNK_in, CH_NETLNK) if(my_id.eq.IO_id) then call output_chrtgrd(igrid, split_output_count, g_ixrt,g_jxrt, & - NLINKS,CH_NETRT, CH_NETLNK, ORDER, startdate, date, & - qlink, dt, geo_finegrid_flnm) + GNLINKS,CH_NETRT, CH_NETLNK, g_ORDER, startdate, date, & + g_qlink, dt, geo_finegrid_flnm) endif return @@ -3749,7 +3630,7 @@ subroutine output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & #ifdef HYDRO_D if (iret /= 0) then print*, "Problem nf_create" - call hydro_stop() + call hydro_stop("output_chrtgrd") endif #endif @@ -3966,7 +3847,7 @@ subroutine read_chan_forcing( & if (ierr /= 0) then #ifdef HYDRO_D write(*,'("READFORC_chan Problem opening netcdf file: ''", A, "''")') trim(inflnm) - call hydro_stop() + call hydro_stop("read_chan_forcing") #endif endif @@ -3993,7 +3874,7 @@ subroutine get2d_int(var_name,out_buff,ix,jx,fileName) if (iret .ne. 0) then #ifdef HYDRO_D print*,"aaa failed to open the netcdf file: ",trim(fileName) - call hydro_stop() + call hydro_stop("get2d_int") #endif endif iret = nf_inq_varid(ncid,trim(var_name), varid) @@ -4009,9 +3890,9 @@ subroutine get2d_int(var_name,out_buff,ix,jx,fileName) end subroutine get2d_int #ifdef MPP_LAND - SUBROUTINE MPP_READ_ROUTEDIM(g_IXRT,g_JXRT, IXRT,JXRT, & + SUBROUTINE MPP_READ_ROUTEDIM(did,g_IXRT,g_JXRT, GCH_NETLNK,GNLINKS,IXRT,JXRT, & route_chan_f,route_link_f, & - route_direction_f, route_lake_f, NLINKS, NLAKES, & + route_direction_f, route_lake_f,NLINKS, NLAKES, & CH_NETLNK, channel_option, geo_finegrid_flnm) @@ -4019,37 +3900,63 @@ SUBROUTINE MPP_READ_ROUTEDIM(g_IXRT,g_JXRT, IXRT,JXRT, & implicit none #include - INTEGER :: channel_option + INTEGER :: channel_option, did INTEGER :: g_IXRT,g_JXRT - INTEGER, INTENT(INOUT) :: NLINKS, NLAKES + INTEGER, INTENT(INOUT) :: NLINKS, NLAKES, GNLINKS INTEGER, INTENT(IN) :: IXRT,JXRT INTEGER :: CHNID,cnt INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: GCH_NETLNK !- each node gets unique id based on global domain INTEGER, DIMENSION(g_IXRT,g_JXRT) :: g_CH_NETLNK ! temp array INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT REAL, DIMENSION(IXRT,JXRT) :: LAT, LON - + integer:: i,j CHARACTER(len=256) :: route_chan_f, route_link_f,route_direction_f,route_lake_f CHARACTER(len=256) :: geo_finegrid_flnm ! CHARACTER(len=*) :: geo_finegrid_flnm +! integer, allocatable, dimension(:) :: tmp_int + integer :: ywcount + if(my_id .eq. IO_id) then CALL READ_ROUTEDIM(g_IXRT, g_JXRT, route_chan_f, route_link_f, & - route_direction_f, route_lake_f, NLINKS, NLAKES, & + route_direction_f, route_lake_f, GNLINKS, NLAKES, & g_CH_NETLNK, channel_option,geo_finegrid_flnm) endif call mpp_land_bcast_int1(NLAKES) - call mpp_land_bcast_int1(NLINKS) + call mpp_land_bcast_int1(GNLINKS) - call decompose_RT_int(g_CH_NETLNK,CH_NETLNK,g_IXRT,g_JXRT,ixrt,jxrt) - + call decompose_RT_int(g_CH_NETLNK,GCH_NETLNK,g_IXRT,g_JXRT,ixrt,jxrt) + ywcount = 0 + CH_NETLNK = -9999 + do j = 1, jxrt + do i = 1, ixrt + if(GCH_NETLNK(i,j) .gt. 0) then + ywcount = ywcount + 1 + CH_NETLNK(i,j) = ywcount + endif + end do + end do + NLINKS = ywcount + + allocate(rt_domain(did)%map_l2g(NLINKS)) + + rt_domain(did)%map_l2g = -1 + do j = 1, jxrt + do i = 1, ixrt + if(CH_NETLNK(i,j) .gt. 0) then + rt_domain(did)%map_l2g(CH_NETLNK(i,j)) = GCH_NETLNK(i,j) + endif + end do + end do + call mpp_chrt_nlinks_collect(NLINKS) return end SUBROUTINE MPP_READ_ROUTEDIM @@ -4125,113 +4032,6 @@ subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& return end subroutine MPP_DEEPGW_HRLDAS - - SUBROUTINE MPP_READ_CHROUTING(IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & - FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, & - NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, & - HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & - ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, & - route_link_f, & - route_lake_f, route_direction_f, route_order_f, & - CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, & - CHANXI, CHANYJ, CHLAT, CHLON, & - channel_option,LATVAL,& - LONVAL,STRMFRXSTPTS,geo_finegrid_flnm,g_ixrt,g_jxrt) - implicit none -#include - INTEGER, INTENT(IN) :: IXRT,JXRT,g_IXRT,g_JXRT -!yw INTEGER, INTENT(IN) :: CHANRTSWCRT, NLINKS, NLAKES - INTEGER :: CHANRTSWCRT, NLINKS, NLAKES - INTEGER :: I,J,channel_option - REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_LATVAL, g1_LONVAL - CHARACTER(len=28) :: dir - -!----DJG,DNY New variables for channel and lake routing - CHARACTER(len=155) :: header - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: FROM_NODE - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ZELEV - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHLAT,CHLON - - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TYPEL - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TO_NODE,ORDER - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: STRMFRXSTPTS - - INTEGER, INTENT(INOUT) :: MAXORDER - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum - REAL, INTENT(INOUT), DIMENSION(NLINKS,2) :: QLINK !channel flow - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHANLEN !channel length - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MannN, So !mannings N - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: LAKENODE ! identifies which nodes pour into which lakes - REAL, INTENT(IN) :: dist(ixrt,jxrt,9) - - -!-- store the location x,y location of the channel element - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ - -!--reservoir/lake attributes - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: HRZAREA - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: LAKEMAXH - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: WEIRC - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: WEIRL - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ORIFICEC - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ORIFICEA - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ORIFICEE - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: LATLAKE,LONLAKE,ELEVLAKE - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ChSSlp, Bw - - CHARACTER(len=256) :: route_link_f - CHARACTER(len=256) :: route_lake_f - CHARACTER(len=256) :: route_direction_f - CHARACTER(len=256) :: route_order_f - CHARACTER(len=256) :: geo_finegrid_flnm - CHARACTER(len=256) :: var_name - - INTEGER :: tmp, cnt, ncid - real :: gc,n - - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: latval,lonval - real g1_elrt(g_ixrt,g_jxrt), g_dist(g_ixrt,g_jxrt,9) - integer g1_ch_netrt(g_ixrt,g_jxrt) - INTEGER, DIMENSION(g_IXRT,g_JXRT) :: g1_LAKE_MSKRT, g1_ch_netlnk - integer :: k - - - call write_IO_rt_real(elrt,g1_elrt) - call write_IO_rt_int(ch_netrt,g1_ch_netrt) - call write_IO_rt_int(CH_NETLNK,g1_CH_NETLNK) -! if(dist(1,1,1) .ne. -999) then - do k = 1, 9 - call write_IO_rt_real(dist(:,:,k),g_dist(:,:,k)) - end do -! endif - - if(my_id .eq. IO_id) then - CALL READ_CHROUTING(g_IXRT,g_JXRT,g1_ELRT,g1_CH_NETRT, g1_LAKE_MSKRT, & - FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, & - NLAKES, MUSK, MUSX, QLINK,CHANLEN, MannN, So, ChSSlp, Bw, & - HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, & - ORIFICEA, ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, & - route_link_f,route_lake_f, & - route_direction_f, route_order_f, & - CHANRTSWCRT,g_dist, ZELEV, LAKENODE, g1_CH_NETLNK, CHANXI, CHANYJ, & - CHLAT, CHLON, channel_option, g1_latval,g1_lonval,& - STRMFRXSTPTS,geo_finegrid_flnm) - endif - - call decompose_RT_int(g1_LAKE_MSKRT,LAKE_MSKRT,g_IXRT,G_JXRT,ixrt,jxrt) - call decompose_RT_real(g1_latval,latval,g_IXRT,G_JXRT,ixrt,jxrt) - call decompose_RT_real(g1_lonval,lonval,g_IXRT,G_JXRT,ixrt,jxrt) - -! do k = 1, 9 -! call decompose_RT_real(g_dist(:,:,k),dist(:,:,k),g_IXRT,G_JXRT,ixrt,jxrt) -! end do - - return - end SUBROUTINE MPP_READ_CHROUTING #endif SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & @@ -4243,12 +4043,8 @@ SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT !Dummy inverted grids - REAL, DIMENSION(IXRT,JXRT) :: ELRT_inv,LKSATFAC_inv REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC - REAL, DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC_inv REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC - REAL, DIMENSION(IXRT,JXRT) :: RETDEPRTFAC_inv - INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT_inv INTEGER :: I,J, iret, jj CHARACTER(len=256) :: var_name @@ -4258,13 +4054,9 @@ SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & var_name = "TOPOGRAPHY" - iret = get2d_real(var_name,ELRT_inv,ixrt,jxrt,& + call readRT2d_real(var_name,ELRT,ixrt,jxrt,& trim(geo_finegrid_flnm)) #ifdef HYDRO_D - if(iret .ne. 0) then - write(6,*) "Error reading TOPOGRAPHY failed" - call hydro_stop() - endif write(6,*) "read ",var_name #endif @@ -4274,7 +4066,7 @@ SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & ! trim(geo_finegrid_flnm)) var_name = "CHANNELGRID" - call get2d_int(var_name,CH_NETRT_inv,ixrt,jxrt,& + call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& trim(geo_finegrid_flnm)) #ifdef HYDRO_D @@ -4282,43 +4074,28 @@ SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & #endif var_name = "LKSATFAC" - LKSATFAC_inv = -9999.9 - iret = get2d_real(var_name,LKSATFAC_inv,ixrt,jxrt,& + LKSATFAC = -9999.9 + call readRT2d_real(var_name,LKSATFAC,ixrt,jxrt,& trim(geo_finegrid_flnm)) #ifdef HYDRO_D write(6,*) "read ",var_name #endif - where (LKSATFAC_inv == -9999.9) LKSATFAC_inv = 1000.0 !specify LKSAFAC if no term avail... + where (LKSATFAC == -9999.9) LKSATFAC = 1000.0 !specify LKSAFAC if no term avail... !1.12.2012...Read in routing calibration factors... var_name = "RETDEPRTFAC" - iret = get2d_real(var_name,RETDEPRTFAC_inv,ixrt,jxrt,& + call readRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,& trim(geo_finegrid_flnm)) - where (RETDEPRTFAC_inv < 0.) RETDEPRTFAC_inv = 1.0 ! reset grid to = 1.0 if non-valid value exists + where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists var_name = "OVROUGHRTFAC" - iret = get2d_real(var_name,OVROUGHRTFAC_inv,ixrt,jxrt,& + call readRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,& trim(geo_finegrid_flnm)) - where (OVROUGHRTFAC_inv <= 0.) OVROUGHRTFAC_inv = 1.0 ! reset grid to = 1.0 if non-valid value exists - - - -!!!Flip y-dimension of highres grids from exported Arc files... + where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists - do i=1,ixrt - jj=jxrt - do j=1,jxrt - ELRT(i,j)=ELRT_inv(i,jj) - CH_NETRT(i,j)=CH_NETRT_inv(i,jj) - LKSATFAC(i,j)=LKSATFAC_inv(i,jj) - RETDEPRTFAC(i,j)=RETDEPRTFAC_inv(i,jj) - OVROUGHRTFAC(i,j)=OVROUGHRTFAC_inv(i,jj) - jj=jxrt-j - end do - end do #ifdef HYDRO_D write(6,*) "finish READ_ROUTING_seq" @@ -4362,7 +4139,7 @@ subroutine output_lsm(outFile,did) #ifdef HYDRO_D if (iret /= 0) then print*, "Problem nf_create" - call hydro_stop() + call hydro_stop("output_lsm") endif #endif @@ -4408,6 +4185,7 @@ subroutine output_lsm(outFile,did) call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SFCHEADRT,"sfcheadrt" ) + #ifdef MPP_LAND if(IO_id.eq.my_id) then #endif @@ -4436,7 +4214,7 @@ subroutine RESTART_OUT_nc(outFile,did) integer :: ncid,irt, dimid_ix, dimid_jx, & dimid_ixrt, dimid_jxrt, varid, & - dimid_links, dimid_basns, dimid_soil + dimid_links, dimid_basns, dimid_soil, dimid_lakes integer :: iret @@ -4458,7 +4236,7 @@ subroutine RESTART_OUT_nc(outFile,did) #ifdef HYDRO_D if (iret /= 0) then print*, "Problem nf_create" - call hydro_stop() + call hydro_stop("RESTART_OUT_nc") endif #endif @@ -4480,7 +4258,10 @@ subroutine RESTART_OUT_nc(outFile,did) iret = nf_def_dim(ncid, "iyrt", rt_domain(did)%jxrt, dimid_jxrt) #endif - iret = nf_def_dim(ncid, "links", rt_domain(did)%nlinks, dimid_links) + iret = nf_def_dim(ncid, "links", rt_domain(did)%gnlinks, dimid_links) + if(rt_domain(did)%nlakes .gt. 0) then + iret = nf_def_dim(ncid, "lakes", rt_domain(did)%nlakes, dimid_lakes) + endif iret = nf_def_dim(ncid, "basns", rt_domain(did)%numbasns, dimid_basns) !define variables @@ -4492,31 +4273,51 @@ subroutine RESTART_OUT_nc(outFile,did) iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) -! iret = nf_def_var(ncid,"soldrain",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) + iret = nf_def_var(ncid,"soldrain",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then - iret = nf_def_var(ncid,"infxswgt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + iret = nf_def_var(ncid,"infxswgt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + iret = nf_def_var(ncid,"SFCHEADSUBRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) iret = nf_def_var(ncid,"sh2owgt",NF_FLOAT,3,(/dimid_ixrt,dimid_jxrt,dimid_soil/),varid) + iret = nf_def_var(ncid,"qstrmvolrt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + iret = nf_def_var(ncid,"RETDEPRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) + + + + + + if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then iret = nf_def_var(ncid,"hlink",NF_FLOAT,1,(/dimid_links/),varid) iret = nf_def_var(ncid,"qlink1",NF_FLOAT,1,(/dimid_links/),varid) iret = nf_def_var(ncid,"qlink2",NF_FLOAT,1,(/dimid_links/),varid) iret = nf_def_var(ncid,"cvol",NF_FLOAT,1,(/dimid_links/),varid) - iret = nf_def_var(ncid,"resht",NF_FLOAT,1,(/dimid_links/),varid) - iret = nf_def_var(ncid,"qlakeo",NF_FLOAT,1,(/dimid_links/),varid) + if(rt_domain(did)%nlakes .gt. 0) then + iret = nf_def_var(ncid,"resht",NF_FLOAT,1,(/dimid_lakes/),varid) + iret = nf_def_var(ncid,"qlakeo",NF_FLOAT,1,(/dimid_lakes/),varid) + endif iret = nf_def_var(ncid,"lake_inflort",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - iret = nf_def_var(ncid,"qstrmvolrt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) end if if(nlst_rt(did)%GWBASESWCRT.EQ.1) then iret = nf_def_var(ncid,"z_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) +!yw test bucket model +! iret = nf_def_var(ncid,"gwbas_pix_ct",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"gw_buck_exp",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"z_max",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"gw_buck_coeff",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"qin_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) +! iret = nf_def_var(ncid,"qinflowbase",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) +! iret = nf_def_var(ncid,"qout_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) end if end if ! put global attribute iret = nf_put_att_int(ncid,NF_GLOBAL,"his_out_counts",NF_INT, 1,rt_domain(did)%his_out_counts) - + iret = nf_put_att_text(ncid,NF_GLOBAL,"Restart_Time",19,nlst_rt(did)%olddate(1:19)) + iret = nf_put_att_text(ncid,NF_GLOBAL,"Since_Date",19,nlst_rt(did)%sincedate(1:19)) + iret = nf_put_att_real(ncid,NF_GLOBAL,"DTCT",NF_REAL, 1,nlst_rt(did)%DTCT) iret = nf_enddef(ncid) #ifdef MPP_LAND @@ -4531,61 +4332,84 @@ subroutine RESTART_OUT_nc(outFile,did) call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" ) call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1" ) call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) -! call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain" ) + call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain" ) call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt" ) if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT, "infxswgt" ) call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT, "QBDRYRT" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT, "infxswgt" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT, "SFCHEADSUBRT" ) call w_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT, "sh2owgt" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT, "qstrmvolrt" ) + call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT, "RETDEPRT" ) + +!yw test + + +!yw test + + if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%HLINK,"hlink" & #ifdef MPP_LAND - ,rt_domain(did)%nlinks_index, rt_domain(did)%mpp_nlinks & + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & #endif ) call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,1),"qlink1" & #ifdef MPP_LAND - ,rt_domain(did)%nlinks_index, rt_domain(did)%mpp_nlinks & + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & #endif ) call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,2),"qlink2" & #ifdef MPP_LAND - ,rt_domain(did)%nlinks_index, rt_domain(did)%mpp_nlinks & + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & #endif ) call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%cvol,"cvol" & #ifdef MPP_LAND - ,rt_domain(did)%nlinks_index, rt_domain(did)%mpp_nlinks & + ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & #endif ) - call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%resht,"resht" & +! call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%resht,"resht" & +!#ifdef MPP_LAND +! ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & +!#endif +! ) + + call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%resht,"resht" & #ifdef MPP_LAND - ,rt_domain(did)%lake_index, rt_domain(did)%mpp_nlinks & + ,rt_domain(did)%lake_index & #endif ) - call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%qlakeo,"qlakeo" & + call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakeo,"qlakeo" & #ifdef MPP_LAND - ,rt_domain(did)%lake_index, rt_domain(did)%mpp_nlinks & + ,rt_domain(did)%lake_index & #endif ) call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort") - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT, "qstrmvolrt" ) end if if(nlst_rt(did)%GWBASESWCRT.EQ.1) then call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,"z_gwsubbas" ) +!yw test bucket model +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gwbas_pix_ct,"gwbas_pix_ct" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_exp,"gw_buck_exp" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_max,"z_max" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_coeff,"gw_buck_coeff" ) +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,"qin_gwsubbas" ) +! call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%qinflowbase,"qinflowbase") +! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,"qout_gwsubbas" ) end if end if @@ -4611,7 +4435,11 @@ subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName) endif #else iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),inVar) + if(iret .eq. 0) then + iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),inVar) + else + write(6,*) "Error : variable not defined in rst file before write: ", varName + endif #endif return @@ -4682,9 +4510,9 @@ subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName) return end subroutine w_rst_nc3 - subroutine w_rst_crt_nc1(ncid,n,inVar,varName & + subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName & #ifdef MPP_LAND - ,index, mpp_n& + ,nodelist & #endif ) implicit none @@ -4692,8 +4520,10 @@ subroutine w_rst_crt_nc1(ncid,n,inVar,varName & character(len=*) varName real inVar(n) #ifdef MPP_LAND - integer:: index(n),mpp_n - call write_chanel_real(inVar,index,mpp_n,n) + integer:: nodelist(n) + if(n .eq. 0) return + + call write_lake_real(inVar,nodelist,n) if(my_id .eq. IO_id) then #endif iret = nf_inq_varid(ncid,varName, varid) @@ -4702,30 +4532,56 @@ subroutine w_rst_crt_nc1(ncid,n,inVar,varName & endif #endif return - end subroutine w_rst_crt_nc1 + end subroutine w_rst_crt_nc1_lake - subroutine w_rst_crt_nc1g(ncid,n,inVar,varName) + subroutine w_rst_crt_nc1(ncid,n,inVar,varName & +#ifdef MPP_LAND + ,map_l2g, gnlinks& +#endif + ) implicit none integer:: ncid,n,varid , iret character(len=*) varName real inVar(n) #ifdef MPP_LAND + integer:: gnlinks, map_l2g(n) + real g_var(gnlinks) + call write_chanel_real(inVar,map_l2g,gnlinks,n,g_var) if(my_id .eq. IO_id) then -#endif + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/gnlinks/),g_var) +#else iret = nf_inq_varid(ncid,varName, varid) iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) +#endif #ifdef MPP_LAND endif #endif return - end subroutine w_rst_crt_nc1g - - subroutine RESTART_IN_NC(inFile,did) - - - implicit none - character(len=*) inFile - integer :: ierr, iret,ncid, did + end subroutine w_rst_crt_nc1 + + subroutine w_rst_crt_nc1g(ncid,n,inVar,varName) + implicit none + integer:: ncid,n,varid , iret + character(len=*) varName + real inVar(n) +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + iret = nf_inq_varid(ncid,varName, varid) + iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) +#ifdef MPP_LAND + endif +#endif + return + end subroutine w_rst_crt_nc1g + + subroutine RESTART_IN_NC(inFile,did) + + + implicit none + character(len=*) inFile + integer :: ierr, iret,ncid, did integer :: i, j @@ -4743,7 +4599,7 @@ subroutine RESTART_IN_NC(inFile,did) #ifdef HYDRO_D write(*,'("Problem opening file: ''", A, "''")') & trim(inFile) - call hydro_stop() + call hydro_stop("RESTART_IN_NC") #endif endif @@ -4751,21 +4607,31 @@ subroutine RESTART_IN_NC(inFile,did) if(IO_id .eq. my_id) then #endif iret = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'his_out_counts', rt_domain(did)%his_out_counts) + iret = NF_GET_ATT_REAL(ncid, NF_GLOBAL, 'DTCT', nlst_rt(did)%DTCT) + iret = nf_get_att_text(ncid,NF_GLOBAL,"Since_Date",nlst_rt(did)%sincedate(1:19)) + if(iret /= 0) nlst_rt(did)%sincedate = nlst_rt(did)%startdate + if(nlst_rt(did)%DTCT .gt. 0) then + nlst_rt(did)%DTCT = min(nlst_rt(did)%DTCT, nlst_rt(did)%DTRT) + else + nlst_rt(did)%DTCT = nlst_rt(did)%DTRT + endif #ifdef MPP_LAND endif call mpp_land_bcast_int1(rt_domain(did)%out_counts) + call mpp_land_bcast_real1(nlst_rt(did)%DTCT) #endif #ifdef HYDRO_D write(6,*) "nlst_rt(did)%nsoil=",nlst_rt(did)%nsoil #endif + if(nlst_rt(did)%rst_typ .eq. 1 ) then call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt") -! call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain") call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt") + call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain") endif call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") @@ -4775,20 +4641,28 @@ subroutine RESTART_IN_NC(inFile,did) if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT,"infxswgt") + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT,"SFCHEADSUBRT") call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT,"QBDRYRT") + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT,"qstrmvolrt") + call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT,"RETDEPRT") call read_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT,"sh2owgt") + + if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then - call read_rst_crt_nc(ncid,rt_domain(did)%HLINK,rt_domain(did)%NLINKS,"hlink") - call read_rst_crt_nc(ncid,rt_domain(did)%QLINK(:,1),rt_domain(did)%NLINKS,"qlink1") - call read_rst_crt_nc(ncid,rt_domain(did)%QLINK(:,2),rt_domain(did)%NLINKS,"qlink2") - call read_rst_crt_nc(ncid,rt_domain(did)%CVOL,rt_domain(did)%NLINKS,"cvol") - call read_rst_crt_nc(ncid,rt_domain(did)%RESHT,rt_domain(did)%nlinks,"resht") - call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEO,rt_domain(did)%nlinks,"qlakeo") + call read_rst_crt_stream_nc(ncid,rt_domain(did)%HLINK,rt_domain(did)%NLINKS,"hlink",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,1),rt_domain(did)%NLINKS,"qlink1",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,2),rt_domain(did)%NLINKS,"qlink2",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + call read_rst_crt_stream_nc(ncid,rt_domain(did)%CVOL,rt_domain(did)%NLINKS,"cvol",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) + if(rt_domain(did)%NLAKES .gt. 0) then + call read_rst_crt_nc(ncid,rt_domain(did)%RESHT,rt_domain(did)%NLAKES,"resht") + call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEO,rt_domain(did)%NLAKES,"qlakeo") + endif call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort") - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT,"qstrmvolrt") + end if - if(nlst_rt(did)%GWBASESWCRT.EQ.1.AND.nlst_rt(did)%GW_RESTART.NE.0) then - call read_rst_crt_nc(ncid,rt_domain(did)%z_gwsubbas,rt_domain(did)%numbasns,"z_gwsubbas") + + if(nlst_rt(did)%GWBASESWCRT.EQ.1.AND.nlst_rt(did)%GW_RESTART.NE.0 .and. rt_domain(did)%numbasns .gt. 0) then + call read_rst_crt_nc(ncid,rt_domain(did)%z_gwsubbas,rt_domain(did)%numbasns,"z_gwsubbas") end if end if @@ -4808,8 +4682,15 @@ subroutine RESTART_IN_NC(inFile,did) iret = nf_close(ncid) #ifdef HYDRO_D write(6,*) "end of RESTART_IN" + flush(6) #endif - + + !call check_channel(81,rt_domain(did)%QLINK(:,1),1,rt_domain(did)%NLINKS) + !call check_channel(83,rt_domain(did)%QLINK(:,2),1,rt_domain(did)%NLINKS) + !call check_channel(84,rt_domain(did)%HLINK,1,rt_domain(did)%NLINKS) + !call check_channel(85,rt_domain(did)%CVOL,1,rt_domain(did)%NLINKS) + !call hydro_stop("666666666666") + return end subroutine RESTART_IN_nc @@ -4882,6 +4763,7 @@ subroutine read_rst_nc2(ncid,ix,jx,var,varStr) call decompose_data_real(xtmp, var) #else + var = 0.0 iret = nf_get_var_real(ncid, varid, var) #endif return @@ -4960,6 +4842,7 @@ subroutine read_rt_nc2(ncid,ix,jx,var,varStr) #ifdef MPP_LAND real,dimension(global_rt_nx,global_rt_ny) :: xtmp + xtmp = 0.0 #endif iret = nf_inq_varid(ncid, trim(varStr), varid) #ifdef MPP_LAND @@ -4990,7 +4873,8 @@ subroutine read_rst_crt_nc(ncid,var,n,varStr) integer :: ireg, ncid, varid, n, iret real,dimension(n) :: var character(len=*) :: varStr - + + if( n .le. 0) return #ifdef MPP_LAND if(my_id .eq. IO_id) & #endif @@ -5018,6 +4902,58 @@ subroutine read_rst_crt_nc(ncid,var,n,varStr) return end subroutine read_rst_crt_nc + subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g) + implicit none + integer :: ncid, varid, n, iret, gnlinks + integer, intent(in), dimension(:) :: map_l2g + character(len=*) :: varStr + integer :: l, g + real,intent(out) , dimension(:) :: var_out +#ifdef MPP_LAND + real,dimension(gnlinks) :: var +#else + real,dimension(n) :: var +#endif + + +#ifdef MPP_LAND + if(my_id .eq. IO_id) & +#endif + iret = nf_inq_varid(ncid, trim(varStr), varid) +#ifdef MPP_LAND + call mpp_land_bcast_int1(iret) +#endif + if (iret /= 0) then +#ifdef HYDRO_D + print*, 'variable not found: name = "', trim(varStr)//'"' +#endif + return + endif +#ifdef HYDRO_D + print*, "read restart variable ", varStr +#endif +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + var = 0.0 + iret = nf_get_var_real(ncid, varid, var) +#ifdef MPP_LAND + endif + call mpp_land_bcast_real(gnlinks,var) + + if(n .le. 0) return + var_out = 0 + + do l = 1, n + g = map_l2g(l) + var_out(l) = var(g) + end do +#else + var_out = var +#endif + return + end subroutine read_rst_crt_stream_nc + subroutine hrldas_out() end subroutine hrldas_out @@ -5030,12 +4966,8 @@ SUBROUTINE READ_ROUTING_old(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT !Dummy inverted grids - REAL, DIMENSION(IXRT,JXRT) :: ELRT_inv,LKSATFAC_inv REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC - REAL, DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC_inv REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC - REAL, DIMENSION(IXRT,JXRT) :: RETDEPRTFAC_inv - INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT_inv INTEGER :: I,J, iret, jj CHARACTER(len=256) :: var_name @@ -5044,7 +4976,7 @@ SUBROUTINE READ_ROUTING_old(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & CHARACTER(len=256) :: geo_finegrid_flnm var_name = "TOPOGRAPHY" - iret = get2d_real(var_name,ELRT_inv,ixrt,jxrt,& + call readRT2d_real(var_name,ELRT,ixrt,jxrt,& trim(geo_finegrid_flnm)) #ifdef HYDRO_D write(6,*) "read ",var_name @@ -5056,7 +4988,7 @@ SUBROUTINE READ_ROUTING_old(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & ! trim(geo_finegrid_flnm)) var_name = "CHANNELGRID" - call get2d_int(var_name,CH_NETRT_inv,ixrt,jxrt,& + call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& trim(geo_finegrid_flnm)) #ifdef HYDRO_D @@ -5064,42 +4996,27 @@ SUBROUTINE READ_ROUTING_old(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & #endif var_name = "LKSATFAC" - LKSATFAC_inv = -9999.9 - iret = get2d_real(var_name,LKSATFAC_inv,ixrt,jxrt,& + LKSATFAC = -9999.9 + call readRT2d_real(var_name,LKSATFAC,ixrt,jxrt,& trim(geo_finegrid_flnm)) #ifdef HYDRO_D write(6,*) "read ",var_name #endif - where (LKSATFAC_inv == -9999.9) LKSATFAC_inv = 1000.0 !specify LKSAFAC if no term avail... + where (LKSATFAC == -9999.9) LKSATFAC = 1000.0 !specify LKSAFAC if no term avail... !1.12.2012...Read in routing calibration factors... var_name = "RETDEPRTFAC" - iret = get2d_real(var_name,RETDEPRTFAC_inv,ixrt,jxrt,& + call readRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,& trim(geo_finegrid_flnm)) - where (RETDEPRTFAC_inv < 0.) RETDEPRTFAC_inv = 1.0 ! reset grid to = 1.0 if non-valid value exists + where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists var_name = "OVROUGHRTFAC" - iret = get2d_real(var_name,OVROUGHRTFAC_inv,ixrt,jxrt,& + call readRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,& trim(geo_finegrid_flnm)) - where (OVROUGHRTFAC_inv <= 0.) OVROUGHRTFAC_inv = 1.0 ! reset grid to = 1.0 if non-valid value exists - - - -!!!Flip y-dimension of highres grids from exported Arc files... + where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists - do i=1,ixrt - jj=jxrt - do j=1,jxrt - ELRT(i,j)=ELRT_inv(i,jj) - CH_NETRT(i,j)=CH_NETRT_inv(i,jj) - LKSATFAC(i,j)=LKSATFAC_inv(i,jj) - RETDEPRTFAC(i,j)=RETDEPRTFAC_inv(i,jj) - OVROUGHRTFAC(i,j)=OVROUGHRTFAC_inv(i,jj) - jj=jxrt-j - end do - end do #ifdef HYDRO_D write(6,*) "finish READ_ROUTING_old" @@ -5111,4 +5028,1313 @@ SUBROUTINE READ_ROUTING_old(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & END SUBROUTINE READ_ROUTING_old !DJG _____________________________ + +#ifdef MPP_LAND + + SUBROUTINE MPP_READ_CHROUTING(did,IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & + FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, & + NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, & + HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & + ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, & + route_link_f, & + route_lake_f, route_direction_f, route_order_f, & + CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, & + CHANXI, CHANYJ, CHLAT, CHLON, & + channel_option,LATVAL,LONVAL, & + STRMFRXSTPTS,geo_finegrid_flnm,Link_Location) + use module_mpp_land, only: my_id, io_id +#include + INTEGER, INTENT(IN) :: IXRT,JXRT, did + INTEGER :: CHANRTSWCRT, NLINKS, NLAKES + REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT + INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION + INTEGER, DIMENSION(IXRT,JXRT) :: GSTRMFRXSTPTS + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + INTEGER, DIMENSION(IXRT,JXRT) :: GORDER !-- gridded stream orderk + INTEGER, DIMENSION(IXRT,JXRT) :: Link_Location !-- gridded stream orderk + INTEGER :: I,J,channel_option + REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LATVAL, LONVAL + CHARACTER(len=28) :: dir +!Dummy inverted grids from arc + + +!----DJG,DNY New variables for channel and lake routing + CHARACTER(len=155) :: header + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: FROM_NODE + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ZELEV + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHLAT,CHLON + + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TYPEL + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TO_NODE,ORDER + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: STRMFRXSTPTS + + INTEGER, INTENT(INOUT) :: MAXORDER + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum + REAL, INTENT(INOUT), DIMENSION(NLINKS,2) :: QLINK !channel flow + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHANLEN !channel length + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MannN, So !mannings N + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: LAKENODE ! identifies which nodes pour into which lakes + REAL, INTENT(IN) :: dist(ixrt,jxrt,9) + + INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK + REAL, DIMENSION(IXRT,JXRT) :: ChSSlpG,BwG,MannNG !channel properties on Grid + + +!-- store the location x,y location of the channel element + INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ + +!--reservoir/lake attributes + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: HRZAREA + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: LAKEMAXH + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: WEIRC + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: WEIRL + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEC + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEA + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEE + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: LATLAKE,LONLAKE,ELEVLAKE + REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ChSSlp, Bw + + CHARACTER(len=256) :: route_link_f + CHARACTER(len=256) :: route_lake_f + CHARACTER(len=256) :: route_direction_f + CHARACTER(len=256) :: route_order_f + CHARACTER(len=256) :: geo_finegrid_flnm + CHARACTER(len=256) :: var_name + + INTEGER :: tmp, cnt, ncid, iret, jj,ct + real :: gc,n + +!--------------------------------------------------------- +! End Declarations +!--------------------------------------------------------- + MAXORDER = -9999 +!initialize GSTRM + GSTRMFRXSTPTS = -9999 + +!yw initialize the array. + to_node = MAXORDER + from_node = MAXORDER + Link_location = MAXORDER + +#ifdef HYDRO_D + print *, "reading routing initialization files..." + print *, "route direction", route_direction_f + print *, "route order", route_order_f + print *, "route linke",route_link_f + print *, "route lake",route_lake_f +#endif + +!DJG Edited code here to retrieve data from hires netcdf file.... + + IF((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then + + var_name = "LATITUDE" +#ifdef MPP_LAND + call mpp_readRT2d_real (did, & +#else + call readRT2d_real ( & +#endif + var_name,LATVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) + + + var_name = "LONGITUDE" +#ifdef MPP_LAND + call mpp_readRT2d_real(did, & +#else + call readRT2d_real( & +#endif + var_name,LONVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) + + END IF + + + IF(CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2) then +!DJG change filename to LAKEPARM.TBL open(unit=79,file=trim(route_link_f), & +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + open(unit=79,file='LAKEPARM.TBL', & + form='formatted',status='old') +#ifdef MPP_LAND + endif +#endif + END IF + + + var_name = "LAKEGRID" +#ifdef MPP_LAND + call mpp_readRT2d_int(did,& +#else + call readRT2d_int(& +#endif + var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm)) + + var_name = "FLOWDIRECTION" +#ifdef MPP_LAND + call mpp_readRT2d_int(did, & +#else + call readRT2d_int(& +#endif + var_name,DIRECTION,ixrt,jxrt,trim(geo_finegrid_flnm)) + + var_name = "STREAMORDER" +#ifdef MPP_LAND + call mpp_readRT2d_int(did,& +#else + call readRT2d_int(& +#endif + var_name,GORDER,ixrt,jxrt,trim(geo_finegrid_flnm)) + + + var_name = "frxst_pts" +#ifdef MPP_LAND + call mpp_readRT2d_int(did,& +#else + call readRT2d_int(& +#endif + var_name,GSTRMFRXSTPTS,ixrt,jxrt,trim(geo_finegrid_flnm)) + +!!!Flip y-dimension of highres grids from exported Arc files... + + + ct = 0 + +#ifdef HYDRO_D + print *, "Number of frxst pts: ",ct +#endif + + +! temp fix for buggy Arc export... + do j=1,jxrt + do i=1,ixrt + if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 + end do + end do + + cnt =0 + if ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option .ne. 3) then ! not routing on grid, read from file + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + read(79,*) header +#ifdef MPP_LAND + endif +#endif + call hydro_stop("Possible Error for this code") + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + do i=1,NLINKS + read (79,*) tmp, FROM_NODE(i), TO_NODE(i), TYPEL(i),& + ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), & + MannN(i), So(i), ChSSlp(i), Bw(i), HRZAREA(i),& + LAKEMAXH(i), WEIRC(i), WEIRL(i), ORIFICEC(i), & + ORIFICEA(i),ORIFICEE(i) + + !-- hardwire QLINK + QLINK(i,1) = 1.0 + QLINK(i,2) = QLINK(i,1) + + if (So(i).lt.0.005) So(i) = 0.005 !-- impose a minimum slope requireement + + if (ORDER(i) .gt. MAXORDER) then + MAXORDER = ORDER(i) + endif + + end do +#ifdef MPP_LAND + endif + call mpp_land_bcast_int(NLINKS,FROM_NODE) + call mpp_land_bcast_int(NLINKS,TO_NODE) + call mpp_land_bcast_int(NLINKS,TYPEL ) + call mpp_land_bcast_int(NLINKS,ORDER ) + call mpp_land_bcast_real(NLINKS,QLINK ) + call mpp_land_bcast_real(NLINKS,MUSK ) + call mpp_land_bcast_real(NLINKS,MUSX ) + call mpp_land_bcast_real(NLINKS,CHANLEN) + call mpp_land_bcast_real(NLINKS,MannN ) + call mpp_land_bcast_real(NLINKS,So ) + call mpp_land_bcast_real(NLINKS,ChSSlp ) + call mpp_land_bcast_real(NLINKS,Bw ) + call mpp_land_bcast_real(NLINKS,HRZAREA) + call mpp_land_bcast_real(NLINKS,LAKEMAXH) + call mpp_land_bcast_real(NLINKS,WEIRC ) + call mpp_land_bcast_real(NLINKS,WEIRL ) + call mpp_land_bcast_real(NLINKS,ORIFICEC) + call mpp_land_bcast_real(NLINKS,ORIFICEA) + call mpp_land_bcast_real(NLINKS,ORIFICEE) + call mpp_land_bcast_int1(MAXORDER) + +#endif + + elseif ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then !-- handle setting up topology on the grid for diffusion scheme + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + read(79,*) header !-- read the lake file +#ifdef HYDRO_D + write(*,*) "output message: reading lake file ", header + write(6,*) "output message: error check read file ",route_link_f +#endif +#ifdef MPP_LAND + endif +#endif + + + if (NLAKES.gt.0) then !read in only if there are lakes + +#ifdef MPP_LAND + if(my_id .eq. IO_id) then +#endif + + do i=1, NLAKES + read (79,*) tmp, HRZAREA(i),LAKEMAXH(i), & + WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),& + LATLAKE(i), LONLAKE(i),ELEVLAKE(i) +#ifdef HYDRO_D + write (*,*) tmp, HRZAREA(i),LAKEMAXH(i), LATLAKE(i), LONLAKE(i),ELEVLAKE(i),NLAKES +#endif + enddo + +#ifdef MPP_LAND + endif + call mpp_land_bcast_real(NLAKES,HRZAREA) + call mpp_land_bcast_real(NLAKES,LAKEMAXH) + call mpp_land_bcast_real(NLAKES,WEIRC ) + call mpp_land_bcast_real(NLAKES,WEIRL ) + call mpp_land_bcast_real(NLAKES,ORIFICEC) + call mpp_land_bcast_real(NLAKES,ORIFICEA) + call mpp_land_bcast_real(NLAKES,ORIFICEE) + call mpp_land_bcast_real(NLAKES,LATLAKE ) + call mpp_land_bcast_real(NLAKES,LONLAKE ) + call mpp_land_bcast_real(NLAKES,ELEVLAKE) +#endif + + end if !end if for NLAKES >0 check + + cnt = 0 + + + BwG = 0.0 + ChSSlpG = 0.0 + MannNG = 0.0 + TYPEL = 0 + MannN = 0.0 + Bw = 0.0 + ChSSlp = 0.0 + +!DJG inv DO j = JXRT,1,-1 !rows + DO j = 1,JXRT !rows + DO i = 1 ,IXRT !colsumns + If (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order + If ((DIRECTION(i, j) .EQ. 64) .AND. (j + 1 .LE. JXRT) .AND. & + (CH_NETRT(i,j+1).ge.0) ) then !North + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i, j + 1) + CHANLEN(cnt) = dist(i,j,1) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1).ge.0) ) then !North East + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1) + CHANLEN(cnt) = dist(i,j,2) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT) & + .AND. (CH_NETRT(i+1,j).ge.0) ) then !East + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j) + CHANLEN(cnt) = dist(i,j,3) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & + .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i+1,j-1).ge.0) ) then !south east + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1) + CHANLEN(cnt) = dist(i,j,4) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0) ) then !due south + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i, j - 1) + CHANLEN(cnt) = dist(i,j,5) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & + .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i-1,j-1).ge.0)) then !south west + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i,j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1) + CHANLEN(cnt) = dist(i,j,6) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0) ) then !West + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j) + CHANLEN(cnt) = dist(i,j,7) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0) ) then !North West + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + FROM_NODE(cnt) = CH_NETLNK(i, j) + TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1) + CHANLEN(cnt) = dist(i,j,8) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt + else +#ifdef HYDRO_D + print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east +#endif + End If + + End If !CH_NETRT check for this node + + END DO + END DO + +#ifdef HYDRO_D + print *, "after exiting the channel, this many nodes", cnt + write(*,*) " " +#endif + +!Find out if the boundaries are on an edge +!DJG inv DO j = JXRT,1,-1 + DO j = 1,JXRT + DO i = 1 ,IXRT + If (CH_NETRT(i, j) .ge. 0) then !get its direction + +!#ifdef MPP_LAND +! If (((DIRECTION(i, j).EQ. 64) .AND. ((j + 1 .GT. JXRT) .and. (up_id < 0)) ) .OR. & !-- 64's can only flow north +! ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North +!#else + If (((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) .OR. & !-- 64's can only flow north + ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North +!#endif + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(j+1 .GT. JXRT) then !-- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i,j+1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i,j+1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,1) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + +!#ifdef MPP_LAND +! else if ( ((DIRECTION(i, j) .EQ. 128) .AND. ((i + 1 .GT. IXRT) .and. (right_id < 0)) ) & !-- 128's can flow out of the North or East edge +! .OR. ((DIRECTION(i, j) .EQ. 128) .AND. ((j + 1 .GT. JXRT) .and. (up_id < 0)) ) & ! this is due north edge +! .OR. ((DIRECTION(i, j) .EQ. 128) .AND. (i1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if((i+1 .GT. IXRT) .OR. (j-1 .EQ. 0)) then !an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i+1,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,4) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + +!#ifdef MPP_LAND +! else if (((DIRECTION(i, j) .EQ. 4) .AND. ((j - 1 .EQ. 0) .and. (down_id <0)) ) .OR. & !-- 4's can only flow due south +! ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south +!#else + else if (((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) .OR. & !-- 4's can only flow due south + ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south +!#endif + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(j-1 .EQ. 0) then !- an edge + TYPEL(cnt) =1 + elseif(LAKE_MSKRT(i,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,5) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + +!#ifdef MPP_LAND +! else if ( ((DIRECTION(i, j) .EQ. 8) .AND. ((i - 1 .LE. 0).and.(left_id <0))) & !-- 8's can flow south or west +! .OR. ((DIRECTION(i, j) .EQ. 8) .AND.( (j - 1 .EQ. 0) .and. (down_id <0)) ) & !-- this is the south edge +! .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west +!#else + else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west + .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge + .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west +!#endif + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if( (i-1 .EQ. 0) .OR. (j-1 .EQ. 0) ) then !- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i-1,j-1).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,6) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif +!#ifdef MPP_LAND +! else if (((DIRECTION(i, j) .EQ. 16) .AND. ((i - 1 .LE.0) .and. (left_id <0)) ) & !16's can only flow due west +!#else + else if (((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE.0) ) & !16's can only flow due west +!#endif + .OR.((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West + !yw cnt = cnt + 1 + cnt = CH_NETLNK(i,j) + ORDER(cnt) = GORDER(i,j) + STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) + ZELEV(cnt) = ELRT(i,j) + MannN(cnt) = MannNG(i,j) + ChSSlp(cnt) = ChSSlpG(i,j) + Bw(cnt) = BwG(i,j) + CHLAT(cnt) = LATVAL(i,j) + CHLON(cnt) = LONVAL(i,j) + if(i-1 .EQ. 0) then !-- an edge + TYPEL(cnt) = 1 + elseif(LAKE_MSKRT(i-1,j).gt.0) then + TYPEL(cnt) = 2 + LAKENODE(cnt) = LAKE_MSKRT(i-1,j) + else + TYPEL(cnt) = 1 + endif + FROM_NODE(cnt) = CH_NETLNK(i, j) + CHANLEN(cnt) = dist(i,j,7) + CHANXI(cnt) = i + CHANYJ(cnt) = j + Link_Location(i,j) = cnt +#ifdef HYDRO_D + print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt +#endif + +!#ifdef MPP_LAND +! else if ( ((DIRECTION(i, j) .EQ. 32) .AND. ((i - 1 .LE. 0) .and. (left_id <0)) ) & !-- 32's can flow either west or north +! .OR. ((DIRECTION(i, j) .EQ. 32) .AND. ((j + 1 .GT. JXRT) .and. (up_id <0)) ) & !-- this is the north edge +!#else + else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north + .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge +!#endif + .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j + INTEGER :: I,J,channel_option,iret,jj, did + INTEGER, INTENT(OUT) :: NLINKS + INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id + + INTEGER, INTENT(IN) :: IXRT,JXRT + INTEGER :: CHNID,cnt + INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask + INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction + INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT + REAL, DIMENSION(IXRT,JXRT) :: LAT, LON + +!!Dummy read in grids for inverted y-axis + + + CHARACTER(len=*) :: route_chan_f, route_link_f,route_direction_f,route_lake_f + CHARACTER(len=256) :: InputLine + CHARACTER(len=256) :: geo_finegrid_flnm + CHARACTER(len=256) :: var_name +! external get2d_real +! integer :: get2d_real + + NLINKS = 0 + CH_NETRT = -9999 + CH_NETLNK = -9999 + + + cnt = 0 +#ifdef HYDRO_D + print *, "Channel Option in Routedim is ", channel_option +#endif + + IF(channel_option.eq.3) then !get maxnodes and links from grid + + var_name = "CHANNELGRID" +#ifdef MPP_LAND + call mpp_readRT2d_int(did,& +#else + call readRT2d_int(& +#endif + var_name,CH_NETRT,ixrt,jxrt, trim(geo_finegrid_flnm)) + + + var_name = "FLOWDIRECTION" +#ifdef MPP_LAND + call mpp_readRT2d_int(did, & +#else + call readRT2d_int( & +#endif + var_name,DIRECTION,ixrt,jxrt, trim(geo_finegrid_flnm)) + + var_name = "LAKEGRID" +#ifdef MPP_LAND + call mpp_readRT2d_int(did, & +#else + call readRT2d_int( & +#endif + var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm)) + + + var_name = "LATITUDE" +#ifdef MPP_LAND + call mpp_readRT2d_real(did, & +#else + call readRT2d_real( & +#endif + var_name,LAT,ixrt,jxrt,trim(geo_finegrid_flnm)) + + + var_name = "LONGITUDE" +#ifdef MPP_LAND + call mpp_readRT2d_real(did, & +#else + call readRT2d_real( & +#endif + var_name,LON,ixrt,jxrt,trim(geo_finegrid_flnm)) + +! temp fix for buggy Arc export... + do j=1,jxrt + do i=1,ixrt + if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 + end do + end do + +!DJG inv do j=jxrt,1,-1 + do j=1,jxrt + do i = 1, ixrt + if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then + NLINKS = NLINKS + 1 + endif + end do + end do +#ifdef HYDRO_D + print *, "NLINKS IS ", NLINKS +#endif + + +!DJG inv DO j = JXRT,1,-1 !rows + DO j = 1,JXRT !rows + DO i = 1 ,IXRT !colsumns + If (CH_NETRT(i, j) .ge. 0) then !get its direction + If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT).AND.(CH_NETRT(i,j+1) .ge.0) ) then !North + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1) .ge.0)) then !North East + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT).AND.(CH_NETRT(i+1,j) .ge. 0)) then !East + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & + .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i+1,j-1).ge.0)) then !south east + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0)) then !due south + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & + .AND. (j - 1 .NE. 0).AND. (CH_NETRT(i-1,j-1).ge.0) ) then !south west + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0)) then !West + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & + .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0)) then !North West + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt + else +#ifdef HYDRO_D + write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j +135 FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4) +#endif + if (DIRECTION(i,j) .eq. 0) then +#ifdef HYDRO_D + print *, "Direction i,j ",i,j," of point ", cnt, "is invalid" +#endif + endif + + End If + End If !CH_NETRT check for this node + END DO + END DO +#ifdef HYDRO_D + print *, "found type 0 nodes", cnt +#endif + +!Find out if the boundaries are on an edge or flow into a lake +!DJG inv DO j = JXRT,1,-1 + DO j = 1,JXRT + DO i = 1 ,IXRT + If (CH_NETRT(i, j) .ge. 0) then !get its direction + + If ( ((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) & !-- 64's can only flow north + .OR. ((DIRECTION(i, j) .EQ. 64).and. (j1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) & !-- 4's can only flow due south + .OR. ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west + .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge + .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE. 0)) & !-- 16's can only flow due west + .OR. ((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West + cnt = cnt + 1 + CH_NETLNK(i,j) = cnt +#ifdef HYDRO_D + print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j +#endif + else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north + .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge + .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. jchannel coefficients" print *, "nod, n, Cs, Bw", nod, n, Cs, Bw - call hydro_stop() + call hydro_stop("in DIFFUSION") #endif endif @@ -194,7 +205,7 @@ REAL FUNCTION DIFFUSION(nod,z1,z2,h1,h2,dx,n, & !endif !modifieed by Wei Yu for false geography data - if(abs(z1-z2) .gt. 1.0E4) then + if(abs(z1-z2) .gt. 1.0E5) then #ifdef HYDRO_D print*, "Warning: huge slope rest to 0 for channel grid.", z1,z2 #endif @@ -280,7 +291,7 @@ REAL FUNCTION MUSKINGCUNGE(index,qup, quc, qdp, ql,& if (n.le.0.or.So.le.0.or.z.le.0.or.Bw.le.0) then #ifdef HYDRO_D print*, "error in channel coefficients -> Muskingum cunge" - call hydro_stop() + call hydro_stop("in MUSKINGCUNGE") #endif end if @@ -411,10 +422,10 @@ END FUNCTION KINEMATIC ! ------------------------------------------------ ! SUBROUTINE drive_CHANNEL ! ------------------------------------------------ - Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & + Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & QSUBRT, LAKEINFLORT, QSTRMVOLRT, TO_NODE, FROM_NODE, & TYPEL, ORDER, MAXORDER, NLINKS, CH_NETLNK, CH_NETRT, & - LAKE_MSKRT, DT, DTRT, MUSK, MUSX, QLINK, & + LAKE_MSKRT, DT, DTCT,DTRT, MUSK, MUSX, QLINK, & HLINK, ELRT, CHANLEN, MannN, So, ChSSlp, Bw, & RESHT, HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & ORIFICEE, ZELEV, CVOL, NLAKES, QLAKEI, QLAKEO, LAKENODE, & @@ -440,6 +451,7 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT + real , dimension(ixrt,jxrt):: latval,lonval INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT INTEGER, INTENT(IN), DIMENSION(NLINKS) :: ORDER, TYPEL !--link @@ -456,28 +468,29 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & REAL , INTENT(INOUT), DIMENSION(NLINKS) :: HLINK REAL, INTENT(IN) :: DT !-- model timestep REAL, INTENT(IN) :: DTRT !-- routing timestep - REAL :: DTCT, dist(ixrt,jxrt,9) + REAL, INTENT(INOUT):: DTCT + REAL :: dist(ixrt,jxrt,9) REAL :: RETDEP_CHAN INTEGER, INTENT(IN) :: MAXORDER, SUBRTSWCRT REAL , INTENT(IN), DIMENSION(NLINKS) :: node_area !-- lake params - REAL, INTENT(IN), DIMENSION(NLINKS) :: HRZAREA !-- horizontal area (km^2) - REAL, INTENT(IN), DIMENSION(NLINKS) :: LAKEMAXH !-- maximum lake depth (m^2) - REAL, INTENT(IN), DIMENSION(NLINKS) :: WEIRC !-- weir coefficient - REAL, INTENT(IN), DIMENSION(NLINKS) :: WEIRL !-- weir length (m) - REAL, INTENT(IN), DIMENSION(NLINKS) :: ORIFICEC !-- orrifice coefficient - REAL, INTENT(IN), DIMENSION(NLINKS) :: ORIFICEA !-- orrifice area (m^2) - REAL, INTENT(IN), DIMENSION(NLINKS) :: ORIFICEE !-- orrifce elevation (m) - - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: RESHT !-- reservoir height (m) - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: QLAKEI !-- lake inflow (cms) - REAL, DIMENSION(NLINKS) :: QLAKEIP !-- lake inflow previous timestep (cms) - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: QLAKEO !-- outflow from lake used in diffusion scheme + REAL, INTENT(IN), DIMENSION(NLAKES) :: HRZAREA !-- horizontal area (km^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: LAKEMAXH !-- maximum lake depth (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRC !-- weir coefficient + REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRL !-- weir length (m) + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEC !-- orrifice coefficient + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEA !-- orrifice area (m^2) + REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEE !-- orrifce elevation (m) + + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: RESHT !-- reservoir height (m) + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEI !-- lake inflow (cms) + REAL, DIMENSION(NLAKES) :: QLAKEIP !-- lake inflow previous timestep (cms) + REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEO !-- outflow from lake used in diffusion scheme INTEGER, INTENT(IN), DIMENSION(NLINKS) :: LAKENODE !-- outflow from lake used in diffusion scheme REAL, DIMENSION(NLINKS) :: QLateral !--lateral flux REAL, DIMENSION(NLINKS) :: QSUM !--mass bal of node - REAL, DIMENSION(NLINKS) :: QLLAKE !-- lateral inflow to lake in diffusion scheme + REAL, DIMENSION(NLAKES) :: QLLAKE !-- lateral inflow to lake in diffusion scheme !-- Local Variables INTEGER :: i,j,k,m,kk,KRT,node @@ -500,13 +513,14 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & #endif integer flag + integer :: kk2 ! tmp + QLAKEIP = 0 QLINKPREV = 0 HLINKTMP = 0 CVOLTMP = 0 CD = 0 -!yw node = 3924 node = 1 @@ -519,12 +533,13 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & #ifdef MPP_LAND #ifdef HYDRO_D write(6,*) "Error: not parallelized" - call hydro_stop() + call hydro_stop("in drive_CHANNEL") #endif #endif DT_STEPS = 1 DO KRT=1,DT_STEPS !-- route over routing timestep + do k = 1, NLINKS QLateral(k)=0 !--initial lateral flux to 0 for this reach do i = 1, IXRT @@ -576,7 +591,7 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & else #ifdef HYDRO_D print *, "No channel option selected" - call hydro_stop() + call hydro_stop("drive_CHANNEL") #endif endif endif @@ -611,7 +626,7 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & else #ifdef HYDRO_D print *, " no channel option selected" - call hydro_stop() + call hydro_stop("drive_CHANNEL") #endif endif QLINK(k,1) = qu !save inflow to reach at current timestep @@ -629,19 +644,26 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & !yw begin elseif(channel_option .eq. 3) then !--- route using the diffusion scheme on nodes not links + #ifdef MPP_LAND call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINK,NLINKS,99) call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOL,NLINKS,99) #endif - + KRT = 0 !-- initialize the time counter - DTCT = DTRT !-- initialize the routing timestep to the timestep in namelist (s) + + DTCT = min(DTCT*2.0,DTRT) +!yw DTCT = DTRT !-- initialize the routing timestep to the timestep in namelist (s) + HLINKTMP = HLINK !-- temporary storage of the water elevations (m) CVOLTMP = CVOL !-- temporary storage of the volume of water in channel (m^3) QLAKEIP = QLAKEI !-- temporary lake inflow from previous timestep (cms) - +! call check_channel(77,HLINKTMP,1,nlinks) ! call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,ZELEV,NLINKS,99) +! call check_channel(78,ZELEV,1,nlinks) + + crnt: DO !-- loop on the courant condition QSUM = 0 !-- initialize the total flow out of each cell to zero QLAKEI = 0 !-- set the lake inflow as zero @@ -658,11 +680,10 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & #else DO i = 1,NLINKS #endif + if(node_area(i) .eq. 0) then -#ifdef HYDRO_D write(6,*) "Error: node_area(i) is zero. i=", i - call hydro_stop() -#endif + call hydro_stop("drive_CHANNEL") endif if((CH_NETRT(CHANXI(i), CHANYJ(i) ) .eq. 0) .and. & @@ -678,11 +699,11 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & print *, "NEGATIVE Lat inflow...",QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))), & QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)), & QINFLOWBASE(CHANXI(i),CHANYJ(i)) - call hydro_stop() + call hydro_stop("drive_CHANNEL") #endif end if elseif(LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .gt. 0 .and. & - (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .ne. 9999)) then !--a lake node + (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .ne. -9999)) then !--a lake node QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) = & QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) + & (LAKEINFLORT(CHANXI(i),CHANYJ(i))+ & @@ -697,9 +718,13 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & #ifdef MPP_LAND call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLateral,NLINKS,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT ,ixrt,jxrt,QLLAKE,NLINKS,99) + if(NLAKES .gt. 0) then + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT ,ixrt,jxrt,QLLAKE,NLAKES,99) + endif #endif +! call check_channel(79,QLINK(:,1),1,nlinks) + !-- compute conveyances, with known depths (just assign to QLINK(,1) !--QLINK(,2) will not be used), QLINK is the flow across the node face @@ -712,18 +737,10 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & DO i = 1,NLINKS #endif if (TYPEL(i) .eq. 0 .AND. HLINKTMP(FROM_NODE(i)) .gt. RETDEP_CHAN) then - - if(from_node(i) .ne. to_node(i) ) & ! added by Wei Yu - QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & - HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & - CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) - -#ifdef HYDRO_D - if(qlink(i,1) .ge. 1.0E6) then - print*, "Warning: big Qlink",QLINK(i,1),i,TO_NODE(i),from_node(i) - endif -#endif - + if(from_node(i) .ne. to_node(i) .and. (to_node(i) .gt. 0) .and.(from_node(i) .gt. 0) ) & ! added by Wei Yu + QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & + HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & + CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) else !-- we are just computing critical depth for outflow points QLINK(i,1) =0. endif @@ -732,7 +749,17 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & #ifdef MPP_LAND call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99) #endif +! call check_lake(80,QLLAKE,lake_index,nlakes) +! call check_channel(81,QLINK(:,1),1,nlinks) +! call check_channel(82,HLINKTMP,1,nlinks) +! call check_channel(89,HLINKTMP,1,nlinks) +! call check_channel(83,CHANLEN,1,nlinks) +! call check_channel(84,MannN,1,nlinks) +! call check_channel(85,Bw,1,nlinks) +! call check_channel(86,ChSSlp,1,nlinks) +! call check_channel(87,TYPEL*1.0,1,nlinks) + !-- compute total flow across face, into node #ifdef MPP_LAND DO iyw = 1,yw_mpp_nlinks @@ -741,14 +768,22 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & DO i = 1,NLINKS !-- inflow to node across each face #endif if(TYPEL(i) .eq. 0) then !-- only regular nodes have to attribute - QSUM(TO_NODE(i)) = QSUM(TO_NODE(i)) + QLINK(i,1) + QSUM(TO_NODE(i)) = QSUM(TO_NODE(i)) + QLINK(i,1) endif END DO #ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,99) + call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,0) #endif +! call check_channel(79,TYPEL*1.0,1,nlinks) + +! call check_channel(80,QLINK(:,1),1,nlinks) + +! call check_channel(89,qsum,1,nlinks) + + + #ifdef MPP_LAND DO iyw = 1,yw_mpp_nlinks i = nlinks_index(iyw) @@ -760,8 +795,12 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & #ifdef MPP_LAND call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,99) #endif +! call check_channel(89,qsum,1,nlinks) + flag = 99 + + #ifdef MPP_LAND DO iyw = 1,yw_MPP_NLINKS i = nlinks_index(iyw) @@ -772,9 +811,19 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & if( TYPEL(i).eq.0 .and. CVOLTMP(i) .ge. 0.001 .and.(CVOLTMP(i)-QSUM(i)*DTCT)/CVOLTMP(i) .le. -0.01 ) then flag = -99 #ifdef HYDRO_D - write(6,*) "Unstatble at node ",i + write(6,*) "******* start diag ***************" + write(6,*) "Unstable at node ",i, "i=",CHANXI(i),"j=",CHANYJ(i) + write(6,*) "Unstatble at node ",i, "lat=",latval(CHANXI(i),CHANYJ(i)), "lon=",lonval(CHANXI(i),CHANYJ(i)) write(6,*) "TYPEL, CVOLTMP, QSUM, QSUM*DTCT",TYPEL(i), CVOLTMP(i), QSUM(i), QSUM(i)*DTCT write(6,*) "qsubrt, qstrmvolrt,qlink",QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)),qlink(i,1),qlink(i,2) +! write(6,*) "current nodes, z, h", ZELEV(FROM_NODE(i)),HLINKTMP(FROM_NODE(i)) +! if(TO_NODE(i) .gt. 0) then +! write(6,*) "to nodes, z, h", ZELEV(TO_NODE(i)), HLINKTMP(TO_NODE(i)) +! else +! write(6,*) "no to nodes " +! endif + write(6,*) "CHANLEN(i), MannN(i), Bw(i), ChSSlp(i) ", CHANLEN(i), MannN(i), Bw(i), ChSSlp(i) + write(6,*) "*******end of diag ***************" #endif goto 999 @@ -787,9 +836,12 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & #endif - if(flag < 0 ) then + if(flag < 0 .and. DTCT >0.1) then + + ! call smoth121(HLINK,nlinks,maxv_p,pnode,to_node) + if(DTCT .gt. 0.001) then !-- timestep in seconds - DTCT = DTCT/2 !-- 1/2 timestep + DTCT = max(DTCT/2 ,0.1) !-- 1/2 timestep KRT = 0 !-- restart counter HLINKTMP = HLINK !-- set head and vol to start value of timestep CVOLTMP = CVOL @@ -797,7 +849,7 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & else #ifdef HYDRO_D write(6,*) "Error ..... with small DTCT",DTCT - call hydro_stop() + call hydro_stop("drive_CHANNEL") #endif DTCT = 0.1 HLINKTMP = HLINK !-- set head and volume to start values of timestep @@ -831,36 +883,36 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & if (QSUM(i)+QLateral(i) .lt. 0) then else - CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) +!DJG remove to have const. flux b.c.... CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) + CD(i) = HLINKTMP(i) !This is a temp hardwire for flow depth for the pour point... + endif - endif ! change in volume is inflow, lateral flow, and outflow - CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & !yw DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*DXRT),HLINKTMP(i), & - DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & - CD(i),CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT - + CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & + DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & + CD(i),CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT elseif (TYPEL(i) .eq. 2) then !--- into a reservoir, assume critical depth if (QSUM(i)+QLateral(i) .lt. 0) then #ifdef HYDRO_D print *, i, 'CrtDpth Qsum+QLat into lake< 0',QSUM(i), QLateral(i) #endif else - CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) +!DJG remove to have const. flux b.c.... CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) + CD(i) = HLINKTMP(i) !This is a temp hardwire for flow depth for the pour point... endif !-- compute volume in reach (m^3) - CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & - DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & - CD(i) ,CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT - + CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & + DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & + CD(i) ,CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT !-- compute flow rate into lake from all contributing nodes (cms) QLAKEI(LAKENODE(i)) = QLAKEI(LAKENODE(i)) + QLINK(FROM_NODE(i),1) else #ifdef HYDRO_D - print *, "this node does not have a type.. error" - call hydro_stop() + print *, "this node does not have a type.. error TYPEL =", TYPEL(i) + call hydro_stop("drive_CHANNEL") #endif endif @@ -875,14 +927,19 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & #ifdef MPP_LAND call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOLTMP,NLINKS,99) call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CD,NLINKS,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) + if(NLAKES .gt. 0) then + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) + endif call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINKTMP,NLINKS,99) #endif +! call check_channel(83,CVOLTMP,1,nlinks) +! call check_channel(84,CD,1,nlinks) +! call check_channel(85,HLINKTMP,1,nlinks) +! call check_lake(86,QLAKEI,lake_index,nlakes) + +! call hydro_stop("88888888") + -! call check_channel(92,CVOLTMP,nlinks_index,mpp_nlinks,nlinks) -! call check_channel(91,CD,nlinks_index,mpp_nlinks,nlinks) -! call check_channel(55,QLAKEI,nlinks_index,mpp_nlinks,nlinks) -! call check_channel(56,HLINKTMP,nlinks_index,mpp_nlinks,nlinks) do i = 1, NLAKES !-- mass balances of lakes @@ -898,11 +955,13 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & #endif enddo #ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT ,ixrt,jxrt,QLLAKE,NLINKS,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,RESHT,NLAKES,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEO,NLAKES,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEIP,NLAKES,99) + if(NLAKES .gt. 0) then + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT ,ixrt,jxrt,QLLAKE,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,RESHT,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEO,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) + call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEIP,NLAKES,99) + endif #endif @@ -913,9 +972,9 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & DO i = 1, NLINKS !--- compute volume and depth at each node #endif if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow - QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & - HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & - CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) + QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & + HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & + CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) endif enddo @@ -933,7 +992,7 @@ Subroutine drive_CHANNEL(KT, IXRT,JXRT, SUBRTSWCRT, & else !-- no channel option apparently selected #ifdef HYDRO_D print *, "no channel option selected" - call hydro_stop() + call hydro_stop("drive_CHANNEL") #endif endif @@ -970,7 +1029,7 @@ REAL FUNCTION FLOW(n,So,Bw,h,z) if (WP .le.0) then #ifdef HYDRO_D print *, "Wetter perimeter is zero, will get divide by zero error" - call hydro_stop() + call hydro_stop("in SHAPE") #endif else FLOW = (1/n)*sqrt(So)*(AREA**(5./3.)/(WP**(2./3.))) @@ -989,7 +1048,7 @@ REAL FUNCTION CDf(Q,Bw,h,z) if(h .le. 0) then #ifdef HYDRO_D print *, "head is zero, will get division by zero error" - call hydro_stop() + call hydro_stop("in AREAf") #endif else CDf = (Q/((Bw+z*h)*h))/(sqrt(9.81*(((Bw+z*h)*h)/(Bw+2*z*h))))-1 !--critical depth function @@ -1087,7 +1146,9 @@ REAL FUNCTION CRITICALDEPTH(lnk,Q,Bw,z) !-- find the critical depth print *, "interval won't work to find CD of lnk ", lnk print *, "Q, hl, hu", Q, hl, hu print *, "cd lwr, upr", CDf(Q,BW,hl,z), CDf(Q,BW,hu,z) - call hydro_stop() + ! call hydro_stop("in CRITICALDEPTH") + CRITICALDEPTH = -9999 + return #endif else Q = 0.0 @@ -1196,15 +1257,73 @@ REAL FUNCTION fnDXCDT(qp,Tw,So,Ck,dx,dt) !-- function to help find sub-length fo END FUNCTION fnDXCDT ! ---------------------------------------------------------------------- - subroutine check_channel(unit,cd,nlinks_index,mpp_nlinks,nlinks) - integer :: unit,mpp_nlinks,nlinks,nlinks_index(nlinks),i + subroutine check_lake(unit,cd,lake_index,nlakes) + use module_RT_data, only: rt_domain + implicit none + integer :: unit,nlakes,i,lake_index(nlakes) + real cd(nlakes) +#ifdef MPP_LAND + call write_lake_real(cd,lake_index,nlakes) +#endif + write(unit,*) cd + flush(unit) + return + end subroutine check_lake + + subroutine check_channel(unit,cd,did,nlinks) + use module_RT_data, only: rt_domain +#ifdef MPP_LAND + USE module_mpp_land +#endif + implicit none + integer :: unit,nlinks,i, did real cd(nlinks) #ifdef MPP_LAND - call write_chanel_real(cd,nlinks_index,mpp_nlinks,nlinks) + real g_cd(rt_domain(did)%gnlinks) + call write_chanel_real(cd,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,nlinks,g_cd) if(my_id .eq. IO_id) then - write(unit,*) cd + write(unit,*) "rt_domain(did)%gnlinks = ",rt_domain(did)%gnlinks + write(unit,*) g_cd endif +#else + write(unit,*) cd #endif + flush(unit) + close(unit) return end subroutine check_channel + subroutine smoth121(var,nlinks,maxv_p,from_node,to_node) + implicit none + integer,intent(in) :: nlinks, maxv_p + integer, intent(in), dimension(nlinks):: to_node + integer, intent(in), dimension(nlinks):: from_node(nlinks,maxv_p) + real, intent(inout), dimension(nlinks) :: var + real, dimension(nlinks) :: vartmp + integer :: i,j , k, from,to + integer :: plen + vartmp = 0 + do i = 1, nlinks + to = to_node(i) + plen = from_node(i,1) + if(plen .gt. 1) then + do k = 1, plen-1 + from = from_node(i,k+1) + if(to .gt. 0) then + vartmp(i) = vartmp(i)+0.25*(var(from)+2.*var(i)+var(to)) + else + vartmp(i) = vartmp(i)+(2.*var(i)+var(from))/3.0 + endif + end do + vartmp(i) = vartmp(i) /(plen-1) + else + if(to .gt. 0) then + vartmp(i) = vartmp(i)+(2.*var(i)+var(to)/3.0) + else + vartmp(i) = var(i) + endif + endif + end do + var = vartmp + return + end subroutine smoth121 END MODULE module_channel_routing diff --git a/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F b/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F index 85f654a0..4ec65dd9 100644 --- a/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F +++ b/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F @@ -111,7 +111,7 @@ subroutine geth_newdate (ndate, odate, idt) case default #ifdef HYDRO_D write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - call hydro_stop() + call hydro_stop("geth_newdate") #endif end select @@ -165,7 +165,7 @@ subroutine geth_newdate (ndate, odate, idt) case default #ifdef HYDRO_D write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - call hydro_stop() + call hydro_stop("geth_newdate") #endif end select endif @@ -298,7 +298,7 @@ subroutine geth_newdate (ndate, odate, idt) write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & oldlen write(*,*) '#'//odate(1:oldlen)//'#' - call hydro_stop() + call hydro_stop("geth_newdate") #endif end if @@ -504,7 +504,7 @@ subroutine geth_idts (newdate, olddate, idt) if (newlen.ne.oldlen) then #ifdef HYDRO_D write(*,'("GETH_IDTS: NEWLEN /= OLDLEN: ", A, 3x, A)') newdate(1:newlen), olddate(1:oldlen) - call hydro_stop() + call hydro_stop("geth_newdate") #endif endif @@ -532,7 +532,7 @@ subroutine geth_idts (newdate, olddate, idt) #ifdef HYDRO_D write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') & ndate(1:newlen), odate(1:oldlen) - call hydro_stop() + call hydro_stop("geth_idts") #endif endif else @@ -541,7 +541,7 @@ subroutine geth_idts (newdate, olddate, idt) #ifdef HYDRO_D write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') & ndate(1:newlen), odate(1:oldlen) - call hydro_stop() + call hydro_stop("geth_idts") #endif endif endif @@ -588,7 +588,7 @@ subroutine geth_idts (newdate, olddate, idt) case default #ifdef HYDRO_D write(*,*) 'ERROR: geth_idts: odd length: #'//trim(odate)//'#' - call hydro_stop() + call hydro_stop("geth_idts") #endif end select else @@ -635,7 +635,7 @@ subroutine geth_idts (newdate, olddate, idt) case default #ifdef HYDRO_D write(*,*) 'ERROR: geth_idts: odd length: #'//trim(odate)//'#' - call hydro_stop() + call hydro_stop("geth_idts") #endif end select endif @@ -805,14 +805,14 @@ subroutine geth_idts (newdate, olddate, idt) if (.not. npass) then #ifdef HYDRO_D print*, 'Screwy NDATE: ', ndate(1:newlen) - call hydro_stop() + call hydro_stop("geth_idts") #endif end if if (.not. opass) then #ifdef HYDRO_D print*, 'Screwy ODATE: ', odate(1:oldlen) - call hydro_stop() + call hydro_stop("geth_idts") #endif end if @@ -953,7 +953,7 @@ function monthabbr_to_mm(mon) result(mm) #ifdef HYDRO_D write(*, '("Function monthabbr_to_mm: mon = <",A,">")') mon print*, "Function monthabbr_to_mm: Unrecognized mon" - call hydro_stop() + call hydro_stop("monthabbr_to_mm") #endif endif end function monthabbr_to_mm @@ -987,7 +987,7 @@ subroutine swap_date_format(indate, outdate) case default #ifdef HYDRO_D write(*,'("Unrecognized length: <", A,">")') indate - call hydro_stop() + call hydro_stop("swap_date_format") #endif end select else @@ -1014,7 +1014,7 @@ subroutine swap_date_format(indate, outdate) case default #ifdef HYDRO_D write(*,'("Unrecognized length: <", A,">")') indate - call hydro_stop() + call hydro_stop("swap_date_format") #endif end select endif @@ -1032,7 +1032,7 @@ character(len=3) function mm_to_monthabbr(ii) result(mon) else #ifdef HYDRO_D print*, "mm_to_monthabbr" - call hydro_stop() + call hydro_stop("mm_to_monthabbr") #endif endif end function mm_to_monthabbr diff --git a/wrfv2_fire/hydro/Routing/module_lsm_forcing.F b/wrfv2_fire/hydro/Routing/module_lsm_forcing.F index 944b3255..f60b0493 100644 --- a/wrfv2_fire/hydro/Routing/module_lsm_forcing.F +++ b/wrfv2_fire/hydro/Routing/module_lsm_forcing.F @@ -7,17 +7,27 @@ module module_lsm_forcing implicit none #include + integer :: i_forcing +character(len=19) out_date + +interface read_hydro_forcing +#ifdef MPP_LAND + module procedure read_hydro_forcing_mpp +#else + module procedure read_hydro_forcing_seq +#endif +end interface Contains - subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) + subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) implicit none character(len=*), intent(in) :: flnm integer, intent(in) :: ix integer, intent(in) :: jx character(len=*), intent(in) :: target_date - real, dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc + real, dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc, lai,fpar integer tlevel character(len=256) :: units @@ -25,6 +35,9 @@ subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) integer :: ncid tlevel = 1 + + pcp = 0 + pcpc = 0 ! Open the NetCDF file. ierr = nf_open(flnm, NF_NOWRITE, ncid) @@ -32,7 +45,7 @@ subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) #ifdef HYDRO_D write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) #endif - call hydro_stop() + call hydro_stop("READFORC_WRF") endif call get_2d_netcdf_ruc("T2", ncid, t, ix, jx,tlevel, .true., ierr) @@ -44,6 +57,11 @@ subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) call get_2d_netcdf_ruc("SWDOWN", ncid, sw, ix, jx,tlevel, .true., ierr) call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) + call get_2d_netcdf_ruc("VEGFRA", ncid, fpar, ix, jx,tlevel, .true., ierr) + if(ierr == 0) then + if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar/100. + endif + call get_2d_netcdf_ruc("LAI", ncid, lai, ix, jx,tlevel, .true., ierr) ierr = nf_close(ncid) @@ -72,7 +90,7 @@ subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) write(*,'("Problem opening geo_static file: ''", A, "''")') & trim(geo_static_flnm) #endif - call hydro_stop() + call hydro_stop("read_hrldas_hdrinfo") endif iret = nf_inq_dimid(ncid, "west_east", dimid) @@ -81,7 +99,7 @@ subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) #ifdef HYDRO_D print*, "nf_inq_dimid: west_east" #endif - call hydro_stop() + call hydro_stop("read_hrldas_hdrinfo") endif iret = nf_inq_dimlen(ncid, dimid, ix) @@ -89,7 +107,7 @@ subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) #ifdef HYDRO_D print*, "nf_inq_dimlen: west_east" #endif - call hydro_stop() + call hydro_stop("read_hrldas_hdrinfo") endif iret = nf_inq_dimid(ncid, "south_north", dimid) @@ -97,7 +115,7 @@ subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) #ifdef HYDRO_D print*, "nf_inq_dimid: south_north" #endif - call hydro_stop() + call hydro_stop("read_hrldas_hdrinfo") endif iret = nf_inq_dimlen(ncid, dimid, jx) @@ -105,7 +123,7 @@ subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) #ifdef HYDRO_D print*, "nf_inq_dimlen: south_north" #endif - call hydro_stop() + call hydro_stop("read_hrldas_hdrinfo") endif iret = nf_inq_dimid(ncid, "land_cat", dimid) @@ -113,7 +131,7 @@ subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) #ifdef HYDRO_D print*, "nf_inq_dimid: land_cat" #endif - call hydro_stop() + call hydro_stop("read_hrldas_hdrinfo") endif iret = nf_inq_dimlen(ncid, dimid, land_cat) @@ -121,7 +139,7 @@ subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) #ifdef HYDRO_D print*, "nf_inq_dimlen: land_cat" #endif - call hydro_stop() + call hydro_stop("read_hrldas_hdrinfo") endif iret = nf_inq_dimid(ncid, "soil_cat", dimid) @@ -129,7 +147,7 @@ subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) #ifdef HYDRO_D print*, "nf_inq_dimid: soil_cat" #endif - call hydro_stop() + call hydro_stop("read_hrldas_hdrinfo") endif iret = nf_inq_dimlen(ncid, dimid, soil_cat) @@ -137,7 +155,7 @@ subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) #ifdef HYDRO_D print*, "nf_inq_dimlen: soil_cat" #endif - call hydro_stop() + call hydro_stop("read_hrldas_hdrinfo") endif iret = nf_close(ncid) @@ -170,7 +188,7 @@ subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp #ifdef HYDRO_D write(*,'("Problem opening geo_static file: ''", A, "''")') trim(geo_static_flnm) #endif - call hydro_stop() + call hydro_stop("readland_hrldas") endif flag = -99 @@ -182,7 +200,7 @@ subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp #ifdef HYDRO_D write(6,*) "XLAT not found from wrfstatic file. " #endif - call hydro_stop() + call hydro_stop("readland_hrldas") endif flag = 2 endif @@ -250,7 +268,7 @@ subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp #ifdef HYDRO_D print*, "MODULE_NOAHLSM_HRLDAS_INPUT: READLAND_HRLDAS: NF_CLOSE" #endif - call hydro_stop() + call hydro_stop("readland_hrldas") endif ! Make sure vegtyp and soltyp are consistent when it comes to water points, @@ -285,9 +303,9 @@ subroutine get_2d_netcdf_ruc(var_name,ncid,var, & if (iret /= 0) then if (fatal_IF_ERROR) then #ifdef HYDRO_D - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf_inq_varid" + print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf_inq_varid ", trim(var_name) #endif - call hydro_stop() + call hydro_stop("get_2d_netcdf_ruc") else ierr = iret return @@ -321,7 +339,7 @@ subroutine get_2d_netcdf_cows(var_name,ncid,var, & #ifdef HYDRO_D print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid" #endif - call hydro_stop() + call hydro_stop("get_2d_netcdf_cows") else ierr = iret return @@ -368,7 +386,7 @@ subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, & write(*,'("READINIT Problem opening netcdf file: ''", A, "''")') & trim(netcdf_flnm) #endif - call hydro_stop() + call hydro_stop("readinit_hrldas") endif call get_2d_netcdf("CANWAT", ncid, cmc, units, ix, jx, .TRUE., ierr) @@ -385,7 +403,7 @@ subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, & print*, 'units = "'//trim(units)//'"' print*, "Unrecognized units on WEASD" #endif - call hydro_stop() + call hydro_stop("readinit_hrldas") endif call get_2d_netcdf("SNODEP", ncid, snodep, units, ix, jx, .FALSE., ierr_snodep) @@ -437,8 +455,8 @@ subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) real, dimension(ix,jx), intent(out) :: lw real, dimension(ix,jx), intent(out) :: sw real, dimension(ix,jx), intent(out) :: pcp - real, dimension(ix,jx), intent(out) :: lai - real, dimension(ix,jx), intent(out) :: fpar + real, dimension(ix,jx), intent(inout) :: lai + real, dimension(ix,jx), intent(inout) :: fpar character(len=256) :: units integer :: ierr @@ -450,7 +468,7 @@ subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) #ifdef HYDRO_D write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) #endif - call hydro_stop() + call hydro_stop("READFORC_HRLDAS") endif call get_2d_netcdf("T2D", ncid, t, units, ix, jx, .TRUE., ierr) @@ -463,7 +481,7 @@ subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) call get_2d_netcdf("RAINRATE",ncid, pcp, units, ix, jx, .TRUE., ierr) call get_2d_netcdf("VEGFRA", ncid, fpar, units, ix, jx, .FALSE., ierr) if (ierr == 0) then - fpar = fpar * 1.E-2 + if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000) fpar = fpar * 1.E-2 endif call get_2d_netcdf("LAI", ncid, lai, units, ix, jx, .FALSE., ierr) @@ -596,7 +614,7 @@ subroutine READFORC_NAMPCP(flnm,ix,jx,pcp,k,product) write(*,'("READFORC_NAMPCP1 Problem opening netcdf file: ''",A, "''")') & trim(flnm) #endif - call hydro_stop() + call hydro_stop("READFORC_NAMPCP") end if ierr = nf_inq_varid(ncid, trim(product), varid) @@ -608,7 +626,7 @@ subroutine READFORC_NAMPCP(flnm,ix,jx,pcp,k,product) write(*,'("READFORC_NAMPCP2 Problem reading netcdf file: ''", A,"''")') & trim(flnm) #endif - call hydro_stop() + call hydro_stop("READFORC_NAMPCP") end if endif #ifdef HYDRO_D @@ -657,7 +675,7 @@ subroutine READFORC_COWS(flnm,ix,jx,target_date, t,q,u,p,lw,sw,pcp,tlevel) #ifdef HYDRO_D write(*,'("READFORC_COWS Problem opening netcdf file: ''", A, "''")') trim(flnm) #endif - call hydro_stop() + call hydro_stop("READFORC_COWS") endif call get_2d_netcdf_cows("TA2", ncid, t, ix, jx,tlevel, .TRUE., ierr) @@ -699,7 +717,7 @@ subroutine READFORC_RUC(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) #ifdef HYDRO_D write(*,'("READFORC_RUC Problem opening netcdf file: ''", A, "''")') trim(flnm) #endif - call hydro_stop() + call hydro_stop("READFORC_RUC") endif call get_2d_netcdf_ruc("T2", ncid, t, ix, jx,tlevel, .true., ierr) @@ -748,7 +766,7 @@ subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) #ifdef HYDRO_D write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm) #endif - call hydro_stop() + call hydro_stop("READSNOW_FORC") endif call get_2d_netcdf("WEASD", ncid, tmp, units, ix, jx, .FALSE., ierr) @@ -821,7 +839,7 @@ subroutine get2d_hrldas(inflnm,ix,jx,nsoil,smc,stc,sh2ox,cmc,t1,weasd,snodep) #ifdef HYDRO_D write(6,*) "Error: failed to open file :",trim(inflnm) #endif - call hydro_stop() + call hydro_stop("get2d_hrldas") endif call get2d_hrldas_real("CMC", ncid, cmc, ix, jx) @@ -879,7 +897,7 @@ subroutine read_stage4(flnm,IX,JX,pcp) ierr = nf_open(flnm, NF_NOWRITE, ncid) if(ierr .ne. 0) then - call hydro_stop() + call hydro_stop("read_stage4") endif call get_2d_netcdf("RAINRATE",ncid, buf, units, ix, jx, .TRUE., ierr) @@ -898,11 +916,11 @@ END subroutine read_stage4 - subroutine read_seq_forcing( & + subroutine read_hydro_forcing_seq( & indir,olddate,hgrid, & ix,jx,forc_typ,snow_assim, & T2,q2x,u,v,pres,xlong,short,prcp1,& - weasd,snodep,dt,k,prcp0 ) + lai,fpar,snodep,dt,k,prcp_old) ! This subrouting is going to read different forcing. implicit none ! in variable @@ -911,10 +929,10 @@ subroutine read_seq_forcing( & integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& prcpnew,weasd,snodep,prcp0,prcp2,prcp_old - real :: dt + real :: dt, wrf_dt ! tmp variable character(len=256) :: inflnm, inflnm2, product - integer :: i,j,mmflag,igrid,ierr_flg + integer :: i,j,mmflag,ierr_flg real,dimension(ix,jx):: lai,fpar character(len=4) nwxst_t logical :: fexist @@ -936,7 +954,7 @@ subroutine read_seq_forcing( & #ifdef HYDRO_D print*, "no forcing data found", inflnm #endif - call hydro_stop() + call hydro_stop("read_hydro_forcing_seq") endif CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & @@ -957,7 +975,7 @@ subroutine read_seq_forcing( & #ifdef HYDRO_D print*, "no forcing data found", inflnm #endif - call hydro_stop() + call hydro_stop("read_hydro_forcing_seq") endif CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & PRES,XLONG,SHORT,PRCP1,LAI,FPAR) @@ -980,19 +998,34 @@ subroutine read_seq_forcing( & #ifdef HYDRO_D print*, "no forcing data found", inflnm #endif - call hydro_stop() + call hydro_stop("read_hydro_forcing_seq") endif - CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCPnew) - PRCP1=(PRCPnew-prcp0)/dt !Adjustment to convert accum to rate...(mm/s) + do i_forcing = 1, int(24*3600/dt) + wrf_dt = i_forcing*dt + call geth_newdate(out_date,olddate,nint(wrf_dt)) + inflnm2 = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& + "_"//out_date(12:13)//":00:00" + inquire (file=trim(inflnm2), exist=fexist) + if (fexist ) goto 991 + end do +991 continue -!added by Wei Yu - if(k.eq. 1) then - PRCP1 = 0 +#ifdef HYDRO_D + if(.not. fexist) then + write(6,*) "Error: could not find file ",trim(inflnm2) + call hydro_stop("read_hydro_forcing_seq") endif - prcp0 = PRCPnew -!end added + print*, "read WRF forcing data: ", trim(inflnm) + print*, "read WRF forcing data: ", trim(inflnm2) +#endif + CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCPnew,lai,fpar) + CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,prcp0,lai,fpar) + PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) end if @@ -1033,7 +1066,7 @@ subroutine read_seq_forcing( & !!!DJG Idealized Met. w/ Specified Precip. Forcing Data...(Note: input precip units here are in 'mm/hr') ! This option uses hard-wired met forcing EXCEPT precipitation which is read in -! from a single, separate input file called 'YYYYMMDDHHMM.LDASIN_PRECIP_DOMAIN' +! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' ! if(FORC_TYP.eq.5) then ! Standard Met. Vars... @@ -1051,32 +1084,14 @@ subroutine read_seq_forcing( & ! inflnm = trim(indir)//"/"//"sat_domain1.nc" !!Create forcing data filename... inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".LDASIN_PRECIP_DOMAIN"//hgrid - inquire (file=trim(inflnm), exist=fexist) - if ( .not. fexist ) then - inflnm = trim(indir)//"/"//& olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& olddate(15:16)//".PRECIP_FORCING.nc" - inquire (file=trim(inflnm), exist=fexist) - endif - if ( .not. fexist ) then - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//"00.PRECIP_FORCING.nc" - inquire (file=trim(inflnm), exist=fexist) - endif - if ( .not. fexist ) then - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - ".PRECIP_FORCING.nc" - inquire (file=trim(inflnm), exist=fexist) - endif + inquire (file=trim(inflnm), exist=fexist) if ( .not. fexist ) then #ifdef HYDRO_D - print*, "no forcing data found", inflnm + print*, "no specified precipitation data found", inflnm #endif - call hydro_stop() + call hydro_stop("read_hydro_forcing_seq") endif PRCP1 = 0. @@ -1125,7 +1140,7 @@ subroutine read_seq_forcing( & !!!DJG HRLDAS Forcing with hourly format filename with specified precipitation forcing... ! This option uses HRLDAS-formatted met forcing EXCEPT precipitation which is read in -! from a single, separate input file called 'YYYYMMDDHHMM.LDASIN_PRECIP_DOMAIN' +! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' if(FORC_TYP.eq.6) then @@ -1149,6 +1164,10 @@ subroutine read_seq_forcing( & print*, "no ATM forcing data found at this time", inflnm #endif else +#ifdef HYDRO_D + print*, "reading forcing data at this time", inflnm +#endif + CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & PRES,XLONG,SHORT,PRCP1,LAI,FPAR) PRCP_old = PRCP1 ! This assigns new precip to last precip as a fallback for missing data... @@ -1159,34 +1178,17 @@ subroutine read_seq_forcing( & !!!VIP, dimensions of grid are currently hardwired in input subroutine!!! !!Create forcing data filename... inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//"00.PRECIP_FORCING.nc" - inquire (file=trim(inflnm), exist=fexist) -#ifdef HYDRO_D - if(fexist) print*, "using pcp forcing: ",trim(inflnm) -#endif - if ( .not. fexist ) then - inflnm = trim(indir)//"/"//& olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& olddate(15:16)//".PRECIP_FORCING.nc" - inquire (file=trim(inflnm), exist=fexist) + inquire (file=trim(inflnm), exist=fexist) #ifdef HYDRO_D - if(fexist) print*, "using pcp forcing: ",trim(inflnm) -#endif + if(fexist) then + print*, "using specified pcp forcing: ",trim(inflnm) + else + print*, "no specified pcp forcing: ",trim(inflnm) endif - if ( .not. fexist ) then - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".LDASIN_PRECIP_DOMAIN"//hgrid - inquire (file=trim(inflnm), exist=fexist) -#ifdef HYDRO_D - if(fexist) print*, "using pcp forcing: ",trim(inflnm) #endif - endif if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no supplemental forcing data found ", trim(inflnm) -#endif prcp1 = PRCP_old ! for missing pcp data use analysis/model input else CALL READFORC_MDV(inflnm,IX,JX, & @@ -1202,23 +1204,116 @@ subroutine read_seq_forcing( & IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... PRCP1=PRCP2/DT !convert from mm to mm/s END IF ! Endif mmflag +#ifdef HYDRO_D print*, "replace pcp successfully! ",trim(inflnm) +#endif endif endif ! Loop through data to screen for plausible values where(PRCP1 .lt. 0) PRCP1=PRCP_old + where(PRCP1 .gt. 10 ) PRCP1= PRCP_old do i=1,ix do j=1,jx if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0 if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889 !set max pcp intens = 500 mm/h end do end do +! write(80,*) prcp1 +! call hydro_stop("9999") end if +!!!! FORC_TYP 7: uses WRF forcing data plus additional pcp forcing. + + if(FORC_TYP.eq.7) then + +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//& + "_"//olddate(12:13)//":00:00" + + inquire (file=trim(inflnm), exist=fexist) + + + if ( .not. fexist ) then +#ifdef HYDRO_D + print*, "no forcing data found", inflnm +#endif + else + do i_forcing = 1, int(24*3600/dt) + wrf_dt = i_forcing*dt + call geth_newdate(out_date,olddate,nint(wrf_dt)) + inflnm2 = trim(indir)//"/"//& + "wrfout_d0"//hgrid//"_"//& + out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& + "_"//out_date(12:13)//":00:00" + inquire (file=trim(inflnm2), exist=fexist) + if (fexist ) goto 992 + end do +992 continue + +#ifdef HYDRO_D + print*, "read WRF forcing data: ", trim(inflnm) + print*, "read WRF forcing data: ", trim(inflnm2) +#endif + CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,PRCPnew,lai,fpar) + CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & + PRES,XLONG,SHORT,prcp0,lai,fpar) + PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) + PRCP_old = PRCP1 + endif + +!Get specified precip.... +!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! +!!Create forcing data filename... + inflnm = trim(indir)//"/"//& + olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& + olddate(15:16)//".PRECIP_FORCING.nc" + inquire (file=trim(inflnm), exist=fexist) +#ifdef HYDRO_D + if(fexist) then + print*, "using specified pcp forcing: ",trim(inflnm) + else + print*, "no specified pcp forcing: ",trim(inflnm) + endif +#endif + if ( .not. fexist ) then + prcp1 = PRCP_old ! for missing pcp data use analysis/model input + else + CALL READFORC_MDV(inflnm,IX,JX, & + PRCP2,mmflag,ierr_flg) +!If radar or spec. data is ok use if not, skip to original NARR data... + if(ierr_flg .ne. 0) then +#ifdef HYDRO_D + print*, "Warning: pcp reading problem: ", trim(inflnm) +#endif + PRCP1=PRCP_old + else + PRCP1=PRCP2 !assumes PRCP2 is in mm/s + IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... + write(6,*) "using supplemental pcp time interval ", DT + PRCP1=PRCP2/DT !convert from mm to mm/s + else + write(6,*) "using supplemental pcp rates " + END IF ! Endif mmflag +#ifdef HYDRO_D + print*, "replace pcp successfully! ",trim(inflnm) +#endif + endif + endif + + +! Loop through data to screen for plausible values + where(PRCP1 .lt. 0) PRCP1=PRCP_old + where(PRCP1 .gt. 10 ) PRCP1= PRCP_old ! set maximum to be 500 mm/h + where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h + end if + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!The other forcing data types below here are obsolete and left for reference... !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -1537,7 +1632,7 @@ subroutine read_seq_forcing( & end if - end subroutine read_seq_forcing + end subroutine read_hydro_forcing_seq #ifdef MPP_LAND @@ -1639,35 +1734,30 @@ subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& end subroutine MPP_DEEPGW_HRLDAS - subroutine mpp_read_forcing( & - indir,olddate,startdate,hgrid, & + subroutine read_hydro_forcing_mpp( & + indir,olddate,hgrid, & ix,jx,forc_typ,snow_assim, & T2,q2x,u,v,pres,xlong,short,prcp1,& - weasd,snodep,dt,k,g_ix,g_jx,igrid,prcp0) + lai,fpar,snodep,dt,k,prcp_old) ! This subrouting is going to read different forcing. implicit none ! in variable - character(len=*) :: olddate,hgrid,indir,startdate + character(len=*) :: olddate,hgrid,indir character(len=256) :: filename - integer :: ix,jx,forc_typ,k,snow_assim,igrid ! k is time loop + integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& - prcpnew,weasd,snodep,prcp0 + prcpnew,lai,fpar,snodep,prcp_old real :: dt ! tmp variable character(len=256) :: inflnm, product - integer :: i,j,mmflag, g_ix,g_jx - real,dimension(ix,jx):: lai,fpar - real,dimension(g_ix,g_jx):: g_T2,g_Q2X,g_U,g_V,g_XLONG, & - g_SHORT,g_PRCP1,g_PRES,g_weasd,g_snodep,g_prcp0 + integer :: i,j,mmflag + real,dimension(global_nx,global_ny):: g_T2,g_Q2X,g_U,g_V,g_XLONG, & + g_SHORT,g_PRCP1,g_PRES,g_lai,g_snodep,g_prcp_old, g_fpar integer flag - if(forc_typ .eq. 2) then - call write_io_real(prcp0,g_prcp0) - endif - if(forc_typ .eq. 6 .OR. forc_typ .eq. 11) then ! DJG (6-Spec. precip., 11-DESWAT) call write_io_real(T2,g_T2) call write_io_real(Q2X,g_Q2X) @@ -1677,20 +1767,25 @@ subroutine mpp_read_forcing( & call write_io_real(SHORT,g_SHORT) call write_io_real(PRCP1,g_PRCP1) call write_io_real(PRES,g_PRES) + call write_io_real(prcp_old,g_PRCP_old) + + call write_io_real(lai,g_lai) + call write_io_real(fpar,g_fpar) + call write_io_real(snodep,g_snodep) - end if if(my_id .eq. IO_id) then - call read_seq_forcing( & + call read_hydro_forcing_seq( & indir,olddate,hgrid,& global_nx,global_ny,forc_typ,snow_assim, & g_T2,g_q2x,g_u,g_v,g_pres,g_xlong,g_short,g_prcp1,& - g_weasd,g_snodep,dt,k,g_prcp0 ) + g_lai,g_fpar,g_snodep,dt,k,g_prcp_old) #ifdef HYDRO_D - write(6,*) "finish read forcing,startdate,olddate ",startdate,olddate + write(6,*) "finish read forcing,olddate ",olddate #endif end if + call decompose_data_real(g_T2,T2) call decompose_data_real(g_Q2X,Q2X) call decompose_data_real(g_U,U) @@ -1698,24 +1793,484 @@ subroutine mpp_read_forcing( & call decompose_data_real(g_XLONG,XLONG) call decompose_data_real(g_SHORT,SHORT) call decompose_data_real(g_PRCP1,PRCP1) + call decompose_data_real(g_prcp_old,prcp_old) call decompose_data_real(g_PRES,PRES) - if(forc_typ .eq. 3 .or. forc_typ .eq. 6 .and. snow_assim .eq. 1) then - call decompose_data_real(g_weasd,weasd) - call decompose_data_real(g_snodep,snodep) - else - flag = -1 - if( my_id.eq.IO_id) then - if(OLDDATE(12:16) == "00:00") flag = 99 - end if - call mpp_land_bcast_int1(flag) - if(flag .eq. 99 .and. snow_assim .eq. 1) then - call decompose_data_real(g_weasd,weasd) - call decompose_data_real(g_snodep,snodep) - endif - endif - return - end subroutine mpp_read_forcing + call decompose_data_real(g_lai,lai) + call decompose_data_real(g_fpar,fpar) + call decompose_data_real(g_snodep,snodep) + + return + end subroutine read_hydro_forcing_mpp +#endif + + integer function nfeb_yw(year) + ! + ! Compute the number of days in February for the given year. + ! + implicit none + integer, intent(in) :: year ! Four-digit year + + nfeb_yw = 28 ! By default, February has 28 days ... + if (mod(year,4).eq.0) then + nfeb_yw = 29 ! But every four years, it has 29 days ... + if (mod(year,100).eq.0) then + nfeb_yw = 28 ! Except every 100 years, when it has 28 days ... + if (mod(year,400).eq.0) then + nfeb_yw = 29 ! Except every 400 years, when it has 29 days ... + if (mod(year,3600).eq.0) then + nfeb_yw = 28 ! Except every 3600 years, when it has 28 days. + endif + endif + endif + endif + end function nfeb_yw + + subroutine geth_newdate (ndate, odate, idt) + implicit none + + ! From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and + ! delta-time, compute the new date. + + ! on entry - odate - the old hdate. + ! idt - the change in time + + ! on exit - ndate - the new hdate. + + integer, intent(in) :: idt + character (len=*), intent(out) :: ndate + character (len=*), intent(in) :: odate + + ! Local Variables + + ! yrold - indicates the year associated with "odate" + ! moold - indicates the month associated with "odate" + ! dyold - indicates the day associated with "odate" + ! hrold - indicates the hour associated with "odate" + ! miold - indicates the minute associated with "odate" + ! scold - indicates the second associated with "odate" + + ! yrnew - indicates the year associated with "ndate" + ! monew - indicates the month associated with "ndate" + ! dynew - indicates the day associated with "ndate" + ! hrnew - indicates the hour associated with "ndate" + ! minew - indicates the minute associated with "ndate" + ! scnew - indicates the second associated with "ndate" + + ! mday - a list assigning the number of days in each month + + ! i - loop counter + ! nday - the integer number of days represented by "idt" + ! nhour - the integer number of hours in "idt" after taking out + ! all the whole days + ! nmin - the integer number of minutes in "idt" after taking out + ! all the whole days and whole hours. + ! nsec - the integer number of minutes in "idt" after taking out + ! all the whole days, whole hours, and whole minutes. + + integer :: newlen, oldlen + integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew + integer :: yrold, moold, dyold, hrold, miold, scold, frold + integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc + logical :: opass + character (len=10) :: hfrc + character (len=1) :: sp + logical :: punct + integer :: yrstart, yrend, mostart, moend, dystart, dyend + integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart + integer :: units + integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) +!yw integer nfeb_yw + + ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...." + if (odate(5:5) == "-") then + punct = .TRUE. + else + punct = .FALSE. + endif + + ! Break down old hdate into parts + + hrold = 0 + miold = 0 + scold = 0 + frold = 0 + oldlen = LEN(odate) + if (punct) then + yrstart = 1 + yrend = 4 + mostart = 6 + moend = 7 + dystart = 9 + dyend = 10 + hrstart = 12 + hrend = 13 + mistart = 15 + miend = 16 + scstart = 18 + scend = 19 + frstart = 21 + select case (oldlen) + case (10) + ! Days + units = 1 + case (13) + ! Hours + units = 2 + case (16) + ! Minutes + units = 3 + case (19) + ! Seconds + units = 4 + case (21) + ! Tenths + units = 5 + case (22) + ! Hundredths + units = 6 + case (23) + ! Thousandths + units = 7 + case (24) + ! Ten thousandths + units = 8 + case default +#ifdef HYDRO_D + write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' + call hydro_stop("in geth_newdate") +#endif + end select + + if (oldlen.ge.11) then + sp = odate(11:11) + else + sp = ' ' + end if + + else + + yrstart = 1 + yrend = 4 + mostart = 5 + moend = 6 + dystart = 7 + dyend = 8 + hrstart = 9 + hrend = 10 + mistart = 11 + miend = 12 + scstart = 13 + scend = 14 + frstart = 15 + + select case (oldlen) + case (8) + ! Days + units = 1 + case (10) + ! Hours + units = 2 + case (12) + ! Minutes + units = 3 + case (14) + ! Seconds + units = 4 + case (15) + ! Tenths + units = 5 + case (16) + ! Hundredths + units = 6 + case (17) + ! Thousandths + units = 7 + case (18) + ! Ten thousandths + units = 8 + case default +#ifdef HYDRO_D + write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' + call hydro_stop("in geth_newdate") +#endif + end select + endif + + ! Use internal READ statements to convert the CHARACTER string + ! date into INTEGER components. + + read(odate(yrstart:yrend), '(i4)') yrold + read(odate(mostart:moend), '(i2)') moold + read(odate(dystart:dyend), '(i2)') dyold + if (units.ge.2) then + read(odate(hrstart:hrend),'(i2)') hrold + if (units.ge.3) then + read(odate(mistart:miend),'(i2)') miold + if (units.ge.4) then + read(odate(scstart:scend),'(i2)') scold + if (units.ge.5) then + read(odate(frstart:oldlen),*) frold + end if + end if + end if + end if + + ! Set the number of days in February for that year. + + mday(2) = nfeb_yw(yrold) + + ! Check that ODATE makes sense. + + opass = .TRUE. + + ! Check that the month of ODATE makes sense. + + if ((moold.gt.12).or.(moold.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold +#endif + opass = .FALSE. + end if + + ! Check that the day of ODATE makes sense. + + if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold #endif + opass = .FALSE. + end if + + ! Check that the hour of ODATE makes sense. + + if ((hrold.gt.23).or.(hrold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold +#endif + opass = .FALSE. + end if + + ! Check that the minute of ODATE makes sense. + + if ((miold.gt.59).or.(miold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold +#endif + opass = .FALSE. + end if + + ! Check that the second of ODATE makes sense. + + if ((scold.gt.59).or.(scold.lt.0)) then +#ifdef HYDRO_D + write(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold +#endif + opass = .FALSE. + end if + + ! Check that the fractional part of ODATE makes sense. + if (.not.opass) then +#ifdef HYDRO_D + write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen + call hydro_stop("in geth_newdate") +#endif + end if + + ! Date Checks are completed. Continue. + + + ! Compute the number of days, hours, minutes, and seconds in idt + + if (units.ge.5) then !idt should be in fractions of seconds + ifrc = oldlen-(frstart)+1 + ifrc = 10**ifrc + nday = abs(idt)/(86400*ifrc) + nhour = mod(abs(idt),86400*ifrc)/(3600*ifrc) + nmin = mod(abs(idt),3600*ifrc)/(60*ifrc) + nsec = mod(abs(idt),60*ifrc)/(ifrc) + nfrac = mod(abs(idt), ifrc) + else if (units.eq.4) then !idt should be in seconds + ifrc = 1 + nday = abs(idt)/86400 ! integer number of days in delta-time + nhour = mod(abs(idt),86400)/3600 + nmin = mod(abs(idt),3600)/60 + nsec = mod(abs(idt),60) + nfrac = 0 + else if (units.eq.3) then !idt should be in minutes + ifrc = 1 + nday = abs(idt)/1440 ! integer number of days in delta-time + nhour = mod(abs(idt),1440)/60 + nmin = mod(abs(idt),60) + nsec = 0 + nfrac = 0 + else if (units.eq.2) then !idt should be in hours + ifrc = 1 + nday = abs(idt)/24 ! integer number of days in delta-time + nhour = mod(abs(idt),24) + nmin = 0 + nsec = 0 + nfrac = 0 + else if (units.eq.1) then !idt should be in days + ifrc = 1 + nday = abs(idt) ! integer number of days in delta-time + nhour = 0 + nmin = 0 + nsec = 0 + nfrac = 0 + else +#ifdef HYDRO_D + write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & + oldlen + write(*,*) '#'//odate(1:oldlen)//'#' + call hydro_stop("in geth_newdate") +#endif + end if + + if (idt.ge.0) then + + frnew = frold + nfrac + if (frnew.ge.ifrc) then + frnew = frnew - ifrc + nsec = nsec + 1 + end if + + scnew = scold + nsec + if (scnew .ge. 60) then + scnew = scnew - 60 + nmin = nmin + 1 + end if + + minew = miold + nmin + if (minew .ge. 60) then + minew = minew - 60 + nhour = nhour + 1 + end if + + hrnew = hrold + nhour + if (hrnew .ge. 24) then + hrnew = hrnew - 24 + nday = nday + 1 + end if + + dynew = dyold + monew = moold + yrnew = yrold + do i = 1, nday + dynew = dynew + 1 + if (dynew.gt.mday(monew)) then + dynew = dynew - mday(monew) + monew = monew + 1 + if (monew .gt. 12) then + monew = 1 + yrnew = yrnew + 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb_yw(yrnew) + end if + end if + end do + + else if (idt.lt.0) then + + frnew = frold - nfrac + if (frnew .lt. 0) then + frnew = frnew + ifrc + nsec = nsec + 1 + end if + + scnew = scold - nsec + if (scnew .lt. 00) then + scnew = scnew + 60 + nmin = nmin + 1 + end if + + minew = miold - nmin + if (minew .lt. 00) then + minew = minew + 60 + nhour = nhour + 1 + end if + + hrnew = hrold - nhour + if (hrnew .lt. 00) then + hrnew = hrnew + 24 + nday = nday + 1 + end if + + dynew = dyold + monew = moold + yrnew = yrold + do i = 1, nday + dynew = dynew - 1 + if (dynew.eq.0) then + monew = monew - 1 + if (monew.eq.0) then + monew = 12 + yrnew = yrnew - 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb_yw(yrnew) + end if + dynew = mday(monew) + end if + end do + end if + + ! Now construct the new mdate + + newlen = LEN(ndate) + + if (punct) then + + if (newlen.gt.frstart) then + write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew + write(hfrc,'(i10)') frnew+1000000000 + ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + + else if (newlen.eq.scend) then + write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew +19 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2) + + else if (newlen.eq.miend) then + write(ndate,16) yrnew, monew, dynew, hrnew, minew +16 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2) + + else if (newlen.eq.hrend) then + write(ndate,13) yrnew, monew, dynew, hrnew +13 format(i4,'-',i2.2,'-',i2.2,'_',i2.2) + + else if (newlen.eq.dyend) then + write(ndate,10) yrnew, monew, dynew +10 format(i4,'-',i2.2,'-',i2.2) + + end if + + else + + if (newlen.gt.frstart) then + write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew + write(hfrc,'(i10)') frnew+1000000000 + ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) + + else if (newlen.eq.scend) then + write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew +119 format(i4,i2.2,i2.2,i2.2,i2.2,i2.2) + + else if (newlen.eq.miend) then + write(ndate,116) yrnew, monew, dynew, hrnew, minew +116 format(i4,i2.2,i2.2,i2.2,i2.2) + + else if (newlen.eq.hrend) then + write(ndate,113) yrnew, monew, dynew, hrnew +113 format(i4,i2.2,i2.2,i2.2) + + else if (newlen.eq.dyend) then + write(ndate,110) yrnew, monew, dynew +110 format(i4,i2.2,i2.2) + + end if + + endif + + if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp + end subroutine geth_newdate end module module_lsm_forcing diff --git a/wrfv2_fire/hydro/Run/.svn/all-wcprops b/wrfv2_fire/hydro/Run/.svn/all-wcprops new file mode 100644 index 00000000..83be28c2 --- /dev/null +++ b/wrfv2_fire/hydro/Run/.svn/all-wcprops @@ -0,0 +1,17 @@ +K 25 +svn:wc:ra_dav:version-url +V 56 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Run +END +hydro.namelist +K 25 +svn:wc:ra_dav:version-url +V 71 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Run/hydro.namelist +END +HYDRO.TBL +K 25 +svn:wc:ra_dav:version-url +V 66 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Run/HYDRO.TBL +END diff --git a/wrfv2_fire/hydro/Run/.svn/entries b/wrfv2_fire/hydro/Run/.svn/entries new file mode 100644 index 00000000..253741b0 --- /dev/null +++ b/wrfv2_fire/hydro/Run/.svn/entries @@ -0,0 +1,96 @@ +10 + +dir +9105 +https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/Run +https://kkeene@svn-wrf-model.cgd.ucar.edu + + + +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + +b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d + +hydro.namelist +file + + + + +2016-02-11T20:37:50.230193Z +57b60e98bf800551790f4a412231f488 +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +3436 + +HYDRO.TBL +file + + + + +2016-02-11T20:37:50.231253Z +f265ac087359e672e926e2334ca5fc38 +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +2199 + diff --git a/wrfv2_fire/hydro/Run/.svn/text-base/HYDRO.TBL.svn-base b/wrfv2_fire/hydro/Run/.svn/text-base/HYDRO.TBL.svn-base new file mode 100644 index 00000000..1d691a08 --- /dev/null +++ b/wrfv2_fire/hydro/Run/.svn/text-base/HYDRO.TBL.svn-base @@ -0,0 +1,51 @@ + 28 USGS for OV_ROUGH + SFC_ROUGH' + 0.025, 'Urban and Built-Up Land' + 0.035, 'Dryland Cropland and Pasture' + 0.035, 'Irrigated Cropland and Pasture' + 0.055, 'Mixed Dryland/Irrigated Cropland and Pasture' + 0.035, 'Cropland/Grassland Mosaic' + 0.068, 'Cropland/Woodland Mosaic' + 0.055, 'Grassland' + 0.055, 'Shrubland' + 0.055, 'Mixed Shrubland/Grassland' + 0.055, 'Savanna' + 0.200, 'Deciduous Broadleaf Forest' + 0.200, 'Deciduous Needleleaf Forest' + 0.200, 'Evergreen Broadleaf Forest' + 0.200, 'Evergreen Needleleaf Forest' + 0.200, 'Mixed Forest' + 0.005, 'Water Bodies' + 0.070, 'Herbaceous Wetland' + 0.070, 'Wooded Wetland' + 0.035, 'Barren or Sparsely Vegetated' + 0.055, 'Herbaceous Tundra' + 0.055, 'Wooded Tundra' + 0.055, 'Mixed Tundra' + 0.055, 'Bare Ground Tundra' + 0.010, 'Snow or Ice' + 0.010, 'Playa' + 0.100, 'Lava' + 0.010, 'White Sand' + 0.005, 'Non-Ocean Water Bodies' +19, for SATDK +SATDK MAXSMC REFSMC WLTSMC QTZ ' +1.07E-6, 0.339, 0.236, 0.010, 0.92, 'SAND' +1.41E-5, 0.421, 0.383, 0.028, 0.82, 'LOAMY SAND' +5.23E-6, 0.434, 0.383, 0.047, 0.60, 'SANDY LOAM' +2.81E-6, 0.476, 0.360, 0.084, 0.25, 'SILT LOAM' +2.81E-6, 0.476, 0.383, 0.084, 0.10, 'SILT' +3.38E-6, 0.439, 0.329, 0.066, 0.40, 'LOAM' +4.45E-6, 0.404, 0.314, 0.067, 0.60, 'SANDY CLAY LOAM' +2.04E-6, 0.464, 0.387, 0.120, 0.10, 'SILTY CLAY LOAM' +2.45E-6, 0.465, 0.382, 0.103, 0.35, 'CLAY LOAM' +7.22E-6, 0.406, 0.338, 0.100, 0.52, 'SANDY CLAY' +1.34E-6, 0.468, 0.404, 0.126, 0.10, 'SILTY CLAY' +9.74E-7, 0.468, 0.412, 0.138, 0.25, 'CLAY' +3.38E-6, 0.439, 0.329, 0.066, 0.05, 'ORGANIC MATERIAL' + 0.0, 1.0, 0.0, 0.0, 0.60, 'WATER' +1.75E-5, 0.20, 0.170, 0.006, 0.07, 'BEDROCK' +1.41E-5, 0.421, 0.283, 0.028, 0.25, 'OTHER(land-ice)' +9.74E-7, 0.468, 0.454, 0.030, 0.60, 'PLAYA' +1.41E-4, 0.200, 0.170, 0.006, 0.52, 'LAVA' +1.07E-6, 0.339, 0.236, 0.01, 0.92, 'WHITE SAND' diff --git a/wrfv2_fire/hydro/Run/.svn/text-base/hydro.namelist.svn-base b/wrfv2_fire/hydro/Run/.svn/text-base/hydro.namelist.svn-base new file mode 100644 index 00000000..f47b80a1 --- /dev/null +++ b/wrfv2_fire/hydro/Run/.svn/text-base/hydro.namelist.svn-base @@ -0,0 +1,105 @@ +&HYDRO_nlist + +!!!! SYSTEM COUPLING !!!! +!Specify what is being coupled: 1=HRLDAS (offline Noah-LSM), 2=WRF, 3=NASA/LIS, 4=CLM + sys_cpl = 2 + + + +!!!! MODEL INPUT DATA FILES !!! +!Specify land surface model gridded input data file...(e.g.: "geo_em.d03.nc") + GEO_STATIC_FLNM = "DOMAIN/geo_em.d03.nc" + +!Specify the high-resolution routing terrain input data file...(e.g.: "Fulldom_hires_hydrofile.nc" + GEO_FINEGRID_FLNM = "DOMAIN/Fulldom_hires_hydrofile_ohd_new_basns_w_cal_params_full_domain.nc" + +!Specify the name of the restart file if starting from restart...comment out with '!' if not... +! RESTART_FILE = 'HYDRO_RST.2012-07-21_12:00_DOMAIN2' + + + +!!!! MODEL SETUP AND I/O CONTROL !!!! +!Specify the domain or nest number identifier...(integer) + IGRID = 3 + +!Specify the restart file write frequency...(minutes) + !rst_dt = 360 + rst_dt = 30 + +!Specify the output file write frequency...(minutes) + out_dt = 15 ! minutes + +!Specify if output history files are to be written...(.TRUE. or .FALSE.) + HISTORY_OUTPUT = .TRUE. + +!Specify the number of output times to be contained within each output history file...(integer) +! SET = 1 WHEN RUNNING CHANNEL ROUTING ONLY/CALIBRATION SIMS!!! +! SET = 1 WHEN RUNNING COUPLED TO WRF!!! + SPLIT_OUTPUT_COUNT = 1 + +! rst_typ = 1 : overwrite the soil variables from routing restart file. + rst_typ = 0 + +!Restart switch to set restart accumulation variables = 0 (0-no reset, 1-yes reset to 0.0) + RSTRT_SWC = 0 + +!Output high-resolution routing files...0=none, 1=total chan_inflow ASCII time-series, 2=hires grid and chan_inflow... + HIRES_OUT = 2 + +!Specify the minimum stream order to output to netcdf point file...(integer) +!Note: lower value of stream order produces more output. + order_to_write = 1 + + + +!!!! PHYSICS OPTIONS AND RELATED SETTINGS !!!! +!Switch for terrain adjustment of incoming solar radiation: 0=no, 1=yes +!Note: This option is not yet active in Verion 1.0... +! WRF has this capability so be careful not to double apply the correction!!! + TERADJ_SOLAR = 0 + +!Specify the number of soil layers (integer) and the depth of the bottom of each layer (meters)... +! Notes: In Version 1 of WRF-Hydro these must be the same as in the namelist.input file +! Future versions will permit this to be different. + NSOIL=4 + ZSOIL8(1) = -0.10 + ZSOIL8(2) = -0.40 + ZSOIL8(3) = -1.0 + ZSOIL8(4) = -2.0 + +!Specify the grid spacing of the terrain routing grid...(meters) + DXRT = 100 + +!Specify the integer multiple between the land model grid and the terrain routing grid...(integer) + AGGFACTRT = 10 + +!Specify the routing model timestep...(seconds) + DTRT = 2 + +!Switch activate subsurface routing...(0=no, 1=yes) + SUBRTSWCRT = 1 + +!Switch activate surface overland flow routing...(0=no, 1=yes) + OVRTSWCRT = 1 + +!Switch to activate channel routing Routing Option: 1=Seepest Descent (D8) 2=CASC2D + rt_option = 1 + CHANRTSWCRT = 0 + +!Specify channel routing option: 1=Muskingam-reach, 2=Musk.-Cunge-reach, 3=Diff.Wave-gridded + channel_option =3 + +!Specify the reach file for reach-based routing options... + route_link_f = "" + +!Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through) + GWBASESWCRT = 2 + +!Specify baseflow/bucket model initialization...(0=cold start from table, 1=restart file) + GW_RESTART = 0 + +!Groundwater/baseflow mask specified on land surface model grid... +!Note: Only required if baseflow bucket model is active + gwbasmskfil = "DOMAIN/basn_msk1k_frng_ohd.txt" + +/ diff --git a/wrfv2_fire/hydro/Run/HYDRO.TBL b/wrfv2_fire/hydro/Run/HYDRO.TBL index 1de05f57..1d691a08 100644 --- a/wrfv2_fire/hydro/Run/HYDRO.TBL +++ b/wrfv2_fire/hydro/Run/HYDRO.TBL @@ -1,4 +1,4 @@ - 27 USGS for OV_ROUGH + 28 USGS for OV_ROUGH SFC_ROUGH' 0.025, 'Urban and Built-Up Land' 0.035, 'Dryland Cropland and Pasture' @@ -27,6 +27,7 @@ 0.010, 'Playa' 0.100, 'Lava' 0.010, 'White Sand' + 0.005, 'Non-Ocean Water Bodies' 19, for SATDK SATDK MAXSMC REFSMC WLTSMC QTZ ' 1.07E-6, 0.339, 0.236, 0.010, 0.92, 'SAND' @@ -43,7 +44,7 @@ SATDK MAXSMC REFSMC WLTSMC QTZ ' 9.74E-7, 0.468, 0.412, 0.138, 0.25, 'CLAY' 3.38E-6, 0.439, 0.329, 0.066, 0.05, 'ORGANIC MATERIAL' 0.0, 1.0, 0.0, 0.0, 0.60, 'WATER' -1.41E-4, 0.20, 0.170, 0.006, 0.07, 'BEDROCK' +1.75E-5, 0.20, 0.170, 0.006, 0.07, 'BEDROCK' 1.41E-5, 0.421, 0.283, 0.028, 0.25, 'OTHER(land-ice)' 9.74E-7, 0.468, 0.454, 0.030, 0.60, 'PLAYA' 1.41E-4, 0.200, 0.170, 0.006, 0.52, 'LAVA' diff --git a/wrfv2_fire/hydro/Run/hydro.namelist b/wrfv2_fire/hydro/Run/hydro.namelist index df5e19dc..f47b80a1 100644 --- a/wrfv2_fire/hydro/Run/hydro.namelist +++ b/wrfv2_fire/hydro/Run/hydro.namelist @@ -8,25 +8,26 @@ !!!! MODEL INPUT DATA FILES !!! !Specify land surface model gridded input data file...(e.g.: "geo_em.d03.nc") - GEO_STATIC_FLNM = "RT/geo_em.d03.nc" + GEO_STATIC_FLNM = "DOMAIN/geo_em.d03.nc" !Specify the high-resolution routing terrain input data file...(e.g.: "Fulldom_hires_hydrofile.nc" - GEO_FINEGRID_FLNM = "/d1/gochis/NDHMS/terrain/FRNG/Fulldom_hires_hydrofile_ohd_new_basns_w_cal_params_full_domain.nc" + GEO_FINEGRID_FLNM = "DOMAIN/Fulldom_hires_hydrofile_ohd_new_basns_w_cal_params_full_domain.nc" !Specify the name of the restart file if starting from restart...comment out with '!' if not... - RESTART_FILE = 'HYDRO_RST.2010-10-01_06:00_DOMAIN2' +! RESTART_FILE = 'HYDRO_RST.2012-07-21_12:00_DOMAIN2' !!!! MODEL SETUP AND I/O CONTROL !!!! !Specify the domain or nest number identifier...(integer) - IGRID = 2 + IGRID = 3 !Specify the restart file write frequency...(minutes) - rst_dt = 60 + !rst_dt = 360 + rst_dt = 30 !Specify the output file write frequency...(minutes) - out_dt = 60 ! minutes + out_dt = 15 ! minutes !Specify if output history files are to be written...(.TRUE. or .FALSE.) HISTORY_OUTPUT = .TRUE. @@ -37,7 +38,7 @@ SPLIT_OUTPUT_COUNT = 1 ! rst_typ = 1 : overwrite the soil variables from routing restart file. - rst_typ = 1 + rst_typ = 0 !Restart switch to set restart accumulation variables = 0 (0-no reset, 1-yes reset to 0.0) RSTRT_SWC = 0 @@ -47,7 +48,7 @@ !Specify the minimum stream order to output to netcdf point file...(integer) !Note: lower value of stream order produces more output. - order_to_write = 2 + order_to_write = 1 @@ -61,10 +62,10 @@ ! Notes: In Version 1 of WRF-Hydro these must be the same as in the namelist.input file ! Future versions will permit this to be different. NSOIL=4 - ZSOIL8(1) = -0.05 - ZSOIL8(2) = -0.25 - ZSOIL8(3) = -0.70 - ZSOIL8(4) = -1.5 + ZSOIL8(1) = -0.10 + ZSOIL8(2) = -0.40 + ZSOIL8(3) = -1.0 + ZSOIL8(4) = -2.0 !Specify the grid spacing of the terrain routing grid...(meters) DXRT = 100 @@ -73,7 +74,7 @@ AGGFACTRT = 10 !Specify the routing model timestep...(seconds) - DTRT = 10 + DTRT = 2 !Switch activate subsurface routing...(0=no, 1=yes) SUBRTSWCRT = 1 @@ -83,7 +84,7 @@ !Switch to activate channel routing Routing Option: 1=Seepest Descent (D8) 2=CASC2D rt_option = 1 - CHANRTSWCRT = 1 + CHANRTSWCRT = 0 !Specify channel routing option: 1=Muskingam-reach, 2=Musk.-Cunge-reach, 3=Diff.Wave-gridded channel_option =3 @@ -92,13 +93,13 @@ route_link_f = "" !Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through) - GWBASESWCRT = 1 + GWBASESWCRT = 2 !Specify baseflow/bucket model initialization...(0=cold start from table, 1=restart file) - GW_RESTART = 1 + GW_RESTART = 0 !Groundwater/baseflow mask specified on land surface model grid... !Note: Only required if baseflow bucket model is active - gwbasmskfil = "RT/basn_msk1k_frng_ohd.txt" + gwbasmskfil = "DOMAIN/basn_msk1k_frng_ohd.txt" / diff --git a/wrfv2_fire/hydro/arc/.svn/all-wcprops b/wrfv2_fire/hydro/arc/.svn/all-wcprops new file mode 100644 index 00000000..701f4568 --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/all-wcprops @@ -0,0 +1,65 @@ +K 25 +svn:wc:ra_dav:version-url +V 56 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc +END +macros.mpp.gfort +K 25 +svn:wc:ra_dav:version-url +V 73 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.mpp.gfort +END +macros.mpp.ifort +K 25 +svn:wc:ra_dav:version-url +V 73 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.mpp.ifort +END +macros.seq.IBM.xlf90_r +K 25 +svn:wc:ra_dav:version-url +V 79 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.seq.IBM.xlf90_r +END +Makefile.seq +K 25 +svn:wc:ra_dav:version-url +V 69 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/Makefile.seq +END +macros.mpp.IBM.xlf90_r +K 25 +svn:wc:ra_dav:version-url +V 79 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.mpp.IBM.xlf90_r +END +Makefile.mpp +K 25 +svn:wc:ra_dav:version-url +V 69 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/Makefile.mpp +END +macros.seq.linux +K 25 +svn:wc:ra_dav:version-url +V 73 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.seq.linux +END +macros.seq.gfort +K 25 +svn:wc:ra_dav:version-url +V 73 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.seq.gfort +END +macros.mpp.linux +K 25 +svn:wc:ra_dav:version-url +V 73 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.mpp.linux +END +macros.seq.ifort +K 25 +svn:wc:ra_dav:version-url +V 73 +/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.seq.ifort +END diff --git a/wrfv2_fire/hydro/arc/.svn/entries b/wrfv2_fire/hydro/arc/.svn/entries new file mode 100644 index 00000000..5affc035 --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/entries @@ -0,0 +1,368 @@ +10 + +dir +9105 +https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/arc +https://kkeene@svn-wrf-model.cgd.ucar.edu + + + +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + +b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d + +macros.mpp.gfort +file + + + + +2016-02-11T20:37:49.552475Z +12187f1c1835a25d489f0bcad4f1ee8e +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +838 + +macros.mpp.ifort +file + + + + +2016-02-11T20:37:49.553462Z +6229cf85e23f4eda91a9502670a678df +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +859 + +macros.seq.IBM.xlf90_r +file + + + + +2016-02-11T20:37:49.554415Z +607dbe92225a1bfab2525e3fa7d8cea1 +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +742 + +Makefile.seq +file + + + + +2016-02-11T20:37:49.556507Z +4aa282f0ae08c6c65705d144cec193b1 +2013-11-15T19:40:36.446206Z +6964 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +571 + +macros.mpp.IBM.xlf90_r +file + + + + +2016-02-11T20:37:49.557348Z +9bfc47c368eb915db5e270025d090330 +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +827 + +Makefile.mpp +file + + + + +2016-02-11T20:37:49.559360Z +fa1ab651d6e2cc9a6aceb458ddc975a6 +2013-11-15T19:40:36.446206Z +6964 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +411 + +macros.seq.linux +file + + + + +2016-02-11T20:37:49.560391Z +545de223d8fe266c3a91fc9365039860 +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +797 + +macros.seq.gfort +file + + + + +2016-02-11T20:37:49.549654Z +47acd877f54da658b716de60139e7fcb +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +800 + +macros.mpp.linux +file + + + + +2016-02-11T20:37:49.550613Z +83a02ae424831fbb8e57ea790c35fbed +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +783 + +macros.seq.ifort +file + + + + +2016-02-11T20:37:49.551534Z +0b7e9fe9a50eb39e6232d3a58e427c62 +2014-12-05T18:15:21.639800Z +7824 +weiyu@ucar.edu + + + + + + + + + + + + + + + + + + + + + +876 + diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.mpp.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.mpp.svn-base new file mode 100644 index 00000000..a494e8df --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.mpp.svn-base @@ -0,0 +1,17 @@ +# Makefile + +all: + (make -f Makefile.comm BASIC) + +BASIC: + (cd MPP ; make -f Makefile) + (cd Data_Rec ; make -f Makefile) + (cd Routing; make -f Makefile) + (cd HYDRO_drv; make -f Makefile) + +clean: + (cd Data_Rec; make -f Makefile clean) + (cd HYDRO_drv; make -f Makefile clean) + (cd MPP; make -f Makefile clean) + (cd Routing; make -f Makefile clean) + (rm -f lib/*.a */*.mod */*.o CPL/*/*.o CPL/*/*.mod) diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.seq.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.seq.svn-base new file mode 100644 index 00000000..14d8a260 --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.seq.svn-base @@ -0,0 +1,30 @@ +# Makefile + +all: + (make -f Makefile BASIC) + +BASIC: + (cd Data_Rec ; make -f Makefile) + (cd Routing; make -f Makefile) + (cd HYDRO_drv; make -f Makefile) + +LIS: + (make -f Makefile BASIC) + (cd LIS_cpl ; make -f Makefile) + +CLM: + (make -f Makefile BASIC) + (cd CLM_cpl ; make -f Makefile) + +WRF: + (make -f Makefile BASIC) + (cd WRF_cpl ; make -f Makefile) + +HYDRO: + (make -f Makefile BASIC) + +clean: + (cd Data_Rec; make -f Makefile clean) + (cd HYDRO_drv; make -f Makefile clean) + (cd Routing; make -f Makefile clean) + (rm -f lib/*.a */*.mod CPL/*/*.o CPL/*/*.mod) diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.IBM.xlf90_r.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.IBM.xlf90_r.svn-base new file mode 100644 index 00000000..67b224a7 --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.IBM.xlf90_r.svn-base @@ -0,0 +1,37 @@ +.IGNORE: + +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + +RM = rm -f +RMD = rm -f +COMPILER90= mpxlf90_r +F90FLAGS = -O2 -qfree=f90 -c -w -qspill=20000 -qmaxmem=64000 +LDFLAGS = -O2 -qfree=f90 -w -qspill=20000 -qmaxmem=64000 +MODFLAG = -I./ -I ../MPP -I../../MPP -I ../mod +LDFLAGS = +CPP = cpp +LIBS = +CPPFLAGS = -C -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf + diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.gfort.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.gfort.svn-base new file mode 100644 index 00000000..f0ac6898 --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.gfort.svn-base @@ -0,0 +1,33 @@ +.IGNORE: +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + +RMD = rm -f +COMPILER90= mpif90 +F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 +MODFLAG = -I"./" -I"../../MPP" -I"../MPP" -I"../mod" +LDFLAGS = +CPP = cpp +CPPFLAGS = -C -P -xassembler-with-cpp -traditional -DMPP_LAND -I"../Data_Rec" $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.ifort.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.ifort.svn-base new file mode 100644 index 00000000..c6f6bcf6 --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.ifort.svn-base @@ -0,0 +1,36 @@ +.IGNORE: +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + + +RMD = rm -f +COMPILER90= mpif90 +FORMAT_FREE = -FR +BYTESWAPIO = -convert big_endian +F90FLAGS = -w -c -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO) +MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod +LDFLAGS = +CPP = cpp +CPPFLAGS = -C -P -traditional -DMPP_LAND -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.linux.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.linux.svn-base new file mode 100644 index 00000000..025d18de --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.linux.svn-base @@ -0,0 +1,35 @@ +.IGNORE: +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + +RM = rm -f +RMD = rm -f +COMPILER90= mpif90 +F90FLAGS = -Mfree -c -byteswapio -O2 -Kieee +LDFLAGS = $(F90FLAGS) +MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod +LDFLAGS = +CPP = cpp +CPPFLAGS = -C -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.IBM.xlf90_r.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.IBM.xlf90_r.svn-base new file mode 100644 index 00000000..fb5c020f --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.IBM.xlf90_r.svn-base @@ -0,0 +1,36 @@ +.IGNORE: +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + + + +RM = rm -f +RMD = rm -f +COMPILER90= xlf90_r +F90FLAGS = -c -O2 -qfree=f90 -qmaxmem=819200 +MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod +LDFLAGS = +CPP = cpp -C -P +CPPFLAGS = -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.gfort.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.gfort.svn-base new file mode 100644 index 00000000..a03fba3d --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.gfort.svn-base @@ -0,0 +1,34 @@ +.IGNORE: +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + + +RMD = rm -f +COMPILER90= gfortran +F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 +MODFLAG = -I./ -I../mod +LDFLAGS = +CPP = cpp +CPPFLAGS = -C -P -xassembler-with-cpp -traditional -I"../Data_Rec" $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.ifort.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.ifort.svn-base new file mode 100644 index 00000000..60b64161 --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.ifort.svn-base @@ -0,0 +1,36 @@ +.IGNORE: +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + + +RMD = rm -f +COMPILER90= ifort +##F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 +F90FLAGS = -w -c -ftz -align all -fno-alias -fp-model precise -FR -convert big_endian + +MODFLAG = -I./ -I ../mod +LDFLAGS = +CPP = cpp +CPPFLAGS = -C -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.linux.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.linux.svn-base new file mode 100644 index 00000000..748bad15 --- /dev/null +++ b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.linux.svn-base @@ -0,0 +1,36 @@ +.IGNORE: +ifeq ($(WRF_HYDRO),1) +WRF_HYDRO = -DWRF_HYDRO +else +WRF_HYDRO = +endif + +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + +ifeq ($(HYDRO_D),1) +HYDRO_D = -DHYDRO_D $(WRF_HYDRO) +else +HYDRO_D = $(WRF_HYDRO) +endif + +ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) +WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT +else +WRFIO_NCD_LARGE_FILE_SUPPORT = +endif + + +RMD = ls +RM = rm -f +COMPILER90= pgf90 +F90FLAGS = -Mfree -Mfptrap -c -byteswapio -Ktrap=fp -O2 -Kieee +LDFLAGS = $(F90FLAGS) +MODFLAG = -I./ -I ../mod +LDFLAGS = +CPP = cpp +CPPFLAGS = -C -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRF_HYDRO) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +LIBS = +NETCDFINC = $(NETCDF_INC) +NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r b/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r index d59c0b15..67b224a7 100644 --- a/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r +++ b/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r @@ -6,6 +6,10 @@ else WRF_HYDRO = endif +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + ifeq ($(HYDRO_D),1) HYDRO_D = -DHYDRO_D $(WRF_HYDRO) else diff --git a/wrfv2_fire/hydro/arc/macros.mpp.gfort b/wrfv2_fire/hydro/arc/macros.mpp.gfort index fd2da440..f0ac6898 100644 --- a/wrfv2_fire/hydro/arc/macros.mpp.gfort +++ b/wrfv2_fire/hydro/arc/macros.mpp.gfort @@ -5,6 +5,10 @@ else WRF_HYDRO = endif +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + ifeq ($(HYDRO_D),1) HYDRO_D = -DHYDRO_D $(WRF_HYDRO) else @@ -20,10 +24,10 @@ endif RMD = rm -f COMPILER90= mpif90 F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 -MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod +MODFLAG = -I"./" -I"../../MPP" -I"../MPP" -I"../mod" LDFLAGS = -CPP = /lib/cpp -CPPFLAGS = -C -P -traditional -DMPP_LAND -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +CPP = cpp +CPPFLAGS = -C -P -xassembler-with-cpp -traditional -DMPP_LAND -I"../Data_Rec" $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) LIBS = NETCDFINC = $(NETCDF_INC) NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.mpp.ifort b/wrfv2_fire/hydro/arc/macros.mpp.ifort index d3fd9a7c..c6f6bcf6 100644 --- a/wrfv2_fire/hydro/arc/macros.mpp.ifort +++ b/wrfv2_fire/hydro/arc/macros.mpp.ifort @@ -5,6 +5,10 @@ else WRF_HYDRO = endif +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + ifeq ($(HYDRO_D),1) HYDRO_D = -DHYDRO_D $(WRF_HYDRO) else diff --git a/wrfv2_fire/hydro/arc/macros.mpp.linux b/wrfv2_fire/hydro/arc/macros.mpp.linux index 9c355ed2..025d18de 100644 --- a/wrfv2_fire/hydro/arc/macros.mpp.linux +++ b/wrfv2_fire/hydro/arc/macros.mpp.linux @@ -5,6 +5,10 @@ else WRF_HYDRO = endif +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + ifeq ($(HYDRO_D),1) HYDRO_D = -DHYDRO_D $(WRF_HYDRO) else @@ -20,7 +24,7 @@ endif RM = rm -f RMD = rm -f COMPILER90= mpif90 -F90FLAGS = -Mfree -c -byteswapio -O2 +F90FLAGS = -Mfree -c -byteswapio -O2 -Kieee LDFLAGS = $(F90FLAGS) MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod LDFLAGS = diff --git a/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r b/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r index d64595fe..fb5c020f 100644 --- a/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r +++ b/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r @@ -5,6 +5,10 @@ else WRF_HYDRO = endif +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + ifeq ($(HYDRO_D),1) HYDRO_D = -DHYDRO_D $(WRF_HYDRO) else diff --git a/wrfv2_fire/hydro/arc/macros.seq.gfort b/wrfv2_fire/hydro/arc/macros.seq.gfort index 6a978310..a03fba3d 100644 --- a/wrfv2_fire/hydro/arc/macros.seq.gfort +++ b/wrfv2_fire/hydro/arc/macros.seq.gfort @@ -5,6 +5,10 @@ else WRF_HYDRO = endif +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + ifeq ($(HYDRO_D),1) HYDRO_D = -DHYDRO_D $(WRF_HYDRO) else @@ -23,8 +27,8 @@ COMPILER90= gfortran F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 MODFLAG = -I./ -I../mod LDFLAGS = -CPP = /lib/cpp -CPPFLAGS = -C -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) +CPP = cpp +CPPFLAGS = -C -P -xassembler-with-cpp -traditional -I"../Data_Rec" $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) LIBS = NETCDFINC = $(NETCDF_INC) NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.seq.ifort b/wrfv2_fire/hydro/arc/macros.seq.ifort index 8a6249da..60b64161 100644 --- a/wrfv2_fire/hydro/arc/macros.seq.ifort +++ b/wrfv2_fire/hydro/arc/macros.seq.ifort @@ -5,6 +5,10 @@ else WRF_HYDRO = endif +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + ifeq ($(HYDRO_D),1) HYDRO_D = -DHYDRO_D $(WRF_HYDRO) else diff --git a/wrfv2_fire/hydro/arc/macros.seq.linux b/wrfv2_fire/hydro/arc/macros.seq.linux index 50a77465..748bad15 100644 --- a/wrfv2_fire/hydro/arc/macros.seq.linux +++ b/wrfv2_fire/hydro/arc/macros.seq.linux @@ -5,6 +5,10 @@ else WRF_HYDRO = endif +ifeq ($(WRF_HYDRO_RAPID),1) +WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID +endif + ifeq ($(HYDRO_D),1) HYDRO_D = -DHYDRO_D $(WRF_HYDRO) else @@ -21,7 +25,7 @@ endif RMD = ls RM = rm -f COMPILER90= pgf90 -F90FLAGS = -Mfree -Mfptrap -c -byteswapio -Ktrap=fp -O2 +F90FLAGS = -Mfree -Mfptrap -c -byteswapio -Ktrap=fp -O2 -Kieee LDFLAGS = $(F90FLAGS) MODFLAG = -I./ -I ../mod LDFLAGS = diff --git a/wrfv2_fire/hydro/configure b/wrfv2_fire/hydro/configure index 151c2d0d..5848f116 100755 --- a/wrfv2_fire/hydro/configure +++ b/wrfv2_fire/hydro/configure @@ -9,14 +9,20 @@ } } + ${NETCDF_LIB} = $ENV{NETCDF_LIB}; if(! defined($ENV{NETCDF_LIB})){ if(defined($ENV{NETCDF})) { $tt = `echo "NETCDF_LIB = \${NETCDF}/lib" >> macros.tmp` ; + ${NETCDF_LIB} = $ENV{NETCDF}."/lib"; } else { print"Error: environment variable NETCDF_LIB not defined. \n"; exit(0); } } + + if(! -e "${NETCDF_LIB}/libnetcdff.a"){ + $tt = `echo "NETCDFLIB = -L${NETCDF_LIB} -lnetcdf" >> macros.tmp `; + } if(-e macros) {system (rm -f macros);} # if(-e Makefile) {system "rm -f Makefile" ;} @@ -97,5 +103,5 @@ } if(! (-e lib)) {mkdir lib;} if(! (-e mod)) {mkdir mod;} - if(-e "macros.tmp") { system("cat macros.tmp macros > macros.a; rm -f macros.tmp; mv macros.a macros");} + if(-e "macros.tmp") { system("cat macros macros.tmp > macros.a; rm -f macros.tmp; mv macros.a macros");} if((-d "LandModel") ) {system "cat macros LandModel/user_build_options.bak > LandModel/user_build_options";} diff --git a/wrfv2_fire/inc/version_decl b/wrfv2_fire/inc/version_decl index 1b5abede..fa58cdcc 100644 --- a/wrfv2_fire/inc/version_decl +++ b/wrfv2_fire/inc/version_decl @@ -1 +1 @@ - CHARACTER (LEN=10) :: release_version = 'V3.6 ' + CHARACTER (LEN=10) :: release_version = 'V3.7 ' diff --git a/wrfv2_fire/main/Makefile b/wrfv2_fire/main/Makefile index 83e06c94..34c9761b 100644 --- a/wrfv2_fire/main/Makefile +++ b/wrfv2_fire/main/Makefile @@ -27,7 +27,7 @@ $(SOLVER)_ideal : module_initialize ideal_$(SOLVER).o $(SOLVER)_real : module_initialize ndown_$(SOLVER).o nup_$(SOLVER).o tc_$(SOLVER).o real_$(SOLVER).o $(RANLIB) $(LIBWRFLIB) $(LD) -o ndown.exe $(LDFLAGS) ndown_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) - $(LD) -o nup.exe $(LDFLAGS) nup_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) + #TEMPORARILY REMOVED $(LD) -o nup.exe $(LDFLAGS) nup_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) $(LD) -o tc.exe $(LDFLAGS) tc_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) $(LD) -o real.exe $(LDFLAGS) real_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) diff --git a/wrfv2_fire/main/convert_em.F b/wrfv2_fire/main/convert_em.F index c34e92c2..05679d53 100644 --- a/wrfv2_fire/main/convert_em.F +++ b/wrfv2_fire/main/convert_em.F @@ -13,7 +13,7 @@ PROGRAM convert_data USE module_driver_constants USE module_configure USE module_timing -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_input_chem_data USE module_input_chem_bioemiss #endif @@ -24,7 +24,7 @@ PROGRAM convert_data IMPLICIT NONE -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! interface INTERFACE ! mediation-supplied diff --git a/wrfv2_fire/main/depend.common b/wrfv2_fire/main/depend.common index 1bb2347d..cd8ec584 100644 --- a/wrfv2_fire/main/depend.common +++ b/wrfv2_fire/main/depend.common @@ -147,6 +147,9 @@ module_cpl.o: \ module_cpl_oasis3.o: module_driver_constants.o \ module_domain.o +module_clear_halos.o: module_configure.o \ + module_domain.o + # End of DEPENDENCIES for frame # DEPENDENCIES for phys @@ -161,8 +164,6 @@ module_bl_boulac.o: ../share/module_model_constants.o module_bl_qnsepbl.o: ../share/module_model_constants.o -module_bl_qnsepbl09.o: ../share/module_model_constants.o - module_progtm.o: module_gfs_machine.o module_bl_gfs.o: module_gfs_machine.o \ @@ -288,6 +289,13 @@ module_cam_shr_kind_mod.o: module_cu_kf.o: ../frame/module_wrf_error.o + +module_cu_kfcup.o: ../frame/module_wrf_error.o \ + ../frame/module_state_description.o \ + $(CF2) \ + ../share/module_model_constants.o \ + module_mixactivate.o + module_cu_kfeta.o: ../frame/module_wrf_error.o module_cu_gd.o: @@ -315,6 +323,8 @@ module_cu_tiedtke.o:module_gfs_machine.o \ module_gfs_funcphys.o \ module_gfs_physcons.o +module_cu_ntiedtke.o: ../share/module_model_constants.o + module_ra_gfdleta.o: ../frame/module_dm.o \ module_mp_etanew.o @@ -350,6 +360,10 @@ module_mp_thompson.o : ../frame/module_wrf_error.o \ module_mp_nssl_2mom.o : ../frame/module_wrf_error.o \ ../share/module_model_constants.o +module_mp_fast_sbm.o : module_mp_radar.o + +module_mp_full_sbm.o : module_mp_radar.o + module_mp_cammgmp_driver.o : module_cam_mp_microp_aero.o \ module_cam_constituents.o \ module_cam_shr_kind_mod.o \ @@ -433,14 +447,8 @@ module_sf_noah_seaice_drv.o: module_sf_noah_seaice.o module_sf_noah_seaice.o: module_sf_noahlsm.o ../share/module_model_constants.o module_sf_noahmpdrv.o: module_sf_noahmplsm.o \ - module_sf_noahdrv.o \ - module_ra_gfdleta.o \ module_data_gocart_dust.o \ - module_sf_urban.o \ - module_sf_noah_seaice.o \ - module_sf_noahlsm_glacial_only.o \ module_sf_noahmp_glacier.o \ - module_sf_myjsfc.o \ module_sf_noahmp_groundwater.o \ ../share/module_model_constants.o @@ -449,7 +457,7 @@ module_sf_noahlsm_glacial_only.o: module_sf_noahlsm.o module_sf_noahmplsm.o module_sf_noahmplsm.o: ../share/module_model_constants.o \ module_sf_myjsfc.o -module_sf_noahmp_groundwater.o: +module_sf_noahmp_groundwater.o: module_sf_noahmplsm.o module_sf_bep.o: ../share/module_model_constants.o module_sf_urban.o @@ -462,9 +470,12 @@ module_sf_ruclsm.o: ../frame/module_wrf_error.o module_data_gocart_dust.o module_sf_pxlsm.o: ../share/module_model_constants.o module_sf_pxlsm_data.o module_ra_rrtmg_sw.o: module_ra_rrtmg_lw.o +module_ra_rrtmg_swf.o: module_ra_rrtmg_lwf.o module_ra_rrtmg_lw.o: ../share/module_model_constants.o \ module_ra_clWRF_support.o +module_ra_rrtmg_lwf.o: ../share/module_model_constants.o \ + module_ra_clWRF_support.o module_physics_addtendc.o: \ module_cu_kf.o \ @@ -475,6 +486,8 @@ module_physics_addtendc.o: \ module_physics_init.o : \ module_ra_rrtm.o \ + module_ra_rrtmg_lwf.o \ + module_ra_rrtmg_swf.o \ module_ra_rrtmg_lw.o \ module_ra_rrtmg_sw.o \ module_ra_cam.o \ @@ -512,7 +525,6 @@ module_physics_init.o : \ module_bl_acm.o \ module_bl_myjpbl.o \ module_bl_qnsepbl.o \ - module_bl_qnsepbl09.o \ module_bl_mynn.o \ module_bl_myjurb.o \ module_bl_boulac.o \ @@ -522,12 +534,14 @@ module_physics_init.o : \ module_cu_kf.o \ module_cu_g3.o \ module_cu_kfeta.o \ + module_cu_mskf.o \ module_cu_bmj.o \ module_cu_gd.o \ module_cu_nsas.o \ module_cu_sas.o \ module_cu_osas.o \ module_cu_camzm_driver.o \ + module_cu_kfcup.o \ module_shcu_camuwshcu.o \ module_shcu_grims.o \ module_mp_sbu_ylin.o \ @@ -535,7 +549,6 @@ module_physics_init.o : \ module_mp_wsm5.o \ module_mp_wsm6.o \ module_mp_etanew.o \ - module_mp_etaold.o \ module_mp_HWRF.o \ module_fdda_psufddagd.o \ module_fdda_spnudging.o \ @@ -567,7 +580,7 @@ module_microphysics_driver.o: \ module_mp_kessler.o module_mp_sbu_ylin.o module_mp_lin.o \ module_mp_wsm3.o module_mp_wsm5.o \ module_mp_wsm6.o module_mp_etanew.o \ - module_mp_etaold.o module_mp_HWRF.o \ + module_mp_HWRF.o \ module_mp_thompson.o \ module_mp_gsfcgce.o \ module_mp_morr_two_moment.o \ @@ -597,6 +610,8 @@ module_cumulus_driver.o: \ module_cu_osas.o \ module_cu_camzm_driver.o \ module_cu_tiedtke.o \ + module_cu_ntiedtke.o \ + module_cu_kfcup.o \ ../frame/module_state_description.o \ ../frame/module_configure.o \ ../frame/module_domain.o \ @@ -609,7 +624,6 @@ module_pbl_driver.o: \ module_bl_myjpbl.o \ module_bl_myjurb.o \ module_bl_qnsepbl.o \ - module_bl_qnsepbl09.o \ module_bl_acm.o \ module_bl_ysu.o \ module_bl_mrf.o \ @@ -638,6 +652,8 @@ module_radiation_driver.o: \ module_ra_rrtm.o \ module_ra_rrtmg_lw.o \ module_ra_rrtmg_sw.o \ + module_ra_rrtmg_lwf.o \ + module_ra_rrtmg_swf.o \ module_ra_cam.o \ module_ra_gfdleta.o \ module_ra_HWRF.o \ @@ -645,6 +661,7 @@ module_radiation_driver.o: \ module_ra_goddard.o \ module_ra_flg.o \ module_ra_aerosol.o \ + module_mp_thompson.o \ ../frame/module_driver_constants.o \ ../frame/module_state_description.o \ ../frame/module_dm.o \ @@ -699,6 +716,7 @@ module_diagnostics_driver.o: \ module_diag_cl.o \ module_diag_pld.o \ module_diag_afwa.o \ + ../frame/module_comm_dm.o \ ../frame/module_state_description.o \ ../frame/module_domain.o \ ../frame/module_configure.o \ @@ -715,12 +733,17 @@ module_diag_cl.o: \ module_diag_pld.o: \ ../share/module_model_constants.o +module_diag_afwa_hail.o: + module_diag_afwa.o: \ ../frame/module_domain.o \ ../frame/module_dm.o \ ../frame/module_state_description.o \ ../frame/module_configure.o \ - ../share/module_model_constants.o + ../frame/module_streams.o \ + ../external/esmf_time_f90/module_utility.o \ + ../share/module_model_constants.o \ + module_diag_afwa_hail.o module_diag_refl.o: \ ../frame/module_dm.o \ @@ -833,7 +856,7 @@ solve_interface.o: solve_em.int ../frame/module_domain.o ../frame/module_configu ../frame/module_timing.o ../frame/module_driver_constants.o \ ../frame/module_wrf_error.o -start_domain.o: start_domain_em.int wrf_timeseries.o track_driver.o ../frame/module_domain.o ../frame/module_configure.o +start_domain.o: start_domain_em.int wrf_timeseries.o track_driver.o ../frame/module_domain.o ../frame/module_configure.o module_date_time.o: ../frame/module_wrf_error.o ../frame/module_configure.o \ module_model_constants.o @@ -1125,23 +1148,23 @@ ndown_em.o: \ ../dyn_em/module_big_step_utilities_em.o \ $(ESMF_MOD_DEPENDENCE) -nup_em.o: \ - ../frame/module_machine.o \ - ../frame/module_domain.o \ - ../frame/module_streams.o \ - ../frame/module_driver_constants.o \ - ../frame/module_configure.o \ - ../frame/module_timing.o \ - ../frame/module_dm.o \ - ../frame/module_wrf_error.o \ - ../frame/module_integrate.o \ - ../share/module_bc.o \ - ../share/module_io_domain.o \ - ../share/module_get_file_names.o \ - ../share/module_soil_pre.o \ - ../dyn_em/module_initialize_real.o \ - ../dyn_em/module_big_step_utilities_em.o \ - $(ESMF_MOD_DEPENDENCE) +#TEMPORARILY REMOVED nup_em.o: \ +# ../frame/module_machine.o \ +# ../frame/module_domain.o \ +# ../frame/module_streams.o \ +# ../frame/module_driver_constants.o \ +# ../frame/module_configure.o \ +# ../frame/module_timing.o \ +# ../frame/module_dm.o \ +# ../frame/module_wrf_error.o \ +# ../frame/module_integrate.o \ +# ../share/module_bc.o \ +# ../share/module_io_domain.o \ +# ../share/module_get_file_names.o \ +# ../share/module_soil_pre.o \ +# ../dyn_em/module_initialize_real.o \ +# ../dyn_em/module_big_step_utilities_em.o \ +# $(ESMF_MOD_DEPENDENCE) # this already built above :../dyn_em/module_initialize.real.o \ real_em.o: \ diff --git a/wrfv2_fire/main/ideal_em.F b/wrfv2_fire/main/ideal_em.F index be8e1b21..98dc6ce7 100644 --- a/wrfv2_fire/main/ideal_em.F +++ b/wrfv2_fire/main/ideal_em.F @@ -9,13 +9,13 @@ PROGRAM ideal USE module_timing USE module_wrf_error -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_input_chem_data USE module_input_chem_bioemiss #endif IMPLICIT NONE -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! interface INTERFACE ! mediation-supplied @@ -161,7 +161,7 @@ END SUBROUTINE med_initialdata_output CALL set_config_as_buffer( configbuf, configbuflen ) #endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF( grid%chem_opt > 0 ) then ! Read the chemistry data from a previous wrf forecast (wrfout file) IF(grid%chem_in_opt == 1 ) THEN @@ -230,6 +230,7 @@ END SUBROUTINE med_initialdata_output END IF #endif + grid%this_is_an_ideal_run = .TRUE. CALL med_initialdata_output( head_grid , config_flags ) CALL wrf_debug ( 0 , 'wrf: SUCCESS COMPLETE IDEAL INIT' ) diff --git a/wrfv2_fire/main/ideal_nmm.F b/wrfv2_fire/main/ideal_nmm.F index 9df31051..4fb85b32 100644 --- a/wrfv2_fire/main/ideal_nmm.F +++ b/wrfv2_fire/main/ideal_nmm.F @@ -11,7 +11,7 @@ PROGRAM ideal_nmm USE module_configure USE module_timing USE module_check_a_mundo -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_input_chem_data USE module_input_chem_bioemiss #endif @@ -188,7 +188,7 @@ SUBROUTINE med_sidata_input ( grid , config_flags ) USE module_bc_time_utilities USE module_initialize_ideal USE module_optional_input -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_input_chem_data USE module_input_chem_bioemiss #endif @@ -344,8 +344,10 @@ END SUBROUTINE start_domain ENDIF SELECT CASE ( use_package(io_form_auxinput1) ) -#ifdef NETCDF - CASE ( IO_NETCDF ) +#if defined(NETCDF) || defined(PNETCDF) || defined(PIO) + CASE ( IO_NETCDF ) + CASE ( IO_PNETCDF ) + CASE ( IO_PIO ) ! Open the wrfinput file. @@ -543,7 +545,7 @@ END SUBROUTINE start_domain CALL start_domain ( grid , .TRUE.) END IF -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( loop == 1 ) THEN ! IF ( ( grid%chem_opt .EQ. RADM2 ) .OR. & ! ( grid%chem_opt .EQ. RADM2SORG ) .OR. & diff --git a/wrfv2_fire/main/module_wrf_top.F b/wrfv2_fire/main/module_wrf_top.F index 71b236c2..65cdcf1c 100644 --- a/wrfv2_fire/main/module_wrf_top.F +++ b/wrfv2_fire/main/module_wrf_top.F @@ -21,7 +21,7 @@ MODULE module_wrf_top USE module_nesting #ifdef DM_PARALLEL - USE module_dm, ONLY : wrf_dm_initialize + USE module_dm, ONLY : wrf_dm_initialize,wrf_get_hostid #endif USE module_cpl, ONLY : coupler_on, cpl_finalize, cpl_defdomain diff --git a/wrfv2_fire/main/ndown_em.F b/wrfv2_fire/main/ndown_em.F index c0f526d3..d2788a30 100644 --- a/wrfv2_fire/main/ndown_em.F +++ b/wrfv2_fire/main/ndown_em.F @@ -26,7 +26,7 @@ PROGRAM ndown_em USE module_bc USE module_big_step_utilities_em USE module_get_file_names -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! for chemistry USE module_input_chem_data @@ -368,7 +368,15 @@ END SUBROUTINE vert_cor CALL close_dataset ( fid , config_flags , "DATASET=INPUT" ) file_counter = file_counter + 1 IF ( file_counter .GT. number_of_eligible_files ) THEN - WRITE( wrf_err_message , FMT='(A,A,A,I8)' ) 'program ndown: opening too many files' + WRITE( wrf_err_message , FMT='(A)' ) 'program ndown: opening too many files' + CALL wrf_message ( TRIM(wrf_err_message) ) + WRITE( wrf_err_message , FMT='(A)' ) 'Usually, this is caused by trying to run ndown past the last time available d01 model output' + CALL wrf_message ( TRIM(wrf_err_message) ) + WRITE( wrf_err_message , FMT='(A)' ) 'The CG model output is used to supply lateral boundary conditions' + CALL wrf_message ( TRIM(wrf_err_message) ) + WRITE( wrf_err_message , FMT='(A)' ) 'The ndown program uses the start and end times, the WRF model for d01 likely used the run times option.' + CALL wrf_message ( TRIM(wrf_err_message) ) + WRITE( wrf_err_message , FMT='(A)' ) 'Check the namelist.input time_control section for inconsistencies.' CALL WRF_ERROR_FATAL ( wrf_err_message ) END IF CALL wrf_debug ( 100 , 'ndown_em main: calling open_r_dataset for ' // TRIM(eligible_file_name(file_counter)) ) @@ -465,7 +473,7 @@ END SUBROUTINE vert_cor CALL nl_set_bdyfrq ( nested_grid%id , new_bdy_frq ) config_flags%bdyfrq = new_bdy_frq -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) nested_grid%chem_opt = parent_grid%chem_opt nested_grid%chem_in_opt = parent_grid%chem_in_opt #endif @@ -697,7 +705,7 @@ END SUBROUTINE vert_cor ! print *,'current_date = ',current_date CALL domain_clock_set( nested_grid, & current_timestr=current_date(1:19) ) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! ! Put in chemistry data ! @@ -864,7 +872,7 @@ END SUBROUTINE vert_cor ids , ide , jds , jde , 1 , 1 , & ims , ime , jms , jme , 1 , 1 , & ips , ipe , jps , jpe , 1 , 1 ) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) do nvchem=1,num_chem ! if(nvchem.eq.p_o3)then ! write(0,*)'fill ch_b',cbdy3dtemp1(5,1,5),nvchem @@ -990,7 +998,7 @@ END SUBROUTINE vert_cor ids , ide , jds , jde , 1 , 1 , & ims , ime , jms , jme , 1 , 1 , & ips , ipe , jps , jpe , 1 , 1 ) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) do nvchem=1,num_chem cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem) cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem) @@ -1137,7 +1145,7 @@ END SUBROUTINE vert_cor END DO -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) do nvchem=1,num_chem cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem) ! if(nvchem.eq.p_o3)then @@ -1192,7 +1200,7 @@ END SUBROUTINE vert_cor ! During all of the loops after the first loop, we first compute the boundary ! tendencies with the current data values and the previously save information ! stored in the *bdy3dtemp1 arrays. -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) do nvchem=1,num_chem cbdy3dtemp1(ips:ipe,kps:kpe,jps:jpe)=cbdy3dtemp0(ips:ipe,kps:kpe,jps:jpe,nvchem) cbdy3dtemp2(ips:ipe,kps:kpe,jps:jpe)=nested_grid%chem(ips:ipe,kps:kpe,jps:jpe,nvchem) diff --git a/wrfv2_fire/main/nup_em.F b/wrfv2_fire/main/nup_em.F index 3689a7fa..17189ee6 100644 --- a/wrfv2_fire/main/nup_em.F +++ b/wrfv2_fire/main/nup_em.F @@ -84,7 +84,7 @@ PROGRAM nup_em USE module_bc USE module_big_step_utilities_em USE module_get_file_names -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! for chemistry USE module_input_chem_data @@ -487,7 +487,7 @@ END SUBROUTINE med_interp_domain parent_grid%cfn = nested_grid%cfn parent_grid%cfn1 = nested_grid%cfn1 -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) parent_grid%chem_opt = nested_grid%chem_opt parent_grid%chem_in_opt = nested_grid%chem_in_opt #endif @@ -635,7 +635,7 @@ END SUBROUTINE med_interp_domain ! ! SEP Put in chemistry data ! -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF( parent_grid%chem_opt .NE. 0 ) then IF( parent_grid%chem_in_opt .EQ. 0 ) then ! Read the chemistry data from a previous wrf forecast (wrfout file) diff --git a/wrfv2_fire/main/real_em.F b/wrfv2_fire/main/real_em.F index c837ec65..c8ce23ba 100644 --- a/wrfv2_fire/main/real_em.F +++ b/wrfv2_fire/main/real_em.F @@ -22,7 +22,7 @@ PROGRAM real_data USE module_symbols_util, ONLY: wrfu_cal_gregorian #endif USE module_check_a_mundo -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_input_chem_data USE module_input_chem_bioemiss ! USE module_input_chem_emissopt3 @@ -31,7 +31,7 @@ PROGRAM real_data IMPLICIT NONE -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! interface INTERFACE ! mediation-supplied @@ -237,9 +237,11 @@ END SUBROUTINE Setup_Timekeeping ok_so_far = .TRUE. DO loop = 2 , model_config_rec%max_dom + IF ( model_config_rec%vert_refine_method(loop) .EQ. 0 ) THEN IF ( model_config_rec%e_vert(loop) .NE. model_config_rec%e_vert(1) ) THEN CALL wrf_message ( 'e_vert must be the same for each domain' ) ok_so_far = .FALSE. + END IF END IF END DO IF ( .NOT. ok_so_far ) THEN @@ -294,7 +296,7 @@ SUBROUTINE med_sidata_input ( grid , config_flags ) USE module_bc_time_utilities USE module_initialize_real USE module_optional_input -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_input_chem_data USE module_input_chem_bioemiss ! USE module_input_chem_emissopt3 @@ -416,8 +418,8 @@ END SUBROUTINE start_domain CALL nl_get_io_form_auxinput1( 1, io_form_auxinput1 ) SELECT CASE ( use_package(io_form_auxinput1) ) -#ifdef NETCDF - CASE ( IO_NETCDF ) +#if defined(NETCDF) || defined(PNETCDF) || defined(PIO) + CASE ( IO_NETCDF , IO_PNETCDF , IO_PIO ) IF ( config_flags%auxinput1_inname(1:8) .NE. 'wrf_real' ) THEN @@ -496,7 +498,7 @@ END SUBROUTINE start_domain CALL wrf_debug( 0, wrf_err_message ) CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( loop == 1 ) THEN IF( grid%chem_opt > 0 ) then ! Read the chemistry data from a previous wrf forecast (wrfout file) @@ -684,6 +686,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) INTEGER , SAVE :: id, id2, id4 CHARACTER (LEN=80) :: inpname , bdyname CHARACTER(LEN= 4) :: loop_char + CHARACTER (LEN=256) :: message character *19 :: temp19 character *24 :: temp24 , temp24b @@ -727,6 +730,18 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) sst_update = model_config_rec%sst_update grid_fdda = model_config_rec%grid_fdda(grid%id) + ! Domain check. We cannot decompose the domain into pieces that are + ! too small to manufacture the lateral boundary conditions. + + IF ( ( ipe-ips+2 .LE. spec_bdy_width ) .OR. & + ( jpe-jps+2 .LE. spec_bdy_width ) ) THEN + CALL wrf_message( 'The "width" of the lateral boundary conditions must be entirely contained within') + CALL wrf_message( 'the decomposed patch. ') + WRITE(message,fmt='("ips=",i4,", ipe=",i4,", jps=",i4,", jpe=",i4,", spec_bdy_width=",i2)') ips,ipe,jps,jpe,spec_bdy_width + CALL wrf_message( message ) + CALL wrf_error_fatal( 'Submit the real program again with fewer processors ') + END IF + IF ( loop .EQ. 1 ) THEN @@ -781,6 +796,8 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) ! Open the wrfinput file. From this program, this is an *output* file. + grid%this_is_an_ideal_run = .FALSE. + CALL construct_filename1( inpname , 'wrfinput' , grid%id , 2 ) CALL open_w_dataset ( id1, TRIM(inpname) , grid , config_flags , output_input , "DATASET=INPUT", ierr ) IF ( ierr .NE. 0 ) THEN diff --git a/wrfv2_fire/main/real_nmm.F b/wrfv2_fire/main/real_nmm.F index 4fe42fe4..27f60a80 100644 --- a/wrfv2_fire/main/real_nmm.F +++ b/wrfv2_fire/main/real_nmm.F @@ -11,7 +11,7 @@ PROGRAM real_data USE module_configure USE module_timing USE module_check_a_mundo -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_input_chem_data USE module_input_chem_bioemiss #endif @@ -189,7 +189,7 @@ SUBROUTINE med_sidata_input ( grid , config_flags ) USE module_bc_time_utilities USE module_initialize_real USE module_optional_input -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_input_chem_data USE module_input_chem_bioemiss #endif @@ -344,8 +344,8 @@ END SUBROUTINE start_domain ENDIF SELECT CASE ( use_package(io_form_auxinput1) ) -#ifdef NETCDF - CASE ( IO_NETCDF ) +#if defined(NETCDF) || defined(PNETCDF) || defined(PIO) + CASE ( IO_NETCDF , IO_PNETCDF , IO_PIO ) ! Open the wrfinput file. @@ -543,7 +543,7 @@ END SUBROUTINE start_domain CALL start_domain ( grid , .TRUE.) END IF -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( loop == 1 ) THEN ! IF ( ( grid%chem_opt .EQ. RADM2 ) .OR. & ! ( grid%chem_opt .EQ. RADM2SORG ) .OR. & diff --git a/wrfv2_fire/phys/Makefile b/wrfv2_fire/phys/Makefile index c5ffe640..0fa15d83 100644 --- a/wrfv2_fire/phys/Makefile +++ b/wrfv2_fire/phys/Makefile @@ -32,12 +32,12 @@ MODULES = \ module_data_cam_mam_asect.o \ module_cam_infnan.o \ module_bl_ysu.o \ + module_bl_shinhong.o \ module_bl_mrf.o \ module_bl_gfs.o \ module_bl_gfs2011.o \ module_bl_myjpbl.o \ module_bl_qnsepbl.o \ - module_bl_qnsepbl09.o \ module_bl_acm.o \ module_bl_mynn.o \ module_bl_fogdes.o \ @@ -57,13 +57,16 @@ MODULES = \ module_cu_kf.o \ module_cu_bmj.o \ module_cu_kfeta.o \ + module_cu_mskf.o \ module_cu_tiedtke.o\ + module_cu_ntiedtke.o\ module_cu_gd.o \ module_cu_gf.o \ module_cu_nsas.o \ module_cu_sas.o \ module_cu_mesosas.o \ module_cu_osas.o \ + module_cu_kfcup.o \ module_mp_radar.o \ module_mp_kessler.o \ module_mp_lin.o \ @@ -72,11 +75,11 @@ MODULES = \ module_mp_wsm5.o \ module_mp_wsm6.o \ module_mp_etanew.o \ - module_mp_etaold.o \ module_mp_HWRF.o \ module_mp_thompson.o \ module_mp_full_sbm.o \ module_mp_fast_sbm.o \ + module_ltng_lpi.o \ module_mp_gsfcgce.o \ module_mp_morr_two_moment.o \ module_mp_milbrandt2mom.o \ @@ -91,6 +94,8 @@ MODULES = \ module_ra_rrtm.o \ module_ra_rrtmg_lw.o \ module_ra_rrtmg_sw.o \ + module_ra_rrtmg_lwf.o \ + module_ra_rrtmg_swf.o \ module_ra_cam_support.o \ module_ra_cam.o \ module_ra_gfdleta.o \ @@ -176,6 +181,7 @@ FIRE_MODULES = \ DIAGNOSTIC_MODULES_EM = \ module_diag_afwa.o \ + module_diag_afwa_hail.o \ module_diag_cl.o \ module_diag_misc.o \ module_diag_pld.o diff --git a/wrfv2_fire/phys/module_bl_acm.F b/wrfv2_fire/phys/module_bl_acm.F index ed0a2ffc..49c13ba0 100755 --- a/wrfv2_fire/phys/module_bl_acm.F +++ b/wrfv2_fire/phys/module_bl_acm.F @@ -323,10 +323,11 @@ SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah & !... Real REAL :: TVCON, WSS, TCONV, TH1, TOG, DTMP, WSSQ + REAL :: ZH1,UH1,VH1 ! NEW FOR V3.7 REAL :: psix, THV1 REAL, DIMENSION( its:ite ) :: FINT, PSTAR, CPAIR REAL, DIMENSION( its:ite, kts:kte ) :: THETAV, RIB, & - EDDYZ, UX, VX, THETAX, & + EDDYZ, EDDYZM, UX, VX, THETAX, & QVX, QCX, QIX, ZA REAL, DIMENSION( its:ite, 0:kte ) :: ZF REAL, DIMENSION( its:ite) :: WST, TST, QST, USTM, TSTV @@ -415,38 +416,47 @@ SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah & ENDDO 69 CONTINUE TH1 = 0.0 + ZH1 = 0.0 + UH1 = 0.0 + VH1 = 0.0 DO K = 1,KSRC TH1 = TH1 + THETAV(I,K) + ZH1 = ZH1 + ZA(I,K) + UH1 = UH1 + US(I,K) + VH1 = VH1 + VS(I,K) ENDDO TH1 = TH1/KSRC + ZH1 = ZH1/KSRC + UH1 = UH1/KSRC + VH1 = VH1/KSRC IF(MOL(I).LT.0.0 .AND. XTIME.GT.1) then WSS = (UST(I) ** 3 + 0.6 * WST(I) ** 3) ** 0.33333 TCONV = -8.5 * UST(I) * TSTV(I) / WSS TH1 = TH1 + TCONV ENDIF -99 KMIX = 1 - DO K = 1,kte +99 KMIX = KSRC + DO K = KSRC,kte DTMP = THETAV(I,K) - TH1 IF (DTMP.LT.0.0) KMIX = K ENDDO - IF(KMIX.GT.1) THEN + IF(KMIX.GT.KSRC) THEN FINTT = (TH1 - THETAV(I,KMIX)) / (THETAV(I,KMIX+1) & - THETAV(I,KMIX)) ZMIX = FINTT * (ZA(I,KMIX+1)-ZA(I,KMIX)) + ZA(I,KMIX) UMIX = FINTT * (US(I,KMIX+1)-US(I,KMIX)) + US(I,KMIX) VMIX = FINTT * (VS(I,KMIX+1)-VS(I,KMIX)) + VS(I,KMIX) ELSE - ZMIX = ZA(I,1) - UMIX = US(I,1) - VMIX = VS(I,1) + ZMIX = ZH1 + UMIX = UH1 + VMIX = VH1 ENDIF DO K = KMIX,kte DTMP = THETAV(I,K) - TH1 TOG = 0.5 * (THETAV(I,K) + TH1) / G WSSQ = (US(I,K)-UMIX)**2 & + (VS(I,K)-VMIX)**2 - IF (KMIX == 1) WSSQ = WSSQ + 100.*UST(I)*UST(I) + IF (KMIX == KSRC) WSSQ = WSSQ + 100.*UST(I)*UST(I) WSSQ = MAX( WSSQ, 0.1 ) RIB(I,K) = ABS(ZA(I,K)-ZMIX) * DTMP / (TOG * WSSQ) IF (RIB(I,K) .GE. RIC) GO TO 201 @@ -466,7 +476,7 @@ SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah & 100 CONTINUE DO I = its,ite - IF (KPBLH(I) .NE. 1) THEN + IF (KPBLH(I) .GT. KSRC) THEN !---------INTERPOLATE BETWEEN LEVELS -- jp 7/93 FINT(I) = (RIC - RIB(I,KPBLH(I)-1)) / (RIB(I,KPBLH(I)) - & RIB(I,KPBLH(I)-1)) @@ -482,9 +492,9 @@ SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah & KLPBL(I) = KPBLHT PBLSIG(I) = FINT(I) * DSIGH(KPBLHT) + SIGMAF(KPBLHT-1) ! sigma at PBL height ELSE - KLPBL(I) = 1 - PBL(I) = ZF(I,1) - PBLSIG(I) = SIGMAF(1) + KLPBL(I) = KSRC + PBL(I) = ZA(I,KSRC) + PBLSIG(I) = SIGMAH(KSRC) ENDIF ENDDO @@ -504,19 +514,27 @@ SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah & CALL EDDYX(DTPBL, ZF, ZA, MOL, PBL, UST, & US, VS, TT, THETAV, DENSX, PSTAR, & QVS, QCS, QIS, DSIGFI, G, RD, CPAIR, & - EDDYZ, its,ite, kts,kte,ims,ime, kms,kme) + EDDYZ, EDDYZM, its,ite, kts,kte,ims,ime, kms,kme) CALL ACM(DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, J, & KLPBL, PBL, PBLSIG, MOL, UST, & TST, QST, USTM, EDDYZ, DENSX, & - US, VS, THETA, QVS, QCS, QIS, & - UX, VX, THETAX, QVX, QCX, QIX, & + THETA, QVS, QCS, QIS, & + THETAX, QVX, QCX, QIX, & #if (WRF_CHEM == 1) CHEM, VD, NCHEM, KDVEL, NDVEL,NUM_VERT_MIX, & #endif ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) + CALL ACMM(DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, J, & + KLPBL, PBL, PBLSIG, MOL, UST, & + TST, QST, USTM, EDDYZM, DENSX, & + US, VS, & + UX, VX, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) !.. Load exch_h for use in CCN activation @@ -626,7 +644,7 @@ END SUBROUTINE acminit SUBROUTINE EDDYX(DTPBL, ZF, ZA, MOL, PBL, UST, & US, VS, TT, THETAV, DENSX, PSTAR, & QVS, QCS, QIS, DSIGFI, G, RD, CPAIR, & - EDDYZ, its,ite, kts,kte,ims,ime,kms,kme ) + EDDYZ, EDDYZM, its,ite, kts,kte,ims,ime,kms,kme ) !********************************************************************** @@ -656,7 +674,8 @@ SUBROUTINE EDDYX(DTPBL, ZF, ZA, MOL, PBL, UST, & !-- G gravity !-- RD gas constant for dry air (j/kg/k) !-- CPAIR specific heat of moist air (M^2 S^-2 K^-1) -!-- EDDYZ eddy diffusivity KZ +!-- EDDYZ eddy diffusivity for heat KZ +!-- EDDYZM eddy diffusivity for momentum KM !----------------------------------------------------------------------- !----------------------------------------------------------------------- @@ -677,7 +696,7 @@ SUBROUTINE EDDYX(DTPBL, ZF, ZA, MOL, PBL, UST, & REAL, DIMENSION( its:ite, kts:kte ), INTENT(IN) :: ZA, THETAV REAL, DIMENSION( its:ite, 0:kte ) , INTENT(IN) :: ZF - REAL , DIMENSION( its:ite, kts:kte ), INTENT(OUT) :: EDDYZ + REAL , DIMENSION( its:ite, kts:kte ), INTENT(OUT) :: EDDYZ,EDDYZM !.......Local variables @@ -687,15 +706,19 @@ SUBROUTINE EDDYX(DTPBL, ZF, ZA, MOL, PBL, UST, & !... Real REAL :: ZOVL, PHIH, WT, ZSOL, ZFUNC, DZF, SS, GOTH, EDYZ REAL :: RI, QMEAN, TMEAN, XLV, ALPH, CHI, ZK, SQL, DENSF, KZO - REAL :: FH + REAL :: FH, FM + REAL :: WM, EDYZM, PHIM !... Parameters REAL, PARAMETER :: RV = 461.5 REAL, PARAMETER :: RC = 0.25 REAL, PARAMETER :: RLAM = 80.0 - REAL, PARAMETER :: GAMH = 16.0 !15.0 ! Holtslag and Boville (1993) - REAL, PARAMETER :: BETAH = 5.0 ! Holtslag and Boville (1993) + REAL, PARAMETER :: GAMH = 16.0 !Dyer74 !15.0 ! Holtslag and Boville (1993) + REAL, PARAMETER :: GAMM = 16.0 !Dyer74 + REAL, PARAMETER :: BETAH = 5.0 ! Holtslag and Boville (1993) BETAM = BETAH REAL, PARAMETER :: KARMAN = 0.4 + REAL, PARAMETER :: P = 2.0 ! ZFUNC exponent REAL, PARAMETER :: EDYZ0 = 0.01 ! New Min Kz + REAL, PARAMETER :: PR = 0.8 ! Prandtl # ! REAL, PARAMETER :: EDYZ0 = 0.1 !-- IMVDIF imvdif=1 for moist adiabat vertical diffusion INTEGER, PARAMETER :: imvdif = 1 @@ -716,23 +739,30 @@ SUBROUTINE EDDYX(DTPBL, ZF, ZA, MOL, PBL, UST, & IF (ZOVL .LT. 0.0) THEN IF (ZF(I,K) .LT. 0.1 * PBL(I)) THEN PHIH = 1.0 / SQRT(1.0 - GAMH * ZOVL) + PHIM = (1.0 - GAMM * ZOVL)**(-0.25) WT = UST(I) / PHIH + WM = UST(I) / PHIM ELSE ZSOL = 0.1 * PBL(I) / MOL(I) PHIH = 1.0 / SQRT(1.0 - GAMH * ZSOL) + PHIM = (1.0 - GAMM * ZSOL)**(-0.25) WT = UST(I) / PHIH + WM = UST(I) / PHIM ENDIF ELSE IF (ZOVL .LT. 1.0) THEN PHIH = 1.0 + BETAH * ZOVL WT = UST(I) / PHIH + WM = WT ELSE PHIH = BETAH + ZOVL WT = UST(I) / PHIH + WM = WT ENDIF - ZFUNC = ZF(I,K) * (1.0 - ZF(I,K) / PBL(I)) ** 2 + ZFUNC = ZF(I,K) * (1.0 - ZF(I,K) / PBL(I)) ** P EDYZ = KARMAN * WT * ZFUNC + EDYZM = KARMAN * WM * ZFUNC ENDIF -!-------------------------------------------------------------------------- +!--------------------------------------------------------------------------!-------------------------------------------------------------------------- SS = ((US(I,K+1) - US(I,K)) ** 2 + (VS(I,K+1) - VS(I,K)) ** 2) & / (DZF * DZF) + 1.0E-9 GOTH = 2.0 * G / (THETAV(I,K+1) + THETAV(I,K)) @@ -757,34 +787,46 @@ SUBROUTINE EDDYX(DTPBL, ZF, ZA, MOL, PBL, UST, & SQL = (ZK * RLAM / (RLAM + ZK)) ** 2 IF (RI .GE. 0.0) THEN - IF (ZF(I,K).LT.PBL(I).AND.ZOVL.GT.0.0) THEN - FH = MAX((1.-ZF(I,K)/PBL(I))**2,0.01) * PHIH **(-2) - SQL = ZK ** 2 - ELSE - FH = (MAX(1.-RI/RC,0.01))**2 - ENDIF +! IF (ZF(I,K).LT.PBL(I).AND.ZOVL.GT.0.0) THEN +! FH = MAX((1.-ZF(I,K)/PBL(I))**2,0.01) * PHIH **(-2) +! SQL = ZK ** 2 +! ELSE +! FH = (MAX(1.-RI/RC,0.01))**2 +! ENDIF + FH=1./(1.+10.*RI+50.*RI**2+5000.*RI**4)+0.0012 !pleim5 + FM= PR*FH + 0.00104 + EDDYZ(I,K) = KZO + SQRT(SS) * FH * SQL + EDDYZM(I,K) = KZO + SQRT(SS) * FM * SQL ELSE EDDYZ(I,K) = KZO + SQRT(SS * (1.0 - 25.0 * RI)) * SQL + EDDYZM(I,K) = EDDYZ(I,K) * PR ENDIF IF(EDYZ.GT.EDDYZ(I,K)) THEN EDDYZ(I,K) = EDYZ + EDDYZM(I,K) = MIN(EDYZM,EDYZ*0.8) !PR ENDIF EDDYZ(I,K) = MIN(1000.0,EDDYZ(I,K)) EDDYZ(I,K) = MAX(KZO,EDDYZ(I,K)) + EDDYZM(I,K) = MIN(1000.0,EDDYZM(I,K)) + EDDYZM(I,K) = MAX(KZO,EDDYZM(I,K)) DENSF = 0.5 * (DENSX(I,K+1) + DENSX(I,K)) EDDYZ(I,K) = EDDYZ(I,K) * (DENSF * G / PSTAR(I)) ** 2 * & DTPBL * DSIGFI(K)*1E-6 + EDDYZM(I,K) = EDDYZM(I,K) * (DENSF * G / PSTAR(I)) ** 2 * & + DTPBL * DSIGFI(K)*1E-6 + ENDDO ! for I loop ENDDO ! for k loop ! DO I = its,ILX EDDYZ(I,KL) = 0.0 ! EDDYZ(I,KLM) -- changed jp 3/08 + EDDYZM(I,KL) = 0.0 ENDDO END SUBROUTINE EDDYX @@ -796,8 +838,8 @@ END SUBROUTINE EDDYX SUBROUTINE ACM (DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, JX, & KLPBL, PBL, PBLSIG, MOL, UST, & TST, QST, USTM, EDDYZ, DENSX, & - US, VS, THETA, QVS, QCS, QIS, & - UX, VX, THETAX, QVX, QCX, QIX, & + THETA, QVS, QCS, QIS, & + THETAX, QVX, QCX, QIX, & #if (WRF_CHEM == 1) CHEM, VD, NCHEM, KDVEL, NDVEL, & NUM_VERT_MIX, & @@ -871,9 +913,9 @@ SUBROUTINE ACM (DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, JX, & REAL , DIMENSION( kts:kte ), INTENT(IN) :: DSIGHI, DSIGH REAL , DIMENSION( 0:kte ), INTENT(IN) :: SIGMAF REAL , DIMENSION( its:ite, kts:kte ), INTENT(INOUT) :: EDDYZ - REAL , DIMENSION( ims:ime, kms:kme ), INTENT(IN) :: US,VS, THETA, & + REAL , DIMENSION( ims:ime, kms:kme ), INTENT(IN) :: THETA, & QVS, QCS, QIS, DENSX - REAL , DIMENSION( its:ite, kts:kte ), INTENT(OUT) :: UX, VX, THETAX, & + REAL , DIMENSION( its:ite, kts:kte ), INTENT(OUT) :: THETAX, & QVX, QCX, QIX #if (WRF_CHEM == 1) !......Chem @@ -884,7 +926,7 @@ SUBROUTINE ACM (DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, JX, & !.......Local variables !... Parameters - INTEGER, PARAMETER :: NSP = 6 + INTEGER, PARAMETER :: NSP = 4 ! !......ACM2 Parameters ! INTEGER, PARAMETER :: IFACM = 0 @@ -907,7 +949,7 @@ SUBROUTINE ACM (DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, JX, & REAL DELC REAL, DIMENSION( kts:kte ) :: AI, BI, CI, EI !, Y REAL, ALLOCATABLE, DIMENSION( : , : ) :: DI, UI - REAL, ALLOCATABLE, DIMENSION( : , : ) :: FS, BCBOTN + REAL, ALLOCATABLE, DIMENSION( : , : ) :: FS REAL, ALLOCATABLE, DIMENSION( : , : , : ) :: VCI CHARACTER*80 :: message @@ -929,8 +971,7 @@ SUBROUTINE ACM (DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, JX, & !...Allocate species variables ALLOCATE (DI( 1:NSPX,kts:kte )) ALLOCATE (UI( 1:NSPX,kts:kte )) - ALLOCATE (FS( 1:NSPX, its:ite )) - ALLOCATE (BCBOTN( 1:NSPX, its:ite )) + ALLOCATE (FS( 1:NSPX, its:ite )) ALLOCATE (VCI( 1:NSPX,its:ite,kts:kte )) !---COMPUTE ACM MIXING RATE @@ -983,14 +1024,12 @@ SUBROUTINE ACM (DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, JX, & DO I = its,ILX VCI(1,I,K) = THETA(I,K) VCI(2,I,K) = QVS(I,K) - VCI(3,I,K) = US(I,K) - VCI(4,I,K) = VS(I,K) ! -- Also mix cloud water and ice IF necessary ! IF (IMOISTX.NE.1.AND.IMOISTX.NE.3) THEN !!! Check other PBL models - VCI(5,I,K) = QCS(I,K) - VCI(6,I,K) = QIS(I,K) + VCI(3,I,K) = QCS(I,K) + VCI(4,I,K) = QIS(I,K) #if (WRF_CHEM == 1) - DO L= 7, NSPX + DO L= NSP+1, NSPX VCI(L,I,K) = CHEM(I,K,L-NSP) ENDDO #endif @@ -1000,14 +1039,10 @@ SUBROUTINE ACM (DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, JX, & DO I = its,ILX FS(1,I) = -UST(I) * TST(I) * DENSX(I,1) * PSTARI(I) FS(2,I) = -UST(I) * QST(I) * DENSX(I,1) * PSTARI(I) - FM = -USTM(I) * USTM(I) * DENSX(I,1) * PSTARI(I) - WSPD = SQRT(US(I,1) * US(I,1) + VS(I,1) * VS(I,1)) + 1.E-9 - FS(3,I) = FM * US(I,1) / WSPD - FS(4,I) = FM * VS(I,1) / WSPD - FS(5,I) = 0.0 - FS(6,I) = 0.0 ! SURFACE FLUXES OF CLOUD WATER AND ICE = 0 + FS(3,I) = 0.0 + FS(4,I) = 0.0 ! SURFACE FLUXES OF CLOUD WATER AND ICE = 0 #if (WRF_CHEM == 1) - DO L= 7, NSPX + DO L= NSP+1, NSPX FS(L,I) = -VD(I,1,L-NSP) * CHEM(I,1,L-NSP) * DENSX(I,1) * PSTARI(I) ENDDO #endif @@ -1137,10 +1172,8 @@ SUBROUTINE ACM (DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, JX, & DO I = its,ILX THETAX(I,K) = VCI(1,I,K) QVX(I,K) = VCI(2,I,K) - UX(I,K) = VCI(3,I,K) - VX(I,K) = VCI(4,I,K) - QCX(I,K) = VCI(5,I,K) - QIX(I,K) = VCI(6,I,K) + QCX(I,K) = VCI(3,I,K) + QIX(I,K) = VCI(4,I,K) #if (WRF_CHEM == 1) DO LL= 7, NSPX CHEM(I,K,LL-NSP) = VCI(LL,I,K) @@ -1152,12 +1185,316 @@ SUBROUTINE ACM (DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, JX, & DEALLOCATE (DI) DEALLOCATE (UI) DEALLOCATE (FS) - DEALLOCATE (BCBOTN) DEALLOCATE (VCI) END SUBROUTINE ACM !----------------------------------------------------------------------- !----------------------------------------------------------------------- +!------------------------------------------------------------------- + SUBROUTINE ACMM (DTPBL, PSTAR, NOCONV, SIGMAF, DSIGH, DSIGHI, JX, & + KLPBL, PBL, PBLSIG, MOL, UST, & + TST, QST, USTM, EDDYZM, DENSX, & + US, VS, & + UX, VX, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte) +!********************************************************************** +! PBL model called the Asymmetric Convective Model, Version 2 (ACM2) +! -- See top of module for summary and references +! +!---- REVISION HISTORY: +! AX 3/2005 - developed WRF version based on ACM2 in the MM5 PX LSM +! JP and RG 8/2006 - updates +! +!********************************************************************** +! ARGUMENTS: +!-- DTPBL PBL time step +!-- PSTAR Psurf - Ptop in cb +!-- NOCONV If free convection =0, no; =1, yes +!-- SIGMAF Sigma for full layer +!-- DSIGH Sigma thickness +!-- DSIGHI Inverse of sigma thickness +!-- JX N-S index +!-- KLPBL PBL level at K index +!-- PBL PBL height in m +!-- PBLSIG Sigma level for PBL +!-- MOL Monin-Obukhov length in 1D form +!-- UST U* in 1D form +!-- TST Theta* in 1D form +!-- QST Q* in 1D form +!-- USTM U* for computation of momemtum flux +!-- EDDYZM eddy diffusivity for momentum KM +!-- DENSX dry air density (kg/m^3) +!-- US U wind +!-- VS V wind +!-- THETA potential temperature +!-- QVS water vapor mixing ratio (Kg/Kg) +!-- QCS cloud mixing ratio (Kg/Kg) +!-- QIS ice mixing ratio (Kg/Kg) +!-- UX new U wind +!-- VX new V wind +!-- THETAX new potential temperature +!-- QVX new water vapor mixing ratio (Kg/Kg) +!-- QCX new cloud mixing ratio (Kg/Kg) +!-- QIX new ice mixing ratio (Kg/Kg) +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + + IMPLICIT NONE + +!.......Arguments + +!... Integer + INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, JX + INTEGER, DIMENSION( its:ite ), INTENT(IN) :: NOCONV + INTEGER, DIMENSION( ims:ime ), INTENT(IN) :: KLPBL + +!... Real + REAL , DIMENSION( ims:ime ), INTENT(IN) :: PBL, UST + REAL , INTENT(IN) :: DTPBL + REAL , DIMENSION( its:ite ), INTENT(IN) :: PSTAR, PBLSIG, & + MOL, TST, & + QST, USTM + REAL , DIMENSION( kts:kte ), INTENT(IN) :: DSIGHI, DSIGH + REAL , DIMENSION( 0:kte ), INTENT(IN) :: SIGMAF + REAL , DIMENSION( its:ite, kts:kte ), INTENT(INOUT) :: EDDYZM + REAL , DIMENSION( ims:ime, kms:kme ), INTENT(IN) :: US,VS, & + DENSX + REAL , DIMENSION( its:ite, kts:kte ), INTENT(OUT) :: UX, VX +!.......Local variables + +!... Parameters + INTEGER, PARAMETER :: NSP = 2 +! +!......ACM2 Parameters +! INTEGER, PARAMETER :: IFACM = 0 +! + REAL, PARAMETER :: G1000 = 9.8 * 1.0E-3 + REAL, PARAMETER :: XX = 0.5 ! FACTOR APPLIED TO CONV MIXING TIME STEP + REAL, PARAMETER :: KARMAN = 0.4 + +!... Integer + INTEGER :: ILX, KL, KLM, I, K, NSPX, NLP, NL, JJ, L + INTEGER :: KCBLMX + INTEGER, DIMENSION( its:ite ) :: KCBL + +!... Real + REAL :: G1000I, MBMAX, HOVL, MEDDY, MBAR + REAL :: EKZ, RZ, FM, WSPD, DTS, DTRAT, F1 + REAL, DIMENSION( its:ite ) :: PSTARI, FSACM, DTLIM + REAL, DIMENSION( kts:kte, its:ite) :: MBARKS, MDWN + REAL, DIMENSION( 1:NSP, its:ite ) :: FS + REAL, DIMENSION( kts:kte ) :: XPLUS, XMINUS + REAL DELC + REAL, DIMENSION( 1:NSP,its:ite,kts:kte ) :: VCI + + REAL, DIMENSION( kts:kte ) :: AI, BI, CI, EI !, Y + REAL, DIMENSION( 1:NSP,kts:kte ) :: DI, UI +! +!--Start Exicutable ---- + + ILX = ite + KL = kte + KLM = kte - 1 + + G1000I = 1.0 / G1000 + KCBLMX = 0 + MBMAX = 0.0 + +!---COMPUTE ACM MIXING RATE + DO I = its, ILX + DTLIM(I) = DTPBL + PSTARI(I) = 1.0 / PSTAR(I) + KCBL(I) = 1 + FSACM(I) = 0.0 + + IF (NOCONV(I) .EQ. 1) THEN + KCBL(I) = KLPBL(I) + +!-------MBARKS IS UPWARD MIXING RATE; MDWN IS DOWNWARD MIXING RATE +!--New couple ACM & EDDY------------------------------------------------------------- + HOVL = -PBL(I) / MOL(I) + FSACM(I) = 1./(1.+((KARMAN/(HOVL))**0.3333)/(0.72*KARMAN)) + MEDDY = EDDYZM(I,1) / (DTPBL * (PBLSIG(I) - SIGMAF(1))) + MBAR = MEDDY * FSACM(I) + DO K = kts,KCBL(I)-1 + EDDYZM(I,K) = EDDYZM(I,K) * (1.0 - FSACM(I)) + ENDDO + + MBMAX = AMAX1(MBMAX,MBAR) + DO K = kts+1,KCBL(I) + MBARKS(K,I) = MBAR + MDWN(K,I) = MBAR * (PBLSIG(I) - SIGMAF(K-1)) * DSIGHI(K) + ENDDO + MBARKS(1,I) = MBAR + MBARKS(KCBL(I),I) = MDWN(KCBL(I),I) + MDWN(KCBL(I)+1,I) = 0.0 + ENDIF + ENDDO ! end of I loop + + DO K = kts,KLM + DO I = its,ILX + EKZ = EDDYZM(I,K) / DTPBL * DSIGHI(K) + DTLIM(I) = AMIN1(0.75 / EKZ,DTLIM(I)) + ENDDO + ENDDO + + DO I = its,ILX + IF (NOCONV(I) .EQ. 1) THEN + KCBLMX = AMAX0(KLPBL(I),KCBLMX) + RZ = (SIGMAF(KCBL(I)) - SIGMAF(1)) * DSIGHI(1) + DTLIM(I) = AMIN1(XX / (MBARKS(1,I) * RZ),DTLIM(I)) + ENDIF + ENDDO + + DO K = kts,KL + DO I = its,ILX + VCI(1,I,K) = US(I,K) + VCI(2,I,K) = VS(I,K) + ENDDO + ENDDO + + NSPX=2 + + DO I = its,ILX + FM = -USTM(I) * USTM(I) * DENSX(I,1) * PSTARI(I) + WSPD = SQRT(US(I,1) * US(I,1) + VS(I,1) * VS(I,1)) + 1.E-9 + FS(1,I) = FM * US(I,1) / WSPD + FS(2,I) = FM * VS(I,1) / WSPD + ENDDO +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + DO I = its,ILX + + NLP = INT(DTPBL / DTLIM(I) + 1.0) + DTS = (DTPBL / NLP) + DTRAT = DTS / DTPBL + DO NL = 1,NLP ! LOOP OVER SUB TIME LOOP + +!-- COMPUTE ARRAY ELEMENTS THAT ARE INDEPENDANT OF SPECIES + + DO K = kts,KL + AI(K) = 0.0 + BI(K) = 0.0 + CI(K) = 0.0 + EI(K) = 0.0 + ENDDO + + DO K = 2, KCBL(I) + EI(K-1) = -CRANKP * MDWN(K,I) * DTS * DSIGH(K) * DSIGHI(K-1) + BI(K) = 1.0 + CRANKP * MDWN(K,I) * DTS + AI(K) = -CRANKP * MBARKS(K,I) * DTS + ENDDO + + EI(1) = EI(1) -EDDYZM(I,1) * CRANKP * DSIGHI(1 )* DTRAT + AI(2) = AI(2) -EDDYZM(I,1) * CRANKP * DSIGHI(2) * DTRAT + + DO K = KCBL(I)+1, KL + BI(K) = 1.0 + ENDDO + + DO K = 2,KL + XPLUS(K) = EDDYZM(I,K) * DSIGHI(K) * DTRAT + XMINUS(K) = EDDYZM(I,K-1) * DSIGHI(K) * DTRAT + CI(K) = - XMINUS(K) * CRANKP + EI(K) = EI(K) - XPLUS(K) * CRANKP + BI(K) = BI(K) + XPLUS(K) * CRANKP + XMINUS(K) * CRANKP + ENDDO + + IF (NOCONV(I) .EQ. 1) THEN + BI(1) = 1.0 + CRANKP * MBARKS(1,I) * (PBLSIG(I) - SIGMAF(1)) * & + DTS * DSIGHI(1) + EDDYZM(I,1) * DSIGHI(1) * CRANKP * DTRAT + ELSE + BI(1) = 1.0 + EDDYZM(I,1) * DSIGHI(1) * CRANKP * DTRAT + ENDIF + + + DO K = 1,KL + DO L = 1,NSPX + DI(L,K) = 0.0 + ENDDO + ENDDO +! +!** COMPUTE TENDENCY OF CBL CONCENTRATIONS - SEMI-IMPLICIT SOLUTION + DO K = 2,KCBL(I) + DO L = 1,NSPX + DELC = DTS * (MBARKS(K,I) * VCI(L,I,1) - MDWN(K,I) * & + VCI(L,I,K) + DSIGH(K+1) * DSIGHI(K) * & + MDWN(K+1,I) * VCI(L,I,K+1)) + DI(L,K) = VCI(L,I,K) + (1.0 - CRANKP) * DELC + ENDDO + ENDDO + + DO K = KCBL(I)+1, KL + DO L = 1,NSPX + DI(L,K) = VCI(L,I,K) + ENDDO + ENDDO + + DO K = 2,KL + IF (K .EQ. KL) THEN + DO L = 1,NSPX + DI(L,K) = DI(L,K) - (1.0 - CRANKP) * XMINUS(K) * & + (VCI(L,I,K) - VCI(L,I,K-1)) + ENDDO + ELSE + DO L = 1,NSPX + DI(L,K) = DI(L,K) + (1.0 - CRANKP) * XPLUS(K) * & + (VCI(L,I,K+1) - VCI(L,I,K)) - & + (1.0 - CRANKP) * XMINUS(K) * & + (VCI(L,I,K) - VCI(L,I,K-1)) + ENDDO + ENDIF + ENDDO + + IF (NOCONV(I) .EQ. 1) THEN + DO L = 1,NSPX + F1 = -G1000I * (MBARKS(1,I) * & + (PBLSIG(I) - SIGMAF(1)) * VCI(L,I,1) - & + MDWN(2,I) * VCI(L,I,2) * DSIGH(2)) + + DI(L,1) = VCI(L,I,1) - G1000 * (FS(L,I) - (1.0 - CRANKP) & + * F1) * DSIGHI(1) * DTS + ENDDO + ELSE + DO L = 1,NSPX + DI(L,1) = VCI(L,I,1) - G1000 * FS(L,I) * DSIGHI(1) * DTS + ENDDO + ENDIF + DO L = 1,NSPX + DI(L,1) = DI(L,1) + (1.0 - CRANKP) * EDDYZM(I,1) * DSIGHI(1) & + * DTRAT * (VCI(L,I,2) - VCI(L,I,1)) + ENDDO + IF ( NOCONV(I) .EQ. 1 ) THEN + CALL MATRIX (AI, BI, CI, DI, EI, UI, KL, NSPX) + ELSE + CALL TRI (CI, BI, EI, DI, UI, KL, NSPX) + END IF +! +!-- COMPUTE NEW THETAV AND Q + DO K = 1,KL + DO L = 1,NSPX + VCI(L,I,K) = UI(L,K) + ENDDO + ENDDO + + ENDDO ! END I LOOP + ENDDO ! END SUB TIME LOOP +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! + DO K = kts,KL + DO I = its,ILX + UX(I,K) = VCI(1,I,K) + VX(I,K) = VCI(2,I,K) + ENDDO + ENDDO + + END SUBROUTINE ACMM +!----------------------------------------------------------------------- !----------------------------------------------------------------------- !----------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_bl_gfs.F b/wrfv2_fire/phys/module_bl_gfs.F index 14407726..67836789 100755 --- a/wrfv2_fire/phys/module_bl_gfs.F +++ b/wrfv2_fire/phys/module_bl_gfs.F @@ -569,7 +569,7 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & & AL(IM,KM-1), AD(IM,KM), & & AU(IM,KM-1), A1(IM,KM), & & A2(IM,KM), THETA(IM,KM), & - & AT(IM,KM*(ntrac-1)),DKU(IM,KM-1),DKT(IM,KM-1) + & AT(IM,KM*(ntrac-1)),DKU(IM,KM-1),DKT(IM,KM-1),WSPM(IM,KM-1) ! RGF added WSPM logical pblflg(IM), sfcflg(IM), stable(IM) ! real(kind=kind_phys) aphi16, aphi5, bet1, bvf2, & @@ -589,6 +589,8 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & & tvu, utend, vk, vk2, & & vpert, vtend, xkzo, zfac, & & zfmin, zk, tem1 + integer kLOC ! RGF + real xDKU ! RGF ! PARAMETER(g=grav) PARAMETER(GOR=G/RD,GOCP=G/CP) @@ -601,6 +603,27 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & PARAMETER(GAMCRT=3.,GAMCRQ=0.) PARAMETER(RZERO=0.,RONE=1.) PARAMETER(IUN=84) +#if HWRF==1 + real*8 :: ran1 !zhang + integer :: ens_random_seed !zhang + real :: ens_pblamp,rr !zhang + logical :: pert_pbl !zhang + logical,save :: pert_pbl_local !zhang + integer,save :: ens_random_seed_local !zhang + real,save :: ens_pblamp_local !zhang + data ens_random_seed_local/0/ +!zz print*, 'zhang in pbl===========' + if ( ens_random_seed_local .eq. 0 ) then + CALL nl_get_pert_pbl(1,pert_pbl) + CALL nl_get_ens_random_seed(1,ens_random_seed) + CALL nl_get_ens_pblamp(1,ens_pblamp) + pert_pbl_local=pert_pbl + ens_random_seed_local=ens_random_seed + ens_pblamp_local=ens_pblamp +!zz print*, "zhang in pbl= one time ", pert_pbl_local, ens_random_seed_local, ens_pblamp_local + endif +!zz print*, "zhang in pbl=",pert_pbl_local, ens_random_seed_local, ens_pblamp_local +#endif ! ! !----------------------------------------------------------------------- @@ -837,6 +860,14 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & RBINT = (RBCR(I)-RBDN(I))/(RBUP(I)-RBDN(I)) ENDIF HPBL(I) = ZL(I,K-1) + RBINT*(ZL(I,k)-ZL(I,K-1)) +#if (HWRF==1) +!zhang adding PBL perturtion + if ( pert_pbl_local ) then + rr=(2.0*ens_pblamp_local*ran1(ens_random_seed_local)-ens_pblamp_local) + print*, "zhang inside the loop", rr, ens_pblamp_local,ens_random_seed_local + HPBL(I) = HPBL(I)*(1.0+rr) + endif +#endif IF(HPBL(I).LT.ZI(I,KPBL(I))) KPBL(I) = KPBL(I) - 1 IF(KPBL(I).LE.1) PBLFLG(I) = .FALSE. ENDIF @@ -845,9 +876,42 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & ! ! COMPUTE DIFFUSION COEFFICIENTS BELOW PBL ! - DO K = 1, KMPBL - DO I=1,IM - IF(KPBL(I).GT.K) THEN + +#if (HWRF==1) +! ------------------------------------------------------------------------------------- +! begin RGF modifications +! this is version MOD05 + + +! RGF determine wspd at roughly 500 m above surface, or as close as possible, reuse SPDK2 +! zi(i,k) is AGL, right? May not matter if applied only to water grid points + if(ALPHA.lt.0)then + + DO I=1,IM + SPDK2 = 0. + WSPM(i,1) = 0. + DO K = 1, KMPBL ! kmpbl is like a max possible pbl height + if(zi(i,k).le.500.and.zi(i,k+1).gt.500.)then ! find level bracketing 500 m + SPDK2 = SQRT(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)) ! wspd near 500 m + WSPM(i,1) = SPDK2/0.6 ! now the Km limit for 500 m. just store in K=1 + WSPM(i,2) = float(k) ! height of level at gridpoint i. store in K=2 +! if(i.eq.25) print *,' IK ',i,k,' ZI ',zi(i,k), ' WSPM1 ',wspm(i,1),' KMPBL ',kmpbl,' KPBL ',kpbl(i) + endif + ENDDO + ENDDO ! i + + endif ! ALPHA < 0 +#endif + + + DO I=1,IM ! RGF SWAPPED ORDER. TESTED - NO IMPACT + DO K = 1, KMPBL + + + +! First guess at DKU. If alpha >= 0, this is the only loop executed + + IF(KPBL(I).GT.K) THEN ! first guess DKU, this is original loop PRINV = 1.0 / (PHIH(I)/PHIM(I)+CFAC*VK*.1) PRINV = MIN(PRINV,PRMAX) PRINV = MAX(PRINV,PRMIN) @@ -859,8 +923,14 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & ! alpha factor (0-1.0) is multiplied to profile function to reduce the effect ! height of the Hurricane Boundary Layer. This is gopal's doing ! + + DKU(i,k) = XKZO + WSCALE(I)*VK*ZI(I,K+1) & - & *ALPHA* ZFAC**PFAC + & *ABS(ALPHA)* ZFAC**PFAC +! if alpha = -1, the above provides the first guess for DKU, based on assumption alpha = +1 +! (other values of alpha < 0 can also be applied) +! if alpha > 0, the above applies the alpha suppression factor and we are finished +! if(i.eq.25) print *,' I25 K ',k,' ORIG DKU ',dku(i,k) DKT(i,k) = DKU(i,k)*PRINV DKO(i,k) = (DKU(i,k)-XKZO)*PRINV DKU(i,k) = MIN(DKU(i,k),DKMAX) @@ -868,9 +938,79 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & DKT(i,k) = MIN(DKT(i,k),DKMAX) DKT(i,k) = MAX(DKT(i,k),DKMIN) DKO(i,k) = MAX(RZERO, MIN(DKMAX, DKO(i,k))) - ENDIF - ENDDO - ENDDO + endif ! KPBL + ENDDO ! K + + +#if (HWRF==1) +! possible modification of first guess DKU, under certain conditions +! (1) this applies only to columns over water + + IF(xland1(i).eq.2)then ! sea only + +! (2) alpha test +! if alpha < 0, find alpha for each column and do the loop again +! if alpha > 0, we are finished + + + if(alpha.lt.0)then ! variable alpha test + +! k-level of layer around 500 m + kLOC = INT(WSPM(i,2)) +! print *,' kLOC ',kLOC,' KPBL ',KPBL(I) + +! (3) only do this IF KPBL(I) >= kLOC. Otherwise, we are finished, with DKU as if alpha = +1 + + if(KPBL(I).ge.kLOC)then + + xDKU = DKU(i,kLOC) ! Km at k-level + +! (4) DKU check. +! WSPM(i,1) is the KM cap for the 500-m level. +! if DKU at 500-m level < WSPM(i,1), do not limit Km ANYWHERE. Alpha = abs(alpha). No need to recalc. +! if DKU at 500-m level > WSPM(i,1), then alpha = WSPM(i,1)/xDKU for entire column + if(xDKU.ge.WSPM(i,1)) then ! ONLY if DKU at 500-m exceeds cap, otherwise already done + + + WSPM(i,3) = WSPM(i,1)/xDKU ! ratio of cap to Km at k-level, store in WSPM(i,3) + WSPM(i,4) = amin1(WSPM(I,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed + +! if(i.eq.25) print *,' I25 kLOC ',kLOC,' xDKU ',xDKU,' WSPM1 ',WSPM(i,1),' WSPM3 ',WSPM(i,3),' WSPM4 ',WSPM(i,4) + + DO K = 1, KMPBL ! now go through K loop again + IF(KPBL(I).GT.K) THEN + PRINV = 1.0 / (PHIH(I)/PHIM(I)+CFAC*VK*.1) + PRINV = MIN(PRINV,PRMAX) + PRINV = MAX(PRINV,PRMIN) +! ZFAC = MAX((1.-(ZI(I,K+1)-ZL1(I))/ & +! & (HPBL(I)-ZL1(I))), ZFMIN) + ZFAC = MAX((1.-(ZI(I,K+1)-ZL(I,1))/ & + & (HPBL(I)-ZL(I,1))), ZFMIN) + + DKU(i,k) = XKZO + WSCALE(I)*VK*ZI(I,K+1) & + & *WSPM(i,4)* ZFAC**PFAC ! recalculated DKU using column alpha +! if(i.eq.25) print *,' I25 K ',k,' DKU AFTER ',dku(i,k) + + + DKT(i,k) = DKU(i,k)*PRINV + DKO(i,k) = (DKU(i,k)-XKZO)*PRINV + DKU(i,k) = MIN(DKU(i,k),DKMAX) + DKU(i,k) = MAX(DKU(i,k),DKMIN) + DKT(i,k) = MIN(DKT(i,k),DKMAX) + DKT(i,k) = MAX(DKT(i,k),DKMIN) + DKO(i,k) = MAX(RZERO, MIN(DKMAX, DKO(i,k))) + ENDIF ! KPBL + ENDDO ! DO K (RGF ALTERED) + endif ! xDKU.ge.WSPM(i,1) + endif ! KPBL(I).ge.kLOC + endif ! alpha < 0 + endif ! xland1 = 2 +#endif + ENDDO ! DO I + +! end RGF modifications +! ------------------------------------------------------------------------------------- + ! ! COMPUTE DIFFUSION COEFFICIENTS OVER PBL (FREE ATMOSPHERE) ! diff --git a/wrfv2_fire/phys/module_bl_gwdo.F b/wrfv2_fire/phys/module_bl_gwdo.F index 280e3280..51fa9b01 100644 --- a/wrfv2_fire/phys/module_bl_gwdo.F +++ b/wrfv2_fire/phys/module_bl_gwdo.F @@ -1,124 +1,124 @@ -! WRf:model_layer:physics -! +!WRF:model_layer:physics ! ! ! ! module module_bl_gwdo contains -! -!------------------------------------------------------------------- -! - subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & - rublten,rvblten, & - dtaux3d,dtauy3d,dusfcg,dvsfcg, & +!------------------------------------------------------------------------------- + subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & + rublten,rvblten, & + dtaux3d,dtauy3d,dusfcg,dvsfcg, & var2d,oc12d,oa2d1,oa2d2,oa2d3,oa2d4,ol2d1,ol2d2,ol2d3,ol2d4, & - znu,znw,mut,p_top, & - cp,g,rd,rv,ep1,pi, & - dt,dx,kpbl2d,itimestep, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & + znu,znw,mut,p_top, & + cp,g,rd,rv,ep1,pi, & + dt,dx,kpbl2d,itimestep, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) -!------------------------------------------------------------------- - implicit none -!------------------------------------------------------------------------------ -! -!-- u3d 3d u-velocity interpolated to theta points (m/s) -!-- v3d 3d v-velocity interpolated to theta points (m/s) -!-- t3d temperature (k) -!-- qv3d 3d water vapor mixing ratio (kg/kg) -!-- p3d 3d pressure (pa) -!-- p3di 3d pressure (pa) at interface level -!-- pi3d 3d exner function (dimensionless) -!-- rublten u tendency due to -! pbl parameterization (m/s/s) -!-- rvblten v tendency due to -!-- cp heat capacity at constant pressure for dry air (j/kg/k) -!-- g acceleration due to gravity (m/s^2) -!-- rd gas constant for dry air (j/kg/k) -!-- z height above sea level (m) -!-- rv gas constant for water vapor (j/kg/k) -!-- dt time step (s) -!-- dx model grid interval (m) -!-- ep1 constant for virtual temperature (r_v/r_d - 1) (dimensionless) -!-- ids start index for i in domain -!-- ide end index for i in domain -!-- jds start index for j in domain -!-- jde end index for j in domain -!-- kds start index for k in domain -!-- kde end index for k in domain -!-- ims start index for i in memory -!-- ime end index for i in memory -!-- jms start index for j in memory -!-- jme end index for j in memory -!-- kms start index for k in memory -!-- kme end index for k in memory -!-- its start index for i in tile -!-- ite end index for i in tile -!-- jts start index for j in tile -!-- jte end index for j in tile -!-- kts start index for k in tile -!-- kte end index for k in tile -!------------------------------------------------------------------- -! - integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! +!-- u3d 3d u-velocity interpolated to theta points (m/s) +!-- v3d 3d v-velocity interpolated to theta points (m/s) +!-- t3d temperature (k) +!-- qv3d 3d water vapor mixing ratio (kg/kg) +!-- p3d 3d pressure (pa) +!-- p3di 3d pressure (pa) at interface level +!-- pi3d 3d exner function (dimensionless) +!-- rublten u tendency due to pbl parameterization (m/s/s) +!-- rvblten v tendency due to pbl parameterization (m/s/s) +!-- znu eta values (sigma values) +!-- cp heat capacity at constant pressure for dry air (j/kg/k) +!-- g acceleration due to gravity (m/s^2) +!-- rd gas constant for dry air (j/kg/k) +!-- z height above sea level (m) +!-- rv gas constant for water vapor (j/kg/k) +!-- dt time step (s) +!-- dx model grid interval (m) +!-- ep1 constant for virtual temperature (r_v/r_d - 1) (dimensionless) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +! +!------------------------------------------------------------------------------- + integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - integer, intent(in ) :: itimestep + integer, intent(in ) :: itimestep ! - real, intent(in ) :: dt,dx,cp,g,rd,rv,ep1,pi + real, intent(in ) :: dt,dx,cp,g,rd,rv,ep1,pi ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: qv3d, & + real, dimension( ims:ime, kms:kme, jms:jme ) , & + intent(in ) :: qv3d, & p3d, & pi3d, & t3d, & z - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: p3di + real, dimension( ims:ime, kms:kme, jms:jme ) , & + intent(in ) :: p3di ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: rublten, & + real, dimension( ims:ime, kms:kme, jms:jme ) , & + intent(inout) :: rublten, & rvblten - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(inout) :: dtaux3d, & + real, dimension( ims:ime, kms:kme, jms:jme ) , & + intent(inout) :: dtaux3d, & dtauy3d ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: u3d, & + real, dimension( ims:ime, kms:kme, jms:jme ) , & + intent(in ) :: u3d, & v3d ! - integer, dimension( ims:ime, jms:jme ) , & - intent(in ) :: kpbl2d - real, dimension( ims:ime, jms:jme ) , & - intent(inout ) :: dusfcg, & + integer, dimension( ims:ime, jms:jme ) , & + intent(in ) :: kpbl2d + real, dimension( ims:ime, jms:jme ) , & + intent(inout ) :: dusfcg, & dvsfcg ! - real, dimension( ims:ime, jms:jme ) , & - intent(in ) :: var2d, & + real, dimension( ims:ime, jms:jme ) , & + intent(in ) :: var2d, & oc12d, & oa2d1,oa2d2,oa2d3,oa2d4, & ol2d1,ol2d2,ol2d3,ol2d4 + real, dimension( ims:ime, jms:jme ) , & + optional , & + intent(in ) :: mut ! - real, dimension( ims:ime, jms:jme ) , & - optional , & - intent(in ) :: mut -! - real, dimension( kms:kme ) , & - optional , & - intent(in ) :: znu, & + real, dimension( kms:kme ) , & + optional , & + intent(in ) :: znu, & znw ! - real, optional, intent(in ) :: p_top + real, optional, intent(in ) :: p_top ! !local ! - real, dimension( its:ite, kts:kte ) :: delprsi, & + real, dimension( its:ite, kts:kte ) :: delprsi, & pdh - real, dimension( its:ite, kts:kte+1 ) :: pdhi - real, dimension( its:ite, 4 ) :: oa4, & + real, dimension( its:ite, kts:kte+1 ) :: pdhi + real, dimension( its:ite, 4 ) :: oa4, & ol4 - integer :: i,j,k,kdt + integer :: i,j,k,kdt,kpblmax +! + do k = kts,kte + if(znu(k).gt.0.6) kpblmax = k + 1 + enddo ! do j = jts,jte if(present(mut))then @@ -153,430 +153,467 @@ subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z, & ol4(i,3) = ol2d3(i,j) ol4(i,4) = ol2d4(i,j) enddo - call gwdo2d(dudt=rublten(ims,kms,j),dvdt=rvblten(ims,kms,j) & - ,dtaux2d=dtaux3d(ims,kms,j),dtauy2d=dtauy3d(ims,kms,j) & - ,u1=u3d(ims,kms,j),v1=v3d(ims,kms,j) & - ,t1=t3d(ims,kms,j),q1=qv3d(ims,kms,j) & - ,prsi=pdhi(its,kts),del=delprsi(its,kts) & - ,prsl=pdh(its,kts),prslk=pi3d(ims,kms,j) & - ,zl=z(ims,kms,j),rcl=1.0 & - ,dusfc=dusfcg(ims,j),dvsfc=dvsfcg(ims,j) & - ,var=var2d(ims,j),oc1=oc12d(ims,j) & - ,oa4=oa4,ol4=ol4 & - ,g=g,cp=cp,rd=rd,rv=rv,fv=ep1,pi=pi & - ,dxmeter=dx,deltim=dt & - ,kpbl=kpbl2d(ims,j),kdt=itimestep,lat=j & - ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde & - ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme & - ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte ) + call gwdo2d(dudt=rublten(ims,kms,j),dvdt=rvblten(ims,kms,j) & + ,dtaux2d=dtaux3d(ims,kms,j),dtauy2d=dtauy3d(ims,kms,j) & + ,u1=u3d(ims,kms,j),v1=v3d(ims,kms,j) & + ,t1=t3d(ims,kms,j),q1=qv3d(ims,kms,j) & + ,del=delprsi(its,kts) & + ,prsi=pdhi(its,kts) & + ,prsl=pdh(its,kts),prslk=pi3d(ims,kms,j) & + ,zl=z(ims,kms,j),rcl=1.0 & + ,kpblmax=kpblmax & + ,dusfc=dusfcg(ims,j),dvsfc=dvsfcg(ims,j) & + ,var=var2d(ims,j),oc1=oc12d(ims,j) & + ,oa4=oa4,ol4=ol4 & + ,g=g,cp=cp,rd=rd,rv=rv,fv=ep1,pi=pi & + ,dxmeter=dx,deltim=dt & + ,kpbl=kpbl2d(ims,j),kdt=itimestep,lat=j & + ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde & + ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme & + ,its=its,ite=ite, jts=jts,jte=jte, kts=kts,kte=kte ) enddo -! ! end subroutine gwdo -! -!------------------------------------------------------------------- -! -! -! -! - subroutine gwdo2d(dudt,dvdt,dtaux2d,dtauy2d, & - u1,v1,t1,q1, & - prsi,del,prsl,prslk,zl,rcl, & - var,oc1,oa4,ol4,dusfc,dvsfc, & - g,cp,rd,rv,fv,pi,dxmeter,deltim,kpbl,kdt,lat, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine gwdo2d(dudt,dvdt,dtaux2d,dtauy2d, & + u1,v1,t1,q1, & + del, & + prsi,prsl,prslk,zl,rcl,kpblmax, & + var,oc1,oa4,ol4,dusfc,dvsfc, & + g,cp,rd,rv,fv,pi,dxmeter,deltim,kpbl,kdt,lat, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte) -!------------------------------------------------------------------- -! -! this code handles the time tendencies of u v due to the effect of mountain -! induced gravity wave drag from sub-grid scale orography. this routine -! not only treats the traditional upper-level wave breaking due to mountain -! variance (alpert 1988), but also the enhanced lower-tropospheric wave -! breaking due to mountain convexity and asymmetry (kim and arakawa 1995). -! thus, in addition to the terrain height data in a model grid gox, -! additional 10-2d topographic statistics files are needed, including -! orographic standard deviation (var), convexity (oc1), asymmetry (oa4) -! and ol (ol4). these data sets are prepared based on the 30 sec usgs orography -! hong (1999). the current scheme was implmented as in hong et al.(2008) -! -! coded by song-you hong and young-joon kim and implemented by song-you hong -! -! references: -! hong et al. (2008), wea. and forecasting -! kim and arakawa (1995), j. atmos. sci. -! alpet et al. (1988), NWP conference. -! hong (1999), NCEP office note 424. -! -! notice : comparible or lower resolution orography files than model resolution -! are desirable in preprocess (wps) to prevent weakening of the drag -!------------------------------------------------------------------- -! -! input -! dudt (ims:ime,kms:kme) non-lin tendency for u wind component -! dvdt (ims:ime,kms:kme) non-lin tendency for v wind component -! u1(ims:ime,kms:kme) zonal wind / sqrt(rcl) m/sec at t0-dt -! v1(ims:ime,kms:kme) meridional wind / sqrt(rcl) m/sec at t0-dt -! t1(ims:ime,kms:kme) temperature deg k at t0-dt -! q1(ims:ime,kms:kme) specific humidity at t0-dt -! -! rcl a scaling factor = reciprocal of square of cos(lat) -! for mrf gsm. rcl=1 if u1 and v1 are wind components. -! deltim time step secs -! del(kts:kte) positive increment of pressure across layer (pa) -! -! output -! dudt, dvdt wind tendency due to gwdo -! -!------------------------------------------------------------------- +!------------------------------------------------------------------------------- +! +! this code handles the time tendencies of u v due to the effect of mountain +! induced gravity wave drag from sub-grid scale orography. this routine +! not only treats the traditional upper-level wave breaking due to mountain +! variance (alpert 1988), but also the enhanced lower-tropospheric wave +! breaking due to mountain convexity and asymmetry (kim and arakawa 1995). +! thus, in addition to the terrain height data in a model grid gox, +! additional 10-2d topographic statistics files are needed, including +! orographic standard deviation (var), convexity (oc1), asymmetry (oa4) +! and ol (ol4). these data sets are prepared based on the 30 sec usgs orography +! hong (1999). the current scheme was implmented as in hong et al.(2008) +! +! coded by song-you hong and young-joon kim and implemented by song-you hong +! +! program history log: +! 2014-10-01 Hyun-Joo Choi (from KIAPS) flow-blocking drag of kim and doyle +! with blocked height by dividing streamline theory +! +! references: +! hong et al. (2008), wea. and forecasting +! kim and doyle (2005), Q. J. R. Meteor. Soc. +! kim and arakawa (1995), j. atmos. sci. +! alpet et al. (1988), NWP conference. +! hong (1999), NCEP office note 424. +! +! notice : comparible or lower resolution orography files than model resolution +! are desirable in preprocess (wps) to prevent weakening of the drag +!------------------------------------------------------------------------------- +! +! input +! dudt (ims:ime,kms:kme) non-lin tendency for u wind component +! dvdt (ims:ime,kms:kme) non-lin tendency for v wind component +! u1(ims:ime,kms:kme) zonal wind / sqrt(rcl) m/sec at t0-dt +! v1(ims:ime,kms:kme) meridional wind / sqrt(rcl) m/sec at t0-dt +! t1(ims:ime,kms:kme) temperature deg k at t0-dt +! q1(ims:ime,kms:kme) specific humidity at t0-dt +! +! rcl a scaling factor = reciprocal of square of cos(lat) +! for gmp. rcl=1 if u1 and v1 are wind components. +! deltim time step secs +! del(kts:kte) positive increment of pressure across layer (pa) +! +! output +! dudt, dvdt wind tendency due to gwdo +! +!------------------------------------------------------------------------------- implicit none -!------------------------------------------------------------------- - integer :: kdt,lat,latd,lond, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & +!------------------------------------------------------------------------------- + integer :: kdt,lat,latd,lond,kpblmax, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ! - real :: g,rd,rv,fv,cp,pi,dxmeter,deltim,rcl - real :: dudt(ims:ime,kms:kme),dvdt(ims:ime,kms:kme), & + real :: g,rd,rv,fv,cp,pi,dxmeter,deltim,rcl + real :: dudt(ims:ime,kms:kme),dvdt(ims:ime,kms:kme), & dtaux2d(ims:ime,kms:kme),dtauy2d(ims:ime,kms:kme), & - u1(ims:ime,kms:kme),v1(ims:ime,kms:kme), & - t1(ims:ime,kms:kme),q1(ims:ime,kms:kme), & - zl(ims:ime,kms:kme),prslk(ims:ime,kms:kme) - real :: prsl(its:ite,kts:kte),prsi(its:ite,kts:kte+1), & - del(its:ite,kts:kte) - real :: oa4(its:ite,4),ol4(its:ite,4) -! - integer :: kpbl(ims:ime) - real :: var(ims:ime),oc1(ims:ime), & + u1(ims:ime,kms:kme),v1(ims:ime,kms:kme), & + t1(ims:ime,kms:kme),q1(ims:ime,kms:kme), & + zl(ims:ime,kms:kme),prsl(its:ite,kts:kte), & + prslk(ims:ime,kms:kme) + real :: prsi(its:ite,kts:kte+1),del(its:ite,kts:kte) + real :: oa4(its:ite,4),ol4(its:ite,4) +! + integer :: kpbl(ims:ime) + real :: var(ims:ime),oc1(ims:ime), & dusfc(ims:ime),dvsfc(ims:ime) +! ! critical richardson number for wave breaking : ! larger drag with larger value ! - real,parameter :: ric = 0.25 -! - real,parameter :: dw2min = 1. - real,parameter :: rimin = -100. - real,parameter :: bnv2min = 1.0e-5 - real,parameter :: efmin = 0.0 - real,parameter :: efmax = 10.0 - real,parameter :: xl = 4.0e4 - real,parameter :: critac = 1.0e-5 - real,parameter :: gmax = 1. - real,parameter :: veleps = 1.0 - real,parameter :: factop = 0.5 - real,parameter :: frc = 1.0 - real,parameter :: ce = 0.8 - real,parameter :: cg = 0.5 -! -! local variables -! - integer :: i,k,lcap,lcapp1,nwd,idir,kpblmin,kpblmax, & + real,parameter :: ric = 0.25 +! + real,parameter :: dw2min = 1. + real,parameter :: rimin = -100. + real,parameter :: bnv2min = 1.0e-5 + real,parameter :: efmin = 0.0 + real,parameter :: efmax = 10.0 + real,parameter :: xl = 4.0e4 + real,parameter :: critac = 1.0e-5 + real,parameter :: gmax = 1. + real,parameter :: veleps = 1.0 + real,parameter :: factop = 0.5 + real,parameter :: frc = 1.0 + real,parameter :: ce = 0.8 + real,parameter :: cg = 0.5 + integer,parameter :: kpblmin = 2 +! +! local variables +! + integer :: i,k,lcap,lcapp1,nwd,idir, & klcap,kp1,ikount,kk ! - real :: rcs,rclcs,csg,fdir,cleff,cs,rcsks, & - wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, & - wtkbj,coefm,tem,gfobnv,hd,fro,rim,temc,tem1,efact, & + real :: rcs,rclcs,csg,fdir,cleff,cs,rcsks, & + wdir,ti,rdz,temp,tem2,dw2,shr2,bvf2,rdelks, & + wtkbj,tem,gfobnv,hd,fro,rim,temc,tem1,efact, & temv,dtaux,dtauy ! - logical :: ldrag(its:ite),icrilv(its:ite), & + logical :: ldrag(its:ite),icrilv(its:ite), & flag(its:ite),kloop1(its:ite) -! - real :: taub(its:ite),taup(its:ite,kts:kte+1), & - xn(its:ite),yn(its:ite), & - ubar(its:ite),vbar(its:ite), & - fr(its:ite),ulow(its:ite), & - rulow(its:ite),bnv(its:ite), & - oa(its:ite),ol(its:ite), & - roll(its:ite),dtfac(its:ite), & - brvf(its:ite),xlinv(its:ite), & - delks(its:ite),delks1(its:ite), & - bnv2(its:ite,kts:kte),usqj(its:ite,kts:kte), & - taud(its:ite,kts:kte),ro(its:ite,kts:kte), & - vtk(its:ite,kts:kte),vtj(its:ite,kts:kte), & - zlowtop(its:ite),velco(its:ite,kts:kte-1) -! - integer :: kbl(its:ite),klowtop(its:ite), & - lowlv(its:ite) +! + real :: taub(its:ite),taup(its:ite,kts:kte+1), & + xn(its:ite),yn(its:ite), & + ubar(its:ite),vbar(its:ite), & + fr(its:ite),ulow(its:ite), & + rulow(its:ite),bnv(its:ite), & + oa(its:ite),ol(its:ite), & + roll(its:ite),dtfac(its:ite), & + brvf(its:ite),xlinv(its:ite), & + delks(its:ite),delks1(its:ite), & + bnv2(its:ite,kts:kte),usqj(its:ite,kts:kte), & + taud(its:ite,kts:kte),ro(its:ite,kts:kte), & + vtk(its:ite,kts:kte),vtj(its:ite,kts:kte), & + zlowtop(its:ite),velco(its:ite,kts:kte-1), & + coefm(its:ite) +! + integer :: kbl(its:ite),klowtop(its:ite) ! logical :: iope - integer,parameter :: mdir=8 - integer :: nwdir(mdir) + integer,parameter :: mdir=8 + integer :: nwdir(mdir) data nwdir/6,7,5,8,2,3,1,4/ ! -! initialize local variables -! - kbl=0 ; klowtop=0 ; lowlv=0 -! -!---- constants -! - rcs = sqrt(rcl) - cs = 1. / sqrt(rcl) - csg = cs * g - lcap = kte - lcapp1 = lcap + 1 - fdir = mdir / (2.0*pi) -! -! -!!!!!!! cleff (subgrid mountain scale ) is highly tunable parameter -!!!!!!! the bigger (smaller) value produce weaker (stronger) wave drag -! - cleff = max(dxmeter,50.e3) -! -! initialize!! -! +! variables for flow-blocking drag +! + real,parameter :: frmax = 10. + real,parameter :: olmin = 1.0e-5 + real,parameter :: odmin = 0.1 + real,parameter :: odmax = 10. + real,parameter :: erad = 6371.315e+3 + integer :: komax(its:ite) + integer :: kblk + real :: cd + real :: zblk,tautem + real :: pe,ke + real :: delx,dely,dxy4(4),dxy4p(4) + real :: dxy(its:ite),dxyp(its:ite) + real :: ol4p(4),olp(its:ite),od(its:ite) + real :: taufb(its:ite,kts:kte+1) +! +!---- constants +! + rcs = sqrt(rcl) + cs = 1. / sqrt(rcl) + csg = cs * g + lcap = kte + lcapp1 = lcap + 1 + fdir = mdir / (2.0*pi) +! +!--- calculate length of grid for flow-blocking drag +! + delx = dxmeter + dely = dxmeter + dxy4(1) = delx + dxy4(2) = dely + dxy4(3) = sqrt(delx*delx + dely*dely) + dxy4(4) = dxy4(3) + dxy4p(1) = dxy4(2) + dxy4p(2) = dxy4(1) + dxy4p(3) = dxy4(4) + dxy4p(4) = dxy4(3) +! +! +!-----initialize arrays +! dtaux = 0.0 dtauy = 0.0 + do i = its,ite + klowtop(i) = 0 + kbl(i) = 0 + enddo +! + do i = its,ite + xn(i) = 0.0 + yn(i) = 0.0 + ubar (i) = 0.0 + vbar (i) = 0.0 + roll (i) = 0.0 + taub (i) = 0.0 + taup(i,1) = 0.0 + oa(i) = 0.0 + ol(i) = 0.0 + ulow (i) = 0.0 + dtfac(i) = 1.0 + ldrag(i) = .false. + icrilv(i) = .false. + flag(i) = .true. + enddo +! do k = kts,kte do i = its,ite usqj(i,k) = 0.0 bnv2(i,k) = 0.0 - vtj(i,k) = 0.0 - vtk(i,k) = 0.0 + vtj(i,k) = 0.0 + vtk(i,k) = 0.0 taup(i,k) = 0.0 taud(i,k) = 0.0 dtaux2d(i,k)= 0.0 dtauy2d(i,k)= 0.0 enddo enddo +! do i = its,ite taup(i,kte+1) = 0.0 - xlinv(i) = 1.0/xl + xlinv(i) = 1.0/xl enddo +! +! initialize array for flow-blocking drag +! + taufb(its:ite,kts:kte+1) = 0.0 + komax(its:ite) = 0 ! do k = kts,kte do i = its,ite - vtj(i,k) = t1(i,k) * (1.+fv*q1(i,k)) - vtk(i,k) = vtj(i,k) / prslk(i,k) - ro(i,k) = 1./rd * prsl(i,k) / vtj(i,k) ! density kg/m**3 + vtj(i,k) = t1(i,k) * (1.+fv*q1(i,k)) + vtk(i,k) = vtj(i,k) / prslk(i,k) + ro(i,k) = 1./rd * prsl(i,k) / vtj(i,k) ! density kg/m**3 enddo enddo +! +! determine reference level: maximum of 2*var and pbl heights ! do i = its,ite zlowtop(i) = 2. * var(i) enddo -! -!--- determine new reference level > 2*var ! do i = its,ite kloop1(i) = .true. enddo +! do k = kts+1,kte do i = its,ite if(kloop1(i).and.zl(i,k)-zl(i,1).ge.zlowtop(i)) then klowtop(i) = k+1 - kloop1(i) = .false. + kloop1(i) = .false. endif enddo enddo ! - kpblmax = 2 do i = its,ite - kbl(i) = max(2, kpbl(i)) - kbl(i) = max(kbl(i), klowtop(i)) - delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) - ubar (i) = 0.0 - vbar (i) = 0.0 - taup(i,1) = 0.0 - oa(i) = 0.0 - kpblmax = max(kpblmax,kbl(i)) - flag(i) = .true. - lowlv(i) = 2 + kbl(i) = max(kpbl(i), klowtop(i)) + kbl(i) = max(min(kbl(i),kpblmax),kpblmin) enddo - kpblmax = min(kpblmax+1,kte-1) ! -! compute low level averages within pbl +! determine the level of maximum orographic height +! + komax(:) = kbl(:) +! + do i = its,ite + delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) + delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) + enddo +! +! compute low level averages within pbl ! do k = kts,kpblmax do i = its,ite if (k.lt.kbl(i)) then - rcsks = rcs * del(i,k) * delks(i) - ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean - vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean + rcsks = rcs * del(i,k) * delks(i) + rdelks = del(i,k) * delks(i) + ubar(i) = ubar(i) + rcsks * u1(i,k) ! pbl u mean + vbar(i) = vbar(i) + rcsks * v1(i,k) ! pbl v mean + roll(i) = roll(i) + rdelks * ro(i,k) ! ro mean endif enddo enddo ! -! figure out low-level horizontal wind direction -! -! nwd 1 2 3 4 5 6 7 8 -! wd w s sw nw e n ne se +! figure out low-level horizontal wind direction ! - do i = its,ite - wdir = atan2(ubar(i),vbar(i)) + pi - idir = mod(nint(fdir*wdir),mdir) + 1 - nwd = nwdir(idir) - oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) - ol(i) = ol4(i,mod(nwd-1,4)+1) - enddo +! nwd 1 2 3 4 5 6 7 8 +! wd w s sw nw e n ne se ! - kpblmin = kte - do i = its,ite - kpblmin = min(kpblmin, kbl(i)) - enddo + do i = its,ite + wdir = atan2(ubar(i),vbar(i)) + pi + idir = mod(nint(fdir*wdir),mdir) + 1 + nwd = nwdir(idir) + oa(i) = (1-2*int( (nwd-1)/4 )) * oa4(i,mod(nwd-1,4)+1) + ol(i) = ol4(i,mod(nwd-1,4)+1) ! - do i = its,ite - if (oa(i).le.0.0) kbl(i) = kpbl(i) + 1 - enddo +!----- compute orographic width along (ol) and perpendicular (olp) +!----- the direction of wind ! - do i = its,ite - delks(i) = 1.0 / (prsi(i,1) - prsi(i,kbl(i))) - delks1(i) = 1.0 / (prsl(i,1) - prsl(i,kbl(i))) - enddo + ol4p(1) = ol4(i,2) + ol4p(2) = ol4(i,1) + ol4p(3) = ol4(i,4) + ol4p(4) = ol4(i,3) + olp(i) = ol4p(mod(nwd-1,4)+1) ! -!--- saving richardson number in usqj for migwdi +!----- compute orographic direction (horizontal orographic aspect ratio) ! - do k = kts,kte-1 - do i = its,ite - ti = 2.0 / (t1(i,k)+t1(i,k+1)) - rdz = 1./(zl(i,k+1) - zl(i,k)) - tem1 = u1(i,k) - u1(i,k+1) - tem2 = v1(i,k) - v1(i,k+1) - dw2 = rcl*(tem1*tem1 + tem2*tem2) - shr2 = max(dw2,dw2min) * rdz * rdz - bvf2 = g*(g/cp+rdz*(vtj(i,k+1)-vtj(i,k))) * ti - usqj(i,k) = max(bvf2/shr2,rimin) - bnv2(i,k) = 2*g*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) - bnv2(i,k) = max( bnv2(i,k), bnv2min ) - enddo - enddo + od(i) = olp(i)/max(ol(i),olmin) + od(i) = min(od(i),odmax) + od(i) = max(od(i),odmin) ! -!-----initialize arrays +!----- compute length of grid in the along(dxy) and cross(dxyp) wind directions ! - do i = its,ite - xn(i) = 0.0 - yn(i) = 0.0 - ubar (i) = 0.0 - vbar (i) = 0.0 - roll (i) = 0.0 - taub (i) = 0.0 - ulow (i) = 0.0 - dtfac(i) = 1.0 - ldrag(i) = .false. - icrilv(i) = .false. ! initialize critical level control vector + dxy(i) = dxy4(MOD(nwd-1,4)+1) + dxyp(i) = dxy4p(MOD(nwd-1,4)+1) enddo +! +!--- saving richardson number in usqj for migwdi ! -!---- compute low level averages -!---- (u,v)*cos(lat) use uv=(u1,v1) which is wind at t0-1 -!---- use rcs=1/cos(lat) to get wind field -! - do k = 1,kpblmax - do i = its,ite - if (k .lt. kbl(i)) then - rdelks = del(i,k) * delks(i) - rcsks = rcs * rdelks - ubar(i) = ubar(i) + rcsks * u1(i,k) ! u mean - vbar(i) = vbar(i) + rcsks * v1(i,k) ! v mean - roll(i) = roll(i) + rdelks * ro(i,k) ! ro mean - endif - enddo - enddo -! -!----compute the "low level" or 1/3 wind magnitude (m/s) + do k = kts,kte-1 + do i = its,ite + ti = 2.0 / (t1(i,k)+t1(i,k+1)) + rdz = 1./(zl(i,k+1) - zl(i,k)) + tem1 = u1(i,k) - u1(i,k+1) + tem2 = v1(i,k) - v1(i,k+1) + dw2 = rcl*(tem1*tem1 + tem2*tem2) + shr2 = max(dw2,dw2min) * rdz * rdz + bvf2 = g*(g/cp+rdz*(vtj(i,k+1)-vtj(i,k))) * ti + usqj(i,k) = max(bvf2/shr2,rimin) + bnv2(i,k) = 2.0*g*rdz*(vtk(i,k+1)-vtk(i,k))/(vtk(i,k+1)+vtk(i,k)) + bnv2(i,k) = max( bnv2(i,k), bnv2min ) + enddo + enddo ! - do i = its,ite +!----compute the "low level" or 1/3 wind magnitude (m/s) +! + do i = its,ite ulow(i) = max(sqrt(ubar(i)*ubar(i) + vbar(i)*vbar(i)), 1.0) rulow(i) = 1./ulow(i) - enddo + enddo ! - do k = kts,kte-1 - do i = its,ite - velco(i,k) = (0.5*rcs) * ((u1(i,k)+u1(i,k+1)) * ubar(i) & - + (v1(i,k)+v1(i,k+1)) * vbar(i)) - velco(i,k) = velco(i,k) * rulow(i) + do k = kts,kte-1 + do i = its,ite + velco(i,k) = (0.5*rcs) * ((u1(i,k)+u1(i,k+1)) * ubar(i) & + + (v1(i,k)+v1(i,k+1)) * vbar(i)) + velco(i,k) = velco(i,k) * rulow(i) if ((velco(i,k).lt.veleps) .and. (velco(i,k).gt.0.)) then - velco(i,k) = veleps + velco(i,k) = veleps endif - enddo - enddo -! -! no drag when critical level in the base layer -! - do i = its,ite - ldrag(i) = velco(i,1).le.0. - enddo -! - do k = kts+1,kpblmax-1 - do i = its,ite + enddo + enddo +! +! no drag when critical level in the base layer +! + do i = its,ite + ldrag(i) = velco(i,1).le.0. + enddo +! +! no drag when velco.lt.0 +! + do k = kpblmin,kpblmax + do i = its,ite if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. velco(i,k).le.0. - enddo - enddo -! -! no drag when bnv2.lt.0 -! - do k = kts,kpblmax-1 - do i = its,ite + enddo + enddo +! +! no drag when bnv2.lt.0 +! + do k = kts,kpblmax + do i = its,ite if (k .lt. kbl(i)) ldrag(i) = ldrag(i).or. bnv2(i,k).lt.0. - enddo - enddo -! -!-----the low level weighted average ri is stored in usqj(1,1; im) -!-----the low level weighted average n**2 is stored in bnv2(1,1; im) -!---- this is called bnvl2 in phys_gwd_alpert_sub not bnv2 -!---- rdelks (del(k)/delks) vert ave factor so we can * instead of / -! - do i = its,ite - wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) - bnv2(i,1) = wtkbj * bnv2(i,1) - usqj(i,1) = wtkbj * usqj(i,1) - enddo -! - do k = kts+1,kpblmax-1 - do i = its,ite + enddo + enddo +! +!-----the low level weighted average ri is stored in usqj(1,1; im) +!-----the low level weighted average n**2 is stored in bnv2(1,1; im) +!---- this is called bnvl2 in phys_gwd_alpert_sub not bnv2 +!---- rdelks (del(k)/delks) vert ave factor so we can * instead of / +! + do i = its,ite + wtkbj = (prsl(i,1)-prsl(i,2)) * delks1(i) + bnv2(i,1) = wtkbj * bnv2(i,1) + usqj(i,1) = wtkbj * usqj(i,1) + enddo +! + do k = kpblmin,kpblmax + do i = its,ite if (k .lt. kbl(i)) then - rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) + rdelks = (prsl(i,k)-prsl(i,k+1)) * delks1(i) bnv2(i,1) = bnv2(i,1) + bnv2(i,k) * rdelks usqj(i,1) = usqj(i,1) + usqj(i,k) * rdelks endif - enddo - enddo -! - do i = its,ite - ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 - ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 + enddo + enddo +! + do i = its,ite + ldrag(i) = ldrag(i) .or. bnv2(i,1).le.0.0 + ldrag(i) = ldrag(i) .or. ulow(i).eq.1.0 ldrag(i) = ldrag(i) .or. var(i) .le. 0.0 - enddo -! -! ----- set all ri low level values to the low level value -! - do k = kts+1,kpblmax-1 - do i = its,ite + enddo +! +! set all ri low level values to the low level value +! + do k = kpblmin,kpblmax + do i = its,ite if (k .lt. kbl(i)) usqj(i,k) = usqj(i,1) - enddo - enddo -! - do i = its,ite - if (.not.ldrag(i)) then - bnv(i) = sqrt( bnv2(i,1) ) - fr(i) = bnv(i) * rulow(i) * var(i) - xn(i) = ubar(i) * rulow(i) - yn(i) = vbar(i) * rulow(i) + enddo + enddo +! + do i = its,ite + if (.not.ldrag(i)) then + bnv(i) = sqrt( bnv2(i,1) ) + fr(i) = bnv(i) * rulow(i) * 2. * var(i) * od(i) + fr(i) = min(fr(i),frmax) + xn(i) = ubar(i) * rulow(i) + yn(i) = vbar(i) * rulow(i) endif enddo ! -! compute the base level stress and store it in taub -! calculate enhancement factor, number of mountains & aspect -! ratio const. use simplified relationship between standard -! deviation & critical hgt +! compute the base level stress and store it in taub +! calculate enhancement factor, number of mountains & aspect +! ratio const. use simplified relationship between standard +! deviation & critical hgt ! - do i = its,ite - if (.not. ldrag(i)) then - efact = (oa(i) + 2.) ** (ce*fr(i)/frc) - efact = min( max(efact,efmin), efmax ) - coefm = (1. + ol(i)) ** (oa(i)+1.) - xlinv(i) = coefm / cleff - tem = fr(i) * fr(i) * oc1(i) - gfobnv = gmax * tem / ((tem + cg)*bnv(i)) - taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & - * ulow(i) * gfobnv * efact - else - taub(i) = 0.0 - xn(i) = 0.0 - yn(i) = 0.0 - endif - enddo -! -! now compute vertical structure of the stress. -! -!----set up bottom values of stress + do i = its,ite + if (.not. ldrag(i)) then + efact = (oa(i) + 2.) ** (ce*fr(i)/frc) + efact = min( max(efact,efmin), efmax ) +!!!!!!! cleff (effective grid length) is highly tunable parameter +!!!!!!! the bigger (smaller) value produce weaker (stronger) wave drag + cleff = sqrt(dxy(i)**2. + dxyp(i)**2.) + cleff = 3. * max(dxmeter,cleff) + coefm(i) = (1. + ol(i)) ** (oa(i)+1.) + xlinv(i) = coefm(i) / cleff + tem = fr(i) * fr(i) * oc1(i) + gfobnv = gmax * tem / ((tem + cg)*bnv(i)) + taub(i) = xlinv(i) * roll(i) * ulow(i) * ulow(i) & + * ulow(i) * gfobnv * efact + else + taub(i) = 0.0 + xn(i) = 0.0 + yn(i) = 0.0 + endif + enddo +! +! now compute vertical structure of the stress. ! do k = kts,kpblmax do i = its,ite @@ -584,117 +621,156 @@ subroutine gwdo2d(dudt,dvdt,dtaux2d,dtauy2d, & enddo enddo ! - do k = kpblmin, kte-1 ! vertical level k loop! + do k = kpblmin, kte-1 ! vertical level k loop! kp1 = k + 1 do i = its,ite ! -!-----unstablelayer if ri < ric -!-----unstable layer if upper air vel comp along surf vel <=0 (crit lay) -!---- at (u-c)=0. crit layer exists and bit vector should be set (.le.) +! unstablelayer if ri < ric +! unstable layer if upper air vel comp along surf vel <=0 (crit lay) +! at (u-c)=0. crit layer exists and bit vector should be set (.le.) ! if (k .ge. kbl(i)) then - icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & + icrilv(i) = icrilv(i) .or. ( usqj(i,k) .lt. ric) & .or. (velco(i,k) .le. 0.0) - brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared - brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency + brvf(i) = max(bnv2(i,k),bnv2min) ! brunt-vaisala frequency squared + brvf(i) = sqrt(brvf(i)) ! brunt-vaisala frequency endif enddo ! do i = its,ite - if (k .ge. kbl(i) .and. (.not. ldrag(i))) then + if (k .ge. kbl(i) .and. (.not. ldrag(i))) then if (.not.icrilv(i) .and. taup(i,k) .gt. 0.0 ) then temv = 1.0 / velco(i,k) - tem1 = xlinv(i)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5 - hd = sqrt(taup(i,k) / tem1) - fro = brvf(i) * hd * temv + tem1 = coefm(i)/dxy(i)*(ro(i,kp1)+ro(i,k))*brvf(i)*velco(i,k)*0.5 + hd = sqrt(taup(i,k) / tem1) + fro = brvf(i) * hd * temv ! -! rim is the minimum-richardson number by shutts (1985) +! rim is the minimum-richardson number by shutts (1985) ! - tem2 = sqrt(usqj(i,k)) - tem = 1. + tem2 * fro - rim = usqj(i,k) * (1.-fro) / (tem * tem) + tem2 = sqrt(usqj(i,k)) + tem = 1. + tem2 * fro + rim = usqj(i,k) * (1.-fro) / (tem * tem) ! -! check stability to employ the 'saturation hypothesis' -! of lindzen (1981) except at tropospheric downstream regions +! check stability to employ the 'saturation hypothesis' +! of lindzen (1981) except at tropospheric downstream regions ! - if (rim .le. ric) then ! saturation hypothesis! - if ((oa(i) .le. 0. .or. kp1 .ge. lowlv(i) )) then + if (rim .le. ric) then ! saturation hypothesis! + if ((oa(i) .le. 0.).or.(kp1 .ge. kpblmin )) then temc = 2.0 + 1.0 / tem2 - hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) + hd = velco(i,k) * (2.*sqrt(temc)-temc) / brvf(i) taup(i,kp1) = tem1 * hd * hd endif - else ! no wavebreaking! + else ! no wavebreaking! taup(i,kp1) = taup(i,k) endif endif endif - enddo + enddo enddo ! - if(lcap.lt.kte) then - do klcap = lcapp1,kte - do i = its,ite - taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) - enddo - enddo - endif + if(lcap.lt.kte) then + do klcap = lcapp1,kte + do i = its,ite + taup(i,klcap) = prsi(i,klcap) / prsi(i,lcap) * taup(i,lcap) + enddo + enddo + endif + do i = its,ite + if(.not.ldrag(i)) then ! -! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy +!------- determine the height of flow-blocking layer ! - do k = kts,kte - do i = its,ite - taud(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) - enddo - enddo + kblk = 0 + pe = 0.0 + do k = kte, kpblmin, -1 + if(kblk.eq.0 .and. k.le.komax(i)) then + pe = pe + bnv2(i,k)*(zl(i,komax(i))-zl(i,k))*del(i,k)/g/ro(i,k) + ke = 0.5*((rcs*u1(i,k))**2.+(rcs*v1(i,k))**2.) ! -!------limit de-acceleration (momentum deposition ) at top to 1/2 value -!------the idea is some stuff must go out the 'top' +!---------- apply flow-blocking drag when pe >= ke ! - do klcap = lcap,kte - do i = its,ite - taud(i,klcap) = taud(i,klcap) * factop - enddo - enddo + if(pe.ge.ke) then + kblk = k + kblk = min(kblk,kbl(i)) + zblk = zl(i,kblk)-zl(i,kts) + endif + endif + enddo + if(kblk.ne.0) then ! -!------if the gravity wave drag would force a critical line -!------in the lower ksmm1 layers during the next deltim timestep, -!------then only apply drag until that critical line is reached. +!--------- compute flow-blocking stress ! - do k = kts,kpblmax-1 - do i = its,ite + cd = max(2.0-1.0/od(i),0.0) + taufb(i,kts) = 0.5 * roll(i) * coefm(i) / dxy(i)**2 * cd * dxyp(i) & + * olp(i) * zblk * ulow(i)**2 + tautem = taufb(i,kts)/float(kblk-kts) + do k = kts+1, kblk + taufb(i,k) = taufb(i,k-1) - tautem + enddo +! +!----------sum orographic GW stress and flow-blocking stress +! + taup(i,:) = taup(i,:) + taufb(i,:) + endif + endif + enddo +! +! calculate - (g)*d(tau)/d(pressure) and deceleration terms dtaux, dtauy +! + do k = kts,kte + do i = its,ite + taud(i,k) = 1. * (taup(i,k+1) - taup(i,k)) * csg / del(i,k) + enddo + enddo +! +! limit de-acceleration (momentum deposition ) at top to 1/2 value +! the idea is some stuff must go out the 'top' +! + do klcap = lcap,kte + do i = its,ite + taud(i,klcap) = taud(i,klcap) * factop + enddo + enddo +! +! if the gravity wave drag would force a critical line +! in the lower ksmm1 layers during the next deltim timestep, +! then only apply drag until that critical line is reached. +! + do k = kts,kpblmax-1 + do i = its,ite if (k .le. kbl(i)) then - if(taud(i,k).ne.0.) & - dtfac(i) = min(dtfac(i),abs(velco(i,k) & + if(taud(i,k).ne.0.) & + dtfac(i) = min(dtfac(i),abs(velco(i,k) & /(deltim*rcs*taud(i,k)))) endif - enddo - enddo + enddo + enddo ! do i = its,ite dusfc(i) = 0. dvsfc(i) = 0. enddo ! - do k = kts,kte - do i = its,ite - taud(i,k) = taud(i,k) * dtfac(i) + do k = kts,kte + do i = its,ite + taud(i,k) = taud(i,k) * dtfac(i) dtaux = taud(i,k) * xn(i) dtauy = taud(i,k) * yn(i) dtaux2d(i,k) = dtaux dtauy2d(i,k) = dtauy - dudt(i,k) = dtaux + dudt(i,k) - dvdt(i,k) = dtauy + dvdt(i,k) - dusfc(i) = dusfc(i) + dtaux * del(i,k) - dvsfc(i) = dvsfc(i) + dtauy * del(i,k) - enddo - enddo + dudt(i,k) = dtaux + dudt(i,k) + dvdt(i,k) = dtauy + dvdt(i,k) + dusfc(i) = dusfc(i) + dtaux * del(i,k) + dvsfc(i) = dvsfc(i) + dtauy * del(i,k) + enddo + enddo ! do i = its,ite dusfc(i) = (-1./g*rcs) * dusfc(i) dvsfc(i) = (-1./g*rcs) * dvsfc(i) enddo ! - return + return end subroutine gwdo2d !------------------------------------------------------------------- end module module_bl_gwdo diff --git a/wrfv2_fire/phys/module_bl_qnsepbl09.F b/wrfv2_fire/phys/module_bl_qnsepbl09.F deleted file mode 100755 index c57dd76a..00000000 --- a/wrfv2_fire/phys/module_bl_qnsepbl09.F +++ /dev/null @@ -1,1345 +0,0 @@ -!----------------------------------------------------------------------- -! - MODULE MODULE_BL_QNSEPBL09 -! -!----------------------------------------------------------------------- -! - USE MODULE_MODEL_CONSTANTS -! -!----------------------------------------------------------------------- -! -! REFERENCES: Janjic (2002), NCEP Office Note 437 -! Mellor and Yamada (1982), Rev. Geophys. Space Phys. -! -! ABSTRACT: -! MYJ UPDATES THE TURBULENT KINETIC ENERGY WITH THE PRODUCTION/ -! DISSIPATION TERM AND THE VERTICAL DIFFUSION TERM -! (USING AN IMPLICIT FORMULATION) FROM MELLOR-YAMADA -! LEVEL 2.5 AS EXTENDED BY JANJIC. EXCHANGE COEFFICIENTS FOR -! THE SURFACE AND FOR ALL LAYER INTERFACES ARE COMPUTED FROM -! MONIN-OBUKHOV THEORY. -! THE TURBULENT VERTICAL EXCHANGE IS THEN EXECUTED. -! -!----------------------------------------------------------------------- -! - INTEGER :: ITRMX=5 ! Iteration count for mixing length computation -! -! REAL,PARAMETER :: G=9.81,PI=3.1415926,R_D=287.04,R_V=461.6 & -! & ,VKARMAN=0.4 - REAL,PARAMETER :: PI=3.1415926,VKARMAN=0.4 -! -!----------------------------------------------------------------------- -!*** QNSE MODEL CONSTANTS -!----------------------------------------------------------------------- -! - REAL,PARAMETER :: EPSQ2L=0.01 - REAL,PARAMETER :: C0=0.55,CEPS=C0**3,BLCKDR=0.0063,CN=0.75 & - & ,AM1=8.0,AM2=2.3,AM3=35.0,AH1=1.4,AH2=-0.01 & - & ,AH3=1.29,AH4=2.44,AH5=19.8 & - & ,ARIMIN=0.127,BM1=2.88,BM2=16.0,BH1=3.6,BH2=16.0 & - & ,BH3=720.0,EPSKM=1.E-3 -! - REAL,PARAMETER :: CAPA=R_D/CP - REAL,PARAMETER :: RLIVWV=XLS/XLV,ELOCP=2.72E6/CP - REAL,PARAMETER :: EPS1=1.E-12,EPS2=0. - REAL,PARAMETER :: EPSL=0.32,EPSRU=1.E-7,EPSRS=1.E-7 & - & ,EPSTRB=1.E-24 - REAL,PARAMETER :: EPSA=1.E-8,EPSIT=1.E-4,EPSU2=1.E-4,EPSUST=0.07 & - & ,FH=1.01 - REAL,PARAMETER :: ALPH=0.30,BETA=1./273.,EL0MAX=1000.,EL0MIN=1. & - & ,ELFC=0.23*0.5,GAM1=0.2222222222222222222 & - & ,PRT=1. - REAL,PARAMETER :: A1=0.659888514560862645 & - & ,A2x=0.6574209922667784586 & - & ,B1=11.87799326209552761 & - & ,B2=7.226971804046074028 & - & ,C1=0.000830955950095854396 - REAL,PARAMETER :: A2S=17.2693882,A3S=273.16,A4S=35.86 - REAL,PARAMETER :: ELZ0=0.,ESQ=5.0,EXCM=0.001 & - & ,FHNEU=0.8,GLKBR=10.,GLKBS=30. & - & ,QVISC=2.1E-5,RFC=0.191,RIC=0.505,SMALL=0.35 & - & ,SQPR=0.84,SQSC=0.84,SQVISC=258.2,TVISC=2.1E-5 & - & ,USTC=0.7,USTR=0.225,VISC=1.5E-5 & - & ,WOLD=0.15,WWST=1.2,ZTMAX=1.,ZTFC=1.,ZTMIN=-5. -! - REAL,PARAMETER :: SEAFC=0.98,PQ0SEA=PQ0*SEAFC -! - REAL,PARAMETER :: BTG=BETA*G,CZIV=SMALL*GLKBS & -! & ,EP_1=R_V/R_D-1.,ESQHF=0.5*5.0,GRRS=GLKBR/GLKBS & - & ,ESQHF=0.5*5.0,GRRS=GLKBR/GLKBS & - & ,RB1=1./B1,RTVISC=1./TVISC,RVISC=1./VISC & - & ,ZQRZT=SQSC/SQPR -! - REAL,PARAMETER :: ADNH= 9.*A1*A2x*A2x*(12.*A1+3.*B2)*BTG*BTG & - & ,ADNM=18.*A1*A1*A2x*(B2-3.*A2x)*BTG & - & ,ANMH=-9.*A1*A2x*A2x*BTG*BTG & - & ,ANMM=-3.*A1*A2x*(3.*A2x+3.*B2*C1+18.*A1*C1-B2) & - & *BTG & - & ,BDNH= 3.*A2x*(7.*A1+B2)*BTG & - & ,BDNM= 6.*A1*A1 & - & ,BEQH= A2x*B1*BTG+3.*A2x*(7.*A1+B2)*BTG & - & ,BEQM=-A1*B1*(1.-3.*C1)+6.*A1*A1 & - & ,BNMH=-A2x*BTG & - & ,BNMM=A1*(1.-3.*C1) & - & ,BSHH=9.*A1*A2x*A2x*BTG & - & ,BSHM=18.*A1*A1*A2x*C1 & - & ,BSMH=-3.*A1*A2x*(3.*A2x+3.*B2*C1+12.*A1*C1-B2) & - & *BTG & - & ,CESH=A2x & - & ,CESM=A1*(1.-3.*C1) & - & ,CNV=EP_1*G/BTG & - & ,ELFCS=VKARMAN*BTG & - & ,FZQ1=RTVISC*QVISC*ZQRZT & - & ,FZQ2=RTVISC*QVISC*ZQRZT & - & ,FZT1=RVISC *TVISC*SQPR & - & ,FZT2=CZIV*GRRS*TVISC*SQPR & - & ,FZU1=CZIV*VISC & - & ,PIHF=0.5*PI & - & ,RFAC=RIC/(FHNEU*RFC*RFC) & - & ,RQVISC=1./QVISC & - & ,RRIC=1./RIC & - & ,USTFC=0.018/G & - & ,WNEW=1.-WOLD & - & ,WWST2=WWST*WWST -! -!----------------------------------------------------------------------- -!*** FREE TERM IN THE EQUILIBRIUM EQUATION FOR (L/Q)**2 -!----------------------------------------------------------------------- -! - REAL,PARAMETER :: AEQH=9.*A1*A2x*A2x*B1*BTG*BTG & - & +9.*A1*A2x*A2x*(12.*A1+3.*B2)*BTG*BTG & - & ,AEQM=3.*A1*A2x*B1*(3.*A2x+3.*B2*C1+18.*A1*C1-B2)& - & *BTG+18.*A1*A1*A2x*(B2-3.*A2x)*BTG -! -!----------------------------------------------------------------------- -!*** FORBIDDEN TURBULENCE AREA -!----------------------------------------------------------------------- -! - REAL,PARAMETER :: REQU=-AEQH/AEQM & - & ,EPSGH=1.E-9,EPSGM=REQU*EPSGH -! -!----------------------------------------------------------------------- -!*** NEAR ISOTROPY FOR SHEAR TURBULENCE, WW/Q2 LOWER LIMIT -!----------------------------------------------------------------------- -! - REAL,PARAMETER :: UBRYL=(18.*REQU*A1*A1*A2x*B2*C1*BTG & - & +9.*A1*A2x*A2x*B2*BTG*BTG) & - & /(REQU*ADNM+ADNH) & - & ,UBRY=(1.+EPSRS)*UBRYL,UBRY3=3.*UBRY -! - REAL,PARAMETER :: AUBH=27.*A1*A2x*A2x*B2*BTG*BTG-ADNH*UBRY3 & - & ,AUBM=54.*A1*A1*A2x*B2*C1*BTG -ADNM*UBRY3 & - & ,BUBH=(9.*A1*A2x+3.*A2x*B2)*BTG-BDNH*UBRY3 & - & ,BUBM=18.*A1*A1*C1 -BDNM*UBRY3 & - & ,CUBR=1. - UBRY3 & - & ,RCUBR=1./CUBR -! -!----------------------------------------------------------------------- -! - CONTAINS -! -!---------------------------------------------------------------------- - SUBROUTINE QNSEPBL09(DT,STEPBL,HT,DZ & - & ,PMID,PINT,TH,T,EXNER,QV,CWM,U,V,RHO & - & ,TSK,QSFC,CHKLOWQ,THZ0,QZ0,UZ0,VZ0,CORF & - & ,LOWLYR,XLAND,SICE,SNOW & - & ,TKE,EXCH_H,EXCH_M,USTAR,ZNT,EL_MYJ,PBLH,KPBL,CT & - & ,AKHS,AKMS,ELFLX & - & ,RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN & - & ,IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE) -!---------------------------------------------------------------------- -! - IMPLICIT NONE -! -!---------------------------------------------------------------------- - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE -! - INTEGER,INTENT(IN) :: STEPBL - - INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LOWLYR -! - INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: KPBL -! - REAL,INTENT(IN) :: DT -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: HT,SICE,SNOW & - & ,TSK,XLAND -! - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(IN) :: CWM,DZ & - & ,EXNER & - & ,PMID,PINT & - & ,QV,RHO & - & ,T,TH,U,V -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: PBLH -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: AKHS,AKMS -! - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) & - & ,INTENT(OUT) :: EL_MYJ & - & ,RQCBLTEN,RQVBLTEN & - & ,RTHBLTEN & - & ,RUBLTEN,RVBLTEN -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: CT,QSFC,QZ0 & - & ,THZ0,USTAR & - & ,UZ0,VZ0,ZNT -! - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME) & - & ,INTENT(INOUT) :: EXCH_H,EXCH_M,TKE -! - REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: CHKLOWQ,ELFLX,CORF -! -!---------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** - INTEGER :: I,J,K,KFLIP,LLOW,LMH,LMXL -! - INTEGER,DIMENSION(ITS:ITE,JTS:JTE) :: LPBL -! - REAL :: AKHS_DENS,AKMS_DENS,APEX,DCDT,DELTAZ,DQDT,DTDIF,DTDT & - & ,DTTURBL,DUDT,DVDT,EXNSFC,PSFC,PTOP,QFC1,QLOW,QOLD & - & ,RATIOMX,RDTTURBL,RG,RWMSK,SEAMASK,THNEW,THOLD,TX & - & ,ULOW,VLOW,WMSK -! - REAL,DIMENSION(KTS:KTE) :: CWMK,PK,Q2K,QK,THEK,TK,UK,VK -! - REAL,DIMENSION(KTS:KTE-1) :: AKHK,AKMK,EL,RI,GH,S2 -! - REAL,DIMENSION(KTS:KTE+1) :: ZHK -! - REAL,DIMENSION(ITS:ITE,JTS:JTE) :: THSK -! - REAL,DIMENSION(KTS:KTE,ITS:ITE) :: RHOK -! - REAL,DIMENSION(ITS:ITE,KTS:KTE,JTS:JTE) :: APE,THE -! - REAL,DIMENSION(ITS:ITE,KTS:KTE-1,JTS:JTE) :: AKH,AKM -! - REAL,DIMENSION(ITS:ITE,KTS:KTE+1,JTS:JTE) :: ZINT -! -!*** Begin debugging - REAL :: ZSL_DIAG - INTEGER :: IMD,JMD,PRINT_DIAG -!*** End debugging -! -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- -! -!*** Begin debugging - IMD=(IMS+IME)/2 - JMD=(JMS+JME)/2 -!*** End debugging -! -!*** MAKE PREPARATIONS -! -!---------------------------------------------------------------------- - DTTURBL=DT*STEPBL - RDTTURBL=1./DTTURBL - DTDIF=DTTURBL - RG=1./G -! - DO J=JTS,JTE - DO K=KTS,KTE-1 - DO I=ITS,ITE - AKM(I,K,J)=0. - ENDDO - ENDDO - ENDDO -! - DO J=JTS,JTE - DO K=KTS,KTE+1 - DO I=ITS,ITE - ZINT(I,K,J)=0. - ENDDO - ENDDO - ENDDO -! - DO J=JTS,JTE - DO I=ITS,ITE - ZINT(I,KTE+1,J)=HT(I,J) ! Z at bottom of lowest sigma layer -! -!!!!!!!!! -!!!!!! UNCOMMENT THESE LINES IF USING ETA COORDINATES -!!!!!!!!! -!!!!!! ZINT(I,KTE+1,J)=1.E-4 ! Z of bottom of lowest eta layer -!!!!!! ZHK(KTE+1)=1.E-4 ! Z of bottom of lowest eta layer -! - ENDDO - ENDDO -! - DO J=JTS,JTE - DO K=KTE,KTS,-1 - KFLIP=KTE+1-K - DO I=ITS,ITE - ZINT(I,K,J)=ZINT(I,K+1,J)+DZ(I,KFLIP,J) - APEX=1./EXNER(I,K,J) - APE(I,K,J)=APEX - TX=T(I,K,J) - THE(I,K,J)=(CWM(I,K,J)*(-ELOCP/TX)+1.)*TH(I,K,J) - ENDDO - ENDDO - ENDDO -! - EL_MYJ(its:ite,:,jts:jte) = 0. -! -!---------------------------------------------------------------------- - setup_integration: DO J=JTS,JTE -!---------------------------------------------------------------------- -! - DO I=ITS,ITE -! -!*** LOWEST LAYER ABOVE GROUND MUST BE FLIPPED -! - LMH=KTE-LOWLYR(I,J)+1 -! - PTOP=PINT(I,KTE+1,J) ! KTE+1=KME - PSFC=PINT(I,LOWLYR(I,J),J) -! -!*** CONVERT LAND MASK (1 FOR SEA; 0 FOR LAND) -! - SEAMASK=XLAND(I,J)-1. -! -!*** FILL 1-D VERTICAL ARRAYS -!*** AND FLIP DIRECTION SINCE MYJ SCHEME -!*** COUNTS DOWNWARD FROM THE DOMAIN'S TOP -! - DO K=KTE,KTS,-1 - KFLIP=KTE+1-K - TK(K)=T(I,KFLIP,J) - THEK(K)=THE(I,KFLIP,J) - RATIOMX=QV(I,KFLIP,J) - QK(K)=RATIOMX/(1.+RATIOMX) - CWMK(K)=CWM(I,KFLIP,J) - PK(K)=PMID(I,KFLIP,J) - UK(K)=U(I,KFLIP,J) - VK(K)=V(I,KFLIP,J) -! -!*** TKE=0.5*(q**2) ==> q**2=2.*TKE -! - Q2K(K)=2.*TKE(I,KFLIP,J) -! -!*** COMPUTE THE HEIGHTS OF THE LAYER INTERFACES -! - ZHK(K)=ZINT(I,K,J) -! - ENDDO - ZHK(KTE+1)=HT(I,J) ! Z at bottom of lowest sigma layer -! -!*** Begin debugging -! IF(I==IMD.AND.J==JMD)THEN -! PRINT_DIAG=1 -! ELSE -! PRINT_DIAG=0 -! ENDIF -! IF(I==227.AND.J==363)PRINT_DIAG=2 -!*** End debugging -! -!---------------------------------------------------------------------- -!*** -!*** FIND THE MIXING LENGTH -!*** - CALL MIXLEN(LMH,UK,VK,TK,THEK,QK,CWMK & - & ,Q2K,ZHK,USTAR(I,J),CORF(I,J),S2,GH,RI,EL & - & ,PBLH(I,J),LPBL(I,J),LMXL,CT(I,J) & - & ,IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE) -! -!---------------------------------------------------------------------- -!*** THE MODEL LAYER (COUNTING UPWARD) CONTAINING THE TOP OF THE PBL -!---------------------------------------------------------------------- -! - KPBL(I,J)=KTE-LPBL(I,J)+1 -! -!---------------------------------------------------------------------- -!*** -!*** FIND THE QNSE EXCHANGE COEFFICIENTS -!*** - CALL DIFCOF(LMH,EL,RI,Q2K,ZHK,AKMK,AKHK & - & ,IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE,PRINT_DIAG) ! debug -! -!---------------------------------------------------------------------- -!*** COUNTING DOWNWARD FROM THE TOP, THE EXCHANGE COEFFICIENTS AKH -!*** ARE DEFINED ON THE BOTTOMS OF THE LAYERS KTS TO KTE-1. COUNTING -!*** COUNTING UPWARD FROM THE BOTTOM, THOSE SAME COEFFICIENTS EXCH_H -!*** ARE DEFINED ON THE TOPS OF THE LAYERS KTS TO KTE-1. -! - DO K=KTS,KTE-1 - KFLIP=KTE-K - AKH(I,K,J)=AKHK(K) - AKM(I,K,J)=AKMK(K) - DELTAZ=0.5*(ZHK(KFLIP)-ZHK(KFLIP+2)) - EXCH_H(I,K+1,J)=AKHK(KFLIP)*DELTAZ - EXCH_M(I,K+1,J)=AKMK(KFLIP)*DELTAZ - ENDDO -! -!---------------------------------------------------------------------- -!*** -!*** SOLVE FOR THE PRODUCTION/DISSIPATION OF -!*** THE TURBULENT KINETIC ENERGY -!*** -! - CALL PRODQ2(LMH,DTTURBL,USTAR(I,J),S2,RI,Q2K,EL,ZHK,AKMK,AKHK & - & ,IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE) -! -!---------------------------------------------------------------------- -!*** -!*** CARRY OUT THE VERTICAL DIFFUSION OF -!*** TURBULENT KINETIC ENERGY -!*** -! - CALL VDIFQ(LMH,DTDIF,Q2K,EL,ZHK & - & ,IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE) -! -!*** SAVE THE NEW TKE AND MIXING LENGTH. -! - DO K=KTS,KTE - KFLIP=KTE+1-K - Q2K(KFLIP)=AMAX1(Q2K(KFLIP),EPSQ2L) - TKE(I,K,J)=0.5*Q2K(KFLIP) - IF(KFLIP/=KTE)EL_MYJ(I,K,J)=EL(KFLIP) ! EL IS NOT DEFINED AT KTE - ENDDO -! - ENDDO -! -!---------------------------------------------------------------------- - ENDDO setup_integration -!---------------------------------------------------------------------- -! -!*** CONVERT SURFACE SENSIBLE TEMPERATURE TO POTENTIAL TEMPERATURE. -! - DO J=JTS,JTE - DO I=ITS,ITE - PSFC=PINT(I,LOWLYR(I,J),J) - THSK(I,J)=TSK(I,J)*(1.E5/PSFC)**CAPA - ENDDO - ENDDO -! -!---------------------------------------------------------------------- -! -!---------------------------------------------------------------------- - main_integration: DO J=JTS,JTE -!---------------------------------------------------------------------- -! - DO I=ITS,ITE -! -!*** FILL 1-D VERTICAL ARRAYS -!*** AND FLIP DIRECTION SINCE MYJ SCHEME -!*** COUNTS DOWNWARD FROM THE DOMAIN'S TOP -! - DO K=KTE,KTS,-1 - KFLIP=KTE+1-K - THEK(K)=THE(I,KFLIP,J) - RATIOMX=QV(I,KFLIP,J) - QK(K)=RATIOMX/(1.+RATIOMX) - CWMK(K)=CWM(I,KFLIP,J) - ZHK(K)=ZINT(I,K,J) - RHOK(K,I)=PMID(I,KFLIP,J)/(R_D*T(I,KFLIP,J)* & - & (1.+P608*QK(K)-CWMK(K))) - ENDDO -! -!*** COUNTING DOWNWARD FROM THE TOP, THE EXCHANGE COEFFICIENTS AKH -!*** ARE DEFINED ON THE BOTTOMS OF THE LAYERS KTS TO KTE-1. THESE COEFFICIENTS -!*** ARE ALSO MULTIPLIED BY THE DENSITY AT THE BOTTOM INTERFACE LEVEL. -! - DO K=KTS,KTE-1 - AKHK(K)=AKH(I,K,J)*0.5*(RHOK(K,I)+RHOK(K+1,I)) - ENDDO -! - ZHK(KTE+1)=ZINT(I,KTE+1,J) -! - SEAMASK=XLAND(I,J)-1. - THZ0(I,J)=(1.-SEAMASK)*THSK(I,J)+SEAMASK*THZ0(I,J) -! - LLOW=LOWLYR(I,J) - AKHS_DENS=AKHS(I,J)*RHOK(KTE+1-LLOW,I) -! - IF(SEAMASK<0.5)THEN - QFC1=XLV*CHKLOWQ(I,J)*AKHS_DENS -! - IF(SNOW(I,J)>0..OR.SICE(I,J)>0.5)THEN - QFC1=QFC1*RLIVWV - ENDIF -! - IF(QFC1>0.)THEN - QLOW=QK(KTE+1-LLOW) - QSFC(I,J)=QLOW+ELFLX(I,J)/QFC1 - ENDIF -! - ELSE - PSFC=PINT(I,LOWLYR(I,J),J) - EXNSFC=(1.E5/PSFC)**CAPA - QSFC(I,J)=PQ0SEA/PSFC & - & *EXP(A2*(THSK(I,J)-A3*EXNSFC)/(THSK(I,J)-A4*EXNSFC)) - ENDIF -! - QZ0 (I,J)=(1.-SEAMASK)*QSFC(I,J)+SEAMASK*QZ0 (I,J) -! -!*** LOWEST LAYER ABOVE GROUND MUST BE FLIPPED -! - LMH=KTE-LOWLYR(I,J)+1 -! -!---------------------------------------------------------------------- -!*** CARRY OUT THE VERTICAL DIFFUSION OF -!*** TEMPERATURE AND WATER VAPOR -!---------------------------------------------------------------------- -! - CALL VDIFH(DTDIF,LMH,THZ0(I,J),QZ0(I,J) & - & ,AKHS_DENS,CHKLOWQ(I,J),CT(I,J) & - & ,THEK,QK,CWMK,AKHK,ZHK,RHOK(KTS,I) & - & ,IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE,I,J) -!---------------------------------------------------------------------- -!*** -!*** COMPUTE PRIMARY VARIABLE TENDENCIES -!*** - DO K=KTS,KTE - KFLIP=KTE+1-K - THOLD=TH(I,K,J) - THNEW=THEK(KFLIP)+CWMK(KFLIP)*ELOCP*APE(I,K,J) - DTDT=(THNEW-THOLD)*RDTTURBL - QOLD=QV(I,K,J)/(1.+QV(I,K,J)) - DQDT=(QK(KFLIP)-QOLD)*RDTTURBL - DCDT=(CWMK(KFLIP)-CWM(I,K,J))*RDTTURBL -! - RTHBLTEN(I,K,J)=DTDT - RQVBLTEN(I,K,J)=DQDT/(1.-QK(KFLIP))**2 - RQCBLTEN(I,K,J)=DCDT - ENDDO -! -!*** Begin debugging -! IF(I==IMD.AND.J==JMD)THEN -! PRINT_DIAG=0 -! ELSE -! PRINT_DIAG=0 -! ENDIF -! IF(I==227.AND.J==363)PRINT_DIAG=0 -!*** End debugging -! - PSFC=.01*PINT(I,LOWLYR(I,J),J) - ZSL_DIAG=0.5*DZ(I,1,J) -! -!*** Begin debugging -! IF(PRINT_DIAG==1)THEN -! -! write(6,"(a, 2i5, 2i3, 2f8.2, f6.2, 2f8.2)") & -! '{turb4 i,j, Kpbl, Kmxl, Psfc, Zsfc, Zsl, Zpbl, Zmxl = ' & -! , i, j, KPBL(i,j), KTE-LMXL+1, PSFC, ZHK(LMH+1), ZSL_diag & -! , PBLH(i,j), ZHK(LMXL)-ZHK(LMH+1) -! write(6,"(a, 2f7.2, f7.3, 3e11.4)") & -! '{turb4 tsk, thsk, qz0, q**2_0, akhs, exch_0 = ' & -! , tsk(i,j)-273.15, thsk(i,j), 1000.*qz0(i,j) & -! , 2.*tke_myj(i,1,j), akhs(i,j), akhs(i,j)*ZSL_diag -! write(6,"(a)") & -! '{turb5 k, Pmid, Pint_1, Tc, TH, DTH, GH, S2, EL, Q**2, Akh, EXCH_h, Dz, Dp' -! do k=kts,kte/2 -! KFLIP=KTE-K !-- Includes the KFLIP-1 in earlier versions -! write(6,"(a,i3, 2f8.2, 2f8.3, 3e12.4, 4e11.4, f7.2, f6.2)") & -! '{turb5 ', k, .01*pmid(i,k,j),.01*pint(i,k,j), T(i,k,j)-273.15 & -! , th(i,k,j), DTTURBL*rthblten(i,k,j), GH(KFLIP), S2(KFLIP) & -! , el_myj(i,KFLIP,j), 2.*tke_myj(i,k+1,j), akh(i,KFLIP,j) & -! , exch_h(i,k,j), dz(i,k,j), .01*(pint(i,k,j)-pint(i,k+1,j)) -! enddo -! -! ELSEIF(PRINT_DIAG==2)THEN -! -! write(6,"(a, 2i5, 2i3, 2f8.2, f6.2, 2f8.2)") & -! '}turb4 i,j, Kpbl, Kmxl, Psfc, Zsfc, Zsl, Zpbl, Zmxl = ' & -! , i, j, KPBL(i,j), KTE-LMXL+1, PSFC, ZHK(LMH+1), ZSL_diag & -! , PBLH(i,j), ZHK(LMXL)-ZHK(LMH+1) -! write(6,"(a, 2f7.2, f7.3, 3e11.4)") & -! '}turb4 tsk, thsk, qz0, q**2_0, akhs, exch_0 = ' & -! , tsk(i,j)-273.15, thsk(i,j), 1000.*qz0(i,j) & -! , 2.*tke_myj(i,1,j), akhs(i,j), akhs(i,j)*ZSL_diag -! write(6,"(a)") & -! '}turb5 k, Pmid, Pint_1, Tc, TH, DTH, GH, S2, EL, Q**2, Akh, EXCH_h, Dz, Dp' -! do k=kts,kte/2 -! KFLIP=KTE-K !-- Includes the KFLIP-1 in earlier versions -! write(6,"(a,i3, 2f8.2, 2f8.3, 3e12.4, 4e11.4, f7.2, f6.2)") & -! '}turb5 ', k, .01*pmid(i,k,j),.01*pint(i,k,j), T(i,k,j)-273.15 & -! , th(i,k,j), DTTURBL*rthblten(i,k,j), GH(KFLIP), S2(KFLIP) & -! , el_myj(i,KFLIP,j), 2.*tke_myj(i,k+1,j), akh(i,KFLIP,j) & -! , exch_h(i,k,j), dz(i,k,j), .01*(pint(i,k,j)-pint(i,k+1,j)) -! enddo -! ENDIF -!*** End debugging -! -!---------------------------------------------------------------------- - ENDDO -!---------------------------------------------------------------------- - DO I=ITS,ITE -! -!*** FILL 1-D VERTICAL ARRAYS -!*** AND FLIP DIRECTION SINCE MYJ SCHEME -!*** COUNTS DOWNWARD FROM THE DOMAIN'S TOP -! - DO K=KTS,KTE-1 - AKMK(K)=AKM(I,K,J) - AKMK(K)=AKMK(K)*(RHOK(K,I)+RHOK(K+1,I))*0.5 - ENDDO -! - LLOW=LOWLYR(I,J) - AKMS_DENS=AKMS(I,J)*RHOK(KTE+1-LLOW,I) -! - DO K=KTE,KTS,-1 - KFLIP=KTE+1-K - UK(K)=U(I,KFLIP,J) - VK(K)=V(I,KFLIP,J) - ZHK(K)=ZINT(I,K,J) - ENDDO - ZHK(KTE+1)=ZINT(I,KTE+1,J) -! -!---------------------------------------------------------------------- -!*** CARRY OUT THE VERTICAL DIFFUSION OF -!*** VELOCITY COMPONENTS -!---------------------------------------------------------------------- -! - CALL VDIFV(LMH,DTDIF,UZ0(I,J),VZ0(I,J) & - & ,AKMS_DENS,UK,VK,AKMK,ZHK,RHOK(KTS,I) & - & ,IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE,I,J) -! -!---------------------------------------------------------------------- -!*** -!*** COMPUTE PRIMARY VARIABLE TENDENCIES -!*** - DO K=KTS,KTE - KFLIP=KTE+1-K - DUDT=(UK(KFLIP)-U(I,K,J))*RDTTURBL - DVDT=(VK(KFLIP)-V(I,K,J))*RDTTURBL - RUBLTEN(I,K,J)=DUDT - RVBLTEN(I,K,J)=DVDT - ENDDO -! - ENDDO -!---------------------------------------------------------------------- -! - ENDDO main_integration -! -!---------------------------------------------------------------------- -! - END SUBROUTINE QNSEPBL09 -! -!---------------------------------------------------------------------- -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!---------------------------------------------------------------------- - SUBROUTINE MIXLEN & -!---------------------------------------------------------------------- -! ****************************************************************** -! * * -! * LEVEL 2.5 MIXING LENGTH * -! * * -! ****************************************************************** -! - &(LMH,U,V,T,THE,Q,CWM,Q2,Z,USTAR,CORF & - &,S2,GH,RI,EL,PBLH,LPBL,LMXL,CT & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) -!---------------------------------------------------------------------- -! - IMPLICIT NONE -! -!---------------------------------------------------------------------- - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE -! - INTEGER,INTENT(IN) :: LMH -! - INTEGER,INTENT(OUT) :: LMXL,LPBL -! - REAL,DIMENSION(KTS:KTE),INTENT(IN) :: CWM,Q,Q2,T,THE,U,V -! - REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z -! - REAL,INTENT(OUT) :: PBLH -! - REAL,DIMENSION(KTS:KTE-1),INTENT(OUT) :: EL,RI,GH,S2 -! - REAL,INTENT(INOUT) :: CT -! - REAL,INTENT(IN) :: CORF,USTAR -!---------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** - INTEGER :: K,LPBLM -! - REAL :: A,ADEN,B,BDEN,AUBR,BUBR,BLMX,EL0,ELOQ2X,GHL,S2L & - & ,QOL2ST,QOL2UN,QDZL,RDZ,SQ,SREL,SZQ,TEM,THM,VKRMZ,RLAMBDA & - & ,RLB,RLN,F -! - REAL,DIMENSION(KTS:KTE) :: Q1,EN2 -! - REAL,DIMENSION(KTS:KTE-1) :: DTH,ELM,REL -! -!---------------------------------------------------------------------- -!********************************************************************** -!--------------FIND THE HEIGHT OF THE PBL------------------------------- - LPBL=LMH -! - DO K=LMH-1,1,-1 - IF(Q2(K)<=EPSQ2L*FH)THEN - LPBL=K - GO TO 110 - ENDIF - ENDDO -! - LPBL=1 -! -!--------------THE HEIGHT OF THE PBL------------------------------------ -! - 110 PBLH=Z(LPBL)-Z(LMH+1) -! -!----------------------------------------------------------------------- - DO K=KTS,LMH - Q1(K)=0. - ENDDO -! - DO K=1,LMH-1 - DTH(K)=THE(K)-THE(K+1) - ENDDO -! - DO K=LMH-2,1,-1 - IF(DTH(K)>0..AND.DTH(K+1)<=0.)THEN - DTH(K)=DTH(K)+CT - EXIT - ENDIF - ENDDO -! - CT=0. -!---------------------------------------------------------------------- -!*** COMPUTE LOCAL GRADIENT RICHARDSON NUMBER -!---------------------------------------------------------------------- - DO K=KTS,LMH-1 - RDZ=2./(Z(K)-Z(K+2)) - S2L=((U(K)-U(K+1))**2+(V(K)-V(K+1))**2)*RDZ*RDZ ! S**2 - S2L=MAX(S2L,EPSGM) - S2(K)=S2L -! - TEM=(T(K)+T(K+1))*0.5 - THM=(THE(K)+THE(K+1))*0.5 -! - A=THM*P608 - B=(ELOCP/TEM-1.-P608)*THM -! - GHL=(DTH(K)*((Q(K)+Q(K+1)+CWM(K)+CWM(K+1))*(0.5*P608)+1.) & - & +(Q(K)-Q(K+1)+CWM(K)-CWM(K+1))*A & - & +(CWM(K)-CWM(K+1))*B)*RDZ ! dTheta/dz -! - IF(ABS(GHL)<=EPSGH)GHL=EPSGH -! - EN2(K)=GHL*G/THM ! N**2 -! - GH(K)=GHL - RI(K)=EN2(K)/S2L - ENDDO -! -!---------------------------------------------------------------------- -!*** FIND MAXIMUM MIXING LENGTHS AND THE LEVEL OF THE PBL TOP -!---------------------------------------------------------------------- -! - LMXL=LMH -! - DO K=KTS,LMH-1 - S2L=S2(K) - GHL=GH(K) -! - IF(GHL>=EPSGH)THEN - IF(S2L/GHL<=REQU)THEN - ELM(K)=EPSL - LMXL=K - ELSE - AUBR=(AUBM*S2L+AUBH*GHL)*GHL - BUBR= BUBM*S2L+BUBH*GHL - QOL2ST=(-0.5*BUBR+SQRT(BUBR*BUBR*0.25-AUBR*CUBR))*RCUBR - ELOQ2X=1./QOL2ST - ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL) - ENDIF - ELSE - ADEN=(ADNM*S2L+ADNH*GHL)*GHL - BDEN= BDNM*S2L+BDNH*GHL - QOL2UN=-0.5*BDEN+SQRT(BDEN*BDEN*0.25-ADEN) - ELOQ2X=1./(QOL2UN+EPSRU) ! repsr1/qol2un - ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL) - ENDIF - ENDDO -! - IF(ELM(LMH-1)==EPSL)LMXL=LMH -! -!---------------------------------------------------------------------- -!*** THE HEIGHT OF THE MIXED LAYER -!---------------------------------------------------------------------- -! - BLMX=Z(LMXL)-Z(LMH+1) -! -!---------------------------------------------------------------------- - DO K=LPBL,LMH - Q1(K)=SQRT(Q2(K)) - ENDDO -!---------------------------------------------------------------------- - SZQ=0. - SQ =0. -! - DO K=KTS,LMH-1 - QDZL=(Q1(K)+Q1(K+1))*(Z(K+1)-Z(K+2)) - SZQ=(Z(K+1)+Z(K+2)-Z(LMH+1)-Z(LMH+1))*QDZL+SZQ - SQ=QDZL+SQ - ENDDO -! -!---------------------------------------------------------------------- -!*** COMPUTATION OF ASYMPTOTIC L IN BLACKADAR FORMULA -!---------------------------------------------------------------------- -! - EL0=MIN(ALPH*SZQ*0.5/SQ,EL0MAX) - EL0=MAX(EL0 ,EL0MIN) -! -!---------------------------------------------------------------------- -!*** ABOVE THE PBL TOP -!---------------------------------------------------------------------- -! - LPBLM=MAX(LPBL-1,1) -! - DO K=KTS,LPBLM - EL(K)=MIN((Z(K)-Z(K+2))*ELFC,ELM(K)) - REL(K)=EL(K)/ELM(K) - ENDDO -! -!---------------------------------------------------------------------- -!*** INSIDE THE PBL -!---------------------------------------------------------------------- -! - IF(LPBL=0.0)THEN ! Stable case - VKRMZ=(Z(K+1)-Z(LMH+1))*VKARMAN - RLB=RLAMBDA+1./VKRMZ - RLN=SQRT(2.*EN2(K)/Q2(K))/CN -! EL(K)=MIN(1./(RLB+RLN),ELM(K)) - EL(K)=1./(RLB+RLN) - ENDIF - ENDDO -! -!---------------------------------------------------------------------- - END SUBROUTINE MIXLEN -!---------------------------------------------------------------------- -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!---------------------------------------------------------------------- - SUBROUTINE PRODQ2 & -!---------------------------------------------------------------------- -! ****************************************************************** -! * * -! * LEVEL 2.5 Q2 PRODUCTION/DISSIPATION * -! * * -! ****************************************************************** -! - &(LMH,DTTURBL,USTAR,S2,RI,Q2,EL,Z,AKM,AKH & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) -!---------------------------------------------------------------------- -! - IMPLICIT NONE -! -!---------------------------------------------------------------------- - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE -! - INTEGER,INTENT(IN) :: LMH -! - REAL,INTENT(IN) :: DTTURBL,USTAR -! - REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: S2,RI,AKM,AKH,EL -! - REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z -! - REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2 -!---------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** - INTEGER :: K -! - REAL :: S2L,Q2L,DELTAZ,AKML,AKHL,EN2,PR,BPR,DIS,RC02 -! -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- -! - RC02=2.0/(C0*C0) - main_integration: DO K=1,LMH-1 - S2L=S2(K) - Q2L=Q2(K) - DELTAZ=0.5*(Z(K)-Z(K+2)) - AKML=AKM(K)*DELTAZ - AKHL=AKH(K)*DELTAZ - EN2=RI(K)*S2L !N**2 -! -!*** TURBULENCE PRODUCTION TERM -! - PR=AKML*S2L -! -!*** BUOYANCY PRODUCTION -! - BPR=AKHL*EN2 -! -!*** DISSIPATION -! - DIS=CEPS*(0.5*Q2L)**1.5/EL(K) -! - Q2L=Q2L+2.0*(PR-BPR-DIS)*DTTURBL - Q2(K)=AMAX1(Q2L,EPSQ2L) -!---------------------------------------------------------------------- -!*** END OF PRODUCTION/DISSIPATION LOOP -!---------------------------------------------------------------------- -! - ENDDO main_integration -! -!---------------------------------------------------------------------- -!*** LOWER BOUNDARY CONDITION FOR Q2 -!---------------------------------------------------------------------- -! - Q2(LMH)=AMAX1(RC02*USTAR*USTAR,EPSQ2L) -!---------------------------------------------------------------------- -! - END SUBROUTINE PRODQ2 -! -!---------------------------------------------------------------------- -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!---------------------------------------------------------------------- - SUBROUTINE DIFCOF & -! ****************************************************************** -! * * -! * DIFFUSION COEFFICIENTS KM, KH BASED ON THE QNSE THEORY * -! * * -! ****************************************************************** - &(LMH,EL,RI,Q2,Z,AKM,AKH & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE,PRINT_DIAG) ! debug -!---------------------------------------------------------------------- -! - IMPLICIT NONE -! -!---------------------------------------------------------------------- - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE -! - INTEGER,INTENT(IN) :: LMH -! - REAL,DIMENSION(KTS:KTE),INTENT(IN) :: Q2 - REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: EL,RI - REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z -! - REAL,DIMENSION(KTS:KTE-1),INTENT(OUT) :: AKH,AKM -!---------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** - INTEGER :: K -! - REAL :: AK0,ALPHAM,ALPHAH,RIL,RIL2,ARIL,ARIL2,ARIL4,ELL,Q1L,RDZ & - & ,AK0DZ,AKMIN -! -!*** Begin debugging - INTEGER,INTENT(IN) :: PRINT_DIAG -! REAL :: D2Tmin -!*** End debugging -! -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- -! - DO K=1,LMH-1 - ELL=EL(K) - Q1L=SQRT(0.5*Q2(K)) !Note that Q1L is SQRT(TKE) - RIL=RI(K) - AK0=C0*ELL*Q1L !KM in neutral case -! -!---------------------------------------------------------------------- -!*** STABILITY FUNCTIONS ALPHAM AND ALPHAH -!---------------------------------------------------------------------- -! -!!! UNSTABLE CASE -! - IF(RIL<=0) THEN - ARIL=MIN(ABS(RIL),2.*ARIMIN) - ARIL2=ARIL*ARIL - ARIL4=ARIL2*ARIL2 - ALPHAM=1.0+BM1*ARIL+BM2*ARIL2 - ALPHAH=AH1+BH1*ARIL+BH2*ARIL2+BH3*ARIL4 -! -!!! STABLE CASE -! - ELSE - RIL2=RIL*RIL - ALPHAM=(1.0+AM1*RIL2)/(1.0+AM2*RIL+AM3*RIL2) - ALPHAH=(AH1+AH2*RIL+AH3*RIL2)/(1.0+AH4*RIL+AH5*RIL2) - ENDIF -! -!----------------------------------------------------------------------- -!*** END OF STABILITY FUNCTIONS COMPUTATIONS -!----------------------------------------------------------------------- -! -!---------------------------------------------------------------------- -!*** DIFFUSION COEFFICIENTS -!---------------------------------------------------------------------- -! - RDZ=2./(Z(K)-Z(K+2)) - AK0DZ=AK0*RDZ - AKMIN=EPSKM*RDZ - AKM(K)=MAX(AK0DZ*ALPHAM,AKMIN) - AKH(K)=MAX(AK0DZ*ALPHAH,AKMIN) -!---------------------------------------------------------------------- - ENDDO -!---------------------------------------------------------------------- -! - END SUBROUTINE DIFCOF -! -!---------------------------------------------------------------------- -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!---------------------------------------------------------------------- - SUBROUTINE VDIFQ & -! ****************************************************************** -! * * -! * VERTICAL DIFFUSION OF Q2 (TKE) * -! * * -! ****************************************************************** - &(LMH,DTDIF,Q2,EL,Z & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) -!---------------------------------------------------------------------- -! - IMPLICIT NONE -! -!---------------------------------------------------------------------- - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE -! - INTEGER,INTENT(IN) :: LMH -! - REAL,INTENT(IN) :: DTDIF -! - REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: EL - REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z -! - REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2 -!---------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** - INTEGER :: K -! - REAL :: ADEN,AKQS,BDEN,BESH,BESM,CDEN,CF,DTOZS,ELL,ELOQ2,ELOQ4 & - & ,ELQDZ,ESH,ESM,ESQHF,GHL,GML,Q1L,RDEN,RDZ -! - REAL,DIMENSION(KTS:KTE-2) :: AKQ,CM,CR,DTOZ,RSQ2 -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- -!*** -!*** VERTICAL TURBULENT DIFFUSION -!*** -!---------------------------------------------------------------------- - ESQHF=0.5*ESQ -! - DO K=KTS,LMH-2 - DTOZ(K)=(DTDIF+DTDIF)/(Z(K)-Z(K+2)) - AKQ(K)=SQRT((Q2(K)+Q2(K+1))*0.5)*(EL(K)+EL(K+1))*ESQHF & - & /(Z(K+1)-Z(K+2)) - CR(K)=-DTOZ(K)*AKQ(K) - ENDDO -! - CM(1)=DTOZ(1)*AKQ(1)+1. - RSQ2(1)=Q2(1) -! - DO K=KTS+1,LMH-2 - CF=-DTOZ(K)*AKQ(K-1)/CM(K-1) - CM(K)=-CR(K-1)*CF+(AKQ(K-1)+AKQ(K))*DTOZ(K)+1. - RSQ2(K)=-RSQ2(K-1)*CF+Q2(K) - ENDDO -! - DTOZS=(DTDIF+DTDIF)/(Z(LMH-1)-Z(LMH+1)) - AKQS=SQRT((Q2(LMH-1)+Q2(LMH))*0.5)*(EL(LMH-1)+ELZ0)*ESQHF & - & /(Z(LMH)-Z(LMH+1)) -! - CF=-DTOZS*AKQ(LMH-2)/CM(LMH-2) -! - Q2(LMH-1)=(DTOZS*AKQS*Q2(LMH)-RSQ2(LMH-2)*CF+Q2(LMH-1)) & - & /((AKQ(LMH-2)+AKQS)*DTOZS-CR(LMH-2)*CF+1.) -! - DO K=LMH-2,KTS,-1 - Q2(K)=(-CR(K)*Q2(K+1)+RSQ2(K))/CM(K) - ENDDO -!---------------------------------------------------------------------- -! - END SUBROUTINE VDIFQ -! -!---------------------------------------------------------------------- -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!--------------------------------------------------------------------- - SUBROUTINE VDIFH(DTDIF,LMH,THZ0,QZ0,RKHS,CHKLOWQ,CT & - & ,THE,Q,CWM,RKH,Z,RHO & - & ,IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE,I,J) -! *************************************************************** -! * * -! * VERTICAL DIFFUSION OF MASS VARIABLES * -! * * -! *************************************************************** -!--------------------------------------------------------------------- -! - IMPLICIT NONE -! -!--------------------------------------------------------------------- - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE,I,J -! - INTEGER,INTENT(IN) :: LMH -! - REAL,INTENT(IN) :: CHKLOWQ,CT,DTDIF,QZ0,RKHS,THZ0 -! - REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: RKH - REAL,DIMENSION(KTS:KTE),INTENT(IN) :: RHO - REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z - REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: CWM,Q,THE -! -!---------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** - INTEGER :: K -! - REAL :: CF,CMB,CMCB,CMQB,CMTB,CTHF,DTOZL,DTOZS & - & ,RCML,RKHH,RKQS,RSCB,RSQB,RSTB -! - REAL,DIMENSION(KTS:KTE-1) :: CM,CR,DTOZ,RKCT,RSC,RSQ,RST -! -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- - CTHF=0.5*CT -! - DO K=KTS,LMH-1 - DTOZ(K)=DTDIF/(Z(K)-Z(K+1)) - CR(K)=-DTOZ(K)*RKH(K) - RKCT(K)=RKH(K)*(Z(K)-Z(K+2))*CTHF - ENDDO -! - CM(KTS)=DTOZ(KTS)*RKH(KTS)+RHO(KTS) -!---------------------------------------------------------------------- - RST(KTS)=-RKCT(KTS)*DTOZ(KTS) & - & +THE(KTS)*RHO(KTS) - RSQ(KTS)=Q(KTS) *RHO(KTS) - RSC(KTS)=CWM(KTS)*RHO(KTS) -!---------------------------------------------------------------------- - DO K=KTS+1,LMH-1 - DTOZL=DTOZ(K) - CF=-DTOZL*RKH(K-1)/CM(K-1) - CM(K)=-CR(K-1)*CF+(RKH(K-1)+RKH(K))*DTOZL+RHO(K) - RST(K)=-RST(K-1)*CF+(RKCT(K-1)-RKCT(K))*DTOZL+THE(K)*RHO(K) - RSQ(K)=-RSQ(K-1)*CF+Q(K) *RHO(K) - RSC(K)=-RSC(K-1)*CF+CWM(K)*RHO(K) - ENDDO -! - DTOZS=DTDIF/(Z(LMH)-Z(LMH+1)) - RKHH=RKH(LMH-1) -! - CF=-DTOZS*RKHH/CM(LMH-1) - RKQS=RKHS*CHKLOWQ -! - CMB=CR(LMH-1)*CF - CMTB=-CMB+(RKHH+RKHS)*DTOZS+RHO(LMH) - CMQB=-CMB+(RKHH+RKQS)*DTOZS+RHO(LMH) - CMCB=-CMB+(RKHH )*DTOZS+RHO(LMH) -! - RSTB=-RST(LMH-1)*CF+RKCT(LMH-1)*DTOZS+THE(LMH)*RHO(LMH) - RSQB=-RSQ(LMH-1)*CF+Q(LMH) *RHO(LMH) - RSCB=-RSC(LMH-1)*CF+CWM(LMH)*RHO(LMH) -!---------------------------------------------------------------------- - THE(LMH)=(DTOZS*RKHS*THZ0+RSTB)/CMTB - Q(LMH) =(DTOZS*RKQS*QZ0 +RSQB)/CMQB - CWM(LMH)=( RSCB)/CMCB -!---------------------------------------------------------------------- - DO K=LMH-1,KTS,-1 - RCML=1./CM(K) - THE(K)=(-CR(K)*THE(K+1)+RST(K))*RCML - Q(K) =(-CR(K)* Q(K+1)+RSQ(K))*RCML - CWM(K)=(-CR(K)*CWM(K+1)+RSC(K))*RCML - ENDDO -!---------------------------------------------------------------------- -! - END SUBROUTINE VDIFH -! -!--------------------------------------------------------------------- -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!--------------------------------------------------------------------- - SUBROUTINE VDIFV(LMH,DTDIF,UZ0,VZ0,RKMS,U,V,RKM,Z,RHO & - & ,IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - ,ITS,ITE,JTS,JTE,KTS,KTE,I,J) -! *************************************************************** -! * * -! * VERTICAL DIFFUSION OF VELOCITY COMPONENTS * -! * * -! *************************************************************** -!--------------------------------------------------------------------- -! - IMPLICIT NONE -! -!--------------------------------------------------------------------- - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE,I,J -! - INTEGER,INTENT(IN) :: LMH -! - REAL,INTENT(IN) :: RKMS,DTDIF,UZ0,VZ0 -! - REAL,DIMENSION(KTS:KTE-1),INTENT(IN) :: RKM - REAL,DIMENSION(KTS:KTE),INTENT(IN) :: RHO - REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z -! - REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: U,V -!---------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** - INTEGER :: K -! - REAL :: CF,DTOZAK,DTOZL,DTOZS,RCML,RCMVB,RHOK,RKMH -! - REAL,DIMENSION(KTS:KTE-1) :: CM,CR,DTOZ,RSU,RSV -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- - DO K=1,LMH-1 - DTOZ(K)=DTDIF/(Z(K)-Z(K+1)) - CR(K)=-DTOZ(K)*RKM(K) - ENDDO -! - RHOK=RHO(1) - CM(1)=DTOZ(1)*RKM(1)+RHOK - RSU(1)=U(1)*RHOK - RSV(1)=V(1)*RHOK -!---------------------------------------------------------------------- - DO K=2,LMH-1 - DTOZL=DTOZ(K) - CF=-DTOZL*RKM(K-1)/CM(K-1) - RHOK=RHO(K) - CM(K)=-CR(K-1)*CF+(RKM(K-1)+RKM(K))*DTOZL+RHOK - RSU(K)=-RSU(K-1)*CF+U(K)*RHOK - RSV(K)=-RSV(K-1)*CF+V(K)*RHOK - ENDDO -!---------------------------------------------------------------------- - DTOZS=DTDIF/(Z(LMH)-Z(LMH+1)) - RKMH=RKM(LMH-1) -! - CF=-DTOZS*RKMH/CM(LMH-1) - RHOK=RHO(LMH) - RCMVB=1./((RKMH+RKMS)*DTOZS-CR(LMH-1)*CF+RHOK) - DTOZAK=DTOZS*RKMS -!---------------------------------------------------------------------- - U(LMH)=(DTOZAK*UZ0-RSU(LMH-1)*CF+U(LMH)*RHOK)*RCMVB - V(LMH)=(DTOZAK*VZ0-RSV(LMH-1)*CF+V(LMH)*RHOK)*RCMVB -!---------------------------------------------------------------------- - DO K=LMH-1,1,-1 - RCML=1./CM(K) - U(K)=(-CR(K)*U(K+1)+RSU(K))*RCML - V(K)=(-CR(K)*V(K+1)+RSV(K))*RCML - ENDDO -!---------------------------------------------------------------------- -! - END SUBROUTINE VDIFV -! -!----------------------------------------------------------------------- -! -!======================================================================= - SUBROUTINE QNSEPBLINIT09(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - & TKE,EXCH_H,RESTART,ALLOWED_TO_READ, & - & IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE ) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, & - & IMS,IME,JMS,JME,KMS,KME, & - & ITS,ITE,JTS,JTE,KTS,KTE - - REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(OUT) :: EXCH_H, & - & RUBLTEN, & - & RVBLTEN, & - & RTHBLTEN, & - & RQVBLTEN, & - & TKE - INTEGER :: I,J,K,ITF,JTF,KTF -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - - JTF=MIN0(JTE,JDE-1) - KTF=MIN0(KTE,KDE-1) - ITF=MIN0(ITE,IDE-1) - - IF(.NOT.RESTART)THEN - DO J=JTS,JTF - DO K=KTS,KTF - DO I=ITS,ITF - TKE(I,K,J)=EPSQ2L - RUBLTEN(I,K,J)=0. - RVBLTEN(I,K,J)=0. - RTHBLTEN(I,K,J)=0. - RQVBLTEN(I,K,J)=0. - EXCH_H(I,K,J)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - END SUBROUTINE QNSEPBLINIT09 -!----------------------------------------------------------------------- -! - END MODULE MODULE_BL_QNSEPBL09 -! -!----------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_bl_shinhong.F b/wrfv2_fire/phys/module_bl_shinhong.F new file mode 100644 index 00000000..651225cd --- /dev/null +++ b/wrfv2_fire/phys/module_bl_shinhong.F @@ -0,0 +1,2458 @@ +!WRF:model_layer:physics +! +module module_bl_shinhong +! + USE MODULE_MODEL_CONSTANTS +! +!----------------------------------------------------------------------- +! + INTEGER :: ITRMX=5 ! ITERATION COUNT FOR MIXING LENGTH COMPUTATION + REAL,PARAMETER :: PI=3.1415926,VKARMAN=0.4 +! +!----------------------------------------------------------------------- +!*** QNSE MODEL CONSTANTS +!----------------------------------------------------------------------- +! + REAL,PARAMETER :: EPSQ2L=0.01 + REAL,PARAMETER :: C0=0.55,CEPS=C0**3,BLCKDR=0.0063,CN=0.75 & + & ,AM1=8.0,AM2=2.3,AM3=35.0,AH1=1.4,AH2=-0.01 & + & ,AH3=1.29,AH4=2.44,AH5=19.8 & + & ,ARIMIN=0.127,BM1=2.88,BM2=16.0,BH1=3.6,BH2=16.0 & + & ,BH3=720.0,EPSKM=1.E-3 + REAL,PARAMETER :: CAPA=R_D/CP + REAL,PARAMETER :: RLIVWV=XLS/XLV,ELOCP=2.72E6/CP + REAL,PARAMETER :: EPS1=1.E-12,EPS2=0. + REAL,PARAMETER :: EPSL=0.32,EPSRU=1.E-7,EPSRS=1.E-7 & + & ,EPSTRB=1.E-24 + REAL,PARAMETER :: EPSA=1.E-8,EPSIT=1.E-4,EPSU2=1.E-4,EPSUST=0.07 + REAL,PARAMETER :: ALPH=0.30,BETA=1./273.,EL0MAX=1000.,EL0MIN=1. & + & ,ELFC=0.23*0.5,GAM1=0.2222222222222222222 & + & ,PRT=1. + REAL,PARAMETER :: A1=0.659888514560862645 & + & ,A2X=0.6574209922667784586 & + & ,B1=11.87799326209552761 & + & ,B2=7.226971804046074028 & + & ,C1=0.000830955950095854396 + REAL,PARAMETER :: A2S=17.2693882,A3S=273.16,A4S=35.86 + REAL,PARAMETER :: ELZ0=0.,ESQ=5.0,EXCM=0.001 & + & ,FHNEU=0.8,GLKBR=10.,GLKBS=30. & + & ,QVISC=2.1E-5,RFC=0.191,RIC=0.505,SMALL=0.35 & + & ,SQPR=0.84,SQSC=0.84,SQVISC=258.2,TVISC=2.1E-5 & + & ,USTC=0.7,USTR=0.225,VISC=1.5E-5 & + & ,WOLD=0.15,WWST=1.2,ZTMAX=1.,ZTFC=1.,ZTMIN=-5. +! + REAL,PARAMETER :: SEAFC=0.98,PQ0SEA=PQ0*SEAFC +! + REAL,PARAMETER :: BTG=BETA*G,CZIV=SMALL*GLKBS & + & ,ESQHF=0.5*5.0,GRRS=GLKBR/GLKBS & + & ,RB1=1./B1,RTVISC=1./TVISC,RVISC=1./VISC & + & ,ZQRZT=SQSC/SQPR +! + REAL,PARAMETER :: ADNH= 9.*A1*A2X*A2X*(12.*A1+3.*B2)*BTG*BTG & + & ,ADNM=18.*A1*A1*A2X*(B2-3.*A2X)*BTG & + & ,ANMH=-9.*A1*A2X*A2X*BTG*BTG & + & ,ANMM=-3.*A1*A2X*(3.*A2X+3.*B2*C1+18.*A1*C1-B2) & + & *BTG & + & ,BDNH= 3.*A2X*(7.*A1+B2)*BTG & + & ,BDNM= 6.*A1*A1 & + & ,BEQH= A2X*B1*BTG+3.*A2X*(7.*A1+B2)*BTG & + & ,BEQM=-A1*B1*(1.-3.*C1)+6.*A1*A1 & + & ,BNMH=-A2X*BTG & + & ,BNMM=A1*(1.-3.*C1) & + & ,BSHH=9.*A1*A2X*A2X*BTG & + & ,BSHM=18.*A1*A1*A2X*C1 & + & ,BSMH=-3.*A1*A2X*(3.*A2X+3.*B2*C1+12.*A1*C1-B2) & + & *BTG & + & ,CESH=A2X & + & ,CESM=A1*(1.-3.*C1) & + & ,CNV=EP_1*G/BTG & + & ,ELFCS=VKARMAN*BTG & + & ,FZQ1=RTVISC*QVISC*ZQRZT & + & ,FZQ2=RTVISC*QVISC*ZQRZT & + & ,FZT1=RVISC *TVISC*SQPR & + & ,FZT2=CZIV*GRRS*TVISC*SQPR & + & ,FZU1=CZIV*VISC & + & ,PIHF=0.5*PI & + & ,RFAC=RIC/(FHNEU*RFC*RFC) & + & ,RQVISC=1./QVISC & + & ,RRIC=1./RIC & + & ,USTFC=0.018/G & + & ,WNEW=1.-WOLD & + & ,WWST2=WWST*WWST +! +!----------------------------------------------------------------------- +!*** FREE TERM IN THE EQUILIBRIUM EQUATION FOR (L/Q)**2 +!----------------------------------------------------------------------- +! + REAL,PARAMETER :: AEQH=9.*A1*A2X*A2X*B1*BTG*BTG & + & +9.*A1*A2X*A2X*(12.*A1+3.*B2)*BTG*BTG & + & ,AEQM=3.*A1*A2X*B1*(3.*A2X+3.*B2*C1+18.*A1*C1-B2)& + & *BTG+18.*A1*A1*A2X*(B2-3.*A2X)*BTG +! +!----------------------------------------------------------------------- +!*** FORBIDDEN TURBULENCE AREA +!----------------------------------------------------------------------- +! + REAL,PARAMETER :: REQU=-AEQH/AEQM & + & ,EPSGH=1.E-9,EPSGM=REQU*EPSGH +! +!----------------------------------------------------------------------- +!*** NEAR ISOTROPY FOR SHEAR TURBULENCE, WW/Q2 LOWER LIMIT +!----------------------------------------------------------------------- +! + REAL,PARAMETER :: UBRYL=(18.*REQU*A1*A1*A2X*B2*C1*BTG & + & +9.*A1*A2X*A2X*B2*BTG*BTG) & + & /(REQU*ADNM+ADNH) & + & ,UBRY=(1.+EPSRS)*UBRYL,UBRY3=3.*UBRY +! + REAL,PARAMETER :: AUBH=27.*A1*A2X*A2X*B2*BTG*BTG-ADNH*UBRY3 & + & ,AUBM=54.*A1*A1*A2X*B2*C1*BTG -ADNM*UBRY3 & + & ,BUBH=(9.*A1*A2X+3.*A2X*B2)*BTG-BDNH*UBRY3 & + & ,BUBM=18.*A1*A1*C1 -BDNM*UBRY3 & + & ,CUBR=1. - UBRY3 & + & ,RCUBR=1./CUBR +! +!----------------------------------------------------------------------- +! +contains +! +!------------------------------------------------------------------------------- +! + subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & + rublten,rvblten,rthblten, & + rqvblten,rqcblten,rqiblten,flag_qi, & + cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & + dz8w,psfc, & + znu,znw,mut,p_top, & + znt,ust,hpbl,psim,psih, & + xland,hfx,qfx,wspd,br, & + dt,kpbl2d, & + exch_h, & + u10,v10, & + ctopo,ctopo2, & + shinhong_tke_diag,tke_pbl,el_pbl,corf, & + dx,dy, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + !optional + wstar,delta, & + regime ) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +!-- u3d 3d u-velocity interpolated to theta points (m/s) +!-- v3d 3d v-velocity interpolated to theta points (m/s) +!-- th3d 3d potential temperature (k) +!-- t3d temperature (k) +!-- qv3d 3d water vapor mixing ratio (kg/kg) +!-- qc3d 3d cloud mixing ratio (kg/kg) +!-- qi3d 3d ice mixing ratio (kg/kg) +! (note: if P_QI0..AND.DTH(K-1)<=0.)THEN + DTH(K)=DTH(K)+CT + EXIT + ENDIF + ENDDO +! + CT=0. +!---------------------------------------------------------------------- +!*** COMPUTE LOCAL GRADIENT RICHARDSON NUMBER +!---------------------------------------------------------------------- + DO K=KTE,KTS+1,-1 + RDZ=2./(Z(K+1)-Z(K-1)) + S2L=((U(K)-U(K-1))**2+(V(K)-V(K-1))**2)*RDZ*RDZ ! S**2 + IF(PBLFLG.AND.K.LE.LPBL)THEN + SUK=(U(K)-U(K-1))*RDZ + SVK=(V(K)-V(K-1))*RDZ + S2L=(SUK-HGAMU/PBLH)*SUK+(SVK-HGAMV/PBLH)*SVK + ENDIF + S2L=MAX(S2L,EPSGM) + S2(K)=S2L +! + TEM=(T(K)+T(K-1))*0.5 + THM=(THE(K)+THE(K-1))*0.5 +! + A=THM*P608 + B=(ELOCP/TEM-1.-P608)*THM +! + GHL=(DTH(K)*((Q(K)+Q(K-1)+CWM(K)+CWM(K-1))*(0.5*P608)+1.) & + & +(Q(K)-Q(K-1)+CWM(K)-CWM(K-1))*A & + & +(CWM(K)-CWM(K-1))*B)*RDZ ! dTheta/dz + IF(PBLFLG.AND.K.LE.LPBL)THEN + GHL=GHL-HGAMT/PBLH + ENDIF +! + IF(ABS(GHL)<=EPSGH)GHL=EPSGH +! + EN2(K)=GHL*G/THM ! N**2 +! + GH(K)=GHL + RI(K)=EN2(K)/S2L + ENDDO +! +!---------------------------------------------------------------------- +!*** FIND MAXIMUM MIXING LENGTHS AND THE LEVEL OF THE PBL TOP +!---------------------------------------------------------------------- +! + DO K=KTE,KTS+1,-1 + S2L=S2(K) + GHL=GH(K) +! + IF(GHL>=EPSGH)THEN + IF(S2L/GHL<=REQU)THEN + ELM(K)=EPSL + ELSE + AUBR=(AUBM*S2L+AUBH*GHL)*GHL + BUBR= BUBM*S2L+BUBH*GHL + QOL2ST=(-0.5*BUBR+SQRT(BUBR*BUBR*0.25-AUBR*CUBR))*RCUBR + ELOQ2X=1./QOL2ST + ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL) + ENDIF + ELSE + ADEN=(ADNM*S2L+ADNH*GHL)*GHL + BDEN= BDNM*S2L+BDNH*GHL + QOL2UN=-0.5*BDEN+SQRT(BDEN*BDEN*0.25-ADEN) + ELOQ2X=1./(QOL2UN+EPSRU) ! repsr1/qol2un + ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL) + ENDIF + ENDDO +! +!---------------------------------------------------------------------- + DO K=LPBL,LMH,-1 + Q1(K)=SQRT(Q2(K)) + ENDDO +!---------------------------------------------------------------------- + SZQ=0. + SQ =0. +! + DO K=KTE,KTS+1,-1 + QDZL=(Q1(K)+Q1(K-1))*(Z(K)-Z(K-1)) + SZQ=(Z(K)+Z(K-1)-Z(LMH)-Z(LMH))*QDZL+SZQ + SQ=QDZL+SQ + ENDDO +! +!---------------------------------------------------------------------- +!*** COMPUTATION OF ASYMPTOTIC L IN BLACKADAR FORMULA +!---------------------------------------------------------------------- +! + EL0=MIN(ALPH*SZQ*0.5/SQ,EL0MAX) + EL0=MAX(EL0 ,EL0MIN) +! +!---------------------------------------------------------------------- +!*** ABOVE THE PBL TOP +!---------------------------------------------------------------------- +! + LPBLM=MIN(LPBL+1,KTE) +! + DO K=KTE,LPBLM,-1 + EL(K)=(Z(K+1)-Z(K-1))*ELFC + REL(K)=EL(K)/ELM(K) + ENDDO +! +!---------------------------------------------------------------------- +!*** INSIDE THE PBL +!---------------------------------------------------------------------- +! + EPSHOL=MIN(EPSHOL,0.0) + CKP=ELCBL*((1.0-8.0*EPSHOL)**(1./3.)) + IF(LPBL>LMH)THEN + DO K=LPBL,LMH+1,-1 + VKRMZ=(Z(K)-Z(LMH))*VKARMAN + IF(PBLFLG) THEN + VKRMZ=CKP*(Z(K)-Z(LMH))*VKARMAN + EL(K)=VKRMZ/(VKRMZ/EL0+1.) + ELSE + EL(K)=VKRMZ/(VKRMZ/EL0+1.) + ENDIF + REL(K)=EL(K)/ELM(K) + ENDDO + ENDIF +! + DO K=LPBL-1,LMH+2,-1 + SREL=MIN(((REL(K-1)+REL(K+1))*0.5+REL(K))*0.5,REL(K)) + EL(K)=MAX(SREL*ELM(K),EPSL) + ENDDO +! +!---------------------------------------------------------------------- +!*** MIXING LENGTH FOR THE QNSE MODEL IN STABLE CASE +!---------------------------------------------------------------------- +! + F=MAX(CORF,EPS1) + RLAMBDA=F/(BLCKDR*USTAR) + DO K=KTE,KTS+1,-1 + IF(EN2(K)>=0.0)THEN ! Stable case + VKRMZ=(Z(K)-Z(LMH))*VKARMAN + RLB=RLAMBDA+1./VKRMZ + RLN=SQRT(2.*EN2(K)/Q2(K))/CN +! EL(K)=MIN(1./(RLB+RLN),ELM(K)) + EL(K)=1./(RLB+RLN) + ENDIF + ENDDO +! +!---------------------------------------------------------------------- + END SUBROUTINE MIXLEN +!---------------------------------------------------------------------- +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE PRODQ2 & +!---------------------------------------------------------------------- +! ****************************************************************** +! * * +! * LEVEL 2.5 Q2 PRODUCTION/DISSIPATION * +! * * +! ****************************************************************** +! + &(LMH,DTTURBL,USTAR,S2,RI,Q2,EL,Z,AKM,AKH & + &,UXK,VXK,THXK,THVXK & + &,HGAMU,HGAMV,HGAMT & + &,HPBL,PBLFLG,KPBL & + &,ZFACENTK,UFXPBL,VFXPBL,HFXPBL & + &,IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE) +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE +! + INTEGER,INTENT(IN) :: LMH +! + REAL,INTENT(IN) :: DTTURBL,USTAR +! + REAL,DIMENSION(KTS+1:KTE),INTENT(IN) :: S2,RI,AKM,AKH,EL +! + REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z +! + REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2 +! + REAL,DIMENSION(KTS:KTE),INTENT(IN) :: UXK,VXK,THXK,THVXK + REAL,INTENT(IN) :: HGAMU,HGAMV,HGAMT,HPBL +! + INTEGER,INTENT(IN) :: KPBL + LOGICAL,INTENT(IN) :: PBLFLG +! + REAL,DIMENSION(KTS+1:KTE),INTENT(IN) :: ZFACENTK + REAL,INTENT(IN) :: UFXPBL,VFXPBL,HFXPBL +! +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER :: K +! + REAL :: S2L,Q2L,DELTAZ,AKML,AKHL,EN2,PR,BPR,DIS,RC02 + REAL :: SUK,SVK,GTHVK,GOVRTHVK,PRU,PRV + REAL :: ZFACENTL +! +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +! + RC02=2.0/(C0*C0) + main_integration: DO K=KTS+1,KTE + DELTAZ=0.5*(Z(K+1)-Z(K-1)) + S2L=S2(K) + Q2L=Q2(K) + SUK=(UXK(K)-UXK(K-1))/DELTAZ + SVK=(VXK(K)-VXK(K-1))/DELTAZ + GTHVK=(THVXK(K)-THVXK(K-1))/DELTAZ + GOVRTHVK=G/(0.5*(THVXK(K)+THVXK(K-1))) + AKML=AKM(K) + AKHL=AKH(K) + ZFACENTL=ZFACENTK(K) + EN2=RI(K)*S2L !N**2 +! +!*** TURBULENCE PRODUCTION TERM +! + IF(PBLFLG.AND.K.LE.KPBL)THEN + PRU=(AKML*(SUK-HGAMU/HPBL))*SUK + PRV=(AKML*(SVK-HGAMV/HPBL))*SVK + PRU=(AKML*(SUK-HGAMU/HPBL)-UFXPBL*ZFACENTL)*SUK + PRV=(AKML*(SVK-HGAMV/HPBL)-VFXPBL*ZFACENTL)*SVK + ELSE + PRU=AKML*SUK*SUK + PRV=AKML*SVK*SVK + ENDIF + PR=PRU+PRV +! +!*** BUOYANCY PRODUCTION +! + IF(PBLFLG.AND.K.LE.KPBL)THEN + BPR=(AKHL*(GTHVK-HGAMT/HPBL))*GOVRTHVK + BPR=(AKHL*(GTHVK-HGAMT/HPBL)-HFXPBL*ZFACENTL)*GOVRTHVK + ELSE + BPR=AKHL*GTHVK*GOVRTHVK + ENDIF +! +!*** DISSIPATION +! + DIS=CEPS*(0.5*Q2L)**1.5/EL(K) +! + Q2L=Q2L+2.0*(PR-BPR-DIS)*DTTURBL + Q2(K)=AMAX1(Q2L,EPSQ2L) +!---------------------------------------------------------------------- +!*** END OF PRODUCTION/DISSIPATION LOOP +!---------------------------------------------------------------------- +! + ENDDO main_integration +! +!---------------------------------------------------------------------- +!*** LOWER BOUNDARY CONDITION FOR Q2 +!---------------------------------------------------------------------- +! + Q2(KTS)=AMAX1(RC02*USTAR*USTAR,EPSQ2L) +!---------------------------------------------------------------------- +! + END SUBROUTINE PRODQ2 +! +!---------------------------------------------------------------------- +!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +!---------------------------------------------------------------------- + SUBROUTINE VDIFQ & +! ****************************************************************** +! * * +! * VERTICAL DIFFUSION OF Q2 (TKE) * +! * * +! ****************************************************************** + &(LMH,DTDIF,Q2,EL,Z & + &,AKHK & + &,HGAME,HPBL,PBLFLG,KPBL & + &,EFXPBL & + &,IDS,IDE,JDS,JDE,KDS,KDE & + &,IMS,IME,JMS,JME,KMS,KME & + &,ITS,ITE,JTS,JTE,KTS,KTE) +!---------------------------------------------------------------------- +! + IMPLICIT NONE +! +!---------------------------------------------------------------------- + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE +! + INTEGER,INTENT(IN) :: LMH +! + REAL,INTENT(IN) :: DTDIF +! + REAL,DIMENSION(KTS+1:KTE),INTENT(IN) :: EL + REAL,DIMENSION(KTS+1:KTE),INTENT(IN) :: AKHK + REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z +! + REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2 +! + REAL,DIMENSION(KTS:KTE),INTENT(IN) :: HGAME + REAL,INTENT(IN) :: HPBL + INTEGER,INTENT(IN) :: KPBL + LOGICAL,INTENT(IN) :: PBLFLG +! + REAL,INTENT(IN) :: EFXPBL +! +! +!---------------------------------------------------------------------- +!*** +!*** LOCAL VARIABLES +!*** + INTEGER :: K +! + REAL :: ADEN,AKQS,BDEN,BESH,BESM,CDEN,CF,DTOZS,ELL,ELOQ2,ELOQ4 & + & ,ELQDZ,ESH,ESM,ESQHF,GHL,GML,Q1L,RDEN,RDZ + REAL :: ZAK +! + REAL,DIMENSION(KTS+2:KTE) :: AKQ,CM,CR,DTOZ,RSQ2 + REAL,DIMENSION(KTS+1:KTE) :: ZFACENTK +! + REAL,PARAMETER :: C_K=1.0 +!---------------------------------------------------------------------- +!********************************************************************** +!---------------------------------------------------------------------- +!*** +!*** VERTICAL TURBULENT DIFFUSION +!*** +!---------------------------------------------------------------------- + ESQHF=0.5*ESQ + DO K=KTS+1,KTE + ZAK=0.5*(Z(K)+Z(K-1)) !ZAK OF VDIFQ = ZA(K-1) OF SHINHONG2D + ZFACENTK(K)=(ZAK/HPBL)**3.0 + ENDDO +! + DO K=KTE,KTS+2,-1 + DTOZ(K)=(DTDIF+DTDIF)/(Z(K+1)-Z(K-1)) + AKQ(K)=C_K*(AKHK(K)/(Z(K+1)-Z(K-1))+AKHK(K-1)/(Z(K)-Z(K-2))) + CR(K)=-DTOZ(K)*AKQ(K) + ENDDO +! + AKQS=C_K*AKHK(KTS+1)/(Z(KTS+2)-Z(KTS)) + CM(KTE)=DTOZ(KTE)*AKQ(KTE)+1. + RSQ2(KTE)=Q2(KTE) +! + DO K=KTE-1,KTS+2,-1 + CF=-DTOZ(K)*AKQ(K+1)/CM(K+1) + CM(K)=-CR(K+1)*CF+(AKQ(K+1)+AKQ(K))*DTOZ(K)+1. + RSQ2(K)=-RSQ2(K+1)*CF+Q2(K) + IF(PBLFLG.AND.K.LT.KPBL) THEN + RSQ2(K)=RSQ2(K)-DTOZ(K)*(2.0*HGAME(K)/HPBL)*AKQ(K+1)*(Z(K+1)-Z(K)) & + +DTOZ(K)*(2.0*HGAME(K-1)/HPBL)*AKQ(K)*(Z(K)-Z(K-1)) + RSQ2(K)=RSQ2(K)-DTOZ(K)*2.0*EFXPBL*ZFACENTK(K+1) & + +DTOZ(K)*2.0*EFXPBL*ZFACENTK(K) + ENDIF + ENDDO +! + DTOZS=(DTDIF+DTDIF)/(Z(KTS+2)-Z(KTS)) + CF=-DTOZS*AKQ(LMH+2)/CM(LMH+2) +! + IF(PBLFLG.AND.((LMH+1).LT.KPBL)) THEN + Q2(LMH+1)=(DTOZS*AKQS*Q2(LMH)-RSQ2(LMH+2)*CF+Q2(LMH+1) & + -DTOZS*(2.0*HGAME(LMH+1)/HPBL)*AKQ(LMH+2)*(Z(LMH+2)-Z(LMH+1)) & + +DTOZS*(2.0*HGAME(LMH)/HPBL)*AKQS*(Z(LMH+1)-Z(LMH))) + Q2(LMH+1)=Q2(LMH+1)-DTOZS*2.0*EFXPBL*ZFACENTK(LMH+2) & + +DTOZS*2.0*EFXPBL*ZFACENTK(LMH+1) + Q2(LMH+1)=Q2(LMH+1)/((AKQ(LMH+2)+AKQS)*DTOZS-CR(LMH+2)*CF+1.) + ELSE + Q2(LMH+1)=(DTOZS*AKQS*Q2(LMH)-RSQ2(LMH+2)*CF+Q2(LMH+1)) & + & /((AKQ(LMH+2)+AKQS)*DTOZS-CR(LMH+2)*CF+1.) + ENDIF +! + DO K=LMH+2,KTE + Q2(K)=(-CR(K)*Q2(K-1)+RSQ2(K))/CM(K) + ENDDO +!---------------------------------------------------------------------- +! + END SUBROUTINE VDIFQ +! +!---------------------------------------------------------------------- +end module module_bl_shinhong +!------------------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_bl_ysu.F b/wrfv2_fire/phys/module_bl_ysu.F index f682615d..3ad60517 100644 --- a/wrfv2_fire/phys/module_bl_ysu.F +++ b/wrfv2_fire/phys/module_bl_ysu.F @@ -24,7 +24,8 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & exch_h, & wstar,delta, & u10,v10, & - uoce,voce, & + uoce,voce, & + rthraten,ysu_topdown_pblmix, & ctopo,ctopo2, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -112,6 +113,8 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte + + integer, intent(in) :: ysu_topdown_pblmix ! real, intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv ! @@ -125,7 +128,8 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & pi3d, & th3d, & t3d, & - dz8w + dz8w, & + rthraten real, dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: p3di ! @@ -263,6 +267,8 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & ,delta=delta(ims,j) & ,u10=u10(ims,j),v10=v10(ims,j) & ,uox=uoce(ims,j),vox=voce(ims,j) & + ,rthraten=rthraten(ims,kms,j),p2diORG=p3di(ims,kms,j) & + ,ysu_topdown_pblmix=ysu_topdown_pblmix & ,ctopo=ctopo(ims,j),ctopo2=ctopo2(ims,j) & ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde & ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme & @@ -295,6 +301,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & wstar,delta, & u10,v10, & uox,vox, & + rthraten,p2diORG, & + ysu_topdown_pblmix, & ctopo,ctopo2, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -375,6 +383,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & j,ndiff + + integer, intent(in) :: ysu_topdown_pblmix ! real, intent(in ) :: dt,rcl,cp,g,rovcp,rovg,rd,xlv,rv ! @@ -382,7 +392,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! real, dimension( ims:ime, kms:kme ), & intent(in) :: dz8w2d, & - pi2d + pi2d, & + p2diorg ! real, dimension( ims:ime, kms:kme ) , & intent(in ) :: tx @@ -401,7 +412,6 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! real, dimension( its:ite, kts:kte ) , & intent(in ) :: p2d -! ! real, dimension( ims:ime ) , & intent(inout) :: ust, & @@ -423,7 +433,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! real, dimension( ims:ime, kms:kme ) , & intent(in ) :: ux, & - vx + vx, & + rthraten real, dimension( ims:ime ) , & optional , & intent(in ) :: ctopo, & @@ -438,7 +449,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & real, dimension( its:ite, kts:kte+1 ) :: zq ! real, dimension( its:ite, kts:kte ) :: & - thx,thvx, & + thx,thvx,thlix, & del, & dza, & dzq, & @@ -456,7 +467,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & dusfc,dvsfc, & dtsfc,dqsfc, & prpbl, & - wspd1 + wspd1,thermalli ! real, dimension( its:ite, kts:kte ) :: xkzm,xkzh, & f1,f2, & @@ -465,7 +476,9 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & cu, & al, & xkzq, & - zfac + zfac, & + rhox2, & + hgamt2 ! !jdf added exch_hx ! @@ -475,7 +488,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & real, dimension( ims:ime ) , & intent(inout) :: u10, & v10 - real, dimension( ims:ime ) , & + real, dimension( ims:ime ) , & intent(in ) :: uox, & vox real, dimension( its:ite ) :: & @@ -485,13 +498,16 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & brcr_sbro ! real, dimension( its:ite, kts:kte, ndiff) :: r3,f3 - integer, dimension( its:ite ) :: kpbl + integer, dimension( its:ite ) :: kpbl,kpblold ! logical, dimension( its:ite ) :: pblflg, & sfcflg, & - stable + stable, & + cloudflg + + logical :: definebrup ! - integer :: n,i,k,l,ic,is + integer :: n,i,k,l,ic,is,kk integer :: klpbl, ktrace1, ktrace2, ktrace3 ! ! @@ -503,13 +519,14 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & real :: cont, conq, conw, conwrc ! - real, dimension( its:ite, kts:kte ) :: wscalek + real, dimension( its:ite, kts:kte ) :: wscalek,wscalek2 real, dimension( ims:ime ) :: wstar real, dimension( ims:ime ) :: delta real, dimension( its:ite, kts:kte ) :: xkzml,xkzhl, & zfacent,entfac real, dimension( its:ite ) :: ust3, & wstar3, & + wstar3_2, & hgamu,hgamv, & wm2, we, & bfxpbl, & @@ -518,7 +535,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & dthvx real :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & - prfac,prfac2,phim8z + prfac,prfac2,phim8z,radsum,tmp1,templ,rvls,temps,ent_eff, & + rcldb,bruptmp,radflux ! !------------------------------------------------------------------------------- ! @@ -539,6 +557,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & do k = kts,kte do i = its,ite thx(i,k) = tx(i,k)/pi2d(i,k) + thlix(i,k) = (tx(i,k)-xlv*qx(i,ktrace2+k)/cp-2.834E6*qx(i,ktrace3+k)/cp)/pi2d(i,k) enddo enddo ! @@ -565,6 +584,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & do k = kts,kte do i = its,ite zq(i,k+1) = dz8w2d(i,k)+zq(i,k) + tvcon = (1.+ep1*qx(i,k)) + rhox2(i,k) = p2d(i,k)/(rd*tx(i,k)*tvcon) enddo enddo ! @@ -616,11 +637,13 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & hgamu(i) = 0.0 hgamv(i) = 0.0 delta(i) = 0.0 + wstar3_2(i) = 0.0 enddo ! do k = kts,klpbl do i = its,ite wscalek(i,k) = 0.0 + wscalek2(i,k) = 0.0 enddo enddo ! @@ -650,6 +673,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & hpbl(i) = zq(i,1) zl1(i) = za(i,1) thermal(i)= thvx(i,1) + thermalli(i) = thlix(i,1) pblflg(i) = .true. sfcflg(i) = .true. sflux(i) = hfx(i)/rhox(i)/cp + qfx(i)/rhox(i)*ep1*thx(i,1) @@ -730,6 +754,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & hgamq(i) = min(gamfac*qfx(i),gamcrq) vpert = (hgamt(i)+ep1*thx(i,1)*hgamq(i))/bfac*afac thermal(i) = thermal(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) + thermalli(i)= thermalli(i)+max(vpert,0.)*min(za(i,1)/(sfcfrac*hpbl(i)),1.0) hgamt(i) = max(hgamt(i),0.0) hgamq(i) = max(hgamq(i),0.0) brint = -15.9*ust(i)*ust(i)/wspd(i)*wstar3(i)/(wscale(i)**4.) @@ -769,6 +794,30 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & enddo enddo ! +! enhance pbl by theta-li +! + if (ysu_topdown_pblmix.eq.1)then + do i = its,ite + kpblold(i) = kpbl(i) + definebrup=.false. + do k = kpblold(i), kte-1 + spdk2 = max(ux(i,k)**2+vx(i,k)**2,1.) + bruptmp = (thlix(i,k)-thermalli(i))*(g*za(i,k)/thlix(i,1))/spdk2 + stable(i) = bruptmp.ge.brcr(i) + if (definebrup) then + kpbl(i) = k + brup(i) = bruptmp + definebrup=.false. + endif + if (.not.stable(i)) then !overwrite brup brdn values + brdn(i)=bruptmp + definebrup=.true. + pblflg(i)=.true. + endif + enddo + enddo + endif + do i = its,ite if(pblflg(i)) then k = kpbl(i) @@ -846,16 +895,78 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! estimate the entrainment parameters ! do i = its,ite + cloudflg(i)=.false. if(pblflg(i)) then k = kpbl(i) - 1 - prpbl(i) = 1.0 wm3 = wstar3(i) + 5. * ust3(i) wm2(i) = wm3**h2 bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + if((qx(i,ktrace2+k)+qx(i,ktrace3+k)).gt.0.01e-3.and.ysu_topdown_pblmix.eq.1)then + if ( kpbl(i) .ge. 2) then + cloudflg(i)=.true. + templ=thlix(i,k)*(p2di(i,k+1)/100000)**rovcp + !rvls is ws at full level + rvls=100.*6.112*EXP(17.67*(templ-273.16)/(templ-29.65))*(ep2/p2di(i,k+1)) + temps=templ + ((qx(i,k)+qx(i,ktrace2+k))-rvls)/(cp/xlv + & + ep2*xlv*rvls/(rd*templ**2)) + rvls=100.*6.112*EXP(17.67*(temps-273.15)/(temps-29.65))*(ep2/p2di(i,k+1)) + rcldb=max((qx(i,k)+qx(i,ktrace2+k))-rvls,0.) + !entrainment efficiency + dthvx(i) = (thlix(i,k+2)+thx(i,k+2)*ep1*(qx(i,k+2)+qx(i,ktrace2+k+2))) & + - (thlix(i,k) + thx(i,k) *ep1*(qx(i,k) +qx(i,ktrace2+k))) + dthvx(i) = max(dthvx(i),0.1) + tmp1 = xlv/cp * rcldb/(pi2d(i,k)*dthvx(i)) + ent_eff = 0.2 * 8. * tmp1 +0.2 + + radsum=0. + do kk = 1,kpbl(i)-1 + radflux=rthraten(i,kk)*pi2d(i,kk) !converts theta/s to temp/s + radflux=radflux*cp/g*(p2diORG(i,kk)-p2diORG(i,kk+1)) ! converts temp/s to W/m^2 + if (radflux < 0.0 ) radsum=abs(radflux)+radsum + enddo + radsum=max(radsum,0.0) + + !recompute entrainment from sfc thermals + bfx0 = max(max(sflux(i),0.0)-radsum/rhox2(i,k)/cp,0.) + bfx0 = max(sflux(i),0.0) + wm3 = (govrth(i)*bfx0*hpbl(i))+5. * ust3(i) + wm2(i) = wm3**h2 + bfxpbl(i) = -0.15*thvx(i,1)/g*wm3/hpbl(i) + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),tmin) + we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) + + !entrainment from PBL top thermals + bfx0 = max(radsum/rhox2(i,k)/cp-max(sflux(i),0.0),0.) + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wm3 = (g/thvx(i,k)*bfx0*hpbl(i)) ! this is wstar3(i) + wm2(i) = wm2(i)+wm3**h2 + bfxpbl(i) = - ent_eff * bfx0 + dthvx(i) = max(thvx(i,k+1)-thvx(i,k),0.1) + we(i) = we(i) + max(bfxpbl(i)/dthvx(i),-sqrt(wm3**h2)) + + !wstar3_2 + bfx0 = max(radsum/rhox2(i,k)/cp,0.) + wstar3_2(i) = (g/thvx(i,k)*bfx0*hpbl(i)) + !recompute hgamt + wscale(i) = (ust3(i)+phifac*karman*(wstar3(i)+wstar3_2(i))*0.5)**h1 + wscale(i) = min(wscale(i),ust(i)*aphi16) + wscale(i) = max(wscale(i),ust(i)/aphi5) + gamfac = bfac/rhox(i)/wscale(i) + hgamt(i) = min(gamfac*hfx(i)/cp,gamcrt) + hgamq(i) = min(gamfac*qfx(i),gamcrq) + gamfac = bfac/rhox2(i,k)/wscale(i) + hgamt2(i,k) = min(gamfac*radsum/cp,gamcrt) + hgamt(i) = max(hgamt(i),0.0) + max(hgamt2(i,k),0.0) + brint = -15.9*ust(i)*ust(i)/wspd(i)*(wstar3(i)+wstar3_2(i))/(wscale(i)**4.) + hgamu(i) = brint*ux(i,1) + hgamv(i) = brint*vx(i,1) + endif + endif + prpbl(i) = 1.0 dthx = max(thx(i,k+1)-thx(i,k),tmin) dqx = min(qx(i,k+1)-qx(i,k),0.0) - we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) hfxpbl(i) = we(i)*dthx qfxpbl(i) = we(i)*dqx ! @@ -898,9 +1009,10 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & zfac(i,k) = min(max((1.-(zq(i,k+1)-zl1(i))/(hpbl(i)-zl1(i))),zfmin),1.) zfacent(i,k) = (1.-zfac(i,k))**3. wscalek(i,k) = (ust3(i)+phifac*karman*wstar3(i)*(1.-zfac(i,k)))**h1 + wscalek2(i,k) = (phifac*karman*wstar3_2(i)*(zfac(i,k)))**h1 if(sfcflg(i)) then prfac = conpr - prfac2 = 15.9*wstar3(i)/ust3(i)/(1.+4.*karman*wstar3(i)/ust3(i)) + prfac2 = 15.9*(wstar3(i)+wstar3_2(i))/ust3(i)/(1.+4.*karman*(wstar3(i)+wstar3_2(i))/ust3(i)) prnumfac = -3.*(max(zq(i,k+1)-sfcfrac*hpbl(i),0.))**2./hpbl(i)**2. else prfac = 0. @@ -912,7 +1024,12 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & endif prnum0 = (phih(i)/phim(i)+prfac) prnum0 = max(min(prnum0,prmax),prmin) - xkzm(i,k) = wscalek(i,k)*karman*zq(i,k+1)*zfac(i,k)**pfac + xkzm(i,k) = wscalek(i,k) *karman* zq(i,k+1) * zfac(i,k)**pfac+ & + wscalek2(i,k)*karman*(hpbl(i)-zq(i,k+1))*(1-zfac(i,k))**pfac + !Do not include xkzm at kpbl-1 since it changes entrainment + if (k.eq.kpbl(i)-1.and.cloudflg(i).and.we(i).lt.0.0) then + xkzm(i,k) = 0.0 + endif prnum = 1. + (prnum0-1.)*exp(prnumfac) xkzq(i,k) = xkzm(i,k)/prnum*zfac(i,k)**(pfac_q-pfac) prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) diff --git a/wrfv2_fire/phys/module_cam_mp_microp_aero.F b/wrfv2_fire/phys/module_cam_mp_microp_aero.F index c8b0e8ea..04e35185 100644 --- a/wrfv2_fire/phys/module_cam_mp_microp_aero.F +++ b/wrfv2_fire/phys/module_cam_mp_microp_aero.F @@ -1,5 +1,5 @@ #define WRF_PORT -#if defined ( WRF_CHEM ) +#if ( WRF_CHEM == 1 ) # include "../chem/MODAL_AERO_CPP_DEFINES.h" #else # define MODAL_AERO diff --git a/wrfv2_fire/phys/module_cam_mp_ndrop.F b/wrfv2_fire/phys/module_cam_mp_ndrop.F index 848146c1..a9ab7447 100644 --- a/wrfv2_fire/phys/module_cam_mp_ndrop.F +++ b/wrfv2_fire/phys/module_cam_mp_ndrop.F @@ -1581,7 +1581,6 @@ subroutine maxsat(zeta,eta,nmode,smc,smax) g1=zeta(m)/eta(m) g1sqrt=sqrt(g1) g1=g1sqrt*g1 - g1=g1sqrt*g1 g2=smc(m)/sqrt(eta(m)+3._r8*zeta(m)) g2sqrt=sqrt(g2) g2=g2sqrt*g2 diff --git a/wrfv2_fire/phys/module_cam_support.F b/wrfv2_fire/phys/module_cam_support.F index 14466a5b..b35cabac 100644 --- a/wrfv2_fire/phys/module_cam_support.F +++ b/wrfv2_fire/phys/module_cam_support.F @@ -88,7 +88,7 @@ MODULE module_cam_support !From cam_history_support.F90 real(r8), parameter, public :: fillvalue = 1.e36_r8 ! fill value for netcdf fields -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !For module_cam_mam_gas_wetdep_driver.F !BSINGH - We are going to operate on only 6 gases (following MOSAIC - !module_mosaic_wetscav.F). MOSAIC actually operates upon 7 gases but MAM diff --git a/wrfv2_fire/phys/module_cu_camzm.F b/wrfv2_fire/phys/module_cu_camzm.F index d54b4659..e9116687 100644 --- a/wrfv2_fire/phys/module_cu_camzm.F +++ b/wrfv2_fire/phys/module_cu_camzm.F @@ -197,7 +197,16 @@ subroutine zm_convi(DT,DX,limcnv_in, no_deep_pbl_in) ! convection is too weak, thus adjusted to 2400. #ifndef WRF_PORT hgrid = get_resolution() -#endif + tau = 3600._r8 +! PMA: Standard 2-deg CAM5.1 uses 1-hr relaxation time scale which is too long for the +! mesoscale model to remove CAPE quickly. As a result, the model generates grid-scale +! storms and becomes unstable sometimes (Williamson, 2012). Hence, we sets tau as a function +! of the length of time step. The caveat of this is that the model behavior +! of precipitation will be different to CAM5. We acknowledge that reducing dynamical +! time step can also make a stable model simulation. March 12, 2013 +! + tau = max(min(2._r8*DTT,1200._r8),120._r8) +#else !PMA: The 1.9x2.5 deg CAM5 uses tau = 3600s. With higher resolution and shorter timestep in CAM, ! tau is set to a smaller value. Williamson (2012) found that without reducing tau in a high-res @@ -218,6 +227,7 @@ subroutine zm_convi(DT,DX,limcnv_in, no_deep_pbl_in) tau = max(taumin, taumax*min(1._r8,deltax/ref_dx)) +#endif if ( masterproc ) then write(iulog,*) 'delta X =',deltax #ifdef WRF_PORT @@ -229,6 +239,10 @@ subroutine zm_convi(DT,DX,limcnv_in, no_deep_pbl_in) call wrf_debug(1,iulog) #endif write(iulog,*) 'tuning parameters zm_convi: tau',tau +#ifdef WRF_PORT + call wrf_message(iulog) +#endif + write(iulog,*) 'Standard 2-deg CAM5.1 sets tau=3600s and is reduced for the mesoscale model WRF' #ifdef WRF_PORT call wrf_debug(1,iulog) #endif diff --git a/wrfv2_fire/phys/module_cu_camzm_driver.F b/wrfv2_fire/phys/module_cu_camzm_driver.F index 6869c188..52fad5bc 100644 --- a/wrfv2_fire/phys/module_cu_camzm_driver.F +++ b/wrfv2_fire/phys/module_cu_camzm_driver.F @@ -21,7 +21,7 @@ MODULE module_cu_camzm_driver USE module_cam_support, only: pcnst =>pcnst_runtime, pcols, pver, pverp -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_cam_support, only: cam_mam_aerosols #endif USE shr_kind_mod, only: r8 => shr_kind_r8 @@ -32,7 +32,7 @@ MODULE module_cu_camzm_driver PRIVATE !Default to private PUBLIC :: & !Public entities camzm_driver , & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) zm_conv_tend_2, & #endif zm_conv_init @@ -100,7 +100,7 @@ SUBROUTINE camzm_driver( & dz8w, & !height between interfaces (m) p, & !pressure at mid-level (Pa) p8w, & !pressure at level interface (Pa) - pi_phy, & !exner function, (p0/p)^(R/cpair) (none) + pi_phy, & !exner function, (p/p0)^(R/cpair) (none) qv, & !water vapor mixing ratio (kg/kg-dry air) th, & !potential temperature (K) tke_pbl, & !turbulent kinetic energy from PBL (m2/s2) @@ -238,7 +238,7 @@ SUBROUTINE camzm_driver( & !BSINGH - 02/18/2013: FRACIS is used for qv,qc and qi for WRF_CHEM simulation but for ! WRF simulations it is used for qnc and qni also -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) REAL(r8), DIMENSION(pcols, kte, 3) :: & #else REAL(r8), DIMENSION(pcols, kte, 5) :: & @@ -670,7 +670,7 @@ SUBROUTINE camzm_driver( & l_qt(2:3) = .true. !do mix cloud water and ice cloudtnd = 0._r8 fracis(1,:,1:3) = 1._r8 !all cloud liquid & ice -#ifndef WRF_CHEM +#if ( WRF_CHEM != 1 ) !BSINGH:02/01/2013: For WRF Physics ONLY runs, the liq # and ice # should !also be transpoted. Please note that liq # and ice # are transported in the !zm_conv_tend_2 call for WRF_CHEM simulations (ONLY works for MAM aerosols) @@ -1023,7 +1023,7 @@ END SUBROUTINE get_tpert !========================================================================================= -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) subroutine zm_conv_tend_2(itimestep, dt, p8w, fracis3d, dp3d, du3d, ed3d, eu3d, md3d, mu3d, & dsubcld2d, ideep2d, jt2d, maxg2d, lengath2d, moist, scalar, chem, & ids,ide, jds,jde, kds,kde, & diff --git a/wrfv2_fire/phys/module_cu_kfcup.F b/wrfv2_fire/phys/module_cu_kfcup.F new file mode 100644 index 00000000..1cba849c --- /dev/null +++ b/wrfv2_fire/phys/module_cu_kfcup.F @@ -0,0 +1,5544 @@ +!-------------------------------------------------------------------- +! Kain-Fritsch + CuP Cumulus Parameterization +! +! Module contents: +! kf_cup_cps* - the top-level driver routine +! kf_cup_para* - the guts of the KF scheme +! tpmix2 +! dtfrznew +! condload +! prof5 +! tpmix2dd +! envirtht +! kf_cup_init* +! kf_lutab +! cupCloudFraction* +! cup_jfd* +! cupSlopeSigma* +! findCp* +! findIndex* +! findRs* +! findRsi* +! +! * = Subroutine either modified or added for CuP compared to the +! original kfeta scheme. +!-------------------------------------------------------------------- + +!-------------------------------------------------------------------- +!TODO's: +! - Add variable descriptions with units and other code docs +! - Should we vary rBinSize based on t2 to get more sensitivity when cold? +! - Figure out appropriate limiting values for the slopes and sigmas +! that ensure the jfd sums to one and gives at least some +! perturbations. +! - Figure out how to make minimum frequency settings dependent upon +! the chosen bin sizes. +! - Tie cloud radius calc. to dx or the shallow trigger. +! - When run with a small dx, deep convection should never be allowed +! to trigger. Right now, it can. +! - Figure out how to do cloud fraction feedback. +! - Figure out how to handle combination of liquid and ice for cloud +! fraction calculation. +! - Clean up cldfratend_cup once we are sure that it will never be +! used again. +! - When fluxes are negative, wstar goes negative and then the +! time scales go negative for tstar and taucloud. The neg. cancels +! out for the cloud fraction, but it is troublesome none the less. +! - Deep convective clouds don't necessarily develop concurrent +! condensed phase mass. This has impacts for radiation and should +! be investigated. +!-------------------------------------------------------------------- + +MODULE module_cu_kfcup + + USE module_wrf_error + + IMPLICIT NONE + +!-------------------------------------------------------------------- +! Lookup table variables: + INTEGER, PARAMETER, PRIVATE :: KFNT=250,KFNP=220 + REAL, DIMENSION(KFNT,KFNP),PRIVATE, SAVE :: TTAB,QSTAB + REAL, DIMENSION(KFNP),PRIVATE, SAVE :: THE0K + REAL, DIMENSION(200),PRIVATE, SAVE :: ALU + REAL, PRIVATE, SAVE :: RDPR,RDTHK,PLUTOP + +! Note: KF Lookup table is used by subroutines KF_cup_PARA, TPMIX2, +! TPMIX2DD, ENVIRTHT +! End of Lookup table variables: + + real, parameter, private :: eps=0.622 !used to be epsilon + !real, parameter, private :: reallysmall=1e-30 !for div by 0 checks + real, parameter, private :: reallysmall=5e-4 !for div by 0 checks + +! if ==1, apply barahona and nenes (2007) entrainment adjustment to activation +! at cloud base ; if =/1, do not apply this + integer, parameter, private :: qndrop_cldbase_entrain_opt = 1 +! if ==1, updraft qndrop above cloud base is reduced by entrainment (dilution) ; +! if /=1, no dilution + integer, parameter, private :: qndrop_incloud_entrain_opt = 1 +! minimum vertical velocity (m/s) passed to activate routine + real, parameter, private :: w_act_min = 0.2 + +! for testing -- multiply aerosol number/volume by this before activation calculation +! real, parameter, private :: naero_adjust_factor = 1.0 +! for testing -- if ==1, set aerosol size to dcen_sect for activation calcs +! if /=1, do not adjust aerosol size +! integer, parameter, private :: vaero_dsect_adjust_opt = 0 + + +CONTAINS + + SUBROUTINE KF_cup_CPS( grid_id, & ! rce 10-may-2012 + ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,DT,KTAU,DX & + ,rho,RAINCV,NCA & + ,U,V,TH,T,W,dz8w,Pcps,pi & + ,W0AVG,XLV0,XLV1,XLS0,XLS1,CP,R,G,EP1 & + ,EP2,SVP1,SVP2,SVP3,SVPT0 & + ,STEPCU,CU_ACT_FLAG,warm_rain,CUTOP,CUBOT & + ,QV & + ,xland & !LD 18-Oct-2011 + ,psfc,z,z_at_w,ht,tsk,hfx,qfx,mavail & !CuP, wig, 24-Aug-2006 + ,sf_sfclay_physics & !CuP, wig, 24-Aug-2006 + ,br,regime,pblh,kpbl,t2,q2 & !CuP, wig, 24-Aug-2006 + ,slopeSfc,slopeEZ,sigmasfc,sigmaEZ & !CuP, wig, 24-Aug-2006 + ,cupflag,cldfra_cup,cldfratend_cup & !CuP, wig, 18-Sep-2006 + ,shall,taucloud,tactive & !CuP, wig, 18-Sep-2006 + ,activeFrac & !CuP, lkb 5-May-2010 + ,tstar, lnterms & !CuP, wig 4-Oct-2006 + ,lnint & !CuP, wig 4-Oct-2006 + ,numBins, thBinSize, rBinSize & !CuP, lkb 4-Nov-2009 + ,minDeepFreq, minShallowFreq & !CuP, lkb 4-Nov-2009 + ,wCloudBase & !CuP, lkb 4-April-2010 + ,wact_cup & !CuP, rce 10-may-2012 + ,wulcl_cup & !CuP, rce 10-may-2012 + ,wup_cup & !CuP, rce 15-mar-2013 + ,qc_ic_cup & !CuP, rce 10-may-2012 + ,qndrop_ic_cup & !CuP, rce 10-may-2012 + ,qc_iu_cup & !CuP, rce 10-may-2012 + ,fcvt_qc_to_pr_cup & !CuP, rce 10-may-2012 + ,fcvt_qc_to_qi_cup & !CuP, rce 10-may-2012 + ,fcvt_qi_to_pr_cup & !CuP, rce 10-may-2012 + ,mfup_cup & !CuP, rce 10-may-2012 + ,mfup_ent_cup & !CuP, rce 10-may-2012 + ,mfdn_cup & !CuP, rce 10-may-2012 + ,mfdn_ent_cup & !CuP, rce 10-may-2012 + ,updfra_cup & !CuP, rce 10-may-2012 + ,tcloud_cup & !CuP, rce 10-may-2012 + ,shcu_aerosols_opt & !CuP, rce 10-may-2012 + ! optionals + ,chem_opt & !CuP, rce 10-may-2012 + ,chem & !CuP, rce 10-may-2012 + ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & + ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN & + ,RQICUTEN,RQSCUTEN & + ) +! + USE module_state_description, only: num_chem +#if ( WRF_CHEM == 1 ) + USE module_state_description, only: cbmz_mosaic_4bin, cbmz_mosaic_4bin_aq, & + cbmz_mosaic_8bin, cbmz_mosaic_8bin_aq, & + saprc99_mosaic_8bin_vbs2_aq_kpp, & + saprc99_mosaic_8bin_vbs2_kpp + USE module_data_mosaic_asect, only: maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ntype_aer, nsize_aer, ncomp_aer, & + ai_phase, msectional, massptr_aer, numptr_aer, & + dlo_sect, dhi_sect, dens_aer, hygro_aer, sigmag_aer +#endif + +!------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------- + INTEGER, INTENT(IN ) :: grid_id, & !rce 10-may-2012 + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: STEPCU + LOGICAL, INTENT(IN ) :: warm_rain + + REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1 + REAL, INTENT(IN ) :: CP,R,G,EP1,EP2 + REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 + + INTEGER, INTENT(IN ) :: KTAU, & + sf_sfclay_physics, & !CuP, wig, 24-Aug-2006 + shcu_aerosols_opt !CuP, rce, 10-may-2012 + + INTEGER, DIMENSION( ims:ime , jms:jme ) , & !CuP, wig, 24-Aug-2006 + INTENT(IN ) :: & !CuP, wig, 24-Aug-2006 + kpbl !Note that this is different from kpbl in the main KF scheme below. CuP, wig, 24-Aug-2006 + + REAL, DIMENSION( ims:ime , jms:jme ) , & !CuP, wig, 24-Aug-2006 + INTENT(IN ) :: & !CuP, wig, 24-Aug-2006 + psfc, & !CuP, wig, 24-Aug-2006 + ht, & !CuP, wig, 24-Aug-2006 + tsk, & !CuP, wig, 24-Aug-2006 + hfx, & !CuP, wig, 24-Aug-2006 + qfx, & !CuP, wig, 24-Aug-2006 + mavail, & !CuP, wig, 24-Aug-2006 + br, & !CuP, wig, 24-Aug-2006 + regime, & !CuP, wig, 24-Aug-2006 + pblh, & !CuP, wig, 24-Aug-2006 + t2, & !CuP, wig, 24-Aug-2006 + q2, & !CuP, wig, 24-Aug-2006 + xland !LD 18-Oct-2011 + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + U, & + V, & + W, & + TH, & + T, & + QV, & + dz8w, & + Pcps, & + rho, & + pi, & + z, & !CuP, wig, 24-Aug-2006 + z_at_w !CuP, wig 5-Oct-2006 +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: & + W0AVG, & + cldfra_cup, & !CuP, wig, 18-Sep-2006 + cldfratend_cup !CuP, wig, 18-Sep-2006 + + REAL, INTENT(IN ) :: DT, DX +! + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: RAINCV + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: NCA, & + shall !CuP, wig, 18-Sep-2006 This has to be "real" because "integer" would only output zeros to the history file. + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(OUT) :: CUBOT, & + CUTOP, & + slopeSfc, & !CuP, wig, 24-Aug-2006 + slopeEZ, & !CuP, wig, 24-Aug-2006 + sigmaSfc, & !CuP, wig, 24-Aug-2006 + sigmaEZ, & !CuP, wig, 24-Aug-2006 + taucloud, & !CuP, wig, 1-Oct-2006 + tactive, & !CuP, wig, 1-Oct-2006 + tstar, & !CuP, wig, 4-Oct-2006 + lnint, & !CuP, wig, 4-Oct-2006 + activeFrac, & !CuP, lkb, 5-May-2010 + wCloudBase !CuP, lkb, 10-April-2010 + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: wact_cup, & !CuP, rce 10-may-2012 + wulcl_cup, & !CuP, rce 10-may-2012 + tcloud_cup !CuP, rce 10-may-2012 + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: & + wup_cup, & !CuP, rce 15-mar-2013 + qc_ic_cup, & !CuP, rce 10-may-2012 + qndrop_ic_cup, & !CuP, rce 10-may-2012 + qc_iu_cup, & !CuP, rce 10-may-2012 + fcvt_qc_to_pr_cup, & !CuP, rce 10-may-2012 + fcvt_qc_to_qi_cup, & !CuP, rce 10-may-2012 + fcvt_qi_to_pr_cup, & !CuP, rce 10-may-2012 + mfup_cup, & !CuP, rce 10-may-2012 + mfup_ent_cup, & !CuP, rce 10-may-2012 + mfdn_cup, & !CuP, rce 10-may-2012 + mfdn_ent_cup, & !CuP, rce 10-may-2012 + updfra_cup !CuP, rce 10-may-2012 + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(OUT) :: & + lnterms !CuP, wig 4-Oct-2006 + + LOGICAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: CU_ACT_FLAG, & + cupflag !CuP, wig 9-Oct-2006 + INTEGER, INTENT(IN) :: numBins + REAL, INTENT(IN) :: thBinSize, rBinSize + REAL, INTENT(IN) :: minDeepFreq, minShallowFreq +! +! Optional arguments +! + INTEGER, OPTIONAL, INTENT(IN ) :: chem_opt !CuP, rce 10-may-2012 + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme, 1:num_chem ),& + OPTIONAL, INTENT(IN) :: & + chem !CuP, rce 10-may-2012 + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + OPTIONAL, & + INTENT(INOUT) :: & + RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN + +! +! Flags relating to the optional tendency arrays declared above +! Models that carry the optional tendencies will provdide the +! optional arguments at compile time; these flags all the model +! to determine at run-time whether a particular tracer is in +! use or not. +! + LOGICAL, OPTIONAL :: & + F_QV & + ,F_QC & + ,F_QR & + ,F_QI & + ,F_QS + + +! LOCAL VARS + + LOGICAL :: flag_qr, flag_qi, flag_qs + LOGICAL :: flag_chem ! rce 10-may-2012 + + REAL, DIMENSION( kts:kte ) :: & + U1D, & + V1D, & + T1D, & + th1d, & !wig, CuP, 24-Aug-2006 + z1d, & !wig, CuP, 15-Sep-2006 + z_at_w1d, & !wig, CuP 5-Oct-2006 + DZ1D, & + QV1D, & + P1D, & + RHO1D, & + W0AVG1D, & + cldfra_cup1d, & !wig, CuP, 20-Sep-2006 + cldfratend_cup1d, & !wig, CuP, 20-Sep-2006 + qndrop1d, & !rce, CuP, 11-may-2012 + qc1d, & !rce, CuP, 11-may-2012 + qi1d, & !rce, CuP, 11-may-2012 + fcvt_qc_to_pr, & !rce, CuP, 11-may-2012 + fcvt_qc_to_qi, & !rce, CuP, 11-may-2012 + fcvt_qi_to_pr !rce, CuP, 11-may-2012 + + REAL, DIMENSION( kts:kte ):: & + DQDT, & + DQIDT, & + DQCDT, & + DQRDT, & + DQSDT, & + DTDT + + REAL, DIMENSION( kts:kte, 1:num_chem ) :: & + chem1d !rce, CuP, 11-may-2012 + + REAL :: TST,tv,PRS,RHOE,W0,SCR1,DXSQ,tmp,RTHCUMAX + + + INTEGER :: i,j,k,NTST,ICLDCK + +! Local vars specific to CuP... wig, 24-Aug-2006 +!~sensitivity test for 41 integer, parameter :: numBins = 21 !Number of perturbations for each variable (theta & qvapor) +!! integer, parameter :: numBins = 41 !41!Number of perturbations for each variable (theta & qvapor) +!! ! Should be an odd value. +!! real, parameter :: thBinSize = 0.1 !0.1 !Size of potential temp. perturbation increment (K) +!! real, parameter :: rBinSize = 1.0e-4 !1e-4 !Size of mxing ratio perturbation increment (kg/kg) +! real, parameter :: minFreq = 1e-5 !Minimum frequency required for a perturbation to be used ~should be dependent upon bin sizes +!! real, parameter :: minDeepFreq= 50e-2 !Cumulative freq. threshold before deep convection is allowed ~this was 5e-2 before + + integer :: ipert, ishall, jpert, kcubot, kcutop + !!real :: activeFrac, biggestDeepFreq, cumDeepFreq, cumShallFreq, & + real :: biggestDeepFreq, cumDeepFreq, cumShallFreq, & + cubot_deep, cutop_deep, nca_deep, raincv_deep, & + cubot_shall, cutop_shall, nca_shall, raincv_shall, & + minFreq, wstar, wLCL + real, dimension(numBins) :: r_perturb, th_perturb + real, dimension(numBins, numBins) :: jfd + real, dimension(kts:kte) :: dqdt_deep, dqidt_deep, dqcdt_deep, & + dqrdt_deep, dqsdt_deep, dtdt_deep, & + dqdt_shall, dqidt_shall, dqcdt_shall, & + dqrdt_shall, dqsdt_shall, dtdt_shall, & + qlg, qlg_shall, qig, qig_shall + character(len=200) :: message + +! rce 11-may-2012 mods start ------------------------------------------- + integer :: idiagee, idiagff + integer :: ipert_deepsv, jpert_deepsv + integer :: kcubotmin, kcubotmax, kcutopmin, kcutopmax + integer :: kupdrbot_deep, kupdrbot_shall + integer :: l + + logical :: ltmpa + + real :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpg, tmph, tmpi, tmpj + real :: tmpr, tmps, tmpx, tmpy, tmpz + real :: tmpcf + real :: tmp_nca, tmp_updfra + real :: tmpveca(1:999) + real :: updfra, updfra_deep, updfra_shall + real :: wact, wact_deep, wact_shall + real :: wcb_v2, wcb_v2_shall, wcb_v2_deep + real :: wulcl, wulcl_deep, wulcl_shall + real :: wcloudbase_shall, wcloudbase_deep + + real, dimension(kts:kte) :: & + qlg_deep, qig_deep, & + qndrop_ic_deep, qndrop_ic_shall, & + qc_ic_deep, qc_ic_shall, & + qi_ic_deep, qi_ic_shall, & + fcvt_qc_to_pr_deep, fcvt_qc_to_pr_shall, & + fcvt_qc_to_qi_deep, fcvt_qc_to_qi_shall, & + fcvt_qi_to_pr_deep, fcvt_qi_to_pr_shall, & + cumshallfreq1d, & + umfout, uerout, udrout, & + umf_deep, uer_deep, udr_deep, & + umf_shall, uer_shall, udr_shall, & + dmfout, derout, ddrout, & + dmf_deep, der_deep, ddr_deep, & ! only deep has downdraft + wup, wup_deep, wup_shall +! rce 11-may-2012 mods end --------------------------------------------- + +! + DXSQ=DX*DX +!---------------------- + NTST=STEPCU + TST=float(NTST*2) + flag_qr = .FALSE. + flag_qi = .FALSE. + flag_qs = .FALSE. + IF ( PRESENT(F_QR) ) flag_qr = F_QR + IF ( PRESENT(F_QI) ) flag_qi = F_QI + IF ( PRESENT(F_QS) ) flag_qs = F_QS + +! flag_chem is .TRUE. only when chem is present, shcu_aerosols_opt >= 2, and chem_opt is appropriate + flag_chem = .FALSE. +#if ( WRF_CHEM == 1 ) + if ( PRESENT( chem ) .and. shcu_aerosols_opt >= 2) then + if ( chem_opt == cbmz_mosaic_4bin .or. & + chem_opt == cbmz_mosaic_4bin_aq .or. & + chem_opt == cbmz_mosaic_8bin .or. & + chem_opt == cbmz_mosaic_8bin_aq .or. & + chem_opt == saprc99_mosaic_8bin_vbs2_aq_kpp .or. & + chem_opt == saprc99_mosaic_8bin_vbs2_kpp ) then !BSINGH (04/08/2014): Added for non-aq vbs + + flag_chem = .TRUE. + else + CALL wrf_error_fatal( 'kf_cup_cps - bad chem_opt for shcu_aerosols_opt >= 2' ) + end if + end if +#endif + + idiagff = 0 ; idiagee = 0 ! rce 11-may-2012 start + if ((ide-ids <= 3) .and. (jde-jds <= 3)) then + idiagff = 1 ! turn on diagnostics at i=j=1 for single column runs +! idiagff = 0 ! (do this to turn off extra diagnostics) + end if ! rce 11-may-2012 end + +! + DO J = jts,jte + DO K=kts,kte + DO I= its,ite +! SCR1=-5.0E-4*G*rho(I,K,J)*(w(I,K,J)+w(I,K+1,J)) +! TV=T(I,K,J)*(1.+EP1*QV(I,K,J)) +! RHOE=Pcps(I,K,J)/(R*TV) +! W0=-101.9368*SCR1/RHOE + W0=0.5*(w(I,K,J)+w(I,K+1,J)) !~this can probably be passed in instead of recalced + W0AVG(I,K,J)=(W0AVG(I,K,J)*(TST-1.)+W0)/TST +! CLDFRA_CUP(I,K,j) = 0.0 ! Start with 0 cloud fraction, added by LK Berg 10/29/09 01/11/2012 + ENDDO + ENDDO + ENDDO +! +!...CHECK FOR CONVECTIVE INITIATION EVERY 5 MINUTES (OR NTST/2)... +! +!---------------------- + ICLDCK=MOD(KTAU,NTST) + +! rce 11-may-2012 mods start ------------------------------------------- + if (idiagff > 0) then + if (ktau <= 1) then + write(*,'(a,i5,1p,4e11.3)') 'kfcup_control numbins, ...binsize, min...freq', numbins, thbinsize, rbinsize, mindeepfreq, minshallowfreq + write(*,'(a,3i5)') 'kfcup_control -- qndrop_cldbase_entrain_opt, ...incloud', & + qndrop_cldbase_entrain_opt, qndrop_incloud_entrain_opt + write(*,'(a,1p,2e11.35)') 'kfcup_control -- w_act_min', w_act_min + write(*,'(a,2i5/(a,3(i9,i5)))') 'kfcup_control -- grid_id, ktau', grid_id, ktau, & + 'kfcup_control -- d indices', ids,ide, jds,jde, kds,kde, & + 'kfcup_control -- m indices', ims,ime, jms,jme, kms,kme, & + 'kfcup_control -- e indices', its,ite, jts,jte, kts,kte + end if + + write(*,'(a)') 'kfcup', 'kfcup', 'kfcup--------------------------------------------------------------------------------' + write(*,'(a,l5)') 'kfcup -- flag_chem', flag_chem + write(*,'(a,3i5,l5,3i5,f10.1,1p,2e10.2)') 'kfcup a00 ktau,ntst,icldck; cupflag,ishall,bot/top; nca,cldfra', & + ktau, ntst, icldck, cupflag(its,jts), nint(shall(its,jts)), nint(cubot(its,jts)), nint(cutop(its,jts)), nca(its,jts), & + maxval(cldfra_cup(its,kts:kte-2,jts)), maxval(rqvcuten(its,kts:kte-2,jts)) + write(*,'(a,i5,1p,4e11.3)') 'kfcup numbins, ...binsize, min...freq', numbins, thbinsize, rbinsize, mindeepfreq, minshallowfreq + end if ! (idiagff > 0) +! rce 11-may-2012 mods end --------------------------------------------- + + if ((ide-ids <= 3) .and. (jde-jds <= 3)) then ! rce 11-may-2012 + ! for single column, skip ktau=1 + ltmpa = (ICLDCK .EQ. 0) .and. (KTAU .gt. 1) + else + ltmpa = (ICLDCK .EQ. 0) .or. (KTAU .eq. 1) + end if + +main_test_on_ktau_ntst: & ! rce 11-may-2012 + IF ( ltmpa ) then +! IF(ICLDCK.EQ.0 .or. KTAU .eq. 1) then + +! +!write(message,*)'~trying convection...' +!call wrf_message(message) + DO J = jts,jte + DO I= its,ite + CU_ACT_FLAG(i,j) = .true. + ENDDO + ENDDO + +main_loop_on_j: & ! rce 11-may-2012 + DO J = jts,jte +main_loop_on_i: & ! rce 11-may-2012 + DO I=its,ite + + idiagee = 0 ! rce 11-may-2012 + if (idiagff > 0) then + ! turn on diagnostics at i=j=1 for single column runs + if (i==its .and. j==jts) idiagee = 1 + end if + + ishall = int(shall(i,j)) !CuP, wig 19-Sep-2006 +!write(message,*)'~i,j,nca,shall=',i,j,nca(i,j),ishall +!call wrf_message(message) + +main_test_on_nca: & ! rce 11-may-2012 + IF ( NCA(I,J) .ge. 0.5*DT ) then !byang 26 aug 2011 +! A previous call to KF triggered a cloud, and now we have to wait for +! the appropriate time scale before triggering another cloud. + CU_ACT_FLAG(i,j) = .false. + + ELSE +!call wrf_message("~doing convection...") + DO k=kts,kte + DQDT(k)=0. + DQIDT(k)=0. + DQCDT(k)=0. + DQRDT(k)=0. + DQSDT(k)=0. + DTDT(k)=0. + ENDDO + RAINCV(I,J)=0. + CUTOP(I,J)=KTS + CUBOT(I,J)=KTE+1 + + qc_ic_cup(i,:,j) = 0.0 ! rce 11-may-2012 start + qndrop_ic_cup(i,:,j) = 0.0 + qc_iu_cup(i,:,j) = 0.0 + fcvt_qc_to_pr_cup(i,:,j) = 0.0 + fcvt_qc_to_qi_cup(i,:,j) = 0.0 + fcvt_qi_to_pr_cup(i,:,j) = 0.0 + wup_cup(i,:,j) = 0.0 + wact_cup(i,j) = 0.0 + wulcl_cup(i,j) = 0.0 + tcloud_cup(i,j) = 0.0 + updfra_cup(i,:,j) = 0.0 + mfup_cup(i,:,j) = 0.0 + mfup_ent_cup(i,:,j) = 0.0 + mfdn_cup(i,:,j) = 0.0 + mfdn_ent_cup(i,:,j) = 0.0 ! rce 11-may-2012 end +! +! assign vars from 3D to 1D + DO K=kts,kte + U1D(K) =U(I,K,J) + V1D(K) =V(I,K,J) + T1D(K) =T(I,K,J) + th1d(k) = th(i,k,j) !wig, CuP 24-Aug-2006 + RHO1D(K) =rho(I,K,J) + QV1D(K)=QV(I,K,J) + P1D(K) =Pcps(I,K,J) + W0AVG1D(K) =W0AVG(I,K,J) + z1d(k) = z(i,k,j) !wig, CuP 15-Sep-2006 + z_at_w1d(k) = z_at_w(i,k,j) !wig, CuP 15-Sep-2006 + DZ1D(k)=dz8w(I,K,J) + cldfra_cup1d(k) = cldfra_cup(i,k,j) !wig, CuP 20-Sep-2006 + ENDDO + + if ( flag_chem ) then ! rce 11-may-2012 start + do l = 1, num_chem + do k = kts, kte + chem1d(k,l) = chem(i,k,j,l) + end do + end do + end if + qndrop1d = 0.0 + qc1d = 0.0 + qi1d = 0.0 + fcvt_qc_to_pr = 0.0 + fcvt_qc_to_qi = 0.0 + fcvt_qi_to_pr = 0.0 + wup = 0.0 + wact = 0.0 + updfra = 0.0 + ipert_deepsv = -999 + jpert_deepsv = -999 ! rce 11-may-2012 end +! +! CuP, wig: begin, Aug-2006 +! Get the slopes and std. dev. for CuP + +!!$!~beg +!!$print*,dx, psfc(i,j), p1d, rho1d +!!$print*, dz1d, z1d, ht(i,j) +!!$print*, t1d, th1d, tsk(i,j), u1d, v1d +!!$print*, qv1d, hfx(i,j), qfx(i,j), mavail(i,j) +!!$print*, sf_sfclay_physics, br(i,j), regime(i,j), pblh(i,j) +!!$print*, kpbl(i,j), t2(i,j), q2(i,j) +!!$print*, slopeSfc(i,j), slopeEZ(i,j) +!!$print*, sigmaSfc(i,j), sigmaEZ(i,j) +!!$print*, wstar, cupflag(i,j) +!!$print*, kms, kme, kts, kte +!!$ +!!$print*,'~entering cupSlopeSigma',i,j +!!$!~end + call cupSlopeSigma(dx, psfc(i,j), p1d, rho1d, & + dz1d, z1d, ht(i,j), & + t1d, th1d, tsk(i,j), u1d, v1d, & + qv1d, hfx(i,j),xland(i,j), qfx(i,j), mavail(i,j), & ! add xland LD 19-Oct-2011 + sf_sfclay_physics, br(i,j), regime(i,j), pblh(i,j),& + kpbl(i,j), t2(i,j), q2(i,j), & + slopeSfc(i,j), slopeEZ(i,j), & + sigmaSfc(i,j), sigmaEZ(i,j), & + wstar, cupflag(i,j), shall(i,j), & + kms, kme, kts, kte ) + + if (idiagee>0) then ! rce 11-may-2012 + write(*,'(a,l5,i5)') 'kfcup cupslopesigma cupflag, ishall', cupflag(i,j), nint(shall(i,j)) + write(*,'(a,i10,1p,5e10.2)') 'kfcup kpbl, pblh, ht, z1d, dz', kpbl(i,j), pblh(i,j), ht(i,j), z1d(1), dz1d(1) + write(*,'(a, 1p,5e10.2)') 'kfcup hfx, qfx, regime // w0', hfx(i,j), qfx(i,j), regime(i,j) + write(*,'( 1p,10e10.2)') w0avg1d(kts:kts+19) + end if + +! If the CuP scheme is activated, use the CuP perturbations. +! Otherwise, default to the standard KF algorithm. +main_test_on_cupflag: & ! rce 11-may-2012 + if( cupflag(i,j) ) then +! +! Get the joint frequency distribution and the associated perturbations +! +!~The pert. calcs can be pulled out of the i/j do loops for speed, but +!~are left in right now in case we want to vary the pert. values based +!~on environmental conditions. + call cup_jfd(slopeSfc(i,j), slopeEZ(i,j), & + sigmaSfc(i,j), sigmaEZ(i,j), & + numBins, thBinSize, rBinSize, & + th_perturb, r_perturb, jfd ) +! +! Determine the minimum frequency of occurance that we will allow to +! contribute to the results. This serves two purposes. It prevents large +! excursions from the mean that might creep in from mal-conditioned +! PBL structures. And, it also speeds up overall calculation time by +! limiting which bins to send to the KF scheme for lifting. +! + minFreq = minShallowFreq*jfd(int(numBins/2)+1, int(numBins/2)+1) + !!minFreq = 1e-2*jfd(int(numBins/2)+1, int(numBins/2)+1) + if (idiagee>0) write(*,'(a,2i5,1p,2e11.3)') 'kfcup minfreq stuff', & + int(numBins/2)+1, int(numBins/2)+1, minshallowfreq, minfreq ! rce 11-may-2012 +! +! Setup some vars and then loop through all the perturbation +! possibilities... +! + biggestDeepFreq = -999. + cumDeepFreq = 0. + cumShallFreq = 0. + dqdt_shall = 0. + dqidt_shall = 0. + dqcdt_shall = 0. + dqrdt_shall = 0. + dqsdt_shall = 0. + dtdt_shall = 0. + raincv_shall = 0. + cubot_shall = 0. + cutop_shall = 0. + qlg_shall = 0. + qig_shall = 0. + wCloudBase(i,j) = 0. + +! rce 11-may-2012 mods start ------------------------------------------- + cumShallFreq1d = 0. + qndrop_ic_shall = 0. + qc_ic_shall = 0. + qi_ic_shall = 0. + fcvt_qc_to_pr_shall = 0. + fcvt_qc_to_qi_shall = 0. + fcvt_qi_to_pr_shall = 0. + wact_shall = 0. + wulcl_shall = 0. + wCloudBase_shall= 0. + updfra_shall = 0. + umf_shall = 0. + uer_shall = 0. + udr_shall = 0. + wcb_v2 = 0. + wcb_v2_shall = 0. + kcubotmin = 99 + kcubotmax = 0 + kcutopmin = 99 + kcutopmax = 0 + wup_deep = 0. + wup_shall = 0. +! rce 11-may-2012 mods end --------------------------------------------- + + +PERTLOOPS: do jpert = 1,numBins + do ipert = 1,numBins +! +! Only consider the perturbations that exceed a threshold value. Also, +! skip this perturbation if we already know deep convection will be +! output and the current probability is lower than a previous deep +! convective possibility. +! + if( (jfd(ipert,jpert) < minFreq) .or. & + !!(jfd(ipert,jpert) > 0.001) .or. & ! lkb, 18-Aug-2008 + !!(th_perturb(ipert) <= 0) .or. & ! lkb, 18-Aug-2008 : Commented out for tests run on 11/3/09 looking at lower freq. of DC + !!(r_perturb(ipert) <= 0) .or. & ! lkb, 18-Aug-2008 : COmmented out for tests run on 11/3/09 + (cumDeepFreq > minDeepFreq .and. & ! lkb, 18-Aug_2008 + jfd(ipert,jpert) < biggestDeepFreq) ) cycle + + + +! write(*,*) raincv ,'in if before KF_cup_PARA' !LD, 20-April-2011 + if (idiagee>0) then ! rce 11-may-2012 + write(*,'(a,2i5,1p,2e11.3)') 'kfcup calling kf_cup_para' + write(98,'(///a,i5,2i5,5x,a,2i5,1pe11.3)') 'kfcup calling kf_cup_para, ktau, i, j', ktau, i, j, & + 'ijpert, jdf', ipert, jpert, jfd(ipert,jpert) + end if + + CALL KF_cup_PARA( GRID_ID, KTAU, & ! rce 11-may-2012 + I, J, & + U1D,V1D,T1D,QV1D,P1D,DZ1D, & + W0AVG1D,DT,DX,DXSQ,RHO1D, & + XLV0,XLV1,XLS0,XLS1,CP,R,G, & + EP2,SVP1,SVP2,SVP3,SVPT0, & + pblh(i,j),z_at_w1d,cupflag(i,j), & !wig, 21-Feb-2008 + th_perturb(ipert),r_perturb(jpert), & !wig, 25-Aug-2006 + jfd(ipert,jpert), & !lkb, 15-Aug-2008 + ishall,qlg,qig, & !wig, 20-Sep-2006 + DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & + RAINCV,NCA,NTST, & !LD add PRATEC 21-April-2011 + flag_QI,flag_QS,warm_rain, & + CUTOP,CUBOT, wLCL, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + idiagee, updfra, wulcl, wup, & + umfout, uerout, udrout, & ! rce 11-may-2012 + dmfout, derout, ddrout, & ! " + shcu_aerosols_opt, & ! " + flag_chem, num_chem, & ! " + wact, qndrop1d, qc1d, qi1d, & ! " + fcvt_qc_to_qi, fcvt_qc_to_pr, & ! " + fcvt_qi_to_pr, chem1d, & ! " +#if ( WRF_CHEM == 1 ) + maxd_acomp, maxd_aphase, & ! " + maxd_atype, maxd_asize, & ! " + ntype_aer, nsize_aer, ncomp_aer, & ! " + ai_phase, msectional, & ! " + massptr_aer, numptr_aer, & ! " + dlo_sect, dhi_sect, & ! " + dens_aer, hygro_aer, sigmag_aer ) ! " +#else + 1, 1, & ! " + 1, 1 ) ! rce 11-may-2012 +#endif + + if (idiagee>0) then ! rce 11-may-2012 + if (ishall==0 .or. ishall==1) then + write(*,'(a,3i5,1p,e11.3,a)') 'kfcup 1 ishall, cubot/top, nca', & + ishall, nint(cubot(i,j)), nint(cutop(i,j)), nca(i,j), ' triggered' + else + write(*,'(a,3i5,1p,e11.3,a)') 'kfcup 1 ishall, cubot/top, nca', & + ishall, nint(cubot(i,j)), nint(cutop(i,j)), nca(i,j) + end if + end if + +! if( raincv(i,j).ne. 0 ) then &!LD, 20-April-2011 +! write(*,*) raincv,'after cup_PARA' !LD, 20-April-2011 +! end if &!LD, 20-April-2011 + +! Move these tendency applications to after the averaging for all the +! different CuP perturbations. +!!$ IF(PRESENT(rthcuten).AND.PRESENT(rqvcuten)) THEN +!!$ DO K=kts,kte +!!$ RTHCUTEN(I,K,J)=DTDT(K)/pi(I,K,J) +!!$! RTHCUMAX=max(abs(RTHCUTEN(I,K,J)),RTHCUMAX) +!!$ RQVCUTEN(I,K,J)=DQDT(K) +!!$ ENDDO +!!$ ENDIF +! +! If deep convection triggered, accumulate the deep convective +! probability. This will also be the case if no convection occurred +! and then the results would be small. Save the results if this deep +! possibility is more probable than previous possibilities... +! + if( ishall == 0 ) then + cumDeepFreq = cumDeepFreq + jfd(ipert,jpert) + if( jfd(ipert,jpert) > biggestDeepFreq ) then + biggestDeepFreq = jfd(ipert,jpert) + do k = kts, kte ! Added by lkb + dqdt_deep(k) = dqdt(k) + dqidt_deep(k) = dqidt(k) + dqcdt_deep(k) = dqcdt(k) + dqrdt_deep(k) = dqrdt(k) + dqsdt_deep(k) = dqsdt(k) + dtdt_deep(k) = dtdt(k) + enddo + nca_deep = nca(i,j) + raincv_deep = raincv(i,j) + cubot_deep = cubot(i,j) + cutop_deep = cutop(i,j) + + ipert_deepsv = ipert ! rce 11-may-2012 start + jpert_deepsv = jpert + qlg_deep = qlg + qig_deep = qig + qndrop_ic_deep = qndrop1d + qc_ic_deep = qc1d + qi_ic_deep = qi1d + fcvt_qc_to_pr_deep = fcvt_qc_to_pr + fcvt_qc_to_qi_deep = fcvt_qc_to_qi + fcvt_qi_to_pr_deep = fcvt_qi_to_pr + updfra_deep = updfra + wup_deep = wup + wact_deep = wact + wulcl_deep = wulcl + wcb_v2_deep = max( wlcl, wulcl ) + wcloudbase_deep = wlcl + + kcubot = nint(cubot_deep) + kupdrbot_deep = kcubot + do k = kcubot-1, kts, -1 + if ((umfout(k) > 0.0) .or. (uerout(k) > 0.0)) kupdrbot_deep = k + end do + do k = kts, kte + umf_deep(k) = max( 0.0, umfout(k) ) + uer_deep(k) = max( 0.0, uerout(k) ) + udr_deep(k) = max( 0.0, udrout(k) ) + dmf_deep(k) = min( 0.0, dmfout(k) ) + der_deep(k) = max( 0.0, derout(k) ) + ddr_deep(k) = max( 0.0, ddrout(k) ) + enddo ! rce 11-may-2012 end + end if +! +! Or if shallow convection ocurred and we need to accumulate +! frequency weighted running sums of the results... +! + else if( ishall == 1 ) then + cumShallFreq = cumShallFreq + jfd(ipert,jpert) ! lkb-9/02/08 changed to just use JFD + !!dqdt_shall = dqdt_shall + dqdt*jfd(ipert,jpert) + + do k = kts, kte ! Added by lkb + !!!dqdt_shall = dqdt_shall + dqdt*jfd(ipert,jpert) + dqdt_shall(k) = dqdt_shall(k) + dqdt(k) + !!!dqidt_shall = dqidt_shall + dqidt*jfd(ipert,jpert) + dqidt_shall(k) = dqidt_shall(k) + dqidt(k) + !!!dqcdt_shall = dqcdt_shall + dqcdt*jfd(ipert,jpert) + dqcdt_shall(k) = dqcdt_shall(k) + dqcdt(k) + !!!dqrdt_shall = dqrdt_shall + dqrdt*jfd(ipert,jpert) + dqrdt_shall(k) = dqrdt_shall(k) + dqrdt(k) + !!!dqsdt_shall = dqsdt_shall + dqsdt*jfd(ipert,jpert) + dqsdt_shall(k) = dqsdt_shall(k) + dqsdt(k) + !!!dtdt_shall(k) = dtdt_shall(k) + dtdt(k)*jfd(ipert,jpert) + dtdt_shall(k) = dtdt_shall(k) + dtdt(k) +! in kf_cup_para, when you have shallow conv, +! ainc (and so updraft area and mass fluxes) get multiplied by jfd(ipert,jpert) +! which is passed in as "freq" +! thus the following variables that are averaged over perts +! should not be weighted by jfd (same for updfra_shall) + umf_shall(k) = umf_shall(k) + max( 0.0, umfout(k) ) ! rce 11-may-2012 start + uer_shall(k) = uer_shall(k) + max( 0.0, uerout(k) ) + udr_shall(k) = udr_shall(k) + max( 0.0, udrout(k) ) ! rce 11-may-2012 end + enddo + nca_shall = nca(i,j)!NINT(TIMEC_SHALL/DT)*DT ! add 01/11/2012 real(ntst)*DT !add dt 01/11/2012 All shallow clouds have a 40 min time scale per KF code. + raincv_shall = raincv_shall + raincv(i,j)*jfd(ipert,jpert) + !!!raincv_shall = raincv_shall + raincv(i,j) + cubot_shall = cubot_shall + z1d(nint(cubot(i,j)))*jfd(ipert,jpert) !Average the heights, then back out index later + cutop_shall = cutop_shall + z1d(nint(cutop(i,j)))*jfd(ipert,jpert) !ditto + qlg_shall = qlg_shall + qlg*jfd(ipert,jpert) + !!!qlg_shall = qlg_shall + qlg + qig_shall = qig_shall + qig*jfd(ipert,jpert) + !!!qig_shall = qig_shall + qig +! wCloudBase(i,j) = wLCL * jfd(ipert,jpert) + wCloudBase(i,j) ! rce 11-may-2012 start + wCloudBase_shall= wLCL * jfd(ipert,jpert) + wCloudBase_shall + do k = max( kts, nint(cubot(i,j)) ), min( kte, nint(cutop(i,j)) ) + ! these are "in cloud" values, so only do them for cubot <= k <= cutop + cumshallfreq1d(k) = cumshallfreq1d(k) + jfd(ipert,jpert) + qndrop_ic_shall(k) = qndrop_ic_shall(k) + qndrop1d(k)*jfd(ipert,jpert) + qc_ic_shall(k) = qc_ic_shall(k) + qc1d(k)*jfd(ipert,jpert) + qi_ic_shall(k) = qi_ic_shall(k) + qi1d(k)*jfd(ipert,jpert) + ! fcvt_qc_to_pr is fraction of qc converted to precip as air moves through the updraft layer + ! compute average as: sum( fcvt_qc_to_pr * qc1d * jfd ) / sum( qc1d * jfd ) + fcvt_qc_to_pr_shall(k) = fcvt_qc_to_pr_shall(k) + fcvt_qc_to_pr(k)*qc1d(k)*jfd(ipert,jpert) + fcvt_qc_to_qi_shall(k) = fcvt_qc_to_qi_shall(k) + fcvt_qc_to_qi(k)*qc1d(k)*jfd(ipert,jpert) + fcvt_qi_to_pr_shall(k) = fcvt_qi_to_pr_shall(k) + fcvt_qi_to_pr(k)*qi1d(k)*jfd(ipert,jpert) + end do + wup_shall = wup_shall + wup*jfd(ipert,jpert) + wact_shall = wact_shall + wact*jfd(ipert,jpert) + wulcl_shall = wulcl_shall + wulcl*jfd(ipert,jpert) + updfra_shall = updfra_shall + updfra + wcb_v2_shall = wcb_v2_shall + jfd(ipert,jpert)*max( wlcl, wulcl ) + kcubotmin = min( kcubotmin, nint(cubot(i,j)) ) + kcubotmax = max( kcubotmax, nint(cubot(i,j)) ) + kcutopmin = min( kcutopmin, nint(cutop(i,j)) ) + kcutopmax = max( kcutopmax, nint(cutop(i,j)) ) ! rce 11-may-2012 end + end if + + +! +! Otherwise, no convection occurred so do nothing. +! + end do + end do PERTLOOPS +! +! Now that we know what kind of convection will occur, copy the +! appropriate type, shallow or deep, into the output arrays that +! KF normally expects. Shallow convection needs to be turned into +! an average from a running sum. +! +! write(*,*) 'raincv_deep',raincv_deep,ishall,'raincv_deep' !LD, 20-April-2011 + +main_test_on_deep_shall_freq: & ! rce 11-may-2012 + if( cumDeepFreq > minDeepFreq ) then !Deep convection + ishall = 0 + activeFrac(i,j) = 1. + do k = kts, kte ! Added by lkb + dqdt(k) = dqdt_deep(k) + dqidt(k) = dqidt_deep(k) + dqcdt(k) = dqcdt_deep(k) + dqrdt(k) = dqrdt_deep(k) + dqsdt(k) = dqsdt_deep(k) + dtdt(k) = dtdt_deep(k) + enddo + + nca(i,j) = nca_deep + raincv(i,j) = raincv_deep + cubot(i,j) = cubot_deep + cutop(i,j) = cutop_deep +! write(*,*) 'raincv',raincv,ishall,'raincv' !LD, 20-April-2011 + + qc_iu_cup(i,kts:kte,j) = qc_ic_deep(kts:kte) ! rce 11-may-2012 start + qc_ic_cup(i,kts:kte,j) = qc_ic_deep(kts:kte) + qndrop_ic_cup(i,kts:kte,j) = qndrop_ic_deep(kts:kte) + wup_cup(i,kts:kte,j) = wup_deep(kts:kte) + wact_cup(i,j) = wact_deep + wulcl_cup(i,j) = wulcl_deep + wCloudBase(i,j) = wCloudBase_deep + wcb_v2 = wcb_v2_deep + + kcutop = nint(cutop_deep) + fcvt_qc_to_pr_cup(i,kts:kcutop,j) = fcvt_qc_to_pr_deep(kts:kcutop) + fcvt_qc_to_qi_cup(i,kts:kcutop,j) = fcvt_qc_to_qi_deep(kts:kcutop) + fcvt_qi_to_pr_cup(i,kts:kcutop,j) = fcvt_qi_to_pr_deep(kts:kcutop) + + call adjust_mfentdet_kfcup( idiagee, grid_id, ktau, & + i, j, kts, kte, kcutop, ishall, & + umf_deep, uer_deep, udr_deep, dmf_deep, der_deep, ddr_deep ) + + ! mfup_ent_cup(k) is at center of layer k, and is 0 for k > kcutop + mfup_ent_cup(i,kts:kcutop,j) = uer_deep(kts:kcutop) + ! mfup_cup(k) is at bottom of layer k, and is 0 for k > kcutop + ! umf_deep(k) is at top of layer k + mfup_cup(i,kts+1:kcutop,j) = umf_deep(kts:kcutop-1) + mfdn_ent_cup(i,kts:kcutop,j) = der_deep(kts:kcutop) + mfdn_cup(i,kts+1:kcutop,j) = dmf_deep(kts:kcutop-1) + + updfra_cup(i,kupdrbot_deep:kcutop,j) = updfra_deep + tcloud_cup(i,j) = nca_deep ! rce 11-may-2012 end + +!main_test_on_deep_shall_freq: & ! rce 11-may-2012 + else if( cumShallFreq > 0. ) then !Shallow convection + ishall = 1 + activeFrac(i,j) = cumShallFreq + + do k = kts, kte ! Added by lkb + !!!dqdt = dqdt_shall / cumShallFreq + dqdt(k) = dqdt_shall(k) + !!!dqidt = dqidt_shall / cumShallFreq + dqidt(k) = dqidt_shall(k) + !!!dqcdt = dqcdt_shall / cumShallFreq + dqcdt(k) = dqcdt_shall(k) + !!!dqrdt = dqrdt_shall / cumShallFreq + dqrdt(k) = dqrdt_shall(k) + !!!dqsdt = dqsdt_shall / cumShallFreq + dqsdt(k) = dqsdt_shall(k) + !!!dtdt(k) = dtdt_shall(k) / cumShallFreq + dtdt(k) = dtdt_shall(k) + enddo + + nca(i,j) = nca_shall ! shallow convection timescale is locked to convective time scale + raincv(i,j) = raincv_shall / cumShallFreq + !!!raincv(i,j) = raincv_shall + + cubot_shall = cubot_shall / cumShallFreq !This gives the average height in AMSL + cutop_shall = cutop_shall / cumShallFreq !ditto + cubot(i,j) = findIndex(cubot_shall, z_at_w1d)-1 !Now, get the index of the level + cutop(i,j) = findIndex(cutop_shall, z_at_w1d)-1 !ditto + qlg = qlg_shall / cumShallFreq + !!!qlg = qlg_shall + qig = qig_shall / cumShallFreq + !!!qig = qig_shall + +! wCloudBase(i,j) = wCloudBase(i,j) / cumShallFreq ! rce 11-may-2012 start + wCloudBase_shall= wCloudBase_shall/ cumShallFreq + wCloudBase(i,j) = wCloudBase_shall + + do k = kts, kte + ! these are "in cloud" values + if (cumshallfreq1d(k) > 0.0) then + fcvt_qc_to_pr_shall(k) = fcvt_qc_to_pr_shall(k) / max( 1.0e-20, qc_ic_shall(k) ) + fcvt_qc_to_qi_shall(k) = fcvt_qc_to_qi_shall(k) / max( 1.0e-20, qc_ic_shall(k) ) + fcvt_qi_to_pr_shall(k) = fcvt_qi_to_pr_shall(k) / max( 1.0e-20, qi_ic_shall(k) ) + qndrop_ic_shall(k) = qndrop_ic_shall(k)/cumshallfreq1d(k) + qc_ic_shall(k) = qc_ic_shall(k)/cumshallfreq1d(k) + qi_ic_shall(k) = qi_ic_shall(k)/cumshallfreq1d(k) + end if + cumshallfreq1d(k) = cumshallfreq1d(k)/cumshallfreq + end do + wup_shall = wup_shall/cumshallfreq + wact_shall = wact_shall/cumshallfreq + wulcl_shall = wulcl_shall/cumshallfreq + wcb_v2_shall = wcb_v2_shall / cumshallfreq + wup_cup(i,kts:kte,j) = wup_shall(kts:kte) + wact_cup(i,j) = wact_shall + wulcl_cup(i,j) = wulcl_shall + wcb_v2 = wcb_v2_shall + + kcubot = nint(cubot(i,j)) + kcutop = nint(cutop(i,j)) + ! qc_ic_cup(k) and qndrop_ic_cup(k) are at center of layer k, and are 0 for k > kcutop + qc_ic_cup(i,kts:kcutop,j) = qc_ic_shall(kts:kcutop) + qndrop_ic_cup(i,kts:kcutop,j) = qndrop_ic_shall(kts:kcutop) + ! note: qc_ic_shall = qc1d from subr. kf_cup_para is really for updraft + ! if an empirical "in cumulus" cloud-water is used for radiation, + ! it should be put into qc_ic_cup, and used for cloud-chemistry too + qc_iu_cup(i,kts:kcutop,j) = qc_ic_shall(kts:kcutop) + ! for qc_ic_cup, use the value in module_ra_cam (1.0 g/kg) + ! For shallow convection, use a representative condensate value based on + ! observations from CHAPS (Oklahoma area) and Florida (Blyth et al. 2005) + qc_ic_cup(i,kcubot:kcutop,j) = 1.0e-3 + + fcvt_qc_to_pr_cup(i,kts:kcutop,j) = fcvt_qc_to_pr_shall(kts:kcutop) + fcvt_qc_to_qi_cup(i,kts:kcutop,j) = fcvt_qc_to_qi_shall(kts:kcutop) + fcvt_qi_to_pr_cup(i,kts:kcutop,j) = fcvt_qi_to_pr_shall(kts:kcutop) + + call adjust_mfentdet_kfcup( idiagee, grid_id, ktau, & + i, j, kts, kte, kcutop, ishall, & + umf_shall, uer_shall, udr_shall, dmfout, derout, ddrout ) + + ! mfup_ent_cup(k) is at center of layer k, and is 0 for k > kcutop + mfup_ent_cup(i,kts:kcutop,j) = uer_shall(kts:kcutop) + ! mfup_cup(k) is at bottom of layer k, and is 0 for k > kcutop + ! umf_shall(k) is at top of layer k + mfup_cup(i,kts+1:kcutop,j) = umf_shall(kts:kcutop-1) + + kupdrbot_shall = kcubot + do k = kcubot-1, kts, -1 + if ((umf_shall(k) > 0.0) .or. (uer_shall(k) > 0.0)) kupdrbot_shall = k + end do + updfra_cup(i,kupdrbot_shall:kcutop,j) = updfra_shall + tcloud_cup(i,j) = nca_shall ! rce 11-may-2012 end + +!main_test_on_deep_shall_freq: & ! rce 11-may-2012 + else !No convection + ishall = 2 + activeFrac(i,j) = 0. + dqdt = 0. + dqidt = 0. + dqcdt = 0. + dqrdt = 0. + dqsdt = 0. + dtdt = 0. + nca(i,j) = -1. + raincv(i,j) = 0. + cubot(i,j) = 1.! add 1 replace 0 LD 01/11/2012 + cutop(i,j) = 1. + end if main_test_on_deep_shall_freq ! rce 11-may-2012 + + if (idiagee>0) write(*,'(a,3i5,1p,3e11.3)') 'kfcup 2 ishall, cubot/top, nca', & + ishall, nint(cubot(i,j)), nint(cutop(i,j)), nca(i,j) ! rce 11-may-2012 + + shall(i,j) = real(ishall) + kcubot = int(cubot(i,j)) + kcutop = int(cutop(i,j)) + call cupCloudFraction(qlg, qig, qv1d, t1d, z1d, p1d, & + kcubot, kcutop, ishall, wStar, wCloudBase(i,j), pblh(i,j), dt, & + activeFrac(i,j), cldfra_cup1d, cldfratend_cup1d, & + taucloud(i,j), tActive(i,j), tstar(i,j), lnterms(i,:,j), & + lnint(i,j), & + kts, kte, mfup_cup(i,:,j)) ! add mfup_cup LD 06 29 2012 + ! kts, kte) + do k=kts,kte + cldfra_cup(i,k,j) = cldfra_cup1d(k) + end do + + + if (idiagee > 0) then + call cu_kfcup_diagee01( & ! rce 11-may-2012 + ims, ime, jms, jme, kms, kme, kts, kte, & + i, j, & + idiagee, idiagff, ishall, ktau, & + kcubotmin, kcubotmax, kcutopmin, kcutopmax, & + activefrac, cldfra_cup1d, & + cubot, cutop, cumshallfreq1d, & + ddr_deep, der_deep, dmf_deep, dt, dz1d, & + fcvt_qc_to_pr_deep, fcvt_qc_to_qi_deep, fcvt_qi_to_pr_deep, & + fcvt_qc_to_pr_shall, fcvt_qc_to_qi_shall, fcvt_qi_to_pr_shall, & + nca_deep, nca_shall, p1d, pblh, & + qc_ic_deep, qc_ic_shall, qi_ic_deep, qi_ic_shall, qndrop_ic_cup, rho1d, & + tactive, taucloud, tstar, & + udr_deep, udr_shall, uer_deep, uer_shall, umf_deep, umf_shall, & + updfra_deep, updfra_shall, updfra_cup, & + wact_cup, wcloudbase, wcb_v2, wcb_v2_shall, & + wulcl_cup, wstar, z1d, z_at_w1d ) + end if + + +!!$ write(message,'(2i4,a,f10.5,a,f10.5)') i,j," Frequencies: cumDeepFreq=",cumDeepFreq," cumShallFreq=",cumShallFreq +!!$ call wrf_message(message) + + +!main_test_on_cupflag ! rce 11-may-2012 + else +! +! CuP did not trigger due to stable conditions so default to standard +! KF scheme... +! + !!CALL KF_cup_PARA(I, J, & + !! U1D,V1D,T1D,QV1D,P1D,DZ1D, & + !! W0AVG1D,DT,DX,DXSQ,RHO1D, & + !! XLV0,XLV1,XLS0,XLS1,CP,R,G, & + !! EP2,SVP1,SVP2,SVP3,SVPT0, & + !! pblh(i,j),z_at_w1d,cupflag(i,j), & !wig, 21-Feb-2008 + !! th_perturb(1),r_perturb(1), & !wig, 9-Oct-2006 + !! 0.01, & !lkb, 15-Aug-2008, replace mass flux with default + !! ishall,qlg,qig, & !wig, 20-Sep-2006 + !! DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & + !! RAINCV,NCA,NTST, & + !! flag_QI,flag_QS,warm_rain, & + !! CUTOP,CUBOT, & + !! ids,ide, jds,jde, kds,kde, & + !! ims,ime, jms,jme, kms,kme, & + !! its,ite, jts,jte, kts,kte) + + CALL KF_cup_PARA( GRID_ID, KTAU, & ! rce 11-may-2012 + I, J, & + U1D,V1D,T1D,QV1D,P1D,DZ1D, & + W0AVG1D,DT,DX,DXSQ,RHO1D, & + XLV0,XLV1,XLS0,XLS1,CP,R,G, & + EP2,SVP1,SVP2,SVP3,SVPT0, & + pblh(i,j),z_at_w1d,cupflag(i,j), & !wig, 21-Feb-2008 + th_perturb(1),r_perturb(1), & !wig, 9-Oct-2006 + 0.01, & !lkb, 15-Aug-2008, replace mass flux with default + ishall,qlg,qig, & !wig, 20-Sep-2006 + DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & + RAINCV,NCA,NTST, & !LD, add PRATEC 21-Apr-2011 + flag_QI,flag_QS,warm_rain, & + CUTOP,CUBOT,WLCL, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + idiagee, updfra, wulcl, wup, & + umfout, uerout, udrout, & ! rce 11-may-2012 + dmfout, derout, ddrout, & ! " + shcu_aerosols_opt, & ! " + flag_chem, num_chem, & ! " + wact, qndrop1d, qc1d, qi1d, & ! " + fcvt_qc_to_qi, fcvt_qc_to_pr, & ! " + fcvt_qi_to_pr, chem1d, & ! " +#if ( WRF_CHEM == 1 ) + maxd_acomp, maxd_aphase, & ! " + maxd_atype, maxd_asize, & ! " + ntype_aer, nsize_aer, ncomp_aer, & ! " + ai_phase, msectional, & ! " + massptr_aer, numptr_aer, & ! " + dlo_sect, dhi_sect, & ! " + dens_aer, hygro_aer, sigmag_aer ) ! " +#else + 1, 1, & ! " + 1, 1 ) ! rce 11-may-2012 +#endif + + !!shall(i,j) = real(ishall) + !!do k=kts,kte + !! cldfra_cup(i,k,j) = 0. + !!end do + + ! rce 11-may-2012 *** currently, clouds produce by this call to kf_cup_para do not + ! rce 11-may-2012 *** produce any "cup" diagnostics and do not used by chem_cup + ! rce 11-may-2012 *** may want to change that eventually + + end if main_test_on_cupflag ! rce 11-may-2012 + + +! This was moved from earlier in the routine... + IF(PRESENT(rthcuten).AND.PRESENT(rqvcuten)) THEN + DO K=kts,kte + RTHCUTEN(I,K,J)=DTDT(K)/pi(I,K,J) + RQVCUTEN(I,K,J)=DQDT(K) + ENDDO + ENDIF +! wig: end + + IF(PRESENT(rqrcuten).AND.PRESENT(rqccuten)) THEN + IF( F_QR )THEN + DO K=kts,kte + RQRCUTEN(I,K,J)=DQRDT(K) + RQCCUTEN(I,K,J)=DQCDT(K) + ENDDO + ELSE +! This is the case for Eta microphysics without 3d rain field + DO K=kts,kte + RQRCUTEN(I,K,J)=0. + RQCCUTEN(I,K,J)=DQRDT(K)+DQCDT(K) + ENDDO + ENDIF + ENDIF + +!...... QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2) + + IF(PRESENT( rqicuten )) THEN + IF ( F_QI ) THEN + DO K=kts,kte + RQICUTEN(I,K,J)=DQIDT(K) + ENDDO + ENDIF + ENDIF + + IF(PRESENT( rqscuten )) THEN + IF ( F_QS ) THEN + DO K=kts,kte + RQSCUTEN(I,K,J)=DQSDT(K) + ENDDO + ENDIF + ENDIF +! + if (idiagee>0) then ! rce 11-may-2012 + write(*,'(a,3i5,1p,3e11.3)') 'kfcup 3 ishall, cubot/top, nca', ishall, nint(cubot(i,j)), nint(cutop(i,j)), nca(i,j) + write(*,'(a,5i5,1p,3e11.3)') 'kfcup a08 ishall, i/jpert_deep, cubot/top, nca', ishall, & + ipert_deepsv, jpert_deepsv, nint(cubot(i,j)), nint(cutop(i,j)), nca(i,j) + end if + + ENDIF main_test_on_nca ! rce 11-may-2012 + + ENDDO main_loop_on_i ! rce 11-may-2012 + ENDDO main_loop_on_j ! rce 11-may-2012 + ENDIF main_test_on_ktau_ntst ! rce 11-may-2012 + +! write(*,*) 'end',raincv,ishall,'end' !LD, 20-April-2011 + + if (idiagff > 0) then ! rce 11-may-2012 + i = its ; j = jts + write(*,'(a,i5,10x,l5,3i5,f10.1,1p,2e10.2)') 'kfcup a09 ktau; cupflag,ishall,bot/top; nca,cldfra,rqvcuten', & + ktau, cupflag(i,j), nint(shall(i,j)), nint(cubot(i,j)), nint(cutop(i,j)), nca(i,j), & + maxval(cldfra_cup(i,kts:kte-2,j)), maxval(rqvcuten(i,kts:kte-2,j)) + write(*,'(a,10i5)') 'kfcup a10 maxlocs for cldfra_cup & rqvcuten', & + maxloc(cldfra_cup(i,kts:kte-2,j)), maxloc(rqvcuten(i,kts:kte-2,j)) + write(*,'(a,i7,l5,3i5,2f10.1)') 'kfcup_a20 ktau, cupflag, ishall, bot/top, nca, tcloud', & + ktau, cupflag(i,j), nint(shall(i,j)), nint(cubot(i,j)), nint(cutop(i,j)), nca(i,j), tcloud_cup(i,j) + end if + + END SUBROUTINE KF_cup_CPS +! **************************************************************************** +!----------------------------------------------------------- + SUBROUTINE KF_cup_PARA ( GRID_ID, KTAU, & ! rce 11-may-2012 + I, J, & + U0,V0,T0,QV0,P0,DZQ,W0AVG1D, & + DT,DX,DXSQ,rhoe, & + XLV0,XLV1,XLS0,XLS1,CP,R,G, & + EP2,SVP1,SVP2,SVP3,SVPT0, & + pblh,z_at_w1d,cupflag, & !wig, 21-Feb-2008 + th_perturb,r_perturb, & !wig, 25-Aug-2006 + freq, & !lkb, 15-Aug-2008 + ishall,qlg,qig, & !wig, 25-Aug-2006 + DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & + RAINCV,NCA,NTST, & !LD, add PRATEC 21-Apr-2011 + F_QI,F_QS,warm_rain, & + CUTOP,CUBOT, wLCL, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & ! rce 11-may-2012 + idiagee, updfra, wulcl, wup, & ! " + umfout, uerout, udrout, & ! " + dmfout, derout, ddrout, & ! " + shcu_aerosols_opt, & ! " + flag_chem, num_chem, & ! " + wact, qndrop1d, qc1d, qi1d, & ! " + fcvt_qc_to_qi, fcvt_qc_to_pr, & ! " + fcvt_qi_to_pr, chem1d, & ! " + maxd_acomp, maxd_aphase, & ! " + maxd_atype, maxd_asize, & ! " + ntype_aer, nsize_aer, ncomp_aer, & ! " + ai_phase, msectional, & ! " + massptr_aer, numptr_aer, & ! " + dlo_sect, dhi_sect, & ! " + dens_aer, hygro_aer, sigmag_aer ) ! rce 11-may-2012 + +!----------------------------------------------------------- +!***** The KF scheme that is currently used in experimental runs of EMCs +!***** Eta model....jsk 8/00 +! + IMPLICIT NONE +!----------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + I,J,NTST, & + GRID_ID, KTAU ! rce 11-may-2012 + ! ,P_QI,P_QS,P_FIRST_SCALAR + + LOGICAL, INTENT(IN ) :: F_QI, F_QS + + LOGICAL, INTENT(IN ) :: warm_rain, & + cupflag !CuP, wig 9-Oct-2006 +! + REAL, DIMENSION( kts:kte ), & + INTENT(IN ) :: U0, & + V0, & + T0, & + QV0, & + P0, & + rhoe, & + DZQ, & + W0AVG1D, & + z_at_w1d !wig, 21-Feb-2008 +! + REAL, INTENT(IN ) :: DT,DX,DXSQ, & + pblh, & !wig, 21-Feb-2008 + th_perturb, r_perturb, & !wig, 25-Aug-2006 + freq !lkb, 15-Aug-2008 +! + + REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1,CP,R,G + REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 + +! + REAL, DIMENSION( kts:kte ), INTENT(INOUT) :: & + DQDT, & + DQIDT, & + DQCDT, & + DQRDT, & + DQSDT, & + DTDT + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: NCA + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: RAINCV !LD, add PRATEC 21-Apr-2011 + + integer, intent(out) :: ishall !wig, 25-Aug-2006 (was local before) + real, intent(out) :: wLCL !lkb, 29-April-2010 + REAL, DIMENSION( kts:kte ), INTENT(OUT) :: & + qlg, & !wig, 20-Sep-2006 (was local before) + qig !wig, 20-Sep-2006 (was local before) + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(OUT) :: CUBOT, & + CUTOP + +! rce 11-may-2012 mods start ------------------------------------------- + INTEGER, INTENT(IN ) :: idiagee, & + shcu_aerosols_opt, & + num_chem + + LOGICAL, INTENT(IN ) :: flag_chem + + REAL, INTENT(OUT ) :: updfra, & + wulcl, & + wact + + REAL, DIMENSION( kts:kte ), & + INTENT(INOUT) :: umfout, & + uerout, & + udrout, & + dmfout, & + derout, & + ddrout, & + wup + + REAL, DIMENSION( kts:kte ), & + INTENT(INOUT) :: qndrop1d, & + qc1d, & + qi1d, & + fcvt_qc_to_qi, & + fcvt_qc_to_pr, & + fcvt_qi_to_pr + + REAL, DIMENSION( kts:kte, 1:num_chem ), & + INTENT(INOUT) :: chem1d + + INTEGER, INTENT(IN ) :: maxd_acomp, & + maxd_aphase, & + maxd_atype, & + maxd_asize + + INTEGER, INTENT(IN ), OPTIONAL :: ntype_aer, & + nsize_aer(maxd_atype), & + ncomp_aer(maxd_atype), & + ai_phase, & + msectional, & + massptr_aer(maxd_acomp,maxd_asize,maxd_atype,maxd_aphase), & + numptr_aer(maxd_asize,maxd_atype,maxd_aphase) + + REAL, DIMENSION( maxd_asize, maxd_atype ), & + INTENT(IN ), OPTIONAL :: dlo_sect, dhi_sect, & + sigmag_aer + + REAL, DIMENSION( maxd_acomp, maxd_atype ), & + INTENT(IN ), OPTIONAL :: dens_aer, hygro_aer +! rce 11-may-2012 mods end --------------------------------------------- + +! +!...DEFINE LOCAL VARIABLES... +! + REAL, DIMENSION( kts:kte ) :: & + Q0,Z0,TV0,TU,TVU,QU,TZ,TVD, & + QD,QES,THTES,TG,TVG,QG,WU,WD,W0,EMS,EMSD, & + UMF,UER,UDR,DMF,DER,DDR,UMF2,UER2, & + UDR2,DMF2,DER2,DDR2,DZA,THTA0,THETEE, & + THTAU,THETEU,THTAD,THETED,QLIQ,QICE, & + QLQOUT,QICOUT,PPTLIQ,PPTICE,DETLQ,DETIC, & + DETLQ2,DETIC2,RATIO,RATIO2 + + + REAL, DIMENSION( kts:kte ) :: & + DOMGDP,EXN,TVQU,DP,RH,EQFRC,WSPD, & + QDT,FXM,THTAG,THPA,THFXOUT, & + THFXIN,QPA,QFXOUT,QFXIN,QLPA,QLFXIN, & + QLFXOUT,QIPA,QIFXIN,QIFXOUT,QRPA, & + QRFXIN,QRFXOUT,QSPA,QSFXIN,QSFXOUT, & + QL0,QI0,QR0,QRG,QS0,QSG + + + REAL, DIMENSION( kts:kte+1 ) :: OMG + REAL, DIMENSION( kts:kte ) :: RAINFB,SNOWFB + REAL, DIMENSION( kts:kte ) :: & + CLDHGT,QSD,DILFRC,DDILFRC,TKE,TGU,QGU,THTEEG + +! LOCAL VARS + + REAL :: P00,T00,RLF,RHIC,RHBC,PIE, & + TTFRZ,TBFRZ,C5,RATE + REAL :: GDRY,ROCP,ALIQ,BLIQ, & + CLIQ,DLIQ + REAL :: FBFRC,P300,DPTHMX,THMIX,QMIX,ZMIX,PMIX, & + ROCPQ,TMIX,EMIX,TLOG,TDPT,TLCL,TVLCL, & + CPORQ,PLCL,ES,DLP,TENV,QENV,TVEN,TVBAR, & + ZLCL,WKL,WABS,TRPPT,WSIGNE,DTLCL,GDT, & + !!ZLCL,WKL,WABS,TRPPT,WSIGNE,DTLCL,GDT,WLCL,& + TVAVG,QESE,WTW,RHOLCL,AU0,VMFLCL,UPOLD, & + UPNEW,ABE,WKLCL,TTEMP,FRC1, & + QNEWIC,RL,R1,QNWFRZ,EFFQ,BE,BOTERM,ENTERM,& + DZZ,UDLBE,REI,EE2,UD2,TTMP,F1,F2, & + THTTMP,QTMP,TMPLIQ,TMPICE,TU95,TU10,EE1, & + UD1,DPTT,QNEWLQ,DUMFDP,EE,TSAT, & + THTA,VCONV,TIMEC,SHSIGN,VWS,PEF, & + CBH,RCBH,PEFCBH,PEFF,PEFF2,TDER,THTMIN, & + DTMLTD,QS,TADVEC,DPDD,FRC,DPT,RDD,A1, & + DSSDT,DTMP,T1RH,QSRH,PPTFLX,CPR,CNDTNF, & + UPDINC,AINCM2,DEVDMF,PPR,RCED,DPPTDF, & + DMFLFS,DMFLFS2,RCED2,DDINC,AINCMX,AINCM1, & + AINC,TDER2,PPTFL2,FABE,STAB,DTT,DTT1, & + DTIME,TMA,TMB,TMM,BCOEFF,ACOEFF,QVDIFF, & + TOPOMG,CPM,DQ,ABEG,DABE,DFDA,FRC2,DR, & + UDFRC,TUC,QGS,RH0,RHG,QINIT,QFNL,ERR2, & + RELERR,RLC,RLS,RNC,FABEOLD,AINCOLD,UEFRC, & + DDFRC,TDC,DEFRC,RHBAR,DMFFRC,DPMIN,DILBE + REAL :: TIMEC_SHALL ! Added by lkb, 10/31/10 + REAL :: ASTRT,TP,VALUE,AINTRP,TKEMAX,QFRZ,& + QSS,PPTMLT,DTMELT,RHH,EVAC,BINC +! + INTEGER :: INDLU,NU,NUCHM,NNN,KLFS + REAL :: CHMIN,PM15,CHMAX,DTRH,RAD,DPPP + REAL :: TVDIFF,DTTOT,ABSOMG,ABSOMGTC,FRDP + + INTEGER :: KX,K,KL +! + INTEGER :: NCHECK + INTEGER, DIMENSION (kts:kte) :: KCHECK + + INTEGER :: ISTOP,ML,L5,KMIX,LOW, & + LC,MXLAYR,LLFC,NLAYRS,NK, & + !KPBL,KLCL,LCL,LET,IFLAG, & + KCLDLAYER,KLCL,LCL,LET,IFLAG, & + NK1,LTOP,NJ,LTOP1, & + LTOPM1,LVF,KSTART,KMIN,LFS, & + ND,NIC,LDB,LDT,ND1,NDK, & + NM,LMAX,NCOUNT,NOITR, & + NSTEP,NTC,NCHM,NSHALL + LOGICAL :: IPRNT + CHARACTER*1024 message + + INTEGER :: ksvaa ! rce 11-may-2012 + REAL :: rho_act, tk_act, w_act, w_act_eff ! rce 11-may-2012 + REAL :: qndrop_tmp ! rce 11-may-2012 + REAL :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpg, tmph, tmpi + REAL :: tmp_alphabn, tmp_ebn, tmp_escale, tmp_lv ! rce 11-may-2012 + REAL :: tmp_deltarh, tmp_deltatk, tmp_deltatkfact ! rce 11-may-2012 + REAL :: qndropbb(kts:kte) ! rce 11-may-2012 + +! + DATA P00,T00/1.E5,273.16/ + DATA RLF/3.339E5/ + DATA RHIC,RHBC/1.,0.90/ + DATA PIE,TTFRZ,TBFRZ,C5/3.141592654,268.16,248.16,1.0723E-3/ + DATA RATE/0.03/ + +!----------------------------------------------------------- + IPRNT=.FALSE. + GDRY=-G/CP + ROCP=R/CP + NSHALL = 0 + KL=kte + KX=kte + +! rce 11-may-2012 mods start ------------------------------------------- + if (idiagee > 0) IPRNT=.TRUE. + updfra = 0.0 + wup = 0.0 + wulcl = 0.0 + wact = 0.0 + qndrop1d = 0.0 + qc1d = 0.0 + qi1d = 0.0 + fcvt_qc_to_qi = 0.0 + fcvt_qc_to_pr = 0.0 + fcvt_qi_to_pr = 0.0 + umfout = 0.0 + uerout = 0.0 + udrout = 0.0 + dmfout = 0.0 + derout = 0.0 + ddrout = 0.0 +! rce 11-may-2012 mods end --------------------------------------------- + +! +! ALIQ = 613.3 +! BLIQ = 17.502 +! CLIQ = 4780.8 +! DLIQ = 32.19 + ALIQ = SVP1*1000. + BLIQ = SVP2 + CLIQ = SVP2*SVPT0 + DLIQ = SVP3 +! +! +!**************************************************************************** +! ! PPT FB MODS +!...OPTION TO FEED CONVECTIVELY GENERATED RAINWATER ! PPT FB MODS +!...INTO GRID-RESOLVED RAINWATER (OR SNOW/GRAUPEL) ! PPT FB MODS +!...FIELD. "FBFRC" IS THE FRACTION OF AVAILABLE ! PPT FB MODS +!...PRECIPITATION TO BE FED BACK (0.0 - 1.0)... ! PPT FB MODS + FBFRC=0.0 ! PPT FB MODS +!...mods to allow shallow convection... + NCHM = 0 + ISHALL = 0 + DPMIN = 5.E3 +!... + P300=P0(1)-30000. + +!... Set time constant for shallow convection + TIMEC_SHALL = 1800.0 ! Set to the min value allowed for all convection + +! +!...PRESSURE PERTURBATION TERM IS ONLY DEFINED AT MID-POINT OF +!...VERTICAL LAYERS...SINCE TOTAL PRESSURE IS NEEDED AT THE TOP AND +!...BOTTOM OF LAYERS BELOW, DO AN INTERPOLATION... +! +!...INPUT A VERTICAL SOUNDING ... NOTE THAT MODEL LAYERS ARE NUMBERED +!...FROM BOTTOM-UP IN THE KF SCHEME... +! + ML=0 +!SUE tmprpsb=1./PSB(I,J) +!SUE CELL=PTOP*tmprpsb +! + DO K=1,KX +! +!...IF Q0 IS ABOVE SATURATION VALUE, REDUCE IT TO SATURATION LEVEL... +! + ES=ALIQ*EXP((BLIQ*T0(K)-CLIQ)/(T0(K)-DLIQ)) + QES(K)=0.622*ES/(P0(K)-ES) + Q0(K)=AMIN1(QES(K),QV0(K)) + Q0(K)=AMAX1(0.000001,Q0(K)) + QL0(K)=0. + QI0(K)=0. + QR0(K)=0. + QS0(K)=0. + RH(K) = Q0(K)/QES(K) + DILFRC(K) = 1. + TV0(K)=T0(K)*(1.+0.608*Q0(K)) +! RHOE(K)=P0(K)/(R*TV0(K)) +! DP IS THE PRESSURE INTERVAL BETWEEN FULL SIGMA LEVELS... + DP(K)=rhoe(k)*g*DZQ(k) +! IF Turbulent Kinetic Energy (TKE) is available from turbulent mixing scheme +! use it for shallow convection...For now, assume it is not available.... +! TKE(K) = Q2(I,J,NK) + TKE(K) = 0. + CLDHGT(K) = 0. +! IF(P0(K).GE.500E2)L5=K + IF(P0(K).GE.0.5*P0(1))L5=K + IF(P0(K).GE.P300)LLFC=K + IF(T0(K).GT.T00)ML=K + ENDDO +! +!...DZQ IS DZ BETWEEN SIGMA SURFACES, DZA IS DZ BETWEEN MODEL HALF LEVEL + Z0(1)=.5*DZQ(1) +!cdir novector + DO K=2,KL + Z0(K)=Z0(K-1)+.5*(DZQ(K)+DZQ(K-1)) + DZA(K-1)=Z0(K)-Z0(K-1) + ENDDO + DZA(KL)=0. +! +! +! To save time, specify a pressure interval to move up in sequential +! check of different ~50 mb deep groups of adjacent model layers in +! the process of identifying updraft source layer (USL). Note that +! this search is terminated as soon as a buoyant parcel is found and +! this parcel can produce a cloud greater than specifed minimum depth +! (CHMIN)...For now, set interval at 15 mb... +! + NCHECK = 1 + KCHECK(NCHECK)=1 + PM15 = P0(1)-15.E2 + DO K=2,LLFC + IF(P0(K).LT.PM15)THEN + NCHECK = NCHECK+1 + KCHECK(NCHECK) = K + PM15 = PM15-15.E2 + ENDIF + ENDDO +! + NU=0 + NUCHM=0 +usl: DO + NU = NU+1 + IF(NU.GT.NCHECK)THEN + IF(ISHALL.EQ.1)THEN + CHMAX = 0. + NCHM = 0 + DO NK = 1,NCHECK + NNN=KCHECK(NK) + IF(CLDHGT(NNN).GT.CHMAX)THEN + NCHM = NNN + NUCHM = NK + CHMAX = CLDHGT(NNN) + ENDIF + ENDDO + NU = NUCHM-1 + FBFRC=1. + CYCLE usl + ELSE +! wig, 29-Aug-2006: I think this is where no convecion occurs. So, force +! ishall to a flag value to indicate this for accounting purposes. + ishall = 2 + RETURN + ENDIF + ENDIF + KMIX = KCHECK(NU) + LOW=KMIX +!... + LC = LOW +! +!...ASSUME THAT IN ORDER TO SUPPORT A DEEP UPDRAFT YOU NEED A LAYER OF +!...UNSTABLE AIR AT LEAST 50 mb DEEP...TO APPROXIMATE THIS, ISOLATE A +!...GROUP OF ADJACENT INDIVIDUAL MODEL LAYERS, WITH THE BASE AT LEVEL +!...LC, SUCH THAT THE COMBINED DEPTH OF THESE LAYERS IS AT LEAST 50 mb.. +! + NLAYRS=0 + DPTHMX=0. + NK=LC-1 + IF ( NK+1 .LT. KTS ) THEN + WRITE(message,*)'WOULD GO OFF BOTTOM: KF_CUP_PARA I,J,NK',I,J,NK + CALL wrf_message (TRIM(message)) + ELSE + DO + NK=NK+1 + IF ( NK .GT. KTE ) THEN + WRITE(message,*) & + 'WOULD GO OFF TOP: KF_CUP_PARA I,J,DPTHMX,DPMIN',I,J,DPTHMX,DPMIN + CALL wrf_message (TRIM(message)) + EXIT + ENDIF + DPTHMX=DPTHMX+DP(NK) + NLAYRS=NLAYRS+1 + IF(DPTHMX.GT.DPMIN)THEN + EXIT + ENDIF + END DO + ENDIF + IF(DPTHMX.LT.DPMIN)THEN +! wig, 29-Aug-2006: Indicate no convection occurred in ishall. + ishall = 2 + RETURN + ENDIF + !!KPBL=LC+NLAYRS-1 + KCLDLAYER=LC+NLAYRS-1 ! Added new veriable for top of cloud layer + !!if(ishall .eq. 0) KPBL=LC !lkb, changed to only adjust mixed layer depth for deep convection +! +!...******************************************************** +!...for computational simplicity without much loss in accuracy, +!...mix temperature instead of theta for evaluating convective +!...initiation (triggering) potential... +! THMIX=0. + TMIX=0. + QMIX=0. + ZMIX=0. + PMIX=0. +! +!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY +!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL +!...LAYERS... +! +!cdir novector + !!DO NK=LC,KPBL + DO NK=LC,KCLDLAYER + TMIX=TMIX+DP(NK)*T0(NK) + QMIX=QMIX+DP(NK)*Q0(NK) + ZMIX=ZMIX+DP(NK)*Z0(NK) + PMIX=PMIX+DP(NK)*P0(NK) + ENDDO +! THMIX=THMIX/DPTHMX + TMIX=TMIX/DPTHMX + QMIX=QMIX/DPTHMX + ZMIX=ZMIX/DPTHMX + PMIX=PMIX/DPTHMX + EMIX=QMIX*PMIX/(0.622+QMIX) +! +!...FIND THE TEMPERATURE OF THE MIXTURE AT ITS LCL... +! +! TLOG=ALOG(EMIX/ALIQ) +! ...calculate dewpoint using lookup table... +! + astrt=1.e-3 + ainc=0.075 + a1=emix/aliq + tp=(a1-astrt)/ainc + indlu=int(tp)+1 + value=(indlu-1)*ainc+astrt + aintrp=(a1-value)/ainc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT) + TLCL=AMIN1(TLCL,TMIX) + TVLCL=TLCL*(1.+0.608*QMIX) + ZLCL = ZMIX+(TLCL-TMIX)/GDRY + NK = LC-1 + DO + NK = NK+1 + KLCL=NK + IF(ZLCL.LE.Z0(NK) .or. NK.GT.KL)THEN + EXIT + ENDIF + ENDDO + IF(NK.GT.KL)THEN +! wig, 29-Aug-2006: Indicate no convection occurred. + ishall = 2 + RETURN + ENDIF + K=KLCL-1 + DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K)) +! +!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... +! + TENV=T0(K)+(T0(KLCL)-T0(K))*DLP + QENV=Q0(K)+(Q0(KLCL)-Q0(K))*DLP + TVEN=TENV*(1.+0.608*QENV) +! +!...CHECK TO SEE IF CLOUD IS BUOYANT USING FRITSCH-CHAPPELL TRIGGER +!...FUNCTION DESCRIBED IN KAIN AND FRITSCH (1992)...W0 IS AN +!...APROXIMATE VALUE FOR THE RUNNING-MEAN GRID-SCALE VERTICAL +!...VELOCITY, WHICH GIVES SMOOTHER FIELDS OF CONVECTIVE INITIATION +!...THAN THE INSTANTANEOUS VALUE...FORMULA RELATING TEMPERATURE +!...PERTURBATION TO VERTICAL VELOCITY HAS BEEN USED WITH THE MOST +!...SUCCESS AT GRID LENGTHS NEAR 25 km. FOR DIFFERENT GRID-LENGTHS, +!...ADJUST VERTICAL VELOCITY TO EQUIVALENT VALUE FOR 25 KM GRID +!...LENGTH, ASSUMING LINEAR DEPENDENCE OF W ON GRID LENGTH... + IF(ZLCL.LT.2.E3)THEN + WKLCL=0.02*ZLCL/2.E3 + ELSE + WKLCL=0.02 + ENDIF + WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)*DX/25.E3-WKLCL + +! CuP, wig, 28-Aug-2006, begin: +! +! Replace KF perturbation temperatures with CuP perturbations. CuP +! perturbations are in potential temp. so convert the theta difference +! to a temperature difference. For the moisture perturbation, convert +! the CuP mixing ratio (kg/kg) into a virtual temperature adjustment. +! +! Standard KF way... + if( .not. cupflag ) then + IF(WKL.LT.0.0001)THEN + DTLCL=0. + ELSE + DTLCL=4.64*WKL**0.33 + ENDIF + DTRH = 0. !CuP, wig: Move this from a few lines below since + ! it is commented out there for CuP. + else +! New CuP way... + PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP + dtlcl = th_perturb*(p00/p0(k))**rocp + dtrh = 0.608*r_perturb + end if +! wig: end + +! +!...for ETA model, give parcel an extra temperature perturbation based +!...the threshold RH for condensation (U00)... +! +!...for now, just assume U00=0.75... +!...!!!!!! for MM5, SET DTRH = 0. !!!!!!!! +! U00 = 0.75 +! IF(U00.lt.1.)THEN +! QSLCL=QES(K)+(QES(KLCL)-QES(K))*DLP +! RHLCL = QENV/QSLCL +! DQSSDT = QMIX*(CLIQ-BLIQ*DLIQ)/((TLCL-DLIQ)*(TLCL-DLIQ)) +! IF(RHLCL.ge.0.75 .and. RHLCL.le.0.95)then +! DTRH = 0.25*(RHLCL-0.75)*QMIX/DQSSDT +! ELSEIF(RHLCL.GT.0.95)THEN +! DTRH = (1./RHLCL-1.)*QMIX/DQSSDT +! ELSE +!!$wig, 28-Aug-2006 DTRH = 0. +! ENDIF +! ENDIF +! IF(ISHALL.EQ.1)IPRNT=.TRUE. +! IPRNT=.TRUE. +! IF(TLCL+DTLCL.GT.TENV)GOTO 45 +! + +! CuP, wig 28-Aug-2006, begin: Change parcel temperature adjustment +! comparison to use virtual temperature instead of "normal" +! temperature... +!~Check to see if this should be switched back if cupflag==F. Why isn't +! the virt. temp. used in the standard scheme? +!!$trigger: IF(TLCL+DTLCL+DTRH.LT.TENV)THEN + TVLCL=TLCL*(1.+0.608*QMIX) +trigger: if( tvlcl+dtlcl+dtrh < tven ) then +! wig: end + +! +! Parcel not buoyant, CYCLE back to start of trigger and evaluate next potential USL... +! + CYCLE usl +! + ELSE ! Parcel is buoyant, determine updraft +! +!...CONVECTIVE TRIGGERING CRITERIA HAS BEEN SATISFIED...COMPUTE +!...EQUIVALENT POTENTIAL TEMPERATURE +!...(THETEU) AND VERTICAL VELOCITY OF THE RISING PARCEL AT THE LCL... +! + CALL ENVIRTHT(PMIX,TMIX,QMIX,THETEU(K),ALIQ,BLIQ,CLIQ,DLIQ) +! +!...modify calculation of initial parcel vertical velocity...jsk 11/26/97 +! +! CuP, wig 28-Aug-2006: The original KF algorithm sets the parcel's +! initial pert. vertical velocity at the LCL based on the pert. +! temperature, with a minimum W of 3. But, if the pert. temp. is +! negative, a smaller minimum positive W is set (==1). For CuP, +! allow the perturbation to set the W without any constraints +! except that the pert. must be positive. + DTTOT = DTLCL+DTRH + IF(DTTOT.GT.1.E-4)THEN + GDT=2.*G*DTTOT*500./TVEN + WLCL=1.+0.5*SQRT(GDT) + if( .not. cupflag ) WLCL = AMIN1(WLCL,3.) !wig 9-Oct-2006 + ELSE + if( cupflag ) then + wlcl = 0. + else + WLCL=1. + end if + ENDIF +!print*,'~ dttot and wlcl=',dttot,wlcl +! wig: end + PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP + WTW=WLCL*WLCL +! + TVLCL=TLCL*(1.+0.608*QMIX) + RHOLCL=PLCL/(R*TVLCL) +! + LCL=KLCL + LET=LCL +! make RAD a function of background vertical velocity... + IF(WKL.LT.0.)THEN + RAD = 1000. + ELSEIF(WKL.GT.0.1)THEN + RAD = 2000. + ELSE + RAD = 1000.+1000*WKL/0.1 + ENDIF +! +!******************************************************************* +! * +! COMPUTE UPDRAFT PROPERTIES * +! * +!******************************************************************* +! +! +!... +!...ESTIMATE INITIAL UPDRAFT MASS FLUX (UMF(K))... +! + WU(K)=WLCL + AU0=0.01*DXSQ + UMF(K)=RHOLCL*AU0 + !!UMF(K)=freq*dxsq*WU(K)*RHOLCL ! Added by lkb + VMFLCL=UMF(K) + UPOLD=VMFLCL + UPNEW=UPOLD + ksvaa = k ! rce 11-may-2012 +! +!...RATIO2 IS THE DEGREE OF GLACIATION IN THE CLOUD (0 TO 1), +!...UER IS THE ENVIR ENTRAINMENT RATE, ABE IS AVAILABLE +!...BUOYANT ENERGY, TRPPT IS THE TOTAL RATE OF PRECIPITATION +!...PRODUCTION... +! + RATIO2(K)=0. + UER(K)=0. + ABE=0. + TRPPT=0. + TU(K)=TLCL + TVU(K)=TVLCL + QU(K)=QMIX + EQFRC(K)=1. + QLIQ(K)=0. + QICE(K)=0. + QLQOUT(K)=0. + QICOUT(K)=0. + DETLQ(K)=0. + DETIC(K)=0. + PPTLIQ(K)=0. + PPTICE(K)=0. + IFLAG=0 +! +!...TTEMP IS USED DURING CALCULATION OF THE LINEAR GLACIATION +!...PROCESS; IT IS INITIALLY SET TO THE TEMPERATURE AT WHICH +!...FREEZING IS SPECIFIED TO BEGIN. WITHIN THE GLACIATION +!...INTERVAL, IT IS SET EQUAL TO THE UPDRAFT TEMP AT THE +!...PREVIOUS MODEL LEVEL... +! + TTEMP=TTFRZ +! +!...ENTER THE LOOP FOR UPDRAFT CALCULATIONS...CALCULATE UPDRAFT TEMP, +!...MIXING RATIO, VERTICAL MASS FLUX, LATERAL DETRAINMENT OF MASS AND +!...MOISTURE, PRECIPITATION RATES AT EACH MODEL LEVEL... +! +! + EE1=1. + UD1=0. + REI = 0. + DILBE = 0. + qndropbb(:) = 0.0 ! rce 11-may-2012 + +updraft: DO NK=K,KL-1 + NK1=NK+1 + RATIO2(NK1)=RATIO2(NK) + FRC1=0. + TU(NK1)=T0(NK1) + THETEU(NK1)=THETEU(NK) + QU(NK1)=QU(NK) + QLIQ(NK1)=QLIQ(NK) + QICE(NK1)=QICE(NK) + call tpmix2(p0(nk1),theteu(nk1),tu(nk1),qu(nk1),qliq(nk1), & + qice(nk1),qnewlq,qnewic,XLV1,XLV0) +! +! +!...CHECK TO SEE IF UPDRAFT TEMP IS ABOVE THE TEMPERATURE AT WHICH +!...GLACIATION IS ASSUMED TO INITIATE; IF IT IS, CALCULATE THE +!...FRACTION OF REMAINING LIQUID WATER TO FREEZE...TTFRZ IS THE +!...TEMP AT WHICH FREEZING BEGINS, TBFRZ THE TEMP BELOW WHICH ALL +!...LIQUID WATER IS FROZEN AT EACH LEVEL... +! + IF(TU(NK1).LE.TTFRZ)THEN + IF(TU(NK1).GT.TBFRZ)THEN + IF(TTEMP.GT.TTFRZ)TTEMP=TTFRZ + FRC1=(TTEMP-TU(NK1))/(TTEMP-TBFRZ) + ELSE + FRC1=1. + IFLAG=1 + ENDIF + TTEMP=TU(NK1) +! +! DETERMINE THE EFFECTS OF LIQUID WATER FREEZING WHEN TEMPERATURE +!...IS BELOW TTFRZ... +! + ! rce 11-may-2012 - added lines with tmpa/c and fcvt_qc_to_qi + tmpa = max( 0.0, qliq(nk1)+qnewlq ) ! qliq before freezing calc + QFRZ = (QLIQ(NK1)+QNEWLQ)*FRC1 + QNEWIC=QNEWIC+QNEWLQ*FRC1 + QNEWLQ=QNEWLQ-QNEWLQ*FRC1 + QICE(NK1) = QICE(NK1)+QLIQ(NK1)*FRC1 + QLIQ(NK1) = QLIQ(NK1)-QLIQ(NK1)*FRC1 + tmpc = max( 0.0, qliq(nk1)+qnewlq ) ! qliq after freezing calc + fcvt_qc_to_qi(nk1) = max( 0.0, tmpa-tmpc ) / max( 1.0e-10, tmpa ) + CALL DTFRZNEW(TU(NK1),P0(NK1),THETEU(NK1),QU(NK1),QFRZ, & + QICE(NK1),ALIQ,BLIQ,CLIQ,DLIQ) + ENDIF + TVU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)) +! +! CALCULATE UPDRAFT VERTICAL VELOCITY AND PRECIPITATION FALLOUT... +! + IF(NK.EQ.K)THEN + BE=(TVLCL+TVU(NK1))/(TVEN+TV0(NK1))-1. + BOTERM=2.*(Z0(NK1)-ZLCL)*G*BE/1.5 + DZZ=Z0(NK1)-ZLCL + ELSE + BE=(TVU(NK)+TVU(NK1))/(TV0(NK)+TV0(NK1))-1. + BOTERM=2.*DZA(NK)*G*BE/1.5 + DZZ=DZA(NK) + ENDIF + ENTERM=2.*REI*WTW/UPOLD + + ! rce 11-may-2012 - added lines with tmpa/b/c and fcvt_q?_to_pr + tmpa = max( 0.0, qliq(nk1)+qnewlq ) ! qliq before precip calc + tmpb = max( 0.0, qice(nk1)+qnewic ) ! qice before precip calc + CALL CONDLOAD(QLIQ(NK1),QICE(NK1),WTW,DZZ,BOTERM,ENTERM, & + RATE,QNEWLQ,QNEWIC,QLQOUT(NK1),QICOUT(NK1),G) + tmpc = max( 0.0, qliq(nk1)+qnewlq ) ! qliq after precip calc + fcvt_qc_to_pr(nk1) = max( 0.0, tmpa-tmpc ) / max( 1.0e-10, tmpa ) + tmpc = max( 0.0, qice(nk1)+qnewic ) ! qice after precip calc + fcvt_qi_to_pr(nk1) = max( 0.0, tmpb-tmpc ) / max( 1.0e-10, tmpb ) + +! +!...IF VERT VELOCITY IS LESS THAN ZERO, EXIT THE UPDRAFT LOOP AND, +!...IF CLOUD IS TALL ENOUGH, FINALIZE UPDRAFT CALCULATIONS... +! + IF(WTW.LT.1.E-3)THEN + EXIT + ELSE + WU(NK1)=SQRT(WTW) + ENDIF +!...Calculate value of THETA-E in environment to entrain into updraft... +! + CALL ENVIRTHT(P0(NK1),T0(NK1),Q0(NK1),THETEE(NK1),ALIQ,BLIQ,CLIQ,DLIQ) +! +!...REI IS THE RATE OF ENVIRONMENTAL INFLOW... +! + REI=VMFLCL*DP(NK1)*0.03/RAD + TVQU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)-QLIQ(NK1)-QICE(NK1)) + IF(NK.EQ.K)THEN + DILBE=((TVLCL+TVQU(NK1))/(TVEN+TV0(NK1))-1.)*DZZ + ELSE + DILBE=((TVQU(NK)+TVQU(NK1))/(TV0(NK)+TV0(NK1))-1.)*DZZ + ENDIF + IF(DILBE.GT.0.)ABE=ABE+DILBE*G +! +!...IF CLOUD PARCELS ARE VIRTUALLY COLDER THAN THE ENVIRONMENT, MINIMAL +!...ENTRAINMENT (0.5*REI) IS IMPOSED... +! + IF(TVQU(NK1).LE.TV0(NK1))THEN ! Entrain/Detrain IF BLOCK + EE2=0.5 + UD2=1. + EQFRC(NK1)=0. + ELSE + LET=NK1 + TTMP=TVQU(NK1) +! +!...DETERMINE THE CRITICAL MIXED FRACTION OF UPDRAFT AND ENVIRONMENTAL AIR... +! + F1=0.95 + F2=1.-F1 + THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) + QTMP=F1*Q0(NK1)+F2*QU(NK1) + TMPLIQ=F2*QLIQ(NK1) + TMPICE=F2*QICE(NK1) + call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, & + qnewlq,qnewic,XLV1,XLV0) + TU95=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) + IF(TU95.GT.TV0(NK1))THEN + EE2=1. + UD2=0. + EQFRC(NK1)=1.0 + ELSE + F1=0.10 + F2=1.-F1 + THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) + QTMP=F1*Q0(NK1)+F2*QU(NK1) + TMPLIQ=F2*QLIQ(NK1) + TMPICE=F2*QICE(NK1) + call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, & + qnewlq,qnewic,XLV1,XLV0) + TU10=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) + TVDIFF = ABS(TU10-TVQU(NK1)) + IF(TVDIFF.LT.1.e-3)THEN + EE2=1. + UD2=0. + EQFRC(NK1)=1.0 + ELSE + EQFRC(NK1)=(TV0(NK1)-TVQU(NK1))*F1/(TU10-TVQU(NK1)) + EQFRC(NK1)=AMAX1(0.0,EQFRC(NK1)) + EQFRC(NK1)=AMIN1(1.0,EQFRC(NK1)) + IF(EQFRC(NK1).EQ.1)THEN + EE2=1. + UD2=0. + ELSEIF(EQFRC(NK1).EQ.0.)THEN + EE2=0. + UD2=1. + ELSE +! +!...SUBROUTINE PROF5 INTEGRATES OVER THE GAUSSIAN DIST TO DETERMINE THE +! FRACTIONAL ENTRAINMENT AND DETRAINMENT RATES... +! + CALL PROF5(EQFRC(NK1),EE2,UD2) + ENDIF + ENDIF + ENDIF + ENDIF ! End of Entrain/Detrain IF BLOCK +! +! +!...NET ENTRAINMENT AND DETRAINMENT RATES ARE GIVEN BY THE AVERAGE FRACTIONAL +! VALUES IN THE LAYER... +! + EE2 = AMAX1(EE2,0.5) + UD2 = 1.5*UD2 + UER(NK1)=0.5*REI*(EE1+EE2) + UDR(NK1)=0.5*REI*(UD1+UD2) +! +!...IF THE CALCULATED UPDRAFT DETRAINMENT RATE IS GREATER THAN THE TOTAL +! UPDRAFT MASS FLUX, ALL CLOUD MASS DETRAINS, EXIT UPDRAFT CALCULATIONS... +! + IF(UMF(NK)-UDR(NK1).LT.10.)THEN +! +!...IF THE CALCULATED DETRAINED MASS FLUX IS GREATER THAN THE TOTAL UPD MASS +! FLUX, IMPOSE TOTAL DETRAINMENT OF UPDRAFT MASS AT THE PREVIOUS MODEL LVL.. +! First, correct ABE calculation if needed... +! + IF(DILBE.GT.0.)THEN + ABE=ABE-DILBE*G + ENDIF + LET=NK +! WRITE(98,1015)P0(NK1)/100. + EXIT + ELSE + EE1=EE2 + UD1=UD2 + UPOLD=UMF(NK)-UDR(NK1) + UPNEW=UPOLD+UER(NK1) + UMF(NK1)=UPNEW + DILFRC(NK1) = UPNEW/UPOLD +! +!...DETLQ AND DETIC ARE THE RATES OF DETRAINMENT OF LIQUID AND +!...ICE IN THE DETRAINING UPDRAFT MASS... +! + DETLQ(NK1)=QLIQ(NK1)*UDR(NK1) + DETIC(NK1)=QICE(NK1)*UDR(NK1) + QDT(NK1)=QU(NK1) + QU(NK1)=(UPOLD*QU(NK1)+UER(NK1)*Q0(NK1))/UPNEW + THETEU(NK1)=(THETEU(NK1)*UPOLD+THETEE(NK1)*UER(NK1))/UPNEW + QLIQ(NK1)=QLIQ(NK1)*UPOLD/UPNEW + QICE(NK1)=QICE(NK1)*UPOLD/UPNEW +! +!...PPTLIQ IS THE RATE OF GENERATION (FALLOUT) OF +!...LIQUID PRECIP AT A GIVEN MODEL LVL, PPTICE THE SAME FOR ICE, +!...TRPPT IS THE TOTAL RATE OF PRODUCTION OF PRECIP UP TO THE +!...CURRENT MODEL LEVEL... +! + PPTLIQ(NK1)=QLQOUT(NK1)*UMF(NK) + PPTICE(NK1)=QICOUT(NK1)*UMF(NK) +! + TRPPT=TRPPT+PPTLIQ(NK1)+PPTICE(NK1) + !!IF(NK1.LE.KPBL)UER(NK1)=UER(NK1)+VMFLCL*DP(NK1)/DPTHMX + IF(NK1.LE.KCLDLAYER)UER(NK1)=UER(NK1)+VMFLCL*DP(NK1)/DPTHMX + ENDIF +! + END DO updraft +! +!...CHECK CLOUD DEPTH...IF CLOUD IS TALL ENOUGH, ESTIMATE THE EQUILIBRIU +! TEMPERATURE LEVEL (LET) AND ADJUST MASS FLUX PROFILE AT CLOUD TOP SO +! THAT MASS FLUX DECREASES TO ZERO AS A LINEAR FUNCTION OF PRESSURE BE +! THE LET AND CLOUD TOP... +! +!...LTOP IS THE MODEL LEVEL JUST BELOW THE LEVEL AT WHICH VERTICAL VELOC +! FIRST BECOMES NEGATIVE... +! + LTOP=NK + CLDHGT(LC)=Z0(LTOP)-ZLCL +! +!...Instead of using the same minimum cloud height (for deep convection) +!...everywhere, try specifying minimum cloud depth as a function of TLCL... +! +! +! + IF(TLCL.GT.293.)THEN + CHMIN = 4.E3 + ELSEIF(TLCL.LE.293. .and. TLCL.GE.273)THEN + CHMIN = 2.E3 + 100.*(TLCL-273.) + ELSEIF(TLCL.LT.273.)THEN + CHMIN = 2.E3 + ENDIF + +! +!...If cloud top height is less than the specified minimum for deep +!...convection, save value to consider this level as source for +!...shallow convection, go back up to check next level... +! +!...Try specifying minimum cloud depth as a function of TLCL... +! +! +!...DO NOT ALLOW ANY CLOUD FROM THIS LAYER IF: +! +!... 1.) if there is no CAPE, or +!... 2.) cloud top is at model level just above LCL, or +!... 3.) cloud top is within updraft source layer, or +!... 4.) cloud-top detrainment layer begins within +!... updraft source layer. +! + !!IF(LTOP.LE.KLCL .or. LTOP.LE.KPBL .or. LET+1.LE.KPBL)THEN ! No Convection Allowed + IF(LTOP.LE.KLCL .or. LTOP.LE.KCLDLAYER .or. LET+1.LE.KCLDLAYER)THEN ! No Convection Allowed + CLDHGT(LC)=0. + DO NK=K,LTOP + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + ENDDO +! + ELSEIF(CLDHGT(LC).GT.CHMIN .and. ABE.GT.1)THEN ! Deep Convection allowed + ISHALL=0 + EXIT usl + ELSE +! +!...TO DISALLOW SHALLOW CONVECTION, COMMENT OUT NEXT LINE !!!!!!!! + ISHALL = 1 + IF(NU.EQ.NUCHM)THEN + EXIT usl ! Shallow Convection from this layer + ELSE +! Remember this layer (by virtue of non-zero CLDHGT) as potential shallow-cloud layer + DO NK=K,LTOP + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + ENDDO + ENDIF + ENDIF + ENDIF trigger + END DO usl + IF(ISHALL.EQ.1)THEN + !!KSTART=MAX0(KPBL,KLCL) + KSTART=MAX0(KCLDLAYER,KLCL) + if (idiagee > 0) write(98,'(a,1p,2i5,2x,2i5)') & + 'kfcup let_old, let_new, klcl, ltop', let, kstart, klcl, ltop ! rce 11-may-2012 + LET=KSTART + endif +! +!...IF THE LET AND LTOP ARE THE SAME, DETRAIN ALL OF THE UPDRAFT MASS FL +! THIS LEVEL... +! + IF(LET.EQ.LTOP)THEN + UDR(LTOP)=UMF(LTOP)+UDR(LTOP)-UER(LTOP) + DETLQ(LTOP)=QLIQ(LTOP)*UDR(LTOP)*UPNEW/UPOLD + DETIC(LTOP)=QICE(LTOP)*UDR(LTOP)*UPNEW/UPOLD + UER(LTOP)=0. + UMF(LTOP)=0. + ELSE +! +! BEGIN TOTAL DETRAINMENT AT THE LEVEL ABOVE THE LET... +! + DPTT=0. + DO NJ=LET+1,LTOP + DPTT=DPTT+DP(NJ) + ENDDO + DUMFDP=UMF(LET)/DPTT +! +!...ADJUST MASS FLUX PROFILES, DETRAINMENT RATES, AND PRECIPITATION FALL +! RATES TO REFLECT THE LINEAR DECREASE IN MASS FLX BETWEEN THE LET AND +! + DO NK=LET+1,LTOP +! +!...entrainment is allowed at every level except for LTOP, so disallow +!...entrainment at LTOP and adjust entrainment rates between LET and LTOP +!...so the the dilution factor due to entyrianment is not changed but +!...the actual entrainment rate will change due due forced total +!...detrainment in this layer... +! + IF(NK.EQ.LTOP)THEN + UDR(NK) = UMF(NK-1) + UER(NK) = 0. + DETLQ(NK) = UDR(NK)*QLIQ(NK)*DILFRC(NK) + DETIC(NK) = UDR(NK)*QICE(NK)*DILFRC(NK) + ELSE + UMF(NK)=UMF(NK-1)-DP(NK)*DUMFDP + UER(NK)=UMF(NK)*(1.-1./DILFRC(NK)) + UDR(NK)=UMF(NK-1)-UMF(NK)+UER(NK) + DETLQ(NK)=UDR(NK)*QLIQ(NK)*DILFRC(NK) + DETIC(NK)=UDR(NK)*QICE(NK)*DILFRC(NK) + ENDIF + IF(NK.GE.LET+2)THEN + TRPPT=TRPPT-PPTLIQ(NK)-PPTICE(NK) + PPTLIQ(NK)=UMF(NK-1)*QLQOUT(NK) + PPTICE(NK)=UMF(NK-1)*QICOUT(NK) + TRPPT=TRPPT+PPTLIQ(NK)+PPTICE(NK) + ENDIF + ENDDO + ENDIF +! +! Initialize some arrays below cloud base and above cloud top... +! + DO NK=1,K + IF(NK.GE.LC)THEN + IF(NK.EQ.LC)THEN + UMF(NK)=VMFLCL*DP(NK)/DPTHMX + UER(NK)=VMFLCL*DP(NK)/DPTHMX + !!ELSEIF(NK.LE.KPBL)THEN + ELSEIF(NK.LE.KCLDLAYER)THEN + UER(NK)=VMFLCL*DP(NK)/DPTHMX + UMF(NK)=UMF(NK-1)+UER(NK) + ELSE + UMF(NK)=VMFLCL + UER(NK)=0. + ENDIF + TU(NK)=TMIX+(Z0(NK)-ZMIX)*GDRY + QU(NK)=QMIX + WU(NK)=WLCL + ELSE + TU(NK)=0. + QU(NK)=0. + UMF(NK)=0. + WU(NK)=0. + UER(NK)=0. + ENDIF + UDR(NK)=0. + QDT(NK)=0. + QLIQ(NK)=0. + QICE(NK)=0. + QLQOUT(NK)=0. + QICOUT(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + RATIO2(NK)=0. + CALL ENVIRTHT(P0(NK),T0(NK),Q0(NK),THETEE(NK),ALIQ,BLIQ,CLIQ,DLIQ) + EQFRC(NK)=1.0 + ENDDO +! + LTOP1=LTOP+1 + LTOPM1=LTOP-1 +! +!...DEFINE VARIABLES ABOVE CLOUD TOP... +! + DO NK=LTOP1,KX + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + QDT(NK)=0. + QLIQ(NK)=0. + QICE(NK)=0. + QLQOUT(NK)=0. + QICOUT(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + !IF(NK.GT.LTOP1)THEN + IF(NK.GE.LTOP1)THEN !BSINGH(11/12/2014): So that wu, qu and tu has a value for NK==LTOP1 + TU(NK)=0. + QU(NK)=0. + WU(NK)=0. + ENDIF + THTA0(NK)=0. + THTAU(NK)=0. + EMS(NK)=0. + EMSD(NK)=0. + TG(NK)=T0(NK) + QG(NK)=Q0(NK) + QLG(NK)=0. + QIG(NK)=0. + QRG(NK)=0. + QSG(NK)=0. + OMG(NK)=0. + ENDDO + OMG(KX+1)=0. + +! rce 11-may-2012 mods start ------------------------------------------- +! calc droplet number (qndropbb) + if ( flag_chem ) then + do nk1 = klcl, ltop + nk = nk1 - 1 + if (nk1 == klcl) then +! calculate aerosol activatation at cloud base + tk_act = tu(nk1) + rho_act = p0(nk1)/(r*tu(nk1)*(1.+0.608*qu(nk1))) +! with cup, wlcl can be 0.0, so use wu(k+1) when wlcl is small + w_act = wlcl + if (wlcl < 0.1) w_act = max( w_act, wu(nk1) ) + +! effective w_act accounting for entrainment, from Barahona and Nenes (2007) eqn 14b +! +! w_act_effective = w_act * escale +! +! escale = 1 + (eBN/alphaBN) * [ (delHv*Mw /(Ru*T*T))*deltaT - deltaRH ] +! 1 + (eBN/alphaBN) * [ (delHv*ep2/(Ra*T*T))*deltaT - deltaRH ] +! +! eBN = entrainment rate = d[ln(updraft_mass_flux)]/dz +! alphaBN = [g*Mw *delHv/(cp*Ru*T*T)] - [g*Ma/(Ru*T)] +! = [g*ep2*delHv/(cp*Ra*T*T)] - [g /(Ra*T)] +! +! Mw, Ma = molecular weights of water and air ; ep2 = Mw/Ma +! delHv = latent heat of vaporization +! Ru = universal gas constant ; Ra = dry-air gas const +! deltaT = Tupdr - Tenv ; deltaRH = RHupdr - RHenv = 1 - RHenv + tmpa = max( umf(nk), 1.0e-10 ) + tmpb = max( uer(nk1), 0.0 ) + tmpe = tmpb/(tmpa+0.5*tmpb) + tmp_lv = xlv0 - xlv1*tk_act + tmp_deltatkfact = tmp_lv*ep2/(r*tk_act*tk_act) + tmp_alphabn = tmp_deltatkfact*g/cp - g/(r*tk_act) + tmp_ebn = tmpe/dzq(nk1) + tmp_deltatk = tk_act - t0(nk1) + tmp_deltarh = 1.0 - q0(nk1)/qu(nk1) + tmp_escale = 1.0 + (tmp_ebn/tmp_alphabn) * (tmp_deltatkfact*tmp_deltatk - tmp_deltarh) + w_act_eff = w_act + if (qndrop_cldbase_entrain_opt == 1) w_act_eff = w_act*tmp_escale + w_act_eff = max( w_act_eff, w_act_min ) + wact = w_act_eff + + if (idiagee > 0) then + write(98,'(//a,8i5)') 'kfcup bb activate_cldbase_kfcup - i, j, nu, kcheck, ksrc1/2', & + i, j, nu, kcheck(nu), lc, kcldlayer + write(98,'( a,3i11 )') 'nk1, klcl, k ', nk1, klcl, k + write(98,'( a,3i11 )') 'cldbase_entopt, incloud_entopt ', qndrop_cldbase_entrain_opt, qndrop_incloud_entrain_opt + write(98,'( a,1p,8e11.3)') 'wlcl, wu(nk1), w_act, _eff, _min ', wlcl, wu(nk1), w_act, w_act_eff, w_act_min + write(98,'( a,1p,8e11.3)') 'r, p, t, q, rho ', r, p0(nk1), tk_act, qu(nk1), rho_act + write(98,'( a,1p,8e11.3)') 'g, r, cp, ep2, xlv0, xlv1, tmp_lv ', g, r, cp, ep2, xlv0, xlv1, tmp_lv + write(98,'( a,1p,8e11.3)') 'tmpa/dx2, tmpb/dx2, tmpe ', tmpa/dxsq, tmpb/dxsq, tmpe + write(98,'( a,1p,8e11.3)') 'ebn, dzq(nk1), dz... ', tmp_ebn, dzq(nk1), z_at_w1d(nk1+1)-z_at_w1d(nk1) + write(98,'( a,1p,8e11.3)') 'deltarh, deltatk, deltatk*factor ', tmp_deltarh, tmp_deltatk, tmp_deltatk*tmp_deltatkfact + write(98,'( a,1p,8e11.3)') 'escale, alphabn, deltatkfact ', tmp_escale, tmp_alphabn, tmp_deltatkfact + end if + call activate_cldbase_kfcup( idiagee, grid_id, ktau, & + i, j, nk1, kts, kte, lc, kcldlayer, & + num_chem, maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ntype_aer, nsize_aer, ncomp_aer, & + ai_phase, msectional, massptr_aer, numptr_aer, & + dlo_sect, dhi_sect, dens_aer, hygro_aer, sigmag_aer, & + tk_act, rho_act, dp, w_act_eff, & + chem1d, qndrop_tmp ) + qndrop_tmp = qndrop_tmp + end if + +! calculate dilution from entrainment +! umf(nk) is flux at bottom of layer nk1 ; uer(nk1) is entrainment (delta-umf) in layer nk1 + tmpa = max( umf(nk), 1.0e-10 ) + tmpb = max( uer(nk1), 0.0 ) + if (qndrop_incloud_entrain_opt == 1) then +! qndrop at center of layer nk1 + qndropbb(nk1) = qndrop_tmp*(tmpa/(tmpa+0.5*tmpb)) +! qndrop at top of layer nk1 + qndrop_tmp = qndrop_tmp*(tmpa/(tmpa+tmpb)) + else + qndropbb(nk1) = qndrop_tmp + end if + if (idiagee > 0 .and. nk1 <= klcl+4) then + write(98,'( a,i3,1p,8e11.3)') 'nk1, tmpa/dx2, tmpb/dx2, qndrop', nk1, tmpa/dxsq, tmpb/dxsq, qndropbb(nk1) + end if + end do ! nk1 + if (idiagee > 0) write(98,'(a)') + end if ! ( flag_chem ) then +! rce 11-may-2012 mods end --------------------------------------------- + + DO NK=1,LTOP + EMS(NK)=DP(NK)*DXSQ/G + EMSD(NK)=1./EMS(NK) +! +!...INITIALIZE SOME VARIABLES TO BE USED LATER IN THE VERT ADVECTION SCH +! + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QDT(NK))) + THTAU(NK)=TU(NK)*EXN(NK) + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*Q0(NK))) + THTA0(NK)=T0(NK)*EXN(NK) + DDILFRC(NK) = 1./DILFRC(NK) + OMG(NK)=0. + ENDDO +! IF (XTIME.LT.10.)THEN +! WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, +! * TMIX-T00,PMIX,QMIX,ABE +! WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., +! * WLCL,CLDHGT +! ENDIF +! +!...COMPUTE CONVECTIVE TIME SCALE(TIMEC). THE MEAN WIND AT THE LCL +!...AND MIDTROPOSPHERE IS USED. +! + WSPD(KLCL)=SQRT(U0(KLCL)*U0(KLCL)+V0(KLCL)*V0(KLCL)) + WSPD(L5)=SQRT(U0(L5)*U0(L5)+V0(L5)*V0(L5)) + WSPD(LTOP)=SQRT(U0(LTOP)*U0(LTOP)+V0(LTOP)*V0(LTOP)) + VCONV=.5*(WSPD(KLCL)+WSPD(L5)) +!...for ETA model, DX is a function of location... +! TIMEC=DX(I,J)/VCONV + TIMEC=DX/VCONV + TADVEC=TIMEC + TIMEC=AMAX1(1800.,TIMEC) + TIMEC=AMIN1(3600.,TIMEC) + !!IF(ISHALL.EQ.1)TIMEC=2400. + IF(ISHALL.EQ.1)TIMEC=TIMEC_SHALL ! Reduced time constant, lkb 3/31/10 + NIC=NINT(TIMEC/DT) + TIMEC=FLOAT(NIC)*DT +! +!...COMPUTE WIND SHEAR AND PRECIPITATION EFFICIENCY. +! + IF(WSPD(LTOP).GT.WSPD(KLCL))THEN + SHSIGN=1. + ELSE + SHSIGN=-1. + ENDIF + VWS=(U0(LTOP)-U0(KLCL))*(U0(LTOP)-U0(KLCL))+(V0(LTOP)-V0(KLCL))* & + (V0(LTOP)-V0(KLCL)) + VWS=1.E3*SHSIGN*SQRT(VWS)/(Z0(LTOP)-Z0(LCL)) + PEF=1.591+VWS*(-.639+VWS*(9.53E-2-VWS*4.96E-3)) + PEF=AMAX1(PEF,.2) + PEF=AMIN1(PEF,.9) +! +!...PRECIPITATION EFFICIENCY IS A FUNCTION OF THE HEIGHT OF CLOUD BASE. +! + CBH=(ZLCL-Z0(1))*3.281E-3 + IF(CBH.LT.3.)THEN + RCBH=.02 + ELSE + RCBH=.96729352+CBH*(-.70034167+CBH*(.162179896+CBH*(- & + 1.2569798E-2+CBH*(4.2772E-4-CBH*5.44E-6)))) + ENDIF + IF(CBH.GT.25)RCBH=2.4 + PEFCBH=1./(1.+RCBH) + PEFCBH=AMIN1(PEFCBH,.9) +! +!... MEAN PEF. IS USED TO COMPUTE RAINFALL. +! + PEFF=.5*(PEF+PEFCBH) + PEFF2 = PEFF ! JSK MODS + IF(IPRNT)THEN + WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS +! flush(98) + endif +! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS +!***************************************************************** +! * +! COMPUTE DOWNDRAFT PROPERTIES * +! * +!***************************************************************** +! +! + TDER=0. + devap:IF(ISHALL.EQ.1)THEN + LFS = 1 + DMF(1:KX)=0. ! rce 11-may-2012 - zero these out to avoid problems + DER(1:KX)=0. ! with unit=98 diagnostic output + DDR(1:KX)=0. + WD(1:KX)=0. + TZ(1:KX)=0. + QD(1:KX)=0. + THTAD(1:KX)=0. + ELSE +! +!...start downdraft about 150 mb above cloud base... +! +! KSTART=MAX0(KPBL,KLCL) +! KSTART=KPBL ! Changed 7/23/99 + !!KSTART=KPBL+1 ! Changed 7/23/99 + KSTART=KCLDLAYER+1 ! Changed 7/23/99 + KLFS = LET-1 + DO NK = KSTART+1,KL + DPPP = P0(KSTART)-P0(NK) +! IF(DPPP.GT.200.E2)THEN + IF(DPPP.GT.150.E2)THEN + KLFS = NK + EXIT + ENDIF + ENDDO + KLFS = MIN0(KLFS,LET-1) + LFS = KLFS +! +!...if LFS is not at least 50 mb above cloud base (implying that the +!...level of equil temp, LET, is just above cloud base) do not allow a +!...downdraft... +! + IF((P0(KSTART)-P0(LFS)).GT.50.E2)THEN + THETED(LFS) = THETEE(LFS) + QD(LFS) = Q0(LFS) +! +!...call tpmix2dd to find wet-bulb temp, qv... +! + call tpmix2dd(p0(lfs),theted(lfs),tz(lfs),qss,i,j) + THTAD(LFS)=TZ(LFS)*(P00/P0(LFS))**(0.2854*(1.-0.28*QSS)) +! +!...TAKE A FIRST GUESS AT THE INITIAL DOWNDRAFT MASS FLUX... +! + TVD(LFS)=TZ(LFS)*(1.+0.608*QSS) + RDD=P0(LFS)/(R*TVD(LFS)) + A1=(1.-PEFF)*AU0 + DMF(LFS)=-A1*RDD + DER(LFS)=DMF(LFS) + DDR(LFS)=0. + RHBAR = RH(LFS)*DP(LFS) + DPTT = DP(LFS) + DO ND = LFS-1,KSTART,-1 + ND1 = ND+1 + DER(ND)=DER(LFS)*EMS(ND)/EMS(LFS) + DDR(ND)=0. + DMF(ND)=DMF(ND1)+DER(ND) + THETED(ND)=(THETED(ND1)*DMF(ND1)+THETEE(ND)*DER(ND))/DMF(ND) + QD(ND)=(QD(ND1)*DMF(ND1)+Q0(ND)*DER(ND))/DMF(ND) + DPTT = DPTT+DP(ND) + RHBAR = RHBAR+RH(ND)*DP(ND) + ENDDO + RHBAR = RHBAR/DPTT + DMFFRC = 2.*(1.-RHBAR) + DPDD = 0. +!...Calculate melting effect +!... first, compute total frozen precipitation generated... +! + pptmlt = 0. + DO NK = KLCL,LTOP + PPTMLT = PPTMLT+PPTICE(NK) + ENDDO + if(lc.lt.ml)then +!...For now, calculate melting effect as if DMF = -UMF at KLCL, i.e., as +!...if DMFFRC=1. Otherwise, for small DMFFRC, DTMELT gets too large! +!...12/14/98 jsk... + DTMELT = RLF*PPTMLT/(CP*UMF(KLCL)) + else + DTMELT = 0. + endif + LDT = MIN0(LFS-1,KSTART-1) +! + call tpmix2dd(p0(kstart),theted(kstart),tz(kstart),qss,i,j) +! + tz(kstart) = tz(kstart)-dtmelt + ES=ALIQ*EXP((BLIQ*TZ(KSTART)-CLIQ)/(TZ(KSTART)-DLIQ)) + QSS=0.622*ES/(P0(KSTART)-ES) + THETED(KSTART)=TZ(KSTART)*(1.E5/P0(KSTART))**(0.2854*(1.-0.28*QSS))* & + EXP((3374.6525/TZ(KSTART)-2.5403)*QSS*(1.+0.81*QSS)) +!.... + LDT = MIN0(LFS-1,KSTART-1) ! Determine the level to start at, + ! KSTART is level of PBL + DO ND = LDT,1,-1 + DPDD = DPDD+DP(ND) + THETED(ND) = THETED(KSTART) + QD(ND) = QD(KSTART) +! +!...call tpmix2dd to find wet bulb temp, saturation mixing ratio... +! + call tpmix2dd(p0(nd),theted(nd),tz(nd),qss,i,j) + qsd(nd) = qss +! +!...specify RH decrease of 20%/km in downdraft... +! + RHH = 1.-0.2/1000.*(Z0(KSTART)-Z0(ND)) +! +!...adjust downdraft TEMP, Q to specified RH: +! + IF(RHH.LT.1.)THEN + DSSDT=(CLIQ-BLIQ*DLIQ)/((TZ(ND)-DLIQ)*(TZ(ND)-DLIQ)) + RL=XLV0-XLV1*TZ(ND) + DTMP=RL*QSS*(1.-RHH)/(CP+RL*RHH*QSS*DSSDT) + T1RH=TZ(ND)+DTMP + ES=RHH*ALIQ*EXP((BLIQ*T1RH-CLIQ)/(T1RH-DLIQ)) ! Teten's equation to find Es + QSRH=0.622*ES/(P0(ND)-ES) ! Find the sat. mixing ratio +! +!...CHECK TO SEE IF MIXING RATIO AT SPECIFIED RH IS LESS THAN ACTUAL +!...MIXING RATIO...IF SO, ADJUST TO GIVE ZERO EVAPORATION... +! + IF(QSRH.LT.QD(ND))THEN + QSRH=QD(ND) + T1RH=TZ(ND)+(QSS-QSRH)*RL/CP + ENDIF + TZ(ND)=T1RH + QSS=QSRH + QSD(ND) = QSS + ENDIF + TVD(nd) = tz(nd)*(1.+0.608*qsd(nd)) + IF(TVD(ND).GT.TV0(ND).OR.ND.EQ.1)THEN + LDB=ND + EXIT + ENDIF + ENDDO + IF((P0(LDB)-P0(LFS)) .gt. 50.E2)THEN ! minimum Downdraft depth! + DO ND=LDT,LDB,-1 + ND1 = ND+1 + DDR(ND) = -DMF(KSTART)*DP(ND)/DPDD + DER(ND) = 0. + DMF(ND) = DMF(ND1)+DDR(ND) + TDER=TDER+(QSD(nd)-QD(ND))*DDR(ND) + QD(ND)=QSD(nd) + THTAD(ND)=TZ(ND)*(P00/P0(ND))**(0.2854*(1.-0.28*QD(ND))) + ENDDO + ENDIF + ENDIF + ENDIF devap +! +!...IF DOWNDRAFT DOES NOT EVAPORATE ANY WATER FOR SPECIFIED RELATIVE +!...HUMIDITY, NO DOWNDRAFT IS ALLOWED... +! +d_mf: IF(TDER.LT.1.)THEN +! WRITE(98,3004)I,J +!3004 FORMAT(' ','No Downdraft!; I=',I3,2X,'J=',I3,'ISHALL =',I2) + PPTFLX=TRPPT + CPR=TRPPT + TDER=0. + CNDTNF=0. + UPDINC=1. + LDB=LFS + DO NDK=1,LTOP + DMF(NDK)=0. + DER(NDK)=0. + DDR(NDK)=0. + THTAD(NDK)=0. + WD(NDK)=0. + TZ(NDK)=0. + QD(NDK)=0. + ENDDO + AINCM2=100. + ELSE + DDINC = -DMFFRC*UMF(KLCL)/DMF(KSTART) + UPDINC=1. + IF(TDER*DDINC.GT.TRPPT)THEN + DDINC = TRPPT/TDER + ENDIF + TDER = TDER*DDINC + DO NK=LDB,LFS + DMF(NK)=DMF(NK)*DDINC + DER(NK)=DER(NK)*DDINC + DDR(NK)=DDR(NK)*DDINC + ENDDO + CPR=TRPPT + PPTFLX = TRPPT-TDER + PEFF=PPTFLX/TRPPT + IF(IPRNT)THEN + write(98,*)'PRECIP EFFICIENCY =',PEFF +! flush(98) + ENDIF +! +! +!...ADJUST UPDRAFT MASS FLUX, MASS DETRAINMENT RATE, AND LIQUID WATER AN +! DETRAINMENT RATES TO BE CONSISTENT WITH THE TRANSFER OF THE ESTIMATE +! FROM THE UPDRAFT TO THE DOWNDRAFT AT THE LFS... +! +! DO NK=LC,LFS +! UMF(NK)=UMF(NK)*UPDINC +! UDR(NK)=UDR(NK)*UPDINC +! UER(NK)=UER(NK)*UPDINC +! PPTLIQ(NK)=PPTLIQ(NK)*UPDINC +! PPTICE(NK)=PPTICE(NK)*UPDINC +! DETLQ(NK)=DETLQ(NK)*UPDINC +! DETIC(NK)=DETIC(NK)*UPDINC +! ENDDO +! +!...ZERO OUT THE ARRAYS FOR DOWNDRAFT DATA AT LEVELS ABOVE AND BELOW THE +!...DOWNDRAFT... +! + IF(LDB.GT.1)THEN + DO NK=1,LDB-1 + DMF(NK)=0. + DER(NK)=0. + DDR(NK)=0. + WD(NK)=0. + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + ENDIF + DO NK=LFS+1,KX + DMF(NK)=0. + DER(NK)=0. + DDR(NK)=0. + WD(NK)=0. + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + DO NK=LDT+1,LFS-1 + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + ENDIF d_mf +! +!...SET LIMITS ON THE UPDRAFT AND DOWNDRAFT MASS FLUXES SO THAT THE INFL +! INTO CONVECTIVE DRAFTS FROM A GIVEN LAYER IS NO MORE THAN IS AVAILAB +! IN THAT LAYER INITIALLY... +! + AINCMX=1000. + LMAX=MAX0(KLCL,LFS) + DO NK=LC,LMAX + !IF((UER(NK)-DER(NK)).GT.1.e-3)THEN + IF((UER(NK)-DER(NK)).GT.1.e-5)THEN + AINCM1=EMS(NK)/((UER(NK)-DER(NK))*TIMEC) + !write(*,*) 'Larry... LMAX ', LMAX, LC, UER(NK), DER(NK) + AINCMX=AMIN1(AINCMX,AINCM1) + ENDIF + ENDDO + AINC=1. + IF(AINCMX.LT.AINC)AINC=AINCMX +! +!...SAVE THE RELEVENT VARIABLES FOR A UNIT UPDRAFT AND DOWNDRAFT...THEY WILL +!...BE ITERATIVELY ADJUSTED BY THE FACTOR AINC TO SATISFY THE STABILIZATION +!...CLOSURE... +! + TDER2=TDER + PPTFL2=PPTFLX + DO NK=1,LTOP + DETLQ2(NK)=DETLQ(NK) + DETIC2(NK)=DETIC(NK) + UDR2(NK)=UDR(NK) + UER2(NK)=UER(NK) + DDR2(NK)=DDR(NK) + DER2(NK)=DER(NK) + UMF2(NK)=UMF(NK) + DMF2(NK)=DMF(NK) + ENDDO + FABE=1. + STAB=0.95 + NOITR=0 + ISTOP=0 +! + IF(ISHALL.EQ.1)THEN ! First for shallow convection +! +! No iteration for shallow convection; if turbulent kinetic energy (TKE) is available +! from a turbulence parameterization, scale cloud-base updraft mass flux as a function +! of TKE, but for now, just specify shallow-cloud mass flux using TKEMAX = 5... +! +!...find the maximum TKE value between LC and KLCL... +! TKEMAX = 0. + TKEMAX = 5. + !!TKEMAX = 10. +! DO 173 K = LC,KLCL +! NK = KX-K+1 +! TKEMAX = AMAX1(TKEMAX,Q2(I,J,NK)) +! 173 CONTINUE +! TKEMAX = AMIN1(TKEMAX,10.) +! TKEMAX = AMAX1(TKEMAX,5.) +!c TKEMAX = 10. +!c...3_24_99...DPMIN was changed for shallow convection so that it is the +!c... the same as for deep convection (5.E3). Since this doubles +!c... (roughly) the value of DPTHMX, add a factor of 0.5 to calcu- +!c... lation of EVAC... +!c EVAC = TKEMAX*0.1 + EVAC = 0.5*TKEMAX*0.1 + !!EVAC = 0.5*TKEMAX*0.1*freq +! AINC = 0.1*DPTHMX*DXIJ*DXIJ/(VMFLCL*G*TIMEC) + !!AINC = EVAC*DPTHMX*DX(I,J)*DX(I,J)/(VMFLCL*G*TIMEC) + !!AINC = EVAC*DPTHMX*DXSQ/(VMFLCL*G*TIMEC) + AINC = EVAC*DPTHMX*DXSQ/(VMFLCL*G*TIMEC) * freq * 2.0 ! Use factor of two becuase only 1/2 of pdf would be expected to rise + !!write(*,*) 'Larry ... old AINC ', AINC + !!AINC = WLCL*freq*DXSQ*RHOLCL/(VMFLCL) ! This version uses mass flux from CuP + !!AINC = 1 + + TDER=TDER2*AINC + PPTFLX=PPTFL2*AINC + DO NK=1,LTOP + UMF(NK)=UMF2(NK)*AINC + DMF(NK)=DMF2(NK)*AINC + DETLQ(NK)=DETLQ2(NK)*AINC + DETIC(NK)=DETIC2(NK)*AINC + UDR(NK)=UDR2(NK)*AINC + UER(NK)=UER2(NK)*AINC + DER(NK)=DER2(NK)*AINC + DDR(NK)=DDR2(NK)*AINC + ENDDO + ENDIF ! Otherwise for deep convection +! use iterative procedure to find mass fluxes... +iter: DO NCOUNT=1,10 +! +!***************************************************************** +! * +! COMPUTE PROPERTIES FOR COMPENSATIONAL SUBSIDENCE * +! * +!***************************************************************** +! +!...DETERMINE OMEGA VALUE NECESSARY AT TOP AND BOTTOM OF EACH LAYER TO +!...SATISFY MASS CONTINUITY... +! + DTT=TIMEC + DO NK=1,LTOP + DOMGDP(NK)=-(UER(NK)-DER(NK)-UDR(NK)-DDR(NK))*EMSD(NK) + IF(NK.GT.1)THEN + OMG(NK)=OMG(NK-1)-DP(NK-1)*DOMGDP(NK-1) + ABSOMG = ABS(OMG(NK)) + ABSOMGTC = ABSOMG*TIMEC + FRDP = 0.75*DP(NK-1) + IF(ABSOMGTC.GT.FRDP)THEN + DTT1 = FRDP/ABSOMG + DTT=AMIN1(DTT,DTT1) + ENDIF + ENDIF + ENDDO + DO NK=1,LTOP + THPA(NK)=THTA0(NK) + QPA(NK)=Q0(NK) + NSTEP=NINT(TIMEC/DTT+1) + DTIME=TIMEC/FLOAT(NSTEP) + FXM(NK)=OMG(NK)*DXSQ/G + ENDDO +! +!...DO AN UPSTREAM/FORWARD-IN-TIME ADVECTION OF THETA, QV... +! + DO NTC=1,NSTEP +! +!...ASSIGN THETA AND Q VALUES AT THE TOP AND BOTTOM OF EACH LAYER BASED +!...SIGN OF OMEGA... +! + DO NK=1,LTOP + THFXIN(NK)=0. + THFXOUT(NK)=0. + QFXIN(NK)=0. + QFXOUT(NK)=0. + ENDDO + DO NK=2,LTOP + IF(OMG(NK).LE.0.)THEN + THFXIN(NK)=-FXM(NK)*THPA(NK-1) + QFXIN(NK)=-FXM(NK)*QPA(NK-1) + THFXOUT(NK-1)=THFXOUT(NK-1)+THFXIN(NK) + QFXOUT(NK-1)=QFXOUT(NK-1)+QFXIN(NK) + ELSE + THFXOUT(NK)=FXM(NK)*THPA(NK) + QFXOUT(NK)=FXM(NK)*QPA(NK) + THFXIN(NK-1)=THFXIN(NK-1)+THFXOUT(NK) + QFXIN(NK-1)=QFXIN(NK-1)+QFXOUT(NK) + ENDIF + ENDDO +! +!...UPDATE THE THETA AND QV VALUES AT EACH LEVEL... +! + DO NK=1,LTOP + THPA(NK)=THPA(NK)+(THFXIN(NK)+UDR(NK)*THTAU(NK)+DDR(NK)* & + THTAD(NK)-THFXOUT(NK)-(UER(NK)-DER(NK))*THTA0(NK))* & + DTIME*EMSD(NK) + QPA(NK)=QPA(NK)+(QFXIN(NK)+UDR(NK)*QDT(NK)+DDR(NK)*QD(NK)- & + QFXOUT(NK)-(UER(NK)-DER(NK))*Q0(NK))*DTIME*EMSD(NK) + ENDDO + ENDDO + DO NK=1,LTOP + THTAG(NK)=THPA(NK) + QG(NK)=QPA(NK) + ENDDO +! +!...CHECK TO SEE IF MIXING RATIO DIPS BELOW ZERO ANYWHERE; IF SO, BORRO +!...MOISTURE FROM ADJACENT LAYERS TO BRING IT BACK UP ABOVE ZERO... +! + DO NK=1,LTOP + IF(QG(NK).LT.0.)THEN + IF(NK.EQ.1)THEN ! JSK MODS +! PRINT *,' PROBLEM WITH KF SCHEME: ' ! JSK MODS +! PRINT *,'QG = 0 AT THE SURFACE!!!!!!!' ! JSK MODS + CALL wrf_error_fatal ( 'QG, QG(NK).LT.0') ! JSK MODS + ENDIF ! JSK MODS + NK1=NK+1 + IF(NK.EQ.LTOP)THEN + NK1=KLCL + ENDIF + TMA=QG(NK1)*EMS(NK1) + TMB=QG(NK-1)*EMS(NK-1) + TMM=(QG(NK)-1.E-9)*EMS(NK ) + BCOEFF=-TMM/((TMA*TMA)/TMB+TMB) + ACOEFF=BCOEFF*TMA/TMB + TMB=TMB*(1.-BCOEFF) + TMA=TMA*(1.-ACOEFF) + IF(NK.EQ.LTOP)THEN + QVDIFF=(QG(NK1)-TMA*EMSD(NK1))*100./QG(NK1) +! IF(ABS(QVDIFF).GT.1.)THEN +! PRINT *,'!!!WARNING!!! CLOUD BASE WATER VAPOR CHANGES BY ', & +! QVDIFF, & +! '% WHEN MOISTURE IS BORROWED TO PREVENT NEGATIVE ', & +! 'VALUES IN KAIN-FRITSCH' +! ENDIF + ENDIF + QG(NK)=1.E-9 + QG(NK1)=TMA*EMSD(NK1) + QG(NK-1)=TMB*EMSD(NK-1) + ENDIF + ENDDO + TOPOMG=(UDR(LTOP)-UER(LTOP))*DP(LTOP)*EMSD(LTOP) + IF(ABS(TOPOMG-OMG(LTOP)).GT.1.E-3)THEN +! WRITE(99,*)'ERROR: MASS DOES NOT BALANCE IN KF SCHEME; & +! TOPOMG, OMG =',TOPOMG,OMG(LTOP) +! TOPOMG, OMG =',TOPOMG,OMG(LTOP) + ISTOP=1 + IPRNT=.TRUE. + EXIT iter + ENDIF +! +!...CONVERT THETA TO T... +! + DO NK=1,LTOP + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QG(NK))) + TG(NK)=THTAG(NK)/EXN(NK) + TVG(NK)=TG(NK)*(1.+0.608*QG(NK)) + ENDDO + IF(ISHALL.EQ.1)THEN +! write(*,*) 'Larry, exiting iter ',NCOUNT + if (idiagee > 0) write(*,*) 'Larry, exiting iter - ncount,i,j',NCOUNT, I, J ! rce 11-may-2012 + EXIT iter +! write(*,*) 'Larry, exited, no more iter' + ENDIF +! +!******************************************************************* +! * +! COMPUTE NEW CLOUD AND CHANGE IN AVAILABLE BUOYANT ENERGY. * +! * +!******************************************************************* +! +!...THE FOLLOWING COMPUTATIONS ARE SIMILAR TO THAT FOR UPDRAFT +! +! THMIX=0. + TMIX=0. + QMIX=0. +! +!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY +!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL +!...LAYERS... +! + !!DO NK=LC,KPBL + DO NK=LC,KCLDLAYER + TMIX=TMIX+DP(NK)*TG(NK) + QMIX=QMIX+DP(NK)*QG(NK) + ENDDO + TMIX=TMIX/DPTHMX + QMIX=QMIX/DPTHMX + ES=ALIQ*EXP((TMIX*BLIQ-CLIQ)/(TMIX-DLIQ)) + QSS=0.622*ES/(PMIX-ES) +! +!...REMOVE SUPERSATURATION FOR DIAGNOSTIC PURPOSES, IF NECESSARY... +! + IF(QMIX.GT.QSS)THEN + RL=XLV0-XLV1*TMIX + CPM=CP*(1.+0.887*QMIX) + DSSDT=QSS*(CLIQ-BLIQ*DLIQ)/((TMIX-DLIQ)*(TMIX-DLIQ)) + DQ=(QMIX-QSS)/(1.+RL*DSSDT/CPM) + TMIX=TMIX+RL/CP*DQ + QMIX=QMIX-DQ + TLCL=TMIX + ELSE + QMIX=AMAX1(QMIX,0.) + EMIX=QMIX*PMIX/(0.622+QMIX) + astrt=1.e-3 + binc=0.075 + a1=emix/aliq + tp=(a1-astrt)/binc + indlu=int(tp)+1 + value=(indlu-1)*binc+astrt + aintrp=(a1-value)/binc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT) + TLCL=AMIN1(TLCL,TMIX) + ENDIF + TVLCL=TLCL*(1.+0.608*QMIX) + ZLCL = ZMIX+(TLCL-TMIX)/GDRY + DO NK = LC,KL + KLCL=NK + IF(ZLCL.LE.Z0(NK))THEN + EXIT + ENDIF + ENDDO + K=KLCL-1 + DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K)) +! +!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... +! + TENV=TG(K)+(TG(KLCL)-TG(K))*DLP + QENV=QG(K)+(QG(KLCL)-QG(K))*DLP + TVEN=TENV*(1.+0.608*QENV) + PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP + THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* & + EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX)) +! +!...COMPUTE ADJUSTED ABE(ABEG). +! + ABEG=0. + DO NK=K,LTOPM1 + NK1=NK+1 + THETEU(NK1) = THETEU(NK) +! + call tpmix2dd(p0(nk1),theteu(nk1),tgu(nk1),qgu(nk1),i,j) +! + TVQU(NK1)=TGU(NK1)*(1.+0.608*QGU(NK1)-QLIQ(NK1)-QICE(NK1)) + IF(NK.EQ.K)THEN + DZZ=Z0(KLCL)-ZLCL + DILBE=((TVLCL+TVQU(NK1))/(TVEN+TVG(NK1))-1.)*DZZ + ELSE + DZZ=DZA(NK) + DILBE=((TVQU(NK)+TVQU(NK1))/(TVG(NK)+TVG(NK1))-1.)*DZZ + ENDIF + IF(DILBE.GT.0.)ABEG=ABEG+DILBE*G +! +!...DILUTE BY ENTRAINMENT BY THE RATE AS ORIGINAL UPDRAFT... +! + CALL ENVIRTHT(P0(NK1),TG(NK1),QG(NK1),THTEEG(NK1),ALIQ,BLIQ,CLIQ,DLIQ) + THETEU(NK1)=THETEU(NK1)*DDILFRC(NK1)+THTEEG(NK1)*(1.-DDILFRC(NK1)) + ENDDO +! +!...ASSUME AT LEAST 90% OF CAPE (ABE) IS REMOVED BY CONVECTION DURING +!...THE PERIOD TIMEC... +! + IF(NOITR.EQ.1)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1060)FABE +! GOTO 265 + EXIT iter + ENDIF + DABE=AMAX1(ABE-ABEG,0.1*ABE) + FABE=ABEG/ABE + IF(FABE.GT.1. .and. ISHALL.EQ.0)THEN +! WRITE(98,*)'UPDRAFT/DOWNDRAFT COUPLET INCREASES CAPE AT THIS +! *GRID POINT; NO CONVECTION ALLOWED!' +! wig, 29-Aug-2006: Indicate no convection occurred. + ishall = 2 + RETURN + ENDIF + IF(NCOUNT.NE.1)THEN + IF(ABS(AINC-AINCOLD).LT.0.0001)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ENDIF + DFDA=(FABE-FABEOLD)/(AINC-AINCOLD) + IF(DFDA.GT.0.)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ENDIF + ENDIF + AINCOLD=AINC + FABEOLD=FABE + IF(AINC/AINCMX.GT.0.999.AND.FABE.GT.1.05-STAB)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1055)FABE +! GOTO 265 + EXIT + ENDIF +! If there are shallow clouds, relax 90% requiremnt +! This code is not needed, exit out of shallow cu happens earlier + !!IF(ISHALL .EQ. 1) THEN + !! EXIT iter + IF((FABE.LE.1.05-STAB.AND.FABE.GE.0.95-STAB) .or. NCOUNT.EQ.10)THEN + EXIT iter + ELSE + IF(NCOUNT.GT.10)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1060)FABE +! GOTO 265 + EXIT + ENDIF +! +!...IF MORE THAN 10% OF THE ORIGINAL CAPE REMAINS, INCREASE THE CONVECTI +!...MASS FLUX BY THE FACTOR AINC: +! + IF(FABE.EQ.0.)THEN + AINC=AINC*0.5 + ELSE + IF(DABE.LT.1.e-4)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ELSE + AINC=AINC*STAB*ABE/DABE + ENDIF + ENDIF +! AINC=AMIN1(AINCMX,AINC) + AINC=AMIN1(AINCMX,AINC) +!...IF AINC BECOMES VERY SMALL, EFFECTS OF CONVECTION ! JSK MODS +!...WILL BE MINIMAL SO JUST IGNORE IT... ! JSK MODS + IF(AINC.LT.0.05)then +! wig, 29-Aug-2006: Indicate no convection occurred. + ishall = 2 + RETURN ! JSK MODS + ENDIF +! AINC=AMAX1(AINC,0.05) ! JSK MODS + TDER=TDER2*AINC + PPTFLX=PPTFL2*AINC +! IF (XTIME.LT.10.)THEN +! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT, +! * FABEOLD,AINCOLD +! ENDIF + DO NK=1,LTOP + UMF(NK)=UMF2(NK)*AINC + DMF(NK)=DMF2(NK)*AINC + DETLQ(NK)=DETLQ2(NK)*AINC + DETIC(NK)=DETIC2(NK)*AINC + UDR(NK)=UDR2(NK)*AINC + UER(NK)=UER2(NK)*AINC + DER(NK)=DER2(NK)*AINC + DDR(NK)=DDR2(NK)*AINC + ENDDO +! +!...GO BACK UP FOR ANOTHER ITERATION... +! + ENDIF + ENDDO iter +! +!...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV... +! +!...FRC2 IS THE FRACTION OF TOTAL CONDENSATE ! PPT FB MODS +!...GENERATED THAT GOES INTO PRECIPITIATION ! PPT FB MODS +! +! Redistribute hydormeteors according to the final mass-flux values: +! + IF(CPR.GT.0.)THEN + FRC2=PPTFLX/(CPR*AINC) ! PPT FB MODS + ELSE + FRC2=0. + ENDIF + DO NK=1,LTOP + QLPA(NK)=QL0(NK) + QIPA(NK)=QI0(NK) + QRPA(NK)=QR0(NK) + QSPA(NK)=QS0(NK) + RAINFB(NK)=PPTLIQ(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS + SNOWFB(NK)=PPTICE(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS + ENDDO + DO NTC=1,NSTEP +! +!...ASSIGN HYDROMETEORS CONCENTRATIONS AT THE TOP AND BOTTOM OF EACH LAY +!...BASED ON THE SIGN OF OMEGA... +! + DO NK=1,LTOP + QLFXIN(NK)=0. + QLFXOUT(NK)=0. + QIFXIN(NK)=0. + QIFXOUT(NK)=0. + QRFXIN(NK)=0. + QRFXOUT(NK)=0. + QSFXIN(NK)=0. + QSFXOUT(NK)=0. + ENDDO + DO NK=2,LTOP + IF(OMG(NK).LE.0.)THEN + QLFXIN(NK)=-FXM(NK)*QLPA(NK-1) + QIFXIN(NK)=-FXM(NK)*QIPA(NK-1) + QRFXIN(NK)=-FXM(NK)*QRPA(NK-1) + QSFXIN(NK)=-FXM(NK)*QSPA(NK-1) + QLFXOUT(NK-1)=QLFXOUT(NK-1)+QLFXIN(NK) + QIFXOUT(NK-1)=QIFXOUT(NK-1)+QIFXIN(NK) + QRFXOUT(NK-1)=QRFXOUT(NK-1)+QRFXIN(NK) + QSFXOUT(NK-1)=QSFXOUT(NK-1)+QSFXIN(NK) + ELSE + QLFXOUT(NK)=FXM(NK)*QLPA(NK) + QIFXOUT(NK)=FXM(NK)*QIPA(NK) + QRFXOUT(NK)=FXM(NK)*QRPA(NK) + QSFXOUT(NK)=FXM(NK)*QSPA(NK) + QLFXIN(NK-1)=QLFXIN(NK-1)+QLFXOUT(NK) + QIFXIN(NK-1)=QIFXIN(NK-1)+QIFXOUT(NK) + QRFXIN(NK-1)=QRFXIN(NK-1)+QRFXOUT(NK) + QSFXIN(NK-1)=QSFXIN(NK-1)+QSFXOUT(NK) + ENDIF + ENDDO +! +!...UPDATE THE HYDROMETEOR CONCENTRATION VALUES AT EACH LEVEL... +! + DO NK=1,LTOP + QLPA(NK)=QLPA(NK)+(QLFXIN(NK)+DETLQ(NK)-QLFXOUT(NK))*DTIME*EMSD(NK) + QIPA(NK)=QIPA(NK)+(QIFXIN(NK)+DETIC(NK)-QIFXOUT(NK))*DTIME*EMSD(NK) + QRPA(NK)=QRPA(NK)+(QRFXIN(NK)-QRFXOUT(NK)+RAINFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS + QSPA(NK)=QSPA(NK)+(QSFXIN(NK)-QSFXOUT(NK)+SNOWFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS + ENDDO + ENDDO + DO NK=1,LTOP + QLG(NK)=QLPA(NK) + QIG(NK)=QIPA(NK) + QRG(NK)=QRPA(NK) + QSG(NK)=QSPA(NK) + ENDDO +! +!...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS +!...GRID POINT... +! +! IF (XTIME.LT.10.)THEN +! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC +! ENDIF + IF(IPRNT)THEN + WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC +! flush(98) + endif +! +!...SEND FINAL PARAMETERIZED VALUES TO OUTPUT FILES... +! +!297 IF(IPRNT)then + IF(IPRNT)then +! if(I.eq.16 .and. J.eq.41)then +! IF(ISTOP.EQ.1)THEN + write(98,*) +! write(98,*)'At t(h), I, J =',float(NTSD)*72./3600.,I,J + write(98,*)'P(LC), DTP, WKL, WKLCL =',p0(LC)/100., & + TLCL+DTLCL+dtrh-TENV,WKL,WKLCL + write(98,*)'TLCL, DTLCL, DTRH, TENV =',TLCL,DTLCL, & + DTRH,TENV + WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, & + TMIX-T00,PMIX,QMIX,ABE + WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., & + WLCL,CLDHGT(LC) + WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS + write(98,*)'PRECIP EFFICIENCY =',PEFF + WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC +! ENDIF +!!!!! HERE !!!!!!! + WRITE(98,1070)' P ',' DP ',' DT K/D ',' DR K/D ', & + ' OMG ',' DOMGDP ',' UMF ',' UER ', & + ' UDR ',' DMF ',' DER ' ,' DDR ',& + ' EMS ',' W0 ',' DETLQ ',' DETIC ' + write(98,*)'just before DO 300...' +! flush(98) + DO NK=1,LTOP + K=LTOP-NK+1 + DTT=(TG(K)-T0(K))*86400./TIMEC + RL=XLV0-XLV1*TG(K) + DR=-(QG(K)-Q0(K))*RL*86400./(TIMEC*CP) + UDFRC=UDR(K)*TIMEC*EMSD(K) + UEFRC=UER(K)*TIMEC*EMSD(K) + DDFRC=DDR(K)*TIMEC*EMSD(K) + DEFRC=-DER(K)*TIMEC*EMSD(K) + WRITE(98,1075)P0(K)/100.,DP(K)/100.,DTT,DR,OMG(K),DOMGDP(K)*1.E4, & + UMF(K)/1.E6,UEFRC,UDFRC,DMF(K)/1.E6,DEFRC,DDFRC,EMS(K)/1.E11, & + W0AVG1D(K)*1.E2,DETLQ(K)*TIMEC*EMSD(K)*1.E3,DETIC(K)* & + TIMEC*EMSD(K)*1.E3 + ENDDO + +! rce 11-may-2012 mods start ------------------------------------------- + if (idiagee > 0) then + write(98,'(/31x,3x,15a11)') 'umf/aeai', 'uer/aeai', 'umf/ae', 'uer/ae' + do k = klcl-2, ltop+2 + if (k >= kte) cycle + if (k < kts) cycle + write(98,'(31x,i3,1p,15e11.3)') k, umf(k)/(dxsq*ainc), uer(k)/(dxsq*ainc), umf(k)/dxsq, uer(k)/dxsq + end do + + write(98,'(/a,1p,15i11 )') 'lc, kcldx, klcl, ksvaa, let, ltop', lc, kcldlayer, klcl, ksvaa, let, ltop + write(98,'( a,1p,15e11.3)') 'dt, timec, dx, ae=dxsq, au0, ainc', dt, timec, dx, dxsq, au0, ainc + write(98,'(a,1p,15e11.3 )') 'au0/ae, au0*ainc/ae ', au0/dxsq, au0*ainc/dxsq + write(98,'(a,1p,15e11.3 )') 'vmflcl/ae, vmflcl*ainc/ae ', vmflcl/dxsq, vmflcl*ainc/dxsq + write(98,'(a,1p,15e11.3 )') 'evac, freq, timec, tmp1 / 2 / 3 ', & + evac, freq, timec, (dpthmx/g), (dpthmx/g)*(2.0*evac*freq), (vmflcl*ainc/dxsq)*timec + write(98,'(a,1p,15e11.3 )') 'wlcl, wu(klcl), tpert, rpert ', wlcl, wu(klcl), th_perturb,r_perturb + write(98,'( a,1p,15e11.3)') 'tmpc = (umf/ae)/(wu*rho) tmpd = umf/(wu*rho*au0*ainc)' + write(98,'(3x,15a11)') 'p0', 'dp', 'omg/g', 'umf/ae', 'del-umf', 'uer-udr', 'uer/ae', 'udr/ae', 'wu', 'tmpc', 'tmpd', 'ems' + do k = ltop+2, 1, -1 + if (k >= kte) cycle + tmpa = 0.0 ; tmpb = 0.0 ; tmpc = 0.0 ; tmpd = 0.0 + if (k > 1 .and. k < ltop) tmpa = (umf(k)-umf(k-1))/dxsq + if (k == ltop) tmpa = (0.0 -umf(k-1))/dxsq + tmpb = (uer(k)-udr(k))/dxsq + if (wu(k) > 1.0e-3) tmpc = umf(k)/(wu(k)*rhoe(k)*dxsq) + if (wu(k) > 1.0e-3) tmpd = umf(k)/(wu(k)*rhoe(k)*au0*ainc) + write(98,'(i3,1p,15e11.3)') k, p0(k), dp(k), omg(k)/g, umf(k)/dxsq, tmpa, tmpb, uer(k)/dxsq, udr(k)/dxsq, wu(k), tmpc, tmpd, ems(k) + end do + + write(98,'(/3x,15a11)') 't0', 'p0', 'dp', 'q0', 'qg', 'qu', 'qliq', 'qlg', 'qice', 'qig', 'qndropbb' + do k = ltop, 1, -1 + write(98,'(i3,f11.2,1p,15e11.3)') k, t0(k)-t00, p0(k), dp(k), q0(k), qg(k), qu(k), qliq(k), qlg(k), qice(k), qig(k), & + qndropbb(k) + end do + write(98,'(a)') + end if +! rce 11-may-2012 mods end --------------------------------------------- + + WRITE(98,1085)'K','P','Z','T0','TG','DT','TU','TD','Q0', & + 'QG', & + 'DQ','QU','QD','QLG','QIG','QRG','QSG','RH0','RHG' + DO NK=1,KL + K=KX-NK+1 + DTT=TG(K)-T0(K) + TUC=TU(K)-T00 + IF(K.LT.LC.OR.K.GT.LTOP)TUC=0. + TDC=TZ(K)-T00 + IF((K.LT.LDB.OR.K.GT.LDT).AND.K.NE.LFS)TDC=0. + IF(T0(K).LT.T00)THEN + ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) + ELSE + ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) + ENDIF + QGS=ES*0.622/(P0(K)-ES) + RH0=Q0(K)/QES(K) + RHG=QG(K)/QGS + WRITE(98,1090)K,P0(K)/100.,Z0(K),T0(K)-T00,TG(K)-T00,DTT,TUC, & + TDC,Q0(K)*1000.,QG(K)*1000.,(QG(K)-Q0(K))*1000.,QU(K)* & + 1000.,QD(K)*1000.,QLG(K)*1000.,QIG(K)*1000.,QRG(K)*1000., & + QSG(K)*1000.,RH0,RHG + ENDDO +! +!...IF CALCULATIONS ABOVE SHOW AN ERROR IN THE MASS BUDGET, PRINT OUT A +!...TO BE USED LATER FOR DIAGNOSTIC PURPOSES, THEN ABORT RUN... +! +! IF(ISTOP.EQ.1 .or. ISHALL.EQ.1)THEN + +! IF(ISHALL.NE.1)THEN +! write(98,4421)i,j,iyr,imo,idy,ihr,imn +! write(98)i,j,iyr,imo,idy,ihr,imn,kl +! 4421 format(7i4) +! write(98,4422)kl +! 4422 format(i6) + write(98,'(8a11)') 'p0', 't0', 'q0', 'u0', 'v0', 'w0avg1d', 'dp', 'tke' ! rce 11-may-2012 + DO 310 NK = 1,KL + k = kl - nk + 1 + write(98,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., & + u0(k),v0(k),W0AVG1D(K),dp(k),tke(k) +! write(98) p0,t0,q0,u0,v0,w0,dp,tke +! WRITE(98,1115)Z0(K),P0(K)/100.,T0(K)-273.16,Q0(K)*1000., +! * U0(K),V0(K),DP(K)/100.,W0AVG(I,J,K) + 310 CONTINUE + IF(ISTOP.EQ.1)THEN + CALL wrf_error_fatal ( 'KAIN-FRITSCH, istop=1, diags' ) + ENDIF +! ENDIF + 4455 format(8f11.3) + ENDIF + CNDTNF=(1.-EQFRC(LFS))*(QLIQ(LFS)+QICE(LFS))*DMF(LFS) + RAINCV(I,J)=DT*PPTFLX*(1.-FBFRC)/DXSQ ! PPT FB MODS +! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS +! RNC=0.1*TIMEC*PPTFLX/DXSQ + RNC=RAINCV(I,J)*NIC + IF(ISHALL.EQ.0.AND.IPRNT)write (98,909)I,J,RNC + +! WRITE(98,1095)CPR*AINC,TDER+PPTFLX+CNDTNF +! +! EVALUATE MOISTURE BUDGET... +! + + QINIT=0. + QFNL=0. + DPT=0. + DO 315 NK=1,LTOP + DPT=DPT+DP(NK) + QINIT=QINIT+Q0(NK)*EMS(NK) + QFNL=QFNL+QG(NK)*EMS(NK) + QFNL=QFNL+(QLG(NK)+QIG(NK)+QRG(NK)+QSG(NK))*EMS(NK) + 315 CONTINUE + QFNL=QFNL+PPTFLX*TIMEC*(1.-FBFRC) ! PPT FB MODS +! QFNL=QFNL+PPTFLX*TIMEC ! PPT FB MODS + ERR2=(QFNL-QINIT)*100./QINIT + IF(IPRNT)WRITE(98,1110)QINIT,QFNL,ERR2 + IF(ABS(ERR2).GT.0.05 .AND. ISTOP.EQ.0)THEN +! write(99,*)'!!!!!!!! MOISTURE BUDGET ERROR IN KFPARA !!!' +! WRITE(99,1110)QINIT,QFNL,ERR2 + IPRNT=.TRUE. + ISTOP=1 + write(98,4422)kl + 4422 format(i6) + DO 311 NK = 1,KL + k = kl - nk + 1 +! write(99,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., & +! u0(k),v0(k),W0AVG1D(K),dp(k) +! write(98) p0,t0,q0,u0,v0,w0,dp,tke +! WRITE(98,1115)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & +! U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k) + WRITE(98,4456)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & + U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k) + 311 CONTINUE +! flush(98) + +! GOTO 297 +! STOP 'QVERR' + ENDIF + 1115 FORMAT (2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4) + 4456 format(8f12.3) + IF(PPTFLX.GT.0.)THEN + RELERR=ERR2*QINIT/(PPTFLX*TIMEC) + ELSE + RELERR=0. + ENDIF + IF(IPRNT)THEN + WRITE(98,1120)RELERR + WRITE(98,*)'TDER, CPR, TRPPT =', & + TDER,CPR*AINC,TRPPT*AINC + ENDIF +! +!...FEEDBACK TO RESOLVABLE SCALE TENDENCIES. +! +!...IF THE ADVECTIVE TIME PERIOD (TADVEC) IS LESS THAN SPECIFIED MINIMUM +!...TIMEC, ALLOW FEEDBACK TO OCCUR ONLY DURING TADVEC... +! + IF(TADVEC.LT.TIMEC)NIC=NINT(TADVEC/DT) + NCA(I,J)=REAL(NIC)*DT !byang + IF(ISHALL.EQ.1)THEN + TIMEC = TIMEC_SHALL !! Changed to match other location where TIMEC is set lkb 10/31/10 + !!TIMEC = 2400. + NCA(I,J) = NINT(TIMEC_SHALL/DT)*DT ! add 01/11/2012 +! NCA(I,J) = NTST*DT !byang + NSHALL = NSHALL+1 + ENDIF + DO K=1,KX +! IF(IMOIST(INEST).NE.2)THEN +! +!...IF HYDROMETEORS ARE NOT ALLOWED, THEY MUST BE EVAPORATED OR SUBLIMAT +!...AND FED BACK AS VAPOR, ALONG WITH ASSOCIATED CHANGES IN TEMPERATURE. +!...NOTE: THIS WILL INTRODUCE CHANGES IN THE CONVECTIVE TEMPERATURE AND +!...WATER VAPOR FEEDBACK TENDENCIES AND MAY LEAD TO SUPERSATURATED VALUE +!...OF QG... +! +! RLC=XLV0-XLV1*TG(K) +! RLS=XLS0-XLS1*TG(K) +! CPM=CP*(1.+0.887*QG(K)) +! TG(K)=TG(K)-(RLC*(QLG(K)+QRG(K))+RLS*(QIG(K)+QSG(K)))/CPM +! QG(K)=QG(K)+(QLG(K)+QRG(K)+QIG(K)+QSG(K)) +! DQLDT(I,J,NK)=0. +! DQIDT(I,J,NK)=0. +! DQRDT(I,J,NK)=0. +! DQSDT(I,J,NK)=0. +! ELSE +! +!...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS... +! + IF(.NOT. F_QI .and. warm_rain)THEN + + CPM=CP*(1.+0.887*QG(K)) + TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM + DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC + DQIDT(K)=0. + DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC + DQSDT(K)=0. + ELSEIF(.NOT. F_QI .and. .not. warm_rain)THEN +! +!...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROME +!...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL +! + CPM=CP*(1.+0.887*QG(K)) + IF(K.LE.ML)THEN + TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM + ELSEIF(K.GT.ML)THEN + TG(K)=TG(K)+(QLG(K)+QRG(K))*RLF/CPM + ENDIF + DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC + DQIDT(K)=0. + DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC + DQSDT(K)=0. + ELSEIF(F_QI) THEN +! +!...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE TENDEN +!...OF HYDROMETEORS DIRECTLY... +! + DQCDT(K)=(QLG(K)-QL0(K))/TIMEC + DQIDT(K)=(QIG(K)-QI0(K))/TIMEC + DQRDT(K)=(QRG(K)-QR0(K))/TIMEC + IF (F_QS) THEN + DQSDT(K)=(QSG(K)-QS0(K))/TIMEC + ELSE + DQIDT(K)=DQIDT(K)+(QSG(K)-QS0(K))/TIMEC + ENDIF + ELSE +! PRINT *,'THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED!' + CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED' ) + ENDIF + DTDT(K)=(TG(K)-T0(K))/TIMEC + DQDT(K)=(QG(K)-Q0(K))/TIMEC + ENDDO + +! PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ !LD add PRATEC 21-April-2011 +! RAINCV(I,J)=DT*PRATEC(I,J) !LD add PRATEC 21-April-2011 + + RAINCV(I,J)=DT*PPTFLX*(1.-FBFRC)/DXSQ ! PPT FB MODS + +! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS +! RNC=0.1*TIMEC*PPTFLX/DXSQ + RNC=RAINCV(I,J)*NIC + 909 FORMAT('AT I, J =',i3,1x,i3,' CONVECTIVE RAINFALL =',F8.4,' mm') +! write (98,909)I,J,RNC +! write (6,909)I,J,RNC +! WRITE(98,*)'at NTSD =',NTSD,',No. of KF points activated =', +! * NCCNT +! flush(98) +1000 FORMAT(' ',10A8) +1005 FORMAT(' ',F6.0,2X,F6.4,2X,F7.3,1X,F6.4,2X,4(F6.3,2X),2(F7.3,1X)) +1010 FORMAT(' ',' VERTICAL VELOCITY IS NEGATIVE AT ',F4.0,' MB') +1015 FORMAT(' ','ALL REMAINING MASS DETRAINS BELOW ',F4.0,' MB') +1025 FORMAT(5X,' KLCL=',I2,' ZLCL=',F7.1,'M', & + ' DTLCL=',F5.2,' LTOP=',I2,' P0(LTOP)=',-2PF5.1,'MB FRZ LV=', & + I2,' TMIX=',0PF4.1,1X,'PMIX=',-2PF6.1,' QMIX=',3PF5.1, & + ' CAPE=',0PF7.1) +1030 FORMAT(' ',' P0(LET) = ',F6.1,' P0(LTOP) = ',F6.1,' VMFLCL =', & + E12.3,' PLCL =',F6.1,' WLCL =',F6.3,' CLDHGT =', & + F8.1) +1035 FORMAT(1X,'PEF(WS)=',F4.2,'(CB)=',F4.2,'LC,LET=',2I3,'WKL=' & + ,F6.3,'VWS=',F5.2) +!1055 FORMAT('*** DEGREE OF STABILIZATION =',F5.3, & +! ', NO MORE MASS FLUX IS ALLOWED!') +!1060 FORMAT(' ITERATION DOES NOT CONVERGE TO GIVE THE SPECIFIED & +! &DEGREE OF STABILIZATION! FABE= ',F6.4) + 1070 FORMAT (16A8) + 1075 FORMAT (F8.2,3(F8.2),2(F8.3),F8.2,2F8.3,F8.2,6F8.3) + 1080 FORMAT(2X,'LFS,LDB,LDT =',3I3,' TIMEC, TADVEC, NSTEP=', & + 2(1X,F5.0),I3,'NCOUNT, FABE, AINC=',I2,1X,F5.3,F6.2) + 1085 FORMAT (A3,16A7,2A8) + 1090 FORMAT (I3,F7.2,F7.0,10F7.2,4F7.3,2F8.3) + 1095 FORMAT(' ',' PPT PRODUCTION RATE= ',F10.0,' TOTAL EVAP+PPT= ',F10.0) +1105 FORMAT(' ','NET LATENT HEAT RELEASE =',E12.5,' ACTUAL HEATING =',& + E12.5,' J/KG-S, DIFFERENCE = ',F9.3,'%') +1110 FORMAT(' ','INITIAL WATER =',E12.5,' FINAL WATER =',E12.5, & + ' TOTAL WATER CHANGE =',F8.2,'%') +! 1115 FORMAT (2X,F6.0,2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4) +1120 FORMAT(' ','MOISTURE ERROR AS FUNCTION OF TOTAL PPT =',F9.3,'%') +! +!----------------------------------------------------------------------- +!--------------SAVE CLOUD TOP AND BOTTOM FOR RADIATION------------------ +!----------------------------------------------------------------------- +! + IF (ISHALL<2) THEN ! add LKB 12/23/2011 01/11/2012 only define cloud base + CUTOP(I,J)=REAL(LTOP) ! if there are clouds + CUBOT(I,J)=REAL(LCL) + +! rce 11-may-2012 mods start ------------------------------------------- + updfra = au0*ainc/dxsq + wulcl = wu(klcl) + wup(:) = wu(:) + qc1d(:) = qliq(:) + qi1d(:) = qice(:) + qndrop1d(:) = qndropbb(:) + +! umf(k) and umfout(k) are at top of layer k + umfout(kts:ltop-1) = max( 0.0, umf(kts:ltop-1)/dxsq ) + uerout(kts:ltop) = max( 0.0, uer(kts:ltop)/dxsq ) + udrout(kts:ltop) = max( 0.0, udr(kts:ltop)/dxsq ) +! dmf(k) is at bottom of layer k; ! dmfout(k) is at top of layer k [like umf(k) and umfout(k)] + dmfout(kts:ltop-1) = min( 0.0, dmf(kts+1:ltop)/dxsq ) +! der(k) is negative; derout(k) is positive + derout(kts:ltop) = max( 0.0, -der(kts:ltop)/dxsq ) +! ddr(k) is positive so no change needed + ddrout(kts:ltop) = max( 0.0, ddr(kts:ltop)/dxsq ) + + if ( idiagee > 0 .and. ((ishall == 0) .or. (ishall == 1)) ) then + write(98,'(/a,1p,15i11 )') 'lc, kcldx, klcl, ksvaa, let, ltop', lc, kcldlayer, klcl, ksvaa, let, ltop + write(98,'( a,1p,15e11.3)') 'dt, timec, dx, ae=dxsq, au0, ainc', dt, timec, dx, dxsq, au0, ainc + write(98,'(a,1p,15e11.3 )') 'au0/ae, au0*ainc/ae ', au0/dxsq, au0*ainc/dxsq + write(98,'(a,1p,15e11.3 )') 'wlcl, wu(klcl), tpert, rpert ', wlcl, wu(klcl), th_perturb,r_perturb + tmpa = 0.0 ; tmpb = 0.0 + do k = 1, ltop + tmpa = tmpa + uerout(k) + if (k >= klcl) tmpb = tmpb + dp(k) + end do + write(98,'(a,1p,15e11.3 )') 'tmpu, ...*tau, tmpv, ...*area/g ', tmpa, tmpa*dt*ntst, tmpb, (tmpb/g)*(au0*ainc/dxsq) + write(98,'(3x,15a11)') 'p0', 'dp', 'omg/g', 'umfout', 'del-umf', 'uer-udr', 'uerout', 'udrout', & + 'qc1d', 'qi1d', 'f_qc2qi', 'f_qc2pr', 'f_qi2pr' + do k = ltop+2, 1, -1 + if (k >= kte) cycle + tmpa = 0.0 ; tmpb = 0.0 ; tmpc = 0.0 ; tmpd = 0.0 + if (k > 1 ) tmpa = umfout(k)-umfout(k-1) + if (k == 1) tmpa = umfout(k) + tmpb = uerout(k)-udrout(k) + write(98,'(i3,1p,15e11.3)') k, p0(k), dp(k), omg(k)/g, umfout(k), tmpa, tmpb, uerout(k), udrout(k), & + qc1d(k), qi1d(k), fcvt_qc_to_qi(k), fcvt_qc_to_pr(k), fcvt_qi_to_pr(k) + end do + write(98,'(3x,15a11)') 'p0', 'dp', ' ', 'dmfout', 'del-dmf', 'der-ddr', 'derout', 'ddrout' + do k = ltop+2, 1, -1 + if (k >= kte) cycle + tmpa = 0.0 ; tmpb = 0.0 ; tmpc = 0.0 ; tmpd = 0.0 + if (k > 1 ) tmpa = dmfout(k)-dmfout(k-1) + if (k == 1) tmpa = dmfout(k) + tmpb = derout(k)-ddrout(k) + write(98,'(i3,1p,15e11.3)') k, p0(k), dp(k), 0.0, dmfout(k), tmpa, tmpb, derout(k), ddrout(k) + end do + end if ! ( idiagee > 0 .and. ((ishall == 0) .or. (ishall == 1)) ) then +! rce 11-may-2012 mods end --------------------------------------------- + ENDIF +! +!----------------------------------------------------------------------- +! begin: wig, 21-Feb-2008 +! Only allow shallow-Cu to occur if the cloud base is within 500 m of +! the top of the PBL. This prevents us from getting too many clouds +! in the mid-troposphere. + if( ishall==1 .and. (z_at_w1d(lcl)-pblh) > 500. ) ishall = 2 +! end: wig, 21-Feb-2008 + + END SUBROUTINE KF_cup_PARA + +!******************************************************************** +! *********************************************************************** + + SUBROUTINE TPMIX2(p,thes,tu,qu,qliq,qice,qnewlq,qnewic,XLV1,XLV0) +! +! Lookup table variables: +! INTEGER, PARAMETER :: (KFNT=250,KFNP=220) +! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB +! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K +! REAL, SAVE, DIMENSION(1:200) :: ALU +! REAL, SAVE :: RDPR,RDTHK,PLUTOP +! End of Lookup table variables: +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,THES,XLV1,XLV0 + REAL, INTENT(OUT ) :: QNEWLQ,QNEWIC + REAL, INTENT(INOUT) :: TU,QU,QLIQ,QICE + REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11, & + TEMP,QS,QNEW,DQ,QTOT,RLL,CPP + INTEGER :: IPTB,ITHTB +!----------------------------------------------------------------------- + +!c******** LOOKUP TABLE VARIABLES... **************************** +! parameter(kfnt=250,kfnp=220) +!c +! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp), +! * alu(200),rdpr,rdthk,plutop +!C*************************************************************** +!c +!c*********************************************************************** +!c scaling pressure and tt table index +!c*********************************************************************** +!c +! plutop = model top pressure +! p = pressure level +! rdpr = a pressure (or 1/pressure) increment +! tp = a number of levels (a pressure difference divided by the increment + tp=(p-plutop)*rdpr + qq=tp-aint(tp) + iptb=int(tp)+1 + +! +!*********************************************************************** +! base and scaling factor for the +!*********************************************************************** +! +! scaling the and tt table index + bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb) + tth=(thes-bth)*rdthk + pp =tth-aint(tth) + ithtb=int(tth)+1 + IF(IPTB.GE.220 .OR. IPTB.LE.1 .OR. ITHTB.GE.250 .OR. ITHTB.LE.1)THEN + write(98,*)'**** OUT OF BOUNDS *********' +! flush(98) + ENDIF +! + t00=ttab(ithtb ,iptb ) + t10=ttab(ithtb+1,iptb ) + t01=ttab(ithtb ,iptb+1) + t11=ttab(ithtb+1,iptb+1) +! + q00=qstab(ithtb ,iptb ) + q10=qstab(ithtb+1,iptb ) + q01=qstab(ithtb ,iptb+1) + q11=qstab(ithtb+1,iptb+1) +! +!*********************************************************************** +! parcel temperature +!*********************************************************************** +! + temp=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq) +! + qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq) +! + DQ=QS-QU + IF(DQ.LE.0.)THEN + QNEW=QU-QS + QU=QS + ELSE +! +! IF THE PARCEL IS SUBSATURATED, TEMPERATURE AND MIXING RATIO MUST BE +! ADJUSTED...IF LIQUID WATER IS PRESENT, IT IS ALLOWED TO EVAPORATE +! + QNEW=0. + QTOT=QLIQ+QICE +! +! IF THERE IS ENOUGH LIQUID OR ICE TO SATURATE THE PARCEL, TEMP STAYS AT ITS +! WET BULB VALUE, VAPOR MIXING RATIO IS AT SATURATED LEVEL, AND THE MIXING +! RATIOS OF LIQUID AND ICE ARE ADJUSTED TO MAKE UP THE ORIGINAL SATURATION +! DEFICIT... OTHERWISE, ANY AVAILABLE LIQ OR ICE VAPORIZES AND APPROPRIATE +! ADJUSTMENTS TO PARCEL TEMP; VAPOR, LIQUID, AND ICE MIXING RATIOS ARE MADE. +! +!...subsaturated values only occur in calculations involving various mixtures of +!...updraft and environmental air for estimation of entrainment and detrainment. +!...For these purposes, assume that reasonable estimates can be given using +!...liquid water saturation calculations only - i.e., ignore the effect of the +!...ice phase in this process only...will not affect conservative properties... +! + IF(QTOT.GE.DQ)THEN + qliq=qliq-dq*qliq/(qtot+1.e-10) + qice=qice-dq*qice/(qtot+1.e-10) + QU=QS + ELSE + RLL=XLV0-XLV1*TEMP + CPP=1004.5*(1.+0.89*QU) + IF(QTOT.LT.1.E-10)THEN +! +!...IF NO LIQUID WATER OR ICE IS AVAILABLE, TEMPERATURE IS GIVEN BY: + TEMP=TEMP+RLL*(DQ/(1.+DQ))/CPP + ELSE +! +!...IF SOME LIQ WATER/ICE IS AVAILABLE, BUT NOT ENOUGH TO ACHIEVE SATURATION, +! THE TEMPERATURE IS GIVEN BY: +! + TEMP=TEMP+RLL*((DQ-QTOT)/(1+DQ-QTOT))/CPP + QU=QU+QTOT + QTOT=0. + QLIQ=0. + QICE=0. + ENDIF + ENDIF + ENDIF + TU=TEMP + qnewlq=qnew + qnewic=0. +! + END SUBROUTINE TPMIX2 +!****************************************************************************** + SUBROUTINE DTFRZNEW(TU,P,THTEU,QU,QFRZ,QICE,ALIQ,BLIQ,CLIQ,DLIQ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,QFRZ,ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(INOUT) :: TU,THTEU,QU,QICE + REAL :: RLC,RLS,RLF,CPP,A,DTFRZ,ES,QS,DQEVAP,PII +!----------------------------------------------------------------------- +! +!...ALLOW THE FREEZING OF LIQUID WATER IN THE UPDRAFT TO PROCEED AS AN +!...APPROXIMATELY LINEAR FUNCTION OF TEMPERATURE IN THE TEMPERATURE RANGE +!...TTFRZ TO TBFRZ... +!...FOR COLDER TERMPERATURES, FREEZE ALL LIQUID WATER... +!...THERMODYNAMIC PROPERTIES ARE STILL CALCULATED WITH RESPECT TO LIQUID WATER +!...TO ALLOW THE USE OF LOOKUP TABLE TO EXTRACT TMP FROM THETAE... +! + RLC=2.5E6-2369.276*(TU-273.16) + RLS=2833922.-259.532*(TU-273.16) + RLF=RLS-RLC + CPP=1004.5*(1.+0.89*QU) +! +! A = D(es)/DT IS THAT CALCULATED FROM BUCK (1981) EMPERICAL FORMULAS +! FOR SATURATION VAPOR PRESSURE... +! + A=(CLIQ-BLIQ*DLIQ)/((TU-DLIQ)*(TU-DLIQ)) + DTFRZ = RLF*QFRZ/(CPP+RLS*QU*A) + TU = TU+DTFRZ + + ES = ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) + QS = ES*0.622/(P-ES) +! +!...FREEZING WARMS THE AIR AND IT BECOMES UNSATURATED...ASSUME THAT SOME OF THE +!...LIQUID WATER THAT IS AVAILABLE FOR FREEZING EVAPORATES TO MAINTAIN SATURA- +!...TION...SINCE THIS WATER HAS ALREADY BEEN TRANSFERRED TO THE ICE CATEGORY, +!...SUBTRACT IT FROM ICE CONCENTRATION, THEN SET UPDRAFT MIXING RATIO AT THE NEW +!...TEMPERATURE TO THE SATURATION VALUE... +! + DQEVAP = QS-QU + QICE = QICE-DQEVAP + QU = QU+DQEVAP + PII=(1.E5/P)**(0.2854*(1.-0.28*QU)) + THTEU=TU*PII*EXP((3374.6525/TU-2.5403)*QU*(1.+0.81*QU)) +! + END SUBROUTINE DTFRZNEW +! -------------------------------------------------------------------------------- + + SUBROUTINE CONDLOAD(QLIQ,QICE,WTW,DZ,BOTERM,ENTERM,RATE,QNEWLQ, & + QNEWIC,QLQOUT,QICOUT,G) + +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US +! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL- +! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI- +! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL +! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ). + + REAL, INTENT(IN ) :: G + REAL, INTENT(IN ) :: DZ,BOTERM,ENTERM,RATE + REAL, INTENT(INOUT) :: QLQOUT,QICOUT,WTW,QLIQ,QICE,QNEWLQ,QNEWIC + REAL :: QTOT,QNEW,QEST,G1,WAVG,CONV,RATIO3,OLDQ,RATIO4,DQ,PPTDRG + +! +! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US +! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL- +! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI- +! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL +! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ). + QTOT=QLIQ+QICE + QNEW=QNEWLQ+QNEWIC +! +! ESTIMATE THE VERTICAL VELOCITY SO THAT AN AVERAGE VERTICAL VELOCITY +! BE CALCULATED TO ESTIMATE THE TIME REQUIRED FOR ASCENT BETWEEN MODEL +! LEVELS... +! + QEST=0.5*(QTOT+QNEW) + G1=WTW+BOTERM-ENTERM-2.*G*DZ*QEST/1.5 + IF(G1.LT.0.0)G1=0. + WAVG=0.5*(SQRT(WTW)+SQRT(G1)) + CONV=RATE*DZ/max(WAVG,1e-7) !wig, 12-Sep-2006: added div by 0 check +! +! RATIO3 IS THE FRACTION OF LIQUID WATER IN FRESH CONDENSATE, RATIO4 IS +! THE FRACTION OF LIQUID WATER IN THE TOTAL AMOUNT OF CONDENSATE INVOLV +! IN THE PRECIPITATION PROCESS - NOTE THAT ONLY 60% OF THE FRESH CONDEN +! SATE IS IS ALLOWED TO PARTICIPATE IN THE CONVERSION PROCESS... +! + RATIO3=QNEWLQ/(QNEW+1.E-8) +! OLDQ=QTOT + QTOT=QTOT+0.6*QNEW + OLDQ=QTOT + RATIO4=(0.6*QNEWLQ+QLIQ)/(QTOT+1.E-8) + QTOT=QTOT*EXP(-CONV) +! +! DETERMINE THE AMOUNT OF PRECIPITATION THAT FALLS OUT OF THE UPDRAFT +! PARCEL AT THIS LEVEL... +! + DQ=OLDQ-QTOT + QLQOUT=RATIO4*DQ + QICOUT=(1.-RATIO4)*DQ +! +! ESTIMATE THE MEAN LOAD OF CONDENSATE ON THE UPDRAFT IN THE LAYER, CAL +! LATE VERTICAL VELOCITY +! + PPTDRG=0.5*(OLDQ+QTOT-0.2*QNEW) + WTW=WTW+BOTERM-ENTERM-2.*G*DZ*PPTDRG/1.5 + IF(ABS(WTW).LT.1.E-4)WTW=1.E-4 +! +! DETERMINE THE NEW LIQUID WATER AND ICE CONCENTRATIONS INCLUDING LOSSE +! DUE TO PRECIPITATION AND GAINS FROM CONDENSATION... +! + QLIQ=RATIO4*QTOT+RATIO3*0.4*QNEW + QICE=(1.-RATIO4)*QTOT+(1.-RATIO3)*0.4*QNEW + QNEWLQ=0. + QNEWIC=0. + + END SUBROUTINE CONDLOAD + +! ---------------------------------------------------------------------- + SUBROUTINE PROF5(EQ,EE,UD) +! +!*********************************************************************** +!***** GAUSSIAN TYPE MIXING PROFILE....****************************** +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! THIS SUBROUTINE INTEGRATES THE AREA UNDER THE CURVE IN THE GAUSSIAN +! DISTRIBUTION...THE NUMERICAL APPROXIMATION TO THE INTEGRAL IS TAKEN FROM +! "HANDBOOK OF MATHEMATICAL FUNCTIONS WITH FORMULAS, GRAPHS AND MATHEMATICS TABLES" +! ED. BY ABRAMOWITZ AND STEGUN, NATL BUREAU OF STANDARDS APPLIED +! MATHEMATICS SERIES. JUNE, 1964., MAY, 1968. +! JACK KAIN +! 7/6/89 +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: EQ + REAL, INTENT(INOUT) :: EE,UD + REAL :: SQRT2P,A1,A2,A3,P,SIGMA,FE,X,Y,EY,E45,T1,T2,C1,C2 + + DATA SQRT2P,A1,A2,A3,P,SIGMA,FE/2.506628,0.4361836,-0.1201676, & + 0.9372980,0.33267,0.166666667,0.202765151/ + X=(EQ-0.5)/SIGMA + Y=6.*EQ-3. + EY=EXP(Y*Y/(-2)) + E45=EXP(-4.5) + T2=1./(1.+P*ABS(Y)) + T1=0.500498 + C1=A1*T1+A2*T1*T1+A3*T1*T1*T1 + C2=A1*T2+A2*T2*T2+A3*T2*T2*T2 + IF(Y.GE.0.)THEN + EE=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*EQ*EQ/2. + UD=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*(0.5+EQ*EQ/2.- & + EQ) + ELSE + EE=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*EQ*EQ/2. + UD=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*(0.5+EQ* & + EQ/2.-EQ) + ENDIF + EE=EE/FE + UD=UD/FE + + END SUBROUTINE PROF5 + +! ------------------------------------------------------------------------ + SUBROUTINE TPMIX2DD(p,thes,ts,qs,i,j) +! +! Lookup table variables: +! INTEGER, PARAMETER :: (KFNT=250,KFNP=220) +! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB +! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K +! REAL, SAVE, DIMENSION(1:200) :: ALU +! REAL, SAVE :: RDPR,RDTHK,PLUTOP +! End of Lookup table variables: +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,THES + REAL, INTENT(INOUT) :: TS,QS + INTEGER, INTENT(IN ) :: i,j ! avail for debugging + REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11 + INTEGER :: IPTB,ITHTB + CHARACTER*256 :: MESS +!----------------------------------------------------------------------- + +! +!******** LOOKUP TABLE VARIABLES (F77 format)... **************************** +! parameter(kfnt=250,kfnp=220) +! +! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp), & +! alu(200),rdpr,rdthk,plutop +!*************************************************************** +! +!*********************************************************************** +! scaling pressure and tt table index +!*********************************************************************** +! + tp=(p-plutop)*rdpr + qq=tp-aint(tp) + iptb=int(tp)+1 +! +!*********************************************************************** +! base and scaling factor for the +!*********************************************************************** +! +! scaling the and tt table index + bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb) + tth=(thes-bth)*rdthk + pp =tth-aint(tth) + ithtb=int(tth)+1 +! + t00=ttab(ithtb ,iptb ) + t10=ttab(ithtb+1,iptb ) + t01=ttab(ithtb ,iptb+1) + t11=ttab(ithtb+1,iptb+1) +! + q00=qstab(ithtb ,iptb ) + q10=qstab(ithtb+1,iptb ) + q01=qstab(ithtb ,iptb+1) + q11=qstab(ithtb+1,iptb+1) +! +!*********************************************************************** +! parcel temperature and saturation mixing ratio +!*********************************************************************** +! + ts=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq) +! + qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq) +! + END SUBROUTINE TPMIX2DD + +! ----------------------------------------------------------------------- + SUBROUTINE ENVIRTHT(P1,T1,Q1,THT1,ALIQ,BLIQ,CLIQ,DLIQ) +! +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P1,T1,Q1,ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(INOUT) :: THT1 + REAL :: EE,TLOG,ASTRT,AINC,A1,TP,VALUE,AINTRP,TDPT,TSAT,THT, & + T00,P00,C1,C2,C3,C4,C5 + INTEGER :: INDLU +!----------------------------------------------------------------------- + DATA T00,P00,C1,C2,C3,C4,C5/273.16,1.E5,3374.6525,2.5403,3114.834, & + 0.278296,1.0723E-3/ +! +! CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMPERATURE... +! +! NOTE: Calculations for mixed/ice phase no longer used...jsk 8/00 +! + EE=Q1*P1/(0.622+Q1) +! TLOG=ALOG(EE/ALIQ) +! ...calculate LOG term using lookup table... +! + astrt=1.e-3 + ainc=0.075 + a1=ee/aliq + tp=(a1-astrt)/ainc + indlu=int(tp)+1 + value=(indlu-1)*ainc+astrt + aintrp=(a1-value)/ainc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) +! + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TSAT=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T1-T00))*(T1-TDPT) + THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1)) + THT1=THT*EXP((C1/TSAT-C2)*Q1*(1.+0.81*Q1)) +! + END SUBROUTINE ENVIRTHT +! *********************************************************************** +!==================================================================== + SUBROUTINE kf_cup_init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, & + SVP1,SVP2,SVP3,SVPT0, & + cupflag,cldfra_cup,cldfratend_cup, & !CuP, wig 18-Sep-2006 + shall, & !CuP, wig 18-Sep-2006 + tcloud_cup, & !CuP, rce 10-may-2012 + P_FIRST_SCALAR,restart,allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + LOGICAL , INTENT(IN) :: restart,allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: P_QI,P_QS,P_FIRST_SCALAR + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + W0AVG, & + cldfra_cup, & !CuP, wig 18-Sep-2006 + cldfratend_cup !CuP, wig 18-Sep-2006 + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA, & + shall, & !CuP, wig 19-Sep-2006 + tcloud_cup !CuP, rce 10-may-2012 + + LOGICAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT):: cupflag !CuP, wig 9-Oct-2006 + + INTEGER :: i, j, k, itf, jtf, ktf + REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + + IF(.not.restart)THEN + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RTHCUTEN(i,k,j)=0. + RQVCUTEN(i,k,j)=0. + RQCCUTEN(i,k,j)=0. + RQRCUTEN(i,k,j)=0. + cldfra_cup(i,k,j) = 0. !CuP, wig 18-Sep-2006 + cldfratend_cup(i,k,j) = 0. !CuP, wig 18-Sep-2006 + ENDDO + ENDDO + ENDDO + + IF (P_QI .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQICUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QS .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQSCUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + DO j=jts,jtf + DO i=its,itf + NCA(i,j)=-100. + shall(i,j) = 2. !Indicate no convection at 1st time step. CuP, wig 18-Sep-2006 + cupflag(i,j) = .false. !CuP, wig 9-Oct-2006 + tcloud_cup(i,j) = 0.0 !CuP, rce 10-may-2012 + ENDDO + ENDDO + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + W0AVG(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + endif + + CALL KF_LUTAB(SVP1,SVP2,SVP3,SVPT0) + + END SUBROUTINE kf_cup_init + +!------------------------------------------------------- + + subroutine kf_lutab(SVP1,SVP2,SVP3,SVPT0) +! +! This subroutine is a lookup table. +! Given a series of series of saturation equivalent potential +! temperatures, the temperature is calculated. +! +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- +! Lookup table variables +! INTEGER, SAVE, PARAMETER :: KFNT=250,KFNP=220 +! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB +! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K +! REAL, SAVE, DIMENSION(1:200) :: ALU +! REAL, SAVE :: RDPR,RDTHK,PLUTOP +! End of Lookup table variables + + INTEGER :: KP,IT,ITCNT,I + REAL :: DTH,TMIN,TOLER,PBOT,DPR, & + TEMP,P,ES,QS,PI,THES,TGUES,THGUES,F0,T1,T0,THGS,F1,DT, & + ASTRT,AINC,A1,THTGS +! REAL :: ALIQ,BLIQ,CLIQ,DLIQ,SVP1,SVP2,SVP3,SVPT0 + REAL :: ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 +! +! equivalent potential temperature increment + data dth/1./ +! minimum starting temp + data tmin/150./ +! tolerance for accuracy of temperature + data toler/0.001/ +! top pressure (pascals) + plutop=5000.0 +! bottom pressure (pascals) + pbot=110000.0 + + ALIQ = SVP1*1000. + BLIQ = SVP2 + CLIQ = SVP2*SVPT0 + DLIQ = SVP3 + +! +! compute parameters +! +! 1._over_(sat. equiv. theta increment) + rdthk=1./dth +! pressure increment +! + DPR=(PBOT-PLUTOP)/REAL(KFNP-1) +! dpr=(pbot-plutop)/REAL(kfnp-1) +! 1._over_(pressure increment) + rdpr=1./dpr +! compute the spread of thes +! thespd=dth*(kfnt-1) +! +! calculate the starting sat. equiv. theta +! + temp=tmin + p=plutop-dpr + do kp=1,kfnp + p=p+dpr + es=aliq*exp((bliq*temp-cliq)/(temp-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + the0k(kp)=temp*pi*exp((3374.6525/temp-2.5403)*qs* & + (1.+0.81*qs)) + enddo +! +! compute temperatures for each sat. equiv. potential temp. +! + p=plutop-dpr + do kp=1,kfnp + thes=the0k(kp)-dth + p=p+dpr + do it=1,kfnt +! define sat. equiv. pot. temp. + thes=thes+dth +! iterate to find temperature +! find initial guess + if(it.eq.1) then + tgues=tmin + else + tgues=ttab(it-1,kp) + endif + es=aliq*exp((bliq*tgues-cliq)/(tgues-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + thgues=tgues*pi*exp((3374.6525/tgues-2.5403)*qs* & + (1.+0.81*qs)) + f0=thgues-thes + t1=tgues-0.5*f0 + t0=tgues + itcnt=0 +! iteration loop + do itcnt=1,11 + es=aliq*exp((bliq*t1-cliq)/(t1-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + thtgs=t1*pi*exp((3374.6525/t1-2.5403)*qs*(1.+0.81*qs)) + f1=thtgs-thes + if(abs(f1).lt.toler)then + exit + endif +! itcnt=itcnt+1 + dt=f1*(t1-t0)/(f1-f0) + t0=t1 + f0=f1 + t1=t1-dt + enddo + ttab(it,kp)=t1 + qstab(it,kp)=qs + enddo + enddo +! +! lookup table for tlog(emix/aliq) +! +! set up intial values for lookup tables +! + astrt=1.e-3 + ainc=0.075 +! + a1=astrt-ainc + do i=1,200 + a1=a1+ainc + alu(i)=alog(a1) + enddo +! + END SUBROUTINE KF_LUTAB + + +!-------------------------------------------------------------------- +! Calculates the cloud fraction tendency. +! +SUBROUTINE cupCloudFraction(qlg, qig, qv1d, t1d, z1d, p1d, & + kcubot, kcutop, ishall, wStar, wParcel, pblh, dt, activeFrac, & + cldfra, cldfraTend, & + taucloud, tActive, tstar, lnterms, lnint, & + kts, kte, mfup_cup) ! add mfup_cup LD 06 29 2012 + ! kts, kte) + + use module_model_constants, only: r_v, xls0, xls1, xlv0, xlv1 +! +! Arguments... +! + integer, intent(in) :: kts, kte + integer, intent(in) :: ishall ! Flag for cloud type (0=deep, 1=shallow, 2=none) + + integer, intent(in) :: kcubot, kcutop ! Indices of cloud top and bottom + real, intent(in) :: wStar, pblh ! Deardorff velocity scale and mixed-layer depth + real, intent(in) :: wParcel ! Vertical velocity of parcel + real, intent(in) :: activeFrac ! Active cloud fraction, determined from cloud model + real, intent(in) :: dt ! Time step used to find cloud fraction + + real, dimension(kts:kte), intent(in) :: qlg ! Cloud liquid water + real, dimension(kts:kte), intent(in) :: qig ! Cloud ice + real, dimension(kts:kte), intent(in) :: t1d ! Environment temperature + real, dimension(kts:kte), intent(in) :: qv1d ! Environmental mixing ratio + real, dimension(kts:kte), intent(in) :: z1d ! Height array on cell middles + real, dimension(kts:kte), intent(in) :: p1d ! Pressure array + + real, dimension(kts:kte), intent(inout) :: cldfra ! Cloud fraction + real, dimension(kts:kte), intent(in) :: mfup_cup ! LD 06 29 2012 + real, dimension(kts:kte), intent(out) :: cldfraTend ! Cloud fraction tendency +! +! Local vars... +! + integer :: k, kp1 ,kcutop_p1 !BSINGH - Added kcutop_p1 + + real :: gamma, zsum + real,intent(out) :: tauCloud ! Cloud time scale ~can make local after testing + real,intent(out) :: tActive ! Cloud time scale ~can make local after testing +!!! real,intent(out) :: wParcel ! Cloud velocity scale ~can make local after testing + real,intent(out) :: tStar ! Boundary-layer time scale ~can make local after testing +!!! real,intent(out) :: activeFrac ! Fraction of PDF that forms clouds + real :: ice_term, liquid_term ! Terms inside of log for gamma + real, dimension(kts:kte),intent(out) :: lnTerms ! Combined log terms to be integrated ~can make local after testing + real,intent(out) :: lnInt ! Integrated log terms for gamma ~can make local after testing + real :: intQC ! Integrated cloud water add 2010/01/17 + real, dimension(kts:kte) :: satDef ! Saturation deficit add 2010/01/17 + real :: intSatDef ! Integrated saturation deficit aa 2010/01/17 + real :: deltaZ ! Height diff. between cell centers + real :: deltaRsInt ! Integrated delta rs + real :: deltaRsTop, deltaRsBot ! Value at deltaRs at the top an bottom of the layer + real :: TEnvTop, TEnvBot ! Env. temperature at top and bottom of the layer + real :: rs, rsi ! Saturation mixing ratios w.r.t liquid and ice + real :: cp , Ls, Lv ! Thermodynamic related "constants" + + if( ishall==2 ) then + ! If no convection, then zero out the cloud fraction... + cldfra(:) = 0. + + else if( ishall==0 ) then + ! If deep convection formed, then set the cloud fraction to 1. + cldfra(:) = 0. + + ! cldfra(kcubot:kcutop) = 1. !!LD + !! print(UMF(?)) unit?? + do k=kcubot,kcutop + cldfra(k) = max(0.,min(0.1*log(1.+675.*mfup_cup(k)),1.)) !! LD 06 29 2012 :: .1/675 adjustable parameter + end do +! print*,"mfup_cup(kcubot)=",mfup_cup(kcubot) + + tStar = pblh / wStar ! rce 11-may-2012 + + else if( ishall==1 ) then + + ! Shallow convection occurred so we need to be more detailed... + + tStar = pblh / wStar ! Find tStar based on mixed-layer depth + + ! Integrate the log terms for the cloud time scale over the depth + ! of the cloud and take into account both liquid and ice as + ! separate terms. Do not allow super saturation, and at the same + ! time, preclude divide by zeros by limiting the (rs-r)'s to + ! positive values. + lnTerms(:) = 0. + + !!The determination of the cloud time scales around line 3523. + !!modified the do loop that computes the integrated cloud water and the saturation deficit. + !!code starts at line 3541 and continues through 3560 + + !!do k=kcubot,kcutop + !!cp = findCp(qv1d(k)) + !!rs = findRs(t1d(k), p1d(k)) + !!Lv = xlv0 - xlv1*t1d(k) + !!gamma = eps*(Lv**2)*rs / (cp*r_v*t1d(k)**2) + !!liquid_term = (1.+gamma)*qlg(k) / max(rs - qv1d(k),1e-20) + + !!Ls = xls0 - xls1*t1d(k) + !!rsi = findRsi(t1d(k), p1d(k)) + !!gamma = eps*(Ls**2)*rsi / (cp*r_v*t1d(k)**2) + !!ice_term = (1.+gamma)*qig(k) / max(rsi - qv1d(k),1e-20) + + !!lnTerms(k) = 1. + liquid_term !~tmp + ice_term + !!end do + + !lnInt = 0.! add 2011/01/16 start + intQC = 0. + intSatDef = 0. + zsum = 0. + + !BSINGH - Added do-loop to compute 'satDef' before it is being used in the next do-loop + !BSINGH - This loop should go to (kcutop+1) as we are trying to access satDef(k+1) in the next do-loop + kcutop_p1 = min(kcutop + 1,kte) + do k = kcubot, kcutop_p1 + rs = findRs(t1d(k), p1d(k)) + satDef(k) = max(rs - qv1d(k), 1.0e-20) + end do + !BSINGH - ENDS + + do k=kcubot,kcutop + kp1 = min(k+1,kte-1) + deltaZ = z1d(kp1) - z1d(k) ! Find the interval + zsum = zsum + deltaz + !!lnInt = lnInt + 0.5*(lnTerms(k) + lnTerms(kp1))*deltaZ + rs = findRs(t1d(k), p1d(k)) + satDef(k) = max(rs - qv1d(k), 1e-20) + intQC = 0.5*(qlg(k) + qlg(kp1)) * deltaz + intQC +! print *, 'Values within cupCloudFraction', intSatDef, satDef(k),satDef(kp1),deltaz,k,kp1 + !print *, 'Values within cupCloudFraction',rs,qv1d(k),qlg(k),qlg(kp1),k,kp1 + intSatDef = 0.5*(satDef(k) + satDef(kp1)) * deltaz + intSatDef + end do + !!lnInt = lnInt/zsum !Turn the integral into an average + cp = findCp(qv1d(kcubot)) ! Use the thermodynamic properties at cloud base for defining gamma + rs = findRs(t1d(kcubot), p1d(kcubot)) + Lv = xlv0 - xlv1*t1d(kcubot) + gamma = (Lv**2)*rs / (cp*r_v*t1d(kcubot)**2) + lnInt = log(1.0 + (1.0 + gamma) * intQC / intSatDef) + lnInt = max(lnInt, 1.0) ! Set the value of lnInt to be 1 or greater + ! add 2011/01/16 end + ! Find the time scale of the cloud lifetime, tauCloud, and the time + ! scale of the cloud formation, tActive... + !!tauCloud = min(tStar*lnInt, 3600.) !Set a max taucld of 60 min. + tauCloud = min(tStar*lnInt, 1800.) !Set a max taucld of 60 min. + if(wParcel .gt. 0) then + tActive = z1d(kcutop)/wParcel + else + tActive = z1d(kcutop) / wStar + endif +!!!! tActive or tactive matter? Dec-15-2010-LP +!!$ ! Now, find the cloud fraction tendency. Above and below the cloud, +!!$ ! it is zero. +!!$ cldfraTend(kts:max(kcubot-1,kts)) = 0. +!!$ cldfraTend(min(kcutop+1,kte):kte) = 0. +!!$ do k=kcubot,kcutop +!!$ cldfraTend(k) = dt*(activeFrac/tActive - cldfra(k)/tauCloud) +!!$ enddo + + ! Now, get a steady-state cloud fraction and restrict it to the + ! range [0,1]... + cldfra(:) = 0. + do k=kcubot,kcutop + cldfra(k) = activeFrac*tauCloud/tActive + cldfra(k) = max(cldfra(k), 0.01) ! LKB 9/9/09 Changed from 0 to be 0.1 + cldfra(k) = min(cldfra(k), 1.) + end do + + else + !This should never happen! + call wrf_error_fatal("Bad ishall value in kfcup.") + end if + +END SUBROUTINE cupCloudFraction + + +!------------------------------------------------------------------------ +SUBROUTINE cup_jfd(slopeSfc, slopeEZ, sigmaSfc, sigmaEZ, & + numBins, thBinSize, rBinSize, th_perturb, r_perturb, jfd ) + + USE module_model_constants, only: pi2 +! +! Arguments... +! + integer, intent(in) :: numBins + real, intent(in) :: thBinSize, rBinSize + real, intent(inout) :: slopeSfc, slopeEZ, sigmaSfc, sigmaEZ + real, dimension(numBins), intent(out) :: r_perturb, th_perturb + real, dimension(numBins,numBins), intent(out) :: jfd +! +! Local vars... +! + integer :: centerBin, i, j + real :: bigcheck, c, constants, cterm, dslope, jacobian, jfdCheckSum, m, mterm + character(len=150) :: message +! +! Limit the allowable values of the slopes and sigmas ~get the right values for caps +! +! slopeSfc = sign( min( abs(slopeSfc), 2e6 ), slopeSfc) +! slopeEZ = sign( min( abs(slopeEZ), 2e6 ), slopeEZ) +!~ sigmaSfc = max( abs(sigmaSfc), rBinSize ) ! <-- This one is the only one that really limited anything. It was only giving the value rBinSize. +!~ sigmaEZ = max( abs(sigmaEZ), rBinSize ) + +!!$!~wig begin: testing due to overflow of jfd calc 13-dec-2006 +!!$if( abs(slopesfc) < 1e-14 ) print*,"small slopesfc =",slopesfc +!!$if( abs(slopeez) < 1e-14 ) print*,"small slopeez =",slopeez +!!$if( abs(sigmasfc) < 1e-14 ) print*,"small sigmasfc =",sigmasfc +!!$if( abs(sigmaez) < 1e-14 ) print*,"small sigmaez =",sigmaez +!!$!~wig end + + slopeSfc = sign(max( abs(slopeSfc), 1e-15 ), slopeSfc) + !!slopeEZ = sign(max( abs(slopeEZ), 1e-10 ), slopeEZ) !1e-15 caused an overflow for the jfd~ + if(slopeEZ > 2000) then + slopeEZ = 2000.0 + else if(slopeEZ < -2000) then + slopeEZ = -2000.0 + else if(slopeEZ < 10 .and. slopeEZ > 0) then + slopeEZ = 10.0 + else if(slopeEZ < 0 .and. slopeEZ > -10.0) then + slopeEZ = -10.0 + endif + sigmaSfc = sign(max( abs(sigmaSfc), 1e-15 ), sigmaSfc) + sigmaEZ = sign(max( abs(sigmaEZ), 1e-15 ), sigmaEZ) + !!slopeEZ = 1000.0 ! Larry, set constant value of slopeEZ +!! slopeSfc = sign(min (abs(slopeSfc), 5000.0), slopeSfc) ! lkb Added check on size of slopes +!! slopeSfc = sign(min (abs(slopeEZ), 5000.0), slopeEZ) +! +! Calculate all the values that are held constant while looping through +! the perturbations... +! + centerBin = numBins / 2 + 1 ! Find the center bin + dslope = sign(max(abs(slopeEZ-slopeSfc),1e-15),slopeEZ-slopeSfc) + jacobian = slopeEZ / dslope ! Compute the jacobian + !wig: 22-Dec-2006 added parentheses that had been inadvertantly dropped... +!wig constants = jacobian*thBinSize*rBinSize / (pi2*sigmaSfc*sigmaEZ) + bigcheck = sqrt(huge(c)) ! 10/30/08 lkb 0.1*huge(c) +! +! Loop through all the perturbation possibilities and get the jfd... +! + jfdCheckSum = 0. + do j = 1, numBins ! For each bin of the jfd + r_perturb(j) = rBinSize * (j - centerBin) + do i = 1, numBins + th_perturb(i) = thBinSize * (i - centerBin) + + ! Convert theta and r to c and m space. This uses eq. 4 + ! from Berg and Stull (2004) + c = slopeEZ * (th_perturb(i) - slopeSfc * r_perturb(j)) / dslope + m = (th_perturb(i) - slopeEZ * r_perturb(j)) / dslope + +!wig, 22-Dec-2006: Actual desired calc commented since was getting +! an overflow. So, added code to enforce limits. +! jfd(i,j) = exp(-0.5 * ( (m/sigmaSfc) * (m/sigmaSfc) + & +! (c/sigmaEZ) * (c/sigmaEZ) )) * constants + cterm = c/sigmaEZ + if( abs(cterm) > bigcheck ) then + write(message, & + '("KFCuP setting a bogus cterm for JFD. c=",1e15.6," & + & sigmaEZ=",1e15.6)') & + c, sigmaEZ + call wrf_debug(0,trim(message)) + cterm = sign(bigcheck,cterm) + else + cterm = cterm*cterm + end if + mterm = m/sigmaSfc +!!$ if( abs(mterm) > 0.1*bigcheck ) then +!!$ write(message, & +!!$ '("KFCuP has a big mterm for JFD. m=",1e15.6," sigmaSfc=",1e15.6," dslope=",1e15.6," slopeEZ=",1e15.6," slopeSfc=",1e15.6)') & +!!$ m, sigmaSfc,dslope,slopeEZ,slopeSfc +!!$ call wrf_debug(0,trim(message)) +!!$ flush(0) +!!$ flush(6) +!!$ end if + if( abs(mterm) > bigcheck ) then + +print*,'bigcheck=',bigcheck + write(message, & + '("KFCuP setting a bogus mterm for JFD. m=",1e15.6, & + & " sigmaSfc=",1e15.6)') & + m, sigmaSfc + call wrf_debug(0,trim(message)) + flush(0) + flush(6) + mterm = sign(bigcheck,mterm) + else + mterm = mterm*mterm + end if +!wig: took off constants because they will not affect the outcome after normalizing to one + jfd(i,j) = exp( -0.5*(mterm + cterm) ) !* constants +!wig: end of overflow hack + + jfdCheckSum = jfdCheckSum + jfd(i,j) + + enddo + enddo + +!!$!~Add check to only output the check sum if it is out of the ordinary... +!!$ write(*,*) "JFD sums to ", jfdCheckSum, " Number of bins is ", numBins +!!$ write(30,*) "~JFD sums to ", jfdCheckSum, " Number of bins is ", numBins +!!$ write(30,'("slope sfc/ez & sigma sfc/ez: ",4g18.8)') slopesfc,slopeez,sigmasfc,sigmaez +!!$ if( count(abs(jfd) > 1e-30) > 1 ) write(30,*) "---Non-spiked JFD---",count(abs(jfd) > 1e-30) +!!$ write(30,'(21g11.4)') 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21 +!!$ do j=1,numBins +!!$ write(30,'(i3, 17e11.4)') j,jfd(:,j) +!!$ end do + +! Force jfd sum to be one... + if( jfdCheckSum /= 0. ) jfd(:,:) = jfd(:,:)/jfdCheckSum !~Re-normalize the jfd to sum to one + +!!$ write(30,*) "~adjusted JFD..." +!!$ write(30,'(21g11.4)') 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21 +!!$ do j=1,numBins +!!$ write(30,'(i3, 21e11.4)') j,jfd(:,j) +!!$ end do +!!$ write(30,*) + +END SUBROUTINE cup_jfd + + +!------------------------------------------------------------------------ +SUBROUTINE cupSlopeSigma(dx, psfc, p, rho, dz8w, z, ht, & + t, th, tsk, u, v, qv_curr, hfx,xland, qfxin, mavail, & ! add xland, LD 19-Oct-2011 + sf_sfclay_physics, br, regime, pblh, kpbl, t2, q2, & + slopeSfc, slopeEZ, sigmaSfc, sigmaEZ, wStar, cupflag, & + shall, kms, kme, kts, kte ) + + USE module_model_constants, only: cp, ep_1, ep_2, g, r_d, rcp, & + svp1, svp2, svp3, svpt0, xlv + + USE module_state_description, ONLY : KFCUPSCHEME & + ,SFCLAYSCHEME & + ,MYJSFCSCHEME & + ,GFSSFCSCHEME & + ,SLABSCHEME & + ,LSMSCHEME & + ,RUCLSMSCHEME +! MPI is needed for the test printouts (to get the rank)... +!#ifdef ( DM_PARALLEL ) && !defined( STUBMPI ) +#if ( ! defined(DM_PARALLEL) && ! defined(STUBMPI) ) +! rce_testing turn this off +! INCLUDE 'mpif.h' +#endif + +! +! Arguments... +! + integer, intent(in) :: kpbl, sf_sfclay_physics, & + kms, kme, kts, kte + + real, intent(in) :: & + br, dx, hfx,xland, ht, mavail, pblh, psfc, q2, qfxin, regime, t2, tsk !add xland LD 19-Oct-2011 + + real, dimension(kms:kme), intent(in) :: & + p, rho, dz8w, z, t, th, qv_curr, u, v + + real, intent(out) :: & + slopeSfc, slopeEZ, sigmaSfc, sigmaEZ, wStar + real, intent(inout) :: shall + + logical, intent(out) :: cupflag +! +! Local vars... +! + integer :: docldstep, fout, i, ierr, j, k, kpblmid, numZ + real :: br2, dtcu, e1, dthvdz, flux, govrth, psfccmb, qdiff, qfx, & + qsfc, rhox, thv2, thgb, thv, tskv, tvcon, vconv, vsgd, wspd, za + real, dimension(kts:kte) :: zagl + logical :: UnstableOrNeutral + character(len=50) :: filename +! +! Artificially force a latent heat flux that is not close to zero. This +! prevents sigmaSfc from becoming too small and leading to overflows +! in the JFD calculation. +! + if( abs(qfxin) < 1./xlv ) then + qfx = sign(1./xlv,qfxin) + else + qfx = qfxin + end if +! +! Determine if each column is stable or (unstable or neutral). If the regime +! is already calculated by one of the surface schemes, we can use it. If not, +! deterimine the stability based on the bulk richardson number. We only +! care about stable vs. (neutral or unstable). +! + UnstableOrNeutral = .false. + sfclay_case: SELECT CASE (sf_sfclay_physics) + CASE (SFCLAYSCHEME) + ! Regime categories: + ! 1 = Stable (nighttime) + ! 2 = Damped mechanical turbulence + ! 3 = Forced convection + ! 4 = Free convection + ! Add condition for positive heat flux because negative heat fluxes + ! were causing the wstar calculation to core dump--can't do a 1/3 + ! root of a negative value. wig, 5-Feb-2008 + if( regime > 2.5 & + .AND. hfx >= 0. ) UnstableOrNeutral = .true. + + CASE (GFSSFCSCHEME) + if( br <= 0. ) UnstableOrNeutral = .true. + + CASE DEFAULT + ! The selected sfc scheme does not already provide a stability + ! criteria. So, we will mimic the bulk Richardson calculation from + ! module_sf_sfclay.F. + + !!if( pblh <= 0. ) call wrf_error_fatal( & + !! "CuP needs a PBL height from a PBL scheme.") + if(pblh <= 0.0)then + UnstableOrNeutral = .false. ! Added by LKB 9/8/09 + + else ! Added by LKB 9/8/09 + ZA = 0.5*dz8w(1) + + E1 = SVP1*EXP(SVP2*(TSK-SVPT0)/(TSK-SVP3)) + PSFCCMB=PSFC/1000. !converts from Pa to cmb + QSFC = EP_2*E1/(PSFCCMB-E1) + THGB = TSK*(100./PSFCCMB)**RCP + TSKV = THGB*(1.+EP_1*QSFC*MAVAIL) + TVCON = 1.+EP_1*QV_CURR(1) + THV = TH(1)*TVCON + DTHVDZ= (THV-TSKV) + + GOVRTH= G/TH(1) + + RHOX = PSFC/(r_d*t(1)*TVCON) + flux = max(hfx/rhox/cp + ep_1*tskv*qfx/rhox,0.) + VCONV = (g/TSK*pblh*flux)**.33 + VSGD = 0.32 * (max(dx/5000.-1.,0.))**.33 + WSPD = SQRT(U(1)*U(1)+V(1)*V(1)) + WSPD = SQRT(WSPD*WSPD+VCONV*VCONV+vsgd*vsgd) + WSPD = MAX(WSPD,0.1) + + !And finally, the bulk Richardson number... + BR2 = GOVRTH*ZA*DTHVDZ/(WSPD*WSPD) + + if( br2 <= 0. ) then + UnstableOrNeutral = .true. + else + UnstableOrNeutral = .false. + endif + endif + END SELECT sfclay_case + + ! If we are in a stable regime, then the assumptions for CuP do not + ! make sense, so default back to the standard KF algorithm. Also, do + ! this if the pbl is at the lowest level since then we cannot + !calculate a proper difference with the surface. + !if( kpbl == 1 .or. (.not. UnstableOrNeutral) .or. hfx < 0 .or. qfx < 0) then !~ lkb 8/25/08 changed to require + heat flux + ! if( kpbl == 1 .or. hfx < 1 ) then !~ lkb 8/25/08 changed to require + heat flux + ! if( kpbl == 1 .or. hfx < 50 ) then !~ lkb 8/25/08 changed to require + heat flux + ! if( kpbl <= 2 .or. hfx < 100 ) then !~ lkb 8/25/08 changed to require + heat flux + if(xland .eq.1 )then !~ LD 18-Oct-2011 + if( kpbl <= 2 .or. hfx < 100 ) then !~ lkb 8/25/08 changed to require + heat flux + cupflag = .false. + slopeSfc = 0. + slopeEZ = 0. + sigmaSfc = 0. + sigmaEZ = 0. + shall = 2 ! Added by LK Berg on 6/17/09 to stop shallow clouds at night + return ! <---Alternate return point + else + cupflag = .true. + end if + else + if( kpbl <= 2 .or. hfx < 1 ) then !~ lkb 8/25/08 changed to require + heat flux + cupflag = .false. + slopeSfc = 0. + slopeEZ = 0. + sigmaSfc = 0. + sigmaEZ = 0. + shall = 2 ! Added by LK Berg on 6/17/09 to stop shallow clouds at night + return ! <---Alternate return point + else + cupflag = .true. + end if + end if + + ! Convert height from AMSL to AGL... + do k=kts, kte-1 + zagl(k) = z(k) - ht + end do + +!!$ ! Find the index closest to the middle of the PBL... +!!$ kpblmid = 0 +!!$ do k=kts, kte-1 +!!$ if( zagl(k) > pblh(i,j) ) then +!!$ kpblmid = max(1, k/2) +!!$ exit +!!$ end if +!!$ end do +!!$ if( kpblmid == 0 ) & +!!$ call wrf_error("CuP ERROR: PBLH not within the domain.") + + if( kpbl == 0 ) call wrf_error_fatal("CuP ERROR: kpbl==0") + + ! Calculate the Deardorff velocity, wStar. As a rough + ! approximation of the middle of PBL averaged theta and mixing + ! ratio, use the value at the middle of the PBL. + ! The flux amalgamation formula is from Stull, p.147 and + ! wStar is from Stull, p. 118. + kpblmid = max(kts,kpbl/2) + flux = (1. + EP_1*qv_curr(1))*hfx/rho(1)/cp + & + EP_1*th(1)*qfx/rho(1) !badbad/xlv + tvcon = 1.+EP_1*qv_curr(kpblmid) + thv = th(kpblmid)*tvcon + wStar = (g*pblh*flux/thv)**(1./3.) + !!write(*,*) 'Larry ... wStar', wStar, pblh, flux, thv + ! Calculate the slope (dTemp/dMixRatio) for the surface layer + ! and entrainment zone... + thv = th(kpblmid)*tvcon !Virt. pot. temp. at lowest model level + tvcon = 1.+EP_1*qv_curr(1) + thv2 = th(1)*tvcon !Virt. pot. temp. at lowest model level + qdiff = qv_curr(kpblmid)-qv_curr(1) + if( abs(qdiff) < reallysmall ) qdiff = sign(reallysmall,qdiff) +! slopeSfc = (thv-thv2) / qdiff +! Changed slopeSfc to use Bowen ratio + slopeSfc = hfx/(xlv * qfx) * xlv / cp ! Recall that hfx is in W m-2 and LH is also in W m-2 + tvcon = 1.+EP_1*qv_curr(min(kpbl+2,kte)) + thv = th(min(kpbl+2,kte))*tvcon + tvcon = 1.+EP_1*qv_curr(kpblmid) + thv2 = th(kpblmid)*tvcon + qdiff = qv_curr(min(kpbl+2,kte)) - qv_curr(kpblmid) + if( abs(qdiff) < reallysmall ) then + qdiff = sign(reallysmall,qdiff) + endif + slopeEZ = (thv-thv2) / qdiff + ! Calculate the standard deviations along the theta and + ! mixing ratio axes of the PDF following Berg and Stull (2004) + ! eqs. 17a and 17b. For sigmaSfc, we currently are only using + ! rstar and not rstarNew. + ! For sigmaEZ, reuse the flux var that contains (w'thetav')bar + sigmaEz = flux/wStar* & + ( 2. + (8.2e-4)* & + (zagl(kpblmid)/pblh)**(-1.8) ) ! Changed by lkb, 1/21/09 to use kpblmid + !!(zagl(min(kpbl+2,kte))/pblh)**(-1.8) ) + + flux = qfx/rho(1) !badbad /xlv ! (w'qv')bar +!!$ sigmaSfc(i,j) = flux*(1-zagl(1)/pblh(i,j))/wStar * & +!!$ ( 2.3 + 1.1e-2*(zagl(1)/pblh(i,j))**(-1.6) ) + sigmaSfc = flux/wStar * & + ( 2.3 + 1.1e-2*(zagl(kpblmid)/pblh)**(-1.6) ) + +#if 0 + ! + ! Output the inputs to CuP for debugging with offline code... + ! + call wrf_message("Outputting cupin file.") + k = 0 +#ifdef ( DM_PARALLEL ) && !defined( STUBMPI ) + CALL MPI_Comm_rank ( MPI_COMM_WORLD, k, ierr ) !this isn't tested with MPI yet +#endif + write(filename, '("cupin.",i3.3,".txt")') k + fout = 17 + do !Make sure we use an available unit. + inquire(UNIT=fout,OPENED=ierr) + if( ierr==.true. ) exit + fout = fout + 1 + if( fout > 100 ) exit + end do + open(UNIT=fout, FILE=trim(filename), FORM="formatted", & + STATUS="unknown", IOSTAT=k) + if( k /= 0 ) call wrf_error_fatal("Could not open cupin file.") + + write(UNIT=fout,FMT='(a)') "Inputs to cup_driver..." +!!$ write(UNIT=fout,FMT='("ktau,i,j=",i,2i5)') ktau, i, j +!!$ write(UNIT=fout,FMT='("stepcu, dt=",i,g17.9)') stepcu, dt +!!$ write(UNIT=fout,FMT='("ids,ide, jds, jde, kds, kde=",6i5)') & +!!$ ids,ide, jds, jde, kds, kde +!!$ write(UNIT=fout,FMT='("ims,ime, jms, jme, kms, kme=",6i5)') & +!!$ ims,ime, jms, jme, kms, kme +!!$ write(UNIT=fout,FMT='("its,ite, jts, jte, kts, kte=",6i5)') & +!!$ its,ite, jts, jte, kts, kte + + write(UNIT=fout,FMT='("sf_sfclay_physics =",i)') sf_sfclay_physics + write(UNIT=fout,FMT='("dx =",g17.9)') dx + write(UNIT=fout,FMT='("psfc =",g17.9)') psfc + write(UNIT=fout,FMT='("kpbl =",i)') kpbl + write(UNIT=fout,FMT='("pblh =",g17.9)') pblh + write(UNIT=fout,FMT='("ht =",g17.9)') ht + write(UNIT=fout,FMT='("tsk =",g17.9)') tsk + write(UNIT=fout,FMT='("t2 =",g17.9)') t2 + write(UNIT=fout,FMT='("q2 =",g17.9)') q2 + write(UNIT=fout,FMT='("hfx =",g17.9)') hfx + write(UNIT=fout,FMT='("qfx =",g17.9)') qfx + write(UNIT=fout,FMT='("mavail =",g17.9)') mavail + write(UNIT=fout,FMT='("br =",g17.9)') br + write(UNIT=fout,FMT='("regime =",g17.9)') regime + + write(UNIT=fout,FMT='("p,rho, t, th, qv:")') + do k=kts,kte + write(UNIT=fout,FMT='(" ",5g17.9)') & + p(k), rho(k), t(k), th(k), qv_curr(k) + end do + + write(UNIT=fout,FMT='("z, dz8w, u, v:")') + do k=kts,kte + write(UNIT=fout,FMT='(" ",4g17.9)') & + z(k), dz8w(k), u(k), v(k) + end do + + write(UNIT=fout,FMT='(a)') "Calculated inside cup_driver..." + write(UNIT=fout,FMT='("slopeSfc =",g17.9)') SlopeSfc + write(UNIT=fout,FMT='("slopeEZ =",g17.9)') SlopeEZ + write(UNIT=fout,FMT='("sigmaSfc =",g17.9)') sigmaSfc + write(UNIT=fout,FMT='("sigmaEZ =",g17.9)') sigmaEZ + write(UNIT=fout,FMT='("wStar =",g17.9)') wStar + write(UNIT=fout,FMT='("dtcu =",g17.9)') dtcu + + write(UNIT=fout,FMT='("zagl:")') + do k=kts,kte + write(UNIT=fout,FMT='(" ",1g17.9)') & + zagl(k) + end do + + close(UNIT=fout) +#endif +END SUBROUTINE cupSlopeSigma + + +!------------------------------------------------------------------------ +! Find Cp for moist air +! +FUNCTION findCp(r) + implicit none + real :: findCp + real, intent(in) :: r ! Mixing ratio + + findCp = 1004.67 * (1.0 + 0.84 * r) +END FUNCTION findCp + + +!------------------------------------------------------------------------ +! Finds the index when an ordered list becomes bigger than a given value. +! The list is assumed to be ordered from small to big values. +FUNCTION findIndex(value,list) + implicit none + integer :: findindex + real, intent(in) :: value + real, intent(in), dimension(:) :: list + + integer :: i + + findindex = 0 + do i=1,ubound(list,1) + if( value <= list(i) ) then + findindex = i + exit + end if + end do +END FUNCTION findIndex + +!------------------------------------------------------------------------ +! Find the saturation mixing ratio w.r.t. water. This subroutine uses +! Teten's formula. +! T in K and p in hPa +FUNCTION findRs(t,p) + real :: findRs + real, intent(in) :: t, p + real :: es + + es = 610.78 * exp( 17.67 * (t - 273.16) / (t - 29.66)) + findRs = eps * es / (p - es) +END FUNCTION findRs + + +!------------------------------------------------------------------------ +! Find the saturation mixing ratio w.r.t. ice. +! T in K and p in hPa +FUNCTION findRsi(t,p) + real :: findRsi + real, intent(in) :: t, p + real :: esi + +! WMO formula: +! esi = 10.**(-9.09685*(273.15/t - 1.) - 3.56654*log10(273.15/t) & +! + 0.87682*(1. - t/273.15) + 0.78614) + +! GoffGratch formula: + esi = 10**(-9.09718*(273.15/t - 1.) - 3.56654*log10(273.15/t) & + + 0.876793*(1. - t/273.15) + log10(6.1071)) + + findRsi = eps * esi / (p - esi) +END FUNCTION findRsi + + +!------------------------------------------------------------------------ + subroutine activate_cldbase_kfcup( idiagee, grid_id, ktau, & + ii, jj, kk, kts, kte, lc, kcldlayer, & + num_chem, maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + ntype_aer, nsize_aer, ncomp_aer, & + ai_phase, msectional, massptr_aer, numptr_aer, & + dlo_sect, dhi_sect, dens_aer, hygro_aer, sigmag_aer, & + tk_act, rho_act, dp, w_act, & + chem1d, qndrop_act ) + + use module_mixactivate, only: activate + + integer, intent(in) :: & + idiagee, grid_id, ktau, & + ii, jj, kk, kts, kte, lc, kcldlayer, & + num_chem, maxd_acomp, maxd_aphase, maxd_atype, maxd_asize, & + msectional, ntype_aer, ai_phase + integer, intent(in) :: ncomp_aer(maxd_atype), nsize_aer(maxd_atype) + integer, intent(in) :: massptr_aer(maxd_acomp,maxd_asize,maxd_atype,maxd_aphase) + integer, intent(in) :: numptr_aer(maxd_asize,maxd_atype,maxd_aphase) + + real, intent(in ) :: chem1d(kts:kte,1:num_chem) + real, intent(in ) :: dens_aer(maxd_acomp,maxd_atype) + real, intent(in ) :: dlo_sect(maxd_asize,maxd_atype), dhi_sect(maxd_asize,maxd_atype) + real, intent(in ) :: dp(kts:kte) + real, intent(in ) :: hygro_aer(maxd_acomp,maxd_atype) + real, intent(inout) :: qndrop_act + real, intent(in ) :: rho_act + real, intent(in ) :: sigmag_aer(maxd_asize,maxd_atype) + real, intent(in ) :: tk_act + real, intent(in ) :: w_act + + integer :: icomp, iphase, isize, itype, k, l + + real :: flux_fullact + real :: tmpa, tmpdpsum, tmpvol, tmpwght + real, dimension( 1:maxd_asize, 1:maxd_atype ) :: & + fn, fs, fm, fluxn, fluxs, fluxm, & + hygroavg, numbravg, volumavg + +! +! for each isize and itype, calculate average number, volume, and hygro +! over the updraft source layers +! +! if (idiagee > 0) write(98,'(//a,5i5)') 'kfcup activate_cldbase_kfcup - i, j, ksrc1/2', i, j, lc, kcldlayer + hygroavg(:,:) = 0.0 + numbravg(:,:) = 0.0 + volumavg(:,:) = 0.0 + tmpdpsum = sum( dp(lc:kcldlayer) ) + iphase = ai_phase + do k = lc, kcldlayer + tmpwght = dp(k)/tmpdpsum + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + l = numptr_aer(isize,itype,iphase) + numbravg(isize,itype) = numbravg(isize,itype) + tmpwght*max( 0.0, chem1d(k,l) ) + do icomp = 1, ncomp_aer(itype) + l = massptr_aer(icomp,isize,itype,iphase) + tmpvol = max( 0.0, chem1d(k,l) ) / dens_aer(icomp,itype) + volumavg(isize,itype) = volumavg(isize,itype) + tmpwght*tmpvol + hygroavg(isize,itype) = hygroavg(isize,itype) + tmpwght*tmpvol*hygro_aer(icomp,itype) + end do + end do ! isize + end do ! itype + end do ! k + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + hygroavg(isize,itype) = hygroavg(isize,itype) / max( 1.0e-35, volumavg(isize,itype) ) +! convert numbravg from (#/kg) to (#/m3) + numbravg(isize,itype) = numbravg(isize,itype)*rho_act +! convert volumavg to (m3/m3) -- need 1e-12 factor because (rho_act*chem1d)/dens_aer = [(ugaero/m3air)/(gaero/cm3aero)] + volumavg(isize,itype) = volumavg(isize,itype)*rho_act*1.0e-12 + +! if (vaero_dsect_adjust_opt == 1) then +! recalc volumavg using particle diameter = dcen_sect +! tmpvol = sqrt( dlo_sect(isize,itype) * dhi_sect(isize,itype) ) * 1.0e-2 ! particle diameter in (m) +! tmpvol = (tmpvol**3) * 3.1415926536/6.0 ! particle volume in (m3) +! volumavg(isize,itype) = numbravg(isize,itype) * tmpvol +! end if + end do ! isize + end do ! itype + +! adjust number and volume for scm sensitivity testing +! numbravg(:,:) = numbravg(:,:) * max( naero_adjust_factor, 1.0e-2 ) +! volumavg(:,:) = volumavg(:,:) * max( naero_adjust_factor, 1.0e-2 ) + + call activate( w_act, 0.0, 0.0, 0.0, 1.0, tk_act, rho_act, & + msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & + numbravg, volumavg, dlo_sect, dhi_sect, sigmag_aer, hygroavg, & + fn, fs, fm, fluxn, fluxs, fluxm, flux_fullact, & + grid_id, ktau, ii, jj, kk ) + +! subroutine activate( wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & +! msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & +! na, volc, dlo_sect, dhi_sect, sigman, hygro, & +! fn, fs, fm, fluxn, fluxs, fluxm, flux_fullact, & +! grid_id, ktau, ii, jj, kk ) +! mks units +! +! input +! integer,intent(in) :: maxd_atype ! dimension of types +! integer,intent(in) :: maxd_asize ! dimension of sizes +! integer,intent(in) :: ntype_aer ! number of types +! integer,intent(in) :: nsize_aer(maxd_atype) ! number of sizes for type +! integer,intent(in) :: msectional ! 1 for sectional, 0 for modal +! integer,intent(in) :: grid_id ! WRF grid%id +! integer,intent(in) :: ktau ! WRF time step count +! integer,intent(in) :: ii, jj, kk ! i,j,k of current grid cell +! real,intent(in) :: wbar ! grid cell mean vertical velocity (m/s) +! real,intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) +! real,intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) +! real,intent(in) :: wminf ! minimum updraft velocity for integration (m/s) +! real,intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) +! real,intent(in) :: tair ! air temperature (K) +! real,intent(in) :: rhoair ! air density (kg/m3) +! real,intent(in) :: na(maxd_asize,maxd_atype) ! aerosol number concentration (/m3) +! real,intent(in) :: sigman(maxd_asize,maxd_atype) ! geometric standard deviation of aerosol size distribution +! real,intent(in) :: hygro(maxd_asize,maxd_atype) ! bulk hygroscopicity of aerosol mode +! real,intent(in) :: volc(maxd_asize,maxd_atype) ! total aerosol volume concentration (m3/m3) +! real,intent(in) :: dlo_sect( maxd_asize, maxd_atype ), & ! minimum size of section (cm) +! dhi_sect( maxd_asize, maxd_atype ) ! maximum size of section (cm) +! +! output +! real,intent(inout) :: fn(maxd_asize,maxd_atype) ! number fraction of aerosols activated +! real,intent(inout) :: fs(maxd_asize,maxd_atype) ! surface fraction of aerosols activated +! real,intent(inout) :: fm(maxd_asize,maxd_atype) ! mass fraction of aerosols activated +! real,intent(inout) :: fluxn(maxd_asize,maxd_atype) ! flux of activated aerosol number fraction into cloud (m/s) +! real,intent(inout) :: fluxs(maxd_asize,maxd_atype) ! flux of activated aerosol surface fraction (m/s) +! real,intent(inout) :: fluxm(maxd_asize,maxd_atype) ! flux of activated aerosol mass fraction into cloud (m/s) +! real,intent(inout) :: flux_fullact ! flux when activation fraction = 100% (m/s) + + qndrop_act = 0.0 + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + qndrop_act = qndrop_act + numbravg(isize,itype)*fn(isize,itype) + tmpa = max( numbravg(isize,itype), max(volumavg(isize,itype),1.0)*1.0e-30 ) + tmpa = (6.0*volumavg(isize,itype)/(3.1415926536*tmpa))**0.33333333 + if (idiagee > 0) write(98,'(a,2i3,1p,9e10.2)') 'bin, numbr, volum, hygro, sg, dlo, dav, dhi, fn, fm', itype, isize, & + numbravg(isize,itype), volumavg(isize,itype), hygroavg(isize,itype), & + sigmag_aer(isize,itype), 0.01*dlo_sect(isize,itype), tmpa, 0.01*dhi_sect(isize,itype), & + fn(isize,itype), fm(isize,itype) + end do ! isize + end do ! itype + qndrop_act = qndrop_act/rho_act + if (idiagee > 0) write(98,'(a,21x,i6,1p,2e10.2)') 'msectional, w_act, qndrop', msectional, w_act, qndrop_act + + return + end subroutine activate_cldbase_kfcup + + +!------------------------------------------------------------------------ + subroutine adjust_mfentdet_kfcup( idiagee, grid_id, ktau, & + ii, jj, kts, kte, kcutop, ishall, & + umfout, uerout, udrout, dmfout, derout, ddrout ) + + integer, intent(in) :: & + idiagee, grid_id, ktau, & + ii, jj, kts, kte, kcutop, ishall + + real, dimension( kts:kte ), intent(inout) :: & + umfout, uerout, udrout, dmfout, derout, ddrout + + integer :: k + real, parameter :: rtol = 1.0e-6 + real :: tmpa, tmpb, tmpc, tmpf, tmpg, tmph, tmpold + + +! check that delta(dmfout) = derout - ddrout +! if not, then adjust either derout or ddrout +! the diagnostic output shows these adjustments to be very small, +! so this may be unnecessary +check_dmf: & + if (ishall == 0) then + + dmfout(kcutop:kte) = 0.0 + if (kcutop < kte) then + derout(kcutop+1:kte) = 0.0 + ddrout(kcutop+1:kte) = 0.0 + end if + tmpg = 0.0 + + do k = kts, kcutop + tmpa = dmfout(k) + if (k > kts) then + tmpa = dmfout(k) - dmfout(k-1) + else + tmpa = dmfout(k) + end if + tmpb = derout(k) - ddrout(k) + tmpc = tmpa - tmpb + if (tmpc > 0.0) then + if (derout(k) < ddrout(k)*0.05) then + ! der << ddr, so decrease ddr first, then increase der if needed + tmpold = ddrout(k) + ddrout(k) = max( 0.0, ddrout(k) - tmpc ) + tmpg = tmpg + abs(ddrout(k)-tmpold) + tmpb = derout(k) - ddrout(k) + tmpc = tmpa - tmpb + derout(k) = derout(k) + tmpc + tmpg = tmpg + abs(tmpc) + else + ! just increase der + derout(k) = derout(k) + tmpc + tmpg = tmpg + abs(tmpc) + end if + else + if (ddrout(k) <= derout(k)*0.05) then + ! ddr << der, so decrease der first, then increase ddr if needed + tmpold = derout(k) + derout(k) = max( 0.0, derout(k) + tmpc ) + tmpg = tmpg + abs(derout(k)-tmpold) + tmpb = derout(k) - ddrout(k) + tmpc = tmpa - tmpb + ddrout(k) = ddrout(k) - tmpc + tmpg = tmpg + abs(tmpc) + else + ! just increase ddr + ddrout(k) = ddrout(k) - tmpc + tmpg = tmpg + abs(tmpc) + end if + end if + end do + + if ( idiagee > 0 ) then + tmpf = sum(derout(kts:kcutop)) + sum(ddrout(kts:kcutop)) + tmph = tmpg/max(tmpg,tmpf,1.0e-20) + if (abs(tmph) > rtol) & + write(*,'(a,i9,2i5,1p,4e10.2)') 'kfcupmfadjup', ktau, ii, jj, & + minval(dmfout(kts:kcutop)), tmpf, tmpg, tmph + end if + + end if check_dmf + +! check that delta(umfout) = uerout - udrout +! if not, then adjust either uerout or udrout +! the diagnostic output shows these adjustments to mostly be very small, +! but there is an occasional problem at klcl, +! this suggests a problem in the code that calculates umf and uer, +! but i have not been able to locate it, so this bandaid is needed +check_umf: & + if ((ishall == 0) .or. (ishall == 1)) then + + umfout(kcutop:kte) = 0.0 + if (kcutop < kte) then + uerout(kcutop+1:kte) = 0.0 + udrout(kcutop+1:kte) = 0.0 + end if + tmpg = 0.0 + + do k = kts, kcutop + if (k > kts) then + tmpa = umfout(k) - umfout(k-1) + else + tmpa = umfout(k) + end if + tmpb = uerout(k) - udrout(k) + tmpc = tmpa - tmpb + if (tmpc > 0.0) then + if (uerout(k) < udrout(k)*0.05) then + ! uer << udr, so decrease udr first, then increase uer if needed + tmpold = udrout(k) + udrout(k) = max( 0.0, udrout(k) - tmpc ) + tmpg = tmpg + abs(udrout(k)-tmpold) + tmpb = uerout(k) - udrout(k) + tmpc = tmpa - tmpb + uerout(k) = uerout(k) + tmpc + tmpg = tmpg + abs(tmpc) + else + ! just increase uer + uerout(k) = uerout(k) + tmpc + tmpg = tmpg + abs(tmpc) + end if + else + if (udrout(k) <= uerout(k)*0.05) then + ! udr << uer, so decrease uer first, then increase udr if needed + tmpold = uerout(k) + uerout(k) = max( 0.0, uerout(k) + tmpc ) + tmpg = tmpg + abs(uerout(k)-tmpold) + tmpb = uerout(k) - udrout(k) + tmpc = tmpa - tmpb + udrout(k) = udrout(k) - tmpc + tmpg = tmpg + abs(tmpc) + else + ! just increase udr + udrout(k) = udrout(k) - tmpc + tmpg = tmpg + abs(tmpc) + end if + end if + end do + + if ( idiagee > 0 ) then + tmpf = sum(uerout(kts:kcutop)) + sum(udrout(kts:kcutop)) + tmph = tmpg/max(tmpg,tmpf,1.0e-20) + if (abs(tmph) > rtol) & + write(*,'(a,i9,2i5,1p,4e10.2)') 'kfcupmfadjup', ktau, ii, jj, & + maxval(umfout(kts:kcutop)), tmpf, tmpg, tmph + end if + + end if check_umf + + + return + end subroutine adjust_mfentdet_kfcup + + +! rce 11-may-2012 mods start ------------------------------------------- + subroutine cu_kfcup_diagee01( & + ims, ime, jms, jme, kms, kme, kts, kte, & + i, j, & + idiagee, idiagff, ishall, ktau, & + kcubotmin, kcubotmax, kcutopmin, kcutopmax, & + activefrac, cldfra_cup1d, & + cubot, cutop, cumshallfreq1d, & + ddr_deep, der_deep, dmf_deep, dt, dz1d, & + fcvt_qc_to_pr_deep, fcvt_qc_to_qi_deep, fcvt_qi_to_pr_deep, & + fcvt_qc_to_pr_shall, fcvt_qc_to_qi_shall, fcvt_qi_to_pr_shall, & + nca_deep, nca_shall, p1d, pblh, & + qc_ic_deep, qc_ic_shall, qi_ic_deep, qi_ic_shall, qndrop_ic_cup, rho1d, & + tactive, taucloud, tstar, & + udr_deep, udr_shall, uer_deep, uer_shall, umf_deep, umf_shall, & + updfra_deep, updfra_shall, updfra_cup, & + wact_cup, wcloudbase, wcb_v2, wcb_v2_shall, & + wulcl_cup, wstar, z1d, z_at_w1d ) + +! arguments + integer, intent(in) :: & + ims, ime, jms, jme, kms, kme, kts, kte, & + i, j, & + idiagee, idiagff, ishall, ktau, & + kcubotmin, kcubotmax, kcutopmin, kcutopmax + + real, intent(in) :: & + dt, & + nca_deep, & + nca_shall, & + updfra_deep, & + updfra_shall, & + wcb_v2, & + wcb_v2_shall, & + wstar + + real, dimension( kts:kte ), intent(in) :: & + cumshallfreq1d, & + cldfra_cup1d, & + ddr_deep, & + der_deep, & + dmf_deep, & + dz1d, & + fcvt_qc_to_pr_deep, & + fcvt_qc_to_pr_shall, & + fcvt_qc_to_qi_deep, & + fcvt_qc_to_qi_shall, & + fcvt_qi_to_pr_deep, & + fcvt_qi_to_pr_shall, & + p1d, & + qc_ic_deep, & + qc_ic_shall, & + qi_ic_deep, & + qi_ic_shall, & + rho1d, & + udr_deep, & + udr_shall, & + uer_deep, & + uer_shall, & + umf_deep, & + umf_shall, & + z1d, & + z_at_w1d + + real, dimension( ims:ime, jms:jme ), intent(in) :: & + activefrac, & + cubot, & + cutop, & + pblh, & + tactive, & + taucloud, & + tstar, & + wact_cup, & + wcloudbase, & + wulcl_cup + + real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: & + qndrop_ic_cup, & + updfra_cup + + +! local variables + integer :: & + k, kcubot, kcutop + + real :: tmpa, tmpb, tmpc, tmpd, tmpe, tmpf, tmpg, tmph, tmpi, tmpj + real :: tmpr, tmps, tmpx, tmpy, tmpz + real :: tmpcf + real :: tmp_nca, tmp_updfra + real :: tmpveca(1:999) + real :: updfra + + if (idiagee > 0) then + + tmpveca = 0.0 + + kcubot = nint(cubot(i,j)) + kcutop = nint(cutop(i,j)) + k = (kcubot+kcutop)/2 + updfra = 0.0 ; if (ishall == 0) updfra = updfra_deep ; if (ishall == 1) updfra = updfra_shall +!!! write(*,'(a,1p,5e11.3,3x,3e11.3)') 'activefrac, cldfra(b/m/t), updfra', & +!!! activefrac(i,j), & +!!! cldfra_cup1d(kcubot), cldfra_cup1d(k), cldfra_cup1d(kcutop), updfra +!!! write(*,'(a,1p,4e11.3,3x,3e11.3)') 'wcb, wcb_v2, wulcl, wact ', & +!!! wcloudbase(i,j), wcb_v2_shall, wulcl_cup(i,j), wact_cup(i,j) +!!! write(*,'(a,1p,5e11.3,3x,3e11.3)') 'qndrop(b/m/t/t-b) ', & +!!! qndrop_ic_cup(kcubot), qndrop_ic_cup(k), qndrop_ic_cup(kcutop), & +!!! qndrop_ic_cup(kcutop)-qndrop_ic_cup(kcubot) +!!! write(*,'(a,4i5,f9.5,10(2x,5i5))') 'updfraprofile*1e4', & +!!! ktau, ishall, kcubot, kcutop, updfra, & +!!! ( nint(updfra_cup(i,k,j)*1.0e4), k=kts,min(kte-1,kcutop+3) ) + + if ((ishall==1 .or. ishall==0) .and. idiagee>0) then + if (ishall == 1) then + tmp_updfra = updfra_shall + tmp_nca = nca_shall + else + tmp_updfra = updfra_deep + tmp_nca = nca_deep + end if + + tmpa = 0.0 ; tmpb = 0.0 ; tmpc = 0.0 ; tmpd = 0.0 ; tmpe = 0.0 ; tmpf = 0.0 + do k=kts,kte + if (ishall == 1) then + tmpa = tmpa + max( 0.0, uer_shall(k) ) + tmpx = cumshallfreq1d(k) + else + tmpa = tmpa + max( 0.0, uer_deep(k) ) + tmpx = 1.0 + end if + tmpcf = cldfra_cup1d(k)*tmpx + tmpc = tmpc + max( 0.0, tmpcf ) * dz1d(k)*rho1d(k) +! tmpd = tmpd + max( 0.0, cldfra_cup(i,k,j) ) * dz1d(k)*rho1d(k) + tmpd = tmpd + max( 0.0, cldfra_cup1d(k) ) * dz1d(k)*rho1d(k) + + tmpe = tmpe + max( 0.0, tmp_updfra*tmpx ) * dz1d(k)*rho1d(k) + if (kcubot <= k .and. k <= kcutop) & + tmpf = tmpf + max( 0.0, tmp_updfra ) * dz1d(k)*rho1d(k) + end do + tmpa = tmpa*tmp_nca + tmpb = cldfra_cup1d(kcubot)*wcb_v2*rho1d(kcubot)*tmp_nca +! tmpg = 0.0 +! if (tmpd > 1.0e-10) tmpg = tmpa/tmpd + +! if (idiagee>0) write(*,'(a,1p,6e11.3,0p,f11.3,i8)') 'entrain mass, cloud-vol mass b-e ', & +! tmpa, tmpf, tmpd, tmpe, tmpb, tmpc, tmpg, ktau + if (idiagee>0) write(*,'(a,1p,2e11.3,0p,2f9.3,2(3x,1p,2e11.3,0p,f9.3),i8,2(2x,3i3))') 'cloudmassaa ', & + tmpa, tmpb, & + tmpa/max(tmpc,1.0e-10), tmpb/max(tmpc,1.0e-10), & + tmpc, tmpd, max(tmpc,1.0e-10)/max(tmpd,1.0e-10), & + tmpe, tmpf, max(tmpe,1.0e-10)/max(tmpf,1.0e-10), & + ktau, kcubot, kcubotmin, kcubotmax, kcutop, kcutopmin, kcutopmax + + tmpi = 0.0 ; tmpj = 0.0 + do k = kcubot, kcutop + if (ishall == 1) then + tmpi = tmpi + cldfra_cup1d(k)*dz1d(k)*rho1d(k)*qc_ic_shall(k) + else + tmpi = tmpi + cldfra_cup1d(k)*dz1d(k)*rho1d(k)*qc_ic_deep(k) + end if + tmpj = tmpj + cldfra_cup1d(k)*dz1d(k)*rho1d(k) + end do + + tmpveca(1) = tmpa/max(tmpd,1.0e-10) + tmpveca(2) = tmpb/max(tmpd,1.0e-10) + tmpveca(3) = cldfra_cup1d(kcubot) + tmpveca(4) = sum( dz1d(kcubot:kcutop) ) + tmpveca(5) = wcb_v2 + + tmpa = tmpa/tmp_nca ! total inflow + tmpg = tmpd * (tmp_updfra/cldfra_cup1d(kcubot)) ! updraft mass + tmpveca(101) = cldfra_cup1d(kcubot) + tmpveca(102) = tmp_updfra + tmpveca(103) = sum( dz1d(kcubot:kcutop) ) + tmpveca(104) = wcb_v2 ! w at cloud base + tmpveca(105) = tmpd ! cloud mass + tmpveca(106) = tmpa ! total inflow + if (ishall == 1) then + tmpveca(107) = umf_shall(max(1,kcubot-1)) ! cloud base inflow + else + tmpveca(107) = umf_deep(max(1,kcubot-1)) ! cloud base inflow + end if + tmpveca(108) = tmpg/tmpa ! time to "fill" updraft + tmpveca(109) = tmpd/tmpa ! time to "fill" cloud + tmpveca(110) = tactive(i,j) ! active cloud time-scale + tmpveca(111) = taucloud(i,j) ! cloud dissipation time-scale + tmpveca(112) = tstar(i,j) ! boundary layer time-scale + tmpveca(113) = wstar ! boundary layer convective velocity scale + tmpveca(114) = pblh(i,j) ! pbl height (m) + tmpveca(115) = z_at_w1d(kcubot ) - z_at_w1d(kts) ! bottom of cloudbase layer (m agl) + tmpveca(116) = z_at_w1d(kcutop+1) - z_at_w1d(kts) ! top of cloudtop layer (m agl) + tmpveca(117) = (tmpi/max(tmpj,1.0e-30))*1.0e3 ! convert kg/kg to g/kg + + tmpveca(106:107) = tmpveca(106:107)*60.0 ! convert kg/m2/s to kg/m2/min + tmpveca(108:112) = tmpveca(108:112)/60.0 ! convert s to min + end if ! ((ishall==1 .or. ishall==0) .and. idiagee>0) then + + if (idiagee>0 .and. ishall==1) then + write(*,'(a)') 'k, p, z, dz, umf, del(umf), uer-udr, uer, -udr, qc, qi, f_qc2qi, f_qc2pr, f_qi2pr' + do k = min( kcutop+2, kte-1 ), kts, -1 + if (k .eq. kts) then + tmpa = umf_shall(k) + else + tmpa = umf_shall(k) - umf_shall(k-1) + end if + tmpb = uer_shall(k) - udr_shall(k) + write(*,'(i2,1p,3e11.3,3x,5e11.3,3x,5e11.3)') & + k, p1d(k), z1d(k), dz1d(k), umf_shall(k), tmpa, tmpb, uer_shall(k), -udr_shall(k), & + qc_ic_shall(k), qi_ic_shall(k), fcvt_qc_to_qi_shall(k), fcvt_qc_to_pr_shall(k), fcvt_qi_to_pr_shall(k) + end do + end if ! (idiagee>0 .and. ishall==1) then + + if (idiagee>0 .and. ishall==0) then + write(*,'(a)') 'k, p, z, dz, umf, del(umf), uer-udr, uer, -udr, qc, qi, f_qc2qi, f_qc2pr, f_qi2pr' + do k = min( kcutop+2, kte-1 ), kts, -1 + if (k .eq. kts) then + tmpa = umf_deep(k) + else + tmpa = umf_deep(k) - umf_deep(k-1) + end if + tmpb = uer_deep(k) - udr_deep(k) + write(*,'(i2,1p,3e11.3,3x,5e11.3,3x,5e11.3)') & + k, p1d(k), z1d(k), dz1d(k), umf_deep(k), tmpa, tmpb, uer_deep(k), -udr_deep(k), & + qc_ic_deep(k), qi_ic_deep(k), fcvt_qc_to_qi_deep(k), fcvt_qc_to_pr_deep(k), fcvt_qi_to_pr_deep(k) + end do + write(*,'(a)') 'k, p, z, dz, dmf, del(dmf), der-ddr, der, -ddr, qc' + do k = min( kcutop+2, kte-1 ), kts, -1 + if (k .eq. kts) then + tmpa = dmf_deep(k) + else + tmpa = dmf_deep(k) - dmf_deep(k-1) + end if + tmpb = der_deep(k) - ddr_deep(k) + write(*,'(i2,1p,3e11.3,3x,5e11.3,3x,5e11.3)') & + k, p1d(k), z1d(k), dz1d(k), dmf_deep(k), tmpa, tmpb, der_deep(k), -ddr_deep(k), qc_ic_deep(k) + end do + end if ! (idiagee>0 .and. ishall==0) then + + write(*,'(i6,1p,6e11.3,a)') & + ktau, (ktau*dt/3600.0), tmpveca(1:5), & + ' cloudmassbb ktau, t(h), ratio1, ratio2, cldfra, cldhgt, wcb' + + write(*,'(i6,i2, f7.2, 2x,2f8.5,f8.2,2f7.3, 2x,f9.4,2f9.5, 2x,5f8.2, 3f9.1,f9.5, 3a)') & + ktau, ishall, (ktau*dt/3600.0), tmpveca(101:104), tmpveca(113), & + min(9999.99,tmpveca(105)), min(99.99,tmpveca(106:107)), & + min(9999.99,tmpveca(108:112)), min(99999.9,tmpveca(114:116)), min(99.9999,tmpveca(117)), & + ' cloudmasscc ktau,ish,t(h), cldfra,updfra,cldhgt,wcb,wstar', & + ', cldmass,uertot,uerbase, tauinupd,tauincld,tactive,taucloud,tstar', & + ', pblh,zbot,ztop, qc_ic_av' + + end if ! (idiagee > 0) then + + return + end subroutine cu_kfcup_diagee01 +! rce 11-may-2012 mods end --------------------------------------------- + + +END MODULE module_cu_kfcup diff --git a/wrfv2_fire/phys/module_cu_kfeta.F b/wrfv2_fire/phys/module_cu_kfeta.F index dbf9173f..63319f85 100644 --- a/wrfv2_fire/phys/module_cu_kfeta.F +++ b/wrfv2_fire/phys/module_cu_kfeta.F @@ -1561,7 +1561,7 @@ SUBROUTINE KF_eta_PARA (I, J, & ! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS WRITE(message,1035)PEF,PEFCBH,LC,LET,WKL,VWS CALL wrf_message( message ) -! call flush(98) +! flush(98) endif ! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS !***************************************************************** @@ -1751,7 +1751,7 @@ SUBROUTINE KF_eta_PARA (I, J, & ! write(98,*)'PRECIP EFFICIENCY =',PEFF write(message,*)'PRECIP EFFICIENCY =',PEFF CALL wrf_message(message) -! call flush(98) +! flush(98) ENDIF ! ! @@ -2294,7 +2294,7 @@ SUBROUTINE KF_eta_PARA (I, J, & ! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC WRITE(message,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC CALL wrf_message(message) -! call flush(98) +! flush(98) endif ! !...SEND FINAL PARAMETERIZED VALUES TO OUTPUT FILES... @@ -2331,7 +2331,7 @@ SUBROUTINE KF_eta_PARA (I, J, & call wrf_message(message) write(message,*)'just before DO 300...' call wrf_message(message) -! call flush(98) +! flush(98) DO NK=1,LTOP K=LTOP-NK+1 DTT=(TG(K)-T0(K))*86400./TIMEC @@ -2440,7 +2440,7 @@ SUBROUTINE KF_eta_PARA (I, J, & WRITE(98,4456)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k) 311 CONTINUE -! call flush(98) +! flush(98) ! GOTO 297 ! STOP 'QVERR' @@ -2546,7 +2546,7 @@ SUBROUTINE KF_eta_PARA (I, J, & ! write (6,909)I,J,RNC ! WRITE(98,*)'at NTSD =',NTSD,',No. of KF points activated =', ! * NCCNT -! call flush(98) +! flush(98) 1000 FORMAT(' ',10A8) 1005 FORMAT(' ',F6.0,2X,F6.4,2X,F7.3,1X,F6.4,2X,4(F6.3,2X),2(F7.3,1X)) 1010 FORMAT(' ',' VERTICAL VELOCITY IS NEGATIVE AT ',F4.0,' MB') @@ -2636,7 +2636,7 @@ SUBROUTINE TPMIX2(p,thes,tu,qu,qliq,qice,qnewlq,qnewic,XLV1,XLV0) ithtb=int(tth)+1 IF(IPTB.GE.220 .OR. IPTB.LE.1 .OR. ITHTB.GE.250 .OR. ITHTB.LE.1)THEN write(98,*)'**** OUT OF BOUNDS *********' -! call flush(98) +! flush(98) ENDIF ! t00=ttab(ithtb ,iptb ) diff --git a/wrfv2_fire/phys/module_cu_mskf.F b/wrfv2_fire/phys/module_cu_mskf.F new file mode 100644 index 00000000..3593f88c --- /dev/null +++ b/wrfv2_fire/phys/module_cu_mskf.F @@ -0,0 +1,3336 @@ +MODULE module_cu_mskf + + USE module_wrf_error + +! +!ckay=Kiran Alapaty, EPA +! +!multi-scale KF scheme +! (1) With diagnosed deep and shallow KF cloud fraction using +! CAM3-CAM5 methodology, along with captured liquid and ice condensates. +! and linking with the RRTMG & Other radiation schemes +! (2) Scale-dependent Dynamic adjustment timescale for KF clouds (both shallow and deep) +! (3) Scale-dependent LCL-based entrainment Methodology that avoids 2-km cloud radius method +! (4) Scale-dependent Fallout Rate +! (5) Scale-dependent Stabilization Capacity +! (6) Elimination of "double counting" when environment is saturated +! (7) Estimation and feeback of updraft vertical velocities back +! to gridscale vertical velocities +! (8) new Trigger function based on Bechtold method -- scale dependent +! +! Alapaty et al., 2012: Introducing subgrid-scale cloud feedbacks to radiation +! for regional meteorological and climate modeling. GRL, V39, I24. +! +! Alapaty et al., 2013: The Kain-Fritsch Scheme: Science Updates and revisiting +! gray-scale issues from the NWP and regional climate perspectives. 2013 WRF +! workshop: URL: http://www.mmm.ucar.edu/wrf/users/workshops/WS2013/ppts/9.2.pdf +! +! Herwehe et al., 2014: Increasing the credibility of regional climate simulations +! by introducing subgrid-scale cloud-radiation interactions. JGR, 119, +! 5317-5330, doi:10.1002/2014JD021504. +! +! Zheng et al., 2015: Improving High-Resolution Weather Forecasts using the +! Weather Research and Forecasting (WRF) Model with an Updated Kain-Fritsch +! Scheme. Revision - Mon. Wea. Rev. +!ckay +!-------------------------------------------------------------------- +! Lookup table variables: + INTEGER, PARAMETER :: KFNT=250,KFNP=220 + REAL, DIMENSION(KFNT,KFNP),PRIVATE, SAVE :: TTAB,QSTAB + REAL, DIMENSION(KFNP),PRIVATE, SAVE :: THE0K + REAL, DIMENSION(200),PRIVATE, SAVE :: ALU + REAL, PRIVATE, SAVE :: RDPR,RDTHK,PLUTOP +! Note: KF Lookup table is used by subroutines KF_eta_PARA, TPMIX2, +! TPMIX2DD, ENVIRTHT +! End of Lookup table variables: + +CONTAINS + + SUBROUTINE MSKF_CPS( & + ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,trigger & + ,DT,KTAU,DX,CUDT,ADAPT_STEP_FLAG & + ,rho,RAINCV,PRATEC,NCA & + ,U,V,TH,T,W,dz8w,Pcps,pi & + ,W0AVG,XLV0,XLV1,XLS0,XLS1,CP,R,G,EP1 & + ,EP2,SVP1,SVP2,SVP3,SVPT0 & + ,STEPCU,CU_ACT_FLAG,warm_rain,CUTOP,CUBOT & + ,QV & + ! optionals + ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & + ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN & + ,RQICUTEN,RQSCUTEN, RQVFTEN & +!ckay + ,cldfra_dp_KF,cldfra_sh_KF,w_up & + ,qc_KF,qi_KF & + ,ZOL,WSTAR,UST,PBLH & !ckay + ) +! +!------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------- + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: trigger + INTEGER, INTENT(IN ) :: STEPCU + LOGICAL, INTENT(IN ) :: warm_rain + + REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1 + REAL, INTENT(IN ) :: CP,R,G,EP1,EP2 + REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 + + INTEGER, INTENT(IN ) :: KTAU + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + U, & + V, & +!ckay W, & + TH, & + T, & + QV, & + dz8w, & + Pcps, & + rho, & + pi +! + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: & + W0AVG + + REAL, INTENT(IN ) :: DT, DX + REAL, INTENT(IN ) :: CUDT + LOGICAL,OPTIONAL,INTENT(IN ) :: ADAPT_STEP_FLAG +! + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: RAINCV + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: PRATEC + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: NCA + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(OUT) :: CUBOT, & + CUTOP + + LOGICAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: CU_ACT_FLAG + +! +! Optional arguments +! + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + OPTIONAL, & + INTENT(INOUT) :: & + RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN, & + RQVFTEN +! +! Flags relating to the optional tendency arrays declared above +! Models that carry the optional tendencies will provdide the +! optional arguments at compile time; these flags all the model +! to determine at run-time whether a particular tracer is in +! use or not. +! + LOGICAL, OPTIONAL :: & + F_QV & + ,F_QC & + ,F_QR & + ,F_QI & + ,F_QS + +!ckay + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: & + cldfra_dp_KF, & + cldfra_sh_KF, & + qc_KF, & + qi_KF, & + W +!ckay + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT( IN) :: ZOL, & + WSTAR, & + UST, & + PBLH +!ckaywup + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ) , & + INTENT(INOUT) :: w_up + + +! LOCAL VARS + + LOGICAL :: flag_qr, flag_qi, flag_qs + + REAL, DIMENSION( kts:kte ) :: & + U1D, & + V1D, & + T1D, & + DZ1D, & + QV1D, & + P1D, & + RHO1D, & + tpart_v1D, & + tpart_h1D, & + W0AVG1D + + REAL, DIMENSION( kts:kte ):: & + DQDT, & + DQIDT, & + DQCDT, & + DQRDT, & + DQSDT, & + DTDT + + + REAL, DIMENSION (its-1:ite+1,kts:kte,jts-1:jte+1) :: aveh_t, aveh_q + REAL, DIMENSION (its:ite,kts:kte,jts:jte) :: aveh_qmax, aveh_qmin + REAL, DIMENSION (its:ite,kts:kte,jts:jte) :: avev_t, avev_q + REAL, DIMENSION (its:ite,kts:kte,jts:jte) :: avev_qmax, avev_qmin + REAL, DIMENSION (its:ite,kts:kte,jts:jte) :: coef_v, coef_h, tpart_h, tpart_v + INTEGER :: ii,jj,kk + + REAL :: ttop + REAL, DIMENSION (kts:kte) :: z0 + + REAL :: TST,tv,PRS,RHOE,W0,SCR1,DXSQ,tmp + integer :: ibegh,iendh,jbegh,jendh + integer :: istart,iend,jstart,jend + INTEGER :: i,j,k,NTST + REAL :: lastdt = -1.0 + REAL :: W0AVGfctr, W0fctr, W0den + +! + DXSQ=DX*DX + +!---------------------- + NTST=STEPCU + TST=float(NTST*2) + flag_qr = .FALSE. + flag_qi = .FALSE. + flag_qs = .FALSE. + IF ( PRESENT(F_QR) ) flag_qr = F_QR + IF ( PRESENT(F_QI) ) flag_qi = F_QI + IF ( PRESENT(F_QS) ) flag_qs = F_QS +! + if (lastdt < 0) then + lastdt = dt + endif + + if (ADAPT_STEP_FLAG) then + W0AVGfctr = 2 * MAX(CUDT*60,dt) - dt + W0fctr = dt + W0den = 2 * MAX(CUDT*60,dt) + else + W0AVGfctr = (TST-1.) + W0fctr = 1. + W0den = TST + endif + + DO J = jts,jte + DO K=kts,kte + DO I= its,ite +! SCR1=-5.0E-4*G*rho(I,K,J)*(w(I,K,J)+w(I,K+1,J)) +! TV=T(I,K,J)*(1.+EP1*QV(I,K,J)) +! RHOE=Pcps(I,K,J)/(R*TV) +! W0=-101.9368*SCR1/RHOE + W0=0.5*(w(I,K,J)+w(I,K+1,J)) + +! Old: +! +! W0AVG(I,K,J)=(W0AVG(I,K,J)*(TST-1.)+W0)/TST +! +! New, to support adaptive time step: +! + W0AVG(I,K,J) = ( W0AVG(I,K,J) * W0AVGfctr + W0 * W0fctr ) / W0den +!ckaywup + w(I,K,J)=w(I,K,J)+w_up(i,K,j) + + ENDDO + ENDDO + ENDDO + + + lastdt = dt + +! New trigger function + IF (trigger.eq.2) THEN +! +! calculate 9-point average of moisture advection and temperature using halo (Horizontal) +! + aveh_t=-999 ! horizontal 9-point ave + aveh_q=-999 + avev_t=0 ! vertical 3-level ave + avev_q=0 + avev_qmax=0 + avev_qmin=0 + aveh_qmax=0 + aveh_qmin=0 + tpart_h=0 + tpart_v=0 + coef_h=0 + coef_v=0 + ibegh=max(its-1, ids+1) ! start from 2 + jbegh=max(jts-1, jds+1) + iendh=min(ite+1, ide-2) ! end at ide-2 + jendh=min(jte+1, jde-2) + DO J = jbegh,jendh + DO K = kts,kte + DO I = ibegh,iendh + aveh_t(i,k,j)=(T(i-1,k,j-1)+T(i-1,k,j) +T(i-1,k,j+1)+ & + T(i,k,j-1) +T(i,k,j) +T(i,k,j+1)+ & + T(i+1,k,j-1) +T(i+1,k,j) +T(i+1,k,j+1))/9. + aveh_q(i,k,j)=(rqvften(i-1,k,j-1)+rqvften(i-1,k,j) +rqvften(i-1,k,j+1)+ & + rqvften(i,k,j-1) +rqvften(i,k,j) +rqvften(i,k,j+1)+ & + rqvften(i+1,k,j-1) +rqvften(i+1,k,j) +rqvften(i+1,k,j+1))/9. + ENDDO + ENDDO + ENDDO +! boundary value ( all processors will do the following? Or just those processsors handling sub-area including boundary) + DO K = kts,kte + DO J = jts-1,jte+1 + DO I = its-1,ite+1 + + if(i.eq.ids) then + aveh_t(i,k,j)=aveh_t(i+1,k,j) + aveh_q(i,k,j)=aveh_q(i+1,k,j) + elseif(i.eq.ide-1) then + aveh_t(i,k,j)=aveh_t(i-1,k,j) + aveh_q(i,k,j)=aveh_q(i-1,k,j) + endif + + if(j.eq.jds) then + aveh_t(i,k,j)=aveh_t(i,k,j+1) + aveh_q(i,k,j)=aveh_q(i,k,j+1) + elseif(j.eq.jde-1) then + aveh_t(i,k,j)=aveh_t(i,k,j-1) + aveh_q(i,k,j)=aveh_q(i,k,j-1) + endif + + if(j.eq.jds.and.i.eq.ids) then + aveh_q(i,k,j)=aveh_q(i+1,k,j+1) + aveh_t(i,k,j)=aveh_t(i+1,k,j+1) + endif + + if(j.eq.jde-1.and.i.eq.ids) then + aveh_q(i,k,j)=aveh_q(i+1,k,j-1) + aveh_t(i,k,j)=aveh_t(i+1,k,j-1) + endif + + if(j.eq.jde-1.and.i.eq.ide-1) then + aveh_q(i,k,j)=aveh_q(i-1,k,j-1) + aveh_t(i,k,j)=aveh_t(i-1,k,j-1) + endif + + if(j.eq.jds.and.i.eq.ide-1) then + aveh_q(i,k,j)=aveh_q(i-1,k,j+1) + aveh_t(i,k,j)=aveh_t(i-1,k,j+1) + endif + + ENDDO + ENDDO + ENDDO +! search for max/min moisture advection in 9-point range, calculate horizontal T-perturbation (tpart_h) + istart=max(its, ids+1) ! start from 2 + jstart=max(jts, jds+1) + iend=min(ite, ide-2) ! end at ide-2 + jend=min(jte, jde-2) + DO K = kts,kte + DO J = jstart,jend + DO I = istart,iend + aveh_qmax(i,k,j)=aveh_q(i,k,j) + aveh_qmin(i,k,j)=aveh_q(i,k,j) + DO ii=-1, 1 + DO jj=-1,1 + if(aveh_q(i+II,k,j+JJ).gt.aveh_qmax(i,k,j)) aveh_qmax(i,k,j)=aveh_q(i+II,k,j+JJ) + if(aveh_q(i+II,k,j+JJ).lt.aveh_qmin(i,k,j)) aveh_qmin(i,k,j)=aveh_q(i+II,k,j+JJ) + ENDDO + ENDDO + if(aveh_qmax(i,k,j).gt.aveh_qmin(i,k,j))then + coef_h(i,k,j)=(aveh_q(i,k,j)-aveh_qmin(i,k,j))/(aveh_qmax(i,k,j)-aveh_qmin(i,k,j)) + else + coef_h(i,k,j)=0. + endif + coef_h(i,k,j)=amin1(coef_h(i,k,j),1.0) + coef_h(i,k,j)=amax1(coef_h(i,k,j),0.0) + tpart_h(i,k,j)=coef_h(i,k,j)*(T(i,k,j)-aveh_t(i,k,j)) + ENDDO + ENDDO + ENDDO + 89 continue +! vertical 3-layer calculation + DO J = jts, jte + DO I = its, ite + z0(1) = 0.5 * dz8w(i,1,j) + DO K = 2, kte + Z0(K) = Z0(K-1) + .5 * (DZ8W(i,K,j) + DZ8W(i,K-1,j)) + ENDDO + DO K = kts+1,kte-1 + ttop = t(i,k,j) + ((t(i,k,j) - t(i,k+1,j)) / (z0(k) - z0(k+1))) * (z0(k)-z0(k-1)) + avev_t(i,k,j)=(T(i,k-1,j) + T(i,k,j) + ttop)/3. +! avev_t(i,k,j)=(T(i,k-1,j)+T(i,k,j) + T(i,k+1,j))/3. + avev_q(i,k,j)=(rqvften(i,k-1,j)+rqvften(i,k,j) + rqvften(i,k+1,j))/3. + ENDDO + avev_t(i,kts,j)=avev_t(i,kts+1,j) ! lowest level value, is it the same as avev_t(i,kds,j)=avev_t(i,kds+1,j)? + avev_q(i,kts,j)=avev_q(i,kts+1,j) + avev_t(i,kte,j)=avev_t(i,kte-1,j) ! highest level value + avev_q(i,kte,j)=avev_q(i,kte-1,j) + ENDDO + ENDDO +! max /min value + DO J = jts, jte + DO I = its, ite + DO K = kts+1,kte-1 + avev_qmax(i,k,j)=avev_q(i,k,j) + avev_qmin(i,k,j)=avev_q(i,k,j) + DO kk=-1,1 + if(avev_q(i,k+kk,j).gt.avev_qmax(i,k,j)) avev_qmax(i,k,j)=avev_q(i,k+kk,j) + if(avev_q(i,k+kk,j).lt.avev_qmin(i,k,j)) avev_qmin(i,k,j)=avev_q(i,k+kk,j) + ENDDO + if(avev_qmax(i,k,j).gt.avev_qmin(i,k,j)) then + coef_v(i,k,j)=(avev_q(i,k,j)-avev_qmin(i,k,j))/(avev_qmax(i,k,j)-avev_qmin(i,k,j)) + else + coef_v(i,k,j)=0 + endif + tpart_v(i,k,j)=coef_v(i,k,j)*(T(i,k,j)-avev_t(i,k,j)) + ENDDO + tpart_v(i,kts,j)= tpart_v(i,kts+1,j) ! lowest level + tpart_v(i,kte,j)= tpart_v(i,kte-1,j) ! highest level + ENDDO + ENDDO + ENDIF ! endif (trigger.eq.2) +! + DO J = jts,jte + DO I= its,ite + CU_ACT_FLAG(i,j) = .true. + ENDDO + ENDDO + + DO J = jts,jte + DO I=its,ite + + + IF ( NCA(I,J) .ge. 0.5*DT ) then + CU_ACT_FLAG(i,j) = .false. + ELSE + + DO k=kts,kte + DQDT(k)=0. + DQIDT(k)=0. + DQCDT(k)=0. + DQRDT(k)=0. + DQSDT(k)=0. + DTDT(k)=0. +!ckay + cldfra_dp_KF(I,k,J)=0. + cldfra_sh_KF(I,k,J)=0. + qc_KF(I,k,J)=0. + qi_KF(I,k,J)=0. + w_up(I,k,J)=0. + ENDDO + RAINCV(I,J)=0. + CUTOP(I,J)=KTS + CUBOT(I,J)=KTE+1 + PRATEC(I,J)=0. +! +! assign vars from 3D to 1D + + DO K=kts,kte + U1D(K) =U(I,K,J) + V1D(K) =V(I,K,J) + T1D(K) =T(I,K,J) + RHO1D(K) =rho(I,K,J) + QV1D(K)=QV(I,K,J) + P1D(K) =Pcps(I,K,J) + W0AVG1D(K) =W0AVG(I,K,J) + DZ1D(k)=dz8w(I,K,J) + + IF (trigger.eq.2) THEN + tpart_h1D(K) =tpart_h(I,K,J) + tpart_v1D(K) =tpart_v(I,K,J) + ELSE + tpart_h1D(K) = 0. + tpart_v1D(K) = 0. + ENDIF + ENDDO + CALL KF_eta_PARA(I, J, & + U1D,V1D,T1D,QV1D,P1D,DZ1D,W0AVG1D, & + tpart_h1D,tpart_v1D, & + trigger, & + DT,DX,DXSQ,RHO1D, & + XLV0,XLV1,XLS0,XLS1,CP,R,G, & + EP2,SVP1,SVP2,SVP3,SVPT0, & + DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & + RAINCV,PRATEC,NCA, & + flag_QI,flag_QS,warm_rain, & + CUTOP,CUBOT,CUDT, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & +!ckay + cldfra_dp_KF,cldfra_sh_KF,w_up, & + qc_KF,qi_KF, & + ZOL,WSTAR,UST,PBLH ) + + IF(PRESENT(rthcuten).AND.PRESENT(rqvcuten)) THEN + DO K=kts,kte + RTHCUTEN(I,K,J)=DTDT(K)/pi(I,K,J) + RQVCUTEN(I,K,J)=DQDT(K) + ENDDO + ENDIF + + IF(PRESENT(rqrcuten).AND.PRESENT(rqccuten)) THEN + IF( F_QR )THEN + DO K=kts,kte + RQRCUTEN(I,K,J)=DQRDT(K) + RQCCUTEN(I,K,J)=DQCDT(K) + ENDDO + ELSE +! This is the case for Eta microphysics without 3d rain field + DO K=kts,kte + RQRCUTEN(I,K,J)=0. + RQCCUTEN(I,K,J)=DQRDT(K)+DQCDT(K) + ENDDO + ENDIF + ENDIF + +!...... QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2) + + + IF(PRESENT( rqicuten )) THEN + IF ( F_QI ) THEN + DO K=kts,kte + RQICUTEN(I,K,J)=DQIDT(K) + ENDDO + ENDIF + ENDIF + + IF(PRESENT( rqscuten )) THEN + IF ( F_QS ) THEN + DO K=kts,kte + RQSCUTEN(I,K,J)=DQSDT(K) + ENDDO + ENDIF + ENDIF +! + ENDIF + ENDDO ! i-loop + ENDDO ! j-loop +! + END SUBROUTINE MSKF_CPS +! **************************************************************************** +!----------------------------------------------------------- + SUBROUTINE KF_eta_PARA (I, J, & + U0,V0,T0,QV0,P0,DZQ,W0AVG1D, & + TPART_H0,TPART_V0, & + trigger, & + DT,DX,DXSQ,rhoe, & + XLV0,XLV1,XLS0,XLS1,CP,R,G, & + EP2,SVP1,SVP2,SVP3,SVPT0, & + DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & + RAINCV,PRATEC,NCA, & + F_QI,F_QS,warm_rain, & + CUTOP,CUBOT,CUDT, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & +!ckay + cldfra_dp_KF,cldfra_sh_KF,w_up, & + qc_KF,qi_KF, & + ZOL,WSTAR,UST,PBLH ) +!----------------------------------------------------------- +!***** The KF scheme that is currently used in experimental runs of EMCs +!***** Eta model....jsk 8/00 +! + IMPLICIT NONE +!----------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + I,J + ! ,P_QI,P_QS,P_FIRST_SCALAR + INTEGER, INTENT(IN ) :: trigger + + LOGICAL, INTENT(IN ) :: F_QI, F_QS + + LOGICAL, INTENT(IN ) :: warm_rain +! + REAL, DIMENSION( kts:kte ), & + INTENT(IN ) :: U0, & + V0, & + TPART_H0, & + TPART_V0, & + T0, & + QV0, & + P0, & + rhoe, & + DZQ, & + W0AVG1D +! + REAL, INTENT(IN ) :: DT,DX,DXSQ +! + + REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1,CP,R,G + REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 + +!ckay + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT( IN) :: ZOL, & + WSTAR, & + UST, & + PBLH +! + REAL, DIMENSION( kts:kte ), INTENT(INOUT) :: & + DQDT, & + DQIDT, & + DQCDT, & + DQRDT, & + DQSDT, & + DTDT + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: NCA + +!ckay + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: cldfra_dp_KF, & + cldfra_sh_KF, & + qc_KF, & + qi_KF + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: RAINCV + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: PRATEC + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(OUT) :: CUBOT, & + CUTOP + REAL, INTENT(IN ) :: CUDT + +!ckaywup + REAL, DIMENSION( ims:ime, kms:kme , jms:jme ) , & + INTENT( OUT) :: w_up +! +!...DEFINE LOCAL VARIABLES... +! + REAL, DIMENSION( kts:kte ) :: & + Q0,Z0,TV0,TU,TVU,QU,TZ,TVD, & + QD,QES,THTES,TG,TVG,QG,WU,WD,W0,EMS,EMSD, & + UMF,UER,UDR,DMF,DER,DDR,UMF2,UER2, & + UDR2,DMF2,DER2,DDR2,DZA,THTA0,THETEE, & + THTAU,THETEU,THTAD,THETED,QLIQ,QICE, & + QLQOUT,QICOUT,PPTLIQ,PPTICE,DETLQ,DETIC, & + DETLQ2,DETIC2,RATIO,RATIO2 + + + REAL, DIMENSION( kts:kte ) :: & + DOMGDP,EXN,TVQU,DP,RH,EQFRC,WSPD, & + QDT,FXM,THTAG,THPA,THFXOUT, & + THFXIN,QPA,QFXOUT,QFXIN,QLPA,QLFXIN, & + QLFXOUT,QIPA,QIFXIN,QIFXOUT,QRPA, & + QRFXIN,QRFXOUT,QSPA,QSFXIN,QSFXOUT, & + QL0,QLG,QI0,QIG,QR0,QRG,QS0,QSG + + + REAL, DIMENSION( kts:kte+1 ) :: OMG + REAL, DIMENSION( kts:kte ) :: RAINFB,SNOWFB + REAL, DIMENSION( kts:kte ) :: & + CLDHGT,QSD,DILFRC,DDILFRC,TKE,TGU,QGU,THTEEG + +! LOCAL VARS + + REAL :: P00,T00,RLF,RHIC,RHBC,PIE, & + TTFRZ,TBFRZ,C5,RATE + REAL :: GDRY,ROCP,ALIQ,BLIQ, & + CLIQ,DLIQ + REAL :: FBFRC,P300,DPTHMX,THMIX,QMIX,ZMIX,PMIX, & + ROCPQ,TMIX,EMIX,TLOG,TDPT,TLCL,TVLCL, & + CPORQ,PLCL,ES,DLP,TENV,QENV,TVEN,TVBAR, & + ZLCL,WKL,WABS,TRPPT,WSIGNE,DTLCL,GDT,WLCL,& + TVAVG,QESE,WTW,RHOLCL,AU0,VMFLCL,UPOLD, & + UPNEW,ABE,WKLCL,TTEMP,FRC1, & + QNEWIC,RL,R1,QNWFRZ,EFFQ,BE,BOTERM,ENTERM,& + DZZ,UDLBE,REI,EE2,UD2,TTMP,F1,F2, & + THTTMP,QTMP,TMPLIQ,TMPICE,TU95,TU10,EE1, & + UD1,DPTT,QNEWLQ,DUMFDP,EE,TSAT, & + THTA,VCONV,TIMEC,SHSIGN,VWS,PEF, & + CBH,RCBH,PEFCBH,PEFF,PEFF2,TDER,THTMIN, & + DTMLTD,QS,TADVEC,DPDD,FRC,DPT,RDD,A1, & + DSSDT,DTMP,T1RH,QSRH,PPTFLX,CPR,CNDTNF, & + UPDINC,AINCM2,DEVDMF,PPR,RCED,DPPTDF, & + DMFLFS,DMFLFS2,RCED2,DDINC,AINCMX,AINCM1, & + AINC,TDER2,PPTFL2,FABE,STAB,DTT,DTT1, & + DTIME,TMA,TMB,TMM,BCOEFF,ACOEFF,QVDIFF, & + TOPOMG,CPM,DQ,ABEG,DABE,DFDA,FRC2,DR, & + UDFRC,TUC,QGS,RH0,RHG,QINIT,QFNL,ERR2, & + RELERR,RLC,RLS,RNC,FABEOLD,AINCOLD,UEFRC, & + DDFRC,TDC,DEFRC,RHBAR,DMFFRC,DPMIN,DILBE + REAL :: ASTRT,TP,VALUE,AINTRP,TKEMAX,QFRZ,& + QSS,PPTMLT,DTMELT,RHH,EVAC,BINC +! + INTEGER :: INDLU,NU,NUCHM,NNN,KLFS + REAL :: CHMIN,PM15,CHMAX,DTRH,RAD,DPPP + REAL :: TVDIFF,DTTOT,ABSOMG,ABSOMGTC,FRDP +!ckay + REAL :: xcldfra,UMF_new,DMF_new,FXM_new + REAL :: sourceht, Scale_Fac, TOKIOKA, RATE_kay + REAL :: capeDX, tempKay + REAL :: SCLvel, ZLCL_KAY, zz_kay + +!ckaywup + REAL :: envEsat, envQsat, envRH, envRHavg, denSplume + REAL :: updil, Drag + + INTEGER :: KX,K,KL +! + INTEGER :: NCHECK + INTEGER, DIMENSION (kts:kte) :: KCHECK + + INTEGER :: ISTOP,ML,L5,KMIX,LOW, & + LC,MXLAYR,LLFC,NLAYRS,NK, & + KPBL,KLCL,LCL,LET,IFLAG, & + NK1,LTOP,NJ,LTOP1, & + LTOPM1,LVF,KSTART,KMIN,LFS, & + ND,NIC,LDB,LDT,ND1,NDK, & + NM,LMAX,NCOUNT,NOITR, & + NSTEP,NTC,NCHM,ISHALL,NSHALL + LOGICAL :: IPRNT + REAL :: u00,qslcl,rhlcl,dqssdt !jfb + CHARACTER*1024 message +! + DATA P00,T00/1.E5,273.16/ + DATA RLF/3.339E5/ + DATA RHIC,RHBC/1.,0.90/ + DATA PIE,TTFRZ,TBFRZ,C5/3.141592654,268.16,248.16,1.0723E-3/ + DATA RATE/0.03/ ! wrf default +! DATA RATE/0.01/ ! value used in NRCM +! DATA RATE/0.001/ ! effectively turn off autoconversion +!----------------------------------------------------------- + IPRNT=.FALSE. + GDRY=-G/CP + ROCP=R/CP + NSHALL = 0 + KL=kte + KX=kte +! +! ALIQ = 613.3 +! BLIQ = 17.502 +! CLIQ = 4780.8 +! DLIQ = 32.19 + ALIQ = SVP1*1000. + BLIQ = SVP2 + CLIQ = SVP2*SVPT0 + DLIQ = SVP3 +! + IF(DX.GE.24.999E3) THEN + Scale_Fac = 1.0 + capeDX = 0.1 + ELSE + Scale_Fac = 1.0 + (log(25.E3/DX)) + capeDX = 0.1*Scale_Fac + END IF +! +!**************************************************************************** +! ! PPT FB MODS +!...OPTION TO FEED CONVECTIVELY GENERATED RAINWATER ! PPT FB MODS +!...INTO GRID-RESOLVED RAINWATER (OR SNOW/GRAUPEL) ! PPT FB MODS +!...FIELD. "FBFRC" IS THE FRACTION OF AVAILABLE ! PPT FB MODS +!...PRECIPITATION TO BE FED BACK (0.0 - 1.0)... ! PPT FB MODS + FBFRC=0.0 ! PPT FB MODS +!...mods to allow shallow convection... + NCHM = 0 + ISHALL = 0 + DPMIN = 5.E3 +!... + P300=P0(1)-30000. +! +!...PRESSURE PERTURBATION TERM IS ONLY DEFINED AT MID-POINT OF +!...VERTICAL LAYERS...SINCE TOTAL PRESSURE IS NEEDED AT THE TOP AND +!...BOTTOM OF LAYERS BELOW, DO AN INTERPOLATION... +! +!...INPUT A VERTICAL SOUNDING ... NOTE THAT MODEL LAYERS ARE NUMBERED +!...FROM BOTTOM-UP IN THE KF SCHEME... +! + ML=0 +!SUE tmprpsb=1./PSB(I,J) +!SUE CELL=PTOP*tmprpsb +! + DO K=1,KX +! +! Saturation vapor pressure (ES) is calculated following Buck (1981) +!...IF Q0 IS ABOVE SATURATION VALUE, REDUCE IT TO SATURATION LEVEL... +! + ES=ALIQ*EXP((BLIQ*T0(K)-CLIQ)/(T0(K)-DLIQ)) + QES(K)=0.622*ES/(P0(K)-ES) + Q0(K)=AMIN1(QES(K),QV0(K)) + Q0(K)=AMAX1(0.000001,Q0(K)) + QL0(K)=0. + QI0(K)=0. + QR0(K)=0. + QS0(K)=0. + RH(K) = Q0(K)/QES(K) + DILFRC(K) = 1. + TV0(K)=T0(K)*(1.+0.608*Q0(K)) +! RHOE(K)=P0(K)/(R*TV0(K)) +! DP IS THE PRESSURE INTERVAL BETWEEN FULL SIGMA LEVELS... + DP(K)=rhoe(k)*g*DZQ(k) +! IF Turbulent Kinetic Energy (TKE) is available from turbulent mixing scheme +! use it for shallow convection...For now, assume it is not available.... +! TKE(K) = Q2(I,J,NK) + TKE(K) = 0. + CLDHGT(K) = 0. +! IF(P0(K).GE.500E2)L5=K + IF(P0(K).GE.0.5*P0(1))L5=K + IF(P0(K).GE.P300)LLFC=K + ENDDO +! +!...DZQ IS DZ BETWEEN SIGMA SURFACES, DZA IS DZ BETWEEN MODEL HALF LEVEL + Z0(1)=.5*DZQ(1) +!cdir novector + DO K=2,KL + Z0(K)=Z0(K-1)+.5*(DZQ(K)+DZQ(K-1)) + DZA(K-1)=Z0(K)-Z0(K-1) + ENDDO + DZA(KL)=0. +! +! +! To save time, specify a pressure interval to move up in sequential +! check of different ~50 mb deep groups of adjacent model layers in +! the process of identifying updraft source layer (USL). Note that +! this search is terminated as soon as a buoyant parcel is found and +! this parcel can produce a cloud greater than specifed minimum depth +! (CHMIN)...For now, set interval at 15 mb... +! + NCHECK = 1 + KCHECK(NCHECK)=1 + PM15 = P0(1)-15.E2 + DO K=2,LLFC + IF(P0(K).LT.PM15)THEN + NCHECK = NCHECK+1 + KCHECK(NCHECK) = K + PM15 = PM15-15.E2 + ENDIF + ENDDO +! + NU=0 + NUCHM=0 +usl: DO + NU = NU+1 + IF(NU.GT.NCHECK)THEN + IF(ISHALL.EQ.1)THEN + CHMAX = 0. + NCHM = 0 + DO NK = 1,NCHECK + NNN=KCHECK(NK) + IF(CLDHGT(NNN).GT.CHMAX)THEN + NCHM = NNN + NUCHM = NK + CHMAX = CLDHGT(NNN) + ENDIF + ENDDO + NU = NUCHM-1 + FBFRC=1. + CYCLE usl + ELSE + RETURN + ENDIF + ENDIF + KMIX = KCHECK(NU) + LOW=KMIX +!... + LC = LOW +! +!...ASSUME THAT IN ORDER TO SUPPORT A DEEP UPDRAFT YOU NEED A LAYER OF +!...UNSTABLE AIR AT LEAST 50 mb DEEP...TO APPROXIMATE THIS, ISOLATE A +!...GROUP OF ADJACENT INDIVIDUAL MODEL LAYERS, WITH THE BASE AT LEVEL +!...LC, SUCH THAT THE COMBINED DEPTH OF THESE LAYERS IS AT LEAST 50 mb.. +! + NLAYRS=0 + DPTHMX=0. + NK=LC-1 + IF ( NK+1 .LT. KTS ) THEN + WRITE(message,*)'WOULD GO OFF BOTTOM: MSKF_PARA I,J,NK',I,J,NK + CALL wrf_message (TRIM(message)) + ELSE + DO + NK=NK+1 + IF ( NK .GT. KTE ) THEN + WRITE(message,*)'WOULD GO OFF TOP: MSKF_PARA I,J,DPTHMX,DPMIN',I,J,DPTHMX,DPMIN + CALL wrf_message (TRIM(message)) + EXIT + ENDIF + DPTHMX=DPTHMX+DP(NK) + NLAYRS=NLAYRS+1 + IF(DPTHMX.GT.DPMIN)THEN + EXIT + ENDIF + END DO + ENDIF + IF(DPTHMX.LT.DPMIN)THEN + RETURN + ENDIF + KPBL=LC+NLAYRS-1 +! +!...******************************************************** +!...for computational simplicity without much loss in accuracy, +!...mix temperature instead of theta for evaluating convective +!...initiation (triggering) potential... +! THMIX=0. + TMIX=0. + QMIX=0. + ZMIX=0. + PMIX=0. +! +!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY +!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL +!...LAYERS... +! +!cdir novector + DO NK=LC,KPBL + TMIX=TMIX+DP(NK)*T0(NK) + QMIX=QMIX+DP(NK)*Q0(NK) + ZMIX=ZMIX+DP(NK)*Z0(NK) + PMIX=PMIX+DP(NK)*P0(NK) + ENDDO +! THMIX=THMIX/DPTHMX + TMIX=TMIX/DPTHMX + QMIX=QMIX/DPTHMX + ZMIX=ZMIX/DPTHMX + PMIX=PMIX/DPTHMX + EMIX=QMIX*PMIX/(0.622+QMIX) +! +!...FIND THE TEMPERATURE OF THE MIXTURE AT ITS LCL... +! +! TLOG=ALOG(EMIX/ALIQ) +! ...calculate dewpoint using lookup table... +! + astrt=1.e-3 + ainc=0.075 + a1=emix/aliq + tp=(a1-astrt)/ainc + indlu=int(tp)+1 + value=(indlu-1)*ainc+astrt + aintrp=(a1-value)/ainc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT) + TLCL=AMIN1(TLCL,TMIX) + TVLCL=TLCL*(1.+0.608*QMIX) + ZLCL = ZMIX+(TLCL-TMIX)/GDRY + ! NK = LC-1 + ! DO + ! NK = NK+1 + ! KLCL=NK + ! IF(ZLCL.LE.Z0(NK) .or. NK.GT.KL)THEN + ! EXIT + ! ENDIF + ! ENDDO + ! IF(NK.GT.KL)THEN + ! RETURN + ! ENDIF + + DO NK = LC, KL + KLCL = NK + IF ( ZLCL.LE.Z0(NK) ) EXIT + END DO + IF ( ZLCL.GT.Z0(KL) ) RETURN + + K=KLCL-1 +! calculate DLP using Z instead of log(P) + DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K)) +! +!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... +! + TENV=T0(K)+(T0(KLCL)-T0(K))*DLP + QENV=Q0(K)+(Q0(KLCL)-Q0(K))*DLP + TVEN=TENV*(1.+0.608*QENV) +! +! ww: this needs to be initialized + DTRH = 0. + +! Becthold 2001 trigger with my Beta parameter + DTLCL = W0AVG1D(KLCL)/Scale_Fac + if(DTLCL.lt.0.0) then + tempKay = -1.0 + DTLCL = tempKay * DTLCL + DTLCL = (DTLCL)**0.3333 + else + tempKay = 1.0 + DTLCL = tempKay * DTLCL + DTLCL = (DTLCL)**0.3333 + end if + + DTLCL = 6.0 * tempKay * DTLCL + +! IF(ISHALL.EQ.1)IPRNT=.TRUE. +! IPRNT=.TRUE. +! IF(TLCL+DTLCL.GT.TENV)GOTO 45 + +trigger2: IF(TLCL+DTLCL+DTRH.LT.TENV)THEN +! +! Parcel not buoyant, CYCLE back to start of trigger and evaluate next potential USL... +! + CYCLE usl +! + ELSE ! Parcel is buoyant, determine updraft +! +!...CONVECTIVE TRIGGERING CRITERIA HAS BEEN SATISFIED...COMPUTE +!...EQUIVALENT POTENTIAL TEMPERATURE +!...(THETEU) AND VERTICAL VELOCITY OF THE RISING PARCEL AT THE LCL... +! + CALL ENVIRTHT(PMIX,TMIX,QMIX,THETEU(K),ALIQ,BLIQ,CLIQ,DLIQ) +! +!...modify calculation of initial parcel vertical velocity...jsk 11/26/97 +! + DTTOT = DTLCL+DTRH + IF(DTTOT.GT.1.E-4)THEN + GDT=2.*G*DTTOT*500./TVEN ! Kain (2004) Eq. 3 (sort of) + WLCL=1.+0.5*SQRT(GDT) + WLCL = AMIN1(WLCL,3.) + ELSE + WLCL=1. + ENDIF + PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP + WTW=WLCL*WLCL +! + TVLCL=TLCL*(1.+0.608*QMIX) + RHOLCL=PLCL/(R*TVLCL) +! + LCL=KLCL + LET=LCL +!ckay +! new formulation based on the LCL replacing the cloud radius concept +!introduce LCL instead of RAD based on WKL here + RAD = ZLCL +!ckay Dec20 + sourceht = Z0(KPBL) + RAD = amax1(sourceht, RAD) + + RAD = AMIN1(4000.,RAD) ! max trap + RAD = AMAX1(500.,RAD) ! min trap +! +!******************************************************************* +! * +! COMPUTE UPDRAFT PROPERTIES * +! * +!******************************************************************* +! +! +!... +!...ESTIMATE INITIAL UPDRAFT MASS FLUX (UMF(K))... +! + WU(K)=WLCL + AU0=0.01*DXSQ + UMF(K)=RHOLCL*AU0 + + VMFLCL=UMF(K) + UPOLD=VMFLCL + UPNEW=UPOLD +! +!...RATIO2 IS THE DEGREE OF GLACIATION IN THE CLOUD (0 TO 1), +!...UER IS THE ENVIR ENTRAINMENT RATE, ABE IS AVAILABLE +!...BUOYANT ENERGY, TRPPT IS THE TOTAL RATE OF PRECIPITATION +!...PRODUCTION... +! + RATIO2(K)=0. + UER(K)=0. + ABE=0. + TRPPT=0. + TU(K)=TLCL + TVU(K)=TVLCL + QU(K)=QMIX + EQFRC(K)=1. + QLIQ(K)=0. + QICE(K)=0. + QLQOUT(K)=0. + QICOUT(K)=0. + DETLQ(K)=0. + DETIC(K)=0. + PPTLIQ(K)=0. + PPTICE(K)=0. + IFLAG=0 +! +!...TTEMP IS USED DURING CALCULATION OF THE LINEAR GLACIATION +!...PROCESS; IT IS INITIALLY SET TO THE TEMPERATURE AT WHICH +!...FREEZING IS SPECIFIED TO BEGIN. WITHIN THE GLACIATION +!...INTERVAL, IT IS SET EQUAL TO THE UPDRAFT TEMP AT THE +!...PREVIOUS MODEL LEVEL... +! + TTEMP=TTFRZ +! +!...ENTER THE LOOP FOR UPDRAFT CALCULATIONS...CALCULATE UPDRAFT TEMP, +!...MIXING RATIO, VERTICAL MASS FLUX, LATERAL DETRAINMENT OF MASS AND +!...MOISTURE, PRECIPITATION RATES AT EACH MODEL LEVEL... +! +! **1 variables indicate the bottom of a model layer +! **2 variables indicate the top of a model layer +! + EE1=1. + UD1=0. + REI = 0. + DILBE = 0. +updraft: DO NK=K,KL-1 + NK1=NK+1 + RATIO2(NK1)=RATIO2(NK) + FRC1=0. + TU(NK1)=T0(NK1) + THETEU(NK1)=THETEU(NK) + QU(NK1)=QU(NK) + QLIQ(NK1)=QLIQ(NK) + QICE(NK1)=QICE(NK) + call tpmix2(p0(nk1),theteu(nk1),tu(nk1),qu(nk1),qliq(nk1), & + qice(nk1),qnewlq,qnewic,XLV1,XLV0) +! +! +!...CHECK TO SEE IF UPDRAFT TEMP IS ABOVE THE TEMPERATURE AT WHICH +!...GLACIATION IS ASSUMED TO INITIATE; IF IT IS, CALCULATE THE +!...FRACTION OF REMAINING LIQUID WATER TO FREEZE...TTFRZ IS THE +!...TEMP AT WHICH FREEZING BEGINS, TBFRZ THE TEMP BELOW WHICH ALL +!...LIQUID WATER IS FROZEN AT EACH LEVEL... +! + IF(TU(NK1).LE.TTFRZ)THEN + IF(TU(NK1).GT.TBFRZ)THEN + IF(TTEMP.GT.TTFRZ)TTEMP=TTFRZ + FRC1=(TTEMP-TU(NK1))/(TTEMP-TBFRZ) + ELSE + FRC1=1. + IFLAG=1 + ENDIF + TTEMP=TU(NK1) +! +! DETERMINE THE EFFECTS OF LIQUID WATER FREEZING WHEN TEMPERATURE +!...IS BELOW TTFRZ... +! + QFRZ = (QLIQ(NK1)+QNEWLQ)*FRC1 + QNEWIC=QNEWIC+QNEWLQ*FRC1 + QNEWLQ=QNEWLQ-QNEWLQ*FRC1 + QICE(NK1) = QICE(NK1)+QLIQ(NK1)*FRC1 + QLIQ(NK1) = QLIQ(NK1)-QLIQ(NK1)*FRC1 + CALL DTFRZNEW(TU(NK1),P0(NK1),THETEU(NK1),QU(NK1),QFRZ, & + QICE(NK1),ALIQ,BLIQ,CLIQ,DLIQ) + ENDIF + TVU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)) +! +! CALCULATE UPDRAFT VERTICAL VELOCITY AND PRECIPITATION FALLOUT... +! + IF(NK.EQ.K)THEN + BE=(TVLCL+TVU(NK1))/(TVEN+TV0(NK1))-1. + BOTERM=2.*(Z0(NK1)-ZLCL)*G*BE/1.5 + DZZ=Z0(NK1)-ZLCL + ELSE + BE=(TVU(NK)+TVU(NK1))/(TV0(NK)+TV0(NK1))-1. + BOTERM=2.*DZA(NK)*G*BE/1.5 + DZZ=DZA(NK) + ENDIF + ENTERM=2.*REI*WTW/UPOLD + +!ckay + IF(DX.GE.24.999E3) then + RATE_kay = RATE + else + RATE_kay = RATE / Scale_Fac + end if + CALL CONDLOAD(QLIQ(NK1),QICE(NK1),WTW,DZZ,BOTERM,ENTERM, & + RATE_kay,QNEWLQ,QNEWIC,QLQOUT(NK1),QICOUT(NK1),G) + +! +!...IF VERT VELOCITY IS LESS THAN ZERO, EXIT THE UPDRAFT LOOP AND, +!...IF CLOUD IS TALL ENOUGH, FINALIZE UPDRAFT CALCULATIONS... +! + IF(WTW.LT.1.E-3)THEN + EXIT + ELSE + WU(NK1)=SQRT(WTW) + ENDIF +!...Calculate value of THETA-E in environment to entrain into updraft... +! + CALL ENVIRTHT(P0(NK1),T0(NK1),Q0(NK1),THETEE(NK1),ALIQ,BLIQ,CLIQ,DLIQ) +! +!...REI IS THE RATE OF ENVIRONMENTAL INFLOW... +! New formulation for entrainment +!ckay introduce DX dependcy for the TOKIOKA Parameter =0.03 +!ckay Kim et al 2011; Kang et al 2009; Lin et al 2013; GCM findings + + TOKIOKA = 0.03 + TOKIOKA = TOKIOKA * Scale_Fac + REI=VMFLCL*DP(NK1)*TOKIOKA/RAD +!ckay + TVQU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)-QLIQ(NK1)-QICE(NK1)) + IF(NK.EQ.K)THEN + DILBE=((TVLCL+TVQU(NK1))/(TVEN+TV0(NK1))-1.)*DZZ + ELSE + DILBE=((TVQU(NK)+TVQU(NK1))/(TV0(NK)+TV0(NK1))-1.)*DZZ + ENDIF + IF(DILBE.GT.0.)ABE=ABE+DILBE*G +! +!...IF CLOUD PARCELS ARE VIRTUALLY COLDER THAN THE ENVIRONMENT, MINIMAL +!...ENTRAINMENT (0.5*REI) IS IMPOSED... +! + IF(TVQU(NK1).LE.TV0(NK1))THEN ! Entrain/Detrain IF BLOCK + EE2=0.5 ! Kain (2004) Eq. 4 + UD2=1. + EQFRC(NK1)=0. + ELSE + LET=NK1 + TTMP=TVQU(NK1) +! +!...DETERMINE THE CRITICAL MIXED FRACTION OF UPDRAFT AND ENVIRONMENTAL AIR... +! + F1=0.95 + F2=1.-F1 + THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) + QTMP=F1*Q0(NK1)+F2*QU(NK1) + TMPLIQ=F2*QLIQ(NK1) + TMPICE=F2*QICE(NK1) + call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, & + qnewlq,qnewic,XLV1,XLV0) + TU95=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) + IF(TU95.GT.TV0(NK1))THEN + EE2=1. + UD2=0. + EQFRC(NK1)=1.0 + ELSE + F1=0.10 + F2=1.-F1 + THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) + QTMP=F1*Q0(NK1)+F2*QU(NK1) + TMPLIQ=F2*QLIQ(NK1) + TMPICE=F2*QICE(NK1) + call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, & + qnewlq,qnewic,XLV1,XLV0) + TU10=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) + TVDIFF = ABS(TU10-TVQU(NK1)) + IF(TVDIFF.LT.1.e-3)THEN + EE2=1. + UD2=0. + EQFRC(NK1)=1.0 + ELSE + EQFRC(NK1)=(TV0(NK1)-TVQU(NK1))*F1/(TU10-TVQU(NK1)) + EQFRC(NK1)=AMAX1(0.0,EQFRC(NK1)) + EQFRC(NK1)=AMIN1(1.0,EQFRC(NK1)) + IF(EQFRC(NK1).EQ.1)THEN + EE2=1. + UD2=0. + ELSEIF(EQFRC(NK1).EQ.0.)THEN + EE2=0. + UD2=1. + ELSE +! +!...SUBROUTINE PROF5 INTEGRATES OVER THE GAUSSIAN DIST TO DETERMINE THE +! FRACTIONAL ENTRAINMENT AND DETRAINMENT RATES... +! + CALL PROF5(EQFRC(NK1),EE2,UD2) + ENDIF + ENDIF + ENDIF + ENDIF ! End of Entrain/Detrain IF BLOCK +! +! +!...NET ENTRAINMENT AND DETRAINMENT RATES ARE GIVEN BY THE AVERAGE FRACTIONAL +! VALUES IN THE LAYER... +! + EE2 = AMAX1(EE2,0.5) + UD2 = 1.5*UD2 + UER(NK1)=0.5*REI*(EE1+EE2) + UDR(NK1)=0.5*REI*(UD1+UD2) +! +!...IF THE CALCULATED UPDRAFT DETRAINMENT RATE IS GREATER THAN THE TOTAL +! UPDRAFT MASS FLUX, ALL CLOUD MASS DETRAINS, EXIT UPDRAFT CALCULATIONS... +! + IF(UMF(NK)-UDR(NK1).LT.10.)THEN +! +!...IF THE CALCULATED DETRAINED MASS FLUX IS GREATER THAN THE TOTAL UPD MASS +! FLUX, IMPOSE TOTAL DETRAINMENT OF UPDRAFT MASS AT THE PREVIOUS MODEL LVL.. +! First, correct ABE calculation if needed... +! + IF(DILBE.GT.0.)THEN + ABE=ABE-DILBE*G + ENDIF + LET=NK +! WRITE(98,1015)P0(NK1)/100. + EXIT + ELSE + EE1=EE2 + UD1=UD2 + UPOLD=UMF(NK)-UDR(NK1) + UPNEW=UPOLD+UER(NK1) + UMF(NK1)=UPNEW + DILFRC(NK1) = UPNEW/UPOLD +! +!...DETLQ AND DETIC ARE THE RATES OF DETRAINMENT OF LIQUID AND +!...ICE IN THE DETRAINING UPDRAFT MASS... +! + DETLQ(NK1)=QLIQ(NK1)*UDR(NK1) + DETIC(NK1)=QICE(NK1)*UDR(NK1) + QDT(NK1)=QU(NK1) + QU(NK1)=(UPOLD*QU(NK1)+UER(NK1)*Q0(NK1))/UPNEW + THETEU(NK1)=(THETEU(NK1)*UPOLD+THETEE(NK1)*UER(NK1))/UPNEW + QLIQ(NK1)=QLIQ(NK1)*UPOLD/UPNEW + QICE(NK1)=QICE(NK1)*UPOLD/UPNEW +! +!...PPTLIQ IS THE RATE OF GENERATION (FALLOUT) OF +!...LIQUID PRECIP AT A GIVEN MODEL LVL, PPTICE THE SAME FOR ICE, +!...TRPPT IS THE TOTAL RATE OF PRODUCTION OF PRECIP UP TO THE +!...CURRENT MODEL LEVEL... +! + PPTLIQ(NK1)=QLQOUT(NK1)*UMF(NK) + PPTICE(NK1)=QICOUT(NK1)*UMF(NK) +! + TRPPT=TRPPT+PPTLIQ(NK1)+PPTICE(NK1) + IF(NK1.LE.KPBL)UER(NK1)=UER(NK1)+VMFLCL*DP(NK1)/DPTHMX + ENDIF +! + END DO updraft +! +!...CHECK CLOUD DEPTH...IF CLOUD IS TALL ENOUGH, ESTIMATE THE EQUILIBRIUM +! TEMPERATURE LEVEL (LET) AND ADJUST MASS FLUX PROFILE AT CLOUD TOP SO +! THAT MASS FLUX DECREASES TO ZERO AS A LINEAR FUNCTION OF PRESSURE BETWEEN +! THE LET AND CLOUD TOP... +! +!...LTOP IS THE MODEL LEVEL JUST BELOW THE LEVEL AT WHICH VERTICAL VELOCITY +! FIRST BECOMES NEGATIVE... +! + LTOP=NK + CLDHGT(LC)=Z0(LTOP)-ZLCL +! +!...Instead of using the same minimum cloud height (for deep convection) +!...everywhere, try specifying minimum cloud depth as a function of TLCL... +! +! Kain (2004) Eq. 7 +! + IF(TLCL.GT.293.)THEN + CHMIN = 4.E3 + ELSEIF(TLCL.LE.293. .and. TLCL.GE.273)THEN + CHMIN = 2.E3 + 100.*(TLCL-273.) + ELSEIF(TLCL.LT.273.)THEN + CHMIN = 2.E3 + ENDIF +!ckay + DO NK=K,LTOP + qc_KF(I,NK,J)=QLIQ(NK) + qi_KF(I,NK,J)=QICE(NK) + END DO + +!ckay: if mean env RH with respect to water is over 100% then dont allow KF +! to avoid double counting + envRHavg = 0.0 + DO NK=K-1,LTOP+1 + envEsat = 6.112*exp(17.67*(T0(NK)-273.16)/(243.5+T0(NK)-273.16)) + envEsat = envEsat * 100.0 ! to hPa + envQsat = 0.622*envEsat/(P0(NK)-envEsat) + envRH = Q0(NK)/envQsat + envRHavg = envRHavg + envRH + END DO +!ckay ; get vertically averaged envRHavg + envRHavg = envRHavg / float(LTOP-K+1+2) + +! +!...If cloud top height is less than the specified minimum for deep +!...convection, save value to consider this level as source for +!...shallow convection, go back up to check next level... +! +!...Try specifying minimum cloud depth as a function of TLCL... +! +! +!...DO NOT ALLOW ANY CLOUD FROM THIS LAYER IF: +! +!... 1.) if there is no CAPE, or +!... 2.) cloud top is at model level just above LCL, or +!... 3.) cloud top is within updraft source layer, or +!... 4.) cloud-top detrainment layer begins within +!... updraft source layer. +!...ckay 5.) if the environment is supersaturated i.e., RH > 100% +!...ckay For now, with respect to water +! + + IF(LTOP.LE.KLCL .or. LTOP.LE.KPBL .or. LET+1.LE.KPBL & + .or. envRHavg.ge.1.01)THEN ! No Convection Allowed +!ckay + + CLDHGT(LC)=0. + DO NK=K,LTOP + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. +!ckay + cldfra_dp_KF(I,NK,J)=0. + cldfra_sh_KF(I,NK,J)=0. + qc_KF(I,NK,J)=0. + qi_KF(I,NK,J)=0. + w_up(I,NK,J)=0. + ENDDO +! + ELSEIF(CLDHGT(LC).GT.CHMIN .and. ABE.GT.1)THEN ! Deep Convection allowed + ISHALL=0 +!ckay + DO NK=K,LTOP + cldfra_sh_KF(I,NK,J)=0. + ENDDO + EXIT usl + ELSE +! +!...TO DISALLOW SHALLOW CONVECTION, COMMENT OUT NEXT LINE !!!!!!!! + ISHALL = 1 +!ckay + DO NK=K,LTOP + cldfra_dp_KF(I,NK,J)=0. + w_up(I,NK,J)=0. + ENDDO + IF(NU.EQ.NUCHM)THEN + EXIT usl ! Shallow Convection from this layer + ELSE +! Remember this layer (by virtue of non-zero CLDHGT) as potential shallow-cloud layer + DO NK=K,LTOP + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. +!ckay + cldfra_dp_KF(I,NK,J)=0. + cldfra_sh_KF(I,NK,J)=0. + qc_KF(I,NK,J)=0. + qi_KF(I,NK,J)=0. + w_up(I,NK,J)=0. + ENDDO + ENDIF + ENDIF + ENDIF trigger2 + END DO usl + IF(ISHALL.EQ.1)THEN + KSTART=MAX0(KPBL,KLCL) + LET=KSTART + endif +! +!...IF THE LET AND LTOP ARE THE SAME, DETRAIN ALL OF THE UPDRAFT MASS FL +! THIS LEVEL... +! + IF(LET.EQ.LTOP)THEN + UDR(LTOP)=UMF(LTOP)+UDR(LTOP)-UER(LTOP) + DETLQ(LTOP)=QLIQ(LTOP)*UDR(LTOP)*UPNEW/UPOLD + DETIC(LTOP)=QICE(LTOP)*UDR(LTOP)*UPNEW/UPOLD + UER(LTOP)=0. + UMF(LTOP)=0. + ELSE +! +! BEGIN TOTAL DETRAINMENT AT THE LEVEL ABOVE THE LET... +! + DPTT=0. + DO NJ=LET+1,LTOP + DPTT=DPTT+DP(NJ) + ENDDO + DUMFDP=UMF(LET)/DPTT +! +!...ADJUST MASS FLUX PROFILES, DETRAINMENT RATES, AND PRECIPITATION FALL +! RATES TO REFLECT THE LINEAR DECREASE IN MASS FLX BETWEEN THE LET AND +! + DO NK=LET+1,LTOP +! +!...entrainment is allowed at every level except for LTOP, so disallow +!...entrainment at LTOP and adjust entrainment rates between LET and LTOP +!...so the the dilution factor due to entrainment is not changed but +!...the actual entrainment rate will change due due forced total +!...detrainment in this layer... +! + IF(NK.EQ.LTOP)THEN + UDR(NK) = UMF(NK-1) + UER(NK) = 0. + DETLQ(NK) = UDR(NK)*QLIQ(NK)*DILFRC(NK) + DETIC(NK) = UDR(NK)*QICE(NK)*DILFRC(NK) + ELSE + UMF(NK)=UMF(NK-1)-DP(NK)*DUMFDP + UER(NK)=UMF(NK)*(1.-1./DILFRC(NK)) + UDR(NK)=UMF(NK-1)-UMF(NK)+UER(NK) + DETLQ(NK)=UDR(NK)*QLIQ(NK)*DILFRC(NK) + DETIC(NK)=UDR(NK)*QICE(NK)*DILFRC(NK) + ENDIF + IF(NK.GE.LET+2)THEN + TRPPT=TRPPT-PPTLIQ(NK)-PPTICE(NK) + PPTLIQ(NK)=UMF(NK-1)*QLQOUT(NK) + PPTICE(NK)=UMF(NK-1)*QICOUT(NK) + TRPPT=TRPPT+PPTLIQ(NK)+PPTICE(NK) + ENDIF + ENDDO + ENDIF +! +! Initialize some arrays below cloud base and above cloud top... +! + DO NK=1,LTOP + IF(T0(NK).GT.T00)ML=NK + ENDDO + DO NK=1,K + IF(NK.GE.LC)THEN + IF(NK.EQ.LC)THEN + UMF(NK)=VMFLCL*DP(NK)/DPTHMX + UER(NK)=VMFLCL*DP(NK)/DPTHMX + ELSEIF(NK.LE.KPBL)THEN + UER(NK)=VMFLCL*DP(NK)/DPTHMX + UMF(NK)=UMF(NK-1)+UER(NK) + ELSE + UMF(NK)=VMFLCL + UER(NK)=0. + ENDIF + TU(NK)=TMIX+(Z0(NK)-ZMIX)*GDRY + QU(NK)=QMIX + WU(NK)=WLCL + ELSE + TU(NK)=0. + QU(NK)=0. + UMF(NK)=0. + WU(NK)=0. + UER(NK)=0. +!ckay + cldfra_dp_KF(I,NK,J)=0. + cldfra_sh_KF(I,NK,J)=0. + qc_KF(I,NK,J)=0. + qi_KF(I,NK,J)=0. + w_up (I,NK,J)=0. + ENDIF + UDR(NK)=0. + QDT(NK)=0. + QLIQ(NK)=0. + QICE(NK)=0. + QLQOUT(NK)=0. + QICOUT(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + RATIO2(NK)=0. + CALL ENVIRTHT(P0(NK),T0(NK),Q0(NK),THETEE(NK),ALIQ,BLIQ,CLIQ,DLIQ) + EQFRC(NK)=1.0 + ENDDO +! + LTOP1=LTOP+1 + LTOPM1=LTOP-1 +! +!...DEFINE VARIABLES ABOVE CLOUD TOP... +! + DO NK=LTOP1,KX + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + QDT(NK)=0. + QLIQ(NK)=0. + QICE(NK)=0. + QLQOUT(NK)=0. + QICOUT(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + IF(NK.GT.LTOP1)THEN + TU(NK)=0. + QU(NK)=0. + WU(NK)=0. +!ckay + cldfra_dp_KF(I,NK,J)=0. + cldfra_sh_KF(I,NK,J)=0. + qc_KF(I,NK,J)=0. + qi_KF(I,NK,J)=0. + w_up(I,NK,J)=0. + ENDIF + THTA0(NK)=0. + THTAU(NK)=0. + EMS(NK)=0. + EMSD(NK)=0. + TG(NK)=T0(NK) + QG(NK)=Q0(NK) + QLG(NK)=0. + QIG(NK)=0. + QRG(NK)=0. + QSG(NK)=0. + OMG(NK)=0. + ENDDO + OMG(KX+1)=0. + DO NK=1,LTOP + EMS(NK)=DP(NK)*DXSQ/G + EMSD(NK)=1./EMS(NK) +! +!...INITIALIZE SOME VARIABLES TO BE USED LATER IN THE VERT ADVECTION SCHEME +! + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QDT(NK))) + THTAU(NK)=TU(NK)*EXN(NK) + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*Q0(NK))) + THTA0(NK)=T0(NK)*EXN(NK) + DDILFRC(NK) = 1./DILFRC(NK) + OMG(NK)=0. + ENDDO +! IF (XTIME.LT.10.)THEN +! WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, +! * TMIX-T00,PMIX,QMIX,ABE +! WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., +! * WLCL,CLDHGT +! ENDIF +! +!...COMPUTE CONVECTIVE TIME SCALE(TIMEC). THE MEAN WIND AT THE LCL +!...AND MIDTROPOSPHERE IS USED. +! + WSPD(KLCL)=SQRT(U0(KLCL)*U0(KLCL)+V0(KLCL)*V0(KLCL)) + WSPD(L5)=SQRT(U0(L5)*U0(L5)+V0(L5)*V0(L5)) + WSPD(LTOP)=SQRT(U0(LTOP)*U0(LTOP)+V0(LTOP)*V0(LTOP)) + VCONV=.5*(WSPD(KLCL)+WSPD(L5)) +!...for ETA model, DX is a function of location... + TIMEC=DX/VCONV + TADVEC=TIMEC +! +!ckay +!new dynTau based on subcloud layer scales : note Z0(KPBL)=altitude of source layer + + TIMEC = Amax1(CHMIN,CLDHGT(LC)) + TIMEC = TIMEC*Scale_Fac + +!ckay SCLvel = SubCloudLayerVELOCITY = Wsb + SCLvel = WSTAR(I,J)**3 + ZLCL_KAY = amax1(ZLCL,Z0(KPBL)) + SCLvel = SCLvel/PBLH(I,J) + SCLvel = SCLvel*ZLCL_kay + SCLvel = SCLvel**0.333 ! Wsb=SubCloudLayerVelocity for ConvectivePBL + if(ZOL(i,J).le.0.0) then + FRC2=3.8*Ust(I,J)*Ust(I,J) + FRC2 = FRC2 + 0.22*SCLvel*SCLvel + zz_kay = -1.0*ZOL(I,j) + ZLCL_KAY = zz_kay**(2./3.) + ZLCL_KAY = ZLCL_KAY * (1.9*Ust(I,J)*Ust(I,J)) + FRC2 = FRC2 + ZLCL_KAY + else + FRC2=3.8*Ust(I,J)*Ust(I,J) + end if + + FRC2 = SQRT(FRC2) + SCLvel = FRC2 ! Wsb=new subcloud layer velocity scale for all conditions + + if(ABE.le.0.0) ABE = 1.0 + TIMEC = TIMEC/((0.03*SCLvel*ABE)**0.3333) + +!ckay: this dynTau is good for the Deep as well as Shallow Cu clouds + TIMEC = AMAX1(DT, TIMEC) + + NIC=NINT(TIMEC/DT) + TIMEC=FLOAT(NIC)*DT +! +!...COMPUTE WIND SHEAR AND PRECIPITATION EFFICIENCY. +! + IF(WSPD(LTOP).GT.WSPD(KLCL))THEN + SHSIGN=1. + ELSE + SHSIGN=-1. + ENDIF + VWS=(U0(LTOP)-U0(KLCL))*(U0(LTOP)-U0(KLCL))+(V0(LTOP)-V0(KLCL))* & + (V0(LTOP)-V0(KLCL)) + VWS=1.E3*SHSIGN*SQRT(VWS)/(Z0(LTOP)-Z0(LCL)) + PEF=1.591+VWS*(-.639+VWS*(9.53E-2-VWS*4.96E-3)) + PEF=AMAX1(PEF,.2) + PEF=AMIN1(PEF,.9) +! +!...PRECIPITATION EFFICIENCY IS A FUNCTION OF THE HEIGHT OF CLOUD BASE. +! + CBH=(ZLCL-Z0(1))*3.281E-3 + IF(CBH.LT.3.)THEN + RCBH=.02 + ELSE + RCBH=.96729352+CBH*(-.70034167+CBH*(.162179896+CBH*(- & + 1.2569798E-2+CBH*(4.2772E-4-CBH*5.44E-6)))) + ENDIF + IF(CBH.GT.25)RCBH=2.4 + PEFCBH=1./(1.+RCBH) + PEFCBH=AMIN1(PEFCBH,.9) +! +!... MEAN PEF. IS USED TO COMPUTE RAINFALL. +! + PEFF=.5*(PEF+PEFCBH) + PEFF2 = PEFF ! JSK MODS + IF(IPRNT)THEN +! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS + WRITE(message,1035)PEF,PEFCBH,LC,LET,WKL,VWS + CALL wrf_message( message ) +! flush(98) + endif +! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS +!***************************************************************** +! * +! COMPUTE DOWNDRAFT PROPERTIES * +! * +!***************************************************************** +! +! + TDER=0. + devap:IF(ISHALL.EQ.1)THEN + LFS = 1 + ELSE +! +!...start downdraft about 150 mb above cloud base... +! +! KSTART=MAX0(KPBL,KLCL) +! KSTART=KPBL ! Changed 7/23/99 + KSTART=KPBL+1 ! Changed 7/23/99 + KLFS = LET-1 + DO NK = KSTART+1,KL + DPPP = P0(KSTART)-P0(NK) +! IF(DPPP.GT.200.E2)THEN + IF(DPPP.GT.150.E2)THEN + KLFS = NK + EXIT + ENDIF + ENDDO + KLFS = MIN0(KLFS,LET-1) + LFS = KLFS +! +!...if LFS is not at least 50 mb above cloud base (implying that the +!...level of equil temp, LET, is just above cloud base) do not allow a +!...downdraft... +! + IF((P0(KSTART)-P0(LFS)).GT.50.E2)THEN + THETED(LFS) = THETEE(LFS) + QD(LFS) = Q0(LFS) +! +!...call tpmix2dd to find wet-bulb temp, qv... +! + call tpmix2dd(p0(lfs),theted(lfs),tz(lfs),qss,i,j) + THTAD(LFS)=TZ(LFS)*(P00/P0(LFS))**(0.2854*(1.-0.28*QSS)) +! +!...TAKE A FIRST GUESS AT THE INITIAL DOWNDRAFT MASS FLUX... +! + TVD(LFS)=TZ(LFS)*(1.+0.608*QSS) + RDD=P0(LFS)/(R*TVD(LFS)) + A1=(1.-PEFF)*AU0 + DMF(LFS)=-A1*RDD + DER(LFS)=DMF(LFS) + DDR(LFS)=0. + RHBAR = RH(LFS)*DP(LFS) + DPTT = DP(LFS) + DO ND = LFS-1,KSTART,-1 + ND1 = ND+1 + DER(ND)=DER(LFS)*EMS(ND)/EMS(LFS) + DDR(ND)=0. + DMF(ND)=DMF(ND1)+DER(ND) + THETED(ND)=(THETED(ND1)*DMF(ND1)+THETEE(ND)*DER(ND))/DMF(ND) + QD(ND)=(QD(ND1)*DMF(ND1)+Q0(ND)*DER(ND))/DMF(ND) + DPTT = DPTT+DP(ND) + RHBAR = RHBAR+RH(ND)*DP(ND) + ENDDO + RHBAR = RHBAR/DPTT + DMFFRC = 2.*(1.-RHBAR) ! Kain (2004) eq. 11 + DPDD = 0. +!...Calculate melting effect +!... first, compute total frozen precipitation generated... +! + pptmlt = 0. + DO NK = KLCL,LTOP + PPTMLT = PPTMLT+PPTICE(NK) + ENDDO + if(lc.lt.ml)then +!...For now, calculate melting effect as if DMF = -UMF at KLCL, i.e., as +!...if DMFFRC=1. Otherwise, for small DMFFRC, DTMELT gets too large! +!...12/14/98 jsk... + DTMELT = RLF*PPTMLT/(CP*UMF(KLCL)) + else + DTMELT = 0. + endif + LDT = MIN0(LFS-1,KSTART-1) +! + call tpmix2dd(p0(kstart),theted(kstart),tz(kstart),qss,i,j) +! + tz(kstart) = tz(kstart)-dtmelt + ES=ALIQ*EXP((BLIQ*TZ(KSTART)-CLIQ)/(TZ(KSTART)-DLIQ)) + QSS=0.622*ES/(P0(KSTART)-ES) + THETED(KSTART)=TZ(KSTART)*(1.E5/P0(KSTART))**(0.2854*(1.-0.28*QSS))* & + EXP((3374.6525/TZ(KSTART)-2.5403)*QSS*(1.+0.81*QSS)) +!.... + LDT = MIN0(LFS-1,KSTART-1) + DO ND = LDT,1,-1 + DPDD = DPDD+DP(ND) + THETED(ND) = THETED(KSTART) + QD(ND) = QD(KSTART) +! +!...call tpmix2dd to find wet bulb temp, saturation mixing ratio... +! + call tpmix2dd(p0(nd),theted(nd),tz(nd),qss,i,j) + qsd(nd) = qss +! +!...specify RH decrease of 20%/km in downdraft... +! + RHH = 1.-0.2/1000.*(Z0(KSTART)-Z0(ND)) +! +!...adjust downdraft TEMP, Q to specified RH: +! + IF(RHH.LT.1.)THEN + DSSDT=(CLIQ-BLIQ*DLIQ)/((TZ(ND)-DLIQ)*(TZ(ND)-DLIQ)) + RL=XLV0-XLV1*TZ(ND) + DTMP=RL*QSS*(1.-RHH)/(CP+RL*RHH*QSS*DSSDT) + T1RH=TZ(ND)+DTMP + ES=RHH*ALIQ*EXP((BLIQ*T1RH-CLIQ)/(T1RH-DLIQ)) + QSRH=0.622*ES/(P0(ND)-ES) +! +!...CHECK TO SEE IF MIXING RATIO AT SPECIFIED RH IS LESS THAN ACTUAL +!...MIXING RATIO...IF SO, ADJUST TO GIVE ZERO EVAPORATION... +! + IF(QSRH.LT.QD(ND))THEN + QSRH=QD(ND) + T1RH=TZ(ND)+(QSS-QSRH)*RL/CP + ENDIF + TZ(ND)=T1RH + QSS=QSRH + QSD(ND) = QSS + ENDIF + TVD(nd) = tz(nd)*(1.+0.608*qsd(nd)) + IF(TVD(ND).GT.TV0(ND).OR.ND.EQ.1)THEN + LDB=ND + EXIT + ENDIF + ENDDO + IF((P0(LDB)-P0(LFS)) .gt. 50.E2)THEN ! minimum Downdraft depth! + DO ND=LDT,LDB,-1 + ND1 = ND+1 + DDR(ND) = -DMF(KSTART)*DP(ND)/DPDD + DER(ND) = 0. + DMF(ND) = DMF(ND1)+DDR(ND) + TDER=TDER+(QSD(nd)-QD(ND))*DDR(ND) + QD(ND)=QSD(nd) + THTAD(ND)=TZ(ND)*(P00/P0(ND))**(0.2854*(1.-0.28*QD(ND))) + ENDDO + ENDIF + ENDIF + ENDIF devap +! +!...IF DOWNDRAFT DOES NOT EVAPORATE ANY WATER FOR SPECIFIED RELATIVE +!...HUMIDITY, NO DOWNDRAFT IS ALLOWED... +! +d_mf: IF(TDER.LT.1.)THEN +! WRITE(98,3004)I,J +!3004 FORMAT(' ','No Downdraft!; I=',I3,2X,'J=',I3,'ISHALL =',I2) + PPTFLX=TRPPT + CPR=TRPPT + TDER=0. + CNDTNF=0. + UPDINC=1. + LDB=LFS + DO NDK=1,LTOP + DMF(NDK)=0. + DER(NDK)=0. + DDR(NDK)=0. + THTAD(NDK)=0. + WD(NDK)=0. + TZ(NDK)=0. + QD(NDK)=0. + ENDDO + AINCM2=100. + ELSE + DDINC = -DMFFRC*UMF(KLCL)/DMF(KSTART) + UPDINC=1. + IF(TDER*DDINC.GT.TRPPT)THEN + DDINC = TRPPT/TDER + ENDIF + TDER = TDER*DDINC + DO NK=LDB,LFS + DMF(NK)=DMF(NK)*DDINC + DER(NK)=DER(NK)*DDINC + DDR(NK)=DDR(NK)*DDINC + ENDDO + CPR=TRPPT + PPTFLX = TRPPT-TDER + PEFF=PPTFLX/TRPPT + IF(IPRNT)THEN +! write(98,*)'PRECIP EFFICIENCY =',PEFF + write(message,*)'PRECIP EFFICIENCY =',PEFF + CALL wrf_message(message) +! flush(98) + ENDIF +! +! +!...ADJUST UPDRAFT MASS FLUX, MASS DETRAINMENT RATE, AND LIQUID WATER AN +! DETRAINMENT RATES TO BE CONSISTENT WITH THE TRANSFER OF THE ESTIMATE +! FROM THE UPDRAFT TO THE DOWNDRAFT AT THE LFS... +! +! DO NK=LC,LFS +! UMF(NK)=UMF(NK)*UPDINC +! UDR(NK)=UDR(NK)*UPDINC +! UER(NK)=UER(NK)*UPDINC +! PPTLIQ(NK)=PPTLIQ(NK)*UPDINC +! PPTICE(NK)=PPTICE(NK)*UPDINC +! DETLQ(NK)=DETLQ(NK)*UPDINC +! DETIC(NK)=DETIC(NK)*UPDINC +! ENDDO +! +!...ZERO OUT THE ARRAYS FOR DOWNDRAFT DATA AT LEVELS ABOVE AND BELOW THE +!...DOWNDRAFT... +! + IF(LDB.GT.1)THEN + DO NK=1,LDB-1 + DMF(NK)=0. + DER(NK)=0. + DDR(NK)=0. + WD(NK)=0. + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + ENDIF + DO NK=LFS+1,KX + DMF(NK)=0. + DER(NK)=0. + DDR(NK)=0. + WD(NK)=0. + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + DO NK=LDT+1,LFS-1 + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + ENDIF d_mf +! +!...SET LIMITS ON THE UPDRAFT AND DOWNDRAFT MASS FLUXES SO THAT THE INFLOW +! INTO CONVECTIVE DRAFTS FROM A GIVEN LAYER IS NO MORE THAN IS AVAILABLE +! IN THAT LAYER INITIALLY... +! + AINCMX=1000. + LMAX=MAX0(KLCL,LFS) + DO NK=LC,LMAX + IF((UER(NK)-DER(NK)).GT.1.e-3)THEN + AINCM1=EMS(NK)/((UER(NK)-DER(NK))*TIMEC) + AINCMX=AMIN1(AINCMX,AINCM1) + ENDIF + ENDDO + AINC=1. + IF(AINCMX.LT.AINC)AINC=AINCMX +! +!...SAVE THE RELEVENT VARIABLES FOR A UNIT UPDRAFT AND DOWNDRAFT...THEY WILL +!...BE ITERATIVELY ADJUSTED BY THE FACTOR AINC TO SATISFY THE STABILIZATION +!...CLOSURE... +! + TDER2=TDER + PPTFL2=PPTFLX + DO NK=1,LTOP + DETLQ2(NK)=DETLQ(NK) + DETIC2(NK)=DETIC(NK) + UDR2(NK)=UDR(NK) + UER2(NK)=UER(NK) + DDR2(NK)=DDR(NK) + DER2(NK)=DER(NK) + UMF2(NK)=UMF(NK) + DMF2(NK)=DMF(NK) + ENDDO + FABE=1. + STAB=0.95 + NOITR=0 + ISTOP=0 +! + IF(ISHALL.EQ.1)THEN ! First for shallow convection +! +! No iteration for shallow convection; if turbulent kinetic energy (TKE) is available +! from a turbulence parameterization, scale cloud-base updraft mass flux as a function +! of TKE, but for now, just specify shallow-cloud mass flux using TKEMAX = 5... +! +!...find the maximum TKE value between LC and KLCL... +! TKEMAX = 0. + TKEMAX = 5. +! DO 173 K = LC,KLCL +! NK = KX-K+1 +! TKEMAX = AMAX1(TKEMAX,Q2(I,J,NK)) +! 173 CONTINUE +! TKEMAX = AMIN1(TKEMAX,10.) +! TKEMAX = AMAX1(TKEMAX,5.) +!c TKEMAX = 10. +!c...3_24_99...DPMIN was changed for shallow convection so that it is the +!c... the same as for deep convection (5.E3). Since this doubles +!c... (roughly) the value of DPTHMX, add a factor of 0.5 to calcu- +!c... lation of EVAC... +!c EVAC = TKEMAX*0.1 + EVAC = 0.5*TKEMAX*0.1 +! AINC = 0.1*DPTHMX*DXIJ*DXIJ/(VMFLCL*G*TIMEC) +! AINC = EVAC*DPTHMX*DX(I,J)*DX(I,J)/(VMFLCL*G*TIMEC) + AINC = EVAC*DPTHMX*DXSQ/(VMFLCL*G*TIMEC) + TDER=TDER2*AINC + PPTFLX=PPTFL2*AINC + DO NK=1,LTOP + UMF(NK)=UMF2(NK)*AINC + DMF(NK)=DMF2(NK)*AINC + DETLQ(NK)=DETLQ2(NK)*AINC + DETIC(NK)=DETIC2(NK)*AINC + UDR(NK)=UDR2(NK)*AINC + UER(NK)=UER2(NK)*AINC + DER(NK)=DER2(NK)*AINC + DDR(NK)=DDR2(NK)*AINC + ENDDO + ENDIF ! Otherwise for deep convection +! use iterative procedure to find mass fluxes... +iter: DO NCOUNT=1,10 +! +!***************************************************************** +! * +! COMPUTE PROPERTIES FOR COMPENSATIONAL SUBSIDENCE * +! * +!***************************************************************** +! +!...DETERMINE OMEGA VALUE NECESSARY AT TOP AND BOTTOM OF EACH LAYER TO +!...SATISFY MASS CONTINUITY... +! + DTT=TIMEC + DO NK=1,LTOP + DOMGDP(NK)=-(UER(NK)-DER(NK)-UDR(NK)-DDR(NK))*EMSD(NK) + IF(NK.GT.1)THEN + OMG(NK)=OMG(NK-1)-DP(NK-1)*DOMGDP(NK-1) + ABSOMG = ABS(OMG(NK)) + ABSOMGTC = ABSOMG*TIMEC + FRDP = 0.75*DP(NK-1) + IF(ABSOMGTC.GT.FRDP)THEN + DTT1 = FRDP/ABSOMG + DTT=AMIN1(DTT,DTT1) + ENDIF + ENDIF + ENDDO + DO NK=1,LTOP + THPA(NK)=THTA0(NK) + QPA(NK)=Q0(NK) + NSTEP=NINT(TIMEC/DTT+1) + DTIME=TIMEC/FLOAT(NSTEP) + FXM(NK)=OMG(NK)*DXSQ/G + ENDDO +! +!...DO AN UPSTREAM/FORWARD-IN-TIME ADVECTION OF THETA, QV... +! + DO NTC=1,NSTEP +! +!...ASSIGN THETA AND Q VALUES AT THE TOP AND BOTTOM OF EACH LAYER BASED ON +!...SIGN OF OMEGA... +! + DO NK=1,LTOP + THFXIN(NK)=0. + THFXOUT(NK)=0. + QFXIN(NK)=0. + QFXOUT(NK)=0. + ENDDO + DO NK=2,LTOP + IF(OMG(NK).LE.0.)THEN + THFXIN(NK)=-FXM(NK)*THPA(NK-1) + QFXIN(NK)=-FXM(NK)*QPA(NK-1) + THFXOUT(NK-1)=THFXOUT(NK-1)+THFXIN(NK) + QFXOUT(NK-1)=QFXOUT(NK-1)+QFXIN(NK) + ELSE + THFXOUT(NK)=FXM(NK)*THPA(NK) + QFXOUT(NK)=FXM(NK)*QPA(NK) + THFXIN(NK-1)=THFXIN(NK-1)+THFXOUT(NK) + QFXIN(NK-1)=QFXIN(NK-1)+QFXOUT(NK) + ENDIF + ENDDO +! +!...UPDATE THE THETA AND QV VALUES AT EACH LEVEL... +! + DO NK=1,LTOP + THPA(NK)=THPA(NK)+(THFXIN(NK)+UDR(NK)*THTAU(NK)+DDR(NK)* & + THTAD(NK)-THFXOUT(NK)-(UER(NK)-DER(NK))*THTA0(NK))* & + DTIME*EMSD(NK) + QPA(NK)=QPA(NK)+(QFXIN(NK)+UDR(NK)*QDT(NK)+DDR(NK)*QD(NK)- & + QFXOUT(NK)-(UER(NK)-DER(NK))*Q0(NK))*DTIME*EMSD(NK) + ENDDO + ENDDO + DO NK=1,LTOP + THTAG(NK)=THPA(NK) + QG(NK)=QPA(NK) + ENDDO +! +!...CHECK TO SEE IF MIXING RATIO DIPS BELOW ZERO ANYWHERE; IF SO, BORROW +!...MOISTURE FROM ADJACENT LAYERS TO BRING IT BACK UP ABOVE ZERO... +! + DO NK=1,LTOP + IF(QG(NK).LT.0.)THEN + IF(NK.EQ.1)THEN ! JSK MODS +! PRINT *,' PROBLEM WITH KF SCHEME: ' ! JSK MODS +! PRINT *,'QG = 0 AT THE SURFACE!!!!!!!' ! JSK MODS + CALL wrf_error_fatal ( 'QG, QG(NK).LT.0') ! JSK MODS + ENDIF ! JSK MODS + NK1=NK+1 + IF(NK.EQ.LTOP)THEN + NK1=KLCL + ENDIF + TMA=QG(NK1)*EMS(NK1) + TMB=QG(NK-1)*EMS(NK-1) + TMM=(QG(NK)-1.E-9)*EMS(NK ) + BCOEFF=-TMM/((TMA*TMA)/TMB+TMB) + ACOEFF=BCOEFF*TMA/TMB + TMB=TMB*(1.-BCOEFF) + TMA=TMA*(1.-ACOEFF) + IF(NK.EQ.LTOP)THEN + QVDIFF=(QG(NK1)-TMA*EMSD(NK1))*100./QG(NK1) +! IF(ABS(QVDIFF).GT.1.)THEN +! PRINT *,'!!!WARNING!!! CLOUD BASE WATER VAPOR CHANGES BY ', & +! QVDIFF, & +! '% WHEN MOISTURE IS BORROWED TO PREVENT NEGATIVE ', & +! 'VALUES IN KAIN-FRITSCH' +! ENDIF + ENDIF + QG(NK)=1.E-9 + QG(NK1)=TMA*EMSD(NK1) + QG(NK-1)=TMB*EMSD(NK-1) + ENDIF + ENDDO + TOPOMG=(UDR(LTOP)-UER(LTOP))*DP(LTOP)*EMSD(LTOP) + IF(ABS(TOPOMG-OMG(LTOP)).GT.1.E-3)THEN +! WRITE(99,*)'ERROR: MASS DOES NOT BALANCE IN KF SCHEME; & +! TOPOMG, OMG =',TOPOMG,OMG(LTOP) +! TOPOMG, OMG =',TOPOMG,OMG(LTOP) + ISTOP=1 + IPRNT=.TRUE. + EXIT iter + ENDIF +! +!...CONVERT THETA TO T... +! + DO NK=1,LTOP + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QG(NK))) + TG(NK)=THTAG(NK)/EXN(NK) + TVG(NK)=TG(NK)*(1.+0.608*QG(NK)) + ENDDO + IF(ISHALL.EQ.1)THEN + EXIT iter + ENDIF +! +!******************************************************************* +! * +! COMPUTE NEW CLOUD AND CHANGE IN AVAILABLE BUOYANT ENERGY. * +! * +!******************************************************************* +! +!...THE FOLLOWING COMPUTATIONS ARE SIMILAR TO THAT FOR UPDRAFT +! +! THMIX=0. + TMIX=0. + QMIX=0. +! +!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY +!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL +!...LAYERS... +! + DO NK=LC,KPBL + TMIX=TMIX+DP(NK)*TG(NK) + QMIX=QMIX+DP(NK)*QG(NK) + ENDDO + TMIX=TMIX/DPTHMX + QMIX=QMIX/DPTHMX + ES=ALIQ*EXP((TMIX*BLIQ-CLIQ)/(TMIX-DLIQ)) + QSS=0.622*ES/(PMIX-ES) +! +!...REMOVE SUPERSATURATION FOR DIAGNOSTIC PURPOSES, IF NECESSARY... +! + IF(QMIX.GT.QSS)THEN + RL=XLV0-XLV1*TMIX + CPM=CP*(1.+0.887*QMIX) + DSSDT=QSS*(CLIQ-BLIQ*DLIQ)/((TMIX-DLIQ)*(TMIX-DLIQ)) + DQ=(QMIX-QSS)/(1.+RL*DSSDT/CPM) + TMIX=TMIX+RL/CP*DQ + QMIX=QMIX-DQ + TLCL=TMIX + ELSE + QMIX=AMAX1(QMIX,0.) + EMIX=QMIX*PMIX/(0.622+QMIX) + astrt=1.e-3 + binc=0.075 + a1=emix/aliq + tp=(a1-astrt)/binc + indlu=int(tp)+1 + value=(indlu-1)*binc+astrt + aintrp=(a1-value)/binc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT) + TLCL=AMIN1(TLCL,TMIX) + ENDIF + TVLCL=TLCL*(1.+0.608*QMIX) + ZLCL = ZMIX+(TLCL-TMIX)/GDRY + DO NK = LC,KL + KLCL=NK + IF(ZLCL.LE.Z0(NK))THEN + EXIT + ENDIF + ENDDO + K=KLCL-1 + DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K)) +! +!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... +! + TENV=TG(K)+(TG(KLCL)-TG(K))*DLP + QENV=QG(K)+(QG(KLCL)-QG(K))*DLP + TVEN=TENV*(1.+0.608*QENV) + PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP + THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* & + EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX)) +! +!...COMPUTE ADJUSTED ABE(ABEG). +! + ABEG=0. + DO NK=K,LTOPM1 + NK1=NK+1 + THETEU(NK1) = THETEU(NK) +! + call tpmix2dd(p0(nk1),theteu(nk1),tgu(nk1),qgu(nk1),i,j) +! + TVQU(NK1)=TGU(NK1)*(1.+0.608*QGU(NK1)-QLIQ(NK1)-QICE(NK1)) + IF(NK.EQ.K)THEN + DZZ=Z0(KLCL)-ZLCL + DILBE=((TVLCL+TVQU(NK1))/(TVEN+TVG(NK1))-1.)*DZZ + ELSE + DZZ=DZA(NK) + DILBE=((TVQU(NK)+TVQU(NK1))/(TVG(NK)+TVG(NK1))-1.)*DZZ + ENDIF + IF(DILBE.GT.0.)ABEG=ABEG+DILBE*G +! +!...DILUTE BY ENTRAINMENT BY THE RATE AS ORIGINAL UPDRAFT... +! + CALL ENVIRTHT(P0(NK1),TG(NK1),QG(NK1),THTEEG(NK1),ALIQ,BLIQ,CLIQ,DLIQ) + THETEU(NK1)=THETEU(NK1)*DDILFRC(NK1)+THTEEG(NK1)*(1.-DDILFRC(NK1)) + ENDDO +! +!...ASSUME AT LEAST 90% OF CAPE (ABE) IS REMOVED BY CONVECTION DURING +!...THE PERIOD TIMEC... +! + IF(NOITR.EQ.1)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1060)FABE +! GOTO 265 + EXIT iter + ENDIF + DABE=AMAX1(ABE-ABEG,capeDX*ABE) + + FABE=ABEG/ABE + IF(FABE.GT.1. .and. ISHALL.EQ.0)THEN +! WRITE(98,*)'UPDRAFT/DOWNDRAFT COUPLET INCREASES CAPE AT THIS +! *GRID POINT; NO CONVECTION ALLOWED!' + RETURN + ENDIF + IF(NCOUNT.NE.1)THEN + IF(ABS(AINC-AINCOLD).LT.0.0001)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ENDIF + DFDA=(FABE-FABEOLD)/(AINC-AINCOLD) + IF(DFDA.GT.0.)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ENDIF + ENDIF + AINCOLD=AINC + FABEOLD=FABE + IF(AINC/AINCMX.GT.0.999.AND.FABE.GT.1.05-STAB)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1055)FABE +! GOTO 265 + EXIT + ENDIF + IF((FABE.LE.1.05-STAB.AND.FABE.GE.0.95-STAB) .or. NCOUNT.EQ.10)THEN + EXIT iter + ELSE + IF(NCOUNT.GT.10)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1060)FABE +! GOTO 265 + EXIT + ENDIF +! +!...IF MORE THAN 10% OF THE ORIGINAL CAPE REMAINS, INCREASE THE CONVECTIVE +!...MASS FLUX BY THE FACTOR AINC: +! + IF(FABE.EQ.0.)THEN + AINC=AINC*0.5 + ELSE + IF(DABE.LT.1.e-4)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ELSE + AINC=AINC*STAB*ABE/DABE + ENDIF + ENDIF +! AINC=AMIN1(AINCMX,AINC) + AINC=AMIN1(AINCMX,AINC) +!...IF AINC BECOMES VERY SMALL, EFFECTS OF CONVECTION ! JSK MODS +!...WILL BE MINIMAL SO JUST IGNORE IT... ! JSK MODS + IF(AINC.LT.0.05)then + RETURN ! JSK MODS + ENDIF +! AINC=AMAX1(AINC,0.05) ! JSK MODS + TDER=TDER2*AINC + PPTFLX=PPTFL2*AINC +! IF (XTIME.LT.10.)THEN +! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT, +! * FABEOLD,AINCOLD +! ENDIF + DO NK=1,LTOP + UMF(NK)=UMF2(NK)*AINC + DMF(NK)=DMF2(NK)*AINC + DETLQ(NK)=DETLQ2(NK)*AINC + DETIC(NK)=DETIC2(NK)*AINC + UDR(NK)=UDR2(NK)*AINC + UER(NK)=UER2(NK)*AINC + DER(NK)=DER2(NK)*AINC + DDR(NK)=DDR2(NK)*AINC + ENDDO +! +!...GO BACK UP FOR ANOTHER ITERATION... +! + ENDIF + ENDDO iter + +!ckay +! get the cloud fraction for layer NK+1=NK1 + updil = (100.-AINC) + updil = updil/100. + updil = updil*dxsq + Drag = 0.5 + + IF(ISHALL.EQ.1) THEN + DO NK=KLCL, LTOP + UMF_new = UMF(NK)/updil + denSplume = P0(NK)/(R*TU(NK)) + xcldfra = 0.07*alog(1.+(500.*UMF_new)) + xcldfra = amax1(0.01,xcldfra) + cldfra_sh_KF(I,NK,J) = amin1(0.2,xcldfra) +!ckaywup + DMF_new=DMF(NK)/updil + FXM_new=FXM(NK)/dxsq + w_up(I,NK,J) = (UMF_new+DMF_new-FXM_new)/denSplume + w_up(I,NK,J) = w_up(I,NK,J)*Drag*DT/TIMEC + ENDDO + ELSE + DO NK=KLCL, LTOP +! ww: moved the next line up + UMF_new = UMF(NK)/updil + denSplume = P0(NK)/(R*TU(NK)) + xcldfra = 0.14*alog(1.+(500.*UMF_new)) + xcldfra = amax1(0.01,xcldfra) + cldfra_dp_KF(I,NK,J) = amin1(0.6,xcldfra) +!new added downdraft impact + DMF_new = DMF(NK)/updil + FXM_new = FXM(NK)/dxsq + w_up(I,NK,J) = (UMF_new+DMF_new-FXM_new)/denSplume + w_up(I,NK,J) = w_up(I,NK,J)*Drag*DT/TIMEC + ENDDO + ENDIF +!ckaywup + envRHavg = 0.0 + DO NK=KLCL-1,LTOP1 + envEsat = 6.112*exp(17.67*(T0(NK)-273.16)/(243.5+T0(NK)-273.16)) + envEsat = envEsat * 100.0 ! to hPa + envQsat = 0.622*envEsat/(P0(NK)-envEsat) + envRH = Q0(NK)/envQsat + envRHavg = envRHavg + envRH + if(envRH.gt.1.01) then + w_up(I,NK,J) = 0.0 + end if + END DO +! +!...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV... +! +!...FRC2 IS THE FRACTION OF TOTAL CONDENSATE ! PPT FB MODS +!...GENERATED THAT GOES INTO PRECIPITIATION ! PPT FB MODS +! +! Redistribute hydormeteors according to the final mass-flux values: +! + IF(CPR.GT.0.)THEN + FRC2=PPTFLX/(CPR*AINC) ! PPT FB MODS + ELSE + FRC2=0. + ENDIF + DO NK=1,LTOP + QLPA(NK)=QL0(NK) + QIPA(NK)=QI0(NK) + QRPA(NK)=QR0(NK) + QSPA(NK)=QS0(NK) + RAINFB(NK)=PPTLIQ(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS + SNOWFB(NK)=PPTICE(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS + ENDDO + DO NTC=1,NSTEP +! +!...ASSIGN HYDROMETEORS CONCENTRATIONS AT THE TOP AND BOTTOM OF EACH LAYER +!...BASED ON THE SIGN OF OMEGA... +! + DO NK=1,LTOP + QLFXIN(NK)=0. + QLFXOUT(NK)=0. + QIFXIN(NK)=0. + QIFXOUT(NK)=0. + QRFXIN(NK)=0. + QRFXOUT(NK)=0. + QSFXIN(NK)=0. + QSFXOUT(NK)=0. + ENDDO + DO NK=2,LTOP + IF(OMG(NK).LE.0.)THEN + QLFXIN(NK)=-FXM(NK)*QLPA(NK-1) + QIFXIN(NK)=-FXM(NK)*QIPA(NK-1) + QRFXIN(NK)=-FXM(NK)*QRPA(NK-1) + QSFXIN(NK)=-FXM(NK)*QSPA(NK-1) + QLFXOUT(NK-1)=QLFXOUT(NK-1)+QLFXIN(NK) + QIFXOUT(NK-1)=QIFXOUT(NK-1)+QIFXIN(NK) + QRFXOUT(NK-1)=QRFXOUT(NK-1)+QRFXIN(NK) + QSFXOUT(NK-1)=QSFXOUT(NK-1)+QSFXIN(NK) + ELSE + QLFXOUT(NK)=FXM(NK)*QLPA(NK) + QIFXOUT(NK)=FXM(NK)*QIPA(NK) + QRFXOUT(NK)=FXM(NK)*QRPA(NK) + QSFXOUT(NK)=FXM(NK)*QSPA(NK) + QLFXIN(NK-1)=QLFXIN(NK-1)+QLFXOUT(NK) + QIFXIN(NK-1)=QIFXIN(NK-1)+QIFXOUT(NK) + QRFXIN(NK-1)=QRFXIN(NK-1)+QRFXOUT(NK) + QSFXIN(NK-1)=QSFXIN(NK-1)+QSFXOUT(NK) + ENDIF + ENDDO +! +!...UPDATE THE HYDROMETEOR CONCENTRATION VALUES AT EACH LEVEL... +! + DO NK=1,LTOP + QLPA(NK)=QLPA(NK)+(QLFXIN(NK)+DETLQ(NK)-QLFXOUT(NK))*DTIME*EMSD(NK) + QIPA(NK)=QIPA(NK)+(QIFXIN(NK)+DETIC(NK)-QIFXOUT(NK))*DTIME*EMSD(NK) + QRPA(NK)=QRPA(NK)+(QRFXIN(NK)-QRFXOUT(NK)+RAINFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS + QSPA(NK)=QSPA(NK)+(QSFXIN(NK)-QSFXOUT(NK)+SNOWFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS + ENDDO + ENDDO + DO NK=1,LTOP + QLG(NK)=QLPA(NK) + QIG(NK)=QIPA(NK) + QRG(NK)=QRPA(NK) + QSG(NK)=QSPA(NK) + ENDDO +! +!...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS +!...GRID POINT... +! +! IF (XTIME.LT.10.)THEN +! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC +! ENDIF + IF(IPRNT)THEN +! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC + WRITE(message,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC + CALL wrf_message(message) +! flush(98) + endif +! +!...SEND FINAL PARAMETERIZED VALUES TO OUTPUT FILES... +! +!297 IF(IPRNT)then + IF(IPRNT)then +! if(I.eq.16 .and. J.eq.41)then +! IF(ISTOP.EQ.1)THEN + write(98,*) +! write(98,*)'At t(h), I, J =',float(NTSD)*72./3600.,I,J + write(message,*)'P(LC), DTP, WKL, WKLCL =',p0(LC)/100., & + TLCL+DTLCL+dtrh-TENV,WKL,WKLCL + call wrf_message(message) + write(message,*)'TLCL, DTLCL, DTRH, TENV =',TLCL,DTLCL, & + DTRH,TENV + call wrf_message(message) + WRITE(message,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, & + TMIX-T00,PMIX,QMIX,ABE + call wrf_message(message) + WRITE(message,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., & + WLCL,CLDHGT(LC) + call wrf_message(message) + WRITE(message,1035)PEF,PEFCBH,LC,LET,WKL,VWS + call wrf_message(message) + write(message,*)'PRECIP EFFICIENCY =',PEFF + call wrf_message(message) + WRITE(message,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC + call wrf_message(message) +! ENDIF +!!!!! HERE !!!!!!! + WRITE(message,1070)' P ',' DP ',' DT K/D ',' DR K/D ',' OMG ', & + ' DOMGDP ',' UMF ',' UER ',' UDR ',' DMF ',' DER ' & + ,' DDR ',' EMS ',' W0 ',' DETLQ ',' DETIC ' + call wrf_message(message) + write(message,*)'just before DO 300...' + call wrf_message(message) +! flush(98) + DO NK=1,LTOP + K=LTOP-NK+1 + DTT=(TG(K)-T0(K))*86400./TIMEC + RL=XLV0-XLV1*TG(K) + DR=-(QG(K)-Q0(K))*RL*86400./(TIMEC*CP) + UDFRC=UDR(K)*TIMEC*EMSD(K) + UEFRC=UER(K)*TIMEC*EMSD(K) + DDFRC=DDR(K)*TIMEC*EMSD(K) + DEFRC=-DER(K)*TIMEC*EMSD(K) + WRITE(message,1075)P0(K)/100.,DP(K)/100.,DTT,DR,OMG(K),DOMGDP(K)*1.E4, & + UMF(K)/1.E6,UEFRC,UDFRC,DMF(K)/1.E6,DEFRC,DDFRC,EMS(K)/1.E11, & + W0AVG1D(K)*1.E2,DETLQ(K)*TIMEC*EMSD(K)*1.E3,DETIC(K)* & + TIMEC*EMSD(K)*1.E3 + call wrf_message(message) + ENDDO + WRITE(message,1085)'K','P','Z','T0','TG','DT','TU','TD','Q0','QG', & + 'DQ','QU','QD','QLG','QIG','QRG','QSG','RH0','RHG' + call wrf_message(message) + DO NK=1,KL + K=KX-NK+1 + DTT=TG(K)-T0(K) + TUC=TU(K)-T00 + IF(K.LT.LC.OR.K.GT.LTOP)TUC=0. + TDC=TZ(K)-T00 + IF((K.LT.LDB.OR.K.GT.LDT).AND.K.NE.LFS)TDC=0. + IF(T0(K).LT.T00)THEN + ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) + ELSE + ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) + ENDIF + QGS=ES*0.622/(P0(K)-ES) + RH0=Q0(K)/QES(K) + RHG=QG(K)/QGS + WRITE(message,1090)K,P0(K)/100.,Z0(K),T0(K)-T00,TG(K)-T00,DTT,TUC, & + TDC,Q0(K)*1000.,QG(K)*1000.,(QG(K)-Q0(K))*1000.,QU(K)* & + 1000.,QD(K)*1000.,QLG(K)*1000.,QIG(K)*1000.,QRG(K)*1000., & + QSG(K)*1000.,RH0,RHG + call wrf_message(message) + ENDDO +! +!...IF CALCULATIONS ABOVE SHOW AN ERROR IN THE MASS BUDGET, PRINT OUT A +!...TO BE USED LATER FOR DIAGNOSTIC PURPOSES, THEN ABORT RUN... +! +! IF(ISTOP.EQ.1 .or. ISHALL.EQ.1)THEN + +! IF(ISHALL.NE.1)THEN +! write(98,4421)i,j,iyr,imo,idy,ihr,imn +! write(98)i,j,iyr,imo,idy,ihr,imn,kl +! 4421 format(7i4) +! write(98,4422)kl +! 4422 format(i6) + DO 310 NK = 1,KL + k = kl - nk + 1 + write(98,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., & + u0(k),v0(k),W0AVG1D(K),dp(k),tke(k) +! write(98) p0,t0,q0,u0,v0,w0,dp,tke +! WRITE(98,1115)Z0(K),P0(K)/100.,T0(K)-273.16,Q0(K)*1000., +! * U0(K),V0(K),DP(K)/100.,W0AVG(I,J,K) + 310 CONTINUE + IF(ISTOP.EQ.1)THEN + CALL wrf_error_fatal ( 'KAIN-FRITSCH, istop=1, diags' ) + ENDIF +! ENDIF + 4455 format(8f11.3) + ENDIF + CNDTNF=(1.-EQFRC(LFS))*(QLIQ(LFS)+QICE(LFS))*DMF(LFS) + PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ + RAINCV(I,J)=DT*PRATEC(I,J) ! PPT FB MODS +! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS +! RNC=0.1*TIMEC*PPTFLX/DXSQ + RNC=RAINCV(I,J)*NIC + IF(ISHALL.EQ.0.AND.IPRNT)write (98,909)I,J,RNC + +! WRITE(98,1095)CPR*AINC,TDER+PPTFLX+CNDTNF +! +! EVALUATE MOISTURE BUDGET... +! + + QINIT=0. + QFNL=0. + DPT=0. + DO 315 NK=1,LTOP + DPT=DPT+DP(NK) + QINIT=QINIT+Q0(NK)*EMS(NK) + QFNL=QFNL+QG(NK)*EMS(NK) + QFNL=QFNL+(QLG(NK)+QIG(NK)+QRG(NK)+QSG(NK))*EMS(NK) + 315 CONTINUE + QFNL=QFNL+PPTFLX*TIMEC*(1.-FBFRC) ! PPT FB MODS +! QFNL=QFNL+PPTFLX*TIMEC ! PPT FB MODS + ERR2=(QFNL-QINIT)*100./QINIT + IF(IPRNT)WRITE(98,1110)QINIT,QFNL,ERR2 + IF(ABS(ERR2).GT.0.05 .AND. ISTOP.EQ.0)THEN +! write(99,*)'!!!!!!!! MOISTURE BUDGET ERROR IN KFPARA !!!' +! WRITE(99,1110)QINIT,QFNL,ERR2 + IPRNT=.TRUE. + ISTOP=1 + write(98,4422)kl + 4422 format(i6) + DO 311 NK = 1,KL + k = kl - nk + 1 +! write(99,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., & +! u0(k),v0(k),W0AVG1D(K),dp(k) +! write(98) p0,t0,q0,u0,v0,w0,dp,tke +! WRITE(98,1115)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & +! U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k) + WRITE(98,4456)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & + U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k) + 311 CONTINUE +! flush(98) + +! GOTO 297 +! STOP 'QVERR' + ENDIF + 1115 FORMAT (2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4) + 4456 format(8f12.3) + IF(PPTFLX.GT.0.)THEN + RELERR=ERR2*QINIT/(PPTFLX*TIMEC) + ELSE + RELERR=0. + ENDIF + IF(IPRNT)THEN + WRITE(98,1120)RELERR + WRITE(98,*)'TDER, CPR, TRPPT =', & + TDER,CPR*AINC,TRPPT*AINC + ENDIF +! +!...FEEDBACK TO RESOLVABLE SCALE TENDENCIES. +! +!...IF THE ADVECTIVE TIME PERIOD (TADVEC) IS LESS THAN SPECIFIED MINIMUM +!...TIMEC, ALLOW FEEDBACK TO OCCUR ONLY DURING TADVEC... +! + IF(TADVEC.LT.TIMEC)NIC=NINT(TADVEC/DT) + NCA(I,J) = REAL(NIC)*DT + IF(ISHALL.EQ.1)THEN + TIMEC = 2400. + NCA(I,J) = CUDT*60. + NSHALL = NSHALL+1 + ENDIF + + DO K=1,KX +! IF(IMOIST(INEST).NE.2)THEN +! +!...IF HYDROMETEORS ARE NOT ALLOWED, THEY MUST BE EVAPORATED OR SUBLIMATED +!...AND FED BACK AS VAPOR, ALONG WITH ASSOCIATED CHANGES IN TEMPERATURE. +!...NOTE: THIS WILL INTRODUCE CHANGES IN THE CONVECTIVE TEMPERATURE AND +!...WATER VAPOR FEEDBACK TENDENCIES AND MAY LEAD TO SUPERSATURATED VALUE +!...OF QG... +! +! RLC=XLV0-XLV1*TG(K) +! RLS=XLS0-XLS1*TG(K) +! CPM=CP*(1.+0.887*QG(K)) +! TG(K)=TG(K)-(RLC*(QLG(K)+QRG(K))+RLS*(QIG(K)+QSG(K)))/CPM +! QG(K)=QG(K)+(QLG(K)+QRG(K)+QIG(K)+QSG(K)) +! DQLDT(I,J,NK)=0. +! DQIDT(I,J,NK)=0. +! DQRDT(I,J,NK)=0. +! DQSDT(I,J,NK)=0. +! ELSE +! +!...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS... +! + IF(.NOT. F_QI .and. warm_rain)THEN + + CPM=CP*(1.+0.887*QG(K)) + TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM + DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC + DQIDT(K)=0. + DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC + DQSDT(K)=0. + ELSEIF(.NOT. F_QI .and. .not. warm_rain)THEN +! +!...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROMETEORS +!...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL +! + CPM=CP*(1.+0.887*QG(K)) + IF(K.LE.ML)THEN + TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM + ELSEIF(K.GT.ML)THEN + TG(K)=TG(K)+(QLG(K)+QRG(K))*RLF/CPM + ENDIF + DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC + DQIDT(K)=0. + DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC + DQSDT(K)=0. + ELSEIF(F_QI) THEN +! +!...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE TENDENCIES +!...OF HYDROMETEORS DIRECTLY... +! + DQCDT(K)=(QLG(K)-QL0(K))/TIMEC + DQIDT(K)=(QIG(K)-QI0(K))/TIMEC + DQRDT(K)=(QRG(K)-QR0(K))/TIMEC + IF (F_QS) THEN + DQSDT(K)=(QSG(K)-QS0(K))/TIMEC + ELSE + DQIDT(K)=DQIDT(K)+(QSG(K)-QS0(K))/TIMEC + ENDIF + ELSE +! PRINT *,'THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED!' + CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED' ) + ENDIF + + DTDT(K)=(TG(K)-T0(K))/TIMEC + DQDT(K)=(QG(K)-Q0(K))/TIMEC + ENDDO + PRATEC(I,J)=PPTFLX*(1.-FBFRC)/DXSQ + RAINCV(I,J)=DT*PRATEC(I,J) +! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS +! RNC=0.1*TIMEC*PPTFLX/DXSQ + RNC=RAINCV(I,J)*NIC + 909 FORMAT('AT I, J =',i3,1x,i3,' CONVECTIVE RAINFALL =',F8.4,' mm') +! write (98,909)I,J,RNC +! write (6,909)I,J,RNC +! WRITE(98,*)'at NTSD =',NTSD,',No. of KF points activated =', +! * NCCNT +! flush(98) +1000 FORMAT(' ',10A8) +1005 FORMAT(' ',F6.0,2X,F6.4,2X,F7.3,1X,F6.4,2X,4(F6.3,2X),2(F7.3,1X)) +1010 FORMAT(' ',' VERTICAL VELOCITY IS NEGATIVE AT ',F4.0,' MB') +1015 FORMAT(' ','ALL REMAINING MASS DETRAINS BELOW ',F4.0,' MB') +1025 FORMAT(5X,' KLCL=',I2,' ZLCL=',F7.1,'M', & + ' DTLCL=',F5.2,' LTOP=',I2,' P0(LTOP)=',-2PF5.1,'MB FRZ LV=', & + I2,' TMIX=',0PF4.1,1X,'PMIX=',-2PF6.1,' QMIX=',3PF5.1, & + ' CAPE=',0PF7.1) +1030 FORMAT(' ',' P0(LET) = ',F6.1,' P0(LTOP) = ',F6.1,' VMFLCL =', & + E12.3,' PLCL =',F6.1,' WLCL =',F6.3,' CLDHGT =', & + F8.1) +1035 FORMAT(1X,'PEF(WS)=',F4.2,'(CB)=',F4.2,'LC,LET=',2I3,'WKL=' & + ,F6.3,'VWS=',F5.2) +!1055 FORMAT('*** DEGREE OF STABILIZATION =',F5.3, & +! ', NO MORE MASS FLUX IS ALLOWED!') +!1060 FORMAT(' ITERATION DOES NOT CONVERGE TO GIVE THE SPECIFIED & +! &DEGREE OF STABILIZATION! FABE= ',F6.4) + 1070 FORMAT (16A8) + 1075 FORMAT (F8.2,3(F8.2),2(F8.3),F8.2,2F8.3,F8.2,6F8.3) + 1080 FORMAT(2X,'LFS,LDB,LDT =',3I3,' TIMEC, TADVEC, NSTEP=', & + 2(1X,F5.0),I3,'NCOUNT, FABE, AINC=',I2,1X,F5.3,F6.2) + 1085 FORMAT (A3,16A7,2A8) + 1090 FORMAT (I3,F7.2,F7.0,10F7.2,4F7.3,2F8.3) + 1095 FORMAT(' ',' PPT PRODUCTION RATE= ',F10.0,' TOTAL EVAP+PPT= ',F10.0) +1105 FORMAT(' ','NET LATENT HEAT RELEASE =',E12.5,' ACTUAL HEATING =',& + E12.5,' J/KG-S, DIFFERENCE = ',F9.3,'%') +1110 FORMAT(' ','INITIAL WATER =',E12.5,' FINAL WATER =',E12.5, & + ' TOTAL WATER CHANGE =',F8.2,'%') +! 1115 FORMAT (2X,F6.0,2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4) +1120 FORMAT(' ','MOISTURE ERROR AS FUNCTION OF TOTAL PPT =',F9.3,'%') +! +!----------------------------------------------------------------------- +!--------------SAVE CLOUD TOP AND BOTTOM FOR RADIATION------------------ +!----------------------------------------------------------------------- +! + CUTOP(I,J)=REAL(LTOP) + CUBOT(I,J)=REAL(LCL) +! +!----------------------------------------------------------------------- + END SUBROUTINE KF_eta_PARA +!******************************************************************** +! *********************************************************************** + SUBROUTINE TPMIX2(p,thes,tu,qu,qliq,qice,qnewlq,qnewic,XLV1,XLV0) +! +! Lookup table variables: +! INTEGER, PARAMETER :: (KFNT=250,KFNP=220) +! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB +! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K +! REAL, SAVE, DIMENSION(1:200) :: ALU +! REAL, SAVE :: RDPR,RDTHK,PLUTOP +! End of Lookup table variables: +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,THES,XLV1,XLV0 + REAL, INTENT(OUT ) :: QNEWLQ,QNEWIC + REAL, INTENT(INOUT) :: TU,QU,QLIQ,QICE + REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11, & + TEMP,QS,QNEW,DQ,QTOT,RLL,CPP + INTEGER :: IPTB,ITHTB +!----------------------------------------------------------------------- + +!c******** LOOKUP TABLE VARIABLES... **************************** +! parameter(kfnt=250,kfnp=220) +!c +! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp), +! * alu(200),rdpr,rdthk,plutop +!C*************************************************************** +!c +!c*********************************************************************** +!c scaling pressure and tt table index +!c*********************************************************************** +!c + tp=(p-plutop)*rdpr + qq=tp-aint(tp) + iptb=int(tp)+1 + +! +!*********************************************************************** +! base and scaling factor for the +!*********************************************************************** +! +! scaling the and tt table index + bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb) + tth=(thes-bth)*rdthk + pp =tth-aint(tth) + ithtb=int(tth)+1 + IF(IPTB.GE.220 .OR. IPTB.LE.1 .OR. ITHTB.GE.250 .OR. ITHTB.LE.1)THEN + write(98,*)'**** OUT OF BOUNDS *********' +! flush(98) + ENDIF +! + t00=ttab(ithtb ,iptb ) + t10=ttab(ithtb+1,iptb ) + t01=ttab(ithtb ,iptb+1) + t11=ttab(ithtb+1,iptb+1) +! + q00=qstab(ithtb ,iptb ) + q10=qstab(ithtb+1,iptb ) + q01=qstab(ithtb ,iptb+1) + q11=qstab(ithtb+1,iptb+1) +! +!*********************************************************************** +! parcel temperature +!*********************************************************************** +! + temp=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq) +! + qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq) +! + DQ=QS-QU + IF(DQ.LE.0.)THEN + QNEW=QU-QS + QU=QS + ELSE +! +! IF THE PARCEL IS SUBSATURATED, TEMPERATURE AND MIXING RATIO MUST BE +! ADJUSTED...IF LIQUID WATER IS PRESENT, IT IS ALLOWED TO EVAPORATE +! + QNEW=0. + QTOT=QLIQ+QICE +! +! IF THERE IS ENOUGH LIQUID OR ICE TO SATURATE THE PARCEL, TEMP STAYS AT ITS +! WET BULB VALUE, VAPOR MIXING RATIO IS AT SATURATED LEVEL, AND THE MIXING +! RATIOS OF LIQUID AND ICE ARE ADJUSTED TO MAKE UP THE ORIGINAL SATURATION +! DEFICIT... OTHERWISE, ANY AVAILABLE LIQ OR ICE VAPORIZES AND APPROPRIATE +! ADJUSTMENTS TO PARCEL TEMP; VAPOR, LIQUID, AND ICE MIXING RATIOS ARE MADE. +! +!...subsaturated values only occur in calculations involving various mixtures of +!...updraft and environmental air for estimation of entrainment and detrainment. +!...For these purposes, assume that reasonable estimates can be given using +!...liquid water saturation calculations only - i.e., ignore the effect of the +!...ice phase in this process only...will not affect conservative properties... +! + IF(QTOT.GE.DQ)THEN + qliq=qliq-dq*qliq/(qtot+1.e-10) + qice=qice-dq*qice/(qtot+1.e-10) + QU=QS + ELSE + RLL=XLV0-XLV1*TEMP + CPP=1004.5*(1.+0.89*QU) + IF(QTOT.LT.1.E-10)THEN +! +!...IF NO LIQUID WATER OR ICE IS AVAILABLE, TEMPERATURE IS GIVEN BY: + TEMP=TEMP+RLL*(DQ/(1.+DQ))/CPP + ELSE +! +!...IF SOME LIQ WATER/ICE IS AVAILABLE, BUT NOT ENOUGH TO ACHIEVE SATURATION, +! THE TEMPERATURE IS GIVEN BY: +! + TEMP=TEMP+RLL*((DQ-QTOT)/(1+DQ-QTOT))/CPP + QU=QU+QTOT + QTOT=0. + QLIQ=0. + QICE=0. + ENDIF + ENDIF + ENDIF + TU=TEMP + qnewlq=qnew + qnewic=0. +! + END SUBROUTINE TPMIX2 +!****************************************************************************** + SUBROUTINE DTFRZNEW(TU,P,THTEU,QU,QFRZ,QICE,ALIQ,BLIQ,CLIQ,DLIQ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,QFRZ,ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(INOUT) :: TU,THTEU,QU,QICE + REAL :: RLC,RLS,RLF,CPP,A,DTFRZ,ES,QS,DQEVAP,PII +!----------------------------------------------------------------------- +! +!...ALLOW THE FREEZING OF LIQUID WATER IN THE UPDRAFT TO PROCEED AS AN +!...APPROXIMATELY LINEAR FUNCTION OF TEMPERATURE IN THE TEMPERATURE RANGE +!...TTFRZ TO TBFRZ... +!...FOR COLDER TEMPERATURES, FREEZE ALL LIQUID WATER... +!...THERMODYNAMIC PROPERTIES ARE STILL CALCULATED WITH RESPECT TO LIQUID WATER +!...TO ALLOW THE USE OF LOOKUP TABLE TO EXTRACT TMP FROM THETAE... +! + RLC=2.5E6-2369.276*(TU-273.16) + RLS=2833922.-259.532*(TU-273.16) + RLF=RLS-RLC + CPP=1004.5*(1.+0.89*QU) +! +! A = D(es)/DT IS THAT CALCULATED FROM BUCK (1981) EMPERICAL FORMULAS +! FOR SATURATION VAPOR PRESSURE... +! + A=(CLIQ-BLIQ*DLIQ)/((TU-DLIQ)*(TU-DLIQ)) + DTFRZ = RLF*QFRZ/(CPP+RLS*QU*A) + TU = TU+DTFRZ + + ES = ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) + QS = ES*0.622/(P-ES) +! +!...FREEZING WARMS THE AIR AND IT BECOMES UNSATURATED...ASSUME THAT SOME OF THE +!...LIQUID WATER THAT IS AVAILABLE FOR FREEZING EVAPORATES TO MAINTAIN SATURA- +!...TION...SINCE THIS WATER HAS ALREADY BEEN TRANSFERRED TO THE ICE CATEGORY, +!...SUBTRACT IT FROM ICE CONCENTRATION, THEN SET UPDRAFT MIXING RATIO AT THE NEW +!...TEMPERATURE TO THE SATURATION VALUE... +! + DQEVAP = QS-QU + QICE = QICE-DQEVAP + QU = QU+DQEVAP + PII=(1.E5/P)**(0.2854*(1.-0.28*QU)) + THTEU=TU*PII*EXP((3374.6525/TU-2.5403)*QU*(1.+0.81*QU)) +! + END SUBROUTINE DTFRZNEW +! -------------------------------------------------------------------------------- + + SUBROUTINE CONDLOAD(QLIQ,QICE,WTW,DZ,BOTERM,ENTERM,RATE,QNEWLQ, & + QNEWIC,QLQOUT,QICOUT,G) + +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US +! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL- +! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI- +! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL +! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ). + + REAL, INTENT(IN ) :: G + REAL, INTENT(IN ) :: DZ,BOTERM,ENTERM,RATE + REAL, INTENT(INOUT) :: QLQOUT,QICOUT,WTW,QLIQ,QICE,QNEWLQ,QNEWIC + REAL :: QTOT,QNEW,QEST,G1,WAVG,CONV,RATIO3,OLDQ,RATIO4,DQ,PPTDRG +! + QTOT=QLIQ+QICE + QNEW=QNEWLQ+QNEWIC +! +! ESTIMATE THE VERTICAL VELOCITY SO THAT AN AVERAGE VERTICAL VELOCITY +! BE CALCULATED TO ESTIMATE THE TIME REQUIRED FOR ASCENT BETWEEN MODEL +! LEVELS... +! + QEST=0.5*(QTOT+QNEW) + G1=WTW+BOTERM-ENTERM-2.*G*DZ*QEST/1.5 + IF(G1.LT.0.0)G1=0. + WAVG=0.5*(SQRT(WTW)+SQRT(G1)) + CONV=RATE*DZ/WAVG ! KF90 Eq. 9 +! +! RATIO3 IS THE FRACTION OF LIQUID WATER IN FRESH CONDENSATE, RATIO4 IS +! THE FRACTION OF LIQUID WATER IN THE TOTAL AMOUNT OF CONDENSATE INVOLV +! IN THE PRECIPITATION PROCESS - NOTE THAT ONLY 60% OF THE FRESH CONDEN +! SATE IS IS ALLOWED TO PARTICIPATE IN THE CONVERSION PROCESS... +! + RATIO3=QNEWLQ/(QNEW+1.E-8) +! OLDQ=QTOT + QTOT=QTOT+0.6*QNEW + OLDQ=QTOT + RATIO4=(0.6*QNEWLQ+QLIQ)/(QTOT+1.E-8) + QTOT=QTOT*EXP(-CONV) ! KF90 Eq. 9 +! +! DETERMINE THE AMOUNT OF PRECIPITATION THAT FALLS OUT OF THE UPDRAFT +! PARCEL AT THIS LEVEL... +! + DQ=OLDQ-QTOT + QLQOUT=RATIO4*DQ + QICOUT=(1.-RATIO4)*DQ +! +! ESTIMATE THE MEAN LOAD OF CONDENSATE ON THE UPDRAFT IN THE LAYER, CAL +! LATE VERTICAL VELOCITY +! + PPTDRG=0.5*(OLDQ+QTOT-0.2*QNEW) + WTW=WTW+BOTERM-ENTERM-2.*G*DZ*PPTDRG/1.5 + IF(ABS(WTW).LT.1.E-4)WTW=1.E-4 +! +! DETERMINE THE NEW LIQUID WATER AND ICE CONCENTRATIONS INCLUDING LOSSE +! DUE TO PRECIPITATION AND GAINS FROM CONDENSATION... +! + QLIQ=RATIO4*QTOT+RATIO3*0.4*QNEW + QICE=(1.-RATIO4)*QTOT+(1.-RATIO3)*0.4*QNEW + QNEWLQ=0. + QNEWIC=0. + + END SUBROUTINE CONDLOAD + +! ---------------------------------------------------------------------- + SUBROUTINE PROF5(EQ,EE,UD) +! +!*********************************************************************** +!***** GAUSSIAN TYPE MIXING PROFILE....****************************** +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! THIS SUBROUTINE INTEGRATES THE AREA UNDER THE CURVE IN THE GAUSSIAN +! DISTRIBUTION...THE NUMERICAL APPROXIMATION TO THE INTEGRAL IS TAKEN FROM +! "HANDBOOK OF MATHEMATICAL FUNCTIONS WITH FORMULAS, GRAPHS AND MATHEMATICS TABLES" +! ED. BY ABRAMOWITZ AND STEGUN, NATL BUREAU OF STANDARDS APPLIED +! MATHEMATICS SERIES. JUNE, 1964., MAY, 1968. +! JACK KAIN +! 7/6/89 +! Solves for KF90 Eq. 2 +! +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: EQ + REAL, INTENT(INOUT) :: EE,UD + REAL :: SQRT2P,A1,A2,A3,P,SIGMA,FE,X,Y,EY,E45,T1,T2,C1,C2 + + DATA SQRT2P,A1,A2,A3,P,SIGMA,FE/2.506628,0.4361836,-0.1201676, & + 0.9372980,0.33267,0.166666667,0.202765151/ + X=(EQ-0.5)/SIGMA + Y=6.*EQ-3. + EY=EXP(Y*Y/(-2)) + E45=EXP(-4.5) + T2=1./(1.+P*ABS(Y)) + T1=0.500498 + C1=A1*T1+A2*T1*T1+A3*T1*T1*T1 + C2=A1*T2+A2*T2*T2+A3*T2*T2*T2 + IF(Y.GE.0.)THEN + EE=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*EQ*EQ/2. + UD=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*(0.5+EQ*EQ/2.- & + EQ) + ELSE + EE=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*EQ*EQ/2. + UD=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*(0.5+EQ* & + EQ/2.-EQ) + ENDIF + EE=EE/FE + UD=UD/FE + + END SUBROUTINE PROF5 + +! ------------------------------------------------------------------------ + SUBROUTINE TPMIX2DD(p,thes,ts,qs,i,j) +! +! Lookup table variables: +! INTEGER, PARAMETER :: (KFNT=250,KFNP=220) +! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB +! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K +! REAL, SAVE, DIMENSION(1:200) :: ALU +! REAL, SAVE :: RDPR,RDTHK,PLUTOP +! End of Lookup table variables: +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,THES + REAL, INTENT(INOUT) :: TS,QS + INTEGER, INTENT(IN ) :: i,j ! avail for debugging + REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11 + INTEGER :: IPTB,ITHTB + CHARACTER*256 :: MESS +!----------------------------------------------------------------------- + +! +!******** LOOKUP TABLE VARIABLES (F77 format)... **************************** +! parameter(kfnt=250,kfnp=220) +! +! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp), & +! alu(200),rdpr,rdthk,plutop +!*************************************************************** +! +!*********************************************************************** +! scaling pressure and tt table index +!*********************************************************************** +! + tp=(p-plutop)*rdpr + qq=tp-aint(tp) + iptb=int(tp)+1 +! +!*********************************************************************** +! base and scaling factor for the +!*********************************************************************** +! +! scaling the and tt table index + bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb) + tth=(thes-bth)*rdthk + pp =tth-aint(tth) + ithtb=int(tth)+1 +! + t00=ttab(ithtb ,iptb ) + t10=ttab(ithtb+1,iptb ) + t01=ttab(ithtb ,iptb+1) + t11=ttab(ithtb+1,iptb+1) +! + q00=qstab(ithtb ,iptb ) + q10=qstab(ithtb+1,iptb ) + q01=qstab(ithtb ,iptb+1) + q11=qstab(ithtb+1,iptb+1) +! +!*********************************************************************** +! parcel temperature and saturation mixing ratio +!*********************************************************************** +! + ts=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq) +! + qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq) +! + END SUBROUTINE TPMIX2DD + +! ----------------------------------------------------------------------- + SUBROUTINE ENVIRTHT(P1,T1,Q1,THT1,ALIQ,BLIQ,CLIQ,DLIQ) +! +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P1,T1,Q1,ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(INOUT) :: THT1 + REAL :: EE,TLOG,ASTRT,AINC,A1,TP,VALUE,AINTRP,TDPT,TSAT,THT, & + T00,P00,C1,C2,C3,C4,C5 + INTEGER :: INDLU +!----------------------------------------------------------------------- + DATA T00,P00,C1,C2,C3,C4,C5/273.16,1.E5,3374.6525,2.5403,3114.834, & + 0.278296,1.0723E-3/ +! +! CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMPERATURE... +! +! NOTE: Calculations for mixed/ice phase no longer used...jsk 8/00 +! For example, KF90 Eq. 10 no longer used +! + EE=Q1*P1/(0.622+Q1) +! TLOG=ALOG(EE/ALIQ) +! ...calculate LOG term using lookup table... +! + astrt=1.e-3 + ainc=0.075 + a1=ee/aliq + tp=(a1-astrt)/ainc + indlu=int(tp)+1 + value=(indlu-1)*ainc+astrt + aintrp=(a1-value)/ainc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) +! + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TSAT=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T1-T00))*(T1-TDPT) + THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1)) + THT1=THT*EXP((C1/TSAT-C2)*Q1*(1.+0.81*Q1)) +! + END SUBROUTINE ENVIRTHT +! *********************************************************************** +!==================================================================== + SUBROUTINE mskf_init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, & + SVP1,SVP2,SVP3,SVPT0, & + P_FIRST_SCALAR,restart,allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + LOGICAL , INTENT(IN) :: restart,allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: P_QI,P_QS,P_FIRST_SCALAR + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA + + INTEGER :: i, j, k, itf, jtf, ktf + REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + + IF(.not.restart)THEN + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RTHCUTEN(i,k,j)=0. + RQVCUTEN(i,k,j)=0. + RQCCUTEN(i,k,j)=0. + RQRCUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + IF (P_QI .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQICUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QS .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQSCUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + DO j=jts,jtf + DO i=its,itf + NCA(i,j)=-100. + ENDDO + ENDDO + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + W0AVG(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + endif + + CALL KF_LUTAB(SVP1,SVP2,SVP3,SVPT0) + + END SUBROUTINE mskf_init + +!------------------------------------------------------- + + subroutine kf_lutab(SVP1,SVP2,SVP3,SVPT0) +! +! This subroutine is a lookup table. +! Given a series of series of saturation equivalent potential +! temperatures, the temperature is calculated. +! +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- +! Lookup table variables +! INTEGER, SAVE, PARAMETER :: KFNT=250,KFNP=220 +! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB +! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K +! REAL, SAVE, DIMENSION(1:200) :: ALU +! REAL, SAVE :: RDPR,RDTHK,PLUTOP +! End of Lookup table variables + + INTEGER :: KP,IT,ITCNT,I + REAL :: DTH,TMIN,TOLER,PBOT,DPR, & + TEMP,P,ES,QS,PI,THES,TGUES,THGUES,F0,T1,T0,THGS,F1,DT, & + ASTRT,AINC,A1,THTGS +! REAL :: ALIQ,BLIQ,CLIQ,DLIQ,SVP1,SVP2,SVP3,SVPT0 + REAL :: ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 +! +! equivalent potential temperature increment + data dth/1./ +! minimum starting temp + data tmin/150./ +! tolerance for accuracy of temperature + data toler/0.001/ +! top pressure (pascals) + plutop=5000.0 +! bottom pressure (pascals) + pbot=110000.0 + + ALIQ = SVP1*1000. + BLIQ = SVP2 + CLIQ = SVP2*SVPT0 + DLIQ = SVP3 + +! +! compute parameters +! +! 1._over_(sat. equiv. theta increment) + rdthk=1./dth +! pressure increment +! + DPR=(PBOT-PLUTOP)/REAL(KFNP-1) +! dpr=(pbot-plutop)/REAL(kfnp-1) +! 1._over_(pressure increment) + rdpr=1./dpr +! compute the spread of thes +! thespd=dth*(kfnt-1) +! +! calculate the starting sat. equiv. theta +! + temp=tmin + p=plutop-dpr + do kp=1,kfnp + p=p+dpr + es=aliq*exp((bliq*temp-cliq)/(temp-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + the0k(kp)=temp*pi*exp((3374.6525/temp-2.5403)*qs* & + (1.+0.81*qs)) + enddo +! +! compute temperatures for each sat. equiv. potential temp. +! + p=plutop-dpr + do kp=1,kfnp + thes=the0k(kp)-dth + p=p+dpr + do it=1,kfnt +! define sat. equiv. pot. temp. + thes=thes+dth +! iterate to find temperature +! find initial guess + if(it.eq.1) then + tgues=tmin + else + tgues=ttab(it-1,kp) + endif + es=aliq*exp((bliq*tgues-cliq)/(tgues-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + thgues=tgues*pi*exp((3374.6525/tgues-2.5403)*qs* & + (1.+0.81*qs)) + f0=thgues-thes + t1=tgues-0.5*f0 + t0=tgues + itcnt=0 +! iteration loop + do itcnt=1,11 + es=aliq*exp((bliq*t1-cliq)/(t1-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + thtgs=t1*pi*exp((3374.6525/t1-2.5403)*qs*(1.+0.81*qs)) + f1=thtgs-thes + if(abs(f1).lt.toler)then + exit + endif +! itcnt=itcnt+1 + dt=f1*(t1-t0)/(f1-f0) + t0=t1 + f0=f1 + t1=t1-dt + enddo + ttab(it,kp)=t1 + qstab(it,kp)=qs + enddo + enddo +! +! lookup table for tlog(emix/aliq) +! +! set up intial values for lookup tables +! + astrt=1.e-3 + ainc=0.075 +! + a1=astrt-ainc + do i=1,200 + a1=a1+ainc + alu(i)=alog(a1) + enddo +! + END SUBROUTINE KF_LUTAB + +END MODULE module_cu_mskf diff --git a/wrfv2_fire/phys/module_cu_ntiedtke.F b/wrfv2_fire/phys/module_cu_ntiedtke.F new file mode 100644 index 00000000..e109d7d4 --- /dev/null +++ b/wrfv2_fire/phys/module_cu_ntiedtke.F @@ -0,0 +1,3719 @@ +!----------------------------------------------------------------------- +! +!wrf:model_layer:physics +! +!####################tiedtke scheme######################### +! m.tiedtke e.c.m.w.f. 1989 +! j.morcrette 1992 +!-------------------------------------------- +! modifications +! C. zhang & Yuqing Wang 2011-2014 +! +! modified from IPRC IRAM - yuqing wang, university of hawaii +! & ICTP REGCM4.4 +! +! this scheme is experimental. There are many updates to the old Tiedtke scheme (cu_physics=6) +! update notes: +! the new Tiedtke scheme is similar to the Tiedtke scheme used in REGCM4 and ECMWF cy40r1. +! the major differences to the old Tiedtke (cu_physics=6) scheme are, +! (a) New trigger functions for deep and shallow convections (Jakob and Siebesma 2003; +! Bechtold et al. 2004, 2008, 2014). +! (b) Non-equilibrium situations are considered in the closure for deep convection +! (Bechtold et al. 2014). +! (c) New convection time scale for the deep convection closure (Bechtold et al. 2008). +! (d) New entrainment and detrainment rates for all convection types (Bechtold et al. 2008). +! (e) New formula for the conversion from cloud water/ice to rain/snow (Sundqvist 1978). +! (f) Different way to include cloud scale pressure gradients (Gregory et al. 1997; +! Wu and Yanai 1994) +! +! other refenrence: tiedtke (1989, mwr, 117, 1779-1800) +! IFS documentation - cy33r1, cy37r2, cy38r1, cy40r1 +! +!########################################################### + +module module_cu_ntiedtke + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + use module_model_constants, only:rd=>r_d, rv=>r_v, & + & cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, epsl=>epsilon, g + + implicit none + real,private :: rcpd,vtmpc1,tmelt, & + c1es,c2es,c3les,c3ies,c4les,c4ies,c5les,c5ies,zrg + + real,private :: r5alvcp,r5alscp,ralvdcp,ralsdcp,ralfdcp,rtwat,rtber,rtice + real,private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon + integer,private :: ntrigger,momtrans,p950,p650 + + parameter( & + rcpd=1.0/cpd, & + tmelt=273.16, & + zrg=1.0/g, & + c1es=610.78, & + c2es=c1es*rd/rv, & + c3les=17.2693882, & + c3ies=21.875, & + c4les=35.86, & + c4ies=7.66, & + c5les=c3les*(tmelt-c4les), & + c5ies=c3ies*(tmelt-c4ies), & + r5alvcp=c5les*alv*rcpd, & + r5alscp=c5ies*als*rcpd, & + ralvdcp=alv*rcpd, & + ralsdcp=als*rcpd, & + ralfdcp=alf*rcpd, & + rtwat=tmelt, & + rtber=tmelt-5., & + rtice=tmelt-23., & + vtmpc1=rv/rd-1.0 ) +! +! entrdd: average entrainment & detrainment rate for downdrafts +! ------ +! + parameter(entrdd = 3.0e-4) +! +! cmfcmax: maximum massflux value allowed for updrafts etc +! ------- +! + parameter(cmfcmax = 1.0) +! +! cmfcmin: minimum massflux value (for safety) +! ------- +! + parameter(cmfcmin = 1.e-10) +! +! cmfdeps: fractional massflux for downdrafts at lfs +! ------- +! + parameter(cmfdeps = 0.30) + +! zdnoprc: deep cloud is thicker than this height +! + parameter(zdnoprc = 2.0e4) +! ------- +! +! cprcon: coefficient from cloud water to rain water +! + parameter(cprcon = 1.4e-3) +! ------- +! +! momtrans: momentum transport method +! + parameter(momtrans = 2 ) +! ------- + +!-------------------- +! switches for deep, mid, shallow convections, downdraft, and momemtum transport +! ------------------ + logical :: lmfpen,lmfmid,lmfscv,lmfdd,lmfdudv + parameter(lmfpen=.true.,lmfmid=.true.,lmfscv=.true.,lmfdd=.true.,lmfdudv=.true.) +!-------------------- +!#################### end of variables definition########################## +!----------------------------------------------------------------------- +! +contains +!----------------------------------------------------------------------- + subroutine cu_ntiedtke( & + dt,itimestep,stepcu & + ,raincv,pratec,qfx,hfx & + ,u3d,v3d,w,t3d,qv3d,qc3d,qi3d,pi3d,rho3d & + ,qvften,thften & + ,dz8w,pcps,p8w,xland,cu_act_flag,dx & + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ,rthcuten,rqvcuten,rqccuten,rqicuten & + ,rucuten, rvcuten & + ,f_qv ,f_qc ,f_qr ,f_qi ,f_qs & + ) +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- +!-- u3d 3d u-velocity interpolated to theta points (m/s) +!-- v3d 3d v-velocity interpolated to theta points (m/s) +!-- th3d 3d potential temperature (k) +!-- t3d temperature (k) +!-- qv3d 3d water vapor mixing ratio (kg/kg) +!-- qc3d 3d cloud mixing ratio (kg/kg) +!-- qi3d 3d ice mixing ratio (kg/kg) +!-- rho3d 3d air density (kg/m^3) +!-- p8w 3d hydrostatic pressure at full levels (pa) +!-- pcps 3d hydrostatic pressure at half levels (pa) +!-- pi3d 3d exner function (dimensionless) +!-- qvften 3d total advective moisture tendency (kg kg-1 s-1) +!-- thften 3d total advective temperature tendency (k s-1) +!-- rthcuten theta tendency due to +! cumulus scheme precipitation (k/s) +!-- rucuten u wind tendency due to +! cumulus scheme precipitation (k/s) +!-- rvcuten v wind tendency due to +! cumulus scheme precipitation (k/s) +!-- rqvcuten qv tendency due to +! cumulus scheme precipitation (kg/kg/s) +!-- rqccuten qc tendency due to +! cumulus scheme precipitation (kg/kg/s) +!-- rqicuten qi tendency due to +! cumulus scheme precipitation (kg/kg/s) +!-- rainc accumulated total cumulus scheme precipitation (mm) +!-- raincv cumulus scheme precipitation (mm) +!-- pratec precipitiation rate from cumulus scheme (mm/s) +!-- dz8w dz between full levels (m) +!-- qfx upward moisture flux at the surface (kg/m^2/s) +!-- hfx upward heat flux at the surface (w/m^2) +!-- dt time step (s) +!-- ids start index for i in domain +!-- ide end index for i in domain +!-- jds start index for j in domain +!-- jde end index for j in domain +!-- kds start index for k in domain +!-- kde end index for k in domain +!-- ims start index for i in memory +!-- ime end index for i in memory +!-- jms start index for j in memory +!-- jme end index for j in memory +!-- kms start index for k in memory +!-- kme end index for k in memory +!-- its start index for i in tile +!-- ite end index for i in tile +!-- jts start index for j in tile +!-- jte end index for j in tile +!-- kts start index for k in tile +!-- kte end index for k in tile +!------------------------------------------------------------------- + integer, intent(in) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + itimestep, & + stepcu + + real, intent(in) :: & + dt, & + dx + + + real, dimension(ims:ime, jms:jme), intent(in) :: & + xland + + real, dimension(ims:ime, jms:jme), intent(inout) :: & + raincv, pratec + + logical, dimension(ims:ime,jms:jme), intent(inout) :: & + cu_act_flag + + + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: & + dz8w, & + pcps, & + p8w, & + pi3d, & + qc3d, & + qvften, & + thften, & + qi3d, & + qv3d, & + rho3d, & + t3d, & + u3d, & + v3d, & + w + real, dimension(ims:ime, jms:jme) :: & + qfx, & + hfx + +!--------------------------- optional vars ---------------------------- + + real, dimension(ims:ime, kms:kme, jms:jme), & + optional, intent(inout) :: & + rqccuten, & + rqicuten, & + rqvcuten, & + rthcuten, & + rucuten, & + rvcuten + +! +! flags relating to the optional tendency arrays declared above +! models that carry the optional tendencies will provdide the +! optional arguments at compile time; these flags all the model +! to determine at run-time whether a particular tracer is in +! use or not. +! + logical, optional :: & + f_qv & + ,f_qc & + ,f_qr & + ,f_qi & + ,f_qs + +!--------------------------- local vars ------------------------------ + real :: & + delt, & + rdelt + + real , dimension(its:ite) :: & + rcs, & + rn, & + evap, & + heatflux + integer , dimension(its:ite) :: slimsk + + + real , dimension(its:ite, kts:kte+1) :: & + prsi, & + ghti, & + zi + + real , dimension(its:ite, kts:kte) :: & + dot, & + prsl, & + q1, & + q2, & + q3, & + q1b, & + t1b, & + q11, & + q12, & + t1, & + u1, & + v1, & + zl, & + omg, & + ghtl + + integer, dimension(its:ite) :: & + kbot, & + ktop + + integer :: & + i, & + im, & + j, & + k, & + km, & + kp, & + kx, & + kx1 + +!-------other local variables---- + integer :: zz +!----------------------------------------------------------------------- +! +! +!*** check to see if this is a convection timestep +! + +!----------------------------------------------------------------------- + do j=jts,jte + do i=its,ite + cu_act_flag(i,j)=.true. + enddo + enddo + + im=ite-its+1 + kx=kte-kts+1 + kx1=kx+1 + delt=dt*stepcu + rdelt=1./delt + +!------------- j loop (outer) -------------------------------------------------- + + do j=jts,jte + +! --------------- compute zi and zl ----------------------------------------- + do i=its,ite + zi(i,kts)=0.0 + enddo +! + do k=kts,kte + do i=its,ite + zi(i,k+1)=zi(i,k)+dz8w(i,k,j) + enddo + enddo +! + do k=kts,kte + do i=its,ite + zl(i,k)=0.5*(zi(i,k)+zi(i,k+1)) + enddo + enddo + +! --------------- end compute zi and zl ------------------------------------- + do i=its,ite + slimsk(i)=int(abs(xland(i,j)-2.)) + enddo + + do k=kts,kte + kp=k+1 + do i=its,ite + dot(i,k)=-0.5*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j)) + enddo + enddo + + do k=kts,kte + zz = kte+1-k + do i=its,ite + u1(i,zz)=u3d(i,k,j) + v1(i,zz)=v3d(i,k,j) + t1(i,zz)=t3d(i,k,j) + q1(i,zz)=qv3d(i,k,j) + if(itimestep == 1) then + q1b(i,zz)=0. + t1b(i,zz)=0. + else + q1b(i,zz)=qvften(i,k,j) + t1b(i,zz)=thften(i,k,j) + endif + q2(i,zz)=qc3d(i,k,j) + q3(i,zz)=qi3d(i,k,j) + omg(i,zz)=dot(i,k) + ghtl(i,zz)=zl(i,k) + prsl(i,zz) = pcps(i,k,j) + enddo + enddo + + do k=kts,kte+1 + zz = kte+2-k + do i=its,ite + ghti(i,zz) = zi(i,k) + prsi(i,zz) = p8w(i,k,j) + enddo + enddo +! + do i=its,ite + evap(i) = qfx(i,j) + heatflux(i)= hfx(i,j) + enddo +! +!######################################################################## + call tiecnvn(u1,v1,t1,q1,q2,q3,q1b,t1b,ghtl,ghti,omg,prsl,prsi,evap,heatflux, & + rn,slimsk,im,kx,kx1,delt,dx) + + do i=its,ite + raincv(i,j)=rn(i)/stepcu + pratec(i,j)=rn(i)/(stepcu * dt) + enddo + + do k=kts,kte + zz = kte+1-k + do i=its,ite + rthcuten(i,k,j)=(t1(i,zz)-t3d(i,k,j))/pi3d(i,k,j)*rdelt + rqvcuten(i,k,j)=(q1(i,zz)-qv3d(i,k,j))*rdelt + rucuten(i,k,j) =(u1(i,zz)-u3d(i,k,j))*rdelt + rvcuten(i,k,j) =(v1(i,zz)-v3d(i,k,j))*rdelt + enddo + enddo + + if(present(rqccuten))then + if ( f_qc ) then + do k=kts,kte + zz = kte+1-k + do i=its,ite + rqccuten(i,k,j)=(q2(i,zz)-qc3d(i,k,j))*rdelt + enddo + enddo + endif + endif + + if(present(rqicuten))then + if ( f_qi ) then + do k=kts,kte + zz = kte+1-k + do i=its,ite + rqicuten(i,k,j)=(q3(i,zz)-qi3d(i,k,j))*rdelt + enddo + enddo + endif + endif + + + enddo + + end subroutine cu_ntiedtke + +!==================================================================== + subroutine ntiedtkeinit(rthcuten,rqvcuten,rqccuten,rqicuten, & + rucuten,rvcuten,rthften,rqvften, & + restart,p_qc,p_qi,p_first_scalar, & + allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte) +!-------------------------------------------------------------------- + implicit none +!-------------------------------------------------------------------- + logical , intent(in) :: allowed_to_read,restart + integer , intent(in) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + integer , intent(in) :: p_first_scalar, p_qi, p_qc + + real, dimension( ims:ime , kms:kme , jms:jme ) , intent(out) :: & + rthcuten, & + rqvcuten, & + rqccuten, & + rqicuten, & + rucuten,rvcuten,& + rthften,rqvften + + integer :: i, j, k, itf, jtf, ktf + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + + if(.not.restart)then + do j=jts,jtf + do k=kts,ktf + do i=its,itf + rthcuten(i,k,j)=0. + rqvcuten(i,k,j)=0. + rucuten(i,k,j)=0. + rvcuten(i,k,j)=0. + enddo + enddo + enddo + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + rthften(i,k,j)=0. + rqvften(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + if (p_qc .ge. p_first_scalar) then + do j=jts,jtf + do k=kts,ktf + do i=its,itf + rqccuten(i,k,j)=0. + enddo + enddo + enddo + endif + + if (p_qi .ge. p_first_scalar) then + do j=jts,jtf + do k=kts,ktf + do i=its,itf + rqicuten(i,k,j)=0. + enddo + enddo + enddo + endif + endif + + end subroutine ntiedtkeinit + +!----------------------------------------------------------------- +! level 1 subroutine 'tiecnvn' +!----------------------------------------------------------------- + subroutine tiecnvn(pu,pv,pt,pqv,pqc,pqi,pqvf,ptf,poz,pzz,pomg, & + & pap,paph,evap,hfx,zprecc,lndj,lq,km,km1,dt,dx) +!----------------------------------------------------------------- +! this is the interface between the model and the mass +! flux convection module +!----------------------------------------------------------------- + implicit none +! + real pu(lq,km), pv(lq,km), pt(lq,km), pqv(lq,km) + real poz(lq,km), pomg(lq,km), evap(lq), zprecc(lq) + real pzz(lq,km1) + + real pum1(lq,km), pvm1(lq,km), ztt(lq,km), & + & ptte(lq,km), pqte(lq,km), pvom(lq,km), pvol(lq,km), & + & pverv(lq,km), pgeo(lq,km), pap(lq,km), paph(lq,km1) + real pqhfl(lq), zqq(lq,km), & + & prsfc(lq), pssfc(lq), pcte(lq,km), & + & phhfl(lq), hfx(lq), pgeoh(lq,km1) + real ztp1(lq,km), zqp1(lq,km), ztu(lq,km), zqu(lq,km), & + & zlu(lq,km), zlude(lq,km), zmfu(lq,km), zmfd(lq,km), & + & zqsat(lq,km), pqc(lq,km), pqi(lq,km), zrain(lq) + real pqvf(lq,km), ptf(lq,km) + + integer icbot(lq), ictop(lq), ktype(lq), lndj(lq) + logical locum(lq) +! + real ztmst,fliq,fice,ztc,zalf,tt + integer i,j,k,lq,km,km1 + real dt,dx,ztpp1 + real zew,zqs,zcor +! + ztmst=dt +! +! masv flux diagnostics. +! + do j=1,lq + zrain(j)=0.0 + locum(j)=.false. + prsfc(j)=0.0 + pssfc(j)=0.0 + pqhfl(j)=evap(j) + phhfl(j)=hfx(j) + pgeoh(j,km1)=g*pzz(j,km1) + end do +! +! convert model variables for mflux scheme +! + do k=1,km + do j=1,lq + pcte(j,k)=0.0 + pvom(j,k)=0.0 + pvol(j,k)=0.0 + ztp1(j,k)=pt(j,k) + zqp1(j,k)=pqv(j,k)/(1.0+pqv(j,k)) + pum1(j,k)=pu(j,k) + pvm1(j,k)=pv(j,k) + pverv(j,k)=pomg(j,k) + pgeo(j,k)=g*poz(j,k) + pgeoh(j,k)=g*pzz(j,k) + tt=ztp1(j,k) + zew = foeewm(tt) + zqs = zew/pap(j,k) + zqs = min(0.5,zqs) + zcor = 1./(1.-vtmpc1*zqs) + zqsat(j,k)=zqs*zcor + pqte(j,k)=pqvf(j,k) + zqq(j,k) =pqte(j,k) + ptte(j,k)=ptf(j,k) + ztt(j,k) =ptte(j,k) + end do + end do +! +!----------------------------------------------------------------------- +!* 2. call 'cumastrn'(master-routine for cumulus parameterization) +! + call cumastrn & + & (lq, km, km1, km-1, ztp1, & + & zqp1, pum1, pvm1, pverv, zqsat,& + & pqhfl, ztmst, pap, paph, pgeo, & + & ptte, pqte, pvom, pvol, prsfc,& + & pssfc, locum, & + & ktype, icbot, ictop, ztu, zqu, & + & zlu, zlude, zmfu, zmfd, zrain,& + & pcte, phhfl, lndj, pgeoh, dx) +! +! to include the cloud water and cloud ice detrained from convection +! + do k=1,km + do j=1,lq + if(pcte(j,k).gt.0.) then + fliq=foealfa(ztp1(j,k)) + fice=1.0-fliq + pqc(j,k)=pqc(j,k)+fliq*pcte(j,k)*ztmst + pqi(j,k)=pqi(j,k)+fice*pcte(j,k)*ztmst + endif + end do + end do +! + do k=1,km + do j=1,lq + pt(j,k)= ztp1(j,k)+(ptte(j,k)-ztt(j,k))*ztmst + zqp1(j,k)=zqp1(j,k)+(pqte(j,k)-zqq(j,k))*ztmst + pqv(j,k)=zqp1(j,k)/(1.0-zqp1(j,k)) + end do + end do + + do j=1,lq + zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst) + end do + + if (lmfdudv) then + do k=1,km + do j=1,lq + pu(j,k)=pu(j,k)+pvom(j,k)*ztmst + pv(j,k)=pv(j,k)+pvol(j,k)*ztmst + end do + end do + endif +! + return + end subroutine tiecnvn + +!############################################################# +! +! level 2 subroutines +! +!############################################################# +!*********************************************************** +! subroutine cumastrn +!*********************************************************** + subroutine cumastrn & + & (klon, klev, klevp1, klevm1, pten, & + & pqen, puen, pven, pverv, pqsen,& + & pqhfl, ztmst, pap, paph, pgeo, & + & ptte, pqte, pvom, pvol, prsfc,& + & pssfc, ldcum, & + & ktype, kcbot, kctop, ptu, pqu,& + & plu, plude, pmfu, pmfd, prain,& + & pcte, phhfl, lndj, zgeoh, dx) + implicit none +! +!***cumastrn* master routine for cumulus massflux-scheme +! m.tiedtke e.c.m.w.f. 1986/1987/1989 +! modifications +! y.wang i.p.r.c 2001 +! c.zhang 2012 +!***purpose +! ------- +! this routine computes the physical tendencies of the +! prognostic variables t,q,u and v due to convective processes. +! processes considered are: convective fluxes, formation of +! precipitation, evaporation of falling rain below cloud base, +! saturated cumulus downdrafts. +!***method +! ------ +! parameterization is done using a massflux-scheme. +! (1) define constants and parameters +! (2) specify values (t,q,qs...) at half levels and +! initialize updraft- and downdraft-values in 'cuinin' +! (3) calculate cloud base in 'cutypen', calculate cloud types in cutypen, +! and specify cloud base massflux +! (4) do cloud ascent in 'cuascn' in absence of downdrafts +! (5) do downdraft calculations: +! (a) determine values at lfs in 'cudlfsn' +! (b) determine moist descent in 'cuddrafn' +! (c) recalculate cloud base massflux considering the +! effect of cu-downdrafts +! (6) do final adjusments to convective fluxes in 'cuflxn', +! do evaporation in subcloud layer +! (7) calculate increments of t and q in 'cudtdqn' +! (8) calculate increments of u and v in 'cududvn' +!***externals. +! ---------- +! cuinin: initializes values at vertical grid used in cu-parametr. +! cutypen: cloud bypes, 1: deep cumulus 2: shallow cumulus +! cuascn: cloud ascent for entraining plume +! cudlfsn: determines values at lfs for downdrafts +! cuddrafn:does moist descent for cumulus downdrafts +! cuflxn: final adjustments to convective fluxes (also in pbl) +! cudqdtn: updates tendencies for t and q +! cududvn: updates tendencies for u and v +!***switches. +! -------- +! lmfmid=.t. midlevel convection is switched on +! lmfdd=.t. cumulus downdrafts switched on +! lmfdudv=.t. cumulus friction switched on +!*** +! model parameters (defined in subroutine cuparam) +! ------------------------------------------------ +! entrdd entrainment rate for cumulus downdrafts +! cmfcmax maximum massflux value allowed for +! cmfcmin minimum massflux value (for safety) +! cmfdeps fractional massflux for downdrafts at lfs +! cprcon coefficient for conversion from cloud water to rain +!***reference. +! ---------- +! paper on massflux scheme (tiedtke,1989) +!----------------------------------------------------------------- + integer klev,klon,klevp1,klevm1 + real pten(klon,klev), pqen(klon,klev),& + & puen(klon,klev), pven(klon,klev),& + & ptte(klon,klev), pqte(klon,klev),& + & pvom(klon,klev), pvol(klon,klev),& + & pqsen(klon,klev), pgeo(klon,klev),& + & pap(klon,klev), paph(klon,klevp1),& + & pverv(klon,klev), pqhfl(klon),& + & phhfl(klon) + real ptu(klon,klev), pqu(klon,klev),& + & plu(klon,klev), plude(klon,klev),& + & pmfu(klon,klev), pmfd(klon,klev),& + & prain(klon),& + & prsfc(klon), pssfc(klon) + real ztenh(klon,klev), zqenh(klon,klev),& + & zgeoh(klon,klevp1), zqsenh(klon,klev),& + & ztd(klon,klev), zqd(klon,klev),& + & zmfus(klon,klev), zmfds(klon,klev),& + & zmfuq(klon,klev), zmfdq(klon,klev),& + & zdmfup(klon,klev), zdmfdp(klon,klev),& + & zmful(klon,klev), zrfl(klon),& + & zuu(klon,klev), zvu(klon,klev),& + & zud(klon,klev), zvd(klon,klev),& + & zlglac(klon,klev) + real pmflxr(klon,klevp1), pmflxs(klon,klevp1) + real zhcbase(klon),& + & zmfub(klon), zmfub1(klon),& + & zdqpbl(klon), zdhpbl(klon) + real zsfl(klon), zdpmel(klon,klev),& + & pcte(klon,klev), zcape(klon),& + & zcape1(klon), zcape2(klon),& + & ztauc(klon), ztaubl(klon),& + & zheat(klon) + real wup(klon), zdqcv(klon) + real wbase(klon), zmfuub(klon) + real upbl(klon) + real dx + real pmfude_rate(klon,klev), pmfdde_rate(klon,klev) + real zmfuus(klon,klev), zmfdus(klon,klev) + real zuv2(klon,klev),ztenu(klon,klev),ztenv(klon,klev) + real zmfuvb(klon),zsum12(klon),zsum22(klon) + integer ilab(klon,klev), idtop(klon),& + & ictop0(klon), ilwmin(klon) + integer kdpl(klon) + integer kcbot(klon), kctop(klon),& + & ktype(klon), lndj(klon) + logical ldcum(klon) + logical loddraf(klon), llo1, llo2(klon) + +! local varaiables + real zcons,zcons2,zqumqe,zdqmin,zdh,zmfmax + real zalfaw,zalv,zqalv,zc5ldcp,zc4les,zhsat,zgam,zzz,zhhat + real zpbmpt,zro,zdz,zdp,zeps,zfac,wspeed + integer jl,jk,ik + integer ikb,ikt,icum,itopm2 + real ztmst,ztau,zerate,zderate,zmfa + real zmfs(klon),pmean(klev),zlon + real zduten,zdvten,ztdis,pgf_u,pgf_v +!------------------------------------------- +! 1. specify constants and parameters +!------------------------------------------- + zcons=1./(g*ztmst) + zcons2=3./(g*ztmst) + + zlon = real(klon) + do jk = klev , 1 , -1 + pmean(jk) = sum(pap(:,jk))/zlon + end do + p950 = klev-2 + p650 = klev-2 + do jk = klev , 3 , -1 + if ( pmean(jk)/pmean(klev)*1.013250e5 > 950.e2 ) p950 = jk + if ( pmean(jk)/pmean(klev)*1.013250e5 > 650.e2 ) p650 = jk + end do + p950 = min(klev-2,p950) +!-------------------------------------------------------------- +!* 2. initialize values at vertical grid points in 'cuini' +!-------------------------------------------------------------- + call cuinin & + & (klon, klev, klevp1, klevm1, pten, & + & pqen, pqsen, puen, pven, pverv,& + & pgeo, paph, zgeoh, ztenh, zqenh,& + & zqsenh, ilwmin, ptu, pqu, ztd, & + & zqd, zuu, zvu, zud, zvd, & + & pmfu, pmfd, zmfus, zmfds, zmfuq,& + & zmfdq, zdmfup, zdmfdp, zdpmel, plu, & + & plude, ilab) + +!---------------------------------- +!* 3.0 cloud base calculations +!---------------------------------- +!* (a) determine cloud base values in 'cutypen', +! and the cumulus type 1 or 2 +! ------------------------------------------- + call cutypen & + & ( klon, klev, klevp1, klevm1, pqen,& + & ztenh, zqenh, zqsenh, zgeoh, paph,& + & phhfl, pqhfl, pgeo, pqsen, pap,& + & pten, lndj, ptu, pqu, ilab,& + & ldcum, kcbot, ictop0, ktype, wbase, plu, kdpl) + +!* (b) assign the first guess mass flux at cloud base +! ------------------------------------------ + do jl=1,klon + zdhpbl(jl)=0.0 + upbl(jl) = 0.0 + idtop(jl)=0 + end do + + do jk=2,klev + do jl=1,klon + if(jk.ge.kcbot(jl) .and. ldcum(jl)) then + zdhpbl(jl)=zdhpbl(jl)+(alv*pqte(jl,jk)+cpd*ptte(jl,jk))& + & *(paph(jl,jk+1)-paph(jl,jk)) + wspeed = sqrt(puen(jl,jk)**2 + pven(jl,jk)**2) + upbl(jl) = upbl(jl) + wspeed*(paph(jl,jk+1)-paph(jl,jk)) + end if + end do + end do + + do jl=1,klon + if(ldcum(jl)) then + ikb=kcbot(jl) + zmfmax = (paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + if(ktype(jl) == 1) then + zmfub(jl)= 0.1*zmfmax + else if ( ktype(jl) == 2 ) then + zqumqe = pqu(jl,ikb) + plu(jl,ikb) - zqenh(jl,ikb) + zdqmin = max(0.01*zqenh(jl,ikb),1.e-10) + zdh = cpd*(ptu(jl,ikb)-ztenh(jl,ikb)) + alv*zqumqe + zdh = g*max(zdh,1.e5*zdqmin) + if ( zdhpbl(jl) > 0. ) then + zmfub(jl) = zdhpbl(jl)/zdh + zmfub(jl) = min(zmfub(jl),zmfmax) + else + zmfub(jl) = 0.1*zmfmax + ldcum(jl) = .false. + end if + end if + else + zmfub(jl) = 0. + end if + end do +!------------------------------------------------------ +!* 4.0 determine cloud ascent for entraining plume +!------------------------------------------------------ +!* (a) do ascent in 'cuasc'in absence of downdrafts +!---------------------------------------------------------- + call cuascn & + & (klon, klev, klevp1, klevm1, ztenh,& + & zqenh, puen, pven, pten, pqen,& + & pqsen, pgeo, zgeoh, pap, paph,& + & pqte, pverv, ilwmin, ldcum, zhcbase,& + & ktype, ilab, ptu, pqu, plu,& + & zuu, zvu, pmfu, zmfub,& + & zmfus, zmfuq, zmful, plude, zdmfup,& + & kcbot, kctop, ictop0, icum, ztmst,& + & zqsenh, zlglac, lndj, wup, wbase, kdpl, pmfude_rate ) + +!* (b) check cloud depth and change entrainment rate accordingly +! calculate precipitation rate (for downdraft calculation) +!------------------------------------------------------------------ + do jl=1,klon + if ( ldcum(jl) ) then + ikb = kcbot(jl) + itopm2 = kctop(jl) + zpbmpt = paph(jl,ikb) - paph(jl,itopm2) + if ( ktype(jl) == 1 .and. zpbmpt < zdnoprc ) ktype(jl) = 2 + if ( ktype(jl) == 2 .and. zpbmpt >= zdnoprc ) ktype(jl) = 1 + ictop0(jl) = kctop(jl) + end if + zrfl(jl)=zdmfup(jl,1) + end do + + do jk=2,klev + do jl=1,klon + zrfl(jl)=zrfl(jl)+zdmfup(jl,jk) + end do + end do + + do jk = 1,klev + do jl = 1,klon + pmfd(jl,jk) = 0. + zmfds(jl,jk) = 0. + zmfdq(jl,jk) = 0. + zdmfdp(jl,jk) = 0. + zdpmel(jl,jk) = 0. + end do + end do + +!----------------------------------------- +!* 6.0 cumulus downdraft calculations +!----------------------------------------- + if(lmfdd) then +!* (a) determine lfs in 'cudlfsn' +!-------------------------------------- + call cudlfsn & + & (klon, klev,& + & kcbot, kctop, lndj, ldcum, & + & ztenh, zqenh, puen, pven, & + & pten, pqsen, pgeo, & + & zgeoh, paph, ptu, pqu, plu, & + & zuu, zvu, zmfub, zrfl, & + & ztd, zqd, zud, zvd, & + & pmfd, zmfds, zmfdq, zdmfdp, & + & idtop, loddraf) +!* (b) determine downdraft t,q and fluxes in 'cuddrafn' +!------------------------------------------------------------ + call cuddrafn & + & ( klon, klev, loddraf, & + & ztenh, zqenh, puen, pven, & + & pgeo, zgeoh, paph, zrfl, & + & ztd, zqd, zud, zvd, pmfu, & + & pmfd, zmfds, zmfdq, zdmfdp, pmfdde_rate ) +!----------------------------------------------------------- + end if +! +!----------------------------------------------------------------------- +!* 6.0 closure and clean work +! ------ +!-- 6.1 recalculate cloud base massflux from a cape closure +! for deep convection (ktype=1) +! + do jl=1,klon + if(ldcum(jl) .and. ktype(jl) .eq. 1) then + ikb = kcbot(jl) + ikt = kctop(jl) + zheat(jl)=0.0 + zcape(jl)=0.0 + zcape1(jl)=0.0 + zcape2(jl)=0.0 + zmfub1(jl)=zmfub(jl) + + upbl(jl) = max(2.,upbl(jl)/(paph(jl,klev+1)-paph(jl,ikb))) + ztauc(jl) = (zgeoh(jl,ikt)-zgeoh(jl,ikb)) / & + ((2.+ min(15.0,wup(jl)))*g) + if(lndj(jl) .eq. 1) then + ztaubl(jl) = ztauc(jl) + else + ztaubl(jl) = (zgeoh(jl,ikb)-zgeoh(jl,klev+1))*zrg/upbl(jl) + end if + end if + end do +! + do jk = 1 , klev + do jl = 1 , klon + llo1 = ldcum(jl) .and. ktype(jl) .eq. 1 + if ( llo1 .and. jk <= kcbot(jl) .and. jk > kctop(jl) ) then + ikb = kcbot(jl) + zdz = pgeo(jl,jk-1)-pgeo(jl,jk) + zdp = pap(jl,jk)-pap(jl,jk-1) + zheat(jl) = zheat(jl) + ((pten(jl,jk-1)-pten(jl,jk)+zdz*rcpd) / & + ztenh(jl,jk)+vtmpc1*(pqen(jl,jk-1)-pqen(jl,jk))) * & + (g*(pmfu(jl,jk)+pmfd(jl,jk))) + zcape1(jl) = zcape1(jl) + ((ptu(jl,jk)-ztenh(jl,jk))/ztenh(jl,jk) + & + vtmpc1*(pqu(jl,jk)-zqenh(jl,jk))-plu(jl,jk))*zdp + end if + + if ( llo1 .and. jk >= kcbot(jl) ) then + ikb = kcbot(jl) + if(paph(jl,klev+1)-paph(jl,ikb) <= 50.e2) then + zdp = paph(jl,jk+1)-paph(jl,jk) + zcape2(jl) = zcape2(jl) + ztaubl(jl)* & + (ptte(jl,jk)+vtmpc1*pten(jl,jk)*pqte(jl,jk))*zdp + end if + end if + end do + end do + + do jl=1,klon + if(ldcum(jl).and.ktype(jl).eq.1) then + ikb = kcbot(jl) + ikt = kctop(jl) + ztau = ztauc(jl) * (1.+1.33e-5*dx) + ztau = max(ztmst,ztau) + ztau = max(720.,ztau) + ztau = min(10800.,ztau) + zcape2(jl)= max(0.,zcape2(jl)) + zcape(jl) = max(0.,min(zcape1(jl)-zcape2(jl),5000.)) + zheat(jl) = max(1.e-4,zheat(jl)) + zmfub1(jl) = (zcape(jl)*zmfub(jl))/(zheat(jl)*ztau) + zmfub1(jl) = max(zmfub1(jl),0.001) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + zmfub1(jl)=min(zmfub1(jl),zmfmax) + end if + end do +! +!* 6.2 recalculate convective fluxes due to effect of +! downdrafts on boundary layer moist static energy budget (ktype=2) +!-------------------------------------------------------- + do jl=1,klon + if(ldcum(jl) .and. ktype(jl) .eq. 2) then + ikb=kcbot(jl) + if(pmfd(jl,ikb).lt.0.0 .and. loddraf(jl)) then + zeps=-pmfd(jl,ikb)/max(zmfub(jl),cmfcmin) + else + zeps=0. + endif + zqumqe=pqu(jl,ikb)+plu(jl,ikb)- & + & zeps*zqd(jl,ikb)-(1.-zeps)*zqenh(jl,ikb) + zdqmin=max(0.01*zqenh(jl,ikb),cmfcmin) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 +! using moist static engergy closure instead of moisture closure + zdh=cpd*(ptu(jl,ikb)-zeps*ztd(jl,ikb)- & + & (1.-zeps)*ztenh(jl,ikb))+alv*zqumqe + zdh=g*max(zdh,1.e5*zdqmin) + if(zdhpbl(jl).gt.0.)then + zmfub1(jl)=zdhpbl(jl)/zdh + else + zmfub1(jl) = zmfub(jl) + end if + zmfub1(jl) = min(zmfub1(jl),zmfmax) + end if + +!* 6.3 mid-level convection - nothing special +!--------------------------------------------------------- + if(ldcum(jl) .and. ktype(jl) .eq. 3 ) then + zmfub1(jl) = zmfub(jl) + end if + + end do + +!* 6.4 scaling the downdraft mass flux +!--------------------------------------------------------- + do jk=1,klev + do jl=1,klon + if( ldcum(jl) ) then + zfac=zmfub1(jl)/max(zmfub(jl),cmfcmin) + pmfd(jl,jk)=pmfd(jl,jk)*zfac + zmfds(jl,jk)=zmfds(jl,jk)*zfac + zmfdq(jl,jk)=zmfdq(jl,jk)*zfac + zdmfdp(jl,jk)=zdmfdp(jl,jk)*zfac + pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zfac + end if + end do + end do + +!* 6.5 scaling the updraft mass flux +! -------------------------------------------------------- + do jl = 1,klon + if ( ldcum(jl) ) zmfs(jl) = zmfub1(jl)/max(cmfcmin,zmfub(jl)) + end do + do jk = 2 , klev + do jl = 1,klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + ikb = kcbot(jl) + if ( jk>ikb ) then + zdz = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) + pmfu(jl,jk) = pmfu(jl,ikb)*zdz + end if + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + if ( pmfu(jl,jk)*zmfs(jl) > zmfmax ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + do jk = 2 , klev + do jl = 1,klon + if ( ldcum(jl) .and. jk <= kcbot(jl) .and. jk >= kctop(jl)-1 ) then + pmfu(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfus(jl,jk) = zmfus(jl,jk)*zmfs(jl) + zmfuq(jl,jk) = zmfuq(jl,jk)*zmfs(jl) + zmful(jl,jk) = zmful(jl,jk)*zmfs(jl) + zdmfup(jl,jk) = zdmfup(jl,jk)*zmfs(jl) + plude(jl,jk) = plude(jl,jk)*zmfs(jl) + pmfude_rate(jl,jk) = pmfude_rate(jl,jk)*zmfs(jl) + end if + end do + end do + +!* 6.6 if ktype = 2, kcbot=kctop is not allowed +! --------------------------------------------------- + do jl = 1,klon + if ( ktype(jl) == 2 .and. & + kcbot(jl) == kctop(jl) .and. kcbot(jl) >= klev-1 ) then + ldcum(jl) = .false. + ktype(jl) = 0 + end if + end do + +!* 6.7 set downdraft mass fluxes to zero above cloud top +!---------------------------------------------------- + do jl = 1,klon + if ( loddraf(jl) .and. idtop(jl) <= kctop(jl) ) then + idtop(jl) = kctop(jl) + 1 + end if + end do + do jk = 2 , klev + do jl = 1,klon + if ( loddraf(jl) ) then + if ( jk < idtop(jl) ) then + pmfd(jl,jk) = 0. + zmfds(jl,jk) = 0. + zmfdq(jl,jk) = 0. + pmfdde_rate(jl,jk) = 0. + zdmfdp(jl,jk) = 0. + else if ( jk == idtop(jl) ) then + pmfdde_rate(jl,jk) = 0. + end if + end if + end do + end do +!---------------------------------------------------------- +!* 7.0 determine final convective fluxes in 'cuflx' +!---------------------------------------------------------- + call cuflxn & + & ( klon, klev, ztmst & + & , pten, pqen, pqsen, ztenh, zqenh & + & , paph, pap, zgeoh, lndj, ldcum & + & , kcbot, kctop, idtop, itopm2 & + & , ktype, loddraf & + & , pmfu, pmfd, zmfus, zmfds & + & , zmfuq, zmfdq, zmful, plude & + & , zdmfup, zdmfdp, zdpmel, zlglac & + & , prain, pmfdde_rate, pmflxr, pmflxs ) + + do jl=1,klon + prsfc(jl) = pmflxr(jl,klev+1) + pssfc(jl) = pmflxs(jl,klev+1) + end do + +!---------------------------------------------------------------- +!* 8.0 update tendencies for t and q in subroutine cudtdq +!---------------------------------------------------------------- + call cudtdqn(klon,klev,itopm2,kctop,idtop,ldcum,loddraf, & + ztmst,paph,zgeoh,pgeo,pten,ztenh,pqen,zqenh,pqsen, & + zlglac,plude,pmfu,pmfd,zmfus,zmfds,zmfuq,zmfdq,zmful, & + zdmfup,zdpmel,ptte,pqte,pcte) +!---------------------------------------------------------------- +!* 9.0 update tendencies for u and u in subroutine cududv +!---------------------------------------------------------------- + if(lmfdudv) then + do jk = klev-1 , 2 , -1 + ik = jk + 1 + do jl = 1,klon + if ( ldcum(jl) ) then + if ( jk == kcbot(jl) .and. ktype(jl) < 3 ) then + ikb = kdpl(jl) + zuu(jl,jk) = puen(jl,ikb-1) + zvu(jl,jk) = pven(jl,ikb-1) + else if ( jk == kcbot(jl) .and. ktype(jl) == 3 ) then + zuu(jl,jk) = puen(jl,jk-1) + zvu(jl,jk) = pven(jl,jk-1) + end if + if ( jk < kcbot(jl) .and. jk >= kctop(jl) ) then + if(momtrans .eq. 1)then + zfac = 0. + if ( ktype(jl) == 1 .or. ktype(jl) == 3 ) zfac = 2. + if ( ktype(jl) == 1 .and. jk <= kctop(jl)+2 ) zfac = 3. + zerate = pmfu(jl,jk) - pmfu(jl,ik) + & + (1.+zfac)*pmfude_rate(jl,jk) + zderate = (1.+zfac)*pmfude_rate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & + zerate*puen(jl,jk)-zderate*zuu(jl,ik))*zmfa + zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & + zerate*pven(jl,jk)-zderate*zvu(jl,ik))*zmfa + else + if(ktype(jl) == 1 .or. ktype(jl) == 3) then + pgf_u = -0.7*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+& + pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1))) + pgf_v = -0.7*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+& + pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1))) + else + pgf_u = 0. + pgf_v = 0. + end if + zerate = pmfu(jl,jk) - pmfu(jl,ik) + pmfude_rate(jl,jk) + zderate = pmfude_rate(jl,jk) + zmfa = 1./max(cmfcmin,pmfu(jl,jk)) + zuu(jl,jk) = (zuu(jl,ik)*pmfu(jl,ik) + & + zerate*puen(jl,jk)-zderate*zuu(jl,ik)+pgf_u)*zmfa + zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + & + zerate*pven(jl,jk)-zderate*zvu(jl,ik)+pgf_v)*zmfa + end if + end if + end if + end do + end do + + if(lmfdd) then + do jk = 3 , klev + ik = jk - 1 + do jl = 1,klon + if ( ldcum(jl) ) then + if ( jk == idtop(jl) ) then + zud(jl,jk) = 0.5*(zuu(jl,jk)+puen(jl,ik)) + zvd(jl,jk) = 0.5*(zvu(jl,jk)+pven(jl,ik)) + else if ( jk > idtop(jl) ) then + zerate = -pmfd(jl,jk) + pmfd(jl,ik) + pmfdde_rate(jl,jk) + zmfa = 1./min(-cmfcmin,pmfd(jl,jk)) + zud(jl,jk) = (zud(jl,ik)*pmfd(jl,ik) - & + zerate*puen(jl,ik)+pmfdde_rate(jl,jk)*zud(jl,ik))*zmfa + zvd(jl,jk) = (zvd(jl,ik)*pmfd(jl,ik) - & + zerate*pven(jl,ik)+pmfdde_rate(jl,jk)*zvd(jl,ik))*zmfa + end if + end if + end do + end do + end if +! -------------------------------------------------- +! rescale massfluxes for stability in Momentum +!------------------------------------------------------------------------ + zmfs(:) = 1. + do jk = 2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons + if ( pmfu(jl,jk) > zmfmax .and. jk >= kctop(jl) ) then + zmfs(jl) = min(zmfs(jl),zmfmax/pmfu(jl,jk)) + end if + end if + end do + end do + do jk = 1 , klev + do jl = 1, klon + zmfuus(jl,jk) = pmfu(jl,jk) + zmfdus(jl,jk) = pmfd(jl,jk) + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zmfuus(jl,jk) = pmfu(jl,jk)*zmfs(jl) + zmfdus(jl,jk) = pmfd(jl,jk)*zmfs(jl) + end if + end do + end do +!* 9.1 update u and v in subroutine cududvn +!------------------------------------------------------------------- + do jk = 1 , klev + do jl = 1, klon + ztenu(jl,jk) = pvom(jl,jk) + ztenv(jl,jk) = pvol(jl,jk) + end do + end do + + call cududvn(klon,klev,itopm2,ktype,kcbot,kctop, & + ldcum,ztmst,paph,puen,pven,zmfuus,zmfdus,zuu, & + zud,zvu,zvd,pvom,pvol) + +! calculate KE dissipation + do jl = 1, klon + zsum12(jl) = 0. + zsum22(jl) = 0. + end do + do jk = 1 , klev + do jl = 1, klon + zuv2(jl,jk) = 0. + if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then + zdz = (paph(jl,jk+1)-paph(jl,jk)) + zduten = pvom(jl,jk) - ztenu(jl,jk) + zdvten = pvol(jl,jk) - ztenv(jl,jk) + zuv2(jl,jk) = sqrt(zduten**2+zdvten**2) + zsum22(jl) = zsum22(jl) + zuv2(jl,jk)*zdz + zsum12(jl) = zsum12(jl) - & + (puen(jl,jk)*zduten+pven(jl,jk)*zdvten)*zdz + end if + end do + end do + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk>=kctop(jl)-1 ) then + ztdis = rcpd*zsum12(jl)*zuv2(jl,jk)/max(1.e-15,zsum22(jl)) + ptte(jl,jk) = ptte(jl,jk) + ztdis + end if + end do + end do + + end if + return + end subroutine cumastrn + +!********************************************** +! level 3 subroutine cuinin +!********************************************** +! + subroutine cuinin & + & (klon, klev, klevp1, klevm1, pten,& + & pqen, pqsen, puen, pven, pverv,& + & pgeo, paph, pgeoh, ptenh, pqenh,& + & pqsenh, klwmin, ptu, pqu, ptd,& + & pqd, puu, pvu, pud, pvd,& + & pmfu, pmfd, pmfus, pmfds, pmfuq,& + & pmfdq, pdmfup, pdmfdp, pdpmel, plu,& + & plude, klab) + implicit none +! m.tiedtke e.c.m.w.f. 12/89 +!***purpose +! ------- +! this routine interpolates large-scale fields of t,q etc. +! to half levels (i.e. grid for massflux scheme), +! and initializes values for updrafts and downdrafts +!***interface +! --------- +! this routine is called from *cumastr*. +!***method. +! -------- +! for extrapolation to half levels see tiedtke(1989) +!***externals +! --------- +! *cuadjtq* to specify qs at half levels +! ---------------------------------------------------------------- + integer klon,klev,klevp1,klevm1 + real pten(klon,klev), pqen(klon,klev),& + & puen(klon,klev), pven(klon,klev),& + & pqsen(klon,klev), pverv(klon,klev),& + & pgeo(klon,klev), pgeoh(klon,klevp1),& + & paph(klon,klevp1), ptenh(klon,klev),& + & pqenh(klon,klev), pqsenh(klon,klev) + real ptu(klon,klev), pqu(klon,klev),& + & ptd(klon,klev), pqd(klon,klev),& + & puu(klon,klev), pud(klon,klev),& + & pvu(klon,klev), pvd(klon,klev),& + & pmfu(klon,klev), pmfd(klon,klev),& + & pmfus(klon,klev), pmfds(klon,klev),& + & pmfuq(klon,klev), pmfdq(klon,klev),& + & pdmfup(klon,klev), pdmfdp(klon,klev),& + & plu(klon,klev), plude(klon,klev) + real zwmax(klon), zph(klon), & + & pdpmel(klon,klev) + integer klab(klon,klev), klwmin(klon) + logical loflag(klon) +! local variables + integer jl,jk + integer icall,ik + real zzs +!------------------------------------------------------------ +!* 1. specify large scale parameters at half levels +!* adjust temperature fields if staticly unstable +!* find level of maximum vertical velocity +! ----------------------------------------------------------- + do jk=2,klev + do jl=1,klon + ptenh(jl,jk)=(max(cpd*pten(jl,jk-1)+pgeo(jl,jk-1), & + & cpd*pten(jl,jk)+pgeo(jl,jk))-pgeoh(jl,jk))*rcpd + pqsenh(jl,jk)= pqsen(jl,jk-1) + zph(jl)=paph(jl,jk) + loflag(jl)=.true. + end do + ik=jk + icall=0 + call cuadjtqn(klon,klev,ik,zph,ptenh,pqsenh,loflag,icall) + do jl=1,klon + pqenh(jl,jk)=min(pqen(jl,jk-1),pqsen(jl,jk-1)) & + & +(pqsenh(jl,jk)-pqsen(jl,jk-1)) + pqenh(jl,jk)=max(pqenh(jl,jk),0.) + end do + end do + + do jl=1,klon + ptenh(jl,klev)=(cpd*pten(jl,klev)+pgeo(jl,klev)- & + & pgeoh(jl,klev))*rcpd + pqenh(jl,klev)=pqen(jl,klev) + ptenh(jl,1)=pten(jl,1) + pqenh(jl,1)=pqen(jl,1) + klwmin(jl)=klev + zwmax(jl)=0. + end do + + do jk=klevm1,2,-1 + do jl=1,klon + zzs=max(cpd*ptenh(jl,jk)+pgeoh(jl,jk), & + & cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1)) + ptenh(jl,jk)=(zzs-pgeoh(jl,jk))*rcpd + end do + end do + + do jk=klev,3,-1 + do jl=1,klon + if(pverv(jl,jk).lt.zwmax(jl)) then + zwmax(jl)=pverv(jl,jk) + klwmin(jl)=jk + end if + end do + end do +!----------------------------------------------------------- +!* 2.0 initialize values for updrafts and downdrafts +!----------------------------------------------------------- + do jk=1,klev + ik=jk-1 + if(jk.eq.1) ik=1 + do jl=1,klon + ptu(jl,jk)=ptenh(jl,jk) + ptd(jl,jk)=ptenh(jl,jk) + pqu(jl,jk)=pqenh(jl,jk) + pqd(jl,jk)=pqenh(jl,jk) + plu(jl,jk)=0. + puu(jl,jk)=puen(jl,ik) + pud(jl,jk)=puen(jl,ik) + pvu(jl,jk)=pven(jl,ik) + pvd(jl,jk)=pven(jl,ik) + klab(jl,jk)=0 + end do + end do + return + end subroutine cuinin + +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cutypen & + & ( klon, klev, klevp1, klevm1, pqen,& + & ptenh, pqenh, pqsenh, pgeoh, paph,& + & hfx, qfx, pgeo, pqsen, pap,& + & pten, lndj, cutu, cuqu, culab,& + & ldcum, cubot, cutop, ktype, wbase, culu, kdpl ) +! zhang & wang iprc 2011-2013 +!***purpose. +! -------- +! to produce first guess updraught for cu-parameterizations +! calculates condensation level, and sets updraught base variables and +! first guess cloud type +!***interface +! --------- +! this routine is called from *cumastr*. +! input are environm. values of t,q,p,phi at half levels. +! it returns cloud types as follows; +! ktype=1 for deep cumulus +! ktype=2 for shallow cumulus +!***method. +! -------- +! based on a simplified updraught equation +! partial(hup)/partial(z)=eta(h - hup) +! eta is the entrainment rate for test parcel +! h stands for dry static energy or the total water specific humidity +! references: christian jakob, 2003: a new subcloud model for +! mass-flux convection schemes +! influence on triggering, updraft properties, and model +! climate, mon.wea.rev. +! 131, 2765-2778 +! and +! ifs documentation - cy36r1,cy38r1 +!***input variables: +! ptenh [ztenh] - environment temperature on half levels. (cuini) +! pqenh [zqenh] - env. specific humidity on half levels. (cuini) +! pgeoh [zgeoh] - geopotential on half levels, (mssflx) +! paph - pressure of half levels. (mssflx) +! rho - density of the lowest model level +! qfx - net upward moisture flux at the surface (kg/m^2/s) +! hfx - net upward heat flux at the surface (w/m^2) +!***variables output by cutype: +! ktype - convection type - 1: penetrative (cumastr) +! 2: stratocumulus (cumastr) +! 3: mid-level (cuasc) +! information for updraft parcel (ptu,pqu,plu,kcbot,klab,kdpl...) +! ---------------------------------------------------------------- +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- + integer klon, klev, klevp1, klevm1 + real ptenh(klon,klev), pqenh(klon,klev),& + & pqsen(klon,klev), pqsenh(klon,klev),& + & pgeoh(klon,klevp1), paph(klon,klevp1),& + & pap(klon,klev), pqen(klon,klev) + real pten(klon,klev) + real ptu(klon,klev),pqu(klon,klev),plu(klon,klev) + real pgeo(klon,klev) + integer klab(klon,klev) + integer kctop(klon),kcbot(klon) + + real qfx(klon),hfx(klon) + real zph(klon) + integer lndj(klon) + logical loflag(klon), deepflag(klon), resetflag(klon) + +! output variables + real cutu(klon,klev), cuqu(klon,klev), culu(klon,klev) + integer culab(klon,klev) + real wbase(klon) + integer ktype(klon),cubot(klon),cutop(klon),kdpl(klon) + logical ldcum(klon) + +! local variables + real zqold(klon) + real rho, part1, part2, root, conw, deltt, deltq + real eta(klon),dz(klon),coef(klon) + real dhen(klon,klev), dh(klon,klev) + real plude(klon,klev) + real kup(klon,klev) + real vptu(klon,klev),vten(klon,klev) + real zbuo(klon,klev),abuoy(klon,klev) + + real zz,zdken,zdq + real fscale,crirh1,pp + real atop1,atop2,abot + real tmix,zmix,qmix,pmix + real zlglac,dp,t13 + integer nk,is,ikb,ikt + + real zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp + real zpdifftop, zpdiffbot + integer zcbase(klon) + integer jl,jk,ik,icall,levels + logical needreset, lldcum(klon) +!-------------------------------------------------------------- + t13 = 1.0/3.0 +! + do jl=1,klon + kcbot(jl)=klev + kctop(jl)=klev + kdpl(jl) =klev + ktype(jl)=0 + wbase(jl)=0. + ldcum(jl)=.false. + end do + + if(lmfscv) then +!----------------------------------------------------------- +! let's do test,and check the shallow convection first +! the first level is klev +! define deltat and deltaq +!----------------------------------------------------------- + do jk=1,klev + do jl=1,klon + plu(jl,jk)=culu(jl,jk) ! parcel liquid water + ptu(jl,jk)=cutu(jl,jk) ! parcel temperature + pqu(jl,jk)=cuqu(jl,jk) ! parcel specific humidity + klab(jl,jk)=culab(jl,jk) + dh(jl,jk)=0.0 ! parcel dry static energy + dhen(jl,jk)=0.0 ! environment dry static energy + kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + vptu(jl,jk)=0.0 ! parcel virtual temperature considering water-loading + vten(jl,jk)=0.0 ! environment virtual temperature + zbuo(jl,jk)=0.0 ! parcel buoyancy + abuoy(jl,jk)=0.0 + end do + end do + + do jl=1,klon + zqold(jl) = 0. + lldcum(jl) = .false. + loflag(jl) = .true. + end do + +! check the levels from lowest level to second top level + do jk=klevm1,2,-1 + +! define the variables at the first level + if(jk .eq. klevm1) then + do jl=1,klon + rho=paph(jl,klev+1)/ & + & (rd*(pten(jl,klev)*(1.+vtmpc1*pqen(jl,klev)))) + part1 = 1.5*0.4*(pgeoh(jl,klev)-pgeoh(jl,klev+1))/ & + & (rho*pten(jl,klev)) + part2 = -hfx(jl)*rcpd-vtmpc1*pten(jl,klev)*qfx(jl) + root = 0.001-part1*part2 + if(part2 .lt. 0.) then + conw = 1.2*(root)**t13 + deltt = max(1.5*hfx(jl)/(rho*cpd*conw),0.) + deltq = max(1.5*qfx(jl)/(rho*conw),0.) + kup(jl,klev) = 0.5*(conw**2) + pqu(jl,klev)= pqenh(jl,klev) + deltq + dhen(jl,klev)= pgeoh(jl,klev) + ptenh(jl,klev)*cpd + dh(jl,klev) = dhen(jl,klev) + deltt*cpd + ptu(jl,klev) = (dh(jl,klev)-pgeoh(jl,klev))*rcpd + vptu(jl,klev)=ptu(jl,klev)*(1.+vtmpc1*pqu(jl,klev)) + vten(jl,klev)=ptenh(jl,klev)*(1.+vtmpc1*pqenh(jl,klev)) + zbuo(jl,klev)=(vptu(jl,klev)-vten(jl,klev))/vten(jl,klev) + klab(jl,klev) = 1 + else + loflag(jl) = .false. + end if + end do + end if + + is=0 + do jl=1,klon + if(loflag(jl))then + is=is+1 + endif + enddo + if(is.eq.0) exit + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(loflag(jl)) then + eta(jl) = 0.55/((pgeoh(jl,jk)-pgeoh(jl,klev+1))*zrg)+1.0e-4 + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= 0.5*eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& + & +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl)) + pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& + & +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl)) + ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd + zqold(jl) = pqu(jl,jk) + zph(jl)=paph(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + do jl=1,klon + if( loflag(jl) ) then + zdq = max((zqold(jl) - pqu(jl,jk)),0.) + plu(jl,jk) = plu(jl,jk+1) + zdq + zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & + (1.-foealfa(ptu(jl,jk+1)))) + plu(jl,jk) = min(plu(jl,jk),5.e-3) + dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) +! compute the updraft speed + vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& + ralfdcp*zlglac + vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) + abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g + atop1 = 1.0 - 2.*coef(jl) + atop2 = 2.0*dz(jl)*abuoy(jl,jk) + abot = 1.0 + 2.*coef(jl) + kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot + +! let's find the exact cloud base + if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then + ik = jk + 1 + zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) + zqsu = min(0.5,zqsu) + zcor = 1./(1.-vtmpc1*zqsu) + zqsu = zqsu*zcor + zdq = min(0.,pqu(jl,ik)-zqsu) + zalfaw = foealfa(ptu(jl,ik)) + zfacw = c5les/((ptu(jl,ik)-c4les)**2) + zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) + zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci + zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) + zcor = 1./(1.-vtmpc1*zesdp) + zdqsdt = zfac*zcor*zqsu + zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) + zdp = zdq/(zdqsdt*zdtdp) + zcbase(jl) = paph(jl,ik) + zdp +! chose nearest half level as cloud base (jk or jk+1) + zpdifftop = zcbase(jl) - paph(jl,jk) + zpdiffbot = paph(jl,jk+1) - zcbase(jl) + if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then + ikb = min(klev-1,jk+1) + klab(jl,ikb) = 2 + klab(jl,jk) = 2 + kcbot(jl) = ikb + plu(jl,jk+1) = 1.0e-8 + else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then + klab(jl,jk) = 2 + kcbot(jl) = jk + end if + end if + + if(kup(jl,jk) .lt. 0.)then + loflag(jl) = .false. + if(plu(jl,jk+1) .gt. 0.) then + kctop(jl) = jk + lldcum(jl) = .true. + else + lldcum(jl) = .false. + end if + else if(plu(jl,jk) .gt. 0.)then + klab(jl,jk)=2 + else + klab(jl,jk)=1 + end if + end if + end do + + end do ! end all the levels + + do jl=1,klon + ikb = kcbot(jl) + ikt = kctop(jl) + if(paph(jl,ikb) - paph(jl,ikt) > zdnoprc) lldcum(jl) = .false. + if(lldcum(jl)) then + ktype(jl) = 2 + ldcum(jl) = .true. + wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) + cubot(jl) = ikb + cutop(jl) = ikt + kdpl(jl) = klev + else + cutop(jl) = -1 + cubot(jl) = -1 + kdpl(jl) = klev - 1 + ldcum(jl) = .false. + wbase(jl) = 0. + end if + end do + + do jk=klev,1,-1 + do jl=1,klon + ikt = kctop(jl) + if(jk .ge. ikt)then + culab(jl,jk) = klab(jl,jk) + cutu(jl,jk) = ptu(jl,jk) + cuqu(jl,jk) = pqu(jl,jk) + culu(jl,jk) = plu(jl,jk) + end if + end do + end do + + end if ! if activate shallow convection + + if(lmfpen) then +!----------------------------------------------------------- +! next, let's check the deep convection +! the first level is klevm1-1 +! define deltat and deltaq +!---------------------------------------------------------- +! we check the parcel starting level by level +! assume the mix-layer is 60hPa + deltt = 0.2 + deltq = 1.0e-4 + do jl=1,klon + deepflag(jl) = .false. + end do + + do levels=klevm1-1,p650,-1 ! loop starts + do jk=1,klev + do jl=1,klon + plu(jl,jk)=0.0 ! parcel liquid water + ptu(jl,jk)=0.0 ! parcel temperature + pqu(jl,jk)=0.0 ! parcel specific humidity + dh(jl,jk)=0.0 ! parcel dry static energy + dhen(jl,jk)=0.0 ! environment dry static energy + kup(jl,jk)=0.0 ! updraught kinetic energy for parcel + vptu(jl,jk)=0.0 ! parcel virtual temperature consideringwater-loading + vten(jl,jk)=0.0 ! environment virtual temperature + abuoy(jl,jk)=0.0 + zbuo(jl,jk)=0.0 + klab(jl,jk)=0 + end do + end do + + do jl=1,klon + kcbot(jl) = levels + kctop(jl) = levels + zqold(jl) = 0. + lldcum(jl) = .false. + resetflag(jl)= .false. + loflag(jl) = .not. deepflag(jl) + end do + +! start the inner loop to search the deep convection points + do jk=levels,2,-1 + is=0 + do jl=1,klon + if(loflag(jl))then + is=is+1 + endif + enddo + if(is.eq.0) exit + +! define the variables at the departure level + if(jk .eq. levels) then + do jl=1,klon + if(loflag(jl)) then + if((paph(jl,klev+1)-paph(jl,jk)) < 60.e2) then + tmix=0. + qmix=0. + zmix=0. + pmix=0. + do nk=jk+2,jk,-1 + if(pmix < 50.e2) then + dp = paph(jl,nk) - paph(jl,nk-1) + tmix=tmix+dp*ptenh(jl,nk) + qmix=qmix+dp*pqenh(jl,nk) + zmix=zmix+dp*pgeoh(jl,nk) + pmix=pmix+dp + end if + end do + tmix=tmix/pmix + qmix=qmix/pmix + zmix=zmix/pmix + else + tmix=ptenh(jl,jk+1) + qmix=pqenh(jl,jk+1) + zmix=pgeoh(jl,jk+1) + end if + + pqu(jl,jk+1) = qmix + deltq + dhen(jl,jk+1)= zmix + tmix*cpd + dh(jl,jk+1) = dhen(jl,jk+1) + deltt*cpd + ptu(jl,jk+1) = (dh(jl,jk+1)-pgeoh(jl,jk+1))*rcpd + kup(jl,jk+1) = 0.5 + klab(jl,jk+1)= 1 + vptu(jl,jk+1)=ptu(jl,jk+1)*(1.+vtmpc1*pqu(jl,jk+1)) + vten(jl,jk+1)=ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1)) + zbuo(jl,jk+1)=(vptu(jl,jk+1)-vten(jl,jk+1))/vten(jl,jk+1) + end if + end do + end if + +! the next levels, we use the variables at the first level as initial values + do jl=1,klon + if(loflag(jl)) then +! define the fscale + fscale = min(1.,(pqsen(jl,jk)/pqsen(jl,klev))**3) + eta(jl) = 0.8*1.75e-3*fscale + dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + coef(jl)= 0.5*eta(jl)*dz(jl) + dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) + dh(jl,jk) = 0.5*coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))& + & +(1.-coef(jl))*dh(jl,jk+1) + pqu(jl,jk) =0.5*coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))& + & +(1.-coef(jl))*pqu(jl,jk+1) + ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd + zqold(jl) = pqu(jl,jk) + zph(jl)=paph(jl,jk) + end if + end do +! check if the parcel is saturated + ik=jk + icall=1 + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + + do jl=1,klon + if( loflag(jl) ) then + zdq = max((zqold(jl) - pqu(jl,jk)),0.) + plu(jl,jk) = plu(jl,jk+1) + zdq + zlglac=zdq*((1.-foealfa(ptu(jl,jk))) - & + (1.-foealfa(ptu(jl,jk+1)))) + plu(jl,jk) = 0.5*plu(jl,jk) + dh(jl,jk) = pgeoh(jl,jk) + cpd*(ptu(jl,jk)+ralfdcp*zlglac) +! compute the updraft speed + vptu(jl,jk) = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))+& + ralfdcp*zlglac + vten(jl,jk) = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = (vptu(jl,jk) - vten(jl,jk))/vten(jl,jk) + abuoy(jl,jk)=(zbuo(jl,jk)+zbuo(jl,jk+1))*0.5*g + atop1 = 1.0 - 2.*coef(jl) + atop2 = 2.0*dz(jl)*abuoy(jl,jk) + abot = 1.0 + 2.*coef(jl) + kup(jl,jk) = (atop1*kup(jl,jk+1) + atop2) / abot +! let's find the exact cloud base + if ( plu(jl,jk) > 0. .and. klab(jl,jk+1) == 1 ) then + ik = jk + 1 + zqsu = foeewm(ptu(jl,ik))/paph(jl,ik) + zqsu = min(0.5,zqsu) + zcor = 1./(1.-vtmpc1*zqsu) + zqsu = zqsu*zcor + zdq = min(0.,pqu(jl,ik)-zqsu) + zalfaw = foealfa(ptu(jl,ik)) + zfacw = c5les/((ptu(jl,ik)-c4les)**2) + zfaci = c5ies/((ptu(jl,ik)-c4ies)**2) + zfac = zalfaw*zfacw + (1.-zalfaw)*zfaci + zesdp = foeewm(ptu(jl,ik))/paph(jl,ik) + zcor = 1./(1.-vtmpc1*zesdp) + zdqsdt = zfac*zcor*zqsu + zdtdp = rd*ptu(jl,ik)/(cpd*paph(jl,ik)) + zdp = zdq/(zdqsdt*zdtdp) + zcbase(jl) = paph(jl,ik) + zdp +! chose nearest half level as cloud base (jk or jk+1) + zpdifftop = zcbase(jl) - paph(jl,jk) + zpdiffbot = paph(jl,jk+1) - zcbase(jl) + if ( zpdifftop > zpdiffbot .and. kup(jl,jk+1) > 0. ) then + ikb = min(klev-1,jk+1) + klab(jl,ikb) = 2 + klab(jl,jk) = 2 + kcbot(jl) = ikb + plu(jl,jk+1) = 1.0e-8 + else if ( zpdifftop <= zpdiffbot .and.kup(jl,jk) > 0. ) then + klab(jl,jk) = 2 + kcbot(jl) = jk + end if + end if + + if(kup(jl,jk) .lt. 0.)then + loflag(jl) = .false. + if(plu(jl,jk+1) .gt. 0.) then + kctop(jl) = jk + lldcum(jl) = .true. + else + lldcum(jl) = .false. + end if + else if(plu(jl,jk) .gt. 0.)then + klab(jl,jk)=2 + else + klab(jl,jk)=1 + end if + end if + end do + + end do ! end all the levels + + needreset = .false. + do jl=1,klon + ikb = kcbot(jl) + ikt = kctop(jl) + if(paph(jl,ikb) - paph(jl,ikt) < zdnoprc) lldcum(jl) = .false. + if(lldcum(jl)) then + ktype(jl) = 1 + ldcum(jl) = .true. + deepflag(jl) = .true. + wbase(jl) = sqrt(max(2.*kup(jl,ikb),0.)) + cubot(jl) = ikb + cutop(jl) = ikt + kdpl(jl) = levels+1 + needreset = .true. + resetflag(jl)= .true. + end if + end do + + if(needreset) then + do jk=klev,1,-1 + do jl=1,klon + if(resetflag(jl)) then + ikt = kctop(jl) + ikb = kdpl(jl) + if(jk .le. ikb .and. jk .ge. ikt )then + culab(jl,jk) = klab(jl,jk) + cutu(jl,jk) = ptu(jl,jk) + cuqu(jl,jk) = pqu(jl,jk) + culu(jl,jk) = plu(jl,jk) + else + culab(jl,jk) = 1 + cutu(jl,jk) = ptenh(jl,jk) + cuqu(jl,jk) = pqenh(jl,jk) + culu(jl,jk) = 0. + end if + if ( jk .lt. ikt ) culab(jl,jk) = 0 + end if + end do + end do + end if + + end do ! end all cycles + + end if ! end actiavating deep convection + return + end subroutine cutypen + +!----------------------------------------------------------------- +! level 3 subroutines 'cuascn' +!----------------------------------------------------------------- + subroutine cuascn & + & (klon, klev, klevp1, klevm1, ptenh,& + & pqenh, puen, pven, pten, pqen,& + & pqsen, pgeo, pgeoh, pap, paph,& + & pqte, pverv, klwmin, ldcum, phcbase,& + & ktype, klab, ptu, pqu, plu,& + & puu, pvu, pmfu, pmfub, & + & pmfus, pmfuq, pmful, plude, pdmfup,& + & kcbot, kctop, kctop0, kcum, ztmst,& + & pqsenh, plglac, lndj, wup, wbase, kdpl, pmfude_rate) + implicit none +! this routine does the calculations for cloud ascents +! for cumulus parameterization +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 +! y.wang iprc 11/01 modif. +! c.zhang iprc 05/12 modif. +!***purpose. +! -------- +! to produce cloud ascents for cu-parametrization +! (vertical profiles of t,q,l,u and v and corresponding +! fluxes as well as precipitation rates) +!***interface +! --------- +! this routine is called from *cumastr*. +!***method. +! -------- +! lift surface air dry-adiabatically to cloud base +! and then calculate moist ascent for +! entraining/detraining plume. +! entrainment and detrainment rates differ for +! shallow and deep cumulus convection. +! in case there is no penetrative or shallow convection +! check for possibility of mid level convection +! (cloud base values calculated in *cubasmc*) +!***externals +! --------- +! *cuadjtqn* adjust t and q due to condensation in ascent +! *cuentrn* calculate entrainment/detrainment rates +! *cubasmcn* calculate cloud base values for midlevel convection +!***reference +! --------- +! (tiedtke,1989) +!***input variables: +! ptenh [ztenh] - environ temperature on half levels. (cuini) +! pqenh [zqenh] - env. specific humidity on half levels. (cuini) +! puen - environment wind u-component. (mssflx) +! pven - environment wind v-component. (mssflx) +! pten - environment temperature. (mssflx) +! pqen - environment specific humidity. (mssflx) +! pqsen - environment saturation specific humidity. (mssflx) +! pgeo - geopotential. (mssflx) +! pgeoh [zgeoh] - geopotential on half levels, (mssflx) +! pap - pressure in pa. (mssflx) +! paph - pressure of half levels. (mssflx) +! pqte - moisture convergence (delta q/delta t). (mssflx) +! pverv - large scale vertical velocity (omega). (mssflx) +! klwmin [ilwmin] - level of minimum omega. (cuini) +! klab [ilab] - level label - 1: sub-cloud layer. +! 2: condensation level (cloud base) +! pmfub [zmfub] - updraft mass flux at cloud base. (cumastr) +!***variables modified by cuasc: +! ldcum - logical denoting profiles. (cubase) +! ktype - convection type - 1: penetrative (cumastr) +! 2: stratocumulus (cumastr) +! 3: mid-level (cuasc) +! ptu - cloud temperature. +! pqu - cloud specific humidity. +! plu - cloud liquid water (moisture condensed out) +! puu [zuu] - cloud momentum u-component. +! pvu [zvu] - cloud momentum v-component. +! pmfu - updraft mass flux. +! pmfus [zmfus] - updraft flux of dry static energy. (cubasmc) +! pmfuq [zmfuq] - updraft flux of specific humidity. +! pmful [zmful] - updraft flux of cloud liquid water. +! plude - liquid water returned to environment by detrainment. +! pdmfup [zmfup] - +! kcbot - cloud base level. (cubase) +! kctop - cloud top level +! kctop0 [ictop0] - estimate of cloud top. (cumastr) +! kcum [icum] - flag to control the call + + integer klev,klon,klevp1,klevm1 + real ptenh(klon,klev), pqenh(klon,klev), & + & puen(klon,klev), pven(klon,klev),& + & pten(klon,klev), pqen(klon,klev),& + & pgeo(klon,klev), pgeoh(klon,klevp1),& + & pap(klon,klev), paph(klon,klevp1),& + & pqsen(klon,klev), pqte(klon,klev),& + & pverv(klon,klev), pqsenh(klon,klev) + real ptu(klon,klev), pqu(klon,klev),& + & puu(klon,klev), pvu(klon,klev),& + & pmfu(klon,klev), zph(klon),& + & pmfub(klon), & + & pmfus(klon,klev), pmfuq(klon,klev),& + & plu(klon,klev), plude(klon,klev),& + & pmful(klon,klev), pdmfup(klon,klev) + real zdmfen(klon), zdmfde(klon),& + & zmfuu(klon), zmfuv(klon),& + & zpbase(klon), zqold(klon) + real phcbase(klon), zluold(klon) + real zprecip(klon), zlrain(klon,klev) + real zbuo(klon,klev), kup(klon,klev) + real wup(klon) + real wbase(klon), zodetr(klon,klev) + real plglac(klon,klev) + + real eta(klon),dz(klon) + + integer klwmin(klon), ktype(klon),& + & klab(klon,klev), kcbot(klon),& + & kctop(klon), kctop0(klon) + integer lndj(klon) + logical ldcum(klon), loflag(klon) + logical llo2,llo3, llo1(klon) + + integer kdpl(klon) + real zoentr(klon), zdpmean(klon) + real pdmfen(klon,klev), pmfude_rate(klon,klev) +! local variables + integer jl,jk + integer ikb,icum,itopm2,ik,icall,is,kcum,jlm,jll + integer jlx(klon) + real ztmst,zcons2,zfacbuo,zprcdgw,z_cwdrag,z_cldmax,z_cwifrac,z_cprc2 + real zmftest,zmfmax,zqeen,zseen,zscde,zqude + real zmfusk,zmfuqk,zmfulk + real zbc,zbe,zkedke,zmfun,zwu,zprcon,zdt,zcbf,zzco + real zlcrit,zdfi,zc,zd,zint,zlnew,zvw,zvi,zalfaw,zrold + real zrnew,zz,zdmfeu,zdmfdu,dp + real zfac,zbuoc,zdkbuo,zdken,zvv,zarg,zchange,zxe,zxs,zdshrd + real atop1,atop2,abot +!-------------------------------- +!* 1. specify parameters +!-------------------------------- + zcons2=3./(g*ztmst) + zfacbuo = 0.5/(1.+0.5) + zprcdgw = cprcon*zrg + z_cldmax = 5.e-3 + z_cwifrac = 0.5 + z_cprc2 = 0.5 + z_cwdrag = (3.0/8.0)*0.506/0.2 +!--------------------------------- +! 2. set default values +!--------------------------------- + llo3 = .false. + do jl=1,klon + zluold(jl)=0. + wup(jl)=0. + zdpmean(jl)=0. + zoentr(jl)=0. + if(.not.ldcum(jl)) then + ktype(jl)=0 + kcbot(jl) = -1 + pmfub(jl) = 0. + pqu(jl,klev) = 0. + end if + end do + + ! initialize variout quantities + do jk=1,klev + do jl=1,klon + if(jk.ne.kcbot(jl)) plu(jl,jk)=0. + pmfu(jl,jk)=0. + pmfus(jl,jk)=0. + pmfuq(jl,jk)=0. + pmful(jl,jk)=0. + plude(jl,jk)=0. + plglac(jl,jk)=0. + pdmfup(jl,jk)=0. + zlrain(jl,jk)=0. + zbuo(jl,jk)=0. + kup(jl,jk)=0. + pdmfen(jl,jk) = 0. + pmfude_rate(jl,jk) = 0. + if(.not.ldcum(jl).or.ktype(jl).eq.3) klab(jl,jk)=0 + if(.not.ldcum(jl).and.paph(jl,jk).lt.4.e4) kctop0(jl)=jk + end do + end do + + do jl = 1,klon + if ( ktype(jl) == 3 ) ldcum(jl) = .false. + end do +!------------------------------------------------ +! 3.0 initialize values at cloud base level +!------------------------------------------------ + do jl=1,klon + kctop(jl)=kcbot(jl) + if(ldcum(jl)) then + ikb = kcbot(jl) + kup(jl,ikb) = 0.5*wbase(jl)**2 + pmfu(jl,ikb) = pmfub(jl) + pmfus(jl,ikb) = pmfub(jl)*(cpd*ptu(jl,ikb)+pgeoh(jl,ikb)) + pmfuq(jl,ikb) = pmfub(jl)*pqu(jl,ikb) + pmful(jl,ikb) = pmfub(jl)*plu(jl,ikb) + end if + end do +! +!----------------------------------------------------------------- +! 4. do ascent: subcloud layer (klab=1) ,clouds (klab=2) +! by doing first dry-adiabatic ascent and then +! by adjusting t,q and l accordingly in *cuadjtqn*, +! then check for buoyancy and set flags accordingly +!----------------------------------------------------------------- +! + do jk=klevm1,3,-1 +! specify cloud base values for midlevel convection +! in *cubasmc* in case there is not already convection +! --------------------------------------------------------------------- + ik=jk + call cubasmcn& + & (klon, klev, klevm1, ik, pten,& + & pqen, pqsen, puen, pven, pverv,& + & pgeo, pgeoh, ldcum, ktype, klab, zlrain,& + & pmfu, pmfub, kcbot, ptu,& + & pqu, plu, puu, pvu, pmfus,& + & pmfuq, pmful, pdmfup) + is = 0 + jlm = 0 + do jl = 1,klon + loflag(jl) = .false. + zprecip(jl) = 0. + llo1(jl) = .false. + is = is + klab(jl,jk+1) + if ( klab(jl,jk+1) == 0 ) klab(jl,jk) = 0 + if ( (ldcum(jl) .and. klab(jl,jk+1) == 2) .or. & + (ktype(jl) == 3 .and. klab(jl,jk+1) == 1) ) then + loflag(jl) = .true. + jlm = jlm + 1 + jlx(jlm) = jl + end if + zph(jl) = paph(jl,jk) + if ( ktype(jl) == 3 .and. jk == kcbot(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + if ( pmfub(jl) > zmfmax ) then + zfac = zmfmax/pmfub(jl) + pmfu(jl,jk+1) = pmfu(jl,jk+1)*zfac + pmfus(jl,jk+1) = pmfus(jl,jk+1)*zfac + pmfuq(jl,jk+1) = pmfuq(jl,jk+1)*zfac + pmfub(jl) = zmfmax + end if + pmfub(jl)=min(pmfub(jl),zmfmax) + end if + end do + + if(is.gt.0) llo3 = .true. +! +!* specify entrainment rates in *cuentr* +! ------------------------------------- + ik=jk + call cuentrn(klon,klev,ik,kcbot,ldcum,llo3, & + pgeoh,pmfu,zdmfen,zdmfde) +! +! do adiabatic ascent for entraining/detraining plume + if(llo3) then +! ------------------------------------------------------- +! + do jl = 1,klon + zqold(jl) = 0. + end do + do jll = 1 , jlm + jl = jlx(jll) + zdmfde(jl) = min(zdmfde(jl),0.75*pmfu(jl,jk+1)) + if ( jk == kcbot(jl) ) then + zoentr(jl) = -1.75e-3*(min(1.,pqen(jl,jk)/pqsen(jl,jk)) - & + 1.)*(pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg + zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk+1) + end if + if ( jk < kcbot(jl) ) then + zmfmax = (paph(jl,jk)-paph(jl,jk-1))*zcons2 + zxs = max(pmfu(jl,jk+1)-zmfmax,0.) + wup(jl) = wup(jl) + kup(jl,jk+1)*(pap(jl,jk+1)-pap(jl,jk)) + zdpmean(jl) = zdpmean(jl) + pap(jl,jk+1) - pap(jl,jk) + zdmfen(jl) = zoentr(jl) + if ( ktype(jl) >= 2 ) then + zdmfen(jl) = 2.0*zdmfen(jl) + zdmfde(jl) = zdmfen(jl) + end if + zdmfde(jl) = zdmfde(jl) * & + (1.6-min(1.,pqen(jl,jk)/pqsen(jl,jk))) + zmftest = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + zchange = max(zmftest-zmfmax,0.) + zxe = max(zchange-zxs,0.) + zdmfen(jl) = zdmfen(jl) - zxe + zchange = zchange - zxe + zdmfde(jl) = zdmfde(jl) + zchange + end if + pdmfen(jl,jk) = zdmfen(jl) - zdmfde(jl) + pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + zqeen = pqenh(jl,jk+1)*zdmfen(jl) + zseen = (cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*zdmfen(jl) + zscde = (cpd*ptu(jl,jk+1)+pgeoh(jl,jk+1))*zdmfde(jl) + zqude = pqu(jl,jk+1)*zdmfde(jl) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + zmfusk = pmfus(jl,jk+1) + zseen - zscde + zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude + zmfulk = pmful(jl,jk+1) - plude(jl,jk) + plu(jl,jk) = zmfulk*(1./max(cmfcmin,pmfu(jl,jk))) + pqu(jl,jk) = zmfuqk*(1./max(cmfcmin,pmfu(jl,jk))) + ptu(jl,jk) = (zmfusk * & + (1./max(cmfcmin,pmfu(jl,jk)))-pgeoh(jl,jk))*rcpd + ptu(jl,jk) = max(100.,ptu(jl,jk)) + ptu(jl,jk) = min(400.,ptu(jl,jk)) + zqold(jl) = pqu(jl,jk) + zlrain(jl,jk) = zlrain(jl,jk+1)*(pmfu(jl,jk+1)-zdmfde(jl)) * & + (1./max(cmfcmin,pmfu(jl,jk))) + zluold(jl) = plu(jl,jk) + end do +! reset to environmental values if below departure level + do jl = 1,klon + if ( jk > kdpl(jl) ) then + ptu(jl,jk) = ptenh(jl,jk) + pqu(jl,jk) = pqenh(jl,jk) + plu(jl,jk) = 0. + zluold(jl) = plu(jl,jk) + end if + end do +!* do corrections for moist ascent +!* by adjusting t,q and l in *cuadjtq* +!------------------------------------------------ + ik=jk + icall=1 +! + if ( jlm > 0 ) then + call cuadjtqn(klon,klev,ik,zph,ptu,pqu,loflag,icall) + end if +! compute the upfraft speed in cloud layer + do jll = 1 , jlm + jl = jlx(jll) + if ( pqu(jl,jk) /= zqold(jl) ) then + plglac(jl,jk) = plu(jl,jk) * & + ((1.-foealfa(ptu(jl,jk)))- & + (1.-foealfa(ptu(jl,jk+1)))) + ptu(jl,jk) = ptu(jl,jk) + ralfdcp*plglac(jl,jk) + end if + end do + do jll = 1 , jlm + jl = jlx(jll) + if ( pqu(jl,jk) /= zqold(jl) ) then + klab(jl,jk) = 2 + plu(jl,jk) = plu(jl,jk) + zqold(jl) - pqu(jl,jk) + zbc = ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk+1) - & + zlrain(jl,jk+1)) + zbe = ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zbuo(jl,jk) = zbc - zbe +! set flags for the case of midlevel convection + if ( ktype(jl) == 3 .and. klab(jl,jk+1) == 1 ) then + if ( zbuo(jl,jk) > -0.5 ) then + ldcum(jl) = .true. + kctop(jl) = jk + kup(jl,jk) = 0.5 + else + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + plude(jl,jk) = 0. + plu(jl,jk) = 0. + end if + end if + if ( klab(jl,jk+1) == 2 ) then + if ( zbuo(jl,jk) < 0. .and. klab(jl,jk+1) == 2 ) then + ptenh(jl,jk) = 0.5*(pten(jl,jk)+pten(jl,jk-1)) + pqenh(jl,jk) = 0.5*(pqen(jl,jk)+pqen(jl,jk-1)) + zbuo(jl,jk) = zbc - ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + end if + zbuoc = (zbuo(jl,jk) / & + (ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)))+zbuo(jl,jk+1) / & + (ptenh(jl,jk+1)*(1.+vtmpc1*pqenh(jl,jk+1))))*0.5 + zdkbuo = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zfacbuo*zbuoc +! mixing and "pressure" gradient term in upper troposphere + if ( zdmfen(jl) > 0. ) then + zdken = min(1.,(1.+z_cwdrag)*zdmfen(jl) / & + max(cmfcmin,pmfu(jl,jk+1))) + else + zdken = min(1.,(1.+z_cwdrag)*zdmfde(jl) / & + max(cmfcmin,pmfu(jl,jk+1))) + end if + kup(jl,jk) = (kup(jl,jk+1)*(1.-zdken)+zdkbuo) / & + (1.+zdken) + if ( zbuo(jl,jk) < 0. .and. klab(jl,jk+1) == 2 ) then + zkedke = kup(jl,jk)/max(1.e-10,kup(jl,jk+1)) + zkedke = max(0.,min(1.,zkedke)) + zmfun = sqrt(zkedke)*pmfu(jl,jk+1) + zdmfde(jl) = max(zdmfde(jl),pmfu(jl,jk+1)-zmfun) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) + end if + if ( zbuo(jl,jk) >-0.2 .and. klab(jl,jk+1) == 2 ) then + ikb = kcbot(jl) + zoentr(jl) = 1.75e-3*(0.3-(min(1.,pqen(jl,jk-1) / & + pqsen(jl,jk-1))-1.))*(pgeoh(jl,jk-1)-pgeoh(jl,jk)) * & + zrg*min(1.,pqsen(jl,jk)/pqsen(jl,ikb))**3 + zoentr(jl) = min(0.4,zoentr(jl))*pmfu(jl,jk) + else + zoentr(jl) = 0. + end if +! erase values if below departure level + if ( jk > kdpl(jl) ) then + pmfu(jl,jk) = pmfu(jl,jk+1) + kup(jl,jk) = 0.5 + end if + if ( kup(jl,jk) > 0. .and. pmfu(jl,jk) > 0. ) then + kctop(jl) = jk + llo1(jl) = .true. + else + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + kup(jl,jk) = 0. + zdmfde(jl) = pmfu(jl,jk+1) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + end if +! save detrainment rates for updraught + if ( pmfu(jl,jk+1) > 0. ) pmfude_rate(jl,jk) = zdmfde(jl) + end if + else if ( ktype(jl) == 2 .and. pqu(jl,jk) == zqold(jl) ) then + klab(jl,jk) = 0 + pmfu(jl,jk) = 0. + kup(jl,jk) = 0. + zdmfde(jl) = pmfu(jl,jk+1) + plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) + pmfude_rate(jl,jk) = zdmfde(jl) + end if + end do + + do jl = 1,klon + if ( llo1(jl) ) then +! conversions only proceeds if plu is greater than a threshold liquid water +! content of 0.3 g/kg over water and 0.5 g/kg over land to prevent precipitation +! generation from small water contents. + if ( lndj(jl).eq.1 ) then + zdshrd = 5.e-4 + else + zdshrd = 3.e-4 + end if + ikb=kcbot(jl) + if ( plu(jl,jk) > zdshrd .and.(paph(jl,ikb)-paph(jl,jk))>zdnoprc)then + zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk+1)))) + zprcon = zprcdgw/(0.75*zwu) +! PARAMETERS FOR BERGERON-FINDEISEN PROCESS (T < -5C) + zdt = min(rtber-rtice,max(rtber-ptu(jl,jk),0.)) + zcbf = 1. + z_cprc2*sqrt(zdt) + zzco = zprcon*zcbf + zlcrit = zdshrd/zcbf + zdfi = pgeoh(jl,jk) - pgeoh(jl,jk+1) + zc = (plu(jl,jk)-zluold(jl)) + zarg = (plu(jl,jk)/zlcrit)**2 + if ( zarg < 25.0 ) then + zd = zzco*(1.-exp(-zarg))*zdfi + else + zd = zzco*zdfi + end if + zint = exp(-zd) + zlnew = zluold(jl)*zint + zc/zd*(1.-zint) + zlnew = max(0.,min(plu(jl,jk),zlnew)) + zlnew = min(z_cldmax,zlnew) + zprecip(jl) = max(0.,zluold(jl)+zc-zlnew) + pdmfup(jl,jk) = zprecip(jl)*pmfu(jl,jk) + zlrain(jl,jk) = zlrain(jl,jk) + zprecip(jl) + plu(jl,jk) = zlnew + end if + end if + end do + do jl = 1, klon + if ( llo1(jl) ) then + if ( zlrain(jl,jk) > 0. ) then + zvw = 21.18*zlrain(jl,jk)**0.2 + zvi = z_cwifrac*zvw + zalfaw = foealfa(ptu(jl,jk)) + zvv = zalfaw*zvw + (1.-zalfaw)*zvi + zrold = zlrain(jl,jk) - zprecip(jl) + zc = zprecip(jl) + zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk)))) + zd = zvv/zwu + zint = exp(-zd) + zrnew = zrold*zint + zc/zd*(1.-zint) + zrnew = max(0.,min(zlrain(jl,jk),zrnew)) + zlrain(jl,jk) = zrnew + end if + end if + end do + do jll = 1 , jlm + jl = jlx(jll) + pmful(jl,jk) = plu(jl,jk)*pmfu(jl,jk) + pmfus(jl,jk) = (cpd*ptu(jl,jk)+pgeoh(jl,jk))*pmfu(jl,jk) + pmfuq(jl,jk) = pqu(jl,jk)*pmfu(jl,jk) + end do + end if + end do +!---------------------------------------------------------------------- +! 5. final calculations +! ------------------ + do jl = 1,klon + if ( kctop(jl) == -1 ) ldcum(jl) = .false. + kcbot(jl) = max(kcbot(jl),kctop(jl)) + if ( ldcum(jl) ) then + wup(jl) = max(1.e-2,wup(jl)/max(1.,zdpmean(jl))) + wup(jl) = sqrt(2.*wup(jl)) + end if + end do + + return + end subroutine cuascn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cudlfsn & + & (klon, klev, & + & kcbot, kctop, lndj, ldcum, & + & ptenh, pqenh, puen, pven, & + & pten, pqsen, pgeo, & + & pgeoh, paph, ptu, pqu, plu,& + & puu, pvu, pmfub, prfl, & + & ptd, pqd, pud, pvd, & + & pmfd, pmfds, pmfdq, pdmfdp, & + & kdtop, lddraf) + +! this routine calculates level of free sinking for +! cumulus downdrafts and specifies t,q,u and v values + +! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 + +! purpose. +! -------- +! to produce lfs-values for cumulus downdrafts +! for massflux cumulus parameterization + +! interface +! --------- +! this routine is called from *cumastr*. +! input are environmental values of t,q,u,v,p,phi +! and updraft values t,q,u and v and also +! cloud base massflux and cu-precipitation rate. +! it returns t,q,u and v values and massflux at lfs. + +! method. + +! check for negative buoyancy of air of equal parts of +! moist environmental air and cloud air. + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kcbot* cloud base level +! *kctop* cloud top level + +! input parameters (logical): + +! *lndj* land sea mask (1 for land) +! *ldcum* flag: .true. for convective points + +! input parameters (real): + +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *puen* provisional environment u-velocity (t+1) m/s +! *pven* provisional environment v-velocity (t+1) m/s +! *pten* provisional environment temperature (t+1) k +! *pqsen* environment spec. saturation humidity (t+1) kg/kg +! *pgeo* geopotential m2/s2 +! *pgeoh* geopotential on half levels m2/s2 +! *paph* provisional pressure on half levels pa +! *ptu* temperature in updrafts k +! *pqu* spec. humidity in updrafts kg/kg +! *plu* liquid water content in updrafts kg/kg +! *puu* u-velocity in updrafts m/s +! *pvu* v-velocity in updrafts m/s +! *pmfub* massflux in updrafts at cloud base kg/(m2*s) + +! updated parameters (real): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real): + +! *ptd* temperature in downdrafts k +! *pqd* spec. humidity in downdrafts kg/kg +! *pud* u-velocity in downdrafts m/s +! *pvd* v-velocity in downdrafts m/s +! *pmfd* massflux in downdrafts kg/(m2*s) +! *pmfds* flux of dry static energy in downdrafts j/(m2*s) +! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) +! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) + +! output parameters (integer): + +! *kdtop* top level of downdrafts + +! output parameters (logical): + +! *lddraf* .true. if downdrafts exist + +! externals +! --------- +! *cuadjtq* for calculating wet bulb t and q at lfs +!---------------------------------------------------------------------- + implicit none + + integer klev,klon + real ptenh(klon,klev), pqenh(klon,klev), & + & puen(klon,klev), pven(klon,klev), & + & pten(klon,klev), pqsen(klon,klev), & + & pgeo(klon,klev), & + & pgeoh(klon,klev+1), paph(klon,klev+1),& + & ptu(klon,klev), pqu(klon,klev), & + & puu(klon,klev), pvu(klon,klev), & + & plu(klon,klev), & + & pmfub(klon), prfl(klon) + + real ptd(klon,klev), pqd(klon,klev), & + & pud(klon,klev), pvd(klon,klev), & + & pmfd(klon,klev), pmfds(klon,klev), & + & pmfdq(klon,klev), pdmfdp(klon,klev) + integer kcbot(klon), kctop(klon), & + & kdtop(klon), ikhsmin(klon) + logical ldcum(klon), & + & lddraf(klon) + integer lndj(klon) + + real ztenwb(klon,klev), zqenwb(klon,klev), & + & zcond(klon), zph(klon), & + & zhsmin(klon) + logical llo2(klon) +! local variables + integer jl,jk + integer is,ik,icall,ike + real zhsk,zttest,zqtest,zbuo,zmftop + +!---------------------------------------------------------------------- + +! 1. set default values for downdrafts +! --------------------------------- + do jl=1,klon + lddraf(jl)=.false. + kdtop(jl)=klev+1 + ikhsmin(jl)=klev+1 + zhsmin(jl)=1.e8 + enddo +!---------------------------------------------------------------------- + +! 2. determine level of free sinking: +! downdrafts shall start at model level of minimum +! of saturation moist static energy or below +! respectively + +! for every point and proceed as follows: + +! (1) determine level of minimum of hs +! (2) determine wet bulb environmental t and q +! (3) do mixing with cumulus cloud air +! (4) check for negative buoyancy +! (5) if buoyancy>0 repeat (2) to (4) for next +! level below + +! the assumption is that air of downdrafts is mixture +! of 50% cloud air + 50% environmental air at wet bulb +! temperature (i.e. which became saturated due to +! evaporation of rain and cloud water) +! ---------------------------------------------------- + do jk=3,klev-2 + do jl=1,klon + zhsk=cpd*pten(jl,jk)+pgeo(jl,jk) + & + & foelhm(pten(jl,jk))*pqsen(jl,jk) + if(zhsk .lt. zhsmin(jl)) then + zhsmin(jl) = zhsk + ikhsmin(jl)= jk + end if + end do + end do + + + ike=klev-3 + do jk=3,ike + +! 2.1 calculate wet-bulb temperature and moisture +! for environmental air in *cuadjtq* +! ------------------------------------------- + is=0 + do jl=1,klon + ztenwb(jl,jk)=ptenh(jl,jk) + zqenwb(jl,jk)=pqenh(jl,jk) + zph(jl)=paph(jl,jk) + llo2(jl)=ldcum(jl).and.prfl(jl).gt.0..and..not.lddraf(jl).and. & + & (jk.lt.kcbot(jl).and.jk.gt.kctop(jl)).and. jk.ge.ikhsmin(jl) + if(llo2(jl))then + is=is+1 + endif + enddo + if(is.eq.0) cycle + + ik=jk + icall=2 + call cuadjtqn & + & ( klon, klev, ik, zph, ztenwb, zqenwb, llo2, icall) + +! 2.2 do mixing of cumulus and environmental air +! and check for negative buoyancy. +! then set values for downdraft at lfs. +! ---------------------------------------- + do jl=1,klon + if(llo2(jl)) then + zttest=0.5*(ptu(jl,jk)+ztenwb(jl,jk)) + zqtest=0.5*(pqu(jl,jk)+zqenwb(jl,jk)) + zbuo=zttest*(1.+vtmpc1 *zqtest)- & + & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) + zcond(jl)=pqenh(jl,jk)-zqenwb(jl,jk) + zmftop=-cmfdeps*pmfub(jl) + if(zbuo.lt.0..and.prfl(jl).gt.10.*zmftop*zcond(jl)) then + kdtop(jl)=jk + lddraf(jl)=.true. + ptd(jl,jk)=zttest + pqd(jl,jk)=zqtest + pmfd(jl,jk)=zmftop + pmfds(jl,jk)=pmfd(jl,jk)*(cpd*ptd(jl,jk)+pgeoh(jl,jk)) + pmfdq(jl,jk)=pmfd(jl,jk)*pqd(jl,jk) + pdmfdp(jl,jk-1)=-0.5*pmfd(jl,jk)*zcond(jl) + prfl(jl)=prfl(jl)+pdmfdp(jl,jk-1) + endif + endif + enddo + + enddo + + return + end subroutine cudlfsn + +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- +!********************************************** +! subroutine cuddrafn +!********************************************** + subroutine cuddrafn & + & ( klon, klev, lddraf & + & , ptenh, pqenh, puen, pven & + & , pgeo, pgeoh, paph, prfl & + & , ptd, pqd, pud, pvd, pmfu & + & , pmfd, pmfds, pmfdq, pdmfdp, pmfdde_rate ) + +! this routine calculates cumulus downdraft descent + +! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 + +! purpose. +! -------- +! to produce the vertical profiles for cumulus downdrafts +! (i.e. t,q,u and v and fluxes) + +! interface +! --------- + +! this routine is called from *cumastr*. +! input is t,q,p,phi,u,v at half levels. +! it returns fluxes of s,q and evaporation rate +! and u,v at levels where downdraft occurs + +! method. +! -------- +! calculate moist descent for entraining/detraining plume by +! a) moving air dry-adiabatically to next level below and +! b) correcting for evaporation to obtain saturated state. + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels + +! input parameters (logical): + +! *lddraf* .true. if downdrafts exist + +! input parameters (real): + +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *puen* provisional environment u-velocity (t+1) m/s +! *pven* provisional environment v-velocity (t+1) m/s +! *pgeo* geopotential m2/s2 +! *pgeoh* geopotential on half levels m2/s2 +! *paph* provisional pressure on half levels pa +! *pmfu* massflux updrafts kg/(m2*s) + +! updated parameters (real): + +! *prfl* precipitation rate kg/(m2*s) + +! output parameters (real): + +! *ptd* temperature in downdrafts k +! *pqd* spec. humidity in downdrafts kg/kg +! *pud* u-velocity in downdrafts m/s +! *pvd* v-velocity in downdrafts m/s +! *pmfd* massflux in downdrafts kg/(m2*s) +! *pmfds* flux of dry static energy in downdrafts j/(m2*s) +! *pmfdq* flux of spec. humidity in downdrafts kg/(m2*s) +! *pdmfdp* flux difference of precip. in downdrafts kg/(m2*s) + +! externals +! --------- +! *cuadjtq* for adjusting t and q due to evaporation in +! saturated descent +!---------------------------------------------------------------------- + implicit none + + integer klev,klon + real ptenh(klon,klev), pqenh(klon,klev), & + & puen(klon,klev), pven(klon,klev), & + & pgeoh(klon,klev+1), paph(klon,klev+1), & + & pgeo(klon,klev), pmfu(klon,klev) + + real ptd(klon,klev), pqd(klon,klev), & + & pud(klon,klev), pvd(klon,klev), & + & pmfd(klon,klev), pmfds(klon,klev), & + & pmfdq(klon,klev), pdmfdp(klon,klev), & + & prfl(klon) + real pmfdde_rate(klon,klev) + logical lddraf(klon) + + real zdmfen(klon), zdmfde(klon), & + & zcond(klon), zoentr(klon), & + & zbuoy(klon) + real zph(klon) + logical llo2(klon) + logical llo1 +! local variables + integer jl,jk + integer is,ik,icall,ike, itopde + real zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp + real zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk + + itopde=p950 +!---------------------------------------------------------------------- +! 1. calculate moist descent for cumulus downdraft by +! (a) calculating entrainment/detrainment rates, +! including organized entrainment dependent on +! negative buoyancy and assuming +! linear decrease of massflux in pbl +! (b) doing moist descent - evaporative cooling +! and moistening is calculated in *cuadjtq* +! (c) checking for negative buoyancy and +! specifying final t,q,u,v and downward fluxes +! ------------------------------------------------- + do jl=1,klon + zoentr(jl)=0. + zbuoy(jl)=0. + zdmfen(jl)=0. + zdmfde(jl)=0. + enddo + + do jk=1,klev + do jl=1,klon + pmfdde_rate(jl,jk) = 0. + end do + end do + + do jk=3,klev + is=0 + do jl=1,klon + zph(jl)=paph(jl,jk) + llo2(jl)=lddraf(jl).and.pmfd(jl,jk-1).lt.0. + if(llo2(jl)) then + is=is+1 + endif + enddo + if(is.eq.0) cycle + + do jl=1,klon + if(llo2(jl)) then + zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg + zdmfen(jl)=zentr + zdmfde(jl)=zentr + endif + enddo + + if(jk.gt.itopde) then + do jl=1,klon + if(llo2(jl)) then + zdmfen(jl)=0. + zdmfde(jl)=pmfd(jl,itopde)* & + & (paph(jl,jk)-paph(jl,jk-1))/ & + & (paph(jl,klev+1)-paph(jl,itopde)) + endif + enddo + endif + + if(jk.le.itopde) then + do jl=1,klon + if(llo2(jl)) then + zdz=-(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg + zzentr=zoentr(jl)*zdz*pmfd(jl,jk-1) + zdmfen(jl)=zdmfen(jl)+zzentr + zdmfen(jl)=max(zdmfen(jl),0.3*pmfd(jl,jk-1)) + zdmfen(jl)=max(zdmfen(jl),-0.75*pmfu(jl,jk)- & + & (pmfd(jl,jk-1)-zdmfde(jl))) + zdmfen(jl)=min(zdmfen(jl),0.) + endif + enddo + endif + + do jl=1,klon + if(llo2(jl)) then + pmfd(jl,jk)=pmfd(jl,jk-1)+zdmfen(jl)-zdmfde(jl) + zseen=(cpd*ptenh(jl,jk-1)+pgeoh(jl,jk-1))*zdmfen(jl) + zqeen=pqenh(jl,jk-1)*zdmfen(jl) + zsdde=(cpd*ptd(jl,jk-1)+pgeoh(jl,jk-1))*zdmfde(jl) + zqdde=pqd(jl,jk-1)*zdmfde(jl) + zmfdsk=pmfds(jl,jk-1)+zseen-zsdde + zmfdqk=pmfdq(jl,jk-1)+zqeen-zqdde + pqd(jl,jk)=zmfdqk*(1./min(-cmfcmin,pmfd(jl,jk))) + ptd(jl,jk)=(zmfdsk*(1./min(-cmfcmin,pmfd(jl,jk)))-& + & pgeoh(jl,jk))*rcpd + ptd(jl,jk)=min(400.,ptd(jl,jk)) + ptd(jl,jk)=max(100.,ptd(jl,jk)) + zcond(jl)=pqd(jl,jk) + endif + enddo + + ik=jk + icall=2 + call cuadjtqn(klon, klev, ik, zph, ptd, pqd, llo2, icall ) + + do jl=1,klon + if(llo2(jl)) then + zcond(jl)=zcond(jl)-pqd(jl,jk) + zbuo=ptd(jl,jk)*(1.+vtmpc1 *pqd(jl,jk))- & + & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) + if(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then + zrain=prfl(jl)/pmfu(jl,jk) + zbuo=zbuo-ptd(jl,jk)*zrain + endif + if(zbuo.ge.0 .or. prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then + pmfd(jl,jk)=0. + zbuo=0. + endif + pmfds(jl,jk)=(cpd*ptd(jl,jk)+pgeoh(jl,jk))*pmfd(jl,jk) + pmfdq(jl,jk)=pqd(jl,jk)*pmfd(jl,jk) + zdmfdp=-pmfd(jl,jk)*zcond(jl) + pdmfdp(jl,jk-1)=zdmfdp + prfl(jl)=prfl(jl)+zdmfdp + +! compute organized entrainment for use at next level + zbuoyz=zbuo/ptenh(jl,jk) + zbuoyz=min(zbuoyz,0.0) + zdz=-(pgeo(jl,jk-1)-pgeo(jl,jk)) + zbuoy(jl)=zbuoy(jl)+zbuoyz*zdz + zoentr(jl)=g*zbuoyz*0.5/(1.+zbuoy(jl)) + pmfdde_rate(jl,jk) = -zdmfde(jl) + endif + enddo + + enddo + + return + end subroutine cuddrafn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cuflxn & + & ( klon, klev, ztmst & + & , pten, pqen, pqsen, ptenh, pqenh & + & , paph, pap, pgeoh, lndj, ldcum & + & , kcbot, kctop, kdtop, ktopm2 & + & , ktype, lddraf & + & , pmfu, pmfd, pmfus, pmfds & + & , pmfuq, pmfdq, pmful, plude & + & , pdmfup, pdmfdp, pdpmel, plglac & + & , prain, pmfdde_rate, pmflxr, pmflxs ) + +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 + +! purpose +! ------- + +! this routine does the final calculation of convective +! fluxes in the cloud layer and in the subcloud layer + +! interface +! --------- +! this routine is called from *cumastr*. + + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kcbot* cloud base level +! *kctop* cloud top level +! *kdtop* top level of downdrafts + +! input parameters (logical): + +! *lndj* land sea mask (1 for land) +! *ldcum* flag: .true. for convective points + +! input parameters (real): + +! *ptsphy* time step for the physics s +! *pten* provisional environment temperature (t+1) k +! *pqen* provisional environment spec. humidity (t+1) kg/kg +! *pqsen* environment spec. saturation humidity (t+1) kg/kg +! *ptenh* env. temperature (t+1) on half levels k +! *pqenh* env. spec. humidity (t+1) on half levels kg/kg +! *paph* provisional pressure on half levels pa +! *pap* provisional pressure on full levels pa +! *pgeoh* geopotential on half levels m2/s2 + +! updated parameters (integer): + +! *ktype* set to zero if ldcum=.false. + +! updated parameters (logical): + +! *lddraf* set to .false. if ldcum=.false. or kdtop= kdtop(jl) + if ( llddraf ) then + pmfds(jl,jk) = pmfds(jl,jk)-pmfd(jl,jk) * & + (cpd*ptenh(jl,jk)+pgeoh(jl,jk)) + pmfdq(jl,jk) = pmfdq(jl,jk)-pmfd(jl,jk)*pqenh(jl,jk) + else + pmfd(jl,jk) = 0. + pmfds(jl,jk) = 0. + pmfdq(jl,jk) = 0. + pdmfdp(jl,jk-1) = 0. + end if + if ( llddraf .and. pmfd(jl,jk) < 0. .and. & + abs(pmfd(jl,ikb)) < 1.e-20 ) then + idbas(jl) = jk + end if + else + pmfu(jl,jk)=0. + pmfd(jl,jk)=0. + pmfus(jl,jk)=0. + pmfds(jl,jk)=0. + pmfuq(jl,jk)=0. + pmfdq(jl,jk)=0. + pmful(jl,jk)=0. + plglac(jl,jk)=0. + pdmfup(jl,jk-1)=0. + pdmfdp(jl,jk-1)=0. + plude(jl,jk-1)=0. + endif + enddo + enddo + + do jl=1,klon + pmflxr(jl,klev+1) = 0. + pmflxs(jl,klev+1) = 0. + end do + do jl=1,klon + if(ldcum(jl)) then + ikb=kcbot(jl) + ik=ikb+1 + zzp=((paph(jl,klev+1)-paph(jl,ik))/ & + & (paph(jl,klev+1)-paph(jl,ikb))) + if(ktype(jl).eq.3) then + zzp=zzp**2 + endif + pmfu(jl,ik)=pmfu(jl,ikb)*zzp + pmfus(jl,ik)=(pmfus(jl,ikb)- & + & foelhm(ptenh(jl,ikb))*pmful(jl,ikb))*zzp + pmfuq(jl,ik)=(pmfuq(jl,ikb)+pmful(jl,ikb))*zzp + pmful(jl,ik)=0. + endif + enddo + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.gt.kcbot(jl)+1) then + ikb=kcbot(jl)+1 + zzp=((paph(jl,klev+1)-paph(jl,jk))/ & + & (paph(jl,klev+1)-paph(jl,ikb))) + if(ktype(jl).eq.3) then + zzp=zzp**2 + endif + pmfu(jl,jk)=pmfu(jl,ikb)*zzp + pmfus(jl,jk)=pmfus(jl,ikb)*zzp + pmfuq(jl,jk)=pmfuq(jl,ikb)*zzp + pmful(jl,jk)=0. + endif + ik = idbas(jl) + llddraf = lddraf(jl) .and. jk > ik .and. ik < klev + if ( llddraf .and. ik == kcbot(jl)+1 ) then + zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ik))) + if ( ktype(jl) == 3 ) zzp = zzp*zzp + pmfd(jl,jk) = pmfd(jl,ik)*zzp + pmfds(jl,jk) = pmfds(jl,ik)*zzp + pmfdq(jl,jk) = pmfdq(jl,ik)*zzp + pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) + else if ( llddraf .and. ik /= kcbot(jl)+1 .and. jk == ik+1 ) then + pmfdde_rate(jl,jk) = -(pmfd(jl,jk-1)-pmfd(jl,jk)) + end if + enddo + enddo +!* 2. calculate rain/snow fall rates +!* calculate melting of snow +!* calculate evaporation of precip +! ------------------------------- + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl) .and. jk >=kctop(jl)-1 ) then + prain(jl)=prain(jl)+pdmfup(jl,jk) + if(pmflxs(jl,jk).gt.0..and.pten(jl,jk).gt.tmelt) then + zcons1=zcons1a*(1.+0.5*(pten(jl,jk)-tmelt)) + zfac=zcons1*(paph(jl,jk+1)-paph(jl,jk)) + zsnmlt=min(pmflxs(jl,jk),zfac*(pten(jl,jk)-tmelt)) + pdpmel(jl,jk)=zsnmlt + pqsen(jl,jk)=foeewm(pten(jl,jk)-zsnmlt/zfac)/pap(jl,jk) + endif + zalfaw=foealfa(pten(jl,jk)) + ! + ! No liquid precipitation above melting level + ! + if ( pten(jl,jk) < tmelt .and. zalfaw > 0. ) then + plglac(jl,jk) = plglac(jl,jk)+zalfaw*(pdmfup(jl,jk)+pdmfdp(jl,jk)) + zalfaw = 0. + end if + pmflxr(jl,jk+1)=pmflxr(jl,jk)+zalfaw* & + & (pdmfup(jl,jk)+pdmfdp(jl,jk))+pdpmel(jl,jk) + pmflxs(jl,jk+1)=pmflxs(jl,jk)+(1.-zalfaw)* & + & (pdmfup(jl,jk)+pdmfdp(jl,jk))-pdpmel(jl,jk) + if(pmflxr(jl,jk+1)+pmflxs(jl,jk+1).lt.0.0) then + pdmfdp(jl,jk)=-(pmflxr(jl,jk)+pmflxs(jl,jk)+pdmfup(jl,jk)) + pmflxr(jl,jk+1)=0.0 + pmflxs(jl,jk+1)=0.0 + pdpmel(jl,jk) =0.0 + else if ( pmflxr(jl,jk+1) < 0. ) then + pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) + pmflxr(jl,jk+1) = 0. + else if ( pmflxs(jl,jk+1) < 0. ) then + pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) + pmflxs(jl,jk+1) = 0. + end if + endif + enddo + enddo + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.ge.kcbot(jl)) then + zrfl=pmflxr(jl,jk)+pmflxs(jl,jk) + if(zrfl.gt.1.e-20) then + zdrfl1=zcpecons*max(0.,pqsen(jl,jk)-pqen(jl,jk))*zcucov* & + & (sqrt(paph(jl,jk)/paph(jl,klev+1))/5.09e-3* & + & zrfl/zcucov)**0.5777* & + & (paph(jl,jk+1)-paph(jl,jk)) + zrnew=zrfl-zdrfl1 + zrmin=zrfl-zcucov*max(0.,rhevap(jl)*pqsen(jl,jk) & + & -pqen(jl,jk)) *zcons2*(paph(jl,jk+1)-paph(jl,jk)) + zrnew=max(zrnew,zrmin) + zrfln=max(zrnew,0.) + zdrfl=min(0.,zrfln-zrfl) + zdenom=1./max(1.e-20,pmflxr(jl,jk)+pmflxs(jl,jk)) + zalfaw=foealfa(pten(jl,jk)) + if ( pten(jl,jk) < tmelt ) zalfaw = 0. + zpdr=zalfaw*pdmfdp(jl,jk) + zpds=(1.-zalfaw)*pdmfdp(jl,jk) + pmflxr(jl,jk+1)=pmflxr(jl,jk)+zpdr & + & +pdpmel(jl,jk)+zdrfl*pmflxr(jl,jk)*zdenom + pmflxs(jl,jk+1)=pmflxs(jl,jk)+zpds & + & -pdpmel(jl,jk)+zdrfl*pmflxs(jl,jk)*zdenom + pdmfup(jl,jk)=pdmfup(jl,jk)+zdrfl + if ( pmflxr(jl,jk+1)+pmflxs(jl,jk+1) < 0. ) then + pdmfup(jl,jk) = pdmfup(jl,jk)-(pmflxr(jl,jk+1)+pmflxs(jl,jk+1)) + pmflxr(jl,jk+1) = 0. + pmflxs(jl,jk+1) = 0. + pdpmel(jl,jk) = 0. + else if ( pmflxr(jl,jk+1) < 0. ) then + pmflxs(jl,jk+1) = pmflxs(jl,jk+1)+pmflxr(jl,jk+1) + pmflxr(jl,jk+1) = 0. + else if ( pmflxs(jl,jk+1) < 0. ) then + pmflxr(jl,jk+1) = pmflxr(jl,jk+1)+pmflxs(jl,jk+1) + pmflxs(jl,jk+1) = 0. + end if + else + pmflxr(jl,jk+1)=0.0 + pmflxs(jl,jk+1)=0.0 + pdmfdp(jl,jk)=0.0 + pdpmel(jl,jk)=0.0 + endif + endif + enddo + enddo + + return + end subroutine cuflxn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & + lddraf,ztmst,paph,pgeoh,pgeo,pten,ptenh,pqen, & + pqenh,pqsen,plglac,plude,pmfu,pmfd,pmfus,pmfds, & + pmfuq,pmfdq,pmful,pdmfup,pdpmel,ptent,ptenq,pcte) + implicit none + integer klon,klev,ktopm2 + integer kctop(klon), kdtop(klon) + logical ldcum(klon), lddraf(klon) + real ztmst + real paph(klon,klev+1), pgeoh(klon,klev+1) + real pgeo(klon,klev), pten(klon,klev), & + pqen(klon,klev), ptenh(klon,klev),& + pqenh(klon,klev), pqsen(klon,klev),& + plglac(klon,klev), plude(klon,klev) + real pmfu(klon,klev), pmfd(klon,klev),& + pmfus(klon,klev), pmfds(klon,klev),& + pmfuq(klon,klev), pmfdq(klon,klev),& + pmful(klon,klev), pdmfup(klon,klev),& + pdpmel(klon,klev) + real ptent(klon,klev), ptenq(klon,klev) + real pcte(klon,klev) + +! local variables + integer jk , ik , jl + real zalv , zzp + real zmfus(klon,klev) , zmfuq(klon,klev) + real zmfds(klon,klev) , zmfdq(klon,klev) + real zdtdt(klon,klev) , zdqdt(klon,klev) , zdp(klon,klev) + !* 1.0 SETUP AND INITIALIZATIONS + ! ------------------------- + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + zmfus(jl,jk) = pmfus(jl,jk) + zmfds(jl,jk) = pmfds(jl,jk) + zmfuq(jl,jk) = pmfuq(jl,jk) + zmfdq(jl,jk) = pmfdq(jl,jk) + end if + end do + end do + !----------------------------------------------------------------------- + !* 2.0 COMPUTE TENDENCIES + ! ------------------ + do jk = ktopm2 , klev + if ( jk < klev ) then + do jl = 1,klon + if ( ldcum(jl) ) then + zalv = foelhm(pten(jl,jk)) + zdtdt(jl,jk) = zdp(jl,jk)*rcpd * & + (zmfus(jl,jk+1)-zmfus(jl,jk)+zmfds(jl,jk+1) - & + zmfds(jl,jk)+alf*plglac(jl,jk)-alf*pdpmel(jl,jk) - & + zalv*(pmful(jl,jk+1)-pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk))) + zdqdt(jl,jk) = zdp(jl,jk)*(zmfuq(jl,jk+1) - & + zmfuq(jl,jk)+zmfdq(jl,jk+1)-zmfdq(jl,jk)+pmful(jl,jk+1) - & + pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)) + end if + end do + else + do jl = 1,klon + if ( ldcum(jl) ) then + zalv = foelhm(pten(jl,jk)) + zdtdt(jl,jk) = -zdp(jl,jk)*rcpd * & + (zmfus(jl,jk)+zmfds(jl,jk)+alf*pdpmel(jl,jk) - & + zalv*(pmful(jl,jk)+pdmfup(jl,jk))) + zdqdt(jl,jk) = -zdp(jl,jk)*(zmfuq(jl,jk) + & + zmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk))) + end if + end do + end if + end do + !--------------------------------------------------------------- + !* 3.0 UPDATE TENDENCIES + ! ----------------- + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + ptent(jl,jk) = ptent(jl,jk) + zdtdt(jl,jk) + ptenq(jl,jk) = ptenq(jl,jk) + zdqdt(jl,jk) + pcte(jl,jk) = zdp(jl,jk)*plude(jl,jk) + end if + end do + end do + + return + end subroutine cudtdqn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cududvn(klon,klev,ktopm2,ktype,kcbot,kctop,ldcum, & + ztmst,paph,puen,pven,pmfu,pmfd,puu,pud,pvu,pvd,ptenu, & + ptenv) + implicit none + integer klon,klev,ktopm2 + integer ktype(klon), kcbot(klon), kctop(klon) + logical ldcum(klon) + real ztmst + real paph(klon,klev+1) + real puen(klon,klev), pven(klon,klev),& + pmfu(klon,klev), pmfd(klon,klev),& + puu(klon,klev), pud(klon,klev),& + pvu(klon,klev), pvd(klon,klev) + real ptenu(klon,klev), ptenv(klon,klev) + +!local variables + real zuen(klon,klev) , zven(klon,klev) , zmfuu(klon,klev), & + zmfdu(klon,klev), zmfuv(klon,klev), zmfdv(klon,klev) + + integer ik , ikb , jk , jl + real zzp, zdtdt + + real zdudt(klon,klev), zdvdt(klon,klev), zdp(klon,klev) +! + do jk = 1 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + zuen(jl,jk) = puen(jl,jk) + zven(jl,jk) = pven(jl,jk) + zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk)) + end if + end do + end do +!---------------------------------------------------------------------- +!* 1.0 CALCULATE FLUXES AND UPDATE U AND V TENDENCIES +! ---------------------------------------------- + do jk = ktopm2 , klev + ik = jk - 1 + do jl = 1,klon + if ( ldcum(jl) ) then + zmfuu(jl,jk) = pmfu(jl,jk)*(puu(jl,jk)-zuen(jl,ik)) + zmfuv(jl,jk) = pmfu(jl,jk)*(pvu(jl,jk)-zven(jl,ik)) + zmfdu(jl,jk) = pmfd(jl,jk)*(pud(jl,jk)-zuen(jl,ik)) + zmfdv(jl,jk) = pmfd(jl,jk)*(pvd(jl,jk)-zven(jl,ik)) + end if + end do + end do + ! linear fluxes below cloud + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) .and. jk > kcbot(jl) ) then + ikb = kcbot(jl) + zzp = ((paph(jl,klev+1)-paph(jl,jk))/(paph(jl,klev+1)-paph(jl,ikb))) + if ( ktype(jl) == 3 ) zzp = zzp*zzp + zmfuu(jl,jk) = zmfuu(jl,ikb)*zzp + zmfuv(jl,jk) = zmfuv(jl,ikb)*zzp + zmfdu(jl,jk) = zmfdu(jl,ikb)*zzp + zmfdv(jl,jk) = zmfdv(jl,ikb)*zzp + end if + end do + end do +!---------------------------------------------------------------------- +!* 2.0 COMPUTE TENDENCIES +! ------------------ + do jk = ktopm2 , klev + if ( jk < klev ) then + ik = jk + 1 + do jl = 1,klon + if ( ldcum(jl) ) then + zdudt(jl,jk) = zdp(jl,jk) * & + (zmfuu(jl,ik)-zmfuu(jl,jk)+zmfdu(jl,ik)-zmfdu(jl,jk)) + zdvdt(jl,jk) = zdp(jl,jk) * & + (zmfuv(jl,ik)-zmfuv(jl,jk)+zmfdv(jl,ik)-zmfdv(jl,jk)) + end if + end do + else + do jl = 1,klon + if ( ldcum(jl) ) then + zdudt(jl,jk) = -zdp(jl,jk)*(zmfuu(jl,jk)+zmfdu(jl,jk)) + zdvdt(jl,jk) = -zdp(jl,jk)*(zmfuv(jl,jk)+zmfdv(jl,jk)) + end if + end do + end if + end do +!--------------------------------------------------------------------- +!* 3.0 UPDATE TENDENCIES +! ----------------- + do jk = ktopm2 , klev + do jl = 1, klon + if ( ldcum(jl) ) then + ptenu(jl,jk) = ptenu(jl,jk) + zdudt(jl,jk) + ptenv(jl,jk) = ptenv(jl,jk) + zdvdt(jl,jk) + end if + end do + end do +!---------------------------------------------------------------------- + return + end subroutine cududvn +!--------------------------------------------------------- +! level 3 souroutines +!-------------------------------------------------------- + subroutine cuadjtqn & + & (klon, klev, kk, psp, pt, pq, ldflag, kcall) +! m.tiedtke e.c.m.w.f. 12/89 +! purpose. +! -------- +! to produce t,q and l values for cloud ascent + +! interface +! --------- +! this routine is called from subroutines: +! *cond* (t and q at condensation level) +! *cubase* (t and q at condensation level) +! *cuasc* (t and q at cloud levels) +! *cuini* (environmental t and qs values at half levels) +! input are unadjusted t and q values, +! it returns adjusted values of t and q + +! parameter description units +! --------- ----------- ----- +! input parameters (integer): + +! *klon* number of grid points per packet +! *klev* number of levels +! *kk* level +! *kcall* defines calculation as +! kcall=0 env. t and qs in*cuini* +! kcall=1 condensation in updrafts (e.g. cubase, cuasc) +! kcall=2 evaporation in downdrafts (e.g. cudlfs,cuddraf) +! input parameters (real): + +! *psp* pressure pa + +! updated parameters (real): + +! *pt* temperature k +! *pq* specific humidity kg/kg +! externals +! --------- +! for condensation calculations. +! the tables are initialised in *suphec*. + +!---------------------------------------------------------------------- + + implicit none + + integer klev,klon + real pt(klon,klev), pq(klon,klev), & + & psp(klon) + logical ldflag(klon) +! local variables + integer jl,jk + integer isum,kcall,kk + real zqmax,zqsat,zcor,zqp,zcond,zcond1,zl,zi,zf +!---------------------------------------------------------------------- +! 1. define constants +! ---------------- + zqmax=0.5 + +! 2. calculate condensation and adjust t and q accordingly +! ----------------------------------------------------- + + if ( kcall == 1 ) then + do jl = 1,klon + if ( ldflag(jl) ) then + zqp = 1./psp(jl) + zl = 1./(pt(jl,kk)-c4les) + zi = 1./(pt(jl,kk)-c4ies) + zqsat = c2es*(foealfa(pt(jl,kk))*exp(c3les*(pt(jl,kk)-tmelt)*zl) + & + (1.-foealfa(pt(jl,kk)))*exp(c3ies*(pt(jl,kk)-tmelt)*zi)) + zqsat = zqsat*zqp + zqsat = min(0.5,zqsat) + zcor = 1. - vtmpc1*zqsat + zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & + (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 + zcond = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) + if ( zcond > 0. ) then + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond + pq(jl,kk) = pq(jl,kk) - zcond + zl = 1./(pt(jl,kk)-c4les) + zi = 1./(pt(jl,kk)-c4ies) + zqsat = c2es*(foealfa(pt(jl,kk)) * & + exp(c3les*(pt(jl,kk)-tmelt)*zl)+(1.-foealfa(pt(jl,kk))) * & + exp(c3ies*(pt(jl,kk)-tmelt)*zi)) + zqsat = zqsat*zqp + zqsat = min(0.5,zqsat) + zcor = 1. - vtmpc1*zqsat + zf = foealfa(pt(jl,kk))*r5alvcp*zl**2 + & + (1.-foealfa(pt(jl,kk)))*r5alscp*zi**2 + zcond1 = (pq(jl,kk)*zcor**2-zqsat*zcor)/(zcor**2+zqsat*zf) + if ( abs(zcond) < 1.e-20 ) zcond1 = 0. + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end if + end if + end do + elseif ( kcall == 2 ) then + do jl = 1,klon + if ( ldflag(jl) ) then + zqp = 1./psp(jl) + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + zcond = min(zcond,0.) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond + pq(jl,kk) = pq(jl,kk) - zcond + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + if ( abs(zcond) < 1.e-20 ) zcond1 = min(zcond1,0.) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end if + end do + else if ( kcall == 0 ) then + do jl = 1,klon + zqp = 1./psp(jl) + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + zqsat = foeewm(pt(jl,kk))*zqp + zqsat = min(0.5,zqsat) + zcor = 1./(1.-vtmpc1*zqsat) + zqsat = zqsat*zcor + zcond1 = (pq(jl,kk)-zqsat)/(1.+zqsat*zcor*foedem(pt(jl,kk))) + pt(jl,kk) = pt(jl,kk) + foeldcpm(pt(jl,kk))*zcond1 + pq(jl,kk) = pq(jl,kk) - zcond1 + end do + end if + + return + end subroutine cuadjtqn +!--------------------------------------------------------- +! level 4 souroutines +!-------------------------------------------------------- + subroutine cubasmcn & + & (klon, klev, klevm1, kk, pten,& + & pqen, pqsen, puen, pven, pverv,& + & pgeo, pgeoh, ldcum, ktype, klab, plrain,& + & pmfu, pmfub, kcbot, ptu,& + & pqu, plu, puu, pvu, pmfus,& + & pmfuq, pmful, pdmfup) + implicit none +! m.tiedtke e.c.m.w.f. 12/89 +! c.zhang iprc 05/2012 +!***purpose. +! -------- +! this routine calculates cloud base values +! for midlevel convection +!***interface +! --------- +! this routine is called from *cuasc*. +! input are environmental values t,q etc +! it returns cloudbase values for midlevel convection +!***method. +! ------- +! s. tiedtke (1989) +!***externals +! --------- +! none +! ---------------------------------------------------------------- + real pten(klon,klev), pqen(klon,klev),& + & puen(klon,klev), pven(klon,klev),& + & pqsen(klon,klev), pverv(klon,klev),& + & pgeo(klon,klev), pgeoh(klon,klev+1) + real ptu(klon,klev), pqu(klon,klev),& + & puu(klon,klev), pvu(klon,klev),& + & plu(klon,klev), pmfu(klon,klev),& + & pmfub(klon), & + & pmfus(klon,klev), pmfuq(klon,klev),& + & pmful(klon,klev), pdmfup(klon,klev),& + & plrain(klon,klev) + integer ktype(klon), kcbot(klon),& + & klab(klon,klev) + logical ldcum(klon) +! local variabels + integer jl,kk,klev,klon,klevp1,klevm1 + real zzzmb +!-------------------------------------------------------- +!* 1. calculate entrainment and detrainment rates +! ------------------------------------------------------- + do jl=1,klon + if(.not.ldcum(jl) .and. klab(jl,kk+1).eq.0) then + if(lmfmid .and. pqen(jl,kk) .gt. 0.80*pqsen(jl,kk).and. & + pgeo(jl,kk)*zrg .gt. 5.0e2 .and. & + & pgeo(jl,kk)*zrg .lt. 1.0e4 ) then + ptu(jl,kk+1)=(cpd*pten(jl,kk)+pgeo(jl,kk)-pgeoh(jl,kk+1))& + & *rcpd + pqu(jl,kk+1)=pqen(jl,kk) + plu(jl,kk+1)=0. + zzzmb=max(cmfcmin,-pverv(jl,kk)*zrg) + zzzmb=min(zzzmb,cmfcmax) + pmfub(jl)=zzzmb + pmfu(jl,kk+1)=pmfub(jl) + pmfus(jl,kk+1)=pmfub(jl)*(cpd*ptu(jl,kk+1)+pgeoh(jl,kk+1)) + pmfuq(jl,kk+1)=pmfub(jl)*pqu(jl,kk+1) + pmful(jl,kk+1)=0. + pdmfup(jl,kk+1)=0. + kcbot(jl)=kk + klab(jl,kk+1)=1 + plrain(jl,kk+1)=0.0 + ktype(jl)=3 + end if + end if + end do + return + end subroutine cubasmcn +!--------------------------------------------------------- +! level 4 souroutines +!--------------------------------------------------------- + subroutine cuentrn(klon,klev,kk,kcbot,ldcum,ldwork, & + pgeoh,pmfu,pdmfen,pdmfde) + implicit none + integer klon,klev,kk + integer kcbot(klon) + logical ldcum(klon) + logical ldwork + real pgeoh(klon,klev+1) + real pmfu(klon,klev) + real pdmfen(klon) + real pdmfde(klon) + logical llo1 + integer jl + real zdz , zmf + real zentr(klon) + ! + !* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES + ! ------------------------------------------- + if ( ldwork ) then + do jl = 1,klon + pdmfen(jl) = 0. + pdmfde(jl) = 0. + zentr(jl) = 0. + end do + ! + !* 1.1 SPECIFY ENTRAINMENT RATES + ! ------------------------- + do jl = 1, klon + if ( ldcum(jl) ) then + zdz = (pgeoh(jl,kk)-pgeoh(jl,kk+1))*zrg + zmf = pmfu(jl,kk+1)*zdz + llo1 = kk < kcbot(jl) + if ( llo1 ) then + pdmfen(jl) = zentr(jl)*zmf + pdmfde(jl) = 0.75e-4*zmf + end if + end if + end do + end if + end subroutine cuentrn +!-------------------------------------------------------- +! external functions +!------------------------------------------------------ + real function foealfa(tt) +! foealfa is calculated to distinguish the three cases: +! +! foealfa=1 water phase +! foealfa=0 ice phase +! 0 < foealfa < 1 mixed phase +! +! input : tt = temperature +! + implicit none + real tt + foealfa = min(1.,((max(rtice,min(rtwat,tt))-rtice) & + & /(rtwat-rtice))**2) + + return + end function foealfa + + real function foelhm(tt) + implicit none + real tt + foelhm = foealfa(tt)*alv + (1.-foealfa(tt))*als + return + end function foelhm + + real function foeewm(tt) + implicit none + real tt + foeewm = c2es * & + & (foealfa(tt)*exp(c3les*(tt-tmelt)/(tt-c4les))+ & + & (1.-foealfa(tt))*exp(c3ies*(tt-tmelt)/(tt-c4ies))) + return + end function foeewm + + real function foedem(tt) + implicit none + real tt + foedem = foealfa(tt)*r5alvcp*(1./(tt-c4les)**2)+ & + & (1.-foealfa(tt))*r5alscp*(1./(tt-c4ies)**2) + return + end function foedem + + real function foeldcpm(tt) + implicit none + real tt + foeldcpm = foealfa(tt)*ralvdcp+ & + & (1.-foealfa(tt))*ralsdcp + return + end function foeldcpm + +end module module_cu_ntiedtke + diff --git a/wrfv2_fire/phys/module_cu_sas.F b/wrfv2_fire/phys/module_cu_sas.F index ae5289fa..4aa0f333 100755 --- a/wrfv2_fire/phys/module_cu_sas.F +++ b/wrfv2_fire/phys/module_cu_sas.F @@ -2712,6 +2712,27 @@ subroutine sascnvn(im,ix,km,jcap,delt,del,prsl,ps,phil,ql, & !c & .743,.813,.886,.947,1.138,1.377,1.896/ real(kind=kind_phys) tf, tcr, tcrf parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) +#if HWRF==1 + logical :: pert_sas !zhang + integer :: ens_random_seed !zhang + real*8 :: gasdev,ran1 !zhang + real :: rr, ens_sasamp !zhang + logical,save :: pert_sas_local !zhang + integer,save :: ens_random_seed_local !zhang + real,save :: ens_sasamp_local !zhang + data ens_random_seed_local/0/ +!zz print*,'zhang in sas=============' + if ( ens_random_seed_local .eq. 0 ) then + CALL nl_get_pert_sas(1,pert_sas) + CALL nl_get_ens_random_seed(1,ens_random_seed) + CALL nl_get_ens_sasamp(1,ens_sasamp) + ens_random_seed_local=ens_random_seed + pert_sas_local=pert_sas + ens_sasamp_local=ens_sasamp +!zz print*,"zhang in sas one time", pert_sas_local,ens_random_seed_local,ens_sasamp_local + endif +!zz print*,"zhang in sas", pert_sas_local,ens_random_seed_local,ens_sasamp_local +#endif ! !c----------------------------------------------------------------------- ! @@ -3038,6 +3059,14 @@ subroutine sascnvn(im,ix,km,jcap,delt,del,prsl,ps,phil,ql, & tem1= .5*(cincrmax-cincrmin) cincr = cincrmax - tem * tem1 pbcdif(i) = pfld(i,kb(i)) - pfld(i,kbcon(i)) +#if HWRF==1 +! randomly perturb the convection trigger + if( pert_sas_local ) then + rr=2.0*ens_sasamp_local*ran1(ens_random_seed_local)-ens_sasamp_local + print*, "zhang inde sas=", rr,ens_sasamp_local,ens_random_seed_local + cincr=cincr+rr + endif +#endif if(pbcdif(i).gt.cincr) then cnvflg(i) = .false. endif @@ -5520,3 +5549,56 @@ subroutine shalcnv(im,ix,km,jcap,delt,del,prsl,ps,phil,ql, & end subroutine shalcnv END MODULE module_cu_sas + FUNCTION ran1(idum) + implicit none + integer idum,ia,im,iq,ir,ntab,ndiv + real*8 am,eps,rnmx + real*8 ran1 + parameter (ia=16807,im=2147483647,am=1./im,iq=127773,ir=2836, & + & ntab=32,ndiv=1+(im-1)/ntab,eps=1.2e-7,rnmx=1.-eps) + integer j,k,iv(32),iy,junk + common /random/ junk,iv,iy + data iv /ntab*0/, iy /0/ + if (idum.le.0.or.iy.eq.0) then + idum=max(-idum,1) + do j=ntab+8,1,-1 + k=idum/iq + idum=ia*(idum-k*iq)-ir*k + if (idum.lt.0) idum=idum+im + if (j.le.ntab) iv(j)=idum + enddo + iy=iv(1) + endif + k=idum/iq + idum=ia*(idum-k*iq)-ir*k + if (idum.lt.0) idum=idum+im + j=1+iy/ndiv + iy=iv(j) + iv(j)=idum + ran1=min(am*iy,rnmx) + return + END FUNCTION ran1 + + FUNCTION gasdev(idum) + INTEGER idum + REAL*8 gasdev +!CU USES ran1 + INTEGER iset + REAL*8 fac,gset,rsq,v1,v2,ran1 + SAVE iset,gset + DATA iset/0/ + if (iset.eq.0) then + 1 v1=2.*ran1(idum)-1. + v2=2.*ran1(idum)-1. + rsq=v1**2+v2**2 + if(rsq.ge.1..or.rsq.eq.0.)goto 1 + fac=sqrt(-2.*log(rsq)/rsq) + gset=v1*fac + gasdev=v2*fac + iset=1 + else + gasdev=gset + iset=0 + endif + return + END FUNCTION gasdev diff --git a/wrfv2_fire/phys/module_cu_tiedtke.F b/wrfv2_fire/phys/module_cu_tiedtke.F index 61a6e824..ad3f196b 100644 --- a/wrfv2_fire/phys/module_cu_tiedtke.F +++ b/wrfv2_fire/phys/module_cu_tiedtke.F @@ -1,198 +1,167 @@ !----------------------------------------------------------------------- ! -!WRF:MODEL_LAYER:PHYSICS -! -!####################TIEDTKE SCHEME######################### -! Taken from the IPRC iRAM - Yuqing Wang, University of Hawaii -! Added by Chunxi Zhang and Yuqing Wang to WRF3.2, May, 2010 -! refenrence: Tiedtke (1989, MWR, 117, 1779-1800) -! Nordeng, T.E., (1995), CAPE closure and organized entrainment/detrainment -! Yuqing Wang et al. (2003,J. Climate, 16, 1721-1738) for improvements +!wrf:model_layer:physics +! +!####################tiedtke scheme######################### +! taken from the IPRC IRAM - Yuqing Wang, university of hawaii +! added by Chunxi Zhang and Yuqing Wang to wrf3.2, may, 2010 +! refenrence: Tiedtke (1989, mwr, 117, 1779-1800) +! Nordeng, t.e., (1995), cape closure and organized entrainment/detrainment +! Yuqing Wang et al. (2003,j. climate, 16, 1721-1738) for improvements ! for cloud top detrainment -! (2004, Mon. Wea. Rev., 132, 274-296), improvements for PBL clouds -! (2007,Mon. Wea. Rev., 135, 567-585), diurnal cycle of precipitation -! This scheme is on testing +! (2004, mon. wea. rev., 132, 274-296), improvements for pbl clouds +! (2007,mon. wea. rev., 135, 567-585), diurnal cycle of precipitation !########################################################### -MODULE module_cu_tiedtke +module module_cu_tiedtke ! -!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ -! epsl--- allowed minimum value for floating calculation -!--------------------------------------------------------------- - real,parameter :: epsl = 1.0e-20 - real,parameter :: t000 = 273.15 - real,parameter :: hgfr = 233.15 ! defined in param.f in explct -!------------------------------------------------------------- -! Ends the parameters set -!++++++++++++++++++++++++++++ - REAL,PRIVATE :: G,CPV - REAL :: API,A,EOMEGA,RD,RV,CPD,RCPD,VTMPC1,VTMPC2, & - RHOH2O,ALV,ALS,ALF,CLW,TMELT,SOLC,STBO,DAYL,YEARL, & - C1ES,C2ES,C3LES,C3IES,C4LES,C4IES,C5LES,C5IES,ZRG + use module_model_constants, only:rd=>r_d, rv=>r_v, & + & cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, g + + implicit none + + real :: rcpd,vtmpc1,t000,hgfr,rhoh2o,tmelt, & + c1es,c2es,c3les,c3ies,c4les,c4ies,c5les,c5ies,zrg - REAL :: ENTRPEN,ENTRSCV,ENTRMID,ENTRDD,CMFCTOP,RHM,RHC, & - CMFCMAX,CMFCMIN,CMFDEPS,RHCDD,CPRCON,CRIRH,ZBUO0, & - fdbk,ZTAU + real :: entrpen,entrscv,entrmid,entrdd,cmfctop,rhm,rhc, & + cmfcmax,cmfcmin,cmfdeps,cprcon,crirh,zbuo0, & + fdbk,ztau - INTEGER :: orgen,nturben,cutrigger - - REAL :: CVDIFTS, CEVAPCU1, CEVAPCU2,ZDNOPRC + real :: cevapcu1, cevapcu2, zdnoprc - - PARAMETER(A=6371.22E03, & - ALV=2.5008E6, & - ALS=2.8345E6, & - ALF=ALS-ALV, & - CPD=1005.46, & - CPV=1869.46, & ! CPV in module is 1846.4 - RCPD=1.0/CPD, & - RHOH2O=1.0E03, & - TMELT=273.16, & - G=9.806, & ! G=9.806 - ZRG=1.0/G, & - RD=287.05, & - RV=461.51, & - C1ES=610.78, & - C2ES=C1ES*RD/RV, & - C3LES=17.269, & - C4LES=35.86, & - C5LES=C3LES*(TMELT-C4LES), & - C3IES=21.875, & - C4IES=7.66, & - C5IES=C3IES*(TMELT-C4IES), & - API=3.141593, & ! API=2.0*ASIN(1.) - VTMPC1=RV/RD-1.0, & - VTMPC2=CPV/CPD-1.0, & - CVDIFTS=1.0, & - CEVAPCU1=1.93E-6*261.0*0.5/G, & - CEVAPCU2=1.E3/(38.3*0.293) ) + parameter( & + rcpd=1.0/cpd, & + rhoh2o=1.0e03, & + tmelt=273.16, & + t000= 273.15, & + hgfr= 233.15, & + zrg=1.0/g, & + c1es=610.78, & + c2es=c1es*rd/rv, & + c3les=17.269, & + c4les=35.86, & + c5les=c3les*(tmelt-c4les), & + c3ies=21.875, & + c4ies=7.66, & + c5ies=c3ies*(tmelt-c4ies), & + vtmpc1=rv/rd-1.0, & + cevapcu1=1.93e-6*261.0*0.5/g, & + cevapcu2=1.e3/(38.3*0.293) ) -! SPECIFY PARAMETERS FOR MASSFLUX-SCHEME +! specify parameters for massflux-scheme ! -------------------------------------- -! These are tunable parameters +! these are tunable parameters ! -! ENTRPEN: AVERAGE ENTRAINMENT RATE FOR PENETRATIVE CONVECTION +! entrpen: average entrainment rate for penetrative convection ! ------- ! - PARAMETER(ENTRPEN=1.0E-4) + parameter(entrpen=1.0e-4) ! -! ENTRSCV: AVERAGE ENTRAINMENT RATE FOR SHALLOW CONVECTION +! entrscv: average entrainment rate for shallow convection ! ------- ! - PARAMETER(ENTRSCV=1.2E-3) + parameter(entrscv=1.2e-3) ! -! ENTRMID: AVERAGE ENTRAINMENT RATE FOR MIDLEVEL CONVECTION +! entrmid: average entrainment rate for midlevel convection ! ------- ! - PARAMETER(ENTRMID=1.0E-4) + parameter(entrmid=1.0e-4) ! -! ENTRDD: AVERAGE ENTRAINMENT RATE FOR DOWNDRAFTS +! entrdd: average entrainment rate for downdrafts ! ------ ! - PARAMETER(ENTRDD =2.0E-4) + parameter(entrdd =2.0e-4) ! -! CMFCTOP: RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY LEVEL +! cmfctop: relative cloud massflux at level above nonbuoyancy level ! ------- ! - PARAMETER(CMFCTOP=0.30) + parameter(cmfctop=0.30) ! -! CMFCMAX: MAXIMUM MASSFLUX VALUE ALLOWED FOR UPDRAFTS ETC +! cmfcmax: maximum massflux value allowed for updrafts etc ! ------- ! - PARAMETER(CMFCMAX=1.0) + parameter(cmfcmax=1.0) ! -! CMFCMIN: MINIMUM MASSFLUX VALUE (FOR SAFETY) +! cmfcmin: minimum massflux value (for safety) ! ------- ! - PARAMETER(CMFCMIN=1.E-10) + parameter(cmfcmin=1.e-10) ! -! CMFDEPS: FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS +! cmfdeps: fractional massflux for downdrafts at lfs ! ------- ! - PARAMETER(CMFDEPS=0.30) + parameter(cmfdeps=0.30) ! -! CPRCON: COEFFICIENTS FOR DETERMINING CONVERSION FROM CLOUD WATER +! cprcon: coefficients for determining conversion from cloud water ! - PARAMETER(CPRCON = 1.1E-3/G) + parameter(cprcon = 1.1e-3/g) ! -! ZDNOPRC: The pressure depth below which no precipitation +! zdnoprc: the pressure depth below which no precipitation ! - PARAMETER(ZDNOPRC =1.5E4) + parameter(zdnoprc = 1.5e4) !-------------------- - PARAMETER(orgen=1) ! Old organized entrainment rate -! PARAMETER(orgen=2) ! New organized entrainment rate - - PARAMETER(nturben=1) ! old deep turburent entrainment/detrainment rate -! PARAMETER(nturben=2) ! New deep turburent entrainment/detrainment rate - - PARAMETER(cutrigger=1) ! Old trigger function -! PARAMETER(cutrigger=2) ! New trigger function -! -!-------------------- - PARAMETER(RHC=0.80,RHM=1.0,ZBUO0=0.50) + parameter(rhc=0.80,rhm=1.0,zbuo0=0.50) !-------------------- - PARAMETER(CRIRH=0.70,fdbk = 1.0,ZTAU = 1800.0) + parameter(crirh=0.70,fdbk = 1.0,ztau = 2400.0) !-------------------- - LOGICAL :: LMFPEN,LMFMID,LMFSCV,LMFDD,LMFDUDV - PARAMETER(LMFPEN=.TRUE.,LMFMID=.TRUE.,LMFSCV=.TRUE.,LMFDD=.TRUE.,LMFDUDV=.TRUE.) + logical :: lmfpen,lmfmid,lmfscv,lmfdd,lmfdudv + parameter(lmfpen=.true.,lmfmid=.true.,lmfscv=.true.,lmfdd=.true.,lmfdudv=.true.) !-------------------- -!#################### END of Variables definition########################## +!#################### end of variables definition########################## !----------------------------------------------------------------------- ! -CONTAINS +contains !----------------------------------------------------------------------- - SUBROUTINE CU_TIEDTKE( & - DT,ITIMESTEP,STEPCU & - ,RAINCV,PRATEC,QFX,HFX,ZNU & - ,U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D & - ,QVFTEN,QVPBLTEN & - ,DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG & + subroutine cu_tiedtke( & + dt,itimestep,stepcu & + ,raincv,pratec,qfx,znu & + ,u3d,v3d,w,t3d,qv3d,qc3d,qi3d,pi3d,rho3d & + ,qvften,qvpblten & + ,dz8w,pcps,p8w,xland,cu_act_flag & ,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & ,its,ite, jts,jte, kts,kte & - ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN & - ,RUCUTEN, RVCUTEN & - ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & + ,rthcuten,rqvcuten,rqccuten,rqicuten & + ,rucuten, rvcuten & + ,f_qv ,f_qc ,f_qr ,f_qi ,f_qs & ) + !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- -!-- U3D 3D u-velocity interpolated to theta points (m/s) -!-- V3D 3D v-velocity interpolated to theta points (m/s) -!-- TH3D 3D potential temperature (K) -!-- T3D temperature (K) -!-- QV3D 3D water vapor mixing ratio (Kg/Kg) -!-- QC3D 3D cloud mixing ratio (Kg/Kg) -!-- QI3D 3D ice mixing ratio (Kg/Kg) -!-- RHO3D 3D air density (kg/m^3) -!-- P8w 3D hydrostatic pressure at full levels (Pa) -!-- Pcps 3D hydrostatic pressure at half levels (Pa) -!-- PI3D 3D exner function (dimensionless) -!-- QVFTEN 3D water vapor advection tendency -!-- QVPBLTEN 3D water vapor tendency due to a PBL -!-- RTHCUTEN Theta tendency due to -! cumulus scheme precipitation (K/s) -!-- RUCUTEN U wind tendency due to -! cumulus scheme precipitation (K/s) -!-- RVCUTEN V wind tendency due to -! cumulus scheme precipitation (K/s) -!-- RQVCUTEN Qv tendency due to +!-- u3d 3d u-velocity interpolated to theta points (m/s) +!-- v3d 3d v-velocity interpolated to theta points (m/s) +!-- th3d 3d potential temperature (k) +!-- t3d temperature (k) +!-- qv3d 3d water vapor mixing ratio (kg/kg) +!-- qc3d 3d cloud mixing ratio (kg/kg) +!-- qi3d 3d ice mixing ratio (kg/kg) +!-- rho3d 3d air density (kg/m^3) +!-- p8w 3d hydrostatic pressure at full levels (pa) +!-- pcps 3d hydrostatic pressure at half levels (pa) +!-- pi3d 3d exner function (dimensionless) +!-- rthcuten theta tendency due to +! cumulus scheme precipitation (k/s) +!-- rucuten u wind tendency due to +! cumulus scheme precipitation (k/s) +!-- rvcuten v wind tendency due to +! cumulus scheme precipitation (k/s) +!-- rqvcuten qv tendency due to ! cumulus scheme precipitation (kg/kg/s) -!-- RQRCUTEN Qr tendency due to +!-- rqrcuten qr tendency due to ! cumulus scheme precipitation (kg/kg/s) -!-- RQCCUTEN Qc tendency due to +!-- rqccuten qc tendency due to ! cumulus scheme precipitation (kg/kg/s) -!-- RQSCUTEN Qs tendency due to +!-- rqscuten qs tendency due to ! cumulus scheme precipitation (kg/kg/s) -!-- RQICUTEN Qi tendency due to +!-- rqicuten qi tendency due to ! cumulus scheme precipitation (kg/kg/s) -!-- RAINC accumulated total cumulus scheme precipitation (mm) -!-- RAINCV cumulus scheme precipitation (mm) -!-- PRATEC precipitiation rate from cumulus scheme (mm/s) +!-- rainc accumulated total cumulus scheme precipitation (mm) +!-- raincv cumulus scheme precipitation (mm) +!-- pratec precipitiation rate from cumulus scheme (mm/s) !-- dz8w dz between full levels (m) -!-- QFX upward moisture flux at the surface (kg/m^2/s) -!-- DT time step (s) -!-- F_QV etc flag values for tendencies, not used +!-- qfx upward moisture flux at the surface (kg/m^2/s) +!-- dt time step (s) !-- ids start index for i in domain !-- ide end index for i in domain !-- jds start index for j in domain @@ -212,1962 +181,1573 @@ SUBROUTINE CU_TIEDTKE( & !-- kts start index for k in tile !-- kte end index for k in tile !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & + integer, intent(in) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - ITIMESTEP, & - STEPCU + itimestep, & + stepcu - REAL, INTENT(IN) :: & - DT + real, intent(in) :: & + dt - REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN) :: & - XLAND + real, dimension(ims:ime, jms:jme), intent(in) :: & + xland - REAL, DIMENSION(ims:ime, jms:jme), INTENT(INOUT) :: & - RAINCV, PRATEC + real, dimension(ims:ime, jms:jme), intent(inout) :: & + raincv, pratec - LOGICAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) :: & - CU_ACT_FLAG + logical, dimension(ims:ime,jms:jme), intent(inout) :: & + cu_act_flag - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: & - DZ8W, & - P8w, & - Pcps, & - PI3D, & - QC3D, & - QVFTEN, & - QVPBLTEN, & - QI3D, & - QV3D, & - RHO3D, & - T3D, & - U3D, & - V3D, & - W + real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: & + dz8w, & + p8w, & + pcps, & + pi3d, & + qc3d, & + qvften, & + qvpblten, & + qi3d, & + qv3d, & + rho3d, & + t3d, & + u3d, & + v3d, & + w -!--------------------------- OPTIONAL VARS ---------------------------- +!--------------------------- optional vars ---------------------------- - REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & - OPTIONAL, INTENT(INOUT) :: & - RQCCUTEN, & - RQICUTEN, & - RQVCUTEN, & - RTHCUTEN, & - RUCUTEN, & - RVCUTEN + real, dimension(ims:ime, kms:kme, jms:jme), & + optional, intent(inout) :: & + rqccuten, & + rqicuten, & + rqvcuten, & + rthcuten, & + rucuten, & + rvcuten ! -! Flags relating to the optional tendency arrays declared above -! Models that carry the optional tendencies will provdide the +! flags relating to the optional tendency arrays declared above +! models that carry the optional tendencies will provdide the ! optional arguments at compile time; these flags all the model ! to determine at run-time whether a particular tracer is in ! use or not. ! - LOGICAL, OPTIONAL :: & - F_QV & - ,F_QC & - ,F_QR & - ,F_QI & - ,F_QS + logical, optional :: & + f_qv & + ,f_qc & + ,f_qr & + ,f_qi & + ,f_qs -!--------------------------- LOCAL VARS ------------------------------ - - REAL, DIMENSION(ims:ime, jms:jme) :: & - QFX, & - HFX - - REAL :: & - DELT, & - RDELT - - REAL , DIMENSION(its:ite) :: & - RCS, & - RN, & - EVAP, & - heatflux, & - rho2d - INTEGER , DIMENSION(its:ite) :: SLIMSK - +!--------------------------- local vars ------------------------------ + + real, dimension(ims:ime, jms:jme) :: & + qfx - REAL , DIMENSION(its:ite, kts:kte+1) :: & - PRSI - - REAL , DIMENSION(its:ite, kts:kte) :: & - DEL, & - DOT, & - PHIL, & - PRSL, & - Q1, & - Q2, & - Q3, & - Q1B, & - Q1BL, & - Q11, & - Q12, & - T1, & - U1, & - V1, & - ZI, & - ZL, & - OMG, & - GHT - - INTEGER, DIMENSION(its:ite) :: & - KBOT, & - KTOP - - INTEGER :: & - I, & - IM, & - J, & - K, & - KM, & - KP, & - KX + real :: & + delt, & + rdelt + real , dimension(its:ite) :: & + rcs, & + rn, & + evap + integer , dimension(its:ite) :: slimsk + + + real , dimension(its:ite, kts:kte+1) :: & + prsi + + real , dimension(its:ite, kts:kte) :: & + del, & + dot, & + phil, & + prsl, & + q1, & + q2, & + q3, & + q1b, & + q1bl, & + q11, & + q12, & + t1, & + u1, & + v1, & + zi, & + zl, & + omg, & + ght + + integer, dimension(its:ite) :: & + kbot, & + ktop + + integer :: & + i, & + im, & + j, & + k, & + km, & + kp, & + kx + + + logical :: run_param , doing_adapt_dt , decided !-------other local variables---- - INTEGER,DIMENSION( its:ite ) :: KTYPE - REAL, DIMENSION( kts:kte ) :: sig1 ! half sigma levels - REAL, DIMENSION( kms:kme ) :: ZNU - INTEGER :: zz + integer,dimension( its:ite ) :: ktype + real, dimension( kts:kte ) :: sig1 ! half sigma levels + real, dimension( kms:kme ) :: znu + integer :: zz !----------------------------------------------------------------------- -! - DO J=JTS,JTE - DO I=ITS,ITE - CU_ACT_FLAG(I,J)=.TRUE. - ENDDO - ENDDO + do j=jts,jte + do i=its,ite + cu_act_flag(i,j)=.true. + enddo + enddo - IM=ITE-ITS+1 - KX=KTE-KTS+1 - DELT=DT*STEPCU - RDELT=1./DELT + im=ite-its+1 + kx=kte-kts+1 + delt=dt*stepcu + rdelt=1./delt -!------------- J LOOP (OUTER) -------------------------------------------------- +!------------- j loop (outer) -------------------------------------------------- - DO J=jts,jte + do j=jts,jte ! --------------- compute zi and zl ----------------------------------------- - DO i=its,ite - ZI(I,KTS)=0.0 - ENDDO - - DO k=kts+1,kte - KM=k-1 - DO i=its,ite - ZI(I,K)=ZI(I,KM)+dz8w(i,km,j) - ENDDO - ENDDO - - DO k=kts+1,kte - KM=k-1 - DO i=its,ite - ZL(I,KM)=(ZI(I,K)+ZI(I,KM))*0.5 - ENDDO - ENDDO - - DO i=its,ite - ZL(I,KTE)=2.*ZI(I,KTE)-ZL(I,KTE-1) - ENDDO + do i=its,ite + zi(i,kts)=0.0 + enddo + + do k=kts+1,kte + km=k-1 + do i=its,ite + zi(i,k)=zi(i,km)+dz8w(i,km,j) + enddo + enddo + + do k=kts+1,kte + km=k-1 + do i=its,ite + zl(i,km)=(zi(i,k)+zi(i,km))*0.5 + enddo + enddo + + do i=its,ite + zl(i,kte)=2.*zi(i,kte)-zl(i,kte-1) + enddo ! --------------- end compute zi and zl ------------------------------------- - DO i=its,ite - SLIMSK(i)=int(ABS(XLAND(i,j)-2.)) - ENDDO + do i=its,ite + slimsk(i)=int(abs(xland(i,j)-2.)) + enddo - DO k=kts,kte + do k=kts,kte kp=k+1 - DO i=its,ite - DOT(i,k)=-0.5*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j)) - ENDDO - ENDDO + do i=its,ite + dot(i,k)=-0.5*g*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j)) + enddo + enddo - DO k=kts,kte + do k=kts,kte zz = kte+1-k - DO i=its,ite - U1(i,zz)=U3D(i,k,j) - V1(i,zz)=V3D(i,k,j) - T1(i,zz)=T3D(i,k,j) - Q1(i,zz)= QV3D(i,k,j) + do i=its,ite + u1(i,zz)=u3d(i,k,j) + v1(i,zz)=v3d(i,k,j) + t1(i,zz)=t3d(i,k,j) + q1(i,zz)= qv3d(i,k,j) if(itimestep == 1) then - Q1B(i,zz)=0. - Q1BL(i,zz)=0. + q1b(i,zz)=0. + q1bl(i,zz)=0. else - Q1B(i,zz)=QVFTEN(i,k,j) - Q1BL(i,zz)=QVPBLTEN(i,k,j) + q1b(i,zz)=qvften(i,k,j) + q1bl(i,zz)=qvpblten(i,k,j) endif - Q2(i,zz)=QC3D(i,k,j) - Q3(i,zz)=QI3D(i,k,j) - OMG(i,zz)=DOT(i,k) - GHT(i,zz)=ZL(i,k) - PRSL(i,zz) = Pcps(i,k,j) - ENDDO - ENDDO - - DO k=kts,kte+1 + q2(i,zz)=qc3d(i,k,j) + q3(i,zz)=qi3d(i,k,j) + omg(i,zz)=dot(i,k) + ght(i,zz)=zl(i,k) + prsl(i,zz) = pcps(i,k,j) + enddo + enddo + + do k=kts,kte+1 zz = kte+2-k - DO i=its,ite - PRSI(i,zz) = P8w(i,k,j) - ENDDO - ENDDO + do i=its,ite + prsi(i,zz) = p8w(i,k,j) + enddo + enddo - DO k=kts,kte + do k=kts,kte zz = kte+1-k - sig1(zz) = ZNU(k) - ENDDO + sig1(zz) = znu(k) + enddo -!###############before call TIECNV, we need EVAP######################## -! EVAP is the vapor flux at the surface +!###############before call tiecnv, we need evap######################## +! evap is the vapor flux at the surface !######################################################################## ! - DO i=its,ite - EVAP(i) = QFX(i,j) - heatflux(i)=HFX(i,j) - rho2d(i) = rho3d(i,1,j) - ENDDO + do i=its,ite + evap(i) = qfx(i,j) + enddo !######################################################################## - CALL TIECNV(U1,V1,T1,Q1,Q2,Q3,Q1B,Q1BL,GHT,OMG,PRSL,PRSI,EVAP,heatflux,rho2d, & - RN,SLIMSK,KTYPE,IM,KX,KX+1,sig1,DELT) + call tiecnv(u1,v1,t1,q1,q2,q3,q1b,q1bl,ght,omg,prsl,prsi,evap, & + rn,slimsk,ktype,im,kx,kx+1,sig1,delt) - DO I=ITS,ITE - RAINCV(I,J)=RN(I)/STEPCU - PRATEC(I,J)=RN(I)/(STEPCU * DT) - ENDDO + do i=its,ite + raincv(i,j)=rn(i)/stepcu + pratec(i,j)=rn(i)/(stepcu * dt) + enddo - DO K=KTS,KTE + do k=kts,kte zz = kte+1-k - DO I=ITS,ITE - RTHCUTEN(I,K,J)=(T1(I,zz)-T3D(I,K,J))/PI3D(I,K,J)*RDELT - RQVCUTEN(I,K,J)=(Q1(I,zz)-QV3D(I,K,J))*RDELT - RUCUTEN(I,K,J) =(U1(I,zz)-U3D(I,K,J))*RDELT - RVCUTEN(I,K,J) =(V1(I,zz)-V3D(I,K,J))*RDELT - ENDDO - ENDDO - - IF(PRESENT(RQCCUTEN))THEN - IF ( F_QC ) THEN - DO K=KTS,KTE + do i=its,ite + rthcuten(i,k,j)=(t1(i,zz)-t3d(i,k,j))/pi3d(i,k,j)*rdelt + rqvcuten(i,k,j)=(q1(i,zz)-qv3d(i,k,j))*rdelt + rucuten(i,k,j) =(u1(i,zz)-u3d(i,k,j))*rdelt + rvcuten(i,k,j) =(v1(i,zz)-v3d(i,k,j))*rdelt + enddo + enddo + + if(present(rqccuten))then + if ( f_qc ) then + do k=kts,kte zz = kte+1-k - DO I=ITS,ITE - RQCCUTEN(I,K,J)=(Q2(I,zz)-QC3D(I,K,J))*RDELT - ENDDO - ENDDO - ENDIF - ENDIF - - IF(PRESENT(RQICUTEN))THEN - IF ( F_QI ) THEN - DO K=KTS,KTE + do i=its,ite + rqccuten(i,k,j)=(q2(i,zz)-qc3d(i,k,j))*rdelt + enddo + enddo + endif + endif + + if(present(rqicuten))then + if ( f_qi ) then + do k=kts,kte zz = kte+1-k - DO I=ITS,ITE - RQICUTEN(I,K,J)=(Q3(I,zz)-QI3D(I,K,J))*RDELT - ENDDO - ENDDO - ENDIF - ENDIF + do i=its,ite + rqicuten(i,k,j)=(q3(i,zz)-qi3d(i,k,j))*rdelt + enddo + enddo + endif + endif - ENDDO + enddo - END SUBROUTINE CU_TIEDTKE + end subroutine cu_tiedtke !==================================================================== - SUBROUTINE tiedtkeinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & - RUCUTEN,RVCUTEN, & - RESTART,P_QC,P_QI,P_FIRST_SCALAR, & + subroutine tiedtkeinit(rthcuten,rqvcuten,rqccuten,rqicuten, & + rucuten,rvcuten, & + restart,p_qc,p_qi,p_first_scalar, & allowed_to_read, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte) !-------------------------------------------------------------------- - IMPLICIT NONE + implicit none !-------------------------------------------------------------------- - LOGICAL , INTENT(IN) :: allowed_to_read,restart - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + logical , intent(in) :: allowed_to_read,restart + integer , intent(in) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte - INTEGER , INTENT(IN) :: P_FIRST_SCALAR, P_QI, P_QC + integer , intent(in) :: p_first_scalar, p_qi, p_qc - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & - RTHCUTEN, & - RQVCUTEN, & - RQCCUTEN, & - RQICUTEN, & - RUCUTEN,RVCUTEN + real, dimension( ims:ime , kms:kme , jms:jme ) , intent(out) :: & + rthcuten, & + rqvcuten, & + rqccuten, & + rqicuten, & + rucuten,rvcuten - INTEGER :: i, j, k, itf, jtf, ktf + integer :: i, j, k, itf, jtf, ktf jtf=min0(jte,jde-1) ktf=min0(kte,kde-1) itf=min0(ite,ide-1) - IF(.not.restart)THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RTHCUTEN(i,k,j)=0. - RQVCUTEN(i,k,j)=0. - RUCUTEN(i,k,j)=0. - RVCUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - - IF (P_QC .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQCCUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - - IF (P_QI .ge. P_FIRST_SCALAR) THEN - DO j=jts,jtf - DO k=kts,ktf - DO i=its,itf - RQICUTEN(i,k,j)=0. - ENDDO - ENDDO - ENDDO - ENDIF - ENDIF - - END SUBROUTINE tiedtkeinit + if(.not.restart)then + do j=jts,jtf + do k=kts,ktf + do i=its,itf + rthcuten(i,k,j)=0. + rqvcuten(i,k,j)=0. + rucuten(i,k,j)=0. + rvcuten(i,k,j)=0. + enddo + enddo + enddo + + if (p_qc .ge. p_first_scalar) then + do j=jts,jtf + do k=kts,ktf + do i=its,itf + rqccuten(i,k,j)=0. + enddo + enddo + enddo + endif + + if (p_qi .ge. p_first_scalar) then + do j=jts,jtf + do k=kts,ktf + do i=its,itf + rqicuten(i,k,j)=0. + enddo + enddo + enddo + endif + endif + + end subroutine tiedtkeinit ! ------------------------------------------------------------------------ -!------------This is the combined version for tiedtke--------------- +!------------this is the combined version for tiedtke--------------- !---------------------------------------------------------------- -! In this module only the mass flux convection scheme of the ECMWF is included +! in this module only the mass flux convection scheme of the ecmwf is included !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ !############################################################# ! -! LEVEL 1 SUBROUTINEs +! level 1 subroutines ! !############################################################# !******************************************************** -! subroutine TIECNV +! subroutine tiecnv !******************************************************** - SUBROUTINE TIECNV(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, & - pap,paph,evap,hfx,rho,zprecc,lndj,KTYPE,lq,km,km1,sig1,dt) + subroutine tiecnv(pu,pv,pt,pqv,pqc,pqi,pqvf,pqvbl,poz,pomg, & + pap,paph,evap,zprecc,lndj,ktype,lq,km,km1,sig1,dt) !----------------------------------------------------------------- -! This is the interface between the meso-scale model and the mass +! this is the interface between the meso-scale model and the mass ! flux convection module !----------------------------------------------------------------- implicit none real pu(lq,km),pv(lq,km),pt(lq,km),pqv(lq,km),pqvf(lq,km) real poz(lq,km),pomg(lq,km),evap(lq),zprecc(lq),pqvbl(lq,km) - real PHHFL(lq),RHO(lq),hfx(lq) - REAL PUM1(lq,km), PVM1(lq,km), & - PTTE(lq,km), PQTE(lq,km), PVOM(lq,km), PVOL(lq,km), & - PVERV(lq,km), PGEO(lq,km), PAP(lq,km), PAPH(lq,km1) - REAL PQHFL(lq), ZQQ(lq,km), PAPRC(lq), PAPRS(lq), & - PRSFC(lq), PSSFC(lq), PAPRSM(lq), PCTE(lq,km) - REAL ZTP1(lq,km), ZQP1(lq,km), ZTU(lq,km), ZQU(lq,km), & - ZLU(lq,km), ZLUDE(lq,km), ZMFU(lq,km), ZMFD(lq,km), & - ZQSAT(lq,km), pqc(lq,km), pqi(lq,km), ZRAIN(lq) - - REAL sig(km1),sig1(km) - INTEGER ICBOT(lq), ICTOP(lq), KTYPE(lq), lndj(lq) - REAL dt - LOGICAL LOCUM(lq) - - real PSHEAT,PSRAIN,PSEVAP,PSMELT,PSDISS,TT - real ZTMST,ZTPP1,fliq,fice,ZTC,ZALF + + real pum1(lq,km), pvm1(lq,km), & + ptte(lq,km), pqte(lq,km), pvom(lq,km), pvol(lq,km), & + pverv(lq,km), pgeo(lq,km), pap(lq,km), paph(lq,km1) + real pqhfl(lq), zqq(lq,km), paprc(lq), paprs(lq), & + prsfc(lq), pssfc(lq), paprsm(lq), pcte(lq,km) + real ztp1(lq,km), zqp1(lq,km), ztu(lq,km), zqu(lq,km), & + zlu(lq,km), zlude(lq,km), zmfu(lq,km), zmfd(lq,km), & + zqsat(lq,km), pqc(lq,km), pqi(lq,km), zrain(lq) + + real sig(km1),sig1(km) + integer icbot(lq), ictop(lq), ktype(lq), lndj(lq) + real dt + logical locum(lq) + + real psheat,psrain,psevap,psmelt,psdiss,tt + real ztmst,ztpp1,fliq,fice,ztc,zalf integer i,j,k,lq,lp,km,km1 -! real TLUCUA -! external TLUCUA - - ZTMST=dt -! Masv flux diagnostics. - - PSHEAT=0.0 - PSRAIN=0.0 - PSEVAP=0.0 - PSMELT=0.0 - PSDISS=0.0 - DO 8 j=1,lq - ZRAIN(j)=0.0 - LOCUM(j)=.FALSE. - PRSFC(j)=0.0 - PSSFC(j)=0.0 - PAPRC(j)=0.0 - PAPRS(j)=0.0 - PAPRSM(j)=0.0 - PQHFL(j)=evap(j) - PHHFL(j)=hfx(j) - 8 CONTINUE - -! CONVERT MODEL VARIABLES FOR MFLUX SCHEME - - DO 10 k=1,km - DO 10 j=1,lq - PTTE(j,k)=0.0 - PCTE(j,k)=0.0 - PVOM(j,k)=0.0 - PVOL(j,k)=0.0 - ZTP1(j,k)=pt(j,k) - ZQP1(j,k)=pqv(j,k)/(1.0+pqv(j,k)) - PUM1(j,k)=pu(j,k) - PVM1(j,k)=pv(j,k) - PVERV(j,k)=pomg(j,k) - PGEO(j,k)=G*poz(j,k) - TT=ZTP1(j,k) - ZQSAT(j,k)=TLUCUA(TT)/PAP(j,k) - ZQSAT(j,k)=MIN(0.5,ZQSAT(j,k)) - ZQSAT(j,k)=ZQSAT(j,k)/(1.-VTMPC1*ZQSAT(j,k)) - PQTE(j,k)=pqvf(j,k)+pqvbl(j,k) - ZQQ(j,k)=PQTE(j,k) - 10 CONTINUE +! real tlucua +! external tlucua + + ztmst=dt +! masv flux diagnostics. + + psheat=0.0 + psrain=0.0 + psevap=0.0 + psmelt=0.0 + psdiss=0.0 + do j=1,lq + zrain(j)=0.0 + locum(j)=.false. + prsfc(j)=0.0 + pssfc(j)=0.0 + paprc(j)=0.0 + paprs(j)=0.0 + paprsm(j)=0.0 + pqhfl(j)=evap(j) + end do + +! convert model variables for mflux scheme + + do k=1,km + do j=1,lq + ptte(j,k)=0.0 + pcte(j,k)=0.0 + pvom(j,k)=0.0 + pvol(j,k)=0.0 + ztp1(j,k)=pt(j,k) + zqp1(j,k)=pqv(j,k)/(1.0+pqv(j,k)) + pum1(j,k)=pu(j,k) + pvm1(j,k)=pv(j,k) + pverv(j,k)=pomg(j,k) + pgeo(j,k)=g*poz(j,k) + tt=ztp1(j,k) + zqsat(j,k)=tlucua(tt)/pap(j,k) + zqsat(j,k)=min(0.5,zqsat(j,k)) + zqsat(j,k)=zqsat(j,k)/(1.-vtmpc1*zqsat(j,k)) + pqte(j,k)=pqvf(j,k)+pqvbl(j,k) + zqq(j,k)=pqte(j,k) + end do + end do ! !----------------------------------------------------------------------- -!* 2. CALL 'CUMASTR'(MASTER-ROUTINE FOR CUMULUS PARAMETERIZATION) -! - CALL CUMASTR_NEW & - (lq, km, km1, km-1, ZTP1, & - ZQP1, PUM1, PVM1, PVERV, ZQSAT, & - PQHFL, ZTMST, PAP, PAPH, PGEO, & - PTTE, PQTE, PVOM, PVOL, PRSFC, & - PSSFC, PAPRC, PAPRSM, PAPRS, LOCUM, & - KTYPE, ICBOT, ICTOP, ZTU, ZQU, & - ZLU, ZLUDE, ZMFU, ZMFD, ZRAIN, & - PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT, & - PCTE, PHHFL, RHO, sig1, lndj) -! -! TO INCLUDE THE CLOUD WATER AND CLOUD ICE DETRAINED FROM CONVECTION -! - IF(fdbk.ge.1.0e-9) THEN - DO 20 K=1,km - DO 20 j=1,lq - If(PCTE(j,k).GT.0.0) then - ZTPP1=pt(j,k)+PTTE(j,k)*ZTMST - if(ZTPP1.ge.t000) then +!* 2. call 'cumastr'(master-routine for cumulus parameterization) +! + call cumastr_new & + (lq, km, km1, km-1, ztp1, & + zqp1, pum1, pvm1, pverv, zqsat, & + pqhfl, ztmst, pap, paph, pgeo, & + ptte, pqte, pvom, pvol, prsfc, & + pssfc, paprc, paprsm, paprs, locum, & + ktype, icbot, ictop, ztu, zqu, & + zlu, zlude, zmfu, zmfd, zrain, & + psrain, psevap, psheat, psdiss, psmelt, & + pcte, sig1, lndj) +! +! to include the cloud water and cloud ice detrained from convection +! + if(fdbk.ge.1.0e-9) then + do k=1,km + do j=1,lq + if(pcte(j,k).gt.0.0) then + ztpp1=pt(j,k)+ptte(j,k)*ztmst + if(ztpp1.ge.t000) then fliq=1.0 - ZALF=0.0 - else if(ZTPP1.le.hgfr) then + zalf=0.0 + else if(ztpp1.le.hgfr) then fliq=0.0 - ZALF=ALF + zalf=alf else - ZTC=ZTPP1-t000 - fliq=0.0059+0.9941*exp(-0.003102*ZTC*ZTC) - ZALF=ALF + ztc=ztpp1-t000 + fliq=0.0059+0.9941*exp(-0.003102*ztc*ztc) + zalf=alf endif fice=1.0-fliq - pqc(j,k)=pqc(j,k)+fliq*PCTE(j,k)*ZTMST - pqi(j,k)=pqi(j,k)+fice*PCTE(j,k)*ZTMST - PTTE(j,k)=PTTE(j,k)-ZALF*RCPD*fliq*PCTE(j,k) - Endif - 20 CONTINUE - ENDIF -! - DO 75 k=1,km - DO 75 j=1,lq - pt(j,k)=ZTP1(j,k)+PTTE(j,k)*ZTMST - ZQP1(j,k)=ZQP1(j,k)+(PQTE(j,k)-ZQQ(j,k))*ZTMST - pqv(j,k)=ZQP1(j,k)/(1.0-ZQP1(j,k)) - 75 CONTINUE - DO 85 j=1,lq - zprecc(j)=amax1(0.0,(PRSFC(j)+PSSFC(j))*ZTMST) - 85 CONTINUE - IF (LMFDUDV) THEN - DO 100 k=1,km - DO 100 j=1,lq - pu(j,k)=pu(j,k)+PVOM(j,k)*ZTMST - pv(j,k)=pv(j,k)+PVOL(j,k)*ZTMST - 100 CONTINUE - ENDIF -! - RETURN - END SUBROUTINE TIECNV + pqc(j,k)=pqc(j,k)+fliq*pcte(j,k)*ztmst + pqi(j,k)=pqi(j,k)+fice*pcte(j,k)*ztmst + ptte(j,k)=ptte(j,k)-zalf*rcpd*fliq*pcte(j,k) + endif + end do + end do + endif +! + do k=1,km + do j=1,lq + pt(j,k)=ztp1(j,k)+ptte(j,k)*ztmst + zqp1(j,k)=zqp1(j,k)+(pqte(j,k)-zqq(j,k))*ztmst + pqv(j,k)=zqp1(j,k)/(1.0-zqp1(j,k)) + end do + end do + do j=1,lq + zprecc(j)=amax1(0.0,(prsfc(j)+pssfc(j))*ztmst) + end do + if (lmfdudv) then + do k=1,km + do j=1,lq + pu(j,k)=pu(j,k)+pvom(j,k)*ztmst + pv(j,k)=pv(j,k)+pvol(j,k)*ztmst + end do + end do + endif +! + return + end subroutine tiecnv !############################################################# ! -! LEVEL 2 SUBROUTINEs +! level 2 subroutines ! !############################################################# !*********************************************************** -! SUBROUTINE CUMASTR_NEW +! subroutine cumastr_new !*********************************************************** - SUBROUTINE CUMASTR_NEW & - (KLON, KLEV, KLEVP1, KLEVM1, PTEN, & - PQEN, PUEN, PVEN, PVERV, PQSEN, & - PQHFL, ZTMST, PAP, PAPH, PGEO, & - PTTE, PQTE, PVOM, PVOL, PRSFC, & - PSSFC, PAPRC, PAPRSM, PAPRS, LDCUM, & - KTYPE, KCBOT, KCTOP, PTU, PQU, & - PLU, PLUDE, PMFU, PMFD, PRAIN, & - PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT,& - PCTE, PHHFL, RHO, sig1, lndj) -! -!***CUMASTR* MASTER ROUTINE FOR CUMULUS MASSFLUX-SCHEME -! M.TIEDTKE E.C.M.W.F. 1986/1987/1989 -!***PURPOSE + subroutine cumastr_new & + (klon, klev, klevp1, klevm1, pten, & + pqen, puen, pven, pverv, pqsen, & + pqhfl, ztmst, pap, paph, pgeo, & + ptte, pqte, pvom, pvol, prsfc, & + pssfc, paprc, paprsm, paprs, ldcum, & + ktype, kcbot, kctop, ptu, pqu, & + plu, plude, pmfu, pmfd, prain, & + psrain, psevap, psheat, psdiss, psmelt,& + pcte, sig1, lndj) +! +!***cumastr* master routine for cumulus massflux-scheme +! m.tiedtke e.c.m.w.f. 1986/1987/1989 +!***purpose ! ------- -! THIS ROUTINE COMPUTES THE PHYSICAL TENDENCIES OF THE -! PROGNOSTIC VARIABLES T,Q,U AND V DUE TO CONVECTIVE PROCESSES. -! PROCESSES CONSIDERED ARE: CONVECTIVE FLUXES, FORMATION OF -! PRECIPITATION, EVAPORATION OF FALLING RAIN BELOW CLOUD BASE, -! SATURATED CUMULUS DOWNDRAFTS. -!***INTERFACE. +! this routine computes the physical tendencies of the +! prognostic variables t,q,u and v due to convective processes. +! processes considered are: convective fluxes, formation of +! precipitation, evaporation of falling rain below cloud base, +! saturated cumulus downdrafts. +!***interface. ! ---------- -! *CUMASTR* IS CALLED FROM *MSSFLX* -! THE ROUTINE TAKES ITS INPUT FROM THE LONG-TERM STORAGE -! T,Q,U,V,PHI AND P AND MOISTURE TENDENCIES. -! IT RETURNS ITS OUTPUT TO THE SAME SPACE -! 1.MODIFIED TENDENCIES OF MODEL VARIABLES -! 2.RATES OF CONVECTIVE PRECIPITATION -! (USED IN SUBROUTINE SURF) -! 3.CLOUD BASE, CLOUD TOP AND PRECIP FOR RADIATION -! (USED IN SUBROUTINE CLOUD) -!***METHOD +! *cumastr* is called from *mssflx* +! the routine takes its input from the long-term storage +! t,q,u,v,phi and p and moisture tendencies. +! it returns its output to the same space +! 1.modified tendencies of model variables +! 2.rates of convective precipitation +! (used in subroutine surf) +! 3.cloud base, cloud top and precip for radiation +! (used in subroutine cloud) +!***method ! ------ -! PARAMETERIZATION IS DONE USING A MASSFLUX-SCHEME. -! (1) DEFINE CONSTANTS AND PARAMETERS -! (2) SPECIFY VALUES (T,Q,QS...) AT HALF LEVELS AND -! INITIALIZE UPDRAFT- AND DOWNDRAFT-VALUES IN 'CUINI' -! (3) CALCULATE CLOUD BASE IN 'CUBASE' -! AND SPECIFY CLOUD BASE MASSFLUX FROM PBL MOISTURE BUDGET -! (4) DO CLOUD ASCENT IN 'CUASC' IN ABSENCE OF DOWNDRAFTS -! (5) DO DOWNDRAFT CALCULATIONS: -! (A) DETERMINE VALUES AT LFS IN 'CUDLFS' -! (B) DETERMINE MOIST DESCENT IN 'CUDDRAF' -! (C) RECALCULATE CLOUD BASE MASSFLUX CONSIDERING THE -! EFFECT OF CU-DOWNDRAFTS -! (6) DO FINAL CLOUD ASCENT IN 'CUASC' -! (7) DO FINAL ADJUSMENTS TO CONVECTIVE FLUXES IN 'CUFLX', -! DO EVAPORATION IN SUBCLOUD LAYER -! (8) CALCULATE INCREMENTS OF T AND Q IN 'CUDTDQ' -! (9) CALCULATE INCREMENTS OF U AND V IN 'CUDUDV' -!***EXTERNALS. +! parameterization is done using a massflux-scheme. +! (1) define constants and parameters +! (2) specify values (t,q,qs...) at half levels and +! initialize updraft- and downdraft-values in 'cuini' +! (3) calculate cloud base in 'cubase' +! and specify cloud base massflux from pbl moisture budget +! (4) do cloud ascent in 'cuasc' in absence of downdrafts +! (5) do downdraft calculations: +! (a) determine values at lfs in 'cudlfs' +! (b) determine moist descent in 'cuddraf' +! (c) recalculate cloud base massflux considering the +! effect of cu-downdrafts +! (6) do final cloud ascent in 'cuasc' +! (7) do final adjusments to convective fluxes in 'cuflx', +! do evaporation in subcloud layer +! (8) calculate increments of t and q in 'cudtdq' +! (9) calculate increments of u and v in 'cududv' +!***externals. ! ---------- -! CUINI: INITIALIZES VALUES AT VERTICAL GRID USED IN CU-PARAMETR. -! CUBASE: CLOUD BASE CALCULATION FOR PENETR.AND SHALLOW CONVECTION -! CUASC: CLOUD ASCENT FOR ENTRAINING PLUME -! CUDLFS: DETERMINES VALUES AT LFS FOR DOWNDRAFTS -! CUDDRAF:DOES MOIST DESCENT FOR CUMULUS DOWNDRAFTS -! CUFLX: FINAL ADJUSTMENTS TO CONVECTIVE FLUXES (ALSO IN PBL) -! CUDQDT: UPDATES TENDENCIES FOR T AND Q -! CUDUDV: UPDATES TENDENCIES FOR U AND V -!***SWITCHES. +! cuini: initializes values at vertical grid used in cu-parametr. +! cubase: cloud base calculation for penetr.and shallow convection +! cuasc: cloud ascent for entraining plume +! cudlfs: determines values at lfs for downdrafts +! cuddraf:does moist descent for cumulus downdrafts +! cuflx: final adjustments to convective fluxes (also in pbl) +! cudqdt: updates tendencies for t and q +! cududv: updates tendencies for u and v +!***switches. ! -------- -! LMFPEN=.T. PENETRATIVE CONVECTION IS SWITCHED ON -! LMFSCV=.T. SHALLOW CONVECTION IS SWITCHED ON -! LMFMID=.T. MIDLEVEL CONVECTION IS SWITCHED ON -! LMFDD=.T. CUMULUS DOWNDRAFTS SWITCHED ON -! LMFDUDV=.T. CUMULUS FRICTION SWITCHED ON +! lmfpen=.t. penetrative convection is switched on +! lmfscv=.t. shallow convection is switched on +! lmfmid=.t. midlevel convection is switched on +! lmfdd=.t. cumulus downdrafts switched on +! lmfdudv=.t. cumulus friction switched on !*** -! MODEL PARAMETERS (DEFINED IN SUBROUTINE CUPARAM) +! model parameters (defined in subroutine cuparam) ! ------------------------------------------------ -! ENTRPEN ENTRAINMENT RATE FOR PENETRATIVE CONVECTION -! ENTRSCV ENTRAINMENT RATE FOR SHALLOW CONVECTION -! ENTRMID ENTRAINMENT RATE FOR MIDLEVEL CONVECTION -! ENTRDD ENTRAINMENT RATE FOR CUMULUS DOWNDRAFTS -! CMFCTOP RELATIVE CLOUD MASSFLUX AT LEVEL ABOVE NONBUOYANCY -! LEVEL -! CMFCMAX MAXIMUM MASSFLUX VALUE ALLOWED FOR -! CMFCMIN MINIMUM MASSFLUX VALUE (FOR SAFETY) -! CMFDEPS FRACTIONAL MASSFLUX FOR DOWNDRAFTS AT LFS -! CPRCON COEFFICIENT FOR CONVERSION FROM CLOUD WATER TO RAIN -!***REFERENCE. +! entrpen entrainment rate for penetrative convection +! entrscv entrainment rate for shallow convection +! entrmid entrainment rate for midlevel convection +! entrdd entrainment rate for cumulus downdrafts +! cmfctop relative cloud massflux at level above nonbuoyancy +! level +! cmfcmax maximum massflux value allowed for +! cmfcmin minimum massflux value (for safety) +! cmfdeps fractional massflux for downdrafts at lfs +! cprcon coefficient for conversion from cloud water to rain +!***reference. ! ---------- -! PAPER ON MASSFLUX SCHEME (TIEDTKE,1989) +! paper on massflux scheme (tiedtke,1989) !----------------------------------------------------------------- !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER KLEVM1 - REAL ZTMST - REAL PSRAIN, PSEVAP, PSHEAT, PSDISS, PSMELT, ZCONS2 - INTEGER JK,JL,IKB - REAL ZQUMQE, ZDQMIN, ZMFMAX, ZALVDCP, ZQALV - REAL ZHSAT, ZGAM, ZZZ, ZHHAT, ZBI, ZRO, ZDZ, ZDHDZ, ZDEPTH - REAL ZFAC, ZRH, ZPBMPT, DEPT, ZHT, ZEPS - INTEGER ICUM, ITOPM2 - REAL PTEN(KLON,KLEV), PQEN(KLON,KLEV), & - PUEN(KLON,KLEV), PVEN(KLON,KLEV), & - PTTE(KLON,KLEV), PQTE(KLON,KLEV), & - PVOM(KLON,KLEV), PVOL(KLON,KLEV), & - PQSEN(KLON,KLEV), PGEO(KLON,KLEV), & - PAP(KLON,KLEV), PAPH(KLON,KLEVP1),& - PVERV(KLON,KLEV), PQHFL(KLON), & - PHHFL(KLON), RHO(KLON) - REAL PTU(KLON,KLEV), PQU(KLON,KLEV), & - PLU(KLON,KLEV), PLUDE(KLON,KLEV), & - PMFU(KLON,KLEV), PMFD(KLON,KLEV), & - PAPRC(KLON), PAPRS(KLON), & - PAPRSM(KLON), PRAIN(KLON), & - PRSFC(KLON), PSSFC(KLON) - REAL ZTENH(KLON,KLEV), ZQENH(KLON,KLEV),& - ZGEOH(KLON,KLEV), ZQSENH(KLON,KLEV),& - ZTD(KLON,KLEV), ZQD(KLON,KLEV), & - ZMFUS(KLON,KLEV), ZMFDS(KLON,KLEV), & - ZMFUQ(KLON,KLEV), ZMFDQ(KLON,KLEV), & - ZDMFUP(KLON,KLEV), ZDMFDP(KLON,KLEV),& - ZMFUL(KLON,KLEV), ZRFL(KLON), & - ZUU(KLON,KLEV), ZVU(KLON,KLEV), & - ZUD(KLON,KLEV), ZVD(KLON,KLEV) - REAL ZENTR(KLON), ZHCBASE(KLON), & - ZMFUB(KLON), ZMFUB1(KLON), & - ZDQPBL(KLON), ZDQCV(KLON) - REAL ZSFL(KLON), ZDPMEL(KLON,KLEV), & - PCTE(KLON,KLEV), ZCAPE(KLON), & - ZHEAT(KLON), ZHHATT(KLON,KLEV), & - ZHMIN(KLON), ZRELH(KLON) - REAL sig1(KLEV) - INTEGER ILAB(KLON,KLEV), IDTOP(KLON), & - ICTOP0(KLON), ILWMIN(KLON) - INTEGER KCBOT(KLON), KCTOP(KLON), & - KTYPE(KLON), IHMIN(KLON), & - KTOP0, lndj(KLON) - LOGICAL LDCUM(KLON) - LOGICAL LODDRAF(KLON), LLO1 - REAL CRIRH1 + integer klon, klev, klevp1 + integer klevm1 + real ztmst + real psrain, psevap, psheat, psdiss, psmelt, zcons2 + integer jk,jl,ikb + real zqumqe, zdqmin, zmfmax, zalvdcp, zqalv + real zhsat, zgam, zzz, zhhat, zbi, zro, zdz, zdhdz, zdepth + real zfac, zrh, zpbmpt, dept, zht, zeps + integer icum, itopm2 + real pten(klon,klev), pqen(klon,klev), & + puen(klon,klev), pven(klon,klev), & + ptte(klon,klev), pqte(klon,klev), & + pvom(klon,klev), pvol(klon,klev), & + pqsen(klon,klev), pgeo(klon,klev), & + pap(klon,klev), paph(klon,klevp1),& + pverv(klon,klev), pqhfl(klon) + real ptu(klon,klev), pqu(klon,klev), & + plu(klon,klev), plude(klon,klev), & + pmfu(klon,klev), pmfd(klon,klev), & + paprc(klon), paprs(klon), & + paprsm(klon), prain(klon), & + prsfc(klon), pssfc(klon) + real ztenh(klon,klev), zqenh(klon,klev),& + zgeoh(klon,klev), zqsenh(klon,klev),& + ztd(klon,klev), zqd(klon,klev), & + zmfus(klon,klev), zmfds(klon,klev), & + zmfuq(klon,klev), zmfdq(klon,klev), & + zdmfup(klon,klev), zdmfdp(klon,klev),& + zmful(klon,klev), zrfl(klon), & + zuu(klon,klev), zvu(klon,klev), & + zud(klon,klev), zvd(klon,klev) + real zentr(klon), zhcbase(klon), & + zmfub(klon), zmfub1(klon), & + zdqpbl(klon), zdqcv(klon) + real zsfl(klon), zdpmel(klon,klev), & + pcte(klon,klev), zcape(klon), & + zheat(klon), zhhatt(klon,klev), & + zhmin(klon), zrelh(klon) + real sig1(klev) + integer ilab(klon,klev), idtop(klon), & + ictop0(klon), ilwmin(klon) + integer kcbot(klon), kctop(klon), & + ktype(klon), ihmin(klon), & + ktop0, lndj(klon) + logical ldcum(klon) + logical loddraf(klon), llo1 !------------------------------------------- -! 1. SPECIFY CONSTANTS AND PARAMETERS +! 1. specify constants and parameters !------------------------------------------- - 100 CONTINUE - ZCONS2=1./(G*ZTMST) + zcons2=1./(g*ztmst) !-------------------------------------------------------------- -!* 2. INITIALIZE VALUES AT VERTICAL GRID POINTS IN 'CUINI' +!* 2. initialize values at vertical grid points in 'cuini' !-------------------------------------------------------------- - 200 CONTINUE - CALL CUINI & - (KLON, KLEV, KLEVP1, KLEVM1, PTEN, & - PQEN, PQSEN, PUEN, PVEN, PVERV, & - PGEO, PAPH, ZGEOH, ZTENH, ZQENH, & - ZQSENH, ILWMIN, PTU, PQU, ZTD, & - ZQD, ZUU, ZVU, ZUD, ZVD, & - PMFU, PMFD, ZMFUS, ZMFDS, ZMFUQ, & - ZMFDQ, ZDMFUP, ZDMFDP, ZDPMEL, PLU, & - PLUDE, ILAB) + call cuini & + (klon, klev, klevp1, klevm1, pten, & + pqen, pqsen, puen, pven, pverv, & + pgeo, paph, zgeoh, ztenh, zqenh, & + zqsenh, ilwmin, ptu, pqu, ztd, & + zqd, zuu, zvu, zud, zvd, & + pmfu, pmfd, zmfus, zmfds, zmfuq, & + zmfdq, zdmfup, zdmfdp, zdpmel, plu, & + plude, ilab) !---------------------------------- -!* 3.0 CLOUD BASE CALCULATIONS +!* 3.0 cloud base calculations !---------------------------------- - 300 CONTINUE -!* (A) DETERMINE CLOUD BASE VALUES IN 'CUBASE' +!* (a) determine cloud base values in 'cubase' ! ------------------------------------------- - CALL CUBASE & - (KLON, KLEV, KLEVP1, KLEVM1, ZTENH, & - ZQENH, ZGEOH, PAPH, PTU, PQU, & - PLU, PUEN, PVEN, ZUU, ZVU, & - LDCUM, KCBOT, ILAB) -!* (B) DETERMINE TOTAL MOISTURE CONVERGENCE AND -!* THEN DECIDE ON TYPE OF CUMULUS CONVECTION + call cubase & + (klon, klev, klevp1, klevm1, ztenh, & + zqenh, zgeoh, paph, ptu, pqu, & + plu, puen, pven, zuu, zvu, & + ldcum, kcbot, ilab) +!* (b) determine total moisture convergence and +!* then decide on type of cumulus convection ! ----------------------------------------- - JK=1 - DO 310 JL=1,KLON - ZDQCV(JL) =PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK)) - ZDQPBL(JL)=0.0 - IDTOP(JL)=0 - 310 CONTINUE - DO 320 JK=2,KLEV - DO 315 JL=1,KLON - ZDQCV(JL)=ZDQCV(JL)+PQTE(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK)) - IF(JK.GE.KCBOT(JL)) ZDQPBL(JL)=ZDQPBL(JL)+PQTE(JL,JK) & - *(PAPH(JL,JK+1)-PAPH(JL,JK)) - 315 CONTINUE - 320 CONTINUE - - if(cutrigger .eq. 1) then - DO JL=1,KLON - KTYPE(JL)=0 - IF(ZDQCV(JL).GT.MAX(0.,1.1*PQHFL(JL)*G)) THEN - KTYPE(JL)=1 - ELSE - KTYPE(JL)=2 - ENDIF - END DO - else if(cutrigger .eq. 2) then - CALL CUTYPE & - ( KLON, KLEV, KLEVP1, KLEVM1, & - ZTENH, ZQENH, ZQSENH, ZGEOH, PAPH, & - RHO, PHHFL, PQHFL, KTYPE, lndj ) - end if -!* (C) DETERMINE MOISTURE SUPPLY FOR BOUNDARY LAYER -!* AND DETERMINE CLOUD BASE MASSFLUX IGNORING -!* THE EFFECTS OF DOWNDRAFTS AT THIS STAGE + jk=1 + do jl=1,klon + zdqcv(jl) =pqte(jl,jk)*(paph(jl,jk+1)-paph(jl,jk)) + zdqpbl(jl)=0.0 + idtop(jl)=0 + end do + + do jk=2,klev + do jl=1,klon + zdqcv(jl)=zdqcv(jl)+pqte(jl,jk)*(paph(jl,jk+1)-paph(jl,jk)) + if(jk.ge.kcbot(jl)) zdqpbl(jl)=zdqpbl(jl)+pqte(jl,jk) & + *(paph(jl,jk+1)-paph(jl,jk)) + end do + end do + + do jl=1,klon + ktype(jl)=0 + if(zdqcv(jl).gt.max(0.,1.1*pqhfl(jl)*g)) then + ktype(jl)=1 + else + ktype(jl)=2 + endif + +!* (c) determine moisture supply for boundary layer +!* and determine cloud base massflux ignoring +!* the effects of downdrafts at this stage ! ------------------------------------------ -! do jl=1,klon -! if(ktype(jl) .ge. 1 ) then -! write(6,*)"ktype=", KTYPE(jl) -! end if -! end do - - DO 340 JL=1,KLON - IKB=KCBOT(JL) - ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)-ZQENH(JL,IKB) - ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10) - IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL)) THEN - ZMFUB(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN)) - ELSE - ZMFUB(JL)=0.01 - LDCUM(JL)=.FALSE. - ENDIF - ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2 - ZMFUB(JL)=MIN(ZMFUB(JL),ZMFMAX) + ikb=kcbot(jl) + zqumqe=pqu(jl,ikb)+plu(jl,ikb)-zqenh(jl,ikb) + zdqmin=max(0.01*zqenh(jl,ikb),1.e-10) + if(zdqpbl(jl).gt.0..and.zqumqe.gt.zdqmin.and.ldcum(jl)) then + zmfub(jl)=zdqpbl(jl)/(g*max(zqumqe,zdqmin)) + else + zmfub(jl)=0.01 + ldcum(jl)=.false. + endif + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + zmfub(jl)=min(zmfub(jl),zmfmax) !------------------------------------------------------ -!* 4.0 DETERMINE CLOUD ASCENT FOR ENTRAINING PLUME +!* 4.0 determine cloud ascent for entraining plume !------------------------------------------------------ - 400 CONTINUE -!* (A) ESTIMATE CLOUD HEIGHT FOR ENTRAINMENT/DETRAINMENT -!* CALCULATIONS IN CUASC (MAX.POSSIBLE CLOUD HEIGHT -!* FOR NON-ENTRAINING PLUME, FOLLOWING A.-S.,1974) +!* (a) estimate cloud height for entrainment/detrainment +!* calculations in cuasc (max.possible cloud height +!* for non-entraining plume, following a.-s.,1974) ! ------------------------------------------------------------- - IKB=KCBOT(JL) - ZHCBASE(JL)=CPD*PTU(JL,IKB)+ZGEOH(JL,IKB)+ALV*PQU(JL,IKB) - ICTOP0(JL)=KCBOT(JL)-1 - 340 CONTINUE - ZALVDCP=ALV/CPD - ZQALV=1./ALV - DO 420 JK=KLEVM1,3,-1 - DO 420 JL=1,KLON - ZHSAT=CPD*ZTENH(JL,JK)+ZGEOH(JL,JK)+ALV*ZQSENH(JL,JK) - ZGAM=C5LES*ZALVDCP*ZQSENH(JL,JK)/ & - ((1.-VTMPC1*ZQSENH(JL,JK))*(ZTENH(JL,JK)-C4LES)**2) - ZZZ=CPD*ZTENH(JL,JK)*0.608 - ZHHAT=ZHSAT-(ZZZ+ZGAM*ZZZ)/(1.+ZGAM*ZZZ*ZQALV)* & - MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.) - ZHHATT(JL,JK)=ZHHAT - IF(JK.LT.ICTOP0(JL).AND.ZHCBASE(JL).GT.ZHHAT) ICTOP0(JL)=JK - 420 CONTINUE - DO 430 JL=1,KLON - JK=KCBOT(JL) - ZHSAT=CPD*ZTENH(JL,JK)+ZGEOH(JL,JK)+ALV*ZQSENH(JL,JK) - ZGAM=C5LES*ZALVDCP*ZQSENH(JL,JK)/ & - ((1.-VTMPC1*ZQSENH(JL,JK))*(ZTENH(JL,JK)-C4LES)**2) - ZZZ=CPD*ZTENH(JL,JK)*0.608 - ZHHAT=ZHSAT-(ZZZ+ZGAM*ZZZ)/(1.+ZGAM*ZZZ*ZQALV)* & - MAX(ZQSENH(JL,JK)-ZQENH(JL,JK),0.) - ZHHATT(JL,JK)=ZHHAT - 430 CONTINUE -! -! Find lowest possible org. detrainment level -! - DO 440 JL = 1, KLON - ZHMIN(JL) = 0. - IF( LDCUM(JL).AND.KTYPE(JL).EQ.1 ) THEN - IHMIN(JL) = KCBOT(JL) - ELSE - IHMIN(JL) = -1 - END IF - 440 CONTINUE -! - ZBI = 1./(25.*G) - DO 450 JK = KLEV, 1, -1 - DO 450 JL = 1, KLON - LLO1 = LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.IHMIN(JL).EQ.KCBOT(JL) - IF (LLO1.AND.JK.LT.KCBOT(JL).AND.JK.GE.ICTOP0(JL)) THEN - IKB = KCBOT(JL) - ZRO = RD*ZTENH(JL,JK)/(G*PAPH(JL,JK)) - ZDZ = (PAPH(JL,JK)-PAPH(JL,JK-1))*ZRO - ZDHDZ=(CPD*(PTEN(JL,JK-1)-PTEN(JL,JK))+ALV*(PQEN(JL,JK-1)- & - PQEN(JL,JK))+(PGEO(JL,JK-1)-PGEO(JL,JK)))*G/(PGEO(JL, & - JK-1)-PGEO(JL,JK)) - ZDEPTH = ZGEOH(JL,JK) - ZGEOH(JL,IKB) - ZFAC = SQRT(1.+ZDEPTH*ZBI) - ZHMIN(JL) = ZHMIN(JL) + ZDHDZ*ZFAC*ZDZ - ZRH = -ALV*(ZQSENH(JL,JK)-ZQENH(JL,JK))*ZFAC - IF (ZHMIN(JL).GT.ZRH) IHMIN(JL) = JK - END IF - 450 CONTINUE - DO 460 JL = 1, KLON - IF (LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN - IF (IHMIN(JL).LT.ICTOP0(JL)) IHMIN(JL) = ICTOP0(JL) - END IF - IF(KTYPE(JL).EQ.1) THEN - ZENTR(JL)=ENTRPEN - ELSE - ZENTR(JL)=ENTRSCV - ENDIF - if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.05 - 460 CONTINUE -!* (B) DO ASCENT IN 'CUASC'IN ABSENCE OF DOWNDRAFTS + ikb=kcbot(jl) + zhcbase(jl)=cpd*ptu(jl,ikb)+zgeoh(jl,ikb)+alv*pqu(jl,ikb) + ictop0(jl)=kcbot(jl)-1 + end do + + zalvdcp=alv/cpd + zqalv=1./alv + do jk=klevm1,3,-1 + do jl=1,klon + zhsat=cpd*ztenh(jl,jk)+zgeoh(jl,jk)+alv*zqsenh(jl,jk) + zgam=c5les*zalvdcp*zqsenh(jl,jk)/ & + ((1.-vtmpc1*zqsenh(jl,jk))*(ztenh(jl,jk)-c4les)**2) + zzz=cpd*ztenh(jl,jk)*0.608 + zhhat=zhsat-(zzz+zgam*zzz)/(1.+zgam*zzz*zqalv)* & + max(zqsenh(jl,jk)-zqenh(jl,jk),0.) + zhhatt(jl,jk)=zhhat + if(jk.lt.ictop0(jl).and.zhcbase(jl).gt.zhhat) ictop0(jl)=jk + end do + end do + + do jl=1,klon + jk=kcbot(jl) + zhsat=cpd*ztenh(jl,jk)+zgeoh(jl,jk)+alv*zqsenh(jl,jk) + zgam=c5les*zalvdcp*zqsenh(jl,jk)/ & + ((1.-vtmpc1*zqsenh(jl,jk))*(ztenh(jl,jk)-c4les)**2) + zzz=cpd*ztenh(jl,jk)*0.608 + zhhat=zhsat-(zzz+zgam*zzz)/(1.+zgam*zzz*zqalv)* & + max(zqsenh(jl,jk)-zqenh(jl,jk),0.) + zhhatt(jl,jk)=zhhat + end do +! +! find lowest possible org. detrainment level +! + do jl = 1, klon + zhmin(jl) = 0. + if( ldcum(jl).and.ktype(jl).eq.1 ) then + ihmin(jl) = kcbot(jl) + else + ihmin(jl) = -1 + end if + end do +! + zbi = 1./(25.*g) + do jk = klev, 1, -1 + do jl = 1, klon + llo1 = ldcum(jl).and.ktype(jl).eq.1.and.ihmin(jl).eq.kcbot(jl) + if (llo1.and.jk.lt.kcbot(jl).and.jk.ge.ictop0(jl)) then + ikb = kcbot(jl) + zro = rd*ztenh(jl,jk)/(g*paph(jl,jk)) + zdz = (paph(jl,jk)-paph(jl,jk-1))*zro + zdhdz=(cpd*(pten(jl,jk-1)-pten(jl,jk))+alv*(pqen(jl,jk-1)- & + pqen(jl,jk))+(pgeo(jl,jk-1)-pgeo(jl,jk)))*g/(pgeo(jl, & + jk-1)-pgeo(jl,jk)) + zdepth = zgeoh(jl,jk) - zgeoh(jl,ikb) + zfac = sqrt(1.+zdepth*zbi) + zhmin(jl) = zhmin(jl) + zdhdz*zfac*zdz + zrh = -alv*(zqsenh(jl,jk)-zqenh(jl,jk))*zfac + if (zhmin(jl).gt.zrh) ihmin(jl) = jk + end if + end do + end do + + do jl = 1, klon + if (ldcum(jl).and.ktype(jl).eq.1) then + if (ihmin(jl).lt.ictop0(jl)) ihmin(jl) = ictop0(jl) + end if + if(ktype(jl).eq.1) then + zentr(jl)=entrpen + else + zentr(jl)=entrscv + endif + if(lndj(jl).eq.1) zentr(jl)=zentr(jl)*1.1 + end do +!* (b) do ascent in 'cuasc'in absence of downdrafts !---------------------------------------------------------- - CALL CUASC_NEW & - (KLON, KLEV, KLEVP1, KLEVM1, ZTENH, & - ZQENH, PUEN, PVEN, PTEN, PQEN, & - PQSEN, PGEO, ZGEOH, PAP, PAPH, & - PQTE, PVERV, ILWMIN, LDCUM, ZHCBASE, & - KTYPE, ILAB, PTU, PQU, PLU, & - ZUU, ZVU, PMFU, ZMFUB, ZENTR, & - ZMFUS, ZMFUQ, ZMFUL, PLUDE, ZDMFUP, & - KCBOT, KCTOP, ICTOP0, ICUM, ZTMST, & - IHMIN, ZHHATT, ZQSENH) - IF(ICUM.EQ.0) GO TO 1000 -!* (C) CHECK CLOUD DEPTH AND CHANGE ENTRAINMENT RATE ACCORDINGLY -! CALCULATE PRECIPITATION RATE (FOR DOWNDRAFT CALCULATION) + call cuasc_new & + (klon, klev, klevp1, klevm1, ztenh, & + zqenh, puen, pven, pten, pqen, & + pqsen, pgeo, zgeoh, pap, paph, & + pqte, pverv, ilwmin, ldcum, zhcbase, & + ktype, ilab, ptu, pqu, plu, & + zuu, zvu, pmfu, zmfub, zentr, & + zmfus, zmfuq, zmful, plude, zdmfup, & + kcbot, kctop, ictop0, icum, ztmst, & + ihmin, zhhatt, zqsenh) + if(icum.eq.0) return +!* (c) check cloud depth and change entrainment rate accordingly +! calculate precipitation rate (for downdraft calculation) !------------------------------------------------------------------ - DO 480 JL=1,KLON - ZPBMPT=PAPH(JL,KCBOT(JL))-PAPH(JL,KCTOP(JL)) - IF(LDCUM(JL)) ICTOP0(JL)=KCTOP(JL) - IF(LDCUM(JL).AND.KTYPE(JL).EQ.1.AND.ZPBMPT.LT.ZDNOPRC) KTYPE(JL)=2 - IF(KTYPE(JL).EQ.2) then - ZENTR(JL)=ENTRSCV - if(lndj(JL).eq.1) ZENTR(JL)=ZENTR(JL)*1.05 + do jl=1,klon + zpbmpt=paph(jl,kcbot(jl))-paph(jl,kctop(jl)) + if(ldcum(jl)) ictop0(jl)=kctop(jl) + if(ldcum(jl).and.ktype(jl).eq.1.and.zpbmpt.lt.zdnoprc) ktype(jl)=2 + if(ktype(jl).eq.2) then + zentr(jl)=entrscv + if(lndj(jl).eq.1) zentr(jl)=zentr(jl)*1.1 endif - ZRFL(JL)=ZDMFUP(JL,1) - 480 CONTINUE - DO 490 JK=2,KLEV - DO 490 JL=1,KLON - ZRFL(JL)=ZRFL(JL)+ZDMFUP(JL,JK) - 490 CONTINUE + zrfl(jl)=zdmfup(jl,1) + end do + + do jk=2,klev + do jl=1,klon + zrfl(jl)=zrfl(jl)+zdmfup(jl,jk) + end do + end do !----------------------------------------- -!* 5.0 CUMULUS DOWNDRAFT CALCULATIONS +!* 5.0 cumulus downdraft calculations !----------------------------------------- - 500 CONTINUE - IF(LMFDD) THEN -!* (A) DETERMINE LFS IN 'CUDLFS' + if(lmfdd) then +!* (a) determine lfs in 'cudlfs' !-------------------------------------- - CALL CUDLFS & - (KLON, KLEV, KLEVP1, ZTENH, ZQENH, & - PUEN, PVEN, ZGEOH, PAPH, PTU, & - PQU, ZUU, ZVU, LDCUM, KCBOT, & - KCTOP, ZMFUB, ZRFL, ZTD, ZQD, & - ZUD, ZVD, PMFD, ZMFDS, ZMFDQ, & - ZDMFDP, IDTOP, LODDRAF) -!* (B) DETERMINE DOWNDRAFT T,Q AND FLUXES IN 'CUDDRAF' + call cudlfs & + (klon, klev, klevp1, ztenh, zqenh, & + puen, pven, zgeoh, paph, ptu, & + pqu, zuu, zvu, ldcum, kcbot, & + kctop, zmfub, zrfl, ztd, zqd, & + zud, zvd, pmfd, zmfds, zmfdq, & + zdmfdp, idtop, loddraf) +!* (b) determine downdraft t,q and fluxes in 'cuddraf' !------------------------------------------------------------ - CALL CUDDRAF & - (KLON, KLEV, KLEVP1, ZTENH, ZQENH, & - PUEN, PVEN, ZGEOH, PAPH, ZRFL, & - LODDRAF, ZTD, ZQD, ZUD, ZVD, & - PMFD, ZMFDS, ZMFDQ, ZDMFDP) -!* (C) RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF -! DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET + call cuddraf & + (klon, klev, klevp1, ztenh, zqenh, & + puen, pven, zgeoh, paph, zrfl, & + loddraf, ztd, zqd, zud, zvd, & + pmfd, zmfds, zmfdq, zdmfdp) +!* (c) recalculate convective fluxes due to effect of +! downdrafts on boundary layer moisture budget !----------------------------------------------------------- - END IF + end if ! -!-- 5.1 Recalculate cloud base massflux from a cape closure -! for deep convection (ktype=1) and by PBL equilibrium +!-- 5.1 recalculate cloud base massflux from a cape closure +! for deep convection (ktype=1) and by pbl equilibrium ! taking downdrafts into account for shallow convection ! (ktype=2) -! implemented by Y. WANG based on ECHAM4 in Nov. 2001. -! - DO 510 JL=1,KLON - ZHEAT(JL)=0.0 - ZCAPE(JL)=0.0 - ZRELH(JL)=0.0 - ZMFUB1(JL)=ZMFUB(JL) - 510 CONTINUE -! - DO 511 JL=1,KLON - IF(LDCUM(JL).AND.KTYPE(JL).EQ.1) THEN - do jk=KLEVM1,2,-1 - if(abs(paph(jl,jk)*0.01 - 300) .lt. 50.) then - KTOP0=MAX(jk,KCTOP(JL)) - exit - end if +! implemented by y. wang based on echam4 in nov. 2001. +! + do jl=1,klon + zheat(jl)=0.0 + zcape(jl)=0.0 + zrelh(jl)=0.0 + zmfub1(jl)=zmfub(jl) end do -! KTOP0=MAX(12,KCTOP(JL)) - DO JK=2,KLEV - IF(JK.LE.KCBOT(JL).AND.JK.GT.KCTOP(JL)) THEN - ZRO=PAPH(JL,JK)/(RD*ZTENH(JL,JK)) - ZDZ=(PAPH(JL,JK)-PAPH(JL,JK-1))/(G*ZRO) - ZHEAT(JL)=ZHEAT(JL)+((PTEN(JL,JK-1)-PTEN(JL,JK) & - +G*ZDZ/CPD)/ZTENH(JL,JK)+0.608*(PQEN(JL,JK-1)- & - PQEN(JL,JK)))*(PMFU(JL,JK)+PMFD(JL,JK))*G/ZRO - ZCAPE(JL)=ZCAPE(JL)+G*((PTU(JL,JK)*(1.+.608*PQU(JL,JK) & - -PLU(JL,JK)))/(ZTENH(JL,JK)*(1.+.608*ZQENH(JL,JK))) & - -1.0)*ZDZ - ENDIF - IF(JK.LE.KCBOT(JL).AND.JK.GT.KTOP0) THEN - dept=(PAPH(JL,JK)-PAPH(JL,JK-1))/(PAPH(JL,KCBOT(JL))- & - PAPH(JL,KTOP0)) - ZRELH(JL)=ZRELH(JL)+dept*PQEN(JL,JK)/PQSEN(JL,JK) - ENDIF - ENDDO -! - - if(cutrigger .eq. 1 ) then - IF(lndj(JL).EQ.1) then - CRIRH1=CRIRH*0.8 - ELSE - CRIRH1=CRIRH - ENDIF +! + do jl=1,klon + if(ldcum(jl).and.ktype(jl).eq.1) then + ktop0=max(12,kctop(jl)) + ikb = kcbot(jl) + do jk=2,klev + if(jk.le.kcbot(jl).and.jk.gt.kctop(jl)) then + zro=paph(jl,jk)/(rd*ztenh(jl,jk)) + zdz=(paph(jl,jk)-paph(jl,jk-1))/(g*zro) + zheat(jl)=zheat(jl)+((pten(jl,jk-1)-pten(jl,jk) & + +g*zdz/cpd)/ztenh(jl,jk)+0.608*(pqen(jl,jk-1)- & + pqen(jl,jk)))*(pmfu(jl,jk)+pmfd(jl,jk))*g/zro + zcape(jl)=zcape(jl)+g*((ptu(jl,jk)*(1.+.608*pqu(jl,jk) & + -plu(jl,jk)))/(ztenh(jl,jk)*(1.+.608*zqenh(jl,jk))) & + -1.0)*zdz + endif + if(jk.le.kcbot(jl).and.jk.gt.ktop0) then + dept=(paph(jl,jk+1)-paph(jl,jk))/(paph(jl,ikb+1)- & + paph(jl,ktop0+1)) + zrelh(jl)=zrelh(jl)+dept*pqen(jl,jk)/pqsen(jl,jk) + endif + enddo +! + if(zrelh(jl).ge.crirh) then + zht=max(0.0,(zcape(jl)-0.0))/(ztau*zheat(jl)) + zmfub1(jl)=max(zmfub(jl)*zht,0.01) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + zmfub1(jl)=min(zmfub1(jl),zmfmax) else - CRIRH1=0. - end if - - IF(ZRELH(JL).GE.CRIRH1 .AND. ZCAPE(JL) .GT. 100.) THEN - IKB=KCBOT(JL) - ZHT=ZCAPE(JL)/(ZTAU*ZHEAT(JL)) - ZMFUB1(JL)=MAX(ZMFUB(JL)*ZHT,0.01) - ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2 - ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX) - ELSE - ZMFUB1(JL)=0.01 - ZMFUB(JL)=0.01 - LDCUM(JL)=.FALSE. - ENDIF - ENDIF - 511 CONTINUE -! -!* 5.2 RECALCULATE CONVECTIVE FLUXES DUE TO EFFECT OF -! DOWNDRAFTS ON BOUNDARY LAYER MOISTURE BUDGET + zmfub1(jl)=0.01 + zmfub(jl)=0.01 + ldcum(jl)=.false. + endif + endif + end do +! +!* 5.2 recalculate convective fluxes due to effect of +! downdrafts on boundary layer moisture budget !-------------------------------------------------------- - DO 512 JL=1,KLON - IF(KTYPE(JL).NE.1) THEN - IKB=KCBOT(JL) - IF(PMFD(JL,IKB).LT.0.0.AND.LODDRAF(JL)) THEN - ZEPS=CMFDEPS - ELSE - ZEPS=0. - ENDIF - ZQUMQE=PQU(JL,IKB)+PLU(JL,IKB)- & - ZEPS*ZQD(JL,IKB)-(1.-ZEPS)*ZQENH(JL,IKB) - ZDQMIN=MAX(0.01*ZQENH(JL,IKB),1.E-10) - ZMFMAX=(PAPH(JL,IKB)-PAPH(JL,IKB-1))*ZCONS2 - IF(ZDQPBL(JL).GT.0..AND.ZQUMQE.GT.ZDQMIN.AND.LDCUM(JL) & - .AND.ZMFUB(JL).LT.ZMFMAX) THEN - ZMFUB1(JL)=ZDQPBL(JL)/(G*MAX(ZQUMQE,ZDQMIN)) - ELSE - ZMFUB1(JL)=ZMFUB(JL) - ENDIF - LLO1=(KTYPE(JL).EQ.2).AND.ABS(ZMFUB1(JL) & - -ZMFUB(JL)).LT.0.2*ZMFUB(JL) - IF(.NOT.LLO1) ZMFUB1(JL)=ZMFUB(JL) - ZMFUB1(JL)=MIN(ZMFUB1(JL),ZMFMAX) - END IF - 512 CONTINUE - DO 530 JK=1,KLEV - DO 530 JL=1,KLON - IF(LDCUM(JL)) THEN - ZFAC=ZMFUB1(JL)/MAX(ZMFUB(JL),1.E-10) - PMFD(JL,JK)=PMFD(JL,JK)*ZFAC - ZMFDS(JL,JK)=ZMFDS(JL,JK)*ZFAC - ZMFDQ(JL,JK)=ZMFDQ(JL,JK)*ZFAC - ZDMFDP(JL,JK)=ZDMFDP(JL,JK)*ZFAC - ELSE - PMFD(JL,JK)=0.0 - ZMFDS(JL,JK)=0.0 - ZMFDQ(JL,JK)=0.0 - ZDMFDP(JL,JK)=0.0 - ENDIF - 530 CONTINUE - DO 538 JL=1,KLON - IF(LDCUM(JL)) THEN - ZMFUB(JL)=ZMFUB1(JL) - ELSE - ZMFUB(JL)=0.0 - ENDIF - 538 CONTINUE + do jl=1,klon + if(ktype(jl).ne.1) then + ikb=kcbot(jl) + if(pmfd(jl,ikb).lt.0.0.and.loddraf(jl)) then + zeps=cmfdeps + else + zeps=0. + endif + zqumqe=pqu(jl,ikb)+plu(jl,ikb)- & + zeps*zqd(jl,ikb)-(1.-zeps)*zqenh(jl,ikb) + zdqmin=max(0.01*zqenh(jl,ikb),1.e-10) + zmfmax=(paph(jl,ikb)-paph(jl,ikb-1))*zcons2 + if(zdqpbl(jl).gt.0..and.zqumqe.gt.zdqmin.and.ldcum(jl) & + .and.zmfub(jl).lt.zmfmax) then + zmfub1(jl)=zdqpbl(jl)/(g*max(zqumqe,zdqmin)) + else + zmfub1(jl)=zmfub(jl) + endif + llo1=(ktype(jl).eq.2).and.abs(zmfub1(jl) & + -zmfub(jl)).lt.0.2*zmfub(jl) + if(.not.llo1) zmfub1(jl)=zmfub(jl) + zmfub1(jl)=min(zmfub1(jl),zmfmax) + end if + end do + + do jk=1,klev + do jl=1,klon + if(ldcum(jl)) then + zfac=zmfub1(jl)/max(zmfub(jl),1.e-10) + pmfd(jl,jk)=pmfd(jl,jk)*zfac + zmfds(jl,jk)=zmfds(jl,jk)*zfac + zmfdq(jl,jk)=zmfdq(jl,jk)*zfac + zdmfdp(jl,jk)=zdmfdp(jl,jk)*zfac + else + pmfd(jl,jk)=0.0 + zmfds(jl,jk)=0.0 + zmfdq(jl,jk)=0.0 + zdmfdp(jl,jk)=0.0 + endif + end do + end do + + do jl=1,klon + if(ldcum(jl)) then + zmfub(jl)=zmfub1(jl) + else + zmfub(jl)=0.0 + endif + end do ! !--------------------------------------------------------------- -!* 6.0 DETERMINE FINAL CLOUD ASCENT FOR ENTRAINING PLUME -!* FOR PENETRATIVE CONVECTION (TYPE=1), -!* FOR SHALLOW TO MEDIUM CONVECTION (TYPE=2) -!* AND FOR MID-LEVEL CONVECTION (TYPE=3). +!* 6.0 determine final cloud ascent for entraining plume +!* for penetrative convection (type=1), +!* for shallow to medium convection (type=2) +!* and for mid-level convection (type=3). !--------------------------------------------------------------- - 600 CONTINUE - CALL CUASC_NEW & - (KLON, KLEV, KLEVP1, KLEVM1, ZTENH, & - ZQENH, PUEN, PVEN, PTEN, PQEN, & - PQSEN, PGEO, ZGEOH, PAP, PAPH, & - PQTE, PVERV, ILWMIN, LDCUM, ZHCBASE,& - KTYPE, ILAB, PTU, PQU, PLU, & - ZUU, ZVU, PMFU, ZMFUB, ZENTR, & - ZMFUS, ZMFUQ, ZMFUL, PLUDE, ZDMFUP, & - KCBOT, KCTOP, ICTOP0, ICUM, ZTMST, & - IHMIN, ZHHATT, ZQSENH) + call cuasc_new & + (klon, klev, klevp1, klevm1, ztenh, & + zqenh, puen, pven, pten, pqen, & + pqsen, pgeo, zgeoh, pap, paph, & + pqte, pverv, ilwmin, ldcum, zhcbase,& + ktype, ilab, ptu, pqu, plu, & + zuu, zvu, pmfu, zmfub, zentr, & + zmfus, zmfuq, zmful, plude, zdmfup, & + kcbot, kctop, ictop0, icum, ztmst, & + ihmin, zhhatt, zqsenh) !---------------------------------------------------------- -!* 7.0 DETERMINE FINAL CONVECTIVE FLUXES IN 'CUFLX' +!* 7.0 determine final convective fluxes in 'cuflx' !---------------------------------------------------------- - 700 CONTINUE - CALL CUFLX & - (KLON, KLEV, KLEVP1, PQEN, PQSEN, & - ZTENH, ZQENH, PAPH, ZGEOH, KCBOT, & - KCTOP, IDTOP, KTYPE, LODDRAF, LDCUM, & - PMFU, PMFD, ZMFUS, ZMFDS, ZMFUQ, & - ZMFDQ, ZMFUL, PLUDE, ZDMFUP, ZDMFDP, & - ZRFL, PRAIN, PTEN, ZSFL, ZDPMEL, & - ITOPM2, ZTMST, sig1) + call cuflx & + (klon, klev, klevp1, pqen, pqsen, & + ztenh, zqenh, paph, zgeoh, kcbot, & + kctop, idtop, ktype, loddraf, ldcum, & + pmfu, pmfd, zmfus, zmfds, zmfuq, & + zmfdq, zmful, plude, zdmfup, zdmfdp, & + zrfl, prain, pten, zsfl, zdpmel, & + itopm2, ztmst, sig1) !---------------------------------------------------------------- -!* 8.0 UPDATE TENDENCIES FOR T AND Q IN SUBROUTINE CUDTDQ +!* 8.0 update tendencies for t and q in subroutine cudtdq !---------------------------------------------------------------- - 800 CONTINUE - CALL CUDTDQ & - (KLON, KLEV, KLEVP1, ITOPM2, PAPH, & - LDCUM, PTEN, PTTE, PQTE, ZMFUS, & - ZMFDS, ZMFUQ, ZMFDQ, ZMFUL, ZDMFUP, & - ZDMFDP, ZTMST, ZDPMEL, PRAIN, ZRFL, & - ZSFL, PSRAIN, PSEVAP, PSHEAT, PSMELT, & - PRSFC, PSSFC, PAPRC, PAPRSM, PAPRS, & - PQEN, PQSEN, PLUDE, PCTE) + call cudtdq & + (klon, klev, klevp1, itopm2, paph, & + ldcum, pten, ptte, pqte, zmfus, & + zmfds, zmfuq, zmfdq, zmful, zdmfup, & + zdmfdp, ztmst, zdpmel, prain, zrfl, & + zsfl, psrain, psevap, psheat, psmelt, & + prsfc, pssfc, paprc, paprsm, paprs, & + pqen, pqsen, plude, pcte) !---------------------------------------------------------------- -!* 9.0 UPDATE TENDENCIES FOR U AND U IN SUBROUTINE CUDUDV +!* 9.0 update tendencies for u and u in subroutine cududv !---------------------------------------------------------------- - 900 CONTINUE - IF(LMFDUDV) THEN - CALL CUDUDV & - (KLON, KLEV, KLEVP1, ITOPM2, KTYPE, & - KCBOT, PAPH, LDCUM, PUEN, PVEN, & - PVOM, PVOL, ZUU, ZUD, ZVU, & - ZVD, PMFU, PMFD, PSDISS) - END IF - 1000 CONTINUE - RETURN - END SUBROUTINE CUMASTR_NEW + if(lmfdudv) then + call cududv & + (klon, klev, klevp1, itopm2, ktype, & + kcbot, paph, ldcum, puen, pven, & + pvom, pvol, zuu, zud, zvu, & + zvd, pmfu, pmfd, psdiss) + end if + return + end subroutine cumastr_new ! !############################################################# ! -! LEVEL 3 SUBROUTINEs +! level 3 subroutines ! !############################################################# !********************************************** -! SUBROUTINE CUINI +! subroutine cuini !********************************************** ! - SUBROUTINE CUINI & - (KLON, KLEV, KLEVP1, KLEVM1, PTEN, & - PQEN, PQSEN, PUEN, PVEN, PVERV, & - PGEO, PAPH, PGEOH, PTENH, PQENH, & - PQSENH, KLWMIN, PTU, PQU, PTD, & - PQD, PUU, PVU, PUD, PVD, & - PMFU, PMFD, PMFUS, PMFDS, PMFUQ, & - PMFDQ, PDMFUP, PDMFDP, PDPMEL, PLU, & - PLUDE, KLAB) -! M.TIEDTKE E.C.M.W.F. 12/89 -!***PURPOSE + subroutine cuini & + (klon, klev, klevp1, klevm1, pten, & + pqen, pqsen, puen, pven, pverv, & + pgeo, paph, pgeoh, ptenh, pqenh, & + pqsenh, klwmin, ptu, pqu, ptd, & + pqd, puu, pvu, pud, pvd, & + pmfu, pmfd, pmfus, pmfds, pmfuq, & + pmfdq, pdmfup, pdmfdp, pdpmel, plu, & + plude, klab) +! m.tiedtke e.c.m.w.f. 12/89 +!***purpose ! ------- -! THIS ROUTINE INTERPOLATES LARGE-SCALE FIELDS OF T,Q ETC. -! TO HALF LEVELS (I.E. GRID FOR MASSFLUX SCHEME), -! AND INITIALIZES VALUES FOR UPDRAFTS AND DOWNDRAFTS -!***INTERFACE +! this routine interpolates large-scale fields of t,q etc. +! to half levels (i.e. grid for massflux scheme), +! and initializes values for updrafts and downdrafts +!***interface ! --------- -! THIS ROUTINE IS CALLED FROM *CUMASTR*. -!***METHOD. +! this routine is called from *cumastr*. +!***method. ! -------- -! FOR EXTRAPOLATION TO HALF LEVELS SEE TIEDTKE(1989) -!***EXTERNALS +! for extrapolation to half levels see tiedtke(1989) +!***externals ! --------- -! *CUADJTQ* TO SPECIFY QS AT HALF LEVELS +! *cuadjtq* to specify qs at half levels ! ---------------------------------------------------------------- !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER klevm1 - INTEGER JK,JL,IK, ICALL - REAL ZDP, ZZS - REAL PTEN(KLON,KLEV), PQEN(KLON,KLEV), & - PUEN(KLON,KLEV), PVEN(KLON,KLEV), & - PQSEN(KLON,KLEV), PVERV(KLON,KLEV), & - PGEO(KLON,KLEV), PGEOH(KLON,KLEV), & - PAPH(KLON,KLEVP1), PTENH(KLON,KLEV), & - PQENH(KLON,KLEV), PQSENH(KLON,KLEV) - REAL PTU(KLON,KLEV), PQU(KLON,KLEV), & - PTD(KLON,KLEV), PQD(KLON,KLEV), & - PUU(KLON,KLEV), PUD(KLON,KLEV), & - PVU(KLON,KLEV), PVD(KLON,KLEV), & - PMFU(KLON,KLEV), PMFD(KLON,KLEV), & - PMFUS(KLON,KLEV), PMFDS(KLON,KLEV), & - PMFUQ(KLON,KLEV), PMFDQ(KLON,KLEV), & - PDMFUP(KLON,KLEV), PDMFDP(KLON,KLEV), & - PLU(KLON,KLEV), PLUDE(KLON,KLEV) - REAL ZWMAX(KLON), ZPH(KLON), & - PDPMEL(KLON,KLEV) - INTEGER KLAB(KLON,KLEV), KLWMIN(KLON) - LOGICAL LOFLAG(KLON) + integer klon, klev, klevp1 + integer klevm1 + integer jk,jl,ik, icall + real zdp, zzs + real pten(klon,klev), pqen(klon,klev), & + puen(klon,klev), pven(klon,klev), & + pqsen(klon,klev), pverv(klon,klev), & + pgeo(klon,klev), pgeoh(klon,klev), & + paph(klon,klevp1), ptenh(klon,klev), & + pqenh(klon,klev), pqsenh(klon,klev) + real ptu(klon,klev), pqu(klon,klev), & + ptd(klon,klev), pqd(klon,klev), & + puu(klon,klev), pud(klon,klev), & + pvu(klon,klev), pvd(klon,klev), & + pmfu(klon,klev), pmfd(klon,klev), & + pmfus(klon,klev), pmfds(klon,klev), & + pmfuq(klon,klev), pmfdq(klon,klev), & + pdmfup(klon,klev), pdmfdp(klon,klev), & + plu(klon,klev), plude(klon,klev) + real zwmax(klon), zph(klon), & + pdpmel(klon,klev) + integer klab(klon,klev), klwmin(klon) + logical loflag(klon) !------------------------------------------------------------ -!* 1. SPECIFY LARGE SCALE PARAMETERS AT HALF LEVELS -!* ADJUST TEMPERATURE FIELDS IF STATICLY UNSTABLE -!* FIND LEVEL OF MAXIMUM VERTICAL VELOCITY +!* 1. specify large scale parameters at half levels +!* adjust temperature fields if staticly unstable +!* find level of maximum vertical velocity ! ----------------------------------------------------------- - 100 CONTINUE - ZDP=0.5 - DO 130 JK=2,KLEV - DO 110 JL=1,KLON - PGEOH(JL,JK)=PGEO(JL,JK)+(PGEO(JL,JK-1)-PGEO(JL,JK))*ZDP - PTENH(JL,JK)=(MAX(CPD*PTEN(JL,JK-1)+PGEO(JL,JK-1), & - CPD*PTEN(JL,JK)+PGEO(JL,JK))-PGEOH(JL,JK))*RCPD - PQSENH(JL,JK)=PQSEN(JL,JK-1) - ZPH(JL)=PAPH(JL,JK) - LOFLAG(JL)=.TRUE. - 110 CONTINUE - IK=JK - ICALL=0 - CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTENH,PQSENH,LOFLAG,ICALL) - DO 120 JL=1,KLON - PQENH(JL,JK)=MIN(PQEN(JL,JK-1),PQSEN(JL,JK-1)) & - +(PQSENH(JL,JK)-PQSEN(JL,JK-1)) - PQENH(JL,JK)=MAX(PQENH(JL,JK),0.) - 120 CONTINUE - 130 CONTINUE - DO 140 JL=1,KLON - PTENH(JL,KLEV)=(CPD*PTEN(JL,KLEV)+PGEO(JL,KLEV)- & - PGEOH(JL,KLEV))*RCPD - PQENH(JL,KLEV)=PQEN(JL,KLEV) - PTENH(JL,1)=PTEN(JL,1) - PQENH(JL,1)=PQEN(JL,1) - PGEOH(JL,1)=PGEO(JL,1) - KLWMIN(JL)=KLEV - ZWMAX(JL)=0. - 140 CONTINUE - DO 160 JK=KLEVM1,2,-1 - DO 150 JL=1,KLON - ZZS=MAX(CPD*PTENH(JL,JK)+PGEOH(JL,JK), & - CPD*PTENH(JL,JK+1)+PGEOH(JL,JK+1)) - PTENH(JL,JK)=(ZZS-PGEOH(JL,JK))*RCPD - 150 CONTINUE - 160 CONTINUE - DO 190 JK=KLEV,3,-1 - DO 180 JL=1,KLON - IF(PVERV(JL,JK).LT.ZWMAX(JL)) THEN - ZWMAX(JL)=PVERV(JL,JK) - KLWMIN(JL)=JK - END IF - 180 CONTINUE - 190 CONTINUE -!----------------------------------------------------------- -!* 2.0 INITIALIZE VALUES FOR UPDRAFTS AND DOWNDRAFTS -!----------------------------------------------------------- - 200 CONTINUE - DO 230 JK=1,KLEV - IK=JK-1 - IF(JK.EQ.1) IK=1 - DO 220 JL=1,KLON - PTU(JL,JK)=PTENH(JL,JK) - PTD(JL,JK)=PTENH(JL,JK) - PQU(JL,JK)=PQENH(JL,JK) - PQD(JL,JK)=PQENH(JL,JK) - PLU(JL,JK)=0. - PUU(JL,JK)=PUEN(JL,IK) - PUD(JL,JK)=PUEN(JL,IK) - PVU(JL,JK)=PVEN(JL,IK) - PVD(JL,JK)=PVEN(JL,IK) - PMFU(JL,JK)=0. - PMFD(JL,JK)=0. - PMFUS(JL,JK)=0. - PMFDS(JL,JK)=0. - PMFUQ(JL,JK)=0. - PMFDQ(JL,JK)=0. - PDMFUP(JL,JK)=0. - PDMFDP(JL,JK)=0. - PDPMEL(JL,JK)=0. - PLUDE(JL,JK)=0. - KLAB(JL,JK)=0 - 220 CONTINUE - 230 CONTINUE - RETURN - END SUBROUTINE CUINI - -!********************************************** -! SUBROUTINE CUBASE -!********************************************** - SUBROUTINE CUBASE & - (KLON, KLEV, KLEVP1, KLEVM1, PTENH, & - PQENH, PGEOH, PAPH, PTU, PQU, & - PLU, PUEN, PVEN, PUU, PVU, & - LDCUM, KCBOT, KLAB) -! THIS ROUTINE CALCULATES CLOUD BASE VALUES (T AND Q) -! FOR CUMULUS PARAMETERIZATION -! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89 -!***PURPOSE. -! -------- -! TO PRODUCE CLOUD BASE VALUES FOR CU-PARAMETRIZATION -!***INTERFACE -! --------- -! THIS ROUTINE IS CALLED FROM *CUMASTR*. -! INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS. -! IT RETURNS CLOUD BASE VALUES AND FLAGS AS FOLLOWS; -! KLAB=1 FOR SUBCLOUD LEVELS -! KLAB=2 FOR CONDENSATION LEVEL -!***METHOD. -! -------- -! LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE -! (NON ENTRAINING PLUME,I.E.CONSTANT MASSFLUX) -!***EXTERNALS -! --------- -! *CUADJTQ* FOR ADJUSTING T AND Q DUE TO CONDENSATION IN ASCENT -! ---------------------------------------------------------------- -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER klevm1 - INTEGER JL,JK,IS,IK,ICALL,IKB - REAL ZBUO,ZZ - REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), & - PGEOH(KLON,KLEV), PAPH(KLON,KLEVP1) - REAL PTU(KLON,KLEV), PQU(KLON,KLEV), & - PLU(KLON,KLEV) - REAL PUEN(KLON,KLEV), PVEN(KLON,KLEV), & - PUU(KLON,KLEV), PVU(KLON,KLEV) - REAL ZQOLD(KLON,KLEV), ZPH(KLON) - INTEGER KLAB(KLON,KLEV), KCBOT(KLON) - LOGICAL LDCUM(KLON), LOFLAG(KLON) -!***INPUT VARIABLES: -! PTENH [ZTENH] - Environment Temperature on half levels. (CUINI) -! PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI) -! PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX) -! PAPH - Pressure of half levels. (MSSFLX) -!***VARIABLES MODIFIED BY CUBASE: -! LDCUM - Logical denoting profiles. (CUBASE) -! KTYPE - Convection type - 1: Penetrative (CUMASTR) -! 2: Stratocumulus (CUMASTR) -! 3: Mid-level (CUASC) -! PTU - Cloud Temperature. -! PQU - Cloud specific Humidity. -! PLU - Cloud Liquid Water (Moisture condensed out) -! KCBOT - Cloud Base Level. (CUBASE) -! KLAB [ILAB] - Level Label - 1: Sub-cloud layer (CUBASE) -!------------------------------------------------ -! 1. INITIALIZE VALUES AT LIFTING LEVEL -!------------------------------------------------ - 100 CONTINUE - DO 110 JL=1,KLON - KLAB(JL,KLEV)=1 - KCBOT(JL)=KLEVM1 - LDCUM(JL)=.FALSE. - PUU(JL,KLEV)=PUEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV)) - PVU(JL,KLEV)=PVEN(JL,KLEV)*(PAPH(JL,KLEVP1)-PAPH(JL,KLEV)) - 110 CONTINUE -!------------------------------------------------------- -! 2.0 DO ASCENT IN SUBCLOUD LAYER, -! CHECK FOR EXISTENCE OF CONDENSATION LEVEL, -! ADJUST T,Q AND L ACCORDINGLY IN *CUADJTQ*, -! CHECK FOR BUOYANCY AND SET FLAGS -!------------------------------------------------------- - DO 200 JK=1,KLEV - DO 200 JL=1,KLON - ZQOLD(JL,JK)=0.0 - 200 CONTINUE - DO 290 JK=KLEVM1,2,-1 - IS=0 - DO 210 JL=1,KLON - IF(KLAB(JL,JK+1).EQ.1) THEN - IS=IS+1 - LOFLAG(JL)=.TRUE. - ELSE - LOFLAG(JL)=.FALSE. - ENDIF - ZPH(JL)=PAPH(JL,JK) - 210 CONTINUE - IF(IS.EQ.0) GO TO 290 - DO 220 JL=1,KLON - IF(LOFLAG(JL)) THEN - PQU(JL,JK)=PQU(JL,JK+1) - PTU(JL,JK)=(CPD*PTU(JL,JK+1)+PGEOH(JL,JK+1) & - -PGEOH(JL,JK))*RCPD - ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK))- & - PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))+ZBUO0 - IF(ZBUO.GT.0.) KLAB(JL,JK)=1 - ZQOLD(JL,JK)=PQU(JL,JK) - END IF - 220 CONTINUE - IK=JK - ICALL=1 - CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL) - DO 240 JL=1,KLON - IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL,JK)) THEN - KLAB(JL,JK)=2 - PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL,JK)-PQU(JL,JK) - ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK))- & - PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK))+ZBUO0 - IF(ZBUO.GT.0.) THEN - KCBOT(JL)=JK - LDCUM(JL)=.TRUE. - END IF - END IF - 240 CONTINUE -! CALCULATE AVERAGES OF U AND V FOR SUBCLOUD ARA,. -! THE VALUES WILL BE USED TO DEFINE CLOUD BASE VALUES. - IF(LMFDUDV) THEN - DO 250 JL=1,KLON - IF(JK.GE.KCBOT(JL)) THEN - PUU(JL,KLEV)=PUU(JL,KLEV)+ & - PUEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK)) - PVU(JL,KLEV)=PVU(JL,KLEV)+ & - PVEN(JL,JK)*(PAPH(JL,JK+1)-PAPH(JL,JK)) - END IF - 250 CONTINUE - END IF - 290 CONTINUE - IF(LMFDUDV) THEN - DO 310 JL=1,KLON - IF(LDCUM(JL)) THEN - IKB=KCBOT(JL) - ZZ=1./(PAPH(JL,KLEVP1)-PAPH(JL,IKB)) - PUU(JL,KLEV)=PUU(JL,KLEV)*ZZ - PVU(JL,KLEV)=PVU(JL,KLEV)*ZZ - ELSE - PUU(JL,KLEV)=PUEN(JL,KLEVM1) - PVU(JL,KLEV)=PVEN(JL,KLEVM1) - END IF - 310 CONTINUE - END IF - RETURN - END SUBROUTINE CUBASE - -!********************************************** -! SUBROUTINE CUTYPE -!********************************************** - SUBROUTINE CUTYPE & - ( KLON, KLEV, KLEVP1, KLEVM1,& - PTENH, PQENH, PQSENH, PGEOH, PAPH,& - RHO, HFX, QFX, KTYPE, lndj ) -! THIS ROUTINE CALCULATES CLOUD BASE and TOP -! AND RETURN CLOUD TYPES -! ZHANG & WANG IPRC 12/2010 -!***PURPOSE. -! -------- -! TO PRODUCE CLOUD TYPE for CU-PARAMETERIZATIONS -!***INTERFACE -! --------- -! THIS ROUTINE IS CALLED FROM *CUMASTR*. -! INPUT ARE ENVIRONM. VALUES OF T,Q,P,PHI AT HALF LEVELS. -! IT RETURNS CLOUD TYPES AS FOLLOWS; -! KTYPE=1 FOR deep cumulus -! KTYPE=2 FOR shallow cumulus -!***METHOD. -! -------- -! based on a simplified updraught equation -! partial(Hup)/partial(z)=eta(H - Hup) -! eta is the entrainment rate for test parcel -! H stands for dry static energy or the total water specific humidity -! references: Christian Jakob, 2003: A new subcloud model for mass-flux convection schemes -! influence on triggering, updraft properties, and model climate, Mon.Wea.Rev. -! 131, 2765-2778 -! and -! IFS Documentation - Cy33r1 -! -!***EXTERNALS -! --------- -! *CUADJTQ* FOR ADJUSTING T AND Q DUE TO CONDENSATION IN ASCENT -! ---------------------------------------------------------------- -!------------------------------------------------------------------- - IMPLICIT NONE -!------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER klevm1 - INTEGER JL,JK,IS,IK,ICALL,IKB,LEVELS - REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), & - PQSENH(KLON,KLEV),& - PGEOH(KLON,KLEV), PAPH(KLON,KLEVP1) - REAL ZRELH(KLON) - REAL QFX(KLON),RHO(KLON),HFX(KLON) - REAL ZQOLD(KLON,KLEV), ZPH(KLON) - INTEGER KCTOP(KLON),KCBOT(KLON) - INTEGER KTYPE(KLON),LCLFLAG(KLON) - LOGICAL TOPFLAG(KLON),DEEPFLAG(KLON),MYFLAG(KLON) - - REAL part1(klon), part2(klon), root(klon) - REAL conw(klon),deltT(klon),deltQ(klon) - REAL eta(klon),dz(klon),coef(klon) - REAL dhen(KLON,KLEV), dh(KLON,KLEV),qh(KLON,KLEV) - REAL Tup(KLON,KLEV),Qup(KLON,KLEV),ql(KLON,KLEV) - REAL ww(KLON,KLEV),Kup(KLON,KLEV) - REAL Vtup(KLON,KLEV),Vten(KLON,KLEV),buoy(KLON,KLEV) - - INTEGER lndj(KLON) - REAL CRIRH1 -!***INPUT VARIABLES: -! PTENH [ZTENH] - Environment Temperature on half levels. (CUINI) -! PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI) -! PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX) -! PAPH - Pressure of half levels. (MSSFLX) -! RHO - Density of the lowest Model level -! QFX - net upward moisture flux at the surface (kg/m^2/s) -! HFX - net upward heat flux at the surface (W/m^2) -!***VARIABLES OUTPUT BY CUTYPE: -! KTYPE - Convection type - 1: Penetrative (CUMASTR) -! 2: Stratocumulus (CUMASTR) -! 3: Mid-level (CUASC) -!-------------------------------------------------------------- - DO JL=1,KLON - KCBOT(JL)=KLEVM1 - KCTOP(JL)=KLEVM1 - KTYPE(JL)=0 - END DO -!----------------------------------------------------------- -! let's do test,and check the shallow convection first -! the first level is JK+1 -! define deltaT and deltaQ -!----------------------------------------------------------- - DO JK=1,KLEV - DO JL=1,KLON - ZQOLD(JL,JK)=0.0 - ql(jl,jk)=0.0 ! parcel liquid water - Tup(jl,jk)=0.0 ! parcel temperature - Qup(jl,jk)=0.0 ! parcel specific humidity - dh(jl,jk)=0.0 ! parcel dry static energy - qh(jl,jk)=0.0 ! parcel total water specific humidity - ww(jl,jk)=0.0 ! parcel vertical speed (m/s) - dhen(jl,jk)=0.0 ! environment dry static energy - Kup(jl,jk)=0.0 ! updraught kinetic energy for parcel - Vtup(jl,jk)=0.0 ! parcel virtual temperature considering water-loading - Vten(jl,jk)=0.0 ! environment virtual temperature - buoy(jl,jk)=0.0 ! parcel buoyancy - END DO - END DO - + zdp=0.5 + do jk=2,klev do jl=1,klon - lclflag(jl) = 0 ! flag for the condensation level - conw(jl) = 0.0 ! convective-scale velocity,also used for the vertical speed at the first level - myflag(jl) = .true. ! just as input for cuadjqt subroutine - topflag(jl) = .false.! flag for whether the cloud top is found + pgeoh(jl,jk)=pgeo(jl,jk)+(pgeo(jl,jk-1)-pgeo(jl,jk))*zdp + ptenh(jl,jk)=(max(cpd*pten(jl,jk-1)+pgeo(jl,jk-1), & + cpd*pten(jl,jk)+pgeo(jl,jk))-pgeoh(jl,jk))*rcpd + pqsenh(jl,jk)=pqsen(jl,jk-1) + zph(jl)=paph(jl,jk) + loflag(jl)=.true. end do -! check the levels from lowest level to second top level - do JK=KLEVM1,2,-1 - DO JL=1,KLON - ZPH(JL)=PAPH(JL,JK) - END DO - -! define the variables at the first level - if(jk .eq. KLEVM1) then + ik=jk + icall=0 + call cuadjtq(klon,klev,ik,zph,ptenh,pqsenh,loflag,icall) do jl=1,klon - part1(jl) = 1.5*0.4*pgeoh(jl,jk+1)/(rho(jl)*ptenh(jl,jk+1)) - part2(jl) = hfx(jl)/cpd+0.61*ptenh(jl,jk+1)*qfx(jl) - root(jl) = 0.001-part1(jl)*part2(jl) - if(root(jl) .gt. 0) then - conw(jl) = 1.2*(root(jl))**(1.0/3.0) - else - conw(jl) = -1.2*(-root(jl))**(1.0/3.0) - end if - deltT(jl) = -1.5*hfx(jl)/(rho(jl)*cpd*conw(jl)) - deltQ(jl) = -1.5*qfx(jl)/(rho(jl)*conw(jl)) - - Tup(jl,jk+1) = ptenh(jl,jk+1) + deltT(jl) - Qup(jl,jk+1) = pqenh(jl,jk+1) + deltQ(jl) - ql(jl,jk+1) = 0. - dh(jl,jk+1) = pgeoh(jl,jk+1) + Tup(jl,jk+1)*cpd - qh(jl,jk+1) = pqenh(jl,jk+1) + deltQ(jl) + ql(jl,jk+1) - ww(jl,jk+1) = conw(jl) + pqenh(jl,jk)=min(pqen(jl,jk-1),pqsen(jl,jk-1)) & + +(pqsenh(jl,jk)-pqsen(jl,jk-1)) + pqenh(jl,jk)=max(pqenh(jl,jk),0.) end do - end if - -! the next levels, we use the variables at the first level as initial values - do jl=1,klon - if(.not. topflag(jl)) then - eta(jl) = 0.5*(0.55/(pgeoh(jl,jk)*zrg)+1.0e-3) - dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg - coef(jl)= eta(jl)*dz(jl) - dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) - dh(jl,jk) = (coef(jl)*dhen(jl,jk) + dh(jl,jk+1))/(1+coef(jl)) - qh(jl,jk) = (coef(jl)*pqenh(jl,jk)+ qh(jl,jk+1))/(1+coef(jl)) - Tup(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*RCPD - Qup(jl,jk) = qh(jl,jk) - ql(jl,jk+1) - zqold(jl,jk) = Qup(jl,jk) - end if end do -! check if the parcel is saturated - ik=jk - icall=1 - call CUADJTQ(klon,klev,ik,zph,Tup,Qup,myflag,icall) + do jl=1,klon - if( .not. topflag(jl) .and. zqold(jl,jk) .ne. Qup(jl,jk) ) then - lclflag(jl) = lclflag(jl) + 1 - ql(jl,jk) = ql(jl,jk+1) + zqold(jl,jk) - Qup(jl,jk) - dh(jl,jk) = pgeoh(jl,jk) + cpd*Tup(jl,jk) - end if + ptenh(jl,klev)=(cpd*pten(jl,klev)+pgeo(jl,klev)- & + pgeoh(jl,klev))*rcpd + pqenh(jl,klev)=pqen(jl,klev) + ptenh(jl,1)=pten(jl,1) + pqenh(jl,1)=pqen(jl,1) + pgeoh(jl,1)=pgeo(jl,1) + klwmin(jl)=klev + zwmax(jl)=0. end do -! compute the updraft speed + do jk=klevm1,2,-1 do jl=1,klon - if(.not. topflag(jl))then - Kup(jl,jk+1) = 0.5*ww(jl,jk+1)**2 - Vtup(jl,jk) = Tup(jl,jk)*(1.+VTMPC1*Qup(jl,jk)-ql(jl,jk)) - Vten(jl,jk) = ptenh(jl,jk)*(1.+VTMPC1*pqenh(jl,jk)) - buoy(jl,jk) = (Vtup(jl,jk) - Vten(jl,jk))/Vten(jl,jk)*g - Kup(jl,jk) = (Kup(jl,jk+1) + 0.333*dz(jl)*buoy(jl,jk))/ & - (1+2*2*eta(jl)*dz(jl)) - if(Kup(jl,jk) .gt. 0 ) then - ww(jl,jk) = sqrt(2*Kup(jl,jk)) - if(lclflag(jl) .eq. 1 ) kcbot(jl) = jk - if(jk .eq. 2) then - kctop(jl) = jk - topflag(jl)= .true. - end if - else - ww(jl,jk) = 0 - kctop(jl) = jk + 1 - topflag(jl) = .true. - end if - end if + zzs=max(cpd*ptenh(jl,jk)+pgeoh(jl,jk), & + cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1)) + ptenh(jl,jk)=(zzs-pgeoh(jl,jk))*rcpd + end do end do - end do ! end all the levels + do jk=klev,3,-1 do jl=1,klon - if(paph(jl,kcbot(jl)) - paph(jl,kctop(jl)) .lt. ZDNOPRC .and. & - paph(jl,kcbot(jl)) - paph(jl,kctop(jl)) .gt. 0 & - .and. lclflag(jl) .gt. 0) then - ktype(jl) = 2 - end if + if(pverv(jl,jk).lt.zwmax(jl)) then + zwmax(jl)=pverv(jl,jk) + klwmin(jl)=jk + end if + end do end do - !----------------------------------------------------------- -! Next, let's check the deep convection -! the first level is JK -! define deltaT and deltaQ -!---------------------------------------------------------- -! we check the parcel starting level by level (from the second lowest level to the next 12th level, -! usually, the 12th level around 700 hPa for common eta levels) - do levels=KLEVM1-1,KLEVM1-12,-1 - DO JK=1,KLEV - DO JL=1,KLON - ZQOLD(JL,JK)=0.0 - ql(jl,jk)=0.0 ! parcel liquid water - Tup(jl,jk)=0.0 ! parcel temperature - Qup(jl,jk)=0.0 ! parcel specific humidity - dh(jl,jk)=0.0 ! parcel dry static energy - qh(jl,jk)=0.0 ! parcel total water specific humidity - ww(jl,jk)=0.0 ! parcel vertical speed (m/s) - dhen(jl,jk)=0.0 ! environment dry static energy - Kup(jl,jk)=0.0 ! updraught kinetic energy for parcel - Vtup(jl,jk)=0.0 ! parcel virtual temperature considering water-loading - Vten(jl,jk)=0.0 ! environment virtual temperature - buoy(jl,jk)=0.0 ! parcel buoyancy - END DO - END DO - +!* 2.0 initialize values for updrafts and downdrafts +!----------------------------------------------------------- + do jk=1,klev + ik=jk-1 + if(jk.eq.1) ik=1 do jl=1,klon - lclflag(jl) = 0 ! flag for the condensation level - kctop(jl) = levels - kcbot(jl) = levels - myflag(jl) = .true. ! just as input for cuadjqt subroutine - topflag(jl) = .false.! flag for whether the cloud top is found + ptu(jl,jk)=ptenh(jl,jk) + ptd(jl,jk)=ptenh(jl,jk) + pqu(jl,jk)=pqenh(jl,jk) + pqd(jl,jk)=pqenh(jl,jk) + plu(jl,jk)=0. + puu(jl,jk)=puen(jl,ik) + pud(jl,jk)=puen(jl,ik) + pvu(jl,jk)=pven(jl,ik) + pvd(jl,jk)=pven(jl,ik) + pmfu(jl,jk)=0. + pmfd(jl,jk)=0. + pmfus(jl,jk)=0. + pmfds(jl,jk)=0. + pmfuq(jl,jk)=0. + pmfdq(jl,jk)=0. + pdmfup(jl,jk)=0. + pdmfdp(jl,jk)=0. + pdpmel(jl,jk)=0. + plude(jl,jk)=0. + klab(jl,jk)=0 end do - -! check the levels from lowest level to second top level - do JK=levels,2,-1 - DO JL=1,KLON - ZPH(JL)=PAPH(JL,JK) - END DO - -! define the variables at the first level - if(jk .eq. levels) then - do jl=1,klon - deltT(jl) = 0.2 - deltQ(jl) = 1.0e-4 - - if(paph(jl,KLEVM1-1)-paph(jl,jk) .le. 6.e3) then - ql(jl,jk+1) = 0. - Tup(jl,jk+1) = 0.25*(ptenh(jl,jk+1)+ptenh(jl,jk)+ & - ptenh(jl,jk-1)+ptenh(jl,jk-2)) + & - deltT(jl) - dh(jl,jk+1) = 0.25*(pgeoh(jl,jk+1)+pgeoh(jl,jk)+ & - pgeoh(jl,jk-1)+pgeoh(jl,jk-2)) + & - Tup(jl,jk+1)*cpd - qh(jl,jk+1) = 0.25*(pqenh(jl,jk+1)+pqenh(jl,jk)+ & - pqenh(jl,jk-1)+pqenh(jl,jk-2))+ & - deltQ(jl) + ql(jl,jk+1) - Qup(jl,jk+1) = qh(jl,jk+1) - ql(jl,jk+1) - else - ql(jl,jk+1) = 0. - Tup(jl,jk+1) = ptenh(jl,jk+1) + deltT(jl) - dh(jl,jk+1) = pgeoh(jl,jk+1) + Tup(jl,jk+1)*cpd - qh(jl,jk+1) = pqenh(jl,jk+1) + deltQ(jl) - Qup(jl,jk+1) = qh(jl,jk+1) - ql(jl,jk+1) - end if - ww(jl,jk+1) = 1.0 - end do - end if + return + end subroutine cuini -! the next levels, we use the variables at the first level as initial values +!********************************************** +! subroutine cubase +!********************************************** + subroutine cubase & + (klon, klev, klevp1, klevm1, ptenh, & + pqenh, pgeoh, paph, ptu, pqu, & + plu, puen, pven, puu, pvu, & + ldcum, kcbot, klab) +! this routine calculates cloud base values (t and q) +! for cumulus parameterization +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 +!***purpose. +! -------- +! to produce cloud base values for cu-parametrization +!***interface +! --------- +! this routine is called from *cumastr*. +! input are environm. values of t,q,p,phi at half levels. +! it returns cloud base values and flags as follows; +! klab=1 for subcloud levels +! klab=2 for condensation level +!***method. +! -------- +! lift surface air dry-adiabatically to cloud base +! (non entraining plume,i.e.constant massflux) +!***externals +! --------- +! *cuadjtq* for adjusting t and q due to condensation in ascent +! ---------------------------------------------------------------- +!------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------- + integer klon, klev, klevp1 + integer klevm1 + integer jl,jk,is,ik,icall,ikb + real zbuo,zz + real ptenh(klon,klev), pqenh(klon,klev), & + pgeoh(klon,klev), paph(klon,klevp1) + real ptu(klon,klev), pqu(klon,klev), & + plu(klon,klev) + real puen(klon,klev), pven(klon,klev), & + puu(klon,klev), pvu(klon,klev) + real zqold(klon,klev), zph(klon) + integer klab(klon,klev), kcbot(klon) + logical ldcum(klon), loflag(klon) + logical ldbase(klon) + logical llo1 +!***input variables: +! ptenh [ztenh] - environment temperature on half levels. (cuini) +! pqenh [zqenh] - env. specific humidity on half levels. (cuini) +! pgeoh [zgeoh] - geopotential on half levels, (mssflx) +! paph - pressure of half levels. (mssflx) +!***variables modified by cubase: +! ldcum - logical denoting profiles. (cubase) +! ktype - convection type - 1: penetrative (cumastr) +! 2: stratocumulus (cumastr) +! 3: mid-level (cuasc) +! ptu - cloud temperature. +! pqu - cloud specific humidity. +! plu - cloud liquid water (moisture condensed out) +! kcbot - cloud base level. (cubase) +! klab [ilab] - level label - 1: sub-cloud layer (cubase) +!------------------------------------------------ +! 1. initialize values at lifting level +!------------------------------------------------ do jl=1,klon - if(.not. topflag(jl)) then - eta(jl) = 1.1e-4 - dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg - coef(jl)= eta(jl)*dz(jl) - dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) - dh(jl,jk) = (coef(jl)*dhen(jl,jk) + dh(jl,jk+1))/(1+coef(jl)) - qh(jl,jk) = (coef(jl)*pqenh(jl,jk)+ qh(jl,jk+1))/(1+coef(jl)) - Tup(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*RCPD - Qup(jl,jk) = qh(jl,jk) - ql(jl,jk+1) - zqold(jl,jk) = Qup(jl,jk) - end if + klab(jl,klev)=1 + kcbot(jl)=klevm1 + ldcum(jl)=.false. + ldbase(jl)=.false. + puu(jl,klev)=puen(jl,klev)*(paph(jl,klevp1)-paph(jl,klev)) + pvu(jl,klev)=pven(jl,klev)*(paph(jl,klevp1)-paph(jl,klev)) end do -! check if the parcel is saturated - ik=jk - icall=1 - call CUADJTQ(klon,klev,ik,zph,Tup,Qup,myflag,icall) +!------------------------------------------------------- +! 2.0 do ascent in subcloud layer, +! check for existence of condensation level, +! adjust t,q and l accordingly in *cuadjtq*, +! check for buoyancy and set flags +!------------------------------------------------------- + do jk=1,klev do jl=1,klon - if( .not. topflag(jl) .and. zqold(jl,jk) .ne. Qup(jl,jk) ) then - lclflag(jl) = lclflag(jl) + 1 - ql(jl,jk) = ql(jl,jk+1) + zqold(jl,jk) - Qup(jl,jk) - dh(jl,jk) = pgeoh(jl,jk) + cpd*Tup(jl,jk) - end if + zqold(jl,jk)=0.0 + end do end do -! compute the updraft speed - do jl=1,klon - if(.not. topflag(jl))then - Kup(jl,jk+1) = 0.5*ww(jl,jk+1)**2 - Vtup(jl,jk) = Tup(jl,jk)*(1.+VTMPC1*Qup(jl,jk)-ql(jl,jk)) - Vten(jl,jk) = ptenh(jl,jk)*(1.+VTMPC1*pqenh(jl,jk)) - buoy(jl,jk) = (Vtup(jl,jk) - Vten(jl,jk))/Vten(jl,jk)*g - Kup(jl,jk) = (Kup(jl,jk+1) + 0.333*dz(jl)*buoy(jl,jk))/ & - (1+2*2*eta(jl)*dz(jl)) - if(Kup(jl,jk) .gt. 0 ) then - ww(jl,jk) = sqrt(2*Kup(jl,jk)) - if(lclflag(jl) .eq. 1 ) kcbot(jl) = jk - if(jk .eq. 2) then - kctop(jl) = jk - topflag(jl)= .true. - end if + do jk=klevm1,2,-1 + is=0 + do jl=1,klon + if(klab(jl,jk+1).eq.1 .or.(ldcum(jl).and.kcbot(jl).eq.jk+1)) then + is=is+1 + loflag(jl)=.true. else - ww(jl,jk) = 0 - kctop(jl) = jk + 1 - topflag(jl) = .true. + loflag(jl)=.false. + endif + zph(jl)=paph(jl,jk) + end do + if(is.eq.0) cycle + +! calculate averages of u and v for subcloud area, +! the values will be used to define cloud base values. + + if(lmfdudv) then + do jl=1,klon + if(.not.ldbase(jl)) then + puu(jl,klev)=puu(jl,klev)+ & + puen(jl,jk)*(paph(jl,jk+1)-paph(jl,jk)) + pvu(jl,klev)=pvu(jl,klev)+ & + pven(jl,jk)*(paph(jl,jk+1)-paph(jl,jk)) + endif + enddo + endif + + do jl=1,klon + if(loflag(jl)) then + pqu(jl,jk)=pqu(jl,jk+1) + ptu(jl,jk)=(cpd*ptu(jl,jk+1)+pgeoh(jl,jk+1) & + -pgeoh(jl,jk))*rcpd + zqold(jl,jk)=pqu(jl,jk) end if - end if + end do + + ik=jk + icall=1 + call cuadjtq(klon,klev,ik,zph,ptu,pqu,loflag,icall) + + do jl=1,klon + if(loflag(jl)) then + if(pqu(jl,jk).eq.zqold(jl,jk)) then + zbuo=ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk))- & + ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk))+zbuo0 + if(zbuo.gt.0.) klab(jl,jk)=1 + else + klab(jl,jk)=2 + plu(jl,jk)=plu(jl,jk)+zqold(jl,jk)-pqu(jl,jk) + zbuo=ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk))- & + ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk))+zbuo0 + llo1=zbuo.gt.0..and.klab(jl,jk+1).eq.1 + if(llo1) then + kcbot(jl)=jk + ldcum(jl)=.true. + ldbase(jl)=.true. + end if + end if + end if + end do end do - end do ! end all the levels - do jl = 1, klon - if(paph(jl,kcbot(jl)) - paph(jl,kctop(jl)) .gt. ZDNOPRC .and. & - lclflag(jl) .gt. 0 ) then - ZRELH(JL) = 0. - do jk=kcbot(jl),kctop(jl),-1 - ZRELH(JL)=ZRELH(JL)+ PQENH(JL,JK)/PQSENH(JL,JK) - end do - ZRELH(JL) = ZRELH(JL)/(kcbot(jl)-kctop(jl)+1) - - if(lndj(JL) .eq. 1) then - CRIRH1 = CRIRH*0.8 + if(lmfdudv) then + do jl=1,klon + if(ldcum(jl)) then + ikb=kcbot(jl) + zz=1./(paph(jl,klevp1)-paph(jl,ikb)) + puu(jl,klev)=puu(jl,klev)*zz + pvu(jl,klev)=pvu(jl,klev)*zz else - CRIRH1 = CRIRH + puu(jl,klev)=puen(jl,klevm1) + pvu(jl,klev)=pven(jl,klevm1) end if - if(ZRELH(JL) .ge. CRIRH1) ktype(jl) = 1 - end if - end do - - end do ! end all cycles - - END SUBROUTINE CUTYPE - + end do + end if + return + end subroutine cubase ! !********************************************** -! SUBROUTINE CUASC_NEW +! subroutine cuasc_new !********************************************** - SUBROUTINE CUASC_NEW & - (KLON, KLEV, KLEVP1, KLEVM1, PTENH, & - PQENH, PUEN, PVEN, PTEN, PQEN, & - PQSEN, PGEO, PGEOH, PAP, PAPH, & - PQTE, PVERV, KLWMIN, LDCUM, PHCBASE,& - KTYPE, KLAB, PTU, PQU, PLU, & - PUU, PVU, PMFU, PMFUB, PENTR, & - PMFUS, PMFUQ, PMFUL, PLUDE, PDMFUP, & - KCBOT, KCTOP, KCTOP0, KCUM, ZTMST, & - KHMIN, PHHATT, PQSENH) -! THIS ROUTINE DOES THE CALCULATIONS FOR CLOUD ASCENTS -! FOR CUMULUS PARAMETERIZATION -! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89 -! Y.WANG IPRC 11/01 MODIF. -!***PURPOSE. + subroutine cuasc_new & + (klon, klev, klevp1, klevm1, ptenh, & + pqenh, puen, pven, pten, pqen, & + pqsen, pgeo, pgeoh, pap, paph, & + pqte, pverv, klwmin, ldcum, phcbase,& + ktype, klab, ptu, pqu, plu, & + puu, pvu, pmfu, pmfub, pentr, & + pmfus, pmfuq, pmful, plude, pdmfup, & + kcbot, kctop, kctop0, kcum, ztmst, & + khmin, phhatt, pqsenh) +! this routine does the calculations for cloud ascents +! for cumulus parameterization +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 +! y.wang iprc 11/01 modif. +!***purpose. ! -------- -! TO PRODUCE CLOUD ASCENTS FOR CU-PARAMETRIZATION -! (VERTICAL PROFILES OF T,Q,L,U AND V AND CORRESPONDING -! FLUXES AS WELL AS PRECIPITATION RATES) -!***INTERFACE +! to produce cloud ascents for cu-parametrization +! (vertical profiles of t,q,l,u and v and corresponding +! fluxes as well as precipitation rates) +!***interface ! --------- -! THIS ROUTINE IS CALLED FROM *CUMASTR*. -!***METHOD. +! this routine is called from *cumastr*. +!***method. ! -------- -! LIFT SURFACE AIR DRY-ADIABATICALLY TO CLOUD BASE -! AND THEN CALCULATE MOIST ASCENT FOR -! ENTRAINING/DETRAINING PLUME. -! ENTRAINMENT AND DETRAINMENT RATES DIFFER FOR -! SHALLOW AND DEEP CUMULUS CONVECTION. -! IN CASE THERE IS NO PENETRATIVE OR SHALLOW CONVECTION -! CHECK FOR POSSIBILITY OF MID LEVEL CONVECTION -! (CLOUD BASE VALUES CALCULATED IN *CUBASMC*) -!***EXTERNALS +! lift surface air dry-adiabatically to cloud base +! and then calculate moist ascent for +! entraining/detraining plume. +! entrainment and detrainment rates differ for +! shallow and deep cumulus convection. +! in case there is no penetrative or shallow convection +! check for possibility of mid level convection +! (cloud base values calculated in *cubasmc*) +!***externals ! --------- -! *CUADJTQ* ADJUST T AND Q DUE TO CONDENSATION IN ASCENT -! *CUENTR_NEW* CALCULATE ENTRAINMENT/DETRAINMENT RATES -! *CUBASMC* CALCULATE CLOUD BASE VALUES FOR MIDLEVEL CONVECTION -!***REFERENCE +! *cuadjtq* adjust t and q due to condensation in ascent +! *cuentr_new* calculate entrainment/detrainment rates +! *cubasmc* calculate cloud base values for midlevel convection +!***reference ! --------- -! (TIEDTKE,1989) -!***INPUT VARIABLES: -! PTENH [ZTENH] - Environ Temperature on half levels. (CUINI) -! PQENH [ZQENH] - Env. specific humidity on half levels. (CUINI) -! PUEN - Environment wind u-component. (MSSFLX) -! PVEN - Environment wind v-component. (MSSFLX) -! PTEN - Environment Temperature. (MSSFLX) -! PQEN - Environment Specific Humidity. (MSSFLX) -! PQSEN - Environment Saturation Specific Humidity. (MSSFLX) -! PGEO - Geopotential. (MSSFLX) -! PGEOH [ZGEOH] - Geopotential on half levels, (MSSFLX) -! PAP - Pressure in Pa. (MSSFLX) -! PAPH - Pressure of half levels. (MSSFLX) -! PQTE - Moisture convergence (Delta q/Delta t). (MSSFLX) -! PVERV - Large Scale Vertical Velocity (Omega). (MSSFLX) -! KLWMIN [ILWMIN] - Level of Minimum Omega. (CUINI) -! KLAB [ILAB] - Level Label - 1: Sub-cloud layer. -! 2: Condensation Level (Cloud Base) -! PMFUB [ZMFUB] - Updraft Mass Flux at Cloud Base. (CUMASTR) -!***VARIABLES MODIFIED BY CUASC: -! LDCUM - Logical denoting profiles. (CUBASE) -! KTYPE - Convection type - 1: Penetrative (CUMASTR) -! 2: Stratocumulus (CUMASTR) -! 3: Mid-level (CUASC) -! PTU - Cloud Temperature. -! PQU - Cloud specific Humidity. -! PLU - Cloud Liquid Water (Moisture condensed out) -! PUU [ZUU] - Cloud Momentum U-Component. -! PVU [ZVU] - Cloud Momentum V-Component. -! PMFU - Updraft Mass Flux. -! PENTR [ZENTR] - Entrainment Rate. (CUMASTR ) (CUBASMC) -! PMFUS [ZMFUS] - Updraft Flux of Dry Static Energy. (CUBASMC) -! PMFUQ [ZMFUQ] - Updraft Flux of Specific Humidity. -! PMFUL [ZMFUL] - Updraft Flux of Cloud Liquid Water. -! PLUDE - Liquid Water Returned to Environment by Detrainment. -! PDMFUP [ZMFUP] - FLUX DIFFERENCE OF PRECIP. IN UPDRAFTS -! KCBOT - Cloud Base Level. (CUBASE) -! KCTOP - -! KCTOP0 [ICTOP0] - Estimate of Cloud Top. (CUMASTR) -! KCUM [ICUM] - +! (tiedtke,1989) +!***input variables: +! ptenh [ztenh] - environ temperature on half levels. (cuini) +! pqenh [zqenh] - env. specific humidity on half levels. (cuini) +! puen - environment wind u-component. (mssflx) +! pven - environment wind v-component. (mssflx) +! pten - environment temperature. (mssflx) +! pqen - environment specific humidity. (mssflx) +! pqsen - environment saturation specific humidity. (mssflx) +! pgeo - geopotential. (mssflx) +! pgeoh [zgeoh] - geopotential on half levels, (mssflx) +! pap - pressure in pa. (mssflx) +! paph - pressure of half levels. (mssflx) +! pqte - moisture convergence (delta q/delta t). (mssflx) +! pverv - large scale vertical velocity (omega). (mssflx) +! klwmin [ilwmin] - level of minimum omega. (cuini) +! klab [ilab] - level label - 1: sub-cloud layer. +! 2: condensation level (cloud base) +! pmfub [zmfub] - updraft mass flux at cloud base. (cumastr) +!***variables modified by cuasc: +! ldcum - logical denoting profiles. (cubase) +! ktype - convection type - 1: penetrative (cumastr) +! 2: stratocumulus (cumastr) +! 3: mid-level (cuasc) +! ptu - cloud temperature. +! pqu - cloud specific humidity. +! plu - cloud liquid water (moisture condensed out) +! puu [zuu] - cloud momentum u-component. +! pvu [zvu] - cloud momentum v-component. +! pmfu - updraft mass flux. +! pentr [zentr] - entrainment rate. (cumastr ) (cubasmc) +! pmfus [zmfus] - updraft flux of dry static energy. (cubasmc) +! pmfuq [zmfuq] - updraft flux of specific humidity. +! pmful [zmful] - updraft flux of cloud liquid water. +! plude - liquid water returned to environment by detrainment. +! pdmfup [zmfup] - +! kcbot - cloud base level. (cubase) +! kctop - +! kctop0 [ictop0] - estimate of cloud top. (cumastr) +! kcum [icum] - !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER klevm1,kcum - REAL ZTMST,ZCONS2,ZDZ,ZDRODZ - INTEGER JL,JK,IKB,IK,IS,IKT,ICALL - REAL ZMFMAX,ZFAC,ZMFTEST,ZDPRHO,ZMSE,ZNEVN,ZODMAX - REAL ZQEEN,ZSEEN,ZSCDE,ZGA,ZDT,ZSCOD - REAL ZQUDE,ZQCOD, ZMFUSK, ZMFUQK,ZMFULK - REAL ZBUO, ZPRCON, ZLNEW, ZZ, ZDMFEU, ZDMFDU - REAL ZBUOYZ,ZZDMF - REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), & - PUEN(KLON,KLEV), PVEN(KLON,KLEV), & - PTEN(KLON,KLEV), PQEN(KLON,KLEV), & - PGEO(KLON,KLEV), PGEOH(KLON,KLEV), & - PAP(KLON,KLEV), PAPH(KLON,KLEVP1), & - PQSEN(KLON,KLEV), PQTE(KLON,KLEV), & - PVERV(KLON,KLEV), PQSENH(KLON,KLEV) - REAL PTU(KLON,KLEV), PQU(KLON,KLEV), & - PUU(KLON,KLEV), PVU(KLON,KLEV), & - PMFU(KLON,KLEV), ZPH(KLON), & - PMFUB(KLON), PENTR(KLON), & - PMFUS(KLON,KLEV), PMFUQ(KLON,KLEV), & - PLU(KLON,KLEV), PLUDE(KLON,KLEV), & - PMFUL(KLON,KLEV), PDMFUP(KLON,KLEV) - REAL ZDMFEN(KLON), ZDMFDE(KLON), & - ZMFUU(KLON), ZMFUV(KLON), & - ZPBASE(KLON), ZQOLD(KLON), & - PHHATT(KLON,KLEV), ZODETR(KLON,KLEV), & - ZOENTR(KLON,KLEV), ZBUOY(KLON) - REAL PHCBASE(KLON) - INTEGER KLWMIN(KLON), KTYPE(KLON), & - KLAB(KLON,KLEV), KCBOT(KLON), & - KCTOP(KLON), KCTOP0(KLON), & - KHMIN(KLON) - LOGICAL LDCUM(KLON), LOFLAG(KLON) - integer leveltop,levelbot - real tt(klon),ttb(klon) - real zqsat(klon), zqsatb(klon) - real fscale(klon) - + integer klon, klev, klevp1 + integer klevm1,kcum + real ztmst,zcons2,zdz,zdrodz + integer jl,jk,ikb,ik,is,ikt,icall + real zmfmax,zfac,zmftest,zdprho,zmse,znevn,zodmax + real zqeen,zseen,zscde,zga,zdt,zscod + real zqude,zqcod, zmfusk, zmfuqk,zmfulk + real zbuo, zprcon, zlnew, zz, zdmfeu, zdmfdu + real zbuoyz,zzdmf + real ptenh(klon,klev), pqenh(klon,klev), & + puen(klon,klev), pven(klon,klev), & + pten(klon,klev), pqen(klon,klev), & + pgeo(klon,klev), pgeoh(klon,klev), & + pap(klon,klev), paph(klon,klevp1), & + pqsen(klon,klev), pqte(klon,klev), & + pverv(klon,klev), pqsenh(klon,klev) + real ptu(klon,klev), pqu(klon,klev), & + puu(klon,klev), pvu(klon,klev), & + pmfu(klon,klev), zph(klon), & + pmfub(klon), pentr(klon), & + pmfus(klon,klev), pmfuq(klon,klev), & + plu(klon,klev), plude(klon,klev), & + pmful(klon,klev), pdmfup(klon,klev) + real zdmfen(klon), zdmfde(klon), & + zmfuu(klon), zmfuv(klon), & + zpbase(klon), zqold(klon), & + phhatt(klon,klev), zodetr(klon,klev), & + zoentr(klon,klev), zbuoy(klon) + real phcbase(klon) + integer klwmin(klon), ktype(klon), & + klab(klon,klev), kcbot(klon), & + kctop(klon), kctop0(klon), & + khmin(klon) + logical ldcum(klon), loflag(klon) !-------------------------------- -!* 1. SPECIFY PARAMETERS +!* 1. specify parameters !-------------------------------- - 100 CONTINUE - ZCONS2=1./(G*ZTMST) + zcons2=1./(g*ztmst) !--------------------------------- -! 2. SET DEFAULT VALUES +! 2. set default values !--------------------------------- - 200 CONTINUE - DO 210 JL=1,KLON - ZMFUU(JL)=0. - ZMFUV(JL)=0. - ZBUOY(JL)=0. - IF(.NOT.LDCUM(JL)) KTYPE(JL)=0 - 210 CONTINUE - DO 230 JK=1,KLEV - DO 230 JL=1,KLON - PLU(JL,JK)=0. - PMFU(JL,JK)=0. - PMFUS(JL,JK)=0. - PMFUQ(JL,JK)=0. - PMFUL(JL,JK)=0. - PLUDE(JL,JK)=0. - PDMFUP(JL,JK)=0. - ZOENTR(JL,JK)=0. - ZODETR(JL,JK)=0. - IF(.NOT.LDCUM(JL).OR.KTYPE(JL).EQ.3) KLAB(JL,JK)=0 - IF(.NOT.LDCUM(JL).AND.PAPH(JL,JK).LT.4.E4) KCTOP0(JL)=JK - 230 CONTINUE + do jl=1,klon + zmfuu(jl)=0. + zmfuv(jl)=0. + zbuoy(jl)=0. + if(.not.ldcum(jl)) ktype(jl)=0 + end do + + do jk=1,klev + do jl=1,klon + plu(jl,jk)=0. + pmfu(jl,jk)=0. + pmfus(jl,jk)=0. + pmfuq(jl,jk)=0. + pmful(jl,jk)=0. + plude(jl,jk)=0. + pdmfup(jl,jk)=0. + zoentr(jl,jk)=0. + zodetr(jl,jk)=0. + if(.not.ldcum(jl).or.ktype(jl).eq.3) klab(jl,jk)=0 + if(.not.ldcum(jl).and.paph(jl,jk).lt.4.e4) kctop0(jl)=jk + end do + end do !------------------------------------------------ -! 3.0 INITIALIZE VALUES AT LIFTING LEVEL +! 3.0 initialize values at lifting level !------------------------------------------------ - DO 310 JL=1,KLON - KCTOP(JL)=KLEVM1 - IF(.NOT.LDCUM(JL)) THEN - KCBOT(JL)=KLEVM1 - PMFUB(JL)=0. - PQU(JL,KLEV)=0. - END IF - PMFU(JL,KLEV)=PMFUB(JL) - PMFUS(JL,KLEV)=PMFUB(JL)*(CPD*PTU(JL,KLEV)+PGEOH(JL,KLEV)) - PMFUQ(JL,KLEV)=PMFUB(JL)*PQU(JL,KLEV) - IF(LMFDUDV) THEN - ZMFUU(JL)=PMFUB(JL)*PUU(JL,KLEV) - ZMFUV(JL)=PMFUB(JL)*PVU(JL,KLEV) - END IF - 310 CONTINUE -! -!-- 3.1 Find organized entrainment at cloud base -! - DO 322 JL=1,KLON - LDCUM(JL)=.FALSE. - IF (KTYPE(JL).EQ.1) THEN - IKB = KCBOT(JL) - if(orgen .eq. 1 ) then -! old scheme - ZBUOY(JL)=G*((PTU(JL,IKB)-PTENH(JL,IKB))/PTENH(JL,IKB)+ & - 0.608*(PQU(JL,IKB)-PQENH(JL,IKB))) - IF (ZBUOY(JL).GT.0.) THEN - ZDZ = (PGEO(JL,IKB-1)-PGEO(JL,IKB))*ZRG - ZDRODZ = -LOG(PTEN(JL,IKB-1)/PTEN(JL,IKB))/ZDZ - & - G/(RD*PTENH(JL,IKB)) - ZOENTR(JL,IKB-1)=ZBUOY(JL)*0.5/(1.+ZBUOY(JL)*ZDZ) & - +ZDRODZ - ZOENTR(JL,IKB-1) = MIN(ZOENTR(JL,IKB-1),1.E-3) - ZOENTR(JL,IKB-1) = MAX(ZOENTR(JL,IKB-1),0.) - END IF -! New scheme -! Let's define the fscale - else if(orgen .eq. 2 ) then - tt(jl) = ptenh(jl,ikb-1) - zqsat(jl) = TLUCUA(tt(jl))/paph(jl,ikb-1) - zqsat(jl) = zqsat(jl)/(1.-VTMPC1*zqsat(jl)) - ttb(jl) = ptenh(jl,ikb) - zqsatb(jl) = TLUCUA(ttb(jl))/paph(jl,ikb) - zqsatb(jl) = zqsatb(jl)/(1.-VTMPC1*zqsatb(jl)) - fscale(jl) = (zqsat(jl)/zqsatb(jl))**3 -! end of defining the fscale - zoentr(jl,ikb-1) = 1.E-3*(1.3-PQEN(jl,ikb-1)/PQSEN(jl,ikb-1))*fscale(jl) - zoentr(jl,ikb-1) = MIN(zoentr(jl,ikb-1),1.E-3) - zoentr(jl,ikb-1) = MAX(zoentr(jl,ikb-1),0.) + do jl=1,klon + kctop(jl)=klevm1 + if(.not.ldcum(jl)) then + kcbot(jl)=klevm1 + pmfub(jl)=0. + pqu(jl,klev)=0. + end if + pmfu(jl,klev)=pmfub(jl) + pmfus(jl,klev)=pmfub(jl)*(cpd*ptu(jl,klev)+pgeoh(jl,klev)) + pmfuq(jl,klev)=pmfub(jl)*pqu(jl,klev) + if(lmfdudv) then + zmfuu(jl)=pmfub(jl)*puu(jl,klev) + zmfuv(jl)=pmfub(jl)*pvu(jl,klev) + end if + end do +! +!-- 3.1 find organized entrainment at cloud base +! + do jl=1,klon + ldcum(jl)=.false. + if (ktype(jl).eq.1) then + ikb = kcbot(jl) + zbuoy(jl)=g*((ptu(jl,ikb)-ptenh(jl,ikb))/ptenh(jl,ikb)+ & + 0.608*(pqu(jl,ikb)-pqenh(jl,ikb))) + if (zbuoy(jl).gt.0.) then + zdz = (pgeo(jl,ikb-1)-pgeo(jl,ikb))*zrg + zdrodz = -log(pten(jl,ikb-1)/pten(jl,ikb))/zdz - & + g/(rd*ptenh(jl,ikb)) + zoentr(jl,ikb-1)=zbuoy(jl)*0.5/(1.+zbuoy(jl)*zdz) & + +zdrodz + zoentr(jl,ikb-1) = min(zoentr(jl,ikb-1),1.e-3) + zoentr(jl,ikb-1) = max(zoentr(jl,ikb-1),0.) end if - END IF - 322 CONTINUE + end if + end do ! !----------------------------------------------------------------- -! 4. DO ASCENT: SUBCLOUD LAYER (KLAB=1) ,CLOUDS (KLAB=2) -! BY DOING FIRST DRY-ADIABATIC ASCENT AND THEN -! BY ADJUSTING T,Q AND L ACCORDINGLY IN *CUADJTQ*, -! THEN CHECK FOR BUOYANCY AND SET FLAGS ACCORDINGLY +! 4. do ascent: subcloud layer (klab=1) ,clouds (klab=2) +! by doing first dry-adiabatic ascent and then +! by adjusting t,q and l accordingly in *cuadjtq*, +! then check for buoyancy and set flags accordingly !----------------------------------------------------------------- - 400 CONTINUE - -! let's define the levels in which the middle level convection could be activated - do jk=KLEVM1,2,-1 - if(abs(paph(1,jk)*0.01 - 250) .lt. 50.) then - leveltop = jk - exit - end if - end do - leveltop = min(KLEV-15,leveltop) - levelbot = KLEVM1 - 4 - - DO 480 JK=KLEVM1,2,-1 -! SPECIFY CLOUD BASE VALUES FOR MIDLEVEL CONVECTION -! IN *CUBASMC* IN CASE THERE IS NOT ALREADY CONVECTION + do jk=klevm1,2,-1 +! specify cloud base values for midlevel convection +! in *cubasmc* in case there is not already convection ! --------------------------------------------------------------------- - IK=JK - IF(LMFMID.AND.IK.LT.levelbot.AND.IK.GT.leveltop) THEN - CALL CUBASMC & - (KLON, KLEV, KLEVM1, IK, PTEN, & - PQEN, PQSEN, PUEN, PVEN, PVERV, & - PGEO, PGEOH, LDCUM, KTYPE, KLAB, & - PMFU, PMFUB, PENTR, KCBOT, PTU, & - PQU, PLU, PUU, PVU, PMFUS, & - PMFUQ, PMFUL, PDMFUP, ZMFUU, ZMFUV) - ENDIF - IS=0 - DO 410 JL=1,KLON - ZQOLD(JL)=0.0 - IS=IS+KLAB(JL,JK+1) - IF(KLAB(JL,JK+1).EQ.0) KLAB(JL,JK)=0 - LOFLAG(JL)=KLAB(JL,JK+1).GT.0 - ZPH(JL)=PAPH(JL,JK) - IF(KTYPE(JL).EQ.3.AND.JK.EQ.KCBOT(JL)) THEN - ZMFMAX=(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2 - IF(PMFUB(JL).GT.ZMFMAX) THEN - ZFAC=ZMFMAX/PMFUB(JL) - PMFU(JL,JK+1)=PMFU(JL,JK+1)*ZFAC - PMFUS(JL,JK+1)=PMFUS(JL,JK+1)*ZFAC - PMFUQ(JL,JK+1)=PMFUQ(JL,JK+1)*ZFAC - ZMFUU(JL)=ZMFUU(JL)*ZFAC - ZMFUV(JL)=ZMFUV(JL)*ZFAC - PMFUB(JL)=ZMFMAX - END IF - END IF - 410 CONTINUE - IF(IS.EQ.0) GO TO 480 -! -!* SPECIFY ENTRAINMENT RATES IN *CUENTR_NEW* + ik=jk + if(lmfmid.and.ik.lt.klevm1.and.ik.gt.klev-13) then + call cubasmc & + (klon, klev, klevm1, ik, pten, & + pqen, pqsen, puen, pven, pverv, & + pgeo, pgeoh, ldcum, ktype, klab, & + pmfu, pmfub, pentr, kcbot, ptu, & + pqu, plu, puu, pvu, pmfus, & + pmfuq, pmful, pdmfup, zmfuu, zmfuv) + endif + is=0 + do jl=1,klon + zqold(jl)=0.0 + is=is+klab(jl,jk+1) + if(klab(jl,jk+1).eq.0) klab(jl,jk)=0 + loflag(jl)=klab(jl,jk+1).gt.0 + zph(jl)=paph(jl,jk) + if(ktype(jl).eq.3.and.jk.eq.kcbot(jl)) then + zmfmax=(paph(jl,jk)-paph(jl,jk-1))*zcons2 + if(pmfub(jl).gt.zmfmax) then + zfac=zmfmax/pmfub(jl) + pmfu(jl,jk+1)=pmfu(jl,jk+1)*zfac + pmfus(jl,jk+1)=pmfus(jl,jk+1)*zfac + pmfuq(jl,jk+1)=pmfuq(jl,jk+1)*zfac + zmfuu(jl)=zmfuu(jl)*zfac + zmfuv(jl)=zmfuv(jl)*zfac + pmfub(jl)=zmfmax + end if + end if + end do + + if(is.eq.0) cycle +! +!* specify entrainment rates in *cuentr_new* ! ------------------------------------- - IK=JK - CALL CUENTR_NEW & - (KLON, KLEV, KLEVP1, IK, PTENH,& - PAPH, PAP, PGEOH, KLWMIN, LDCUM,& - KTYPE, KCBOT, KCTOP0, ZPBASE, PMFU, & - PENTR, ZDMFEN, ZDMFDE, ZODETR, KHMIN) -! -! DO ADIABATIC ASCENT FOR ENTRAINING/DETRAINING PLUME + ik=jk + call cuentr_new & + (klon, klev, klevp1, ik, ptenh,& + paph, pap, pgeoh, klwmin, ldcum,& + ktype, kcbot, kctop0, zpbase, pmfu, & + pentr, zdmfen, zdmfde, zodetr, khmin) +! +! do adiabatic ascent for entraining/detraining plume ! ------------------------------------------------------- -! Do adiabatic ascent for entraining/detraining plume +! do adiabatic ascent for entraining/detraining plume ! the cloud ensemble entrains environmental values ! in turbulent detrainment cloud ensemble values are detrained ! in organized detrainment the dry static energy and ! moisture that are neutral compared to the ! environmental air are detrained ! - DO 420 JL=1,KLON - IF(LOFLAG(JL)) THEN - IF(JK.LT.KCBOT(JL)) THEN - ZMFTEST=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL) - ZMFMAX=MIN(ZMFTEST,(PAPH(JL,JK)-PAPH(JL,JK-1))*ZCONS2) - ZDMFEN(JL)=MAX(ZDMFEN(JL)-MAX(ZMFTEST-ZMFMAX,0.),0.) - END IF - ZDMFDE(JL)=MIN(ZDMFDE(JL),0.75*PMFU(JL,JK+1)) - PMFU(JL,JK)=PMFU(JL,JK+1)+ZDMFEN(JL)-ZDMFDE(JL) - IF (JK.LT.kcbot(jl)) THEN + do jl=1,klon + if(loflag(jl)) then + if(jk.lt.kcbot(jl)) then + zmftest=pmfu(jl,jk+1)+zdmfen(jl)-zdmfde(jl) + zmfmax=min(zmftest,(paph(jl,jk)-paph(jl,jk-1))*zcons2) + zdmfen(jl)=max(zdmfen(jl)-max(zmftest-zmfmax,0.),0.) + end if + zdmfde(jl)=min(zdmfde(jl),0.75*pmfu(jl,jk+1)) + pmfu(jl,jk)=pmfu(jl,jk+1)+zdmfen(jl)-zdmfde(jl) + if (jk.lt.kcbot(jl)) then zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg zoentr(jl,jk) = zoentr(jl,jk)*zdprho*pmfu(jl,jk+1) zmftest = pmfu(jl,jk) + zoentr(jl,jk)-zodetr(jl,jk) - zmfmax = MIN(zmftest,(paph(jl,jk)-paph(jl,jk-1))*zcons2) - zoentr(jl,jk) = MAX(zoentr(jl,jk)-MAX(zmftest-zmfmax,0.),0.) - END IF + zmfmax = min(zmftest,(paph(jl,jk)-paph(jl,jk-1))*zcons2) + zoentr(jl,jk) = max(zoentr(jl,jk)-max(zmftest-zmfmax,0.),0.) + end if ! ! limit organized detrainment to not allowing for too deep clouds ! - IF (ktype(jl).EQ.1.AND.jk.LT.kcbot(jl).AND.jk.LE.khmin(jl)) THEN + if (ktype(jl).eq.1.and.jk.lt.kcbot(jl).and.jk.le.khmin(jl)) then zmse = cpd*ptu(jl,jk+1) + alv*pqu(jl,jk+1) + pgeoh(jl,jk+1) ikt = kctop0(jl) znevn=(pgeoh(jl,ikt)-pgeoh(jl,jk+1))*(zmse-phhatt(jl, & jk+1))*zrg - IF (znevn.LE.0.) znevn = 1. + if (znevn.le.0.) znevn = 1. zdprho = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg zodmax = ((phcbase(jl)-zmse)/znevn)*zdprho*pmfu(jl,jk+1) - zodmax = MAX(zodmax,0.) - zodetr(jl,jk) = MIN(zodetr(jl,jk),zodmax) - END IF - zodetr(jl,jk) = MIN(zodetr(jl,jk),0.75*pmfu(jl,jk)) + zodmax = max(zodmax,0.) + zodetr(jl,jk) = min(zodetr(jl,jk),zodmax) + end if + zodetr(jl,jk) = min(zodetr(jl,jk),0.75*pmfu(jl,jk)) pmfu(jl,jk) = pmfu(jl,jk) + zoentr(jl,jk) - zodetr(jl,jk) - ZQEEN=PQENH(JL,JK+1)*ZDMFEN(JL) + zqeen=pqenh(jl,jk+1)*zdmfen(jl) zqeen=zqeen + pqenh(jl,jk+1)*zoentr(jl,jk) - ZSEEN=(CPD*PTENH(JL,JK+1)+PGEOH(JL,JK+1))*ZDMFEN(JL) + zseen=(cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))*zdmfen(jl) zseen=zseen+(cpd*ptenh(jl,jk+1)+pgeoh(jl,jk+1))* & zoentr(jl,jk) - ZSCDE=(CPD*PTU(JL,JK+1)+PGEOH(JL,JK+1))*ZDMFDE(JL) + zscde=(cpd*ptu(jl,jk+1)+pgeoh(jl,jk+1))*zdmfde(jl) ! find moist static energy that give nonbuoyant air zga = alv*pqsenh(jl,jk+1)/(rv*(ptenh(jl,jk+1)**2)) zdt = (plu(jl,jk+1)-0.608*(pqsenh(jl,jk+1)-pqenh(jl, & @@ -2182,1303 +1762,1273 @@ SUBROUTINE CUASC_NEW & zmfusk = pmfus(jl,jk+1) + zseen - zscde zmfuqk = pmfuq(jl,jk+1) + zqeen - zqude zmfulk = pmful(jl,jk+1) - plude(jl,jk) - plu(jl,jk) = zmfulk*(1./MAX(cmfcmin,pmfu(jl,jk))) - pqu(jl,jk) = zmfuqk*(1./MAX(cmfcmin,pmfu(jl,jk))) - ptu(jl,jk)=(zmfusk*(1./MAX(cmfcmin,pmfu(jl,jk)))- & + plu(jl,jk) = zmfulk*(1./max(cmfcmin,pmfu(jl,jk))) + pqu(jl,jk) = zmfuqk*(1./max(cmfcmin,pmfu(jl,jk))) + ptu(jl,jk)=(zmfusk*(1./max(cmfcmin,pmfu(jl,jk)))- & pgeoh(jl,jk))*rcpd - ptu(jl,jk) = MAX(100.,ptu(jl,jk)) - ptu(jl,jk) = MIN(400.,ptu(jl,jk)) + ptu(jl,jk) = max(100.,ptu(jl,jk)) + ptu(jl,jk) = min(400.,ptu(jl,jk)) zqold(jl) = pqu(jl,jk) - END IF - 420 CONTINUE -!* DO CORRECTIONS FOR MOIST ASCENT -!* BY ADJUSTING T,Q AND L IN *CUADJTQ* + end if + end do +!* do corrections for moist ascent +!* by adjusting t,q and l in *cuadjtq* !------------------------------------------------ - IK=JK - ICALL=1 -! - CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTU,PQU,LOFLAG,ICALL) -! - DO 440 JL=1,KLON - IF(LOFLAG(JL).AND.PQU(JL,JK).NE.ZQOLD(JL)) THEN - KLAB(JL,JK)=2 - PLU(JL,JK)=PLU(JL,JK)+ZQOLD(JL)-PQU(JL,JK) - ZBUO=PTU(JL,JK)*(1.+VTMPC1*PQU(JL,JK)-PLU(JL,JK))- & - PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK)) - IF(KLAB(JL,JK+1).EQ.1) ZBUO=ZBUO+ZBUO0 - IF(ZBUO.GT.0..AND.PMFU(JL,JK).GT.0.01*PMFUB(JL).AND. & - JK.GE.KCTOP0(JL)) THEN - KCTOP(JL)=JK - LDCUM(JL)=.TRUE. - IF(ZPBASE(JL)-PAPH(JL,JK).GE.ZDNOPRC) THEN - ZPRCON=CPRCON - ELSE - ZPRCON=0. - ENDIF - ZLNEW=PLU(JL,JK)/(1.+ZPRCON*(PGEOH(JL,JK)-PGEOH(JL,JK+1))) - PDMFUP(JL,JK)=MAX(0.,(PLU(JL,JK)-ZLNEW)*PMFU(JL,JK)) - PLU(JL,JK)=ZLNEW - ELSE - KLAB(JL,JK)=0 - PMFU(JL,JK)=0. - END IF - END IF - IF(LOFLAG(JL)) THEN - PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK) - PMFUS(JL,JK)=(CPD*PTU(JL,JK)+PGEOH(JL,JK))*PMFU(JL,JK) - PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK) - END IF - 440 CONTINUE -! - IF(LMFDUDV) THEN -! - DO 460 JL=1,KLON + ik=jk + icall=1 +! + call cuadjtq(klon,klev,ik,zph,ptu,pqu,loflag,icall) +! + do jl=1,klon + if(loflag(jl).and.pqu(jl,jk).ne.zqold(jl)) then + klab(jl,jk)=2 + plu(jl,jk)=plu(jl,jk)+zqold(jl)-pqu(jl,jk) + zbuo=ptu(jl,jk)*(1.+vtmpc1*pqu(jl,jk)-plu(jl,jk))- & + ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + if(klab(jl,jk+1).eq.1) zbuo=zbuo+zbuo0 + if(zbuo.gt.0..and.pmfu(jl,jk).gt.0.01*pmfub(jl).and. & + jk.ge.kctop0(jl)) then + kctop(jl)=jk + ldcum(jl)=.true. + if(zpbase(jl)-paph(jl,jk).ge.zdnoprc) then + zprcon=cprcon + else + zprcon=0. + endif + zlnew=plu(jl,jk)/(1.+zprcon*(pgeoh(jl,jk)-pgeoh(jl,jk+1))) + pdmfup(jl,jk)=max(0.,(plu(jl,jk)-zlnew)*pmfu(jl,jk)) + plu(jl,jk)=zlnew + else + klab(jl,jk)=0 + pmfu(jl,jk)=0. + end if + end if + if(loflag(jl)) then + pmful(jl,jk)=plu(jl,jk)*pmfu(jl,jk) + pmfus(jl,jk)=(cpd*ptu(jl,jk)+pgeoh(jl,jk))*pmfu(jl,jk) + pmfuq(jl,jk)=pqu(jl,jk)*pmfu(jl,jk) + end if + end do +! + if(lmfdudv) then +! + do jl=1,klon zdmfen(jl) = zdmfen(jl) + zoentr(jl,jk) zdmfde(jl) = zdmfde(jl) + zodetr(jl,jk) - IF(LOFLAG(JL)) THEN - IF(KTYPE(JL).EQ.1.OR.KTYPE(JL).EQ.3) THEN - IF(ZDMFEN(JL).LE.1.E-20) THEN - ZZ=3. - ELSE - ZZ=2. - ENDIF - ELSE - IF(ZDMFEN(JL).LE.1.0E-20) THEN - ZZ=1. - ELSE - ZZ=0. - ENDIF - END IF - ZDMFEU=ZDMFEN(JL)+ZZ*ZDMFDE(JL) - ZDMFDU=ZDMFDE(JL)+ZZ*ZDMFDE(JL) - ZDMFDU=MIN(ZDMFDU,0.75*PMFU(JL,JK+1)) - ZMFUU(JL)=ZMFUU(JL)+ & - ZDMFEU*PUEN(JL,JK)-ZDMFDU*PUU(JL,JK+1) - ZMFUV(JL)=ZMFUV(JL)+ & - ZDMFEU*PVEN(JL,JK)-ZDMFDU*PVU(JL,JK+1) - IF(PMFU(JL,JK).GT.0.) THEN - PUU(JL,JK)=ZMFUU(JL)*(1./PMFU(JL,JK)) - PVU(JL,JK)=ZMFUV(JL)*(1./PMFU(JL,JK)) - END IF - END IF - 460 CONTINUE -! - END IF -! -! Compute organized entrainment + if(loflag(jl)) then + if(ktype(jl).eq.1.or.ktype(jl).eq.3) then + if(zdmfen(jl).le.1.e-20) then + zz=3. + else + zz=2. + endif + else + if(zdmfen(jl).le.1.0e-20) then + zz=1. + else + zz=0. + endif + end if + zdmfeu=zdmfen(jl)+zz*zdmfde(jl) + zdmfdu=zdmfde(jl)+zz*zdmfde(jl) + zdmfdu=min(zdmfdu,0.75*pmfu(jl,jk+1)) + zmfuu(jl)=zmfuu(jl)+ & + zdmfeu*puen(jl,jk)-zdmfdu*puu(jl,jk+1) + zmfuv(jl)=zmfuv(jl)+ & + zdmfeu*pven(jl,jk)-zdmfdu*pvu(jl,jk+1) + if(pmfu(jl,jk).gt.0.) then + puu(jl,jk)=zmfuu(jl)*(1./pmfu(jl,jk)) + pvu(jl,jk)=zmfuv(jl)*(1./pmfu(jl,jk)) + end if + end if + end do +! + end if +! +! compute organized entrainment ! for use at next level ! - DO 470 jl = 1, klon - IF (loflag(jl).AND.ktype(jl).EQ.1) THEN -! old scheme - if(orgen .eq. 1 ) then + do jl = 1, klon + if (loflag(jl).and.ktype(jl).eq.1) then zbuoyz=g*((ptu(jl,jk)-ptenh(jl,jk))/ptenh(jl,jk)+ & 0.608*(pqu(jl,jk)-pqenh(jl,jk))-plu(jl,jk)) - zbuoyz = MAX(zbuoyz,0.0) + zbuoyz = max(zbuoyz,0.0) zdz = (pgeo(jl,jk-1)-pgeo(jl,jk))*zrg - zdrodz = -LOG(pten(jl,jk-1)/pten(jl,jk))/zdz - & + zdrodz = -log(pten(jl,jk-1)/pten(jl,jk))/zdz - & g/(rd*ptenh(jl,jk)) zbuoy(jl) = zbuoy(jl) + zbuoyz*zdz zoentr(jl,jk-1) = zbuoyz*0.5/(1.+zbuoy(jl))+zdrodz - zoentr(jl,jk-1) = MIN(zoentr(jl,jk-1),1.E-3) - zoentr(jl,jk-1) = MAX(zoentr(jl,jk-1),0.) - else if(orgen .eq. 2 ) then -! Let's define the fscale - tt(jl) = ptenh(jl,jk-1) - zqsat(jl) = TLUCUA(tt(jl))/paph(jl,jk-1) - zqsat(jl) = zqsat(jl)/(1.-VTMPC1*zqsat(jl)) - ttb(jl) = ptenh(jl,kcbot(jl)) - zqsatb(jl) = TLUCUA(ttb(jl))/paph(jl,kcbot(jl)) - zqsatb(jl) = zqsatb(jl)/(1.-VTMPC1*zqsatb(jl)) - fscale(jl) = (zqsat(jl)/zqsatb(jl))**3 -! end of defining the fscale - zoentr(jl,jk-1) = 1.E-3*(1.3-PQEN(jl,jk-1)/PQSEN(jl,jk-1))*fscale(jl) - zoentr(jl,jk-1) = MIN(zoentr(jl,jk-1),1.E-3) - zoentr(jl,jk-1) = MAX(zoentr(jl,jk-1),0.) -! write(6,*) "zoentr=",zoentr(jl,jk-1) + zoentr(jl,jk-1) = min(zoentr(jl,jk-1),1.e-3) + zoentr(jl,jk-1) = max(zoentr(jl,jk-1),0.) end if - END IF - 470 CONTINUE + end do ! - 480 CONTINUE + end do ! end outer cycle ! ----------------------------------------------------------------- -! 5. DETERMINE CONVECTIVE FLUXES ABOVE NON-BUOYANCY LEVEL +! 5. determine convective fluxes above non-buoyancy level ! ----------------------------------------------------------------- -! (NOTE: CLOUD VARIABLES LIKE T,Q AND L ARE NOT -! AFFECTED BY DETRAINMENT AND ARE ALREADY KNOWN -! FROM PREVIOUS CALCULATIONS ABOVE) - 500 CONTINUE - DO 510 JL=1,KLON - IF(KCTOP(JL).EQ.KLEVM1) LDCUM(JL)=.FALSE. - KCBOT(JL)=MAX(KCBOT(JL),KCTOP(JL)) - 510 CONTINUE - IS=0 - DO 520 JL=1,KLON - IF(LDCUM(JL)) THEN - IS=IS+1 - ENDIF - 520 CONTINUE - KCUM=IS - IF(IS.EQ.0) GO TO 800 - DO 530 JL=1,KLON - IF(LDCUM(JL)) THEN - JK=KCTOP(JL)-1 - ZZDMF=CMFCTOP - ZDMFDE(JL)=(1.-ZZDMF)*PMFU(JL,JK+1) - PLUDE(JL,JK)=ZDMFDE(JL)*PLU(JL,JK+1) - PMFU(JL,JK)=PMFU(JL,JK+1)-ZDMFDE(JL) - PMFUS(JL,JK)=(CPD*PTU(JL,JK)+PGEOH(JL,JK))*PMFU(JL,JK) - PMFUQ(JL,JK)=PQU(JL,JK)*PMFU(JL,JK) - PMFUL(JL,JK)=PLU(JL,JK)*PMFU(JL,JK) - PLUDE(JL,JK-1)=PMFUL(JL,JK) - PDMFUP(JL,JK)=0. - END IF - 530 CONTINUE - IF(LMFDUDV) THEN - DO 540 JL=1,KLON - IF(LDCUM(JL)) THEN - JK=KCTOP(JL)-1 - PUU(JL,JK)=PUU(JL,JK+1) - PVU(JL,JK)=PVU(JL,JK+1) - END IF - 540 CONTINUE - END IF - 800 CONTINUE - RETURN - END SUBROUTINE CUASC_NEW +! (note: cloud variables like t,q and l are not +! affected by detrainment and are already known +! from previous calculations above) + do jl=1,klon + if(kctop(jl).eq.klevm1) ldcum(jl)=.false. + kcbot(jl)=max(kcbot(jl),kctop(jl)) + end do + + is=0 + do jl=1,klon + if(ldcum(jl)) then + is=is+1 + endif + end do + kcum=is + if(is.eq.0) return + do jl=1,klon + if(ldcum(jl)) then + jk=kctop(jl)-1 + zzdmf=cmfctop + zdmfde(jl)=(1.-zzdmf)*pmfu(jl,jk+1) + plude(jl,jk)=zdmfde(jl)*plu(jl,jk+1) + pmfu(jl,jk)=pmfu(jl,jk+1)-zdmfde(jl) + pmfus(jl,jk)=(cpd*ptu(jl,jk)+pgeoh(jl,jk))*pmfu(jl,jk) + pmfuq(jl,jk)=pqu(jl,jk)*pmfu(jl,jk) + pmful(jl,jk)=plu(jl,jk)*pmfu(jl,jk) + plude(jl,jk-1)=pmful(jl,jk) + pdmfup(jl,jk)=0. + end if + end do + + if(lmfdudv) then + do jl=1,klon + if(ldcum(jl)) then + jk=kctop(jl)-1 + puu(jl,jk)=puu(jl,jk+1) + pvu(jl,jk)=pvu(jl,jk+1) + end if + end do + end if + return + end subroutine cuasc_new ! !********************************************** -! SUBROUTINE CUDLFS +! subroutine cudlfs !********************************************** - SUBROUTINE CUDLFS & - (KLON, KLEV, KLEVP1, PTENH, PQENH, & - PUEN, PVEN, PGEOH, PAPH, PTU, & - PQU, PUU, PVU, LDCUM, KCBOT, & - KCTOP, PMFUB, PRFL, PTD, PQD, & - PUD, PVD, PMFD, PMFDS, PMFDQ, & - PDMFDP, KDTOP, LDDRAF) -! THIS ROUTINE CALCULATES LEVEL OF FREE SINKING FOR -! CUMULUS DOWNDRAFTS AND SPECIFIES T,Q,U AND V VALUES -! M.TIEDTKE E.C.M.W.F. 12/86 MODIF. 12/89 -!***PURPOSE. + subroutine cudlfs & + (klon, klev, klevp1, ptenh, pqenh, & + puen, pven, pgeoh, paph, ptu, & + pqu, puu, pvu, ldcum, kcbot, & + kctop, pmfub, prfl, ptd, pqd, & + pud, pvd, pmfd, pmfds, pmfdq, & + pdmfdp, kdtop, lddraf) +! this routine calculates level of free sinking for +! cumulus downdrafts and specifies t,q,u and v values +! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 +!***purpose. ! -------- -! TO PRODUCE LFS-VALUES FOR CUMULUS DOWNDRAFTS -! FOR MASSFLUX CUMULUS PARAMETERIZATION -!***INTERFACE +! to produce lfs-values for cumulus downdrafts +! for massflux cumulus parameterization +!***interface ! --------- -! THIS ROUTINE IS CALLED FROM *CUMASTR*. -! INPUT ARE ENVIRONMENTAL VALUES OF T,Q,U,V,P,PHI -! AND UPDRAFT VALUES T,Q,U AND V AND ALSO -! CLOUD BASE MASSFLUX AND CU-PRECIPITATION RATE. -! IT RETURNS T,Q,U AND V VALUES AND MASSFLUX AT LFS. -!***METHOD. +! this routine is called from *cumastr*. +! input are environmental values of t,q,u,v,p,phi +! and updraft values t,q,u and v and also +! cloud base massflux and cu-precipitation rate. +! it returns t,q,u and v values and massflux at lfs. +!***method. ! -------- -! CHECK FOR NEGATIVE BUOYANCY OF AIR OF EQUAL PARTS OF -! MOIST ENVIRONMENTAL AIR AND CLOUD AIR. -!***EXTERNALS +! check for negative buoyancy of air of equal parts of +! moist environmental air and cloud air. +!***externals ! --------- -! *CUADJTQ* FOR CALCULATING WET BULB T AND Q AT LFS +! *cuadjtq* for calculating wet bulb t and q at lfs ! ---------------------------------------------------------------- !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER JL,KE,JK,IS,IK,ICALL - REAL ZTTEST, ZQTEST, ZBUO, ZMFTOP - REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), & - PUEN(KLON,KLEV), PVEN(KLON,KLEV), & - PGEOH(KLON,KLEV), PAPH(KLON,KLEVP1), & - PTU(KLON,KLEV), PQU(KLON,KLEV), & - PUU(KLON,KLEV), PVU(KLON,KLEV), & - PMFUB(KLON), PRFL(KLON) - REAL PTD(KLON,KLEV), PQD(KLON,KLEV), & - PUD(KLON,KLEV), PVD(KLON,KLEV), & - PMFD(KLON,KLEV), PMFDS(KLON,KLEV), & - PMFDQ(KLON,KLEV), PDMFDP(KLON,KLEV) - REAL ZTENWB(KLON,KLEV), ZQENWB(KLON,KLEV), & - ZCOND(KLON), ZPH(KLON) - INTEGER KCBOT(KLON), KCTOP(KLON), & - KDTOP(KLON) - LOGICAL LDCUM(KLON), LLo2(KLON), & - LDDRAF(KLON) + integer klon, klev, klevp1 + integer jl,ke,jk,is,ik,icall + real zttest, zqtest, zbuo, zmftop + real ptenh(klon,klev), pqenh(klon,klev), & + puen(klon,klev), pven(klon,klev), & + pgeoh(klon,klev), paph(klon,klevp1), & + ptu(klon,klev), pqu(klon,klev), & + puu(klon,klev), pvu(klon,klev), & + pmfub(klon), prfl(klon) + real ptd(klon,klev), pqd(klon,klev), & + pud(klon,klev), pvd(klon,klev), & + pmfd(klon,klev), pmfds(klon,klev), & + pmfdq(klon,klev), pdmfdp(klon,klev) + real ztenwb(klon,klev), zqenwb(klon,klev), & + zcond(klon), zph(klon) + integer kcbot(klon), kctop(klon), & + kdtop(klon) + logical ldcum(klon), llo2(klon), & + lddraf(klon) !----------------------------------------------- -! 1. SET DEFAULT VALUES FOR DOWNDRAFTS +! 1. set default values for downdrafts !----------------------------------------------- - 100 CONTINUE - DO 110 JL=1,KLON - LDDRAF(JL)=.FALSE. - KDTOP(JL)=KLEVP1 - 110 CONTINUE - IF(.NOT.LMFDD) GO TO 300 + do jl=1,klon + lddraf(jl)=.false. + kdtop(jl)=klevp1 + end do + if(.not.lmfdd) return !------------------------------------------------------------ -! 2. DETERMINE LEVEL OF FREE SINKING BY -! DOING A SCAN FROM TOP TO BASE OF CUMULUS CLOUDS -! FOR EVERY POINT AND PROCEED AS FOLLOWS: -! (1) DETEMINE WET BULB ENVIRONMENTAL T AND Q -! (2) DO MIXING WITH CUMULUS CLOUD AIR -! (3) CHECK FOR NEGATIVE BUOYANCY -! THE ASSUMPTION IS THAT AIR OF DOWNDRAFTS IS MIXTURE -! OF 50% CLOUD AIR + 50% ENVIRONMENTAL AIR AT WET BULB -! TEMPERATURE (I.E. WHICH BECAME SATURATED DUE TO -! EVAPORATION OF RAIN AND CLOUD WATER) +! 2. determine level of free sinking by +! doing a scan from top to base of cumulus clouds +! for every point and proceed as follows: +! (1) detemine wet bulb environmental t and q +! (2) do mixing with cumulus cloud air +! (3) check for negative buoyancy +! the assumption is that air of downdrafts is mixture +! of 50% cloud air + 50% environmental air at wet bulb +! temperature (i.e. which became saturated due to +! evaporation of rain and cloud water) !------------------------------------------------------------------ - 200 CONTINUE - KE=KLEV-3 - DO 290 JK=3,KE -! 2.1 CALCULATE WET-BULB TEMPERATURE AND MOISTURE -! FOR ENVIRONMENTAL AIR IN *CUADJTQ* + ke=klev-3 + do jk=3,ke +! 2.1 calculate wet-bulb temperature and moisture +! for environmental air in *cuadjtq* ! ----------------------------------------------------- - 210 CONTINUE - IS=0 - DO 212 JL=1,KLON - ZTENWB(JL,JK)=PTENH(JL,JK) - ZQENWB(JL,JK)=PQENH(JL,JK) - ZPH(JL)=PAPH(JL,JK) - LLO2(JL)=LDCUM(JL).AND.PRFL(JL).GT.0..AND..NOT.LDDRAF(JL).AND. & - (JK.LT.KCBOT(JL).AND.JK.GT.KCTOP(JL)) - IF(LLO2(JL))THEN - IS=IS+1 - ENDIF - 212 CONTINUE - IF(IS.EQ.0) GO TO 290 - IK=JK - ICALL=2 - CALL CUADJTQ(KLON,KLEV,IK,ZPH,ZTENWB,ZQENWB,LLO2,ICALL) -! 2.2 DO MIXING OF CUMULUS AND ENVIRONMENTAL AIR -! AND CHECK FOR NEGATIVE BUOYANCY. -! THEN SET VALUES FOR DOWNDRAFT AT LFS. + is=0 + do jl=1,klon + ztenwb(jl,jk)=ptenh(jl,jk) + zqenwb(jl,jk)=pqenh(jl,jk) + zph(jl)=paph(jl,jk) + llo2(jl)=ldcum(jl).and.prfl(jl).gt.0..and..not.lddraf(jl).and. & + (jk.lt.kcbot(jl).and.jk.gt.kctop(jl)) + if(llo2(jl))then + is=is+1 + endif + end do + + if(is.eq.0) cycle + ik=jk + icall=2 + call cuadjtq(klon,klev,ik,zph,ztenwb,zqenwb,llo2,icall) +! 2.2 do mixing of cumulus and environmental air +! and check for negative buoyancy. +! then set values for downdraft at lfs. ! ----------------------------------------------------- - 220 CONTINUE - DO 222 JL=1,KLON - IF(LLO2(JL)) THEN - ZTTEST=0.5*(PTU(JL,JK)+ZTENWB(JL,JK)) - ZQTEST=0.5*(PQU(JL,JK)+ZQENWB(JL,JK)) - ZBUO=ZTTEST*(1.+VTMPC1*ZQTEST)- & - PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK)) - ZCOND(JL)=PQENH(JL,JK)-ZQENWB(JL,JK) - ZMFTOP=-CMFDEPS*PMFUB(JL) - IF(ZBUO.LT.0..AND.PRFL(JL).GT.10.*ZMFTOP*ZCOND(JL)) THEN - KDTOP(JL)=JK - LDDRAF(JL)=.TRUE. - PTD(JL,JK)=ZTTEST - PQD(JL,JK)=ZQTEST - PMFD(JL,JK)=ZMFTOP - PMFDS(JL,JK)=PMFD(JL,JK)*(CPD*PTD(JL,JK)+PGEOH(JL,JK)) - PMFDQ(JL,JK)=PMFD(JL,JK)*PQD(JL,JK) - PDMFDP(JL,JK-1)=-0.5*PMFD(JL,JK)*ZCOND(JL) - PRFL(JL)=PRFL(JL)+PDMFDP(JL,JK-1) - END IF - END IF - 222 CONTINUE - IF(LMFDUDV) THEN - DO 224 JL=1,KLON - IF(PMFD(JL,JK).LT.0.) THEN - PUD(JL,JK)=0.5*(PUU(JL,JK)+PUEN(JL,JK-1)) - PVD(JL,JK)=0.5*(PVU(JL,JK)+PVEN(JL,JK-1)) - END IF - 224 CONTINUE - END IF - 290 CONTINUE - 300 CONTINUE - RETURN - END SUBROUTINE CUDLFS + do jl=1,klon + if(llo2(jl)) then + zttest=0.5*(ptu(jl,jk)+ztenwb(jl,jk)) + zqtest=0.5*(pqu(jl,jk)+zqenwb(jl,jk)) + zbuo=zttest*(1.+vtmpc1*zqtest)- & + ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + zcond(jl)=pqenh(jl,jk)-zqenwb(jl,jk) + zmftop=-cmfdeps*pmfub(jl) + if(zbuo.lt.0..and.prfl(jl).gt.10.*zmftop*zcond(jl)) then + kdtop(jl)=jk + lddraf(jl)=.true. + ptd(jl,jk)=zttest + pqd(jl,jk)=zqtest + pmfd(jl,jk)=zmftop + pmfds(jl,jk)=pmfd(jl,jk)*(cpd*ptd(jl,jk)+pgeoh(jl,jk)) + pmfdq(jl,jk)=pmfd(jl,jk)*pqd(jl,jk) + pdmfdp(jl,jk-1)=-0.5*pmfd(jl,jk)*zcond(jl) + prfl(jl)=prfl(jl)+pdmfdp(jl,jk-1) + end if + end if + end do + + if(lmfdudv) then + do jl=1,klon + if(pmfd(jl,jk).lt.0.) then + pud(jl,jk)=0.5*(puu(jl,jk)+puen(jl,jk-1)) + pvd(jl,jk)=0.5*(pvu(jl,jk)+pven(jl,jk-1)) + end if + end do + end if + + end do + return + end subroutine cudlfs ! !********************************************** -! SUBROUTINE CUDDRAF +! subroutine cuddraf !********************************************** - SUBROUTINE CUDDRAF & - (KLON, KLEV, KLEVP1, PTENH, PQENH, & - PUEN, PVEN, PGEOH, PAPH, PRFL, & - LDDRAF, PTD, PQD, PUD, PVD, & - PMFD, PMFDS, PMFDQ, PDMFDP) -! THIS ROUTINE CALCULATES CUMULUS DOWNDRAFT DESCENT -! M.TIEDTKE E.C.M.W.F. 12/86 MODIF. 12/89 -!***PURPOSE. + subroutine cuddraf & + (klon, klev, klevp1, ptenh, pqenh, & + puen, pven, pgeoh, paph, prfl, & + lddraf, ptd, pqd, pud, pvd, & + pmfd, pmfds, pmfdq, pdmfdp) +! this routine calculates cumulus downdraft descent +! m.tiedtke e.c.m.w.f. 12/86 modif. 12/89 +!***purpose. ! -------- -! TO PRODUCE THE VERTICAL PROFILES FOR CUMULUS DOWNDRAFTS -! (I.E. T,Q,U AND V AND FLUXES) -!***INTERFACE +! to produce the vertical profiles for cumulus downdrafts +! (i.e. t,q,u and v and fluxes) +!***interface ! --------- -! THIS ROUTINE IS CALLED FROM *CUMASTR*. -! INPUT IS T,Q,P,PHI,U,V AT HALF LEVELS. -! IT RETURNS FLUXES OF S,Q AND EVAPORATION RATE -! AND U,V AT LEVELS WHERE DOWNDRAFT OCCURS -!***METHOD. +! this routine is called from *cumastr*. +! input is t,q,p,phi,u,v at half levels. +! it returns fluxes of s,q and evaporation rate +! and u,v at levels where downdraft occurs +!***method. ! -------- -! CALCULATE MOIST DESCENT FOR ENTRAINING/DETRAINING PLUME BY -! A) MOVING AIR DRY-ADIABATICALLY TO NEXT LEVEL BELOW AND -! B) CORRECTING FOR EVAPORATION TO OBTAIN SATURATED STATE. -!***EXTERNALS +! calculate moist descent for entraining/detraining plume by +! a) moving air dry-adiabatically to next level below and +! b) correcting for evaporation to obtain saturated state. +!***externals ! --------- -! *CUADJTQ* FOR ADJUSTING T AND Q DUE TO EVAPORATION IN -! SATURATED DESCENT -!***REFERENCE +! *cuadjtq* for adjusting t and q due to evaporation in +! saturated descent +!***reference ! --------- -! (TIEDTKE,1989) +! (tiedtke,1989) ! ---------------------------------------------------------------- !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER JK,IS,JL,ITOPDE, IK, ICALL - REAL ZENTR,ZSEEN, ZQEEN, ZSDDE, ZQDDE,ZMFDSK, ZMFDQK - REAL ZBUO, ZDMFDP, ZMFDUK, ZMFDVK - REAL PTENH(KLON,KLEV), PQENH(KLON,KLEV), & - PUEN(KLON,KLEV), PVEN(KLON,KLEV), & - PGEOH(KLON,KLEV), PAPH(KLON,KLEVP1) - REAL PTD(KLON,KLEV), PQD(KLON,KLEV), & - PUD(KLON,KLEV), PVD(KLON,KLEV), & - PMFD(KLON,KLEV), PMFDS(KLON,KLEV), & - PMFDQ(KLON,KLEV), PDMFDP(KLON,KLEV), & - PRFL(KLON) - REAL ZDMFEN(KLON), ZDMFDE(KLON), & - ZCOND(KLON), ZPH(KLON) - LOGICAL LDDRAF(KLON), LLO2(KLON) + integer klon, klev, klevp1 + integer jk,is,jl,itopde, ik, icall + real zentr,zseen, zqeen, zsdde, zqdde,zmfdsk, zmfdqk + real zbuo, zdmfdp, zmfduk, zmfdvk + real ptenh(klon,klev), pqenh(klon,klev), & + puen(klon,klev), pven(klon,klev), & + pgeoh(klon,klev), paph(klon,klevp1) + real ptd(klon,klev), pqd(klon,klev), & + pud(klon,klev), pvd(klon,klev), & + pmfd(klon,klev), pmfds(klon,klev), & + pmfdq(klon,klev), pdmfdp(klon,klev), & + prfl(klon) + real zdmfen(klon), zdmfde(klon), & + zcond(klon), zph(klon) + logical lddraf(klon), llo2(klon) !-------------------------------------------------------------- -! 1. CALCULATE MOIST DESCENT FOR CUMULUS DOWNDRAFT BY -! (A) CALCULATING ENTRAINMENT RATES, ASSUMING -! LINEAR DECREASE OF MASSFLUX IN PBL -! (B) DOING MOIST DESCENT - EVAPORATIVE COOLING -! AND MOISTENING IS CALCULATED IN *CUADJTQ* -! (C) CHECKING FOR NEGATIVE BUOYANCY AND -! SPECIFYING FINAL T,Q,U,V AND DOWNWARD FLUXES +! 1. calculate moist descent for cumulus downdraft by +! (a) calculating entrainment rates, assuming +! linear decrease of massflux in pbl +! (b) doing moist descent - evaporative cooling +! and moistening is calculated in *cuadjtq* +! (c) checking for negative buoyancy and +! specifying final t,q,u,v and downward fluxes ! ---------------------------------------------------------------- - 100 CONTINUE - DO 180 JK=3,KLEV - IS=0 - DO 110 JL=1,KLON - ZPH(JL)=PAPH(JL,JK) - LLO2(JL)=LDDRAF(JL).AND.PMFD(JL,JK-1).LT.0. - IF(LLO2(JL)) THEN - IS=IS+1 - ENDIF - 110 CONTINUE - IF(IS.EQ.0) GO TO 180 - DO 122 JL=1,KLON - IF(LLO2(JL)) THEN - ZENTR=ENTRDD*PMFD(JL,JK-1)*RD*PTENH(JL,JK-1)/ & - (G*PAPH(JL,JK-1))*(PAPH(JL,JK)-PAPH(JL,JK-1)) - ZDMFEN(JL)=ZENTR - ZDMFDE(JL)=ZENTR - END IF - 122 CONTINUE - ITOPDE=KLEV-2 - IF(JK.GT.ITOPDE) THEN - DO 124 JL=1,KLON - IF(LLO2(JL)) THEN - ZDMFEN(JL)=0. - ZDMFDE(JL)=PMFD(JL,ITOPDE)* & - (PAPH(JL,JK)-PAPH(JL,JK-1))/ & - (PAPH(JL,KLEVP1)-PAPH(JL,ITOPDE)) - END IF - 124 CONTINUE - END IF - DO 126 JL=1,KLON - IF(LLO2(JL)) THEN - PMFD(JL,JK)=PMFD(JL,JK-1)+ZDMFEN(JL)-ZDMFDE(JL) - ZSEEN=(CPD*PTENH(JL,JK-1)+PGEOH(JL,JK-1))*ZDMFEN(JL) - ZQEEN=PQENH(JL,JK-1)*ZDMFEN(JL) - ZSDDE=(CPD*PTD(JL,JK-1)+PGEOH(JL,JK-1))*ZDMFDE(JL) - ZQDDE=PQD(JL,JK-1)*ZDMFDE(JL) - ZMFDSK=PMFDS(JL,JK-1)+ZSEEN-ZSDDE - ZMFDQK=PMFDQ(JL,JK-1)+ZQEEN-ZQDDE - PQD(JL,JK)=ZMFDQK*(1./MIN(-CMFCMIN,PMFD(JL,JK))) - PTD(JL,JK)=(ZMFDSK*(1./MIN(-CMFCMIN,PMFD(JL,JK)))- & - PGEOH(JL,JK))*RCPD - PTD(JL,JK)=MIN(400.,PTD(JL,JK)) - PTD(JL,JK)=MAX(100.,PTD(JL,JK)) - ZCOND(JL)=PQD(JL,JK) - END IF - 126 CONTINUE - IK=JK - ICALL=2 - CALL CUADJTQ(KLON,KLEV,IK,ZPH,PTD,PQD,LLO2,ICALL) - DO 150 JL=1,KLON - IF(LLO2(JL)) THEN - ZCOND(JL)=ZCOND(JL)-PQD(JL,JK) - ZBUO=PTD(JL,JK)*(1.+VTMPC1*PQD(JL,JK))- & - PTENH(JL,JK)*(1.+VTMPC1*PQENH(JL,JK)) - IF(ZBUO.GE.0..OR.PRFL(JL).LE.(PMFD(JL,JK)*ZCOND(JL))) THEN - PMFD(JL,JK)=0. - ENDIF - PMFDS(JL,JK)=(CPD*PTD(JL,JK)+PGEOH(JL,JK))*PMFD(JL,JK) - PMFDQ(JL,JK)=PQD(JL,JK)*PMFD(JL,JK) - ZDMFDP=-PMFD(JL,JK)*ZCOND(JL) - PDMFDP(JL,JK-1)=ZDMFDP - PRFL(JL)=PRFL(JL)+ZDMFDP - END IF - 150 CONTINUE - IF(LMFDUDV) THEN - DO 160 JL=1,KLON - IF(LLO2(JL).AND.PMFD(JL,JK).LT.0.) THEN - ZMFDUK=PMFD(JL,JK-1)*PUD(JL,JK-1)+ & - ZDMFEN(JL)*PUEN(JL,JK-1)-ZDMFDE(JL)*PUD(JL,JK-1) - ZMFDVK=PMFD(JL,JK-1)*PVD(JL,JK-1)+ & - ZDMFEN(JL)*PVEN(JL,JK-1)-ZDMFDE(JL)*PVD(JL,JK-1) - PUD(JL,JK)=ZMFDUK*(1./MIN(-CMFCMIN,PMFD(JL,JK))) - PVD(JL,JK)=ZMFDVK*(1./MIN(-CMFCMIN,PMFD(JL,JK))) - END IF - 160 CONTINUE - END IF - 180 CONTINUE - RETURN - END SUBROUTINE CUDDRAF + do jk=3,klev + is=0 + do jl=1,klon + zph(jl)=paph(jl,jk) + llo2(jl)=lddraf(jl).and.pmfd(jl,jk-1).lt.0. + if(llo2(jl)) then + is=is+1 + endif + end do + + if(is.eq.0) cycle + do jl=1,klon + if(llo2(jl)) then + zentr=entrdd*pmfd(jl,jk-1)*rd*ptenh(jl,jk-1)/ & + (g*paph(jl,jk-1))*(paph(jl,jk)-paph(jl,jk-1)) + zdmfen(jl)=zentr + zdmfde(jl)=zentr + end if + end do + + itopde=klev-2 + if(jk.gt.itopde) then + do jl=1,klon + if(llo2(jl)) then + zdmfen(jl)=0. + zdmfde(jl)=pmfd(jl,itopde)* & + (paph(jl,jk)-paph(jl,jk-1))/ & + (paph(jl,klevp1)-paph(jl,itopde)) + end if + end do + end if + + do jl=1,klon + if(llo2(jl)) then + pmfd(jl,jk)=pmfd(jl,jk-1)+zdmfen(jl)-zdmfde(jl) + zseen=(cpd*ptenh(jl,jk-1)+pgeoh(jl,jk-1))*zdmfen(jl) + zqeen=pqenh(jl,jk-1)*zdmfen(jl) + zsdde=(cpd*ptd(jl,jk-1)+pgeoh(jl,jk-1))*zdmfde(jl) + zqdde=pqd(jl,jk-1)*zdmfde(jl) + zmfdsk=pmfds(jl,jk-1)+zseen-zsdde + zmfdqk=pmfdq(jl,jk-1)+zqeen-zqdde + pqd(jl,jk)=zmfdqk*(1./min(-cmfcmin,pmfd(jl,jk))) + ptd(jl,jk)=(zmfdsk*(1./min(-cmfcmin,pmfd(jl,jk)))- & + pgeoh(jl,jk))*rcpd + ptd(jl,jk)=min(400.,ptd(jl,jk)) + ptd(jl,jk)=max(100.,ptd(jl,jk)) + zcond(jl)=pqd(jl,jk) + end if + end do + + ik=jk + icall=2 + call cuadjtq(klon,klev,ik,zph,ptd,pqd,llo2,icall) + do jl=1,klon + if(llo2(jl)) then + zcond(jl)=zcond(jl)-pqd(jl,jk) + zbuo=ptd(jl,jk)*(1.+vtmpc1*pqd(jl,jk))- & + ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + if(zbuo.ge.0..or.prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then + pmfd(jl,jk)=0. + endif + pmfds(jl,jk)=(cpd*ptd(jl,jk)+pgeoh(jl,jk))*pmfd(jl,jk) + pmfdq(jl,jk)=pqd(jl,jk)*pmfd(jl,jk) + zdmfdp=-pmfd(jl,jk)*zcond(jl) + pdmfdp(jl,jk-1)=zdmfdp + prfl(jl)=prfl(jl)+zdmfdp + end if + end do + + if(lmfdudv) then + do jl=1,klon + if(llo2(jl).and.pmfd(jl,jk).lt.0.) then + zmfduk=pmfd(jl,jk-1)*pud(jl,jk-1)+ & + zdmfen(jl)*puen(jl,jk-1)-zdmfde(jl)*pud(jl,jk-1) + zmfdvk=pmfd(jl,jk-1)*pvd(jl,jk-1)+ & + zdmfen(jl)*pven(jl,jk-1)-zdmfde(jl)*pvd(jl,jk-1) + pud(jl,jk)=zmfduk*(1./min(-cmfcmin,pmfd(jl,jk))) + pvd(jl,jk)=zmfdvk*(1./min(-cmfcmin,pmfd(jl,jk))) + end if + end do + end if + + end do + return + end subroutine cuddraf ! !********************************************** -! SUBROUTINE CUFLX +! subroutine cuflx !********************************************** - SUBROUTINE CUFLX & - (KLON, KLEV, KLEVP1, PQEN, PQSEN, & - PTENH, PQENH, PAPH, PGEOH, KCBOT, & - KCTOP, KDTOP, KTYPE, LDDRAF, LDCUM, & - PMFU, PMFD, PMFUS, PMFDS, PMFUQ, & - PMFDQ, PMFUL, PLUDE, PDMFUP, PDMFDP, & - PRFL, PRAIN, PTEN, PSFL, PDPMEL, & - KTOPM2, ZTMST, sig1) -! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89 -!***PURPOSE + subroutine cuflx & + (klon, klev, klevp1, pqen, pqsen, & + ptenh, pqenh, paph, pgeoh, kcbot, & + kctop, kdtop, ktype, lddraf, ldcum, & + pmfu, pmfd, pmfus, pmfds, pmfuq, & + pmfdq, pmful, plude, pdmfup, pdmfdp, & + prfl, prain, pten, psfl, pdpmel, & + ktopm2, ztmst, sig1) +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 +!***purpose ! ------- -! THIS ROUTINE DOES THE FINAL CALCULATION OF CONVECTIVE -! FLUXES IN THE CLOUD LAYER AND IN THE SUBCLOUD LAYER -!***INTERFACE +! this routine does the final calculation of convective +! fluxes in the cloud layer and in the subcloud layer +!***interface ! --------- -! THIS ROUTINE IS CALLED FROM *CUMASTR*. -!***EXTERNALS +! this routine is called from *cumastr*. +!***externals ! --------- -! NONE +! none ! ---------------------------------------------------------------- !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER KTOPM2, ITOP, JL, JK, IKB - REAL ZTMST, ZCONS1, ZCONS2, ZCUCOV, ZTMELP2 - REAL ZZP, ZFAC, ZSNMLT, ZRFL, CEVAPCU, ZRNEW - REAL ZRMIN, ZRFLN, ZDRFL, ZDPEVAP - REAL PQEN(KLON,KLEV), PQSEN(KLON,KLEV), & - PTENH(KLON,KLEV), PQENH(KLON,KLEV), & - PAPH(KLON,KLEVP1), PGEOH(KLON,KLEV) - REAL PMFU(KLON,KLEV), PMFD(KLON,KLEV), & - PMFUS(KLON,KLEV), PMFDS(KLON,KLEV), & - PMFUQ(KLON,KLEV), PMFDQ(KLON,KLEV), & - PDMFUP(KLON,KLEV), PDMFDP(KLON,KLEV), & - PMFUL(KLON,KLEV), PLUDE(KLON,KLEV), & - PRFL(KLON), PRAIN(KLON) - REAL PTEN(KLON,KLEV), PDPMEL(KLON,KLEV), & - PSFL(KLON), ZPSUBCL(KLON) - REAL sig1(KLEV) - INTEGER KCBOT(KLON), KCTOP(KLON), & - KDTOP(KLON), KTYPE(KLON) - LOGICAL LDDRAF(KLON), LDCUM(KLON) -!* SPECIFY CONSTANTS - ZCONS1=CPD/(ALF*G*ZTMST) - ZCONS2=1./(G*ZTMST) - ZCUCOV=0.05 - ZTMELP2=TMELT+2. -!* 1.0 DETERMINE FINAL CONVECTIVE FLUXES + integer klon, klev, klevp1 + integer ktopm2, itop, jl, jk, ikb + real ztmst, zcons1, zcons2, zcucov, ztmelp2 + real zzp, zfac, zsnmlt, zrfl, cevapcu, zrnew + real zrmin, zrfln, zdrfl, zdpevap + real pqen(klon,klev), pqsen(klon,klev), & + ptenh(klon,klev), pqenh(klon,klev), & + paph(klon,klevp1), pgeoh(klon,klev) + real pmfu(klon,klev), pmfd(klon,klev), & + pmfus(klon,klev), pmfds(klon,klev), & + pmfuq(klon,klev), pmfdq(klon,klev), & + pdmfup(klon,klev), pdmfdp(klon,klev), & + pmful(klon,klev), plude(klon,klev), & + prfl(klon), prain(klon) + real pten(klon,klev), pdpmel(klon,klev), & + psfl(klon), zpsubcl(klon) + real sig1(klev) + integer kcbot(klon), kctop(klon), & + kdtop(klon), ktype(klon) + logical lddraf(klon), ldcum(klon) +!* specify constants + zcons1=cpd/(alf*g*ztmst) + zcons2=1./(g*ztmst) + zcucov=0.05 + ztmelp2=tmelt+2. +!* 1.0 determine final convective fluxes !--------------------------------------------- - 100 CONTINUE - ITOP=KLEV - DO 110 JL=1,KLON - PRFL(JL)=0. - PSFL(JL)=0. - PRAIN(JL)=0. -! SWITCH OFF SHALLOW CONVECTION - IF(.NOT.LMFSCV.AND.KTYPE(JL).EQ.2)THEN - LDCUM(JL)=.FALSE. - LDDRAF(JL)=.FALSE. - ENDIF - ITOP=MIN(ITOP,KCTOP(JL)) - IF(.NOT.LDCUM(JL).OR.KDTOP(JL).LT.KCTOP(JL)) LDDRAF(JL)=.FALSE. - IF(.NOT.LDCUM(JL)) KTYPE(JL)=0 - 110 CONTINUE - KTOPM2=ITOP-2 - DO 120 JK=KTOPM2,KLEV - DO 115 JL=1,KLON - IF(LDCUM(JL).AND.JK.GE.KCTOP(JL)-1) THEN - PMFUS(JL,JK)=PMFUS(JL,JK)-PMFU(JL,JK)* & - (CPD*PTENH(JL,JK)+PGEOH(JL,JK)) - PMFUQ(JL,JK)=PMFUQ(JL,JK)-PMFU(JL,JK)*PQENH(JL,JK) - IF(LDDRAF(JL).AND.JK.GE.KDTOP(JL)) THEN - PMFDS(JL,JK)=PMFDS(JL,JK)-PMFD(JL,JK)* & - (CPD*PTENH(JL,JK)+PGEOH(JL,JK)) - PMFDQ(JL,JK)=PMFDQ(JL,JK)-PMFD(JL,JK)*PQENH(JL,JK) - ELSE - PMFD(JL,JK)=0. - PMFDS(JL,JK)=0. - PMFDQ(JL,JK)=0. - PDMFDP(JL,JK-1)=0. - END IF - ELSE - PMFU(JL,JK)=0. - PMFD(JL,JK)=0. - PMFUS(JL,JK)=0. - PMFDS(JL,JK)=0. - PMFUQ(JL,JK)=0. - PMFDQ(JL,JK)=0. - PMFUL(JL,JK)=0. - PDMFUP(JL,JK-1)=0. - PDMFDP(JL,JK-1)=0. - PLUDE(JL,JK-1)=0. - END IF - 115 CONTINUE - 120 CONTINUE - DO 130 JK=KTOPM2,KLEV - DO 125 JL=1,KLON - IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN - IKB=KCBOT(JL) - ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/ & - (PAPH(JL,KLEVP1)-PAPH(JL,IKB))) - IF(KTYPE(JL).EQ.3) THEN - ZZP=ZZP**2 - ENDIF - PMFU(JL,JK)=PMFU(JL,IKB)*ZZP - PMFUS(JL,JK)=PMFUS(JL,IKB)*ZZP - PMFUQ(JL,JK)=PMFUQ(JL,IKB)*ZZP - PMFUL(JL,JK)=PMFUL(JL,IKB)*ZZP - END IF -!* 2. CALCULATE RAIN/SNOW FALL RATES -!* CALCULATE MELTING OF SNOW -!* CALCULATE EVAPORATION OF PRECIP + itop=klev + do jl=1,klon + prfl(jl)=0. + psfl(jl)=0. + prain(jl)=0. +! switch off shallow convection + if(.not.lmfscv.and.ktype(jl).eq.2)then + ldcum(jl)=.false. + lddraf(jl)=.false. + endif + itop=min(itop,kctop(jl)) + if(.not.ldcum(jl).or.kdtop(jl).lt.kctop(jl)) lddraf(jl)=.false. + if(.not.ldcum(jl)) ktype(jl)=0 + end do + + ktopm2=itop-2 + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.ge.kctop(jl)-1) then + pmfus(jl,jk)=pmfus(jl,jk)-pmfu(jl,jk)* & + (cpd*ptenh(jl,jk)+pgeoh(jl,jk)) + pmfuq(jl,jk)=pmfuq(jl,jk)-pmfu(jl,jk)*pqenh(jl,jk) + if(lddraf(jl).and.jk.ge.kdtop(jl)) then + pmfds(jl,jk)=pmfds(jl,jk)-pmfd(jl,jk)* & + (cpd*ptenh(jl,jk)+pgeoh(jl,jk)) + pmfdq(jl,jk)=pmfdq(jl,jk)-pmfd(jl,jk)*pqenh(jl,jk) + else + pmfd(jl,jk)=0. + pmfds(jl,jk)=0. + pmfdq(jl,jk)=0. + pdmfdp(jl,jk-1)=0. + end if + else + pmfu(jl,jk)=0. + pmfd(jl,jk)=0. + pmfus(jl,jk)=0. + pmfds(jl,jk)=0. + pmfuq(jl,jk)=0. + pmfdq(jl,jk)=0. + pmful(jl,jk)=0. + pdmfup(jl,jk-1)=0. + pdmfdp(jl,jk-1)=0. + plude(jl,jk-1)=0. + end if + end do + end do + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.gt.kcbot(jl)) then + ikb=kcbot(jl) + zzp=((paph(jl,klevp1)-paph(jl,jk))/ & + (paph(jl,klevp1)-paph(jl,ikb))) + if(ktype(jl).eq.3) then + zzp=zzp**2 + endif + pmfu(jl,jk)=pmfu(jl,ikb)*zzp + pmfus(jl,jk)=pmfus(jl,ikb)*zzp + pmfuq(jl,jk)=pmfuq(jl,ikb)*zzp + pmful(jl,jk)=pmful(jl,ikb)*zzp + end if +!* 2. calculate rain/snow fall rates +!* calculate melting of snow +!* calculate evaporation of precip !---------------------------------------------- - IF(LDCUM(JL)) THEN - PRAIN(JL)=PRAIN(JL)+PDMFUP(JL,JK) - IF(PTEN(JL,JK).GT.TMELT) THEN - PRFL(JL)=PRFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK) - IF(PSFL(JL).GT.0..AND.PTEN(JL,JK).GT.ZTMELP2) THEN - ZFAC=ZCONS1*(PAPH(JL,JK+1)-PAPH(JL,JK)) - ZSNMLT=MIN(PSFL(JL),ZFAC*(PTEN(JL,JK)-ZTMELP2)) - PDPMEL(JL,JK)=ZSNMLT - PSFL(JL)=PSFL(JL)-ZSNMLT - PRFL(JL)=PRFL(JL)+ZSNMLT - END IF - ELSE - PSFL(JL)=PSFL(JL)+PDMFUP(JL,JK)+PDMFDP(JL,JK) - END IF - END IF - 125 CONTINUE - 130 CONTINUE - DO 230 JL=1,KLON - PRFL(JL)=MAX(PRFL(JL),0.) - PSFL(JL)=MAX(PSFL(JL),0.) - ZPSUBCL(JL)=PRFL(JL)+PSFL(JL) - 230 CONTINUE - DO 240 JK=KTOPM2,KLEV - DO 235 JL=1,KLON - IF(LDCUM(JL).AND.JK.GE.KCBOT(JL).AND. & - ZPSUBCL(JL).GT.1.E-20) THEN - ZRFL=ZPSUBCL(JL) - CEVAPCU=CEVAPCU1*SQRT(CEVAPCU2*SQRT(sig1(JK))) - ZRNEW=(MAX(0.,SQRT(ZRFL/ZCUCOV)- & - CEVAPCU*(PAPH(JL,JK+1)-PAPH(JL,JK))* & - MAX(0.,PQSEN(JL,JK)-PQEN(JL,JK))))**2*ZCUCOV - ZRMIN=ZRFL-ZCUCOV*MAX(0.,0.8*PQSEN(JL,JK)-PQEN(JL,JK)) & - *ZCONS2*(PAPH(JL,JK+1)-PAPH(JL,JK)) - ZRNEW=MAX(ZRNEW,ZRMIN) - ZRFLN=MAX(ZRNEW,0.) - ZDRFL=MIN(0.,ZRFLN-ZRFL) - PDMFUP(JL,JK)=PDMFUP(JL,JK)+ZDRFL - ZPSUBCL(JL)=ZRFLN - END IF - 235 CONTINUE - 240 CONTINUE - DO 250 JL=1,KLON - ZDPEVAP=ZPSUBCL(JL)-(PRFL(JL)+PSFL(JL)) - PRFL(JL)=PRFL(JL)+ZDPEVAP*PRFL(JL)* & - (1./MAX(1.E-20,PRFL(JL)+PSFL(JL))) - PSFL(JL)=PSFL(JL)+ZDPEVAP*PSFL(JL)* & - (1./MAX(1.E-20,PRFL(JL)+PSFL(JL))) - 250 CONTINUE - RETURN - END SUBROUTINE CUFLX + if(ldcum(jl)) then + prain(jl)=prain(jl)+pdmfup(jl,jk) + if(pten(jl,jk).gt.tmelt) then + prfl(jl)=prfl(jl)+pdmfup(jl,jk)+pdmfdp(jl,jk) + if(psfl(jl).gt.0..and.pten(jl,jk).gt.ztmelp2) then + zfac=zcons1*(paph(jl,jk+1)-paph(jl,jk)) + zsnmlt=min(psfl(jl),zfac*(pten(jl,jk)-ztmelp2)) + pdpmel(jl,jk)=zsnmlt + psfl(jl)=psfl(jl)-zsnmlt + prfl(jl)=prfl(jl)+zsnmlt + end if + else + psfl(jl)=psfl(jl)+pdmfup(jl,jk)+pdmfdp(jl,jk) + end if + end if + end do + end do + + do jl=1,klon + prfl(jl)=max(prfl(jl),0.) + psfl(jl)=max(psfl(jl),0.) + zpsubcl(jl)=prfl(jl)+psfl(jl) + end do + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.ge.kcbot(jl).and. & + zpsubcl(jl).gt.1.e-20) then + zrfl=zpsubcl(jl) + cevapcu=cevapcu1*sqrt(cevapcu2*sqrt(sig1(jk))) + zrnew=(max(0.,sqrt(zrfl/zcucov)- & + cevapcu*(paph(jl,jk+1)-paph(jl,jk))* & + max(0.,pqsen(jl,jk)-pqen(jl,jk))))**2*zcucov + zrmin=zrfl-zcucov*max(0.,0.8*pqsen(jl,jk)-pqen(jl,jk)) & + *zcons2*(paph(jl,jk+1)-paph(jl,jk)) + zrnew=max(zrnew,zrmin) + zrfln=max(zrnew,0.) + zdrfl=min(0.,zrfln-zrfl) + pdmfup(jl,jk)=pdmfup(jl,jk)+zdrfl + zpsubcl(jl)=zrfln + end if + end do + end do + + do jl=1,klon + zdpevap=zpsubcl(jl)-(prfl(jl)+psfl(jl)) + prfl(jl)=prfl(jl)+zdpevap*prfl(jl)* & + (1./max(1.e-20,prfl(jl)+psfl(jl))) + psfl(jl)=psfl(jl)+zdpevap*psfl(jl)* & + (1./max(1.e-20,prfl(jl)+psfl(jl))) + end do + + return + end subroutine cuflx ! !********************************************** -! SUBROUTINE CUDTDQ +! subroutine cudtdq !********************************************** - SUBROUTINE CUDTDQ & - (KLON, KLEV, KLEVP1, KTOPM2, PAPH, & - LDCUM, PTEN, PTTE, PQTE, PMFUS, & - PMFDS, PMFUQ, PMFDQ, PMFUL, PDMFUP, & - PDMFDP, ZTMST, PDPMEL, PRAIN, PRFL, & - PSFL, PSRAIN, PSEVAP, PSHEAT, PSMELT, & - PRSFC, PSSFC, PAPRC, PAPRSM, PAPRS, & - PQEN, PQSEN, PLUDE, PCTE) -!**** *CUDTDQ* - UPDATES T AND Q TENDENCIES, PRECIPITATION RATES -! DOES GLOBAL DIAGNOSTICS -! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89 -!***INTERFACE. + subroutine cudtdq & + (klon, klev, klevp1, ktopm2, paph, & + ldcum, pten, ptte, pqte, pmfus, & + pmfds, pmfuq, pmfdq, pmful, pdmfup, & + pdmfdp, ztmst, pdpmel, prain, prfl, & + psfl, psrain, psevap, psheat, psmelt, & + prsfc, pssfc, paprc, paprsm, paprs, & + pqen, pqsen, plude, pcte) +!**** *cudtdq* - updates t and q tendencies, precipitation rates +! does global diagnostics +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 +!***interface. ! ---------- -! *CUDTDQ* IS CALLED FROM *CUMASTR* +! *cudtdq* is called from *cumastr* ! ---------------------------------------------------------------- !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER KTOPM2,JL, JK - REAL ZTMST, PSRAIN, PSEVAP, PSHEAT, PSMELT, ZDIAGT, ZDIAGW - REAL ZALV, RHK, RHCOE, PLDFD, ZDTDT, ZDQDT - REAL PTTE(KLON,KLEV), PQTE(KLON,KLEV), & - PTEN(KLON,KLEV), PLUDE(KLON,KLEV), & - PGEO(KLON,KLEV), PAPH(KLON,KLEVP1), & - PAPRC(KLON), PAPRS(KLON), & - PAPRSM(KLON), PCTE(KLON,KLEV), & - PRSFC(KLON), PSSFC(KLON) - REAL PMFUS(KLON,KLEV), PMFDS(KLON,KLEV), & - PMFUQ(KLON,KLEV), PMFDQ(KLON,KLEV), & - PMFUL(KLON,KLEV), PQSEN(KLON,KLEV), & - PDMFUP(KLON,KLEV), PDMFDP(KLON,KLEV),& - PRFL(KLON), PRAIN(KLON), & - PQEN(KLON,KLEV) - REAL PDPMEL(KLON,KLEV), PSFL(KLON) - REAL ZSHEAT(KLON), ZMELT(KLON) - LOGICAL LDCUM(KLON) + integer klon, klev, klevp1 + integer ktopm2,jl, jk + real ztmst, psrain, psevap, psheat, psmelt, zdiagt, zdiagw + real zalv, rhk, rhcoe, pldfd, zdtdt, zdqdt + real ptte(klon,klev), pqte(klon,klev), & + pten(klon,klev), plude(klon,klev), & + pgeo(klon,klev), paph(klon,klevp1), & + paprc(klon), paprs(klon), & + paprsm(klon), pcte(klon,klev), & + prsfc(klon), pssfc(klon) + real pmfus(klon,klev), pmfds(klon,klev), & + pmfuq(klon,klev), pmfdq(klon,klev), & + pmful(klon,klev), pqsen(klon,klev), & + pdmfup(klon,klev), pdmfdp(klon,klev),& + prfl(klon), prain(klon), & + pqen(klon,klev) + real pdpmel(klon,klev), psfl(klon) + real zsheat(klon), zmelt(klon) + logical ldcum(klon) !-------------------------------- -!* 1.0 SPECIFY PARAMETERS +!* 1.0 specify parameters !-------------------------------- - 100 CONTINUE - ZDIAGT=ZTMST - ZDIAGW=ZDIAGT/RHOH2O + zdiagt=ztmst + zdiagw=zdiagt/rhoh2o !-------------------------------------------------- -!* 2.0 INCREMENTATION OF T AND Q TENDENCIES +!* 2.0 incrementation of t and q tendencies !-------------------------------------------------- - 200 CONTINUE - DO 210 JL=1,KLON - ZMELT(JL)=0. - ZSHEAT(JL)=0. - 210 CONTINUE - DO 250 JK=KTOPM2,KLEV - IF(JK.LT.KLEV) THEN - DO 220 JL=1,KLON - IF(LDCUM(JL)) THEN - IF(PTEN(JL,JK).GT.TMELT) THEN - ZALV=ALV - ELSE - ZALV=ALS - ENDIF - RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK)) - RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC)) - pldfd=MAX(0.0,RHCOE*fdbk*PLUDE(JL,JK)) - ZDTDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*RCPD* & - (PMFUS(JL,JK+1)-PMFUS(JL,JK)+ & - PMFDS(JL,JK+1)-PMFDS(JL,JK)-ALF*PDPMEL(JL,JK) & - -ZALV*(PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd- & - (PDMFUP(JL,JK)+PDMFDP(JL,JK)))) - PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT - ZDQDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*& - (PMFUQ(JL,JK+1)-PMFUQ(JL,JK)+ & - PMFDQ(JL,JK+1)-PMFDQ(JL,JK)+ & - PMFUL(JL,JK+1)-PMFUL(JL,JK)-pldfd- & - (PDMFUP(JL,JK)+PDMFDP(JL,JK))) - PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT - PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd - ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK)) - ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK) - END IF - 220 CONTINUE - ELSE - DO 230 JL=1,KLON - IF(LDCUM(JL)) THEN - IF(PTEN(JL,JK).GT.TMELT) THEN - ZALV=ALV - ELSE - ZALV=ALS - ENDIF - RHK=MIN(1.0,PQEN(JL,JK)/PQSEN(JL,JK)) - RHCOE=MAX(0.0,(RHK-RHC)/(RHM-RHC)) - pldfd=MAX(0.0,RHCOE*fdbk*PLUDE(JL,JK)) - ZDTDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*RCPD* & - (PMFUS(JL,JK)+PMFDS(JL,JK)+ALF*PDPMEL(JL,JK)-ZALV* & - (PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK)+pldfd)) - PTTE(JL,JK)=PTTE(JL,JK)+ZDTDT - ZDQDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* & - (PMFUQ(JL,JK)+PMFDQ(JL,JK)+pldfd+ & - (PMFUL(JL,JK)+PDMFUP(JL,JK)+PDMFDP(JL,JK))) - PQTE(JL,JK)=PQTE(JL,JK)+ZDQDT - PCTE(JL,JK)=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))*pldfd - ZSHEAT(JL)=ZSHEAT(JL)+ZALV*(PDMFUP(JL,JK)+PDMFDP(JL,JK)) - ZMELT(JL)=ZMELT(JL)+PDPMEL(JL,JK) - END IF - 230 CONTINUE - END IF - 250 CONTINUE + do jl=1,klon + zmelt(jl)=0. + zsheat(jl)=0. + end do + + do jk=ktopm2,klev + if(jk.lt.klev) then + do jl=1,klon + if(ldcum(jl)) then + if(pten(jl,jk).gt.tmelt) then + zalv=alv + else + zalv=als + endif + rhk=min(1.0,pqen(jl,jk)/pqsen(jl,jk)) + rhcoe=max(0.0,(rhk-rhc)/(rhm-rhc)) + pldfd=max(0.0,rhcoe*fdbk*plude(jl,jk)) + zdtdt=(g/(paph(jl,jk+1)-paph(jl,jk)))*rcpd* & + (pmfus(jl,jk+1)-pmfus(jl,jk)+ & + pmfds(jl,jk+1)-pmfds(jl,jk)-alf*pdpmel(jl,jk) & + -zalv*(pmful(jl,jk+1)-pmful(jl,jk)-pldfd- & + (pdmfup(jl,jk)+pdmfdp(jl,jk)))) + ptte(jl,jk)=ptte(jl,jk)+zdtdt + zdqdt=(g/(paph(jl,jk+1)-paph(jl,jk)))*& + (pmfuq(jl,jk+1)-pmfuq(jl,jk)+ & + pmfdq(jl,jk+1)-pmfdq(jl,jk)+ & + pmful(jl,jk+1)-pmful(jl,jk)-pldfd- & + (pdmfup(jl,jk)+pdmfdp(jl,jk))) + pqte(jl,jk)=pqte(jl,jk)+zdqdt + pcte(jl,jk)=(g/(paph(jl,jk+1)-paph(jl,jk)))*pldfd + zsheat(jl)=zsheat(jl)+zalv*(pdmfup(jl,jk)+pdmfdp(jl,jk)) + zmelt(jl)=zmelt(jl)+pdpmel(jl,jk) + end if + end do + else + do jl=1,klon + if(ldcum(jl)) then + if(pten(jl,jk).gt.tmelt) then + zalv=alv + else + zalv=als + endif + rhk=min(1.0,pqen(jl,jk)/pqsen(jl,jk)) + rhcoe=max(0.0,(rhk-rhc)/(rhm-rhc)) + pldfd=max(0.0,rhcoe*fdbk*plude(jl,jk)) + zdtdt=-(g/(paph(jl,jk+1)-paph(jl,jk)))*rcpd* & + (pmfus(jl,jk)+pmfds(jl,jk)+alf*pdpmel(jl,jk)-zalv* & + (pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)+pldfd)) + ptte(jl,jk)=ptte(jl,jk)+zdtdt + zdqdt=-(g/(paph(jl,jk+1)-paph(jl,jk)))* & + (pmfuq(jl,jk)+pmfdq(jl,jk)+pldfd+ & + (pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk))) + pqte(jl,jk)=pqte(jl,jk)+zdqdt + pcte(jl,jk)=(g/(paph(jl,jk+1)-paph(jl,jk)))*pldfd + zsheat(jl)=zsheat(jl)+zalv*(pdmfup(jl,jk)+pdmfdp(jl,jk)) + zmelt(jl)=zmelt(jl)+pdpmel(jl,jk) + end if + end do + end if + end do !--------------------------------------------------------- -! 3. UPDATE SURFACE FIELDS AND DO GLOBAL BUDGETS +! 3. update surface fields and do global budgets !--------------------------------------------------------- - 300 CONTINUE - DO 310 JL=1,KLON - PRSFC(JL)=PRFL(JL) - PSSFC(JL)=PSFL(JL) - PAPRC(JL)=PAPRC(JL)+ZDIAGW*(PRFL(JL)+PSFL(JL)) - PAPRS(JL)=PAPRSM(JL)+ZDIAGW*PSFL(JL) - PSHEAT=PSHEAT+ZSHEAT(JL) - PSRAIN=PSRAIN+PRAIN(JL) - PSEVAP=PSEVAP-(PRFL(JL)+PSFL(JL)) - PSMELT=PSMELT+ZMELT(JL) - 310 CONTINUE - PSEVAP=PSEVAP+PSRAIN - RETURN - END SUBROUTINE CUDTDQ + do jl=1,klon + prsfc(jl)=prfl(jl) + pssfc(jl)=psfl(jl) + paprc(jl)=paprc(jl)+zdiagw*(prfl(jl)+psfl(jl)) + paprs(jl)=paprsm(jl)+zdiagw*psfl(jl) + psheat=psheat+zsheat(jl) + psrain=psrain+prain(jl) + psevap=psevap-(prfl(jl)+psfl(jl)) + psmelt=psmelt+zmelt(jl) + end do + psevap=psevap+psrain + return + end subroutine cudtdq ! !********************************************** -! SUBROUTINE CUDUDV +! subroutine cududv !********************************************** - SUBROUTINE CUDUDV & - (KLON, KLEV, KLEVP1, KTOPM2, KTYPE, & - KCBOT, PAPH, LDCUM, PUEN, PVEN, & - PVOM, PVOL, PUU, PUD, PVU, & - PVD, PMFU, PMFD, PSDISS) -!**** *CUDUDV* - UPDATES U AND V TENDENCIES, -! DOES GLOBAL DIAGNOSTIC OF DISSIPATION -! M.TIEDTKE E.C.M.W.F. 7/86 MODIF. 12/89 -!***INTERFACE. + subroutine cududv & + (klon, klev, klevp1, ktopm2, ktype, & + kcbot, paph, ldcum, puen, pven, & + pvom, pvol, puu, pud, pvu, & + pvd, pmfu, pmfd, psdiss) +!**** *cududv* - updates u and v tendencies, +! does global diagnostic of dissipation +! m.tiedtke e.c.m.w.f. 7/86 modif. 12/89 +!***interface. ! ---------- -! *CUDUDV* IS CALLED FROM *CUMASTR* +! *cududv* is called from *cumastr* ! ---------------------------------------------------------------- !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER KTOPM2, JK, IK, JL, IKB - REAL PSDISS,ZZP, ZDUDT ,ZDVDT, ZSUM - REAL PUEN(KLON,KLEV), PVEN(KLON,KLEV), & - PVOL(KLON,KLEV), PVOM(KLON,KLEV), & - PAPH(KLON,KLEVP1) - REAL PUU(KLON,KLEV), PUD(KLON,KLEV), & - PVU(KLON,KLEV), PVD(KLON,KLEV), & - PMFU(KLON,KLEV), PMFD(KLON,KLEV) - REAL ZMFUU(KLON,KLEV), ZMFDU(KLON,KLEV), & - ZMFUV(KLON,KLEV), ZMFDV(KLON,KLEV), & - ZDISS(KLON) - INTEGER KTYPE(KLON), KCBOT(KLON) - LOGICAL LDCUM(KLON) + integer klon, klev, klevp1 + integer ktopm2, jk, ik, jl, ikb + real psdiss,zzp, zdudt ,zdvdt, zsum + real puen(klon,klev), pven(klon,klev), & + pvol(klon,klev), pvom(klon,klev), & + paph(klon,klevp1) + real puu(klon,klev), pud(klon,klev), & + pvu(klon,klev), pvd(klon,klev), & + pmfu(klon,klev), pmfd(klon,klev) + real zmfuu(klon,klev), zmfdu(klon,klev), & + zmfuv(klon,klev), zmfdv(klon,klev), & + zdiss(klon) + integer ktype(klon), kcbot(klon) + logical ldcum(klon) !------------------------------------------------------------ -!* 1.0 CALCULATE FLUXES AND UPDATE U AND V TENDENCIES +!* 1.0 calculate fluxes and update u and v tendencies ! ----------------------------------------------------------- - 100 CONTINUE - DO 120 JK=KTOPM2,KLEV - IK=JK-1 - DO 110 JL=1,KLON - IF(LDCUM(JL)) THEN - ZMFUU(JL,JK)=PMFU(JL,JK)*(PUU(JL,JK)-PUEN(JL,IK)) - ZMFUV(JL,JK)=PMFU(JL,JK)*(PVU(JL,JK)-PVEN(JL,IK)) - ZMFDU(JL,JK)=PMFD(JL,JK)*(PUD(JL,JK)-PUEN(JL,IK)) - ZMFDV(JL,JK)=PMFD(JL,JK)*(PVD(JL,JK)-PVEN(JL,IK)) - END IF - 110 CONTINUE - 120 CONTINUE - DO 140 JK=KTOPM2,KLEV - DO 130 JL=1,KLON - IF(LDCUM(JL).AND.JK.GT.KCBOT(JL)) THEN - IKB=KCBOT(JL) - ZZP=((PAPH(JL,KLEVP1)-PAPH(JL,JK))/ & - (PAPH(JL,KLEVP1)-PAPH(JL,IKB))) - IF(KTYPE(JL).EQ.3) THEN - ZZP=ZZP**2 - ENDIF - ZMFUU(JL,JK)=ZMFUU(JL,IKB)*ZZP - ZMFUV(JL,JK)=ZMFUV(JL,IKB)*ZZP - ZMFDU(JL,JK)=ZMFDU(JL,IKB)*ZZP - ZMFDV(JL,JK)=ZMFDV(JL,IKB)*ZZP - END IF - 130 CONTINUE - 140 CONTINUE - DO 150 JL=1,KLON - ZDISS(JL)=0. - 150 CONTINUE - DO 190 JK=KTOPM2,KLEV - IF(JK.LT.KLEV) THEN - DO 160 JL=1,KLON - IF(LDCUM(JL)) THEN - ZDUDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* & - (ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+ & - ZMFDU(JL,JK+1)-ZMFDU(JL,JK)) - ZDVDT=(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* & - (ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+ & - ZMFDV(JL,JK+1)-ZMFDV(JL,JK)) - ZDISS(JL)=ZDISS(JL)+ & - PUEN(JL,JK)*(ZMFUU(JL,JK+1)-ZMFUU(JL,JK)+ & - ZMFDU(JL,JK+1)-ZMFDU(JL,JK))+ & - PVEN(JL,JK)*(ZMFUV(JL,JK+1)-ZMFUV(JL,JK)+ & - ZMFDV(JL,JK+1)-ZMFDV(JL,JK)) - PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT - PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT - END IF - 160 CONTINUE - ELSE - DO 170 JL=1,KLON - IF(LDCUM(JL)) THEN - ZDUDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* & - (ZMFUU(JL,JK)+ZMFDU(JL,JK)) - ZDVDT=-(G/(PAPH(JL,JK+1)-PAPH(JL,JK)))* & - (ZMFUV(JL,JK)+ZMFDV(JL,JK)) - ZDISS(JL)=ZDISS(JL)- & - (PUEN(JL,JK)*(ZMFUU(JL,JK)+ZMFDU(JL,JK))+ & - PVEN(JL,JK)*(ZMFUV(JL,JK)+ZMFDV(JL,JK))) - PVOM(JL,JK)=PVOM(JL,JK)+ZDUDT - PVOL(JL,JK)=PVOL(JL,JK)+ZDVDT - END IF - 170 CONTINUE - END IF - 190 CONTINUE - ZSUM=SSUM(KLON,ZDISS(1),1) - PSDISS=PSDISS+ZSUM - RETURN - END SUBROUTINE CUDUDV + do jk=ktopm2,klev + ik=jk-1 + do jl=1,klon + if(ldcum(jl)) then + zmfuu(jl,jk)=pmfu(jl,jk)*(puu(jl,jk)-puen(jl,ik)) + zmfuv(jl,jk)=pmfu(jl,jk)*(pvu(jl,jk)-pven(jl,ik)) + zmfdu(jl,jk)=pmfd(jl,jk)*(pud(jl,jk)-puen(jl,ik)) + zmfdv(jl,jk)=pmfd(jl,jk)*(pvd(jl,jk)-pven(jl,ik)) + end if + end do + end do + + do jk=ktopm2,klev + do jl=1,klon + if(ldcum(jl).and.jk.gt.kcbot(jl)) then + ikb=kcbot(jl) + zzp=((paph(jl,klevp1)-paph(jl,jk))/ & + (paph(jl,klevp1)-paph(jl,ikb))) + if(ktype(jl).eq.3) then + zzp=zzp**2 + endif + zmfuu(jl,jk)=zmfuu(jl,ikb)*zzp + zmfuv(jl,jk)=zmfuv(jl,ikb)*zzp + zmfdu(jl,jk)=zmfdu(jl,ikb)*zzp + zmfdv(jl,jk)=zmfdv(jl,ikb)*zzp + end if + end do + end do + + do jl=1,klon + zdiss(jl)=0. + end do + + do jk=ktopm2,klev + if(jk.lt.klev) then + do jl=1,klon + if(ldcum(jl)) then + zdudt=(g/(paph(jl,jk+1)-paph(jl,jk)))* & + (zmfuu(jl,jk+1)-zmfuu(jl,jk)+ & + zmfdu(jl,jk+1)-zmfdu(jl,jk)) + zdvdt=(g/(paph(jl,jk+1)-paph(jl,jk)))* & + (zmfuv(jl,jk+1)-zmfuv(jl,jk)+ & + zmfdv(jl,jk+1)-zmfdv(jl,jk)) + zdiss(jl)=zdiss(jl)+ & + puen(jl,jk)*(zmfuu(jl,jk+1)-zmfuu(jl,jk)+ & + zmfdu(jl,jk+1)-zmfdu(jl,jk))+ & + pven(jl,jk)*(zmfuv(jl,jk+1)-zmfuv(jl,jk)+ & + zmfdv(jl,jk+1)-zmfdv(jl,jk)) + pvom(jl,jk)=pvom(jl,jk)+zdudt + pvol(jl,jk)=pvol(jl,jk)+zdvdt + end if + end do + else + do jl=1,klon + if(ldcum(jl)) then + zdudt=-(g/(paph(jl,jk+1)-paph(jl,jk)))* & + (zmfuu(jl,jk)+zmfdu(jl,jk)) + zdvdt=-(g/(paph(jl,jk+1)-paph(jl,jk)))* & + (zmfuv(jl,jk)+zmfdv(jl,jk)) + zdiss(jl)=zdiss(jl)- & + (puen(jl,jk)*(zmfuu(jl,jk)+zmfdu(jl,jk))+ & + pven(jl,jk)*(zmfuv(jl,jk)+zmfdv(jl,jk))) + pvom(jl,jk)=pvom(jl,jk)+zdudt + pvol(jl,jk)=pvol(jl,jk)+zdvdt + end if + end do + end if + end do + zsum=ssum(klon,zdiss(1),1) + psdiss=psdiss+zsum + return + end subroutine cududv ! !################################################################# ! -! LEVEL 4 SUBROUTINES +! level 4 subroutines ! !################################################################# !************************************************************** -! SUBROUTINE CUBASMC +! subroutine cubasmc !************************************************************** - SUBROUTINE CUBASMC & - (KLON, KLEV, KLEVM1, KK, PTEN, & - PQEN, PQSEN, PUEN, PVEN, PVERV, & - PGEO, PGEOH, LDCUM, KTYPE, KLAB, & - PMFU, PMFUB, PENTR, KCBOT, PTU, & - PQU, PLU, PUU, PVU, PMFUS, & - PMFUQ, PMFUL, PDMFUP, PMFUU, PMFUV) -! M.TIEDTKE E.C.M.W.F. 12/89 -!***PURPOSE. + subroutine cubasmc & + (klon, klev, klevm1, kk, pten, & + pqen, pqsen, puen, pven, pverv, & + pgeo, pgeoh, ldcum, ktype, klab, & + pmfu, pmfub, pentr, kcbot, ptu, & + pqu, plu, puu, pvu, pmfus, & + pmfuq, pmful, pdmfup, pmfuu, pmfuv) +! m.tiedtke e.c.m.w.f. 12/89 +!***purpose. ! -------- -! THIS ROUTINE CALCULATES CLOUD BASE VALUES -! FOR MIDLEVEL CONVECTION -!***INTERFACE +! this routine calculates cloud base values +! for midlevel convection +!***interface ! --------- -! THIS ROUTINE IS CALLED FROM *CUASC*. -! INPUT ARE ENVIRONMENTAL VALUES T,Q ETC -! IT RETURNS CLOUDBASE VALUES FOR MIDLEVEL CONVECTION -!***METHOD. +! this routine is called from *cuasc*. +! input are environmental values t,q etc +! it returns cloudbase values for midlevel convection +!***method. ! ------- -! S. TIEDTKE (1989) -!***EXTERNALS +! s. tiedtke (1989) +!***externals ! --------- -! NONE +! none ! ---------------------------------------------------------------- !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER KLEVM1,KK, JL - REAL zzzmb - REAL PTEN(KLON,KLEV), PQEN(KLON,KLEV), & - PUEN(KLON,KLEV), PVEN(KLON,KLEV), & - PQSEN(KLON,KLEV), PVERV(KLON,KLEV), & - PGEO(KLON,KLEV), PGEOH(KLON,KLEV) - REAL PTU(KLON,KLEV), PQU(KLON,KLEV), & - PUU(KLON,KLEV), PVU(KLON,KLEV), & - PLU(KLON,KLEV), PMFU(KLON,KLEV), & - PMFUB(KLON), PENTR(KLON), & - PMFUS(KLON,KLEV), PMFUQ(KLON,KLEV), & - PMFUL(KLON,KLEV), PDMFUP(KLON,KLEV), & - PMFUU(KLON), PMFUV(KLON) - INTEGER KTYPE(KLON), KCBOT(KLON), & - KLAB(KLON,KLEV) - LOGICAL LDCUM(KLON) + integer klon, klev, klevp1 + integer klevm1,kk, jl + real zzzmb + real pten(klon,klev), pqen(klon,klev), & + puen(klon,klev), pven(klon,klev), & + pqsen(klon,klev), pverv(klon,klev), & + pgeo(klon,klev), pgeoh(klon,klev) + real ptu(klon,klev), pqu(klon,klev), & + puu(klon,klev), pvu(klon,klev), & + plu(klon,klev), pmfu(klon,klev), & + pmfub(klon), pentr(klon), & + pmfus(klon,klev), pmfuq(klon,klev), & + pmful(klon,klev), pdmfup(klon,klev), & + pmfuu(klon), pmfuv(klon) + integer ktype(klon), kcbot(klon), & + klab(klon,klev) + logical ldcum(klon) !-------------------------------------------------------- -!* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES +!* 1. calculate entrainment and detrainment rates ! ------------------------------------------------------- - 100 CONTINUE - DO 150 JL=1,KLON - IF( .NOT. LDCUM(JL).AND.KLAB(JL,KK+1).EQ.0.0.AND. & - PQEN(JL,KK).GT.0.80*PQSEN(JL,KK)) THEN - PTU(JL,KK+1)=(CPD*PTEN(JL,KK)+PGEO(JL,KK)-PGEOH(JL,KK+1)) & - *RCPD - PQU(JL,KK+1)=PQEN(JL,KK) - PLU(JL,KK+1)=0. - ZZZMB=MAX(CMFCMIN,-PVERV(JL,KK)/G) - ZZZMB=MIN(ZZZMB,CMFCMAX) - PMFUB(JL)=ZZZMB - PMFU(JL,KK+1)=PMFUB(JL) - PMFUS(JL,KK+1)=PMFUB(JL)*(CPD*PTU(JL,KK+1)+PGEOH(JL,KK+1)) - PMFUQ(JL,KK+1)=PMFUB(JL)*PQU(JL,KK+1) - PMFUL(JL,KK+1)=0. - PDMFUP(JL,KK+1)=0. - KCBOT(JL)=KK - KLAB(JL,KK+1)=1 - KTYPE(JL)=3 - PENTR(JL)=ENTRMID - IF(LMFDUDV) THEN - PUU(JL,KK+1)=PUEN(JL,KK) - PVU(JL,KK+1)=PVEN(JL,KK) - PMFUU(JL)=PMFUB(JL)*PUU(JL,KK+1) - PMFUV(JL)=PMFUB(JL)*PVU(JL,KK+1) - END IF - END IF - 150 CONTINUE - RETURN - END SUBROUTINE CUBASMC + do jl=1,klon + if( .not. ldcum(jl).and.klab(jl,kk+1).eq.0.0.and. & + pqen(jl,kk).gt.0.80*pqsen(jl,kk)) then + ptu(jl,kk+1)=(cpd*pten(jl,kk)+pgeo(jl,kk)-pgeoh(jl,kk+1)) & + *rcpd + pqu(jl,kk+1)=pqen(jl,kk) + plu(jl,kk+1)=0. + zzzmb=max(cmfcmin,-pverv(jl,kk)/g) + zzzmb=min(zzzmb,cmfcmax) + pmfub(jl)=zzzmb + pmfu(jl,kk+1)=pmfub(jl) + pmfus(jl,kk+1)=pmfub(jl)*(cpd*ptu(jl,kk+1)+pgeoh(jl,kk+1)) + pmfuq(jl,kk+1)=pmfub(jl)*pqu(jl,kk+1) + pmful(jl,kk+1)=0. + pdmfup(jl,kk+1)=0. + kcbot(jl)=kk + klab(jl,kk+1)=1 + ktype(jl)=3 + pentr(jl)=entrmid + if(lmfdudv) then + puu(jl,kk+1)=puen(jl,kk) + pvu(jl,kk+1)=pven(jl,kk) + pmfuu(jl)=pmfub(jl)*puu(jl,kk+1) + pmfuv(jl)=pmfub(jl)*pvu(jl,kk+1) + end if + end if + end do + return + end subroutine cubasmc ! !************************************************************** -! SUBROUTINE CUADJTQ +! subroutine cuadjtq !************************************************************** - SUBROUTINE CUADJTQ(KLON,KLEV,KK,PP,PT,PQ,LDFLAG,KCALL) -! M.TIEDTKE E.C.M.W.F. 12/89 -! D.SALMOND CRAY(UK)) 12/8/91 -!***PURPOSE. + subroutine cuadjtq(klon,klev,kk,pp,pt,pq,ldflag,kcall) +! m.tiedtke e.c.m.w.f. 12/89 +! d.salmond cray(uk)) 12/8/91 +!***purpose. ! -------- -! TO PRODUCE T,Q AND L VALUES FOR CLOUD ASCENT -!***INTERFACE +! to produce t,q and l values for cloud ascent +!***interface ! --------- -! THIS ROUTINE IS CALLED FROM SUBROUTINES: -! *CUBASE* (T AND Q AT CONDENSTION LEVEL) -! *CUASC* (T AND Q AT CLOUD LEVELS) -! *CUINI* (ENVIRONMENTAL T AND QS VALUES AT HALF LEVELS) -! INPUT ARE UNADJUSTED T AND Q VALUES, -! IT RETURNS ADJUSTED VALUES OF T AND Q -! NOTE: INPUT PARAMETER KCALL DEFINES CALCULATION AS -! KCALL=0 ENV. T AND QS IN*CUINI* -! KCALL=1 CONDENSATION IN UPDRAFTS (E.G. CUBASE, CUASC) -! KCALL=2 EVAPORATION IN DOWNDRAFTS (E.G. CUDLFS,CUDDRAF -!***EXTERNALS +! this routine is called from subroutines: +! *cubase* (t and q at condenstion level) +! *cuasc* (t and q at cloud levels) +! *cuini* (environmental t and qs values at half levels) +! input are unadjusted t and q values, +! it returns adjusted values of t and q +! note: input parameter kcall defines calculation as +! kcall=0 env. t and qs in*cuini* +! kcall=1 condensation in updrafts (e.g. cubase, cuasc) +! kcall=2 evaporation in downdrafts (e.g. cudlfs,cuddraf +!***externals ! --------- -! 3 LOOKUP TABLES ( TLUCUA, TLUCUB, TLUCUC ) -! FOR CONDENSATION CALCULATIONS. -! THE TABLES ARE INITIALISED IN *SETPHYS*. +! 3 lookup tables ( tlucua, tlucub, tlucuc ) +! for condensation calculations. +! the tables are initialised in *setphys*. ! ---------------------------------------------------------------- !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- - INTEGER KLON, KLEV - INTEGER KK, KCALL, ISUM, JL - REAL ZQSAT, ZCOR, ZCOND1, TT - REAL PT(KLON,KLEV), PQ(KLON,KLEV), & - ZCOND(KLON), ZQP(KLON), & - PP(KLON) - LOGICAL LDFLAG(KLON) + integer klon, klev + integer kk, kcall, isum, jl + real zqsat, zcor, zcond1, tt + real pt(klon,klev), pq(klon,klev), & + zcond(klon), zqp(klon), & + pp(klon) + logical ldflag(klon) !------------------------------------------------------------------ -! 2. CALCULATE CONDENSATION AND ADJUST T AND Q ACCORDINGLY +! 2. calculate condensation and adjust t and q accordingly !------------------------------------------------------------------ - 200 CONTINUE - IF (KCALL.EQ.1 ) THEN - ISUM=0 - DO 210 JL=1,KLON - ZCOND(JL)=0. - IF(LDFLAG(JL)) THEN - ZQP(JL)=1./PP(JL) - TT=PT(JL,KK) - ZQSAT=TLUCUA(TT)*ZQP(JL) - ZQSAT=MIN(0.5,ZQSAT) - ZCOR=1./(1.-VTMPC1*ZQSAT) - ZQSAT=ZQSAT*ZCOR - ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT)) - ZCOND(JL)=MAX(ZCOND(JL),0.) - PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL) - PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL) - IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1 - END IF - 210 CONTINUE - IF(ISUM.EQ.0) GO TO 230 - DO 220 JL=1,KLON - IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN - TT=PT(JL,KK) - ZQSAT=TLUCUA(TT)*ZQP(JL) - ZQSAT=MIN(0.5,ZQSAT) - ZCOR=1./(1.-VTMPC1*ZQSAT) - ZQSAT=ZQSAT*ZCOR - ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT)) - PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1 - PQ(JL,KK)=PQ(JL,KK)-ZCOND1 - END IF - 220 CONTINUE - 230 CONTINUE - END IF - IF(KCALL.EQ.2) THEN - ISUM=0 - DO 310 JL=1,KLON - ZCOND(JL)=0. - IF(LDFLAG(JL)) THEN - TT=PT(JL,KK) - ZQP(JL)=1./PP(JL) - ZQSAT=TLUCUA(TT)*ZQP(JL) - ZQSAT=MIN(0.5,ZQSAT) - ZCOR=1./(1.-VTMPC1*ZQSAT) - ZQSAT=ZQSAT*ZCOR - ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT)) - ZCOND(JL)=MIN(ZCOND(JL),0.) - PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL) - PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL) - IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1 - END IF - 310 CONTINUE - IF(ISUM.EQ.0) GO TO 330 - DO 320 JL=1,KLON - IF(LDFLAG(JL).AND.ZCOND(JL).NE.0.) THEN - TT=PT(JL,KK) - ZQSAT=TLUCUA(TT)*ZQP(JL) - ZQSAT=MIN(0.5,ZQSAT) - ZCOR=1./(1.-VTMPC1*ZQSAT) - ZQSAT=ZQSAT*ZCOR - ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT)) - PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1 - PQ(JL,KK)=PQ(JL,KK)-ZCOND1 - END IF - 320 CONTINUE - 330 CONTINUE - END IF - IF(KCALL.EQ.0) THEN - ISUM=0 - DO 410 JL=1,KLON - TT=PT(JL,KK) - ZQP(JL)=1./PP(JL) - ZQSAT=TLUCUA(TT)*ZQP(JL) - ZQSAT=MIN(0.5,ZQSAT) - ZCOR=1./(1.-VTMPC1*ZQSAT) - ZQSAT=ZQSAT*ZCOR - ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT)) - PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL) - PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL) - IF(ZCOND(JL).NE.0.0) ISUM=ISUM+1 - 410 CONTINUE - IF(ISUM.EQ.0) GO TO 430 - DO 420 JL=1,KLON - TT=PT(JL,KK) - ZQSAT=TLUCUA(TT)*ZQP(JL) - ZQSAT=MIN(0.5,ZQSAT) - ZCOR=1./(1.-VTMPC1*ZQSAT) - ZQSAT=ZQSAT*ZCOR - ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT)) - PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1 - PQ(JL,KK)=PQ(JL,KK)-ZCOND1 - 420 CONTINUE - 430 CONTINUE - END IF - IF(KCALL.EQ.4) THEN - DO 510 JL=1,KLON - TT=PT(JL,KK) - ZQP(JL)=1./PP(JL) - ZQSAT=TLUCUA(TT)*ZQP(JL) - ZQSAT=MIN(0.5,ZQSAT) - ZCOR=1./(1.-VTMPC1*ZQSAT) - ZQSAT=ZQSAT*ZCOR - ZCOND(JL)=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT)) - PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND(JL) - PQ(JL,KK)=PQ(JL,KK)-ZCOND(JL) - 510 CONTINUE - DO 520 JL=1,KLON - TT=PT(JL,KK) - ZQSAT=TLUCUA(TT)*ZQP(JL) - ZQSAT=MIN(0.5,ZQSAT) - ZCOR=1./(1.-VTMPC1*ZQSAT) - ZQSAT=ZQSAT*ZCOR - ZCOND1=(PQ(JL,KK)-ZQSAT)/(1.+ZQSAT*ZCOR*TLUCUB(TT)) - PT(JL,KK)=PT(JL,KK)+TLUCUC(TT)*ZCOND1 - PQ(JL,KK)=PQ(JL,KK)-ZCOND1 - 520 CONTINUE - END IF - RETURN - END SUBROUTINE CUADJTQ + if (kcall.eq.1 ) then + isum=0 + do jl=1,klon + zcond(jl)=0. + if(ldflag(jl)) then + zqp(jl)=1./pp(jl) + tt=pt(jl,kk) + zqsat=tlucua(tt)*zqp(jl) + zqsat=min(0.5,zqsat) + zcor=1./(1.-vtmpc1*zqsat) + zqsat=zqsat*zcor + zcond(jl)=(pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(tt)) + zcond(jl)=max(zcond(jl),0.) + pt(jl,kk)=pt(jl,kk)+tlucuc(tt)*zcond(jl) + pq(jl,kk)=pq(jl,kk)-zcond(jl) + if(zcond(jl).ne.0.0) isum=isum+1 + end if + end do + + if(isum.eq.0) return + do jl=1,klon + if(ldflag(jl).and.zcond(jl).ne.0.) then + tt=pt(jl,kk) + zqsat=tlucua(tt)*zqp(jl) + zqsat=min(0.5,zqsat) + zcor=1./(1.-vtmpc1*zqsat) + zqsat=zqsat*zcor + zcond1=(pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(tt)) + pt(jl,kk)=pt(jl,kk)+tlucuc(tt)*zcond1 + pq(jl,kk)=pq(jl,kk)-zcond1 + end if + end do + end if + if(kcall.eq.2) then + isum=0 + do jl=1,klon + zcond(jl)=0. + if(ldflag(jl)) then + tt=pt(jl,kk) + zqp(jl)=1./pp(jl) + zqsat=tlucua(tt)*zqp(jl) + zqsat=min(0.5,zqsat) + zcor=1./(1.-vtmpc1*zqsat) + zqsat=zqsat*zcor + zcond(jl)=(pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(tt)) + zcond(jl)=min(zcond(jl),0.) + pt(jl,kk)=pt(jl,kk)+tlucuc(tt)*zcond(jl) + pq(jl,kk)=pq(jl,kk)-zcond(jl) + if(zcond(jl).ne.0.0) isum=isum+1 + end if + end do + + if(isum.eq.0) return + do jl=1,klon + if(ldflag(jl).and.zcond(jl).ne.0.) then + tt=pt(jl,kk) + zqsat=tlucua(tt)*zqp(jl) + zqsat=min(0.5,zqsat) + zcor=1./(1.-vtmpc1*zqsat) + zqsat=zqsat*zcor + zcond1=(pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(tt)) + pt(jl,kk)=pt(jl,kk)+tlucuc(tt)*zcond1 + pq(jl,kk)=pq(jl,kk)-zcond1 + end if + end do + end if + if(kcall.eq.0) then + isum=0 + do jl=1,klon + tt=pt(jl,kk) + zqp(jl)=1./pp(jl) + zqsat=tlucua(tt)*zqp(jl) + zqsat=min(0.5,zqsat) + zcor=1./(1.-vtmpc1*zqsat) + zqsat=zqsat*zcor + zcond(jl)=(pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(tt)) + pt(jl,kk)=pt(jl,kk)+tlucuc(tt)*zcond(jl) + pq(jl,kk)=pq(jl,kk)-zcond(jl) + if(zcond(jl).ne.0.0) isum=isum+1 + end do + + if(isum.eq.0) return + do jl=1,klon + tt=pt(jl,kk) + zqsat=tlucua(tt)*zqp(jl) + zqsat=min(0.5,zqsat) + zcor=1./(1.-vtmpc1*zqsat) + zqsat=zqsat*zcor + zcond1=(pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(tt)) + pt(jl,kk)=pt(jl,kk)+tlucuc(tt)*zcond1 + pq(jl,kk)=pq(jl,kk)-zcond1 + end do + end if + if(kcall.eq.4) then + do jl=1,klon + tt=pt(jl,kk) + zqp(jl)=1./pp(jl) + zqsat=tlucua(tt)*zqp(jl) + zqsat=min(0.5,zqsat) + zcor=1./(1.-vtmpc1*zqsat) + zqsat=zqsat*zcor + zcond(jl)=(pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(tt)) + pt(jl,kk)=pt(jl,kk)+tlucuc(tt)*zcond(jl) + pq(jl,kk)=pq(jl,kk)-zcond(jl) + end do + + do jl=1,klon + tt=pt(jl,kk) + zqsat=tlucua(tt)*zqp(jl) + zqsat=min(0.5,zqsat) + zcor=1./(1.-vtmpc1*zqsat) + zqsat=zqsat*zcor + zcond1=(pq(jl,kk)-zqsat)/(1.+zqsat*zcor*tlucub(tt)) + pt(jl,kk)=pt(jl,kk)+tlucuc(tt)*zcond1 + pq(jl,kk)=pq(jl,kk)-zcond1 + end do + end if + return + end subroutine cuadjtq ! !********************************************************** -! SUBROUTINE CUENTR_NEW +! subroutine cuentr_new !********************************************************** - SUBROUTINE CUENTR_NEW & - (KLON, KLEV, KLEVP1, KK, PTENH, & - PAPH, PAP, PGEOH, KLWMIN, LDCUM, & - KTYPE, KCBOT, KCTOP0, ZPBASE, PMFU, & - PENTR, ZDMFEN, ZDMFDE, ZODETR, KHMIN) -! M.TIEDTKE E.C.M.W.F. 12/89 -! Y.WANG IPRC 11/01 -!***PURPOSE. + subroutine cuentr_new & + (klon, klev, klevp1, kk, ptenh, & + paph, pap, pgeoh, klwmin, ldcum, & + ktype, kcbot, kctop0, zpbase, pmfu, & + pentr, zdmfen, zdmfde, zodetr, khmin) +! m.tiedtke e.c.m.w.f. 12/89 +! y.wang iprc 11/01 +!***purpose. ! -------- -! THIS ROUTINE CALCULATES ENTRAINMENT/DETRAINMENT RATES -! FOR UPDRAFTS IN CUMULUS PARAMETERIZATION -!***INTERFACE +! this routine calculates entrainment/detrainment rates +! for updrafts in cumulus parameterization +!***interface ! --------- -! THIS ROUTINE IS CALLED FROM *CUASC*. -! INPUT ARE ENVIRONMENTAL VALUES T,Q ETC -! AND UPDRAFT VALUES T,Q ETC -! IT RETURNS ENTRAINMENT/DETRAINMENT RATES -!***METHOD. +! this routine is called from *cuasc*. +! input are environmental values t,q etc +! and updraft values t,q etc +! it returns entrainment/detrainment rates +!***method. ! -------- -! S. TIEDTKE (1989), NORDENG(1996) -!***EXTERNALS +! s. tiedtke (1989), nordeng(1996) +!***externals ! --------- -! NONE +! none ! ---------------------------------------------------------------- !------------------------------------------------------------------- - IMPLICIT NONE + implicit none !------------------------------------------------------------------- - INTEGER KLON, KLEV, KLEVP1 - INTEGER KK, JL, IKLWMIN,IKB, IKT, IKH - REAL ZRRHO, ZDPRHO, ZPMID, ZENTR, ZZMZK, ZTMZK, ARG, ZORGDE - REAL PTENH(KLON,KLEV), & - PAP(KLON,KLEV), PAPH(KLON,KLEVP1), & - PMFU(KLON,KLEV), PGEOH(KLON,KLEV), & - PENTR(KLON), ZPBASE(KLON), & - ZDMFEN(KLON), ZDMFDE(KLON), & - ZODETR(KLON,KLEV) - INTEGER KLWMIN(KLON), KTYPE(KLON), & - KCBOT(KLON), KCTOP0(KLON), & - KHMIN(KLON) - LOGICAL LDCUM(KLON),LLO1,LLO2 - - real tt(klon),ttb(klon) - real zqsat(klon), zqsatb(klon) - real fscale(klon) + integer klon, klev, klevp1 + integer kk, jl, iklwmin,ikb, ikt, ikh + real zrrho, zdprho, zpmid, zentr, zzmzk, ztmzk, arg, zorgde + real ptenh(klon,klev), & + pap(klon,klev), paph(klon,klevp1), & + pmfu(klon,klev), pgeoh(klon,klev), & + pentr(klon), zpbase(klon), & + zdmfen(klon), zdmfde(klon), & + zodetr(klon,klev) + integer klwmin(klon), ktype(klon), & + kcbot(klon), kctop0(klon), & + khmin(klon) + logical ldcum(klon),llo1,llo2 !--------------------------------------------------------- -!* 1. CALCULATE ENTRAINMENT AND DETRAINMENT RATES +!* 1. calculate entrainment and detrainment rates !--------------------------------------------------------- -!* 1.1 SPECIFY ENTRAINMENT RATES FOR SHALLOW CLOUDS +!* 1.1 specify entrainment rates for shallow clouds !---------------------------------------------------------- -!* 1.2 SPECIFY ENTRAINMENT RATES FOR DEEP CLOUDS +!* 1.2 specify entrainment rates for deep clouds !------------------------------------------------------- - DO jl = 1, klon + do jl = 1, klon zpbase(jl) = paph(jl,kcbot(jl)) zrrho = (rd*ptenh(jl,kk+1))/paph(jl,kk+1) zdprho = (paph(jl,kk+1)-paph(jl,kk))*zrg -! old or new choice zpmid = 0.5*(zpbase(jl)+paph(jl,kctop0(jl))) zentr = pentr(jl)*pmfu(jl,kk+1)*zdprho*zrrho - llo1 = kk.LT.kcbot(jl).AND.ldcum(jl) -! old or new choice + llo1 = kk.lt.kcbot(jl).and.ldcum(jl) if(llo1) then - if(nturben.eq.1) zdmfde(jl) = zentr - if(nturben.eq.2) zdmfde(jl) = zentr*1.2 + zdmfde(jl) = zentr else - zdmfde(jl) = 0.0 + zdmfde(jl) = 0.0 endif -! old or new choice - if(nturben .eq. 1) then - fscale(jl) = 1.0 - elseif (nturben .eq. 2) then -! defining the facale - tt(jl) = ptenh(jl,kk+1) - zqsat(jl) = TLUCUA(tt(jl))/paph(jl,kk+1) - zqsat(jl) = zqsat(jl)/(1.-VTMPC1*zqsat(jl)) - ttb(jl) = ptenh(jl,kcbot(jl)) - zqsatb(jl) = TLUCUA(ttb(jl))/zpbase(jl) - zqsatb(jl) = zqsatb(jl)/(1.-VTMPC1*zqsatb(jl)) - fscale(jl) = 4.0*(zqsat(jl)/zqsatb(jl))**2 - end if -! end of defining the fscale - llo2 = llo1.AND.ktype(jl).EQ.2.AND.((zpbase(jl)-paph(jl,kk)) & - .LT.ZDNOPRC.OR.paph(jl,kk).GT.zpmid) + llo2 = llo1.and.ktype(jl).eq.2.and.((zpbase(jl)-paph(jl,kk)) & + .lt.zdnoprc.or.paph(jl,kk).gt.zpmid) if(llo2) then - zdmfen(jl) = zentr*fscale(jl) + zdmfen(jl) = zentr else zdmfen(jl) = 0.0 endif - iklwmin = MAX(klwmin(jl),kctop0(jl)+2) - llo2 = llo1.AND.ktype(jl).EQ.3.AND.(kk.GE.iklwmin.OR.pap(jl,kk) & - .GT.zpmid) - IF (llo2) zdmfen(jl) = zentr*fscale(jl) - llo2 = llo1.AND.ktype(jl).EQ.1 -! Turbulent entrainment - IF (llo2) zdmfen(jl) = zentr*fscale(jl) -! Organized detrainment, detrainment starts at khmin + iklwmin = max(klwmin(jl),kctop0(jl)+2) + llo2 = llo1.and.ktype(jl).eq.3.and.(kk.ge.iklwmin.or.pap(jl,kk) & + .gt.zpmid) + if (llo2) zdmfen(jl) = zentr + llo2 = llo1.and.ktype(jl).eq.1 +! turbulent entrainment + if (llo2) zdmfen(jl) = zentr +! organized detrainment, detrainment starts at khmin ikb = kcbot(jl) zodetr(jl,kk) = 0. - IF (llo2.AND.kk.LE.khmin(jl).AND.kk.GE.kctop0(jl)) THEN + if (llo2.and.kk.le.khmin(jl).and.kk.ge.kctop0(jl)) then ikt = kctop0(jl) ikh = khmin(jl) - IF (ikh.GT.ikt) THEN + if (ikh.gt.ikt) then zzmzk = -(pgeoh(jl,ikh)-pgeoh(jl,kk))*zrg ztmzk = -(pgeoh(jl,ikh)-pgeoh(jl,ikt))*zrg arg = 3.1415*(zzmzk/ztmzk)*0.5 - zorgde = TAN(arg)*3.1415*0.5/ztmzk + zorgde = tan(arg)*3.1415*0.5/ztmzk zdprho = (paph(jl,kk+1)-paph(jl,kk))*(zrg*zrrho) - zodetr(jl,kk) = MIN(zorgde,1.E-3)*pmfu(jl,kk+1)*zdprho - END IF - END IF - ENDDO + zodetr(jl,kk) = min(zorgde,1.e-3)*pmfu(jl,kk+1)*zdprho + end if + end if + enddo +! + return + end subroutine cuentr_new ! - RETURN - END SUBROUTINE CUENTR_NEW !********************************************************** -! FUNCTION SSUM, TLUCUA, TLUCUB, TLUCUC +! function ssum, tlucua, tlucub, tlucuc !********************************************************** - REAL FUNCTION SSUM ( N, X, IX ) -! -! COMPUTES SSUM = SUM OF [X(I)] -! FOR N ELEMENTS OF X WITH SKIP INCREMENT IX FOR VECTOR X + real function ssum ( n, x, ix ) ! - IMPLICIT NONE - REAL X(*) - REAL ZSUM - INTEGER N, IX, JX, JL +! computes ssum = sum of [x(i)] +! for n elements of x with skip increment ix for vector x ! - JX = 1 - ZSUM = 0.0 - DO JL = 1, N - ZSUM = ZSUM + X(JX) - JX = JX + IX + implicit none + real x(*) + real zsum + integer n, ix, jx, jl +! + jx = 1 + zsum = 0.0 + do jl = 1, n + zsum = zsum + x(jx) + jx = jx + ix enddo ! - SSUM=ZSUM + ssum=zsum ! - RETURN - END FUNCTION SSUM + return + end function ssum - REAL FUNCTION TLUCUA(TT) -! -! Set up lookup tables for cloud ascent calculations. -! - IMPLICIT NONE - REAL ZCVM3,ZCVM4,TT -! - IF(TT-TMELT.GT.0.) THEN - ZCVM3=C3LES - ZCVM4=C4LES - ELSE - ZCVM3=C3IES - ZCVM4=C4IES - END IF - TLUCUA=C2ES*EXP(ZCVM3*(TT-TMELT)*(1./(TT-ZCVM4))) + real function tlucua(tt) ! - RETURN - END FUNCTION TLUCUA +! set up lookup tables for cloud ascent calculations. ! - REAL FUNCTION TLUCUB(TT) + implicit none + real zcvm3,zcvm4,tt !,tlucua +! + if(tt-tmelt.gt.0.) then + zcvm3=c3les + zcvm4=c4les + else + zcvm3=c3ies + zcvm4=c4ies + end if + tlucua=c2es*exp(zcvm3*(tt-tmelt)*(1./(tt-zcvm4))) ! -! Set up lookup tables for cloud ascent calculations. + return + end function tlucua ! - IMPLICIT NONE - REAL Z5ALVCP,Z5ALSCP,ZCVM4,ZCVM5,TT + real function tlucub(tt) ! - Z5ALVCP=C5LES*ALV/CPD - Z5ALSCP=C5IES*ALS/CPD - IF(TT-TMELT.GT.0.) THEN - ZCVM4=C4LES - ZCVM5=Z5ALVCP - ELSE - ZCVM4=C4IES - ZCVM5=Z5ALSCP - END IF - TLUCUB=ZCVM5*(1./(TT-ZCVM4))**2 +! set up lookup tables for cloud ascent calculations. ! - RETURN - END FUNCTION TLUCUB + implicit none + real z5alvcp,z5alscp,zcvm4,zcvm5,tt !,tlucub +! + z5alvcp=c5les*alv/cpd + z5alscp=c5ies*als/cpd + if(tt-tmelt.gt.0.) then + zcvm4=c4les + zcvm5=z5alvcp + else + zcvm4=c4ies + zcvm5=z5alscp + end if + tlucub=zcvm5*(1./(tt-zcvm4))**2 ! - REAL FUNCTION TLUCUC(TT) + return + end function tlucub ! -! Set up lookup tables for cloud ascent calculations. + real function tlucuc(tt) ! - IMPLICIT NONE - REAL ZALVDCP,ZALSDCP,TT,ZLDCP +! set up lookup tables for cloud ascent calculations. ! - ZALVDCP=ALV/CPD - ZALSDCP=ALS/CPD - IF(TT-TMELT.GT.0.) THEN - ZLDCP=ZALVDCP - ELSE - ZLDCP=ZALSDCP - END IF - TLUCUC=ZLDCP + implicit none + real zalvdcp,zalsdcp,tt,zldcp !,tlucuc +! + zalvdcp=alv/cpd + zalsdcp=als/cpd + if(tt-tmelt.gt.0.) then + zldcp=zalvdcp + else + zldcp=zalsdcp + end if + tlucuc=zldcp ! - RETURN - END FUNCTION TLUCUC + return + end function tlucuc ! -END MODULE module_cu_tiedtke +end module module_cu_tiedtke diff --git a/wrfv2_fire/phys/module_cumulus_driver.F b/wrfv2_fire/phys/module_cumulus_driver.F index f6ad0d5d..79bf3bd7 100644 --- a/wrfv2_fire/phys/module_cumulus_driver.F +++ b/wrfv2_fire/phys/module_cumulus_driver.F @@ -17,20 +17,55 @@ SUBROUTINE cumulus_driver(grid & ,itimestep,dt,dx,cudt,curr_secs,adapt_step_flag & ,cudtacttime & ,rainc,raincv,pratec,nca & - ,cldfra_dp,cldfra_sh & !ckay for subgrid cloud + ,cldfra_dp,cldfra_sh,w_up & !ckay for subgrid cloud ,QC_CU,QI_CU & ,z,z_at_w,dz8w,mavail,pblh,p8w,psfc,tsk & ,tke_pbl, ust & + ,ZOL,WSTAR & !ckay ,forcet,forceq,w0avg,stepcu,gsw & ,cldefi,lowlyr,xland,cu_act_flag,warm_rain & ,hfx,qfx,cldfra,cldfra_mp_all,tpert2d & ,htop,hbot,kpbl,ht & ,ensdim,maxiens,maxens,maxens2,maxens3 & +#if (EM_CORE == 1) + !BSINGH - For WRFCuP Scheme + ,akpbl, br,regime,t2,q2 & !CuP, wig 3-Aug-2006 + ,slopeSfc, slopeEZ, sigmaSfc, sigmaEZ & !CuP, wig 7-Aug-2006 + ,cupflag, cldfra_cup, cldfratend_cup & !CuP, wig 18-Sep-2006 + ,shall, taucloud, tactive & !CuP, wig 18-Sep-2006 + ,activeFrac & !CuP, lkb 4-May-2010 + ,tstar, lnterms, lnint & !CuP, wig 4-Oct-2006 + ,numBins, thBinSize, rBinSize & !CUP, lkb 4-Nov-2009 + ,minDeepFreq, minShallowFreq & !CUP, lkb 4-Nov-2009 + ,wCloudBase & !CuP, lkb 29-April-2010 + ,wact_cup & !CuP, rce 10-may-2012 + ,wulcl_cup & !CuP, rce 10-may-2012 + ,wup_cup & !CuP, rce 15-mar-2013 !BSINGH (12/06/2013) + ,qc_ic_cup & !CuP, rce 10-may-2012 + ,qndrop_ic_cup & !CuP, rce 10-may-2012 + ,qc_iu_cup & !CuP, rce 10-may-2012 + ,fcvt_qc_to_pr_cup & !CuP, rce 10-may-2012 + ,fcvt_qc_to_qi_cup & !CuP, rce 10-may-2012 + ,fcvt_qi_to_pr_cup & !CuP, rce 10-may-2012 + ,mfup_cup & !CuP, rce 10-may-2012 + ,mfup_ent_cup & !CuP, rce 10-may-2012 + ,mfdn_cup & !CuP, rce 10-may-2012 + ,mfdn_ent_cup & !CuP, rce 10-may-2012 + ,updfra_cup & !CuP, rce 10-may-2012 + ,tcloud_cup & !CuP, rce 10-may-2012 + !BSINGH -ENDS +#endif ,periodic_x,periodic_y & ,is_CAMMGMP_used & ,evapcdp3d,icwmrdp3d,rprddp3d & !Balwinder.Singh@pnnl.gov: Used for CAM's wet scavenging ! Package selection variables ,cu_physics, bl_pbl_physics, sf_sfclay_physics & +#if (EM_CORE == 1) + !BSINGH - For WRFCuP Scheme + ,shcu_aerosols_opt & !CuP, rce 10-may-2012 + ,chem_opt & !CuP, rce 10-may-2012 + !BSINGH - ENDS +#endif ! Optional moisture tracers ,qv_curr, qc_curr, qr_curr & ,qi_curr, qs_curr, qg_curr & @@ -92,10 +127,15 @@ SUBROUTINE cumulus_driver(grid & ,CAMZMSCHEME, SASSCHEME & ,OSASSCHEME,MESO_SAS & !Kwon ,NSASSCHEME & -# if (EM_CORE == 1) - , CAMMGMPSCHEME & -# endif - ,TIEDTKESCHEME +#if (EM_CORE == 1) + ,MSKFSCHEME & + ,CAMMGMPSCHEME & + ,KFCUPSCHEME & !CuP, wig 3-Aug-2006 !BSINGH - For WRFCuP scheme + ,num_chem & !CuP, rce 10-may-2012 !BSINGH - For WRFCuP scheme +#endif + ,TIEDTKESCHEME & + ,NTIEDTKESCHEME + ! *** add new modules of schemes here @@ -103,20 +143,27 @@ SUBROUTINE cumulus_driver(grid & USE module_cu_bmj , ONLY : bmjdrv #ifdef DM_PARALLEL USE module_dm , ONLY : ntasks_x,ntasks_y,local_communicator,mytask,ntasks -# if (EM_CORE == 1) +#if (EM_CORE == 1) USE module_comm_dm , ONLY : halo_cup_g3_in_sub, halo_cup_g3_out_sub -# endif +#endif #endif USE module_domain , ONLY: domain USE module_cu_kfeta , ONLY : kf_eta_cps +#if (EM_CORE==1) + USE module_cu_mskf , ONLY : mskf_cps +#endif USE module_cu_gd , ONLY : grelldrv USE module_cu_gf , ONLY : gfdrv USE module_cu_g3 , ONLY : g3drv,conv_grell_spread3d USE module_cu_sas , ONLY : cu_sas +#if (EM_CORE == 1) + USE module_cu_kfcup , ONLY : KF_CUP_CPS !wig, 3-Aug-2006 !BSINGH - For WRFCuP scheme +#endif USE module_cu_osas , ONLY : cu_osas USE module_cu_mesosas, ONLY : cu_meso_sas USE module_cu_camzm_driver, ONLY : camzm_driver USE module_cu_tiedtke, ONLY : cu_tiedtke + USE module_cu_ntiedtke,ONLY : cu_ntiedtke USE module_cu_nsas , ONLY : cu_nsas USE module_wrf_error , ONLY : wrf_err_message @@ -130,6 +177,7 @@ SUBROUTINE cumulus_driver(grid & ! 5. Grell 3D ensemble scheme ! 6. Modified Tiedtke scheme (Zhang and Wang 2010) ! 14. New simplified Arakawa-Schubert scheme (NCEP, YSU) + ! 16. New Tiedtke scheme (Bechtold et al. 2004, 2008, 2014) ! !---------------------------------------------------------------------- IMPLICIT NONE @@ -305,6 +353,14 @@ SUBROUTINE cumulus_driver(grid & INTEGER, OPTIONAL, INTENT(IN ) :: & cugd_avedx,clos_choice,bl_pbl_physics,sf_sfclay_physics +#if (EM_CORE == 1) + !BSINGH - For WRFCuP scheme + INTEGER, OPTIONAL, INTENT(IN ) :: & + shcu_aerosols_opt !CuP, rce 10-may-2012 + !BSINGH - ENDS +#endif + + INTEGER, INTENT(IN ) :: cu_physics INTEGER, INTENT(IN ) :: STEPCU LOGICAL, INTENT(IN ) :: warm_rain @@ -315,6 +371,17 @@ SUBROUTINE cumulus_driver(grid & INTEGER,DIMENSION( ims:ime, jms:jme ), & INTENT(IN ) :: LOWLYR +#if (EM_CORE == 1) + !BSINGH - For WRFCuP scheme + REAL,DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: shall, & !CuP, wig 18-Sep-2006 + taucloud, & !CuP, wig 1-Oct-2006 + tactive, & !CuP, wig 1-Oct-2006 + activeFrac, & !CuP, lkb 5-May-2010 + wCloudBase !CuP, lkb 29-April-2010 + !BSINGH - ENDS +#endif + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(IN ) :: & @@ -327,8 +394,11 @@ SUBROUTINE cumulus_driver(grid & , v & , th & , t & - , rho & - , w + , rho ! ckay +!ckay + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INout ) :: w + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT ), OPTIONAL :: evapcdp3d, icwmrdp3d, rprddp3d REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & @@ -345,8 +415,22 @@ SUBROUTINE cumulus_driver(grid & INTENT(INOUT) :: cldfra_dp & , cldfra_sh + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ),OPTIONAL :: w_up + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: & GSW,HT,XLAND +#if (EM_CORE == 1) + !BSINGH - For WRFCuP scheme + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) :: & + br, & !CuP, wig 3-Aug-2006 + regime, & !CuP, wig 3-Aug-2006 + t2, & !CuP, wig 3-Aug-2006 + q2 !CuP, wig 3-Aug-2006 + + !BSINGH - ENDS +#endif + REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: RAINC & @@ -355,12 +439,21 @@ SUBROUTINE cumulus_driver(grid & , HTOP & , HBOT & , CLDEFI +#if (EM_CORE == 1) + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: akpbl !CuP, wig 6-Oct-2006 testing !BSINGH - For WRFCuP scheme +#endif REAL, DIMENSION( kms:kme ), OPTIONAL, INTENT(IN ) :: & znu REAL, DIMENSION( ims:ime , jms:jme ),INTENT(INOUT),OPTIONAL :: & PRATEC,MAVAIL,PBLH,PSFC,TSK,TPERT2D,UST,HFX,QFX + +!ckay + REAL, DIMENSION( ims:ime , jms:jme ), & + OPTIONAL, INTENT(INOUT) :: ZOL & + , WSTAR + REAL, DIMENSION( ims:ime , jms:jme ) :: tmppratec INTEGER, DIMENSION( ims:ime , jms:jme ), & @@ -447,6 +540,54 @@ SUBROUTINE cumulus_driver(grid & REAL, DIMENSION( ims:ime , jms:jme , 1:ensdim ), & OPTIONAL, & INTENT(INOUT) :: XF_ENS, PR_ENS + + +#if (EM_CORE == 1) +!BSINGH - For WRFCuP Scheme + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(OUT) :: slopeSfc, slopeEZ, & !CuP, wig 7-Aug-2006 + sigmaSfc, SigmaEZ, & !CuP, wig 7-Aug-2006 + tstar, & !CuP, wig 4-Oct-2006 + lnint !CuP, wig 4-Oct-2006 + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(OUT) :: & + lnterms, & !CuP, wig 4-Oct-2006 + cldfra_cup, & !CuP, wig 18-Sep-2006 + cldfratend_cup !CuP, wig 18-Sep-2006 + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: wact_cup, & !CuP, rce 10-may-2012 + wulcl_cup, & !CuP, rce 10-may-2012 + tcloud_cup !CuP, rce 10-may-2012 + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: & + wup_cup, & !CuP, rce 15-mar-2013 !BSINGH (12/06/2013) + qc_ic_cup, & !CuP, rce 10-may-2012 + qndrop_ic_cup, & !CuP, rce 10-may-2012 + qc_iu_cup, & !CuP, rce 10-may-2012 + fcvt_qc_to_pr_cup, & !CuP, rce 10-may-2012 + fcvt_qc_to_qi_cup, & !CuP, rce 10-may-2012 + fcvt_qi_to_pr_cup, & !CuP, rce 10-may-2012 + mfup_cup, & !CuP, rce 10-may-2012 + mfup_ent_cup, & !CuP, rce 10-may-2012 + mfdn_cup, & !CuP, rce 10-may-2012 + mfdn_ent_cup, & !CuP, rce 10-may-2012 + updfra_cup !CuP, rce 10-may-2012 + + INTEGER, OPTIONAL, INTENT(IN) :: chem_opt !CuP, rce 10-may-2012 + + LOGICAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(OUT) :: cupflag !CuP, wig 9-Oct-2006 + + REAL, INTENT(IN ) :: thBinSize, rBinSize + INTEGER, INTENT(IN ) :: numBins + REAL, INTENT(IN ) :: minDeepFreq, minShallowFreq +!BSINGH - ENDS +#endif + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & OPTIONAL, & INTENT(INOUT) :: & @@ -603,7 +744,7 @@ SUBROUTINE cumulus_driver(grid & END IF #if ( EM_CORE == 1 ) - if(cu_physics .eq. 5 ) then + if(cu_physics .eq. 5 .or. cu_physics .eq. 16) then !$OMP PARALLEL DO & !$OMP PRIVATE ( ij,i,j,k,its,ite,jts,jte ) @@ -625,7 +766,8 @@ SUBROUTINE cumulus_driver(grid & !$OMP END PARALLEL DO endif - IF ( cu_physics == G3SCHEME .OR. cu_physics == GFSCHEME .OR. cu_physics == KFETASCHEME ) THEN + IF ( cu_physics == G3SCHEME .OR. cu_physics == GFSCHEME .OR. & + cu_physics == KFETASCHEME .OR. cu_physics == MSKFSCHEME ) THEN #ifdef DM_PARALLEL #include "HALO_CUP_G3_IN.inc" #endif @@ -645,6 +787,18 @@ SUBROUTINE cumulus_driver(grid & ite = i_end(ij) jts = j_start(ij) jte = j_end(ij) + +#if (EM_CORE == 1) + !BSINGH - For WRFCuP scheme + !wig, beg: testing for kpbl to get output to wrfout since kpbl won't output as an integer + do j=jts,jte + do i=its,ite + akpbl(i,j) = kpbl(i,j) + end do + end do + !wig, end. + !BSINGH - ENDS +#endif cps_select: SELECT CASE(cu_physics) @@ -730,8 +884,43 @@ SUBROUTINE cumulus_driver(grid & ,F_QI=f_qi,F_QS=f_qs & ,CLDFRA_DP_KF=cldfra_dp & ! ckay for sub-grid cloud ,CLDFRA_SH_KF=cldfra_sh & + ,QC_KF=QC_CU,QI_KF=QI_CU ) + +#if (EM_CORE==1) + CASE (MSKFSCHEME) + CALL wrf_debug(100,'in mskf_cps') + CALL MSKF_CPS( & + U=u ,V=v ,TH=th ,T=t ,W=w ,RHO=rho & + ,CUDT=cudt_pass & + ,ADAPT_STEP_FLAG=adapt_step_flag_pass & + ,RAINCV=raincv, PRATEC=tmppratec, NCA=nca & + ,DZ8W=dz8w & + ,PCPS=p, PI=pi ,W0AVG=W0AVG & + ,CUTOP=HTOP,CUBOT=HBOT & + ,XLV0=XLV0 ,XLV1=XLV1 ,XLS0=XLS0 ,XLS1=XLS1 & + ,CP=CP ,R=R_d ,G=G ,EP1=EP_1 ,EP2=EP_2 & + ,SVP1=SVP1 ,SVP2=SVP2 ,SVP3=SVP3 ,SVPT0=SVPT0 & + ,DT=dt ,KTAU=itimestep ,DX=dx & + ,STEPCU=stepcu & + ,CU_ACT_FLAG=cu_act_flag ,WARM_RAIN=warm_rain & + ,QV=qv_curr & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ,trigger=trigger_kf & + ! optionals + ,RTHCUTEN=rthcuten & + ,RQVCUTEN=rqvcuten ,RQCCUTEN=rqccuten & + ,RQRCUTEN=rqrcuten ,RQICUTEN=rqicuten & + ,RQSCUTEN=rqscuten, RQVFTEN=RQVFTEN & + ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & + ,F_QI=f_qi,F_QS=f_qs & + ,CLDFRA_DP_KF=cldfra_dp & ! ckay for sub-grid cloud + ,CLDFRA_SH_KF=cldfra_sh & + ,W_UP=w_up & ! ckay ,QC_KF=QC_CU,QI_KF=QI_CU & - ) + ,ZOL=zol,WSTAR=wstar,UST=ust,PBLH=pblh ) !ckay +#endif CASE (GDSCHEME) CALL wrf_debug(100,'in grelldrv') @@ -1043,7 +1232,7 @@ SUBROUTINE cumulus_driver(grid & CALL wrf_debug(100,'in cu_tiedtke') CALL CU_TIEDTKE( & - DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU,HFX=hfx & + DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU & ,RAINCV=RAINCV,PRATEC=tmppratec,QFX=qfx,ZNU=znu & ,U3D=u,V3D=v,W=w,T3D=t,PI3D=pi,RHO3D=rho & ,QV3D=QV_CURR,QC3D=QC_CURR,QI3D=QI_CURR & @@ -1069,6 +1258,38 @@ SUBROUTINE cumulus_driver(grid & CALL wrf_error_fatal('Lacking arguments for CU_TIEDTKE in cumulus driver') ENDIF +! NEW TIEDTKE SCHEME - ZCX&YQW (U of Hawaii) + CASE (NTIEDTKESCHEME) + + IF ( PRESENT ( QFX ) .AND. PRESENT( HFX )) THEN + + CALL wrf_debug(100,'in cu_ntiedtke') + CALL CU_NTIEDTKE( & + DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU,HFX=hfx & + ,RAINCV=RAINCV,PRATEC=tmppratec,QFX=qfx & + ,U3D=u,V3D=v,W=w,T3D=t,PI3D=pi,RHO3D=rho & + ,QV3D=QV_CURR,QC3D=QC_CURR,QI3D=QI_CURR & + ,DZ8W=dz8w,PCPS=p,P8W=p8w,XLAND=XLAND,DX=dx & + ,CU_ACT_FLAG=CU_ACT_FLAG & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ! optionals +#if (NMM_CORE == 1 ) + ,QVFTEN=FORCEQ, THFTEN=FORCET & +#else + ,QVFTEN=RQVFTEN,THFTEN=RTHFTEN & +#endif + ,RTHCUTEN=RTHCUTEN,RQVCUTEN=RQVCUTEN & + ,RQCCUTEN=RQCCUTEN,RQICUTEN=RQICUTEN & + ,RUCUTEN = RUCUTEN,RVCUTEN = RVCUTEN & + ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & + ,F_QI=f_qi,F_QS=f_qs & + ) + ELSE + CALL wrf_error_fatal('Lacking arguments for CU_NTIEDTKE in cumulus driver') + ENDIF + ! New GFS SAS SCHEME - (Yonsei Univ., South Korea) CASE (NSASSCHEME) IF ( PRESENT ( QFX ) .AND. PRESENT( HFX ) ) THEN @@ -1102,6 +1323,80 @@ SUBROUTINE cumulus_driver(grid & ELSE CALL wrf_error_fatal('Lacking arguments for CU_NSAS in cumulus driver') ENDIF +#if (EM_CORE == 1) + !BSINGH - For WRFCuP scheme + CASE (KFCUPSCHEME) + + CALL wrf_debug(100,'in cu_kfcup') + CALL KF_CUP_CPS( GRID_ID=grid%grid_id & !rce 10-may-2012 add grid%id + ,U=u ,V=v ,TH=th ,T=t ,W=w ,RHO=rho & + ,RAINCV=raincv,NCA=nca ,DZ8W=dz8w,XLAND=xland & !LD add PRATEC 21-Apr-2011 + ,PCPS=p, PI=pi ,W0AVG=W0AVG & + ,CUTOP=HTOP,CUBOT=HBOT & + ,XLV0=XLV0 ,XLV1=XLV1 ,XLS0=XLS0 ,XLS1=XLS1 & + ,CP=CP ,R=R_d ,G=G ,EP1=EP_1 ,EP2=EP_2 & + ,SVP1=SVP1 ,SVP2=SVP2 ,SVP3=SVP3 ,SVPT0=SVPT0 & + ,DT=dt ,KTAU=itimestep ,DX=dx & + ,STEPCU=stepcu & + ,CU_ACT_FLAG=cu_act_flag ,warm_rain=warm_rain & + ,QV=qv_curr & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ,PSFC=psfc,Z=z,Z_AT_W=z_at_w,HT=ht,TSK=tsk & !CuP, wig 5-Oct-2006 + ,HFX=hfx,QFX=qfx & !CuP, wig, 24-Aug-2006 + ,MAVAIL=mavail,SF_SFCLAY_PHYSICS=sf_sfclay_physics & !CuP, wig, 24-Aug-2006 + ,BR=br,REGIME=regime,PBLH=pblh,KPBL=kpbl & !CuP, wig, 24-Aug-2006 + ,T2=t2,Q2=q2 & !CuP, wig, 24-Aug-2006 + ,SLOPESFC=slopeSfc,SLOPEEZ=slopeEZ & !CuP, wig, 24-Aug-2006 + ,SIGMASFC=sigmasfc,SIGMAEZ=sigmaEZ & !CuP, wig, 24-Aug-2006 + ,CUPFLAG=cupflag,CLDFRA_CUP=cldfra_cup & !CuP, wig, 18-Sep-2006 + ,CLDFRATEND_CUP=cldfratend_cup & !CuP, wig, 18-Sep-2006 + ,SHALL=shall,TAUCLOUD=taucloud,TACTIVE=tactive & !CuP, wig, 18-Sep-2006 + ,ACTIVEFRAC=activeFrac & !CuP, lkb, 5-May-2010 + ,TSTAR=tstar, LNTERMS=lnterms & !CuP, wig 4-Oct-2006 + ,LNINT=lnint & !CuP, wig 4-Oct-2006 + ,NUMBINS=numBins & !CuP, lkb 4-Nov-2009 + ,THBINSIZE=thBinSize, RBINSIZE=rBinSize & !CuP, lkb 4-Nov-2009 + ,MINDEEPFREQ=minDeepFreq, MINSHALLOWFREQ=minShallowFreq & !CuP, lkb 4-Nov-2009 + ,WCLOUDBASE=wCloudBase & !CuP, lkb 29-April-2010 + ,WACT_CUP=wact_cup & !CuP, rce 10-may-2012 + ,WULCL_CUP=wulcl_cup & !CuP, rce 10-may-2012 + ,WUP_CUP=wup_cup & !CuP, rce 15-mar-2013 !BSINGH (12/06/2013) + ,QC_IC_CUP=qc_ic_cup & !CuP, rce 10-may-2012 + ,QNDROP_IC_CUP=qndrop_ic_cup & !CuP, rce 10-may-2012 + ,QC_IU_CUP=qc_iu_cup & !CuP, rce 10-may-2012 + ,FCVT_QC_TO_PR_CUP=fcvt_qc_to_pr_cup & !CuP, rce 10-may-2012 + ,FCVT_QC_TO_QI_CUP=fcvt_qc_to_qi_cup & !CuP, rce 10-may-2012 + ,FCVT_QI_TO_PR_CUP=fcvt_qi_to_pr_cup & !CuP, rce 10-may-2012 + ,MFUP_CUP=mfup_cup & !CuP, rce 10-may-2012 + ,MFUP_ENT_CUP=mfup_ent_cup & !CuP, rce 10-may-2012 + ,MFDN_CUP=mfdn_cup & !CuP, rce 10-may-2012 + ,MFDN_ENT_CUP=mfdn_ent_cup & !CuP, rce 10-may-2012 + ,UPDFRA_CUP=updfra_cup & !CuP, rce 10-may-2012 + ,TCLOUD_CUP=tcloud_cup & !CuP, rce 10-may-2012 + ,SHCU_AEROSOLS_OPT=shcu_aerosols_opt & !CuP, rce 10-may-2012 +#if ( WRF_CHEM == 1 ) + ,CHEM_OPT=chem_opt & !CuP, rce 10-may-2012 + ,CHEM=grid%chem & !CuP, rce 10-may-2012 +#endif + ! optionals + ,RTHCUTEN=rthcuten & + ,RQVCUTEN=rqvcuten ,RQCCUTEN=rqccuten & + ,RQRCUTEN=rqrcuten ,RQICUTEN=rqicuten & + ,RQSCUTEN=rqscuten & + ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & + ,F_QI=f_qi,F_QS=f_qs & + ) + + + DO J = jts,jte + DO I=its,ite + tmppratec(i,j)=raincv(i,j)/DT !!!!!byang, move the pratec after calling cup + end do + end do + !BSINGH -ENDS +#endif CASE DEFAULT diff --git a/wrfv2_fire/phys/module_data_cam_mam_aero.F b/wrfv2_fire/phys/module_data_cam_mam_aero.F index 72d4bdfe..61d29347 100644 --- a/wrfv2_fire/phys/module_data_cam_mam_aero.F +++ b/wrfv2_fire/phys/module_data_cam_mam_aero.F @@ -3,7 +3,7 @@ ! Updated to CESM1.0.3 (CAM5.1.01) by Balwinder.Singh@pnnl.gov !-------------------------------------------------------------- #define WRF_PORT -#if defined ( WRF_CHEM ) +#if ( WRF_CHEM == 1 ) # include "../chem/MODAL_AERO_CPP_DEFINES.h" #else # define MODAL_AERO diff --git a/wrfv2_fire/phys/module_data_gocart_dust.F b/wrfv2_fire/phys/module_data_gocart_dust.F index 26b8b44e..d12bbc58 100644 --- a/wrfv2_fire/phys/module_data_gocart_dust.F +++ b/wrfv2_fire/phys/module_data_gocart_dust.F @@ -1,8 +1,16 @@ Module module_data_gocart_dust INTEGER, PARAMETER :: ndust=5,ndcls=3,ndsrc=1,maxstypes=100 INTEGER, PARAMETER :: ngsalt=9 - real, dimension (maxstypes) :: drypoint - real, dimension (maxstypes) :: porosity +! GAC--> +! 20130219 - Drypoint no longer needed. Use NOAA porosity for all schemes to +! allow use of AFWA dust scheme by all LSMs, not just NOAA and RUC. +! real, dimension (maxstypes) :: drypoint +! real, dimension (maxstypes) :: porosity + real, dimension (19), PARAMETER :: porosity=(/0.339, 0.421, 0.434, 0.476, 0.476, 0.439, & + 0.404, 0.464, 0.465, 0.406, 0.468, 0.468, & + 0.439, 1.000, 0.200, 0.421, 0.468, 0.200, & + 0.339/) +! <--GAC REAL :: ch_dust(ndust,12) REAL, PARAMETER :: dyn_visc = 1.5E-5 diff --git a/wrfv2_fire/phys/module_diag_afwa.F b/wrfv2_fire/phys/module_diag_afwa.F index 2bbe6272..6856ba4f 100644 --- a/wrfv2_fire/phys/module_diag_afwa.F +++ b/wrfv2_fire/phys/module_diag_afwa.F @@ -8,836 +8,3232 @@ END MODULE module_diag_afwa !WRF:MEDIATION_LAYER:PHYSICS -MODULE module_diag_afwa +MODULE diag_functions CONTAINS - SUBROUTINE afwa_diagnostics_driver ( grid , config_flags & - , moist & - , scalar & - , chem & - , th_phy , pi_phy , p_phy & - , dz8w , p8w , t8w , rho_phy & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe & - , its, ite, jts, jte & - , k_start, k_end ) + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ calc_rh + !~ + !~ Description: + !~ This function calculates relative humidity given pressure, + !~ temperature, and water vapor mixing ratio. + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION calc_rh ( p, t, qv ) result ( rh ) + + IMPLICIT NONE + + REAL, INTENT(IN) :: p, t, qv + REAL :: rh - !USE module_domain, ONLY : domain - USE module_domain - USE module_configure, ONLY : grid_config_rec_type, model_config_rec - USE module_state_description - USE module_model_constants -#ifdef DM_PARALLEL - USE module_dm, ONLY: wrf_dm_sum_real, wrf_dm_maxval -#endif + ! Local + ! ----- + REAL, PARAMETER :: pq0=379.90516 + REAL, PARAMETER :: a2=17.2693882 + REAL, PARAMETER :: a3=273.16 + REAL, PARAMETER :: a4=35.86 + REAL, PARAMETER :: rhmin=1. + REAL :: q, qs + INTEGER :: i,j,k + + ! Following algorithms adapted from WRFPOST + ! May want to substitute with another later + ! ----------------------------------------- + q=qv/(1.0+qv) + qs=pq0/p*exp(a2*(t-a3)/(t-a4)) + rh=100.*q/qs + IF (rh .gt. 100.) THEN + rh=100. + ELSE IF (rh .lt. rhmin) THEN + rh=rhmin + ENDIF - IMPLICIT NONE + END FUNCTION calc_rh - TYPE ( domain ), INTENT(INOUT) :: grid - TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags - INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe - INTEGER :: k_start , k_end, its, ite, jts, jte - REAL, DIMENSION( ims:ime, kms:kme, jms:jme , num_moist), & - INTENT(IN ) :: moist + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ uv_wind + !~ + !~ Description: + !~ This function calculates the wind speed given U and V wind + !~ components. + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION uv_wind ( u, v ) result ( wind_speed ) + + IMPLICIT NONE + + REAL, INTENT(IN) :: u, v + REAL :: wind_speed - REAL, DIMENSION( ims:ime, kms:kme, jms:jme , num_scalar), & - INTENT(IN ) :: scalar + wind_speed = sqrt( u*u + v*v ) - REAL, DIMENSION( ims:ime, kms:kme, jms:jme , num_chem), & - INTENT(IN ) :: chem + END FUNCTION uv_wind - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: th_phy & - , pi_phy & - , p_phy & - , dz8w & - , p8w & - , t8w & - , rho_phy - ! Local - ! ----- - CHARACTER*256 :: message, timestr - INTEGER :: i,j,k - INTEGER :: icing_opt - REAL :: bdump - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qrain & - , qsnow & - , qgrpl & - , qvapr & - , qcloud & - , qice & - , ncloud & - , rh & - , ptot & - , z_e & - , zagl + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ Theta + !~ + !~ Description: + !~ This function calculates potential temperature as defined by + !~ Poisson's equation, given temperature and pressure ( hPa ). + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION Theta ( t, p ) + IMPLICIT NONE - REAL, DIMENSION( ims:ime, jms:jme, 5 ) :: dustc - REAL, DIMENSION( ims:ime, jms:jme ) :: rh2m & - , wind10m + !~ Variable declaration + ! -------------------- + REAL, INTENT ( IN ) :: t + REAL, INTENT ( IN ) :: p + REAL :: theta - ! Timing - TYPE(WRFU_Time) :: hist_time, aux2_time, CurrTime - TYPE(WRFU_TimeInterval) :: dtint, histint, aux2int - LOGICAL :: is_after_history_dump, is_output_timestep + REAL :: Rd ! Dry gas constant + REAL :: Cp ! Specific heat of dry air at constant pressure + REAL :: p0 ! Standard pressure ( 1000 hPa ) + + Rd = 287.04 + Cp = 1004.67 + p0 = 1000.00 - ! Chirp the routine name for debugging purposes - ! --------------------------------------------- - write ( message, * ) 'inside afwa_diagnostics_driver' - CALL wrf_debug( 100 , message ) + !~ Poisson's equation + ! ------------------ + theta = t * ( (p0/p)**(Rd/Cp) ) + + END FUNCTION Theta - ! Get timing info - ! Want to know if when the last history output was - ! Check history and auxhist2 alarms to check last ring time and how often - ! they are set to ring - ! ----------------------------------------------------------------------- - CALL WRFU_ALARMGET( grid%alarms( HISTORY_ALARM ), prevringtime=hist_time, & - ringinterval=histint) - CALL WRFU_ALARMGET( grid%alarms( AUXHIST2_ALARM ), prevringtime=aux2_time, & - ringinterval=aux2int) - ! Get domain clock - ! ---------------- - CALL domain_clock_get ( grid, current_time=CurrTime, & - current_timestr=timestr, time_step=dtint ) - ! Set some booleans for use later - ! Following uses an overloaded .lt. - ! --------------------------------- - is_after_history_dump = ( Currtime .lt. hist_time + dtint ) + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ Thetae + !~ + !~ Description: + !~ This function returns equivalent potential temperature using the + !~ method described in Bolton 1980, Monthly Weather Review, equation 43. + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION Thetae ( tK, p, rh, mixr ) + IMPLICIT NONE - ! Following uses an overloaded .ge. - ! --------------------------------- - is_output_timestep = (Currtime .ge. hist_time + histint - dtint .or. & - Currtime .ge. aux2_time + aux2int - dtint ) - write ( message, * ) 'is output timestep? ', is_output_timestep - CALL wrf_debug( 100 , message ) - - ! 3-D arrays for moisture variables - ! --------------------------------- - DO i=ims, ime - DO k=kms, kme - DO j=jms, jme - qvapr(i,k,j) = moist(i,k,j,P_QV) - qrain(i,k,j) = moist(i,k,j,P_QR) - qsnow(i,k,j) = moist(i,k,j,P_QS) - qgrpl(i,k,j) = moist(i,k,j,P_QG) - qcloud(i,k,j) = moist(i,k,j,P_QC) - qice(i,k,j) = moist(i,k,j,P_QI) - ncloud(i,k,j) = scalar(i,k,j,P_QNC) - ENDDO - ENDDO - ENDDO - - ! Total pressure - ! -------------- - DO i=ims, ime - DO k=kms, kme - DO j=jms, jme - ptot(i,k,j)=grid%pb(i,k,j)+grid%p(i,k,j) - ENDDO - ENDDO - ENDDO + !~ Variable Declarations + ! --------------------- + REAL :: tK ! Temperature ( K ) + REAL :: p ! Pressure ( hPa ) + REAL :: rh ! Relative humidity + REAL :: mixr ! Mixing Ratio ( kg kg^-1) + REAL :: te ! Equivalent temperature ( K ) + REAL :: thetae ! Equivalent potential temperature + + REAL, PARAMETER :: R = 287.04 ! Universal gas constant (J/deg kg) + REAL, PARAMETER :: P0 = 1000.0 ! Standard pressure at surface (hPa) + REAL, PARAMETER :: lv = 2.54*(10**6) ! Latent heat of vaporization + ! (J kg^-1) + REAL, PARAMETER :: cp = 1004.67 ! Specific heat of dry air constant + ! at pressure (J/deg kg) + REAL :: tlc ! LCL temperature + + !~ Calculate the temperature of the LCL + ! ------------------------------------ + tlc = TLCL ( tK, rh ) + + !~ Calculate theta-e + ! ----------------- + thetae = (tK * (p0/p)**( (R/Cp)*(1.- ( (.28E-3)*mixr*1000.) ) ) )* & + exp( (((3.376/tlc)-.00254))*& + (mixr*1000.*(1.+(.81E-3)*mixr*1000.)) ) + + END FUNCTION Thetae - ! Calculate relative humidity and mid-level relative humidity - ! ----------------------------------------------------------- - DO i=ims,ime - DO k=kms,kme - DO j=jms,jme - rh(i,k,j)=calc_rh(ptot(i,k,j),grid%t_phy(i,k,j), qvapr(i,k,j)) - ENDDO - ENDDO - ENDDO -#ifdef WRF_CHEM - ! Surface dust concentration array (ug m-3) - ! ----------------------------------------- - DO i=ims, ime - DO j=jms, jme - dustc(i,j,1)=chem(i,k_start,j,p_dust_1)*grid%rho(i,k_start,j) - dustc(i,j,2)=chem(i,k_start,j,p_dust_2)*grid%rho(i,k_start,j) - dustc(i,j,3)=chem(i,k_start,j,p_dust_3)*grid%rho(i,k_start,j) - dustc(i,j,4)=chem(i,k_start,j,p_dust_4)*grid%rho(i,k_start,j) - dustc(i,j,5)=chem(i,k_start,j,p_dust_5)*grid%rho(i,k_start,j) - ENDDO - ENDDO -#else - dustc(ims:ime,jms:jme,:)=0. -#endif - - ! Calculate severe weather diagnostics. These variables should only be - ! output at highest frequency output. (e.g. auxhist2) - ! --------------------------------------------------------------------- - IF ( config_flags % afwa_severe_opt == 1 ) THEN - - ! After each history dump, reset max/min value arrays - ! Note: This resets up_heli_max which is currently calculated within - ! rk_first_rk_step_part2.F, may want to move to this diagnostics package - ! later - ! ---------------------------------------------------------------------- - IF ( is_after_history_dump ) THEN - DO j = jms, jme - DO i = ims, ime - grid%wspd10max(i,j) = 0. - grid%w_up_max(i,j) = 0. - grid%w_dn_max(i,j) = 0. - grid%tcoli_max(i,j) = 0. - grid%up_heli_max(i,j) = 0. - grid%refd_max(i,j) = 0. - grid%afwa_llws(i,j) = 0. - grid%afwa_hail(i,j) = 0. - grid%afwa_tornado(i,j) = 0. - grid%midrh_min_old(i,j) = grid%midrh_min(i,j) ! Save old midrh_min - grid%midrh_min(i,j) = 999. - ENDDO - ENDDO - ENDIF ! is_after_history_dump - - CALL severe_wx_diagnostics ( grid % wspd10max & - , grid % w_up_max & - , grid % w_dn_max & - , grid % up_heli_max & - , grid % tcoli_max & - , grid % midrh_min_old & - , grid % midrh_min & - , grid % afwa_hail & - , grid % afwa_cape & - , grid % afwa_zlfc & - , grid % afwa_plfc & - , grid % afwa_llws & - , grid % afwa_tornado & - , grid % u10 & - , grid % v10 & - , grid % w_2 & - , grid % uh & - , grid % t_phy & - , grid % t2 & - , grid % z & - , grid % ht & - , grid % u_phy & - , grid % v_phy & - , ptot & - , qice & - , qsnow & - , qgrpl & - , grid % rho & - , dz8w & - , rh & - , ims, ime, jms, jme, kms, kme & - , its, ite, jts, jte & - , k_start, k_end ) - ENDIF ! afwa_severe_opt == 1 - ! Calculate precipitation type diagnostics - ! ---------------------------------------- - IF ( config_flags % afwa_ptype_opt == 1 ) THEN - - ! First initialize precip buckets - ! ------------------------------- - IF ( grid % itimestep .eq. 1) THEN - DO i=ims,ime - DO j=jms,jme - grid % afwa_rain(i,j)=0. - grid % afwa_snow(i,j)=0. - grid % afwa_ice(i,j)=0. - grid % afwa_fzra(i,j)=0. - grid % afwa_snowfall(i,j)=0. - ENDDO - ENDDO - ENDIF + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ The2T.f90 + !~ + !~ Description: + !~ This function returns the temperature at any pressure level along a + !~ saturation adiabat by iteratively solving for it from the parcel + !~ thetae. + !~ + !~ Dependencies: + !~ function thetae.f90 + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION The2T ( thetaeK, pres, flag ) result ( tparcel ) + IMPLICIT NONE - ! Time-step precipitation (convective + nonconvective) - ! ------------------------------------------------------ - DO i=ims,ime - DO j=jms,jme - grid%afwa_precip(i,j)=grid%raincv(i,j)+grid%rainncv(i,j) - ENDDO - ENDDO - - ! Diagnose precipitation type - ! --------------------------- - CALL precip_type_diagnostics ( grid % t_phy & - , grid % t2 & - , rh & - , grid % z & - , grid % ht & - , grid % afwa_precip & - , grid % swdown & - , grid % afwa_rain & - , grid % afwa_snow & - , grid % afwa_ice & - , grid % afwa_fzra & - , grid % afwa_snowfall & - , grid % afwa_ptype_ccn_tmp & - , grid % afwa_ptype_tot_melt & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe ) - ENDIF ! afwa_ptype_opt == 1 + !~ Variable Declaration + ! -------------------- + REAL, INTENT ( IN ) :: thetaeK + REAL, INTENT ( IN ) :: pres + LOGICAL, INTENT ( INOUT ) :: flag + REAL :: tparcel - ! The following packages are calculated only on output timesteps - ! -------------------------------------------------------------- - IF ( is_output_timestep ) THEN + REAL :: thetaK + REAL :: tovtheta + REAL :: tcheck + REAL :: svpr, svpr2 + REAL :: smixr, smixr2 + REAL :: thetae_check, thetae_check2 + REAL :: tguess_2, correction + + LOGICAL :: found + INTEGER :: iter + + REAL :: R ! Dry gas constant + REAL :: Cp ! Specific heat for dry air + REAL :: kappa ! Rd / Cp + REAL :: Lv ! Latent heat of vaporization at 0 deg. C + + R = 287.04 + Cp = 1004.67 + Kappa = R/Cp + Lv = 2.500E+6 - ! Calculate equivalent radar reflectivity factor (z_e) using - ! old RIP code (2004) if running radar or VIL packages. - ! ---------------------------------------------------------- - IF ( config_flags % afwa_radar_opt == 1 .or. & - config_flags % afwa_vil_opt == 1 ) THEN - write ( message, * ) 'Calculating Radar' - CALL wrf_debug( 100 , message ) - CALL wrf_dbzcalc ( grid%rho & - , grid%t_phy & - , qrain & - , qsnow & - , qgrpl & - , z_e & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe ) - ENDIF ! afwa_radar_opt == 1 .or. afwa_vil_opt == 1 + !~ Make initial guess for temperature of the parcel + ! ------------------------------------------------ + tovtheta = (pres/100000.0)**(r/cp) + tparcel = thetaeK/exp(lv*.012/(cp*295.))*tovtheta - ! Calculate derived radar variables - ! --------------------------------- - IF ( config_flags % afwa_radar_opt == 1 ) THEN - write ( message, * ) 'Calculating derived radar variables' - CALL wrf_debug( 100 , message ) - CALL radar_diagnostics ( grid % refd & - , grid % refd_com & - , grid % refd_max & - , grid % echotop & - , grid % z & - , z_e & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe ) - ENDIF ! afwa_radar_opt == 1 + iter = 1 + found = .false. + flag = .false. - ! Calculate VIL and reflectivity every history output timestep - ! ------------------------------------------------------------ - IF ( config_flags % afwa_vil_opt == 1 ) THEN - write ( message, * ) 'Calculating VIL' - CALL wrf_debug( 100 , message ) - CALL vert_int_liquid_diagnostics ( grid % vil & - , grid % radarvil & - , grid % t_phy & - , qrain & - , qsnow & - , qgrpl & - , z_e & - , dz8w & - , grid % rho & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe ) - ENDIF ! afwa_vil_opt ==1 + DO + IF ( iter > 105 ) EXIT - ! Calculate icing and freezing level - ! ---------------------------------- - IF ( config_flags % afwa_icing_opt == 1 ) THEN + tguess_2 = tparcel + REAL ( 1 ) - ! Determine icing option from microphysics scheme - ! ----------------------------------------------- - - IF ( config_flags % mp_physics == GSFCGCESCHEME ) THEN - icing_opt=1 - ELSEIF ( config_flags % mp_physics == ETAMPNEW ) THEN - icing_opt=2 - ELSEIF ( config_flags % mp_physics == THOMPSON ) THEN - icing_opt=3 - ELSEIF ( config_flags % mp_physics == WSM5SCHEME .OR. & - config_flags % mp_physics == WSM6SCHEME ) THEN - icing_opt=4 - ELSEIF ( config_flags % mp_physics == MORR_TWO_MOMENT ) THEN - !-->RAS13.2 - !Is this run with prognostic cloud droplets or no? - IF (config_flags % progn > 0) THEN - icing_opt=6 - ELSE - icing_opt=5 - ENDIF - ELSEIF ( config_flags % mp_physics == WDM6SCHEME ) THEN - icing_opt=7 - ELSE - icing_opt=0 ! Not supported - ENDIF - - write ( message, * ) 'Calculating Icing with icing opt ',icing_opt - CALL wrf_debug( 100 , message ) - CALL icing_diagnostics ( icing_opt & - , grid % fzlev & - , grid % icing_lg & - , grid % icing_sm & - , grid % qicing_lg_max & - , grid % qicing_sm_max & - , grid % qicing_lg & - , grid % qicing_sm & - , grid % icingtop & - , grid % icingbot & - , grid % t_phy & - , grid % z & - , dz8w & - , grid % rho & - , qrain & - , qcloud & - , ncloud & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe ) - ENDIF ! afwa_icing_opt + svpr = 6.122 * exp ( (17.67*(tparcel-273.15)) / (tparcel-29.66) ) + smixr = ( 0.622*svpr ) / ( (pres/100.0)-svpr ) + svpr2 = 6.122 * exp ( (17.67*(tguess_2-273.15)) / (tguess_2-29.66) ) + smixr2 = ( 0.622*svpr2 ) / ( (pres/100.0)-svpr2 ) - IF ( config_flags % afwa_vis_opt == 1 ) THEN - - ! Calculate 2 meter relative humidity - ! ----------------------------------- - DO i=ims,ime - DO j=jms,jme - rh2m(i,j)=calc_rh(grid%psfc(i,j), grid%t2(i,j), grid%q2(i,j)) - ENDDO - ENDDO - - ! Calculate 10 meter winds - ! ------------------------ - DO i=ims,ime - DO j=jms,jme - wind10m(i,j)=uv_wind(grid%u10(i,j),grid%v10(i,j)) - ENDDO - ENDDO + ! ------------------------------------------------------------------ ~! + !~ When this function was orinially written, the final parcel ~! + !~ temperature check was based off of the parcel temperature and ~! + !~ not the theta-e it produced. As there are multiple temperature- ~! + !~ mixing ratio combinations that can produce a single theta-e value, ~! + !~ we change the check to be based off of the resultant theta-e ~! + !~ value. This seems to be the most accurate way of backing out ~! + !~ temperature from theta-e. ~! + !~ ~! + !~ Rentschler, April 2010 ~! + ! ------------------------------------------------------------------ ! - write ( message, * ) 'Calculating visibility' - CALL wrf_debug( 100 , message ) - CALL vis_diagnostics ( qcloud(ims:ime,k_start,jms:jme) & - , qrain(ims:ime,k_start,jms:jme) & - , qice(ims:ime,k_start,jms:jme) & - , qsnow(ims:ime,k_start,jms:jme) & - , wind10m & - , rh2m & - , dustc & - , grid % afwa_vis & - , grid % afwa_vis_dust & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe ) - ENDIF + !~ Old way... + !thetaK = thetaeK / EXP (lv * smixr /(cp*tparcel) ) + !tcheck = thetaK * tovtheta - IF ( config_flags % afwa_cloud_opt == 1 ) THEN - CALL cloud_diagnostics (qcloud & - , qice & - , qsnow & - , rh & - , dz8w & - , grid % rho & - , grid % z & - , grid % ht & - , grid % afwa_cloud & - , grid % afwa_cloud_ceil & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe ) - ENDIF + !~ New way + thetae_check = Thetae ( tparcel, pres/100., 100., smixr ) + thetae_check2 = Thetae ( tguess_2, pres/100., 100., smixr2 ) - ENDIF ! is_output_timestep + !~ Whew doggies - that there is some accuracy... + !IF ( ABS (tparcel-tcheck) < .05) THEN + IF ( ABS (thetaeK-thetae_check) < .001) THEN + found = .true. + flag = .true. + EXIT + END IF - END SUBROUTINE afwa_diagnostics_driver + !~ Old + !tparcel = tparcel + (tcheck - tparcel)*.3 + !~ New + correction = ( thetaeK-thetae_check ) / ( thetae_check2-thetae_check ) + tparcel = tparcel + correction + iter = iter + 1 + END DO - SUBROUTINE severe_wx_diagnostics ( wspd10max & - , w_up_max & - , w_dn_max & - , up_heli_max & - , tcoli_max & - , midrh_min_old & - , midrh_min & - , afwa_hail & - , cape & - , zlfc & - , plfc & - , llws_max & - , afwa_tornado & - , u10 & - , v10 & - , w_2 & - , uh & - , t_phy & - , t2 & - , z & - , ht & - , u_phy & - , v_phy & - , p & - , qi & - , qs & - , qg & - , rho & - , dz8w & - , rh & - , ims, ime, jms, jme, kms, kme & - , its, ite, jts, jte & - , k_start, k_end ) + !IF ( .not. found ) THEN + ! print*, "Warning! Thetae to temperature calculation did not converge!" + ! print*, "Thetae ", thetaeK, "Pressure ", pres + !END IF - INTEGER, INTENT(IN) :: its, ite, jts, jte, k_start, k_end & - , ims, ime, jms, jme, kms, kme + END FUNCTION The2T - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: p & - , w_2 & - , t_phy & - , u_phy & - , v_phy & - , qi & - , qs & - , qg & - , rho & - , z & - , dz8w & - , rh - REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT(IN ) :: u10 & - , v10 & - , uh & - , t2 & - , ht & - , midrh_min_old & - , up_heli_max + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ VirtualTemperature + !~ + !~ Description: + !~ This function returns virtual temperature given temperature ( K ) + !~ and mixing ratio. + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION VirtualTemperature ( tK, w ) result ( Tv ) + IMPLICIT NONE + !~ Variable declaration + real, intent ( in ) :: tK !~ Temperature + real, intent ( in ) :: w !~ Mixing ratio ( kg kg^-1 ) + real :: Tv !~ Virtual temperature - REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT(INOUT) :: wspd10max & - , w_up_max & - , w_dn_max & - , tcoli_max & - , midrh_min & - , llws_max & - , afwa_hail & - , afwa_tornado + Tv = tK * ( 1.0 + (w/0.622) ) / ( 1.0 + w ) - REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT( OUT) :: cape & - , zlfc & - , plfc + END FUNCTION VirtualTemperature - ! Local - ! ----- - INTEGER :: i,j,k - INTEGER :: kts,kte - REAL :: zagl, zlfc_msl, melt_term, midrh_term, hail, midrh - REAL :: tornado, lfc_term, shr_term, midrh2_term, uh_term - REAL :: u2000, v2000, us, vs - REAL :: wind_vel, p_tot, tcoli - INTEGER :: nz, ostat - LOGICAL :: is_target_level - REAL, DIMENSION( ims:ime, jms:jme ) :: w_up & - , w_dn & - , llws - - ! Calculate midlevel relative humidity minimum - ! -------------------------------------------- - DO i=ims,ime - DO j=jms,jme - is_target_level=.false. - DO k=kms,kme - zagl = z(i,k,j) - ht(i,j) - IF ( ( zagl >= 3500. ) .and. & - ( .NOT. is_target_level ) .and. & - ( k .ne. kms ) ) THEN - is_target_level = .true. - midrh = rh(i,k-1,j) + (3500. - (z(i,k-1,j) - ht(i,j))) & - * ((rh(i,k,j) - rh(i,k-1,j))/(z(i,k,j) - z(i,k-1,j))) - IF ( midrh .lt. midrh_min(i,j) ) THEN - midrh_min(i,j) = midrh - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO - ! Calculate the max 10 m wind speed between output times - ! ------------------------------------------------------ - DO j = jts, jte - DO i = its, ite - !wind_vel = sqrt( u10(i,j)*u10(i,j) + v10(i,j)*v10(i,j) ) - wind_vel = uv_wind ( u10(i,j) , v10(i,j) ) - IF ( wind_vel .GT. wspd10max(i,j) ) THEN - wspd10max(i,j) = wind_vel - ENDIF - ENDDO - ENDDO - - ! Vertical velocity quantities between output times - ! ------------------------------------------------- - w_up=0. - w_dn=0. - DO j = jts, jte - DO k = k_start, k_end - DO i = its, ite - p_tot = p(i,k,j) / 100. - - ! Check vertical velocity field below 400 mb - !IF ( p_tot .GT. 400. .AND. w_2(i,k,j) .GT. w_up_max(i,j) ) THEN - ! w_up_max(i,j) = w_2(i,k,j) - !ENDIF - !IF ( p_tot .GT. 400. .AND. w_2(i,k,j) .LT. w_dn_max(i,j) ) THEN - ! w_dn_max(i,j) = w_2(i,k,j) - !ENDIF - ! Check vertical velocity field below 400 mb - IF ( p_tot .GT. 400. .AND. w_2(i,k,j) .GT. w_up(i,j) ) THEN - w_up(i,j) = w_2(i,k,j) - IF ( w_up(i,j) .GT. w_up_max(i,j) ) THEN - w_up_max(i,j) = w_up(i,j) - ENDIF - ENDIF - IF ( p_tot .GT. 400. .AND. w_2(i,k,j) .LT. w_dn(i,j) ) THEN - w_dn(i,j) = w_2(i,k,j) - IF ( w_dn(i,j) .GT. w_dn_max(i,j) ) THEN - w_dn_max(i,j) = w_dn(i,j) - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO - - ! Hail diameter in millimeters (Weibull distribution) - ! --------------------------------------------------- - DO j = jts, jte - DO i = its, ite - melt_term=max(t2(i,j)-288.15,0.) - midrh_term=max(2*(min(midrh_min(i,j),midrh_min_old(i,j))-70.),0.) - hail=max((w_up(i,j)/1.4)**1.25-melt_term-midrh_term,0.) - IF ( hail .gt. afwa_hail(i,j) ) THEN - afwa_hail(i,j)=hail - ENDIF - ENDDO - ENDDO + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ SaturationMixingRatio + !~ + !~ Description: + !~ This function calculates saturation mixing ratio given the + !~ temperature ( K ) and the ambient pressure ( Pa ). Uses + !~ approximation of saturation vapor pressure. + !~ + !~ References: + !~ Bolton (1980), Monthly Weather Review, pg. 1047, Eq. 10 + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION SaturationMixingRatio ( tK, p ) result ( ws ) - ! Lightning (total column-integrated cloud ice) - ! Note this formula is basically stolen from the VIL calculation. - ! --------------------------------------------------------------- - DO j = jts, jte - DO i = its, ite - tcoli=0. - DO k = k_start, k_end - tcoli = tcoli + & - (qi (i,k,j) + & - qs (i,k,j) + & - qg (i,k,j)) & - *dz8w (i,k,j) * rho(i,k,j) - ENDDO - IF ( tcoli .GT. tcoli_max(i,j) ) THEN - tcoli_max(i,j) = tcoli - ENDIF - ENDDO - ENDDO + IMPLICIT NONE - ! Calculate buoyancy parameters. - ! ------------------------------ - nz = k_end - k_start - DO j = jts, jte - DO i = its, ite - ostat = Buoyancy ( nz & - , t_phy(i,kms:kme ,j) & - , rh(i,kms:kme ,j) & - , p(i,kms:kme ,j) & - , z(i,kms:kme ,j) & - , 1 & - , cape(i,j) & - , zlfc_msl & - , plfc(i,j) & - , 3 ) !Surface - IF ( ostat /= 0 ) then - WRITE (*,*) "something went wrong with buoyancy calc at i=",i," j=",j - ENDIF - - ! Subtract terrain height to convert ZLFC from MSL to AGL - ! ------------------------------------------------------- - zlfc(i,j)=zlfc_msl-ht(i,j) - - ENDDO - ENDDO - - ! Calculate 0-2000 foot (0 - 609.6 meter) shear. - ! ---------------------------------------------- - DO j = jts, jte - DO i = its, ite - is_target_level=.false. - DO k=kms,kme - zagl = z(i,k,j) - ht(i,j) - IF ( ( zagl >= 609.6 ) .and. & - ( .NOT. is_target_level ) .and. & - ( k .ne. kms ) ) THEN - is_target_level = .true. - u2000 = u_phy(i,k-1,j) + (609.6 - (z(i,k-1,j) - ht(i,j))) & - * ((u_phy(i,k,j) - u_phy(i,k-1,j))/(z(i,k,j) - z(i,k-1,j))) - v2000 = v_phy(i,k-1,j) + (609.6 - (z(i,k-1,j) - ht(i,j))) & - * ((v_phy(i,k,j) - v_phy(i,k-1,j))/(z(i,k,j) - z(i,k-1,j))) - us = u2000 - u10(i,j) - vs = v2000 - v10(i,j) - llws(i,j) = uv_wind ( us , vs ) - IF ( llws(i,j) .gt. llws_max(i,j) ) THEN - llws_max(i,j) = llws(i,j) - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO - - ! Maximum tornado wind speed in ms-1. - ! ----------------------------------- - DO j = jts, jte - DO i = its, ite - IF ( zlfc(i,j) .ge. 0. ) THEN - !uh_term = min(max((up_heli_max(i,j) - 25.) / 50., 0.), 1.) - uh_term = min(max((uh(i,j) - 25.) / 50., 0.), 1.) - shr_term = min(max((llws(i,j) - 2.) / 10., 0.), 1.) - lfc_term = min(max((3000. - zlfc(i,j)) / 1500., 0.), 1.) - midrh2_term = min(max((90. - min(midrh_min(i,j),midrh_min_old(i,j))) / 30., 0.), 1.) - tornado = 50. * uh_term * shr_term * lfc_term * midrh2_term - IF (tornado .gt. afwa_tornado(i,j)) THEN - afwa_tornado(i,j) = tornado - ENDIF - ENDIF - ENDDO - ENDDO - - - END SUBROUTINE severe_wx_diagnostics - - - - SUBROUTINE vert_int_liquid_diagnostics ( vil & - , radarvil & - , t_phy & - , qrain & - , qsnow & - , qgrpl & - , z_e & - , dz8w & - , rho & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe ) - - INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe + REAL, INTENT ( IN ) :: tK + REAL, INTENT ( IN ) :: p + REAL :: ws - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN) :: rho & - , qrain & - , qsnow & - , qgrpl & - , t_phy & - , z_e & - , dz8w + REAL :: es - REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT(INOUT) :: vil & - , radarvil + es = 6.122 * exp ( (17.67*(tK-273.15))/ (tK-29.66) ) + ws = ( 0.622*es ) / ( (p/100.0)-es ) - ! Local - ! ----- - INTEGER :: i,j,k,ktime + END FUNCTION SaturationMixingRatio - ! Calculate vertically integrated liquid water (though its mostly not - ! "liquid" now is it?) - ! ------------------------------------------------------------------- - DO i = ips, MIN(ipe,ide-1) - DO j = jps, MIN(jpe,jde-1) - vil (i,j) = 0.0 - DO k = kps, MIN(kpe,kde-1) - vil (i,j) = vil (i,j) + & - (qrain (i,k,j) + & - qsnow (i,k,j) + & - qgrpl (i,k,j)) & - *dz8w (i,k,j) * rho(i,k,j) - ENDDO - ENDDO - ENDDO - ! Diagnose "radar-derived VIL" from equivalent radar reflectivity - ! radarVIL = (integral of LW*dz )/1000.0 (in kg/m^2) - ! LW = 0.00344 * z_e** (4/7) in g/m^3 - ! --------------------------------------------------------------- - DO i = ips, MIN(ipe,ide-1) - DO j = jps, MIN(jpe,jde-1) - radarvil (i,j) = 0.0 - DO k = kps, MIN(kpe,kde-1) - radarvil (i,j) = radarvil (i,j) + & - 0.00344 * z_e(i,k,j)**0.57143 & - *dz8w (i,k,j)/1000.0 - END DO - END DO - END DO - END SUBROUTINE vert_int_liquid_diagnostics + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ tlcl + !~ + !~ Description: + !~ This function calculates the temperature of a parcel of air would have + !~ if lifed dry adiabatically to it's lifting condensation level (lcl). + !~ + !~ References: + !~ Bolton (1980), Monthly Weather Review, pg. 1048, Eq. 22 + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION TLCL ( tk, rh ) + + IMPLICIT NONE + + REAL, INTENT ( IN ) :: tK !~ Temperature ( K ) + REAL, INTENT ( IN ) :: rh !~ Relative Humidity ( % ) + REAL :: tlcl + + REAL :: denom, term1, term2 + term1 = 1.0 / ( tK - 55.0 ) + IF ( rh > REAL (0) ) THEN + term2 = ( LOG (rh/100.0) / 2840.0 ) + ELSE + term2 = ( LOG (0.001/1.0) / 2840.0 ) + END IF + denom = term1 - term2 + tlcl = ( 1.0 / denom ) + REAL ( 55 ) + END FUNCTION TLCL - SUBROUTINE icing_diagnostics ( icing_opt & - , fzlev & - , icing_lg & - , icing_sm & - , qicing_lg_max & - , qicing_sm_max & - , qicing_lg & - , qicing_sm & - , icingtop & - , icingbot & - , t_phy & - , z & - , dz8w & - , rho & - , qrain & - , qcloud & - , ncloud & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe ) - INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe - INTEGER, INTENT(IN) :: icing_opt + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ PWat + !~ + !~ Description: + !~ This function calculates precipitable water by summing up the + !~ water vapor in a column from the first eta layer to model top + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION Pwat ( nz, qv, qc, dz8w, rho ) - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN) :: z & - , qrain & - , qcloud & - , ncloud & - , rho & - , dz8w & - , t_phy + IMPLICIT NONE - REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT( OUT) :: fzlev & - , icing_lg & - , icing_sm & - , qicing_lg_max & - , qicing_sm_max & - , icingtop & - , icingbot + !~ Variable declaration + ! -------------------- + INTEGER, INTENT ( IN ) :: nz !~ Number of vertical levels + REAL, INTENT ( IN ) :: qv ( nz ) !~ Specific humidity in layer (kg/kg) + REAL, INTENT ( IN ) :: qc ( nz ) !~ Cloud water in layer (kg/kg) + REAL, INTENT ( IN ) :: dz8w ( nz ) !~ Dist between vertical levels (m) + REAL, INTENT ( IN ) :: rho ( nz ) !~ Air density (kg/m^3) + REAL :: Pwat !~ Precipitable water (kg/m^2) + INTEGER :: k !~ Vertical index + + !~ Precipitable water (kg/m^2) + ! --------------------------- + Pwat=0 + DO k = 1, nz + Pwat = Pwat + (qv(k) + qc(k)) * dz8w(k) * rho(k) + ENDDO + + END FUNCTION Pwat + - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT( OUT) :: qicing_lg & - , qicing_sm - - ! Local - ! ----- - INTEGER :: i,j,k,ktime,ktop,kbot - REAL :: qcfrac_lg, qcfrac_sm, qc, qr, small, all + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ ~! + !~ Name: ~! + !~ Buoyancy ~! + !~ ~! + !~ Description: ~! + !~ This function computes Convective Available Potential Energy (CAPE) ~! + !~ with inhibition as a result of water loading given the data required ~! + !~ to run up a sounding. ~! + !~ ~! + !~ Additionally, since we are running up a sounding anyways, this ~! + !~ function returns the height of the Level of Free Convection (LFC) and ~! + !~ the pressure at the LFC. That-a-ways, we don't have to run up a ~! + !~ sounding later, saving a relatively computationally expensive ~! + !~ routine. ~! + !~ ~! + !~ Usage: ~! + !~ ostat = Buoyancy ( tK, rh, p, hgt, sfc, CAPE, ZLFC, PLFC, parcel ) ~! + !~ ~! + !~ Where: ~! + !~ ~! + !~ IN ~! + !~ -- ~! + !~ tK = Temperature ( K ) ~! + !~ rh = Relative Humidity ( % ) ~! + !~ p = Pressure ( Pa ) ~! + !~ hgt = Geopotential heights ( m ) ~! + !~ sfc = integer rank within submitted arrays that represents the ~! + !~ surface ~! + !~ ~! + !~ OUT ~! + !~ --- ~! + !~ ostat INTEGER return status. Nonzero is bad. ~! + !~ CAPE ( J/kg ) Convective Available Potential Energy ~! + !~ ZLFC ( gpm ) Height at the LFC ~! + !~ PLFC ( Pa ) Pressure at the LFC ~! + !~ ~! + !~ tK, rh, p, and hgt are all REAL arrays, arranged from lower levels ~! + !~ to higher levels. ~! + !~ ~! + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION Buoyancy ( nz, tk, rh, p, hgt, sfc, cape, cin, zlfc, plfc, lidx, & + parcel ) result (ostat) + + IMPLICIT NONE + + INTEGER, INTENT ( IN ) :: nz !~ Number of vertical levels + INTEGER, INTENT ( IN ) :: sfc !~ Surface level in the profile + REAL, INTENT ( IN ) :: tk ( nz ) !~ Temperature profile ( K ) + REAL, INTENT ( IN ) :: rh ( nz ) !~ Relative Humidity profile ( % ) + REAL, INTENT ( IN ) :: p ( nz ) !~ Pressure profile ( Pa ) + REAL, INTENT ( IN ) :: hgt ( nz ) !~ Height profile ( gpm ) + REAL, INTENT ( OUT ) :: cape !~ CAPE ( J kg^-1 ) + REAL, INTENT ( OUT ) :: cin !~ CIN ( J kg^-1 ) + REAL, INTENT ( OUT ) :: zlfc !~ LFC Height ( gpm ) + REAL, INTENT ( OUT ) :: plfc !~ LFC Pressure ( Pa ) + REAL, INTENT ( OUT ) :: lidx !~ Lifted index + INTEGER :: ostat !~ Function return status + !~ Nonzero is bad. + + INTEGER, INTENT ( IN ) :: parcel !~ Most Unstable = 1 (default) + !~ Mean layer = 2 + !~ Surface based = 3 + + !~ Derived profile variables + ! ------------------------- + REAL :: ws ( nz ) !~ Saturation mixing ratio + REAL :: w ( nz ) !~ Mixing ratio + REAL :: dTvK ( nz ) !~ Parcel / ambient Tv difference + REAL :: buoy ( nz ) !~ Buoyancy + REAL :: tlclK !~ LCL temperature ( K ) + REAL :: plcl !~ LCL pressure ( Pa ) + REAL :: nbuoy !~ Negative buoyancy + REAL :: pbuoy !~ Positive buoyancy + + !~ Source parcel information + ! ------------------------- + REAL :: srctK !~ Source parcel temperature ( K ) + REAL :: srcrh !~ Source parcel rh ( % ) + REAL :: srcws !~ Source parcel sat. mixing ratio + REAL :: srcw !~ Source parcel mixing ratio + REAL :: srcp !~ Source parcel pressure ( Pa ) + REAL :: srctheta !~ Source parcel theta ( K ) + REAL :: srcthetaeK !~ Source parcel theta-e ( K ) + INTEGER :: srclev !~ Level of the source parcel + REAL :: spdiff !~ Pressure difference + + !~ Parcel variables + ! ---------------- + REAL :: ptK !~ Parcel temperature ( K ) + REAL :: ptvK !~ Parcel virtual temperature ( K ) + REAL :: tvK !~ Ambient virtual temperature ( K ) + REAL :: pw !~ Parcel mixing ratio + + !~ Other utility variables + ! ----------------------- + INTEGER :: i, j, k !~ Dummy iterator + INTEGER :: lfclev !~ Level of LFC + INTEGER :: prcl !~ Internal parcel type indicator + INTEGER :: mlev !~ Level for ML calculation + INTEGER :: lyrcnt !~ Number of layers in mean layer + LOGICAL :: flag !~ Dummy flag + LOGICAL :: wflag !~ Saturation flag + REAL :: freeze !~ Water loading multiplier + REAL :: pdiff !~ Pressure difference between levs + REAL :: pm, pu, pd !~ Middle, upper, lower pressures + REAL :: lidxu !~ Lifted index at upper level + REAL :: lidxd !~ Lifted index at lower level + + !~ Thermo / dynamical constants + ! ---------------------------- + REAL :: Rd !~ Dry gas constant + PARAMETER ( Rd = 287.058 ) !~ J deg^-1 kg^-1 + REAL :: Cp !~ Specific heat constant pressure + PARAMETER ( Cp = 1004.67 ) !~ J deg^-1 kg^-1 + REAL :: g !~ Acceleration due to gravity + PARAMETER ( g = 9.80665 ) !~ m s^-2 + REAL :: RUNDEF + PARAMETER ( RUNDEF = -9.999E30 ) + + !~ Initialize variables + ! -------------------- + ostat = 0 + CAPE = REAL ( 0 ) + CIN = REAL ( 0 ) + ZLFC = RUNDEF + PLFC = RUNDEF + + !~ Look for submitted parcel definition + !~ 1 = Most unstable + !~ 2 = Mean layer + !~ 3 = Surface based + ! ------------------------------------- + IF ( parcel > 3 .or. parcel < 1 ) THEN + prcl = 1 + ELSE + prcl = parcel + END IF + + !~ Initalize our parcel to be (sort of) surface based. Because of + !~ issues we've been observing in the WRF model, specifically with + !~ excessive surface moisture values at the surface, using a true + !~ surface based parcel is resulting a more unstable environment + !~ than is actually occuring. To address this, our surface parcel + !~ is now going to be defined as the parcel between 25-50 hPa + !~ above the surface. UPDATE - now that this routine is in WRF, + !~ going to trust surface info. GAC 20140415 + ! ---------------------------------------------------------------- + + !~ Compute mixing ratio values for the layer + ! ----------------------------------------- + DO k = sfc, nz + ws ( k ) = SaturationMixingRatio ( tK(k), p(k) ) + w ( k ) = ( rh(k)/100.0 ) * ws ( k ) + END DO + + srclev = sfc + srctK = tK ( sfc ) + srcrh = rh ( sfc ) + srcp = p ( sfc ) + srcws = ws ( sfc ) + srcw = w ( sfc ) + srctheta = Theta ( tK(sfc), p(sfc)/100.0 ) + + !~ Compute the profile mixing ratio. If the parcel is the MU parcel, + !~ define our parcel to be the most unstable parcel within the lowest + !~ 180 mb. + ! ------------------------------------------------------------------- + mlev = sfc + 1 + DO k = sfc + 1, nz + + !~ Identify the last layer within 100 hPa of the surface + ! ----------------------------------------------------- + pdiff = ( p (sfc) - p (k) ) / REAL ( 100 ) + IF ( pdiff <= REAL (100) ) mlev = k + + !~ If we've made it past the lowest 180 hPa, exit the loop + ! ------------------------------------------------------- + IF ( pdiff >= REAL (180) ) EXIT + + IF ( prcl == 1 ) THEN + !IF ( (p(k) > 70000.0) .and. (w(k) > srcw) ) THEN + IF ( (w(k) > srcw) ) THEN + srctheta = Theta ( tK(k), p(k)/100.0 ) + srcw = w ( k ) + srclev = k + srctK = tK ( k ) + srcrh = rh ( k ) + srcp = p ( k ) + END IF + END IF + + END DO + + !~ If we want the mean layer parcel, compute the mean values in the + !~ lowest 100 hPa. + ! ---------------------------------------------------------------- + lyrcnt = mlev - sfc + 1 + IF ( prcl == 2 ) THEN + + srclev = sfc + srctK = SUM ( tK (sfc:mlev) ) / REAL ( lyrcnt ) + srcw = SUM ( w (sfc:mlev) ) / REAL ( lyrcnt ) + srcrh = SUM ( rh (sfc:mlev) ) / REAL ( lyrcnt ) + srcp = SUM ( p (sfc:mlev) ) / REAL ( lyrcnt ) + srctheta = Theta ( srctK, srcp/100. ) + + END IF + + srcthetaeK = Thetae ( srctK, srcp/100.0, srcrh, srcw ) + + !~ Calculate temperature and pressure of the LCL + ! --------------------------------------------- + tlclK = TLCL ( tK(srclev), rh(srclev) ) + plcl = p(srclev) * ( (tlclK/tK(srclev))**(Cp/Rd) ) + + !~ Now lift the parcel + ! ------------------- + + buoy = REAL ( 0 ) + pw = srcw + wflag = .false. + DO k = srclev, nz + IF ( p (k) <= plcl ) THEN + + !~ The first level after we pass the LCL, we're still going to + !~ lift the parcel dry adiabatically, as we haven't added the + !~ the required code to switch between the dry adiabatic and moist + !~ adiabatic cooling. Since the dry version results in a greater + !~ temperature loss, doing that for the first step so we don't over + !~ guesstimate the instability. + ! ---------------------------------------------------------------- + + IF ( wflag ) THEN + flag = .false. + + !~ Above the LCL, our parcel is now undergoing moist adiabatic + !~ cooling. Because of the latent heating being undergone as + !~ the parcel rises above the LFC, must iterative solve for the + !~ parcel temperature using equivalant potential temperature, + !~ which is conserved during both dry adiabatic and + !~ pseudoadiabatic displacements. + ! -------------------------------------------------------------- + ptK = The2T ( srcthetaeK, p(k), flag ) + + !~ Calculate the parcel mixing ratio, which is now changing + !~ as we condense moisture out of the parcel, and is equivalent + !~ to the saturation mixing ratio, since we are, in theory, at + !~ saturation. + ! ------------------------------------------------------------ + pw = SaturationMixingRatio ( ptK, p(k) ) + + !~ Now we can calculate the virtual temperature of the parcel + !~ and the surrounding environment to assess the buoyancy. + ! ---------------------------------------------------------- + ptvK = VirtualTemperature ( ptK, pw ) + tvK = VirtualTemperature ( tK (k), w (k) ) + + !~ Modification to account for water loading + ! ----------------------------------------- + freeze = 0.033 * ( 263.15 - pTvK ) + IF ( freeze > 1.0 ) freeze = 1.0 + IF ( freeze < 0.0 ) freeze = 0.0 + + !~ Approximate how much of the water vapor has condensed out + !~ of the parcel at this level + ! --------------------------------------------------------- + freeze = freeze * 333700.0 * ( srcw - pw ) / 1005.7 + + pTvK = pTvK - pTvK * ( srcw - pw ) + freeze + dTvK ( k ) = ptvK - tvK + buoy ( k ) = g * ( dTvK ( k ) / tvK ) + + ELSE + + !~ Since the theta remains constant whilst undergoing dry + !~ adiabatic processes, can back out the parcel temperature + !~ from potential temperature below the LCL + ! -------------------------------------------------------- + ptK = srctheta / ( 100000.0/p(k) )**(Rd/Cp) + + !~ Grab the parcel virtual temperture, can use the source + !~ mixing ratio since we are undergoing dry adiabatic cooling + ! ---------------------------------------------------------- + ptvK = VirtualTemperature ( ptK, srcw ) + + !~ Virtual temperature of the environment + ! -------------------------------------- + tvK = VirtualTemperature ( tK (k), w (k) ) + + !~ Buoyancy at this level + ! ---------------------- + dTvK ( k ) = ptvK - tvK + buoy ( k ) = g * ( dtvK ( k ) / tvK ) + + wflag = .true. + + END IF + + ELSE + + !~ Since the theta remains constant whilst undergoing dry + !~ adiabatic processes, can back out the parcel temperature + !~ from potential temperature below the LCL + ! -------------------------------------------------------- + ptK = srctheta / ( 100000.0/p(k) )**(Rd/Cp) + + !~ Grab the parcel virtual temperture, can use the source + !~ mixing ratio since we are undergoing dry adiabatic cooling + ! ---------------------------------------------------------- + ptvK = VirtualTemperature ( ptK, srcw ) + + !~ Virtual temperature of the environment + ! -------------------------------------- + tvK = VirtualTemperature ( tK (k), w (k) ) + + !~ Buoyancy at this level + ! --------------------- + dTvK ( k ) = ptvK - tvK + buoy ( k ) = g * ( dtvK ( k ) / tvK ) + + END IF + + !~ Chirp + ! ----- + ! WRITE ( *,'(I15,6F15.3)' )k,p(k)/100.,ptK,pw*1000.,ptvK,tvK,buoy(k) + + END DO + + !~ Add up the buoyancies, find the LFC + ! ----------------------------------- + flag = .false. + lfclev = -1 + nbuoy = REAL ( 0 ) + pbuoy = REAL ( 0 ) + DO k = sfc + 1, nz + IF ( tK (k) < 253.15 ) EXIT + CAPE = CAPE + MAX ( buoy (k), 0.0 ) * ( hgt (k) - hgt (k-1) ) + CIN = CIN + MIN ( buoy (k), 0.0 ) * ( hgt (k) - hgt (k-1) ) + + !~ If we've already passed the LFC + ! ------------------------------- + IF ( flag .and. buoy (k) > REAL (0) ) THEN + pbuoy = pbuoy + buoy (k) + END IF + + !~ We are buoyant now - passed the LFC + ! ----------------------------------- + IF ( .not. flag .and. buoy (k) > REAL (0) .and. p (k) < plcl ) THEN + flag = .true. + pbuoy = pbuoy + buoy (k) + lfclev = k + END IF + + !~ If we think we've passed the LFC, but encounter a negative layer + !~ start adding it up. + ! ---------------------------------------------------------------- + IF ( flag .and. buoy (k) < REAL (0) ) THEN + nbuoy = nbuoy + buoy (k) + + !~ If the accumulated negative buoyancy is greater than the + !~ positive buoyancy, then we are capped off. Got to go higher + !~ to find the LFC. Reset positive and negative buoyancy summations + ! ---------------------------------------------------------------- + IF ( ABS (nbuoy) > pbuoy ) THEN + flag = .false. + nbuoy = REAL ( 0 ) + pbuoy = REAL ( 0 ) + lfclev = -1 + END IF + END IF + + END DO + + !~ Calculate lifted index by interpolating difference between + !~ parcel and ambient Tv to 500mb. + ! ---------------------------------------------------------- + DO k = sfc + 1, nz + + pm = 50000. + pu = p ( k ) + pd = p ( k - 1 ) + + !~ If we're already above 500mb just set lifted index to 0. + !~ -------------------------------------------------------- + IF ( pd .le. pm ) THEN + lidx = 0. + EXIT + + ELSEIF ( pu .le. pm .and. pd .gt. pm) THEN + + !~ Found trapping pressure: up, middle, down. + !~ We are doing first order interpolation. + ! ------------------------------------------ + lidxu = -dTvK ( k ) * ( pu / 100000. ) ** (Rd/Cp) + lidxd = -dTvK ( k-1 ) * ( pd / 100000. ) ** (Rd/Cp) + lidx = ( lidxu * (pm-pd) + lidxd * (pu-pm) ) / (pu-pd) + EXIT + + ENDIF + + END DO + + !~ Assuming the the LFC is at a pressure level for now + ! --------------------------------------------------- + IF ( lfclev > 0 ) THEN + PLFC = p ( lfclev ) + ZLFC = hgt ( lfclev ) + END IF + + IF ( PLFC /= PLFC .OR. PLFC < REAL (0) ) THEN + PLFC = REAL ( -1 ) + ZLFC = REAL ( -1 ) + END IF + + IF ( CAPE /= CAPE ) cape = REAL ( 0 ) + + IF ( CIN /= CIN ) cin = REAL ( 0 ) + + !~ Chirp + ! ----- + ! WRITE ( *,* ) ' CAPE: ', cape, ' CIN: ', cin + ! WRITE ( *,* ) ' LFC: ', ZLFC, ' PLFC: ', PLFC + ! WRITE ( *,* ) '' + ! WRITE ( *,* ) ' Exiting buoyancy.' + ! WRITE ( *,* ) ' ==================================== ' + ! WRITE ( *,* ) '' + + END FUNCTION Buoyancy + + + +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . +! SUBPROGRAM: NGMSLP NMC SEA LEVEL PRESSURE REDUCTION +! PRGRMMR: TREADON ORG: W/NP2 DATE: 93-02-02 +! +! ABSTRACT: +! +! THIS ROUTINE COMPUTES SEA LEVEL PRESSURE USING THE +! HYDROSTATIC EQUATION WITH THE SHUELL CORRECTION. THE +! FOLLOWING IS BASED ON DOCUMENTATION IN SUBROUTINE +! OUTHYDRO OF THE NGM: +! +! THE FUNDAMENTAL HYDROSTATIC EQUATION IS +! D(HEIGHT) +! --------- = TAU = VIRTUAL TEMPERATURE * (RGAS/GRAVITY) +! D (Z) +! WHERE +! Z = MINUS LOG OF PRESSURE (-LN(P)). +! +! SEA-LEVEL PRESSURE IS COMPUTED FROM THE FORMULA +! PRESS(MSL) = PRESS(GROUND) * EXP( F) +! WHERE +! F = HEIGHT OF GROUND / MEAN TAU +! MEAN TAU = ( TAU(GRND) + TAU(SL) ) / 2 +! +! IN THE NGM TAU(GRND) AND TAU(SL) ARE FIRST SET USING A +! 6.5DEG/KM LAPSE RATE FROM LOWEST MDL LEVEL. THIS IS MODIFIED +! BY A CORRECTION BASED ON THE CRITICAL TAU OF THE SHUELL +! CORRECTION: +! TAUCR=(RGASD/GRAVITY) * 290.66 +! +! 1) WHERE ONLY TAU(SL) EXCEEDS TAUCR, CHANGE TAU(SL) TO TAUCR. +! +! 2) WHERE BOTH TAU(SL) AND TAU(GRND) EXCEED TAUCR, +! CHANGE TAU(SL) TO TAUCR-CONST*(TAU(GRND)-TAUCR )**2 +! WHERE CONST = .005 (GRAVITY/RGASD) +! +! THE AVERAGE OF TAU(SL) AND TAU(GRND) IS THEN USED TOGETHER +! WITH THE GROUND HEIGHT AND PRESSURE TO DERIVE THE PRESSURE +! AT SEA LEVEL. +! +! HEIGHT OF THE 1000MB SURFACE IS COMPUTED FROM THE MSL PRESSURE +! FIELD USING THE FORMULA: +! +! P(MSL) - P(1000MB) = MEAN DENSITY * GRAVITY * HGT(1000MBS) +! +! WHERE P(MSL) IS THE SEA LEVEL PRESSURE FIELD WE HAVE JUST +! COMPUTED. +! +! +! MEB 6/13/02: THIS CODE HAS BEEN SIMPLIFIED CONSIDERABLY FROM +! THE ONE USED IN ETAPOST. HORIZONTAL SMOOTHING HAS BEEN +! REMOVED AND THE FIRST MODEL LEVEL IS USED RATHER +! THAN THE MEAN OF THE VIRTUAL TEMPERATURES IN +! THE LOWEST 30MB ABOVE GROUND TO COMPUTE TAU(GRND). +! +! . +! +! PROGRAM HISTORY LOG: +! 93-02-02 RUSS TREADON +! 98-06-08 T BLACK - CONVERSION FROM 1-D TO 2-D +! 00-01-04 JIM TUCCILLO - MPI VERSION +! 01-10-25 H CHUANG - MODIFIED TO PROCESS HYBRID MODEL OUTPUT +! 01-11-02 H CHUANG - MODIFIED LINE 234 FOR COMPUTATION OF +! SIGMA/HYBRID SLP +! 01-12-18 H CHUANG - INCLUDED SMOOTHING ALONG BOUNDARIES TO BE +! CONSISTENT WITH MESINGER SLP +! 02-06-13 MIKE BALDWIN - WRF VERSION +! 06-12-18 H CHUANG - BUG FIX TO CORRECT TAU AT SFC +! 14-04-17 G CREIGHTON - MODIFIED TO INSERT INTO AFWA DIAGNOSTICS IN WRF +! +!$$$ + + FUNCTION MSLP ( zsfc, psfc, zlev1, qlev1, tlev1 ) + + implicit none + + +! DECLARE VARIABLES + + REAL, INTENT ( IN ) :: zsfc !~ Surface height ( m ) + REAL, INTENT ( IN ) :: psfc !~ Surface height ( m ) + REAL, INTENT ( IN ) :: zlev1 !~ Level 1 height ( m ) + REAL, INTENT ( IN ) :: qlev1 !~ Level 1 mixing ratio ( kg/kg ) + REAL, INTENT ( IN ) :: tlev1 !~ Level 1 temperature ( K ) + real,PARAMETER :: G=9.81 + real,PARAMETER :: GI=1./G + real,PARAMETER :: RD=287.0 + real,PARAMETER :: ZSL=0.0 + real,PARAMETER :: TAUCR=RD*GI*290.66,CONST=0.005*G/RD + real,PARAMETER :: GORD=G/RD,DP=60.E2 + real,PARAMETER :: GAMMA=6.5E-3 + + real MSLP,TVRT,TVRSFC,TAUSFC,TVRSL,TAUSL,TAUAVG +! +!********************************************************************** +! START NGMSLP HERE. +! + MSLP = PSFC +! +! COMPUTE LAYER TAU (VIRTUAL TEMP*RD/G). + TVRT = TLEV1*(1.0+0.608*QLEV1) + !TAU = TVRT*RD*GI +! +! COMPUTE TAU AT THE GROUND (Z=ZSFC) AND SEA LEVEL (Z=0) +! ASSUMING A CONSTANT LAPSE RATE OF GAMMA=6.5DEG/KM. + TVRSFC = TVRT + (ZLEV1 - ZSFC)*GAMMA + TAUSFC = TVRSFC*RD*GI + TVRSL = TVRT + (ZLEV1 - ZSL)*GAMMA + TAUSL = TVRSL*RD*GI +! +! IF NEED BE APPLY SHEULL CORRECTION. + IF ((TAUSL.GT.TAUCR).AND.(TAUSFC.LE.TAUCR)) THEN + TAUSL=TAUCR + ELSEIF ((TAUSL.GT.TAUCR).AND.(TAUSFC.GT.TAUCR)) THEN + TAUSL = TAUCR-CONST*(TAUSFC-TAUCR)**2 + ENDIF +! +! COMPUTE MEAN TAU. + TAUAVG = 0.5*(TAUSL+TAUSFC) +! +! COMPUTE SEA LEVEL PRESSURE. + MSLP = PSFC*EXP(ZSFC/TAUAVG) + + END FUNCTION MSLP + + + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ ~! + !~ Name: ~! + !~ calc_fits ~! + !~ ~! + !~ Description: ~! + !~ This function computes Fighter Index Thermal Stress values given ~! + !~ dry bulb temperature, relative humidity, and pressure. ~! + !~ ~! + !~ Usage: ~! + !~ fitsval = calc_fits ( p, tK, rh ) ~! + !~ ~! + !~ Where: ~! + !~ p = Pressure ( Pa ) ~! + !~ tK = Temperature ( K ) ~! + !~ rh = Relative Humidity ( % ) ~! + !~ ~! + !~ Reference: ~! + !~ Stribley, R.F., S. Nunneley, 1978: Fighter Index of Thermal Stress: ~! + !~ Development of interim guidance for hot-weather USAF operations. ~! + !~ SAM-TR-78-6. Eqn. 9 ~! + !~ ~! + !~ Formula: ~! + !~ FITS = 0.8281*Twb + 0.3549*Tdb + 5.08 (degrees Celsius) ~! + !~ ~! + !~ Where: ~! + !~ Twb = Wet Bulb Temperature ~! + !~ Tdb = Dry Bulb Temperature ~! + !~ ~! + !~ Written: ~! + !~ Scott Rentschler, Software Engineering Services ~! + !~ Fine Scale Models Team ~! + !~ Air Force Weather Agency, 16WS/WXN ~! + !~ DSN: 271-3331 Comm: (402) 294-3331 ~! + !~ scott.rentschler@offutt.af.mil ~! + !~ ~! + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION calc_fits ( p, tK, rh ) RESULT ( fits ) + + implicit none + + !~ Variable declaration + ! -------------------- + real, intent ( in ) :: p !~ Pressure ( Pa ) + real, intent ( in ) :: tK !~ Temperature ( K ) + real, intent ( in ) :: rh !~ Rel Humidity ( % ) + real :: fits !~ FITS index value + + !~ Utility variables + ! -------------------------- + real :: twb !~ Wet bulb temperature ( C ) + real :: wbt + + ! ---------------------------------------------------------------------- ! + ! ---------------------------------------------------------------------- ! + + !~ Initialize variables + ! -------------------- + fits = REAL ( 0 ) + + !~ Get the wet bulb temperature in degrees Celsius + ! ----------------------------------------------- + twb = WetBulbTemp ( p, tK, rh ) - 273.15 + + !~ Compute the FITS index + ! ---------------------- + fits = 0.8281*twb + 0.3549*( tK - 273.15 ) + 5.08 + + !~ Convert the index to Kelvin + ! --------------------------- + fits = fits + 273.15 + + END FUNCTION calc_fits + + + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ calc_wc + !~ + !~ Description: + !~ This function calculates wind chill given temperature ( K ) and + !~ wind speed ( m/s ) + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION calc_wc ( tK, wspd ) RESULT ( wc ) + + implicit none + + !~ Variable Declarations + ! --------------------- + real, intent ( in ) :: tK + real, intent ( in ) :: wspd + + real :: tF, wc, wspd_mph + + wspd_mph = wspd * 2.23693629 ! convert to mph + tF = (( tK - 273.15 ) * ( REAL (9) / REAL (5) ) ) + REAL ( 32 ) + + wc = 35.74 & + + ( 0.6215 * tF ) & + - ( 35.75 * ( wspd_mph**0.16 ) ) & + + ( 0.4275 * tF * ( wspd_mph**0.16 ) ) + + wc = (( wc - REAL (32) ) * ( REAL (5) / REAL (9) ) ) + 273.15 + + END FUNCTION calc_wc + + + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ calc_hi + !~ + !~ Description: + !~ This subroutine calculates the heat index. Requires temperature ( K ) + !~ and relative humidity ( % ). + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION calc_hi ( Tk, RH ) result ( HI ) + + implicit none + + !~ Variable declarations + ! --------------------- + real, intent ( in ) :: Tk + real, intent ( in ) :: RH + + real :: tF, tF2, rh2, HI + + !~ If temperature > 70F then calculate heat index, else set it equal + !~ to dry temperature + ! ----------------------------------------------------------------- + IF ( Tk > 294.26111 ) THEN + + tF = ( (Tk - 273.15) * (REAL (9)/REAL (5)) ) + REAL ( 32 ) + tF2 = tF ** 2 + rh2 = RH ** 2 + + HI = -42.379 & + + ( 2.04901523 * tF ) & + + ( 10.14333127 * RH ) & + - ( 0.22475541 * tF * RH ) & + - ( 6.83783E-03 * tF2 ) & + - ( 5.481717E-02 * rh2 ) & + + ( 1.22874E-03 * tF2 * RH ) & + + ( 8.5282E-04 * tF * rh2 ) & + - ( 1.99E-06 * tF2 * rh2 ) + + HI = ((HI - REAL (32)) * (REAL (5)/REAL (9))) + 273.15 + ELSE + HI = Tk + END IF + + END FUNCTION calc_hi + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ ~! + !~ Name: ~! + !~ WetBulbTemp ~! + !~ ~! + !~ Description: ~! + !~ This function approximates the Wet Bulb Temperature (K) provided ~! + !~ dry bulb temperature (K), relative humidity (%), and pressure (Pa). ~! + !~ ~! + !~ Usage: ~! + !~ wbt = WetBulbTemperature ( p, tK, rh ) ~! + !~ ~! + !~ Where: ~! + !~ p = Pressure ( Pa ) ~! + !~ tK = Temperature ( K ) ~! + !~ rh = Relative Humidity ( % ) ~! + !~ ~! + !~ Reference: ~! + !~ American Society of Civil Engineers ~! + !~ Evapotraspiration and Irrigation Water Requirements ~! + !~ Jensen et al (1990) ASCE Manual No. 70, pp 176-177 ~! + !~ ~! + !~ Written: ~! + !~ Scott Rentschler, Software Engineering Services ~! + !~ Fine Scale Models Team ~! + !~ Air Force Weather Agency ~! + !~ DSM: 271-3331 Comm: (402) 294-3331 ~! + !~ scott.rentschler@offutt.af.mil ~! + !~ ~! + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION WetBulbTemp ( p, tK, rh) result( wbt ) + + implicit none + + !~ Variable delclaration + ! --------------------- + real, intent ( in ) :: p !~ Pressure ( Pa ) + real, intent ( in ) :: tK !~ Temperature ( K ) + real, intent ( in ) :: rh !~ Relative Humidity ( % ) + real :: wbt !~ Wet Bulb Temperature ( K ) + + !~ Utility variables + ! ----------------- + real :: tdK !~ Dewpoint temperature ( K ) + real :: tC !~ Temperature ( C ) + real :: tdC !~ Dewpoint temperature ( K ) + real :: svapr !~ Saturation vapor pressure ( Pa ) + real :: vapr !~ Ambient vapor pressure ( Pa ) + real :: gamma !~ Dummy term + real :: delta !~ Dummy term + + ! ---------------------------------------------------------------------- ! + ! ---------------------------------------------------------------------- ! + !~ Initialize variables + ! -------------------- + wbt = REAL ( 0 ) + tC = tK - 273.15 + + !~ Compute saturation vapor pressure ( Pa ) + ! ---------------------------------------- + svapr = calc_es ( tK ) * REAL ( 100 ) + + !~ Compute vapor pressure + ! ---------------------- + vapr = svapr * ( rh / REAL (100) ) + + !~ Grab the dewpoint + ! ----------------- + tdC = calc_Dewpoint ( tC, rh ) + tdK = tdC + 273.15 + + !~ Compute dummy terms + ! ------------------- + gamma = 0.00066 * ( p / REAL (1000) ) + delta = REAL ( 4098 ) * ( vapr / REAL(1000) ) / ( (tC+237.3)**2 ) + + !~ Compute the wet bulb temperature + ! -------------------------------- + wbt = ( ((gamma * tC) + (delta * tdC)) / (gamma + delta) ) + 273.15 + + END FUNCTION WetBulbTemp + + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ calc_Dewpoint + !~ + !~ Description: + !~ This function approximates dewpoint given temperature and rh. + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION calc_Dewpoint ( tC, rh) result( Dewpoint ) + + implicit none + + !~ Variable Declaration + ! -------------------- + real, intent ( in ) :: tC + real, intent ( in ) :: rh + real :: Dewpoint + + real :: term, es, e1, e, logs, expon + + expon = ( 7.5*tC ) / ( 237.7+tC ) + es = 6.112 * ( 10**expon ) ! Saturated vapor pressure + e = es * ( rh/100.0 ) ! Vapor pressure + logs = LOG10 ( e/6.112 ) + Dewpoint = ( 237.7*logs ) / ( 7.5-logs ) + + END FUNCTION calc_Dewpoint + + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ + !~ Name: + !~ calc_es + !~ + !~ Description: + !~ This function returns the saturation vapor pressure over water ( hPa ) + !~ given temperature ( K ). + !~ + !~ References: + !~ The algorithm is due to Nordquist, W.S., 1973: "Numerical approximations + !~ of selected meteorological parameters for cloud physics problems," + !~ ecom-5475, Atmospheric Sciences Laboratory, U.S. Army Electronics + !~ Command, White Sands Missile Range, New Mexico, 88002 + !~ + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION calc_es ( tK ) result ( es ) + + implicit none + + !~ Variable Declaration + ! -------------------- + real, intent ( in ) :: tK + real :: es + + real :: p1, p2, c1 + + p1 = 11.344 - 0.0303998 * tK + p2 = 3.49149 - 1302.8844 / tK + c1 = 23.832241 - 5.02808 * ALOG10 ( tK ) + es = 10.**(c1-1.3816E-7*10.**p1+8.1328E-3*10.**p2-2949.076/tK) + + END FUNCTION calc_es + + + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ ~! + !~ Name: ~! + !~ CATTurbulence ~! + !~ ~! + !~ Description: ~! + !~ This function calculates the turbulence index ( TI ) for one layer ~! + !~ in the atmosphere given the horizontal wind components and the geo- ~! + !~ potential height of two pressure levels. The index is computed for ~! + !~ the layer between the levels using the deformation and convergence ~! + !~ of the wind field at the top and bottom of the layer and the vertical ~! + !~ wind shear is calculated within the layer. The equation used for ~! + !~ calculating TI is given by: ~! + !~ ~! + !~ ~! + !~ TI = VWS * ( DEF + CONV ) ~! + !~ ~! + !~ Where: ~! + !~ VWS = Vertical wind shear ~! + !~ DEF = Deformation ~! + !~ CONV = Convergence ~! + !~ ~! + !~ Notes: ~! + !~ ~! + !~ References: ~! + !~ Ellrod, G.P. and D.J. Knapp, An objective clear-air turbulence ~! + !~ forecasting technique: verification and operational use, Weather ~! + !~ and Forecasting, 7, March 1992, pp. 150-165. ~! + !~ ~! + !~ Written: ~! + !~ Scott Rentschler, Software Engineering Services ~! + !~ Fine Scale Models Team ~! + !~ Air Force Weather Agency, 16WS/WXN ~! + !~ DSN: 271-3331 Comm: (402) 294-3331 ~! + !~ scott.rentschler@offutt.af.mil ~! + !~ ~! + !~ History: ~! + !~ 1 February 2008 ................... Scott Rentschler, (SES), 2WG/WEA ~! + !~ INITIAL VERSION ~! + !~ ~! + !~ 8 July 2009 ....................... Scott Rentschler, (SES), 2WG/WEA ~! + !~ Adapted for new driver. ~! + !~ ~! + !~ 1 November 2012 ......................... Scott Rentschler, 16WS/WXN ~! + !~ Modified to accept layer argument, which adds the flexibility to make ~! + !~ the computation for whichever flight level is desired. Cleaned up ~! + !~ some of the code and added a couple comments. ~! + !~ ~! + !~ 28 August 2013 .................... Braedi Wickard, SEMS/NG/16WS/WXN ~! + !~ Adapted for use within the Unified Post Processor. UPP can not handle ~! + !~ the layer argument for flight levels, so reverted to hardcoded levels ~! + !~ ~! + !~ 25 April 2014 ............................. Glenn Creighton, 16WS/WXN ~! + !~ Adapted for use within WRF. WRF already computes many of these terms. ~! + !~ Stripped everything down to its bare bones to remove need to compute ~! + !~ horizontal terms, now using deformation variables already within WRF. ~! + !~ ~! + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION CATTurbulence ( ugrdbot, ugrdtop, vgrdbot, vgrdtop & + ,defor11bot, defor11top, defor12bot, defor12top & + ,defor22bot, defor22top, zbot, ztop ) result ( ti ) + + IMPLICIT NONE + + !~ Variable declarations + ! --------------------- + REAL, INTENT ( IN ) :: ugrdbot !~ U-wind bottom of layer + REAL, INTENT ( IN ) :: ugrdtop !~ U-wind top of layer + REAL, INTENT ( IN ) :: vgrdbot !~ V-wind bottom of layer + REAL, INTENT ( IN ) :: vgrdtop !~ V-wind top of layer + REAL, INTENT ( IN ) :: defor11bot !~ 2*du/dx at bottom of layer + REAL, INTENT ( IN ) :: defor11top !~ 2*du/dx at top of layer + REAL, INTENT ( IN ) :: defor12bot !~ du/dy+dv/dx at bottom of layer + REAL, INTENT ( IN ) :: defor12top !~ du/dy+dv/dx at top of layer + REAL, INTENT ( IN ) :: defor22bot !~ 2*dv/dy at bottom of layer + REAL, INTENT ( IN ) :: defor22top !~ 2*dv/dy at top of layer + REAL, INTENT ( IN ) :: zbot !~ Height grid bottom + REAL, INTENT ( IN ) :: ztop !~ Height grid top + REAL :: ti !~ Turbulence index + + !~ Function utility variables + ! -------------------------- + REAL :: dudx, dudx1, dudx2 !~ Wind differentials + REAL :: dvdy, dvdy1, dvdy2 + REAL :: dudz, dvdz + + REAL :: depth, vws, conv !~ Depth, vertical wind shear, convergence + REAL :: def, shear, stretch !~ Deformation, shear, stretching terms + + !~ Initialize variables. + ! ---------------------- + ti = REAL ( 0 ) + + !~ Compute vertical wind shear + ! --------------------------- + depth = ABS ( ztop - zbot ) + dudz = ( ugrdbot - ugrdtop ) / depth + dvdz = ( vgrdbot - vgrdtop ) / depth + vws = SQRT ( dudz**2 + dvdz**2 ) + + dudx1 = defor11top / 2. + dudx2 = defor11bot / 2. + dudx = ( dudx1 + dudx2 ) / REAL ( 2 ) + + dvdy1 = defor22top / 2. + dvdy2 = defor22bot / 2. + dvdy = ( dvdy1 + dvdy2 ) / REAL ( 2 ) + + !~ Compute the deformation + ! ----------------------- + stretch = dudx - dvdy + shear = ( defor12top + defor12bot ) / REAL ( 2 ) + def = SQRT ( stretch**2 + shear**2 ) + + !~ Compute the convergence + ! ----------------------- + conv = - ( dudx + dvdy ) + + !~ Compute the turbulence index + ! ---------------------------- + ti = vws * ( def + conv ) * 1.0E+07 + + IF ( ti /= ti ) ti = REAL ( 0 ) + IF ( ti < 0 ) ti = REAL ( 0 ) + + END FUNCTION CATTurbulence + + + + FUNCTION lin_interp ( x, f, y ) result ( g ) + + ! Purpose: + ! interpolates f(x) to point y + ! assuming f(x) = f(x0) + a * (x - x0) + ! where a = ( f(x1) - f(x0) ) / (x1 - x0) + ! x0 <= x <= x1 + ! assumes x is monotonically increasing + + ! Author: D. Fillmore :: J. Done changed from r8 to r4 + ! Pilfered for AFWA diagnostics - G Creighton + + implicit none + + real, intent(in), dimension(:) :: x ! grid points + real, intent(in), dimension(:) :: f ! grid function values + real, intent(in) :: y ! interpolation point + real :: g ! interpolated function value + + integer :: k ! interpolation point index + integer :: n ! length of x + real :: a + + n = size(x) + + ! find k such that x(k) < y =< x(k+1) + ! set k = 1 if y <= x(1) and k = n-1 if y > x(n) + + if (y <= x(1)) then + k = 1 + else if (y >= x(n)) then + k = n - 1 + else + k = 1 + do while (y > x(k+1) .and. k < n) + k = k + 1 + end do + end if + ! interpolate + a = ( f(k+1) - f(k) ) / ( x(k+1) - x(k) ) + g = f(k) + a * (y - x(k)) + + END FUNCTION lin_interp + + + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ ~! + !~ Name: ~! + !~ LLT_Windspeed ~! + !~ ~! + !~ Description: ~! + !~ This function computes the dynamic term for the low-level turbulence ~! + !~ algorithm. ~! + !~ ~! + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION LLT_Windspeed ( nlayer, u, v ) RESULT ( dynamic ) + IMPLICIT NONE + + !~ Variable Declaration + ! -------------------- + INTEGER, INTENT ( IN ) :: nlayer + REAL, INTENT ( IN ) :: u ( nlayer ) + REAL, INTENT ( IN ) :: v ( nlayer ) + REAL :: dynamic + + !~ Internal function variables + ! --------------------------- + INTEGER :: i + REAL :: this_windspeed ( nlayer ) + REAL :: PI + PARAMETER ( PI = 3.14159265359 ) + + ! -------------------------------------------------------------------- ! + ! -------------------------------------------------------------------- ! + !~ Initialize variables + ! -------------------- + dynamic = REAL ( 0 ) + + !~ Compute the windspeed + ! --------------------- + DO i = 1, nlayer + this_windspeed ( i ) = SQRT ( u(i)**2 + v(i)**2 ) + END DO + + !~ Compute the dynamic term + ! ------------------------- + dynamic = ( this_windspeed(1)+this_windspeed(nlayer) ) / REAL (20) + IF ( dynamic > REAL (2) ) dynamic = REAL ( 2 ) + dynamic = ( dynamic + REAL (3) ) / REAL ( 2 ) + dynamic = SIN ( dynamic*PI ) + dynamic = ( dynamic + REAL (1) ) / REAL ( 2 ) + + + END FUNCTION LLT_Windspeed + + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ ~! + !~ Name: ~! + !~ LLT_Thermodynamic ~! + !~ ~! + !~ Description: ~! + !~ This function computes the thermodynamic term for the low-level ~! + !~ turbulence algorithm. ~! + !~ ~! + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION LLT_Thermodynamic ( nlayer, tK, hgt ) RESULT ( thermodynamic ) + IMPLICIT NONE + + !~ Variable Declaration + ! -------------------- + INTEGER, INTENT ( IN ) :: nlayer + REAL, INTENT ( IN ) :: tK ( nlayer ) !~ Temperature (K) + REAL, INTENT ( IN ) :: hgt ( nlayer ) !~ Heights ( m ) + REAL :: thermodynamic + + !~ Internal function variables + ! --------------------------- + INTEGER :: i + REAL :: lapse + REAL :: PI + PARAMETER ( PI = 3.14159265359 ) + + ! -------------------------------------------------------------------- ! + ! -------------------------------------------------------------------- ! + + !~ Initialize variables + ! -------------------- + thermodynamic = REAL ( 0 ) + + !~ Compute the lapse rate over the layer. The sign gets goofy here, + !~ but works as coded below. + ! ----------------------------------------------------------------- + lapse = ( tk(1) - tk(nlayer) ) * REAL ( 1000 ) + lapse = lapse / ( hgt(nlayer) - hgt(1) ) + + !~ Compute the thermodynamic component + ! ----------------------------------- + thermodynamic = lapse / REAL ( 10 ) + thermodynamic = ( thermodynamic + REAL (3) ) / REAL ( 2 ) + thermodynamic = SIN ( thermodynamic * PI ) + thermodynamic = ( thermodynamic + REAL (1) ) / REAL ( 2 ) + + END FUNCTION LLT_Thermodynamic + + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ ~! + !~ Name: ~! + !~ LLT_MountainWave ~! + !~ ~! + !~ Description: ~! + !~ This function computes the mountain wave term for the low-level ~! + !~ turbulence algorithm. ~! + !~ ~! + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION LLT_MountainWave ( nlayer, tdx, tdy, u, v, tK, hgt) & + RESULT ( MountainWave ) + IMPLICIT NONE + + !~ Variable Declaration + ! -------------------- + INTEGER, INTENT ( IN ) :: nlayer + REAL, INTENT ( IN ) :: tdx !~ Terrain dx + REAL, INTENT ( IN ) :: tdy !~ Terrain dy + REAL, INTENT ( IN ) :: u ( nlayer ) !~ U components f + REAL, INTENT ( IN ) :: v ( nlayer ) !~ V components + REAL, INTENT ( IN ) :: tK ( nlayer ) !~ Temperatures (K) + REAL, INTENT ( IN ) :: hgt ( nlayer ) !~ Heights ( m ) + REAL :: MountainWave !~ Mountain wave term + + !~ Internal function variables + ! --------------------------- + REAL :: u_term + REAL :: v_term + REAL :: uv_term + REAL :: lapse + REAL :: total_mw, this_total_mw + REAL :: this_uv_term + REAL :: min_uv_term, cross_terrain, max_total_mw + INTEGER :: i, j, k + + REAL :: PI + PARAMETER ( PI = 3.14159265359 ) + + ! -------------------------------------------------------------------- ! + ! -------------------------------------------------------------------- ! + + !~ Initialize variables + ! -------------------- + MountainWave = REAL ( 0 ) + + !~ Loop through the layer + ! ---------------------- + DO i = 2, nlayer + + !~ Wind terrain term + ! ----------------- + u_term = ( (u(i-1) + u(i) ) / REAL(2) ) * tdx + v_term = ( (v(i-1) + v(i) ) / REAL(2) ) * tdy + this_uv_term = ( u_term + v_term ) * REAL ( -1 ) + !IF ( uv_term < REAL (0) ) uv_term = REAL ( 0 ) + IF ( min_uv_term < REAL (0) ) min_uv_term = REAL ( 0 ) + IF ( i == 2 ) THEN + !uv_term = this_uv_term + min_uv_term = this_uv_term + ELSE + !IF ( this_uv_term < uv_term ) uv_term = this_uv_term + IF ( this_uv_term < min_uv_term ) min_uv_term = this_uv_term + END IF + + !~ Lapse rate + ! ---------- + lapse = ( tK (i-1) - tK (i) ) * REAL ( 1000 ) + lapse = lapse / ABS ( hgt(i)-hgt(i-1) ) + IF ( lapse > REAL (0) ) lapse = REAL ( 0 ) + lapse = lapse * REAL ( -1 ) + + this_total_mw = this_uv_term * lapse * REAL ( 40000 ) + IF ( i == 2 ) THEN + total_mw = this_total_mw + ELSE + IF ( this_total_mw > total_mw ) total_mw = this_total_mw + END IF + + END DO + + !min_uv_term = uv_term + cross_terrain = min_uv_term * REAL ( 500 ) + + IF ( min_uv_term < 0.03 ) THEN + cross_terrain = REAL ( 0 ) + END IF + + IF ( cross_terrain > REAL (50) ) cross_terrain = REAL ( 50 ) + + !~ Multiply the lapse (inversion) array and the mountain wave array + ! ---------------------------------------------------------------- + IF ( total_mw > REAL (50) ) total_mw = REAL ( 50 ) + + !~ Add the cross terrain flow and inversion term + ! --------------------------------------------- + MountainWave = ( total_mw*(cross_terrain/50.) ) + cross_terrain + MountainWave = MountainWave / REAL ( 100 ) + + END FUNCTION LLT_MountainWave + + + + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + !~ ~! + !~ Name: ~! + !~ LLT_TrappedWave ~! + !~ ~! + !~ Description: ~! + !~ This function computes the trapped wave term for the low-level ~! + !~ turbulence algorithm. ~! + !~ ~! + !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! + FUNCTION LLT_TrappedWave ( nlayer, u, v, p ) RESULT ( trapped ) + IMPLICIT NONE + + !~ Variable Declaration + ! -------------------- + INTEGER, INTENT ( IN ) :: nlayer + REAL, INTENT ( IN ) :: u ( nlayer ) + REAL, INTENT ( IN ) :: v ( nlayer ) + REAL, INTENT ( IN ) :: p ( nlayer ) + REAL :: trapped + + !~ Internal function variables + ! --------------------------- + INTEGER :: i + REAL :: du, dv + REAL :: scale_fact, this_p + REAL :: dudv, this_dudv + REAL :: PI + PARAMETER ( PI = 3.14159265359 ) + + !~ Scale parameters + ! ---------------- + REAL, PARAMETER :: scale_950 = 0.050000 !~ 1/20 + REAL, PARAMETER :: scale_925 = 0.040000 !~ 1/25 + REAL, PARAMETER :: scale_900 = 0.025000 !~ 1/40 + REAL, PARAMETER :: scale_850 = 0.010000 !~ 1/100 + REAL, PARAMETER :: scale_800 = 0.005000 !~ 1/200 + REAL, PARAMETER :: scale_750 = 0.002941 !~ 1/340 + REAL, PARAMETER :: scale_700 = 0.001923 !~ 1/520 + REAL, PARAMETER :: scale_650 = 0.001351 !~ 1/740 + REAL, PARAMETER :: scale_600 = 0.001000 !~ 1/1000 + REAL, PARAMETER :: scale_550 = 0.000800 !~ 1/1250 + + ! -------------------------------------------------------------------- ! + ! -------------------------------------------------------------------- ! + + !~ Initialize variables + ! -------------------- + trapped = REAL ( 0 ) + + !~ Compute the trapped wave term + ! ------------------ + dudv = REAL ( 0 ) + DO i = 2, nlayer + + !~ Compute dudv first + ! ------------------ + du = u ( i-1 ) - u ( i ) + dv = v ( i-1 ) - v ( i ) + + !~ Scale based on pressure level + ! ----------------------------- + this_p = p ( i ) / REAL ( 100 ) + IF ( this_p > REAL (950) ) THEN + scale_fact = scale_950 + ELSE IF ( this_p <= REAL (950) .AND. this_p > REAL (925) ) THEN + scale_fact = scale_925 + ELSE IF ( this_p <= REAL (925) .AND. this_p > REAL (900) ) THEN + scale_fact = scale_900 + ELSE IF ( this_p <= REAL (900) .AND. this_p > REAL (850) ) THEN + scale_fact = scale_850 + ELSE IF ( this_p <= REAL (850) .AND. this_p > REAL (800) ) THEN + scale_fact = scale_800 + ELSE IF ( this_p <= REAL (800) .AND. this_p > REAL (750) ) THEN + scale_fact = scale_750 + ELSE IF ( this_p <= REAL (750) .AND. this_p > REAL (700) ) THEN + scale_fact = scale_700 + ELSE IF ( this_p <= REAL (700) .AND. this_p > REAL (650) ) THEN + scale_fact = scale_650 + ELSE IF ( this_p <= REAL (650) .AND. this_p > REAL (600) ) THEN + scale_fact = scale_600 + ELSE IF ( this_p <= REAL (600) ) THEN + scale_fact = scale_550 + END IF + + this_dudv = ( (du**2)*(dv**2) ) * scale_fact + IF ( this_dudv > dudv ) dudv = this_dudv + + END DO + + trapped = dudv + IF ( trapped > REAL ( 1 ) ) trapped = REAL ( 1 ) + trapped = trapped / REAL ( 4 ) + + END FUNCTION LLT_TrappedWave + +END MODULE diag_functions + + + +MODULE module_diag_afwa + + USE diag_functions + +CONTAINS + + SUBROUTINE afwa_diagnostics_driver ( grid , config_flags & + , moist & + , scalar & + , chem & + , th_phy , pi_phy , p_phy & + , u_phy , v_phy & + , dz8w , p8w , t8w , rho_phy , rho & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe & + , its, ite, jts, jte & + , k_start, k_end ) + + USE module_domain, ONLY : domain , domain_clock_get + USE module_configure, ONLY : grid_config_rec_type, model_config_rec + USE module_state_description + USE module_model_constants + USE module_utility + USE module_streams, ONLY: history_alarm, auxhist2_alarm +#ifdef DM_PARALLEL + USE module_dm, ONLY: wrf_dm_sum_real, wrf_dm_maxval +#endif + USE module_diag_afwa_hail + + IMPLICIT NONE + + TYPE ( domain ), INTENT(INOUT) :: grid + TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags + + INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + INTEGER :: k_start , k_end, its, ite, jts, jte + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme , num_moist), & + INTENT(IN ) :: moist + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme , num_scalar), & + INTENT(IN ) :: scalar + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme , num_chem), & + INTENT(IN ) :: chem + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: th_phy & + , pi_phy & + , p_phy & + , u_phy & + , v_phy & + , dz8w & + , p8w & + , t8w & + , rho_phy & + , rho + + ! Local + ! ----- + CHARACTER*512 :: message + CHARACTER*256 :: timestr + INTEGER :: i,j,k,nz,ostat + INTEGER :: icing_opt + REAL :: bdump + INTEGER :: i_start, i_end, j_start, j_end + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qrain & + , qsnow & + , qgrpl & + , qvapr & + , qcloud & + , qice & + , ncloud & + , ngraup & + , rh & + , rh_cld & + , ptot & + , z_e & + , zagl + + REAL, DIMENSION( ims:ime, jms:jme, 5 ) :: dustc + REAL, DIMENSION( ims:ime, jms:jme ) :: rh2m & + , rh20m & + , tv2m & + , tv20m & + , wind10m & + , wup_mask & + , wind125m & + , llws & + , pwater + + LOGICAL :: do_buoy_calc, do_hailcast_calc + REAL :: zlfc_msl, dum1, dum2, dum3, wind_vel, wind_blend + REAL :: prate_mm_per_hr, factor + REAL :: u1km, v1km, ublend, vblend, u2000, v2000, us, vs + LOGICAL :: is_target_level + + ! Timing + ! ------ + TYPE(WRFU_Time) :: hist_time, aux2_time, CurrTime, StartTime + TYPE(WRFU_TimeInterval) :: dtint, histint, aux2int + LOGICAL :: is_after_history_dump, is_output_timestep, is_first_timestep + + ! Chirp the routine name for debugging purposes + ! --------------------------------------------- + write ( message, * ) 'inside afwa_diagnostics_driver' + CALL wrf_debug( 100 , message ) + + ! Get timing info + ! Want to know if when the last history output was + ! Check history and auxhist2 alarms to check last ring time and how often + ! they are set to ring + ! ----------------------------------------------------------------------- + CALL WRFU_ALARMGET( grid%alarms( HISTORY_ALARM ), prevringtime=hist_time, & + ringinterval=histint) + CALL WRFU_ALARMGET( grid%alarms( AUXHIST2_ALARM ), prevringtime=aux2_time, & + ringinterval=aux2int) + + ! Get domain clock + ! ---------------- + CALL domain_clock_get ( grid, current_time=CurrTime, & + simulationStartTime=StartTime, & + current_timestr=timestr, time_step=dtint ) + + ! Set some booleans for use later + ! Following uses an overloaded .lt. + ! --------------------------------- + is_after_history_dump = ( Currtime .lt. hist_time + dtint ) + + ! Following uses an overloaded .ge. + ! --------------------------------- + is_output_timestep = (Currtime .ge. hist_time + histint - dtint .or. & + Currtime .ge. aux2_time + aux2int - dtint ) + write ( message, * ) 'is output timestep? ', is_output_timestep + CALL wrf_debug( 100 , message ) + + ! Following uses an overloaded .eq. + ! --------------------------------- + is_first_timestep = ( Currtime .eq. StartTime + dtint ) + + ! Here is an optional check for bad data in case the model has gone + ! off the hinges unchecked until now. This happens under certain + ! configurations and can lead to very wrong data writes. This is just + ! a simple check for sane winds and potential temperatures. + ! -------------------------------------------------------------------- + IF ( config_flags%afwa_bad_data_check .GT. 0 ) THEN + IF ( ( is_output_timestep ) .AND. ( .NOT. is_first_timestep ) ) THEN + DO i=its, MIN( ide-1, ite ) + DO k=k_start, k_end + DO j=jts, MIN( jde-1, jte ) + IF ( ( u_phy(i,k,j) .GT. 300. ) .OR. & + ( u_phy(i,k,j) .LT. -300. ) .OR. & + ( v_phy(i,k,j) .GT. 300. ) .OR. & + ( v_phy(i,k,j) .LT. -300. ) .OR. & + ( th_phy(i,k,j) .GT. 9999. ) .OR. & + ( th_phy(i,k,j) .LT. 99. ) ) THEN + write ( message, * ) "AFWA Diagnostics: ERROR - Model winds and/or " // & + "potential temperature appear to be bad. If you do not want this check, " // & + "set afwa_bad_data_check=0. i=",i,", j=",j,", k=",k,", u_phy=",u_phy(i,k,j), & + ", v_phy=", v_phy(i,k,j),", th_phy=",th_phy(i,k,j) + CALL wrf_error_fatal( message ) + ENDIF + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + ! 3-D arrays for moisture variables + ! --------------------------------- + DO i=ims, ime + DO k=kms, kme + DO j=jms, jme + qvapr(i,k,j) = moist(i,k,j,P_QV) + qrain(i,k,j) = moist(i,k,j,P_QR) + qsnow(i,k,j) = moist(i,k,j,P_QS) + qgrpl(i,k,j) = moist(i,k,j,P_QG) + qcloud(i,k,j) = moist(i,k,j,P_QC) + qice(i,k,j) = moist(i,k,j,P_QI) + ncloud(i,k,j) = scalar(i,k,j,P_QNC) + ENDDO + ENDDO + ENDDO + + ! Total pressure + ! -------------- + DO i=ims, ime + DO k=kms, kme + DO j=jms, jme + ptot(i,k,j)=grid%pb(i,k,j)+grid%p(i,k,j) + ENDDO + ENDDO + ENDDO + + ! ZAGL (height above ground) + ! -------------------------- + DO i=ims, ime + DO k=kms, kme + DO j=jms, jme + zagl(i,k,j)=grid%z(i,k,j)-grid%ht(i,j) + ENDDO + ENDDO + ENDDO + + ! Calculate relative humidity + ! --------------------------- + DO i=ims,ime + DO k=kms,kme + DO j=jms,jme + rh(i,k,j)=calc_rh(ptot(i,k,j),grid%t_phy(i,k,j), qvapr(i,k,j)) + rh_cld(i,k,j)=calc_rh(ptot(i,k,j),grid%t_phy(i,k,j), qvapr(i,k,j)+qcloud(i,k,j)+qice(i,k,j)) + ENDDO + ENDDO + ENDDO + + ! Time-step precipitation (convective + nonconvective) + ! -------------------------------------------------------------- + DO i=ims,ime + DO j=jms,jme + grid % afwa_precip(i,j) = grid%raincv(i,j) + grid%rainncv(i,j) + grid % afwa_totprecip(i,j) = grid%rainc(i,j) + grid%rainnc(i,j) + ENDDO + ENDDO + + ! Calculate precipitable water + ! ---------------------------- + nz=kme-kms+1 + DO i=ims,ime + DO j=jms,jme + grid % afwa_pwat ( i, j ) = Pwat( nz, & + qvapr(i,kms:kme,j), & + qcloud(i,kms:kme,j), & + dz8w(i,kms:kme,j), & + rho(i,kms:kme,j) ) + ENDDO + ENDDO + + ! After each history dump, reset max/min value arrays + ! ---------------------------------------------------------------------- + IF ( is_after_history_dump ) THEN + DO j = jms, jme + DO i = ims, ime + grid % wspd10max(i,j) = 0. + grid % afwa_llws(i,j) = 0. + ENDDO + ENDDO + ENDIF + + ! Calculate the max 10 m wind speed between output times + ! ------------------------------------------------------ + ! UPDATE 20150112 - GAC + ! Diagnose from model 10 m winds, and blend with 1 km AGL + ! winds when precipitation rate is > 50 mm/hr to account + ! for increased surface wind gust potential when precip + ! is heavy and when winds aloft are strong. Will use the + ! higher of the surface and the blended winds. Blending + ! is linear weighted between 50-150 mm/hr precip rates. + ! ------------------------------------------------------- + DO j = jms, jme + DO i = ims, ime + wind_vel = uv_wind ( grid % u10(i,j) , grid % v10(i,j) ) + prate_mm_per_hr = ( grid % afwa_precip(i,j) / grid % dt ) * 3600. + + ! Is this an area of heavy precip? Calculate 1km winds to blend down + ! ------------------------------------------------------------------- + IF ( prate_mm_per_hr .GT. 50. ) THEN + is_target_level=.false. + DO k=kms,kme + IF ( ( zagl(i,k,j) >= 1000. ) .and. & + ( .NOT. is_target_level ) .and. & + ( k .ne. kms ) ) THEN + is_target_level = .true. + u1km = u_phy(i,k-1,j) + (1000. - (zagl(i,k-1,j))) & + * ((u_phy(i,k,j) - u_phy(i,k-1,j))/(zagl(i,k,j))) + v1km = v_phy(i,k-1,j) + (1000. - (zagl(i,k-1,j))) & + * ((v_phy(i,k,j) - v_phy(i,k-1,j))/(zagl(i,k,j))) + EXIT ! We've found our level, break the loop + ENDIF + ENDDO + + ! Compute blended wind + ! -------------------- + factor = MAX ( ( ( 150. - prate_mm_per_hr ) / 100. ), 0. ) + ublend = grid % u10(i,j) * factor + u1km * (1. - factor) + vblend = grid % v10(i,j) * factor + v1km * (1. - factor) + wind_blend = uv_wind ( ublend, vblend ) + + ! Set the surface wind to the blended wind if higher + ! -------------------------------------------------- + IF ( wind_blend .GT. wind_vel ) THEN + wind_vel = wind_blend + ENDIF + ENDIF + + IF ( wind_vel .GT. grid % wspd10max(i,j) ) THEN + grid % wspd10max(i,j) = wind_vel + ENDIF + ENDDO + ENDDO + + ! Calculate 0-2000 foot (0 - 609.6 meter) shear. + ! ---------------------------------------------- + DO j = jts, jte + DO i = its, ite + is_target_level=.false. + DO k=kms,kme + IF ( ( zagl(i,k,j) >= 609.6 ) .and. & + ( .NOT. is_target_level ) .and. & + ( k .ne. kms ) ) THEN + is_target_level = .true. + u2000 = u_phy(i,k-1,j) + (609.6 - (zagl(i,k-1,j))) & + * ((u_phy(i,k,j) - u_phy(i,k-1,j))/(zagl(i,k,j))) + v2000 = v_phy(i,k-1,j) + (609.6 - (zagl(i,k-1,j))) & + * ((v_phy(i,k,j) - v_phy(i,k-1,j))/(zagl(i,k,j))) + us = u2000 - grid % u10(i,j) + vs = v2000 - grid % v10(i,j) + llws(i,j) = uv_wind ( us , vs ) + IF ( llws(i,j) .gt. grid % afwa_llws(i,j) ) THEN + grid % afwa_llws(i,j) = llws(i,j) + ENDIF + EXIT ! We've found our level, break the loop + ENDIF + ENDDO + ENDDO + ENDDO + +#if ( WRF_CHEM == 1 ) + ! Surface dust concentration array (ug m-3) + ! ----------------------------------------- + DO i=ims, ime + DO j=jms, jme + dustc(i,j,1)=chem(i,k_start,j,p_dust_1)*rho(i,k_start,j) + dustc(i,j,2)=chem(i,k_start,j,p_dust_2)*rho(i,k_start,j) + dustc(i,j,3)=chem(i,k_start,j,p_dust_3)*rho(i,k_start,j) + dustc(i,j,4)=chem(i,k_start,j,p_dust_4)*rho(i,k_start,j) + dustc(i,j,5)=chem(i,k_start,j,p_dust_5)*rho(i,k_start,j) + ENDDO + ENDDO +#else + dustc(ims:ime,jms:jme,:)=0. +#endif + + ! Calculate severe weather diagnostics. These variables should only be + ! output at highest frequency output. (e.g. auxhist2) + ! --------------------------------------------------------------------- + IF ( config_flags % afwa_severe_opt == 1 ) THEN + + ! After each history dump, reset max/min value arrays + ! Note: This resets up_heli_max which is currently calculated within + ! rk_first_rk_step_part2.F, may want to move to this diagnostics package + ! later + ! ---------------------------------------------------------------------- + IF ( is_after_history_dump ) THEN + DO j = jms, jme + DO i = ims, ime +! grid%wspd10max(i,j) = 0. + grid%w_up_max(i,j) = 0. + grid%w_dn_max(i,j) = 0. + grid%tcoli_max(i,j) = 0. + grid%grpl_flx_max(i,j) = 0. + grid%up_heli_max(i,j) = 0. +! grid%refd_max(i,j) = 0. + grid%afwa_tornado(i,j) = 0. + grid%midrh_min_old(i,j) = grid%midrh_min(i,j) ! Save old midrh_min + grid%midrh_min(i,j) = 999. + grid%afwa_hail(i,j) = 0. + IF ( config_flags % afwa_hailcast_opt == 1 ) THEN + grid%afwa_hail_new1(i,j) = 0. + grid%afwa_hail_new2(i,j) = 0. + grid%afwa_hail_new3(i,j) = 0. + grid%afwa_hail_new4(i,j) = 0. + grid%afwa_hail_new5(i,j) = 0. + ENDIF + ENDDO + ENDDO + ENDIF ! is_after_history_dump + + IF ( ( is_first_timestep ) .OR. ( is_output_timestep ) ) THEN + do_buoy_calc = .true. + ELSE + do_buoy_calc = .false. + ENDIF + + IF ( config_flags % afwa_hailcast_opt == 1 ) THEN + do_hailcast_calc = .true. + ELSE + do_hailcast_calc = .false. + ENDIF + + !-->RAS + ! We need to do some neighboring gridpoint comparisons in this next function; + ! set these values so we don't go off the edges of the domain. Updraft + ! duration on domain edges will always be 0. + ! ---------------------------------------------------------------------- + i_start = its + i_end = ite + j_start = jts + j_end = jte + + IF ( config_flags%open_xs .OR. config_flags%specified .OR. & + config_flags%nested) i_start = MAX( ids+1, its ) + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + config_flags%nested) i_end = MIN( ide-1, ite ) + IF ( config_flags%open_ys .OR. config_flags%specified .OR. & + config_flags%nested) j_start = MAX( jds+1, jts ) + IF ( config_flags%open_ye .OR. config_flags%specified .OR. & + config_flags%nested) j_end = MIN( jde-1, jte ) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + + CALL severe_wx_diagnostics ( grid % wspd10max & + , grid % w_up_max & + , grid % w_dn_max & + , grid % up_heli_max & + , grid % tcoli_max & + , grid % midrh_min_old & + , grid % midrh_min & + , grid % afwa_hail & + , grid % afwa_hail_new1 & + , grid % afwa_hail_new2 & + , grid % afwa_hail_new3 & + , grid % afwa_hail_new4 & + , grid % afwa_hail_new5 & + , grid % afwa_cape & + , grid % afwa_cin & +! , grid % afwa_cape_mu & +! , grid % afwa_cin_mu & + , grid % afwa_zlfc & + , grid % afwa_plfc & + , grid % afwa_lidx & + , llws & + , grid % afwa_tornado & + , grid % grpl_flx_max & + , grid % u10 & + , grid % v10 & + , grid % w_2 & + , grid % uh & + , grid % t_phy & + , grid % t2 & + , grid % z & + , grid % ht & + , grid % wup_mask & + , grid % wdur & + , grid % tornado_mask & + , grid % tornado_dur & + , grid % dt & + , grid % afwa_pwat & + , u_phy & + , v_phy & + , ptot & + , qice & + , qsnow & + , qgrpl & + , ngraup & + , qvapr, qrain, qcloud & + , rho & + , dz8w & + , rh & + , do_buoy_calc & + , do_hailcast_calc & + , ims, ime, jms, jme, kms, kme & + , its, ite, jts, jte & + , k_start, k_end & + , j_start, j_end, i_start, i_end ) + + ENDIF ! afwa_severe_opt == 1 + + ! Calculate precipitation type diagnostics + ! ---------------------------------------- + IF ( config_flags % afwa_ptype_opt == 1 ) THEN + + ! First initialize precip buckets + ! ------------------------------- + IF ( grid % itimestep .eq. 1) THEN + DO i=ims,ime + DO j=jms,jme + grid % afwa_rain(i,j)=0. + grid % afwa_snow(i,j)=0. + grid % afwa_ice(i,j)=0. + grid % afwa_fzra(i,j)=0. + grid % afwa_snowfall(i,j)=0. + ENDDO + ENDDO + ENDIF + + ! Diagnose precipitation type + ! --------------------------- + CALL precip_type_diagnostics ( grid % t_phy & + , grid % t2 & + , rh & + , grid % z & + , grid % ht & + , grid % afwa_precip & + , grid % swdown & + , grid % afwa_rain & + , grid % afwa_snow & + , grid % afwa_ice & + , grid % afwa_fzra & + , grid % afwa_snowfall & + , grid % afwa_ptype_ccn_tmp & + , grid % afwa_ptype_tot_melt & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + ENDIF ! afwa_ptype_opt == 1 + + ! -------------------------------------------------------------- + ! The following packages are calculated only on output timesteps + ! -------------------------------------------------------------- + IF ( is_output_timestep ) THEN + + ! Calculate mean sea level pressure + ! --------------------------------- + DO j = jms, jme + DO i = ims, ime + grid % afwa_mslp ( i, j ) = MSLP ( grid % ht ( i, j ) & + , grid % psfc ( i, j ) & + , grid % z ( i, kms, j ) & + , qvapr ( i, kms, j ) & + , grid % t_phy ( i, kms, j ) ) + ENDDO + ENDDO + + ! Calculate 10 meter winds + ! ------------------------ + DO i=ims,ime + DO j=jms,jme + wind10m(i,j)=uv_wind(grid%u10(i,j),grid%v10(i,j)) + ENDDO + ENDDO + + ! Calculate 2 meter relative humidity/Tv + ! -------------------------------------- + DO i=ims,ime + DO j=jms,jme + rh2m(i,j)=calc_rh(grid%psfc(i,j), grid%t2(i,j), grid%q2(i,j)) + tv2m(i,j)=grid%t2(i,j) * (1 + 0.61 * grid%q2(i,j)) + ENDDO + ENDDO + + ! Calculate the mean and standard deviation of the hail diameter + ! distribution over different embryo sizes + ! ---------------------------------------- + IF ( config_flags % afwa_hailcast_opt == 1 ) THEN + DO j = jms, jme + DO i = ims, ime + !mean + grid%afwa_hail_newmean(i,j)=(grid%afwa_hail_new1(i,j)+& + grid%afwa_hail_new2(i,j) +grid%afwa_hail_new3(i,j)+& + grid%afwa_hail_new4(i,j) +grid%afwa_hail_new5(i,j))/5. + !sample standard deviation + grid%afwa_hail_newstd(i,j) = SQRT( ( & + (grid%afwa_hail_new1(i,j)-grid%afwa_hail_newmean(i,j))**2.+& + (grid%afwa_hail_new2(i,j)-grid%afwa_hail_newmean(i,j))**2.+& + (grid%afwa_hail_new3(i,j)-grid%afwa_hail_newmean(i,j))**2.+& + (grid%afwa_hail_new4(i,j)-grid%afwa_hail_newmean(i,j))**2.+& + (grid%afwa_hail_new5(i,j)-grid%afwa_hail_newmean(i,j))**2.)& + / 4.0) + ENDDO + ENDDO + ENDIF + + ! Calculate buoyancy parameters. + ! ------------------------------ + IF ( config_flags % afwa_buoy_opt == 1 ) THEN + nz = k_end - k_start + 1 + + ! Calculate buoyancy for surface parcel + ! ------------------------------------- + DO j = jts, jte + DO i = its, ite + ostat = Buoyancy ( nz & + , grid%t_phy(i,kms:kme,j) & + , rh(i,kms:kme,j) & + , ptot(i,kms:kme,j) & + , grid % z(i,kms:kme,j) & + , 1 & + , grid % afwa_cape(i,j) & + , grid % afwa_cin(i,j) & + , zlfc_msl & + , grid % afwa_plfc(i,j) & + , grid % afwa_lidx(i,j) & + , 3 ) !Surface + + ! Subtract terrain height to convert ZLFC from MSL to AGL + ! ------------------------------------------------------- + IF ( zlfc_msl .ge. grid % ht ( i, j ) ) THEN + grid % afwa_zlfc ( i, j ) = zlfc_msl - grid % ht ( i, j ) + ELSE + grid % afwa_zlfc( i, j ) = -1. + ENDIF + + ! Add 273.15 to lifted index per some standard I don't understand + ! --------------------------------------------------------------- + IF ( grid % afwa_lidx ( i, j ) .ne. 999. ) THEN + grid % afwa_lidx ( i, j ) = grid % afwa_lidx ( i, j ) + 273.15 + ENDIF + + ! Calculate buoyancy again for most unstable layer + ! ------------------------------------------------ + ostat = Buoyancy ( nz & + , grid%t_phy(i,kms:kme,j) & + , rh(i,kms:kme,j) & + , ptot(i,kms:kme,j) & + , grid % z(i,kms:kme,j) & + , 1 & + , grid % afwa_cape_mu(i,j) & + , grid % afwa_cin_mu(i,j) & + , dum1 & + , dum2 & + , dum3 & + , 1 ) !Most unstable + + ENDDO + ENDDO + ENDIF ! afwa_buoy_opt == 1 + + IF ( config_flags % afwa_therm_opt == 1 ) THEN + write ( message, * ) 'Calculating thermal indices' + CALL wrf_debug( 100 , message ) + CALL thermal_diagnostics ( grid % t2 & + , grid % psfc & + , rh2m & + , wind10m & + , grid % afwa_heatidx & + , grid % afwa_wchill & + , grid % afwa_fits & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + ENDIF ! afwa_therm_opt == 1 + + IF ( config_flags % afwa_turb_opt == 1 ) THEN + write ( message, * ) 'Calculating turbulence indices' + + !~ For now, hard code turbulence layer bottom and top AGL heights + ! -------------------------------------------------------------- + grid % afwa_tlyrbot = (/ 1500., 3000., 4600., 6100., 7600., 9100., & + 10700. /) + grid % afwa_tlyrtop = (/ 3000., 4600., 6100., 7600., 9100., 10700., & + 12700. /) + call turbulence_diagnostics ( u_phy & + , v_phy & + , grid % t_phy & + , ptot & + , zagl & + , grid % defor11 & + , grid % defor12 & + , grid % defor22 & + , grid % afwa_turb & + , grid % afwa_llturb & + , grid % afwa_llturblgt & + , grid % afwa_llturbmdt & + , grid % afwa_llturbsvr & + !, config_flags % num_turb_layers & + , 7 & + , grid % afwa_tlyrbot & + , grid % afwa_tlyrtop & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + ENDIF ! afwa_turb_opt == 1 + + ! Calculate equivalent radar reflectivity factor (z_e) using + ! old RIP code (2004) if running radar or VIL packages. + ! ---------------------------------------------------------- + IF ( config_flags % afwa_radar_opt == 1 .or. & + config_flags % afwa_vil_opt == 1 ) THEN + write ( message, * ) 'Calculating Radar' + CALL wrf_debug( 100 , message ) + CALL wrf_dbzcalc ( rho & + , grid%t_phy & + , qrain & + , qsnow & + , qgrpl & + , z_e & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + ENDIF ! afwa_radar_opt == 1 .or. afwa_vil_opt == 1 + + ! Calculate derived radar variables + ! --------------------------------- + ! UPDATE: removed refd_max calculation, which was not working correctly. + ! To correctly calculate refd_max, this routine could be called every + ! time step, but instead, we are only going to calculate reflectivity + ! on output time steps and avoid cost of calculating refd_max. GAC2014 + ! ---------------------------------------------------------------------- + IF ( config_flags % afwa_radar_opt == 1 ) THEN + write ( message, * ) 'Calculating derived radar variables' + CALL wrf_debug( 100 , message ) + CALL radar_diagnostics ( grid % refd & + , grid % refd_com & +! , grid % refd_max & + , grid % echotop & + , grid % z & + , z_e & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + ENDIF ! afwa_radar_opt == 1 + + ! Calculate VIL and reflectivity every history output timestep + ! ------------------------------------------------------------ + IF ( config_flags % afwa_vil_opt == 1 ) THEN + write ( message, * ) 'Calculating VIL' + CALL wrf_debug( 100 , message ) + CALL vert_int_liquid_diagnostics ( grid % vil & + , grid % radarvil & + , grid % t_phy & + , qrain & + , qsnow & + , qgrpl & + , z_e & + , dz8w & + , rho & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + ENDIF ! afwa_vil_opt ==1 + + ! Calculate icing and freezing level + ! ---------------------------------- + IF ( config_flags % afwa_icing_opt == 1 ) THEN + + ! Determine icing option from microphysics scheme + ! ----------------------------------------------- + + IF ( config_flags % mp_physics == GSFCGCESCHEME ) THEN + icing_opt=1 + ELSEIF ( config_flags % mp_physics == ETAMPNEW ) THEN + icing_opt=2 + ELSEIF ( config_flags % mp_physics == THOMPSON ) THEN + icing_opt=3 + ELSEIF ( config_flags % mp_physics == WSM5SCHEME .OR. & + config_flags % mp_physics == WSM6SCHEME ) THEN + icing_opt=4 + ELSEIF ( config_flags % mp_physics == MORR_TWO_MOMENT ) THEN + + ! Is this run with prognostic cloud droplets or no? + ! ------------------------------------------------- + IF (config_flags % progn > 0) THEN + icing_opt=6 + ELSE + icing_opt=5 + ENDIF + ELSEIF ( config_flags % mp_physics == WDM6SCHEME ) THEN + icing_opt=7 + ELSE + icing_opt=0 ! Not supported + ENDIF + + write ( message, * ) 'Calculating Icing with icing opt ',icing_opt + CALL wrf_debug( 100 , message ) + CALL icing_diagnostics ( icing_opt & + , grid % fzlev & + , grid % icing_lg & + , grid % icing_sm & + , grid % qicing_lg_max & + , grid % qicing_sm_max & + , grid % qicing_lg & + , grid % qicing_sm & + , grid % icingtop & + , grid % icingbot & + , grid % t_phy & + , grid % z & + , dz8w & + , rho & + , qrain & + , qcloud & + , ncloud & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + ENDIF ! afwa_icing_opt + + ! Calculate visiblility diagnostics + ! --------------------------------- + IF ( config_flags % afwa_vis_opt == 1 ) THEN + + ! Interpolate 20m temperature and RH + ! ---------------------------------- + DO i=ims,ime + DO j=jms,jme + tv20m(i,j) = -999. + rh20m(i,j) = -999. + DO k = kps, MIN(kpe,kde-1) + IF (tv20m (i,j) .eq. -999. .AND. zagl (i,k,j) .ge. 20.) THEN + + ! If the lowest model level > 20 m AGL, interpolate using 2-m temperature/RH + ! -------------------------------------------------------------------------- + IF (k .eq. kps) THEN + tv20m(i,j) = tv2m(i,j) + & + (20. - 2.) / & + (zagl(i,k,j) - 2.) * & + (grid%t_phy(i,k,j) * (1 + 0.61 * qvapr(i,k,j)) - tv2m(i,j)) + rh20m(i,j) = rh2m(i,j) + & + (20. - 2.) / & + (zagl(i,k,j) - 2.) * & + (rh(i,k,j) - rh2m(i,j)) + ELSE + tv20m(i,j) = grid%t_phy(i,k-1,j) * (1 + 0.61 * qvapr(i,k-1,j)) + & + ((20. - zagl(i,k-1,j)) / & + (zagl(i,k,j) - zagl(i,k-1,j))) * & + (grid%t_phy(i,k,j) * (1 + 0.61 * qvapr(i,k,j)) - & + grid%t_phy(i,k-1,j) * (1 + 0.61 * qvapr(i,k-1,j))) + rh20m(i,j) = rh (i,k-1,j) + & + ((20. - zagl (i,k-1,j)) / & + (zagl (i,k,j) - zagl (i,k-1,j))) * & + (rh (i,k,j) - rh (i,k-1,j)) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + + ! Calculate 125 meter winds + ! ------------------------- + DO i=ims,ime + DO j=jms,jme + wind125m(i,j) = -999. + DO k = kps, MIN(kpe,kde-1) + IF (wind125m (i,j) .eq. -999. .AND. zagl (i,k,j) .ge. 125.) THEN + + ! If the lowest model level > 125 m AGL, use level 1 wind + ! ------------------------------------------------------- + IF (k .eq. kps) THEN + wind125m(i,j) = uv_wind(u_phy(i,k,j),v_phy(i,k,j)) + ELSE + wind125m(i,j) = uv_wind(u_phy(i,k-1,j),v_phy(i,k-1,j)) + & + ((125. - zagl(i,k-1,j)) / & + (zagl(i,k,j) - zagl(i,k-1,j))) * & + (uv_wind(u_phy(i,k,j),v_phy(i,k,j)) - & + uv_wind(u_phy(i,k-1,j),v_phy(i,k-1,j))) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + + write ( message, * ) 'Calculating visibility' + CALL wrf_debug( 100 , message ) + CALL vis_diagnostics ( qcloud(ims:ime,k_start,jms:jme) & + , qrain(ims:ime,k_start,jms:jme) & + , qice(ims:ime,k_start,jms:jme) & + , qsnow(ims:ime,k_start,jms:jme) & + , qgrpl(ims:ime,k_start,jms:jme) & + , rho(ims:ime,k_start,jms:jme) & + , wind10m & + , wind125m & + , grid % afwa_pwat & + , grid % q2 & + , rh2m & + , rh20m & + , tv2m & + , tv20m & + , dustc & + , grid % afwa_vis & + , grid % afwa_vis_dust & + , grid % afwa_vis_alpha & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + ENDIF + + ! Calculate cloud diagnostics + ! --------------------------- + IF ( config_flags % afwa_cloud_opt == 1 ) THEN + write ( message, * ) 'Calculating cloud' + CALL wrf_debug( 100 , message ) + CALL cloud_diagnostics (qcloud & + , qice & + , qsnow & + , rh_cld & + , dz8w & + , rho & + , grid % z & + , grid % ht & + , grid % afwa_cloud & + , grid % afwa_cloud_ceil & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + ENDIF + + ENDIF ! is_output_timestep + + END SUBROUTINE afwa_diagnostics_driver + + + + SUBROUTINE severe_wx_diagnostics ( wspd10max & + , w_up_max & + , w_dn_max & + , up_heli_max & + , tcoli_max & + , midrh_min_old & + , midrh_min & + , afwa_hail & + , afwa_hail_new1 & + , afwa_hail_new2 & + , afwa_hail_new3 & + , afwa_hail_new4 & + , afwa_hail_new5 & + , cape & + , cin & +! , cape_mu & +! , cin_mu & + , zlfc & + , plfc & + , lidx & + , llws & + , afwa_tornado & + , grpl_flx_max & + , u10 & + , v10 & + , w_2 & + , uh & + , t_phy & + , t2 & + , z & + , ht & + , wup_mask & + , wdur & + , tornado_mask & + , tornado_dur & + , dt & + , pwat & + , u_phy & + , v_phy & + , p & + , qi & + , qs & + , qg & + , ng & + , qv, qr, qc & + , rho & + , dz8w & + , rh & + , do_buoy_calc & + , do_hailcast_calc & + , ims, ime, jms, jme, kms, kme & + , its, ite, jts, jte & + , k_start, k_end & + , j_start, j_end, i_start, i_end ) + + USE module_diag_afwa_hail + + INTEGER, INTENT(IN) :: its, ite, jts, jte, k_start, k_end & + , ims, ime, jms, jme, kms, kme & + , j_start, j_end, i_start, i_end + + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: p & + , w_2 & + , t_phy & + , u_phy & + , v_phy & + , qi & + , qs & + , qg & + , ng & + , qv, qr, qc & + , rho & + , z & + , dz8w & + , rh + + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: u10 & + , v10 & + , wspd10max & + , uh & + , t2 & + , ht & + , midrh_min_old & + , up_heli_max & + , llws & + , pwat + + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: w_up_max & + , w_dn_max & + , tcoli_max & + , midrh_min & + , afwa_hail & + , afwa_hail_new1 & + , afwa_hail_new2 & + , afwa_hail_new3 & + , afwa_hail_new4 & + , afwa_hail_new5 & + , afwa_tornado & + , grpl_flx_max & + , wup_mask & + , wdur & + , tornado_mask & + , tornado_dur + + +! REAL, DIMENSION( ims:ime, jms:jme ), & +! INTENT( OUT) :: cape & +! , cin & +! , cape_mu & +! , cin_mu & +! , zlfc & +! , plfc & +! , lidx + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: cape & + , cin & + , zlfc & + , plfc & + , lidx + + REAL, INTENT(IN) :: dt + LOGICAL, INTENT(IN) :: do_buoy_calc & + , do_hailcast_calc + + ! Local + ! ----- + INTEGER :: i,j,k + INTEGER :: kts,kte + REAL :: zagl, zlfc_msl, melt_term, midrh_term, hail, midrh + REAL :: dum1, dum2, dum3 + REAL :: tornado, lfc_term, shr_term, midrh2_term, uh_term + REAL :: wind_vel, p_tot, tcoli, grpl_flx, w_n15, qg_n15 + INTEGER :: nz, ostat + REAL, DIMENSION( ims:ime, jms:jme ) :: w_up & + , w_dn & + , wup_mask_prev & + , wdur_prev & + , tornado_mask_prev & + , tornado_dur_prev + REAL :: dhail1,dhail2,dhail3,dhail4,dhail5 + REAL :: time_factor, time_factor_prev + LOGICAL :: is_target_level + + ! Calculate midlevel relative humidity minimum + ! -------------------------------------------- + DO i=ims,ime + DO j=jms,jme + is_target_level=.false. + DO k=kms,kme + zagl = z(i,k,j) - ht(i,j) + IF ( ( zagl >= 3500. ) .and. & + ( .NOT. is_target_level ) .and. & + ( k .ne. kms ) ) THEN + is_target_level = .true. + midrh = rh(i,k-1,j) + (3500. - (z(i,k-1,j) - ht(i,j))) & + * ((rh(i,k,j) - rh(i,k-1,j))/(z(i,k,j) - z(i,k-1,j))) + IF ( midrh .lt. midrh_min(i,j) ) THEN + midrh_min(i,j) = midrh + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + + ! Calculate the max 10 m wind speed between output times + ! ------------------------------------------------------ + !DO j = jts, jte + ! DO i = its, ite + ! wind_vel = uv_wind ( u10(i,j) , v10(i,j) ) + ! IF ( wind_vel .GT. wspd10max(i,j) ) THEN + ! wspd10max(i,j) = wind_vel + ! ENDIF + ! ENDDO + !ENDDO + + ! Vertical velocity quantities between output times + ! ------------------------------------------------- + w_up=0. + w_dn=0. + DO j = jts, jte + DO k = k_start, k_end + DO i = its, ite + p_tot = p(i,k,j) / 100. + + ! Check vertical velocity field below 400 mb + IF ( p_tot .GT. 400. .AND. w_2(i,k,j) .GT. w_up(i,j) ) THEN + w_up(i,j) = w_2(i,k,j) + IF ( w_up(i,j) .GT. w_up_max(i,j) ) THEN + w_up_max(i,j) = w_up(i,j) + ENDIF + ENDIF + IF ( p_tot .GT. 400. .AND. w_2(i,k,j) .LT. w_dn(i,j) ) THEN + w_dn(i,j) = w_2(i,k,j) + IF ( w_dn(i,j) .LT. w_dn_max(i,j) ) THEN + w_dn_max(i,j) = w_dn(i,j) + ENDIF + ENDIF + ENDDO + ENDDO + ENDDO + + ! Hail diameter in millimeters (Weibull distribution) + ! --------------------------------------------------- + DO j = jts, jte + DO i = its, ite + melt_term=max(t2(i,j)-288.15,0.) + midrh_term=max(2*(min(midrh_min(i,j),midrh_min_old(i,j))-70.),0.) + ! Change exponent to 1.1 to reduce probabilities for large sizes + !hail=max((w_up(i,j)/1.4)**1.25-melt_term-midrh_term,0.) + hail=max((w_up(i,j)/1.4)**1.1-melt_term-midrh_term,0.) + hail=hail*((uh(i,j)/100)+0.25) + IF ( hail .gt. afwa_hail(i,j) ) THEN + afwa_hail(i,j)=hail + ENDIF + ENDDO + ENDDO + + ! Hailcast calculation. Please note: this is VERY + ! expensive, and needs to be optimized in the future to + ! reduce its expense. Currently, on domains with plenty + ! of convection, we have seen timesteps increase upwards + ! of 300%. Also, because it is not calculated at every + ! grid point, only where there is an updraft, this can + ! lead to very unpredictable run time behavior. Until + ! we are able to speed it up significantly (either by + ! modifications to the algorithm, or by calling it less + ! frequently) we are not running this in production at + ! AFWA and are turning it off by default. To run hailcast + ! please use afwa_hailcast_opt=1 in the namelist. GAC2014 + ! -------------------------------------------------------- + IF ( do_hailcast_calc ) THEN + + ! --> RAS + ! Make a copy of the updraft duration, mask variables + ! --------------------------------------------------- + wdur_prev(:,:) = wdur(:,:) + wup_mask_prev(:,:) = wup_mask(:,:) + + ! Determine updraft mask (where updraft greater than some threshold) + ! --------------------------------------------------- + DO j = jts, jte + DO i = its, ite + wup_mask(i,j) = 0 + wdur(i,j) = 0 + + DO k = k_start, k_end + IF ( w_2(i,k,j) .ge. 10. ) THEN + wup_mask(i,j) = 1 + ENDIF + ENDDO + ENDDO + ENDDO + + ! Determine updraft duration; make sure not to call point outside the domain + ! --------------------------------------------------- + DO j = j_start, j_end + DO i = i_start, i_end + + ! Determine updraft duration using updraft masks + ! --------------------------------------------------- + IF ( (wup_mask(i,j).eq.1) .OR. & + (MAXVAL(wup_mask_prev(i-1:i+1,j-1:j+1)).eq.1) ) THEN + wdur(i,j) = MAXVAL(wdur_prev(i-1:i+1,j-1:j+1)) + dt + ENDIF + ENDDO + ENDDO + + + ! Hail diameter in millimeters (HAILCAST) + ! --------------------------------------------------- + nz = k_end - k_start + DO j = jts, jte + DO i = its, ite + + ! Only call hailstone driver if updraft has been + ! around longer than 15 min + ! ---------------------------------------------- + IF (wdur(i,j) .gt. 900) THEN + CALL hailstone_driver ( t_phy(i,kms:kme,j), & + z(i,kms:kme,j), & + ht(i, j), & + p(i,kms:kme,j), & + rho(i,kms:kme,j), & + qv(i,kms:kme,j), & + qi(i,kms:kme,j), & + qc(i,kms:kme,j), & + qr(i,kms:kme,j), & + qs(i,kms:kme,j), & + qg(i,kms:kme,j), & + ng(i,kms:kme,j), & + w_2(i,kms:kme,j), & + wdur(i,j), & + nz, & + dhail1, dhail2, & + dhail3, dhail4, & + dhail5 ) + IF (dhail1 .gt. afwa_hail_new1(i,j)) THEN + afwa_hail_new1(i,j) = dhail1 + ENDIF + IF (dhail2 .gt. afwa_hail_new2(i,j)) THEN + afwa_hail_new2(i,j) = dhail2 + ENDIF + IF (dhail3 .gt. afwa_hail_new3(i,j)) THEN + afwa_hail_new3(i,j) = dhail3 + ENDIF + IF (dhail4 .gt. afwa_hail_new4(i,j)) THEN + afwa_hail_new4(i,j) = dhail4 + ENDIF + IF (dhail5 .gt. afwa_hail_new5(i,j)) THEN + afwa_hail_new5(i,j) = dhail5 + ENDIF + ENDIF + ENDDO + ENDDO + ! <-- RAS + + ENDIF !~ End if do_hailcast_calc + + ! Lightning (total column-integrated cloud ice) + ! Note this formula is basically stolen from the VIL calculation. + ! --------------------------------------------------------------- + DO j = jts, jte + DO i = its, ite + tcoli=0. + DO k = k_start, k_end + tcoli = tcoli + & + (qi (i,k,j) + & + qs (i,k,j) + & + qg (i,k,j)) & + *dz8w (i,k,j) * rho(i,k,j) + ENDDO + IF ( tcoli .GT. tcoli_max(i,j) ) THEN + tcoli_max(i,j) = tcoli + ENDIF + ENDDO + ENDDO + + ! Lighting (pseudo graupel flux calculation) + ! Model graupel mixing ration (g/kg) times w (m/s) at the -15C level + ! Values should range from around 25 in marginal lightning situations, + ! to over 400 in situations with very frequent lightning. + ! -------------------------------------------------------------------- + DO j = jts, jte + DO i = its, ite + grpl_flx=0 + w_n15=-999. + DO k = k_start, k_end + + ! Interpolate w and qg to -15C level and calculate graupel flux + ! as simply graupel x vertical velocity at -15C + ! ------------------------------------------------------------- + IF ( t_phy (i,k,j) .LE. 258.15 .AND. w_n15 .EQ. -999. .AND. & + k .GT. k_start .AND. qg (i,k,j) .GT. 1.E-20 ) THEN + w_n15 = w_2 (i,k,j) + qg_n15 = 1000. * qg (i,k,j) ! g/kg + grpl_flx = qg_n15 * w_n15 + ENDIF + ENDDO + IF ( grpl_flx .GT. grpl_flx_max(i,j) ) THEN + grpl_flx_max(i,j) = grpl_flx + ENDIF + ENDDO + ENDDO + + ! Update buoyancy parameters. + ! --------------------------- + IF ( do_buoy_calc ) THEN + nz = k_end - k_start + 1 + DO j = jts, jte + DO i = its, ite + ostat = Buoyancy ( nz & + , t_phy(i,kms:kme ,j) & + , rh(i,kms:kme ,j) & + , p(i,kms:kme ,j) & + , z(i,kms:kme ,j) & + , 1 & + , cape(i,j) & + , cin(i,j) & + , zlfc_msl & + , plfc(i,j) & + , lidx(i,j) & + , 3 ) !Surface + + ! Add 273.15 to lifted index per some standard I don't understand + ! --------------------------------------------------------------- + IF ( lidx ( i, j ) .ne. 999. ) lidx ( i, j ) = lidx ( i, j ) + 273.15 + + ! Subtract terrain height to convert ZLFC from MSL to AGL + ! ------------------------------------------------------- + IF ( zlfc_msl .ge. 0. ) THEN + zlfc ( i, j ) = zlfc_msl - ht ( i, j ) + ELSE + zlfc( i, j ) = -1. + ENDIF + + ENDDO + ENDDO + ENDIF + + ! Maximum tornado wind speed in ms-1. + ! First, save off old tornado mask and duration arrays + ! ---------------------------------------------------- + tornado_dur_prev(:,:)=tornado_dur(:,:) + tornado_mask_prev(:,:)=tornado_mask(:,:) + + ! Initialize all tornado variables + ! -------------------------------- + tornado_mask(:,:)=0. + tornado_dur(:,:)=0. + + DO j = j_start, j_end + DO i = i_start, i_end + tornado = 0. + + ! Current tornado algorithm + ! ------------------------- + IF ( zlfc(i,j) .ge. 0. ) THEN + uh_term = min(max((uh(i,j) - 25.) / 50., 0.), 1.) + shr_term = min(max((llws(i,j) - 2.) / 10., 0.), 1.) + lfc_term = min(max((3000. - zlfc(i,j)) / 1500., 0.), 1.) + midrh2_term = min(max((90. - & + min(midrh_min(i,j),midrh_min_old(i,j))) / 30., 0.), 1.) + tornado = 50. * uh_term * shr_term * lfc_term * midrh2_term + ENDIF + + ! Does tornado algorithm indicate all possible ingredients + ! for a minimum tornado, if so turn on mask + ! -------------------------------------------------------- + IF (tornado .GT. 0.) THEN + tornado_mask(i,j) = 1. + ENDIF + + ! Update the duration of this tornado if there was previously + ! a tornado mask at this or an adjacent point + ! ----------------------------------------------------------- + IF ( ( tornado_mask(i,j) .GT. 0.5 ) .OR. & + ( MAXVAL(tornado_mask_prev(i-1:i+1,j-1:j+1)) .GT. 0.5 ) ) THEN + tornado_dur(i,j) = MAXVAL(tornado_dur_prev(i-1:i+1,j-1:j+1)) + dt + ENDIF + + ! Ramp up value of tornado beta value linearly in time until & + ! it has been sustained 5 minutes + ! ------------------------------------------------------------ + time_factor = MIN(tornado_dur(i,j)/900.,1.) + tornado = tornado * time_factor + + ! OPTIONAL + ! Adjust previous max tornado wind upward to account for longer + ! duration - if after 5 minutes, no adjustment made as + ! time_factor/time_factor_prev=1 + ! ------------------------------------------------------------- + !time_factor_prev = MIN((tornado_dur(i,j) - dt)/900.,1.) + !IF ( ( time_factor_prev .GT. 0. ) .AND. & + ! ( time_factor_prev .LT. 1. ) ) THEN + ! afwa_tornado(i,j) = afwa_tornado(i,j) * time_factor/time_factor_prev + !ENDIF + + ! Now that we are comparing apples to apples, see if current tornado + ! wind is higher than previous highest value for this point + ! ------------------------------------------------------------------ + IF ( tornado .GT. afwa_tornado(i,j) ) THEN + afwa_tornado(i,j) = tornado + ENDIF + ENDDO + ENDDO + + END SUBROUTINE severe_wx_diagnostics + + + + SUBROUTINE vert_int_liquid_diagnostics ( vil & + , radarvil & + , t_phy & + , qrain & + , qsnow & + , qgrpl & + , z_e & + , dz8w & + , rho & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + + INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: rho & + , qrain & + , qsnow & + , qgrpl & + , t_phy & + , z_e & + , dz8w + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: vil & + , radarvil + + ! Local + ! ----- + INTEGER :: i,j,k,ktime + + ! Calculate vertically integrated liquid water (though its mostly not + ! "liquid" now is it?) [kg/m^2] + ! ------------------------------------------------------------------- + DO i = ips, MIN(ipe,ide-1) + DO j = jps, MIN(jpe,jde-1) + vil (i,j) = 0.0 + DO k = kps, MIN(kpe,kde-1) + vil (i,j) = vil (i,j) + & + (qrain (i,k,j) + & + qsnow (i,k,j) + & + qgrpl (i,k,j)) & + *dz8w (i,k,j) * rho(i,k,j) + ENDDO + ENDDO + ENDDO + + ! Diagnose "radar-derived VIL" from equivalent radar reflectivity + ! radarVIL = (integral of LW*dz )/1000.0 (in kg/m^2) + ! LW = 0.00344 * z_e** (4/7) in g/m^3 + ! --------------------------------------------------------------- + DO i = ips, MIN(ipe,ide-1) + DO j = jps, MIN(jpe,jde-1) + radarvil (i,j) = 0.0 + DO k = kps, MIN(kpe,kde-1) + radarvil (i,j) = radarvil (i,j) + & + 0.00344 * z_e(i,k,j)**0.57143 & + *dz8w (i,k,j)/1000.0 + END DO + END DO + END DO + + END SUBROUTINE vert_int_liquid_diagnostics + + + + SUBROUTINE icing_diagnostics ( icing_opt & + , fzlev & + , icing_lg & + , icing_sm & + , qicing_lg_max & + , qicing_sm_max & + , qicing_lg & + , qicing_sm & + , icingtop & + , icingbot & + , t_phy & + , z & + , dz8w & + , rho & + , qrain & + , qcloud & + , ncloud & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + + INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe + + INTEGER, INTENT(IN) :: icing_opt + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: z & + , qrain & + , qcloud & + , ncloud & + , rho & + , dz8w & + , t_phy + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT( OUT) :: fzlev & + , icing_lg & + , icing_sm & + , qicing_lg_max & + , qicing_sm_max & + , icingtop & + , icingbot + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT( OUT) :: qicing_lg & + , qicing_sm + + + ! Local + ! ----- + INTEGER :: i,j,k,ktime,ktop,kbot + REAL :: qcfrac_lg, qcfrac_sm, qc, qr, small, all ! Initializations ! --------------- @@ -888,7 +3284,7 @@ SUBROUTINE icing_diagnostics ( icing_opt & ! Thompson ! -------- - ! RAS13.2 Per James McCormick's stats, more large supercooled + ! RAS Per James McCormick's stats, more large supercooled ! drops are needed from the Thompson members. Changing ! calculation to be like WSM5/6 members. !ELSEIF (icing_opt .eq. 3) THEN @@ -1023,7 +3419,7 @@ END SUBROUTINE icing_diagnostics SUBROUTINE radar_diagnostics ( refd & , refd_com & - , refd_max & +! , refd_max & , echotop & , z & , z_e & @@ -1042,7 +3438,7 @@ SUBROUTINE radar_diagnostics ( refd & REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(INOUT) :: refd & , refd_com & - , refd_max & +! , refd_max & , echotop ! Local @@ -1062,9 +3458,9 @@ SUBROUTINE radar_diagnostics ( refd & ! -------------------------- IF (k == kps) refd(i,j) = MAX(10.0 * log10(z_e(i,k,j)),0.) - ! Max reflectivity over the output interval - ! ----------------------------------------- - IF (refd(i,j) .gt. refd_max(i,j)) refd_max(i,j) = refd(i,j) +! ! Max reflectivity over the output interval +! ! ----------------------------------------- +! IF (refd(i,j) .gt. refd_max(i,j)) refd_max(i,j) = refd(i,j) ! Composite reflectivity calc (max reflectivity in the column) ! ------------------------------------------------------------ @@ -1293,15 +3689,13 @@ SUBROUTINE precip_type_diagnostics ( t_phy & IF (t_phy(i,k,j) .gt. maxtmp(i,j)) THEN maxtmp(i,j)=t_phy(i,k,j) ENDIF - IF ( ( rh(i,k,j) .gt. 80 ) .and. & - ( .NOT. saturation(i,j) ) ) THEN + IF (rh(i,k,j) .gt. 80 .and. saturation(i,j) .eqv. .false.) THEN cloud_top_tmp(i,j)=t_phy(i,k,j) cloud_top_k_index(i,j)=k saturation(i,j)=.true. precip_type(i,j)=2 ! Snow ENDIF - IF ( ( rh(i,k,j) .le. 70 ) .and. & - ( saturation(i,j) ) ) THEN + IF (rh(i,k,j) .le. 70 .and. saturation(i,j) .eqv. .true.) THEN saturation(i,j)=.false. ENDIF ENDIF @@ -1374,984 +3768,649 @@ SUBROUTINE precip_type_diagnostics ( t_phy & IF (precip_type(i,j) .eq. 2) THEN snow(i,j)=snow(i,j)+precip(i,j) snowfall(i,j)=snowfall(i,j)+snow_ratio*precip(i,j) & - *(5.-mod_2m_tmp(i,j)+273.15)**0.5 + *(5.-mod_2m_tmp(i,j)+273.15)**0.4 ENDIF IF (precip_type(i,j) .eq. 1) THEN IF (mod_2m_tmp(i,j) .gt. 273.15) THEN rain(i,j)=rain(i,j)+precip(i,j) ELSE frz_rain(i,j)=frz_rain(i,j)+precip(i,j) - ENDIF - ENDIF - - ENDIF ! End if precip>0 - - ENDDO ! End do j=jps,jpe - ENDDO ! End do i=ips,ipe - - END SUBROUTINE precip_type_diagnostics - - - - SUBROUTINE vis_diagnostics ( qcloud & - , qrain & - , qice & - , qsnow & - , wind10m & - , rh2m & - , dustc & - , vis & - , vis_dust & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe ) - - INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe - - INTEGER, PARAMETER :: ndust=5 - - REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT(IN ) :: qcloud & - , qrain & - , qice & - , qsnow & - , wind10m & - , rh2m - REAL, DIMENSION( ims:ime, jms:jme, ndust ), & - INTENT(IN ) :: dustc - REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT( OUT) :: vis & - , vis_dust - - ! Local - ! ----- - INTEGER :: i,j,k,d - REAL, PARAMETER :: visfactor=3.912 - REAL, DIMENSION (ndust) :: dustfact - REAL :: bc, br, bi, bs, dust_extcoeff, hydro_extcoeff, extcoeff, vis_haze - - ! Dust factor based on 5 bin AFWA dust scheme. This is a simplification - ! of the scheme in WRFPOST. More weight is applied to smaller particles. - ! ----------------------------------------------------------------------- - dustfact=(/1.470E-6,7.877E-7,4.623E-7,2.429E-7,1.387E-7/) - - DO i=ims,ime - DO j=jms,jme - - ! Hydrometeor extinction coefficient - ! ---------------------------------- - bc=144.7*qcloud(i,j)**0.88 - br=2.240*qrain(i,j)**0.75 - bi=327.8*qice(i,j) - bs=10.36*qsnow(i,j)**0.78 - hydro_extcoeff=bc+br+bi+bs - - ! Dust extinction coefficient - ! --------------------------- - dust_extcoeff=0. - DO d=1,ndust - dust_extcoeff=dust_extcoeff+dustfact(d)*dustc(i,j,d) - ENDDO - - ! Visibility due to haze obscuration - ! ---------------------------------- - vis_haze=1500.*(105.-rh2m(i,j)+wind10m(i,j)) - - ! Calculate total visibility - ! Take minimum visibility from hydro/lithometeors and haze - ! Define maximum visibility as 20 km (UPDATE: 999.999 km) - ! -------------------------------------------------------- - extcoeff=hydro_extcoeff+dust_extcoeff - IF (extcoeff .gt. 0.) THEN - vis(i,j)=MIN(visfactor/extcoeff,vis_haze) - ELSE - vis(i,j)=999999. - ENDIF - - ! Calculate dust visibility - ! Again, define maximum visibility as 20 km - ! ----------------------------------------- - IF (dust_extcoeff .gt. 0.) THEN - vis_dust(i,j)=MIN(visfactor/dust_extcoeff,999999.) - ELSE - vis_dust(i,j)=999999. - ENDIF - ENDDO - ENDDO - - END SUBROUTINE vis_diagnostics - - - - SUBROUTINE cloud_diagnostics (qcloud & - , qice & - , qsnow & - , rh & - , dz8w & - , rho & - , z & - , ht & - , cloud & - , cloud_ceil & - , ids, ide, jds, jde, kds, kde & - , ims, ime, jms, jme, kms, kme & - , ips, ipe, jps, jpe, kps, kpe ) - - INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: qcloud & - , qice & - , qsnow & - , rh & - , dz8w & - , rho & - , z - - REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT(IN ) :: ht - - REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT( OUT) :: cloud & - , cloud_ceil - - ! Local - ! ----- - INTEGER :: i, j, k - REAL :: tot_cld_cond, maxrh, cld_frm_cnd, cld_frm_rh - - ! Calculate cloud cover based on total cloud condensate, or if none - ! present, from maximum relative humidity in the column. - ! ----------------------------------------------------------------- - DO i=ims,ime - DO j=jms,jme - tot_cld_cond = 0. - maxrh = -9999. - cloud_ceil(i,j) = -9999. - DO k=kms,kme - - ! Total cloud condensate - ! ---------------------- - tot_cld_cond = tot_cld_cond + (qcloud (i,k,j) + qice (i,k,j) & - + qsnow (i,k,j)) * dz8w (i,k,j) * rho(i,k,j) - - ! Maximum column relative humidity - ! -------------------------------- - IF (rh (i,k,j) .gt. maxrh) THEN - maxrh = rh (i,k,j) - ENDIF - - ! Cloud cover parameterization. Take maximum value - ! from condensate and relative humidity terms. - ! ------------------------------------------------ - cld_frm_cnd = 50. * tot_cld_cond - cld_frm_rh = MAX(((maxrh - 70.) / 30.),0.) - cloud (i,j) = MAX(cld_frm_cnd,cld_frm_rh) - - ! Calculate cloud ceiling, the level at which - ! parameterization of cloud cover exceeds 80% - ! ------------------------------------------- - IF ( cloud_ceil (i,j) .eq. -9999. .and. cloud (i,j) .gt. 0.8 ) THEN - cloud_ceil (i,j) = z (i,k,j) - ht (i,j) - ENDIF - ENDDO - ENDDO - ENDDO - - END SUBROUTINE cloud_diagnostics - - - - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - !~ - !~ Name: - !~ calc_rh - !~ - !~ Description: - !~ This function calculates relative humidity given pressure, - !~ temperature, and water vapor mixing ratio. - !~ - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - FUNCTION calc_rh ( p, t, qv ) result ( rh ) - - IMPLICIT NONE - - REAL, INTENT(IN) :: p, t, qv - REAL :: rh - - ! Local - ! ----- - REAL, PARAMETER :: pq0=379.90516 - REAL, PARAMETER :: a2=17.2693882 - REAL, PARAMETER :: a3=273.16 - REAL, PARAMETER :: a4=35.86 - REAL, PARAMETER :: rhmin=1. - REAL :: q, qs - INTEGER :: i,j,k - - ! Following algorithms adapted from WRFPOST - ! May want to substitute with another later - ! ----------------------------------------- - q=qv/(1.0+qv) - qs=pq0/p*exp(a2*(t-a3)/(t-a4)) - rh=100.*q/qs - IF (rh .gt. 100.) THEN - rh=100. - ELSE IF (rh .lt. rhmin) THEN - rh=rhmin - ENDIF - - END FUNCTION calc_rh - - - - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - !~ - !~ Name: - !~ uv_wind - !~ - !~ Description: - !~ This function calculates the wind speed given U and V wind - !~ components. - !~ - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - FUNCTION uv_wind ( u, v ) result ( wind_speed ) - - IMPLICIT NONE - - REAL, INTENT(IN) :: u, v - REAL :: wind_speed - - wind_speed = sqrt( u*u + v*v ) - - END FUNCTION uv_wind - - - - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - !~ - !~ Name: - !~ Theta - !~ - !~ Description: - !~ This function calculates potential temperature as defined by - !~ Poisson's equation, given temperature and pressure ( hPa ). - !~ - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - FUNCTION Theta ( t, p ) - IMPLICIT NONE - - !~ Variable declaration - ! -------------------- - REAL, INTENT ( IN ) :: t - REAL, INTENT ( IN ) :: p - REAL :: theta - - REAL :: Rd ! Dry gas constant - REAL :: Cp ! Specific heat of dry air at constant pressure - REAL :: p0 ! Standard pressure ( 1000 hPa ) - - Rd = 287.04 - Cp = 1004.67 - p0 = 1000.00 + ENDIF + ENDIF - !~ Poisson's equation - ! ------------------ - theta = t * ( (p0/p)**(Rd/Cp) ) - - END FUNCTION Theta + ENDIF ! End if precip>0 + ENDDO ! End do j=jps,jpe + ENDDO ! End do i=ips,ipe + END SUBROUTINE precip_type_diagnostics - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - !~ - !~ Name: - !~ Thetae - !~ - !~ Description: - !~ This function returns equivalent potential temperature using the - !~ method described in Bolton 1980, Monthly Weather Review, equation 43. - !~ - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - FUNCTION Thetae ( tK, p, rh, mixr ) - IMPLICIT NONE - !~ Variable Declarations - ! --------------------- - REAL :: tK ! Temperature ( K ) - REAL :: p ! Pressure ( hPa ) - REAL :: rh ! Relative humidity - REAL :: mixr ! Mixing Ratio ( kg kg^-1) - REAL :: te ! Equivalent temperature ( K ) - REAL :: thetae ! Equivalent potential temperature - - REAL, PARAMETER :: R = 287.04 ! Universal gas constant (J/deg kg) - REAL, PARAMETER :: P0 = 1000.0 ! Standard pressure at surface (hPa) - REAL, PARAMETER :: lv = 2.54*(10**6) ! Latent heat of vaporization - ! (J kg^-1) - REAL, PARAMETER :: cp = 1004.67 ! Specific heat of dry air constant - ! at pressure (J/deg kg) - REAL :: tlc ! LCL temperature - - !~ Calculate the temperature of the LCL - ! ------------------------------------ - tlc = TLCL ( tK, rh ) - - !~ Calculate theta-e - ! ----------------- - thetae = (tK * (p0/p)**( (R/Cp)*(1.- ( (.28E-3)*mixr*1000.) ) ) )* & - exp( (((3.376/tlc)-.00254))*& - (mixr*1000.*(1.+(.81E-3)*mixr*1000.)) ) - - END FUNCTION Thetae + SUBROUTINE vis_diagnostics ( qcloud & + , qrain & + , qice & + , qsnow & + , qgrpl & + , rho & + , wind10m & + , wind125m & + , pwater & + , q2m & + , rh2m & + , rh20m & + , tv2m & + , tv20m & + , dustc & + , vis & + , vis_dust & + , vis_alpha & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) + INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - !~ - !~ Name: - !~ The2T.f90 - !~ - !~ Description: - !~ This function returns the temperature at any pressure level along a - !~ saturation adiabat by iteratively solving for it from the parcel - !~ thetae. - !~ - !~ Dependencies: - !~ function thetae.f90 - !~ - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - FUNCTION The2T ( thetaeK, pres, flag ) result ( tparcel ) - IMPLICIT NONE - - !~ Variable Declaration - ! -------------------- - REAL, INTENT ( IN ) :: thetaeK - REAL, INTENT ( IN ) :: pres - LOGICAL, INTENT ( INOUT ) :: flag - REAL :: tparcel - - REAL :: thetaK - REAL :: tovtheta - REAL :: tcheck - REAL :: svpr, svpr2 - REAL :: smixr, smixr2 - REAL :: thetae_check, thetae_check2 - REAL :: tguess_2, correction - - LOGICAL :: found - INTEGER :: iter - - REAL :: R ! Dry gas constant - REAL :: Cp ! Specific heat for dry air - REAL :: kappa ! Rd / Cp - REAL :: Lv ! Latent heat of vaporization at 0 deg. C - - R = 287.04 - Cp = 1004.67 - Kappa = R/Cp - Lv = 2.500E+6 + INTEGER, PARAMETER :: ndust=5 - !~ Make initial guess for temperature of the parcel - ! ------------------------------------------------ - tovtheta = (pres/100000.0)**(r/cp) - tparcel = thetaeK/exp(lv*.012/(cp*295.))*tovtheta + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: qcloud & + , qrain & + , qice & + , qsnow & + , qgrpl & + , rho & + , wind10m & + , wind125m & + , pwater & + , rh2m & + , q2m & + , rh20m & + , tv2m & + , tv20m + REAL, DIMENSION( ims:ime, jms:jme, ndust ), & + INTENT(IN ) :: dustc + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT( OUT) :: vis & + , vis_dust & + , vis_alpha - iter = 1 - found = .false. - flag = .false. + ! Local + ! ----- + INTEGER :: i,j,k,d + REAL, PARAMETER :: visfactor=3.912 + REAL, DIMENSION (ndust) :: dustfact + REAL :: bc, br, bi, bs, dust_extcoeff, hydro_extcoeff, extcoeff, vis_haze + REAL :: tvd, rh, prob_ext_coeff_gt_p29, haze_ext_coeff + REAL :: vis_hydlith, alpha_haze - DO - IF ( iter > 105 ) EXIT + ! Dust factor based on 5 bin AFWA dust scheme. This is a simplification + ! of the scheme in WRFPOST. More weight is applied to smaller particles. + ! ----------------------------------------------------------------------- + dustfact=(/1.470E-6,7.877E-7,4.623E-7,2.429E-7,1.387E-7/) - tguess_2 = tparcel + REAL ( 1 ) + DO i=ims,ime + DO j=jms,jme - svpr = 6.122 * exp ( (17.67*(tparcel-273.15)) / (tparcel-29.66) ) - smixr = ( 0.622*svpr ) / ( (pres/100.0)-svpr ) - svpr2 = 6.122 * exp ( (17.67*(tguess_2-273.15)) / (tguess_2-29.66) ) - smixr2 = ( 0.622*svpr2 ) / ( (pres/100.0)-svpr2 ) + ! Hydrometeor extinction coefficient + ! For now, lump graupel in with rain + ! ------------------------------------------------------------------- + ! Update: GAC 20131213 Our test results with surface cloud and ice + ! are very unfavorable. Model doesn't do a great job handling clouds + ! at the model surface. Therefore, we will not trust surface + ! cloud water/ice. (Commented out below). + ! ------------------------------------------------------------------- + !br=2.240*qrain(i,j)**0.75 + !bs=10.36*qsnow(i,j)**0.78 + !bc=144.7*qcloud(i,j)**0.88 + !bi=327.8*qice(i,j) + !hydro_extcoeff=bc+br+bi+bs + !br=2.240*(qrain(i,j)+qgrpl(i,j))**0.75 + !bs=10.36*(qsnow(i,j)*rho(i,j))**0.78 + ! Update: moisture variables should be in mass concentration (g m^-3) + br=1.1*(1000.*rho(i,j)*(qrain(i,j)+qgrpl(i,j)))**0.75 + bs=10.36*(1000.*rho(i,j)*qsnow(i,j))**0.78 + hydro_extcoeff=(br+bs)/1000. ! m^-1 - ! ------------------------------------------------------------------ ~! - !~ When this function was orinially written, the final parcel ~! - !~ temperature check was based off of the parcel temperature and ~! - !~ not the theta-e it produced. As there are multiple temperature- ~! - !~ mixing ratio combinations that can produce a single theta-e value, ~! - !~ we change the check to be based off of the resultant theta-e ~! - !~ value. This seems to be the most accurate way of backing out ~! - !~ temperature from theta-e. ~! - !~ ~! - !~ Rentschler, April 2010 ~! - ! ------------------------------------------------------------------ ! + ! Dust extinction coefficient + ! --------------------------- + dust_extcoeff=0. + DO d=1,ndust + dust_extcoeff=dust_extcoeff+dustfact(d)*dustc(i,j,d) + ENDDO - !~ Old way... - !thetaK = thetaeK / EXP (lv * smixr /(cp*tparcel) ) - !tcheck = thetaK * tovtheta + ! UPDATE: GAC 20131213 Old algorithm commented out below + !! Visibility due to haze obscuration + !! ------------------------------------------------------- + !vis_haze=1500.*(105.-rh2m(i,j)+wind10m(i,j)) + ! + !! Calculate total visibility + !! Take minimum visibility from hydro/lithometeors and haze + !! Define maximum visibility as 20 km (UPDATE: 999.999 km) + !! -------------------------------------------------------- + !extcoeff=hydro_extcoeff+dust_extcoeff + !IF (extcoeff .gt. 0.) THEN + ! vis(i,j)=MIN(visfactor/extcoeff,vis_haze) + !ELSE + ! vis(i,j)=999999. + !ENDIF + + ! Update: GAC 20131213 New haze/fog visibility algorithm + ! Start with relative humidity predictor. Increase + ! predicted visibility as mixing ratio decreases (as + ! there is less water to condense). + ! ------------------------------------------------------- + vis_haze=999999. + IF (q2m(i,j) .gt. 0.) THEN + !vis_haze=1500.*(105.-rh2m(i,j))*(15./(1000.*q2m(i,j))) + vis_haze=1500.*(105.-rh2m(i,j))*(5./min(1000.*q2m(i,j),5.)) + ENDIF + + ! Calculate a Weibull function "alpha" term. This can be + ! used later with visibility (which acts as the "beta" term + ! in the Weibull function) to create a probability distribution + ! for visibility. Alpha can be thought of as the "level of + ! certainty" that beta (model visibility) is correct. Fog is + ! notoriously difficult to model. In the below algorithm, + ! the alpha value (certainty) decreases as PWAT, mixing ratio, + ! or winds decrease (possibly foggy conditions), but increases + ! if RH decreases (more certainly not foggy). If PWAT is lower + ! then there is a higher chance of radiation fog because there + ! is less insulating cloud above. + ! ------------------------------------------------------------- + alpha_haze=3.6 + IF (q2m(i,j) .gt. 0.) THEN + alpha_haze=0.1 + pwater(i,j)/25. + wind125m(i,j)/3. + & + (100.-rh2m(i,j))/10. + 1./(1000.*q2m(i,j)) + alpha_haze=min(alpha_haze,3.6) + ENDIF + + ! Calculate visibility from hydro/lithometeors + ! Maximum visibility -> 999999 meters + ! -------------------------------------------- + extcoeff=hydro_extcoeff+dust_extcoeff + IF (extcoeff .gt. 0.) THEN + vis_hydlith=min(visfactor/extcoeff, 999999.) + ELSE + vis_hydlith=999999. + ENDIF - !~ New way - thetae_check = Thetae ( tparcel, pres/100., 100., smixr ) - thetae_check2 = Thetae ( tguess_2, pres/100., 100., smixr2 ) + ! Calculate total visibility + ! Take minimum visibility from hydro/lithometeors and haze + ! Set alpha to be alpha_haze if haze dominates, or 3.6 + ! (a Guassian distribution) when hydro/lithometeors dominate + ! ---------------------------------------------------------- + IF (vis_hydlith < vis_haze) THEN + vis(i,j)=vis_hydlith + vis_alpha(i,j)=3.6 + ELSE + vis(i,j)=vis_haze + vis_alpha(i,j)=alpha_haze + ENDIF - !~ Whew doggies - that there is some accuracy... - !IF ( ABS (tparcel-tcheck) < .05) THEN - IF ( ABS (thetaeK-thetae_check) < .001) THEN - found = .true. - flag = .true. - EXIT - END IF + ! Calculate dust visibility + ! Again, define maximum visibility as 20 km + ! ----------------------------------------- + IF (dust_extcoeff .gt. 0.) THEN + vis_dust(i,j)=MIN(visfactor/dust_extcoeff,999999.) + ELSE + vis_dust(i,j)=999999. + ENDIF + ENDDO + ENDDO - !~ Old - !tparcel = tparcel + (tcheck - tparcel)*.3 + END SUBROUTINE vis_diagnostics + + - !~ New - correction = ( thetaeK-thetae_check ) / ( thetae_check2-thetae_check ) - tparcel = tparcel + correction + SUBROUTINE cloud_diagnostics (qcloud & + , qice & + , qsnow & + , rh & + , dz8w & + , rho & + , z & + , ht & + , cloud & + , cloud_ceil & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) - iter = iter + 1 - END DO + INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe - IF ( .not. found ) THEN - print*, "Warning! Thetae to temperature calculation did not converge!" - print*, "Thetae ", thetaeK, "Pressure ", pres - END IF + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: qcloud & + , qice & + , qsnow & + , rh & + , dz8w & + , rho & + , z - END FUNCTION The2T + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: ht + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT( OUT) :: cloud & + , cloud_ceil + + ! Local + ! ----- + INTEGER :: i, j, k + REAL :: tot_cld_cond, maxrh, cld_frm_cnd, cld_frm_rh, z_maxrh + REAL :: snow_extcoeff, vis_snow, cloud_lo, zagl_up, zagl_lo + REAL, PARAMETER :: min_ceil = 125. ! Minimum ceiling of 125 m + ! Calculate cloud cover based on total cloud condensate, or if none + ! present, from maximum relative humidity in the column. + ! ----------------------------------------------------------------- + DO i=ims,ime + DO j=jms,jme + ! Initialize some key variables + ! ----------------------------- + tot_cld_cond = 0. + cloud(i,j) = 0. + maxrh = -9999. + cloud_ceil(i,j) = -9999. + cloud_lo = 0. - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - !~ - !~ Name: - !~ VirtualTemperature - !~ - !~ Description: - !~ This function returns virtual temperature given temperature ( K ) - !~ and mixing ratio. - !~ - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - FUNCTION VirtualTemperature ( tK, w ) result ( Tv ) - IMPLICIT NONE + ! Now go up the column to find our cloud base + ! ------------------------------------------- + DO k=kms,kme - !~ Variable declaration - real, intent ( in ) :: tK !~ Temperature - real, intent ( in ) :: w !~ Mixing ratio ( kg kg^-1 ) - real :: Tv !~ Virtual temperature + ! Total cloud condensate + ! Don't trust modeled cloud below 125 m. We + ! let the alpha curve determine probabilities + ! below 125 m... + ! --------------------------------------------- + IF ( z(i,k,j) - ht (i,j) .gt. min_ceil ) THEN + + ! Maximum column relative humidity + ! -------------------------------- + IF (rh (i,k,j) .gt. maxrh) THEN + maxrh = rh (i,k,j) + z_maxrh = z(i,k,j) + ENDIF - Tv = tK * ( 1.0 + (w/0.622) ) / ( 1.0 + w ) +! ! Cloud cover parameterization. Take maximum value +! ! from condensate and relative humidity terms. +! ! ------------------------------------------------ +! tot_cld_cond = tot_cld_cond + (qcloud (i,k,j) + qice (i,k,j) & +! + qsnow (i,k,j)) * dz8w (i,k,j) * rho(i,k,j) +! cld_frm_cnd = 50. * tot_cld_cond +! cld_frm_rh = MAX(((maxrh - 70.) / 30.),0.) +! cloud (i,j) = MAX(cld_frm_cnd,cld_frm_rh) + + ! Calculate cloud cover beta value by summing + ! relative humidity above 70% as we go up the + ! column. Assume a higher probability of a + ! cloud if we have an accumulation of high + ! relative humidity over a typical cloud + ! depth of 500m. (Note dz8w is distance + ! between full eta levels. Note also that rh + ! is derived from the sum of qvapor, qcloud, + ! and qcloud, with a maximum of 100%). + ! ------------------------------------------- + cld_frm_rh = MAX(((rh (i,k,j) - 90.) / 10.),0.) + cloud (i,j) = cloud (i,j) + ( cld_frm_rh * dz8w (i,k,j) ) / 250. + + ! Calculate cloud ceiling, the level at which + ! parameterization of cloud cover exceeds 80% + ! Once we exceed the 80% threshold, we will + ! interpolate downward to find the ceiling. + ! If this is the lowest level, then we will + ! simply set ceiling to that level. After + ! we interpolate, if ceiling is below the + ! minimum we trust, we set it to the minimum. + ! ------------------------------------------- + IF ( cloud_ceil (i,j) .eq. -9999. .and. cloud (i,j) .gt. 0.8 ) THEN + zagl_up = z (i,k,j) - ht (i,j) + IF ( k .EQ. kps ) THEN + cloud_ceil (i,j) = zagl_up + ELSE + zagl_lo = z (i,k-1,j) - ht (i,j) + cloud_ceil (i,j) = zagl_lo + & + ((0.8 - cloud_lo) / & + (cloud (i,j) - cloud_lo)) * & + (zagl_up - zagl_lo) + cloud_ceil (i,j) = MAX(cloud_ceil (i,j),ceil_min) + ENDIF + ENDIF + + ! Save cloud amount here to use for interpolation + ! ----------------------------------------------- + cloud_lo=cloud(i,j) + ENDIF + ENDDO - END FUNCTION VirtualTemperature + ! If we did not encounter any definitive cloud earlier, we set + ! cloud ceiling to the level of maximum relative humidity. (If + ! there is any cloud, this is our best guess as to where it + ! will reside in the vertical). Height is AGL. + ! ------------------------------------------------------------ + IF (cloud_ceil (i,j) .eq. -9999.) THEN + cloud_ceil (i,j) = z_maxrh - ht (i,j) + ENDIF + ! Compare cloud ceiling to surface visibility reduction due to snow + ! Note difference from horizontal visibility algorithm for snow + ! ----------------------------------------------------------------- + IF (qsnow (i,1,j) .GT. 0. .AND. rho (i,1,j) .GT. 0.) THEN + snow_extcoeff = 25. * (1000. * rho(i,1,j) * qsnow (i,1,j))**0.78 + snow_extcoeff = snow_extcoeff / 1000. + vis_snow = 3.912 / snow_extcoeff + IF (vis_snow .LT. cloud_ceil (i,j)) cloud_ceil (i,j) = vis_snow + ENDIF + ENDDO + ENDDO + END SUBROUTINE cloud_diagnostics - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - !~ - !~ Name: - !~ SaturationMixingRatio - !~ - !~ Description: - !~ This function calculates saturation mixing ratio given the - !~ temperature ( K ) and the ambient pressure ( Pa ). Uses - !~ approximation of saturation vapor pressure. - !~ - !~ References: - !~ Bolton (1980), Monthly Weather Review, pg. 1047, Eq. 10 - !~ - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - FUNCTION SaturationMixingRatio ( tK, p ) result ( ws ) - IMPLICIT NONE - REAL, INTENT ( IN ) :: tK - REAL, INTENT ( IN ) :: p - REAL :: ws + SUBROUTINE thermal_diagnostics ( t2 & + , psfc & + , rh2m & + , wind10m & + , heatidx & + , wchill & + , fits & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) - REAL :: es + INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe - es = 6.122 * exp ( (17.67*(tK-273.15))/ (tK-29.66) ) - ws = ( 0.622*es ) / ( (p/100.0)-es ) + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN ) :: t2 & + , psfc & + , rh2m & + , wind10m - END FUNCTION SaturationMixingRatio + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT( OUT) :: heatidx & + , wchill & + , fits + ! Local + ! ----- + INTEGER :: i, j + DO i=ims,ime + DO j=jms,jme + + ! Heat Index + ! ---------- + heatidx ( i, j ) = calc_hi ( t2 ( i, j ) & + , rh2m ( i, j ) ) + + ! Wind Chill + ! ---------- + wchill ( i, j ) = calc_wc ( t2 ( i, j ) & + , wind10m ( i, j ) ) + + ! Fighter Index of Thermal Stress + ! ------------------------------- + fits ( i, j ) = calc_fits ( psfc ( i, j ) & + , t2 ( i, j ) & + , rh2m ( i, j ) ) - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - !~ - !~ Name: - !~ tlcl - !~ - !~ Description: - !~ This function calculates the temperature of a parcel of air would have - !~ if lifed dry adiabatically to it's lifting condensation level (lcl). - !~ - !~ References: - !~ Bolton (1980), Monthly Weather Review, pg. 1048, Eq. 22 - !~ - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - FUNCTION TLCL ( tk, rh ) - - IMPLICIT NONE - - REAL, INTENT ( IN ) :: tK !~ Temperature ( K ) - REAL, INTENT ( IN ) :: rh !~ Relative Humidity ( % ) - REAL :: tlcl - - REAL :: denom, term1, term2 + ENDDO + ENDDO - term1 = 1.0 / ( tK - 55.0 ) - IF ( rh > REAL (0) ) THEN - term2 = ( LOG (rh/100.0) / 2840.0 ) - ELSE - term2 = ( LOG (0.001/1.0) / 2840.0 ) - END IF - denom = term1 - term2 - tlcl = ( 1.0 / denom ) + REAL ( 55 ) + END SUBROUTINE thermal_diagnostics - END FUNCTION TLCL + SUBROUTINE turbulence_diagnostics ( u_phy & + , v_phy & + , t_phy & + , p & + , zagl & + , defor11 & + , defor12 & + , defor22 & + , turb & + , llturb & + , llturblgt & + , llturbmdt & + , llturbsvr & + , nlyrs & + , lyrbot & + , lyrtop & + , ids, ide, jds, jde, kds, kde & + , ims, ime, jms, jme, kms, kme & + , ips, ipe, jps, jpe, kps, kpe ) - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - !~ ~! - !~ Name: ~! - !~ Buoyancy ~! - !~ ~! - !~ Description: ~! - !~ This function computes Convective Available Potential Energy (CAPE) ~! - !~ with inhibition as a result of water loading given the data required ~! - !~ to run up a sounding. ~! - !~ ~! - !~ Additionally, since we are running up a sounding anyways, this ~! - !~ function returns the height of the Level of Free Convection (LFC) and ~! - !~ the pressure at the LFC. That-a-ways, we don't have to run up a ~! - !~ sounding later, saving a relatively computationally expensive ~! - !~ routine. ~! - !~ ~! - !~ Usage: ~! - !~ ostat = Buoyancy ( tK, rh, p, hgt, sfc, CAPE, ZLFC, PLFC, parcel ) ~! - !~ ~! - !~ Where: ~! - !~ ~! - !~ IN ~! - !~ -- ~! - !~ tK = Temperature ( K ) ~! - !~ rh = Relative Humidity ( % ) ~! - !~ p = Pressure ( Pa ) ~! - !~ hgt = Geopotential heights ( m ) ~! - !~ sfc = integer rank within submitted arrays that represents the ~! - !~ surface ~! - !~ ~! - !~ OUT ~! - !~ --- ~! - !~ ostat INTEGER return status. Nonzero is bad. ~! - !~ CAPE ( J/kg ) Convective Available Potential Energy ~! - !~ ZLFC ( gpm ) Height at the LFC ~! - !~ PLFC ( Pa ) Pressure at the LFC ~! - !~ ~! - !~ tK, rh, p, and hgt are all REAL arrays, arranged from lower levels ~! - !~ to higher levels. ~! - !~ ~! - !!!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!! - FUNCTION Buoyancy ( nz, tk, rh, p, hgt, sfc, cape, zlfc, plfc, parcel ) & - result (ostat) - - IMPLICIT NONE - - INTEGER, INTENT ( IN ) :: nz !~ Number of vertical levels - INTEGER, INTENT ( IN ) :: sfc !~ Surface level in the profile - REAL, INTENT ( IN ) :: tk ( nz ) !~ Temperature profile ( K ) - REAL, INTENT ( IN ) :: rh ( nz ) !~ Relative Humidity profile ( % ) - REAL, INTENT ( IN ) :: p ( nz ) !~ Pressure profile ( Pa ) - REAL, INTENT ( IN ) :: hgt ( nz ) !~ Height profile ( gpm ) - REAL, INTENT ( OUT ) :: cape !~ CAPE ( J kg^-1 ) - REAL, INTENT ( OUT ) :: zlfc !~ LFC Height ( gpm ) - REAL, INTENT ( OUT ) :: plfc !~ LFC Pressure ( Pa ) - INTEGER :: ostat !~ Function return status - !~ Nonzero is bad. + INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe - INTEGER, INTENT ( IN ) :: parcel !~ Most Unstable = 1 (default) - !~ Mean layer = 2 - !~ Surface based = 3 - - !~ Derived profile variables - ! ------------------------- - REAL :: ws ( nz ) !~ Saturation mixing ratio - REAL :: w ( nz ) !~ Mixing ratio - REAL :: buoy ( nz ) !~ Buoyancy - REAL :: tlclK !~ LCL temperature ( K ) - REAL :: plcl !~ LCL pressure ( Pa ) - REAL :: nbuoy !~ Negative buoyancy - REAL :: pbuoy !~ Positive buoyancy - - !~ Source parcel information - ! ------------------------- - REAL :: srctK !~ Source parcel temperature ( K ) - REAL :: srcrh !~ Source parcel rh ( % ) - REAL :: srcws !~ Source parcel sat. mixing ratio - REAL :: srcw !~ Source parcel mixing ratio - REAL :: srcp !~ Source parcel pressure ( Pa ) - REAL :: srctheta !~ Source parcel theta ( K ) - REAL :: srcthetaeK !~ Source parcel theta-e ( K ) - INTEGER :: srclev !~ Level of the source parcel - INTEGER :: sfcoff !~ Surface offset - REAL :: spdiff !~ Pressure difference - - !~ Parcel variables - ! ---------------- - REAL :: ptK !~ Parcel temperature ( K ) - REAL :: ptvK !~ Parcel virtual temperature ( K ) - REAL :: tvK !~ Ambient virtual temperature ( K ) - REAL :: pw !~ Parcel mixing ratio - - !~ Other utility variables - ! ----------------------- - INTEGER :: i, j, k !~ Dummy iterator - INTEGER :: lfclev !~ Level of LFC - INTEGER :: prcl !~ Internal parcel type indicator - INTEGER :: mlev !~ Level for ML calculation - INTEGER :: lyrcnt !~ Number of layers in mean layer - LOGICAL :: flag !~ Dummy flag - LOGICAL :: wflag !~ Saturation flag - REAL :: freeze !~ Water loading multiplier - REAL :: CIN !~ Convective inhibition - REAL :: pdiff !~ Pressure difference between levs - - !~ Thermo / dynamical constants - ! ---------------------------- - REAL :: Rd !~ Dry gas constant - PARAMETER ( Rd = 287.058 ) !~ J deg^-1 kg^-1 - REAL :: Cp !~ Specific heat constant pressure - PARAMETER ( Cp = 1004.67 ) !~ J deg^-1 kg^-1 - REAL :: g !~ Acceleration due to gravity - PARAMETER ( g = 9.80665 ) !~ m s^-2 - REAL :: RUNDEF - PARAMETER ( RUNDEF = -9.999E30 ) - - !~ Initialize variables - ! -------------------- - ostat = 0 - CAPE = REAL ( 0 ) - ZLFC = RUNDEF - PLFC = RUNDEF - - !~ Look for submitted parcel definition - !~ 1 = Most unstable - !~ 2 = Mean layer - !~ 3 = Surface based - ! ------------------------------------- - IF ( parcel > 3 .or. parcel < 1 ) THEN - !WRITE( *,* ) ' WARNING: User submitted parcel not valid.' - !WRITE( *,* ) ' Defaulting to MU parcel.' - !return - prcl = 1 - ELSE - prcl = parcel - END IF - - !~ Initalize our parcel to be (sort of) surface based. Because of - !~ issues we've been observing in the WRF model, specifically with - !~ excessive surface moisture values at the surface, using a true - !~ surface based parcel is resulting a more unstable environment - !~ than is actually occuring. To address this, our surface parcel - !~ is now going to be defined as the parcel between 25-50 hPa - !~ above the surface. - ! ---------------------------------------------------------------- - - !~ Compute mixing ratio values for the layer - ! ----------------------------------------- - DO k = sfc, nz - ws ( k ) = SaturationMixingRatio ( tK(k), p(k) ) - w ( k ) = ( rh(k)/100.0 ) * ws ( k ) - END DO - - sfcoff=0 - DO k = 2, nz - spdiff = ( p (1) - p (k) ) / REAL ( 100 ) - IF ( spdiff >= 25. .and. spdiff <= 50. ) THEN - sfcoff = ( k - 1 ) + INTEGER, INTENT(IN) :: nlyrs + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: u_phy & + , v_phy & + , t_phy & + , p & + , zagl & + , defor11 & + , defor12 & + , defor22 + + REAL, DIMENSION( nlyrs ), & + INTENT(IN ) :: lyrtop & + , lyrbot + + REAL, DIMENSION( ims:ime, nlyrs, jms:jme ), & + INTENT( OUT) :: turb + + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT( OUT) :: llturb & + , llturblgt & + , llturbmdt & + , llturbsvr + + ! Local + ! ----- + INTEGER :: i, j, k, n, bot, top, nlayer + + REAL :: ugrdtop & + , ugrdbot & + , vgrdtop & + , vgrdbot & + , defor11top & + , defor11bot & + , defor12top & + , defor12bot & + , defor22top & + , defor22bot + + REAL, DIMENSION( kms:kme ) :: this_zagl & + , this_tK & + , this_p & + , this_u & + , this_v + + REAL :: wind, therm, mtn_wave, tpd_wave + + !~ Initialize variables. + ! ---------------------- + turb = REAL ( 0 ) + llturb = REAL ( 0 ) + llturblgt = REAL ( 0 ) + llturbsvr = REAL ( 0 ) + + !~ Loop through the grid. + ! ---------------------- + DO i=ims,ime + DO j=jms,jme + + !~ Loop through the turbulence layers + ! ---------------------------------- + DO n = 1, nlyrs + + !~ Interpolate relevent variables to turbulence layers + ! --------------------------------------------------- + ugrdtop = lin_interp ( zagl ( i, kms:kme-1, j ) & + , u_phy ( i, kms:kme-1, j ) & + , lyrtop ( n ) ) + ugrdbot = lin_interp ( zagl ( i, kms:kme-1, j ) & + , u_phy ( i, kms:kme-1, j ) & + , lyrbot ( n ) ) + vgrdtop = lin_interp ( zagl ( i, kms:kme-1, j ) & + , v_phy ( i, kms:kme-1, j ) & + , lyrtop ( n ) ) + vgrdbot = lin_interp ( zagl ( i, kms:kme-1, j ) & + , v_phy ( i, kms:kme-1, j ) & + , lyrbot ( n ) ) + defor11top = lin_interp ( zagl ( i, kms:kme-1, j ) & + , defor11 ( i, kms:kme-1, j ) & + , lyrtop ( n ) ) + defor11bot = lin_interp ( zagl ( i, kms:kme-1, j ) & + , defor11 ( i, kms:kme-1, j ) & + , lyrbot ( n ) ) + defor12top = lin_interp ( zagl ( i, kms:kme-1, j ) & + , defor12 ( i, kms:kme-1, j ) & + , lyrtop ( n ) ) + defor12bot = lin_interp ( zagl ( i, kms:kme-1, j ) & + , defor12 ( i, kms:kme-1, j ) & + , lyrbot ( n ) ) + defor22top = lin_interp ( zagl ( i, kms:kme-1, j ) & + , defor22 ( i, kms:kme-1, j ) & + , lyrtop ( n ) ) + defor22bot = lin_interp ( zagl ( i, kms:kme-1, j ) & + , defor22 ( i, kms:kme-1, j ) & + , lyrbot ( n ) ) + + !~ Compute Knapp-Ellrod clear air turbulence + ! ----------------------------------------- + turb ( i, n, j ) = CATTurbulence ( ugrdbot & + , ugrdtop & + , vgrdbot & + , vgrdtop & + , defor11bot & + , defor11top & + , defor12bot & + , defor12top & + , defor22bot & + , defor22top & + , lyrbot (n) & + , lyrtop (n) ) + + ENDDO + + !~ Get top and bottom index of 0-1500 m AGL layer + ! ---------------------------------------------- + bot = kms + top = kms + DO k=kms+1,kme + IF ( zagl ( i, k, j ) .gt. 1500. ) THEN + top = k EXIT - END IF - END DO - - sfcoff = 0 ! This negates the 25-50 hPa work-around above - - srclev = sfc+sfcoff - srctK = tK ( sfc+sfcoff ) - srcrh = rh ( sfc+sfcoff ) - srcp = p ( sfc+sfcoff ) - srcws = ws ( sfc+sfcoff ) - srcw = w ( sfc+sfcoff ) - srctheta = Theta ( tK(sfc+sfcoff), p(sfc+sfcoff)/100.0 ) - - !~ Compute the profile mixing ratio. If the parcel is the MU parcel, - !~ define our parcel to be the most unstable parcel below 700 hPa - ! ------------------------------------------------------------------- - mlev = sfc + 1 - DO k = sfc + 1, nz - - !~ Identify the last layer within 100 hPa of the surface - ! ----------------------------------------------------- - pdiff = ( p (k) - p (sfc) ) / REAL ( 100 ) - IF ( pdiff <= REAL (100) ) mlev = k - - IF ( prcl == 1 ) THEN - IF ( (p(k) > 70000.0) .and. (w(k) > srcw) ) THEN - srctheta = Theta ( tK(k), p(k)/100.0 ) - srcw = w ( k ) - srclev = k - srctK = tK ( k ) - srcrh = rh ( k ) - srcp = p ( k ) - END IF - END IF - - END DO - - !~ If we want the mean layer parcel, compute the mean values in the - !~ lowest 100 hPa. - ! ---------------------------------------------------------------- - lyrcnt = mlev - sfc + 1 - IF ( prcl == 2 ) THEN - - srclev = sfc - srctK = SUM ( tK (sfc:mlev) ) / REAL ( lyrcnt ) - srcw = SUM ( w (sfc:mlev) ) / REAL ( lyrcnt ) - srcrh = SUM ( rh (sfc:mlev) ) / REAL ( lyrcnt ) - srcp = SUM ( p (sfc:mlev) ) / REAL ( lyrcnt ) - srctheta = Theta ( srctK, srcp/100. ) - - END IF - - !~ Chirp status as necessary. - ! -------------------------- - ! WRITE ( *,* ) '' - ! WRITE ( *,* ) ' ==================================== ' - ! WRITE ( *,* ) ' Now in Buoyancy ' - ! WRITE ( *,* ) '' - ! WRITE ( *,* ) ' User submitted data: ' - ! WRITE ( *,'(a,I7)' ) ' Number of vertical levels: ', nz - ! WRITE ( *,'(6A12)' ) 'Level', 'Temp', 'RH', 'Pres', 'Hgt', 'MixRat' - ! DO i = 1, nz - ! WRITE ( *,'(i12,5f12.3)' ) i, tK ( i ), rh ( i ) & - ! , p ( i )/REAL ( 100 ), hgt ( i ), w ( i )*REAL ( 1000 ) - ! END DO - ! WRITE ( *,* ) ' Surface level: ', sfc - ! WRITE ( *,* ) '' - - srcthetaeK = Thetae ( srctK, srcp/100.0, srcrh, srcw ) - - !~ Chirp status again - ! ------------------ - ! 10 FORMAT ( A15,F12.3,A8 ) - ! WRITE ( *,* ) 'Source parcel values: ' - ! WRITE ( *,'(A15,I8)' ) ' Source parcel level: ', srclev - ! WRITE ( *,FMT=10 ) ' Mixing Ratio:', srcw * REAL ( 1000 ), 'g/kg' - ! WRITE ( *,FMT=10 ) ' Temperature:', srctK, 'K' - ! WRITE ( *,FMT=10 ) ' RH:',srcrh, '%' - ! WRITE ( *,FMT=10 ) ' Pressure:', srcp/REAL (100), 'hPa' - ! WRITE ( *,FMT=10 ) ' Theta-E:', srcthetaeK, 'K' - ! WRITE ( *,* ) '' - - - !~ Calculate temperature and pressure of the LCL - ! --------------------------------------------- - tlclK = TLCL ( tK(srclev), rh(srclev) ) - plcl = p(srclev) * ( (tlclK/tK(srclev))**(Cp/Rd) ) - - !~ Chirp - ! ----- - ! WRITE ( *,* ) ' LCL Temperature: ', tlclK - ! WRITE ( *,* ) ' LCL Pressure: ', plcl / REAL ( 100 ) - ! WRITE ( *,* ) '' - ! WRITE ( *,* ) ' Now lifting parcel...' - ! WRITE ( *,'(7A15)') 'Level', 'Pressure', 'Parcel Tmp', 'Parcel Mixr' & - ! , 'Parcel Tv', 'Ambient Tv', 'Buoyancy' - - - buoy = REAL ( 0 ) - pw = srcw - wflag = .false. - DO k = srclev, nz - IF ( tK (k) < 253.15 ) EXIT - IF ( p (k) <= plcl ) THEN - - !~ The first level after we pass the LCL, we're still going to - !~ lift the parcel dry adiabatically, as we haven't added the - !~ the required code to switch between the dry adiabatic and moist - !~ adiabatic cooling. Since the dry version results in a greater - !~ temperature loss, doing that for the first step so we don't over - !~ guesstimate the instability. - ! ---------------------------------------------------------------- - - IF ( wflag ) THEN - flag = .false. - - !~ Above the LCL, our parcel is now undergoing moist adiabatic - !~ cooling. Because of the latent heating being undergone as - !~ the parcel rises above the LFC, must iterative solve for the - !~ parcel temperature using equivalant potential temperature, - !~ which is conserved during both dry adiabatic and - !~ pseudoadiabatic displacements. - ! -------------------------------------------------------------- - ptK = The2T ( srcthetaeK, p(k), flag ) - - !~ Calculate the parcel mixing ratio, which is now changing - !~ as we condense moisture out of the parcel, and is equivalent - !~ to the saturation mixing ratio, since we are, in theory, at - !~ saturation. - ! ------------------------------------------------------------ - pw = SaturationMixingRatio ( ptK, p(k) ) - - !~ Now we can calculate the virtual temperature of the parcel - !~ and the surrounding environment to assess the buoyancy. - ! ---------------------------------------------------------- - ptvK = VirtualTemperature ( ptK, pw ) - tvK = VirtualTemperature ( tK (k), w (k) ) - - !~ Calculate the buoyancy at the level - ! ----------------------------------- - !buoy ( k ) = g * ( (ptvK - tvK)/tvK ) - - !~ Modification to account for water loading - ! ----------------------------------------- - freeze = 0.033 * ( 263.15 - pTvK ) - IF ( freeze > 1.0 ) freeze = 1.0 - IF ( freeze < 0.0 ) freeze = 0.0 - - !~ Approximate how much of the water vapor has condensed out - !~ of the parcel at this level - ! --------------------------------------------------------- - freeze = freeze * 333700.0 * ( srcw - pw ) / 1005.7 - - pTvK = pTvK - pTvK * ( srcw - pw ) + freeze - buoy ( k ) = g * ( (ptvK - tvK)/tvK ) - - ELSE - - !~ Since the theta remains constant whilst undergoing dry - !~ adiabatic processes, can back out the parcel temperature - !~ from potential temperature below the LCL - ! -------------------------------------------------------- - ptK = srctheta / ( 100000.0/p(k) )**(Rd/Cp) - - !~ Grab the parcel virtual temperture, can use the source - !~ mixing ratio since we are undergoing dry adiabatic cooling - ! ---------------------------------------------------------- - ptvK = VirtualTemperature ( ptK, srcw ) - - !~ Virtual temperature of the environment - ! -------------------------------------- - tvK = VirtualTemperature ( tK (k), w (k) ) - - !~ Buoyancy at this level - ! ---------------------- - buoy ( k ) = g * ( (ptvK - tvK)/tvK ) - - wflag = .true. - - END IF - - ELSE - - !~ Since the theta remains constant whilst undergoing dry - !~ adiabatic processes, can back out the parcel temperature - !~ from potential temperature below the LCL - ! -------------------------------------------------------- - ptK = srctheta / ( 100000.0/p(k) )**(Rd/Cp) - - !~ Grab the parcel virtual temperture, can use the source - !~ mixing ratio since we are undergoing dry adiabatic cooling - ! ---------------------------------------------------------- - ptvK = VirtualTemperature ( ptK, srcw ) - - !~ Virtual temperature of the environment - ! -------------------------------------- - tvK = VirtualTemperature ( tK (k), w (k) ) - - !~ Buoyancy at this level - ! --------------------- - buoy ( k ) = g * ( (ptvK - tvK)/tvK ) - - END IF - - !~ Chirp - ! ----- - ! WRITE ( *,'(I15,6F15.3)' )k,p(k)/100.,ptK,pw*1000.,ptvK,tvK,buoy(k) - - END DO - - !~ Add up the buoyancies, find the LFC - ! ----------------------------------- - flag = .false. - lfclev = -1 - nbuoy = REAL ( 0 ) - pbuoy = REAL ( 0 ) - DO k = sfc + 1, nz - IF ( tK (k) < 253.15 ) EXIT - CAPE = CAPE + MAX ( buoy (k), 0.0 ) * ( hgt (k) - hgt (k-1) ) - CIN = CIN + MIN ( buoy (k), 0.0 ) * ( hgt (k) - hgt (k-1) ) - - !~ If we've already passed the LFC - ! ------------------------------- - IF ( flag .and. buoy (k) > REAL (0) ) THEN - pbuoy = pbuoy + buoy (k) - END IF - - !~ We are buoyant now - passed the LFC - ! ----------------------------------- - IF ( .not. flag .and. buoy (k) > REAL (0) .and. p (k) < plcl ) THEN - flag = .true. - pbuoy = pbuoy + buoy (k) - lfclev = k - END IF - - !~ If we think we've passed the LFC, but encounter a negative layer - !~ start adding it up. - ! ---------------------------------------------------------------- - IF ( flag .and. buoy (k) < REAL (0) ) THEN - nbuoy = nbuoy + buoy (k) + ENDIF + ENDDO + nlayer = top - bot + 1 !~ Number of layers from bottom to top + + !~ Copy current column at this i,j point into working arrays + ! --------------------------------------------------------- + this_zagl = zagl ( i, kms:kme, j ) + this_tK = t_phy ( i, kms:kme, j ) + this_p = p ( i, kms:kme, j ) + this_u = u_phy ( i, kms:kme, j ) + this_v = v_phy ( i, kms:kme, j ) + + !~ Interpolate req'd vars to the 1500 m level + !~ Overwrite the "top" index with these values + ! ------------------------------------------- + this_zagl ( top ) = 1500. + this_tK ( top ) = lin_interp ( zagl ( i, kms:kme-1, j ) & + , t_phy ( i, kms:kme-1, j ) & + , this_zagl (top) ) + this_p ( top ) = lin_interp ( zagl ( i, kms:kme-1, j ) & + , p ( i, kms:kme-1, j ) & + , this_zagl (top) ) + this_u ( top ) = lin_interp ( zagl ( i, kms:kme-1, j ) & + , u_phy ( i, kms:kme-1, j ) & + , this_zagl (top) ) + this_v ( top ) = lin_interp ( zagl ( i, kms:kme-1, j ) & + , v_phy ( i, kms:kme-1, j ) & + , this_zagl (top) ) + + !~ Compute the low level turbulence index (from 0 - 1500 m AGL) + !~ There are four components to this index: a wind speed term, + !~ thermodynamic term, mountain wave term, and trapped wave term. + !~ These terms will utilize the working arrays we have just + !~ defined, using only the portion of the array valid in the + !~ 0-1500 m layer, e.g. this_u (bot:top). + !~ The algorithm itself was developed by: + !~ + !~ Mr. James McCormick + !~ Aviation Hazards Team + !~ Air Force Weather Agency 16WS/WXN + !~ DSN: 271-1689 Comm: (402) 294-1689 + !~ James.McCormick.ctr@offutt.af.mil + ! -------------------------------------------------------------- ! + !~ Step 1: Compute the wind speed term ~! + ! -------------------------------------------------------------- ! + wind = LLT_WindSpeed ( nlayer, this_u (bot:top) & + , this_v (bot:top) ) + + ! -------------------------------------------------------------- ! + !~ Step 2: Compute the thermodynamic term ~! + ! -------------------------------------------------------------- ! + therm = LLT_Thermodynamic ( nlayer, this_tK(bot:top) & + , this_zagl(bot:top) ) + + ! -------------------------------------------------------------- ! + !~ Step 3: Compute the mountain wave term ~! + ! -------------------------------------------------------------- ! + mtn_wave = LLT_MountainWave ( nlayer, terrain_dx, terrain_dy & + , this_u(bot:top), this_v(bot:top) & + , this_tK(bot:top), this_zagl(bot:top) ) + + ! -------------------------------------------------------------- ! + !~ Step 4: Compute the trapped wave term ~! + ! -------------------------------------------------------------- ! + tpd_wave = LLT_TrappedWave ( nlayer, this_u(bot:top) & + , this_v(bot:top), this_p(bot:top) ) + + ! -------------------------------------------------------------- ! + !~ Step 5: Combine the above and arrive at the turbulence index. ~! + ! -------------------------------------------------------------- ! + llturb ( i,j ) = 1.-((1.-wind)*(1.-therm)*(1.-mtn_wave)*(1.-tpd_wave)) + + !~ Compute probabilities of light, moderate, and severe LLT + ! -------------------------------------------------------- + llturblgt ( i,j ) = (((((((llturb (i,j) * REAL (100))-REAL (30)) & + *2.5)*.01)**2)*0.75)*REAL(100)) + IF ( llturb (i,j) < 0.3 ) llturblgt ( i,j ) = REAL ( 0 ) + IF ( llturblgt (i,j) > REAL (90) ) llturblgt ( i,j ) = REAL ( 90 ) + + llturbmdt ( i,j ) = (((((((llturb (i,j) * REAL (100))-REAL (35)) & + *2.22222)*.01)*0.75)**2)*88.88888) + IF ( llturb (i,j) < 0.35 ) llturbmdt ( i,j ) = REAL ( 0 ) + IF ( llturbmdt (i,j) > REAL (70) ) llturbmdt ( i,j ) = REAL ( 70 ) + + llturbsvr ( i,j ) = (((((((llturb (i,j) * REAL (100))-REAL (40)) & + *REAL(2))*.01)*0.5)**2)*REAL(100)) + IF ( llturb (i,j) < 0.40 ) llturbsvr ( i,j ) = REAL ( 0 ) + IF ( llturbsvr (i,j) > REAL (35) ) llturbsvr ( i,j ) = REAL ( 35 ) - !~ If the accumulated negative buoyancy is greater than the - !~ positive buoyancy, then we are capped off. Got to go higher - !~ to find the LFC. Reset positive and negative buoyancy summations - ! ---------------------------------------------------------------- - IF ( ABS (nbuoy) > pbuoy ) THEN - flag = .false. - nbuoy = REAL ( 0 ) - pbuoy = REAL ( 0 ) - lfclev = -1 - END IF - END IF - - END DO - - !~ Assuming the the LFC is at a pressure level for now - ! --------------------------------------------------- - IF ( lfclev > 0 ) THEN - PLFC = p ( lfclev ) - ZLFC = hgt ( lfclev ) - END IF - - IF ( PLFC /= PLFC .OR. PLFC < REAL (0) ) THEN - PLFC = REAL ( -1 ) - ZLFC = REAL ( -1 ) - END IF - - IF ( CAPE /= CAPE ) cape = REAL ( 0 ) - - !~ Chirp - ! ----- - ! WRITE ( *,* ) ' CAPE: ', cape, ' CIN: ', cin - ! WRITE ( *,* ) ' LFC: ', ZLFC, ' PLFC: ', PLFC - ! WRITE ( *,* ) '' - ! WRITE ( *,* ) ' Exiting buoyancy.' - ! WRITE ( *,* ) ' ==================================== ' - ! WRITE ( *,* ) '' - - END FUNCTION Buoyancy + ENDDO + ENDDO + + END SUBROUTINE turbulence_diagnostics END MODULE module_diag_afwa + #endif diff --git a/wrfv2_fire/phys/module_diag_afwa_hail.F b/wrfv2_fire/phys/module_diag_afwa_hail.F new file mode 100644 index 00000000..b67688e4 --- /dev/null +++ b/wrfv2_fire/phys/module_diag_afwa_hail.F @@ -0,0 +1,852 @@ +MODULE module_diag_afwa_hail + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! +!!!! Hailstone driver, adapted from hailstone subroutine in HAILCAST +!!!! Driver designed to be called from the severe_wx_diagnostics +!!!! subroutine within module_afwa_dignostics.F in WRF. +!!!! Inputs: +!!!! 1-d (nz) +!!!! TCA temperature (K) +!!!! h1d height above sea level (m) +!!!! PA total pressure (Pa) +!!!! rho1d density (kg/m3) +!!!! RA vapor mixing ratio (kg/kg) +!!!! qi1d cloud ice mixing ratio (kg/kg) +!!!! qc1d cloud water mixing ratio (kg/kg) +!!!! qr1d rain water mixing ratio (kg/kg) +!!!! qg1d graupel mixing ratio (kg/kg) +!!!! qs1d snow mixing ratio (kg/kg) +!!!! VUU updraft speed at each level (m/s) +!!!! Float +!!!! ht terrain height (m) +!!!! wdur duration of any updraft > 10 m/s within 1 surrounding +!!!! gridpoint +!!!! nz number of vertical levels +!!!! Integer +!!!! graupel_opt microphysics scheme flag (includes afwa_hail_opt info) +!!!! +!!!! Output: +!!!! dhail hail diameter in mm +!!!! 1st-5th rank-ordered hail diameters returned +!!!! +!!!! 13 Aug 2013 .................................Becky Selin AER/AFWA +!!!! adapted from hailstone subroutine in SPC's HAILCAST +!!!! 18 Mar 2014 .................................Becky Selin AER/AFWA +!!!! added variable rime layer density, per Ziegler et al. (1983) +!!!! marked by comments RAS13.5.1 +!!!! 4 Jun 2014 ..................................Becky Selin AER/AFWA +!!!! removed initial embryo size dependency on microphysic scheme +!!!! marked by comments RAS13.7 +!!!! 5 Jun 2014 ..................................Becky Selin AER/AFWA +!!!! used smaller initial embryo sizes +!!!! marked by comments RAS13.7.2 +!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE hailstone_driver ( TCA, h1d, ht, PA, rho1d,& + RA, qi1d,qc1d,qr1d,qs1d,qg1d,ng1d, & + VUU, wdur, & + nz,dhail1,dhail2,dhail3,dhail4, & + dhail5 ) + + IMPLICIT NONE + INTEGER, INTENT(IN) :: nz + + REAL, DIMENSION( nz ), & + INTENT(IN ) :: TCA & ! temperature (K) + , rho1d & + , h1d & + , PA & ! pressure (Pa) + , RA & ! vapor mixing ratio (kg/kg) + , VUU & ! updraft speed (m/s) + , qi1d,qc1d,qr1d & + , qs1d,qg1d,ng1d + + REAL, INTENT(IN ) :: ht & + , wdur + + !Output: 1st-5th rank-ordered hail diameters returned + REAL, INTENT(INOUT) :: dhail1 & ! hail diameter (mm); + , dhail2 & + , dhail3 & + , dhail4 & + , dhail5 + !Local variables + REAL ZBAS, TBAS, WBASP ! height, temp, pressure of cloud base + REAL RBAS ! mix ratio of cloud base + REAL cwitot ! total cloud water, ice mix ratio + INTEGER KBAS ! k of cloud base + REAL ZFZL, TFZL, WFZLP ! height, temp, pressure of embryo start point + REAL RFZL ! mix ratio of embryo start point + INTEGER KFZL ! k of embryo start point + INTEGER nofroze ! keeps track if hailstone has ever been frozen + INTEGER ITIME ! updraft duration (sec) + REAL TAU ! upper time limit of simulation (sec) + REAL g ! gravity (m/s) + REAL r_d ! constant + !hailstone parameters + REAL*8 DD, D ! hail diameter (m) + REAL VT ! terminal velocity (m/s) + REAL V ! actual stone velocity (m/s) + REAL TS ! hailstone temperature (K) + REAL FW ! fraction of stone that is liquid + REAL DENSE ! hailstone density (kg/m3) + INTEGER ITYPE ! wet (2) or dry (1) growth regime + !1-d column arrays of updraft parameters + REAL, DIMENSION( nz ) :: & + RIA, & ! frozen content mix ratio (kg/kg) + RWA ! liquid content mix ratio (kg/kg) + !in-cloud updraft parameters at location of hailstone + REAL P ! in-cloud pressure (Pa) + REAL RS ! in-cloud saturation mixing ratio + REAL RI, RW ! ice, liquid water mix. ratio (kg/kg) + REAL XI, XW ! ice, liquid water conc. (kg/m3 air) + REAL PC ! in-cloud fraction of frozen water + REAL TC ! in-cloud temperature (K) + REAL VU ! in-cloud updraft speed (m/s) + REAL DENSA ! in-cloud updraft density (kg/m3) + REAL Z ! height of hailstone (m) + REAL DELRW ! diff in sat vap. dens. between hail and air (kg/m3) + REAL d02,d05,d10,d15,d20 ! 5 initial embryo sizes + REAL, DIMENSION(5) :: dhails !hail diameters with the 1st-15th %ile of graupel dsd + !used as initial hail embryo size + !mean sub-cloud layer variables + REAL TLAYER,RLAYER,PLAYER ! mean sub-cloud temp, mix ratio, pres + REAL TSUM,RSUM,PSUM ! sub-cloud layer T, R, P sums + REAL LDEPTH ! layer depth + !internal function variables + REAL GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DI + REAL dum + + REAL sec, secdel ! time step, increment in seconds + INTEGER i, j, k, IFOUT, ind(1) + CHARACTER*256 :: message + + ! Increasing internal time step from 1 to 5 seconds does not appear + ! to hinder the final output but does cut down on the processing + ! load by quite a bit according to RAS. -GAC 20150311 + !secdel = 1.0 !0.2 + secdel = 5.0 + g=9.81 + r_d = 287. + +! Upper limit of simulation in seconds + TAU = 3600. + +! Initialize diameters to 0. + DO i=1,5 + dhails(i) = 0. + ENDDO + ITIME = INT(wdur) + + !Determine where graupel is available above the freezing level. + !This is where we'll start our hail embryo on its journey. + !Also find the cloud base for end-of-algorithm purposes. + KBAS=nz + KFZL=nz + DO k=1,nz + cwitot = qi1d(k) + qc1d(k) + RIA(k) = qi1d(k) + qs1d(k) + qg1d(k) + RWA(k) = qc1d(k) + qr1d(k) + IF ((RIA(k) .ge. 0.0001) .and. (TCA(k).lt.273.15) .and. & + (k .lt. KFZL)) THEN + KFZL = k + ENDIF + IF ((cwitot .ge. 1.E-12) .and. (k .lt. KBAS)) THEN + KBAS = k + ENDIF + ENDDO + !QC - our embryo can't start below the cloud base. + IF (KFZL .lt. KBAS) THEN + KFZL = KBAS + ENDIF + + !Pull heights, etc. of these levels out of 1-d arrays. + ZFZL = h1d(KFZL) + TFZL = TCA(KFZL) + WFZLP = PA(KFZL) + RFZL = RA(KFZL) + ZBAS = h1d(KBAS) + TBAS = TCA(KBAS) + WBASP = PA(KBAS) + RBAS = RA(KBAS) + + + !-->RAS13.7 + !!!!!!!!!!!!!!!! 0. INITIAL EMBRYO SIZE !!!!!!!!!!!!!!!!!!!!! + !!! SET CONSTANT RANGE OF INITIAL EMBRYO SIZES !!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + d02 = 1.E-5 !RAS13.7.2 smaller init embryo sizes + d05 = 2.E-5 !RAS13.7.2 smaller init embryo sizes + d10 = 3.E-5 !RAS13.7.2 smaller init embryo sizes + d15 = 4.E-5 !RAS13.7.2 smaller init embryo sizes + d20 = 5.E-5 !RAS13.7.2 smaller init embryo sizes + !<--RAS13.7 + + !Run each initial embryo size perturbation + DO i=1,5 + SELECT CASE (i) + CASE (1) + !Initial hail embryo diameter in m, at cloud base + DD = d02 + CASE (2) + DD = d05 + CASE (3) + DD = d10 + CASE (4) + DD = d15 + CASE (5) + DD = d20 + END SELECT + + !Begin hail simulation time (seconds) + sec = 60 + + !Set initial values for parameters at freezing level + P = WFZLP + RS = RFZL + TC = TFZL + VU = VUU(KFZL) + Z = ZFZL - ht + LDEPTH = Z + DENSA = rho1d(KFZL) + + !Set initial hailstone parameters + nofroze=1 !Set test for embryo: 0 for never been frozen; 1 frozen + TS = TC + D = DD !hailstone diameter in m + FW = 0.0 + DENSE = 500. !kg/m3 !RAS13.5.1 + + !Start time loop. + DO WHILE (sec .lt. TAU) + sec = sec + secdel + + !!!!!!!!!!!!!!!!!! 1. CALCULATE PARAMETERS !!!!!!!!!!!!!!!!! + !!! CALCULATE UPDRAFT PROPERTIES !!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !Intepolate vertical velocity to our new pressure level + CALL INTERP(VUU,VU,P,IFOUT,PA,nz) + + !Outside pressure levels? If so, exit loop + IF (IFOUT.EQ.1) GOTO 100 + + !If simulation time past updraft duration, set updraft + ! speed to zero + IF (sec .gt. ITIME) VU = 0 + + !Calculate terminal velocity of the hailstone + ! (use previous values) + CALL TERMINL(DENSA,DENSE,D,VT,TC) + + !Actual velocity of hailstone (upwards positive) + V = VU - VT + + !Use hydrostatic eq'n to calc height of next level + P = P - DENSA*g*V*secdel + Z = Z + V*secdel + + !Interpolate cloud temp, qvapor at new p-level + CALL INTERP(TCA,TC,P,IFOUT,PA,nz) + CALL INTERP(RA,RS,P,IFOUT,PA,nz) + + !New density of in-cloud air + DENSA=P/(r_d*(1.+0.609*RS/(1.+RS))*TC) + + !Interpolate liquid, frozen water mix ratio at new level + CALL INTERP(RIA,RI,P,IFOUT,PA,nz) + CALL INTERP(RWA,RW,P,IFOUT,PA,nz) + XI = RI * DENSA + XW = RW * DENSA + IF( (XW+XI).GT.0) THEN + PC = XI / (XW+XI) + ELSE + PC = 1. + ENDIF + !IF(TC.GT.253.15)PC=0. + + !!!!!!!!!!!!!!!!!! 2. TEST FOR WET/DRY GROWTH !!!!!!!!!!!!!!! + !!! WET GROWTH - STONE'S SFC >0; DRY GROWTH SFC < 0 !!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !FREEZE THE HAIL EMBRYO AT -8 DEGC, define emb + IF (TS.GE.264.15 .AND. TC.GE.264.15 .AND. NOFROZE.EQ.0) THEN + IF (TC.LE.265.15) THEN !!! DRY GROWTH + FW=0. !set fraction of water in stone to 0. + TS=TC + ITYPE=1 + NOFROZE=1 + ELSE !!! WET GROWTH + FW=1. + TS=TC + ITYPE=2 + NOFROZE=0 + ENDIF + ELSE + IF (TS.LT.273.155) THEN !!! DRY GROWTH + FW=0. + ITYPE=1 + ELSE !!! WET GROWTH + TS=273.155 + ITYPE=2 + ENDIF + ENDIF + + ! DENSITY OF HAILSTONE - DEPENDS ON FW + ! ONLY WATER=1 GM/L=1000KG/M3; ONLY ICE =0.9 GM/L + !DENSE=(FW*0.1+0.9) * 1000. !KG/M3 !RAS13.5.1-density calc inside MASSAGR + + ! SATURATION VAPOUR DENSITY DIFFERENCE BETWTEEN STONE AND CLOUD + CALL VAPORCLOSE(DELRW,PC,TS,TC,ITYPE) + + + !!!!!!!!!!!!!!!!!! 3. STONE'S MASS GROWTH !!!!!!!!!!!!!!!!!!!! + CALL MASSAGR(D,GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DI, & + TC,TS,P,DENSE,FW,VT,XW,XI,secdel,ITYPE) !RAS13.5.1 + + + !!!!!!!!!!!!!!!!!! 4. HEAT BUDGET OF HAILSTONE !!!!!!!!!!!!!!! + CALL HEATBUD(TS,FW,TC,VT,DELRW,D,DENSA,GM1,DGM,DGMW, & + DGMI,GMW,GMI,DI,secdel,ITYPE,P) + + + !!!!! 5. TEST DIAMETER OF STONE AND HEIGHT ABOVE GROUND !!!!!!! + !!! TEST IF DIAMETER OF STONE IS GREATER THAN 9 MM LIMIT, IF SO + !!! BREAK UP + IF(D.GT.0.009) THEN + CALL BREAKUP(DENSE,D,GM,FW) + ENDIF + + !!! Has stone reached below cloud base? + !IF (Z .LE. 0) GOTO 200 + IF (Z .LE. ZBAS) GOTO 200 + + ENDDO !end cloud lifetime loop + +100 CONTINUE !outside pressure levels in model +200 CONTINUE !stone reached surface + + !!!!!!!!!!!!!!!!!! 6. MELT STONE BELOW CLOUD !!!!!!!!!!!!!!!!!!!! + !Did the stone shoot out the top of the storm? + !Then let's assume it's lost in the murky "outside storm" world. + IF (P.lt.PA(nz)) THEN + !print *, ' shot off top!' + D=0.0 + !Is the stone entirely water? Then set D=0 and exit. + ELSE IF(ABS(FW - 1.0).LT.0.001) THEN + !print *, ' stone entirely water!' + D=0.0 + ELSE IF (Z.GT.0) THEN + !If still frozen, then use melt routine to melt below cloud + ! based on mean below-cloud conditions. + + !Calculate mean sub-cloud layer conditions + TSUM = 0. + RSUM = 0. + PSUM = 0. + DO k=1,KBAS + TSUM = TSUM + TCA(k) + PSUM = PSUM + PA(k) + RSUM = RSUM + RA(k) + ENDDO + TLAYER = TSUM / KBAS + PLAYER = PSUM / KBAS + RLAYER = RSUM / KBAS + + CALL MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT) + ENDIF !end check for melting call + + !assign hail size in mm for output + dhails(i) = D * 1000 + + ENDDO !end embryo size loop + + !! Size-sort hail diameters for function output !! + DO j=1,4 + DO k=j+1,5 + IF (dhails(j).lt.dhails(k)) THEN + dum = dhails(j) + dhails(j) = dhails(k) + dhails(k) = dum + ENDIF + ENDDO + ENDDO + + dhail1 = dhails(1) + dhail2 = dhails(2) + dhail3 = dhails(3) + dhail4 = dhails(4) + dhail5 = dhails(5) + + END SUBROUTINE hailstone_driver + + + + SUBROUTINE INTERP(AA,A,P,IFOUT,PA,ITEL) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!! + !!!! INTERP: to linearly interpolate values of A at level P + !!!! between two levels of AA (at levels PA) + !!!! + !!!! INPUT: AA 1D array of variable + !!!! PA 1D array of pressure + !!!! P new pressure level we want to calculate A at + !!!! IFOUT set to 0 if P outside range of PA + !!!! ITEL number of vertical levels + !!!! OUTPUT: A variable at pressure level P + !!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IMPLICIT NONE + + REAL A, P + REAL, DIMENSION( ITEL) :: AA, PA + INTEGER ITEL, IFOUT + !local variables + INTEGER I + REAL PDIFF, VDIFF, RDIFF, VERH, ADIFF + + IFOUT=1 + + DO I=1,ITEL-1 + IF (P.LE.PA(I) .AND. P.GT.PA(I+1)) THEN + !Calculate ratio between vdiff and pdiff + PDIFF = PA(I)-PA(I+1) + VDIFF = PA(I)-P + VERH = VDIFF/PDIFF + + !Calculate the difference between the 2 A values + RDIFF = AA(I+1) - AA(I) + + !Calculate new value + A = AA(I) + RDIFF*VERH + + !End loop + IFOUT=0 + EXIT + ENDIF + ENDDO + + END SUBROUTINE INTERP + + + SUBROUTINE TERMINL(DENSA,DENSE,D,VT,TC) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!!! + !!!! INTERP: Calculate terminal velocity of the hailstone + !!!! + !!!! INPUT: DENSA density of updraft air (kg/m3) + !!!! DENSE density of hailstone + !!!! D diameter of hailstone (m) + !!!! TC updraft temperature (K) + !!!! OUTPUT:VT hailstone terminal velocity (m/s) + !!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IMPLICIT NONE + + REAL*8 D + REAL DENSA, DENSE, TC, VT + REAL GMASS, GX, RE, W, Y + REAL, PARAMETER :: PI = 3.141592654, G = 9.78956 + REAL ANU + + !Mass of stone in kg + GMASS = (DENSE * PI * (D**3.)) / 6. + + !Dynamic viscosity + ANU = (0.00001718)*(273.16+120.)/(TC+120.)*(TC/273.16)**(1.5) + + !CALC THE BEST NUMBER, X AND REYNOLDS NUMBER, RE + GX=(8.0*GMASS*G*DENSA)/(PI*(ANU*ANU)) + RE=(GX/0.6)**0.5 + + !SELECT APPROPRIATE EQUATIONS FOR TERMINAL VELOCITY DEPENDING ON + !THE BEST NUMBER + IF (GX.LT.550) THEN + W=LOG10(GX) + Y= -1.7095 + 1.33438*W - 0.11591*(W**2.0) + RE=10**Y + VT=ANU*RE/(D*DENSA) + ELSE IF (GX.GE.550.AND.GX.LT.1800) THEN + W=LOG10(GX) + Y= -1.81391 + 1.34671*W - 0.12427*(W**2.0) + 0.0063*(W**3.0) + RE=10**Y + VT=ANU*RE/(D*DENSA) + ELSE IF (GX.GE.1800.AND.GX.LT.3.45E08) THEN + RE=0.4487*(GX**0.5536) + VT=ANU*RE/(D*DENSA) + ELSE + RE=(GX/0.6)**0.5 + VT=ANU*RE/(D*DENSA) + ENDIF + + END SUBROUTINE TERMINL + + + SUBROUTINE VAPORCLOSE(DELRW,PC,TS,TC,ITYPE) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!! VAPORCLOSE: CALC THE DIFFERENCE IN SATURATION VAPOUR DENSITY + !!! BETWEEN THAT OVER THE HAILSTONE'S SURFACE AND THE IN-CLOUD + !!! AIR, DEPENDS ON THE WATER/ICE RATIO OF THE UPDRAFT, + !!! AND IF THE STONE IS IN WET OR DRY GROWTH REGIME + !!! + !!! INPUT: PC fraction of updraft water that is frozen + !!! TS temperature of hailstone (K) + !!! TC temperature of updraft air (K) + !!! ITYPE wet (2) or dry (1) growth regime + !!! OUTPUT: DELRW difference in sat vap. dens. between hail and air + !!! (kg/m3) + !!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IMPLICIT NONE + REAL DELRW, PC, TS, TC + INTEGER ITYPE + !local variables + REAL RV, ALV, ALS, RATIO + DATA RV/461.48/,ALV/2500000./,ALS/2836050./ + REAL ESAT, RHOKOR, ESATW, RHOOMGW, ESATI, RHOOMGI, RHOOMG + + !!! FOR HAILSTONE: FIRST TEST IF STONE IS IN WET OR DRY GROWTH + RATIO = 1./273.16 + IF(ITYPE.EQ.2) THEN !!WET GROWTH + ESAT=611.*EXP(ALV/RV*(RATIO-1./TS)) + ELSE !!DRY GROWTH + ESAT=611.*EXP(ALS/RV*(RATIO-1./TS)) + ENDIF + RHOKOR=ESAT/(RV*TS) + + !!! NOW FOR THE AMBIENT/IN-CLOUD CONDITIONS + ESATW=611.*EXP(ALV/RV*(RATIO-1./TC)) + RHOOMGW=ESATW/(RV*TC) + ESATI=611.*EXP(ALS/RV*(RATIO-1./TC)) + RHOOMGI=ESATI/(RV*TC) + RHOOMG=PC*(RHOOMGI-RHOOMGW)+RHOOMGW + + !!! CALC THE DIFFERENCE(KG/M3): <0 FOR CONDENSATION, + !!! >0 FOR EVAPORATION + DELRW=(RHOKOR-RHOOMG) + END SUBROUTINE VAPORCLOSE + + + + SUBROUTINE MASSAGR(D,GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DI, & + TC,TS,P,DENSE,FW,VT,XW,XI,SEKDEL,ITYPE) !RAS13.5.1 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!! CALC THE STONE'S INCREASE IN MASS + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IMPLICIT NONE + REAL*8 D + REAL GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DI, & + TC,TS,P,DENSE,FW,VT,XW,XI,SEKDEL + INTEGER ITYPE !RAS13.5.1 + !local variables + REAL PI, D0, GMW2, GMI2, EW, EI + !-->RAS13.5.1 + REAL DENSEL !DENSITY OF NEW LAYER (KG M-3) + REAL DC !MEAN CLOUD DROPLET DIAMETER (MICRONS, 1E-6M) + REAL VOLL, VOLT !VOLUME OF NEW LAYER, TOTAL (M3) + !<--RAS13.5.1 + PI=3.141592654 + + !!! CALCULATE THE DIFFUSIVITY DI (m2/s) + D0=0.226*1.E-4 ! change to m2/s, not cm2/s + DI=D0*(TC/273.16)**1.81*(100000./P) + + !!! COLLECTION EFFICIENCY FOR WATER AND ICE + EW=1.0 + + !!! IF TS WARMER THAN -5C THEN ACCRETE ALL THE ICE (EI=1.0) + !!! OTHERWISE EI=0.21 + IF(TS.GE.268.15)THEN + EI=1.00 + ELSE + EI=0.21 + ENDIF + + !!! CALC HAILSTONE'S MASS (GM), MASS OF WATER (GMW) AND THE + !!! MASS OF ICE IN THE STONE (GMI) + GM=PI/6.*(D**3.)*DENSE + GMW=FW*GM + GMI=GM-GMW + + !!! STORE THE MASS + GM1=GM + + !-->RAS13.5.1 + !!!!!! ORIGINAL HAILCAST MASS GROWTH CALCULATIONS !!!!!!!!!!!!!!! + !!!!!! STONE'S MASS GROWTH + !!!!!! CALCULATE THE NEW DIAMETER + !!!D=D+SEKDEL*0.5*VT/DENSE*(XW*EW+XI*EI) + !!!!!! CALCULATE THE INCREASE IN MASS DUE INTERCEPTED CLD WATER + !!!GMW2=GMW+SEKDEL*(PI/4.*D**2.*VT*XW*EW) + !!!DGMW=GMW2-GMW + !!!GMW=GMW2 + !!!!!! CALCULATE THE INCREASE IN MASS DUE INTERCEPTED CLOUD ICE + !!!GMI2=GMI+SEKDEL*(PI/4.*D**2.*VT*XI*EI) + !!!DGMI=GMI2-GMI + !!!GMI=GMI2 + !!!!!! CALCULATE THE TOTAL MASS CHANGE + !!!DGM=DGMW+DGMI + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + !!! NEW MASS GROWTH CALCULATIONS WITH VARIABLE RIME + !!! LAYER DENSITY BASED ON ZIEGLER ET AL. (1983) + + !!! CALCULATE INCREASE IN MASS DUE INTERCEPTED CLD WATER, USE + !!! ORIGINAL DIAMETER + GMW2=GMW+SEKDEL*(PI/4.*D**2.*VT*XW*EW) + DGMW=GMW2-GMW + GMW=GMW2 + !!! CALCULATE THE INCREASE IN MASS DUE INTERCEPTED CLOUD ICE + GMI2=GMI+SEKDEL*(PI/4.*D**2.*VT*XI*EI) + DGMI=GMI2-GMI + GMI=GMI2 + !!! CALCULATE THE TOTAL MASS CHANGE + DGM=DGMW+DGMI + !!! CALCULATE DENSITY OF NEW LAYER, DEPENDS ON FW AND ITYPE + IF (ITYPE.EQ.1) THEN !DRY GROWTH + !MEAN CLOUD DROPLET RADIUS, ASSUME CLOUD DROPLET CONC OF 3E8 M-3 (300 CM-3) + DC = (0.74*XW / (PI*1000.*3.E8))**0.33333333 * 1.E6 !MICRONS + !RIME LAYER DENSITY, MACKLIN FORM + DENSEL = 0.11*(DC*VT / (273.15-TS))**0.76 !G CM-3 + DENSEL = DENSEL * 1000. !KG M-3 + !BOUND POSSIBLE DENSITIES + IF (DENSEL.LT.100) DENSEL=100 + IF (DENSEL.GT.900) DENSEL=900 + ELSE !WET GROWTH + DENSEL = 900. !KG M-3 + ENDIF + !!!VOLUME OF NEW LAYER + VOLL = DGM / DENSEL + !!!NEW TOTAL VOLUME, DENSITY, DIAMETER + VOLT = VOLL + GM/DENSE + !VOLT = VOLL + (0.16666667*3.14159*D**3.) + DENSE = (GM+DGM) / VOLT + D=D+SEKDEL*0.5*VT/DENSE*(XW*EW+XI*EI) + !<--RAS13.5.1 + + END SUBROUTINE MASSAGR + + + + SUBROUTINE HEATBUD(TS,FW,TC,VT,DELRW,D,DENSA,GM1,DGM,DGMW, & + DGMI,GMW,GMI,DI,SEKDEL,ITYPE,P) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!! CALCULATE HAILSTONE'S HEAT BUDGET + !!! See Rasmussen and Heymsfield 1987; JAS + !!! The commented lines in here were not using SI units + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IMPLICIT NONE + REAL*8 D + REAL TS,FW,TC,VT,DELRW,DENSA,GM1,DGM,DGMW, & + DGMI,GMW,GMI,DI,SEKDEL,P + INTEGER ITYPE + + REAL RV, RD, G, PI, ALF, ALV, ALS, CI, CW, AK, ANU + REAL H, E, RE, AH, AE, TCC, TSC + DATA RV/461.48/,RD/287.04/,G/9.78956/ + DATA PI/3.141592654/ + DATA ALF/3.50E5/ !latent heat of freezing J/kg /79.7/ + DATA ALV/2.5E6/ !latent heat of vaporization J/kg /597.3/ + DATA ALS/2.85E6/ !latent heat of sublimation J/kg /677.0/ + DATA CI/2093/ !J/(kg*K); 0.5 cal/(g*K) + DATA CW/4187/ !J/(kg*K); 1. cal/(g*K) + + !!! CALCULATE THE CONSTANTS + !AK=(5.8+0.0184*(TC-273.155))*1.E-5 !thermal conductivity - cal/(cm*sec*K) + AK=(5.8+0.0184*(TC-273.155))*1.E-3*4.187 !thermal conductivity - J/(m*sec*K) + !dynamic viscosity kg/(m*s) + ANU=1.717E-5*(393.0/(TC+120.0))*(TC/273.155)**1.5 + + !!! CALCULATE THE REYNOLDS NUMBER - unitless + RE=D*VT*DENSA/ANU + !H=(0.71)**(0.333333333)*(RE**0.50) !ventilation coefficient heat (fh) + !E=(0.60)**(0.333333333)*(RE**0.50) !ventilation coefficient vapor (fv) + H=(1.46E-5/DI)**(0.333333333)*(RE**0.50) !ventilation coefficient heat (fh) + E=(1.46E-5/AK)**(0.333333333)*(RE**0.50) !ventilation coefficient vapor (fv) + !print *, 'HEATBUD function: ' + !print *, ' ITYPE: ', ITYPE + + !!! SELECT APPROPRIATE VALUES OF AH AND AE ACCORDING TO RE + IF(RE.LT.6000.0)THEN + AH=0.78+0.308*H + AE=0.78+0.308*E + ELSEIF(RE.GE.6000.0.AND.RE.LT.20000.0)THEN + AH=0.76*H + AE=0.76*E + ELSEIF(RE.GE.20000.0) THEN + AH=(0.57+9.0E-6*RE)*H + AE=(0.57+9.0E-6*RE)*E + ENDIF + + !!! FOR DRY GROWTH FW=0, CALCULATE NEW TS, ITIPE=1 + !!! FOR WET GROWTH TS=0, CALCULATE NEW FW, ITIPE=2 + + TCC = TC - 273.15 + TSC = TS - 273.15 + IF(ITYPE.EQ.1) THEN + !!! DRY GROWTH; CALC NEW TEMP OF THE STONE + !TS=TS-TS*DGM/GM1+SEKDEL/(GM1*CI)* & + ! (2.*PI*D*(AH*AK*(TC-TS)-AE*ALS*DI*DELRW)+ & + ! DGMW/SEKDEL*(ALF+CW*TC)+DGMI/SEKDEL*CI*TC) + TS=TS-(TS-273.15)*DGM/GM1+SEKDEL/(GM1*CI)* & + (2.*PI*D*(AH*AK*(TC-TS)-AE*ALS*DI*DELRW)+ & + DGMW/SEKDEL*(ALF+CW*TCC)+DGMI/SEKDEL*CI*TCC) + ELSE IF (ITYPE.EQ.2) THEN + !!! WET GROWTH; CALC NEW FW + !FW=FW-FW*DGM/GM1+SEKDEL/(GM1*ALF)* & + ! (PI*D*(AH*AK*TC-AE*ALV*DI*DELRW)+ & + ! DGMW/SEKDEL*(ALF+CW*TC)+DGMI/SEKDEL*CI*TC) + FW=FW-FW*DGM/GM1+SEKDEL/(GM1*ALF)* & + (2.*PI*D*(AH*AK*TCC-AE*ALV*DI*DELRW)+ & + DGMW/SEKDEL*(ALF+CW*TCC)+DGMI/SEKDEL*CI*TCC) + ENDIF + + IF(FW.GT.1.)FW=1. + IF(FW.LT.0.)FW=0. + END SUBROUTINE HEATBUD + + + + SUBROUTINE BREAKUP(DENSE,D,GM,FW) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!! TEST IF AMOUNT OF WATER ON SURFACE EXCEEDS CRTICAL LIMIT- + !!! IF SO INVOKE SHEDDING SCHEME + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + IMPLICIT NONE + REAL*8 D + REAL DENSE, GM, FW + !local variables + REAL WATER, GMI, CRIT, WAT, PI + DATA PI/3.141592654/ + + WATER=FW*GM + GMI=GM-WATER + + ! CALC CRTICAL MASS CAPABLE OF BEING "SUPPORTED" ON THE STONE'S + ! SURFACE + CRIT=0.268+0.1389*GMI + IF (WATER.GT.CRIT)THEN + WAT=WATER-CRIT + GM=GM-WAT + FW=(CRIT)/GM + + IF(FW.GT.1.0) FW=1.0 + IF(FW.LT.0.0) FW=0.0 + + ! RECALCULATE DENSITY AND DIAMETER AFTER SHEDDING + DENSE=(FW*(0.1)+0.9) * 1000. + D=(6.*GM/(PI*DENSE))**(0.333333333) + ENDIF + END SUBROUTINE BREAKUP + + + SUBROUTINE MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !!! This is a spherical hail melting estimate based on the Goyer + !!! et al. (1969) eqn (3). The depth of the warm layer, estimated + !!! terminal velocity, and mean temperature of the warm layer are + !!! used. DRB. 11/17/2003. + !!! + !!! INPUT: TLAYER mean sub-cloud layer temperature (K) + !!! PLAYER mean sub-cloud layer pressure (Pa) + !!! RLAYER mean sub-cloud layer mixing ratio (kg/kg) + !!! VT terminal velocity of stone (m/s) + !!! OUTPUT: D diameter (m) + !!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IMPLICIT NONE + + REAL*8 D + REAL TLAYER, PLAYER, RLAYER, LDEPTH, VT + REAL eenv, delta, ewet, de, der, wetold, wetbulb, wetbulbk + REAL tdclayer, tclayer, eps, b, hplayer + REAL*8 a + REAL sd, lt, ka, lf, lv, t0, dv, pi, rv, rhoice, & + tres, re, delt, esenv, rhosenv, essfc, rhosfc, dsig, & + dmdt, mass, massorg, newmass, gamma, r, rho + INTEGER wcnt + + !Convert temp to Celsius, calculate dewpoint in celsius + tclayer = TLAYER - 273.155 + a = 2.53E11 + b = 5.42E3 + tdclayer = b / LOG(a*eps / (rlayer*player)) + hplayer = player / 100. + + !Calculate partial vapor pressure + eps = 0.622 + eenv = (player*rlayer) / (rlayer+eps) + eenv = eenv / 100. !convert to mb + + !Estimate wet bulb temperature (C) + gamma = 6.6E-4*player + delta = (4098.0*eenv)/((tdclayer+237.7)*(tdclayer+237.7)) + wetbulb = ((gamma*tclayer)+(delta*tdclayer))/(gamma+delta) + + !Iterate to get exact wet bulb + wcnt = 0 + DO WHILE (wcnt .lt. 11) + ewet = 6.108*(exp((17.27*wetbulb)/(237.3 + wetbulb))) + de = (0.0006355*hplayer*(tclayer-wetbulb))-(ewet-eenv) + der= (ewet*(.0091379024 - (6106.396/(273.155+wetbulb)**2))) & + - (0.0006355*hplayer) + wetold = wetbulb + wetbulb = wetbulb - de/der + wcnt = wcnt + 1 + IF ((abs(wetbulb-wetold)/wetbulb.gt.0.0001)) THEN + EXIT + ENDIF + ENDDO + + wetbulbk = wetbulb + 273.155 !convert to K + ka = .02 ! thermal conductivity of air + lf = 3.34e5 ! latent heat of melting/fusion + lv = 2.5e6 ! latent heat of vaporization + t0 = 273.155 ! temp of ice/water melting interface + dv = 0.25e-4 ! diffusivity of water vapor (m2/s) + pi = 3.1415927 + rv = 1004. - 287. ! gas constant for water vapor + rhoice = 917.0 ! density of ice (kg/m**3) + r = D/2. ! radius of stone (m) + + !Compute residence time in warm layer + tres = LDEPTH / VT + + !Calculate dmdt based on eqn (3) of Goyer et al. (1969) + !Reynolds number...from pg 317 of Atmo Physics (Salby 1996) + !Just use the density of air at 850 mb...close enough. + rho = 85000./(287.*TLAYER) + re = rho*r*VT*.01/1.7e-5 + + !Temperature difference between environment and hailstone surface + delt = wetbulb !- 0.0 !assume stone surface is at 0C + !wetbulb is in Celsius + + !Difference in vapor density of air stream and equil vapor + !density at the sfc of the hailstone + esenv = 610.8*(exp((17.27*wetbulb)/ & + (237.3 + wetbulb))) ! es environment in Pa + rhosenv = esenv/(rv*wetbulbk) + essfc = 610.8*(exp((17.27*(t0-273.155))/ & + (237.3 + (t0-273.155)))) ! es environment in Pa + rhosfc = essfc/(rv*t0) + dsig = rhosenv - rhosfc + + !Calculate new mass growth + dmdt = (-1.7*pi*r*(re**0.5)/lf)*((ka*delt)+((lv-lf)*dv*dsig)) + IF (dmdt.gt.0.) dmdt = 0 + mass = dmdt*tres + + !Find the new hailstone diameter + massorg = 1.33333333*pi*r*r*r*rhoice + newmass = massorg + mass + if (newmass.lt.0.0) newmass = 0.0 + D = 2.*(0.75*newmass/(pi*rhoice))**0.333333333 + END SUBROUTINE MELT + +END MODULE module_diag_afwa_hail diff --git a/wrfv2_fire/phys/module_diag_cl.F b/wrfv2_fire/phys/module_diag_cl.F index a05ed0c5..61d7c2d1 100644 --- a/wrfv2_fire/phys/module_diag_cl.F +++ b/wrfv2_fire/phys/module_diag_cl.F @@ -32,6 +32,7 @@ SUBROUTINE clwrf_output_calc( & ,skintempclmean,skintempclstd & ! CLWRF ,raincv,rainncv & ,dt,xtime,curr_secs2 & + ,nsteps & ) !---------------------------------------------------------------------- @@ -106,13 +107,10 @@ SUBROUTINE clwrf_output_calc( & ! LOCAL VAR INTEGER :: i,j,k,its,ite,jts,jte,ij - INTEGER :: idp,jdp,irc,jrc,irnc,jrnc,isnh,jsnh - INTEGER :: prfreq + INTEGER :: idp,jdp REAL :: xtimep LOGICAL, EXTERNAL :: wrf_dm_on_monitor - CHARACTER*256 :: outstring - CHARACTER*6 :: grid_str !!------------------- !! CLWRF-UC Nov.09 @@ -139,7 +137,7 @@ SUBROUTINE clwrf_output_calc( & REAL :: value INTEGER, INTENT(IN) :: clwrfH CHARACTER (LEN=1024) :: message - INTEGER, SAVE :: nsteps + INTEGER, INTENT(INOUT) :: nsteps LOGICAL :: is_restart !----------------------------------------------------------------- @@ -149,93 +147,12 @@ SUBROUTINE clwrf_output_calc( & ! SET START AND END POINTS FOR TILES ! !$OMP PARALLEL DO & ! !$OMP PRIVATE ( ij ) - ! IF ( MOD(NINT(XTIME), clwrfH) == 0 ) THEN - IF (( MOD(NINT(curr_secs2/dt),NINT(clwrfH*60./dt)) == 0) .AND. (.NOT.is_restart)) THEN +! IF (( MOD(NINT(curr_secs2/dt),NINT(clwrfH*60./dt)) == 0) .AND. (.NOT.is_restart)) THEN + IF (( MOD(NINT(curr_secs2/dt),NINT(clwrfH*60./dt)) == 0) ) THEN DO ij = 1 , num_tiles IF ( wrf_dm_on_monitor() ) THEN - WRITE(message, *)'CLWRFdiag - T2; tile: ',ij,' T2clmin:', & - t2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' T2clmax:', & - t2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' TT2clmin:', & - tt2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' TT2clmax:', & - tt2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' T2clmean:', & - t2clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' T2clstd:', & - t2clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2) - CALL wrf_debug(75, message) - WRITE(message, *)'CLWRFdiag - Q2; tile: ',ij,' Q2clmin:', & - q2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' Q2clmax:', & - q2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' TQ2clmin:', & - tq2clmin(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' TQ2clmax:', & - tq2clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' Q2clmean:', & - q2clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' Q2clstd:', & - q2clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2) - CALL wrf_debug(75, message) - WRITE(message, *)'CLWRFdiag - WINDSPEED; tile: ',ij,' U10clmax:', & - u10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' V10clmax:', & - v10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' SPDUV10clmax:', & - spduv10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' TSPDUV10clmax:', & - tspduv10clmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' U10clmean:', & - u10clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' V10clmean:', & - v10clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' SPDUV10clmean:', & - spduv10clmean(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' U10clstd:', & - u10clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' V10clstd:', & - v10clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' SPDUV10clstd:', & - spduv10clstd(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2) - CALL wrf_debug(75, message) - WRITE(message, *)'CLWRFdiag - RAIN; tile: ',ij,' RAINCclmax:', & - raincclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINNCclmax:', & - rainncclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' TRAINCclmax:', & - traincclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' TRAINNCclmax:', & - trainncclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINCclmean:', & - raincclmean(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINNCclmean:', & - rainncclmean(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINCclstd:', & - raincclstd(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' RAINNCclstd:', & - rainncclstd(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2) - CALL wrf_debug(75, message) - WRITE(message,*)'CLWRFdiag - SKINTEMP; tile: ',ij,' SKINTEMPclmin:',& - skintempclmin(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' SKINTEMPclmax:', & - skintempclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' TSKINTEMPclmin:', & - tskintempclmin(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' TSKINTEMPclmax:', & - tskintempclmax(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' SKINTEMPclmean:', & - skintempclmean(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2),' SKINTEMPclstd:', & - skintempclstd(i_start(ij)+(i_end(ij)-i_start(ij))/2, & - j_start(ij)+(j_end(ij)-j_start(ij))/2) - CALL wrf_debug(75, message) + CALL wrf_debug(0, 'Re-initializing accumulation arrays') ENDIF DO j = j_start(ij), j_end(ij) DO i = i_start(ij), i_end(ij) @@ -264,7 +181,7 @@ SUBROUTINE clwrf_output_calc( & skintempclmax(i,j)=skintemp(i,j) skintempclmean(i,j)=skintemp(i,j) skintempclstd(i,j)=skintemp(i,j)*skintemp(i,j) - nsteps=0 +! nsteps=0 ENDDO ENDDO ENDDO @@ -294,14 +211,14 @@ SUBROUTINE clwrf_output_calc( & rainncclmax,trainncclmax,rainncclmean,rainncclstd) ! Skin Temperature CALL varstatistics(skintemp,xtimep,ime-ims+1,jme-jms+1,skintempclmin,& - skintempclmax, tskintempclmin,tskintempclmax,skintempclmean, & + skintempclmax,tskintempclmin,tskintempclmax,skintempclmean, & skintempclstd) ! IF (MOD(NINT(XTIME),clwrfH) == 0) THEN ! IF (MOD(NINT(XTIME+dt/60.),clwrfH) == 0) THEN IF (MOD(NINT((curr_secs2+dt)/dt),NINT(clwrfH*60./dt)) == 0) THEN - IF ( wrf_dm_on_monitor() ) PRINT *,'nsteps=',nsteps,' xtime:', & - xtime,' clwrfH:',clwrfH + IF ( wrf_dm_on_monitor() ) & + PRINT *,'nsteps=',nsteps,' xtime:', xtime,' clwrfH:',clwrfH t2clmean=t2clmean/nsteps t2clstd=SQRT(t2clstd/nsteps-t2clmean**2.) q2clmean=q2clmean/nsteps @@ -318,8 +235,61 @@ SUBROUTINE clwrf_output_calc( & raincclstd=SQRT(raincclstd/nsteps-raincclmean**2.) rainncclstd=SQRT(rainncclstd/nsteps-rainncclmean**2.) skintempclmean=skintempclmean/nsteps - skintempclstd=SQRT(skintempclstd/nsteps-skintempclmean**2.) - END IF + skintempclstd=SQRT(skintempclstd/nsteps-skintempclmean**2.) + nsteps = 0 + IF ( wrf_dm_on_monitor() ) THEN + DO ij = 1 , num_tiles + idp = i_start(ij)+(i_end(ij)-i_start(ij))/2 + jdp = j_start(ij)+(j_end(ij)-j_start(ij))/2 + WRITE(message, *)'CLWRFdiag - T2; tile: ',ij, & + ' T2clmin:', t2clmin(idp,jdp), & + ' T2clmax:', t2clmax(idp,jdp), & + ' TT2clmin:', tt2clmin(idp,jdp), & + ' TT2clmax:', tt2clmax(idp,jdp), & + ' T2clmean:', t2clmean(idp,jdp), & + ' T2clstd:', t2clstd(idp,jdp) + CALL wrf_debug(0, message) + WRITE(message, *)'CLWRFdiag - Q2; tile: ',ij, & + ' Q2clmin:', q2clmin(idp,jdp), & + ' Q2clmax:', q2clmax(idp,jdp), & + ' TQ2clmin:', tq2clmin(idp,jdp), & + ' TQ2clmax:', tq2clmax(idp,jdp), & + ' Q2clmean:', q2clmean(idp,jdp), & + ' Q2clstd:', q2clstd(idp,jdp) + CALL wrf_debug(75, message) + WRITE(message, *)'CLWRFdiag - WINDSPEED; tile: ',ij, & + ' U10clmax:', u10clmax(idp,jdp), & + ' V10clmax:', v10clmax(idp,jdp), & + ' SPDUV10clmax:', spduv10clmax(idp,jdp), & + ' TSPDUV10clmax:', tspduv10clmax(idp,jdp), & + ' U10clmean:', u10clmean(idp,jdp), & + ' V10clmean:', v10clmean(idp,jdp), & + ' SPDUV10clmean:', spduv10clmean(idp,jdp), & + ' U10clstd:', u10clstd(idp,jdp), & + ' V10clstd:', v10clstd(idp,jdp), & + ' SPDUV10clstd:', spduv10clstd(idp,jdp) + CALL wrf_debug(75, message) + WRITE(message, *)'CLWRFdiag - RAIN; tile: ',ij, & + ' RAINCclmax:',raincclmax(idp,jdp), & + ' RAINNCclmax:',rainncclmax(idp,jdp), & + ' TRAINCclmax:',traincclmax(idp,jdp), & + ' TRAINNCclmax:',trainncclmax(idp,jdp), & + ' RAINCclmean:',raincclmean(idp,jdp), & + ' RAINNCclmean:',rainncclmean(idp,jdp), & + ' RAINCclstd:',raincclstd(idp,jdp), & + ' RAINNCclstd:',rainncclstd(idp,jdp) + CALL wrf_debug(75, message) + WRITE(message,*)'CLWRFdiag - SKINTEMP; tile: ',ij, & + ' SKINTEMPclmin:',skintempclmin(idp,jdp), & + ' SKINTEMPclmax:',skintempclmax(idp,jdp), & + ' TSKINTEMPclmin:',tskintempclmin(idp,jdp), & + ' TSKINTEMPclmax:',tskintempclmax(idp,jdp), & + ' SKINTEMPclmean:',skintempclmean(idp,jdp), & + ' SKINTEMPclstd:',skintempclstd(idp,jdp) + CALL wrf_debug(75, message) + ENDDO + ENDIF + END IF ! ENDDO ! ENDDO ENDIF @@ -359,8 +329,8 @@ SUBROUTINE varstatisticsWIND(varu, varv, tt, dx, dy, varumax, varvmax, & END DO varumean=varumean+varu varvmean=varvmean+varv -varustd=varustd+varu**2 -varvstd=varvstd+varv**2 +varustd=varustd+varu*varu +varvstd=varvstd+varv*varv END SUBROUTINE varstatisticsWIND @@ -386,7 +356,7 @@ SUBROUTINE varstatisticsMAX(var, tt, dx, dy, varmax, tvarmax, varmean, & END DO END DO varmean=varmean+var -varstd=varstd+var**2 +varstd=varstd+var*var END SUBROUTINE varstatisticsMAX @@ -416,7 +386,7 @@ SUBROUTINE varstatistics(var, tt, dx, dy, varmin, varmax, tvarmin, tvarmax, & END DO END DO varmean=varmean+var -varstd=varstd+var**2 +varstd=varstd+var*var END SUBROUTINE varstatistics diff --git a/wrfv2_fire/phys/module_diag_misc.F b/wrfv2_fire/phys/module_diag_misc.F index eca4228a..a69144ac 100644 --- a/wrfv2_fire/phys/module_diag_misc.F +++ b/wrfv2_fire/phys/module_diag_misc.F @@ -9,6 +9,8 @@ END MODULE module_diag_misc ! MODULE module_diag_misc + PRIVATE :: WGAMMA + PRIVATE :: GAMMLN CONTAINS SUBROUTINE diagnostic_output_calc( & ids,ide, jds,jde, kds,kde, & @@ -17,7 +19,7 @@ SUBROUTINE diagnostic_output_calc( & i_start,i_end,j_start,j_end,kts,kte,num_tiles & ,dpsdt,dmudt & ,p8w,pk1m,mu_2,mu_2m & - ,u,v & + ,u,v, temp & ,raincv,rainncv,rainc,rainnc & ,i_rainc,i_rainnc & ,hfx,sfcevp,lh & @@ -32,6 +34,12 @@ SUBROUTINE diagnostic_output_calc( & ,dt,xtime,sbw,t2 & ,diag_print & ,bucket_mm, bucket_J & + ,mphysics_opt & + ,gsfcgce_hail, gsfcgce_2ice & + ,mpuse_hail & + ,nssl_cnoh, nssl_cnohl & + ,nssl_rho_qh, nssl_rho_qhl & + ,nssl_alphah, nssl_alphahl & ,prec_acc_c, prec_acc_nc, snow_acc_nc & ,snowncv, prec_acc_dt, curr_secs2 & ,nwp_diagnostics, diagflag & @@ -44,12 +52,20 @@ SUBROUTINE diagnostic_output_calc( & ,znw,w_colmean & ,numcolpts,w_mean & ,grpl_max,grpl_colint,refd_max,refl_10cm & + ,hail_maxk1,hail_max2d & ,qg_curr & + ,ng_curr,qh_curr,nh_curr,qr_curr,nr_curr & ! Optional (gthompsn) ,rho,ph,phb,g & ) !---------------------------------------------------------------------- USE module_dm, ONLY: wrf_dm_sum_real, wrf_dm_maxval + USE module_state_description, ONLY : & + KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME, & + WSM6SCHEME, ETAMPNEW, THOMPSON, THOMPSONAERO, & + MORR_TWO_MOMENT, GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, & + NSSL_2MOM, NSSL_2MOMCCN, NSSL_1MOM, NSSL_1MOMLFO, & + MILBRANDT2MOM , CAMMGMPSCHEME, FAST_KHAIN_LYNN, FULL_KHAIN_LYNN !,MILBRANDT3MOM, NSSL_3MOM IMPLICIT NONE !====================================================================== @@ -129,6 +145,11 @@ SUBROUTINE diagnostic_output_calc( & INTEGER, INTENT(IN ) :: diag_print REAL, INTENT(IN ) :: bucket_mm, bucket_J + INTEGER, INTENT(IN ) :: mphysics_opt + INTEGER, INTENT(IN) :: gsfcgce_hail, gsfcgce_2ice, mpuse_hail + REAL, INTENT(IN) :: nssl_cnoh, nssl_cnohl & + ,nssl_rho_qh, nssl_rho_qhl & + ,nssl_alphah, nssl_alphahl INTEGER, INTENT(IN ) :: nwp_diagnostics LOGICAL, INTENT(IN ) :: diagflag @@ -196,11 +217,16 @@ SUBROUTINE diagnostic_output_calc( & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN) :: & w & + ,temp & ,qg_curr & ,rho & ,refl_10cm & ,ph,phb + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), OPTIONAL, INTENT(IN) :: & + ng_curr, qh_curr, nh_curr & + ,qr_curr, nr_curr + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: & u10 & ,v10 @@ -213,13 +239,29 @@ SUBROUTINE diagnostic_output_calc( & ,w_up_max,w_dn_max & ,w_colmean,numcolpts,w_mean & ,grpl_max,grpl_colint & + ,hail_maxk1,hail_max2d & ,refd_max + REAL, DIMENSION(ims:ime,kms:kme,jms:jme):: temp_qg, temp_ng, temp_qr, temp_nr + INTEGER :: idump REAL :: wind_vel REAL :: depth + DOUBLE PRECISION:: hail_max + DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.01d0 ! number conc. of graupel/hail per cubic meter + LOGICAL:: scheme_has_graupel + INTEGER, PARAMETER:: ngbins=50 + DOUBLE PRECISION, DIMENSION(ngbins+1):: xxDx + DOUBLE PRECISION, DIMENSION(ngbins):: xxDg, xdtg + REAL:: xrho_g, xam_g, xbm_g, xmu_g + REAL, DIMENSION(3):: cge, cgg + DOUBLE PRECISION:: f_d, sum_ng, lamg, ilamg, N0_g, lam_exp, N0exp + DOUBLE PRECISION:: lamr, N0min + REAL:: mvd_r, xslw1, ygra1, zans1 + INTEGER:: ng, n + !----------------------------------------------------------------- ! Handle accumulations with buckets to prevent round-off truncation in long runs ! This is done every 360 minutes assuming time step fits exactly into 360 minutes @@ -392,6 +434,8 @@ SUBROUTINE diagnostic_output_calc( & ! !$OMP END PARALLEL DO ENDIF + + ! NSSL IF ( nwp_diagnostics .EQ. 1 ) THEN @@ -403,6 +447,7 @@ SUBROUTINE diagnostic_output_calc( & ! print *,' idump = ', idump ! print *,' xtime = ', xtime + ! IF ( MOD(itimestep, idump) .eq. 0 ) THEN ! WRITE(outstring,*) 'Computing PH0 for this domain with curr_secs2 = ', curr_secs2 ! CALL wrf_message ( TRIM(outstring) ) @@ -423,6 +468,8 @@ SUBROUTINE diagnostic_output_calc( & w_mean(i,j) = 0. grpl_max(i,j) = 0. refd_max(i,j) = 0. + hail_maxk1(i,j) = 0. + hail_max2d(i,j) = 0. ENDDO ENDDO ENDDO @@ -520,7 +567,7 @@ SUBROUTINE diagnostic_output_calc( & grpl_max(i,j) = grpl_colint(i,j) ENDIF -! Calculate the max radar reflectivity between output times + ! Calculate the max radar reflectivity between output times IF ( refl_10cm(i,kms,j) .GT. refd_max(i,j) ) THEN refd_max(i,j) = refl_10cm(i,kms,j) @@ -529,6 +576,430 @@ SUBROUTINE diagnostic_output_calc( & ENDDO ENDDO ! !$OMP END PARALLEL DO + + + +!+---+-----------------------------------------------------------------+ +!+---+-----------------------------------------------------------------+ +!..Calculate a maximum hail diameter from the characteristics of the +!.. graupel category mixing ratio and number concentration (or hail, if +!.. available). This diagnostic uses the actual spectral distribution +!.. assumptions, calculated by breaking the distribution into 50 bins +!.. from 0.5mm to 7.5cm. Once a minimum number concentration of 0.01 +!.. particle per cubic meter of air is reached, from the upper size +!.. limit, then this bin is considered the max size. +!+---+-----------------------------------------------------------------+ + + WRITE(outstring,*) 'GT-Diagnostics, computing max-hail diameter' + CALL wrf_debug (100, TRIM(outstring)) + + + IF (PRESENT(qh_curr)) THEN + WRITE(outstring,*) 'GT-Debug, this mp scheme, ', mphysics_opt, ' has hail mixing ratio' + CALL wrf_debug (150, TRIM(outstring)) +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kms,kme-1 + DO i=i_start(ij),i_end(ij) + temp_qg(i,k,j) = MAX(1.E-12, qh_curr(i,k,j)*rho(i,k,j)) + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + ELSE +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kms,kme-1 + DO i=i_start(ij),i_end(ij) + temp_qg(i,k,j) = MAX(1.E-12, qg_curr(i,k,j)*rho(i,k,j)) + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + ENDIF + + IF (PRESENT(nh_curr)) THEN + WRITE(outstring,*) 'GT-Debug, this mp scheme, ', mphysics_opt, ' has hail number concentration' + CALL wrf_debug (150, TRIM(outstring)) +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kms,kme-1 + DO i=i_start(ij),i_end(ij) + temp_ng(i,k,j) = MAX(1.E-8, nh_curr(i,k,j)*rho(i,k,j)) + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + ELSEIF (PRESENT(ng_curr)) THEN + WRITE(outstring,*) 'GT-Debug, this mp scheme, ', mphysics_opt, ' has graupel number concentration' +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kms,kme-1 + DO i=i_start(ij),i_end(ij) + temp_ng(i,k,j) = MAX(1.E-8, ng_curr(i,k,j)*rho(i,k,j)) + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + ELSE +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kms,kme-1 + DO i=i_start(ij),i_end(ij) + temp_ng(i,k,j) = 1.E-8 + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + ENDIF + + + ! Calculate the max hail size from graupel/hail parameters in microphysics scheme (gthompsn 12Mar2015) + ! First, we do know multiple schemes have assumed inverse-exponential distribution with constant + ! intercept parameter and particle density. Please leave next 4 settings alone for common + ! use and copy these and cge constants to re-assign per scheme if needed (e.g. NSSL). + + xrho_g = 500. + xam_g = 3.1415926536/6.0*xrho_g ! Assumed m(D) = a*D**b, where a=PI/6*rho_g and b=3 + xbm_g = 3. ! in other words, spherical graupel/hail + xmu_g = 0. + scheme_has_graupel = .false. + + !..Some constants. These *MUST* get changed below per scheme + !.. *IF* either xbm_g or xmu_g value is changed from 3 and zero, respectively. + + cge(1) = xbm_g + 1. + cge(2) = xmu_g + 1. + cge(3) = xbm_g + xmu_g + 1. + do n = 1, 3 + cgg(n) = WGAMMA(cge(n)) + enddo + + mp_select: SELECT CASE(mphysics_opt) + + CASE (KESSLERSCHEME) +! nothing to do here + + CASE (LINSCHEME) + scheme_has_graupel = .true. + xrho_g = 917. + xam_g = 3.1415926536/6.0*xrho_g + N0exp = 4.e4 +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kme-1, kms, -1 + DO i=i_start(ij),i_end(ij) + if (temp_qg(i,k,j) .LT. 1.E-6) CYCLE + lam_exp = (N0exp*xam_g*cgg(1)/temp_qg(i,k,j))**(1./cge(1)) + temp_ng(i,k,j) = N0exp*cgg(2)*lam_exp**(-cge(2)) + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + + CASE (WSM3SCHEME) +! nothing to do here + + CASE (WSM5SCHEME) +! nothing to do here + + CASE (WSM6SCHEME) + scheme_has_graupel = .true. + xrho_g = 500. + xam_g = 3.1415926536/6.0*xrho_g + N0exp = 4.e6 +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kme-1, kms, -1 + DO i=i_start(ij),i_end(ij) + if (temp_qg(i,k,j) .LT. 1.E-6) CYCLE + lam_exp = (N0exp*xam_g*cgg(1)/temp_qg(i,k,j))**(1./cge(1)) + temp_ng(i,k,j) = N0exp*cgg(2)*lam_exp**(-cge(2)) + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + + CASE (WDM5SCHEME) +! nothing to do here + + CASE (WDM6SCHEME) + scheme_has_graupel = .true. + xrho_g = 500. + N0exp = 4.e6 + if (mpuse_hail .eq. 1) then + xrho_g = 700. + N0exp = 4.e4 + endif + xam_g = 3.1415926536/6.0*xrho_g +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kme-1, kms, -1 + DO i=i_start(ij),i_end(ij) + if (temp_qg(i,k,j) .LT. 1.E-6) CYCLE + lam_exp = (N0exp*xam_g*cgg(1)/temp_qg(i,k,j))**(1./cge(1)) + temp_ng(i,k,j) = N0exp*cgg(2)*lam_exp**(-cge(2)) + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + + CASE (GSFCGCESCHEME) + if (gsfcgce_2ice.eq.0 .OR. gsfcgce_2ice.eq.2) then + scheme_has_graupel = .true. + if (gsfcgce_hail .eq. 1) then + xrho_g = 900. + else + xrho_g = 400. + endif + xam_g = 3.1415926536/6.0*xrho_g + N0exp = 4.e4 +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kme-1, kms, -1 + DO i=i_start(ij),i_end(ij) + if (temp_qg(i,k,j) .LT. 1.E-6) CYCLE + lam_exp = (N0exp*xam_g*cgg(1)/temp_qg(i,k,j))**(1./cge(1)) + temp_ng(i,k,j) = N0exp*cgg(2)*lam_exp**(-cge(2)) + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + endif + + CASE (SBU_YLINSCHEME) +! scheme_has_graupel = .true. ! Can be calculated from rime fraction variable. +! no time to implement + + CASE (ETAMPNEW) +! scheme_has_graupel = .true. ! Can be calculated from rime fraction variable. +! no time to implement + + CASE (THOMPSON, THOMPSONAERO) + + scheme_has_graupel = .true. + +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kms,kme-1 + DO i=i_start(ij),i_end(ij) + temp_qr(i,k,j) = MAX(1.E-10, qr_curr(i,k,j)*rho(i,k,j)) + temp_nr(i,k,j) = MAX(1.E-8, nr_curr(i,k,j)*rho(i,k,j)) + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + + ! Technically, the equation below for lambda-r should have constants + ! for the rain mass-diameter relation and mu, but these are currently + ! the same as graupel, so we are cheating to avoid passing more + ! constants from mp_thompson. + +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + N0min = 1.E6 + DO k=kme-1, kms, -1 + if (temp_qg(i,k,j) .LT. 1.E-6) CYCLE + lamr = (1000.0*3.1415926536/6.0*cgg(3)/cgg(2)*temp_nr(i,k,j)/temp_qr(i,k,j))**(1./3.) + mvd_r = 3.672 / lamr ! Technically this should have (+mu_r) + mvd_r = MAX(100.E-6, MIN(mvd_r, 2.5E-3)) + if (temp(i,k,j).lt.270.65 .and. mvd_r.gt.100.E-6) then + xslw1 = 4.01 + alog10(mvd_r) + else + xslw1 = 0.01 + endif + ygra1 = 4.31 + alog10(max(5.E-5, temp_qg(i,k,j))) + zans1 = 3.1 + (100./(300.*xslw1*ygra1/(10./xslw1+1.+0.25*ygra1)+30.+10.*ygra1)) + N0exp = 10.**(zans1) + N0exp = MAX(DBLE(1.E4), MIN(N0exp, DBLE(1.E6))) + N0min = MIN(N0exp, N0min) + N0exp = N0min + lam_exp = (N0exp*xam_g*cgg(1)/temp_qg(i,k,j))**(1./cge(1)) + lamg = lam_exp * (cgg(3)/cgg(2)/cgg(1))**(1./xbm_g) + N0_g = N0exp/(cgg(2)*lam_exp) * lamg**cge(2) + temp_ng(i,k,j) = N0_g*cgg(2)*lamg**(-cge(2)) + if (N0exp .ge. 1.E4 .AND. N0exp.le.1.E5) then + WRITE(outstring,*) 'GT-Debug, ', N0exp, temp_qr(i,k,j)*1000., temp_ng(i,k,j) + CALL wrf_debug (850, TRIM(outstring)) + endif + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + + +! CASE (MORR_MILB_P3) +! scheme_has_graupel = .true. +! either Hugh or Jason need to implement. + + CASE (MORR_TWO_MOMENT) + scheme_has_graupel = .true. + xrho_g = 400. + if (mpuse_hail .eq. 1) xrho_g = 900. + xam_g = 3.1415926536/6.0*xrho_g + + CASE (MILBRANDT2MOM) + WRITE(outstring,*) 'GT-Debug, using Milbrandt2mom, which has 2-moment hail' + CALL wrf_debug (150, TRIM(outstring)) + scheme_has_graupel = .true. + xrho_g = 900. + xam_g = 3.1415926536/6.0*xrho_g + +! CASE (MILBRANDT3MOM) +! coming in future? + + CASE (NSSL_1MOMLFO, NSSL_1MOM, NSSL_2MOM, NSSL_2MOMCCN) + + scheme_has_graupel = .true. + xrho_g = nssl_rho_qh + N0exp = nssl_cnoh + if (PRESENT(qh_curr)) then + xrho_g = nssl_rho_qhl + N0exp = nssl_cnohl + endif + xam_g = 3.1415926536/6.0*xrho_g + + if (PRESENT(ng_curr)) xmu_g = nssl_alphah + if (PRESENT(nh_curr)) xmu_g = nssl_alphahl + + if (xmu_g .NE. 0.) then + cge(1) = xbm_g + 1. + cge(2) = xmu_g + 1. + cge(3) = xbm_g + xmu_g + 1. + do n = 1, 3 + cgg(n) = WGAMMA(cge(n)) + enddo + endif + + ! NSSL scheme has many options, but, if single-moment, just fill + ! in the number array for graupel from built-in assumptions. + + if (.NOT.(PRESENT(nh_curr).OR.PRESENT(ng_curr)) ) then +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kme-1, kms, -1 + DO i=i_start(ij),i_end(ij) + if (temp_qg(i,k,j) .LT. 1.E-6) CYCLE + lam_exp = (N0exp*xam_g*cgg(1)/temp_qg(i,k,j))**(1./cge(1)) + temp_ng(i,k,j) = N0exp*cgg(2)*lam_exp**(-cge(2)) + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + endif + +! CASE (NSSL_3MOM) +! coming in future? + + CASE (CAMMGMPSCHEME) +! nothing to do here + + CASE (FULL_KHAIN_LYNN) +! explicit bin scheme so code below not applicable +! scheme authors need to implement if desired. + + CASE (FAST_KHAIN_LYNN) +! explicit bin scheme so code below not applicable +! scheme authors need to implement if desired. + + CASE DEFAULT + + END SELECT mp_select + + + if (scheme_has_graupel) then + +!..Create bins of graupel/hail (from 500 microns up to 7.5 cm). + xxDx(1) = 500.D-6 + xxDx(ngbins+1) = 0.075d0 + do n = 2, ngbins + xxDx(n) = DEXP(DFLOAT(n-1)/DFLOAT(ngbins) & + *DLOG(xxDx(ngbins+1)/xxDx(1)) +DLOG(xxDx(1))) + enddo + do n = 1, ngbins + xxDg(n) = DSQRT(xxDx(n)*xxDx(n+1)) + xdtg(n) = xxDx(n+1) - xxDx(n) + enddo + + +! !$OMP PARALLEL DO & +! !$OMP PRIVATE ( ij ) + DO ij = 1 , num_tiles + DO j=j_start(ij),j_end(ij) + DO k=kms,kme-1 + DO i=i_start(ij),i_end(ij) + if (temp_qg(i,k,j) .LT. 1.E-6) CYCLE + lamg = (xam_g*cgg(3)/cgg(2)*temp_ng(i,k,j)/temp_qg(i,k,j))**(1./xbm_g) + N0_g = temp_ng(i,k,j)/cgg(2)*lamg**cge(2) + sum_ng = 0.0d0 + do ng = ngbins, 1, -1 + f_d = N0_g*xxDg(ng)**xmu_g * DEXP(-lamg*xxDg(ng))*xdtg(ng) + sum_ng = sum_ng + f_d + if (sum_ng .gt. thresh_conc) then + exit + endif + enddo + if (ng .ge. ngbins) then + hail_max = xxDg(ngbins) + elseif (xxDg(ng+1) .gt. 1.E-3) then + hail_max = xxDg(ng+1) + else + hail_max = 1.E-4 + endif + if (hail_max .gt. 1E-2) then + WRITE(outstring,*) 'GT-Debug-Hail, ', hail_max*1000. + CALL wrf_debug (350, TRIM(outstring)) + endif + if (k.eq.kms) then + hail_maxk1(i,j) = MAX(hail_maxk1(i,j), hail_max) + endif + hail_max2d(i,j) = MAX(hail_max2d(i,j), hail_max) + ENDDO + ENDDO + ENDDO + ENDDO +! !$OMP END PARALLEL DO + + endif + + ENDIF ! NSSL @@ -722,5 +1193,42 @@ SUBROUTINE diagnostic_output_calc( & END SUBROUTINE diagnostic_output_calc +!+---+-----------------------------------------------------------------+ + REAL FUNCTION GAMMLN(XX) +! --- RETURNS THE VALUE LN(GAMMA(XX)) FOR XX > 0. + IMPLICIT NONE + REAL, INTENT(IN):: XX + DOUBLE PRECISION, PARAMETER:: STP = 2.5066282746310005D0 + DOUBLE PRECISION, DIMENSION(6), PARAMETER:: & + COF = (/76.18009172947146D0, -86.50532032941677D0, & + 24.01409824083091D0, -1.231739572450155D0, & + .1208650973866179D-2, -.5395239384953D-5/) + DOUBLE PRECISION:: SER,TMP,X,Y + INTEGER:: J + + X=XX + Y=X + TMP=X+5.5D0 + TMP=(X+0.5D0)*LOG(TMP)-TMP + SER=1.000000000190015D0 + DO 11 J=1,6 + Y=Y+1.D0 + SER=SER+COF(J)/Y +11 CONTINUE + GAMMLN=TMP+LOG(STP*SER/X) + END FUNCTION GAMMLN +! (C) Copr. 1986-92 Numerical Recipes Software 2.02 +!+---+-----------------------------------------------------------------+ + REAL FUNCTION WGAMMA(y) + + IMPLICIT NONE + REAL, INTENT(IN):: y + + WGAMMA = EXP(GAMMLN(y)) + + END FUNCTION WGAMMA +!+---+-----------------------------------------------------------------+ + + END MODULE module_diag_misc #endif diff --git a/wrfv2_fire/phys/module_diag_pld.F b/wrfv2_fire/phys/module_diag_pld.F index bd2bca6d..88fe6aa4 100644 --- a/wrfv2_fire/phys/module_diag_pld.F +++ b/wrfv2_fire/phys/module_diag_pld.F @@ -14,9 +14,10 @@ MODULE module_diag_pld SUBROUTINE pld ( u,v,w,t,qv,zp,zb,pp,pb,p,pw, & msfux,msfuy,msfvx,msfvy,msftx,msfty, & f,e, & - use_tot_or_hyd_p,missing, & + use_tot_or_hyd_p,extrap_below_grnd,missing, & num_press_levels,max_press_levels,press_levels, & p_pl,u_pl,v_pl,t_pl,rh_pl,ght_pl,s_pl,td_pl, & + q_pl, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -34,6 +35,7 @@ SUBROUTINE pld ( u,v,w,t,qv,zp,zb,pp,pb,p,pw, & REAL , INTENT(IN ) , DIMENSION(ims:ime , jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty, & f,e INTEGER, INTENT(IN ) :: use_tot_or_hyd_p + INTEGER, INTENT(IN ) :: extrap_below_grnd REAL , INTENT(IN ) :: missing REAL , INTENT(IN ) , DIMENSION(ims:ime , kms:kme , jms:jme) :: u,v,w,t,qv,zp,zb,pp,pb,p,pw INTEGER, INTENT(IN ) :: num_press_levels, max_press_levels @@ -42,11 +44,12 @@ SUBROUTINE pld ( u,v,w,t,qv,zp,zb,pp,pb,p,pw, & ! Output variables REAL , INTENT( OUT) , DIMENSION(num_press_levels) :: p_pl - REAL , INTENT( OUT) , DIMENSION(ims:ime , num_press_levels , jms:jme) :: u_pl,v_pl,t_pl,rh_pl,ght_pl,s_pl,td_pl + REAL , INTENT( OUT) , DIMENSION(ims:ime , num_press_levels , jms:jme) :: u_pl,v_pl,t_pl,rh_pl,ght_pl,s_pl,td_pl,q_pl ! Local variables REAL, PARAMETER :: eps = 0.622, t_kelvin = svpt0 , s1 = 243.5, s2 = svp2 , s3 = svp1*10., s4 = 611.0, s5 = 5418.12 + REAL, PARAMETER :: zshul=75., tvshul=290.66 INTEGER :: i, j, ke, kp, ke_h, ke_f REAL :: pu, pd, pm , & @@ -55,10 +58,11 @@ SUBROUTINE pld ( u,v,w,t,qv,zp,zb,pp,pb,p,pw, & uu, ud , & vu, vd , & zu, zd , & - qu, qd, qm , & + qu, qd , & eu, ed, em , & du, dd REAL :: es, qs + REAL :: part, gammas, tvu, tvd ! Silly, but transfer the small namelist.input array into the grid structure for output purposes. @@ -87,14 +91,15 @@ SUBROUTINE pld ( u,v,w,t,qv,zp,zb,pp,pb,p,pw, & j_loop : DO j = jts , MIN(jte,jde-1) i_loop : DO i = its , MIN(ite,ide-1) - ! For each i,j location, loop over the selected pressure levels to find + ! For each i,j location, loop over the selected + ! pressure levels to find ke_h = kts ke_f = kts kp_loop : DO kp = 1 , num_press_levels - ! For this particular i,j and pressure level, find the eta levels that surround this point - ! on half-levels. + ! For this particular i,j and pressure level, find the + ! eta levels that surround this point on half-levels. ke_loop_half : DO ke = ke_h , kte-2 @@ -106,11 +111,95 @@ SUBROUTINE pld ( u,v,w,t,qv,zp,zb,pp,pb,p,pw, & pd = p(i,ke ,j) END IF pm = p_pl(kp) + + ! Added option to extrapolate below ground - GAC (AFWA) + + IF ( ( extrap_below_grnd .EQ. 2 ) .AND. & + ( ke .EQ. ke_h ) .AND. ( pm .GT. pd )) THEN + + ! Requested pressure level is below ground. + ! Extrapolate adiabatically if requested in namelist. + + ! Methodology derived from Unified Post Processor (UPP). + ! Simply conserve first level U, V, and RH below ground. + ! Assume adiabatic lapse rate of gamma = 6.5 K/km + ! below ground, using Shuell correction to gamma + ! ("gammas") to find geopotential height, which is + ! computed by hydrostatically integrating mean isobaric + ! virtual temperature downward from the model surface. + ! Temperature is found by reducing adiabatically + ! from the first level temperature. + ! Sources: + ! Chuang et al, NCEP's WRF Post Processor and + ! Verification Systems, MM5 Workshop Session 7, 2004. + ! Unipost source code: MDL2P.f + + ! Z, T, Q, Tv at first half-eta level + + zu = 0.5 * ( zp(i,ke ,j) + zb(i,ke ,j) + & + zp(i,ke+1,j) + zb(i,ke+1,j) ) / g + tu = ( t(i,ke,j) + t0 ) * ( pd / p1000mb ) ** rcp + qu = MAX(qv(i,ke,j),0.) + tvu = tu * ( 1. + 0.608 * qu ) + + ! 1. Geopotential height (m) + + IF ( zu .GT. zshul ) THEN + tvd = tvu + zu * 6.5E-3 + IF ( tvd .GT. tvshul ) THEN + IF ( tvu .GT. tvshul) THEN + tvd = tvshul - 5.E-3 * ( tvu - tvshul ) ** 2 + ELSE + tvd = tvshul + ENDIF + ENDIF + gammas = ( tvu - tvd ) / zu + ELSE + gammas = 0. + ENDIF + part = ( r_d / g ) * ( ALOG (pm) - ALOG (pd) ) + ght_pl(i,kp,j) = zu - tvu * part / & + ( 1. + 0.5 * gammas * part ) + + ! 2. Temperature (K) + + t_pl(i,kp,j) = tu + ( zu - ght_pl(i,kp,j) ) * 6.5E-3 + + ! 3. Speed (m s-1) + + s_pl(i,kp,j) = 0.5 * SQRT ( ( u(i,ke ,j)+ & + u(i+1,ke ,j) )**2 + & + ( v(i,ke ,j) + v(i,ke ,j+1) )**2 ) + + ! 4. U and V (m s-1) + + u_pl(i,kp,j) = 0.5 * ( u(i,ke ,j) + u(i+1,ke ,j) ) + v_pl(i,kp,j) = 0.5 * ( v(i,ke ,j) + v(i,ke ,j+1) ) + + ! 5. Relative humidity (%) + + es = s4 * exp(s5 * (1.0 / 273.0 - 1.0 / tu) ) + qs = eps * es / (pd - es) + rh_pl(i,kp,j) = MAX(qv(i,ke,j),0.) / qs * 100. + + ! 6. Mixing ratio (kg/kg) + + es = s4 * exp(s5 * (1.0 / 273.0 - 1.0 / t_pl(i,kp,j))) + qs = eps * es / (pm - es) + q_pl(i,kp,j) = rh_pl(i,kp,j) * qs / 100. + + ! 7. Dewpoint (K) - Use Bolton's approximation - IF ( ( pd .GE. pm ) .AND. & + ed = q_pl(i,kp,j) * pm * 0.01 / ( eps + q_pl(i,kp,j) ) + ed = max(ed, 0.001) ! water vapor pressure in mb. + td_pl(i,kp,j) = t_kelvin + (s1 / ((s2 / log(ed/s3)) - 1.0)) + + EXIT ke_loop_half + ELSEIF ( ( pd .GE. pm ) .AND. & ( pu .LT. pm ) ) THEN - ! Found trapping pressure: up, middle, down. We are doing first order interpolation. + ! Found trapping pressure: up, middle, down. + ! We are doing first order interpolation. ! Now we just put in a list of diagnostics for this level. ! 1. Temperature (K) @@ -121,26 +210,32 @@ SUBROUTINE pld ( u,v,w,t,qv,zp,zb,pp,pb,p,pw, & ! 2. Speed (m s-1) - su = 0.5 * SQRT ( ( u(i,ke+1,j)+u(i+1,ke+1,j) )**2 + ( v(i,ke+1,j)+v(i,ke+1,j+1) )**2 ) - sd = 0.5 * SQRT ( ( u(i,ke ,j)+u(i+1,ke ,j) )**2 + ( v(i,ke ,j)+v(i,ke ,j+1) )**2 ) + su = 0.5 * SQRT ( ( u(i,ke+1,j)+u(i+1,ke+1,j) )**2 + & + ( v(i,ke+1,j)+v(i,ke+1,j+1) )**2 ) + sd = 0.5 * SQRT ( ( u(i,ke ,j)+u(i+1,ke ,j) )**2 + & + ( v(i,ke ,j)+v(i,ke ,j+1) )**2 ) s_pl(i,kp,j) = ( su * (pm-pd) + sd * (pu-pm) ) / (pu-pd) ! 3. U and V (m s-1) - uu = 0.5 * ( u(i,ke+1,j)+u(i+1,ke+1,j) ) - ud = 0.5 * ( u(i,ke ,j)+u(i+1,ke ,j) ) + uu = 0.5 * ( u(i,ke+1,j)+u(i+1,ke+1,j) ) + ud = 0.5 * ( u(i,ke ,j)+u(i+1,ke ,j) ) u_pl(i,kp,j) = ( uu * (pm-pd) + ud * (pu-pm) ) / (pu-pd) - vu = 0.5 * ( v(i,ke+1,j)+v(i,ke+1,j+1) ) - vd = 0.5 * ( v(i,ke ,j)+v(i,ke ,j+1) ) + vu = 0.5 * ( v(i,ke+1,j)+v(i,ke+1,j+1) ) + vd = 0.5 * ( v(i,ke ,j)+v(i,ke ,j+1) ) v_pl(i,kp,j) = ( vu * (pm-pd) + vd * (pu-pm) ) / (pu-pd) - ! 4. Dewpoint (K) - Use Bolton's approximation - + ! 4. Mixing ratio (kg/kg) + qu = MAX(qv(i,ke+1,j),0.) qd = MAX(qv(i,ke ,j),0.) - eu = qu * pu * 0.01 / ( eps + qu ) ! water vapor pressure in mb. - ed = qd * pd * 0.01 / ( eps + qd ) ! water vapor pressure in mb. + q_pl(i,kp,j) = ( qu * (pm-pd) + qd * (pu-pm) ) / (pu-pd) + + ! 5. Dewpoint (K) - Use Bolton's approximation + + eu = qu * pu * 0.01 / ( eps + qu ) ! water vapor press (mb) + ed = qd * pd * 0.01 / ( eps + qd ) ! water vapor press (mb) eu = max(eu, 0.001) ed = max(ed, 0.001) @@ -148,27 +243,29 @@ SUBROUTINE pld ( u,v,w,t,qv,zp,zb,pp,pb,p,pw, & dd = t_kelvin + ( s1 / ((s2 / log(ed/s3)) - 1.0) ) td_pl(i,kp,j) = ( du * (pm-pd) + dd * (pu-pm) ) / (pu-pd) - ! 5. Relative humidity (%) + + ! 6. Relative humidity (%) - qm = ( qu * (pm-pd) + qd * (pu-pm) ) / (pu-pd) ! qvapor at the pressure level. es = s4 * exp(s5 * (1.0 / 273.0 - 1.0 / t_pl(i,kp,j))) qs = eps * es / (pm - es) - rh_pl(i,kp,j) = qm / qs * 100. + rh_pl(i,kp,j) = q_pl(i,kp,j) / qs * 100. !em = qm * pm * 0.01 / ( eps + qm ) ! water vapor pressure at the level. !es = s3 * exp( s2 * (t_pl(i,kp,j) - t_kelvin)/(t_pl(i,kp,j) - s4) ) ! sat vapor pressure over liquid water in mb. !rh_pl(i,kp,j) = 100. * em * ( pm * 0.01 - es ) / ( es * ( pm * 0.01 - em ) ) - + ke_h = ke EXIT ke_loop_half END IF END DO ke_loop_half ke_loop_full : DO ke = ke_f , kte-1 + IF ( ( pw(i,ke ,j) .GE. p_pl(kp) ) .AND. & ( pw(i,ke+1,j) .LT. p_pl(kp) ) ) THEN - ! Found trapping pressure: up, middle, down. We are doing first order interpolation. + ! Found trapping pressure: up, middle, down. + ! We are doing first order interpolation. pu = LOG(pw(i,ke+1,j)) pm = LOG(p_pl(kp)) diff --git a/wrfv2_fire/phys/module_diagnostics_driver.F b/wrfv2_fire/phys/module_diagnostics_driver.F index 4ad1194d..59b7c774 100644 --- a/wrfv2_fire/phys/module_diagnostics_driver.F +++ b/wrfv2_fire/phys/module_diagnostics_driver.F @@ -36,11 +36,18 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ! Pick up the number of members for each of the 4d arrays - for declaration purposes. USE module_state_description, ONLY: num_moist, num_chem, num_tracer, num_scalar, & - P_QG, P_QV, & - SKIP_PRESS_DIAGS + P_QG, P_QH, P_QV, & + P_QNG, P_QH, P_QNH, P_QR, P_QNR, & + SKIP_PRESS_DIAGS, & + KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME, & + WSM6SCHEME, ETAMPNEW, THOMPSON, THOMPSONAERO, & + MORR_TWO_MOMENT, GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, & + NSSL_2MOM, NSSL_2MOMCCN, NSSL_1MOM, NSSL_1MOMLFO, & + MILBRANDT2MOM , CAMMGMPSCHEME, FAST_KHAIN_LYNN, FULL_KHAIN_LYNN !,MILBRANDT3MOM, NSSL_3MOM, MORR_MILB_P3 USE module_driver_constants, ONLY: max_plevs + ! From where we preferably are pulling g, Cp, etc. USE module_model_constants, ONLY: g @@ -181,6 +188,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & grid%xlat, grid%xlong, grid%xland, grid%ht, & grid%t_phy, p_phy, grid%rho, & grid%u_phy, grid%v_phy, grid%w_2, & + th_phy, pi_phy,dz8w, & grid%z, moist, & ! Scheme specific prognostics grid%ktop_deep, grid%refl_10cm, & @@ -205,7 +213,8 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ips, ipe, jps, jpe, kps, kpe, & ! Mandatory outputs for all quantitative schemes grid%ic_flashcount, grid%ic_flashrate, & - grid%cg_flashcount, grid%cg_flashrate & + grid%cg_flashcount, grid%cg_flashrate, & + grid%lpi & ) END IF LIGHTNING @@ -216,11 +225,170 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & CALL wrf_debug ( 100 , '--> CALL DIAGNOSTICS PACKAGE: NWP DIAGNOSTICS' ) + + + mp_select: SELECT CASE(config_flags%mp_physics) + + CASE (LINSCHEME, WSM6SCHEME, WDM6SCHEME, GSFCGCESCHEME, NSSL_1MOMLFO) + + CALL diagnostic_output_calc( & + DPSDT=grid%dpsdt ,DMUDT=grid%dmudt & + ,P8W=p8w ,PK1M=grid%pk1m & + ,MU_2=grid%mu_2 ,MU_2M=grid%mu_2m & + ,U=grid%u_2 ,V=grid%v_2 & + ,TEMP=grid%t_phy & + ,RAINCV=grid%raincv ,RAINNCV=grid%rainncv & + ,RAINC=grid%rainc ,RAINNC=grid%rainnc & + ,I_RAINC=grid%i_rainc ,I_RAINNC=grid%i_rainnc & + ,HFX=grid%hfx ,SFCEVP=grid%sfcevp ,LH=grid%lh & + ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & + ,XTIME=grid%xtime ,T2=grid%t2 & + ,ACSWUPT=grid%acswupt ,ACSWUPTC=grid%acswuptc & + ,ACSWDNT=grid%acswdnt ,ACSWDNTC=grid%acswdntc & + ,ACSWUPB=grid%acswupb ,ACSWUPBC=grid%acswupbc & + ,ACSWDNB=grid%acswdnb ,ACSWDNBC=grid%acswdnbc & + ,ACLWUPT=grid%aclwupt ,ACLWUPTC=grid%aclwuptc & + ,ACLWDNT=grid%aclwdnt ,ACLWDNTC=grid%aclwdntc & + ,ACLWUPB=grid%aclwupb ,ACLWUPBC=grid%aclwupbc & + ,ACLWDNB=grid%aclwdnb ,ACLWDNBC=grid%aclwdnbc & + ,I_ACSWUPT=grid%i_acswupt ,I_ACSWUPTC=grid%i_acswuptc & + ,I_ACSWDNT=grid%i_acswdnt ,I_ACSWDNTC=grid%i_acswdntc & + ,I_ACSWUPB=grid%i_acswupb ,I_ACSWUPBC=grid%i_acswupbc & + ,I_ACSWDNB=grid%i_acswdnb ,I_ACSWDNBC=grid%i_acswdnbc & + ,I_ACLWUPT=grid%i_aclwupt ,I_ACLWUPTC=grid%i_aclwuptc & + ,I_ACLWDNT=grid%i_aclwdnt ,I_ACLWDNTC=grid%i_aclwdntc & + ,I_ACLWUPB=grid%i_aclwupb ,I_ACLWUPBC=grid%i_aclwupbc & + ,I_ACLWDNB=grid%i_aclwdnb ,I_ACLWDNBC=grid%i_aclwdnbc & + ! Selection flag + ,DIAG_PRINT=config_flags%diag_print & + ,BUCKET_MM=config_flags%bucket_mm & + ,BUCKET_J =config_flags%bucket_J & + ,MPHYSICS_OPT=config_flags%mp_physics & ! gthompsn + ,GSFCGCE_HAIL=config_flags%gsfcgce_hail & ! gthompsn + ,GSFCGCE_2ICE=config_flags%gsfcgce_2ice & ! gthompsn + ,MPUSE_HAIL=config_flags%hail_opt & ! gthompsn + ,NSSL_ALPHAH=config_flags%nssl_alphah & ! gthompsn + ,NSSL_ALPHAHL=config_flags%nssl_alphahl & ! gthompsn + ,NSSL_CNOH=config_flags%nssl_cnoh & ! gthompsn + ,NSSL_CNOHL=config_flags%nssl_cnohl & ! gthompsn + ,NSSL_RHO_QH=config_flags%nssl_rho_qh & ! gthompsn + ,NSSL_RHO_QHL=config_flags%nssl_rho_qhl & ! gthompsn + ,SNOWNCV=grid%snowncv, SNOW_ACC_NC=grid%snow_acc_nc & + ,PREC_ACC_C=grid%prec_acc_c & + ,PREC_ACC_NC=grid%prec_acc_nc & + ,PREC_ACC_DT=config_flags%prec_acc_dt & + ,CURR_SECS2=curr_secs2 & + ,NWP_DIAGNOSTICS=config_flags%nwp_diagnostics & + ,DIAGFLAG=diag_flag & + ,HISTORY_INTERVAL=grid%history_interval & + ,ITIMESTEP=grid%itimestep & + ,U10=grid%u10,V10=grid%v10,W=grid%w_2 & + ,WSPD10MAX=grid%wspd10max & + ,UP_HELI_MAX=grid%up_heli_max & + ,W_UP_MAX=grid%w_up_max,W_DN_MAX=grid%w_dn_max & + ,ZNW=grid%znw,W_COLMEAN=grid%w_colmean & + ,NUMCOLPTS=grid%numcolpts,W_MEAN=grid%w_mean & + ,GRPL_MAX=grid%grpl_max,GRPL_COLINT=grid%grpl_colint & + ,REFD_MAX=grid%refd_max & + ,refl_10cm=grid%refl_10cm & + ,HAIL_MAXK1=grid%hail_maxk1,HAIL_MAX2D=grid%hail_max2d & ! gthompsn + ,QG_CURR=moist(ims,kms,jms,P_QG) & + ,RHO=grid%rho,PH=grid%ph_2,PHB=grid%phb,G=g & + ! Dimension arguments + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe & + ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1) & + ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1) & + ,KTS=k_start, KTE=min(k_end,kde-1) & + ,NUM_TILES=grid%num_tiles & + ) + + CASE (THOMPSON, THOMPSONAERO) + + CALL diagnostic_output_calc( & + DPSDT=grid%dpsdt ,DMUDT=grid%dmudt & + ,P8W=p8w ,PK1M=grid%pk1m & + ,MU_2=grid%mu_2 ,MU_2M=grid%mu_2m & + ,U=grid%u_2 ,V=grid%v_2 & + ,TEMP=grid%t_phy & + ,RAINCV=grid%raincv ,RAINNCV=grid%rainncv & + ,RAINC=grid%rainc ,RAINNC=grid%rainnc & + ,I_RAINC=grid%i_rainc ,I_RAINNC=grid%i_rainnc & + ,HFX=grid%hfx ,SFCEVP=grid%sfcevp ,LH=grid%lh & + ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & + ,XTIME=grid%xtime ,T2=grid%t2 & + ,ACSWUPT=grid%acswupt ,ACSWUPTC=grid%acswuptc & + ,ACSWDNT=grid%acswdnt ,ACSWDNTC=grid%acswdntc & + ,ACSWUPB=grid%acswupb ,ACSWUPBC=grid%acswupbc & + ,ACSWDNB=grid%acswdnb ,ACSWDNBC=grid%acswdnbc & + ,ACLWUPT=grid%aclwupt ,ACLWUPTC=grid%aclwuptc & + ,ACLWDNT=grid%aclwdnt ,ACLWDNTC=grid%aclwdntc & + ,ACLWUPB=grid%aclwupb ,ACLWUPBC=grid%aclwupbc & + ,ACLWDNB=grid%aclwdnb ,ACLWDNBC=grid%aclwdnbc & + ,I_ACSWUPT=grid%i_acswupt ,I_ACSWUPTC=grid%i_acswuptc & + ,I_ACSWDNT=grid%i_acswdnt ,I_ACSWDNTC=grid%i_acswdntc & + ,I_ACSWUPB=grid%i_acswupb ,I_ACSWUPBC=grid%i_acswupbc & + ,I_ACSWDNB=grid%i_acswdnb ,I_ACSWDNBC=grid%i_acswdnbc & + ,I_ACLWUPT=grid%i_aclwupt ,I_ACLWUPTC=grid%i_aclwuptc & + ,I_ACLWDNT=grid%i_aclwdnt ,I_ACLWDNTC=grid%i_aclwdntc & + ,I_ACLWUPB=grid%i_aclwupb ,I_ACLWUPBC=grid%i_aclwupbc & + ,I_ACLWDNB=grid%i_aclwdnb ,I_ACLWDNBC=grid%i_aclwdnbc & + ! Selection flag + ,DIAG_PRINT=config_flags%diag_print & + ,BUCKET_MM=config_flags%bucket_mm & + ,BUCKET_J =config_flags%bucket_J & + ,MPHYSICS_OPT=config_flags%mp_physics & ! gthompsn + ,GSFCGCE_HAIL=config_flags%gsfcgce_hail & ! gthompsn + ,GSFCGCE_2ICE=config_flags%gsfcgce_2ice & ! gthompsn + ,MPUSE_HAIL=config_flags%hail_opt & ! gthompsn + ,NSSL_ALPHAH=config_flags%nssl_alphah & ! gthompsn + ,NSSL_ALPHAHL=config_flags%nssl_alphahl & ! gthompsn + ,NSSL_CNOH=config_flags%nssl_cnoh & ! gthompsn + ,NSSL_CNOHL=config_flags%nssl_cnohl & ! gthompsn + ,NSSL_RHO_QH=config_flags%nssl_rho_qh & ! gthompsn + ,NSSL_RHO_QHL=config_flags%nssl_rho_qhl & ! gthompsn + ,SNOWNCV=grid%snowncv, SNOW_ACC_NC=grid%snow_acc_nc & + ,PREC_ACC_C=grid%prec_acc_c & + ,PREC_ACC_NC=grid%prec_acc_nc & + ,PREC_ACC_DT=config_flags%prec_acc_dt & + ,CURR_SECS2=curr_secs2 & + ,NWP_DIAGNOSTICS=config_flags%nwp_diagnostics & + ,DIAGFLAG=diag_flag & + ,HISTORY_INTERVAL=grid%history_interval & + ,ITIMESTEP=grid%itimestep & + ,U10=grid%u10,V10=grid%v10,W=grid%w_2 & + ,WSPD10MAX=grid%wspd10max & + ,UP_HELI_MAX=grid%up_heli_max & + ,W_UP_MAX=grid%w_up_max,W_DN_MAX=grid%w_dn_max & + ,ZNW=grid%znw,W_COLMEAN=grid%w_colmean & + ,NUMCOLPTS=grid%numcolpts,W_MEAN=grid%w_mean & + ,GRPL_MAX=grid%grpl_max,GRPL_COLINT=grid%grpl_colint & + ,REFD_MAX=grid%refd_max & + ,refl_10cm=grid%refl_10cm & + ,HAIL_MAXK1=grid%hail_maxk1,HAIL_MAX2D=grid%hail_max2d & ! gthompsn + ,QG_CURR=moist(ims,kms,jms,P_QG) & + ,QR_CURR=moist(ims,kms,jms,P_QR) & ! gthompsn + ,NR_CURR=scalar(ims,kms,jms,P_QNR) & ! gthompsn + ,RHO=grid%rho,PH=grid%ph_2,PHB=grid%phb,G=g & + ! Dimension arguments + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe & + ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1) & + ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1) & + ,KTS=k_start, KTE=min(k_end,kde-1) & + ,NUM_TILES=grid%num_tiles & + ) + + CASE (MORR_TWO_MOMENT) + CALL diagnostic_output_calc( & DPSDT=grid%dpsdt ,DMUDT=grid%dmudt & ,P8W=p8w ,PK1M=grid%pk1m & ,MU_2=grid%mu_2 ,MU_2M=grid%mu_2m & ,U=grid%u_2 ,V=grid%v_2 & + ,TEMP=grid%t_phy & ,RAINCV=grid%raincv ,RAINNCV=grid%rainncv & ,RAINC=grid%rainc ,RAINNC=grid%rainnc & ,I_RAINC=grid%i_rainc ,I_RAINNC=grid%i_rainnc & @@ -247,6 +415,16 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ,DIAG_PRINT=config_flags%diag_print & ,BUCKET_MM=config_flags%bucket_mm & ,BUCKET_J =config_flags%bucket_J & + ,MPHYSICS_OPT=config_flags%mp_physics & ! gthompsn + ,GSFCGCE_HAIL=config_flags%gsfcgce_hail & ! gthompsn + ,GSFCGCE_2ICE=config_flags%gsfcgce_2ice & ! gthompsn + ,MPUSE_HAIL=config_flags%hail_opt & ! gthompsn + ,NSSL_ALPHAH=config_flags%nssl_alphah & ! gthompsn + ,NSSL_ALPHAHL=config_flags%nssl_alphahl & ! gthompsn + ,NSSL_CNOH=config_flags%nssl_cnoh & ! gthompsn + ,NSSL_CNOHL=config_flags%nssl_cnohl & ! gthompsn + ,NSSL_RHO_QH=config_flags%nssl_rho_qh & ! gthompsn + ,NSSL_RHO_QHL=config_flags%nssl_rho_qhl & ! gthompsn ,SNOWNCV=grid%snowncv, SNOW_ACC_NC=grid%snow_acc_nc & ,PREC_ACC_C=grid%prec_acc_c & ,PREC_ACC_NC=grid%prec_acc_nc & @@ -265,7 +443,9 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ,GRPL_MAX=grid%grpl_max,GRPL_COLINT=grid%grpl_colint & ,REFD_MAX=grid%refd_max & ,refl_10cm=grid%refl_10cm & + ,HAIL_MAXK1=grid%hail_maxk1,HAIL_MAX2D=grid%hail_max2d & ! gthompsn ,QG_CURR=moist(ims,kms,jms,P_QG) & + ,NG_CURR=scalar(ims,kms,jms,P_QNG) & ! gthompsn ,RHO=grid%rho,PH=grid%ph_2,PHB=grid%phb,G=g & ! Dimension arguments ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & @@ -277,6 +457,267 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ,NUM_TILES=grid%num_tiles & ) + CASE (NSSL_1MOM) + + CALL diagnostic_output_calc( & + DPSDT=grid%dpsdt ,DMUDT=grid%dmudt & + ,P8W=p8w ,PK1M=grid%pk1m & + ,MU_2=grid%mu_2 ,MU_2M=grid%mu_2m & + ,U=grid%u_2 ,V=grid%v_2 & + ,TEMP=grid%t_phy & + ,RAINCV=grid%raincv ,RAINNCV=grid%rainncv & + ,RAINC=grid%rainc ,RAINNC=grid%rainnc & + ,I_RAINC=grid%i_rainc ,I_RAINNC=grid%i_rainnc & + ,HFX=grid%hfx ,SFCEVP=grid%sfcevp ,LH=grid%lh & + ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & + ,XTIME=grid%xtime ,T2=grid%t2 & + ,ACSWUPT=grid%acswupt ,ACSWUPTC=grid%acswuptc & + ,ACSWDNT=grid%acswdnt ,ACSWDNTC=grid%acswdntc & + ,ACSWUPB=grid%acswupb ,ACSWUPBC=grid%acswupbc & + ,ACSWDNB=grid%acswdnb ,ACSWDNBC=grid%acswdnbc & + ,ACLWUPT=grid%aclwupt ,ACLWUPTC=grid%aclwuptc & + ,ACLWDNT=grid%aclwdnt ,ACLWDNTC=grid%aclwdntc & + ,ACLWUPB=grid%aclwupb ,ACLWUPBC=grid%aclwupbc & + ,ACLWDNB=grid%aclwdnb ,ACLWDNBC=grid%aclwdnbc & + ,I_ACSWUPT=grid%i_acswupt ,I_ACSWUPTC=grid%i_acswuptc & + ,I_ACSWDNT=grid%i_acswdnt ,I_ACSWDNTC=grid%i_acswdntc & + ,I_ACSWUPB=grid%i_acswupb ,I_ACSWUPBC=grid%i_acswupbc & + ,I_ACSWDNB=grid%i_acswdnb ,I_ACSWDNBC=grid%i_acswdnbc & + ,I_ACLWUPT=grid%i_aclwupt ,I_ACLWUPTC=grid%i_aclwuptc & + ,I_ACLWDNT=grid%i_aclwdnt ,I_ACLWDNTC=grid%i_aclwdntc & + ,I_ACLWUPB=grid%i_aclwupb ,I_ACLWUPBC=grid%i_aclwupbc & + ,I_ACLWDNB=grid%i_aclwdnb ,I_ACLWDNBC=grid%i_aclwdnbc & + ! Selection flag + ,DIAG_PRINT=config_flags%diag_print & + ,BUCKET_MM=config_flags%bucket_mm & + ,BUCKET_J =config_flags%bucket_J & + ,MPHYSICS_OPT=config_flags%mp_physics & ! gthompsn + ,GSFCGCE_HAIL=config_flags%gsfcgce_hail & ! gthompsn + ,GSFCGCE_2ICE=config_flags%gsfcgce_2ice & ! gthompsn + ,MPUSE_HAIL=config_flags%hail_opt & ! gthompsn + ,NSSL_ALPHAH=config_flags%nssl_alphah & ! gthompsn + ,NSSL_ALPHAHL=config_flags%nssl_alphahl & ! gthompsn + ,NSSL_CNOH=config_flags%nssl_cnoh & ! gthompsn + ,NSSL_CNOHL=config_flags%nssl_cnohl & ! gthompsn + ,NSSL_RHO_QH=config_flags%nssl_rho_qh & ! gthompsn + ,NSSL_RHO_QHL=config_flags%nssl_rho_qhl & ! gthompsn + ,SNOWNCV=grid%snowncv, SNOW_ACC_NC=grid%snow_acc_nc & + ,PREC_ACC_C=grid%prec_acc_c & + ,PREC_ACC_NC=grid%prec_acc_nc & + ,PREC_ACC_DT=config_flags%prec_acc_dt & + ,CURR_SECS2=curr_secs2 & + ,NWP_DIAGNOSTICS=config_flags%nwp_diagnostics & + ,DIAGFLAG=diag_flag & + ,HISTORY_INTERVAL=grid%history_interval & + ,ITIMESTEP=grid%itimestep & + ,U10=grid%u10,V10=grid%v10,W=grid%w_2 & + ,WSPD10MAX=grid%wspd10max & + ,UP_HELI_MAX=grid%up_heli_max & + ,W_UP_MAX=grid%w_up_max,W_DN_MAX=grid%w_dn_max & + ,ZNW=grid%znw,W_COLMEAN=grid%w_colmean & + ,NUMCOLPTS=grid%numcolpts,W_MEAN=grid%w_mean & + ,GRPL_MAX=grid%grpl_max,GRPL_COLINT=grid%grpl_colint & + ,REFD_MAX=grid%refd_max & + ,refl_10cm=grid%refl_10cm & + ,HAIL_MAXK1=grid%hail_maxk1,HAIL_MAX2D=grid%hail_max2d & ! gthompsn + ,QG_CURR=moist(ims,kms,jms,P_QG) & + ,QH_CURR=moist(ims,kms,jms,P_QH) & ! gthompsn + ,RHO=grid%rho,PH=grid%ph_2,PHB=grid%phb,G=g & + ! Dimension arguments + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe & + ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1) & + ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1) & + ,KTS=k_start, KTE=min(k_end,kde-1) & + ,NUM_TILES=grid%num_tiles & + ) + + CASE (MILBRANDT2MOM, NSSL_2MOM, NSSL_2MOMCCN) + + CALL diagnostic_output_calc( & + DPSDT=grid%dpsdt ,DMUDT=grid%dmudt & + ,P8W=p8w ,PK1M=grid%pk1m & + ,MU_2=grid%mu_2 ,MU_2M=grid%mu_2m & + ,U=grid%u_2 ,V=grid%v_2 & + ,TEMP=grid%t_phy & + ,RAINCV=grid%raincv ,RAINNCV=grid%rainncv & + ,RAINC=grid%rainc ,RAINNC=grid%rainnc & + ,I_RAINC=grid%i_rainc ,I_RAINNC=grid%i_rainnc & + ,HFX=grid%hfx ,SFCEVP=grid%sfcevp ,LH=grid%lh & + ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & + ,XTIME=grid%xtime ,T2=grid%t2 & + ,ACSWUPT=grid%acswupt ,ACSWUPTC=grid%acswuptc & + ,ACSWDNT=grid%acswdnt ,ACSWDNTC=grid%acswdntc & + ,ACSWUPB=grid%acswupb ,ACSWUPBC=grid%acswupbc & + ,ACSWDNB=grid%acswdnb ,ACSWDNBC=grid%acswdnbc & + ,ACLWUPT=grid%aclwupt ,ACLWUPTC=grid%aclwuptc & + ,ACLWDNT=grid%aclwdnt ,ACLWDNTC=grid%aclwdntc & + ,ACLWUPB=grid%aclwupb ,ACLWUPBC=grid%aclwupbc & + ,ACLWDNB=grid%aclwdnb ,ACLWDNBC=grid%aclwdnbc & + ,I_ACSWUPT=grid%i_acswupt ,I_ACSWUPTC=grid%i_acswuptc & + ,I_ACSWDNT=grid%i_acswdnt ,I_ACSWDNTC=grid%i_acswdntc & + ,I_ACSWUPB=grid%i_acswupb ,I_ACSWUPBC=grid%i_acswupbc & + ,I_ACSWDNB=grid%i_acswdnb ,I_ACSWDNBC=grid%i_acswdnbc & + ,I_ACLWUPT=grid%i_aclwupt ,I_ACLWUPTC=grid%i_aclwuptc & + ,I_ACLWDNT=grid%i_aclwdnt ,I_ACLWDNTC=grid%i_aclwdntc & + ,I_ACLWUPB=grid%i_aclwupb ,I_ACLWUPBC=grid%i_aclwupbc & + ,I_ACLWDNB=grid%i_aclwdnb ,I_ACLWDNBC=grid%i_aclwdnbc & + ! Selection flag + ,DIAG_PRINT=config_flags%diag_print & + ,BUCKET_MM=config_flags%bucket_mm & + ,BUCKET_J =config_flags%bucket_J & + ,MPHYSICS_OPT=config_flags%mp_physics & ! gthompsn + ,GSFCGCE_HAIL=config_flags%gsfcgce_hail & ! gthompsn + ,GSFCGCE_2ICE=config_flags%gsfcgce_2ice & ! gthompsn + ,MPUSE_HAIL=config_flags%hail_opt & ! gthompsn + ,NSSL_ALPHAH=config_flags%nssl_alphah & ! gthompsn + ,NSSL_ALPHAHL=config_flags%nssl_alphahl & ! gthompsn + ,NSSL_CNOH=config_flags%nssl_cnoh & ! gthompsn + ,NSSL_CNOHL=config_flags%nssl_cnohl & ! gthompsn + ,NSSL_RHO_QH=config_flags%nssl_rho_qh & ! gthompsn + ,NSSL_RHO_QHL=config_flags%nssl_rho_qhl & ! gthompsn + ,SNOWNCV=grid%snowncv, SNOW_ACC_NC=grid%snow_acc_nc & + ,PREC_ACC_C=grid%prec_acc_c & + ,PREC_ACC_NC=grid%prec_acc_nc & + ,PREC_ACC_DT=config_flags%prec_acc_dt & + ,CURR_SECS2=curr_secs2 & + ,NWP_DIAGNOSTICS=config_flags%nwp_diagnostics & + ,DIAGFLAG=diag_flag & + ,HISTORY_INTERVAL=grid%history_interval & + ,ITIMESTEP=grid%itimestep & + ,U10=grid%u10,V10=grid%v10,W=grid%w_2 & + ,WSPD10MAX=grid%wspd10max & + ,UP_HELI_MAX=grid%up_heli_max & + ,W_UP_MAX=grid%w_up_max,W_DN_MAX=grid%w_dn_max & + ,ZNW=grid%znw,W_COLMEAN=grid%w_colmean & + ,NUMCOLPTS=grid%numcolpts,W_MEAN=grid%w_mean & + ,GRPL_MAX=grid%grpl_max,GRPL_COLINT=grid%grpl_colint & + ,REFD_MAX=grid%refd_max & + ,refl_10cm=grid%refl_10cm & + ,HAIL_MAXK1=grid%hail_maxk1,HAIL_MAX2D=grid%hail_max2d & ! gthompsn + ,QG_CURR=moist(ims,kms,jms,P_QG) & + ,NG_CURR=scalar(ims,kms,jms,P_QNG) & ! gthompsn + ,QH_CURR=moist(ims,kms,jms,P_QH) & ! gthompsn + ,NH_CURR=scalar(ims,kms,jms,P_QNH) & ! gthompsn + ,RHO=grid%rho,PH=grid%ph_2,PHB=grid%phb,G=g & + ! Dimension arguments + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe & + ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1) & + ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1) & + ,KTS=k_start, KTE=min(k_end,kde-1) & + ,NUM_TILES=grid%num_tiles & + ) + + + !..The remaining microphysics schemes do not have graupel, but + !..P_QG will just be empty and the remaining NWP-diagnostics can + !..still be computed, so go ahead, under DEFAULT, not their own. + +! CASE (KESSLERSCHEME) + +! CASE (WDM5SCHEME) + +! CASE (SBU_YLINSCHEME) + +! CASE (ETAMPNEW) + +! CASE (NSSL_3MOM) + +! CASE (MILBRANDT3MOM) + +! CASE (MORR_MILB_P3) + +! CASE (CAMMGMPSCHEME) + +! CASE (FULL_KHAIN_LYNN) + +! CASE (FAST_KHAIN_LYNN) + +! CASE (WSM3SCHEME) + +! CASE (WSM5SCHEME) + + CASE DEFAULT + + CALL diagnostic_output_calc( & + DPSDT=grid%dpsdt ,DMUDT=grid%dmudt & + ,P8W=p8w ,PK1M=grid%pk1m & + ,MU_2=grid%mu_2 ,MU_2M=grid%mu_2m & + ,U=grid%u_2 ,V=grid%v_2 & + ,TEMP=grid%t_phy & + ,RAINCV=grid%raincv ,RAINNCV=grid%rainncv & + ,RAINC=grid%rainc ,RAINNC=grid%rainnc & + ,I_RAINC=grid%i_rainc ,I_RAINNC=grid%i_rainnc & + ,HFX=grid%hfx ,SFCEVP=grid%sfcevp ,LH=grid%lh & + ,DT=grid%dt ,SBW=config_flags%spec_bdy_width & + ,XTIME=grid%xtime ,T2=grid%t2 & + ,ACSWUPT=grid%acswupt ,ACSWUPTC=grid%acswuptc & + ,ACSWDNT=grid%acswdnt ,ACSWDNTC=grid%acswdntc & + ,ACSWUPB=grid%acswupb ,ACSWUPBC=grid%acswupbc & + ,ACSWDNB=grid%acswdnb ,ACSWDNBC=grid%acswdnbc & + ,ACLWUPT=grid%aclwupt ,ACLWUPTC=grid%aclwuptc & + ,ACLWDNT=grid%aclwdnt ,ACLWDNTC=grid%aclwdntc & + ,ACLWUPB=grid%aclwupb ,ACLWUPBC=grid%aclwupbc & + ,ACLWDNB=grid%aclwdnb ,ACLWDNBC=grid%aclwdnbc & + ,I_ACSWUPT=grid%i_acswupt ,I_ACSWUPTC=grid%i_acswuptc & + ,I_ACSWDNT=grid%i_acswdnt ,I_ACSWDNTC=grid%i_acswdntc & + ,I_ACSWUPB=grid%i_acswupb ,I_ACSWUPBC=grid%i_acswupbc & + ,I_ACSWDNB=grid%i_acswdnb ,I_ACSWDNBC=grid%i_acswdnbc & + ,I_ACLWUPT=grid%i_aclwupt ,I_ACLWUPTC=grid%i_aclwuptc & + ,I_ACLWDNT=grid%i_aclwdnt ,I_ACLWDNTC=grid%i_aclwdntc & + ,I_ACLWUPB=grid%i_aclwupb ,I_ACLWUPBC=grid%i_aclwupbc & + ,I_ACLWDNB=grid%i_aclwdnb ,I_ACLWDNBC=grid%i_aclwdnbc & + ! Selection flag + ,DIAG_PRINT=config_flags%diag_print & + ,BUCKET_MM=config_flags%bucket_mm & + ,BUCKET_J =config_flags%bucket_J & + ,MPHYSICS_OPT=config_flags%mp_physics & ! gthompsn + ,GSFCGCE_HAIL=config_flags%gsfcgce_hail & ! gthompsn + ,GSFCGCE_2ICE=config_flags%gsfcgce_2ice & ! gthompsn + ,MPUSE_HAIL=config_flags%hail_opt & ! gthompsn + ,NSSL_ALPHAH=config_flags%nssl_alphah & ! gthompsn + ,NSSL_ALPHAHL=config_flags%nssl_alphahl & ! gthompsn + ,NSSL_CNOH=config_flags%nssl_cnoh & ! gthompsn + ,NSSL_CNOHL=config_flags%nssl_cnohl & ! gthompsn + ,NSSL_RHO_QH=config_flags%nssl_rho_qh & ! gthompsn + ,NSSL_RHO_QHL=config_flags%nssl_rho_qhl & ! gthompsn + ,SNOWNCV=grid%snowncv, SNOW_ACC_NC=grid%snow_acc_nc & + ,PREC_ACC_C=grid%prec_acc_c & + ,PREC_ACC_NC=grid%prec_acc_nc & + ,PREC_ACC_DT=config_flags%prec_acc_dt & + ,CURR_SECS2=curr_secs2 & + ,NWP_DIAGNOSTICS=config_flags%nwp_diagnostics & + ,DIAGFLAG=diag_flag & + ,HISTORY_INTERVAL=grid%history_interval & + ,ITIMESTEP=grid%itimestep & + ,U10=grid%u10,V10=grid%v10,W=grid%w_2 & + ,WSPD10MAX=grid%wspd10max & + ,UP_HELI_MAX=grid%up_heli_max & + ,W_UP_MAX=grid%w_up_max,W_DN_MAX=grid%w_dn_max & + ,ZNW=grid%znw,W_COLMEAN=grid%w_colmean & + ,NUMCOLPTS=grid%numcolpts,W_MEAN=grid%w_mean & + ,GRPL_MAX=grid%grpl_max,GRPL_COLINT=grid%grpl_colint & + ,REFD_MAX=grid%refd_max & + ,refl_10cm=grid%refl_10cm & + ,HAIL_MAXK1=grid%hail_maxk1,HAIL_MAX2D=grid%hail_max2d & ! gthompsn + ,QG_CURR=moist(ims,kms,jms,P_QG) & + ,RHO=grid%rho,PH=grid%ph_2,PHB=grid%phb,G=g & + ! Dimension arguments + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe & + ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1) & + ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1) & + ,KTS=k_start, KTE=min(k_end,kde-1) & + ,NUM_TILES=grid%num_tiles & + ) + + + + END SELECT mp_select ! Climate-oriented diagnostic quantities. @@ -326,6 +767,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ,RAINCV=grid%raincv ,RAINNCV=grid%rainncv & ,DT=grid%dt & ,XTIME=grid%xtime,CURR_SECS2=curr_secs2 & + ,NSTEPS=grid%nsteps & ! Dimension arguments ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & @@ -382,6 +824,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ,e=grid%e & ! Namelist info ,use_tot_or_hyd_p=config_flags%use_tot_or_hyd_p & + ,extrap_below_grnd=config_flags%extrap_below_grnd & ,missing=config_flags%p_lev_missing & ! The diagnostics, mostly output variables ,num_press_levels=config_flags%num_press_levels & @@ -395,6 +838,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ,ght_pl= grid%ght_pl & ,s_pl = grid%s_pl & ,td_pl = grid%td_pl & + ,q_pl = grid%q_pl & ! Dimension arguments ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & @@ -413,9 +857,9 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & AFWA_DIAGS : IF ( config_flags%afwa_diag_opt == 1 ) THEN - IF ( ( config_flags%auxhist2_interval == 0 ) ) THEN + IF ( ( config_flags%history_interval == 0 ) ) THEN WRITE (diag_message , * ) & - "Error : No 'auxhist2_interval' has been defined in 'namelist.input'" + "AFWA Diagnostics Error : No 'history_interval' defined in namelist" CALL wrf_error_fatal ( diag_message ) END IF @@ -430,7 +874,8 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ,scalar & ,chem & ,th_phy , pi_phy , p_phy & - ,dz8w , p8w , t8w , rho_phy & + ,grid%u_phy , grid%v_phy & + ,dz8w , p8w , t8w , rho_phy, grid%rho & ,ids, ide, jds, jde, kds, kde & ,ims, ime, jms, jme, kms, kme & ,ips, ipe, jps, jpe, kps, kpe & diff --git a/wrfv2_fire/phys/module_fdda_spnudging.F b/wrfv2_fire/phys/module_fdda_spnudging.F index 34f69327..79ba2ab9 100644 --- a/wrfv2_fire/phys/module_fdda_spnudging.F +++ b/wrfv2_fire/phys/module_fdda_spnudging.F @@ -819,7 +819,7 @@ SUBROUTINE spectral_nudging_filter_3dy( f, nwave, & ! Check to make sure we have full access to all S/N points IF ((jts /= jds) .OR. (jte /= jde)) THEN - WRITE ( wrf_err_message , * ) 'module_spectral_nudging: 3d: (jts /= jds) or (jte /= jde)',jts,ids,ite,ide + WRITE ( wrf_err_message , * ) 'module_spectral_nudging: 3d: (jts /= jds) or (jte /= jde)',jts,jds,jte,jde CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) END IF @@ -894,11 +894,7 @@ SUBROUTINE spectralnudgingfilterfft2dncar(nx,ny,nwave,fin) CALL wrf_message(TRIM(wrf_err_message)) END IF - if(MOD(n,2) == 0) then - nh = n/2 - 1 - else - nh = (n-1)/2 - end if + nh = min(max(1 + 2*nwave,0),n) ! filter all waves with wavenumber larger than nwave @@ -906,9 +902,8 @@ SUBROUTINE spectralnudgingfilterfft2dncar(nx,ny,nwave,fin) fp = 1. DO j=1,ny - DO i=nwave+1,nh - fp(2*i-1,j) = 0. - fp(2*i,j) = 0. + DO i=nh+1,n + fp(i,j) = 0. ENDDO ENDDO diff --git a/wrfv2_fire/phys/module_lightning_driver.F b/wrfv2_fire/phys/module_lightning_driver.F index 7be1339b..d8c24e86 100644 --- a/wrfv2_fire/phys/module_lightning_driver.F +++ b/wrfv2_fire/phys/module_lightning_driver.F @@ -40,7 +40,7 @@ SUBROUTINE lightning_init ( & ! IC and CG flash rates and accumulated flash count ,ic_flashcount, ic_flashrate & ,cg_flashcount, cg_flashrate & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ,lnox_opt,lnox_passive & ! LNOx tracers (chemistry only) ,lnox_total, lnox_ic, lnox_cg & @@ -56,7 +56,9 @@ SUBROUTINE lightning_init ( & LOGICAL, INTENT(IN) :: restart REAL, INTENT(IN) :: dt,dx INTEGER, INTENT(IN) :: cu_physics,mp_physics,do_radar_ref,lightning_option - REAL, INTENT(IN) :: lightning_dt, lightning_start_seconds +!REAL, INTENT(IN) :: lightning_dt, lightning_start_seconds + REAL, INTENT(IN) :: lightning_start_seconds + REAL, INTENT(INOUT) :: lightning_dt REAL, INTENT(IN) :: iccg_prescribed_num, iccg_prescribed_den INTEGER, INTENT(INOUT) :: cellcount_method INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & @@ -68,7 +70,7 @@ SUBROUTINE lightning_init ( & INTENT(OUT) :: ic_flashcount, ic_flashrate, & cg_flashcount, cg_flashrate -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) INTEGER, INTENT(IN) :: lnox_opt LOGICAL, INTENT(IN) :: lnox_passive REAL, OPTIONAL, DIMENSION( ims:ime,kms:kme,jms:jme ), & @@ -83,7 +85,9 @@ SUBROUTINE lightning_init ( & IF (itimestep .gt. 0 .or. lightning_option .eq. 0) return !-- check to see if lightning_dt is a proper multiple of dt - IF ( MOD(lightning_dt,dt) .ne. 0. ) THEN + IF ( lightning_dt == 0. ) THEN + lightning_dt = dt + ELSEIF ( ABS(1.-(1./NINT(lightning_dt/dt)) * (lightning_dt/dt)) .GT. 0.001 ) THEN CALL wrf_error_fatal (' lightning_init: lightning_dt needs to be a multiple of model time step dt') ENDIF @@ -122,6 +126,12 @@ SUBROUTINE lightning_init ( & WRITE(message, * ) ' lightning_init: CPM lightning option selected: ', lightning_option CALL wrf_debug ( 100 , message ) +#if (EM_CORE==1) + CASE (ltng_lpi) + + WRITE(message, * ) ' lightning_init: LPIM lightning option selected: ', lightning_option + CALL wrf_debug ( 100 , message ) +#endif ! Non-existing options CASE DEFAULT CALL wrf_error_fatal ( ' lightning_init: invalid lightning_option') @@ -155,7 +165,7 @@ SUBROUTINE lightning_init ( & CALL wrf_debug( 100, message ) ENDIF -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) CALL wrf_debug( 100, ' lightning_init: initializing and validating WRF-Chem only arrays and settings') @@ -191,6 +201,7 @@ SUBROUTINE lightning_driver ( & itimestep, dt, dx, dy, & xlat, xlon, xland, ht, & t_phy, p_phy, rho, u, v, w, & + th_phy, pi_phy,dz8w, & z, moist, & ! Scheme specific prognostics ktop_deep, & @@ -216,7 +227,8 @@ SUBROUTINE lightning_driver ( & its, ite, jts, jte, kts, kte, & ! Mandatory outputs for all quantitative schemes ic_flashcount, ic_flashrate, & - cg_flashcount, cg_flashrate & + cg_flashcount, cg_flashrate, & + lpi & ) !----------------------------------------------------------------- ! Framework @@ -235,6 +247,11 @@ SUBROUTINE lightning_driver ( & ! IC:CG methods USE module_ltng_iccg +! LPI +#if (EM_CORE==1) + USE module_ltng_lpi +#endif + IMPLICIT NONE !----------------------------------------------------------------- @@ -244,6 +261,7 @@ SUBROUTINE lightning_driver ( & REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: xlat, xlon, xland, ht REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: t_phy, p_phy, rho + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: th_phy, pi_phy, dz8w REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: u, v, w, z REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist), INTENT(IN ) :: moist @@ -252,6 +270,7 @@ SUBROUTINE lightning_driver ( & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: refl ! reflectivity from mp_physics TYPE(WRFU_Time), INTENT(IN ) :: current_time ! For use of IC:CG input + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT), OPTIONAL :: LPI ! Mandatory namelist inputs INTEGER, INTENT(IN ) :: lightning_option REAL, INTENT(IN ) :: lightning_dt, lightning_start_seconds, flashrate_factor @@ -274,6 +293,7 @@ SUBROUTINE lightning_driver ( & REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ic_flashcount , cg_flashcount REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT( OUT) :: ic_flashrate , cg_flashrate + ! Local variables REAL, DIMENSION( ims:ime, jms:jme ) :: total_flashrate CHARACTER (LEN=80) :: message @@ -374,8 +394,33 @@ SUBROUTINE lightning_driver ( & total_flashrate & ) + ! LPI lightning options +#if (EM_CORE==1) + CASE( ltng_lpi ) + CALL wrf_debug ( 100, ' lightning_driver: calling Light Potential Index' ) + IF(F_QG) THEN + CALL calclpi(W=w, & + Z=z, & + PI_PHY=pi_phy, RHO_PHY=rho, & + TH_PHY=TH_PHY,P_PHY=p_phy, & + DZ8w=dz8w, & + QV=moist(ims,kms,jms,P_QV), & !Qv=qv_curr, & + QC=moist(ims,kms,jms,P_QC), & !Qc=qc_curr, & + QR=moist(ims,kms,jms,P_QR), & !QR=qr_curr, & + QI=moist(ims,kms,jms,P_QI), & !QI=qi_curr, & + QS=moist(ims,kms,jms,P_QS), & !qs_curr, & + QG=moist(ims,kms,jms,P_QG), & !qg_curr, & + QH=moist(ims,kms,jms,P_QH), & !qh_curr, & + lpi=lpi & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte) + ELSE + WRITE(wrf_err_message, * ) ' lightning_driver: LPI option needs Microphysics Option with Graupel ' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF +#endif ! CASE ( another_cpm_option) -! CALL ... ! Invalid lightning options CASE DEFAULT diff --git a/wrfv2_fire/phys/module_ltng_lpi.F b/wrfv2_fire/phys/module_ltng_lpi.F new file mode 100644 index 00000000..a99c80e6 --- /dev/null +++ b/wrfv2_fire/phys/module_ltng_lpi.F @@ -0,0 +1,180 @@ +MODULE module_ltng_lpi +!Yair, Y., B. Lynn, C. Price, V. Kotroni, K. Lagouvardos, E. Morin, +!A. Magnai, and M. del Carmen Llasat (2010), Predicting the potential for +!lightning activity in Mediterranean storms based on the Weather +!Research and Forecasting (WRF) model dynamic and microphysical +!fields, J. Geophys. Res., 115, D04205, doi:10.1029/2008JD010868. +! However, we don't check for collapsing cell (so as not to require use of halo). +! This means that lpi is also calculated in cells that are no longer (on average) growing +! For a "complete" lightning forecast scheme, please see: +!http://journals.ametsoc.org/doi/abs/10.1175/WAF-D-11-00144.1 +!(Predicting Cloud-to-Ground and Intracloud Lightning in Weather Forecast Models) + +CONTAINS +!=================================================================== +! + SUBROUTINE calclpi(qv,qc, qr, qi, qs, qg, qh & + ,w,z,dz8w,pi_phy,th_phy,p_phy,rho_phy & + ,lpi& + ,ids,ide, jds,jde, kds,kde & + ,ims,ime, jms,jme, kms,kme & + ,its,ite, jts,jte, kts,kte & + ) +!------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------- +! +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde , & + ims,ime, jms,jme, kms,kme , & + its,ite, jts,jte, kts,kte + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN) :: & + qv, & + qc, & + qi, & + qr, & + qs, & + qg,qh + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: w, z + REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: & + & dz8w,pi_phy,p_phy,rho_phy + REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: & + & th_phy + REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme):: & + & LPI + + + + + REAL, DIMENSION(kms:kme):: tempk,rh + REAL, DIMENSION(kms:kme):: qv1d,p1d,rho1d,qti1d + REAL, DIMENSION(kms:kme):: temp,qc1d,ql1d,qi1d,qs1d,qg1d,lpi1d + REAL, DIMENSION(0:kme):: w1d,height + REAL, DIMENSION(kms:kme):: e1d,height_t,w1d_t + REAL z_full,qrs,teten,RELHUM,LOC,Td_850,Td_700,PC_DWPT + INTEGER level + REAL :: dt_lpi,t_base,t_top + INTEGER I_COLLAPSE + LOGICAL LOOK_T + INTEGER I_START,I_END,J_START,J_END + + + INTEGER :: i,j,k +!------------------------------------------------------------------- + DO j = jts,jte + DO i = its,ite + z_full=0. + height(0)=z_full + w1d(0)=w(i,1,j) + DO k = kts,kte-1 + if (k.lt.kte-1)then + w1d(k)=w(i,k+1,j) + else + w1d(k)=0. + end if + temp(k) = th_phy(i,k,j)*pi_phy(i,k,j)-273.16 + tempk(k) = th_phy(i,k,j)*pi_phy(i,k,j) + qv1d(k)=qv(i,k,j) + p1d(k)=p_phy(i,k,j) + rho1d(k)=rho_phy(i,k,j) + z_full=z_full+dz8w(i,k,j) + height(k)=z_full + qc1d(k)=qc(i,k,j) + ql1d(k)=qc(i,k,j)+qr(i,k,j) + qi1d(k)=qi(i,k,j) + qti1d(k)=qi(i,k,j)+qs(i,k,j)+qg(i,k,j)+qh(i,k,j) + qs1d(k)=qs(i,k,j) +! qg1d(k)=qg(i,k,j)+qh(i,k,j) +! Hail doesn't usually charge + qg1d(k)=qg(i,k,j) +! For conservative advection multiply by rho1d and divide by it below + ENDDO + do k = kts,kte-1 + height_t(k)=0.5*(height(k-1)+height(k)) + w1d_t(k)=0.5*(w1d(k-1)+w1d(k)) + end do + t_base=-0 + t_top=-20 + call calc_lpi(ql1d,qi1d,qs1d,qg1d,w1d,temp,height,lpi(i,j),t_base,t_top,kme,kte) + END DO + END DO + return + end subroutine calclpi + subroutine & + & calc_lpi(ql3d,qi3d,qs3d,qg3d,w3d,t3d,height,lpi,t_base,t_top,nk,nke) + implicit none + integer nk,nke + real t_base,t_top + real ql3d(nk) + real qg3d(nk) + real qi3d(nk) + real qs3d(nk) + real w3d(0:nk) + real t3d(nk) + real height(0:nk) + real lpi + real del_z(nk) + real w_ave(nk) + integer ic,jc,icnt,i,j,k,i_collapse + real i_dist,j_dist,del_z_tot + real top, bot + real num,den,ave_z + real num_s,den_s + real num_i,den_i + real q_isg + icnt=0 + do k=1,nke + top=height(k) + bot=height(k-1) + del_z(k)=top-bot + w_ave(k)=0.5*(w3d(k)+w3d(k-1)) + end do +! +! Check for collapsing cell +! Here, we don't check, since it requires a halo. + ave_z=0 + del_z_tot=0 + lpi=0 + do k=1,nke-1 + if (t3d(k).le.t_base.and.t3d(k).gt.t_top)then ! set temp range + + den_i = qi3d(k)+qg3d(k) + den_s = qs3d(k)+qg3d(k) + if (qs3d(k).eq.0.or.qg3d(k).eq.0.)then !checks for zeroes + den_s=10000. + num_s = 0. + else + num_s = sqrt(qs3d(k)*qg3d(k)) + end if + if (qi3d(k).eq.0.or.qg3d(k).eq.0.)then ! checks for zeroes + den_i=10000. + num_i = 0. + else + num_i = sqrt(qi3d(k)*qg3d(k)) + end if + q_isg = qg3d(k)*(num_i/den_i+num_s/den_s) ! ice "fract"-content + + if (ql3d(k).eq.0.or.q_isg.eq.0)then + num=0 + den=10000. + else + num = sqrt(ql3d(k)*q_isg) + den = ql3d(k)+q_isg + end if + del_z_tot=del_z_tot+del_z(k) + if (num.gt.0)then + ave_z=ave_z+del_z(k)*(2.*num/den)*w_ave(k)**2 ! lightning potential index J/unit-mass + end if + end if + end do +! + if (del_z_tot.eq.0)del_z_tot=100000 + lpi=ave_z/del_z_tot + +! + return + end subroutine calc_lpi + END MODULE module_ltng_lpi diff --git a/wrfv2_fire/phys/module_microphysics_driver.F b/wrfv2_fire/phys/module_microphysics_driver.F index af034503..e7cd8cb6 100644 --- a/wrfv2_fire/phys/module_microphysics_driver.F +++ b/wrfv2_fire/phys/module_microphysics_driver.F @@ -32,7 +32,7 @@ SUBROUTINE microphysics_driver( & ,accum_mode,aitken_mode,coarse_mode & ,icwmrsh3d,icwmrdp3d,shfrc3d,cmfmc3d,cmfmc2_3d & ,config_flags,fnm,fnp,rh_old_mp,lcd_old_mp & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ,chem &! For CAMMGMP scheme Prognostic aerosols ,qme3d,prain3d,nevapr3d,rate1ord_cw2pr_st3d & ,dgnum4D,dgnumwet4D & @@ -46,20 +46,20 @@ SUBROUTINE microphysics_driver( & ,qns_curr,qnr_curr,qng_curr,qnn_curr,qnc_curr & ,qnwfa_curr,qnifa_curr & ! for water/ice-friendly aerosols ,f_qnwfa,f_qnifa & ! for water/ice-friendly aerosols - ,qvolg_curr & + ,qvolg_curr,qvolh_curr & ,effr_curr,ice_effr_curr,tot_effr_curr & ,qic_effr_curr,qip_effr_curr,qid_effr_curr & ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni & ,f_qns,f_qnr,f_qng,f_qnc,f_qnn,f_qh,f_qnh & , f_qzr,f_qzi,f_qzs,f_qzg,f_qzh & - ,f_qvolg & + ,f_qvolg,f_qvolh & ,f_qic,f_qip,f_qid & ,f_qnic,f_qnip,f_qnid & ,f_effr,f_ice_effr,f_tot_effr & ,f_qic_effr,f_qip_effr,f_qid_effr & ,qrcuten, qscuten, qicuten, mu & ,qt_curr,f_qt & - ,mp_restart_state,tbpvs_state,tbpvs0_state & ! for etampnew or etampold + ,mp_restart_state,tbpvs_state,tbpvs0_state & ! for etampnew or etamp_hr ,hail,ice2 & ! for mp_gsfcgce ! ,ccntype & ! for mp_milbrandt2mom ,u,v,w,z & @@ -67,7 +67,7 @@ SUBROUTINE microphysics_driver( & ,snownc, snowncv & ,hailnc, hailncv & ,graupelnc, graupelncv & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ,rainprod, evapprod & ,qv_b4mp, qc_b4mp, qi_b4mp, qs_b4mp & #endif @@ -79,6 +79,7 @@ SUBROUTINE microphysics_driver( & ,diagflag, do_radar_ref & ,re_cloud, re_ice, re_snow & ! G. Thompson ,has_reqc, has_reqi, has_reqs & ! G. Thompson + ,ccn_conc & ! RAS ,scalar,num_scalar & ,kext_ql,kext_qs,kext_qg & ,kext_qh,kext_qa & @@ -88,30 +89,36 @@ SUBROUTINE microphysics_driver( & ,height,tempc & ,TH_OLD & ,QV_OLD & - ,xlat,xlong,ivgtyp & + ,xlat,xlong,ivgtyp & ) ! Framework #if(NMM_CORE==1) USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME & - ,WSM6SCHEME, ETAMPNEW, ETAMPOLD, etamp_HWRF,THOMPSON, THOMPSONAERO, MORR_TWO_MOMENT & - ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME & + ,WSM6SCHEME, ETAMPNEW, ETAMP_HR, etamp_HWRF,THOMPSON, THOMPSONAERO, MORR_TWO_MOMENT & + ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN, NSSL_2MOMG & + ,NSSL_1MOM,NSSL_1MOMLFO & ,MILBRANDT2MOM !,MILBRANDT3MOM #else USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME & - ,WSM6SCHEME, ETAMPNEW, ETAMPOLD, THOMPSON, THOMPSONAERO, FAST_KHAIN_LYNN, MORR_TWO_MOMENT & - ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN & + ,WSM6SCHEME, ETAMPNEW, ETAMP_HR, THOMPSON, THOMPSONAERO, FAST_KHAIN_LYNN, MORR_TWO_MOMENT & + ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN, NSSL_2MOMG & ,NSSL_1MOM,NSSL_1MOMLFO & ! ,NSSL_3MOM & ,MILBRANDT2MOM , CAMMGMPSCHEME,FULL_KHAIN_LYNN !,MILBRANDT3MOM #endif +#ifdef DM_PARALLEL + USE module_dm, ONLY : & + local_communicator, mytask, wrf_dm_min_real, wrf_dm_max_real +#endif + ! Model Layer USE module_model_constants USE module_wrf_error USE module_configure, only: grid_config_rec_type -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !mchen USE module_state_description, only: num_scalar ! For CAMMGMP scheme Prognostic aerosols USE module_state_description, only: num_chem ! mchen USE modal_aero_data, only: ntot_amode_cam_mam => ntot_amode ! For CAMMGMP scheme Prognostic aerosols @@ -126,7 +133,6 @@ SUBROUTINE microphysics_driver( & USE module_mp_wsm5 USE module_mp_wsm6 USE module_mp_etanew - USE module_mp_etaold USE module_mp_thompson USE module_mp_full_sbm USE module_mp_fast_sbm @@ -162,7 +168,6 @@ SUBROUTINE microphysics_driver( & ! WRF Single-Moment 6-class, Lim and Hong (2003 WRF workshop) ! Eta Grid-scale Cloud and Precipitation scheme (EGCP01, Ferrier) ! * etampnew - what's in the operational 4-km High-Resolution Window Runs - ! * etampold - what was run in the 12-km operational NAM ! Milbrandt and Yau (2005) !---------------------------------------------------------------------- @@ -306,6 +311,9 @@ SUBROUTINE microphysics_driver( & !-- diagflag Logical to tell us when to produce diagnostics for history or restart ! !====================================================================== + INTEGER,parameter :: iunit=6 + INTEGER :: mpi_error_code=1 + TYPE(grid_config_rec_type), INTENT(IN ) , OPTIONAL :: config_flags INTEGER, INTENT(IN ) :: mp_physics LOGICAL, INTENT(IN ) :: specified @@ -370,7 +378,7 @@ SUBROUTINE microphysics_driver( & shfrc3d, & !Shallow cloud fraction cmfmc3d, & !Deep + Shallow Convective mass flux [ kg /s/m^2 ] cmfmc2_3d !Shallow convective mass flux [ kg/s/m^2 ] -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !4D variables required for CAMMGMP scheme REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme,ntot_amode_cam_mam ), & INTENT(IN) :: & @@ -384,7 +392,7 @@ SUBROUTINE microphysics_driver( & rh_old_mp, & !Old RH lcd_old_mp !Old liquid cloud fraction !In-outs -optional -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem), & INTENT(INOUT) :: & chem !Chem array for CAMMGMP scheme Prognostic aerosols @@ -400,8 +408,7 @@ SUBROUTINE microphysics_driver( & lradius, & !Old Cloud fraction for CAMMGMP microphysics only iradius, & !Old Cloud fraction for CAMMGMP microphysics only cldfra_conv - -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(INOUT), OPTIONAL :: & qme3d, & !Net condensation rate (kg/kg/s) @@ -412,7 +419,7 @@ SUBROUTINE microphysics_driver( & REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY -!!$#ifdef WRF_CHEM +!!$#if ( WRF_CHEM == 1 ) ! REAL, INTENT(OUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & !!$#else @@ -462,14 +469,14 @@ SUBROUTINE microphysics_driver( & ,kext_ft_qic,kext_ft_qip,kext_ft_qid & ,kext_ft_qs,kext_ft_qg & ,qnwfa_curr,qnifa_curr & ! Added by G. Thompson - ,qvolg_curr + ,qvolg_curr,qvolh_curr REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & OPTIONAL, & INTENT(IN) :: qrcuten, qscuten, qicuten -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(INOUT) :: rainprod, evapprod REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & @@ -517,22 +524,29 @@ SUBROUTINE microphysics_driver( & ,f_qic_effr,f_qip_effr,f_qid_effr & ,f_qic,f_qip,f_qid & ,f_qnic,f_qnip,f_qnid & - ,f_qzi,f_qzs,f_qzg,f_qzh,f_qvolg & + ,f_qzi,f_qzs,f_qzg,f_qzh,f_qvolg,f_qvolh & ,f_qnwfa, f_qnifa ! Added by G. Thompson LOGICAL, OPTIONAL, INTENT(IN) :: diagflag + REAL, INTENT(IN) :: ccn_conc ! RAS INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT) :: & ! G. Thompson re_cloud, re_ice, re_snow INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs +! REAL , DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT) :: lwp ! LOCAL VAR INTEGER :: i,j,k,its,ite,jts,jte,ij,sz,n LOGICAL :: channel + LOGICAL :: nssl_progn = .false. REAL :: z0, z1, z2, w1, w2 + integer, parameter :: ntot = 50 + real :: wmin, wmax + integer :: ierr + !--------------------------------------------------------------------- ! check for microphysics type. We need a clean way to ! specify these things! @@ -548,6 +562,18 @@ SUBROUTINE microphysics_driver( & sz = 0 ENDIF +! set this to true to print out the global max/min for W on each time step. + IF ( .false. ) THEN + wmax = maxval( w(ips:ipe,kps:kpe,jps:jpe) ) + wmin = minval( w(ips:ipe,kps:kpe,jps:jpe) ) +#if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) + wmax = wrf_dm_max_real ( wmax ) + wmin = wrf_dm_min_real ( wmin ) +#endif + WRITE( wrf_err_message , * ) 'microphysics_driver: GLOBAL w max/min = ', wmax, wmin + CALL wrf_message ( wrf_err_message ) + ENDIF + #ifdef XEON_OPTIMIZED_WSM5 ! the OpenMP loops are inside the scheme when running on MIC IF ( mp_physics .EQ. WSM5SCHEME ) THEN @@ -581,6 +607,12 @@ SUBROUTINE microphysics_driver( & ,REFL_10CM=refl_10cm & ,diagflag=diagflag & ,do_radar_ref=do_radar_ref & + ,has_reqc=has_reqc & ! for radiation + + ,has_reqi=has_reqi & + ,has_reqs=has_reqs & + ,re_cloud=re_cloud & + ,re_ice=re_ice & + ,re_snow=re_snow & ! for radiation - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -612,12 +644,24 @@ SUBROUTINE microphysics_driver( & !----------- IF( PRESENT(chem_opt) .AND. PRESENT(progn) ) THEN - IF( chem_opt==0 .AND. progn==1 .AND. (mp_physics==LINSCHEME .OR. mp_physics==MORR_TWO_MOMENT)) THEN + + ! ERM: check whether to use built-in droplet nucleation or use qndrop from CHEM + IF ( mp_physics==NSSL_2MOMCCN .or. mp_physics==NSSL_2MOM .or. mp_physics==NSSL_2MOMG ) THEN + IF ( progn > 0 ) THEN + IF ( .not. (chem_opt == 0 .or. chem_opt == 401) ) nssl_progn = .true. + ELSE + nssl_progn = .false. ! use NUCOND for droplet nucleation + ENDIF + ENDIF + + !Add pass for dust-only wrf-chem option - RAS + IF( (chem_opt==0 .OR. chem_opt==401) .AND. progn==1 .AND. (mp_physics==LINSCHEME .OR. mp_physics==MORR_TWO_MOMENT)) THEN IF( PRESENT( QNDROP_CURR ) ) THEN CALL wrf_debug ( 100 , 'microphysics_driver: calling prescribe_aerosol_mixactivate' ) ! 06-nov-2005 rce - id & itimestep added to arg list call prescribe_aerosol_mixactivate ( & id, itimestep, dt, naer, & + ccn_conc, chem_opt, & !RAS13.1 rho, th, pi_phy, w, cldfra, cldfra_old, & z, dz8w, p8w, t8w, exch_h, & qv_curr, qc_curr, qi_curr, qndrop_curr, & @@ -627,9 +671,13 @@ SUBROUTINE microphysics_driver( & its,ite, jts,jte, kts,kte, & F_QC=f_qc, F_QI=f_qi ) END IF - ELSE IF( progn==1 .AND. mp_physics/=LINSCHEME .AND. mp_physics/=MORR_TWO_MOMENT) THEN + ELSEIF ( (chem_opt==0 .OR. chem_opt==401) .AND. progn==1 .AND. (mp_physics==NSSL_2MOMCCN .or. & + mp_physics==NSSL_2MOM .or. mp_physics==NSSL_2MOMG)) THEN +! Do nothing here for the moment. Use activation of CCN within the NSSL_2MOM scheme instead, based on nssl_cccn namelist value. + ELSEIF ( progn==1 .AND. mp_physics/=LINSCHEME .AND. mp_physics/=MORR_TWO_MOMENT & + .AND. mp_physics/=NSSL_2MOM .AND. mp_physics/=NSSL_2MOMCCN .AND. mp_physics/=NSSL_2MOMG ) THEN call wrf_error_fatal( & - "SETTINGS ERROR: Prognostic cloud droplet number can only be used with the mp_physics=LINSCHEME or MORRISON.") + "SETTINGS ERROR: Prognostic cloud droplet number can only be used with the mp_physics=LINSCHEME or MORRISON or NSSL_2MOM.") END IF END IF @@ -671,7 +719,7 @@ SUBROUTINE microphysics_driver( & PRESENT( SNOWNC) .AND. PRESENT ( SNOWNCV) .AND. & PRESENT( GRAUPELNC).AND. PRESENT ( GRAUPELNCV) .AND. & PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) qv_b4mp(its:ite,kts:kte,jts:jte) = qv_curr(its:ite,kts:kte,jts:jte) qc_b4mp(its:ite,kts:kte,jts:jte) = qc_curr(its:ite,kts:kte,jts:jte) qi_b4mp(its:ite,kts:kte,jts:jte) = qi_curr(its:ite,kts:kte,jts:jte) @@ -704,7 +752,7 @@ SUBROUTINE microphysics_driver( & GRAUPELNC=GRAUPELNC, & GRAUPELNCV=GRAUPELNCV, & SR=SR, & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) RAINPROD=rainprod, & EVAPPROD=evapprod, & #endif @@ -733,7 +781,7 @@ SUBROUTINE microphysics_driver( & ! PRESENT( SNOWNC) .AND. PRESENT ( SNOWNCV) .AND. & ! PRESENT( GRAUPELNC) .AND. PRESENT ( GRAUPELNCV) .AND. & PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) ) THEN -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) qv_b4mp(its:ite,kts:kte,jts:jte) = qv_curr(its:ite,kts:kte,jts:jte) qc_b4mp(its:ite,kts:kte,jts:jte) = qc_curr(its:ite,kts:kte,jts:jte) qi_b4mp(its:ite,kts:kte,jts:jte) = qi_curr(its:ite,kts:kte,jts:jte) @@ -762,7 +810,7 @@ SUBROUTINE microphysics_driver( & GRAUPELNC=GRAUPELNC, & GRAUPELNCV=GRAUPELNCV, & SR=SR, & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) RAINPROD=rainprod, & EVAPPROD=evapprod, & #endif @@ -926,6 +974,9 @@ SUBROUTINE microphysics_driver( & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & ,QLSINK=qlsink & ! jdf for wrf-chem +#if ( WRF_CHEM == 1 ) + ,EVAPPROD=evapprod,RAINPROD=rainprod & +#endif ,PRECR=precr,PRECI=preci,PRECS=precs,PRECG=precg & ! jdf for wrf-chem ) ELSE @@ -951,6 +1002,7 @@ SUBROUTINE microphysics_driver( & CALL mp_milbrandt2mom_driver( & ITIMESTEP=itimestep, & + p8w=p8w, & TH=th, & QV=qv_curr, & QC=qc_curr, & @@ -1148,7 +1200,7 @@ SUBROUTINE microphysics_driver( & CASE (NSSL_2MOM) CALL wrf_debug(100, 'microphysics_driver: calling nssl2mom') IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. PRESENT (QNC_CURR) .AND. & + PRESENT (QC_CURR) .AND. PRESENT (QNdrop_CURR) .AND. & PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. & PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. & PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. & @@ -1159,7 +1211,8 @@ SUBROUTINE microphysics_driver( & PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & PRESENT (Z ) .AND. PRESENT ( W ) .AND. & - PRESENT (QVOLG_CURR) ) THEN + PRESENT (QVOLG_CURR) .AND. F_QVOLG .AND. & + PRESENT (QVOLH_CURR) .AND. F_QVOLH ) THEN CALL nssl_2mom_driver( & @@ -1172,13 +1225,15 @@ SUBROUTINE microphysics_driver( & QS=qs_curr, & QH=qg_curr, & QHL=qh_curr, & - CCW=qnc_curr, & + ! CCW=qnc_curr, & + CCW=qndrop_curr, & CRW=qnr_curr, & CCI=qni_curr, & CSW=qns_curr, & CHW=qng_curr, & CHL=qnh_curr, & VHW=qvolg_curr, & + VHL=qvolh_curr, & PII=pi_phy, & P=p, & W=w, & @@ -1195,11 +1250,90 @@ SUBROUTINE microphysics_driver( & GRPLNCV = GRAUPELNCV, & SR=SR, & dbz = refl_10cm, & +#if ( WRF_CHEM == 1 ) + EVAPPROD=evapprod,RAINPROD=rainprod, & +#endif + nssl_progn=nssl_progn, & diagflag = diagflag, & + re_cloud=re_cloud, & + re_ice=re_ice, & + re_snow=re_snow, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + + ELSE + Call wrf_error_fatal( 'arguments not present for calling nssl_2mom') + ENDIF + + CASE (NSSL_2MOMG) + CALL wrf_debug(100, 'microphysics_driver: calling nssl2mom') + IF (PRESENT (QV_CURR) .AND. & + PRESENT (QC_CURR) .AND. PRESENT (QNdrop_CURR) .AND. & + PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. & + PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. & + PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. & + PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. & + PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & + PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & + PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & + PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & + PRESENT (Z ) .AND. PRESENT ( W ) .AND. & + PRESENT (QVOLG_CURR) .AND. F_QVOLG ) THEN + + + CALL nssl_2mom_driver( & + ITIMESTEP=itimestep, & + TH=th, & + QV=qv_curr, & + QC=qc_curr, & + QR=qr_curr, & + QI=qi_curr, & + QS=qs_curr, & + QH=qg_curr, & + ! CCW=qnc_curr, & + CCW=qndrop_curr, & + CRW=qnr_curr, & + CCI=qni_curr, & + CSW=qns_curr, & + CHW=qng_curr, & + VHW=qvolg_curr, & + PII=pi_phy, & + P=p, & + W=w, & + DZ=dz8w, & + DTP=dt, & + DN=rho, & + RAINNC = RAINNC, & + RAINNCV = RAINNCV, & + SNOWNC = SNOWNC, & + SNOWNCV = SNOWNCV, & + HAILNC = HAILNC, & + HAILNCV = HAILNCV, & + GRPLNC = GRAUPELNC, & + GRPLNCV = GRAUPELNCV, & + SR=SR, & + dbz = refl_10cm, & +#if ( WRF_CHEM == 1 ) + EVAPPROD=evapprod,RAINPROD=rainprod, & +#endif + nssl_progn=nssl_progn, & + diagflag = diagflag, & + re_cloud=re_cloud, & + re_ice=re_ice, & + re_snow=re_snow, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & ) + ELSE Call wrf_error_fatal( 'arguments not present for calling nssl_2mom') ENDIF @@ -1207,7 +1341,7 @@ SUBROUTINE microphysics_driver( & CASE (NSSL_2MOMCCN) CALL wrf_debug(100, 'microphysics_driver: calling nssl_2momccn') IF (PRESENT (QV_CURR) .AND. & - PRESENT (QC_CURR) .AND. PRESENT (QNC_CURR) .AND. & + PRESENT (QC_CURR) .AND. PRESENT (QNDROP_CURR) .AND. & PRESENT (QR_CURR) .AND. PRESENT (QNR_CURR) .AND. & PRESENT (QI_CURR) .AND. PRESENT (QNI_CURR) .AND. & PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. & @@ -1218,7 +1352,9 @@ SUBROUTINE microphysics_driver( & PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & PRESENT (Z ) .AND. PRESENT ( W ) .AND. & - PRESENT (QVOLG_CURR) .AND. PRESENT( QNN_CURR ) ) THEN + PRESENT (QVOLG_CURR) .AND. F_QVOLG .AND. & + PRESENT (QVOLH_CURR) .AND. F_QVOLH .AND. & + PRESENT( QNN_CURR ) ) THEN CALL nssl_2mom_driver( & @@ -1231,13 +1367,15 @@ SUBROUTINE microphysics_driver( & QS=qs_curr, & QH=qg_curr, & QHL=qh_curr, & - CCW=qnc_curr, & +! CCW=qnc_curr, & + CCW=qndrop_curr, & CRW=qnr_curr, & CCI=qni_curr, & CSW=qns_curr, & CHW=qng_curr, & CHL=qnh_curr, & VHW=qvolg_curr, & + VHL=qvolh_curr, & cn=qnn_curr, & PII=pi_phy, & P=p, & @@ -1255,7 +1393,17 @@ SUBROUTINE microphysics_driver( & GRPLNCV = GRAUPELNCV, & SR=SR, & dbz = refl_10cm, & +#if ( WRF_CHEM == 1 ) + EVAPPROD=evapprod,RAINPROD=rainprod,& +#endif + nssl_progn=nssl_progn, & diagflag = diagflag, & + re_cloud=re_cloud, & + re_ice=re_ice, & + re_snow=re_snow, & + has_reqc=has_reqc, & ! ala G. Thompson + has_reqi=has_reqi, & ! ala G. Thompson + has_reqs=has_reqs, & ! ala G. Thompson IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde, & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme, & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -1411,6 +1559,14 @@ SUBROUTINE microphysics_driver( & ,RAIN=rainnc ,RAINNCV=rainncv & ,SNOW=snownc ,SNOWNCV=snowncv & ,SR=sr & +# ifndef _ACCEL + ,has_reqc=has_reqc & ! for radiation + + ,has_reqi=has_reqi & + ,has_reqs=has_reqs & + ,re_cloud=re_cloud & + ,re_ice=re_ice & + ,re_snow=re_snow & ! for radiation - +# endif ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -1443,11 +1599,17 @@ SUBROUTINE microphysics_driver( & ,RAIN=rainnc ,RAINNCV=rainncv & ,SNOW=snownc ,SNOWNCV=snowncv & ,SR=sr & -#ifndef _ACCEL +# ifndef _ACCEL ,REFL_10CM=refl_10cm & ! added for radar reflectivity ,diagflag=diagflag & ! added for radar reflectivity ,do_radar_ref=do_radar_ref & ! added for radar reflectivity -#endif + ,has_reqc=has_reqc & ! for radiation + + ,has_reqi=has_reqi & + ,has_reqs=has_reqs & + ,re_cloud=re_cloud & + ,re_ice=re_ice & + ,re_snow=re_snow & ! for radiation - +# endif ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -1485,6 +1647,12 @@ SUBROUTINE microphysics_driver( & ,diagflag=diagflag & ! added for radar reflectivity ,do_radar_ref=do_radar_ref & ! added for radar reflectivity ,GRAUPEL=graupelnc ,GRAUPELNCV=graupelncv & + ,has_reqc=has_reqc & ! for radiation + + ,has_reqi=has_reqi & + ,has_reqs=has_reqs & + ,re_cloud=re_cloud & + ,re_ice=re_ice & + ,re_snow=re_snow & ! for radiation - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -1511,7 +1679,7 @@ SUBROUTINE microphysics_driver( & ,NC=qnc_curr & ,NR=qnr_curr & ,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w & - ,DELT=dt,G=g,CPD=cp,CPV=cpv,CCN0=n_ccn0 & + ,DELT=dt,G=g,CPD=cp,CPV=cpv,CCN0=ccn_conc & ! RAS ,RD=r_d,RV=r_v,T0C=svpt0 & ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & ,XLS=xls, XLV0=xlv, XLF0=xlf & @@ -1523,6 +1691,12 @@ SUBROUTINE microphysics_driver( & ,REFL_10CM=refl_10cm & ! added for radar reflectivity ,diagflag=diagflag & ! added for radar reflectivity ,do_radar_ref=do_radar_ref & ! added for radar reflectivity + ,has_reqc=has_reqc & ! for radiation + + ,has_reqi=has_reqi & + ,has_reqs=has_reqs & + ,re_cloud=re_cloud & + ,re_ice=re_ice & + ,re_snow=re_snow & ! for radiation - ,ITIMESTEP=itimestep & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & @@ -1552,7 +1726,7 @@ SUBROUTINE microphysics_driver( & ,NC=qnc_curr & ,NR=qnr_curr & ,DEN=rho,PII=pi_phy,P=p,DELZ=dz8w & - ,DELT=dt,G=g,CPD=cp,CPV=cpv,CCN0=n_ccn0 & + ,DELT=dt,G=g,CPD=cp,CPV=cpv,CCN0=ccn_conc & ! RAS ,RD=r_d,RV=r_v,T0C=svpt0 & ,EP1=ep_1, EP2=ep_2, QMIN=epsilon & ,XLS=xls, XLV0=xlv, XLF0=xlf & @@ -1566,6 +1740,12 @@ SUBROUTINE microphysics_driver( & ,do_radar_ref=do_radar_ref & ! added for radar reflectivity ,GRAUPEL=graupelnc ,GRAUPELNCV=graupelncv & ,ITIMESTEP=itimestep & + ,has_reqc=has_reqc & ! for radiation + + ,has_reqi=has_reqi & + ,has_reqs=has_reqs & + ,re_cloud=re_cloud & + ,re_ice=re_ice & + ,re_snow=re_snow & ! for radiation - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & @@ -1641,12 +1821,12 @@ SUBROUTINE microphysics_driver( & PRESENT( f_qi ) .AND. PRESENT( qnc_curr ) .AND. & PRESENT( RAINNCV ) .AND. PRESENT( SNOWNCV ) .AND. & PRESENT( qns_curr ) .AND. PRESENT( qnr_curr ) .AND. & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) PRESENT( chem ) .AND. PRESENT(dgnum4D ) .AND. & PRESENT( dgnumwet4D ) .AND. & #endif PRESENT( qni_curr ) .AND. PRESENT( RAINNC ) ) THEN -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) qv_b4mp(its:ite,kts:kte,jts:jte) = qv_curr(its:ite,kts:kte,jts:jte) qc_b4mp(its:ite,kts:kte,jts:jte) = qc_curr(its:ite,kts:kte,jts:jte) qi_b4mp(its:ite,kts:kte,jts:jte) = qi_curr(its:ite,kts:kte,jts:jte) @@ -1663,7 +1843,7 @@ SUBROUTINE microphysics_driver( & ,CMFMC3D=cmfmc3d,CMFMC2_3D=cmfmc2_3d & ,CONFIG_FLAGS=config_flags,F_ICE_PHY=f_ice_phy & ,F_RAIN_PHY=f_rain_phy & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ,DGNUM4D=dgnum4D,DGNUMWET4D=dgnumwet4D & #endif ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & @@ -1679,7 +1859,7 @@ SUBROUTINE microphysics_driver( & ,QS_CURR=qs_curr,QR_CURR=qr_curr,NC3D=qnc_curr & ,NI3D=qni_curr,NS3D=qns_curr,NR3D=qnr_curr,QNDROP=qndrop_curr& ,RH_OLD_MP=rh_old_mp,LCD_OLD_MP=lcd_old_mp & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ,CHEM=chem & ,QME3D=qme3d,PRAIN3D=prain3d,NEVAPR3D=nevapr3d & ,RATE1ORD_CW2PR_ST3D=rate1ord_cw2pr_st3d & @@ -1691,36 +1871,6 @@ SUBROUTINE microphysics_driver( & ENDIF #endif - CASE (ETAMPOLD) !-- What was run in the operational NAM (WRF NMM) - CALL wrf_debug ( 100 , 'microphysics_driver: calling etampold') - - IF ( PRESENT( qv_curr ) .AND. PRESENT( qt_curr ) .AND. & - PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & - PRESENT( mp_restart_state ) .AND. & - PRESENT( tbpvs_state ) .AND. & - PRESENT( tbpvs0_state ) ) THEN - CALL ETAMP_OLD( & - ITIMESTEP=itimestep,DT=dt,DX=dx,DY=dy & - ,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,PI_PHY=pi_phy,TH_PHY=th & - ,QV=qv_curr & - ,QC=qc_curr & - ,QS=qs_curr & - ,QR=qr_curr & - ,QT=qt_curr & - ,LOWLYR=LOWLYR,SR=SR & - ,F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY & - ,F_RIMEF_PHY=F_RIMEF_PHY & - ,RAINNC=rainnc,RAINNCV=rainncv & - ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & - ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & - ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & - ,MP_RESTART_STATE=mp_restart_state & - ,TBPVS_STATE=tbpvs_state,TBPVS0_STATE=tbpvs0_state & - ) - ELSE - CALL wrf_error_fatal ( 'arguments not present for calling etampold' ) - ENDIF - CASE DEFAULT WRITE( wrf_err_message , * ) 'The microphysics option does not exist: mp_physics = ', mp_physics @@ -1735,6 +1885,25 @@ SUBROUTINE microphysics_driver( & ENDIF #endif +! by ZCX +! IF ( PRESENT (LWP) ) THEN +! DO ij = 1 , num_tiles +! its = i_start(ij) +! ite = i_end(ij) +! jts = j_start(ij) +! jte = j_end(ij) +! DO j=jts,jte +! DO i=its,ite +! lwp(i,j) = 0.0 +! do k=kts,kte +! lwp(i,j)=lwp(i,j)+qc_curr(i,k,j)*rho(i,k,j)*dz8w(i,k,j) +! end do +! ENDDO +! ENDDO +! ENDDO +! ENDIF +! ZCX + CALL wrf_debug ( 200 , 'microphysics_driver: returning from' ) RETURN diff --git a/wrfv2_fire/phys/module_mixactivate.F b/wrfv2_fire/phys/module_mixactivate.F index ababfc10..8bdc8bbc 100644 --- a/wrfv2_fire/phys/module_mixactivate.F +++ b/wrfv2_fire/phys/module_mixactivate.F @@ -11,7 +11,7 @@ MODULE module_mixactivate PRIVATE -PUBLIC prescribe_aerosol_mixactivate, mixactivate +PUBLIC prescribe_aerosol_mixactivate, mixactivate, activate !BSINGH - added 'activate' for WRFCuP scheme CONTAINS @@ -21,14 +21,15 @@ MODULE module_mixactivate ! 25-apr-2006 rce - dens_aer is (g/cm3), NOT (kg/m3) subroutine prescribe_aerosol_mixactivate ( & grid_id, ktau, dtstep, naer, & + ccn_conc, chem_opt, & ! RAS rho_phy, th_phy, pi_phy, w, cldfra, cldfra_old, & z, dz8w, p_at_w, t_at_w, exch_h, & - qv, qc, qi, qndrop3d, & + qv, qc, qi, qndrop3d, & nsource, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - f_qc, f_qi ) + f_qc, f_qi, cn ) ! USE module_configure @@ -45,6 +46,8 @@ subroutine prescribe_aerosol_mixactivate ( & real, intent(in) :: dtstep real, intent(inout) :: naer ! aerosol number (/kg) + real, intent(in) :: ccn_conc ! CCN conc set within namelist + integer, optional, intent(in) :: chem_opt real, intent(in), & dimension( ims:ime, kms:kme, jms:jme ) :: & @@ -58,6 +61,10 @@ subroutine prescribe_aerosol_mixactivate ( & dimension( ims:ime, kms:kme, jms:jme ) :: & qv, qc, qi + real, intent(inout), optional, & + dimension( ims:ime, kms:kme, jms:jme ) :: & + cn ! single-size CCN concentration + real, intent(inout), & dimension( ims:ime, kms:kme, jms:jme ) :: & qndrop3d @@ -99,9 +106,12 @@ subroutine prescribe_aerosol_mixactivate ( & integer ptr real maer - if(naer.lt.1.)then - naer=1000.e6 ! #/kg default value - endif +! if(naer.lt.1.)then +! naer=1000.e6 ! #/kg default value +! endif + IF ( (naer.lt.1.) .OR. ( PRESENT(chem_opt) .AND. (chem_opt.eq.401))) THEN + naer = ccn_conc !CCN value set in namelist + ENDIF ai_phase=1 cw_phase=2 idrydep_onoff = 0 @@ -136,14 +146,19 @@ subroutine prescribe_aerosol_mixactivate ( & do m=1,nsize_aer(n) ptr=ptr+1 numptr_aer( m, n, p )=ptr - if(p.eq.ai_phase)then - chem(its:ite,kts:kte,jts:jte,ptr)=naer - else - chem(its:ite,kts:kte,jts:jte,ptr)=0. - endif - end do ! size - end do ! type - end do ! phase + + if(p.eq.ai_phase)then + IF ( present( cn ) ) THEN + chem(its:ite,kts:kte,jts:jte,ptr) = cn(its:ite,kts:kte,jts:jte) + ELSE ! ERM: use qndrop3d as a proxy for number of activated CCN + chem(its:ite,kts:kte,jts:jte,ptr) = Max(0.0, naer-qndrop3d(its:ite,kts:kte,jts:jte) ) + ENDIF + else + chem(its:ite,kts:kte,jts:jte,ptr)=0. + endif + end do ! size + end do ! type + end do ! phase do p=1,maxd_aphase do n=1,ntype_aer do m=1,nsize_aer(n) @@ -158,12 +173,18 @@ subroutine prescribe_aerosol_mixactivate ( & ! 1.e6 factor converts g to ug maer= 1.0e6 * naer * dens_aer(l,n) * ( (3.1416/6.) * & (dgnum_aer(m,n)**3) * exp( 4.5*((log(sigmag_aer(m,n)))**2) ) ) - if(p.eq.ai_phase)then - chem(its:ite,kts:kte,jts:jte,ptr)=maer - else - chem(its:ite,kts:kte,jts:jte,ptr)=0. - endif - end do + if(p.eq.ai_phase)then + IF ( present( cn ) ) THEN + chem(its:ite,kts:kte,jts:jte,ptr) = 1.0e6 * cn(its:ite,kts:kte,jts:jte)* dens_aer(l,n) * ( (3.1416/6.) * & + (dgnum_aer(m,n)**3) * exp( 4.5*((log(sigmag_aer(m,n)))**2) ) ) + ELSE ! ERM: use qndrop3d as a proxy for number of activated CCN + chem(its:ite,kts:kte,jts:jte,ptr) = 1.0e6 * Max(0.0, naer -qndrop3d(its:ite,kts:kte,jts:jte))* & + dens_aer(l,n) * ( (3.1416/6.) *(dgnum_aer(m,n)**3) * exp( 4.5*((log(sigmag_aer(m,n)))**2) ) ) + ENDIF + else + chem(its:ite,kts:kte,jts:jte,ptr)=0. + endif + end do end do ! size end do ! type end do ! phase @@ -200,6 +221,11 @@ subroutine prescribe_aerosol_mixactivate ( & F_QC=f_qc, F_QI=f_qi ) + ! ERM : If CCN field was passed in, then copy back the new field, which is the first + IF ( present( cn ) ) THEN + cn(its:ite,kts:kte,jts:jte) = Max(0.0, chem(its:ite,kts:kte,jts:jte,1)) + ENDIF + end subroutine prescribe_aerosol_mixactivate !---------------------------------------------------------------------- @@ -1343,7 +1369,7 @@ subroutine activate(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & msectional, maxd_atype, ntype_aer, maxd_asize, nsize_aer, & na, volc, dlo_sect,dhi_sect,sigman, hygro, & fn, fs, fm, fluxn, fluxs, fluxm, flux_fullact, & - grid_id, ktau, ii, jj, kk ) + grid_id, ktau, ii, jj, kk,smax_prescribed )!BSINGH - Added smax_prescribed for WRFCuP ! calculates number, surface, and mass fraction of aerosols activated as CCN ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud @@ -1385,6 +1411,7 @@ subroutine activate(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & real,intent(in) :: volc(maxd_asize,maxd_atype) ! total aerosol volume concentration (m3/m3) real,intent(in) :: dlo_sect( maxd_asize, maxd_atype ), & ! minimum size of section (cm) dhi_sect( maxd_asize, maxd_atype ) ! maximum size of section (cm) + real,intent(in),optional :: smax_prescribed ! prescribed max. supersaturation for secondary activation !BSINGH - Added for WRFCuP ! output @@ -1533,6 +1560,26 @@ subroutine activate(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & else isectional = 0 endif + !BSINGH - For WRFCuP + if ( present( smax_prescribed ) ) then + if (smax_prescribed <= 0.0) then + do n=1,ntype_aer + do m=1,nsize_aer(n) + fluxn(m,n)=0. + fn(m,n)=0. + fluxs(m,n)=0. + fs(m,n)=0. + fluxm(m,n)=0. + fm(m,n)=0. + end do + end do + flux_fullact=0. + return + end if + end if + + !BSINGH - ENDS + do n=1,ntype_aer ! print *,'ntype_aer,n,nsize_aer(n)=',ntype_aer,n,nsize_aer(n) @@ -1920,8 +1967,16 @@ subroutine activate(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & eta(1,n)=1.e10 endif enddo - call maxsat(zeta,eta,maxd_atype,ntype_aer, & - maxd_asize,(/1/),gmsm,gmlnsig,f1,smax) + !BSINGH - For WRFCuP scheme + ! use smax_prescribed if it is present; otherwise get smax from subr maxsat + if ( present( smax_prescribed ) ) then + smax = smax_prescribed + else + !BSINGH -ENDS + + call maxsat(zeta,eta,maxd_atype,ntype_aer, & + maxd_asize,(/1/),gmsm,gmlnsig,f1,smax) + endif lnsmax=log(smax) x=2*(log(gmsm(1))-lnsmax)/(3*sq2*gmlnsig(1)) fnew=0.5*(1.-ERF_ALT(x)) @@ -1933,9 +1988,14 @@ subroutine activate(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & eta(m,n)=etafactor1*etafactor2(m,n) enddo enddo - - call maxsat(zeta,eta,maxd_atype,ntype_aer, & - maxd_asize,nsize_aer,sm,alnsign,f1,smax) + !BSINGH - For WRFCuP scheme + if ( present( smax_prescribed ) ) then + smax = smax_prescribed + else + !BSINGH -ENDS + call maxsat(zeta,eta,maxd_atype,ntype_aer, & + maxd_asize,nsize_aer,sm,alnsign,f1,smax) + endif ! write(6,*)'w,smax=',w,smax lnsmax=log(smax) @@ -2297,8 +2357,15 @@ subroutine activate(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & eta(1,n)=1.e10 endif end do - call maxsat(zeta,eta,maxd_atype,ntype_aer, & - maxd_asize,(/1/),gmsm,gmlnsig,f1,smax) + !BSINGH - For WRFCuP + ! use smax_prescribed if it is present; otherwise get smax from subr maxsat + if ( present( smax_prescribed ) ) then + smax = smax_prescribed + else + !BSINGH -ENDS + call maxsat(zeta,eta,maxd_atype,ntype_aer, & + maxd_asize,(/1/),gmsm,gmlnsig,f1,smax) + endif else @@ -2311,9 +2378,16 @@ subroutine activate(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & endif end do end do - - call maxsat(zeta,eta,maxd_atype,ntype_aer, & - maxd_asize,nsize_aer,sm,alnsign,f1,smax) + !BSINGH - For WRFCuP + ! use smax_prescribed if it is present; otherwise get smax from subr maxsat + if ( present( smax_prescribed ) ) then + smax = smax_prescribed + else + !BSINGH -ENDS + + call maxsat(zeta,eta,maxd_atype,ntype_aer, & + maxd_asize,nsize_aer,sm,alnsign,f1,smax) + endif endif diff --git a/wrfv2_fire/phys/module_mp_cammgmp_driver.F b/wrfv2_fire/phys/module_mp_cammgmp_driver.F index cf3059bb..0987df60 100644 --- a/wrfv2_fire/phys/module_mp_cammgmp_driver.F +++ b/wrfv2_fire/phys/module_mp_cammgmp_driver.F @@ -36,12 +36,12 @@ module module_mp_cammgmp_driver use shr_kind_mod, only: r8=>shr_kind_r8 use physconst, only: gravit use module_cam_support, only: pcnst =>pcnst_mp, pcols, pver, pverp -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) use module_cam_support, only: cam_mam_aerosols #endif use constituents, only: cnst_get_ind, cnst_name, qmin -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) use module_state_description, only: num_chem, param_first_scalar, & CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM7_AQ, CBMZ_CAM_MAM3_NOAQ, & CBMZ_CAM_MAM3_AQ @@ -54,7 +54,7 @@ module module_mp_cammgmp_driver public :: CAMMGMP_INIT public :: CAMMGMP -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) public :: physics_ptend_init ! Mimics CAM's physics ptend init. Also used in wet scavaging code in WRF_CHEM public :: physics_update ! Mimics CAM's physics update. Also used in wet scavaging code in WRF_CHEM #endif @@ -102,7 +102,7 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & , aitken_mode, coarse_mode, icwmrsh3d & , icwmrdp3d, shfrc3d, cmfmc3d, cmfmc2_3d & , config_flags, f_ice_phy, f_rain_phy & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) , dgnum4d, dgnumwet4d & #endif , ids, ide, jds, jde, kds, kde & @@ -116,7 +116,7 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & , qv_curr, qc_curr, qi_curr,qs_curr & , qr_curr, nc3d, ni3d,ns3d,nr3d,qndrop & , rh_old_mp,lcd_old_mp & !PMA- added for macrophysics -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) , chem & , qme3d,prain3d,nevapr3d & , rate1ord_cw2pr_st3d & @@ -149,7 +149,7 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & nspec_amode => nspec_amode_mp #endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) use module_data_cam_mam_asect, only: lptr_chem_to_q, lptr_chem_to_qqcw, factconv_chem_to_q #endif @@ -202,7 +202,7 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: icwmrsh3d !Shallow cumulus in-cloud water mixing ratio (kg/m2) real, dimension( ims:ime, kms:kme, jms:jme ), intent(in) :: icwmrdp3d !Deep Convection in-cloud water mixing ratio (kg/m2) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) real, dimension( ims:ime, kms:kme, jms:jme, ntot_amode ), intent(in) :: dgnum4d, dgnumwet4d ! 4-dimensional Number mode diameters #endif !2d in-outs @@ -234,14 +234,14 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: iradius real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: cldfrai real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: cldfral -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: qme3d !Net condensation rate (kg/kg/s) real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: prain3d !Rate of conversion of condensate to precipitation (kg/kg/s) real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: nevapr3d !Evaporation rate of rain + snow (kg/kg/s) real, dimension( ims:ime, kms:kme, jms:jme ), intent(inout) :: rate1ord_cw2pr_st3d !1st order rate for direct conversion of strat. cloud water to precip (1/s) #endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !4d in-outs real, dimension( ims:ime, kms:kme, jms:jme, num_chem ), intent(inout) :: chem !Chem array #endif @@ -259,7 +259,7 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & logical :: ptend_loc_ls, ptend_all_ls !Flag for updating tendencies logical :: ptend_loc_lq(pcnst),ptend_all_lq(pcnst) !Flag for updating tendencies integer :: i,k,m,n,iw,jw,kw,imode,itsm1,itile_len,ktep1,kflip,ips,kcam -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) integer :: p1st,l2 !For iterating loop of NUM_CHEM for CHEM array #endif integer :: lchnk !Chunk identifier @@ -576,12 +576,12 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & !*** IMPORTANT-WARNING *** :Should be in the namelist file. Hardwired currently conv_water_in_rad = 1 -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) p1st = param_first_scalar ! Obtain CHEM array's first element's index #endif ! Specify diameter for each mode -#ifndef WRF_CHEM +#if ( WRF_CHEM != 1 ) dgnumwet(:,:,:) = 0.1e-6_r8 !*** IMPORTANT-WARNING *** :Constant value for the whole domain (prescribed value). The value match precribe_aerosol_mixactivate, but units change dgnumwet(:,:,modeptr_aitken) = 0.02e-6 dgnumwet(:,:,modeptr_coarse) = 1.0e-6 @@ -602,7 +602,7 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & !default values for radius lradius(:,:,:) = 10._r8 - iradius(:,:,:) = 25._r8 + iradius(:,:,:) = 70._r8 !Flag for first time step is_first_step = .false. @@ -714,7 +714,7 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & endif ! For prescribed aerosols qqcw(1,kflip,:) = 1.e-38_r8 !used in microp_aero for dropmicnuc, presently set to a constant value -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) if(chem_opt.NE.0 .and. config_flags%CAM_MP_MAM_cpled ) then !Following Do-Loop is obtained from chem/module_cam_mam_aerchem_driver.F do l = p1st, num_chem @@ -904,7 +904,7 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & #endif #ifdef MODAL_AERO -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) do m = 1, ntot_amode lnum = numptr_amode(m) if( lnum > 0 ) then @@ -938,7 +938,7 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & aist_mic(:ncol,:pver) = aist(:ncol,:pver) endif -#ifndef WRF_CHEM +#if ( WRF_CHEM != 1 ) !Adding 7 new fields to state1_q(# mixing ratio and mass mixing ratio !for 3 modes of prescribed aerosols[s04,dust(+sea salt),aitken]) array. !state%q holds 5 constituents already therefore the prescribed aerosol @@ -1354,7 +1354,7 @@ subroutine CAMMGMP(itimestep, dt, p8w, p_hyd & lradius(iw,kw,jw) = efcout(1,kflip) iradius(iw,kw,jw) = efiout(1,kflip) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) if(chem_opt .NE. 0 .and. config_flags%CAM_MP_MAM_cpled ) then do l = p1st, num_chem l2 = lptr_chem_to_q(l) @@ -2148,7 +2148,7 @@ subroutine CAMMGMP_INIT(ixcldliq_in,ixcldice_in & call ini_microp_aero #ifdef MODAL_AERO -#ifndef WRF_CHEM +#if ( WRF_CHEM != 1 ) !When WRF_CHEM is 1, activate_init is called from MODULE_CAM_MAM_INIT after initializing aerosols call activate_init #else diff --git a/wrfv2_fire/phys/module_mp_etanew.F b/wrfv2_fire/phys/module_mp_etanew.F index 1910e1aa..b5adac4c 100644 --- a/wrfv2_fire/phys/module_mp_etanew.F +++ b/wrfv2_fire/phys/module_mp_etanew.F @@ -1189,7 +1189,7 @@ SUBROUTINE EGCP01COLUMN ( ARAIN, ASNOW, DTPH, I_index, J_index, & !--- Collection of cloud water by large ice particles ("snow") ! PIACWI=PIACW for riming, PIACWI=0 for shedding ! - FWS=MIN(.1, CIACW*VEL_INC*NLICE*ACCRI(INDEXS)/PP**C1) + FWS=MIN(1., CIACW*VEL_INC*NLICE*ACCRI(INDEXS)/PP**C1) PIACW=FWS*QW IF (TC .LT. 0.) PIACWI=PIACW ! Large ice riming ENDIF ! End IF (QLICE .GT. EPSQ) @@ -1550,7 +1550,7 @@ SUBROUTINE EGCP01COLUMN ( ARAIN, ASNOW, DTPH, I_index, J_index, & PREVP=MAX(DUM, PRLOSS) ELSE IF (QW .GT. EPSQ) THEN FWR=CRACW*GAMMAR*N0r*ACCRR(INDEXR) - PRACW=MIN(.1,FWR)*QW + PRACW=MIN(1.0,FWR)*QW ENDIF ! End IF (DWVr.LT.0. .AND. DUM.LE.EPSQ) ! IF (TC.LT.0. .AND. TCC.LT.0.) THEN @@ -2311,15 +2311,15 @@ SUBROUTINE ETANEWinit (GSMDT,DT,DELX,DELY,LOWLYR,restart, & ! !--- CIACW is used in calculating riming rates ! The assumed effective collection efficiency of cloud water rimed onto -! ice is =0.1 : +! ice is =0.5 : ! - CIACW=0.1*DTPH*0.25*PI*(1.E5)**C1 + CIACW=0.5*DTPH*0.25*PI*(1.E5)**C1 ! -!--- CIACR is used in calculating freezing of rain colliding with large ice -! The assumed collection efficiency is 0.5 +!--- CIACR is us5d in calculating freezing of rain colliding with large ice +! The assumed collection efficiency is 1.0 ! - CIACR=0.5*PI*DTPH + CIACR=1.0*PI*DTPH ! !--- Based on rain lookup tables for mean diameters from 0.05 to 1.0 mm ! * Four different functional relationships of mean drop diameter as @@ -2350,9 +2350,9 @@ SUBROUTINE ETANEWinit (GSMDT,DT,DELX,DELY,LOWLYR,restart, & CN0r_DMRmax=1./(PI*RHOL*DMRmax**4) ! !--- CRACW is used in calculating collection of cloud water by rain (an -! assumed collection efficiency of 0.1) +! assumed collection efficiency of 1.0) ! - CRACW=0.1*DTPH*0.25*PI + CRACW=1.0*DTPH*0.25*PI ! ESW0=1000.*FPVS0(T0C) ! Saturation vapor pressure at 0C RFmax=1.1**Nrime ! Maximum rime factor allowed diff --git a/wrfv2_fire/phys/module_mp_etaold.F b/wrfv2_fire/phys/module_mp_etaold.F deleted file mode 100644 index 0403ff61..00000000 --- a/wrfv2_fire/phys/module_mp_etaold.F +++ /dev/null @@ -1,2623 +0,0 @@ -!WRF:MODEL_MP:PHYSICS -! -MODULE module_mp_etaold -! -!----------------------------------------------------------------------- - REAL,PRIVATE,SAVE :: ABFR, CBFR, CIACW, CIACR, C_N0r0, & - & CN0r0, CN0r_DMRmin, CN0r_DMRmax, CRACW, CRAUT, ESW0, & - & RFmax, RQR_DR1, RQR_DR2, RQR_DR3, RQR_DRmin, & - & RQR_DRmax, RR_DRmin, RR_DR1, RR_DR2, RR_DR3, RR_DRmax -! - INTEGER, PRIVATE,PARAMETER :: MY_T1=1, MY_T2=35 - REAL,PRIVATE,DIMENSION(MY_T1:MY_T2),SAVE :: MY_GROWTH -! - REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, & - & DelDMI=1.e-6,XMImin=1.e6*DMImin, XMIexp=.0536 - INTEGER, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax, & - & MDImin=XMImin, MDImax=XMImax - REAL, PRIVATE,DIMENSION(MDImin:MDImax) :: & - & ACCRI,SDENS,VSNOWI,VENTI1,VENTI2 -! - REAL, PRIVATE,PARAMETER :: DMRmin=.05e-3, DMRmax=.45e-3, & - & DelDMR=1.e-6,XMRmin=1.e6*DMRmin, XMRmax=1.e6*DMRmax - INTEGER, PRIVATE,PARAMETER :: MDRmin=XMRmin, MDRmax=XMRmax - REAL, PRIVATE,DIMENSION(MDRmin:MDRmax):: & - & ACCRR,MASSR,RRATE,VRAIN,VENTR1,VENTR2 -! - INTEGER, PRIVATE,PARAMETER :: Nrime=40 - REAL, DIMENSION(2:9,0:Nrime),PRIVATE,SAVE :: VEL_RF -! - INTEGER,PARAMETER :: NX=7501 - REAL, PARAMETER :: XMIN=180.0,XMAX=330.0 - REAL, DIMENSION(NX),SAVE :: TBPVS,TBPVS0 - REAL, SAVE :: C1XPVS0,C2XPVS0,C1XPVS,C2XPVS -! - REAL, PRIVATE,PARAMETER :: & -!--- Physical constants follow: - & CP=1004.6, EPSQ=1.E-12, GRAV=9.806, RHOL=1000., RD=287.04 & - & ,RV=461.5, T0C=273.15, XLS=2.834E6 & -!--- Derived physical constants follow: - & ,EPS=RD/RV, EPS1=RV/RD-1., EPSQ1=1.001*EPSQ & - & ,RCP=1./CP, RCPRV=RCP/RV, RGRAV=1./GRAV, RRHOL=1./RHOL & - & ,XLS1=XLS*RCP, XLS2=XLS*XLS*RCPRV, XLS3=XLS*XLS/RV & -!--- Constants specific to the parameterization follow: -!--- CLIMIT/CLIMIT1 are lower limits for treating accumulated precipitation - & ,CLIMIT=10.*EPSQ, CLIMIT1=-CLIMIT & - & ,C1=1./3. & - & ,DMR1=.1E-3, DMR2=.2E-3, DMR3=.32E-3 & - & ,XMR1=1.e6*DMR1, XMR2=1.e6*DMR2, XMR3=1.e6*DMR3 - INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3 -! -! ====================================================================== -!--- Important tunable parameters that are exported to other modules -! * RHgrd - threshold relative humidity for onset of condensation -! * T_ICE - temperature (C) threshold at which all remaining liquid water -! is glaciated to ice -! * T_ICE_init - maximum temperature (C) at which ice nucleation occurs -! * NLImax - maximum number concentrations (m**-3) of large ice (snow/graupel/sleet) -! * NLImin - minimum number concentrations (m**-3) of large ice (snow/graupel/sleet) -! * N0r0 - assumed intercept (m**-4) of rain drops if drop diameters are between 0.2 and 0.45 mm -! * N0rmin - minimum intercept (m**-4) for rain drops -! * NCW - number concentrations of cloud droplets (m**-3) -! * FLARGE1, FLARGE2 - number fraction of large ice to total (large+snow) ice -! at T>0C and in presence of sublimation (FLARGE1), otherwise in -! presence of ice saturated/supersaturated conditions -! ====================================================================== - REAL, PUBLIC,PARAMETER :: & - & RHgrd=1. & - & ,T_ICE=-40. & - & ,T_ICEK=T0C+T_ICE & - & ,T_ICE_init=-5. & - & ,NLImax=5.E3 & - & ,NLImin=1.E3 & - & ,N0r0=8.E6 & - & ,N0rmin=1.E4 & - & ,NCW=100.E6 & - & ,FLARGE1=1. & - & ,FLARGE2=.03 ! Improved simulated GOES radiances -!--- Other public variables passed to other routines: - REAL,PUBLIC,SAVE :: QAUT0 - REAL, PUBLIC,DIMENSION(MDImin:MDImax) :: MASSI -! -! - CONTAINS - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - SUBROUTINE ETAMP_OLD (itimestep,DT,DX,DY, & - & dz8w,rho_phy,p_phy,pi_phy,th_phy,qv,qt, & - & LOWLYR,SR, & - & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & - & QC,QR,QS, & - & mp_restart_state,tbpvs_state,tbpvs0_state, & - & RAINNC,RAINNCV, & - & ids,ide, jds,jde, kds,kde, & - & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte ) -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- - INTEGER, PARAMETER :: ITLO=-60, ITHI=40 - - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE & - & ,ITIMESTEP - - REAL, INTENT(IN) :: DT,DX,DY - REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: & - & dz8w,p_phy,pi_phy,rho_phy - REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme):: & - & th_phy,qv,qt - REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & - & qc,qr,qs - REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & - & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY - REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: & - & RAINNC,RAINNCV - REAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme):: SR -! - REAL,DIMENSION(*),INTENT(INOUT) :: MP_RESTART_STATE -! - REAL,DIMENSION(nx),INTENT(INOUT) :: TBPVS_STATE,TBPVS0_STATE -! - INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR - -!----------------------------------------------------------------------- -! LOCAL VARS -!----------------------------------------------------------------------- - -! NSTATS,QMAX,QTOT are diagnostic vars - - INTEGER,DIMENSION(ITLO:ITHI,4) :: NSTATS - REAL, DIMENSION(ITLO:ITHI,5) :: QMAX - REAL, DIMENSION(ITLO:ITHI,22):: QTOT - -! SOME VARS WILL BE USED FOR DATA ASSIMILATION (DON'T NEED THEM NOW). -! THEY ARE TREATED AS LOCAL VARS, BUT WILL BECOME STATE VARS IN THE -! FUTURE. SO, WE DECLARED THEM AS MEMORY SIZES FOR THE FUTURE USE - -! TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related -! the microphysics scheme. Instead, they will be used by Eta precip -! assimilation. - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: & - & TLATGS_PHY,TRAIN_PHY - REAL, DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC - REAL, DIMENSION(its:ite, kts:kte, jts:jte):: t_phy - - INTEGER :: I,J,K,KFLIP - REAL :: WC -! -!----------------------------------------------------------------------- -!********************************************************************** -!----------------------------------------------------------------------- -! - MY_GROWTH(MY_T1:MY_T2)=MP_RESTART_STATE(MY_T1:MY_T2) -! - C1XPVS0=MP_RESTART_STATE(MY_T2+1) - C2XPVS0=MP_RESTART_STATE(MY_T2+2) - C1XPVS =MP_RESTART_STATE(MY_T2+3) - C2XPVS =MP_RESTART_STATE(MY_T2+4) - CIACW =MP_RESTART_STATE(MY_T2+5) - CIACR =MP_RESTART_STATE(MY_T2+6) - CRACW =MP_RESTART_STATE(MY_T2+7) - CRAUT =MP_RESTART_STATE(MY_T2+8) -! - TBPVS(1:NX) =TBPVS_STATE(1:NX) - TBPVS0(1:NX)=TBPVS0_STATE(1:NX) -! - DO j = jts,jte - DO k = kts,kte - DO i = its,ite - t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j) - qv(i,k,j)=qv(i,k,j)/(1.+qv(i,k,j)) !Convert to specific humidity - ENDDO - ENDDO - ENDDO - -! initial diagnostic variables and data assimilation vars -! (will need to delete this part in the future) - - DO k = 1,4 - DO i = ITLO,ITHI - NSTATS(i,k)=0. - ENDDO - ENDDO - - DO k = 1,5 - DO i = ITLO,ITHI - QMAX(i,k)=0. - ENDDO - ENDDO - - DO k = 1,22 - DO i = ITLO,ITHI - QTOT(i,k)=0. - ENDDO - ENDDO - -! initial data assimilation vars (will need to delete this part in the future) - - DO j = jts,jte - DO k = kts,kte - DO i = its,ite - TLATGS_PHY (i,k,j)=0. - TRAIN_PHY (i,k,j)=0. - ENDDO - ENDDO - ENDDO - - DO j = jts,jte - DO i = its,ite - ACPREC(i,j)=0. - APREC (i,j)=0. - PREC (i,j)=0. - SR (i,j)=0. - ENDDO - ENDDO - -!-- NOTE: ARW QT has been advected, while QR, QS and QC have not -! -!-- Update QT, F_ice, F_rain arrays for WRF NMM only - -#if (NMM_CORE==1) -! -!-- NOTE: The total ice array in this code is "QS" because the vast -! majority of the ice mass is in the form of snow, and using -! the "QS" array should result in better coupling with the -! Dudhia SW package. NMM calls microphysics after other -! physics, so use updated QR, QS and QC to update QT array. -! - DO j = jts,jte - DO k = kts,kte - DO i = its,ite - QT(I,K,J)=QC(I,K,J)+QR(I,K,J)+QS(I,K,J) - IF (QS(I,K,J) <= EPSQ) THEN - F_ICE_PHY(I,K,J)=0. - IF (T_PHY(I,K,J) < T_ICEK) F_ICE_PHY(I,K,J)=1. - ELSE - F_ICE_PHY(I,K,J)=MAX( 0., MIN(1., QS(I,K,J)/QT(I,K,J) ) ) - ENDIF - IF (QR(I,K,J) <= EPSQ) THEN - F_RAIN_PHY(I,K,J)=0. - ELSE - F_RAIN_PHY(I,K,J)=QR(I,K,J)/(QC(I,K,J)+QR(I,K,J)) - ENDIF - ENDDO - ENDDO - ENDDO -#endif - -!----------------------------------------------------------------------- - - CALL EGCP01DRV(DT,LOWLYR, & - & APREC,PREC,ACPREC,SR,NSTATS,QMAX,QTOT, & - & dz8w,rho_phy,qt,t_phy,qv,F_ICE_PHY,P_PHY, & - & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & - & ids,ide, jds,jde, kds,kde, & - & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte ) -!----------------------------------------------------------------------- - - DO j = jts,jte - DO k = kts,kte - DO i = its,ite - th_phy(i,k,j) = t_phy(i,k,j)/pi_phy(i,k,j) - qv(i,k,j)=qv(i,k,j)/(1.-qv(i,k,j)) !Convert to mixing ratio - WC=qt(I,K,J) - QS(I,K,J)=0. - QR(I,K,J)=0. - QC(I,K,J)=0. - IF(F_ICE_PHY(I,K,J)>=1.)THEN - QS(I,K,J)=WC - ELSEIF(F_ICE_PHY(I,K,J)<=0.)THEN - QC(I,K,J)=WC - ELSE - QS(I,K,J)=F_ICE_PHY(I,K,J)*WC - QC(I,K,J)=WC-QS(I,K,J) - ENDIF -! - IF(QC(I,K,J)>0..AND.F_RAIN_PHY(I,K,J)>0.)THEN - IF(F_RAIN_PHY(I,K,J).GE.1.)THEN - QR(I,K,J)=QC(I,K,J) - QC(I,K,J)=0. - ELSE - QR(I,K,J)=F_RAIN_PHY(I,K,J)*QC(I,K,J) - QC(I,K,J)=QC(I,K,J)-QR(I,K,J) - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO -! -! update rain (from m to mm) - - DO j=jts,jte - DO i=its,ite - RAINNC(i,j)=APREC(i,j)*1000.+RAINNC(i,j) - RAINNCV(i,j)=APREC(i,j)*1000. - ENDDO - ENDDO -! - MP_RESTART_STATE(MY_T1:MY_T2)=MY_GROWTH(MY_T1:MY_T2) - MP_RESTART_STATE(MY_T2+1)=C1XPVS0 - MP_RESTART_STATE(MY_T2+2)=C2XPVS0 - MP_RESTART_STATE(MY_T2+3)=C1XPVS - MP_RESTART_STATE(MY_T2+4)=C2XPVS - MP_RESTART_STATE(MY_T2+5)=CIACW - MP_RESTART_STATE(MY_T2+6)=CIACR - MP_RESTART_STATE(MY_T2+7)=CRACW - MP_RESTART_STATE(MY_T2+8)=CRAUT -! - TBPVS_STATE(1:NX) =TBPVS(1:NX) - TBPVS0_STATE(1:NX)=TBPVS0(1:NX) - -!----------------------------------------------------------------------- - - END SUBROUTINE ETAMP_OLD - -!----------------------------------------------------------------------- - - SUBROUTINE EGCP01DRV( & - & DTPH,LOWLYR,APREC,PREC,ACPREC,SR, & - & NSTATS,QMAX,QTOT, & - & dz8w,RHO_PHY,CWM_PHY,T_PHY,Q_PHY,F_ICE_PHY,P_PHY, & - & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & - & ids,ide, jds,jde, kds,kde, & - & ims,ime, jms,jme, kms,kme, & - & its,ite, jts,jte, kts,kte) -!----------------------------------------------------------------------- -! DTPH Physics time step (s) -! CWM_PHY (qt) Mixing ratio of the total condensate. kg/kg -! Q_PHY Mixing ratio of water vapor. kg/kg -! F_RAIN_PHY Fraction of rain. -! F_ICE_PHY Fraction of ice. -! F_RIMEF_PHY Mass ratio of rimed ice (rime factor). -! -!TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related the -!micrphysics sechme. Instead, they will be used by Eta precip assimilation. -! -!NSTATS,QMAX,QTOT are used for diagnosis purposes. -! -!----------------------------------------------------------------------- -!--- Variables APREC,PREC,ACPREC,SR are calculated for precip assimilation -! and/or ZHAO's scheme in Eta and are not required by this microphysics -! scheme itself. -!--- NSTATS,QMAX,QTOT are used for diagnosis purposes only. They will be -! printed out when PRINT_diag is true. -! -!----------------------------------------------------------------------- - IMPLICIT NONE -!----------------------------------------------------------------------- -! - INTEGER, PARAMETER :: ITLO=-60, ITHI=40 - LOGICAL, PARAMETER :: PRINT_diag=.FALSE. -! VARIABLES PASSED IN/OUT - INTEGER,INTENT(IN ) :: ids,ide, jds,jde, kds,kde & - & ,ims,ime, jms,jme, kms,kme & - & ,its,ite, jts,jte, kts,kte - REAL,INTENT(IN) :: DTPH - INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR - INTEGER,DIMENSION(ITLO:ITHI,4),INTENT(INOUT) :: NSTATS - REAL,DIMENSION(ITLO:ITHI,5),INTENT(INOUT) :: QMAX - REAL,DIMENSION(ITLO:ITHI,22),INTENT(INOUT) :: QTOT - REAL,DIMENSION(ims:ime,jms:jme),INTENT(INOUT) :: & - & APREC,PREC,ACPREC,SR - REAL,DIMENSION( its:ite, kts:kte, jts:jte ),INTENT(INOUT) :: t_phy - REAL,DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN) :: & - & dz8w,P_PHY,RHO_PHY - REAL,DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(INOUT) :: & - & CWM_PHY, F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY & - & ,Q_PHY,TRAIN_PHY -! -!----------------------------------------------------------------------- -!LOCAL VARIABLES -!----------------------------------------------------------------------- -! -#define CACHE_FRIENDLY_MP_ETAOLD -#ifdef CACHE_FRIENDLY_MP_ETAOLD -# define TEMP_DIMS kts:kte,its:ite,jts:jte -# define TEMP_DEX L,I,J -#else -# define TEMP_DIMS its:ite,jts:jte,kts:kte -# define TEMP_DEX I,J,L -#endif -! - INTEGER :: LSFC,I,J,I_index,J_index,L,K,KFLIP - REAL,DIMENSION(TEMP_DIMS) :: CWM,T,Q,TRAIN,TLATGS,P - REAL,DIMENSION(kts:kte,its:ite,jts:jte) :: F_ice,F_rain,F_RimeF - INTEGER,DIMENSION(its:ite,jts:jte) :: LMH - REAL :: TC,WC,QI,QR,QW,Fice,Frain,DUM,ASNOW,ARAIN - REAL,DIMENSION(kts:kte) :: P_col,Q_col,T_col,QV_col,WC_col, & - RimeF_col,QI_col,QR_col,QW_col, THICK_col,DPCOL - REAL,DIMENSION(2) :: PRECtot,PRECmax -!----------------------------------------------------------------------- -! - DO J=JTS,JTE - DO I=ITS,ITE - LMH(I,J) = KTE-LOWLYR(I,J)+1 - ENDDO - ENDDO - - DO 98 J=JTS,JTE - DO 98 I=ITS,ITE - DO L=KTS,KTE - KFLIP=KTE+1-L - CWM(TEMP_DEX)=CWM_PHY(I,KFLIP,J) - T(TEMP_DEX)=T_PHY(I,KFLIP,J) - Q(TEMP_DEX)=Q_PHY(I,KFLIP,J) - P(TEMP_DEX)=P_PHY(I,KFLIP,J) - TLATGS(TEMP_DEX)=TLATGS_PHY(I,KFLIP,J) - TRAIN(TEMP_DEX)=TRAIN_PHY(I,KFLIP,J) - F_ice(L,I,J)=F_ice_PHY(I,KFLIP,J) - F_rain(L,I,J)=F_rain_PHY(I,KFLIP,J) - F_RimeF(L,I,J)=F_RimeF_PHY(I,KFLIP,J) - ENDDO -98 CONTINUE - - DO 100 J=JTS,JTE - DO 100 I=ITS,ITE - LSFC=LMH(I,J) ! "L" of surface -! - DO K=KTS,KTE - KFLIP=KTE+1-K - DPCOL(K)=RHO_PHY(I,KFLIP,J)*GRAV*dz8w(I,KFLIP,J) - ENDDO -! - ! - !--- Initialize column data (1D arrays) - ! - L=1 - IF (CWM(TEMP_DEX) .LE. EPSQ) CWM(TEMP_DEX)=EPSQ - F_ice(1,I,J)=1. - F_rain(1,I,J)=0. - F_RimeF(1,I,J)=1. - DO L=1,LSFC - ! - !--- Pressure (Pa) = (Psfc-Ptop)*(ETA/ETA_sfc)+Ptop - ! - P_col(L)=P(TEMP_DEX) - ! - !--- Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_sfc) - ! - THICK_col(L)=DPCOL(L)*RGRAV - T_col(L)=T(TEMP_DEX) - TC=T_col(L)-T0C - QV_col(L)=max(EPSQ, Q(TEMP_DEX)) - IF (CWM(TEMP_DEX) .LE. EPSQ1) THEN - WC_col(L)=0. - IF (TC .LT. T_ICE) THEN - F_ice(L,I,J)=1. - ELSE - F_ice(L,I,J)=0. - ENDIF - F_rain(L,I,J)=0. - F_RimeF(L,I,J)=1. - ELSE - WC_col(L)=CWM(TEMP_DEX) - ENDIF - ! - !--- Determine composition of condensate in terms of - ! cloud water, ice, & rain - ! - WC=WC_col(L) - QI=0. - QR=0. - QW=0. - Fice=F_ice(L,I,J) - Frain=F_rain(L,I,J) - IF (Fice .GE. 1.) THEN - QI=WC - ELSE IF (Fice .LE. 0.) THEN - QW=WC - ELSE - QI=Fice*WC - QW=WC-QI - ENDIF - IF (QW.GT.0. .AND. Frain.GT.0.) THEN - IF (Frain .GE. 1.) THEN - QR=QW - QW=0. - ELSE - QR=Frain*QW - QW=QW-QR - ENDIF - ENDIF - IF (QI .LE. 0.) F_RimeF(L,I,J)=1. - RimeF_col(L)=F_RimeF(L,I,J) ! (real) - QI_col(L)=QI - QR_col(L)=QR - QW_col(L)=QW - ENDDO -! -!####################################################################### - ! - !--- Perform the microphysical calculations in this column - ! - I_index=I - J_index=J - CALL EGCP01COLUMN ( ARAIN, ASNOW, DTPH, I_index, J_index, LSFC, & - & P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, & - & THICK_col, WC_col,KTS,KTE,NSTATS,QMAX,QTOT ) - - - ! -!####################################################################### -! - ! - !--- Update storage arrays - ! - DO L=1,LSFC - TRAIN(TEMP_DEX)=(T_col(L)-T(TEMP_DEX))/DTPH - TLATGS(TEMP_DEX)=T_col(L)-T(TEMP_DEX) - T(TEMP_DEX)=T_col(L) - Q(TEMP_DEX)=QV_col(L) - CWM(TEMP_DEX)=WC_col(L) - ! - !--- REAL*4 array storage - ! - IF (QI_col(L) .LE. EPSQ) THEN - F_ice(L,I,J)=0. - IF (T_col(L) .LT. T_ICEK) F_ice(L,I,J)=1. - F_RimeF(L,I,J)=1. - ELSE - F_ice(L,I,J)=MAX( 0., MIN(1., QI_col(L)/WC_col(L)) ) - F_RimeF(L,I,J)=MAX(1., RimeF_col(L)) - ENDIF - IF (QR_col(L) .LE. EPSQ) THEN - DUM=0 - ELSE - DUM=QR_col(L)/(QR_col(L)+QW_col(L)) - ENDIF - F_rain(L,I,J)=DUM - ! - ENDDO - ! - !--- Update accumulated precipitation statistics - ! - !--- Surface precipitation statistics; SR is fraction of surface - ! precipitation (if >0) associated with snow - ! - APREC(I,J)=(ARAIN+ASNOW)*RRHOL ! Accumulated surface precip (depth in m) !<--- Ying - PREC(I,J)=PREC(I,J)+APREC(I,J) - ACPREC(I,J)=ACPREC(I,J)+APREC(I,J) - IF(APREC(I,J) .LT. 1.E-8) THEN - SR(I,J)=0. - ELSE - SR(I,J)=RRHOL*ASNOW/APREC(I,J) - ENDIF - ! - !--- Debug statistics - ! - IF (PRINT_diag) THEN - PRECtot(1)=PRECtot(1)+ARAIN - PRECtot(2)=PRECtot(2)+ASNOW - PRECmax(1)=MAX(PRECmax(1), ARAIN) - PRECmax(2)=MAX(PRECmax(2), ASNOW) - ENDIF - - -!####################################################################### -!####################################################################### -! -100 CONTINUE ! End "I" & "J" loops - DO 101 J=JTS,JTE - DO 101 I=ITS,ITE - DO L=KTS,KTE - KFLIP=KTE+1-L - CWM_PHY(I,KFLIP,J)=CWM(TEMP_DEX) - T_PHY(I,KFLIP,J)=T(TEMP_DEX) - Q_PHY(I,KFLIP,J)=Q(TEMP_DEX) - TLATGS_PHY(I,KFLIP,J)=TLATGS(TEMP_DEX) - TRAIN_PHY(I,KFLIP,J)=TRAIN(TEMP_DEX) - F_ice_PHY(I,KFLIP,J)=F_ice(L,I,J) - F_rain_PHY(I,KFLIP,J)=F_rain(L,I,J) - F_RimeF_PHY(I,KFLIP,J)=F_RimeF(L,I,J) - ENDDO -101 CONTINUE - END SUBROUTINE EGCP01DRV -! -! -!############################################################################### -! ***** VERSION OF MICROPHYSICS DESIGNED FOR HIGHER RESOLUTION MESO ETA MODEL -! (1) Represents sedimentation by preserving a portion of the precipitation -! through top-down integration from cloud-top. Modified procedure to -! Zhao and Carr (1997). -! (2) Microphysical equations are modified to be less sensitive to time -! steps by use of Clausius-Clapeyron equation to account for changes in -! saturation mixing ratios in response to latent heating/cooling. -! (3) Prevent spurious temperature oscillations across 0C due to -! microphysics. -! (4) Uses lookup tables for: calculating two different ventilation -! coefficients in condensation and deposition processes; accretion of -! cloud water by precipitation; precipitation mass; precipitation rate -! (and mass-weighted precipitation fall speeds). -! (5) Assumes temperature-dependent variation in mean diameter of large ice -! (Houze et al., 1979; Ryan et al., 1996). -! -> 8/22/01: This relationship has been extended to colder temperatures -! to parameterize smaller large-ice particles down to mean sizes of MDImin, -! which is 50 microns reached at -55.9C. -! (6) Attempts to differentiate growth of large and small ice, mainly for -! improved transition from thin cirrus to thick, precipitating ice -! anvils. -! -> 8/22/01: This feature has been diminished by effectively adjusting to -! ice saturation during depositional growth at temperatures colder than -! -10C. Ice sublimation is calculated more explicitly. The logic is -! that sources of are either poorly understood (e.g., nucleation for NWP) -! or are not represented in the Eta model (e.g., detrainment of ice from -! convection). Otherwise the model is too wet compared to the radiosonde -! observations based on 1 Feb - 18 March 2001 retrospective runs. -! (7) Top-down integration also attempts to treat mixed-phase processes, -! allowing a mixture of ice and water. Based on numerous observational -! studies, ice growth is based on nucleation at cloud top & -! subsequent growth by vapor deposition and riming as the ice particles -! fall through the cloud. Effective nucleation rates are a function -! of ice supersaturation following Meyers et al. (JAM, 1992). -! -> 8/22/01: The simulated relative humidities were far too moist compared -! to the rawinsonde observations. This feature has been substantially -! diminished, limited to a much narrower temperature range of 0 to -10C. -! (8) Depositional growth of newly nucleated ice is calculated for large time -! steps using Fig. 8 of Miller and Young (JAS, 1979), at 1 deg intervals -! using their ice crystal masses calculated after 600 s of growth in water -! saturated conditions. The growth rates are normalized by time step -! assuming 3D growth with time**1.5 following eq. (6.3) in Young (1993). -! -> 8/22/01: This feature has been effectively limited to 0 to -10C. -! (9) Ice precipitation rates can increase due to increase in response to -! cloud water riming due to (a) increased density & mass of the rimed -! ice, and (b) increased fall speeds of rimed ice. -! -> 8/22/01: This feature has been effectively limited to 0 to -10C. -!############################################################################### -!############################################################################### -! - SUBROUTINE EGCP01COLUMN ( ARAIN, ASNOW, DTPH, I_index, J_index, & - & LSFC, P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, & - & THICK_col, WC_col ,KTS,KTE,NSTATS,QMAX,QTOT) -! -!############################################################################### -!############################################################################### -! -!------------------------------------------------------------------------------- -!----- NOTE: Code is currently set up w/o threading! -!------------------------------------------------------------------------------- -!$$$ SUBPROGRAM DOCUMENTATION BLOCK -! . . . -! SUBPROGRAM: Grid-scale microphysical processes - condensation & precipitation -! PRGRMMR: Ferrier ORG: W/NP22 DATE: 08-2001 -! PRGRMMR: Jin (Modification for WRF structure) -!------------------------------------------------------------------------------- -! ABSTRACT: -! * Merges original GSCOND & PRECPD subroutines. -! * Code has been substantially streamlined and restructured. -! * Exchange between water vapor & small cloud condensate is calculated using -! the original Asai (1965, J. Japan) algorithm. See also references to -! Yau and Austin (1979, JAS), Rutledge and Hobbs (1983, JAS), and Tao et al. -! (1989, MWR). This algorithm replaces the Sundqvist et al. (1989, MWR) -! parameterization. -!------------------------------------------------------------------------------- -! -! USAGE: -! * CALL EGCP01COLUMN FROM SUBROUTINE EGCP01DRV -! -! INPUT ARGUMENT LIST: -! DTPH - physics time step (s) -! I_index - I index -! J_index - J index -! LSFC - Eta level of level above surface, ground -! P_col - vertical column of model pressure (Pa) -! QI_col - vertical column of model ice mixing ratio (kg/kg) -! QR_col - vertical column of model rain ratio (kg/kg) -! QV_col - vertical column of model water vapor specific humidity (kg/kg) -! QW_col - vertical column of model cloud water mixing ratio (kg/kg) -! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) -! T_col - vertical column of model temperature (deg K) -! THICK_col - vertical column of model mass thickness (density*height increment) -! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) -! -! -! OUTPUT ARGUMENT LIST: -! ARAIN - accumulated rainfall at the surface (kg) -! ASNOW - accumulated snowfall at the surface (kg) -! QV_col - vertical column of model water vapor specific humidity (kg/kg) -! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) -! QW_col - vertical column of model cloud water mixing ratio (kg/kg) -! QI_col - vertical column of model ice mixing ratio (kg/kg) -! QR_col - vertical column of model rain ratio (kg/kg) -! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) -! T_col - vertical column of model temperature (deg K) -! -! OUTPUT FILES: -! NONE -! -! Subprograms & Functions called: -! * Real Function CONDENSE - cloud water condensation -! * Real Function DEPOSIT - ice deposition (not sublimation) -! -! UNIQUE: NONE -! -! LIBRARY: NONE -! -! COMMON BLOCKS: -! CMICRO_CONS - key constants initialized in GSMCONST -! CMICRO_STATS - accumulated and maximum statistics -! CMY_GROWTH - lookup table for growth of ice crystals in -! water saturated conditions (Miller & Young, 1979) -! IVENT_TABLES - lookup tables for ventilation effects of ice -! IACCR_TABLES - lookup tables for accretion rates of ice -! IMASS_TABLES - lookup tables for mass content of ice -! IRATE_TABLES - lookup tables for precipitation rates of ice -! IRIME_TABLES - lookup tables for increase in fall speed of rimed ice -! RVENT_TABLES - lookup tables for ventilation effects of rain -! RACCR_TABLES - lookup tables for accretion rates of rain -! RMASS_TABLES - lookup tables for mass content of rain -! RVELR_TABLES - lookup tables for fall speeds of rain -! RRATE_TABLES - lookup tables for precipitation rates of rain -! -! ATTRIBUTES: -! LANGUAGE: FORTRAN 90 -! MACHINE : IBM SP -! -! -!------------------------------------------------------------------------- -!--------------- Arrays & constants in argument list --------------------- -!------------------------------------------------------------------------- -! - IMPLICIT NONE -! - INTEGER,INTENT(IN) :: KTS,KTE,I_index, J_index, LSFC - REAL,INTENT(INOUT) :: ARAIN, ASNOW - REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: P_col, QI_col,QR_col & - & ,QV_col ,QW_col, RimeF_col, T_col, THICK_col,WC_col -! -!------------------------------------------------------------------------- -!-------------- Common blocks for microphysical statistics --------------- -!------------------------------------------------------------------------- -! -!------------------------------------------------------------------------- -!--------- Common blocks for constants initialized in GSMCONST ---------- -! - INTEGER, PARAMETER :: ITLO=-60, ITHI=40 - INTEGER,INTENT(INOUT) :: NSTATS(ITLO:ITHI,4) - REAL,INTENT(INOUT) :: QMAX(ITLO:ITHI,5),QTOT(ITLO:ITHI,22) -! -!------------------------------------------------------------------------- -!--------------- Common blocks for various lookup tables ----------------- -! -!--- Discretized growth rates of small ice crystals after their nucleation -! at 1 C intervals from -1 C to -35 C, based on calculations by Miller -! and Young (1979, JAS) after 600 s of growth. Resultant growth rates -! are multiplied by physics time step in GSMCONST. -! -!------------------------------------------------------------------------- -! -!--- Mean ice-particle diameters varying from 50 microns to 1000 microns -! (1 mm), assuming an exponential size distribution. -! -!---- Meaning of the following arrays: -! - mdiam - mean diameter (m) -! - VENTI1 - integrated quantity associated w/ ventilation effects -! (capacitance only) for calculating vapor deposition onto ice -! - VENTI2 - integrated quantity associated w/ ventilation effects -! (with fall speed) for calculating vapor deposition onto ice -! - ACCRI - integrated quantity associated w/ cloud water collection by ice -! - MASSI - integrated quantity associated w/ ice mass -! - VSNOWI - mass-weighted fall speed of snow (large ice), used to calculate -! precipitation rates -! -! -!------------------------------------------------------------------------- -! -!--- VEL_RF - velocity increase of rimed particles as functions of crude -! particle size categories (at 0.1 mm intervals of mean ice particle -! sizes) and rime factor (different values of Rime Factor of 1.1**N, -! where N=0 to Nrime). -! -!------------------------------------------------------------------------- -! -!--- Mean rain drop diameters varying from 50 microns (0.05 mm) to 450 microns -! (0.45 mm), assuming an exponential size distribution. -! -!------------------------------------------------------------------------- -!------- Key parameters, local variables, & important comments --------- -!----------------------------------------------------------------------- -! -!--- TOLER => Tolerance or precision for accumulated precipitation -! - REAL, PARAMETER :: TOLER=5.E-7, C2=1./6., RHO0=1.194, Xratio=.025 -! -!--- If BLEND=1: -! precipitation (large) ice amounts are estimated at each level as a -! blend of ice falling from the grid point above and the precip ice -! present at the start of the time step (see TOT_ICE below). -!--- If BLEND=0: -! precipitation (large) ice amounts are estimated to be the precip -! ice present at the start of the time step. -! -!--- Extended to include sedimentation of rain on 2/5/01 -! - REAL, PARAMETER :: BLEND=1. -! -!--- This variable is for debugging purposes (if .true.) -! - LOGICAL, PARAMETER :: PRINT_diag=.FALSE. -! -!----------------------------------------------------------------------- -!--- Local variables -!----------------------------------------------------------------------- -! - REAL EMAIRI, N0r, NLICE, NSmICE - LOGICAL CLEAR, ICE_logical, DBG_logical, RAIN_logical - INTEGER :: IDR,INDEX_MY,INDEXR,INDEXR1,INDEXS,IPASS,ITDX,IXRF, & - & IXS,LBEF,L -! - REAL :: ABI,ABW,AIEVP,ARAINnew,ASNOWnew,BLDTRH,BUDGET, & - & CREVP,DELI,DELR,DELT,DELV,DELW,DENOMF, & - & DENOMI,DENOMW,DENOMWI,DIDEP, & - & DIEVP,DIFFUS,DLI,DTPH,DTRHO,DUM,DUM1, & - & DUM2,DWV0,DWVI,DWVR,DYNVIS,ESI,ESW,FIR,FLARGE,FLIMASS, & - & FSMALL,FWR,FWS,GAMMAR,GAMMAS, & - & PCOND,PIACR,PIACW,PIACWI,PIACWR,PICND,PIDEP,PIDEP_max, & - & PIEVP,PILOSS,PIMLT,PP,PRACW,PRAUT,PREVP,PRLOSS, & - & QI,QInew,QLICE,QR,QRnew,QSI,QSIgrd,QSInew,QSW,QSW0, & - & QSWgrd,QSWnew,QT,QTICE,QTnew,QTRAIN,QV,QW,QW0,QWnew, & - & RFACTOR,RHO,RIMEF,RIMEF1,RQR,RR,RRHO,SFACTOR, & - & TC,TCC,TFACTOR,THERM_COND,THICK,TK,TK2,TNEW, & - & TOT_ICE,TOT_ICEnew,TOT_RAIN,TOT_RAINnew, & - & VEL_INC,VENTR,VENTIL,VENTIS,VRAIN1,VRAIN2,VRIMEF,VSNOW, & - & WC,WCnew,WSgrd,WS,WSnew,WV,WVnew,WVQW, & - & XLF,XLF1,XLI,XLV,XLV1,XLV2,XLIMASS,XRF,XSIMASS -! -!####################################################################### -!########################## Begin Execution ############################ -!####################################################################### -! -! - ARAIN=0. ! Accumulated rainfall into grid box from above (kg/m**2) - ASNOW=0. ! Accumulated snowfall into grid box from above (kg/m**2) -! -!----------------------------------------------------------------------- -!------------ Loop from top (L=1) to surface (L=LSFC) ------------------ -!----------------------------------------------------------------------- -! - - DO 10 L=1,LSFC - -!--- Skip this level and go to the next lower level if no condensate -! and very low specific humidities -! - IF (QV_col(L).LE.EPSQ .AND. WC_col(L).LE.EPSQ) GO TO 10 -! -!----------------------------------------------------------------------- -!------------ Proceed with cloud microphysics calculations ------------- -!----------------------------------------------------------------------- -! - TK=T_col(L) ! Temperature (deg K) - TC=TK-T0C ! Temperature (deg C) - PP=P_col(L) ! Pressure (Pa) - QV=QV_col(L) ! Specific humidity of water vapor (kg/kg) - WV=QV/(1.-QV) ! Water vapor mixing ratio (kg/kg) - WC=WC_col(L) ! Grid-scale mixing ratio of total condensate (water or ice; kg/kg) -! -!----------------------------------------------------------------------- -!--- Moisture variables below are mixing ratios & not specifc humidities -!----------------------------------------------------------------------- -! - CLEAR=.TRUE. -! -!--- This check is to determine grid-scale saturation when no condensate is present -! - ESW=MIN(1000.*FPVS0(TK),0.99*PP) ! Saturation vapor pressure w/r/t water - QSW=EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water - WS=QSW ! General saturation mixing ratio (water/ice) - IF (TC .LT. 0.) THEN - ESI=MIN(1000.*FPVS(TK),0.99*PP) ! Saturation vapor pressure w/r/t ice - QSI=EPS*ESI/(PP-ESI) ! Saturation mixing ratio w/r/t water - WS=QSI ! General saturation mixing ratio (water/ice) - ENDIF -! -!--- Effective grid-scale Saturation mixing ratios -! - QSWgrd=RHgrd*QSW - QSIgrd=RHgrd*QSI - WSgrd=RHgrd*WS -! -!--- Check if air is subsaturated and w/o condensate -! - IF (WV.GT.WSgrd .OR. WC.GT.EPSQ) CLEAR=.FALSE. -! -!--- Check if any rain is falling into layer from above -! - IF (ARAIN .GT. CLIMIT) THEN - CLEAR=.FALSE. - ELSE - ARAIN=0. - ENDIF -! -!--- Check if any ice is falling into layer from above -! -!--- NOTE that "SNOW" in variable names is synonomous with -! large, precipitation ice particles -! - IF (ASNOW .GT. CLIMIT) THEN - CLEAR=.FALSE. - ELSE - ASNOW=0. - ENDIF -! -!----------------------------------------------------------------------- -!-- Loop to the end if in clear, subsaturated air free of condensate --- -!----------------------------------------------------------------------- -! - IF (CLEAR) GO TO 10 -! -!----------------------------------------------------------------------- -!--------- Initialize RHO, THICK & microphysical processes ------------- -!----------------------------------------------------------------------- -! -! -!--- Virtual temperature, TV=T*(1./EPS-1)*Q, Q is specific humidity; -! (see pp. 63-65 in Fleagle & Businger, 1963) -! - RHO=PP/(RD*TK*(1.+EPS1*QV)) ! Air density (kg/m**3) - RRHO=1./RHO ! Reciprocal of air density - DTRHO=DTPH*RHO ! Time step * air density - BLDTRH=BLEND*DTRHO ! Blend parameter * time step * air density - THICK=THICK_col(L) ! Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_sfc) -! - ARAINnew=0. ! Updated accumulated rainfall - ASNOWnew=0. ! Updated accumulated snowfall - QI=QI_col(L) ! Ice mixing ratio - QInew=0. ! Updated ice mixing ratio - QR=QR_col(L) ! Rain mixing ratio - QRnew=0. ! Updated rain ratio - QW=QW_col(L) ! Cloud water mixing ratio - QWnew=0. ! Updated cloud water ratio -! - PCOND=0. ! Condensation (>0) or evaporation (<0) of cloud water (kg/kg) - PIDEP=0. ! Deposition (>0) or sublimation (<0) of ice crystals (kg/kg) - PIACW=0. ! Cloud water collection (riming) by precipitation ice (kg/kg; >0) - PIACWI=0. ! Growth of precip ice by riming (kg/kg; >0) - PIACWR=0. ! Shedding of accreted cloud water to form rain (kg/kg; >0) - PIACR=0. ! Freezing of rain onto large ice at supercooled temps (kg/kg; >0) - PICND=0. ! Condensation (>0) onto wet, melting ice (kg/kg) - PIEVP=0. ! Evaporation (<0) from wet, melting ice (kg/kg) - PIMLT=0. ! Melting ice (kg/kg; >0) - PRAUT=0. ! Cloud water autoconversion to rain (kg/kg; >0) - PRACW=0. ! Cloud water collection (accretion) by rain (kg/kg; >0) - PREVP=0. ! Rain evaporation (kg/kg; <0) -! -!--- Double check input hydrometeor mixing ratios -! -! DUM=WC-(QI+QW+QR) -! DUM1=ABS(DUM) -! DUM2=TOLER*MIN(WC, QI+QW+QR) -! IF (DUM1 .GT. DUM2) THEN -! WRITE(6,"(/2(a,i4),a,i2)") '{@ i=',I_index,' j=',J_index, -! & ' L=',L -! WRITE(6,"(4(a12,g11.4,1x))") -! & '{@ TCold=',TC,'P=',.01*PP,'DIFF=',DUM,'WCold=',WC, -! & '{@ QIold=',QI,'QWold=',QW,'QRold=',QR -! ENDIF -! -!*********************************************************************** -!*********** MAIN MICROPHYSICS CALCULATIONS NOW FOLLOW! **************** -!*********************************************************************** -! -!--- Calculate a few variables, which are used more than once below -! -!--- Latent heat of vaporization as a function of temperature from -! Bolton (1980, JAS) -! - XLV=3.148E6-2370*TK ! Latent heat of vaporization (Lv) - XLF=XLS-XLV ! Latent heat of fusion (Lf) - XLV1=XLV*RCP ! Lv/Cp - XLF1=XLF*RCP ! Lf/Cp - TK2=1./(TK*TK) ! 1./TK**2 - XLV2=XLV*XLV*QSW*TK2/RV ! Lv**2*Qsw/(Rv*TK**2) - DENOMW=1.+XLV2*RCP ! Denominator term, Clausius-Clapeyron correction -! -!--- Basic thermodynamic quantities -! * DYNVIS - dynamic viscosity [ kg/(m*s) ] -! * THERM_COND - thermal conductivity [ J/(m*s*K) ] -! * DIFFUS - diffusivity of water vapor [ m**2/s ] -! - TFACTOR=TK**1.5/(TK+120.) - DYNVIS=1.496E-6*TFACTOR - THERM_COND=2.116E-3*TFACTOR - DIFFUS=8.794E-5*TK**1.81/PP -! -!--- Air resistance term for the fall speed of ice following the -! basic research by Heymsfield, Kajikawa, others -! - GAMMAS=(1.E5/PP)**C1 -! -!--- Air resistance for rain fall speed (Beard, 1985, JAS, p.470) -! - GAMMAR=(RHO0/RHO)**.4 -! -!---------------------------------------------------------------------- -!------------- IMPORTANT MICROPHYSICS DECISION TREE ----------------- -!---------------------------------------------------------------------- -! -!--- Determine if conditions supporting ice are present -! - IF (TC.LT.0. .OR. QI.GT. EPSQ .OR. ASNOW.GT.CLIMIT) THEN - ICE_logical=.TRUE. - ELSE - ICE_logical=.FALSE. - QLICE=0. - QTICE=0. - ENDIF -! -!--- Determine if rain is present -! - RAIN_logical=.FALSE. - IF (ARAIN.GT.CLIMIT .OR. QR.GT.EPSQ) RAIN_logical=.TRUE. -! - IF (ICE_logical) THEN -! -!--- IMPORTANT: Estimate time-averaged properties. -! -!--- -! * FLARGE - ratio of number of large ice to total (large & small) ice -! * FSMALL - ratio of number of small ice crystals to large ice particles -! -> Small ice particles are assumed to have a mean diameter of 50 microns. -! * XSIMASS - used for calculating small ice mixing ratio -!--- -! * TOT_ICE - total mass (small & large) ice before microphysics, -! which is the sum of the total mass of large ice in the -! current layer and the input flux of ice from above -! * PILOSS - greatest loss (<0) of total (small & large) ice by -! sublimation, removing all of the ice falling from above -! and the ice within the layer -! * RimeF1 - Rime Factor, which is the mass ratio of total (unrimed & rimed) -! ice mass to the unrimed ice mass (>=1) -! * VrimeF - the velocity increase due to rime factor or melting (ratio, >=1) -! * VSNOW - Fall speed of rimed snow w/ air resistance correction -! * EMAIRI - equivalent mass of air associated layer and with fall of snow into layer -! * XLIMASS - used for calculating large ice mixing ratio -! * FLIMASS - mass fraction of large ice -! * QTICE - time-averaged mixing ratio of total ice -! * QLICE - time-averaged mixing ratio of large ice -! * NLICE - time-averaged number concentration of large ice -! * NSmICE - number concentration of small ice crystals at current level -!--- -!--- Assumed number fraction of large ice particles to total (large & small) -! ice particles, which is based on a general impression of the literature. -! - WVQW=WV+QW ! Water vapor & cloud water -! - - - IF (TC.GE.0. .OR. WVQW.LT.QSIgrd) THEN - ! - !--- Eliminate small ice particle contributions for melting & sublimation - ! - FLARGE=FLARGE1 - ELSE - ! - !--- Enhanced number of small ice particles during depositional growth - ! (effective only when 0C > T >= T_ice [-10C] ) - ! - FLARGE=FLARGE2 - ! - !--- Larger number of small ice particles due to rime splintering - ! - IF (TC.GE.-8. .AND. TC.LE.-3.) FLARGE=.5*FLARGE -! - ENDIF ! End IF (TC.GE.0. .OR. WVQW.LT.QSIgrd) - FSMALL=(1.-FLARGE)/FLARGE - XSIMASS=RRHO*MASSI(MDImin)*FSMALL - IF (QI.LE.EPSQ .AND. ASNOW.LE.CLIMIT) THEN - INDEXS=MDImin - TOT_ICE=0. - PILOSS=0. - RimeF1=1. - VrimeF=1. - VEL_INC=GAMMAS - VSNOW=0. - EMAIRI=THICK - XLIMASS=RRHO*RimeF1*MASSI(INDEXS) - FLIMASS=XLIMASS/(XLIMASS+XSIMASS) - QLICE=0. - QTICE=0. - NLICE=0. - NSmICE=0. - ELSE - ! - !--- For T<0C mean particle size follows Houze et al. (JAS, 1979, p. 160), - ! converted from Fig. 5 plot of LAMDAs. Similar set of relationships - ! also shown in Fig. 8 of Ryan (BAMS, 1996, p. 66). - ! - DUM=XMImax*EXP(.0536*TC) - INDEXS=MIN(MDImax, MAX(MDImin, INT(DUM) ) ) - TOT_ICE=THICK*QI+BLEND*ASNOW - PILOSS=-TOT_ICE/THICK - LBEF=MAX(1,L-1) - DUM1=RimeF_col(LBEF) - DUM2=RimeF_col(L) - RimeF1=(DUM2*THICK*QI+DUM1*BLEND*ASNOW)/TOT_ICE - RimeF1=MIN(RimeF1, RFmax) - DO IPASS=0,1 - IF (RimeF1 .LE. 1.) THEN - RimeF1=1. - VrimeF=1. - ELSE - IXS=MAX(2, MIN(INDEXS/100, 9)) - XRF=10.492*ALOG(RimeF1) - IXRF=MAX(0, MIN(INT(XRF), Nrime)) - IF (IXRF .GE. Nrime) THEN - VrimeF=VEL_RF(IXS,Nrime) - ELSE - VrimeF=VEL_RF(IXS,IXRF)+(XRF-FLOAT(IXRF))* & - & (VEL_RF(IXS,IXRF+1)-VEL_RF(IXS,IXRF)) - ENDIF - ENDIF ! End IF (RimeF1 .LE. 1.) - VEL_INC=GAMMAS*VrimeF - VSNOW=VEL_INC*VSNOWI(INDEXS) - EMAIRI=THICK+BLDTRH*VSNOW - XLIMASS=RRHO*RimeF1*MASSI(INDEXS) - FLIMASS=XLIMASS/(XLIMASS+XSIMASS) - QTICE=TOT_ICE/EMAIRI - QLICE=FLIMASS*QTICE - NLICE=QLICE/XLIMASS - NSmICE=Fsmall*NLICE - ! - IF ( (NLICE.GE.NLImin .AND. NLICE.LE.NLImax) & - & .OR. IPASS.EQ.1) THEN - EXIT - ELSE - IF (TC < 0) THEN - XLI=RHO*(QTICE/DUM-XSIMASS)/RimeF1 - IF (XLI .LE. MASSI(MDImin) ) THEN - INDEXS=MDImin - ELSE IF (XLI .LE. MASSI(450) ) THEN - DLI=9.5885E5*XLI**.42066 ! DLI in microns - INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) - ELSE IF (XLI .LE. MASSI(MDImax) ) THEN - DLI=3.9751E6*XLI**.49870 ! DLI in microns - INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) - ELSE - INDEXS=MDImax - ENDIF ! End IF (XLI .LE. MASSI(MDImin) ) - ENDIF ! End IF (TC < 0) - ! - !--- Reduce excessive accumulation of ice at upper levels - ! associated with strong grid-resolved ascent - ! - !--- Force NLICE to be between NLImin and NLImax - ! - ! - !--- 8/22/01: Increase density of large ice if maximum limits - ! are reached for number concentration (NLImax) and mean size - ! (MDImax). Done to increase fall out of ice. - ! - DUM=MAX(NLImin, MIN(NLImax, NLICE) ) - IF (DUM.GE.NLImax .AND. INDEXS.GE.MDImax) & - & RimeF1=RHO*(QTICE/NLImax-XSIMASS)/MASSI(INDEXS) -! WRITE(6,"(4(a12,g11.4,1x))") -! & '{$ TC=',TC,'P=',.01*PP,'NLICE=',NLICE,'DUM=',DUM, -! & '{$ XLI=',XLI,'INDEXS=',FLOAT(INDEXS),'RHO=',RHO,'QTICE=',QTICE, -! & '{$ XSIMASS=',XSIMASS,'RimeF1=',RimeF1 - ENDIF ! End IF ( (NLICE.GE.NLImin .AND. NLICE.LE.NLImax) ... - ENDDO ! End DO IPASS=0,1 - ENDIF ! End IF (QI.LE.EPSQ .AND. ASNOW.LE.CLIMIT) - ENDIF ! End IF (ICE_logical) -! -!---------------------------------------------------------------------- -!--------------- Calculate individual processes ----------------------- -!---------------------------------------------------------------------- -! -!--- Cloud water autoconversion to rain and collection by rain -! - IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) THEN - ! - !--- QW0 could be modified based on land/sea properties, - ! presence of convection, etc. This is why QAUT0 and CRAUT - ! are passed into the subroutine as externally determined - ! parameters. Can be changed in the future if desired. - ! - QW0=QAUT0*RRHO - PRAUT=MAX(0., MIN(QW-QW0, QW0) )*CRAUT - IF (QLICE .GT. EPSQ) THEN - ! - !--- Collection of cloud water by large ice particles ("snow") - ! PIACWI=PIACW for riming, PIACWI=0 for shedding - ! - FWS=MIN(1., CIACW*VEL_INC*NLICE*ACCRI(INDEXS)/PP**C1) - PIACW=FWS*QW - IF (TC .LT. 0.) PIACWI=PIACW ! Large ice riming - ENDIF ! End IF (QLICE .GT. EPSQ) - ENDIF ! End IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) -! -!---------------------------------------------------------------------- -!--- Loop around some of the ice-phase processes if no ice should be present -!---------------------------------------------------------------------- -! - IF (ICE_logical .EQV. .FALSE.) GO TO 20 -! -!--- Now the pretzel logic of calculating ice deposition -! - IF (TC.LT.T_ICE .AND. (WV.GT.QSIgrd .OR. QW.GT.EPSQ)) THEN - ! - !--- Adjust to ice saturation at T0) and evaporation - ! - DUM=PIEVP-PIMLT - IF (DUM .LT. PILOSS) THEN - DUM1=PILOSS/DUM - PIMLT=PIMLT*DUM1 - PIEVP=PIEVP*DUM1 - ENDIF ! End IF (DUM .GT. QTICE) - ENDIF ! End IF (TC.GT.0. .AND. TCC.GT.0. .AND. ICE_logical) -! -!--- IMPORTANT: Estimate time-averaged properties. -! -! * TOT_RAIN - total mass of rain before microphysics, which is the sum of -! the total mass of rain in the current layer and the input -! flux of rain from above -! * VRAIN1 - fall speed of rain into grid from above (with air resistance correction) -! * QTRAIN - time-averaged mixing ratio of rain (kg/kg) -! * PRLOSS - greatest loss (<0) of rain, removing all rain falling from -! above and the rain within the layer -! * RQR - rain content (kg/m**3) -! * INDEXR - mean size of rain drops to the nearest 1 micron in size -! * N0r - intercept of rain size distribution (typically 10**6 m**-4) -! - TOT_RAIN=0. - VRAIN1=0. - QTRAIN=0. - PRLOSS=0. - RQR=0. - N0r=0. - INDEXR=MDRmin - INDEXR1=INDEXR !-- For debugging only - IF (RAIN_logical) THEN - IF (ARAIN .LE. 0.) THEN - INDEXR=MDRmin - VRAIN1=0. - ELSE - ! - !--- INDEXR (related to mean diameter) & N0r could be modified - ! by land/sea properties, presence of convection, etc. - ! - !--- Rain rate normalized to a density of 1.194 kg/m**3 - ! - RR=ARAIN/(DTPH*GAMMAR) - ! - IF (RR .LE. RR_DRmin) THEN - ! - !--- Assume fixed mean diameter of rain (0.2 mm) for low rain rates, - ! instead vary N0r with rain rate - ! - INDEXR=MDRmin - ELSE IF (RR .LE. RR_DR1) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.05 and 0.10 mm: - ! V(Dr)=5.6023e4*Dr**1.136, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*5.6023e4*Dr**(4+1.136) = 1.408e15*Dr**5.136, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.123e-3*RR**.1947 -> Dr (microns) = 1.123e3*RR**.1947 - ! - INDEXR=INT( 1.123E3*RR**.1947 + .5 ) - INDEXR=MAX( MDRmin, MIN(INDEXR, MDR1) ) - ELSE IF (RR .LE. RR_DR2) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.10 and 0.20 mm: - ! V(Dr)=1.0867e4*Dr**.958, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*1.0867e4*Dr**(4+.958) = 2.731e14*Dr**4.958, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.225e-3*RR**.2017 -> Dr (microns) = 1.225e3*RR**.2017 - ! - INDEXR=INT( 1.225E3*RR**.2017 + .5 ) - INDEXR=MAX( MDR1, MIN(INDEXR, MDR2) ) - ELSE IF (RR .LE. RR_DR3) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.20 and 0.32 mm: - ! V(Dr)=2831.*Dr**.80, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*2831.*Dr**(4+.80) = 7.115e13*Dr**4.80, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.3006e-3*RR**.2083 -> Dr (microns) = 1.3006e3*RR**.2083 - ! - INDEXR=INT( 1.3006E3*RR**.2083 + .5 ) - INDEXR=MAX( MDR2, MIN(INDEXR, MDR3) ) - ELSE IF (RR .LE. RR_DRmax) THEN - ! - !--- Best fit to mass-weighted fall speeds (V) from rain lookup tables - ! for mean diameters (Dr) between 0.32 and 0.45 mm: - ! V(Dr)=944.8*Dr**.6636, V in m/s and Dr in m - ! RR = PI*1000.*N0r0*944.8*Dr**(4+.6636) = 2.3745e13*Dr**4.6636, - ! RR in kg/(m**2*s) - ! Dr (m) = 1.355e-3*RR**.2144 -> Dr (microns) = 1.355e3*RR**.2144 - ! - INDEXR=INT( 1.355E3*RR**.2144 + .5 ) - INDEXR=MAX( MDR3, MIN(INDEXR, MDRmax) ) - ELSE - ! - !--- Assume fixed mean diameter of rain (0.45 mm) for high rain rates, - ! instead vary N0r with rain rate - ! - INDEXR=MDRmax - ENDIF ! End IF (RR .LE. RR_DRmin) etc. - VRAIN1=GAMMAR*VRAIN(INDEXR) - ENDIF ! End IF (ARAIN .LE. 0.) - INDEXR1=INDEXR ! For debugging only - TOT_RAIN=THICK*QR+BLEND*ARAIN - QTRAIN=TOT_RAIN/(THICK+BLDTRH*VRAIN1) - PRLOSS=-TOT_RAIN/THICK - RQR=RHO*QTRAIN - ! - !--- RQR - time-averaged rain content (kg/m**3) - ! - IF (RQR .LE. RQR_DRmin) THEN - N0r=MAX(N0rmin, CN0r_DMRmin*RQR) - INDEXR=MDRmin - ELSE IF (RQR .GE. RQR_DRmax) THEN - N0r=CN0r_DMRmax*RQR - INDEXR=MDRmax - ELSE - N0r=N0r0 - INDEXR=MAX( XMRmin, MIN(CN0r0*RQR**.25, XMRmax) ) - ENDIF - ! - IF (TC .LT. T_ICE) THEN - PIACR=-PRLOSS - ELSE - DWVr=WV-PCOND-QSW - DUM=QW+PCOND - IF (DWVr.LT.0. .AND. DUM.LE.EPSQ) THEN - ! - !--- Rain evaporation - ! - ! * RFACTOR - [GAMMAR**.5]*[Schmidt**(1./3.)]*[(RHO/DYNVIS)**.5], - ! where Schmidt (Schmidt Number) =DYNVIS/(RHO*DIFFUS) - ! - ! * Units: RFACTOR - s**.5/m ; ABW - m**2/s ; VENTR - m**-2 ; - ! N0r - m**-4 ; VENTR1 - m**2 ; VENTR2 - m**3/s**.5 ; - ! CREVP - unitless - ! - RFACTOR=GAMMAR**.5*(RHO/(DIFFUS*DIFFUS*DYNVIS))**C2 - ABW=1./(RHO*XLV2/THERM_COND+1./DIFFUS) - ! - !--- Note that VENTR1, VENTR2 lookup tables do not include the - ! 1/Davg multiplier as in the ice tables - ! - VENTR=N0r*(VENTR1(INDEXR)+RFACTOR*VENTR2(INDEXR)) - CREVP=ABW*VENTR*DTPH - IF (CREVP .LT. Xratio) THEN - DUM=DWVr*CREVP - ELSE - DUM=DWVr*(1.-EXP(-CREVP*DENOMW))/DENOMW - ENDIF - PREVP=MAX(DUM, PRLOSS) - ELSE IF (QW .GT. EPSQ) THEN - FWR=CRACW*GAMMAR*N0r*ACCRR(INDEXR) - PRACW=MIN(1.,FWR)*QW - ENDIF ! End IF (DWVr.LT.0. .AND. DUM.LE.EPSQ) - ! - IF (TC.LT.0. .AND. TCC.LT.0.) THEN - ! - !--- Biggs (1953) heteorogeneous freezing (e.g., Lin et al., 1983) - ! - Rescaled mean drop diameter from microns (INDEXR) to mm (DUM) to prevent underflow - ! - DUM=.001*FLOAT(INDEXR) - DUM=(EXP(ABFR*TC)-1.)*DUM*DUM*DUM*DUM*DUM*DUM*DUM - PIACR=MIN(CBFR*N0r*RRHO*DUM, QTRAIN) - IF (QLICE .GT. EPSQ) THEN - ! - !--- Freezing of rain by collisions w/ large ice - ! - DUM=GAMMAR*VRAIN(INDEXR) - DUM1=DUM-VSNOW - ! - !--- DUM2 - Difference in spectral fall speeds of rain and - ! large ice, parameterized following eq. (48) on p. 112 of - ! Murakami (J. Meteor. Soc. Japan, 1990) - ! - DUM2=(DUM1*DUM1+.04*DUM*VSNOW)**.5 - DUM1=5.E-12*INDEXR*INDEXR+2.E-12*INDEXR*INDEXS & - & +.5E-12*INDEXS*INDEXS - FIR=MIN(1., CIACR*NLICE*DUM1*DUM2) - ! - !--- Future? Should COLLECTION BY SMALL ICE SHOULD BE INCLUDED??? - ! - PIACR=MIN(PIACR+FIR*QTRAIN, QTRAIN) - ENDIF ! End IF (QLICE .GT. EPSQ) - DUM=PREVP-PIACR - If (DUM .LT. PRLOSS) THEN - DUM1=PRLOSS/DUM - PREVP=DUM1*PREVP - PIACR=DUM1*PIACR - ENDIF ! End If (DUM .LT. PRLOSS) - ENDIF ! End IF (TC.LT.0. .AND. TCC.LT.0.) - ENDIF ! End IF (TC .LT. T_ICE) - ENDIF ! End IF (RAIN_logical) -! -!---------------------------------------------------------------------- -!---------------------- Main Budget Equations ------------------------- -!---------------------------------------------------------------------- -! -! -!----------------------------------------------------------------------- -!--- Update fields, determine characteristics for next lower layer ---- -!----------------------------------------------------------------------- -! -!--- Carefully limit sinks of cloud water -! - DUM1=PIACW+PRAUT+PRACW-MIN(0.,PCOND) - IF (DUM1 .GT. QW) THEN - DUM=QW/DUM1 - PIACW=DUM*PIACW - PIACWI=DUM*PIACWI - PRAUT=DUM*PRAUT - PRACW=DUM*PRACW - IF (PCOND .LT. 0.) PCOND=DUM*PCOND - ENDIF - PIACWR=PIACW-PIACWI ! TC >= 0C -! -!--- QWnew - updated cloud water mixing ratio -! - DELW=PCOND-PIACW-PRAUT-PRACW - QWnew=QW+DELW - IF (QWnew .LE. EPSQ) QWnew=0. - IF (QW.GT.0. .AND. QWnew.NE.0.) THEN - DUM=QWnew/QW - IF (DUM .LT. TOLER) QWnew=0. - ENDIF -! -!--- Update temperature and water vapor mixing ratios -! - DELT= XLV1*(PCOND+PIEVP+PICND+PREVP) & - & +XLS1*PIDEP+XLF1*(PIACWI+PIACR-PIMLT) - Tnew=TK+DELT -! - DELV=-PCOND-PIDEP-PIEVP-PICND-PREVP - WVnew=WV+DELV -! -!--- Update ice mixing ratios -! -!--- -! * TOT_ICEnew - total mass (small & large) ice after microphysics, -! which is the sum of the total mass of large ice in the -! current layer and the flux of ice out of the grid box below -! * RimeF - Rime Factor, which is the mass ratio of total (unrimed & -! rimed) ice mass to the unrimed ice mass (>=1) -! * QInew - updated mixing ratio of total (large & small) ice in layer -! -> TOT_ICEnew=QInew*THICK+BLDTRH*QLICEnew*VSNOW -! -> But QLICEnew=QInew*FLIMASS, so -! -> TOT_ICEnew=QInew*(THICK+BLDTRH*FLIMASS*VSNOW) -! * ASNOWnew - updated accumulation of snow at bottom of grid cell -!--- -! - DELI=0. - RimeF=1. - IF (ICE_logical) THEN - DELI=PIDEP+PIEVP+PIACWI+PIACR-PIMLT - TOT_ICEnew=TOT_ICE+THICK*DELI - IF (TOT_ICE.GT.0. .AND. TOT_ICEnew.NE.0.) THEN - DUM=TOT_ICEnew/TOT_ICE - IF (DUM .LT. TOLER) TOT_ICEnew=0. - ENDIF - IF (TOT_ICEnew .LE. CLIMIT) THEN - TOT_ICEnew=0. - RimeF=1. - QInew=0. - ASNOWnew=0. - ELSE - ! - !--- Update rime factor if appropriate - ! - DUM=PIACWI+PIACR - IF (DUM.LE.EPSQ .AND. PIDEP.LE.EPSQ) THEN - RimeF=RimeF1 - ELSE - ! - !--- Rime Factor, RimeF = (Total ice mass)/(Total unrimed ice mass) - ! DUM1 - Total ice mass, rimed & unrimed - ! DUM2 - Estimated mass of *unrimed* ice - ! - DUM1=TOT_ICE+THICK*(PIDEP+DUM) - DUM2=TOT_ICE/RimeF1+THICK*PIDEP - IF (DUM2 .LE. 0.) THEN - RimeF=RFmax - ELSE - RimeF=MIN(RFmax, MAX(1., DUM1/DUM2) ) - ENDIF - ENDIF ! End IF (DUM.LE.EPSQ .AND. PIDEP.LE.EPSQ) - QInew=TOT_ICEnew/(THICK+BLDTRH*FLIMASS*VSNOW) - IF (QInew .LE. EPSQ) QInew=0. - IF (QI.GT.0. .AND. QInew.NE.0.) THEN - DUM=QInew/QI - IF (DUM .LT. TOLER) QInew=0. - ENDIF - ASNOWnew=BLDTRH*FLIMASS*VSNOW*QInew - IF (ASNOW.GT.0. .AND. ASNOWnew.NE.0.) THEN - DUM=ASNOWnew/ASNOW - IF (DUM .LT. TOLER) ASNOWnew=0. - ENDIF - ENDIF ! End IF (TOT_ICEnew .LE. CLIMIT) - ENDIF ! End IF (ICE_logical) - - -! -!--- Update rain mixing ratios -! -!--- -! * TOT_RAINnew - total mass of rain after microphysics -! current layer and the input flux of ice from above -! * VRAIN2 - time-averaged fall speed of rain in grid and below -! (with air resistance correction) -! * QRnew - updated rain mixing ratio in layer -! -> TOT_RAINnew=QRnew*(THICK+BLDTRH*VRAIN2) -! * ARAINnew - updated accumulation of rain at bottom of grid cell -!--- -! - DELR=PRAUT+PRACW+PIACWR-PIACR+PIMLT+PREVP+PICND - TOT_RAINnew=TOT_RAIN+THICK*DELR - IF (TOT_RAIN.GT.0. .AND. TOT_RAINnew.NE.0.) THEN - DUM=TOT_RAINnew/TOT_RAIN - IF (DUM .LT. TOLER) TOT_RAINnew=0. - ENDIF - IF (TOT_RAINnew .LE. CLIMIT) THEN - TOT_RAINnew=0. - VRAIN2=0. - QRnew=0. - ARAINnew=0. - ELSE - ! - !--- 1st guess time-averaged rain rate at bottom of grid box - ! - RR=TOT_RAINnew/(DTPH*GAMMAR) - ! - !--- Use same algorithm as above for calculating mean drop diameter - ! (IDR, in microns), which is used to estimate the time-averaged - ! fall speed of rain drops at the bottom of the grid layer. This - ! isn't perfect, but the alternative is solving a transcendental - ! equation that is numerically inefficient and nasty to program - ! (coded in earlier versions of GSMCOLUMN prior to 8-22-01). - ! - IF (RR .LE. RR_DRmin) THEN - IDR=MDRmin - ELSE IF (RR .LE. RR_DR1) THEN - IDR=INT( 1.123E3*RR**.1947 + .5 ) - IDR=MAX( MDRmin, MIN(IDR, MDR1) ) - ELSE IF (RR .LE. RR_DR2) THEN - IDR=INT( 1.225E3*RR**.2017 + .5 ) - IDR=MAX( MDR1, MIN(IDR, MDR2) ) - ELSE IF (RR .LE. RR_DR3) THEN - IDR=INT( 1.3006E3*RR**.2083 + .5 ) - IDR=MAX( MDR2, MIN(IDR, MDR3) ) - ELSE IF (RR .LE. RR_DRmax) THEN - IDR=INT( 1.355E3*RR**.2144 + .5 ) - IDR=MAX( MDR3, MIN(IDR, MDRmax) ) - ELSE - IDR=MDRmax - ENDIF ! End IF (RR .LE. RR_DRmin) - VRAIN2=GAMMAR*VRAIN(IDR) - QRnew=TOT_RAINnew/(THICK+BLDTRH*VRAIN2) - IF (QRnew .LE. EPSQ) QRnew=0. - IF (QR.GT.0. .AND. QRnew.NE.0.) THEN - DUM=QRnew/QR - IF (DUM .LT. TOLER) QRnew=0. - ENDIF - ARAINnew=BLDTRH*VRAIN2*QRnew - IF (ARAIN.GT.0. .AND. ARAINnew.NE.0.) THEN - DUM=ARAINnew/ARAIN - IF (DUM .LT. TOLER) ARAINnew=0. - ENDIF - ENDIF -! - WCnew=QWnew+QRnew+QInew -! -!---------------------------------------------------------------------- -!-------------- Begin debugging & verification ------------------------ -!---------------------------------------------------------------------- -! -!--- QT, QTnew - total water (vapor & condensate) before & after microphysics, resp. -! - - - QT=THICK*(WV+WC)+ARAIN+ASNOW - QTnew=THICK*(WVnew+WCnew)+ARAINnew+ASNOWnew - BUDGET=QT-QTnew -! -!--- Additional check on budget preservation, accounting for truncation effects -! - DBG_logical=.FALSE. -! DUM=ABS(BUDGET) -! IF (DUM .GT. TOLER) THEN -! DUM=DUM/MIN(QT, QTnew) -! IF (DUM .GT. TOLER) DBG_logical=.TRUE. -! ENDIF -!! -! DUM=(RHgrd+.001)*QSInew -! IF ( (QWnew.GT.EPSQ) .OR. QRnew.GT.EPSQ .OR. WVnew.GT.DUM) -! & .AND. TC.LT.T_ICE ) DBG_logical=.TRUE. -! -! IF (TC.GT.5. .AND. QInew.GT.EPSQ) DBG_logical=.TRUE. -! - IF ((WVnew.LT.EPSQ .OR. DBG_logical) .AND. PRINT_diag) THEN - ! - WRITE(6,"(/2(a,i4),2(a,i2))") '{} i=',I_index,' j=',J_index,& - & ' L=',L,' LSFC=',LSFC - ! - ESW=MIN(1000.*FPVS0(Tnew),0.99*PP) - QSWnew=EPS*ESW/(PP-ESW) - IF (TC.LT.0. .OR. Tnew .LT. 0.) THEN - ESI=MIN(1000.*FPVS(Tnew),0.99*PP) - QSInew=EPS*ESI/(PP-ESI) - ELSE - QSI=QSW - QSInew=QSWnew - ENDIF - WSnew=QSInew - WRITE(6,"(4(a12,g11.4,1x))") & - & '{} TCold=',TC,'TCnew=',Tnew-T0C,'P=',.01*PP,'RHO=',RHO, & - & '{} THICK=',THICK,'RHold=',WV/WS,'RHnew=',WVnew/WSnew, & - & 'RHgrd=',RHgrd, & - & '{} RHWold=',WV/QSW,'RHWnew=',WVnew/QSWnew,'RHIold=',WV/QSI, & - & 'RHInew=',WVnew/QSInew, & - & '{} QSWold=',QSW,'QSWnew=',QSWnew,'QSIold=',QSI,'QSInew=',QSInew, & - & '{} WSold=',WS,'WSnew=',WSnew,'WVold=',WV,'WVnew=',WVnew, & - & '{} WCold=',WC,'WCnew=',WCnew,'QWold=',QW,'QWnew=',QWnew, & - & '{} QIold=',QI,'QInew=',QInew,'QRold=',QR,'QRnew=',QRnew, & - & '{} ARAINold=',ARAIN,'ARAINnew=',ARAINnew,'ASNOWold=',ASNOW, & - & 'ASNOWnew=',ASNOWnew, & - & '{} TOT_RAIN=',TOT_RAIN,'TOT_RAINnew=',TOT_RAINnew, & - & 'TOT_ICE=',TOT_ICE,'TOT_ICEnew=',TOT_ICEnew, & - & '{} BUDGET=',BUDGET,'QTold=',QT,'QTnew=',QTnew - ! - WRITE(6,"(4(a12,g11.4,1x))") & - & '{} DELT=',DELT,'DELV=',DELV,'DELW=',DELW,'DELI=',DELI, & - & '{} DELR=',DELR,'PCOND=',PCOND,'PIDEP=',PIDEP,'PIEVP=',PIEVP, & - & '{} PICND=',PICND,'PREVP=',PREVP,'PRAUT=',PRAUT,'PRACW=',PRACW, & - & '{} PIACW=',PIACW,'PIACWI=',PIACWI,'PIACWR=',PIACWR,'PIMLT=', & - & PIMLT, & - & '{} PIACR=',PIACR - ! - IF (ICE_logical) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} RimeF1=',RimeF1,'GAMMAS=',GAMMAS,'VrimeF=',VrimeF, & - & 'VSNOW=',VSNOW, & - & '{} INDEXS=',FLOAT(INDEXS),'FLARGE=',FLARGE,'FSMALL=',FSMALL, & - & 'FLIMASS=',FLIMASS, & - & '{} XSIMASS=',XSIMASS,'XLIMASS=',XLIMASS,'QLICE=',QLICE, & - & 'QTICE=',QTICE, & - & '{} NLICE=',NLICE,'NSmICE=',NSmICE,'PILOSS=',PILOSS, & - & 'EMAIRI=',EMAIRI, & - & '{} RimeF=',RimeF - ! - IF (TOT_RAIN.GT.0. .OR. TOT_RAINnew.GT.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} INDEXR1=',FLOAT(INDEXR1),'INDEXR=',FLOAT(INDEXR), & - & 'GAMMAR=',GAMMAR,'N0r=',N0r, & - & '{} VRAIN1=',VRAIN1,'VRAIN2=',VRAIN2,'QTRAIN=',QTRAIN,'RQR=',RQR, & - & '{} PRLOSS=',PRLOSS,'VOLR1=',THICK+BLDTRH*VRAIN1, & - & 'VOLR2=',THICK+BLDTRH*VRAIN2 - ! - IF (PRAUT .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} QW0=',QW0 - ! - IF (PRACW .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} FWR=',FWR - ! - IF (PIACR .GT. 0.) WRITE(6,"(a12,g11.4,1x)") '{} FIR=',FIR - ! - DUM=PIMLT+PICND-PREVP-PIEVP - IF (DUM.GT.0. .or. DWVi.NE.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} TFACTOR=',TFACTOR,'DYNVIS=',DYNVIS, & - & 'THERM_CON=',THERM_COND,'DIFFUS=',DIFFUS - ! - IF (PREVP .LT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} RFACTOR=',RFACTOR,'ABW=',ABW,'VENTR=',VENTR,'CREVP=',CREVP, & - & '{} DWVr=',DWVr,'DENOMW=',DENOMW - ! - IF (PIDEP.NE.0. .AND. DWVi.NE.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} DWVi=',DWVi,'DENOMI=',DENOMI,'PIDEP_max=',PIDEP_max, & - & 'SFACTOR=',SFACTOR, & - & '{} ABI=',ABI,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS), & - & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), & - & '{} VENTIS=',VENTIS,'DIDEP=',DIDEP - ! - IF (PIDEP.GT.0. .AND. PCOND.NE.0.) & - & WRITE(6,"(4(a12,g11.4,1x))") & - & '{} DENOMW=',DENOMW,'DENOMWI=',DENOMWI,'DENOMF=',DENOMF, & - & 'DUM2=',PCOND-PIACW - ! - IF (FWS .GT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} FWS=',FWS - ! - DUM=PIMLT+PICND-PIEVP - IF (DUM.GT. 0.) WRITE(6,"(4(a12,g11.4,1x))") & - & '{} SFACTOR=',SFACTOR,'VENTIL=',VENTIL,'VENTIL1=',VENTI1(INDEXS), & - & 'VENTIL2=',SFACTOR*VENTI2(INDEXS), & - & '{} AIEVP=',AIEVP,'DIEVP=',DIEVP,'QSW0=',QSW0,'DWV0=',DWV0 - ! - ENDIF - - -! -!----------------------------------------------------------------------- -!--------------- Water budget statistics & maximum values -------------- -!----------------------------------------------------------------------- -! - IF (PRINT_diag) THEN - ITdx=MAX( ITLO, MIN( INT(Tnew-T0C), ITHI ) ) - IF (QInew .GT. EPSQ) NSTATS(ITdx,1)=NSTATS(ITdx,1)+1 - IF (QInew.GT.EPSQ .AND. QRnew+QWnew.GT.EPSQ) & - & NSTATS(ITdx,2)=NSTATS(ITdx,2)+1 - IF (QWnew .GT. EPSQ) NSTATS(ITdx,3)=NSTATS(ITdx,3)+1 - IF (QRnew .GT. EPSQ) NSTATS(ITdx,4)=NSTATS(ITdx,4)+1 - ! - QMAX(ITdx,1)=MAX(QMAX(ITdx,1), QInew) - QMAX(ITdx,2)=MAX(QMAX(ITdx,2), QWnew) - QMAX(ITdx,3)=MAX(QMAX(ITdx,3), QRnew) - QMAX(ITdx,4)=MAX(QMAX(ITdx,4), ASNOWnew) - QMAX(ITdx,5)=MAX(QMAX(ITdx,5), ARAINnew) - QTOT(ITdx,1)=QTOT(ITdx,1)+QInew*THICK - QTOT(ITdx,2)=QTOT(ITdx,2)+QWnew*THICK - QTOT(ITdx,3)=QTOT(ITdx,3)+QRnew*THICK - ! - QTOT(ITdx,4)=QTOT(ITdx,4)+PCOND*THICK - QTOT(ITdx,5)=QTOT(ITdx,5)+PICND*THICK - QTOT(ITdx,6)=QTOT(ITdx,6)+PIEVP*THICK - QTOT(ITdx,7)=QTOT(ITdx,7)+PIDEP*THICK - QTOT(ITdx,8)=QTOT(ITdx,8)+PREVP*THICK - QTOT(ITdx,9)=QTOT(ITdx,9)+PRAUT*THICK - QTOT(ITdx,10)=QTOT(ITdx,10)+PRACW*THICK - QTOT(ITdx,11)=QTOT(ITdx,11)+PIMLT*THICK - QTOT(ITdx,12)=QTOT(ITdx,12)+PIACW*THICK - QTOT(ITdx,13)=QTOT(ITdx,13)+PIACWI*THICK - QTOT(ITdx,14)=QTOT(ITdx,14)+PIACWR*THICK - QTOT(ITdx,15)=QTOT(ITdx,15)+PIACR*THICK - ! - QTOT(ITdx,16)=QTOT(ITdx,16)+(WVnew-WV)*THICK - QTOT(ITdx,17)=QTOT(ITdx,17)+(QWnew-QW)*THICK - QTOT(ITdx,18)=QTOT(ITdx,18)+(QInew-QI)*THICK - QTOT(ITdx,19)=QTOT(ITdx,19)+(QRnew-QR)*THICK - QTOT(ITdx,20)=QTOT(ITdx,20)+(ARAINnew-ARAIN) - QTOT(ITdx,21)=QTOT(ITdx,21)+(ASNOWnew-ASNOW) - IF (QInew .GT. 0.) & - & QTOT(ITdx,22)=QTOT(ITdx,22)+QInew*THICK/RimeF - ! - ENDIF -! -!---------------------------------------------------------------------- -!------------------------- Update arrays ------------------------------ -!---------------------------------------------------------------------- -! - - - T_col(L)=Tnew ! Updated temperature -! - QV_col(L)=max(EPSQ, WVnew/(1.+WVnew)) ! Updated specific humidity - WC_col(L)=max(EPSQ, WCnew) ! Updated total condensate mixing ratio - QI_col(L)=max(EPSQ, QInew) ! Updated ice mixing ratio - QR_col(L)=max(EPSQ, QRnew) ! Updated rain mixing ratio - QW_col(L)=max(EPSQ, QWnew) ! Updated cloud water mixing ratio - RimeF_col(L)=RimeF ! Updated rime factor - ASNOW=ASNOWnew ! Updated accumulated snow - ARAIN=ARAINnew ! Updated accumulated rain -! -!####################################################################### -! -10 CONTINUE ! ##### End "L" loop through model levels ##### - - -! -!####################################################################### -! -!----------------------------------------------------------------------- -!--------------------------- Return to GSMDRIVE ----------------------- -!----------------------------------------------------------------------- -! - CONTAINS -!####################################################################### -!--------- Produces accurate calculation of cloud condensation --------- -!####################################################################### -! - REAL FUNCTION CONDENSE (PP, QW, TK, WV) -! -!--------------------------------------------------------------------------------- -!------ The Asai (1965) algorithm takes into consideration the release of ------ -!------ latent heat in increasing the temperature & in increasing the ------ -!------ saturation mixing ratio (following the Clausius-Clapeyron eqn.). ------ -!--------------------------------------------------------------------------------- -! - IMPLICIT NONE -! - INTEGER, PARAMETER :: HIGH_PRES=Selected_Real_Kind(15) - REAL (KIND=HIGH_PRES), PARAMETER :: & - & RHLIMIT=.001, RHLIMIT1=-RHLIMIT - REAL (KIND=HIGH_PRES) :: COND, SSAT, WCdum -! - REAL,INTENT(IN) :: QW,PP,WV,TK - REAL WVdum,Tdum,XLV2,DWV,WS,ESW,XLV1,XLV -integer nsteps -! -!----------------------------------------------------------------------- -! -!--- LV (T) is from Bolton (JAS, 1980) -! - XLV=3.148E6-2370.*TK - XLV1=XLV*RCP - XLV2=XLV*XLV*RCPRV - Tdum=TK - WVdum=WV - WCdum=QW - ESW=MIN(1000.*FPVS0(Tdum),0.99*PP) ! Saturation vapor press w/r/t water - WS=RHgrd*EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water - DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio - SSAT=DWV/WS ! Supersaturation ratio - CONDENSE=0. -nsteps = 0 - DO WHILE ((SSAT.LT.RHLIMIT1 .AND. WCdum.GT.EPSQ) & - & .OR. SSAT.GT.RHLIMIT) - nsteps = nsteps + 1 - COND=DWV/(1.+XLV2*WS/(Tdum*Tdum)) ! Asai (1965, J. Japan) - COND=MAX(COND, -WCdum) ! Limit cloud water evaporation - Tdum=Tdum+XLV1*COND ! Updated temperature - WVdum=WVdum-COND ! Updated water vapor mixing ratio - WCdum=WCdum+COND ! Updated cloud water mixing ratio - CONDENSE=CONDENSE+COND ! Total cloud water condensation - ESW=MIN(1000.*FPVS0(Tdum),0.99*PP) ! Updated saturation vapor press w/r/t water - WS=RHgrd*EPS*ESW/(PP-ESW) ! Updated saturation mixing ratio w/r/t water - DWV=WVdum-WS ! Deficit grid-scale water vapor mixing ratio - SSAT=DWV/WS ! Grid-scale supersaturation ratio - ENDDO -! - END FUNCTION CONDENSE -! -!####################################################################### -!---------------- Calculate ice deposition at TepsN or Q>epsQ.and.NT_low .and. T(i,k)=0. .and. Qv(i,k)=x_low .and. Qc(i,k)=x_low .and. Qr(i,k)=x_low .and. Qi(i,k)=x_low .and. Qn(i,k)=x_low .and. Qg(i,k)=x_low .and. Qh(i,k)=x_low .and. Nc(i,k)=x_low .and. Nr(i,k)=x_low .and. Ny(i,k)=x_low .and. Nn(i,k)=x_low .and. Ng(i,k)=x_low .and. Nh(i,k)epsQ.and.Nc(i,k)epsN)) then + print*,'** WARNING IN MICRO **' + print*, '** src,i,k,Qc,Nc: ',source_ind,i,k,Qc(i,k),Nc(i,k) + trap = .true. + endif + if ((Qr(i,k)>epsQ.and.Nr(i,k)epsN)) then + print*,'** WARNING IN MICRO **' + print*, '** src,i,k,Qr,Nr: ',source_ind,i,k,Qr(i,k),Nr(i,k) + trap = .true. + endif + if ((Qi(i,k)>epsQ.and.Ny(i,k)epsN)) then + print*,'** WARNING IN MICRO **' + print*, '** src,i,k,Qi,Ny: ',source_ind,i,k,Qi(i,k),Ny(i,k) + trap = .true. + endif + if ((Qn(i,k)>epsQ.and.Nn(i,k)epsN)) then + print*,'** WARNING IN MICRO **' + print*, '** src,i,k,Qn,Nn: ',source_ind,i,k,Qn(i,k),Nn(i,k) + trap = .true. + endif + if ((Qg(i,k)>epsQ.and.Ng(i,k)epsN)) then + print*,'** WARNING IN MICRO **' + print*, '** src,i,k,Qg,Ng: ',source_ind,i,k,Qg(i,k),Ng(i,k) + trap = .true. + endif + if ((Qh(i,k)>epsQ.and.Nh(i,k)epsN)) then + print*,'** WARNING IN MICRO **' + print*, '** src,i,k,Qh,Nh: ',source_ind,i,k,Qh(i,k),Nh(i,k) + trap = .true. + endif + endif !if (check_consistency) + enddo + enddo -!CALLING PARAMETERS: - integer, intent(in) :: ktop,kbot,kdir,nk,nk_skip,nk_sub - integer, dimension(nk_skip), intent(in) :: kskip - integer, dimension(nk_sub), intent(out) :: kfull - integer, dimension(nk_skip,3), intent(out) :: iint - - !LOCAL VARIABLES: - logical :: skip_this_one - integer :: k1,k2,k3 -!--- - - !Construct 'kfull': - kfull = 0 - k3 = 1 - do k1=1,nk - skip_this_one = .false. - do k2 = 1,nk_skip - if (k1==kskip(k2)) then !if actual levels to skip are supplied -! if (k1==nk-kskip(k2)) then !if levels from the bottom to skip are supplied - skip_this_one = .true. - exit - endif - enddo - if (.not. skip_this_one) then - kfull(k3) = k1 - k3 = k3 + 1 - endif - enddo + if (trap .and. force_abort) then + print*,'** DEBUG TRAP IN MICRO, s/r CHECK_VALUES -- source: ',source_ind + if (source_ind/=100) stop + endif - !Construct 'iint': - do k1 = 1,nk_skip - iint(k1,1) = kskip(k1) - do k2 = 1,nk_sub - if (kfull(k2)>kskip(k1)) exit - enddo - iint(k1,2) = kfull(k2-1) - iint(k1,3) = kfull(k2) - enddo + end subroutine check_values -END SUBROUTINE compute_sublevels !=====================================================================================! - SUBROUTINE sedi_wrapper(QX,NX,cat,epsQ,epsQ_sedi,epsN,dmx,ni,nk_sub,VxMax,DxMax,dt, & - massFlux_bot,kdir,kbot,ktop_sedi,GRAV,nk_skip,kfull,iint,DE_sub,iDE_sub, & - iDP_sub,DZ_sub,iDZ_sub,gamfact_sub,zheight,nk,DE,iDE,iDP,DZ,iDZ,gamfact, & - kskip1,kount,afx_in,bfx_in,cmx_in,ckQx1_in,ckQx2_in,ckQx4_in,BX,epsB) + SUBROUTINE sedi_wrapper_2(QX,NX,cat,epsQ,epsQ_sedi,epsN,dmx,ni,VxMax,DxMax,dt, & + massFlux_bot,kdir,kbot,ktop_sedi,GRAV,zheight,nk,DE,iDE,iDP, & + DZ,iDZ,gamfact,kount,afx_in,bfx_in,cmx_in,ckQx1_in,ckQx2_in,ckQx4_in) !-------------------------------------------------------------------------------------! -! Wrapper for s/r SEDI_main_2. Called from MY2_MAIN. Reduces the number of levels, -! calls SEDI_main_2, then interpolates updated QX,NX back to full levels before -! passing back. +! Wrapper for s/r SEDI, for computation on all vertical levels. Called from MY2_MAIN. !-------------------------------------------------------------------------------------! -! use my2_fncs_mod - use my_fncs_mod !GEM - implicit none ! PASSING PARAMETERS: - real, dimension(:,:), intent(inout),optional :: BX real, dimension(:,:), intent(inout) :: QX,NX real, dimension(:), intent(out) :: massFlux_bot - real, dimension(:,:), intent(in) :: DE_sub,iDE_sub,iDP_sub,DZ_sub,iDZ_sub, & - gamfact_sub,zheight, DE,iDE,iDP,DZ,iDZ,gamfact + real, dimension(:,:), intent(in) :: zheight, DE,iDE,iDP,DZ,iDZ,gamfact real, intent(in) :: epsQ,epsQ_sedi,epsN,VxMax,dmx,DxMax,dt,GRAV - real, intent(in), optional :: afx_in,bfx_in,cmx_in,ckQx1_in,ckQx2_in, & - ckQx4_in,epsB - integer, dimension(:), intent(in) :: ktop_sedi,kfull - integer, intent(in) :: ni,nk_sub,cat,kbot,kdir,nk_skip,nk,kskip1,kount - integer, dimension(:,:), intent(in) :: iint + real, intent(in), optional :: afx_in,bfx_in,cmx_in,ckQx1_in,ckQx2_in,ckQx4_in + integer, dimension(:), intent(in) :: ktop_sedi + integer, intent(in) :: ni,cat,kbot,kdir,nk,kount ! LOCAL VARIABLES: - real, dimension(:,:), allocatable :: QX_sub,NX_sub,BX_sub - real :: i_Zrun integer, dimension(size(QX,dim=1)) :: activeColumn,ktop integer :: counter - integer :: status - integer :: a,i,k,i_sub,k_sub - logical :: sediOnFull,found_blank,found_Q - -real :: tmp1,tmp2 - -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! ARGUMENTS: DESCRIPTIONS: -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! -! X (or x) in variables/parameters denots hydrometeor category x, where x = r,i,s,g,h -! for rain, ice, snow, graupel, and hail, respectively. -! -! -- INPUT: -- -! -! ktop_sedi array of k-indices of max height to consider sedi (in each column) -! ni number of columns in slab -! nk number of vertical levels -! kskip1 index of highest level to be skipped for sedimentation (0 = full levels only) -! {x}_sub arrays on sub-levels for which sedimentaion is computed -! DZ height difference between level k and k+kdir (below) [m] -! DP pressure difference between level k and k+kdir (below) [Pa] -! DE air density [kg m-3] -! gamfact air density correction factor for fall speed -! epsQ minimum allowable value of QX [kg m-3] -! epsQ_sedi minimum value of QX to compute sedimentation [kg m-3] -! epsN minimum allowable value of NX [m-3] -! zheight height above surface at level k [m] -! VxMax maximum allowable fall speed for hydrometeor category x [m s-1] -! afx, bfx fall speed parameters for hydrometeor category x -! cmx, dmx mass-diameter parameters for hydrometeor category x -! ckQx[1,2,4] precomputed expressions related to gamma functions for category x -! DxMax maximum allowable mean-mass diameter for category x [m] -! dt dynamical time step of model [s] -! GRAV gravitational constant [m s-2] -! -! -- OUTPUT: -- -! -! massFlux_bot mass flux at lowest level (for compute sedimentation rate) [kg s-1] -! -! -- INPUT/OUTPUT: -- -! -! QX, NX mixing ratio and number concentration of category X -! -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! LOCAL: DESCRIPTIONS: -! -! QX_sub,NX_sub QX,NX on active columns and sublevels to treat sedimentation -! i_Zrun denominator of height slope for interpolation back to full levels -! activeColumn array of i-indices for columns to treat sedimentation (with QX>epsQ_sedi) -! ktop array of k-indices with highest level to treat sedimentation -! counter number of columns to treat sedimentation -! status for allocate/deallocate statements (0 for success) -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! + integer :: a,i,k -!-------------------------------------------------------------------------------------! massFlux_bot = 0. - !Determine for which columns sedimentation should be computed: - ! (returns the number of columns with non-negible hydrometeor content [counter], the - ! array of i-points to treat [activeColumn], and the max. height [plus one level higher] - ! containing non-neglible content in that column) - ktop = ktop_sedi !(i-array) - for complete column, ktop(:)=1 + ktop = ktop_sedi !(i-array) - for complete column, ktop(:)=1 (GEM) or =nk (WRF) call count_columns(QX,ni,epsQ_sedi,counter,activeColumn,kdir,kbot,ktop) -! ni_sub = counter !ni of columns to process for sedi DO a = 1,counter i= activeColumn(a) !From here, all sedi calcs are done for each column i - sediOnFull = .true. !WRF -! ! !--- determine FULL or SUB: -! ! if (kskip1==0) then -! ! sediOnFull = .true. -! ! else -! ! sediOnFull = .false. -! ! !NOTE: Rather than using kskip1, base this on 2 or 3 levels higher (see notes 2013-04-25) -! ! found_blank = QX(i,kskip1-5)<=epsQ -! ! found_Q = QX(i,kskip1-5)>epsQ -! ! do k=kskip1+1-5,nk -! ! if (.not. found_blank) found_blank = (QX(i,k)<=epsQ) -! ! if (.not. found_Q) found_Q = (QX(i,k)>epsQ) -! ! if (found_blank .and. found_Q) then -! ! sediOnFull = .true. -! ! go to 66 !exit -! ! endif -! ! enddo -! ! 66 continue -! ! endif -!=== - -! ! if (sediOnFull) then -! ! !perform sedimentation on full set of levels: - -! ! if (present(BX)) then -! ! call sedi_1D(QX(i,:),NX(i,:),cat,DE(i,:),iDE(i,:),iDP(i,:),gamfact(i,:),epsQ, & -! ! ! epsN,dmx,VxMax,DxMax,dt,DZ(i,:),iDZ(i,:),massFlux_bot(i),kdir,nk,ktop(i),GRAV,BX1d=BX(i,:),epsB=epsB) -! ! epsN,dmx,VxMax,DxMax,dt,DZ(i,:),iDZ(i,:),massFlux_bot(i),kdir,kbot,ktop(i), & -! ! GRAV,BX1d=BX(i,:),epsB=epsB) -! ! else - call sedi_1D(QX(i,:),NX(i,:),cat,DE(i,:),iDE(i,:),iDP(i,:),gamfact(i,:),epsQ, & -! epsN,dmx,VxMax,DxMax,dt,DZ(i,:),iDZ(i,:),massFlux_bot(i),kdir,nk,ktop(i),GRAV,afx_in=afx_in,bfx_in=bfx_in,cmx_in=cmx_in,ckQx1_in=ckQx1_in,ckQx2_in=ckQx2_in,ckQx4_in=ckQx4_in) - epsN,dmx,VxMax,DxMax,dt,DZ(i,:),iDZ(i,:),massFlux_bot(i),kdir,kbot,ktop(i), & - GRAV,afx_in=afx_in,bfx_in=bfx_in,cmx_in=cmx_in,ckQx1_in=ckQx1_in,ckQx2_in= & - ckQx2_in,ckQx4_in=ckQx4_in) -! ! endif - -! ! else -! ! !perform sedimentation on sub-levels only: -! ! -! ! allocate ( QX_sub( ni,nk_sub), STAT=status ) -! ! allocate ( NX_sub( ni,nk_sub), STAT=status ) -! ! -! ! do k_sub = 1,nk_sub -! ! k= kfull(k_sub) -! ! QX_sub(:,k_sub) = QX(:,k) -! ! NX_sub(:,k_sub) = NX(:,k) -! ! enddo -! ! ! -! ! if (present(BX)) then -! ! allocate ( BX_sub( ni,nk_sub), STAT=status ) -! ! do k_sub = 1,nk_sub -! ! k= kfull(k_sub) -! ! BX_sub(:,k_sub) = BX(:,k) -! ! enddo -! ! endif -! ! -! ! if (present(BX)) then -! ! call sedi_1D(QX_sub(i,:),NX_sub(i,:),cat,DE_sub(i,:),iDE_sub(i,:),iDP_sub(i,:), & -! ! gamfact_sub(i,:),epsQ,epsN,dmx,VxMax,DxMax,dt,DZ_sub(i,:), & -! ! iDZ_sub(i,:),massFlux_bot(i),kdir,nk_sub,ktop(i),GRAV, & -! ! BX1d=BX_sub(i,:),epsB=epsB) -! ! else -! ! call sedi_1D(QX_sub(i,:),NX_sub(i,:),cat,DE_sub(i,:),iDE_sub(i,:),iDP_sub(i,:), & -! ! gamfact_sub(i,:),epsQ,epsN,dmx,VxMax,DxMax,dt,DZ_sub(i,:), & -! ! iDZ_sub(i,:),massFlux_bot(i),kdir,nk_sub,ktop(i),GRAV, & -! ! afx_in=afx_in,bfx_in=bfx_in,cmx_in=cmx_in,ckQx1_in=ckQx1_in, & -! ! ckQx2_in=ckQx2_in,ckQx4_in=ckQx4_in) -! ! endif -! ! -! ! !interpolate {VAR}_sub to {VAR}: -! ! -! ! !- common levels: -! ! do k_sub = 1,nk_sub -! ! k= kfull(k_sub) -! ! QX(i,k) = QX_sub(i,k_sub) -! ! NX(i,k) = NX_sub(i,k_sub) -! ! enddo -! ! ! -! ! if (present(BX)) then -! ! do k_sub = 1,nk_sub -! ! k= kfull(k_sub) -! ! BX(i,k) = BX_sub(i,k_sub) -! ! enddo -! ! endif -! ! != -! ! -! ! !- interpolated levels: -! ! do k = 1,nk_skip -! ! i_Zrun = 1./(zheight(i,iint(k,2))-zheight(i,iint(k,3))) -! ! QX(i,iint(k,1))= QX(i,iint(k,3))+(zheight(i,iint(k,1))-zheight(i,iint(k,3)))* & -! ! ( (QX(i,iint(k,2))-QX(i,iint(k,3)))*i_Zrun ) -! ! NX(i,iint(k,1))= NX(i,iint(k,3))+(zheight(i,iint(k,1))-zheight(i,iint(k,3)))* & -! ! ( (NX(i,iint(k,2))-NX(i,iint(k,3)))*i_Zrun ) -! ! enddo -! ! ! -! ! if (present(BX)) then -! ! do k = 1,nk_skip -! ! i_Zrun = 1./(zheight(i,iint(k,2))-zheight(i,iint(k,3))) -! ! BX(i,iint(k,1))=BX(i,iint(k,3))+(zheight(i,iint(k,1))-zheight(i,iint(k,3)))*& -! ! ( (BX(i,iint(k,2))-BX(i,iint(k,3)))*i_Zrun ) -! ! enddo -! ! endif -! ! != -! ! -! ! deallocate ( QX_sub, STAT=status ) -! ! deallocate ( NX_sub, STAT=status ) -! ! if (present(BX)) deallocate ( BX_sub, STAT=status ) -! ! -! ! endif !if (sediOnFull) + call sedi_1D(QX(i,:),NX(i,:),cat,DE(i,:),iDE(i,:),iDP(i,:),gamfact(i,:),epsQ,epsN, & + dmx,VxMax,DxMax,dt,DZ(i,:),iDZ(i,:),massFlux_bot(i),kdir,kbot,ktop(i), & + GRAV,afx_in=afx_in,bfx_in=bfx_in,cmx_in=cmx_in,ckQx1_in=ckQx1_in, & + ckQx2_in=ckQx2_in,ckQx4_in=ckQx4_in) ENDDO !a-loop - END SUBROUTINE sedi_wrapper + END SUBROUTINE sedi_wrapper_2 !=====================================================================================! - SUBROUTINE sedi_1D(QX1d,NX1d,cat,DE1d,iDE1d,iDP1d,gamfact1d,epsQ,epsN,dmx,VxMax,DxMax, & - dt,DZ1d,iDZ1d,massFlux_bot,kdir,kbot,ktop,GRAV,afx_in,bfx_in,cmx_in, & +SUBROUTINE sedi_1D(QX1d,NX1d,cat,DE1d,iDE1d,iDP1d,gamfact1d,epsQ,epsN,dmx,VxMax,DxMax, & + dt,DZ1d,iDZ1d,massFlux_bot,kdir,kbot,ktop,GRAV,afx_in,bfx_in,cmx_in, & ckQx1_in,ckQx2_in,ckQx4_in,BX1d,epsB) -!-------------------------------------------------------------------------------------! -! Performs 2-moment sedimentation on a single column for hydrometeor categories whose -! fall velocity equation is V(D) = gamfact * afx * D^bfx. -! Sub-time stepping for numerical stability is determined locally. -!-------------------------------------------------------------------------------------! - -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! ARGUMENTS: DESCRIPTIONS: -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! -! -! X (or x) in variables/parameters denots hydrometeor category x, where x = r,i,s,g,h -! for rain, ice, snow, graupel, and hail, respectively. -! -! -- INPUT: -- -! -! cat hydrometeor category (value of 1,2,3,4,5 for x=r,i,s,g,h, respectively) -! DE air density -! iDE 1./DE -! iDP 1./(pressure difference beween level k and level above) -! gamfact air density correction factor -! epsQ minimum allowable mixing ratio -! epsN minimum allowable number concentration -! afx fall velocity parameter (coefficient) -! bfx fall velocity parameter (exponent) -! cmx mass-diameter parameter (coefficient) -! dmx mass-diameter parameter (exponent) -! ckQx1 size distribution term [function of GAMMA(...)] -! ckQx2 size distribution term [function of GAMMA(...)] -! ckQx4 size distribution term [function of GAMMA(...)] -! VxMax maximum mass-weighted fall velocity (for category X) -! DxMax maximum mean-mass diameter (for category x) -! dt model tim step -! DZ vertical grid spacing between level k and level below -! iDZ 1./DZ -! kdir vertical leveling increment, (GEM: kdir=-1; WRF: kdir=1) -! kbot k index of bottom level (GEM: kbot=nk; WRF: kbot=1) -! GRAV gravitational constant -! -! -- OUTPUT: -- -! -! massFlux_bot mass flux (at lowest model level) -! -! -- INPUT/OUTPUT: -- -! -! QX hydrometeor mixing ratio -! NX hydrometeor total number concentration -! -!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -! - -! use my2_fncs_mod - use my_fncs_mod !GEM - implicit none ! PASSING PARAMETERS: @@ -852,7 +644,7 @@ SUBROUTINE sedi_1D(QX1d,NX1d,cat,DE1d,iDE1d,iDP1d,gamfact1d,epsQ,epsN,dmx,VxMax, BX_present = present(BX1d) !for rain, ice, snow, hail: - if (.not. (cat==4 .and. BX_present)) then +! ! if (.not. (cat==4 .and. BX_present)) then afx = afx_in bfx = bfx_in cmx = cmx_in @@ -861,7 +653,7 @@ SUBROUTINE sedi_1D(QX1d,NX1d,cat,DE1d,iDE1d,iDP1d,gamfact1d,epsQ,epsN,dmx,VxMax, ckQx2 = ckQx2_in ckQx4 = ckQx4_in ratio_Vn2Vq = ckQx2/ckQx1 - endif +! ! endif massFlux_bot = 0. iDxMax = 1./DxMax @@ -872,38 +664,19 @@ SUBROUTINE sedi_1D(QX1d,NX1d,cat,DE1d,iDE1d,iDP1d,gamfact1d,epsQ,epsN,dmx,VxMax, VnMax = 0. VVQ(:) = 0. -! ! if (cat==4 .and. BX_present) then -! ! !for graupel: -! ! do k= kbot,ktop,kdir -! ! QxPresent = (QX1d(k)>epsQ .and. NX1d(k)>epsN .and. BX1d(k)>epsB) -! ! if (QxPresent) then -! ! call compute_graupel_parameters(2,QX1d(k),NX1d(k),BX1d(k),epsQ,epsN,epsB, & -! ! DE1d(k),PIov6,thrd,dmx,alpha_x,iLAMx,afx,bfx,cmx,icmx,ckQx1, & -! ! ckQx2,ckQx4) -! ! ratio_Vn2Vq = ckQx2/ckQx1 -! ! VVQ(k) = VV_Qg() -! ! endif -! ! enddo -! ! else -! ! !for rain, ice, snow, hail: do k= kbot,ktop,kdir QxPresent = (QX1d(k)>epsQ .and. NX1d(k)>epsN) if (QxPresent) VVQ(k)= VV_Q() enddo -! ! endif Vxmaxx= min( VxMax, maxval(VVQ(:))) if (kdir==1) then - dzMIN = minval(DZ1d(ktop-kdir:kbot)) !WRF (to be tested) + dzMIN = minval(DZ1d) !WRF (to be tested) else dzMIN = minval(DZ1d(ktop:kbot+kdir)) !GEM endif npassx= max(1, nint( dt*Vxmaxx/(CoMAX*dzMIN) )) -!test: -! if (cat==4 .or. cat==5) npassx= max(1, nint( dt*Vxmaxx/(0.5*CoMAX*dzMIN) )) -! if (cat==4 .or. cat==5) npassx= npassx + 2 -! if (cat==4 ) npassx= max(4, nint( dt*Vxmaxx/(0.5*CoMAX*dzMIN) )) dtx = dt/float(npassx) @@ -911,45 +684,6 @@ SUBROUTINE sedi_1D(QX1d,NX1d,cat,DE1d,iDE1d,iDP1d,gamfact1d,epsQ,epsN,dmx,VxMax, DO nnn= 1,npassx firstPass = (nnn==1) - -! ! if (cat==4 .and. BX_present) then -! ! -! ! !for graupel: -! ! do k= kbot,ktop,kdir -! ! QxPresent = (QX1d(k)>epsQ .and. NX1d(k)>epsN .and. BX1d(k)>epsB) -! ! if (QxPresent) then -! ! if (firstPass) then !to avoid re-computing VVQ on first pass -! ! VVQ(k)= -VVQ(k) -! ! else -! ! call compute_graupel_parameters(3,QX1d(k),NX1d(k),BX1d(k),epsQ,epsN,epsB, & -! ! DE1d(k),PIov6,thrd,dmx,alpha_x,iLAMx,afx,bfx,cmx,icmx,ckQx1, & -! ! ckQx2,ckQx4) -! ! ratio_Vn2Vq = ckQx2/ckQx1 -! ! VVQ(k) = -VV_Qg() -! ! endif -! ! !-- -! ! ! !to control excessive size-sorting for graupel: -! ! ! ! note: with constant alpha_g=3, there appears to be no need for extra -! ! ! ! control of size-sorting. (commented code is left as a placeholder) -! ! ! tmp1 = (icmx*QX1d(k)/NX1d(k))**thrd !Dmg -! ! ! tmp2 = min(50., 0.5*(1000.*tmp1)) !mu = const*Dmg [mm] -! ! ! ratio_Vn2Vq = ((3.+tmp2)*(2.+tmp2)*(1.+tmp2))/((3.+bfx+tmp2)* & -! ! ! (2.+bfx+tmp2)*(1.+bfx+tmp2)) -! ! !== -! ! VVN(k) = VVQ(k)*ratio_Vn2Vq -! ! VqMax = max(VxMAX,-VVQ(k)) -! ! VnMax = max(VxMAX,-VVN(k)) -! ! else -! ! VVQ(k) = 0. -! ! VVN(k) = 0. -! ! VqMax = 0. -! ! VnMax = 0. -! ! endif -! ! enddo !k-loop -! ! -! ! else -! ! -! ! !for rain, ice, snow, hail: do k= kbot,ktop,kdir QxPresent = (QX1d(k)>epsQ .and. NX1d(k)>epsN) if (QxPresent) then @@ -958,15 +692,15 @@ SUBROUTINE sedi_1D(QX1d,NX1d,cat,DE1d,iDE1d,iDP1d,gamfact1d,epsQ,epsN,dmx,VxMax, else VVQ(k)= -VV_Q() endif -!!*** TUNING FOR HAIL *** -! if (cat==5) then -! !to control excessive size-sorting for hail: -! tmp1 = (icmx*QX1d(k)/NX1d(k))**thrd !Dmh -! tmp2 = min(50., 0.1*(1000.*tmp1)) !mu = const*Dmh [mm] -! ratio_Vn2Vq = ((3.+tmp2)*(2.+tmp2)*(1.+tmp2))/((3.+bfx+tmp2)* & -! (2.+bfx+tmp2)*(1.+bfx+tmp2)) -! endif -!!*** + !-- + !control excessive size-sorting for hail: + if (cat==5) then + tmp1 = (icmx*QX1d(k)/NX1d(k))**thrd !Dmh + tmp2 = min(50., 0.1*(1000.*tmp1)) !mu = const*Dmh [mm] + ratio_Vn2Vq = ((3.+tmp2)*(2.+tmp2)*(1.+tmp2))/((3.+bfx+tmp2)* & + (2.+bfx+tmp2)*(1.+bfx+tmp2)) + endif + !== VVN(k) = VVQ(k)*ratio_Vn2Vq VqMax = max(VxMAX,-VVQ(k)) VnMax = max(VxMAX,-VVN(k)) @@ -978,20 +712,7 @@ SUBROUTINE sedi_1D(QX1d,NX1d,cat,DE1d,iDE1d,iDP1d,gamfact1d,epsQ,epsN,dmx,VxMax, endif enddo !k-loop -! ! endif - - !sum instantaneous surface mass flux at each split step: (for division later) massFlux_bot= massFlux_bot - VVQ(kbot)*DE1d(kbot)*QX1d(kbot) - !-- Perform single split sedimentation step (Eulerian FIT-BIS): - ! note: VVQ and VVN are negative (downward) -! !p-coordinates: -! do k= kbot,ktop,kdir -! QX1d(k)= QX1d(k) + dtx*GRAV*iDP1d(k+kdir)*(-DE1d(k+kdir)*QX1d(k+kdir)* & -! VVQ(k+kdir)+DE1d(k)*QX1d(k)*VVQ(k)) -! NX1d(k)= NX1d(k) + dtx*GRAV*iDP1d(k+kdir)*DE1d(k)*(-NX1d(k+kdir)* & -! VVN(k+kdir)+ NX1d(k)*VVN(k)) -! enddo - !z-coordinates: do k= kbot,ktop,kdir QX1d(k)= QX1d(k) + dtx*iDE1d(k)*(-DE1d(k+kdir)*QX1d(k+kdir)*VVQ(k+kdir) + & DE1d(k)*QX1d(k)*VVQ(k))*iDZ1d(k+kdir) @@ -1113,20 +834,7 @@ SUBROUTINE count_columns(QX,ni,minQX,counter,activeColumn,kdir,kbot,ktop) enddo END SUBROUTINE count_columns -!=====================================================================================! - -end module my_sedi_mod - -!________________________________________________________________________________________! - -module my_dmom_mod - - implicit none - - private - public :: mp_milbrandt2mom_main - - contains +!=======================================================================================! !_______________________________________________________________________________________! @@ -1135,14 +843,6 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, dt,NI,NK,J,KOUNT,CCNtype,precipDiag_ON,sedi_ON,warmphase_ON,autoconv_ON,icephase_ON, & snow_ON,Dm_c,Dm_r,Dm_i,Dm_s,Dm_g,Dm_h,ZET,ZEC,SS,nk_bottom) - - use my_fncs_mod - use my_sedi_mod -!--WRF: - use module_model_constants, ONLY: CPD => cp, CPV => cpv, RGASD => r_d, RGASV => r_v, & - EPS1 => EP_2, DELTA => EP_1, CAPPA => rcp, GRAV => g, CHLC => XLV, CHLF => XLF -!== - implicit none !CALLING PARAMETERS: @@ -1163,9 +863,6 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, ! Milbrandt-Yau Multimoment Bulk Microphysics Scheme ! ! - double-moment version - ! !_______________________________________________________________________________________! -! Package version: 2.25.0 (internal bookkeeping) ! -! Last modified : 2014-03 ! -!_______________________________________________________________________________________! ! ! Author: ! J. Milbrandt, McGill University (August 2004) @@ -1283,8 +980,7 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, !LOCAL VARIABLES: !Variables to count active grid points: - logical :: log1,log2,log3,log4,doneK,rainPresent,calcDiag,CB_found,ML_found, & - SN_found + logical :: log1,log2,log3,log4,doneK,rainPresent,calcDiag logical, dimension(size(QC,dim=1),size(QC,dim=2)) :: activePoint integer, dimension(size(QC,dim=1)) :: ktop_sedi integer :: i,k,niter,ll,start,kskip_1,ktop,kbot,kdir @@ -1371,10 +1067,6 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, real, parameter :: iLAMmin1= 1.e-6 !min. iLAMx (prevents underflow in Nox and VENTx calcs) real, parameter :: iLAMmin2= 1.e-10 !min. iLAMx (prevents underflow in Nox and VENTx calcs) real, parameter :: eps = 1.e-32 - real, parameter :: k1 = 0.001 - real, parameter :: k2 = 0.0005 - real, parameter :: k3 = 2.54 - real, parameter :: CPW = 4218., CPI=2093. real, parameter :: deg = 400., mgo= 1.6e-10 real, parameter :: deh = 900. @@ -1391,9 +1083,10 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, real, parameter :: DrMax= 5.e-3, VrMax= 16., epsQr_sedi= 1.e-8 real, parameter :: DiMax= 5.e-3, ViMax= 2., epsQi_sedi= 1.e-10 real, parameter :: DsMax= 5.e-3, VsMax= 4., epsQs_sedi= 1.e-8 - real, parameter :: DgMax= 5.e-3, VgMax= 6., epsQg_sedi= 1.e-8 + real, parameter :: DgMax= 2.e-3, VgMax= 6., epsQg_sedi= 1.e-8 real, parameter :: DhMax= 80.e-3, VhMax= 25., epsQh_sedi= 1.e-10 + real, parameter :: CPW = 4218. ![J kg-1 K-1] specific heat capacity of water real, parameter :: DEo = 1.225 ![kg m-3] reference air density real, parameter :: thrd = 1./3. real, parameter :: sixth = 0.5*thrd @@ -1427,27 +1120,20 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, real, parameter :: Fv_Dsmin = 125.e-6 ![m] min snow size to compute volume flux real, parameter :: Fv_Dsmax = 0.008 ![m] max snow size to compute volume flux real, parameter :: Ni_max = 1.e+7 ![m-3] max ice crystal concentration + real, parameter :: satw_peak = 1.01 !assumed max. peak saturation w.r.t. water (for calc of Simax) !------------------------------------------------------------------------------! !-- For GEM: !#include "consphy.cdk" -!-- For WRF: -!#include "consphy.cdk" -! real, parameter :: CPD =.100546e+4 !J K-1 kg-1; specific heat of dry air -! real, parameter :: CPV =.186946e+4 !J K-1 kg-1; specific heat of water vapour -! real, parameter :: RGASD =.28705e+3 !J K-1 kg-1; gas constant for dry air -! real, parameter :: RGASV =.46151e+3 !J K-1 kg-1; gas constant for water vapour +!-- For WRF + kin_1d + kin_2d: + real, parameter :: CPI =.21153e+4 !J kg-1 K-1; specific heat capacity of ice real, parameter :: TRPL =.27316e+3 !K; triple point of water real, parameter :: TCDK =.27315e+3 !conversion from kelvin to celsius real, parameter :: RAUW =.1e+4 !density of liquid H2O -! real, parameter :: EPS1 =.62194800221014 !RGASD/RGASV real, parameter :: EPS2 =.3780199778986 !1 - EPS1 -! real, parameter :: DELTA =.6077686814144 !1/EPS1 - 1 -! real, parameter :: CAPPA =.28549121795 !RGASD/CPD real, parameter :: TGL =.27316e+3 !K; ice temperature in the atmosphere real, parameter :: CONSOL =.1367e+4 !W m-2; solar constant -! real, parameter :: GRAV =.980616e+1 !M s-2; gravitational acceleration real, parameter :: RAYT =.637122e+7 !M; mean radius of the earth real, parameter :: STEFAN =.566948e-7 !J m-2 s-1 K-4; Stefan-Boltzmann constant real, parameter :: PI =.314159265359e+1 !PI constant = ACOS(-1) @@ -1456,8 +1142,18 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, real, parameter :: STLO =.6628486583943e-3 !K s2 m-2; Schuman-Newell Lapse Rate real, parameter :: KARMAN =.35 !Von Karman constant real, parameter :: RIC =.2 !Critical Richardson number -! real, parameter :: CHLC =.2501e+7 !J kg-1; latent heat of condensation -! real, parameter :: CHLF =.334e+6 !J kg-1; latent heat of fusion +!-- For kin_1d + kin_2d (exclude from WRF): + real, parameter :: CHLC =.2501e+7 !J kg-1; latent heat of condensation + real, parameter :: CHLF =.334e+6 !J kg-1; latent heat of fusion + real, parameter :: CPD =.100546e+4 !J K-1 kg-1; specific heat of dry air + real, parameter :: CPV =.186946e+4 !J K-1 kg-1; specific heat of water vapour + real, parameter :: RGASD =.28705e+3 !J K-1 kg-1; gas constant for dry air + real, parameter :: RGASV =.46151e+3 !J K-1 kg-1; gas constant for water vapour + real, parameter :: EPS1 =.62194800221014 !RGASD/RGASV + real, parameter :: DELTA =.6077686814144 !1/EPS1 - 1 + real, parameter :: CAPPA =.28549121795 !RGASD/CPD + real, parameter :: GRAV =.980616e+1 !M s-2; gravitational acceleration +!== !------------------------------------------------------------------------------! ! Constants used for contact ice nucleation: @@ -1469,6 +1165,8 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, real, parameter :: KAPa = 5.39e5 !aerosol thermal conductivity !Test switches: + logical, parameter :: DEBUG_ON = .false. !.true. to switch on debugging checks/traps throughout code + logical, parameter :: DEBUG_abort = .true. !.true. will result in forced abort in s/r 'check_values' logical, parameter :: iceDep_ON = .true. !.false. to suppress depositional growth of ice logical, parameter :: grpl_ON = .true. !.false. to suppress graupel initiation logical, parameter :: hail_ON = .true. !.false. to suppress hail initiation @@ -1482,12 +1180,14 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, real, dimension(size(QC,dim=1)) :: fluxM_r,fluxM_i,fluxM_s,fluxM_g, & fluxM_h,dum integer, dimension(size(QC,dim=1)) :: activeColumn - integer :: k_sub,nk_sub,nk_skip - integer :: status !for allocate/deallocate statements (0 for success) - integer, allocatable, dimension(:) :: kfull,kskip - integer, allocatable, dimension(:,:) :: iint - real, dimension(:,:), allocatable :: DE_sub,iDE_sub,iDP_sub,pres_sub, & - DZ_sub,zheight_sub,iDZ_sub,gamfact_sub + + !-- for use with sedimentation on subset of levels: + !integer :: k_sub,nk_sub,nk_skip + !integer :: status !for allocate/deallocate statements (0 for success) + !integer, allocatable, dimension(:) :: kfull,kskip + !integer, allocatable, dimension(:,:) :: iint + !real, dimension(:,:), allocatable :: DE_sub,iDE_sub,iDP_sub,pres_sub, & + !== DZ_sub,zheight_sub,iDZ_sub,gamfact_sub !==================================================================================! @@ -1496,6 +1196,10 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, ! PART 1: Prelimiary Calculations ! !----------------------------------------------------------------------------------! + !Switch on here later, once it is certain that calling routine is not supposed to + !pass negative values of tracers. + if (DEBUG_ON) call check_values(Q,T,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,epsQ,epsN,.false.,DEBUG_abort,100) + if (nk_BOTTOM) then ! !GEM / kin_1d: ktop = 1 !k of top level @@ -1508,19 +1212,6 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, kdir = 1 !direction of vertical leveling (k: 1=bottom, nk=top) endif -!!-------- Specify levels to skip for sedimentation: -----! -! User-specified (assuming nk=bottom) -! !-- L(general), full levels - nk_skip = 0 - allocate ( kskip(nk_skip), STAT=status ) - kskip = 0 -! !-- L57, subset 2 -! nk_skip = 8 -! allocate ( kskip(nk_skip), STAT=status ) -! kskip = (/ 45, 47, 49,50, 52,53,55,56 /) -!!========================================================! - - do k= kbot,ktop,kdir pres(:,k)= PS(:)*sigma(:,k) !air pressure [Pa] do i=1,ni @@ -1748,6 +1439,7 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, !#### !=======================================================================================! +! if (DEBUG_ON) call check_values(Q,T,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,epsQ,epsN,.false.,DEBUG_abort,200) !--- Ensure consistency between moments: do k= kbot,ktop,kdir @@ -1757,16 +1449,19 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, tmp2 = QSI(i,k)/max(Q(i,k),1.e-20) !saturation w.r.t. ice !NOTE: Hydrometeor (Qx,Nx) is clipped if Qx is tiny or if Qx is small ! and is expected to completely evaporate/sublimate in one time step - ! anyway. + ! anyway. (To avoid creating mass from a parallel universe, only + ! positive Qx values are added to water vapor upon clipping.) ! ** RH thresholds for clipping need to be tuned (especially for graupel ! and hail, for which it may be preferable to reduce threshold) + !cloud: if (QC(i,k)>epsQ .and. NC(i,k)epsQ .and. NY(i,k)50.) & - print*, '***WARNING*** -- In MICROPHYSICS -- Ambient Temp.(C):',Tc -! Cdiff = (2.2157e-5+0.0155e-5*Tc)*1.e5/(sigma(i,k)*HPS(i)) + if (Tc<-120. .or. Tc>50.) then + print*, '***WARNING*** -- In MICROPHYSICS -- Ambient Temp.(C),step,i,k:',Tc,kount,i,k + !stop + endif Cdiff = (2.2157e-5+0.0155e-5*Tc)*1.e5/pres(i,k) MUdyn = 1.72e-5*(393./(T(i,k)+120.))*(T(i,k)/TRPL)**1.5 !RYp.102 MUkin = MUdyn*iDE(i,k) @@ -2147,7 +1853,7 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, endif !snow: (i.e. self-collection [aggregation]) - NCLss= dt*0.93952*Ess*(DE(i,k)*(QN(i,k)))**((2.+bfs)*thrd)*(NN(i,k))** & + NCLss= dt*0.93952*Ess*(DE(i,k)*(QN(i,k)))**((2.+bfs)*thrd)*(NN(i,k))** & ((4.-bfs)*thrd) !Note: 0.91226 = I(bfs)*afs*PI^((1-bfs)/3)*des^((-2-bfs)/3); I(bfs=0.41)=1138 ! 0.93952 = I(bfs)*afs*PI^((1-bfs)/3)*des^((-2-bfs)/3); I(bfs=0.42)=1172 @@ -2170,11 +1876,11 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, Kstoke = max(1.5,min(10.,Kstoke)) Ecg = 0.55*log10(2.51*Kstoke) - QCLcg= dt*gam*afg*cmr*Ecg*PIov4*iDE(i,k)*(NC(i,k)*NG(i,k))*iGC5*iGG31* & + QCLcg= dt*gam*afg*cmr*Ecg*PIov4*iDE(i,k)*(NC(i,k)*NG(i,k))*iGC5*iGG31* & (GC13*GG13*iLAMc3*iLAMgB2+ 2.*GC14*GG12*iLAMc4*iLAMgB1+GC15*GG11* & iLAMc5*iLAMgB0) - NCLcg= dt*gam*afg*PIov4*Ecg*(NC(i,k)*NG(i,k))*iGC5*iGG31*(GC5*GG13* & + NCLcg= dt*gam*afg*PIov4*Ecg*(NC(i,k)*NG(i,k))*iGC5*iGG31*(GC5*GG13* & iLAMgB2+2.*GC11*GG12*iLAMc*iLAMgB1+GC12*GG11*iLAMc2*iLAMgB0) QCLcg= min(QCLcg, (QC(i,k))) @@ -2188,9 +1894,9 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, tmp1= vg0-vi0 tmp3= sqrt(tmp1*tmp1+0.04*vg0*vi0) - QCLig= dt*cmi*iDE(i,k)*PI*6.*Eig*(NY(i,k)*NG(i,k))*tmp3*iGI31*iGG31*(0.5* & + QCLig= dt*cmi*iDE(i,k)*PI*6.*Eig*(NY(i,k)*NG(i,k))*tmp3*iGI31*iGG31*(0.5* & iLAMg2*iLAMi3+2.*iLAMg*iLAMi4+5.*iLAMi5) - NCLig= dt*PIov4*Eig*(NY(i,k)*NG(i,k))*GI31*GG31*tmp3*(GI33*GG31*iLAMi2+ & + NCLig= dt*PIov4*Eig*(NY(i,k)*NG(i,k))*GI31*GG31*tmp3*(GI33*GG31*iLAMi2+ & 2.*GI32*GG32*iLAMi*iLAMg+GI31*GG33*iLAMg2) QCLig= min(QCLig, (QI(i,k))) @@ -2228,11 +1934,11 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, if (QC(i,k)>epsQ) then Ech = exp(-8.68e-7*Dc**(-1.6)*Dh) !Ziegler (1985) A24 - QCLch= dt*gam*afh*cmr*Ech*PIov4*iDE(i,k)*(NC(i,k)*NH(i,k))*iGC5*iGH31* & + QCLch= dt*gam*afh*cmr*Ech*PIov4*iDE(i,k)*(NC(i,k)*NH(i,k))*iGC5*iGH31* & (GC13*GH13*iLAMc3*iLAMhB2+2.*GC14*GH12*iLAMc4*iLAMhB1+GC15*GH11* & iLAMc5*iLAMhB0) - NCLch= dt*gam*afh*PIov4*Ech*(NC(i,k)*NH(i,k))*iGC5*iGH31*(GC5*GH13* & + NCLch= dt*gam*afh*PIov4*Ech*(NC(i,k)*NH(i,k))*iGC5*iGH31*(GC5*GH13* & iLAMhB2+2.*GC11*GH12*iLAMc*iLAMhB1+GC12*GH11*iLAMc2*iLAMhB0) QCLch= min(QCLch, QC(i,k)) @@ -2245,10 +1951,10 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, if (QR(i,k)>epsQ) then tmp1= vh0-vr0 tmp3= sqrt(tmp1*tmp1+0.04*vh0*vr0) - QCLrh= dt*cmr*Erh*PIov4*iDE(i,k)*(NH(i,k)*NR(i,k))*iGR31*iGH31*tmp3* & + QCLrh= dt*cmr*Erh*PIov4*iDE(i,k)*(NH(i,k)*NR(i,k))*iGR31*iGH31*tmp3* & (GR36*GH31*iLAMr5+2.*GR35*GH32*iLAMr4*iLAMh+GR34*GH33*iLAMr3*iLAMh2) - NCLrh= dt*PIov4*Erh*(NH(i,k)*NR(i,k))*iGR31*iGH31*tmp3*(GR33*GH31* & + NCLrh= dt*PIov4*Erh*(NH(i,k)*NR(i,k))*iGR31*iGH31*tmp3*(GR33*GH31* & iLAMr2+2.*GR32*GH32*iLAMr*iLAMh+GR31*GH33*iLAMh2) QCLrh= min(QCLrh, QR(i,k)) @@ -2262,10 +1968,10 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, tmp1 = vh0-vi0 tmp3 = sqrt(tmp1*tmp1+0.04*vh0*vi0) - QCLih= dt*cmi*iDE(i,k)*PI*6.*Eih*(NY(i,k)*NH(i,k))*tmp3*iGI31*iGH31*(0.5* & + QCLih= dt*cmi*iDE(i,k)*PI*6.*Eih*(NY(i,k)*NH(i,k))*tmp3*iGI31*iGH31*(0.5* & iLAMh2*iLAMi3+2.*iLAMh*iLAMi4+5.*iLAMi5) - NCLih= dt*PIov4*Eih*(NY(i,k)*NH(i,k))*GI31*GH31*tmp3*(GI33*GH31*iLAMi2+ & + NCLih= dt*PIov4*Eih*(NY(i,k)*NH(i,k))*GI31*GH31*tmp3*(GI33*GH31*iLAMi2+ & 2.*GI32*GH32*iLAMi*iLAMh+GI31*GH33*iLAMh2) QCLih= min(QCLih, QI(i,k)) @@ -2282,16 +1988,16 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, if (snowSpherical) then !hardcoded for dms=3: - QCLsh= dt*cms*iDE(i,k)*PI*6.*Esh*(NN(i,k)*NH(i,k))*tmp3*iGS31*iGH31* & + QCLsh= dt*cms*iDE(i,k)*PI*6.*Esh*(NN(i,k)*NH(i,k))*tmp3*iGS31*iGH31* & (0.5*iLAMh2*iLAMs2*iLAMs+2.*iLAMh*tmp4+5.*tmp4*iLAMs) else !hardcoded for dms=2: - QCLsh= dt*cms*iDE(i,k)*PI*0.25*Esh*tmp3*NN(i,k)*NH(i,k)*iGS31*iGH31* & - (GH33*GS33*iLAMh**2.*iLAMs**2. + 2.*GH32*GS34*iLAMh*iLAMs**3. + & + QCLsh= dt*cms*iDE(i,k)*PI*0.25*Esh*tmp3*NN(i,k)*NH(i,k)*iGS31*iGH31* & + (GH33*GS33*iLAMh**2.*iLAMs**2. + 2.*GH32*GS34*iLAMh*iLAMs**3. + & GH31*GS35*iLAMs**4.) endif - NCLsh= dt*PIov4*Esh*(NN(i,k)*NH(i,k))*GS31*GH31*tmp3*(GS33*GH31*iLAMs2+ & + NCLsh= dt*PIov4*Esh*(NN(i,k)*NH(i,k))*GS31*GH31*tmp3*(GS33*GH31*iLAMs2+ & 2.*GS32*GH32*iLAMs*iLAMh+GS31*GH33*iLAMh2) QCLsh= min(QCLsh, (QN(i,k))) @@ -2432,7 +2138,11 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, if (primIceNucl==1) then NuDEPSOR= 0.; NuCONT= 0. - Simax = min(Si, SxFNC(WZ(i,k),Tc,pres(i,k),QSW(i,k),QSI(i,k),CCNtype,2)) + if (QSI(i,k)>1.e-20) then + Simax = min(Si, satw_peak*QSW(i,k)/QSI(i,k)) + else + Simax = 0. + endif tmp1 = T(i,k)-7.66 NNUmax = max(0., DE(i,k)/mio*(Q(i,k)-QSI(i,k))/(1.+ck6*(QSI(i,k)/(tmp1* & tmp1)))) @@ -2441,11 +2151,15 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, NuDEPSOR= max(0., 1.e3*exp(12.96*(Simax-1.)-0.639)-(NY(i,k))) !Meyers(1992) endif !Contact nucleation: - if (QC(i,k)>epsQ .and. Tc<-2.) then + if (QC(i,k)>epsQ .and. Tc<-2. .and. WZ(i,k)>0.001) then GG = 1.*idew/(RGASV*(T(i,k))/((QSW(i,k)*pres(i,k))/EPS1)/ & Cdiff+CHLC/Ka/(T(i,k))*(CHLC/RGASV/(T(i,k))-1.)) !CP00a Swmax = SxFNC(WZ(i,k),Tc,pres(i,k),QSW(i,k),QSI(i,k),CCNtype,1) - ssat = min((Q(i,k)/QSW(i,k)), Swmax) -1. + if (QSW(i,k)>1.e-20) then + ssat= min((Q(i,k)/QSW(i,k)), Swmax) -1. + else + ssat= 0. + endif Tcc = Tc + GG*ssat*CHLC/Kdiff !C86_eqn64 Na = exp(4.11-0.262*Tcc) !W95_eqn60/M92_2.6 Kn = LAMa0*(T(i,k))*p0/(T0*pres(i,k)*Ra) !W95_eqn59 @@ -2511,7 +2225,8 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, !estimate ice PSD after VDvi (if there were no CNis): tmp1 = QI(i,k) + QVDvi tmp2 = NY(i,k) + NVDvi - iLAMi = max( iLAMmin2, iLAMDA_x(DE(i,k),tmp1,1./tmp2,icexi9,thrd) ) + tmp3 = 1./tmp2 + iLAMi = max( iLAMmin2, iLAMDA_x(DE(i,k),tmp1,tmp3,icexi9,thrd) ) No_i = tmp2*iGI31/iLAMi !optimized for alpha_i=0 !compute number and mass of ice converted to snow as the integral from ! Dso to INF of Ni(D)dD and m(D)Ni(D)dD, respectively: @@ -2535,14 +2250,14 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, tmp1 = vr0-vi0 tmp3 = sqrt(tmp1*tmp1+0.04*vr0*vi0) - QCLir= dt*cmi*Eri*PIov4*iDE(i,k)*(NR(i,k)*NY(i,k))*iGI31*iGR31*tmp3* & + QCLir= dt*cmi*Eri*PIov4*iDE(i,k)*(NR(i,k)*NY(i,k))*iGI31*iGR31*tmp3* & (GI36*GR31*iLAMi5+2.*GI35*GR32*iLAMi4*iLAMr+GI34*GR33*iLAMi3* & iLAMr2) - NCLri= dt*PIov4*Eri*(NR(i,k)*NY(i,k))*iGI31*iGR31*tmp3*(GI33*GR31* & + NCLri= dt*PIov4*Eri*(NR(i,k)*NY(i,k))*iGI31*iGR31*tmp3*(GI33*GR31* & iLAMi2+2.*GI32*GR32*iLAMi*iLAMr+GI31*GR33*iLAMr2) - QCLri= dt*cmr*Eri*PIov4*iDE(i,k)*(NY(i,k)*NR(i,k))*iGR31*iGI31*tmp3* & + QCLri= dt*cmr*Eri*PIov4*iDE(i,k)*(NY(i,k)*NR(i,k))*iGR31*iGI31*tmp3* & (GR36*GI31 *iLAMr5+2.*GR35*GI32*iLAMr4*iLAMi+GR34*GI33*iLAMr3* & iLAMi2) @@ -2628,21 +2343,21 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, tmp2 = sqrt(tmp1*tmp1+0.04*vs0*vr0) tmp6 = iLAMs2*iLAMs2*iLAMs - QCLrs= dt*cmr*Ers*PIov4*iDE(i,k)*NN(i,k)*NR(i,k)*iGR31*iGS31*tmp2* & + QCLrs= dt*cmr*Ers*PIov4*iDE(i,k)*NN(i,k)*NR(i,k)*iGR31*iGS31*tmp2* & (GR36*GS31*iLAMr5+2.*GR35*GS32*iLAMr4*iLAMs+GR34*GS33*iLAMr3* & iLAMs2) - NCLrs= dt*0.25e0*PI*Ers*(NN(i,k)*NR(i,k))*iGR31*iGS31*tmp2*(GR33* & + NCLrs= dt*0.25e0*PI*Ers*(NN(i,k)*NR(i,k))*iGR31*iGS31*tmp2*(GR33* & GS31*iLAMr2+2.*GR32*GS32*iLAMr*iLAMs+GR31*GS33*iLAMs2) if (snowSpherical) then !hardcoded for dms=3: - QCLsr= dt*cms*Ers*PIov4*iDE(i,k)*(NR(i,k)*NN(i,k))*iGS31*iGR31* & + QCLsr= dt*cms*Ers*PIov4*iDE(i,k)*(NR(i,k)*NN(i,k))*iGS31*iGR31* & tmp2*(GS36*GR31*tmp6+2.*GS35*GR32*iLAMs2*iLAMs2*iLAMr+GS34* & GR33*iLAMs2*iLAMs*iLAMr2) else !hardcoded for dms=2: - QCLsr= dt*cms*iDE(i,k)*PI*0.25*ERS*tmp2*NN(i,k)*NR(i,k)*iGS31* & + QCLsr= dt*cms*iDE(i,k)*PI*0.25*ERS*tmp2*NN(i,k)*NR(i,k)*iGS31* & iGR31*(GR33*GS33*iLAMr**2.*iLAMs**2. + 2.*GR32*GS34*iLAMr* & iLAMs**3. +GR31*GS35*iLAMs**4.) endif @@ -2666,6 +2381,7 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, endif endif if (.not. grpl_ON) Dsrg=0. + else QCLrs= 0.; QCLsr= 0.; NCLrs= 0.; NCLsr= 0. endif @@ -2679,13 +2395,16 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, !------------! ! GRAUPEL: ! !------------! - IF (QG(i,k)>epsQ) THEN + IF (QG(i,k)>epsQ .and. NG(i,k)>epsN) THEN !Conversion to hail: (D_sll given by S-L limit) if ( (QCLcg+QCLrg)>0. .and. hail_ON ) then ! D_sll = 0.01*(exp(min(20.,-Tc/(1.1e4*DE(i,k)*(QC(i,k)+QR(i,k))-1.3e3*DE(i,k)*QI(i,k)+1.)))-1.) ! D_sll = 2.0*D_sll !correction factor [error Ziegler (1985), as per Young (1993)] - D_sll = 2.*0.01*(exp(min(20.,-Tc/(1.1e4*DE(i,k)*(QC(i,k)+QR(i,k)) + 1.)))-1.) +! D_sll = 2.*0.01*(exp(min(20.,-Tc/(1.1e4*DE(i,k)*(QC(i,k)+QR(i,k)) + 1.)))-1.) + tmp1 = 1.1e4*DE(i,k)*(QC(i,k)+QR(i,k)) + 1. + tmp1 = max(1.,tmp1) !to prevent div-by-zero + D_sll = 2.*0.01*(exp(min(20.,-Tc/tmp1))-1.) D_sll = min(1., max(0.0001,D_sll)) !smallest D_sll=0.1mm; largest=1m tmp1 = iLAMg !hold value tmp2 = No_g !hold value @@ -2714,7 +2433,8 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, endif !3-component freezing (collisions with rain): - if (QR(i,k)>epsQ) then +! if (QR(i,k)>epsQ) then + if (QR(i,k)>epsQ .and. Tc<-5.) then tmp1 = vg0-vr0 tmp2 = sqrt(tmp1*tmp1 + 0.04*vg0*vr0) tmp8 = iLAMg2*iLAMg ! iLAMg**3 @@ -2726,14 +2446,14 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, Kstoke = max(1.5,min(10.,Kstoke)) Erg = 0.55*log10(2.51*Kstoke) - QCLrg= dt*cmr*Erg*PIov4*iDE(i,k)*(NG(i,k)*NR(i,k))*iGR31*iGG31*tmp2* & + QCLrg= dt*cmr*Erg*PIov4*iDE(i,k)*(NG(i,k)*NR(i,k))*iGR31*iGG31*tmp2* & (GR36*GG31*iLAMr5+2.*GR35*GG32*iLAMr4*iLAMg+GR34*GG33*iLAMr3* & iLAMg2) - NCLrg= dt*PIov4*Erg*(NG(i,k)*NR(i,k))*iGR31*iGG31*tmp2*(GR33*GG31* & + NCLrg= dt*PIov4*Erg*(NG(i,k)*NR(i,k))*iGR31*iGG31*tmp2*(GR33*GG31* & iLAMr2+2.*GR32*GG32*iLAMr*iLAMg+GR31*GG33*iLAMg2) - QCLgr= dt*cmg*Erg*PIov4*iDE(i,k)*(NR(i,k)*NG(i,k))*iGG31*iGR31*tmp2* & + QCLgr= dt*cmg*Erg*PIov4*iDE(i,k)*(NR(i,k)*NG(i,k))*iGG31*iGR31*tmp2* & (GG36*GR31*tmp10+2.*GG35*GR32*tmp9*iLAMr+GG34*GR33*tmp8*iLAMr2) !(note: For explicit eqns, NCLgr= NCLrg) @@ -2784,6 +2504,58 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, ENDIF ! ( if Tc<0C Block ) + !----- Prevent mass transfer from accretion during melting: ---! + ! (only if exepcted NX (X=s,g,h) < 0 after source/sinks added) + ! The purpose is to prevent mass tranfer from cloud to X and then + ! to vapor (during "prevent overdepletion" code) if all of X + ! would otherwise be completely depleted (e.g. due to melting). + + !estimate NN after S/S: + tmp1= NN(i,k) +NsCNis -NVDvs -NCNsg -NMLsr -NCLss -NCLsr -NCLsh +NCLsrs + if (tmp1sour) then ratio= sour/sink QCLrg= ratio*QCLrg; QCLri= ratio*QCLri; NCLri= ratio*NCLri - QCLrs= ratio*QCLrs; NCLrs= ratio*NCLrs; QCLrg= ratio*QCLrg + QCLrs= ratio*QCLrs; NCLrs= ratio*NCLrs NCLrg= ratio*NCLrg; QCLrh= ratio*QCLrh; NCLrh= ratio*NCLrh QFZrh= ratio*QFZrh; NrFZrh=ratio*NrFZrh; NhFZrh=ratio*NhFZrh if (ratio==0.) then @@ -2886,7 +2658,7 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, endif ! (7) Hail: - source= QH(i,k)+dim(QVDvh,0.)+QCLch+QCLrh+Dirh*(QCLri+QCLir)+QCLih+QCLsh+ & + source= QH(i,k)+dim(QVDvh,0.)+QCLch+QCLrh+Dirh*(QCLri+QCLir)+QCLih+QCLsh+ & Dsrh*(QCLrs+QCLsr)+QCNgh+Dgrh*(QCLrg+QCLgr)+QFZrh sink = dim(-QVDvh,0.)+QMLhr sour = max(source,0.) @@ -2930,7 +2702,7 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, !========================================================================! !Diagnostic S/S terms: (to facilitate output of 3D variables for diagnostics) - !SS01(i,k)= QVDvs*idt (e.g., for depositional growth rate of snow, kg kg-1 s-1) + !e.g. SS(i,k,1)= QVDvs*idt (for depositional growth rate of snow, kg kg-1 s-1) ! Q-Source/Sink Terms: Q(i,k) = Q(i,k) -QNUvi -QVDvi -QVDvs -QVDvg -QVDvh @@ -2986,7 +2758,8 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, !ice: if (QI(i,k)>epsQ .and. NY(i,k)epsQ .and. NH(i,k)>epsN) then !transfer small hail to graupel: - Dh = Dm_x(DE(i,k),QH(i,k),1./NH(i,k),icmh,thrd) + tmp1 = 1./NH(i,k) + Dh = Dm_x(DE(i,k),QH(i,k),tmp1,icmh,thrd) if (Dh < Dh_min) then QG(i,k) = QG(i,k) + QH(i,k) NG(i,k) = NG(i,k) + NH(i,k) @@ -3041,6 +2815,14 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, Q(i,k)= max(Q(i,k),0.) NY(i,k)= min(NY(i,k), Ni_max) +!----- + if ( T(i,k)<173. .or. T(i,k)>323.) then !** DEBUG ** + print*, '** STOPPING IN MICROPHYSICS: (Part 2, end) **' !** DEBUG ** + print*, '** i,k,T [K]: ',i,k,T(i,k) !** DEBUG ** + stop !** DEBUG ** + endif !** DEBUG ** +!===== + ENDIF !if (activePoint) ENDDO ENDDO @@ -3049,6 +2831,8 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, ! End of ice phase microphysics (Part 2) ! !----------------------------------------------------------------------------------! + if (DEBUG_ON) call check_values(Q,T,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,epsQ,epsN,.true.,DEBUG_abort,450) + !----------------------------------------------------------------------------------! ! PART 3: Warm Microphysics Processes ! ! ! @@ -3072,7 +2856,8 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, rainPresent= (QR_in(i,k)>epsQ .and. NR_in(i,k)>epsN) if (QC_in(i,k)>epsQ .and. NC_in(i,k)>epsN) then - iLAMc = iLAMDA_x(DE(i,k),QC_in(i,k),1./NC_in(i,k),icexc9,thrd) + iNC = 1./NC_in(i,k) + iLAMc = iLAMDA_x(DE(i,k),QC_in(i,k),iNC,icexc9,thrd) iLAMc3= iLAMc*iLAMc*iLAMc iLAMc6= iLAMc3*iLAMc3 Dc = iLAMc*(GC2*iGC1)**thrd @@ -3082,17 +2867,21 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, endif if (rainPresent) then - Dr = Dm_x(DE(i,k),QR_in(i,k),1./NR_in(i,k),icmr,thrd) - !Drop-size limiter [prevents initially large drops from melted hail] + iNR = 1./NR_in(i,k) + Dr = Dm_x(DE(i,k),QR_in(i,k),iNR,icmr,thrd) + + !Drop-size limiter [prevents initially large drops] if (Dr>3.e-3) then - tmp1 = (Dr-3.e-3); tmp2= (Dr/DrMAX); tmp3= tmp2*tmp2*tmp2 + tmp1 = (Dr-3.e-3) + tmp2 = (Dr/DrMAX) + tmp3 = tmp2*tmp2*tmp2 NR_in(i,k)= NR_in(i,k)*max((1.+2.e4*tmp1*tmp1),tmp3) - tmp1 = DE(i,k)*QR_in(i,k)*icmr - Dr = (tmp1/NR_in(i,k))**thrd + iNR = 1./NR_in(i,k) + Dr = Dm_x(DE(i,k),QR_in(i,k),iNR,icmr,thrd) endif - iLAMr = iLAMDA_x(DE(i,k),QR(i,k),1./NR(i,k),icexr9,thrd) - iLAMr3= iLAMr*iLAMr*iLAMr - iLAMr6= iLAMr3*iLAMr3 + iLAMr = iLAMDA_x(DE(i,k),QR_in(i,k),iNR,icexr9,thrd) + iLAMr3 = iLAMr*iLAMr*iLAMr + iLAMr6 = iLAMr3*iLAMr3 endif ! Autoconversion: @@ -3182,7 +2971,8 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, NR(i,k)= max(0., NR(i,k)+( CCAUTR-CRSCOR)*dt ) if (QR(i,k)>epsQ .and. NR(i,k)>epsN) then - Dr = Dm_x(DE(i,k),QR(i,k),1./NR(i,k),icmr,thrd) + iNR = 1./NR(i,k) + Dr = Dm_x(DE(i,k),QR(i,k),iNR,icmr,thrd) if (Dr>3.e-3) then tmp1= (Dr-3.e-3); tmp2= tmp1*tmp1 tmp3= (Dr/DrMAX); tmp4= tmp3*tmp3*tmp3 @@ -3200,8 +2990,12 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, ! Part 3b - Condensation/Evaporation: QSW(i,k) = qsat(T(i,k),pres(i,k),0) !Flatau formulation - ssat = Q(i,k)/QSW(i,k)-1. !supersaturation ratio - X = Q(i,k)-QSW(i,k) !saturation exesss (deficit) + if (QSW(i,k)>1.e-20) then + ssat = Q(i,k)/QSW(i,k)-1. !supersaturation ratio + else + ssat = 0. + endif + X = Q(i,k)-QSW(i,k) !saturation excess (deficit) !adjustment for latent heating during cond/evap ! X = X/(1.+ck5*QSW(i,k)/(T(i,k)-35.86)**2) !orig (KY97) X = X / ( 1.+ ((3.1484e6-2370.*T(i,k))**2 * QSW(i,k))/( (1005.*(1.+ & !morr2mom @@ -3210,29 +3004,35 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, QC(i,k) = QC(i,k) + X Q(i,k) = Q(i,k) - X T(i,k) = T(i,k) + LCP*X - if (ssat>0. .and. WZ(i,k)>0.001) then - ! Nucleation of cloud droplets: - ! note: WZ threshold of 1 mm/s is to overflow problem in NccnFNC, which - ! uses a polynomial approximation that is invalid for tiny WZ. - !NC(i,k)= max(NC(i,k),NccnFNC(WZ(i,k),T(i,k),HPS(i)*sigma(i,k),CCNtype)) - NC(i,k) = max(NC(i,k), NccnFNC(WZ(i,k),T(i,k),pres(i,k),CCNtype)) + + if (X>0.) then + !nucleation of cloud droplets: + if (WZ(i,k)>0.001) then + !condensation and non-negligible upward motion: + !note: WZ threshold of 1 mm/s is to overflow problem in NccnFNC, which + ! uses a polynomial approximation that is invalid for tiny WZ. + NC(i,k) = max(NC(i,k), NccnFNC(WZ(i,k),T(i,k),pres(i,k),CCNtype)) + else + !condensation and negible or downward vertical motion: + NC(i,k) = max(NC(i,k), N_c_SM) + endif else - NC(i,k) = max(0., NC(i,k) + X*NC(i,k)/max(QC(i,k),epsQ) ) !(dNc/dt)|evap + if (QC(i,k)>epsQ) then + !partial evaporation of cloud droplets: + NC(i,k) = max(0., NC(i,k) + X*NC(i,k)/max(QC(i,k),epsQ) ) !(dNc/dt)|evap + else + NC(i,k) = 0. + endif endif - !ensure consistency for cloud: - if (QC(i,k)>epsQ .and. NC(i,k)epsQ .and. NC(i,k)epsQ) then - - ssat = Q(i,k)/QSW(i,k)-1. + if (Q(i,k)epsQ .and. NR(i,k)>epsN) then + ssat = Q(i,k)/QSW(i,k)-1. Tc = T(i,k)-TRPL Cdiff = max(1.62e-5, (2.2157e-5 + 0.0155e-5*Tc)) *1.e5/pres(i,k) - !Cdiff = max(1.62e-5, (2.2157e-5 + 0.0155e-5*Tc)) *1.e5/pres(i,k) MUdyn = max(1.51e-5, (1.7153e-5 + 0.0050e-5*Tc)) Ka = max(2.07e-2, (2.3971e-2 + 0.0078e-2*Tc)) MUkin = MUdyn*iDE(i,k) @@ -3246,7 +3046,8 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, DE(i,k) = pres(i,k)/(RGASD*T(i,k)) !recompute air density (with updated T) iDE(i,k) = 1./DE(i,k) gam = sqrt(DEo*iDE(i,k)) - iLAMr = iLAMDA_x(DE(i,k),QR(i,k),1./NR(i,k),icexr9,thrd) + tmp1 = 1./NR(i,k) + iLAMr = iLAMDA_x(DE(i,k),QR(i,k),tmp1,icexr9,thrd) LAMr = 1./iLAMr !note: The following coding of 'No_r=...' prevents overflow: !No_r = NR(i,k)*LAMr**(1.+alpha_r))*iGR31 @@ -3267,8 +3068,7 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, QR(i,k) = 0. NR(i,k) = 0. endif - - endif + endif !homogeneous freezing of cloud: Tc = T(i,k) - TRPL @@ -3307,7 +3107,8 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, endif if (QI(i,k)>epsQ .and. NY(i,k)epsQ .and. NN(i,k)>epsN) then - !Impose No_s max for snow: (assumes alpha_s=0.) - iLAMs = max( iLAMmin2, iLAMDA_x(DE(i,k),QN(i,k), 1./NN(i,k),iGS20,idms) ) + tmp1 = 1./NN(i,k) + iLAMs = max( iLAMmin2, iLAMDA_x(DE(i,k),QN(i,k),tmp1,iGS20,idms) ) tmp1 = min(NN(i,k)/iLAMs,No_s_max) !min. No_s NN(i,k)= tmp1**(dms/(1.+dms))*(iGS20*DE(i,k)*QN(i,k))**(1./(1.+dms)) !impose Nos_max - !Impose LAMDAs_min (by increasing LAMDAs if it is below LAMDAs_min2 [2xLAMDAs_min]) - iLAMs = max( iLAMmin2, iLAMDA_x(DE(i,k),QN(i,k),1./NN(i,k),iGS20,idms) ) + tmp1 = 1./NN(i,k) + iLAMs = max( iLAMmin2, iLAMDA_x(DE(i,k),QN(i,k),tmp1,iGS20,idms) ) tmp2 = 1./iLAMs !LAMs before adjustment !adjust value of lamdas_min to be applied: ! This adjusts for multiple corrections (each time step). The factor 0.6 was obtained by @@ -3387,18 +3196,19 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, tmp3 = max(tmp3, lamdas_min) !final correction NN(i,k)= NN(i,k)*(tmp3*iLAMs)**dms !re-compute NN after LAMs adjustment endif - - enddo !i-loop - enddo !k-loop + enddo !i-loop + enddo !k-loop !=== !Compute melted (liquid-equivalent) volume fluxes [m3 (liquid) m-2 (sfc area) s-1]: ! (note: For other precipitation schemes in RPN-CMC physics, this is computed in 'vkuocon6.ftn') - RT_rn1 = fluxM_r *idew - RT_sn1 = fluxM_i *idew - RT_sn2 = fluxM_s *idew - RT_sn3 = fluxM_g *idew - RT_pe1 = fluxM_h *idew + RT_rn1 = fluxM_r *idew + RT_sn1 = fluxM_i *idew + RT_sn2 = fluxM_s *idew + RT_sn3 = fluxM_g *idew + RT_pe1 = fluxM_h *idew + + if (DEBUG_ON) call check_values(Q,T,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,epsQ,epsN,.false.,DEBUG_abort,700) !---- !Compute sum of solid (unmelted) volume fluxes [m3 (bulk hydrometeor) m-2 (sfc area) s-1]: @@ -3422,10 +3232,11 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, ! integral and Fv_x=Fm_x/dex ! Optimized for alpha_s = 0. if (QN(i,nk)>epsQ .and. NN(i,nk)>epsN .and. fluxM_s(i)>0.) then - tmp1= 1./iLAMDA_x(DE(i,nk),QN(i,nk),1./NN(i,nk),iGS20,idms) !LAMDA_s - fluxV_s= fluxM_s(i)*rfact_FvFm*tmp1**(dms-3.) + tmp2 = 1./NN(i,nk) + tmp1 = 1./iLAMDA_x(DE(i,nk),QN(i,nk),tmp2,iGS20,idms) !LAMDA_s + fluxV_s = fluxM_s(i)*rfact_FvFm*tmp1**(dms-3.) else - fluxV_s=0. + fluxV_s = 0. endif !total solid unmelted volume flux, before accounting for partial melting: @@ -3508,8 +3319,9 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, !large hail: if (QH(i,kbot)>epsQ) then - N_h= NH(i,kbot) - Dm_h(i,kbot)= Dm_x(DE(i,kbot),QH(i,kbot),1./N_h,icmh,thrd) + N_h = NH(i,kbot) + tmp1 = 1./N_h + Dm_h(i,kbot)= Dm_x(DE(i,kbot),QH(i,kbot),tmp1,icmh,thrd) if (DM_h(i,kbot)>Dh_large) RT_peL(i)= RT_pe2(i) !note: large hail (RT_peL) is a subset of the total hail (RT_pe2) endif @@ -3527,13 +3339,44 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, ! End of sedimentation calculations (Part 4) ! !-----------------------------------------------------------------------------------! + if (DEBUG_ON) call check_values(Q,T,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,epsQ,epsN,.false.,DEBUG_abort,800) !===================================================================================! ! End of microphysics scheme ! !===================================================================================! !-----------------------------------------------------------------------------------! - ! Calculation of diagnostic output variables: ! + ! Calculation of diagnostic variables: ! + + !Compute effective radii for cloud and ice (to be passed to radiation scheme): + ! - based of definition, r_eff = M_r(3)/M_r(2) = 0.5*M_D(3)/M_D(2), + ! where the pth moment w.r.t. diameter, M_D(p), is given by MY2005a, eqn (2) + do k = kbot,ktop,kdir + do i = 1,ni + + !cloud: + if (QC(i,k)>epsQ .and. NC(i,k)>epsN) then + !hardcoded for alpha_c = 1. and mu_c = 3. + iNC = 1./NC(i,k) + iLAMc = iLAMDA_x(DE(i,k),QC(i,k),iNC,icexc9,thrd) + ! reff_c(i,k) = 0.664639*iLAMc + else + ! reff_c(i,k) = 0. + endif + + !ice: + if (QI(i,k)>epsQ .and. NY(i,k)>epsN) then + !hardcoded for alpha_i = 0. and mu_i = 1. + iNY = 1./NY(i,k) + iLAMi = max( iLAMmin2, iLAMDA_x(DE(i,k),QI(i,k),iNY,icexi9,thrd) ) + ! reff_i(i,k) = 1.5*iLAMi + else + ! reff_i(i,k) = 0. + endif + + enddo + enddo + IF (calcDiag) THEN @@ -3590,12 +3433,30 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, !Mean-mass diameters: (units of [m]) Dm_c(i,k)= 0.; Dm_r(i,k)= 0.; Dm_i(i,k)= 0. Dm_s(i,k)= 0.; Dm_g(i,k)= 0.; Dm_h(i,k)= 0. - if(QC(i,k)>epsQ.and.N_c>epsN) Dm_c(i,k)=Dm_x(DE(i,k),QC(i,k),1./N_c,icmr,thrd) - if(QR(i,k)>epsQ.and.N_r>epsN) Dm_r(i,k)=Dm_x(DE(i,k),QR(i,k),1./N_r,icmr,thrd) - if(QI(i,k)>epsQ.and.N_i>epsN) Dm_i(i,k)=Dm_x(DE(i,k),QI(i,k),1./N_i,icmi,thrd) - if(QN(i,k)>epsQ.and.N_s>epsN) Dm_s(i,k)=Dm_x(DE(i,k),QN(i,k),1./N_s,icms,idms) - if(QG(i,k)>epsQ.and.N_g>epsN) Dm_g(i,k)=Dm_x(DE(i,k),QG(i,k),1./N_g,icmg,thrd) - if(QH(i,k)>epsQ.and.N_h>epsN) Dm_h(i,k)=Dm_x(DE(i,k),QH(i,k),1./N_h,icmh,thrd) + if (QC(i,k)>epsQ.and.N_c>epsN) then + tmp1 = 1./N_c + Dm_c(i,k) = Dm_x(DE(i,k),QC(i,k),tmp1,icmr,thrd) + endif + if (QR(i,k)>epsQ.and.N_r>epsN) then + tmp1 = 1./N_r + Dm_r(i,k) = Dm_x(DE(i,k),QR(i,k),tmp1,icmr,thrd) + endif + if (QI(i,k)>epsQ.and.N_i>epsN) then + tmp1 = 1./N_i + Dm_i(i,k) = Dm_x(DE(i,k),QI(i,k),tmp1,icmi,thrd) + endif + if (QN(i,k)>epsQ.and.N_s>epsN) then + tmp1 = 1./N_s + Dm_s(i,k) = Dm_x(DE(i,k),QN(i,k),tmp1,icms,idms) + endif + if (QG(i,k)>epsQ.and.N_g>epsN) then + tmp1 = 1./N_g + Dm_g(i,k) = Dm_x(DE(i,k),QG(i,k),tmp1,icmg,thrd) + endif + if (QH(i,k)>epsQ.and.N_h>epsN) then + tmp1 = 1./N_h + Dm_h(i,k) = Dm_x(DE(i,k),QH(i,k),tmp1,icmh,thrd) + endif enddo !i-loop enddo !k-loop @@ -3619,9 +3480,11 @@ SUBROUTINE mp_milbrandt2mom_main(WZ,T,Q,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,PS, ! QG = max(QG, 0.); NG = max(NG, 0.) ! QH = max(QH, 0.); NH = max(NH, 0.) - !-----------------------------------------------------------------------------------! -END SUBROUTINE mp_milbrandt2mom_main - !___________________________________________________________________________________! + if (DEBUG_ON) call check_values(Q,T,QC,QR,QI,QN,QG,QH,NC,NR,NY,NN,NG,NH,epsQ,epsN,.false.,DEBUG_abort,900) + + END SUBROUTINE mp_milbrandt2mom_main + +!___________________________________________________________________________________! real function des_OF_Ds(Ds_local,desMax_local,eds_local,fds_local) !Computes density of equivalent-volume snow particle based on (pi/6*des)*Ds^3 = cms*Ds^dms @@ -3663,14 +3526,14 @@ end function Nos_Thompson !===================================================================================================! -END MODULE my_dmom_mod +END MODULE my2_mod !________________________________________________________________________________________! MODULE module_mp_milbrandt2mom use module_wrf_error - use my_dmom_mod + use my2_mod, ONLY: mp_milbrandt2mom_main implicit none @@ -3694,7 +3557,7 @@ END SUBROUTINE milbrandt2mom_init SUBROUTINE mp_milbrandt2mom_driver(qv, qc, qr, qi, qs, qg, qh, nc, nr, ni, ns, ng, & - nh, th, pii, p, w, dz, dt_in, itimestep, & + nh, th, pii, p, w, dz, dt_in, itimestep, p8w, & RAINNC, RAINNCV, SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & HAILNC, HAILNCV, SR, Zet, & ids,ide, jds,jde, kds,kde, & ! domain dims @@ -3711,6 +3574,7 @@ SUBROUTINE mp_milbrandt2mom_driver(qv, qc, qr, qi, qs, qg, qh, nc, nr, ni, ns, n qv,qc,qr,qi,qs,qg,qh,nc,nr,ni,ns,ng,nh,th,Zet real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: & pii,p,w,dz + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p8w real, dimension(ims:ime, jms:jme), intent(inout):: & RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,HAILNC,HAILNCV, & SR @@ -3738,6 +3602,8 @@ SUBROUTINE mp_milbrandt2mom_driver(qv, qc, qr, qi, qs, qg, qh, nc, nr, ni, ns, n real, parameter :: ms2mmh = 3.6e+6 !conversion factor for precipitation rates logical, parameter :: nk_BOTTOM = .false. !.F. for k=1 at bottom level (WRF) + real, parameter :: statfreq = 300. !frequency (seconds) to output block stats + !+---+ i2d_max = ite-its+1 k2d_max = kte-kts+1 @@ -3762,17 +3628,33 @@ SUBROUTINE mp_milbrandt2mom_driver(qv, qc, qr, qi, qs, qg, qh, nc, nr, ni, ns, n HAILNCV(its:ite,jts:jte) = 0. SR(its:ite,jts:jte) = 0. + !--run-time stats: +! if (mod(itimestep*dt,statfreq)==0.) then +! t3d = th*pii +! print*, 'Bloc Stats -- BEFORE micro call (my-2.25.1_b11)' +! write(6,'(a8,7e15.5)') 'Max qx: ',maxval(qc(its:ite,kts:kte,jts:jte)),maxval(qr(its:ite,kts:kte,jts:jte)),maxval(qi(its:ite,kts:kte,jts:jte)), & +! maxval(qs(its:ite,kts:kte,jts:jte)),maxval(qg(its:ite,kts:kte,jts:jte)),maxval(qh(its:ite,kts:kte,jts:jte)) +! write(6,'(a8,6e15.5)') 'Max Nx: ',maxval(nc(its:ite,kts:kte,jts:jte)),maxval(nr(its:ite,kts:kte,jts:jte)),maxval(ni(its:ite,kts:kte,jts:jte)), & +! maxval(ns(its:ite,kts:kte,jts:jte)),maxval(ng(its:ite,kts:kte,jts:jte)),maxval(nh(its:ite,kts:kte,jts:jte)) +! write(6,'(a8,7e15.5)') 'Min qx: ',minval(qc(its:ite,kts:kte,jts:jte)),minval(qr(its:ite,kts:kte,jts:jte)),minval(qi(its:ite,kts:kte,jts:jte)), & +! minval(qs(its:ite,kts:kte,jts:jte)),minval(qg(its:ite,kts:kte,jts:jte)),minval(qh(its:ite,kts:kte,jts:jte)) +! write(6,'(a8,6e15.5)') 'Min Nx: ',minval(nc(its:ite,kts:kte,jts:jte)),minval(nr(its:ite,kts:kte,jts:jte)),minval(ni(its:ite,kts:kte,jts:jte)), & +! minval(ns(its:ite,kts:kte,jts:jte)),minval(ng(its:ite,kts:kte,jts:jte)),minval(nh(its:ite,kts:kte,jts:jte)) +! write(6,'(a8,6e15.5)') 'W,T,qv: ',minval( w(its:ite,kts:kte,jts:jte)),maxval( w(its:ite,kts:kte,jts:jte)),minval(t3d(its:ite,kts:kte,jts:jte)),& +! maxval(t3d(its:ite,kts:kte,jts:jte)),minval(qv(its:ite,kts:kte,jts:jte)),maxval(qv(its:ite,kts:kte,jts:jte)) +! endif + do j = jts, jte t2d(:,:) = th(its:ite,kts:kte,j)*pii(its:ite,kts:kte,j) p2d(:,:) = p(its:ite,kts:kte,j) - p_sfc(:) = p2d(:,k2d_max) + ! p_sfc(:) = p2d(:,k2d_max) + p_sfc(:) = p8w(its:ite,kms, j) do i = its, ite i2d = i-its+1 sigma2d(i2d,:) = p2d(i2d,:)/p_sfc(i2d) enddo - call mp_milbrandt2mom_main(w(its:ite,kts:kte,j),t2d,qv(its:ite,kts:kte,j), & qc(its:ite,kts:kte,j),qr(its:ite,kts:kte,j),qi(its:ite,kts:kte,j), & qs(its:ite,kts:kte,j),qg(its:ite,kts:kte,j),qh(its:ite,kts:kte,j), & @@ -3792,9 +3674,32 @@ SUBROUTINE mp_milbrandt2mom_driver(qv, qc, qr, qi, qs, qg, qh, nc, nr, ni, ns, n HAILNCV(its:ite,j) = (rt_pe1(:) + rt_pe2(:))*ms2mmstp GRPLNCV(its:ite,j) = rt_sn3(:)*ms2mmstp + RAINNC(its:ite,j) = RAINNC(its:ite,j) + RAINNCV(its:ite,j) + SNOWNC(its:ite,j) = SNOWNC(its:ite,j) + SNOWNCV(its:ite,j) + HAILNC(its:ite,j) = HAILNC(its:ite,j) + HAILNCV(its:ite,j) + GRPLNC(its:ite,j) = GRPLNC(its:ite,j) + GRPLNCV(its:ite,j) + SR(its:ite,j) = (SNOWNCV(its:ite,j)+HAILNCV(its:ite,j)+GRPLNCV(its:ite,j))/(RAINNCV(its:ite,j)+1.e-12) + enddo !j_loop + !--run-time stats: +! if (mod(itimestep*dt,statfreq)==0.) then +! t3d = th*pii +! print*, 'Bloc Stats -- AFTER micro call; my_2.25.1-b11)' +! write(6,'(a8,7e15.5)') 'Max qx: ',maxval(qc(its:ite,kts:kte,jts:jte)),maxval(qr(its:ite,kts:kte,jts:jte)),maxval(qi(its:ite,kts:kte,jts:jte)), & +! maxval(qs(its:ite,kts:kte,jts:jte)),maxval(qg(its:ite,kts:kte,jts:jte)),maxval(qh(its:ite,kts:kte,jts:jte)) +! write(6,'(a8,6e15.5)') 'Max Nx: ',maxval(nc(its:ite,kts:kte,jts:jte)),maxval(nr(its:ite,kts:kte,jts:jte)),maxval(ni(its:ite,kts:kte,jts:jte)), & +! maxval(ns(its:ite,kts:kte,jts:jte)),maxval(ng(its:ite,kts:kte,jts:jte)),maxval(nh(its:ite,kts:kte,jts:jte)) +! write(6,'(a8,7e15.5)') 'Min qx: ',minval(qc(its:ite,kts:kte,jts:jte)),minval(qr(its:ite,kts:kte,jts:jte)),minval(qi(its:ite,kts:kte,jts:jte)), & +! minval(qs(its:ite,kts:kte,jts:jte)),minval(qg(its:ite,kts:kte,jts:jte)),minval(qh(its:ite,kts:kte,jts:jte)) +! write(6,'(a8,6e15.5)') 'Min Nx: ',minval(nc(its:ite,kts:kte,jts:jte)),minval(nr(its:ite,kts:kte,jts:jte)),minval(ni(its:ite,kts:kte,jts:jte)), & +! minval(ns(its:ite,kts:kte,jts:jte)),minval(ng(its:ite,kts:kte,jts:jte)),minval(nh(its:ite,kts:kte,jts:jte)) +! write(6,'(a8,6e15.5)') 'W,T,qv: ',minval( w(its:ite,kts:kte,jts:jte)),maxval( w(its:ite,kts:kte,jts:jte)),minval(t3d(its:ite,kts:kte,jts:jte)),& +! maxval(t3d(its:ite,kts:kte,jts:jte)),minval(qv(its:ite,kts:kte,jts:jte)),maxval(qv(its:ite,kts:kte,jts:jte)) +! write(6,'(a8,2e15.5)') 'Zet : ',maxval(Zet(its:ite,kts:kte,jts:jte)) +! endif + END SUBROUTINE mp_milbrandt2mom_driver !+---+-----------------------------------------------------------------+ diff --git a/wrfv2_fire/phys/module_mp_morr_two_moment.F b/wrfv2_fire/phys/module_mp_morr_two_moment.F index 147126e9..dd56351a 100644 --- a/wrfv2_fire/phys/module_mp_morr_two_moment.F +++ b/wrfv2_fire/phys/module_mp_morr_two_moment.F @@ -67,6 +67,11 @@ ! collected drops can smaller than number of shed drops ! 6) change of specific heat of liquid water from 4218 to 4187 J/kg/K +! CHANGES FOR WRFV3.6.1 +! 1) minor bug fix to melting of snow and graupel, an extra factor of air density (RHO) was removed +! from the calculation of PSMLT and PGMLT +! 2) redundant initialization of PSMLT (non answer-changing) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING @@ -233,7 +238,7 @@ MODULE MODULE_MP_MORR_TWO_MOMENT CONTAINS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -SUBROUTINE MORR_TWO_MOMENT_INIT +SUBROUTINE MORR_TWO_MOMENT_INIT(hail_opt) ! RAS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! THIS SUBROUTINE INITIALIZES ALL PHYSICAL CONSTANTS AMND PARAMETERS ! NEEDED BY THE MICROPHYSICS SCHEME. @@ -242,6 +247,8 @@ SUBROUTINE MORR_TWO_MOMENT_INIT IMPLICIT NONE + INTEGER, INTENT(IN):: hail_opt ! RAS + integer n,i !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -325,7 +332,13 @@ SUBROUTINE MORR_TWO_MOMENT_INIT ! IHAIL = 1, DENSE PRECIPITATING ICE IS HAIL ! NOTE ---> RECOMMEND IHAIL = 1 FOR CONTINENTAL DEEP CONVECTION - IHAIL = 0 + !IHAIL = 0 !changed to namelist option (hail_opt) by RAS + ! Check if namelist option is feasible, otherwise default to graupel - RAS + IF (hail_opt .eq. 1) THEN + IHAIL = 1 + ELSE + IHAIL = 0 + ENDIF !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -546,6 +559,7 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP, & ,IMS,IME, JMS,JME, KMS,KME & ! memory dims ,ITS,ITE, JTS,JTE, KTS,KTE & ! tile dims ) !jdf ,C2PREC3D,CSED3D,ISED3D,SSED3D,GSED3D,RSED3D & ! HM ADD, WRF-CHEM + ,rainprod, evapprod & ,QLSINK,PRECR,PRECI,PRECS,PRECG & ! HM ADD, WRF-CHEM ) @@ -589,6 +603,10 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP, & ! QLSINK - TENDENCY OF CLOUD WATER TO RAIN, SNOW, GRAUPEL (KG/KG/S) ! CSED,ISED,SSED,GSED,RSED - SEDIMENTATION FLUXES (KG/M^2/S) FOR CLOUD WATER, ICE, SNOW, GRAUPEL, RAIN ! PRECI,PRECS,PRECG,PRECR - SEDIMENTATION FLUXES (KG/M^2/S) FOR ICE, SNOW, GRAUPEL, RAIN + +! rainprod - total tendency of conversion of cloud water/ice and graupel to rain (kg kg-1 s-1) +! evapprod - tendency of evaporation of rain (kg kg-1 s-1) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! reflectivity currently not included!!!! @@ -623,6 +641,7 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP, & REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop !jdf REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT):: CSED3D, & REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: QLSINK, & + rainprod, evapprod, & PRECI,PRECS,PRECG,PRECR ! HM, WRF-CHEM !, effcs, effis @@ -676,6 +695,7 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP, & ! wrf-chem REAL, DIMENSION(kts:kte) :: nc1d, nc_tend1d,C2PREC,CSED,ISED,SSED,GSED,RSED + REAL, DIMENSION(kts:kte) :: rainprod1d, evapprod1d ! HM add reflectivity REAL, DIMENSION(kts:kte) :: dBZ @@ -790,6 +810,9 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP, & ! ADD SEDIMENTATION TENDENCIES QGSTEN,QRSTEN,QISTEN,QNISTEN,QCSTEN, & nc1d, nc_tend1d, iinum, C2PREC,CSED,ISED,SSED,GSED,RSED & !wrf-chem +#if (WRF_CHEM == 1) + ,rainprod1d, evapprod1d & !wrf-chem +#endif ) ! @@ -844,6 +867,11 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP, & ! EFFIS(I,K,J) = MIN(EFFI(I,K,J),130.) ! EFFIS(I,K,J) = MAX(EFFIS(I,K,J),13.) +#if ( WRF_CHEM == 1) + IF ( PRESENT( rainprod ) ) rainprod(i,k,j) = rainprod1d(k) + IF ( PRESENT( evapprod ) ) evapprod(i,k,j) = evapprod1d(k) +#endif + end do ! hm modified so that m2005 precip variables correctly match wrf precip variables @@ -886,6 +914,9 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN, & QGSTEN,QRSTEN,QISTEN,QNISTEN,QCSTEN, & nc3d,nc3dten,iinum, & ! wrf-chem c2prec,CSED,ISED,SSED,GSED,RSED & ! hm added, wrf-chem +#if (WRF_CHEM == 1) + ,rainprod, evapprod & +#endif ) !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC @@ -1197,7 +1228,11 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN, & INTEGER IDROP ! FOR WRF-CHEM - REAL, DIMENSION(KTS:KTE)::C2PREC,CSED,ISED,SSED,GSED,RSED + REAL, DIMENSION(KTS:KTE)::C2PREC,CSED,ISED,SSED,GSED,RSED +#if (WRF_CHEM == 1) + REAL, DIMENSION(KTS:KTE), INTENT(INOUT) :: rainprod, evapprod +#endif + REAL, DIMENSION(KTS:KTE) :: tqimelt ! melting of cloud ice (tendency) ! comment lines for wrf-chem since these are intent(in) in that case ! REAL, DIMENSION(KTS:KTE) :: NC3DTEN ! CLOUD DROPLET NUMBER CONCENTRATION (1/KG/S) @@ -1223,6 +1258,14 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN, & GSED(K)=0. RSED(K)=0. +#if (WRF_CHEM == 1) + rainprod(K) = 0. + evapprod(K) = 0. + tqimelt(K) = 0. + PRC(K) = 0. + PRA(K) = 0. +#endif + ! LATENT HEAT OF VAPORATION XXLV(K) = 3.1484E6-2370.*T3D(K) @@ -1575,7 +1618,6 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN, & PRA(K) = 0. NPRA(K) = 0. NRAGG(K) = 0. - PSMLT(K) = 0. NSMLTS(K) = 0. NSMLTR(K) = 0. EVPMS(K) = 0. @@ -1784,8 +1826,14 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN, & ! DUM = -CPW/XLF(K)*T3D(K)*PRACS(K) DUM = -CPW/XLF(K)*(T3D(K)-273.15)*PRACS(K) +! hm fix 1/20/15 +! PSMLT(K)=2.*PI*N0S(K)*KAP(K)*(273.15-T3D(K))/ & +! XLF(K)*RHO(K)*(F1S/(LAMS(K)*LAMS(K))+ & +! F2S*(ASN(K)*RHO(K)/MU(K))**0.5* & +! SC(K)**(1./3.)*CONS10/ & +! (LAMS(K)**CONS35))+DUM PSMLT(K)=2.*PI*N0S(K)*KAP(K)*(273.15-T3D(K))/ & - XLF(K)*RHO(K)*(F1S/(LAMS(K)*LAMS(K))+ & + XLF(K)*(F1S/(LAMS(K)*LAMS(K))+ & F2S*(ASN(K)*RHO(K)/MU(K))**0.5* & SC(K)**(1./3.)*CONS10/ & (LAMS(K)**CONS35))+DUM @@ -1818,8 +1866,14 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN, & ! DUM = -CPW/XLF(K)*T3D(K)*PRACG(K) DUM = -CPW/XLF(K)*(T3D(K)-273.15)*PRACG(K) +! hm fix 1/20/15 +! PGMLT(K)=2.*PI*N0G(K)*KAP(K)*(273.15-T3D(K))/ & +! XLF(K)*RHO(K)*(F1S/(LAMG(K)*LAMG(K))+ & +! F2S*(AGN(K)*RHO(K)/MU(K))**0.5* & +! SC(K)**(1./3.)*CONS11/ & +! (LAMG(K)**CONS36))+DUM PGMLT(K)=2.*PI*N0G(K)*KAP(K)*(273.15-T3D(K))/ & - XLF(K)*RHO(K)*(F1S/(LAMG(K)*LAMG(K))+ & + XLF(K)*(F1S/(LAMG(K)*LAMG(K))+ & F2S*(AGN(K)*RHO(K)/MU(K))**0.5* & SC(K)**(1./3.)*CONS11/ & (LAMG(K)**CONS36))+DUM @@ -1987,6 +2041,11 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN, & T3DTEN(K) = T3DTEN(K)+PCC(K)*XXLV(K)/CPM(K) QC3DTEN(K) = QC3DTEN(K)+PCC(K) +#if (WRF_CHEM == 1) + evapprod(k) = - PRE(K) - EVPMS(K) - EVPMG(K) + rainprod(k) = PRA(K) + PRC(K) + tqimelt(K) +#endif + !....................................................................... ! ACTIVATION OF CLOUD DROPLETS ! ACTIVATION OF DROPLET CURRENTLY NOT CALCULATED @@ -3226,6 +3285,13 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN, & NG3DTEN(K) = NG3DTEN(K)+NSUBG(K) NR3DTEN(K) = NR3DTEN(K)+NSUBR(K) +#if (WRF_CHEM == 1) + evapprod(k) = - PRE(K) - EPRDS(K) - EPRDG(K) + rainprod(k) = PRA(K) + PRC(K) + PSACWS(K) + PSACWG(K) + PGSACW(K) & + + PRAI(K) + PRCI(K) + PRACI(K) + PRACIS(K) + & + + PRDS(K) + PRDG(K) +#endif + END IF !!!!!! TEMPERATURE ! SWITCH LTRUE TO 1, SINCE HYDROMETEORS ARE PRESENT @@ -3705,6 +3771,9 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN, & IF (QI3D(K).GE.QSMALL.AND.T3D(K).GE.273.15) THEN QR3D(K) = QR3D(K)+QI3D(K) T3D(K) = T3D(K)-QI3D(K)*XLF(K)/CPM(K) +#if (WRF_CHEM == 1) + tqimelt(K)=QI3D(K)/DT +#endif QI3D(K) = 0. NR3D(K) = NR3D(K)+NI3D(K) NI3D(K) = 0. diff --git a/wrfv2_fire/phys/module_mp_nssl_2mom.F b/wrfv2_fire/phys/module_mp_nssl_2mom.F index 804ac45f..0c8688bb 100644 --- a/wrfv2_fire/phys/module_mp_nssl_2mom.F +++ b/wrfv2_fire/phys/module_mp_nssl_2mom.F @@ -1,6 +1,6 @@ +!WRF:MODEL_LAYER:PHYSICS -!WRF:MODEL_LAYER:PHYSICS @@ -42,12 +42,22 @@ ! alphah, alphahl : Size distribution shape parameters for graupel (h) and hail (hl) ! infall : changes sedimentation options to see effects (see below) ! +! lightning model references: +! +! Fierro, A. O., E.R. Mansell, C. Ziegler and D. R. MacGorman 2013: The +! implementation of an explicit charging and discharge lightning scheme +! within the WRF-ARW model: Benchmark simulations of a continental squall line, a +! tropical cyclone and a winter storm. Monthly Weather Review, Volume 141, 2390-2415 +! +! Mansell et al. 2005: Charge structure and lightning sensitivity in a simulated +! multicell thunderstorm. J. Geophys. Res., 110, D12101, doi:10.1029/2004JD005287 ! ! Note: Some parameters below apply to unreleased features. ! !--------------------------------------------------------------------- + MODULE module_mp_nssl_2mom IMPLICIT NONE @@ -55,11 +65,18 @@ MODULE module_mp_nssl_2mom public nssl_2mom_driver public nssl_2mom_init private gamma,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis + private gamma_dp private delbk, delabk private gammadp logical, public :: cleardiag = .false. PRIVATE + +#ifdef WRF_CHEM + integer, parameter :: wrfchem_flag = 1 +#else + integer, parameter :: wrfchem_flag = 0 +#endif integer, private :: eqtset = 1 ! Flag for use with cm1 to use alternate equation set (changes latent heating rates) double precision, parameter, public :: zscale = 1.0d0 ! 1.000e-10 @@ -80,6 +97,7 @@ MODULE module_mp_nssl_2mom integer :: iusewetgraupel = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) ! =2 turn on for graupel density less than 300. only integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + integer :: iusewetsnow = 1 ! =1 to turn on diagnosed bright band ! microphysics @@ -88,6 +106,7 @@ MODULE module_mp_nssl_2mom real, private :: rho_qh = 500., cnoh = 4.0e5 ! set in namelist!! graupel params real, private :: rho_qhl= 900., cnohl = 4.0e4 ! set in namelist!! hail params + real, private :: hdnmn = 170.0 ! minimum graupel density (for variable density graupel) real, private :: hldnmn = 500.0 ! minimum hail density (for variable density hail) real :: cnohmn = 1.e-2 ! minimum intercept for 2-moment graupel (alphah < 0.5) @@ -98,7 +117,7 @@ MODULE module_mp_nssl_2mom real , private :: qcmincwrn = 2.0e-3 ! qc threshold for autonconversion (LFO; for 10ICE use qminrncw for ircnw != 5) real , private :: cwdiap = 20.0e-6 ! threshold diameter of cloud drops (Ferrier 1994 autoconversion) real , private :: cwdisp = 0.15 ! assume droplet dispersion parameter (can be 0.3 for maritime) - real , private :: ccn = 1.5e+09 ! set in namelist!! Central plains CCN value + real , private :: ccn = 0.6e+09 ! set in namelist!! Central plains CCN value real , private :: qccn ! ccn "mixing ratio" integer, private :: iauttim = 1 ! 10-ice rain delay flag real , private :: auttim = 300. ! 10-ice rain delay time @@ -137,17 +156,21 @@ MODULE module_mp_nssl_2mom integer, private :: ipconc = 5 integer, private :: ichaff = 0 integer, private :: ilimit = 0 + + real, private :: constccw = -1. real, private :: cimn = 1.0e3, cimx = 1.0e6 real , private :: ifrzg = 1.0 ! fraction of frozen drops going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail + real , private :: ifrzs = 1.0 ! fraction of small frozen drops going to snow. 1=freeze rain to snow, 0=freeze to cloud ice integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget) integer, private :: irimtim = 0 ! future use ! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds real , private :: rimc1 = 300.0, rimc2 = 0.44 ! rime density coeff. and power (Default Heymsfield and Pflaum, 1985) real , private :: rimc3 = 170.0 ! minimum rime density + real :: rimc4 = 900.0 ! maximum rime density real , private :: rimtim = 120.0 ! cut-off rime time (10ICE) real , private :: eqtot = 1.0e-9 ! threshold for mass budget reporting @@ -164,7 +187,7 @@ MODULE module_mp_nssl_2mom ! = 1 : cnuc = actual available CCN ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac real , private :: cck = 0.6 ! exponent in Twomey expression - real , private :: xcradmx = 40.0e-6,ciintmx = 1.0e6 + real , private :: ciintmx = 1.0e6 real , private :: cwccn ! , cwmasn,cwmasx real , private :: ccwmx @@ -176,7 +199,7 @@ MODULE module_mp_nssl_2mom ! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process - integer, private :: icenucopt = 2 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott) + integer, private :: icenucopt = 3 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott) integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version integer, private :: ihrn = 0 ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only) integer, private :: ibfc = 1 ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on) @@ -185,12 +208,15 @@ MODULE module_mp_nssl_2mom integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation) integer, private :: ibiggopt = 1 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) - integer, private :: iacrsize = 1 ! assumed min size of drops freezing by capture + integer, private :: iacrsize = 5 ! assumed min size of drops freezing by capture ! 1: > 500 micron diam ! 2: > 300 micron ! 3: > 40 micron + ! 4: all sizes + ! 5: > 150 micron (only for imurain = 1) real , private :: cimas0 = 6.62e-11 ! default mass of Hallett-Mossop crystals ! 6.62e-11kg results in half the diam. (60 microns) of old default value of 5.0e-10 + real , private :: cimas1 = 6.88e-13 ! default mass of new ice crystals real , private :: splintermass = 6.88e-13 real , private :: cfnfac = 0.1 ! Hack factor that goes with icfn=1 integer, private :: iscni = 4 ! default option for ice crystal aggregation/conversion to snow @@ -200,9 +226,12 @@ MODULE module_mp_nssl_2mom integer, private :: iehlw = 1 ! 0 -> ehlw=ehlw0; 1 -> old ehlw; 2 -> test ehlw with Mason table data ! For ehw/ehlw = 1, ehw0/ehlw0 act as maximum limit on collection efficiency (defaults are 1.0) integer, private :: ierw = 1 ! for single-moment rain (LFO/Z) - real , private :: ehw0 = 0.9 ! constant or max assumed graupel-droplet collection efficiency + real , private :: ehw0 = 0.5 ! constant or max assumed graupel-droplet collection efficiency real , private :: erw0 = 1.0 ! constant assumed rain-droplet collection efficiency - real , private :: ehlw0 = 0.9 ! constant or max assumed hail-droplet collection efficiency + real , private :: ehlw0 = 0.75 ! constant or max assumed hail-droplet collection efficiency + real :: ehr0 = 1.0 ! constant or max assumed graupel-rain collection efficiency + real :: ehlr0 = 1.0 ! constant or max assumed hail-rain collection efficiency + real , private :: esilfo0 = 1.0 ! factor for LFO collection efficiency of snow for cloud ice. real , private :: ehslfo0 = 1.0 ! factor for LFO collection efficiency of hail/graupel for snow. @@ -223,7 +252,7 @@ MODULE module_mp_nssl_2mom ! set eii1 = 0 to get a constant value of eii0 real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) ! set eii1hl = 0 to get a constant value of eii0hl - real , private :: eri0 = 1.0 ! rain efficiency to collect ice crystals + real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals real , private :: ehs0 = 0.1 ,ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! set ehs1 = 0 to get a constant value of ehs0 real , private :: ess0 = 1.0 ,ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) @@ -232,6 +261,7 @@ MODULE module_mp_nssl_2mom real , private :: ehimin = 0.0 ! Minimum collection efficiency (graupel - ice crystal) real , private :: ehimax = 1.0 ! Maximum collection efficiency (graupel - ice crystal) real , private :: ehsmax = 0.5 ! Maximum collection efficiency (graupel - snow) + real , private :: ecollmx = 0.5 ! Maximum collision efficiency for graup/hail with ice; used only for charging rates integer, private :: iglcnvi = 1 ! flag for riming conversion from cloud ice to rimed ice/graupel integer, private :: iglcnvs = 2 ! flag for conversion from snow to rimed ice/graupel @@ -252,7 +282,7 @@ MODULE module_mp_nssl_2mom integer, parameter, private :: icond = 1 ! (Z only) icond = 1 calculates ice deposition (crystals and snow) BEFORE droplet condensation ! icond = 2 does not work (intended to calc. dep in loop with droplet cond.) - real , private :: dfrz = 0.15e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 + real , private :: dfrz = 0.15e-3 ! 0.25e-3 ! minimum diameter of frozen drops from Bigg freezing (used for vfrz) for iacr > 1 ! and for ciacrf for iacr=4 real , private :: dmlt = 3.0e-3 ! maximum diameter for rain melting from graupel and hail real , private :: dshd = 1.0e-3 ! nominal diameter for drops shed from graupel/hail @@ -291,12 +321,61 @@ MODULE module_mp_nssl_2mom logical :: rescale_high_alpha = .false. ! whether to rescale number. conc. when alpha = alphamax (3-moment only) logical :: rescale_low_alpha = .true. ! whether to rescale Z (graupel/hail) when alpha = alphamin (3-moment only) logical :: rescale_low_alphar = .true. ! whether to rescale Z for rain when alpha = alphamin (3-moment only) - + + real, parameter :: alpharmax = 8. ! limited for rwvent calculation integer, private :: ihlcnh = 1 ! which graupel -> hail conversion to use ! 1 = Milbrandt and Yau (2005) using Ziegler 1985 wet growth diameter ! 2 = Straka and Mansell (2005) conversion using size threshold + real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. + real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) real , private :: hldia1 = 20.0e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 2 option. + integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed + + integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. + integer, private :: imusnow = 3 ! 3 for gamma-volume, 1 for gamma-diameter DSD for snow (=1 NOT IMPLEMENTED!!). + integer :: iturbenhance = 0 ! enhancement of rain self-collection by turbulence + integer, private :: isedonly = 0 ! 1= only do sedimentation and skip other microphysics + integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1) + integer, private :: izwisventr = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3) + integer :: iresetmoments = 0 ! if >0, then set all moments to zero when one of them is zero (3-moment only) + integer, private :: imaxdiaopt = 3 ! = 1 use mean diameter for breakup + ! = 2 use maximum mass diameter for breakup + ! = 3 use mass-weighted diameter for breakup + integer, private :: dmrauto = 0 ! = -1 no limiter on crcnw + ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) + ! = 1 DTD version based on MY code + ! = 2 DTD mass-weighted version based on MY code + ! = 3 Milbrandt version (from Cohard and Pinty's code + real, parameter :: alpharaut = 0.0 ! MY2005 for autoconversion + real :: cxmin = 1.e-4 ! threshold cutoff for number concentration + real :: zxmin = 1.e-28 ! threshold cutoff for reflectivity moment + + integer :: ithompsoncnoh = 0 ! For single moment graupel only + ! 0 = fixed intercept + ! 1 = intercept based on graupel mass + + integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting + ! when liquid fraction is not predicted + integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories + integer, private :: isnowfall = 2 ! Option for choosing between snow fall speed parameters + ! 1 = original Zrnic et al. (Mansell et al. 2010) + ! 2 = Ferrier 1994 (results in slower fall speeds) + + integer, private :: ibiggsnow = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing + ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction + ! 3 = switch conversion over to snow for small frozen drops from both + + integer, private :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi) + + real, private :: evapfac = 1.0 ! Multiplier on rain evaporation rate + + integer, private :: ibinhmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of graupel, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + integer, private :: ibinhlmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of hail, and appropriate shed drop sizes + ! =2 to test melting by temporary bins + + integer, parameter :: lqmx = 30 integer, parameter :: lt = 1 @@ -318,6 +397,7 @@ MODULE module_mp_nssl_2mom integer, private :: lns = 12 integer, private :: lnh = 13 integer, private :: lnhl = 0 + integer, private :: lss = 0 integer :: lvh = 15 integer, private :: lhab = 8 @@ -386,7 +466,6 @@ MODULE module_mp_nssl_2mom real :: dmuh = 1.0 ! power in exponential part (graupel) real :: dmuhl = 1.0 ! power in exponential part (hail) - real, parameter :: alpharmax = 8. ! limited for rwvent calculation real, parameter :: alphamax = 15. real, parameter :: alphamin = 0. real, parameter :: rnumin = -0.8 @@ -412,45 +491,29 @@ MODULE module_mp_nssl_2mom real da1 (lc:lqmx) ! collection coefficients from Seifert 2005 real bb (lc:lqmx) -! -! max and min mean volumes -! - real :: xvcmn, xvcmx = 2.89e-13 ! min, max droplet volumes - real xvrmn, xvrmx0 ! min, max rain volumes - real xvsmn, xvsmx ! min, max snow volumes - real xvfmn, xvfmx ! min, max frozen drop volumes - real xvgmn, xvgmx ! min, max graupel volumes - real xvhmn, xvhmn0, xvhmx, xvhmx0 ! min, max hail volumes - real xvhlmn, xvhlmx ! min, max lg hail volumes - - real, private :: dhmn = -1., dhmx = -1. - real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3 - - parameter( xvcmn=4.188e-18 ) ! mks min volume = 1 micron radius - parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 ) ! mks - real :: xvdmx = -1.0 ! 3.0e-3 - real :: xvrmx - parameter( xvsmn=0.523599*(0.1e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 ) ! mks - parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 - parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 - parameter( xvhmn0=0.523599*(0.15e-3)**3, xvhmx0=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 - parameter( xvhlmn=0.523599*(0.3e-3)**3, xvhlmx=0.523599*(25.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 ! put ipelec here for now.... integer :: ipelec = 0 integer :: isaund = 0 logical :: idonic = .false. + real, private :: delqnw = -1.0e-10!-1.0e-12 ! + real, private :: delqxw = 1.0e-10! 1.0e-12 ! + real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed + ! ! gamma function lookup table ! integer ngm0,ngm1,ngm2 parameter (ngm0=3001,ngm1=500,ngm2=500) - real, parameter :: dgam = 0.01, dgami = 100. - real gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) + double precision, parameter :: dgam = 0.01, dgami = 100. + double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) - integer, parameter :: nqiacralpha = 15, nqiacrratio = 25 - real, parameter :: dqiacralpha = 1., dqiacrratio = 1. + integer, parameter :: nqiacralpha = 120 ! 15 + integer, parameter :: nqiacrratio = 50 ! 25 + real, parameter :: dqiacralpha = 15./Float(nqiacralpha), dqiacrratio = 25./Float(nqiacrratio) + real, parameter :: dqiacrratioinv = 1./dqiacrratio, dqiacralphainv = 1./dqiacralpha real :: ciacrratio(0:nqiacrratio,0:nqiacralpha) real :: qiacrratio(0:nqiacrratio,0:nqiacralpha) + double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,8,2) ! last index for graupel (1) or hail (2) integer, parameter :: ngdnmm = 9 real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail @@ -509,6 +572,43 @@ MODULE module_mp_nssl_2mom real, parameter :: gr = 9.8 +! +! max and min mean volumes +! + real xvrmn, xvrmx0 ! min, max rain volumes + real xvsmn, xvsmx ! min, max snow volumes + real xvfmn, xvfmx ! min, max frozen drop volumes + real xvgmn, xvgmx ! min, max graupel volumes + real xvhmn, xvhmn0, xvhmx, xvhmx0 ! min, max hail volumes + real xvhlmn, xvhlmx ! min, max lg hail volumes + + real, parameter :: dhlmn = 0.3e-3, dhlmx = 40.e-3 + real, parameter :: dhmn0 = 0.3e-3 + real, private :: dhmn = dhmn0, dhmx = -1. + + real, parameter :: cwradn = 2.5e-6, xcradmn = cwradn ! minimum radius + real, parameter :: cwradx = 40.e-6, xcradmx = cwradx ! maximum radius + real, parameter :: cwc1 = 6.0/(pi*1000.) + +! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius + real, parameter :: xvcmn=0.523599*(2.*cwradn)**3 ! mks min volume = 2.5 micron radius + real, parameter :: xvcmx=0.523599*(2.*xcradmx)**3 ! mks min volume = 2.5 micron radius + real, parameter :: cwmasn = 1000.*xvcmn ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 1000.*xvcmx ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwmasn5 = 1000.*0.523599*(2.*5.0e-6)**3 ! 5.23e-13 + + real, parameter :: xvimn=0.523599*(2.*5.e-6)**3 ! mks min volume = 5 micron radius + real, parameter :: xvimx=0.523599*(2.*1.e-3)**3 ! mks max volume = 1 mm radius (solid sphere approx) + + real :: xvdmx = -1.0 ! 3.0e-3 + real :: xvrmx + parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvsmn=0.523599*(0.1e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 ) ! mks + parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + parameter( xvhlmn=0.523599*(dhlmn)**3, xvhlmx=0.523599*(dhlmx)**3 ) ! mks xvfmx = (pi/6)*(10mm)**3 + ! ! electrical permitivity of air C / (N m**2) - check the units ! @@ -553,57 +653,26 @@ MODULE module_mp_nssl_2mom real, parameter :: bfnu0 = (rnu + 2.0)/(rnu + 1.0) real :: ventr, ventrn, ventc, c1sw - real :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 - real :: cwmasn5 = 5.23e-13 - real :: cwradn = 5.0e-6 ! minimum radius - real :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 - real, parameter :: cwc1 = 6.0/(pi*1000.) - real :: cckm,ccne,ccnefac,cnexp + real :: cckm,ccne,ccnefac,cnexp,CCNE0 integer :: na = 9 real gf4p5, gf4ds, gf4br + real gsnow1, gsnow53, gsnow73 real gfcinu1, gfcinu1p47, gfcinu2p47 real :: cwchtmp0 = 1.0 real :: cwchltmp0 = 1.0 - integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. - integer :: iturbenhance = 0 ! enhancement of rain self-collection by turbulence - integer, private :: isedonly = 0 ! 1= only do sedimentation and skip other microphysics - integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1) - integer, private :: izwisventr = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3) - integer :: iresetmoments = 1 ! if >0, then set all moments to zero when one of them is zero (3-moment only) - integer, private :: imaxdiaopt = 3 ! = 1 use mean diameter for breakup - ! = 2 use maximum mass diameter for breakup - ! = 3 use mass-weighted diameter for breakup - integer, private :: dmrauto = 0 ! = -1 no limiter on crcnw - ! = 0 limit crcnw when qr > 1.2*L (Cohard-Pinty 2002) - ! = 1 DTD version based on MY code - ! = 2 DTD mass-weighted version based on MY code - ! = 3 Milbrandt version (from Cohard and Pinty's code - real :: cxmin = 1.e-4 ! threshold cutoff for number concentration - real :: zxmin = 1.e-28 ! threshold cutoff for reflectivity moment - - integer :: ithompsoncnoh = 0 ! For single moment graupel only - ! 0 = fixed intercept - ! 1 = intercept based on graupel mass + real :: esctot = 1.0e-13 - integer :: ivhmltsoak = 1 ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting - ! when liquid fraction is not predicted - integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories - - integer :: ibiggsnow = 0 ! 1 = switch conversion over to snow for small frozen drops - - integer :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi) - - real :: evapfac = 1.0 ! Multiplier on rain evaporation rate - - real, private :: hlcnhdia = 1.e-3 ! threshold diameter for graupel -> hail conversion for ihlcnh = 1 option. - real, private :: hlcnhqmin = 0.1e-3 ! minimum graupel mass content for graupel -> hail conversion (ihlcnh = 1) - integer :: icvhl2h = 0 ! allow conversion of hail back to graupel when hail density gets close to minimum allowed + integer iexy(lc:lqmx,lc:lqmx) + integer :: ieswi = 1, ieswc = 1, ieswr = 0 + integer :: iehlsw = 1, iehli = 1, iehlc = 1, iehlr = 0 + integer :: iehwsw = 1, iehwi = 1, iehwc = 1, iehwr = 0 + logical, parameter :: do_satadj_for_wrfchem = .true. ! ##################################################################### ! ##################################################################### @@ -634,14 +703,18 @@ SUBROUTINE nssl_2mom_init( & integer, intent(in) :: ims,ime, jms,jme, kms,kme real, intent(in), dimension(20) :: nssl_params + + integer, intent(in) :: ipctmp,mixphase,ihvol logical, optional, intent(in) :: idonictmp - real :: arg, temq + double precision :: arg + real :: temq integer :: igam integer :: i,il,j,l integer :: ltmp integer :: isub + real :: bxh,bxhl real :: alp,ratio,x,y @@ -650,7 +723,7 @@ SUBROUTINE nssl_2mom_init( & ! ! set some global values from namelist input ! - ccn = nssl_params(1) + ccn = nssl_params(1) alphah = nssl_params(2) alphahl = nssl_params(3) cnoh = nssl_params(4) @@ -661,9 +734,17 @@ SUBROUTINE nssl_2mom_init( & rho_qhl = nssl_params(9) rho_qs = nssl_params(10) + cwccn = ccn - IF ( ipelec > 0 ) idonic = .true. + lhab = 8 + lhl = 8 + IF ( ihvol == -1 ) THEN + lhab = 7 ! turns off hail -- option for single moment, only!! + lhl = 0 + ENDIF + +! IF ( ipelec > 0 ) idonic = .true. ! ! Build lookup table for saturation mixing ratio (Soong and Ogura 73) @@ -679,48 +760,96 @@ SUBROUTINE nssl_2mom_init( & & cai/(temq - cbi))*tabqis(l) end do + bx(lr) = 0.85 + ax(lr) = 1647.81 + fx(lr) = 135.477 + + IF ( icdx > 0 ) THEN + bx(lh) = 0.5 + ax(lh) = 75.7149 + ELSE + bx(lh) = 0.37 ! 0.6 + ax(lh) = 19.3 + ENDIF +! bx(lh) = 0.6 + + IF ( lhl .gt. 1 ) THEN + IF (icdxhl > 0 ) THEN + bx(lhl) = 0.5 + ax(lhl) = 75.7149 + ELSE + ax(lhl) = 206.984 + bx(lhl) = 0.6384 + ENDIF + ENDIF + ! fill in the complete gamma function lookup table - gmoi(0) = 1.e32 + gmoi(0) = 1.d32 do igam = 1,ngm0 arg = dgam*igam - gmoi(igam) = gamma(arg) + gmoi(igam) = gamma_dp(arg) end do ! build lookup table to compute the number and mass fractions of rain drops ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr ! Uses incomplete gamma functions + bxh = bx(lh) + bxhl = bx(Max(lh,lhl)) + DO j = 0,nqiacralpha - alp = float(j) + alp = float(j)*dqiacralpha y = gamma(1.+alp) DO i = 1,nqiacrratio - ratio = float(i) + ratio = float(i)*dqiacrratio x = gamxinf( 1.+alp, ratio ) ! write(0,*) 'i, x/y = ',i, x/y ciacrratio(i,j) = x/y + + gamxinflu(i,j,1,1) = x/y + gamxinflu(i,j,2,1) = gamxinf( 2.0+alp, ratio )/y + gamxinflu(i,j,3,1) = gamxinf( 2.5+alp+0.5*bxh, ratio )/y + gamxinflu(i,j,5,1) = gamxinf( 5.0+alp, ratio )/y + gamxinflu(i,j,6,1) = gamxinf( 5.5+alp+0.5*bxh, ratio )/y + + gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) + gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) + gamxinflu(i,j,3,2) = gamxinf( 2.5+alp+0.5*bxhl, ratio )/y + gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1) + gamxinflu(i,j,6,2) = gamxinf( 5.5+alp+0.5*bxhl, ratio )/y + + IF ( alp > 1.1 ) THEN + gamxinflu(i,j,7,1) = gamxinf( alp - 1., ratio )/y + gamxinflu(i,j,8,1) = gamxinf( alp - 0.5 + 0.5*bxh, ratio )/y + gamxinflu(i,j,8,2) = gamxinf( alp - 0.5 + 0.5*bxhl, ratio )/y + ELSE + gamxinflu(i,j,7,1) = gamxinf( .1, ratio )/y + gamxinflu(i,j,8,1) = gamxinf( 1.1 - 0.5 + 0.5*bxh, ratio )/y + gamxinflu(i,j,8,2) = gamxinf( 1.1 - 0.5 + 0.5*bxhl, ratio )/y + ENDIF + + gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) + ENDDO ENDDO ciacrratio(0,:) = 1.0 DO j = 0,nqiacralpha - alp = float(j) + alp = float(j)*dqiacralpha y = gamma(4.+alp) DO i = 1,nqiacrratio - ratio = float(i) + ratio = float(i)*dqiacrratio x = gamxinf( 4.+alp, ratio ) ! write(0,*) 'i, x/y = ',i, x/y qiacrratio(i,j) = x/y + gamxinflu(i,j,4,1) = x/y + gamxinflu(i,j,4,2) = x/y + ENDDO ENDDO qiacrratio(0,:) = 1.0 - lhab = 8 - lhl = 8 - IF ( ihvol == -1 ) THEN - lhab = 7 ! turns off hail -- option for single moment, only!! - lhl = 0 - ENDIF isub = Min( 0, ihvol) ! is -1 or 0 lccn = 0 @@ -879,28 +1008,6 @@ SUBROUTINE nssl_2mom_init( & ! write(0,*) 'lsw,lhw,lhlw = ',lsw,lhw,lhlw ENDIF - bx(lr) = 0.85 - ax(lr) = 1647.81 - fx(lr) = 135.477 - - IF ( icdx > 0 ) THEN - bx(lh) = 0.5 - ax(lh) = 75.7149 - ELSE - bx(lh) = 0.37 ! 0.6 - ax(lh) = 19.3 - ENDIF -! bx(lh) = 0.6 - - IF ( lhl .gt. 1 ) THEN - IF (icdxhl > 0 ) THEN - bx(lhl) = 0.5 - ax(lhl) = 75.7149 - ELSE - ax(lhl) = 206.984 - bx(lhl) = 0.6384 - ENDIF - ENDIF xnu(lc) = 0.0 @@ -991,7 +1098,7 @@ SUBROUTINE nssl_2mom_init( & xdnmn(lc) = 1000.0 xdnmn(li) = 100.0 xdnmn(ls) = 100.0 - xdnmn(lh) = 170.0 + xdnmn(lh) = hdnmn IF ( lhl .gt. 1 ) xdnmn(lhl) = hldnmn xdn0(:) = 900.0 @@ -1023,7 +1130,7 @@ SUBROUTINE nssl_2mom_init( & IF ( lzr > 0 ) irfall = 0 qccn = ccn/rho00 - xvcmx = (4./3.)*pi*xcradmx**3 +! xvcmx = (4./3.)*pi*xcradmx**3 ! set max rain diameter IF ( xvdmx .gt. 0.0 ) THEN @@ -1048,11 +1155,13 @@ SUBROUTINE nssl_2mom_init( & ! load max/min diameters xvmn(lc) = xvcmn + xvmn(li) = xvimn xvmn(lr) = xvrmn xvmn(ls) = xvsmn xvmn(lh) = xvhmn xvmx(lc) = xvcmx + xvmx(li) = xvimx xvmx(lr) = xvrmx xvmx(ls) = xvsmx xvmx(lh) = xvhmx @@ -1066,15 +1175,15 @@ SUBROUTINE nssl_2mom_init( & ! cloud water constants in mks units ! ! cwmasn = 4.25e-15 ! radius of 1.0e-6 - cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 - cwmasn5 = 5.23e-13 - cwradn = 5.0e-6 ! minimum radius - cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 +! cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 +! cwmasn5 = 5.23e-13 +! cwradn = 5.0e-6 ! minimum radius +! cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 ! mwfac = 6.0**(1./3.) IF ( ipconc .ge. 2 ) THEN - cwmasn = xvmn(lc)*1000. ! minimum mass, defined by minimum droplet volume - cwradn = 1.0e-6 ! minimum radius - cwmasx = xvmx(lc)*1000. ! maximum mass, defined by maximum droplet volume +! cwmasn = xvmn(lc)*1000. ! minimum mass, defined by minimum droplet volume +! cwradn = 1.0e-6 ! minimum radius +! cwmasx = xvmx(lc)*1000. ! maximum mass, defined by maximum droplet volume ENDIF ! rwmasn = xvmn(lr)*1000. ! minimum mass, defined by minimum rain volume @@ -1118,7 +1227,7 @@ SUBROUTINE nssl_2mom_init( & IF ( li .gt. 1 .and. lni .gt. 1 ) qxmin(li ) = 1.0e-13 IF ( ls .gt. 1 .and. lns .gt. 1 ) qxmin(ls ) = 1.0e-13 IF ( lh .gt. 1 .and. lnh .gt. 1 ) qxmin(lh ) = 1.0e-12 - IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-9 + IF ( lhl.gt. 1 .and. lnhl.gt. 1 ) qxmin(lhl) = 1.0e-12 ! constants for droplet nucleation @@ -1128,11 +1237,13 @@ SUBROUTINE nssl_2mom_init( & ! ccne is all the factors with w in eq. A7 in Mansell et al. 2010 (JAS). The constant changes ! if k (cck) is changed! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) + ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck)) + write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp IF ( cwccn .lt. 0.0 ) THEN cwccn = Abs(cwccn) - ccwmx = cwccn + ccwmx = 50.e9 ! cwccn ELSE - ccwmx = cwccn ! *1.4 + ccwmx = 50.e9 ! cwccn ! *1.4 ENDIF ! @@ -1170,10 +1281,31 @@ SUBROUTINE nssl_2mom_init( & gfcinu1p47 = gamma(cinu + 1.47167) gfcinu2p47 = gamma(cinu + 2.47167) + gsnow1 = gamma(snu + 1.0) + gsnow53 = gamma(snu + 5./3.) + gsnow73 = gamma(snu + 7./3.) + IF ( lh .gt. 1 ) cwchtmp0 = 6.0/pi*gamma( (xnu(lh) + 1.)/xmu(lh) )/gamma( (xnu(lh) + 2.)/xmu(lh) ) IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma( (xnu(lhl) + 1)/xmu(lhl) )/gamma( (xnu(lhl) + 2)/xmu(lhl) ) + iexy(:,:)=0; ! sets to zero the ones Imight have forgotten + +! snow + iexy(ls,li) = ieswi + iexy(ls,lc) = ieswc ; iexy(ls,lr) = ieswr ; + +! graupel + iexy(lh,ls) = iehwsw ; iexy(lh,li) = iehwi ; + iexy(lh,lc) = iehwc ; iexy(lh,lr) = iehwr ; + +! hail + IF (lhl .gt. 1 ) THEN + iexy(lhl,ls) = iehlsw ; iexy(lhl,li) = iehli ; + iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; + ENDIF + + RETURN END SUBROUTINE nssl_2mom_init @@ -1187,13 +1319,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw th, pii, p, w, dn, dz, dtp, itimestep, & RAINNC,RAINNCV, SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & SR,HAILNC, HAILNCV, & + re_cloud, re_ice, re_snow, & + has_reqc, has_reqi, has_reqs, & dx, dy, & dbz, vzf,compdbz, & - rscghis_3d, rscghis_2d, & + rscghis_2d, & scr,scw,sci,scs,sch,schl,sctot,noninduc, & induc,elec,scion,sciona, & ipelectmp, & diagflag, & + nssl_progn, & ! wrf-chem +! 20130903 acd_mb_washout start + rainprod, evapprod, & ! wrf-chem +! 20130903 acd_mb_washout end ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims its,ite, jts,jte, kts,kte) ! tile dims @@ -1220,7 +1358,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d - real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d +! real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::rscghis_3d real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & scr,scw,sci,scs,sch,schl,sciona,sctot,induc,noninduc ! space charge real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elec ! elecsave = Ez @@ -1231,15 +1369,31 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: & + re_cloud, re_ice, re_snow + INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs real, optional, intent(in) :: dx,dy real, intent(in):: dtp integer, intent(in):: itimestep !, ccntype logical, optional, intent(in) :: diagflag - real, optional, intent(in) :: ipelectmp + integer, optional, intent(in) :: ipelectmp + + LOGICAL, INTENT(IN), OPTIONAL :: nssl_progn ! wrf-chem +! REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: qndrop + LOGICAL :: flag_qndrop ! wrf-chem + +! 20130903 acd_ck_washout start +! rainprod - total tendency of conversion of cloud water/ice and graupel to rain (kg kg-1 s-1) +! evapprod - tendency of evaporation of rain (kg kg-1 s-1) +! 20130903 acd_ck_washout end + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT):: rainprod, evapprod + ! ! local variables ! - real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+ + real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab +! real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+ + real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d real, dimension(its:ite, 1, kts:kte, na) :: an real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d @@ -1262,6 +1416,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, parameter :: cnin2a = 12.96 real, parameter :: cnin2b = 0.639 + logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state + real :: tmp,dv double precision :: dt1,dt2 @@ -1274,11 +1430,17 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! write(0,*) 'N2M: entering routine' - - + + flag_qndrop = .false. + IF ( PRESENT ( nssl_progn ) ) flag_qndrop = nssl_progn + IF ( present( vzf ) ) vzflag0 = 1 - IF ( present( ipelectmp ) ) ipelec = Nint(ipelectmp) + IF ( present( ipelectmp ) ) THEN + ipelec = ipelectmp + ELSE + ipelec = 0 + ENDIF ! IF ( present( dbz ) ) THEN ! DO jy = jts,jte ! DO kz = kts,kte @@ -1303,18 +1465,30 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw nz = kte-kts+1 ! set up CCN array and some other static local values - IF ( itimestep == 1 ) THEN - IF ( itimestep == 1 .and. present( cn ) ) THEN + IF ( itimestep == 1 .and. .not. invertccn .and. present( cn ) ) THEN +! IF ( cn((ite+its)/2,(kte+kts)/2,(jte+jts)/2) == 0.0 ) THEN ! initialize ccn if not already done + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cn(ix,kz,jy) = qccn + ENDDO + ENDDO + ENDDO +! ENDIF + ENDIF + + IF ( invertccn .and. present( cn ) ) THEN ! hack for WRF to convert activated ccn to unactivated, then don't have to + ! worry about initial and boundary conditions - they are zero DO jy = jts,jte DO kz = kts,kte DO ix = its,ite - cn(ix,kz,jy) = qccn + cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) ENDDO ENDDO ENDDO ENDIF - ENDIF ! itimestep == 1 +! ENDIF ! itimestep == 1 ! sedimentation settings @@ -1365,8 +1539,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw xfall(:,:,:) = 0.0 - -! write(0,*) 'N2M: load an, jy = ',jy +! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn ! copy from 3D array to 2D slab @@ -1385,11 +1558,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( present( cn ) ) THEN an(ix,1,kz,lccn) = cn(ix,kz,jy) ELSE - an(ix,1,kz,lccn) = qccn + an(ix,1,kz,lccn) = qccn - ccw(ix,kz,jy) ENDIF ENDIF IF ( ipconc >= 5 ) THEN - an(ix,1,kz,lnc) = ccw(ix,kz,jy) + an(ix,1,kz,lnc) = ccw(ix,kz,jy) + IF ( constccw > 0.0 ) THEN + an(ix,1,kz,lnc) = constccw + ENDIF an(ix,1,kz,lnr) = crw(ix,kz,jy) an(ix,1,kz,lni) = cci(ix,kz,jy) an(ix,1,kz,lns) = csw(ix,kz,jy) @@ -1469,7 +1645,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! Here, the fit line values from Cooper 1986 are converted. Very little difference ! in practice - t7(ix,1,kz) = 0.00446684*exp(0.3108*(273.16 - Max(233.0, t0(ix,1,kz) ) ) ) + t7(ix,1,kz) = 1000.*0.00446684*exp(0.3108*(273.16 - Max(233.0, t0(ix,1,kz) ) ) ) ! factor of 1000 to convert L**-1 to m**-3 + ! write(0,*) 'Cooper t7,ssival = ',ix,kz,t7(ix,1,kz),ssival ELSEIF ( icenucopt == 3 ) THEN ! Phillips (Meyers/DeMott) @@ -1494,6 +1671,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 + IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 + ENDIF ! transform from number mixing ratios to number conc. @@ -1564,6 +1745,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! IF ( isedonly /= 2 ) THEN + call nssl_2mom_gs & & (nx,ny,nz,na,jy & & ,nor,nor & @@ -1577,26 +1759,30 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! & ln,ipc,lvol,lz,lliq, & & cdx, & & xdn0,dbz2d,timevtcalc & + & ,rainprod2d, evapprod2d & + & ,elec2,its,ids,ide,jds,jde & & ) - ENDIF ! isedonly /= 1 ! droplet nucleation/condensation/evaporation + IF ( .true. ) THEN CALL NUCOND & & (nx,ny,nz,na,jy & & ,nor,nor & & ,dtp,dz2d & - & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,t0,t9 & & ,an,dn1,t77 & & ,pn,wn & - & ,ssat,t00,t77,dbz2d,scion2) + & ,ssat,t00,t77,flag_qndrop) + ENDIF + ! compute diagnostic S-band reflectivity if needed IF ( present( dbz ) .and. makediag ) THEN @@ -1621,6 +1807,38 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO +! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F + IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and. & + present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN + IF ( has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = 2.51E-6 + re_ice(ix,kz,jy) = 10.01E-6 + re_snow(ix,kz,jy) = 25.E-6 + t1(ix,1,kz) = 2.51E-6 + t2(ix,1,kz) = 10.01E-6 + t3(ix,1,kz) = 25.E-6 + ENDDO + ENDDO + + call calc_eff_radius & + & (nx,ny,nz,na,jy & + & ,nor,nor & + & ,t1,t2,t3 & + & ,an,dn1 ) + + DO kz = kts,kte + DO ix = its,ite + re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6)) + re_ice(ix,kz,jy) = MAX(10.01E-6, MIN(t2(ix,1,kz), 125.E-6)) + re_snow(ix,kz,jy) = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6)) + ENDDO + ENDDO + + ENDIF + ENDIF + ENDIF ! transform concentrations back to mixing ratios @@ -1648,10 +1866,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw qs(ix,kz,jy) = an(ix,1,kz,ls) qh(ix,kz,jy) = an(ix,1,kz,lh) IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl) - IF ( present( cn ) .and. lccn > 1 ) THEN + IF ( present( cn ) .and. lccn > 1 .and. .not. flag_qndrop) THEN cn(ix,kz,jy) = an(ix,1,kz,lccn) ENDIF IF ( ipconc >= 5 ) THEN + ccw(ix,kz,jy) = an(ix,1,kz,lnc) crw(ix,kz,jy) = an(ix,1,kz,lnr) cci(ix,kz,jy) = an(ix,1,kz,lni) @@ -1666,11 +1885,28 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( lvh > 0 ) vhw(ix,kz,jy) = an(ix,1,kz,lvh) IF ( lvhl > 0 .and. present( vhl ) ) vhl(ix,kz,jy) = an(ix,1,kz,lvhl) +#ifdef WRF_CHEM + IF ( wrfchem_flag > 0 ) THEN + IF ( PRESENT( rainprod ) ) rainprod(ix,kz,jy) = rainprod2d(ix,kz) + IF ( PRESENT( evapprod ) ) evapprod(ix,kz,jy) = evapprod2d(ix,kz) + ENDIF +#endif ENDDO ENDDO ENDDO ! jy + IF ( invertccn .and. present( cn ) ) THEN ! hack to convert unactivated ccn back to activated + DO jy = jts,jte + DO kz = kts,kte + DO ix = its,ite + cn(ix,kz,jy) = Max( 0.0, qccn - cn(ix,kz,jy) ) + ENDDO + ENDDO + ENDDO + ENDIF + + @@ -1724,10 +1960,10 @@ real function GAMXINF(A1,X1) ! =================================================== ! Purpose: Compute the incomplete gamma function ! from x to infinity -! Input : a --- Parameter ( a ó 170 ) +! Input : a --- Parameter ( a 170 ) ! x --- Argument -! Output: GIM --- â(a,x) t=x,Infinity -! Routine called: GAMMA for computing â(x) +! Output: GIM --- gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing gamma(x) ! =================================================== ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) @@ -1916,7 +2152,7 @@ real function BETA(P,Q) ! Input : p --- Parameter ( p > 0 ) ! q --- Parameter ( q > 0 ) ! Output: BT --- B(p,q) -! Routine called: GAMMA for computing â(x) +! Routine called: GAMMA for computing gamma(x) ! ========================================== ! ! IMPLICIT real (A-H,O-Z) @@ -1934,15 +2170,49 @@ real function BETA(P,Q) RETURN END function BETA +! ##################################################################### +! ##################################################################### + + DOUBLE PRECISION FUNCTION GAMMA_DP(xx) + + implicit none + double precision xx + integer j + +! Double precision ser,stp,tmp,x,y,cof(6) + + real*8 ser,stp,tmp,x,y,cof(6) + SAVE cof,stp + DATA cof,stp/76.18009172947146d+0, & + & -86.50532032941677d0, & + & 24.01409824083091d0, & + & -1.231739572450155d0, & + & 0.1208650973866179d-2,& + & -0.5395239384953d-5, & + & 2.5066282746310005d0/ + + x = xx + y = x + tmp = x + 5.5d0 + tmp = (x + 0.5d0)*Log(tmp) - tmp + ser = 1.000000000190015d0 + DO j=1,6 + y = y + 1.0d0 + ser = ser + cof(j)/y + END DO + gamma_dp = Exp(tmp + log(stp*ser/x)) + + RETURN + END function gamma_dp ! ##################################################################### SUBROUTINE GAMMADP(X,GA) ! ! ================================================== -! Purpose: Compute gamma function â(x) -! Input : x --- Argument of â(x) -! ( x is not equal to 0,-1,-2,úúú) -! Output: GA --- â(x) +! Purpose: Compute gamma function Gamma(x) +! Input : x --- Argument of Gamma(x) +! ( x is not equal to 0,-1,-2,...) +! Output: GA --- gamma(x) ! ================================================== ! ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) @@ -2121,6 +2391,15 @@ END Function delabk ! ##################################################################### ! ! ##################################################################### +!-------------------------------------------------------------------------- + subroutine cld_cpu(string) + + implicit none + character( LEN = * ) string + + return + + end subroutine cld_cpu ! !-------------------------------------------------------------------------- @@ -2187,7 +2466,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & real :: xdn(ngs,lc:lhab) real :: xdia(ngs,lc:lhab,3) real :: vx(ngs,li:lhab) - real :: alpha(ngs,lr:lhab) + real :: alpha(ngs,lc:lhab) real :: zx(ngs,lr:lhab) logical :: hasmass(nx,lc+1:lhab) @@ -2205,7 +2484,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & real cimasn,cimasx,cnina(ngs),cimas(ngs) real cnostmp(ngs) - + !----------------------------------------------------------------------------- @@ -2295,7 +2574,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & ! loop over each species and do sedimentation for all moments - DO il = lc+1,lhab + DO il = lc,lhab ! IF ( .not. hasmass(ix,il) ) CYCLE @@ -2638,7 +2917,7 @@ END SUBROUTINE FALLOUT1D ! ############################################################################## subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & - & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qh, ixcol) + & z,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx, lvol, rho_qx, ixcol) implicit none @@ -2659,7 +2938,7 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & integer l ! index for q integer ln ! index for N integer lvol ! index for volume - real rho_qh + real rho_qx integer ix,jy,kz @@ -2681,12 +2960,12 @@ subroutine calczgr1d(nx,ny,nz,nor,na,a,ixe,kze, & IF ( lvol .gt. 1 ) THEN IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) - xdn = Min( 900., Max( 170., xdn ) ) + xdn = Min( 900., Max( hdnmn, xdn ) ) ELSE - xdn = rho_qh + xdn = rho_qx ENDIF ELSE - xdn = rho_qh + xdn = rho_qx ENDIF IF ( l == lr ) xdn = 1000. @@ -2757,7 +3036,7 @@ END subroutine calczgr1d subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & & z0,db,jgs,ipconc, alpha, l,ln, qmin, xvmn,xvmx,t1, & - & lvol, rho_qh, infall, ixcol) + & lvol, rho_qx, infall, ixcol) implicit none @@ -2780,7 +3059,7 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & integer l ! index for q integer ln ! index for N integer lvol ! index for volume - real rho_qh + real rho_qx integer infall @@ -2812,12 +3091,12 @@ subroutine calcnfromz1d(nx,ny,nz,nor,na,a,t0,ixe,kze, & IF ( lvol .gt. 1 ) THEN IF ( a(ix,jy,kz,lvol) .gt. 0.0 ) THEN xdn = db(ix,kz)*a(ix,jy,kz,l)/a(ix,jy,kz,lvol) - xdn = Min( 900., Max( 170., xdn ) ) + xdn = Min( 900., Max( hdnmn, xdn ) ) ELSE - xdn = rho_qh + xdn = rho_qx ENDIF ELSE - xdn = rho_qh + xdn = rho_qx ENDIF IF ( l == lr ) xdn = 1000. @@ -2962,7 +3241,6 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) real xvmn,xvmx integer ipconc integer lvol ! index for volume - real rho_qh integer infall @@ -3075,24 +3353,18 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) END subroutine calcnfromq - - ! ##################################################################### ! ##################################################################### -! -! Subroutine for explicit cloud condensation and droplet nucleation -! - SUBROUTINE NUCOND & + + SUBROUTINE calc_eff_radius & & (nx,ny,nz,na,jyslab & & ,nor,norz & - & ,dtp,dz3d & - & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & - & ,an,dn,p2 & - & ,pn,w & - & ,ssfilt,t00,t77,tmp3d,scion) + & ,t1,t2,t3 & + & ,an,dn ) implicit none + integer, parameter :: ng1 = 1 integer :: nx,ny,nz,na integer :: ng integer :: nor,norz, jyslab ! ,nht,ngt,igsr @@ -3102,49 +3374,33 @@ SUBROUTINE NUCOND & ! ! external temporary arrays ! - real t00(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t8(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real t9(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) ! perturbation Pi - real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) -! real qv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - - real ssfilt(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real tmp3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - real scion(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,2) ! local + + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) ! ! declarations microphysics and for gather/scatter ! integer nxmpb,nzmpb,nxz integer mgs,ngs,numgs,inumgs - parameter (ngs=500) + parameter (ngs=1) integer ngscnt,igs(ngs),kgs(ngs) - integer kgsp(ngs),kgsm(ngs) - integer nsvcnt - + real rho0(ngs) + integer ix,kz,i,n, kp1 integer :: jy, jgs integer ixb,ixe,jyb,jye,kzb,kze @@ -3153,134 +3409,18 @@ SUBROUTINE NUCOND & integer ixend,jyend,kzend,kzbeg integer nxend,nyend,nzend,nzbeg -! -! Variables for Ziegler warm rain microphysics -! - - - real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) - real sscb ! 'cloud base' SS threshold - parameter ( sscb = 2.0 ) - integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals - parameter ( idecss = 1 ) - integer iba ! flag to do condensation/nucleation in 1st or 2nd loop - ! =0 to use ad to calculate SS - ! =1 to use an at end of main jy loop to calculate SS - parameter (iba = 1) - integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat - parameter ( ifilt = 0 ) - real temp1,temp2 ! ,ssold - real ssmax(ngs) ! maximum SS experienced by a parcel - real ssmx - real dnnet,dqnet -! real cnu,rnu,snu,cinu -! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) - real ventrx(ngs) - real ventrxn(ngs) - real volb, t2s - real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler - - real ec0, ex1, ft, rhoinv(ngs) - - real chw, g1, rd1 - - real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super - real x,y,del,r,alpr - double precision :: vent1,vent2 - real g1palp - real bs - real v1, v2 - real d1r, d1i, d1s, e1i - integer nc ! condensation step - real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) - real delta - integer ltemq1,ltemq1m ! ,ltemq1m2 - real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation - - real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 - real dqvr, dqc, dqr, dqi, dqs - real qv1m,qvs1m,ss1m,ssi1m,qis1m - real cwmastmp - real dcloud,dcloud2 ! ,as, bs - real cn(ngs) - - integer ltemq - - integer il - - real es(ngs) ! ss(ngs), - real eis(ngs) - real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs) - real ssfjp1(ngs),ssfjm1(ngs) - real ssfip1(ngs),ssfim1(ngs) - - real supcb, supmx - parameter (supcb=0.5,supmx=238.0) - real r2dxm, r2dym, r2dzm - real dssdz, dssdy, dssdx -! real tqvcon - real epsi,d - parameter (epsi = 0.622, d = 0.266) - real r1,qevap ! ,slv - - real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc - real ctmp, ccwtmp - real f5, qvs0 ! Kessler condensation factor - real :: t0p1, t0p3 - real qvex - -! real, dimension(ngs) :: temp, tempc, elv, elf, els, pqs, theta, temg, temcg - real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs) - real temp(ngs),tempc(ngs) - real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) ! ,tembzg(ngs) - real temgx(ngs),temcgx(ngs) - real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) - real felv(ngs),felf(ngs),fels(ngs) - real felvcp(ngs) - real gamw(ngs),gams(ngs) ! qciavl(ngs), - real tsqr(ngs),ssi(ngs),ssw(ngs) - real cc3(ngs),cqv1(ngs),cqv2(ngs) - real qcwtmp(ngs),qtmp - - real fvent(ngs) !,fraci(ngs),fracl(ngs) - real fwvdf(ngs),ftka(ngs),fthdf(ngs) - real fadvisc(ngs),fakvisc(ngs) - real fci(ngs),fcw(ngs) - real fschm(ngs),fpndl(ngs) - - real pres(ngs) - real pk(ngs) - real rho0(ngs),pi0(ngs) - real rhovt(ngs) - real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) - real thsave(ngs) - real qss0(ngs) - real fcqv1(ngs) - real wvel(ngs),wvelkm1(ngs) - - real wvdf(ngs),tka(ngs) - real advisc(ngs) - - real rwvent(ngs) - - real :: qx(ngs,lv:lhab) real :: cx(ngs,lc:lhab) real :: xv(ngs,lc:lhab) real :: xmas(ngs,lc:lhab) real :: xdn(ngs,lc:lhab) real :: xdia(ngs,lc:lhab,3) - real :: alpha(ngs,lr:lhab) - real :: zx(ngs,lr:lhab) - - - logical zerocx(lc:lqmx) - - integer, parameter :: iunit = 0 - - real :: frac, hwdn, tmpg + real :: alpha(ngs,lc:lhab) - real :: cvm + real :: gamc1,gamc2,gami1,gami2,gams1,gams2, factor_c, factor_i, factor_s + real :: lam_c, lam_i, lam_s + integer :: il + ! ------------------------------------------------------------------------------- itile = nx @@ -3295,32 +3435,20 @@ SUBROUTINE NUCOND & kzbeg = 1 nzbeg = 1 - jy = 1 - - IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200 - -! -! Ziegler nucleation -! - - ssfilt(:,:,:) = 0.0 - - do kz = 1,nz - do ix = 1,nx - - temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz) - t0(ix,jy,kz) = temp1 - ltemq = Int( (temp1-163.15)/fqsat+1.5 ) - ltemq = Min( nqsat, Max(1,ltemq) ) - - c1 = t00(ix,jy,kz)*tabqvs(ltemq) - - ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values - + jy = 1 + pb(:) = 0.0 + pinit(:) = 0.0 - ENDDO - ENDDO + gamc1 = Gamma(2. + cnu) + gamc2 = 1. ! Gamma[1 + alphac] + gami1 = Gamma(2. + cinu) + gami2 = 1. ! Gamma[1 + alphac] + gams1 = Gamma(2. + cinu) + gams2 = Gamma(1. + snu) + factor_c = (1. + cnu)*Gamma(1. + cnu)/Gamma(5./3. + cnu) + factor_i = (1. + cinu)*Gamma(1. + cinu)/Gamma(5./3. + cinu) + factor_s = (1. + snu)*Gamma(1. + snu)/Gamma(5./3. + snu) ! ! jy = 1 ! working on a 2d slab @@ -3328,12090 +3456,12695 @@ SUBROUTINE NUCOND & jgs = jy -! -!..Gather microphysics -! - if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Gather stage' - - nxmpb = 1 - nzmpb = 1 - nxz = nx*nz - numgs = nxz/ngs + 1 - - - do 2000 inumgs = 1,numgs - - ngscnt = 0 - - - kzb = nzmpb - kze = nz - ! if (kzbeg .le. nzmpb .and. kzend .gt. nzmpb) kzb = nzmpb - - ixb = nxmpb - ixe = itile -! if (ixbeg .le. nxmpb .and. ixend .gt. nxmpb) ixb = nxmpb - - do kz = kzb,kze - do ix = nxmpb,nx - - pqs(1) = 380.0/pn(ix,jy,kz) - theta(1) = an(ix,jy,kz,lt) - temg(1) = t0(ix,jy,kz) - - temcg(1) = temg(1) - tfr - ltemq = (temg(1)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(1) = pqs(1)*tabqvs(ltemq) - qis(1) = pqs(1)*tabqis(ltemq) + mgs = 1 + DO kz = 1,nz + DO ix = 1,nx ! ixcol - qss(1) = qvs(1) + rho0(mgs) = dn(ix,jy,kz) + DO il = lc,ls + qx(mgs,il) = max(an(ix,jy,kz,il), 0.0) + cx(mgs,il) = max(an(ix,jy,kz,ln(il)), 0.0) + ENDDO + + IF ( qx(mgs,lc) > qxmin(lc) ) THEN +! Lambda for cloud droplets + lam_c = ((cx(mgs,lc)*(Pi/6.)*xdn0(lc)*Gamc1)/(qx(mgs,lc)*rho0(mgs)*Gamc2))**(1./3.) + t1(ix,jy,kz) = 0.5*factor_c/lam_c + ENDIF + IF ( qx(mgs,li) > qxmin(li) ) THEN +! Lambda for cloud ice + lam_i = ((cx(mgs,li)*(Pi/6.)*xdn0(li)*Gami1)/(qx(mgs,li)*rho0(mgs)*Gami2))**(1./3.) + t2(ix,jy,kz) = 0.5*factor_i/lam_i + ENDIF - if ( temg(1) .lt. tfr ) then - end if -! - if ( (temg(1) .gt. tfrh ) .and. & - & ( an(ix,jy,kz,lv) .gt. qss(1) .or. & - & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & - & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) & - & )) then - ngscnt = ngscnt + 1 - igs(ngscnt) = ix - kgs(ngscnt) = kz - if ( ngscnt .eq. ngs ) goto 2100 - end if + IF ( qx(mgs,ls) > qxmin(ls) ) THEN +! Lambda for snow + lam_s = ((cx(mgs,ls)*(Pi/6.)*xdn0(ls)*Gams1)/(qx(mgs,ls)*rho0(mgs)*Gams2))**(1./3.) + t3(ix,jy,kz) = 0.5*factor_s/lam_s + ENDIF - end do !ix + + ENDDO ! ix + ENDDO ! kz - nxmpb = 1 - end do !kz -! if ( jy .eq. (ny-jstag) ) iend = 1 - 2100 continue + RETURN + END SUBROUTINE calc_eff_radius - if ( ngscnt .eq. 0 ) go to 29998 - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8' +! ##################################################################### +! ##################################################################### + SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & + & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt) - qx(:,:) = 0.0 - cx(:,:) = 0.0 - - xv(:,:) = 0.0 - xmas(:,:) = 0.0 +!##################################################################### +! Purpose: find the amount of vapor that can be condensed to liquid +!##################################################################### - alpha(:,lr) = xnu(lr) + implicit none + integer ngs,mgs,ngscnt + + real theta2temp + + real qvex + + integer nqsat + real fqsat, cbw + + real ss1 ! 'target' supersaturation ! -! define temporaries for state variables to be used in calculations +! input arrays ! - DO mgs = 1,ngscnt - qx(mgs,lv) = an(igs(mgs),jy,kgs(mgs),lv) - DO il = lc,lhab - qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) - ENDDO - - qcwtmp(mgs) = qx(mgs,lc) - - - theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) ! - thetap(mgs) = 0.0 - theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - qv0(mgs) = qx(mgs,lv) - qwvp(mgs) = qx(mgs,lv) - qv0(mgs) + real qv0(ngs), qcw1(ngscnt), pres(ngs), qwvp0(mgs) + real thetap0(ngs), theta0(ngs) + real fcqv1(ngs), felvcp(ngs), pi0(ngs) + real pk(ngs) + + real tabqvs(nqsat) +! +! Local stuff +! + + integer itertd + integer ltemq + real gamss + real theta(ngs), qvap(ngs), pqs(ngs), qcw(ngs), qwv(ngs) + real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs) + real dqcw(ngs), dqwv(ngs), dqvcnd(ngs) + real temg(ngs), temcg(ngs), thetap(ngs) + + real tfr + parameter ( tfr = 273.15 ) + +! real poo,cap +! parameter ( cap = rd/cp, poo = 1.0e+05 ) +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + pqs(mgs) = (380.0)/(pres(mgs)) + thetap(mgs) = thetap0(mgs) + theta(mgs) = thetap(mgs) + theta0(mgs) + qwvp(mgs) = qwvp0(mgs) + qvap(mgs) = max( (qwvp0(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) +! +! +! +! reset temporaries for cloud particles and vapor +! + + qwv(mgs) = max( 0.0, qvap(mgs) ) + qcw(mgs) = max( 0.0, qcw1(mgs) ) +! +! + qcwtmp(mgs) = qcw(mgs) + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) - pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) - rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) - rhoinv(mgs) = 1.0/rho0(mgs) - rhovt(mgs) = Sqrt(rho00/rho0(mgs)) - pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) - temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) - pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap - temcg(mgs) = temg(mgs) - tfr - qss0(mgs) = (380.0)/(pres(mgs)) - pqs(mgs) = (380.0)/(pres(mgs)) - ltemq = (temg(mgs)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - qis(mgs) = pqs(mgs)*tabqis(ltemq) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) ! - qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) - es(mgs) = 6.1078e2*tabqvs(ltemq) - qss(mgs) = qvs(mgs) +! iterate adjustment +! + do itertd = 1,2 +! +! +! calculate super-saturation +! + dqcw(mgs) = 0.0 + dqwv(mgs) = ( qwv(mgs) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qcw(mgs) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qcw(mgs) + dqwv(mgs) = dqwv(mgs) + qcw(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) ) ! add to perturbation vapor +! + qcw(mgs) = qcw(mgs) + dqcw(mgs) + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) ) - temgx(mgs) = min(temg(mgs),313.15) - temgx(mgs) = max(temgx(mgs),233.15) - felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) ! - IF ( eqtset <= 1 ) THEN - felvcp(mgs) = felv(mgs)*cpi - ELSE ! equation set 2 in cm1 - tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) - IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) - cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & - +cpigb*(tmp) - felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm - ENDIF +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN +! + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) +! +! + dqcw(mgs) = dqvcnd(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) ) & + & / (pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qcw(mgs) = qcw(mgs) + dqcw(mgs) +! + END IF ! dqwv(mgs) .ge. 0. - temcgx(mgs) = min(temg(mgs),273.15) - temcgx(mgs) = max(temcgx(mgs),223.15) - temcgx(mgs) = temcgx(mgs)-273.15 - felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr +! tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qcw(mgs) = max( 0.0, qcw(mgs) ) + qwv(mgs) = max( 0.0, qvap(mgs)) + qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) + end do ! - fels(mgs) = felv(mgs) + felf(mgs) - fcqv1(mgs) = 4098.0258*felv(mgs)*cpi +! end the saturation adjustment iteration loop +! +! + qvex = Max(0.0, qcw(mgs) - qcw1(mgs) ) - wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & - & (101325.0/pn(igs(mgs),jgs,kgs(mgs))) ! diffusivity of water vapor, Hall and Pruppacher (76) - advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & - & (temg(mgs)/296.0)**(1.5) ! dynamic viscosity (SMT; see Beard & Pruppacher 71) - tka(mgs) = tka0*advisc(mgs)/advisc1 ! thermal conductivity + RETURN + END SUBROUTINE QVEXCESS + +! ##################################################################### +! ##################################################################### - ENDDO ! -! load concentrations +! ############################################################################## ! - if ( ipconc .ge. 1 ) then - do mgs = 1,ngscnt - cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) - end do - end if - if ( ipconc .ge. 2 ) then - do mgs = 1,ngscnt - cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) - cwnccn(mgs) = cwccn*rho0(mgs)/rho00 - cn(mgs) = 0.0 - IF ( lccn .gt. 1 ) THEN - ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) - ELSE - ccnc(mgs) = cwnccn(mgs) - ENDIF - IF ( lccna > 1 ) THEN - ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) - ELSE - IF ( lccn > 1 ) THEN - ccna(mgs) = cwnccn(mgs) - ccnc(mgs) - ELSE - ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn - ENDIF - ENDIF - end do - end if - if ( ipconc .ge. 3 ) then - do mgs = 1,ngscnt - cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) - end do - end if - - cnuc(1:ngscnt) = cwccn*(1. - renucfrac) + ccnc(1:ngscnt)*renucfrac - + SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx, & + & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & + & itype1a,itype2a,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) -! Set density -! - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set density' - do mgs = 1,ngscnt - xdn(mgs,lc) = xdn0(lc) - xdn(mgs,lr) = xdn0(lr) - end do + implicit none - ventrx(:) = ventr - ventrxn(:) = ventrn +! include 'sam.index.ion.h' +! include 'swm.index.zieg.h' - - + integer ngscnt,ngs0,ngs,nz +! integer infall ! whether to calculate number-weighted fall speeds - DO mgs = 1,ngscnt + real xv(ngs,lc:lhab) + real qx(ngs,lv:lhab) + real qxw(ngs,ls:lhab) + real cx(ngs,lc:lhab) + real vtxbar(ngs,lc:lhab,3) + real xmas(ngs,lc:lhab) + real xdn(ngs,lc:lhab) + real xdia(ngs,lc:lhab,3) + real xvmn0(lc:lhab), xvmx0(lc:lhab) + real qxmin(lc:lhab) + real cdx(lc:lhab) + real alpha(ngs,lc:lhab) - kp1 = Min(nz, kgs(mgs)+1 ) - wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & - & +w(igs(mgs),jgs,kgs(mgs))) - wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & - & +w(igs(mgs),jgs,Max(1,kgs(mgs)-1))) - - ssat0(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) - ssf(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) + real rho0(ngs),rhovt(ngs),temcg(ngs) + real cno(lc:lhab) + real cnostmp(ngs) - ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) - ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) - - - ENDDO + real cwc1, cimna, cimxa + real cnina(ngs) + integer kgs(ngs) + real fadvisc(ngs) + real fsw + + integer ipconc1 + integer ndebug1 + + integer, intent (in) :: itype1a,itype2a,infdo + integer, intent (in) :: ildo ! which species to do, or all if ildo=0 + real :: axh(ngs),bxh(ngs) + real :: axhl(ngs),bxhl(ngs) + +! Local vars + + + + real cd + real cwc0 ! ,cwc1 + real :: cwch(ngscnt), cwchl(ngscnt) + real :: cwchtmp,cwchltmp,xnutmp + real pii + real cimasx,cimasn + real cwmasn,cwmasx,cwradn + real cwrad + real vr,rnux + real alp + + real ccimx + + integer mgs + + real arx,frx,vtrain,fw + real fwlo,fwhi,rfwdiff + real ar,br,cs,ds +! real gf4p5, gf4ds, gf4br, ifirst, gf1ds +! real gfcinu1, gfcinu1p47, gfcinu2p47 + real gr + real rwrad,rwdia + real mwfac + integer il + +! save gf4p5, gf4ds, gf4br, ifirst, gf1ds +! save gfcinu1, gfcinu1p47, gfcinu2p47 +! data ifirst /0/ + + real bta1,cnit + parameter ( bta1 = 0.6, cnit = 1.0e-02 ) + real x,y,tmp,del + real aax,bbx,delrho + integer :: indxr + real mwt + real, parameter :: rho00 = 1.225 + integer i + real xvbarmax + + integer l1, l2 ! -! cloud water variables +! set values ! +! cwmasn = 5.23e-13 ! radius of 5.0e-6 +! cwradn = 5.0e-6 +! cwmasx = 5.25e-10 ! radius of 50.0e-6 - if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables' + fwlo = 0.2 ! water fraction to start weighting toward rain fall speed + fwhi = 0.4 ! water fraction at which rain fall speed only is used + rfwdiff = 1./(fwhi - fwlo) + +! pi = 4.0*atan(1.0) + pii = piinv ! 1.0/pi + + arx = 10. + frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + + ar = 841.99666 + br = 0.8 + gr = 9.8 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab + ELSE + l1 = ildo + l2 = ildo + ENDIF + +! IF ( ifirst .eq. 0 ) THEN +! ifirst = 1 +! gf4br = gamma(4.0+br) +! gf4ds = gamma(4.0+ds) +!! gf1ds = gamma(1.0+ds) +! gf4p5 = gamma(4.0+0.5) +! gfcinu1 = gamma(cinu + 1.0) +! gfcinu1p47 = gamma(cinu + 1.47167) +! gfcinu2p47 = gamma(cinu + 2.47167) + + IF ( lh .gt. 1 ) THEN + IF ( dmuh == 1.0 ) THEN + cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) + ELSE + cwchtmp = 6.0*pii*gamma( (xnu(lh) + 1.)/xmu(lh) )/gamma( (xnu(lh) + 2.)/xmu(lh) ) + ENDIF + ENDIF + IF ( lhl .gt. 1 ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) + ELSE + cwchltmp = 6.0*pii*gamma( (xnu(lhl) + 1)/xmu(lhl) )/gamma( (xnu(lhl) + 2)/xmu(lhl) ) + ENDIF + ENDIF + + IF ( ipconc .le. 5 ) THEN + IF ( lh .gt. 1 ) cwch(:) = cwchtmp + IF ( lhl .gt. 1 ) cwchl(:) = cwchltmp + ELSE + DO mgs = 1,ngscnt + + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( dmuh == 1.0 ) THEN + cwch(mgs) = ((3. + alpha(mgs,lh))*(2. + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lh) - 2.0)/3.0 + cwch(mgs) = 6.0*pii*gamma( (xnutmp + 1.)/xmu(lh) )/gamma( (xnutmp + 2.)/xmu(lh) ) + ENDIF + ELSE + cwch(mgs) = cwchtmp + ENDIF + ENDIF + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( dmuhl == 1.0 ) THEN + cwchl(mgs) = ((3. + alpha(mgs,lhl))*(2. + alpha(mgs,lhl))*(1.0 + alpha(mgs,lhl)))**(-1./3.) + ELSE + xnutmp = (alpha(mgs,lhl) - 2.0)/3.0 + cwchl(mgs) = 6.0*pii*gamma( (xnutmp + 1)/xmu(lhl) )/gamma( (xnutmp + 2)/xmu(lhl) ) + ENDIF + ELSE + cwchl(mgs) = cwchltmp + ENDIF + ENDIF + + ENDDO + + ENDIF + + + cimasn = Min( cimas0, 6.88e-13) + cimasx = 1.0e-8 + ccimx = 5000.0e3 ! max of 5000 per liter + + cwc1 = 6.0/(pi*1000.) + cwc0 = pii ! 6.0*pii + mwfac = 6.0**(1./3.) + + + if (ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set scale diameter' +! + +! +! cloud water variables +! ################################################################ +! +! DROPLETS +! +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cloud water variables' + + IF ( ildo == 0 .or. ildo == lc ) THEN + do mgs = 1,ngscnt xv(mgs,lc) = 0.0 - IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN - xmas(mgs,lc) = & + + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN !{ + + IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e-9 ) THEN !{ + xmas(mgs,lc) = & & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) ELSE - IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN - xmas(mgs,lc) = & + IF ( ipconc .lt. 2 ) THEN + cx(mgs,lc) = rho0(mgs)*ccn/rho00 ! scales to local density, relative to standard air density + ENDIF + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN !{ + xmas(mgs,lc) = & & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & & xdn(mgs,lc)*xvmx(lc) ) - + + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) - + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) - + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE xmas(mgs,lc) = cwmasn - ENDIF + xv(mgs,lc) = xmas(mgs,lc)/1000. +! do not define ccw here! it can feed back to ccn!!! cx(mgs,lc) = 0.0 ! cwnc(mgs) + ENDIF !} + ENDIF !} +! IF ( ipconc .lt. 2 ) THEN +! xmas(mgs,lc) = & +! & min( max(qx(mgs,lc)*rho0(mgs)/cwnc(mgs),cwmasn),cwmasx ) +! cx(mgs,lc) = Max(1.0,qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)) +! ELSE +! cwnc(mgs) = an(igs(mgs),jgs,kgs(mgs),lnc) +! cx(mgs,lc) = cwnc(mgs) +! ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**(1./3.) + xdia(mgs,lc,2) = xdia(mgs,lc,1)**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + cwrad = 0.5*xdia(mgs,lc,1) + IF ( fadvisc(mgs) > 0.0 ) THEN + vtxbar(mgs,lc,1) = & + & (2.0*gr*xdn(mgs,lc) *(cwrad**2)) & + & /(9.0*fadvisc(mgs)) + ELSE + vtxbar(mgs,lc,1) = 0.0 ENDIF - xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 - + + ELSE + xmas(mgs,lc) = cwmasn + IF ( ipconc .le. 1 ) cx(mgs,lc) = 0.01 + xdia(mgs,lc,1) = 2.*cwradn + xdia(mgs,lc,2) = 4.*cwradn**2 + xdia(mgs,lc,3) = xdia(mgs,lc,1) + vtxbar(mgs,lc,1) = 0.0 + + ENDIF !} qcw .gt. qxmin(lc) + end do + + ENDIF + + + ! -! rain +! cloud ice variables +! columns ! +! ################################################################ +! +! CLOUD ICE +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cip' + + IF ( li .gt. 1 .and. ( ildo == 0 .or. ildo == li ) ) THEN do mgs = 1,ngscnt - if ( qx(mgs,lr) .gt. qxmin(lr) ) then + xdn(mgs,li) = 900.0 + IF ( ipconc .eq. 0 ) THEN +! cx(mgs,li) = min(cnit*exp(-temcg(mgs)*bta1),1.e+09) + cx(mgs,li) = cnina(mgs) + IF ( cimna .gt. 1.0 ) THEN + cx(mgs,li) = Max(cimna,cx(mgs,li)) + ENDIF + IF ( cimxa .gt. 1.0 ) THEN + cx(mgs,li) = Min(cimxa,cx(mgs,li)) + ENDIF +! erm 3/28/2002 + IF ( itype1a .ge. 1 .or. itype2a .ge. 1 ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) + ENDIF +! + cx(mgs,li) = max(1.0e-20,cx(mgs,li)) +! cx(mgs,li) = Min(ccimx, cx(mgs,li)) - if ( ipconc .ge. 3 ) then - xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-9,cx(mgs,lr))) -! parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 ) ! mks - IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN - xv(mgs,lr) = xvmx(lr) - cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + + ELSEIF ( ipconc .ge. 1 ) THEN + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) + cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) +! cx(mgs,li) = Max(1.0,cx(mgs,li)) + ENDIF + ENDIF + + IF ( qx(mgs,li) .gt. qxmin(li) ) THEN + xmas(mgs,li) = & + & max( qx(mgs,li)*rho0(mgs)/cx(mgs,li), cimasn ) +! & min( max(qx(mgs,li)*rho0(mgs)/cx(mgs,li),cimasn),cimasx ) + +! if ( temcg(mgs) .gt. 0.0 ) then +! xdia(mgs,li,1) = 0.0 +! else + if ( xmas(mgs,li) .gt. 0.0 ) THEN ! cimasn ) then +!c xdia(mgs,li,1) = 0.4892*(xmas(mgs,li)**(0.4554)) +! xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + +! xdia(mgs,li,1) = (132.694*5.40662/xmas(mgs,li))**(-1./2.9163) ! for inverse exponential distribution + IF ( ixtaltype == 1 ) THEN ! column + xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) + xdia(mgs,li,3) = 0.1871*(xmas(mgs,li)**(0.3429)) + ELSEIF ( ixtaltype == 2 ) THEN ! disk + xdia(mgs,li,1) = 0.277823*xmas(mgs,li)**0.359971 + xdia(mgs,li,3) = 0.277823*xmas(mgs,li)**0.359971 + ENDIF + end if +! end if +! xdia(mgs,li,1) = max(xdia(mgs,li,1), 5.e-6) +! xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + + IF ( ipconc .ge. 0 ) THEN +! vtxbar(mgs,li,1) = rhovt(mgs)*49420.*40.0005/5.40662*xdia(mgs,li,1)**(1.415) ! mass-weighted +! vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + IF ( ixtaltype == 1 ) THEN ! column + tmp = (67056.6300748612*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p47 + vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + ELSEIF ( ixtaltype == 2 ) THEN ! disk -- but just use column fall speed for now + tmp = (67056.6300748612*rhovt(mgs))/ & + & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1) + vtxbar(mgs,li,2) = tmp*gfcinu1p47 + vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu) + vtxbar(mgs,li,3) = vtxbar(mgs,li,1) + + ENDIF +! vtxbar(mgs,li,1) = vtxbar(mgs,li,2)*(1.+cinu)/(1. + cinu) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) +! xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 +! vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + ELSE + xdia(mgs,li,1) = max(xdia(mgs,li,1), 10.e-6) + xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) + vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) +! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) + xdn(mgs,li) = 900.0 + xdia(mgs,li,2) = xdia(mgs,li,1)**2 + vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) + xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) + ENDIF ! ipconc gt 3 + ELSE + xmas(mgs,li) = 1.e-13 + xdn(mgs,li) = 900.0 + xdia(mgs,li,1) = 1.e-7 + xdia(mgs,li,2) = (1.e-14) + xdia(mgs,li,3) = 1.e-7 + vtxbar(mgs,li,1) = 0.0 +! cicap(mgs) = 0.0 +! ciat(mgs) = 0.0 + ENDIF + end do + + ENDIF ! li .gt. 1 + + +! ################################################################ +! +! RAIN +! + +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + +! IF ( qx(mgs,lr) .gt. 10.0e-3 ) & +! & write(0,*) 'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr) + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) + xvbarmax = xvmx(lr) + IF ( imaxdiaopt == 1 ) THEN + xvbarmax = xvmx(lr) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + IF ( imurain == 1 ) THEN + xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) + ELSEIF ( imurain == 3 ) THEN + + ENDIF + ENDIF + + IF ( xv(mgs,lr) .gt. xvbarmax ) THEN + xv(mgs,lr) = xvbarmax + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*xdn(mgs,lr)) ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN xv(mgs,lr) = xvmn(lr) cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) ENDIF + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) IF ( imurain == 3 ) THEN ! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) ELSE ! imurain == 1, Characteristic diameter (1/lambda) - xdia(mgs,lr,1) = (6.*piinv*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) ENDIF ! rwrad(mgs) = 0.5*xdia(mgs,lr,1) ! Inverse exponential version: ! xdia(mgs,lr,1) = -! > (qx(mgs,lr)*rho0(mgs) -! > /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) +! & (qx(mgs,lr)*rho0(mgs) +! & /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) ELSE xdia(mgs,lr,1) = & - & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) + cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) end if else xdia(mgs,lr,1) = 1.e-9 + xdia(mgs,lr,3) = 1.e-9 + xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 ! rwrad(mgs) = 0.5*xdia(mgs,lr,1) end if - + xdia(mgs,lr,2) = xdia(mgs,lr,1)**2 +! xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 end do - - + + ENDIF +! ################################################################ +! +! SNOW ! -! Ventilation coefficients - - do mgs = 1,ngscnt - - fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & - & (temg(mgs)/296.0)**(1.5) + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + if ( ipconc .ge. 4 ) then ! - fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) +! parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 ) ! mks + xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls) - fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & - & (101325.0/(pres(mgs))) - - fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) + IF ( xv(mgs,ls) .lt. xvmn(ls) .or. xv(mgs,ls) .gt. xvmx(ls) ) THEN + xv(mgs,ls) = Min( xvmx(ls), Max( xvmn(ls),xv(mgs,ls) ) ) + xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls) + cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + ENDIF - fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + xdia(mgs,ls,3) = xdia(mgs,ls,1) + ELSE + xdia(mgs,ls,1) = & + & (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25) + cx(mgs,ls) = cnostmp(mgs)*xdia(mgs,ls,1) + xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) + xdia(mgs,ls,3) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) + end if + else + xdia(mgs,ls,1) = 1.e-9 + xdia(mgs,ls,3) = 1.e-9 + cx(mgs,ls) = 0.0 + end if + xdia(mgs,ls,2) = xdia(mgs,ls,1)**2 +! swdia3(mgs) = xdia(mgs,ls,2)*xdia(mgs,ls,1) +! xmas(mgs,ls) = xdn(mgs,ls)*(pi/6.)*swdia3(mgs) end do + + ENDIF ! ls .gt 1 ! ! -! Ziegler nucleation +! ################################################################ ! +! GRAUPEL ! -! cloud evaporation, condensation, and nucleation -! sqsat -> qss(mgs) - DO mgs=1,ngscnt - dcloud = 0.0 - IF ( temg(mgs) .le. tfrh ) THEN + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + if ( ipconc .ge. 5 ) then + xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*Max(1.0e-9,cx(mgs,lh))) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) - CYCLE + IF ( xv(mgs,lh) .lt. xvmn(lh) .or. xv(mgs,lh) .gt. xvmx(lh) ) THEN + xv(mgs,lh) = Min( xvmx(lh), Max( xvmn(lh),xv(mgs,lh) ) ) + xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) + cx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xmas(mgs,lh)) ENDIF - IF( ssat0(mgs) .GT. 0. .OR. ssf(mgs) .GT. 0. ) GO TO 620 -!6/4 IF( qvap(mgs) .EQ. qss(mgs) ) GO TO 631 -! -!.... EVAPORATION. QV IS LESS THAN qss(mgs). -!.... EVAPORATE CLOUD FIRST -! - IF ( qx(mgs,lc) .LE. 0. ) GO TO 631 -!.... CLOUD EVAPORATION. -! convert input 'cp' to cgs - R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ & - & (cp*(temg(mgs) - cbw)**2)) - QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) - + xdia(mgs,lh,3) = (xv(mgs,lh)*6.*pii)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuh == 1.0 ) THEN + xdia(mgs,lh,1) = cwch(mgs)*xdia(mgs,lh,3) + ELSE + xdia(mgs,lh,1) = (xv(mgs,lh)*cwch(mgs))**(1./3.) + ENDIF - IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 - qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) - thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) -! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) - (qx(mgs,lc))/dtp*felv(mgs)/(cp*pi0(mgs)) !* & -!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) - qx(mgs,lc) = 0. - cx(mgs,lc) = 0. ELSE - qwvp(mgs) = qwvp(mgs) + QEVAP - qx(mgs,lc) = qx(mgs,lc) - QEVAP - IF ( qx(mgs,lc) .le. 0. ) cx(mgs,lc) = 0. - thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) -! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) - (qevap)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & -!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + xdia(mgs,lh,1) = & + & (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25) + cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) + xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) + xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if + else + xdia(mgs,lh,1) = 1.e-9 + xdia(mgs,lh,3) = 1.e-9 + end if + xdia(mgs,lh,2) = xdia(mgs,lh,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + ENDIF - GO TO 631 - - - 620 CONTINUE - -!.... CLOUD CONDENSATION - - IF ( qx(mgs,lc) .GT. qxmin(lc) .and. cx(mgs,lc) .ge. 1. ) THEN - - - -! ac1 = xdn(mgs,lc)*elv(kgs(mgs))**2*epsi/ -! : (tka(kgs(mgs))*rw*temg(mgs)**2) -! took out xdn factor because it cancels later... - ac1 = felv(mgs)**2/(tka(mgs)*rw*temg(mgs)**2) - - -! bc = xdn(mgs,lc)*rw*temg(mgs)/ -! : (epsi*wvdf(kgs(mgs))*es(mgs)) -! took out xdn factor because it cancels later... - bc = rw*temg(mgs)/(wvdf(mgs)*es(mgs)) - -! bs = rho0(mgs)*((rd*temg(mgs)/(epsi*es(mgs)))+ -! : (epsi*elv(kgs(mgs))**2/(pres(mgs)*temg(mgs)*cp))) - -! taus = Min(dtp, xdn(mgs,lc)*rho0(mgs)*(ac1+bc)/ -! : (4*pi*0.89298*BS*0.5*xdia(mgs,lc,1)*cx(mgs,lc)*xdn(mgs,lc))) - ! - IF ( ssf(mgs) .gt. 0.0 .or. ssat0(mgs) .gt. 0.0 ) THEN - IF ( ny .le. 2 ) THEN -! write(0,*) 'undershoot: ',ssf(mgs), -! : ( (qx(mgs,lv) - dcloud)/c1 - 1.0)*100. - ENDIF +! ################################################################ +! +! HAIL +! + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then + if ( ipconc .ge. 5 ) then + xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*Max(1.0e-9,cx(mgs,lhl))) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xmas(mgs,lhl),qx(mgs,lhl) - IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + IF ( xv(mgs,lhl) .lt. xvmn(lhl) .or. xv(mgs,lhl) .gt. xvmx(lhl) ) THEN + xv(mgs,lhl) = Min( xvmx(lhl), Max( xvmn(lhl),xv(mgs,lhl) ) ) + xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) + cx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xmas(mgs,lhl)) + ENDIF - IF ( xdia(mgs,lc,1) .le. 0.0 ) THEN - xmas(mgs,lc) = cwmasn - xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) + IF ( dmuhl == 1.0 ) THEN + xdia(mgs,lhl,1) = cwchl(mgs)*xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = (xv(mgs,lhl)*cwchl(mgs))**(1./3.) ENDIF - d1 = (1./(ac1 + bc))*4.0*pi*ventc & - & *0.5*xdia(mgs,lc,1)*cx(mgs,lc)*rhoinv(mgs) - - ELSE - d1 = 0.0 - ENDIF - - IF ( rcond .eq. 2 .and. qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > 1.e-9 ) THEN - IF ( imurain == 3 ) THEN - IF ( izwisventr == 1 ) THEN - rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) - ELSE ! izwisventr = 2 -! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier's rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br - rwvent(mgs) = & - & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & - & *Sqrt((ar*rhovt(mgs))) & - & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) - ENDIF - - ELSE ! imurain == 1 - - IF ( iferwisventr == 1 ) THEN - alpr = Min(alpharmax,alpha(mgs,lr) ) -! alpr = alpha(mgs,lr) - x = 1. + alpr - - tmp = 1 + alpr - i = Int(dgami*(tmp)) - del = tmp - dgam*i - g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - - tmp = 2.5 + alpr + 0.5*bx(lr) - i = Int(dgami*(tmp)) - del = tmp - dgam*i - y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions - - vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) - vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) +! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xdia(mgs,lhl,3) + ELSE + xdia(mgs,lhl,1) = & + & (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25) + cx(mgs,lhl) = cno(lhl)*xdia(mgs,lhl,1) + xv(mgs,lhl) = Max(xvmn(lhl), rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ) + xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) + end if + else + xdia(mgs,lhl,1) = 1.e-9 + xdia(mgs,lhl,3) = 1.e-9 + end if + xdia(mgs,lhl,2) = xdia(mgs,lhl,1)**2 +! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) +! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + end do + + ENDIF +! +! +! +! Set terminal velocities... +! also set drag coefficients (moved to start of subroutine) +! +! cdx(lr) = 0.60 +! cdx(lh) = 0.45 +! cdx(lhl) = 0.45 +! cdx(lf) = 0.45 +! cdx(lgh) = 0.60 +! cdx(lgm) = 0.80 +! cdx(lgl) = 0.80 +! cdx(lir) = 2.00 +! + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set terminal velocities' +! +! +! ################################################################ +! +! RAIN +! + IF ( ildo == 0 .or. ildo == lr ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + IF ( ipconc .lt. 3 ) THEN + vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs) +! write(91,*) 'vtxbar: ',vtxbar(mgs,lr,1),mgs,gf4br,xdia(mgs,lr,1),rhovt(mgs) + ELSE + + IF ( imurain == 1 ) THEN ! DSD of Diameter - rwvent(mgs) = & - & 0.78*x + & - & 0.308*fvent(mgs)*y* & - & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + ! using functional form of arx*(1 - Exp(-frx*diameter) ), with arx = arx = 10. + ! and frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. - ELSEIF ( iferwisventr == 2 ) THEN + + alp = alpha(mgs,lr) -! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier's rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br - x = 1. + alpha(mgs,lr) - - rwvent(mgs) = & - & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & - & *Sqrt((ar*rhovt(mgs))) & - & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) - + vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted - ENDIF ! iferwisventr + IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ! number weighted + ELSE + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF - ENDIF ! imurain - - d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & - & *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs) - ELSE - d1r = 0.0 - ENDIF - - - e1 = felvcp(mgs)/(pi0(mgs)) - f1 = pk(mgs) ! (pres(mgs)/poo)**cap - -! -! fifth trial to see what happens: -! - ltemq = (temg(mgs)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) - ltemq1 = ltemq - temp1 = temg(mgs) - p380 = 380.0/pres(mgs) - -! taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) ) -! nc = NInt(dtp/Min(1.0,0.5*taus)) -! dtcon = dtp/float(nc) - ss1 = qx(mgs,lv)/qvs(mgs) - ss2 = ss1 - temp2 = temp1 - qv1 = qx(mgs,lv) - qvs1 = qvs(mgs) - qis1 = qis(mgs) - dt1 = 0.0 + IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN + vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ! z-weighted + ELSE + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + +! write(91,*) 'setvt: alp,vn,vm,vz = ',alp,vtxbar(mgs,lr,2), vtxbar(mgs,lr,1), vtxbar(mgs,lr,3),alpha(mgs,lr) + ELSEIF ( imurain == 3 ) THEN ! DSD of Volume + + IF ( lzr < 1 ) THEN ! not 3-moment rain + rwdia = Min( xdia(mgs,lr,1), 8.0e-3 ) + + vtxbar(mgs,lr,1) = rhovt(mgs)*6.0*pii*( 0.04771 + 3788.0*rwdia - & + & 1.105e6*rwdia**2 + 1.412e8*rwdia**3 - 6.527e9*rwdia**4) + + IF ( infdo .ge. 1 ) THEN + vtxbar(mgs,lr,2) = (0.09112 + 2714.0*rwdia - 4.872e5*rwdia**2 + & + & 4.495e7*rwdia**3 - 1.626e9*rwdia**4)*rhovt(mgs) + ENDIF + + IF ( infdo .ge. 2 ) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)*( & + & 0.0911229 + & + & 9246.494*(rwdia) - & + & 3.2839926e6*(rwdia**2) + & + & 4.944093e8*(rwdia**3) - & + & 2.631718e10*(rwdia**4) ) + ENDIF + + ELSE ! 3-moment rain, gamma-volume -! dtcon = Max(dtcon,0.2) -! nc = Nint(dtp/dtcon) + vr = xv(mgs,lr) + rnux = alpha(mgs,lr) + + IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag + vtxbar(mgs,lr,2) = rhovt(mgs)* & + & (((1. + rnux)/vr)**(-1.333333)* & + & (0.0911229*((1. + rnux)/vr)**1.333333*Gamma(1. + rnux) + & + & (5430.3131*(1. + rnux)*Gamma(4./3. + rnux))/ & + & vr - 1.0732802e6*((1. + rnux)/vr)**0.6666667* & + & Gamma(1.666667 + rnux) + & + & 8.584110982429507e7*((1. + rnux)/vr)**(1./3.)* & + & Gamma(2. + rnux) - & + & 2.3303765697228556e9*Gamma(7./3. + rnux)))/ & + & Gamma(1. + rnux) + ENDIF - ltemq1 = ltemq -! want to start out with a small time step to handle the steep slope -! and fast changes, then can switch to a larger step (dtcon2) for the -! rest of the big time step. -! base the initial time step (dtcon1) on the slope (delta) - IF ( Abs(ss1 - 1.0) .gt. 1.e-5 ) THEN - delta = 0.5*(qv1-qvs1)/(d1*(ss1 - 1.0)) - ELSE - delta = 0.1*dtp - ENDIF -! delta is the extrapolated time to get halfway from qv1 to qvs1 -! want at least 5 time steps to the halfway point, so multiply by 0.2 -! for the initial time step - dtcon1 = Min(0.05,0.2*delta) - nc = Max(5,2*NInt( (dtp-4.0*dtcon1)/delta)) - dtcon2 = (dtp-4.0*dtcon1)/nc - - n = 1 - dt1 = 0.0 - nc = 0 - dqc = 0.0 - dqr = 0.0 - dqi = 0.0 - dqs = 0.0 - - RK2c: DO WHILE ( dt1 .lt. dtp ) - nc = 0 - IF ( n .le. 4 ) THEN - dtcon = dtcon1 - ELSE - dtcon = dtcon2 - ENDIF - 609 dqv = -(ss1 - 1.)*d1*dtcon - dqvr = -(ss1 - 1.)*d1r*dtcon - dtemp = -0.5*e1*f1*(dqv + dqvr) -! write(0,*) 'RK2c dqv1 = ',dqv -! calculate midpoint values: - ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5) - IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN - write(0,*) 'STOP in icezvd_dr line 3790 ' - write(0,*) ' ltemq1m,icond = ',ltemq1m,icond - write(0,*) ' dtemp,e1,f1,dqv,dqvr = ', dtemp,e1,f1,dqv,dqvr - write(0,*) ' d1,d1r,dtcon,ss1 = ',d1,d1r,dtcon,ss1 - write(0,*) ' dqc, dqr = ',dqc,dqr - write(0,*) ' qv,qc,qr = ',qx(mgs,lv)*1000.,qx(mgs,lc)*1000.,qx(mgs,lr)*1000. - write(0,*) ' i, j, k = ',igs(mgs),jy,kgs(mgs) - write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta - write(0,*) ' nc,dtp = ',nc,dtp - write(0,*) ' rwvent,xdia,crw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr) - write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr) - write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1 - ENDIF - dqvs = dtemp*p380*dtabqvs(ltemq1m) - qv1m = qv1 + dqv + dqvr -! qv1mr = qv1r + dqvr - - qvs1m = qvs1 + dqvs - ss1m = qv1m/qvs1m - - ! check for undersaturation when no ice is present, if so, then reduce time step - IF ( ss1m .lt. 1. .and. (dqvii + dqvis) .eq. 0.0 ) THEN - dtcon = (0.5*dtcon) - IF ( dtcon .ge. dtcon1 ) THEN - GOTO 609 - ELSE - EXIT - ENDIF - ENDIF -! calculate full step: - dqv = -(ss1m - 1.)*d1*dtcon - dqvr = -(ss1m - 1.)*d1r*dtcon - - -! write(0,*) 'RK2a dqv1m = ',dqv - dtemp = -e1*f1*(dqv + dqvr) - ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5) - IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN - write(0,*) 'STOP in icezvd_dr line 3856 ' - write(0,*) ' ltemq1m,icond = ',ltemq1m,icond - write(0,*) ' dtemp,e1,dqv,dqvr = ', dtemp,e1,dqv,dqvr - ENDIF - dqvs = dtemp*p380*dtabqvs(ltemq1) - - qv1 = qv1 + dqv + dqvr - - dqc = dqc - dqv - dqr = dqr - dqvr - - qvs1 = qvs1 + dqvs - ss1 = qv1/qvs1 - temp1 = temp1 + dtemp - IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or. & - & ss1 .eq. 1.00 .or. & - & ( n .gt. 10 .and. ss1 .lt. 1.0005 ) ) THEN -! write(0,*) 'RK2c break' - EXIT - ELSE - ss2 = ss1 - temp2 = temp1 - dt1 = dt1 + dtcon - n = n + 1 - ENDIF - ENDDO RK2c - - - dcloud = dqc ! qx(mgs,lv) - qv1 - thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr) - qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr) - qx(mgs,lc) = qx(mgs,lc) + DCLOUD - qx(mgs,lr) = qx(mgs,lr) + dqr -! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD + dqr)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & -!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) - - - theta(mgs) = thetap(mgs) + theta0(mgs) - temg(mgs) = theta(mgs)*f1 - ltemq = (temg(mgs)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - es(mgs) = 6.1078e2*tabqvs(ltemq) +! mass-weighted + vtxbar(mgs,lr,1) = rhovt(mgs)* & + & (0.0911229*(1 + rnux)**1.3333333333333333*Gamma(2. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma(2.333333333333333 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666*vr**0.6666666666666666* & + & Gamma(2.6666666666666667 + rnux) + & + & 8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma(3 + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma(3.333333333333333 + rnux))/ & + & ((1 + rnux)**2.333333333333333*Gamma(1 + rnux)) + + IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted + vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) + ENDIF + + IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed + vtxbar(mgs,lr,3) = rhovt(mgs)* & + & ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma(3. + rnux) + & + & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & + & Gamma(3.3333333333333335 + rnux) - & + & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666* & + & vr**0.6666666666666666*Gamma(3.6666666666666665 + rnux) + & + & 8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*Gamma(4. + rnux) - & + & 2.3303765697228556e9*vr**1.3333333333333333* & + & Gamma(4.333333333333333 + rnux)))/ & + & ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma(1 + rnux)) + +! write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) + + ELSEIF (infdo .ge. 2) THEN ! No size-sorting, set Z-weighted fall speed to mass-weighted + vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) + ENDIF + + + ENDIF + ENDIF ! imurain +! IF ( rwrad*mwfac .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,1) = 20.1*Sqrt(100.*rwrad*mwfac)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,1) = 80.0e2*rwrad*rhovt(mgs)*mwfac +! ENDIF +! IF ( rwrad .gt. 6.0e-4 ) THEN +! vtxbar(mgs,lr,2) = 20.1*Sqrt(100.*rwrad)*rhovt(mgs) +! ELSE +! vtxbar(mgs,lr,2) = 80.0e2*rwrad*rhovt(mgs) +! ENDIF + ENDIF ! ipconc + else ! qr < qrmin + vtxbar(mgs,lr,1) = 0.0 + vtxbar(mgs,lr,2) = 0.0 + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set rain vt' + + ENDIF ! - - ENDIF ! dcloud .gt. 0. - - - ELSE ! qc .le. qxmin(lc) - - IF ( ssf(mgs) .gt. 0.0 ) THEN ! .and. ssmax(mgs) .lt. sscb ) THEN - - IF ( iqcinit == 1 ) THEN - - qvs0 = 380.*exp(17.27*(temg(mgs)-273.)/(temg(mgs)- 36.))/pk(mgs) - - dcloud = Max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) ) - - ELSEIF ( iqcinit == 3 ) THEN - R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & - & ((temg(mgs) - cbw)**2)) - DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; - ! this will put mass into qc if qv > sqsat exists +! ################################################################ +! +! SNOW !Zrnic et al. (1993) +! + IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + do mgs = 1,ngscnt + if ( qx(mgs,ls) .gt. qxmin(ls) ) then + IF ( ipconc .ge. 4 ) THEN + if ( mixedphase .and. qsvtmod ) then + else + IF ( isnowfall == 1 ) THEN + ! original (Zrnic et al. 1993) + vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14) + ENDIF - ELSEIF ( iqcinit == 2 ) THEN -! R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ -! : (cp*(temg(mgs) - cbw)**2)) -! DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; - ! this will put mass into qc if qv > sqsat exists - ssmx = ssmxinit - - IF ( ssf(mgs) > ssmx ) THEN - CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & - & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + IF(sssflg == 1) THEN + IF ( isnowfall == 1 ) THEN + vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + ELSEIF ( isnowfall == 2 ) THEN + ! Ferrier: + vtxbar(mgs,ls,1) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14) + ENDIF ELSE - dcloud = 0.0 + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) ENDIF - ENDIF + vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1) + endif ELSE - dcloud = 0.0 + vtxbar(mgs,ls,1) = (cs*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) ENDIF - - thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) - qwvp(mgs) = qwvp(mgs) - DCLOUD - qx(mgs,lc) = qx(mgs,lc) + DCLOUD - -! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD)/dtp*felv(mgs)/(cp*pi0(mgs)) ! * & -!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) - - theta(mgs) = thetap(mgs) + theta0(mgs) - temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap -! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) - ltemq = (temg(mgs)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - es(mgs) = 6.1078e2*tabqvs(ltemq) - -!.... S. TWOMEY (1959) -! Note: get here if there is no previous cloud water and w > 0. - cn(mgs) = 0.0 + else + vtxbar(mgs,ls,1) = 0.0 + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set snow vt' - IF ( ncdebug .ge. 1 ) THEN - write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs) - ENDIF + ENDIF ! ls .gt. 1 +! +! +! ################################################################ +! +! GRAUPEL !Wisner et al. (1972) +! + IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN -! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN - IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN - CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 - IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & - & .and. ncdebug .ge. 1 ) THEN ! .and. kgs(mgs) <= 6 ) THEN - write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & - & wvel(mgs), dcloud*1.e3 - IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ', & - & 1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3, & - & igs(mgs),kgs(mgs),temcg(mgs), & - & 1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc) - ENDIF - IF ( iccwflg .eq. 1 ) THEN - cn(mgs) = Min(cwccn, Max(cn(mgs), & - & rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3))) - ENDIF - ELSE - cn(mgs) = Min(cwccn, & - & rho0(mgs)*dcloud/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3) ) - ENDIF + do mgs = 1,ngscnt + vtxbar(mgs,lh,1) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lh)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axh(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxh(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) - IF ( cn(mgs) .gt. 0.0 ) THEN - IF ( cn(mgs) .gt. ccnc(mgs) ) THEN - cn(mgs) = ccnc(mgs) -! ccnc(mgs) = 0.0 + + ELSE + axh(mgs) = mmgraupvt(indxr,2) + bxh(mgs) = mmgraupvt(indxr,3) + ENDIF + + aax = axh(mgs) + bbx = bxh(mgs) + ENDIF -! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - ccna(mgs) = ccna(mgs) + cn(mgs) - ENDIF - -! write(91,*) 'nuc1: cn, ix, kz = ',cn(mgs),igs(mgs),kgs(mgs),wvel(mgs),cnexp,ccnc(mgs) - - IF( CN(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = CN(mgs) - IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN - cx(mgs,lc) = 0. + + IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN + vtxbar(mgs,lh,1) = (gf4p5/6.0)* & + & Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) / & + & (3.0*cd*rho0(mgs)) ) ELSE - cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn) - ENDIF - - END IF ! qc .gt. 0. - -! ES=EES(PIB(K)*PT) -! SQSAT=EPSI*ES/(PB(K)*1000.-ES) + IF ( icdx /= 6 ) bbx = bx(lh) + tmp = 4. + alpha(mgs,lh) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami -!.... CLOUD NUCLEATION -! T=PIB(K)*PT -! ES=1.E3*PB(K)*QV/EPSI + tmp = 4. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! aax = Max( 1.0, Min(2.0, (xdn(mgs,lh)/400.) ) ) +! vtxbar(mgs,lh,1) = rhovt(mgs)*aax*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + + IF ( icdx > 0 .and. icdx /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y + axh(mgs) = aax + bxh(mgs) = bbx + ELSEIF (icdx == 6 ) THEN + vtxbar(mgs,lh,1) = rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y + ELSE + axh(mgs) = ax(lh) + bxh(mgs) = bx(lh) + vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y + ENDIF - IF ( wvel(mgs) .le. 0. ) GO TO 616 - IF ( cx(mgs,lc) .le. 0. ) GO TO 613 !TWOMEY (1959) Nucleation - IF ( kzbeg-1+kgs(mgs) .GT. 1 .and. qx(mgs,lc) .le. qxmin(lc)) GO TO 613 !TWOMEY (1959) Nucleation - IF ( kzbeg-1+kgs(mgs) .eq. 1 .and. wvel(mgs) .gt. 0. ) GO TO 613 !TWOMEY (1959) Nucleation -!.... ATTEMPT ZIEGLER CLOUD NUCLEATION IN CLOUD INTERIOR UNLESS... - 616 IF ( ssf(mgs) .LE. SUPCB .AND. wvel(mgs) .GT. 0. ) GO TO 631 !... weakly saturated updraft - IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND. & - & (ssfkp1(mgs) .GE. SUPMX .OR. & - & ssf(mgs) .GE. SUPMX .OR. & - & ssfkm1(mgs) .GE. SUPMX)) GO TO 631 !... too much vapour - IF (ssf(mgs) .LT. 1.E-10 .OR. ssf(mgs) .GE. SUPMX) GO TO 631 !... at the extremes for ss +! & Gamma(4.0 + dnu(lh) + 0.6))/Gamma(4. + dnu(lh)) + ENDIF + IF ( lwsm6 .and. ipconc == 0 ) THEN +! vtxbar(mgs,lh,1) = (330.*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) + vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs) + ENDIF + + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lh .gt. 1 ! -! get here if ( qc > 0 and ss > supcb) or (w < 0) ! +! ################################################################ +! +! HAIL +! + IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN + + do mgs = 1,ngscnt + vtxbar(mgs,lhl,1) = 0.0 + if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then - if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" !mpidebug + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lhl)/rho_qh)**(2./3.) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + indxr = Int( (xdn(mgs,lhl)-50.)/100. ) + 1 + indxr = Min( ngdnmm, Max(1,indxr) ) + + + delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) ) + IF ( indxr < ngdnmm ) THEN + + axhl(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) + bxhl(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) - DSSDZ=0. - r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) - IF ( irenuc >= 0 ) THEN + + ELSE + axhl(mgs) = mmgraupvt(indxr,2) + bxhl(mgs) = mmgraupvt(indxr,3) + ENDIF + + aax = axhl(mgs) + bbx = bxhl(mgs) + + ELSE +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) + cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + ENDIF - IF ( irenuc /= 2 ) THEN !{ + IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 .and. icdxhl /= 6) THEN + vtxbar(mgs,lhl,1) = (gf4p5/6.0)* & + & Sqrt( (xdn(mgs,lhl)*xdia(mgs,lhl,1)*4.0*gr) / & + & (3.0*cd*rho0(mgs)) ) + ELSE + IF ( icdxhl /= 6 ) bbx = bx(lhl) + tmp = 4. + alpha(mgs,lhl) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - IF ( kzend == nzend ) THEN - t0p3 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+3)) - t0p1 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+1)) - ELSE - t0p3 = t0(igs(mgs),jgs,kgs(mgs)+3) - t0p1 = t0(igs(mgs),jgs,kgs(mgs)+1) - ENDIF + tmp = 4. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - IF ( ( ssf(mgs) .gt. ssmax(mgs) .or. irenuc .eq. 1 ) & - & .and. ( ( lccn .lt. 1 .and. & - & cx(mgs,lc) .lt. cwccn*(Min(1.0,rho0(mgs)))) .or. & - & ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. ) ) & - & ) THEN - IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & - & .and. ssf(mgs) .gt. 0.0 & - & .and. ssfkp1(mgs) .LT. SUPMX .and. ssfkp1(mgs) .ge. 0.0 & - & .AND. ssfkm1(mgs) .LT. SUPMX .AND. ssfkm1(mgs) .ge. 0.0 & - & .AND. ssfkp1(mgs) .gt. ssfkm1(mgs) & - & .and. t0p3 .gt. 233.2) THEN - DSSDZ = (ssfkp1(mgs) - ssfkm1(mgs))*R2DZM -! -! otherwise check for cloud base condition with updraft: -! - ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & -! IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 & - & .and. ssf(mgs) .gt. 0.0 .and. wvel(mgs) .gt. 0.0 & - & .and. ssfkp1(mgs) .gt. 0.0 & - & .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 & - & .AND. ssf(mgs) .gt. ssfkm1(mgs) & - & .and. t0p1 .gt. 233.2) THEN - DSSDZ = 2.*(ssf(mgs) - ssfkm1(mgs))*R2DZM ! 1-sided difference + IF ( icdxhl > 0 .and. icdxhl /= 6) THEN + aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y + axhl(mgs) = aax + bxhl(mgs) = bbx + ELSEIF ( icdxhl == 6 ) THEN + vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y + ELSE + axhl(mgs) = ax(lhl) + bxhl(mgs) = bx(lhl) + vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y ENDIF - - ENDIF -! -!CLZ IF(wijk.LE.0.) CN=CCN*ssfilt(ix,jy,kz)**CCK -! note: CCN -> cwccn, DELT -> dtp - c1 = Max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ & - & (xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)) - IF ( lccn .lt. 1 ) THEN - CN(mgs) = cwccn*CCK*ssf(mgs)**CCKM*dtp* & - & Max(0.0, & - & (wvel(mgs)*DSSDZ) ) ! probably the vertical gradient dominates - ELSE - CN(mgs) = & - & Min(ccnc(mgs), cnuc(mgs)*CCK*ssf(mgs)**CCKM*dtp* & - & Max(0.0, & - & ( wvel(mgs)*DSSDZ) ) ) -! IF ( cn(mgs) .gt. 0 ) ccnc(mgs) = ccnc(mgs) - cn(mgs) + +! & Gamma(4.0 + dnu(lh) + 0.6))/Gamma(4. + dnu(lh)) ENDIF - IF ( cn(mgs) .gt. 0.0 ) THEN - IF ( ccnc(mgs) .lt. 5.e7 .and. cn(mgs) .ge. 5.e7 ) THEN - cn(mgs) = 5.e7 - ccnc(mgs) = 0.0 - ELSEIF ( cn(mgs) .gt. ccnc(mgs) ) THEN - cn(mgs) = ccnc(mgs) - ccnc(mgs) = 0.0 - ENDIF - cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - ENDIF - ELSEIF ( irenuc == 2 ) THEN !} { - ! simple Twomey scheme - CN(mgs) = CCNE*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 -!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) - CN(mgs) = Min(cn(mgs), ccnc(mgs)) - - cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - - ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) - - ENDIF ! } + end if + end do + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' + + ENDIF ! lhl .gt. 1 - ccna(mgs) = ccna(mgs) + cn(mgs) - ENDIF ! irenuc >= 0 + IF ( infdo .ge. 1 ) THEN - IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. - GO TO 631 -!.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT +! DO il = lc,lhab +! IF ( il .ne. lr ) THEN + DO mgs = 1,ngscnt + vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) + IF ( li .gt. 1 ) THEN +! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) +! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) - 613 CONTINUE +! test print stuff... +! IF ( xdia(mgs,li,1) .gt. 200.e-6 ) THEN +! tmp = (xv(mgs,li)*cwc0)**(1./3.) +! x = rhovt(mgs)*49420.*40.0005/5.40662*tmp**(1.415) +! y = rhovt(mgs)*49420.*1.25447*tmp**(1.415) +! write(6,*) 'Ice fall: ',vtxbar(mgs,li,1),x,y,tmp,xdia(mgs,li,1) +! ENDIF + ENDIF +! vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + ENDDO - 631 CONTINUE + IF ( lg .gt. lr ) THEN -! -! Check for supersaturation greater than ssmx and adjust down -! - ssmx = 1.1 - qv1 = qv0(mgs) + qwvp(mgs) - qvs1 = qvs(mgs) + DO il = lg,lhab + IF ( ildo == 0 .or. ildo == il ) THEN - IF ( qv1 .gt. (ssmx*qvs1) ) THEN - - ss1 = qv1/qvs1 + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .gt. qxmin(il) ) THEN + IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN ! DTD: added flag for size-sorting + + ! DTD: allow for setting of number-weighted and z-weighted fall speeds to the mass-weighted value, + ! effectively turning off size-sorting - ssmx = 100.*(ssmx - 1.0) + IF ( il .eq. lh ) THEN ! { + + IF ( icdx .eq. 1 ) THEN + cd = cdx(lh) + ELSEIF ( icdx .eq. 2 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) + cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) +! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdx .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hdnmn, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdx .eq. 4 ) THEN + cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & + & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) + ELSEIF ( icdx .eq. 5 ) THEN + cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2./3.) + ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axh(mgs) + bbx = bxh(mgs) + ENDIF + + ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN + + IF ( icdxhl .eq. 1 ) THEN + cd = cdx(lhl) + ELSEIF ( icdxhl .eq. 3 ) THEN +! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) + cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( hldnmn, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) + ELSEIF ( icdxhl .eq. 4 ) THEN + cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & + & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) + ELSEIF ( icdxhl == 5 ) THEN +! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) +! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) + cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) + ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) + aax = axhl(mgs) + bbx = bxhl(mgs) + ENDIF + + ENDIF ! } - CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, & - & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and. & + ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! { + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cd*rho0(mgs)) ) + ELSE + IF ( il == lh .and. icdx /= 6 ) bbx = bx(il) + IF ( il == lhl .and. icdxhl /= 6 ) bbx = bx(il) + tmp = 1. + alpha(mgs,il) + bbx + i = Int(dgami*(tmp)) + del = tmp - dgam*i + x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 1. + alpha(mgs,il) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + IF ( il .eq. lh .or. il .eq. lhl) THEN ! { + IF ( ( il==lh .and. icdx > 0 ) ) THEN + IF ( icdx /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**0.5 * x/y + ELSE ! (icdx == 6 ) THEN + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF +! ELSE +! aax = ax(il) +! vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y +! ENDIF - IF ( qvex .gt. 0.0 ) THEN - thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + ELSEIF ( ( il==lhl .and. icdxhl > 0 ) ) THEN + IF ( icdxhl /= 6 ) THEN + aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**0.5 * x/y + ELSE ! ( icdxhl == 6 ) + vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y + ENDIF + ELSE + aax = ax(il) + vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y + ENDIF -! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (qvex)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & -!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* & +! & x)/y +! vtxbar(mgs,il,2) = & +! & rhovt(mgs)*(xdn(mgs,il)/400.)*(ax(il)*xdia(mgs,il,1)**bx(il)* & +! & x)/y + IF ( infdo .ge. 2 ) THEN ! Z-weighted + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(1.0/xdia(mgs,il,1) )**(- bbx)* & + & Gamma(7.0 + alpha(mgs,il) + bbx))/Gamma(7. + alpha(mgs,il)) +! & (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma(7.0 + alpha(mgs,il) + bx(il)))/Gamma(7. + alpha(mgs,il)) + ENDIF - qwvp(mgs) = qwvp(mgs) - qvex - qx(mgs,lc) = qx(mgs,lc) + qvex - cn(mgs) = Min( ccwmx, qvex/Max( cwmasn5, xmas(mgs,lc) ) ) - ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) - cx(mgs,lc) = cx(mgs,lc) + cn(mgs) - -! write(iunit,*) 'theta = ',theta0(mgs) + thetap(mgs) + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt3' -! temg(mgs) = theta(mgs)*( pres(mgs) / poo ) ** cap + ELSE ! hail + vtxbar(mgs,il,2) = & + & rhovt(mgs)*(ax(il)*xdia(mgs,il,1)**bx(il)* & + & x)/y - ENDIF + IF ( infdo .ge. 2 ) THEN ! Z-weighted + vtxbar(mgs,il,3) = rhovt(mgs)* & + & (aax*(1.0/xdia(mgs,il,1) )**(- bbx)* & + & Gamma(7.0 + alpha(mgs,il) + bbx))/Gamma(7. + alpha(mgs,il)) +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma(7.0 + alpha(mgs,il) + bx(il)))/Gamma(7. + alpha(mgs,il)) + ENDIF - - ENDIF + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt4' -! -! Calculate droplet volume and check if it is within bounds. -! Adjust if necessary -! + ENDIF ! } +! & Gamma(1.0 + dnu(il) + 0.6)/Gamma(1. + dnu(il)) + ENDIF ! } +! IF ( infdo .ge. 2 ) THEN ! Z-weighted +! vtxbar(mgs,il,3) = rhovt(mgs)* & +! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & +! & Gamma(7.0 + alpha(mgs,il) + bx(il)))/Gamma(7. + alpha(mgs,il)) +! ENDIF - cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) - IF ( cx(mgs,lc) .GT. 1.0e7 .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN - xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)) - ENDIF +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'setvt: ',qx(mgs,il),xdia(mgs,il,1),xdia(mgs,il,3),dnu(il),ax(il),bx(il) +! ENDIF + ELSEIF ( (il .eq. lh .and. hssflg == 0) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 0) ) THEN ! no size-sorting for graupel or hail + vtxbar(mgs,il,2) = vtxbar(mgs,il,1) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) + ELSE ! not lh or lhl + vtxbar(mgs,il,2) = & + & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & + & (3.0*cdx(il)*rho0(mgs)) ) + vtxbar(mgs,il,3) = vtxbar(mgs,il,1) - xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx ) - xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn ) + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5' -! IF( cx(mgs,lc) .GT. 10.e6 .AND. qx(mgs,lc) .GT. qxmin(lc) ) GO TO 681 -! ccwtmp = cx(mgs,lc) -! cwmastmp = xmas(mgs,lc) -! xmas(mgs,lc) = Max(xmas(mgs,lc), cwmasn) -! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. cx(mgs,lc) .le. 0.) THEN -! cx(mgs,lc) = Min(0.5*cwccn,rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)) -! xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) -! ENDIF -! IF (cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .GT. qxmin(lc)) & -! & xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) -! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .LT. cwmasn) & -! & xmas(mgs,lc) = cwmasn -! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .GT. cwmasx) & -! & xmas(mgs,lc) = cwmasx -! IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN -! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc)) -! ENDIF - + ENDIF + ELSE ! qx < qxmin + vtxbar(mgs,il,2) = 0.0 - 681 CONTINUE - - IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt6' + + ENDIF + ENDDO ! mgs + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt7' + ENDIF + ENDDO ! il + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt8' + + ENDIF ! lg .gt. 1 - IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr)) & - & xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) - IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr) - IF (xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr) +! ENDIF +! ENDDO - ENDIF + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt9' +! DO mgs = 1,ngscnt +! IF ( qx(mgs,lr) > qxmin(lr) ) THEN +! write(0,*) 'setvt2: mgs,lzr,infdo = ',mgs,lzr,infdo +! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) +! ENDIF +! ENDDO + ENDIF ! infdo .ge. 1 + + if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: END OF ROUTINE' - ENDDO ! mgs +!############ SETVTZ ############################ + RETURN + END SUBROUTINE setvtz +!-------------------------------------------------------------------------- -! ################################################################ - DO mgs=1,ngscnt - IF ( ssf(mgs) .gt. ssmax(mgs) & - & .and. ( idecss .eq. 0 .or. qx(mgs,lc) .gt. qxmin(lc)) ) THEN - ssmax(mgs) = ssf(mgs) - ENDIF - ENDDO ! +! ############################################################################## - do mgs = 1,ngscnt - an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs) - an(igs(mgs),jy,kgs(mgs),lv) = qv0(mgs) + qwvp(mgs) -! tmp3d(igs(mgs),jy,kgs(mgs)) = tmp3d(igs(mgs),jy,kgs(mgs)) + t9(igs(mgs),jy,kgs(mgs)) ! pi0(mgs) ! wvdf(mgs) ! ssf(mgs) ! cn(mgs) +! #include "sam.def.h" ! - if ( ido(lc) .eq. 1 ) then - an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) + & - & min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 ) -! qx(mgs,lc) = an(igs(mgs),jy,kgs(mgs),lc) - end if +! subroutine to calculate fall speeds of hydrometeors ! - if ( ido(lr) .eq. 1 .and. rcond == 2 ) then - an(igs(mgs),jy,kgs(mgs),lr) = qx(mgs,lr) + & - & min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 ) -! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) - end if - - - - IF ( ipconc .ge. 2 ) THEN - an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) - IF ( lccn .gt. 1 ) THEN - an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, Min( ccwmx, ccnc(mgs) ) ) - ENDIF - ENDIF - IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN - an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0) - ENDIF - end do + subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & + & xvt, rhovtzx, & + & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, & + & cwradn, & + & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & + & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & + & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & + & cnostmp, & + & infdo,ildo,timesetvt) +! 12.16.2005: .F version use in transitional SWM model +! +! 10.10.2003: Added cimn and cimx to setting for cci and cip. +! +! TO DO LIST: +! +! need to set up values for: +! : cipdia,cidia,cwdia,cwmas,vtwbar, +! : rho0,temcg,cip,cci +! +! and need to put fallspeed values in cwvt etc. +! + + implicit none + integer ng1 + parameter(ng1 = 1) + + integer, intent(in) :: ixcol ! which column to return + integer, intent(in) :: ildo + + integer nx,ny,nz,nor,norz,ngt,jgs,na + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real dn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) + real dtp,dtz1 + + real :: rhovtzx(nz,nx) + + integer ndebugzf + parameter (ndebugzf = 0) -29998 continue + integer ix,jy,kz,i,j,k,il + integer infdo +! +! + real xvt(nz+1,nx,3,lc:lhab) ! 1=mass-weighted, 2=number-weighted + real qxmin(lc:lhab) + real xdn0(lc:lhab) + real xvmn(lc:lhab), xvmx(lc:lhab) + double precision,optional :: timesetvt - if ( kz .gt. nz-1 .and. ix .ge. nx) then - if ( ix .ge. nx ) then - go to 2200 ! exit gather scatter - else - nzmpb = kz - endif - else - nzmpb = kz - end if + integer :: ngs + integer :: ngscnt,mgs,ipconc0 +! parameter ( ngs=200 ) + + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: vx(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) +!#ifdef Z3MOM + real :: zx(ngs,lr:lhab) +!#endif - if ( ix .ge. nx ) then - nxmpb = 1 - nzmpb = kz+1 - else - nxmpb = ix+1 - end if + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) - 2000 continue ! inumgs - 2200 continue ! -! end of gather scatter (for this jy slice) - - -! Redistribute inappreciable cloud particles and charge +! drag coefficients ! -! Redistribution everywhere in the domain... + real cdx(lc:lhab) ! - frac = 1.0 ! 0.25 ! 1.0 ! 0.2 +! Fixed intercept values for single moment scheme ! -! alternate test version for ipconc .ge. 3 -! just vaporize stuff to prevent noise in the number concentrations + real cno(lc:lhab) + + real cwccn0,cwmasn,cwmasx,cwradn +! real cwc0 + integer nxmpb,nzmpb,nxz,numgs,inumgs + integer kstag + parameter (kstag=1) - do kz = 1,nz -! do jy = 1,1 - do ix = 1,nx + integer igs(ngs),kgs(ngs) - zerocx(:) = .false. - DO il = lc,lhab - IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) - IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. an(ix,jy,kz,lz(il)) < zxmin ) - ENDDO + real rho0(ngs),temcg(ngs) - IF ( lhl .gt. 1 ) THEN + real temg(ngs) + real rhovt(ngs) - if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then - -! IF ( an(ix,jy,kz,lhl) .gt. 0 ) THEN - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) - an(ix,jy,kz,lhl) = 0.0 -! ENDIF - - IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN - an(ix,jy,kz,lnhl) = 0.0 - ENDIF - - IF ( lvhl .gt. 1 ) THEN - an(ix,jy,kz,lvhl) = 0.0 - ENDIF - - IF ( lhlw .gt. 1 ) THEN - an(ix,jy,kz,lhlw) = 0.0 - ENDIF + real cwnc(ngs),cinc(ngs) + real fadvisc(ngs),cwdia(ngs),cipmas(ngs) - IF ( lzhl .gt. 1 ) THEN - an(ix,jy,kz,lzhl) = 0.0 - ENDIF - - ELSE - IF ( lvol(lhl) .gt. 1 ) THEN ! check density - IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN - tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) - ELSE - tmp = 0.5*( xdnmn(lhl) + xdnmx(lhl) ) - an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp - ENDIF - -! DEBUG -! tmp = 850. -! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp -! IF ( an(ix,jy,kz,lhl) .gt. 1.0e-3 ) THEN -! write(iunit,*) 'HAILdr: dn,q,c,v = ',tmp,an(ix,jy,kz,lhl)*1000., -! : an(ix,jy,kz,lnhl), an(ix,jy,kz,lvhl) -! write(iunit,*) 'lvhl = ',lvhl -! ENDIF +! real cimasn,cimasx, + real :: cnina(ngs),cimas(ngs) + + real :: cnostmp(ngs) +! real pii +! +! +! general constants for microphysics +! - IF ( tmp .gt. xdnmx(lhl) .or. tmp .lt. xdnmn(lhl) ) THEN - tmp = Min( xdnmx(lhl), Max( xdnmn(lhl) , tmp ) ) - an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp - ENDIF - - ENDIF - - -! CHECK INTERCEPT - IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN - - IF ( lvhl .gt. 1 ) THEN - hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) - ELSE - hwdn = xdn0(lhl) - ENDIF - tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl)) - tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.) - IF ( tmpg .lt. cnohlmn ) THEN - tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.) - an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) - ENDIF - - ENDIF -! ELSE ! check mean size here? +! +! Miscellaneous +! + + logical flag + logical ldoliq + + + real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp + + real vtmax + real xvbarmax + + integer l1, l2 + + double precision :: dpt1, dpt2 - end if +!----------------------------------------------------------------------------- +! MPI LOCAL VARIABLES + integer :: ixb, jyb, kzb + integer :: ixe, jye, kze - ENDIF !lhl + logical :: debug_mpi = .false. - if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: ENTERED SUBROUTINE" -! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) - an(ix,jy,kz,lh) = 0.0 -! ENDIF +! ##################################################################### +! BEGIN EXECUTABLE +! ##################################################################### +! - IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN - an(ix,jy,kz,lnh) = 0.0 - ENDIF +! constants +! - IF ( lvh .gt. 1 ) THEN - an(ix,jy,kz,lvh) = 0.0 - ENDIF + ldoliq = .false. + IF ( ls .gt. 1 ) THEN + DO il = ls,lhab + ldoliq = ldoliq .or. ( lliq(il) .gt. 1 ) + ENDDO + ENDIF - IF ( lhw .gt. 1 ) THEN - an(ix,jy,kz,lhw) = 0.0 - ENDIF +! poo = 1.0e+05 +! cp608 = 0.608 +! cp = 1004.0 +! cv = 717.0 +! dnz00 = 1.225 +! rho00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds +! cs = 12.42 +! ds = 0.42 +! pi = 4.0*atan(1.0) +! pii = piinv ! 1./pi +! pid4 = pi/4.0 +! qccrit = 2.0e-03 +! qscrit = 6.0e-04 +! cwc0 = pii - IF ( lzh .gt. 1 ) THEN - an(ix,jy,kz,lzh) = 0.0 - ENDIF +! +! +! general constants for microphysics +! + +! +! ci constants in mks units +! +! cimasn = 6.88e-13 +! cimasx = 1.0e-8 +! +! Set terminal velocities... +! also set drag coefficients +! + jy = jgs + nxmpb = ixcol + nzmpb = 1 + nxz = 1*nz +! ngs = nz + numgs = 1 + IF ( ildo == 0 ) THEN + l1 = lc + l2 = lhab ELSE - IF ( lvol(lh) .gt. 1 ) THEN ! check density - IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN - tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) - ELSE - tmp = rho_qh - an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp - ENDIF - - IF ( tmp .lt. xdnmn(lh) ) THEN - tmp = Max( xdnmn(lh), tmp ) - an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp - ENDIF + l1 = ildo + l2 = ildo + ENDIF - IF ( tmp .gt. xdnmx(lh) .and. lhw .le. 0 ) THEN ! no liquid allowed on graupel - tmp = Min( xdnmx(lh), tmp ) - an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp - ELSEIF ( tmp .gt. xdnmx(lh) .and. lhw .gt. 1 ) THEN ! allow for liquid on graupel - IF ( tmp .gt. xdnmx(lh) .and. an(ix,jy,kz,lhw) .lt. qxmin(lh) ) THEN - tmp = Min( xdnmx(lh), tmp ) - an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp - ELSEIF ( tmp .gt. xdnmx(lr) ) THEN - tmp = xdnmn(lr) - an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp - ENDIF - ENDIF - IF ( lhw .gt. 1 ) THEN ! check if basically pure water - IF ( an(ix,jy,kz,lhw) .gt. 0.98*an(ix,jy,kz,lh) ) THEN - tmp = xdnmx(lr) - an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp - ENDIF - ENDIF - - ENDIF + do inumgs = 1,numgs + ngscnt = 0 -! CHECK INTERCEPT - IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN - - IF ( lvh .gt. 1 ) THEN - IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN - hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) - ELSE - hwdn = xdn0(lh) - ENDIF - hwdn = Max( xdnmn(lh), hwdn ) - ELSE - hwdn = xdn0(lh) - ENDIF - tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh)) - tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.) - IF ( tmpg .lt. cnohmn ) THEN -! tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) -! tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) - tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) - an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.) - ENDIF - - ENDIF - - end if + do kz = nzmpb,nz + do ix = ixcol,ixcol + flag = .false. - if ( an(ix,jy,kz,ls) .lt. frac*qxmin(ls) .or. zerocx(ls) & ! .or. an(ix,jy,kz,lns) .lt. 0.1 ! .and. - & ) then - IF ( t0(ix,jy,kz) .lt. 273.15 ) THEN -! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) - an(ix,jy,kz,ls) = 0.0 -! ENDIF - - IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! -! an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lns) - an(ix,jy,kz,lns) = 0.0 - ENDIF - IF ( lvs .gt. 1 ) THEN - an(ix,jy,kz,lvs) = 0.0 - ENDIF - - IF ( lsw .gt. 1 ) THEN - an(ix,jy,kz,lsw) = 0.0 - ENDIF - - ELSE -! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) - an(ix,jy,kz,ls) = 0.0 -! ENDIF + DO il = l1,l2 + flag = flag .or. ( an(ix,jy,kz,il) .gt. qxmin(il) ) + ENDDO - IF ( lvs .gt. 1 ) THEN - an(ix,jy,kz,lvs) = 0.0 - ENDIF + if ( flag ) then +! load temp quantities - IF ( lsw .gt. 1 ) THEN - an(ix,jy,kz,lsw) = 0.0 - ENDIF + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if +!#ifndef MPI + end do !!ix +!#endif + nxmpb = 1 + end do !! kz - IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! -! an(ix,jy,kz,lnr) = an(ix,jy,kz,lnr) + an(ix,jy,kz,lns) - an(ix,jy,kz,lns) = 0.0 - ENDIF +! if ( jy .eq. (ny-jstag) ) iend = 1 - ENDIF - + 1100 continue - ELSEIF ( lvol(ls) .gt. 1 ) THEN ! check density - IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN - tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) - IF ( tmp .gt. xdnmx(ls) .or. tmp .lt. xdnmn(ls) ) THEN - tmp = Min( xdnmx(ls), Max( xdnmn(ls), tmp ) ) - an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp - ENDIF - ELSE - tmp = rho_qs - an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp - ENDIF + if ( ngscnt .eq. 0 ) go to 9998 +! +! set temporaries for microphysics variables +! - end if +! +! Reconstruct various quantities +! + do mgs = 1,ngscnt + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhovt(mgs) = rhovtzx(kgs(mgs),ixcol) ! Sqrt(rho00/rho0(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr - if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & - & ) then - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) - an(ix,jy,kz,lr) = 0.0 - IF ( ipconc .ge. 3 ) THEN -! an(ix,jy,kz,lnc) = an(ix,jy,kz,lnc) + an(ix,jy,kz,lnr) - an(ix,jy,kz,lnr) = 0.0 - ENDIF - end if - ! -! for qci + end do ! - IF ( an(ix,jy,kz,li) .le. frac*qxmin(li) .or. zerocx(li) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 - & ) THEN - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) - an(ix,jy,kz,li)= 0.0 - IF ( ipconc .ge. 1 ) THEN - an(ix,jy,kz,lni) = 0.0 - ENDIF +! only need fadvisc for + IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) + end do ENDIF -! -! for qcw -! - - IF ( an(ix,jy,kz,lc) .le. frac*qxmin(lc) .or. zerocx(lc) & - & ) THEN - an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) - an(ix,jy,kz,lc)= 0.0 - IF ( ipconc .ge. 2 ) THEN - IF ( lccn .gt. 1 ) THEN - an(ix,jy,kz,lccn) = & - & Min( ccwmx, an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) ) - ENDIF - an(ix,jy,kz,lnc) = 0.0 + IF ( ipconc .eq. 0 ) THEN + do mgs = 1,ngscnt + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + end do + ENDIF - ENDIF + IF ( ildo > 0 ) THEN + vtxbar(:,ildo,:) = 0.0 + ELSE + vtxbar(:,:,:) = 0.0 ENDIF - - end do -! end do - end do +! do mgs = 1,ngscnt +! qx(mgs,lv) = max(an(igs(mgs),jy,kgs(mgs),lv), 0.0) +! ENDDO + DO il = l1,l2 + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO + end do - IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' + cnostmp(:) = cno(ls) + IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF + + ! +! set concentrations ! - - RETURN - END SUBROUTINE NUCOND + cx(:,:) = 0.0 + + if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + end do + end if + if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) +! IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! ELSE +! cx(mgs,lr) = Max( 0.0, cx(mgs,lr) ) +! ENDIF + end do + end if + if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) +! IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! ELSE +! cx(mgs,ls) = Max( 0.0, cx(mgs,ls) ) +! ENDIF + end do + end if -! ##################################################################### -! ##################################################################### + if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then + do mgs = 1,ngscnt - SUBROUTINE QVEXCESS(ngs,mgs,qwvp0,qv0,qcw1,pres,thetap0,theta0, & - & qvex,pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ss1,pk,ngscnt) - -!##################################################################### -! Purpose: find the amount of vapor that can be condensed to liquid -!##################################################################### + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) +! IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! ELSE +! cx(mgs,lh) = Max( 0.0, cx(mgs,lh) ) +! ENDIF - implicit none + end do + ENDIF + + if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then + do mgs = 1,ngscnt + + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) +! IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN +! cx(mgs,lhl) = 0.0 +! ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN +! qx(mgs,lhl) = 0.0 +! ELSE +! cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) ) +! ENDIF + + end do + end if + + do mgs = 1,ngscnt + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) +! IF ( ls .gt. 1 .and. lvs .eq. 0 ) xdn(mgs,ls) = xdn0(ls) +! IF ( lh .gt. 1 .and. lvh .eq. 0 ) xdn(mgs,lh) = xdn0(lh) + IF ( li .gt. 1 ) xdn(mgs,li) = xdn0(li) + IF ( ls .gt. 1 ) xdn(mgs,ls) = xdn0(ls) + IF ( lh .gt. 1 ) xdn(mgs,lh) = xdn0(lh) + IF ( lhl .gt. 1 ) xdn(mgs,lhl) = xdn0(lhl) + end do - integer ngs,mgs,ngscnt - - real theta2temp - - real qvex - - integer nqsat - real fqsat, cbw - - real ss1 ! 'target' supersaturation ! -! input arrays +! Set mean particle volume ! - real qv0(ngs), qcw1(ngscnt), pres(ngs), qwvp0(mgs) - real thetap0(ngs), theta0(ngs) - real fcqv1(ngs), felvcp(ngs), pi0(ngs) - real pk(ngs) + IF ( ldovol .and. (ildo == 0 .or. ildo >= li ) ) THEN - real tabqvs(nqsat) -! -! Local stuff -! + vx(:,:) = 0.0 - integer itertd - integer ltemq - real gamss - real theta(ngs), qvap(ngs), pqs(ngs), qcw(ngs), qwv(ngs) - real qcwtmp(ngs), qss(ngs), qvs(ngs), qwvp(ngs) - real dqcw(ngs), dqwv(ngs), dqvcnd(ngs) - real temg(ngs), temcg(ngs), thetap(ngs) + DO il = l1,l2 + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + IF ( vx(mgs,il) .gt. rho0(mgs)*qxmin(il)*1.e-3 .and. qx(mgs,il) .gt. qxmin(il) ) THEN + xdn(mgs,il) = Min( xdnmx(il), Max( xdnmn(il), rho0(mgs)*qx(mgs,il)/vx(mgs,il) ) ) + ENDIF + ENDDO + + ENDIF - real tfr - parameter ( tfr = 273.15 ) - -! real poo,cap -! parameter ( cap = rd/cp, poo = 1.0e+05 ) -! -! -! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) -! -! -! -! set up temperature and vapor arrays -! - pqs(mgs) = (380.0)/(pres(mgs)) - thetap(mgs) = thetap0(mgs) - theta(mgs) = thetap(mgs) + theta0(mgs) - qwvp(mgs) = qwvp0(mgs) - qvap(mgs) = max( (qwvp0(mgs) + qv0(mgs)), 0.0 ) - temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap -! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) -! -! -! -! reset temporaries for cloud particles and vapor -! + ENDDO - qwv(mgs) = max( 0.0, qvap(mgs) ) - qcw(mgs) = max( 0.0, qcw1(mgs) ) -! -! - qcwtmp(mgs) = qcw(mgs) - temcg(mgs) = temg(mgs) - tfr - ltemq = (temg(mgs)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) - - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) -! -! iterate adjustment -! - do itertd = 1,2 -! -! -! calculate super-saturation -! - dqcw(mgs) = 0.0 - dqwv(mgs) = ( qwv(mgs) - qss(mgs) ) -! -! evaporation and sublimation adjustment -! - if( dqwv(mgs) .lt. 0. ) then ! subsaturated - if( qcw(mgs) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit - dqcw(mgs) = dqwv(mgs) - dqwv(mgs) = 0. - else ! otherwise make all qc available for evap - dqcw(mgs) = -qcw(mgs) - dqwv(mgs) = dqwv(mgs) + qcw(mgs) - end if -! - qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) ) ! add to perturbation vapor -! - qcw(mgs) = qcw(mgs) + dqcw(mgs) - - thetap(mgs) = thetap(mgs) + & - & 1./pi0(mgs)* & - & (felvcp(mgs)*dqcw(mgs) ) - - end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) -! -! condensation/deposition -! - IF ( dqwv(mgs) .ge. 0. ) THEN -! - dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & - & ((temg(mgs)-cbw)**2)) -! -! - dqcw(mgs) = dqvcnd(mgs) -! - thetap(mgs) = thetap(mgs) + & - & (felvcp(mgs)*dqcw(mgs) ) & - & / (pi0(mgs)) - qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) - qcw(mgs) = qcw(mgs) + dqcw(mgs) -! - END IF ! dqwv(mgs) .ge. 0. + ENDIF - theta(mgs) = thetap(mgs) + theta0(mgs) - temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap -! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) - qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) - temcg(mgs) = temg(mgs) - tfr -! tqvcon = temg(mgs)-cbw - ltemq = (temg(mgs)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - qcw(mgs) = max( 0.0, qcw(mgs) ) - qwv(mgs) = max( 0.0, qvap(mgs)) - qss(mgs) = (0.01*ss1 + 1.0)*qvs(mgs) - end do -! -! end the saturation adjustment iteration loop -! -! - qvex = Max(0.0, qcw(mgs) - qcw1(mgs) ) + DO il = lg,lhab + DO mgs = 1,ngscnt + alpha(mgs,il) = dnu(il) + ENDDO + ENDDO + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) + ENDIF + - RETURN - END SUBROUTINE QVEXCESS -! ##################################################################### -! ##################################################################### -! #undef CHGELEC -!#include "sam.def.h" -!#define ICE10 -!#define ELEC -!#define SAM ! -! Things to do: +! Set density ! -! Test using exponential formulation for rain fall speed. If there is little change -! from the quadratic, it would be less complicated to use. + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' ! -! Contact nucleation needs to be fixed up to be similar to Cotton et al. 1986 and Meyers et al 1992. + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & + & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,infdo,alpha,ildo,axh,bxh,axhl,bxhl) + + + ! -! The following are done? +! put fall speeds into the x-z arrays ! -! Fix Rain evaporation for gamma function (ipconc >= 3) -! -! convert cloud ice to snow as in Ferrier 1994 (change only mass in cloud ice), -! then can try turning off direct conversion from cloud ice to graupel and rimed ice -! -! look at an iterative check on overdepletion; need to be careful with two-moment -! -! check ice supersaturation in two-moment. Getting enough deposition, or need -! to do sat adj. when cloud droplets are all gone? -! -! -! -! new comment -! -! Fix use of gt for SWM IN FALLOUT ROUTINES -! -! How to remove hl for ipconc=5? Need to preprocess? -! -! When the charging rates are moved to a subroutine, need to move the -! call to be after the wet growth calculations -- or at least the -! splashing stuff. Think about this.... -! -! Think about what to do with cracif -! -! Replace qv0 with qx(mgs,lv)? No. qv0 is base val -! -! Need to look at limiting supersaturation to 1 or so by nucleation/condensation -! -! put in temperature-dependent function for homogeneous freezing -! -!c-------------------------------------------------------------------------- -! -! -!-------------------------------------------------------------------------- -! - subroutine nssl_2mom_gs & - & (nx,ny,nz,na,jyslab & - & ,nor,norz & - & ,dtp,gz & - & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & - & ,an,dn,p2 & - & ,pn,w,iunit & - & ,t00,t77, & - & ventr,ventc,c1sw,jgs,ido, & - & xdnmx,xdnmn, & -! & ln,ipc,lvol,lz,lliq, & - & cdx, & - & xdn0,tmp3d,timevtcalc & - & ) -! -!-------------------------------------------------------------------------- -! -! Ziegler 1985 parameterized microphysics (also Zrnic et al. 1993) -! 1) cloud water -! 2) rain -! 3) column ice -! 6) snow -! 11) graupel/hail -! -!-------------------------------------------------------------------------- -! -! Notes: -! -! 4/27/2009: allows for liquid water to be advected on snow and graupel particles using flag "mixedphase" -! -! 3/14/2007: (APS) added qproc temp to make microphysic process timeseries -! -! 10/17/2006: added flag (iehw) to select how to calculate ehw -! -! 10/5/2006: switched chacr to integrated version rather than assuming that average rain -! drop mass does not change. This acts to reduce rain size somewhat via graupel -! collection. -! Use Mason data for ehw, with scaling toward ehw=1 as air density decreases. -! -! 10/3/2006: Turned off Meyers nucleation for T > -5 (can turn on with imeyers5 flag) -! Turned off contact nucleation in updrafts -! -! 7/24/2006: Turned on Meyers nucleation for -5 < T < 0 -! -! 5/12/2006: Converted qsacw/csacw and qsaci/csaci to Z93 -! -! 5/12/2006: Put a threshold on Bigg rain freezing. If the frozen drops -! have an average volume less than xvhmn, then the drops are put -! into snow instead of graupel/hail. -! -! Fixed bug when vapor deposition was limited. -! -! 5/13/2006: Note that qhacr has a large effect, but Z85 did not include it. -! Turned off qsacr (set to zero). -! -! 9/14/2007: erm: recalculate vx(lh) after setting xdn(lh) in case xdn was out of allowed range. -! added parameter rimc3 for minimum rime density. Default value set at 170. kg/m**3 -! instead of previous use of 100. (Farley, 1987) -! -!-------------------------------------------------------------------------- -! -! general declarations -! -!-------------------------------------------------------------------------- -! -! -! - implicit none + DO il = l1,l2 + do mgs = 1,ngscnt + + vtmax = 150.0 -! -! integer icond -! parameter ( icond = 2 ) + + IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & + & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN + + + + vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) + + ENDIF - - integer jyslab,its,ids,ide,jds,jde ! domain boundaries - integer ng1 - integer, intent(in) :: iunit !,iunit0 - parameter(ng1 = 1) - real qvex - integer iraincv, icgxconv - parameter ( iraincv = 1, icgxconv = 1) - real ffrz + + IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & + & vtxbar(mgs,il,3) .gt. vtmax ) THEN + + vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) + vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) + vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) + +! call commasmpi_abort() + ENDIF - real qcitmp,cirdiatmp ! ,qiptmp,qirtmp - real ccwtmp,ccitmp ! ,ciptmp,cirtmp - real cpqc,cpci ! ,cpip,cpir - real cpqc0,cpci0 ! ,cpip0,cpir0 - real scfac ! ,cpip1 - - double precision dp1 - - real :: delqnw = -1.0e-10!-1.0e-12 ! - real :: delqxw = 1.0e-10! 1.0e-12 ! - real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed - double precision frac, frach, xvfrz + xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1) + xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2) + IF ( infdo .ge. 2 ) THEN + xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3) + ELSE + xvt(kgs(mgs),igs(mgs),3,il) = 0.0 + ENDIF - integer iexy(lc:lqmx,lc:lqmx) - integer :: ieswi = 1, ieswc = 1, ieswr = 0 - integer :: iehlsw = 1, iehli = 1, iehlc = 1, iehlr = 0 - integer :: iehwsw = 1, iehwi = 1, iehwc = 1, iehwr = 0 - - double precision :: timevtcalc - double precision :: dpt1,dpt2 - -! real rar ! rime accretion rate as calculated from qxacw +! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il) + enddo + ENDDO -! a few vars for time-split fallout - real vtmax - integer n,ndfall - - double precision chgneg,chgpos - - real temgtmp - integer nx,ny,nz,na,nba,nv - integer nor,norz,istag,jstag,kstag ! ,nht,ngt,igsr - integer iwrite - real dtp,dx,dy,dz - real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - - real qimax,xni0,roqi0 + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' - real dv - real dtptmp - integer itest,nidx,id1,jd1,kd1 - parameter (itest=1) - parameter (nidx=10) - parameter (id1=1,jd1=1,kd1=1) - integer ierr - integer iend - integer ix,kz, il, ic, ir, icp1, irp1, ip1,jp1,kp1 - integer :: jy - integer i,j - real slope1, slope2 - real x1, x2, x3 - real eps,eps2 - parameter (eps=1.e-20,eps2=1.e-5) -! -! Other elec. vars + 9998 continue + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: DONE WITH LOOP' + + if ( kz .gt. nz-1 ) then + go to 1200 + else + nzmpb = kz + end if + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB' + + end do !! inumgs + + if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NXMPB' + + 1200 continue + + +! ENDDO ! ix +! ENDDO ! kz + + + if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE" + + + RETURN + END subroutine ziegfall1d + +! ##################################################################### +! ##################################################################### + + +! ##################################################################### +! ##################################################################### + +! ############################################################################## + subroutine radardd02(nx,ny,nz,nor,na,an,temk, & + & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc, iunit) ! - real temele - real trev - - logical ldovol, ishail, ltest +! 11.13.2005: Changed values of indices for reordering of lip ! +! 07.13.2005: Fixed an error where cnoh was being used for graupel and frozen drops ! -! wind indicies +! 01.24.2005: add ice crystal reflectivity using parameterization of +! Heymsfield (JAS, 1977). Could also try Ferrier for this, too. ! - integer mu,mv,mw - parameter (mu=1,mv=2,mw=3) +! 09.28.2002 Test alterations for dry ice following Ferrier (1994) +! for equivalent melted diameter reflectivity. +! Converted to Fortran by ERM. +! +!Date: Tue, 21 Nov 2000 10:13:36 -0600 (CST) +!From: Matthew Gilmore ! -! conversion parameters +!PRO RF_SPEC ; Computes Radar Reflectivity +!COMMON MAINB, data, x1d, y1d, z1d, iconst, rconst, labels, nx, ny, nz, dshft ! - integer mqcw,mqxw,mtem,mrho,mtim - parameter (mqcw=21,mqxw=21,mtem=21,mrho=5,mtim=6) - - real xftim,xftimi,yftim, xftem,yftem, xfqcw,yfqcw, xfqxw,yfqxw - parameter (xftim=0.05,xftimi = 1./xftim,yftim=1.) - parameter (xftem=0.5,yftem=1.) - parameter (xfqcw=2000.,yfqcw=1.) - parameter (xfqxw=2000.,yfqxw=1.) - real dtfac - parameter ( dtfac = 1.0 ) - integer ido(lc:lqmx) - -! integer iexy(lc:lqmx,lc:lqmx) -! integer ieswi, ieswir, ieswip, ieswc, ieswr -! integer ieglsw, iegli, ieglir, ieglip, ieglc, ieglr -! integer iegmsw, iegmi, iegmir, iegmip, iegmc, iegmr -! integer ieghsw, ieghi, ieghir, ieghip, ieghc, ieghr -! integer iefwsw, iefwi, iefwir, iefwip, iefwc, iefwr -! integer iehwsw, iehwi, iehwir, iehwip, iehwc, iehwr -! integer iehlsw, iehli, iehlir, iehlip, iehlc, iehlr -! real delqnsa, delqxsa, delqnsb, delqxsb, delqnia, delqxia -! real delqnra, delqxra - - real delqnxa(lc:lqmx) - real delqxxa(lc:lqmx) -! -! external temporary arrays +!;MODIFICATION HISTORY +!; 5/99 -Svelta Veleva introduces variable dielf (const_ki_x) as a (weak) +!; function of density. This leads to slight modification of dielf such +!; that the snow reflectivity is slightly increased - not a big effect. +!; This is believed to be more accurate than assuming the dielectric +!; constant for snow is the same as for hail in previous versions. ! - real t00(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real t77(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) +!;On 6/13/99 I added the VIL computation (k=0 in vil array) +!;On 6/15/99 I removed the number concentration dependencies as a function +!; of temperature (only use for ferrier!) +!;On 6/15/99 I added the Composite reflectivity (k=1 in VIL array) +!;On 6/15/99 I added the Severe Hail Index computation (k=2 in vil array) +!; +!; 6/99 - Veleva and Seo argue that since graupel is more similar to +!; snow (in number conc and size density) than it is to hail, we +!; should not weight wetted graupel with the .95 exponent correction +!; factor as in the case of hail. An if-statement checks the size +!; density for wet hail/graupel and treats them appropriately. +!; +!; 6/22/99 - Added function to compute height of max rf and 40 dbz echo top +!; Also added vilqr which is the model vertical integrated liquid only +!; using qr. Will need to check...doesn't seem consistent with vilZ +!; - real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real t1(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real t2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real t3(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real t4(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real t5(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real t6(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) ! perturbation Pi - real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) - real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,na) - real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) - real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + implicit none + + character(LEN=15), parameter :: microp = 'ZVD' + integer nx,ny,nz,nor,na,ngt + integer nzdbz ! how many levels actually to process + + integer ng1,n10 + integer iunit + integer, parameter :: printyn = 0 - real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + parameter( ng1 = 1 ) + + real cnoh0t,hwdn1t + integer ipconc + real vr -! -! declarations microphyscs and for gather/scatter -! - integer nxmpb,nzmpb,nxz - integer jgs,mgs,ngs,numgs - parameter (ngs=500) !500) - integer, parameter :: ngsz = 500 - integer ntt - parameter (ntt=300) - integer ngscnt,igs(ngs),kgs(ngs) - integer kgsp(ngs),kgsm(ngs),kgsm2(ngs) - integer ncuse - parameter (ncuse=0) - integer il0(ngs),il5(ngs),il2(ngs),il3(ngs) -! integer il1m(ngs),il2m(ngs),il3m(ngs),il4m(ngs),il5m(ngs) -! - real cai,caw,cbi,cbw - real tdtol,temsav,tfrcbw,tfrcbi,thnuc + integer imapz,mzdist - real tfr,tfrh - parameter ( tfr = 273.15, tfrh = 233.15) + integer vzflag + integer, parameter :: norz = 3 + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) + real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air density +! real gt(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,ngt) + real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air temperature (kelvin) + real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! reflectivity + real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4) -! -! Ice Multiplication Arrays. -! - real fimt1(ngs),fimta(ngs),fimt2(ngs) !,qmul1(ngs),qmul2(ngs) - real xcwmas -! -! -! Variables for Ziegler warm rain microphysics -! +! real g,rgas,eta,inveta + real cr1, cr2 , hwdnsq,swdnsq + real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc + real reflectmin, kw_sq + real const_ki_sn, const_ki_h, ki_sq_sn + real ki_sq_h, dielf_sn, dielf_h + real pi + logical ltest +! Other data arrays + real gtmp (nx,nz) + real dtmp (nx,nz) + real tmp - real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs) - real sscb ! 'cloud base' SS threshold - parameter ( sscb = 2.0 ) - integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals - parameter ( idecss = 1 ) - integer iba ! flag to do condensation/nucleation in 1st or 2nd loop - ! =0 to use ad to calculate SS - ! =1 to use an at end of main jy loop to calculate SS - parameter (iba = 1) - integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat - parameter ( ifilt = 0 ) - real temp1,temp2 ! ,ssold - real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor - real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter, 4 for mass-weighted diameter - real ssmax(ngs) ! maximum SS experienced by a parcel - real ssmx - real dnnet,dqnet -! real cnu,rnu,snu,cinu -! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) - real bfnu, bfnu0, bfnu1 - parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0) ) - real ventr, ventc - real volb, aa1, aa2 - double precision t2s, xdp - double precision xl2p(ngs),rb(ngs) - parameter ( aa1 = 9.44e15, aa2 = 5.78e3 ) ! a1 in Ziegler -! snow parameters: - real cexs, cecs - parameter ( cexs = 0.1, cecs = 0.5 ) - real rvt ! ratio of collection kernels (Zrnic et al, 1993) - parameter ( rvt = 0.104 ) - real kfrag ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) - parameter ( kfrag = 1.0e-6 ) - real mfrag ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) - parameter ( mfrag = 1.0e-10) - double precision cautn(ngs), rh(ngs), nh(ngs) - real ex1, ft, rhoinv(ngs) - double precision ec0(ngs) - - real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4 ! , sstdy, super - real ratio, delx, dely - real dbigg,volt - real chgtmp,fac - real x,y,del,r,alpr - double precision :: vent1,vent2,dprwvent - real g1palp - real fqt !charge separation as fn of temperature from Dong and Hallett 1992 - real bs - real v1, v2 - real d1r, d1i, d1s, e1i - real c1sw ! integration factor for snow melting with snu = -0.8 - real, parameter :: vr1mm = 5.23599e-10 ! volume of 1mm diameter sphere (m**3) - real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3 ! volume of a 3 mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) - real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 ! volume of 4.5mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) - real vmlt,vshd - real rhosm - parameter ( rhosm = 500. ) - integer nc ! condensation step - real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) - real delta - integer ltemq1,ltemq1m ! ,ltemq1m2 - real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation - real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 - real dqvr, dqc, dqr, dqi, dqs - real qv1m,qvs1m,ss1m,ssi1m,qis1m - real cwmastmp - real dcloud,dcloud2 ! ,as, bs - real cn(ngs) - double precision xvc, xvr - real mwfac - real es(ngs) ! ss(ngs), - real eis(ngs) + real*8 dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x - real rwmasn,rwmasx + integer i,j,k,ix,jy,kz,ihcnt - real vgra,vfrz - parameter ( vgra = 0.523599*(1.0e-3)**3 ) - - real epsi,d - parameter (epsi = 0.622, d = 0.266) - real r1,qevap ! ,slv + real*8 xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc + real*8 dadr + real dbzmax,dbzmin + parameter ( dbzmin = 0 ) + + real cnow,cnoi,cnoip,cnoir,cnor,cnos + real cnogl,cnogm,cnogh,cnof,cnoh,cnohl + + real swdn, rwdn ,hwdn,gldn,gmdn,ghdn,fwdn,hldn + real swdn0 + + real rwdnmx,cwdnmx,cidnmx,xidnmx,swdnmx,gldnmx,gmdnmx + real ghdnmx,fwdnmx,hwdnmx,hldnmx + real rwdnmn,cwdnmn,cidnmn,xidnmn,swdnmn,gldnmn,gmdnmn + real ghdnmn,fwdnmn,hwdnmn,hldnmn + + real gldnsq,gmdnsq,ghdnsq,fwdnsq,hldnsq + + real dadgl,dadgm,dadgh,dadhl,dadf + real zgldryc,zglwetc,zgmdryc, zgmwetc,zghdryc,zghwetc + real zhldryc,zhlwetc,zfdryc,zfwetc + + real dielf_gl,dielf_gm,dielf_gh,dielf_hl,dielf_fw - real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r + integer imx,jmx,kmx - real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain - real, parameter :: rimedens = 500. ! default rime density - -! real svc(ngs) ! droplet volume -! -! contact freezing nucleation -! - real raero,kaero !assumd aerosol radius, thermal conductivity - parameter ( raero = 3.e-7, kaero = 5.39e-3 ) - real kb ! Boltzman constant J K-1 - parameter (kb = 1.3807e-23) + real swdia,gldia,gmdia,ghdia,fwdia,hwdia,hldia - real knud(ngs),knuda(ngs) !knudsen number and correction factor - real gtp(ngs) !G(T,p) = 1/(a' + b') Cotton 72b - real dfar(ngs) !aerosol diffusivity - real fn1(ngs),fn2(ngs),fnft(ngs) + real csw,cgl,cgm,cgh,cfw,chw,chl + real xvs,xvgl,xvgm,xvgh,xvf,xvh,xvhl - real ccia(ngs) - real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs) -! -! misc -! - real ni,nr,d0 - real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs) - real tempc(ngs) - real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) - real temgkm1(ngs), temgkm2(ngs) - real temgx(ngs),temcgx(ngs) - real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) - real elv(ngs),elf(ngs),els(ngs) - real tsqr(ngs),ssi(ngs),ssw(ngs) - real qcwtmp(ngs),qtmp,qtot(ngs) - real qcond(ngs) - real ctmp, sctmp - real cwmasn,cwmasx - real cwmasn5 - real cwradn - real cimasn,cimasx,ccimx - real pid4 - real ar,br,cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1 - real gf73rds, gf83rds - real gf43rds, gf53rds - real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn - parameter ( rwradmn = 50.e-6 ) - real dh0 + real cwc0 + integer izieg + integer ice10 + real rhos + parameter ( rhos = 0.1 ) - real clionpmx,clionnmx - parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 -! -! other arrays + real qxw ! temp value for liquid water on ice mixing ratio - real fwet1(ngs),fwet2(ngs) - real fmlt1(ngs),fmlt2(ngs) - real fvds(ngs),fvce(ngs),fiinit(ngs) - real fvent(ngs),fraci(ngs),fracl(ngs) -! - real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs) - real felv(ngs),fels(ngs),felf(ngs) - real felvcp(ngs),felscp(ngs),felfcp(ngs) - real felvs(ngs),felss(ngs) ! ,felfs(ngs) - real fwvdf(ngs),ftka(ngs),fthdf(ngs) - real fadvisc(ngs),fakvisc(ngs) - real fci(ngs),fcw(ngs) - real fschm(ngs),fpndl(ngs) - real fgamw(ngs),fgams(ngs) - real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) + real, parameter :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 + real, parameter :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 + real, parameter :: cwradn = 5.0e-6 ! minimum radius + + real cwnccn(nz) - real cvm -! - real fcci(ngs), fcip(ngs) -! - real :: sfm1(ngs),sfm2(ngs) - real :: gfm1(ngs),gfm2(ngs) - real :: hfm1(ngs),hfm2(ngs) + real :: vzsnow, vzrain, vzgraupel, vzhail + real :: ksq + real :: dtp - logical :: wetsfc(ngs),wetsfchl(ngs) - logical :: wetgrowth(ngs), wetgrowthhl(ngs) - real qitmp(ngs) - - real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs) - real vt2ave(ngs) +! ######################################################################### - real :: qx(ngs,lv:lhab) - real :: qxw(ngs,ls:lhab) - real :: cx(ngs,lc:lhab) - real :: cxmxd(ngs,lc:lhab) - real :: qxmxd(ngs,lv:lhab) - real :: scx(ngs,lc:lhab) - real :: xv(ngs,lc:lhab) -! real :: xsfca(ngs,lc:lhab) - real :: vtxbar(ngs,lc:lhab,3) - real :: xmas(ngs,lc:lhab) - real :: xdn(ngs,lc:lhab) - real :: xdia(ngs,lc:lhab,3) - real :: rarx(ngs,ls:lhab) - real :: vx(ngs,li:lhab) - real :: rimdn(ngs,li:lhab) - real :: raindn(ngs,li:lhab) - real :: alpha(ngs,lr:lhab) - real :: dab0lh(ngs,lc:lhab,lr:lhab) - real :: dab1lh(ngs,lc:lhab,lr:lhab) - - - real, parameter :: alpharaut = 0.0 ! MY2005 for autoconversion - real, parameter :: galpharaut = (6.+alpharaut)* & - & (5.+alpharaut)* & - & (4.+alpharaut)/ & - & ((3.+alpharaut)* & - & (2.+alpharaut)* & - & (1.+alpharaut)) + vzflag = 0 - real ventrx(ngs) - real ventrxn(ngs) - real g1shr, alphashr - real g1mlr, alphamlr + izieg = 0 + ice10 = 0 +! g=9.806 ! g: gravity constant +! rgas=287.04 ! rgas: gas constant for dry air +! rcp=rgas/cp ! rcp: gamma constant +! eta=0.622 +! inveta = 1./eta +! rcpinv = 1./rcp +! cpr=cp/rgas +! cvr=cv/rgas + pi = 4.0*ATan(1.) + cwc0 = piinv ! 1./pi ! 6.0/pi - real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs) - real civent(ngs) -! - real xmascw(ngs) - real xdnmx(lc:lhab), xdnmn(lc:lhab) - real dnmx -! - real cilen(ngs) ! ,ciplen(ngs) -! -! - real rwcap(ngs),swcap(ngs) - real hwcap(ngs) - real hlcap(ngs) - real cicap(ngs) + cnoh = cnoh0t + hwdn = hwdn1t - real qvimxd(ngs) - real qimxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) - real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs) - real cionpmxd(ngs),cionnmxd(ngs) - real clionpmxd(ngs),clionnmxd(ngs) + rwdn = 1000.0 + swdn = 100.0 -! -! - real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs) - real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs) - - real csplinter(ngs),qsplinter(ngs) - real csplinter2(ngs),qsplinter2(ngs) -! -! -! concentration arrays... -! - real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs) - real cracif(ngs), ciacrf(ngs) - real cracr(ngs) + qrmin = 1.0e-05 + qsmin = 1.0e-06 + qhmin = 1.0e-05 ! - real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs) - real cicint(ngs) - real cipint(ngs) - real ciacw(ngs), cwacii(ngs) - real ciacr(ngs), craci(ngs) - real csacw(ngs) - real csacr(ngs) - real csaci(ngs), csacs(ngs) - real cracw(ngs) - real chacw(ngs), chacr(ngs) - real :: chlacw(ngs) ! = 0.0 - real chaci(ngs), chacs(ngs) +! default slope intercepts ! - real :: chlacr(ngs) - real :: chlaci(ngs), chlacs(ngs) - real crcnw(ngs) - real cidpv(ngs),cisbv(ngs) - real cimlr(ngs) + cnow = 1.0e+08 + cnoi = 1.0e+08 + cnoip = 1.0e+08 + cnoir = 1.0e+08 + cnor = 8.0e+06 + cnos = 8.0e+06 + cnogl = 4.0e+05 + cnogm = 4.0e+05 + cnogh = 4.0e+05 + cnof = 4.0e+05 + cnohl = 1.0e+03 - real chlsbv(ngs), chldpv(ngs) - real chlmlr(ngs), chlmlrr(ngs) - real chlshr(ngs), chlshrr(ngs) - real chdpv(ngs),chsbv(ngs) - real chmlr(ngs),chcev(ngs) - real chmlrr(ngs) - real chshr(ngs), chshrr(ngs) + imx = 1 + jmx = 1 + kmx = 1 + i = 1 - real csdpv(ngs),cssbv(ngs) - real csmlr(ngs),cscev(ngs) - real csshr(ngs) - real crcev(ngs) - real crshr(ngs) -! -! -! arrays for w-ac-x ; x-ac-w -! -! -! - real qrcnw(ngs), qwcnr(ngs) - real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) + IF ( microp(1:4) .eq. 'ZIEG' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN +! write(0,*) 'Set reflectivity for ZIEG' + izieg = 1 - real qracw(ngs) ! qwacr(ngs), - real qiacw(ngs) !, qwaci(ngs) + hwdn = hwdn1t ! 500. - real qsacw(ngs) ! ,qwacs(ngs), - real qhacw(ngs) ! qwach(ngs), - real :: qhlacw(ngs) ! = 0.0 - real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) -! - real qsacws(ngs) + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF -! -! arrays for x-ac-r and r-ac-x; -! - real qsacr(ngs),qracs(ngs) - real qhacr(ngs) ! ,qrach(ngs) - real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) - real qiacr(ngs),qraci(ngs) - - real ziacr(ngs) + ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN - real qracif(ngs),qiacrf(ngs),qiacrs(ngs) + izieg = 1 + + swdn0 = swdn - real :: qhlacr(ngs) ! = 0.0 - real qsacrs(ngs) !,qracss(ngs) -! -! ice - ice interactions -! - real qsaci(ngs) - real qhaci(ngs) - real qhacs(ngs) + cnor = cno(lr) + cnos = cno(ls) + cnoh = cno(lh) + + qrmin = qxmin(lr) + qsmin = qxmin(ls) + qhmin = qxmin(lh) + IF ( lhl .gt. 1 ) THEN + cnohl = cno(lhl) + qhlmin = qxmin(lhl) + ENDIF +! write(*,*) 'radardbz: ',db(1,1,1),temk(1,1,1),an(1,1,1,lr),an(1,1,1,ls),an(1,1,1,lh) - real :: qhlaci(ngs) ! = 0.0 - real :: qhlacs(ngs) ! = 0.0 -! -! conversions -! - real qrfrz(ngs) ! , qirirhr(ngs) - real zrfrz(ngs), zrfrzf(ngs) - real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) - real zhacw(ngs), zhacs(ngs) - real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs) - real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs) - real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) - real zhwdn(ngs) ! change in Z due to density changes - real zhldn(ngs) ! change in Z due to density changes - real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs) - real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs) + ENDIF - - real vrfrzf(ngs), viacrf(ngs) - real qrfrzs(ngs), qrfrzf(ngs) - real qwfrz(ngs), qwctfz(ngs) - real cwfrz(ngs), cwctfz(ngs) - real qwfrzc(ngs), qwctfzc(ngs) - real cwfrzc(ngs), cwctfzc(ngs) - real qwfrzp(ngs), qwctfzp(ngs) - real cwfrzp(ngs), cwctfzp(ngs) - real xcolmn(ngs), xplate(ngs) - real ciihr(ngs), qiihr(ngs) - real cicichr(ngs), qicichr(ngs) - real cipiphr(ngs), qipiphr(ngs) - real qscni(ngs), cscni(ngs), cscnis(ngs) - real qscnvi(ngs), cscnvi(ngs), cscnvis(ngs) - real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs) - real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs) - real qiint(ngs),qipipnt(ngs),qicicnt(ngs) - real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs) - real tke(ngs) - real uvel(ngs),vvel(ngs) -! - real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs), - real qimlr(ngs),qidsv(ngs),qidsvp(ngs) ! ,qicev(ngs) +! cdx(lr) = 0.60 +! +! IF ( lh > 1 ) THEN +! cdx(lh) = 0.8 ! 1.0 ! 0.45 +! cdx(ls) = 2.00 +! ENDIF ! - real qfdpv(ngs),qfsbv(ngs) ! qfcnv(ngs),qfevv(ngs), - real qfmlr(ngs),qfdsv(ngs) ! ,qfcev(ngs) - real qfwet(ngs),qfdry(ngs),qfshr(ngs) - real qfshrp(ngs) +! IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 ! - real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), - real :: qhlmlr(ngs), qhldsv(ngs) - real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) +! xvmn(lc) = xvcmn +! xvmn(lr) = xvrmn ! - real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs) +! xvmx(lc) = xvcmx +! xvmx(lr) = xvrmx ! - real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs), - real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) - real qhlcev(ngs), chlcev(ngs) - real qhwet(ngs),qhdry(ngs),qhshr(ngs) - real qhshrp(ngs) - real qhshh(ngs) !accreted water that remains on graupel - real qhmlh(ngs) !melt water that remains on graupel - real qhfzh(ngs) !water that freezes on mixed-phase graupel - real qhlfzhl(ngs) !water that freezes on mixed-phase hail - - real vhfzh(ngs) ! change in volume from water that freezes on mixed-phase graupel - real vhlfzhl(ngs) ! change in volume from water that freezes on mixed-phase hail - - real vhshdr(ngs) !accreted water that leaves on graupel (mixedphase) - real vhlshdr(ngs) !accreted water that leaves on hail (mixedphase) - real vhmlr(ngs) !melt water that leaves graupel (single phase) - real vhlmlr(ngs) !melt water that leaves hail (single phase) - real vhsoak(ngs) ! aquired water that seeps into graupel. - real vhlsoak(ngs) ! aquired water that seeps into hail. +! IF ( lh > 1 ) THEN +! xvmn(ls) = xvsmn +! xvmn(lh) = xvhmn +! xvmx(ls) = xvsmx +! xvmx(lh) = xvhmx +! ENDIF ! - real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs), - real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs) - real qswet(ngs),qsdry(ngs),qsshr(ngs) - real qsshrp(ngs) - real qsfzs(ngs) +! IF ( lhl .gt. 1 ) THEN +! xvmn(lhl) = xvhlmn +! xvmx(lhl) = xvhlmx +! ENDIF ! +! xdnmx(lr) = 1000.0 +! xdnmx(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmx(li) = 917.0 +! xdnmx(ls) = 300.0 +! xdnmx(lh) = 900.0 +! ENDIF +! IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 +!! +! xdnmn(:) = 900.0 +! +! xdnmn(lr) = 1000.0 +! xdnmn(lc) = 1000.0 +! IF ( lh > 1 ) THEN +! xdnmn(li) = 100.0 +! xdnmn(ls) = 100.0 +! xdnmn(lh) = hdnmn +! ENDIF +! IF ( lhl .gt. 1 ) xdnmn(lhl) = 500.0 ! - real qipdpv(ngs),qipsbv(ngs) - real qipmlr(ngs),qipdsv(ngs) +! xdn0(:) = 900.0 +! +! xdn0(lc) = 1000.0 +! xdn0(lr) = 1000.0 +! IF ( lh > 1 ) THEN +! xdn0(li) = 900.0 +! xdn0(ls) = 100.0 ! 100.0 +! xdn0(lh) = hwdn1t ! (0.5)*(xdnmn(lh)+xdnmx(lh)) +! ENDIF +! IF ( lhl .gt. 1 ) xdn0(lhl) = 800.0 + ! - real qirdpv(ngs),qirsbv(ngs) - real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs) +! slope intercepts ! - real qgldpv(ngs),qglsbv(ngs) - real qglmlr(ngs),qgldsv(ngs) - real qglwet(ngs),qgldry(ngs),qglshr(ngs) - real qglshrp(ngs) +! cnow = 1.0e+08 +! cnoi = 1.0e+08 +! cnoip = 1.0e+08 +! cnoir = 1.0e+08 +! cnor = 8.0e+06 +! cnos = 8.0e+06 +! cnogl = 4.0e+05 +! cnogm = 4.0e+05 +! cnogh = 4.0e+05 +! cnof = 4.0e+05 +!c cnoh = 4.0e+04 +! cnohl = 1.0e+03 ! - real qgmdpv(ngs),qgmsbv(ngs) - real qgmmlr(ngs),qgmdsv(ngs) - real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs) - real qgmshrp(ngs) - real qghdpv(ngs),qghsbv(ngs) - real qghmlr(ngs),qghdsv(ngs) - real qghwet(ngs),qghdry(ngs),qghshr(ngs) - real qghshrp(ngs) ! - real qrztot(ngs),qrzmax(ngs),qrzfac(ngs) - real qrcev(ngs) - real qrshr(ngs) - real fsw(ngs),fhw(ngs),fhlw(ngs) !liquid water fractions - real qhcnf(ngs) - real :: qhlcnh(ngs) ! = 0.0 - real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) - - real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel +! density maximums and minimums +! + rwdnmx = 1000.0 + cwdnmx = 1000.0 + cidnmx = 917.0 + xidnmx = 917.0 + swdnmx = 200.0 + gldnmx = 400.0 + gmdnmx = 600.0 + ghdnmx = 800.0 + fwdnmx = 900.0 + hwdnmx = 900.0 + hldnmx = 900.0 +! + rwdnmn = 1000.0 + cwdnmn = 1000.0 + xidnmn = 001.0 + cidnmn = 001.0 + swdnmn = 001.0 + gldnmn = 200.0 + gmdnmn = 400.0 + ghdnmn = 600.0 + fwdnmn = 700.0 + hwdnmn = 700.0 + hldnmn = 900.0 - real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs) - real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs) - real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) - real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) - real ehxr(ngs),ehlr(ngs),egmr(ngs) - real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs) - real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs) - real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) - real ehscnv(ngs) - real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) + + gldn = (0.5)*(gldnmn+gldnmx) ! 300. + gmdn = (0.5)*(gmdnmn+gmdnmx) ! 500. + ghdn = (0.5)*(ghdnmn+ghdnmx) ! 700. + fwdn = (0.5)*(fwdnmn+fwdnmx) ! 800. + hldn = (0.5)*(hldnmn+hldnmx) ! 900. - real ew(8,6) - real cwr(8,2) ! radius and inverse of interval - data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & ! radius - & 1.0, 1.0, 0.5, 0.5, 0.5, 0.2, 0.2, 1. / ! inverse of interval - integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs) - real grad(6,2) ! graupel radius and inverse of interval - data grad / 100., 200., 300., 400., 600., 1000., & - & 1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1. / -!droplet radius: 2 3 4 6 8 10 15 20 - data ew /0.03, 0.07, 0.17, 0.41, 0.58, 0.69, 0.82, 0.88, & ! 100 -! : 0.07, 0.13, 0.27, 0.48, 0.65, 0.73, 0.84, 0.91, ! 150 - & 0.10, 0.20, 0.34, 0.58, 0.70, 0.78, 0.88, 0.92, & ! 200 - & 0.15, 0.31, 0.44, 0.65, 0.75, 0.83, 0.96, 0.91, & ! 300 - & 0.17, 0.37, 0.50, 0.70, 0.81, 0.87, 0.93, 0.96, & ! 400 - & 0.17, 0.40, 0.54, 0.71, 0.83, 0.88, 0.94, 0.98, & ! 600 - & 0.15, 0.37, 0.52, 0.74, 0.82, 0.88, 0.94, 0.98 / ! 1000 -! : 0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400 + cr1 = 7.2e+20 + cr2 = 7.295e+19 + hwdnsq = hwdn**2 + swdnsq = swdn**2 + rwdnsq = rwdn**2 - real da0lr(ngs) - real da0lh(ngs) - real da0lhl(ngs) + gldnsq = gldn**2 + gmdnsq = gmdn**2 + ghdnsq = ghdn**2 + fwdnsq = fwdn**2 + hldnsq = hldn**2 + + dhmin = 0.005 + tfr = 273.16 + tfrh = tfr - 8.0 + zrc = cr1*cnor + reflectmin = 0.0 + kw_sq = 0.93 + dbzmax = dbzmin + + ihcnt=0 + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Dielectric Factor - Formulas implemented by Svetla Veleva +! following Battan, "Radar Meteorology" - p. 40 +! The result of these calculations is that the dielf numerator (ki_sq) without +! the density ratio is .2116 for hail if using 917 density and .25 for +! snow if using 220 density. +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + const_ki_sn = 0.5 - (0.5-0.46)/(917.-220.)*(swdn-220.) + const_ki_h = 0.5 - (0.5-0.46)/(917.-220.)*(hwdn-220.) + ki_sq_sn = (swdnsq/rwdnsq) * const_ki_sn**2 + ki_sq_h = (hwdnsq/rwdnsq) * const_ki_h**2 + dielf_sn = ki_sq_sn / kw_sq + dielf_h = ki_sq_h / kw_sq + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the next line if you want to hardwire dielf for dry hail for both dry +! snow and dry hail. +! This would be equivalent to what Straka had originally. (i.e, .21/.93) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + dielf_sn = (swdnsq/rwdnsq)*.21/ kw_sq + dielf_h = (hwdnsq/rwdnsq)*.21/ kw_sq + dielf_gl = (gldnsq/rwdnsq)*.21/ kw_sq + dielf_gm = (gmdnsq/rwdnsq)*.21/ kw_sq + dielf_gh = (ghdnsq/rwdnsq)*.21/ kw_sq + dielf_hl = (hldnsq/rwdnsq)*.21/ kw_sq + dielf_fw = (fwdnsq/rwdnsq)*.21/ kw_sq - real va0 (lc:lqmx) ! collection coefficients from Seifert 2005 - real vab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 - real vab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 - real va1 (lc:lqmx) ! collection coefficients from Seifert 2005 - real ehip(ngs),ehlip(ngs),ehlir(ngs) - real erir(ngs),esir(ngs),eglir(ngs),egmir(ngs),eghir(ngs) - real efir(ngs),ehir(ngs),eirw(ngs),eirir(ngs),ehr(ngs) - real erip(ngs),esip(ngs),eglip(ngs),eghip(ngs) - real efip(ngs),eipi(ngs),eipw(ngs),eipip(ngs) -! -! arrays for production terms -! - real ptotal(ngs) ! , pqtot(ngs) -! - real pqcwi(ngs),pqcii(ngs),pqrwi(ngs) - real pqswi(ngs),pqhwi(ngs),pqwvi(ngs) - real pqgli(ngs),pqghi(ngs),pqfwi(ngs) - real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) - real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), - real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs) - - real pvhwi(ngs), pvhwd(ngs) - real pvhli(ngs), pvhld(ngs) - real pvswi(ngs), pvswd(ngs) -! - real pqcwd(ngs),pqcid(ngs),pqrwd(ngs) - real pqswd(ngs),pqhwd(ngs),pqwvd(ngs) - real pqgld(ngs),pqghd(ngs),pqfwd(ngs) - real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) - real pqird(ngs),pqipd(ngs) ! pqwad(ngs), - real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs) -! -! real pqxii(ngs,nhab),pqxid(ngs,nhab) -! - real pctot(ngs) - real pcipi(ngs), pcipd(ngs) - real pciri(ngs), pcird(ngs) - real pccwi(ngs), pccwd(ngs) - real pccii(ngs), pccid(ngs) - real pcrwi(ngs), pcrwd(ngs) - real pcswi(ngs), pcswd(ngs) - real pchwi(ngs), pchwd(ngs) - real pchli(ngs), pchld(ngs) - real pcfwi(ngs), pcfwd(ngs) - real pcgli(ngs), pcgld(ngs) - real pcgmi(ngs), pcgmd(ngs) - real pcghi(ngs), pcghd(ngs) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Notes on dielectric factors - from Eun-Kyoung Seo +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! constants for both snow and hail would be (x=s,h)..... +! xwdnsq/rwdnsq *0.21/kw_sq ! Straka/Smith - the original +! xwdnsq/rwdnsq *0.224 ! Ferrier - for particle sizes in equiv. drop diam +! xwdnsq/rwdnsq *0.176/kw_sq ! =0.189 in Smith - for particle sizes in equiv +! ice spheres +! xwdnsq/rwdnsq *0.208/kw_sq ! Smith '84 - for particle sizes in equiv melted drop diameter +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - real pzrwi(ngs), pzrwd(ngs) - real pzhwi(ngs), pzhwd(ngs) - real pzhli(ngs), pzhld(ngs) - real pzswi(ngs), pzswd(ngs) -! -! other arrays -! - real dqisdt(ngs) !,advisc(ngs) !dqwsdt(ngs), ,schm(ngs),pndl(ngs) +! VIL algorithm constants +! Ztop = 10.**(56./10) !56 dbz is the max rf used by WATADS in cell vil - real qss0(ngs) - real advisc0,advisc1,tka0 +! Hail detection algorithm constants +! ZL = 40. +! ZU = 50. +! Ho = 3400. !WATADS Defaults +! Hm20 = 6200. !WATADS Defaults - real qsacip(ngs) - real pres(ngs) - real pk(ngs) - real rho0(ngs),pi0(ngs) - real rhovt(ngs) - real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) - real thsave(ngs) - real ptwfzi(ngs),ptimlw(ngs) - real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs) - - real cnostmp(ngs) ! for diagnosed snow intercept -! -! iholef = 1 to do hole filling technique version 1 -! which uses all hydrometerors to do hole filling of all hydrometeors -! iholef = 2 to do hole filling technique version 2 -! which uses an individual hydrometeror species to do hole -! filling of a species of a hydrometeor +! DO kz = 1,Min(nzdbz,nz-1) + + DO jy=1,1 + + DO kz = 1,nz + + DO ix=1,nx + dbz(ix,jy,kz) = 0.0 + + vzsnow = 0.0 + vzrain = 0.0 + vzgraupel = 0.0 + vzhail = 0.0 + + dtmph = 0.0 + dtmps = 0.0 + dtmphl = 0.0 + dtmpr = 0.0 + dadr = (db(ix,jy,kz)/(pi*rwdn*cnor))**(0.25) +!----------------------------------------------------------------------- +! Compute Rain Radar Reflectivity +!----------------------------------------------------------------------- + + dtmp(ix,kz) = 0.0 + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,lr) .ge. qrmin ) THEN + IF ( ipconc .le. 2 ) THEN + gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) + dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 + ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN + IF ( imurain == 3 ) THEN + vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) + dtmp(ix,kz) = 3.6e18*(rnu+2.)*an(ix,jy,kz,lnr)*vr**2/(rnu+1.) + ELSE ! imurain == 1 + g1 = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) + zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lr))**2/an(ix,jy,kz,lnr) + ze =1.e18*zx*(6./(pi*1000.))**2 ! note: using 1000. here for water density + dtmp(ix,kz) = ze + ENDIF + ENDIF + dtmpr = dtmp(ix,kz) + ENDIF + +!----------------------------------------------------------------------- +! Compute snow and graupel reflectivity ! -! iholen = interval that hole filling is done +! Lou modified to look at parcel temperature rather than base state +!----------------------------------------------------------------------- + + IF( lhab .gt. lr ) THEN + +! qs2d = reform(data[*,*,k,10],[nx*ny]) +! qh2d = reform(data[*,*,k,11],[nx*ny]) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Straka's GEMS microphysics +! (Sam 1-d version modified by L Wicker does not use this) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ;xcnoh = cnoh*exp(-0.025*(temp-tfr)) +! ;xcnos = cnos*exp(-0.038*(temp-tfr)) +! ;good = where(temp GT tfr, n_elements) +! ;IF n_elements NE 0 THEN xcnoh(good) = cnoh*exp(-0.075*(temp(good)-tfr)) +! ;IF n_elements NE 0 THEN xcnos(good) = cnos*exp(-0.088*(temp(good)-tfr)) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Only use the following lines if running Ferrier micro with No=No(T) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! ; NOSE = -.15 +! ; NOGE = .0 +! ; xcnoh = cnoh*(1.>exp(NOGE*(temp-tfr)) ) +! ; xcnos = cnos*(1.>exp(NOSE*(temp-tfr)) ) + +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +! Use the following lines if Nos and Noh are constant +! (As in Svetla's version of Ferrier, GCE Tao, and SAM 1-d) +!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + xcnoh = cnoh + xcnos = cnos + ! - integer iholef - integer iholen - parameter (iholef = 1) - parameter (iholen = 1) - real cqtotn,cqtotn1 - real cctotn - real citotn - real crtotn - real cstotn - real cvtotn - real cftotn - real cgltotn - real cghtotn - real chtotn - real cqtotp,cqtotp1 - real cctotp - real citotp - real ciptotp - real crtotp - real cstotp - real cvtotp - real cftotp - real chltotp - real cgltotp - real cgmtotp - real cghtotp - real chtotp - real cqfac - real ccfac - real cifac - real cipfac - real crfac - real csfac - real cvfac - real cffac - real cglfac - real cghfac - real chfac - - real ssifac, qvapor +! Temporary fix for predicted number concentration -- need a +! more appropriate reflectivity equation! ! -! Miscellaneous variables +! IF ( an(ix,jy,kz,lns) .lt. 0.1 ) THEN +! swdia = (xvrmn*cwc0)**(1./3.) +! xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvrmn*swdn*swdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! swdia = +! > (an(ix,jy,kz,ls)*db(ix,jy,kz) +! > /(pi*swdn*an(ix,jy,kz,lns)))**(1./3.) ! - integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh - integer lqrw - real vt - real arg ! gamma is a function - real erbnd1, fdgt1, costhe1 - real qeps - real dyi2,dzi2,cp608,bta1,cnit,dragh,dnz00,rho00,pii - real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds,gr +! xcnos = an(ix,jy,kz,lns)/swdia +! ENDIF - - real xdn0(lc:lhab) - real xdn_new,drhodt - - integer l ,ltemq,inumgs, idelq + IF ( ls .gt. 1 ) THEN ! { + + IF ( lvs .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + swdn = db(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + swdn = Min( 300., Max( 100., swdn ) ) + ELSE + swdn = swdn0 + ENDIF + + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { - real c1f3,brz,arz,rw,temq + xvs = db(ix,jy,kz)*an(ix,jy,kz,ls)/ & + & (swdn*Max(1.0e-3,an(ix,jy,kz,lns))) + IF ( xvs .lt. xvsmn .or. xvs .gt. xvsmx ) THEN + xvs = Min( xvsmx, Max( xvsmn,xvs ) ) + csw = db(ix,jy,kz)*an(ix,jy,kz,ls)/(xvs*swdn) + ENDIF - real ssival,tqvcon - real cdx(lc:lhab) - real cnox - real cval,aval,eval,fval,gval ,qsign,ftelwc,qconkq - real qconm,qconn,cfce15,gf8,gf4i,gf3p5,gf1a,gf1p5,qdiff,argrcnw - real c4,bradp,bl2,bt2,dtrh,hrifac, hdia0,hdia1,civenta,civentb - real civentc,civentd,civente,civentf,civentg,cireyn,xcivent - real cipventa,cipventb,cipventc,cipventd,cipreyn,cirventa - real cirventb - integer igmrwa,igmrwb,igmswa, igmswb,igmfwa,igmfwb,igmhwa,igmhwb - real rwventa ,rwventb,swventa,swventb,fwventa,fwventb,fwventc - real hwventa,hwventb - real hwventc, hlventa, hlventb, hlventc - real glventa, glventb, glventc - real gmventa, gmventb, gmventc, ghventa, ghventb, ghventc - real dzfacp, dzfacm, cmassin, cwdiar - real rimmas, rhobar - real argtim, argqcw, argqxw, argtem - real frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1 - real frcglgl, frcglgm, frcglgh, frcglfw, frcglgl1 - real frcgmgl, frcgmgm, frcgmgh, frcgmfw, frcgmgm1 - real frcghgl, frcghgm, frcghgh, frcghfw, frcghgh1 - real frcfwgl, frcfwgm, frcfwgh, frcfwfw, frcfwfw1 - real frcswrsw, frcswrgl, frcswrgm, frcswrgh, frcswrfw - real frcswrsw1 - real frcrswsw, frcrswgl, frcrswgm, frcrswgh, frcrswfw - real frcrswsw1 - real frcglrgl, frcglrgm, frcglrgh, frcglrfw, frcglrgl1 - real frcrglgl - real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 - real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 - real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 - real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt - real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl - real frcrghgm, frcrghgh, frcrghfw, frcrghgh1 - real a1,a2,a3,a4,a5,a6 - real gamss - real cdw, cdi, denom1, denom2, delqci1, delqip1 - real cirtotn, ciptotn, cgmtotn, chltotn, cirtotp - real cgmfac, chlfac, cirfac - integer igmhla, igmhlb, igmgla, igmglb, igmgma, igmgmb - integer igmgha, igmghb - integer idqis, item, itim0 - integer iqgl, iqgm, iqgh, iqrw, iqsw - integer itertd, ia - - real tau, ewtmp - - integer cntnic_noliq - real q_noliqmn, q_noliqmx - real scsacimn, scsacimx - - double precision :: dtpinv - -! arrays for temporary bin space - - integer nbin - parameter (nbin=50) ! number of mass bins for bin model - real rn(nbin) !,rd(nbin),rm(nbin) - real rq(nbin),vtr(nbin) !,rdrd(nbin) - - real vtra(nbin) - real hmmin,hjo -! parameter ( hjo = 0.8*7.5*nbin/(41.) ) - parameter (hmmin = 1.e-11, hjo = 0.8*7.5 ) - - integer itile,jtile,ktile - integer ixend,jyend,kzend,kzbeg - integer nxend,nyend,nzend,nzbeg - - real :: qaacw ! combined qsacw-qhacw for WSM6 variation - - -! -! #################################################################### -! -! Start routine -! -! #################################################################### - - - - iexy(:,:)=0; ! sets to zero the ones Imight have forgotten + swdia = (xvs*cwc0)**(1./3.) + xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvs*swdn*swdia) + + ENDIF ! } + ENDIF ! } -! snow - iexy(ls,li) = ieswi - iexy(ls,lc) = ieswc ; iexy(ls,lr) = ieswr ; +! IF ( an(ix,jy,kz,lnh) .lt. 0.1 ) THEN +! hwdia = (xvrmn*cwc0)**(1./3.) +! xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvrmn*hwdn*hwdia) +! ELSE +! ! changed back to diameter of mean volume!!! +! hwdia = +! > (an(ix,jy,kz,lh)*db(ix,jy,kz) +! > /(pi*hwdn*an(ix,jy,kz,lnh)))**(1./3.) +! +! xcnoh = an(ix,jy,kz,lnh)/hwdia +! ENDIF -! graupel - iexy(lh,ls) = iehwsw ; iexy(lh,li) = iehwi ; - iexy(lh,lc) = iehwc ; iexy(lh,lr) = iehwr ; + IF ( lh .gt. 1 ) THEN ! { -! hail - IF (lhl .gt. 1 ) THEN - iexy(lhl,ls) = iehlsw ; iexy(lhl,li) = iehli ; - iexy(lhl,lc) = iehlc ; iexy(lhl,lr) = iehlr ; - ENDIF -! + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( hdnmn, hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF + ELSE + hwdn = hwdn1t + ENDIF + + IF ( ipconc .ge. 5 ) THEN ! { - itile = nx - jtile = ny - ktile = nz - ixend = nx - jyend = ny - kzend = nz - nxend = nx + 1 - nyend = ny + 1 - nzend = nz - kzbeg = 1 - nzbeg = 1 + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/ & + & (hwdn*Max(1.0e-3,an(ix,jy,kz,lnh))) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF - istag = 0 - jstag = 0 - kstag = 1 + hwdia = (xvh*cwc0)**(1./3.) + xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvh*hwdn*hwdia) + + ENDIF ! } ipconc .ge. 5 + + ENDIF ! } + dadh = 0.0 + dadhl = 0.0 + dads = 0.0 + IF ( xcnoh .gt. 0.0 ) THEN + dadh = ( db(ix,jy,kz) /(pi*hwdn*xcnoh) )**(.25) + zhdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnoh ! dielf_h*cr1*xcnoh ! SV - equiv formula as before but + ! ratio of densities included in + ! dielf_h rather than here following + ! Battan. + ELSE + dadh = 0.0 + zhdryc = 0.0 + ENDIF + + IF ( xcnos .gt. 0.0 ) THEN + dads = ( db(ix,jy,kz) /(pi*swdn*xcnos) )**(.25) + zsdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnos ! dielf_sn*cr1*xcnos ! SV - similar change as above + ELSE + dads = 0.0 + zsdryc = 0.0 + ENDIF + zhwetc = zhdryc ! cr1*xcnoh !Hail/graupel version with .95 power bug removed + zswetc = zsdryc ! cr1*xcnos +! +! snow contribution ! -! slope intercepts -! - - IF ( ngs .lt. nz ) THEN -! write(0,*) 'Error in ICEZVD: Must have ngs .ge. nz!' -! STOP - ENDIF - - cntnic_noliq = 0 - q_noliqmn = 0.0 - q_noliqmx = 0.0 - scsacimn = 0.0 - scsacimx = 0.0 + IF ( ls .gt. 1 ) THEN + + gtmp(ix,kz) = 0.0 + qxw = 0.0 + dtmps = 0.0 + IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN !{ + IF ( ipconc .ge. 4 ) THEN ! (Ferrier 94) !{ - ldovol = .false. + if (lsw .gt. 1) THEN + qxw = an(ix,jy,kz,lsw) + ELSEIF ( iusewetsnow == 1 .and. temk(ix,jy,kz) .gt. tfr+1. .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) & + & .and. an(ix,jy,kz,lr) > qsmin) THEN + qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr)) + ENDIF - DO il = lc,lhab - ldovol = ldovol .or. ( lvol(il) .gt. 1 ) - ENDDO + vr = xvs ! db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) +! gtmp(ix,kz) = 3.6e18*(0.243*rhos**2/0.93)*(snu+2.)*an(ix,jy,kz,lns)*vr**2/(snu+1.) + + ksq = 0.189 ! Smith (1984, JAMC) for equiv. ice sphere + IF ( an(ix,jy,kz,lns) .gt. 1.e-7 ) THEN + IF ( qxw > qsmin ) THEN ! old version +! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & +! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + + ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size + gtmp(ix,kz) = 1.e18* 1.06214**2*(ksq*an(ix,jy,kz,ls) + (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow1* gsnow73/ & + & (an(ix,jy,kz,lns)*(917.)**2* gsnow53**2) + ENDIF + + ENDIF + +! tmp = Min(1.0,1.e3*(an(ix,jy,kz,ls))*db(ix,jy,kz)) +! gtmp(ix,kz) = Max( 1.0*gtmp(ix,kz), 750.0*(tmp)**1.98) + dtmps = gtmp(ix,kz) + dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz) + ELSE + gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25) + + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN !{ + dtmps = zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ELSE + dtmp(ix,kz) = dtmp(ix,kz) + & + & zswetc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) + ENDIF + ENDIF !} + ENDIF !} + + ENDIF !} + + ENDIF -! DO il = lc,lhab -! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) -! ENDDO - -! -! density maximums and minimums ! - +! ice crystal contribution (Heymsfield, 1977, JAS) ! -! Set terminal velocities... -! also set drag coefficients + IF ( li .gt. 1 .and. idbzci .ne. 0 ) THEN + + gtmp(ix,kz) = 0.0 + IF ( an(ix,jy,kz,li) .ge. 0.1e-3 ) THEN + gtmp(ix,kz) = Min(1.0,1.e3*(an(ix,jy,kz,li))*db(ix,jy,kz)) + dtmp(ix,kz) = dtmp(ix,kz) + 750.0*(gtmp(ix,kz))**1.98 + ENDIF + + ENDIF + +! +! graupel/hail contribution ! + IF ( lh .gt. 1 ) THEN ! { + gtmp(ix,kz) = 0.0 + dtmph = 0.0 + qxw = 0.0 - dtpinv = 1.d0/dtp + IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN -! + ltest = .false. + + IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .gt. 1.e-6 )) THEN + + IF ( lvh .gt. 1 ) THEN + + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + hwdn = Min( 900., Max( 100., hwdn ) ) + ELSE + hwdn = 500. ! hwdn1t + ENDIF -! -! electricity constants -! -! mixing ratio epsilon -! - qeps = 1.0e-20 + ENDIF -! rebound efficiency (erbnd) -! -! -! -! constants -! - cai = 21.87455 - caw = 17.2693882 - cbi = 7.66 - cbw = 35.86 + chw = an(ix,jy,kz,lnh) + IF ( chw .gt. 0.0 ) THEN ! (Ferrier 94) + xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*Max(1.0e-3,chw)) + IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN + xvh = Min( xvhmx, Max( xvhmn,xvh ) ) + chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + ENDIF + + IF ( lhw .gt. 1 ) THEN + IF ( iusewetgraupel .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhw) + ELSEIF ( iusewetgraupel .eq. 2 ) THEN + IF ( hwdn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhw) + ENDIF + ENDIF + ELSEIF ( iusewetgraupel .eq. 3 ) THEN + IF ( hwdn .lt. 300. .and. temk(ix,jy,kz) > tfr .and. an(ix,jy,kz,lr) > qhmin ) THEN + qxw = Min( an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + ENDIF + ENDIF + + IF ( lzh .gt. 1 ) THEN + ELSE + g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw +! ze = 0.224*1.e18*zx*(6./(pi*1000.))**2 + zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lh) + 0.776*qxw)*an(ix,jy,kz,lh)/chw + ze =1.e18*zx*(6./(pi*1000.))**2 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmph = ze + ENDIF + + ENDIF + + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF + + ELSE + + dtmph = 0.0 + + IF ( an(ix,jy,kz,lh) .ge. qhmin ) THEN + gtmp(ix,kz) = dadh*an(ix,jy,kz,lh)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN + dtmph = zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) +! +! & (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF + ENDIF + + + + ENDIF + - cp608 = 0.608 - ar = 841.99666 - br = 0.8 - aradcw = -0.27544 - bradcw = 0.26249e+06 - cradcw = -1.8896e+10 - dradcw = 4.4626e+14 - bta1 = 0.6 - cnit = 1.0e-02 - dragh = 0.60 - dnz00 = 1.225 - rho00 = 1.225 -! cs = 4.83607122 -! ds = 0.25 -! new values for cs and ds - cs = 12.42 - ds = 0.42 - pii = piinv ! 1./pi - pid4 = pi/4.0 -! qscrit = 6.0e-04 - gf1 = 1.0 ! gamma(1.0) - gf1p5 = 0.8862269255 ! gamma(1.5) - gf2 = 1.0 ! gamma(2.0) - gf3 = 2.0 ! gamma(3.0) - gf3p5 = 3.32335097 ! gamma(3.5) - gf4 = 6.00 ! gamma(4.0) - gf5 = 24.0 ! gamma(5.0) - gf6 = 120.0 ! gamma(6.0) - gf7 = 720.0 ! gamma(7.0) - gf4br = 17.837861981813607 ! gamma(4.0+br) - gf4ds = 10.41688578110938 ! gamma(4.0+ds) - gf4p5 = 11.63172839656745 ! gamma(4.0+0.5) - gf3ds = 3.0458730354120997 ! gamma(3.0+ds) - gf1ds = 0.8863557896089221 ! gamma(1.0+ds) - gr = 9.8 - gf43rds = 0.8929795116 ! gamma(4./3.) - gf53rds = 0.9027452930 ! gamma(5./3.) - gf73rds = 1.190639349 ! gamma(7./3.) - gf83rds = 1.504575488 ! gamma(8./3.) -! -! constants -! - c1f3 = 1.0/3.0 -! -! general constants for microphysics -! - brz = 100.0 - arz = 0.66 - cai = 21.87455 - caw = 17.2693882 - cbi = 7.66 - cbw = 35.86 - - bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/((1. + alphar)*(2. + alphar)*(3. + alphar)) - - vfrz = 0.523599*(dfrz)**3 - vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) - vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) + ENDIF ! } + + ENDIF ! na .gt. 5 - + + IF ( izieg .ge. 1 .and. lhl .gt. 1 ) THEN - tdtol = 1.0e-05 - thnuc = 233.15 - rw = 461.5 ! gas const. for water vapor - advisc0 = 1.832e-05 - advisc1 = 1.718e-05 ! dynamic viscosity - tka0 = 2.43e-02 ! thermal conductivity - tfrcbw = tfr - cbw - tfrcbi = tfr - cbi -! -! -! cw constants in mks units -! -! cwmasn = 4.25e-15 ! radius of 1.0e-6 - cwmasn = 5.23e-13 ! radius of 5.0e-6 - cwmasn5 = 5.23e-13 - cwradn = 5.0e-6 - cwmasx = 5.25e-10 ! radius of 50.0e-6 - mwfac = 6.0**(1./3.) - IF ( ipconc .ge. 2 ) THEN - cwmasn = xvmn(lc)*1000. - cwradn = 1.0e-6 - cwmasx = xvmx(lc)*1000. - ENDIF - rwmasn = xvmn(lr)*1000. - rwmasx = xvmx(lr)*1000. + hldn = 900.0 + gtmp(ix,kz) = 0.0 + dtmphl = 0.0 + qxw = 0.0 + -! -! ci constants in mks units -! - cimasn = Min(cimas0, 6.88e-13) ! 12 microns for 0.1871*(xmas(mgs,li)**(0.3429)) - cimasx = 1.0e-8 ! 338 microns - ccimx = 5000.0e3 ! max of 5000 per liter + IF ( lvhl .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + hldn = db(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + hldn = Min( 900., Max( 300., hldn ) ) + ELSE + hldn = 900. + ENDIF + ELSE + hldn = rho_qhl + ENDIF -! -! constants for paramerization -! -! -! set save counter (number of saves): nsvcnt -! -! nsvcnt = 0 - iend = 0 -! timetd1 = etime(tarray) -! timetd1 = tarray(1) + IF ( ipconc .ge. 5 ) THEN -! -!$ ndebug = -1 -! cmic$ cncall -!*********************************************************** -! start jy loop -!*********************************************************** -! + ltest = .false. -! do 9999 jy = 1,ny-jstag -! -! VERY IMPORTANT: SET jy = jgs -! - jy = jgs - - IF ( ipconc < 2 ) THEN ! Make a copy of cloud droplet mixing ratio to use for homogeneous freezing - DO kz = 1,nz - DO ix = 1,nx - t9(ix,jy,kz) = an(ix,jy,kz,lc) - ENDDO - ENDDO - ENDIF - -! -!..Gather microphysics -! - if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE' + IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ + chl = an(ix,jy,kz,lnhl) + IF ( chl .gt. 0.0 ) THEN !{ + xvhl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/ & + & (hldn*Max(1.0e-9,an(ix,jy,kz,lnhl))) + IF ( xvhl .lt. xvhlmn .or. xvhl .gt. xvhlmx ) THEN ! { + xvhl = Min( xvhlmx, Max( xvhlmn,xvhl ) ) + chl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvhl*hldn) + an(ix,jy,kz,lnhl) = chl + ENDIF ! } + IF ( lhlw .gt. 1 ) THEN + IF ( iusewethail .eq. 1 ) THEN + qxw = an(ix,jy,kz,lhlw) + ELSEIF ( iusewethail .eq. 2 ) THEN + IF ( hldn .lt. 300. ) THEN + qxw = an(ix,jy,kz,lhlw) + ENDIF + ENDIF + ENDIF + + IF ( lzhl .gt. 1 ) THEN !{ + ELSE !} - nxmpb = 1 - nzmpb = 1 - nxz = nx*nz - numgs = nxz/ngs + 1 -! write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE: nx,nz,nxz,numgs,ngs = ',nx,nz,nxz,numgs,ngs + g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) + zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lhl) + 0.776*qxw)*an(ix,jy,kz,lhl)/chl +! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lhl))**2/chl + ze = 0.224*1.e18*zx*(6./(pi*1000.))**2 + dtmp(ix,kz) = dtmp(ix,kz) + ze + dtmphl = ze + + ENDIF !} + ENDIF!} + ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze + ENDIF - do 1000 inumgs = 1,numgs - ngscnt = 0 - - do kz = nzmpb,nz - do ix = nxmpb,nx + + ELSE + + + IF ( an(ix,jy,kz,lhl) .ge. qhlmin ) THEN ! { + dadhl = ( db(ix,jy,kz) /(pi*hldn*cnohl) )**(.25) + gtmp(ix,kz) = dadhl*an(ix,jy,kz,lhl)**(0.25) + IF ( gtmp(ix,kz) .gt. 0.0 ) THEN ! { - pqs(1) = t00(ix,jy,kz) -! pqs(kz) = t00(ix,jy,kz) + zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl - theta(1) = an(ix,jy,kz,lt) - temg(1) = t0(ix,jy,kz) - temcg(1) = temg(1) - tfr - tqvcon = temg(1)-cbw - ltemq = (temg(1)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(1) = pqs(1)*tabqvs(ltemq) - qis(1) = pqs(1)*tabqis(ltemq) - - qss(1) = qvs(1) + dtmphl = zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) -! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN -! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz) -! ENDIF + IF ( temk(ix,jy,kz) .lt. tfr ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) + ELSE +! IF ( hwdn .gt. 700.0 ) THEN + dtmp(ix,kz) = dtmp(ix,kz) + & + & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) +! +! : (zhwetc*gtmp(ix,kz)**7)**0.95 +! ELSE +! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 +! ENDIF + ENDIF + ENDIF ! } + + ENDIF ! } + + ENDIF ! ipconc .ge. 5 - if ( temg(1) .lt. tfr ) then -! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = qis(kz) -! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / -! > (qcw(kz) + qci(kz)) - qss(1) = qis(1) - else -! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN -! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz) -! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz)) -! ENDIF - end if -! - ishail = .false. - IF ( lhl > 1 ) THEN - IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) ishail = .true. - ENDIF - - if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & - & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & - & an(ix,jy,kz,li) .gt. qxmin(li) .or. & - & an(ix,jy,kz,lr) .gt. qxmin(lr) .or. & - & an(ix,jy,kz,ls) .gt. qxmin(ls) .or. & - & an(ix,jy,kz,lh) .gt. qxmin(lh) .or. ishail ) then - ngscnt = ngscnt + 1 - igs(ngscnt) = ix - kgs(ngscnt) = kz - if ( ngscnt .eq. ngs ) goto 1100 - end if - enddo !ix - nxmpb = 1 - enddo !kz - 1100 continue - if ( ngscnt .eq. 0 ) go to 9998 + ENDIF ! izieg .ge. 1 .and. lhl .gt. 1 - if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5' + + + IF ( dtmp(ix,kz) .gt. 0.0 ) THEN + dbz(ix,jy,kz) = Max(dbzmin, 10.0*Log10(dtmp(ix,kz)) ) + + IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN + dbzmax = Max(dbzmax,dbz(ix,jy,kz)) + imx = ix + jmx = jy + kmx = kz + ENDIF + ELSE + dbz(ix,jy,kz) = dbzmin + IF ( lh > 1 .and. lhl > 1) THEN + IF ( an(ix,jy,kz,lh) > 1.0e-3 ) THEN + write(0,*) 'radardbz: qr,qh,qhl = ',an(ix,jy,kz,lr), an(ix,jy,kz,lh),an(ix,jy,kz,lhl) + write(0,*) 'radardbz: dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + + IF ( lzh>1 .and. lzhl>1 ) write(0,*) 'radardbz: zh, zhl = ',an(ix,jy,kz,lzh),an(ix,jy,kz,lzhl) + ENDIF + ENDIF + ENDIF -! write(0,*) 'allocating qc +! IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and. +! & dbz(ix,jy,kz) .le. 0.0 ) THEN +! write(0,*) 'dbz = ',dbz(ix,jy,kz) +! write(0,*) 'Hail intercept: ',xcnoh,ix,kz +! write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) +! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) +! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph +! ENDIF + IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN +! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN +! write(0,*) 'my_rank = ',my_rank + write(0,*) 'ix,jy,kz = ',ix,jy,kz + write(0,*) 'dbz = ',dbz(ix,jy,kz) + write(0,*) 'db, zhdryc = ',db(ix,jy,kz),zhdryc + write(0,*) 'Hail intercept: ',xcnoh,ix,kz + write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) + write(0,*) 'graupel density hwdn = ',hwdn + write(0,*) 'rain q: ',an(ix,jy,kz,lr) + write(0,*) 'ice q: ',an(ix,jy,kz,li) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lhl): ',an(ix,jy,kz,lhl) + IF (ipconc .ge. 3 ) write(0,*) 'rain c: ',an(ix,jy,kz,lnr) + IF ( lzr > 1 ) write(0,*) 'rain Z: ',an(ix,jy,kz,lzr) + IF ( ipconc .ge. 5 ) THEN + write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) + IF ( lhl .gt. 1 ) write(0,*) 'Hail (lnhl): ',an(ix,jy,kz,lnhl) + IF ( lzhl .gt. 1 ) THEN + write(0,*) 'Hail (lzhl): ',an(ix,jy,kz,lzhl) + write(0,*) 'chl,xvhl,dhl = ',chl,xvhl,(xvhl*6./3.14159)**(1./3.) + write(0,*) 'xvhlmn,xvhlmx = ',xvhlmn,xvhlmx + ENDIF + ENDIF + write(0,*) 'chw,xvh = ', chw,xvh + write(0,*) 'dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl + write(0,*) 'dtmpr = ',dtmpr + write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) + IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN + write(0,*) 'dbz out of bounds! STOP!' +! STOP + ENDIF + ENDIF + + ENDDO ! ix + ENDDO ! kz + ENDDO ! jy + - xv(:,:) = 0.0 -! xsfca(:,:) = 0.0 - xmas(:,:) = 0.0 - vtxbar(:,:,:) = 0.0 - xdia(:,:,:) = 0.0 - raindn(:,:) = 900. - cx(:,:) = 0.0 - alpha(:,:) = 0.0 - DO il = li,lhab - DO mgs = 1,ngscnt - rimdn(mgs,il) = rimedens ! xdn0(il) - ENDDO - ENDDO -! -! define temporaries for state variables to be used in calculations -! - do mgs = 1,ngscnt - kgsm(mgs) = max(kgs(mgs)-1,1) - kgsm2(mgs) = Max(kgs(mgs)-2,1) - kgsp(mgs) = min(kgs(mgs)+1,nz-1) - theta0(mgs) = 0.0 - thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs) - theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - qv0(mgs) = 0.0 - qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv) - qv0(mgs) ! qv0(mgs) is zero, so qwvp is the FULL qv! + + +! write(0,*) 'na,lr = ',na,lr + IF ( printyn .eq. 1 ) THEN +! IF ( dbzmax .gt. dbzmin ) THEN + write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx + write(iunit,*) 'qrw = ',an(imx,jmx,kmx,lr) + + IF ( lh .gt. 1 ) THEN + write(iunit,*) 'qi = ',an(imx,jmx,kmx,li) + write(iunit,*) 'qsw = ',an(imx,jmx,kmx,ls) + write(iunit,*) 'qhw = ',an(imx,jmx,kmx,lh) + IF ( lhl .gt. 1 ) write(iunit,*) 'qhl = ',an(imx,jmx,kmx,lhl) + ENDIF - pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) - rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) - rhoinv(mgs) = 1.0/rho0(mgs) - rhovt(mgs) = Sqrt(rho00/rho0(mgs)) - pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) ! pinit(kgs(mgs)) - temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) - temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs)) - temgkm2(mgs) = t0(igs(mgs),jy,kgsm2(mgs)) - pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) - temcg(mgs) = temg(mgs) - tfr - qss0(mgs) = (380.0)/(pres(mgs)) - pqs(mgs) = (380.0)/(pres(mgs)) - ltemq = (temg(mgs)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - qis(mgs) = pqs(mgs)*tabqis(ltemq) - es(mgs) = 6.1078e2*tabqvs(ltemq) - eis(mgs) = 6.1078e2*tabqis(ltemq) - cnostmp(mgs) = cno(ls) -! - il5(mgs) = 0 - if ( temg(mgs) .lt. tfr ) then - il5(mgs) = 1 - end if - enddo !mgs - IF ( ipconc < 1 .and. lwsm6 ) THEN - DO mgs = 1,ngscnt - tmp = Min( 0.0, temcg(mgs) ) - cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) - ENDDO ENDIF + + + RETURN + END subroutine radardd02 + +! ############################################################################## +! ############################################################################## + +! ##################################################################### +! ##################################################################### ! -! zero arrays that are used but not otherwise set (tm) -! - do mgs = 1,ngscnt - qhshr(mgs) = 0.0 - end do -! -! set temporaries for microphysics variables +! Subroutine for explicit cloud condensation and droplet nucleation ! - DO il = lv,lhab - do mgs = 1,ngscnt - qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) - ENDDO - end do + SUBROUTINE NUCOND & + & (nx,ny,nz,na,jyslab & + & ,nor,norz,dtp & + & ,dz3d & + & ,t0,t9 & + & ,an,dn,p2 & + & ,pn,w & + & ,ssfilt,t00,t77,flag_qndrop & + & ) - qxw(:,:) = 0.0 + + implicit none + + integer :: nx,ny,nz,na + integer :: nor,norz, jyslab ! ,nht,ngt,igsr + real :: dtp ! time step + logical :: flag_qndrop + + integer, parameter :: ng1 = 1 - scx(:,:) = 0.0 ! -! set shape parameters +! external temporary arrays ! - IF ( imurain == 1 ) THEN - alpha(:,lr) = alphar - ELSEIF ( imurain == 3 ) THEN - alpha(:,lr) = xnu(lr) - ENDIF + real t00(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t77(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - DO il = lc,lhab - do mgs = 1,ngscnt - IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) - DO ic = lr,lhab - dab0lh(mgs,il,ic) = dab0(ic,il) - dab1lh(mgs,il,ic) = dab1(ic,il) - ENDDO - ENDDO - end do - + real t0(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t1(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t3(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t4(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t5(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t6(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t7(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real t8(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real t9(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) -! DO mgs = 1,ngscnt - da0lh(:) = da0(lh) - da0lr(:) = da0(lr) - IF ( lzh < 1 .or. lzhl < 1 ) THEN - rzxhlh(:) = rzhl/rz - ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN - rzxhlh(:) = 1. - ENDIF - IF ( lzr > 1 ) THEN - rzxh(:) = 1. - rzxhl(:) = 1. - ELSE - rzxh(:) = rz - rzxhl(:) = rzhl - ENDIF - ! ENDDO - - IF ( lhl .gt. 1 ) THEN - DO mgs = 1,ngscnt - da0lhl(mgs) = da0(lhl) - ENDDO - ENDIF - - ventrx(:) = ventr - ventrxn(:) = ventrn - -! -! set concentrations -! -! ssmax = 0.0 - + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - if ( ipconc .ge. 1 ) then - do mgs = 1,ngscnt - cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) - IF ( lcina .gt. 1 ) THEN - cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) - ELSE - cina(mgs) = cx(mgs,li) - ENDIF - IF ( lcin > 1 ) THEN - ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin) - ENDIF - IF ( qx(mgs,li) .le. qxmin(li) .or. cx(mgs,li) .le. 0.0 ) THEN - cx(mgs,li) = 0.0 - an(igs(mgs),jy,kgs(mgs),lni) = 0.0 - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,li) - qx(mgs,li) = 0.0 - ENDIF - end do - end if - if ( ipconc .ge. 2 ) then - do mgs = 1,ngscnt - cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) - cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) - IF ( qx(mgs,lc) .le. qxmin(lc) .or. cx(mgs,lc) .le. 0.0 ) THEN - cx(mgs,lc) = 0.0 - an(igs(mgs),jy,kgs(mgs),lnc) = 0.0 - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lc) - qx(mgs,lc) = 0.0 - ENDIF - IF ( lccn .gt. 1 ) THEN - ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) - ELSE - ccnc(mgs) = 0.0 - ENDIF - end do -! ELSE -! cx(mgs,lc) = Abs(ccn) - end if - if ( ipconc .ge. 3 ) then - do mgs = 1,ngscnt - cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) - IF ( qx(mgs,lr) .le. qxmin(lr) .or. cx(mgs,lr) .le. 0.0 ) THEN - cx(mgs,lr) = 0.0 - an(igs(mgs),jy,kgs(mgs),lnr) = 0.0 - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lr) - qx(mgs,lr) = 0.0 - ENDIF - IF ( cx(mgs,lr) .eq. 0.0 .and. qx(mgs,lr) .lt. 3.0*qxmin(lr) ) THEN - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lr) - qx(mgs,lr) = 0.0 - ELSE - cx(mgs,lr) = Max( 1.e-9, cx(mgs,lr) ) - IF ( .not. ( cx(mgs,lr) < 1.e30 .and. cx(mgs,lr) > -1.e20 ) ) THEN - write(0,*) 'icezvd_gs: problem with cx(mgs,lr)! ',qx(mgs,lr),cx(mgs,lr) - STOP - ENDIF - ENDIF + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) +! real qv(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - end do - end if - if ( ipconc .ge. 4 ) then - do mgs = 1,ngscnt - cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) - IF ( qx(mgs,ls) .le. qxmin(ls) .or. cx(mgs,ls) .le. 0.0 ) THEN - cx(mgs,ls) = 0.0 - an(igs(mgs),jy,kgs(mgs),lns) = 0.0 - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,ls) - qx(mgs,ls) = 0.0 - ENDIF - IF ( cx(mgs,ls) .eq. 0.0 .and. qx(mgs,ls) .lt. 3.0*qxmin(ls) ) THEN - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,ls) - qx(mgs,ls) = 0.0 - ELSE - cx(mgs,ls) = Max( 1.e-9, cx(mgs,ls) ) + real ssfilt(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) + - IF ( ilimit .ge. ipc(ls) ) THEN - tmp = (xdn0(ls)*cx(mgs,ls))/(rho0(mgs)*qx(mgs,ls)) - tmp2 = (tmp*(3.14159))**(1./3.) - cnox = cx(mgs,ls)*(tmp2) - IF ( cnox .gt. 3.0*cno(ls) ) THEN - cx(mgs,ls) = 3.0*cno(ls)/tmp2 - ENDIF - ENDIF - ENDIF - end do - end if - if ( ipconc .ge. 5 ) then - do mgs = 1,ngscnt + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) - cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) - IF ( qx(mgs,lh) .le. qxmin(lh) .or. cx(mgs,lh) .le. 0.0 ) THEN - cx(mgs,lh) = 0.0 - an(igs(mgs),jy,kgs(mgs),lnh) = 0.0 - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) - qx(mgs,lh) = 0.0 - ENDIF - IF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) - qx(mgs,lh) = 0.0 - ELSE - cx(mgs,lh) = Max( 1.e-9, cx(mgs,lh) ) - IF ( ilimit .ge. ipc(lh) ) THEN - tmp = (xdn0(lh)*cx(mgs,lh))/(rho0(mgs)*qx(mgs,lh)) - tmp2 = (tmp*(3.14159))**(1./3.) - cnox = cx(mgs,lh)*(tmp2) - IF ( cnox .gt. 3.0*cno(lh) ) THEN - cx(mgs,lh) = 3.0*cno(lh)/tmp2 - ENDIF - ENDIF - ENDIF - end do - end if + real dz3d(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz) - if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then - do mgs = 1,ngscnt + + ! local - cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) - IF ( qx(mgs,lhl) .le. qxmin(lhl) .or. cx(mgs,lhl) .le. 0.0 ) THEN - cx(mgs,lhl) = 0.0 - an(igs(mgs),jy,kgs(mgs),lnhl) = 0.0 - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) - qx(mgs,lhl) = 0.0 - ENDIF - IF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN - qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) - qx(mgs,lhl) = 0.0 - ELSE - cx(mgs,lhl) = Max( 1.e-9, cx(mgs,lhl) ) - IF ( ilimit .ge. ipc(lhl) ) THEN - tmp = (xdn0(lhl)*cx(mgs,lhl))/(rho0(mgs)*qx(mgs,lhl)) - tmp2 = (tmp*(3.14159))**(1./3.) - cnox = cx(mgs,lhl)*(tmp2) - IF ( cnox .gt. 3.0*cno(lhl) ) THEN - cx(mgs,lhl) = 3.0*cno(lhl)/tmp2 - ENDIF - ENDIF - ENDIF - end do - end if +! +! declarations microphysics and for gather/scatter ! -! Set mean particle volume -! - IF ( ldovol ) THEN - - vx(:,:) = 0.0 + integer nxmpb,nzmpb,nxz + integer mgs,ngs,numgs,inumgs + parameter (ngs=500) + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs) + integer nsvcnt + + integer ix,kz,i,n, kp1 + integer :: jy, jgs + integer ixb,ixe,jyb,jye,kzb,kze + + integer itile,jtile,ktile + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg - DO il = li,lhab +! +! Variables for Ziegler warm rain microphysics +! - IF ( lvol(il) .ge. 1 ) THEN - DO mgs = 1,ngscnt - vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) - ENDDO + real ccnc(ngs), ccna(ngs), cnuc(ngs), cwnccn(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real ssmax(ngs) ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real ventrx(ngs) + real ventrxn(ngs) + real volb, t2s + real, parameter :: aa1 = 9.44e15, aa2 = 5.78e3 ! a1 in Ziegler - ENDIF + real ec0, ex1, ft, rhoinv(ngs) + + real chw, g1, rd1 - ENDDO + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super + real x,y,del,r,alpr + double precision :: vent1,vent2 + real g1palp + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation - ENDIF + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real cn(ngs) + integer ltemq + + integer il + real es(ngs) ! ss(ngs), + real eis(ngs) + real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs) + real ssfjp1(ngs),ssfjm1(ngs) + real ssfip1(ngs),ssfim1(ngs) + real supcb, supmx + parameter (supcb=0.5,supmx=238.0) + real r2dxm, r2dym, r2dzm + real dssdz, dssdy, dssdx +! real tqvcon + real epsi,d + parameter (epsi = 0.622, d = 0.266) + real r1,qevap ! ,slv + + real vr,nrx,qr,z1,z2,rdi,alp,xnutmp,xnuc + real ctmp, ccwtmp + real f5, qvs0 ! Kessler condensation factor + real :: t0p1, t0p3 + real qvex + +! real, dimension(ngs) :: temp, tempc, elv, elf, els, pqs, theta, temg, temcg + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs) + real temp(ngs),tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) ! ,tembzg(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real felv(ngs),felf(ngs),fels(ngs) + real felvcp(ngs) + real gamw(ngs),gams(ngs) ! qciavl(ngs), + real tsqr(ngs),ssi(ngs),ssw(ngs) + real cc3(ngs),cqv1(ngs),cqv2(ngs) + real qcwtmp(ngs),qtmp + real fvent(ngs) !,fraci(ngs),fracl(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) + real fschm(ngs),fpndl(ngs) -! -! set factors -! - do mgs = 1,ngscnt -! - ssi(mgs) = qx(mgs,lv)/qis(mgs) - ssw(mgs) = qx(mgs,lv)/qvs(mgs) -! - tsqr(mgs) = temg(mgs)**2 -! - temgx(mgs) = min(temg(mgs),313.15) - temgx(mgs) = max(temgx(mgs),233.15) - felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) -! - temcgx(mgs) = min(temg(mgs),273.15) - temcgx(mgs) = max(temcgx(mgs),223.15) - temcgx(mgs) = temcgx(mgs)-273.15 + real pres(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs) + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real qss0(ngs) + real fcqv1(ngs) + real wvel(ngs),wvelkm1(ngs) -! felf = latent heat of fusion, fels = LH of sublimation, felv = LH of vaporization - felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 -! - fels(mgs) = felv(mgs) + felf(mgs) -! - felvs(mgs) = felv(mgs)*felv(mgs) - felss(mgs) = fels(mgs)*fels(mgs) + real wvdf(ngs),tka(ngs) + real advisc(ngs) + + real rwvent(ngs) - IF ( eqtset <= 1 ) THEN - felvcp(mgs) = felv(mgs)*cpi - felscp(mgs) = fels(mgs)*cpi - felfcp(mgs) = felf(mgs)*cpi - ELSE - tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) - IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) - cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & - +cpigb*(tmp) - felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm - felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm - felfcp(mgs) = felf(mgs)/cvm - ENDIF -! - fgamw(mgs) = felvcp(mgs)/pi0(mgs) - fgams(mgs) = felscp(mgs)/pi0(mgs) -! - fcqv1(mgs) = 4098.0258*pi0(mgs)*fgamw(mgs) - fcqv2(mgs) = 5807.6953*pi0(mgs)*fgams(mgs) - fcc3(mgs) = felfcp(mgs)/pi0(mgs) -! -! fwvdf = water vapor diffusivity - fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)*(101325.0/(pres(mgs))) -! -! fadvisc = 1/Reynolds number - fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))*(temg(mgs)/296.0)**(1.5) -! - fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) -! - temcgx(mgs) = min(temg(mgs),273.15) - temcgx(mgs) = max(temcgx(mgs),233.15) - temcgx(mgs) = temcgx(mgs)-273.15 - fci(mgs) = (2.118636 + 0.007371*(temcgx(mgs)))*(1.0e+03) -! - if ( temg(mgs) .lt. 273.15 ) then - temcgx(mgs) = min(temg(mgs),273.15) - temcgx(mgs) = max(temcgx(mgs),233.15) - temcgx(mgs) = temcgx(mgs)-273.15 - fcw(mgs) = 4203.1548 + (1.30572e-2)*((temcgx(mgs)-35.)**2) & - & + (1.60056e-5)*((temcgx(mgs)-35.)**4) - end if - if ( temg(mgs) .ge. 273.15 ) then - temcgx(mgs) = min(temg(mgs),308.15) - temcgx(mgs) = max(temcgx(mgs),273.15) - temcgx(mgs) = temcgx(mgs)-273.15 - fcw(mgs) = 4243.1688 + (3.47104e-1)*(temcgx(mgs)**2) - end if -! - ftka(mgs) = tka0*fadvisc(mgs)/advisc1 ! thermal conductivity -! fthdf(mgs) = ftka(mgs)*cpi*rhoinv(mgs) -! - fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) ! Schmidt number -! fpndl(mgs) = (fakvisc(mgs)/fthdf(mgs)) ! Prandl number (not used) -! - fai(mgs) = (fels(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) - fbi(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qis(mgs))) - fav(mgs) = (felv(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) - fbv(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qvs(mgs))) -! - end do -! -! -! ice habit fractions -! -! -! -! Set density -! - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set density' -! - do mgs = 1,ngscnt - xdn(mgs,li) = xdn0(li) - xdn(mgs,lc) = xdn0(lc) - xdn(mgs,lr) = xdn0(lr) - xdn(mgs,ls) = xdn0(ls) - xdn(mgs,lh) = xdn0(lh) - IF ( lvol(ls) .gt. 1 ) THEN - IF ( vx(mgs,ls) .gt. 0.0 .and. qx(mgs,ls) .gt. qxmin(ls) ) THEN - xdn(mgs,ls) = Min( xdnmx(ls), Max( xdnmn(ls), rho0(mgs)*qx(mgs,ls)/vx(mgs,ls) ) ) - ENDIF - ENDIF + real :: qx(ngs,lv:lhab) + real :: cx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: alpha(ngs,lc:lhab) + real :: zx(ngs,lr:lhab) - IF ( lvol(lh) .gt. 1 ) THEN - IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN - IF ( mixedphase ) THEN - ELSE - dnmx = xdnmx(lh) - ENDIF - xdn(mgs,lh) = Min( dnmx, Max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) ) - vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) - ENDIF - ENDIF - IF ( lhl .gt. 1 ) THEN + logical zerocx(lc:lqmx) - xdn(mgs,lhl) = xdn0(lhl) + integer, parameter :: iunit = 0 + + real :: frac, hwdn, tmpg + + real :: cvm + + integer :: kstag + + integer :: count + - IF ( lvol(lhl) .gt. 1 ) THEN - IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN +! ------------------------------------------------------------------------------- + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 - IF ( mixedphase .and. lhlw > 1 ) THEN - ELSE - dnmx = xdnmx(lhl) - ENDIF + jy = 1 + kstag = 0 + pb(:) = 0.0 + pinit(:) = 0.0 + + IF ( ipconc <= 1 .or. isedonly == 2 ) GOTO 2200 - xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) - vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) - ENDIF - ENDIF +! +! Ziegler nucleation +! - ENDIF + ssfilt(:,:,:) = 0.0 + ssmx = 0 + count = 0 -! adjust density for wet snow and graupel (Ferrier 94) -! (aps): for the time being, do not adjust density until we keep track of fully melted snow/graupel -! -! IF (mixedphase) THEN - IF (qsdenmod) THEN - IF(fsw(mgs) .gt. 0.01) THEN - xdn(mgs,ls) = (1.-fsw(mgs))*rho_qs + fsw(mgs)*rho_qr !Ferrier: 100./(1.-fsw(mgs)) - IF(fsw(mgs) .eq. 1.) xdn(mgs,ls) = rho_qr ! fsw = 1 means it's liquid water, yo! - ENDIF - ENDIF + do kz = 1,nz-kstag + do ix = 1,nx - IF (qhdenmod) THEN -! IF(fhw(mgs) .gt. 0.01) THEN -! IF(fhw(mgs) .lt. 1.) xdn(mgs,lh) = rho_qh / (1. - fhw(mgs)) !Ferrier: 400./(1.-fsw(mgs)) -! IF(fhw(mgs) .eq. 1.) xdn(mgs,lh) = rho_qr ! fhw = 1 means it's liquid water, yo! -! ENDIF - ENDIF -! ENDIF + temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz) + t0(ix,jy,kz) = temp1 + ltemq = Int( (temp1-163.15)/fqsat+1.5 ) + ltemq = Min( nqsat, Max(1,ltemq) ) - end do + c1 = t00(ix,jy,kz)*tabqvs(ltemq) + + ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values + + + ENDDO + ENDDO ! -! set some values for ice nucleation -! - do mgs = 1,ngscnt - kp1 = Min(nz, kgs(mgs)+1 ) - wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & - & +w(igs(mgs),jgs,kgs(mgs))) - wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & - & +w(igs(mgs),jgs,Max(1,kgs(mgs)-1))) - kgsm(mgs) = max(kgs(mgs)-1,1) - kgsp(mgs) = min(kgs(mgs)+1,nz-1) - cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) - cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) - cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) - end do +! jy = 1 ! working on a 2d slab +!! VERY IMPORTANT: SET jgs = jy + + jgs = jy ! -! Set a couple of cloud variables... +!..Gather microphysics ! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Gather stage' -! SUBROUTINE setvt(ngscnt,qx,qxmin,cx,rho0,rhovt,xdia,cno, -! : xmas,xdn,xvmn,xvmx,xv,cdx, -! : ipconc,ndebug) -! SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno, & -! & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & -! & ipconc1,ndebug1,ngs,nz,kgs,cwnccn,fadvisc, & -! & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & -! & itype1a,itype2a,temcg,infdo,alpha) + nxmpb = 1 + nzmpb = 1 + nxz = nx*nz + numgs = nxz/ngs + 1 - call setvtz(ngscnt,ngs,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & - & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & - & ipconc,ndebug,ngs,nz,kgs,fadvisc, & - & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,0,alpha,0) + do 2000 inumgs = 1,numgs + ngscnt = 0 - IF ( lwsm6 .and. ipconc == 0 ) THEN - tmp = Max(qxmin(lh), qxmin(ls)) - DO mgs = 1,ngscnt - sum = qx(mgs,lh) + qx(mgs,ls) - IF ( sum > tmp ) THEN - vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum - ELSE - vt2ave(mgs) = 0.0 - ENDIF - ENDDO - ENDIF + kzb = nzmpb + kze = nz-kstag + ! if (kzbeg .le. nzmpb .and. kzend .gt. nzmpb) kzb = nzmpb -! -! Set number concentrations (need xdia from setvt) -! - if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration' - IF ( ipconc .lt. 1 ) THEN - cina(1:ngscnt) = cx(1:ngscnt,li) - ENDIF - if ( ipconc .lt. 5 ) then - do mgs = 1,ngscnt + ixb = nxmpb + ixe = itile +! if (ixbeg .le. nxmpb .and. ixend .gt. nxmpb) ixb = nxmpb + do kz = kzb,kze + do ix = nxmpb,nx - IF ( ipconc .lt. 3 ) THEN -! cx(mgs,lr) = 0.0 - if ( qx(mgs,lr) .gt. qxmin(lh) ) then -! cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) -! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) - end if - ENDIF + pqs(1) = 380.0/(pn(ix,jy,kz) + pb(kz)) + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) - IF ( ipconc .lt. 4 ) THEN -! tmp = cx(mgs,ls) -! cx(mgs,ls) = 0.0 - if ( qx(mgs,ls) .gt. qxmin(ls) ) then -! cx(mgs,ls) = cno(ls)*xdia(mgs,ls,1) -! xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) - end if - ENDIF ! ( ipconc .lt. 4 ) + temcg(1) = temg(1) - tfr + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) - IF ( ipconc .lt. 5 ) THEN + qss(1) = qvs(1) -! cx(mgs,lh) = 0.0 - if ( qx(mgs,lh) .gt. qxmin(lh) ) then -! cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) -! xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) -! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + if ( temg(1) .lt. tfr ) then + end if +! + if ( (temg(1) .gt. tfrh ) .and. & + & ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & ( an(ix,jy,kz,lr) .gt. qxmin(lr) .and. rcond == 2 ) & + & )) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 2100 end if - ENDIF ! ( ipconc .lt. 5 ) + end do !ix - end do - end if + nxmpb = 1 + end do !kz +! if ( jy .eq. (ny-jstag) ) iend = 1 + 2100 continue - IF ( ipconc .ge. 2 ) THEN - DO mgs = 1,ngscnt - rb(mgs) = 0.5*xdia(mgs,lc,1)*((1./(1.+cnu)))**(1./6.) - xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & - & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) - IF ( rb(mgs) .gt. 3.51e-6 ) THEN -! rh(mgs) = Max( 0.5d0*xdia(mgs,lc,1), 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) - rh(mgs) = Max( 41.d-6, 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) - ELSE - rh(mgs) = 41.d-6 - ENDIF - IF ( xl2p(mgs) .gt. 0.0 ) THEN - nh(mgs) = 4.2d9*xl2p(mgs) - ELSE - nh(mgs) = 1.e30 - ENDIF - ENDDO + if ( ngscnt .eq. 0 ) go to 29998 + + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: dbg = 8' + +! write(0,*) 'NUCOND: dbg = 8, ngscnt,ssmx = ',ngscnt,ssmx + + + qx(:,:) = 0.0 + cx(:,:) = 0.0 + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) ENDIF ! +! define temporaries for state variables to be used in calculations ! -! -! -! maximum depletion tendency by any one source -! -! - if( ndebug .ge. 0 ) THEN -!mpi! write(iunit,*) 'Set depletion max/min1' -! call flush(iunit) - endif - do mgs = 1,ngscnt - qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))/dtp ! depletion by all vap. dep to ice. - qvimxd(mgs) = max(qvimxd(mgs), 0.0) -! qimxd(mgs) = 0.20*qx(mgs,li)/dtp -! qcmxd(mgs) = 0.20*qx(mgs,lc)/dtp -! qrmxd(mgs) = 0.20*qx(mgs,lr)/dtp -! qsmxd(mgs) = 0.20*qx(mgs,ls)/dtp -! qhmxd(mgs) = 0.20*qx(mgs,lh)/dtp + DO mgs = 1,ngscnt + qx(mgs,lv) = an(igs(mgs),jy,kgs(mgs),lv) + DO il = lc,lhab + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO - frac = 0.1d0 - qimxd(mgs) = frac*qx(mgs,li)/dtp - qcmxd(mgs) = frac*qx(mgs,lc)/dtp - qrmxd(mgs) = frac*qx(mgs,lr)/dtp - qsmxd(mgs) = frac*qx(mgs,ls)/dtp - qhmxd(mgs) = frac*qx(mgs,lh)/dtp - IF ( lhl > 1 ) qhlmxd(mgs) = frac*qx(mgs,lhl)/dtp - end do -! - if( ndebug .ge. 0 ) THEN -!mpi! write(iunit,*) 'Set depletion max/min2' -! call flush(iunit) - endif + qcwtmp(mgs) = qx(mgs,lc) - do mgs = 1,ngscnt -! - if ( qx(mgs,lc) .le. qxmin(lc) ) then - ccmxd(mgs) = 0.20*cx(mgs,lc)/dtp - else - IF ( ipconc .ge. 2 ) THEN - ccmxd(mgs) = frac*cx(mgs,lc)/dtp - ELSE - ccmxd(mgs) = frac*qx(mgs,lc)/(xmas(mgs,lc)*rho0(mgs)*dtp) - ENDIF - end if + + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) ! + thetap(mgs) = 0.0 + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = qx(mgs,lv) + qwvp(mgs) = qx(mgs,lv) - qv0(mgs) + + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/rho0(mgs)) + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) ! - if ( qx(mgs,li) .le. qxmin(li) ) then - cimxd(mgs) = frac*cx(mgs,li)/dtp - else - IF ( ipconc .ge. 1 ) THEN - cimxd(mgs) = frac*cx(mgs,li)/dtp - ELSE - cimxd(mgs) = frac*qx(mgs,li)/(xmas(mgs,li)*rho0(mgs)*dtp) - ENDIF - end if + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + es(mgs) = 6.1078e2*tabqvs(ltemq) + qss(mgs) = qvs(mgs) + + + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) ! + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + ELSE ! equation set 2 in cm1 + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + ENDIF + + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 ! - crmxd(mgs) = 0.10*cx(mgs,lr)/dtp - csmxd(mgs) = frac*cx(mgs,ls)/dtp - chmxd(mgs) = frac*cx(mgs,lh)/dtp + fels(mgs) = felv(mgs) + felf(mgs) + fcqv1(mgs) = 4098.0258*felv(mgs)*cpi - ccmxd(mgs) = frac*cx(mgs,lc)/dtp - cimxd(mgs) = frac*cx(mgs,li)/dtp - crmxd(mgs) = frac*cx(mgs,lr)/dtp - csmxd(mgs) = frac*cx(mgs,ls)/dtp - chmxd(mgs) = frac*cx(mgs,lh)/dtp + wvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pb(kgs(mgs)) + pn(igs(mgs),jgs,kgs(mgs)))) ! diffusivity of water vapor, Hall and Pruppacher (76) + advisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) ! dynamic viscosity (SMT; see Beard & Pruppacher 71) + tka(mgs) = tka0*advisc(mgs)/advisc1 ! thermal conductivity - qxmxd(mgs,lv) = Max(0.0, 0.1*(qx(mgs,lv) - qvs(mgs))/dtp) - DO il = lc,lhab - qxmxd(mgs,il) = frac*qx(mgs,il)/dtp - cxmxd(mgs,il) = frac*cx(mgs,il)/dtp ENDDO - end do - ! +! load concentrations ! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + end do + end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) + cwnccn(mgs) = cwccn*rho0(mgs)/rho00 + cn(mgs) = 0.0 + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = cwnccn(mgs) + ENDIF + IF ( lccna > 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) + ELSE + IF ( lccn > 1 ) THEN + ccna(mgs) = cwnccn(mgs) - ccnc(mgs) + ELSE + ccna(mgs) = cx(mgs,lc) ! approximation of number of activated ccn + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + end do + end if + +! cnuc(1:ngscnt) = cwccn*rho0(mgs)/rho00*(1. - renucfrac) + ccnc(1:ngscnt)*renucfrac + DO mgs = 1,ngscnt + cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac + ENDDO + +! Set density ! -! -! microphysics source terms (1/s) for mixing ratios -! -! -! -! Collection efficiencies: -! - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies' -! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_DR: Set density' + do mgs = 1,ngscnt -! -! -! - erw(mgs) = 0.0 - esw(mgs) = 0.0 - ehw(mgs) = 0.0 - ehlw(mgs) = 0.0 -! ehxw(mgs) = 0.0 -! - err(mgs) = 0.0 - esr(mgs) = 0.0 - il2(mgs) = 0 - il3(mgs) = 0 - ehr(mgs) = 0.0 - ehlr(mgs) = 0.0 -! ehxr(mgs) = 0.0 -! - eri(mgs) = 0.0 - esi(mgs) = 0.0 - ehi(mgs) = 0.0 - ehli(mgs) = 0.0 -! ehxi(mgs) = 0.0 -! - ers(mgs) = 0.0 - ess(mgs) = 0.0 - ehs(mgs) = 0.0 - ehls(mgs) = 0.0 - ehscnv(mgs) = 0.0 -! ehxs(mgs) = 0.0 -! - eiw(mgs) = 0.0 - eii(mgs) = 0.0 + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + end do - icwr(mgs) = 1 - IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN - cwrad = 0.5*xdia(mgs,lc,1) - DO il = 1,8 - IF ( cwrad .ge. 1.e-6*cwr(il,1) ) icwr(mgs) = il - ENDDO - ENDIF + ventrx(:) = ventr + ventrxn(:) = ventrn + - irwr(mgs) = 1 - IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN - rwrad = 0.5*xdia(mgs,lr,3) ! changed to mean volume diameter (10/6/06) - DO il = 1,6 - IF ( rwrad .ge. 1.e-6*grad(il,1) ) irwr(mgs) = il - ENDDO - ENDIF +! write(0,*) 'NUCOND: Set ssf variables, ssmxinit =',ssmxinit + ssmx = 0.0 + DO mgs = 1,ngscnt + + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,Max(1,kgs(mgs)-1))) + ssat0(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) + ssf(mgs) = ssfilt(igs(mgs),jgs,kgs(mgs)) +! ssmx = Max( ssmx, ssf(mgs) ) + + + ssfkp1(mgs) = ssfilt(igs(mgs),jgs,Min(nz-1,kgs(mgs)+1)) + ssfkm1(mgs) = ssfilt(igs(mgs),jgs,Max(1,kgs(mgs)-1)) - igwr(mgs) = 1 -! IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN -! rwrad = 0.5*xdia(mgs,lr,1) -! setting erw = 1 always, so now use igwr for graupel - IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN - rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter (10/6/06) - DO il = 1,6 - IF ( rwrad .ge. 1.e-6*grad(il,1) ) igwr(mgs) = il - ENDDO - ENDIF - IF ( lhl .gt. 1 ) THEN ! hail is turned on - ihlr(mgs) = 1 - IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN - rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter (10/6/06) - DO il = 1,6 - IF ( rwrad .ge. 1.e-6*grad(il,1) ) ihlr(mgs) = il ENDDO - ENDIF - ENDIF + + ! +! cloud water variables ! -! Ice-Ice: Collection (cxc) efficiencies -! -! - if ( qx(mgs,li) .gt. qxmin(li) ) then -! IF ( ipconc .ge. 14 ) THEN -! eii(mgs)=0.1*exp(0.1*temcg(mgs)) -! if ( temg(mgs) .lt. 243.15 .and. qx(mgs,lc) .gt. 1.e-6 ) then -! eii(mgs)=0.1 -! end if -! -! ELSE - eii(mgs) = exp(0.025*Min(temcg(mgs),0.0)) ! alpha1 from LFO83 (21) -! ENDIF - if ( temg(mgs) .gt. 273.15 ) eii(mgs) = 1.0 - end if -! -! -! -! Ice-cloud water: Collection (cxc) efficiencies + + if ( ndebug .gt. 0 )write(0,*) 'ICEZVD_DR: Set cloud water variables' + + do mgs = 1,ngscnt + xv(mgs,lc) = 0.0 + IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e6 ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) + xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) + ELSE + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN + xmas(mgs,lc) = & + & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & + & xdn(mgs,lc)*xvmx(lc) ) + + cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) + + ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN + xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + + ELSE + xmas(mgs,lc) = cwmasn + ENDIF + ENDIF + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + + + end do ! +! rain ! - eiw(mgs) = 0.0 - if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then - if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then -! erm 5/10/2007 test following change: -! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then - eiw(mgs) = 0.5 + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) ) then + + if ( ipconc .ge. 3 ) then + xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-9,cx(mgs,lr))) +! parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 ) ! mks + IF ( xv(mgs,lr) .gt. xvmx(lr) ) THEN + xv(mgs,lr) = xvmx(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmx(lr)*xdn(mgs,lr)) + ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN + xv(mgs,lr) = xvmn(lr) + cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) + ENDIF + + xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) + xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) + IF ( imurain == 3 ) THEN +! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) + xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) + ELSE ! imurain == 1, Characteristic diameter (1/lambda) + xdia(mgs,lr,1) = (6.*piinv*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) + ENDIF +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + +! Inverse exponential version: +! xdia(mgs,lr,1) = +! > (qx(mgs,lr)*rho0(mgs) +! > /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) + ELSE + xdia(mgs,lr,1) = & + & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) end if - if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 + else + xdia(mgs,lr,1) = 1.e-9 +! rwrad(mgs) = 0.5*xdia(mgs,lr,1) end if -! -! -! -! Rain: Collection (cxc) efficiencies -! -! - if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lc).gt.qxmin(lc) ) then - IF ( lnr .gt. 1 ) THEN - erw(mgs) = 1.0 + end do - ELSE -! cwrad = 0.5*xdia(mgs,lc,1) -! erw(mgs) = -! > min((aradcw + cwrad*(bradcw + cwrad* -! < (cradcw + cwrad*(dradcw)))), 1.0) -! IF ( xdia(mgs,lc,1) .lt. 2.4e-06 .or. xdia(mgs,lr,1) .le. 50.0e-6 ) THEN -! erw(mgs)=0.0 -! ENDIF -! erw(mgs) = ew(icwr(mgs),igwr(mgs)) -! interpolate along droplet radius - ic = icwr(mgs) - icp1 = Min( 8, ic+1 ) - ir = irwr(mgs) - irp1 = Min( 6, ir+1 ) - cwrad = 0.5*xdia(mgs,lc,3) - rwrad = 0.5*xdia(mgs,lr,3) - - slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) - slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) +! +! Ventilation coefficients -! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + do mgs = 1,ngscnt - x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) - x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) - slope1 = (x2 - x1)*grad(ir,2) + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & + & (temg(mgs)/296.0)**(1.5) - erw(mgs) = Max(0.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) )) + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) -! write(iunit,*) 'erw: ',erw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 -! write(iunit,*) + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)* & + & (101325.0/(pres(mgs))) + + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) - erw(mgs) = Max(0.0, erw(mgs) ) - IF ( rwrad .lt. 50.e-6 ) THEN - erw(mgs) = 0.0 - ELSEIF ( rwrad .lt. 100.e-6 ) THEN ! linear change from zero at 50 to erw at 100 microns - erw(mgs) = erw(mgs)*(rwrad - 50.e-6)/50.e-6 - ENDIF + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) - ENDIF - end if - IF ( cx(mgs,lc) .le. 0.0 ) erw(mgs) = 0.0 -! - if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr).gt.qxmin(lr) ) then - err(mgs)=1.0 - end if -! - if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,ls).gt.qxmin(ls) ) then - ers(mgs)=1.0 - end if -! - if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,li).gt.qxmin(li) ) then -! IF ( vtxbar(mgs,lr,1) .gt. vtxbar(mgs,li,1) .and. -! : xdia(mgs,lr,3) .gt. 200.e-6 .and. xdia(mgs,li,3) .gt. 100.e-6 ) THEN - eri(mgs) = eri0 -! cwrad = 0.5*xdia(mgs,li,3) -! eri(mgs) = -! > 1.0*min((aradcw + cwrad*(bradcw + cwrad* -! < (cradcw + cwrad*(dradcw)))), 1.0) -! ENDIF -! if ( xdia(mgs,li,1) .lt. 10.e-6 ) eri(mgs)=0.0 - if ( xdia(mgs,li,1) .lt. 40.e-6 ) eri(mgs)=0.0 - end if + end do ! ! -! Snow aggregates: Collection (cxc) efficiencies +! Ziegler nucleation ! -! Modified by ERM with a linear function for small droplets and large -! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997, which -! allows collection of very small droplets, albeit at low efficiency. But slow -! fall speeds of snow make up for the efficiency. ! - esw(mgs) = 0.0 - if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lc).gt.qxmin(lc) ) then - esw(mgs) = 0.5 - if ( xdia(mgs,lc,1) .gt. 15.e-6 .and. xdia(mgs,ls,1) .gt. 100.e-6) then - esw(mgs) = 0.5 - ELSEIF ( xdia(mgs,ls,1) .ge. 500.e-6 ) THEN - esw(mgs) = Min(0.5, 0.05 + (0.8-0.05)/(40.e-6)*xdia(mgs,lc,1) ) +! cloud evaporation, condensation, and nucleation +! sqsat -> qss(mgs) + + DO mgs=1,ngscnt + dcloud = 0.0 + IF ( temg(mgs) .le. tfrh ) THEN + CYCLE ENDIF - end if -! - if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lr).gt.qxmin(lr) & - & .and. temg(mgs) .lt. tfr - 1. & - & ) then - esr(mgs)=Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,ls,1)) - IF ( qx(mgs,ls) < 1.e-4 .and. qx(mgs,lr) < 1.e-4 ) il2(mgs) = 1 - end if - - IF ( ipconc < 3 .and. temg(mgs) < tfr .and. qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr) < 1.e-4 ) THEN - il3(mgs) = 1 - ENDIF + + IF( ssat0(mgs) .GT. 0. .OR. ssf(mgs) .GT. 0. ) GO TO 620 +!6/4 IF( qvap(mgs) .EQ. qss(mgs) ) GO TO 631 ! -! if ( qx(mgs,ls).gt.qxmin(ls) ) then - if ( temcg(mgs) < 0.0 ) then - IF ( ipconc .lt. 4 .or. temcg(mgs) < -25. ) THEN - ess(mgs) = 0.0 -! ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) -! ess(mgs)=min(0.1,ess(mgs)) - ELSE - IF ( temcg(mgs) > -25. .and. temcg(mgs) < -20. ) THEN - ess(mgs) = ess0*Exp(ess1*(-20.) )*(temcg(mgs) + 25.)/5. - ELSEIF ( temcg(mgs) >= -20.0 ) THEN - ess(mgs) = ess0*Exp(ess1*Min( temcg(mgs), 0.0 ) ) - ENDIF - ENDIF - end if +!.... EVAPORATION. QV IS LESS THAN qss(mgs). +!.... EVAPORATE CLOUD FIRST ! - if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,li).gt.qxmin(li) ) then -! IF ( ipconc .lt. 4 ) THEN - IF ( ipconc < 1 .and. lwsm6 ) THEN - esi(mgs) = exp(0.7*min(temcg(mgs),0.0)) + IF ( qx(mgs,lc) .LE. 0. ) GO TO 631 +!.... CLOUD EVAPORATION. +! convert input 'cp' to cgs + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ & + & (cp*(temg(mgs) - cbw)**2)) + QEVAP= Min( qx(mgs,lc), R1*(qss(mgs)-qvap(mgs)) ) + + + IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 + qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) + thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) +! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) - (qx(mgs,lc))/dtp*felv(mgs)/(cp*pi0(mgs)) !* & +!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + qx(mgs,lc) = 0. + cx(mgs,lc) = 0. ELSE - esi(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) - esi(mgs)=min(0.1,esi(mgs)) - ENDIF - IF ( ipconc .le. 3 ) THEN - esi(mgs) = exp(0.025*min(temcg(mgs),0.0)) ! LFO -! esi(mgs) = Min(0.5, exp(0.025*min(temcg(mgs),0.0)) ) ! LFO -! esi(mgs)=0.5*exp(0.1*min(temcg(mgs),0.0)) ! 10ice + qwvp(mgs) = qwvp(mgs) + QEVAP + qx(mgs,lc) = qx(mgs,lc) - QEVAP + IF ( qx(mgs,lc) .le. 0. ) cx(mgs,lc) = 0. + thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) +! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) - (qevap)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & +!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) ENDIF -! ELSE ! zrnic/ziegler 1993 -! esi(mgs)= 0.1 ! 0.5*exp(0.1*min(temcg(mgs),0.0)) -! ENDIF - if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0 - end if -! -! -! -! -! Graupel: Collection (cxc) efficiencies -! -! - xmascw(mgs) = xmas(mgs,lc) - if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc).gt.qxmin(lc) ) then - ehw(mgs) = 1.0 - IF ( iehw .eq. 0 ) THEN - ehw(mgs) = ehw0 ! default value is 1.0 - ELSEIF ( iehw .eq. 1 .or. iehw .eq. 10 ) THEN - cwrad = 0.5*xdia(mgs,lc,1) - ehw(mgs) = Min( ehw0, & - & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & - & (cradcw + cwrad*(dradcw)))), 1.0) ) - - ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN - ic = icwr(mgs) - icp1 = Min( 8, ic+1 ) - ir = igwr(mgs) - irp1 = Min( 6, ir+1 ) - cwrad = 0.5*xdia(mgs,lc,1) - rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter - - slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) - slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) - -! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) - x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) - x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) - - slope1 = (x2 - x1)*grad(ir,2) - - tmp = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) ) - ehw(mgs) = Min( ehw(mgs), tmp ) + GO TO 631 -! write(iunit,*) 'ehw: ',ehw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 -! write(iunit,*) -! ehw(mgs) = Max( 0.2, ehw(mgs) ) -! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that -! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 -! ehw(mgs) = ehw(mgs) + (1.0 - ehw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + 620 CONTINUE - ELSEIF ( iehw .eq. 3 .or. iehw .eq. 10 ) THEN ! use fraction of droplets greater than dmincw diameter - tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) - xmascw(mgs) = xmas(mgs,lc) + xdn0(lc)*(pi*dmincw**3/6.0) ! this is the average mass of the droplets with d > dmincw - ehw(mgs) = Min( ehw(mgs), tmp ) - ELSEIF ( iehw .eq. 4 .or. iehw .eq. 10 ) THEN ! Cober and List 1993 - tmp = & - & 2.0*xdn(mgs,lc)*vtxbar(mgs,lh,1)*(0.5*xdia(mgs,lc,1))**2 & - & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lh,3)) - tmp = Max( 1.5, Min(10.0, tmp) ) - ehw(mgs) = Min( ehw(mgs), 0.55*Log10(2.51*tmp) ) - ENDIF - if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0 +!.... CLOUD CONDENSATION - ehw(mgs) = Min( ehw0, ehw(mgs) ) - - IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN - ehw(mgs) = 0.0 - ENDIF + IF ( qx(mgs,lc) .GT. qxmin(lc) .and. cx(mgs,lc) .ge. 1. ) THEN - end if -! - if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lr).gt.qxmin(lr) & - & .and. temg(mgs) .lt. tfr & - & ) then -! ehr(mgs) = Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,lh,1)) - ehr(mgs) = 1.0 - end if -! - IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN - IF ( ipconc .ge. 4 ) THEN - ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) - ELSE - ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) - ENDIF - if ( qx(mgs,lh).gt.qxmin(lh) ) then - ehs(mgs) = ehscnv(mgs) - end if - ENDIF -! - if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,li).gt.qxmin(li) ) then - ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) - ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 ) ehi(mgs) = 0.0 - end if -! -! -! Hail: Collection (cxc) efficiencies -! -! - IF ( lhl .gt. 1 ) THEN +! ac1 = xdn(mgs,lc)*elv(kgs(mgs))**2*epsi/ +! : (tka(kgs(mgs))*rw*temg(mgs)**2) +! took out xdn factor because it cancels later... + ac1 = felv(mgs)**2/(tka(mgs)*rw*temg(mgs)**2) - if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lc).gt.qxmin(lc) ) then - IF ( iehw == 3 ) iehlw = 3 - IF ( iehw == 4 ) iehlw = 4 - ehlw(mgs) = ehlw0 - IF ( iehlw .eq. 0 ) THEN - ehlw(mgs) = ehlw0 ! default value is 1.0 - ELSEIF ( iehlw .eq. 1 .or. iehlw .eq. 10 ) THEN - cwrad = 0.5*xdia(mgs,lc,1) - ehlw(mgs) = Min( ehlw0, & - & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & - & (cradcw + cwrad*(dradcw)))), 1.0) ) - - ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN - ic = icwr(mgs) - icp1 = Min( 8, ic+1 ) - ir = ihlr(mgs) - irp1 = Min( 6, ir+1 ) - cwrad = 0.5*xdia(mgs,lc,1) - rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter - - slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) - slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) - - x1 = ew(ic, ir) + slope1*(cwrad - cwr(ic,1)) - x2 = ew(icp1,ir) + slope2*(cwrad - cwr(ic,1)) - - slope1 = (x2 - x1)*grad(ir,2) - - tmp = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) ) - ehlw(mgs) = Min( ehlw(mgs), tmp ) - ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) -! ehw(mgs) = Max( 0.2, ehw(mgs) ) -! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that -! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 -! ehlw(mgs) = ehlw(mgs) + (1.0 - ehlw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 - ELSEIF ( iehlw .eq. 3 .or. iehlw .eq. 10 ) THEN ! use fraction of droplets greater than 15 micron diameter - tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) - ehlw(mgs) = Min( ehlw(mgs), tmp ) - ELSEIF ( iehlw .eq. 4 .or. iehlw .eq. 10 ) THEN ! Cober and List 1993 - tmp = & - & 2.0*xdn(mgs,lc)*vtxbar(mgs,lhl,1)*(0.5*xdia(mgs,lc,1))**2 & - & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lhl,3)) - tmp = Max( 1.5, Min(10.0, tmp) ) - ehlw(mgs) = Min( ehlw(mgs), 0.55*Log10(2.51*tmp) ) - ENDIF - if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0 - ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) +! bc = xdn(mgs,lc)*rw*temg(mgs)/ +! : (epsi*wvdf(kgs(mgs))*es(mgs)) +! took out xdn factor because it cancels later... + bc = rw*temg(mgs)/(wvdf(mgs)*es(mgs)) - IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN - ehlw(mgs) = 0.0 - ENDIF +! bs = rho0(mgs)*((rd*temg(mgs)/(epsi*es(mgs)))+ +! : (epsi*elv(kgs(mgs))**2/(pres(mgs)*temg(mgs)*cp))) + +! taus = Min(dtp, xdn(mgs,lc)*rho0(mgs)*(ac1+bc)/ +! : (4*pi*0.89298*BS*0.5*xdia(mgs,lc,1)*cx(mgs,lc)*xdn(mgs,lc))) - end if -! - if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lr).gt.qxmin(lr) & - & .and. temg(mgs) .lt. tfr & - & ) then - ehlr(mgs) = 1.0 - end if -! - IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN - if ( qx(mgs,lhl).gt.qxmin(lhl) ) then - ehls(mgs) = ehscnv(mgs) - end if - ENDIF ! - if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,li).gt.qxmin(li) ) then - ehli(mgs)=eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) - ehli(mgs) = Min( ehimax, Max( ehli(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 ) ehli(mgs) = 1.0 - end if + IF ( ssf(mgs) .gt. 0.0 .or. ssat0(mgs) .gt. 0.0 ) THEN + IF ( ny .le. 2 ) THEN +! write(0,*) 'undershoot: ',ssf(mgs), +! : ( (qx(mgs,lv) - dcloud)/c1 - 1.0)*100. + ENDIF - ENDIF ! lhl .gt. 1 - ENDDO ! mgs loop for collection efficiencies + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN -! -! -! -! Set flags for plates vs. columns -! -! - do mgs = 1,ngscnt -! - xplate(mgs) = 0.0 - xcolmn(mgs) = 1.0 -! -! if ( temcg(mgs) .lt. 0. .and. temcg(mgs) .ge. -4. ) then -! xplate(mgs) = 1.0 -! xcolmn(mgs) = 0.0 -! end if -!c -! if ( temcg(mgs) .lt. -4. .and. temcg(mgs) .ge. -9. ) then -! xplate(mgs) = 0.0 -! xcolmn(mgs) = 1.0 -! end if -!c -! if ( temcg(mgs) .lt. -9. .and. temcg(mgs) .ge. -22.5 ) then -! xplate(mgs) = 1.0 -! xcolmn(mgs) = 0.0 -! end if -!c -! if ( temcg(mgs) .lt. -22.5 .and. temcg(mgs) .ge. -90. ) then -! xplate(mgs) = 0.0 -! xcolmn(mgs) = 1.0 -! end if -! - end do -! -! -! -! Collection growth equations.... -! -! - if (ndebug .gt. 0 ) write(0,*) 'Collection: rain collects xxxxx' -! - do mgs = 1,ngscnt - qracw(mgs) = 0.0 - IF ( qx(mgs,lr) .gt. qxmin(lr) .and. erw(mgs) .gt. 0.0 ) THEN - IF ( ipconc .lt. 3 ) THEN - IF ( erw(mgs) .gt. 0.0 .and. qx(mgs,lr) .gt. 1.e-7 ) THEN - vt = (ar*(xdia(mgs,lc,1)**br))*rhovt(mgs) - qracw(mgs) = & - & (0.25)*pi*erw(mgs)*qx(mgs,lc)*cx(mgs,lr) & -! > *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & - & *Max(0.0, vtxbar(mgs,lr,1)-vt) & - & *( gf3*xdia(mgs,lr,2) & - & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,lc,1) & - & + gf1*xdia(mgs,lc,2) ) -! qracw(mgs) = 0.0 -! write(iunit,*) 'qracw,cx =',qracw(mgs),1.e6*xdia(mgs,lr,1),erw(mgs) -! write(iunit,*) 'qracw,cx =',qracw(mgs),cx(mgs,lc),kgs(mgs),cx(mgs,lr),1.e6*xdia(mgs,lr,1),vtxbar(mgs,lr,1),vt -! write(iunit,*) 'vtr: ',vtxbar(mgs,lr,1), ar*gf4br/6.0*xdia(mgs,lr,1)**br, rhovt(mgs), -! : ar*gf4br/6.0*xdia(mgs,lr,1)**br * rhovt(mgs) - ENDIF - ELSE + IF ( xdia(mgs,lc,1) .le. 0.0 ) THEN + xmas(mgs,lc) = cwmasn + xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**c1f3 + ENDIF + d1 = (1./(ac1 + bc))*4.0*pi*ventc & + & *0.5*xdia(mgs,lc,1)*cx(mgs,lc)*rhoinv(mgs) - IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN - rwrad = 0.5*xdia(mgs,lr,3) - IF ( rwrad .gt. rh(mgs) ) THEN ! .or. cx(mgs,lr) .gt. nh(mgs) ) THEN - IF ( rwrad .gt. rwradmn ) THEN -! DM1CCC=A2*XNC*XNR*XVC*(((CNU+2.)/(CNU+1.))*XVC+XVR) ! (A12) -! NOTE: Result is independent of imurain, assumes mucloud = 3 - qracw(mgs) = erw(mgs)*aa2*cx(mgs,lr)*cx(mgs,lc)*xmas(mgs,lc)* & - & ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,lr))/rho0(mgs) !*rhoinv(mgs) - ELSE + ELSE + d1 = 0.0 + ENDIF + IF ( rcond .eq. 2 .and. qx(mgs,lr) .gt. qxmin(lr) .and. cx(mgs,lr) > 1.e-9 ) THEN IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier's rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF -! DM1CCC=A1*XNC*XNR*(((CNU+3.)*(CNU+2.)/(CNU+1.)**2)*XVC**3+ ! (A14) -! 1 ((RNU+2.)/(RNU+1.))*XVC*XVR**2) + ELSE ! imurain == 1 -! qracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)* & -! & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**3/(cnu + 1.)**2 + & -! & (alpha(mgs,lr) + 2.)*xv(mgs,lc)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))/rho0(mgs) !*rhoinv(mgs) -! save multiplies by converting cx*xdn*xv/rho0 to qx - qracw(mgs) = aa1*cx(mgs,lr)*qx(mgs,lc)* & - & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.)**2 + & - & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) - - ELSE ! imurain == 1 + IF ( iferwisventr == 1 ) THEN + alpr = Min(alpharmax,alpha(mgs,lr) ) +! alpr = alpha(mgs,lr) + x = 1. + alpr - qracw(mgs) = aa1*cx(mgs,lr)*qx(mgs,lc)* & - & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.)**2 + & - & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & - & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) - - ENDIF - - ENDIF - ENDIF - ENDIF - ENDIF -! qracw(mgs) = Min(qracw(mgs), qx(mgs,lc)) - qracw(mgs) = Min(qracw(mgs), qcmxd(mgs)) - ENDIF - end do -! - do mgs = 1,ngscnt - qraci(mgs) = 0.0 - craci(mgs) = 0.0 - IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN - IF ( ipconc .ge. 3 ) THEN + tmp = 1 + alpr + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - tmp = eri(mgs)*aa2*cx(mgs,lr)*cx(mgs,li)* & - & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,lr)) + tmp = 2.5 + alpr + 0.5*bx(lr) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions - qraci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) ) - craci(mgs) = Min( cxmxd(mgs,li), tmp ) + vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) + vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) -! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + -! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) -! -! qraci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*qx(mgs,li)*vt* -! : ( da0(lr)*xdia(mgs,lr,3)**2 + -! : dab1(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + -! : da1(li)*xdia(mgs,li,3)**2 ) -! -! -! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + -! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) -! -! craci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*cx(mgs,li)*vt* -! : ( da0(lr)*xdia(mgs,lr,3)**2 + -! : dab0(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + -! : da0(li)*xdia(mgs,li,3)**2 ) -! -! qraci(mgs) = Min( qraci(mgs), qxmxd(mgs,li) ) -! craci(mgs) = Min( craci(mgs), cxmxd(mgs,li) ) + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier's rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) - ELSE - qraci(mgs) = & - & min( & - & (0.25)*pi*eri(mgs)*qx(mgs,li)*cx(mgs,lr) & - & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & - & *( gf3*xdia(mgs,lr,2) & - & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & - & + gf1*xdia(mgs,li,2) ) & - & , qimxd(mgs)) - ENDIF - if ( temg(mgs) .gt. 268.15 ) then - qraci(mgs) = 0.0 - end if - ENDIF - end do -! - do mgs = 1,ngscnt - qracs(mgs) = 0.0 - IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN - IF ( lwsm6 .and. ipconc == 0 ) THEN - vt = vt2ave(mgs) + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + + ENDIF ! iferwisventr + + ENDIF ! imurain + + d1r = (1./(ac1 + bc))*4.0*pi*rwvent(mgs) & + & *0.5*xdia(mgs,lr,1)*cx(mgs,lr)*rhoinv(mgs) ELSE - vt = vtxbar(mgs,ls,1) + d1r = 0.0 ENDIF - qracs(mgs) = & - & min( & - & ((0.25)*pi/gf4)*ers(mgs)*qx(mgs,ls)*cx(mgs,lr) & - & *abs(vtxbar(mgs,lr,1)-vt) & - & *( gf6*gf1*xdia(mgs,ls,2) & - & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lr,1) & - & + gf4*gf3*xdia(mgs,lr,2) ) & - & , qsmxd(mgs)) - ENDIF - end do + + + e1 = felvcp(mgs)/(pi0(mgs)) + f1 = pk(mgs) ! (pres(mgs)/poo)**cap ! +! fifth trial to see what happens: ! - if (ndebug .gt. 0 ) write(0,*) 'Collection: snow collects xxxxx' -! - do mgs = 1,ngscnt - qsacw(mgs) = 0.0 - csacw(mgs) = 0.0 - vsacw(mgs) = 0.0 - IF ( esw(mgs) .gt. 0.0 ) THEN + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + ltemq1 = ltemq + temp1 = temg(mgs) + p380 = 380.0/pres(mgs) - IF ( ipconc .ge. 4 ) THEN -! QSACC=CECS*RVT*A2*XNC*XNS*XVC*ROS* -! * (((CNU+2.)/(CNU+1.))*XVC+XVS)/RO +! taus = Max( 0.05*dtp, Min(taus, 0.25*dtp ) ) +! nc = NInt(dtp/Min(1.0,0.5*taus)) +! dtcon = dtp/float(nc) + ss1 = qx(mgs,lv)/qvs(mgs) + ss2 = ss1 + temp2 = temp1 + qv1 = qx(mgs,lv) + qvs1 = qvs(mgs) + qis1 = qis(mgs) + dt1 = 0.0 -! tmp = esw(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* -! : ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls)) - tmp = 1.0*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* & - & ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls)) - qsacw(mgs) = Min( qxmxd(mgs,lc), tmp*xmas(mgs,lc)*rhoinv(mgs) ) - csacw(mgs) = Min( cxmxd(mgs,lc), tmp ) +! dtcon = Max(dtcon,0.2) +! nc = Nint(dtp/dtcon) - IF ( lvol(ls) .gt. 1 ) THEN - IF ( temg(mgs) .lt. 273.15) THEN - rimdn(mgs,ls) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & - & *((0.60)*vtxbar(mgs,ls,1)) & - & /(temg(mgs)-273.15))**(rimc2) - rimdn(mgs,ls) = Min( Max( rimc3, rimdn(mgs,ls) ), 900.0 ) - ELSE - rimdn(mgs,ls) = 1000. - ENDIF + ltemq1 = ltemq +! want to start out with a small time step to handle the steep slope +! and fast changes, then can switch to a larger step (dtcon2) for the +! rest of the big time step. +! base the initial time step (dtcon1) on the slope (delta) + IF ( Abs(ss1 - 1.0) .gt. 1.e-5 ) THEN + delta = 0.5*(qv1-qvs1)/(d1*(ss1 - 1.0)) + ELSE + delta = 0.1*dtp + ENDIF +! delta is the extrapolated time to get halfway from qv1 to qvs1 +! want at least 5 time steps to the halfway point, so multiply by 0.2 +! for the initial time step + dtcon1 = Min(0.05,0.2*delta) + nc = Max(5,2*NInt( (dtp-4.0*dtcon1)/delta)) + dtcon2 = (dtp-4.0*dtcon1)/nc - vsacw(mgs) = rho0(mgs)*qsacw(mgs)/rimdn(mgs,ls) + n = 1 + dt1 = 0.0 + nc = 0 + dqc = 0.0 + dqr = 0.0 + dqi = 0.0 + dqs = 0.0 + RK2c: DO WHILE ( dt1 .lt. dtp ) + nc = 0 + IF ( n .le. 4 ) THEN + dtcon = dtcon1 + ELSE + dtcon = dtcon2 ENDIF + 609 dqv = -(ss1 - 1.)*d1*dtcon + dqvr = -(ss1 - 1.)*d1r*dtcon + dtemp = -0.5*e1*f1*(dqv + dqvr) +! write(0,*) 'RK2c dqv1 = ',dqv +! calculate midpoint values: + ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5) + IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN + write(0,*) 'STOP in icezvd_dr line 3790 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,f1,dqv,dqvr = ', dtemp,e1,f1,dqv,dqvr + write(0,*) ' d1,d1r,dtcon,ss1 = ',d1,d1r,dtcon,ss1 + write(0,*) ' dqc, dqr = ',dqc,dqr + write(0,*) ' qv,qc,qr = ',qx(mgs,lv)*1000.,qx(mgs,lc)*1000.,qx(mgs,lr)*1000. + write(0,*) ' i, j, k = ',igs(mgs),jy,kgs(mgs) + write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta + write(0,*) ' nc,dtp = ',nc,dtp + write(0,*) ' rwvent,xdia,crw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr) + write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr) + write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1 + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1m) + qv1m = qv1 + dqv + dqvr +! qv1mr = qv1r + dqvr + qvs1m = qvs1 + dqvs + ss1m = qv1m/qvs1m -! qsacw(mgs) = cecs*aa2*cx(mgs,ls)*cx(mgs,lc)*xmas(mgs,lc)* -! : ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls))*rhoinv(mgs) - ELSE -! qsacw(mgs) = -! > min( -! > ((0.25)*pi)*esw(mgs)*qx(mgs,lc)*cx(mgs,ls) -! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) -! > *( gf3*xdia(mgs,ls,2) -! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,lc,1) -! > + gf1*xdia(mgs,lc,2) ) -! < , qcmxd(mgs)) + ! check for undersaturation when no ice is present, if so, then reduce time step + IF ( ss1m .lt. 1. .and. (dqvii + dqvis) .eq. 0.0 ) THEN + dtcon = (0.5*dtcon) + IF ( dtcon .ge. dtcon1 ) THEN + GOTO 609 + ELSE + EXIT + ENDIF + ENDIF +! calculate full step: + dqv = -(ss1m - 1.)*d1*dtcon + dqvr = -(ss1m - 1.)*d1r*dtcon - vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) - qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt* & - & ( da0(ls)*xdia(mgs,ls,3)**2 + & - & dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) - qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) ) - csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc) - ENDIF - ENDIF - end do -! -! - do mgs = 1,ngscnt - qsaci(mgs) = 0.0 - csaci(mgs) = 0.0 - IF ( ipconc .ge. 4 ) THEN - IF ( esi(mgs) .gt. 0.0 ) THEN -! QSCOI=CEXS*RVT*A2*XNCI*XNS*XVCI*ROS* -! * (((CINU+2.)/(CINU+1.))*VCIP+XVS)/RO +! write(0,*) 'RK2a dqv1m = ',dqv + dtemp = -e1*f1*(dqv + dqvr) + ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5) + IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN + write(0,*) 'STOP in icezvd_dr line 3856 ' + write(0,*) ' ltemq1m,icond = ',ltemq1m,icond + write(0,*) ' dtemp,e1,dqv,dqvr = ', dtemp,e1,dqv,dqvr + ENDIF + dqvs = dtemp*p380*dtabqvs(ltemq1) - tmp = esi(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,li)* & - & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,ls)) + qv1 = qv1 + dqv + dqvr - qsaci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) ) - csaci(mgs) = Min( cxmxd(mgs,li), tmp ) + dqc = dqc - dqv + dqr = dqr - dqvr + + qvs1 = qvs1 + dqvs + ss1 = qv1/qvs1 + temp1 = temp1 + dtemp + IF ( temp2 .eq. temp1 .or. ss2 .eq. ss1 .or. & + & ss1 .eq. 1.00 .or. & + & ( n .gt. 10 .and. ss1 .lt. 1.0005 ) ) THEN +! write(0,*) 'RK2c break' + EXIT + ELSE + ss2 = ss1 + temp2 = temp1 + dt1 = dt1 + dtcon + n = n + 1 + ENDIF + ENDDO RK2c + + + dcloud = dqc ! qx(mgs,lv) - qv1 + thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr) + qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr) + qx(mgs,lc) = qx(mgs,lc) + DCLOUD + qx(mgs,lr) = qx(mgs,lr) + dqr +! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD + dqr)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & +!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + + + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*f1 + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + es(mgs) = 6.1078e2*tabqvs(ltemq) -! qsaci(mgs) = -! > min( -! > ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) -! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) -! > *( gf3*xdia(mgs,ls,2) -! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) -! > + gf1*xdia(mgs,li,2) ) -! < , qimxd(mgs)) - ENDIF - ELSE ! - IF ( esi(mgs) .gt. 0.0 ) THEN - qsaci(mgs) = & - & min( & - & ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) & - & *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) & - & *( gf3*xdia(mgs,ls,2) & - & + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) & - & + gf1*xdia(mgs,li,2) ) & - & , qimxd(mgs)) - ENDIF - ENDIF - end do -! -! -! - do mgs = 1,ngscnt - qsacr(mgs) = 0.0 - qsacrs(mgs) = 0.0 - csacr(mgs) = 0.0 - IF ( esr(mgs) .gt. 0.0 ) THEN - IF ( ipconc .ge. 3 ) THEN -! vt = Sqrt((vtxbar(mgs,ls,1)-vtxbar(mgs,lr,1))**2 + -! : 0.04*vtxbar(mgs,ls,1)*vtxbar(mgs,lr,1) ) -! qsacr(mgs) = esr(mgs)*cx(mgs,ls)*vt* -! : qx(mgs,lr)*0.25*pi* -! : (3.02787*xdia(mgs,lr,2) + -! : 3.30669*xdia(mgs,ls,1)*xdia(mgs,lr,1) + -! : 2.*xdia(mgs,ls,2)) -! qsacr(mgs) = Min( qsacr(mgs), qrmxd(mgs) ) -! csacr(mgs) = qsacr(mgs)*cx(mgs,lr)/qx(mgs,lr) -! csacr(mgs) = min(csacr(mgs),crmxd(mgs)) - ELSE - IF ( lwsm6 .and. ipconc == 0 ) THEN - vt = vt2ave(mgs) - ELSE - vt = vtxbar(mgs,ls,1) - ENDIF - - qsacr(mgs) = & - & min( & - & ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls) & - & *abs(vtxbar(mgs,lr,1)-vt) & - & *( gf6*gf1*xdia(mgs,lr,2) & - & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,ls,1) & - & + gf4*gf3*xdia(mgs,ls,2) ) & - & , qrmxd(mgs)) - ENDIF - ENDIF - end do -! -! -! - if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' ! - do mgs = 1,ngscnt - qhacw(mgs) = 0.0 - rarx(mgs,lh) = 0.0 - vhacw(mgs) = 0.0 - vhsoak(mgs) = 0.0 - zhacw(mgs) = 0.0 - - IF ( .false. ) THEN - vtmax = (gz(igs(mgs),jgs,kgs(mgs))/dtp) - vtxbar(mgs,lh,1) = Min( vtmax, vtxbar(mgs,lh,1)) - vtxbar(mgs,lh,2) = Min( vtmax, vtxbar(mgs,lh,2)) - vtxbar(mgs,lh,3) = Min( vtmax, vtxbar(mgs,lh,3)) - ENDIF - IF ( ehw(mgs) .gt. 0.0 ) THEN - IF ( ipconc .ge. 2 ) THEN + ENDIF ! dcloud .gt. 0. - IF ( .false. ) THEN - qhacw(mgs) = (ehw(mgs)*qx(mgs,lc)*cx(mgs,lh)*pi* & - & abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* & - & (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + & - & xdia(mgs,lc,1)*gf73rds) + & - & xdia(mgs,lc,2)*gf83rds))/4. - - ELSE ! using Seifert coefficients - vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) - qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*qx(mgs,lc)*vt* & - & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,lc,lh)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) - - ENDIF - qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)/dtp ) - - IF ( lzh .gt. 1 ) THEN - tmp = qx(mgs,lh)/cx(mgs,lh) - -!! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ -!! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) -! alp = Max( 1.0, alpha(mgs,lh)+1. ) -! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ -! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) -! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) - ENDIF - - ELSE - qhacw(mgs) = & - & min( & - & ((0.25)*pi)*ehw(mgs)*qx(mgs,lc)*cx(mgs,lh) & - & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & - & *( gf3*xdia(mgs,lh,2) & - & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,lc,1) & - & + gf1*xdia(mgs,lc,2) ) & - & , 0.5*qx(mgs,lc)/dtp) -! < , qxmxd(mgs,lc)) -! < , qcmxd(mgs)) - - - IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and. qhacw(mgs) > 0.0) THEN - qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh)) -! qaacw = Min( qaacw, 0.5*(qsacw(mgs) + qhacw(mgs) ) ) - qsacw(mgs) = qaacw - qhacw(mgs) = qaacw - ENDIF - - ENDIF - - IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail - - IF ( temg(mgs) .lt. 273.15) THEN - rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & - & *((0.60)*vtxbar(mgs,lh,1)) & - & /(temg(mgs)-273.15))**(rimc2) - rimdn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), 900.0 ) - ELSE - rimdn(mgs,lh) = 1000. - ENDIF - - IF ( lvol(lh) > 1 ) vhacw(mgs) = rho0(mgs)*qhacw(mgs)/rimdn(mgs,lh) + ELSE ! qc .le. qxmin(lc) - ENDIF - - IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .gt. 0 ) THEN - rarx(mgs,lh) = & - & qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh)) - ENDIF - - ENDIF - end do -! -! - do mgs = 1,ngscnt - qhaci(mgs) = 0.0 - IF ( ehi(mgs) .gt. 0.0 ) THEN - IF ( ipconc .ge. 5 ) THEN +! IF ( ssf(mgs) .gt. 0.0 .and. .not. flag_qndrop ) THEN ! flag_qndrop turns off primary nucleation when using wrf-chem with progn=1 + IF ( ssf(mgs) .gt. 0.0 ) THEN ! .and. ssmax(mgs) .lt. sscb ) THEN ! except that wrf-chem does not seem to initialize qc for activated aerosols, so keep this, after all - vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & - & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + IF ( iqcinit == 1 ) THEN - qhaci(mgs) = 0.25*pi*ehi(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & - & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & - & da1(li)*xdia(mgs,li,3)**2 ) - qhaci(mgs) = Min( qhaci(mgs), qimxd(mgs) ) - ELSE - qhaci(mgs) = & - & min( & - & ((0.25)*pi)*ehi(mgs)*qx(mgs,li)*cx(mgs,lh) & - & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & - & *( gf3*xdia(mgs,lh,2) & - & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,li,1) & - & + gf1*xdia(mgs,li,2) ) & - & , qimxd(mgs)) - ENDIF - ENDIF - end do -! -! - do mgs = 1,ngscnt - qhacs(mgs) = 0.0 - IF ( ehs(mgs) .gt. 0.0 ) THEN - IF ( ipconc .ge. 5 ) THEN + qvs0 = 380.*exp(17.27*(temg(mgs)-273.)/(temg(mgs)- 36.))/pk(mgs) - vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & - & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + dcloud = Max(0.0, (qx(mgs,lv)-qvs0) / (1.+qvs0*f5/(temg(mgs)-36.)**2) ) - qhacs(mgs) = 0.25*pi*ehs(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & - & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & - & da1(ls)*xdia(mgs,ls,3)**2 ) - - qhacs(mgs) = Min( qhacs(mgs), qsmxd(mgs) ) + ELSEIF ( iqcinit == 3 ) THEN + R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felvcp(mgs)/ & + & ((temg(mgs) - cbw)**2)) + DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + + ELSEIF ( iqcinit == 2 ) THEN +! R1=1./(1. + caw*(273.15 - cbw)*qss(mgs)*felv(mgs)/ +! : (cp*(temg(mgs) - cbw)**2)) +! DCLOUD=R1*(qvap(mgs) - qvs(mgs)) ! KW model adjustment; + ! this will put mass into qc if qv > sqsat exists + ssmx = ssmxinit - ELSE - qhacs(mgs) = & - & min( & - & ((0.25)*pi/gf4)*ehs(mgs)*qx(mgs,ls)*cx(mgs,lh) & - & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & - & *( gf6*gf1*xdia(mgs,ls,2) & - & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & - & + gf4*gf3*xdia(mgs,lh,2) ) & - & , qsmxd(mgs)) + IF ( ssf(mgs) > ssmx ) THEN + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,dcloud, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) + ELSE + dcloud = 0.0 + ENDIF + ENDIF + ELSE + dcloud = 0.0 ENDIF - ENDIF - end do -! - do mgs = 1,ngscnt - qhacr(mgs) = 0.0 - vhacr(mgs) = 0.0 - chacr(mgs) = 0.0 - zhacr(mgs) = 0.0 - IF ( temg(mgs) .gt. tfr ) raindn(mgs,lh) = 1000.0 - - IF ( ehr(mgs) .gt. 0.0 ) THEN - IF ( ipconc .ge. 3 ) THEN - vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & - & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) -! qhacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* -! : qx(mgs,lr)*0.25*pi* -! : (3.02787*xdia(mgs,lr,2) + -! : 3.30669*xdia(mgs,lh,1)*xdia(mgs,lr,1) + -! : 2.*xdia(mgs,lh,2)) - - qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & - & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab1lh(mgs,lr,lh)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & - & da1(lr)*xdia(mgs,lr,3)**2 ) -! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp -!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) -!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) -!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) - - qhacr(mgs) = Min( qhacr(mgs), qxmxd(mgs,lr) ) -! chacr(mgs) = Min( qhacr(mgs)*rho0(mgs)/xmas(mgs,lr), cxmxd(mgs,lr) ) - -! chacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* -! : cx(mgs,lr)*0.25*pi* -! : (0.69874*xdia(mgs,lr,2) + -! : 1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) + -! : 2.*xdia(mgs,lh,2)) - -! chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* -! : ( da0lh(mgs)*xdia(mgs,lh,3)**2 + -! : dab0lh(mgs,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + -! : da0(lr)*xdia(mgs,lr,3)**2 ) -! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp + thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - DCLOUD + qx(mgs,lc) = qx(mgs,lc) + DCLOUD - chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) - chacr(mgs) = min(chacr(mgs),crmxd(mgs)) +! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD)/dtp*felv(mgs)/(cp*pi0(mgs)) ! * & +!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) - IF ( lzh .gt. 1 ) THEN - tmp = qx(mgs,lh)/cx(mgs,lh) + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap +! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + es(mgs) = 6.1078e2*tabqvs(ltemq) -! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ -! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) -! alp = Max( 1.0, alpha(mgs,lh)+1. ) -! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ -! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) -! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) -! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacr(mgs) ) +!.... S. TWOMEY (1959) +! Note: get here if there is no previous cloud water and w > 0. + cn(mgs) = 0.0 + + IF ( ncdebug .ge. 1 ) THEN + write(iunit,*) 'at 613: ',qx(mgs,lc),cx(mgs,lc),wvel(mgs),ssmax(mgs),kgs(mgs) ENDIF - ELSE - IF ( lwsm6 .and. ipconc == 0 ) THEN - vt = vt2ave(mgs) - ELSE - vt = vtxbar(mgs,lh,1) - ENDIF + IF ( .not. flag_qndrop ) THEN ! { only calculate mass change when using wrf-chem - qhacr(mgs) = & - & min( & - & ((0.25)*pi/gf4)*ehr(mgs)*qx(mgs,lr)*cx(mgs,lh) & - & *abs(vt-vtxbar(mgs,lr,1)) & - & *( gf6*gf1*xdia(mgs,lr,2) & - & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1) & - & + gf4*gf3*xdia(mgs,lh,2) ) & - & , qrmxd(mgs)) - ENDIF - IF ( lvol(lh) .gt. 1 ) THEN - vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh) + +! IF ( ssmax(mgs) .lt. sscb .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + IF ( dcloud .gt. qxmin(lc) .and. wvel(mgs) > 0.0) THEN +! CN(mgs) = CCNE*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*wvel(mgs)**cnexp ! *Min(1.0,1./dtp) ! 0.3465 + IF ( ny .le. 2 .and. cn(mgs) .gt. 0.0 & + & .and. ncdebug .ge. 1 ) THEN + write(iunit,*) 'CN: ',cn(mgs)*1.e-6, cx(mgs,lc)*1.e-6, qx(mgs,lc)*1.e3, & + & wvel(mgs), dcloud*1.e3 + IF ( cn(mgs) .gt. 1.0 ) write(iunit,*) 'cwrad = ', & + & 1.e6*(rho0(mgs)*qx(mgs,lc)/cn(mgs)*cwc1)**c1f3, & + & igs(mgs),kgs(mgs),temcg(mgs), & + & 1.e3*an(igs(mgs),jgs,kgs(mgs)-1,lc) + ENDIF + IF ( iccwflg .eq. 1 ) THEN + cn(mgs) = Min(cwccn*rho0(mgs)/rho00, Max(cn(mgs), & + & rho0(mgs)*qx(mgs,lc)/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3))) ENDIF + ELSE + cn(mgs) = 0.0 + dcloud = 0.0 +! cn(mgs) = Min(cwccn, & +! & rho0(mgs)*dcloud/(xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3) ) ENDIF - end do - -! -! - if (ndebug .gt. 0 ) write(0,*) 'Collection: hail collects xxxxx' -! - do mgs = 1,ngscnt - qhlacw(mgs) = 0.0 - vhlacw(mgs) = 0.0 - vhlsoak(mgs) = 0.0 - IF ( lhl > 1 .and. .true.) THEN - vtmax = (gz(igs(mgs),jgs,kgs(mgs))/dtp) - vtxbar(mgs,lhl,1) = Min( vtmax, vtxbar(mgs,lhl,1)) - vtxbar(mgs,lhl,2) = Min( vtmax, vtxbar(mgs,lhl,2)) - vtxbar(mgs,lhl,3) = Min( vtmax, vtxbar(mgs,lhl,3)) + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) +! ccnc(mgs) = 0.0 + ENDIF +! cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + ccna(mgs) = ccna(mgs) + cn(mgs) ENDIF - IF ( lhl > 0 ) THEN - rarx(mgs,lhl) = 0.0 - ENDIF +! write(91,*) 'nuc1: cn, ix, kz = ',cn(mgs),igs(mgs),kgs(mgs),wvel(mgs),cnexp,ccnc(mgs) - IF ( lhl .gt. 1 .and. ehlw(mgs) .gt. 0.0 ) THEN + IF( CN(mgs) .GT. cx(mgs,lc) ) cx(mgs,lc) = CN(mgs) + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .le. qxmin(lc) ) THEN + cx(mgs,lc) = 0. + ELSE + cx(mgs,lc) = Min(cx(mgs,lc),rho0(mgs)*Max(0.0,qx(mgs,lc))/cwmasn) + ENDIF + + ENDIF ! }.not. flag_qndrop + GOTO 613 + + END IF ! qc .gt. 0. -! IF ( ipconc .ge. 2 ) THEN +! ES=EES(PIB(K)*PT) +! SQSAT=EPSI*ES/(PB(K)*1000.-ES) - vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) +!.... CLOUD NUCLEATION +! T=PIB(K)*PT +! ES=1.E3*PB(K)*QV/EPSI - qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*qx(mgs,lc)*vt* & - & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,lc,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) - - - qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)/dtp ) + IF ( wvel(mgs) .le. 0. ) GO TO 616 + IF ( cx(mgs,lc) .le. 0. ) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .GT. 1 .and. qx(mgs,lc) .le. qxmin(lc)) GO TO 613 !TWOMEY (1959) Nucleation + IF ( kzbeg-1+kgs(mgs) .eq. 1 .and. wvel(mgs) .gt. 0. ) GO TO 613 !TWOMEY (1959) Nucleation +!.... ATTEMPT ZIEGLER CLOUD NUCLEATION IN CLOUD INTERIOR UNLESS... + 616 IF ( ssf(mgs) .LE. SUPCB .AND. wvel(mgs) .GT. 0. ) GO TO 631 !... weakly saturated updraft + IF ( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 .AND. & + & (ssfkp1(mgs) .GE. SUPMX .OR. & + & ssf(mgs) .GE. SUPMX .OR. & + & ssfkm1(mgs) .GE. SUPMX)) GO TO 631 !... too much vapour + IF (ssf(mgs) .LT. 1.E-10 .OR. ssf(mgs) .GE. SUPMX) GO TO 631 !... at the extremes for ss - IF ( lvol(lhl) .gt. 1 ) THEN +! +! get here if ( qc > 0 and ss > supcb) or (w < 0) +! - IF ( temg(mgs) .lt. 273.15) THEN - rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & - & *((0.60)*vtxbar(mgs,lhl,1)) & - & /(temg(mgs)-273.15))**(rimc2) - rimdn(mgs,lhl) = Min( Max( rimc3, rimdn(mgs,lhl) ), 900.0 ) - ELSE - rimdn(mgs,lhl) = 1000. - ENDIF + if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: Entered Ziegler Cloud Nucleation" !mpidebug - vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/rimdn(mgs,lhl) + DSSDZ=0. + r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs)) + IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation) - ENDIF + IF ( irenuc /= 2 ) THEN !{ + IF ( kzend == nzend ) THEN + t0p3 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+3)) + t0p1 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+1)) + ELSE + t0p3 = t0(igs(mgs),jgs,kgs(mgs)+3) + t0p1 = t0(igs(mgs),jgs,kgs(mgs)+1) + ENDIF - IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .gt. 0 ) THEN - rarx(mgs,lhl) = & - & qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl)) + IF ( ( ssf(mgs) .gt. ssmax(mgs) .or. irenuc .eq. 1 ) & + & .and. ( ( lccn .lt. 1 .and. & + & cx(mgs,lc) .lt. cwccn*(Min(1.0,rho0(mgs)))) .or. & + & ( lccn .gt. 1 .and. ccnc(mgs) .gt. 0. ) ) & + & ) THEN + IF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & + & .and. ssf(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .LT. SUPMX .and. ssfkp1(mgs) .ge. 0.0 & + & .AND. ssfkm1(mgs) .LT. SUPMX .AND. ssfkm1(mgs) .ge. 0.0 & + & .AND. ssfkp1(mgs) .gt. ssfkm1(mgs) & + & .and. t0p3 .gt. 233.2) THEN + DSSDZ = (ssfkp1(mgs) - ssfkm1(mgs))*R2DZM +! +! otherwise check for cloud base condition with updraft: +! + ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 & +! IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 & + & .and. ssf(mgs) .gt. 0.0 .and. wvel(mgs) .gt. 0.0 & + & .and. ssfkp1(mgs) .gt. 0.0 & + & .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 & + & .AND. ssf(mgs) .gt. ssfkm1(mgs) & + & .and. t0p1 .gt. 233.2) THEN + DSSDZ = 2.*(ssf(mgs) - ssfkm1(mgs))*R2DZM ! 1-sided difference ENDIF + ENDIF +! +!CLZ IF(wijk.LE.0.) CN=CCN*ssfilt(ix,jy,kz)**CCK +! note: CCN -> cwccn, DELT -> dtp + c1 = Max(0.0, rho0(mgs)*(qx(mgs,lv) - qss(mgs))/ & + & (xdn(mgs,lc)*(4.*pi/3.)*(4.e-6)**3)) + IF ( lccn .lt. 1 ) THEN + CN(mgs) = cwccn*rho0(mgs)/rho00*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & (wvel(mgs)*DSSDZ) ) ! probably the vertical gradient dominates + ELSE + CN(mgs) = & + & Min(ccnc(mgs), cnuc(mgs)*CCK*ssf(mgs)**CCKM*dtp* & + & Max(0.0, & + & ( wvel(mgs)*DSSDZ) ) ) +! IF ( cn(mgs) .gt. 0 ) ccnc(mgs) = ccnc(mgs) - cn(mgs) ENDIF - end do - - qhlaci(:) = 0.0 - IF ( lhl .gt. 1 ) THEN - do mgs = 1,ngscnt - IF ( ehli(mgs) .gt. 0.0 ) THEN - IF ( ipconc .ge. 5 ) THEN - - vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & - & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) - qhlaci(mgs) = 0.25*pi*ehli(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & - & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,li,lhl)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & - & da1(li)*xdia(mgs,li,3)**2 ) - qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) ) + IF ( cn(mgs) .gt. 0.0 ) THEN + IF ( ccnc(mgs) .lt. 5.e7 .and. cn(mgs) .ge. 5.e7 ) THEN + cn(mgs) = 5.e7 + ccnc(mgs) = 0.0 + ELSEIF ( cn(mgs) .gt. ccnc(mgs) ) THEN + cn(mgs) = ccnc(mgs) + ccnc(mgs) = 0.0 ENDIF + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) ENDIF - end do - ENDIF -! - qhlacs(:) = 0.0 - IF ( lhl .gt. 1 ) THEN - do mgs = 1,ngscnt - IF ( ehls(mgs) .gt. 0.0) THEN - IF ( ipconc .ge. 5 ) THEN - vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & - & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + ELSEIF ( irenuc == 2 ) THEN !} { + ! simple Twomey scheme +! if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR: Cloud reNucleation, wvel = ',wvel(mgs) + CN(mgs) = CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465 +! ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck)) +!!! CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from + ! Philips, Donner et al. 2007, but results in too much limitation of + ! nucleation + CN(mgs) = Min(cn(mgs), ccnc(mgs)) + cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass + + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) + + ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs)) + + ENDIF ! } - qhlacs(mgs) = 0.25*pi*ehli(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & - & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,ls,lhl)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & - & da1(ls)*xdia(mgs,ls,3)**2 ) + ccna(mgs) = ccna(mgs) + cn(mgs) - qhlacs(mgs) = Min( qhlacs(mgs), qsmxd(mgs) ) + ENDIF ! irenuc >= 0 .and. .not. flag_qndrop - ENDIF - ENDIF - end do - ENDIF + IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0. + GO TO 631 +!.... NUCLEATION ON CLOUD INFLOW BOUNDARY POINT + 613 CONTINUE - do mgs = 1,ngscnt - qhlacr(mgs) = 0.0 - chlacr(mgs) = 0.0 - vhlacr(mgs) = 0.0 - IF ( lhl .gt. 1 .and. temg(mgs) .gt. tfr ) raindn(mgs,lhl) = 1000.0 + 631 CONTINUE - IF ( lhl .gt. 1 .and. ehlr(mgs) .gt. 0.0 ) THEN - IF ( ipconc .ge. 3 ) THEN - vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & - & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) +! +! Check for supersaturation greater than ssmx and adjust down +! + ssmx = 1.9 + qv1 = qv0(mgs) + qwvp(mgs) + qvs1 = qvs(mgs) + +! IF ( flag_qndrop .and. do_satadj_for_wrfchem ) ssmx = 1.04 ! set lower threshold for progn=1 when using WRF-CHEM - qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & - & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab1lh(mgs,lr,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & - & da1(lr)*xdia(mgs,lr,3)**2 ) -! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp -!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) -!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) -!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + IF ( qv1 .gt. (ssmx*qvs1) ) THEN +! use line below to disable saturation adjustment when flag_qndrop is true +! IF ( qv1 .gt. (ssmx*qvs1) .and. .not. flag_qndrop ) THEN + + ss1 = qv1/qvs1 - qhlacr(mgs) = Min( qhlacr(mgs), qxmxd(mgs,lr) ) + ssmx = 100.*(ssmx - 1.0) + + qvex = 0.0 + CALL QVEXCESS(ngs,mgs,qwvp,qv0,qx(1,lc),pres,thetap,theta0,qvex, & + & pi0,tabqvs,nqsat,fqsat,cbw,fcqv1,felvcp,ssmx,pk,ngscnt) - chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt* & - & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab0(lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & - & da0(lr)*xdia(mgs,lr,3)**2 ) - chlacr(mgs) = min(chlacr(mgs),crmxd(mgs)) - IF ( lvol(lhl) .gt. 1 ) THEN - vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/raindn(mgs,lhl) + IF ( qvex .gt. 0.0 ) THEN + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) + +! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (qvex)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & +!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + + qwvp(mgs) = qwvp(mgs) - qvex + qx(mgs,lc) = qx(mgs,lc) + qvex + IF ( .not. flag_qndrop) THEN + cn(mgs) = Min( Max(ccnc(mgs),cwnccn(mgs)), rho0(mgs)*qvex/Max( cwmasn5, xmas(mgs,lc) ) ) + ccnc(mgs) = Max( 0.0, ccnc(mgs) - cn(mgs) ) + cx(mgs,lc) = cx(mgs,lc) + cn(mgs) ENDIF - ENDIF - ENDIF - end do + +! write(iunit,*) 'theta = ',theta0(mgs) + thetap(mgs) +! temg(mgs) = theta(mgs)*( pres(mgs) / poo ) ** cap + ENDIF + + + ENDIF ! -! -! -! - if (ndebug .gt. 0 ) write(0,*) 'Collection: Cloud collects xxxxx' +! Calculate droplet volume and check if it is within bounds. +! Adjust if necessary +! +! if (ndebug .gt. 0) write(0,*) "ICEZVD_DR: check droplet volume" - if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx2' + +! cx(mgs,lc) = Min( cwnccn(mgs), cx(mgs,lc) ) + IF( cx(mgs,lc) > cxmin .AND. qx(mgs,lc) .GT. qxmin(lc)) THEN +! SVC(mgs) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)*xdn(mgs,lc)) + xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/(cx(mgs,lc)) + + IF ( xmas(mgs,lc) < cwmasn .or. xmas(mgs,lc) > cwmasx ) THEN + xmas(mgs,lc) = Min( xmas(mgs,lc), cwmasx ) + xmas(mgs,lc) = Max( xmas(mgs,lc), cwmasn ) + cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) + ENDIF + ENDIF + + +! IF( cx(mgs,lc) .GT. 10.e6 .AND. qx(mgs,lc) .GT. qxmin(lc) ) GO TO 681 +! ccwtmp = cx(mgs,lc) +! cwmastmp = xmas(mgs,lc) +! xmas(mgs,lc) = Max(xmas(mgs,lc), cwmasn) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. cx(mgs,lc) .le. 0.) THEN +! cx(mgs,lc) = Min(0.5*cwccn,rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc)) +! xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! ENDIF +! IF (cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .GT. qxmin(lc)) & +! & xmas(mgs,lc) = rho0(mgs)*qx(mgs,lc)/cx(mgs,lc) +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .LT. cwmasn) & +! & xmas(mgs,lc) = cwmasn +! IF (qx(mgs,lc) .GT. qxmin(lc) .AND. xmas(mgs,lc) .GT. cwmasx) & +! & xmas(mgs,lc) = cwmasx +! IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN +! cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/Max(cwmasn,xmas(mgs,lc)) +! ENDIF +! ! - do mgs = 1,ngscnt - qiacw(mgs) = 0.0 - IF ( eiw(mgs) .gt. 0.0 ) THEN +! 681 CONTINUE - vt = Sqrt((vtxbar(mgs,li,1)-vtxbar(mgs,lc,1))**2 + & - & 0.04*vtxbar(mgs,li,1)*vtxbar(mgs,lc,1) ) + + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN - qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt* & - & ( da0(li)*xdia(mgs,li,3)**2 + & - & dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) + & - & da1(lc)*xdia(mgs,lc,3)**2 ) + + IF (cx(mgs,lr) .GT. 0. .AND. qx(mgs,lr) .GT. qxmin(lr)) & + & xv(mgs,lr)=rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) + IF (xv(mgs,lr) .GT. xvmx(lr)) xv(mgs,lr) = xvmx(lr) + IF (xv(mgs,lr) .LT. xvmn(lr)) xv(mgs,lr) = xvmn(lr) - qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) ) ENDIF - end do -! -! - if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8' -! - do mgs = 1,ngscnt - qiacr(mgs) = 0.0 - qiacrf(mgs) = 0.0 - qiacrs(mgs) = 0.0 - ciacr(mgs) = 0.0 - ciacrf(mgs) = 0.0 - viacrf(mgs) = 0.0 - csplinter(mgs) = 0.0 - qsplinter(mgs) = 0.0 - csplinter2(mgs) = 0.0 - qsplinter2(mgs) = 0.0 - IF ( iacr .ge. 1 .and. eri(mgs) .gt. 0.0 & - & .and. temg(mgs) .le. 270.15 ) THEN - IF ( ipconc .ge. 3 ) THEN - ni = 0.0 - IF ( xdia(mgs,li,1) .ge. 10.e-6 ) THEN - ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 ) - ENDIF - IF ( imurain == 1 ) THEN ! gamma of diameter - IF ( iacrsize .eq. 1 ) THEN - ratio = 500.e-6/xdia(mgs,lr,1) - ELSEIF ( iacrsize .eq. 2 ) THEN - ratio = 300.e-6/xdia(mgs,lr,1) - ELSEIF ( iacrsize .eq. 3 ) THEN - ratio = 40.e-6/xdia(mgs,lr,1) - ENDIF - - i = Int(Min(25.0,ratio)) - j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))) - delx = ratio - float(i) - dely = alpha(mgs,lr) - float(j) - ip1 = Min( i+1, nqiacrratio ) - jp1 = Min( j+1, nqiacralpha ) - ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out - tmp1 = ciacrratio(i,j) + delx*(ciacrratio(ip1,j) - ciacrratio(i,j)) - tmp2 = ciacrratio(i,jp1) + delx*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) - - ! interpoate along alpha; note interval spacing is 1., so division is left out - - nr = (tmp1 + dely*(tmp2 - tmp1))*cx(mgs,lr) - - ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out - tmp1 = qiacrratio(i,j) + delx*(qiacrratio(ip1,j) - qiacrratio(i,j)) - tmp2 = qiacrratio(i,jp1) + delx*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) - - ! interpoate along alpha; note interval spacing is 1., so division is left out - - qr = (tmp1 + dely*(tmp2 - tmp1))*qx(mgs,lr) - vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + & - & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) - qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* & - & ( da0(li)*xdia(mgs,li,3)**2 + & - & dab1lh(mgs,lr,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & - & da1(lr)*xdia(mgs,lr,3)**2 ) + ENDDO ! mgs - qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) - ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & - & ( da0(li)*xdia(mgs,li,3)**2 + & - & dab0lh(mgs,lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & - & da0(lr)*xdia(mgs,lr,3)**2 ) +! ################################################################ + DO mgs=1,ngscnt + IF ( ssf(mgs) .gt. ssmax(mgs) & + & .and. ( idecss .eq. 0 .or. qx(mgs,lc) .gt. qxmin(lc)) ) THEN + ssmax(mgs) = ssf(mgs) + ENDIF + ENDDO +! - ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) - -! write(iunit,*) 'qiacr: ',cx(mgs,lr),nr,qx(mgs,lr),qr,qiacr(mgs),ciacr(mgs) -! write(iunit,*) 'xdia r li = ',xdia(mgs,lr,3),xdia(mgs,li,3),xdia(mgs,lr,1),xdia(mgs,li,1) -! write(iunit,*) 'i,j,ratio = ',i,j,ciacrratio(i,j),qiacrratio(i,j) -! write(iunit,*) 'ni,ci = ',ni,cx(mgs,li),qx(mgs,li) + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lt) = theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qv0(mgs) + qwvp(mgs) +! tmp3d(igs(mgs),jy,kgs(mgs)) = tmp3d(igs(mgs),jy,kgs(mgs)) + t9(igs(mgs),jy,kgs(mgs)) ! pi0(mgs) ! wvdf(mgs) ! ssf(mgs) ! cn(mgs) +! + if ( ido(lc) .eq. 1 ) then + an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) + & + & min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 ) +! qx(mgs,lc) = an(igs(mgs),jy,kgs(mgs),lc) + end if +! - ELSEIF ( imurain == 3 ) THEN ! gamma of volume -! Set nr to the number of drops greater than 40 microns. - arg = 1000.*xdia(mgs,lr,3) -! nr = cx(mgs,lr)*gaml02( arg ) -! IF ( iacr .eq. 1 ) THEN - IF ( ipconc .ge. 3 ) THEN - IF ( iacrsize .eq. 1 ) THEN - nr = cx(mgs,lr)*gaml02d500( arg ) ! number greater than 500 microns in diameter - ELSEIF ( iacrsize .eq. 2 ) THEN - nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter - ELSEIF ( iacrsize .eq. 3 ) THEN - nr = cx(mgs,lr)*gaml02( arg ) ! number greater than 40 microns in diameter - ELSEIF ( iacrsize .eq. 4 ) THEN - nr = cx(mgs,lr) ! all raindrops - ENDIF - ELSE - nr = cx(mgs,lr)*gaml02( arg ) - ENDIF -! ELSEIF ( iacr .eq. 2 ) THEN -! nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter -! ENDIF - IF ( ni .gt. 0.0 .and. nr .gt. 0.0 ) THEN - d0 = xdia(mgs,lr,3) - qiacr(mgs) = xdn(mgs,lr)*rhoinv(mgs)* & - & (0.217239*(0.522295*(d0**5) + & - & 49711.81*(d0**6) - & - & 1.673016e7*(d0**7)+ & - & 2.404471e9*(d0**8) - & - & 1.22872e11*(d0**9))*ni*nr) - qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) - ciacr(mgs) = & - & (0.217239*(0.2301947*(d0**2) + & - & 15823.76*(d0**3) - & - & 4.167685e6*(d0**4) + & - & 4.920215e8*(d0**5) - & - & 2.133344e10*(d0**6))*ni*nr) - ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) -! ciacr(mgs) = qiacr(mgs)*cx(mgs,lr)/qx(mgs,lr) - ENDIF - IF ( iacr .eq. 1 .or. iacr .eq. 3 ) THEN - ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vr1mm*1000.0)*rho0(mgs) ) ! *rzxh(mgs) - ELSEIF ( iacr .eq. 2 ) THEN - ciacrf(mgs) = ciacr(mgs) ! *rzxh(mgs) - ELSEIF ( iacr .eq. 4 ) THEN - ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vfrz*1000.0)*rho0(mgs) ) ! *rzxh(mgs) - ELSEIF ( iacr .eq. 5 ) THEN - ciacrf(mgs) = ciacr(mgs)*rzxh(mgs) - ENDIF -! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*27.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) - ENDIF - - - ELSE ! single-moment rain - qiacr(mgs) = & - & min( & - & ((0.25/gf4)*pi)*eri(mgs)*cx(mgs,li)*qx(mgs,lr) & - & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & - & *( gf6*gf1*xdia(mgs,lr,2) & - & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & - & + gf4*gf3*xdia(mgs,li,2) ) & - & , qrmxd(mgs)) - ENDIF -! if ( temg(mgs) .gt. 268.15 ) then -! qiacr(mgs) = 0.0 -! ciacr(mgs) = 0.0 -! end if - ENDIF + if ( ido(lr) .eq. 1 .and. rcond == 2 ) then + an(igs(mgs),jy,kgs(mgs),lr) = qx(mgs,lr) + & + & min( an(igs(mgs),jy,kgs(mgs),lr), 0.0 ) +! qx(mgs,lr) = an(igs(mgs),jy,kgs(mgs),lr) + end if - IF ( ipconc .ge. 1 ) THEN - IF ( nsplinter .ge. 0 ) THEN - csplinter(mgs) = nsplinter*ciacr(mgs) - ELSE - csplinter(mgs) = -nsplinter*ciacrf(mgs) - ENDIF - qsplinter(mgs) = Min(0.1*qiacr(mgs), csplinter(mgs)*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel - ENDIF - - qiacrf(mgs) = qiacr(mgs) -! IF ( lwsm6 .and. ipconc == 0 .and. qx(mgs,lr) < 1.e-4 ) THEN -! qiacrs(mgs) = qiacr(mgs) -! qiacrf(mgs) = 0.0 -! ENDIF - IF ( lvol(lh) > 1 ) THEN - viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz - ENDIF - + + IF ( ipconc .ge. 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0) + IF ( lccn .gt. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + ENDIF + IF ( ipconc .ge. 3 .and. rcond == 2 ) THEN + an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0) + ENDIF end do + + +29998 continue + + + if ( kz .gt. nz-1 .and. ix .ge. nx) then + if ( ix .ge. nx ) then + go to 2200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if + + if ( ix .ge. nx ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if + + 2000 continue ! inumgs + 2200 continue ! +! end of gather scatter (for this jy slice) + + +!#ifdef COMMAS +! GOTO 9999 +!#endif + +! Redistribute inappreciable cloud particles and charge ! +! Redistribution everywhere in the domain... ! + frac = 1.0 ! 0.25 ! 1.0 ! 0.2 ! +! alternate test version for ipconc .ge. 3 +! just vaporize stuff to prevent noise in the number concentrations -! snow aggregation here - if ( ipconc .ge. 4 .or. ipelec .ge. 100 ) then ! - do mgs = 1,ngscnt - csacs(mgs) = 0.0 - IF ( ess(mgs) .gt. 0.0 ) THEN -! csacs(mgs) = -a2*eps*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) - csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) - csacs(mgs) = min(csacs(mgs),csmxd(mgs)) - ENDIF - end do - end if -! -! - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 11' - if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then - do mgs = 1,ngscnt - ciacw(mgs) = 0.0 - IF ( eiw(mgs) .gt. 0.0 ) THEN - ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc) - ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) - ENDIF - end do - end if + do kz = 1,nz +! do jy = 1,1 + do ix = 1,nx + + zerocx(:) = .false. + DO il = lc,lhab + IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) < cxmin ) + IF ( lz(il) > 1 ) zerocx(il) = ( zerocx(il) .or. an(ix,jy,kz,lz(il)) < zxmin ) + ELSE + IF ( il == lc ) THEN + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) .and. .not. flag_qndrop ! don't reset if progn=1 (WRF-CHEM) + ELSE + IF ( ln(il) > 1 ) zerocx(il) = ( an(ix,jy,kz,ln(il)) <= 0 ) + ENDIF + ENDIF + ENDDO - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' - if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then - do mgs = 1,ngscnt - cracw(mgs) = 0.0 - cracr(mgs) = 0.0 - ec0(mgs) = 1.e9 - IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) & - & .and. qracw(mgs) .gt. 0.0 ) THEN + IF ( lhl .gt. 1 ) THEN + + + if ( an(ix,jy,kz,lhl) .lt. frac*qxmin(lhl) .or. zerocx(lhl) ) then - IF ( ipconc .lt. 3 ) THEN - IF ( erw(mgs) .gt. 0.0 ) THEN - cracw(mgs) = & - & ((0.25)*pi)*erw(mgs)*cx(mgs,lc)*cx(mgs,lr) & - & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & - & *( gf1*xdia(mgs,lc,2) & - & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) & - & + gf3*xdia(mgs,lr,2) ) - ENDIF - ELSE ! IF ( ipconc .ge. 3 .and. - IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN !{ - IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) -! IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN - IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6 -! DM0CCC=A2*XNC*XNR*(XVC+XVR) ! (A11) -! NOTE: murain drops out, so same result for imurain = 1 and 3 - cracw(mgs) = aa2*cx(mgs,lr)*cx(mgs,lc)*(xv(mgs,lc) + xv(mgs,lr)) - ELSE - IF ( imurain == 3 ) THEN -! DM0CCC=A1*XNC*XNR*(((CNU+2.)/(CNU+1.))*XVC**2+((RNU+2.)/(RNU+1.))*XVR**2) ! (A13) - cracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)* & - & ((cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.) + & - & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) - ELSE ! imurain == 1 USE CP00 for rain DSD in diameter - cracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)* & - & ((cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.) + & - & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & - & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) ) - ENDIF ! imurain - ENDIF - ENDIF ! } rh - ENDIF ! } dmrauto - ENDIF ! ipconc - ENDIF ! qc > qcmin & qr > qrmin - -! Rain self collection (cracr) and break-up (factor of ec0) -! -! - ec0(mgs) = 2.e9 - IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN - rwrad = 0.5*xdia(mgs,lr,3) - IF ( xdia(mgs,lr,3) .gt. 2.0e-3 ) THEN - ec0(mgs) = 0.0 - cracr(mgs) = 0.0 - ELSE - IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN - IF ( xdia(mgs,lr,3) .lt. 6.1e-4 ) THEN - ec0(mgs) = 1.0 - ELSE - ec0(mgs) = Exp(-50.0*(50.0*(xdia(mgs,lr,3) - 6.0e-4))) - ENDIF - +! IF ( an(ix,jy,kz,lhl) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lhl) + an(ix,jy,kz,lhl) = 0.0 +! ENDIF - IF ( rwrad .ge. 50.e-6 ) THEN - cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr) - ELSE - IF ( imurain == 3 ) THEN - cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & - & (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.) - ELSE ! imurain == 1 - cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & - & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ & - & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) - - ENDIF - ENDIF -! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) - ENDIF - ENDIF + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnhl) = 0.0 ENDIF -! cracw(mgs) = min(cracw(mgs),ccmxd(mgs)) - end do - end if -! -! -! -! Graupel -! - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' - chacw(:) = 0.0 - if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then - do mgs = 1,ngscnt - - IF ( ipconc .ge. 5 ) THEN - IF ( qhacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN - -! This is the explict version of chacw, which turns out to be very close to the -! approximation that the droplet size does not change, to within a few percent. -! This may _not_ be the case for cnu other than zero! -! chacw(mgs) = (ehw(mgs)*cx(mgs,lc)*cx(mgs,lh)*(pi/4.)* -! : abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* -! : (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + -! : xdia(mgs,lc,1)*gf43rds) + -! : xdia(mgs,lc,2)*gf53rds)) + IF ( lvhl .gt. 1 ) THEN + an(ix,jy,kz,lvhl) = 0.0 + ENDIF -! chacw(mgs) = Min( chacw(mgs), 0.6*cx(mgs,lc)/dtp ) + IF ( lhlw .gt. 1 ) THEN + an(ix,jy,kz,lhlw) = 0.0 + ENDIF + + IF ( lzhl .gt. 1 ) THEN + an(ix,jy,kz,lzhl) = 0.0 + ENDIF -! chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmas(mgs,lc) - chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmascw(mgs) -! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) - chacw(mgs) = Min( chacw(mgs), 0.5*cx(mgs,lc)/dtp ) - ELSE - qhacw(mgs) = 0.0 - ENDIF ELSE - chacw(mgs) = & - & ((0.25)*pi)*ehw(mgs)*cx(mgs,lc)*cx(mgs,lh) & - & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & - & *( gf1*xdia(mgs,lc,2) & - & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lh,1) & - & + gf3*xdia(mgs,lh,2) ) - chacw(mgs) = min(chacw(mgs),0.5*cx(mgs,lc)/dtp) -! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) -! chacw(mgs) = min(chacw(mgs),ccmxd(mgs)) - ENDIF - end do - end if -! - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' - chaci(:) = 0.0 - if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then - do mgs = 1,ngscnt - IF ( ehi(mgs) .gt. 0.0 ) THEN - IF ( ipconc .ge. 5 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + tmp = 0.5*( xdnmn(lhl) + xdnmx(lhl) ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF - vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & - & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) +! DEBUG +! tmp = 850. +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! IF ( an(ix,jy,kz,lhl) .gt. 1.0e-3 ) THEN +! write(iunit,*) 'HAILdr: dn,q,c,v = ',tmp,an(ix,jy,kz,lhl)*1000., +! : an(ix,jy,kz,lnhl), an(ix,jy,kz,lvhl) +! write(iunit,*) 'lvhl = ',lvhl +! ENDIF - chaci(mgs) = 0.25*pi*ehi(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & - & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab0lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & - & da0(li)*xdia(mgs,li,3)**2 ) - ELSE - chaci(mgs) = & - & ((0.25)*pi)*ehi(mgs)*cx(mgs,li)*cx(mgs,lh) & - & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & - & *( gf1*xdia(mgs,li,2) & - & + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lh,1) & - & + gf3*xdia(mgs,lh,2) ) + IF ( tmp .gt. xdnmx(lhl) .or. tmp .lt. xdnmn(lhl) ) THEN + tmp = Min( xdnmx(lhl), Max( xdnmn(lhl) , tmp ) ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp ENDIF - - chaci(mgs) = min(chaci(mgs),cimxd(mgs)) + ENDIF - end do - end if -! -! - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' - chacs(:) = 0.0 - if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then - do mgs = 1,ngscnt - IF ( ehs(mgs) .gt. 0 ) THEN - IF ( ipconc .ge. 5 ) THEN - - vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & - & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) - - chacs(mgs) = 0.25*pi*ehs(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & - & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & - & dab0lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & - & da0(ls)*xdia(mgs,ls,3)**2 ) + + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lhl) .gt. qxmin(lhl) .and. alphahl .le. 0.1 .and. lnhl .gt. 1 .and. lzhl == 0 ) THEN + + IF ( lvhl .gt. 1 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) + ELSE + hwdn = xdn0(lhl) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnhl))/(dn(ix,jy,kz)*an(ix,jy,kz,lhl)) + tmpg = an(ix,jy,kz,lnhl)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohlmn ) THEN + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lhl))*(3.14159))**(1./3.) + an(ix,jy,kz,lnhl) = (cnohlmn/tmp)**(3./4.) + ENDIF + + ENDIF +! ELSE ! check mean size here? - ELSE - chacs(mgs) = & - & ((0.25)*pi)*ehs(mgs)*cx(mgs,ls)*cx(mgs,lh) & - & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & - & *( gf3*gf1*xdia(mgs,ls,2) & - & + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & - & + gf1*gf3*xdia(mgs,lh,2) ) - ENDIF - chacs(mgs) = min(chacs(mgs),csmxd(mgs)) - ENDIF - end do end if -! -! -! Hail -! - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' - chlacw(:) = 0.0 - if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then - do mgs = 1,ngscnt - - IF ( lhl .gt. 1 .and. ipconc .ge. 5 ) THEN - IF ( qhlacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN -! This is the explict version of chacw, which turns out to be very close to the -! approximation that the droplet size does not change, to within a few percent. -! This may _not_ be the case for cnu other than zero! -! chlacw(mgs) = (ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)*(pi/4.)* -! : abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))* -! : (2.0*xdia(mgs,lhl,1)*(xdia(mgs,lhl,1) + -! : xdia(mgs,lc,1)*gf43rds) + -! : xdia(mgs,lc,2)*gf53rds)) + ENDIF !lhl -! chlacw(mgs) = Min( chlacw(mgs), 0.6*cx(mgs,lc)/dtp ) -! chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmas(mgs,lc) - chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmascw(mgs) -! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) - chlacw(mgs) = Min( chlacw(mgs), 0.5*cx(mgs,lc)/dtp ) - ELSE - qhlacw(mgs) = 0.0 - ENDIF -! ELSE -! chlacw(mgs) = -! > ((0.25)*pi)*ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl) -! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) -! > *( gf1*xdia(mgs,lc,2) -! > + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lhl,1) -! > + gf3*xdia(mgs,lhl,2) ) -! chlacw(mgs) = min(chlacw(mgs),0.5*cx(mgs,lc)/dtp) -! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) -! chlacw(mgs) = min(chlacw(mgs),ccmxd(mgs)) - ENDIF - end do - end if -! - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' - chlaci(:) = 0.0 - if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then - do mgs = 1,ngscnt - IF ( lhl .gt. 1 .and. ehli(mgs) .gt. 0.0 ) THEN - IF ( ipconc .ge. 5 ) THEN + if ( an(ix,jy,kz,lh) .lt. frac*qxmin(lh) .or. zerocx(lh) ) then - vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & - & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) +! IF ( an(ix,jy,kz,lh) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lh) + an(ix,jy,kz,lh) = 0.0 +! ENDIF - chlaci(mgs) = 0.25*pi*ehli(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt* & - & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab0(lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & - & da0(li)*xdia(mgs,li,3)**2 ) + IF ( ipconc .ge. 5 ) THEN ! .and. an(ix,jy,kz,lnh) .gt. 0.0 ) THEN + an(ix,jy,kz,lnh) = 0.0 + ENDIF -! ELSE -! chlaci(mgs) = -! > ((0.25)*pi)*ehli(mgs)*cx(mgs,li)*cx(mgs,lhl) -! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1)) -! > *( gf1*xdia(mgs,li,2) -! > + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lhl,1) -! > + gf3*xdia(mgs,lhl,2) ) + IF ( lvh .gt. 1 ) THEN + an(ix,jy,kz,lvh) = 0.0 + ENDIF + + IF ( lhw .gt. 1 ) THEN + an(ix,jy,kz,lhw) = 0.0 + ENDIF + + IF ( lzh .gt. 1 ) THEN + an(ix,jy,kz,lzh) = 0.0 ENDIF - chlaci(mgs) = min(chlaci(mgs),cimxd(mgs)) - ENDIF - end do - end if -! -! - if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj' - chlacs(:) = 0.0 - if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then - do mgs = 1,ngscnt - IF ( lhl .gt. 1 .and. ehls(mgs) .gt. 0 ) THEN - IF ( ipconc .ge. 5 ) THEN + ELSE + IF ( lvol(lh) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + tmp = rho_qh + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF - vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & - & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + IF ( tmp .lt. xdnmn(lh) ) THEN + tmp = Max( xdnmn(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF - chlacs(mgs) = 0.25*pi*ehls(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt* & - & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & - & dab0(lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & - & da0(ls)*xdia(mgs,ls,3)**2 ) + IF ( tmp .gt. xdnmx(lh) .and. lhw .le. 0 ) THEN ! no liquid allowed on graupel + tmp = Min( xdnmx(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ELSEIF ( tmp .gt. xdnmx(lh) .and. lhw .gt. 1 ) THEN ! allow for liquid on graupel + IF ( tmp .gt. xdnmx(lh) .and. an(ix,jy,kz,lhw) .lt. qxmin(lh) ) THEN + tmp = Min( xdnmx(lh), tmp ) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ELSEIF ( tmp .gt. xdnmx(lr) ) THEN + tmp = xdnmn(lr) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + ENDIF -! ELSE -! chlacs(mgs) = -! > ((0.25)*pi)*ehls(mgs)*cx(mgs,ls)*cx(mgs,lhl) -! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1)) -! > *( gf3*gf1*xdia(mgs,ls,2) -! > + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lhl,1) -! > + gf1*gf3*xdia(mgs,lhl,2) ) - ENDIF - chlacs(mgs) = min(chlacs(mgs),csmxd(mgs)) - ENDIF - end do + IF ( lhw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhw) .gt. 0.98*an(ix,jy,kz,lh) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + ENDIF + ENDIF + + ENDIF + +! CHECK INTERCEPT + IF ( ipconc == 5 .and. an(ix,jy,kz,lh) .gt. qxmin(lh) .and. alphah .le. 0.1 .and. lnh .gt. 1 .and. lzh == 0 ) THEN + + IF ( lvh .gt. 1 ) THEN + IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN + hwdn = dn(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) + ELSE + hwdn = xdn0(lh) + ENDIF + hwdn = Max( xdnmn(lh), hwdn ) + ELSE + hwdn = xdn0(lh) + ENDIF + tmp = (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh)) + tmpg = an(ix,jy,kz,lnh)*(tmp*(3.14159))**(1./3.) + IF ( tmpg .lt. cnohmn ) THEN +! tmpg = an(ix,jy,kz,lnh)*( (hwdn*an(ix,jy,kz,lnh))/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) +! tmpg = an(ix,jy,kz,lnh)**(4./3.)*( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + tmp = ( (hwdn)/(dn(ix,jy,kz)*an(ix,jy,kz,lh))*(3.14159))**(1./3.) + an(ix,jy,kz,lnh) = (cnohmn/tmp)**(3./4.) + ENDIF + + ENDIF + end if -! -! Ziegler (1985) autoconversion -! -! - IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion - if (ndebug .gt. 0 ) write(0,*) 'conc 26a' - - DO mgs = 1,ngscnt - zrcnw(mgs) = 0.0 - qrcnw(mgs) = 0.0 - crcnw(mgs) = 0.0 - cautn(mgs) = 0.0 - ENDDO + + if ( an(ix,jy,kz,ls) .lt. frac*qxmin(ls) .or. zerocx(ls) & ! .or. an(ix,jy,kz,lns) .lt. 0.1 ! .and. + & ) then + IF ( t0(ix,jy,kz) .lt. 273.15 ) THEN +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF - DO mgs = 1,ngscnt -! qracw(mgs) = 0.0 -! cracw(mgs) = 0.0 - IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN - ! .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing - volb = xv(mgs,lc)*(1./(1.+CNU))**(1./2.) - cautn(mgs) = Min(ccmxd(mgs), & - & ((CNU+2.)/(CNU+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) - cautn(mgs) = Max( 0.0d0, cautn(mgs) ) - IF ( rb(mgs) .le. 7.51d-6 ) THEN - t2s = 1.d30 -! cautn(mgs) = 0.0 - ELSE -! XL2P=2.7E-2*XNC*XVC*((1.E12*RB**3*RC)-0.4) - -! T2S=3.72E-3/(((1.E4*RB)-7.5)*XNC*XVC) -! t2s = 3.72E-3/(((1.e6*rb)-7.5)*cx(mgs,lc)*xv(mgs,lc)) -! t2s = 3.72/(((1.e6*rb(mgs))-7.5)*rho0(mgs)*qx(mgs,lc)) - t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc)) + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF - qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) ) - crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) ) - - IF ( dmrauto == 0 ) THEN - IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19) - crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs) - ENDIF - ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN - IF ( qx(mgs,lr) > qxmin(lr) ) THEN - tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) - crcnw(mgs) = Min(tmp,crcnw(mgs) ) - ENDIF - ELSEIF ( dmrauto == 2 .and. cx(mgs,lr) > cxmin) THEN - tmp = crcnw(mgs) - tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) - ! try mass-weighted average of old and new Dmr - crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) - ELSEIF ( dmrauto == 3 .and. cx(mgs,lr) > cxmin) THEN ! adapted from MY/CP code - tmp = Max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) ) - crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3) - ENDIF - - IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF -! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) -! : THEN -! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), -! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s,qx(mgs,lr) -! write(0,*) ' ',qx(mgs,lc),cx(mgs,lc),0.5e6*xdia(mgs,lc,1) -! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), -! : 1.e6*(( 3/(4.*pi))*rho0(mgs)*qrcnw(mgs)/ -! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.),rh(mgs)*1.e6,rwrad(mgs) -! ELSEIF ( crcnw(mgs) .gt. 1.0 .and. cautn(mgs) .gt. 0.) THEN -! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), -! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s -! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), -! : 1.e6*(( 3*pi/4.)*rho0(mgs)*qrcnw(mgs)/ -! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.) -! ENDIF -! crcnw(mgs) = Min(cautn(mgs),3.5e9*xl2p(mgs)/t2s) + ELSE +! IF ( an(ix,jy,kz,ls) .gt. 0 ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,ls) + an(ix,jy,kz,ls) = 0.0 +! ENDIF -! IF ( qrcnw(mgs) .gt. 0.3e-2 ) THEN -! write(0,*) 'QRCNW' -! write(0,*) qrcnw(mgs),crcnw(mgs),cautn(mgs) -! write(0,*) xl2p,t2s,rho0(mgs),xv(mgs,lc),cx(mgs,lc),qx(mgs,lc) -! write(0,*) rb,0.5*xdia(mgs,lc,1),mgs,igs(mgs),kgs(mgs) -! ENDIF -! qrcnw(mgs) = Min(qrcnw(mgs),qcmxd(mgs)) - ENDIF + IF ( lvs .gt. 1 ) THEN + an(ix,jy,kz,lvs) = 0.0 + ENDIF + + IF ( lsw .gt. 1 ) THEN + an(ix,jy,kz,lsw) = 0.0 + ENDIF + IF ( ipconc .ge. 4 ) THEN ! .and. an(ix,jy,kz,lns) .gt. 0.0 ) THEN ! +! an(ix,jy,kz,lnr) = an(ix,jy,kz,lnr) + an(ix,jy,kz,lns) + an(ix,jy,kz,lns) = 0.0 + ENDIF + + ENDIF + + + ELSEIF ( lvol(ls) .gt. 1 ) THEN ! check density + IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN + tmp = dn(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) + IF ( tmp .gt. xdnmx(ls) .or. tmp .lt. xdnmn(ls) ) THEN + tmp = Min( xdnmx(ls), Max( xdnmn(ls), tmp ) ) + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF + ELSE + tmp = rho_qs + an(ix,jy,kz,lvs) = dn(ix,jy,kz)*an(ix,jy,kz,ls)/tmp + ENDIF - ENDIF - ENDDO + end if - ELSE + if ( an(ix,jy,kz,lr) .lt. frac*qxmin(lr) .or. zerocx(lr) & + & ) then + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lr) + an(ix,jy,kz,lr) = 0.0 + IF ( ipconc .ge. 3 ) THEN +! an(ix,jy,kz,lnc) = an(ix,jy,kz,lnc) + an(ix,jy,kz,lnr) + an(ix,jy,kz,lnr) = 0.0 + ENDIF + + end if ! -! Berry 1968 auto conversion for rain (Orville & Kopp 1977) +! for qci ! + IF ( an(ix,jy,kz,li) .le. frac*qxmin(li) .or. zerocx(li) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,li) + an(ix,jy,kz,li)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lni) = 0.0 + ENDIF + ENDIF + ! - if ( ircnw .eq. 4 ) then - do mgs = 1,ngscnt -! sconvmix(lcw,mgs) = 0.0 - qrcnw(mgs) = 0.0 - qdiff = max((qx(mgs,lc)-qminrncw),0.0) - if ( qdiff .gt. 0.0 .and. xdia(mgs,lc,1) .gt. 20.0e-6 ) then - argrcnw = & - & ((1.2e-4)+(1.596e-12)*(cx(mgs,lc)*1.0e-6) & - & /(cwdisp*qdiff*1.0e-3*rho0(mgs))) - qrcnw(mgs) = (rho0(mgs)*1e-3)*(qdiff**2)/argrcnw -! sconvmix(lcw,mgs) = max(sconvmix(lcw,mgs),0.0) - qrcnw(mgs) = (max(qrcnw(mgs),0.0)) - end if - end do +! for qcw +! + + IF ( an(ix,jy,kz,lc) .le. frac*qxmin(lc) .or. zerocx(lc) & + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lc) + an(ix,jy,kz,lc)= 0.0 + IF ( ipconc .ge. 2 ) THEN + IF ( lccn .gt. 1 ) THEN + an(ix,jy,kz,lccn) = & + & an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc)) + ENDIF + an(ix,jy,kz,lnc) = 0.0 + + ENDIF ENDIF + + end do +! end do + end do + + + IF ( ndebug .ge. 1 ) write(6,*) 'END OF ICEZVD_DR' ! ! + + + 9999 RETURN + + END SUBROUTINE NUCOND + + +! ##################################################################### +! ##################################################################### + + ! -! Berry 1968 auto conversion for rain (Ferrier 1994) +! Things to do: ! +! Test using exponential formulation for rain fall speed. If there is little change +! from the quadratic, it would be less complicated to use. ! - if ( ircnw .eq. 5 ) then - do mgs = 1,ngscnt - qrcnw(mgs) = 0.0 - qrcnw(mgs) = 0.0 - qccrit = (pi/6.)*(cx(mgs,lc)*cwdiap**3)*xdn(mgs,lc)/rho0(mgs) - qdiff = max((qx(mgs,lc)-qccrit),0.) - if ( qdiff .gt. 0.0 .and. cx(mgs,lc) .gt. 1.0 ) then - argrcnw = & -! > ((1.2e-4)+(1.596e-12)*cx(mgs,lc)/(cwdisp*rho0(mgs)*qdiff)) & - & ((1.2e-4)+(1.596e-12)*cx(mgs,lc)*1.0e-3/(cwdisp*rho0(mgs)*qdiff)) - qrcnw(mgs) = & -! > timflg(mgs)*rho0(mgs)*(qdiff**2)/argrcnw & - & 1.0e-3*rho0(mgs)*(qdiff**2)/argrcnw - qrcnw(mgs) = Min(qxmxd(mgs,lc), (max(qrcnw(mgs),0.0)) ) - -! write(iunit,*) 'qrcnw,cx =',qrcnw(mgs),cx(mgs,lc),mgs,1.e3*qx(mgs,lc),cno(lr) - end if - end do - end if - +! Contact nucleation needs to be fixed up to be similar to Cotton et al. 1986 and Meyers et al 1992. ! +! The following are done? ! -! kessler auto conversion for rain. +! Fix Rain evaporation for gamma function (ipconc >= 3) ! - if ( ircnw .eq. 2 ) then - do mgs = 1,ngscnt - qrcnw(mgs) = 0.0 - qrcnw(mgs) = (0.001)*max((qx(mgs,lc)-qminrncw),0.0) - end do - end if +! convert cloud ice to snow as in Ferrier 1994 (change only mass in cloud ice), +! then can try turning off direct conversion from cloud ice to graupel and rimed ice ! -! c4 = pi/6 -! c1 = 0.12-0.32 for colorado storms...typically 0.3-0.4 -! berry reinhart type conversion (proctor 1988) +! look at an iterative check on overdepletion; need to be careful with two-moment +! +! check ice supersaturation in two-moment. Getting enough deposition, or need +! to do sat adj. when cloud droplets are all gone? +! +! +! +! new comment +! +! Fix use of gt for SWM IN FALLOUT ROUTINES +! +! How to remove hl for ipconc=5? Need to preprocess? +! +! When the charging rates are moved to a subroutine, need to move the +! call to be after the wet growth calculations -- or at least the +! splashing stuff. Think about this.... +! +! Think about what to do with cracif +! +! Replace qv0 with qx(mgs,lv)? No. qv0 is base val +! +! Need to look at limiting supersaturation to 1 or so by nucleation/condensation +! +! put in temperature-dependent function for homogeneous freezing +! +!c-------------------------------------------------------------------------- +! +! +!-------------------------------------------------------------------------- ! - if ( ircnw .eq. 1 ) then - do mgs = 1,ngscnt - qrcnw(mgs) = 0.0 - c1 = 0.2 - c4 = pi/(6.0) - bradp = & - & (1.e+06) * ((c1/(0.38))**(1./3.)) * (xdia(mgs,lc,1)*(0.5)) - bl2 = & - & (0.027) * ((100.0)*(bradp**3)*(xdia(mgs,lc,1)*(0.5)) - (0.4)) - bt2 = (bradp -7.5) / (3.72) - qrcnw(mgs) = 0.0 - if ( bl2 .gt. 0.0 .and. bt2 .gt. 0.0 ) then - qrcnw(mgs) = bl2 * bt2 * rho0(mgs) & - & * qx(mgs,lc) * qx(mgs,lc) - end if - end do - end if - + subroutine nssl_2mom_gs & + & (nx,ny,nz,na,jyslab & + & ,nor,norz & + & ,dtp,gz & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn,p2 & + & ,pn,w,iunit & + & ,t00,t77, & + & ventr,ventc,c1sw,jgs,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & + & cdx, & + & xdn0,tmp3d & + & ,timevtcalc & + & ,rainprod2d, evapprod2d & + & ,elec,its,ids,ide,jds,jde & + & ) - ENDIF ! ( ipconc .ge. 2 ) ! +!-------------------------------------------------------------------------- +! +! Ziegler 1985 parameterized microphysics (also Zrnic et al. 1993) +! 1) cloud water +! 2) rain +! 3) column ice +! 6) snow +! 11) graupel/hail +! +!-------------------------------------------------------------------------- +! +! Notes: +! +! 4/27/2009: allows for liquid water to be advected on snow and graupel particles using flag "mixedphase" +! +! 3/14/2007: (APS) added qproc temp to make microphysic process timeseries +! +! 10/17/2006: added flag (iehw) to select how to calculate ehw +! +! 10/5/2006: switched chacr to integrated version rather than assuming that average rain +! drop mass does not change. This acts to reduce rain size somewhat via graupel +! collection. +! Use Mason data for ehw, with scaling toward ehw=1 as air density decreases. +! +! 10/3/2006: Turned off Meyers nucleation for T > -5 (can turn on with imeyers5 flag) +! Turned off contact nucleation in updrafts +! +! 7/24/2006: Turned on Meyers nucleation for -5 < T < 0 +! +! 5/12/2006: Converted qsacw/csacw and qsaci/csaci to Z93 +! +! 5/12/2006: Put a threshold on Bigg rain freezing. If the frozen drops +! have an average volume less than xvhmn, then the drops are put +! into snow instead of graupel/hail. +! +! Fixed bug when vapor deposition was limited. +! +! 5/13/2006: Note that qhacr has a large effect, but Z85 did not include it. +! Turned off qsacr (set to zero). +! +! 9/14/2007: erm: recalculate vx(lh) after setting xdn(lh) in case xdn was out of allowed range. +! added parameter rimc3 for minimum rime density. Default value set at 170. kg/m**3 +! instead of previous use of 100. (Farley, 1987) +! +!-------------------------------------------------------------------------- +! +! general declarations +! +!-------------------------------------------------------------------------- ! ! -! Bigg Freezing of Rain ! - if (ndebug .gt. 0 ) write(0,*) 'conc 27a' - qrfrz(:) = 0.0 - qrfrzs(:) = 0.0 - qrfrzf(:) = 0.0 - vrfrzf(:) = 0.0 - crfrz(:) = 0.0 - crfrzs(:) = 0.0 - crfrzf(:) = 0.0 - zrfrz(:) = 0.0 - zrfrzf(:) = 0.0 - qwcnr(:) = 0.0 - - IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN - - do mgs = 1,ngscnt - if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. ) then -! brz = 100.0 -! arz = 0.66 - IF ( ipconc .lt. 3 ) THEN - qrfrz(mgs) = & - & min( & - & (20.0)*(pi**2)*brz*(xdn(mgs,lr)/rho0(mgs)) & - & *cx(mgs,lr)*(xdia(mgs,lr,1)**6) & - & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & - & , qrmxd(mgs)) - qrfrzf(mgs) = qrfrz(mgs) -! ELSEIF ( ipconc .ge. 3 .and. xv(mgs,lr) .gt. 1.1*xvmn(lr) ) THEN - ELSEIF ( ipconc .ge. 3 ) THEN -! tmp = brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) -! crfrz(mgs) = xv(mgs,lr)*tmp - frach = 1.0d0 - - IF ( ibiggopt == 2 .and. imurain == 1 ) THEN - ! integrate from Bigg diameter (for given supercooling Ts) to infinity - - volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 - ! for mean temperature for freezing: -ln (V) = a*Ts - b - ! volt is given in cm**3, so convert to m**3 - dbigg = (6./pi* volt )**(1./3.) - - ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. - - ratio = dbigg/xdia(mgs,lr,1) - - i = Int(Min(25.0,ratio)) - j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))) - delx = ratio - float(i) - dely = alpha(mgs,lr) - float(j) - ip1 = Min( i+1, nqiacrratio ) - jp1 = Min( j+1, nqiacralpha ) + implicit none +! +! integer icond +! parameter ( icond = 2 ) - ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out - tmp1 = ciacrratio(i,j) + delx*(ciacrratio(ip1,j) - ciacrratio(i,j)) - tmp2 = ciacrratio(i,jp1) + delx*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) - - ! interpolate along alpha; note interval spacing is 1., so division is left out - - crfrz(mgs) = (tmp1 + dely*(tmp2 - tmp1))*cx(mgs,lr)/dtp - - ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out - tmp1 = qiacrratio(i,j) + delx*(qiacrratio(ip1,j) - qiacrratio(i,j)) - tmp2 = qiacrratio(i,jp1) + delx*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) - - ! interpolate along alpha; note interval spacing is 1., so division is left out - - qrfrz(mgs) = (tmp1 + dely*(tmp2 - tmp1))*qx(mgs,lr)/dtp - - - - IF ( dbigg < Max(dfrz,dhmn) .and. ibiggsnow > 0 ) THEN ! convert some to snow or ice crystals - ! temporarily store qrfrz and crfrz in snow terms - crfrzs(mgs) = qrfrz(mgs) - qrfrzs(mgs) = crfrz(mgs) + integer, parameter :: ng1 = 1 + integer nx,ny,nz,na,nba,nv + integer nor,norz,istag,jstag,kstag ! ,nht,ngt,igsr + integer iwrite + real dtp,dx,dy,dz - ! recalculate using dhmn for ratio - ratio = Max(dfrz,dhmn)/xdia(mgs,lr,1) - - i = Int(Min(25.0,ratio)) - j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))) - delx = ratio - float(i) - dely = alpha(mgs,lr) - float(j) - ip1 = Min( i+1, nqiacrratio ) - jp1 = Min( j+1, nqiacralpha ) + integer itile,jtile,ktile + integer ixbeg,jybeg + integer ixend,jyend,kzend,kzbeg + integer nxend,nyend,nzend,nzbeg + integer :: my_rank = 0 + integer, parameter :: myprock = 1, nprock = 1 + real rainprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) - ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out - tmp1 = ciacrratio(i,j) + delx*(ciacrratio(ip1,j) - ciacrratio(i,j)) - tmp2 = ciacrratio(i,jp1) + delx*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) - - ! interpolate along alpha; note interval spacing is 1., so division is left out - - crfrz(mgs) = (tmp1 + dely*(tmp2 - tmp1))*cx(mgs,lr)/dtp - - ! interpolate along x, i.e., ratio; note interval spacing is 1., so division is left out - tmp1 = qiacrratio(i,j) + delx*(qiacrratio(ip1,j) - qiacrratio(i,j)) - tmp2 = qiacrratio(i,jp1) + delx*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) - - ! interpolate along alpha; note interval spacing is 1., so division is left out - - qrfrz(mgs) = (tmp1 + dely*(tmp2 - tmp1))*qx(mgs,lr)/dtp - ! now subtract off the difference - crfrzs(mgs) = crfrzs(mgs) - crfrz(mgs) - qrfrzs(mgs) = qrfrzs(mgs) - qrfrz(mgs) + real :: galpharaut + + integer jyslab,its,ids,ide,jds,jde ! domain boundaries + integer, intent(in) :: iunit !,iunit0 + real qvex + integer iraincv, icgxconv + parameter ( iraincv = 1, icgxconv = 1) + real ffrz - - ELSE - crfrzs(mgs) = 0.0 - qrfrzs(mgs) = 0.0 - ENDIF - - IF ( (qrfrzs(mgs) + qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN - fac = ( qrfrzs(mgs) + qrfrz(mgs) )*dtp/qx(mgs,lr) - qrfrz(mgs) = fac*qrfrz(mgs) - qrfrzs(mgs) = fac*qrfrzs(mgs) - qrfrzf(mgs) = fac*qrfrzf(mgs) - crfrz(mgs) = fac*crfrz(mgs) - crfrzs(mgs) = fac*crfrzs(mgs) - crfrzf(mgs) = fac*crfrzf(mgs) - ENDIF -! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN -! fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr) -! crfrz(mgs) = fac*crfrz(mgs) -! crfrzs(mgs) = fac*crfrzs(mgs) -! ENDIF - - qrfrzf(mgs) = qrfrz(mgs) - crfrzf(mgs) = crfrz(mgs) - - qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs) - crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs) + real qcitmp,cirdiatmp ! ,qiptmp,qirtmp + real ccwtmp,ccitmp ! ,ciptmp,cirtmp + real cpqc,cpci ! ,cpip,cpir + real cpqc0,cpci0 ! ,cpip0,cpir0 + real scfac ! ,cpip1 + + double precision dp1 + + double precision frac, frach, xvfrz + + double precision :: timevtcalc + double precision :: dpt1,dpt2 + + + logical, parameter :: usegamxinf = .false. + logical, parameter :: usegamxinf2 = .true. +! real rar ! rime accretion rate as calculated from qxacw - - ELSE ! ibiggopt == 1 - - tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) - IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN ! { -! write(iunit,*) 'Bigg Freezing problem!',mgs,igs(mgs),kgs(mgs) -! write(iunit,*) 'tmp, cx(lr), xv = ',tmp, cx(mgs,lr), xv(mgs,lr), (Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) -! write(iunit,*) 'qr,temcg = ',qx(mgs,lr)*1000.,temcg(mgs) - crfrz(mgs) = cxmxd(mgs,lr) ! cx(mgs,lr)/dtp - qrfrz(mgs) = qxmxd(mgs,lr) ! qx(mgs,lr)/dtp -! STOP - ELSE ! } { - crfrz(mgs) = tmp - ! crfrzfmx = cx(mgs,lr)*Exp(-4./3.*pi*(40.e-6)**3/xv(mgs,lr)) - ! IF ( crfrz(mgs) .gt. crfrzmx ) THEN - ! crfrz(mgs) = crfrzmx - ! qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrzmx - ! qwcnr(mgs) = cx(mgs,lr) - crfrzmx - ! ELSE - IF ( lzr < 1 ) THEN - IF ( imurain == 3 ) THEN - bfnu = bfnu0 - ELSE !imurain == 1 - bfnu = bfnu1 - ENDIF - ELSE - ! bfnu = 1.0 ! (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) - IF ( imurain == 3 ) THEN - bfnu = (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) - ELSE !imurain == 1 -! bfnu = bfnu1 - bfnu = (4. + alpha(mgs,lr))*(5. + alpha(mgs,lr))*(6. + alpha(mgs,lr))/ & - & ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr))) -! bfnu = 1. - ENDIF - ENDIF - qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs) - qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)/dtp ) ! qxmxd(mgs,lr) - crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)/dtp ) !cxmxd(mgs,lr) - qrfrz(mgs) = Min( qrfrz(mgs), qx(mgs,lr) ) - qrfrzf(mgs) = qrfrz(mgs) - ENDIF !} +! a few vars for time-split fallout + real vtmax + integer n,ndfall + + double precision chgneg,chgpos + + real temgtmp - - - - IF ( crfrz(mgs) .gt. 0.0 ) THEN -! IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN -! IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN - - IF ( ibiggsnow == 1 .or. ibiggsnow == 3 ) THEN - xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density - frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) + real pb(-norz+ng1:nz+norz) + real pinit(-norz+ng1:nz+norz) - qrfrzs(mgs) = (1.-frach)*qrfrz(mgs) - crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs) -! qrfrzf(mgs) = frach*qrfrz(mgs) - - ENDIF - - IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN - qrfrzs(mgs) = qrfrz(mgs) - crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs) - ELSE -! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)/dtp ) ! cxmxd(mgs,lr) ) -! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)/dtp ) ! qxmxd(mgs,lr) ) - qrfrzf(mgs) = frach*qrfrz(mgs) -! crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) ) - IF ( ibfr .le. 1 ) THEN - crfrzf(mgs) = Min(frach*crfrz(mgs), dble(qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs)) ) ! rzxh(mgs)*crfrz(mgs) - ELSEIF ( ibfr .eq. 5 ) THEN - crfrzf(mgs) = Min(frach*crfrz(mgs), dble(qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs)) )*rzxh(mgs) !*crfrz(mgs) - ELSE - crfrzf(mgs) = Min(frach*crfrz(mgs), dble(qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs)) ) ! rzxh(mgs)*crfrz(mgs) - ENDIF -! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) -! IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN -! crfrzf(mgs) = crfrz(mgs) -! ENDIF - - ENDIF -! crfrz(mgs) = Min( cxmxd(mgs,lr), rho0(mgs)*qrfrz(mgs)/xmas(mgs,lr) ) - ELSE - crfrz(mgs) = 0.0 - qrfrz(mgs) = 0.0 - ENDIF + real gz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! dz + + real qimax,xni0,roqi0 - ENDIF ! ibiggopt - IF ( lvol(lh) .gt. 1 ) THEN - vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz - ENDIF + real dv - - IF ( nsplinter .ne. 0 ) THEN - IF ( nsplinter .gt. 0 ) THEN - tmp = nsplinter*crfrz(mgs) - ELSE - tmp = -nsplinter*crfrzf(mgs) - ENDIF - csplinter2(mgs) = tmp - qsplinter2(mgs) = Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + real dtptmp + integer itest,nidx,id1,jd1,kd1 + parameter (itest=1) + parameter (nidx=10) + parameter (id1=1,jd1=1,kd1=1) + integer ierr + integer iend -! csplinter(mgs) = csplinter(mgs) + tmp -! qsplinter(mgs) = qsplinter(mgs) + Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel - ENDIF -! IF ( temcg(mgs) .lt. -31.0 ) THEN -! qrfrz(mgs) = qx(mgs,lr)/dtp + qrcnw(mgs) -! qrfrzf(mgs) = qrfrz(mgs) -! crfrz(mgs) = cx(mgs,lr)/dtp + crcnw(mgs) -! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) -! ENDIF -! qrfrz(mgs) = 6.0*xdn(mgs,lr)*xv(mgs,lr)**2*tmp*rhoinv(mgs) -! qrfrz(mgs) = Min( qrfrz(mgs), ffrz*qrmxd(mgs) ) -! crfrz(mgs) = Min( crmxd(mgs), ffrz*crfrz(mgs)) -! crfrz(mgs) = Min(crmxd(mgs),qrfrz(mgs)*rho0(mgs)/xmas(mgs,lr)) - ENDIF -! if ( temg(mgs) .gt. 268.15 ) then - else -! end if - end if - end do + integer ix,kz, il, ic, ir, icp1, irp1, ip1,jp1,kp1 + integer :: jy + integer i,j,k,i1 + integer kzb,kze + real slope1, slope2 + real x1, x2, x3 + real eps,eps2 + parameter (eps=1.e-20,eps2=1.e-5) +! +! Other elec. vars +! + real temele + real trev - ENDIF + logical ldovol, ishail, ltest ! -! Homogeneous freezing of cloud drops to ice crystals -! following Bigg (1953) and Ferrier (1994). ! - if (ndebug .gt. 0 ) write(0,*) 'conc 25b' - do mgs = 1,ngscnt - qwfrz(mgs) = 0.0 - cwfrz(mgs) = 0.0 - qwfrzc(mgs) = 0.0 - cwfrzc(mgs) = 0.0 - qwfrzp(mgs) = 0.0 - cwfrzp(mgs) = 0.0 - IF ( ibfc == 1 .and. temg(mgs) <= 268.15 ) THEN -! if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1. .and. & -! & .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then - if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.0 ) THEN - IF ( ipconc < 2 ) THEN - qwfrz(mgs) = ((2.0)*(brz)/(xdn(mgs,lc)*cx(mgs,lc))) & - & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & - & *rho0(mgs)*(qx(mgs,lc)**2) - qwfrz(mgs) = max(qwfrz(mgs), 0.0) - qwfrz(mgs) = min(qwfrz(mgs),qcmxd(mgs)) - cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li) - ELSEIF ( ipconc .ge. 2 ) THEN - IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN - volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 - ! for mean temperature for freezing: -ln (V) = a*Ts - b - ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 -! dbigg = (6./pi* volt )**(1./3.) +! wind indicies +! + integer mu,mv,mw + parameter (mu=1,mv=2,mw=3) +! +! conversion parameters +! + integer mqcw,mqxw,mtem,mrho,mtim + parameter (mqcw=21,mqxw=21,mtem=21,mrho=5,mtim=6) - - cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))/dtp ! number of droplets with volume greater than volt -!turn off limit so that all can freeze at low temp -!!! cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs)) + real xftim,xftimi,yftim, xftem,yftem, xfqcw,yfqcw, xfqxw,yfqxw + parameter (xftim=0.05,xftimi = 1./xftim,yftim=1.) + parameter (xftem=0.5,yftem=1.) + parameter (xfqcw=2000.,yfqcw=1.) + parameter (xfqxw=2000.,yfqxw=1.) + real dtfac + parameter ( dtfac = 1.0 ) + integer ido(lc:lqmx) - qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) -! cwfrz(mgs) = cx(mgs,lc)*qwfrz(mgs)/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes - ! sure that cwfrz and qwfrz are consistent and prevents - ! spurious creation of ice crystals. - IF ( temg(mgs) < tfrh - 3 ) THEN - cwfrz(mgs) = cx(mgs,lc) - qwfrz(mgs) = qx(mgs,lc) - ENDIF -! IF ( qwfrz(mgs) > 0.5*qx(mgs,lc) ) THEN -! write(0,*) 'Problem with qwfrz(mgs): qwfrz,temcg,volt,xv,cx = ',qwfrz(mgs),qx(mgs,lc),temcg(mgs),volt,xv(mgs,lc),cx(mgs,lc),cwfrz(mgs) -! STOP -! ENDIF -!turn off limit so that all can freeze at low temp -!!! qwfrz(mgs) = Min( qwfrz(mgs), qxmxd(mgs,lc) ) - ENDIF - ENDIF - if ( temg(mgs) .gt. 268.15 ) then - qwfrz(mgs) = 0.0 - cwfrz(mgs) = 0.0 - end if - end if - ENDIF -! - if ( xplate(mgs) .eq. 1 ) then - qwfrzp(mgs) = qwfrz(mgs) - cwfrzp(mgs) = cwfrz(mgs) - end if -! - if ( xcolmn(mgs) .eq. 1 ) then - qwfrzc(mgs) = qwfrz(mgs) - cwfrzc(mgs) = cwfrz(mgs) - end if -! -! qwfrzp(mgs) = 0.0 -! qwfrzc(mgs) = qwfrz(mgs) -! - end do -! +! integer iexy(lc:lqmx,lc:lqmx) +! integer ieswi, ieswir, ieswip, ieswc, ieswr +! integer ieglsw, iegli, ieglir, ieglip, ieglc, ieglr +! integer iegmsw, iegmi, iegmir, iegmip, iegmc, iegmr +! integer ieghsw, ieghi, ieghir, ieghip, ieghc, ieghr +! integer iefwsw, iefwi, iefwir, iefwip, iefwc, iefwr +! integer iehwsw, iehwi, iehwir, iehwip, iehwc, iehwr +! integer iehlsw, iehli, iehlir, iehlip, iehlc, iehlr +! real delqnsa, delqxsa, delqnsb, delqxsb, delqnia, delqxia +! real delqnra, delqxra + + real delqnxa(lc:lqmx) + real delqxxa(lc:lqmx) ! -! Contact freezing nucleation: factor is to convert from L-1 -! T < -2C: via Meyers et al. JAM July, 1992 (31, 708-721) +! external temporary arrays ! - if (ndebug .gt. 0 ) write(0,*) 'conc 25a' - do mgs = 1,ngscnt - - ccia(mgs) = 0.0 - - cwctfz(mgs) = 0.0 - qwctfz(mgs) = 0.0 - ctfzbd(mgs) = 0.0 - ctfzth(mgs) = 0.0 - ctfzdi(mgs) = 0.0 - - cwctfzc(mgs) = 0.0 - qwctfzc(mgs) = 0.0 - cwctfzp(mgs) = 0.0 - qwctfzp(mgs) = 0.0 - - IF ( icfn .ge. 1 ) THEN - - IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN - -! find available # of ice nuclei & limit value to max depletion of cloud water - - IF ( icfn .ge. 2 ) THEN - ccia(mgs) = exp( 4.11 - (0.262)*temcg(mgs) ) ! in m-3, see Walko et al. 1995 - !ccia(mgs) = Min(cwctfz(mgs), ccmxd(mgs) ) - -! now find how many of these collect cloud water to form IN -! Cotton et al 1986 - - knud(mgs) = 2.28e-5 * temg(mgs) / ( pres(mgs)*raero ) !Walko et al. 1995 - knuda(mgs) = 1.257 + 0.4*exp(-1.1/knud(mgs)) !Pruppacher & Klett 1997 eqn 11-16 - gtp(mgs) = 1. / ( fai(mgs) + fbi(mgs) ) !Byers 65 / Cotton 72b - dfar(mgs) = kb*temg(mgs)*(1.+knuda(mgs)*knud(mgs))/(6.*pi*fadvisc(mgs)*raero) !P&K 1997 eqn 11-15 - fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs) - fn2(mgs) = -gtp(mgs)*(ssw(mgs)-1.)*felv(mgs)/pres(mgs) - fnft(mgs) = 0.4*(1.+1.45*knud(mgs)+0.4*knud(mgs)*exp(-1./knud(mgs)))*(ftka(mgs)+2.5*knud(mgs)*kaero) & - & / ( (1.+3.*knud(mgs))*(2*ftka(mgs)+5.*knud(mgs)*kaero+kaero) ) - - -! Brownian diffusion - ctfzbd(mgs) = fn1(mgs)*dfar(mgs) - -! Thermophoretic contact nucleation - ctfzth(mgs) = fn1(mgs)*fn2(mgs)*fnft(mgs)/rho0(mgs) - -! Diffusiophoretic contact nucleation - ctfzdi(mgs) = fn1(mgs)*fn2(mgs)*rw*temg(mgs)/(felv(mgs)*rho0(mgs)) - - cwctfz(mgs) = max( ctfzbd(mgs) + ctfzth(mgs) + ctfzdi(mgs) , 0.) - -! Sum of the contact nucleation processes -! IF ( cx(mgs,lc) .gt. 50.e6) write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs) -! IF ( wvel(mgs) .lt. -0.05 ) write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs) -! IF ( ssw(mgs) .lt. 1.0 .and. cx(mgs,lc) .gt. 1.e6 .and. cwctfz(mgs) .gt. 1. ) THEN -! write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs),fn1(mgs),fn2(mgs) -! write(6,*) 'more = ',nstep,ssw(mgs),dfar(mgs),gtp(mgs),felv(mgs),pres(mgs) -! ENDIF - - ELSEIF ( icfn .eq. 1 ) THEN - IF ( wvel(mgs) .lt. -0.05 ) THEN ! older kludgy version - cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) ) - cwctfz(mgs) = Min((1.0e3)*cwctfz(mgs), ccmxd(mgs) ) !convert to m-3 - ENDIF - ENDIF ! icfn + real t00(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t77(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - IF ( ipconc .ge. 2 ) THEN - cwctfz(mgs) = Min( cwctfz(mgs)/dtp, ccmxd(mgs) ) - qwctfz(mgs) = xmas(mgs,lc)*cwctfz(mgs)/rho0(mgs) - ELSE - qwctfz(mgs) = (cimasn)*cwctfz(mgs)/(dtp*rho0(mgs)) - qwctfz(mgs) = max(qwctfz(mgs), 0.0) - qwctfz(mgs) = min(qwctfz(mgs),qcmxd(mgs)) - ENDIF + real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t1(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t2(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t3(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t4(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t5(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t6(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t8(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) + real t9(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) -! - if ( xplate(mgs) .eq. 1 ) then - qwctfzp(mgs) = qwctfz(mgs) - cwctfzp(mgs) = cwctfz(mgs) - end if -! - if ( xcolmn(mgs) .eq. 1 ) then - qwctfzc(mgs) = qwctfz(mgs) - cwctfzc(mgs) = cwctfz(mgs) - end if -! -! qwctfzc(mgs) = qwctfz(mgs) -! qwctfzp(mgs) = 0.0 -! - end if + real p2(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) ! perturbation Pi + real pn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,na) + real dn(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) + real w(-nor+1:nx+nor,-nor+1:ny+nor,-norz+ng1:nz+norz) - ENDIF ! icfn + real tmp3d(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) - end do -! -! -! -! Hobbs-Rangno ice enhancement (Ferrier, 1994) +! +! declarations microphyscs and for gather/scatter ! - if (ndebug .gt. 0 ) write(0,*) 'conc 23a' - dtrh = 300.0 - hrifac = (1.e-3)*((0.044)*(0.01**3)) - do mgs = 1,ngscnt - ciihr(mgs) = 0.0 - qiihr(mgs) = 0.0 - cicichr(mgs) = 0.0 - qicichr(mgs) = 0.0 - cipiphr(mgs) = 0.0 - qipiphr(mgs) = 0.0 - IF ( ihrn .ge. 1 ) THEN - if ( qx(mgs,lc) .gt. qxmin(lc) ) then - if ( temg(mgs) .lt. 273.15 ) then -! write(iunit,'(3(1x,i3),3(1x,1pe12.5))') -! : igs(mgs),jgs,kgs(mgs),cx(mgs,lc),rho0(mgs),qx(mgs,lc) -! write(iunit,'(1pe15.6)') -! : log(cx(mgs,lc)*(1.e-6)/(3.0)), -! : ((1.e-3)*rho0(mgs)*qx(mgs,lc)), -! : (cx(mgs,lc)*(1.e-6)), -! : ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)), -! : (alog(cx(mgs,lc)*(1.e-6)/(3.0)) * -! > ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6))) + integer nxmpb,nzmpb,nxz + integer jgs,mgs,ngs,numgs + parameter (ngs=500) !500) + integer, parameter :: ngsz = 500 + integer ntt + parameter (ntt=300) - IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN - ciihr(mgs) = ((1.69e17)/dtrh) & - & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) * & - & ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.) - ciihr(mgs) = ciihr(mgs)*(1.0e6) - qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs) - qiihr(mgs) = max(qiihr(mgs), 0.0) - qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs)) - ENDIF -! - if ( xplate(mgs) .eq. 1 ) then - qipiphr(mgs) = qiihr(mgs) - cipiphr(mgs) = ciihr(mgs) - end if -! - if ( xcolmn(mgs) .eq. 1 ) then - qicichr(mgs) = qiihr(mgs) - cicichr(mgs) = ciihr(mgs) - end if -! -! qipiphr(mgs) = 0.0 -! qicichr(mgs) = qiihr(mgs) -! - end if - end if - ENDIF ! ihrn - end do -! -! -! -! simple frozen rain to hail conversion. All of the -! frozen rain larger than 5.0e-3 m in diameter are converted -! to hail. This is done by considering the equation for -! frozen rain mixing ratio: -! -! -! qfw = [ cno(lf) * pi * fwdn / (6 rhoair) ] -! -! /inf -! * | fwdia*3 exp(-dia/fwdia) d(dia) -! /Do + integer ngscnt,igs(ngs),kgs(ngs) + integer kgsp(ngs),kgsm(ngs),kgsm2(ngs) + integer ncuse + parameter (ncuse=0) + integer il0(ngs),il5(ngs),il2(ngs),il3(ngs) +! integer il1m(ngs),il2m(ngs),il3m(ngs),il4m(ngs),il5m(ngs) ! -! The amount to be reclassified as hail is the integral above from -! Do to inf where Do is 5.0e-3 m. + real tdtol,temsav,tfrcbw,tfrcbi + real, parameter :: thnuc = 235.15 ! +! Ice Multiplication Arrays. ! -! qfauh = [ cno(lf) * pi * fwdn / (6 rhoair) ] + real fimt1(ngs),fimta(ngs),fimt2(ngs) !,qmul1(ngs),qmul2(ngs) + real xcwmas ! ! +! Variables for Ziegler warm rain microphysics +! - hdia0 = 300.0e-6 - do mgs = 1,ngscnt - qscnvi(mgs) = 0.0 - cscnvi(mgs) = 0.0 - cscnvis(mgs) = 0.0 -! IF ( .false. ) THEN -! IF ( temg(mgs) .lt. tfr .and. ssi(mgs) .gt. 1.01 .and. qx(mgs,li) .gt. qxmin(li) ) THEN - IF ( temg(mgs) .lt. tfr .and. qx(mgs,li) .gt. qxmin(li) ) THEN - IF ( ipconc .ge. 4 .and. .false. ) THEN - if ( cx(mgs,li) .gt. 10. .and. xdia(mgs,li,1) .gt. 50.e-6 ) then !{ - cirdiatmp = & - & (qx(mgs,li)*rho0(mgs) & - & /(pi*xdn(mgs,li)*cx(mgs,li)))**(1./3.) - IF ( cirdiatmp .gt. 100.e-6 ) THEN !{ - qscnvi(mgs) = & - & ((pi*xdn(mgs,li)*cx(mgs,li)) / (6.0*rho0(mgs)*dtp)) & - & *exp(-hdia0/cirdiatmp) & - & *( (hdia0**3) + 3.0*(hdia0**2)*cirdiatmp & - & + 6.0*(hdia0)*(cirdiatmp**2) + 6.0*(cirdiatmp**3) ) - qscnvi(mgs) = & - & min(qscnvi(mgs),qimxd(mgs)) - IF ( ipconc .ge. 4 ) THEN - cscnvi(mgs) = Min( cimxd(mgs), cx(mgs,li)*Exp(-hdia0/cirdiatmp)) - ENDIF - ENDIF ! } - end if ! } - - ELSEIF ( ipconc .lt. 4 ) THEN + real ccnc(ngs),ccin(ngs),cina(ngs),ccna(ngs) + real cwnccn(ngs) + real sscb ! 'cloud base' SS threshold + parameter ( sscb = 2.0 ) + integer idecss ! flag to turn on (=1) decay of ssmax when no cloud or ice crystals + parameter ( idecss = 1 ) + integer iba ! flag to do condensation/nucleation in 1st or 2nd loop + ! =0 to use ad to calculate SS + ! =1 to use an at end of main jy loop to calculate SS + parameter (iba = 1) + integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat + parameter ( ifilt = 0 ) + real temp1,temp2 ! ,ssold + real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor + real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter, 4 for mass-weighted diameter + real ssmax(ngs) ! maximum SS experienced by a parcel + real ssmx + real dnnet,dqnet +! real cnu,rnu,snu,cinu +! parameter ( cnu = 0.0, rnu = -0.8, snu = -0.8, cinu = 0.0 ) + real bfnu, bfnu0, bfnu1 + parameter ( bfnu0 = (rnu + 2.0)/(rnu + 1.0) ) + real ventr, ventc + real volb, aa1, aa2 + double precision t2s, xdp + double precision xl2p(ngs),rb(ngs) + parameter ( aa1 = 9.44e15, aa2 = 5.78e3 ) ! a1 in Ziegler +! snow parameters: + real cexs, cecs + parameter ( cexs = 0.1, cecs = 0.5 ) + real rvt ! ratio of collection kernels (Zrnic et al, 1993) + parameter ( rvt = 0.104 ) + real kfrag ! rate coefficent for collisional splintering (Schuur & Rutledge 00b) + parameter ( kfrag = 1.0e-6 ) + real mfrag ! assumed ice fragment mass for collisional splintering (Schuur & Rutledge 00b) + parameter ( mfrag = 1.0e-10) + double precision cautn(ngs), rh(ngs), nh(ngs) + real ex1, ft, rhoinv(ngs) + double precision ec0(ngs) + + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4 ! , sstdy, super + real ratio, delx, dely + real dbigg,volt + real chgtmp,fac + real x,y,del,r,rtmp,alpr + double precision :: vent1,vent2 + real g1palp,g4palp + real fqt !charge separation as fn of temperature from Dong and Hallett 1992 + real bs + real v1, v2 + real d1r, d1i, d1s, e1i + real c1sw ! integration factor for snow melting with snu = -0.8 + real, parameter :: vr1mm = 5.23599e-10 ! volume of 1mm diameter sphere (m**3) + real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3 ! volume of a 3 mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 ! volume of 4.5mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) + real vmlt,vshd + real rhosm + parameter ( rhosm = 500. ) + integer nc ! condensation step + real dtcon,dtcon1,dtcon2 ! condensation time step (dtcon*nc = dtp) + real delta + integer ltemq1,ltemq1m ! ,ltemq1m2 + real dqv,qv1,ss1,ss2,qvs1,dqvs,dtemp,dt1 ! temporaries for condensation + real ssi1, ssi2, dqvi, dqvis, dqvii,qis1 + real dqvr, dqc, dqr, dqi, dqs + real qv1m,qvs1m,ss1m,ssi1m,qis1m + real cwmastmp + real dcloud,dcloud2 ! ,as, bs + real cn(ngs) + double precision xvc, xvr + real mwfac + real es(ngs) ! ss(ngs), + real eis(ngs) - qscnvi(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) - qscnvi(mgs) = min(qscnvi(mgs),qxmxd(mgs,li)) - cscnvi(mgs) = qscnvi(mgs)*rho0(mgs)/xmas(mgs,li) - cscnvis(mgs) = 0.5*cscnvi(mgs) + real rwmasn,rwmasx - ENDIF - ENDIF -! ENDIF - end do + real vgra,vfrz + parameter ( vgra = 0.523599*(1.0e-3)**3 ) + + real epsi,d + parameter (epsi = 0.622, d = 0.266) + real r1,qevap ! ,slv + + real vr,nrx,chw,g1,qr,z,z1,rdi,alp,xnutmp,xnuc,g1r,rd1,rdia + + real, parameter :: rhofrz = 900. ! density of graupel from newly-frozen rain + real, parameter :: rimedens = 500. ! default rime density +! real svc(ngs) ! droplet volume ! -! Ventilation coeficients +! contact freezing nucleation ! - do mgs = 1,ngscnt - fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) - end do + real raero,kaero !assumd aerosol radius, thermal conductivity + parameter ( raero = 3.e-7, kaero = 5.39e-3 ) + real kb ! Boltzman constant J K-1 + parameter (kb = 1.3807e-23) + + real knud(ngs),knuda(ngs) !knudsen number and correction factor + real gtp(ngs) !G(T,p) = 1/(a' + b') Cotton 72b + real dfar(ngs) !aerosol diffusivity + real fn1(ngs),fn2(ngs),fnft(ngs) + + real ccia(ngs) + real ctfzbd(ngs),ctfzth(ngs),ctfzdi(ngs) ! +! misc ! - if ( ndebug .gt. 0 ) write(0,*) 'civent' + real ni,nr,d0 + real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs) + real tempc(ngs) + real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) + real temgkm1(ngs), temgkm2(ngs) + real temgx(ngs),temcgx(ngs) + real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) + real elv(ngs),elf(ngs),els(ngs) + real tsqr(ngs),ssi(ngs),ssw(ngs) + real qcwtmp(ngs),qtmp,qtot(ngs) + real qcond(ngs) + real ctmp, sctmp + real cimasn,cimasx,ccimx + real pid4 + real cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1 + real gf73rds, gf83rds + real gf43rds, gf53rds + real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn + parameter ( rwradmn = 50.e-6 ) + real dh0 + + real clionpmx,clionnmx + parameter (clionpmx=1.e9,clionnmx=1.e9) ! Takahashi 84 ! - civenta = 1.258e4 - civentb = 2.331 - civentc = 5.662e4 - civentd = 2.373 - civente = 0.8241 - civentf = -0.042 - civentg = 1.70 - - do mgs = 1,ngscnt - IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & - & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN - IF ( qx(mgs,li) .gt. qxmin(li) ) THEN - cireyn = & - & (civenta*xdia(mgs,li,1)**civentb & - & +civentc*xdia(mgs,li,1)**civentd) & - & / & - & (civente*xdia(mgs,li,1)**civentf+civentg) - xcivent = (fschm(mgs)**(1./3.))*((cireyn/fakvisc(mgs))**0.5) - if ( xcivent .lt. 1.0 ) then - civent(mgs) = 1.0 + 0.14*xcivent**2 - end if - if ( xcivent .ge. 1.0 ) then - civent(mgs) = 0.86 + 0.28*xcivent - end if - ELSE - civent(mgs) = 0.0 - ENDIF - ENDIF ! icond .eq. 1 - end do +! other arrays + real fwet1(ngs),fwet2(ngs) + real fmlt1(ngs),fmlt2(ngs) + real fvds(ngs),fvce(ngs),fiinit(ngs) + real fvent(ngs),fraci(ngs),fracl(ngs) ! + real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs) + real felv(ngs),fels(ngs),felf(ngs) + real felvcp(ngs),felscp(ngs),felfcp(ngs) + real felvs(ngs),felss(ngs) ! ,felfs(ngs) + real fwvdf(ngs),ftka(ngs),fthdf(ngs) + real fadvisc(ngs),fakvisc(ngs) + real fci(ngs),fcw(ngs) + real fschm(ngs),fpndl(ngs) + real fgamw(ngs),fgams(ngs) + real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) + + real cvm ! - igmrwa = 100.0*2.0 - igmrwb = 100.*((5.0+br)/2.0) - rwventa = (0.78)*gmoi(igmrwa) ! 0.78 - rwventb = (0.308)*gmoi(igmrwb) ! 0.562825 - do mgs = 1,ngscnt - IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN - IF ( ipconc .ge. 3 ) THEN - IF ( imurain == 3 ) THEN - IF ( izwisventr == 1 ) THEN - rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) - ELSE ! izwisventr = 2 -! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier's rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br - rwvent(mgs) = & - & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & - & *Sqrt((ar*rhovt(mgs))) & - & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) - ENDIF - - ELSE ! imurain == 1 - ! linear interpolation of complete gamma function -! tmp = 2. + alpha(mgs,lr) -! i = Int(dgami*(tmp)) -! del = tmp - dgam*i -! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - - IF ( iferwisventr == 1 ) THEN - - alpr = Min(alpharmax, alpha(mgs,lr)) -! alpr = alpha(mgs,lr) - x = 1. + alpr - - tmp = 1 + alpr - i = Int(dgami*(tmp)) - del = tmp - dgam*i - g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + real fcci(ngs), fcip(ngs) +! + real :: sfm1(ngs),sfm2(ngs) + real :: gfm1(ngs),gfm2(ngs) + real :: hfm1(ngs),hfm2(ngs) - tmp = 2.5 + alpr + 0.5*bx(lr) - i = Int(dgami*(tmp)) - del = tmp - dgam*i - y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + logical :: wetsfc(ngs),wetsfchl(ngs) + logical :: wetgrowth(ngs), wetgrowthhl(ngs) - - vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) - vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) - - - rwvent(mgs) = & - & 0.78*x + & - & 0.308*fvent(mgs)*y* & - & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + real qitmp(ngs) - ELSEIF ( iferwisventr == 2 ) THEN - -! Following Wisner et al. (1972) - x = 1. + alpha(mgs,lr) - - rwvent(mgs) = & - & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & - & *Sqrt((ar*rhovt(mgs))) & - & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs) + real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) + real vt2ave(ngs) - - ENDIF ! iferwisventr - - ENDIF ! imurain - ELSE - rwvent(mgs) = & - & (rwventa + rwventb*fvent(mgs) & - & *Sqrt((ar*rhovt(mgs))) & - & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) - ENDIF - ELSE - rwvent(mgs) = 0.0 - ENDIF - end do + real :: qx(ngs,lv:lhab) + real :: qxw(ngs,ls:lhab) + real :: cx(ngs,lc:lhab) + real :: cxmxd(ngs,lc:lhab) + real :: qxmxd(ngs,lv:lhab) + real :: scx(ngs,lc:lhab) + real :: xv(ngs,lc:lhab) + real :: vtxbar(ngs,lc:lhab,3) + real :: xmas(ngs,lc:lhab) + real :: xdn(ngs,lc:lhab) + real :: xdia(ngs,lc:lhab,3) + real :: rarx(ngs,ls:lhab) + real :: vx(ngs,li:lhab) + real :: rimdn(ngs,li:lhab) + real :: raindn(ngs,li:lhab) + real :: alpha(ngs,lc:lhab) + real :: dab0lh(ngs,lc:lhab,lr:lhab) + real :: dab1lh(ngs,lc:lhab,lr:lhab) + + real :: galphrout + + real ventrx(ngs) + real ventrxn(ngs) + real g1shr, alphashr + real g1mlr, alphamlr + ! - igmswa = 100.0*2.0 - igmswb = 100.*((5.0+ds)/2.0) - swventa = (0.78)*gmoi(igmswa) - swventb = (0.308)*gmoi(igmswb) - do mgs = 1,ngscnt - IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN - IF ( ipconc .ge. 4 ) THEN - swvent(mgs) = 0.65 + 0.44*fvent(mgs)*Sqrt(vtxbar(mgs,ls,1)*xdia(mgs,ls,1)) - ELSE -! 10-ice version: - swvent(mgs) = & - & (swventa + swventb*fvent(mgs) & - & *Sqrt((cs*rhovt(mgs))) & - & *(xdia(mgs,ls,1)**((1.0+ds)/2.0)) ) - ENDIF - ELSE - swvent(mgs) = 0.0 - ENDIF - end do + real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs) + integer, parameter :: ndiam = 10 + integer :: numdiam + real hwvent0(ndiam+3),hlvent0 ! 0 to d1 + real hwvent1,hlvent1 ! d1 to infinity + real hwvent2,hlvent2 ! d2 to infinity + real gama0,gamb0 + real gama1,gamb1 + real gama2,gamb2 + real, parameter :: mltdiam1 = 9.0e-3, mltdiam2 = 19.0e-3, mltdiam3 = 200.0e-3, mltdiam05 = 4.5e-3 + real :: mltdiam(ndiam+3) + real mltmass1inv,mltmass2inv, mltmass1cgs, mltmass2cgs + real qhmlr0, qhmlr05, qhmlr1, qhmlr2, qhmlr12 + real qhlmlr0, qhlmlr05, qhlmlr1, qhlmlr2, qhlmlr12 + real qxd1, cxd1 ! mass and number up to mltdiam1 + real qxd05, cxd05 ! mass and number up to mltdiam1/2 + + real :: qxd(ndiam+3), cxd(ndiam+3), qhml(ndiam+3), qhml0(ndiam+3) + real :: dqxd(ndiam+3), dcxd(ndiam+3), dqhml(ndiam+3) + + + real civent(ngs) ! + real xmascw(ngs) + real xdnmx(lc:lhab), xdnmn(lc:lhab) + real dnmx + real :: xdiamxmas(ngs,lc:lhab) ! + real cilen(ngs) ! ,ciplen(ngs) +! +! + real rwcap(ngs),swcap(ngs) + real hwcap(ngs) + real hlcap(ngs) + real cicap(ngs) - igmhwa = 100.0*2.0 - igmhwb = 100.0*2.75 - hwventa = (0.78)*gmoi(igmhwa) - hwventb = (0.308)*gmoi(igmhwb) - hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25) - do mgs = 1,ngscnt - IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN - IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN - hwvent(mgs) = & - & ( hwventa + hwventb*hwventc*fvent(mgs) & - & *((xdn(mgs,lh)/rho0(mgs))**(0.25)) & - & *(xdia(mgs,lh,1)**(0.75))) - ELSE ! Ferrier 1994, eq. B.36 - ! linear interpolation of complete gamma function -! tmp = 2. + alpha(mgs,lh) -! i = Int(dgami*(tmp)) -! del = tmp - dgam*i -! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - - x = 1. + alpha(mgs,lh) - - tmp = 1 + alpha(mgs,lh) - i = Int(dgami*(tmp)) - del = tmp - dgam*i - g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + real qvimxd(ngs) + real qimxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) + real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs) + real cionpmxd(ngs),cionnmxd(ngs) + real clionpmxd(ngs),clionnmxd(ngs) - tmp = 2.5 + alpha(mgs,lh) + 0.5*bx(lh) - i = Int(dgami*(tmp)) - del = tmp - dgam*i - y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp - - hwvent(mgs) = & - & ( 0.78*x + & - & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bx(lh)))* & - & Sqrt(xdn(mgs,lh)*ax(lh)*rhovt(mgs)/rg0) ) - - ENDIF - ELSE - hwvent(mgs) = 0.0 - ENDIF - end do - - hlvent(:) = 0.0 - IF ( lhl .gt. 1 ) THEN - igmhwa = 100.0*2.0 - igmhwb = 100.0*2.75 - hwventa = (0.78)*gmoi(igmhwa) - hwventb = (0.308)*gmoi(igmhwb) - hwventc = (4.0*gr/(3.0*cdx(lhl)))**(0.25) - do mgs = 1,ngscnt - IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + real elec(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz) ! Ez (elecsave) - IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN - hlvent(mgs) = & - & ( hwventa + hwventb*hwventc*fvent(mgs) & - & *((xdn(mgs,lhl)/rho0(mgs))**(0.25)) & - & *(xdia(mgs,lhl,1)**(0.75))) - ELSE ! Ferrier 1994, eq. B.36 - ! linear interpolation of complete gamma function -! tmp = 2. + alpha(mgs,lhl) -! i = Int(dgami*(tmp)) -! del = tmp - dgam*i -! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - x = 1. + alpha(mgs,lhl) +! +! + ! Hallett-Mossop arrays + real chmul1(ngs),chlmul1(ngs),csmul1(ngs),csmul(ngs) + real qhmul1(ngs),qhlmul1(ngs),qsmul1(ngs),qsmul(ngs) + + ! splinters from drop freezing + real csplinter(ngs),qsplinter(ngs) + real csplinter2(ngs),qsplinter2(ngs) +! +! +! concentration arrays... +! + real :: chlcnh(ngs), vhlcnh(ngs), vhlcnhl(ngs) + real cracif(ngs), ciacrf(ngs) + real cracr(ngs) - tmp = 1 + alpha(mgs,lhl) - i = Int(dgami*(tmp)) - del = tmp - dgam*i - g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami +! + real ciint(ngs), crfrz(ngs), crfrzf(ngs), crfrzs(ngs) + real cicint(ngs) + real cipint(ngs) + real ciacw(ngs), cwacii(ngs) + real ciacr(ngs), craci(ngs) + real csacw(ngs) + real csacr(ngs) + real csaci(ngs), csacs(ngs) + real cracw(ngs) + real chacw(ngs), chacr(ngs) + real :: chlacw(ngs) ! = 0.0 + real chaci(ngs), chacs(ngs) +! + real :: chlacr(ngs) + real :: chlaci(ngs), chlacs(ngs) + real crcnw(ngs) + real cidpv(ngs),cisbv(ngs) + real cimlr(ngs) - tmp = 2.5 + alpha(mgs,lhl) + 0.5*bx(lhl) - i = Int(dgami*(tmp)) - del = tmp - dgam*i - y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + real chlsbv(ngs), chldpv(ngs) + real chlmlr(ngs), chlmlrr(ngs) + real chlshr(ngs), chlshrr(ngs) - - hlvent(mgs) = & - & ( 0.78*x + & - & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bx(lhl)))* & - & Sqrt(ax(lhl)*rhovt(mgs))) -! : Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp + real chdpv(ngs),chsbv(ngs) + real chmlr(ngs),chcev(ngs) + real chmlrr(ngs) + real chshr(ngs), chshrr(ngs) - ENDIF - ENDIF - end do - ENDIF + real csdpv(ngs),cssbv(ngs) + real csmlr(ngs),cscev(ngs) + real csshr(ngs) + real crcev(ngs) + real crshr(ngs) ! ! +! arrays for w-ac-x ; x-ac-w ! -! Wet growth constants ! - do mgs = 1,ngscnt - fwet1(mgs) = & - & (2.0*pi)* & - & ( felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qss0(mgs)-qx(mgs,lv)) & - & -ftka(mgs)*temcg(mgs) ) & - & / ( rho0(mgs)*(felf(mgs)+fcw(mgs)*temcg(mgs)) ) - fwet2(mgs) = & - & (1.0)-fci(mgs)*temcg(mgs) & - & / ( felf(mgs)+fcw(mgs)*temcg(mgs) ) - end do ! -! Melting constants + real qrcnw(ngs), qwcnr(ngs) + real zrcnw(ngs),zracr(ngs),zracw(ngs),zrcev(ngs) + + + real qracw(ngs) ! qwacr(ngs), + real qiacw(ngs) !, qwaci(ngs) + + real qsacw(ngs) ! ,qwacs(ngs), + real qhacw(ngs) ! qwach(ngs), + real :: qhlacw(ngs) ! = 0.0 + real vhacw(ngs), vsacw(ngs), vhlacw(ngs), vhlacr(ngs) + ! - do mgs = 1,ngscnt - fmlt1(mgs) = (2.0*pi)* & - & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) & - & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) & - & / (felf(mgs)) - fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) - end do + real qsacws(ngs) + ! -! Vapor Deposition constants +! arrays for x-ac-r and r-ac-x; ! - do mgs = 1,ngscnt - fvds(mgs) = & - & (4.0*pi/rho0(mgs))*(ssi(mgs)-1.0)* & - & (1.0/(fai(mgs)+fbi(mgs))) - end do - do mgs = 1,ngscnt - fvce(mgs) = & - & (4.0*pi/rho0(mgs))*(ssw(mgs)-1.0)* & - & (1.0/(fav(mgs)+fbv(mgs))) - end do + real qsacr(ngs),qracs(ngs) + real qhacr(ngs),qhacrmlr(ngs) ! ,qrach(ngs) + real vhacr(ngs), zhacr(ngs), zhacrf(ngs), zrach(ngs), zrachl(ngs) + real qiacr(ngs),qraci(ngs) + + real ziacr(ngs) + + real qracif(ngs),qiacrf(ngs),qiacrs(ngs),ciacrs(ngs) + real :: qhlacr(ngs),qhlacrmlr(ngs) ! = 0.0 + real qsacrs(ngs) !,qracss(ngs) ! -! deposition, sublimation, and melting of snow, graupel and hail +! ice - ice interactions ! - qsmlr(:) = 0.0 - qimlr(:) = 0.0 - qhmlr(:) = 0.0 - qhlmlr(:) = 0.0 - qhfzh(:) = 0.0 - qhlfzhl(:) = 0.0 - vhfzh(:) = 0.0 - vhlfzhl(:) = 0.0 - qsfzs(:) = 0.0 - zsmlr(:) = 0.0 - zhmlr(:) = 0.0 - zhmlrr(:) = 0.0 - zhshr(:) = 0.0 - zhlmlr(:) = 0.0 - zhlshr(:) = 0.0 + real qsaci(ngs) + real qhaci(ngs) + real qhacs(ngs) - zhshrr(:) = 0.0 - zhlmlrr(:) = 0.0 - zhlshrr(:) = 0.0 + real :: csaci0(ngs) ! collision rate only + real :: chaci0(ngs) ! collision rate only + real :: chacs0(ngs) ! collision rate only + real :: chlaci0(ngs) ! = 0.0 + real :: chlacs0(ngs) ! = 0.0 - csmlr(:) = 0.0 - chmlr(:) = 0.0 - chmlrr(:) = 0.0 - chlmlr(:) = 0.0 - chlmlrr(:) = 0.0 + real :: qsaci0(ngs) ! collision rate only + real :: qhaci0(ngs) ! collision rate only + real :: qhacs0(ngs) ! collision rate only + real :: qhlaci0(ngs) ! = 0.0 + real :: qhlacs0(ngs) ! = 0.0 - if ( .not. mixedphase ) then !{ - do mgs = 1,ngscnt + real :: qhlaci(ngs) ! = 0.0 + real :: qhlacs(ngs) ! = 0.0 ! - IF ( temg(mgs) .gt. tfr ) THEN - - IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN - qsmlr(mgs) = & - & min( & - & (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & ! /rhosm & - & , 0.0 ) - ENDIF - -! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs), -! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv) -! ELSE -! qsmlr(mgs) = 0.0 -! ENDIF -! 10ice version: -! > min( -! > (fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) + -! > fmlt2(mgs)*(qsacr(mgs)+qsacw(mgs)) ) -! < , 0.0 ) - - IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN - qhmlr(mgs) = & - & min( & - & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & - & + fmlt2(mgs)*(qhacr(mgs)+qhacw(mgs)) & - & , 0.0 ) - - IF ( ivhmltsoak > 0 .and. qhmlr(mgs) < 0.0 .and. lvol(lh) > 1 .and. xdn(mgs,lh) .lt. xdnmx(lh) ) THEN - ! act as if 100% of the meltwater were soaked into the graupel - v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*(vx(mgs,lh) + rho0(mgs)*qhmlr(mgs)/xdn(mgs,lh) )/(dtp) ! volume available for filling - v2 = -1.0*rho0(mgs)*qhmlr(mgs)/xdnmx(lh) ! volume of melted ice if it were refrozen in the matrix - - vhsoak(mgs) = Min(v1,v2) - - ENDIF - - ENDIF - - - IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN - IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN - qhlmlr(mgs) = & - & min( & - & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & - & + fmlt2(mgs)*(qhlacr(mgs)+qhlacw(mgs)) & - & , 0.0 ) +! conversions +! + real qrfrz(ngs) ! , qirirhr(ngs) + real zrfrz(ngs), zrfrzf(ngs) + real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) + real zhacw(ngs), zhacs(ngs), zhaci(ngs) + real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs) + real zhmlrtmp,zhmlr0inf,zhlmlr0inf + real zhmlrr(ngs),zhlmlrr(ngs),zhshrr(ngs),zhlshrr(ngs) + real zsmlr(ngs), zsmlrr(ngs), zsshr(ngs) + real zhcns(ngs), zhcni(ngs) + real zhwdn(ngs) ! change in Z due to density changes + real zhldn(ngs) ! change in Z due to density changes - IF ( ivhmltsoak > 0 .and. qhlmlr(mgs) < 0.0 .and. lvol(lhl) > 1 .and. xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN - ! act as if 50% of the meltwater were soaked into the graupel - v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*(vx(mgs,lhl) + rho0(mgs)*qhlmlr(mgs)/xdn(mgs,lhl) )/(dtp) ! volume available for filling - v2 = -1.0*rho0(mgs)*qhlmlr(mgs)/xdnmx(lhl) ! volume of melted ice if it were refrozen in the matrix - - vhlsoak(mgs) = Min(v1,v2) - - ENDIF - - ENDIF - ENDIF + real zhlacw(ngs), zhlacs(ngs), zhlacr(ngs) + real zhlmlr(ngs), zhldsv(ngs), zhlsbv(ngs), zhlshr(ngs) - ENDIF + real vrfrzf(ngs), viacrf(ngs) + real qrfrzs(ngs), qrfrzf(ngs) + real qwfrz(ngs), qwctfz(ngs) + real cwfrz(ngs), cwctfz(ngs) + real qwfrzc(ngs), qwctfzc(ngs) + real cwfrzc(ngs), cwctfzc(ngs) + real qwfrzp(ngs), qwctfzp(ngs) + real cwfrzp(ngs), cwctfzp(ngs) + real xcolmn(ngs), xplate(ngs) + real ciihr(ngs), qiihr(ngs) + real cicichr(ngs), qicichr(ngs) + real cipiphr(ngs), qipiphr(ngs) + real qscni(ngs), cscni(ngs), cscnis(ngs) + real qscnvi(ngs), cscnvi(ngs), cscnvis(ngs) + real qhcns(ngs), chcns(ngs), chcnsh(ngs), vhcns(ngs) + real qscnh(ngs), cscnh(ngs), vscnh(ngs) + real qhcni(ngs), chcni(ngs), chcnih(ngs), vhcni(ngs) + real qiint(ngs),qipipnt(ngs),qicicnt(ngs) + real cninm(ngs),cnina(ngs),cninp(ngs),wvel(ngs),wvelkm1(ngs) + real tke(ngs) + real uvel(ngs),vvel(ngs) ! -! qimlr(mgs) = max( qimlr(mgs), -qimxd(mgs) ) -! qsmlr(mgs) = max( qsmlr(mgs), -qsmxd(mgs) ) -! erm 5/10/2007 changed to next line: - if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)/dtp ) ) - if ( .not. mixedphase ) qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.5*qx(mgs,lh)/dtp ) ) -! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)/dtp ) !limits to 1/2 qh or max depletion - qhmlh(mgs) = 0. - - - ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding - - - IF ( lhl .gt. 1 .and. lhlw < 1 ) qhlmlr(mgs) = max( qhlmlr(mgs), Min( -qxmxd(mgs,lhl), -0.5*qx(mgs,lhl)/dtp ) ) + real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs), + real qimlr(ngs),qidsv(ngs),qidsvp(ngs) ! ,qicev(ngs) ! - end do - - endif ! } not mixedphase + real qfdpv(ngs),qfsbv(ngs) ! qfcnv(ngs),qfevv(ngs), + real qfmlr(ngs),qfdsv(ngs) ! ,qfcev(ngs) + real qfwet(ngs),qfdry(ngs),qfshr(ngs) + real qfshrp(ngs) ! - if ( ipconc .ge. 1 ) then - do mgs = 1,ngscnt - cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs) + real :: qhldpv(ngs), qhlsbv(ngs) ! qhlcnv(ngs),qhlevv(ngs), + real :: qhlmlr(ngs), qhldsv(ngs) + real :: qhlwet(ngs), qhldry(ngs), qhlshr(ngs) +! + real :: qrfz(ngs),qsfz(ngs),qhfz(ngs),qhlfz(ngs) +! + real qhdpv(ngs),qhsbv(ngs) ! qhcnv(ngs),qhevv(ngs), + real qhmlr(ngs),qhdsv(ngs),qhcev(ngs),qhcndv(ngs),qhevv(ngs) + real qhmlrlg(ngs),qhlmlrlg(ngs) ! melting from the larger diameters + real qhlcev(ngs), chlcev(ngs) + real qhwet(ngs),qhdry(ngs),qhshr(ngs) + real qhshrp(ngs) + real qhshh(ngs) !accreted water that remains on graupel + real qhmlh(ngs) !melt water that remains on graupel + real qhfzh(ngs) !water that freezes on mixed-phase graupel + real qhlfzhl(ngs) !water that freezes on mixed-phase hail - IF ( .not. mixedphase ) THEN - IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN - csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm) - ELSE - csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsmlr(mgs) - ENDIF + real vhfzh(ngs) ! change in volume from water that freezes on mixed-phase graupel + real vhlfzhl(ngs) ! change in volume from water that freezes on mixed-phase hail + real vhshdr(ngs) !accreted water that leaves on graupel (mixedphase) + real vhlshdr(ngs) !accreted water that leaves on hail (mixedphase) + real vhmlr(ngs) !melt water that leaves graupel (single phase) + real vhlmlr(ngs) !melt water that leaves hail (single phase) + real vhsoak(ngs) ! aquired water that seeps into graupel. + real vhlsoak(ngs) ! aquired water that seeps into hail. +! + real qsdpv(ngs),qssbv(ngs) ! qscnv(ngs),qsevv(ngs), + real qsmlr(ngs),qsdsv(ngs),qscev(ngs),qscndv(ngs),qsevv(ngs) + real qswet(ngs),qsdry(ngs),qsshr(ngs) + real qsshrp(ngs) + real qsfzs(ngs) +! +! + real qipdpv(ngs),qipsbv(ngs) + real qipmlr(ngs),qipdsv(ngs) +! + real qirdpv(ngs),qirsbv(ngs) + real qirmlr(ngs),qirdsv(ngs),qirmlw(ngs) +! + real qgldpv(ngs),qglsbv(ngs) + real qglmlr(ngs),qgldsv(ngs) + real qglwet(ngs),qgldry(ngs),qglshr(ngs) + real qglshrp(ngs) +! + real qgmdpv(ngs),qgmsbv(ngs) + real qgmmlr(ngs),qgmdsv(ngs) + real qgmwet(ngs),qgmdry(ngs),qgmshr(ngs) + real qgmshrp(ngs) + real qghdpv(ngs),qghsbv(ngs) + real qghmlr(ngs),qghdsv(ngs) + real qghwet(ngs),qghdry(ngs),qghshr(ngs) + real qghshrp(ngs) +! + real qrztot(ngs),qrzmax(ngs),qrzfac(ngs) + real qrcev(ngs) + real qrshr(ngs) + real fsw(ngs),fhw(ngs),fhlw(ngs) !liquid water fractions + real qhcnf(ngs) + real :: qhlcnh(ngs) ! = 0.0 + real qhcngh(ngs),qhcngm(ngs),qhcngl(ngs) + + real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel -! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN -! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail -! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) ) -! ELSE - chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) -! ENDIF + real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs) + real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs) + real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) + real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) + real ehxr(ngs),ehlr(ngs),egmr(ngs) + real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs) + real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs) + real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs) + real ehscnv(ngs) + real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) + real ehsclsn(ngs),ehiclsn(ngs) + real ehlsclsn(ngs),ehliclsn(ngs) + real esiclsn(ngs) - IF ( chmlr(mgs) < 0.0 ) THEN - - IF ( ihmlt .eq. 1 ) THEN - chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain - ELSEIF ( ihmlt .eq. 2 ) THEN - IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN -! chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain -! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas - IF(imltshddmr > 0) THEN - ! DTD: If Dmg < sheddiam, then assume complete melting into - ! maximal raindrop. Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop - tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size - tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter - chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) - chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs))) - ELSE ! Old method - chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! into rain - ENDIF - ELSE - chmlrr(mgs) = chmlr(mgs) - ENDIF - ELSEIF ( ihmlt .eq. 0 ) THEN - chmlrr(mgs) = chmlr(mgs) - ENDIF + real :: ehs_collsn = 0.5, ehi_collsn = 1.0 + real :: ehls_collsn = 1.0, ehli_collsn = 1.0 + real :: esi_collsn = 1.0 - ENDIF ! chmlr(mgs) < 0.0 + real ew(8,6) + real cwr(8,2) ! radius and inverse of interval + data cwr / 2.0, 3.0, 4.0, 6.0, 8.0, 10.0, 15.0, 20.0 , & ! radius + & 1.0, 1.0, 0.5, 0.5, 0.5, 0.2, 0.2, 1. / ! inverse of interval + integer icwr(ngs), igwr(ngs), irwr(ngs), ihlr(ngs) + real grad(6,2) ! graupel radius and inverse of interval + data grad / 100., 200., 300., 400., 600., 1000., & + & 1.e-2,1.e-2,1.e-2,5.e-3,2.5e-3, 1. / +!droplet radius: 2 3 4 6 8 10 15 20 + data ew /0.03, 0.07, 0.17, 0.41, 0.58, 0.69, 0.82, 0.88, & ! 100 +! : 0.07, 0.13, 0.27, 0.48, 0.65, 0.73, 0.84, 0.91, ! 150 + & 0.10, 0.20, 0.34, 0.58, 0.70, 0.78, 0.88, 0.92, & ! 200 + & 0.15, 0.31, 0.44, 0.65, 0.75, 0.83, 0.96, 0.91, & ! 300 + & 0.17, 0.37, 0.50, 0.70, 0.81, 0.87, 0.93, 0.96, & ! 400 + & 0.17, 0.40, 0.54, 0.71, 0.83, 0.88, 0.94, 0.98, & ! 600 + & 0.15, 0.37, 0.52, 0.74, 0.82, 0.88, 0.94, 0.98 / ! 1000 +! : 0.11, 0.34, 0.49, 0.71, 0.83, 0.88, 0.94, 0.95 / ! 1400 - IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN ! { + + real da0lr(ngs) + real da0lh(ngs) + real da0lhl(ngs) -! IF ( xdia(mgs,lhl,1) .gt. 1.e-6 .and. Abs(qhlmlr(mgs)) .ge. qxmin(lhl) ) THEN -! chlmlr(mgs) = rho0(mgs)*qhlmlr(mgs)/(pi*xdn(mgs,lhl)*xdia(mgs,lhl,1)**3) ! out of hail -! chlmlr(mgs) = Max( chlmlr(mgs), -cxmxd(mgs,lhl) ) -! ELSE - chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlmlr(mgs) -! ENDIF - - IF ( ihmlt .eq. 1 ) THEN - chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain - ELSEIF ( ihmlt .eq. 2 ) THEN - IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN -! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain -! chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain - IF(imltshddmr > 0) THEN - tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size - tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter - chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam) - chlmlrr(mgs) = -Max(tmp,Min(tmp2,chlmlrr(mgs))) - ELSE - chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain - ENDIF - ELSE - chlmlrr(mgs) = chlmlr(mgs) - ENDIF - ELSEIF ( ihmlt .eq. 0 ) THEN - chlmlrr(mgs) = chlmlr(mgs) - ENDIF - - ENDIF ! } - - ENDIF ! .not. mixedphase - -! 10ice versions: -! chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) -! chmlrr(mgs) = chmlr(mgs) - end do - end if - + real va0 (lc:lqmx) ! collection coefficients from Seifert 2005 + real vab0(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real vab1(lc:lqmx,lc:lqmx) ! collection coefficients from Seifert 2005 + real va1 (lc:lqmx) ! collection coefficients from Seifert 2005 + real ehip(ngs),ehlip(ngs),ehlir(ngs) + real erir(ngs),esir(ngs),eglir(ngs),egmir(ngs),eghir(ngs) + real efir(ngs),ehir(ngs),eirw(ngs),eirir(ngs),ehr(ngs) + real erip(ngs),esip(ngs),eglip(ngs),eghip(ngs) + real efip(ngs),eipi(ngs),eipw(ngs),eipip(ngs) ! -! deposition/sublimation of ice +! arrays for production terms ! - DO mgs = 1,ngscnt - - rwcap(mgs) = (0.5)*xdia(mgs,lr,1) - swcap(mgs) = (0.5)*xdia(mgs,ls,1) - hwcap(mgs) = (0.5)*xdia(mgs,lh,1) - IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1) - - if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then + real ptotal(ngs) ! , pqtot(ngs) ! -! from Cotton, 1972 (Part II) + real pqcwi(ngs),pqcii(ngs),pqrwi(ngs) + real pqswi(ngs),pqhwi(ngs),pqwvi(ngs) + real pqgli(ngs),pqghi(ngs),pqfwi(ngs) + real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) + real pqiri(ngs),pqipi(ngs) ! pqwai(ngs), + real pqlwsi(ngs),pqlwhi(ngs),pqlwhli(ngs) + + real pvhwi(ngs), pvhwd(ngs) + real pvhli(ngs), pvhld(ngs) + real pvswi(ngs), pvswd(ngs) ! - cilen(mgs) = 0.4764*(xdia(mgs,li,1))**(0.958) - cval = xdia(mgs,li,1) - aval = cilen(mgs) - eval = Sqrt(1.0-(aval**2)/(cval**2)) - fval = min(0.99,eval) - gval = alog( abs( (1.+fval)/(1.-fval) ) ) - cicap(mgs) = cval*fval / gval - ELSE - cicap(mgs) = 0.0 - end if - ENDDO + real pqcwd(ngs),pqcid(ngs),pqrwd(ngs) + real pqswd(ngs),pqhwd(ngs),pqwvd(ngs) + real pqgld(ngs),pqghd(ngs),pqfwd(ngs) + real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) + real pqird(ngs),pqipd(ngs) ! pqwad(ngs), + real pqlwsd(ngs),pqlwhd(ngs),pqlwhld(ngs) ! +! real pqxii(ngs,nhab),pqxid(ngs,nhab) ! - qhldsv(:) = 0.0 + real pctot(ngs) + real pcipi(ngs), pcipd(ngs) + real pciri(ngs), pcird(ngs) + real pccwi(ngs), pccwd(ngs) + real pccii(ngs), pccid(ngs) + real pccin(ngs) + real pcrwi(ngs), pcrwd(ngs) + real pcswi(ngs), pcswd(ngs) + real pchwi(ngs), pchwd(ngs) + real pchli(ngs), pchld(ngs) + real pcfwi(ngs), pcfwd(ngs) + real pcgli(ngs), pcgld(ngs) + real pcgmi(ngs), pcgmd(ngs) + real pcghi(ngs), pcghd(ngs) - do mgs = 1,ngscnt - IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & - & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN - qidsv(mgs) = & - & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs) - qsdsv(mgs) = & - & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs) -! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) -! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN -! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1), -! : fvds(mgs),civent(mgs),cicap(mgs) -! ENDIF - ELSE - qidsv(mgs) = 0.0 - qsdsv(mgs) = 0.0 - ENDIF - qhdsv(mgs) = & - & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs) + real pzrwi(ngs), pzrwd(ngs) + real pzhwi(ngs), pzhwd(ngs) + real pzhli(ngs), pzhld(ngs) + real pzswi(ngs), pzswd(ngs) - IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs) -! ! - end do +! other arrays ! - do mgs = 1,ngscnt - IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & - & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN -! qisbv(mgs) = max( min(qidsv(mgs), 0.0), -qimxd(mgs) ) -! qssbv(mgs) = max( min(qsdsv(mgs), 0.0), -qsmxd(mgs) ) -! erm 5/10/2007: - qisbv(mgs) = max( min(qidsv(mgs), 0.0), Min( -qimxd(mgs), -0.7*qx(mgs,li)/dtp ) ) - qssbv(mgs) = max( min(qsdsv(mgs), 0.0), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)/dtp ) ) - qidpv(mgs) = Max(qidsv(mgs), 0.0) - qsdpv(mgs) = Max(qsdsv(mgs), 0.0) - ELSE - qisbv(mgs) = 0.0 - qssbv(mgs) = 0.0 - qidpv(mgs) = 0.0 - qsdpv(mgs) = 0.0 - ENDIF - - qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) - - - qhdpv(mgs) = Max(qhdsv(mgs), 0.0) - - qhlsbv(mgs) = 0.0 - qhldpv(mgs) = 0.0 - IF ( lhl .gt. 1 ) THEN - qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) - qhldpv(mgs) = Max(qhldsv(mgs), 0.0) - ENDIF - - temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) - - IF ( temp1 .gt. qvimxd(mgs) ) THEN - - frac = qvimxd(mgs)/temp1 - - qidpv(mgs) = frac*qidpv(mgs) - qsdpv(mgs) = frac*qsdpv(mgs) - qhdpv(mgs) = frac*qhdpv(mgs) - qhldpv(mgs) = frac*qhldpv(mgs) - -! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) -! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN -! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac -! ENDIF + real dqisdt(ngs) !,advisc(ngs) !dqwsdt(ngs), ,schm(ngs),pndl(ngs) - ENDIF + real qss0(ngs) - end do + real qsacip(ngs) + real pres(ngs) + real pk(ngs) + real rho0(ngs),pi0(ngs) + real rhovt(ngs),sqrtrhovt + real thetap(ngs),theta0(ngs),qwvp(ngs),qv0(ngs) + real thsave(ngs) + real ptwfzi(ngs),ptimlw(ngs) + real psub(ngs),pvap(ngs),pfrz(ngs),ptem(ngs),pmlt(ngs),pevap(ngs),pdep(ngs) + + real cnostmp(ngs) ! for diagnosed snow intercept ! +! iholef = 1 to do hole filling technique version 1 +! which uses all hydrometerors to do hole filling of all hydrometeors +! iholef = 2 to do hole filling technique version 2 +! which uses an individual hydrometeror species to do hole +! filling of a species of a hydrometeor ! - if ( ipconc .ge. 1 ) then - do mgs = 1,ngscnt - cssbv(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qssbv(mgs) - cisbv(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qisbv(mgs) - chsbv(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhsbv(mgs) - IF ( lhl .gt. 1 ) chlsbv(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlsbv(mgs) - csdpv(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsdpv(mgs) - cidpv(mgs) = 0.0 ! (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qidpv(mgs) - chdpv(mgs) = 0.0 ! (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhdpv(mgs) - chldpv(mgs) = 0.0 - end do - end if - +! iholen = interval that hole filling is done ! -! Aggregation of crystals + integer iholef + integer iholen + parameter (iholef = 1) + parameter (iholen = 1) + real cqtotn,cqtotn1 + real cctotn + real citotn + real crtotn + real cstotn + real cvtotn + real cftotn + real cgltotn + real cghtotn + real chtotn + real cqtotp,cqtotp1 + real cctotp + real citotp + real ciptotp + real crtotp + real cstotp + real cvtotp + real cftotp + real chltotp + real cgltotp + real cgmtotp + real cghtotp + real chtotp + real cqfac + real ccfac + real cifac + real cipfac + real crfac + real csfac + real cvfac + real cffac + real cglfac + real cghfac + real chfac + + real ssifac, qvapor ! - if (ndebug .gt. 0 ) write(0,*) 'conc 29a' - do mgs = 1,ngscnt - qscni(mgs) = 0.0 - cscni(mgs) = 0.0 - cscnis(mgs) = 0.0 - if ( ipconc .ge. 4 .and. iscni .ge. 1 .and. qx(mgs,li) .gt. qxmin(li) ) then - IF ( iscni .eq. 1 ) THEN - qscni(mgs) = & - & pi*rho0(mgs)*((0.25)/(6.0)) & - & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & - & *vtxbar(mgs,li,1)/xmas(mgs,li) - cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) - cscnis(mgs) = 0.5*cscni(mgs) - ELSEIF ( iscni .eq. 2 .or. iscni .eq. 4 ) THEN ! Zeigler 1985/Zrnic 1993, sort of - IF ( qidpv(mgs) .gt. 0.0 .and. xdia(mgs,li,3) .ge. 100.e-6 ) THEN -! IF ( xdia(mgs,ls,3) .gt. xdia(mgs,li,3) ) THEN -! qscni(mgs) = Max(0.1,xdia(mgs,li,3)/xdia(mgs,ls,3))*qidpv(mgs) -! erm 9/5/08 changed max to min - qscni(mgs) = Min(0.5, xdia(mgs,li,3)/200.e-6)*qidpv(mgs) -! ELSE -! qscni(mgs) = 0.1*qidpv(mgs) -! ENDIF - cscni(mgs) = 0.5*Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvsmn,xmas(mgs,li))) -! cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li) ) -! IF ( xdia(mgs,ls,3) .le. 200.e-6 ) THEN - cscnis(mgs) = cscni(mgs) -! ELSE -! cscnis(mgs) = 0.0 -! ENDIF - ENDIF +! Miscellaneous variables +! + integer ireadqf,lrho,lqsw,lqgl,lqgm ,lqgh + integer lqrw + real vt + real arg ! gamma is a function + real erbnd1, fdgt1, costhe1 + real qeps + real dyi2,dzi2,cp608,bta1,cnit,dragh,dnz00,pii + real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds,gr - IF ( iscni .ne. 4 ) THEN -! erm 9/5/08 commented second line and added xv to 1st line (zrnic et al 1993) - tmp = ess(mgs)*rvt*aa2*cx(mgs,li)*cx(mgs,li)*xv(mgs,li) -! : ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,li)) + + real xdn0(lc:lhab) + real xdn_new,drhodt + + integer l ,ltemq,inumgs, idelq -! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) + real brz,arz,temq - qscni(mgs) = qscni(mgs) + Min( qxmxd(mgs,li), 2.0*tmp*xmas(mgs,li)*rhoinv(mgs) ) - cscni(mgs) = cscni(mgs) + Min( cxmxd(mgs,li), 2.0*tmp ) - cscnis(mgs) = cscnis(mgs) + Min( cxmxd(mgs,li), tmp ) - ENDIF - ELSEIF ( iscni .eq. 3 ) THEN ! LFO - qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) - qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) - cscni(mgs) = qscni(mgs)*rho0(mgs)/xmas(mgs,li) - cscnis(mgs) = 0.5*cscni(mgs) -! write(iunit,*) 'qscni, qi = ',qscni(mgs),qx(mgs,li),igs(mgs),kgs(mgs) - ENDIF + real ssival,tqvcon + real cdx(lc:lhab) + real cnox + real cval,aval,eval,fval,gval ,qsign,ftelwc,qconkq + real qconm,qconn,cfce15,gf8,gf4i,gf3p5,gf1a,gf1p5,qdiff,argrcnw + real c4,bradp,bl2,bt2,dtrh,hrifac, hdia0,hdia1,civenta,civentb + real civentc,civentd,civente,civentf,civentg,cireyn,xcivent + real cipventa,cipventb,cipventc,cipventd,cipreyn,cirventa + real cirventb + integer igmrwa,igmrwb,igmswa, igmswb,igmfwa,igmfwb,igmhwa,igmhwb + real rwventa ,rwventb,swventa,swventb,fwventa,fwventb,fwventc + real hwventa,hwventb + real hwventc, hlventa, hlventb, hlventc + real glventa, glventb, glventc + real gmventa, gmventb, gmventc, ghventa, ghventb, ghventc + real dzfacp, dzfacm, cmassin, cwdiar + real rimmas, rhobar + real argtim, argqcw, argqxw, argtem + real frcswsw, frcswgl, frcswgm, frcswgh, frcswfw, frcswsw1 + real frcglgl, frcglgm, frcglgh, frcglfw, frcglgl1 + real frcgmgl, frcgmgm, frcgmgh, frcgmfw, frcgmgm1 + real frcghgl, frcghgm, frcghgh, frcghfw, frcghgh1 + real frcfwgl, frcfwgm, frcfwgh, frcfwfw, frcfwfw1 + real frcswrsw, frcswrgl, frcswrgm, frcswrgh, frcswrfw + real frcswrsw1 + real frcrswsw, frcrswgl, frcrswgm, frcrswgh, frcrswfw + real frcrswsw1 + real frcglrgl, frcglrgm, frcglrgh, frcglrfw, frcglrgl1 + real frcrglgl + real frcrglgm, frcrglgh, frcrglfw, frcrglgl1 + real frcgmrgl, frcgmrgm, frcgmrgh, frcgmrfw, frcgmrgm1 + real frcrgmgl, frcrgmgm, frcrgmgh, frcrgmfw, frcrgmgm1 + real sum, qweps, gf2a, gf4a, dqldt, dqidt, dqdt + real frcghrgl, frcghrgm, frcghrgh, frcghrfw, frcghrgh1, frcrghgl + real frcrghgm, frcrghgh, frcrghfw, frcrghgh1 + real a1,a2,a3,a4,a5,a6 + real gamss + real cdw, cdi, denom1, denom2, delqci1, delqip1 + real cirtotn, ciptotn, cgmtotn, chltotn, cirtotp + real cgmfac, chlfac, cirfac + integer igmhla, igmhlb, igmgla, igmglb, igmgma, igmgmb + integer igmgha, igmghb + integer idqis, item, itim0 + integer iqgl, iqgm, iqgh, iqrw, iqsw + integer itertd, ia + + real tau, ewtmp + + integer cntnic_noliq + real q_noliqmn, q_noliqmx + real scsacimn, scsacimx + + double precision :: dtpinv + +! arrays for temporary bin space - ELSEIF ( ipconc < 4 ) THEN ! LFO - IF ( lwsm6 ) THEN - qimax = rhoinv(mgs)*roqimax - qscni(mgs) = Min(0.9d0*qx(mgs,li), Max( 0.d0, (qx(mgs,li) - qimax)*dtpinv ) ) - ELSE - qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) - qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) - ENDIF - else ! 10-ice version - if ( qx(mgs,li) .gt. qxmin(li) ) then - qscni(mgs) = & - & pi*rho0(mgs)*((0.25)/(6.0)) & - & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & - & *vtxbar(mgs,li,1)/xmas(mgs,li) - cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) - end if - end if - end do + real :: qaacw ! combined qsacw-qhacw for WSM6 variation + +! inline functions for Newton method + ! +! #################################################################### ! -! compute dry growth rate of snow, graupel, and hail +! Start routine ! - do mgs = 1,ngscnt +! #################################################################### + + + ! - qsdry(mgs) = qsacr(mgs) + qsacw(mgs) & - & + qsaci(mgs) + + pb(:) = 0.0 + pinit(:) = 0.0 + itile = nx + jtile = ny + ktile = nz + ixend = nx + jyend = ny + kzend = nz + nxend = nx + 1 + nyend = ny + 1 + nzend = nz + kzbeg = 1 + nzbeg = 1 + + istag = 0 + jstag = 0 + kstag = 1 + + ! - qhdry(mgs) = qhaci(mgs) + qhacs(mgs) & - & + qhacr(mgs) & - & + qhacw(mgs) +! slope intercepts ! - qhldry(mgs) = 0.0 - IF ( lhl .gt. 1 ) THEN - qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & - & + qhlacr(mgs) & - & + qhlacw(mgs) + + IF ( ngs .lt. nz ) THEN +! write(0,*) 'Error in ICEZVD: Must have ngs .ge. nz!' +! STOP ENDIF - end do -! -! set wet growth and shedding -! - do mgs = 1,ngscnt -! -! qswet(mgs) = -! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) -! > + fwet2(mgs)*(qsaci(mgs)+qsacir(mgs) -! > +qsacip(mgs)) ) -! qswet(mgs) = max( 0.0, qswet(mgs)) -! -! IF ( dnu(lh) .ne. 0. ) THEN -! qhwet(mgs) = qhdry(mgs) -! ELSE - qhwet(mgs) = & - & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & - & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) - qhwet(mgs) = max( 0.0, qhwet(mgs)) -! ENDIF - qhlwet(mgs) = 0.0 - IF ( lhl .gt. 1 ) THEN - qhlwet(mgs) = & - & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & - & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) - qhlwet(mgs) = max( 0.0, qhlwet(mgs)) - ENDIF -! -! qhlwet(mgs) = qhldry(mgs) + cntnic_noliq = 0 + q_noliqmn = 0.0 + q_noliqmx = 0.0 + scsacimn = 0.0 + scsacimx = 0.0 - end do -! -! shedding rate -! - qsshr(:) = 0.0 - qhshr(:) = 0.0 - qhlshr(:) = 0.0 - qhshh(:) = 0.0 - csshr(:) = 0.0 - chshr(:) = 0.0 - chlshr(:) = 0.0 - chshrr(:) = 0.0 - chlshrr(:) = 0.0 - vhshdr(:) = 0.0 - vhlshdr(:) = 0.0 - wetsfc(:) = .false. - wetgrowth(:) = .false. - wetsfchl(:) = .false. - wetgrowthhl(:) = .false. + ldovol = .false. + + DO il = lc,lhab + ldovol = ldovol .or. ( lvol(il) .gt. 1 ) + ENDDO - do mgs = 1,ngscnt +! DO il = lc,lhab +! write(iunit,*) 'delqnxa(',il,') = ',delqnxa(il) +! ENDDO + ! +! density maximums and minimums ! + +! +! Set terminal velocities... +! also set drag coefficients ! - qhshr(mgs) = Min( 0.0, qhwet(mgs) - qhdry(mgs) ) ! water that freezes should never be more than what sheds - + dtpinv = 1.d0/dtp - qhlshr(mgs) = Min( 0.0, qhlwet(mgs) - qhldry(mgs) ) +! ! -! limit wet growth to only higher density particles +! electricity constants ! - qsshr(mgs) = 0.0 +! mixing ratio epsilon ! + qeps = 1.0e-20 + +! rebound efficiency (erbnd) ! -! no shedding for temperatures < 243.15 ! - if ( temg(mgs) .lt. 243.15 ) then - qsshr(mgs) = 0.0 - qhshr(mgs) = 0.0 - qhlshr(mgs) = 0.0 - vhshdr(mgs) = 0.0 - vhlshdr(mgs) = 0.0 - wetsfc(mgs) = .false. - wetgrowth(mgs) = .false. - wetsfchl(mgs) = .false. - wetgrowthhl(mgs) = .false. - end if ! -! shed all at temperatures > 273.15 +! constants ! - if ( temg(mgs) .gt. tfr ) then - - qsshr(mgs) = -qsdry(mgs) - qhlshr(mgs) = -qhldry(mgs) - qhshr(mgs) = -qhdry(mgs) - vhshdr(mgs) = -vhacw(mgs) - vhacr(mgs) - vhlshdr(mgs) = -vhlacw(mgs) - qhwet(mgs) = 0.0 - qhlwet(mgs) = 0.0 - end if + cp608 = 0.608 + aradcw = -0.27544 + bradcw = 0.26249e+06 + cradcw = -1.8896e+10 + dradcw = 4.4626e+14 + bta1 = 0.6 + cnit = 1.0e-02 + dragh = 0.60 + dnz00 = 1.225 +! cs = 4.83607122 +! ds = 0.25 +! new values for cs and ds + cs = 12.42 + ds = 0.42 + pii = piinv ! 1./pi + pid4 = pi/4.0 +! qscrit = 6.0e-04 + gf1 = 1.0 ! gamma(1.0) + gf1p5 = 0.8862269255 ! gamma(1.5) + gf2 = 1.0 ! gamma(2.0) + gf3 = 2.0 ! gamma(3.0) + gf3p5 = 3.32335097 ! gamma(3.5) + gf4 = 6.00 ! gamma(4.0) + gf5 = 24.0 ! gamma(5.0) + gf6 = 120.0 ! gamma(6.0) + gf7 = 720.0 ! gamma(7.0) + gf4br = 17.837861981813607 ! gamma(4.0+br) + gf4ds = 10.41688578110938 ! gamma(4.0+ds) + gf4p5 = 11.63172839656745 ! gamma(4.0+0.5) + gf3ds = 3.0458730354120997 ! gamma(3.0+ds) + gf1ds = 0.8863557896089221 ! gamma(1.0+ds) + gr = 9.8 + gf43rds = 0.8929795116 ! gamma(4./3.) + gf53rds = 0.9027452930 ! gamma(5./3.) + gf73rds = 1.190639349 ! gamma(7./3.) + gf83rds = 1.504575488 ! gamma(8./3.) ! -! if (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN - wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) - wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) -! ENDIF - - if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN - wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) - wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) - ENDIF - - end do +! constants ! - if ( ipconc .ge. 1 ) then - do mgs = 1,ngscnt - csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) - chshr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) - IF ( temg(mgs) < tfr ) THEN - chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding - ELSE - IF(imltshddmr > 0) THEN - ! DTD: If Dmg < sheddiam, then assume complete melting into - ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop - tmp = -Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain - tmp2 = -rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter - chshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) - chshrr(mgs) = -Max(tmp,Min(tmp2,chshrr(mgs))) - ELSE - chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to maximum size allowed for rain or 4.5mm diameter, whichever is smaller -! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain - ENDIF - ENDIF - chlshr(mgs) = 0.0 - chlshrr(mgs) = 0.0 - IF ( lhl .gt. 1 ) THEN - chlshr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) - IF ( temg(mgs) < tfr ) THEN - chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding -! chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vr1mm) ) ! maximum of 1mm drops from shedding - ELSE - IF(imltshddmr > 0) THEN - ! DTD: If Dmg < sheddiam, then assume complete melting into - ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop - tmp = -Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain - tmp2 = -rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter - chlshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lhl,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(sheddiam0-sheddiam) - chlshrr(mgs) = -Max(tmp,Min(tmp2,chlshrr(mgs))) - ELSE - chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to 4.5mm diameter or maximum size allowed for rain, whichever is smaller -! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain - ENDIF - ENDIF - ENDIF - end do - end if +! +! general constants for microphysics +! + brz = 100.0 + arz = 0.66 + + bfnu1 = (4. + alphar)*(5. + alphar)*(6. + alphar)/ & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)) + + galpharaut = (6.+alpharaut)*(5.+alpharaut)*(4.+alpharaut)/ & + & ((3.+alpharaut)*(2.+alpharaut)*(1.+alpharaut)) + + vfrz = 0.523599*(dfrz)**3 + vmlt = Min(xvmx(lr), 0.523599*(dmlt)**3 ) + vshd = Min(xvmx(lr), 0.523599*(dshd)**3 ) + + tdtol = 1.0e-05 + tfrcbw = tfr - cbw + tfrcbi = tfr - cbi ! -! final decisions ! - do mgs = 1,ngscnt + ! -! Snow +! cw constants in mks units ! - if ( qsshr(mgs) .lt. 0.0 ) then - qsdpv(mgs) = 0.0 - qssbv(mgs) = 0.0 - else - qsshr(mgs) = 0.0 - end if +! cwmasn = 4.25e-15 ! radius of 1.0e-6 + mwfac = 6.0**(1./3.) + IF ( ipconc .ge. 2 ) THEN +! cwmasn = xvmn(lc)*1000. +! cwradn = 1.0e-6 +! cwmasx = xvmx(lc)*1000. + ENDIF + rwmasn = xvmn(lr)*1000. + rwmasx = xvmx(lr)*1000. + ! -! if ( qsdry(mgs) .lt. qswet(mgs) ) then -! qswet(mgs) = 0.0 -! else -! qsdry(mgs) = 0.0 -! end if +! ci constants in mks units ! + cimasn = Min(cimas0, cimas1) ! 12 microns for 0.1871*(xmas(mgs,li)**(0.3429)) + cimasx = 1.0e-8 ! 338 microns + ccimx = 5000.0e3 ! max of 5000 per liter -! zero the shedding rates when wet snow/graupel included. -! shedding of wet snow/graupel is calculated after summing other sources/sinks. - if (mixedphase) then - qsshr(mgs) = 0.0 - qhshr(mgs) = 0.0 - csshr(mgs) = 0.0 - chshr(mgs) = 0.0 - chshrr(mgs) = 0.0 - vhshdr(mgs) = 0.0 - IF ( lhlw > 1 ) THEN - qhlshr(mgs) = 0.0 - vhlshdr(mgs) = 0.0 - chlshr(mgs) = 0.0 - chlshrr(mgs) = 0.0 - ENDIF - end if - -! graupel ! +! constants for paramerization ! - if ( wetgrowth(mgs) .or. (mixedphase .and. fhw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then - - -! soaking (when not advected liquid water film with graupel) - - IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN - ! rescale volumes to maximum density - rimdn(mgs,lh) = xdnmx(lh) - raindn(mgs,lh) = xdnmx(lh) - vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh) - vhacr(mgs) = qhacr(mgs)*rho0(mgs)/raindn(mgs,lh) -! IF ( lvol(lh) .gt. 1 .and. wetgrowth(mgs) ) THEN - IF ( xdn(mgs,lh) .lt. xdnmx(lh) ) THEN - ! soak some liquid into the graupel -! v1 = xdnmx(lh)*vx(mgs,lh)/(xdn(mgs,lh)*dtp) ! volume available for filling - v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*vx(mgs,lh)/(dtp) ! volume available for filling -! tmp = (vx(mgs,lh)/rho0(mgs))*(xdnmx(lh) - xdn(mgs,lh)) ! max mixing ratio of liquid water that can be added - v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion - - vhsoak(mgs) = Min(v1,v2) - - ENDIF - - vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) - - ELSEIF ( lvol(lh) .gt. 1 .and. mixedphase ) THEN -! vhacw(mgs) = rho0(mgs)*qhacw(mgs)/xdn0(lr) -! vhacr(mgs) = rho0(mgs)*qhacr(mgs)/xdn0(lr) - ENDIF - - - qhdpv(mgs) = 0.0 -! qhsbv(mgs) = 0.0 - chdpv(mgs) = 0.0 -! chsbv(mgs) = 0.0 +! +! set save counter (number of saves): nsvcnt +! +! nsvcnt = 0 + iend = 0 -! collection efficiency modification - IF ( ehi(mgs) .gt. 0.0 ) THEN - qhaci(mgs) = Min(qimxd(mgs),qhaci(mgs)/ehi(mgs)) ! effectively sets collection eff to 1 - ENDIF - IF ( ehs(mgs) .gt. 0.0 ) THEN -! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs)) ! effectively sets collection eff to 1 - qhacs(mgs) = qhacs(mgs)/ehs(mgs) ! divide out the collection efficiency - ehs(mgs) = min(ehsfrac*ehs(mgs),ehsmax) ! modify it - qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)*ehs(mgs)) ! plug it back in - ENDIF +! timetd1 = etime(tarray) +! timetd1 = tarray(1) -! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop - wetsfc(mgs) = .true. +! +!*********************************************************** +! start jy loop +!*********************************************************** +! - else -! qhshr(mgs) = 0.0 - end if +! do 9999 jy = 1,ny-jstag ! +! VERY IMPORTANT: SET jy = jgs ! -! hail + jy = jgs + + +! t1(:,:,:) = 0 +! t2(:,:,:) = 0 +! t3(:,:,:) = 0 +! t4(:,:,:) = 0 +! t5(:,:,:) = 0 +! t6(:,:,:) = 0 +! t8(:,:,:) = 0 + + IF ( ipconc < 2 ) THEN ! Make a copy of cloud droplet mixing ratio to use for homogeneous freezing + DO kz = 1,nz + DO ix = 1,itile + t9(ix,jy,kz) = an(ix,jy,kz,lc) + ENDDO + ENDDO + ENDIF + ! -! if ( lhl .gt. 1 .and. qhlshr(mgs) .lt. 0.0 ) then - if ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then -! if ( wetgrowthhl(mgs) ) then - +!..Gather microphysics +! + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE' - qhldpv(mgs) = 0.0 -! qhlsbv(mgs) = 0.0 - chldpv(mgs) = 0.0 -! chlsbv(mgs) = 0.0 + + nxmpb = 1 + nzmpb = 1 + nxz = itile*nz + numgs = nxz/ngs + 1 +! write(0,*) 'ICEZVD_GS: ENTER GATHER STAGE: nx,nz,nxz,numgs,ngs = ',nx,nz,nxz,numgs,ngs + do 1000 inumgs = 1,numgs + ngscnt = 0 + + do kz = nzmpb,nz + do ix = nxmpb,itile + pqs(1) = t00(ix,jy,kz) +! pqs(kz) = t00(ix,jy,kz) - IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN -! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN + theta(1) = an(ix,jy,kz,lt) + temg(1) = t0(ix,jy,kz) + temcg(1) = temg(1) - tfr + tqvcon = temg(1)-cbw + ltemq = (temg(1)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(1) = pqs(1)*tabqvs(ltemq) + qis(1) = pqs(1)*tabqis(ltemq) - rimdn(mgs,lhl) = xdnmx(lhl) - raindn(mgs,lhl) = xdnmx(lhl) - vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) - vhlacr(mgs) = qhlacr(mgs)*rho0(mgs)/raindn(mgs,lhl) + qss(1) = qvs(1) - IF ( xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN - ! soak some liquid into the hail -! v1 = xdnmx(lhl)*vx(mgs,lhl)/(xdn(mgs,lhl)*dtp) ! volume available for filling - v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*vx(mgs,lhl)/(dtp) ! volume available for filling -! tmp = (vx(mgs,lhl)/rho0(mgs))*(xdnmx(lhl) - xdn(mgs,lhl)) ! max mixing ratio of liquid water that can be added - v2 = rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) ! volume of frozen accretion - IF ( v1 > v2 ) THEN ! all the frozen stuff fits in - vhlsoak(mgs) = v2 - ELSE ! fill up the available space - vhlsoak(mgs) = v1 - ENDIF -! vhlacw(mgs) = 0.0 -! vhlacr(mgs) = Max( 0.0, v2 - v1 ) - ELSE - vhlsoak(mgs) = 0.0 -! vhlacw(mgs) = 0.0 -! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl) - - ENDIF +! IF ( jy .eq. 1 .and. ix .eq. 24 ) THEN +! write(91,*) 'kz,qv,th: ',kz,an(ix,jy,kz,lv),an(ix,jy,kz,lt),pqs(kz),tabqvs(ltemq),qvs(kz) +! ENDIF - vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) + if ( temg(1) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) + qss(1) = qis(1) + else +! IF ( an(ix,jy,kz,lv) .gt. qss(kz) ) THEN +! write(iunit,*) 'qss exceeded at ',ix,jy,kz,qss(kz),an(ix,jy,kz,lv),temg(kz) +! write(iunit,*) 'other temg = ',theta(kz)*(pinit(kz)+p2(ix,jy,kz)) +! ENDIF + end if +! + ishail = .false. + IF ( lhl > 1 ) THEN + IF ( an(ix,jy,kz,lhl) .gt. qxmin(lhl) ) ishail = .true. + ENDIF + + if ( an(ix,jy,kz,lv) .gt. qss(1) .or. & + & an(ix,jy,kz,lc) .gt. qxmin(lc) .or. & + & an(ix,jy,kz,li) .gt. qxmin(li) .or. & + & an(ix,jy,kz,lr) .gt. qxmin(lr) .or. & + & an(ix,jy,kz,ls) .gt. qxmin(ls) .or. & + & an(ix,jy,kz,lh) .gt. qxmin(lh) .or. ishail ) then + ngscnt = ngscnt + 1 + igs(ngscnt) = ix + kgs(ngscnt) = kz + if ( ngscnt .eq. ngs ) goto 1100 + end if + enddo !ix + nxmpb = 1 + enddo !kz + 1100 continue + if ( ngscnt .eq. 0 ) go to 9998 - ELSEIF ( lvol(lhl) .gt. 1 .and. mixedphase ) THEN -! vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/xdn0(lr) -! vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/xdn0(lr) - ENDIF + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: dbg = 5' - IF ( ehli(mgs) .gt. 0.0 ) THEN - qhlaci(mgs) = Min(qimxd(mgs),qhlaci(mgs)/ehli(mgs)) - ENDIF - IF ( ehls(mgs) .gt. 0.0 ) THEN - qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs)) - ENDIF - -! qhlwet(mgs) = 1.0 +! write(0,*) 'allocating qc -! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop - wetsfchl(mgs) = .true. + + xv(:,:) = 0.0 + xmas(:,:) = 0.0 + vtxbar(:,:,:) = 0.0 + xdia(:,:,:) = 0.0 + raindn(:,:) = 900. + cx(:,:) = 0.0 + alpha(:,:) = 0.0 + DO il = li,lhab + DO mgs = 1,ngscnt + rimdn(mgs,il) = rimedens ! xdn0(il) + ENDDO + ENDDO +! +! define temporaries for state variables to be used in calculations +! + do mgs = 1,ngscnt + kgsm(mgs) = max(kgs(mgs)-1,1) + kgsp(mgs) = min(kgs(mgs)+1,nz-1) + kgsm2(mgs) = Max(kgs(mgs)-2,1) + theta0(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + thetap(mgs) = an(igs(mgs),jy,kgs(mgs),lt) - theta0(mgs) + theta(mgs) = an(igs(mgs),jy,kgs(mgs),lt) + qv0(mgs) = an(igs(mgs),jy,kgs(mgs),lv) + qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv) - qv0(mgs) ! qv0(mgs) is full qv, so qwvp starts as zero! + pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) + rhoinv(mgs) = 1.0/rho0(mgs) + rhovt(mgs) = Sqrt(rho00/rho0(mgs)) + pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) + temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) + temgkm1(mgs) = t0(igs(mgs),jy,kgsm(mgs)) + temgkm2(mgs) = t0(igs(mgs),jy,kgsm2(mgs)) + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) + temcg(mgs) = temg(mgs) - tfr + qss0(mgs) = (380.0)/(pres(mgs)) + pqs(mgs) = (380.0)/(pres(mgs)) + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + es(mgs) = 6.1078e2*tabqvs(ltemq) + eis(mgs) = 6.1078e2*tabqis(ltemq) + cnostmp(mgs) = cno(ls) +! - else -! qhlshr(mgs) = 0.0 -! qhlwet(mgs) = 0.0 + il5(mgs) = 0 + if ( temg(mgs) .lt. tfr ) then + il5(mgs) = 1 end if + enddo !mgs + + IF ( ipconc < 1 .and. lwsm6 ) THEN + DO mgs = 1,ngscnt + tmp = Min( 0.0, temcg(mgs) ) + cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) + ENDDO + ENDIF +! +! zero arrays that are used but not otherwise set (tm) +! + do mgs = 1,ngscnt + qhshr(mgs) = 0.0 + end do +! +! set temporaries for microphysics variables +! + DO il = lv,lhab + do mgs = 1,ngscnt + qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) + ENDDO end do + + qxw(:,:) = 0.0 + + + + scx(:,:) = 0.0 ! -! Ice -> graupel conversion +! set shape parameters ! - DO mgs = 1,ngscnt - - qhcni(mgs) = 0.0 - chcni(mgs) = 0.0 - chcnih(mgs) = 0.0 - vhcni(mgs) = 0.0 - - IF ( iglcnvi .ge. 1 ) THEN - IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs) - qidpv(mgs) .gt. 0.0 ) THEN - - - tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & - & *((0.60)*vtxbar(mgs,li,1)) & - & /(temg(mgs)-273.15))**(rimc2) - tmp = Min( Max( rimc3, tmp ), 900.0 ) - - ! Assume that half the volume of the embryo is rime with density 'tmp' - ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 - ! V = 2*m/(rhoi + rhorime) - -! write(0,*) 'rime dens = ',tmp - - IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN - r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) -! r = Max( r, 400. ) - qhcni(mgs) = (qiacw(mgs) - qidpv(mgs)) ! *float(iglcnvi) - chcni(mgs) = cx(mgs,li)*qhcni(mgs)/qx(mgs,li) -! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) - chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) -! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) - vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r - ENDIF - + IF ( imurain == 1 ) THEN + alpha(:,lr) = alphar + ELSEIF ( imurain == 3 ) THEN + alpha(:,lr) = xnu(lr) ENDIF - + alpha(:,li) = xnu(li) + + IF ( imusnow == 1 ) THEN + alpha(:,ls) = alphas + ELSEIF ( imusnow == 3 ) THEN + alpha(:,ls) = xnu(ls) ENDIF - + DO il = lc,lhab + do mgs = 1,ngscnt + IF ( il .ge. lg ) alpha(mgs,il) = dnu(il) + DO ic = lr,lhab + dab0lh(mgs,il,ic) = dab0(ic,il) + dab1lh(mgs,il,ic) = dab1(ic,il) + ENDDO ENDDO + end do - qhlcnh(:) = 0.0 - chlcnh(:) = 0.0 - vhlcnh(:) = 0.0 - vhlcnhl(:) = 0.0 - zhlcnh(:) = 0.0 - - qhcnhl(:) = 0.0 - chcnhl(:) = 0.0 - vhcnhl(:) = 0.0 - zhcnhl(:) = 0.0 +! DO mgs = 1,ngscnt + da0lh(:) = da0(lh) + da0lr(:) = da0(lr) + IF ( lzh < 1 .or. lzhl < 1 ) THEN + rzxhlh(:) = rzhl/rz + ELSEIF ( lzh > 1 .and. lzhl > 1 ) THEN + rzxhlh(:) = 1. + ENDIF + IF ( lzr > 1 ) THEN + rzxh(:) = 1. + rzxhl(:) = 1. + ELSE + rzxh(:) = rz + rzxhl(:) = rzhl + ENDIF + ! ENDDO - - IF ( lhl .gt. 1 ) THEN + IF ( lhl .gt. 1 ) THEN + DO mgs = 1,ngscnt + da0lhl(mgs) = da0(lhl) + ENDDO + ENDIF - IF ( ihlcnh == 1 ) THEN + ventrx(:) = ventr + ventrxn(:) = ventrn ! -! Graupel (h) conversion to hail (hl) based on Milbrandt and Yau 2005b +! set concentrations ! - DO mgs = 1,ngscnt - -! IF ( lhl .gt. 1 .and. ipconc .ge. 5 .and. qx(mgs,lh) .gt. 1.0e-3 .and. -! : xdn(mgs,lh) .gt. 750. .and. qhshr(mgs) .lt. 0.0 .and. -! : xdia(mgs,lh,3) .gt. 1.e-3 ) THEN - IF ( wetgrowth(mgs) .and. (xdn(mgs,lh) .gt. hldnmn .or. lvh < 1 ) .and. & ! correct this when hail gets turned on -! IF ( ( qhshr(mgs) .lt. 0.0 .or. rimdn(mgs,lh) .gt. 800. ) .and. & - & rimdn(mgs,lh) .gt. 800. .and. & - & xdia(mgs,lh,3) .gt. hlcnhdia .and. qx(mgs,lh) .gt. hlcnhqmin ) THEN -! : xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3 ) THEN ! 0823.2008 erm test -! IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN - IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN - ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05 -! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - -! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0) - x = (1.1e4*(rho0(mgs)*qx(mgs,lc)) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0e-3 ) - IF ( x > 1.e-20 ) THEN - arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit - dh0 = 0.01*(exp(arg) - 1.0) - ELSE - dh0 = 1.e30 - ENDIF -! dh0 = Max( dh0, 5.e-3 ) - -! IF ( dh0 .gt. 0.0 ) write(0,*) 'dh0 = ',dh0 -! IF ( dh0 .gt. 1.0e-4 ) THEN - IF ( xdia(mgs,lh,3)/dh0 .gt. 0.1 ) THEN -! IF ( xdia(mgs,lh,3) .lt. 20.*dh0 .and. dh0 .lt. 2.0*xdia(mgs,lh,3) ) THEN - tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) -! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) - qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) - IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN - hdia1 = Max(dh0, xdia(mgs,lh,3) ) - qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, & - & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & - & *exp(-hdia1/xdia(mgs,lh,1)) & - & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) & - & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) ) - -!c qtmp = Min( qxmxd(mgs,lh), qtmp ) -!c tmp = tmp + Min( 0.5e-3/dtp, qtmp ) - ENDIF -! write(0,*) 'dh0 = ',dh0,tmp,qx(mgs,lh)*1000. -! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) -! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) - qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) - - IF ( ipconc .ge. 5 ) THEN -! dh0 = Max( xdia(mgs,lh,3), Min( dh0, 5.e-3 ) ) ! don't create hail greater than 5mm diam. unless the graupel is larger - dh0 = Min( dh0, 10.e-3 ) ! don't create hail greater than 10mm diam., which is the max graupel size -! IF ( qx(mgs,lhl) > 0.1e-3 ) dh0 = xdia(mgs,lhl,3) ! when enough hail is established, don't dilute the size - chlcnh(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) ) -! chlcnh(mgs) = Min( chlcnh(mgs), (1./8.)*rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) -! chlcnh(mgs) = Min( chlcnh(mgs), (1./2.)*rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) - r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter -! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r ) -! chlcnh(mgs) = Min( chlcnh(mgs), r ) - chlcnh(mgs) = Max( chlcnh(mgs), r ) -! chlcnh(mgs) = r - ENDIF - - vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) - vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) -! write(0,*) 'qhlcnh = ',qhlcnh(mgs)*1000.,chlcnh(mgs) - ENDIF -! write(0,*) 'graupel to hail conversion not complete! STOP!' -! STOP - ENDIF - ENDIF +! ssmax = 0.0 - ENDDO - ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion - -! -! Staka and Mansell (2005) type conversion -- assuming alphah = 0 for now! -! -! hldia1 is set in micro_module and namelist - do mgs = 1,ngscnt -! qhlcnh(mgs) = 0.0 -! chlcnh(mgs) = 0.0 - if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then - if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then - qhlcnh(mgs) = & - ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & - *exp(-hldia1/xdia(mgs,lh,1)) & - *( (hldia1**3) + 3.0*(hldia1**2)*xdia(mgs,lh,1) & - + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) - qhlcnh(mgs) = min(qhlcnh(mgs),qhmxd(mgs)) - IF ( ipconc .ge. 5 ) THEN - chlcnh(mgs) = Min( cxmxd(mgs,lh), cx(mgs,lh)*Exp(-hldia1/xdia(mgs,lh,1))) -! chlcnh(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(2.0*xmas(mgs,lh) )) - ENDIF - vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) - vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) + IF ( lcina .gt. 1 ) THEN + cina(mgs) = an(igs(mgs),jy,kgs(mgs),lcina) + ELSE + cina(mgs) = cx(mgs,li) + ENDIF + IF ( lcin > 1 ) THEN + ccin(mgs) = an(igs(mgs),jy,kgs(mgs),lcin) + ENDIF + end do end if + if ( ipconc .ge. 2 ) then + do mgs = 1,ngscnt + cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) +! cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) + IF ( lss > 1 ) THEN + ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss) + ENDIF + IF ( lccn .gt. 1 ) THEN + ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn) + ELSE + ccnc(mgs) = 0.0 + ENDIF + IF ( lccna .gt. 1 ) THEN + ccna(mgs) = an(igs(mgs),jy,kgs(mgs),lccna) + ELSE + ccna(mgs) = cx(mgs,lc) + ENDIF + end do +! ELSE +! cx(mgs,lc) = Abs(ccn) end if - end do - - ENDIF - - ENDIF ! lhl > 1 - - -! -! Ziegler snow conversion to graupel -! - DO mgs = 1,ngscnt + if ( ipconc .ge. 3 ) then + do mgs = 1,ngscnt + cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) + IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN +! cx(mgs,lr) = 0.0 + ELSEIF ( cx(mgs,lr) .eq. 0.0 .and. qx(mgs,lr) .lt. 3.0*qxmin(lr) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lr) + qx(mgs,lr) = 0.0 + ELSE + cx(mgs,lr) = Max( 1.e-9, cx(mgs,lr) ) + ENDIF + end do + end if + if ( ipconc .ge. 4 ) then + do mgs = 1,ngscnt + cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) + IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN +! cx(mgs,ls) = 0.0 + ELSEIF ( cx(mgs,ls) .eq. 0.0 .and. qx(mgs,ls) .lt. 3.0*qxmin(ls) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,ls) + qx(mgs,ls) = 0.0 + ELSE + cx(mgs,ls) = Max( 1.e-9, cx(mgs,ls) ) - qhcns(mgs) = 0.0 - chcns(mgs) = 0.0 - chcnsh(mgs) = 0.0 - vhcns(mgs) = 0.0 + IF ( ilimit .ge. ipc(ls) ) THEN + tmp = (xdn0(ls)*cx(mgs,ls))/(rho0(mgs)*qx(mgs,ls)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,ls)*(tmp2) + IF ( cnox .gt. 3.0*cno(ls) ) THEN + cx(mgs,ls) = 3.0*cno(ls)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if + if ( ipconc .ge. 5 ) then + do mgs = 1,ngscnt - IF ( ipconc .ge. 5 ) THEN + cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) + IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN +! cx(mgs,lh) = 0.0 + ELSEIF ( cx(mgs,lh) .eq. 0.0 .and. qx(mgs,lh) .lt. 3.0*qxmin(lh) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lh) + qx(mgs,lh) = 0.0 + ELSE + cx(mgs,lh) = Max( 1.e-9, cx(mgs,lh) ) + IF ( ilimit .ge. ipc(lh) ) THEN + tmp = (xdn0(lh)*cx(mgs,lh))/(rho0(mgs)*qx(mgs,lh)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lh)*(tmp2) + IF ( cnox .gt. 3.0*cno(lh) ) THEN + cx(mgs,lh) = 3.0*cno(lh)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if - IF ( qx(mgs,ls) .gt. qxmin(ls) .and. qsacw(mgs) .gt. 0.0 ) THEN + if ( lhl .gt. 1 .and. ipconc .ge. 5 ) then + do mgs = 1,ngscnt -! DATA VGRA/1.413E-2/ ! this is the volume (cm**3) of a 3mm diam. sphere -! vgra = 1.4137e-8 m**3 + cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) + IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN + cx(mgs,lhl) = 0.0 + ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN + qx(mgs,lv) = qx(mgs,lv) + qx(mgs,lhl) + qx(mgs,lhl) = 0.0 + ELSE + cx(mgs,lhl) = Max( 1.e-9, cx(mgs,lhl) ) + IF ( ilimit .ge. ipc(lhl) ) THEN + tmp = (xdn0(lhl)*cx(mgs,lhl))/(rho0(mgs)*qx(mgs,lhl)) + tmp2 = (tmp*(3.14159))**(1./3.) + cnox = cx(mgs,lhl)*(tmp2) + IF ( cnox .gt. 3.0*cno(lhl) ) THEN + cx(mgs,lhl) = 3.0*cno(lhl)/tmp2 + ENDIF + ENDIF + ENDIF + end do + end if -! DNNET=DNCNV-DNAGG -! DQNET=QXCON+QSACC+SDEP -! -! DNSCNV=EXP(-(ROS*XNS*VGRA/(RO*QI)))*((1.-(XNS*VGRA*ROS/ -! / (RO*QI)))*DNNET + (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET) -! IF(DNSCNV.LT.0.) DNSCNV=0. ! -! QIHC=(ROS*VGRA/RO)*DNSCNV +! Set mean particle volume ! -! QH=QH+DT*QIHC -! QI=QI-DT*QIHC -! XNH=XNH+DT*DNSCNV -! XNS=XNS-DT*DNSCNV + IF ( ldovol ) THEN + + vx(:,:) = 0.0 + + DO il = li,lhab + + IF ( lvol(il) .ge. 1 ) THEN + + DO mgs = 1,ngscnt + vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) + ENDDO - IF ( iglcnvs .eq. 1 ) THEN ! Zrnic, Ziegler et al (1993) + ENDIF - dnnet = cscnvis(mgs) + cscnis(mgs) - csacs(mgs) - dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs) + ENDDO - a3 = 1./(rho0(mgs)*qx(mgs,ls)) - a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) ! EXP(-(ROS*XNS*VGRA/(RO*QI))) -! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET - a2 = (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet -! (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET - a4 = cx(mgs,ls)**2*vgra*xdn(mgs,ls)*a3/qx(mgs,ls)*dqnet + ENDIF - chcns(mgs) = Max( 0.0, a1*(a2 + a4) ) - chcns(mgs) = Min( chcns(mgs), cxmxd(mgs,ls) ) - chcnsh(mgs) = chcns(mgs) - qhcns(mgs) = Min( xdn(mgs,ls)*vgra*rhoinv(mgs)*chcns(mgs), qxmxd(mgs,ls) ) - vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),xdnmn(lh)) -! vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) - ELSEIF ( iglcnvs .ge. 2 ) THEN ! treat like ice crystals, i.e., check for rime density (ERM) - IF ( temg(mgs) .lt. 273.0 .and. qsacw(mgs) - qsdpv(mgs) .gt. 0.0 ) THEN +! +! set factors +! + do mgs = 1,ngscnt +! + ssi(mgs) = qx(mgs,lv)/qis(mgs) + ssw(mgs) = qx(mgs,lv)/qvs(mgs) +! + tsqr(mgs) = temg(mgs)**2 +! + temgx(mgs) = min(temg(mgs),313.15) + temgx(mgs) = max(temgx(mgs),233.15) + felv(mgs) = 2500837.367 * (273.15/temgx(mgs))**((0.167)+(3.67e-4)*temgx(mgs)) +! + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),223.15) + temcgx(mgs) = temcgx(mgs)-273.15 - tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & - & *((0.60)*vtxbar(mgs,ls,1)) & - & /(temg(mgs)-273.15))**(rimc2) - tmp = Min( Max( rimc3, tmp ), 900.0 ) - - ! Assume that half the volume of the embryo is rime with density 'tmp' - ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 - ! V = 2*m/(rhoi + rhorime) - -! write(0,*) 'rime dens = ',tmp - - IF ( tmp .ge. 200.0 .or. iglcnvs >= 3 ) THEN - r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) -! r = Max( r, 400. ) - qhcns(mgs) = (qsacw(mgs) - qsdpv(mgs)) - chcns(mgs) = cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls) -! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) - chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) -! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) - vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r - ENDIF - - ENDIF - - ENDIF - - - ENDIF - - ELSE ! single moment lfo - - qhcns(mgs) = 0.001*ehscnv(mgs)*max((qx(mgs,ls)-6.e-4),0.0) - qhcns(mgs) = min(qhcns(mgs),qxmxd(mgs,ls)) - IF ( lvol(lh) .ge. 1 ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) - - ENDIF - ENDDO -! -! -! heat budget for rain---not all rain that collects ice can freeze -! -! +! felf = latent heat of fusion, fels = LH of sublimation, felv = LH of vaporization + felf(mgs) = 333690.6098 + (2030.61425)*temcgx(mgs) - (10.46708312)*temcgx(mgs)**2 ! - if ( irwfrz .gt. 0 .and. .not. mixedphase) then + fels(mgs) = felv(mgs) + felf(mgs) ! - do mgs = 1,ngscnt + felvs(mgs) = felv(mgs)*felv(mgs) + felss(mgs) = fels(mgs)*fels(mgs) + + IF ( eqtset <= 1 ) THEN + felvcp(mgs) = felv(mgs)*cpi + felscp(mgs) = fels(mgs)*cpi + felfcp(mgs) = felf(mgs)*cpi + ELSE + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) + IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) + cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm + felfcp(mgs) = felf(mgs)/cvm + ENDIF ! -! compute total rain that freeze when it interacts with cloud ice + fgamw(mgs) = felvcp(mgs)/pi0(mgs) + fgams(mgs) = felscp(mgs)/pi0(mgs) ! - qrztot(mgs) = qrfrz(mgs) + qiacr(mgs) + qsacr(mgs) + fcqv1(mgs) = 4098.0258*pi0(mgs)*fgamw(mgs) + fcqv2(mgs) = 5807.6953*pi0(mgs)*fgams(mgs) + fcc3(mgs) = felfcp(mgs)/pi0(mgs) ! -! compute the maximum amount of rain that can freeze -! Used to limit freezing to 4*qrmxd, but now allow all rain to freeze if possible +! fwvdf = water vapor diffusivity + fwvdf(mgs) = (2.11e-05)*((temg(mgs)/tfr)**1.94)*(101325.0/(pres(mgs))) ! - qrzmax(mgs) = & - & ( xdia(mgs,lr,1)*rwvent(mgs)*cx(mgs,lr)*fwet1(mgs) ) - qrzmax(mgs) = max(qrzmax(mgs), 0.0) - qrzmax(mgs) = min(qrztot(mgs), qrzmax(mgs)) - qrzmax(mgs) = min(qx(mgs,lr)/dtp, qrzmax(mgs)) - - IF ( temcg(mgs) < -30. ) THEN ! allow all to freeze if T < -30 because fwet becomes invalid (negative) - qrzmax(mgs) = qx(mgs,lr)/dtp - ENDIF -! qrzmax(mgs) = min(4.*qrmxd(mgs), qrzmax(mgs)) +! fadvisc = kinematic viscosity + fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))*(temg(mgs)/296.0)**(1.5) ! dynamic visc. ! -! compute the correction factor + fakvisc(mgs) = fadvisc(mgs)*rhoinv(mgs) ! divide by rho_air to get kinematic visc. (note the 'k' vs. 'd') ! -! IF ( qrztot(mgs) .gt. qxmin(lr) ) THEN - IF ( qrztot(mgs) .gt. qrzmax(mgs) .and. qrztot(mgs) .gt. qxmin(lr) ) THEN - qrzfac(mgs) = qrzmax(mgs)/(qrztot(mgs)) - ELSE - qrzfac(mgs) = 1.0 - ENDIF - qrzfac(mgs) = min(1.0, qrzfac(mgs)) + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fci(mgs) = (2.118636 + 0.007371*(temcgx(mgs)))*(1.0e+03) ! - end do + if ( temg(mgs) .lt. 273.15 ) then + temcgx(mgs) = min(temg(mgs),273.15) + temcgx(mgs) = max(temcgx(mgs),233.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4203.1548 + (1.30572e-2)*((temcgx(mgs)-35.)**2) & + & + (1.60056e-5)*((temcgx(mgs)-35.)**4) + end if + if ( temg(mgs) .ge. 273.15 ) then + temcgx(mgs) = min(temg(mgs),308.15) + temcgx(mgs) = max(temcgx(mgs),273.15) + temcgx(mgs) = temcgx(mgs)-273.15 + fcw(mgs) = 4243.1688 + (3.47104e-1)*(temcgx(mgs)**2) + end if ! + ftka(mgs) = tka0*fadvisc(mgs)/advisc1 ! thermal conductivity: proportional to dynamic viscosity + fthdf(mgs) = ftka(mgs)*cpi*rhoinv(mgs) ! -! now correct the above sources + fschm(mgs) = (fakvisc(mgs)/fwvdf(mgs)) ! Schmidt number + fpndl(mgs) = (fakvisc(mgs)/fthdf(mgs)) ! Prandl number (not used) ! + fai(mgs) = (fels(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbi(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qis(mgs))) + fav(mgs) = (felv(mgs)**2)/(ftka(mgs)*rw*temg(mgs)**2) + fbv(mgs) = (1.0/(rho0(mgs)*fwvdf(mgs)*qvs(mgs))) ! - do mgs = 1,ngscnt - if ( temg(mgs) .le. 273.15 .and. qrzfac(mgs) .lt. 1.0 ) then - qrfrz(mgs) = qrzfac(mgs)*qrfrz(mgs) - qrfrzs(mgs) = qrzfac(mgs)*qrfrzs(mgs) - qrfrzf(mgs) = qrzfac(mgs)*qrfrzf(mgs) - qiacr(mgs) = qrzfac(mgs)*qiacr(mgs) - qsacr(mgs) = qrzfac(mgs)*qsacr(mgs) - qiacrf(mgs) = qrzfac(mgs)*qiacrf(mgs) - crfrz(mgs) = qrzfac(mgs)*crfrz(mgs) - crfrzf(mgs) = qrzfac(mgs)*crfrzf(mgs) - crfrzs(mgs) = qrzfac(mgs)*crfrzs(mgs) - ciacr(mgs) = qrzfac(mgs)*ciacr(mgs) - ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) - - - vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) - viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) - end if end do ! ! -! - end if -! +! ice habit fractions ! ! -! evaporation of rain ! +! Set density ! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set density' ! - qrcev(:) = 0.0 - crcev(:) = 0.0 - do mgs = 1,ngscnt -! - IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + xdn(mgs,li) = xdn0(li) + xdn(mgs,lc) = xdn0(lc) + xdn(mgs,lr) = xdn0(lr) + xdn(mgs,ls) = xdn0(ls) + xdn(mgs,lh) = xdn0(lh) + IF ( lvol(ls) .gt. 1 ) THEN + IF ( vx(mgs,ls) .gt. 0.0 .and. qx(mgs,ls) .gt. qxmin(ls) ) THEN + xdn(mgs,ls) = Min( xdnmx(ls), Max( xdnmn(ls), rho0(mgs)*qx(mgs,ls)/vx(mgs,ls) ) ) + ENDIF + ENDIF - qrcev(mgs) = & - & fvce(mgs)*cx(mgs,lr)*rwvent(mgs)*rwcap(mgs) -! this line to allow condensation on rain: - IF ( rcond .eq. 1 ) THEN - qrcev(mgs) = min(qrcev(mgs), qxmxd(mgs,lv)) -! this line to have evaporation only: - ELSE - qrcev(mgs) = min(qrcev(mgs), 0.0) - ENDIF + IF ( lvol(lh) .gt. 1 ) THEN + IF ( vx(mgs,lh) .gt. 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( mixedphase ) THEN + ELSE + dnmx = xdnmx(lh) + ENDIF + xdn(mgs,lh) = Min( dnmx, Max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) ) + vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh) + ENDIF + ENDIF - qrcev(mgs) = max(qrcev(mgs), -qrmxd(mgs)) -! if ( temg(mgs) .lt. 273.15 ) qrcev(mgs) = 0.0 - IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN -! qrcev(mgs) = -qrmxd(mgs) -! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs) - crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) - ELSE - crcev(mgs) = 0.0 - ENDIF -! if ( temg(mgs) .lt. 273.15 ) crcev(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + + xdn(mgs,lhl) = xdn0(lhl) + + IF ( lvol(lhl) .gt. 1 ) THEN + IF ( vx(mgs,lhl) .gt. 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + + IF ( mixedphase .and. lhlw > 1 ) THEN + ELSE + dnmx = xdnmx(lhl) + ENDIF + + xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) ) + vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl) + ENDIF + ENDIF + + ENDIF + +! adjust density for wet snow and graupel (Ferrier 94) +! (aps): for the time being, do not adjust density until we keep track of fully melted snow/graupel ! - ENDIF +! IF (mixedphase) THEN + IF (qsdenmod) THEN + IF(fsw(mgs) .gt. 0.01) THEN + xdn(mgs,ls) = (1.-fsw(mgs))*rho_qs + fsw(mgs)*rho_qr !Ferrier: 100./(1.-fsw(mgs)) + IF(fsw(mgs) .eq. 1.) xdn(mgs,ls) = rho_qr ! fsw = 1 means it's liquid water, yo! + ENDIF + ENDIF + + IF (qhdenmod) THEN +! IF(fhw(mgs) .gt. 0.01) THEN +! IF(fhw(mgs) .lt. 1.) xdn(mgs,lh) = rho_qh / (1. - fhw(mgs)) !Ferrier: 400./(1.-fsw(mgs)) +! IF(fhw(mgs) .eq. 1.) xdn(mgs,lh) = rho_qr ! fhw = 1 means it's liquid water, yo! +! ENDIF + ENDIF +! ENDIF end do -! -! evaporation/condensation of wet graupel and snow -! - qscev(:) = 0.0 - cscev(:) = 0.0 - qhcev(:) = 0.0 - chcev(:) = 0.0 - qhlcev(:) = 0.0 - chlcev(:) = 0.0 + ! +! set some values for ice nucleation ! + do mgs = 1,ngscnt + kp1 = Min(nz, kgs(mgs)+1 ) + wvel(mgs) = (0.5)*(w(igs(mgs),jgs,kp1) & + & +w(igs(mgs),jgs,kgs(mgs))) + + + wvelkm1(mgs) = (0.5)*(w(igs(mgs),jgs,kgs(mgs)) & + & +w(igs(mgs),jgs,kgsm(mgs))) + cninm(mgs) = t7(igs(mgs),jgs,kgsm(mgs)) + cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) + cninp(mgs) = t7(igs(mgs),jgs,kgsp(mgs)) + end do + ! -! ICE MULTIPLICATION: Two modes (rimpa, and rimpb) -! (following Cotton et al. 1986) -! - - chmul1(:) = 0.0 - chlmul1(:) = 0.0 - csmul1(:) = 0.0 +! Set a couple of cloud variables... ! - qhmul1(:) = 0.0 - qhlmul1(:) = 0.0 - qsmul1(:) = 0.0 - do mgs = 1,ngscnt - - ltest = qx(mgs,lh) .gt. qxmin(lh) - IF ( lhl > 1 ) ltest = ltest .or. qx(mgs,lhl) .gt. qxmin(lhl) - - IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 ) & - & .and. qx(mgs,lc) .gt. qxmin(lc)) THEN - if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then - IF ( ipconc .ge. 2 ) THEN - IF ( xv(mgs,lc) .gt. 0.0 & - & .and. ltest & -! .and. itype2 .ge. 2 & - & ) THEN -! -! Ziegler et al. 1986 Hallett-Mossop process. VSTAR = 7.23e-15 (vol of 12micron radius) -! - ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc)) - IF ( itype2 .le. 2 ) THEN - ft = Max(0.0,Min(1.0,-0.11*temcg(mgs)**2 - 1.1*temcg(mgs)-1.7)) - ELSE - IF ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) THEN - ft = 0.5 - ELSEIF (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) THEN - ft = 1.0 - ELSEIF (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) THEN - ft = 0.5 - ELSE - ft = 0.0 - ENDIF - ENDIF -! rhoinv = 1./rho0(mgs) -! DNSTAR = ex1*cglacw(mgs) - - IF ( ft > 0.0 ) THEN - - IF ( itype2 > 0 ) THEN - IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN - chmul1(mgs) = (ft*ex1*chacw(mgs)) - qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs) - ENDIF - IF ( lhl .gt. 1 ) THEN - IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN - chlmul1(mgs) = (ft*ex1*chlacw(mgs)) - qhlmul1(mgs) = cimas0*chlmul1(mgs)*rhoinv(mgs) - ENDIF - ENDIF - ENDIF ! itype2 +! SUBROUTINE setvt(ngscnt,qx,qxmin,cx,rho0,rhovt,xdia,cno, +! : xmas,xdn,xvmn,xvmx,xv,cdx, +! : ipconc,ndebug) +! SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno, & +! & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & +! & ipconc1,ndebug1,ngs,nz,kgs,cwnccn,fadvisc, & +! & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & +! & itype1a,itype2a,temcg,infdo,alpha) - IF ( itype1 > 0 ) THEN - IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN - tmp = ft*(3.5e+08)*rho0(mgs)*qhacw(mgs) - chmul1(mgs) = chmul1(mgs) + tmp - qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs) - ENDIF - IF ( lhl .gt. 1 ) THEN - IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN - tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs) - chlmul1(mgs) = chlmul1(mgs) + tmp - qhlmul1(mgs) = qhlmul1(mgs) + cimas0*tmp*rhoinv(mgs) + + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & + & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & + & ipconc,ndebug,ngs,nz,kgs,fadvisc, & + & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & + & itype1,itype2,temcg,0,alpha,0,axh,bxh,axhl,bxhl) + + + IF ( lwsm6 .and. ipconc == 0 ) THEN + tmp = Max(qxmin(lh), qxmin(ls)) + DO mgs = 1,ngscnt + sum = qx(mgs,lh) + qx(mgs,ls) + IF ( sum > tmp ) THEN + vt2ave(mgs) = (qx(mgs,lh)*vtxbar(mgs,lh,1) + qx(mgs,ls)*vtxbar(mgs,ls,1))/sum + ELSE + vt2ave(mgs) = 0.0 ENDIF - ENDIF - ENDIF ! itype1 - - ENDIF ! ft + ENDDO + ENDIF - ENDIF ! xv(mgs,lc) .gt. 0.0 .and. - ELSE ! ipconc .lt. 2 -! -! define the temperature function -! - fimt1(mgs) = 0.0 -! -! Cotton et al. (1986) version -! - if ( temg(mgs) .ge. 268.15 .and. temg(mgs) .le. 270.15 ) then - fimt1(mgs) = 1.0 -(temg(mgs)-268.15)/2.0 - elseif (temg(mgs) .le. 268.15 .and. temg(mgs) .ge. 265.15 ) then - fimt1(mgs) = 1.0 +(temg(mgs)-268.15)/3.0 - ELSE - fimt1(mgs) = 0.0 - end if -! -! Ferrier (1994) version -! - if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) then - fimt1(mgs) = 0.5 - elseif (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) then - fimt1(mgs) = 1.0 - elseif (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) then - fimt1(mgs) = 0.5 - ELSE - fimt1(mgs) = 0.0 - end if ! +! Set number concentrations (need xdia from setvt) ! -! type I: 350 splinters are formed for every 1e-3 grams of cloud -! water accreted by graupel/hail (note converted to MKS units) -! 3.5e+8 has units of 1/kg -! - IF ( itype1 .ge. 1 ) THEN - fimta(mgs) = (3.5e+08)*rho0(mgs) - ELSE - fimta(mgs) = 0.0 + if ( ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set concentration' + IF ( ipconc .lt. 1 ) THEN + cina(1:ngscnt) = cx(1:ngscnt,li) ENDIF + if ( ipconc .lt. 5 ) then + do mgs = 1,ngscnt -! -! -! type II: 1 splinter formed for every 250 cloud droplets larger than -! 24 micons in diameter (12 microns in radius) accreted by -! graupel/hail -! -! - fimt2(mgs) = 0.0 - xcwmas = xmas(mgs,lc) * 1000. -! - IF ( itype2 .ge. 1 ) THEN - if ( xcwmas.lt.1.26e-9 ) then - fimt2(mgs) = 0.0 - end if - if ( xcwmas .le. 3.55e-9 .and. xcwmas .ge. 1.26e-9 ) then - fimt2(mgs) = (2.27)*alog(xcwmas) + 13.39 + + IF ( ipconc .lt. 3 ) THEN +! cx(mgs,lr) = 0.0 + if ( qx(mgs,lr) .gt. qxmin(lh) ) then +! cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) +! xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) end if - if ( xcwmas .gt. 3.55e-9 ) then - fimt2(mgs) = 1.0 + ENDIF + + IF ( ipconc .lt. 4 ) THEN +! tmp = cx(mgs,ls) +! cx(mgs,ls) = 0.0 + if ( qx(mgs,ls) .gt. qxmin(ls) ) then +! cx(mgs,ls) = cno(ls)*xdia(mgs,ls,1) +! xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) end if + ENDIF ! ( ipconc .lt. 4 ) - fimt2(mgs) = min(fimt2(mgs),1.0) - fimt2(mgs) = max(fimt2(mgs),0.0) - - ENDIF -! -! qhmul2 = 0.0 -! qsmul2 = 0.0 -! -! qhmul2 = -! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qhacw(mgs) -! qsmul2 = -! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qsacw(mgs) -! -! cimas0 = (1.0e-12) -! cimas0 = 2.5e-10 - IF ( .not. wetsfc(mgs) ) THEN - chmul1(mgs) = fimt1(mgs)*(fimta(mgs) + & - & (4.0e-03)*fimt2(mgs))*qhacw(mgs) - ENDIF -! - qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) + IF ( ipconc .lt. 5 ) THEN - IF ( lhl .gt. 1 ) THEN - IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN - tmp = fimt1(mgs)*(fimta(mgs) + & - & (4.0e-03)*fimt2(mgs))*qhlacw(mgs) - chlmul1(mgs) = tmp - qhlmul1(mgs) = cimas0*tmp*rhoinv(mgs) - ENDIF - ENDIF +! cx(mgs,lh) = 0.0 + if ( qx(mgs,lh) .gt. qxmin(lh) ) then +! cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) +! xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) +! xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) + end if -! qsmul1(mgs) = csmul1(mgs)*(cimas0/rho0(mgs)) -! - ENDIF ! ( ipconc .ge. 2 ) + ENDIF ! ( ipconc .lt. 5 ) + + end do + end if - end if ! (in temperature range) + IF ( ipconc .ge. 2 ) THEN + DO mgs = 1,ngscnt + rb(mgs) = 0.5*xdia(mgs,lc,1)*((1./(1.+cnu)))**(1./6.) + xl2p(mgs) = Max(0.0d0, 2.7e-2*xdn(mgs,lc)*cx(mgs,lc)*xv(mgs,lc)* & + & ((0.5e20*rb(mgs)**3*xdia(mgs,lc,1))-0.4) ) + IF ( rb(mgs) .gt. 3.51e-6 ) THEN +! rh(mgs) = Max( 0.5d0*xdia(mgs,lc,1), 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + rh(mgs) = Max( 41.d-6, 6.3d-4/(1.d6*(rb(mgs) - 3.5d-6)) ) + ELSE + rh(mgs) = 41.d-6 + ENDIF + IF ( xl2p(mgs) .gt. 0.0 ) THEN + nh(mgs) = 4.2d9*xl2p(mgs) + ELSE + nh(mgs) = 1.e30 + ENDIF + ENDDO + ENDIF - ENDIF ! ( itype1 .eq. 1 .or. itype2 .eq. 1) -! - end do -! -! ! -! end if ! -! end do +! ! +! maximum depletion tendency by any one source ! -! ICE MULTIPLICATION FROM SNOW -! Lo and Passarelli 82 / Willis and Heymsfield 89 / Schuur and Rutledge 00b -! using kfrag as fragmentation rate (s-1) / 500 microns as char mean diam for max snow mix ratio ! - csmul(:) = 0.0 - qsmul(:) = 0.0 - - IF ( isnwfrac /= 0 ) THEN + if( ndebug .ge. 0 ) THEN +!mpi! write(iunit,*) 'Set depletion max/min1' +! flush(iunit) + endif do mgs = 1,ngscnt - IF (temg(mgs) .gt. 265.0) THEN !{ - if (xdia(mgs,ls,1) .gt. 100.e-6 .and. xdia(mgs,ls,1) .lt. 2.0e-3) then ! equiv diameter 100microns to 2mm - - tmp = rhoinv(mgs)*pi*xdn(mgs,ls)*cx(mgs,ls)*(500.e-6)**3 - qsmul(mgs) = Max( kfrag*( qx(mgs,ls) - tmp ) , 0.0 ) - - qsmul(mgs) = Min( qxmxd(mgs,li), qsmul(mgs) ) - csmul(mgs) = Min( cxmxd(mgs,li), rho0(mgs)*qsmul(mgs)/mfrag ) + qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))/dtp ! depletion by all vap. dep to ice. + qvimxd(mgs) = max(qvimxd(mgs), 0.0) +! qimxd(mgs) = 0.20*qx(mgs,li)/dtp +! qcmxd(mgs) = 0.20*qx(mgs,lc)/dtp +! qrmxd(mgs) = 0.20*qx(mgs,lr)/dtp +! qsmxd(mgs) = 0.20*qx(mgs,ls)/dtp +! qhmxd(mgs) = 0.20*qx(mgs,lh)/dtp - endif - ENDIF !} - enddo - ENDIF + frac = 0.1d0 + qimxd(mgs) = frac*qx(mgs,li)/dtp + qcmxd(mgs) = frac*qx(mgs,lc)/dtp + qrmxd(mgs) = frac*qx(mgs,lr)/dtp + qsmxd(mgs) = frac*qx(mgs,ls)/dtp + qhmxd(mgs) = frac*qx(mgs,lh)/dtp + IF ( lhl > 1 ) qhlmxd(mgs) = frac*qx(mgs,lhl)/dtp + end do +! + if( ndebug .ge. 0 ) THEN +!mpi! write(iunit,*) 'Set depletion max/min2' +! flush(iunit) + endif + do mgs = 1,ngscnt ! -! frozen rain-rain interaction.... + if ( qx(mgs,lc) .le. qxmin(lc) ) then + ccmxd(mgs) = 0.20*cx(mgs,lc)/dtp + else + IF ( ipconc .ge. 2 ) THEN + ccmxd(mgs) = frac*cx(mgs,lc)/dtp + ELSE + ccmxd(mgs) = frac*qx(mgs,lc)/(xmas(mgs,lc)*rho0(mgs)*dtp) + ENDIF + end if +! + if ( qx(mgs,li) .le. qxmin(li) ) then + cimxd(mgs) = frac*cx(mgs,li)/dtp + else + IF ( ipconc .ge. 1 ) THEN + cimxd(mgs) = frac*cx(mgs,li)/dtp + ELSE + cimxd(mgs) = frac*qx(mgs,li)/(xmas(mgs,li)*rho0(mgs)*dtp) + ENDIF + end if +! +! + crmxd(mgs) = 0.10*cx(mgs,lr)/dtp + csmxd(mgs) = frac*cx(mgs,ls)/dtp + chmxd(mgs) = frac*cx(mgs,lh)/dtp + + ccmxd(mgs) = frac*cx(mgs,lc)/dtp + cimxd(mgs) = frac*cx(mgs,li)/dtp + crmxd(mgs) = frac*cx(mgs,lr)/dtp + csmxd(mgs) = frac*cx(mgs,ls)/dtp + chmxd(mgs) = frac*cx(mgs,lh)/dtp + + qxmxd(mgs,lv) = Max(0.0, 0.1*(qx(mgs,lv) - qvs(mgs))/dtp) + + DO il = lc,lhab + qxmxd(mgs,il) = frac*qx(mgs,il)/dtp + cxmxd(mgs,il) = frac*cx(mgs,il)/dtp + ENDDO + + end do + + + + +! calculate maximum mass diameters + ! ! +! microphysics source terms (1/s) for mixing ratios ! ! -! rain-ice interaction ! +! Collection efficiencies: +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: Set collection efficiencies' ! do mgs = 1,ngscnt - qracif(mgs) = qraci(mgs) - cracif(mgs) = craci(mgs) -! ciacrf(mgs) = ciacr(mgs) - end do ! -! -! vapor to pristine ice crystals UP ! ! + erw(mgs) = 0.0 + esw(mgs) = 0.0 + ehw(mgs) = 0.0 + ehlw(mgs) = 0.0 +! ehxw(mgs) = 0.0 ! -! compute the nucleation rate + err(mgs) = 0.0 + esr(mgs) = 0.0 + il2(mgs) = 0 + il3(mgs) = 0 + ehr(mgs) = 0.0 + ehlr(mgs) = 0.0 +! ehxr(mgs) = 0.0 ! -! do mgs = 1,ngscnt -! idqis = 0 -! if ( ssi(mgs) .gt. 1.0 ) idqis = 1 -! fiinit(mgs) = (felv(mgs)**2)/(cp*rw) -! dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ -! > (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) -! qidsvp(mgs) = dqisdt(mgs) -! cnnt = min(cnit*exp(-temcg(mgs)*bta1),1.0e+09) -! qiint(mgs) = -! > il5(mgs)*idqis*(1.0/dtp) -! < *min((6.88e-13)*cnnt/rho0(mgs), 0.25*dqisdt(mgs)) -! end do + eri(mgs) = 0.0 + esi(mgs) = 0.0 + ehi(mgs) = 0.0 + ehli(mgs) = 0.0 +! ehxi(mgs) = 0.0 ! -! Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation + ers(mgs) = 0.0 + ess(mgs) = 0.0 + ehs(mgs) = 0.0 + ehls(mgs) = 0.0 + ehscnv(mgs) = 0.0 +! ehxs(mgs) = 0.0 ! - cmassin = cimasn ! 6.88e-13 - do mgs = 1,ngscnt - qiint(mgs) = 0.0 - ciint(mgs) = 0.0 - qicicnt(mgs) = 0.0 - cicint(mgs) = 0.0 - qipipnt(mgs) = 0.0 - cipint(mgs) = 0.0 - IF ( icenucopt == 1 ) THEN - if ( ( temg(mgs) .lt. 268.15 .or. & -! : ( imeyers5 .and. temg(mgs) .lt. 273.0) ) .and. & - & ( imeyers5 .and. temg(mgs) .lt. 272.0 .and. temgkm2(mgs) .lt. tfr) ) .and. & - & ciintmx .gt. (cx(mgs,li)) & -! : .and. cninm(mgs) .gt. 0. & - & ) then - IF ( ipconc >= 4 .or. .not. lwsm6 ) THEN - - fiinit(mgs) = (felv(mgs)**2)/(cp*rw) - dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ & - & (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) -! qidsvp(mgs) = dqisdt(mgs) - idqis = 0 - if ( ssi(mgs) .gt. 1.0 ) THEN - idqis = 1 - dzfacp = max( float(kgsp(mgs)-kgs(mgs)), 0.0 ) - dzfacm = max( float(kgs(mgs)-kgsm(mgs)), 0.0 ) - qiint(mgs) = & - & idqis*il5(mgs) & - & *(cmassin/rho0(mgs)) & - & *max(0.0,wvel(mgs)) & - & *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs)) & - & /((dzfacp+dzfacm)) + eiw(mgs) = 0.0 + eii(mgs) = 0.0 - qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) - ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin - - ELSE ! lwsm6 = true + ehsclsn(mgs) = 0.0 + ehiclsn(mgs) = 0.0 + ehlsclsn(mgs) = 0.0 + ehliclsn(mgs) = 0.0 + esiclsn(mgs) = 0.0 - IF ( ssi(mgs) .gt. 1.0 ) THEN - xni0 = 1.e3*exp(0.1*temcg(mgs)) - roqi0 = 4.92e-11*xni0**1.33 -! qiint(mgs) = Max(0.,(roqi0*rhoinv(mgs) - Max(qx(mgs,li),0.))*dtpinv) - qiint(mgs) = Max(0.0d0,dble(roqi0*rhoinv(mgs) - Max(qx(mgs,li),0.))*dtpinv) -! ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin - ENDIF - ENDIF + icwr(mgs) = 1 + IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + DO il = 1,8 + IF ( cwrad .ge. 1.e-6*cwr(il,1) ) icwr(mgs) = il + ENDDO ENDIF -! -! limit new crystals so it does not increase the current concentration -! above ciintmx 20,000 per liter (2.e7 per m**3) -! -! ciintmx = 1.e9 - IF ( ciint(mgs) .gt. (ciintmx - (cx(mgs,li)))) THEN - ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) ) - qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) - ENDIF -! - end if - ELSEIF ( icenucopt == 2 ) THEN -! IF ( temg(mgs) .lt. 268.15 ) write(0,*) 'Cooper: i,k,ssi = ',igs(mgs),kgs(mgs),ssi(mgs) - - IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 0.999 ) .or. ssi(mgs) > 1.05 ) THEN - ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) ) - qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) - fiinit(mgs) = (felv(mgs)**2)/(cp*rw) - dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/(1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) - qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) - ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + irwr(mgs) = 1 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) irwr(mgs) = il + ENDDO + ENDIF -! IF ( qiint(mgs) > 0.0 ) write(0,*) 'Cooper: i,k,qiint = ',igs(mgs),kgs(mgs),qiint(mgs),ssi(mgs),cnina(mgs),cina(mgs) - ENDIF - - - - ELSEIF ( icenucopt == 3 ) THEN - IF ( temg(mgs) .lt. 268.15 ) THEN - ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) ) - qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) - ENDIF + igwr(mgs) = 1 +! IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN +! rwrad = 0.5*xdia(mgs,lr,1) +! setting erw = 1 always, so now use igwr for graupel + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) igwr(mgs) = il + ENDDO + ENDIF + + IF ( lhl .gt. 1 ) THEN ! hail is turned on + ihlr(mgs) = 1 + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter (10/6/06) + DO il = 1,6 + IF ( rwrad .ge. 1.e-6*grad(il,1) ) ihlr(mgs) = il + ENDDO + ENDIF ENDIF - if ( xplate(mgs) .eq. 1 ) then - qipipnt(mgs) = qiint(mgs) - cipint(mgs) = ciint(mgs) - end if -! - if ( xcolmn(mgs) .eq. 1 ) then - qicicnt(mgs) = qiint(mgs) - cicint(mgs) = ciint(mgs) - end if ! -! qipipnt(mgs) = 0.0 -! qicicnt(mgs) = qiint(mgs) ! - end do +! Ice-Ice: Collection (cxc) efficiencies ! -! - ! -! vapor to cloud droplets UP + if ( qx(mgs,li) .gt. qxmin(li) ) then +! IF ( ipconc .ge. 14 ) THEN +! eii(mgs)=0.1*exp(0.1*temcg(mgs)) +! if ( temg(mgs) .lt. 243.15 .and. qx(mgs,lc) .gt. 1.e-6 ) then +! eii(mgs)=0.1 +! end if +! +! ELSE + eii(mgs) = exp(0.025*Min(temcg(mgs),0.0)) ! alpha1 from LFO83 (21) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) eii(mgs) = 1.0 + end if ! - if (ndebug .gt. 0 ) write(0,*) 'dbg = 8' ! ! - if (ndebug .gt. 0 ) write(0,*) 'Collection: set 3-component' +! Ice-cloud water: Collection (cxc) efficiencies ! -! time for riming.... ! -! rimtim = 240.0 -! dtrim = rimtim -! xacrtim = 120.0 -! tranfr = 0.50 -! tranfw = 0.50 + eiw(mgs) = 0.0 + if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then + if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then +! erm 5/10/2007 test following change: +! if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then + eiw(mgs) = 0.5 + end if + if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 + end if ! -! coefficients for riming ! -! rimc1 = 300.00 -! rimc2 = 0.44 ! -! -! zero som arrays +! Rain: Collection (cxc) efficiencies ! ! - do mgs = 1,ngscnt - qrshr(mgs) = 0.0 - qsshrp(mgs) = 0.0 - qhshrp(mgs) = 0.0 - end do + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lc).gt.qxmin(lc) ) then + + IF ( lnr .gt. 1 ) THEN + erw(mgs) = 1.0 + + ELSE + +! cwrad = 0.5*xdia(mgs,lc,1) +! erw(mgs) = +! > min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! IF ( xdia(mgs,lc,1) .lt. 2.4e-06 .or. xdia(mgs,lr,1) .le. 50.0e-6 ) THEN +! erw(mgs)=0.0 +! ENDIF +! erw(mgs) = ew(icwr(mgs),igwr(mgs)) +! interpolate along droplet radius + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = irwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,3) + rwrad = 0.5*xdia(mgs,lr,3) + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + erw(mgs) = Max(0.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) )) + +! write(iunit,*) 'erw: ',erw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + + erw(mgs) = Max(0.0, erw(mgs) ) + IF ( rwrad .lt. 50.e-6 ) THEN + erw(mgs) = 0.0 + ELSEIF ( rwrad .lt. 100.e-6 ) THEN ! linear change from zero at 50 to erw at 100 microns + erw(mgs) = erw(mgs)*(rwrad - 50.e-6)/50.e-6 + ENDIF + + ENDIF + end if + IF ( cx(mgs,lc) .le. 0.0 ) erw(mgs) = 0.0 ! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr).gt.qxmin(lr) ) then + err(mgs)=1.0 + end if ! -! first sum all of the shed rain + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,ls).gt.qxmin(ls) ) then + ers(mgs)=1.0 + end if +! + if ( qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,li).gt.qxmin(li) ) then +! IF ( vtxbar(mgs,lr,1) .gt. vtxbar(mgs,li,1) .and. +! : xdia(mgs,lr,3) .gt. 200.e-6 .and. xdia(mgs,li,3) .gt. 100.e-6 ) THEN + eri(mgs) = eri0 +! cwrad = 0.5*xdia(mgs,li,3) +! eri(mgs) = +! > 1.0*min((aradcw + cwrad*(bradcw + cwrad* +! < (cradcw + cwrad*(dradcw)))), 1.0) +! ENDIF +! if ( xdia(mgs,li,1) .lt. 10.e-6 ) eri(mgs)=0.0 + if ( xdia(mgs,li,3) .lt. 40.e-6 ) eri(mgs)=0.0 + end if ! ! - do mgs = 1,ngscnt - qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) - crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) - IF ( ipconc .ge. 3 ) THEN -! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) ) +! Snow aggregates: Collection (cxc) efficiencies +! +! Modified by ERM with a linear function for small droplets and large +! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997, which +! allows collection of very small droplets, albeit at low efficiency. But slow +! fall speeds of snow make up for the efficiency. +! + esw(mgs) = 0.0 + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lc).gt.qxmin(lc) ) then + esw(mgs) = 0.5 + if ( xdia(mgs,lc,1) .gt. 15.e-6 .and. xdia(mgs,ls,1) .gt. 100.e-6) then + esw(mgs) = 0.5 + ELSEIF ( xdia(mgs,ls,1) .ge. 500.e-6 ) THEN + esw(mgs) = Min(0.5, 0.05 + (0.8-0.05)/(40.e-6)*xdia(mgs,lc,1) ) + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,lr).gt.qxmin(lr) & + & .and. temg(mgs) .lt. tfr - 1. & + & ) then + esr(mgs)=Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,ls,1)) + IF ( qx(mgs,ls) < 1.e-4 .and. qx(mgs,lr) < 1.e-4 ) il2(mgs) = 1 + end if + + IF ( ipconc < 3 .and. temg(mgs) < tfr .and. qx(mgs,lr).gt.qxmin(lr) .and. qx(mgs,lr) < 1.e-4 ) THEN + il3(mgs) = 1 ENDIF - end do ! +! if ( qx(mgs,ls).gt.qxmin(ls) ) then + if ( temcg(mgs) < 0.0 ) then + IF ( ipconc .lt. 4 .or. temcg(mgs) < -25. ) THEN + ess(mgs) = 0.0 +! ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) +! ess(mgs)=min(0.1,ess(mgs)) + ELSE + IF ( temcg(mgs) > -25. .and. temcg(mgs) < -20. ) THEN ! only nonzero for T > -25 + ess(mgs) = ess0*Exp(ess1*(-20.) )*(temcg(mgs) + 25.)/5. ! linear ramp up from zero at -25 to value at -20 + ELSEIF ( temcg(mgs) >= -20.0 ) THEN + ess(mgs) = ess0*Exp(ess1*Min( temcg(mgs), 0.0 ) ) + ENDIF + ENDIF + end if +! + if ( qx(mgs,ls).gt.qxmin(ls) .and. qx(mgs,li).gt.qxmin(li) ) then + esiclsn(mgs) = esi_collsn +! IF ( ipconc .lt. 4 ) THEN + IF ( ipconc < 1 .and. lwsm6 ) THEN + esi(mgs) = exp(0.7*min(temcg(mgs),0.0)) + ELSE + esi(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) + esi(mgs)=min(0.1,esi(mgs)) + ENDIF + IF ( ipconc .le. 3 ) THEN + esi(mgs) = exp(0.025*min(temcg(mgs),0.0)) ! LFO +! esi(mgs) = Min(0.5, exp(0.025*min(temcg(mgs),0.0)) ) ! LFO +! esi(mgs)=0.5*exp(0.1*min(temcg(mgs),0.0)) ! 10ice + ENDIF +! ELSE ! zrnic/ziegler 1993 +! esi(mgs)= 0.1 ! 0.5*exp(0.1*min(temcg(mgs),0.0)) +! ENDIF + if ( temg(mgs) .gt. 273.15 ) esi(mgs) = 0.0 + end if ! ! - ! ! +! Graupel: Collection (cxc) efficiencies ! ! - IF ( ipconc .ge. 1 ) THEN + xmascw(mgs) = xmas(mgs,lc) + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc).gt.qxmin(lc) ) then + ehw(mgs) = 1.0 + IF ( iehw .eq. 0 ) THEN + ehw(mgs) = ehw0 ! default value is 1.0 + ELSEIF ( iehw .eq. 1 .or. iehw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehw(mgs) = Min( ehw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) + + ELSEIF ( iehw .eq. 2 .or. iehw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = igwr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lh,3) ! changed to mean volume diameter + + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) + +! write(iunit,*) 'slop1: ',slope1,slope2,ew(ic,ir),cwr(ic,2) + + x1 = ew(ic, ir) + slope1*Max(0.0, (cwrad - cwr(ic,1)) ) + x2 = ew(icp1,ir) + slope2*Max(0.0, (cwrad - cwr(ic,1)) ) + + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*Max(0.0, (rwrad - grad(ir,1)) ) ) ) + ehw(mgs) = Min( ehw(mgs), tmp ) + +! write(iunit,*) 'ehw: ',ehw(mgs),1.e6*cwrad,1.e6*rwrad,ic,ir,x1,x2 +! write(iunit,*) + +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehw(mgs) = ehw(mgs) + (1.0 - ehw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 + + ELSEIF ( iehw .eq. 3 .or. iehw .eq. 10 ) THEN ! use fraction of droplets greater than dmincw diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + xmascw(mgs) = xmas(mgs,lc) + xdn0(lc)*(pi*dmincw**3/6.0) ! this is the average mass of the droplets with d > dmincw + ehw(mgs) = Min( ehw(mgs), tmp ) + ELSEIF ( iehw .eq. 4 .or. iehw .eq. 10 ) THEN ! Cober and List 1993 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lh,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lh,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehw(mgs) = Min( ehw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehw(mgs)=0.0 + + ehw(mgs) = Min( ehw0, ehw(mgs) ) + + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehw(mgs) = 0.0 + ENDIF + + end if ! + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then +! ehr(mgs) = Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,lh,1)) + ehr(mgs) = 1.0 + ehr(mgs) = Min( ehr0, ehr(mgs) ) + end if ! -! concentration production terms + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) + ELSE + ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) + ENDIF + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lc) > qxmin(lc) ) then + ehsclsn(mgs) = ehs_collsn + IF ( xdia(mgs,ls,3) < 40.e-6 ) THEN + ehsclsn(mgs) = 0.0 + ELSEIF ( xdia(mgs,ls,3) < 150.e-6 ) THEN + ehsclsn(mgs) = ehs_collsn*(xdia(mgs,ls,3) - 40.e-6)/(150.e-6 - 40.e-6) + ELSE + ehsclsn(mgs) = ehs_collsn + ENDIF +! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density + ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to lowest density + end if + ENDIF ! -! YYY + if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,li).gt.qxmin(li) ) then + ehiclsn(mgs) = ehi_collsn + ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) + ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 ) ehi(mgs) = 0.0 + end if + + ! ! -! DO mgs = 1,ngscnt - pccwi(:) = 0.0 - pccwd(:) = 0.0 - pccii(:) = 0.0 - pccid(:) = 0.0 - pcrwi(:) = 0.0 - pcrwd(:) = 0.0 - pcswi(:) = 0.0 - pcswd(:) = 0.0 - pchwi(:) = 0.0 - pchwd(:) = 0.0 - pchli(:) = 0.0 - pchld(:) = 0.0 -! ENDDO +! Hail: Collection (cxc) efficiencies ! -! Cloud ice ! -! IF ( ipconc .ge. 1 ) THEN + IF ( lhl .gt. 1 ) THEN - IF ( warmonly < 0.5 ) THEN - do mgs = 1,ngscnt - pccii(mgs) = & - & il5(mgs)*cicint(mgs) & -! > +il5(mgs)*cidpv(mgs) -! > +il5(mgs)*(cwacii(mgs)) & - & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & - & +cicichr(mgs)) & - & +chmul1(mgs) & - & +chlmul1(mgs) & - & + csplinter(mgs) + csplinter2(mgs) & -! > + nsplinter*(crfrzf(mgs) + crfrz(mgs)) - & +csmul(mgs) - pccid(mgs) = & - & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & - & -craci(mgs) & - & -csaci(mgs) & - & -chaci(mgs) - chlaci(mgs) & - & -chcni(mgs)) & - & +il5(mgs)*cisbv(mgs) & - & -(1.-il5(mgs))*cimlr(mgs) - end do - ELSEIF ( warmonly < 0.8 ) THEN - do mgs = 1,ngscnt - -! qiint(mgs) = 0.0 -! cicint(mgs) = 0.0 -! qicicnt(mgs) = 0.0 - - pccii(mgs) = & - & il5(mgs)*cicint(mgs) & - & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & - & +cicichr(mgs)) & - & +chmul1(mgs) & - & +chlmul1(mgs) & - & + csplinter(mgs) + csplinter2(mgs) & - & +csmul(mgs) - pccid(mgs) = & -! & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & -! & -craci(mgs) & -! & -csaci(mgs) & -! & -chaci(mgs) - chlaci(mgs) & -! & -chcni(mgs)) & - & +il5(mgs)*cisbv(mgs) & - & -(1.-il5(mgs))*cimlr(mgs) - end do - ENDIF ! warmonly - - -! ENDIF ! ( ipconc .ge. 1 ) -! -! Cloud water -! - IF ( ipconc .ge. 2 ) THEN - - do mgs = 1,ngscnt - pccwi(mgs) = (0.0) ! + (1-il5(mgs))*(-cirmlw(mgs)) - - IF ( warmonly < 0.5 ) THEN - pccwd(mgs) = & - & - cautn(mgs) + & - & il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & - & -cwfrzc(mgs)-cwctfzc(mgs) & - & ) & - & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) - ELSEIF ( warmonly < 0.8 ) THEN - pccwd(mgs) = & - & - cautn(mgs) + & - & il5(mgs)*( & - & -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & - & -cwfrzc(mgs)-cwctfzc(mgs) & - & ) & - & -cracw(mgs) -chacw(mgs) -chlacw(mgs) - ELSE + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lc).gt.qxmin(lc) ) then + IF ( iehw == 3 ) iehlw = 3 + IF ( iehw == 4 ) iehlw = 4 + ehlw(mgs) = ehlw0 + IF ( iehlw .eq. 0 ) THEN + ehlw(mgs) = ehlw0 ! default value is 1.0 + ELSEIF ( iehlw .eq. 1 .or. iehlw .eq. 10 ) THEN + cwrad = 0.5*xdia(mgs,lc,1) + ehlw(mgs) = Min( ehlw0, & + & ewfac*min((aradcw + cwrad*(bradcw + cwrad* & + & (cradcw + cwrad*(dradcw)))), 1.0) ) -! tmp3d(igs(mgs),jy,kgs(mgs)) = crcnw(mgs) - -! cracw(mgs) = 0.0 ! turn off accretion -! qracw(mgs) = 0.0 -! crcev(mgs) = 0.0 ! turn off evap -! qrcev(mgs) = 0.0 ! turn off evap -! cracr(mgs) = 0.0 ! turn off self collection + ELSEIF ( iehlw .eq. 2 .or. iehlw .eq. 10 ) THEN + ic = icwr(mgs) + icp1 = Min( 8, ic+1 ) + ir = ihlr(mgs) + irp1 = Min( 6, ir+1 ) + cwrad = 0.5*xdia(mgs,lc,1) + rwrad = 0.5*xdia(mgs,lhl,3) ! changed to mean volume diameter + slope1 = (ew(icp1, ir ) - ew(ic,ir ))*cwr(ic,2) + slope2 = (ew(icp1, irp1) - ew(ic,irp1))*cwr(ic,2) -! cautn(mgs) = 0.0 -! crcnw(mgs) = 0.0 -! qrcnw(mgs) = 0.0 - - pccwd(mgs) = & - & - cautn(mgs) -cracw(mgs) - ENDIF - - - IF ( -pccwd(mgs)*dtp .gt. cx(mgs,lc) ) THEN -! write(0,*) 'OUCH! pccwd(mgs)*dtp .gt. ccw(mgs) ',pccwd(mgs),cx(mgs,lc) -! write(0,*) 'qc = ',qx(mgs,lc) -! write(0,*) -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs)-cwfrzc(mgs)-cwctfzc(mgs) -! write(0,*) -cracw(mgs) -csacw(mgs) -chacw(mgs) -! write(0,*) - cautn(mgs) - - frac = -cx(mgs,lc)/(pccwd(mgs)*dtp) - pccwd(mgs) = -cx(mgs,lc)/dtp - - ciacw(mgs) = frac*ciacw(mgs) - cwfrzp(mgs) = frac*cwfrzp(mgs) - cwctfzp(mgs) = frac*cwctfzp(mgs) - cwfrzc(mgs) = frac*cwfrzc(mgs) - cwctfzc(mgs) = frac*cwctfzc(mgs) - cracw(mgs) = frac*cracw(mgs) - csacw(mgs) = frac*csacw(mgs) - chacw(mgs) = frac*chacw(mgs) - cautn(mgs) = frac*cautn(mgs) + x1 = ew(ic, ir) + slope1*(cwrad - cwr(ic,1)) + x2 = ew(icp1,ir) + slope2*(cwrad - cwr(ic,1)) - pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs)) - IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) - -! STOP - ENDIF + slope1 = (x2 - x1)*grad(ir,2) + + tmp = Max( 0.0, Min( 1.0, x1 + slope1*(rwrad - grad(ir,1)) ) ) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) +! ehw(mgs) = Max( 0.2, ehw(mgs) ) +! assume that ehw = 1 for zero air resistance (rho0 = 0.0) and extrapolate toward that +! ehw(mgs) = ehw(mgs) + (ehw(mgs) - 1.0)*(rho0(mgs) - rho00)/rho00 +! ehlw(mgs) = ehlw(mgs) + (1.0 - ehlw(mgs))*((Max(0.0,rho00 - rho0(mgs)))/rho00)**2 - end do + ELSEIF ( iehlw .eq. 3 .or. iehlw .eq. 10 ) THEN ! use fraction of droplets greater than 15 micron diameter + tmp = Exp(- (dmincw/xdia(mgs,lc,1))**3) + ehlw(mgs) = Min( ehlw(mgs), tmp ) + ELSEIF ( iehlw .eq. 4 .or. iehlw .eq. 10 ) THEN ! Cober and List 1993 + tmp = & + & 2.0*xdn(mgs,lc)*vtxbar(mgs,lhl,1)*(0.5*xdia(mgs,lc,1))**2 & + & /(9.0*fadvisc(mgs)*0.5*xdia(mgs,lhl,3)) + tmp = Max( 1.5, Min(10.0, tmp) ) + ehlw(mgs) = Min( ehlw(mgs), 0.55*Log10(2.51*tmp) ) + ENDIF + if ( xdia(mgs,lc,1) .lt. 2.4e-06 ) ehlw(mgs)=0.0 + ehlw(mgs) = Min( ehlw0, ehlw(mgs) ) - ENDIF ! ipconc + IF ( ibfc == -1 .and. temcg(mgs) < -41.0 ) THEN + ehlw(mgs) = 0.0 + ENDIF + end if ! -! Rain + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lr).gt.qxmin(lr) & +! & .and. temg(mgs) .lt. tfr & + & ) then + ehlr(mgs) = 1.0 + ehlr(mgs) = Min( ehlr0, ehlr(mgs) ) + end if ! - IF ( ipconc .ge. 3 ) THEN - - do mgs = 1,ngscnt - - IF ( warmonly < 0.5 ) THEN - pcrwi(mgs) = & -! > cracw(mgs) + & - & crcnw(mgs) & - & +(1-il5(mgs))*( & - & -chmlrr(mgs)/rzxh(mgs) & - & -chlmlrr(mgs)/rzxhl(mgs) & - & -csmlr(mgs) & - & - cimlr(mgs) ) & - & -crshr(mgs) !null at this point when wet snow/graupel included - pcrwd(mgs) = & - & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs)) -! > -csacr(mgs) & - & - chacr(mgs) - chlacr(mgs) & - & +crcev(mgs) & - & - cracr(mgs) -! > -il5(mgs)*ciracr(mgs) - ELSEIF ( warmonly < 0.8 ) THEN - pcrwi(mgs) = & - & crcnw(mgs) & - & +(1-il5(mgs))*( & - & -chmlrr(mgs)/rzxh(mgs) & - & -chlmlrr(mgs)/rzxhl(mgs) & - & -csmlr(mgs) & - & - cimlr(mgs) ) & - & -crshr(mgs) !null at this point when wet snow/graupel included - pcrwd(mgs) = & - & il5(mgs)*( - crfrz(mgs) ) & ! - cipacr(mgs)) - & - chacr(mgs) & - & - chlacr(mgs) & - & +crcev(mgs) & - & - cracr(mgs) - ELSE - pcrwi(mgs) = & - & crcnw(mgs) - pcrwd(mgs) = & - & +crcev(mgs) & - & - cracr(mgs) - -! tmp3d(igs(mgs),jy,kgs(mgs)) = vtxbar(mgs,lr,1) ! crcnw(mgs) ! (pcrwi(mgs) + pcrwd(mgs)) -! pcrwi(mgs) = 0.0 -! pcrwd(mgs) = 0.0 -! qrcnw(mgs) = 0.0 - - ENDIF - - - frac = 0.0 - IF ( -pcrwd(mgs)*dtp .gt. cx(mgs,lr) ) THEN -! write(0,*) 'OUCH! pcrwd(mgs)*dtp .gt. crw(mgs) ',pcrwd(mgs)*dtp,cx(mgs,lr),mgs,igs(mgs),kgs(mgs) -! write(0,*) -ciacr(mgs) -! write(0,*) -crfrz(mgs) -! write(0,*) -chacr(mgs) -! write(0,*) crcev(mgs) -! write(0,*) -cracr(mgs) - - frac = -cx(mgs,lr)/(pcrwd(mgs)*dtp) - pcrwd(mgs) = -cx(mgs,lr)/dtp - - ciacr(mgs) = frac*ciacr(mgs) - crfrz(mgs) = frac*crfrz(mgs) - crfrzf(mgs) = frac*crfrzf(mgs) - chacr(mgs) = frac*chacr(mgs) - crcev(mgs) = frac*crcev(mgs) - cracr(mgs) = frac*cracr(mgs) - -! STOP + IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN + if ( qx(mgs,lhl).gt.qxmin(lhl) ) then + ehlsclsn(mgs) = ehls_collsn + ehls(mgs) = ehscnv(mgs) + end if ENDIF +! + if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,li).gt.qxmin(li) ) then + ehliclsn(mgs) = ehli_collsn + ehli(mgs)=eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) + ehli(mgs) = Min( ehimax, Max( ehli(mgs), ehimin ) ) + if ( temg(mgs) .gt. 273.15 ) ehli(mgs) = 1.0 + end if - end do - - ENDIF + ENDIF ! lhl .gt. 1 - IF ( warmonly < 0.5 ) THEN + ENDDO ! mgs loop for collection efficiencies ! -! Snow ! - IF ( ipconc .ge. 4 ) THEN ! - - do mgs = 1,ngscnt - pcswi(mgs) = & - & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & - & + crfrzs(mgs) - pcswd(mgs) = & -! : cracs(mgs) & - & -chacs(mgs) - chlacs(mgs) & - & -chcns(mgs) & - & +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & ! + csshrp(mgs) -! > +il5(mgs)*(cssbv(mgs)) & - & + cssbv(mgs) & - & - csacs(mgs) - end do - - ENDIF - ! -! Graupel +! Set flags for plates vs. columns +! ! - IF ( ipconc .ge. 5 ) THEN ! do mgs = 1,ngscnt - pchwi(mgs) = & - & +ifrzg*(crfrzf(mgs) & - & +il5(mgs)*(ciacrf(mgs) )) & - & + chcnsh(mgs) + chcnih(mgs) - - pchwd(mgs) = & - & (1-il5(mgs))*chmlr(mgs) & -! > + il5(mgs)*chsbv(mgs) & - & + chsbv(mgs) & - & - il5(mgs)*chlcnh(mgs) +! + xplate(mgs) = 0.0 + xcolmn(mgs) = 1.0 +! +! if ( temcg(mgs) .lt. 0. .and. temcg(mgs) .ge. -4. ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -4. .and. temcg(mgs) .ge. -9. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +!c +! if ( temcg(mgs) .lt. -9. .and. temcg(mgs) .ge. -22.5 ) then +! xplate(mgs) = 1.0 +! xcolmn(mgs) = 0.0 +! end if +!c +! if ( temcg(mgs) .lt. -22.5 .and. temcg(mgs) .ge. -90. ) then +! xplate(mgs) = 0.0 +! xcolmn(mgs) = 1.0 +! end if +! end do ! - ! -! Hail ! - IF ( lhl .gt. 1 ) THEN ! +! Collection growth equations.... +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: rain collects xxxxx' +! do mgs = 1,ngscnt - pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs) +il5(mgs)*(ciacrf(mgs) )) & - & + chlcnh(mgs) *rzxhlh(mgs) + qracw(mgs) = 0.0 + IF ( qx(mgs,lr) .gt. qxmin(lr) .and. erw(mgs) .gt. 0.0 ) THEN + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 .and. qx(mgs,lr) .gt. 1.e-7 ) THEN + vt = (ar*(xdia(mgs,lc,1)**br))*rhovt(mgs) + qracw(mgs) = & + & (0.25)*pi*erw(mgs)*qx(mgs,lc)*cx(mgs,lr) & +! > *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *Max(0.0, vtxbar(mgs,lr,1)-vt) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) +! qracw(mgs) = 0.0 +! write(iunit,*) 'qracw,cx =',qracw(mgs),1.e6*xdia(mgs,lr,1),erw(mgs) +! write(iunit,*) 'qracw,cx =',qracw(mgs),cx(mgs,lc),kgs(mgs),cx(mgs,lr),1.e6*xdia(mgs,lr,1),vtxbar(mgs,lr,1),vt +! write(iunit,*) 'vtr: ',vtxbar(mgs,lr,1), ar*gf4br/6.0*xdia(mgs,lr,1)**br, rhovt(mgs), +! : ar*gf4br/6.0*xdia(mgs,lr,1)**br * rhovt(mgs) + ENDIF + ELSE - pchld(mgs) = & - & (1-il5(mgs))*chlmlr(mgs) & -! > + il5(mgs)*chlsbv(mgs) & - & + chlsbv(mgs) + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( rwrad .gt. rh(mgs) ) THEN ! .or. cx(mgs,lr) .gt. nh(mgs) ) THEN + IF ( rwrad .gt. rwradmn ) THEN +! DM1CCC=A2*XNC*XNR*XVC*(((CNU+2.)/(CNU+1.))*XVC+XVR) ! (A12) +! NOTE: Result is independent of imurain, assumes mucloud = 3 + qracw(mgs) = erw(mgs)*aa2*cx(mgs,lr)*cx(mgs,lc)*xmas(mgs,lc)* & + & ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,lr))/rho0(mgs) !*rhoinv(mgs) + ELSE -! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN -! write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) -! ENDIF - end do + IF ( imurain == 3 ) THEN - ENDIF +! DM1CCC=A1*XNC*XNR*(((CNU+3.)*(CNU+2.)/(CNU+1.)**2)*XVC**3+ ! (A14) +! 1 ((RNU+2.)/(RNU+1.))*XVC*XVR**2) + +! qracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)*xdn(mgs,lc)* & +! & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**3/(cnu + 1.)**2 + & +! & (alpha(mgs,lr) + 2.)*xv(mgs,lc)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.))/rho0(mgs) !*rhoinv(mgs) +! save multiplies by converting cx*xdn*xv/rho0 to qx + qracw(mgs) = aa1*cx(mgs,lr)*qx(mgs,lc)* & + & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.)**2 + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + + ELSE ! imurain == 1 + + qracw(mgs) = aa1*cx(mgs,lr)*qx(mgs,lc)* & + & ((cnu + 3.)*(cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.)**2 + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.))) + + ENDIF + + ENDIF + ENDIF + ENDIF + ENDIF +! qracw(mgs) = Min(qracw(mgs), qx(mgs,lc)) + qracw(mgs) = Min(qracw(mgs), qcmxd(mgs)) + ENDIF + end do ! + do mgs = 1,ngscnt + qraci(mgs) = 0.0 + craci(mgs) = 0.0 + IF ( eri(mgs) .gt. 0.0 .and. iacr .ge. 1 .and. xdia(mgs,lr,3) .gt. 2.*rwradmn ) THEN + IF ( ipconc .ge. 3 ) THEN - ENDIF ! (ipconc .ge. 5 ) + tmp = eri(mgs)*aa2*cx(mgs,lr)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,lr)) - ELSEIF ( warmonly < 0.8 ) THEN + qraci(mgs) = Min( qxmxd(mgs,li), tmp*xmas(mgs,li)*rhoinv(mgs) ) + craci(mgs) = Min( cxmxd(mgs,li), tmp ) +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) ! -! Graupel +! qraci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*qx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab1(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da1(li)*xdia(mgs,li,3)**2 ) ! - IF ( ipconc .ge. 5 ) THEN ! - do mgs = 1,ngscnt - pchwi(mgs) = & - & +ifrzg*(crfrzf(mgs) ) +! +! vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + +! : 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) +! +! craci(mgs) = 0.25*pi*eri(mgs)*cx(mgs,lr)*cx(mgs,li)*vt* +! : ( da0(lr)*xdia(mgs,lr,3)**2 + +! : dab0(lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + +! : da0(li)*xdia(mgs,li,3)**2 ) +! +! qraci(mgs) = Min( qraci(mgs), qxmxd(mgs,li) ) +! craci(mgs) = Min( craci(mgs), cxmxd(mgs,li) ) - pchwd(mgs) = & - & (1-il5(mgs))*chmlr(mgs) & - & - il5(mgs)*chlcnh(mgs) + ELSE + qraci(mgs) = & + & min( & + & (0.25)*pi*eri(mgs)*qx(mgs,li)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lr,2) & + & + 2.0*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qraci(mgs) = 0.0 + end if + ENDIF end do ! -! Hail + do mgs = 1,ngscnt + qracs(mgs) = 0.0 + IF ( ers(mgs) .gt. 0.0 .and. ipconc < 3 ) THEN + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + qracs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ers(mgs)*qx(mgs,ls)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lr,1) & + & + gf4*gf3*xdia(mgs,lr,2) ) & + & , qsmxd(mgs)) + ENDIF + end do + +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: snow collects xxxxx' ! - IF ( lhl .gt. 1 ) THEN ! do mgs = 1,ngscnt - pchli(mgs) = & ! (1.0-ifrzg)*(crfrzf(mgs) +il5(mgs)*(ciacrf(mgs) )) & - & + chlcnh(mgs) *rzxhl(mgs)/rzxh(mgs) + qsacw(mgs) = 0.0 + csacw(mgs) = 0.0 + vsacw(mgs) = 0.0 + IF ( esw(mgs) .gt. 0.0 ) THEN - pchld(mgs) = & - & (1-il5(mgs))*chlmlr(mgs) ! & -! > + il5(mgs)*chlsbv(mgs) & -! & + chlsbv(mgs) + IF ( ipconc .ge. 4 ) THEN +! QSACC=CECS*RVT*A2*XNC*XNS*XVC*ROS* +! * (((CNU+2.)/(CNU+1.))*XVC+XVS)/RO -! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN -! write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) -! ENDIF - end do +! tmp = esw(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* +! : ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls)) + tmp = 1.0*rvt*aa2*cx(mgs,ls)*cx(mgs,lc)* & + & ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls)) - ENDIF + qsacw(mgs) = Min( qxmxd(mgs,lc), tmp*xmas(mgs,lc)*rhoinv(mgs) ) + csacw(mgs) = Min( cxmxd(mgs,lc), tmp ) - ENDIF ! ipconc >= 5 + IF ( lvol(ls) .gt. 1 ) THEN + IF ( temg(mgs) .lt. 273.15) THEN + rimdn(mgs,ls) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,ls) = Min( Max( rimc3, rimdn(mgs,ls) ), rimc4 ) + ELSE + rimdn(mgs,ls) = 1000. + ENDIF - ENDIF ! warmonly + vsacw(mgs) = rho0(mgs)*qsacw(mgs)/rimdn(mgs,ls) -! + ENDIF -! -! Balance and checks for continuity.....within machine precision... -! - do mgs = 1,ngscnt - pctot(mgs) = pccwi(mgs) +pccwd(mgs) + & - & pccii(mgs) +pccid(mgs) + & - & pcrwi(mgs) +pcrwd(mgs) + & - & pcswi(mgs) +pcswd(mgs) + & - & pchwi(mgs) +pchwd(mgs) + & - & pchli(mgs) +pchld(mgs) + +! qsacw(mgs) = cecs*aa2*cx(mgs,ls)*cx(mgs,lc)*xmas(mgs,lc)* +! : ((cnu + 2.)*xv(mgs,lc)/(cnu + 1.) + xv(mgs,ls))*rhoinv(mgs) + ELSE +! qsacw(mgs) = +! > min( +! > ((0.25)*pi)*esw(mgs)*qx(mgs,lc)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,lc,1) +! > + gf1*xdia(mgs,lc,2) ) +! < , qcmxd(mgs)) + + vt = abs(vtxbar(mgs,ls,1)-vtxbar(mgs,lc,1)) + + qsacw(mgs) = 0.25*pi*esw(mgs)*cx(mgs,ls)*qx(mgs,lc)*vt* & + & ( da0(ls)*xdia(mgs,ls,3)**2 + & + & dab1(ls,lc)*xdia(mgs,ls,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) + qsacw(mgs) = Min( qsacw(mgs), qxmxd(mgs,ls) ) + csacw(mgs) = rho0(mgs)*qsacw(mgs)/xmas(mgs,lc) + ENDIF + ENDIF end do ! ! - ENDIF ! ( ipconc .ge. 1 ) -! -! -! -! -! -! GOGO -! production terms for mass -! -! - pqwvi(:) = 0.0 - pqwvd(:) = 0.0 - pqcwi(:) = 0.0 - pqcwd(:) = 0.0 - pqcii(:) = 0.0 - pqcid(:) = 0.0 - pqrwi(:) = 0.0 - pqrwd(:) = 0.0 - pqswi(:) = 0.0 - pqswd(:) = 0.0 - pqhwi(:) = 0.0 - pqhwd(:) = 0.0 - pqhli(:) = 0.0 - pqhld(:) = 0.0 - pqlwsi(:) = 0.0 - pqlwsd(:) = 0.0 - pqlwhi(:) = 0.0 - pqlwhd(:) = 0.0 - pqlwhli(:) = 0.0 - pqlwhld(:) = 0.0 -! -! Vapor -! - IF ( warmonly < 0.5 ) THEN do mgs = 1,ngscnt - pqwvi(mgs) = & - & -Min(0.0, qrcev(mgs)) & - & -Min(0.0, qhcev(mgs)) & - & -Min(0.0, qhlcev(mgs)) & - & -Min(0.0, qscev(mgs)) & -! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & - & -qhsbv(mgs) - qhlsbv(mgs) & - & -qssbv(mgs) & - & -il5(mgs)*qisbv(mgs) - pqwvd(mgs) = & - & -Max(0.0, qrcev(mgs)) & - & -Max(0.0, qhcev(mgs)) & - & -Max(0.0, qhlcev(mgs)) & - & -Max(0.0, qscev(mgs)) & - & +il5(mgs)*(-qiint(mgs) & - & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & - & -il5(mgs)*qidpv(mgs) - end do + qsaci(mgs) = 0.0 + csaci(mgs) = 0.0 + csaci0(mgs) = 0.0 + IF ( ipconc .ge. 4 ) THEN + IF ( esi(mgs) .gt. 0.0 .or. ( ipelec > 0 .and. esiclsn(mgs) > 0.0 )) THEN +! QSCOI=CEXS*RVT*A2*XNCI*XNS*XVCI*ROS* +! * (((CINU+2.)/(CINU+1.))*VCIP+XVS)/RO - ELSEIF ( warmonly < 0.8 ) THEN - do mgs = 1,ngscnt - pqwvi(mgs) = & - & -Min(0.0, qrcev(mgs)) & - & -il5(mgs)*qisbv(mgs) - pqwvd(mgs) = & - & +il5(mgs)*(-qiint(mgs) & -! & -qhdpv(mgs) ) & !- qhldpv(mgs)) & - & -qhdpv(mgs) - qhldpv(mgs)) & -! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & - & -Max(0.0, qrcev(mgs)) & - & -il5(mgs)*qidpv(mgs) - end do + tmp = esiclsn(mgs)*rvt*aa2*cx(mgs,ls)*cx(mgs,li)* & + & ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,ls)) - ELSE - do mgs = 1,ngscnt - pqwvi(mgs) = & - & -Min(0.0, qrcev(mgs)) - pqwvd(mgs) = & - & -Max(0.0, qrcev(mgs)) - end do + qsaci(mgs) = Min( qxmxd(mgs,li), esi(mgs)*tmp*xmas(mgs,li)*rhoinv(mgs) ) + csaci0(mgs) = tmp + csaci(mgs) = Min(cxmxd(mgs,li), esi(mgs)*tmp ) - ENDIF ! warmonly +! qsaci(mgs) = +! > min( +! > ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) +! > *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) +! > *( gf3*xdia(mgs,ls,2) +! > + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) +! > + gf1*xdia(mgs,li,2) ) +! < , qimxd(mgs)) + ENDIF + ELSE ! + IF ( esi(mgs) .gt. 0.0 ) THEN + qsaci(mgs) = & + & min( & + & ((0.25)*pi)*esi(mgs)*qx(mgs,li)*cx(mgs,ls) & + & *abs(vtxbar(mgs,ls,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,ls,2) & + & + 2.0*gf2*xdia(mgs,ls,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do +! ! -! Cloud water ! do mgs = 1,ngscnt - - pqcwi(mgs) = (0.0) + qwcnr(mgs) - - IF ( warmonly < 0.5 ) THEN - pqcwd(mgs) = & - & il5(mgs)*(-qiacw(mgs)-qwfrzc(mgs)-qwctfzc(mgs)) & - & -il5(mgs)*(qicichr(mgs)) & - & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) -! > -il5(mgs)*(qwfrzp(mgs)+qwctfzp(mgs)) - ELSEIF ( warmonly < 0.8 ) THEN - pqcwd(mgs) = & - & il5(mgs)*(-qiacw(mgs)-qwfrzc(mgs)-qwctfzc(mgs)) & -! & il5(mgs)*(-qwfrzc(mgs)-qwctfzc(mgs)) & - & -il5(mgs)*(qicichr(mgs)) & - & -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs) + qsacr(mgs) = 0.0 + qsacrs(mgs) = 0.0 + csacr(mgs) = 0.0 + IF ( esr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN +! vt = Sqrt((vtxbar(mgs,ls,1)-vtxbar(mgs,lr,1))**2 + +! : 0.04*vtxbar(mgs,ls,1)*vtxbar(mgs,lr,1) ) +! qsacr(mgs) = esr(mgs)*cx(mgs,ls)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,ls,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,ls,2)) +! qsacr(mgs) = Min( qsacr(mgs), qrmxd(mgs) ) +! csacr(mgs) = qsacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +! csacr(mgs) = min(csacr(mgs),crmxd(mgs)) ELSE - pqcwd(mgs) = & - & -qracw(mgs) - qrcnw(mgs) + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,ls,1) + ENDIF + + qsacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*esr(mgs)*qx(mgs,lr)*cx(mgs,ls) & + & *abs(vtxbar(mgs,lr,1)-vt) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,ls,1) & + & + gf4*gf3*xdia(mgs,ls,2) ) & + & , qrmxd(mgs)) ENDIF - - IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN - - frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp) - pqcwd(mgs) = -qx(mgs,lc)/dtp - - qiacw(mgs) = frac*qiacw(mgs) -! qwfrzp(mgs) = frac*qwfrzp(mgs) -! qwctfzp(mgs) = frac*qwctfzp(mgs) - qwfrzc(mgs) = frac*qwfrzc(mgs) - qwctfzc(mgs) = frac*qwctfzc(mgs) - qracw(mgs) = frac*qracw(mgs) - qsacw(mgs) = frac*qsacw(mgs) - qhacw(mgs) = frac*qhacw(mgs) - vhacw(mgs) = frac*vhacw(mgs) - qrcnw(mgs) = frac*qrcnw(mgs) - IF ( lhl .gt. 1 ) THEN - qhlacw(mgs) = frac*qhlacw(mgs) - vhlacw(mgs) = frac*vhlacw(mgs) - ENDIF -! IF ( lzh .gt. 1 ) zhacw(mgs) = frac*zhacw(mgs) - -! STOP ENDIF - - end do ! -! Cloud ice ! - IF ( warmonly < 0.5 ) THEN - - do mgs = 1,ngscnt - pqcii(mgs) = & - & il5(mgs)*qicicnt(mgs) & - & +il5(mgs)*qidpv(mgs) & - & +il5(mgs)*qiacw(mgs) & ! (qiacwi(mgs)+qwacii(mgs)) & - & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & - & +il5(mgs)*(qicichr(mgs)) & - & +qsmul(mgs) & - & +qhmul1(mgs) + qhlmul1(mgs) & - & + qsplinter(mgs) + qsplinter2(mgs) -! > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) - - pqcid(mgs) = & - & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & - & -qraci(mgs) & - & -qsaci(mgs) ) & - & -qhaci(mgs) & - & -qhlaci(mgs) & - & +il5(mgs)*qisbv(mgs) & - & +(1.-il5(mgs))*qimlr(mgs) & - & - qhcni(mgs) - end do - - ELSEIF ( warmonly < 0.8 ) THEN - +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: graupel collects xxxxx' +! do mgs = 1,ngscnt - pqcii(mgs) = & - & il5(mgs)*qicicnt(mgs) & - & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & -! & +il5(mgs)*(qicichr(mgs)) & -! & +qsmul(mgs) & - & +qhmul1(mgs) + qhlmul1(mgs) & - & + qsplinter(mgs) + qsplinter2(mgs) & - & +il5(mgs)*qidpv(mgs) & - & +il5(mgs)*qiacw(mgs) ! & ! (qiacwi(mgs)+qwacii(mgs)) & -! & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & -! & +il5(mgs)*(qicichr(mgs)) & -! & +qsmul(mgs) & -! & +qhmul1(mgs) + qhlmul1(mgs) & -! & + qsplinter(mgs) + qsplinter2(mgs) + qhacw(mgs) = 0.0 + rarx(mgs,lh) = 0.0 + vhacw(mgs) = 0.0 + vhsoak(mgs) = 0.0 + zhacw(mgs) = 0.0 + + IF ( .false. ) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))/dtp) + vtxbar(mgs,lh,1) = Min( vtmax, vtxbar(mgs,lh,1)) + vtxbar(mgs,lh,2) = Min( vtmax, vtxbar(mgs,lh,2)) + vtxbar(mgs,lh,3) = Min( vtmax, vtxbar(mgs,lh,3)) + ENDIF + IF ( ehw(mgs) .gt. 0.0 ) THEN - pqcid(mgs) = & -! & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & -! & -qraci(mgs) & -! & -qsaci(mgs) ) & -! & -qhaci(mgs) & -! & -qhlaci(mgs) & - & +il5(mgs)*qisbv(mgs) & - & +(1.-il5(mgs))*qimlr(mgs) ! & -! & - qhcni(mgs) - end do + IF ( ipconc .ge. 2 ) THEN - ENDIF -! -! Rain -! + IF ( .false. ) THEN + qhacw(mgs) = (ehw(mgs)*qx(mgs,lc)*cx(mgs,lh)*pi* & + & abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* & + & (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + & + & xdia(mgs,lc,1)*gf73rds) + & + & xdia(mgs,lc,2)*gf83rds))/4. + + ELSE ! using Seifert coefficients + vt = abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) - do mgs = 1,ngscnt - IF ( warmonly < 0.5 ) THEN - pqrwi(mgs) = & - & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & - & +(1-il5(mgs))*( & - & -qhmlr(mgs) & !null at this point when wet snow/graupel included - & -qsmlr(mgs) - qhlmlr(mgs) & - & -qimlr(mgs)) & - & -qsshr(mgs) & !null at this point when wet snow/graupel included - & -qhshr(mgs) & !null at this point when wet snow/graupel included - & -qhlshr(mgs) - pqrwd(mgs) = & - & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & - & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & - & + Min(0.0,qrcev(mgs)) - ELSEIF ( warmonly < 0.8 ) THEN - pqrwi(mgs) = & - & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & - & +(1-il5(mgs))*( & - & -qhmlr(mgs) & !null at this point when wet snow/graupel included - & -qhshr(mgs) & !null at this point when wet snow/graupel included - & -qhlmlr(mgs) & !null at this point when wet snow/graupel included - & -qhlshr(mgs) ) !null at this point when wet snow/graupel included - pqrwd(mgs) = & - & il5(mgs)*(-qrfrz(mgs)) & - & - qhacr(mgs) & - & - qhlacr(mgs) & - & + Min(0.0,qrcev(mgs)) - ELSE - pqrwi(mgs) = & - & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) - pqrwd(mgs) = Min(0.0,qrcev(mgs)) - ENDIF ! warmonly - - - ! IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN - IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN - - frac = (-qx(mgs,lr) + pqrwi(mgs)*dtp)/(pqrwd(mgs)*dtp) -! pqrwd(mgs) = -qx(mgs,lr)/dtp + pqrwi(mgs) - - pqwvi(mgs) = pqwvi(mgs) & - & + Min(0.0, qrcev(mgs)) & - & - frac*Min(0.0, qrcev(mgs)) - pqwvd(mgs) = pqwvd(mgs) & - & + Max(0.0, qrcev(mgs)) & - & - frac*Max(0.0, qrcev(mgs)) - - qiacr(mgs) = frac*qiacr(mgs) - qiacrf(mgs) = frac*qiacrf(mgs) - viacrf(mgs) = frac*viacrf(mgs) - qrfrz(mgs) = frac*qrfrz(mgs) - qrfrzs(mgs) = frac*qrfrzs(mgs) - qrfrzf(mgs) = frac*qrfrzf(mgs) - vrfrzf(mgs) = frac*vrfrzf(mgs) - qsacr(mgs) = frac*qsacr(mgs) - qhacr(mgs) = frac*qhacr(mgs) - vhacr(mgs) = frac*vhacr(mgs) - qrcev(mgs) = frac*qrcev(mgs) - qhlacr(mgs) = frac*qhlacr(mgs) - vhlacr(mgs) = frac*vhlacr(mgs) -! qhcev(mgs) = frac*qhcev(mgs) - - - IF ( warmonly < 0.5 ) THEN - pqrwd(mgs) = & - & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs)) & - & - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & - & + Min(0.0,qrcev(mgs)) - ELSEIF ( warmonly < 0.8 ) THEN - pqrwd(mgs) = & - & il5(mgs)*(-qrfrz(mgs)) & - & - qhacr(mgs) & - & - qhlacr(mgs) & - & + Min(0.0,qrcev(mgs)) - ELSE - pqrwd(mgs) = Min(0.0,qrcev(mgs)) - ENDIF ! warmonly - -! -! Resum for vapor since qrcev has changed -! - IF ( qrcev(mgs) .ne. 0.0 ) THEN - pqwvi(mgs) = & - & -Min(0.0, qrcev(mgs)) & - & -Min(0.0, qhcev(mgs)) & - & -Min(0.0, qhlcev(mgs)) & - & -Min(0.0, qscev(mgs)) & -! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & - & -qhsbv(mgs) - qhlsbv(mgs) & - & -qssbv(mgs) & - & -il5(mgs)*qisbv(mgs) - pqwvd(mgs) = & - & -Max(0.0, qrcev(mgs)) & - & -Max(0.0, qhcev(mgs)) & - & -Max(0.0, qhlcev(mgs)) & - & -Max(0.0, qscev(mgs)) & - & +il5(mgs)*(-qiint(mgs) & - & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & - & -il5(mgs)*qidpv(mgs) + qhacw(mgs) = 0.25*pi*ehw(mgs)*cx(mgs,lh)*qx(mgs,lc)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lc,lh)*xdia(mgs,lh,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) + + ENDIF + qhacw(mgs) = Min( qhacw(mgs), 0.5*qx(mgs,lc)/dtp ) + + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) + +!! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +!! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacw(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( qx(mgs,lh)/cx(mgs,lh)) * qhacw(mgs) ) + ENDIF + + ELSE + qhacw(mgs) = & + & min( & + & ((0.25)*pi)*ehw(mgs)*qx(mgs,lc)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,lc,1) & + & + gf1*xdia(mgs,lc,2) ) & + & , 0.5*qx(mgs,lc)/dtp) +! < , qxmxd(mgs,lc)) +! < , qcmxd(mgs)) + + + IF ( lwsm6 .and. qsacw(mgs) > 0.0 .and. qhacw(mgs) > 0.0) THEN + qaacw = ( qx(mgs,ls)*qsacw(mgs) + qx(mgs,lh)*qhacw(mgs) )/(qx(mgs,ls) + qx(mgs,lh)) +! qaacw = Min( qaacw, 0.5*(qsacw(mgs) + qhacw(mgs) ) ) + qsacw(mgs) = qaacw + qhacw(mgs) = qaacw + ENDIF + ENDIF + IF ( lvol(lh) .gt. 1 .or. lhl .gt. 1 ) THEN ! calculate rime density for graupel volume and/or for graupel conversion to hail + + IF ( temg(mgs) .lt. 273.15) THEN + rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,lh,1)) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,lh) = Min( Max( hdnmn, rimc3, rimdn(mgs,lh) ), rimc4 ) + ELSE + rimdn(mgs,lh) = 1000. + ENDIF + + IF ( lvol(lh) > 1 ) vhacw(mgs) = rho0(mgs)*qhacw(mgs)/rimdn(mgs,lh) -! STOP - ENDIF - end do - - IF ( warmonly < 0.5 ) THEN - -! -! Snow -! - do mgs = 1,ngscnt - pqswi(mgs) = & - & il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & - & + qscnvi(mgs) + qrfrzs(mgs) + il2(mgs)*qsacr(mgs)) & - & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & - & + Max(0.0, qscev(mgs)) & - & + qsacw(mgs) - pqswd(mgs) = & -! > -qfacs(mgs) ! -qwacs(mgs) & - & -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs) & - & -qhcns(mgs) & - & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included -! > +il5(mgs)*(qssbv(mgs)) & - & + (qssbv(mgs)) & - & + Min(0.0, qscev(mgs)) & - & -qsmul(mgs) - + ENDIF - end do + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .gt. 0 ) THEN + rarx(mgs,lh) = & + & qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh)) + ENDIF + ENDIF + end do ! -! Graupel ! do mgs = 1,ngscnt - pqhwi(mgs) = & - & +il5(mgs)*ifrzg*(qrfrzf(mgs) + (1-il3(mgs))*(qiacrf(mgs)+qracif(mgs))) & - & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & - & +il5(mgs)*(qhdpv(mgs)) & - & +Max(0.0, qhcev(mgs)) & - & +qhacr(mgs)+qhacw(mgs) & - & +qhacs(mgs)+qhaci(mgs) & - & + qhcns(mgs) + qhcni(mgs) - pqhwd(mgs) = & - & qhshr(mgs) & !null at this point when wet graupel included - & +(1-il5(mgs))*qhmlr(mgs) & !null at this point when wet graupel included -! > +il5(mgs)*qhsbv(mgs) & - & + qhsbv(mgs) & - & + Min(0.0, qhcev(mgs)) & - & -qhmul1(mgs) - qhlcnh(mgs) & - & - qsplinter(mgs) - qsplinter2(mgs) -! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) - end do + qhaci(mgs) = 0.0 + qhaci0(mgs) = 0.0 + IF ( ehi(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) + + qhaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*qx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + qhaci(mgs) = Min( ehi(mgs)*qhaci0(mgs), qimxd(mgs) ) + ELSE + qhaci(mgs) = & + & min( & + & ((0.25)*pi)*ehi(mgs)*ehiclsn(mgs)*qx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf3*xdia(mgs,lh,2) & + & + 2.0*gf2*xdia(mgs,lh,1)*xdia(mgs,li,1) & + & + gf1*xdia(mgs,li,2) ) & + & , qimxd(mgs)) + ENDIF + ENDIF + end do ! -! Hail ! - IF ( lhl .gt. 1 ) THEN - do mgs = 1,ngscnt - pqhli(mgs) = & - & +il5(mgs)*(qhldpv(mgs) + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & - & +Max(0.0, qhlcev(mgs)) & - & +qhlacr(mgs)+qhlacw(mgs) & - & +qhlacs(mgs)+qhlaci(mgs) & - & + qhlcnh(mgs) - pqhld(mgs) = & - & qhlshr(mgs) & - & +(1-il5(mgs))*qhlmlr(mgs) & -! > +il5(mgs)*qhlsbv(mgs) & - & + qhlsbv(mgs) & - & + Min(0.0, qhlcev(mgs)) & - & -qhlmul1(mgs) - end do + qhacs(mgs) = 0.0 + qhacs0(mgs) = 0.0 + IF ( ehs(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + qhacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*qx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) - ENDIF ! lhl + qhacs(mgs) = Min( ehs(mgs)*qhacs0(mgs), qsmxd(mgs) ) - ELSEIF ( warmonly < 0.8 ) THEN -! -! Graupel + ELSE + qhacs(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehs(mgs)*ehsclsn(mgs)*qx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf6*gf1*xdia(mgs,ls,2) & + & + 2.0*gf5*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qsmxd(mgs)) + ENDIF + ENDIF + end do ! do mgs = 1,ngscnt - pqhwi(mgs) = & - & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) & - & +il5(mgs)*(qhdpv(mgs)) & - & +qhacr(mgs)+qhacw(mgs) - pqhwd(mgs) = & - & qhshr(mgs) & !null at this point when wet graupel included - & - qhlcnh(mgs) & - & - qhmul1(mgs) & - & - qsplinter(mgs) - qsplinter2(mgs) & - & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included - end do + qhacr(mgs) = 0.0 + qhacrmlr(mgs) = 0.0 + vhacr(mgs) = 0.0 + chacr(mgs) = 0.0 + zhacr(mgs) = 0.0 + IF ( temg(mgs) .gt. tfr ) raindn(mgs,lh) = 1000.0 -! -! Hail -! - IF ( lhl .gt. 1 ) THEN + IF ( ehr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lr,1) ) +! qhacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : qx(mgs,lr)*0.25*pi* +! : (3.02787*xdia(mgs,lr,2) + +! : 3.30669*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) + + qhacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*qx(mgs,lr)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab1lh(mgs,lr,lh)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) - do mgs = 1,ngscnt - pqhli(mgs) = & - & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & - & +qhlacr(mgs)+qhlacw(mgs) & -! & +qhlacs(mgs)+qhlaci(mgs) & - & + qhlcnh(mgs) - pqhld(mgs) = & - & qhlshr(mgs) & - & +(1-il5(mgs))*qhlmlr(mgs) & -! > +il5(mgs)*qhlsbv(mgs) & - & + qhlsbv(mgs) & - & -qhlmul1(mgs) + qhacr(mgs) = Min( qhacr(mgs), qxmxd(mgs,lr) ) - end do + IF ( temg(mgs) > tfr ) THEN + qhacrmlr(mgs) = qhacr(mgs) + qhacr(mgs) = 0.0 + ELSE +! chacr(mgs) = Min( qhacr(mgs)*rho0(mgs)/xmas(mgs,lr), cxmxd(mgs,lr) ) - ENDIF ! lhl +! chacr(mgs) = ehr(mgs)*cx(mgs,lh)*vt* +! : cx(mgs,lr)*0.25*pi* +! : (0.69874*xdia(mgs,lr,2) + +! : 1.24001*xdia(mgs,lh,1)*xdia(mgs,lr,1) + +! : 2.*xdia(mgs,lh,2)) - ENDIF ! warmonly +! chacr(mgs) = 0.25*pi*ehr(mgs)*cx(mgs,lh)*cx(mgs,lr)*vt* +! : ( da0lh(mgs)*xdia(mgs,lh,3)**2 + +! : dab0lh(mgs,lr)*xdia(mgs,lh,3)*xdia(mgs,lr,3) + +! : da0(lr)*xdia(mgs,lr,3)**2 ) -! -! Liquid water on snow and graupel -! +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'chacr= ',chacr(mgs),tmp - vhmlr(:) = 0.0 - vhlmlr(:) = 0.0 - vhfzh(:) = 0.0 - vhlfzhl(:) = 0.0 + chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + chacr(mgs) = min(chacr(mgs),crmxd(mgs)) - IF ( mixedphase ) THEN - ELSE ! set arrays for non-mixedphase graupel - -! vhshdr(:) = 0.0 - vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation -! vhsoak(:) = 0.0 + IF ( lzh .gt. 1 ) THEN + tmp = qx(mgs,lh)/cx(mgs,lh) -! vhlshdr(:) = 0.0 - vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation -! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) -! vhlsoak(:) = 0.0 +! g1 = (6.0 + alpha(mgs,lh))*(5.0 + alpha(mgs,lh))*(4.0 + alpha(mgs,lh))/ +! : ((3.0 + alpha(mgs,lh))*(2.0 + alpha(mgs,lh))*(1.0 + alpha(mgs,lh))) +! alp = Max( 1.0, alpha(mgs,lh)+1. ) +! g1 = (6.0 + alp)*(5.0 + alp)*(4.0 + alp)/ +! : ((3.0 + alp)*(2.0 + alp)*(1.0 + alp)) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*1000.))**2*( 2.*( tmp ) * qhacr(mgs) - tmp**2 * chacr(mgs) ) +! zhacr(mgs) = g1*(6.*rho0(mgs)/(pi*xdn(mgs,lh)))**2*( 2.*( tmp ) * qhacr(mgs) ) + ENDIF + ENDIF ! temg > tfr - ENDIF ! mixedphase - + ELSE + IF ( lwsm6 .and. ipconc == 0 ) THEN + vt = vt2ave(mgs) + ELSE + vt = vtxbar(mgs,lh,1) + ENDIF + qhacr(mgs) = & + & min( & + & ((0.25)*pi/gf4)*ehr(mgs)*qx(mgs,lr)*cx(mgs,lh) & + & *abs(vt-vtxbar(mgs,lr,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,lh,1) & + & + gf4*gf3*xdia(mgs,lh,2) ) & + & , qrmxd(mgs)) + + IF ( temg(mgs) > tfr ) THEN + qhacrmlr(mgs) = qhacr(mgs) + qhacr(mgs) = 0.0 + ENDIF + + ENDIF + IF ( lvol(lh) .gt. 1 ) THEN + vhacr(mgs) = rho0(mgs)*qhacr(mgs)/raindn(mgs,lh) + ENDIF + ENDIF + end do ! -! Snow volume ! - IF ( lvol(ls) .gt. 1 ) THEN - do mgs = 1,ngscnt -! pvswi(mgs) = rho0(mgs)*( pqswi(mgs) )/xdn0(ls) - - pvswi(mgs) = rho0(mgs)*( & -!aps > il5*qsfzs(mgs)/xdn(mgs,ls) & -!aps > -il5*qsfzs(mgs)/xdn(mgs,lr) & - & +il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & - & + qscnvi(mgs) + qrfrzs(mgs))/xdn0(ls) & - & + (qsacr(mgs))/rimdn(mgs,ls) ) + vsacw(mgs) -! > + (qsacw(mgs) + qsacr(mgs))/rimdn(mgs,ls) ) - pvswd(mgs) = rho0(mgs)*( pqswd(mgs) )/xdn0(ls) & -! > -qhacs(mgs) -! > -qhcns(mgs) -! > +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) -! > +il5(mgs)*(qssbv(mgs)) - & -rho0(mgs)*qsmul(mgs)/xdn0(ls) -!aps > +rho0(mgs)*(1-il5(mgs))*( -!aps > qsmlr(mgs)/xdn(mgs,ls) -!aps > +(qscev-qsmlr(mgs))/xdn(mgs,lr) ) - end do + if (ndebug .gt. 0 ) write(0,*) 'Collection: hail collects xxxxx' +! -!aps IF (mixedphase) THEN -!aps pvswd(mgs) = pvswd(mgs) -!aps > + rho0(mgs)*qsshr(mgs)/xdn(mgs,lr) -!aps ENDIF + do mgs = 1,ngscnt + qhlacw(mgs) = 0.0 + vhlacw(mgs) = 0.0 + vhlsoak(mgs) = 0.0 + IF ( lhl > 1 .and. .true.) THEN + vtmax = (gz(igs(mgs),jgs,kgs(mgs))/dtp) + vtxbar(mgs,lhl,1) = Min( vtmax, vtxbar(mgs,lhl,1)) + vtxbar(mgs,lhl,2) = Min( vtmax, vtxbar(mgs,lhl,2)) + vtxbar(mgs,lhl,3) = Min( vtmax, vtxbar(mgs,lhl,3)) + ENDIF + IF ( lhl > 0 ) THEN + rarx(mgs,lhl) = 0.0 ENDIF -! -! Graupel volume -! - IF ( lvol(lh) .gt. 1 ) THEN - DO mgs = 1,ngscnt -! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) )/xdn0(lh) ) -! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) - il5(mgs)*qrfrzf(mgs) )/xdn0(lh) ! -! : + il5(mgs)*qrfrzf(mgs)/rhofrz ) + IF ( lhl .gt. 1 .and. ehlw(mgs) .gt. 0.0 ) THEN - pvhwi(mgs) = rho0(mgs)*( & - & +il5(mgs)*( qracif(mgs))/rhofrz & -!erm > + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)? & - & + ( il5(mgs)*qhdpv(mgs) & - & + qhacs(mgs) + qhaci(mgs) )/xdnmn(lh) ) & - & + rho0(mgs)*Max(0.0, qhcev(mgs))/1000. & ! only used in mixed phase: evaporation of liquid water coating -! > + qhacs(mgs) + qhaci(mgs) )/xdn0(ls) ) & - & + vhcns(mgs) & - & + vhacr(mgs) + vhacw(mgs) + vhfzh(mgs) & ! qhacw(mgs)/rimdn(mgs,lh) -! > + vhfrh(mgs) & - & + vhcni(mgs) + viacrf(mgs) + vrfrzf(mgs) -! > +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh) - -! pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh) - pvhwd(mgs) = rho0(mgs)*( & -! > qhshr(mgs)/xdn0(lr) & -! > - il5(mgs)*qhfzh(mgs)/xdn(mgs,lr) & - & +( (1-il5(mgs))*vhmlr(mgs) & -! > +il5(mgs)*qhsbv(mgs) & - & + qhsbv(mgs) & - & + Min(0.0, qhcev(mgs)) & - & -qhmul1(mgs) )/xdn(mgs,lh) ) & - & - vhlcnh(mgs) + vhshdr(mgs) - vhsoak(mgs) +! IF ( ipconc .ge. 2 ) THEN -! IF (mixedphase) THEN -! pvhwd(mgs) = pvhwd(mgs) -! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) -! ENDIF + vt = abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) - IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN + qhlacw(mgs) = 0.25*pi*ehlw(mgs)*cx(mgs,lhl)*qx(mgs,lc)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lc,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) - write(iunit,*) - write(iunit,*) 'Graupel at ',igs(mgs),kgs(mgs) -! - write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) - write(iunit,*) il5(mgs)*qiacrf(mgs) - write(iunit,*) il5(mgs)*qracif(mgs) - write(iunit,*) 'qhcns',qhcns(mgs) - write(iunit,*) 'qhcni',qhcni(mgs) - write(iunit,*) il5(mgs)*(qhdpv(mgs)) - write(iunit,*) 'qhacr ',qhacr(mgs) - write(iunit,*) 'qhacw', qhacw(mgs) - write(iunit,*) 'qhacs', qhacs(mgs) - write(iunit,*) 'qhaci', qhaci(mgs) - write(iunit,*) 'pqhwi = ',pqhwi(mgs) - write(iunit,*) - write(iunit,*) 'qhcev',qhcev(mgs) - write(iunit,*) - write(iunit,*) 'qhshr',qhshr(mgs) - write(iunit,*) 'qhmlr', (1-il5(mgs))*qhmlr(mgs) - write(iunit,*) 'qhsbv', qhsbv(mgs) - write(iunit,*) 'qhlcnh',-qhlcnh(mgs) - write(iunit,*) 'qhmul1',-qhmul1(mgs) - write(iunit,*) 'pqhwd = ', pqhwd(mgs) - write(iunit,*) - write(iunit,*) 'Volume' - write(iunit,*) - write(iunit,*) 'pvhwi',pvhwi(mgs) - write(iunit,*) 'vhcns', vhcns(mgs) - write(iunit,*) 'vhacr,vhacw',vhacr(mgs), vhacw(mgs) ! qhacw(mgs)/rimdn(mgs,lh) - write(iunit,*) 'vhcni',vhcni(mgs) - write(iunit,*) - write(iunit,*) 'pvhwd',pvhwd(mgs) - write(iunit,*) 'vhlcnh,vhshdr,vhsoak ', vhlcnh(mgs), vhshdr(mgs), vhsoak(mgs) - write(iunit,*) 'vhmlr', vhmlr(mgs) - write(iunit,*) -! write(iunit,*) -! write(iunit,*) -! write(iunit,*) - write(iunit,*) 'Concentration' - write(iunit,*) pchwi(mgs),pchwd(mgs) - write(iunit,*) crfrzf(mgs) - write(iunit,*) chcns(mgs) - write(iunit,*) ciacrf(mgs) + qhlacw(mgs) = Min( qhlacw(mgs), 0.5*qx(mgs,lc)/dtp ) - ENDIF + IF ( lvol(lhl) .gt. 1 ) THEN + IF ( temg(mgs) .lt. 273.15) THEN + rimdn(mgs,lhl) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,lhl,1)) & + & /(temg(mgs)-273.15))**(rimc2) + rimdn(mgs,lhl) = Min( Max( hldnmn, rimc3, rimdn(mgs,lhl) ), rimc4 ) + ELSE + rimdn(mgs,lhl) = 1000. + ENDIF - ENDDO + vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/rimdn(mgs,lhl) + + ENDIF + + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .gt. 0 ) THEN + rarx(mgs,lhl) = & + & qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl)) + ENDIF ENDIF -! -! -! + end do + qhlaci(:) = 0.0 + IF ( lhl .gt. 1 ) THEN + do mgs = 1,ngscnt + IF ( ehli(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 5 ) THEN + + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) + + qhlaci(mgs) = 0.25*pi*ehli(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,li,lhl)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da1(li)*xdia(mgs,li,3)**2 ) + qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) ) + ENDIF + ENDIF + end do + ENDIF ! -! Hail volume -! + qhlacs(:) = 0.0 IF ( lhl .gt. 1 ) THEN - IF ( lvol(lhl) .gt. 1 ) THEN - DO mgs = 1,ngscnt + do mgs = 1,ngscnt + IF ( ehls(mgs) .gt. 0.0) THEN + IF ( ipconc .ge. 5 ) THEN - pvhli(mgs) = rho0(mgs)*( & - & + ( il5(mgs)*qhldpv(mgs) & -! & + Max(0.0, qhlcev(mgs)) & -! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) ) & ! xdn0(ls) ) & - & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose - & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & - & + vhlcnhl(mgs) & - & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl) - - pvhld(mgs) = rho0(mgs)*( & - & +( qhlsbv(mgs) & - & + Min(0.0, qhlcev(mgs)) & - & -qhlmul1(mgs) )/xdn(mgs,lhl) ) & -! & + vhlmlr(mgs) & - & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & - & + vhlshdr(mgs) - vhlsoak(mgs) + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) + + qhlacs(mgs) = 0.25*pi*ehli(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,ls,lhl)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da1(ls)*xdia(mgs,ls,3)**2 ) + qhlacs(mgs) = Min( qhlacs(mgs), qsmxd(mgs) ) - ENDDO - + ENDIF ENDIF + end do ENDIF - if ( ndebug .ge. 1 ) then do mgs = 1,ngscnt -! - ptotal(mgs) = 0. - ptotal(mgs) = ptotal(mgs) & - & + pqwvi(mgs) + pqwvd(mgs) & - & + pqcwi(mgs) + pqcwd(mgs) & - & + pqcii(mgs) + pqcid(mgs) & - & + pqrwi(mgs) + pqrwd(mgs) & - & + pqswi(mgs) + pqswd(mgs) & - & + pqhwi(mgs) + pqhwd(mgs) & - & + pqhli(mgs) + pqhld(mgs) -! + qhlacr(mgs) = 0.0 + qhlacrmlr(mgs) = 0.0 + chlacr(mgs) = 0.0 + vhlacr(mgs) = 0.0 + IF ( lhl .gt. 1 .and. temg(mgs) .gt. tfr ) raindn(mgs,lhl) = 1000.0 - if ( ( (ndebug .ge. 1 ) .and. abs(ptotal(mgs)) .gt. eqtot ) & -! if ( ( abs(ptotal(mgs)) .gt. eqtot ) -! : .or. pqswi(mgs)*dtp .gt. 1.e-3 -! : .or. pqhwi(mgs)*dtp .gt. 1.e-3 -! : .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3 -! : .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7 -! : .or. dtp*(pcipi(mgs)+pcipd(mgs)) .gt. 1.e7 & - & .or. .not. (ptotal(mgs) .lt. 1.0 .and. & - & ptotal(mgs) .gt. -1.0) ) then - write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs, & - & kgs(mgs),ptotal(mgs) + IF ( lhl .gt. 1 .and. ehlr(mgs) .gt. 0.0 ) THEN + IF ( ipconc .ge. 3 ) THEN + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lr,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lr,1) ) - write(iunit,*) 't7: ', t7(igs(mgs),jgs,kgs(mgs)) - write(iunit,*) 'cci,ccw,crw,rdia: ',cx(mgs,li),cx(mgs,lc),cx(mgs,lr),0.5*xdia(mgs,lr,1) - write(iunit,*) 'qc,qi,qr : ',qx(mgs,lc),qx(mgs,li),qx(mgs,lr) - write(iunit,*) 'rmas, qrcalc : ',xmas(mgs,lr),xmas(mgs,lr)*cx(mgs,lr)/rho0(mgs) - write(iunit,*) 'vti,vtc,eiw,vtr: ',vtxbar(mgs,li,1),vtxbar(mgs,lc,1),eiw(mgs),vtxbar(mgs,lr,1) - write(iunit,*) 'cidia,cwdia,qcmxd: ', xdia(mgs,li,1),xdia(mgs,lc,1),qcmxd(mgs) - write(iunit,*) 'snow: ',qx(mgs,ls),cx(mgs,ls),swvent(mgs),vtxbar(mgs,ls,1),xdia(mgs,ls,1) - write(iunit,*) 'graupel: ',qx(mgs,lh),cx(mgs,lh),hwvent(mgs),vtxbar(mgs,lh,1),xdia(mgs,lh,1) - IF ( lhl .gt. 1 ) write(iunit,*) 'hail: ',qx(mgs,lhl),cx(mgs,lhl),hlvent(mgs),vtxbar(mgs,lhl,1),xdia(mgs,lhl,1) + qhlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*qx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab1lh(mgs,lr,lhl)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) +! IF ( qhacr(mgs) .gt. 0. .or. tmp .gt. 0.0 ) write(0,*) 'qhacr= ',qhacr(mgs),tmp +!! qhacr(mgs) = Min( qhacr(mgs), qrmxd(mgs) ) +!! chacr(mgs) = qhacr(mgs)*cx(mgs,lr)/qx(mgs,lr) +!! chacr(mgs) = min(chacr(mgs),crmxd(mgs)) + qhlacr(mgs) = Min( qhlacr(mgs), qxmxd(mgs,lr) ) - write(iunit,*) 'li: ',xdia(mgs,li,1),xdia(mgs,li,2),xmas(mgs,li),qx(mgs,li), & - & vtxbar(mgs,li,1) + + qhlacrmlr(mgs) = qhlacr(mgs) + IF ( temg(mgs) > tfr ) THEN + qhlacr(mgs) = 0.0 + ELSE + chlacr(mgs) = 0.25*pi*ehlr(mgs)*cx(mgs,lhl)*cx(mgs,lr)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,lr)*xdia(mgs,lhl,3)*xdia(mgs,lr,3) + & + & da0(lr)*xdia(mgs,lr,3)**2 ) + chlacr(mgs) = min(chlacr(mgs),crmxd(mgs)) + + IF ( lvol(lhl) .gt. 1 ) THEN + vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/raindn(mgs,lhl) + ENDIF + ENDIF + ENDIF + ENDIF + end do - write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr) - write(iunit,*) 'temcg = ', temcg(mgs) - write(iunit,*) pqwvi(mgs) ,pqwvd(mgs) - write(iunit,*) pqcwi(mgs) ,pqcwd(mgs) - write(iunit,*) pqcii(mgs) ,pqcid(mgs) - write(iunit,*) pqrwi(mgs) ,pqrwd(mgs) - write(iunit,*) pqswi(mgs) ,pqswd(mgs) - write(iunit,*) pqhwi(mgs) ,pqhwd(mgs) - write(iunit,*) pqhli(mgs) ,pqhld(mgs) - write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' -! -! print production terms -! - write(iunit,*) - write(iunit,*) 'Vapor' -! - write(iunit,*) -Min(0.0,qrcev(mgs)) - write(iunit,*) -il5(mgs)*qhsbv(mgs) - write(iunit,*) -il5(mgs)*qhlsbv(mgs) - write(iunit,*) -il5(mgs)*qssbv(mgs) - write(iunit,*) -il5(mgs)*qisbv(mgs) - write(iunit,*) 'pqwvi= ', pqwvi(mgs) - write(iunit,*) -Max(0.0,qrcev(mgs)) - write(iunit,*) -il5(mgs)*qiint(mgs) - write(iunit,*) -il5(mgs)*qhdpv(mgs) - write(iunit,*) -il5(mgs)*qhldpv(mgs) - write(iunit,*) -il5(mgs)*qsdpv(mgs) - write(iunit,*) -il5(mgs)*qidpv(mgs) - write(iunit,*) 'pqwvd = ', pqwvd(mgs) -! - write(iunit,*) - write(iunit,*) 'Cloud ice' -! - write(iunit,*) il5(mgs)*qicicnt(mgs) - write(iunit,*) il5(mgs)*qidpv(mgs) - write(iunit,*) il5(mgs)*qiacw(mgs) - write(iunit,*) il5(mgs)*qwfrz(mgs) - write(iunit,*) il5(mgs)*qwctfz(mgs) - write(iunit,*) il5(mgs)*qicichr(mgs) - write(iunit,*) qhmul1(mgs) - write(iunit,*) qhlmul1(mgs) - write(iunit,*) 'pqcii = ', pqcii(mgs) - write(iunit,*) -il5(mgs)*qscni(mgs) - write(iunit,*) -il5(mgs)*qscnvi(mgs) - write(iunit,*) -il5(mgs)*qraci(mgs) - write(iunit,*) -il5(mgs)*qsaci(mgs) - write(iunit,*) -il5(mgs)*qhaci(mgs) - write(iunit,*) -il5(mgs)*qhlaci(mgs) - write(iunit,*) il5(mgs)*qisbv(mgs) - write(iunit,*) (1.-il5(mgs))*qimlr(mgs) - write(iunit,*) -il5(mgs)*qhcni(mgs) - write(iunit,*) 'pqcid = ', pqcid(mgs) - write(iunit,*) ' Conc:' - write(iunit,*) pccii(mgs),pccid(mgs) - write(iunit,*) il5(mgs),cicint(mgs) - write(iunit,*) cwacii(mgs),cwfrzc(mgs),cwctfzc(mgs) - write(iunit,*) cicichr(mgs) - write(iunit,*) chmul1(mgs) - write(iunit,*) chlmul1(mgs) - write(iunit,*) csmul(mgs) ! ! ! ! - write(iunit,*) - write(iunit,*) 'Cloud water' +! if (ndebug .gt. 0 ) write(0,*) 'Collection: Cloud collects xxxxx' + + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx2' ! - write(iunit,*) 'pqcwi =', pqcwi(mgs) - write(iunit,*) -il5(mgs)*qiacw(mgs) - write(iunit,*) -il5(mgs)*qwfrzc(mgs) - write(iunit,*) -il5(mgs)*qwctfzc(mgs) -! write(iunit,*) -il5(mgs)*qwfrzp(mgs) -! write(iunit,*) -il5(mgs)*qwctfzp(mgs) - write(iunit,*) -il5(mgs)*qiihr(mgs) - write(iunit,*) -il5(mgs)*qicichr(mgs) - write(iunit,*) -il5(mgs)*qipiphr(mgs) - write(iunit,*) -qracw(mgs) - write(iunit,*) -qsacw(mgs) - write(iunit,*) -qrcnw(mgs) - write(iunit,*) -qhacw(mgs) - write(iunit,*) -qhlacw(mgs) - write(iunit,*) 'pqcwd = ', pqcwd(mgs) + do mgs = 1,ngscnt + qiacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN + vt = Sqrt((vtxbar(mgs,li,1)-vtxbar(mgs,lc,1))**2 + & + & 0.04*vtxbar(mgs,li,1)*vtxbar(mgs,lc,1) ) - write(iunit,*) - write(iunit,*) 'Concentration:' - write(iunit,*) -cautn(mgs) - write(iunit,*) -cracw(mgs) - write(iunit,*) -csacw(mgs) - write(iunit,*) -chacw(mgs) - write(iunit,*) -ciacw(mgs) - write(iunit,*) -cwfrzp(mgs) - write(iunit,*) -cwctfzp(mgs) - write(iunit,*) -cwfrzc(mgs) - write(iunit,*) -cwctfzc(mgs) - write(iunit,*) pccwd(mgs) + qiacw(mgs) = 0.25*pi*eiw(mgs)*cx(mgs,li)*qx(mgs,lc)*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1(li,lc)*xdia(mgs,li,3)*xdia(mgs,lc,3) + & + & da1(lc)*xdia(mgs,lc,3)**2 ) + + qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) ) + ENDIF + end do ! - write(iunit,*) - write(iunit,*) 'Rain ' ! - write(iunit,*) qracw(mgs) - write(iunit,*) qrcnw(mgs) - write(iunit,*) Max(0.0, qrcev(mgs)) - write(iunit,*) -(1-il5(mgs))*qhmlr(mgs) - write(iunit,*) -(1-il5(mgs))*qhlmlr(mgs) - write(iunit,*) -(1-il5(mgs))*qsmlr(mgs) - write(iunit,*) -(1-il5(mgs))*qimlr(mgs) - write(iunit,*) -qrshr(mgs) - write(iunit,*) 'pqrwi = ', pqrwi(mgs) - write(iunit,*) -qsshr(mgs) - write(iunit,*) -qhshr(mgs) - write(iunit,*) -qhlshr(mgs) - write(iunit,*) -il5(mgs)*qiacr(mgs),qiacr(mgs), qiacrf(mgs) - write(iunit,*) -il5(mgs)*qrfrz(mgs) - write(iunit,*) -qsacr(mgs) - write(iunit,*) -qhacr(mgs) - write(iunit,*) -qhlacr(mgs) - write(iunit,*) qrcev(mgs) - write(iunit,*) 'pqrwd = ', pqrwd(mgs) - write(iunit,*) 'fhw, fhlw = ',fhw(mgs),fhlw(mgs) - write(iunit,*) 'qrzfac = ', qrzfac(mgs) + if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8' ! + do mgs = 1,ngscnt + qiacr(mgs) = 0.0 + qiacrf(mgs) = 0.0 + qiacrs(mgs) = 0.0 + ciacrs(mgs) = 0.0 + ciacr(mgs) = 0.0 + ciacrf(mgs) = 0.0 + viacrf(mgs) = 0.0 + csplinter(mgs) = 0.0 + qsplinter(mgs) = 0.0 + csplinter2(mgs) = 0.0 + qsplinter2(mgs) = 0.0 + IF ( iacr .ge. 1 .and. eri(mgs) .gt. 0.0 & + & .and. temg(mgs) .le. 270.15 ) THEN + IF ( ipconc .ge. 3 ) THEN + ni = 0.0 + IF ( xdia(mgs,li,1) .ge. 10.e-6 ) THEN + ni = ni + cx(mgs,li)*Exp(- (40.e-6/xdia(mgs,li,1))**3 ) + ENDIF + IF ( imurain == 1 ) THEN ! gamma of diameter + IF ( iacrsize /= 4 ) THEN + IF ( iacrsize .eq. 1 ) THEN + ratio = 500.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 2 ) THEN + ratio = 300.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 3 ) THEN + ratio = 40.e-6/xdia(mgs,lr,1) + ELSEIF ( iacrsize .eq. 5 ) THEN + ratio = 150.e-6/xdia(mgs,lr,1) + ENDIF + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) + + ! interpolate along x, i.e., ratio + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha + + nr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr) + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qr = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr) + + ELSE ! iacrsize == 4 : use all + nr = cx(mgs,lr) + qr = qx(mgs,lr) + ENDIF + + vt = Sqrt((vtxbar(mgs,lr,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lr,1)*vtxbar(mgs,li,1) ) + + qiacr(mgs) = 0.25*pi*eri(mgs)*ni*qr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab1lh(mgs,lr,li)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da1(lr)*xdia(mgs,lr,3)**2 ) + + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + + + ciacr(mgs) = 0.25*pi*eri(mgs)*ni*nr*vt* & + & ( da0(li)*xdia(mgs,li,3)**2 + & + & dab0lh(mgs,lr,li)*xdia(mgs,lr,3)*xdia(mgs,li,3) + & + & da0(lr)*xdia(mgs,lr,3)**2 ) + + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) + +! write(iunit,*) 'qiacr: ',cx(mgs,lr),nr,qx(mgs,lr),qr,qiacr(mgs),ciacr(mgs) +! write(iunit,*) 'xdia r li = ',xdia(mgs,lr,3),xdia(mgs,li,3),xdia(mgs,lr,1),xdia(mgs,li,1) +! write(iunit,*) 'i,j,ratio = ',i,j,ciacrratio(i,j),qiacrratio(i,j) +! write(iunit,*) 'ni,ci = ',ni,cx(mgs,li),qx(mgs,li) + + ELSEIF ( imurain == 3 ) THEN ! gamma of volume +! Set nr to the number of drops greater than 40 microns. + arg = 1000.*xdia(mgs,lr,3) +! nr = cx(mgs,lr)*gaml02( arg ) +! IF ( iacr .eq. 1 ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( iacrsize .eq. 1 ) THEN + nr = cx(mgs,lr)*gaml02d500( arg ) ! number greater than 500 microns in diameter + ELSEIF ( iacrsize .eq. 2 .or. iacrsize .eq. 5 ) THEN + nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter + ELSEIF ( iacrsize .eq. 3 ) THEN + nr = cx(mgs,lr)*gaml02( arg ) ! number greater than 40 microns in diameter + ELSEIF ( iacrsize .eq. 4 ) THEN + nr = cx(mgs,lr) ! all raindrops + ENDIF + ELSE + nr = cx(mgs,lr)*gaml02( arg ) + ENDIF +! ELSEIF ( iacr .eq. 2 ) THEN +! nr = cx(mgs,lr)*gaml02d300( arg ) ! number greater than 300 microns in diameter +! ENDIF + IF ( ni .gt. 0.0 .and. nr .gt. 0.0 ) THEN + d0 = xdia(mgs,lr,3) + qiacr(mgs) = xdn(mgs,lr)*rhoinv(mgs)* & + & (0.217239*(0.522295*(d0**5) + & + & 49711.81*(d0**6) - & + & 1.673016e7*(d0**7)+ & + & 2.404471e9*(d0**8) - & + & 1.22872e11*(d0**9))*ni*nr) + qiacr(mgs) = Min( qrmxd(mgs), qiacr(mgs) ) + ciacr(mgs) = & + & (0.217239*(0.2301947*(d0**2) + & + & 15823.76*(d0**3) - & + & 4.167685e6*(d0**4) + & + & 4.920215e8*(d0**5) - & + & 2.133344e10*(d0**6))*ni*nr) + ciacr(mgs) = Min( crmxd(mgs), ciacr(mgs) ) +! ciacr(mgs) = qiacr(mgs)*cx(mgs,lr)/qx(mgs,lr) + ENDIF + ENDIF + IF ( iacr .eq. 1 .or. iacr .eq. 3 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vr1mm*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 2 ) THEN + ciacrf(mgs) = ciacr(mgs) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 4 ) THEN + ciacrf(mgs) = Min(ciacr(mgs), qiacr(mgs)/(1.0*vfrz*1000.0)*rho0(mgs) ) ! *rzxh(mgs) + ELSEIF ( iacr .eq. 5 ) THEN + ciacrf(mgs) = ciacr(mgs)*rzxh(mgs) + ENDIF +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*27.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) + ENDIF - write(iunit,*) - write(iunit,*) 'Rain concentration' - write(iunit,*) pcrwi(mgs) - write(iunit,*) crcnw(mgs) - write(iunit,*) 1-il5(mgs) - write(iunit,*) -chmlr(mgs),-csmlr(mgs) - write(iunit,*) -crshr(mgs) - write(iunit,*) pcrwd(mgs) - write(iunit,*) il5(mgs) - write(iunit,*) -ciacr(mgs),-crfrz(mgs) - write(iunit,*) -csacr(mgs),-chacr(mgs) - write(iunit,*) +crcev(mgs) - write(iunit,*) cracr(mgs) -! write(iunit,*) -il5(mgs)*ciracr(mgs) + + ELSE ! single-moment rain + qiacr(mgs) = & + & min( & + & ((0.25/gf4)*pi)*eri(mgs)*cx(mgs,li)*qx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,li,1)) & + & *( gf6*gf1*xdia(mgs,lr,2) & + & + 2.0*gf5*gf2*xdia(mgs,lr,1)*xdia(mgs,li,1) & + & + gf4*gf3*xdia(mgs,li,2) ) & + & , qrmxd(mgs)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then +! qiacr(mgs) = 0.0 +! ciacr(mgs) = 0.0 +! end if + IF ( ipconc .ge. 1 ) THEN + IF ( nsplinter .ge. 0 ) THEN + csplinter(mgs) = nsplinter*ciacr(mgs) + ELSE + csplinter(mgs) = -nsplinter*ciacrf(mgs) + ENDIF + qsplinter(mgs) = Min(0.1*qiacr(mgs), csplinter(mgs)*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + ENDIF + + frach = 1.0 + IF ( ibiggsnow == 2 .or. ibiggsnow == 3 ) THEN + IF ( ciacr(mgs) > qxmin(lh) ) THEN + xvfrz = rho0(mgs)*qiacr(mgs)/(ciacr(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) - write(iunit,*) - write(iunit,*) 'Snow' -! - write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs) - write(iunit,*) il5(mgs)*qsaci(mgs) - write(iunit,*) il5(mgs)*qrfrzs(mgs) - write(iunit,*) il5(mgs)*qsdpv(mgs) - write(iunit,*) qsacw(mgs) - write(iunit,*) qsacr(mgs) - write(iunit,*) 'pqswi = ',pqswi(mgs) - write(iunit,*) -qhcns(mgs) -! write(iunit,*) -qracs(mgs) - write(iunit,*) -qhacs(mgs) - write(iunit,*) -qhlacs(mgs) - write(iunit,*) (1-il5(mgs))*qsmlr(mgs) - write(iunit,*) qsshr(mgs) -! write(iunit,*) qsshrp(mgs) - write(iunit,*) il5(mgs)*(qssbv(mgs)) - write(iunit,*) 'pqswd = ', pqswd(mgs) -! -! - write(iunit,*) - write(iunit,*) 'Graupel' -! - write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) - write(iunit,*) il5(mgs)*qiacrf(mgs) - write(iunit,*) il5(mgs)*qracif(mgs) - write(iunit,*) qhcns(mgs) - write(iunit,*) qhcni(mgs) - write(iunit,*) il5(mgs)*(qhdpv(mgs)) - write(iunit,*) qhacr(mgs) - write(iunit,*) qhacw(mgs) - write(iunit,*) qhacs(mgs) - write(iunit,*) qhaci(mgs) - write(iunit,*) 'pqhwi = ',pqhwi(mgs) - write(iunit,*) - write(iunit,*) qhshr(mgs) - write(iunit,*) (1-il5(mgs))*qhmlr(mgs) - write(iunit,*) il5(mgs),qhsbv(mgs) - write(iunit,*) -qhlcnh(mgs) - write(iunit,*) -qhmul1(mgs) - write(iunit,*) 'pqhwd = ', pqhwd(mgs) - write(iunit,*) 'Concentration' - write(iunit,*) pchwi(mgs),pchwd(mgs) - write(iunit,*) crfrzf(mgs) - write(iunit,*) chcns(mgs) - write(iunit,*) ciacrf(mgs) + qiacrs(mgs) = (1.-frach)*qiacr(mgs) + ciacrs(mgs) = (1.-frach)*ciacr(mgs) ! *rzxh(mgs) + + ENDIF + ENDIF + qiacrf(mgs) = frach*qiacr(mgs) + ciacrf(mgs) = frach*ciacrf(mgs) + + IF ( lvol(lh) > 1 ) THEN + viacrf(mgs) = rho0(mgs)*qiacrf(mgs)/rhofrz + ENDIF + + end do ! - write(iunit,*) - write(iunit,*) 'Hail' -! - write(iunit,*) qhlcnh(mgs) - write(iunit,*) il5(mgs)*(qhldpv(mgs)) - write(iunit,*) qhlacr(mgs) - write(iunit,*) qhlacw(mgs) - write(iunit,*) qhlacs(mgs) - write(iunit,*) qhlaci(mgs) - write(iunit,*) pqhli(mgs) - write(iunit,*) - write(iunit,*) qhlshr(mgs) - write(iunit,*) (1-il5(mgs))*qhlmlr(mgs) - write(iunit,*) il5(mgs)*qhlsbv(mgs) - write(iunit,*) pqhld(mgs) - write(iunit,*) 'Concentration' - write(iunit,*) pchli(mgs),pchld(mgs) - write(iunit,*) chlcnh(mgs) -! -! Balance and checks for continuity.....within machine precision... ! ! - write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' - write(iunit,*) 'PTOTAL',ptotal(mgs) ! + +! snow aggregation here + if ( ipconc .ge. 4 .or. ipelec .ge. 100 ) then ! + do mgs = 1,ngscnt + csacs(mgs) = 0.0 + IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 .and. xv(mgs,ls) < 0.25*xvmx(ls) ) THEN + csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) + csacs(mgs) = min(csacs(mgs),csmxd(mgs)) + ENDIF + end do end if ! - end do ! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 11' + if ( ipconc .ge. 2 .or. ipelec .ge. 9 ) then + do mgs = 1,ngscnt + ciacw(mgs) = 0.0 + IF ( eiw(mgs) .gt. 0.0 ) THEN - end if ! ( nstep/12*12 .eq. nstep ) + ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc) + ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) + ENDIF + end do + end if -! -! latent heating from phase changes (except qcw, qci cond, and evap) -! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' + if ( ipconc .ge. 2 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt - IF ( warmonly < 0.5 ) THEN - pfrz(mgs) = & - & (1-il5(mgs))* & - & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & - & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) & - & +il5(mgs)*(1-imixedphase)*( & - & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & - & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & - & +qsshr(mgs) & - & +qhshr(mgs) & - & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) & - & ) & - & +il5(mgs)*(qwfrz(mgs) & - & +qwctfz(mgs)+qiihr(mgs) & - & +qiacw(mgs)) - pmlt(mgs) = & - & (1-il5(mgs))* & - & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) - psub(mgs) = & - & il5(mgs)*( & - & + qsdpv(mgs) + qhdpv(mgs) & - & + qhldpv(mgs) & - & + qidpv(mgs) + qisbv(mgs) ) & - & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) & - & +il5(mgs)*(qiint(mgs)) - pvap(mgs) = & - & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) - pevap(mgs) = & - & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) - pdep(mgs) = & - & il5(mgs)*( & - & + qsdpv(mgs) + qhdpv(mgs) & - & + qhldpv(mgs) & - & + qidpv(mgs) ) & - & +il5(mgs)*(qiint(mgs)) - ELSEIF ( warmonly < 0.8 ) THEN - pfrz(mgs) = & - & (1-il5(mgs))* & - & (qhmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & - & +il5(mgs)*(qhfzh(mgs)+qhlfzhl(mgs)) & - & +il5(mgs)*( & - & +qhshr(mgs) & - & +qhlshr(mgs) & - & +qrfrz(mgs)+qwfrz(mgs) & - & +qwctfz(mgs)+qiihr(mgs) & - & +qiacw(mgs) & - & +qhacw(mgs) + qhlacw(mgs) & - & +qhacr(mgs) + qhlacr(mgs) ) - psub(mgs) = 0.0 + & - & il5(mgs)*( & - & + qhdpv(mgs) & - & + qhldpv(mgs) & - & + qidpv(mgs) + qisbv(mgs) ) & - & +il5(mgs)*(qiint(mgs)) - pvap(mgs) = & - & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) - ELSE - pfrz(mgs) = 0.0 - psub(mgs) = 0.0 - pvap(mgs) = qrcev(mgs) - ENDIF ! warmonly - ptem(mgs) = & - & (1./pi0(mgs))* & - & (felfcp(mgs)*pfrz(mgs) & - & +felscp(mgs)*psub(mgs) & - & +felvcp(mgs)*pvap(mgs)) - thetap(mgs) = thetap(mgs) + dtp*ptem(mgs) - end do - + cracw(mgs) = 0.0 + cracr(mgs) = 0.0 + ec0(mgs) = 1.e9 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) & + & .and. qracw(mgs) .gt. 0.0 ) THEN + IF ( ipconc .lt. 3 ) THEN + IF ( erw(mgs) .gt. 0.0 ) THEN + cracw(mgs) = & + & ((0.25)*pi)*erw(mgs)*cx(mgs,lc)*cx(mgs,lr) & + & *abs(vtxbar(mgs,lr,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lr,1) & + & + gf3*xdia(mgs,lr,2) ) + ENDIF + ELSE ! IF ( ipconc .ge. 3 .and. + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN !{ + IF ( 0.5*xdia(mgs,lr,3) .gt. rh(mgs) ) THEN ! { .or. cx(mgs,lr) .gt. nh(mgs) +! IF ( qx(mgs,lc) .gt. qxmin(lc) .and. qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( 0.5*xdia(mgs,lr,3) .gt. rwradmn ) THEN ! r > 50.e-6 +! DM0CCC=A2*XNC*XNR*(XVC+XVR) ! (A11) +! NOTE: murain drops out, so same result for imurain = 1 and 3 + cracw(mgs) = aa2*cx(mgs,lr)*cx(mgs,lc)*(xv(mgs,lc) + xv(mgs,lr)) + ELSE + IF ( imurain == 3 ) THEN +! DM0CCC=A1*XNC*XNR*(((CNU+2.)/(CNU+1.))*XVC**2+((RNU+2.)/(RNU+1.))*XVR**2) ! (A13) + cracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)* & + & ((cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.) + & + & (alpha(mgs,lr) + 2.)*xv(mgs,lr)**2/(alpha(mgs,lr) + 1.)) + ELSE ! imurain == 1 USE CP00 for rain DSD in diameter + cracw(mgs) = aa1*cx(mgs,lr)*cx(mgs,lc)* & + & ((cnu + 2.)*xv(mgs,lc)**2/(cnu + 1.) + & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)*xv(mgs,lr)**2/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) ) + ENDIF ! imurain + ENDIF + ENDIF ! } rh + ENDIF ! } dmrauto + ENDIF ! ipconc + ENDIF ! qc > qcmin & qr > qrmin + +! Rain self collection (cracr) and break-up (factor of ec0) +! +! + ec0(mgs) = 2.e9 + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + rwrad = 0.5*xdia(mgs,lr,3) + IF ( xdia(mgs,lr,3) .gt. 2.0e-3 ) THEN + ec0(mgs) = 0.0 + cracr(mgs) = 0.0 + ELSE + IF ( dmrauto <= 0 .or. rho0(mgs)*qx(mgs,lr) > 1.2*xl2p(mgs) ) THEN + IF ( xdia(mgs,lr,3) .lt. 6.1e-4 ) THEN + ec0(mgs) = 1.0 + ELSE + ec0(mgs) = Exp(-50.0*(50.0*(xdia(mgs,lr,3) - 6.0e-4))) + ENDIF + + IF ( rwrad .ge. 50.e-6 ) THEN + cracr(mgs) = ec0(mgs)*aa2*cx(mgs,lr)**2*xv(mgs,lr) + ELSE + IF ( imurain == 3 ) THEN + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 2.)/(alpha(mgs,lr) + 1.) + ELSE ! imurain == 1 + cracr(mgs) = ec0(mgs)*aa1*(cx(mgs,lr)*xv(mgs,lr))**2* & + & (alpha(mgs,lr) + 6.)*(alpha(mgs,lr) + 5.)*(alpha(mgs,lr) + 4.)/ & + & ((alpha(mgs,lr) + 3.)*(alpha(mgs,lr) + 2.)*(alpha(mgs,lr) + 1.)) + + ENDIF + ENDIF +! cracr(mgs) = Min(cracr(mgs),crmxd(mgs)) + ENDIF + ENDIF + ENDIF +! cracw(mgs) = min(cracw(mgs),ccmxd(mgs)) + end do + end if +! ! -! sum the sources and sinks for qwvp, qcw, qci, qrw, qsw ! +! Graupel ! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt - qwvp(mgs) = qwvp(mgs) + & - & dtp*(pqwvi(mgs)+pqwvd(mgs)) - qx(mgs,lc) = qx(mgs,lc) + & - & dtp*(pqcwi(mgs)+pqcwd(mgs)) -! IF ( qx(mgs,lr) .gt. 10.0e-3 ) THEN -! write(0,*) 'RAIN1a: ',igs(mgs),kgs(mgs),qx(mgs,lr) -! ENDIF - qx(mgs,lr) = qx(mgs,lr) + & - & dtp*(pqrwi(mgs)+pqrwd(mgs)) -! IF ( qx(mgs,lr) .gt. 10.0e-3 ) THEN -! write(0,*) 'RAIN1b: ',igs(mgs),kgs(mgs),qx(mgs,lr) -! write(0,*) pqrwi(mgs),pqrwd(mgs) -! ENDIF - qx(mgs,li) = qx(mgs,li) + & - & dtp*(pqcii(mgs)+pqcid(mgs)) - qx(mgs,ls) = qx(mgs,ls) + & - & dtp*(pqswi(mgs)+pqswd(mgs)) - qx(mgs,lh) = qx(mgs,lh) + & - & dtp*(pqhwi(mgs)+pqhwd(mgs)) - IF ( lhl .gt. 1 ) THEN - qx(mgs,lhl) = qx(mgs,lhl) + & - & dtp*(pqhli(mgs)+pqhld(mgs)) -! IF ( pqhli(mgs) .gt. 1.e-8 ) write(0,*) ' pqhli,qx(lhl) = ',pqhli(mgs),qx(mgs,lhl) - ENDIF - - - end do - -! sum sources for particle volume - IF ( ldovol ) THEN + IF ( ipconc .ge. 5 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN - do mgs = 1,ngscnt +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chacw(mgs) = (ehw(mgs)*cx(mgs,lc)*cx(mgs,lh)*(pi/4.)* +! : abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lh,1)*(xdia(mgs,lh,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) - IF ( lvol(ls) .gt. 1 ) THEN - vx(mgs,ls) = vx(mgs,ls) + & - & dtp*(pvswi(mgs)+pvswd(mgs)) - ENDIF +! chacw(mgs) = Min( chacw(mgs), 0.6*cx(mgs,lc)/dtp ) - IF ( lvol(lh) .gt. 1 ) THEN - vx(mgs,lh) = vx(mgs,lh) + & - & dtp*(pvhwi(mgs)+pvhwd(mgs)) -! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) +! chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chacw(mgs) = qhacw(mgs)*rho0(mgs)/xmascw(mgs) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) + chacw(mgs) = Min( chacw(mgs), 0.5*cx(mgs,lc)/dtp ) + ELSE + qhacw(mgs) = 0.0 + ENDIF + ELSE + chacw(mgs) = & + & ((0.25)*pi)*ehw(mgs)*cx(mgs,lc)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,lc,1)) & + & *( gf1*xdia(mgs,lc,2) & + & + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + chacw(mgs) = min(chacw(mgs),0.5*cx(mgs,lc)/dtp) +! chacw(mgs) = min(chacw(mgs),cxmxd(mgs,lc)) +! chacw(mgs) = min(chacw(mgs),ccmxd(mgs)) ENDIF + end do + end if +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chaci(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( ehi(mgs) .gt. 0.0 .or. ( ehiclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN + IF ( ipconc .ge. 5 ) THEN - IF ( lhl .gt. 1 ) THEN - IF ( lvol(lhl) .gt. 1 ) THEN - vx(mgs,lhl) = vx(mgs,lhl) + & - & dtp*(pvhli(mgs)+pvhld(mgs)) -! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) - ENDIF - ENDIF + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,li,1) ) - ENDDO + chaci0(mgs) = 0.25*pi*ehiclsn(mgs)*cx(mgs,lh)*cx(mgs,li)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,li,lh)*xdia(mgs,lh,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) - ENDIF ! ldovol + ELSE + chaci0(mgs) = & + & ((0.25)*pi)*ehiclsn(mgs)*cx(mgs,li)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,li,1)) & + & *( gf1*xdia(mgs,li,2) & + & + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lh,1) & + & + gf3*xdia(mgs,lh,2) ) + ENDIF + chaci(mgs) = min(ehi(mgs)*chaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if ! ! -! -! concentrations -! - if ( ipconc .ge. 1 ) then + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn' + chacs(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt - cx(mgs,li) = cx(mgs,li) + & - & dtp*(pccii(mgs)+pccid(mgs)) - IF ( ipconc .ge. 2 ) THEN - cx(mgs,lc) = cx(mgs,lc) + & - & dtp*(pccwi(mgs)+pccwd(mgs)) - ENDIF - IF ( ipconc .ge. 3 ) THEN - cx(mgs,lr) = cx(mgs,lr) + & - & dtp*(pcrwi(mgs)+pcrwd(mgs)) - ENDIF - IF ( ipconc .ge. 4 ) THEN - cx(mgs,ls) = cx(mgs,ls) + & - & dtp*(pcswi(mgs)+pcswd(mgs)) + IF ( ehs(mgs) .gt. 0 ) THEN + IF ( ipconc .ge. 5 .or. ( ehsclsn(mgs) > 0.0 .and. ipelec > 0 ) ) THEN + + vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,ls,1) ) + + chacs0(mgs) = 0.25*pi*ehsclsn(mgs)*cx(mgs,lh)*cx(mgs,ls)*vt* & + & ( da0lh(mgs)*xdia(mgs,lh,3)**2 + & + & dab0lh(mgs,ls,lh)*xdia(mgs,lh,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) + + ELSE + chacs0(mgs) = & + & ((0.25)*pi)*ehsclsn(mgs)*cx(mgs,ls)*cx(mgs,lh) & + & *abs(vtxbar(mgs,lh,1)-vtxbar(mgs,ls,1)) & + & *( gf3*gf1*xdia(mgs,ls,2) & + & + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lh,1) & + & + gf1*gf3*xdia(mgs,lh,2) ) ENDIF - IF ( ipconc .ge. 5 ) THEN - cx(mgs,lh) = cx(mgs,lh) + & - & dtp*(pchwi(mgs)+pchwd(mgs)) - IF ( lhl .gt. 1 ) THEN - cx(mgs,lhl) = cx(mgs,lhl) + & - & dtp*(pchli(mgs)+pchld(mgs)) -! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN -! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) -! ENDIF - ENDIF + chacs(mgs) = min(ehs(mgs)*chacs0(mgs),csmxd(mgs)) ENDIF end do end if + + ! ! +! Hail ! -! start saturation adjustment -! - if (ndebug .gt. 0 ) write(0,*) 'conc 30a' -! include 'sam.jms.satadj.sgi' -! -! -! -! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) -! -! -! -! set up temperature and vapor arrays -! - do mgs = 1,ngscnt - pqs(mgs) = (380.0)/(pres(mgs)) - theta(mgs) = thetap(mgs) + theta0(mgs) - qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) - temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap - end do -! -! melting of cloud ice -! - do mgs = 1,ngscnt - qcwtmp(mgs) = qx(mgs,lc) - ptimlw(mgs) = 0.0 - end do -! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22ii' + chlacw(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt - qitmp(mgs) = qx(mgs,li) - if( temg(mgs) .gt. tfr .and. & - & qitmp(mgs) .gt. 0.0 ) then - qx(mgs,lc) = qx(mgs,lc) + qitmp(mgs) -! pfrz(mgs) = pfrz(mgs) - qitmp(mgs)/dtp - ptem(mgs) = ptem(mgs) + & - & (1./pi0(mgs))* & - & felfcp(mgs)*(- qitmp(mgs)/dtp) - pmlt(mgs) = pmlt(mgs) - qitmp(mgs)/dtp - scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li) - thetap(mgs) = thetap(mgs) - & - & fcc3(mgs)*qitmp(mgs) - ptimlw(mgs) = -fcc3(mgs)*qitmp(mgs)/dtp - cx(mgs,lc) = cx(mgs,lc) + cx(mgs,li) - qx(mgs,li) = 0.0 - cx(mgs,li) = 0.0 - scx(mgs,li) = 0.0 - vx(mgs,li) = 0.0 - qitmp(mgs) = 0.0 - end if - end do -! -! + IF ( lhl .gt. 1 .and. ipconc .ge. 5 ) THEN + IF ( qhlacw(mgs) .gt. 0.0 .and. xmas(mgs,lc) .gt. 0.0 ) THEN -! do mgs = 1,ngscnt -! qimlw(mgs) = (qcwtmp(mgs)-qx(mgs,lc))/dtp -! end do -! -! homogeneous freezing of cloud water -! - IF ( warmonly < 0.8 ) THEN +! This is the explict version of chacw, which turns out to be very close to the +! approximation that the droplet size does not change, to within a few percent. +! This may _not_ be the case for cnu other than zero! +! chlacw(mgs) = (ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl)*(pi/4.)* +! : abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1))* +! : (2.0*xdia(mgs,lhl,1)*(xdia(mgs,lhl,1) + +! : xdia(mgs,lc,1)*gf43rds) + +! : xdia(mgs,lc,2)*gf53rds)) - do mgs = 1,ngscnt - qcwtmp(mgs) = qx(mgs,lc) - ptwfzi(mgs) = 0.0 +! chlacw(mgs) = Min( chlacw(mgs), 0.6*cx(mgs,lc)/dtp ) + +! chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmas(mgs,lc) + chlacw(mgs) = qhlacw(mgs)*rho0(mgs)/xmascw(mgs) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) + chlacw(mgs) = Min( chlacw(mgs), 0.5*cx(mgs,lc)/dtp ) + ELSE + qhlacw(mgs) = 0.0 + ENDIF +! ELSE +! chlacw(mgs) = +! > ((0.25)*pi)*ehlw(mgs)*cx(mgs,lc)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,lc,1)) +! > *( gf1*xdia(mgs,lc,2) +! > + 2.0*gf2*xdia(mgs,lc,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) +! chlacw(mgs) = min(chlacw(mgs),0.5*cx(mgs,lc)/dtp) +! chlacw(mgs) = min(chlacw(mgs),cxmxd(mgs,lc)) +! chlacw(mgs) = min(chlacw(mgs),ccmxd(mgs)) + ENDIF end do + end if ! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk' + chlaci(:) = 0.0 + chlaci0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehli(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehliclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN -! if( temg(mgs) .lt. tfrh ) THEN -! write(0,*) 'GS: mgs,temp,qc,qi = ',mgs,temg(mgs),temcg(mgs),qx(mgs,lc),qx(mgs,li) -! ENDIF - - ctmp = 0.0 - frac = 0.0 - qtmp = 0.0 - -! if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and. & -! & qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then - if( temg(mgs) .lt. thnuc + 0. .and. & - & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) - IF ( ibfc /= 2 .or. ipconc < 2 ) THEN - frac = Max( 0.25, Min( 1., ((thnuc + 2.) - temg(mgs) )/4.0 ) ) - ELSE - volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 - ! for mean temperature for freezing: -ln (V) = a*Ts - b - ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 - - cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc)) ! number of droplets with volume greater than volt + chlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*cx(mgs,li)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,li)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & + & da0(li)*xdia(mgs,li,3)**2 ) - qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) - frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes - ! sure that cwfrz and qwfrz are consistent and prevents - ! spurious creation of ice crystals. - - ENDIF - qtmp = frac*qx(mgs,lc) +! ELSE +! chlaci(mgs) = +! > ((0.25)*pi)*ehli(mgs)*cx(mgs,li)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1)) +! > *( gf1*xdia(mgs,li,2) +! > + 2.0*gf2*xdia(mgs,li,1)*xdia(mgs,lhl,1) +! > + gf3*xdia(mgs,lhl,2) ) + ENDIF - qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc) - pfrz(mgs) = pfrz(mgs) + qtmp/dtp - ptem(mgs) = ptem(mgs) + & - & (1./pi0(mgs))* & - & felfcp(mgs)*(qtmp/dtp) -! IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qx(mgs,lc)/xdn0(li) - IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li) + chlaci(mgs) = min(ehli(mgs)*chlaci0(mgs),cimxd(mgs)) + ENDIF + end do + end if +! +! + if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj' + chlacs(:) = 0.0 + chlacs0(:) = 0.0 + if ( ipconc .ge. 1 .or. ipelec .ge. 1 ) then + do mgs = 1,ngscnt + IF ( lhl .gt. 1 .and. ( ehls(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlsclsn(mgs) > 0.0) ) ) THEN + IF ( ipconc .ge. 5 ) THEN - IF ( ipconc .ge. 2 ) THEN - ctmp = frac*cx(mgs,lc) -! cx(mgs,li) = cx(mgs,li) + cx(mgs,lc) - cx(mgs,li) = cx(mgs,li) + ctmp - ELSE ! (ipconc .lt. 2 ) - ctmp = 0.0 - IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN - qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1) + vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & + & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) -! cx(mgs,lc) = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp - ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp - ELSE - cx(mgs,lc) = Max(0.0,wvel(mgs))*dtp*cwccn & - & /gz(igs(mgs),jgs,kgs(mgs)) - cx(mgs,lc) = cwccn - ENDIF + chlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*cx(mgs,ls)*vt* & + & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & + & dab0(lhl,ls)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & + & da0(ls)*xdia(mgs,ls,3)**2 ) - IF ( ipconc .ge. 1 ) cx(mgs,li) = Min(ccimx, cx(mgs,li) + cx(mgs,lc)) +! ELSE +! chlacs(mgs) = +! > ((0.25)*pi)*ehls(mgs)*cx(mgs,ls)*cx(mgs,lhl) +! > *abs(vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1)) +! > *( gf3*gf1*xdia(mgs,ls,2) +! > + 2.0*gf2*gf2*xdia(mgs,ls,1)*xdia(mgs,lhl,1) +! > + gf1*gf3*xdia(mgs,lhl,2) ) + ENDIF + chlacs(mgs) = min(ehls(mgs)*chlacs0(mgs),csmxd(mgs)) ENDIF - - sctmp = frac*scx(mgs,lc) -! scx(mgs,li) = scx(mgs,li) + scx(mgs,lc) - scx(mgs,li) = scx(mgs,li) + sctmp -! thetap(mgs) = thetap(mgs) + fcc3(mgs)*qx(mgs,lc) -! ptwfzi(mgs) = fcc3(mgs)*qx(mgs,lc)/dtp -! qx(mgs,lc) = 0.0 -! cx(mgs,lc) = 0.0 -! scx(mgs,lc) = 0.0 - thetap(mgs) = thetap(mgs) + fcc3(mgs)*qtmp - ptwfzi(mgs) = fcc3(mgs)*qtmp/dtp - qx(mgs,lc) = qx(mgs,lc) - qtmp - cx(mgs,lc) = cx(mgs,lc) - ctmp - scx(mgs,lc) = scx(mgs,lc) - sctmp - end if end do + end if - ENDIF ! warmonly ! -! do mgs = 1,ngscnt -! qwfzi(mgs) = (qcwtmp(mgs)-qx(mgs,lc))/dtp ! Not used?? (ERM) -! end do +! Ziegler (1985) autoconversion ! -! reset temporaries for cloud particles and vapor ! - qcond(:) = 0.0 + IF ( ipconc .ge. 2 .and. ircnw /= -1) THEN ! DTD: added flag for autoconversion. If -1, turns off autoconversion + if (ndebug .gt. 0 ) write(0,*) 'conc 26a' - IF ( ipconc .le. 1 .and. lwsm6 ) THEN ! Explicit cloud condensation/evaporation (Rutledge and Hobbs 1983) - DO mgs = 1,ngscnt - - qcwtmp(mgs) = qx(mgs,lc) - theta(mgs) = thetap(mgs) + theta0(mgs) - temgtmp = temg(mgs) -! temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap -! temsav = temg(mgs) -! thsave(mgs) = thetap(mgs) - temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap - temcg(mgs) = temg(mgs) - tfr - ltemq = (temg(mgs)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) + DO mgs = 1,ngscnt + zrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + crcnw(mgs) = 0.0 + cautn(mgs) = 0.0 + ENDDO + + DO mgs = 1,ngscnt +! qracw(mgs) = 0.0 +! cracw(mgs) = 0.0 + IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1000. .and. temg(mgs) .gt. tfrh+4.) THEN + ! .and. w(igs(mgs),jgs,kgs(mgs)) > 5.0) THEN ! DTD: added w threshold for testing + volb = xv(mgs,lc)*(1./(1.+CNU))**(1./2.) + cautn(mgs) = Min(ccmxd(mgs), & + & ((CNU+2.)/(CNU+1.))*aa1*cx(mgs,lc)**2*xv(mgs,lc)**2) + cautn(mgs) = Max( 0.0d0, cautn(mgs) ) + IF ( rb(mgs) .le. 7.51d-6 ) THEN + t2s = 1.d30 +! cautn(mgs) = 0.0 + ELSE +! XL2P=2.7E-2*XNC*XVC*((1.E12*RB**3*RC)-0.4) + +! T2S=3.72E-3/(((1.E4*RB)-7.5)*XNC*XVC) +! t2s = 3.72E-3/(((1.e6*rb)-7.5)*cx(mgs,lc)*xv(mgs,lc)) +! t2s = 3.72/(((1.e6*rb(mgs))-7.5)*rho0(mgs)*qx(mgs,lc)) + t2s = 3.72/(1.e6*(rb(mgs)-7.500d-6)*rho0(mgs)*qx(mgs,lc)) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qrcnw(mgs) = Max( 0.0d0, xl2p(mgs)/(t2s*rho0(mgs)) ) + crcnw(mgs) = Max( 0.0d0, Min(3.5e9*xl2p(mgs)/t2s,0.5*cautn(mgs)) ) + + IF ( dmrauto == 0 ) THEN + IF ( qx(mgs,lr)*rho0(mgs) > 1.2*xl2p(mgs) .and. cx(mgs,lr) > cxmin ) THEN ! Cohard and Pinty (2000a) switch over from (18) to (19) + crcnw(mgs) = cx(mgs,lr)/qx(mgs,lr)*qrcnw(mgs) + ENDIF + ELSEIF ( dmrauto == 1 .and. cx(mgs,lr) > cxmin) THEN + IF ( qx(mgs,lr) > qxmin(lr) ) THEN + tmp = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + crcnw(mgs) = Min(tmp,crcnw(mgs) ) + ENDIF + ELSEIF ( dmrauto == 2 .and. cx(mgs,lr) > cxmin) THEN + tmp = crcnw(mgs) + tmp2 = qrcnw(mgs)*cx(mgs,lr)/qx(mgs,lr) + ! try mass-weighted average of old and new Dmr + crcnw(mgs) = (tmp*qrcnw(mgs)+tmp2*qx(mgs,lr))/(qrcnw(mgs)+qx(mgs,lr)) + ELSEIF ( dmrauto == 3 .and. cx(mgs,lr) > cxmin) THEN ! adapted from MY/CP code + tmp = Max( 2.d0*rh(mgs), dble( xdia(mgs,lr,3) ) ) + crcnw(mgs) = rho0(mgs)*qrcnw(mgs)/(pi/6.*1000.*tmp**3) + ENDIF + + IF ( crcnw(mgs) < 1.e-30 ) qrcnw(mgs) = 0.0 - IF ( ( qwvp(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN - tmp = (qwvp(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) ) - qcond(mgs) = Min( Max( 0.0, tmp ), (qwvp(mgs)-qvs(mgs)) ) - IF ( qx(mgs,lc) > qxmin(lc) .and. tmp < 0.0 ) THEN ! evaporation - qcond(mgs) = Max( tmp, -qx(mgs,lc) ) - ENDIF - qwvp(mgs) = qwvp(mgs) - qcond(mgs) - qx(mgs,lc) = Max( 0.0, qx(mgs,lc) + qcond(mgs) ) - thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs)) - - ENDIF - - ENDDO - - ENDIF - - - IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN -! IF ( ipconc .le. 1 ) THEN - +! IF ( crcnw(mgs) .gt. cautn(mgs) .and. crcnw(mgs) .gt. 1.0 ) +! : THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s,qx(mgs,lr) +! write(0,*) ' ',qx(mgs,lc),cx(mgs,lc),0.5e6*xdia(mgs,lc,1) +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3/(4.*pi))*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.),rh(mgs)*1.e6,rwrad(mgs) +! ELSEIF ( crcnw(mgs) .gt. 1.0 .and. cautn(mgs) .gt. 0.) THEN +! write(0,*) 'crcnw,cautn ',crcnw(mgs)/cautn(mgs), +! : crcnw(mgs),cautn(mgs),igs(mgs),kgs(mgs),t2s +! write(0,*) ' ',rho0(mgs)*qrcnw(mgs)/crcnw(mgs), +! : 1.e6*(( 3*pi/4.)*rho0(mgs)*qrcnw(mgs)/ +! : (crcnw(mgs)*xdn(mgs,lr)))**(1./3.) +! ENDIF +! crcnw(mgs) = Min(cautn(mgs),3.5e9*xl2p(mgs)/t2s) + +! IF ( qrcnw(mgs) .gt. 0.3e-2 ) THEN +! write(0,*) 'QRCNW' +! write(0,*) qrcnw(mgs),crcnw(mgs),cautn(mgs) +! write(0,*) xl2p,t2s,rho0(mgs),xv(mgs,lc),cx(mgs,lc),qx(mgs,lc) +! write(0,*) rb,0.5*xdia(mgs,lc,1),mgs,igs(mgs),kgs(mgs) +! ENDIF +! qrcnw(mgs) = Min(qrcnw(mgs),qcmxd(mgs)) + ENDIF + + + ENDIF + ENDDO + + + + ELSE + +! +! Berry 1968 auto conversion for rain (Orville & Kopp 1977) +! +! + if ( ircnw .eq. 4 ) then do mgs = 1,ngscnt - qx(mgs,lv) = max( 0.0, qvap(mgs) ) - qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) - qx(mgs,li) = max( 0.0, qx(mgs,li) ) - qitmp(mgs) = qx(mgs,li) +! sconvmix(lcw,mgs) = 0.0 + qrcnw(mgs) = 0.0 + qdiff = max((qx(mgs,lc)-qminrncw),0.0) + if ( qdiff .gt. 0.0 .and. xdia(mgs,lc,1) .gt. 20.0e-6 ) then + argrcnw = & + & ((1.2e-4)+(1.596e-12)*(cx(mgs,lc)*1.0e-6) & + & /(cwdisp*qdiff*1.0e-3*rho0(mgs))) + qrcnw(mgs) = (rho0(mgs)*1e-3)*(qdiff**2)/argrcnw +! sconvmix(lcw,mgs) = max(sconvmix(lcw,mgs),0.0) + qrcnw(mgs) = (max(qrcnw(mgs),0.0)) + end if end do + + ENDIF +! +! +! +! Berry 1968 auto conversion for rain (Ferrier 1994) ! ! + if ( ircnw .eq. 5 ) then do mgs = 1,ngscnt - qcwtmp(mgs) = qx(mgs,lc) - qitmp(mgs) = qx(mgs,li) - theta(mgs) = thetap(mgs) + theta0(mgs) - temgtmp = temg(mgs) - temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap - temsav = temg(mgs) - thsave(mgs) = thetap(mgs) - temcg(mgs) = temg(mgs) - tfr - tqvcon = temg(mgs)-cbw - ltemq = (temg(mgs)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) -! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN -! C$PAR CRITICAL SECTION -! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs), -! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs), -! : ltemq,igs(mgs),jy,kgs(mgs) -! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt), -! : ab(igs(mgs),jy,kgs(mgs),lt), -! : t0(igs(mgs),jy,kgs(mgs)) -! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs) -! STOP -! C$PAR END CRITICAL SECTION -! END IF - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - qis(mgs) = pqs(mgs)*tabqis(ltemq) -! qss(kz) = qvs(kz) -! if ( temg(kz) .lt. tfr ) then -! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = qis(kz) -! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) -! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / -! > (qcw(kz) + qci(kz)) -! qss(kz) = qis(kz) -! end if -! dont get enough condensation with qcw .le./.gt. qxmin(lc) -! if ( temg(mgs) .lt. tfr ) then -! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) -! > qss(mgs) = qvs(mgs) -! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = qis(mgs) -! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / -! > (qx(mgs,lc) + qitmp(mgs)) -! else -! qss(mgs) = qvs(mgs) -! end if - qss(mgs) = qvs(mgs) - if ( temg(mgs) .lt. tfr ) then - if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & - & qss(mgs) = qvs(mgs) - if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & - & qss(mgs) = qis(mgs) - if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & - & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & - & (qx(mgs,lc) + qitmp(mgs)) + qrcnw(mgs) = 0.0 + qrcnw(mgs) = 0.0 + qccrit = (pi/6.)*(cx(mgs,lc)*cwdiap**3)*xdn(mgs,lc)/rho0(mgs) + qdiff = max((qx(mgs,lc)-qccrit),0.) + if ( qdiff .gt. 0.0 .and. cx(mgs,lc) .gt. 1.0 ) then + argrcnw = & +! > ((1.2e-4)+(1.596e-12)*cx(mgs,lc)/(cwdisp*rho0(mgs)*qdiff)) & + & ((1.2e-4)+(1.596e-12)*cx(mgs,lc)*1.0e-3/(cwdisp*rho0(mgs)*qdiff)) + qrcnw(mgs) = & +! > timflg(mgs)*rho0(mgs)*(qdiff**2)/argrcnw & + & 1.0e-3*rho0(mgs)*(qdiff**2)/argrcnw + qrcnw(mgs) = Min(qxmxd(mgs,lc), (max(qrcnw(mgs),0.0)) ) + +! write(iunit,*) 'qrcnw,cx =',qrcnw(mgs),cx(mgs,lc),mgs,1.e3*qx(mgs,lc),cno(lr) end if end do + end if + ! -! iterate adjustment ! - do itertd = 1,2 +! kessler auto conversion for rain. ! + if ( ircnw .eq. 2 ) then do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + qrcnw(mgs) = (0.001)*max((qx(mgs,lc)-qminrncw),0.0) + end do + end if ! -! calculate super-saturation +! c4 = pi/6 +! c1 = 0.12-0.32 for colorado storms...typically 0.3-0.4 +! berry reinhart type conversion (proctor 1988) ! - qitmp(mgs) = qx(mgs,li) - fcci(mgs) = 0.0 - fcip(mgs) = 0.0 - dqcw(mgs) = 0.0 - dqci(mgs) = 0.0 - dqwv(mgs) = ( qx(mgs,lv) - qss(mgs) ) + if ( ircnw .eq. 1 ) then + do mgs = 1,ngscnt + qrcnw(mgs) = 0.0 + c1 = 0.2 + c4 = pi/(6.0) + bradp = & + & (1.e+06) * ((c1/(0.38))**(1./3.)) * (xdia(mgs,lc,1)*(0.5)) + bl2 = & + & (0.027) * ((100.0)*(bradp**3)*(xdia(mgs,lc,1)*(0.5)) - (0.4)) + bt2 = (bradp -7.5) / (3.72) + qrcnw(mgs) = 0.0 + if ( bl2 .gt. 0.0 .and. bt2 .gt. 0.0 ) then + qrcnw(mgs) = bl2 * bt2 * rho0(mgs) & + & * qx(mgs,lc) * qx(mgs,lc) + end if + end do + end if + + + + ENDIF ! ( ipconc .ge. 2 ) + ! -! evaporation and sublimation adjustment ! - if( dqwv(mgs) .lt. 0. ) then ! subsaturated - if( qx(mgs,lc) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit - dqcw(mgs) = dqwv(mgs) - dqwv(mgs) = 0. - else ! otherwise make all qc available for evap - dqcw(mgs) = -qx(mgs,lc) - dqwv(mgs) = dqwv(mgs) + qx(mgs,lc) - end if ! - if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit - dqci(mgs) = dqwv(mgs) - dqwv(mgs) = 0. - else ! otherwise make all ice available for sublimation - dqci(mgs) = -qitmp(mgs) - dqwv(mgs) = dqwv(mgs) + qitmp(mgs) - end if -! - qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor -! -! This next line removed 3/19/2003 thanks to Adam Houston, -! who found the bug in the 3-ICE code -! qwvp(mgs) = max(qwvp(mgs), 0.0) - qitmp(mgs) = qx(mgs,li) - IF ( qitmp(mgs) .gt. qxmin(li) ) THEN - fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) - ELSE - fcci(mgs) = 0.0 - ENDIF - qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) - qx(mgs,li) = qx(mgs,li) + dqci(mgs) * fcci(mgs) - thetap(mgs) = thetap(mgs) + & - & 1./pi0(mgs)* & - & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) - - end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) -! -! condensation/deposition +! Bigg Freezing of Rain ! - IF ( dqwv(mgs) .ge. 0. ) THEN + if (ndebug .gt. 0 ) write(0,*) 'conc 27a' + qrfrz(:) = 0.0 + qrfrzs(:) = 0.0 + qrfrzf(:) = 0.0 + vrfrzf(:) = 0.0 + crfrz(:) = 0.0 + crfrzs(:) = 0.0 + crfrzf(:) = 0.0 + zrfrz(:) = 0.0 + zrfrzf(:) = 0.0 + qwcnr(:) = 0.0 -! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) -! - qitmp(mgs) = qx(mgs,li) - fracl(mgs) = 1.0 - fraci(mgs) = 0.0 - if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then - fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) - fraci(mgs) = 1.0-fracl(mgs) - end if - if ( temg(mgs) .le. thnuc ) then - fraci(mgs) = 1.0 - fracl(mgs) = 0.0 - end if - fraci(mgs) = 1.0-fracl(mgs) -! - gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & - & / (pi0(mgs)) -! - IF ( temg(mgs) .lt. tfr ) then - IF (qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) then - dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & - & ((temg(mgs)-cbw)**2)) - END IF - IF ( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then - dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qss(mgs)/ & - & ((temg(mgs)-cbi)**2)) - END IF - IF ( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then - cdw = caw*pi0(mgs)*tfrcbw/((temg(mgs)-cbw)**2) - cdi = cai*pi0(mgs)*tfrcbi/((temg(mgs)-cbi)**2) - denom1 = qx(mgs,lc) + qitmp(mgs) - denom2 = 1.0 + gamss* & - & (qx(mgs,lc)*qvs(mgs)*cdw + qitmp(mgs)*qis(mgs)*cdi) / denom1 - dqvcnd(mgs) = dqwv(mgs) / denom2 - END IF - - ENDIF ! temg(mgs) .lt. tfr -! - if ( temg(mgs) .ge. tfr ) then - dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & - & ((temg(mgs)-cbw)**2)) - end if -! - delqci1=qx(mgs,li) -! - IF ( qitmp(mgs) .gt. qxmin(li) ) THEN - fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) - ELSE - fcci(mgs) = 0.0 - ENDIF -! - dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) - dqci(mgs) = dqvcnd(mgs)*fraci(mgs) -! - thetap(mgs) = thetap(mgs) + & - & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & - & / (pi0(mgs)) - qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) - qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) - IF ( qitmp(mgs) .gt. qxmin(li) ) THEN - qx(mgs,li) = qx(mgs,li) + dqci(mgs)*fcci(mgs) - qitmp(mgs) = qx(mgs,li) - ENDIF -! -! delqci(mgs) = dqci(mgs)*fcci(mgs) -! - END IF ! dqwv(mgs) .ge. 0. - end do -! - do mgs = 1,ngscnt - qitmp(mgs) = qx(mgs,li) - theta(mgs) = thetap(mgs) + theta0(mgs) - temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap - qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) - temcg(mgs) = temg(mgs) - tfr - tqvcon = temg(mgs)-cbw - ltemq = (temg(mgs)-163.15)/fqsat+1.5 - ltemq = Min( nqsat, Max(1,ltemq) ) - qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - qis(mgs) = pqs(mgs)*tabqis(ltemq) - qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) - qitmp(mgs) = max( 0.0, qitmp(mgs) ) - qx(mgs,lv) = max( 0.0, qvap(mgs)) -! if ( temg(mgs) .lt. tfr ) then -! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) -! > qss(mgs) = qvs(mgs) -!c if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) -! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = qis(mgs) -!c if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) -! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) -! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / -! > (qx(mgs,lc) + qitmp(mgs)) -! else -! qss(mgs) = qvs(mgs) -! end if - qss(mgs) = qvs(mgs) - if ( temg(mgs) .lt. tfr ) then - if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & - & qss(mgs) = qvs(mgs) - if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & - & qss(mgs) = qis(mgs) - if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & - & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & - & (qx(mgs,lc) + qitmp(mgs)) - end if -! pceds(mgs) = (thetap(mgs) - thsave(mgs))/dtp -! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) - end do -! -! end the saturation adjustment iteration loop -! - end do - - ENDIF ! ( ipconc .le. 1 ) - -! -! spread the growth owing to vapor diffusion onto the -! ice crystal categories using the -! -! END OF SATURATION ADJUSTMENT -! - - if (ndebug .gt. 0 ) write(0,*) 'conc 30b' -! -! -! end of saturation adjustment -! -! -! !DIR$ IVDEP - do mgs = 1,ngscnt - t0(igs(mgs),jy,kgs(mgs)) = temg(mgs) - end do -! -! Load the save arrays -! - - - if (ndebug .gt. 0 ) write(0,*) 'gs 11' - - do mgs = 1,ngscnt -! - an(igs(mgs),jy,kgs(mgs),lt) = & - & theta0(mgs) + thetap(mgs) - an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) ! qv0(mgs) is zero, so qwvp is the FULL qv! -! + IF ( .not. ( ipconc == 0 .and. lwsm6 ) ) THEN - DO il = lc,lhab - IF ( ido(il) .eq. 1 ) THEN - an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) + & - & min( an(igs(mgs),jy,kgs(mgs),il), 0.0 ) - qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il) - ENDIF - ENDDO - + do mgs = 1,ngscnt + if ( qx(mgs,lr) .gt. qxmin(lr) .and. temcg(mgs) .lt. -5. .and. ibiggopt > 0 ) then +! brz = 100.0 +! arz = 0.66 + IF ( ipconc .lt. 3 ) THEN + qrfrz(mgs) = & + & min( & + & (20.0)*(pi**2)*brz*(xdn(mgs,lr)/rho0(mgs)) & + & *cx(mgs,lr)*(xdia(mgs,lr,1)**6) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & , qrmxd(mgs)) + qrfrzf(mgs) = qrfrz(mgs) -! - end do -! +! ELSEIF ( ipconc .ge. 3 .and. xv(mgs,lr) .gt. 1.1*xvmn(lr) ) THEN + ELSEIF ( ipconc .ge. 3 ) THEN +! tmp = brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! crfrz(mgs) = xv(mgs,lr)*tmp - if ( ipconc .ge. 1 ) then - DO il = lc,lhab !{ + frach = 1.0d0 + + IF ( ibiggopt == 2 .and. imurain == 1 ) THEN + ! integrate from Bigg diameter (for given supercooling Ts) to infinity + + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so convert to m**3 + dbigg = (6./pi* volt )**(1./3.) + + ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. + + ratio = dbigg/xdia(mgs,lr,1) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) +! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))) + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) -! write(0,*) 'limiter loop: il,ipc,lz: ',il,ipc(il),lz(il),ipconc + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha; + + crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)/dtp + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)/dtp + + + + IF ( dbigg < Min(dfrz,dhmn) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! convert some to snow or ice crystals + ! temporarily store qrfrz and crfrz in snow terms + crfrzs(mgs) = qrfrz(mgs) + qrfrzs(mgs) = crfrz(mgs) - IF ( ipconc .ge. ipc(il) ) THEN ! { - IF ( ipconc .ge. 4 .and. ipc(il) .ge. 3 ) THEN ! { + ! recalculate using dhmn for ratio + ratio = Min(dfrz,dhmn)/xdia(mgs,lr,1) + + i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) +! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))) + j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))*dqiacralphainv) + delx = ratio - float(i)*dqiacrratio + dely = alpha(mgs,lr) - float(j)*dqiacralpha + ip1 = Min( i+1, nqiacrratio ) + jp1 = Min( j+1, nqiacralpha ) -! write(0,*) 'MY limiter: il,ipc,lz: ',il,ipc(il),lz(il),lr,lzr -! STOP + ! interpolate along x, i.e., ratio; + tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) + tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) + + ! interpolate along alpha; + + crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)/dtp + + ! interpolate along x, i.e., ratio; + tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) + tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) + + ! interpolate along alpha; + + qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)/dtp - IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN ! { { is a two-moment category so dont worry about reflectivity - + ! now subtract off the difference + crfrzs(mgs) = crfrzs(mgs) - crfrz(mgs) + qrfrzs(mgs) = qrfrzs(mgs) - qrfrz(mgs) - DO mgs = 1,ngscnt - IF ( qx(mgs,il) .le. 0.0 ) THEN - cx(mgs,il) = 0.0 - ELSE - xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) - -! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN -! write(0,*) 'dr: xv,cx,qx,xdn,ln = ',xv(mgs,il),cx(mgs,il),qx(mgs,il),xdn(mgs,il),ln(il) -! ENDIF - - IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvmx(il) ) THEN - xv(mgs,il) = Min( xvmx(il), Max( xvmn(il),xv(mgs,il) ) ) - cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il)) - ENDIF + + ELSE + crfrzs(mgs) = 0.0 + qrfrzs(mgs) = 0.0 + ENDIF + + IF ( (qrfrzs(mgs) + qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN + fac = ( qrfrzs(mgs) + qrfrz(mgs) )*dtp/qx(mgs,lr) + qrfrz(mgs) = fac*qrfrz(mgs) + qrfrzs(mgs) = fac*qrfrzs(mgs) + qrfrzf(mgs) = fac*qrfrzf(mgs) + crfrz(mgs) = fac*crfrz(mgs) + crfrzs(mgs) = fac*crfrzs(mgs) + crfrzf(mgs) = fac*crfrzf(mgs) + ENDIF +! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN +! fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr) +! crfrz(mgs) = fac*crfrz(mgs) +! crfrzs(mgs) = fac*crfrzs(mgs) +! ENDIF + + qrfrzf(mgs) = qrfrz(mgs) + crfrzf(mgs) = crfrz(mgs) + + qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs) + crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs) -! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN -! write(0,*) 'dr: xv,cx,= ',xv(mgs,il),cx(mgs,il) -! ENDIF + + ELSE ! ibiggopt == 1 + + tmp = xv(mgs,lr)*brz*cx(mgs,lr)*(Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) + IF ( .false. .and. tmp .gt. cxmxd(mgs,lr) ) THEN ! { +! write(iunit,*) 'Bigg Freezing problem!',mgs,igs(mgs),kgs(mgs) +! write(iunit,*) 'tmp, cx(lr), xv = ',tmp, cx(mgs,lr), xv(mgs,lr), (Exp(Max( -arz*temcg(mgs), 0.0 )) - 1.0) +! write(iunit,*) 'qr,temcg = ',qx(mgs,lr)*1000.,temcg(mgs) + crfrz(mgs) = cxmxd(mgs,lr) ! cx(mgs,lr)/dtp + qrfrz(mgs) = qxmxd(mgs,lr) ! qx(mgs,lr)/dtp +! STOP + ELSE ! } { + crfrz(mgs) = tmp + ! crfrzfmx = cx(mgs,lr)*Exp(-4./3.*pi*(40.e-6)**3/xv(mgs,lr)) + ! IF ( crfrz(mgs) .gt. crfrzmx ) THEN + ! crfrz(mgs) = crfrzmx + ! qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrzmx + ! qwcnr(mgs) = cx(mgs,lr) - crfrzmx + ! ELSE + IF ( lzr < 1 ) THEN + IF ( imurain == 3 ) THEN + bfnu = bfnu0 + ELSE !imurain == 1 + bfnu = bfnu1 + ENDIF + ELSE + ! bfnu = 1.0 ! (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + IF ( imurain == 3 ) THEN + bfnu = (alpha(mgs,lr)+2.0)/(alpha(mgs,lr)+1.) + ELSE !imurain == 1 +! bfnu = bfnu1 + bfnu = (4. + alpha(mgs,lr))*(5. + alpha(mgs,lr))*(6. + alpha(mgs,lr))/ & + & ((1. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(3. + alpha(mgs,lr))) +! bfnu = 1. + ENDIF + ENDIF + qrfrz(mgs) = bfnu*xmas(mgs,lr)*rhoinv(mgs)*crfrz(mgs) + + qrfrz(mgs) = Min( qrfrz(mgs), 1.*qx(mgs,lr)/dtp ) ! qxmxd(mgs,lr) + crfrz(mgs) = Min( crfrz(mgs), 1.*cx(mgs,lr)/dtp ) !cxmxd(mgs,lr) + qrfrz(mgs) = Min( qrfrz(mgs), qx(mgs,lr) ) + qrfrzf(mgs) = qrfrz(mgs) + ENDIF !} + + + + IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN +! IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN +! IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN + + IF ( ibiggsnow == 1 .or. ibiggsnow == 3 ) THEN + xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density + frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) + + qrfrzs(mgs) = (1.-frach)*qrfrz(mgs) + crfrzs(mgs) = (1.-frach)*crfrz(mgs) ! *rzxh(mgs) +! qrfrzf(mgs) = frach*qrfrz(mgs) + + ENDIF + + IF ( ipconc .ge. 14 .and. 1.e-3*rho0(mgs)*qrfrz(mgs)/crfrz(mgs) .lt. xvmn(lh) ) THEN + qrfrzs(mgs) = qrfrz(mgs) + crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs) + ELSE +! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)/dtp ) ! cxmxd(mgs,lr) ) +! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)/dtp ) ! qxmxd(mgs,lr) ) + qrfrzf(mgs) = frach*qrfrz(mgs) +! crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) ) + IF ( ibfr .le. 1 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), dble(qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs)) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 5 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), dble(qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs)) )*rzxh(mgs) !*crfrz(mgs) + ELSEIF ( ibfr .eq. 2 ) THEN + crfrzf(mgs) = frach*Min(crfrz(mgs), dble(qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs)) ) ! rzxh(mgs)*crfrz(mgs) + ELSEIF ( ibfr .eq. 6 ) THEN + crfrzf(mgs) = frach*Max(crfrz(mgs), dble(qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs)) ) ! rzxh(mgs)*crfrz(mgs) + ELSE + crfrzf(mgs) = frach*crfrz(mgs) ENDIF - ENDDO ! mgs - - - ENDIF ! }} - ENDIF ! } +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN +! crfrzf(mgs) = crfrz(mgs) +! ENDIF + + ENDIF +! crfrz(mgs) = Min( cxmxd(mgs,lr), rho0(mgs)*qrfrz(mgs)/xmas(mgs,lr) ) + ELSE + crfrz(mgs) = 0.0 + qrfrz(mgs) = 0.0 + ENDIF - DO mgs = 1,ngscnt - an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) - ENDDO - ENDIF ! } - ENDDO ! il } + ENDIF ! ibiggopt - IF ( lcin > 1 ) THEN - do mgs = 1,ngscnt - an(igs(mgs),jy,kgs(mgs),lcin) = Max(0.0, ccin(mgs)) - end do - ENDIF + IF ( lvol(lh) .gt. 1 ) THEN + vrfrzf(mgs) = rho0(mgs)*qrfrzf(mgs)/rhofrz + ENDIF - IF ( ipconc .ge. 2 ) THEN - do mgs = 1,ngscnt - IF ( lccn > 1 ) THEN - an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, Min(ccwmx,ccnc(mgs)) ) + + IF ( nsplinter .ne. 0 ) THEN + IF ( nsplinter .gt. 0 ) THEN + tmp = nsplinter*crfrz(mgs) + ELSE + tmp = -nsplinter*crfrzf(mgs) + ENDIF + csplinter2(mgs) = tmp + qsplinter2(mgs) = Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel + +! csplinter(mgs) = csplinter(mgs) + tmp +! qsplinter(mgs) = qsplinter(mgs) + Min(0.1*qrfrz(mgs), tmp*splintermass/rho0(mgs) ) ! makes splinters smaller if too much mass is taken from graupel ENDIF +! IF ( temcg(mgs) .lt. -31.0 ) THEN +! qrfrz(mgs) = qx(mgs,lr)/dtp + qrcnw(mgs) +! qrfrzf(mgs) = qrfrz(mgs) +! crfrz(mgs) = cx(mgs,lr)/dtp + crcnw(mgs) +! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) +! ENDIF +! qrfrz(mgs) = 6.0*xdn(mgs,lr)*xv(mgs,lr)**2*tmp*rhoinv(mgs) +! qrfrz(mgs) = Min( qrfrz(mgs), ffrz*qrmxd(mgs) ) +! crfrz(mgs) = Min( crmxd(mgs), ffrz*crfrz(mgs)) +! crfrz(mgs) = Min(crmxd(mgs),qrfrz(mgs)*rho0(mgs)/xmas(mgs,lr)) + ENDIF +! if ( temg(mgs) .gt. 268.15 ) then + else +! end if + end if end do - ENDIF - - ELSEIF ( ipconc .eq. 0 .and. lni .gt. 1 ) THEN - DO mgs = 1,ngscnt - an(igs(mgs),jy,kgs(mgs),lni) = Max(cx(mgs,li), 0.0) - ENDDO + ENDIF +! +! Homogeneous freezing of cloud drops to ice crystals +! following Bigg (1953) and Ferrier (1994). +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25b' + do mgs = 1,ngscnt + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + qwfrzc(mgs) = 0.0 + cwfrzc(mgs) = 0.0 + qwfrzp(mgs) = 0.0 + cwfrzp(mgs) = 0.0 + IF ( ibfc .ge. 1 .and. temg(mgs) < 268.15 ) THEN +! if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1. .and. & +! & .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then + if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN + IF ( ipconc < 2 ) THEN + qwfrz(mgs) = ((2.0)*(brz)/(xdn(mgs,lc)*cx(mgs,lc))) & + & *(exp(max(-arz*temcg(mgs), 0.0))-1.0) & + & *rho0(mgs)*(qx(mgs,lc)**2) + qwfrz(mgs) = max(qwfrz(mgs), 0.0) + qwfrz(mgs) = min(qwfrz(mgs),qcmxd(mgs)) + cwfrz(mgs) = qwfrz(mgs)*rho0(mgs)/xmas(mgs,li) + ELSEIF ( ipconc .ge. 2 ) THEN + IF ( xdia(mgs,lc,3) > 0.e-6 ) THEN + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 +! dbigg = (6./pi* volt )**(1./3.) + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))/dtp ! number of droplets with volume greater than volt +!turn off limit so that all can freeze at low temp +!!! cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs)) + qwfrz(mgs) = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) +! cwfrz(mgs) = cx(mgs,lc)*qwfrz(mgs)/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes + ! sure that cwfrz and qwfrz are consistent and prevents + ! spurious creation of ice crystals. +! IF ( temg(mgs) < tfrh - 3 ) THEN +! cwfrz(mgs) = cx(mgs,lc) +! qwfrz(mgs) = qx(mgs,lc) +! ENDIF +! IF ( qwfrz(mgs) > 0.5*qx(mgs,lc) ) THEN +! write(0,*) 'Problem with qwfrz(mgs): qwfrz,temcg,volt,xv,cx = ',qwfrz(mgs),qx(mgs,lc),temcg(mgs),volt,xv(mgs,lc),cx(mgs,lc),cwfrz(mgs) +! STOP +! ENDIF +!turn off limit so that all can freeze at low temp +!!! qwfrz(mgs) = Min( qwfrz(mgs), qxmxd(mgs,lc) ) + ENDIF + ENDIF + if ( temg(mgs) .gt. 268.15 ) then + qwfrz(mgs) = 0.0 + cwfrz(mgs) = 0.0 + end if end if - - IF ( ldovol ) THEN - - DO il = li,lhab - - IF ( lvol(il) .ge. 1 ) THEN - - DO mgs = 1,ngscnt - - an(igs(mgs),jy,kgs(mgs),lvol(il)) = Max( 0.0, vx(mgs,il) ) - ENDDO - - ENDIF - - ENDDO - ENDIF ! + if ( xplate(mgs) .eq. 1 ) then + qwfrzp(mgs) = qwfrz(mgs) + cwfrzp(mgs) = cwfrz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwfrzc(mgs) = qwfrz(mgs) + cwfrzc(mgs) = cwfrz(mgs) + end if ! +! qwfrzp(mgs) = 0.0 +! qwfrzc(mgs) = qwfrz(mgs) ! + end do ! ! - if (ndebug .gt. 0 ) write(0,*) 'gs 12' - +! Contact freezing nucleation: factor is to convert from L-1 +! T < -2C: via Meyers et al. JAM July, 1992 (31, 708-721) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 25a' + do mgs = 1,ngscnt + ccia(mgs) = 0.0 - if (ndebug .gt. 0 ) write(0,*) 'gs 13' - - 9998 continue + cwctfz(mgs) = 0.0 + qwctfz(mgs) = 0.0 + ctfzbd(mgs) = 0.0 + ctfzth(mgs) = 0.0 + ctfzdi(mgs) = 0.0 - if ( kz .gt. nz-1 .and. ix .ge. nx) then - if ( ix .ge. nx ) then - go to 1200 ! exit gather scatter - else - nzmpb = kz - endif - else - nzmpb = kz - end if + cwctfzc(mgs) = 0.0 + qwctfzc(mgs) = 0.0 + cwctfzp(mgs) = 0.0 + qwctfzp(mgs) = 0.0 - if ( ix .ge. nx ) then - nxmpb = 1 - nzmpb = kz+1 - else - nxmpb = ix+1 - end if + IF ( icfn .ge. 1 ) THEN - 1000 continue - 1200 continue -! -! end of gather scatter (for this jy slice) -! -! + IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN - return - end subroutine nssl_2mom_gs -! -!-------------------------------------------------------------------------- -! +! find available # of ice nuclei & limit value to max depletion of cloud water + IF ( icfn .ge. 2 ) THEN + ccia(mgs) = exp( 4.11 - (0.262)*temcg(mgs) ) ! in m-3, see Walko et al. 1995 + !ccia(mgs) = Min(cwctfz(mgs), ccmxd(mgs) ) -! -! ############################################################################## -! - SUBROUTINE setvtz(ngscnt,ngs0,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & - & xmas,vtxbar,xdn,xvmn0,xvmx0,xv,cdx, & - & ipconc1,ndebug1,ngs,nz,kgs,fadvisc, & - & cwmasn,cwmasx,cwradn,cnina,cimna,cimxa, & - & itype1a,itype2a,temcg,infdo,alpha,ildo) +! now find how many of these collect cloud water to form IN +! Cotton et al 1986 + knud(mgs) = 2.28e-5 * temg(mgs) / ( pres(mgs)*raero ) !Walko et al. 1995 + knuda(mgs) = 1.257 + 0.4*exp(-1.1/knud(mgs)) !Pruppacher & Klett 1997 eqn 11-16 + gtp(mgs) = 1. / ( fai(mgs) + fbi(mgs) ) !Byers 65 / Cotton 72b + dfar(mgs) = kb*temg(mgs)*(1.+knuda(mgs)*knud(mgs))/(6.*pi*fadvisc(mgs)*raero) !P&K 1997 eqn 11-15 + fn1(mgs) = 2.*pi*xdia(mgs,lc,1)*cx(mgs,lc)*ccia(mgs) + fn2(mgs) = -gtp(mgs)*(ssw(mgs)-1.)*felv(mgs)/pres(mgs) + fnft(mgs) = 0.4*(1.+1.45*knud(mgs)+0.4*knud(mgs)*exp(-1./knud(mgs)))*(ftka(mgs)+2.5*knud(mgs)*kaero) & + & / ( (1.+3.*knud(mgs))*(2*ftka(mgs)+5.*knud(mgs)*kaero+kaero) ) - implicit none -! include 'sam.index.ion.h' -! include 'swm.index.zieg.h' - - integer ngscnt,ngs0,ngs,nz -! integer infall ! whether to calculate number-weighted fall speeds - - real xv(ngs0,lc:lhab) - real qx(ngs0,lv:lhab) - real qxw(ngs0,ls:lhab) - real cx(ngs0,lc:lhab) - real vtxbar(ngs0,lc:lhab,3) - real xmas(ngs0,lc:lhab) - real xdn(ngs0,lc:lhab) - real xdia(ngs0,lc:lhab,3) - real xvmn0(lc:lhab), xvmx0(lc:lhab) - real qxmin(lc:lhab) - real cdx(lc:lhab) - real alpha(ngs0,lr:lhab) - - real rho0(ngs),rhovt(ngs),temcg(ngs) - real cno(lc:lhab) - real cnostmp(ngs) - - real cwc1, cimna, cimxa - real cnina(ngs) - integer kgs(ngs) - real fadvisc(ngs) - real fsw - - integer ipconc1 - integer ndebug1 - - integer, intent (in) :: itype1a,itype2a,infdo - integer, intent (in) :: ildo ! which species to do, or all if ildo=0 - -! Local vars +! Brownian diffusion + ctfzbd(mgs) = fn1(mgs)*dfar(mgs) - real :: axh(ngs0),bxh(ngs0) - real :: axhl(ngs0),bxhl(ngs0) +! Thermophoretic contact nucleation + ctfzth(mgs) = fn1(mgs)*fn2(mgs)*fnft(mgs)/rho0(mgs) - real cd - real cwc0 ! ,cwc1 - real :: cwch(ngscnt), cwchl(ngscnt) - real :: cwchtmp,cwchltmp,xnutmp - real pii - real cimasx,cimasn - real cwmasn,cwmasx,cwradn - real cwrad - real vr,rnux - real alp - - real ccimx +! Diffusiophoretic contact nucleation + ctfzdi(mgs) = fn1(mgs)*fn2(mgs)*rw*temg(mgs)/(felv(mgs)*rho0(mgs)) - integer mgs - - real arx,frx,vtrain,fw - real fwlo,fwhi,rfwdiff - real ar,br,cs,ds -! real gf4p5, gf4ds, gf4br, ifirst, gf1ds -! real gfcinu1, gfcinu1p47, gfcinu2p47 - real gr - real rwrad,rwdia - real mwfac - integer il + cwctfz(mgs) = max( ctfzbd(mgs) + ctfzth(mgs) + ctfzdi(mgs) , 0.) -! save gf4p5, gf4ds, gf4br, ifirst, gf1ds -! save gfcinu1, gfcinu1p47, gfcinu2p47 -! data ifirst /0/ - - real bta1,cnit - parameter ( bta1 = 0.6, cnit = 1.0e-02 ) - real x,y,tmp,del - real aax,bbx,delrho - integer :: indxr - real mwt - real, parameter :: rho00 = 1.225 - integer i - real xvbarmax +! Sum of the contact nucleation processes +! IF ( cx(mgs,lc) .gt. 50.e6) write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs) +! IF ( wvel(mgs) .lt. -0.05 ) write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs) +! IF ( ssw(mgs) .lt. 1.0 .and. cx(mgs,lc) .gt. 1.e6 .and. cwctfz(mgs) .gt. 1. ) THEN +! write(6,*) 'ctfzbd,etc = ',ctfzbd(mgs),ctfzth(mgs),ctfzdi(mgs),cx(mgs,lc)*1e-6,wvel(mgs),fn1(mgs),fn2(mgs) +! write(6,*) 'more = ',nstep,ssw(mgs),dfar(mgs),gtp(mgs),felv(mgs),pres(mgs) +! ENDIF - integer l1, l2 + ELSEIF ( icfn .eq. 1 ) THEN + IF ( wvel(mgs) .lt. -0.05 ) THEN ! older kludgy version + cwctfz(mgs) = cfnfac*exp( (-2.80) - (0.262)*temcg(mgs) ) + cwctfz(mgs) = Min((1.0e3)*cwctfz(mgs), ccmxd(mgs) ) !convert to m-3 + ENDIF + ENDIF ! icfn + IF ( ipconc .ge. 2 ) THEN + cwctfz(mgs) = Min( cwctfz(mgs)/dtp, ccmxd(mgs) ) + qwctfz(mgs) = xmas(mgs,lc)*cwctfz(mgs)/rho0(mgs) + ELSE + qwctfz(mgs) = (cimasn)*cwctfz(mgs)/(dtp*rho0(mgs)) + qwctfz(mgs) = max(qwctfz(mgs), 0.0) + qwctfz(mgs) = min(qwctfz(mgs),qcmxd(mgs)) + ENDIF ! -! set values + if ( xplate(mgs) .eq. 1 ) then + qwctfzp(mgs) = qwctfz(mgs) + cwctfzp(mgs) = cwctfz(mgs) + end if ! -! cwmasn = 5.23e-13 ! radius of 5.0e-6 -! cwradn = 5.0e-6 -! cwmasx = 5.25e-10 ! radius of 50.0e-6 - - fwlo = 0.2 ! water fraction to start weighting toward rain fall speed - fwhi = 0.4 ! water fraction at which rain fall speed only is used - rfwdiff = 1./(fwhi - fwlo) - -! pi = 4.0*atan(1.0) - pii = piinv ! 1.0/pi + if ( xcolmn(mgs) .eq. 1 ) then + qwctfzc(mgs) = qwctfz(mgs) + cwctfzc(mgs) = cwctfz(mgs) + end if +! +! qwctfzc(mgs) = qwctfz(mgs) +! qwctfzp(mgs) = 0.0 +! + end if - arx = 10. - frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + ENDIF ! icfn - ar = 841.99666 - br = 0.8 - gr = 9.8 -! new values for cs and ds - cs = 12.42 - ds = 0.42 + end do +! +! +! +! Hobbs-Rangno ice enhancement (Ferrier, 1994) +! + if (ndebug .gt. 0 ) write(0,*) 'conc 23a' + dtrh = 300.0 + hrifac = (1.e-3)*((0.044)*(0.01**3)) + do mgs = 1,ngscnt + ciihr(mgs) = 0.0 + qiihr(mgs) = 0.0 + cicichr(mgs) = 0.0 + qicichr(mgs) = 0.0 + cipiphr(mgs) = 0.0 + qipiphr(mgs) = 0.0 + IF ( ihrn .ge. 1 ) THEN + if ( qx(mgs,lc) .gt. qxmin(lc) ) then + if ( temg(mgs) .lt. 273.15 ) then +! write(iunit,'(3(1x,i3),3(1x,1pe12.5))') +! : igs(mgs),jgs,kgs(mgs),cx(mgs,lc),rho0(mgs),qx(mgs,lc) +! write(iunit,'(1pe15.6)') +! : log(cx(mgs,lc)*(1.e-6)/(3.0)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc)), +! : (cx(mgs,lc)*(1.e-6)), +! : ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)), +! : (alog(cx(mgs,lc)*(1.e-6)/(3.0)) * +! > ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6))) - IF ( ildo == 0 ) THEN - l1 = lc - l2 = lhab - ELSE - l1 = ildo - l2 = ildo + IF ( Log(cx(mgs,lc)*(1.e-6)/(3.0)) .gt. 0.0 ) THEN + ciihr(mgs) = ((1.69e17)/dtrh) & + & *(log(cx(mgs,lc)*(1.e-6)/(3.0)) * & + & ((1.e-3)*rho0(mgs)*qx(mgs,lc))/(cx(mgs,lc)*(1.e-6)))**(7./3.) + ciihr(mgs) = ciihr(mgs)*(1.0e6) + qiihr(mgs) = hrifac*ciihr(mgs)/rho0(mgs) + qiihr(mgs) = max(qiihr(mgs), 0.0) + qiihr(mgs) = min(qiihr(mgs),qcmxd(mgs)) ENDIF - -! IF ( ifirst .eq. 0 ) THEN -! ifirst = 1 -! gf4br = gamma(4.0+br) -! gf4ds = gamma(4.0+ds) -!! gf1ds = gamma(1.0+ds) -! gf4p5 = gamma(4.0+0.5) -! gfcinu1 = gamma(cinu + 1.0) -! gfcinu1p47 = gamma(cinu + 1.47167) -! gfcinu2p47 = gamma(cinu + 2.47167) - - IF ( lh .gt. 1 ) THEN - IF ( dmuh == 1.0 ) THEN - cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.) - ELSE - cwchtmp = 6.0*pii*gamma( (xnu(lh) + 1.)/xmu(lh) )/gamma( (xnu(lh) + 2.)/xmu(lh) ) - ENDIF - ENDIF - IF ( lhl .gt. 1 ) THEN - IF ( dmuhl == 1.0 ) THEN - cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.) - ELSE - cwchltmp = 6.0*pii*gamma( (xnu(lhl) + 1)/xmu(lhl) )/gamma( (xnu(lhl) + 2)/xmu(lhl) ) - ENDIF - ENDIF - - IF ( ipconc .le. 5 ) THEN - IF ( lh .gt. 1 ) cwch(:) = cwchtmp - IF ( lhl .gt. 1 ) cwchl(:) = cwchltmp - ELSE - DO mgs = 1,ngscnt - - IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN - IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN - IF ( dmuh == 1.0 ) THEN - cwch(mgs) = ((3. + alpha(mgs,lh))*(2. + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))**(-1./3.) - ELSE - xnutmp = (alpha(mgs,lh) - 2.0)/3.0 - cwch(mgs) = 6.0*pii*gamma( (xnutmp + 1.)/xmu(lh) )/gamma( (xnutmp + 2.)/xmu(lh) ) - ENDIF - ELSE - cwch(mgs) = cwchtmp - ENDIF - ENDIF - IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN - IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN - IF ( dmuhl == 1.0 ) THEN - cwchl(mgs) = ((3. + alpha(mgs,lhl))*(2. + alpha(mgs,lhl))*(1.0 + alpha(mgs,lhl)))**(-1./3.) - ELSE - xnutmp = (alpha(mgs,lhl) - 2.0)/3.0 - cwchl(mgs) = 6.0*pii*gamma( (xnutmp + 1)/xmu(lhl) )/gamma( (xnutmp + 2)/xmu(lhl) ) - ENDIF - ELSE - cwchl(mgs) = cwchltmp - ENDIF - ENDIF - - ENDDO - - ENDIF - - - cimasn = Min( cimas0, 6.88e-13) - cimasx = 1.0e-8 - ccimx = 5000.0e3 ! max of 5000 per liter - - cwc1 = 6.0/(pi*1000.) - cwc0 = pii ! 6.0*pii - mwfac = 6.0**(1./3.) - - - if (ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set scale diameter' ! - - + if ( xplate(mgs) .eq. 1 ) then + qipiphr(mgs) = qiihr(mgs) + cipiphr(mgs) = ciihr(mgs) + end if ! -! cloud water variables -! ################################################################ + if ( xcolmn(mgs) .eq. 1 ) then + qicichr(mgs) = qiihr(mgs) + cicichr(mgs) = ciihr(mgs) + end if ! -! DROPLETS +! qipiphr(mgs) = 0.0 +! qicichr(mgs) = qiihr(mgs) ! + end if + end if + ENDIF ! ihrn + end do ! - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cloud water variables' - - IF ( ildo == 0 .or. ildo == lc ) THEN - +! +! +! simple frozen rain to hail conversion. All of the +! frozen rain larger than 5.0e-3 m in diameter are converted +! to hail. This is done by considering the equation for +! frozen rain mixing ratio: +! +! +! qfw = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! /inf +! * | fwdia*3 exp(-dia/fwdia) d(dia) +! /Do +! +! The amount to be reclassified as hail is the integral above from +! Do to inf where Do is 5.0e-3 m. +! +! +! qfauh = [ cno(lf) * pi * fwdn / (6 rhoair) ] +! +! + + + hdia0 = 300.0e-6 do mgs = 1,ngscnt - xv(mgs,lc) = 0.0 - - IF ( qx(mgs,lc) .gt. qxmin(lc) ) THEN !{ - - IF ( ipconc .ge. 2 .and. cx(mgs,lc) .gt. 1.0e-9 ) THEN !{ - xmas(mgs,lc) = & - & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),cwmasn),cwmasx ) - xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) - ELSE - IF ( ipconc .lt. 2 ) THEN - cx(mgs,lc) = rho0(mgs)*ccn/rho00 ! scales to local density, relative to standard air density - ENDIF - IF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 0.01 ) THEN !{ - xmas(mgs,lc) = & - & min( max(qx(mgs,lc)*rho0(mgs)/cx(mgs,lc),xdn(mgs,lc)*xvmn(lc)), & - & xdn(mgs,lc)*xvmx(lc) ) - - xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) - cx(mgs,lc) = qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc) - - ELSEIF ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .le. 0.01 ) THEN - xmas(mgs,lc) = xdn(mgs,lc)*4.*pi/3.*(5.0e-6)**3 - cx(mgs,lc) = rho0(mgs)*qx(mgs,lc)/xmas(mgs,lc) - xv(mgs,lc) = xmas(mgs,lc)/xdn(mgs,lc) - - ELSE - xmas(mgs,lc) = cwmasn - xv(mgs,lc) = xmas(mgs,lc)/1000. -! do not define ccw here! it can feed back to ccn!!! cx(mgs,lc) = 0.0 ! cwnc(mgs) - ENDIF !} - ENDIF !} -! IF ( ipconc .lt. 2 ) THEN -! xmas(mgs,lc) = & -! & min( max(qx(mgs,lc)*rho0(mgs)/cwnc(mgs),cwmasn),cwmasx ) -! cx(mgs,lc) = Max(1.0,qx(mgs,lc)*rho0(mgs)/xmas(mgs,lc)) -! ELSE -! cwnc(mgs) = an(igs(mgs),jgs,kgs(mgs),lnc) -! cx(mgs,lc) = cwnc(mgs) -! ENDIF - xdia(mgs,lc,1) = (xmas(mgs,lc)*cwc1)**(1./3.) - xdia(mgs,lc,2) = xdia(mgs,lc,1)**2 - xdia(mgs,lc,3) = xdia(mgs,lc,1) - cwrad = 0.5*xdia(mgs,lc,1) - IF ( fadvisc(mgs) > 0.0 ) THEN - vtxbar(mgs,lc,1) = & - & (2.0*gr*xdn(mgs,lc) *(cwrad**2)) & - & /(9.0*fadvisc(mgs)) - ELSE - vtxbar(mgs,lc,1) = 0.0 - ENDIF + qscnvi(mgs) = 0.0 + cscnvi(mgs) = 0.0 + cscnvis(mgs) = 0.0 +! IF ( .false. ) THEN +! IF ( temg(mgs) .lt. tfr .and. ssi(mgs) .gt. 1.01 .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( temg(mgs) .lt. tfr .and. qx(mgs,li) .gt. qxmin(li) ) THEN + IF ( ipconc .ge. 4 .and. .false. ) THEN + if ( cx(mgs,li) .gt. 10. .and. xdia(mgs,li,1) .gt. 50.e-6 ) then !{ + cirdiatmp = & + & (qx(mgs,li)*rho0(mgs) & + & /(pi*xdn(mgs,li)*cx(mgs,li)))**(1./3.) + IF ( cirdiatmp .gt. 100.e-6 ) THEN !{ + qscnvi(mgs) = & + & ((pi*xdn(mgs,li)*cx(mgs,li)) / (6.0*rho0(mgs)*dtp)) & + & *exp(-hdia0/cirdiatmp) & + & *( (hdia0**3) + 3.0*(hdia0**2)*cirdiatmp & + & + 6.0*(hdia0)*(cirdiatmp**2) + 6.0*(cirdiatmp**3) ) + qscnvi(mgs) = & + & min(qscnvi(mgs),qimxd(mgs)) + IF ( ipconc .ge. 4 ) THEN + cscnvi(mgs) = Min( cimxd(mgs), cx(mgs,li)*Exp(-hdia0/cirdiatmp)) + ENDIF + ENDIF ! } + end if ! } - - ELSE - xmas(mgs,lc) = cwmasn - IF ( ipconc .le. 1 ) cx(mgs,lc) = 0.01 - xdia(mgs,lc,1) = 2.*cwradn - xdia(mgs,lc,2) = 4.*cwradn**2 - xdia(mgs,lc,3) = xdia(mgs,lc,1) - vtxbar(mgs,lc,1) = 0.0 - - ENDIF !} qcw .gt. qxmin(lc) - - end do - - ENDIF + ELSEIF ( ipconc .lt. 4 ) THEN + qscnvi(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscnvi(mgs) = min(qscnvi(mgs),qxmxd(mgs,li)) + cscnvi(mgs) = qscnvi(mgs)*rho0(mgs)/xmas(mgs,li) + cscnvis(mgs) = 0.5*cscnvi(mgs) + ENDIF + ENDIF +! ENDIF + end do ! -! cloud ice variables -! columns +! Ventilation coeficients ! -! ################################################################ + do mgs = 1,ngscnt + fvent(mgs) = (fschm(mgs)**(1./3.)) * (fakvisc(mgs)**(-0.5)) + end do ! -! CLOUD ICE ! - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set cip' - - IF ( li .gt. 1 .and. ( ildo == 0 .or. ildo == li ) ) THEN - do mgs = 1,ngscnt - xdn(mgs,li) = 900.0 - IF ( ipconc .eq. 0 ) THEN -! cx(mgs,li) = min(cnit*exp(-temcg(mgs)*bta1),1.e+09) - cx(mgs,li) = cnina(mgs) - IF ( cimna .gt. 1.0 ) THEN - cx(mgs,li) = Max(cimna,cx(mgs,li)) - ENDIF - IF ( cimxa .gt. 1.0 ) THEN - cx(mgs,li) = Min(cimxa,cx(mgs,li)) - ENDIF -! erm 3/28/2002 - IF ( itype1a .ge. 1 .or. itype2a .ge. 1 ) THEN - cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) - cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) - ENDIF + if ( ndebug .gt. 0 ) write(0,*) 'civent' ! - cx(mgs,li) = max(1.0e-20,cx(mgs,li)) -! cx(mgs,li) = Min(ccimx, cx(mgs,li)) + civenta = 1.258e4 + civentb = 2.331 + civentc = 5.662e4 + civentd = 2.373 + civente = 0.8241 + civentf = -0.042 + civentg = 1.70 - - ELSEIF ( ipconc .ge. 1 ) THEN - IF ( qx(mgs,li) .gt. qxmin(li) ) THEN - cx(mgs,li) = Max(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasx) - cx(mgs,li) = Min(cx(mgs,li),qx(mgs,li)*rho0(mgs)/cimasn) -! cx(mgs,li) = Max(1.0,cx(mgs,li)) - ENDIF - ENDIF - + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN IF ( qx(mgs,li) .gt. qxmin(li) ) THEN - xmas(mgs,li) = & - & max( qx(mgs,li)*rho0(mgs)/cx(mgs,li), cimasn ) -! & min( max(qx(mgs,li)*rho0(mgs)/cx(mgs,li),cimasn),cimasx ) - -! if ( temcg(mgs) .gt. 0.0 ) then -! xdia(mgs,li,1) = 0.0 -! else - if ( xmas(mgs,li) .gt. 0.0 ) THEN ! cimasn ) then -!c xdia(mgs,li,1) = 0.4892*(xmas(mgs,li)**(0.4554)) -! xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) - -! xdia(mgs,li,1) = (132.694*5.40662/xmas(mgs,li))**(-1./2.9163) ! for inverse exponential distribution - IF ( ixtaltype == 1 ) THEN ! column - xdia(mgs,li,1) = 0.1871*(xmas(mgs,li)**(0.3429)) - xdia(mgs,li,3) = 0.1871*(xmas(mgs,li)**(0.3429)) - ELSEIF ( ixtaltype == 2 ) THEN ! disk - xdia(mgs,li,1) = 0.277823*xmas(mgs,li)**0.359971 - xdia(mgs,li,3) = 0.277823*xmas(mgs,li)**0.359971 - ENDIF - end if -! end if -! xdia(mgs,li,1) = max(xdia(mgs,li,1), 5.e-6) -! xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) - - IF ( ipconc .ge. 0 ) THEN -! vtxbar(mgs,li,1) = rhovt(mgs)*49420.*40.0005/5.40662*xdia(mgs,li,1)**(1.415) ! mass-weighted -! vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) - xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) - IF ( ixtaltype == 1 ) THEN ! column - tmp = (67056.6300748612*rhovt(mgs))/ & - & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1) - vtxbar(mgs,li,2) = tmp*gfcinu1p47 - vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu) - vtxbar(mgs,li,3) = vtxbar(mgs,li,1) - ELSEIF ( ixtaltype == 2 ) THEN ! disk -- but just use column fall speed for now - tmp = (67056.6300748612*rhovt(mgs))/ & - & (((1.0 + cinu)/xv(mgs,li))**0.4716666666666667*gfcinu1) - vtxbar(mgs,li,2) = tmp*gfcinu1p47 - vtxbar(mgs,li,1) = tmp*gfcinu2p47/(1. + cinu) - vtxbar(mgs,li,3) = vtxbar(mgs,li,1) - - ENDIF -! vtxbar(mgs,li,1) = vtxbar(mgs,li,2)*(1.+cinu)/(1. + cinu) -! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) -! xdn(mgs,li) = 900.0 - xdia(mgs,li,2) = xdia(mgs,li,1)**2 -! vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) - ELSE - xdia(mgs,li,1) = max(xdia(mgs,li,1), 10.e-6) - xdia(mgs,li,1) = min(xdia(mgs,li,1), 1000.e-6) - vtxbar(mgs,li,1) = (4.942e4)*(xdia(mgs,li,1)**(1.4150)) -! xdn(mgs,li) = min(max(769.8*xdia(mgs,li,1)**(-0.0140),300.0),900.0) - xdn(mgs,li) = 900.0 - xdia(mgs,li,2) = xdia(mgs,li,1)**2 - vtxbar(mgs,li,1) = vtxbar(mgs,li,1)*rhovt(mgs) - xv(mgs,li) = xmas(mgs,li)/xdn(mgs,li) - ENDIF ! ipconc gt 3 + cireyn = & + & (civenta*xdia(mgs,li,1)**civentb & + & +civentc*xdia(mgs,li,1)**civentd) & + & / & + & (civente*xdia(mgs,li,1)**civentf+civentg) + xcivent = (fschm(mgs)**(1./3.))*((cireyn/fakvisc(mgs))**0.5) + if ( xcivent .lt. 1.0 ) then + civent(mgs) = 1.0 + 0.14*xcivent**2 + end if + if ( xcivent .ge. 1.0 ) then + civent(mgs) = 0.86 + 0.28*xcivent + end if ELSE - xmas(mgs,li) = 1.e-13 - xdn(mgs,li) = 900.0 - xdia(mgs,li,1) = 1.e-7 - xdia(mgs,li,2) = (1.e-14) - xdia(mgs,li,3) = 1.e-7 - vtxbar(mgs,li,1) = 0.0 -! cicap(mgs) = 0.0 -! ciat(mgs) = 0.0 + civent(mgs) = 0.0 ENDIF + ENDIF ! icond .eq. 1 end do - - ENDIF ! li .gt. 1 - -! ################################################################ -! -! RAIN ! - ! - IF ( ildo == 0 .or. ildo == lr ) THEN + igmrwa = 100.0*2.0 + igmrwb = 100.*((5.0+br)/2.0) + rwventa = (0.78)*gmoi(igmrwa) ! 0.78 + rwventb = (0.308)*gmoi(igmrwb) ! 0.562825 do mgs = 1,ngscnt - if ( qx(mgs,lr) .gt. qxmin(lr) ) then - -! IF ( qx(mgs,lr) .gt. 10.0e-3 ) & -! & write(0,*) 'RAIN1: ',igs(mgs),kgs(mgs),qx(mgs,lr) - - if ( ipconc .ge. 3 ) then - xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*Max(1.0e-11,cx(mgs,lr))) - xvbarmax = xvmx(lr) - IF ( imaxdiaopt == 1 ) THEN - xvbarmax = xvmx(lr) - ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter - IF ( imurain == 1 ) THEN - xvbarmax = xvmx(lr)/((3. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) - ELSEIF ( imurain == 3 ) THEN - - ENDIF - ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter - IF ( imurain == 1 ) THEN - xvbarmax = xvmx(lr)/((4. + alpha(mgs,lr))**3/((3. + alpha(mgs,lr))*(2. + alpha(mgs,lr))*(1. + alpha(mgs,lr)))) - ELSEIF ( imurain == 3 ) THEN - - ENDIF - ENDIF - - IF ( xv(mgs,lr) .gt. xvbarmax ) THEN - xv(mgs,lr) = xvbarmax - cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvbarmax*xdn(mgs,lr)) - ELSEIF ( xv(mgs,lr) .lt. xvmn(lr) ) THEN - xv(mgs,lr) = xvmn(lr) - cx(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xvmn(lr)*xdn(mgs,lr)) - ENDIF - + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + IF ( ipconc .ge. 3 ) THEN + IF ( imurain == 3 ) THEN + IF ( izwisventr == 1 ) THEN + rwvent(mgs) = ventrx(mgs)*(1.6 + 124.9*(1.e-3*rho0(mgs)*qx(mgs,lr))**.2046) + ELSE ! izwisventr = 2 +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier's rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + rwvent(mgs) = & + & (0.78*ventrx(mgs) + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF - xmas(mgs,lr) = xv(mgs,lr)*xdn(mgs,lr) - xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) ! xdia(mgs,lr,1) - IF ( imurain == 3 ) THEN -! xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/(alpha(mgs,lr)+1.))**(1./3.) - xdia(mgs,lr,1) = xdia(mgs,lr,3) ! formulae for Ziegler (1985) use mean volume diameter, not lambda**(-1) - ELSE ! imurain == 1, Characteristic diameter (1/lambda) - xdia(mgs,lr,1) = (6.*pii*xv(mgs,lr)/((alpha(mgs,lr)+3.)*(alpha(mgs,lr)+2.)*(alpha(mgs,lr)+1.)))**(1./3.) - ENDIF -! rwrad(mgs) = 0.5*xdia(mgs,lr,1) + ELSE ! imurain == 1 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lr) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami -! Inverse exponential version: -! xdia(mgs,lr,1) = -! & (qx(mgs,lr)*rho0(mgs) -! & /(pi*xdn(mgs,lr)*cx(mgs,lr)))**(0.333333) - ELSE - xdia(mgs,lr,1) = & - & (qx(mgs,lr)*rho0(mgs)/(pi*xdn(mgs,lr)*cno(lr)))**(0.25) - xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 - xdia(mgs,lr,3) = (xmas(mgs,lr)*cwc1)**(1./3.) - cx(mgs,lr) = cno(lr)*xdia(mgs,lr,1) - xv(mgs,lr) = rho0(mgs)*qx(mgs,lr)/(xdn(mgs,lr)*cx(mgs,lr)) - end if - else - xdia(mgs,lr,1) = 1.e-9 - xdia(mgs,lr,3) = 1.e-9 - xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 -! rwrad(mgs) = 0.5*xdia(mgs,lr,1) - end if - xdia(mgs,lr,2) = xdia(mgs,lr,1)**2 -! xmas(mgs,lr) = xdn(mgs,lr)*(pi/6.)*xdia(mgs,lr,1)**3 - end do - - ENDIF -! ################################################################ -! -! SNOW -! + IF ( iferwisventr == 1 ) THEN - IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN - - do mgs = 1,ngscnt - if ( qx(mgs,ls) .gt. qxmin(ls) ) then - if ( ipconc .ge. 4 ) then ! + alpr = Min(alpharmax,alpha(mgs,lr) ) - xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls))) -! parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 ) ! mks - xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls) + x = 1. + alpha(mgs,lr) - IF ( xv(mgs,ls) .lt. xvmn(ls) .or. xv(mgs,ls) .gt. xvmx(ls) ) THEN - xv(mgs,ls) = Min( xvmx(ls), Max( xvmn(ls),xv(mgs,ls) ) ) - xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls) - cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls)) + IF ( lzr > 1 ) THEN ! 3 moment + ELSE + y = ventrxn(mgs) ENDIF - xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) - xdia(mgs,ls,3) = xdia(mgs,ls,1) + vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) + vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr)) + + + rwvent(mgs) = & + & 0.78*x + & + & 0.308*fvent(mgs)*y* & + & Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2) + + ELSEIF ( iferwisventr == 2 ) THEN + +! Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier's rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br + x = 1. + alpha(mgs,lr) + + rwvent(mgs) = & + & (0.78*x + 0.308*ventrxn(mgs)*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + + ENDIF ! iferwisventr + + ENDIF ! imurain + ELSE + rwvent(mgs) = & + & (rwventa + rwventb*fvent(mgs) & + & *Sqrt((ar*rhovt(mgs))) & + & *(xdia(mgs,lr,1)**((1.0+br)/2.0)) ) + ENDIF ELSE - xdia(mgs,ls,1) = & - & (qx(mgs,ls)*rho0(mgs)/(pi*xdn(mgs,ls)*cnostmp(mgs)))**(0.25) - cx(mgs,ls) = cnostmp(mgs)*xdia(mgs,ls,1) - xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*cx(mgs,ls)) - xdia(mgs,ls,3) = (xv(mgs,ls)*cwc0*6.0)**(1./3.) - end if - else - xdia(mgs,ls,1) = 1.e-9 - xdia(mgs,ls,3) = 1.e-9 - cx(mgs,ls) = 0.0 - end if - xdia(mgs,ls,2) = xdia(mgs,ls,1)**2 -! swdia3(mgs) = xdia(mgs,ls,2)*xdia(mgs,ls,1) -! xmas(mgs,ls) = xdn(mgs,ls)*(pi/6.)*swdia3(mgs) + rwvent(mgs) = 0.0 + ENDIF end do - - ENDIF ! ls .gt 1 -! ! -! ################################################################ + igmswa = 100.0*2.0 + igmswb = 100.*((5.0+ds)/2.0) + swventa = (0.78)*gmoi(igmswa) + swventb = (0.308)*gmoi(igmswb) + do mgs = 1,ngscnt + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + IF ( ipconc .ge. 4 ) THEN + swvent(mgs) = 0.65 + 0.44*fvent(mgs)*Sqrt(vtxbar(mgs,ls,1)*xdia(mgs,ls,1)) + ELSE +! 10-ice version: + swvent(mgs) = & + & (swventa + swventb*fvent(mgs) & + & *Sqrt((cs*rhovt(mgs))) & + & *(xdia(mgs,ls,1)**((1.0+ds)/2.0)) ) + ENDIF + ELSE + swvent(mgs) = 0.0 + ENDIF + end do ! -! GRAUPEL ! - IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN - - do mgs = 1,ngscnt - if ( qx(mgs,lh) .gt. qxmin(lh) ) then - if ( ipconc .ge. 5 ) then - - xv(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*Max(1.0e-9,cx(mgs,lh))) - xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) - - IF ( xv(mgs,lh) .lt. xvmn(lh) .or. xv(mgs,lh) .gt. xvmx(lh) ) THEN - xv(mgs,lh) = Min( xvmx(lh), Max( xvmn(lh),xv(mgs,lh) ) ) - xmas(mgs,lh) = xv(mgs,lh)*xdn(mgs,lh) - cx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/(xmas(mgs,lh)) - ENDIF - - xdia(mgs,lh,3) = (xv(mgs,lh)*6.*pii)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) - IF ( dmuh == 1.0 ) THEN - xdia(mgs,lh,1) = cwch(mgs)*xdia(mgs,lh,3) - ELSE - xdia(mgs,lh,1) = (xv(mgs,lh)*cwch(mgs))**(1./3.) - ENDIF + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) + hwventc = (4.0*gr/(3.0*cdx(lh)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + IF ( .false. .or. alpha(mgs,lh) .eq. 0.0 ) THEN + hwvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lh)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lh,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lh) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + +! note that hwvent includes a division by Gamma(1+alpha), so Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y + x = 1. + alpha(mgs,lh) + + tmp = 1 + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + tmp = 2.5 + alpha(mgs,lh) + 0.5*bxh(mgs) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp + + + hwventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lh,1)**(0.5 + 0.5*bxh(mgs)))*Sqrt(axh(mgs)*rhovt(mgs)) + hwvent(mgs) = & + & ( 0.78*x + y*hwventy(mgs) ) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lh,1)**(0.5 + 0.5*bxh(mgs)))* & +! & Sqrt(axh(mgs)*rhovt(mgs)) ) + + ENDIF ELSE - xdia(mgs,lh,1) = & - & (qx(mgs,lh)*rho0(mgs)/(pi*xdn(mgs,lh)*cno(lh)))**(0.25) - cx(mgs,lh) = cno(lh)*xdia(mgs,lh,1) - xv(mgs,lh) = Max(xvmn(lh), rho0(mgs)*qx(mgs,lh)/(xdn(mgs,lh)*cx(mgs,lh)) ) - xdia(mgs,lh,3) = (xv(mgs,lh)*6./pi)**(1./3.) - end if - else - xdia(mgs,lh,1) = 1.e-9 - xdia(mgs,lh,3) = 1.e-9 - end if - xdia(mgs,lh,2) = xdia(mgs,lh,1)**2 -! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) -! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + hwvent(mgs) = 0.0 + hwventy(mgs) = 0.0 + ENDIF end do - ENDIF + hlvent(:) = 0.0 + hlventy(:) = 0.0 -! -! ################################################################ -! -! HAIL -! + IF ( lhl .gt. 1 ) THEN + igmhwa = 100.0*2.0 + igmhwb = 100.0*2.75 + hwventa = (0.78)*gmoi(igmhwa) + hwventb = (0.308)*gmoi(igmhwb) + hwventc = (4.0*gr/(3.0*cdx(lhl)))**(0.25) + do mgs = 1,ngscnt + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN - IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN - - do mgs = 1,ngscnt - if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then - if ( ipconc .ge. 5 ) then + IF ( .false. .or. alpha(mgs,lhl) .eq. 0.0 ) THEN + hlvent(mgs) = & + & ( hwventa + hwventb*hwventc*fvent(mgs) & + & *((xdn(mgs,lhl)/rho0(mgs))**(0.25)) & + & *(xdia(mgs,lhl,1)**(0.75))) + ELSE ! Ferrier 1994, eq. B.36 + ! linear interpolation of complete gamma function +! tmp = 2. + alpha(mgs,lhl) +! i = Int(dgami*(tmp)) +! del = tmp - dgam*i +! x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - xv(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*Max(1.0e-9,cx(mgs,lhl))) - xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) -! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xmas(mgs,lhl),qx(mgs,lhl) +! note that hlvent includes a division by Gamma(1+alpha), so x = Gamma(2+alpha)/Gamma(1+alpha) = 1 + alpha +! and g1palp = Gamma(1+alpha) divides into y - IF ( xv(mgs,lhl) .lt. xvmn(lhl) .or. xv(mgs,lhl) .gt. xvmx(lhl) ) THEN - xv(mgs,lhl) = Min( xvmx(lhl), Max( xvmn(lhl),xv(mgs,lhl) ) ) - xmas(mgs,lhl) = xv(mgs,lhl)*xdn(mgs,lhl) - cx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/(xmas(mgs,lhl)) - ENDIF + x = 1. + alpha(mgs,lhl) - xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) ! mwfac*xdia(mgs,lh,1) ! (xv(mgs,lh)*cwc0*6.0)**(1./3.) - IF ( dmuhl == 1.0 ) THEN - xdia(mgs,lhl,1) = cwchl(mgs)*xdia(mgs,lhl,3) - ELSE - xdia(mgs,lhl,1) = (xv(mgs,lhl)*cwchl(mgs))**(1./3.) - ENDIF + tmp = 1 + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + tmp = 2.5 + alpha(mgs,lhl) + 0.5*bxhl(mgs) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions + + hlventy(mgs) = 0.308*fvent(mgs)*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxhl(mgs)))*Sqrt(axhl(mgs)*rhovt(mgs)) -! write(0,*) 'setvt: xv = ',xv(mgs,lhl),xdn(mgs,lhl),cx(mgs,lhl),xdia(mgs,lhl,3) - ELSE - xdia(mgs,lhl,1) = & - & (qx(mgs,lhl)*rho0(mgs)/(pi*xdn(mgs,lhl)*cno(lhl)))**(0.25) - cx(mgs,lhl) = cno(lhl)*xdia(mgs,lhl,1) - xv(mgs,lhl) = Max(xvmn(lhl), rho0(mgs)*qx(mgs,lhl)/(xdn(mgs,lhl)*cx(mgs,lhl)) ) - xdia(mgs,lhl,3) = (xv(mgs,lhl)*6./pi)**(1./3.) - end if - else - xdia(mgs,lhl,1) = 1.e-9 - xdia(mgs,lhl,3) = 1.e-9 - end if - xdia(mgs,lhl,2) = xdia(mgs,lhl,1)**2 -! hwdia3(mgs) = xdia(mgs,lh,2)*xdia(mgs,lh,1) -! xmas(mgs,lh) = xdn(mgs,lh)*(pi/6.)*hwdia3(mgs) + hlvent(mgs) = 0.78*x + y*hlventy(mgs) ! & +! & 0.308*fvent(mgs)*y*(xdia(mgs,lhl,1)**(0.5 + 0.5*bxhl(mgs)))* & +! & Sqrt(axhl(mgs)*rhovt(mgs))) +! : Sqrt(xdn(mgs,lhl)*ax(lhl)*rhovt(mgs)/rg0))/tmp + + ENDIF + ENDIF end do - ENDIF -! + ! ! -! Set terminal velocities... -! also set drag coefficients (moved to start of subroutine) ! -! cdx(lr) = 0.60 -! cdx(lh) = 0.45 -! cdx(lhl) = 0.45 -! cdx(lf) = 0.45 -! cdx(lgh) = 0.60 -! cdx(lgm) = 0.80 -! cdx(lgl) = 0.80 -! cdx(lir) = 2.00 +! Wet growth constants ! - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set terminal velocities' + do mgs = 1,ngscnt + fwet1(mgs) = & + & (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*rho0(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs) ) & + & / ( rho0(mgs)*(felf(mgs)+fcw(mgs)*temcg(mgs)) ) + fwet2(mgs) = & + & (1.0)-fci(mgs)*temcg(mgs) & + & / ( felf(mgs)+fcw(mgs)*temcg(mgs) ) + end do ! +! Melting constants ! -! ################################################################ + do mgs = 1,ngscnt + fmlt1(mgs) = (2.0*pi)* & + & ( felv(mgs)*fwvdf(mgs)*(qss0(mgs)-qx(mgs,lv)) & + & -ftka(mgs)*temcg(mgs)/rho0(mgs) ) & + & / (felf(mgs)) + fmlt2(mgs) = -fcw(mgs)*temcg(mgs)/felf(mgs) + end do ! -! RAIN +! Vapor Deposition constants ! - IF ( ildo == 0 .or. ildo == lr ) THEN do mgs = 1,ngscnt - if ( qx(mgs,lr) .gt. qxmin(lr) ) then - IF ( ipconc .lt. 3 ) THEN - vtxbar(mgs,lr,1) = rainfallfac*(ar*gf4br/6.0)*(xdia(mgs,lr,1)**br)*rhovt(mgs) -! write(91,*) 'vtxbar: ',vtxbar(mgs,lr,1),mgs,gf4br,xdia(mgs,lr,1),rhovt(mgs) - ELSE - - IF ( imurain == 1 ) THEN ! DSD of Diameter - - ! using functional form of arx*(1 - Exp(-frx*diameter) ), with arx = arx = 10. - ! and frx = 516.575 ! raind fit parameters for arx*(1 - Exp(-fx*d)), where d is rain diameter in meters. + fvds(mgs) = & + & (4.0*pi/rho0(mgs))*(ssi(mgs)-1.0)* & + & (1.0/(fai(mgs)+fbi(mgs))) + end do + do mgs = 1,ngscnt + fvce(mgs) = & + & (4.0*pi/rho0(mgs))*(ssw(mgs)-1.0)* & + & (1.0/(fav(mgs)+fbv(mgs))) + end do - - alp = alpha(mgs,lr) - - vtxbar(mgs,lr,1) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 4.0) ) ! mass weighted - - IF ( infdo .ge. 1 .and. rssflg == 1 ) THEN - vtxbar(mgs,lr,2) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 1.0) ) ! number weighted - ELSE - vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) - ENDIF - - IF ( infdo .ge. 2 .and. rssflg == 1 ) THEN - vtxbar(mgs,lr,3) = rhovt(mgs)*arx*(1.0 - (1.0 + frx*xdia(mgs,lr,1))**(-alp - 7.0) ) ! z-weighted - ELSE - vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) - ENDIF - -! write(91,*) 'setvt: alp,vn,vm,vz = ',alp,vtxbar(mgs,lr,2), vtxbar(mgs,lr,1), vtxbar(mgs,lr,3),alpha(mgs,lr) +! +! deposition, sublimation, and melting of snow, graupel and hail +! + qsmlr(:) = 0.0 + qimlr(:) = 0.0 ! this is not used. qi melts to qc way down in the code. + qhmlr(:) = 0.0 + qhlmlr(:) = 0.0 + qhmlrlg(:) = 0.0 + qhlmlrlg(:) = 0.0 + qhfzh(:) = 0.0 + qhlfzhl(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + qsfzs(:) = 0.0 + zsmlr(:) = 0.0 + zhmlr(:) = 0.0 + zhmlrr(:) = 0.0 + zhshr(:) = 0.0 + zhlmlr(:) = 0.0 + zhlshr(:) = 0.0 - ELSEIF ( imurain == 3 ) THEN ! DSD of Volume - - IF ( lzr < 1 ) THEN ! not 3-moment rain - rwdia = Min( xdia(mgs,lr,1), 8.0e-3 ) - - vtxbar(mgs,lr,1) = rhovt(mgs)*6.0*pii*( 0.04771 + 3788.0*rwdia - & - & 1.105e6*rwdia**2 + 1.412e8*rwdia**3 - 6.527e9*rwdia**4) - - IF ( infdo .ge. 1 ) THEN - vtxbar(mgs,lr,2) = (0.09112 + 2714.0*rwdia - 4.872e5*rwdia**2 + & - & 4.495e7*rwdia**3 - 1.626e9*rwdia**4)*rhovt(mgs) - ENDIF - - IF ( infdo .ge. 2 ) THEN ! Z-weighted fall speed - vtxbar(mgs,lr,3) = rhovt(mgs)*( & - & 0.0911229 + & - & 9246.494*(rwdia) - & - & 3.2839926e6*(rwdia**2) + & - & 4.944093e8*(rwdia**3) - & - & 2.631718e10*(rwdia**4) ) - ENDIF - - ELSE ! 3-moment rain, gamma-volume + zhshrr(:) = 0.0 + zhlmlrr(:) = 0.0 + zhlshrr(:) = 0.0 - vr = xv(mgs,lr) - rnux = alpha(mgs,lr) - - IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag - vtxbar(mgs,lr,2) = rhovt(mgs)* & - & (((1. + rnux)/vr)**(-1.333333)* & - & (0.0911229*((1. + rnux)/vr)**1.333333*Gamma(1. + rnux) + & - & (5430.3131*(1. + rnux)*Gamma(4./3. + rnux))/ & - & vr - 1.0732802e6*((1. + rnux)/vr)**0.6666667* & - & Gamma(1.666667 + rnux) + & - & 8.584110982429507e7*((1. + rnux)/vr)**(1./3.)* & - & Gamma(2. + rnux) - & - & 2.3303765697228556e9*Gamma(7./3. + rnux)))/ & - & Gamma(1. + rnux) - ENDIF + csmlr(:) = 0.0 + chmlr(:) = 0.0 + chmlrr(:) = 0.0 + chlmlr(:) = 0.0 + chlmlrr(:) = 0.0 -! mass-weighted - vtxbar(mgs,lr,1) = rhovt(mgs)* & - & (0.0911229*(1 + rnux)**1.3333333333333333*Gamma(2. + rnux) + & - & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & - & Gamma(2.333333333333333 + rnux) - & - & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666*vr**0.6666666666666666* & - & Gamma(2.6666666666666667 + rnux) + & - & 8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma(3 + rnux) - & - & 2.3303765697228556e9*vr**1.3333333333333333* & - & Gamma(3.333333333333333 + rnux))/ & - & ((1 + rnux)**2.333333333333333*Gamma(1 + rnux)) - - IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted - vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1) - ENDIF + if ( .not. mixedphase ) then !{ + do mgs = 1,ngscnt +! + IF ( temg(mgs) .gt. tfr ) THEN - IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed - vtxbar(mgs,lr,3) = rhovt(mgs)* & - & ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma(3. + rnux) + & - & 5430.313059683277*(1 + rnux)*vr**0.3333333333333333* & - & Gamma(3.3333333333333335 + rnux) - & - & 1.0732802065650471e6*(1 + rnux)**0.6666666666666666* & - & vr**0.6666666666666666*Gamma(3.6666666666666665 + rnux) + & - & 8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*Gamma(4. + rnux) - & - & 2.3303765697228556e9*vr**1.3333333333333333* & - & Gamma(4.333333333333333 + rnux)))/ & - & ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma(1 + rnux)) - -! write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo -! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) - - ELSEIF (infdo .ge. 2) THEN ! No size-sorting, set Z-weighted fall speed to mass-weighted - vtxbar(mgs,lr,3) = vtxbar(mgs,lr,1) - ENDIF - + IF ( qx(mgs,ls) .gt. qxmin(ls) ) THEN + qsmlr(mgs) = & + & min( & + & (c1sw*fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) ) & ! /rhosm & + & , 0.0 ) + ENDIF + +! IF ( qx(mgs,ls) .gt. 0.1e-4 ) write(0,*) 'qsmlr: ',qsmlr(mgs),qx(mgs,ls),cx(mgs,ls),fmlt1(mgs), +! : temcg(mgs),swvent(mgs),xdia(mgs,ls,1),qss0(mgs)-qx(mgs,lv) +! ELSE +! qsmlr(mgs) = 0.0 +! ENDIF +! 10ice version: +! > min( +! > (fmlt1(mgs)*cx(mgs,ls)*swvent(mgs)*xdia(mgs,ls,1) + +! > fmlt2(mgs)*(qsacr(mgs)+qsacw(mgs)) ) +! < , 0.0 ) + + IF ( qx(mgs,lh) .gt. qxmin(lh) ) THEN + + IF ( ibinhmlr == 0 .or. lzh < 1 ) THEN + qhmlr(mgs) = & + & min( & + & fmlt1(mgs)*cx(mgs,lh)*hwvent(mgs)*xdia(mgs,lh,1) & + & + fmlt2(mgs)*(qhacrmlr(mgs)+qhacw(mgs)) & + & , 0.0 ) + ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + + ENDIF + + + IF ( ivhmltsoak > 0 .and. qhmlr(mgs) < 0.0 .and. lvol(lh) > 1 .and. xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! act as if 100% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*(vx(mgs,lh) + rho0(mgs)*qhmlr(mgs)/xdn(mgs,lh) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhmlr(mgs)/xdnmx(lh) ! volume of melted ice if it were refrozen in the matrix + + vhsoak(mgs) = Min(v1,v2) + + ENDIF + + ENDIF ! qx(mgs,lh) .gt. qxmin(lh) + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) THEN + + IF ( qx(mgs,lhl) .gt. qxmin(lhl) ) THEN + IF ( ibinhlmlr == 0 .or. lzhl < 1) THEN + qhlmlr(mgs) = & + & min( & + & fmlt1(mgs)*cx(mgs,lhl)*hlvent(mgs)*xdia(mgs,lhl,1) & + & + fmlt2(mgs)*(qhlacrmlr(mgs)+qhlacw(mgs)) & + & , 0.0 ) + + ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + + ENDIF ! ibinhlmlr + + + IF ( ivhmltsoak > 0 .and. qhlmlr(mgs) < 0.0 .and. lvol(lhl) > 1 .and. xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! act as if 50% of the meltwater were soaked into the graupel + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*(vx(mgs,lhl) + rho0(mgs)*qhlmlr(mgs)/xdn(mgs,lhl) )/(dtp) ! volume available for filling + v2 = -1.0*rho0(mgs)*qhlmlr(mgs)/xdnmx(lhl) ! volume of melted ice if it were refrozen in the matrix + + vhlsoak(mgs) = Min(v1,v2) + + ENDIF ENDIF - ENDIF ! imurain + ENDIF -! IF ( rwrad*mwfac .gt. 6.0e-4 ) THEN -! vtxbar(mgs,lr,1) = 20.1*Sqrt(100.*rwrad*mwfac)*rhovt(mgs) -! ELSE -! vtxbar(mgs,lr,1) = 80.0e2*rwrad*rhovt(mgs)*mwfac -! ENDIF -! IF ( rwrad .gt. 6.0e-4 ) THEN -! vtxbar(mgs,lr,2) = 20.1*Sqrt(100.*rwrad)*rhovt(mgs) -! ELSE -! vtxbar(mgs,lr,2) = 80.0e2*rwrad*rhovt(mgs) -! ENDIF - ENDIF ! ipconc - else ! qr < qrmin - vtxbar(mgs,lr,1) = 0.0 - vtxbar(mgs,lr,2) = 0.0 - end if - end do - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set rain vt' - ENDIF + ! -! ################################################################ +! qimlr(mgs) = max( qimlr(mgs), -qimxd(mgs) ) +! qsmlr(mgs) = max( qsmlr(mgs), -qsmxd(mgs) ) +! erm 5/10/2007 changed to next line: + if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)/dtp ) ) + if ( .not. mixedphase ) qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.5*qx(mgs,lh)/dtp ) ) +! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)/dtp ) !limits to 1/2 qh or max depletion + qhmlh(mgs) = 0. + + + ! Rasmussen and Heymsfield say melt water remains on graupel up to 9 mm before shedding + + + IF ( lhl .gt. 1 .and. lhlw < 1 ) qhlmlr(mgs) = max( qhlmlr(mgs), Min( -qxmxd(mgs,lhl), -0.5*qx(mgs,lhl)/dtp ) ) + ! -! SNOW !Zrnic et al. (1993) + end do + + endif ! } not mixedphase ! - IF ( ls .gt. 1 .and. ( ildo == 0 .or. ildo == ls ) ) THEN + if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt - if ( qx(mgs,ls) .gt. qxmin(ls) ) then - IF ( ipconc .ge. 4 ) THEN - if ( mixedphase .and. qsvtmod ) then - else - vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.) - IF(sssflg == 1) THEN - vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.) + cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs) + + IF ( .not. mixedphase ) THEN + IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN +! csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm) + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsmlr(mgs) + ELSE + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsmlr(mgs) + ENDIF + + +! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN +! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail +! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) ) +! ELSE + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) +! ENDIF + + + IF ( chmlr(mgs) < 0.0 ) THEN + + IF ( ihmlt .eq. 1 ) THEN + chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN +! chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain +! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas + IF(imltshddmr > 0) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop + tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) + chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs))) + ELSE ! Old method + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! into rain + ENDIF + ELSE + chmlrr(mgs) = chmlr(mgs) + ENDIF + ELSEIF ( ihmlt .eq. 0 ) THEN + chmlrr(mgs) = chmlr(mgs) + ENDIF + + ENDIF ! chmlr(mgs) < 0.0 + + IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN ! { + +! IF ( xdia(mgs,lhl,1) .gt. 1.e-6 .and. Abs(qhlmlr(mgs)) .ge. qxmin(lhl) ) THEN +! chlmlr(mgs) = rho0(mgs)*qhlmlr(mgs)/(pi*xdn(mgs,lhl)*xdia(mgs,lhl,1)**3) ! out of hail +! chlmlr(mgs) = Max( chlmlr(mgs), -cxmxd(mgs,lhl) ) +! ELSE + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlmlr(mgs) +! ENDIF + + IF ( ihmlt .eq. 1 ) THEN + chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain + ELSEIF ( ihmlt .eq. 2 ) THEN + IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain +! chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain + IF(imltshddmr > 0) THEN + tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size + tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam) + chlmlrr(mgs) = -Max(tmp,Min(tmp2,chlmlrr(mgs))) ELSE - vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain ENDIF - vtxbar(mgs,ls,3) = vtxbar(mgs,ls,1) - endif ELSE - vtxbar(mgs,ls,1) = (cs*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) - vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) + chlmlrr(mgs) = chlmlr(mgs) ENDIF - else - vtxbar(mgs,ls,1) = 0.0 - end if + ELSEIF ( ihmlt .eq. 0 ) THEN + chlmlrr(mgs) = chlmlr(mgs) + ENDIF + + ENDIF ! } + + ENDIF ! .not. mixedphase + +! 10ice versions: +! chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) +! chmlrr(mgs) = chmlr(mgs) end do - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set snow vt' - - ENDIF ! ls .gt. 1 + end if + ! +! deposition/sublimation of ice ! -! ################################################################ + DO mgs = 1,ngscnt + + rwcap(mgs) = (0.5)*xdia(mgs,lr,1) + swcap(mgs) = (0.5)*xdia(mgs,ls,1) + hwcap(mgs) = (0.5)*xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) hlcap(mgs) = (0.5)*xdia(mgs,lhl,1) + + if ( qx(mgs,li).gt.qxmin(li) .and. xdia(mgs,li,1) .gt. 0.0 ) then ! -! GRAUPEL !Wisner et al. (1972) +! from Cotton, 1972 (Part II) ! - IF ( lh .gt. 1 .and. ( ildo == 0 .or. ildo == lh ) ) THEN - - do mgs = 1,ngscnt - vtxbar(mgs,lh,1) = 0.0 - if ( qx(mgs,lh) .gt. qxmin(lh) ) then - IF ( icdx .eq. 1 ) THEN - cd = cdx(lh) - ELSEIF ( icdx .eq. 2 ) THEN -! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) -! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) - cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) -! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) - ELSEIF ( icdx .eq. 3 ) THEN -! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 300.) ) ) - cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) - ELSEIF ( icdx .eq. 4 ) THEN - cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & - & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) - ELSEIF ( icdx .eq. 5 ) THEN - cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2/3) - ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) - indxr = Int( (xdn(mgs,lh)-50.)/100. ) + 1 - indxr = Min( ngdnmm, Max(1,indxr) ) - - - delrho = Max( 0.0, 0.01*(xdn(mgs,lh) - mmgraupvt(indxr,1)) ) - IF ( indxr < ngdnmm ) THEN - - axh(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) - bxh(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) - - - ELSE - axh(mgs) = mmgraupvt(indxr,2) - bxh(mgs) = mmgraupvt(indxr,3) - ENDIF - - aax = axh(mgs) - bbx = bxh(mgs) - - ENDIF - - IF ( alpha(mgs,lh) .eq. 0.0 .and. icdx > 0 .and. icdx /= 6 ) THEN - vtxbar(mgs,lh,1) = (gf4p5/6.0)* & - & Sqrt( (xdn(mgs,lh)*xdia(mgs,lh,1)*4.0*gr) / & - & (3.0*cd*rho0(mgs)) ) + cilen(mgs) = 0.4764*(xdia(mgs,li,1))**(0.958) + cval = xdia(mgs,li,1) + aval = cilen(mgs) + eval = Sqrt(1.0-(aval**2)/(cval**2)) + fval = min(0.99,eval) + gval = alog( abs( (1.+fval)/(1.-fval) ) ) + cicap(mgs) = cval*fval / gval ELSE - IF ( icdx /= 6 ) bbx = bx(lh) - tmp = 4. + alpha(mgs,lh) + bbx - i = Int(dgami*(tmp)) - del = tmp - dgam*i - x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - - tmp = 4. + alpha(mgs,lh) - i = Int(dgami*(tmp)) - del = tmp - dgam*i - y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - -! aax = Max( 1.0, Min(2.0, (xdn(mgs,lh)/400.) ) ) -! vtxbar(mgs,lh,1) = rhovt(mgs)*aax*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y - - IF ( icdx > 0 .and. icdx /= 6) THEN - aax = Sqrt(4.0*xdn(mgs,lh)*gr/(3.0*cd*rho00)) - vtxbar(mgs,lh,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lh,1)) * x/y - ELSEIF (icdx == 6 ) THEN - vtxbar(mgs,lh,1) = rhovt(mgs)*aax* xdia(mgs,lh,1)**bbx * x/y - ELSE - vtxbar(mgs,lh,1) = rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y - ENDIF + cicap(mgs) = 0.0 + end if + ENDDO +! +! + qhldsv(:) = 0.0 -! & Gamma(4.0 + dnu(lh) + 0.6))/Gamma(4. + dnu(lh)) + do mgs = 1,ngscnt + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN + qidsv(mgs) = & + & fvds(mgs)*cx(mgs,li)*civent(mgs)*cicap(mgs) + qsdsv(mgs) = & + & fvds(mgs)*cx(mgs,ls)*swvent(mgs)*swcap(mgs) +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidsv = ',nstep,kgs(mgs),qidsv(mgs),temg(mgs)-tfrh,100.*(qx(mgs,lv)/qis(mgs) - 1.),1.e6*xdia(mgs,li,1), +! : fvds(mgs),civent(mgs),cicap(mgs) +! ENDIF + ELSE + qidsv(mgs) = 0.0 + qsdsv(mgs) = 0.0 ENDIF + qhdsv(mgs) = & + & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs) - IF ( lwsm6 .and. ipconc == 0 ) THEN -! vtxbar(mgs,lh,1) = (330.*gf4ds/6.0)*(xdia(mgs,ls,1)**ds)*rhovt(mgs) - vtxbar(mgs,lh,1) = (330.*gf4br/6.0)*(xdia(mgs,lh,1)**br)*rhovt(mgs) - ENDIF - - end if - end do - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' - - ENDIF ! lh .gt. 1 -! + IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs) ! -! ################################################################ ! -! HAIL + end do ! - IF ( lhl .gt. 1 .and. ( ildo == 0 .or. ildo == lhl ) ) THEN - do mgs = 1,ngscnt - vtxbar(mgs,lhl,1) = 0.0 - if ( qx(mgs,lhl) .gt. qxmin(lhl) ) then - - IF ( icdxhl .eq. 1 ) THEN - cd = cdx(lhl) - ELSEIF ( icdxhl .eq. 3 ) THEN -! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) - cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) - ELSEIF ( icdxhl .eq. 4 ) THEN - cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & - & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) - ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) - indxr = Int( (xdn(mgs,lhl)-50.)/100. ) + 1 - indxr = Min( ngdnmm, Max(1,indxr) ) - - - delrho = Max( 0.0, 0.01*(xdn(mgs,lhl) - mmgraupvt(indxr,1)) ) - IF ( indxr < ngdnmm ) THEN - - axhl(mgs) = mmgraupvt(indxr,2) + delrho*(mmgraupvt(indxr+1,2) - mmgraupvt(indxr,2) ) - bxhl(mgs) = mmgraupvt(indxr,3) + delrho*(mmgraupvt(indxr+1,3) - mmgraupvt(indxr,3) ) - - - ELSE - axhl(mgs) = mmgraupvt(indxr,2) - bxhl(mgs) = mmgraupvt(indxr,3) - ENDIF - - aax = axhl(mgs) - bbx = bxhl(mgs) - - ELSE -! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) -! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) - cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) - ENDIF - - IF ( alpha(mgs,lhl) .eq. 0.0 .and. icdxhl > 0 ) THEN - vtxbar(mgs,lhl,1) = (gf4p5/6.0)* & - & Sqrt( (xdn(mgs,lhl)*xdia(mgs,lhl,1)*4.0*gr) / & - & (3.0*cd*rho0(mgs)) ) + IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & + & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN +! qisbv(mgs) = max( min(qidsv(mgs), 0.0), -qimxd(mgs) ) +! qssbv(mgs) = max( min(qsdsv(mgs), 0.0), -qsmxd(mgs) ) +! erm 5/10/2007: + qisbv(mgs) = max( min(qidsv(mgs), 0.0), Min( -qimxd(mgs), -0.7*qx(mgs,li)/dtp ) ) + qssbv(mgs) = max( min(qsdsv(mgs), 0.0), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)/dtp ) ) + qidpv(mgs) = Max(qidsv(mgs), 0.0) + qsdpv(mgs) = Max(qsdsv(mgs), 0.0) ELSE - IF ( icdx /= 6 ) bbx = bx(lhl) - tmp = 4. + alpha(mgs,lhl) + bbx - i = Int(dgami*(tmp)) - del = tmp - dgam*i - x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 + ENDIF - tmp = 4. + alpha(mgs,lhl) - i = Int(dgami*(tmp)) - del = tmp - dgam*i - y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + qhsbv(mgs) = max( min(qhdsv(mgs), 0.0), -qhmxd(mgs) ) - IF ( icdxhl > 0 .and. icdxhl /= 6) THEN - aax = Sqrt(4.0*xdn(mgs,lhl)*gr/(3.0*cd*rho00)) - vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* Sqrt(xdia(mgs,lhl,1)) * x/y - ELSEIF ( icdx == 6 ) THEN - vtxbar(mgs,lhl,1) = rhovt(mgs)*aax* (xdia(mgs,lhl,1))**bbx * x/y - ELSE - vtxbar(mgs,lhl,1) = rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y - ENDIF - -! & Gamma(4.0 + dnu(lh) + 0.6))/Gamma(4. + dnu(lh)) - ENDIF + qhdpv(mgs) = Max(qhdsv(mgs), 0.0) - end if - end do - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt' - - ENDIF ! lhl .gt. 1 + qhlsbv(mgs) = 0.0 + qhldpv(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) + qhldpv(mgs) = Max(qhldsv(mgs), 0.0) + ENDIF + temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) - IF ( infdo .ge. 1 ) THEN + IF ( temp1 .gt. qvimxd(mgs) ) THEN -! DO il = lc,lhab -! IF ( il .ne. lr ) THEN - DO mgs = 1,ngscnt - vtxbar(mgs,lc,2) = vtxbar(mgs,lc,1) - IF ( li .gt. 1 ) THEN -! vtxbar(mgs,li,2) = rhovt(mgs)*49420.*1.25447*xdia(mgs,li,1)**(1.415) ! n-wgt (Ferrier 94) -! vtxbar(mgs,li,2) = vtxbar(mgs,li,1) + frac = qvimxd(mgs)/temp1 -! test print stuff... -! IF ( xdia(mgs,li,1) .gt. 200.e-6 ) THEN -! tmp = (xv(mgs,li)*cwc0)**(1./3.) -! x = rhovt(mgs)*49420.*40.0005/5.40662*tmp**(1.415) -! y = rhovt(mgs)*49420.*1.25447*tmp**(1.415) -! write(6,*) 'Ice fall: ',vtxbar(mgs,li,1),x,y,tmp,xdia(mgs,li,1) -! ENDIF - ENDIF -! vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) - ENDDO + qidpv(mgs) = frac*qidpv(mgs) + qsdpv(mgs) = frac*qsdpv(mgs) + qhdpv(mgs) = frac*qhdpv(mgs) + qhldpv(mgs) = frac*qhldpv(mgs) - IF ( lg .gt. lr ) THEN +! IF ( ny .eq. 2 .and. igs(mgs) .eq. 302 .and. temg(mgs) .le. tfrh+10 .and. qx(mgs,lv) .gt. qis(mgs) +! : .and. qx(mgs,li) .gt. qxmin(li) ) THEN +! write(0,*) 'qidpv,frac = ',kgs(mgs),qidpv(mgs),frac +! ENDIF - DO il = lg,lhab - IF ( ildo == 0 .or. ildo == il ) THEN + ENDIF - DO mgs = 1,ngscnt - IF ( qx(mgs,il) .gt. qxmin(il) ) THEN - IF ( (il .eq. lh .and. hssflg == 1) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 1) ) THEN ! DTD: added flag for size-sorting - - ! DTD: allow for setting of number-weighted and z-weighted fall speeds to the mass-weighted value, - ! effectively turning off size-sorting + end do +! +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cssbv(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qssbv(mgs) + cisbv(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qisbv(mgs) + chsbv(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhsbv(mgs) + IF ( lhl .gt. 1 ) chlsbv(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlsbv(mgs) + csdpv(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsdpv(mgs) + cidpv(mgs) = 0.0 ! (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qidpv(mgs) + chdpv(mgs) = 0.0 ! (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhdpv(mgs) + chldpv(mgs) = 0.0 + end do + end if - IF ( il .eq. lh ) THEN ! { - - IF ( icdx .eq. 1 ) THEN - cd = cdx(lh) - ELSEIF ( icdx .eq. 2 ) THEN -! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(xdnmx(lh) - xdn(mgs,lh))/(xdnmx(lh)-xdnmn(lh)) ) ) -! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lh))/(900. - 300.) ) ) - cd = Max(0.45, Min(1.0, 0.45 + 0.35*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) -! cd = Max(0.55, Min(1.0, 0.55 + 0.25*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 500.) ) ) - ELSEIF ( icdx .eq. 3 ) THEN -! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) - cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lh) ) ) )/(800. - 170.0) ) ) - ELSEIF ( icdx .eq. 4 ) THEN - cd = Max(cdhmin, Min(cdhmax, cdhmin + (cdhmax-cdhmin)* & - & (cdhdnmax - Max( cdhdnmin, Min( cdhdnmax, xdn(mgs,lh) ) ) )/(cdhdnmax - cdhdnmin) ) ) - ELSEIF ( icdx .eq. 5 ) THEN - cd = cdx(lh)*(xdn(mgs,lh)/rho_qh)**(2/3) - ELSEIF ( icdx .eq. 6 ) THEN ! Milbrandt and Morrison (2013) - aax = axh(mgs) - bbx = bxh(mgs) - ENDIF - - ELSEIF ( lhl .gt. 1 .and. il .eq. lhl ) THEN - - IF ( icdxhl .eq. 1 ) THEN - cd = cdx(lhl) - ELSEIF ( icdxhl .eq. 3 ) THEN -! cd = Max(0.45, Min(1.0, 0.45 + 0.55*(800.0 - Max( 300., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 300.) ) ) - cd = Max(0.45, Min(1.2, 0.45 + 0.55*(800.0 - Max( 170.0, Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 170.0) ) ) - ELSEIF ( icdxhl .eq. 4 ) THEN - cd = Max(cdhlmin, Min(cdhlmax, cdhlmin + (cdhlmax-cdhlmin)* & - & (cdhldnmax - Max( cdhldnmin, Min( cdhldnmax, xdn(mgs,lhl) ) ) )/(cdhldnmax - cdhldnmin) ) ) - ELSEIF ( icdxhl == 5 ) THEN -! cd = Max(0.6, Min(1.0, 0.6 + 0.4*(900.0 - xdn(mgs,lhl))/(900. - 300.) ) ) -! cd = Max(0.5, Min(0.8, 0.5 + 0.3*(xdnmx(lhl) - xdn(mgs,lhl))/(xdnmx(lhl)-xdnmn(lhl)) ) ) - cd = Max(0.45, Min(0.6, 0.45 + 0.15*(800.0 - Max( 500., Min( 800.0, xdn(mgs,lhl) ) ) )/(800. - 500.) ) ) - ELSEIF ( icdxhl .eq. 6 ) THEN ! Milbrandt and Morrison (2013) - aax = axhl(mgs) - bbx = bxhl(mgs) - ENDIF - - ENDIF ! } - - IF ( alpha(mgs,il) .eq. 0. .and. infdo .lt. 2 .and. & - ( ( il==lh .and. icdx > 0 .and. icdx /= 6) .or. ( il==lhl .and. icdxhl > 0 .and. icdxhl /= 6 ) ) ) THEN ! { - vtxbar(mgs,il,2) = & - & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & - & (3.0*cd*rho0(mgs)) ) - - ELSE - IF ( il == lh .and. icdx /= 6 ) bbx = bx(il) - IF ( il == lhl .and. icdxhl /= 6 ) bbx = bx(il) - tmp = 1. + alpha(mgs,il) + bbx - i = Int(dgami*(tmp)) - del = tmp - dgam*i - x = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - - tmp = 1. + alpha(mgs,il) - i = Int(dgami*(tmp)) - del = tmp - dgam*i - y = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami - - IF ( il .eq. lh .or. il .eq. lhl) THEN ! { - IF ( ( il==lh .and. icdx > 0 ) ) THEN - IF ( icdx /= 6 ) THEN - aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) - vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**0.5 * x/y - ELSE ! (icdx == 6 ) THEN - vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y - ENDIF -! ELSE -! aax = ax(il) -! vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y -! ENDIF - - ELSEIF ( ( il==lhl .and. icdxhl > 0 ) ) THEN - IF ( icdxhl /= 6 ) THEN - aax = Sqrt(4.0*xdn(mgs,il)*gr/(3.0*cd*rho00)) - vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**0.5 * x/y - ELSE ! ( icdxhl == 6 ) - vtxbar(mgs,il,2) = rhovt(mgs)*aax* xdia(mgs,il,1)**bbx * x/y - ENDIF - ELSE - aax = ax(il) - vtxbar(mgs,il,2) = rhovt(mgs)*ax(il)*(xdia(mgs,il,1)**bx(il)*x)/y - ENDIF - -! vtxbar(mgs,il,2) = & -! & rhovt(mgs)*(xdn(mgs,il)/400.)*(75.715*xdia(mgs,il,1)**0.6* & -! & x)/y -! vtxbar(mgs,il,2) = & -! & rhovt(mgs)*(xdn(mgs,il)/400.)*(ax(il)*xdia(mgs,il,1)**bx(il)* & -! & x)/y - IF ( infdo .ge. 2 ) THEN ! Z-weighted - vtxbar(mgs,il,3) = rhovt(mgs)* & - & (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))* & - & Gamma(7.0 + alpha(mgs,il) + bx(il)))/Gamma(7. + alpha(mgs,il)) - ENDIF - - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt3' - - ELSE ! hail - vtxbar(mgs,il,2) = & - & rhovt(mgs)*(ax(il)*xdia(mgs,il,1)**bx(il)* & - & x)/y - - IF ( infdo .ge. 2 ) THEN ! Z-weighted - vtxbar(mgs,il,3) = rhovt(mgs)* & - & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & - & Gamma(7.0 + alpha(mgs,il) + bx(il)))/Gamma(7. + alpha(mgs,il)) - ENDIF - - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt4' - - ENDIF ! } -! & Gamma(1.0 + dnu(il) + 0.6)/Gamma(1. + dnu(il)) - ENDIF ! } - -! IF ( infdo .ge. 2 ) THEN ! Z-weighted -! vtxbar(mgs,il,3) = rhovt(mgs)* & -! & (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))* & -! & Gamma(7.0 + alpha(mgs,il) + bx(il)))/Gamma(7. + alpha(mgs,il)) -! ENDIF - -! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN -! write(0,*) 'setvt: ',qx(mgs,il),xdia(mgs,il,1),xdia(mgs,il,3),dnu(il),ax(il),bx(il) -! ENDIF - ELSEIF ( (il .eq. lh .and. hssflg == 0) .or. ( lhl .gt. 1 .and. il .eq. lhl .and. hlssflg == 0) ) THEN ! no size-sorting for graupel or hail - vtxbar(mgs,il,2) = vtxbar(mgs,il,1) - vtxbar(mgs,il,3) = vtxbar(mgs,il,1) - ELSE ! not lh or lhl - vtxbar(mgs,il,2) = & - & Sqrt( (xdn(mgs,il)*xdia(mgs,il,1)*pi*gr) / & - & (3.0*cdx(il)*rho0(mgs)) ) - vtxbar(mgs,il,3) = vtxbar(mgs,il,1) - - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt5' - - - ENDIF - ELSE ! qx < qxmin - vtxbar(mgs,il,2) = 0.0 - - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt6' +! +! Aggregation of crystals +! + if (ndebug .gt. 0 ) write(0,*) 'conc 29a' + do mgs = 1,ngscnt + qscni(mgs) = 0.0 + cscni(mgs) = 0.0 + cscnis(mgs) = 0.0 + if ( ipconc .ge. 4 .and. iscni .ge. 1 .and. qx(mgs,li) .gt. qxmin(li) ) then + IF ( iscni .eq. 1 ) THEN + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + cscnis(mgs) = 0.5*cscni(mgs) + ELSEIF ( iscni .eq. 2 .or. iscni .eq. 4 .or. iscni .eq. 5 ) THEN ! Zeigler 1985/Zrnic 1993, sort of + IF ( iscni .ne. 5 .and. qidpv(mgs) .gt. 0.0 .and. xdia(mgs,li,3) .ge. 100.e-6 ) THEN + ! convert larger crystals to snow +! IF ( xdia(mgs,ls,3) .gt. xdia(mgs,li,3) ) THEN +! qscni(mgs) = Max(0.1,xdia(mgs,li,3)/xdia(mgs,ls,3))*qidpv(mgs) +! erm 9/5/08 changed max to min + qscni(mgs) = Min(0.5, xdia(mgs,li,3)/200.e-6)*qidpv(mgs) +! ELSE +! qscni(mgs) = 0.1*qidpv(mgs) +! ENDIF + cscni(mgs) = 0.5*Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvsmn,xmas(mgs,li))) +! cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li) ) +! IF ( xdia(mgs,ls,3) .le. 200.e-6 ) THEN + cscnis(mgs) = cscni(mgs) +! ELSE +! cscnis(mgs) = 0.0 +! ENDIF + ENDIF - ENDIF - ENDDO ! mgs + IF ( iscni .ne. 4 ) THEN + ! crystal aggregation to become snow +! erm 9/5/08 commented second line and added xv to 1st line (zrnic et al 1993) + tmp = ess(mgs)*rvt*aa2*cx(mgs,li)*cx(mgs,li)*xv(mgs,li) +! : ((cinu + 2.)*xv(mgs,li)/(cinu + 1.) + xv(mgs,li)) - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt7' +! csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) + qscni(mgs) = qscni(mgs) + Min( qxmxd(mgs,li), 2.0*tmp*xmas(mgs,li)*rhoinv(mgs) ) + cscni(mgs) = cscni(mgs) + Min( cxmxd(mgs,li), 2.0*tmp ) + cscnis(mgs) = cscnis(mgs) + Min( cxmxd(mgs,li), tmp ) + ENDIF + ELSEIF ( iscni .eq. 3 ) THEN ! LFO + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + cscni(mgs) = qscni(mgs)*rho0(mgs)/xmas(mgs,li) + cscnis(mgs) = 0.5*cscni(mgs) +! write(iunit,*) 'qscni, qi = ',qscni(mgs),qx(mgs,li),igs(mgs),kgs(mgs) ENDIF - ENDDO ! il - - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt8' - - ENDIF ! lg .gt. 1 - -! ENDIF -! ENDDO - - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set graupel vt9' - -! DO mgs = 1,ngscnt -! IF ( qx(mgs,lr) > qxmin(lr) ) THEN -! write(0,*) 'setvt2: mgs,lzr,infdo = ',mgs,lzr,infdo -! write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3) -! ENDIF -! ENDDO - - ENDIF ! infdo .ge. 1 - - if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: END OF ROUTINE' - -!############ SETVTZ ############################ - RETURN - END SUBROUTINE setvtz -!-------------------------------------------------------------------------- + ELSEIF ( ipconc < 4 ) THEN ! LFO + IF ( lwsm6 ) THEN + qimax = rhoinv(mgs)*roqimax + qscni(mgs) = Min(0.9d0*qx(mgs,li), Max( 0.d0, (qx(mgs,li) - qimax)*dtpinv ) ) + ELSE + qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) + qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) + ENDIF + else ! 10-ice version + if ( qx(mgs,li) .gt. qxmin(li) ) then + qscni(mgs) = & + & pi*rho0(mgs)*((0.25)/(6.0)) & + & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & + & *vtxbar(mgs,li,1)/xmas(mgs,li) + cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li)) + end if -! -! ############################################################################## + end if + end do -! #include "sam.def.h" -! -! subroutine to calculate fall speeds of hydrometeors ! - - subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & - & xvt, rhovtzx, & - & an,dn,ipconc0,t0,t7,cwmasn,cwmasx, & - & cwradn, & - & qxmin,xdnmx,xdnmn,cdx,cno,xdn0,xvmn,xvmx, & - & ngs,qx,qxw,cx,xv,vtxbar,xmas,xdn,xdia,vx,alpha,zx,igs,kgs, & - & rho0,temcg,temg,rhovt,cwnc,cinc,fadvisc,cwdia,cipmas,cnina,cimas, & - & cnostmp, & - & infdo,ildo,timesetvt) - -! 12.16.2005: .F version use in transitional SWM model ! -! 10.10.2003: Added cimn and cimx to setting for cci and cip. +! compute dry growth rate of snow, graupel, and hail ! -! TO DO LIST: + do mgs = 1,ngscnt ! -! need to set up values for: -! : cipdia,cidia,cwdia,cwmas,vtwbar, -! : rho0,temcg,cip,cci + qsdry(mgs) = qsacr(mgs) + qsacw(mgs) & + & + qsaci(mgs) ! -! and need to put fallspeed values in cwvt etc. + qhdry(mgs) = qhaci(mgs) + qhacs(mgs) & + & + qhacr(mgs) & + & + qhacw(mgs) ! - - implicit none - integer ng1 - parameter(ng1 = 1) - - integer, intent(in) :: ixcol ! which column to return - integer, intent(in) :: ildo - - integer nx,ny,nz,nor,norz,ngt,jgs,na - real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) - real dn(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) - real t0(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) - real t7(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) - real dtp,dtz1 - - real :: rhovtzx(nz,nx) - - integer ndebugzf - parameter (ndebugzf = 0) - - integer ix,jy,kz,i,j,k,il - integer infdo + qhldry(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhldry(mgs) = qhlaci(mgs) + qhlacs(mgs) & + & + qhlacr(mgs) & + & + qhlacw(mgs) + ENDIF + end do +! +! set wet growth and shedding ! + do mgs = 1,ngscnt ! - real xvt(nz+1,nx,3,lc:lhab) ! 1=mass-weighted, 2=number-weighted +! qswet(mgs) = +! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) +! > + fwet2(mgs)*(qsaci(mgs)+qsacir(mgs) +! > +qsacip(mgs)) ) +! qswet(mgs) = max( 0.0, qswet(mgs)) +! +! IF ( dnu(lh) .ne. 0. ) THEN +! qhwet(mgs) = qhdry(mgs) +! ELSE + qhwet(mgs) = & + & ( xdia(mgs,lh,1)*hwvent(mgs)*cx(mgs,lh)*fwet1(mgs) & + & + fwet2(mgs)*(qhaci(mgs) + qhacs(mgs)) ) + qhwet(mgs) = max( 0.0, qhwet(mgs)) +! ENDIF - real qxmin(lc:lhab) - real xdn0(lc:lhab) - real xvmn(lc:lhab), xvmx(lc:lhab) - double precision,optional :: timesetvt + qhlwet(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + qhlwet(mgs) = & + & ( xdia(mgs,lhl,1)*hlvent(mgs)*cx(mgs,lhl)*fwet1(mgs) & + & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) + qhlwet(mgs) = max( 0.0, qhlwet(mgs)) + ENDIF +! +! qhlwet(mgs) = qhldry(mgs) - integer :: ngs - integer :: ngscnt,mgs,ipconc0 -! parameter ( ngs=200 ) - - real :: qx(ngs,lv:lhab) - real :: qxw(ngs,ls:lhab) - real :: cx(ngs,lc:lhab) - real :: xv(ngs,lc:lhab) - real :: vtxbar(ngs,lc:lhab,3) - real :: xmas(ngs,lc:lhab) - real :: xdn(ngs,lc:lhab) - real :: xdia(ngs,lc:lhab,3) - real :: vx(ngs,li:lhab) - real :: alpha(ngs,lr:lhab) -!#ifdef Z3MOM - real :: zx(ngs,lr:lhab) -!#endif + end do +! +! shedding rate +! + qsshr(:) = 0.0 + qhshr(:) = 0.0 + qhlshr(:) = 0.0 + qhshh(:) = 0.0 + csshr(:) = 0.0 + chshr(:) = 0.0 + chlshr(:) = 0.0 + chshrr(:) = 0.0 + chlshrr(:) = 0.0 + vhshdr(:) = 0.0 + vhlshdr(:) = 0.0 + wetsfc(:) = .false. + wetgrowth(:) = .false. + wetsfchl(:) = .false. + wetgrowthhl(:) = .false. - real xdnmx(lc:lhab), xdnmn(lc:lhab) + do mgs = 1,ngscnt ! -! drag coefficients -! - real cdx(lc:lhab) ! -! Fixed intercept values for single moment scheme ! - real cno(lc:lhab) + qhshr(mgs) = Min( 0.0, qhwet(mgs) - qhdry(mgs) ) ! water that freezes should never be more than what sheds - real cwccn0,cwmasn,cwmasx,cwradn -! real cwc0 - - integer nxmpb,nzmpb,nxz,numgs,inumgs - integer kstag - parameter (kstag=1) - integer igs(ngs),kgs(ngs) - - real rho0(ngs),temcg(ngs) - real temg(ngs) - - real rhovt(ngs) - - real cwnc(ngs),cinc(ngs) - real fadvisc(ngs),cwdia(ngs),cipmas(ngs) - -! real cimasn,cimasx, - real :: cnina(ngs),cimas(ngs) - - real :: cnostmp(ngs) + qhlshr(mgs) = Min( 0.0, qhlwet(mgs) - qhldry(mgs) ) -! real pii ! +! limit wet growth to only higher density particles ! -! general constants for microphysics + qsshr(mgs) = 0.0 ! - -! -! Miscellaneous ! - - logical flag - logical ldoliq - - - real chw, qr, z, rd, alp, z1, g1, vr, nrx, tmp - - real vtmax - real xvbarmax - - integer l1, l2 - - double precision :: dpt1, dpt2 +! no shedding for temperatures < 243.15 +! + if ( temg(mgs) .lt. 243.15 ) then + qsshr(mgs) = 0.0 + qhshr(mgs) = 0.0 + qhlshr(mgs) = 0.0 + vhshdr(mgs) = 0.0 + vhlshdr(mgs) = 0.0 + wetsfc(mgs) = .false. + wetgrowth(mgs) = .false. + wetsfchl(mgs) = .false. + wetgrowthhl(mgs) = .false. + end if +! +! shed all at temperatures > 273.15 +! + if ( temg(mgs) .gt. tfr ) then + qsshr(mgs) = -qsdry(mgs) + qhlshr(mgs) = -qhldry(mgs) -!----------------------------------------------------------------------------- -! MPI LOCAL VARIABLES + qhshr(mgs) = -qhdry(mgs) + vhshdr(mgs) = -vhacw(mgs) - vhacr(mgs) + vhlshdr(mgs) = -vhlacw(mgs) + qhwet(mgs) = 0.0 + qhlwet(mgs) = 0.0 + end if +! +! if (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfc(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhmlr(mgs) < -qxmin(lh) .and. temg(mgs) > tfr ) + wetgrowth(mgs) = (qhshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) +! ENDIF - integer :: ixb, jyb, kzb - integer :: ixe, jye, kze + if (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) THEN + wetsfchl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) .or. ( qhlmlr(mgs) < -qxmin(lhl) .and. temg(mgs) > tfr ) + wetgrowthhl(mgs) = (qhlshr(mgs) .lt. 0.0 .and. temg(mgs) < tfr ) + ENDIF - logical :: debug_mpi = .false. + end do +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) + chshr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) + IF ( temg(mgs) < tfr ) THEN + chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding + ELSE + IF(imltshddmr > 0) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop + tmp = -Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain + tmp2 = -rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) + chshrr(mgs) = -Max(tmp,Min(tmp2,chshrr(mgs))) + ELSE + chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to maximum size allowed for rain or 4.5mm diameter, whichever is smaller +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + ENDIF + ENDIF + chlshr(mgs) = 0.0 + chlshrr(mgs) = 0.0 + IF ( lhl .gt. 1 ) THEN + chlshr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) + IF ( temg(mgs) < tfr ) THEN + chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding +! chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vr1mm) ) ! maximum of 1mm drops from shedding + ELSE + IF(imltshddmr > 0) THEN + ! DTD: If Dmg < sheddiam, then assume complete melting into + ! maximal raindrop. Between sheddiam and sheddiam0, linearly ramp down to a 3 mm shed drop + tmp = -Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! limit to maximum size allowed for rain + tmp2 = -rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter + chlshrr(mgs) = tmp*(sheddiam0-xdia(mgs,lhl,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(sheddiam0-sheddiam) + chlshrr(mgs) = -Max(tmp,Min(tmp2,chlshrr(mgs))) + ELSE + chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*Min(vr4p5mm,xvmx(lr))) ) ! limit to 4.5mm diameter or maximum size allowed for rain, whichever is smaller +! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain + ENDIF + ENDIF + ENDIF + end do + end if - if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: ENTERED SUBROUTINE" -! ##################################################################### -! BEGIN EXECUTABLE -! ##################################################################### ! - -! constants +! final decisions +! + do mgs = 1,ngscnt +! +! Snow +! + if ( qsshr(mgs) .lt. 0.0 ) then + qsdpv(mgs) = 0.0 + qssbv(mgs) = 0.0 + else + qsshr(mgs) = 0.0 + end if +! +! if ( qsdry(mgs) .lt. qswet(mgs) ) then +! qswet(mgs) = 0.0 +! else +! qsdry(mgs) = 0.0 +! end if ! - ldoliq = .false. - IF ( ls .gt. 1 ) THEN - DO il = ls,lhab - ldoliq = ldoliq .or. ( lliq(il) .gt. 1 ) - ENDDO - ENDIF - -! poo = 1.0e+05 -! cp608 = 0.608 -! cp = 1004.0 -! cv = 717.0 -! dnz00 = 1.225 -! rho00 = 1.225 -! cs = 4.83607122 -! ds = 0.25 -! new values for cs and ds -! cs = 12.42 -! ds = 0.42 -! pi = 4.0*atan(1.0) -! pii = piinv ! 1./pi -! pid4 = pi/4.0 -! qccrit = 2.0e-03 -! qscrit = 6.0e-04 -! cwc0 = pii - -! +! zero the shedding rates when wet snow/graupel included. +! shedding of wet snow/graupel is calculated after summing other sources/sinks. + if (mixedphase) then + qsshr(mgs) = 0.0 + qhshr(mgs) = 0.0 + csshr(mgs) = 0.0 + chshr(mgs) = 0.0 + chshrr(mgs) = 0.0 + vhshdr(mgs) = 0.0 + IF ( lhlw > 1 ) THEN + qhlshr(mgs) = 0.0 + vhlshdr(mgs) = 0.0 + chlshr(mgs) = 0.0 + chlshrr(mgs) = 0.0 + ENDIF + end if + +! graupel ! -! general constants for microphysics ! + if ( wetgrowth(mgs) .or. (mixedphase .and. fhw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then -! -! ci constants in mks units -! -! cimasn = 6.88e-13 -! cimasx = 1.0e-8 -! -! Set terminal velocities... -! also set drag coefficients -! - jy = jgs - nxmpb = ixcol - nzmpb = 1 - nxz = 1*nz -! ngs = nz - numgs = 1 - - IF ( ildo == 0 ) THEN - l1 = lc - l2 = lhab - ELSE - l1 = ildo - l2 = ildo - ENDIF - - - do inumgs = 1,numgs - ngscnt = 0 +! soaking (when not advected liquid water film with graupel) - do kz = nzmpb,nz - do ix = ixcol,ixcol - flag = .false. + IF ( lvol(lh) .gt. 1 .and. .not. mixedphase) THEN + ! rescale volumes to maximum density + rimdn(mgs,lh) = xdnmx(lh) + raindn(mgs,lh) = xdnmx(lh) + vhacw(mgs) = qhacw(mgs)*rho0(mgs)/rimdn(mgs,lh) + vhacr(mgs) = qhacr(mgs)*rho0(mgs)/raindn(mgs,lh) +! IF ( lvol(lh) .gt. 1 .and. wetgrowth(mgs) ) THEN + IF ( xdn(mgs,lh) .lt. xdnmx(lh) ) THEN + ! soak some liquid into the graupel +! v1 = xdnmx(lh)*vx(mgs,lh)/(xdn(mgs,lh)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lh)/xdnmx(lh))*vx(mgs,lh)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lh)/rho0(mgs))*(xdnmx(lh) - xdn(mgs,lh)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhwet(mgs)/xdnmx(lh) ! volume of frozen accretion + + vhsoak(mgs) = Min(v1,v2) + + ENDIF + vhshdr(mgs) = Min(0.0, rho0(mgs)*qhwet(mgs)/xdnmx(lh) - vhacw(mgs) - vhacr(mgs) ) + + ELSEIF ( lvol(lh) .gt. 1 .and. mixedphase ) THEN +! vhacw(mgs) = rho0(mgs)*qhacw(mgs)/xdn0(lr) +! vhacr(mgs) = rho0(mgs)*qhacr(mgs)/xdn0(lr) + ENDIF - DO il = l1,l2 - flag = flag .or. ( an(ix,jy,kz,il) .gt. qxmin(il) ) - ENDDO - if ( flag ) then -! load temp quantities + qhdpv(mgs) = 0.0 +! qhsbv(mgs) = 0.0 + chdpv(mgs) = 0.0 +! chsbv(mgs) = 0.0 - ngscnt = ngscnt + 1 - igs(ngscnt) = ix - kgs(ngscnt) = kz - if ( ngscnt .eq. ngs ) goto 1100 - end if -!#ifndef MPI - end do !!ix -!#endif - nxmpb = 1 - end do !! kz +! collection efficiency modification -! if ( jy .eq. (ny-jstag) ) iend = 1 + IF ( ehi(mgs) .gt. 0.0 ) THEN + qhaci(mgs) = Min(qimxd(mgs),qhaci0(mgs)) ! effectively sets collection eff to 1 + chaci(mgs) = Min(cimxd(mgs),chaci0(mgs)) ! effectively sets collection eff to 1 + ENDIF + IF ( ehs(mgs) .gt. 0.0 ) THEN +! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs)) ! effectively sets collection eff to 1 + qhacs(mgs) = qhacs0(mgs) !/ehs(mgs) ! divide out the collection efficiency + chacs(mgs) = chacs0(mgs) !/ehs(mgs) ! divide out the collection efficiency + ehs(mgs) = 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it + ! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)*ehs(mgs)) ! plug it back in + ENDIF - 1100 continue +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfc(mgs) = .true. - if ( ngscnt .eq. 0 ) go to 9998 + else +! qhshr(mgs) = 0.0 + end if ! -! set temporaries for microphysics variables ! +! hail +! +! if ( lhl .gt. 1 .and. qhlshr(mgs) .lt. 0.0 ) then + if ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then +! if ( wetgrowthhl(mgs) ) then + + qhldpv(mgs) = 0.0 +! qhlsbv(mgs) = 0.0 + chldpv(mgs) = 0.0 +! chlsbv(mgs) = 0.0 -! -! Reconstruct various quantities -! - do mgs = 1,ngscnt - rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) - rhovt(mgs) = rhovtzx(kgs(mgs),ixcol) ! Sqrt(rho00/rho0(mgs)) - temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) - temcg(mgs) = temg(mgs) - tfr - -! - end do -! -! only need fadvisc for - IF ( lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then - do mgs = 1,ngscnt - fadvisc(mgs) = advisc0*(416.16/(temg(mgs)+120.0))* & - & (temg(mgs)/296.0)**(1.5) - end do - ENDIF - IF ( ipconc .eq. 0 ) THEN - do mgs = 1,ngscnt - cnina(mgs) = t7(igs(mgs),jgs,kgs(mgs)) - end do - ENDIF + IF ( lvol(lhl) .gt. 1 .and. .not. mixedphase ) THEN +! IF ( lvol(lhl) .gt. 1 .and. wetgrowthhl(mgs) ) THEN + rimdn(mgs,lhl) = xdnmx(lhl) + raindn(mgs,lhl) = xdnmx(lhl) + vhlacw(mgs) = qhlacw(mgs)*rho0(mgs)/rimdn(mgs,lhl) + vhlacr(mgs) = qhlacr(mgs)*rho0(mgs)/raindn(mgs,lhl) - IF ( ildo > 0 ) THEN - vtxbar(:,ildo,:) = 0.0 - ELSE - vtxbar(:,:,:) = 0.0 + IF ( xdn(mgs,lhl) .lt. xdnmx(lhl) ) THEN + ! soak some liquid into the hail +! v1 = xdnmx(lhl)*vx(mgs,lhl)/(xdn(mgs,lhl)*dtp) ! volume available for filling + v1 = (1. - xdn(mgs,lhl)/xdnmx(lhl))*vx(mgs,lhl)/(dtp) ! volume available for filling +! tmp = (vx(mgs,lhl)/rho0(mgs))*(xdnmx(lhl) - xdn(mgs,lhl)) ! max mixing ratio of liquid water that can be added + v2 = rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) ! volume of frozen accretion + IF ( v1 > v2 ) THEN ! all the frozen stuff fits in + vhlsoak(mgs) = v2 + ELSE ! fill up the available space + vhlsoak(mgs) = v1 + ENDIF +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = Max( 0.0, v2 - v1 ) + ELSE + vhlsoak(mgs) = 0.0 +! vhlacw(mgs) = 0.0 +! vhlacr(mgs) = rho0(mgs)*qhlwet(mgs)/raindn(mgs,lhl) + + ENDIF + + vhlshdr(mgs) = Min(0.0, rho0(mgs)*qhlwet(mgs)/xdnmx(lhl) - vhlacw(mgs) - vhlacr(mgs) ) + + + ELSEIF ( lvol(lhl) .gt. 1 .and. mixedphase ) THEN +! vhlacw(mgs) = rho0(mgs)*qhlacw(mgs)/xdn0(lr) +! vhlacr(mgs) = rho0(mgs)*qhlacr(mgs)/xdn0(lr) + ENDIF + + IF ( ehli(mgs) .gt. 0.0 ) THEN + qhlaci(mgs) = Min(qimxd(mgs),qhlaci(mgs)/ehli(mgs)) ENDIF - -! do mgs = 1,ngscnt -! qx(mgs,lv) = max(an(igs(mgs),jy,kgs(mgs),lv), 0.0) -! ENDDO - DO il = l1,l2 - do mgs = 1,ngscnt - qx(mgs,il) = max(an(igs(mgs),jy,kgs(mgs),il), 0.0) - ENDDO - end do - - cnostmp(:) = cno(ls) - IF ( ipconc < 1 .and. lwsm6 .and. (ildo == 0 .or. ildo == ls )) THEN - DO mgs = 1,ngscnt - tmp = Min( 0.0, temcg(mgs) ) - cnostmp(mgs) = Min( 2.e8, 2.e6*exp(0.12*tmp) ) - ENDDO + IF ( ehls(mgs) .gt. 0.0 ) THEN + qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs)) ENDIF + +! qhlwet(mgs) = 1.0 + +! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop + wetsfchl(mgs) = .true. + else +! qhlshr(mgs) = 0.0 +! qhlwet(mgs) = 0.0 + end if + + + end do ! -! set concentrations +! Ice -> graupel conversion ! - cx(:,:) = 0.0 + DO mgs = 1,ngscnt - if ( ipconc .ge. 1 .and. li .gt. 1 .and. (ildo == 0 .or. ildo == li ) ) then - do mgs = 1,ngscnt - cx(mgs,li) = Max(an(igs(mgs),jy,kgs(mgs),lni), 0.0) - end do - end if - if ( ipconc .ge. 2 .and. lc .gt. 1 .and. (ildo == 0 .or. ildo == lc ) ) then - do mgs = 1,ngscnt - cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0) - cx(mgs,lc) = Min( ccwmx, cx(mgs,lc) ) - end do - end if - if ( ipconc .ge. 3 .and. lr .gt. 1 .and. (ildo == 0 .or. ildo == lr ) ) then - do mgs = 1,ngscnt - cx(mgs,lr) = Max(an(igs(mgs),jy,kgs(mgs),lnr), 0.0) -! IF ( qx(mgs,lr) .le. qxmin(lr) ) THEN -! ELSE -! cx(mgs,lr) = Max( 0.0, cx(mgs,lr) ) -! ENDIF - end do - end if - if ( ipconc .ge. 4 .and. ls .gt. 1 .and. (ildo == 0 .or. ildo == ls ) ) then - do mgs = 1,ngscnt - cx(mgs,ls) = Max(an(igs(mgs),jy,kgs(mgs),lns), 0.0) -! IF ( qx(mgs,ls) .le. qxmin(ls) ) THEN -! ELSE -! cx(mgs,ls) = Max( 0.0, cx(mgs,ls) ) -! ENDIF - end do - end if + qhcni(mgs) = 0.0 + chcni(mgs) = 0.0 + chcnih(mgs) = 0.0 + vhcni(mgs) = 0.0 + + IF ( iglcnvi .ge. 1 ) THEN + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs) - qidpv(mgs) .gt. 0.0 ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + + IF ( tmp .ge. 200.0 .or. iglcnvi >= 2 ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = (qiacw(mgs) - qidpv(mgs)) ! *float(iglcnvi) + chcni(mgs) = cx(mgs,li)*qhcni(mgs)/qx(mgs,li) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + + ENDIF - if ( ipconc .ge. 5 .and. lh .gt. 1 .and. (ildo == 0 .or. ildo == lh ) ) then - do mgs = 1,ngscnt + + ENDIF + + + ENDDO + + + qhlcnh(:) = 0.0 + chlcnh(:) = 0.0 + vhlcnh(:) = 0.0 + vhlcnhl(:) = 0.0 + zhlcnh(:) = 0.0 - cx(mgs,lh) = Max(an(igs(mgs),jy,kgs(mgs),lnh), 0.0) -! IF ( qx(mgs,lh) .le. qxmin(lh) ) THEN -! ELSE -! cx(mgs,lh) = Max( 0.0, cx(mgs,lh) ) -! ENDIF + qhcnhl(:) = 0.0 + chcnhl(:) = 0.0 + vhcnhl(:) = 0.0 + zhcnhl(:) = 0.0 + - end do - ENDIF + IF ( lhl .gt. 1 ) THEN + + IF ( ihlcnh == 1 ) THEN - if ( ipconc .ge. 5 .and. lhl .gt. 1 .and. (ildo == 0 .or. ildo == lhl ) ) then - do mgs = 1,ngscnt +! +! Graupel (h) conversion to hail (hl) based on Milbrandt and Yau 2005b +! + DO mgs = 1,ngscnt - cx(mgs,lhl) = Max(an(igs(mgs),jy,kgs(mgs),lnhl), 0.0) -! IF ( qx(mgs,lhl) .le. qxmin(lhl) ) THEN -! cx(mgs,lhl) = 0.0 -! ELSEIF ( cx(mgs,lhl) .eq. 0.0 .and. qx(mgs,lhl) .lt. 3.0*qxmin(lhl) ) THEN -! qx(mgs,lhl) = 0.0 -! ELSE -! cx(mgs,lhl) = Max( 0.0, cx(mgs,lhl) ) -! ENDIF +! IF ( lhl .gt. 1 .and. ipconc .ge. 5 .and. qx(mgs,lh) .gt. 1.0e-3 .and. +! : xdn(mgs,lh) .gt. 750. .and. qhshr(mgs) .lt. 0.0 .and. +! : xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( wetgrowth(mgs) .and. (xdn(mgs,lh) .gt. hldnmn .or. lvh < 1 ) .and. & ! correct this when hail gets turned on +! IF ( ( qhshr(mgs) .lt. 0.0 .or. rimdn(mgs,lh) .gt. 800. ) .and. & + & rimdn(mgs,lh) .gt. 800. .and. & + & xdia(mgs,lh,3) .gt. hlcnhdia .and. qx(mgs,lh) .gt. hlcnhqmin ) THEN +! : xdia(mgs,lh,3) .gt. 2.e-3 .and. qx(mgs,lh) .gt. 1.0e-3 ) THEN ! 0823.2008 erm test +! IF ( xdia(mgs,lh,3) .gt. 1.e-3 ) THEN + IF ( qhacw(mgs) .gt. 0.0 .and. qhacw(mgs) .gt. qhaci(mgs) .and. temg(mgs) .le. tfr-2.0 ) THEN + ! dh0 is the diameter dividing wet growth from dry growth (Ziegler 1985), modified by MY05 +! dh0 = 0.01*(exp(temcg(mgs)/(1.1e4*(qx(mgs,lc)+qx(mgs,lr)) - +! : 1.3e3*qx(mgs,li) + 1.0e-3 ) ) - 1.0) + x = (1.1e4*(rho0(mgs)*qx(mgs,lc)) - 1.3e3*rho0(mgs)*qx(mgs,li) + 1.0e-3 ) + IF ( x > 1.e-20 ) THEN + arg = Min(70.0, (-temcg(mgs)/x )) ! prevent overflow of the exp function in 32 bit + dh0 = 0.01*(exp(arg) - 1.0) + ELSE + dh0 = 1.e30 + ENDIF +! dh0 = Max( dh0, 5.e-3 ) + +! IF ( dh0 .gt. 0.0 ) write(0,*) 'dh0 = ',dh0 +! IF ( dh0 .gt. 1.0e-4 ) THEN + IF ( xdia(mgs,lh,3)/dh0 .gt. 0.1 ) THEN +! IF ( xdia(mgs,lh,3) .lt. 20.*dh0 .and. dh0 .lt. 2.0*xdia(mgs,lh,3) ) THEN + tmp = qhacw(mgs) + qhacr(mgs) + qhaci(mgs) + qhacs(mgs) +! qtmp = Min( 1.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) + qtmp = Min( 100.0, xdia(mgs,lh,3)/(2.0*dh0) )*(tmp) + IF ( .false. .and. qx(mgs,lhl) + qtmp*dtp .lt. 0.5e-3 ) THEN + hdia1 = Max(dh0, xdia(mgs,lh,3) ) + qtmp = qtmp + Min(qxmxd(mgs,lh), Max( 0.0, & + & ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & + & *exp(-hdia1/xdia(mgs,lh,1)) & + & *( (hdia1**3) + 3.0*(hdia1**2)*xdia(mgs,lh,1) & + & + 6.0*(hdia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) ) ) - end do - end if - - do mgs = 1,ngscnt - xdn(mgs,lc) = xdn0(lc) - xdn(mgs,lr) = xdn0(lr) -! IF ( ls .gt. 1 .and. lvs .eq. 0 ) xdn(mgs,ls) = xdn0(ls) -! IF ( lh .gt. 1 .and. lvh .eq. 0 ) xdn(mgs,lh) = xdn0(lh) - IF ( li .gt. 1 ) xdn(mgs,li) = xdn0(li) - IF ( ls .gt. 1 ) xdn(mgs,ls) = xdn0(ls) - IF ( lh .gt. 1 ) xdn(mgs,lh) = xdn0(lh) - IF ( lhl .gt. 1 ) xdn(mgs,lhl) = xdn0(lhl) - end do +!c qtmp = Min( qxmxd(mgs,lh), qtmp ) +!c tmp = tmp + Min( 0.5e-3/dtp, qtmp ) + ENDIF +! write(0,*) 'dh0 = ',dh0,tmp,qx(mgs,lh)*1000. +! qhlcnh(mgs) = Min( 0.5*(qx(mgs,lh))+tmp, xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) +! qhlcnh(mgs) = Min( qxmxd(mgs,lh), xdia(mgs,lh,3)/(2.0*dh0)*(tmp) ) + qhlcnh(mgs) = Min( qxmxd(mgs,lh), qtmp ) + + IF ( ipconc .ge. 5 ) THEN +! dh0 = Max( xdia(mgs,lh,3), Min( dh0, 5.e-3 ) ) ! don't create hail greater than 5mm diam. unless the graupel is larger + dh0 = Min( dh0, 10.e-3 ) ! don't create hail greater than 10mm diam., which is the max graupel size +! IF ( qx(mgs,lhl) > 0.1e-3 ) dh0 = xdia(mgs,lhl,3) ! when enough hail is established, don't dilute the size + chlcnh(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(pi*xdn(mgs,lh)*dh0**3/6.0) ) +! chlcnh(mgs) = Min( chlcnh(mgs), (1./8.)*rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) +! chlcnh(mgs) = Min( chlcnh(mgs), (1./2.)*rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) + r = rho0(mgs)*qhlcnh(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ! number of graupel particles at mean volume diameter +! chlcnh(mgs) = Min( Max( 1./8.*r , chlcnh(mgs)), r ) +! chlcnh(mgs) = Min( chlcnh(mgs), r ) + chlcnh(mgs) = Max( chlcnh(mgs), r ) +! chlcnh(mgs) = r + ENDIF + + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) +! write(0,*) 'qhlcnh = ',qhlcnh(mgs)*1000.,chlcnh(mgs) + ENDIF +! write(0,*) 'graupel to hail conversion not complete! STOP!' +! STOP + ENDIF + ENDIF + + ENDDO + + ELSEIF ( ihlcnh == 2 ) THEN ! 10-ice type conversion ! -! Set mean particle volume +! Staka and Mansell (2005) type conversion -- assuming alphah = 0 for now! ! - IF ( ldovol .and. (ildo == 0 .or. ildo >= li ) ) THEN +! hldia1 is set in micro_module and namelist + do mgs = 1,ngscnt +! qhlcnh(mgs) = 0.0 +! chlcnh(mgs) = 0.0 + if ( wetgrowth(mgs) .and. temg(mgs) .lt. tfr-5. .and. qx(mgs,lh) > qxmin(lh) ) then + if ( qhacw(mgs).gt.1.e-6 .and. xdn(mgs,lh) > 700. ) then + qhlcnh(mgs) = & + ((pi*xdn(mgs,lh)*cx(mgs,lh)) / (6.0*rho0(mgs)*dtp)) & + *exp(-hldia1/xdia(mgs,lh,1)) & + *( (hldia1**3) + 3.0*(hldia1**2)*xdia(mgs,lh,1) & + + 6.0*(hldia1)*(xdia(mgs,lh,1)**2) + 6.0*(xdia(mgs,lh,1)**3) ) + qhlcnh(mgs) = min(qhlcnh(mgs),qhmxd(mgs)) + IF ( ipconc .ge. 5 ) THEN + chlcnh(mgs) = Min( cxmxd(mgs,lh), cx(mgs,lh)*Exp(-hldia1/xdia(mgs,lh,1))) +! chlcnh(mgs) = Min( cxmxd(mgs,lh), rho0(mgs)*qhlcnh(mgs)/(2.0*xmas(mgs,lh) )) + ENDIF + vhlcnh(mgs) = rho0(mgs)*qhlcnh(mgs)/xdn(mgs,lh) + vhlcnhl(mgs) = rho0(mgs)*qhlcnh(mgs)/Max(xdnmn(lhl), xdn(mgs,lh)) + end if + end if + end do - vx(:,:) = 0.0 + ENDIF - DO il = l1,l2 - - IF ( lvol(il) .ge. 1 ) THEN - - DO mgs = 1,ngscnt - vx(mgs,il) = Max(an(igs(mgs),jy,kgs(mgs),lvol(il)), 0.0) - IF ( vx(mgs,il) .gt. rho0(mgs)*qxmin(il)*1.e-3 .and. qx(mgs,il) .gt. qxmin(il) ) THEN - xdn(mgs,il) = Min( xdnmx(il), Max( xdnmn(il), rho0(mgs)*qx(mgs,il)/vx(mgs,il) ) ) - ENDIF - ENDDO + ! convert low-density hail to graupel + IF ( icvhl2h >= 1 ) THEN + DO mgs = 1,ngscnt + IF ( qx(mgs,lhl) > qxmin(lhl) .and. xdn(mgs,lhl) < 0.5*(xdnmn(lhl) + xdnmx(lhl)) ) THEN + tmp = Min(0.95, 1. - 0.5*(1. + tanh(0.125*(xdn(mgs,lhl) - 1.01*xdnmn(lhl) )) )) + qhcnhl(mgs) = tmp*qx(mgs,lhl)/dtp + chcnhl(mgs) = cx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) + vhcnhl(mgs) = vx(mgs,lhl)*qhcnhl(mgs)/qx(mgs,lhl) ENDIF - - ENDDO + ENDDO ENDIF + + + ENDIF ! lhl > 1 - DO il = lg,lhab + +! +! Ziegler snow conversion to graupel +! DO mgs = 1,ngscnt - alpha(mgs,il) = dnu(il) - ENDDO - ENDDO - - alpha(:,lr) = xnu(lr) - + qhcns(mgs) = 0.0 + chcns(mgs) = 0.0 + chcnsh(mgs) = 0.0 + vhcns(mgs) = 0.0 + + qscnh(mgs) = 0.0 + cscnh(mgs) = 0.0 + vscnh(mgs) = 0.0 + + IF ( ipconc .ge. 5 ) THEN + IF ( temg(mgs) < tfr .and. qx(mgs,lh) .gt. qxmin(lh) .and. qhdpv(mgs) > qxmin(lh)*dtpinv & + & .and. qhacw(mgs) < qxmin(lh)*dtpinv ) THEN + IF ( xdn(mgs,lh) < 290. ) THEN +! qscnh(mgs) = 2.*qhdpv(mgs) +! cscnh(mgs) = cx(mgs,lh)*qscnh(mgs)/qx(mgs,lh) +! vscnh(mgs) = rho0(mgs)*qscnh(mgs)/xdn(mgs,lh) + ENDIF + ENDIF + IF ( qx(mgs,ls) .gt. qxmin(ls) .and. qsacw(mgs) .gt. 0.0 ) THEN +! DATA VGRA/1.413E-2/ ! this is the volume (cm**3) of a 3mm diam. sphere +! vgra = 1.4137e-8 m**3 +! DNNET=DNCNV-DNAGG +! DQNET=QXCON+QSACC+SDEP ! -! Set density +! DNSCNV=EXP(-(ROS*XNS*VGRA/(RO*QI)))*((1.-(XNS*VGRA*ROS/ +! / (RO*QI)))*DNNET + (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET) +! IF(DNSCNV.LT.0.) DNSCNV=0. ! - if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: call setvtz' +! QIHC=(ROS*VGRA/RO)*DNSCNV ! - - call setvtz(ngscnt,ngs,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & - & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & - & ipconc,ndebugzf,ngs,nz,kgs,fadvisc, & - & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,infdo,alpha,ildo) +! QH=QH+DT*QIHC +! QI=QI-DT*QIHC +! XNH=XNH+DT*DNSCNV +! XNS=XNS-DT*DNSCNV + IF ( iglcnvs .eq. 1 ) THEN ! Zrnic, Ziegler et al (1993) -! -! put fall speeds into the x-z arrays -! - DO il = l1,l2 - do mgs = 1,ngscnt - - vtmax = 150.0 + dnnet = cscnvis(mgs) + cscnis(mgs) - csacs(mgs) + dqnet = qscnvi(mgs) + qscni(mgs) + qsacw(mgs) + qsdpv(mgs) + qssbv(mgs) - - IF ( vtxbar(mgs,il,2) .gt. vtxbar(mgs,il,1) .or. & - & ( vtxbar(mgs,il,1) .gt. vtxbar(mgs,il,3) .and. vtxbar(mgs,il,3) > 0.0) ) THEN - - - - vtxbar(mgs,il,1) = Max( vtxbar(mgs,il,1), vtxbar(mgs,il,2) ) - vtxbar(mgs,il,3) = Max( vtxbar(mgs,il,3), vtxbar(mgs,il,1) ) - - ENDIF - - - IF ( vtxbar(mgs,il,1) .gt. vtmax .or. vtxbar(mgs,il,2) .gt. vtmax .or. & - & vtxbar(mgs,il,3) .gt. vtmax ) THEN - - vtxbar(mgs,il,1) = Min(vtmax,vtxbar(mgs,il,1) ) - vtxbar(mgs,il,2) = Min(vtmax,vtxbar(mgs,il,2) ) - vtxbar(mgs,il,3) = Min(vtmax,vtxbar(mgs,il,3) ) - -! call commasmpi_abort() - ENDIF - - - xvt(kgs(mgs),igs(mgs),1,il) = vtxbar(mgs,il,1) - xvt(kgs(mgs),igs(mgs),2,il) = vtxbar(mgs,il,2) - IF ( infdo .ge. 2 ) THEN - xvt(kgs(mgs),igs(mgs),3,il) = vtxbar(mgs,il,3) - ELSE - xvt(kgs(mgs),igs(mgs),3,il) = 0.0 - ENDIF + a3 = 1./(rho0(mgs)*qx(mgs,ls)) + a1 = Exp( - xdn(mgs,ls)*cx(mgs,ls)*vgra*a3 ) ! EXP(-(ROS*XNS*VGRA/(RO*QI))) +! (1.-(XNS*VGRA*ROS/(RO*QI)))*DNNET + a2 = (1.-(cx(mgs,ls)*vgra*xdn(mgs,ls)*a3))*dnnet +! (XNS**2*VGRA*ROS/(RO*QI**2))*DQNET + a4 = cx(mgs,ls)**2*vgra*xdn(mgs,ls)*a3/qx(mgs,ls)*dqnet -! xvt(kgs(mgs),igs(mgs),2,il) = xvt(kgs(mgs),igs(mgs),1,il) + chcns(mgs) = Max( 0.0, a1*(a2 + a4) ) + chcns(mgs) = Min( chcns(mgs), cxmxd(mgs,ls) ) + chcnsh(mgs) = chcns(mgs) - enddo - ENDDO + qhcns(mgs) = Min( xdn(mgs,ls)*vgra*rhoinv(mgs)*chcns(mgs), qxmxd(mgs,ls) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),xdnmn(lh)) +! vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + ELSEIF ( iglcnvs .ge. 2 ) THEN ! treat like ice crystals, i.e., check for rime density (ERM) - if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: COPIED FALL SPEEDS' + IF ( temg(mgs) .lt. 273.0 .and. qsacw(mgs) - qsdpv(mgs) .gt. 0.0 ) THEN + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,ls,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) - 9998 continue + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) - if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: DONE WITH LOOP' +! write(0,*) 'rime dens = ',tmp - if ( kz .gt. nz-1 ) then - go to 1200 - else - nzmpb = kz - end if + IF ( tmp .ge. 200.0 .or. iglcnvs >= 3 ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = (qsacw(mgs) - qsdpv(mgs)) + chcns(mgs) = cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls) +! chcnih(mgs) = rho0(mgs)*qhcni(mgs)/(1.6e-10) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF - if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NZMPB' + ENDIF - end do !! inumgs + ENDIF - if (ndebugzf .gt. 0 ) write(0,*) 'ZIEGFALL: SET NXMPB' - 1200 continue + ENDIF + ELSE ! single moment lfo -! ENDDO ! ix -! ENDDO ! kz + qhcns(mgs) = 0.001*ehscnv(mgs)*max((qx(mgs,ls)-6.e-4),0.0) + qhcns(mgs) = min(qhcns(mgs),qxmxd(mgs,ls)) + IF ( lvol(lh) .ge. 1 ) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/Max(xdn(mgs,ls),400.) + ENDIF + ENDDO +! +! +! heat budget for rain---not all rain that collects ice can freeze +! +! +! + if ( irwfrz .gt. 0 .and. .not. mixedphase) then +! + do mgs = 1,ngscnt +! +! compute total rain that freeze when it interacts with cloud ice +! + qrztot(mgs) = qrfrz(mgs) + qiacr(mgs) + qsacr(mgs) +! +! compute the maximum amount of rain that can freeze +! Used to limit freezing to 4*qrmxd, but now allow all rain to freeze if possible +! + qrzmax(mgs) = & + & ( xdia(mgs,lr,1)*rwvent(mgs)*cx(mgs,lr)*fwet1(mgs) ) + qrzmax(mgs) = max(qrzmax(mgs), 0.0) + qrzmax(mgs) = min(qrztot(mgs), qrzmax(mgs)) + qrzmax(mgs) = min(qx(mgs,lr)/dtp, qrzmax(mgs)) - if (ndebugzf .gt. 0 ) write(0,*) "ZIEGFALL: EXITING SUBROUTINE" + IF ( temcg(mgs) < -30. ) THEN ! allow all to freeze if T < -30 because fwet becomes invalid (negative) + qrzmax(mgs) = qx(mgs,lr)/dtp + ENDIF +! qrzmax(mgs) = min(4.*qrmxd(mgs), qrzmax(mgs)) +! +! compute the correction factor +! +! IF ( qrztot(mgs) .gt. qxmin(lr) ) THEN + IF ( qrztot(mgs) .gt. qrzmax(mgs) .and. qrztot(mgs) .gt. qxmin(lr) ) THEN + qrzfac(mgs) = qrzmax(mgs)/(qrztot(mgs)) + ELSE + qrzfac(mgs) = 1.0 + ENDIF + qrzfac(mgs) = min(1.0, qrzfac(mgs)) +! + end do +! +! +! now correct the above sources +! +! + do mgs = 1,ngscnt + if ( temg(mgs) .le. 273.15 .and. qrzfac(mgs) .lt. 1.0 ) then + qrfrz(mgs) = qrzfac(mgs)*qrfrz(mgs) + qrfrzs(mgs) = qrzfac(mgs)*qrfrzs(mgs) + qrfrzf(mgs) = qrzfac(mgs)*qrfrzf(mgs) + qiacr(mgs) = qrzfac(mgs)*qiacr(mgs) + qsacr(mgs) = qrzfac(mgs)*qsacr(mgs) + qiacrf(mgs) = qrzfac(mgs)*qiacrf(mgs) + qiacrs(mgs) = qrzfac(mgs)*qiacrs(mgs) + crfrz(mgs) = qrzfac(mgs)*crfrz(mgs) + crfrzf(mgs) = qrzfac(mgs)*crfrzf(mgs) + crfrzs(mgs) = qrzfac(mgs)*crfrzs(mgs) + ciacr(mgs) = qrzfac(mgs)*ciacr(mgs) + ciacrf(mgs) = qrzfac(mgs)*ciacrf(mgs) + ciacrs(mgs) = qrzfac(mgs)*ciacrs(mgs) + + vrfrzf(mgs) = qrzfac(mgs)*vrfrzf(mgs) + viacrf(mgs) = qrzfac(mgs)*viacrf(mgs) + end if + end do +! +! +! + end if +! +! +! +! evaporation of rain +! +! +! + qrcev(:) = 0.0 + crcev(:) = 0.0 - RETURN - END subroutine ziegfall1d -! ##################################################################### -! ##################################################################### + do mgs = 1,ngscnt +! + IF ( qx(mgs,lr) .gt. qxmin(lr) ) THEN + qrcev(mgs) = & + & fvce(mgs)*cx(mgs,lr)*rwvent(mgs)*rwcap(mgs)*evapfac +! this line to allow condensation on rain: + IF ( rcond .eq. 1 ) THEN + qrcev(mgs) = min(qrcev(mgs), qxmxd(mgs,lv)) +! this line to have evaporation only: + ELSE + qrcev(mgs) = min(qrcev(mgs), 0.0) + ENDIF -! ##################################################################### -! ##################################################################### + qrcev(mgs) = max(qrcev(mgs), -qrmxd(mgs)) +! if ( temg(mgs) .lt. 273.15 ) qrcev(mgs) = 0.0 + IF ( qrcev(mgs) .lt. 0. .and. lnr > 1 ) THEN +! qrcev(mgs) = -qrmxd(mgs) +! crcev(mgs) = (rho0(mgs)/(xmas(mgs,lr)+1.e-20))*qrcev(mgs) + crcev(mgs) = (cx(mgs,lr)/(qx(mgs,lr)))*qrcev(mgs) + ELSE + crcev(mgs) = 0.0 + ENDIF +! if ( temg(mgs) .lt. 273.15 ) crcev(mgs) = 0.0 +! + ENDIF -! ############################################################################## - subroutine radardd02(nx,ny,nz,nor,na,an,temk, & - & dbz,db,nzdbz,cnoh0t,hwdn1t,ipconc, iunit) + end do ! -! 11.13.2005: Changed values of indices for reordering of lip +! evaporation/condensation of wet graupel and snow ! -! 07.13.2005: Fixed an error where cnoh was being used for graupel and frozen drops + qscev(:) = 0.0 + cscev(:) = 0.0 + qhcev(:) = 0.0 + chcev(:) = 0.0 + qhlcev(:) = 0.0 + chlcev(:) = 0.0 + ! -! 01.24.2005: add ice crystal reflectivity using parameterization of -! Heymsfield (JAS, 1977). Could also try Ferrier for this, too. ! -! 09.28.2002 Test alterations for dry ice following Ferrier (1994) -! for equivalent melted diameter reflectivity. -! Converted to Fortran by ERM. -! -!Date: Tue, 21 Nov 2000 10:13:36 -0600 (CST) -!From: Matthew Gilmore ! -!PRO RF_SPEC ; Computes Radar Reflectivity -!COMMON MAINB, data, x1d, y1d, z1d, iconst, rconst, labels, nx, ny, nz, dshft +! ICE MULTIPLICATION: Two modes (rimpa, and rimpb) +! (following Cotton et al. 1986) ! -!;MODIFICATION HISTORY -!; 5/99 -Svelta Veleva introduces variable dielf (const_ki_x) as a (weak) -!; function of density. This leads to slight modification of dielf such -!; that the snow reflectivity is slightly increased - not a big effect. -!; This is believed to be more accurate than assuming the dielectric -!; constant for snow is the same as for hail in previous versions. + + chmul1(:) = 0.0 + chlmul1(:) = 0.0 + csmul1(:) = 0.0 ! -!;On 6/13/99 I added the VIL computation (k=0 in vil array) -!;On 6/15/99 I removed the number concentration dependencies as a function -!; of temperature (only use for ferrier!) -!;On 6/15/99 I added the Composite reflectivity (k=1 in VIL array) -!;On 6/15/99 I added the Severe Hail Index computation (k=2 in vil array) -!; -!; 6/99 - Veleva and Seo argue that since graupel is more similar to -!; snow (in number conc and size density) than it is to hail, we -!; should not weight wetted graupel with the .95 exponent correction -!; factor as in the case of hail. An if-statement checks the size -!; density for wet hail/graupel and treats them appropriately. -!; -!; 6/22/99 - Added function to compute height of max rf and 40 dbz echo top -!; Also added vilqr which is the model vertical integrated liquid only -!; using qr. Will need to check...doesn't seem consistent with vilZ -!; - + qhmul1(:) = 0.0 + qhlmul1(:) = 0.0 + qsmul1(:) = 0.0 - implicit none - - character(LEN=15), parameter :: microp = 'ZVD' - integer nx,ny,nz,nor,na,ngt - integer nzdbz ! how many levels actually to process - - integer ng1,n10 - integer iunit - integer, parameter :: printyn = 0 - - parameter( ng1 = 1 ) - - real cnoh0t,hwdn1t - integer ipconc - real vr - - - integer imapz,mzdist - - integer vzflag - integer, parameter :: norz = 3 - real an(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,na) - real db(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air density -! real gt(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor,ngt) - real temk(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! air temperature (kelvin) - real dbz(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-nor+ng1:nz+nor) ! reflectivity - real gz(-nor+1:nz+nor) ! ,z1d(-nor+1:nz+nor,4) - -! real g,rgas,eta,inveta - real cr1, cr2 , hwdnsq,swdnsq - real rwdnsq, dhmin, qrmin, qsmin, qhmin, qhlmin, tfr, tfrh, zrc - real reflectmin, kw_sq - real const_ki_sn, const_ki_h, ki_sq_sn - real ki_sq_h, dielf_sn, dielf_h - real pi - logical ltest - -! Other data arrays - real gtmp (nx,nz) - real dtmp (nx,nz) - real tmp - - real*8 dtmps, dtmpr, dtmph, dtmphl, g1, zx, ze, x - - integer i,j,k,ix,jy,kz,ihcnt - - real*8 xcnoh, xcnos, dadh, dads, zhdryc, zsdryc, zhwetc,zswetc - real*8 dadr - real dbzmax,dbzmin - parameter ( dbzmin = 0 ) - - real cnow,cnoi,cnoip,cnoir,cnor,cnos - real cnogl,cnogm,cnogh,cnof,cnoh,cnohl - - real swdn, rwdn ,hwdn,gldn,gmdn,ghdn,fwdn,hldn - real swdn0 - - real rwdnmx,cwdnmx,cidnmx,xidnmx,swdnmx,gldnmx,gmdnmx - real ghdnmx,fwdnmx,hwdnmx,hldnmx - real rwdnmn,cwdnmn,cidnmn,xidnmn,swdnmn,gldnmn,gmdnmn - real ghdnmn,fwdnmn,hwdnmn,hldnmn + do mgs = 1,ngscnt - real gldnsq,gmdnsq,ghdnsq,fwdnsq,hldnsq - - real dadgl,dadgm,dadgh,dadhl,dadf - real zgldryc,zglwetc,zgmdryc, zgmwetc,zghdryc,zghwetc - real zhldryc,zhlwetc,zfdryc,zfwetc - - real dielf_gl,dielf_gm,dielf_gh,dielf_hl,dielf_fw - - integer imx,jmx,kmx - - real swdia,gldia,gmdia,ghdia,fwdia,hwdia,hldia - - real csw,cgl,cgm,cgh,cfw,chw,chl - real xvs,xvgl,xvgm,xvgh,xvf,xvh,xvhl - - real cwc0 - integer izieg - integer ice10 - real rhos - parameter ( rhos = 0.1 ) - - real qxw ! temp value for liquid water on ice mixing ratio - - real, parameter :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 - real, parameter :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 - real, parameter :: cwradn = 5.0e-6 ! minimum radius - - real cwnccn(nz) - - real :: vzsnow, vzrain, vzgraupel, vzhail - real :: dtp - - -! ######################################################################### - - vzflag = 0 - - izieg = 0 - ice10 = 0 -! g=9.806 ! g: gravity constant -! rgas=287.04 ! rgas: gas constant for dry air -! rcp=rgas/cp ! rcp: gamma constant -! eta=0.622 -! inveta = 1./eta -! rcpinv = 1./rcp -! cpr=cp/rgas -! cvr=cv/rgas - pi = 4.0*ATan(1.) - cwc0 = piinv ! 1./pi ! 6.0/pi - - cnoh = cnoh0t - hwdn = hwdn1t - - rwdn = 1000.0 - swdn = 100.0 - - qrmin = 1.0e-05 - qsmin = 1.0e-06 - qhmin = 1.0e-05 - + ltest = qx(mgs,lh) .gt. qxmin(lh) + IF ( lhl > 1 ) ltest = ltest .or. qx(mgs,lhl) .gt. qxmin(lhl) + + IF ( (itype1 .ge. 1 .or. itype2 .ge. 1 ) & + & .and. qx(mgs,lc) .gt. qxmin(lc)) THEN + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 271.15 ) then + IF ( ipconc .ge. 2 ) THEN + IF ( xv(mgs,lc) .gt. 0.0 & + & .and. ltest & +! .and. itype2 .ge. 2 & + & ) THEN ! -! default slope intercepts +! Ziegler et al. 1986 Hallett-Mossop process. VSTAR = 7.23e-15 (vol of 12micron radius) ! - cnow = 1.0e+08 - cnoi = 1.0e+08 - cnoip = 1.0e+08 - cnoir = 1.0e+08 - cnor = 8.0e+06 - cnos = 8.0e+06 - cnogl = 4.0e+05 - cnogm = 4.0e+05 - cnogh = 4.0e+05 - cnof = 4.0e+05 - cnohl = 1.0e+03 - - - imx = 1 - jmx = 1 - kmx = 1 - i = 1 - - - IF ( microp(1:4) .eq. 'ZIEG' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN - -! write(0,*) 'Set reflectivity for ZIEG' - izieg = 1 - - hwdn = hwdn1t ! 500. - - - cnor = cno(lr) - cnos = cno(ls) - cnoh = cno(lh) - qrmin = qxmin(lr) - qsmin = qxmin(ls) - qhmin = qxmin(lh) + ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc)) + IF ( itype2 .le. 2 ) THEN + ft = Max(0.0,Min(1.0,-0.11*temcg(mgs)**2 - 1.1*temcg(mgs)-1.7)) + ELSE + IF ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) THEN + ft = 0.5 + ELSEIF (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) THEN + ft = 1.0 + ELSEIF (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) THEN + ft = 0.5 + ELSE + ft = 0.0 + ENDIF + ENDIF +! rhoinv = 1./rho0(mgs) +! DNSTAR = ex1*cglacw(mgs) + + IF ( ft > 0.0 ) THEN + + IF ( itype2 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + chmul1(mgs) = ft*ex1*chacw(mgs) +! chmul1(mgs) = Min( ft*ex1*chacw(mgs), ft*(30.*1.e+06)*rho0(mgs)*qhacw(mgs) ) ! 1.e+6 converts kg to mg; Saunders & Hosseini (2001) average of about 30 crystals per mg + qhmul1(mgs) = cimas0*chmul1(mgs)*rhoinv(mgs) + ENDIF IF ( lhl .gt. 1 ) THEN - cnohl = cno(lhl) - qhlmin = qxmin(lhl) + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + chlmul1(mgs) = (ft*ex1*chlacw(mgs)) + qhlmul1(mgs) = cimas0*chlmul1(mgs)*rhoinv(mgs) + ENDIF ENDIF + ENDIF ! itype2 - ELSEIF ( microp(1:3) .eq. 'ZVD' ) THEN ! na .ge. 14 .and. ipconc .ge. 3 ) THEN - - izieg = 1 - - swdn0 = swdn - - cnor = cno(lr) - cnos = cno(ls) - cnoh = cno(lh) - - qrmin = qxmin(lr) - qsmin = qxmin(ls) - qhmin = qxmin(lh) + IF ( itype1 > 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. (.not. wetsfc(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhacw(mgs) + chmul1(mgs) = chmul1(mgs) + tmp + qhmul1(mgs) = qhmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF IF ( lhl .gt. 1 ) THEN - cnohl = cno(lhl) - qhlmin = qxmin(lhl) + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = ft*(3.5e+08)*rho0(mgs)*qhlacw(mgs) + chlmul1(mgs) = chlmul1(mgs) + tmp + qhlmul1(mgs) = qhlmul1(mgs) + cimas0*tmp*rhoinv(mgs) + ENDIF ENDIF -! write(*,*) 'radardbz: ',db(1,1,1),temk(1,1,1),an(1,1,1,lr),an(1,1,1,ls),an(1,1,1,lh) - - - ENDIF + ENDIF ! itype1 + + ENDIF ! ft + ENDIF ! xv(mgs,lc) .gt. 0.0 .and. -! cdx(lr) = 0.60 -! -! IF ( lh > 1 ) THEN -! cdx(lh) = 0.8 ! 1.0 ! 0.45 -! cdx(ls) = 2.00 -! ENDIF + ELSE ! ipconc .lt. 2 ! -! IF ( lhl .gt. 1 ) cdx(lhl) = 0.45 +! define the temperature function ! -! xvmn(lc) = xvcmn -! xvmn(lr) = xvrmn + fimt1(mgs) = 0.0 ! -! xvmx(lc) = xvcmx -! xvmx(lr) = xvrmx +! Cotton et al. (1986) version ! -! IF ( lh > 1 ) THEN -! xvmn(ls) = xvsmn -! xvmn(lh) = xvhmn -! xvmx(ls) = xvsmx -! xvmx(lh) = xvhmx -! ENDIF + if ( temg(mgs) .ge. 268.15 .and. temg(mgs) .le. 270.15 ) then + fimt1(mgs) = 1.0 -(temg(mgs)-268.15)/2.0 + elseif (temg(mgs) .le. 268.15 .and. temg(mgs) .ge. 265.15 ) then + fimt1(mgs) = 1.0 +(temg(mgs)-268.15)/3.0 + ELSE + fimt1(mgs) = 0.0 + end if ! -! IF ( lhl .gt. 1 ) THEN -! xvmn(lhl) = xvhlmn -! xvmx(lhl) = xvhlmx -! ENDIF +! Ferrier (1994) version ! -! xdnmx(lr) = 1000.0 -! xdnmx(lc) = 1000.0 -! IF ( lh > 1 ) THEN -! xdnmx(li) = 917.0 -! xdnmx(ls) = 300.0 -! xdnmx(lh) = 900.0 -! ENDIF -! IF ( lhl .gt. 1 ) xdnmx(lhl) = 900.0 -!! -! xdnmn(:) = 900.0 -! -! xdnmn(lr) = 1000.0 -! xdnmn(lc) = 1000.0 -! IF ( lh > 1 ) THEN -! xdnmn(li) = 100.0 -! xdnmn(ls) = 100.0 -! xdnmn(lh) = 170.0 -! ENDIF -! IF ( lhl .gt. 1 ) xdnmn(lhl) = 500.0 + if ( temg(mgs) .ge. 265.15 .and. temg(mgs) .le. 267.15 ) then + fimt1(mgs) = 0.5 + elseif (temg(mgs) .ge. 267.15 .and. temg(mgs) .le. 269.15 ) then + fimt1(mgs) = 1.0 + elseif (temg(mgs) .ge. 269.15 .and. temg(mgs) .le. 271.15 ) then + fimt1(mgs) = 0.5 + ELSE + fimt1(mgs) = 0.0 + end if ! -! xdn0(:) = 900.0 -! -! xdn0(lc) = 1000.0 -! xdn0(lr) = 1000.0 -! IF ( lh > 1 ) THEN -! xdn0(li) = 900.0 -! xdn0(ls) = 100.0 ! 100.0 -! xdn0(lh) = hwdn1t ! (0.5)*(xdnmn(lh)+xdnmx(lh)) -! ENDIF -! IF ( lhl .gt. 1 ) xdn0(lhl) = 800.0 - ! -! slope intercepts +! type I: 350 splinters are formed for every 1e-3 grams of cloud +! water accreted by graupel/hail (note converted to MKS units) +! 3.5e+8 has units of 1/kg ! -! cnow = 1.0e+08 -! cnoi = 1.0e+08 -! cnoip = 1.0e+08 -! cnoir = 1.0e+08 -! cnor = 8.0e+06 -! cnos = 8.0e+06 -! cnogl = 4.0e+05 -! cnogm = 4.0e+05 -! cnogh = 4.0e+05 -! cnof = 4.0e+05 -!c cnoh = 4.0e+04 -! cnohl = 1.0e+03 + IF ( itype1 .ge. 1 ) THEN + fimta(mgs) = (3.5e+08)*rho0(mgs) + ELSE + fimta(mgs) = 0.0 + ENDIF + ! ! -! density maximums and minimums +! type II: 1 splinter formed for every 250 cloud droplets larger than +! 24 micons in diameter (12 microns in radius) accreted by +! graupel/hail ! - rwdnmx = 1000.0 - cwdnmx = 1000.0 - cidnmx = 917.0 - xidnmx = 917.0 - swdnmx = 200.0 - gldnmx = 400.0 - gmdnmx = 600.0 - ghdnmx = 800.0 - fwdnmx = 900.0 - hwdnmx = 900.0 - hldnmx = 900.0 ! - rwdnmn = 1000.0 - cwdnmn = 1000.0 - xidnmn = 001.0 - cidnmn = 001.0 - swdnmn = 001.0 - gldnmn = 200.0 - gmdnmn = 400.0 - ghdnmn = 600.0 - fwdnmn = 700.0 - hwdnmn = 700.0 - hldnmn = 900.0 + fimt2(mgs) = 0.0 + xcwmas = xmas(mgs,lc) * 1000. +! + IF ( itype2 .ge. 1 ) THEN + if ( xcwmas.lt.1.26e-9 ) then + fimt2(mgs) = 0.0 + end if + if ( xcwmas .le. 3.55e-9 .and. xcwmas .ge. 1.26e-9 ) then + fimt2(mgs) = (2.27)*alog(xcwmas) + 13.39 + end if + if ( xcwmas .gt. 3.55e-9 ) then + fimt2(mgs) = 1.0 + end if + fimt2(mgs) = min(fimt2(mgs),1.0) + fimt2(mgs) = max(fimt2(mgs),0.0) - gldn = (0.5)*(gldnmn+gldnmx) ! 300. - gmdn = (0.5)*(gmdnmn+gmdnmx) ! 500. - ghdn = (0.5)*(ghdnmn+ghdnmx) ! 700. - fwdn = (0.5)*(fwdnmn+fwdnmx) ! 800. - hldn = (0.5)*(hldnmn+hldnmx) ! 900. + ENDIF +! +! qhmul2 = 0.0 +! qsmul2 = 0.0 +! +! qhmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qhacw(mgs) +! qsmul2 = +! > (4.0e-03)*fimt1(mgs)*fimt2(mgs)*qsacw(mgs) +! +! cimas0 = (1.0e-12) +! cimas0 = 2.5e-10 + IF ( .not. wetsfc(mgs) ) THEN + chmul1(mgs) = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhacw(mgs) + ENDIF +! + qhmul1(mgs) = chmul1(mgs)*(cimas0/rho0(mgs)) - cr1 = 7.2e+20 - cr2 = 7.295e+19 - hwdnsq = hwdn**2 - swdnsq = swdn**2 - rwdnsq = rwdn**2 + IF ( lhl .gt. 1 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. (.not. wetsfchl(mgs)) ) THEN + tmp = fimt1(mgs)*(fimta(mgs) + & + & (4.0e-03)*fimt2(mgs))*qhlacw(mgs) + chlmul1(mgs) = tmp + qhlmul1(mgs) = cimas0*tmp*rhoinv(mgs) + ENDIF + ENDIF - gldnsq = gldn**2 - gmdnsq = gmdn**2 - ghdnsq = ghdn**2 - fwdnsq = fwdn**2 - hldnsq = hldn**2 +! qsmul1(mgs) = csmul1(mgs)*(cimas0/rho0(mgs)) +! + ENDIF ! ( ipconc .ge. 2 ) - dhmin = 0.005 - tfr = 273.16 - tfrh = tfr - 8.0 - zrc = cr1*cnor - reflectmin = 0.0 - kw_sq = 0.93 - dbzmax = dbzmin + end if ! (in temperature range) - ihcnt=0 - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Dielectric Factor - Formulas implemented by Svetla Veleva -! following Battan, "Radar Meteorology" - p. 40 -! The result of these calculations is that the dielf numerator (ki_sq) without -! the density ratio is .2116 for hail if using 917 density and .25 for -! snow if using 220 density. -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - const_ki_sn = 0.5 - (0.5-0.46)/(917.-220.)*(swdn-220.) - const_ki_h = 0.5 - (0.5-0.46)/(917.-220.)*(hwdn-220.) - ki_sq_sn = (swdnsq/rwdnsq) * const_ki_sn**2 - ki_sq_h = (hwdnsq/rwdnsq) * const_ki_h**2 - dielf_sn = ki_sq_sn / kw_sq - dielf_h = ki_sq_h / kw_sq - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Use the next line if you want to hardwire dielf for dry hail for both dry -! snow and dry hail. -! This would be equivalent to what Straka had originally. (i.e, .21/.93) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - dielf_sn = (swdnsq/rwdnsq)*.21/ kw_sq - dielf_h = (hwdnsq/rwdnsq)*.21/ kw_sq - - dielf_gl = (gldnsq/rwdnsq)*.21/ kw_sq - dielf_gm = (gmdnsq/rwdnsq)*.21/ kw_sq - dielf_gh = (ghdnsq/rwdnsq)*.21/ kw_sq - dielf_hl = (hldnsq/rwdnsq)*.21/ kw_sq - dielf_fw = (fwdnsq/rwdnsq)*.21/ kw_sq - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Notes on dielectric factors - from Eun-Kyoung Seo -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! constants for both snow and hail would be (x=s,h)..... -! xwdnsq/rwdnsq *0.21/kw_sq ! Straka/Smith - the original -! xwdnsq/rwdnsq *0.224 ! Ferrier - for particle sizes in equiv. drop diam -! xwdnsq/rwdnsq *0.176/kw_sq ! =0.189 in Smith - for particle sizes in equiv -! ice spheres -! xwdnsq/rwdnsq *0.208/kw_sq ! Smith '84 - for particle sizes in equiv melted drop diameter -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - - -! VIL algorithm constants -! Ztop = 10.**(56./10) !56 dbz is the max rf used by WATADS in cell vil - + ENDIF ! ( itype1 .eq. 1 .or. itype2 .eq. 1) +! + end do +! +! +! +! end if +! +! end do +! +! +! ICE MULTIPLICATION FROM SNOW +! Lo and Passarelli 82 / Willis and Heymsfield 89 / Schuur and Rutledge 00b +! using kfrag as fragmentation rate (s-1) / 500 microns as char mean diam for max snow mix ratio +! + csmul(:) = 0.0 + qsmul(:) = 0.0 + + IF ( isnwfrac /= 0 ) THEN + do mgs = 1,ngscnt + IF (temg(mgs) .gt. 265.0) THEN !{ + if (xdia(mgs,ls,1) .gt. 100.e-6 .and. xdia(mgs,ls,1) .lt. 2.0e-3) then ! equiv diameter 100microns to 2mm -! Hail detection algorithm constants -! ZL = 40. -! ZU = 50. -! Ho = 3400. !WATADS Defaults -! Hm20 = 6200. !WATADS Defaults + tmp = rhoinv(mgs)*pi*xdn(mgs,ls)*cx(mgs,ls)*(500.e-6)**3 + qsmul(mgs) = Max( kfrag*( qx(mgs,ls) - tmp ) , 0.0 ) -! DO kz = 1,Min(nzdbz,nz-1) + qsmul(mgs) = Min( qxmxd(mgs,li), qsmul(mgs) ) + csmul(mgs) = Min( cxmxd(mgs,li), rho0(mgs)*qsmul(mgs)/mfrag ) - DO jy=1,1 + endif + ENDIF !} + enddo + ENDIF - DO kz = 1,nz - - DO ix=1,nx - dbz(ix,jy,kz) = 0.0 - - vzsnow = 0.0 - vzrain = 0.0 - vzgraupel = 0.0 - vzhail = 0.0 - - dtmph = 0.0 - dtmps = 0.0 - dtmphl = 0.0 - dtmpr = 0.0 - dadr = (db(ix,jy,kz)/(pi*rwdn*cnor))**(0.25) -!----------------------------------------------------------------------- -! Compute Rain Radar Reflectivity -!----------------------------------------------------------------------- - - dtmp(ix,kz) = 0.0 - gtmp(ix,kz) = 0.0 - IF ( an(ix,jy,kz,lr) .ge. qrmin ) THEN - IF ( ipconc .le. 2 ) THEN - gtmp(ix,kz) = dadr*an(ix,jy,kz,lr)**(0.25) - dtmp(ix,kz) = zrc*gtmp(ix,kz)**7 - ELSEIF ( an(ix,jy,kz,lnr) .gt. 1.e-3 ) THEN - IF ( imurain == 3 ) THEN - vr = db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) - dtmp(ix,kz) = 3.6e18*(rnu+2.)*an(ix,jy,kz,lnr)*vr**2/(rnu+1.) - ELSE ! imurain == 1 - g1 = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar)) - zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lr))**2/an(ix,jy,kz,lnr) - ze =1.e18*zx*(6./(pi*1000.))**2 ! note: using 1000. here for water density - dtmp(ix,kz) = ze - ENDIF - ENDIF - dtmpr = dtmp(ix,kz) - ENDIF - -!----------------------------------------------------------------------- -! Compute snow and graupel reflectivity ! -! Lou modified to look at parcel temperature rather than base state -!----------------------------------------------------------------------- +! frozen rain-rain interaction.... +! +! +! +! +! rain-ice interaction +! +! + do mgs = 1,ngscnt + qracif(mgs) = qraci(mgs) + cracif(mgs) = craci(mgs) +! ciacrf(mgs) = ciacr(mgs) + end do +! +! +! vapor to pristine ice crystals UP +! +! +! +! compute the nucleation rate +! +! do mgs = 1,ngscnt +! idqis = 0 +! if ( ssi(mgs) .gt. 1.0 ) idqis = 1 +! fiinit(mgs) = (felv(mgs)**2)/(cp*rw) +! dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ +! > (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) +! cnnt = min(cnit*exp(-temcg(mgs)*bta1),1.0e+09) +! qiint(mgs) = +! > il5(mgs)*idqis*(1.0/dtp) +! < *min((6.88e-13)*cnnt/rho0(mgs), 0.25*dqisdt(mgs)) +! end do +! +! Meyers et al. (1992; JAS) and Ferrier (1994) primary ice nucleation +! + cmassin = cimasn ! 6.88e-13 + do mgs = 1,ngscnt + qiint(mgs) = 0.0 + ciint(mgs) = 0.0 + qicicnt(mgs) = 0.0 + cicint(mgs) = 0.0 + qipipnt(mgs) = 0.0 + cipint(mgs) = 0.0 + IF ( icenucopt == 1 ) THEN + if ( ( temg(mgs) .lt. 268.15 .or. & +! : ( imeyers5 .and. temg(mgs) .lt. 273.0) ) .and. & + & ( imeyers5 .and. temg(mgs) .lt. 272.0 .and. temgkm2(mgs) .lt. tfr) ) .and. & + & ciintmx .gt. (cx(mgs,li)) & +! : .and. cninm(mgs) .gt. 0. & + & ) then + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/ & + & (1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) +! qidsvp(mgs) = dqisdt(mgs) + idqis = 0 + if ( ssi(mgs) .gt. 1.0 ) THEN + idqis = 1 + dzfacp = max( float(kgsp(mgs)-kgs(mgs)), 0.0 ) + dzfacm = max( float(kgs(mgs)-kgsm(mgs)), 0.0 ) + qiint(mgs) = & + & idqis*il5(mgs) & + & *(cmassin/rho0(mgs)) & + & *max(0.0,wvel(mgs)) & + & *max((cninp(mgs)-cninm(mgs)),0.0)/gz(igs(mgs),jgs,kgs(mgs)) & + & /((dzfacp+dzfacm)) - IF( lhab .gt. lr ) THEN + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin +! +! limit new crystals so it does not increase the current concentration +! above ciintmx 20,000 per liter (2.e7 per m**3) +! +! ciintmx = 1.e9 +! ciintmx = 1.e9 + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(ciint(mgs), ccin(mgs)) + ccin(mgs) = ccin(mgs) - ciint(mgs) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ELSEIF ( lcina > 1 ) THEN + ciint(mgs) = Max(0.0, Min( ciint(mgs), Min( cnina(mgs), ciintmx ) - cina(mgs) )) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( ciint(mgs) .gt. (ciintmx - (cx(mgs,li)))) THEN + ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) ) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ENDIF + end if + endif -! qs2d = reform(data[*,*,k,10],[nx*ny]) -! qh2d = reform(data[*,*,k,11],[nx*ny]) + ELSEIF ( icenucopt == 2 .or. icenucopt == -1 .or. icenucopt == -2 ) THEN + + IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 0.999 ) .or. ssi(mgs) > 1.05 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ccin(mgs) = ccin(mgs) - ciint(mgs) + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) ) + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Only use the following lines if running Straka's GEMS microphysics -! (Sam 1-d version modified by L Wicker does not use this) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! ;xcnoh = cnoh*exp(-0.025*(temp-tfr)) -! ;xcnos = cnos*exp(-0.038*(temp-tfr)) -! ;good = where(temp GT tfr, n_elements) -! ;IF n_elements NE 0 THEN xcnoh(good) = cnoh*exp(-0.075*(temp(good)-tfr)) -! ;IF n_elements NE 0 THEN xcnos(good) = cnos*exp(-0.088*(temp(good)-tfr)) + fiinit(mgs) = (felv(mgs)**2)/(cp*rw) + dqisdt(mgs) = (qx(mgs,lv)-qis(mgs))/(1.0 + fiinit(mgs)*qis(mgs)/tsqr(mgs)) + qiint(mgs) = min(qiint(mgs), max(0.25*dqisdt(mgs),0.0)) + ciint(mgs) = qiint(mgs)*rho0(mgs)/cmassin + ENDIF + + + + ELSEIF ( icenucopt == 3 ) THEN + IF ( temg(mgs) .lt. 268.15 ) THEN + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ccin(mgs) = ccin(mgs) - ciint(mgs) + ELSE + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) ) + ENDIF + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ENDIF -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Only use the following lines if running Ferrier micro with No=No(T) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! ; NOSE = -.15 -! ; NOGE = .0 -! ; xcnoh = cnoh*(1.>exp(NOGE*(temp-tfr)) ) -! ; xcnos = cnos*(1.>exp(NOSE*(temp-tfr)) ) + ENDIF +! + if ( xplate(mgs) .eq. 1 ) then + qipipnt(mgs) = qiint(mgs) + cipint(mgs) = ciint(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qicicnt(mgs) = qiint(mgs) + cicint(mgs) = ciint(mgs) + end if +! +! qipipnt(mgs) = 0.0 +! qicicnt(mgs) = qiint(mgs) +! + end do +! +! -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! Use the following lines if Nos and Noh are constant -! (As in Svetla's version of Ferrier, GCE Tao, and SAM 1-d) -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - xcnoh = cnoh - xcnos = cnos +! +! vapor to cloud droplets UP +! + if (ndebug .gt. 0 ) write(0,*) 'dbg = 8' +! +! + if (ndebug .gt. 0 ) write(0,*) 'Collection: set 3-component' +! +! time for riming.... +! +! rimtim = 240.0 +! dtrim = rimtim +! xacrtim = 120.0 +! tranfr = 0.50 +! tranfw = 0.50 +! +! coefficients for riming +! +! rimc1 = 300.00 +! rimc2 = 0.44 +! +! +! zero som arrays +! +! + do mgs = 1,ngscnt + qrshr(mgs) = 0.0 + qsshrp(mgs) = 0.0 + qhshrp(mgs) = 0.0 + end do +! +! +! first sum all of the shed rain +! +! + do mgs = 1,ngscnt + qrshr(mgs) = qsshr(mgs) + qhshr(mgs) + qhlshr(mgs) + crshr(mgs) = chshrr(mgs)/rzxh(mgs) + chlshrr(mgs)/rzxhl(mgs) + IF ( ipconc .ge. 3 ) THEN +! crshr(mgs) = Max(crshr(mgs), rho0(mgs)*qrshr(mgs)/(xdn(mgs,lr)*vr1mm) ) + ENDIF + end do +! +! +! ! -! Temporary fix for predicted number concentration -- need a -! more appropriate reflectivity equation! ! -! IF ( an(ix,jy,kz,lns) .lt. 0.1 ) THEN -! swdia = (xvrmn*cwc0)**(1./3.) -! xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvrmn*swdn*swdia) -! ELSE -! ! changed back to diameter of mean volume!!! -! swdia = -! > (an(ix,jy,kz,ls)*db(ix,jy,kz) -! > /(pi*swdn*an(ix,jy,kz,lns)))**(1./3.) ! -! xcnos = an(ix,jy,kz,lns)/swdia -! ENDIF +! + IF ( ipconc .ge. 1 ) THEN +! +! +! concentration production terms +! +! YYY +! +! +! DO mgs = 1,ngscnt + pccwi(:) = 0.0 + pccwd(:) = 0.0 + pccii(:) = 0.0 + pccin(:) = 0.0 + pccid(:) = 0.0 + pcrwi(:) = 0.0 + pcrwd(:) = 0.0 + pcswi(:) = 0.0 + pcswd(:) = 0.0 + pchwi(:) = 0.0 + pchwd(:) = 0.0 + pchli(:) = 0.0 + pchld(:) = 0.0 +! ENDDO +! +! Cloud ice +! +! IF ( ipconc .ge. 1 ) THEN - IF ( ls .gt. 1 ) THEN ! { - - IF ( lvs .gt. 1 ) THEN - IF ( an(ix,jy,kz,lvs) .gt. 0.0 ) THEN - swdn = db(ix,jy,kz)*an(ix,jy,kz,ls)/an(ix,jy,kz,lvs) - swdn = Min( 300., Max( 100., swdn ) ) - ELSE - swdn = swdn0 + IF ( warmonly < 0.5 ) THEN + do mgs = 1,ngscnt + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & +! > +il5(mgs)*cidpv(mgs) +! > +il5(mgs)*(cwacii(mgs)) & + & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & +! > + nsplinter*(crfrzf(mgs) + crfrz(mgs)) + & +csmul(mgs) + pccid(mgs) = & + & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & + & -craci(mgs) & + & -csaci(mgs) & + & -chaci(mgs) - chlaci(mgs) & + & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + end do + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + +! qiint(mgs) = 0.0 +! cicint(mgs) = 0.0 +! qicicnt(mgs) = 0.0 + + pccii(mgs) = & + & il5(mgs)*cicint(mgs) & + & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs)) & + & +chmul1(mgs) & + & +chlmul1(mgs) & + & + csplinter(mgs) + csplinter2(mgs) & + & +csmul(mgs) + pccid(mgs) = & +! & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & +! & -craci(mgs) & +! & -csaci(mgs) & +! & -chaci(mgs) - chlaci(mgs) & +! & -chcni(mgs)) & + & +il5(mgs)*cisbv(mgs) & + & -(1.-il5(mgs))*cimlr(mgs) + + pccin(mgs) = ciint(mgs) + + end do + ENDIF ! warmonly + + +! ENDIF ! ( ipconc .ge. 1 ) +! +! Cloud water +! + IF ( ipconc .ge. 2 ) THEN + + do mgs = 1,ngscnt + pccwi(mgs) = (0.0) ! + (1-il5(mgs))*(-cirmlw(mgs)) + + IF ( warmonly < 0.5 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*(-ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & + & -cwfrzc(mgs)-cwctfzc(mgs) & + & ) & + & -cracw(mgs) -csacw(mgs) -chacw(mgs) - chlacw(mgs) + ELSEIF ( warmonly < 0.8 ) THEN + pccwd(mgs) = & + & - cautn(mgs) + & + & il5(mgs)*( & + & -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs) & + & -cwfrzc(mgs)-cwctfzc(mgs) & + & ) & + & -cracw(mgs) -chacw(mgs) -chlacw(mgs) + ELSE + +! tmp3d(igs(mgs),jy,kgs(mgs)) = crcnw(mgs) + +! cracw(mgs) = 0.0 ! turn off accretion +! qracw(mgs) = 0.0 +! crcev(mgs) = 0.0 ! turn off evap +! qrcev(mgs) = 0.0 ! turn off evap +! cracr(mgs) = 0.0 ! turn off self collection + + +! cautn(mgs) = 0.0 +! crcnw(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + pccwd(mgs) = & + & - cautn(mgs) -cracw(mgs) + ENDIF + + + IF ( -pccwd(mgs)*dtp .gt. cx(mgs,lc) ) THEN +! write(0,*) 'OUCH! pccwd(mgs)*dtp .gt. ccw(mgs) ',pccwd(mgs),cx(mgs,lc) +! write(0,*) 'qc = ',qx(mgs,lc) +! write(0,*) -ciacw(mgs)-cwfrzp(mgs)-cwctfzp(mgs)-cwfrzc(mgs)-cwctfzc(mgs) +! write(0,*) -cracw(mgs) -csacw(mgs) -chacw(mgs) +! write(0,*) - cautn(mgs) + + frac = -cx(mgs,lc)/(pccwd(mgs)*dtp) + pccwd(mgs) = -cx(mgs,lc)/dtp + + ciacw(mgs) = frac*ciacw(mgs) + cwfrzp(mgs) = frac*cwfrzp(mgs) + cwctfzp(mgs) = frac*cwctfzp(mgs) + cwfrzc(mgs) = frac*cwfrzc(mgs) + cwctfzc(mgs) = frac*cwctfzc(mgs) + cracw(mgs) = frac*cracw(mgs) + csacw(mgs) = frac*csacw(mgs) + chacw(mgs) = frac*chacw(mgs) + cautn(mgs) = frac*cautn(mgs) + + pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs)) + IF ( lhl .gt. 1 ) chlacw(mgs) = frac*chlacw(mgs) + +! STOP + ENDIF + + end do + + ENDIF ! ipconc + +! +! Rain +! + IF ( ipconc .ge. 3 ) THEN + + do mgs = 1,ngscnt + + IF ( warmonly < 0.5 ) THEN + pcrwi(mgs) = & +! > cracw(mgs) + & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & + & -csmlr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*(-ciacr(mgs) - crfrz(mgs) ) & ! - cipacr(mgs)) +! > -csacr(mgs) & + & - chacr(mgs) - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) +! > -il5(mgs)*ciracr(mgs) + ELSEIF ( warmonly < 0.8 ) THEN + pcrwi(mgs) = & + & crcnw(mgs) & + & +(1-il5(mgs))*( & + & -chmlrr(mgs)/rzxh(mgs) & + & -chlmlrr(mgs)/rzxhl(mgs) & + & -csmlr(mgs) & + & - cimlr(mgs) ) & + & -crshr(mgs) !null at this point when wet snow/graupel included + pcrwd(mgs) = & + & il5(mgs)*( - crfrz(mgs) ) & ! - cipacr(mgs)) + & - chacr(mgs) & + & - chlacr(mgs) & + & +crcev(mgs) & + & - cracr(mgs) + ELSE + pcrwi(mgs) = & + & crcnw(mgs) + pcrwd(mgs) = & + & +crcev(mgs) & + & - cracr(mgs) + +! tmp3d(igs(mgs),jy,kgs(mgs)) = vtxbar(mgs,lr,1) ! crcnw(mgs) ! (pcrwi(mgs) + pcrwd(mgs)) +! pcrwi(mgs) = 0.0 +! pcrwd(mgs) = 0.0 +! qrcnw(mgs) = 0.0 + + ENDIF + + + frac = 0.0 + IF ( -pcrwd(mgs)*dtp .gt. cx(mgs,lr) ) THEN +! write(0,*) 'OUCH! pcrwd(mgs)*dtp .gt. crw(mgs) ',pcrwd(mgs)*dtp,cx(mgs,lr),mgs,igs(mgs),kgs(mgs) +! write(0,*) -ciacr(mgs) +! write(0,*) -crfrz(mgs) +! write(0,*) -chacr(mgs) +! write(0,*) crcev(mgs) +! write(0,*) -cracr(mgs) + + frac = -cx(mgs,lr)/(pcrwd(mgs)*dtp) + pcrwd(mgs) = -cx(mgs,lr)/dtp + + ciacr(mgs) = frac*ciacr(mgs) + ciacrf(mgs) = frac*ciacrf(mgs) + ciacrs(mgs) = frac*ciacrs(mgs) + crfrz(mgs) = frac*crfrz(mgs) + crfrzf(mgs) = frac*crfrzf(mgs) + crfrzs(mgs) = frac*crfrzs(mgs) + chacr(mgs) = frac*chacr(mgs) + crcev(mgs) = frac*crcev(mgs) + cracr(mgs) = frac*cracr(mgs) + +! STOP + ENDIF + + end do + + ENDIF + + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + IF ( ipconc .ge. 4 ) THEN ! + + do mgs = 1,ngscnt + pcswi(mgs) = & + & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & + & + ifrzs*crfrzs(mgs) & + & + ifrzs*ciacrs(mgs) & + & + cscnh(mgs) + pcswd(mgs) = & +! : cracs(mgs) & + & -chacs(mgs) - chlacs(mgs) & + & -chcns(mgs) & + & +(1-il5(mgs))*csmlr(mgs) + csshr(mgs) & ! + csshrp(mgs) +! > +il5(mgs)*(cssbv(mgs)) & + & + cssbv(mgs) & + & - csacs(mgs) + + pccii(mgs) = pccii(mgs) & + & + (1. - ifrzs)*crfrzs(mgs) & + & + (1. - ifrzs)*ciacrs(mgs) + + end do + + ENDIF + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +ifrzg*(crfrzf(mgs) & + & +il5(mgs)*(ciacrf(mgs) )) & + & + chcnsh(mgs) + chcnih(mgs) + chcnhl(mgs) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & +! > + il5(mgs)*chsbv(mgs) & + & + chsbv(mgs) & + & - il5(mgs)*chlcnh(mgs) & + & - cscnh(mgs) + end do +! + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs) +il5(mgs)*(ciacrf(mgs) )) & + & + chlcnh(mgs) *rzxhlh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) & +! > + il5(mgs)*chlsbv(mgs) & + & + chlsbv(mgs) - chcnhl(mgs) + +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF + end do + + ENDIF +! + + ENDIF ! (ipconc .ge. 5 ) + + ELSEIF ( warmonly < 0.8 ) THEN + +! +! Graupel +! + IF ( ipconc .ge. 5 ) THEN ! + do mgs = 1,ngscnt + pchwi(mgs) = & + & +ifrzg*(crfrzf(mgs) ) + + pchwd(mgs) = & + & (1-il5(mgs))*chmlr(mgs) & + & - il5(mgs)*chlcnh(mgs) + end do +! +! Hail +! + IF ( lhl .gt. 1 ) THEN ! + do mgs = 1,ngscnt + pchli(mgs) = & ! (1.0-ifrzg)*(crfrzf(mgs) +il5(mgs)*(ciacrf(mgs) )) & + & + chlcnh(mgs) *rzxhl(mgs)/rzxh(mgs) + + pchld(mgs) = & + & (1-il5(mgs))*chlmlr(mgs) ! & +! > + il5(mgs)*chlsbv(mgs) & +! & + chlsbv(mgs) + +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: pchli,pchld = ', pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF + end do + + ENDIF + + ENDIF ! ipconc >= 5 + + ENDIF ! warmonly + +! + +! +! Balance and checks for continuity.....within machine precision... +! + do mgs = 1,ngscnt + pctot(mgs) = pccwi(mgs) +pccwd(mgs) + & + & pccii(mgs) +pccid(mgs) + & + & pcrwi(mgs) +pcrwd(mgs) + & + & pcswi(mgs) +pcswd(mgs) + & + & pchwi(mgs) +pchwd(mgs) + & + & pchli(mgs) +pchld(mgs) + end do +! +! + ENDIF ! ( ipconc .ge. 1 ) +! +! +! +! +! +! GOGO +! production terms for mass +! +! + pqwvi(:) = 0.0 + pqwvd(:) = 0.0 + pqcwi(:) = 0.0 + pqcwd(:) = 0.0 + pqcii(:) = 0.0 + pqcid(:) = 0.0 + pqrwi(:) = 0.0 + pqrwd(:) = 0.0 + pqswi(:) = 0.0 + pqswd(:) = 0.0 + pqhwi(:) = 0.0 + pqhwd(:) = 0.0 + pqhli(:) = 0.0 + pqhld(:) = 0.0 + pqlwsi(:) = 0.0 + pqlwsd(:) = 0.0 + pqlwhi(:) = 0.0 + pqlwhd(:) = 0.0 + pqlwhli(:) = 0.0 + pqlwhld(:) = 0.0 +! +! Vapor +! + IF ( warmonly < 0.5 ) THEN + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + end do + + ELSEIF ( warmonly < 0.8 ) THEN + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -il5(mgs)*qisbv(mgs) + pqwvd(mgs) = & + & +il5(mgs)*(-qiint(mgs) & +! & -qhdpv(mgs) ) & !- qhldpv(mgs)) & + & -qhdpv(mgs) - qhldpv(mgs)) & +! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -Max(0.0, qrcev(mgs)) & + & -il5(mgs)*qidpv(mgs) + end do + + ELSE + do mgs = 1,ngscnt + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) + end do + + ENDIF ! warmonly +! +! Cloud water +! + do mgs = 1,ngscnt + + pqcwi(mgs) = (0.0) + qwcnr(mgs) + + IF ( warmonly < 0.5 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrzc(mgs)-qwctfzc(mgs)) & + & -il5(mgs)*(qicichr(mgs)) & + & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) +! > -il5(mgs)*(qwfrzp(mgs)+qwctfzp(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqcwd(mgs) = & + & il5(mgs)*(-qiacw(mgs)-qwfrzc(mgs)-qwctfzc(mgs)) & +! & il5(mgs)*(-qwfrzc(mgs)-qwctfzc(mgs)) & + & -il5(mgs)*(qicichr(mgs)) & + & -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs) + ELSE + pqcwd(mgs) = & + & -qracw(mgs) - qrcnw(mgs) + ENDIF + + IF ( pqcwd(mgs) .lt. 0.0 .and. -pqcwd(mgs)*dtp .gt. qx(mgs,lc) ) THEN + + frac = -Max(0.0,qx(mgs,lc))/(pqcwd(mgs)*dtp) + pqcwd(mgs) = -qx(mgs,lc)/dtp + + qiacw(mgs) = frac*qiacw(mgs) +! qwfrzp(mgs) = frac*qwfrzp(mgs) +! qwctfzp(mgs) = frac*qwctfzp(mgs) + qwfrzc(mgs) = frac*qwfrzc(mgs) + qwctfzc(mgs) = frac*qwctfzc(mgs) + qracw(mgs) = frac*qracw(mgs) + qsacw(mgs) = frac*qsacw(mgs) + qhacw(mgs) = frac*qhacw(mgs) + vhacw(mgs) = frac*vhacw(mgs) + qrcnw(mgs) = frac*qrcnw(mgs) + qwfrz(mgs) = frac*qwfrz(mgs) + qwfrzp(mgs) = frac*qwfrzp(mgs) + IF ( lhl .gt. 1 ) THEN + qhlacw(mgs) = frac*qhlacw(mgs) + vhlacw(mgs) = frac*vhlacw(mgs) + ENDIF +! IF ( lzh .gt. 1 ) zhacw(mgs) = frac*zhacw(mgs) + +! STOP + ENDIF + + + end do +! +! Cloud ice +! + IF ( warmonly < 0.5 ) THEN + + do mgs = 1,ngscnt + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) & ! (qiacwi(mgs)+qwacii(mgs)) & + & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & + & +il5(mgs)*(qicichr(mgs)) & + & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) +! > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + + pqcid(mgs) = & + & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & + & -qraci(mgs) & + & -qsaci(mgs) ) & + & -qhaci(mgs) & + & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) & + & - qhcni(mgs) + end do + + ELSEIF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + pqcii(mgs) = & + & il5(mgs)*qicicnt(mgs) & + & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & + & +qhmul1(mgs) + qhlmul1(mgs) & + & + qsplinter(mgs) + qsplinter2(mgs) & + & +il5(mgs)*qidpv(mgs) & + & +il5(mgs)*qiacw(mgs) ! & ! (qiacwi(mgs)+qwacii(mgs)) & +! & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & +! & +il5(mgs)*(qicichr(mgs)) & +! & +qsmul(mgs) & +! & +qhmul1(mgs) + qhlmul1(mgs) & +! & + qsplinter(mgs) + qsplinter2(mgs) + + pqcid(mgs) = & +! & il5(mgs)*(-qscni(mgs) - qscnvi(mgs) & ! -qwaci(mgs) & +! & -qraci(mgs) & +! & -qsaci(mgs) ) & +! & -qhaci(mgs) & +! & -qhlaci(mgs) & + & +il5(mgs)*qisbv(mgs) & + & +(1.-il5(mgs))*qimlr(mgs) ! & +! & - qhcni(mgs) + end do + + ENDIF +! +! Rain +! + + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhmlr(mgs) & !null at this point when wet snow/graupel included + & -qsmlr(mgs) - qhlmlr(mgs) & + & -qimlr(mgs)) & + & -qsshr(mgs) & !null at this point when wet snow/graupel included + & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs)) & + & - qsacr(mgs) - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) & + & +(1-il5(mgs))*( & + & -qhmlr(mgs) & !null at this point when wet snow/graupel included + & -qhshr(mgs) & !null at this point when wet snow/graupel included + & -qhlmlr(mgs) & !null at this point when wet snow/graupel included + & -qhlshr(mgs) ) !null at this point when wet snow/graupel included + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwi(mgs) = & + & qracw(mgs) + qrcnw(mgs) + Max(0.0, qrcev(mgs)) + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + + + ! IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + IF ( pqrwd(mgs) .lt. 0.0 .and. -(pqrwd(mgs) + pqrwi(mgs))*dtp .gt. qx(mgs,lr) ) THEN + + frac = (-qx(mgs,lr) + pqrwi(mgs)*dtp)/(pqrwd(mgs)*dtp) +! pqrwd(mgs) = -qx(mgs,lr)/dtp + pqrwi(mgs) + + pqwvi(mgs) = pqwvi(mgs) & + & + Min(0.0, qrcev(mgs)) & + & - frac*Min(0.0, qrcev(mgs)) + pqwvd(mgs) = pqwvd(mgs) & + & + Max(0.0, qrcev(mgs)) & + & - frac*Max(0.0, qrcev(mgs)) + + qiacr(mgs) = frac*qiacr(mgs) + qiacrf(mgs) = frac*qiacrf(mgs) + qiacrs(mgs) = frac*qiacrs(mgs) + viacrf(mgs) = frac*viacrf(mgs) + qrfrz(mgs) = frac*qrfrz(mgs) + qrfrzs(mgs) = frac*qrfrzs(mgs) + qrfrzf(mgs) = frac*qrfrzf(mgs) + vrfrzf(mgs) = frac*vrfrzf(mgs) + qsacr(mgs) = frac*qsacr(mgs) + qhacr(mgs) = frac*qhacr(mgs) + vhacr(mgs) = frac*vhacr(mgs) + qrcev(mgs) = frac*qrcev(mgs) + qhlacr(mgs) = frac*qhlacr(mgs) + vhlacr(mgs) = frac*vhlacr(mgs) +! qhcev(mgs) = frac*qhcev(mgs) + + + IF ( warmonly < 0.5 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qiacr(mgs)-qrfrz(mgs) - qsacr(mgs)) & + & - qhacr(mgs) - qhlacr(mgs) - qwcnr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pqrwd(mgs) = & + & il5(mgs)*(-qrfrz(mgs)) & + & - qhacr(mgs) & + & - qhlacr(mgs) & + & + Min(0.0,qrcev(mgs)) + ELSE + pqrwd(mgs) = Min(0.0,qrcev(mgs)) + ENDIF ! warmonly + +! +! Resum for vapor since qrcev has changed +! + IF ( qrcev(mgs) .ne. 0.0 ) THEN + pqwvi(mgs) = & + & -Min(0.0, qrcev(mgs)) & + & -Min(0.0, qhcev(mgs)) & + & -Min(0.0, qhlcev(mgs)) & + & -Min(0.0, qscev(mgs)) & +! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & + & -qhsbv(mgs) - qhlsbv(mgs) & + & -qssbv(mgs) & + & -il5(mgs)*qisbv(mgs) + pqwvd(mgs) = & + & -Max(0.0, qrcev(mgs)) & + & -Max(0.0, qhcev(mgs)) & + & -Max(0.0, qhlcev(mgs)) & + & -Max(0.0, qscev(mgs)) & + & +il5(mgs)*(-qiint(mgs) & + & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & + & -il5(mgs)*qidpv(mgs) + ENDIF + + +! STOP + ENDIF + end do + + IF ( warmonly < 0.5 ) THEN + +! +! Snow +! + do mgs = 1,ngscnt + pqswi(mgs) = & + & il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) & + & + ifrzs*(qiacrs(mgs) + qrfrzs(mgs)) & + & + il2(mgs)*qsacr(mgs)) & + & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & + & + Max(0.0, qscev(mgs)) & + & + qsacw(mgs) + qscnh(mgs) + pqswd(mgs) = & +! > -qfacs(mgs) ! -qwacs(mgs) & + & -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs) & + & -qhcns(mgs) & + & +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) & !null at this point when wet snow included +! > +il5(mgs)*(qssbv(mgs)) & + & + (qssbv(mgs)) & + & + Min(0.0, qscev(mgs)) & + & -qsmul(mgs) + + pqcii(mgs) = pqcii(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & + (1. - ifrzs)*qiacrs(mgs) + + end do + +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*ifrzg*(qrfrzf(mgs) + (1-il3(mgs))*(qiacrf(mgs)+qracif(mgs))) & + & + (1-il2(mgs))*(qracs(mgs) + qsacr(mgs)) & + & +il5(mgs)*(qhdpv(mgs)) & + & +Max(0.0, qhcev(mgs)) & + & +qhacr(mgs)+qhacw(mgs) & + & +qhacs(mgs)+qhaci(mgs) & + & + qhcns(mgs) + qhcni(mgs) + qhcnhl(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & +(1-il5(mgs))*qhmlr(mgs) & !null at this point when wet graupel included +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) - qhlcnh(mgs) - qscnh(mgs) & + & - qsplinter(mgs) - qsplinter2(mgs) +! > - cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs) + end do + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & + & +Max(0.0, qhlcev(mgs)) & + & +qhlacr(mgs)+qhlacw(mgs) & + & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) - qhcnhl(mgs) + end do + + ENDIF ! lhl + + ELSEIF ( warmonly < 0.8 ) THEN +! +! Graupel +! + do mgs = 1,ngscnt + pqhwi(mgs) = & + & +il5(mgs)*ifrzg*(qrfrzf(mgs) ) & + & +il5(mgs)*(qhdpv(mgs)) & + & +qhacr(mgs)+qhacw(mgs) + pqhwd(mgs) = & + & qhshr(mgs) & !null at this point when wet graupel included + & - qhlcnh(mgs) & + & - qhmul1(mgs) & + & - qsplinter(mgs) - qsplinter2(mgs) & + & +(1-il5(mgs))*qhmlr(mgs) !null at this point when wet graupel included + end do + +! +! Hail +! + IF ( lhl .gt. 1 ) THEN + + do mgs = 1,ngscnt + pqhli(mgs) = & + & +il5(mgs)*(qhldpv(mgs) ) & ! + (1.0-ifrzg)*(qiacrf(mgs)+qrfrzf(mgs) + qracif(mgs))) & + & +qhlacr(mgs)+qhlacw(mgs) & +! & +qhlacs(mgs)+qhlaci(mgs) & + & + qhlcnh(mgs) + pqhld(mgs) = & + & qhlshr(mgs) & + & +(1-il5(mgs))*qhlmlr(mgs) & +! > +il5(mgs)*qhlsbv(mgs) & + & + qhlsbv(mgs) & + & -qhlmul1(mgs) - qhcnhl(mgs) + + end do + + ENDIF ! lhl + + ENDIF ! warmonly + +! +! Liquid water on snow and graupel +! + + vhmlr(:) = 0.0 + vhlmlr(:) = 0.0 + vhfzh(:) = 0.0 + vhlfzhl(:) = 0.0 + + IF ( mixedphase ) THEN + ELSE ! set arrays for non-mixedphase graupel + +! vhshdr(:) = 0.0 + vhmlr(:) = qhmlr(:) ! not actually volume, but treated as q in rate equation +! vhsoak(:) = 0.0 + +! vhlshdr(:) = 0.0 + vhlmlr(:) = qhlmlr(:) ! not actually volume, but treated as q in rate equation +! vhlmlr(:) = rho0(:)*qhlmlr(:)/xdn(:,lhl) +! vhlsoak(:) = 0.0 + + ENDIF ! mixedphase + + + +! +! Snow volume +! + IF ( lvol(ls) .gt. 1 ) THEN + do mgs = 1,ngscnt +! pvswi(mgs) = rho0(mgs)*( pqswi(mgs) )/xdn0(ls) + + pvswi(mgs) = rho0(mgs)*( & +!aps > il5*qsfzs(mgs)/xdn(mgs,ls) & +!aps > -il5*qsfzs(mgs)/xdn(mgs,lr) & + & +il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & + & + qscnvi(mgs) + (1. - ifrzs)*qiacrs(mgs) & + & + (1. - ifrzs)*qrfrzs(mgs) & + & )/xdn0(ls) & + & + (qsacr(mgs))/rimdn(mgs,ls) ) + vsacw(mgs) +! > + (qsacw(mgs) + qsacr(mgs))/rimdn(mgs,ls) ) + pvswd(mgs) = rho0(mgs)*( pqswd(mgs) )/xdn0(ls) & +! > -qhacs(mgs) +! > -qhcns(mgs) +! > +(1-il5(mgs))*qsmlr(mgs) + qsshr(mgs) +! > +il5(mgs)*(qssbv(mgs)) + & -rho0(mgs)*qsmul(mgs)/xdn0(ls) +!aps > +rho0(mgs)*(1-il5(mgs))*( +!aps > qsmlr(mgs)/xdn(mgs,ls) +!aps > +(qscev-qsmlr(mgs))/xdn(mgs,lr) ) + end do + +!aps IF (mixedphase) THEN +!aps pvswd(mgs) = pvswd(mgs) +!aps > + rho0(mgs)*qsshr(mgs)/xdn(mgs,lr) +!aps ENDIF + + ENDIF +! +! Graupel volume +! + IF ( lvol(lh) .gt. 1 ) THEN + DO mgs = 1,ngscnt +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) )/xdn0(lh) ) + +! pvhwi(mgs) = rho0(mgs)*( (pqhwi(mgs) - il5(mgs)*qrfrzf(mgs) )/xdn0(lh) ! +! : + il5(mgs)*qrfrzf(mgs)/rhofrz ) + + pvhwi(mgs) = rho0(mgs)*( & + & +il5(mgs)*( qracif(mgs))/rhofrz & +!erm > + il5(mgs)*qhfzh(mgs)/rhofrz !aps: or use xdnmx(lh)? & + & + ( il5(mgs)*qhdpv(mgs) & + & + qhacs(mgs) + qhaci(mgs) )/xdnmn(lh) ) & + & + rho0(mgs)*Max(0.0, qhcev(mgs))/1000. & ! only used in mixed phase: evaporation of liquid water coating +! > + qhacs(mgs) + qhaci(mgs) )/xdn0(ls) ) & + & + vhcns(mgs) & + & + vhacr(mgs) + vhacw(mgs) + vhfzh(mgs) & ! qhacw(mgs)/rimdn(mgs,lh) +! > + vhfrh(mgs) & + & + vhcni(mgs) + ifrzg*(viacrf(mgs) + vrfrzf(mgs)) +! > +qhacr(mgs)/raindn(mgs,lh) + qhacw(mgs)/rimdn(mgs,lh) + +! pvhwd(mgs) = rho0(mgs)*(pqhwd(mgs) )/xdn0(lh) + + pvhwd(mgs) = rho0(mgs)*( & +! > qhshr(mgs)/xdn0(lr) & +! > - il5(mgs)*qhfzh(mgs)/xdn(mgs,lr) & + & +( (1-il5(mgs))*vhmlr(mgs) & +! > +il5(mgs)*qhsbv(mgs) & + & + qhsbv(mgs) & + & + Min(0.0, qhcev(mgs)) & + & -qhmul1(mgs) )/xdn(mgs,lh) ) & + & - vhlcnh(mgs) + vhshdr(mgs) - vhsoak(mgs) - vscnh(mgs) + +! IF (mixedphase) THEN +! pvhwd(mgs) = pvhwd(mgs) +! > + rho0(mgs)*qhshr(mgs)/xdn(mgs,lh) !xdn(mgs,lr) +! ENDIF + + IF ( .false. .and. ny .eq. 2 .and. kgs(mgs) .eq. 9 .and. igs(mgs) .eq. 19 ) THEN + + write(iunit,*) + write(iunit,*) 'Graupel at ',igs(mgs),kgs(mgs) +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) 'qhcns',qhcns(mgs) + write(iunit,*) 'qhcni',qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) 'qhacr ',qhacr(mgs) + write(iunit,*) 'qhacw', qhacw(mgs) + write(iunit,*) 'qhacs', qhacs(mgs) + write(iunit,*) 'qhaci', qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) 'qhcev',qhcev(mgs) + write(iunit,*) + write(iunit,*) 'qhshr',qhshr(mgs) + write(iunit,*) 'qhmlr', (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) 'qhsbv', qhsbv(mgs) + write(iunit,*) 'qhlcnh',-qhlcnh(mgs) + write(iunit,*) 'qhmul1',-qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) + write(iunit,*) 'Volume' + write(iunit,*) + write(iunit,*) 'pvhwi',pvhwi(mgs) + write(iunit,*) 'vhcns', vhcns(mgs) + write(iunit,*) 'vhacr,vhacw',vhacr(mgs), vhacw(mgs) ! qhacw(mgs)/rimdn(mgs,lh) + write(iunit,*) 'vhcni',vhcni(mgs) + write(iunit,*) + write(iunit,*) 'pvhwd',pvhwd(mgs) + write(iunit,*) 'vhlcnh,vhshdr,vhsoak ', vhlcnh(mgs), vhshdr(mgs), vhsoak(mgs) + write(iunit,*) 'vhmlr', vhmlr(mgs) + write(iunit,*) +! write(iunit,*) +! write(iunit,*) +! write(iunit,*) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + + + ENDIF + + + ENDDO + + ENDIF +! +! +! + +! +! Hail volume +! + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + DO mgs = 1,ngscnt + + pvhli(mgs) = rho0(mgs)*( & + & + ( il5(mgs)*qhldpv(mgs) & +! & + Max(0.0, qhlcev(mgs)) & +! & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) ) & ! xdn0(ls) ) & + & + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) ) & ! yes, this is 'lh' on purpose + & + rho0(mgs)*Max(0.0, qhlcev(mgs))/1000. & + & + vhlcnhl(mgs) + (1.0-ifrzg)*(viacrf(mgs) + vrfrzf(mgs)) & + & + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl) + + pvhld(mgs) = rho0(mgs)*( & + & +( qhlsbv(mgs) & + & + Min(0.0, qhlcev(mgs)) & + & -qhlmul1(mgs) )/xdn(mgs,lhl) ) & +! & + vhlmlr(mgs) & + & + rho0(mgs)*(1-il5(mgs))*vhlmlr(mgs)/xdn(mgs,lhl) & + & + vhlshdr(mgs) - vhlsoak(mgs) + + + ENDDO + + ENDIF + ENDIF + + + if ( ndebug .ge. 1 ) then + do mgs = 1,ngscnt +! + ptotal(mgs) = 0. + ptotal(mgs) = ptotal(mgs) & + & + pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) +! + + if ( ( (ndebug .ge. 1 ) .and. abs(ptotal(mgs)) .gt. eqtot ) & +! if ( ( abs(ptotal(mgs)) .gt. eqtot ) +! : .or. pqswi(mgs)*dtp .gt. 1.e-3 +! : .or. pqhwi(mgs)*dtp .gt. 1.e-3 +! : .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3 +! : .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7 +! : .or. dtp*(pcipi(mgs)+pcipd(mgs)) .gt. 1.e7 & + & .or. .not. (ptotal(mgs) .lt. 1.0 .and. & + & ptotal(mgs) .gt. -1.0) ) then + write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs, & + & kgs(mgs),ptotal(mgs) + + write(iunit,*) 't7: ', t7(igs(mgs),jgs,kgs(mgs)) + write(iunit,*) 'cci,ccw,crw,rdia: ',cx(mgs,li),cx(mgs,lc),cx(mgs,lr),0.5*xdia(mgs,lr,1) + write(iunit,*) 'qc,qi,qr : ',qx(mgs,lc),qx(mgs,li),qx(mgs,lr) + write(iunit,*) 'rmas, qrcalc : ',xmas(mgs,lr),xmas(mgs,lr)*cx(mgs,lr)/rho0(mgs) + write(iunit,*) 'vti,vtc,eiw,vtr: ',vtxbar(mgs,li,1),vtxbar(mgs,lc,1),eiw(mgs),vtxbar(mgs,lr,1) + write(iunit,*) 'cidia,cwdia,qcmxd: ', xdia(mgs,li,1),xdia(mgs,lc,1),qcmxd(mgs) + write(iunit,*) 'snow: ',qx(mgs,ls),cx(mgs,ls),swvent(mgs),vtxbar(mgs,ls,1),xdia(mgs,ls,1) + write(iunit,*) 'graupel: ',qx(mgs,lh),cx(mgs,lh),hwvent(mgs),vtxbar(mgs,lh,1),xdia(mgs,lh,1) + IF ( lhl .gt. 1 ) write(iunit,*) 'hail: ',qx(mgs,lhl),cx(mgs,lhl),hlvent(mgs),vtxbar(mgs,lhl,1),xdia(mgs,lhl,1) + + + write(iunit,*) 'li: ',xdia(mgs,li,1),xdia(mgs,li,2),xmas(mgs,li),qx(mgs,li), & + & vtxbar(mgs,li,1) + + + write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr) + write(iunit,*) 'temcg = ', temcg(mgs) + + write(iunit,*) pqwvi(mgs) ,pqwvd(mgs) + write(iunit,*) pqcwi(mgs) ,pqcwd(mgs) + write(iunit,*) pqcii(mgs) ,pqcid(mgs) + write(iunit,*) pqrwi(mgs) ,pqrwd(mgs) + write(iunit,*) pqswi(mgs) ,pqswd(mgs) + write(iunit,*) pqhwi(mgs) ,pqhwd(mgs) + write(iunit,*) pqhli(mgs) ,pqhld(mgs) + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + +! +! print production terms +! + write(iunit,*) + write(iunit,*) 'Vapor' +! + write(iunit,*) -Min(0.0,qrcev(mgs)) + write(iunit,*) -il5(mgs)*qhsbv(mgs) + write(iunit,*) -il5(mgs)*qhlsbv(mgs) + write(iunit,*) -il5(mgs)*qssbv(mgs) + write(iunit,*) -il5(mgs)*qisbv(mgs) + write(iunit,*) 'pqwvi= ', pqwvi(mgs) + write(iunit,*) -Max(0.0,qrcev(mgs)) + write(iunit,*) -Max(0.0,qhcev(mgs)) + write(iunit,*) -Max(0.0,qhlcev(mgs)) + write(iunit,*) -Max(0.0,qscev(mgs)) + write(iunit,*) -il5(mgs)*qiint(mgs) + write(iunit,*) -il5(mgs)*qhdpv(mgs) + write(iunit,*) -il5(mgs)*qhldpv(mgs) + write(iunit,*) -il5(mgs)*qsdpv(mgs) + write(iunit,*) -il5(mgs)*qidpv(mgs) + write(iunit,*) 'pqwvd = ', pqwvd(mgs) +! + write(iunit,*) + write(iunit,*) 'Cloud ice' +! + write(iunit,*) il5(mgs)*qicicnt(mgs) + write(iunit,*) il5(mgs)*qidpv(mgs) + write(iunit,*) il5(mgs)*qiacw(mgs) + write(iunit,*) il5(mgs)*qwfrz(mgs) + write(iunit,*) il5(mgs)*qwctfz(mgs) + write(iunit,*) il5(mgs)*qicichr(mgs) + write(iunit,*) qhmul1(mgs) + write(iunit,*) qhlmul1(mgs) + write(iunit,*) 'pqcii = ', pqcii(mgs) + write(iunit,*) -il5(mgs)*qscni(mgs) + write(iunit,*) -il5(mgs)*qscnvi(mgs) + write(iunit,*) -il5(mgs)*qraci(mgs) + write(iunit,*) -il5(mgs)*qsaci(mgs) + write(iunit,*) -il5(mgs)*qhaci(mgs) + write(iunit,*) -il5(mgs)*qhlaci(mgs) + write(iunit,*) il5(mgs)*qisbv(mgs) + write(iunit,*) (1.-il5(mgs))*qimlr(mgs) + write(iunit,*) -il5(mgs)*qhcni(mgs) + write(iunit,*) 'pqcid = ', pqcid(mgs) + write(iunit,*) ' Conc:' + write(iunit,*) pccii(mgs),pccid(mgs) + write(iunit,*) il5(mgs),cicint(mgs) + write(iunit,*) cwacii(mgs),cwfrzc(mgs),cwctfzc(mgs) + write(iunit,*) cicichr(mgs) + write(iunit,*) chmul1(mgs) + write(iunit,*) chlmul1(mgs) + write(iunit,*) csmul(mgs) +! +! +! +! + write(iunit,*) + write(iunit,*) 'Cloud water' +! + write(iunit,*) 'pqcwi =', pqcwi(mgs) + write(iunit,*) -il5(mgs)*qiacw(mgs) + write(iunit,*) -il5(mgs)*qwfrzc(mgs) + write(iunit,*) -il5(mgs)*qwctfzc(mgs) +! write(iunit,*) -il5(mgs)*qwfrzp(mgs) +! write(iunit,*) -il5(mgs)*qwctfzp(mgs) + write(iunit,*) -il5(mgs)*qiihr(mgs) + write(iunit,*) -il5(mgs)*qicichr(mgs) + write(iunit,*) -il5(mgs)*qipiphr(mgs) + write(iunit,*) -qracw(mgs) + write(iunit,*) -qsacw(mgs) + write(iunit,*) -qrcnw(mgs) + write(iunit,*) -qhacw(mgs) + write(iunit,*) -qhlacw(mgs) + write(iunit,*) 'pqcwd = ', pqcwd(mgs) + + + write(iunit,*) + write(iunit,*) 'Concentration:' + write(iunit,*) -cautn(mgs) + write(iunit,*) -cracw(mgs) + write(iunit,*) -csacw(mgs) + write(iunit,*) -chacw(mgs) + write(iunit,*) -ciacw(mgs) + write(iunit,*) -cwfrzp(mgs) + write(iunit,*) -cwctfzp(mgs) + write(iunit,*) -cwfrzc(mgs) + write(iunit,*) -cwctfzc(mgs) + write(iunit,*) pccwd(mgs) +! + write(iunit,*) + write(iunit,*) 'Rain ' +! + write(iunit,*) qracw(mgs) + write(iunit,*) qrcnw(mgs) + write(iunit,*) Max(0.0, qrcev(mgs)) + write(iunit,*) -(1-il5(mgs))*qhmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qsmlr(mgs) + write(iunit,*) -(1-il5(mgs))*qimlr(mgs) + write(iunit,*) -qrshr(mgs) + write(iunit,*) 'pqrwi = ', pqrwi(mgs) + write(iunit,*) -qsshr(mgs) + write(iunit,*) -qhshr(mgs) + write(iunit,*) -qhlshr(mgs) + write(iunit,*) -il5(mgs)*qiacr(mgs),qiacr(mgs), qiacrf(mgs) + write(iunit,*) -il5(mgs)*qrfrz(mgs) + write(iunit,*) -qsacr(mgs) + write(iunit,*) -qhacr(mgs) + write(iunit,*) -qhlacr(mgs) + write(iunit,*) qrcev(mgs) + write(iunit,*) 'pqrwd = ', pqrwd(mgs) + write(iunit,*) 'fhw, fhlw = ',fhw(mgs),fhlw(mgs) + write(iunit,*) 'qrzfac = ', qrzfac(mgs) +! + + write(iunit,*) + write(iunit,*) 'Rain concentration' + write(iunit,*) pcrwi(mgs) + write(iunit,*) crcnw(mgs) + write(iunit,*) 1-il5(mgs) + write(iunit,*) -chmlr(mgs),-csmlr(mgs) + write(iunit,*) -crshr(mgs) + write(iunit,*) pcrwd(mgs) + write(iunit,*) il5(mgs) + write(iunit,*) -ciacr(mgs),-crfrz(mgs) + write(iunit,*) -csacr(mgs),-chacr(mgs) + write(iunit,*) +crcev(mgs) + write(iunit,*) cracr(mgs) +! write(iunit,*) -il5(mgs)*ciracr(mgs) + + + write(iunit,*) + write(iunit,*) 'Snow' +! + write(iunit,*) il5(mgs)*qscni(mgs), qscnvi(mgs) + write(iunit,*) il5(mgs)*qsaci(mgs) + write(iunit,*) il5(mgs)*qrfrzs(mgs) + write(iunit,*) il5(mgs)*qiacrs(mgs),il3(mgs)*(qiacrf(mgs)+qracif(mgs)),il3(mgs),qiacrf(mgs),qracif(mgs) + write(iunit,*) il5(mgs)*qsdpv(mgs), qscev(mgs) + write(iunit,*) qsacw(mgs) + write(iunit,*) qsacr(mgs), qscnh(mgs) + write(iunit,*) 'pqswi = ',pqswi(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) -qracs(mgs) + write(iunit,*) -qhacs(mgs) + write(iunit,*) -qhlacs(mgs) + write(iunit,*) (1-il5(mgs))*qsmlr(mgs) + write(iunit,*) qsshr(mgs) +! write(iunit,*) qsshrp(mgs) + write(iunit,*) il5(mgs)*(qssbv(mgs)) + write(iunit,*) 'pqswd = ', pqswd(mgs) +! +! + write(iunit,*) + write(iunit,*) 'Graupel' +! + write(iunit,*) il5(mgs)*qrfrzf(mgs), qrfrzf(mgs) - qrfrz(mgs) + write(iunit,*) il5(mgs)*qiacrf(mgs) + write(iunit,*) il5(mgs)*qracif(mgs) + write(iunit,*) qhcns(mgs) + write(iunit,*) qhcni(mgs) + write(iunit,*) il5(mgs)*(qhdpv(mgs)) + write(iunit,*) qhacr(mgs) + write(iunit,*) qhacw(mgs) + write(iunit,*) qhacs(mgs) + write(iunit,*) qhaci(mgs) + write(iunit,*) 'pqhwi = ',pqhwi(mgs) + write(iunit,*) + write(iunit,*) qhshr(mgs) + write(iunit,*) (1-il5(mgs))*qhmlr(mgs) + write(iunit,*) il5(mgs),qhsbv(mgs) + write(iunit,*) -qhlcnh(mgs) + write(iunit,*) -qhmul1(mgs) + write(iunit,*) 'pqhwd = ', pqhwd(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchwi(mgs),pchwd(mgs) + write(iunit,*) crfrzf(mgs) + write(iunit,*) chcns(mgs) + write(iunit,*) ciacrf(mgs) + +! + write(iunit,*) + write(iunit,*) 'Hail' +! + write(iunit,*) qhlcnh(mgs) + write(iunit,*) il5(mgs)*(qhldpv(mgs)) + write(iunit,*) qhlacr(mgs) + write(iunit,*) qhlacw(mgs) + write(iunit,*) qhlacs(mgs) + write(iunit,*) qhlaci(mgs) + write(iunit,*) pqhli(mgs) + write(iunit,*) + write(iunit,*) qhlshr(mgs) + write(iunit,*) (1-il5(mgs))*qhlmlr(mgs) + write(iunit,*) il5(mgs)*qhlsbv(mgs) + write(iunit,*) pqhld(mgs) + write(iunit,*) 'Concentration' + write(iunit,*) pchli(mgs),pchld(mgs) + write(iunit,*) chlcnh(mgs) +! +! Balance and checks for continuity.....within machine precision... +! +! + write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' + write(iunit,*) 'PTOTAL',ptotal(mgs) +! + end if +! + end do +! + end if ! ( nstep/12*12 .eq. nstep ) + +! +! latent heating from phase changes (except qcw, qci cond, and evap) +! + do mgs = 1,ngscnt + IF ( warmonly < 0.5 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qsfzs(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*(1-imixedphase)*( & + & qsacw(mgs)+qhacw(mgs) + qhlacw(mgs) & + & +qsacr(mgs)+qhacr(mgs) + qhlacr(mgs) & + & +qsshr(mgs) & + & +qhshr(mgs) & + & +qhlshr(mgs) +qrfrz(mgs)+qiacr(mgs) & + & ) & + & +il5(mgs)*(qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs)) + pmlt(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) + psub(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) + pevap(mgs) = & + & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) + pdep(mgs) = & + & il5(mgs)*( & + & + qsdpv(mgs) + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + ELSEIF ( warmonly < 0.8 ) THEN + pfrz(mgs) = & + & (1-il5(mgs))* & + & (qhmlr(mgs)+qhlmlr(mgs)) & !+qhmlh(mgs)) & + & +il5(mgs)*(qhfzh(mgs)+qhlfzhl(mgs)) & + & +il5(mgs)*( & + & +qhshr(mgs) & + & +qhlshr(mgs) & + & +qrfrz(mgs)+qwfrz(mgs) & + & +qwctfz(mgs)+qiihr(mgs) & + & +qiacw(mgs) & + & +qhacw(mgs) + qhlacw(mgs) & + & +qhacr(mgs) + qhlacr(mgs) ) + psub(mgs) = 0.0 + & + & il5(mgs)*( & + & + qhdpv(mgs) & + & + qhldpv(mgs) & + & + qidpv(mgs) + qisbv(mgs) ) & + & +il5(mgs)*(qiint(mgs)) + pvap(mgs) = & + & qrcev(mgs) + qhcev(mgs) + qhlcev(mgs) ! + qscev(mgs) + ELSE + pfrz(mgs) = 0.0 + psub(mgs) = 0.0 + pvap(mgs) = qrcev(mgs) + ENDIF ! warmonly + ptem(mgs) = & + & (1./pi0(mgs))* & + & (felfcp(mgs)*pfrz(mgs) & + & +felscp(mgs)*psub(mgs) & + & +felvcp(mgs)*pvap(mgs)) + thetap(mgs) = thetap(mgs) + dtp*ptem(mgs) + end do + + + + +! +! sum the sources and sinks for qwvp, qcw, qci, qrw, qsw +! +! + do mgs = 1,ngscnt + qwvp(mgs) = qwvp(mgs) + & + & dtp*(pqwvi(mgs)+pqwvd(mgs)) + qx(mgs,lc) = qx(mgs,lc) + & + & dtp*(pqcwi(mgs)+pqcwd(mgs)) +! IF ( qx(mgs,lr) .gt. 10.0e-3 ) THEN +! write(0,*) 'RAIN1a: ',igs(mgs),kgs(mgs),qx(mgs,lr) +! ENDIF + qx(mgs,lr) = qx(mgs,lr) + & + & dtp*(pqrwi(mgs)+pqrwd(mgs)) +! IF ( qx(mgs,lr) .gt. 10.0e-3 ) THEN +! write(0,*) 'RAIN1b: ',igs(mgs),kgs(mgs),qx(mgs,lr) +! write(0,*) pqrwi(mgs),pqrwd(mgs) +! ENDIF + qx(mgs,li) = qx(mgs,li) + & + & dtp*(pqcii(mgs)+pqcid(mgs)) + qx(mgs,ls) = qx(mgs,ls) + & + & dtp*(pqswi(mgs)+pqswd(mgs)) + qx(mgs,lh) = qx(mgs,lh) + & + & dtp*(pqhwi(mgs)+pqhwd(mgs)) + IF ( lhl .gt. 1 ) THEN + qx(mgs,lhl) = qx(mgs,lhl) + & + & dtp*(pqhli(mgs)+pqhld(mgs)) +! IF ( pqhli(mgs) .gt. 1.e-8 ) write(0,*) ' pqhli,qx(lhl) = ',pqhli(mgs),qx(mgs,lhl) + ENDIF + + + end do + +! sum sources for particle volume + + IF ( ldovol ) THEN + + do mgs = 1,ngscnt + + IF ( lvol(ls) .gt. 1 ) THEN + vx(mgs,ls) = vx(mgs,ls) + & + & dtp*(pvswi(mgs)+pvswd(mgs)) + ENDIF + + IF ( lvol(lh) .gt. 1 ) THEN + vx(mgs,lh) = vx(mgs,lh) + & + & dtp*(pvhwi(mgs)+pvhwd(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + + IF ( lhl .gt. 1 ) THEN + IF ( lvol(lhl) .gt. 1 ) THEN + vx(mgs,lhl) = vx(mgs,lhl) + & + & dtp*(pvhli(mgs)+pvhld(mgs)) +! > rho0(mgs)*dtp*(pqhwi(mgs)+pqhwd(mgs))/xdn0(lh) + ENDIF + ENDIF + + ENDDO + + ENDIF ! ldovol + +! +! +! +! concentrations +! + if ( ipconc .ge. 1 ) then + do mgs = 1,ngscnt + cx(mgs,li) = cx(mgs,li) + & + & dtp*(pccii(mgs)+pccid(mgs)) + IF ( ipconc .ge. 2 ) THEN + cx(mgs,lc) = cx(mgs,lc) + & + & dtp*(pccwi(mgs)+pccwd(mgs)) + ENDIF + IF ( ipconc .ge. 3 ) THEN + cx(mgs,lr) = cx(mgs,lr) + & + & dtp*(pcrwi(mgs)+pcrwd(mgs)) + ENDIF + IF ( ipconc .ge. 4 ) THEN + cx(mgs,ls) = cx(mgs,ls) + & + & dtp*(pcswi(mgs)+pcswd(mgs)) + ENDIF + IF ( ipconc .ge. 5 ) THEN + cx(mgs,lh) = cx(mgs,lh) + & + & dtp*(pchwi(mgs)+pchwd(mgs)) + IF ( lhl .gt. 1 ) THEN + cx(mgs,lhl) = cx(mgs,lhl) + & + & dtp*(pchli(mgs)+pchld(mgs)) +! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN +! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) +! ENDIF + ENDIF + ENDIF + end do + end if + + + IF ( wrfchem_flag > 0 ) THEN +! 20130917 acd_mb_washout start + DO mgs = 1,ngscnt + evapprod2d(igs(mgs),kgs(mgs)) = -(qrcev(mgs) + qssbv(mgs) + qhsbv(mgs) + qhlsbv(mgs)) ! - PRE(K) - EVPMS(K) - EVPMG(K) + rainprod2d(igs(mgs),kgs(mgs)) = qrcnw(mgs) + qracw(mgs) + qsacw(mgs) + qhacw(mgs) + qhlacw(mgs) + & + qraci(mgs) + qsaci(mgs) + qhaci(mgs) + qhlaci(mgs) + qscni(mgs) ! PRA(K) + PRC(K) + tqimelt(K) +! evapprod(k) = - PRE(K) - EPRDS(K) - EPRDG(K) +! rainprod(k) = PRA(K) + PRC(K) + PSACWS(K) + PSACWG(K) + PGSACW(K) & +! + PRAI(K) + PRCI(K) + PRACI(K) + PRACIS(K) + & +! + PRDS(K) + PRDG(K) + ENDDO +! 20130917 acd_mb_washout end + ENDIF +! +! +! +! start saturation adjustment +! + if (ndebug .gt. 0 ) write(0,*) 'conc 30a' +! include 'sam.jms.satadj.sgi' +! +! +! +! Modified Straka adjustment (nearly identical to Tao et al. 1989 MWR) +! +! +! +! set up temperature and vapor arrays +! + do mgs = 1,ngscnt + pqs(mgs) = (380.0)/(pres(mgs)) + theta(mgs) = thetap(mgs) + theta0(mgs) + qvap(mgs) = max( (qwvp(mgs) + qv0(mgs)), 0.0 ) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + end do +! +! melting of cloud ice +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptimlw(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + if( temg(mgs) .gt. tfr .and. & + & qitmp(mgs) .gt. 0.0 ) then + qx(mgs,lc) = qx(mgs,lc) + qitmp(mgs) +! pfrz(mgs) = pfrz(mgs) - qitmp(mgs)/dtp + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(- qitmp(mgs)/dtp) + pmlt(mgs) = pmlt(mgs) - qitmp(mgs)/dtp + scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li) + thetap(mgs) = thetap(mgs) - & + & fcc3(mgs)*qitmp(mgs) + ptimlw(mgs) = -fcc3(mgs)*qitmp(mgs)/dtp + cx(mgs,lc) = cx(mgs,lc) + cx(mgs,li) + qx(mgs,li) = 0.0 + cx(mgs,li) = 0.0 + scx(mgs,li) = 0.0 + vx(mgs,li) = 0.0 + qitmp(mgs) = 0.0 + end if + end do +! +! + + +! do mgs = 1,ngscnt +! qimlw(mgs) = (qcwtmp(mgs)-qx(mgs,lc))/dtp +! end do +! +! homogeneous freezing of cloud water +! + IF ( warmonly < 0.8 ) THEN + + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + ptwfzi(mgs) = 0.0 + end do +! + do mgs = 1,ngscnt + +! if( temg(mgs) .lt. tfrh ) THEN +! write(0,*) 'GS: mgs,temp,qc,qi = ',mgs,temg(mgs),temcg(mgs),qx(mgs,lc),qx(mgs,li) +! ENDIF + + ctmp = 0.0 + frac = 0.0 + qtmp = 0.0 + +! if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and. & +! & qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then + if( temg(mgs) .lt. thnuc + 0. .and. & + & qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then + + IF ( ibfc /= 2 .or. ipconc < 2 ) THEN + frac = Max( 0.25, Min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) ) + ELSE + volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 + ! for mean temperature for freezing: -ln (V) = a*Ts - b + ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3 + + cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc)) ! number of droplets with volume greater than volt + + qtmp = cwfrz(mgs)*xdn0(lc)*rhoinv(mgs)*(volt + xv(mgs,lc)) + frac = qtmp/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes + ! sure that cwfrz and qwfrz are consistent and prevents + ! spurious creation of ice crystals. + + ENDIF + qtmp = frac*qx(mgs,lc) + + qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc) + pfrz(mgs) = pfrz(mgs) + qtmp/dtp + ptem(mgs) = ptem(mgs) + & + & (1./pi0(mgs))* & + & felfcp(mgs)*(qtmp/dtp) +! IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qx(mgs,lc)/xdn0(li) + IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li) + + IF ( ipconc .ge. 2 ) THEN + ctmp = frac*cx(mgs,lc) +! cx(mgs,li) = cx(mgs,li) + cx(mgs,lc) + cx(mgs,li) = cx(mgs,li) + ctmp + ELSE ! (ipconc .lt. 2 ) + ctmp = 0.0 + IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN + qtmp = frac*t9(igs(mgs),jgs,kgs(mgs)-1) + +! cx(mgs,lc) = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ctmp = cx(mgs,lc)*qx(mgs,lc)*rho0(mgs)/qtmp + ELSE + cx(mgs,lc) = Max(0.0,wvel(mgs))*dtp*cwccn & + & /gz(igs(mgs),jgs,kgs(mgs)) + cx(mgs,lc) = cwccn + ENDIF + + IF ( ipconc .ge. 1 ) cx(mgs,li) = Min(ccimx, cx(mgs,li) + cx(mgs,lc)) + ENDIF + + sctmp = frac*scx(mgs,lc) +! scx(mgs,li) = scx(mgs,li) + scx(mgs,lc) + scx(mgs,li) = scx(mgs,li) + sctmp +! thetap(mgs) = thetap(mgs) + fcc3(mgs)*qx(mgs,lc) +! ptwfzi(mgs) = fcc3(mgs)*qx(mgs,lc)/dtp +! qx(mgs,lc) = 0.0 +! cx(mgs,lc) = 0.0 +! scx(mgs,lc) = 0.0 + thetap(mgs) = thetap(mgs) + fcc3(mgs)*qtmp + ptwfzi(mgs) = fcc3(mgs)*qtmp/dtp + qx(mgs,lc) = qx(mgs,lc) - qtmp + cx(mgs,lc) = cx(mgs,lc) - ctmp + scx(mgs,lc) = scx(mgs,lc) - sctmp + end if + end do + + ENDIF ! warmonly +! +! do mgs = 1,ngscnt +! qwfzi(mgs) = (qcwtmp(mgs)-qx(mgs,lc))/dtp ! Not used?? (ERM) +! end do +! +! reset temporaries for cloud particles and vapor +! + qcond(:) = 0.0 + + IF ( ipconc .le. 1 .and. lwsm6 ) THEN ! Explicit cloud condensation/evaporation (Rutledge and Hobbs 1983) + DO mgs = 1,ngscnt + + qcwtmp(mgs) = qx(mgs,lc) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) +! temg(mgs) = theta(mgs)*(p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap +! temsav = temg(mgs) +! thsave(mgs) = thetap(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + temcg(mgs) = temg(mgs) - tfr + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + + IF ( ( qvap(mgs) > qvs(mgs) .or. qx(mgs,lc) > qxmin(lc) ) .and. temg(mgs) > tfrh ) THEN + tmp = (qvap(mgs) - qvs(mgs))/(1. + qvs(mgs)*felv(mgs)**2/(cp*rw*temg(mgs)**2) ) + qcond(mgs) = Min( Max( 0.0, tmp ), (qvap(mgs)-qvs(mgs)) ) + IF ( qx(mgs,lc) > qxmin(lc) .and. tmp < 0.0 ) THEN ! evaporation + qcond(mgs) = Max( tmp, -qx(mgs,lc) ) ENDIF + qwvp(mgs) = qwvp(mgs) - qcond(mgs) + qvap(mgs) = qvap(mgs) - qcond(mgs) + qx(mgs,lc) = Max( 0.0, qx(mgs,lc) + qcond(mgs) ) + thetap(mgs) = thetap(mgs) + felvcp(mgs)*qcond(mgs)/(pi0(mgs)) + + ENDIF - ENDIF - - IF ( ipconc .ge. 5 ) THEN ! { + ENDDO + + ENDIF + + + IF ( ipconc .le. 1 .and. .not. lwsm6 ) THEN +! IF ( ipconc .le. 1 ) THEN + + do mgs = 1,ngscnt + qx(mgs,lv) = max( 0.0, qvap(mgs) ) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qx(mgs,li) = max( 0.0, qx(mgs,li) ) + qitmp(mgs) = qx(mgs,li) + end do +! +! + do mgs = 1,ngscnt + qcwtmp(mgs) = qx(mgs,lc) + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temgtmp = temg(mgs) + temg(mgs) = theta(mgs)*(pinit(kgs(mgs)) + p2(igs(mgs),jgs,kgs(mgs)) ) ! *pk(mgs) ! ( pres(mgs) / poo ) ** cap + temsav = temg(mgs) + thsave(mgs) = thetap(mgs) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) +! IF ( ltemq .lt. 1 .or. ltemq .gt. nqsat ) THEN +! C$PAR CRITICAL SECTION +! write(iunit,*) 'out of range ltemq!',temgtmp,temg(mgs), +! : thetap(mgs),theta0(mgs),pres(mgs),theta(mgs), +! : ltemq,igs(mgs),jy,kgs(mgs) +! write(iunit,*) an(igs(mgs),jy,kgs(mgs),lt), +! : ab(igs(mgs),jy,kgs(mgs),lt), +! : t0(igs(mgs),jy,kgs(mgs)) +! write(iunit,*) fcc3(mgs),qx(mgs,lc),qitmp(mgs),dtp,ptem(mgs) +! STOP +! C$PAR END CRITICAL SECTION +! END IF + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) +! qss(kz) = qvs(kz) +! if ( temg(kz) .lt. tfr ) then +! if( qcw(kz) .le. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = qis(kz) +! if( qcw(kz) .gt. qxmin(lc) .and. qci(kz) .gt. qxmin(li)) +! > qss(kz) = (qcw(kz)*qvs(kz) + qci(kz)*qis(kz)) / +! > (qcw(kz) + qci(kz)) +! qss(kz) = qis(kz) +! end if +! dont get enough condensation with qcw .le./.gt. qxmin(lc) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if + end do +! +! iterate adjustment +! + do itertd = 1,2 +! + do mgs = 1,ngscnt +! +! calculate super-saturation +! + qitmp(mgs) = qx(mgs,li) + fcci(mgs) = 0.0 + fcip(mgs) = 0.0 + dqcw(mgs) = 0.0 + dqci(mgs) = 0.0 + dqwv(mgs) = ( qx(mgs,lv) - qss(mgs) ) +! +! evaporation and sublimation adjustment +! + if( dqwv(mgs) .lt. 0. ) then ! subsaturated + if( qx(mgs,lc) .gt. -dqwv(mgs) ) then ! check if qc can make up all of the deficit + dqcw(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all qc available for evap + dqcw(mgs) = -qx(mgs,lc) + dqwv(mgs) = dqwv(mgs) + qx(mgs,lc) + end if +! + if( qitmp(mgs) .gt. -dqwv(mgs) ) then ! check if qi can make up all the deficit + dqci(mgs) = dqwv(mgs) + dqwv(mgs) = 0. + else ! otherwise make all ice available for sublimation + dqci(mgs) = -qitmp(mgs) + dqwv(mgs) = dqwv(mgs) + qitmp(mgs) + end if +! + qwvp(mgs) = qwvp(mgs) - ( dqcw(mgs) + dqci(mgs) ) ! add to perturbation vapor +! +! This next line removed 3/19/2003 thanks to Adam Houston, +! who found the bug in the 3-ICE code +! qwvp(mgs) = max(qwvp(mgs), 0.0) + qitmp(mgs) = qx(mgs,li) + IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 0.0 + ENDIF + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) + qx(mgs,li) = qx(mgs,li) + dqci(mgs) * fcci(mgs) + thetap(mgs) = thetap(mgs) + & + & 1./pi0(mgs)* & + & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) +! +! condensation/deposition +! + IF ( dqwv(mgs) .ge. 0. ) THEN + +! write(iunit,*) 'satadj: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) +! + qitmp(mgs) = qx(mgs,li) + fracl(mgs) = 1.0 + fraci(mgs) = 0.0 + if ( temg(mgs) .lt. tfr .and. temg(mgs) .gt. thnuc ) then + fracl(mgs) = max(min(1.,(temg(mgs)-233.15)/(20.)),0.0) + fraci(mgs) = 1.0-fracl(mgs) + end if + if ( temg(mgs) .le. thnuc ) then + fraci(mgs) = 1.0 + fracl(mgs) = 0.0 + end if + fraci(mgs) = 1.0-fracl(mgs) +! + gamss = (felvcp(mgs)*fracl(mgs) + felscp(mgs)*fraci(mgs)) & + & / (pi0(mgs)) +! + IF ( temg(mgs) .lt. tfr ) then + IF (qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + END IF + IF ( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv2(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbi)**2)) + END IF + IF ( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li) ) then + cdw = caw*pi0(mgs)*tfrcbw/((temg(mgs)-cbw)**2) + cdi = cai*pi0(mgs)*tfrcbi/((temg(mgs)-cbi)**2) + denom1 = qx(mgs,lc) + qitmp(mgs) + denom2 = 1.0 + gamss* & + & (qx(mgs,lc)*qvs(mgs)*cdw + qitmp(mgs)*qis(mgs)*cdi) / denom1 + dqvcnd(mgs) = dqwv(mgs) / denom2 + END IF + + ENDIF ! temg(mgs) .lt. tfr +! + if ( temg(mgs) .ge. tfr ) then + dqvcnd(mgs) = dqwv(mgs)/(1. + fcqv1(mgs)*qss(mgs)/ & + & ((temg(mgs)-cbw)**2)) + end if +! + delqci1=qx(mgs,li) +! + IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + fcci(mgs) = qx(mgs,li)/(qitmp(mgs)) + ELSE + fcci(mgs) = 0.0 + ENDIF +! + dqcw(mgs) = dqvcnd(mgs)*fracl(mgs) + dqci(mgs) = dqvcnd(mgs)*fraci(mgs) +! + thetap(mgs) = thetap(mgs) + & + & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & + & / (pi0(mgs)) + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) + qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) + IF ( qitmp(mgs) .gt. qxmin(li) ) THEN + qx(mgs,li) = qx(mgs,li) + dqci(mgs)*fcci(mgs) + qitmp(mgs) = qx(mgs,li) + ENDIF +! +! delqci(mgs) = dqci(mgs)*fcci(mgs) +! + END IF ! dqwv(mgs) .ge. 0. + end do +! + do mgs = 1,ngscnt + qitmp(mgs) = qx(mgs,li) + theta(mgs) = thetap(mgs) + theta0(mgs) + temg(mgs) = theta(mgs)*pk(mgs) ! ( pres(mgs) / poo ) ** cap + qvap(mgs) = Max((qwvp(mgs) + qv0(mgs)), 0.0) + temcg(mgs) = temg(mgs) - tfr + tqvcon = temg(mgs)-cbw + ltemq = (temg(mgs)-163.15)/fqsat+1.5 + ltemq = Min( nqsat, Max(1,ltemq) ) + qvs(mgs) = pqs(mgs)*tabqvs(ltemq) + qis(mgs) = pqs(mgs)*tabqis(ltemq) + qx(mgs,lc) = max( 0.0, qx(mgs,lc) ) + qitmp(mgs) = max( 0.0, qitmp(mgs) ) + qx(mgs,lv) = max( 0.0, qvap(mgs)) +! if ( temg(mgs) .lt. tfr ) then +! if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) +! > qss(mgs) = qvs(mgs) +!c if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .eq. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = qis(mgs) +!c if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) +! if( qx(mgs,lc) .gt. 0.0 .and. qitmp(mgs) .gt. qxmin(li)) +! > qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / +! > (qx(mgs,lc) + qitmp(mgs)) +! else +! qss(mgs) = qvs(mgs) +! end if + qss(mgs) = qvs(mgs) + if ( temg(mgs) .lt. tfr ) then + if( qx(mgs,lc) .ge. 0.0 .and. qitmp(mgs) .le. qxmin(li) ) & + & qss(mgs) = qvs(mgs) + if( qx(mgs,lc) .le. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = qis(mgs) + if( qx(mgs,lc) .gt. qxmin(lc) .and. qitmp(mgs) .gt. qxmin(li)) & + & qss(mgs) = (qx(mgs,lc)*qvs(mgs) + qitmp(mgs)*qis(mgs)) / & + & (qx(mgs,lc) + qitmp(mgs)) + end if +! pceds(mgs) = (thetap(mgs) - thsave(mgs))/dtp +! write(iunit,*) 'satadj2: mgs,iter = ',mgs,itertd,dqwv(mgs),qss(mgs),qx(mgs,lv),qx(mgs,lc) + end do +! +! end the saturation adjustment iteration loop +! + end do - xvs = db(ix,jy,kz)*an(ix,jy,kz,ls)/ & - & (swdn*Max(1.0e-3,an(ix,jy,kz,lns))) - IF ( xvs .lt. xvsmn .or. xvs .gt. xvsmx ) THEN - xvs = Min( xvsmx, Max( xvsmn,xvs ) ) - csw = db(ix,jy,kz)*an(ix,jy,kz,ls)/(xvs*swdn) - ENDIF + ENDIF ! ( ipconc .le. 1 ) - swdia = (xvs*cwc0)**(1./3.) - xcnos = an(ix,jy,kz,ls)*db(ix,jy,kz)/(xvs*swdn*swdia) - - ENDIF ! } - ENDIF ! } +! +! spread the growth owing to vapor diffusion onto the +! ice crystal categories using the +! +! END OF SATURATION ADJUSTMENT +! -! IF ( an(ix,jy,kz,lnh) .lt. 0.1 ) THEN -! hwdia = (xvrmn*cwc0)**(1./3.) -! xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvrmn*hwdn*hwdia) -! ELSE -! ! changed back to diameter of mean volume!!! -! hwdia = -! > (an(ix,jy,kz,lh)*db(ix,jy,kz) -! > /(pi*hwdn*an(ix,jy,kz,lnh)))**(1./3.) -! -! xcnoh = an(ix,jy,kz,lnh)/hwdia -! ENDIF + if (ndebug .gt. 0 ) write(0,*) 'conc 30b' +! +! +! end of saturation adjustment +! +! +! !DIR$ IVDEP + do mgs = 1,ngscnt + t0(igs(mgs),jy,kgs(mgs)) = temg(mgs) + end do +! +! Load the save arrays +! - IF ( lh .gt. 1 ) THEN ! { - IF ( lvh .gt. 1 ) THEN - IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN - hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) - hwdn = Min( 900., Max( 170., hwdn ) ) - ELSE - hwdn = 500. ! hwdn1t - ENDIF - ELSE - hwdn = hwdn1t - ENDIF - - IF ( ipconc .ge. 5 ) THEN ! { + if (ndebug .gt. 0 ) write(0,*) 'gs 11' - xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/ & - & (hwdn*Max(1.0e-3,an(ix,jy,kz,lnh))) - IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN - xvh = Min( xvhmx, Max( xvhmn,xvh ) ) - chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) + do mgs = 1,ngscnt +! + an(igs(mgs),jy,kgs(mgs),lt) = & + & theta0(mgs) + thetap(mgs) + an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) + qv0(mgs) ! +! + + DO il = lc,lhab + IF ( ido(il) .eq. 1 ) THEN + an(igs(mgs),jy,kgs(mgs),il) = qx(mgs,il) + & + & min( an(igs(mgs),jy,kgs(mgs),il), 0.0 ) + qx(mgs,il) = an(igs(mgs),jy,kgs(mgs),il) ENDIF + ENDDO - hwdia = (xvh*cwc0)**(1./3.) - xcnoh = an(ix,jy,kz,lh)*db(ix,jy,kz)/(xvh*hwdn*hwdia) - - ENDIF ! } ipconc .ge. 5 - - ENDIF ! } - dadh = 0.0 - dadhl = 0.0 - dads = 0.0 - IF ( xcnoh .gt. 0.0 ) THEN - dadh = ( db(ix,jy,kz) /(pi*hwdn*xcnoh) )**(.25) - zhdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnoh ! dielf_h*cr1*xcnoh ! SV - equiv formula as before but - ! ratio of densities included in - ! dielf_h rather than here following - ! Battan. - ELSE - dadh = 0.0 - zhdryc = 0.0 - ENDIF - - IF ( xcnos .gt. 0.0 ) THEN - dads = ( db(ix,jy,kz) /(pi*swdn*xcnos) )**(.25) - zsdryc = 0.224*cr2*(db(ix,jy,kz)/rwdn)**2/xcnos ! dielf_sn*cr1*xcnos ! SV - similar change as above - ELSE - dads = 0.0 - zsdryc = 0.0 - ENDIF - zhwetc = zhdryc ! cr1*xcnoh !Hail/graupel version with .95 power bug removed - zswetc = zsdryc ! cr1*xcnos -! -! snow contribution ! - IF ( ls .gt. 1 ) THEN - - gtmp(ix,kz) = 0.0 - qxw = 0.0 - dtmps = 0.0 - IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN !{ - IF ( ipconc .ge. 4 ) THEN ! (Ferrier 94) !{ - - if (lsw .gt. 1) qxw = an(ix,jy,kz,lsw) - - vr = xvs ! db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) -! gtmp(ix,kz) = 3.6e18*(0.243*rhos**2/0.93)*(snu+2.)*an(ix,jy,kz,lns)*vr**2/(snu+1.) - - IF ( an(ix,jy,kz,lns) .gt. 1.e-5 ) THEN - gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & - & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2) - ENDIF - - tmp = Min(1.0,1.e3*(an(ix,jy,kz,ls))*db(ix,jy,kz)) - gtmp(ix,kz) = Max( 1.0*gtmp(ix,kz), 750.0*(tmp)**1.98) - dtmps = gtmp(ix,kz) - dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz) - ELSE - gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25) - - IF ( gtmp(ix,kz) .gt. 0.0 ) THEN !{ - dtmps = zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) - IF ( temk(ix,jy,kz) .lt. tfr ) THEN - dtmp(ix,kz) = dtmp(ix,kz) + & - & zsdryc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) - ELSE - dtmp(ix,kz) = dtmp(ix,kz) + & - & zswetc*an(ix,jy,kz,ls)**2/gtmp(ix,kz) - ENDIF - ENDIF !} - ENDIF !} - - ENDIF !} - - ENDIF + end do +! + if ( ipconc .ge. 1 ) then + DO il = lc,lhab !{ -! -! ice crystal contribution (Heymsfield, 1977, JAS) -! - IF ( li .gt. 1 .and. idbzci .ne. 0 ) THEN - - gtmp(ix,kz) = 0.0 - IF ( an(ix,jy,kz,li) .ge. 0.1e-3 ) THEN - gtmp(ix,kz) = Min(1.0,1.e3*(an(ix,jy,kz,li))*db(ix,jy,kz)) - dtmp(ix,kz) = dtmp(ix,kz) + 750.0*(gtmp(ix,kz))**1.98 - ENDIF - - ENDIF - -! -! graupel/hail contribution -! - IF ( lh .gt. 1 ) THEN ! { - gtmp(ix,kz) = 0.0 - dtmph = 0.0 - qxw = 0.0 +! write(0,*) 'limiter loop: il,ipc,lz: ',il,ipc(il),lz(il),ipconc - IF ( izieg .ge. 1 .and. ipconc .ge. 5 ) THEN + IF ( ipconc .ge. ipc(il) ) THEN ! { - ltest = .false. - - IF ( ltest .or. (an(ix,jy,kz,lh) .ge. qhmin .and. an(ix,jy,kz,lnh) .gt. 1.e-6 )) THEN - - IF ( lvh .gt. 1 ) THEN - - IF ( an(ix,jy,kz,lvh) .gt. 0.0 ) THEN - hwdn = db(ix,jy,kz)*an(ix,jy,kz,lh)/an(ix,jy,kz,lvh) - hwdn = Min( 900., Max( 100., hwdn ) ) - ELSE - hwdn = 500. ! hwdn1t - ENDIF + IF ( ipconc .ge. 4 .and. ipc(il) .ge. 1 ) THEN ! { - ENDIF +! write(0,*) 'MY limiter: il,ipc,lz: ',il,ipc(il),lz(il),lr,lzr +! STOP - chw = an(ix,jy,kz,lnh) - IF ( chw .gt. 0.0 ) THEN ! (Ferrier 94) - xvh = db(ix,jy,kz)*an(ix,jy,kz,lh)/(hwdn*Max(1.0e-3,chw)) - IF ( xvh .lt. xvhmn .or. xvh .gt. xvhmx ) THEN - xvh = Min( xvhmx, Max( xvhmn,xvh ) ) - chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) - ENDIF - - IF ( lhw .gt. 1 ) THEN - IF ( iusewetgraupel .eq. 1 ) THEN - qxw = an(ix,jy,kz,lhw) - ELSEIF ( iusewetgraupel .eq. 2 ) THEN - IF ( hwdn .lt. 300. ) THEN - qxw = an(ix,jy,kz,lhw) - ENDIF - ENDIF - ENDIF - - IF ( lzh .gt. 1 ) THEN - ELSE - g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) -! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw -! ze = 0.224*1.e18*zx*(6./(pi*1000.))**2 - zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lh) + 0.776*qxw)*an(ix,jy,kz,lh)/chw - ze =1.e18*zx*(6./(pi*1000.))**2 - dtmp(ix,kz) = dtmp(ix,kz) + ze - dtmph = ze - ENDIF - - ENDIF - - ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze - ENDIF - - ELSE - - dtmph = 0.0 + IF ( lz(il) <= 1 .or. ioldlimiter == 1 ) THEN ! { { is a two-moment category so dont worry about reflectivity - IF ( an(ix,jy,kz,lh) .ge. qhmin ) THEN - gtmp(ix,kz) = dadh*an(ix,jy,kz,lh)**(0.25) - IF ( gtmp(ix,kz) .gt. 0.0 ) THEN - dtmph = zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) - IF ( temk(ix,jy,kz) .lt. tfr ) THEN - dtmp(ix,kz) = dtmp(ix,kz) + & - & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) - ELSE -! IF ( hwdn .gt. 700.0 ) THEN - dtmp(ix,kz) = dtmp(ix,kz) + & - & zhdryc*an(ix,jy,kz,lh)**2/gtmp(ix,kz) -! -! & (zhwetc*gtmp(ix,kz)**7)**0.95 -! ELSE -! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 -! ENDIF - ENDIF - ENDIF - ENDIF + + DO mgs = 1,ngscnt + IF ( qx(mgs,il) .le. 0.0 ) THEN + cx(mgs,il) = 0.0 + ELSE !{ + IF ( cx(mgs,il) .gt. cxmin ) THEN !{ +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(1.0e-9,cx(mgs,il))) +! xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*Max(cxmin,cx(mgs,il))) + xv(mgs,il) = rho0(mgs)*qx(mgs,il)/(xdn(mgs,il)*cx(mgs,il)) + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,qx,xdn,ln = ',xv(mgs,il),cx(mgs,il),qx(mgs,il),xdn(mgs,il),ln(il) +! ENDIF + + IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvmx(il) ) THEN + xv(mgs,il) = Min( xvmx(il), xv(mgs,il) ) + xv(mgs,il) = Max( xvmn(il), xv(mgs,il) ) + cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il)) + ENDIF + + ENDIF !} + +! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN +! write(0,*) 'dr: xv,cx,= ',xv(mgs,il),cx(mgs,il) +! ENDIF + + ENDIF !} + ENDDO ! mgs - - ENDIF - - + ENDIF ! }} ENDIF ! } - - ENDIF ! na .gt. 5 - - IF ( izieg .ge. 1 .and. lhl .gt. 1 ) THEN + DO mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),ln(il)) = Max(cx(mgs,il), 0.0) + ENDDO + ENDIF ! } + ENDDO ! il } - hldn = 900.0 - gtmp(ix,kz) = 0.0 - dtmphl = 0.0 - qxw = 0.0 - + IF ( lcin > 1 ) THEN + do mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lcin) = Max(0.0, ccin(mgs)) + end do + ENDIF - IF ( lvhl .gt. 1 ) THEN - IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN - hldn = db(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) - hldn = Min( 900., Max( 300., hldn ) ) - ELSE - hldn = 900. - ENDIF - ELSE - hldn = rho_qhl - ENDIF + IF ( ipconc .ge. 2 ) THEN + do mgs = 1,ngscnt + IF ( lccn > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + ENDIF + end do + ENDIF + + ELSEIF ( ipconc .eq. 0 .and. lni .gt. 1 ) THEN + + DO mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lni) = Max(cx(mgs,li), 0.0) + ENDDO - IF ( ipconc .ge. 5 ) THEN + end if - ltest = .false. + IF ( ldovol ) THEN - IF ( ltest .or. ( an(ix,jy,kz,lhl) .ge. qhlmin .and. an(ix,jy,kz,lnhl) .gt. 0.) ) THEN !{ - chl = an(ix,jy,kz,lnhl) - IF ( chl .gt. 0.0 ) THEN !{ - xvhl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/ & - & (hldn*Max(1.0e-9,an(ix,jy,kz,lnhl))) - IF ( xvhl .lt. xvhlmn .or. xvhl .gt. xvhlmx ) THEN ! { - xvhl = Min( xvhlmx, Max( xvhlmn,xvhl ) ) - chl = db(ix,jy,kz)*an(ix,jy,kz,lhl)/(xvhl*hldn) - an(ix,jy,kz,lnhl) = chl - ENDIF ! } + DO il = li,lhab - IF ( lhlw .gt. 1 ) THEN - IF ( iusewethail .eq. 1 ) THEN - qxw = an(ix,jy,kz,lhlw) - ELSEIF ( iusewethail .eq. 2 ) THEN - IF ( hldn .lt. 300. ) THEN - qxw = an(ix,jy,kz,lhlw) - ENDIF - ENDIF - ENDIF - - IF ( lzhl .gt. 1 ) THEN !{ - ELSE !} + IF ( lvol(il) .ge. 1 ) THEN - g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) - zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lhl) + 0.776*qxw)*an(ix,jy,kz,lhl)/chl -! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lhl))**2/chl - ze = 0.224*1.e18*zx*(6./(pi*1000.))**2 - dtmp(ix,kz) = dtmp(ix,kz) + ze - dtmphl = ze - - ENDIF !} - ENDIF!} - ! IF ( an(ix,jy,kz,lh) .gt. 1.0e-3 ) write(0,*) 'Graupel Z : ',dtmph,ze - ENDIF + DO mgs = 1,ngscnt + an(igs(mgs),jy,kgs(mgs),lvol(il)) = Max( 0.0, vx(mgs,il) ) + ENDDO - ELSE - - - IF ( an(ix,jy,kz,lhl) .ge. qhlmin ) THEN ! { - dadhl = ( db(ix,jy,kz) /(pi*hldn*cnohl) )**(.25) - gtmp(ix,kz) = dadhl*an(ix,jy,kz,lhl)**(0.25) - IF ( gtmp(ix,kz) .gt. 0.0 ) THEN ! { + ENDIF + + ENDDO + + ENDIF +! +! +! +! +! + if (ndebug .gt. 0 ) write(0,*) 'gs 12' - zhldryc = 0.224*cr2*( db(ix,jy,kz)/rwdn)**2/cnohl - dtmphl = zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) - IF ( temk(ix,jy,kz) .lt. tfr ) THEN - dtmp(ix,kz) = dtmp(ix,kz) + & - & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) - ELSE -! IF ( hwdn .gt. 700.0 ) THEN - dtmp(ix,kz) = dtmp(ix,kz) + & - & zhldryc*an(ix,jy,kz,lhl)**2/gtmp(ix,kz) -! -! : (zhwetc*gtmp(ix,kz)**7)**0.95 -! ELSE -! dtmp(ix,kz) = dtmp(ix,kz) + zhwetc*gtmp(ix,kz)**7 -! ENDIF - ENDIF - ENDIF ! } - - ENDIF ! } - - ENDIF ! ipconc .ge. 5 + if (ndebug .gt. 0 ) write(0,*) 'gs 13' + 9998 continue - ENDIF ! izieg .ge. 1 .and. lhl .gt. 1 + if ( kz .gt. nz-1 .and. ix .ge. itile) then + if ( ix .ge. itile ) then + go to 1200 ! exit gather scatter + else + nzmpb = kz + endif + else + nzmpb = kz + end if - - - IF ( dtmp(ix,kz) .gt. 0.0 ) THEN - dbz(ix,jy,kz) = Max(dbzmin, 10.0*Log10(dtmp(ix,kz)) ) - - IF ( dbz(ix,jy,kz) .gt. dbzmax ) THEN - dbzmax = Max(dbzmax,dbz(ix,jy,kz)) - imx = ix - jmx = jy - kmx = kz - ENDIF - ELSE - dbz(ix,jy,kz) = dbzmin - IF ( lh > 1 .and. lhl > 1) THEN - IF ( an(ix,jy,kz,lh) > 1.0e-3 ) THEN - write(0,*) 'radardbz: qr,qh,qhl = ',an(ix,jy,kz,lr), an(ix,jy,kz,lh),an(ix,jy,kz,lhl) - write(0,*) 'radardbz: dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl - - IF ( lzh>1 .and. lzhl>1 ) write(0,*) 'radardbz: zh, zhl = ',an(ix,jy,kz,lzh),an(ix,jy,kz,lzhl) - ENDIF - ENDIF - ENDIF + if ( ix .ge. itile ) then + nxmpb = 1 + nzmpb = kz+1 + else + nxmpb = ix+1 + end if -! IF ( an(ix,jy,kz,lh) .gt. 1.e-4 .and. -! & dbz(ix,jy,kz) .le. 0.0 ) THEN -! write(0,*) 'dbz = ',dbz(ix,jy,kz) -! write(0,*) 'Hail intercept: ',xcnoh,ix,kz -! write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) -! write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) -! write(0,*) 'dtmps,dtmph = ',dtmps,dtmph -! ENDIF - IF ( .not. dtmp(ix,kz) .lt. 1.e30 .or. dbz(ix,jy,kz) > 190.0 ) THEN -! IF ( ix == 31 .and. kz == 20 .and. jy == 23 ) THEN -! write(0,*) 'my_rank = ',my_rank - write(0,*) 'ix,jy,kz = ',ix,jy,kz - write(0,*) 'dbz = ',dbz(ix,jy,kz) - write(0,*) 'db, zhdryc = ',db(ix,jy,kz),zhdryc - write(0,*) 'Hail intercept: ',xcnoh,ix,kz - write(0,*) 'Hail,snow q: ',an(ix,jy,kz,lh),an(ix,jy,kz,ls) - write(0,*) 'graupel density hwdn = ',hwdn - write(0,*) 'rain q: ',an(ix,jy,kz,lr) - write(0,*) 'ice q: ',an(ix,jy,kz,li) - IF ( lhl .gt. 1 ) write(0,*) 'Hail (lhl): ',an(ix,jy,kz,lhl) - IF (ipconc .ge. 3 ) write(0,*) 'rain c: ',an(ix,jy,kz,lnr) - IF ( lzr > 1 ) write(0,*) 'rain Z: ',an(ix,jy,kz,lzr) - IF ( ipconc .ge. 5 ) THEN - write(0,*) 'Hail,snow c: ',an(ix,jy,kz,lnh),an(ix,jy,kz,lns) - IF ( lhl .gt. 1 ) write(0,*) 'Hail (lnhl): ',an(ix,jy,kz,lnhl) - IF ( lzhl .gt. 1 ) THEN - write(0,*) 'Hail (lzhl): ',an(ix,jy,kz,lzhl) - write(0,*) 'chl,xvhl,dhl = ',chl,xvhl,(xvhl*6./3.14159)**(1./3.) - write(0,*) 'xvhlmn,xvhlmx = ',xvhlmn,xvhlmx - ENDIF - ENDIF - write(0,*) 'chw,xvh = ', chw,xvh - write(0,*) 'dtmps,dtmph,dadh,dadhl,dtmphl = ',dtmps,dtmph,dadh,dadhl,dtmphl - write(0,*) 'dtmpr = ',dtmpr - write(0,*) 'gtmp = ',gtmp(ix,kz),dtmp(ix,kz) - IF ( .not. (dbz(ix,jy,kz) .gt. -100 .and. dbz(ix,jy,kz) .lt. 200 ) ) THEN - write(0,*) 'dbz out of bounds! STOP!' -! STOP - ENDIF - ENDIF + 1000 continue + 1200 continue +! +! end of gather scatter (for this jy slice) +! +! - - ENDDO ! ix - ENDDO ! kz - ENDDO ! jy - - - - -! write(0,*) 'na,lr = ',na,lr - IF ( printyn .eq. 1 ) THEN -! IF ( dbzmax .gt. dbzmin ) THEN - write(iunit,*) 'maxdbz,ijk = ',dbzmax,imx,jmx,kmx - write(iunit,*) 'qrw = ',an(imx,jmx,kmx,lr) - - IF ( lh .gt. 1 ) THEN - write(iunit,*) 'qi = ',an(imx,jmx,kmx,li) - write(iunit,*) 'qsw = ',an(imx,jmx,kmx,ls) - write(iunit,*) 'qhw = ',an(imx,jmx,kmx,lh) - IF ( lhl .gt. 1 ) write(iunit,*) 'qhl = ',an(imx,jmx,kmx,lhl) - ENDIF + return + end subroutine nssl_2mom_gs +! +!-------------------------------------------------------------------------- +! - - ENDIF - - - RETURN - END subroutine radardd02 - -! ############################################################################## -! ############################################################################## + +! +!-------------------------------------------------------------------------- +! END MODULE module_mp_nssl_2mom diff --git a/wrfv2_fire/phys/module_mp_thompson.F b/wrfv2_fire/phys/module_mp_thompson.F index 648db6ba..4b816fb1 100644 --- a/wrfv2_fire/phys/module_mp_thompson.F +++ b/wrfv2_fire/phys/module_mp_thompson.F @@ -14,7 +14,7 @@ !.. Beginning with WRFv3.6, this is also the "aerosol-aware" scheme as !.. described in Thompson, G. and T. Eidhammer, 2014: A study of !.. aerosol impacts on clouds and precipitation development in a large -!.. winter cyclone. J. Atmos. Sci., 1??, ????-????. Setting WRF +!.. winter cyclone. J. Atmos. Sci., 71, 3636-3658. Setting WRF !.. namelist option mp_physics=8 utilizes the older one-moment cloud !.. water with constant droplet concentration set as Nt_c (found below) !.. while mp_physics=28 uses double-moment cloud droplet number @@ -36,7 +36,8 @@ !.. Remaining values should probably be left alone. !.. !..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 -!..Last modified: 19 Mar 2014 Aerosol additions to v3.5.1 code 9/2013 +!..Last modified: 11 Feb 2015 Aerosol additions to v3.5.1 code 9/2013 +!.. Cloud fraction additions 11/2014 part of pre-v3.7 !+---+-----------------------------------------------------------------+ !wrft:model_layer:physics !+---+-----------------------------------------------------------------+ @@ -45,6 +46,9 @@ MODULE module_mp_thompson USE module_wrf_error USE module_mp_radar +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + USE module_dm, ONLY : wrf_dm_max_real +#endif IMPLICIT NONE @@ -87,7 +91,6 @@ MODULE module_mp_thompson REAL, PARAMETER, PRIVATE:: mu_g = 0.0 REAL, PARAMETER, PRIVATE:: mu_i = 0.0 REAL, PRIVATE:: mu_c - INTEGER, PRIVATE:: nu_c !..Sum of two gamma distrib for snow (Field et al. 2005). !.. N(D) = M2**4/M3**3 * [Kap0*exp(-M2*Lam0*D/M3) @@ -379,8 +382,6 @@ MODULE module_mp_thompson REAL:: t1_qs_sd, t2_qs_sd, t1_qg_sd, t2_qg_sd REAL:: t1_qs_me, t2_qs_me, t1_qg_me, t2_qg_me - CHARACTER*256:: mp_debug - !+---+ !+---+-----------------------------------------------------------------+ !..END DECLARATIONS @@ -409,9 +410,11 @@ SUBROUTINE thompson_init(hgt, nwfa2d, nwfa, nifa, dx, dy, & REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL, INTENT(INOUT) :: nwfa2d REAL, OPTIONAL, INTENT(IN) :: DX, DY LOGICAL, OPTIONAL, INTENT(IN) :: is_start + CHARACTER*256:: mp_debug + INTEGER:: i, j, k, l, m, n - REAL:: h_01, niIN3, niCCN3 + REAL:: h_01, niIN3, niCCN3, max_test LOGICAL:: micro_init, has_CCN, has_IN is_aerosol_aware = .FALSE. @@ -433,7 +436,13 @@ SUBROUTINE thompson_init(hgt, nwfa2d, nwfa, nifa, dx, dy, & !..Check for existing aerosol data, both CCN and IN aerosols. If missing !.. fill in just a basic vertical profile, somewhat boundary-layer following. - if (SUM(nwfa(its,:,jts)) .lt. eps) then +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + max_test = wrf_dm_max_real ( MAXVAL(nwfa(its:ite-1,:,jts:jte-1)) ) +#else + max_test = MAXVAL ( nwfa(its:ite-1,:,jts:jte-1) ) +#endif + + if (max_test .lt. eps) then write(mp_debug,*) ' Apparently there are no initial CCN aerosols.' CALL wrf_debug(100, mp_debug) write(mp_debug,*) ' checked column at point (i,j) = ', its,jts @@ -462,7 +471,14 @@ SUBROUTINE thompson_init(hgt, nwfa2d, nwfa, nifa, dx, dy, & CALL wrf_debug(100, mp_debug) endif - if (SUM(nifa(its,:,jts)) .lt. eps) then + +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + max_test = wrf_dm_max_real ( MAXVAL(nifa(its:ite-1,:,jts:jte-1)) ) +#else + max_test = MAXVAL ( nifa(its:ite-1,:,jts:jte-1) ) +#endif + + if (max_test .lt. eps) then write(mp_debug,*) ' Apparently there are no initial IN aerosols.' CALL wrf_debug(100, mp_debug) write(mp_debug,*) ' checked column at point (i,j) = ', its,jts @@ -523,9 +539,9 @@ SUBROUTINE thompson_init(hgt, nwfa2d, nwfa, nifa, dx, dy, & nwfa2d(i,j) = nwfa2d(i,j)*h_01 * 1.E6 enddo enddo - else - write(mp_debug,*) ' sample (lower-left) aerosol surface flux emission rate: ', nwfa2d(1,1) - CALL wrf_debug(100, mp_debug) +! else +! write(mp_debug,*) ' sample (lower-left) aerosol surface flux emission rate: ', nwfa2d(1,1) +! CALL wrf_debug(100, mp_debug) endif endif @@ -994,7 +1010,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & RAINNC, RAINNCV, & SNOWNC, SNOWNCV, & GRAUPELNC, GRAUPELNCV, SR, & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) rainprod, evapprod, & #endif refl_10cm, diagflag, do_radar_ref, & @@ -1018,7 +1034,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & re_cloud, re_ice, re_snow INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & rainprod, evapprod #endif @@ -1039,7 +1055,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nr1d, nc1d, nwfa1d, nifa1d, & t1d, p1d, w1d, dz1d, dBZ REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte):: & rainprod1d, evapprod1d #endif @@ -1054,6 +1070,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & INTEGER:: i_start, j_start, i_end, j_end LOGICAL, OPTIONAL, INTENT(IN) :: diagflag INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref + CHARACTER*256:: mp_debug !+---+ @@ -1160,7 +1177,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & call mp_thompson(qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dz1d, & pptrain, pptsnow, pptgraul, pptice, & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) rainprod1d, evapprod1d, & #endif kts, kte, dt, i, j) @@ -1207,7 +1224,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & ni(i,k,j) = ni1d(k) nr(i,k,j) = nr1d(k) th(i,k,j) = t1d(k)/pii(i,k,j) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) rainprod(i,k,j) = rainprod1d(k) evapprod(i,k,j) = evapprod1d(k) #endif @@ -1309,14 +1326,14 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & do k = kts, kte re_qc1d(k) = 2.51E-6 re_qi1d(k) = 10.01E-6 - re_qs1d(k) = 25.E-6 + re_qs1d(k) = 10.01E-6 enddo call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & re_qc1d, re_qi1d, re_qs1d, kts, kte) do k = kts, kte - re_cloud(i,k,j) = MAX(2.51E-6, MIN(re_qc1d(k), 50.E-6)) + re_cloud(i,k,j) = MAX( 2.51E-6, MIN(re_qc1d(k), 50.E-6)) re_ice(i,k,j) = MAX(10.01E-6, MIN(re_qi1d(k), 125.E-6)) - re_snow(i,k,j) = MAX(25.E-6, MIN(re_qs1d(k), 999.E-6)) + re_snow(i,k,j) = MAX(10.01E-6, MIN(re_qs1d(k), 999.E-6)) enddo ENDIF @@ -1355,7 +1372,7 @@ END SUBROUTINE mp_gt_driver subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, t1d, p1d, w1d, dzq, & pptrain, pptsnow, pptgraul, pptice, & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) rainprod, evapprod, & #endif kts, kte, dt, ii, jj) @@ -1370,7 +1387,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & REAL, DIMENSION(kts:kte), INTENT(IN):: p1d, w1d, dzq REAL, INTENT(INOUT):: pptrain, pptsnow, pptgraul, pptice REAL, INTENT(IN):: dt -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte), INTENT(INOUT):: & rainprod, evapprod #endif @@ -1458,6 +1475,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & LOGICAL:: melti, no_micro LOGICAL, DIMENSION(kts:kte):: L_qc, L_qi, L_qr, L_qs, L_qg LOGICAL:: debug_flag + CHARACTER*256:: mp_debug + INTEGER:: nu_c !+---+ @@ -1571,7 +1590,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pnd_scd(k) = 0. pnd_gcd(k) = 0. enddo -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) do k = kts, kte rainprod(k) = 0. evapprod(k) = 0. @@ -2196,6 +2215,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & prr_rcg(k) = tcg_racg(idx_g1,idx_g,idx_r1,idx_r) prr_rcg(k) = MIN(DBLE(rg(k)*odts), prr_rcg(k)) prg_rcg(k) = -prr_rcg(k) +!..Put in explicit drop break-up due to collisions. + pnr_rcg(k) = -5.*tnr_gacr(idx_g1,idx_g,idx_r1,idx_r) ! RAIN2M endif endif endif @@ -2285,9 +2306,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & !..Freezing of aqueous aerosols based on Koop et al (2001, Nature) xni = smo0(k)+ni(k) + (pni_rfz(k)+pni_wfz(k)+pni_inu(k))*dtsave - if (is_aerosol_aware .AND. homogIce .AND. (xni.le.100.) & - & .AND. (pni_inu(k).lt.eps) .AND. (temp(k).lt.238) & - & .AND. (ssati(k).ge.0.4) ) then + if (is_aerosol_aware .AND. homogIce .AND. (xni.le.500.E3) & + & .AND.(temp(k).lt.238).AND.(ssati(k).ge.0.4) ) then xnc = iceKoop(temp(k),qv(k),qvs(k),nwfa(k), dtsave) pni_iha(k) = xnc*odts pri_iha(k) = MIN(DBLE(rate_max), xm0i*0.1*pni_iha(k)) @@ -2948,7 +2968,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & pnc_wcd(k) = 0.5*(xnc-nc(k) + abs(xnc-nc(k)))*odts*orho !+---+-----------------------------------------------------------------+ ! EVAPORATION - elseif (clap .lt. -eps .AND. is_aerosol_aware) then + elseif (clap .lt. -eps .AND. ssatw(k).lt.-1.E-6 .AND. is_aerosol_aware) then tempc = temp(k) - 273.15 otemp = 1./temp(k) rvs = rho(k)*qvs(k) @@ -3099,7 +3119,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & rho(k) = 0.622*pres(k)/(R*temp(k)*(qv(k)+0.622)) endif enddo -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) do k = kts, kte evapprod(k) = prv_rev(k) - (min(zeroD0,prs_sde(k)) + & min(zeroD0,prg_gde(k))) @@ -3533,30 +3553,85 @@ subroutine qr_acr_qg DOUBLE PRECISION, DIMENSION(nbr):: vr, N_r DOUBLE PRECISION:: N0_r, N0_g, lam_exp, lamg, lamr DOUBLE PRECISION:: massg, massr, dvg, dvr, t1, t2, z1, z2, y1, y2 + LOGICAL force_read_thompson, write_thompson_tables + LOGICAL lexist,lopen + INTEGER good + LOGICAL, EXTERNAL :: wrf_dm_on_monitor !+---+ - do n2 = 1, nbr + CALL nl_get_force_read_thompson(1,force_read_thompson) + CALL nl_get_write_thompson_tables(1,write_thompson_tables) + + good = 0 + IF ( wrf_dm_on_monitor() ) THEN + INQUIRE(FILE="qr_acr_qg.dat",EXIST=lexist) + IF ( lexist ) THEN + CALL wrf_message("ThompMP: read qr_acr_qg.dat stead of computing") + OPEN(63,file="qr_acr_qg.dat",form="unformatted",err=1234) + READ(63,err=1234) tcg_racg + READ(63,err=1234) tmr_racg + READ(63,err=1234) tcr_gacr + READ(63,err=1234) tmg_gacr + READ(63,err=1234) tnr_racg + READ(63,err=1234) tnr_gacr + good = 1 + 1234 CONTINUE + IF ( good .NE. 1 ) THEN + INQUIRE(63,opened=lopen) + IF (lopen) THEN + IF( force_read_thompson ) THEN + CALL wrf_error_fatal("Error reading qr_acr_qg.dat. Aborting because force_read_thompson is .true.") + ENDIF + CLOSE(63) + ELSE + IF( force_read_thompson ) THEN + CALL wrf_error_fatal("Error opening qr_acr_qg.dat. Aborting because force_read_thompson is .true.") + ENDIF + ENDIF + ENDIF + ELSE + IF( force_read_thompson ) THEN + CALL wrf_error_fatal("Non-existent qr_acr_qg.dat. Aborting because force_read_thompson is .true.") + ENDIF + ENDIF + ENDIF +#if defined(DM_PARALLEL) && !defined(STUBMPI) + CALL wrf_dm_bcast_integer(good,1) +#endif + + IF ( good .EQ. 1 ) THEN +#if defined(DM_PARALLEL) && !defined(STUBMPI) + CALL wrf_dm_bcast_double(tcg_racg,SIZE(tcg_racg)) + CALL wrf_dm_bcast_double(tmr_racg,SIZE(tmr_racg)) + CALL wrf_dm_bcast_double(tcr_gacr,SIZE(tcr_gacr)) + CALL wrf_dm_bcast_double(tmg_gacr,SIZE(tmg_gacr)) + CALL wrf_dm_bcast_double(tnr_racg,SIZE(tnr_racg)) + CALL wrf_dm_bcast_double(tnr_gacr,SIZE(tnr_gacr)) +#endif + ELSE + CALL wrf_message("ThompMP: computing qr_acr_qg") + do n2 = 1, nbr ! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2) & - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2) - enddo - do n = 1, nbg + enddo + do n = 1, nbg vg(n) = av_g*Dg(n)**bv_g - enddo + enddo !..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for !.. fortran indices. J. Michalakes, 2009Oct30. #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) - CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e ) + CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e ) #else - km_s = 0 - km_e = ntb_r*ntb_r1 - 1 + km_s = 0 + km_e = ntb_r*ntb_r1 - 1 #endif - do km = km_s, km_e + do km = km_s, km_e m = km / ntb_r1 + 1 k = mod( km , ntb_r1 ) + 1 @@ -3614,19 +3689,34 @@ subroutine qr_acr_qg tnr_gacr(i,j,k,m) = y2 enddo enddo - enddo + enddo !..Note wrf_dm_gatherv expects zero-based km_s, km_e (J. Michalakes, 2009Oct30). #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) - CALL wrf_dm_gatherv(tcg_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tmr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tcr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tmg_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tcg_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tmr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tcr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tmg_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_racg, ntb_g*ntb_g1, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_gacr, ntb_g*ntb_g1, km_s, km_e, R8SIZE) #endif + IF ( write_thompson_tables .AND. wrf_dm_on_monitor() ) THEN + CALL wrf_message("Writing qr_acr_qg.dat in Thompson MP init") + OPEN(63,file="qr_acr_qg.dat",form="unformatted",err=9234) + WRITE(63,err=9234) tcg_racg + WRITE(63,err=9234) tmr_racg + WRITE(63,err=9234) tcr_gacr + WRITE(63,err=9234) tmg_gacr + WRITE(63,err=9234) tnr_racg + WRITE(63,err=9234) tnr_gacr + CLOSE(63) + RETURN ! ----- RETURN + 9234 CONTINUE + CALL wrf_error_fatal("Error writing qr_acr_qg.dat") + ENDIF + ENDIF end subroutine qr_acr_qg !+---+-----------------------------------------------------------------+ @@ -3649,31 +3739,98 @@ subroutine qr_acr_qs DOUBLE PRECISION:: dvs, dvr, masss, massr DOUBLE PRECISION:: t1, t2, t3, t4, z1, z2, z3, z4 DOUBLE PRECISION:: y1, y2, y3, y4 + LOGICAL force_read_thompson, write_thompson_tables + LOGICAL lexist,lopen + INTEGER good + LOGICAL, EXTERNAL :: wrf_dm_on_monitor !+---+ - do n2 = 1, nbr + CALL nl_get_force_read_thompson(1,force_read_thompson) + CALL nl_get_write_thompson_tables(1,write_thompson_tables) + + good = 0 + IF ( wrf_dm_on_monitor() ) THEN + INQUIRE(FILE="qr_acr_qs.dat",EXIST=lexist) + IF ( lexist ) THEN + CALL wrf_message("ThompMP: read qr_acr_qs.dat instead of computing") + OPEN(63,file="qr_acr_qs.dat",form="unformatted",err=1234) + READ(63,err=1234)tcs_racs1 + READ(63,err=1234)tmr_racs1 + READ(63,err=1234)tcs_racs2 + READ(63,err=1234)tmr_racs2 + READ(63,err=1234)tcr_sacr1 + READ(63,err=1234)tms_sacr1 + READ(63,err=1234)tcr_sacr2 + READ(63,err=1234)tms_sacr2 + READ(63,err=1234)tnr_racs1 + READ(63,err=1234)tnr_racs2 + READ(63,err=1234)tnr_sacr1 + READ(63,err=1234)tnr_sacr2 + good = 1 + 1234 CONTINUE + IF ( good .NE. 1 ) THEN + INQUIRE(63,opened=lopen) + IF (lopen) THEN + IF( force_read_thompson ) THEN + CALL wrf_error_fatal("Error reading qr_acr_qs.dat. Aborting because force_read_thompson is .true.") + ENDIF + CLOSE(63) + ELSE + IF( force_read_thompson ) THEN + CALL wrf_error_fatal("Error opening qr_acr_qs.dat. Aborting because force_read_thompson is .true.") + ENDIF + ENDIF + ENDIF + ELSE + IF( force_read_thompson ) THEN + CALL wrf_error_fatal("Non-existent qr_acr_qs.dat. Aborting because force_read_thompson is .true.") + ENDIF + ENDIF + ENDIF +#if defined(DM_PARALLEL) && !defined(STUBMPI) + CALL wrf_dm_bcast_integer(good,1) +#endif + + IF ( good .EQ. 1 ) THEN +#if defined(DM_PARALLEL) && !defined(STUBMPI) + CALL wrf_dm_bcast_double(tcs_racs1,SIZE(tcs_racs1)) + CALL wrf_dm_bcast_double(tmr_racs1,SIZE(tmr_racs1)) + CALL wrf_dm_bcast_double(tcs_racs2,SIZE(tcs_racs2)) + CALL wrf_dm_bcast_double(tmr_racs2,SIZE(tmr_racs2)) + CALL wrf_dm_bcast_double(tcr_sacr1,SIZE(tcr_sacr1)) + CALL wrf_dm_bcast_double(tms_sacr1,SIZE(tms_sacr1)) + CALL wrf_dm_bcast_double(tcr_sacr2,SIZE(tcr_sacr2)) + CALL wrf_dm_bcast_double(tms_sacr2,SIZE(tms_sacr2)) + CALL wrf_dm_bcast_double(tnr_racs1,SIZE(tnr_racs1)) + CALL wrf_dm_bcast_double(tnr_racs2,SIZE(tnr_racs2)) + CALL wrf_dm_bcast_double(tnr_sacr1,SIZE(tnr_sacr1)) + CALL wrf_dm_bcast_double(tnr_sacr2,SIZE(tnr_sacr2)) +#endif + ELSE + CALL wrf_message("ThompMP: computing qr_acr_qs") + do n2 = 1, nbr ! vr(n2) = av_r*Dr(n2)**bv_r * DEXP(-fv_r*Dr(n2)) vr(n2) = -0.1021 + 4.932E3*Dr(n2) - 0.9551E6*Dr(n2)*Dr(n2) & + 0.07934E9*Dr(n2)*Dr(n2)*Dr(n2) & - 0.002362E12*Dr(n2)*Dr(n2)*Dr(n2)*Dr(n2) D1(n2) = (vr(n2)/av_s)**(1./bv_s) - enddo - do n = 1, nbs + enddo + do n = 1, nbs vs(n) = 1.5*av_s*Ds(n)**bv_s * DEXP(-fv_s*Ds(n)) - enddo + enddo !..Note values returned from wrf_dm_decomp1d are zero-based, add 1 for !.. fortran indices. J. Michalakes, 2009Oct30. #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) - CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e ) + CALL wrf_dm_decomp1d ( ntb_r*ntb_r1, km_s, km_e ) #else - km_s = 0 - km_e = ntb_r*ntb_r1 - 1 + km_s = 0 + km_e = ntb_r*ntb_r1 - 1 #endif - do km = km_s, km_e + do km = km_s, km_e m = km / ntb_r1 + 1 k = mod( km , ntb_r1 ) + 1 @@ -3800,25 +3957,46 @@ subroutine qr_acr_qs tnr_sacr2(i,j,k,m) = y4 enddo enddo - enddo + enddo !..Note wrf_dm_gatherv expects zero-based km_s, km_e (J. Michalakes, 2009Oct30). #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) - CALL wrf_dm_gatherv(tcs_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tmr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tcs_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tmr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tcr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tms_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tcr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tms_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) - CALL wrf_dm_gatherv(tnr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tcs_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tmr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tcs_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tmr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tcr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tms_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tcr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tms_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_racs1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_racs2, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_sacr1, ntb_s*ntb_t, km_s, km_e, R8SIZE) + CALL wrf_dm_gatherv(tnr_sacr2, ntb_s*ntb_t, km_s, km_e, R8SIZE) #endif + IF ( write_thompson_tables .AND. wrf_dm_on_monitor() ) THEN + CALL wrf_message("Writing qr_acr_qs.dat in Thompson MP init") + OPEN(63,file="qr_acr_qs.dat",form="unformatted",err=9234) + WRITE(63,err=9234)tcs_racs1 + WRITE(63,err=9234)tmr_racs1 + WRITE(63,err=9234)tcs_racs2 + WRITE(63,err=9234)tmr_racs2 + WRITE(63,err=9234)tcr_sacr1 + WRITE(63,err=9234)tms_sacr1 + WRITE(63,err=9234)tcr_sacr2 + WRITE(63,err=9234)tms_sacr2 + WRITE(63,err=9234)tnr_racs1 + WRITE(63,err=9234)tnr_racs2 + WRITE(63,err=9234)tnr_sacr1 + WRITE(63,err=9234)tnr_sacr2 + CLOSE(63) + RETURN ! ----- RETURN + 9234 CONTINUE + CALL wrf_error_fatal("Error writing qr_acr_qs.dat") + ENDIF + ENDIF end subroutine qr_acr_qs !+---+-----------------------------------------------------------------+ @@ -3840,23 +4018,80 @@ subroutine freezeH2O DOUBLE PRECISION:: sum1, sum2, sumn1, sumn2, & prob, vol, Texp, orho_w, & lam_exp, lamr, N0_r, lamc, N0_c, y + INTEGER:: nu_c REAL:: T_adjust + LOGICAL force_read_thompson, write_thompson_tables + LOGICAL lexist,lopen + INTEGER good + LOGICAL, EXTERNAL :: wrf_dm_on_monitor !+---+ + CALL nl_get_force_read_thompson(1,force_read_thompson) + CALL nl_get_write_thompson_tables(1,write_thompson_tables) - orho_w = 1./rho_w + good = 0 + IF ( wrf_dm_on_monitor() ) THEN + INQUIRE(FILE="freezeH2O.dat",EXIST=lexist) + IF ( lexist ) THEN + CALL wrf_message("ThompMP: read freezeH2O.dat stead of computing") + OPEN(63,file="freezeH2O.dat",form="unformatted",err=1234) + READ(63,err=1234)tpi_qrfz + READ(63,err=1234)tni_qrfz + READ(63,err=1234)tpg_qrfz + READ(63,err=1234)tnr_qrfz + READ(63,err=1234)tpi_qcfz + READ(63,err=1234)tni_qcfz + good = 1 + 1234 CONTINUE + IF ( good .NE. 1 ) THEN + INQUIRE(63,opened=lopen) + IF (lopen) THEN + IF( force_read_thompson ) THEN + CALL wrf_error_fatal("Error reading freezeH2O.dat. Aborting because force_read_thompson is .true.") + ENDIF + CLOSE(63) + ELSE + IF( force_read_thompson ) THEN + CALL wrf_error_fatal("Error opening freezeH2O.dat. Aborting because force_read_thompson is .true.") + ENDIF + ENDIF + ENDIF + ELSE + IF( force_read_thompson ) THEN + CALL wrf_error_fatal("Non-existent freezeH2O.dat. Aborting because force_read_thompson is .true.") + ENDIF + ENDIF + ENDIF + +#if defined(DM_PARALLEL) && !defined(STUBMPI) + CALL wrf_dm_bcast_integer(good,1) +#endif - do n2 = 1, nbr + IF ( good .EQ. 1 ) THEN +#if defined(DM_PARALLEL) && !defined(STUBMPI) + CALL wrf_dm_bcast_double(tpi_qrfz,SIZE(tpi_qrfz)) + CALL wrf_dm_bcast_double(tni_qrfz,SIZE(tni_qrfz)) + CALL wrf_dm_bcast_double(tpg_qrfz,SIZE(tpg_qrfz)) + CALL wrf_dm_bcast_double(tnr_qrfz,SIZE(tnr_qrfz)) + CALL wrf_dm_bcast_double(tpi_qcfz,SIZE(tpi_qcfz)) + CALL wrf_dm_bcast_double(tni_qcfz,SIZE(tni_qcfz)) +#endif + ELSE + CALL wrf_message("ThompMP: computing freezeH2O") + + orho_w = 1./rho_w + + do n2 = 1, nbr massr(n2) = am_r*Dr(n2)**bm_r - enddo - do n = 1, nbc + enddo + do n = 1, nbc massc(n) = am_r*Dc(n)**bm_r - enddo + enddo !..Freeze water (smallest drops become cloud ice, otherwise graupel). - do m = 1, ntb_IN - T_adjust = MAX(-3.0, MIN(3.0 - ALOG10(Nt_IN(m)), 3.0)) - do k = 1, 45 + do m = 1, ntb_IN + T_adjust = MAX(-3.0, MIN(3.0 - ALOG10(Nt_IN(m)), 3.0)) + do k = 1, 45 ! print*, ' Freezing water for temp = ', -k Texp = DEXP( DFLOAT(k) - T_adjust*1.0D0 ) - 1.0D0 do j = 1, ntb_r1 @@ -3907,8 +4142,24 @@ subroutine freezeH2O tni_qcfz(i,j,k,m) = sumn2 enddo enddo - enddo - enddo + enddo + enddo + + IF ( write_thompson_tables .AND. wrf_dm_on_monitor() ) THEN + CALL wrf_message("Writing freezeH2O.dat in Thompson MP init") + OPEN(63,file="freezeH2O.dat",form="unformatted",err=9234) + WRITE(63,err=9234)tpi_qrfz + WRITE(63,err=9234)tni_qrfz + WRITE(63,err=9234)tpg_qrfz + WRITE(63,err=9234)tnr_qrfz + WRITE(63,err=9234)tpi_qcfz + WRITE(63,err=9234)tni_qcfz + CLOSE(63) + RETURN ! ----- RETURN + 9234 CONTINUE + CALL wrf_error_fatal("Error writing freezeH2O.dat") + ENDIF + ENDIF end subroutine freezeH2O !+---+-----------------------------------------------------------------+ @@ -4137,6 +4388,7 @@ subroutine table_dropEvap INTEGER:: i, j, k, n DOUBLE PRECISION, DIMENSION(nbc):: N_c, massc DOUBLE PRECISION:: summ, summ2, lamc, N0_c + INTEGER:: nu_c ! DOUBLE PRECISION:: Nt_r, N0, lam_exp, lam ! REAL:: xlimit_intg @@ -4251,7 +4503,9 @@ subroutine table_ccnAct ENDDO 2010 CONTINUE ENDIF +#if defined(DM_PARALLEL) && !defined(STUBMPI) CALL wrf_dm_bcast_bytes ( iunit_mp_th1 , IWORDSIZE ) +#endif IF ( iunit_mp_th1 < 0 ) THEN CALL wrf_error_fatal ( 'module_mp_thompson: table_ccnAct: '// & 'Can not find unused fortran unit to read in lookup table.') @@ -4267,7 +4521,9 @@ subroutine table_ccnAct #define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes(A, size(A)*R4SIZE) IF ( wrf_dm_on_monitor() ) READ(iunit_mp_th1,ERR=9010) tnccn_act +#if defined(DM_PARALLEL) && !defined(STUBMPI) DM_BCAST_MACRO(tnccn_act) +#endif RETURN @@ -4580,6 +4836,7 @@ real function iceDeMott(tempc, qv, qvs, qvsi, rho, nifa) REAL, PARAMETER:: bbp = 0. REAL, PARAMETER:: y1p = -35. REAL, PARAMETER:: y2p = -25. + REAL, PARAMETER:: rho_not0 = 101325./(287.05*273.15) !+---+ @@ -4614,11 +4871,12 @@ real function iceDeMott(tempc, qv, qvs, qvsi, rho, nifa) endif mux = hx*p_alpha*n_in*rho xni = mux*((6700.*nifa)-200.)/((6700.*5.E5)-200.) - elseif (satw.ge.0.985) then - nifa_cc = nifa*RHO_NOT*1.E-6 - xni = (5.94e-5*(-tempc)**3.33) & - * (nifa_cc**((-0.0264*(tempc))+0.0033)) - xni = xni*rho/RHO_NOT * 1000. + elseif (satw.ge.0.985 .and. tempc.gt.HGFR-273.15) then + nifa_cc = nifa*RHO_NOT0*1.E-6/rho + xni = 3.*nifa_cc**(1.25)*exp((0.46*(-tempc))-11.6) ! [DeMott, 2015] +! xni = (5.94e-5*(-tempc)**3.33) & +! * (nifa_cc**((-0.0264*(tempc))+0.0033)) + xni = xni*rho/RHO_NOT0 * 1000. endif iceDeMott = MAX(0., xni) @@ -4646,10 +4904,11 @@ real function iceKoop(temp, qv, qvs, naero, dt) log_J_rate = -906.7 + (8502.0*delta_aw) & & - (26924.0*delta_aw*delta_aw) & & + (29180.0*delta_aw*delta_aw*delta_aw) + log_J_rate = MIN(20.0, log_J_rate) J_rate = 0.01*(10.**log_J_rate) ! cm-3 s-1 prob_h = MIN(1.-exp(-J_rate*ar_volume*DT), 1.) if (prob_h .gt. 0.) then - xni = MIN(prob_h*naero, 250.E3) + xni = MIN(prob_h*naero, 1000.E3) endif iceKoop = MAX(0.0, xni) @@ -4743,7 +5002,13 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & if (has_qc) then do k = kts, kte if (rc(k).le.R1 .or. nc(k).le.R2) CYCLE - inu_c = MIN(15, NINT(1000.E6/nc(k)) + 2) + if (nc(k).lt.100) then + inu_c = 15 + elseif (nc(k).gt.1.E10) then + inu_c = 2 + else + inu_c = MIN(15, NINT(1000.E6/nc(k)) + 2) + endif lamc = (nc(k)*am_r*g_ratio(inu_c)/rc(k))**obmr re_qc1d(k) = MAX(2.51E-6, MIN(SNGL(0.5D0 * DBLE(3.+inu_c)/lamc), 50.E-6)) enddo @@ -4793,7 +5058,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & & + sb(7)*tc0*tc0*cse(1) + sb(8)*tc0*cse(1)*cse(1) & & + sb(9)*tc0*tc0*tc0 + sb(10)*cse(1)*cse(1)*cse(1) smoc = a_ * smo2**b_ - re_qs1d(k) = MAX(25.E-6, MIN(0.5*(smoc/smob), 999.E-6)) + re_qs1d(k) = MAX(10.E-6, MIN(0.5*(smoc/smob), 999.E-6)) enddo endif @@ -5105,8 +5370,9 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d, & ! enddo end subroutine calc_refl10cm - +! !+---+-----------------------------------------------------------------+ + !+---+-----------------------------------------------------------------+ END MODULE module_mp_thompson !+---+-----------------------------------------------------------------+ diff --git a/wrfv2_fire/phys/module_mp_wdm5.F b/wrfv2_fire/phys/module_mp_wdm5.F index c597de74..ea0e9b27 100644 --- a/wrfv2_fire/phys/module_mp_wdm5.F +++ b/wrfv2_fire/phys/module_mp_wdm5.F @@ -82,6 +82,8 @@ SUBROUTINE wdm5(th, q, qc, qr, qi, qs & ,rain, rainncv & ,snow, snowncv & ,sr & + ,has_reqc, has_reqi, has_reqs & ! for radiation + ,re_cloud, re_ice, re_snow & ! for radiation ,refl_10cm, diagflag, do_radar_ref & ,itimestep & ,ids,ide, jds,jde, kds,kde & @@ -109,6 +111,14 @@ SUBROUTINE wdm5(th, q, qc, qr, qi, qs & ! ! Implemented by Kyo-Sun Lim and Jimy Dudhia (NCAR) Winter 2008 ! +! further modifications : +! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 +! ==> higher accuracy and efficient at lower resolutions +! reflectivity computation from greg thompson, lim, jun 2011 +! ==> only diagnostic, but with removal of too large drops +! effective radius of hydrometeors, bae from kiaps, jan 2015 +! ==> consistency in solar insolation of rrtmg radiation +! ! Reference) Lim and Hong (LH, 2010) Mon. Wea. Rev. ! Juang and Hong (JH, 2010) Mon. Wea. Rev. ! Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. @@ -165,6 +175,16 @@ SUBROUTINE wdm5(th, q, qc, qr, qi, qs & INTENT(INOUT) :: rain, & rainncv, & sr +! for radiation connecting + INTEGER, INTENT(IN):: & + has_reqc, & + has_reqi, & + has_reqs + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & + INTENT(INOUT):: & + re_cloud, & + re_ice, & + re_snow !+---+-----------------------------------------------------------------+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & ! GT refl_10cm @@ -186,6 +206,10 @@ SUBROUTINE wdm5(th, q, qc, qr, qi, qs & LOGICAL, OPTIONAL, INTENT(IN) :: diagflag INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref !+---+-----------------------------------------------------------------+ +! to calculate effective radius for radiation + REAL, DIMENSION( kts:kte ) :: qc1d, nc1d, den1d + REAL, DIMENSION( kts:kte ) :: qi1d + REAL, DIMENSION( kts:kte ) :: re_qc, re_qi, re_qs #ifndef RUN_ON_GPU IF (itimestep .eq. 1) THEN @@ -261,6 +285,31 @@ SUBROUTINE wdm5(th, q, qc, qr, qi, qs & ENDDO endif ENDIF + + if (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) then + do i = its, ite + do k = kts, kte + re_qc(k) = 2.51E-6 + re_qi(k) = 10.01E-6 + re_qs(k) = 25.E-6 + + t1d(k) = th(i,k,j)*pii(i,k,j) + den1d(k)= den(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qs1d(k) = qs(i,k,j) + nc1d(k) = nc(i,k,j) + enddo + call effectRad_wdm5 (t1d, qc1d, nc1d, qi1d, qs1d, den1d, & + qmin, t0c, re_qc, re_qi, re_qs, & + kts, kte, i, j) + do k = kts, kte + re_cloud(i,k,j) = MAX(2.51E-6, MIN(re_qc(k), 50.E-6)) + re_ice(i,k,j) = MAX(10.01E-6, MIN(re_qi(k), 125.E-6)) + re_snow(i,k,j) = MAX(25.E-6, MIN(re_qs(k), 999.E-6)) + enddo ! k loop + enddo ! i loop + endif ! has_reqc, etc... !+---+-----------------------------------------------------------------+ ENDDO @@ -2239,4 +2288,106 @@ subroutine refl10cm_wdm5 (qv1d, qr1d, nr1d, qs1d, & end subroutine refl10cm_wdm5 !+---+-----------------------------------------------------------------+ +!----------------------------------------------------------------------- + subroutine effectRad_wdm5 (t, qc, nc, qi, qs, rho, qmin, t0c, & + re_qc, re_qi, re_qs, kts, kte, ii, jj) + +!----------------------------------------------------------------------- +! Compute radiation effective radii of cloud water, ice, and snow for +! double-moment microphysics.. +! These are entirely consistent with microphysics assumptions, not +! constant or otherwise ad hoc as is internal to most radiation +! schemes. +! Coded and implemented by Soo Ya Bae, KIAPS, January 2015. +!----------------------------------------------------------------------- + implicit none + +!..Sub arguments + integer, intent(in) :: kts, kte, ii, jj + real, intent(in) :: qmin + real, intent(in) :: t0c + real, dimension( kts:kte ), intent(in):: t + real, dimension( kts:kte ), intent(in):: qc + real, dimension( kts:kte ), intent(in):: nc + real, dimension( kts:kte ), intent(in):: qi + real, dimension( kts:kte ), intent(in):: qs + real, dimension( kts:kte ), intent(in):: rho + real, dimension( kts:kte ), intent(inout):: re_qc + real, dimension( kts:kte ), intent(inout):: re_qi + real, dimension( kts:kte ), intent(inout):: re_qs +!..Local variables + integer:: i,k + integer :: inu_c + real, dimension( kts:kte ):: ni + real, dimension( kts:kte ):: rqc + real, dimension( kts:kte ):: rnc + real, dimension( kts:kte ):: rqi + real, dimension( kts:kte ):: rni + real, dimension( kts:kte ):: rqs + real :: cdm2 + real :: temp + real :: supcol, n0sfac, lamdas + real :: diai ! diameter of ice in m + double precision :: lamc + logical :: has_qc, has_qi, has_qs +!..Minimum microphys values + real, parameter :: R1 = 1.E-12 + real, parameter :: R2 = 1.E-6 + real, parameter :: pi = 3.1415926536 + real, parameter :: bm_r = 3.0 + real, parameter :: obmr = 1.0/bm_r + real, parameter :: cdm = 5./3. + + has_qc = .false. + has_qi = .false. + has_qs = .false. + + cdm2 = rgmma(cdm) + + do k=kts,kte + ! for cloud + rqc(k) = max(R1, qc(k)*rho(k)) + rnc(k) = max(R2, nc(k)*rho(k)) + if (rqc(k).gt.R1 .and. rnc(k).gt.R2) has_qc = .true. + ! for ice + rqi(k) = max(R1, qi(k)*rho(k)) + temp = (rho(k)*max(qi(k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(k) = min(max(5.38e7*temp,1.e3),1.e6) + rni(k)= max(R2, ni(k)*rho(k)) + if (rqi(k).gt.R1 .and. rni(k).gt.R2) has_qi = .true. + ! for snow + rqs(k) = max(R1, qs(k)*rho(k)) + if (rqs(k).gt.R1) has_qs = .true. + enddo + + if (has_qc) then + do k=kts,kte + if (rqc(k).le.R1 .or. rnc(k).le.R2) CYCLE + lamc = 2.*cdm2*(pidnc*nc(k)/rqc(k))**obmr + re_qc(k) = max(2.51e-6,min(sngl(1.0d0/lamc),50.e-6)) + enddo + endif + + if (has_qi) then + do k=kts,kte + if (rqi(k).le.R1 .or. rni(k).le.R2) CYCLE + diai = 11.9*sqrt(rqi(k)/ni(k)) + re_qi(k) = max(10.01e-6,min(0.75*0.163*diai,125.e-6)) + enddo + endif + + if (has_qs) then + do k=kts,kte + if (rqs(k).le.R1) CYCLE + supcol = t0c-t(k) + n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) + lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(k))) + re_qs(k) = max(25.e-6,min(0.5*(1./lamdas),999.e-6)) + enddo + endif + + end subroutine effectRad_wdm5 +!----------------------------------------------------------------------- + END MODULE module_mp_wdm5 diff --git a/wrfv2_fire/phys/module_mp_wdm6.F b/wrfv2_fire/phys/module_mp_wdm6.F index cd192a2f..47f4552d 100644 --- a/wrfv2_fire/phys/module_mp_wdm6.F +++ b/wrfv2_fire/phys/module_mp_wdm6.F @@ -14,7 +14,7 @@ MODULE module_mp_wdm6 ! REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain - REAL, PARAMETER, PRIVATE :: n0g = 4.e6 ! intercept parameter graupel +! REAL, PARAMETER, PRIVATE :: n0g = 4.e6 ! intercept parameter graupel ! RAS - now set in subroutine based on namelist option REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m @@ -23,16 +23,16 @@ MODULE module_mp_wdm6 REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: avtg = 330. ! a constant for terminal velocity of graupel - REAL, PARAMETER, PRIVATE :: bvtg = 0.8 ! a constant for terminal velocity of graupel - REAL, PARAMETER, PRIVATE :: deng = 500. ! density of graupel +! REAL, PARAMETER, PRIVATE :: avtg = 330. ! a constant for terminal velocity of graupel ! RAS - now set in subroutine based on namelist option +! REAL, PARAMETER, PRIVATE :: bvtg = 0.8 ! a constant for terminal velocity of graupel ! RAS - now set in subroutine based on namelist option +! REAL, PARAMETER, PRIVATE :: deng = 500. ! density of graupel !RAS13.1 - now set in subroutine based on namelist option REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) REAL, PARAMETER, PRIVATE :: lamdacmax = 5.0e5 ! limited maximum value for slope parameter of cloud water REAL, PARAMETER, PRIVATE :: lamdacmin = 2.0e4 ! limited minimum value for slope parameter of cloud water REAL, PARAMETER, PRIVATE :: lamdarmax = 5.0e4 ! limited maximum value for slope parameter of rain REAL, PARAMETER, PRIVATE :: lamdarmin = 2.0e3 ! limited minimum value for slope parameter of rain REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow - REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel +! REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel - now set in subroutine based on namelist option REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow @@ -68,6 +68,7 @@ MODULE module_mp_wdm6 bvts3,bvts4,g1pbs,g3pbs,g4pbs,g5pbso2, & pvts,pacrs,precs1,precs2,pidn0s,xlv1,pacrc, & bvtg1,bvtg2,bvtg3,bvtg4,g1pbg,g3pbg,g4pbg, & + n0g,avtg,bvtg,deng,lamdagmax, & !RAS13.3 - set these in wdm6init g5pbgo2,pvtg,pacrg,precg1,precg2,pidn0g, & rslopecmax,rslopec2max,rslopec3max, & rslopermax,rslopesmax,rslopegmax, & @@ -90,6 +91,8 @@ SUBROUTINE wdm6(th, q, qc, qr, qi, qs, qg, & refl_10cm, diagflag, do_radar_ref, & graupel, graupelncv, & itimestep, & + has_reqc, has_reqi, has_reqs, & ! for radiation + re_cloud, re_ice, re_snow, & ! for radiation ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte & @@ -116,6 +119,16 @@ SUBROUTINE wdm6(th, q, qc, qr, qi, qs, qg, & ! ! Implemented by Kyo-Sun Lim and Jimy Dudhia (NCAR) Winter 2008 ! +! further modifications : +! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 +! ==> higher accuracy and efficient at lower resolutions +! reflectivity computation from greg thompson, lim, jun 2011 +! ==> only diagnostic, but with removal of too large drops +! add hail option from afwa, aug 2014 +! ==> switch graupel or hail by changing no, den, fall vel. +! effective radius of hydrometeors, bae from kiaps, jan 2015 +! ==> consistency in solar insolation of rrtmg radiation +! ! Reference) Lim and Hong (LH, 2010) Mon. Wea. Rev. ! Juang and Hong (JH, 2010) Mon. Wea. Rev. ! Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. @@ -173,6 +186,16 @@ SUBROUTINE wdm6(th, q, qc, qr, qi, qs, qg, & INTENT(INOUT) :: rain, & rainncv, & sr +! for radiation connecting + INTEGER, INTENT(IN):: & + has_reqc, & + has_reqi, & + has_reqs + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & + INTENT(INOUT):: & + re_cloud, & + re_ice, & + re_snow !+---+-----------------------------------------------------------------+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & ! GT @@ -185,6 +208,7 @@ SUBROUTINE wdm6(th, q, qc, qr, qi, qs, qg, & REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & INTENT(INOUT) :: graupel, & graupelncv + ! LOCAL VAR REAL, DIMENSION( its:ite , kts:kte ) :: t REAL, DIMENSION( its:ite , kts:kte, 2 ) :: qci @@ -196,6 +220,10 @@ SUBROUTINE wdm6(th, q, qc, qr, qi, qs, qg, & LOGICAL, OPTIONAL, INTENT(IN) :: diagflag INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref !+---+-----------------------------------------------------------------+ +! to calculate effective radius for radiation + REAL, DIMENSION( kts:kte ) :: qc1d, nc1d, den1d + REAL, DIMENSION( kts:kte ) :: qi1d + REAL, DIMENSION( kts:kte ) :: re_qc, re_qi, re_qs IF (itimestep .eq. 1) THEN DO j=jms,jme @@ -274,9 +302,35 @@ SUBROUTINE wdm6(th, q, qc, qr, qi, qs, qg, & ENDDO endif ENDIF -!+---+-----------------------------------------------------------------+ +! calculate effective radius of cloud, ice, and snow + IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN + DO i=its,ite + DO k=kts,kte + re_qc(k) = 2.51E-6 + re_qi(k) = 10.01E-6 + re_qs(k) = 25.E-6 + + t1d(k) = th(i,k,j)*pii(i,k,j) + den1d(k)= den(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qs1d(k) = qs(i,k,j) + nc1d(k) = nc(i,k,j) + ENDDO + call effectRad_wdm6(t1d, qc1d, nc1d, qi1d, qs1d, den1d, & + qmin, t0c, re_qc, re_qi, re_qs, & + kts, kte, i, j) + DO k=kts,kte + re_cloud(i,k,j) = max(2.51E-6, min(re_qc(k), 50.E-6)) + re_ice(i,k,j) = max(10.01E-6, min(re_qi(k), 125.E-6)) + re_snow(i,k,j) = max(25.E-6, min(re_qs(k), 999.E-6)) + ENDDO + ENDDO + ENDIF + ENDDO + END SUBROUTINE wdm6 !=================================================================== ! @@ -378,9 +432,9 @@ SUBROUTINE wdm62D(t, q, qci, qrs, ncr, den, p, delz & nsacw, ngacw, niacr, nsacr, ngacr, naacw, & nseml, ngeml, ncact REAL, DIMENSION( its:ite , kts:kte ) :: & - pigen, pidep, pcond, xl, cpm, work2, psmlt, psevp, & - denfac, xni, pgevp,n0sfac, qsum, & - denqrs1, denqr1, denqrs2, denqrs3, denncr3, denqci + pigen, pidep, pcond, pgevp, psmlt, psevp, & + xl, cpm, work2, denfac, n0sfac, qsum, & + denqrs1, denqr1, denqrs2, denqrs3, denncr3, denqci, xni REAL, DIMENSION( its:ite ) :: & delqrs1, delqrs2, delqrs3, delncr3, delqi REAL, DIMENSION( its:ite ) :: tstepsnow, tstepgraup @@ -1851,7 +1905,7 @@ REAL FUNCTION rgmma(x) INTEGER :: i if(x.eq.1.)then rgmma=0. - else + else rgmma=x*exp(euler*x) do i=1,10000 y=float(i) @@ -1886,13 +1940,30 @@ REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END FUNCTION fpvs !------------------------------------------------------------------- - SUBROUTINE wdm6init(den0,denr,dens,cl,cpv, ccn0, allowed_to_read) + SUBROUTINE wdm6init(den0,denr,dens,cl,cpv, ccn0, hail_opt, allowed_to_read) ! RAS !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- !.... constants which may not be tunable REAL, INTENT(IN) :: den0,denr,dens,cl,cpv,ccn0 + INTEGER, INTENT(IN) :: hail_opt ! RAS LOGICAL, INTENT(IN) :: allowed_to_read + +! RAS13.1 define graupel parameters as graupel-like or hail-like, +! depending on namelist option + IF (hail_opt .eq. 1) THEN !Hail! + n0g = 4.e4 + deng = 700. + avtg = 285.0 + bvtg = 0.8 + lamdagmax = 2.e4 + ELSE !Graupel! + n0g = 4.e6 + deng = 500 + avtg = 330.0 + bvtg = 0.8 + lamdagmax = 6.e4 + ENDIF ! pi = 4.*atan(1.) xlv1 = cl-cpv @@ -1993,7 +2064,6 @@ SUBROUTINE wdm6init(den0,denr,dens,cl,cpv, ccn0, allowed_to_read) call radar_init !+---+-----------------------------------------------------------------+ - ! END SUBROUTINE wdm6init !------------------------------------------------------------------------------ @@ -2918,4 +2988,107 @@ subroutine refl10cm_wdm6 (qv1d, qr1d, nr1d, qs1d, qg1d, & end subroutine refl10cm_wdm6 !+---+-----------------------------------------------------------------+ +!----------------------------------------------------------------------- + subroutine effectRad_wdm6 (t, qc, nc, qi, qs, rho, qmin, t0c, & + re_qc, re_qi, re_qs, kts, kte, ii, jj) + +!----------------------------------------------------------------------- +! Compute radiation effective radii of cloud water, ice, and snow for +! double-moment microphysics.. +! These are entirely consistent with microphysics assumptions, not +! constant or otherwise ad hoc as is internal to most radiation +! schemes. +! Coded and implemented by Soo Ya Bae, KIAPS, January 2015. +!----------------------------------------------------------------------- + + implicit none + +!..Sub arguments + integer, intent(in) :: kts, kte, ii, jj + real, intent(in) :: qmin + real, intent(in) :: t0c + real, dimension( kts:kte ), intent(in):: t + real, dimension( kts:kte ), intent(in):: qc + real, dimension( kts:kte ), intent(in):: nc + real, dimension( kts:kte ), intent(in):: qi + real, dimension( kts:kte ), intent(in):: qs + real, dimension( kts:kte ), intent(in):: rho + real, dimension( kts:kte ), intent(inout):: re_qc + real, dimension( kts:kte ), intent(inout):: re_qi + real, dimension( kts:kte ), intent(inout):: re_qs +!..Local variables + integer:: i,k + integer :: inu_c + real, dimension( kts:kte ):: ni + real, dimension( kts:kte ):: rqc + real, dimension( kts:kte ):: rnc + real, dimension( kts:kte ):: rqi + real, dimension( kts:kte ):: rni + real, dimension( kts:kte ):: rqs + real :: cdm2 + real :: temp + real :: supcol, n0sfac, lamdas + real :: diai ! diameter of ice in m + double precision :: lamc + logical :: has_qc, has_qi, has_qs +!..Minimum microphys values + real, parameter :: R1 = 1.E-12 + real, parameter :: R2 = 1.E-6 + real, parameter :: pi = 3.1415926536 + real, parameter :: bm_r = 3.0 + real, parameter :: obmr = 1.0/bm_r + real, parameter :: cdm = 5./3. +!----------------------------------------------------------------------- + has_qc = .false. + has_qi = .false. + has_qs = .false. + + cdm2 = rgmma(cdm) + + do k=kts,kte + ! for cloud + rqc(k) = max(R1, qc(k)*rho(k)) + rnc(k) = max(R2, nc(k)*rho(k)) + if (rqc(k).gt.R1 .and. rnc(k).gt.R2) has_qc = .true. + ! for ice + rqi(k) = max(R1, qi(k)*rho(k)) + temp = (rho(k)*max(qi(k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(k) = min(max(5.38e7*temp,1.e3),1.e6) + rni(k)= max(R2, ni(k)*rho(k)) + if (rqi(k).gt.R1 .and. rni(k).gt.R2) has_qi = .true. + ! for snow + rqs(k) = max(R1, qs(k)*rho(k)) + if (rqs(k).gt.R1) has_qs = .true. + enddo + + if (has_qc) then + do k=kts,kte + if (rqc(k).le.R1 .or. rnc(k).le.R2) CYCLE + lamc = 2.*cdm2*(pidnc*nc(k)/rqc(k))**obmr + re_qc(k) = max(2.51e-6,min(sngl(1.0d0/lamc),50.e-6)) + enddo + endif + + if (has_qi) then + do k=kts,kte + if (rqi(k).le.R1 .or. rni(k).le.R2) CYCLE + diai = 11.9*sqrt(rqi(k)/ni(k)) + re_qi(k) = max(10.01e-6,min(0.75*0.163*diai,125.e-6)) + enddo + endif + + if (has_qs) then + do k=kts,kte + if (rqs(k).le.R1) CYCLE + supcol = t0c-t(k) + n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) + lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(k))) + re_qs(k) = max(25.e-6,min(0.5*(1./lamdas),999.e-6)) + enddo + endif + + end subroutine effectRad_wdm6 +!----------------------------------------------------------------------- + END MODULE module_mp_wdm6 diff --git a/wrfv2_fire/phys/module_mp_wsm3.F b/wrfv2_fire/phys/module_mp_wsm3.F index f18df7e2..c7ee838c 100644 --- a/wrfv2_fire/phys/module_mp_wsm3.F +++ b/wrfv2_fire/phys/module_mp_wsm3.F @@ -32,7 +32,8 @@ MODULE module_mp_wsm3 REAL, PARAMETER, PRIVATE :: alpha = .12 ! .122 exponen factor for n0s REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg REAL, SAVE :: & - qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & + qc0, qck1, pidnc, & + bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & precr1,precr2,xmmax,roqimax,bvts1, & bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & @@ -57,6 +58,8 @@ SUBROUTINE wsm3(th, q, qci, qrs & , rain, rainncv & , snow, snowncv & , sr & + , has_reqc, has_reqi, has_reqs & ! for radiation + , re_cloud, re_ice, re_snow & ! for radiation , ids,ide, jds,jde, kds,kde & , ims,ime, jms,jme, kms,kme & , its,ite, jts,jte, kts,kte & @@ -105,9 +108,29 @@ SUBROUTINE wsm3(th, q, qci, qrs & INTENT(INOUT) :: snow, & snowncv, & sr +! for radiation connecting + INTEGER, INTENT(IN):: & + has_reqc, & + has_reqi, & + has_reqs + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & + INTENT(INOUT):: & + re_cloud, & + re_ice, & + re_snow + ! LOCAL VAR REAL, DIMENSION( its:ite , kts:kte ) :: t INTEGER :: i,j,k + +! to calculate effective radius for radiation + REAL, DIMENSION( kts:kte ) :: t1d + REAL, DIMENSION( kts:kte ) :: den1d + REAL, DIMENSION( kts:kte ) :: qc1d + REAL, DIMENSION( kts:kte ) :: qi1d + REAL, DIMENSION( kts:kte ) :: qs1d + REAL, DIMENSION( kts:kte ) :: re_qc, re_qi, re_qs + !------------------------------------------------------------------- DO j=jts,jte DO k=kts,kte @@ -135,6 +158,37 @@ SUBROUTINE wsm3(th, q, qci, qrs & th(i,k,j)=t(i,k)/pii(i,k,j) ENDDO ENDDO + + if (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) then + do i=its,ite + do k=kts,kte + re_qc(k) = 2.51E-6 + re_qi(k) = 10.01E-6 + re_qs(k) = 25.E-6 + + t1d(k) = th(i,k,j)*pii(i,k,j) + den1d(k)= den(i,k,j) + if(t(i,k).ge.t0c) then + qc1d(k) = qci(i,k,j) + qi1d(k) = 0.0 + qs1d(k) = 0.0 + else + qc1d(k) = 0.0 + qi1d(k) = qci(i,k,j) + qs1d(k) = qrs(i,k,j) + endif + enddo + call effectRad_wsm3(t1d, qc1d, qi1d, qs1d, den1d, & + qmin, t0c, re_qc, re_qi, re_qs, & + kts, kte, i, j) + do k=kts,kte + re_cloud(i,k,j) = MAX(2.51E-6, MIN(re_qc(k), 50.E-6)) + re_ice(i,k,j) = MAX(10.01E-6, MIN(re_qi(k), 125.E-6)) + re_snow(i,k,j) = MAX(25.E-6, MIN(re_qs(k), 999.E-6)) + enddo + enddo + endif ! has_reqc, etc... + ENDDO END SUBROUTINE wsm3 !=================================================================== @@ -175,8 +229,11 @@ SUBROUTINE wsm32D(t, q & ! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) ! Summer 2003 ! -! History : semi-lagrangian scheme sedimentation(JH), and clean up -! Hong, August 2009 +! further modifications : +! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 +! ==> higher accuracy and efficient at lower resolutions +! effective radius of hydrometeors, bae from kiaps, jan 2015 +! ==> consistency in solar insolation of rrtmg radiation ! ! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. ! Dudhia (D89, 1989) J. Atmos. Sci. @@ -875,6 +932,7 @@ SUBROUTINE wsm3init(den0,denr,dens,cl,cpv,allowed_to_read) ! qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 + pidnc = pi*denr/6. ! syb ! bvtr1 = 1.+bvtr bvtr2 = 2.5+.5*bvtr @@ -1416,5 +1474,101 @@ SUBROUTINE nislfv_rain_plm(im,km,denl,denfacl,tkl,dzl,wwl,rql,precip,dt,id,iter) ! END SUBROUTINE nislfv_rain_plm ! +!----------------------------------------------------------------------- + subroutine effectRad_wsm3 (t, qc, qi, qs, rho, qmin, t0c, & + re_qc, re_qi, re_qs, kts, kte, ii, jj) + +!----------------------------------------------------------------------- +! Compute radiation effective radii of cloud water, ice, and snow for +! single-moment microphysics. +! These are entirely consistent with microphysics assumptions, not +! constant or otherwise ad hoc as is internal to most radiation +! schemes. +! Coded and implemented by Soo ya Bae, KIAPS, January 2015. +!----------------------------------------------------------------------- + + implicit none + +!..Sub arguments + integer, intent(in) :: kts, kte, ii, jj + real, intent(in) :: qmin + real, intent(in) :: t0c + real, dimension( kts:kte ), intent(in):: t + real, dimension( kts:kte ), intent(in):: qc + real, dimension( kts:kte ), intent(in):: qi + real, dimension( kts:kte ), intent(in):: qs + real, dimension( kts:kte ), intent(in):: rho + real, dimension( kts:kte ), intent(inout):: re_qc + real, dimension( kts:kte ), intent(inout):: re_qi + real, dimension( kts:kte ), intent(inout):: re_qs +!..Local variables + integer:: i,k + integer :: inu_c + real, dimension( kts:kte ):: ni + real, dimension( kts:kte ):: rqc + real, dimension( kts:kte ):: rqi + real, dimension( kts:kte ):: rni + real, dimension( kts:kte ):: rqs + real :: temp + real :: lamdac + real :: supcol, n0sfac, lamdas + real :: diai ! diameter of ice in m + logical :: has_qc, has_qi, has_qs +!..Minimum microphys values + real, parameter :: R1 = 1.E-12 + real, parameter :: R2 = 1.E-6 +!..Mass power law relations: mass = am*D**bm + real, parameter :: bm_r = 3.0 + real, parameter :: obmr = 1.0/bm_r + real, parameter :: nc0 = 3.E8 +!----------------------------------------------------------------------- + has_qc = .false. + has_qi = .false. + has_qs = .false. + + do k = kts, kte + ! for cloud + rqc(k) = max(R1, qc(k)*rho(k)) + if (rqc(k).gt.R1) has_qc = .true. + ! for ice + rqi(k) = max(R1, qi(k)*rho(k)) + temp = (rho(k)*max(qi(k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(k) = min(max(5.38e7*temp,1.e3),1.e6) + rni(k)= max(R2, ni(k)*rho(k)) + if (rqi(k).gt.R1 .and. rni(k).gt.R2) has_qi = .true. + ! for snow + rqs(k) = max(R1, qs(k)*rho(k)) + if (rqs(k).gt.R1) has_qs = .true. + enddo + + if (has_qc) then + do k=kts,kte + if (rqc(k).le.R1) CYCLE + lamdac = (pidnc*nc0/rqc(k))**obmr + re_qc(k) = max(2.51E-6,min(1.5*(1.0/lamdac),50.E-6)) + enddo + endif + + if (has_qi) then + do k=kts,kte + if (rqi(k).le.R1 .or. rni(k).le.R2) CYCLE + diai = 11.9*sqrt(rqi(k)/ni(k)) + re_qi(k) = max(10.01E-6,min(0.75*0.163*diai,125.E-6)) + enddo + endif + + if (has_qs) then + do k=kts,kte + if (rqs(k).le.R1) CYCLE + supcol = t0c-t(k) + n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) + lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(k))) + re_qs(k) = max(25.E-6,min(0.5*(1./lamdas), 999.E-6)) + enddo + endif + + end subroutine effectRad_wsm3 +!----------------------------------------------------------------------- END MODULE module_mp_wsm3 #endif diff --git a/wrfv2_fire/phys/module_mp_wsm5.F b/wrfv2_fire/phys/module_mp_wsm5.F index 039588f4..a598df97 100644 --- a/wrfv2_fire/phys/module_mp_wsm5.F +++ b/wrfv2_fire/phys/module_mp_wsm5.F @@ -39,7 +39,8 @@ MODULE module_mp_wsm5 REAL, PARAMETER, PRIVATE :: qcrmin = 1.e-9 ! minimun values for qr, qs, and qg REAL, PARAMETER, PRIVATE :: eacrc = 1.0 ! Snow/cloud-water collection efficiency REAL, SAVE :: & - qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & + qc0, qck1, pidnc, & + bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & precr1,precr2,xmmax,roqimax,bvts1, & bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & @@ -65,6 +66,8 @@ SUBROUTINE wsm5(th, q, qc, qr, qi, qs & ,snow, snowncv & ,sr & ,refl_10cm, diagflag, do_radar_ref & + ,has_reqc, has_reqi, has_reqs & ! for radiation + ,re_cloud, re_ice, re_snow & ! for radiation ,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & ,its,ite, jts,jte, kts,kte & @@ -112,7 +115,16 @@ SUBROUTINE wsm5(th, q, qc, qr, qi, qs & INTENT(INOUT) :: rain, & rainncv, & sr - +! for radiation connecting + INTEGER, INTENT(IN):: & + has_reqc, & + has_reqi, & + has_reqs + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & + INTENT(INOUT):: & + re_cloud, & + re_ice, & + re_snow !+---+-----------------------------------------------------------------+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & ! GT refl_10cm @@ -137,6 +149,12 @@ SUBROUTINE wsm5(th, q, qc, qr, qi, qs & INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref !+---+-----------------------------------------------------------------+ +! to calculate effective radius for radiation + REAL, DIMENSION( kts:kte ) :: den1d + REAL, DIMENSION( kts:kte ) :: qc1d + REAL, DIMENSION( kts:kte ) :: qi1d + REAL, DIMENSION( kts:kte ) :: re_qc, re_qi, re_qs + !+---+-----------------------------------------------------------------+ #ifndef XEON_OPTIMIZED_WSM5 @@ -198,6 +216,30 @@ SUBROUTINE wsm5(th, q, qc, qr, qi, qs & ENDDO endif ENDIF + + if (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) then + do i=its,ite + do k=kts,kte + re_qc(k) = 2.51E-6 + re_qi(k) = 10.01E-6 + re_qs(k) = 25.E-6 + + t1d(k) = th(i,k,j)*pii(i,k,j) + den1d(k)= den(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qs1d(k) = qs(i,k,j) + enddo + call effectRad_wsm5(t1d, qc1d, qi1d, qs1d, den1d, & + qmin, t0c, re_qc, re_qi, re_qs, & + kts, kte, i, j) + do k=kts,kte + re_cloud(i,k,j) = MAX(2.51E-6, MIN(re_qc(k), 50.E-6)) + re_ice(i,k,j) = MAX(10.01E-6, MIN(re_qi(k), 125.E-6)) + re_snow(i,k,j) = MAX(25.E-6, MIN(re_qs(k), 999.E-6)) + enddo + enddo + endif ! has_reqc, etc... !+---+-----------------------------------------------------------------+ ENDDO @@ -273,6 +315,14 @@ SUBROUTINE wsm52D(t, q & ! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) ! Summer 2003 ! +! further modifications : +! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 +! ==> higher accuracy and efficient at lower resolutions +! reflectivity computation from greg thompson, lim, jun 2011 +! ==> only diagnostic, but with removal of too large drops +! effective radius of hydrometeors, bae from kiaps, jan 2015 +! ==> consistency in solar insolation of rrtmg radiation +! ! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. ! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. ! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. @@ -1762,6 +1812,7 @@ SUBROUTINE wsm5init(den0,denr,dens,cl,cpv,allowed_to_read) ! qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 + pidnc = pi*denr/6. ! syb ! bvtr1 = 1.+bvtr bvtr2 = 2.5+.5*bvtr @@ -1844,5 +1895,102 @@ REAL FUNCTION rgmma(x) endif END FUNCTION rgmma +!----------------------------------------------------------------------- + subroutine effectRad_wsm5 (t, qc, qi, qs, rho, qmin, t0c, & + re_qc, re_qi, re_qs, kts, kte, ii, jj) + +!----------------------------------------------------------------------- +! Compute radiation effective radii of cloud water, ice, and snow for +! single-moment microphysics. +! These are entirely consistent with microphysics assumptions, not +! constant or otherwise ad hoc as is internal to most radiation +! schemes. +! Coded and implemented by Soo ya Bae, KIAPS, January 2015. +!----------------------------------------------------------------------- + + implicit none + +!..Sub arguments + integer, intent(in) :: kts, kte, ii, jj + real, intent(in) :: qmin + real, intent(in) :: t0c + real, dimension( kts:kte ), intent(in):: t + real, dimension( kts:kte ), intent(in):: qc + real, dimension( kts:kte ), intent(in):: qi + real, dimension( kts:kte ), intent(in):: qs + real, dimension( kts:kte ), intent(in):: rho + real, dimension( kts:kte ), intent(inout):: re_qc + real, dimension( kts:kte ), intent(inout):: re_qi + real, dimension( kts:kte ), intent(inout):: re_qs +!..Local variables + integer:: i,k + integer :: inu_c + real, dimension( kts:kte ):: ni + real, dimension( kts:kte ):: rqc + real, dimension( kts:kte ):: rqi + real, dimension( kts:kte ):: rni + real, dimension( kts:kte ):: rqs + real :: temp + real :: lamdac + real :: supcol, n0sfac, lamdas + real :: diai ! diameter of ice in m + logical :: has_qc, has_qi, has_qs +!..Minimum microphys values + real, parameter :: R1 = 1.E-12 + real, parameter :: R2 = 1.E-6 +!..Mass power law relations: mass = am*D**bm + real, parameter :: bm_r = 3.0 + real, parameter :: obmr = 1.0/bm_r + real, parameter :: nc0 = 3.E8 +!----------------------------------------------------------------------- + has_qc = .false. + has_qi = .false. + has_qs = .false. + + do k = kts, kte + ! for cloud + rqc(k) = max(R1, qc(k)*rho(k)) + if (rqc(k).gt.R1) has_qc = .true. + ! for ice + rqi(k) = max(R1, qi(k)*rho(k)) + temp = (rho(k)*max(qi(k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(k) = min(max(5.38e7*temp,1.e3),1.e6) + rni(k)= max(R2, ni(k)*rho(k)) + if (rqi(k).gt.R1 .and. rni(k).gt.R2) has_qi = .true. + ! for snow + rqs(k) = max(R1, qs(k)*rho(k)) + if (rqs(k).gt.R1) has_qs = .true. + enddo + + if (has_qc) then + do k=kts,kte + if (rqc(k).le.R1) CYCLE + lamdac = (pidnc*nc0/rqc(k))**obmr + re_qc(k) = max(2.51E-6,min(1.5*(1.0/lamdac),50.E-6)) + enddo + endif + + if (has_qi) then + do k=kts,kte + if (rqi(k).le.R1 .or. rni(k).le.R2) CYCLE + diai = 11.9*sqrt(rqi(k)/ni(k)) + re_qi(k) = max(10.01E-6,min(0.75*0.163*diai,125.E-6)) + enddo + endif + + if (has_qs) then + do k=kts,kte + if (rqs(k).le.R1) CYCLE + supcol = t0c-t(k) + n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) + lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(k))) + re_qs(k) = max(25.E-6,min(0.5*(1./lamdas), 999.E-6)) + enddo + endif + + end subroutine effectRad_wsm5 +!----------------------------------------------------------------------- + END MODULE module_mp_wsm5 #endif diff --git a/wrfv2_fire/phys/module_mp_wsm6.F b/wrfv2_fire/phys/module_mp_wsm6.F index 447dfa88..6422ee2b 100644 --- a/wrfv2_fire/phys/module_mp_wsm6.F +++ b/wrfv2_fire/phys/module_mp_wsm6.F @@ -14,7 +14,7 @@ MODULE module_mp_wsm6 ! REAL, PARAMETER, PRIVATE :: dtcldcr = 120. ! maximum time step for minor loops REAL, PARAMETER, PRIVATE :: n0r = 8.e6 ! intercept parameter rain - REAL, PARAMETER, PRIVATE :: n0g = 4.e6 ! intercept parameter graupel +! REAL, PARAMETER, PRIVATE :: n0g = 4.e6 ! intercept parameter graupel ! set later with hail_opt REAL, PARAMETER, PRIVATE :: avtr = 841.9 ! a constant for terminal velocity of rain REAL, PARAMETER, PRIVATE :: bvtr = 0.8 ! a constant for terminal velocity of rain REAL, PARAMETER, PRIVATE :: r0 = .8e-5 ! 8 microm in contrast to 10 micro m @@ -23,13 +23,13 @@ MODULE module_mp_wsm6 REAL, PARAMETER, PRIVATE :: xmyu = 1.718e-5 ! the dynamic viscosity kgm-1s-1 REAL, PARAMETER, PRIVATE :: avts = 11.72 ! a constant for terminal velocity of snow REAL, PARAMETER, PRIVATE :: bvts = .41 ! a constant for terminal velocity of snow - REAL, PARAMETER, PRIVATE :: avtg = 330. ! a constant for terminal velocity of graupel - REAL, PARAMETER, PRIVATE :: bvtg = 0.8 ! a constant for terminal velocity of graupel - REAL, PARAMETER, PRIVATE :: deng = 500. ! density of graupel +! REAL, PARAMETER, PRIVATE :: avtg = 330. ! a constant for terminal velocity of graupel ! set later with hail_opt +! REAL, PARAMETER, PRIVATE :: bvtg = 0.8 ! a constant for terminal velocity of graupel ! set later with hail_opt +! REAL, PARAMETER, PRIVATE :: deng = 500. ! density of graupel ! set later with hail_opt REAL, PARAMETER, PRIVATE :: n0smax = 1.e11 ! maximum n0s (t=-90C unlimited) REAL, PARAMETER, PRIVATE :: lamdarmax = 8.e4 ! limited maximum value for slope parameter of rain REAL, PARAMETER, PRIVATE :: lamdasmax = 1.e5 ! limited maximum value for slope parameter of snow - REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel +! REAL, PARAMETER, PRIVATE :: lamdagmax = 6.e4 ! limited maximum value for slope parameter of graupel REAL, PARAMETER, PRIVATE :: dicon = 11.9 ! constant for the cloud-ice diamter REAL, PARAMETER, PRIVATE :: dimax = 500.e-6 ! limited maximum value for the cloud-ice diamter REAL, PARAMETER, PRIVATE :: n0s = 2.e6 ! temperature dependent intercept parameter snow @@ -41,11 +41,13 @@ MODULE module_mp_wsm6 REAL, PARAMETER, PRIVATE :: dens = 100.0 ! Density of snow REAL, PARAMETER, PRIVATE :: qs0 = 6.e-4 ! threshold amount for aggretion to occur REAL, SAVE :: & - qc0, qck1,bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & + qc0, qck1, pidnc, & + bvtr1,bvtr2,bvtr3,bvtr4,g1pbr, & g3pbr,g4pbr,g5pbro2,pvtr,eacrr,pacrr, & bvtr6,g6pbr, & precr1,precr2,roqimax,bvts1, & bvts2,bvts3,bvts4,g1pbs,g3pbs,g4pbs, & + n0g,avtg,bvtg,deng,lamdagmax, & !RAS13.3 - set these in wsm6init g5pbso2,pvts,pacrs,precs1,precs2,pidn0r, & pidn0s,xlv1,pacrc,pi, & bvtg1,bvtg2,bvtg3,bvtg4,g1pbg, & @@ -69,6 +71,8 @@ SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg & ,sr & ,refl_10cm, diagflag, do_radar_ref & ,graupel, graupelncv & + ,has_reqc, has_reqi, has_reqs & ! for radiation + ,re_cloud, re_ice, re_snow & ! for radiation ,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & ,its,ite, jts,jte, kts,kte & @@ -116,7 +120,16 @@ SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg & INTENT(INOUT) :: rain, & rainncv, & sr - +! for radiation connecting + INTEGER, INTENT(IN):: & + has_reqc, & + has_reqi, & + has_reqs + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), & + INTENT(INOUT):: & + re_cloud, & + re_ice, & + re_snow !+---+-----------------------------------------------------------------+ REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT):: & ! GT refl_10cm @@ -139,6 +152,11 @@ SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg & LOGICAL, OPTIONAL, INTENT(IN) :: diagflag INTEGER, OPTIONAL, INTENT(IN) :: do_radar_ref !+---+-----------------------------------------------------------------+ +! to calculate effective radius for radiation + REAL, DIMENSION( kts:kte ) :: den1d + REAL, DIMENSION( kts:kte ) :: qc1d + REAL, DIMENSION( kts:kte ) :: qi1d + REAL, DIMENSION( kts:kte ) :: re_qc, re_qi, re_qs DO j=jts,jte DO k=kts,kte @@ -200,6 +218,30 @@ SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg & ENDDO endif ENDIF + + if (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) then + do i=its,ite + do k=kts,kte + re_qc(k) = 2.51E-6 + re_qi(k) = 10.01E-6 + re_qs(k) = 25.E-6 + + t1d(k) = th(i,k,j)*pii(i,k,j) + den1d(k)= den(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qs1d(k) = qs(i,k,j) + enddo + call effectRad_wsm6(t1d, qc1d, qi1d, qs1d, den1d, & + qmin, t0c, re_qc, re_qi, re_qs, & + kts, kte, i, j) + do k=kts,kte + re_cloud(i,k,j) = MAX(2.51E-6, MIN(re_qc(k), 50.E-6)) + re_ice(i,k,j) = MAX(10.01E-6, MIN(re_qi(k), 125.E-6)) + re_snow(i,k,j) = MAX(25.E-6, MIN(re_qs(k), 999.E-6)) + enddo + enddo + endif ! has_reqc, etc... !+---+-----------------------------------------------------------------+ ENDDO @@ -242,8 +284,15 @@ SUBROUTINE wsm62D(t, q & ! Implemented by Song-You Hong (Yonsei Univ.) and Jimy Dudhia (NCAR) ! Summer 2004 ! -! History : semi-lagrangian scheme sedimentation(JH), and clean up -! Hong, August 2009 +! further modifications : +! semi-lagrangian sedimentation (JH,2010),hong, aug 2009 +! ==> higher accuracy and efficient at lower resolutions +! reflectivity computation from greg thompson, lim, jun 2011 +! ==> only diagnostic, but with removal of too large drops +! add hail option from afwa, aug 2014 +! ==> switch graupel or hail by changing no, den, fall vel. +! effective radius of hydrometeors, bae from kiaps, jan 2015 +! ==> consistency in solar insolation of rrtmg radiation ! ! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. ! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. @@ -1454,19 +1503,37 @@ REAL FUNCTION fpvs(t,ice,rd,rv,cvap,cliq,cice,hvap,hsub,psat,t0c) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - END FUNCTION fpvs !------------------------------------------------------------------- - SUBROUTINE wsm6init(den0,denr,dens,cl,cpv,allowed_to_read) + SUBROUTINE wsm6init(den0,denr,dens,cl,cpv,hail_opt,allowed_to_read) !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- !.... constants which may not be tunable REAL, INTENT(IN) :: den0,denr,dens,cl,cpv + INTEGER, INTENT(IN) :: hail_opt ! RAS LOGICAL, INTENT(IN) :: allowed_to_read + +! RAS13.1 define graupel parameters as graupel-like or hail-like, +! depending on namelist option + IF (hail_opt .eq. 1) THEN !Hail! + n0g = 4.e4 + deng = 700. + avtg = 285.0 + bvtg = 0.8 + lamdagmax = 2.e4 + ELSE !Graupel! + n0g = 4.e6 + deng = 500 + avtg = 330.0 + bvtg = 0.8 + lamdagmax = 6.e4 + ENDIF ! pi = 4.*atan(1.) xlv1 = cl-cpv ! qc0 = 4./3.*pi*denr*r0**3*xncr/den0 ! 0.419e-3 -- .61e-3 qck1 = .104*9.8*peaut/(xncr*denr)**(1./3.)/xmyu*den0**(4./3.) ! 7.03 + pidnc = pi*denr/6. ! syb ! bvtr1 = 1.+bvtr bvtr2 = 2.5+.5*bvtr @@ -2450,4 +2517,101 @@ subroutine refl10cm_wsm6 (qv1d, qr1d, qs1d, qg1d, & end subroutine refl10cm_wsm6 !+---+-----------------------------------------------------------------+ +!----------------------------------------------------------------------- + subroutine effectRad_wsm6 (t, qc, qi, qs, rho, qmin, t0c, & + re_qc, re_qi, re_qs, kts, kte, ii, jj) + +!----------------------------------------------------------------------- +! Compute radiation effective radii of cloud water, ice, and snow for +! single-moment microphysics. +! These are entirely consistent with microphysics assumptions, not +! constant or otherwise ad hoc as is internal to most radiation +! schemes. +! Coded and implemented by Soo ya Bae, KIAPS, January 2015. +!----------------------------------------------------------------------- + + implicit none + +!..Sub arguments + integer, intent(in) :: kts, kte, ii, jj + real, intent(in) :: qmin + real, intent(in) :: t0c + real, dimension( kts:kte ), intent(in):: t + real, dimension( kts:kte ), intent(in):: qc + real, dimension( kts:kte ), intent(in):: qi + real, dimension( kts:kte ), intent(in):: qs + real, dimension( kts:kte ), intent(in):: rho + real, dimension( kts:kte ), intent(inout):: re_qc + real, dimension( kts:kte ), intent(inout):: re_qi + real, dimension( kts:kte ), intent(inout):: re_qs +!..Local variables + integer:: i,k + integer :: inu_c + real, dimension( kts:kte ):: ni + real, dimension( kts:kte ):: rqc + real, dimension( kts:kte ):: rqi + real, dimension( kts:kte ):: rni + real, dimension( kts:kte ):: rqs + real :: temp + real :: lamdac + real :: supcol, n0sfac, lamdas + real :: diai ! diameter of ice in m + logical :: has_qc, has_qi, has_qs +!..Minimum microphys values + real, parameter :: R1 = 1.E-12 + real, parameter :: R2 = 1.E-6 +!..Mass power law relations: mass = am*D**bm + real, parameter :: bm_r = 3.0 + real, parameter :: obmr = 1.0/bm_r + real, parameter :: nc0 = 3.E8 +!----------------------------------------------------------------------- + has_qc = .false. + has_qi = .false. + has_qs = .false. + + do k = kts, kte + ! for cloud + rqc(k) = max(R1, qc(k)*rho(k)) + if (rqc(k).gt.R1) has_qc = .true. + ! for ice + rqi(k) = max(R1, qi(k)*rho(k)) + temp = (rho(k)*max(qi(k),qmin)) + temp = sqrt(sqrt(temp*temp*temp)) + ni(k) = min(max(5.38e7*temp,1.e3),1.e6) + rni(k)= max(R2, ni(k)*rho(k)) + if (rqi(k).gt.R1 .and. rni(k).gt.R2) has_qi = .true. + ! for snow + rqs(k) = max(R1, qs(k)*rho(k)) + if (rqs(k).gt.R1) has_qs = .true. + enddo + + if (has_qc) then + do k=kts,kte + if (rqc(k).le.R1) CYCLE + lamdac = (pidnc*nc0/rqc(k))**obmr + re_qc(k) = max(2.51E-6,min(1.5*(1.0/lamdac),50.E-6)) + enddo + endif + + if (has_qi) then + do k=kts,kte + if (rqi(k).le.R1 .or. rni(k).le.R2) CYCLE + diai = 11.9*sqrt(rqi(k)/ni(k)) + re_qi(k) = max(10.01E-6,min(0.75*0.163*diai,125.E-6)) + enddo + endif + + if (has_qs) then + do k=kts,kte + if (rqs(k).le.R1) CYCLE + supcol = t0c-t(k) + n0sfac = max(min(exp(alpha*supcol),n0smax/n0s),1.) + lamdas = sqrt(sqrt(pidn0s*n0sfac/rqs(k))) + re_qs(k) = max(25.E-6,min(0.5*(1./lamdas), 999.E-6)) + enddo + endif + + end subroutine effectRad_wsm6 +!----------------------------------------------------------------------- + END MODULE module_mp_wsm6 diff --git a/wrfv2_fire/phys/module_pbl_driver.F b/wrfv2_fire/phys/module_pbl_driver.F index 3c4bcd60..86052ef2 100644 --- a/wrfv2_fire/phys/module_pbl_driver.F +++ b/wrfv2_fire/phys/module_pbl_driver.F @@ -22,12 +22,14 @@ SUBROUTINE pbl_driver( & ,thz0,qz0,uz0,vz0,qsfc,f & ,lowlyr,u10,v10,uoce,voce,t2 & ,psim,psih,fm,fhh,gz1oz0, wspd,br,chklowq & - ,bl_pbl_physics, ra_lw_physics, dx & + ,bl_pbl_physics, ra_lw_physics, dx, dy & ,stepbl,warm_rain & ,kpbl,mixht,ct,lh,snow,xice & ,znu, znw, mut, p_top & ! paj ,ctopo,ctopo2,windfarm_opt,power & + ,ysu_topdown_pblmix & + ,shinhong_tke_diag & ! OPTIONAL for TEMF scheme ,te_temf,km_temf,kh_temf & ,shf_temf,qf_temf,uw_temf,vw_temf & @@ -114,16 +116,16 @@ SUBROUTINE pbl_driver( & YSUSCHEME,MRFSCHEME,GFSSCHEME,MYJPBLSCHEME,ACMPBLSCHEME,& QNSEPBLSCHEME,MYNNPBLSCHEME2,MYNNPBLSCHEME3,BOULACSCHEME,& CAMUWPBLSCHEME,BEPSCHEME,BEP_BEMSCHEME,MYJSFCSCHEME, & - FITCHSCHEME, & - TEMFPBLSCHEME,QNSEPBL09SCHEME,GBMPBLSCHEME, & + FITCHSCHEME,SHINHONGSCHEME, & + TEMFPBLSCHEME,GBMPBLSCHEME, & CAMMGMPSCHEME,p_qi,p_qni,p_qnc,param_first_scalar !CAMMGMPSCHEME, p_qni,p_qnc is used for camuwpbl scheme #else USE module_state_description, ONLY : & YSUSCHEME,MRFSCHEME,GFSSCHEME,MYJPBLSCHEME,ACMPBLSCHEME & , QNSEPBLSCHEME, p_qi,param_first_scalar & - , TEMFPBLSCHEME, GFS2011SCHEME,QNSEPBL09SCHEME & + , TEMFPBLSCHEME, GFS2011SCHEME & , CAMUWPBLSCHEME & - , FITCHSCHEME & + , FITCHSCHEME, SHINHONGSCHEME & , GBMPBLSCHEME, MYJSFCSCHEME #endif @@ -133,8 +135,8 @@ SUBROUTINE pbl_driver( & USE module_bl_myjpbl USE module_bl_qnsepbl - USE module_bl_qnsepbl09 USE module_bl_ysu + USE module_bl_shinhong USE module_bl_mrf USE module_bl_gfs USE module_bl_gfs2011, only: bl_gfs2011 @@ -158,13 +160,13 @@ SUBROUTINE pbl_driver( & ! 1. ysupbl ! 2. myjpbl ! 4. qnsepbl - ! 94. qnsepbl09 (old version) ! 5. mynnpbl2 ! 6. mynnpbl3 ! 7. acmpbl ! 8. boulacpbl ! 9. camuwpbl ! 10. temfpbl + ! 11. shinhongpbl ! 99. mrfpbl ! 12. gbmpbl ! @@ -347,6 +349,8 @@ SUBROUTINE pbl_driver( & INTEGER, INTENT(IN ) :: bl_pbl_physics, ra_lw_physics,sf_sfclay_physics,sf_urban_physics,windfarm_opt + INTEGER, INTENT(IN ) :: ysu_topdown_pblmix + INTEGER, OPTIONAL, INTENT(IN ) :: shinhong_tke_diag INTEGER, OPTIONAL, INTENT(IN ) :: scalar_pblmix, tracer_pblmix INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & @@ -384,7 +388,7 @@ SUBROUTINE pbl_driver( & OPTIONAL, INTENT(IN ) :: znu, & znw ! - REAL, INTENT(IN ) :: DT,DX + REAL, INTENT(IN ) :: DT,DX,DY REAL, INTENT(IN ),OPTIONAL :: bldt REAL, INTENT(IN ),OPTIONAL :: curr_secs LOGICAL, INTENT(IN ),OPTIONAL :: adapt_step_flag @@ -1101,13 +1105,14 @@ SUBROUTINE pbl_driver( & ,U10=u10,V10=v10 & ,UOCE=uoce,VOCE=voce & ! paj - ,CTOPO=ctopo,CTOPO2=ctopo2 & -! + ,CTOPO=ctopo,CTOPO2=ctopo2 & + ,YSU_TOPDOWN_PBLMIX=ysu_topdown_pblmix & ,WSPD=wspd,BR=br,DT=dtbl,KPBL2D=kpbl & ,EP1=ep_1,EP2=ep_2,KARMAN=karman & ,EXCH_H=exch_h,REGIME=regime & + ,RTHRATEN=RTHRATEN & ! for grims shallow convection with ysupbl - ,WSTAR=wstar,DELTA=delta & + ,WSTAR=wstar,DELTA=delta & ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & @@ -1133,6 +1138,64 @@ SUBROUTINE pbl_driver( & CALL wrf_error_fatal('Lack arguments to call YSU pbl') ENDIF + CASE (SHINHONGSCHEME) + CALL wrf_debug(100,'in SHINHONG PBL') + IF ( PRESENT( qv_curr ) .AND. PRESENT( qc_curr ) .AND. & + PRESENT( qi_curr ) .AND. & + PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. & + PRESENT( rqiblten ) .AND. & + PRESENT( hol ) ) THEN +! + CALL shinhong( & + U3D=u_phytmp,V3D=v_phytmp,TH3D=th_phy,T3D=t_phy & + ,QV3D=qv_curr,QC3D=qc_curr,QI3D=qi_curr & + ,P3D=p_phy,P3DI=p8w,PI3D=pi_phy & + ,RUBLTEN=rublten,RVBLTEN=rvblten & + ,RTHBLTEN=rthblten,RQVBLTEN=rqvblten & + ,RQCBLTEN=rqcblten,RQIBLTEN=rqiblten & + ,FLAG_QI=flag_qi & + ,CP=cp,G=g,ROVCP=rcp,RD=r_D,ROVG=rovg & + ,DZ8W=dz8w,XLV=XLV,RV=r_v,PSFC=PSFC & + ,ZNU=znu,ZNW=znw,MUT=mut,P_TOP=p_top & + ,ZNT=znt,UST=ust,HPBL=pblh & + ,PSIM=fm,PSIH=fhh,XLAND=xland & + ,HFX=hfx,QFX=qfx & + ,U10=u10,V10=v10 & +! paj + ,CTOPO=ctopo,CTOPO2=ctopo2 & + ,SHINHONG_TKE_DIAG=shinhong_tke_diag & + ,WSPD=wspd,BR=br,DT=dtbl,KPBL2D=kpbl & + ,EP1=ep_1,EP2=ep_2,KARMAN=karman & + ,EXCH_H=exch_h,REGIME=regime & +! for grims shallow convection with shinhongpbl + ,WSTAR=wstar,DELTA=delta & + ,TKE_PBL=tke_pbl,EL_PBL=el_pbl,CORF=f & + ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & + ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & + ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & + ,DX=dx,DY=dy & + ) + ELSE + WRITE ( message , FMT = '(A,7(L1,1X))' ) & + 'present: '// & + 'qv_curr, '// & + 'qc_curr, '// & + 'qi_curr, '// & + 'rqvblten, '// & + 'rqcblten, '// & + 'rqiblten, '// & + 'hol = ' , & + PRESENT( qv_curr ) , & + PRESENT( qc_curr ) , & + PRESENT( qi_curr ) , & + PRESENT( rqvblten ) , & + PRESENT( rqcblten ) , & + PRESENT( rqiblten ) , & + PRESENT( hol ) + CALL wrf_debug(0,message) + CALL wrf_error_fatal('Lack arguments to call SHINHONG pbl') + ENDIF + CASE (MRFSCHEME) IF ( PRESENT( qv_curr ) .AND. PRESENT( qc_curr ) .AND. & PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. & @@ -1423,44 +1486,6 @@ SUBROUTINE pbl_driver( & CALL wrf_error_fatal('Lack arguments to call QNSE pbl') ENDIF - CASE (QNSEPBL09SCHEME) - IF ( PRESENT( qv_curr ) .AND. PRESENT( qc_curr ) .AND. & - PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. & - .TRUE. ) THEN - CALL wrf_debug(100,'in QNSEPBL09') - CALL qnsepbl09( & - DT=dt,STEPBL=stepbl,HT=ht,DZ=dz8w & - ,PMID=p_phy,PINT=p8w,TH=th_phy,T=t_phy,EXNER=pi_phy & - ,QV=qv_curr, CWM=qc_curr & - ,U=u_phy,V=v_phy,RHO=rho & - ,TSK=tsk,QSFC=qsfc,CHKLOWQ=chklowq,THZ0=thz0 & - ,QZ0=qz0,UZ0=uz0,VZ0=vz0,CORF=f & - ,LOWLYR=lowlyr & - ,XLAND=xland,SICE=xice,SNOW=snow & - ,TKE=tke_pbl,EXCH_H=exch_h,EXCH_M=exch_m,USTAR=ust,ZNT=znt & - ,EL_MYJ=el_pbl,PBLH=pblh,KPBL=kpbl,CT=ct & - ,AKHS=akhs,AKMS=akms,ELFLX=lh & - ,RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten & - ,RQVBLTEN=rqvblten,RQCBLTEN=rqcblten & - ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & - ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & - ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & - ) - ELSE - WRITE ( message , FMT = '(A,4(L1,1X))' ) & - 'present: '// & - 'qv_curr, '// & - 'qc_curr, '// & - 'rqvblten, '// & - 'rqcblten = ' , & - PRESENT( qv_curr ) , & - PRESENT( qc_curr ) , & - PRESENT( rqvblten ) , & - PRESENT( rqcblten ) - CALL wrf_debug(0,message) - CALL wrf_error_fatal('Lack arguments to call old QNSE pbl') - ENDIF - CASE (ACMPBLSCHEME) !! These are values that are not supplied to pbl driver, but are required by ACM diff --git a/wrfv2_fire/phys/module_physics_addtendc.F b/wrfv2_fire/phys/module_physics_addtendc.F index 3c38d382..ef36494e 100644 --- a/wrfv2_fire/phys/module_physics_addtendc.F +++ b/wrfv2_fire/phys/module_physics_addtendc.F @@ -309,6 +309,61 @@ SUBROUTINE phy_bl_ten(config_flags,rk_step,n_moist,n_scalar, & its, ite, jts, jte, kts, kte ) ENDIF + CASE (SHINHONGSCHEME) + + CALL add_a2a(rt_tendf,RTHBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2c_u(ru_tendf,RUBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + CALL add_a2c_v(rv_tendf,RVBLTEN,config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QV .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QV),RQVBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QC .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QC),RQCBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QI .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(moist_tendf(ims,kms,jms,P_QI),RQIBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + IF(.not. adv_moist_cond)THEN + + if (P_QT .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQCBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + if (P_QT .ge. PARAM_FIRST_SCALAR) & + CALL add_a2a(scalar_tendf(ims,kms,jms,P_QT),RQIBLTEN, & + config_flags, & + ids,ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF + CASE (MRFSCHEME) CALL add_a2a(rt_tendf,RTHBLTEN,config_flags, & @@ -520,7 +575,7 @@ SUBROUTINE phy_bl_ten(config_flags,rk_step,n_moist,n_scalar, & ENDIF - CASE (QNSEPBLSCHEME,QNSEPBL09SCHEME) + CASE (QNSEPBLSCHEME) CALL add_a2a(rt_tendf,RTHBLTEN,config_flags, & ids,ide, jds, jde, kds, kde, & @@ -1041,7 +1096,7 @@ SUBROUTINE phy_cu_ten(config_flags,rk_step,n_moist,n_scalar, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CASE (KFETASCHEME) + CASE (KFETASCHEME, MSKFSCHEME, KFCUPSCHEME)!BSINGH - Added KFCUPSCHEME for CuP CALL add_a2a(rt_tendf,RTHCUTEN,config_flags, & ids,ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -1327,7 +1382,7 @@ SUBROUTINE phy_cu_ten(config_flags,rk_step,n_moist,n_scalar, & ENDIF - CASE (TIEDTKESCHEME) + CASE (TIEDTKESCHEME, NTIEDTKESCHEME) CALL add_a2a(rt_tendf,RTHCUTEN,config_flags, & ids,ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -1714,6 +1769,7 @@ END SUBROUTINE phy_fr_ten !---------------------------------------------------------------------- SUBROUTINE advance_ppt(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + CLDFRA_CUP, & ! add LD 01/11/2012 !BSINGH - Added for CuP RQICUTEN,RQSCUTEN, & RAINC,RAINCV,RAINSH,PRATEC,PRATESH, & NCA, HTOP,HBOT,CUTOP,CUBOT, & @@ -1742,7 +1798,8 @@ SUBROUTINE advance_ppt(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & RQCCUTEN, & RQRCUTEN, & RQICUTEN, & - RQSCUTEN + RQSCUTEN, & + CLDFRA_CUP ! add LD 01/11/2012 !BSINGH - For CuP REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: RAINC, & @@ -1845,7 +1902,7 @@ SUBROUTINE advance_ppt(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & ENDDO ENDDO - CASE (KFETASCHEME) + CASE (KFETASCHEME, MSKFSCHEME, KFCUPSCHEME)!BSINGH - added KFCUPSCHEME for CuP DO J = j_start,j_end DO i = i_start,i_end @@ -1862,7 +1919,6 @@ SUBROUTINE advance_ppt(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & IF ( NCA(I,J) .GT. 0 ) THEN - IF ( NINT(NCA(I,J) / DT) .LE. 1 ) THEN ! set tendency to zero @@ -1886,6 +1942,20 @@ SUBROUTINE advance_ppt(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & ENDDO ENDDO + IF ( config_flags%cu_physics == kfcupscheme ) THEN + DO J = j_start,j_end + DO i = i_start,i_end + IF ( NCA(I,J) .GT. 0 ) THEN + IF ( NINT(NCA(I,J) / DT) .LE. 1 ) THEN + DO k = k_start,k_end + CLDFRA_CUP(i,k,j)=0. ! By LKB 12/22/11 01/11/2012 !BSINGH - For CuP + ENDDO + ENDIF + ENDIF + ENDDO + ENDDO + ENDIF + CASE DEFAULT END SELECT diff --git a/wrfv2_fire/phys/module_physics_init.F b/wrfv2_fire/phys/module_physics_init.F index e8712227..7d1b1c70 100644 --- a/wrfv2_fire/phys/module_physics_init.F +++ b/wrfv2_fire/phys/module_physics_init.F @@ -35,10 +35,17 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & RUBLTEN,RVBLTEN,RTHBLTEN, & RQVBLTEN,RQCBLTEN,RQIBLTEN, & RTHRATEN,RTHRATENLW,RTHRATENSW, & +#if ( EM_CORE == 1 ) + !BSINGH - For WRFCuP scheme(11/12/2013) + cupflag,cldfra_cup,cldfratend_cup, & !wig, 18-Sep-2006 + shall, & !wig, 18-Sep-2006 + tcloud_cup, & !rce, 18-apr-2012 + !BSINGH - ENDS +#endif STEPBL,STEPRA,STEPCU, & W0AVG, RAINNC, RAINC, RAINCV, RAINNCV, & SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV, & - z_at_q, qnwfa2d, scalar, num_sc, & ! G. Thompson + z_at_q, qnwfa2d, scalar, num_sc, & ! G. Thompson re_cloud, re_ice, re_snow, & ! G. Thompson has_reqc, has_reqi, has_reqs, & ! G. Thompson NCA,swrad_scat, & @@ -91,7 +98,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & CHXY, FWETXY, SNEQVOXY, ALBOLDXY, QSNOWXY, & ! Optional Noah-MP WSLAKEXY, ZWTXY, WAXY, WTXY, LFMASSXY, RTMASSXY, & ! Optional Noah-MP STMASSXY, WOODXY, STBLCPXY, FASTCPXY, & ! Optional Noah-MP - XSAIXY, & ! Optional Noah-MP + XSAIXY, LAI, & ! Optional Noah-MP T2MVXY, T2MBXY, CHSTARXY , & ! Optional Noah-MP SMOISEQ ,SMCWTDXY ,RECHXY, DEEPRECHXY, AREAXY, & ! Optional Noah-MP WTDDT , STEPWTD ,QRFSXY ,QSPRINGSXY ,QSLATXY, & ! Optional Noah-MP @@ -106,6 +113,10 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & TRL_URB3D, TBL_URB3D, TGL_URB3D, & !Optional urban SH_URB2D, LH_URB2D, G_URB2D, RN_URB2D, & !Optional urban TS_URB2D, FRC_URB2D, UTYPE_URB2D, & !Optional urban + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !Optional urban + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !Optional urban + FLXHUMR_URB2D,FLXHUMB_URB2D, & !Optional urban + FLXHUMG_URB2D, & !Optional urban TRB_URB4D,TW1_URB4D,TW2_URB4D, & !Optional multi-layer urban TGB_URB4D,TLEV_URB3D,QLEV_URB3D, & !Optional multi-layer urban TW1LEV_URB3D,TW2LEV_URB3D, & !Optional multi-layer urban @@ -191,6 +202,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & ,massflux_EDKF, entr_EDKF, detr_EDKF & ! Optional for qnse ,thl_up, thv_up, rt_up & ! Optional for qnse ,rv_up, rc_up, u_up, v_up, frac_up & ! Optional for qnse + ,ccn_conc & ! RAS ,QKE & !for MYNN ,landusef,landusef2,mosaic_cat_index & ! danli mosaic ,TSK_mosaic,TSLB_mosaic,SMOIS_mosaic,SH2O_mosaic & ! danli mosaic @@ -211,7 +223,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & USE module_domain USE module_wrf_error use module_sf_lake, only : nlevsoil,nlevsnow,nlevlake -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_cam_support, ONLY : cam_mam_aerosols #endif USE module_wind_fitch @@ -292,6 +304,14 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & INTENT(INOUT) :: IVGTYP, & ISLTYP + INTEGER :: HAIL_OPT +#if ( EM_CORE == 1 ) + !BSINGH - For WRFCuP scheme + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: shall, & !CuP, wig 18-Sep-2006 + tcloud_cup !CuP, rce 18-apr-2012 + !BSINGH - ENDS +#endif ! rad !..Added by G. Thompson to couple cloud physics variables with RRTMG radiation. @@ -325,6 +345,15 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & RQSCUTEN, RQICUTEN, & RUSHTEN, RVSHTEN, RTHSHTEN, RQVSHTEN, RQRSHTEN, RQCSHTEN, & RQSSHTEN, RQISHTEN, RQGSHTEN +#if ( EM_CORE == 1 ) + !BSINGH - For WRFCuP scheme + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: & + cldfra_cup,cldfratend_cup !CuP, wig 18-Sep-2006 + + LOGICAL, DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) :: cupflag !CuP, wig 9-Oct-2006 + !BSINGH -ENDS +#endif + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT), OPTIONAL :: RQCNCUTEN, RQINCUTEN REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG @@ -339,8 +368,8 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) :: & RAINNC, RAINC, RAINCV, RAINNCV, & SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV - REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: z_at_q ! G. Thompson - REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: qnwfa2d ! G. Thompson + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: z_at_q ! G. Thompson + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: qnwfa2d ! G. Thompson INTEGER, INTENT(IN) :: num_sc ! G. Thompson REAL, DIMENSION(ims:ime,kms:kme,jms:jme,num_sc), INTENT(INOUT) :: scalar ! G. Thompson @@ -425,6 +454,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: STBLCPXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: FASTCPXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: XSAIXY + REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: LAI REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: T2MVXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: T2MBXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: CHSTARXY @@ -450,6 +480,8 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY REAL, DIMENSION(:), INTENT(INOUT) :: mp_restart_state,tbpvs_state,tbpvs0_state LOGICAL, INTENT(IN) :: allowed_to_read, moved + REAL, INTENT(INOUT) :: ccn_conc ! RAS + ! ocean mixed layer REAL, DIMENSION( ims:ime , jms:jme ) , OPTIONAL, INTENT(INOUT) :: & @@ -483,12 +515,23 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D !urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D !urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D + ! REAL, DIMENSION(ims:ime, 1:num_roof_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D !urban ! REAL, DIMENSION(ims:ime, 1:num_wall_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D !urban ! REAL, DIMENSION(ims:ime, 1:num_road_layers, jms:jme), INTENT(INOUT) :: TGL_URB3D !urban REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D !urban REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D !urban REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TGL_URB3D !urban + REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TGRL_URB3D !urban + REAL, OPTIONAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: SMR_URB3D !urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D !urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D !urban @@ -624,6 +667,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & nssl_rho_qh, nssl_rho_qhl, & nssl_rho_qs + ! WA 12/21/09 REAL,OPTIONAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & INTENT(OUT) :: te_temf, cf3d_temf @@ -649,6 +693,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & LOGICAL :: usemonalb LOGICAL :: rdmaxalb INTEGER :: mfshconv + INTEGER :: icloud_cu INTEGER :: iopt_run INTEGER :: i, j, k, itf, jtf, ktf, n @@ -709,13 +754,22 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & !..Added G. Thompson to determine if we will compute and pass radiative !.. effective radii of cloud water, ice, and snow. Currently ONLY properly !.. connected if using Physics options Thompson-MP and RRTMG-LW/SW. +! 10/2014: T. Mansell added support for NSSL_2MOM options has_reqc = 0 has_reqi = 0 has_reqs = 0 - if (config_flags%ra_lw_physics .eq. RRTMG_LWSCHEME .and. & - config_flags%ra_sw_physics .eq. RRTMG_SWSCHEME .and. & + if ((config_flags%ra_lw_physics .eq. RRTMG_LWSCHEME .or. config_flags%ra_lw_physics .eq. RRTMG_LWSCHEME_FAST) .and. & + (config_flags%ra_sw_physics .eq. RRTMG_SWSCHEME .or. config_flags%ra_sw_physics .eq. RRTMG_SWSCHEME_FAST) .and. & (config_flags%mp_physics .eq. THOMPSON .or. & - config_flags%mp_physics .eq. THOMPSONAERO) ) then + config_flags%mp_physics .eq. THOMPSONAERO & + .or. config_flags%mp_physics .eq. NSSL_2MOM .or. & + config_flags%mp_physics .eq. NSSL_2MOMG .or. & + config_flags%mp_physics .eq. NSSL_2MOMCCN .or. & + config_flags%mp_physics .eq. WSM3SCHEME .or. & ! syb+ + config_flags%mp_physics .eq. WSM5SCHEME .or. & ! syb+ + config_flags%mp_physics .eq. WSM6SCHEME .or. & ! syb+ + config_flags%mp_physics .eq. WDM5SCHEME .or. & ! syb+ + config_flags%mp_physics .eq. WDM6SCHEME ) ) then ! syb+ has_reqc = 1 has_reqi = 1 has_reqs = 1 @@ -755,7 +809,24 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & !-- temporary fix by ww landuse_ISICE = isice -! +!..Determine which cu_rad_feedback option to use + + icloud_cu = 0 + IF ( config_flags%cu_rad_feedback ) THEN + IF ( config_flags%cu_physics == kfetascheme ) THEN + icloud_cu = 2 + ELSE IF ( config_flags%cu_physics == gfscheme .OR. & + config_flags%cu_physics == g3scheme .OR. & + config_flags%cu_physics == gdscheme ) THEN + icloud_cu = 1 + END IF + END IF +#if (EM_CORE == 1) + IF ( config_flags%cu_physics == mskfscheme ) THEN + icloud_cu = 2 + END IF +#endif + CALL nl_set_icloud_cu ( id , icloud_cu ) IF(.not.restart)THEN !-- initialize common variables @@ -769,7 +840,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & IF ( .NOT. moved ) THEN DO j=jts,jtf DO i=its,itf - XLAND(i,j)=1. + XLAND(i,j)=float(config_flags%ideal_xland) GSW(i,j)=0. GLW(i,j)=0. !-- initialize ust to a small value @@ -867,19 +938,6 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & end do end do -!..Determine which cu_rad_feedback option to use - - config_flags%icloud_cu = 0 - IF ( config_flags%cu_rad_feedback ) THEN - IF ( config_flags%cu_physics == kfetascheme ) THEN - config_flags%icloud_cu = 2 - ELSE IF ( config_flags%cu_physics == gfscheme .OR. & - config_flags%cu_physics == g3scheme .OR. & - config_flags%cu_physics == gdscheme ) THEN - config_flags%icloud_cu = 1 - END IF - END IF - !..Fill initial starting values of radiative effective radii for !.. cloud water (2.51 microns), cloud ice (5.01 microns), and !.. snow (10.01 microns). @@ -946,7 +1004,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & if(config_flags%mp_physics == CAMMGMPSCHEME) is_CAMMGMP_used = .TRUE. # endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !BSINGH:02/01/2013 - For WRF_CHEM simulations, initialize cam_mam_aerosols variable cam_mam_aerosols = .FALSE. if(config_flags%chem_opt == CBMZ_CAM_MAM3_NOAQ .OR. config_flags%chem_opt == CBMZ_CAM_MAM3_AQ & @@ -960,7 +1018,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & # if (EM_CORE == 1) .OR. config_flags%mp_physics == CAMMGMPSCHEME & # endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !For WRF_CHEM simulations, first five constituents are added in CAM_INIT and rest are added in the MODULE_CAM_MAM_INIT in chem/ .OR. config_flags%chem_opt == CBMZ_CAM_MAM3_NOAQ .OR. config_flags%chem_opt == CBMZ_CAM_MAM3_AQ & .OR. config_flags%chem_opt == CBMZ_CAM_MAM7_NOAQ .OR. config_flags%chem_opt == CBMZ_CAM_MAM7_AQ & @@ -1031,7 +1089,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & CHXY, FWETXY, SNEQVOXY, ALBOLDXY, QSNOWXY, & WSLAKEXY, ZWTXY, WAXY, WTXY, LFMASSXY, RTMASSXY,& STMASSXY, WOODXY, STBLCPXY, FASTCPXY, & - XSAIXY, & + XSAIXY, LAI, & SMOISEQ, SMCWTDXY, RECHXY, DEEPRECHXY, AREAXY, & WTDDT, STEPWTD, QRFSXY ,QSPRINGSXY ,QSLATXY, & FDEPTHXY, RIVERBEDXY, EQZWT, RIVERCONDXY, PEXPXY, & @@ -1058,6 +1116,9 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & SH_URB2D, LH_URB2D, G_URB2D, RN_URB2D, & !Optional urban TS_URB2D, FRC_URB2D, UTYPE_URB2D, & SF_URBAN_PHYSICS, & !Optional urban + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !Optional urban + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !Optional urban + FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !Optional urban NUM_URBAN_LAYERS, & !Optional multi-layer urban NUM_URBAN_HI, & !Optional multi-layer urban TRB_URB4D,TW1_URB4D,TW2_URB4D, & !Optional multi-layer urban @@ -1083,7 +1144,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & oml_hml0, sf_ocean_physics, & !Optional oml TML,T0ML,HML,H0ML,HUML,HVML,TMOML, & !Optional oml is_CAMMGMP_used & - ,TSK_SAVE & !Optional oml + ,TSK_SAVE & !Optional fractional seaice ! CLM vraiables ,numc,nump,snl, & snowdp,wtc,wtp,h2osno,t_grnd,t_veg, & @@ -1142,6 +1203,13 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & NCA,RAINC,RAINCV,W0AVG,config_flags,restart, & CLDEFI,LOWLYR,MASS_FLUX, & RTHFTEN, RQVFTEN, & +#if ( EM_CORE == 1 ) + !BSINGH - For WRFCuP Scheme + cupflag,cldfra_cup,cldfratend_cup, & !CuP, wig 18-Sep-2006 + shall, & !CuP, wig 18-Sep-2006 + tcloud_cup, & !CuP, rce 18-apr-2012 + !BSINGH -ENDS +#endif APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & APR_CAPMA,APR_CAPME,APR_CAPMI, & cugd_tten,cugd_ttens,cugd_qvten, & @@ -1178,6 +1246,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & nssl_cnor, nssl_cnos, & nssl_rho_qh, nssl_rho_qhl, & nssl_rho_qs, & + ccn_conc, & ! RAS z_at_q, qnwfa2d, scalar, num_sc, & ! G. Thompson ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -1557,6 +1626,8 @@ SUBROUTINE ra_init(id,STEPRA,RADT,DT,RTHRATEN,RTHRATENLW, & USE module_ra_rrtm , ONLY : rrtminit USE module_ra_rrtmg_lw , ONLY : rrtmg_lwinit USE module_ra_rrtmg_sw , ONLY : rrtmg_swinit + USE module_ra_rrtmg_lwf , ONLY : rrtmg_lwinit_fast + USE module_ra_rrtmg_swf , ONLY : rrtmg_swinit_fast USE module_ra_cam , ONLY : camradinit USE module_ra_cam_support , ONLY : oznini USE module_ra_sw , ONLY : swinit @@ -1751,6 +1822,16 @@ SUBROUTINE ra_init(id,STEPRA,RADT,DT,RTHRATEN,RTHRATENLW, & aclwalloc = .true. + CASE (RRTMG_LWSCHEME_FAST) + CALL rrtmg_lwinit_fast( & + p_top, allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + aclwalloc = .true. + + CASE (GFDLLWSCHEME) CALL nl_get_start_month(id,month) CALL nl_get_start_day(id,iday) @@ -1834,6 +1915,16 @@ SUBROUTINE ra_init(id,STEPRA,RADT,DT,RTHRATEN,RTHRATENLW, & acswalloc = .true. + CASE (RRTMG_SWSCHEME_FAST) + CALL rrtmg_swinit_fast( & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + acswalloc = .true. + + CASE (GFDLSWSCHEME) IF(.not.etalw)THEN CALL nl_get_start_month(id,month) @@ -1899,7 +1990,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & CHXY, FWETXY, SNEQVOXY, ALBOLDXY, QSNOWXY, & WSLAKEXY, ZWTXY, WAXY, WTXY, LFMASSXY, RTMASSXY,& STMASSXY, WOODXY, STBLCPXY, FASTCPXY, & - XSAIXY, & + XSAIXY, LAI, & SMOISEQ, SMCWTDXY, RECHXY, DEEPRECHXY, AREAXY, & WTDDT, STEPWTD,QRFSXY ,QSPRINGSXY ,QSLATXY, & FDEPTHXY, RIVERBEDXY, EQZWT, RIVERCONDXY, PEXPXY, & @@ -1927,6 +2018,9 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D, & !Optional urban TS_URB2D, FRC_URB2D, UTYPE_URB2D, & SF_URBAN_PHYSICS, & !Optional urban + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !Optional urban + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !Optional urban + FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !Optional urban NUM_URBAN_LAYERS, & !Optional multi-layer urban NUM_URBAN_HI, & !Optional multi-layer urban TRB_URB4D,TW1_URB4D,TW2_URB4D, & !Optional multi-layer urban @@ -2009,6 +2103,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & USE module_sf_slab USE module_sf_pxsfclay USE module_bl_ysu + USE module_bl_shinhong USE module_bl_mrf USE module_bl_gfs USE module_bl_gfs2011, only : gfs2011init @@ -2032,7 +2127,6 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & USE module_bl_camuwpbl_driver, ONLY : camuwpblinit USE module_bl_qnsepbl USE module_sf_lake - USE module_bl_qnsepbl09 USE module_bl_mfshconvpbl USE module_bl_gbmpbl #if ( EM_CORE == 1 ) @@ -2172,6 +2266,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: STBLCPXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: FASTCPXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: XSAIXY + REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: LAI REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: T2MVXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: T2MBXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: CHSTARXY @@ -2208,6 +2303,14 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D !Optional urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D !Optional urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D !Optional urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D !Optional urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D !Optional urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D !Optional urban @@ -2221,6 +2324,8 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D !Optional urban REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D !Optional urban REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(INOUT) :: TGRL_URB3D !Optional urban + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), INTENT(INOUT) :: SMR_URB3D !Optional urban INTEGER , INTENT(IN) :: num_urban_layers INTEGER , INTENT(IN) :: num_urban_hi @@ -2410,7 +2515,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & ENDIF IF(PRESENT(TSK_SAVE))THEN - IF(config_flags%fractional_seaice.EQ.1)THEN + IF(.NOT.restart .AND. config_flags%fractional_seaice.EQ.1)THEN DO j=jts,jte DO i=its,ite TSK_SAVE(i,j)=TSK(i,j) @@ -2427,7 +2532,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & CALL sfclayinit( allowed_to_read ) isfc = 1 CASE (SFCLAYREVSCHEME) -! CALL sfclayinit( allowed_to_read ) + CALL sfclayrevinit isfc = 1 CASE (PXSFCSCHEME) CALL pxsfclayinit( allowed_to_read ) @@ -2582,6 +2687,9 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & LP_URB2D,HI_URB2D,LB_URB2D, & !urban HGT_URB2D,MH_URB2D,STDH_URB2D, & !urban LF_URB2D, & !urban + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !urban + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !urban + FLXHUMR_URB2D, FLXHUMB_URB2D, FLXHUMG_URB2D, & !urban A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP, & !multi-layer urban A_E_BEP,B_U_BEP,B_V_BEP, & !multi-layer urban B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP, & !multi-layer urban @@ -2630,13 +2738,13 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & ! CASE (NOAHMPSCHEME) - CALL NOAHMP_INIT(MMINLU, SNOW,SNOWH,CANWAT,ISLTYP,IVGTYP,ISURBAN, & - TSLB,SMOIS,SH2O,DZS, FNDSOILW, FNDSNOWH, config_flags%isice, config_flags%iswater , & + CALL NOAHMP_INIT(MMINLU, SNOW,SNOWH,CANWAT,ISLTYP,IVGTYP, & + TSLB,SMOIS,SH2O,DZS, FNDSOILW, FNDSNOWH, & TSK,isnowxy ,tvxy ,tgxy ,canicexy ,TMN,XICE, & canliqxy ,eahxy ,tahxy ,cmxy ,chxy , & fwetxy ,sneqvoxy ,alboldxy ,qsnowxy ,wslakexy ,zwtxy ,waxy , & wtxy ,tsnoxy ,zsnsoxy ,snicexy ,snliqxy ,lfmassxy ,rtmassxy , & - stmassxy ,woodxy ,stblcpxy ,fastcpxy ,xsaixy , & + stmassxy ,woodxy ,stblcpxy ,fastcpxy ,xsaixy ,lai , & t2mvxy ,t2mbxy ,chstarxy , & num_soil_layers, restart, & allowed_to_read, iopt_run , & @@ -2809,6 +2917,19 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) + CASE (SHINHONGSCHEME) + if(isfc .ne. 1)CALL wrf_error_fatal & + ( 'module_physics_init: use sfclay scheme for this pbl option' ) + IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal & + ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' ) + CALL shinhonginit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,& + RQCBLTEN,RQIBLTEN,TKE_PBL,P_QI, & + PARAM_FIRST_SCALAR, & + restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) CASE (MRFSCHEME) if(isfc .ne. 1)CALL wrf_error_fatal & ( 'module_physics_init: use sfclay scheme for this pbl option' ) @@ -2906,18 +3027,6 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & its, ite, jts, jte, kts, kte ) ! ENDIF - CASE (QNSEPBL09SCHEME) - if(isfc .ne. 4)CALL wrf_error_fatal & - ( 'module_physics_init: use qnsesfc scheme for this pbl option' ) - IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal & - ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' ) - CALL qnsepblinit09(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & - TKE_PBL,EXCH_H,restart, & - allowed_to_read , & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) - #if (NMM_CORE != 1) CASE (BOULACSCHEME) if(isfc .ne. 1 .and. isfc .ne. 2)CALL wrf_error_fatal & @@ -3018,6 +3127,13 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN, & NCA,RAINC,RAINCV,W0AVG,config_flags,restart, & CLDEFI,LOWLYR,MASS_FLUX, & RTHFTEN, RQVFTEN, & +#if ( EM_CORE == 1 ) + !BSINGH - For WRFCuP Scheme + cupflag,cldfra_cup,cldfratend_cup, & !CuP, wig 18-Sep-2006 + shall, & !CuP, wig 18-Sep-2006 + tcloud_cup, & !CuP, rce 18-apr-2012 + !BSINGH -ENDS +#endif APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & APR_CAPMA,APR_CAPME,APR_CAPMI, & cugd_tten,cugd_ttens,cugd_qvten, & @@ -3030,6 +3146,7 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN, & !------------------------------------------------------------------ USE module_cu_kf USE module_cu_kfeta + USE module_cu_mskf USE MODULE_CU_BMJ USE module_cu_gd, ONLY : GDINIT USE module_cu_g3, ONLY : G3INIT @@ -3039,8 +3156,12 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN, & USE module_cu_camzm_driver, ONLY : zm_conv_init USE module_cu_nsas USE module_cu_tiedtke + USE module_cu_ntiedtke +#if ( EM_CORE == 1 ) + USE module_cu_kfcup !BSINGH - For WRFCuP Scheme +#endif !------------------------------------------------------------------ - IMPLICIT NONE + IMPLICIT NONE !------------------------------------------------------------------ TYPE (grid_config_rec_type) :: config_flags LOGICAL , INTENT(IN) :: restart @@ -3055,11 +3176,19 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN, & LOGICAL , INTENT(IN) :: allowed_to_read INTEGER , INTENT(INOUT) :: STEPCU - REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: & + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: & RUCUTEN, RVCUTEN, RTHCUTEN, & RQVCUTEN, RQCCUTEN, RQRCUTEN, RQICUTEN, RQSCUTEN - REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , OPTIONAL, INTENT(INOUT) :: & - cugd_tten,cugd_ttens,cugd_qvten, & +#if ( EM_CORE == 1 ) + !BSINGH - For WRFCuP Scheme + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: & + cldfra_cup,cldfratend_cup !CuP, wig 18-Sep-2006 + !BSINGH -ENDS +#endif + + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , OPTIONAL, INTENT(INOUT) :: & + cugd_tten,cugd_ttens,cugd_qvten, & cugd_qvtens,cugd_qcten, RQCNCUTEN, RQINCUTEN REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG @@ -3070,13 +3199,19 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN, & REAL , DIMENSION( ims:ime , jms:jme ), INTENT(OUT):: RAINC, RAINCV REAL , DIMENSION( ims:ime , jms:jme ), INTENT(OUT):: CLDEFI +#if ( EM_CORE == 1 ) + !BSINGH - For WRFCuP Scheme + REAL , DIMENSION( ims:ime , jms:jme ), INTENT(OUT):: shall, & !CuP, wig 18-Sep-2006 + tcloud_cup !CuP, rce 18-apr-2012 + LOGICAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT):: cupflag !CuP, wig 9-Oct-2006 !BSINGH - For WRFCuP Scheme + !BSINGH -ENDS +#endif REAL , DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA REAL , DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: MASS_FLUX, & - APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & + APR_GR,APR_W,APR_MC,APR_ST,APR_AS, & APR_CAPMA,APR_CAPME,APR_CAPMI - INTEGER, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: LOWLYR ! LOCAL VAR @@ -3133,6 +3268,19 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) + +#if ( EM_CORE == 1 ) + CASE (MSKFSCHEME) + CALL mskf_init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, & + SVP1,SVP2,SVP3,SVPT0, & + PARAM_FIRST_SCALAR,restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +#endif + CASE (GDSCHEME) CALL gdinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & MASS_FLUX,cp,restart, & @@ -3177,6 +3325,24 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) +#if ( EM_CORE == 1 ) + !BSINGH - For WRFCuP Scheme + CASE (KFCUPSCHEME) !wig: 18-Sep-2006 + CALL kf_cup_init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, & + SVP1,SVP2,SVP3,SVPT0, & + cupflag,cldfra_cup,cldfratend_cup, & + shall, & + tcloud_cup, & + PARAM_FIRST_SCALAR,restart, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + !BSINGH - ENDS +#endif + CASE (MESO_SAS) !Kwon CALL msasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & RUCUTEN,RVCUTEN, & ! gopal's doing for SAS @@ -3218,6 +3384,16 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) + CASE (NTIEDTKESCHEME) + CALL ntiedtkeinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & + RUCUTEN,RVCUTEN, & + RTHFTEN, RQVFTEN, & + restart,P_QC,P_QI,PARAM_FIRST_SCALAR, & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CASE DEFAULT END SELECT cps_select @@ -3333,6 +3509,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, nssl_cnor, nssl_cnos, & nssl_rho_qh, nssl_rho_qhl, & nssl_rho_qs, & + ccn_conc, & ! RAS z_at_q, qnwfa2d, scalar, num_sc, & ! G. Thompson ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3342,7 +3519,6 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, USE module_mp_wsm5 USE module_mp_wsm6 USE module_mp_etanew - USE module_mp_etaold #if (NMM_CORE == 1) USE module_mp_HWRF #endif @@ -3385,6 +3561,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY REAL , DIMENSION(:) ,INTENT(INOUT) :: mp_restart_state,tbpvs_state,tbpvs0_state LOGICAL , INTENT(IN) :: allowed_to_read + REAL, INTENT(INOUT) :: ccn_conc ! RAS REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT):: qnwfa2d ! G. Thompson REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: z_at_q ! G. Thompson INTEGER, INTENT(IN) :: num_sc ! G. Thompson @@ -3431,7 +3608,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, CASE (WSM5SCHEME) CALL wsm5init(rhoair0,rhowater,rhosnow,cliq,cpv, allowed_to_read ) CASE (WSM6SCHEME) - CALL wsm6init(rhoair0,rhowater,rhosnow,cliq,cpv, allowed_to_read ) + CALL wsm6init(rhoair0,rhowater,rhosnow,cliq,cpv, config_flags%hail_opt,allowed_to_read ) CASE (ETAMPNEW) adv_moist_cond = .false. CALL etanewinit (MPDT,DT,DX,DY,LOWLYR,restart, & @@ -3472,15 +3649,16 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ITS=its, ITE=ite, JTS=jts, JTE=jte, KTS=kts, KTE=kte) CASE (MORR_TWO_MOMENT) - CALL morr_two_moment_init + CALL morr_two_moment_init( config_flags%hail_opt ) CASE (MILBRANDT2MOM) CALL milbrandt2mom_init ! CASE (MILBRANDT3MOM) ! CALL milbrandt3mom_init CASE (WDM5SCHEME) - CALL wdm5init(rhoair0,rhowater,rhosnow,cliq,cpv,n_ccn0,allowed_to_read ) + CALL wdm5init(rhoair0,rhowater,rhosnow,cliq,cpv,ccn_conc,allowed_to_read ) CASE (WDM6SCHEME) - CALL wdm6init(rhoair0,rhowater,rhosnow,cliq,cpv,n_ccn0,allowed_to_read ) + CALL wdm6init(rhoair0,rhowater,rhosnow,cliq,cpv,ccn_conc, & + config_flags%hail_opt, allowed_to_read ) #if (EM_CORE==1) CASE (FULL_KHAIN_LYNN) IF(start_of_simulation.or.restart)THEN @@ -3495,9 +3673,12 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, CASE (NSSL_1MOM) CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=0,mixphase=0,ihvol=0) CASE (NSSL_2MOM) - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=0) + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=1) + CASE (NSSL_2MOMG) + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=-1) ! turn off hail CASE (NSSL_2MOMCCN) - CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=0) + ccn_conc = nssl_cccn/1.225 ! set this to have correct boundary conditions + CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=1) ! CASE (NSSL_3MOM) ! CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=8,mixphase=0,ihvol=1) CASE (CAMMGMPSCHEME) ! CAM5's microphysics @@ -3507,16 +3688,6 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ,ims, ime, jms, jme, kms, kme & ,its, ite, jts, jte, kts, kte ) #endif - CASE (ETAMPOLD) - adv_moist_cond = .false. - CALL etaoldinit (MPDT,DT,DX,DY,LOWLYR,restart, & - F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & - mp_restart_state,tbpvs_state,tbpvs0_state,& - allowed_to_read, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) - CASE DEFAULT @@ -3885,7 +4056,7 @@ SUBROUTINE CAM_INIT (ixcldliq, ixcldice, ixnumliq, ixnumice,config_flags) !pcnst for microphysics (pcnst_mp is different from pcnst ONLY if CAM MAM package amd CAMMGMP schemes are decoupled) pcnst_mp = pcnst -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !If CAM MAM package is selected !BSINGH (01/23/2014):Please make sure pcnst is equal to cam_mam_nspec in chem/module_cam_mam_init.F and registry.chem IF(config_flags%chem_opt == CBMZ_CAM_MAM3_NOAQ .OR. config_flags%chem_opt==CBMZ_CAM_MAM3_AQ) then @@ -3947,7 +4118,7 @@ SUBROUTINE CAM_INIT (ixcldliq, ixcldice, ixnumliq, ixnumice,config_flags) !For prescribed aerosols #if ( EM_CORE == 1 ) IF(config_flags%mp_physics .EQ. CAMMGMPSCHEME & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) .AND. config_flags%chem_opt .EQ. 0 & #endif )THEN @@ -3975,7 +4146,7 @@ SUBROUTINE CAM_INIT (ixcldliq, ixcldice, ixnumliq, ixnumice,config_flags) #if ( EM_CORE == 1 ) IF(config_flags%mp_physics == CAMMGMPSCHEME)THEN -#ifndef WRF_CHEM +#if ( WRF_CHEM != 1 ) !Aerosols must be initialized after adding the constituents otherwise the code may crash in WRF-Chem simulations CALL modal_aero_initialize_phys #else @@ -4051,9 +4222,10 @@ subroutine aerosol_in(aerodm,pina,alevsiz,no_months,no_src_types,XLAT,XLONG, & REAL, DIMENSION(alevsiz), INTENT(OUT ) :: pina ! Local -! data from Torn, computed from EC 6 types of aerosol data: +! Data from Ryan Torn, computed from EC 6 types of aerosol data: ! organic carbon, sea salt, dust, black carbon, sulfalte ! and stratospheric aerosol (volcanic ashes) +! The data dimensions are 46 x 72 x 12 (pressure levels), and in unit of AOD per Pa INTEGER, PARAMETER :: latsiz = 46 INTEGER, PARAMETER :: lonsiz = 72 diff --git a/wrfv2_fire/phys/module_ra_aerosol.F b/wrfv2_fire/phys/module_ra_aerosol.F index 3756869a..9d36ca83 100644 --- a/wrfv2_fire/phys/module_ra_aerosol.F +++ b/wrfv2_fire/phys/module_ra_aerosol.F @@ -263,11 +263,11 @@ subroutine calc_aerosol_goddard_sw(ht,dz8w,p,t3d,qv3d,aer_type, call wrf_error_fatal(wrf_err_message) end if if ((minval(aerssa2d) .lt. 0) .or. (maxval(aerssa2d) .gt. 1)) then - call wrf_error_fatal('Aerosol single-scattering albedo must be within [0,1]. & - Out of bounds value(s) found in auxinput') + call wrf_error_fatal('Aerosol single-scattering albedo must be within [0,1]. ' // & + 'Out of bounds value(s) found in auxinput') end if - write( wrf_err_message, '("aer_ssa_opt=",I1,": single-scattering albedo read & - from auxinput (min=",F6.3," max=",F6.3,")")') & + write( wrf_err_message, & + '("aer_ssa_opt=",I1,": single-scattering albedo read from auxinput (min=",F6.3," max=",F6.3,")")') & aer_ssa_opt,minval(aerssa2d),maxval(aerssa2d) call wrf_debug(100, wrf_err_message ) do j=jts,jte @@ -395,6 +395,8 @@ subroutine calc_aerosol_rrtmg_sw(ht,dz8w,p,t3d,qv3d,aer_type, ! constants integer, parameter :: N_BANDS=14 + ! local index variables + integer :: i,j,k,nb real :: lower_wvl(N_BANDS),upper_wvl(N_BANDS) data (lower_wvl(i),i=1,N_BANDS) /3.077,2.500,2.150,1.942,1.626,1.299,1.242,0.7782,0.6250,0.4415,0.3448,0.2632,0.2000,3.846/ @@ -416,7 +418,6 @@ subroutine calc_aerosol_rrtmg_sw(ht,dz8w,p,t3d,qv3d,aer_type, real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS), intent(inout) :: tauaer, ssaaer, asyaer ! local variables - integer :: i,j,k,nb real :: angexp_val,aod_rate,x,xy,xx real, dimension(ims:ime, jms:jme, 1:N_BANDS) :: aod550spc real, dimension(ims:ime, kms:kme, jms:jme) :: rh ! relative humidity @@ -560,7 +561,8 @@ subroutine calc_aerosol_rrtmg_sw(ht,dz8w,p,t3d,qv3d,aer_type, write(wrf_err_message,'("aer_ssa_val must be within [0,1]. Illegal value ",F7.4," found")') aer_ssa_val call wrf_error_fatal(wrf_err_message) end if - write( wrf_err_message, '("aer_ssa_opt=",I1,": single-scattering albedo fixed to value ",F6.3)') aer_ssa_opt,aer_ssa_val + write( wrf_err_message, & + '("aer_ssa_opt=",I1,": single-scattering albedo fixed to value ",F6.3)') aer_ssa_opt,aer_ssa_val call wrf_debug(100, wrf_err_message ) do j=jts,jte do i=its,ite @@ -584,8 +586,8 @@ subroutine calc_aerosol_rrtmg_sw(ht,dz8w,p,t3d,qv3d,aer_type, call wrf_error_fatal(wrf_err_message) end if if ((minval(aerssa2d) .lt. 0) .or. (maxval(aerssa2d) .gt. 1)) then - call wrf_error_fatal('Aerosol single-scattering albedo must be within [0,1]. & - Out of bounds value(s) found in auxinput') + call wrf_error_fatal('Aerosol single-scattering albedo must be within [0,1]. ' // & + 'Out of bounds value(s) found in auxinput') end if write( wrf_err_message, '("aer_ssa_opt=",I1,": single-scattering albedo from auxinput (min=",F6.3," max=",F6.3,")")') & aer_ssa_opt,minval(aerssa2d),maxval(aerssa2d) diff --git a/wrfv2_fire/phys/module_ra_cam.F b/wrfv2_fire/phys/module_ra_cam.F index ebc32a0d..7aba770b 100644 --- a/wrfv2_fire/phys/module_ra_cam.F +++ b/wrfv2_fire/phys/module_ra_cam.F @@ -210,6 +210,7 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & SWVISDIR,SWVISDIF, & !ssib SWNIRDIR,SWNIRDIF, & !ssib sf_surface_physics, & !ssib + SWDDIR,SWDDIF,SWDDNI, & ! amontornes-bcodina (2014-04-20) F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, & f_ice_phy,f_rain_phy, & p_phy,p8w,z,pi_phy,rho_phy,dz8w, & @@ -312,7 +313,11 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & INTENT(OUT) :: SWVISDIR, & SWVISDIF, & SWNIRDIR, & - SWNIRDIF + SWNIRDIF, & + SWDDIR, & + SWDDNI, & + SWDDIF + INTEGER, INTENT(IN) :: sf_surface_physics !-------------------------------------- ! saving arrays for doabsems reduction of radiation calcs @@ -399,6 +404,10 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsupc ! Upward clear sky solar real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdn ! Downward total sky solar real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdnc ! Downward clear sky solar + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdndir ! Direct Downward total sky solar amontornes-bcodina (2014-04-20) + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdncdir ! Direct Downward clear sky solar amontornes-bcodina (2014-04-20) + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdndif ! Diffuse Downward total sky solar amontornes-bcodina (2014-04-20) + real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fsdncdif ! Diffuse Downward clear sky solar amontornes-bcodina (2014-04-20) real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: flup ! Upward total sky longwave real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: flupc ! Upward clear sky longwave real(r8), dimension( 1:ite-its+1, 1:kte-kts+2 ) :: fldn ! Downward total sky longwave @@ -413,6 +422,8 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & real(r8), dimension( 1:ite-its+1 ) :: solld ! Downward solar rad onto surface (lw diffuse) real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrs ! Solar heating rate real(r8), dimension( 1:ite-its+1 ) :: fsds ! Flux Shortwave Downwelling Surface + real(r8), dimension( 1:ite-its+1 ) :: fsdsdir ! Flux Shortwave Direct Downwelling Surface + real(r8), dimension( 1:ite-its+1 ) :: fsdsdif ! Flux Shortwave Diffuse Downwelling Surface real(r8), dimension( 1:ite-its+1, 1:kte-kts+1 ) :: qrl ! Longwave cooling rate real(r8), dimension( 1:ite-its+1 ) :: flwds ! Surface down longwave flux real(r8), dimension( 1:ite-its+1, levsiz, num_months ) :: ozmixmj ! monthly ozone mixing ratio @@ -477,10 +488,10 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & IF ( wrf_dm_on_monitor() ) THEN WRITE(message,*)'write 1 CAM-CLWRF interpolated values______ year:',yr,' julian day:',julian - call wrf_debug( 1, message) + call wrf_debug( 100, message) WRITE(message,*)' CAM-CLWRF co2vmr: ',co2vmr,' n2ovmr:',n2ovmr,' ch4vmr:',ch4vmr,' cfc11:'& ,f11vmr,' cfc12:',f12vmr - call wrf_debug( 1, message) + call wrf_debug( 100, message) ENDIF #else @@ -755,7 +766,9 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & pin, ozmixmj, ozmix, levsiz, num_months, & m_psjp,m_psjn, aerosoljp, aerosoljn, m_hybi, paerlev, naer_c, pmxrgn, nmxrgn, & dolw, dosw, doabsems, abstot, absnxt, emstot, & - fsup, fsupc, fsdn, fsdnc, flup, flupc, fldn, fldnc, swcftoa, lwcftoa, olrtoa, & + fsup, fsupc, fsdn, fsdnc, & + fsdndir ,fsdncdir,fsdndif ,fsdncdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes + flup, flupc, fldn, fldnc, swcftoa, lwcftoa, olrtoa, & fsns, fsnt ,flns ,flnt , & qrs, qrl, flwds, rel, rei, & sols, soll, solsd, solld, & @@ -765,7 +778,7 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & n2ovmr, ch4vmr, f11vmr, f12vmr , & #endif !ccc - landfrac, zm, fsds) + landfrac, zm, fsds, fsdsdir, fsdsdif) ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes do k = kts,kte kk = kte - k + kts @@ -876,6 +889,9 @@ subroutine camrad(RTHRATENLW,RTHRATENSW, & GSW(I,J) = fsns(ii) swcf(i,j) = swcftoa(ii) coszr(i,j) = coszrs(ii) + SWDDIR(i,j)= fsdsdir(ii) ! amontornes-bcodina (2014-04-20) + SWDDNI(i,j)= fsdsdir(ii)/coszrs(ii) ! amontornes-bcodina (2014-04-20) + SWDDIF(i,j)= fsdsdif(ii) ! amontornes-bcodina (2014-04-20) endif enddo !-------fds (06/2010)--------- @@ -1558,6 +1574,7 @@ subroutine radctl(j, lchnk ,ncol , pcols, pver, pverp, pverr, pverrp, ppcns nmxrgn , & dolw, dosw, doabsems, abstot, absnxt, emstot, & fsup ,fsupc ,fsdn ,fsdnc , & + fsdndir ,fsdncdir,fsdndif ,fsdncdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes flup ,flupc ,fldn ,fldnc , & swcf ,lwcf ,flut , & fsns ,fsnt ,flns ,flnt , & @@ -1569,7 +1586,7 @@ subroutine radctl(j, lchnk ,ncol , pcols, pver, pverp, pverr, pverrp, ppcns n2ovmr, ch4vmr, f11vmr, f12vmr , & #endif !ccc - landfrac,zm ,fsds ) + landfrac,zm ,fsds, fsdsdir,fsdsdif ) ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes !----------------------------------------------------------------------- ! ! Purpose: @@ -1678,11 +1695,17 @@ subroutine radctl(j, lchnk ,ncol , pcols, pver, pverp, pverr, pverrp, ppcns real(r8), intent(out) :: solld(pcols) ! Downward solar rad onto surface (lw diffuse) real(r8), intent(out) :: qrs(pcols,pver) ! Solar heating rate real(r8), intent(out) :: fsds(pcols) ! Flux Shortwave Downwelling Surface + real(r8), intent(out) :: fsdsdir(pcols) ! Flux Shortwave Direct Downwelling Surface (amontornes-bcodina 2014-04-20) + real(r8), intent(out) :: fsdsdif(pcols) ! Flux Shortwave Diffuse Downwelling Surface (amontornes-bcodina 2014-04-20) ! Added outputs of total and clearsky fluxes etc real(r8), intent(out) :: fsup(pcols,pverp) ! Upward total sky solar real(r8), intent(out) :: fsupc(pcols,pverp) ! Upward clear sky solar real(r8), intent(out) :: fsdn(pcols,pverp) ! Downward total sky solar real(r8), intent(out) :: fsdnc(pcols,pverp) ! Downward clear sky solar + real(r8), intent(out) :: fsdndir(pcols,pverp) ! Downward Direct total sky solar (amontornes-bcodina 2014-04-20) + real(r8), intent(out) :: fsdncdir(pcols,pverp)! Downward Direct clear sky solar (amontornes-bcodina 2014-04-20) + real(r8), intent(out) :: fsdndif(pcols,pverp) ! Downward Diffuse total sky solar (amontornes-bcodina 2014-04-20) + real(r8), intent(out) :: fsdncdif(pcols,pverp)! Downward Diffuse clear sky solar (amontornes-bcodina 2014-04-20) real(r8), intent(out) :: flup(pcols,pverp) ! Upward total sky longwave real(r8), intent(out) :: flupc(pcols,pverp) ! Upward clear sky longwave real(r8), intent(out) :: fldn(pcols,pverp) ! Downward total sky longwave @@ -1718,6 +1741,8 @@ subroutine radctl(j, lchnk ,ncol , pcols, pver, pverp, pverr, pverrp, ppcns real(r8) fsntc(pcols) ! Clear sky total column abs solar flux real(r8) fsnsc(pcols) ! Clear sky surface abs solar flux real(r8) fsdsc(pcols) ! Clear sky surface downwelling solar flux + real(r8) fsdscdir(pcols) ! Clear sky surface direct downwelling solar flux (amontornes-bcodina 2014-04-20) + real(r8) fsdscdif(pcols) ! Clear sky surface diffuse downwelling solar flux (amontornes-bcodina 2014-04-20) ! real(r8) flut(pcols) ! Upward flux at top of model ! real(r8) lwcf(pcols) ! longwave cloud forcing ! real(r8) swcf(pcols) ! shortwave cloud forcing @@ -1826,6 +1851,8 @@ subroutine radctl(j, lchnk ,ncol , pcols, pver, pverp, pverr, pverrp, ppcns fsnsc ,fsdsc ,fsds ,sols ,soll , & solsd ,solld ,frc_day , & fsup ,fsupc ,fsdn ,fsdnc , & + fsdndir ,fsdncdir,fsdndif ,fsdncdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes profile + fsdsdir ,fsdsdif ,fsdscdir,fsdscdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes sfc aertau ,aerssa ,aerasm ,aerfwd ) ! call t_stopf('radcswmx_rf') @@ -1874,6 +1901,8 @@ subroutine radctl(j, lchnk ,ncol , pcols, pver, pverp, pverr, pverrp, ppcns fsnsc ,fsdsc ,fsds ,sols ,soll , & solsd ,solld ,frc_day , & fsup ,fsupc ,fsdn ,fsdnc , & + fsdndir ,fsdncdir,fsdndif ,fsdncdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes profiles + fsdsdir ,fsdsdif ,fsdscdir,fsdscdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes sfc aertau ,aerssa ,aerasm ,aerfwd ) ! call t_stopf('radcswmx') @@ -1895,6 +1924,11 @@ subroutine radctl(j, lchnk ,ncol , pcols, pver, pverp, pverr, pverrp, ppcns fsntoa(i)=fsntoa(i)*1.e-3 fsntoac(i)=fsntoac(i)*1.e-3 swcf(i) = fsntoa(i) - fsntoac(i) + + fsdsdir(i) = fsdsdir(i)*1.e-3 ! amontornes-bcodina (2014-04-20) + fsdsdif(i) = fsdsdif(i)*1.e-3 ! amontornes-bcodina (2014-04-20) + fsdscdir(i) = fsdscdir(i)*1.e-3 ! amontornes-bcodina (2014-04-20) + fsdscdif(i) = fsdscdif(i)*1.e-3 ! amontornes-bcodina (2014-04-20) end do ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair @@ -5677,6 +5711,8 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & fsnsc ,fsdsc ,fsds ,sols ,soll , & solsd ,solld ,frc_day , & fsup ,fsupc ,fsdn ,fsdnc , & + fsdndir ,fsdncdir,fsdndif ,fsdncdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes profiles + fsdsdir ,fsdsdif ,fsdscdir,fsdscdif, & ! amontornes-bcodina (2014-04-20) Dir/Dif fluxes sfc aertau ,aerssa ,aerasm ,aerfwd ) !----------------------------------------------------------------------- ! @@ -5853,6 +5889,12 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & ! real(r8), intent(out) :: fsnsc(pcols) ! Clear sky surface absorbed solar flux real(r8), intent(out) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux + + real(r8), intent(out) :: fsdscdir(pcols) ! Clear sky surface direct downwelling solar flux (amontornes-bcodina 2014-04-20) + real(r8), intent(out) :: fsdscdif(pcols) ! Clear sky surface diffuse downwelling solar flux (amontornes-bcodina 2014-04-20) + real(r8), intent(out) :: fsdsdir(pcols) ! Clear sky surface direct downwelling solar flux (amontornes-bcodina 2014-04-20) + real(r8), intent(out) :: fsdsdif(pcols) ! Clear sky surface diffuse downwelling solar flux (amontornes-bcodina 2014-04-20) + real(r8), intent(out) :: fsntc(pcols) ! Clear sky total column absorbed solar flx real(r8), intent(out) :: fsntoac(pcols) ! Clear sky net solar flx at TOA real(r8), intent(out) :: sols(pcols) ! Direct solar rad on surface (< 0.7) @@ -5870,6 +5912,10 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & real(r8), intent(out) :: fsupc(pcols,pverp) ! Clear sky upward solar flux (spectrally summed) real(r8), intent(out) :: fsdn(pcols,pverp) ! Total sky downward solar flux (spectrally summed) real(r8), intent(out) :: fsdnc(pcols,pverp) ! Clear sky downward solar flux (spectrally summed) + real(r8), intent(out) :: fsdndir(pcols,pverp) ! Total sky direct downward solar flux (spectrally summed) amontornes-bcodina (2014-04-20) + real(r8), intent(out) :: fsdncdir(pcols,pverp) ! Clear sky direct downward solar flux (spectrally summed) amontornes-bcodina (2014-04-20) + real(r8), intent(out) :: fsdndif(pcols,pverp) ! Total sky diffuse downward solar flux (spectrally summed) amontornes-bcodina (2014-04-20) + real(r8), intent(out) :: fsdncdif(pcols,pverp) ! Clear sky diffuse downward solar flux (spectrally summed) amontornes-bcodina (2014-04-20) ! real(r8) , intent(out) :: frc_day(pcols) ! = 1 for daylight, =0 for night columns real(r8) :: aertau(pcols,nspint,naer_groups) ! Aerosol column optical depth @@ -6030,6 +6076,8 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & real(r8) fswdn(0:pverp) ! Spectrally summed down flux real(r8) fswupc(0:pverp) ! Spectrally summed up clear sky flux real(r8) fswdnc(0:pverp) ! Spectrally summed down clear sky flux + real(r8) fswdndir(0:pverp) ! Spectrally summed direct flux in all sky (amontornes-bcodina 2014-04-20) + real(r8) fswdncdir(0:pverp)! Spectrally summed direct flux in clear sky (amontornes-bcodina 2014-04-20) ! ! Cloud radiative property arrays ! @@ -6223,6 +6271,7 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & real(r8) fluxup(0:pverp) ! Up flux at model interface real(r8) fluxdn(0:pverp) ! Down flux at model interface + real(r8) fluxdndir(0:pverp) ! Direct Down flux at model interface (amontornes-bcodina 2014-04-20) real(r8) wexptdn ! Direct solar beam trans. to surface ! moved to here from the module storage above, because these have to be thread-private. JM 20100217 @@ -6262,6 +6311,11 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & fsnsc(i) = 0.0_r8 fsdsc(i) = 0.0_r8 + fsdscdir(i) = 0.0_r8 ! amontornes-bcodina (2014-04-20) + fsdscdif(i) = 0.0_r8 ! amontornes-bcodina (2014-04-20) + fsdsdir(i) = 0.0_r8 ! amontornes-bcodina (2014-04-20) + fsdsdif(i) = 0.0_r8 ! amontornes-bcodina (2014-04-20) + fsnt(i) = 0.0_r8 fsntc(i) = 0.0_r8 fsntoa(i) = 0.0_r8 @@ -6281,6 +6335,10 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & fsupc(i,k) = 0.0_r8 fsdn(i,k) = 0.0_r8 fsdnc(i,k) = 0.0_r8 + fsdndir(i,k) = 0.0_r8 ! amontornes-bcodina (2014-04-20) + fsdncdir(i,k) = 0.0_r8 ! amontornes-bcodina (2014-04-20) + fsdndif(i,k) = 0.0_r8 ! amontornes-bcodina (2014-04-20) + fsdncdif(i,k) = 0.0_r8 ! amontornes-bcodina (2014-04-20) tauxcl(i,k-1) = 0.0_r8 tauxci(i,k-1) = 0.0_r8 end do @@ -7127,6 +7185,8 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & fswdn (k) = 0.0_r8 fswupc (k) = 0.0_r8 fswdnc (k) = 0.0_r8 + fswdndir(k) = 0.0_r8 ! amontornes-bcodina (2014-04-20) + fswdncdir(k)= 0.0_r8 ! amontornes-bcodina (2014-04-20) end do sfltot = 0.0_r8 @@ -7134,6 +7194,9 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & fswdn (pverp) = 0.0_r8 fswupc (pverp) = 0.0_r8 fswdnc (pverp) = 0.0_r8 + fswdndir(pverp) = 0.0_r8 ! amontornes-bcodina (2014-04-20) + fswdncdir(pverp)= 0.0_r8 ! amontornes-bcodina (2014-04-20) + ! ! Start spectral interval ! @@ -7307,6 +7370,7 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & ! fluxup(k)=0.0_r8 fluxdn(k)=0.0_r8 + fluxdndir(k) = 0.0_r8 ! amontornes-bcodina (2014-04-20) do iconfig = 1, nconfig xwgt = wgtv(iconfig) @@ -7324,6 +7388,8 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & ((xexpt * xrups + (xtdnt - xexpt) * xrupd) * rdenom) fluxdn(k) = fluxdn(k) + xwgt * & (xexpt + (xtdnt - xexpt + xexpt * xrups * xrdnd) * rdenom) + fluxdndir(k) = fluxdndir(k) + xwgt * xexpt ! Beer's Law amontornes-bcodina (2014-04-20) + ! ! End do iconfig = 1, nconfig ! @@ -7333,7 +7399,8 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & ! in solution ! fluxup(k)=fluxup(k) / totwgt - fluxdn(k)=fluxdn(k) / totwgt + fluxdn(k)=fluxdn(k) / totwgt + fluxdndir(k)=fluxdndir(k) / totwgt ! amontornes-bcodina (2014-04-20) ! ! End do k = 0,pverp ! @@ -7358,6 +7425,7 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & sfltot = sfltot + solflx fswup(0) = fswup(0) + solflx*fluxup(0) fswdn(0) = fswdn(0) + solflx*fluxdn(0) + fswdndir(0) = fswdndir(0) + solflx*fluxdndir(0) ! amontornes-bcodina (2014-04-20) ! ! Down spectral fluxes need to be in mks; thus the .001 conversion factors ! @@ -7381,6 +7449,7 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & totfld(k) = totfld(k) + solflx*flxdiv fswdn(kp1) = fswdn(kp1) + solflx*fluxdn(kp1) fswup(kp1) = fswup(kp1) + solflx*fluxup(kp1) + fswdndir(kp1) = fswdndir(kp1) + solflx*fluxdndir(kp1) ! amontornes-bcodina (2014-04-20) end do ! ! Perform clear-sky calculation @@ -7431,6 +7500,7 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & rdenom fswupc(k) = fswupc(k) + solflx*fluxup(k) fswdnc(k) = fswdnc(k) + solflx*fluxdn(k) + fswdncdir(k) = fswdncdir(k) + solflx*exptdnc(k) ! Beer's Law amontornes-bcodina (2014-04-20) end do ! k = pverp do k=2,pverp @@ -7441,6 +7511,7 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & exptdnc(k)*rupdirc(k)*rdndifc(k))*rdenom fswupc(k) = fswupc(k) + solflx*fluxup(k) fswdnc(k) = fswdnc(k) + solflx*fluxdn(k) + fswdncdir(k) = fswdncdir(k) + solflx*exptdnc(k) ! Beer's Law amontornes-bcodina (2014-04-20) end do fsntc(i) = fsntc(i)+solflx*(fluxdn(1)-fluxup(1)) @@ -7470,11 +7541,21 @@ subroutine radcswmx(jj, lchnk ,ncol ,pcols, pver, pverp, & fsupc(i,k) = fswupc(k) fsdn(i,k) = fswdn(k) fsdnc(i,k) = fswdnc(k) + fsdndir(i,k) = fswdndir(k) ! amontornes-bcodina (2014-04-20) + fsdncdir(i,k) = fswdncdir(k) ! amontornes-bcodina (2014-04-20) + fsdndif(i,k) = fswdn(k)-fswdndir(k) ! amontornes-bcodina (2014-04-20) + fsdncdif(i,k) = fswdnc(k)-fswdncdir(k) ! amontornes-bcodina (2014-04-20) end do + ! ! Set the downwelling flux at the surface ! fsds(i) = fswdn(pverp) +! amontornes-bcodina (2014-04-20) :: Save surface direct/difuse fluxes + fsdscdir(i) = fsdncdir(i,pverp) ! amontornes-bcodina (2014-04-20) + fsdscdif(i) = fsdncdif(i,pverp) ! amontornes-bcodina (2014-04-20) + fsdsdir(i) = fsdndir(i,pverp) ! amontornes-bcodina (2014-04-20) + fsdsdif(i) = fsdndif(i,pverp) ! amontornes-bcodina (2014-04-20) ! ! End do n=1,ndayc ! diff --git a/wrfv2_fire/phys/module_ra_flg.F b/wrfv2_fire/phys/module_ra_flg.F index 101eed32..3d2fd484 100644 --- a/wrfv2_fire/phys/module_ra_flg.F +++ b/wrfv2_fire/phys/module_ra_flg.F @@ -7975,6 +7975,8 @@ subroutine RAD_FLG & ! & , ulwtop, ulwbot, dlwbot, netlwstr, netlwbot & & , uswtop, ulwtop,NETSWBOT,DLWBOT,DSWBOT & & , deltat,dtshort, dtlongwv & +!-- amontornes-bcodina (2014-04-29): return direct and diffuse fluxes at surface + & , swddir,swddif,swddni & !-- for optional aerosol input ! & , tau_aer_2D, tau_aer_3D, fraca_in & !-- change over @@ -8009,7 +8011,10 @@ subroutine RAD_FLG & !* USWTOP = upward solar flux at TOA (down-up) !* DSWTOP = net downward solar flux at TOA (down-up) !* DSWBOT = net downward solar flux at surface (down-up) -!* SWINC = solar flux incident at TOA +!* swddir = direct horizontal irradiance (amontornes-bcodina, 2014-04-29) +!* swddif = diffuse irradiance (amontornes-bcodina, 2014-04-29) +!* swddni = direct normal irradiance (amontornes-bcodina, 2014-04-29) +!* SWINC = solar flux incident at TOA !* DELTAT = total column physics increment to theta ! !* ULWBOT = upward IR flux at surface @@ -8169,6 +8174,10 @@ subroutine RAD_FLG & real xlat(ims:idim,jms:jdim), xlong(ims:idim, jms:jdim) real dswtop(ims:idim,jms:jdim) , dswbot(ims:idim,jms:jdim) +!c--- amontornes-bcodina (2014-04-29): for DHI, DIF and DNI outputs + real swddir(ims:idim,jms:jdim) + real swddif(ims:idim,jms:jdim) + real swddni(ims:idim,jms:jdim) real uswtop(ims:idim,jms:jdim) real netswbot(ims:idim,jms:jdim) real swinc(ims:idim,jms:jdim) @@ -8211,6 +8220,8 @@ subroutine RAD_FLG & real fds(kmax), fus(kmax), dts(kmax-1) real fdir(kmax), fuir(kmax), dtir(kmax-1) real fd(kmax), fu(kmax), dt_rad(kmax-1) +!C-- amontornes-bcodina (2014-04-29): direct and diffuse fluxes + real fdsdir(kmax), fdsdif(kmax) !*************************************************************************** !* Use Fu-Liou radiation routine and algorithm @@ -8320,6 +8331,10 @@ subroutine RAD_FLG & dts(k)=rzero dtir(k)=rzero dt_rad(k)=rzero +!C--- amontornes-bcodina (2014-04-29): direct and diffuse fluxes + fdsdir(k)=rzero + fdsdif(k)=rzero + enddo VERTICAL_PROFILE fds(kmax)=rzero @@ -8328,7 +8343,9 @@ subroutine RAD_FLG & fuir(kmax)=rzero fd(kmax)=rzero fu(kmax)=rzero - +!C--- amontornes-bcodina (2014-04-29): direct and diffuse fluxes + fdsdir(kmax)=rzero + fdsdif(kmax)=rzero o3ij(kmax) = rzero @@ -8910,6 +8927,8 @@ subroutine RAD_FLG & !C--- output: fluxes and heating rates & , fds, fus, dts, fdir, fuir, dtir & & , fd, fu, dt_rad & +!C--- amontornes-bcodina (2014-04-29): new to save the direct and diffuse fluxes + & , fdsdir, fdsdif & & ) !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC @@ -8921,7 +8940,17 @@ subroutine RAD_FLG & !*** net solar at sfc netswbot(i,j) = fds(kmax) - fus(kmax) !*** downward solar at sfc - dswbot(i,j) = fds(kmax) + dswbot(i,j) = fds(kmax) +!*** DNI, DIR and DIF values (amontornes-bcodina 2014-04-29) + if(u0ij .gt. 0.0001) then + swddni(i,j) = fdsdir(kmax)/u0ij + swddir(i,j) = fdsdir(kmax) + swddif(i,j) = fdsdif(kmax) + else + swddni(i,j) = 0. + swddir(i,j) = 0. + swddif(i,j) = 0. + endif !*** downward IR at sfc dlwbot(i,j) = fdir(kmax) !*** upward IR at sfc @@ -9073,6 +9102,8 @@ subroutine rad_all ( nv, nv1 & & , fdsij, fusij, dtsij & & , fdirij, fuirij, dtirij & & , fdij, fuij, dtij & +!C--- amontornes-bcodina (2014-04-29): new to save the direct and diffuse fluxes + & , fdsdir, fdsdif & & ) !c ********************************************************************* @@ -9160,6 +9191,8 @@ subroutine rad_all ( nv, nv1 & !C--- variables in the offline version real, dimension(nv1) :: pp, pt, ph, po real, dimension(nv1) :: fds, fus, fdir, fuir, fd, fu +!C--- amontornes-bcodina (2014-04-29): new to save the direct and diffuse information + real, dimension(nv1) :: fdsdir, fdsdif real, dimension(nv) :: dts, dtir, dt real, dimension(nv) :: piwc, plwc, pgwc, prwc, & & pde, pre, cldamnt @@ -9168,6 +9201,8 @@ subroutine rad_all ( nv, nv1 & real :: pts, u0 real, dimension(nv1) :: fu1, fd1 +!C--- amontornes-bcodina (2014-04-29): new to save the direct and diffuse information + real, dimension(nv1) :: ffddir,ffdif real :: bf(nv1), bs real, dimension(nv) :: wc1, wc2, wc3, wc4, wc, tt ! -- add for partial clouds @@ -9236,6 +9271,9 @@ subroutine rad_all ( nv, nv1 & fus(i) = 0.0 fdir(i) = 0.0 fuir(i) = 0.0 +!C--- amontornes-bcodina (2014-04-29): Added for direct and diffuse computations + fdsdir(i) = 0.0 + fdsdif(i) = 0.0 10 end do as = asij @@ -9421,8 +9459,9 @@ subroutine rad_all ( nv, nv1 & !c 11/4/95 (begin) if ( ib .le. mbs ) then if ( fourssl ) then +!c amontornes-bcodina (2014-04-29): this line was modified to introduce the direct and diffuse fluxes call qfts ( nv,nv1,ib, as(ib), u0, f0, & - & wc1,wc2,wc3,wc4,wc,tt,fu1,fd1 ) + & wc1,wc2,wc3,wc4,wc,tt,fu1,fd1,ffddir,ffdif ) endif if ( twossl ) then quadra = .false. @@ -9435,7 +9474,10 @@ subroutine rad_all ( nv, nv1 & ! fds(i) = fds(i) + fd1(i) * hk ! fus(i) = fus(i) + fu1(i) * hk fds(i) = fds(i) + fd1(i) * hk * area - fus(i) = fus(i) + fu1(i) * hk * area + fus(i) = fus(i) + fu1(i) * hk * area +!c amontornes-bcodina (2014-04-29): this line was added for the direct and diffuse outputs + fdsdir(i) = fdsdir(i) + ffddir(i) * hk * area + fdsdif(i) = fdsdif(i) + ffdif(i) * hk * area 40 end do else if ( foursir ) then @@ -9477,9 +9519,13 @@ subroutine rad_all ( nv, nv1 & do i = 1, nv1 fds(i) = fds(i) * fuq1 fus(i) = fus(i) * fuq1 +!c amontornes-bcodina (2014-04-29): direct and diffuse fluxes + fdsdir(i) = fdsdir(i) * fuq1 + fdsdif(i) = fdsdif(i) * fuq1 fuir(i) = fuir(i) + fuq2 fd(i) = fds(i) + fdir(i) fu(i) = fus(i) + fuir(i) + !C--- assign result to output variables fdsij(i) = fds(i) fusij(i) = fus(i) @@ -10734,7 +10780,7 @@ subroutine ice_new_Single ( nv,nv1,ib,pre,pde,plwc,piwc,dz,ti,wi,wwi ) subroutine water_fl ( nv,nv1,ib,pre,plwc,pde,piwc,dz,tw,ww,www ) !c ********************************************************************* - !c tw, ww, and www are the optical depth, single scattering albedo, & +!c tw, ww, and www are the optical depth, single scattering albedo, & !c and expansion coefficients of the phase function ( 1, 2, 3, and !c 4) due to the Mie scattering of water clouds for a given layer. !c By using the mean single scattering properties of the eight drop @@ -10764,7 +10810,7 @@ subroutine water_fl ( nv,nv1,ib,pre,plwc,pde,piwc,dz,tw,ww,www ) www(i,3) = 0.0 www(i,4) = 0.0 else - if ( pre(i) .lt. re(1) ) then + if ( pre(i) .le. re(1) ) then ! A cloud with the effective radius smaller than 4.18 um is assumed ! to have an effective radius of 4.18 um with respect to the single ! scattering properties. @@ -10778,7 +10824,7 @@ subroutine water_fl ( nv,nv1,ib,pre,plwc,pde,piwc,dz,tw,ww,www ) www(i,2) = 5.0 * x2 www(i,3) = 7.0 * x3 www(i,4) = 9.0 * x4 - elseif ( pre(i) .gt. re(nc) ) then + elseif ( pre(i) .ge. re(nc) ) then ! A cloud with the effective radius larger than 31.23 um is assumed ! to have an effective radius of 31.18 um with respect to the single ! scattering properties. @@ -10793,9 +10839,9 @@ subroutine water_fl ( nv,nv1,ib,pre,plwc,pde,piwc,dz,tw,ww,www ) www(i,3) = 7.0 * x3 www(i,4) = 9.0 * x4 else - j = 1 + j = nc do while (pre(i) .lt. re(j)) - j = j + 1 + j = j - 1 end do tw(i) = dz(i) * plwc(i) * ( bz(j,ib) / fl(j) + & & ( bz(j+1,ib) / fl(j+1) - bz(j,ib) / fl(j) ) / & @@ -13520,7 +13566,9 @@ subroutine adjust ( nv, nv1, ww1,ww2,ww3,ww4,ww,tt,w1,w2,w3,w,t ) !c ww1(nv), ww2(nv), ww3(nv), ww4(nv), ww(nv), and tt(nv) !c through common statement 'dfsin'. !c ********************************************************************** - subroutine qfts ( nv, nv1, ib,as,u0,f0,ww1,ww2,ww3,ww4,ww,tt,ffu,ffd ) + +!c amontornes-bcodina (2014-04-29): this line modified to introduce the direct and diffuse fluxes + subroutine qfts ( nv, nv1, ib,as,u0,f0,ww1,ww2,ww3,ww4,ww,tt,ffu,ffd,ffddir,ffdif ) !# include "para.file" USE PARA_FILE ! common /dis/ a(4) @@ -13531,6 +13579,8 @@ subroutine qfts ( nv, nv1, ib,as,u0,f0,ww1,ww2,ww3,ww4,ww,tt,ffu,ffd ) real, intent(in) :: as, u0, f0 real, intent(in), dimension(nv) :: ww1, ww2, ww3, ww4, ww, tt real, intent(out), dimension(nv1) :: ffu, ffd +!c amontornes-bcodina (2014-04-29): this line was added to introduce the direct and diffuse fluxes + real, intent(out), dimension(nv1) :: ffddir,ffdif real, dimension(nv) :: w1, w2, w3, w4, w, t, u0a, f0a real :: fk1(nv), fk2(nv), a4(4,4,nv), & & z4(4,nv), g4(4,nv) @@ -13586,6 +13636,9 @@ subroutine qfts ( nv, nv1, ib,as,u0,f0,ww1,ww2,ww3,ww4,ww,tt,ffu,ffd ) 40 end do ffu(i)= fw1 * fi(2) + fw2 * fi(1) ffd(i)= fw1 * fi(3) + fw2 * fi(4) + fw3 * y +!c amontornes-bcodina (2014-04-29): save direct and diffuse terms + ffddir(i) = fw3 * y ! amontornes-bcodina Direct downward flux + ffdif(i) = ffd(i)-ffddir(i) ! amontornes-bcodina Diffuse downward flux 10 end do return end subroutine diff --git a/wrfv2_fire/phys/module_ra_gsfcsw.F b/wrfv2_fire/phys/module_ra_gsfcsw.F index 9ef5bf49..5537ce2f 100644 --- a/wrfv2_fire/phys/module_ra_gsfcsw.F +++ b/wrfv2_fire/phys/module_ra_gsfcsw.F @@ -12,18 +12,19 @@ MODULE module_ra_gsfcsw CONTAINS - SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong & + SUBROUTINE GSFCSWRAD(rthraten,gsw & ! PAJ: xlat and xlong removed. ,dz8w,rho_phy & ,alb,t3d,qv3d,qc3d,qr3d & ,qi3d,qs3d,qg3d,qndrop3d & ,p3d,p8w3d,pi3d,cldfra3d,rswtoa & - ,gmt,cp,g,julday,xtime,declin,solcon & - ,radfrq,degrad,taucldi,taucldc,warm_rain & + ,cp,g,julday,solcon & ! PAJ: declin, gmt and xtime removed. + ,taucldi,taucldc,warm_rain & ! PAJ: radfrq and degrad removed ,tauaer300,tauaer400,tauaer600,tauaer999 & ! jcb ,gaer300,gaer400,gaer600,gaer999 & ! jcb ,waer300,waer400,waer600,waer999 & ! jcb ,aer_ra_feedback & ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop & + ,coszen & ! PAJ ,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & ,its,ite, jts,jte, kts,kte ) @@ -39,9 +40,10 @@ SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong & INTEGER, INTENT(IN ) :: JULDAY - - REAL, INTENT(IN ) :: RADFRQ,DEGRAD, & - XTIME,DECLIN,SOLCON + REAL, INTENT(IN ) :: SOLCON +! PAJ: degrad and radfqr removed: +! REAL, INTENT(IN ) :: RADFRQ,DEGRAD, & +! PAJ: declin and xtime removed. XTIME,DECLIN,SOLCON ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(IN ) :: P3D, & @@ -61,15 +63,19 @@ SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong & taucldc ! REAL, DIMENSION( ims:ime, jms:jme ), & - INTENT(IN ) :: XLAT, & - XLONG, & - ALB + INTENT(IN ) :: ALB +! PAJ: XLAT and XLONG no longer needed. Lines commented. +! INTENT(IN ) :: XLAT, & +! XLONG, & +! ALB ! REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(INOUT) :: GSW, & RSWTOA ! - REAL, INTENT(IN ) :: GMT,CP,G +! PAJ: GMT removed. +! REAL, INTENT(IN ) :: GMT,CP,G + REAL, INTENT(IN ) :: CP,G ! ! @@ -96,6 +102,10 @@ SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong & LOGICAL, OPTIONAL, INTENT(IN ) :: & F_QV,F_QC,F_QR,F_QI,F_QS,F_QG, & F_QNDROP +! +! ... PAJ ... +! + REAL, DIMENSION( ims:ime, jms:jme), INTENT(IN) :: COSZEN ! LOCAL VARS @@ -161,9 +171,11 @@ SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong & ! - REAL :: XLAT0,XLONG0 +! PAJ: The following variables are not used in the subroutime. Line commented. +! REAL :: XLAT0,XLONG0 REAL :: fac,latrmp - REAL :: xt24,tloctm,hrang,xxlat +! PAJ: The following variables are no longer needed. Line commented. +! REAL :: xt24,tloctm,hrang,xxlat real, dimension(11) :: midbands ! jcb data midbands/.2,.235,.27,.2875,.3025,.305,.3625,.55,1.92,1.745,6.135/ ! jcb @@ -365,7 +377,7 @@ SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong & !-------------------------------------------------------------------------------- -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( aer_ra_feedback == 1) then IF ( .NOT. & ( PRESENT(tauaer300) .AND. & @@ -610,7 +622,7 @@ SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong & end do end do -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( AER_RA_FEEDBACK == 1) then !wig end do ib = 1, 11 @@ -741,12 +753,14 @@ SUBROUTINE GSFCSWRAD(rthraten,gsw,xlat,xlong & ! ... Solar zenith angle ! do i = its,ite - xt24 = mod(xtime + radfrq * 0.5, 1440.) - tloctm = GMT + xt24 / 60. + XLONG(i,j) / 15. - hrang = 15. * (tloctm - 12.) * degrad - xxlat = XLAT(i,j) * degrad - cosz(i) = sin(xxlat) * sin(declin) + & - cos(xxlat) * cos(declin) * cos(hrang) +! PAJ: Use cos zenith angle from the radiation driver: + cosz(i)=coszen(i,j) +! xt24 = mod(xtime + radfrq * 0.5, 1440.) +! tloctm = GMT + xt24 / 60. + XLONG(i,j) / 15. +! hrang = 15. * (tloctm - 12.) * degrad +! xxlat = XLAT(i,j) * degrad +! cosz(i) = sin(xxlat) * sin(declin) + & +! cos(xxlat) * cos(declin) * cos(hrang) rsuvbm(i) = ALB(i,j) rsuvdf(i) = ALB(i,j) rsirbm(i) = ALB(i,j) diff --git a/wrfv2_fire/phys/module_ra_rrtm.F b/wrfv2_fire/phys/module_ra_rrtm.F index 8792593c..38830222 100644 --- a/wrfv2_fire/phys/module_ra_rrtm.F +++ b/wrfv2_fire/phys/module_ra_rrtm.F @@ -1728,7 +1728,9 @@ MODULE module_ra_rrtm CONTAINS !------------------------------------------------------------------ - SUBROUTINE RRTMLWRAD(rthraten,glw,olr,emiss & + SUBROUTINE RRTMLWRAD( & + p_top & + ,rthraten,glw,olr,emiss & ,p8w,p3d,pi3d & ,dz8w,tsk,t3d,t8w,rho3d,r,g & ,icloud, warm_rain & @@ -1826,8 +1828,23 @@ SUBROUTINE RRTMLWRAD(rthraten,glw,olr,emiss & LOGICAL, EXTERNAL :: wrf_dm_on_monitor CHARACTER(LEN=256) :: message +! p_top for vertical nesting + REAL, INTENT(IN ) :: p_top + !------------------------------------------------------------------ + IF ( p_top .GT. 0 ) THEN ! flag value for NMM = -1 +! NLAYERS is recalculated +! every time the radiation scheme is called. This is +! necessary if e_vert parent .NE. e_vert nest since +! NLAYERS could then be different for each domain. + CALL rrtminit( & + p_top, .FALSE. , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + END IF + !----- Calculate the trace gas concentrations from file. !ccc #ifdef CLWRFGHG @@ -1845,9 +1862,9 @@ SUBROUTINE RRTMLWRAD(rthraten,glw,olr,emiss & IF ( wrf_dm_on_monitor() ) THEN WRITE(message,*)'CAM-CLWRF interpolated values______ year:',yr,' julian day:',julian - call wrf_debug( 1, message) + call wrf_debug( 100, message) WRITE(message,*)' CAM-CLWRF co2vmr: ',co2vmr,' n2ovmr:',n2ovmr,' ch4vmr:',ch4vmr - call wrf_debug( 1, message) + call wrf_debug( 100, message) ENDIF @@ -6447,23 +6464,18 @@ SUBROUTINE RTRN(kts,ktep1, & RADLD(IPR) = RADLD(IPR) + (BBD - RADLD(IPR)) * & ABSS(INDEX) DRAD = DRAD + RADLD(IPR) - 2100 CONTINUE ! Set clear sky stream to total sky stream as long as layers ! remain clear. Streams diverge when a cloud is reached. IF (ICLDDN.EQ.1) THEN - DO 2200 IPR = 1, NGPT RADCLRD(IPR) = RADCLRD(IPR) + (BBD - RADCLRD(IPR)) * & ABSS(INDEX) CLRDRAD = CLRDRAD + RADCLRD(IPR) - 2200 CONTINUE ELSE - DO 2300 IPR = 1, NGPT RADCLRD(IPR) = RADLD(IPR) CLRDRAD = DRAD - 2300 CONTINUE ENDIF -! 2100 CONTINUE + 2100 CONTINUE ENDIF diff --git a/wrfv2_fire/phys/module_ra_rrtmg_lw.F b/wrfv2_fire/phys/module_ra_rrtmg_lw.F index c565cd45..5305bb55 100644 --- a/wrfv2_fire/phys/module_ra_rrtmg_lw.F +++ b/wrfv2_fire/phys/module_ra_rrtmg_lw.F @@ -2772,7 +2772,7 @@ subroutine cldprmc(nlayers, inflag, iceflag, liqflag, cldfmc, & data icb /1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5/ - hvrclc = '$Revision: 1.8 $' +!jm not thread safe hvrclc = '$Revision: 1.8 $' ncbands = 1 @@ -3137,7 +3137,7 @@ subroutine rtrnmc(nlayers, istart, iend, iout, pz, semiss, ncbands, & ! htrc ! clear sky longwave heating rate (k/day) - hvrrtc = '$Revision: 1.3 $' +!jm not thread safe hvrrtc = '$Revision: 1.3 $' do ibnd = 1,nbndlw if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then @@ -3556,7 +3556,7 @@ subroutine setcoef(nlayers, istart, pavel, tavel, tz, tbound, semiss, & real(kind=rb) :: plog, fp, ft, ft1, water, scalefac, factor, compfp - hvrset = '$Revision: 1.3 $' +!jm not thread safe hvrset = '$Revision: 1.3 $' stpfac = 296._rb/1013._rb @@ -4934,7 +4934,7 @@ subroutine taumol(nlayers, pavel, wx, coldry, & real(kind=rb), intent(out) :: taug(:,:) ! gaseous optical depth ! Dimensions: (nlayers,ngptlw) - hvrtau = '$Revision: 1.7 $' +!jm not thread safe hvrtau = '$Revision: 1.7 $' ! Calculate gaseous optical depth and planck fractions for each spectral band. @@ -6191,7 +6191,7 @@ subroutine taugb7 fac100 = fs * fac00(lay) fac110 = fs * fac10(lay) endif - if (specparm .lt. 0.125_rb) then + if (specparm1 .lt. 0.125_rb) then p = fs1 - 1 p4 = p**4 fk0 = p4 @@ -7902,7 +7902,7 @@ subroutine rrtmg_lw_ini(cpdair) ! BPADE Inverse of the Pade approximation constant ! - hvrini = '$Revision: 1.3 $' +!jm not thread safe hvrini = '$Revision: 1.3 $' ! Initialize model data call lwdatinit(cpdair) @@ -8017,7 +8017,7 @@ subroutine lwdatinit(cpdair) use parrrtm, only : maxxsec, maxinpx use rrlw_con, only: heatfac, grav, planck, boltz, & clight, avogad, alosmt, gascon, radcn1, radcn2, & - sbcnst, secdy + sbcnst, secdy, fluxfac, oneminus, pi use rrlw_vsn save @@ -8081,6 +8081,12 @@ subroutine lwdatinit(cpdair) ! (W cm-2 K-4) secdy = 8.6400e4_rb ! Number of seconds per day ! (s d-1) + +!jm moved here for thread safety, 20141107 + oneminus = 1._rb - 1.e-6_rb + pi = 2._rb * asin(1._rb) + fluxfac = pi * 2.e4_rb ! orig: fluxfac = pi * 2.d4 + ! ! units are generally cgs ! @@ -10888,9 +10894,9 @@ subroutine rrtmg_lw & ! ! Initializations - oneminus = 1._rb - 1.e-6_rb - pi = 2._rb * asin(1._rb) - fluxfac = pi * 2.e4_rb ! orig: fluxfac = pi * 2.d4 +!jm not thread safe oneminus = 1._rb - 1.e-6_rb +!jm not thread safe pi = 2._rb * asin(1._rb) +!jm not thread safe fluxfac = pi * 2.e4_rb ! orig: fluxfac = pi * 2.d4 istart = 1 iend = 16 iout = 0 @@ -11376,23 +11382,23 @@ MODULE module_ra_rrtmg_lw use mcica_subcol_gen_lw, only: mcica_subcol_lw real retab(95) - data retab / & - 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & - 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & - 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & - 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & - 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & - 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & - 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & - 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & - 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & - 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & - 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & - 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & - 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & - 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & - 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & - 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/ + data retab / & + 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & + 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & + 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & + 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & + 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & + 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & + 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & + 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & + 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & + 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & + 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & + 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & + 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & + 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & + 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & + 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/ ! save retab ! For buffer layer adjustment. Steven Cavallo, Dec 2010. @@ -11726,7 +11732,8 @@ SUBROUTINE RRTMG_LWRAD( & integer :: pcols, pver ! - INTEGER :: i,j,K + INTEGER :: i,j,K, idx_rei + REAL :: corr LOGICAL :: predicate ! Added for top of model adjustment. Steven Cavallo NCAR/MMM December 2010 @@ -11750,17 +11757,17 @@ SUBROUTINE RRTMG_LWRAD( & 0.56,0.48,0.41,0.35,0.30,0.26, & 0.22,0.19,0.16,0.14,0.12,0.10/ DATA TPROF /286.96,281.07,275.16,268.11,260.56,253.02, & - 245.62,238.41,231.57,225.91,221.72,217.79, & - 215.06,212.74,210.25,210.16,210.69,212.14, & - 213.74,215.37,216.82,217.94,219.03,220.18, & - 221.37,222.64,224.16,225.88,227.63,229.51, & - 231.50,233.73,236.18,238.78,241.60,244.44, & - 247.35,250.33,253.32,256.30,259.22,262.12, & - 264.80,266.50,267.59,268.44,268.69,267.76, & - 266.13,263.96,261.54,258.93,256.15,253.23, & - 249.89,246.67,243.48,240.25,236.66,233.86/ + 245.62,238.41,231.57,225.91,221.72,217.79, & + 215.06,212.74,210.25,210.16,210.69,212.14, & + 213.74,215.37,216.82,217.94,219.03,220.18, & + 221.37,222.64,224.16,225.88,227.63,229.51, & + 231.50,233.73,236.18,238.78,241.60,244.44, & + 247.35,250.33,253.32,256.30,259.22,262.12, & + 264.80,266.50,267.59,268.44,268.69,267.76, & + 266.13,263.96,261.54,258.93,256.15,253.23, & + 249.89,246.67,243.48,240.25,236.66,233.86/ !------------------------------------------------------------------ -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( aer_ra_feedback == 1) then IF ( .NOT. & ( PRESENT(tauaerlw1) .AND. & @@ -11799,9 +11806,9 @@ SUBROUTINE RRTMG_LWRAD( & IF ( wrf_dm_on_monitor() ) THEN WRITE(message,*)'CAM-CLWRF interpolated values______ year:',yr,' julian day:',julian - call wrf_debug( 1, message) + call wrf_debug( 100, message) WRITE(message,*)' CAM-CLWRF co2vmr: ',co2,' n2ovmr:',n2o,' ch4vmr:',ch4,' cfc11vmr:',cfc11,' cfc12vmr:',cfc12 - call wrf_debug( 1, message) + call wrf_debug( 100, message) ENDIF #endif @@ -11987,6 +11994,13 @@ SUBROUTINE RRTMG_LWRAD( & inflglw = 3 DO K=kts,kte recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6) + if (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean + recloud1D(ncol,K) = 10.5 + elseif(recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land + recloud1D(ncol,K) = 7.5 + endif ENDDO ELSE DO K=kts,kte @@ -12003,6 +12017,14 @@ SUBROUTINE RRTMG_LWRAD( & iceflglw = 4 DO K=kts,kte reice1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6) + if (reice1D(ncol,K).LE.10..AND.cldfra3d(i,k,j).gt.0.) then + idx_rei = int(t3d(i,k,j)-179.) + idx_rei = min(max(idx_rei,1),75) + corr = t3d(i,k,j) - int(t3d(i,k,j)) + reice1D(ncol,K) = retab(idx_rei)*(1.-corr) + & + & retab(idx_rei+1)*corr + reice1D(ncol,K) = MAX(reice1D(ncol,K), 10.0) + endif ENDDO ELSE DO K=kts,kte @@ -12126,8 +12148,8 @@ SUBROUTINE RRTMG_LWRAD( & do L=kte+1,nlayers+1,1 tlev(ncol,L) = varint(L) + (tlev(ncol,kte) - varint(kte)) !if ( L .le. nlay ) then - tlay(ncol,L-1) = 0.5*(tlev(ncol,L) + tlev(ncol,L-1)) - !endif + tlay(ncol,L-1) = 0.5*(tlev(ncol,L) + tlev(ncol,L-1)) + !endif enddo ! Now the chemical species (except for ozone) @@ -12141,9 +12163,9 @@ SUBROUTINE RRTMG_LWRAD( & cfc12vmr(ncol,L) = cfc12vmr(ncol,kte) cfc22vmr(ncol,L) = cfc22vmr(ncol,kte) ccl4vmr(ncol,L) = ccl4vmr(ncol,kte) - enddo + enddo ! End top of model buffer -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Get ozone profile including amount in extra layer above model top. ! Steven Cavallo: Must pass nlay-1 into subroutine to get nlayers ! dimension for o3mmr @@ -12411,18 +12433,18 @@ SUBROUTINE RRTMG_LWRAD( & endif ! Buffer adjustment. Steven Cavallo December 2010 - do k=kte+1,nlayers - clwpth(ncol,k) = 0. - ciwpth(ncol,k) = 0. - cswpth(ncol,k) = 0. - rel(ncol,k) = 10. + do k=kte+1,nlayers + clwpth(ncol,k) = 0. + ciwpth(ncol,k) = 0. + cswpth(ncol,k) = 0. + rel(ncol,k) = 10. rei(ncol,k) = 10. res(ncol,k) = 10. cldfrac(ncol,k) = 0. - do nb = 1,nbndlw + do nb = 1,nbndlw taucld(nb,ncol,k) = 0. enddo - enddo + enddo iplon = 1 irng = 0 @@ -12453,7 +12475,7 @@ SUBROUTINE RRTMG_LWRAD( & end do end do -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( AER_RA_FEEDBACK == 1) then ! do nb = 1, nbndlw do k = kts,kte !wig @@ -12724,7 +12746,7 @@ SUBROUTINE rrtmg_lwinit( & ! Steven Cavallo. Added for buffer layer adjustment. December 2010. NLAYERS = kme + nint(p_top*0.01/deltap)- 1 ! Model levels plus new levels. ! nlayers will subsequently - ! replace kte+1 + ! replace kte+1 ! Read in absorption coefficients and other data IF ( allowed_to_read ) THEN @@ -14345,7 +14367,7 @@ subroutine reicalc(ncol, pcols, pver, t, re) index = int(t(i,k)-179.) index = min(max(index,1),94) corr = t(i,k) - int(t(i,k)) - re(i,k) = retab(index)*(1.-corr) & + re(i,k) = retab(index)*(1.-corr) & +retab(index+1)*corr ! re(i,k) = amax1(amin1(re(i,k),30.),10.) end do diff --git a/wrfv2_fire/phys/module_ra_rrtmg_lwf.F b/wrfv2_fire/phys/module_ra_rrtmg_lwf.F new file mode 100644 index 00000000..d535d315 --- /dev/null +++ b/wrfv2_fire/phys/module_ra_rrtmg_lwf.F @@ -0,0 +1,18180 @@ +!MODULE module_ra_rrtmg_lwf +#define CHNK 8 +!#define CHNK 1849 +!#define CHNK 43 + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2013, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! Uncomment to use GPU, or comment to use CPU +!#define _ACCEL + +#ifdef _ACCEL +#define _gpudev ,device +#define _gpudeva ,device,allocatable +#define _gpudevanp ,device,allocatable +#define _gpucon ,constant +#define _gpuker attributes(global) +#define _gpuked attributes(device) +#define _gpuchv <<>> +#define _cpus +#define _cpusnp +#else +#define _gpudev +#define _gpudeva ,pointer +#define _gpudevanp ,allocatable +#define _gpucon +#define _gpuker +#define _gpuked +#define _gpuchv +#define _cpus ,target +#define _cpusnp +#endif + +#ifdef _ACCEL +#define dbreg(x) call dbal(x) +#define dbcop(x,y) call dbcp(x, cpointer);call c_f_pointer( cpointer, y, shape(x)) +#define dbcopnp(x,y,t,u) call dbcp(x, cpointer);call c_f_pointer( cpointer, y, shape(x)) +#define dreg(x,y,z) call ddbxeg(x,y,z,cpointer);call c_f_pointer( cpointer, x, [y,z] ) +#define sreg(x,y,z) call ddbxeg(x,y,z,cpointer) +#define dbflushreg() call dbflushrg() +#define dbflushcop() call dbflushcp() +#else +#define dbreg(x) +#define dbcop(x,y) y=>x +#define dbcopnp(x,y,u,v) if (allocated(y).eqv..true.) deallocate(y) ;allocate( y( u, v)); y=x +#define dbflushreg() +#define dbflushcop() +#define dreg(x,y,z) if (allocated(x).eqv..true.) deallocate(x) ;allocate( x( y , z)) +#define sreg(x,y,z) +#endif + +!! !#define _memdiag + +module memory +#ifdef _ACCEL + + +use iso_c_binding +use cudafor +type adr + integer*8 :: loc + integer*8 :: size + integer*8 :: gap + integer :: cindex = 0 + integer :: cnum = 0 + integer :: oindex = 0 + integer :: agn = 0 + type(c_ptr) :: locp +end type + +type adrd + type(c_devptr) :: loc + integer*8 :: size + real, device, allocatable :: ar(:) +end type + + +type(adr) :: plist(500) +type(adr) :: clist(100) +type(adrd) :: dlist(100) +integer :: np = 0 +integer :: nc = 0 +integer :: acgap = 4 +type(c_devptr) :: cpointer + +integer :: ddnp = 0 +real, device, allocatable :: ddar(:) +real, device :: ddtemp(1) +integer :: ddsizec = 0 +integer :: ddindex = 0 +integer :: ddflush = 0 + + + +interface dbal + module procedure dbalr, dbalr2, dbalr3, dbali, dbali2, dbali3 +end interface + +interface dbcp + module procedure dbcpi1, dbcpi2, dbcpi3, dbcpr1, dbcpr2, dbcpr3 +end interface + +interface ddbxeg + module procedure ddbxegi, ddbxegr +end interface + +contains + +subroutine ddbxegi( a, x, y , pt) + integer, allocatable, device :: a(:,:) + integer :: x,y + type(c_devptr), intent(out) :: pt + + + if (ddflush == 0) then + + ddsizec = ddsizec + (x*y) + !pt = c_devloc( ddtemp(1) ) + + else + + pt = c_devloc( ddar( ddindex ) ) + ddindex = ddindex + (x*y) + + end if +end subroutine + + + +subroutine ddbxegr( a, x, y , pt) + real, allocatable, device :: a(:,:) + integer :: x,y + type(c_devptr), intent(out) :: pt + + + if (ddflush == 0) then + + ddsizec = ddsizec + (x*y) + pt = c_devloc( ddtemp(1) ) + + else + + pt = c_devloc( ddar( ddindex ) ) + ddindex = ddindex + (x*y) + + end if +end subroutine + +subroutine dflush() +#ifdef _ACCEL + allocate( ddar( ddsizec + 1 ) ) +#endif + + ddflush = 1 + ddindex = 1 +end subroutine + +subroutine dclean() +#ifdef _ACCEL + deallocate( ddar ) +#endif + ddindex = 0 + ddsizec = 0 + ddflush = 0 +end subroutine + + +subroutine dbgenr( p, s ) + real, intent(in) :: p(*) + integer, intent(in) :: s + np = np + 1 + plist(np)%loc = loc(p(1)) + plist(np)%locp = c_loc(p(1)) + plist(np)%size = s + plist(np)%gap = 0 + plist(np)%oindex = np +#ifdef _memdiag + print *, "index ", np + print *, "real allocation ", np, " loc: ", plist(np)%loc, " size: ", plist(np)%size +#endif +end subroutine + +subroutine dbgeni( p, s ) + integer, intent(in) :: p(*) + integer, intent(in) :: s + np = np + 1 + plist(np)%loc = loc(p(1)) + plist(np)%locp = c_loc(p(1)) + plist(np)%size = s + plist(np)%gap = 0 + plist(np)%oindex = np +#ifdef _memdiag + print *, "index ", np + print *, "integer allocation ", np, " loc: ", plist(np)%loc, " size: ", plist(np)%size +#endif +end subroutine + +subroutine dbalr( p ) + real, intent(in) :: p(:) + call dbgenr( p, size(p) * 4) +end subroutine + +subroutine dbalr2( p) + real, intent(in) :: p(:,:) + call dbgenr( p, size(p) * 4) +end subroutine + +subroutine dbalr3( p) + real, intent(in) :: p(:,:,:) + call dbgenr( p, size(p) * 4) +end subroutine + +subroutine dbali( p ) + integer, intent(in) :: p(:) + call dbgeni( p, size(p) * 4) +end subroutine + +subroutine dbali2( p ) + integer, intent(in) :: p(:,:) + call dbgeni( p, size(p) * 4) +end subroutine + +subroutine dbali3( p ) + integer, intent(in) :: p(:,:,:) + call dbgeni( p, size(p) * 4) +end subroutine + + +subroutine dbflushrg() + integer :: i,j + integer*8 :: loc, size, oin + type(c_ptr) :: locp, cpt + integer :: cpti +#ifdef _memdiag + print *, "analyzing memory" + print *, "sorting entries" +#endif + do j = 1, np + do i = 1, np-1 + + if (plist(i)%loc > plist(i+1)%loc) then + loc = plist(i)%loc + locp = plist(i)%locp + size = plist(i)%size + oin = plist(i)%oindex + + plist(i)%loc = plist(i+1)%loc + plist(i)%locp = plist(i+1)%locp + plist(i)%size = plist(i+1)%size + plist(i)%oindex = plist(i+1)%oindex + plist(i+1)%loc = loc + plist(i+1)%locp = locp + plist(i+1)%size = size + plist(i+1)%oindex = oin + end if + + end do + end do + + do i = 1, np - 1 + plist(i)%gap = plist(i+1)%loc - (plist(i)%loc + plist(i)%size) + end do + plist(np)%gap = 9999999 +#ifdef _memdiag + print *, "sorted elements" +#endif + do i = 1, np +#ifdef _memdiag + print *, plist(i)%loc, plist(i)%size, plist(i)%gap +#endif + if (plist(i)%gap < 0) then + print *, "ERROR! Memory overlap found at index ", plist(i)%oindex + stop + end if + end do +#ifdef _memdiag + print *, "analyzing contiguous regions" +#endif + nc = 1 + clist(1)%loc = plist(1)%loc + clist(1)%cindex = 1 + do i = 1, np + plist(i)%cnum = nc + plist(i)%cindex = clist(nc)%size/4 + + if (plist(i)%gap > acgap) then + clist(nc)%size = clist(nc)%size + plist(i)%size + if (i < np) then + clist(nc+1)%loc = plist(i+1)%loc + clist(nc+1)%cindex = i+1 + end if + nc = nc + 1 + else + clist(nc)%size = clist(nc)%size + plist(i)%size + plist(i)%gap + end if + + end do + nc = nc - 1 + +#ifdef _memdiag + print *, "contiguous regions", nc + print *, "number alloc/copy reduced to ", 100.0 * real(nc)/real(np), "%" + + do i = 1, nc + print *, clist(i)%loc, clist(i)%size + end do + + print *, "allocating device memory" +#endif + do i = 1, nc + + dlist(i)%size = clist(i)%size +#ifdef _memdiag + print *, dlist(i)%size +#endif +#ifdef _ACCEL + allocate( dlist(i)%ar( dlist(i)%size + 2 )) +#endif + dlist(i)%loc = c_devloc( dlist(i)%ar(1) ) + end do + + + +end subroutine + +subroutine dbcpr( p, pt ) + + real, intent(in) :: p(*) + integer*8 :: lc + type(c_devptr), intent(out) :: pt + + +end subroutine + +subroutine dbcpi1( p, pt ) + integer, intent(in) :: p(:) + integer*8 :: lc + type(c_devptr), intent(out) :: pt + lc = loc(p(1)) + call dbcpg( lc, pt) +end subroutine + +subroutine dbcpi2( p, pt ) + integer, intent(in) :: p(:,:) + integer*8 :: lc + type(c_devptr), intent(out) :: pt + lc = loc(p(1,1)) + call dbcpg( lc, pt) +end subroutine + +subroutine dbcpi3( p, pt ) + integer, intent(in) :: p(:,:,:) + integer*8 :: lc + type(c_devptr), intent(out) :: pt + lc = loc(p(1,1,1)) + call dbcpg( lc, pt) +end subroutine + +subroutine dbcpr1( p, pt ) + real, intent(in) :: p(:) + integer*8 :: lc + type(c_devptr), intent(out) :: pt + lc = loc(p(1)) + call dbcpg( lc, pt) +end subroutine + +subroutine dbcpr2( p, pt ) + real, intent(in) :: p(:,:) + integer*8 :: lc + type(c_devptr), intent(out) :: pt + lc = loc(p(1,1)) + call dbcpg( lc, pt) +end subroutine + +subroutine dbcpr3( p, pt ) + real, intent(in) :: p(:,:,:) + integer*8 :: lc + type(c_devptr), intent(out) :: pt + lc = loc(p(1,1,1)) + call dbcpg( lc, pt) +end subroutine + + + +subroutine dbcpg( lc, pt ) + integer*8, intent(in) :: lc + type(c_devptr), intent(out) :: pt + integer :: fl + fl = 0 + do i = 1, np + + if (plist(i)%loc .eq. lc) then +#ifdef _memdiag + print *, "pointer found at index ", i +#endif + pt = c_devloc( dlist( plist(i)%cnum )%ar( plist(i)%cindex+1 )) + fl = 1 + plist(i)%agn = 1 + end if + end do + + if (fl == 0) then + print *, "ERROR! pointer not found!" + stop + end if + +end subroutine + + +subroutine dbflushcp + integer :: i + integer :: err +#ifdef _memdiag + print *, "checking that all pointers are assigned" +#endif + do i = 1, np + if (plist(i)%agn == 0) then + print *, "ERROR! pointer not assigned at index ", plist(i)%oindex + stop + end if + end do +#ifdef _memdiag + print *, "pointers are OK" +#endif + do i=1, nc + err = cudaMemCpyAsync( dlist(i)%loc, plist(clist(i)%cindex)%locp , clist(i)%size+1) + if (err <> 0) then + print *, "ERROR! there was an error with a memory copy" + stop + end if + end do +#ifdef _memdiag + print *, "memory copied successfully" +#endif +end subroutine + +subroutine dbclean + integer :: i + + do i=1, nc + dlist(i)%size=0 + clist(i)%size=0 + +#ifdef _ACCEL + deallocate( dlist(i)%ar ) +#endif + end do + nc = 0 + np = 0 + +end subroutine +#endif +end module + + + + module parrrtm_f + +! use parkind ,only : im => kind + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw main parameters +! +! Initial version: JJMorcrette, ECMWF, Jul 1998 +! Revised: MJIacono, AER, Jun 2006 +! Revised: MJIacono, AER, Aug 2007 +! Revised: MJIacono, AER, Aug 2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! mxlay : integer: maximum number of layers +! mg : integer: number of original g-intervals per spectral band +! nbndlw : integer: number of spectral bands +! maxxsec: integer: maximum number of cross-section molecules +! (e.g. cfcs) +! maxinpx: integer: +! ngptlw : integer: total number of reduced g-intervals for rrtmg_lw +! ngNN : integer: number of reduced g-intervals per spectral band +! ngsNN : integer: cumulative number of g-intervals per band +!------------------------------------------------------------------ + + integer , parameter :: mxlay = 100 + integer , parameter :: mg = 16 + integer , parameter :: nbndlw = 16 + integer , parameter :: maxxsec= 4 + integer , parameter :: mxmol = 38 + integer , parameter :: maxinpx= 38 + integer , parameter :: nmol = 7 +! Use for 140 g-point model + integer , parameter :: ngptlw = 140 +! Use for 256 g-point model +! integer , parameter :: ngptlw = 256 + +! Use for 140 g-point model + integer , parameter :: ng1 = 10 + integer , parameter :: ng2 = 12 + integer , parameter :: ng3 = 16 + integer , parameter :: ng4 = 14 + integer , parameter :: ng5 = 16 + integer , parameter :: ng6 = 8 + integer , parameter :: ng7 = 12 + integer , parameter :: ng8 = 8 + integer , parameter :: ng9 = 12 + integer , parameter :: ng10 = 6 + integer , parameter :: ng11 = 8 + integer , parameter :: ng12 = 8 + integer , parameter :: ng13 = 4 + integer , parameter :: ng14 = 2 + integer , parameter :: ng15 = 2 + integer , parameter :: ng16 = 2 + + integer , parameter :: ngs1 = 10 + integer , parameter :: ngs2 = 22 + integer , parameter :: ngs3 = 38 + integer , parameter :: ngs4 = 52 + integer , parameter :: ngs5 = 68 + integer , parameter :: ngs6 = 76 + integer , parameter :: ngs7 = 88 + integer , parameter :: ngs8 = 96 + integer , parameter :: ngs9 = 108 + integer , parameter :: ngs10 = 114 + integer , parameter :: ngs11 = 122 + integer , parameter :: ngs12 = 130 + integer , parameter :: ngs13 = 134 + integer , parameter :: ngs14 = 136 + integer , parameter :: ngs15 = 138 + +! Use for 256 g-point model +! integer , parameter :: ng1 = 16 +! integer , parameter :: ng2 = 16 +! integer , parameter :: ng3 = 16 +! integer , parameter :: ng4 = 16 +! integer , parameter :: ng5 = 16 +! integer , parameter :: ng6 = 16 +! integer , parameter :: ng7 = 16 +! integer , parameter :: ng8 = 16 +! integer , parameter :: ng9 = 16 +! integer , parameter :: ng10 = 16 +! integer , parameter :: ng11 = 16 +! integer , parameter :: ng12 = 16 +! integer , parameter :: ng13 = 16 +! integer , parameter :: ng14 = 16 +! integer , parameter :: ng15 = 16 +! integer , parameter :: ng16 = 16 + +! integer , parameter :: ngs1 = 16 +! integer , parameter :: ngs2 = 32 +! integer , parameter :: ngs3 = 48 +! integer , parameter :: ngs4 = 64 +! integer , parameter :: ngs5 = 80 +! integer , parameter :: ngs6 = 96 +! integer , parameter :: ngs7 = 112 +! integer , parameter :: ngs8 = 128 +! integer , parameter :: ngs9 = 144 +! integer , parameter :: ngs10 = 160 +! integer , parameter :: ngs11 = 176 +! integer , parameter :: ngs12 = 192 +! integer , parameter :: ngs13 = 208 +! integer , parameter :: ngs14 = 224 +! integer , parameter :: ngs15 = 240 +! integer , parameter :: ngs16 = 256 + + end module parrrtm_f + + module rrlw_cld_f + +! use parkind, only : rb => kind + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw cloud property coefficients + +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! abscld1: real : +! absice0: real : +! absice1: real : +! absice2: real : +! absice3: real : +! absliq0: real : +! absliq1: real : +!------------------------------------------------------------------ + + real :: abscld1 + real , dimension(2) :: absice0 + real , dimension(2,5) :: absice1 + real , dimension(43,16) :: absice2 + real , dimension(46,16) :: absice3 + real :: absliq0 + real , dimension(58,16) :: absliq1 + + end module rrlw_cld_f + + module rrlw_con_f + +! use parkind, only : rb => kind + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw constants + +! Initial version: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! fluxfac: real : radiance to flux conversion factor +! heatfac: real : flux to heating rate conversion factor +!oneminus: real : 1.-1.e-6 +! pi : real : pi +! grav : real : acceleration of gravity +! planck : real : planck constant +! boltz : real : boltzmann constant +! clight : real : speed of light +! avogad : real : avogadro constant +! alosmt : real : loschmidt constant +! gascon : real : molar gas constant +! radcn1 : real : first radiation constant +! radcn2 : real : second radiation constant +! sbcnst : real : stefan-boltzmann constant +! secdy : real : seconds per day +!------------------------------------------------------------------ + + real :: fluxfac, heatfac + real :: oneminus, pi, grav + real :: planck, boltz, clight + real :: avogad, alosmt, gascon + real :: radcn1, radcn2 + real :: sbcnst, secdy + + end module rrlw_con_f + + module rrlw_kg01_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 1 +! band 1: 10-250 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mn2 : real +! kbo_mn2 : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no1 = 16 + + real :: fracrefao(no1) , fracrefbo(no1) + real :: kao(5,13,no1) + real :: kbo(5,13:59,no1) + real :: kao_mn2(19,no1) , kbo_mn2(19,no1) + real :: selfrefo(10,no1), forrefo(4,no1) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 1 +! band 1: 10-250 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! absa : real +! absb : real +! ka_mn2 : real +! kb_mn2 : real +! selfref : real +! forref : real +!----------------------------------------------------------------- + + integer , parameter :: ng1 = 10 + + + real _cpusnp :: ka(5,13,ng1) , absa(65,ng1) + real _cpusnp :: kb(5,13:59,ng1), absb(235,ng1) + real _cpus :: fracrefa(ng1) , fracrefb(ng1) + real _cpus :: ka_mn2(19,ng1) , kb_mn2(19,ng1) + real _cpus :: selfref(10,ng1), forref(4,ng1) + + + real _gpudevanp :: kad(:,:,:), absad(:,:), absbd(:,:) + real _gpudevanp :: kbd(:,:,:) + + real _gpudeva :: fracrefad(:) , fracrefbd(:) + real _gpudeva :: ka_mn2d(:,:) , kb_mn2d(:,:) + real _gpudeva :: selfrefd(:,:), forrefd(:,:) + + equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU1 + + dbcop(fracrefa,fracrefad) + dbcop(fracrefb,fracrefbd) + dbcop(ka_mn2,ka_mn2d) + dbcop(kb_mn2,kb_mn2d) + dbcop(selfref,selfrefd) + dbcop(forref,forrefd) + + dbcopnp(absa , absad , 65 , ng1) + dbcopnp(absb , absbd , 235 , ng1) + + end subroutine + + subroutine reg1 + + dbreg(fracrefa) + dbreg(fracrefb) + dbreg(ka_mn2) + dbreg(kb_mn2) + dbreg(selfref) + dbreg(forref) + dbreg(absa) + dbreg(absb) + + end subroutine + + end module rrlw_kg01_f + + module rrlw_kg02_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 2 +! band 2: 250-500 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no2 = 16 + real _cpus :: kao(5,13,no2) + real _cpus :: kbo(5,13:59,no2) + real _cpus :: fracrefao(no2) , fracrefbo(no2) + real _cpus :: selfrefo(10,no2) , forrefo(4,no2) + + real _gpudeva :: fracrefaod(:) , fracrefbod(:) + real _gpudeva :: selfrefod(:,:) , forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 2 +! band 2: 250-500 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! +! refparam: real +!----------------------------------------------------------------- + + integer , parameter :: ng2 = 12 + + real _cpus :: fracrefa(ng2) , fracrefb(ng2) + real _cpusnp :: ka(5,13,ng2) , absa(65,ng2) + real _cpusnp :: kb(5,13:59,ng2), absb(235,ng2) + real _cpus :: selfref(10,ng2), forref(4,ng2) + + real _gpudeva :: fracrefad(:) , fracrefbd(:) + real _gpudevanp :: absad(:,:) + real _gpudevanp :: absbd(:,:) + real _gpudeva :: selfrefd(:,:), forrefd(:,:) + + real :: refparam(13) + + equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU2 + + dbcop(fracrefao,fracrefaod) + dbcop(fracrefbo,fracrefbod) + dbcop(selfrefo, selfrefod) + dbcop(forrefo, forrefod) + + dbcop(fracrefa,fracrefad) + dbcop(fracrefb,fracrefbd) + + dbcopnp(absa , absad , 65 , ng2) + dbcopnp(absb , absbd , 235 , ng2) + + dbcop(selfref, selfrefd) + dbcop(forref, forrefd) + + end subroutine + + subroutine reg2 + ! 9 + dbreg(fracrefao) + dbreg(fracrefbo) + dbreg(selfrefo) + dbreg(forrefo) + + dbreg(fracrefa) + dbreg(fracrefb) + dbreg(absa) + dbreg(absb) + dbreg(selfref) + dbreg(forref) + + end subroutine + + end module rrlw_kg02_f + + module rrlw_kg03_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 3 +! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mn2o: real +! kbo_mn2o: real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no3 = 16 + + real _cpus :: fracrefao(no3,9) ,fracrefbo(no3,5) + real _cpus :: kao(9,5,13,no3) + real _cpus :: kbo(5,5,13:59,no3) + real _cpus :: kao_mn2o(9,19,no3), kbo_mn2o(5,19,no3) + real _cpus :: selfrefo(10,no3) + real _cpus :: forrefo(4,no3) + + real _gpudeva :: fracrefaod(:,:) ,fracrefbod(:,:) + !real _gpudeva :: kaod(9,5,13,no3) + !real _gpudeva :: kbod(5,5,13:59,no3) + real _gpudeva :: kao_mn2od(:,:,:), kbo_mn2od(:,:,:) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 3 +! band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mn2o : real +! kb_mn2o : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer , parameter :: ng3 = 16 + + real _cpus :: fracrefa(ng3,9) ,fracrefb(ng3,5) + real _cpusnp :: ka(9,5,13,ng3) ,absa(585,ng3) + real _cpusnp :: kb(5,5,13:59,ng3),absb(1175,ng3) + real _cpus :: ka_mn2o(9,19,ng3), kb_mn2o(5,19,ng3) + real _cpus :: selfref(10,ng3) + real _cpus :: forref(4,ng3) + + real _gpudeva :: fracrefad(:,:) ,fracrefbd(:,:) + real _gpudevanp :: absad(:,:) + real _gpudevanp :: absbd(:,:) + real _gpudeva :: ka_mn2od(:,:,:), kb_mn2od(:,:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + + equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU3 + + dbcop( fracrefao , fracrefaod ) + dbcop( fracrefbo , fracrefbod ) + dbcop( kao_mn2o , kao_mn2od ) + dbcop( kbo_mn2o , kbo_mn2od ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + + dbcop( fracrefa , fracrefad ) + dbcop( fracrefb , fracrefbd ) + + dbcopnp( absa , absad , 585 , ng3 ) + dbcopnp( absb , absbd , 1175 , ng3 ) + + dbcop( ka_mn2o , ka_mn2od ) + dbcop( kb_mn2o , kb_mn2od ) + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + end subroutine + + subroutine reg3 + !19 + dbreg( fracrefao ) + dbreg( fracrefbo ) + + dbreg( kao_mn2o ) + dbreg( kbo_mn2o ) + dbreg( selfrefo ) + dbreg( forrefo ) + + dbreg( fracrefa ) + dbreg( fracrefb ) + + dbreg( absa ) + + dbreg( absb ) + dbreg( ka_mn2o ) + dbreg( kb_mn2o ) + dbreg( selfref ) + dbreg( forref ) + + end subroutine + + end module rrlw_kg03_f + + module rrlw_kg04_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 4 +! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + integer , parameter :: ng4 = 14 + integer , parameter :: no4 = 16 + + real _cpus :: kao(9,5,13,no4) + real _cpus :: kbo(5,5,13:59,no4) + real _cpusnp :: ka(9,5,13,ng4) ,absa(585,ng4) + real _cpusnp :: kb(5,5,13:59,ng4),absb(1175,ng4) + + real _cpus :: fracrefao(no4,9) ,fracrefbo(no4,5) + + real _cpus :: selfrefo(10,no4) ,forrefo(4,no4) + + real _gpudeva :: fracrefaod(:,:) ,fracrefbod(:,:) + !real _gpudev :: kaod(9,5,13,no4) + !real _gpudev :: kbod(5,5,13:59,no4) + real _gpudeva :: selfrefod(:,:) ,forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 4 +! band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! absa : real +! absb : real +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! selfref : real +! forref : real +!----------------------------------------------------------------- + + real _cpus :: fracrefa(ng4,9) ,fracrefb(ng4,5) + + real _cpus :: selfref(10,ng4) ,forref(4,ng4) + + real _gpudeva :: fracrefad(:,:) ,fracrefbd(:,:) + real _gpudevanp :: absad(:,:) + real _gpudevanp :: absbd(:,:) + real _gpudeva :: selfrefd(:,:) ,forrefd(:,:) + + equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU4 + + dbcop( fracrefa , fracrefad ) + dbcop( fracrefb , fracrefbd ) + + dbcopnp( absa , absad , 585 , ng4 ) + dbcopnp( absb , absbd , 1175 , ng4) + + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + end subroutine + + subroutine reg4 + !33 + dbreg( fracrefa ) + dbreg( fracrefb ) + + dbreg( absa ) + + dbreg( absb ) + dbreg( selfref ) + dbreg( forref ) + + end subroutine + + end module rrlw_kg04_f + + module rrlw_kg05_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 5 +! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mo3 : real +! selfrefo: real +! forrefo : real +! ccl4o : real +!----------------------------------------------------------------- + + integer , parameter :: no5 = 16 + integer , parameter :: ng5 = 16 + real _cpusnp :: ka(9,5,13,ng5),kb(5,5,13:59,ng5) + real _cpus :: kao(9,5,13,no5) + real _cpus :: kbo(5,5,13:59,no5) + + real _cpus :: fracrefao(no5,9) ,fracrefbo(no5,5) + real _cpusnp :: absa(585,ng5) + + real _cpus :: kao_mo3(9,19,no5) + real _cpus :: selfrefo(10,no5) + real _cpus :: forrefo(4,no5) + real _cpus :: ccl4o(no5) + + + real _gpudeva :: fracrefaod(:,:) ,fracrefbod(:,:) + real _gpudev :: kaod(9,5,13,no5) + real _gpudev :: kbod(5,5,13:59,no5) + real _gpudeva :: kao_mo3d(:,:,:) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + real _gpudeva :: ccl4od(:) +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 5 +! band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mo3 : real +! selfref : real +! forref : real +! ccl4 : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + real _cpusnp :: absb(1175,ng5) + + real _cpus :: fracrefa(ng5,9) ,fracrefb(ng5,5) + + real _cpus :: ka_mo3(9,19,ng5) + real _cpus :: selfref(10,ng5) + real _cpus :: forref(4,ng5) + real _cpus :: ccl4(ng5) + + real _gpudeva :: fracrefad(:,:) ,fracrefbd(:,:) + real _gpudevanp :: absad(:,:) + real _gpudevanp :: absbd(:,:) + real _gpudeva :: ka_mo3d(:,:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + real _gpudeva :: ccl4d(:) + + equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU5 + + dbcop( fracrefao , fracrefaod ) + dbcop( fracrefbo , fracrefbod ) + + dbcop( kao_mo3 , kao_mo3d ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + dbcop( ccl4o , ccl4od ) + + dbcop( fracrefa , fracrefad ) + dbcop( fracrefb , fracrefbd ) + + dbcopnp( absa , absad, 585 , ng5 ) + dbcopnp( absb , absbd, 1175 , ng5 ) + + dbcop( ka_mo3 , ka_mo3d ) + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + dbcop( ccl4 , ccl4d ) + + end subroutine + + subroutine reg5 + + dbreg( fracrefao ) + dbreg( fracrefbo ) + + dbreg( kao_mo3 ) + dbreg( selfrefo ) + dbreg( forrefo ) + dbreg( ccl4o ) + + dbreg( fracrefa ) + dbreg( fracrefb ) + + dbreg( absa ) + + dbreg( absb ) + dbreg( ka_mo3 ) + dbreg( selfref ) + dbreg( forref ) + dbreg( ccl4 ) + + end subroutine + + end module rrlw_kg05_f + + module rrlw_kg06_f + +! use parkind ,only : im => kind , rb => kind + + use memory + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 6 +! band 6: 820-980 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +! kao : real +! kao_mco2: real +! selfrefo: real +! forrefo : real +!cfc11adjo: real +! cfc12o : real +!----------------------------------------------------------------- + + integer , parameter :: no6 = 16 + integer , parameter :: ng6 = 8 + + real _cpusnp :: ka(5,13,ng6),absa(65,ng6) + real _cpus, dimension(no6) :: fracrefao + real _cpus :: kao(5,13,no6) + real _cpus :: kao_mco2(19,no6) + real _cpus :: selfrefo(10,no6) + real _cpus :: forrefo(4,no6) + + real _cpus, dimension(no6) :: cfc11adjo + real _cpus, dimension(no6) :: cfc12o + + real _gpudeva , dimension(:) :: fracrefaod + real _gpudeva :: kaod(:,:,:) + real _gpudeva :: kao_mco2d(:,:) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + + real _gpudeva , dimension(:) :: cfc11adjod + real _gpudeva , dimension(:) :: cfc12od + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 6 +! band 6: 820-980 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +! ka : real +! ka_mco2 : real +! selfref : real +! forref : real +!cfc11adj : real +! cfc12 : real +! +! absa : real +!----------------------------------------------------------------- + + real _cpus, dimension(ng6) :: fracrefa + + real _cpus :: ka_mco2(19,ng6) + real _cpus :: selfref(10,ng6) + real _cpus :: forref(4,ng6) + + real _cpus, dimension(ng6) :: cfc11adj + real _cpus, dimension(ng6) :: cfc12 + + real _gpudeva , dimension(:) :: fracrefad + real _gpudevanp :: absad(:,:) + real _gpudeva :: ka_mco2d(:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + + real _gpudeva , dimension(:) :: cfc11adjd + real _gpudeva , dimension(:) :: cfc12d + + equivalence (ka(1,1,1),absa(1,1)) + + contains + + subroutine copyToGPU6 + + dbcop( fracrefao , fracrefaod ) + dbcop( kao , kaod ) + dbcop( kao_mco2 , kao_mco2d ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + dbcop( cfc11adjo , cfc11adjod ) + dbcop( cfc12o , cfc12od ) + + dbcop( fracrefa , fracrefad ) + + dbcopnp( absa , absad, 65, ng6 ) + dbcop( ka_mco2 , ka_mco2d ) + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + dbcop( cfc11adj , cfc11adjd ) + dbcop( cfc12 , cfc12d ) + + end subroutine + + subroutine reg6 + !53 + dbreg( fracrefao ) + dbreg( kao ) + dbreg( kao_mco2 ) + dbreg( selfrefo ) + dbreg( forrefo ) + dbreg( cfc11adjo ) + dbreg( cfc12o ) + + dbreg( fracrefa ) + + dbreg( absa ) + dbreg( ka_mco2 ) + dbreg( selfref ) + dbreg( forref ) + dbreg( cfc11adj ) + dbreg( cfc12 ) + + end subroutine + + end module rrlw_kg06_f + + module rrlw_kg07_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 7 +! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mco2: real +! kbo_mco2: real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no7 = 16 + integer , parameter :: ng7 = 12 + real _gpudev :: kaod(9,5,13,no7) + real _gpudev :: kbod(5,13:59,no7) + real _cpusnp :: ka(9,5,13,ng7) ,kb(5,13:59,ng7),absa(585,ng7) + real _cpusnp :: absb(235,ng7) + + real _cpus, dimension(no7) :: fracrefbo + real _cpus :: fracrefao(no7,9) + real _cpus :: kao(9,5,13,no7) + real _cpus :: kbo(5,13:59,no7) + real _cpus :: kao_mco2(9,19,no7) + real _cpus :: kbo_mco2(19,no7) + real _cpus :: selfrefo(10,no7) + real _cpus :: forrefo(4,no7) + + real _gpudeva , dimension(:) :: fracrefbod + real _gpudeva :: fracrefaod(:,:) + + real _gpudeva :: kao_mco2d(:,:,:) + real _gpudeva :: kbo_mco2d(:,:) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 7 +! band 7: 980-1080 cm-1 (low - h2o,o3; high - o3) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mco2 : real +! kb_mco2 : real +! selfref : real +! forref : real +! +! absa : real +!----------------------------------------------------------------- + + real _cpus, dimension(ng7) :: fracrefb + real _cpus :: fracrefa(ng7,9) + + real _cpus :: ka_mco2(9,19,ng7) + real _cpus :: kb_mco2(19,ng7) + real _cpus :: selfref(10,ng7) + real _cpus :: forref(4,ng7) + + real _gpudeva , dimension(:) :: fracrefbd + real _gpudeva :: fracrefad(:,:) + real _gpudevanp :: absad(:,:) + real _gpudevanp :: absbd(:,:) + real _gpudeva :: ka_mco2d(:,:,:) + real _gpudeva :: kb_mco2d(:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU7 + + dbcop( fracrefb , fracrefbd ) + dbcop( fracrefa , fracrefad ) + + dbcopnp( absa , absad, 585, ng7 ) + dbcopnp( absb , absbd, 235, ng7 ) + + dbcop( ka_mco2 , ka_mco2d ) + dbcop( kb_mco2 , kb_mco2d ) + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + dbcop( fracrefbo , fracrefbod ) + dbcop( fracrefao , fracrefaod ) + + dbcop( kao_mco2 , kao_mco2d ) + dbcop( kbo_mco2 , kbo_mco2d ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + + end subroutine + + subroutine reg7 + !67 + dbreg( fracrefb ) + dbreg( fracrefa ) + + !dbreg( ka ) + dbreg( absa ) + !dbreg( kb ) + dbreg( absb ) + dbreg( ka_mco2 ) + dbreg( kb_mco2 ) + dbreg( selfref ) + dbreg( forref ) + + dbreg( fracrefbo ) + dbreg( fracrefao ) + !dbreg( kao ) + !dbreg( kbo ) + !dbreg( absbo ) + dbreg( kao_mco2 ) + dbreg( kbo_mco2 ) + dbreg( selfrefo ) + dbreg( forrefo ) + + end subroutine + + end module rrlw_kg07_f + + module rrlw_kg08_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 8 +! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mco2: real +! kbo_mco2: real +! kao_mn2o: real +! kbo_mn2o: real +! kao_mo3 : real +! selfrefo: real +! forrefo : real +! cfc12o : real +!cfc22adjo: real +!----------------------------------------------------------------- + + integer , parameter :: no8 = 16 + + real _cpus, dimension(no8) :: fracrefao + real _cpus, dimension(no8) :: fracrefbo + real _cpus, dimension(no8) :: cfc12o + real _cpus, dimension(no8) :: cfc22adjo + + real _cpus :: kao(5,13,no8) + real _cpus :: kao_mco2(19,no8) + real _cpus :: kao_mn2o(19,no8) + real _cpus :: kao_mo3(19,no8) + real _cpus :: kbo(5,13:59,no8) + real _cpus :: kbo_mco2(19,no8) + real _cpus :: kbo_mn2o(19,no8) + real _cpus :: selfrefo(10,no8) + real _cpus :: forrefo(4,no8) + + real _gpudeva , dimension(:) :: fracrefaod + real _gpudeva , dimension(:) :: fracrefbod + real _gpudeva , dimension(:) :: cfc12od + real _gpudeva , dimension(:) :: cfc22adjod + + real _gpudev :: kaod(5,13,no8) + real _gpudeva :: kao_mco2d(:,:) + real _gpudeva :: kao_mn2od(:,:) + real _gpudeva :: kao_mo3d(:,:) + real _gpudev :: kbod(5,13:59,no8) + real _gpudeva :: kbo_mco2d(:,:) + real _gpudeva :: kbo_mn2od(:,:) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 8 +! band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mco2 : real +! kb_mco2 : real +! ka_mn2o : real +! kb_mn2o : real +! ka_mo3 : real +! selfref : real +! forref : real +! cfc12 : real +! cfc22adj: real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer , parameter :: ng8 = 8 + + real _cpus, dimension(ng8) :: fracrefa + real _cpus, dimension(ng8) :: fracrefb + real _cpus, dimension(ng8) :: cfc12 + real _cpus, dimension(ng8) :: cfc22adj + + real _cpusnp :: ka(5,13,ng8) ,absa(65,ng8) + real _cpusnp :: kb(5,13:59,ng8) ,absb(235,ng8) + real _cpus :: ka_mco2(19,ng8) + real _cpus :: ka_mn2o(19,ng8) + real _cpus :: ka_mo3(19,ng8) + real _cpus :: kb_mco2(19,ng8) + real _cpus :: kb_mn2o(19,ng8) + real _cpus :: selfref(10,ng8) + real _cpus :: forref(4,ng8) + + real _gpudeva , dimension(:) :: fracrefad + real _gpudeva , dimension(:) :: fracrefbd + real _gpudeva , dimension(:) :: cfc12d + real _gpudeva , dimension(:) :: cfc22adjd + + real _gpudevanp :: absad(:,:) + real _gpudevanp :: absbd(:,:) + real _gpudeva :: ka_mco2d(:,:) + real _gpudeva :: ka_mn2od(:,:) + real _gpudeva :: ka_mo3d(:,:) + real _gpudeva :: kb_mco2d(:,:) + real _gpudeva :: kb_mn2od(:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + + equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU8 + + kaod = kao + kbod = kbo + + dbcop( fracrefao , fracrefaod ) + dbcop( fracrefbo , fracrefbod ) + dbcop( cfc12o , cfc12od ) + dbcop( cfc22adjo , cfc22adjod ) + + dbcop( kao_mco2 , kao_mco2d ) + dbcop( kao_mn2o , kao_mn2od ) + dbcop( kao_mo3 , kao_mo3d ) + + dbcop( kbo_mco2 , kbo_mco2d ) + dbcop( kbo_mn2o , kbo_mn2od ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + + dbcop( fracrefa , fracrefad ) + dbcop( fracrefb , fracrefbd ) + dbcop( cfc12 , cfc12d ) + dbcop( cfc22adj , cfc22adjd ) + + dbcopnp( absa , absad, 65 , ng8 ) + dbcopnp( absb , absbd, 235 , ng8 ) + + dbcop( ka_mco2 , ka_mco2d ) + dbcop( ka_mn2o , ka_mn2od ) + dbcop( ka_mo3 , ka_mo3d ) + dbcop( kb_mco2 , kb_mco2d ) + dbcop( kb_mn2o , kb_mn2od ) + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + end subroutine + + subroutine reg8 + + dbreg( fracrefao ) + dbreg( fracrefbo ) + dbreg( cfc12o ) + dbreg( cfc22adjo ) + + dbreg( kao_mco2 ) + dbreg( kao_mn2o ) + dbreg( kao_mo3 ) + + dbreg( kbo_mco2 ) + dbreg( kbo_mn2o ) + dbreg( selfrefo ) + dbreg( forrefo ) + + dbreg( fracrefa ) + dbreg( fracrefb ) + dbreg( cfc12 ) + dbreg( cfc22adj ) + dbreg( absa ) + dbreg( absb ) + dbreg( ka_mco2 ) + dbreg( ka_mn2o ) + dbreg( ka_mo3 ) + dbreg( kb_mco2 ) + dbreg( kb_mn2o ) + dbreg( selfref ) + dbreg( forref ) + + end subroutine + + end module rrlw_kg08_f + + module rrlw_kg09_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 9 +! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mn2o: real +! kbo_mn2o: real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no9 = 16 + + real _cpus, dimension(no9) :: fracrefbo + + real _cpus :: fracrefao(no9,9) + real _cpus :: kao(9,5,13,no9) + real _cpus :: kbo(5,13:59,no9) + real _cpus :: kao_mn2o(9,19,no9) + real _cpus :: kbo_mn2o(19,no9) + real _cpus :: selfrefo(10,no9) + real _cpus :: forrefo(4,no9) + + real _gpudeva , dimension(:) :: fracrefbod + + real _gpudeva :: fracrefaod(:,:) + real _gpudev :: kaod(9,5,13,no9) + real _gpudev :: kbod(5,13:59,no9) + real _gpudeva :: kao_mn2od(:,:,:) + real _gpudeva :: kbo_mn2od(:,:) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 9 +! band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mn2o : real +! kb_mn2o : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer , parameter :: ng9 = 12 + + real _cpus, dimension(ng9) :: fracrefb + real _cpus :: fracrefa(ng9,9) + real _cpusnp :: ka(9,5,13,ng9) ,absa(585,ng9) + real _cpusnp :: kb(5,13:59,ng9) ,absb(235,ng9) + real _cpus :: ka_mn2o(9,19,ng9) + real _cpus :: kb_mn2o(19,ng9) + real _cpus :: selfref(10,ng9) + real _cpus :: forref(4,ng9) + + real _gpudeva , dimension(:) :: fracrefbd + real _gpudeva :: fracrefad(:,:) + real _gpudevanp :: absad(:,:) + real _gpudevanp :: absbd(:,:) + real _gpudeva :: ka_mn2od(:,:,:) + real _gpudeva :: kb_mn2od(:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + + equivalence (ka(1,1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU9 + + kaod = kao + kbod = kbo + + dbcop( fracrefao , fracrefaod ) + dbcop( fracrefbo , fracrefbod ) + + dbcopnp( absa , absad , 585 , ng9 ) + dbcopnp( absb , absbd, 235 , ng9 ) + + dbcop( kao_mn2o , kao_mn2od ) + dbcop( kbo_mn2o , kbo_mn2od ) + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + dbcop( fracrefa , fracrefad ) + dbcop( fracrefb , fracrefbd ) + + dbcop( ka_mn2o , ka_mn2od ) + dbcop( kb_mn2o , kb_mn2od ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + + end subroutine + + subroutine reg9 + + !105 + dbreg( fracrefao ) + dbreg( fracrefbo ) + + dbreg( kao_mn2o ) + dbreg( kbo_mn2o ) + dbreg( selfrefo ) + dbreg( forrefo ) + + dbreg( fracrefa ) + dbreg( fracrefb ) + + dbreg( absa ) + dbreg( absb ) + dbreg( ka_mn2o ) + dbreg( kb_mn2o ) + dbreg( selfref ) + dbreg( forref ) + + end subroutine + + end module rrlw_kg09_f + + module rrlw_kg10_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 10 +! band 10: 1390-1480 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no10 = 16 + + real _cpus, dimension(no10) :: fracrefao + real _cpus, dimension(no10) :: fracrefbo + + real _cpus :: kao(5,13,no10) + real _cpus :: kbo(5,13:59,no10) + real _cpus :: selfrefo(10,no10) + real _cpus :: forrefo(4,no10) + + real _gpudeva , dimension(:) :: fracrefaod + real _gpudeva , dimension(:) :: fracrefbod + + real _gpudev :: kaod(5,13,no10) + real _gpudev :: kbod(5,13:59,no10) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 10 +! band 10: 1390-1480 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer , parameter :: ng10 = 6 + + real _cpus , dimension(ng10) :: fracrefa + real _cpus , dimension(ng10) :: fracrefb + + real _cpusnp :: ka(5,13,ng10) , absa(65,ng10) + real _cpusnp :: kb(5,13:59,ng10), absb(235,ng10) + real _cpus :: selfref(10,ng10) + real _cpus :: forref(4,ng10) + + real _gpudeva , dimension(:) :: fracrefad + real _gpudeva , dimension(:) :: fracrefbd + + real _gpudevanp :: absad(:,:) + real _gpudevanp :: absbd(:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + + equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU10 + + kaod = kao + kbod = kbo + + dbcop( fracrefao , fracrefaod ) + dbcop( fracrefbo , fracrefbod ) + + !dbcop( kao , kaod ) + !dbcop( kbo , kbod ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + + dbcop( fracrefa , fracrefad ) + dbcop( fracrefb , fracrefbd ) + + !dbcop( ka , kad ) + !dbcop( kb , kbd ) + dbcopnp( absa , absad, 65 , ng10 ) + dbcopnp( absb , absbd, 235 , ng10 ) + + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + end subroutine + + subroutine reg10 + + dbreg( fracrefao ) + dbreg( fracrefbo ) + + !dbreg( kao ) + !dbreg( kbo ) + dbreg( selfrefo ) + dbreg( forrefo ) + + dbreg( fracrefa ) + dbreg( fracrefb ) + + !dbreg( ka ) + !dbreg( kb ) + dbreg( absa ) + dbreg( absb ) + dbreg( selfref ) + dbreg( forref ) + + end subroutine + + end module rrlw_kg10_f + + module rrlw_kg11_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 11 +! band 11: 1480-1800 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! kao_mo2 : real +! kbo_mo2 : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no11 = 16 + + real _cpus, dimension(no11) :: fracrefao + real _cpus, dimension(no11) :: fracrefbo + + real _cpus :: kao(5,13,no11) + real _cpus :: kbo(5,13:59,no11) + real _cpus :: kao_mo2(19,no11) + real _cpus :: kbo_mo2(19,no11) + real _cpus :: selfrefo(10,no11) + real _cpus :: forrefo(4,no11) + + real _gpudeva , dimension(:) :: fracrefaod + real _gpudeva , dimension(:) :: fracrefbod + + real _gpudev :: kaod(5,13,no11) + real _gpudev :: kbod(5,13:59,no11) + real _gpudeva :: kao_mo2d(:,:) + real _gpudeva :: kbo_mo2d(:,:) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 11 +! band 11: 1480-1800 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! ka_mo2 : real +! kb_mo2 : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer , parameter :: ng11 = 8 + + real _cpus, dimension(ng11) :: fracrefa + real _cpus, dimension(ng11) :: fracrefb + + real _cpusnp :: ka(5,13,ng11) , absa(65,ng11) + real _cpusnp :: kb(5,13:59,ng11), absb(235,ng11) + real _cpus :: ka_mo2(19,ng11) + real _cpus :: kb_mo2(19,ng11) + real _cpus :: selfref(10,ng11) + real _cpus :: forref(4,ng11) + + real _gpudeva , dimension(:) :: fracrefad + real _gpudeva , dimension(:) :: fracrefbd + + real _gpudevanp :: absad(:,:) + real _gpudevanp :: absbd(:,:) + real _gpudeva :: ka_mo2d(:,:) + real _gpudeva :: kb_mo2d(:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + + equivalence (ka(1,1,1),absa(1,1)),(kb(1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU11 + + dbcop( fracrefa , fracrefad ) + dbcop( fracrefb , fracrefbd ) + + dbcopnp( absa , absad , 65 , ng11 ) + dbcopnp( absb , absbd , 235 , ng11 ) + + dbcop( ka_mo2 , ka_mo2d ) + dbcop( kb_mo2 , kb_mo2d ) + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + end subroutine + + subroutine reg11 + + dbreg( fracrefa ) + dbreg( fracrefb ) + + !dbreg( ka ) + dbreg( absa ) + !dbreg( kb ) + dbreg( absb ) + dbreg( ka_mo2 ) + dbreg( kb_mo2 ) + dbreg( selfref ) + dbreg( forref ) + + end subroutine + + end module rrlw_kg11_f + + module rrlw_kg12_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 12 +! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +! kao : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no12 = 16 + + real _cpus :: fracrefao(no12,9) + real _cpus :: kao(9,5,13,no12) + real _cpus :: selfrefo(10,no12) + real _cpus :: forrefo(4,no12) + + real _gpudeva :: fracrefaod(:,:) + real _gpudev :: kaod(9,5,13,no12) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 12 +! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +! ka : real +! selfref : real +! forref : real +! +! absa : real +!----------------------------------------------------------------- + + integer , parameter :: ng12 = 8 + + real _cpus :: fracrefa(ng12,9) + real _cpusnp :: ka(9,5,13,ng12) ,absa(585,ng12) + real _cpus :: selfref(10,ng12) + real _cpus :: forref(4,ng12) + + real _gpudeva :: fracrefad(:,:) + real _gpudevanp :: absad(:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + + equivalence (ka(1,1,1,1),absa(1,1)) + + contains + + subroutine copyToGPU12 + + kao = kaod + + dbcop( fracrefao , fracrefaod ) + !dbcop( kao , kaod ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + + dbcop( fracrefa , fracrefad ) + !dbcop( ka , kad ) + dbcopnp( absa , absad , 585 , ng12 ) + + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + end subroutine + + subroutine reg12 + + dbreg( fracrefao ) + !dbreg( kao ) + dbreg( selfrefo ) + dbreg( forrefo ) + + dbreg( fracrefa ) + !dbreg( ka ) + dbreg( absa ) + + dbreg( selfref ) + dbreg( forref ) + + end subroutine + + end module rrlw_kg12_f + + module rrlw_kg13_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 13 +! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +! kao : real +! kao_mco2: real +! kao_mco : real +! kbo_mo3 : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no13 = 16 + + real _cpus, dimension(no13) :: fracrefbo + + real _cpus :: fracrefao(no13,9) + real _cpus :: kao(9,5,13,no13) + real _cpus :: kao_mco2(9,19,no13) + real _cpus :: kao_mco(9,19,no13) + real _cpus :: kbo_mo3(19,no13) + real _cpus :: selfrefo(10,no13) + real _cpus :: forrefo(4,no13) + + real _gpudeva , dimension(:) :: fracrefbod + + real _gpudeva :: fracrefaod(:,:) + real _gpudev :: kaod(9,5,13,no13) + real _gpudeva :: kao_mco2d(:,:,:) + real _gpudeva :: kao_mcod(:,:,:) + real _gpudeva :: kbo_mo3d(:,:) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 13 +! band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +! ka : real +! ka_mco2 : real +! ka_mco : real +! kb_mo3 : real +! selfref : real +! forref : real +! +! absa : real +!----------------------------------------------------------------- + + integer , parameter :: ng13 = 4 + + real _cpus, dimension(ng13) :: fracrefb + + real _cpus :: fracrefa(ng13,9) + real _cpusnp :: ka(9,5,13,ng13) ,absa(585,ng13) + real _cpus :: ka_mco2(9,19,ng13) + real _cpus :: ka_mco(9,19,ng13) + real _cpus :: kb_mo3(19,ng13) + real _cpus :: selfref(10,ng13) + real _cpus :: forref(4,ng13) + + real _gpudeva , dimension(:) :: fracrefbd + + real _gpudeva :: fracrefad(:,:) + real _gpudevanp :: absad(:,:) + real _gpudeva :: ka_mco2d(:,:,:) + real _gpudeva :: ka_mcod(:,:,:) + real _gpudeva :: kb_mo3d(:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + + equivalence (ka(1,1,1,1),absa(1,1)) + + contains + + subroutine copyToGPU13 + + kaod = kao + + dbcop( fracrefbo , fracrefbod ) + dbcop( fracrefao , fracrefaod ) + + dbcop( kao_mco2 , kao_mco2d ) + dbcop( kao_mco , kao_mcod ) + dbcop( kbo_mo3 , kbo_mo3d ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + + dbcop( fracrefb , fracrefbd ) + dbcop( fracrefa , fracrefad ) + + dbcopnp( absa , absad , 585 , ng13) + + dbcop( ka_mco2 , ka_mco2d ) + dbcop( ka_mco , ka_mcod ) + dbcop( kb_mo3 , kb_mo3d ) + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + end subroutine + + subroutine reg13 + + dbreg( fracrefbo ) + dbreg( fracrefao ) + !dbreg( kao ) + dbreg( kao_mco2 ) + dbreg( kao_mco ) + dbreg( kbo_mo3 ) + dbreg( selfrefo ) + dbreg( forrefo ) + + dbreg( fracrefb ) + dbreg( fracrefa ) + !dbreg( ka ) + dbreg( absa ) + dbreg( ka_mco2 ) + dbreg( ka_mco ) + dbreg( kb_mo3 ) + dbreg( selfref ) + dbreg( forref ) + + end subroutine + + end module rrlw_kg13_f + + module rrlw_kg14_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 14 +! band 14: 2250-2380 cm-1 (low - co2; high - co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +!fracrefbo: real +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no14 = 16 + + real _cpus, dimension(no14) :: fracrefao + real _cpus, dimension(no14) :: fracrefbo + + real _cpus :: kao(5,13,no14) + real _cpus :: kbo(5,13:59,no14) + real _cpus :: selfrefo(10,no14) + real _cpus :: forrefo(4,no14) + + real _gpudeva , dimension(:) :: fracrefaod + real _gpudeva , dimension(:) :: fracrefbod + + real _gpudev :: kaod(5,13,no14) + real _gpudev :: kbod(5,13:59,no14) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 14 +! band 14: 2250-2380 cm-1 (low - co2; high - co2) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +!fracrefb : real +! ka : real +! kb : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer , parameter :: ng14 = 2 + + real _cpus, dimension(ng14) :: fracrefa + real _cpus, dimension(ng14) :: fracrefb + + real _cpusnp :: ka(5,13,ng14) ,absa(65,ng14) + real _cpusnp :: kb(5,13:59,ng14),absb(235,ng14) + real _cpus :: selfref(10,ng14) + real _cpus :: forref(4,ng14) + + real _gpudeva , dimension(:) :: fracrefad + real _gpudeva , dimension(:) :: fracrefbd + + real _gpudevanp :: absad(:,:) + real _gpudevanp :: absbd(:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + + equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU14 + + kaod = kao + kbod = kbo + + dbcop( fracrefao , fracrefaod ) + dbcop( fracrefbo , fracrefbod ) + + !dbcop( kao , kaod ) + !dbcop( kbo , kbod ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + + dbcop( fracrefa , fracrefad ) + dbcop( fracrefb , fracrefbd ) + + !dbcop( ka , kad ) + !dbcop( kb , kbd ) + dbcopnp( absa , absad , 65 , ng14 ) + dbcopnp( absb , absbd , 235 , ng14 ) + + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + end subroutine + + subroutine reg14 + + dbreg( fracrefao ) + dbreg( fracrefbo ) + + !dbreg( kao ) + !dbreg( kbo ) + dbreg( selfrefo ) + dbreg( forrefo ) + + dbreg( fracrefa ) + dbreg( fracrefb ) + + !dbreg( ka ) + !dbreg( kb ) + dbreg( absa ) + dbreg( absb ) + dbreg( selfref ) + dbreg( forref ) + + end subroutine + + end module rrlw_kg14_f + + module rrlw_kg15_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 15 +! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +! kao : real +! kao_mn2 : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no15 = 16 + + real _cpus :: fracrefao(no15,9) + real _cpus :: kao(9,5,13,no15) + real _cpus :: kao_mn2(9,19,no15) + real _cpus :: selfrefo(10,no15) + real _cpus :: forrefo(4,no15) + + real _gpudeva :: fracrefaod(:,:) + real _gpudev :: kaod(9,5,13,no15) + real _gpudeva :: kao_mn2d(:,:,:) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 15 +! band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +! ka : real +! ka_mn2 : real +! selfref : real +! forref : real +! +! absa : real +!----------------------------------------------------------------- + + integer , parameter :: ng15 = 2 + + real _cpus :: fracrefa(ng15,9) + real _cpusnp :: ka(9,5,13,ng15) ,absa(585,ng15) + real _cpus :: ka_mn2(9,19,ng15) + real _cpus :: selfref(10,ng15) + real _cpus :: forref(4,ng15) + + real _gpudeva :: fracrefad(:,:) + real _gpudevanp :: absad(:,:) + real _gpudeva :: ka_mn2d(:,:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + + equivalence (ka(1,1,1,1),absa(1,1)) + + contains + + subroutine copyToGPU15 + + kaod = kao + + dbcop( fracrefao , fracrefaod ) + !dbcop( kao , kaod ) + dbcop( kao_mn2 , kao_mn2d ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + + dbcop( fracrefa , fracrefad ) + !dbcop( ka , kad ) + + dbcopnp( absa , absad , 585 , ng15 ) + + dbcop( ka_mn2 , ka_mn2d ) + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + end subroutine + + subroutine reg15 + + dbreg( fracrefao ) + !dbreg( kao ) + dbreg( kao_mn2 ) + dbreg( selfrefo ) + dbreg( forrefo ) + + dbreg( fracrefa ) + !dbreg( ka ) + dbreg( absa ) + dbreg( ka_mn2 ) + dbreg( selfref ) + dbreg( forref ) + + end subroutine + + end module rrlw_kg15_f + + module rrlw_kg16_f + +! use parkind ,only : im => kind , rb => kind + + use memory +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_lw ORIGINAL abs. coefficients for interval 16 +! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefao: real +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!----------------------------------------------------------------- + + integer , parameter :: no16 = 16 + + real _cpus, dimension(no16) :: fracrefbo + + real _cpus :: fracrefao(no16,9) + real _cpus :: kao(9,5,13,no16) + real _cpus :: kbo(5,13:59,no16) + real _cpus :: selfrefo(10,no16) + real _cpus :: forrefo(4,no16) + + real _gpudeva , dimension(:) :: fracrefbod + real _gpudeva :: fracrefaod(:,:) + real _gpudev :: kaod(9,5,13,no16) + real _gpudev :: kbod(5,13:59,no16) + real _gpudeva :: selfrefod(:,:) + real _gpudeva :: forrefod(:,:) + +!----------------------------------------------------------------- +! rrtmg_lw COMBINED abs. coefficients for interval 16 +! band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!fracrefa : real +! ka : real +! kb : real +! selfref : real +! forref : real +! +! absa : real +! absb : real +!----------------------------------------------------------------- + + integer , parameter :: ng16 = 2 + + real _cpus, dimension(ng16) :: fracrefb + + real _cpus :: fracrefa(ng16,9) + real _cpusnp :: ka(9,5,13,ng16) ,absa(585,ng16) + real _cpusnp :: kb(5,13:59,ng16), absb(235,ng16) + real _cpus :: selfref(10,ng16) + real _cpus :: forref(4,ng16) + + real _gpudeva , dimension(:) :: fracrefbd + + real _gpudeva :: fracrefad(:,:) + real _gpudevanp :: absad(:,:) + real _gpudevanp :: absbd(:,:) + real _gpudeva :: selfrefd(:,:) + real _gpudeva :: forrefd(:,:) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + contains + + subroutine copyToGPU16 + + kaod = kao + kbod = kbo + + dbcop( fracrefao , fracrefaod ) + + !dbcop( kao , kaod ) + !dbcop( kbo , kbod ) + dbcop( selfrefo , selfrefod ) + dbcop( forrefo , forrefod ) + + dbcop( fracrefa , fracrefad ) + dbcop( fracrefb , fracrefbd ) + + !dbcop( ka , kad ) + !dbcop( kb , kbd ) + dbcopnp( absa , absad , 585 , ng16) + dbcopnp( absb , absbd , 235 , ng16) + + dbcop( selfref , selfrefd ) + dbcop( forref , forrefd ) + + end subroutine + + subroutine reg16 + + dbreg( fracrefao ) + + !dbreg( kao ) + !dbreg( kbo ) + dbreg( selfrefo ) + dbreg( forrefo ) + + dbreg( fracrefa ) + dbreg( fracrefb ) + + !dbreg( ka ) + !dbreg( kb ) + dbreg( absa ) + dbreg( absb ) + dbreg( selfref ) + dbreg( forref ) + + end subroutine + + end module rrlw_kg16_f + + module rrlw_ncpar + +! use parkind ,only : im => kind , rb => kind + +! implicit none + save + + real , parameter :: cpdair = 1003.5 ! Specific heat capacity of dry air + ! at constant pressure at 273 K + ! (J kg-1 K-1) + + + integer , parameter :: maxAbsorberNameLength = 5, & + Absorber = 12 + character(len = maxAbsorberNameLength), dimension(Absorber), parameter :: & + AbsorberNames = (/ & + 'N2 ', & + 'CCL4 ', & + 'CFC11', & + 'CFC12', & + 'CFC22', & + 'H2O ', & + 'CO2 ', & + 'O3 ', & + 'N2O ', & + 'CO ', & + 'CH4 ', & + 'O2 ' /) + + integer , dimension(40) :: status + integer :: i + integer , parameter :: keylower = 9, & + keyupper = 5, & + Tdiff = 5, & + ps = 59, & + plower = 13, & + pupper = 47, & + Tself = 10, & + Tforeign = 4, & + pforeign = 4, & + T = 19, & + Tplanck = 181, & + band = 16, & + GPoint = 16, & + GPointSet = 2 + + contains + + subroutine getAbsorberIndex(AbsorberName,AbsorberIndex) + character(len = *), intent(in) :: AbsorberName + integer , intent(out) :: AbsorberIndex + + integer :: m + + AbsorberIndex = -1 + do m = 1, Absorber + if (trim(AbsorberNames(m)) == trim(AbsorberName)) then + AbsorberIndex = m + end if + end do + + if (AbsorberIndex == -1) then + print*, "Absorber name index lookup failed." + end if + end subroutine getAbsorberIndex + + end module rrlw_ncpar + + module rrlw_ref_f + +! use parkind, only : im => kind , rb => kind + +! implicit none + +!------------------------------------------------------------------ +! rrtmg_lw reference atmosphere +! Based on standard mid-latitude summer profile +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! pref : real : Reference pressure levels +! preflog: real : Reference pressure levels, ln(pref) +! tref : real : Reference temperature levels for MLS profile +! chi_mls: real : +!------------------------------------------------------------------ + + real , dimension(59) :: pref + real , dimension(59) :: preflog + real , dimension(59) :: tref + real :: chi_mls(7,59) + + ! (dmb 2012) These GPU arrays are defined as constant so that they are cached. + ! This is really needed because they accessed in quite a scattered pattern. + real _gpucon :: chi_mlsd(7,59) + real _gpucon :: preflogd(59) + real _gpucon :: trefd(59) + +#ifndef _ACCEL +# define chi_mlsd chi_mls +# define preflogd preflog +# define trefd tref +#endif + + contains + + ! (dmb 2012) Copy the reference arrays over to the GPU + subroutine copyToGPUref() + + chi_mlsd = chi_mls + preflogd = preflog + trefd = tref + + end subroutine + + end module rrlw_ref_f + + module rrlw_tbl_f + +! use parkind, only : im => kind , rb => kind + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw exponential lookup table arrays + +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, Jun 2006 +! Revised: MJIacono, AER, Aug 2007 +! Revised: MJIacono, AER, Aug 2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! ntbl : integer: Lookup table dimension +! tblint : real : Lookup table conversion factor +! tau_tbl: real : Clear-sky optical depth (used in cloudy radiative +! transfer) +! exp_tbl: real : Transmittance lookup table +! tfn_tbl: real : Tau transition function; i.e. the transition of +! the Planck function from that for the mean layer +! temperature to that for the layer boundary +! temperature as a function of optical depth. +! The "linear in tau" method is used to make +! the table. +! pade : real : Pade constant +! bpade : real : Inverse of Pade constant +!------------------------------------------------------------------ + + integer , parameter :: ntbl = 10000 + + real , parameter :: tblint = 10000.0 + + real , dimension(0:ntbl) :: tau_tbl + real , dimension(0:ntbl) :: exp_tbl + real , dimension(0:ntbl) :: tfn_tbl + + real , parameter :: pade = 0.278 + real :: bpade + + end module rrlw_tbl_f + + module rrlw_vsn_f + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw version information + +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +!hnamrtm :character: +!hnamini :character: +!hnamcld :character: +!hnamclc :character: +!hnamrtr :character: +!hnamrtx :character: +!hnamrtc :character: +!hnamset :character: +!hnamtau :character: +!hnamatm :character: +!hnamutl :character: +!hnamext :character: +!hnamkg :character: +! +! hvrrtm :character: +! hvrini :character: +! hvrcld :character: +! hvrclc :character: +! hvrrtr :character: +! hvrrtx :character: +! hvrrtc :character: +! hvrset :character: +! hvrtau :character: +! hvratm :character: +! hvrutl :character: +! hvrext :character: +! hvrkg :character: +!------------------------------------------------------------------ + + character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrtr,hvrrtx, & + hvrrtc,hvrset,hvrtau,hvratm,hvrutl,hvrext + character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrtr,hnamrtx, & + hnamrtc,hnamset,hnamtau,hnamatm,hnamutl,hnamext + + character*18 hvrkg + character*20 hnamkg + + end module rrlw_vsn_f + + module rrlw_wvn_f + +! use parkind, only : im => kind , rb => kind + use parrrtm_f, only : nbndlw, mg, ngptlw, maxinpx + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_lw spectral information + +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! ng : integer: Number of original g-intervals in each spectral band +! nspa : integer: For the lower atmosphere, the number of reference +! atmospheres that are stored for each spectral band +! per pressure level and temperature. Each of these +! atmospheres has different relative amounts of the +! key species for the band (i.e. different binary +! species parameters). +! nspb : integer: Same as nspa for the upper atmosphere +!wavenum1: real : Spectral band lower boundary in wavenumbers +!wavenum2: real : Spectral band upper boundary in wavenumbers +! delwave: real : Spectral band width in wavenumbers +! totplnk: real : Integrated Planck value for each band; (band 16 +! includes total from 2600 cm-1 to infinity) +! Used for calculation across total spectrum +!totplk16: real : Integrated Planck value for band 16 (2600-3250 cm-1) +! Used for calculation in band 16 only if +! individual band output requested +!totplnkderiv: real: Integrated Planck function derivative with respect +! to temperature for each band; (band 16 +! includes total from 2600 cm-1 to infinity) +! Used for calculation across total spectrum +!totplk16deriv:real: Integrated Planck function derivative with respect +! to temperature for band 16 (2600-3250 cm-1) +! Used for calculation in band 16 only if +! individual band output requested +! +! ngc : integer: The number of new g-intervals in each band +! ngs : integer: The cumulative sum of new g-intervals for each band +! ngm : integer: The index of each new g-interval relative to the +! original 16 g-intervals in each band +! ngn : integer: The number of original g-intervals that are +! combined to make each new g-intervals in each band +! ngb : integer: The band index for each new g-interval +! wt : real : RRTM weights for the original 16 g-intervals +! rwgt : real : Weights for combining original 16 g-intervals +! (256 total) into reduced set of g-intervals +! (140 total) +! nxmol : integer: Number of cross-section molecules +! ixindx : integer: Flag for active cross-sections in calculation +!------------------------------------------------------------------ + + integer :: ng(nbndlw) + integer :: nspa(nbndlw) + integer :: nspb(nbndlw) + + real :: wavenum1(nbndlw) + real :: wavenum2(nbndlw) + real :: delwave(nbndlw) + + real :: totplnk(181,nbndlw) + real :: totplk16(181) + + real :: totplnkderiv(181,nbndlw) + real :: totplk16deriv(181) + + integer :: ngc(nbndlw) + integer :: ngs(nbndlw) + integer :: ngn(ngptlw) + integer :: ngb(ngptlw) + integer :: ngm(nbndlw*mg) + + real :: wt(mg) + real :: rwgt(nbndlw*mg) + + integer :: nxmol + integer :: ixindx(maxinpx) + + end module rrlw_wvn_f + + +! Fortran-95 implementation of the Mersenne Twister 19937, following +! the C implementation described below (code mt19937ar-cok.c, dated 2002/2/10), +! adapted cosmetically by making the names more general. +! Users must declare one or more variables of type randomNumberSequence in the calling +! procedure which are then initialized using a required seed. If the +! variable is not initialized the random numbers will all be 0. +! For example: +! program testRandoms +! use RandomNumbers +! type(randomNumberSequence) :: randomNumbers +! integer :: i +! +! randomNumbers = new_RandomNumberSequence(seed = 100) +! do i = 1, 10 +! print ('(f12.10, 2x)'), getRandomReal(randomNumbers) +! end do +! end program testRandoms +! +! Fortran-95 implementation by +! Robert Pincus +! NOAA-CIRES Climate Diagnostics Center +! Boulder, CO 80305 +! email: Robert.Pincus@colorado.edu +! +! This documentation in the original C program reads: +! ------------------------------------------------------------- +! A C-program for MT19937, with initialization improved 2002/2/10. +! Coded by Takuji Nishimura and Makoto Matsumoto. +! This is a faster version by taking Shawn Cokus's optimization, +! Matthe Bellew's simplification, Isaku Wada's real version. +! +! Before using, initialize the state by using init_genrand(seed) +! or init_by_array(init_key, key_length). +! +! Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions +! are met: +! +! 1. Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions and the following disclaimer in the +! documentation and/or other materials provided with the distribution. +! +! 3. The names of its contributors may not be used to endorse or promote +! products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! +! Any feedback is very welcome. +! http://www.math.keio.ac.jp/matumoto/emt.html +! email: matumoto@math.keio.ac.jp +! ------------------------------------------------------------- + + module MersenneTwister_f +! ------------------------------------------------------------- + + !use parkind, only : im => kind , rb => kind + + implicit none + private + + ! Algorithm parameters + ! ------- + ! Period parameters + integer , parameter :: blockSize = 624, & + M = 397, & + MATRIX_A = -1727483681, & ! constant vector a (0x9908b0dfUL) +! UMASK = -2147483648, & ! most significant w-r bits (0x80000000UL) + UMASK = -2147483647, & ! most significant w-r bits (0x80000000UL) + LMASK = 2147483647 ! least significant r bits (0x7fffffffUL) + ! Tempering parameters + integer , parameter :: TMASKB= -1658038656, & ! (0x9d2c5680UL) + TMASKC= -272236544 ! (0xefc60000UL) + ! ------- + + ! The type containing the state variable + type randomNumberSequence + integer :: currentElement ! = blockSize + integer , dimension(0:blockSize -1) :: state ! = 0 + end type randomNumberSequence + + interface new_RandomNumberSequence + module procedure initialize_scalar, initialize_vector + end interface new_RandomNumberSequence + + public :: randomNumberSequence + public :: new_RandomNumberSequence, finalize_RandomNumberSequence, & + getRandomInt, getRandomPositiveInt, getRandomReal +! ------------------------------------------------------------- +contains + ! ------------------------------------------------------------- + ! Private functions + ! --------------------------- + function mixbits(u, v) + integer , intent( in) :: u, v + integer :: mixbits + + mixbits = ior(iand(u, UMASK), iand(v, LMASK)) + end function mixbits + ! --------------------------- + function twist(u, v) + integer , intent( in) :: u, v + integer :: twist + + ! Local variable + integer , parameter, dimension(0:1) :: t_matrix = (/ 0 , MATRIX_A /) + + twist = ieor(ishft(mixbits(u, v), -1 ), t_matrix(iand(v, 1 ))) + twist = ieor(ishft(mixbits(u, v), -1 ), t_matrix(iand(v, 1 ))) + end function twist + ! --------------------------- + subroutine nextState(twister) + type(randomNumberSequence), intent(inout) :: twister + + ! Local variables + integer :: k + + do k = 0, blockSize - M - 1 + twister%state(k) = ieor(twister%state(k + M), & + twist(twister%state(k), twister%state(k + 1 ))) + end do + do k = blockSize - M, blockSize - 2 + twister%state(k) = ieor(twister%state(k + M - blockSize), & + twist(twister%state(k), twister%state(k + 1 ))) + end do + twister%state(blockSize - 1 ) = ieor(twister%state(M - 1 ), & + twist(twister%state(blockSize - 1 ), twister%state(0 ))) + twister%currentElement = 0 + + end subroutine nextState + ! --------------------------- + elemental function temper(y) + integer , intent(in) :: y + integer :: temper + + integer :: x + + ! Tempering + x = ieor(y, ishft(y, -11)) + x = ieor(x, iand(ishft(x, 7), TMASKB)) + x = ieor(x, iand(ishft(x, 15), TMASKC)) + temper = ieor(x, ishft(x, -18)) + end function temper + ! ------------------------------------------------------------- + ! Public (but hidden) functions + ! -------------------- + function initialize_scalar(seed) result(twister) + integer , intent(in ) :: seed + type(randomNumberSequence) :: twister + + integer :: i + ! See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. In the previous versions, + ! MSBs of the seed affect only MSBs of the array state[]. + ! 2002/01/09 modified by Makoto Matsumoto + + twister%state(0) = iand(seed, -1 ) + do i = 1, blockSize - 1 ! ubound(twister%state) + twister%state(i) = 1812433253 * ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30 )) + i + twister%state(i) = iand(twister%state(i), -1 ) ! for >32 bit machines + end do + twister%currentElement = blockSize + end function initialize_scalar + ! ------------------------------------------------------------- + function initialize_vector(seed) result(twister) + integer , dimension(0:), intent(in) :: seed + type(randomNumberSequence) :: twister + + integer :: i, j, k, nFirstLoop, nWraps + + nWraps = 0 + twister = initialize_scalar(19650218 ) + + nFirstLoop = max(blockSize, size(seed)) + do k = 1, nFirstLoop + i = mod(k + nWraps, blockSize) + j = mod(k - 1, size(seed)) + if(i == 0) then + twister%state(i) = twister%state(blockSize - 1) + twister%state(1) = ieor(twister%state(1), & + ieor(twister%state(1-1), & + ishft(twister%state(1-1), -30 )) * 1664525 ) + & + seed(j) + j ! Non-linear + twister%state(i) = iand(twister%state(i), -1 ) ! for >32 bit machines + nWraps = nWraps + 1 + else + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30 )) * 1664525 ) + & + seed(j) + j ! Non-linear + twister%state(i) = iand(twister%state(i), -1 ) ! for >32 bit machines + end if + end do + + ! + ! Walk through the state array, beginning where we left off in the block above + ! + do i = mod(nFirstLoop, blockSize) + nWraps + 1, blockSize - 1 + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30 )) * 1566083941 ) - i ! Non-linear + twister%state(i) = iand(twister%state(i), -1 ) ! for >32 bit machines + end do + + twister%state(0) = twister%state(blockSize - 1) + + do i = 1, mod(nFirstLoop, blockSize) + nWraps + twister%state(i) = ieor(twister%state(i), & + ieor(twister%state(i-1), & + ishft(twister%state(i-1), -30 )) * 1566083941 ) - i ! Non-linear + twister%state(i) = iand(twister%state(i), -1 ) ! for >32 bit machines + end do + + twister%state(0) = UMASK + twister%currentElement = blockSize + + end function initialize_vector + ! ------------------------------------------------------------- + ! Public functions + ! -------------------- + function getRandomInt(twister) + type(randomNumberSequence), intent(inout) :: twister + integer :: getRandomInt + ! Generate a random integer on the interval [0,0xffffffff] + ! Equivalent to genrand_int32 in the C code. + ! Fortran doesn't have a type that's unsigned like C does, + ! so this is integers in the range -2**31 - 2**31 + ! All functions for getting random numbers call this one, + ! then manipulate the result + + if(twister%currentElement >= blockSize) call nextState(twister) + + getRandomInt = temper(twister%state(twister%currentElement)) + twister%currentElement = twister%currentElement + 1 + + end function getRandomInt + ! -------------------- + function getRandomPositiveInt(twister) + type(randomNumberSequence), intent(inout) :: twister + integer :: getRandomPositiveInt + ! Generate a random integer on the interval [0,0x7fffffff] + ! or [0,2**31] + ! Equivalent to genrand_int31 in the C code. + + ! Local integers + integer :: localInt + + localInt = getRandomInt(twister) + getRandomPositiveInt = ishft(localInt, -1) + + end function getRandomPositiveInt + ! -------------------- +!! mji - modified Jan 2007, double converted to rrtmg real kind type + function getRandomReal(twister) + type(randomNumberSequence), intent(inout) :: twister +! double precision :: getRandomReal + real :: getRandomReal + ! Generate a random number on [0,1] + ! Equivalent to genrand_real1 in the C code + ! The result is stored as double precision but has 32 bit resolution + + integer :: localInt + + localInt = getRandomInt(twister) + if(localInt < 0) then +! getRandomReal = dble(localInt + 2.0d0**32)/(2.0d0**32 - 1.0d0) + getRandomReal = (localInt + 2.0**32 )/(2.0**32 - 1.0 ) + else +! getRandomReal = dble(localInt )/(2.0d0**32 - 1.0d0) + getRandomReal = (localInt )/(2.0**32 - 1.0 ) + end if + + end function getRandomReal + ! -------------------- + subroutine finalize_RandomNumberSequence(twister) + type(randomNumberSequence), intent(inout) :: twister + + twister%currentElement = blockSize + twister%state(:) = 0 + end subroutine finalize_RandomNumberSequence + + ! -------------------- + + end module MersenneTwister_f + + + module mcica_random_numbers_f + + ! Generic module to wrap random number generators. + ! The module defines a type that identifies the particular stream of random + ! numbers, and has procedures for initializing it and getting real numbers + ! in the range 0 to 1. + ! This version uses the Mersenne Twister to generate random numbers on [0, 1]. + ! + use MersenneTwister_f, only: randomNumberSequence, & ! The random number engine. + new_RandomNumberSequence, getRandomReal +!! mji +!! use time_manager_mod, only: time_type, get_date + + !use parkind, only : im => kind , rb => kind + + implicit none + private + + type randomNumberStream + type(randomNumberSequence) :: theNumbers + end type randomNumberStream + + interface getRandomNumbers + module procedure getRandomNumber_Scalar, getRandomNumber_1D, getRandomNumber_2D + end interface getRandomNumbers + + interface initializeRandomNumberStream + module procedure initializeRandomNumberStream_S, initializeRandomNumberStream_V + end interface initializeRandomNumberStream + + public :: randomNumberStream, & + initializeRandomNumberStream, getRandomNumbers +!! mji +!! initializeRandomNumberStream, getRandomNumbers, & +!! constructSeed +contains + ! --------------------------------------------------------- + ! Initialization + ! --------------------------------------------------------- + function initializeRandomNumberStream_S(seed) result(new) + integer , intent( in) :: seed + type(randomNumberStream) :: new + + new%theNumbers = new_RandomNumberSequence(seed) + + end function initializeRandomNumberStream_S + ! --------------------------------------------------------- + function initializeRandomNumberStream_V(seed) result(new) + integer , dimension(:), intent( in) :: seed + type(randomNumberStream) :: new + + new%theNumbers = new_RandomNumberSequence(seed) + + end function initializeRandomNumberStream_V + ! --------------------------------------------------------- + ! Procedures for drawing random numbers + ! --------------------------------------------------------- + subroutine getRandomNumber_Scalar(stream, number) + type(randomNumberStream), intent(inout) :: stream + real , intent( out) :: number + + number = getRandomReal(stream%theNumbers) + end subroutine getRandomNumber_Scalar + ! --------------------------------------------------------- + subroutine getRandomNumber_1D(stream, numbers) + type(randomNumberStream), intent(inout) :: stream + real , dimension(:), intent( out) :: numbers + + ! Local variables + integer :: i + + do i = 1, size(numbers) + numbers(i) = getRandomReal(stream%theNumbers) + end do + end subroutine getRandomNumber_1D + ! --------------------------------------------------------- + subroutine getRandomNumber_2D(stream, numbers) + type(randomNumberStream), intent(inout) :: stream + real , dimension(:, :), intent( out) :: numbers + + ! Local variables + integer :: i + + do i = 1, size(numbers, 2) + call getRandomNumber_1D(stream, numbers(:, i)) + end do + end subroutine getRandomNumber_2D +! mji +! ! --------------------------------------------------------- +! ! Constructing a unique seed from grid cell index and model date/time +! ! Once we have the GFDL stuff we'll add the year, month, day, hour, minute +! ! --------------------------------------------------------- +! function constructSeed(i, j, time) result(seed) +! integer , intent( in) :: i, j +! type(time_type), intent( in) :: time +! integer , dimension(8) :: seed +! +! ! Local variables +! integer :: year, month, day, hour, minute, second +! +! +! call get_date(time, year, month, day, hour, minute, second) +! seed = (/ i, j, year, month, day, hour, minute, second /) +! end function constructSeed + + end module mcica_random_numbers_f + + module gpu_mcica_subcol_gen_lw + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2006-2009, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! Purpose: Create McICA stochastic arrays for cloud physical or optical properties. +! Two options are possible: +! 1) Input cloud physical properties: cloud fraction, ice and liquid water +! paths, ice fraction, and particle sizes. Output will be stochastic +! arrays of these variables. (inflag = 1) +! 2) Input cloud optical properties directly: cloud optical depth, single +! scattering albedo and asymmetry parameter. Output will be stochastic +! arrays of these variables. (inflag = 0; longwave scattering is not +! yet available, ssac and asmc are for future expansion) + +! --------- Modules ---------- + + !use parkind, only : im => kind , rb => kind + use parrrtm_f, only : nbndlw, ngptlw, mxlay + use rrlw_con_f, only: grav + use rrlw_wvn_f, only: ngb + use rrlw_vsn_f + +#ifdef _ACCEL + use cudafor + use cudadevice +#endif + + implicit none + +#ifdef _ACCEL + real _gpudev, allocatable :: pmidd(:, :) + real _gpudev, allocatable :: cldfracd(:,:), clwpd(:,:), ciwpd(:,:), cswpd(:,:), taucd(:,:,:) + +!$OMP THREADPRIVATE(pmidd,cldfracd,clwpd,ciwpd,cswpd,taucd) +#endif + +! public interfaces/functions/subroutines + !public :: mcica_subcol_lwg, generate_stochastic_cloudsg + + contains + +!------------------------------------------------------------------ +! Public subroutines +!------------------------------------------------------------------ + + subroutine mcica_subcol_lwg(colstart, ncol, nlay, icld, permuteseed, irng, & +#ifndef _ACCEL + pmidd,clwpd,ciwpd,cswpd,taucd, & +#endif + play, cldfrac, ciwp, clwp, cswp, tauc, ngbd, cldfmcl, & + ciwpmcl, clwpmcl, cswpmcl, taucmcl) + +! ----- Input ----- +! Control + integer , intent(in) :: colstart ! column/longitude index + integer , intent(in) :: ncol ! number of columns + integer , intent(in) :: nlay ! number of model layers + integer , intent(in) :: icld ! clear/cloud, cloud overlap flag + integer , intent(in) :: permuteseed ! if the cloud generator is called multiple times, + ! permute the seed between each call. + ! between calls for LW and SW, recommended + ! permuteseed differes by 'ngpt' + integer , intent(in) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister +! integer , intent(in) :: cloudMH, cloudHH + +! Atmosphere + real , intent(in) :: play(:,:) ! layer pressures (mb) + ! Dimensions: (ncol,nlay) + +! Atmosphere/clouds - cldprop + real , intent(in) :: cldfrac(:,:) ! layer cloud fraction + ! Dimensions: (ncol,nlay) + real , intent(in) :: tauc(:,:,:) ! in-cloud optical depth + ! Dimensions: (ncol,nbndlw,nlay) + real , intent(in) :: ciwp(:,:) ! in-cloud ice water path + ! Dimensions: (ncol,nlay) + real , intent(in) :: clwp(:,:) ! in-cloud liquid water path + ! Dimensions: (ncol,nlay) + real , intent(in) :: cswp(:,:) ! in-cloud snow path + ! Dimensions: (ncol,nlay) + integer _gpudev, intent(in) :: ngbd(:) + +! ----- Output ----- +! Atmosphere/clouds - cldprmc [mcica] + real _gpudev, intent(out) :: cldfmcl(:,:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real _gpudev, intent(out) :: ciwpmcl(:,:,:) ! in-cloud ice water path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real _gpudev, intent(out) :: clwpmcl(:,:,:) ! in-cloud liquid water path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real _gpudev, intent(out) :: cswpmcl(:,:,:) ! in-cloud snow water path [mcica] + ! Dimensions: (ngptlw,ncol,nlay) + real _gpudev, intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica] + ! Dimensions: (ngptlw,ncol,nlay) +! integer , intent(out) :: cloudFlag(:,:) + +#ifndef _ACCEL +! were module data but changed to arguments because not thread-safe + real :: pmidd(:, :) + real :: clwpd(:,:), ciwpd(:,:), cswpd(:,:), taucd(:,:,:) +#endif + +! ----- Local ----- + +! Stochastic cloud generator variables [mcica] + integer , parameter :: nsubclw = ngptlw ! number of sub-columns (g-point intervals) + integer :: ilev ! loop index + + real :: pmid(ncol, nlay) ! layer pressures (Pa) +#ifdef _ACCEL + type(dim3) :: dimGrid, dimBlock +#endif + integer, save :: counter = 0 + integer :: i,j,k,tk + real :: t1, t2 + +! Return if clear sky; or stop if icld out of range + if (icld.eq.0) then + cldfmcl = 0.0 + ciwpmcl = 0.0 + clwpmcl = 0.0 + cswpmcl = 0.0 + taucmcl = 0.0 +! cloudFlag = 0.0 + + return + end if + if (icld.lt.0.or.icld.gt.4) then + stop 'MCICA_SUBCOL: INVALID ICLD' + endif + +! NOTE: For GCM mode, permuteseed must be offset between LW and SW by at least the number of subcolumns + + +! Pass particle sizes to new arrays, no subcolumns for these properties yet +! Convert pressures from mb to Pa + +#ifdef _ACCEL + pmid(1:ncol,:nlay) = play(colstart:colstart+ncol-1,:nlay)*1.e2 +#else + pmidd(1:ncol,:nlay) = play(colstart:colstart+ncol-1,:nlay)*1.e2 +#endif + +#ifdef _ACCEL + allocate( pmidd(ncol, nlay), cldfracd(ncol, mxlay+1)) + allocate( clwpd(ncol, mxlay+1), ciwpd(ncol, mxlay+1), cswpd(ncol, mxlay+1)) + allocate( taucd(ncol, nbndlw, mxlay)) +#endif + +#ifdef _ACCEL + pmidd = pmid + + cldfracd = cldfrac + clwpd = clwp + ciwpd = ciwp + cswpd = cswp + taucd = tauc +#endif + + end subroutine mcica_subcol_lwg + +!------------------------------------------------------------------------------------------------- + _gpuker subroutine generate_stochastic_cloudsg(ncol, nlay, icld, ngbd, & +#ifndef _ACCEL + pmidd,cldfracd,clwpd,ciwpd,cswpd,taucd,changeSeed, & +#endif + cld_stoch, clwp_stoch, ciwp_stoch, cswp_stoch, & + tauc_stoch) +!------------------------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------------------------------------------- + ! --------------------- + ! Contact: Cecile Hannay (hannay@ucar.edu) + ! + ! Original code: Based on Raisanen et al., QJRMS, 2004. + ! + ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default + ! random number generator, which can be changed to the optional kissvec random number generator + ! with flag 'irng'. Some extra functionality has been commented or removed. + ! Michael J. Iacono, AER, Inc., February 2007 + ! + ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. + ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one + ! and uniform cloud liquid and cloud ice concentration. + ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer + ! and obeys an overlap assumption in the vertical. + ! + ! Overlap assumption: + ! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential. + ! The default option is maximum-random (option 3) + ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap + ! This is set with the variable "overlap" + !mji - Exponential overlap option (overlap=4) has been deactivated in this version + ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) + ! + ! Seed: + ! If the stochastic cloud generator is called several times during the same timestep, + ! one should change the seed between the call to insure that the subcolumns are different. + ! This is done by changing the argument 'changeSeed' + ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave , + ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call + ! + ! PDF assumption: + ! We can use arbitrary complicated PDFS. + ! In the present version, we produce homogeneuous clouds (the simplest case). + ! Future developments include using the PDF scheme of Ben Johnson. + ! + ! History file: + ! Option to add diagnostics variables in the history file. (using FINCL in the namelist) + ! nsubcol = number of subcolumns + ! overlap = overlap type (1-3) + ! Zo = length scale + ! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) + ! CLDLIQ_S = mean of the subcolumn cloud water + ! CLDICE_S = mean of the subcolumn cloud ice + ! + ! Note: + ! Here: we force that the cloud condensate to be consistent with the cloud fraction + ! i.e we only have cloud condensate when the cell is cloudy. + ! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations + ! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction + ! without cloud condensate or the opposite). + !--------------------------------------------------------------------------------------------------------------- + + +! -- Arguments + + integer , intent(in) :: ncol ! number of columns + integer , intent(in) :: nlay ! number of layers + integer , intent(in) :: icld ! clear/cloud, cloud overlap flag + + integer _gpudev, intent(in) :: ngbd(:) + +#ifndef _ACCEL +! were module data but changed to arguments because not thread-safe + real :: pmidd(:, :) + real :: cldfracd(:,:), clwpd(:,:), ciwpd(:,:), cswpd(:,:), taucd(:,:,:) + integer, intent(in) :: changeSeed +#endif + +! real , intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo + ! Dimensions: (nbndlw,ncol,nlay) + ! inactive - for future expansion +! real , intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter + ! Dimensions: (nbndlw,ncol,nlay) + ! inactive - for future expansion + + real _gpudev, intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction + ! Dimensions: (ncol,ngptlw,nlay) + real _gpudev, intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path + ! Dimensions: (ncol,ngptlw,nlay) + real _gpudev, intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path + ! Dimensions: (ncol,ngptlw,nlay) + real _gpudev, intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path + ! Dimensions: (ncol,ngptlw,nlay) + real _gpudev, intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth + ! Dimensions: (ncol,ngptlw,nlay) +! real , intent(out) :: ssac_stoch(:,:,:)! subcolumn in-cloud single scattering albedo + ! Dimensions: (ngptlw,ncol,nlay) + ! inactive - for future expansion +! real , intent(out) :: asmc_stoch(:,:,:)! subcolumn in-cloud asymmetry parameter + ! Dimensions: (ngptlw,ncol,nlay) + ! inactive - for future expansion + + !integer, value, intent(in) :: counter + + +! Cloud condensate + + real :: RIND1, RIND2, ZCW, SIGMA_QCW + integer :: IND1, IND2 + + real :: CDF3(mxlay) ! random numbers + + real :: cfs + integer, parameter :: nsubcol = 140 + +! Constants (min value for cloud fraction and cloud water and ice) + ! real , parameter :: cldmin = 1.0e-20 ! min cloud fraction +! real , parameter :: qmin = 1.0e-10 ! min cloud water and cloud ice (not used) + +! Variables related to random number and seed +#ifdef _ACCEL + real :: CDF(mxlay), CDF2(mxlay) ! random numbers + integer :: seed1, seed2, seed3, seed4 ! seed to create random number (kissvec) + real :: rand_num ! random number (kissvec) +#else + real :: CDF(ncol,mxlay), CDF2(mxlay) ! random numbers + integer,dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number (kissvec) + real ,dimension(ncol) :: rand_num ! random number (kissvec) +#endif + integer :: iseed ! seed to create random number (Mersenne Teister) + real :: rand_num_mt ! random number (Mersenne Twister) + +! Flag to identify cloud fraction in subcolumns + ! logical :: iscloudy(mxlay) ! flag that says whether a gridbox is cloudy + +! Indices + integer :: ilev, isubcol, i, n ! indices + + integer :: iplon, gp + integer :: m, k, n1, kiss + + m(k, n1) = ieor (k, ishft (k, n1) ) +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + gp = (blockidx%y-1) * blockdim%y + threadidx%y + +!------------------------------------------------------------------------------------------ + ! print *, "ppp ", iplon, gp + if (iplon <= ncol .and. gp <= nsubcol) then +# define ILOOP_S_CPU +# define ILOOP_E_CPU +#else +# define ILOOP_S_CPU do iplon = 1, ncol +# define ILOOP_E_CPU enddo +#endif + + +! ----- Create seed -------- + +! Advance randum number generator by changeseed values + +! For kissvec, create a seed that depends on the state of the columns. Maybe not the best way, but it works. +! Must use pmid from bottom four layers. +#ifdef _ACCEL + seed1 = (pmidd(iplon,1) - int(pmidd(iplon,1))) * 1000000000 + (gp) * 11 + seed3 = (pmidd(iplon,3) - int(pmidd(iplon,3))) * 1000000000 + (gp) * 13 + seed2 = seed1 + gp + seed4 = seed3 - gp +#else +! Have it agree with the original _lw.F version, jm 20141222 + do iplon = 1, ncol + seed1(iplon) = (pmidd(iplon,1) - int(pmidd(iplon,1))) * 1000000000 + seed2(iplon) = (pmidd(iplon,2) - int(pmidd(iplon,2))) * 1000000000 + seed3(iplon) = (pmidd(iplon,3) - int(pmidd(iplon,3))) * 1000000000 + seed4(iplon) = (pmidd(iplon,4) - int(pmidd(iplon,4))) * 1000000000 + do i=1,changeSeed +! call kissvec(seed1(iplon), seed2(iplon), seed3(iplon), seed4(iplon), rand_num(iplon)) + + seed1(iplon) = 69069 * seed1(iplon) + 1327217885 + seed2(iplon) = m (m (m (seed2(iplon), 13), - 17), 5) + seed3(iplon) = 18000 * iand (seed3(iplon), 65535) + ishft (seed3(iplon), - 16) + seed4(iplon) = 30903 * iand (seed4(iplon), 65535) + ishft (seed4(iplon), - 16) + kiss = seed1(iplon) + seed2(iplon) + ishft (seed3(iplon), 16) + seed4(iplon) + rand_num(iplon) = kiss*2.328306e-10 + 0.5 + + enddo + enddo + + do gp = 1, nsubcol + +#endif + + +! ------ Apply overlap assumption -------- + +! generate the random numbers + + select case (icld) + +#ifdef _ACCEL +! Random overlap + case(1) + +# if 0 + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(iplon,ilev) = rand_num + end do +# endif + + +! Maximum-Random overlap + case(2) + + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(ilev) = rand_num + end do + + + do ilev = 2,nlay + if (CDF(ilev-1) > 1. - cldfracd(iplon, ilev-1)) then + CDF(ilev) = CDF(ilev-1) + else + CDF(ilev) = CDF(ilev) * (1. - cldfracd(iplon, ilev-1)) + end if + end do + +! Maximum overlap + case(3) + + call kissvec(seed1, seed2, seed3, seed4, rand_num) + do ilev = 1,nlay + CDF(ilev) = rand_num + end do + + + end select +#else +! Random overlap + case(1) + +# if 0 + do ilev = 1,nlay + call kissvec(seed1, seed2, seed3, seed4, rand_num) + CDF(iplon,ilev) = rand_num + end do +# else + CALL wrf_error_fatal("icld == 1 not supported: module_ra_rrtmg_lwf.F") +#endif + +! Maximum-Random overlap + case(2) + + do ilev = 1,nlay + ILOOP_S_CPU +! call kissvec(seed1(iplon), seed2(iplon), seed3(iplon), seed4(iplon), rand_num(iplon)) + seed1(iplon) = 69069 * seed1(iplon) + 1327217885 + seed2(iplon) = m (m (m (seed2(iplon), 13), - 17), 5) + seed3(iplon) = 18000 * iand (seed3(iplon), 65535) + ishft (seed3(iplon), - 16) + seed4(iplon) = 30903 * iand (seed4(iplon), 65535) + ishft (seed4(iplon), - 16) + kiss = seed1(iplon) + seed2(iplon) + ishft (seed3(iplon), 16) + seed4(iplon) + CDF(iplon,ilev) = kiss*2.328306e-10 + 0.5 + ILOOP_E_CPU + end do + + + do ilev = 2,nlay + ILOOP_S_CPU + if (CDF(iplon,ilev-1) > 1. - cldfracd(iplon, ilev-1)) then + CDF(iplon,ilev) = CDF(iplon,ilev-1) + else + CDF(iplon,ilev) = CDF(iplon,ilev) * (1. - cldfracd(iplon, ilev-1)) + end if + ILOOP_E_CPU + end do + +! Maximum overlap + case(3) + + ILOOP_S_CPU +! call kissvec(seed1(iplon), seed2(iplon), seed3(iplon), seed4(iplon), rand_num(iplon)) + seed1(iplon) = 69069 * seed1(iplon) + 1327217885 + seed2(iplon) = m (m (m (seed2(iplon), 13), - 17), 5) + seed3(iplon) = 18000 * iand (seed3(iplon), 65535) + ishft (seed3(iplon), - 16) + seed4(iplon) = 30903 * iand (seed4(iplon), 65535) + ishft (seed4(iplon), - 16) + kiss = seed1(iplon) + seed2(iplon) + ishft (seed3(iplon), 16) + seed4(iplon) + rand_num(iplon) = kiss*2.328306e-10 + 0.5 + ILOOP_E_CPU + do ilev = 1,nlay + ILOOP_S_CPU + CDF(iplon,ilev) = rand_num(iplon) + ILOOP_E_CPU + end do + + end select +#endif + + n = ngbd(gp) + + do ilev = 1,nlay + ILOOP_S_CPU + cfs = cldfracd(iplon, ilev) + ! do gp = 1, nsubcol +#ifdef _ACCEL + if (CDF(ilev) >=1. - cfs) then +#else + if (CDF(iplon,ilev) >=1. - cfs) then +#endif + + cld_stoch(iplon,gp,ilev) = 1. + clwp_stoch(iplon,gp,ilev) = clwpd(iplon,ilev) + ciwp_stoch(iplon,gp,ilev) = ciwpd(iplon,ilev) + cswp_stoch(iplon,gp,ilev) = cswpd(iplon,ilev) + + tauc_stoch(iplon,gp,ilev) = taucd(iplon,n,ilev) + + else + cld_stoch(iplon,gp,ilev) = 0. + clwp_stoch(iplon,gp,ilev) = 0. + ciwp_stoch(iplon,gp,ilev) = 0. + cswp_stoch(iplon,gp,ilev) = 0. + tauc_stoch(iplon,gp,ilev) = 0. +! ssac_stoch(isubcol,i,ilev) = 1. +! asmc_stoch(isubcol,i,ilev) = 1. + endif + + ILOOP_E_CPU + enddo + +#ifdef _ACCEL + endif +#else + end do +#endif + + end subroutine generate_stochastic_cloudsg + + _gpuked subroutine kissvec(seed1,seed2,seed3,seed4,ran_arr) +!-------------------------------------------------------------------------------------------------- + +! public domain code +! made available from http://www.fortran.com/ +! downloaded by pjr on 03/16/04 for NCAR CAM +! converted to vector form, functions inlined by pjr,mvr on 05/10/2004 + +! The KISS (Keep It Simple Stupid) random number generator. Combines: +! (1) The congruential generator x(n)=69069*x(n-1)+1327217885, period 2^32. +! (2) A 3-shift shift-register generator, period 2^32-1, +! (3) Two 16-bit multiply-with-carry generators, period 597273182964842497>2^59 +! Overall period>2^123; +! + real , intent(inout) :: ran_arr + integer , intent(inout) :: seed1,seed2,seed3,seed4 + integer :: i,sz,kiss + integer :: m, k, n + +! inline function + m(k, n) = ieor (k, ishft (k, n) ) + + seed1 = 69069 * seed1 + 1327217885 + seed2 = m (m (m (seed2, 13), - 17), 5) + seed3 = 18000 * iand (seed3, 65535) + ishft (seed3, - 16) + seed4 = 30903 * iand (seed4, 65535) + ishft (seed4, - 16) + kiss = seed1 + seed2 + ishft (seed3, 16) + seed4 + ran_arr = kiss*2.328306e-10 + 0.5 + + end subroutine kissvec + + end module gpu_mcica_subcol_gen_lw + +! (dmb 2012) This is the GPU version of the cldprmc routine. I have parallelized across +! all 3 dimensions (columns, g-points, and layers) to make this routine run very fast on the GPU. +! The greatest speedup was obtained by switching the indices for the cloud variables so that +! the columns were the least significant (leftmost) dimension + + module gpu_rrtmg_lw_cldprmc + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! --------- Modules ---------- + +! use parkind, only : im => kind , rb => kind + use parrrtm_f, only : ngptlw, nbndlw + use rrlw_cld_f, only: abscld1, absliq0, absliq1, & + absice0, absice1, absice2, absice3 +! use rrlw_wvn_f, only: ngb + use rrlw_vsn_f, only: hvrclc, hnamclc + +#ifdef _ACCEL + use cudafor +#endif + implicit none + +#ifdef _ACCEL +! (dmb 2012) I moved most GPU variables so that they are module level variables. +! PGI Fortran seems to sometimes have trouble passing arrays into kernels correctly. +! Using module level variables bypasses this issue and allows for cleaner code. +! (jm 2014) but not thread safe. + integer _gpudev, allocatable :: inflagd(:), iceflagd(:), liqflagd(:) + + real _gpudev, allocatable :: ciwpmcd(:,:,:) ! in-cloud ice water path [mcica] + real _gpudev, allocatable :: clwpmcd(:,:,:) ! in-cloud liquid water path [mcica] + real _gpudev, allocatable :: cswpmcd(:,:,:) ! in-cloud snow water path [mcica] + ! Dimensions: (ncol,ngptlw,nlayers) + real _gpudev, allocatable :: relqmcd(:,:) ! liquid particle effective radius (microns) + real _gpudev, allocatable :: reicmcd(:,:) ! ice particle effective size (microns) + real _gpudev, allocatable :: resnmcd(:,:) ! snow particle effective size (microns) + ! Dimensions: (ncol,nlayers) + ! specific definition of reicmc depends on setting of iceflag: + ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec must be >= 10.0 microns + ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflag = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + + real _gpucon, dimension(2) :: absice0d + real _gpucon, dimension(2,5) :: absice1d + real _gpucon, dimension(43,16) :: absice2d + real _gpucon, dimension(46,16) :: absice3d + real _gpucon, dimension(58,16) :: absliq1d + + +! (jm 2014) My reading of threadprivate documentation says this should work, +! see http://publib.boulder.ibm.com/infocenter/comphelp/v101v121 +! but keep an eye on it. Different vendors have extended this in different ways. +! See also the intel -openmp-threadprivate=legacy/compat documentation. +!$OMP THREADPRIVATE(inflagd,iceflagd,liqflagd,ciwpmcd,clwpmcd,cswpmcd,relqmcd,reicmcd,resnmcd, & +!$OMP absice0d,absice1d,absice2d,absice3d,absliq1d) +#endif + + contains + +! ------------------------------------------------------------------------------ + _gpuker subroutine cldprmcg(ncol, nlayers, & +#ifndef _ACCEL + inflagd,iceflagd,liqflagd,ciwpmcd,clwpmcd,cswpmcd,relqmcd,reicmcd,resnmcd, & + absice0d,absice1d,absice2d,absice3d,absliq1d, & +#endif + cldfmc, taucmc, ngb, icb, ncbands, icldlyr) +! ------------------------------------------------------------------------------ + +! Purpose: Compute the cloud optical depth(s) for each cloudy layer. + +! ------- Input ------- + + integer, value, intent(in) :: ncol ! total number of columns + integer, value, intent(in) :: nlayers ! total number of layers + +#ifndef _ACCEL +# define ncol CHNK +#endif + + real , intent(in) :: cldfmc(ncol, ngptlw, nlayers+1) ! cloud fraction [mcica] + + integer , intent(out) :: icldlyr( ncol, nlayers+1) + integer , dimension(140), intent(in) :: ngb + integer , intent(in) :: icb(16) + real , intent(inout) :: taucmc(:,:,:) ! cloud optical depth [mcica] + + real , parameter :: absliq0 = 0.0903614 + +! ------- Output ------- + + integer , intent(out) :: ncbands(:) ! number of cloud spectral bands + +#ifndef _ACCEL +!changed to arguments for thread safety on CPU + integer :: inflagd(:), iceflagd(:), liqflagd(:) + + real :: ciwpmcd(:,:,:) ! in-cloud ice water path [mcica] + real :: clwpmcd(:,:,:) ! in-cloud liquid water path [mcica] + real :: cswpmcd(:,:,:) ! in-cloud snow water path [mcica] + ! Dimensions: (ncol,ngptlw,nlayers) + real :: relqmcd(:,:) ! liquid particle effective radius (microns) + real :: reicmcd(:,:) ! ice particle effective size (microns) + real :: resnmcd(:,:) ! snow particle effective size (microns) + ! Dimensions: (ncol,nlayers) + ! specific definition of reicmc depends on setting of iceflag: + ! iceflag = 0: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec must be >= 10.0 microns + ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflag = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + + real, dimension(2) :: absice0d + real, dimension(2,5) :: absice1d + real, dimension(43,16) :: absice2d + real, dimension(46,16) :: absice3d + real, dimension(58,16) :: absliq1d +#endif + +! ------- Local ------- + + integer :: iplon + integer :: lay ! Layer index + integer :: ib ! spectral band index + integer :: ig ! g-point interval index + integer :: index + + + real :: abscoice ! ice absorption coefficients + real :: abscoliq ! liquid absorption coefficients + real :: abscosno ! snow absorption coefficients + real :: cwp ! cloud water path + real :: radice ! cloud ice effective size (microns) + real :: radliq ! cloud liquid droplet radius (microns) + real :: radsno ! cloud snow effective radius (microns) + real :: factor ! + real :: fint ! + real , parameter :: eps = 1.e-6 ! epsilon + real , parameter :: cldmin = 1.e-20 ! minimum value for cloud quantities + + character*256 errmess +! ------- Definitions ------- + +! Explanation of the method for each value of INFLAG. Values of +! 0 or 1 for INFLAG do not distingish being liquid and ice clouds. +! INFLAG = 2 does distinguish between liquid and ice clouds, and +! requires further user input to specify the method to be used to +! compute the aborption due to each. +! INFLAG = 0: For each cloudy layer, the cloud fraction and (gray) +! optical depth are input. +! INFLAG = 1: For each cloudy layer, the cloud fraction and cloud +! water path (g/m2) are input. The (gray) cloud optical +! depth is computed as in CCM2. +! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud +! water path (g/m2), and cloud ice fraction are input. +! ICEFLAG = 0: The ice effective radius (microns) is input and the +! optical depths due to ice clouds are computed as in CCM3. +! ICEFLAG = 1: The ice effective radius (microns) is input and the +! optical depths due to ice clouds are computed as in +! Ebert and Curry, JGR, 97, 3831-3836 (1992). The +! spectral regions in this work have been matched with +! the spectral bands in RRTM to as great an extent +! as possible: +! E&C 1 IB = 5 RRTM bands 9-16 +! E&C 2 IB = 4 RRTM bands 6-8 +! E&C 3 IB = 3 RRTM bands 3-5 +! E&C 4 IB = 2 RRTM band 2 +! E&C 5 IB = 1 RRTM band 1 +! ICEFLAG = 2: The ice effective radius (microns) is input and the +! optical properties due to ice clouds are computed from +! the optical properties stored in the RT code, +! STREAMER v3.0 (Reference: Key. J., Streamer +! User's Guide, Cooperative Institute for +! Meteorological Satellite Studies, 2001, 96 pp.). +! Valid range of values for re are between 5.0 and +! 131.0 micron. +! ICEFLAG = 3: The ice generalized effective size (dge) is input +! and the optical properties, are calculated as in +! Q. Fu, J. Climate, (1998). Q. Fu provided high resolution +! tables which were appropriately averaged for the +! bands in RRTM_LW. Linear interpolation is used to +! get the coefficients from the stored tables. +! Valid range of values for dge are between 5.0 and +! 140.0 micron. +! LIQFLAG = 0: The optical depths due to water clouds are computed as +! in CCM3. +! LIQFLAG = 1: The water droplet effective radius (microns) is input +! and the optical depths due to water clouds are computed +! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993). +! The values for absorption coefficients appropriate for +! the spectral bands in RRTM have been obtained for a +! range of effective radii by an averaging procedure +! based on the work of J. Pinto (private communication). +! Linear interpolation is used to get the absorption +! coefficients for the input effective radius. + +! (dmb 2012) Here insead of looping over the column, layer, and band dimensions, +! I compute the index for each dimension from the grid and block layout. This +! function is called once per each thread, and each thread has a unique combination of +! column, layer, and g-point. + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + ig = (blockidx%z-1) * blockdim%z + threadidx%z +! (dmb 2012) Make sure that the column, layer, and g-points are all within the proper +! range. They can be out of range if we select certain block configurations due to +! optimizations. + if (iplon<=ncol .and. lay<=nlayers .and. ig<=ngptlw) then +#else + do iplon = 1, ncol + do lay = 1, nlayers + do ig = 1, ngptlw +#endif + + ncbands(iplon) = 1 +! (dmb 2012) all of the cloud variables have been modified so that the column dimensions +! is least significant. + if (cldfmc(iplon,ig,lay) .eq. 1. ) then + icldlyr(iplon, lay)=1 + endif + cwp = ciwpmcd(iplon,ig,lay) + clwpmcd(iplon,ig,lay) + cswpmcd(iplon,ig,lay) +! (dmb 2012) the stop commands were removed because they aren't supported on the GPU + if (cldfmc(iplon,ig,lay) .ge. cldmin .and. & + (cwp .ge. cldmin .or. taucmc(iplon,ig,lay) .ge. cldmin)) then + + +!jm top cldprmc inflagd 5 +!jm top cldprmc iceflagd 5 +!jm top cldprmc liqflagd 1 + + +!jm zap if(inflagd(iplon) .eq. 2) then + if(inflagd(iplon) .ge. 2) then + radice = reicmcd(iplon, lay) + +! Calculation of absorption coefficients due to ice clouds. + if (ciwpmcd(iplon,ig,lay)+cswpmcd(iplon,ig,lay) .eq. 0.0) then + abscoice = 0.0 + abscosno = 0.0 + + elseif (iceflagd(iplon) .eq. 0) then + abscoice= absice0d(1) + absice0d(2)/radice + abscosno = 0.0 + + elseif (iceflagd(iplon) .eq. 1) then + ncbands(iplon) = 5 + ib = icb(ngb(ig)) + abscoice = absice1d(1,ib) + absice1d(2,ib)/radice + abscosno = 0.0 + +! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns + + elseif (iceflagd(iplon) .eq. 2) then + ncbands(iplon) = 16 + factor = (radice - 2.)/3. + index = int(factor) +! mji - temporary fix to prevent out of range subscripts + if (index .le. 0) index = 1 + if (index .ge. 43) index = 42 +! if (index .eq. 43) index = 42 + fint = factor - float(index) + ib = ngb(ig) + abscoice = & + absice2d(index,ib) + fint * & + (absice2d(index+1,ib) - (absice2d(index,ib))) + abscosno = 0.0 + +! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns + +!jm elseif (iceflagd(iplon) .eq. 3) then + elseif (iceflagd(iplon) .ge. 3) then + ncbands(iplon) = 16 + factor = (radice - 2.)/3. + index = int(factor) +! mji - temporary fix to prevent out of range subscripts + if (index .le. 0) index = 1 + if (index .ge. 46) index = 45 +! if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) + abscoice= & + absice3d(index,ib) + fint * & + (absice3d(index+1,ib) - (absice3d(index,ib))) + abscosno = 0.0 + + endif + +!..Incorporate additional effects due to snow. +!STOPPED HERE + if (cswpmcd(iplon,ig,lay).gt.0.0 .and. iceflagd(iplon) .eq. 5) then + radsno = resnmcd(iplon,lay) + +#ifndef _ACCEL + if (radsno .lt. 5.0 .or. radsno .gt. 140.0) then + write(errmess,'(A,i5,i5,i5,f8.2,f8.2)' ) & + 'ERROR: SNOW GENERALIZED EFFECTIVE SIZE OUT OF BOUNDS' & + ,iplon,ig, lay, cswpmcd(iplon,ig,lay), radsno + call wrf_error_fatal(errmess) + end if +#endif + + ncbands(iplon) = 16 + factor = (radsno - 2.)/3. + index = int(factor) +! mji - temporary fix to prevent out of range subscripts + if (index .le. 0) index = 1 + if (index .ge. 46) index = 45 +! if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) + abscosno = & + absice3d(index,ib) + fint * & + (absice3d(index+1,ib) - (absice3d(index,ib))) + endif + +! Calculation of absorption coefficients due to water clouds. + if (liqflagd(iplon) .eq. 1) then + radliq = relqmcd(iplon, lay) + index = int(radliq - 1.5 ) +! mji - temporary fix to prevent out of range subscripts + if (index .le. 0) index = 1 + if (index .ge. 58) index = 57 +! if (index .eq. 0) index = 1 +! if (index .eq. 58) index = 57 + fint = radliq - 1.5 - float(index) + ib = ngb(ig) + abscoliq = & + absliq1d(index,ib) + fint * & + (absliq1d(index+1,ib) - (absliq1d(index,ib))) + endif + + taucmc(iplon,ig,lay) = ciwpmcd(iplon,ig,lay) * abscoice + & + clwpmcd(iplon,ig,lay) * abscoliq + & + cswpmcd(iplon,ig,lay) * abscosno + + + endif + endif + +#ifdef _ACCEL + endif +#else + end do + end do + end do +#endif + + end subroutine cldprmcg + +#ifndef _ACCEL +# undef ncol +#endif + + +! (dmb 2012) This subroutine allocates the module level arrays on the GPU + subroutine allocateGPUcldprmcg(ncol, nlay, ngptlw) + + integer , intent(in) :: nlay, ngptlw, ncol +#ifdef _ACCEL + allocate( inflagd(ncol), iceflagd(ncol), liqflagd(ncol)) + allocate( relqmcd(ncol, nlay+1), reicmcd(ncol, nlay+1)) + allocate( resnmcd(ncol, nlay+1)) + + allocate( ciwpmcd(ncol, ngptlw, nlay+1)) + allocate( clwpmcd(ncol, ngptlw, nlay+1)) + allocate( cswpmcd(ncol, ngptlw, nlay+1)) +#endif + + end subroutine + + ! (dmb 2012) This subroutine deallocates any GPU arrays. + subroutine deallocateGPUcldprmcg() + +#ifdef _ACCEL + deallocate( inflagd, iceflagd, liqflagd) + deallocate( relqmcd, reicmcd, resnmcd) + + deallocate( ciwpmcd) + deallocate( clwpmcd) + deallocate( cswpmcd) +#endif + + end subroutine + + ! (dmb 2012) This subroutine copies input data from the CPU over to the GPU + ! for use in the cldprmcg subroutine. + subroutine copyGPUcldprmcg(inflag, iceflag, liqflag,& + absice0, absice1, absice2, absice3, absliq1) + + integer :: inflag(:), iceflag(:), liqflag(:) + + real , dimension(:) :: absice0 + real , dimension(:,:) :: absice1 + real , dimension(:,:) :: absice2 + real , dimension(:,:) :: absice3 + real , dimension(:,:) :: absliq1 + +#ifdef _ACCEL + inflagd = inflag + iceflagd = iceflag + liqflagd = liqflag + + absice0d = absice0 + absice1d = absice1 + absice2d = absice2 + absice3d = absice3 + absliq1d = absliq1 +#endif + + end subroutine + + end module gpu_rrtmg_lw_cldprmc + +! (dmb 2012) This is the GPU version of the rtrnmc subroutine. This has been greatly +! modified to be efficiently run on the GPU. Originally, there was a g-point loop within +! this subroutine to perform the summation of the fluxes over the g-points. This has been +! modified so that this subroutine can be run in parallel across the g-points. This was +! absolutely critical because of two reasons. +! 1. For a relatively low number of profiles, there wouldn't be enough threads to keep +! the GPU busy enough to run at full potential. As a result of this, this subroutine +! would end up being a bottleneck. +! 2. The memory access for the GPU arrays would be innefient because there would be very +! little coalescing which is critical for obtaining optimal performance. + + module gpu_rrtmg_lw_rtrnmc + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! --------- Modules ---------- + +! use parkind, only : im => kind , rb => kind + use parrrtm_f, only : mg, nbndlw, ngptlw, mxlay + use rrlw_con_f, only: fluxfac, heatfac +! (jm 2014) not sure why the GPU version defines ntbl 2x instead of using it +! from rrlw_tbl, but will leave it alone for now. However, it is an error when +! compiling for CPU, at least with the Intel compiler. Says it's defined twice. +#ifdef _ACCEL + use rrlw_tbl_f, only: bpade, tblint, tau_tbl, exp_tbl, tfn_tbl +#else + use rrlw_tbl_f, only: bpade, tblint, tau_tbl, exp_tbl, tfn_tbl, ntbl +#endif + +#ifdef _ACCEL + use cudafor +#endif + + implicit none + +#ifdef _ACCEL +! (jm 2014) see comment above) + integer(kind=4), parameter :: ntbl = 10000 +#endif +#ifdef _ACCEL + integer _gpucon :: ngsd(nbndlw) + +! (dmb 2012) I moved most GPU variables so that they are module level variables. +! PGI Fortran seems to sometimes have trouble passing arrays into kernels correctly. +! Using module level variables bypasses this issue and allows for cleaner code. +! (jm 2014) but not thread safe. + +! Atmosphere + real , allocatable _gpudev :: taucmcd(:,:,:) + + real , allocatable _gpudev, dimension(:,:) :: pzd ! level (interface) pressures (hPa, mb) + ! Dimensions: (ncol,0:nlayers) + real , allocatable _gpudev, dimension(:) :: pwvcmd ! precipitable water vapor (cm) + ! Dimensions: (ncol) + real , allocatable _gpudev, dimension(:,:) :: semissd ! lw surface emissivity + ! Dimensions: (ncol,nbndlw) + real , allocatable _gpudev, dimension(:,:,:) :: planklayd ! + ! Dimensions: (ncol,nlayers,nbndlw) + real , allocatable _gpudev, dimension(:,:,:) :: planklevd ! + ! Dimensions: (ncol,0:nlayers,nbndlw) + real, allocatable _gpudev, dimension(:,:) :: plankbndd ! + ! Dimensions: (ncol,nbndlw) + + real , allocatable _gpudev :: gurad(:,:,:) ! upward longwave flux (w/m2) + real , allocatable _gpudev :: gdrad(:,:,:) ! downward longwave flux (w/m2) + real , allocatable _gpudev :: gclrurad(:,:,:) ! clear sky upward longwave flux (w/m2) + real , allocatable _gpudev :: gclrdrad(:,:,:) ! clear sky downward longwave flux (w/m2) + + real _gpudev, allocatable :: gdtotuflux_dtd(:,:,:) ! change in upward longwave flux (w/m2/k) + ! with respect to surface temperature + + real _gpudev, allocatable :: gdtotuclfl_dtd(:,:,:) ! change in clear sky upward longwave flux (w/m2/k) + ! with respect to surface temperature + + +! Clouds + integer _gpudev :: idrvd ! flag for calculation of dF/dt from + ! Planck derivative [0=off, 1=on] + real _gpucon :: bpaded + real _gpucon :: heatfacd + real _gpucon :: fluxfacd + real _gpucon :: a0d(nbndlw), a1d(nbndlw), a2d(nbndlw) + integer _gpucon :: delwaved(nbndlw) + real , allocatable _gpudev :: totufluxd(:,:) ! upward longwave flux (w/m2) + real , allocatable _gpudev :: totdfluxd(:,:) ! downward longwave flux (w/m2) + real , allocatable _gpudev :: fnetd(:,:) ! net longwave flux (w/m2) + real , allocatable _gpudev :: htrd(:,:) ! longwave heating rate (k/day) + real , allocatable _gpudev :: totuclfld(:,:) ! clear sky upward longwave flux (w/m2) + real , allocatable _gpudev :: totdclfld(:,:) ! clear sky downward longwave flux (w/m2) + real , allocatable _gpudev :: fnetcd(:,:) ! clear sky net longwave flux (w/m2) + real , allocatable _gpudev :: htrcd(:,:) ! clear sky longwave heating rate (k/day) + real , allocatable _gpudev :: dtotuflux_dtd(:,:) ! change in upward longwave flux (w/m2/k) + ! with respect to surface temperature + real , allocatable _gpudev :: dtotuclfl_dtd(:,:) ! change in clear sky upward longwave flux (w/m2/k) + ! with respect to surface temperature + real , allocatable _gpudev :: dplankbnd_dtd(:,:) + +! (jm 2014) +!$OMP THREADPRIVATE( taucmcd,pzd,pwvcmd,semissd,planklayd,planklevd,plankbndd,gurad,gdrad,gclrurad,gclrdrad,& +!$OMP gdtotuflux_dtd,gdtotuclfl_dtd,idrvd,bpaded,heatfacd,fluxfacd,a0d,a1d,a2d, & +!$OMP delwaved,totufluxd,totdfluxd,fnetd,htrd,totuclfld,totdclfld,fnetcd,htrcd,dtotuflux_dtd, & +!$OMP dtotuclfl_dtd,dplankbnd_dtd ) +#endif + + contains + +!----------------------------------------------------------------------------- + _gpuker subroutine rtrnmcg(ncol, nlayers, istart, iend, iout & +#include "rrtmg_lw_cpu_args.h" + ,ngb,icldlyr, taug, fracsd, cldfmcd) +!----------------------------------------------------------------------------- +! +! Original version: E. J. Mlawer, et al. RRTM_V3.0 +! Revision for GCMs: Michael J. Iacono; October, 2002 +! Revision for F90: Michael J. Iacono; June, 2006 +! Revision for dFdT option: M. J. Iacono and E. J. Mlawer, November 2009 +! +! This program calculates the upward fluxes, downward fluxes, and +! heating rates for an arbitrary clear or cloudy atmosphere. The input +! to this program is the atmospheric profile, all Planck function +! information, and the cloud fraction by layer. A variable diffusivity +! angle (SECDIFF) is used for the angle integration. Bands 2-3 and 5-9 +! use a value for SECDIFF that varies from 1.50 to 1.80 as a function of +! the column water vapor, and other bands use a value of 1.66. The Gaussian +! weight appropriate to this angle (WTDIFF=0.5) is applied here. Note that +! use of the emissivity angle for the flux integration can cause errors of +! 1 to 4 W/m2 within cloudy layers. +! Clouds are treated with the McICA stochastic approach and maximum-random +! cloud overlap. +! This subroutine also provides the optional capability to calculate +! the derivative of upward flux respect to surface temperature using +! the pre-tabulated derivative of the Planck function with respect to +! temperature integrated over each spectral band. +!*************************************************************************** + +! ------- Declarations ------- + +! ----- Input ----- + integer(kind=4), value, intent(in) :: nlayers ! total number of layers + integer(kind=4), value, intent(in) :: ncol ! total number of columns + integer(kind=4), value, intent(in) :: istart ! beginning band of calculation + integer(kind=4), value, intent(in) :: iend ! ending band of calculation + integer(kind=4), value, intent(in) :: iout ! output option flag + integer , intent(in) :: ngb(:) ! band index + + integer , intent(in) :: icldlyr(:,:) + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) + real _gpudev :: cldfmcd(:,:,:) + +#include "rrtmg_lw_cpu_defs.h" + + ! ----- Local ----- +! Declarations for radiative transfer + +#ifndef _ACCEL +# define IDIM (ncol) +# define IDIM1 ncol, +#else +# define IDIM +# define IDIM1 +#endif + + real :: atot( IDIM1 mxlay) + real :: atrans( IDIM1 mxlay) + real :: bbugas( IDIM1 mxlay) + real :: bbutot( IDIM1 mxlay) + + real :: uflux( IDIM1 0:mxlay) + real :: dflux( IDIM1 0:mxlay) + real :: uclfl( IDIM1 0:mxlay) + real :: dclfl( IDIM1 0:mxlay) + +#ifndef _ACCEL +# define atot(X) ATOT(iplon,X) +# define atrans(X) ATRANS(iplon,X) +# define bbugas(X) BBUGAS(iplon,X) +# define bbutot(X) BBUTOT(iplon,X) +# define uflux(X) UFLUX(iplon,X) +# define dflux(X) DFLUX(iplon,X) +# define uclfl(X) UCLFL(iplon,X) +# define dclfl(X) DCLFL(iplon,X) +#endif + + real :: odclds + real :: efclfracs + real :: absclds + + real :: secdiff IDIM ! secant of diffusivity angle + real :: transcld, radld IDIM, radclrd IDIM, plfrac, blay, dplankup, dplankdn + real :: odepth, odtot, odepth_rec, odtot_rec, gassrc + real :: tblind, tfactot, bbd, bbdtot, tfacgas, transc, tausfac + real :: rad0, reflect, radlu IDIM , radclru IDIM + real :: d_rad0_dt, d_radlu_dt IDIM , d_radclru_dt IDIM + + integer :: ibnd, ib, lay, lev, l, ig ! loop indices + integer :: igc ! g-point interval counter + integer :: iclddn IDIM ! flag for cloud in down path + integer :: ittot, itgas, itr ! lookup table indices + +! ------- Definitions ------- +! input +! nlayers ! number of model layers +! ngptlw ! total number of g-point subintervals +! nbndlw ! number of longwave spectral bands +! ncbands ! number of spectral bands for clouds +! secdiff ! diffusivity angle +! wtdiff ! weight for radiance to flux conversion +! pavel ! layer pressures (mb) +! pz ! level (interface) pressures (mb) +! tavel ! layer temperatures (k) +! tz ! level (interface) temperatures(mb) +! tbound ! surface temperature (k) +! cldfrac ! layer cloud fraction +! taucloud ! layer cloud optical depth +! itr ! integer look-up table index +! icldlyr ! flag for cloudy layers +! iclddn ! flag for cloud in column at any layer +! semiss ! surface emissivities for each band +! reflect ! surface reflectance +! bpade ! 1/(pade constant) +! tau_tbl ! clear sky optical depth look-up table +! exp_tbl ! exponential look-up table for transmittance +! tfn_tbl ! tau transition function look-up table + +! local +! atrans ! gaseous absorptivity +! abscld ! cloud absorptivity +! atot ! combined gaseous and cloud absorptivity +! odclr ! clear sky (gaseous) optical depth +! odcld ! cloud optical depth +! odtot ! optical depth of gas and cloud +! tfacgas ! gas-only pade factor, used for planck fn +! tfactot ! gas and cloud pade factor, used for planck fn +! bbdgas ! gas-only planck function for downward rt +! bbugas ! gas-only planck function for upward rt +! bbdtot ! gas and cloud planck function for downward rt +! bbutot ! gas and cloud planck function for upward calc. +! gassrc ! source radiance due to gas only +! efclfrac ! effective cloud fraction +! radlu ! spectrally summed upward radiance +! radclru ! spectrally summed clear sky upward radiance +! urad ! upward radiance by layer +! clrurad ! clear sky upward radiance by layer +! radld ! spectrally summed downward radiance +! radclrd ! spectrally summed clear sky downward radiance +! drad ! downward radiance by layer +! clrdrad ! clear sky downward radiance by layer +! d_radlu_dt ! spectrally summed upward radiance +! d_radclru_dt ! spectrally summed clear sky upward radiance +! d_urad_dt ! upward radiance by layer +! d_clrurad_dt ! clear sky upward radiance by layer + +! output +! totuflux ! upward longwave flux (w/m2) +! totdflux ! downward longwave flux (w/m2) +! fnet ! net longwave flux (w/m2) +! htr ! longwave heating rate (k/day) +! totuclfl ! clear sky upward longwave flux (w/m2) +! totdclfl ! clear sky downward longwave flux (w/m2) +! fnetc ! clear sky net longwave flux (w/m2) +! htrc ! clear sky longwave heating rate (k/day) +! dtotuflux_dt ! change in upward longwave flux (w/m2/k) +! ! with respect to surface temperature +! dtotuclfl_dt ! change in clear sky upward longwave flux (w/m2/k) +! + + +! This secant and weight corresponds to the standard diffusivity +! angle. This initial value is redefined below for some bands. + real , parameter :: wtdiff = 0.5 + real , parameter :: rec_6 = 0.166667 + +! Reset diffusivity angle for Bands 2-3 and 5-9 to vary (between 1.50 +! and 1.80) as a function of total column water vapor. The function +! has been defined to minimize flux and cooling rate errors in these bands +! over a wide range of precipitable water values. + + integer :: iplon + real :: bbb + +! (dmb 2012) Here we compute the index for the column and band dimensions +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + igc = (blockidx%y-1) * blockdim%y + threadidx%y +! (dmb 2012) Make sure that the column and bands are within the proper ranges + if (iplon <= ncol .and. igc<=140) then + + +#else + do igc = 1, 140 +# define secdiff SECDIFF(iplon) +#endif + ibnd = ngb(igc) + + ILOOP_S_CPU + if (ibnd.eq.1 .or. ibnd.eq.4 .or. ibnd.ge.10) then + secdiff = 1.66 + else + secdiff = a0d(ibnd) + a1d(ibnd)*exp(a2d(ibnd)*pwvcmd(iplon)) + if (secdiff .gt. 1.80 ) secdiff = 1.80 + if (secdiff .lt. 1.50 ) secdiff = 1.50 + endif + gurad(iplon, igc, 0) = 0.0 + gdrad(iplon, igc, 0) = 0.0 +!totuflux(iplon,igc,0) = 0.0 +!totdflux(iplon,igc,0) = 0.0 + gclrurad(iplon, igc, 0) = 0.0 + gclrdrad(iplon, igc, 0) = 0.0 +!totuclfl(iplon,igc,0) = 0.0 +!totdclfl(iplon,igc,0) = 0.0 + if (idrvd .eq. 1) then + gdtotuflux_dtd(iplon,igc,0) = 0.0 + gdtotuclfl_dtd(iplon,igc,0) = 0.0 + endif + ILOOP_E_CPU + + do lay = 1, nlayers + ILOOP_S_CPU + gurad(iplon, igc, lay) = 0.0 + gdrad(iplon, igc, lay) = 0.0 + gclrurad(iplon, igc, lay) = 0.0 + gclrdrad(iplon, igc, lay) = 0.0 + +! (dmb 2012) I removed the band loop here because it was terribly inefficient +! I now set the required variables outside of the kernel + + if (idrvd .eq. 1) then + gdtotuflux_dtd(iplon,igc,lay) = 0.0 + gdtotuclfl_dtd(iplon,igc,lay) = 0.0 + endif + ILOOP_E_CPU + enddo + +! Radiative transfer starts here. + radld = 0. + radclrd = 0. + iclddn = 0 + +! Downward radiative transfer loop. + +# ifndef _ACCEL +# define radld RADLD(iplon) +# define radclrd RADCLRD(iplon) +# define iclddn ICLDDN(iplon) +# endif + + do lev = nlayers, 1, -1 + ILOOP_S_CPU + plfrac = fracsd(iplon,lev,igc) + blay = planklayd(iplon,lev,ibnd) + dplankup = planklevd(iplon,lev,ibnd) - blay + dplankdn = planklevd(iplon,lev-1,ibnd) - blay + odepth = secdiff * taug(iplon,lev,igc) + if (odepth .lt. 0.0 ) odepth = 0.0 +! Cloudy layer + if (icldlyr(iplon, lev).eq.1) then + iclddn = 1 +! (dmb 2012) Here instead of using the lookup tables to compute +! the optical depth and related quantities, I compute them on the +! fly because this is actually much more efficient on the GPU. + odclds = secdiff * taucmcd(iplon,igc,lev) + absclds = 1. - exp(-odclds) + efclfracs = absclds * cldfmcd(iplon, igc,lev) + odtot = odepth + odclds + +#ifdef _ACCEL + tblind = odepth/(bpaded+odepth) + itgas = tblint*tblind+0.5 + bbb = itgas / float(tblint) + odepth = bpaded * bbb / (1. - bbb) + + atrans(lev) = exp( -odepth) + atrans(lev) = 1 -atrans(lev) +! (dmb 2012) Compute tfacgas on the fly. Even though this is an expensive operation, +! it is more efficient to do the calculation within the kernel on the GPU. + if (odepth < 0.06) then + tfacgas = odepth/6. + else + tfacgas = 1. -2. *((1. /odepth)-((1. - atrans(lev))/(atrans(lev)))) + endif + gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn) + + odtot = odepth + odclds + tblind = odtot/(bpaded+odtot) + ittot = tblint*tblind + 0.5 + bbb = ittot / float(tblint) + bbb = bpaded * bbb / (1. - bbb) + atot(lev) = 1. - exp(-bbb) + if (bbb < 0.06) then + tfactot = bbb/6. + else + tfactot = 1. -2. *((1. /bbb)-((1-atot(lev))/(atot(lev)))) + endif + bbdtot = plfrac * (blay + tfactot*dplankdn) + bbd = plfrac*(blay+tfacgas*dplankdn) +#else + tblind = odepth/(bpade+odepth) + itgas = tblint*tblind+0.5 + odepth = tau_tbl(itgas) + atrans(lev) = 1. - exp_tbl(itgas) + tfacgas = tfn_tbl(itgas) + gassrc = atrans(lev) * plfrac * (blay + tfacgas*dplankdn) + + odtot = odepth + odclds + tblind = odtot/(bpade+odtot) + ittot = tblint*tblind + 0.5 + tfactot = tfn_tbl(ittot) + bbdtot = plfrac * (blay + tfactot*dplankdn) + bbd = plfrac*(blay+tfacgas*dplankdn) + atot(lev) = 1. - exp_tbl(ittot) +#endif + + radld = radld - radld * (atrans(lev) + & + efclfracs * (1. - atrans(lev))) + & + gassrc + cldfmcd(iplon, igc,lev) * & + (bbdtot * atot(lev) - gassrc) + gdrad(iplon, igc, lev-1) = gdrad(iplon, igc, lev-1) + radld + bbugas(lev) = plfrac * (blay + tfacgas * dplankup) + bbutot(lev) = plfrac * (blay + tfactot * dplankup) + +! Clear layer + else + +#ifdef _ACCEL + tblind = odepth/(bpaded+odepth) + itr = tblint*tblind+0.5 +! (dmb 2012) Compute the atrans and related values on the fly instead +! of using the lookup tables. + bbb = itr/float(tblint) + bbb = bpaded * bbb / (1. - bbb) + transc = exp( -bbb ) + if (transc < 1.e-20 ) transc = 1.e-20 + atrans(lev) = 1. -transc + + if (bbb < 0.06 ) then + tausfac = bbb/6. + else + tausfac = 1. -2. *((1. /bbb)-(transc/(1.-transc))) + endif + + bbd = plfrac*(blay+tausfac*dplankdn) + bbugas(lev) = plfrac * (blay + tausfac * dplankup) +#else +# if 0 + tblind = odepth/(bpade+odepth) + itr = tblint*tblind+0.5 + transc = exp_tbl(itr) + atrans(lev) = 1. -transc + tausfac = tfn_tbl(itr) + bbd = plfrac*(blay+tausfac*dplankdn) + bbugas(lev) = plfrac * (blay + tausfac * dplankup) +# else + ! jm agree with the calculation in module_ra_rrtmg_lw.F ~line 3340 + if (odepth .le. 0.06) then + atrans(lev) = odepth-0.5*odepth*odepth + odepth = rec_6*odepth + bbd = plfrac*(blay+dplankdn*odepth) + bbugas(lev) = plfrac*(blay+dplankup*odepth) + else + tblind = odepth/(bpade+odepth) + itr = tblint*tblind+0.5 + transc = exp_tbl(itr) + atrans(lev) = 1.-transc + tausfac = tfn_tbl(itr) + bbd = plfrac*(blay+tausfac*dplankdn) + bbugas(lev) = plfrac * (blay + tausfac * dplankup) + endif +# endif +#endif + radld = radld + (bbd-radld )*atrans(lev) + gdrad(iplon, igc, lev-1) = gdrad(iplon, igc, lev-1) + radld + + endif + +! Set clear sky stream to total sky stream as long as layers +! remain clear. Streams diverge when a cloud is reached (iclddn=1), +! and clear sky stream must be computed separately from that point. + if (iclddn .eq.1) then + radclrd = radclrd + (bbd-radclrd) * atrans(lev) +! (dmb 2012) Rather than summing up the results and then computing the +! total fluxes, I store the g-point specific values in GPU arrays to be +! summed up later in a new kernel. This ensures that we can parallelize +! across enough dimensions so that the GPU remains busy. + gclrdrad(iplon, igc, lev-1) = gclrdrad(iplon, igc, lev-1) + radclrd + else + radclrd = radld + gclrdrad(iplon, igc, lev-1) = gdrad(iplon, igc, lev-1) + endif + ILOOP_E_CPU + enddo ! end of downward radiation loop + +! Spectral emissivity & reflectance +! Include the contribution of spectrally varying longwave emissivity +! and reflection from the surface to the upward radiative transfer. +! Note: Spectral and Lambertian reflection are identical for the +! diffusivity angle flux integration used here. +! Note: The emissivity is applied to plankbnd and dplankbnd_dt when +! they are defined in subroutine setcoef. + +# ifndef _ACCEL +# define radlu RADLU(iplon) +# define radclru RADCLRU(iplon) +# define d_radlu_dt D_RADLU_DT(iplon) +# define d_radclru_dt D_RADCLRU_DT(iplon) +# endif + + ILOOP_S_CPU + rad0 = fracsd(iplon,1,igc) * plankbndd(iplon,ibnd) +! Add in specular reflection of surface downward radiance. + reflect = 1. - semissd(iplon,ibnd) + radlu = rad0 + reflect * radld + radclru = rad0 + reflect * radclrd + + + + +! Upward radiative transfer loop. + gurad(iplon, igc, 0) = gurad(iplon, igc, 0) + radlu + gclrurad(iplon, igc, 0) = gclrurad(iplon, igc, 0) + radclru + ILOOP_E_CPU + + do lev = 1, nlayers + ILOOP_S_CPU +! Cloudy layer + if (icldlyr(iplon, lev) .eq. 1) then + gassrc = bbugas(lev) * atrans(lev) + odclds = secdiff * taucmcd(iplon,igc,lev) + absclds = 1. - exp(-odclds) + efclfracs = absclds * cldfmcd(iplon, igc,lev) + radlu = radlu - radlu * (atrans(lev) + & + efclfracs * (1. - atrans(lev))) + & + gassrc + cldfmcd(iplon, igc,lev) * & + (bbutot(lev) * atot(lev) - gassrc) + gurad(iplon, igc, lev) = gurad(iplon, igc, lev) + radlu +! Clear layer + else + radlu = radlu + (bbugas(lev)-radlu)*atrans(lev) + gurad(iplon, igc, lev) = gurad(iplon, igc, lev) + radlu + endif + + + +! Set clear sky stream to total sky stream as long as all layers +! are clear (iclddn=0). Streams must be calculated separately at +! all layers when a cloud is present (ICLDDN=1), because surface +! reflectance is different for each stream. + if (iclddn.eq.1) then + radclru = radclru + (bbugas(lev)-radclru)*atrans(lev) + gclrurad(iplon, igc, lev) = gclrurad(iplon, igc, lev) + radclru + else + radclru = radlu + gclrurad(iplon, igc, lev) = gurad(iplon, igc, lev) + endif + ILOOP_E_CPU + enddo + + + tblind = wtdiff * delwaved(ibnd) * fluxfacd + ! (dmb 2012) Now that the g-points values were created, we modify them + ! so that later summation (integration) will be simpler. + do lev = 0, nlayers + ILOOP_S_CPU + gurad(iplon, igc, lev) = gurad(iplon, igc, lev) * tblind + gdrad(iplon, igc, lev) = gdrad(iplon, igc, lev) * tblind + gclrurad(iplon, igc, lev) = gclrurad(iplon, igc, lev) * tblind + gclrdrad(iplon, igc, lev) = gclrdrad(iplon, igc, lev) * tblind + ILOOP_E_CPU + end do + +#ifdef _ACCEL + endif +#else + end do ! igc loop +#endif + + end subroutine rtrnmcg + +! (dmb 2012) This subroutine adds up the indivial g-point fluxes to arrive at a +! final upward and downward flux value for each column and layer. This subroutine +! is parallelized across the column and layer dimensions. As long as we parallelize +! across two of the three dimesnions, we should usually have enough GPU saturation. + _gpuker subroutine rtrnadd(ncol, nlay, ngpt, drvf & +#include "rrtmg_lw_cpu_args.h" + ) + + integer, intent(in), value :: ncol + integer, intent(in), value :: nlay + integer, intent(in), value :: ngpt + integer, intent(in), value :: drvf +#include "rrtmg_lw_cpu_defs.h" + + integer :: iplon, ilay, igp +! real :: d(140) + +! (dmb 2012) compute the column and layer indices from the grid and block +! configurations. + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + ilay = (blockidx%y-1) * blockdim%y + threadidx%y - 1 + +! (dmb 2012) make sure that the column and layer are within range + if (ilay <= nlay .and. iplon <= ncol) then +#else +! zap should move this inside the igp loop + do iplon = 1, ncol + do ilay = 0, nlay +#endif + + do igp = 1, ngpt + + totufluxd(iplon, ilay)=totufluxd(iplon, ilay)+gurad(iplon, igp, ilay) + totdfluxd(iplon, ilay)=totdfluxd(iplon, ilay)+gdrad(iplon, igp, ilay) + totuclfld(iplon, ilay)=totuclfld(iplon, ilay)+gclrurad(iplon, igp, ilay) + totdclfld(iplon, ilay)=totdclfld(iplon, ilay)+gclrdrad(iplon, igp, ilay) + + end do + + if (drvf .eq. 1) then + + do igp = 1, ngpt + + dtotuflux_dtd(iplon, ilay) = dtotuflux_dtd(iplon, ilay) + gdtotuflux_dtd( iplon, igp, ilay) + dtotuclfl_dtd(iplon, ilay) = dtotuclfl_dtd(iplon, ilay) + gdtotuclfl_dtd( iplon, igp, ilay) + + end do + + end if + +#ifdef _ACCEL + end if +#else + end do + end do +#endif + + end subroutine + +! (dmb 2012) This kernel computes the heating rates separately. It is parallelized across the +! columnn and layer dimensions. + _gpuker subroutine rtrnheatrates(ncol, nlay & +#include "rrtmg_lw_cpu_args.h" + ) + + integer, intent(in), value :: ncol + integer, intent(in), value :: nlay +#include "rrtmg_lw_cpu_defs.h" + + real :: t2 + integer :: iplon, ilay + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + ilay = (blockidx%y-1) * blockdim%y + threadidx%y - 1 + + + if (ilay kind , rb => kind + use parrrtm_f, only : mg, nbndlw, maxxsec, ngptlw + use rrlw_con_f, only: oneminus + use rrlw_wvn_f, only: nspa, nspb + use rrlw_vsn_f, only: hvrtau, hnamtau + use rrlw_wvn_f, only: ngb + use rrlw_ref_f + use memory + +#ifdef _ACCEL + use cudafor +#endif + + implicit none + +#ifdef _ACCEL +! (dmb 2012) There are a lot of GPU module level variables in this module +! The parameter list for the taumol subroutines have been reduced for +! efficiency and readability. +! (jm 2014) not thread-safe + real _gpudev, allocatable :: pavel(:,:) + real _gpudev, allocatable :: wx1(:,:) + real _gpudev, allocatable :: wx2(:,:) + real _gpudev, allocatable :: wx3(:,:) + real _gpudev, allocatable :: wx4(:,:) + real _gpudev, allocatable :: coldry(:,:) + integer _gpudev, allocatable :: laytrop(:) + integer _gpudev, allocatable :: jp(:,:) + integer _gpudev, allocatable :: jt(:,:) + integer _gpudev, allocatable :: jt1(:,:) + real _gpudev, allocatable :: colh2o(:,:) + real _gpudev, allocatable :: colco2(:,:) + real _gpudev, allocatable :: colo3(:,:) + real _gpudev, allocatable :: coln2o(:,:) + real _gpudev, allocatable :: colco(:,:) + real _gpudev, allocatable :: colch4(:,:) + real _gpudev, allocatable :: colo2(:,:) + real _gpudev, allocatable :: colbrd(:,:) + integer _gpudev, allocatable :: indself(:,:) + integer _gpudev, allocatable :: indfor(:,:) + real _gpudev, allocatable :: selffac(:,:) + real _gpudev, allocatable :: selffrac(:,:) + real _gpudev, allocatable :: forfac(:,:) + real _gpudev, allocatable :: forfrac(:,:) + integer _gpudev, allocatable :: indminor(:,:) + real _gpudev, allocatable :: minorfrac(:,:) + real _gpudev, allocatable :: scaleminor(:,:) + real _gpudev, allocatable :: scaleminorn2(:,:) + real _gpudev, allocatable :: fac00(:,:), fac01(:,:), fac10(:,:), fac11(:,:) + real _gpudev, allocatable :: rat_h2oco2(:,:),rat_h2oco2_1(:,:), & + rat_h2oo3(:,:),rat_h2oo3_1(:,:), & + rat_h2on2o(:,:),rat_h2on2o_1(:,:), & + rat_h2och4(:,:),rat_h2och4_1(:,:), & + rat_n2oco2(:,:),rat_n2oco2_1(:,:), & + rat_o3co2(:,:),rat_o3co2_1(:,:) + ! Dimensions: (ncol,nlayers) + real _gpudev, allocatable :: tauaa(:,:,:) + ! Dimensions: (ncol,nlayers,ngptlw) + + integer _gpudev, allocatable :: nspad(:) + integer _gpudev, allocatable :: nspbd(:) + real _gpucon :: oneminusd +!$OMP THREADPRIVATE( pavel,wx1,wx2,wx3,wx4,coldry,laytrop,jp,jt,jt1,colh2o,colco2,colo3,coln2o, & +!$OMP colco,colch4,colo2,colbrd,indself,indfor,selffac,selffrac,forfac,forfrac, & +!$OMP indminor,minorfrac,scaleminor,scaleminorn2,fac00,fac01,fac10,fac11, & +!$OMP rat_h2oco2,rat_h2oco2_1,rat_h2oo3,rat_h2oo3_1,rat_h2on2o,rat_h2on2o_1, & +!$OMP rat_h2och4,rat_h2och4_1,rat_n2oco2,rat_n2oco2_1,rat_o3co2,rat_o3co2_1, & +!$OMP tauaa,nspad,nspbd,oneminusd ) +#endif + + contains + +#ifndef _ACCEL +!defines for taugb functions + +# define absad absa +# define absbd absb +# define absbod absbo +# define ccl4d ccl4 +# define ccl4od ccl4o +# define cfc11adjd cfc11adj +# define cfc11adjod cfc11adjo +# define cfc12d cfc12 +# define cfc12od cfc12o +# define cfc22adjd cfc22adj +# define cfc22adjod cfc22adjo +# define forrefd forref +# define forrefod forrefo +# define fracrefad fracrefa +# define fracrefaod fracrefao +# define fracrefbd fracrefb +# define fracrefbod fracrefbo +# define kad ka +# define ka_mcod ka_mco +# define ka_mco2d ka_mco2 +# define ka_mn2d ka_mn2 +# define ka_mn2od ka_mn2o +# define ka_mo2d ka_mo2 +# define ka_mo3d ka_mo3 +# define kaod kao +# define kao_mcod kao_mco +# define kao_mco2d kao_mco2 +# define kao_mn2d kao_mn2 +# define kao_mn2od kao_mn2o +# define kao_mo3d kao_mo3 +# define kbd kb +# define kb_mco2d kb_mco2 +# define kb_mn2d kb_mn2 +# define kb_mn2od kb_mn2o +# define kb_mo2d kb_mo2 +# define kb_mo3d kb_mo3 +# define kbod kbo +# define kbo_mco2d kbo_mco2 +# define kbo_mn2od kbo_mn2o +# define kbo_mo3d kbo_mo3 +# define selfrefd selfref +# define selfrefod selfrefo + +#endif +!---------------------------------------------------------------------------- + _gpuker subroutine taugb1g( ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + +!---------------------------------------------------------------------------- + +! ------- Modifications ------- +! Written by Eli J. Mlawer, Atmospheric & Environmental Research. +! Revised by Michael J. Iacono, Atmospheric & Environmental Research. +! +! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) +! (high key - h2o; high minor - n2) +! +! note: previous versions of rrtm band 1: +! 10-250 cm-1 (low - h2o; high - h2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng1 + use rrlw_kg01_f + +! ------- Declarations ------- + + integer :: lay, ind0, ind1, inds, indf, indm, ig + real :: pp, corradj, scalen2, tauself, taufor, taun2 + integer , value, intent(in) :: ncol, nlayers + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) +#include "taug_cpu_defs.h" + +! Local + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif + +! Minor gas mapping levels: +! lower - n2, p = 142.5490 mbar, t = 215.70 k +! upper - n2, p = 142.5490 mbar, t = 215.70 k + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below laytrop, the water vapor self-continuum and +! foreign continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + + + if (lay <= laytrop(iplon)) then + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(1) + 1 + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(1) + 1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + pp = pavel(iplon, lay) + corradj = 1. + if (pp .lt. 250. ) then + corradj = 1. - 0.15 * (250. -pp) / 154.4 + endif + + scalen2 = colbrd(iplon,lay) * scaleminorn2(iplon,lay) + do ig = 1, ng1 + tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + taun2 = scalen2*(ka_mn2d(indm,ig) + & + minorfrac(iplon,lay) * (ka_mn2d(indm+1,ig) - ka_mn2d(indm,ig))) + taug(iplon,lay,ig) = corradj * (colh2o(iplon,lay) * & + (fac00(iplon,lay) * absad(ind0,ig) + & + fac10(iplon,lay) * absad(ind0+1,ig) + & + fac01(iplon,lay) * absad(ind1,ig) + & + fac11(iplon,lay) * absad(ind1+1,ig)) & + + tauself + taufor + taun2) + fracsd(iplon,lay,ig) = fracrefad(ig) + + enddo + else + + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(1) + 1 + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(1) + 1 + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + pp = pavel(iplon, lay) + corradj = 1. - 0.15 * (pp / 95.6 ) + + scalen2 = colbrd(iplon,lay) * scaleminorn2(iplon,lay) + do ig = 1, ng1 + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + & + forfrac(iplon,lay) * (forrefd(indf+1,ig) - forrefd(indf,ig))) + taun2 = scalen2*(kb_mn2d(indm,ig) + & + minorfrac(iplon,lay) * (kb_mn2d(indm+1,ig) - kb_mn2d(indm,ig))) + taug(iplon,lay,ig) = corradj * (colh2o(iplon,lay) * & + (fac00(iplon,lay) * absbd(ind0,ig) + & + fac10(iplon,lay) * absbd(ind0+1,ig) + & + fac01(iplon,lay) * absbd(ind1,ig) + & + fac11(iplon,lay) * absbd(ind1+1,ig)) & + + taufor + taun2) + fracsd(iplon,lay,ig) = fracrefbd(ig) + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb1g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb2g( ncol, nlayers , taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) +! +! note: previous version of rrtm band 2: +! 250 - 500 cm-1 (low - h2o; high - h2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng2, ngs1 + use parrrtm_f, only : ngs1 + use rrlw_kg02_f + +! ------- Declarations ------- + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) +#include "taug_cpu_defs.h" + +! Local + integer :: lay, ind0, ind1, inds, indf, ig + real :: pp, corradj, tauself, taufor + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below laytrop, the water vapor self-continuum and +! foreign continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(2) + 1 + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(2) + 1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + pp = pavel(iplon, lay) + corradj = 1. - .05 * (pp - 100. ) / 900. + do ig = 1, ng2 + tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + taug(iplon,lay,ngs1+ig) = corradj * (colh2o(iplon,lay) * & + (fac00(iplon,lay) * absad(ind0,ig) + & + fac10(iplon,lay) * absad(ind0+1,ig) + & + fac01(iplon,lay) * absad(ind1,ig) + & + fac11(iplon,lay) * absad(ind1+1,ig)) & + + tauself + taufor) + fracsd(iplon,lay,ngs1+ig) = fracrefad(ig) + enddo + else + + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(2) + 1 + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(2) + 1 + indf = indfor(iplon,lay) + do ig = 1, ng2 + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + & + forfrac(iplon,lay) * (forrefd(indf+1,ig) - forrefd(indf,ig))) + taug(iplon,lay,ngs1+ig) = colh2o(iplon,lay) * & + (fac00(iplon,lay) * absbd(ind0,ig) + & + fac10(iplon,lay) * absbd(ind0+1,ig) + & + fac01(iplon,lay) * absbd(ind1,ig) + & + fac11(iplon,lay) * absbd(ind1+1,ig)) & + + taufor + fracsd(iplon,lay,ngs1+ig) = fracrefbd(ig) + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb2g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb3g( ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) +! (high key - h2o,co2; high minor - n2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng3, ngs2 + use parrrtm_f, only : ngs2 + use rrlw_ref_f, only : chi_mlsd + use rrlw_kg03_f + +! ------- Declarations ------- +#include "taug_cpu_defs.h" + +! Local + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) + + integer :: lay, ind0, ind1, inds, indf, indm, ig + integer :: js, js1, jmn2o, jpl + real :: speccomb, specparm, specmult, fs + real :: speccomb1, specparm1, specmult1, fs1 + real :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, & + fmn2o, fmn2omf, chi_n2o, ratn2o, adjfac, adjcoln2o + real :: speccomb_planck, specparm_planck, specmult_planck, fpl + real :: p, p4, fk0, fk1, fk2 + real :: fac000, fac100, fac200, fac010, fac110, fac210 + real :: fac001, fac101, fac201, fac011, fac111, fac211 + real :: tauself, taufor, n2om1, n2om2, absn2o + real :: refrat_planck_a, refrat_planck_b, refrat_m_a, refrat_m_b + real :: tau_major, tau_major1 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Minor gas mapping levels: +! lower - n2o, p = 706.272 mbar, t = 278.94 k +! upper - n2o, p = 95.58 mbar, t = 215.7 k + +! P = 212.725 mb + refrat_planck_a = chi_mlsd(1,9)/chi_mlsd(2,9) + +! P = 95.58 mb + refrat_planck_b = chi_mlsd(1,13)/chi_mlsd(2,13) + +! P = 706.270mb + refrat_m_a = chi_mlsd(1,3)/chi_mlsd(2,3) + +! P = 95.58 mb + refrat_m_b = chi_mlsd(1,13)/chi_mlsd(2,13) + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature, and appropriate species. Below laytrop, the water vapor +! self-continuum and foreign continuum is interpolated (in temperature) +! separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + + speccomb = colh2o(iplon,lay) + rat_h2oco2(iplon,lay)*colco2(iplon,lay) + specparm = colh2o(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = colh2o(iplon,lay) + rat_h2oco2_1(iplon,lay)*colco2(iplon,lay) + specparm1 = colh2o(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 8. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + speccomb_mn2o = colh2o(iplon,lay) + refrat_m_a*colco2(iplon,lay) + specparm_mn2o = colh2o(iplon,lay)/speccomb_mn2o + if (specparm_mn2o .ge. oneminusd) specparm_mn2o = oneminusd + specmult_mn2o = 8. *specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o,1.0 ) + fmn2omf = minorfrac(iplon,lay)*fmn2o +! In atmospheres where the amount of N2O is too great to be considered +! a minor species, adjust the column amount of N2O by an empirical factor +! to obtain the proper contribution. + chi_n2o = coln2o(iplon,lay)/coldry(iplon,lay) + ratn2o = 1.e20 *chi_n2o/chi_mlsd(4,jp(iplon,lay)+1) + if (ratn2o .gt. 1.5 ) then + adjfac = 0.5 +(ratn2o-0.5 )**0.65 + adjcoln2o = adjfac*chi_mlsd(4,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20 + else + adjcoln2o = coln2o(iplon,lay) + endif + + speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colco2(iplon,lay) + specparm_planck = colh2o(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 8. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(3) + js + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(3) + js1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + + if (specparm .lt. 0.125 ) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else if (specparm .gt. 0.875 ) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + endif + if (specparm1 .lt. 0.125 ) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else if (specparm1 .gt. 0.875 ) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + endif + + do ig = 1, ng3 + tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + n2om1 = ka_mn2od(jmn2o,indm,ig) + fmn2o * & + (ka_mn2od(jmn2o+1,indm,ig) - ka_mn2od(jmn2o,indm,ig)) + n2om2 = ka_mn2od(jmn2o,indm+1,ig) + fmn2o * & + (ka_mn2od(jmn2o+1,indm+1,ig) - ka_mn2od(jmn2o,indm+1,ig)) + absn2o = n2om1 + minorfrac(iplon,lay) * (n2om2 - n2om1) + + if (specparm .lt. 0.125 ) then + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac200 * absad(ind0+2,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig) + & + fac210 * absad(ind0+11,ig)) + else if (specparm .gt. 0.875 ) then + tau_major = speccomb * & + (fac200 * absad(ind0-1,ig) + & + fac100 * absad(ind0,ig) + & + fac000 * absad(ind0+1,ig) + & + fac210 * absad(ind0+8,ig) + & + fac110 * absad(ind0+9,ig) + & + fac010 * absad(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125 ) then + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac201 * absad(ind1+2,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig) + & + fac211 * absad(ind1+11,ig)) + else if (specparm1 .gt. 0.875 ) then + tau_major1 = speccomb1 * & + (fac201 * absad(ind1-1,ig) + & + fac101 * absad(ind1,ig) + & + fac001 * absad(ind1+1,ig) + & + fac211 * absad(ind1+8,ig) + & + fac111 * absad(ind1+9,ig) + & + fac011 * absad(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig)) + endif + + taug(iplon,lay,ngs2+ig) = tau_major + tau_major1 & + + tauself + taufor & + + adjcoln2o*absn2o + fracsd(iplon,lay,ngs2+ig) = fracrefad(ig,jpl) + fpl * & + (fracrefad(ig,jpl+1)-fracrefad(ig,jpl)) + enddo + + +! Upper atmosphere loop + else + + speccomb = colh2o(iplon,lay) + rat_h2oco2(iplon,lay)*colco2(iplon,lay) + specparm = colh2o(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 4. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = colh2o(iplon,lay) + rat_h2oco2_1(iplon,lay)*colco2(iplon,lay) + specparm1 = colh2o(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 4. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + + speccomb_mn2o = colh2o(iplon,lay) + refrat_m_b*colco2(iplon,lay) + specparm_mn2o = colh2o(iplon,lay)/speccomb_mn2o + if (specparm_mn2o .ge. oneminusd) specparm_mn2o = oneminusd + specmult_mn2o = 4. *specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o,1.0 ) + fmn2omf = minorfrac(iplon,lay)*fmn2o +! In atmospheres where the amount of N2O is too great to be considered +! a minor species, adjust the column amount of N2O by an empirical factor +! to obtain the proper contribution. + chi_n2o = coln2o(iplon,lay)/coldry(iplon,lay) + ratn2o = 1.e20*chi_n2o/chi_mlsd(4,jp(iplon,lay)+1) + if (ratn2o .gt. 1.5 ) then + adjfac = 0.5 +(ratn2o-0.5 )**0.65 + adjcoln2o = adjfac*chi_mlsd(4,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20 + else + adjcoln2o = coln2o(iplon,lay) + endif + + speccomb_planck = colh2o(iplon,lay)+refrat_planck_b*colco2(iplon,lay) + specparm_planck = colh2o(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 4. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(3) + js + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(3) + js1 + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + + do ig = 1, ng3 + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + & + forfrac(iplon,lay) * (forrefd(indf+1,ig) - forrefd(indf,ig))) + n2om1 = kb_mn2od(jmn2o,indm,ig) + fmn2o * & + (kb_mn2od(jmn2o+1,indm,ig)-kb_mn2od(jmn2o,indm,ig)) + n2om2 = kb_mn2od(jmn2o,indm+1,ig) + fmn2o * & + (kb_mn2od(jmn2o+1,indm+1,ig)-kb_mn2od(jmn2o,indm+1,ig)) + absn2o = n2om1 + minorfrac(iplon,lay) * (n2om2 - n2om1) + taug(iplon,lay,ngs2+ig) = speccomb * & + (fac000 * absbd(ind0,ig) + & + fac100 * absbd(ind0+1,ig) + & + fac010 * absbd(ind0+5,ig) + & + fac110 * absbd(ind0+6,ig)) & + + speccomb1 * & + (fac001 * absbd(ind1,ig) + & + fac101 * absbd(ind1+1,ig) + & + fac011 * absbd(ind1+5,ig) + & + fac111 * absbd(ind1+6,ig)) & + + taufor & + + adjcoln2o*absn2o + fracsd(iplon,lay,ngs2+ig) = fracrefbd(ig,jpl) + fpl * & + (fracrefbd(ig,jpl+1)-fracrefbd(ig,jpl)) + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb3g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb4g( ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng4, ngs3 + use parrrtm_f, only : ngs3 + use rrlw_ref_f, only : chi_mlsd + use rrlw_kg04_f + +! ------- Declarations ------- +#include "taug_cpu_defs.h" + +! Local + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) + + + integer :: lay, ind0, ind1, inds, indf, ig + integer :: js, js1, jpl + real :: speccomb, specparm, specmult, fs + real :: speccomb1, specparm1, specmult1, fs1 + real :: speccomb_planck, specparm_planck, specmult_planck, fpl + real :: p, p4, fk0, fk1, fk2 + real :: fac000, fac100, fac200, fac010, fac110, fac210 + real :: fac001, fac101, fac201, fac011, fac111, fac211 + real :: tauself, taufor + real :: refrat_planck_a, refrat_planck_b + real :: tau_major, tau_major1 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! P = 142.5940 mb + refrat_planck_a = chi_mlsd(1,11)/chi_mlsd(2,11) + +! P = 95.58350 mb + refrat_planck_b = chi_mlsd(3,13)/chi_mlsd(2,13) + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated (in temperature) +! separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + + speccomb = colh2o(iplon,lay) + rat_h2oco2(iplon,lay)*colco2(iplon,lay) + specparm = colh2o(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = colh2o(iplon,lay) + rat_h2oco2_1(iplon,lay)*colco2(iplon,lay) + specparm1 = colh2o(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 8. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colco2(iplon,lay) + specparm_planck = colh2o(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 8. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(4) + js + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(4) + js1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + + if (specparm .lt. 0.125 ) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else if (specparm .gt. 0.875 ) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + endif + + if (specparm1 .lt. 0.125 ) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else if (specparm1 .gt. 0.875 ) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + endif + + do ig = 1, ng4 + tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + + if (specparm .lt. 0.125 ) then + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac200 * absad(ind0+2,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig) + & + fac210 * absad(ind0+11,ig)) + else if (specparm .gt. 0.875 ) then + tau_major = speccomb * & + (fac200 * absad(ind0-1,ig) + & + fac100 * absad(ind0,ig) + & + fac000 * absad(ind0+1,ig) + & + fac210 * absad(ind0+8,ig) + & + fac110 * absad(ind0+9,ig) + & + fac010 * absad(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125 ) then + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac201 * absad(ind1+2,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig) + & + fac211 * absad(ind1+11,ig)) + else if (specparm1 .gt. 0.875 ) then + tau_major1 = speccomb1 * & + (fac201 * absad(ind1-1,ig) + & + fac101 * absad(ind1,ig) + & + fac001 * absad(ind1+1,ig) + & + fac211 * absad(ind1+8,ig) + & + fac111 * absad(ind1+9,ig) + & + fac011 * absad(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig)) + endif + + taug(iplon,lay,ngs3+ig) = tau_major + tau_major1 & + + tauself + taufor + fracsd(iplon,lay,ngs3+ig) = fracrefad(ig,jpl) + fpl * & + (fracrefad(ig,jpl+1)-fracrefad(ig,jpl)) + enddo + + +! Upper atmosphere loop + else + + speccomb = colo3(iplon,lay) + rat_o3co2(iplon,lay)*colco2(iplon,lay) + specparm = colo3(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 4. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = colo3(iplon,lay) + rat_o3co2_1(iplon,lay)*colco2(iplon,lay) + specparm1 = colo3(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 4. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + + speccomb_planck = colo3(iplon,lay)+refrat_planck_b*colco2(iplon,lay) + specparm_planck = colo3(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 4. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(4) + js + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(4) + js1 + + do ig = 1, ng4 + taug(iplon,lay,ngs3+ig) = speccomb * & + (fac000 * absbd(ind0,ig) + & + fac100 * absbd(ind0+1,ig) + & + fac010 * absbd(ind0+5,ig) + & + fac110 * absbd(ind0+6,ig)) & + + speccomb1 * & + (fac001 * absbd(ind1,ig) + & + fac101 * absbd(ind1+1,ig) + & + fac011 * absbd(ind1+5,ig) + & + fac111 * absbd(ind1+6,ig)) + fracsd(iplon,lay,ngs3+ig) = fracrefbd(ig,jpl) + fpl * & + (fracrefbd(ig,jpl+1)-fracrefbd(ig,jpl)) + enddo + +! Empirical modification to code to improve stratospheric cooling rates +! for co2. Revised to apply weighting for g-point reduction in this band. + + taug(iplon,lay,ngs3+8)=taug(iplon,lay,ngs3+8)*0.92 + taug(iplon,lay,ngs3+9)=taug(iplon,lay,ngs3+9)*0.88 + taug(iplon,lay,ngs3+10)=taug(iplon,lay,ngs3+10)*1.07 + taug(iplon,lay,ngs3+11)=taug(iplon,lay,ngs3+11)*1.1 + taug(iplon,lay,ngs3+12)=taug(iplon,lay,ngs3+12)*0.99 + taug(iplon,lay,ngs3+13)=taug(iplon,lay,ngs3+13)*0.88 + taug(iplon,lay,ngs3+14)=taug(iplon,lay,ngs3+14)*0.943 + + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb4g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb5g( ncol, nlayers , taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) +! (high key - o3,co2) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng5, ngs4 + use parrrtm_f, only : ngs4 + use rrlw_ref_f, only : chi_mlsd + use rrlw_kg05_f + +! ------- Declarations ------- +#include "taug_cpu_defs.h" + +! Local + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) + + integer :: lay, ind0, ind1, inds, indf, indm, ig + integer :: js, js1, jmo3, jpl + real :: speccomb, specparm, specmult, fs + real :: speccomb1, specparm1, specmult1, fs1 + real :: speccomb_mo3, specparm_mo3, specmult_mo3, fmo3 + real :: speccomb_planck, specparm_planck, specmult_planck, fpl + real :: p, p4, fk0, fk1, fk2 + real :: fac000, fac100, fac200, fac010, fac110, fac210 + real :: fac001, fac101, fac201, fac011, fac111, fac211 + real :: tauself, taufor, o3m1, o3m2, abso3 + real :: refrat_planck_a, refrat_planck_b, refrat_m_a + real :: tau_major, tau_major1 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Minor gas mapping level : +! lower - o3, p = 317.34 mbar, t = 240.77 k +! lower - ccl4 + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + +! P = 473.420 mb + refrat_planck_a = chi_mlsd(1,5)/chi_mlsd(2,5) + +! P = 0.2369 mb + refrat_planck_b = chi_mlsd(3,43)/chi_mlsd(2,43) + +! P = 317.3480 + refrat_m_a = chi_mlsd(1,7)/chi_mlsd(2,7) + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature, and appropriate species. Below laytrop, the +! water vapor self-continuum and foreign continuum is +! interpolated (in temperature) separately. + +! Lower atmosphere loop + !do lay = 1, laytrop(iplon) + if (lay <= laytrop(iplon)) then + speccomb = colh2o(iplon,lay) + rat_h2oco2(iplon,lay)*colco2(iplon,lay) + specparm = colh2o(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = colh2o(iplon,lay) + rat_h2oco2_1(iplon,lay)*colco2(iplon,lay) + specparm1 = colh2o(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 8. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + speccomb_mo3 = colh2o(iplon,lay) + refrat_m_a*colco2(iplon,lay) + specparm_mo3 = colh2o(iplon,lay)/speccomb_mo3 + if (specparm_mo3 .ge. oneminusd) specparm_mo3 = oneminusd + specmult_mo3 = 8. *specparm_mo3 + jmo3 = 1 + int(specmult_mo3) + fmo3 = mod(specmult_mo3,1.0 ) + + speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colco2(iplon,lay) + specparm_planck = colh2o(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 8. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(5) + js + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(5) + js1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + + if (specparm .lt. 0.125 ) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else if (specparm .gt. 0.875 ) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + endif + + if (specparm1 .lt. 0.125 ) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else if (specparm1 .gt. 0.875 ) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + endif + + do ig = 1, ng5 + tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + o3m1 = ka_mo3d(jmo3,indm,ig) + fmo3 * & + (ka_mo3d(jmo3+1,indm,ig)-ka_mo3d(jmo3,indm,ig)) + o3m2 = ka_mo3d(jmo3,indm+1,ig) + fmo3 * & + (ka_mo3d(jmo3+1,indm+1,ig)-ka_mo3d(jmo3,indm+1,ig)) + abso3 = o3m1 + minorfrac(iplon,lay)*(o3m2-o3m1) + + if (specparm .lt. 0.125 ) then + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac200 * absad(ind0+2,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig) + & + fac210 * absad(ind0+11,ig)) + else if (specparm .gt. 0.875 ) then + tau_major = speccomb * & + (fac200 * absad(ind0-1,ig) + & + fac100 * absad(ind0,ig) + & + fac000 * absad(ind0+1,ig) + & + fac210 * absad(ind0+8,ig) + & + fac110 * absad(ind0+9,ig) + & + fac010 * absad(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125 ) then + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac201 * absad(ind1+2,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig) + & + fac211 * absad(ind1+11,ig)) + else if (specparm1 .gt. 0.875 ) then + tau_major1 = speccomb1 * & + (fac201 * absad(ind1-1,ig) + & + fac101 * absad(ind1,ig) + & + fac001 * absad(ind1+1,ig) + & + fac211 * absad(ind1+8,ig) + & + fac111 * absad(ind1+9,ig) + & + fac011 * absad(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig)) + endif + + taug(iplon,lay,ngs4+ig) = tau_major + tau_major1 & + + tauself + taufor & + + abso3*colo3(iplon,lay) & + + wx1(iplon,lay) * coldry(iplon,lay) * 1.e-20 * ccl4d(ig) + fracsd(iplon,lay,ngs4+ig) = fracrefad(ig,jpl) + fpl * & + (fracrefad(ig,jpl+1)-fracrefad(ig,jpl)) + enddo + else + +! Upper atmosphere loop + !do lay = laytrop(iplon)+1, nlayers + + speccomb = colo3(iplon,lay) + rat_o3co2(iplon,lay)*colco2(iplon,lay) + specparm = colo3(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 4. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = colo3(iplon,lay) + rat_o3co2_1(iplon,lay)*colco2(iplon,lay) + specparm1 = colo3(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 4. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + + speccomb_planck = colo3(iplon,lay)+refrat_planck_b*colco2(iplon,lay) + specparm_planck = colo3(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 4. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(5) + js + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(5) + js1 + + do ig = 1, ng5 + taug(iplon,lay,ngs4+ig) = speccomb * & + (fac000 * absbd(ind0,ig) + & + fac100 * absbd(ind0+1,ig) + & + fac010 * absbd(ind0+5,ig) + & + fac110 * absbd(ind0+6,ig)) & + + speccomb1 * & + (fac001 * absbd(ind1,ig) + & + fac101 * absbd(ind1+1,ig) + & + fac011 * absbd(ind1+5,ig) + & + fac111 * absbd(ind1+6,ig)) & + + wx1(iplon, lay) * coldry(iplon,lay) * 1.e-20 * ccl4d(ig) + fracsd(iplon,lay,ngs4+ig) = fracrefbd(ig,jpl) + fpl * & + (fracrefbd(ig,jpl+1)-fracrefbd(ig,jpl)) + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb5g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb6g( ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) +! (high key - nothing; high minor - cfc11, cfc12) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng6, ngs5 + use parrrtm_f, only : ngs5 + use rrlw_ref_f, only : chi_mlsd + use rrlw_kg06_f + +! ------- Declarations ------- +#include "taug_cpu_defs.h" + +! Local + integer :: lay, ind0, ind1, inds, indf, indm, ig + real :: chi_co2, ratco2, adjfac, adjcolco2 + real :: tauself, taufor, absco2 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Minor gas mapping level: +! lower - co2, p = 706.2720 mb, t = 294.2 k +! upper - cfc11, cfc12 + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. The water vapor self-continuum and foreign continuum +! is interpolated (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(iplon,lay)/(coldry(iplon,lay)) + ratco2 = 1.e20 *chi_co2/chi_mlsd(2,jp(iplon,lay)+1) + if (ratco2 .gt. 3.0 ) then + adjfac = 2.0 +(ratco2-2.0 )**0.77 + adjcolco2 = adjfac*chi_mlsd(2,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20 + else + adjcolco2 = colco2(iplon,lay) + endif + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(6) + 1 + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(6) + 1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + + do ig = 1, ng6 + tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + absco2 = (ka_mco2d(indm,ig) + minorfrac(iplon,lay) * & + (ka_mco2d(indm+1,ig) - ka_mco2d(indm,ig))) + taug(iplon,lay,ngs5+ig) = colh2o(iplon,lay) * & + (fac00(iplon,lay) * absad(ind0,ig) + & + fac10(iplon,lay) * absad(ind0+1,ig) + & + fac01(iplon,lay) * absad(ind1,ig) + & + fac11(iplon,lay) * absad(ind1+1,ig)) & + + tauself + taufor & + + adjcolco2 * absco2 & + + wx2(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc11adjd(ig) & + + wx3(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc12d(ig) + fracsd(iplon,lay,ngs5+ig) = fracrefad(ig) + enddo + else + + do ig = 1, ng6 + taug(iplon,lay,ngs5+ig) = 0.0 & + + wx2(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc11adjd(ig) & + + wx3(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc12d(ig) + fracsd(iplon,lay,ngs5+ig) = fracrefad(ig) + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb6g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb7g( ncol, nlayers , taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) +! (high key - o3; high minor - co2) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng7, ngs6 + use parrrtm_f, only : ngs6 + use rrlw_ref_f, only : chi_mlsd + use rrlw_kg07_f + +! ------- Declarations ------- +#include "taug_cpu_defs.h" + +! Local + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) + + integer :: lay, ind0, ind1, inds, indf, indm, ig + integer :: js, js1, jmco2, jpl + real :: speccomb, specparm, specmult, fs + real :: speccomb1, specparm1, specmult1, fs1 + real :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2 + real :: speccomb_planck, specparm_planck, specmult_planck, fpl + real :: p, p4, fk0, fk1, fk2 + real :: fac000, fac100, fac200, fac010, fac110, fac210 + real :: fac001, fac101, fac201, fac011, fac111, fac211 + real :: tauself, taufor, co2m1, co2m2, absco2 + real :: chi_co2, ratco2, adjfac, adjcolco2 + real :: refrat_planck_a, refrat_m_a + real :: tau_major, tau_major1 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Minor gas mapping level : +! lower - co2, p = 706.2620 mbar, t= 278.94 k +! upper - co2, p = 12.9350 mbar, t = 234.01 k + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. + +! P = 706.2620 mb + refrat_planck_a = chi_mlsd(1,3)/chi_mlsd(3,3) + +! P = 706.2720 mb + refrat_m_a = chi_mlsd(1,3)/chi_mlsd(3,3) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + + speccomb = colh2o(iplon,lay) + rat_h2oo3(iplon,lay)*colo3(iplon,lay) + specparm = colh2o(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = colh2o(iplon,lay) + rat_h2oo3_1(iplon,lay)*colo3(iplon,lay) + specparm1 = colh2o(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 8. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + speccomb_mco2 = colh2o(iplon,lay) + refrat_m_a*colo3(iplon,lay) + specparm_mco2 = colh2o(iplon,lay)/speccomb_mco2 + if (specparm_mco2 .ge. oneminusd) specparm_mco2 = oneminusd + specmult_mco2 = 8. *specparm_mco2 + + jmco2 = 1 + int(specmult_mco2) + fmco2 = mod(specmult_mco2,1.0 ) + +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(iplon,lay)/(coldry(iplon,lay)) + ratco2 = 1.e20*chi_co2/chi_mlsd(2,jp(iplon,lay)+1) + if (ratco2 .gt. 3.0 ) then + adjfac = 3.0 +(ratco2-3.0 )**0.79 + adjcolco2 = adjfac*chi_mlsd(2,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20 + else + adjcolco2 = colco2(iplon,lay) + endif + + speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colo3(iplon,lay) + specparm_planck = colh2o(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 8. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(7) + js + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(7) + js1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + + if (specparm .lt. 0.125 ) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else if (specparm .gt. 0.875 ) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + endif + if (specparm1 .lt. 0.125 ) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else if (specparm1 .gt. 0.875 ) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + endif + + do ig = 1, ng7 + tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + co2m1 = ka_mco2d(jmco2,indm,ig) + fmco2 * & + (ka_mco2d(jmco2+1,indm,ig) - ka_mco2d(jmco2,indm,ig)) + co2m2 = ka_mco2d(jmco2,indm+1,ig) + fmco2 * & + (ka_mco2d(jmco2+1,indm+1,ig) - ka_mco2d(jmco2,indm+1,ig)) + absco2 = co2m1 + minorfrac(iplon,lay) * (co2m2 - co2m1) + + if (specparm .lt. 0.125 ) then + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac200 * absad(ind0+2,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig) + & + fac210 * absad(ind0+11,ig)) + else if (specparm .gt. 0.875 ) then + tau_major = speccomb * & + (fac200 * absad(ind0-1,ig) + & + fac100 * absad(ind0,ig) + & + fac000 * absad(ind0+1,ig) + & + fac210 * absad(ind0+8,ig) + & + fac110 * absad(ind0+9,ig) + & + fac010 * absad(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125 ) then + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac201 * absad(ind1+2,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig) + & + fac211 * absad(ind1+11,ig)) + else if (specparm1 .gt. 0.875 ) then + tau_major1 = speccomb1 * & + (fac201 * absad(ind1-1,ig) + & + fac101 * absad(ind1,ig) + & + fac001 * absad(ind1+1,ig) + & + fac211 * absad(ind1+8,ig) + & + fac111 * absad(ind1+9,ig) + & + fac011 * absad(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig)) + endif + + taug(iplon,lay,ngs6+ig) = tau_major + tau_major1 & + + tauself + taufor & + + adjcolco2*absco2 + fracsd(iplon,lay,ngs6+ig) = fracrefad(ig,jpl) + fpl * & + (fracrefad(ig,jpl+1)-fracrefad(ig,jpl)) + enddo + else +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(iplon,lay)/(coldry(iplon,lay)) + ratco2 = 1.e20*chi_co2/chi_mlsd(2,jp(iplon,lay)+1) + if (ratco2 .gt. 3.0 ) then + adjfac = 2.0 +(ratco2-2.0 )**0.79 + adjcolco2 = adjfac*chi_mlsd(2,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20 + else + adjcolco2 = colco2(iplon,lay) + endif + + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(7) + 1 + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(7) + 1 + indm = indminor(iplon,lay) + + do ig = 1, ng7 + absco2 = kb_mco2d(indm,ig) + minorfrac(iplon,lay) * & + (kb_mco2d(indm+1,ig) - kb_mco2d(indm,ig)) + taug(iplon,lay,ngs6+ig) = colo3(iplon,lay) * & + (fac00(iplon,lay) * absbd(ind0,ig) + & + fac10(iplon,lay) * absbd(ind0+1,ig) + & + fac01(iplon,lay) * absbd(ind1,ig) + & + fac11(iplon,lay) * absbd(ind1+1,ig)) & + + adjcolco2 * absco2 + fracsd(iplon,lay,ngs6+ig) = fracrefbd(ig) + enddo + +! Empirical modification to code to improve stratospheric cooling rates +! for o3. Revised to apply weighting for g-point reduction in this band. + + taug(iplon,lay,ngs6+6)=taug(iplon,lay,ngs6+6)*0.92 + taug(iplon,lay,ngs6+7)=taug(iplon,lay,ngs6+7)*0.88 + taug(iplon,lay,ngs6+8)=taug(iplon,lay,ngs6+8)*1.07 + taug(iplon,lay,ngs6+9)=taug(iplon,lay,ngs6+9)*1.1 + taug(iplon,lay,ngs6+10)=taug(iplon,lay,ngs6+10)*0.99 + taug(iplon,lay,ngs6+11)=taug(iplon,lay,ngs6+11)*0.855 + + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb7g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb8g( ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) +! (high key - o3; high minor - co2, n2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng8, ngs7 + use parrrtm_f, only : ngs7 + use rrlw_ref_f, only : chi_mlsd + use rrlw_kg08_f + +! ------- Declarations ------- +#include "taug_cpu_defs.h" + +! Local + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) + + integer :: lay, ind0, ind1, inds, indf, indm, ig + real :: tauself, taufor, absco2, abso3, absn2o + real :: chi_co2, ratco2, adjfac, adjcolco2 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Minor gas mapping level: +! lower - co2, p = 1053.63 mb, t = 294.2 k +! lower - o3, p = 317.348 mb, t = 240.77 k +! lower - n2o, p = 706.2720 mb, t= 278.94 k +! lower - cfc12,cfc11 +! upper - co2, p = 35.1632 mb, t = 223.28 k +! upper - n2o, p = 8.716e-2 mb, t = 226.03 k + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature, and appropriate species. Below laytrop, the water vapor +! self-continuum and foreign continuum is interpolated (in temperature) +! separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(iplon,lay)/(coldry(iplon,lay)) + ratco2 = 1.e20 *chi_co2/chi_mlsd(2,jp(iplon,lay)+1) + if (ratco2 .gt. 3.0 ) then + adjfac = 2.0 +(ratco2-2.0 )**0.65 + adjcolco2 = adjfac*chi_mlsd(2,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20 + else + adjcolco2 = colco2(iplon,lay) + endif + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(8) + 1 + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(8) + 1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + + do ig = 1, ng8 + tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + absco2 = (ka_mco2d(indm,ig) + minorfrac(iplon,lay) * & + (ka_mco2d(indm+1,ig) - ka_mco2d(indm,ig))) + abso3 = (ka_mo3d(indm,ig) + minorfrac(iplon,lay) * & + (ka_mo3d(indm+1,ig) - ka_mo3d(indm,ig))) + absn2o = (ka_mn2od(indm,ig) + minorfrac(iplon,lay) * & + (ka_mn2od(indm+1,ig) - ka_mn2od(indm,ig))) + taug(iplon,lay,ngs7+ig) = colh2o(iplon,lay) * & + (fac00(iplon,lay) * absad(ind0,ig) + & + fac10(iplon,lay) * absad(ind0+1,ig) + & + fac01(iplon,lay) * absad(ind1,ig) + & + fac11(iplon,lay) * absad(ind1+1,ig)) & + + tauself + taufor & + + adjcolco2*absco2 & + + colo3(iplon,lay) * abso3 & + + coln2o(iplon,lay) * absn2o & + + wx3(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc12d(ig) & + + wx4(iplon, lay) * coldry(iplon,lay) * 1.e-20 * cfc22adjd(ig) + fracsd(iplon,lay,ngs7+ig) = fracrefad(ig) + enddo + else +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(iplon,lay)/coldry(iplon,lay) + ratco2 = 1.e20 *chi_co2/chi_mlsd(2,jp(iplon,lay)+1) + if (ratco2 .gt. 3.0 ) then + adjfac = 2.0 +(ratco2-2.0 )**0.65 + adjcolco2 = adjfac*chi_mlsd(2,jp(iplon,lay)+1) * coldry(iplon,lay)*1.e-20 + else + adjcolco2 = colco2(iplon,lay) + endif + + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(8) + 1 + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(8) + 1 + indm = indminor(iplon,lay) + + do ig = 1, ng8 + absco2 = (kb_mco2d(indm,ig) + minorfrac(iplon,lay) * & + (kb_mco2d(indm+1,ig) - kb_mco2d(indm,ig))) + absn2o = (kb_mn2od(indm,ig) + minorfrac(iplon,lay) * & + (kb_mn2od(indm+1,ig) - kb_mn2od(indm,ig))) + taug(iplon,lay,ngs7+ig) = colo3(iplon,lay) * & + (fac00(iplon,lay) * absbd(ind0,ig) + & + fac10(iplon,lay) * absbd(ind0+1,ig) + & + fac01(iplon,lay) * absbd(ind1,ig) + & + fac11(iplon,lay) * absbd(ind1+1,ig)) & + + adjcolco2*absco2 & + + coln2o(iplon,lay)*absn2o & + + wx3(iplon,lay) * coldry(iplon,lay) * 1.e-20 * cfc12d(ig) & + + wx4(iplon,lay) * coldry(iplon,lay) * 1.e-20 * cfc22adjd(ig) + fracsd(iplon,lay,ngs7+ig) = fracrefbd(ig) + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb8g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb9g( ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) +! (high key - ch4; high minor - n2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng9, ngs8 + use parrrtm_f, only : ngs8 + use rrlw_ref_f, only : chi_mlsd + use rrlw_kg09_f + +! ------- Declarations ------- + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) +#include "taug_cpu_defs.h" + +! Local + integer :: lay, ind0, ind1, inds, indf, indm, ig + integer :: js, js1, jmn2o, jpl + real :: speccomb, specparm, specmult, fs + real :: speccomb1, specparm1, specmult1, fs1 + real :: speccomb_mn2o, specparm_mn2o, specmult_mn2o, fmn2o + real :: speccomb_planck, specparm_planck, specmult_planck, fpl + real :: p, p4, fk0, fk1, fk2 + real :: fac000, fac100, fac200, fac010, fac110, fac210 + real :: fac001, fac101, fac201, fac011, fac111, fac211 + real :: tauself, taufor, n2om1, n2om2, absn2o + real :: chi_n2o, ratn2o, adjfac, adjcoln2o + real :: refrat_planck_a, refrat_m_a + real :: tau_major, tau_major1 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Minor gas mapping level : +! lower - n2o, p = 706.272 mbar, t = 278.94 k +! upper - n2o, p = 95.58 mbar, t = 215.7 k + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + +! P = 212 mb + refrat_planck_a = chi_mlsd(1,9)/chi_mlsd(6,9) + +! P = 706.272 mb + refrat_m_a = chi_mlsd(1,3)/chi_mlsd(6,3) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + + speccomb = colh2o(iplon,lay) + rat_h2och4(iplon,lay)*colch4(iplon,lay) + specparm = colh2o(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = colh2o(iplon,lay) + rat_h2och4_1(iplon,lay)*colch4(iplon,lay) + specparm1 = colh2o(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 8. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + speccomb_mn2o = colh2o(iplon,lay) + refrat_m_a*colch4(iplon,lay) + specparm_mn2o = colh2o(iplon,lay)/speccomb_mn2o + if (specparm_mn2o .ge. oneminusd) specparm_mn2o = oneminusd + specmult_mn2o = 8. *specparm_mn2o + jmn2o = 1 + int(specmult_mn2o) + fmn2o = mod(specmult_mn2o,1.0 ) + +! In atmospheres where the amount of N2O is too great to be considered +! a minor species, adjust the column amount of N2O by an empirical factor +! to obtain the proper contribution. + chi_n2o = coln2o(iplon,lay)/(coldry(iplon,lay)) + ratn2o = 1.e20 *chi_n2o/chi_mlsd(4,jp(iplon,lay)+1) + if (ratn2o .gt. 1.5 ) then + adjfac = 0.5 +(ratn2o-0.5 )**0.65 + adjcoln2o = adjfac*chi_mlsd(4,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20 + else + adjcoln2o = coln2o(iplon,lay) + endif + + speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colch4(iplon,lay) + specparm_planck = colh2o(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 8. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(9) + js + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(9) + js1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + + if (specparm .lt. 0.125 ) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else if (specparm .gt. 0.875 ) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + endif + + if (specparm1 .lt. 0.125 ) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else if (specparm1 .gt. 0.875 ) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + endif + + do ig = 1, ng9 + tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + n2om1 = ka_mn2od(jmn2o,indm,ig) + fmn2o * & + (ka_mn2od(jmn2o+1,indm,ig) - ka_mn2od(jmn2o,indm,ig)) + n2om2 = ka_mn2od(jmn2o,indm+1,ig) + fmn2o * & + (ka_mn2od(jmn2o+1,indm+1,ig) - ka_mn2od(jmn2o,indm+1,ig)) + absn2o = n2om1 + minorfrac(iplon,lay) * (n2om2 - n2om1) + + if (specparm .lt. 0.125 ) then + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac200 * absad(ind0+2,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig) + & + fac210 * absad(ind0+11,ig)) + else if (specparm .gt. 0.875 ) then + tau_major = speccomb * & + (fac200 * absad(ind0-1,ig) + & + fac100 * absad(ind0,ig) + & + fac000 * absad(ind0+1,ig) + & + fac210 * absad(ind0+8,ig) + & + fac110 * absad(ind0+9,ig) + & + fac010 * absad(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125 ) then + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac201 * absad(ind1+2,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig) + & + fac211 * absad(ind1+11,ig)) + else if (specparm1 .gt. 0.875 ) then + tau_major1 = speccomb1 * & + (fac201 * absad(ind1-1,ig) + & + fac101 * absad(ind1,ig) + & + fac001 * absad(ind1+1,ig) + & + fac211 * absad(ind1+8,ig) + & + fac111 * absad(ind1+9,ig) + & + fac011 * absad(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig)) + endif + + taug(iplon,lay,ngs8+ig) = tau_major + tau_major1 & + + tauself + taufor & + + adjcoln2o*absn2o + fracsd(iplon,lay,ngs8+ig) = fracrefad(ig,jpl) + fpl * & + (fracrefad(ig,jpl+1)-fracrefad(ig,jpl)) + enddo + else +! In atmospheres where the amount of N2O is too great to be considered +! a minor species, adjust the column amount of N2O by an empirical factor +! to obtain the proper contribution. + chi_n2o = coln2o(iplon,lay)/(coldry(iplon,lay)) + ratn2o = 1.e20 *chi_n2o/chi_mlsd(4,jp(iplon,lay)+1) + if (ratn2o .gt. 1.5 ) then + adjfac = 0.5 +(ratn2o-0.5 )**0.65 + adjcoln2o = adjfac*chi_mlsd(4,jp(iplon,lay)+1)*coldry(iplon,lay)*1.e-20 + else + adjcoln2o = coln2o(iplon,lay) + endif + + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(9) + 1 + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(9) + 1 + indm = indminor(iplon,lay) + + do ig = 1, ng9 + absn2o = kb_mn2od(indm,ig) + minorfrac(iplon,lay) * & + (kb_mn2od(indm+1,ig) - kb_mn2od(indm,ig)) + taug(iplon,lay,ngs8+ig) = colch4(iplon,lay) * & + (fac00(iplon,lay) * absbd(ind0,ig) + & + fac10(iplon,lay) * absbd(ind0+1,ig) + & + fac01(iplon,lay) * absbd(ind1,ig) + & + fac11(iplon,lay) * absbd(ind1+1,ig)) & + + adjcoln2o*absn2o + fracsd(iplon,lay,ngs8+ig) = fracrefbd(ig) + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb9g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb10g( ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng10, ngs9 + use parrrtm_f, only : ngs9 + use rrlw_kg10_f + +! ------- Declarations ------- + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) +#include "taug_cpu_defs.h" + +! Local + integer :: lay, ind0, ind1, inds, indf, ig + real :: tauself, taufor + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below laytrop, the water vapor self-continuum and +! foreign continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(10) + 1 + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(10) + 1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + + do ig = 1, ng10 + tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + taug(iplon,lay,ngs9+ig) = colh2o(iplon,lay) * & + (fac00(iplon,lay) * absad(ind0,ig) + & + fac10(iplon,lay) * absad(ind0+1,ig) + & + fac01(iplon,lay) * absad(ind1,ig) + & + fac11(iplon,lay) * absad(ind1+1,ig)) & + + tauself + taufor + fracsd(iplon,lay,ngs9+ig) = fracrefad(ig) + enddo + else + + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(10) + 1 + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(10) + 1 + indf = indfor(iplon,lay) + + do ig = 1, ng10 + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + taug(iplon,lay,ngs9+ig) = colh2o(iplon,lay) * & + (fac00(iplon,lay) * absbd(ind0,ig) + & + fac10(iplon,lay) * absbd(ind0+1,ig) + & + fac01(iplon,lay) * absbd(ind1,ig) + & + fac11(iplon,lay) * absbd(ind1+1,ig)) & + + taufor + fracsd(iplon,lay,ngs9+ig) = fracrefbd(ig) + enddo + end if + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + end subroutine taugb10g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb11g( ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) +! (high key - h2o; high minor - o2) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng11, ngs10 + use parrrtm_f, only : ngs10 + use rrlw_kg11_f + +! ------- Declarations ------- + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) +#include "taug_cpu_defs.h" + +! Local + integer :: lay, ind0, ind1, inds, indf, indm, ig + real :: scaleo2, tauself, taufor, tauo2 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Minor gas mapping level : +! lower - o2, p = 706.2720 mbar, t = 278.94 k +! upper - o2, p = 4.758820 mbarm t = 250.85 k + +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below laytrop, the water vapor self-continuum and +! foreign continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(11) + 1 + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(11) + 1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + scaleo2 = colo2(iplon,lay)*scaleminor(iplon,lay) + do ig = 1, ng11 + tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + tauo2 = scaleo2 * (ka_mo2d(indm,ig) + minorfrac(iplon,lay) * & + (ka_mo2d(indm+1,ig) - ka_mo2d(indm,ig))) + taug(iplon,lay,ngs10+ig) = colh2o(iplon,lay) * & + (fac00(iplon,lay) * absad(ind0,ig) + & + fac10(iplon,lay) * absad(ind0+1,ig) + & + fac01(iplon,lay) * absad(ind1,ig) + & + fac11(iplon,lay) * absad(ind1+1,ig)) & + + tauself + taufor & + + tauo2 + fracsd(iplon,lay,ngs10+ig) = fracrefad(ig) + enddo + else + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(11) + 1 + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(11) + 1 + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + scaleo2 = colo2(iplon,lay)*scaleminor(iplon,lay) + do ig = 1, ng11 + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + tauo2 = scaleo2 * (kb_mo2d(indm,ig) + minorfrac(iplon,lay) * & + (kb_mo2d(indm+1,ig) - kb_mo2d(indm,ig))) + taug(iplon,lay,ngs10+ig) = colh2o(iplon,lay) * & + (fac00(iplon,lay) * absbd(ind0,ig) + & + fac10(iplon,lay) * absbd(ind0+1,ig) + & + fac01(iplon,lay) * absbd(ind1,ig) + & + fac11(iplon,lay) * absbd(ind1+1,ig)) & + + taufor & + + tauo2 + fracsd(iplon,lay,ngs10+ig) = fracrefbd(ig) + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb11g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb12g( ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng12, ngs11 + use parrrtm_f, only : ngs11 + use rrlw_ref_f, only : chi_mlsd + use rrlw_kg12_f + +! ------- Declarations ------- + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) +#include "taug_cpu_defs.h" + +! Local + integer :: lay, ind0, ind1, inds, indf, ig + integer :: js, js1, jpl + real :: speccomb, specparm, specmult, fs + real :: speccomb1, specparm1, specmult1, fs1 + real :: speccomb_planck, specparm_planck, specmult_planck, fpl + real :: p, p4, fk0, fk1, fk2 + real :: fac000, fac100, fac200, fac010, fac110, fac210 + real :: fac001, fac101, fac201, fac011, fac111, fac211 + real :: tauself, taufor + real :: refrat_planck_a + real :: tau_major, tau_major1 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + +! P = 174.164 mb + refrat_planck_a = chi_mlsd(1,10)/chi_mlsd(2,10) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum adn foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + + speccomb = colh2o(iplon,lay) + rat_h2oco2(iplon,lay)*colco2(iplon,lay) + specparm = colh2o(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = colh2o(iplon,lay) + rat_h2oco2_1(iplon,lay)*colco2(iplon,lay) + specparm1 = colh2o(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 8. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colco2(iplon,lay) + specparm_planck = colh2o(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 8. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(12) + js + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(12) + js1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + + if (specparm .lt. 0.125 ) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else if (specparm .gt. 0.875 ) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + endif + + if (specparm1 .lt. 0.125 ) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else if (specparm1 .gt. 0.875 ) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + endif + + do ig = 1, ng12 + tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + + if (specparm .lt. 0.125 ) then + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac200 * absad(ind0+2,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig) + & + fac210 * absad(ind0+11,ig)) + else if (specparm .gt. 0.875 ) then + tau_major = speccomb * & + (fac200 * absad(ind0-1,ig) + & + fac100 * absad(ind0,ig) + & + fac000 * absad(ind0+1,ig) + & + fac210 * absad(ind0+8,ig) + & + fac110 * absad(ind0+9,ig) + & + fac010 * absad(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125 ) then + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac201 * absad(ind1+2,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig) + & + fac211 * absad(ind1+11,ig)) + else if (specparm1 .gt. 0.875 ) then + tau_major1 = speccomb1 * & + (fac201 * absad(ind1-1,ig) + & + fac101 * absad(ind1,ig) + & + fac001 * absad(ind1+1,ig) + & + fac211 * absad(ind1+8,ig) + & + fac111 * absad(ind1+9,ig) + & + fac011 * absad(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig)) + endif + + taug(iplon,lay,ngs11+ig) = tau_major + tau_major1 & + + tauself + taufor + fracsd(iplon,lay,ngs11+ig) = fracrefad(ig,jpl) + fpl * & + (fracrefad(ig,jpl+1)-fracrefad(ig,jpl)) + enddo + + else + do ig = 1, ng12 + taug(iplon,lay,ngs11+ig) = 0.0 + fracsd(iplon,lay,ngs11+ig) = 0.0 + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb12g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb13g( ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng13, ngs12 + use parrrtm_f, only : ngs12 + use rrlw_ref_f, only : chi_mlsd + use rrlw_kg13_f +! ------- Declarations ------- + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) +#include "taug_cpu_defs.h" + +! Local + integer :: lay, ind0, ind1, inds, indf, indm, ig + integer :: js, js1, jmco2, jmco, jpl + real :: speccomb, specparm, specmult, fs + real :: speccomb1, specparm1, specmult1, fs1 + real :: speccomb_mco2, specparm_mco2, specmult_mco2, fmco2 + real :: speccomb_mco, specparm_mco, specmult_mco, fmco + real :: speccomb_planck, specparm_planck, specmult_planck, fpl + real :: p, p4, fk0, fk1, fk2 + real :: fac000, fac100, fac200, fac010, fac110, fac210 + real :: fac001, fac101, fac201, fac011, fac111, fac211 + real :: tauself, taufor, co2m1, co2m2, absco2 + real :: com1, com2, absco, abso3 + real :: chi_co2, ratco2, adjfac, adjcolco2 + real :: refrat_planck_a, refrat_m_a, refrat_m_a3 + real :: tau_major, tau_major1 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Minor gas mapping levels : +! lower - co2, p = 1053.63 mb, t = 294.2 k +! lower - co, p = 706 mb, t = 278.94 k +! upper - o3, p = 95.5835 mb, t = 215.7 k + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower/upper atmosphere. + +! P = 473.420 mb (Level 5) + refrat_planck_a = chi_mlsd(1,5)/chi_mlsd(4,5) + +! P = 1053. (Level 1) + refrat_m_a = chi_mlsd(1,1)/chi_mlsd(4,1) + +! P = 706. (Level 3) + refrat_m_a3 = chi_mlsd(1,3)/chi_mlsd(4,3) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + + speccomb = colh2o(iplon,lay) + rat_h2on2o(iplon,lay)*coln2o(iplon,lay) + specparm = colh2o(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = colh2o(iplon,lay) + rat_h2on2o_1(iplon,lay)*coln2o(iplon,lay) + specparm1 = colh2o(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 8. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + speccomb_mco2 = colh2o(iplon,lay) + refrat_m_a*coln2o(iplon,lay) + specparm_mco2 = colh2o(iplon,lay)/speccomb_mco2 + if (specparm_mco2 .ge. oneminusd) specparm_mco2 = oneminusd + specmult_mco2 = 8. *specparm_mco2 + jmco2 = 1 + int(specmult_mco2) + fmco2 = mod(specmult_mco2,1.0 ) + +! In atmospheres where the amount of CO2 is too great to be considered +! a minor species, adjust the column amount of CO2 by an empirical factor +! to obtain the proper contribution. + chi_co2 = colco2(iplon,lay)/(coldry(iplon,lay)) + ratco2 = 1.e20 *chi_co2/3.55e-4 + if (ratco2 .gt. 3.0 ) then + adjfac = 2.0 +(ratco2-2.0 )**0.68 + adjcolco2 = adjfac*3.55e-4*coldry(iplon,lay)*1.e-20 + else + adjcolco2 = colco2(iplon,lay) + endif + + speccomb_mco = colh2o(iplon,lay) + refrat_m_a3*coln2o(iplon,lay) + specparm_mco = colh2o(iplon,lay)/speccomb_mco + if (specparm_mco .ge. oneminusd) specparm_mco = oneminusd + specmult_mco = 8. *specparm_mco + jmco = 1 + int(specmult_mco) + fmco = mod(specmult_mco,1.0 ) + + speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*coln2o(iplon,lay) + specparm_planck = colh2o(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 8. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(13) + js + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(13) + js1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + + if (specparm .lt. 0.125 ) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else if (specparm .gt. 0.875 ) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + endif + + if (specparm1 .lt. 0.125 ) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else if (specparm1 .gt. 0.875 ) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + endif + + do ig = 1, ng13 + tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + co2m1 = ka_mco2d(jmco2,indm,ig) + fmco2 * & + (ka_mco2d(jmco2+1,indm,ig) - ka_mco2d(jmco2,indm,ig)) + co2m2 = ka_mco2d(jmco2,indm+1,ig) + fmco2 * & + (ka_mco2d(jmco2+1,indm+1,ig) - ka_mco2d(jmco2,indm+1,ig)) + absco2 = co2m1 + minorfrac(iplon,lay) * (co2m2 - co2m1) + com1 = ka_mcod(jmco,indm,ig) + fmco * & + (ka_mcod(jmco+1,indm,ig) - ka_mcod(jmco,indm,ig)) + com2 = ka_mcod(jmco,indm+1,ig) + fmco * & + (ka_mcod(jmco+1,indm+1,ig) - ka_mcod(jmco,indm+1,ig)) + absco = com1 + minorfrac(iplon,lay) * (com2 - com1) + + if (specparm .lt. 0.125 ) then + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac200 * absad(ind0+2,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig) + & + fac210 * absad(ind0+11,ig)) + else if (specparm .gt. 0.875 ) then + tau_major = speccomb * & + (fac200 * absad(ind0-1,ig) + & + fac100 * absad(ind0,ig) + & + fac000 * absad(ind0+1,ig) + & + fac210 * absad(ind0+8,ig) + & + fac110 * absad(ind0+9,ig) + & + fac010 * absad(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125 ) then + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac201 * absad(ind1+2,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig) + & + fac211 * absad(ind1+11,ig)) + else if (specparm1 .gt. 0.875 ) then + tau_major1 = speccomb1 * & + (fac201 * absad(ind1-1,ig) + & + fac101 * absad(ind1,ig) + & + fac001 * absad(ind1+1,ig) + & + fac211 * absad(ind1+8,ig) + & + fac111 * absad(ind1+9,ig) + & + fac011 * absad(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig)) + endif + + taug(iplon,lay,ngs12+ig) = tau_major + tau_major1 & + + tauself + taufor & + + adjcolco2*absco2 & + + colco(iplon,lay)*absco + fracsd(iplon,lay,ngs12+ig) = fracrefad(ig,jpl) + fpl * & + (fracrefad(ig,jpl+1)-fracrefad(ig,jpl)) + enddo + else + indm = indminor(iplon,lay) + do ig = 1, ng13 + abso3 = kb_mo3d(indm,ig) + minorfrac(iplon,lay) * & + (kb_mo3d(indm+1,ig) - kb_mo3d(indm,ig)) + taug(iplon,lay,ngs12+ig) = colo3(iplon,lay)*abso3 + fracsd(iplon,lay,ngs12+ig) = fracrefbd(ig) + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb13g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb14g( ncol, nlayers , taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 14: 2250-2380 cm-1 (low - co2; high - co2) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng14, ngs13 + use parrrtm_f, only : ngs13 + use rrlw_kg14_f + +! ------- Declarations ------- + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) +#include "taug_cpu_defs.h" + +! Local + integer :: lay, ind0, ind1, inds, indf, ig + real :: tauself, taufor + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Compute the optical depth by interpolating in ln(pressure) and +! temperature. Below laytrop, the water vapor self-continuum +! and foreign continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(14) + 1 + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(14) + 1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + do ig = 1, ng14 + tauself = selffac(iplon,lay) * (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + taug(iplon,lay,ngs13+ig) = colco2(iplon,lay) * & + (fac00(iplon,lay) * absad(ind0,ig) + & + fac10(iplon,lay) * absad(ind0+1,ig) + & + fac01(iplon,lay) * absad(ind1,ig) + & + fac11(iplon,lay) * absad(ind1+1,ig)) & + + tauself + taufor + fracsd(iplon,lay,ngs13+ig) = fracrefad(ig) + enddo + else + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(14) + 1 + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(14) + 1 + do ig = 1, ng14 + taug(iplon,lay,ngs13+ig) = colco2(iplon,lay) * & + (fac00(iplon,lay) * absbd(ind0,ig) + & + fac10(iplon,lay) * absbd(ind0+1,ig) + & + fac01(iplon,lay) * absbd(ind1,ig) + & + fac11(iplon,lay) * absbd(ind1+1,ig)) + fracsd(iplon,lay,ngs13+ig) = fracrefbd(ig) + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb14g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb15g( ncol, nlayers , taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) +! (high - nothing) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng15, ngs14 + use parrrtm_f, only : ngs14 + use rrlw_ref_f, only : chi_mlsd + use rrlw_kg15_f + +! ------- Declarations ------- + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) +#include "taug_cpu_defs.h" + +! Local + integer :: lay, ind0, ind1, inds, indf, indm, ig + integer :: js, js1, jmn2, jpl + real :: speccomb, specparm, specmult, fs + real :: speccomb1, specparm1, specmult1, fs1 + real :: speccomb_mn2, specparm_mn2, specmult_mn2, fmn2 + real :: speccomb_planck, specparm_planck, specmult_planck, fpl + real :: p, p4, fk0, fk1, fk2 + real :: fac000, fac100, fac200, fac010, fac110, fac210 + real :: fac001, fac101, fac201, fac011, fac111, fac211 + real :: scalen2, tauself, taufor, n2m1, n2m2, taun2 + real :: refrat_planck_a, refrat_m_a + real :: tau_major, tau_major1 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Minor gas mapping level : +! Lower - Nitrogen Continuum, P = 1053., T = 294. + +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. +! P = 1053. mb (Level 1) + refrat_planck_a = chi_mlsd(4,1)/chi_mlsd(2,1) + +! P = 1053. + refrat_m_a = chi_mlsd(4,1)/chi_mlsd(2,1) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + + speccomb = coln2o(iplon,lay) + rat_n2oco2(iplon,lay)*colco2(iplon,lay) + specparm = coln2o(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = coln2o(iplon,lay) + rat_n2oco2_1(iplon,lay)*colco2(iplon,lay) + specparm1 = coln2o(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 8. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + speccomb_mn2 = coln2o(iplon,lay) + refrat_m_a*colco2(iplon,lay) + specparm_mn2 = coln2o(iplon,lay)/speccomb_mn2 + if (specparm_mn2 .ge. oneminusd) specparm_mn2 = oneminusd + specmult_mn2 = 8. *specparm_mn2 + jmn2 = 1 + int(specmult_mn2) + fmn2 = mod(specmult_mn2,1.0 ) + + speccomb_planck = coln2o(iplon,lay)+refrat_planck_a*colco2(iplon,lay) + specparm_planck = coln2o(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 8. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(15) + js + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(15) + js1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + indm = indminor(iplon,lay) + + scalen2 = colbrd(iplon,lay)*scaleminor(iplon,lay) + + if (specparm .lt. 0.125 ) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else if (specparm .gt. 0.875 ) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + endif + if (specparm1 .lt. 0.125 ) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else if (specparm1 .gt. 0.875 ) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + endif + + do ig = 1, ng15 + tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + n2m1 = ka_mn2d(jmn2,indm,ig) + fmn2 * & + (ka_mn2d(jmn2+1,indm,ig) - ka_mn2d(jmn2,indm,ig)) + n2m2 = ka_mn2d(jmn2,indm+1,ig) + fmn2 * & + (ka_mn2d(jmn2+1,indm+1,ig) - ka_mn2d(jmn2,indm+1,ig)) + taun2 = scalen2 * (n2m1 + minorfrac(iplon,lay) * (n2m2 - n2m1)) + + if (specparm .lt. 0.125 ) then + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac200 * absad(ind0+2,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig) + & + fac210 * absad(ind0+11,ig)) + else if (specparm .gt. 0.875 ) then + tau_major = speccomb * & + (fac200 * absad(ind0-1,ig) + & + fac100 * absad(ind0,ig) + & + fac000 * absad(ind0+1,ig) + & + fac210 * absad(ind0+8,ig) + & + fac110 * absad(ind0+9,ig) + & + fac010 * absad(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125 ) then + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac201 * absad(ind1+2,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig) + & + fac211 * absad(ind1+11,ig)) + else if (specparm1 .gt. 0.875 ) then + tau_major1 = speccomb1 * & + (fac201 * absad(ind1-1,ig) + & + fac101 * absad(ind1,ig) + & + fac001 * absad(ind1+1,ig) + & + fac211 * absad(ind1+8,ig) + & + fac111 * absad(ind1+9,ig) + & + fac011 * absad(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig)) + endif + + taug(iplon,lay,ngs14+ig) = tau_major + tau_major1 & + + tauself + taufor & + + taun2 + fracsd(iplon,lay,ngs14+ig) = fracrefad(ig,jpl) + fpl * & + (fracrefad(ig,jpl+1)-fracrefad(ig,jpl)) + enddo + + else + do ig = 1, ng15 + taug(iplon,lay,ngs14+ig) = 0.0 + fracsd(iplon,lay,ngs14+ig) = 0.0 + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb15g + +!---------------------------------------------------------------------------- + _gpuker subroutine taugb16g( ncol, nlayers , taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- +! +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +!---------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parrrtm_f, only : ng16, ngs15 + use parrrtm_f, only : ngs15 + use rrlw_ref_f, only : chi_mlsd + use rrlw_kg16_f + +! ------- Declarations ------- + real _gpudev :: taug(:,:,:) + real _gpudev :: fracsd(:,:,:) +#include "taug_cpu_defs.h" + +! Local + integer :: lay, ind0, ind1, inds, indf, ig + integer :: js, js1, jpl + real :: speccomb, specparm, specmult, fs + real :: speccomb1, specparm1, specmult1, fs1 + real :: speccomb_planck, specparm_planck, specmult_planck, fpl + real :: p, p4, fk0, fk1, fk2 + real :: fac000, fac100, fac200, fac010, fac110, fac210 + real :: fac001, fac101, fac201, fac011, fac111, fac211 + real :: tauself, taufor + real :: refrat_planck_a + real :: tau_major, tau_major1 + integer , value, intent(in) :: ncol, nlayers + integer :: iplon + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + if (iplon <= ncol .and. lay <= nlayers) then +#else + do iplon = 1, ncol + do lay = 1, nlayers +#endif +! Calculate reference ratio to be used in calculation of Planck +! fraction in lower atmosphere. + +! P = 387. mb (Level 6) + refrat_planck_a = chi_mlsd(1,6)/chi_mlsd(6,6) + +! Compute the optical depth by interpolating in ln(pressure), +! temperature,and appropriate species. Below laytrop, the water +! vapor self-continuum and foreign continuum is interpolated +! (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + speccomb = colh2o(iplon,lay) + rat_h2och4(iplon,lay)*colch4(iplon,lay) + specparm = colh2o(iplon,lay)/speccomb + if (specparm .ge. oneminusd) specparm = oneminusd + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult,1.0 ) + + speccomb1 = colh2o(iplon,lay) + rat_h2och4_1(iplon,lay)*colch4(iplon,lay) + specparm1 = colh2o(iplon,lay)/speccomb1 + if (specparm1 .ge. oneminusd) specparm1 = oneminusd + specmult1 = 8. *(specparm1) + js1 = 1 + int(specmult1) + fs1 = mod(specmult1,1.0 ) + + speccomb_planck = colh2o(iplon,lay)+refrat_planck_a*colch4(iplon,lay) + specparm_planck = colh2o(iplon,lay)/speccomb_planck + if (specparm_planck .ge. oneminusd) specparm_planck=oneminusd + specmult_planck = 8. *specparm_planck + jpl= 1 + int(specmult_planck) + fpl = mod(specmult_planck,1.0 ) + + ind0 = ((jp(iplon,lay)-1)*5+(jt(iplon,lay)-1))*nspad(16) + js + ind1 = (jp(iplon,lay)*5+(jt1(iplon,lay)-1))*nspad(16) + js1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + + if (specparm .lt. 0.125 ) then + p = fs - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else if (specparm .gt. 0.875 ) then + p = -fs + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac000 = fk0*fac00(iplon,lay) + fac100 = fk1*fac00(iplon,lay) + fac200 = fk2*fac00(iplon,lay) + fac010 = fk0*fac10(iplon,lay) + fac110 = fk1*fac10(iplon,lay) + fac210 = fk2*fac10(iplon,lay) + else + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + endif + + if (specparm1 .lt. 0.125 ) then + p = fs1 - 1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else if (specparm1 .gt. 0.875 ) then + p = -fs1 + p4 = p**4 + fk0 = p4 + fk1 = 1 - p - 2.0 *p4 + fk2 = p + p4 + fac001 = fk0*fac01(iplon,lay) + fac101 = fk1*fac01(iplon,lay) + fac201 = fk2*fac01(iplon,lay) + fac011 = fk0*fac11(iplon,lay) + fac111 = fk1*fac11(iplon,lay) + fac211 = fk2*fac11(iplon,lay) + else + fac001 = (1. - fs1) * fac01(iplon,lay) + fac011 = (1. - fs1) * fac11(iplon,lay) + fac101 = fs1 * fac01(iplon,lay) + fac111 = fs1 * fac11(iplon,lay) + endif + + do ig = 1, ng16 + tauself = selffac(iplon,lay)* (selfrefd(inds,ig) + selffrac(iplon,lay) * & + (selfrefd(inds+1,ig) - selfrefd(inds,ig))) + taufor = forfac(iplon,lay) * (forrefd(indf,ig) + forfrac(iplon,lay) * & + (forrefd(indf+1,ig) - forrefd(indf,ig))) + + if (specparm .lt. 0.125 ) then + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac200 * absad(ind0+2,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig) + & + fac210 * absad(ind0+11,ig)) + else if (specparm .gt. 0.875 ) then + tau_major = speccomb * & + (fac200 * absad(ind0-1,ig) + & + fac100 * absad(ind0,ig) + & + fac000 * absad(ind0+1,ig) + & + fac210 * absad(ind0+8,ig) + & + fac110 * absad(ind0+9,ig) + & + fac010 * absad(ind0+10,ig)) + else + tau_major = speccomb * & + (fac000 * absad(ind0,ig) + & + fac100 * absad(ind0+1,ig) + & + fac010 * absad(ind0+9,ig) + & + fac110 * absad(ind0+10,ig)) + endif + + if (specparm1 .lt. 0.125 ) then + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac201 * absad(ind1+2,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig) + & + fac211 * absad(ind1+11,ig)) + else if (specparm1 .gt. 0.875 ) then + tau_major1 = speccomb1 * & + (fac201 * absad(ind1-1,ig) + & + fac101 * absad(ind1,ig) + & + fac001 * absad(ind1+1,ig) + & + fac211 * absad(ind1+8,ig) + & + fac111 * absad(ind1+9,ig) + & + fac011 * absad(ind1+10,ig)) + else + tau_major1 = speccomb1 * & + (fac001 * absad(ind1,ig) + & + fac101 * absad(ind1+1,ig) + & + fac011 * absad(ind1+9,ig) + & + fac111 * absad(ind1+10,ig)) + endif + + taug(iplon,lay,ngs15+ig) = tau_major + tau_major1 & + + tauself + taufor + fracsd(iplon,lay,ngs15+ig) = fracrefad(ig,jpl) + fpl * & + (fracrefad(ig,jpl+1)-fracrefad(ig,jpl)) + enddo + else + ind0 = ((jp(iplon,lay)-13)*5+(jt(iplon,lay)-1))*nspbd(16) + 1 + ind1 = ((jp(iplon,lay)-12)*5+(jt1(iplon,lay)-1))*nspbd(16) + 1 + do ig = 1, ng16 + taug(iplon,lay,ngs15+ig) = colch4(iplon,lay) * & + (fac00(iplon,lay) * absbd(ind0,ig) + & + fac10(iplon,lay) * absbd(ind0+1,ig) + & + fac01(iplon,lay) * absbd(ind1,ig) + & + fac11(iplon,lay) * absbd(ind1+1,ig)) + fracsd(iplon,lay,ngs15+ig) = fracrefbd(ig) + enddo + endif + +#ifdef _ACCEL + endif +#else + end do + end do +#endif + + end subroutine taugb16g + + _gpuker subroutine addAerosols( ncol, nlayers, ngptlw, nbndlw, ngbd, taug & +#include "taug_cpu_args.h" + ) + + integer , intent(in), value :: ncol, nlayers, ngptlw, nbndlw + integer , intent(in) :: ngbd(:) + +#include "taug_cpu_defs.h" + + integer :: iplon, lay, ig + real _gpudev :: taug(:,:,:) + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + lay = (blockidx%y-1) * blockdim%y + threadidx%y + ig = (blockidx%z-1) * blockdim%z + threadidx%z + if (iplon<=ncol .and. lay<=nlayers .and. ig<=ngptlw) then +#else + do iplon = 1, ncol + do lay = 1, nlayers + do ig = 1, ngptlw +#endif + + taug(iplon, lay, ig) = taug(iplon, lay, ig) + tauaa(iplon, lay, ngbd(ig)) + +#ifdef _ACCEL + endif +#else + end do + end do + end do +#endif + + end subroutine + +!---------------------------------------------------------------------------- + subroutine taumolg(iplon, ncol, nlayers, ngbd, taug, fracsd & +#include "taug_cpu_args.h" + ) +!---------------------------------------------------------------------------- + +! ******************************************************************************* +! * * +! * Optical depths developed for the * +! * * +! * RAPID RADIATIVE TRANSFER MODEL (RRTM) * +! * * +! * * +! * ATMOSPHERIC AND ENVIRONMENTAL RESEARCH, INC. * +! * 131 HARTWELL AVENUE * +! * LEXINGTON, MA 02421 * +! * * +! * * +! * ELI J. MLAWER * +! * JENNIFER DELAMERE * +! * STEVEN J. TAUBMAN * +! * SHEPARD A. CLOUGH * +! * * +! * * +! * * +! * * +! * email: mlawer@aer.com * +! * email: jdelamer@aer.com * +! * * +! * The authors wish to acknowledge the contributions of the * +! * following people: Karen Cady-Pereira, Patrick D. Brown, * +! * Michael J. Iacono, Ronald E. Farren, Luke Chen, Robert Bergstrom. * +! * * +! ******************************************************************************* +! * * +! * Revision for g-point reduction: Michael J. Iacono, AER, Inc. * +! * * +! ******************************************************************************* +! * TAUMOL * +! * * +! * This file contains the subroutines TAUGBn (where n goes from * +! * 1 to 16). TAUGBn calculates the optical depths and Planck fractions * +! * per g-value and layer for band n. * +! * * +! * Output: optical depths (unitless) * +! * fractions needed to compute Planck functions at every layer * +! * and g-value * +! * * +! * COMMON /TAUGCOM/ TAUG(MXLAY,MG) * +! * COMMON /PLANKG/ fracsd(MXLAY,MG) * +! * * +! * Input * +! * * +! * COMMON /FEATURES/ NG(NBANDS),NSPA(NBANDS),NSPB(NBANDS) * +! * COMMON /PRECISE/ oneminusd * +! * COMMON /PROFILE/ NLAYERS,PAVEL(MXLAY),TAVEL(MXLAY), * +! * & PZ(0:MXLAY),TZ(0:MXLAY) * +! * COMMON /PROFDATA/ LAYTROP, * +! * & COLH2O(MXLAY),COLCO2(MXLAY),COLO3(MXLAY), * +! * & COLN2O(MXLAY),colco(MXLAY),COLCH4(MXLAY), * +! * & COLO2(MXLAY) +! * COMMON /INTFAC/ fac00(iplon,MXLAY),fac01(iplon,MXLAY), * +! * & FAC10(MXLAY),fac11(iplon,MXLAY) * +! * COMMON /INTIND/ JP(MXLAY),JT(MXLAY),JT1(MXLAY) * +! * COMMON /SELF/ SELFFAC(MXLAY), SELFFRAC(MXLAY), INDSELF(MXLAY) * +! * * +! * Description: * +! * NG(IBAND) - number of g-values in band IBAND * +! * NSPA(IBAND) - for the lower atmosphere, the number of reference * +! * atmospheres that are stored for band IBAND per * +! * pressure level and temperature. Each of these * +! * atmospheres has different relative amounts of the * +! * key species for the band (i.e. different binary * +! * species parameters). * +! * NSPB(IBAND) - same for upper atmosphere * +! * oneminusd - since problems are caused in some cases by interpolation * +! * parameters equal to or greater than 1, for these cases * +! * these parameters are set to this value, slightly < 1. * +! * PAVEL - layer pressures (mb) * +! * TAVEL - layer temperatures (degrees K) * +! * PZ - level pressures (mb) * +! * TZ - level temperatures (degrees K) * +! * LAYTROP - layer at which switch is made from one combination of * +! * key species to another * +! * COLH2O, COLCO2, COLO3, COLN2O, COLCH4 - column amounts of water * +! * vapor,carbon dioxide, ozone, nitrous ozide, methane, * +! * respectively (molecules/cm**2) * +! * FACij(LAY) - for layer LAY, these are factors that are needed to * +! * compute the interpolation factors that multiply the * +! * appropriate reference k-values. A value of 0 (1) for * +! * i,j indicates that the corresponding factor multiplies * +! * reference k-value for the lower (higher) of the two * +! * appropriate temperatures, and altitudes, respectively. * +! * JP - the index of the lower (in altitude) of the two appropriate * +! * reference pressure levels needed for interpolation * +! * JT, JT1 - the indices of the lower of the two appropriate reference * +! * temperatures needed for interpolation (for pressure * +! * levels JP and JP+1, respectively) * +! * SELFFAC - scale factor needed for water vapor self-continuum, equals * +! * (water vapor density)/(atmospheric density at 296K and * +! * 1013 mb) * +! * SELFFRAC - factor needed for temperature interpolation of reference * +! * water vapor self-continuum data * +! * INDSELF - index of the lower of the two appropriate reference * +! * temperatures needed for the self-continuum interpolation * +! * FORFAC - scale factor needed for water vapor foreign-continuum. * +! * FORFRAC - factor needed for temperature interpolation of reference * +! * water vapor foreign-continuum data * +! * INDFOR - index of the lower of the two appropriate reference * +! * temperatures needed for the foreign-continuum interpolation * +! * * +! * Data input * +! * COMMON /Kn/ KA(NSPA(n),5,13,MG), KB(NSPB(n),5,13:59,MG), SELFREF(10,MG),* +! * FORREF(4,MG), KA_M'MGAS', KB_M'MGAS' * +! * (note: n is the band number,'MGAS' is the species name of the minor * +! * gas) * +! * * +! * Description: * +! * KA - k-values for low reference atmospheres (key-species only) * +! * (units: cm**2/molecule) * +! * KB - k-values for high reference atmospheres (key-species only) * +! * (units: cm**2/molecule) * +! * KA_M'MGAS' - k-values for low reference atmosphere minor species * +! * (units: cm**2/molecule) * +! * KB_M'MGAS' - k-values for high reference atmosphere minor species * +! * (units: cm**2/molecule) * +! * SELFREF - k-values for water vapor self-continuum for reference * +! * atmospheres (used below LAYTROP) * +! * (units: cm**2/molecule) * +! * FORREF - k-values for water vapor foreign-continuum for reference * +! * atmospheres (used below/above LAYTROP) * +! * (units: cm**2/molecule) * +! * * +! * DIMENSION ABSA(65*NSPA(n),MG), ABSB(235*NSPB(n),MG) * +! * EQUIVALENCE (KA,ABSA),(KB,ABSB) * +! * * +!******************************************************************************* + + use parrrtm_f, only : ng1 + +! ------- Declarations ------- +#include "taug_cpu_defs.h" + +! ----- Input ----- + integer , intent(in) :: iplon ! the column number (move to calculated in kernel) + integer , intent(in) :: ncol ! the total number of columns + integer , intent(in) :: nlayers ! total number of layers + integer _gpudev, intent(in) :: ngbd(:) + real , intent(in) _gpudev :: fracsd(:,:,:) + real , intent(in) _gpudev :: taug(:,:,:) + + !real :: taugcc(ncol, nlayers, 140) + +! ----- Output ----- + + integer :: i,j,err + real :: t1, t2 + +#ifdef _ACCEL + type(dim3) :: dimGrid, dimBlock +#endif +#ifdef _ACCEL + !dimGrid = dim3( (ncol + 127) / 128, 1, 1) + !dimBlock = dim3( 128,1,1) + + dimGrid = dim3( (ncol + 63) / 64, ((nlayers+1)/2), 1) + dimBlock = dim3( 64, 2, 1) + +#else +!jm this can be made constant if the arrays are padded out, otherwise +!jm will generate a seg fault computing garbage data on unused ends of vectors +!jm zap # define ncol CHNK +#endif + +! Calculate gaseous optical depth and planck fractions for each spectral band. + +! (dmb 2012) Here we configure the grid and thread blocks. These subroutines are +! only parallelized across the column dimension so the blocks are one dimensional. + call taugb1g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb2g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb3g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb4g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb5g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb6g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb7g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb8g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb9g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb10g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb11g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb12g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb13g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb14g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb15g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + + call taugb16g _gpuchv (ncol, nlayers, taug, fracsd & +#include "taug_cpu_args.h" + ) + +#ifdef _ACCEL + dimGrid = dim3( (ncol+ 255) / 256, nlayers, ngptlw ) + dimBlock = dim3( 256, 1, 1) +#endif + +! (dmb 2012) This code used to be in the main rrtmg_lw_rad source file +! We add the aerosol optical depths to the gas optical depths + call addAerosols _gpuchv (ncol, nlayers, ngptlw, nbndlw, ngbd, taug & +#include "taug_cpu_args.h" + ) + + end subroutine taumolg + +#ifndef _ACCEL +! undefines for taug functions +# undef absad +# undef absbd +# undef absbod +# undef ccl4d +# undef ccl4od +# undef cfc11adjd +# undef cfc11adjod +# undef cfc12d +# undef cfc12od +# undef cfc22adjd +# undef cfc22adjod +# undef forrefd +# undef forrefod +# undef fracrefad +# undef fracrefaod +# undef fracrefbd +# undef fracrefbod +# undef kad +# undef ka_mcod +# undef ka_mco2d +# undef ka_mn2d +# undef ka_mn2od +# undef ka_mo2d +# undef ka_mo3d +# undef kaod +# undef kao_mcod +# undef kao_mco2d +# undef kao_mn2d +# undef kao_mn2od +# undef kao_mo3d +# undef kbd +# undef kb_mco2d +# undef kb_mn2d +# undef kb_mn2od +# undef kb_mo2d +# undef kb_mo3d +# undef kbod +# undef kbo_mco2d +# undef kbo_mn2od +# undef kbo_mo3d +# undef selfrefd +# undef selfrefod +#endif + + +!#ifndef _ACCEL +# undef ncol +!#endif + +! (dmb 2012) Allocate all of the needed memory for the taumol subroutines + subroutine allocateGPUTaumol(ncol, nlayers, npart) + + integer , intent(in) :: ncol + integer , intent(in) :: nlayers + integer , intent(in) :: npart + integer :: i +#ifdef _ACCEL + sreg( wx1 , ncol, nlayers ) + sreg( wx2 , ncol, nlayers ) + sreg( wx3 , ncol, nlayers ) + sreg( wx4 , ncol, nlayers ) + + sreg( jp , ncol, nlayers ) + sreg( jt , ncol, nlayers ) + sreg( jt1 , ncol, nlayers ) + sreg( colh2o , ncol, nlayers ) + sreg( colco2 , ncol, nlayers ) + sreg( colo3 , ncol, nlayers ) + sreg( coln2o , ncol, nlayers ) + sreg( colco , ncol, nlayers ) + sreg( colch4 , ncol, nlayers ) + sreg( colo2 , ncol, nlayers ) + sreg( colbrd , ncol, nlayers ) + sreg( indself , ncol, nlayers ) + sreg( indfor , ncol, nlayers ) + sreg( selffac , ncol, nlayers ) + sreg( selffrac , ncol, nlayers ) + sreg( forfac , ncol, nlayers ) + sreg( forfrac , ncol, nlayers ) + sreg( indminor , ncol, nlayers ) + sreg( minorfrac , ncol, nlayers ) + sreg( scaleminor , ncol, nlayers ) + sreg( scaleminorn2 , ncol, nlayers ) + + sreg( fac00 , ncol, nlayers ) + sreg( fac10 , ncol, nlayers ) + sreg( fac01 , ncol, nlayers ) + sreg( fac11 , ncol, nlayers ) + sreg( rat_h2oco2 , ncol, nlayers ) + sreg( rat_h2oco2_1 , ncol, nlayers ) + sreg( rat_h2oo3 , ncol, nlayers ) + sreg( rat_h2oo3_1 , ncol, nlayers ) + sreg( rat_h2on2o , ncol, nlayers ) + sreg( rat_h2on2o_1 , ncol, nlayers ) + sreg( rat_h2och4 , ncol, nlayers ) + sreg( rat_h2och4_1 , ncol, nlayers ) + sreg( rat_n2oco2 , ncol, nlayers ) + sreg( rat_n2oco2_1 , ncol, nlayers ) + sreg( rat_o3co2 , ncol, nlayers ) + sreg( rat_o3co2_1 , ncol, nlayers ) + + call dflush() + + allocate( pavel( ncol, nlayers )) + dreg( wx1 , ncol, nlayers ) + dreg( wx2 , ncol, nlayers ) + dreg( wx3 , ncol, nlayers ) + dreg( wx4 , ncol, nlayers ) + + allocate( coldry( ncol, nlayers )) + + dreg( jp , ncol, nlayers ) + dreg( jt , ncol, nlayers ) + dreg( jt1 , ncol, nlayers ) + dreg( colh2o , ncol, nlayers ) + dreg( colco2 , ncol, nlayers ) + dreg( colo3 , ncol, nlayers ) + dreg( coln2o , ncol, nlayers ) + dreg( colco , ncol, nlayers ) + dreg( colch4 , ncol, nlayers ) + dreg( colo2 , ncol, nlayers ) + dreg( colbrd , ncol, nlayers ) + dreg( indself , ncol, nlayers ) + dreg( indfor , ncol, nlayers ) + dreg( selffac , ncol, nlayers ) + dreg( selffrac , ncol, nlayers ) + dreg( forfac , ncol, nlayers ) + dreg( forfrac , ncol, nlayers ) + dreg( indminor , ncol, nlayers ) + dreg( minorfrac , ncol, nlayers ) + dreg( scaleminor , ncol, nlayers ) + dreg( scaleminorn2 , ncol, nlayers ) + + dreg( fac00 , ncol, nlayers ) + dreg( fac10 , ncol, nlayers ) + dreg( fac01 , ncol, nlayers ) + dreg( fac11 , ncol, nlayers ) + dreg( rat_h2oco2 , ncol, nlayers ) + dreg( rat_h2oco2_1 , ncol, nlayers ) + dreg( rat_h2oo3 , ncol, nlayers ) + dreg( rat_h2oo3_1 , ncol, nlayers ) + dreg( rat_h2on2o , ncol, nlayers ) + dreg( rat_h2on2o_1 , ncol, nlayers ) + dreg( rat_h2och4 , ncol, nlayers ) + dreg( rat_h2och4_1 , ncol, nlayers ) + dreg( rat_n2oco2 , ncol, nlayers ) + dreg( rat_n2oco2_1 , ncol, nlayers ) + dreg( rat_o3co2 , ncol, nlayers ) + dreg( rat_o3co2_1 , ncol, nlayers ) + + allocate( laytrop( ncol )) + allocate( tauaa( ncol, nlayers, nbndlw )) + allocate( nspad( nbndlw )) + allocate( nspbd( nbndlw )) + +#endif + + end subroutine + +! (dmb 2012) Perform the necessary cleanup of the GPU arrays + subroutine deallocateGPUTaumol() + +#ifdef _ACCEL + call dbclean + call dclean + deallocate( pavel) + + deallocate( tauaa ) + deallocate( laytrop) + + deallocate( nspad) + deallocate( nspbd) + deallocate( coldry) +#endif + + end subroutine + + subroutine copyGPUTaumolMol( colstart, pncol, nlayers, colh2oc, colco2c, colo3c, coln2oc, colch4c, colo2c,& + px1,px2,px3,px4, npart) + + integer, value, intent(in) :: colstart, pncol, nlayers, npart + real , intent(in) :: colh2oc(:,:), colco2c(:,:), colo3c(:,:), coln2oc(:,:), & + colch4c(:,:), colo2c(:,:), px1(:,:), px2(:,:), px3(:,:), px4(:,:) + +#ifdef _ACCEL + if (npart > 1) then + colh2o(1:pncol, :) = colh2oc( colstart:(colstart+pncol-1), 1:nlayers) + colco2(1:pncol, :) = colco2c( colstart:(colstart+pncol-1), 1:nlayers) + colo3(1:pncol, :) = colo3c( colstart:(colstart+pncol-1), 1:nlayers) + coln2o(1:pncol, :) = coln2oc( colstart:(colstart+pncol-1), 1:nlayers) + + colch4(1:pncol, :) = colch4c( colstart:(colstart+pncol-1), 1:nlayers) + colo2(1:pncol, :) = colo2c( colstart:(colstart+pncol-1), 1:nlayers) + wx1(1:pncol, :) = px1(colstart:(colstart+pncol-1), 1:nlayers) + wx2(1:pncol, :) = px2(colstart:(colstart+pncol-1), 1:nlayers) + wx3(1:pncol, :) = px3(colstart:(colstart+pncol-1), 1:nlayers) + wx4(1:pncol, :) = px4(colstart:(colstart+pncol-1), 1:nlayers) + else + colh2o = colh2oc + colco2 = colco2c + colo3 = colo3c + coln2o = coln2oc + colch4 = colch4c + colo2 = colo2c + wx1 = px1 + wx2 = px2 + wx3 = px3 + wx4 = px4 + + endif + colco = 0 +#endif + end subroutine + +! (dmb 2012) Copy the needed data from the CPU to the GPU. I had to separate this +! out into 16 separate functions to correspond with the 16 taumol subroutines. + subroutine copyGPUTaumol(pavelc, wxc, coldryc, tauap, pncol, colstart, nlay, npart) + + use rrlw_kg01_f, only : copyToGPU1, reg1 + use rrlw_kg02_f, only : copyToGPU2, reg2 + use rrlw_kg03_f, only : copyToGPU3, reg3 + use rrlw_kg04_f, only : copyToGPU4, reg4 + use rrlw_kg05_f, only : copyToGPU5, reg5 + use rrlw_kg06_f, only : copyToGPU6, reg6 + use rrlw_kg07_f, only : copyToGPU7, reg7 + use rrlw_kg08_f, only : copyToGPU8, reg8 + use rrlw_kg09_f, only : copyToGPU9, reg9 + use rrlw_kg10_f, only : copyToGPU10, reg10 + use rrlw_kg11_f, only : copyToGPU11, reg11 + use rrlw_kg12_f, only : copyToGPU12, reg12 + use rrlw_kg13_f, only : copyToGPU13, reg13 + use rrlw_kg14_f, only : copyToGPU14, reg14 + use rrlw_kg15_f, only : copyToGPU15, reg15 + use rrlw_kg16_f, only : copyToGPU16, reg16 + use rrlw_ref_f, only : copyToGPUref + + real , intent(in) :: pavelc(:,:) ! layer pressures (mb) + ! Dimensions: (ncol,nlayers) + real , intent(in) :: wxc(:,:,:) ! cross-section amounts (mol/cm2) + ! Dimensions: (ncol,maxxsec,nlayers) + real , intent(in) :: coldryc(:,:) ! column amount (dry air) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: tauap(:,:,:) + ! Dimensions: (ncol,nlayers,ngptlw) + integer, intent(in) :: pncol, colstart, nlay, npart + +#ifdef _ACCEL + call reg1 + call reg2 + call reg3 + call reg4 + call reg5 + call reg6 + call reg7 + call reg8 + call reg9 + call reg10 + call reg11 + call reg12 + call reg13 + call reg14 + call reg15 + call reg16 + + dbflushreg() + call CopyToGPU1 + call CopyToGPU2 + call CopyToGPU3 + call CopyToGPU4 + call CopyToGPU5 + call CopyToGPU6 + call CopyToGPU7 + call CopyToGPU8 + call CopyToGPU9 + call CopyToGPU10 + call CopyToGPU11 + call CopyToGPU12 + call CopyToGPU13 + call CopyToGPU14 + call CopyToGPU15 + call CopyToGPU16 + + nspad= nspa + nspbd= nspb + pavel= pavelc + coldry= coldryc + + oneminusd = oneminus + + dbflushcop() + + if (npart > 1) then + tauaa(1:pncol, :, :) = tauap(colstart:(colstart+pncol-1), :, :) + else + tauaa = tauap + endif +#endif + end subroutine + + end module gpu_rrtmg_lw_taumol + +! This is the gpu version of the setcoef routine. + module gpu_rrtmg_lw_setcoef + + use gpu_rrtmg_lw_rtrnmc + + use parrrtm_f, only : nbndlw, mg, maxxsec, mxmol + use rrlw_wvn_f, only: totplnk, totplk16, totplnkderiv, totplk16deriv + use rrlw_vsn_f, only: hvrset, hnamset + use rrlw_ref_f, only : chi_mlsd + + use gpu_rrtmg_lw_taumol + + implicit none + +#ifdef _ACCEL + real _gpudev, allocatable :: taveld(:,:) ! layer temperatures (K) + ! Dimensions: (ncol,nlayers) + real _gpudev, allocatable :: tzd(:,:) ! level (interface) temperatures (K) + ! Dimensions: (ncol,0:nlayers) + real _gpudev, allocatable :: tboundd(:) ! surface temperature (K) + ! Dimensions: (ncol) + real _gpudev, allocatable :: wbroadd(:,:) ! broadening gas column density (mol/cm2) + ! Dimensions: (ncol,nlayers) + + real _gpudev :: totplnkd(181,nbndlw) + real _gpudev :: totplk16d(181) + + real _gpudev :: totplnkderivd(181,nbndlw) + real _gpudev :: totplk16derivd(181) +!$OMP THREADPRIVATE(taveld,tzd,tboundd,wbroadd,totplnkd,totplk16d,totplnkderivd,totplk16derivd) +#endif + + contains + +! (dmb 2012) This subroutine allocates the needed GPU arrays + subroutine allocateGPUSetCoef( ncol, nlayers ) + + integer, intent(in) :: ncol + integer, intent(in) :: nlayers +#ifdef _ACCEL + allocate( taveld( ncol, nlayers) ) + allocate( tzd( ncol, 0:nlayers) ) + allocate( tboundd( ncol )) + allocate( wbroadd( ncol, nlayers) ) +#endif + + end subroutine + +! (dmb 2012) This subroutine deallocates the GPU arrays + subroutine deallocateGPUSetCoef( ) + +#ifdef _ACCEL + deallocate( taveld ) + deallocate( tzd ) + deallocate( tboundd) + deallocate( wbroadd) +#endif + + end subroutine + +! (dmb 2012) Copy the needed reference data from the CPU to the GPU + subroutine copyGPUSetCoef() + +#ifdef _ACCEL + totplnkd = totplnk + totplk16d = totplk16 + totplnkderivd = totplnkderiv + totplk16derivd = totplk16deriv +#endif + + end subroutine + +!---------------------------------------------------------------------------- + _gpuker subroutine setcoefg(ncol, nlayers, istart & +# include "rrtmg_lw_cpu_args.h" +# include "taug_cpu_args.h" +#ifndef _ACCEL + ,taveld,tzd,tboundd,wbroadd,totplnkd,totplk16d,totplnkderivd,totplk16derivd & +#endif + ) +!---------------------------------------------------------------------------- +! +! Purpose: For a given atmosphere, calculate the indices and +! fractions related to the pressure and temperature interpolations. +! Also calculate the values of the integrated Planck functions +! for each band at the level and layer temperatures. + +! ------- Declarations ------- +#ifndef _ACCEL +# include "rrtmg_lw_cpu_defs.h" +# include "taug_cpu_defs.h" + real :: taveld(CHNK,nlayers+1) ! layer temperatures (K) + ! Dimensions: (ncol,nlayers) + real :: tzd(CHNK,0:nlayers+1) ! level (interface) temperatures (K) + ! Dimensions: (ncol,0:nlayers) + real :: tboundd(CHNK) ! surface temperature (K) + ! Dimensions: (ncol) + real :: wbroadd(CHNK,nlayers+1) ! broadening gas column density (mol/cm2) + ! Dimensions: (ncol,nlayers) + + real :: totplnkd(181,nbndlw) + real :: totplk16d(181) + + real :: totplnkderivd(181,nbndlw) + real :: totplk16derivd(181) +#endif + +! ----- Input ----- + integer , value, intent(in) :: ncol + integer , value, intent(in) :: nlayers ! total number of layers + integer , value, intent(in) :: istart ! beginning band of calculation +!jm integer , value, intent(in) :: idrv ! Planck derivative option flag + +! ----- Local ----- + integer :: indbound, indlev0 + integer :: lay, indlay, indlev, iband + integer :: jp1 + real :: stpfac, tbndfrac, t0frac, tlayfrac, tlevfrac + real :: dbdtlev, dbdtlay + real :: plog, fp, ft, ft1, water, scalefac, factor, compfp + integer :: iplon + real :: wv, lcoldry + +#ifdef _ACCEL + iplon = (blockidx%x-1) * blockdim%x + threadidx%x + if (iplon <= ncol) then +#else + do iplon = 1, ncol +#endif + + stpfac = 296. /1013. + + indbound = tboundd(iplon) - 159. + if (indbound .lt. 1) then + indbound = 1 + elseif (indbound .gt. 180) then + indbound = 180 + endif + tbndfrac = tboundd(iplon) - 159. - float(indbound) + indlev0 = tzd(iplon, 0) - 159. + if (indlev0 .lt. 1) then + indlev0 = 1 + elseif (indlev0 .gt. 180) then + indlev0 = 180 + endif + t0frac = tzd(iplon, 0) - 159. - float(indlev0) + laytrop(iplon) = 0 + +! Begin layer loop +! Calculate the integrated Planck functions for each band at the +! surface, level, and layer temperatures. + do lay = 1, nlayers + indlay = taveld(iplon, lay) - 159. + lcoldry = coldry( iplon, lay) + wv = colh2o(iplon, lay) * lcoldry + if (indlay .lt. 1) then + indlay = 1 + elseif (indlay .gt. 180) then + indlay = 180 + endif + tlayfrac = taveld(iplon, lay) - 159. - float(indlay) + indlev = tzd(iplon, lay) - 159. + if (indlev .lt. 1) then + indlev = 1 + elseif (indlev .gt. 180) then + indlev = 180 + endif + tlevfrac = tzd(iplon, lay) - 159. - float(indlev) + +! Begin spectral band loop + do iband = 1, 15 + if (lay.eq.1) then + dbdtlev = totplnkd(indbound+1,iband) - totplnkd(indbound,iband) + plankbndd(iplon, iband) = semissd(iplon, iband) * & + (totplnkd(indbound,iband) + tbndfrac * dbdtlev) + dbdtlev = totplnkd(indlev0+1,iband)-totplnkd(indlev0,iband) + planklevd(iplon, 0,iband) = totplnkd(indlev0,iband) + t0frac * dbdtlev + if (idrvd .eq. 1) then + dbdtlev = totplnkderivd(indbound+1,iband) - totplnkderivd(indbound,iband) + dplankbnd_dtd(iplon, iband) = semissd(iplon, iband) * & + (totplnkderivd(indbound,iband) + tbndfrac * dbdtlev) + endif + endif + dbdtlev = totplnkd(indlev+1,iband) - totplnkd(indlev,iband) + dbdtlay = totplnkd(indlay+1,iband) - totplnkd(indlay,iband) + planklayd(iplon, lay,iband) = totplnkd(indlay,iband) + tlayfrac * dbdtlay + + planklevd(iplon, lay,iband) = totplnkd(indlev,iband) + tlevfrac * dbdtlev + enddo + +! For band 16, if radiative transfer will be performed on just +! this band, use integrated Planck values up to 3250 cm-1. +! If radiative transfer will be performed across all 16 bands, +! then include in the integrated Planck values for this band +! contributions from 2600 cm-1 to infinity. + iband = 16 + if (istart .eq. 16) then + if (lay.eq.1) then + dbdtlev = totplk16d( indbound+1) - totplk16d( indbound) + plankbndd(iplon, iband) = semissd(iplon, iband) * & + (totplk16d( indbound) + tbndfrac * dbdtlev) + if (idrvd .eq. 1) then + dbdtlev = totplk16derivd( indbound+1) - totplk16derivd( indbound) + dplankbnd_dtd(iplon, iband) = semissd(iplon, iband) * & + (totplk16derivd(indbound) + tbndfrac * dbdtlev) + endif + dbdtlev = totplnkd(indlev0+1,iband)-totplnkd(indlev0,iband) + planklevd(iplon, 0,iband) = totplk16d( indlev0) + & + t0frac * dbdtlev + endif + dbdtlev = totplk16d( indlev+1) - totplk16d( indlev) + dbdtlay = totplk16d( indlay+1) - totplk16d( indlay) + planklayd(iplon, lay,iband) = totplk16d( indlay) + tlayfrac * dbdtlay + planklevd(iplon, lay,iband) = totplk16d( indlev) + tlevfrac * dbdtlev + else + if (lay.eq.1) then + dbdtlev = totplnkd(indbound+1,iband) - totplnkd(indbound,iband) + plankbndd(iplon, iband) = semissd(iplon, iband) * & + (totplnkd(indbound,iband) + tbndfrac * dbdtlev) + if (idrvd .eq. 1) then + dbdtlev = totplnkderivd( indbound+1,iband) - totplnkderivd( indbound,iband) + dplankbnd_dtd(iplon, iband) = semissd(iplon, iband) * & + (totplnkderivd( indbound,iband) + tbndfrac * dbdtlev) + endif + dbdtlev = totplnkd(indlev0+1,iband)-totplnkd(indlev0,iband) + planklevd(iplon, 0,iband) = totplnkd(indlev0,iband) + t0frac * dbdtlev + endif + dbdtlev = totplnkd(indlev+1,iband) - totplnkd(indlev,iband) + dbdtlay = totplnkd(indlay+1,iband) - totplnkd(indlay,iband) + planklayd(iplon, lay,iband) = totplnkd(indlay,iband) + tlayfrac * dbdtlay + planklevd(iplon, lay,iband) = totplnkd(indlev,iband) + tlevfrac * dbdtlev + endif + + +! Find the two reference pressures on either side of the +! layer pressure. Store them in JP and JP1. Store in FP the +! fraction of the difference (in ln(pressure)) between these +! two values that the layer pressure lies. +! plog = alog(pavel(lay)) + plog = alog(pavel(iplon, lay)) + jp(iplon, lay) = int(36. - 5*(plog+0.04 )) + if (jp(iplon, lay) .lt. 1) then + jp(iplon, lay) = 1 + elseif (jp(iplon, lay) .gt. 58) then + jp(iplon, lay) = 58 + endif + jp1 = jp(iplon, lay) + 1 + fp = 5. *(preflogd(jp(iplon, lay)) - plog) + +! Determine, for each reference pressure (JP and JP1), which +! reference temperature (these are different for each +! reference pressure) is nearest the layer temperature but does +! not exceed it. Store these indices in JT and JT1, resp. +! Store in FT (resp. FT1) the fraction of the way between JT +! (JT1) and the next highest reference temperature that the +! layer temperature falls. + jt(iplon, lay) = int(3. + (taveld(iplon, lay)-trefd(jp(iplon, lay)))/15. ) + if (jt(iplon, lay) .lt. 1) then + jt(iplon, lay) = 1 + elseif (jt(iplon, lay) .gt. 4) then + jt(iplon, lay) = 4 + endif + ft = ((taveld(iplon, lay)-trefd(jp(iplon, lay)))/15. ) - float(jt(iplon, lay)-3) + jt1(iplon, lay) = int(3. + (taveld(iplon, lay)-trefd( jp1))/15. ) + if (jt1(iplon, lay) .lt. 1) then + jt1(iplon, lay) = 1 + elseif (jt1(iplon, lay) .gt. 4) then + jt1(iplon, lay) = 4 + endif + ft1 = ((taveld(iplon, lay)-trefd(jp1))/15. ) - float(jt1(iplon, lay)-3) + water = wv/lcoldry + scalefac = pavel(iplon, lay) * stpfac / taveld(iplon, lay) + +! If the pressure is less than ~100mb, perform a different +! set of species interpolations. + if (plog .le. 4.56 ) go to 5300 + laytrop(iplon) = laytrop(iplon) + 1 + + forfac(iplon, lay) = scalefac / (1.+water) + factor = (332.0 -taveld(iplon, lay))/36.0 + indfor(iplon, lay) = min(2, max(1, int(factor))) + forfrac(iplon, lay) = factor - float(indfor(iplon, lay)) + +! Set up factors needed to separately include the water vapor +! self-continuum in the calculation of absorption coefficient. + selffac(iplon, lay) = water * forfac(iplon, lay) + factor = (taveld(iplon, lay)-188.0 )/7.2 + indself(iplon, lay) = min(9, max(1, int(factor)-7)) + selffrac(iplon, lay) = factor - float(indself(iplon, lay) + 7) + +! Set up factors needed to separately include the minor gases +! in the calculation of absorption coefficient + scaleminor(iplon, lay) = pavel(iplon, lay)/taveld(iplon, lay) + scaleminorn2(iplon, lay) = (pavel(iplon, lay)/taveld(iplon, lay)) & + *(wbroadd(iplon, lay)/(lcoldry+wv)) + factor = (taveld(iplon, lay)-180.8 )/7.2 + indminor(iplon, lay) = min(18, max(1, int(factor))) + minorfrac(iplon, lay) = factor - float(indminor(iplon, lay)) + +! Setup reference ratio to be used in calculation of binary +! species parameter in lower atmosphere. + rat_h2oco2(iplon, lay)=chi_mlsd( 1,jp(iplon, lay))/chi_mlsd( 2,jp(iplon, lay)) + rat_h2oco2_1(iplon, lay)=chi_mlsd( 1,jp(iplon, lay)+1)/chi_mlsd( 2,jp(iplon, lay)+1) + + rat_h2oo3(iplon, lay)=chi_mlsd( 1,jp(iplon, lay))/chi_mlsd( 3,jp(iplon, lay)) + rat_h2oo3_1(iplon, lay)=chi_mlsd( 1,jp(iplon, lay)+1)/chi_mlsd( 3,jp(iplon, lay)+1) + + rat_h2on2o(iplon, lay)=chi_mlsd( 1,jp(iplon, lay))/chi_mlsd( 4,jp(iplon, lay)) + rat_h2on2o_1(iplon, lay)=chi_mlsd( 1,jp(iplon, lay)+1)/chi_mlsd( 4,jp(iplon, lay)+1) + + rat_h2och4(iplon, lay)=chi_mlsd( 1,jp(iplon, lay))/chi_mlsd( 6,jp(iplon, lay)) + rat_h2och4_1(iplon, lay)=chi_mlsd( 1,jp(iplon, lay)+1)/chi_mlsd( 6,jp(iplon, lay)+1) + + rat_n2oco2(iplon, lay)=chi_mlsd( 4,jp(iplon, lay))/chi_mlsd( 2,jp(iplon, lay)) + rat_n2oco2_1(iplon, lay)=chi_mlsd( 4,jp(iplon, lay)+1)/chi_mlsd( 2,jp(iplon, lay)+1) + +! Calculate needed column amounts. + colh2o(iplon, lay) = 1.e-20 * colh2o(iplon, lay) * lcoldry + colco2(iplon, lay) = 1.e-20 * colco2(iplon, lay) * lcoldry + colo3(iplon, lay) = 1.e-20 * colo3(iplon, lay) * lcoldry + coln2o(iplon, lay) = 1.e-20 * coln2o(iplon, lay) * lcoldry + colco(iplon, lay) = 1.e-20 * colco(iplon, lay) * lcoldry + colch4(iplon, lay) = 1.e-20 * colch4(iplon, lay) * lcoldry + colo2(iplon, lay) = 1.e-20 * colo2(iplon, lay) * lcoldry + if (colco2(iplon, lay) .eq. 0. ) colco2(iplon, lay) = 1.e-32 * lcoldry + if (colo3(iplon, lay) .eq. 0. ) colo3(iplon, lay) = 1.e-32 * lcoldry + if (coln2o(iplon, lay) .eq. 0. ) coln2o(iplon, lay) = 1.e-32 * lcoldry + if (colco(iplon, lay) .eq. 0. ) colco(iplon, lay) = 1.e-32 * lcoldry + if (colch4(iplon, lay) .eq. 0. ) colch4(iplon, lay) = 1.e-32 * lcoldry + colbrd(iplon, lay) = 1.e-20 * wbroadd(iplon, lay) + go to 5400 + +! Above laytrop. + 5300 continue + + forfac(iplon, lay) = scalefac / (1.+water) + factor = (taveld(iplon, lay)-188.0 )/36.0 + indfor(iplon, lay) = 3 + forfrac(iplon, lay) = factor - 1.0 + +! Set up factors needed to separately include the water vapor +! self-continuum in the calculation of absorption coefficient. + selffac(iplon, lay) = water * forfac(iplon, lay) + +! Set up factors needed to separately include the minor gases +! in the calculation of absorption coefficient + scaleminor(iplon, lay) = pavel(iplon, lay)/taveld(iplon, lay) + scaleminorn2(iplon, lay) = (pavel(iplon, lay)/taveld(iplon, lay)) & + * (wbroadd(iplon, lay)/(coldry(iplon, lay)+wv)) + factor = (taveld(iplon, lay)-180.8 )/7.2 + indminor(iplon, lay) = min(18, max(1, int(factor))) + minorfrac(iplon, lay) = factor - float(indminor(iplon, lay)) + +! Setup reference ratio to be used in calculation of binary +! species parameter in upper atmosphere. + rat_h2oco2(iplon, lay)=chi_mlsd( 1,jp(iplon, lay))/chi_mlsd( 2,jp(iplon, lay)) + rat_h2oco2_1(iplon, lay)=chi_mlsd( 1,jp(iplon, lay)+1)/chi_mlsd( 2,jp(iplon, lay)+1) + + rat_o3co2(iplon, lay)=chi_mlsd( 3,jp(iplon, lay))/chi_mlsd( 2,jp(iplon, lay)) + rat_o3co2_1(iplon, lay)=chi_mlsd( 3,jp(iplon, lay)+1)/chi_mlsd( 2,jp(iplon, lay)+1) + +! Calculate needed column amounts. + colh2o(iplon, lay) = 1.e-20 * colh2o(iplon, lay) * lcoldry + colco2(iplon, lay) = 1.e-20 * colco2(iplon, lay) * lcoldry + colo3(iplon, lay) = 1.e-20 * colo3(iplon, lay) * lcoldry + coln2o(iplon, lay) = 1.e-20 * coln2o(iplon, lay) * lcoldry + colco(iplon, lay) = 1.e-20 * colco(iplon, lay) * lcoldry + colch4(iplon, lay) = 1.e-20 * colch4(iplon, lay) * lcoldry + colo2(iplon, lay) = 1.e-20 * colo2(iplon, lay) * lcoldry + if (colco2(iplon, lay) .eq. 0. ) colco2(iplon, lay) = 1.e-32 * lcoldry + if (colo3(iplon, lay) .eq. 0. ) colo3(iplon, lay) = 1.e-32 * lcoldry + if (coln2o(iplon, lay) .eq. 0. ) coln2o(iplon, lay) = 1.e-32 * lcoldry + if (colco(iplon, lay) .eq. 0. ) colco(iplon, lay) = 1.e-32 * lcoldry + if (colch4(iplon, lay) .eq. 0. ) colch4(iplon, lay) = 1.e-32 * lcoldry + colbrd(iplon, lay) = 1.e-20 * wbroadd(iplon, lay) + 5400 continue + +! We have now isolated the layer ln pressure and temperature, +! between two reference pressures and two reference temperatures +! (for each reference pressure). We multiply the pressure +! fraction FP with the appropriate temperature fractions to get +! the factors that will be needed for the interpolation that yields +! the optical depths (performed in routines TAUGBn for band n).` + + compfp = 1. - fp + fac10(iplon, lay) = compfp * ft + fac00(iplon, lay) = compfp * (1. - ft) + fac11(iplon, lay) = fp * ft1 + fac01(iplon, lay) = fp * (1. - ft1) + +! Rescale selffac and forfac for use in taumol + selffac(iplon, lay) = colh2o(iplon, lay)*selffac(iplon, lay) + forfac(iplon, lay) = colh2o(iplon, lay)*forfac(iplon, lay) +! End layer loop + enddo + +#ifdef _ACCEL + endif +#else + end do +#endif + end subroutine setcoefg + + end module gpu_rrtmg_lw_setcoef + + module rrtmg_lw_setcoef_f + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- + +! use parkind, only : im => kind , rb => kind + use parrrtm_f, only : nbndlw, mg, maxxsec, mxmol + use rrlw_wvn_f, only: totplnk, totplk16, totplnkderiv, totplk16deriv + use rrlw_ref_f + + implicit none + + contains + +!*************************************************************************** + subroutine lwatmref +!*************************************************************************** + + save + +! These pressures are chosen such that the ln of the first pressure +! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and +! each subsequent ln(pressure) differs from the previous one by 0.2. + + pref(:) = (/ & + 1.05363e+03 ,8.62642e+02 ,7.06272e+02 ,5.78246e+02 ,4.73428e+02 , & + 3.87610e+02 ,3.17348e+02 ,2.59823e+02 ,2.12725e+02 ,1.74164e+02 , & + 1.42594e+02 ,1.16746e+02 ,9.55835e+01 ,7.82571e+01 ,6.40715e+01 , & + 5.24573e+01 ,4.29484e+01 ,3.51632e+01 ,2.87892e+01 ,2.35706e+01 , & + 1.92980e+01 ,1.57998e+01 ,1.29358e+01 ,1.05910e+01 ,8.67114e+00 , & + 7.09933e+00 ,5.81244e+00 ,4.75882e+00 ,3.89619e+00 ,3.18993e+00 , & + 2.61170e+00 ,2.13828e+00 ,1.75067e+00 ,1.43333e+00 ,1.17351e+00 , & + 9.60789e-01 ,7.86628e-01 ,6.44036e-01 ,5.27292e-01 ,4.31710e-01 , & + 3.53455e-01 ,2.89384e-01 ,2.36928e-01 ,1.93980e-01 ,1.58817e-01 , & + 1.30029e-01 ,1.06458e-01 ,8.71608e-02 ,7.13612e-02 ,5.84256e-02 , & + 4.78349e-02 ,3.91639e-02 ,3.20647e-02 ,2.62523e-02 ,2.14936e-02 , & + 1.75975e-02 ,1.44076e-02 ,1.17959e-02 ,9.65769e-03 /) + + preflog(:) = (/ & + 6.9600e+00 , 6.7600e+00 , 6.5600e+00 , 6.3600e+00 , 6.1600e+00 , & + 5.9600e+00 , 5.7600e+00 , 5.5600e+00 , 5.3600e+00 , 5.1600e+00 , & + 4.9600e+00 , 4.7600e+00 , 4.5600e+00 , 4.3600e+00 , 4.1600e+00 , & + 3.9600e+00 , 3.7600e+00 , 3.5600e+00 , 3.3600e+00 , 3.1600e+00 , & + 2.9600e+00 , 2.7600e+00 , 2.5600e+00 , 2.3600e+00 , 2.1600e+00 , & + 1.9600e+00 , 1.7600e+00 , 1.5600e+00 , 1.3600e+00 , 1.1600e+00 , & + 9.6000e-01 , 7.6000e-01 , 5.6000e-01 , 3.6000e-01 , 1.6000e-01 , & + -4.0000e-02 ,-2.4000e-01 ,-4.4000e-01 ,-6.4000e-01 ,-8.4000e-01 , & + -1.0400e+00 ,-1.2400e+00 ,-1.4400e+00 ,-1.6400e+00 ,-1.8400e+00 , & + -2.0400e+00 ,-2.2400e+00 ,-2.4400e+00 ,-2.6400e+00 ,-2.8400e+00 , & + -3.0400e+00 ,-3.2400e+00 ,-3.4400e+00 ,-3.6400e+00 ,-3.8400e+00 , & + -4.0400e+00 ,-4.2400e+00 ,-4.4400e+00 ,-4.6400e+00 /) + +! These are the temperatures associated with the respective +! pressures for the mls standard atmosphere. + + tref(:) = (/ & + 2.9420e+02 , 2.8799e+02 , 2.7894e+02 , 2.6925e+02 , 2.5983e+02 , & + 2.5017e+02 , 2.4077e+02 , 2.3179e+02 , 2.2306e+02 , 2.1578e+02 , & + 2.1570e+02 , 2.1570e+02 , 2.1570e+02 , 2.1706e+02 , 2.1858e+02 , & + 2.2018e+02 , 2.2174e+02 , 2.2328e+02 , 2.2479e+02 , 2.2655e+02 , & + 2.2834e+02 , 2.3113e+02 , 2.3401e+02 , 2.3703e+02 , 2.4022e+02 , & + 2.4371e+02 , 2.4726e+02 , 2.5085e+02 , 2.5457e+02 , 2.5832e+02 , & + 2.6216e+02 , 2.6606e+02 , 2.6999e+02 , 2.7340e+02 , 2.7536e+02 , & + 2.7568e+02 , 2.7372e+02 , 2.7163e+02 , 2.6955e+02 , 2.6593e+02 , & + 2.6211e+02 , 2.5828e+02 , 2.5360e+02 , 2.4854e+02 , 2.4348e+02 , & + 2.3809e+02 , 2.3206e+02 , 2.2603e+02 , 2.2000e+02 , 2.1435e+02 , & + 2.0887e+02 , 2.0340e+02 , 1.9792e+02 , 1.9290e+02 , 1.8809e+02 , & + 1.8329e+02 , 1.7849e+02 , 1.7394e+02 , 1.7212e+02 /) + + chi_mls(1,1:12) = (/ & + 1.8760e-02 , 1.2223e-02 , 5.8909e-03 , 2.7675e-03 , 1.4065e-03 , & + 7.5970e-04 , 3.8876e-04 , 1.6542e-04 , 3.7190e-05 , 7.4765e-06 , & + 4.3082e-06 , 3.3319e-06 /) + chi_mls(1,13:59) = (/ & + 3.2039e-06 , 3.1619e-06 , 3.2524e-06 , 3.4226e-06 , 3.6288e-06 , & + 3.9148e-06 , 4.1488e-06 , 4.3081e-06 , 4.4420e-06 , 4.5778e-06 , & + 4.7087e-06 , 4.7943e-06 , 4.8697e-06 , 4.9260e-06 , 4.9669e-06 , & + 4.9963e-06 , 5.0527e-06 , 5.1266e-06 , 5.2503e-06 , 5.3571e-06 , & + 5.4509e-06 , 5.4830e-06 , 5.5000e-06 , 5.5000e-06 , 5.4536e-06 , & + 5.4047e-06 , 5.3558e-06 , 5.2533e-06 , 5.1436e-06 , 5.0340e-06 , & + 4.8766e-06 , 4.6979e-06 , 4.5191e-06 , 4.3360e-06 , 4.1442e-06 , & + 3.9523e-06 , 3.7605e-06 , 3.5722e-06 , 3.3855e-06 , 3.1988e-06 , & + 3.0121e-06 , 2.8262e-06 , 2.6407e-06 , 2.4552e-06 , 2.2696e-06 , & + 4.3360e-06 , 4.1442e-06 /) + chi_mls(2,1:12) = (/ & + 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , & + 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , & + 3.5500e-04 , 3.5500e-04 /) + chi_mls(2,13:59) = (/ & + 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , & + 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , & + 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , & + 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , & + 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , & + 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , & + 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , & + 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , 3.5500e-04 , & + 3.5500e-04 , 3.5471e-04 , 3.5427e-04 , 3.5384e-04 , 3.5340e-04 , & + 3.5500e-04 , 3.5500e-04 /) + chi_mls(3,1:12) = (/ & + 3.0170e-08 , 3.4725e-08 , 4.2477e-08 , 5.2759e-08 , 6.6944e-08 , & + 8.7130e-08 , 1.1391e-07 , 1.5677e-07 , 2.1788e-07 , 3.2443e-07 , & + 4.6594e-07 , 5.6806e-07 /) + chi_mls(3,13:59) = (/ & + 6.9607e-07 , 1.1186e-06 , 1.7618e-06 , 2.3269e-06 , 2.9577e-06 , & + 3.6593e-06 , 4.5950e-06 , 5.3189e-06 , 5.9618e-06 , 6.5113e-06 , & + 7.0635e-06 , 7.6917e-06 , 8.2577e-06 , 8.7082e-06 , 8.8325e-06 , & + 8.7149e-06 , 8.0943e-06 , 7.3307e-06 , 6.3101e-06 , 5.3672e-06 , & + 4.4829e-06 , 3.8391e-06 , 3.2827e-06 , 2.8235e-06 , 2.4906e-06 , & + 2.1645e-06 , 1.8385e-06 , 1.6618e-06 , 1.5052e-06 , 1.3485e-06 , & + 1.1972e-06 , 1.0482e-06 , 8.9926e-07 , 7.6343e-07 , 6.5381e-07 , & + 5.4419e-07 , 4.3456e-07 , 3.6421e-07 , 3.1194e-07 , 2.5967e-07 , & + 2.0740e-07 , 1.9146e-07 , 1.9364e-07 , 1.9582e-07 , 1.9800e-07 , & + 7.6343e-07 , 6.5381e-07 /) + chi_mls(4,1:12) = (/ & + 3.2000e-07 , 3.2000e-07 , 3.2000e-07 , 3.2000e-07 , 3.2000e-07 , & + 3.1965e-07 , 3.1532e-07 , 3.0383e-07 , 2.9422e-07 , 2.8495e-07 , & + 2.7671e-07 , 2.6471e-07 /) + chi_mls(4,13:59) = (/ & + 2.4285e-07 , 2.0955e-07 , 1.7195e-07 , 1.3749e-07 , 1.1332e-07 , & + 1.0035e-07 , 9.1281e-08 , 8.5463e-08 , 8.0363e-08 , 7.3372e-08 , & + 6.5975e-08 , 5.6039e-08 , 4.7090e-08 , 3.9977e-08 , 3.2979e-08 , & + 2.6064e-08 , 2.1066e-08 , 1.6592e-08 , 1.3017e-08 , 1.0090e-08 , & + 7.6249e-09 , 6.1159e-09 , 4.6672e-09 , 3.2857e-09 , 2.8484e-09 , & + 2.4620e-09 , 2.0756e-09 , 1.8551e-09 , 1.6568e-09 , 1.4584e-09 , & + 1.3195e-09 , 1.2072e-09 , 1.0948e-09 , 9.9780e-10 , 9.3126e-10 , & + 8.6472e-10 , 7.9818e-10 , 7.5138e-10 , 7.1367e-10 , 6.7596e-10 , & + 6.3825e-10 , 6.0981e-10 , 5.8600e-10 , 5.6218e-10 , 5.3837e-10 , & + 9.9780e-10 , 9.3126e-10 /) + chi_mls(5,1:12) = (/ & + 1.5000e-07 , 1.4306e-07 , 1.3474e-07 , 1.3061e-07 , 1.2793e-07 , & + 1.2038e-07 , 1.0798e-07 , 9.4238e-08 , 7.9488e-08 , 6.1386e-08 , & + 4.5563e-08 , 3.3475e-08 /) + chi_mls(5,13:59) = (/ & + 2.5118e-08 , 1.8671e-08 , 1.4349e-08 , 1.2501e-08 , 1.2407e-08 , & + 1.3472e-08 , 1.4900e-08 , 1.6079e-08 , 1.7156e-08 , 1.8616e-08 , & + 2.0106e-08 , 2.1654e-08 , 2.3096e-08 , 2.4340e-08 , 2.5643e-08 , & + 2.6990e-08 , 2.8456e-08 , 2.9854e-08 , 3.0943e-08 , 3.2023e-08 , & + 3.3101e-08 , 3.4260e-08 , 3.5360e-08 , 3.6397e-08 , 3.7310e-08 , & + 3.8217e-08 , 3.9123e-08 , 4.1303e-08 , 4.3652e-08 , 4.6002e-08 , & + 5.0289e-08 , 5.5446e-08 , 6.0603e-08 , 6.8946e-08 , 8.3652e-08 , & + 9.8357e-08 , 1.1306e-07 , 1.4766e-07 , 1.9142e-07 , 2.3518e-07 , & + 2.7894e-07 , 3.5001e-07 , 4.3469e-07 , 5.1938e-07 , 6.0407e-07 , & + 6.8946e-08 , 8.3652e-08 /) + chi_mls(6,1:12) = (/ & + 1.7000e-06 , 1.7000e-06 , 1.6999e-06 , 1.6904e-06 , 1.6671e-06 , & + 1.6351e-06 , 1.6098e-06 , 1.5590e-06 , 1.5120e-06 , 1.4741e-06 , & + 1.4385e-06 , 1.4002e-06 /) + chi_mls(6,13:59) = (/ & + 1.3573e-06 , 1.3130e-06 , 1.2512e-06 , 1.1668e-06 , 1.0553e-06 , & + 9.3281e-07 , 8.1217e-07 , 7.5239e-07 , 7.0728e-07 , 6.6722e-07 , & + 6.2733e-07 , 5.8604e-07 , 5.4769e-07 , 5.1480e-07 , 4.8206e-07 , & + 4.4943e-07 , 4.1702e-07 , 3.8460e-07 , 3.5200e-07 , 3.1926e-07 , & + 2.8646e-07 , 2.5498e-07 , 2.2474e-07 , 1.9588e-07 , 1.8295e-07 , & + 1.7089e-07 , 1.5882e-07 , 1.5536e-07 , 1.5304e-07 , 1.5072e-07 , & + 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , & + 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , & + 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , 1.5000e-07 , & + 1.5000e-07 , 1.5000e-07 /) + chi_mls(7,1:12) = (/ & + 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , & + 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , & + 0.2090 , 0.2090 /) + chi_mls(7,13:59) = (/ & + 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , & + 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , & + 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , & + 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , & + 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , & + 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , & + 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , & + 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , & + 0.2090 , 0.2090 , 0.2090 , 0.2090 , 0.2090 , & + 0.2090 , 0.2090 /) + + end subroutine lwatmref + +!*************************************************************************** + subroutine lwavplank +!*************************************************************************** + + save + + totplnk(1:50, 1) = (/ & + 0.14783e-05 ,0.15006e-05 ,0.15230e-05 ,0.15455e-05 ,0.15681e-05 , & + 0.15908e-05 ,0.16136e-05 ,0.16365e-05 ,0.16595e-05 ,0.16826e-05 , & + 0.17059e-05 ,0.17292e-05 ,0.17526e-05 ,0.17762e-05 ,0.17998e-05 , & + 0.18235e-05 ,0.18473e-05 ,0.18712e-05 ,0.18953e-05 ,0.19194e-05 , & + 0.19435e-05 ,0.19678e-05 ,0.19922e-05 ,0.20166e-05 ,0.20412e-05 , & + 0.20658e-05 ,0.20905e-05 ,0.21153e-05 ,0.21402e-05 ,0.21652e-05 , & + 0.21902e-05 ,0.22154e-05 ,0.22406e-05 ,0.22659e-05 ,0.22912e-05 , & + 0.23167e-05 ,0.23422e-05 ,0.23678e-05 ,0.23934e-05 ,0.24192e-05 , & + 0.24450e-05 ,0.24709e-05 ,0.24968e-05 ,0.25229e-05 ,0.25490e-05 , & + 0.25751e-05 ,0.26014e-05 ,0.26277e-05 ,0.26540e-05 ,0.26805e-05 /) + totplnk(51:100, 1) = (/ & + 0.27070e-05 ,0.27335e-05 ,0.27602e-05 ,0.27869e-05 ,0.28136e-05 , & + 0.28404e-05 ,0.28673e-05 ,0.28943e-05 ,0.29213e-05 ,0.29483e-05 , & + 0.29754e-05 ,0.30026e-05 ,0.30298e-05 ,0.30571e-05 ,0.30845e-05 , & + 0.31119e-05 ,0.31393e-05 ,0.31669e-05 ,0.31944e-05 ,0.32220e-05 , & + 0.32497e-05 ,0.32774e-05 ,0.33052e-05 ,0.33330e-05 ,0.33609e-05 , & + 0.33888e-05 ,0.34168e-05 ,0.34448e-05 ,0.34729e-05 ,0.35010e-05 , & + 0.35292e-05 ,0.35574e-05 ,0.35857e-05 ,0.36140e-05 ,0.36424e-05 , & + 0.36708e-05 ,0.36992e-05 ,0.37277e-05 ,0.37563e-05 ,0.37848e-05 , & + 0.38135e-05 ,0.38421e-05 ,0.38708e-05 ,0.38996e-05 ,0.39284e-05 , & + 0.39572e-05 ,0.39861e-05 ,0.40150e-05 ,0.40440e-05 ,0.40730e-05 /) + totplnk(101:150, 1) = (/ & + 0.41020e-05 ,0.41311e-05 ,0.41602e-05 ,0.41893e-05 ,0.42185e-05 , & + 0.42477e-05 ,0.42770e-05 ,0.43063e-05 ,0.43356e-05 ,0.43650e-05 , & + 0.43944e-05 ,0.44238e-05 ,0.44533e-05 ,0.44828e-05 ,0.45124e-05 , & + 0.45419e-05 ,0.45715e-05 ,0.46012e-05 ,0.46309e-05 ,0.46606e-05 , & + 0.46903e-05 ,0.47201e-05 ,0.47499e-05 ,0.47797e-05 ,0.48096e-05 , & + 0.48395e-05 ,0.48695e-05 ,0.48994e-05 ,0.49294e-05 ,0.49594e-05 , & + 0.49895e-05 ,0.50196e-05 ,0.50497e-05 ,0.50798e-05 ,0.51100e-05 , & + 0.51402e-05 ,0.51704e-05 ,0.52007e-05 ,0.52309e-05 ,0.52612e-05 , & + 0.52916e-05 ,0.53219e-05 ,0.53523e-05 ,0.53827e-05 ,0.54132e-05 , & + 0.54436e-05 ,0.54741e-05 ,0.55047e-05 ,0.55352e-05 ,0.55658e-05 /) + totplnk(151:181, 1) = (/ & + 0.55964e-05 ,0.56270e-05 ,0.56576e-05 ,0.56883e-05 ,0.57190e-05 , & + 0.57497e-05 ,0.57804e-05 ,0.58112e-05 ,0.58420e-05 ,0.58728e-05 , & + 0.59036e-05 ,0.59345e-05 ,0.59653e-05 ,0.59962e-05 ,0.60272e-05 , & + 0.60581e-05 ,0.60891e-05 ,0.61201e-05 ,0.61511e-05 ,0.61821e-05 , & + 0.62131e-05 ,0.62442e-05 ,0.62753e-05 ,0.63064e-05 ,0.63376e-05 , & + 0.63687e-05 ,0.63998e-05 ,0.64310e-05 ,0.64622e-05 ,0.64935e-05 , & + 0.65247e-05 /) + totplnk(1:50, 2) = (/ & + 0.20262e-05 ,0.20757e-05 ,0.21257e-05 ,0.21763e-05 ,0.22276e-05 , & + 0.22794e-05 ,0.23319e-05 ,0.23849e-05 ,0.24386e-05 ,0.24928e-05 , & + 0.25477e-05 ,0.26031e-05 ,0.26591e-05 ,0.27157e-05 ,0.27728e-05 , & + 0.28306e-05 ,0.28889e-05 ,0.29478e-05 ,0.30073e-05 ,0.30673e-05 , & + 0.31279e-05 ,0.31890e-05 ,0.32507e-05 ,0.33129e-05 ,0.33757e-05 , & + 0.34391e-05 ,0.35029e-05 ,0.35674e-05 ,0.36323e-05 ,0.36978e-05 , & + 0.37638e-05 ,0.38304e-05 ,0.38974e-05 ,0.39650e-05 ,0.40331e-05 , & + 0.41017e-05 ,0.41708e-05 ,0.42405e-05 ,0.43106e-05 ,0.43812e-05 , & + 0.44524e-05 ,0.45240e-05 ,0.45961e-05 ,0.46687e-05 ,0.47418e-05 , & + 0.48153e-05 ,0.48894e-05 ,0.49639e-05 ,0.50389e-05 ,0.51143e-05 /) + totplnk(51:100, 2) = (/ & + 0.51902e-05 ,0.52666e-05 ,0.53434e-05 ,0.54207e-05 ,0.54985e-05 , & + 0.55767e-05 ,0.56553e-05 ,0.57343e-05 ,0.58139e-05 ,0.58938e-05 , & + 0.59742e-05 ,0.60550e-05 ,0.61362e-05 ,0.62179e-05 ,0.63000e-05 , & + 0.63825e-05 ,0.64654e-05 ,0.65487e-05 ,0.66324e-05 ,0.67166e-05 , & + 0.68011e-05 ,0.68860e-05 ,0.69714e-05 ,0.70571e-05 ,0.71432e-05 , & + 0.72297e-05 ,0.73166e-05 ,0.74039e-05 ,0.74915e-05 ,0.75796e-05 , & + 0.76680e-05 ,0.77567e-05 ,0.78459e-05 ,0.79354e-05 ,0.80252e-05 , & + 0.81155e-05 ,0.82061e-05 ,0.82970e-05 ,0.83883e-05 ,0.84799e-05 , & + 0.85719e-05 ,0.86643e-05 ,0.87569e-05 ,0.88499e-05 ,0.89433e-05 , & + 0.90370e-05 ,0.91310e-05 ,0.92254e-05 ,0.93200e-05 ,0.94150e-05 /) + totplnk(101:150, 2) = (/ & + 0.95104e-05 ,0.96060e-05 ,0.97020e-05 ,0.97982e-05 ,0.98948e-05 , & + 0.99917e-05 ,0.10089e-04 ,0.10186e-04 ,0.10284e-04 ,0.10382e-04 , & + 0.10481e-04 ,0.10580e-04 ,0.10679e-04 ,0.10778e-04 ,0.10877e-04 , & + 0.10977e-04 ,0.11077e-04 ,0.11178e-04 ,0.11279e-04 ,0.11380e-04 , & + 0.11481e-04 ,0.11583e-04 ,0.11684e-04 ,0.11786e-04 ,0.11889e-04 , & + 0.11992e-04 ,0.12094e-04 ,0.12198e-04 ,0.12301e-04 ,0.12405e-04 , & + 0.12509e-04 ,0.12613e-04 ,0.12717e-04 ,0.12822e-04 ,0.12927e-04 , & + 0.13032e-04 ,0.13138e-04 ,0.13244e-04 ,0.13349e-04 ,0.13456e-04 , & + 0.13562e-04 ,0.13669e-04 ,0.13776e-04 ,0.13883e-04 ,0.13990e-04 , & + 0.14098e-04 ,0.14206e-04 ,0.14314e-04 ,0.14422e-04 ,0.14531e-04 /) + totplnk(151:181, 2) = (/ & + 0.14639e-04 ,0.14748e-04 ,0.14857e-04 ,0.14967e-04 ,0.15076e-04 , & + 0.15186e-04 ,0.15296e-04 ,0.15407e-04 ,0.15517e-04 ,0.15628e-04 , & + 0.15739e-04 ,0.15850e-04 ,0.15961e-04 ,0.16072e-04 ,0.16184e-04 , & + 0.16296e-04 ,0.16408e-04 ,0.16521e-04 ,0.16633e-04 ,0.16746e-04 , & + 0.16859e-04 ,0.16972e-04 ,0.17085e-04 ,0.17198e-04 ,0.17312e-04 , & + 0.17426e-04 ,0.17540e-04 ,0.17654e-04 ,0.17769e-04 ,0.17883e-04 , & + 0.17998e-04 /) + totplnk(1:50, 3) = (/ & + 1.34822e-06 ,1.39134e-06 ,1.43530e-06 ,1.48010e-06 ,1.52574e-06 , & + 1.57222e-06 ,1.61956e-06 ,1.66774e-06 ,1.71678e-06 ,1.76666e-06 , & + 1.81741e-06 ,1.86901e-06 ,1.92147e-06 ,1.97479e-06 ,2.02898e-06 , & + 2.08402e-06 ,2.13993e-06 ,2.19671e-06 ,2.25435e-06 ,2.31285e-06 , & + 2.37222e-06 ,2.43246e-06 ,2.49356e-06 ,2.55553e-06 ,2.61837e-06 , & + 2.68207e-06 ,2.74664e-06 ,2.81207e-06 ,2.87837e-06 ,2.94554e-06 , & + 3.01356e-06 ,3.08245e-06 ,3.15221e-06 ,3.22282e-06 ,3.29429e-06 , & + 3.36662e-06 ,3.43982e-06 ,3.51386e-06 ,3.58876e-06 ,3.66451e-06 , & + 3.74112e-06 ,3.81857e-06 ,3.89688e-06 ,3.97602e-06 ,4.05601e-06 , & + 4.13685e-06 ,4.21852e-06 ,4.30104e-06 ,4.38438e-06 ,4.46857e-06 /) + totplnk(51:100, 3) = (/ & + 4.55358e-06 ,4.63943e-06 ,4.72610e-06 ,4.81359e-06 ,4.90191e-06 , & + 4.99105e-06 ,5.08100e-06 ,5.17176e-06 ,5.26335e-06 ,5.35573e-06 , & + 5.44892e-06 ,5.54292e-06 ,5.63772e-06 ,5.73331e-06 ,5.82970e-06 , & + 5.92688e-06 ,6.02485e-06 ,6.12360e-06 ,6.22314e-06 ,6.32346e-06 , & + 6.42455e-06 ,6.52641e-06 ,6.62906e-06 ,6.73247e-06 ,6.83664e-06 , & + 6.94156e-06 ,7.04725e-06 ,7.15370e-06 ,7.26089e-06 ,7.36883e-06 , & + 7.47752e-06 ,7.58695e-06 ,7.69712e-06 ,7.80801e-06 ,7.91965e-06 , & + 8.03201e-06 ,8.14510e-06 ,8.25891e-06 ,8.37343e-06 ,8.48867e-06 , & + 8.60463e-06 ,8.72128e-06 ,8.83865e-06 ,8.95672e-06 ,9.07548e-06 , & + 9.19495e-06 ,9.31510e-06 ,9.43594e-06 ,9.55745e-06 ,9.67966e-06 /) + totplnk(101:150, 3) = (/ & + 9.80254e-06 ,9.92609e-06 ,1.00503e-05 ,1.01752e-05 ,1.03008e-05 , & + 1.04270e-05 ,1.05539e-05 ,1.06814e-05 ,1.08096e-05 ,1.09384e-05 , & + 1.10679e-05 ,1.11980e-05 ,1.13288e-05 ,1.14601e-05 ,1.15922e-05 , & + 1.17248e-05 ,1.18581e-05 ,1.19920e-05 ,1.21265e-05 ,1.22616e-05 , & + 1.23973e-05 ,1.25337e-05 ,1.26706e-05 ,1.28081e-05 ,1.29463e-05 , & + 1.30850e-05 ,1.32243e-05 ,1.33642e-05 ,1.35047e-05 ,1.36458e-05 , & + 1.37875e-05 ,1.39297e-05 ,1.40725e-05 ,1.42159e-05 ,1.43598e-05 , & + 1.45044e-05 ,1.46494e-05 ,1.47950e-05 ,1.49412e-05 ,1.50879e-05 , & + 1.52352e-05 ,1.53830e-05 ,1.55314e-05 ,1.56803e-05 ,1.58297e-05 , & + 1.59797e-05 ,1.61302e-05 ,1.62812e-05 ,1.64327e-05 ,1.65848e-05 /) + totplnk(151:181, 3) = (/ & + 1.67374e-05 ,1.68904e-05 ,1.70441e-05 ,1.71982e-05 ,1.73528e-05 , & + 1.75079e-05 ,1.76635e-05 ,1.78197e-05 ,1.79763e-05 ,1.81334e-05 , & + 1.82910e-05 ,1.84491e-05 ,1.86076e-05 ,1.87667e-05 ,1.89262e-05 , & + 1.90862e-05 ,1.92467e-05 ,1.94076e-05 ,1.95690e-05 ,1.97309e-05 , & + 1.98932e-05 ,2.00560e-05 ,2.02193e-05 ,2.03830e-05 ,2.05472e-05 , & + 2.07118e-05 ,2.08768e-05 ,2.10423e-05 ,2.12083e-05 ,2.13747e-05 , & + 2.15414e-05 /) + totplnk(1:50, 4) = (/ & + 8.90528e-07 ,9.24222e-07 ,9.58757e-07 ,9.94141e-07 ,1.03038e-06 , & + 1.06748e-06 ,1.10545e-06 ,1.14430e-06 ,1.18403e-06 ,1.22465e-06 , & + 1.26618e-06 ,1.30860e-06 ,1.35193e-06 ,1.39619e-06 ,1.44136e-06 , & + 1.48746e-06 ,1.53449e-06 ,1.58246e-06 ,1.63138e-06 ,1.68124e-06 , & + 1.73206e-06 ,1.78383e-06 ,1.83657e-06 ,1.89028e-06 ,1.94495e-06 , & + 2.00060e-06 ,2.05724e-06 ,2.11485e-06 ,2.17344e-06 ,2.23303e-06 , & + 2.29361e-06 ,2.35519e-06 ,2.41777e-06 ,2.48134e-06 ,2.54592e-06 , & + 2.61151e-06 ,2.67810e-06 ,2.74571e-06 ,2.81433e-06 ,2.88396e-06 , & + 2.95461e-06 ,3.02628e-06 ,3.09896e-06 ,3.17267e-06 ,3.24741e-06 , & + 3.32316e-06 ,3.39994e-06 ,3.47774e-06 ,3.55657e-06 ,3.63642e-06 /) + totplnk(51:100, 4) = (/ & + 3.71731e-06 ,3.79922e-06 ,3.88216e-06 ,3.96612e-06 ,4.05112e-06 , & + 4.13714e-06 ,4.22419e-06 ,4.31227e-06 ,4.40137e-06 ,4.49151e-06 , & + 4.58266e-06 ,4.67485e-06 ,4.76806e-06 ,4.86229e-06 ,4.95754e-06 , & + 5.05383e-06 ,5.15113e-06 ,5.24946e-06 ,5.34879e-06 ,5.44916e-06 , & + 5.55053e-06 ,5.65292e-06 ,5.75632e-06 ,5.86073e-06 ,5.96616e-06 , & + 6.07260e-06 ,6.18003e-06 ,6.28848e-06 ,6.39794e-06 ,6.50838e-06 , & + 6.61983e-06 ,6.73229e-06 ,6.84573e-06 ,6.96016e-06 ,7.07559e-06 , & + 7.19200e-06 ,7.30940e-06 ,7.42779e-06 ,7.54715e-06 ,7.66749e-06 , & + 7.78882e-06 ,7.91110e-06 ,8.03436e-06 ,8.15859e-06 ,8.28379e-06 , & + 8.40994e-06 ,8.53706e-06 ,8.66515e-06 ,8.79418e-06 ,8.92416e-06 /) + totplnk(101:150, 4) = (/ & + 9.05510e-06 ,9.18697e-06 ,9.31979e-06 ,9.45356e-06 ,9.58826e-06 , & + 9.72389e-06 ,9.86046e-06 ,9.99793e-06 ,1.01364e-05 ,1.02757e-05 , & + 1.04159e-05 ,1.05571e-05 ,1.06992e-05 ,1.08422e-05 ,1.09861e-05 , & + 1.11309e-05 ,1.12766e-05 ,1.14232e-05 ,1.15707e-05 ,1.17190e-05 , & + 1.18683e-05 ,1.20184e-05 ,1.21695e-05 ,1.23214e-05 ,1.24741e-05 , & + 1.26277e-05 ,1.27822e-05 ,1.29376e-05 ,1.30939e-05 ,1.32509e-05 , & + 1.34088e-05 ,1.35676e-05 ,1.37273e-05 ,1.38877e-05 ,1.40490e-05 , & + 1.42112e-05 ,1.43742e-05 ,1.45380e-05 ,1.47026e-05 ,1.48680e-05 , & + 1.50343e-05 ,1.52014e-05 ,1.53692e-05 ,1.55379e-05 ,1.57074e-05 , & + 1.58778e-05 ,1.60488e-05 ,1.62207e-05 ,1.63934e-05 ,1.65669e-05 /) + totplnk(151:181, 4) = (/ & + 1.67411e-05 ,1.69162e-05 ,1.70920e-05 ,1.72685e-05 ,1.74459e-05 , & + 1.76240e-05 ,1.78029e-05 ,1.79825e-05 ,1.81629e-05 ,1.83440e-05 , & + 1.85259e-05 ,1.87086e-05 ,1.88919e-05 ,1.90760e-05 ,1.92609e-05 , & + 1.94465e-05 ,1.96327e-05 ,1.98199e-05 ,2.00076e-05 ,2.01961e-05 , & + 2.03853e-05 ,2.05752e-05 ,2.07658e-05 ,2.09571e-05 ,2.11491e-05 , & + 2.13418e-05 ,2.15352e-05 ,2.17294e-05 ,2.19241e-05 ,2.21196e-05 , & + 2.23158e-05 /) + totplnk(1:50, 5) = (/ & + 5.70230e-07 ,5.94788e-07 ,6.20085e-07 ,6.46130e-07 ,6.72936e-07 , & + 7.00512e-07 ,7.28869e-07 ,7.58019e-07 ,7.87971e-07 ,8.18734e-07 , & + 8.50320e-07 ,8.82738e-07 ,9.15999e-07 ,9.50110e-07 ,9.85084e-07 , & + 1.02093e-06 ,1.05765e-06 ,1.09527e-06 ,1.13378e-06 ,1.17320e-06 , & + 1.21353e-06 ,1.25479e-06 ,1.29698e-06 ,1.34011e-06 ,1.38419e-06 , & + 1.42923e-06 ,1.47523e-06 ,1.52221e-06 ,1.57016e-06 ,1.61910e-06 , & + 1.66904e-06 ,1.71997e-06 ,1.77192e-06 ,1.82488e-06 ,1.87886e-06 , & + 1.93387e-06 ,1.98991e-06 ,2.04699e-06 ,2.10512e-06 ,2.16430e-06 , & + 2.22454e-06 ,2.28584e-06 ,2.34821e-06 ,2.41166e-06 ,2.47618e-06 , & + 2.54178e-06 ,2.60847e-06 ,2.67626e-06 ,2.74514e-06 ,2.81512e-06 /) + totplnk(51:100, 5) = (/ & + 2.88621e-06 ,2.95841e-06 ,3.03172e-06 ,3.10615e-06 ,3.18170e-06 , & + 3.25838e-06 ,3.33618e-06 ,3.41511e-06 ,3.49518e-06 ,3.57639e-06 , & + 3.65873e-06 ,3.74221e-06 ,3.82684e-06 ,3.91262e-06 ,3.99955e-06 , & + 4.08763e-06 ,4.17686e-06 ,4.26725e-06 ,4.35880e-06 ,4.45150e-06 , & + 4.54537e-06 ,4.64039e-06 ,4.73659e-06 ,4.83394e-06 ,4.93246e-06 , & + 5.03215e-06 ,5.13301e-06 ,5.23504e-06 ,5.33823e-06 ,5.44260e-06 , & + 5.54814e-06 ,5.65484e-06 ,5.76272e-06 ,5.87177e-06 ,5.98199e-06 , & + 6.09339e-06 ,6.20596e-06 ,6.31969e-06 ,6.43460e-06 ,6.55068e-06 , & + 6.66793e-06 ,6.78636e-06 ,6.90595e-06 ,7.02670e-06 ,7.14863e-06 , & + 7.27173e-06 ,7.39599e-06 ,7.52142e-06 ,7.64802e-06 ,7.77577e-06 /) + totplnk(101:150, 5) = (/ & + 7.90469e-06 ,8.03477e-06 ,8.16601e-06 ,8.29841e-06 ,8.43198e-06 , & + 8.56669e-06 ,8.70256e-06 ,8.83957e-06 ,8.97775e-06 ,9.11706e-06 , & + 9.25753e-06 ,9.39915e-06 ,9.54190e-06 ,9.68580e-06 ,9.83085e-06 , & + 9.97704e-06 ,1.01243e-05 ,1.02728e-05 ,1.04224e-05 ,1.05731e-05 , & + 1.07249e-05 ,1.08779e-05 ,1.10320e-05 ,1.11872e-05 ,1.13435e-05 , & + 1.15009e-05 ,1.16595e-05 ,1.18191e-05 ,1.19799e-05 ,1.21418e-05 , & + 1.23048e-05 ,1.24688e-05 ,1.26340e-05 ,1.28003e-05 ,1.29676e-05 , & + 1.31361e-05 ,1.33056e-05 ,1.34762e-05 ,1.36479e-05 ,1.38207e-05 , & + 1.39945e-05 ,1.41694e-05 ,1.43454e-05 ,1.45225e-05 ,1.47006e-05 , & + 1.48797e-05 ,1.50600e-05 ,1.52413e-05 ,1.54236e-05 ,1.56070e-05 /) + totplnk(151:181, 5) = (/ & + 1.57914e-05 ,1.59768e-05 ,1.61633e-05 ,1.63509e-05 ,1.65394e-05 , & + 1.67290e-05 ,1.69197e-05 ,1.71113e-05 ,1.73040e-05 ,1.74976e-05 , & + 1.76923e-05 ,1.78880e-05 ,1.80847e-05 ,1.82824e-05 ,1.84811e-05 , & + 1.86808e-05 ,1.88814e-05 ,1.90831e-05 ,1.92857e-05 ,1.94894e-05 , & + 1.96940e-05 ,1.98996e-05 ,2.01061e-05 ,2.03136e-05 ,2.05221e-05 , & + 2.07316e-05 ,2.09420e-05 ,2.11533e-05 ,2.13657e-05 ,2.15789e-05 , & + 2.17931e-05 /) + totplnk(1:50, 6) = (/ & + 2.73493e-07 ,2.87408e-07 ,3.01848e-07 ,3.16825e-07 ,3.32352e-07 , & + 3.48439e-07 ,3.65100e-07 ,3.82346e-07 ,4.00189e-07 ,4.18641e-07 , & + 4.37715e-07 ,4.57422e-07 ,4.77774e-07 ,4.98784e-07 ,5.20464e-07 , & + 5.42824e-07 ,5.65879e-07 ,5.89638e-07 ,6.14115e-07 ,6.39320e-07 , & + 6.65266e-07 ,6.91965e-07 ,7.19427e-07 ,7.47666e-07 ,7.76691e-07 , & + 8.06516e-07 ,8.37151e-07 ,8.68607e-07 ,9.00896e-07 ,9.34029e-07 , & + 9.68018e-07 ,1.00287e-06 ,1.03860e-06 ,1.07522e-06 ,1.11274e-06 , & + 1.15117e-06 ,1.19052e-06 ,1.23079e-06 ,1.27201e-06 ,1.31418e-06 , & + 1.35731e-06 ,1.40141e-06 ,1.44650e-06 ,1.49257e-06 ,1.53965e-06 , & + 1.58773e-06 ,1.63684e-06 ,1.68697e-06 ,1.73815e-06 ,1.79037e-06 /) + totplnk(51:100, 6) = (/ & + 1.84365e-06 ,1.89799e-06 ,1.95341e-06 ,2.00991e-06 ,2.06750e-06 , & + 2.12619e-06 ,2.18599e-06 ,2.24691e-06 ,2.30895e-06 ,2.37212e-06 , & + 2.43643e-06 ,2.50189e-06 ,2.56851e-06 ,2.63628e-06 ,2.70523e-06 , & + 2.77536e-06 ,2.84666e-06 ,2.91916e-06 ,2.99286e-06 ,3.06776e-06 , & + 3.14387e-06 ,3.22120e-06 ,3.29975e-06 ,3.37953e-06 ,3.46054e-06 , & + 3.54280e-06 ,3.62630e-06 ,3.71105e-06 ,3.79707e-06 ,3.88434e-06 , & + 3.97288e-06 ,4.06270e-06 ,4.15380e-06 ,4.24617e-06 ,4.33984e-06 , & + 4.43479e-06 ,4.53104e-06 ,4.62860e-06 ,4.72746e-06 ,4.82763e-06 , & + 4.92911e-06 ,5.03191e-06 ,5.13603e-06 ,5.24147e-06 ,5.34824e-06 , & + 5.45634e-06 ,5.56578e-06 ,5.67656e-06 ,5.78867e-06 ,5.90213e-06 /) + totplnk(101:150, 6) = (/ & + 6.01694e-06 ,6.13309e-06 ,6.25060e-06 ,6.36947e-06 ,6.48968e-06 , & + 6.61126e-06 ,6.73420e-06 ,6.85850e-06 ,6.98417e-06 ,7.11120e-06 , & + 7.23961e-06 ,7.36938e-06 ,7.50053e-06 ,7.63305e-06 ,7.76694e-06 , & + 7.90221e-06 ,8.03887e-06 ,8.17690e-06 ,8.31632e-06 ,8.45710e-06 , & + 8.59928e-06 ,8.74282e-06 ,8.88776e-06 ,9.03409e-06 ,9.18179e-06 , & + 9.33088e-06 ,9.48136e-06 ,9.63323e-06 ,9.78648e-06 ,9.94111e-06 , & + 1.00971e-05 ,1.02545e-05 ,1.04133e-05 ,1.05735e-05 ,1.07351e-05 , & + 1.08980e-05 ,1.10624e-05 ,1.12281e-05 ,1.13952e-05 ,1.15637e-05 , & + 1.17335e-05 ,1.19048e-05 ,1.20774e-05 ,1.22514e-05 ,1.24268e-05 , & + 1.26036e-05 ,1.27817e-05 ,1.29612e-05 ,1.31421e-05 ,1.33244e-05 /) + totplnk(151:181, 6) = (/ & + 1.35080e-05 ,1.36930e-05 ,1.38794e-05 ,1.40672e-05 ,1.42563e-05 , & + 1.44468e-05 ,1.46386e-05 ,1.48318e-05 ,1.50264e-05 ,1.52223e-05 , & + 1.54196e-05 ,1.56182e-05 ,1.58182e-05 ,1.60196e-05 ,1.62223e-05 , & + 1.64263e-05 ,1.66317e-05 ,1.68384e-05 ,1.70465e-05 ,1.72559e-05 , & + 1.74666e-05 ,1.76787e-05 ,1.78921e-05 ,1.81069e-05 ,1.83230e-05 , & + 1.85404e-05 ,1.87591e-05 ,1.89791e-05 ,1.92005e-05 ,1.94232e-05 , & + 1.96471e-05 /) + totplnk(1:50, 7) = (/ & + 1.25349e-07 ,1.32735e-07 ,1.40458e-07 ,1.48527e-07 ,1.56954e-07 , & + 1.65748e-07 ,1.74920e-07 ,1.84481e-07 ,1.94443e-07 ,2.04814e-07 , & + 2.15608e-07 ,2.26835e-07 ,2.38507e-07 ,2.50634e-07 ,2.63229e-07 , & + 2.76301e-07 ,2.89864e-07 ,3.03930e-07 ,3.18508e-07 ,3.33612e-07 , & + 3.49253e-07 ,3.65443e-07 ,3.82195e-07 ,3.99519e-07 ,4.17428e-07 , & + 4.35934e-07 ,4.55050e-07 ,4.74785e-07 ,4.95155e-07 ,5.16170e-07 , & + 5.37844e-07 ,5.60186e-07 ,5.83211e-07 ,6.06929e-07 ,6.31355e-07 , & + 6.56498e-07 ,6.82373e-07 ,7.08990e-07 ,7.36362e-07 ,7.64501e-07 , & + 7.93420e-07 ,8.23130e-07 ,8.53643e-07 ,8.84971e-07 ,9.17128e-07 , & + 9.50123e-07 ,9.83969e-07 ,1.01868e-06 ,1.05426e-06 ,1.09073e-06 /) + totplnk(51:100, 7) = (/ & + 1.12810e-06 ,1.16638e-06 ,1.20558e-06 ,1.24572e-06 ,1.28680e-06 , & + 1.32883e-06 ,1.37183e-06 ,1.41581e-06 ,1.46078e-06 ,1.50675e-06 , & + 1.55374e-06 ,1.60174e-06 ,1.65078e-06 ,1.70087e-06 ,1.75200e-06 , & + 1.80421e-06 ,1.85749e-06 ,1.91186e-06 ,1.96732e-06 ,2.02389e-06 , & + 2.08159e-06 ,2.14040e-06 ,2.20035e-06 ,2.26146e-06 ,2.32372e-06 , & + 2.38714e-06 ,2.45174e-06 ,2.51753e-06 ,2.58451e-06 ,2.65270e-06 , & + 2.72210e-06 ,2.79272e-06 ,2.86457e-06 ,2.93767e-06 ,3.01201e-06 , & + 3.08761e-06 ,3.16448e-06 ,3.24261e-06 ,3.32204e-06 ,3.40275e-06 , & + 3.48476e-06 ,3.56808e-06 ,3.65271e-06 ,3.73866e-06 ,3.82595e-06 , & + 3.91456e-06 ,4.00453e-06 ,4.09584e-06 ,4.18851e-06 ,4.28254e-06 /) + totplnk(101:150, 7) = (/ & + 4.37796e-06 ,4.47475e-06 ,4.57293e-06 ,4.67249e-06 ,4.77346e-06 , & + 4.87583e-06 ,4.97961e-06 ,5.08481e-06 ,5.19143e-06 ,5.29948e-06 , & + 5.40896e-06 ,5.51989e-06 ,5.63226e-06 ,5.74608e-06 ,5.86136e-06 , & + 5.97810e-06 ,6.09631e-06 ,6.21597e-06 ,6.33713e-06 ,6.45976e-06 , & + 6.58388e-06 ,6.70950e-06 ,6.83661e-06 ,6.96521e-06 ,7.09531e-06 , & + 7.22692e-06 ,7.36005e-06 ,7.49468e-06 ,7.63084e-06 ,7.76851e-06 , & + 7.90773e-06 ,8.04846e-06 ,8.19072e-06 ,8.33452e-06 ,8.47985e-06 , & + 8.62674e-06 ,8.77517e-06 ,8.92514e-06 ,9.07666e-06 ,9.22975e-06 , & + 9.38437e-06 ,9.54057e-06 ,9.69832e-06 ,9.85762e-06 ,1.00185e-05 , & + 1.01810e-05 ,1.03450e-05 ,1.05106e-05 ,1.06777e-05 ,1.08465e-05 /) + totplnk(151:181, 7) = (/ & + 1.10168e-05 ,1.11887e-05 ,1.13621e-05 ,1.15372e-05 ,1.17138e-05 , & + 1.18920e-05 ,1.20718e-05 ,1.22532e-05 ,1.24362e-05 ,1.26207e-05 , & + 1.28069e-05 ,1.29946e-05 ,1.31839e-05 ,1.33749e-05 ,1.35674e-05 , & + 1.37615e-05 ,1.39572e-05 ,1.41544e-05 ,1.43533e-05 ,1.45538e-05 , & + 1.47558e-05 ,1.49595e-05 ,1.51647e-05 ,1.53716e-05 ,1.55800e-05 , & + 1.57900e-05 ,1.60017e-05 ,1.62149e-05 ,1.64296e-05 ,1.66460e-05 , & + 1.68640e-05 /) + totplnk(1:50, 8) = (/ & + 6.74445e-08 ,7.18176e-08 ,7.64153e-08 ,8.12456e-08 ,8.63170e-08 , & + 9.16378e-08 ,9.72168e-08 ,1.03063e-07 ,1.09184e-07 ,1.15591e-07 , & + 1.22292e-07 ,1.29296e-07 ,1.36613e-07 ,1.44253e-07 ,1.52226e-07 , & + 1.60540e-07 ,1.69207e-07 ,1.78236e-07 ,1.87637e-07 ,1.97421e-07 , & + 2.07599e-07 ,2.18181e-07 ,2.29177e-07 ,2.40598e-07 ,2.52456e-07 , & + 2.64761e-07 ,2.77523e-07 ,2.90755e-07 ,3.04468e-07 ,3.18673e-07 , & + 3.33381e-07 ,3.48603e-07 ,3.64352e-07 ,3.80638e-07 ,3.97474e-07 , & + 4.14871e-07 ,4.32841e-07 ,4.51395e-07 ,4.70547e-07 ,4.90306e-07 , & + 5.10687e-07 ,5.31699e-07 ,5.53357e-07 ,5.75670e-07 ,5.98652e-07 , & + 6.22315e-07 ,6.46672e-07 ,6.71731e-07 ,6.97511e-07 ,7.24018e-07 /) + totplnk(51:100, 8) = (/ & + 7.51266e-07 ,7.79269e-07 ,8.08038e-07 ,8.37584e-07 ,8.67922e-07 , & + 8.99061e-07 ,9.31016e-07 ,9.63797e-07 ,9.97417e-07 ,1.03189e-06 , & + 1.06722e-06 ,1.10343e-06 ,1.14053e-06 ,1.17853e-06 ,1.21743e-06 , & + 1.25726e-06 ,1.29803e-06 ,1.33974e-06 ,1.38241e-06 ,1.42606e-06 , & + 1.47068e-06 ,1.51630e-06 ,1.56293e-06 ,1.61056e-06 ,1.65924e-06 , & + 1.70894e-06 ,1.75971e-06 ,1.81153e-06 ,1.86443e-06 ,1.91841e-06 , & + 1.97350e-06 ,2.02968e-06 ,2.08699e-06 ,2.14543e-06 ,2.20500e-06 , & + 2.26573e-06 ,2.32762e-06 ,2.39068e-06 ,2.45492e-06 ,2.52036e-06 , & + 2.58700e-06 ,2.65485e-06 ,2.72393e-06 ,2.79424e-06 ,2.86580e-06 , & + 2.93861e-06 ,3.01269e-06 ,3.08803e-06 ,3.16467e-06 ,3.24259e-06 /) + totplnk(101:150, 8) = (/ & + 3.32181e-06 ,3.40235e-06 ,3.48420e-06 ,3.56739e-06 ,3.65192e-06 , & + 3.73779e-06 ,3.82502e-06 ,3.91362e-06 ,4.00359e-06 ,4.09494e-06 , & + 4.18768e-06 ,4.28182e-06 ,4.37737e-06 ,4.47434e-06 ,4.57273e-06 , & + 4.67254e-06 ,4.77380e-06 ,4.87651e-06 ,4.98067e-06 ,5.08630e-06 , & + 5.19339e-06 ,5.30196e-06 ,5.41201e-06 ,5.52356e-06 ,5.63660e-06 , & + 5.75116e-06 ,5.86722e-06 ,5.98479e-06 ,6.10390e-06 ,6.22453e-06 , & + 6.34669e-06 ,6.47042e-06 ,6.59569e-06 ,6.72252e-06 ,6.85090e-06 , & + 6.98085e-06 ,7.11238e-06 ,7.24549e-06 ,7.38019e-06 ,7.51646e-06 , & + 7.65434e-06 ,7.79382e-06 ,7.93490e-06 ,8.07760e-06 ,8.22192e-06 , & + 8.36784e-06 ,8.51540e-06 ,8.66459e-06 ,8.81542e-06 ,8.96786e-06 /) + totplnk(151:181, 8) = (/ & + 9.12197e-06 ,9.27772e-06 ,9.43513e-06 ,9.59419e-06 ,9.75490e-06 , & + 9.91728e-06 ,1.00813e-05 ,1.02471e-05 ,1.04144e-05 ,1.05835e-05 , & + 1.07543e-05 ,1.09267e-05 ,1.11008e-05 ,1.12766e-05 ,1.14541e-05 , & + 1.16333e-05 ,1.18142e-05 ,1.19969e-05 ,1.21812e-05 ,1.23672e-05 , & + 1.25549e-05 ,1.27443e-05 ,1.29355e-05 ,1.31284e-05 ,1.33229e-05 , & + 1.35193e-05 ,1.37173e-05 ,1.39170e-05 ,1.41185e-05 ,1.43217e-05 , & + 1.45267e-05 /) + totplnk(1:50, 9) = (/ & + 2.61522e-08 ,2.80613e-08 ,3.00838e-08 ,3.22250e-08 ,3.44899e-08 , & + 3.68841e-08 ,3.94129e-08 ,4.20820e-08 ,4.48973e-08 ,4.78646e-08 , & + 5.09901e-08 ,5.42799e-08 ,5.77405e-08 ,6.13784e-08 ,6.52001e-08 , & + 6.92126e-08 ,7.34227e-08 ,7.78375e-08 ,8.24643e-08 ,8.73103e-08 , & + 9.23832e-08 ,9.76905e-08 ,1.03240e-07 ,1.09039e-07 ,1.15097e-07 , & + 1.21421e-07 ,1.28020e-07 ,1.34902e-07 ,1.42075e-07 ,1.49548e-07 , & + 1.57331e-07 ,1.65432e-07 ,1.73860e-07 ,1.82624e-07 ,1.91734e-07 , & + 2.01198e-07 ,2.11028e-07 ,2.21231e-07 ,2.31818e-07 ,2.42799e-07 , & + 2.54184e-07 ,2.65983e-07 ,2.78205e-07 ,2.90862e-07 ,3.03963e-07 , & + 3.17519e-07 ,3.31541e-07 ,3.46039e-07 ,3.61024e-07 ,3.76507e-07 /) + totplnk(51:100, 9) = (/ & + 3.92498e-07 ,4.09008e-07 ,4.26050e-07 ,4.43633e-07 ,4.61769e-07 , & + 4.80469e-07 ,4.99744e-07 ,5.19606e-07 ,5.40067e-07 ,5.61136e-07 , & + 5.82828e-07 ,6.05152e-07 ,6.28120e-07 ,6.51745e-07 ,6.76038e-07 , & + 7.01010e-07 ,7.26674e-07 ,7.53041e-07 ,7.80124e-07 ,8.07933e-07 , & + 8.36482e-07 ,8.65781e-07 ,8.95845e-07 ,9.26683e-07 ,9.58308e-07 , & + 9.90732e-07 ,1.02397e-06 ,1.05803e-06 ,1.09292e-06 ,1.12866e-06 , & + 1.16526e-06 ,1.20274e-06 ,1.24109e-06 ,1.28034e-06 ,1.32050e-06 , & + 1.36158e-06 ,1.40359e-06 ,1.44655e-06 ,1.49046e-06 ,1.53534e-06 , & + 1.58120e-06 ,1.62805e-06 ,1.67591e-06 ,1.72478e-06 ,1.77468e-06 , & + 1.82561e-06 ,1.87760e-06 ,1.93066e-06 ,1.98479e-06 ,2.04000e-06 /) + totplnk(101:150, 9) = (/ & + 2.09631e-06 ,2.15373e-06 ,2.21228e-06 ,2.27196e-06 ,2.33278e-06 , & + 2.39475e-06 ,2.45790e-06 ,2.52222e-06 ,2.58773e-06 ,2.65445e-06 , & + 2.72238e-06 ,2.79152e-06 ,2.86191e-06 ,2.93354e-06 ,3.00643e-06 , & + 3.08058e-06 ,3.15601e-06 ,3.23273e-06 ,3.31075e-06 ,3.39009e-06 , & + 3.47074e-06 ,3.55272e-06 ,3.63605e-06 ,3.72072e-06 ,3.80676e-06 , & + 3.89417e-06 ,3.98297e-06 ,4.07315e-06 ,4.16474e-06 ,4.25774e-06 , & + 4.35217e-06 ,4.44802e-06 ,4.54532e-06 ,4.64406e-06 ,4.74428e-06 , & + 4.84595e-06 ,4.94911e-06 ,5.05376e-06 ,5.15990e-06 ,5.26755e-06 , & + 5.37671e-06 ,5.48741e-06 ,5.59963e-06 ,5.71340e-06 ,5.82871e-06 , & + 5.94559e-06 ,6.06403e-06 ,6.18404e-06 ,6.30565e-06 ,6.42885e-06 /) + totplnk(151:181, 9) = (/ & + 6.55364e-06 ,6.68004e-06 ,6.80806e-06 ,6.93771e-06 ,7.06898e-06 , & + 7.20190e-06 ,7.33646e-06 ,7.47267e-06 ,7.61056e-06 ,7.75010e-06 , & + 7.89133e-06 ,8.03423e-06 ,8.17884e-06 ,8.32514e-06 ,8.47314e-06 , & + 8.62284e-06 ,8.77427e-06 ,8.92743e-06 ,9.08231e-06 ,9.23893e-06 , & + 9.39729e-06 ,9.55741e-06 ,9.71927e-06 ,9.88291e-06 ,1.00483e-05 , & + 1.02155e-05 ,1.03844e-05 ,1.05552e-05 ,1.07277e-05 ,1.09020e-05 , & + 1.10781e-05 /) + totplnk(1:50,10) = (/ & + 8.89300e-09 ,9.63263e-09 ,1.04235e-08 ,1.12685e-08 ,1.21703e-08 , & + 1.31321e-08 ,1.41570e-08 ,1.52482e-08 ,1.64090e-08 ,1.76428e-08 , & + 1.89533e-08 ,2.03441e-08 ,2.18190e-08 ,2.33820e-08 ,2.50370e-08 , & + 2.67884e-08 ,2.86402e-08 ,3.05969e-08 ,3.26632e-08 ,3.48436e-08 , & + 3.71429e-08 ,3.95660e-08 ,4.21179e-08 ,4.48040e-08 ,4.76294e-08 , & + 5.05996e-08 ,5.37201e-08 ,5.69966e-08 ,6.04349e-08 ,6.40411e-08 , & + 6.78211e-08 ,7.17812e-08 ,7.59276e-08 ,8.02670e-08 ,8.48059e-08 , & + 8.95508e-08 ,9.45090e-08 ,9.96873e-08 ,1.05093e-07 ,1.10733e-07 , & + 1.16614e-07 ,1.22745e-07 ,1.29133e-07 ,1.35786e-07 ,1.42711e-07 , & + 1.49916e-07 ,1.57410e-07 ,1.65202e-07 ,1.73298e-07 ,1.81709e-07 /) + totplnk(51:100,10) = (/ & + 1.90441e-07 ,1.99505e-07 ,2.08908e-07 ,2.18660e-07 ,2.28770e-07 , & + 2.39247e-07 ,2.50101e-07 ,2.61340e-07 ,2.72974e-07 ,2.85013e-07 , & + 2.97467e-07 ,3.10345e-07 ,3.23657e-07 ,3.37413e-07 ,3.51623e-07 , & + 3.66298e-07 ,3.81448e-07 ,3.97082e-07 ,4.13212e-07 ,4.29848e-07 , & + 4.47000e-07 ,4.64680e-07 ,4.82898e-07 ,5.01664e-07 ,5.20991e-07 , & + 5.40888e-07 ,5.61369e-07 ,5.82440e-07 ,6.04118e-07 ,6.26410e-07 , & + 6.49329e-07 ,6.72887e-07 ,6.97095e-07 ,7.21964e-07 ,7.47506e-07 , & + 7.73732e-07 ,8.00655e-07 ,8.28287e-07 ,8.56635e-07 ,8.85717e-07 , & + 9.15542e-07 ,9.46122e-07 ,9.77469e-07 ,1.00960e-06 ,1.04251e-06 , & + 1.07623e-06 ,1.11077e-06 ,1.14613e-06 ,1.18233e-06 ,1.21939e-06 /) + totplnk(101:150,10) = (/ & + 1.25730e-06 ,1.29610e-06 ,1.33578e-06 ,1.37636e-06 ,1.41785e-06 , & + 1.46027e-06 ,1.50362e-06 ,1.54792e-06 ,1.59319e-06 ,1.63942e-06 , & + 1.68665e-06 ,1.73487e-06 ,1.78410e-06 ,1.83435e-06 ,1.88564e-06 , & + 1.93797e-06 ,1.99136e-06 ,2.04582e-06 ,2.10137e-06 ,2.15801e-06 , & + 2.21576e-06 ,2.27463e-06 ,2.33462e-06 ,2.39577e-06 ,2.45806e-06 , & + 2.52153e-06 ,2.58617e-06 ,2.65201e-06 ,2.71905e-06 ,2.78730e-06 , & + 2.85678e-06 ,2.92749e-06 ,2.99946e-06 ,3.07269e-06 ,3.14720e-06 , & + 3.22299e-06 ,3.30007e-06 ,3.37847e-06 ,3.45818e-06 ,3.53923e-06 , & + 3.62161e-06 ,3.70535e-06 ,3.79046e-06 ,3.87695e-06 ,3.96481e-06 , & + 4.05409e-06 ,4.14477e-06 ,4.23687e-06 ,4.33040e-06 ,4.42538e-06 /) + totplnk(151:181,10) = (/ & + 4.52180e-06 ,4.61969e-06 ,4.71905e-06 ,4.81991e-06 ,4.92226e-06 , & + 5.02611e-06 ,5.13148e-06 ,5.23839e-06 ,5.34681e-06 ,5.45681e-06 , & + 5.56835e-06 ,5.68146e-06 ,5.79614e-06 ,5.91242e-06 ,6.03030e-06 , & + 6.14978e-06 ,6.27088e-06 ,6.39360e-06 ,6.51798e-06 ,6.64398e-06 , & + 6.77165e-06 ,6.90099e-06 ,7.03198e-06 ,7.16468e-06 ,7.29906e-06 , & + 7.43514e-06 ,7.57294e-06 ,7.71244e-06 ,7.85369e-06 ,7.99666e-06 , & + 8.14138e-06 /) + totplnk(1:50,11) = (/ & + 2.53767e-09 ,2.77242e-09 ,3.02564e-09 ,3.29851e-09 ,3.59228e-09 , & + 3.90825e-09 ,4.24777e-09 ,4.61227e-09 ,5.00322e-09 ,5.42219e-09 , & + 5.87080e-09 ,6.35072e-09 ,6.86370e-09 ,7.41159e-09 ,7.99628e-09 , & + 8.61974e-09 ,9.28404e-09 ,9.99130e-09 ,1.07437e-08 ,1.15436e-08 , & + 1.23933e-08 ,1.32953e-08 ,1.42522e-08 ,1.52665e-08 ,1.63410e-08 , & + 1.74786e-08 ,1.86820e-08 ,1.99542e-08 ,2.12985e-08 ,2.27179e-08 , & + 2.42158e-08 ,2.57954e-08 ,2.74604e-08 ,2.92141e-08 ,3.10604e-08 , & + 3.30029e-08 ,3.50457e-08 ,3.71925e-08 ,3.94476e-08 ,4.18149e-08 , & + 4.42991e-08 ,4.69043e-08 ,4.96352e-08 ,5.24961e-08 ,5.54921e-08 , & + 5.86277e-08 ,6.19081e-08 ,6.53381e-08 ,6.89231e-08 ,7.26681e-08 /) + totplnk(51:100,11) = (/ & + 7.65788e-08 ,8.06604e-08 ,8.49187e-08 ,8.93591e-08 ,9.39879e-08 , & + 9.88106e-08 ,1.03834e-07 ,1.09063e-07 ,1.14504e-07 ,1.20165e-07 , & + 1.26051e-07 ,1.32169e-07 ,1.38525e-07 ,1.45128e-07 ,1.51982e-07 , & + 1.59096e-07 ,1.66477e-07 ,1.74132e-07 ,1.82068e-07 ,1.90292e-07 , & + 1.98813e-07 ,2.07638e-07 ,2.16775e-07 ,2.26231e-07 ,2.36015e-07 , & + 2.46135e-07 ,2.56599e-07 ,2.67415e-07 ,2.78592e-07 ,2.90137e-07 , & + 3.02061e-07 ,3.14371e-07 ,3.27077e-07 ,3.40186e-07 ,3.53710e-07 , & + 3.67655e-07 ,3.82031e-07 ,3.96848e-07 ,4.12116e-07 ,4.27842e-07 , & + 4.44039e-07 ,4.60713e-07 ,4.77876e-07 ,4.95537e-07 ,5.13706e-07 , & + 5.32392e-07 ,5.51608e-07 ,5.71360e-07 ,5.91662e-07 ,6.12521e-07 /) + totplnk(101:150,11) = (/ & + 6.33950e-07 ,6.55958e-07 ,6.78556e-07 ,7.01753e-07 ,7.25562e-07 , & + 7.49992e-07 ,7.75055e-07 ,8.00760e-07 ,8.27120e-07 ,8.54145e-07 , & + 8.81845e-07 ,9.10233e-07 ,9.39318e-07 ,9.69113e-07 ,9.99627e-07 , & + 1.03087e-06 ,1.06286e-06 ,1.09561e-06 ,1.12912e-06 ,1.16340e-06 , & + 1.19848e-06 ,1.23435e-06 ,1.27104e-06 ,1.30855e-06 ,1.34690e-06 , & + 1.38609e-06 ,1.42614e-06 ,1.46706e-06 ,1.50886e-06 ,1.55155e-06 , & + 1.59515e-06 ,1.63967e-06 ,1.68512e-06 ,1.73150e-06 ,1.77884e-06 , & + 1.82715e-06 ,1.87643e-06 ,1.92670e-06 ,1.97797e-06 ,2.03026e-06 , & + 2.08356e-06 ,2.13791e-06 ,2.19330e-06 ,2.24975e-06 ,2.30728e-06 , & + 2.36589e-06 ,2.42560e-06 ,2.48641e-06 ,2.54835e-06 ,2.61142e-06 /) + totplnk(151:181,11) = (/ & + 2.67563e-06 ,2.74100e-06 ,2.80754e-06 ,2.87526e-06 ,2.94417e-06 , & + 3.01429e-06 ,3.08562e-06 ,3.15819e-06 ,3.23199e-06 ,3.30704e-06 , & + 3.38336e-06 ,3.46096e-06 ,3.53984e-06 ,3.62002e-06 ,3.70151e-06 , & + 3.78433e-06 ,3.86848e-06 ,3.95399e-06 ,4.04084e-06 ,4.12907e-06 , & + 4.21868e-06 ,4.30968e-06 ,4.40209e-06 ,4.49592e-06 ,4.59117e-06 , & + 4.68786e-06 ,4.78600e-06 ,4.88561e-06 ,4.98669e-06 ,5.08926e-06 , & + 5.19332e-06 /) + totplnk(1:50,12) = (/ & + 2.73921e-10 ,3.04500e-10 ,3.38056e-10 ,3.74835e-10 ,4.15099e-10 , & + 4.59126e-10 ,5.07214e-10 ,5.59679e-10 ,6.16857e-10 ,6.79103e-10 , & + 7.46796e-10 ,8.20335e-10 ,9.00144e-10 ,9.86671e-10 ,1.08039e-09 , & + 1.18180e-09 ,1.29142e-09 ,1.40982e-09 ,1.53757e-09 ,1.67529e-09 , & + 1.82363e-09 ,1.98327e-09 ,2.15492e-09 ,2.33932e-09 ,2.53726e-09 , & + 2.74957e-09 ,2.97710e-09 ,3.22075e-09 ,3.48145e-09 ,3.76020e-09 , & + 4.05801e-09 ,4.37595e-09 ,4.71513e-09 ,5.07672e-09 ,5.46193e-09 , & + 5.87201e-09 ,6.30827e-09 ,6.77205e-09 ,7.26480e-09 ,7.78794e-09 , & + 8.34304e-09 ,8.93163e-09 ,9.55537e-09 ,1.02159e-08 ,1.09151e-08 , & + 1.16547e-08 ,1.24365e-08 ,1.32625e-08 ,1.41348e-08 ,1.50554e-08 /) + totplnk(51:100,12) = (/ & + 1.60264e-08 ,1.70500e-08 ,1.81285e-08 ,1.92642e-08 ,2.04596e-08 , & + 2.17171e-08 ,2.30394e-08 ,2.44289e-08 ,2.58885e-08 ,2.74209e-08 , & + 2.90290e-08 ,3.07157e-08 ,3.24841e-08 ,3.43371e-08 ,3.62782e-08 , & + 3.83103e-08 ,4.04371e-08 ,4.26617e-08 ,4.49878e-08 ,4.74190e-08 , & + 4.99589e-08 ,5.26113e-08 ,5.53801e-08 ,5.82692e-08 ,6.12826e-08 , & + 6.44245e-08 ,6.76991e-08 ,7.11105e-08 ,7.46634e-08 ,7.83621e-08 , & + 8.22112e-08 ,8.62154e-08 ,9.03795e-08 ,9.47081e-08 ,9.92066e-08 , & + 1.03879e-07 ,1.08732e-07 ,1.13770e-07 ,1.18998e-07 ,1.24422e-07 , & + 1.30048e-07 ,1.35880e-07 ,1.41924e-07 ,1.48187e-07 ,1.54675e-07 , & + 1.61392e-07 ,1.68346e-07 ,1.75543e-07 ,1.82988e-07 ,1.90688e-07 /) + totplnk(101:150,12) = (/ & + 1.98650e-07 ,2.06880e-07 ,2.15385e-07 ,2.24172e-07 ,2.33247e-07 , & + 2.42617e-07 ,2.52289e-07 ,2.62272e-07 ,2.72571e-07 ,2.83193e-07 , & + 2.94147e-07 ,3.05440e-07 ,3.17080e-07 ,3.29074e-07 ,3.41430e-07 , & + 3.54155e-07 ,3.67259e-07 ,3.80747e-07 ,3.94631e-07 ,4.08916e-07 , & + 4.23611e-07 ,4.38725e-07 ,4.54267e-07 ,4.70245e-07 ,4.86666e-07 , & + 5.03541e-07 ,5.20879e-07 ,5.38687e-07 ,5.56975e-07 ,5.75751e-07 , & + 5.95026e-07 ,6.14808e-07 ,6.35107e-07 ,6.55932e-07 ,6.77293e-07 , & + 6.99197e-07 ,7.21656e-07 ,7.44681e-07 ,7.68278e-07 ,7.92460e-07 , & + 8.17235e-07 ,8.42614e-07 ,8.68606e-07 ,8.95223e-07 ,9.22473e-07 , & + 9.50366e-07 ,9.78915e-07 ,1.00813e-06 ,1.03802e-06 ,1.06859e-06 /) + totplnk(151:181,12) = (/ & + 1.09986e-06 ,1.13184e-06 ,1.16453e-06 ,1.19796e-06 ,1.23212e-06 , & + 1.26703e-06 ,1.30270e-06 ,1.33915e-06 ,1.37637e-06 ,1.41440e-06 , & + 1.45322e-06 ,1.49286e-06 ,1.53333e-06 ,1.57464e-06 ,1.61679e-06 , & + 1.65981e-06 ,1.70370e-06 ,1.74847e-06 ,1.79414e-06 ,1.84071e-06 , & + 1.88821e-06 ,1.93663e-06 ,1.98599e-06 ,2.03631e-06 ,2.08759e-06 , & + 2.13985e-06 ,2.19310e-06 ,2.24734e-06 ,2.30260e-06 ,2.35888e-06 , & + 2.41619e-06 /) + totplnk(1:50,13) = (/ & + 4.53634e-11 ,5.11435e-11 ,5.75754e-11 ,6.47222e-11 ,7.26531e-11 , & + 8.14420e-11 ,9.11690e-11 ,1.01921e-10 ,1.13790e-10 ,1.26877e-10 , & + 1.41288e-10 ,1.57140e-10 ,1.74555e-10 ,1.93665e-10 ,2.14613e-10 , & + 2.37548e-10 ,2.62633e-10 ,2.90039e-10 ,3.19948e-10 ,3.52558e-10 , & + 3.88073e-10 ,4.26716e-10 ,4.68719e-10 ,5.14331e-10 ,5.63815e-10 , & + 6.17448e-10 ,6.75526e-10 ,7.38358e-10 ,8.06277e-10 ,8.79625e-10 , & + 9.58770e-10 ,1.04410e-09 ,1.13602e-09 ,1.23495e-09 ,1.34135e-09 , & + 1.45568e-09 ,1.57845e-09 ,1.71017e-09 ,1.85139e-09 ,2.00268e-09 , & + 2.16464e-09 ,2.33789e-09 ,2.52309e-09 ,2.72093e-09 ,2.93212e-09 , & + 3.15740e-09 ,3.39757e-09 ,3.65341e-09 ,3.92579e-09 ,4.21559e-09 /) + totplnk(51:100,13) = (/ & + 4.52372e-09 ,4.85115e-09 ,5.19886e-09 ,5.56788e-09 ,5.95928e-09 , & + 6.37419e-09 ,6.81375e-09 ,7.27917e-09 ,7.77168e-09 ,8.29256e-09 , & + 8.84317e-09 ,9.42487e-09 ,1.00391e-08 ,1.06873e-08 ,1.13710e-08 , & + 1.20919e-08 ,1.28515e-08 ,1.36514e-08 ,1.44935e-08 ,1.53796e-08 , & + 1.63114e-08 ,1.72909e-08 ,1.83201e-08 ,1.94008e-08 ,2.05354e-08 , & + 2.17258e-08 ,2.29742e-08 ,2.42830e-08 ,2.56545e-08 ,2.70910e-08 , & + 2.85950e-08 ,3.01689e-08 ,3.18155e-08 ,3.35373e-08 ,3.53372e-08 , & + 3.72177e-08 ,3.91818e-08 ,4.12325e-08 ,4.33727e-08 ,4.56056e-08 , & + 4.79342e-08 ,5.03617e-08 ,5.28915e-08 ,5.55270e-08 ,5.82715e-08 , & + 6.11286e-08 ,6.41019e-08 ,6.71951e-08 ,7.04119e-08 ,7.37560e-08 /) + totplnk(101:150,13) = (/ & + 7.72315e-08 ,8.08424e-08 ,8.45927e-08 ,8.84866e-08 ,9.25281e-08 , & + 9.67218e-08 ,1.01072e-07 ,1.05583e-07 ,1.10260e-07 ,1.15107e-07 , & + 1.20128e-07 ,1.25330e-07 ,1.30716e-07 ,1.36291e-07 ,1.42061e-07 , & + 1.48031e-07 ,1.54206e-07 ,1.60592e-07 ,1.67192e-07 ,1.74015e-07 , & + 1.81064e-07 ,1.88345e-07 ,1.95865e-07 ,2.03628e-07 ,2.11643e-07 , & + 2.19912e-07 ,2.28443e-07 ,2.37244e-07 ,2.46318e-07 ,2.55673e-07 , & + 2.65316e-07 ,2.75252e-07 ,2.85489e-07 ,2.96033e-07 ,3.06891e-07 , & + 3.18070e-07 ,3.29576e-07 ,3.41417e-07 ,3.53600e-07 ,3.66133e-07 , & + 3.79021e-07 ,3.92274e-07 ,4.05897e-07 ,4.19899e-07 ,4.34288e-07 , & + 4.49071e-07 ,4.64255e-07 ,4.79850e-07 ,4.95863e-07 ,5.12300e-07 /) + totplnk(151:181,13) = (/ & + 5.29172e-07 ,5.46486e-07 ,5.64250e-07 ,5.82473e-07 ,6.01164e-07 , & + 6.20329e-07 ,6.39979e-07 ,6.60122e-07 ,6.80767e-07 ,7.01922e-07 , & + 7.23596e-07 ,7.45800e-07 ,7.68539e-07 ,7.91826e-07 ,8.15669e-07 , & + 8.40076e-07 ,8.65058e-07 ,8.90623e-07 ,9.16783e-07 ,9.43544e-07 , & + 9.70917e-07 ,9.98912e-07 ,1.02754e-06 ,1.05681e-06 ,1.08673e-06 , & + 1.11731e-06 ,1.14856e-06 ,1.18050e-06 ,1.21312e-06 ,1.24645e-06 , & + 1.28049e-06 /) + totplnk(1:50,14) = (/ & + 1.40113e-11 ,1.59358e-11 ,1.80960e-11 ,2.05171e-11 ,2.32266e-11 , & + 2.62546e-11 ,2.96335e-11 ,3.33990e-11 ,3.75896e-11 ,4.22469e-11 , & + 4.74164e-11 ,5.31466e-11 ,5.94905e-11 ,6.65054e-11 ,7.42522e-11 , & + 8.27975e-11 ,9.22122e-11 ,1.02573e-10 ,1.13961e-10 ,1.26466e-10 , & + 1.40181e-10 ,1.55206e-10 ,1.71651e-10 ,1.89630e-10 ,2.09265e-10 , & + 2.30689e-10 ,2.54040e-10 ,2.79467e-10 ,3.07128e-10 ,3.37190e-10 , & + 3.69833e-10 ,4.05243e-10 ,4.43623e-10 ,4.85183e-10 ,5.30149e-10 , & + 5.78755e-10 ,6.31255e-10 ,6.87910e-10 ,7.49002e-10 ,8.14824e-10 , & + 8.85687e-10 ,9.61914e-10 ,1.04385e-09 ,1.13186e-09 ,1.22631e-09 , & + 1.32761e-09 ,1.43617e-09 ,1.55243e-09 ,1.67686e-09 ,1.80992e-09 /) + totplnk(51:100,14) = (/ & + 1.95212e-09 ,2.10399e-09 ,2.26607e-09 ,2.43895e-09 ,2.62321e-09 , & + 2.81949e-09 ,3.02844e-09 ,3.25073e-09 ,3.48707e-09 ,3.73820e-09 , & + 4.00490e-09 ,4.28794e-09 ,4.58819e-09 ,4.90647e-09 ,5.24371e-09 , & + 5.60081e-09 ,5.97875e-09 ,6.37854e-09 ,6.80120e-09 ,7.24782e-09 , & + 7.71950e-09 ,8.21740e-09 ,8.74271e-09 ,9.29666e-09 ,9.88054e-09 , & + 1.04956e-08 ,1.11434e-08 ,1.18251e-08 ,1.25422e-08 ,1.32964e-08 , & + 1.40890e-08 ,1.49217e-08 ,1.57961e-08 ,1.67140e-08 ,1.76771e-08 , & + 1.86870e-08 ,1.97458e-08 ,2.08553e-08 ,2.20175e-08 ,2.32342e-08 , & + 2.45077e-08 ,2.58401e-08 ,2.72334e-08 ,2.86900e-08 ,3.02122e-08 , & + 3.18021e-08 ,3.34624e-08 ,3.51954e-08 ,3.70037e-08 ,3.88899e-08 /) + totplnk(101:150,14) = (/ & + 4.08568e-08 ,4.29068e-08 ,4.50429e-08 ,4.72678e-08 ,4.95847e-08 , & + 5.19963e-08 ,5.45058e-08 ,5.71161e-08 ,5.98309e-08 ,6.26529e-08 , & + 6.55857e-08 ,6.86327e-08 ,7.17971e-08 ,7.50829e-08 ,7.84933e-08 , & + 8.20323e-08 ,8.57035e-08 ,8.95105e-08 ,9.34579e-08 ,9.75488e-08 , & + 1.01788e-07 ,1.06179e-07 ,1.10727e-07 ,1.15434e-07 ,1.20307e-07 , & + 1.25350e-07 ,1.30566e-07 ,1.35961e-07 ,1.41539e-07 ,1.47304e-07 , & + 1.53263e-07 ,1.59419e-07 ,1.65778e-07 ,1.72345e-07 ,1.79124e-07 , & + 1.86122e-07 ,1.93343e-07 ,2.00792e-07 ,2.08476e-07 ,2.16400e-07 , & + 2.24568e-07 ,2.32988e-07 ,2.41666e-07 ,2.50605e-07 ,2.59813e-07 , & + 2.69297e-07 ,2.79060e-07 ,2.89111e-07 ,2.99455e-07 ,3.10099e-07 /) + totplnk(151:181,14) = (/ & + 3.21049e-07 ,3.32311e-07 ,3.43893e-07 ,3.55801e-07 ,3.68041e-07 , & + 3.80621e-07 ,3.93547e-07 ,4.06826e-07 ,4.20465e-07 ,4.34473e-07 , & + 4.48856e-07 ,4.63620e-07 ,4.78774e-07 ,4.94325e-07 ,5.10280e-07 , & + 5.26648e-07 ,5.43436e-07 ,5.60652e-07 ,5.78302e-07 ,5.96397e-07 , & + 6.14943e-07 ,6.33949e-07 ,6.53421e-07 ,6.73370e-07 ,6.93803e-07 , & + 7.14731e-07 ,7.36157e-07 ,7.58095e-07 ,7.80549e-07 ,8.03533e-07 , & + 8.27050e-07 /) + totplnk(1:50,15) = (/ & + 3.90483e-12 ,4.47999e-12 ,5.13122e-12 ,5.86739e-12 ,6.69829e-12 , & + 7.63467e-12 ,8.68833e-12 ,9.87221e-12 ,1.12005e-11 ,1.26885e-11 , & + 1.43534e-11 ,1.62134e-11 ,1.82888e-11 ,2.06012e-11 ,2.31745e-11 , & + 2.60343e-11 ,2.92087e-11 ,3.27277e-11 ,3.66242e-11 ,4.09334e-11 , & + 4.56935e-11 ,5.09455e-11 ,5.67338e-11 ,6.31057e-11 ,7.01127e-11 , & + 7.78096e-11 ,8.62554e-11 ,9.55130e-11 ,1.05651e-10 ,1.16740e-10 , & + 1.28858e-10 ,1.42089e-10 ,1.56519e-10 ,1.72243e-10 ,1.89361e-10 , & + 2.07978e-10 ,2.28209e-10 ,2.50173e-10 ,2.73999e-10 ,2.99820e-10 , & + 3.27782e-10 ,3.58034e-10 ,3.90739e-10 ,4.26067e-10 ,4.64196e-10 , & + 5.05317e-10 ,5.49631e-10 ,5.97347e-10 ,6.48689e-10 ,7.03891e-10 /) + totplnk(51:100,15) = (/ & + 7.63201e-10 ,8.26876e-10 ,8.95192e-10 ,9.68430e-10 ,1.04690e-09 , & + 1.13091e-09 ,1.22079e-09 ,1.31689e-09 ,1.41957e-09 ,1.52922e-09 , & + 1.64623e-09 ,1.77101e-09 ,1.90401e-09 ,2.04567e-09 ,2.19647e-09 , & + 2.35690e-09 ,2.52749e-09 ,2.70875e-09 ,2.90127e-09 ,3.10560e-09 , & + 3.32238e-09 ,3.55222e-09 ,3.79578e-09 ,4.05375e-09 ,4.32682e-09 , & + 4.61574e-09 ,4.92128e-09 ,5.24420e-09 ,5.58536e-09 ,5.94558e-09 , & + 6.32575e-09 ,6.72678e-09 ,7.14964e-09 ,7.59526e-09 ,8.06470e-09 , & + 8.55897e-09 ,9.07916e-09 ,9.62638e-09 ,1.02018e-08 ,1.08066e-08 , & + 1.14420e-08 ,1.21092e-08 ,1.28097e-08 ,1.35446e-08 ,1.43155e-08 , & + 1.51237e-08 ,1.59708e-08 ,1.68581e-08 ,1.77873e-08 ,1.87599e-08 /) + totplnk(101:150,15) = (/ & + 1.97777e-08 ,2.08423e-08 ,2.19555e-08 ,2.31190e-08 ,2.43348e-08 , & + 2.56045e-08 ,2.69302e-08 ,2.83140e-08 ,2.97578e-08 ,3.12636e-08 , & + 3.28337e-08 ,3.44702e-08 ,3.61755e-08 ,3.79516e-08 ,3.98012e-08 , & + 4.17265e-08 ,4.37300e-08 ,4.58143e-08 ,4.79819e-08 ,5.02355e-08 , & + 5.25777e-08 ,5.50114e-08 ,5.75393e-08 ,6.01644e-08 ,6.28896e-08 , & + 6.57177e-08 ,6.86521e-08 ,7.16959e-08 ,7.48520e-08 ,7.81239e-08 , & + 8.15148e-08 ,8.50282e-08 ,8.86675e-08 ,9.24362e-08 ,9.63380e-08 , & + 1.00376e-07 ,1.04555e-07 ,1.08878e-07 ,1.13349e-07 ,1.17972e-07 , & + 1.22751e-07 ,1.27690e-07 ,1.32793e-07 ,1.38064e-07 ,1.43508e-07 , & + 1.49129e-07 ,1.54931e-07 ,1.60920e-07 ,1.67099e-07 ,1.73473e-07 /) + totplnk(151:181,15) = (/ & + 1.80046e-07 ,1.86825e-07 ,1.93812e-07 ,2.01014e-07 ,2.08436e-07 , & + 2.16082e-07 ,2.23957e-07 ,2.32067e-07 ,2.40418e-07 ,2.49013e-07 , & + 2.57860e-07 ,2.66963e-07 ,2.76328e-07 ,2.85961e-07 ,2.95868e-07 , & + 3.06053e-07 ,3.16524e-07 ,3.27286e-07 ,3.38345e-07 ,3.49707e-07 , & + 3.61379e-07 ,3.73367e-07 ,3.85676e-07 ,3.98315e-07 ,4.11287e-07 , & + 4.24602e-07 ,4.38265e-07 ,4.52283e-07 ,4.66662e-07 ,4.81410e-07 , & + 4.96535e-07 /) + totplnk(1:50,16) = (/ & + 0.28639e-12 ,0.33349e-12 ,0.38764e-12 ,0.44977e-12 ,0.52093e-12 , & + 0.60231e-12 ,0.69522e-12 ,0.80111e-12 ,0.92163e-12 ,0.10586e-11 , & + 0.12139e-11 ,0.13899e-11 ,0.15890e-11 ,0.18138e-11 ,0.20674e-11 , & + 0.23531e-11 ,0.26744e-11 ,0.30352e-11 ,0.34401e-11 ,0.38936e-11 , & + 0.44011e-11 ,0.49681e-11 ,0.56010e-11 ,0.63065e-11 ,0.70919e-11 , & + 0.79654e-11 ,0.89357e-11 ,0.10012e-10 ,0.11205e-10 ,0.12526e-10 , & + 0.13986e-10 ,0.15600e-10 ,0.17380e-10 ,0.19342e-10 ,0.21503e-10 , & + 0.23881e-10 ,0.26494e-10 ,0.29362e-10 ,0.32509e-10 ,0.35958e-10 , & + 0.39733e-10 ,0.43863e-10 ,0.48376e-10 ,0.53303e-10 ,0.58679e-10 , & + 0.64539e-10 ,0.70920e-10 ,0.77864e-10 ,0.85413e-10 ,0.93615e-10 /) + totplnk(51:100,16) = (/ & + 0.10252e-09 ,0.11217e-09 ,0.12264e-09 ,0.13397e-09 ,0.14624e-09 , & + 0.15950e-09 ,0.17383e-09 ,0.18930e-09 ,0.20599e-09 ,0.22399e-09 , & + 0.24339e-09 ,0.26427e-09 ,0.28674e-09 ,0.31090e-09 ,0.33686e-09 , & + 0.36474e-09 ,0.39466e-09 ,0.42676e-09 ,0.46115e-09 ,0.49800e-09 , & + 0.53744e-09 ,0.57964e-09 ,0.62476e-09 ,0.67298e-09 ,0.72448e-09 , & + 0.77945e-09 ,0.83809e-09 ,0.90062e-09 ,0.96725e-09 ,0.10382e-08 , & + 0.11138e-08 ,0.11941e-08 ,0.12796e-08 ,0.13704e-08 ,0.14669e-08 , & + 0.15694e-08 ,0.16781e-08 ,0.17934e-08 ,0.19157e-08 ,0.20453e-08 , & + 0.21825e-08 ,0.23278e-08 ,0.24815e-08 ,0.26442e-08 ,0.28161e-08 , & + 0.29978e-08 ,0.31898e-08 ,0.33925e-08 ,0.36064e-08 ,0.38321e-08 /) + totplnk(101:150,16) = (/ & + 0.40700e-08 ,0.43209e-08 ,0.45852e-08 ,0.48636e-08 ,0.51567e-08 , & + 0.54652e-08 ,0.57897e-08 ,0.61310e-08 ,0.64897e-08 ,0.68667e-08 , & + 0.72626e-08 ,0.76784e-08 ,0.81148e-08 ,0.85727e-08 ,0.90530e-08 , & + 0.95566e-08 ,0.10084e-07 ,0.10638e-07 ,0.11217e-07 ,0.11824e-07 , & + 0.12458e-07 ,0.13123e-07 ,0.13818e-07 ,0.14545e-07 ,0.15305e-07 , & + 0.16099e-07 ,0.16928e-07 ,0.17795e-07 ,0.18699e-07 ,0.19643e-07 , & + 0.20629e-07 ,0.21656e-07 ,0.22728e-07 ,0.23845e-07 ,0.25010e-07 , & + 0.26223e-07 ,0.27487e-07 ,0.28804e-07 ,0.30174e-07 ,0.31600e-07 , & + 0.33084e-07 ,0.34628e-07 ,0.36233e-07 ,0.37902e-07 ,0.39637e-07 , & + 0.41440e-07 ,0.43313e-07 ,0.45259e-07 ,0.47279e-07 ,0.49376e-07 /) + totplnk(151:181,16) = (/ & + 0.51552e-07 ,0.53810e-07 ,0.56153e-07 ,0.58583e-07 ,0.61102e-07 , & + 0.63713e-07 ,0.66420e-07 ,0.69224e-07 ,0.72129e-07 ,0.75138e-07 , & + 0.78254e-07 ,0.81479e-07 ,0.84818e-07 ,0.88272e-07 ,0.91846e-07 , & + 0.95543e-07 ,0.99366e-07 ,0.10332e-06 ,0.10740e-06 ,0.11163e-06 , & + 0.11599e-06 ,0.12050e-06 ,0.12515e-06 ,0.12996e-06 ,0.13493e-06 , & + 0.14005e-06 ,0.14534e-06 ,0.15080e-06 ,0.15643e-06 ,0.16224e-06 , & + 0.16823e-06 /) + totplk16(1:50) = (/ & + 0.28481e-12 ,0.33159e-12 ,0.38535e-12 ,0.44701e-12 ,0.51763e-12 , & + 0.59836e-12 ,0.69049e-12 ,0.79549e-12 ,0.91493e-12 ,0.10506e-11 , & + 0.12045e-11 ,0.13788e-11 ,0.15758e-11 ,0.17984e-11 ,0.20493e-11 , & + 0.23317e-11 ,0.26494e-11 ,0.30060e-11 ,0.34060e-11 ,0.38539e-11 , & + 0.43548e-11 ,0.49144e-11 ,0.55387e-11 ,0.62344e-11 ,0.70086e-11 , & + 0.78692e-11 ,0.88248e-11 ,0.98846e-11 ,0.11059e-10 ,0.12358e-10 , & + 0.13794e-10 ,0.15379e-10 ,0.17128e-10 ,0.19055e-10 ,0.21176e-10 , & + 0.23508e-10 ,0.26070e-10 ,0.28881e-10 ,0.31963e-10 ,0.35339e-10 , & + 0.39034e-10 ,0.43073e-10 ,0.47484e-10 ,0.52299e-10 ,0.57548e-10 , & + 0.63267e-10 ,0.69491e-10 ,0.76261e-10 ,0.83616e-10 ,0.91603e-10 /) + totplk16(51:100) = (/ & + 0.10027e-09 ,0.10966e-09 ,0.11983e-09 ,0.13084e-09 ,0.14275e-09 , & + 0.15562e-09 ,0.16951e-09 ,0.18451e-09 ,0.20068e-09 ,0.21810e-09 , & + 0.23686e-09 ,0.25704e-09 ,0.27875e-09 ,0.30207e-09 ,0.32712e-09 , & + 0.35400e-09 ,0.38282e-09 ,0.41372e-09 ,0.44681e-09 ,0.48223e-09 , & + 0.52013e-09 ,0.56064e-09 ,0.60392e-09 ,0.65015e-09 ,0.69948e-09 , & + 0.75209e-09 ,0.80818e-09 ,0.86794e-09 ,0.93157e-09 ,0.99929e-09 , & + 0.10713e-08 ,0.11479e-08 ,0.12293e-08 ,0.13157e-08 ,0.14074e-08 , & + 0.15047e-08 ,0.16079e-08 ,0.17172e-08 ,0.18330e-08 ,0.19557e-08 , & + 0.20855e-08 ,0.22228e-08 ,0.23680e-08 ,0.25214e-08 ,0.26835e-08 , & + 0.28546e-08 ,0.30352e-08 ,0.32257e-08 ,0.34266e-08 ,0.36384e-08 /) + totplk16(101:150) = (/ & + 0.38615e-08 ,0.40965e-08 ,0.43438e-08 ,0.46041e-08 ,0.48779e-08 , & + 0.51658e-08 ,0.54683e-08 ,0.57862e-08 ,0.61200e-08 ,0.64705e-08 , & + 0.68382e-08 ,0.72240e-08 ,0.76285e-08 ,0.80526e-08 ,0.84969e-08 , & + 0.89624e-08 ,0.94498e-08 ,0.99599e-08 ,0.10494e-07 ,0.11052e-07 , & + 0.11636e-07 ,0.12246e-07 ,0.12884e-07 ,0.13551e-07 ,0.14246e-07 , & + 0.14973e-07 ,0.15731e-07 ,0.16522e-07 ,0.17347e-07 ,0.18207e-07 , & + 0.19103e-07 ,0.20037e-07 ,0.21011e-07 ,0.22024e-07 ,0.23079e-07 , & + 0.24177e-07 ,0.25320e-07 ,0.26508e-07 ,0.27744e-07 ,0.29029e-07 , & + 0.30365e-07 ,0.31753e-07 ,0.33194e-07 ,0.34691e-07 ,0.36246e-07 , & + 0.37859e-07 ,0.39533e-07 ,0.41270e-07 ,0.43071e-07 ,0.44939e-07 /) + totplk16(151:181) = (/ & + 0.46875e-07 ,0.48882e-07 ,0.50961e-07 ,0.53115e-07 ,0.55345e-07 , & + 0.57655e-07 ,0.60046e-07 ,0.62520e-07 ,0.65080e-07 ,0.67728e-07 , & + 0.70466e-07 ,0.73298e-07 ,0.76225e-07 ,0.79251e-07 ,0.82377e-07 , & + 0.85606e-07 ,0.88942e-07 ,0.92386e-07 ,0.95942e-07 ,0.99612e-07 , & + 0.10340e-06 ,0.10731e-06 ,0.11134e-06 ,0.11550e-06 ,0.11979e-06 , & + 0.12421e-06 ,0.12876e-06 ,0.13346e-06 ,0.13830e-06 ,0.14328e-06 , & + 0.14841e-06 /) + + end subroutine lwavplank + +!*************************************************************************** + subroutine lwavplankderiv +!*************************************************************************** + + save + + totplnkderiv(1:50, 1) = (/ & + 2.22125e-08 ,2.23245e-08 ,2.24355e-08 ,2.25435e-08 ,2.26560e-08 , & + 2.27620e-08 ,2.28690e-08 ,2.29760e-08 ,2.30775e-08 ,2.31800e-08 , & + 2.32825e-08 ,2.33825e-08 ,2.34820e-08 ,2.35795e-08 ,2.36760e-08 , & + 2.37710e-08 ,2.38655e-08 ,2.39595e-08 ,2.40530e-08 ,2.41485e-08 , & + 2.42395e-08 ,2.43300e-08 ,2.44155e-08 ,2.45085e-08 ,2.45905e-08 , & + 2.46735e-08 ,2.47565e-08 ,2.48465e-08 ,2.49315e-08 ,2.50100e-08 , & + 2.50905e-08 ,2.51705e-08 ,2.52490e-08 ,2.53260e-08 ,2.54075e-08 , & + 2.54785e-08 ,2.55555e-08 ,2.56340e-08 ,2.57050e-08 ,2.57820e-08 , & + 2.58525e-08 ,2.59205e-08 ,2.59945e-08 ,2.60680e-08 ,2.61375e-08 , & + 2.61980e-08 ,2.62745e-08 ,2.63335e-08 ,2.63995e-08 ,2.64710e-08 /) + totplnkderiv(51:100, 1) = (/ & + 2.65300e-08 ,2.66005e-08 ,2.66685e-08 ,2.67310e-08 ,2.67915e-08 , & + 2.68540e-08 ,2.69065e-08 ,2.69730e-08 ,2.70270e-08 ,2.70690e-08 , & + 2.71420e-08 ,2.71985e-08 ,2.72560e-08 ,2.73180e-08 ,2.73760e-08 , & + 2.74285e-08 ,2.74840e-08 ,2.75290e-08 ,2.75950e-08 ,2.76360e-08 , & + 2.76975e-08 ,2.77475e-08 ,2.78080e-08 ,2.78375e-08 ,2.79120e-08 , & + 2.79510e-08 ,2.79955e-08 ,2.80625e-08 ,2.80920e-08 ,2.81570e-08 , & + 2.81990e-08 ,2.82330e-08 ,2.82830e-08 ,2.83365e-08 ,2.83740e-08 , & + 2.84295e-08 ,2.84910e-08 ,2.85275e-08 ,2.85525e-08 ,2.86085e-08 , & + 2.86535e-08 ,2.86945e-08 ,2.87355e-08 ,2.87695e-08 ,2.88105e-08 , & + 2.88585e-08 ,2.88945e-08 ,2.89425e-08 ,2.89580e-08 ,2.90265e-08 /) + totplnkderiv(101:150, 1) = (/ & + 2.90445e-08 ,2.90905e-08 ,2.91425e-08 ,2.91560e-08 ,2.91970e-08 , & + 2.91905e-08 ,2.92880e-08 ,2.92950e-08 ,2.93630e-08 ,2.93995e-08 , & + 2.94425e-08 ,2.94635e-08 ,2.94770e-08 ,2.95290e-08 ,2.95585e-08 , & + 2.95815e-08 ,2.95995e-08 ,2.96745e-08 ,2.96725e-08 ,2.97040e-08 , & + 2.97750e-08 ,2.97905e-08 ,2.98175e-08 ,2.98355e-08 ,2.98705e-08 , & + 2.99040e-08 ,2.99680e-08 ,2.99860e-08 ,3.00270e-08 ,3.00200e-08 , & + 3.00770e-08 ,3.00795e-08 ,3.01065e-08 ,3.01795e-08 ,3.01815e-08 , & + 3.02025e-08 ,3.02360e-08 ,3.02360e-08 ,3.03090e-08 ,3.03155e-08 , & + 3.03725e-08 ,3.03635e-08 ,3.04270e-08 ,3.04610e-08 ,3.04635e-08 , & + 3.04610e-08 ,3.05180e-08 ,3.05430e-08 ,3.05290e-08 ,3.05885e-08 /) + totplnkderiv(151:181, 1) = (/ & + 3.05750e-08 ,3.05775e-08 ,3.06795e-08 ,3.07025e-08 ,3.07365e-08 , & + 3.07435e-08 ,3.07525e-08 ,3.07680e-08 ,3.08115e-08 ,3.07930e-08 , & + 3.08155e-08 ,3.08660e-08 ,3.08865e-08 ,3.08390e-08 ,3.09340e-08 , & + 3.09685e-08 ,3.09340e-08 ,3.09820e-08 ,3.10365e-08 ,3.10705e-08 , & + 3.10750e-08 ,3.10475e-08 ,3.11685e-08 ,3.11455e-08 ,3.11500e-08 , & + 3.11775e-08 ,3.11890e-08 ,3.12045e-08 ,3.12185e-08 ,3.12415e-08 , & + 3.12590e-08 /) + totplnkderiv(1:50, 2) = (/ & + 4.91150e-08 ,4.97290e-08 ,5.03415e-08 ,5.09460e-08 ,5.15550e-08 , & + 5.21540e-08 ,5.27575e-08 ,5.33500e-08 ,5.39500e-08 ,5.45445e-08 , & + 5.51290e-08 ,5.57235e-08 ,5.62955e-08 ,5.68800e-08 ,5.74620e-08 , & + 5.80425e-08 ,5.86145e-08 ,5.91810e-08 ,5.97435e-08 ,6.03075e-08 , & + 6.08625e-08 ,6.14135e-08 ,6.19775e-08 ,6.25185e-08 ,6.30675e-08 , & + 6.36145e-08 ,6.41535e-08 ,6.46920e-08 ,6.52265e-08 ,6.57470e-08 , & + 6.62815e-08 ,6.68000e-08 ,6.73320e-08 ,6.78550e-08 ,6.83530e-08 , & + 6.88760e-08 ,6.93735e-08 ,6.98790e-08 ,7.03950e-08 ,7.08810e-08 , & + 7.13815e-08 ,7.18795e-08 ,7.23415e-08 ,7.28505e-08 ,7.33285e-08 , & + 7.38075e-08 ,7.42675e-08 ,7.47605e-08 ,7.52380e-08 ,7.57020e-08 /) + totplnkderiv(51:100, 2) = (/ & + 7.61495e-08 ,7.65955e-08 ,7.70565e-08 ,7.75185e-08 ,7.79735e-08 , & + 7.83915e-08 ,7.88625e-08 ,7.93215e-08 ,7.97425e-08 ,8.02195e-08 , & + 8.05905e-08 ,8.10335e-08 ,8.14770e-08 ,8.19025e-08 ,8.22955e-08 , & + 8.27115e-08 ,8.31165e-08 ,8.35645e-08 ,8.39440e-08 ,8.43785e-08 , & + 8.47380e-08 ,8.51495e-08 ,8.55405e-08 ,8.59720e-08 ,8.63135e-08 , & + 8.67065e-08 ,8.70930e-08 ,8.74545e-08 ,8.78780e-08 ,8.82160e-08 , & + 8.85625e-08 ,8.89850e-08 ,8.93395e-08 ,8.97080e-08 ,9.00675e-08 , & + 9.04085e-08 ,9.07360e-08 ,9.11315e-08 ,9.13815e-08 ,9.18320e-08 , & + 9.21500e-08 ,9.24725e-08 ,9.28640e-08 ,9.31955e-08 ,9.35185e-08 , & + 9.38645e-08 ,9.41780e-08 ,9.45465e-08 ,9.48470e-08 ,9.51375e-08 /) + totplnkderiv(101:150, 2) = (/ & + 9.55245e-08 ,9.57925e-08 ,9.61195e-08 ,9.64750e-08 ,9.68110e-08 , & + 9.71715e-08 ,9.74150e-08 ,9.77250e-08 ,9.79600e-08 ,9.82600e-08 , & + 9.85300e-08 ,9.88400e-08 ,9.91600e-08 ,9.95350e-08 ,9.97500e-08 , & + 1.00090e-07 ,1.00370e-07 ,1.00555e-07 ,1.00935e-07 ,1.01275e-07 , & + 1.01400e-07 ,1.01790e-07 ,1.01945e-07 ,1.02225e-07 ,1.02585e-07 , & + 1.02895e-07 ,1.03010e-07 ,1.03285e-07 ,1.03540e-07 ,1.03890e-07 , & + 1.04015e-07 ,1.04420e-07 ,1.04640e-07 ,1.04810e-07 ,1.05090e-07 , & + 1.05385e-07 ,1.05600e-07 ,1.05965e-07 ,1.06050e-07 ,1.06385e-07 , & + 1.06390e-07 ,1.06795e-07 ,1.06975e-07 ,1.07240e-07 ,1.07435e-07 , & + 1.07815e-07 ,1.07960e-07 ,1.08010e-07 ,1.08535e-07 ,1.08670e-07 /) + totplnkderiv(151:181, 2) = (/ & + 1.08855e-07 ,1.09210e-07 ,1.09195e-07 ,1.09510e-07 ,1.09665e-07 , & + 1.09885e-07 ,1.10130e-07 ,1.10440e-07 ,1.10640e-07 ,1.10760e-07 , & + 1.11125e-07 ,1.11195e-07 ,1.11345e-07 ,1.11710e-07 ,1.11765e-07 , & + 1.11960e-07 ,1.12225e-07 ,1.12460e-07 ,1.12595e-07 ,1.12730e-07 , & + 1.12880e-07 ,1.13295e-07 ,1.13215e-07 ,1.13505e-07 ,1.13665e-07 , & + 1.13870e-07 ,1.14025e-07 ,1.14325e-07 ,1.14495e-07 ,1.14605e-07 , & + 1.14905e-07 /) + totplnkderiv(1:50, 3) = (/ & + 4.27040e-08 ,4.35430e-08 ,4.43810e-08 ,4.52210e-08 ,4.60630e-08 , & + 4.69135e-08 ,4.77585e-08 ,4.86135e-08 ,4.94585e-08 ,5.03230e-08 , & + 5.11740e-08 ,5.20250e-08 ,5.28940e-08 ,5.37465e-08 ,5.46175e-08 , & + 5.54700e-08 ,5.63430e-08 ,5.72085e-08 ,5.80735e-08 ,5.89430e-08 , & + 5.98015e-08 ,6.06680e-08 ,6.15380e-08 ,6.24130e-08 ,6.32755e-08 , & + 6.41340e-08 ,6.50060e-08 ,6.58690e-08 ,6.67315e-08 ,6.76025e-08 , & + 6.84585e-08 ,6.93205e-08 ,7.01845e-08 ,7.10485e-08 ,7.19160e-08 , & + 7.27695e-08 ,7.36145e-08 ,7.44840e-08 ,7.53405e-08 ,7.61770e-08 , & + 7.70295e-08 ,7.78745e-08 ,7.87350e-08 ,7.95740e-08 ,8.04150e-08 , & + 8.12565e-08 ,8.20885e-08 ,8.29455e-08 ,8.37830e-08 ,8.46035e-08 /) + totplnkderiv(51:100, 3) = (/ & + 8.54315e-08 ,8.62770e-08 ,8.70975e-08 ,8.79140e-08 ,8.87190e-08 , & + 8.95625e-08 ,9.03625e-08 ,9.11795e-08 ,9.19930e-08 ,9.27685e-08 , & + 9.36095e-08 ,9.43785e-08 ,9.52375e-08 ,9.59905e-08 ,9.67680e-08 , & + 9.75840e-08 ,9.83755e-08 ,9.91710e-08 ,9.99445e-08 ,1.00706e-07 , & + 1.01477e-07 ,1.02255e-07 ,1.03021e-07 ,1.03776e-07 ,1.04544e-07 , & + 1.05338e-07 ,1.06082e-07 ,1.06843e-07 ,1.07543e-07 ,1.08298e-07 , & + 1.09103e-07 ,1.09812e-07 ,1.10536e-07 ,1.11268e-07 ,1.12027e-07 , & + 1.12727e-07 ,1.13464e-07 ,1.14183e-07 ,1.15037e-07 ,1.15615e-07 , & + 1.16329e-07 ,1.17057e-07 ,1.17734e-07 ,1.18448e-07 ,1.19149e-07 , & + 1.19835e-07 ,1.20512e-07 ,1.21127e-07 ,1.21895e-07 ,1.22581e-07 /) + totplnkderiv(101:150, 3) = (/ & + 1.23227e-07 ,1.23928e-07 ,1.24560e-07 ,1.25220e-07 ,1.25895e-07 , & + 1.26565e-07 ,1.27125e-07 ,1.27855e-07 ,1.28490e-07 ,1.29195e-07 , & + 1.29790e-07 ,1.30470e-07 ,1.31070e-07 ,1.31690e-07 ,1.32375e-07 , & + 1.32960e-07 ,1.33570e-07 ,1.34230e-07 ,1.34840e-07 ,1.35315e-07 , & + 1.35990e-07 ,1.36555e-07 ,1.37265e-07 ,1.37945e-07 ,1.38425e-07 , & + 1.38950e-07 ,1.39640e-07 ,1.40220e-07 ,1.40775e-07 ,1.41400e-07 , & + 1.42020e-07 ,1.42500e-07 ,1.43085e-07 ,1.43680e-07 ,1.44255e-07 , & + 1.44855e-07 ,1.45385e-07 ,1.45890e-07 ,1.46430e-07 ,1.46920e-07 , & + 1.47715e-07 ,1.48090e-07 ,1.48695e-07 ,1.49165e-07 ,1.49715e-07 , & + 1.50130e-07 ,1.50720e-07 ,1.51330e-07 ,1.51725e-07 ,1.52350e-07 /) + totplnkderiv(151:181, 3) = (/ & + 1.52965e-07 ,1.53305e-07 ,1.53915e-07 ,1.54280e-07 ,1.54950e-07 , & + 1.55370e-07 ,1.55850e-07 ,1.56260e-07 ,1.56825e-07 ,1.57470e-07 , & + 1.57760e-07 ,1.58295e-07 ,1.58780e-07 ,1.59470e-07 ,1.59940e-07 , & + 1.60325e-07 ,1.60825e-07 ,1.61100e-07 ,1.61605e-07 ,1.62045e-07 , & + 1.62670e-07 ,1.63020e-07 ,1.63625e-07 ,1.63900e-07 ,1.64420e-07 , & + 1.64705e-07 ,1.65430e-07 ,1.65610e-07 ,1.66220e-07 ,1.66585e-07 , & + 1.66965e-07 /) + totplnkderiv(1:50, 4) = (/ & + 3.32829e-08 ,3.41160e-08 ,3.49626e-08 ,3.58068e-08 ,3.66765e-08 , & + 3.75320e-08 ,3.84095e-08 ,3.92920e-08 ,4.01830e-08 ,4.10715e-08 , & + 4.19735e-08 ,4.28835e-08 ,4.37915e-08 ,4.47205e-08 ,4.56410e-08 , & + 4.65770e-08 ,4.75090e-08 ,4.84530e-08 ,4.93975e-08 ,5.03470e-08 , & + 5.13000e-08 ,5.22560e-08 ,5.32310e-08 ,5.41865e-08 ,5.51655e-08 , & + 5.61590e-08 ,5.71120e-08 ,5.81075e-08 ,5.91060e-08 ,6.00895e-08 , & + 6.10750e-08 ,6.20740e-08 ,6.30790e-08 ,6.40765e-08 ,6.50940e-08 , & + 6.60895e-08 ,6.71230e-08 ,6.81200e-08 ,6.91260e-08 ,7.01485e-08 , & + 7.11625e-08 ,7.21870e-08 ,7.32010e-08 ,7.42080e-08 ,7.52285e-08 , & + 7.62930e-08 ,7.73040e-08 ,7.83185e-08 ,7.93410e-08 ,8.03560e-08 /) + totplnkderiv(51:100, 4) = (/ & + 8.14115e-08 ,8.24200e-08 ,8.34555e-08 ,8.45100e-08 ,8.55265e-08 , & + 8.65205e-08 ,8.75615e-08 ,8.85870e-08 ,8.96175e-08 ,9.07015e-08 , & + 9.16475e-08 ,9.27525e-08 ,9.37055e-08 ,9.47375e-08 ,9.57995e-08 , & + 9.67635e-08 ,9.77980e-08 ,9.87735e-08 ,9.98485e-08 ,1.00904e-07 , & + 1.01900e-07 ,1.02876e-07 ,1.03905e-07 ,1.04964e-07 ,1.05956e-07 , & + 1.06870e-07 ,1.07952e-07 ,1.08944e-07 ,1.10003e-07 ,1.10965e-07 , & + 1.11952e-07 ,1.12927e-07 ,1.13951e-07 ,1.14942e-07 ,1.15920e-07 , & + 1.16968e-07 ,1.17877e-07 ,1.18930e-07 ,1.19862e-07 ,1.20817e-07 , & + 1.21817e-07 ,1.22791e-07 ,1.23727e-07 ,1.24751e-07 ,1.25697e-07 , & + 1.26634e-07 ,1.27593e-07 ,1.28585e-07 ,1.29484e-07 ,1.30485e-07 /) + totplnkderiv(101:150, 4) = (/ & + 1.31363e-07 ,1.32391e-07 ,1.33228e-07 ,1.34155e-07 ,1.35160e-07 , & + 1.36092e-07 ,1.37070e-07 ,1.37966e-07 ,1.38865e-07 ,1.39740e-07 , & + 1.40770e-07 ,1.41620e-07 ,1.42605e-07 ,1.43465e-07 ,1.44240e-07 , & + 1.45305e-07 ,1.46220e-07 ,1.47070e-07 ,1.47935e-07 ,1.48890e-07 , & + 1.49905e-07 ,1.50640e-07 ,1.51435e-07 ,1.52335e-07 ,1.53235e-07 , & + 1.54045e-07 ,1.54895e-07 ,1.55785e-07 ,1.56870e-07 ,1.57360e-07 , & + 1.58395e-07 ,1.59185e-07 ,1.60060e-07 ,1.60955e-07 ,1.61770e-07 , & + 1.62445e-07 ,1.63415e-07 ,1.64170e-07 ,1.65125e-07 ,1.65995e-07 , & + 1.66545e-07 ,1.67580e-07 ,1.68295e-07 ,1.69130e-07 ,1.69935e-07 , & + 1.70800e-07 ,1.71610e-07 ,1.72365e-07 ,1.73215e-07 ,1.73770e-07 /) + totplnkderiv(151:181, 4) = (/ & + 1.74590e-07 ,1.75525e-07 ,1.76095e-07 ,1.77125e-07 ,1.77745e-07 , & + 1.78580e-07 ,1.79315e-07 ,1.80045e-07 ,1.80695e-07 ,1.81580e-07 , & + 1.82360e-07 ,1.83205e-07 ,1.84055e-07 ,1.84315e-07 ,1.85225e-07 , & + 1.85865e-07 ,1.86660e-07 ,1.87445e-07 ,1.88350e-07 ,1.88930e-07 , & + 1.89420e-07 ,1.90275e-07 ,1.90630e-07 ,1.91650e-07 ,1.92485e-07 , & + 1.93285e-07 ,1.93695e-07 ,1.94595e-07 ,1.94895e-07 ,1.95960e-07 , & + 1.96525e-07 /) + totplnkderiv(1:50, 5) = (/ & + 2.41948e-08 ,2.49273e-08 ,2.56705e-08 ,2.64263e-08 ,2.71899e-08 , & + 2.79687e-08 ,2.87531e-08 ,2.95520e-08 ,3.03567e-08 ,3.11763e-08 , & + 3.20014e-08 ,3.28390e-08 ,3.36865e-08 ,3.45395e-08 ,3.54083e-08 , & + 3.62810e-08 ,3.71705e-08 ,3.80585e-08 ,3.89650e-08 ,3.98750e-08 , & + 4.07955e-08 ,4.17255e-08 ,4.26635e-08 ,4.36095e-08 ,4.45605e-08 , & + 4.55190e-08 ,4.64910e-08 ,4.74670e-08 ,4.84480e-08 ,4.94430e-08 , & + 5.04460e-08 ,5.14440e-08 ,5.24500e-08 ,5.34835e-08 ,5.44965e-08 , & + 5.55325e-08 ,5.65650e-08 ,5.76050e-08 ,5.86615e-08 ,5.97175e-08 , & + 6.07750e-08 ,6.18400e-08 ,6.29095e-08 ,6.39950e-08 ,6.50665e-08 , & + 6.61405e-08 ,6.72290e-08 ,6.82800e-08 ,6.94445e-08 ,7.05460e-08 /) + totplnkderiv(51:100, 5) = (/ & + 7.16400e-08 ,7.27475e-08 ,7.38790e-08 ,7.49845e-08 ,7.61270e-08 , & + 7.72375e-08 ,7.83770e-08 ,7.95045e-08 ,8.06315e-08 ,8.17715e-08 , & + 8.29275e-08 ,8.40555e-08 ,8.52110e-08 ,8.63565e-08 ,8.75045e-08 , & + 8.86735e-08 ,8.98150e-08 ,9.09970e-08 ,9.21295e-08 ,9.32730e-08 , & + 9.44605e-08 ,9.56170e-08 ,9.67885e-08 ,9.79275e-08 ,9.91190e-08 , & + 1.00278e-07 ,1.01436e-07 ,1.02625e-07 ,1.03792e-07 ,1.04989e-07 , & + 1.06111e-07 ,1.07320e-07 ,1.08505e-07 ,1.09626e-07 ,1.10812e-07 , & + 1.11948e-07 ,1.13162e-07 ,1.14289e-07 ,1.15474e-07 ,1.16661e-07 , & + 1.17827e-07 ,1.19023e-07 ,1.20167e-07 ,1.21356e-07 ,1.22499e-07 , & + 1.23653e-07 ,1.24876e-07 ,1.25983e-07 ,1.27175e-07 ,1.28325e-07 /) + totplnkderiv(101:150, 5) = (/ & + 1.29517e-07 ,1.30685e-07 ,1.31840e-07 ,1.33013e-07 ,1.34160e-07 , & + 1.35297e-07 ,1.36461e-07 ,1.37630e-07 ,1.38771e-07 ,1.39913e-07 , & + 1.41053e-07 ,1.42218e-07 ,1.43345e-07 ,1.44460e-07 ,1.45692e-07 , & + 1.46697e-07 ,1.47905e-07 ,1.49010e-07 ,1.50210e-07 ,1.51285e-07 , & + 1.52380e-07 ,1.53555e-07 ,1.54655e-07 ,1.55805e-07 ,1.56850e-07 , & + 1.58055e-07 ,1.59115e-07 ,1.60185e-07 ,1.61255e-07 ,1.62465e-07 , & + 1.63575e-07 ,1.64675e-07 ,1.65760e-07 ,1.66765e-07 ,1.67945e-07 , & + 1.69070e-07 ,1.70045e-07 ,1.71145e-07 ,1.72260e-07 ,1.73290e-07 , & + 1.74470e-07 ,1.75490e-07 ,1.76515e-07 ,1.77555e-07 ,1.78660e-07 , & + 1.79670e-07 ,1.80705e-07 ,1.81895e-07 ,1.82745e-07 ,1.83950e-07 /) + totplnkderiv(151:181, 5) = (/ & + 1.84955e-07 ,1.85940e-07 ,1.87080e-07 ,1.88010e-07 ,1.89145e-07 , & + 1.90130e-07 ,1.91110e-07 ,1.92130e-07 ,1.93205e-07 ,1.94230e-07 , & + 1.95045e-07 ,1.96070e-07 ,1.97155e-07 ,1.98210e-07 ,1.99080e-07 , & + 2.00280e-07 ,2.01135e-07 ,2.02150e-07 ,2.03110e-07 ,2.04135e-07 , & + 2.05110e-07 ,2.06055e-07 ,2.07120e-07 ,2.08075e-07 ,2.08975e-07 , & + 2.09950e-07 ,2.10870e-07 ,2.11830e-07 ,2.12960e-07 ,2.13725e-07 , & + 2.14765e-07 /) + totplnkderiv(1:50, 6) = (/ & + 1.36567e-08 ,1.41766e-08 ,1.47079e-08 ,1.52499e-08 ,1.58075e-08 , & + 1.63727e-08 ,1.69528e-08 ,1.75429e-08 ,1.81477e-08 ,1.87631e-08 , & + 1.93907e-08 ,2.00297e-08 ,2.06808e-08 ,2.13432e-08 ,2.20183e-08 , & + 2.27076e-08 ,2.34064e-08 ,2.41181e-08 ,2.48400e-08 ,2.55750e-08 , & + 2.63231e-08 ,2.70790e-08 ,2.78502e-08 ,2.86326e-08 ,2.94259e-08 , & + 3.02287e-08 ,3.10451e-08 ,3.18752e-08 ,3.27108e-08 ,3.35612e-08 , & + 3.44198e-08 ,3.52930e-08 ,3.61785e-08 ,3.70690e-08 ,3.79725e-08 , & + 3.88845e-08 ,3.98120e-08 ,4.07505e-08 ,4.16965e-08 ,4.26515e-08 , & + 4.36190e-08 ,4.45925e-08 ,4.55760e-08 ,4.65735e-08 ,4.75835e-08 , & + 4.85970e-08 ,4.96255e-08 ,5.06975e-08 ,5.16950e-08 ,5.27530e-08 /) + totplnkderiv(51:100, 6) = (/ & + 5.38130e-08 ,5.48860e-08 ,5.59715e-08 ,5.70465e-08 ,5.81385e-08 , & + 5.92525e-08 ,6.03565e-08 ,6.14815e-08 ,6.26175e-08 ,6.37475e-08 , & + 6.48855e-08 ,6.60340e-08 ,6.71980e-08 ,6.83645e-08 ,6.95430e-08 , & + 7.07145e-08 ,7.19015e-08 ,7.30995e-08 ,7.43140e-08 ,7.55095e-08 , & + 7.67115e-08 ,7.79485e-08 ,7.91735e-08 ,8.03925e-08 ,8.16385e-08 , & + 8.28775e-08 ,8.41235e-08 ,8.53775e-08 ,8.66405e-08 ,8.78940e-08 , & + 8.91805e-08 ,9.04515e-08 ,9.17290e-08 ,9.30230e-08 ,9.43145e-08 , & + 9.56200e-08 ,9.69160e-08 ,9.82140e-08 ,9.95285e-08 ,1.00829e-07 , & + 1.02145e-07 ,1.03478e-07 ,1.04787e-07 ,1.06095e-07 ,1.07439e-07 , & + 1.08785e-07 ,1.10078e-07 ,1.11466e-07 ,1.12795e-07 ,1.14133e-07 /) + totplnkderiv(101:150, 6) = (/ & + 1.15479e-07 ,1.16825e-07 ,1.18191e-07 ,1.19540e-07 ,1.20908e-07 , & + 1.22257e-07 ,1.23634e-07 ,1.24992e-07 ,1.26345e-07 ,1.27740e-07 , & + 1.29098e-07 ,1.30447e-07 ,1.31831e-07 ,1.33250e-07 ,1.34591e-07 , & + 1.36011e-07 ,1.37315e-07 ,1.38721e-07 ,1.40103e-07 ,1.41504e-07 , & + 1.42882e-07 ,1.44259e-07 ,1.45674e-07 ,1.46997e-07 ,1.48412e-07 , & + 1.49794e-07 ,1.51167e-07 ,1.52577e-07 ,1.53941e-07 ,1.55369e-07 , & + 1.56725e-07 ,1.58125e-07 ,1.59460e-07 ,1.60895e-07 ,1.62260e-07 , & + 1.63610e-07 ,1.65085e-07 ,1.66410e-07 ,1.67805e-07 ,1.69185e-07 , & + 1.70570e-07 ,1.71915e-07 ,1.73375e-07 ,1.74775e-07 ,1.76090e-07 , & + 1.77485e-07 ,1.78905e-07 ,1.80190e-07 ,1.81610e-07 ,1.82960e-07 /) + totplnkderiv(151:181, 6) = (/ & + 1.84330e-07 ,1.85750e-07 ,1.87060e-07 ,1.88470e-07 ,1.89835e-07 , & + 1.91250e-07 ,1.92565e-07 ,1.93925e-07 ,1.95220e-07 ,1.96620e-07 , & + 1.98095e-07 ,1.99330e-07 ,2.00680e-07 ,2.02090e-07 ,2.03360e-07 , & + 2.04775e-07 ,2.06080e-07 ,2.07440e-07 ,2.08820e-07 ,2.10095e-07 , & + 2.11445e-07 ,2.12785e-07 ,2.14050e-07 ,2.15375e-07 ,2.16825e-07 , & + 2.18080e-07 ,2.19345e-07 ,2.20710e-07 ,2.21980e-07 ,2.23425e-07 , & + 2.24645e-07 /) + totplnkderiv(1:50, 7) = (/ & + 7.22270e-09 ,7.55350e-09 ,7.89480e-09 ,8.24725e-09 ,8.60780e-09 , & + 8.98215e-09 ,9.36430e-09 ,9.76035e-09 ,1.01652e-08 ,1.05816e-08 , & + 1.10081e-08 ,1.14480e-08 ,1.18981e-08 ,1.23600e-08 ,1.28337e-08 , & + 1.33172e-08 ,1.38139e-08 ,1.43208e-08 ,1.48413e-08 ,1.53702e-08 , & + 1.59142e-08 ,1.64704e-08 ,1.70354e-08 ,1.76178e-08 ,1.82065e-08 , & + 1.88083e-08 ,1.94237e-08 ,2.00528e-08 ,2.06913e-08 ,2.13413e-08 , & + 2.20058e-08 ,2.26814e-08 ,2.33686e-08 ,2.40729e-08 ,2.47812e-08 , & + 2.55099e-08 ,2.62449e-08 ,2.69966e-08 ,2.77569e-08 ,2.85269e-08 , & + 2.93144e-08 ,3.01108e-08 ,3.09243e-08 ,3.17433e-08 ,3.25756e-08 , & + 3.34262e-08 ,3.42738e-08 ,3.51480e-08 ,3.60285e-08 ,3.69160e-08 /) + totplnkderiv(51:100, 7) = (/ & + 3.78235e-08 ,3.87390e-08 ,3.96635e-08 ,4.06095e-08 ,4.15600e-08 , & + 4.25180e-08 ,4.34895e-08 ,4.44800e-08 ,4.54715e-08 ,4.64750e-08 , & + 4.74905e-08 ,4.85210e-08 ,4.95685e-08 ,5.06135e-08 ,5.16725e-08 , & + 5.27480e-08 ,5.38265e-08 ,5.49170e-08 ,5.60120e-08 ,5.71275e-08 , & + 5.82610e-08 ,5.93775e-08 ,6.05245e-08 ,6.17025e-08 ,6.28355e-08 , & + 6.40135e-08 ,6.52015e-08 ,6.63865e-08 ,6.75790e-08 ,6.88120e-08 , & + 7.00070e-08 ,7.12335e-08 ,7.24720e-08 ,7.37340e-08 ,7.49775e-08 , & + 7.62415e-08 ,7.75185e-08 ,7.87915e-08 ,8.00875e-08 ,8.13630e-08 , & + 8.26710e-08 ,8.39645e-08 ,8.53060e-08 ,8.66305e-08 ,8.79915e-08 , & + 8.93080e-08 ,9.06560e-08 ,9.19860e-08 ,9.33550e-08 ,9.47305e-08 /) + totplnkderiv(101:150, 7) = (/ & + 9.61180e-08 ,9.74500e-08 ,9.88850e-08 ,1.00263e-07 ,1.01688e-07 , & + 1.03105e-07 ,1.04489e-07 ,1.05906e-07 ,1.07345e-07 ,1.08771e-07 , & + 1.10220e-07 ,1.11713e-07 ,1.13098e-07 ,1.14515e-07 ,1.16019e-07 , & + 1.17479e-07 ,1.18969e-07 ,1.20412e-07 ,1.21852e-07 ,1.23387e-07 , & + 1.24851e-07 ,1.26319e-07 ,1.27811e-07 ,1.29396e-07 ,1.30901e-07 , & + 1.32358e-07 ,1.33900e-07 ,1.35405e-07 ,1.36931e-07 ,1.38443e-07 , & + 1.39985e-07 ,1.41481e-07 ,1.43072e-07 ,1.44587e-07 ,1.46133e-07 , & + 1.47698e-07 ,1.49203e-07 ,1.50712e-07 ,1.52363e-07 ,1.53795e-07 , & + 1.55383e-07 ,1.56961e-07 ,1.58498e-07 ,1.60117e-07 ,1.61745e-07 , & + 1.63190e-07 ,1.64790e-07 ,1.66370e-07 ,1.67975e-07 ,1.69555e-07 /) + totplnkderiv(151:181, 7) = (/ & + 1.71060e-07 ,1.72635e-07 ,1.74345e-07 ,1.75925e-07 ,1.77395e-07 , & + 1.78960e-07 ,1.80620e-07 ,1.82180e-07 ,1.83840e-07 ,1.85340e-07 , & + 1.86940e-07 ,1.88550e-07 ,1.90095e-07 ,1.91670e-07 ,1.93385e-07 , & + 1.94895e-07 ,1.96500e-07 ,1.98090e-07 ,1.99585e-07 ,2.01280e-07 , & + 2.02950e-07 ,2.04455e-07 ,2.06075e-07 ,2.07635e-07 ,2.09095e-07 , & + 2.10865e-07 ,2.12575e-07 ,2.14050e-07 ,2.15630e-07 ,2.17060e-07 , & + 2.18715e-07 /) + totplnkderiv(1:50, 8) = (/ & + 4.26397e-09 ,4.48470e-09 ,4.71299e-09 ,4.94968e-09 ,5.19542e-09 , & + 5.44847e-09 ,5.71195e-09 ,5.98305e-09 ,6.26215e-09 ,6.55290e-09 , & + 6.85190e-09 ,7.15950e-09 ,7.47745e-09 ,7.80525e-09 ,8.14190e-09 , & + 8.48915e-09 ,8.84680e-09 ,9.21305e-09 ,9.59105e-09 ,9.98130e-09 , & + 1.03781e-08 ,1.07863e-08 ,1.12094e-08 ,1.16371e-08 ,1.20802e-08 , & + 1.25327e-08 ,1.29958e-08 ,1.34709e-08 ,1.39592e-08 ,1.44568e-08 , & + 1.49662e-08 ,1.54828e-08 ,1.60186e-08 ,1.65612e-08 ,1.71181e-08 , & + 1.76822e-08 ,1.82591e-08 ,1.88487e-08 ,1.94520e-08 ,2.00691e-08 , & + 2.06955e-08 ,2.13353e-08 ,2.19819e-08 ,2.26479e-08 ,2.33234e-08 , & + 2.40058e-08 ,2.47135e-08 ,2.54203e-08 ,2.61414e-08 ,2.68778e-08 /) + totplnkderiv(51:100, 8) = (/ & + 2.76265e-08 ,2.83825e-08 ,2.91632e-08 ,2.99398e-08 ,3.07389e-08 , & + 3.15444e-08 ,3.23686e-08 ,3.31994e-08 ,3.40487e-08 ,3.49020e-08 , & + 3.57715e-08 ,3.66515e-08 ,3.75465e-08 ,3.84520e-08 ,3.93675e-08 , & + 4.02985e-08 ,4.12415e-08 ,4.21965e-08 ,4.31630e-08 ,4.41360e-08 , & + 4.51220e-08 ,4.61235e-08 ,4.71440e-08 ,4.81515e-08 ,4.91905e-08 , & + 5.02395e-08 ,5.12885e-08 ,5.23735e-08 ,5.34460e-08 ,5.45245e-08 , & + 5.56375e-08 ,5.67540e-08 ,5.78780e-08 ,5.90065e-08 ,6.01520e-08 , & + 6.13000e-08 ,6.24720e-08 ,6.36530e-08 ,6.48500e-08 ,6.60500e-08 , & + 6.72435e-08 ,6.84735e-08 ,6.97025e-08 ,7.09530e-08 ,7.21695e-08 , & + 7.34270e-08 ,7.47295e-08 ,7.59915e-08 ,7.72685e-08 ,7.85925e-08 /) + totplnkderiv(101:150, 8) = (/ & + 7.98855e-08 ,8.12205e-08 ,8.25120e-08 ,8.38565e-08 ,8.52005e-08 , & + 8.65570e-08 ,8.79075e-08 ,8.92920e-08 ,9.06535e-08 ,9.20455e-08 , & + 9.34230e-08 ,9.48355e-08 ,9.62720e-08 ,9.76890e-08 ,9.90755e-08 , & + 1.00528e-07 ,1.01982e-07 ,1.03436e-07 ,1.04919e-07 ,1.06368e-07 , & + 1.07811e-07 ,1.09326e-07 ,1.10836e-07 ,1.12286e-07 ,1.13803e-07 , & + 1.15326e-07 ,1.16809e-07 ,1.18348e-07 ,1.19876e-07 ,1.21413e-07 , & + 1.22922e-07 ,1.24524e-07 ,1.26049e-07 ,1.27573e-07 ,1.29155e-07 , & + 1.30708e-07 ,1.32327e-07 ,1.33958e-07 ,1.35480e-07 ,1.37081e-07 , & + 1.38716e-07 ,1.40326e-07 ,1.41872e-07 ,1.43468e-07 ,1.45092e-07 , & + 1.46806e-07 ,1.48329e-07 ,1.49922e-07 ,1.51668e-07 ,1.53241e-07 /) + totplnkderiv(151:181, 8) = (/ & + 1.54996e-07 ,1.56561e-07 ,1.58197e-07 ,1.59884e-07 ,1.61576e-07 , & + 1.63200e-07 ,1.64885e-07 ,1.66630e-07 ,1.68275e-07 ,1.69935e-07 , & + 1.71650e-07 ,1.73245e-07 ,1.75045e-07 ,1.76710e-07 ,1.78330e-07 , & + 1.79995e-07 ,1.81735e-07 ,1.83470e-07 ,1.85200e-07 ,1.86890e-07 , & + 1.88595e-07 ,1.90300e-07 ,1.91995e-07 ,1.93715e-07 ,1.95495e-07 , & + 1.97130e-07 ,1.98795e-07 ,2.00680e-07 ,2.02365e-07 ,2.04090e-07 , & + 2.05830e-07 /) + totplnkderiv(1:50, 9) = (/ & + 1.85410e-09 ,1.96515e-09 ,2.08117e-09 ,2.20227e-09 ,2.32861e-09 , & + 2.46066e-09 ,2.59812e-09 ,2.74153e-09 ,2.89058e-09 ,3.04567e-09 , & + 3.20674e-09 ,3.37442e-09 ,3.54854e-09 ,3.72892e-09 ,3.91630e-09 , & + 4.11013e-09 ,4.31150e-09 ,4.52011e-09 ,4.73541e-09 ,4.95870e-09 , & + 5.18913e-09 ,5.42752e-09 ,5.67340e-09 ,5.92810e-09 ,6.18995e-09 , & + 6.46055e-09 ,6.73905e-09 ,7.02620e-09 ,7.32260e-09 ,7.62700e-09 , & + 7.94050e-09 ,8.26370e-09 ,8.59515e-09 ,8.93570e-09 ,9.28535e-09 , & + 9.64575e-09 ,1.00154e-08 ,1.03944e-08 ,1.07839e-08 ,1.11832e-08 , & + 1.15909e-08 ,1.20085e-08 ,1.24399e-08 ,1.28792e-08 ,1.33280e-08 , & + 1.37892e-08 ,1.42573e-08 ,1.47408e-08 ,1.52345e-08 ,1.57371e-08 /) + totplnkderiv(51:100, 9) = (/ & + 1.62496e-08 ,1.67756e-08 ,1.73101e-08 ,1.78596e-08 ,1.84161e-08 , & + 1.89869e-08 ,1.95681e-08 ,2.01632e-08 ,2.07626e-08 ,2.13800e-08 , & + 2.20064e-08 ,2.26453e-08 ,2.32970e-08 ,2.39595e-08 ,2.46340e-08 , & + 2.53152e-08 ,2.60158e-08 ,2.67235e-08 ,2.74471e-08 ,2.81776e-08 , & + 2.89233e-08 ,2.96822e-08 ,3.04488e-08 ,3.12298e-08 ,3.20273e-08 , & + 3.28304e-08 ,3.36455e-08 ,3.44765e-08 ,3.53195e-08 ,3.61705e-08 , & + 3.70385e-08 ,3.79155e-08 ,3.88065e-08 ,3.97055e-08 ,4.06210e-08 , & + 4.15490e-08 ,4.24825e-08 ,4.34355e-08 ,4.43920e-08 ,4.53705e-08 , & + 4.63560e-08 ,4.73565e-08 ,4.83655e-08 ,4.93815e-08 ,5.04180e-08 , & + 5.14655e-08 ,5.25175e-08 ,5.35865e-08 ,5.46720e-08 ,5.57670e-08 /) + totplnkderiv(101:150, 9) = (/ & + 5.68640e-08 ,5.79825e-08 ,5.91140e-08 ,6.02515e-08 ,6.13985e-08 , & + 6.25525e-08 ,6.37420e-08 ,6.49220e-08 ,6.61145e-08 ,6.73185e-08 , & + 6.85520e-08 ,6.97760e-08 ,7.10050e-08 ,7.22650e-08 ,7.35315e-08 , & + 7.48035e-08 ,7.60745e-08 ,7.73740e-08 ,7.86870e-08 ,7.99845e-08 , & + 8.13325e-08 ,8.26615e-08 ,8.40010e-08 ,8.53640e-08 ,8.67235e-08 , & + 8.80960e-08 ,8.95055e-08 ,9.08945e-08 ,9.23045e-08 ,9.37100e-08 , & + 9.51555e-08 ,9.65630e-08 ,9.80235e-08 ,9.94920e-08 ,1.00966e-07 , & + 1.02434e-07 ,1.03898e-07 ,1.05386e-07 ,1.06905e-07 ,1.08418e-07 , & + 1.09926e-07 ,1.11454e-07 ,1.13010e-07 ,1.14546e-07 ,1.16106e-07 , & + 1.17652e-07 ,1.19264e-07 ,1.20817e-07 ,1.22395e-07 ,1.24024e-07 /) + totplnkderiv(151:181, 9) = (/ & + 1.25585e-07 ,1.27213e-07 ,1.28817e-07 ,1.30472e-07 ,1.32088e-07 , & + 1.33752e-07 ,1.35367e-07 ,1.37018e-07 ,1.38698e-07 ,1.40394e-07 , & + 1.42026e-07 ,1.43796e-07 ,1.45438e-07 ,1.47175e-07 ,1.48866e-07 , & + 1.50576e-07 ,1.52281e-07 ,1.54018e-07 ,1.55796e-07 ,1.57515e-07 , & + 1.59225e-07 ,1.60989e-07 ,1.62754e-07 ,1.64532e-07 ,1.66285e-07 , & + 1.68070e-07 ,1.69870e-07 ,1.71625e-07 ,1.73440e-07 ,1.75275e-07 , & + 1.77040e-07 /) + totplnkderiv(1:50,10) = (/ & + 7.14917e-10 ,7.64833e-10 ,8.17460e-10 ,8.72980e-10 ,9.31380e-10 , & + 9.92940e-10 ,1.05746e-09 ,1.12555e-09 ,1.19684e-09 ,1.27162e-09 , & + 1.35001e-09 ,1.43229e-09 ,1.51815e-09 ,1.60831e-09 ,1.70271e-09 , & + 1.80088e-09 ,1.90365e-09 ,2.01075e-09 ,2.12261e-09 ,2.23924e-09 , & + 2.36057e-09 ,2.48681e-09 ,2.61814e-09 ,2.75506e-09 ,2.89692e-09 , & + 3.04423e-09 ,3.19758e-09 ,3.35681e-09 ,3.52113e-09 ,3.69280e-09 , & + 3.86919e-09 ,4.05205e-09 ,4.24184e-09 ,4.43877e-09 ,4.64134e-09 , & + 4.85088e-09 ,5.06670e-09 ,5.29143e-09 ,5.52205e-09 ,5.75980e-09 , & + 6.00550e-09 ,6.25840e-09 ,6.51855e-09 ,6.78800e-09 ,7.06435e-09 , & + 7.34935e-09 ,7.64220e-09 ,7.94470e-09 ,8.25340e-09 ,8.57030e-09 /) + totplnkderiv(51:100,10) = (/ & + 8.89680e-09 ,9.23255e-09 ,9.57770e-09 ,9.93045e-09 ,1.02932e-08 , & + 1.06649e-08 ,1.10443e-08 ,1.14348e-08 ,1.18350e-08 ,1.22463e-08 , & + 1.26679e-08 ,1.30949e-08 ,1.35358e-08 ,1.39824e-08 ,1.44425e-08 , & + 1.49126e-08 ,1.53884e-08 ,1.58826e-08 ,1.63808e-08 ,1.68974e-08 , & + 1.74159e-08 ,1.79447e-08 ,1.84886e-08 ,1.90456e-08 ,1.96124e-08 , & + 2.01863e-08 ,2.07737e-08 ,2.13720e-08 ,2.19837e-08 ,2.26044e-08 , & + 2.32396e-08 ,2.38856e-08 ,2.45344e-08 ,2.52055e-08 ,2.58791e-08 , & + 2.65706e-08 ,2.72758e-08 ,2.79852e-08 ,2.87201e-08 ,2.94518e-08 , & + 3.02063e-08 ,3.09651e-08 ,3.17357e-08 ,3.25235e-08 ,3.33215e-08 , & + 3.41285e-08 ,3.49485e-08 ,3.57925e-08 ,3.66330e-08 ,3.74765e-08 /) + totplnkderiv(101:150,10) = (/ & + 3.83675e-08 ,3.92390e-08 ,4.01330e-08 ,4.10340e-08 ,4.19585e-08 , & + 4.28815e-08 ,4.38210e-08 ,4.47770e-08 ,4.57575e-08 ,4.67325e-08 , & + 4.77170e-08 ,4.87205e-08 ,4.97410e-08 ,5.07620e-08 ,5.18180e-08 , & + 5.28540e-08 ,5.39260e-08 ,5.50035e-08 ,5.60885e-08 ,5.71900e-08 , & + 5.82940e-08 ,5.94380e-08 ,6.05690e-08 ,6.17185e-08 ,6.28860e-08 , & + 6.40670e-08 ,6.52300e-08 ,6.64225e-08 ,6.76485e-08 ,6.88715e-08 , & + 7.00750e-08 ,7.13760e-08 ,7.25910e-08 ,7.38860e-08 ,7.51290e-08 , & + 7.64420e-08 ,7.77550e-08 ,7.90725e-08 ,8.03825e-08 ,8.17330e-08 , & + 8.30810e-08 ,8.44330e-08 ,8.57720e-08 ,8.72115e-08 ,8.85800e-08 , & + 8.99945e-08 ,9.13905e-08 ,9.28345e-08 ,9.42665e-08 ,9.56765e-08 /) + totplnkderiv(151:181,10) = (/ & + 9.72000e-08 ,9.86780e-08 ,1.00105e-07 ,1.01616e-07 ,1.03078e-07 , & + 1.04610e-07 ,1.06154e-07 ,1.07639e-07 ,1.09242e-07 ,1.10804e-07 , & + 1.12384e-07 ,1.13871e-07 ,1.15478e-07 ,1.17066e-07 ,1.18703e-07 , & + 1.20294e-07 ,1.21930e-07 ,1.23543e-07 ,1.25169e-07 ,1.26806e-07 , & + 1.28503e-07 ,1.30233e-07 ,1.31834e-07 ,1.33596e-07 ,1.35283e-07 , & + 1.36947e-07 ,1.38594e-07 ,1.40362e-07 ,1.42131e-07 ,1.43823e-07 , & + 1.45592e-07 /) + totplnkderiv(1:50,11) = (/ & + 2.25919e-10 ,2.43810e-10 ,2.62866e-10 ,2.83125e-10 ,3.04676e-10 , & + 3.27536e-10 ,3.51796e-10 ,3.77498e-10 ,4.04714e-10 ,4.33528e-10 , & + 4.64000e-10 ,4.96185e-10 ,5.30165e-10 ,5.65999e-10 ,6.03749e-10 , & + 6.43579e-10 ,6.85479e-10 ,7.29517e-10 ,7.75810e-10 ,8.24440e-10 , & + 8.75520e-10 ,9.29065e-10 ,9.85175e-10 ,1.04405e-09 ,1.10562e-09 , & + 1.17005e-09 ,1.23742e-09 ,1.30780e-09 ,1.38141e-09 ,1.45809e-09 , & + 1.53825e-09 ,1.62177e-09 ,1.70884e-09 ,1.79942e-09 ,1.89390e-09 , & + 1.99205e-09 ,2.09429e-09 ,2.20030e-09 ,2.31077e-09 ,2.42510e-09 , & + 2.54410e-09 ,2.66754e-09 ,2.79529e-09 ,2.92777e-09 ,3.06498e-09 , & + 3.20691e-09 ,3.35450e-09 ,3.50653e-09 ,3.66427e-09 ,3.82723e-09 /) + totplnkderiv(51:100,11) = (/ & + 3.99549e-09 ,4.16911e-09 ,4.34892e-09 ,4.53415e-09 ,4.72504e-09 , & + 4.92197e-09 ,5.12525e-09 ,5.33485e-09 ,5.55085e-09 ,5.77275e-09 , & + 6.00105e-09 ,6.23650e-09 ,6.47855e-09 ,6.72735e-09 ,6.98325e-09 , & + 7.24695e-09 ,7.51730e-09 ,7.79480e-09 ,8.07975e-09 ,8.37170e-09 , & + 8.67195e-09 ,8.98050e-09 ,9.29575e-09 ,9.61950e-09 ,9.95150e-09 , & + 1.02912e-08 ,1.06397e-08 ,1.09964e-08 ,1.13611e-08 ,1.17348e-08 , & + 1.21158e-08 ,1.25072e-08 ,1.29079e-08 ,1.33159e-08 ,1.37342e-08 , & + 1.41599e-08 ,1.45966e-08 ,1.50438e-08 ,1.54964e-08 ,1.59605e-08 , & + 1.64337e-08 ,1.69189e-08 ,1.74134e-08 ,1.79136e-08 ,1.84272e-08 , & + 1.89502e-08 ,1.94845e-08 ,2.00248e-08 ,2.05788e-08 ,2.11455e-08 /) + totplnkderiv(101:150,11) = (/ & + 2.17159e-08 ,2.23036e-08 ,2.28983e-08 ,2.35033e-08 ,2.41204e-08 , & + 2.47485e-08 ,2.53860e-08 ,2.60331e-08 ,2.66891e-08 ,2.73644e-08 , & + 2.80440e-08 ,2.87361e-08 ,2.94412e-08 ,3.01560e-08 ,3.08805e-08 , & + 3.16195e-08 ,3.23690e-08 ,3.31285e-08 ,3.39015e-08 ,3.46820e-08 , & + 3.54770e-08 ,3.62805e-08 ,3.70960e-08 ,3.79295e-08 ,3.87715e-08 , & + 3.96185e-08 ,4.04860e-08 ,4.13600e-08 ,4.22500e-08 ,4.31490e-08 , & + 4.40610e-08 ,4.49810e-08 ,4.59205e-08 ,4.68650e-08 ,4.78260e-08 , & + 4.87970e-08 ,4.97790e-08 ,5.07645e-08 ,5.17730e-08 ,5.27960e-08 , & + 5.38285e-08 ,5.48650e-08 ,5.59205e-08 ,5.69960e-08 ,5.80690e-08 , & + 5.91570e-08 ,6.02640e-08 ,6.13750e-08 ,6.25015e-08 ,6.36475e-08 /) + totplnkderiv(151:181,11) = (/ & + 6.47950e-08 ,6.59510e-08 ,6.71345e-08 ,6.83175e-08 ,6.95250e-08 , & + 7.07325e-08 ,7.19490e-08 ,7.31880e-08 ,7.44315e-08 ,7.56880e-08 , & + 7.69500e-08 ,7.82495e-08 ,7.95330e-08 ,8.08450e-08 ,8.21535e-08 , & + 8.34860e-08 ,8.48330e-08 ,8.61795e-08 ,8.75480e-08 ,8.89235e-08 , & + 9.03060e-08 ,9.17045e-08 ,9.31140e-08 ,9.45240e-08 ,9.59720e-08 , & + 9.74140e-08 ,9.88825e-08 ,1.00347e-07 ,1.01825e-07 ,1.03305e-07 , & + 1.04826e-07 /) + totplnkderiv(1:50,12) = (/ & + 2.91689e-11 ,3.20300e-11 ,3.51272e-11 ,3.84803e-11 ,4.21014e-11 , & + 4.60107e-11 ,5.02265e-11 ,5.47685e-11 ,5.96564e-11 ,6.49111e-11 , & + 7.05522e-11 ,7.66060e-11 ,8.30974e-11 ,9.00441e-11 ,9.74820e-11 , & + 1.05435e-10 ,1.13925e-10 ,1.22981e-10 ,1.32640e-10 ,1.42933e-10 , & + 1.53882e-10 ,1.65527e-10 ,1.77903e-10 ,1.91054e-10 ,2.05001e-10 , & + 2.19779e-10 ,2.35448e-10 ,2.52042e-10 ,2.69565e-10 ,2.88128e-10 , & + 3.07714e-10 ,3.28370e-10 ,3.50238e-10 ,3.73235e-10 ,3.97433e-10 , & + 4.22964e-10 ,4.49822e-10 ,4.78042e-10 ,5.07721e-10 ,5.38915e-10 , & + 5.71610e-10 ,6.05916e-10 ,6.41896e-10 ,6.79600e-10 ,7.19110e-10 , & + 7.60455e-10 ,8.03625e-10 ,8.48870e-10 ,8.96080e-10 ,9.45490e-10 /) + totplnkderiv(51:100,12) = (/ & + 9.96930e-10 ,1.05071e-09 ,1.10679e-09 ,1.16521e-09 ,1.22617e-09 , & + 1.28945e-09 ,1.35554e-09 ,1.42427e-09 ,1.49574e-09 ,1.56984e-09 , & + 1.64695e-09 ,1.72715e-09 ,1.81034e-09 ,1.89656e-09 ,1.98613e-09 , & + 2.07898e-09 ,2.17515e-09 ,2.27498e-09 ,2.37826e-09 ,2.48517e-09 , & + 2.59566e-09 ,2.71004e-09 ,2.82834e-09 ,2.95078e-09 ,3.07686e-09 , & + 3.20739e-09 ,3.34232e-09 ,3.48162e-09 ,3.62515e-09 ,3.77337e-09 , & + 3.92614e-09 ,4.08317e-09 ,4.24567e-09 ,4.41272e-09 ,4.58524e-09 , & + 4.76245e-09 ,4.94450e-09 ,5.13235e-09 ,5.32535e-09 ,5.52415e-09 , & + 5.72770e-09 ,5.93815e-09 ,6.15315e-09 ,6.37525e-09 ,6.60175e-09 , & + 6.83485e-09 ,7.07490e-09 ,7.32060e-09 ,7.57225e-09 ,7.83035e-09 /) + totplnkderiv(101:150,12) = (/ & + 8.09580e-09 ,8.36620e-09 ,8.64410e-09 ,8.93110e-09 ,9.22170e-09 , & + 9.52055e-09 ,9.82595e-09 ,1.01399e-08 ,1.04613e-08 ,1.07878e-08 , & + 1.11223e-08 ,1.14667e-08 ,1.18152e-08 ,1.21748e-08 ,1.25410e-08 , & + 1.29147e-08 ,1.32948e-08 ,1.36858e-08 ,1.40827e-08 ,1.44908e-08 , & + 1.49040e-08 ,1.53284e-08 ,1.57610e-08 ,1.61995e-08 ,1.66483e-08 , & + 1.71068e-08 ,1.75714e-08 ,1.80464e-08 ,1.85337e-08 ,1.90249e-08 , & + 1.95309e-08 ,2.00407e-08 ,2.05333e-08 ,2.10929e-08 ,2.16346e-08 , & + 2.21829e-08 ,2.27402e-08 ,2.33112e-08 ,2.38922e-08 ,2.44802e-08 , & + 2.50762e-08 ,2.56896e-08 ,2.63057e-08 ,2.69318e-08 ,2.75705e-08 , & + 2.82216e-08 ,2.88787e-08 ,2.95505e-08 ,3.02335e-08 ,3.09215e-08 /) + totplnkderiv(151:181,12) = (/ & + 3.16235e-08 ,3.23350e-08 ,3.30590e-08 ,3.37960e-08 ,3.45395e-08 , & + 3.52955e-08 ,3.60615e-08 ,3.68350e-08 ,3.76265e-08 ,3.84255e-08 , & + 3.92400e-08 ,4.00485e-08 ,4.08940e-08 ,4.17310e-08 ,4.25860e-08 , & + 4.34585e-08 ,4.43270e-08 ,4.52220e-08 ,4.61225e-08 ,4.70345e-08 , & + 4.79560e-08 ,4.89000e-08 ,4.98445e-08 ,5.07985e-08 ,5.17705e-08 , & + 5.27575e-08 ,5.37420e-08 ,5.47495e-08 ,5.57725e-08 ,5.68105e-08 , & + 5.78395e-08 /) + totplnkderiv(1:50,13) = (/ & + 5.47482e-12 ,6.09637e-12 ,6.77874e-12 ,7.52703e-12 ,8.34784e-12 , & + 9.24486e-12 ,1.02246e-11 ,1.12956e-11 ,1.24615e-11 ,1.37321e-11 , & + 1.51131e-11 ,1.66129e-11 ,1.82416e-11 ,2.00072e-11 ,2.19187e-11 , & + 2.39828e-11 ,2.62171e-11 ,2.86290e-11 ,3.12283e-11 ,3.40276e-11 , & + 3.70433e-11 ,4.02847e-11 ,4.37738e-11 ,4.75070e-11 ,5.15119e-11 , & + 5.58120e-11 ,6.04059e-11 ,6.53208e-11 ,7.05774e-11 ,7.61935e-11 , & + 8.21832e-11 ,8.85570e-11 ,9.53575e-11 ,1.02592e-10 ,1.10298e-10 , & + 1.18470e-10 ,1.27161e-10 ,1.36381e-10 ,1.46161e-10 ,1.56529e-10 , & + 1.67521e-10 ,1.79142e-10 ,1.91423e-10 ,2.04405e-10 ,2.18123e-10 , & + 2.32608e-10 ,2.47889e-10 ,2.63994e-10 ,2.80978e-10 ,2.98843e-10 /) + totplnkderiv(51:100,13) = (/ & + 3.17659e-10 ,3.37423e-10 ,3.58206e-10 ,3.80090e-10 ,4.02996e-10 , & + 4.27065e-10 ,4.52298e-10 ,4.78781e-10 ,5.06493e-10 ,5.35576e-10 , & + 5.65942e-10 ,5.97761e-10 ,6.31007e-10 ,6.65740e-10 ,7.02095e-10 , & + 7.39945e-10 ,7.79575e-10 ,8.20845e-10 ,8.63870e-10 ,9.08680e-10 , & + 9.55385e-10 ,1.00416e-09 ,1.05464e-09 ,1.10737e-09 ,1.16225e-09 , & + 1.21918e-09 ,1.27827e-09 ,1.33988e-09 ,1.40370e-09 ,1.46994e-09 , & + 1.53850e-09 ,1.60993e-09 ,1.68382e-09 ,1.76039e-09 ,1.83997e-09 , & + 1.92182e-09 ,2.00686e-09 ,2.09511e-09 ,2.18620e-09 ,2.28034e-09 , & + 2.37753e-09 ,2.47805e-09 ,2.58193e-09 ,2.68935e-09 ,2.80064e-09 , & + 2.91493e-09 ,3.03271e-09 ,3.15474e-09 ,3.27987e-09 ,3.40936e-09 /) + totplnkderiv(101:150,13) = (/ & + 3.54277e-09 ,3.68019e-09 ,3.82173e-09 ,3.96703e-09 ,4.11746e-09 , & + 4.27104e-09 ,4.43020e-09 ,4.59395e-09 ,4.76060e-09 ,4.93430e-09 , & + 5.11085e-09 ,5.29280e-09 ,5.48055e-09 ,5.67300e-09 ,5.86950e-09 , & + 6.07160e-09 ,6.28015e-09 ,6.49295e-09 ,6.71195e-09 ,6.93455e-09 , & + 7.16470e-09 ,7.39985e-09 ,7.64120e-09 ,7.88885e-09 ,8.13910e-09 , & + 8.39930e-09 ,8.66535e-09 ,8.93600e-09 ,9.21445e-09 ,9.49865e-09 , & + 9.78845e-09 ,1.00856e-08 ,1.04361e-08 ,1.07018e-08 ,1.10164e-08 , & + 1.13438e-08 ,1.16748e-08 ,1.20133e-08 ,1.23575e-08 ,1.27117e-08 , & + 1.30708e-08 ,1.34383e-08 ,1.38138e-08 ,1.41985e-08 ,1.45859e-08 , & + 1.49846e-08 ,1.53879e-08 ,1.58042e-08 ,1.62239e-08 ,1.66529e-08 /) + totplnkderiv(151:181,13) = (/ & + 1.70954e-08 ,1.75422e-08 ,1.79943e-08 ,1.84537e-08 ,1.89280e-08 , & + 1.94078e-08 ,1.98997e-08 ,2.03948e-08 ,2.08956e-08 ,2.14169e-08 , & + 2.19330e-08 ,2.24773e-08 ,2.30085e-08 ,2.35676e-08 ,2.41237e-08 , & + 2.46919e-08 ,2.52720e-08 ,2.58575e-08 ,2.64578e-08 ,2.70675e-08 , & + 2.76878e-08 ,2.83034e-08 ,2.89430e-08 ,2.95980e-08 ,3.02480e-08 , & + 3.09105e-08 ,3.15980e-08 ,3.22865e-08 ,3.29755e-08 ,3.36775e-08 , & + 3.43990e-08 /) + totplnkderiv(1:50,14) = (/ & + 1.81489e-12 ,2.03846e-12 ,2.28659e-12 ,2.56071e-12 ,2.86352e-12 , & + 3.19789e-12 ,3.56668e-12 ,3.97211e-12 ,4.41711e-12 ,4.90616e-12 , & + 5.44153e-12 ,6.02790e-12 ,6.67001e-12 ,7.37018e-12 ,8.13433e-12 , & + 8.96872e-12 ,9.87526e-12 ,1.08601e-11 ,1.19328e-11 ,1.30938e-11 , & + 1.43548e-11 ,1.57182e-11 ,1.71916e-11 ,1.87875e-11 ,2.05091e-11 , & + 2.23652e-11 ,2.43627e-11 ,2.65190e-11 ,2.88354e-11 ,3.13224e-11 , & + 3.39926e-11 ,3.68664e-11 ,3.99372e-11 ,4.32309e-11 ,4.67496e-11 , & + 5.05182e-11 ,5.45350e-11 ,5.88268e-11 ,6.34126e-11 ,6.82878e-11 , & + 7.34973e-11 ,7.90201e-11 ,8.49075e-11 ,9.11725e-11 ,9.78235e-11 , & + 1.04856e-10 ,1.12342e-10 ,1.20278e-10 ,1.28680e-10 ,1.37560e-10 /) + totplnkderiv(51:100,14) = (/ & + 1.46953e-10 ,1.56900e-10 ,1.67401e-10 ,1.78498e-10 ,1.90161e-10 , & + 2.02523e-10 ,2.15535e-10 ,2.29239e-10 ,2.43665e-10 ,2.58799e-10 , & + 2.74767e-10 ,2.91522e-10 ,3.09141e-10 ,3.27625e-10 ,3.47011e-10 , & + 3.67419e-10 ,3.88720e-10 ,4.11066e-10 ,4.34522e-10 ,4.59002e-10 , & + 4.84657e-10 ,5.11391e-10 ,5.39524e-10 ,5.68709e-10 ,5.99240e-10 , & + 6.31295e-10 ,6.64520e-10 ,6.99200e-10 ,7.35525e-10 ,7.73135e-10 , & + 8.12440e-10 ,8.53275e-10 ,8.95930e-10 ,9.40165e-10 ,9.86260e-10 , & + 1.03423e-09 ,1.08385e-09 ,1.13567e-09 ,1.18916e-09 ,1.24469e-09 , & + 1.30262e-09 ,1.36268e-09 ,1.42479e-09 ,1.48904e-09 ,1.55557e-09 , & + 1.62478e-09 ,1.69642e-09 ,1.77023e-09 ,1.84696e-09 ,1.92646e-09 /) + totplnkderiv(101:150,14) = (/ & + 2.00831e-09 ,2.09299e-09 ,2.18007e-09 ,2.27093e-09 ,2.36398e-09 , & + 2.46020e-09 ,2.55985e-09 ,2.66230e-09 ,2.76795e-09 ,2.87667e-09 , & + 2.98971e-09 ,3.10539e-09 ,3.22462e-09 ,3.34779e-09 ,3.47403e-09 , & + 3.60419e-09 ,3.73905e-09 ,3.87658e-09 ,4.01844e-09 ,4.16535e-09 , & + 4.31470e-09 ,4.46880e-09 ,4.62765e-09 ,4.78970e-09 ,4.95735e-09 , & + 5.12890e-09 ,5.30430e-09 ,5.48595e-09 ,5.67010e-09 ,5.86145e-09 , & + 6.05740e-09 ,6.25725e-09 ,6.46205e-09 ,6.67130e-09 ,6.88885e-09 , & + 7.10845e-09 ,7.33450e-09 ,7.56700e-09 ,7.80440e-09 ,8.04465e-09 , & + 8.29340e-09 ,8.54820e-09 ,8.80790e-09 ,9.07195e-09 ,9.34605e-09 , & + 9.62005e-09 ,9.90685e-09 ,1.01939e-08 ,1.04938e-08 ,1.07957e-08 /) + totplnkderiv(151:181,14) = (/ & + 1.11059e-08 ,1.14208e-08 ,1.17447e-08 ,1.20717e-08 ,1.24088e-08 , & + 1.27490e-08 ,1.31020e-08 ,1.34601e-08 ,1.38231e-08 ,1.41966e-08 , & + 1.45767e-08 ,1.49570e-08 ,1.53503e-08 ,1.57496e-08 ,1.61663e-08 , & + 1.65784e-08 ,1.70027e-08 ,1.74290e-08 ,1.78730e-08 ,1.83235e-08 , & + 1.87810e-08 ,1.92418e-08 ,1.97121e-08 ,2.01899e-08 ,2.05787e-08 , & + 2.11784e-08 ,2.16824e-08 ,2.21931e-08 ,2.27235e-08 ,2.32526e-08 , & + 2.37850e-08 /) + totplnkderiv(1:50,15) = (/ & + 5.39905e-13 ,6.11835e-13 ,6.92224e-13 ,7.81886e-13 ,8.81851e-13 , & + 9.93072e-13 ,1.11659e-12 ,1.25364e-12 ,1.40562e-12 ,1.57359e-12 , & + 1.75937e-12 ,1.96449e-12 ,2.19026e-12 ,2.43892e-12 ,2.71249e-12 , & + 3.01233e-12 ,3.34163e-12 ,3.70251e-12 ,4.09728e-12 ,4.52885e-12 , & + 4.99939e-12 ,5.51242e-12 ,6.07256e-12 ,6.68167e-12 ,7.34274e-12 , & + 8.06178e-12 ,8.84185e-12 ,9.68684e-12 ,1.06020e-11 ,1.15909e-11 , & + 1.26610e-11 ,1.38158e-11 ,1.50620e-11 ,1.64047e-11 ,1.78508e-11 , & + 1.94055e-11 ,2.10805e-11 ,2.28753e-11 ,2.48000e-11 ,2.68699e-11 , & + 2.90824e-11 ,3.14526e-11 ,3.39882e-11 ,3.67020e-11 ,3.95914e-11 , & + 4.26870e-11 ,4.59824e-11 ,4.94926e-11 ,5.32302e-11 ,5.72117e-11 /) + totplnkderiv(51:100,15) = (/ & + 6.14475e-11 ,6.59483e-11 ,7.07393e-11 ,7.57999e-11 ,8.11980e-11 , & + 8.68920e-11 ,9.29390e-11 ,9.93335e-11 ,1.06101e-10 ,1.13263e-10 , & + 1.20827e-10 ,1.28819e-10 ,1.37255e-10 ,1.46163e-10 ,1.55547e-10 , & + 1.65428e-10 ,1.75837e-10 ,1.86816e-10 ,1.98337e-10 ,2.10476e-10 , & + 2.23218e-10 ,2.36600e-10 ,2.50651e-10 ,2.65425e-10 ,2.80895e-10 , & + 2.97102e-10 ,3.14100e-10 ,3.31919e-10 ,3.50568e-10 ,3.70064e-10 , & + 3.90464e-10 ,4.11813e-10 ,4.34111e-10 ,4.57421e-10 ,4.81717e-10 , & + 5.07039e-10 ,5.33569e-10 ,5.61137e-10 ,5.89975e-10 ,6.19980e-10 , & + 6.51170e-10 ,6.83650e-10 ,7.17520e-10 ,7.52735e-10 ,7.89390e-10 , & + 8.27355e-10 ,8.66945e-10 ,9.08020e-10 ,9.50665e-10 ,9.95055e-10 /) + totplnkderiv(101:150,15) = (/ & + 1.04101e-09 ,1.08864e-09 ,1.13823e-09 ,1.18923e-09 ,1.24257e-09 , & + 1.29741e-09 ,1.35442e-09 ,1.41347e-09 ,1.47447e-09 ,1.53767e-09 , & + 1.60322e-09 ,1.67063e-09 ,1.74033e-09 ,1.81256e-09 ,1.88704e-09 , & + 1.96404e-09 ,2.04329e-09 ,2.12531e-09 ,2.21032e-09 ,2.29757e-09 , & + 2.38739e-09 ,2.48075e-09 ,2.57628e-09 ,2.67481e-09 ,2.77627e-09 , & + 2.88100e-09 ,2.98862e-09 ,3.09946e-09 ,3.21390e-09 ,3.33105e-09 , & + 3.45185e-09 ,3.57599e-09 ,3.70370e-09 ,3.83512e-09 ,3.96909e-09 , & + 4.10872e-09 ,4.25070e-09 ,4.39605e-09 ,4.54670e-09 ,4.70015e-09 , & + 4.85850e-09 ,5.02050e-09 ,5.18655e-09 ,5.35815e-09 ,5.53180e-09 , & + 5.71225e-09 ,5.89495e-09 ,6.08260e-09 ,6.27485e-09 ,6.47345e-09 /) + totplnkderiv(151:181,15) = (/ & + 6.67520e-09 ,6.88310e-09 ,7.09400e-09 ,7.31140e-09 ,7.53350e-09 , & + 7.76040e-09 ,7.99215e-09 ,8.22850e-09 ,8.47235e-09 ,8.71975e-09 , & + 8.97360e-09 ,9.23365e-09 ,9.49950e-09 ,9.76965e-09 ,1.00441e-08 , & + 1.03270e-08 ,1.06158e-08 ,1.09112e-08 ,1.12111e-08 ,1.15172e-08 , & + 1.18263e-08 ,1.21475e-08 ,1.24735e-08 ,1.28027e-08 ,1.32023e-08 , & + 1.34877e-08 ,1.38399e-08 ,1.42000e-08 ,1.45625e-08 ,1.49339e-08 , & + 1.53156e-08 /) + totplnkderiv(1:50,16) = (/ & + 4.38799e-14 ,5.04835e-14 ,5.79773e-14 ,6.64627e-14 ,7.60706e-14 , & + 8.69213e-14 ,9.91554e-14 ,1.12932e-13 ,1.28419e-13 ,1.45809e-13 , & + 1.65298e-13 ,1.87109e-13 ,2.11503e-13 ,2.38724e-13 ,2.69058e-13 , & + 3.02878e-13 ,3.40423e-13 ,3.82128e-13 ,4.28390e-13 ,4.79625e-13 , & + 5.36292e-13 ,5.98933e-13 ,6.68066e-13 ,7.44216e-13 ,8.28159e-13 , & + 9.20431e-13 ,1.02180e-12 ,1.13307e-12 ,1.25504e-12 ,1.38863e-12 , & + 1.53481e-12 ,1.69447e-12 ,1.86896e-12 ,2.05903e-12 ,2.26637e-12 , & + 2.49193e-12 ,2.73736e-12 ,3.00416e-12 ,3.29393e-12 ,3.60781e-12 , & + 3.94805e-12 ,4.31675e-12 ,4.71543e-12 ,5.14627e-12 ,5.61226e-12 , & + 6.11456e-12 ,6.65585e-12 ,7.23969e-12 ,7.86811e-12 ,8.54456e-12 /) + totplnkderiv(51:100,16) = (/ & + 9.27075e-12 ,1.00516e-11 ,1.08898e-11 ,1.17884e-11 ,1.27514e-11 , & + 1.37839e-11 ,1.48893e-11 ,1.60716e-11 ,1.73333e-11 ,1.86849e-11 , & + 2.01237e-11 ,2.16610e-11 ,2.33001e-11 ,2.50440e-11 ,2.69035e-11 , & + 2.88827e-11 ,3.09881e-11 ,3.32234e-11 ,3.55981e-11 ,3.81193e-11 , & + 4.07946e-11 ,4.36376e-11 ,4.66485e-11 ,4.98318e-11 ,5.32080e-11 , & + 5.67754e-11 ,6.05524e-11 ,6.45450e-11 ,6.87639e-11 ,7.32160e-11 , & + 7.79170e-11 ,8.28780e-11 ,8.81045e-11 ,9.36200e-11 ,9.94280e-11 , & + 1.05545e-10 ,1.11982e-10 ,1.18752e-10 ,1.25866e-10 ,1.33350e-10 , & + 1.41210e-10 ,1.49469e-10 ,1.58143e-10 ,1.67233e-10 ,1.76760e-10 , & + 1.86758e-10 ,1.97236e-10 ,2.08227e-10 ,2.19723e-10 ,2.31737e-10 /) + totplnkderiv(101:150,16) = (/ & + 2.44329e-10 ,2.57503e-10 ,2.71267e-10 ,2.85647e-10 ,3.00706e-10 , & + 3.16391e-10 ,3.32807e-10 ,3.49887e-10 ,3.67748e-10 ,3.86369e-10 , & + 4.05746e-10 ,4.25984e-10 ,4.47060e-10 ,4.68993e-10 ,4.91860e-10 , & + 5.15601e-10 ,5.40365e-10 ,5.66085e-10 ,5.92855e-10 ,6.20640e-10 , & + 6.49605e-10 ,6.79585e-10 ,7.10710e-10 ,7.43145e-10 ,7.76805e-10 , & + 8.11625e-10 ,8.47800e-10 ,8.85300e-10 ,9.24220e-10 ,9.64550e-10 , & + 1.00623e-09 ,1.04957e-09 ,1.09429e-09 ,1.14079e-09 ,1.18882e-09 , & + 1.23848e-09 ,1.28986e-09 ,1.34301e-09 ,1.39796e-09 ,1.45493e-09 , & + 1.51372e-09 ,1.57440e-09 ,1.63702e-09 ,1.70173e-09 ,1.76874e-09 , & + 1.83753e-09 ,1.90898e-09 ,1.98250e-09 ,2.05836e-09 ,2.13646e-09 /) + totplnkderiv(151:181,16) = (/ & + 2.21710e-09 ,2.30027e-09 ,2.38591e-09 ,2.47432e-09 ,2.56503e-09 , & + 2.65878e-09 ,2.75516e-09 ,2.85432e-09 ,2.95688e-09 ,3.06201e-09 , & + 3.17023e-09 ,3.28153e-09 ,3.39604e-09 ,3.51391e-09 ,3.63517e-09 , & + 3.75955e-09 ,3.88756e-09 ,4.01880e-09 ,4.15405e-09 ,4.29255e-09 , & + 4.43535e-09 ,4.58145e-09 ,4.73165e-09 ,4.88560e-09 ,5.04390e-09 , & + 5.20630e-09 ,5.37255e-09 ,5.54355e-09 ,5.71915e-09 ,5.89855e-09 , & + 6.08280e-09 /) + totplk16deriv(1:50) = (/ & + 4.35811e-14 ,5.01270e-14 ,5.75531e-14 ,6.59588e-14 ,7.54735e-14 , & + 8.62147e-14 ,9.83225e-14 ,1.11951e-13 ,1.27266e-13 ,1.44456e-13 , & + 1.63715e-13 ,1.85257e-13 ,2.09343e-13 ,2.36209e-13 ,2.66136e-13 , & + 2.99486e-13 ,3.36493e-13 ,3.77582e-13 ,4.23146e-13 ,4.73578e-13 , & + 5.29332e-13 ,5.90936e-13 ,6.58891e-13 ,7.33710e-13 ,8.16135e-13 , & + 9.06705e-13 ,1.00614e-12 ,1.11524e-12 ,1.23477e-12 ,1.36561e-12 , & + 1.50871e-12 ,1.66488e-12 ,1.83552e-12 ,2.02123e-12 ,2.22375e-12 , & + 2.44389e-12 ,2.68329e-12 ,2.94338e-12 ,3.22570e-12 ,3.53129e-12 , & + 3.86236e-12 ,4.22086e-12 ,4.60827e-12 ,5.02666e-12 ,5.47890e-12 , & + 5.96595e-12 ,6.49057e-12 ,7.05592e-12 ,7.66401e-12 ,8.31821e-12 /) + totplk16deriv(51:100) = (/ & + 9.01998e-12 ,9.77390e-12 ,1.05826e-11 ,1.14491e-11 ,1.23769e-11 , & + 1.33709e-11 ,1.44341e-11 ,1.55706e-11 ,1.67821e-11 ,1.80793e-11 , & + 1.94586e-11 ,2.09316e-11 ,2.25007e-11 ,2.41685e-11 ,2.59454e-11 , & + 2.78356e-11 ,2.98440e-11 ,3.19744e-11 ,3.42355e-11 ,3.66340e-11 , & + 3.91772e-11 ,4.18773e-11 ,4.47339e-11 ,4.77509e-11 ,5.09490e-11 , & + 5.43240e-11 ,5.78943e-11 ,6.16648e-11 ,6.56445e-11 ,6.98412e-11 , & + 7.42680e-11 ,7.89335e-11 ,8.38450e-11 ,8.90220e-11 ,9.44695e-11 , & + 1.00197e-10 ,1.06221e-10 ,1.12550e-10 ,1.19193e-10 ,1.26175e-10 , & + 1.33498e-10 ,1.41188e-10 ,1.49251e-10 ,1.57693e-10 ,1.66530e-10 , & + 1.75798e-10 ,1.85495e-10 ,1.95661e-10 ,2.06275e-10 ,2.17357e-10 /) + totplk16deriv(101:150) = (/ & + 2.28959e-10 ,2.41085e-10 ,2.53739e-10 ,2.66944e-10 ,2.80755e-10 , & + 2.95121e-10 ,3.10141e-10 ,3.25748e-10 ,3.42057e-10 ,3.59026e-10 , & + 3.76668e-10 ,3.95066e-10 ,4.14211e-10 ,4.34111e-10 ,4.54818e-10 , & + 4.76295e-10 ,4.98681e-10 ,5.21884e-10 ,5.46000e-10 ,5.71015e-10 , & + 5.97065e-10 ,6.23965e-10 ,6.51865e-10 ,6.80905e-10 ,7.11005e-10 , & + 7.42100e-10 ,7.74350e-10 ,8.07745e-10 ,8.42355e-10 ,8.78185e-10 , & + 9.15130e-10 ,9.53520e-10 ,9.93075e-10 ,1.03415e-09 ,1.07649e-09 , & + 1.12021e-09 ,1.16539e-09 ,1.21207e-09 ,1.26025e-09 ,1.31014e-09 , & + 1.36156e-09 ,1.41453e-09 ,1.46909e-09 ,1.52540e-09 ,1.58368e-09 , & + 1.64334e-09 ,1.70527e-09 ,1.76888e-09 ,1.83442e-09 ,1.90182e-09 /) + totplk16deriv(151:181) = (/ & + 1.97128e-09 ,2.04281e-09 ,2.11635e-09 ,2.19219e-09 ,2.26979e-09 , & + 2.34989e-09 ,2.43219e-09 ,2.51660e-09 ,2.60396e-09 ,2.69317e-09 , & + 2.78501e-09 ,2.87927e-09 ,2.97600e-09 ,3.07548e-09 ,3.17772e-09 , & + 3.28235e-09 ,3.38982e-09 ,3.49985e-09 ,3.61307e-09 ,3.72883e-09 , & + 3.84805e-09 ,3.96975e-09 ,4.09465e-09 ,4.22240e-09 ,4.35370e-09 , & + 4.48800e-09 ,4.62535e-09 ,4.76640e-09 ,4.91110e-09 ,5.05850e-09 , & + 5.20965e-09 /) + + end subroutine lwavplankderiv + + end module rrtmg_lw_setcoef_f + + module rrtmg_lw_init_f + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +! ------- Modules ------- +! use parkind, only : im => kind , rb => kind + use rrlw_wvn_f + use rrtmg_lw_setcoef_f, only: lwatmref, lwavplank, lwavplankderiv + + implicit none + + contains + +! ************************************************************************** + subroutine rrtmg_lw_ini(cpdair) +! ************************************************************************** +! +! Original version: Michael J. Iacono; July, 1998 +! First revision for GCMs: September, 1998 +! Second revision for RRTM_V3.0: September, 2002 +! +! This subroutine performs calculations necessary for the initialization +! of the longwave model. Lookup tables are computed for use in the LW +! radiative transfer, and input absorption coefficient data for each +! spectral band are reduced from 256 g-point intervals to 140. +! ************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw + use rrlw_tbl_f, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl, tfn_tbl + use rrlw_vsn_f, only: hvrini, hnamini + + real , intent(in) :: cpdair ! Specific heat capacity of dry air + ! at constant pressure at 273 K + ! (J kg-1 K-1) + +! ------- Local ------- + + integer :: itr, ibnd, igc, ig, ind, ipr + integer :: igcsm, iprsm + + real :: wtsum, wtsm(mg) ! + real :: tfn ! + + real , parameter :: expeps = 1.e-20 ! Smallest value for exponential table + +! ------- Definitions ------- +! Arrays for 10000-point look-up tables: +! TAU_TBL Clear-sky optical depth (used in cloudy radiative transfer) +! EXP_TBL Exponential lookup table for ransmittance +! TFN_TBL Tau transition function; i.e. the transition of the Planck +! function from that for the mean layer temperature to that for +! the layer boundary temperature as a function of optical depth. +! The "linear in tau" method is used to make the table. +! PADE Pade approximation constant (= 0.278) +! BPADE Inverse of the Pade approximation constant +! + + hvrini = '$Revision: 1.1.1.2 $' + +! Initialize model data + call lwdatinit(cpdair) + call lwcmbdat ! g-point interval reduction data + call lwcldpr ! cloud optical properties + call lwatmref ! reference MLS profile + call lwavplank ! Planck function + call lwavplankderiv ! Planck function derivative wrt temp +! Moved to module_ra_rrtmg_lw for WRF +! call lw_kgb01 ! molecular absorption coefficients +! call lw_kgb02 +! call lw_kgb03 +! call lw_kgb04 +! call lw_kgb05 +! call lw_kgb06 +! call lw_kgb07 +! call lw_kgb08 +! call lw_kgb09 +! call lw_kgb10 +! call lw_kgb11 +! call lw_kgb12 +! call lw_kgb13 +! call lw_kgb14 +! call lw_kgb15 +! call lw_kgb16 + +! Compute lookup tables for transmittance, tau transition function, +! and clear sky tau (for the cloudy sky radiative transfer). Tau is +! computed as a function of the tau transition function, transmittance +! is calculated as a function of tau, and the tau transition function +! is calculated using the linear in tau formulation at values of tau +! above 0.01. TF is approximated as tau/6 for tau < 0.01. All tables +! are computed at intervals of 0.001. The inverse of the constant used +! in the Pade approximation to the tau transition function is set to b. + + tau_tbl(0) = 0.0 + tau_tbl(ntbl) = 1.e10 + exp_tbl(0) = 1.0 + exp_tbl(ntbl) = expeps + tfn_tbl(0) = 0.0 + tfn_tbl(ntbl) = 1.0 + bpade = 1.0 / pade + do itr = 1, ntbl-1 + tfn = float(itr) / float(ntbl) + tau_tbl(itr) = bpade * tfn / (1. - tfn) + exp_tbl(itr) = exp(-tau_tbl(itr)) + if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps + if (tau_tbl(itr) .lt. 0.06 ) then + tfn_tbl(itr) = tau_tbl(itr)/6. + else + tfn_tbl(itr) = 1. -2. *((1. /tau_tbl(itr))-(exp_tbl(itr)/(1.-exp_tbl(itr)))) + endif + enddo + +! Perform g-point reduction from 16 per band (256 total points) to +! a band dependant number (140 total points) for all absorption +! coefficient input data and Planck fraction input data. +! Compute relative weighting for new g-point combinations. + + igcsm = 0 + do ibnd = 1,nbndlw + iprsm = 0 + if (ngc(ibnd).lt.mg) then + do igc = 1,ngc(ibnd) + igcsm = igcsm + 1 + wtsum = 0. + do ipr = 1, ngn(igcsm) + iprsm = iprsm + 1 + wtsum = wtsum + wt(iprsm) + enddo + wtsm(igc) = wtsum + enddo + do ig = 1, ng(ibnd) + ind = (ibnd-1)*mg + ig + rwgt(ind) = wt(ig)/wtsm(ngm(ind)) + enddo + else + do ig = 1, ng(ibnd) + igcsm = igcsm + 1 + ind = (ibnd-1)*mg + ig + rwgt(ind) = 1.0 + enddo + endif + enddo + +! Reduce g-points for absorption coefficient data in each LW spectral band. + + call cmbgb1 + call cmbgb2 + call cmbgb3 + call cmbgb4 + call cmbgb5 + call cmbgb6 + call cmbgb7 + call cmbgb8 + call cmbgb9 + call cmbgb10 + call cmbgb11 + call cmbgb12 + call cmbgb13 + call cmbgb14 + call cmbgb15 + call cmbgb16 + + end subroutine rrtmg_lw_ini + +!*************************************************************************** + subroutine lwdatinit(cpdair) +!*************************************************************************** + +! --------- Modules ---------- + + use parrrtm_f, only : maxxsec, maxinpx + use rrlw_con_f, only: heatfac, grav, planck, boltz, & + clight, avogad, alosmt, gascon, radcn1, radcn2, & + sbcnst, secdy + use rrlw_vsn_f + + save + + real , intent(in) :: cpdair ! Specific heat capacity of dry air + ! at constant pressure at 273 K + ! (J kg-1 K-1) + +! Longwave spectral band limits (wavenumbers) + wavenum1(:) = (/ 10. , 350. , 500. , 630. , 700. , 820. , & + 980. ,1080. ,1180. ,1390. ,1480. ,1800. , & + 2080. ,2250. ,2380. ,2600. /) + wavenum2(:) = (/350. , 500. , 630. , 700. , 820. , 980. , & + 1080. ,1180. ,1390. ,1480. ,1800. ,2080. , & + 2250. ,2380. ,2600. ,3250. /) + delwave(:) = (/340. , 150. , 130. , 70. , 120. , 160. , & + 100. , 100. , 210. , 90. , 320. , 280. , & + 170. , 130. , 220. , 650. /) + +! Spectral band information + ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16/) + nspa(:) = (/1,1,9,9,9,1,9,1,9,1,1,9,9,1,9,9/) + nspb(:) = (/1,1,5,5,5,0,1,1,1,1,1,0,0,1,0,0/) + +! nxmol - number of cross-sections input by user +! ixindx(i) - index of cross-section molecule corresponding to Ith +! cross-section specified by user +! = 0 -- not allowed in rrtm +! = 1 -- ccl4 +! = 2 -- cfc11 +! = 3 -- cfc12 +! = 4 -- cfc22 + nxmol = 4 + ixindx(1) = 1 + ixindx(2) = 2 + ixindx(3) = 3 + ixindx(4) = 4 + ixindx(5:maxinpx) = 0 + +! Fundamental physical constants from NIST 2002 + + grav = 9.8066 ! Acceleration of gravity + ! (m s-2) + planck = 6.62606876e-27 ! Planck constant + ! (ergs s; g cm2 s-1) + boltz = 1.3806503e-16 ! Boltzmann constant + ! (ergs K-1; g cm2 s-2 K-1) + clight = 2.99792458e+10 ! Speed of light in a vacuum + ! (cm s-1) + avogad = 6.02214199e+23 ! Avogadro constant + ! (mol-1) + alosmt = 2.6867775e+19 ! Loschmidt constant + ! (cm-3) + gascon = 8.31447200e+07 ! Molar gas constant + ! (ergs mol-1 K-1) + radcn1 = 1.191042722e-12 ! First radiation constant + ! (W cm2 sr-1) + radcn2 = 1.4387752 ! Second radiation constant + ! (cm K) + sbcnst = 5.670400e-04 ! Stefan-Boltzmann constant + ! (W cm-2 K-4) + secdy = 8.6400e4 ! Number of seconds per day + ! (s d-1) +! +! units are generally cgs +! +! The first and second radiation constants are taken from NIST. +! They were previously obtained from the relations: +! radcn1 = 2.*planck*clight*clight*1.e-07 +! radcn2 = planck*clight/boltz + +! Heatfac is the factor by which delta-flux / delta-pressure is +! multiplied, with flux in W/m-2 and pressure in mbar, to get +! the heating rate in units of degrees/day. It is equal to: +! Original value: +! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p) +! Here, cpdair (1.004) is in units of J g-1 K-1, and the +! constant (1.e-5) converts mb to Pa and g-1 to kg-1. +! = (9.8066)(86400)(1e-5)/(1.004) +! heatfac = 8.4391 +! +! Modified value for consistency with CAM3: +! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p) +! Here, cpdair (1.00464) is in units of J g-1 K-1, and the +! constant (1.e-5) converts mb to Pa and g-1 to kg-1. +! = (9.80616)(86400)(1e-5)/(1.00464) +! heatfac = 8.43339130434 +! +! Calculated value: +! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2) +! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2) +! converts mb to Pa when heatfac is multiplied by W m-2 mb-1. + heatfac = grav * secdy / (cpdair * 1.e2 ) + + end subroutine lwdatinit + +!*************************************************************************** + subroutine lwcmbdat +!*************************************************************************** + + save + +! ------- Definitions ------- +! Arrays for the g-point reduction from 256 to 140 for the 16 LW bands: +! This mapping from 256 to 140 points has been carefully selected to +! minimize the effect on the resulting fluxes and cooling rates, and +! caution should be used if the mapping is modified. The full 256 +! g-point set can be restored with ngptlw=256, ngc=16*16, ngn=256*1., etc. +! ngptlw The total number of new g-points +! ngc The number of new g-points in each band +! ngs The cumulative sum of new g-points for each band +! ngm The index of each new g-point relative to the original +! 16 g-points for each band. +! ngn The number of original g-points that are combined to make +! each new g-point in each band. +! ngb The band index for each new g-point. +! wt RRTM weights for 16 g-points. + +! ------- Data statements ------- + ngc(:) = (/10,12,16,14,16,8,12,8,12,6,8,8,4,2,2,2/) + ngs(:) = (/10,22,38,52,68,76,88,96,108,114,122,130,134,136,138,140/) + ngm(:) = (/1,2,3,3,4,4,5,5,6,6,7,7,8,8,9,10, & ! band 1 + 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 2 + 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 3 + 1,2,3,4,5,6,7,8,9,10,11,12,13,14,14,14, & ! band 4 + 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 5 + 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 6 + 1,1,2,2,3,4,5,6,7,8,9,10,11,11,12,12, & ! band 7 + 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 8 + 1,2,3,4,5,6,7,8,9,9,10,10,11,11,12,12, & ! band 9 + 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 10 + 1,2,3,3,4,4,5,5,6,6,7,7,7,8,8,8, & ! band 11 + 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 12 + 1,1,1,2,2,2,3,3,3,3,4,4,4,4,4,4, & ! band 13 + 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 14 + 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 15 + 1,1,1,1,2,2,2,2,2,2,2,2,2,2,2,2/) ! band 16 + ngn(:) = (/1,1,2,2,2,2,2,2,1,1, & ! band 1 + 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 2 + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 3 + 1,1,1,1,1,1,1,1,1,1,1,1,1,3, & ! band 4 + 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 5 + 2,2,2,2,2,2,2,2, & ! band 6 + 2,2,1,1,1,1,1,1,1,1,2,2, & ! band 7 + 2,2,2,2,2,2,2,2, & ! band 8 + 1,1,1,1,1,1,1,1,2,2,2,2, & ! band 9 + 2,2,2,2,4,4, & ! band 10 + 1,1,2,2,2,2,3,3, & ! band 11 + 1,1,1,1,2,2,4,4, & ! band 12 + 3,3,4,6, & ! band 13 + 8,8, & ! band 14 + 8,8, & ! band 15 + 4,12/) ! band 16 + ngb(:) = (/1,1,1,1,1,1,1,1,1,1, & ! band 1 + 2,2,2,2,2,2,2,2,2,2,2,2, & ! band 2 + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, & ! band 3 + 4,4,4,4,4,4,4,4,4,4,4,4,4,4, & ! band 4 + 5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5, & ! band 5 + 6,6,6,6,6,6,6,6, & ! band 6 + 7,7,7,7,7,7,7,7,7,7,7,7, & ! band 7 + 8,8,8,8,8,8,8,8, & ! band 8 + 9,9,9,9,9,9,9,9,9,9,9,9, & ! band 9 + 10,10,10,10,10,10, & ! band 10 + 11,11,11,11,11,11,11,11, & ! band 11 + 12,12,12,12,12,12,12,12, & ! band 12 + 13,13,13,13, & ! band 13 + 14,14, & ! band 14 + 15,15, & ! band 15 + 16,16/) ! band 16 + wt(:) = (/ 0.1527534276 , 0.1491729617 , 0.1420961469 , & + 0.1316886544 , 0.1181945205 , 0.1019300893 , & + 0.0832767040 , 0.0626720116 , 0.0424925000 , & + 0.0046269894 , 0.0038279891 , 0.0030260086 , & + 0.0022199750 , 0.0014140010 , 0.0005330000 , & + 0.0000750000 /) + + end subroutine lwcmbdat + +!*************************************************************************** + subroutine cmbgb1 +!*************************************************************************** +! +! Original version: MJIacono; July 1998 +! Revision for GCMs: MJIacono; September 1998 +! Revision for RRTMG: MJIacono, September 2002 +! Revision for F90 reformatting: MJIacono, June 2006 +! +! The subroutines CMBGB1->CMBGB16 input the absorption coefficient +! data for each band, which are defined for 16 g-points and 16 spectral +! bands. The data are combined with appropriate weighting following the +! g-point mapping arrays specified in RRTMINIT. Plank fraction data +! in arrays FRACREFA and FRACREFB are combined without weighting. All +! g-point reduced data are put into new arrays for use in RRTM. +! +! band 1: 10-350 cm-1 (low key - h2o; low minor - n2) +! (high key - h2o; high minor - n2) +! note: previous versions of rrtm band 1: +! 10-250 cm-1 (low - h2o; high - h2o) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng1 + use rrlw_kg01_f, only: fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2, kb_mn2, & + selfref, forref + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumk1, sumk2, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(1) + sumk1 = 0. + sumk2 = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk1 = sumk1 + kao_mn2(jt,iprsm)*rwgt(iprsm) + sumk2 = sumk2 + kbo_mn2(jt,iprsm)*rwgt(iprsm) + enddo + ka_mn2(jt,igc) = sumk1 + kb_mn2(jt,igc) = sumk2 + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(1) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + enddo + + end subroutine cmbgb1 + +!*************************************************************************** + subroutine cmbgb2 +!*************************************************************************** +! +! band 2: 350-500 cm-1 (low key - h2o; high key - h2o) +! +! note: previous version of rrtm band 2: +! 250 - 500 cm-1 (low - h2o; high - h2o) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng2 + use rrlw_kg02_f, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+16) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+16) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(2) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + enddo + + end subroutine cmbgb2 + +!*************************************************************************** + subroutine cmbgb3 +!*************************************************************************** +! +! band 3: 500-630 cm-1 (low key - h2o,co2; low minor - n2o) +! (high key - h2o,co2; high minor - n2o) +! +! old band 3: 500-630 cm-1 (low - h2o,co2; high - h2o,co2) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng3 + use rrlw_kg03_f, only: fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, ka_mn2o, kb_mn2o, & + selfref, forref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+32) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+32) + enddo + ka_mn2o(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jn = 1,5 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo_mn2o(jn,jt,iprsm)*rwgt(iprsm+32) + enddo + kb_mn2o(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(3) + sumf = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + do jp = 1,5 + iprsm = 0 + do igc = 1,ngc(3) + sumf = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm,jp) + enddo + fracrefb(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb3 + +!*************************************************************************** + subroutine cmbgb4 +!*************************************************************************** +! +! band 4: 630-700 cm-1 (low key - h2o,co2; high key - o3,co2) +! +! old band 4: 630-700 cm-1 (low - h2o,co2; high - o3,co2) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng4 + use rrlw_kg04_f, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+48) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(4) + sumf = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + do jp = 1,5 + iprsm = 0 + do igc = 1,ngc(4) + sumf = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm,jp) + enddo + fracrefb(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb4 + +!*************************************************************************** + subroutine cmbgb5 +!*************************************************************************** +! +! band 5: 700-820 cm-1 (low key - h2o,co2; low minor - o3, ccl4) +! (high key - o3,co2) +! +! old band 5: 700-820 cm-1 (low - h2o,co2; high - o3,co2) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng5 + use rrlw_kg05_f, only: fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, ka_mo3, ccl4, & + selfref, forref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+64) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+64) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mo3(jn,jt,iprsm)*rwgt(iprsm+64) + enddo + ka_mo3(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(5) + sumf = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + do jp = 1,5 + iprsm = 0 + do igc = 1,ngc(5) + sumf = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm,jp) + enddo + fracrefb(igc,jp) = sumf + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + ccl4o(iprsm)*rwgt(iprsm+64) + enddo + ccl4(igc) = sumk + enddo + + end subroutine cmbgb5 + +!*************************************************************************** + subroutine cmbgb6 +!*************************************************************************** +! +! band 6: 820-980 cm-1 (low key - h2o; low minor - co2) +! (high key - nothing; high minor - cfc11, cfc12) +! +! old band 6: 820-980 cm-1 (low - h2o; high - nothing) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng6 + use rrlw_kg06_f, only: fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, & + selfrefo, forrefo, & + fracrefa, absa, ka, ka_mco2, cfc11adj, cfc12, & + selfref, forref + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumf, sumk1, sumk2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+80) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mco2(jt,iprsm)*rwgt(iprsm+80) + enddo + ka_mco2(jt,igc) = sumk + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(6) + sumf = 0. + sumk1= 0. + sumk2= 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm) + sumk1= sumk1+ cfc11adjo(iprsm)*rwgt(iprsm+80) + sumk2= sumk2+ cfc12o(iprsm)*rwgt(iprsm+80) + enddo + fracrefa(igc) = sumf + cfc11adj(igc) = sumk1 + cfc12(igc) = sumk2 + enddo + + end subroutine cmbgb6 + +!*************************************************************************** + subroutine cmbgb7 +!*************************************************************************** +! +! band 7: 980-1080 cm-1 (low key - h2o,o3; low minor - co2) +! (high key - o3; high minor - co2) +! +! old band 7: 980-1080 cm-1 (low - h2o,o3; high - o3) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng7 + use rrlw_kg07_f, only: fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, ka_mco2, kb_mco2, & + selfref, forref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+96) + enddo + ka_mco2(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo_mco2(jt,iprsm)*rwgt(iprsm+96) + enddo + kb_mco2(jt,igc) = sumk + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(7) + sumf = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(7) + sumf = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm) + enddo + fracrefb(igc) = sumf + enddo + + end subroutine cmbgb7 + +!*************************************************************************** + subroutine cmbgb8 +!*************************************************************************** +! +! band 8: 1080-1180 cm-1 (low key - h2o; low minor - co2,o3,n2o) +! (high key - o3; high minor - co2, n2o) +! +! old band 8: 1080-1180 cm-1 (low (i.e.>~300mb) - h2o; high - o3) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng8 + use rrlw_kg08_f, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, & + kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, & + cfc12o, cfc22adjo, & + fracrefa, fracrefb, absa, ka, ka_mco2, ka_mn2o, & + ka_mo3, absb, kb, kb_mco2, kb_mn2o, selfref, forref, & + cfc12, cfc22adj + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumk1, sumk2, sumk3, sumk4, sumk5, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+112) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(8) + sumk1 = 0. + sumk2 = 0. + sumk3 = 0. + sumk4 = 0. + sumk5 = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk1 = sumk1 + kao_mco2(jt,iprsm)*rwgt(iprsm+112) + sumk2 = sumk2 + kbo_mco2(jt,iprsm)*rwgt(iprsm+112) + sumk3 = sumk3 + kao_mo3(jt,iprsm)*rwgt(iprsm+112) + sumk4 = sumk4 + kao_mn2o(jt,iprsm)*rwgt(iprsm+112) + sumk5 = sumk5 + kbo_mn2o(jt,iprsm)*rwgt(iprsm+112) + enddo + ka_mco2(jt,igc) = sumk1 + kb_mco2(jt,igc) = sumk2 + ka_mo3(jt,igc) = sumk3 + ka_mn2o(jt,igc) = sumk4 + kb_mn2o(jt,igc) = sumk5 + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(8) + sumf1= 0. + sumf2= 0. + sumk1= 0. + sumk2= 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + sumk1= sumk1+ cfc12o(iprsm)*rwgt(iprsm+112) + sumk2= sumk2+ cfc22adjo(iprsm)*rwgt(iprsm+112) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + cfc12(igc) = sumk1 + cfc22adj(igc) = sumk2 + enddo + + end subroutine cmbgb8 + +!*************************************************************************** + subroutine cmbgb9 +!*************************************************************************** +! +! band 9: 1180-1390 cm-1 (low key - h2o,ch4; low minor - n2o) +! (high key - ch4; high minor - n2o)! + +! old band 9: 1180-1390 cm-1 (low - h2o,ch4; high - ch4) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng9 + use rrlw_kg09_f, only: fracrefao, fracrefbo, kao, kao_mn2o, & + kbo, kbo_mn2o, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, ka_mn2o, & + absb, kb, kb_mn2o, selfref, forref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mn2o(jn,jt,iprsm)*rwgt(iprsm+128) + enddo + ka_mn2o(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo_mn2o(jt,iprsm)*rwgt(iprsm+128) + enddo + kb_mn2o(jt,igc) = sumk + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(9) + sumf = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(9) + sumf = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm) + enddo + fracrefb(igc) = sumf + enddo + + end subroutine cmbgb9 + +!*************************************************************************** + subroutine cmbgb10 +!*************************************************************************** +! +! band 10: 1390-1480 cm-1 (low key - h2o; high key - h2o) +! +! old band 10: 1390-1480 cm-1 (low - h2o; high - h2o) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng10 + use rrlw_kg10_f, only: fracrefao, fracrefbo, kao, kbo, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, & + selfref, forref + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(10) + sumk = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(10) + sumk = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+144) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(10) + sumk = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+144) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(10) + sumk = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+144) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(10) + sumf1= 0. + sumf2= 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + enddo + + end subroutine cmbgb10 + +!*************************************************************************** + subroutine cmbgb11 +!*************************************************************************** +! +! band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) +! (high key - h2o; high minor - o2) +! +! old band 11: 1480-1800 cm-1 (low - h2o; low minor - o2) +! (high key - h2o; high minor - o2) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng11 + use rrlw_kg11_f, only: fracrefao, fracrefbo, kao, kao_mo2, & + kbo, kbo_mo2, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, ka_mo2, & + absb, kb, kb_mo2, selfref, forref + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumk1, sumk2, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(11) + sumk = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+160) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(11) + sumk = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+160) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(11) + sumk1 = 0. + sumk2 = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumk1 = sumk1 + kao_mo2(jt,iprsm)*rwgt(iprsm+160) + sumk2 = sumk2 + kbo_mo2(jt,iprsm)*rwgt(iprsm+160) + enddo + ka_mo2(jt,igc) = sumk1 + kb_mo2(jt,igc) = sumk2 + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(11) + sumk = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+160) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(11) + sumk = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+160) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(11) + sumf1= 0. + sumf2= 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + enddo + + end subroutine cmbgb11 + +!*************************************************************************** + subroutine cmbgb12 +!*************************************************************************** +! +! band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +! +! old band 12: 1800-2080 cm-1 (low - h2o,co2; high - nothing) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng12 + use rrlw_kg12_f, only: fracrefao, kao, selfrefo, forrefo, & + fracrefa, absa, ka, selfref, forref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(12) + sumk = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+176) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(12) + sumk = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+176) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(12) + sumk = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+176) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(12) + sumf = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb12 + +!*************************************************************************** + subroutine cmbgb13 +!*************************************************************************** +! +! band 13: 2080-2250 cm-1 (low key - h2o,n2o; high minor - o3 minor) +! +! old band 13: 2080-2250 cm-1 (low - h2o,n2o; high - nothing) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng13 + use rrlw_kg13_f, only: fracrefao, fracrefbo, kao, kao_mco2, kao_mco, & + kbo_mo3, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, ka_mco2, ka_mco, & + kb_mo3, selfref, forref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumk1, sumk2, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(13) + sumk1 = 0. + sumk2 = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk1 = sumk1 + kao_mco2(jn,jt,iprsm)*rwgt(iprsm+192) + sumk2 = sumk2 + kao_mco(jn,jt,iprsm)*rwgt(iprsm+192) + enddo + ka_mco2(jn,jt,igc) = sumk1 + ka_mco(jn,jt,igc) = sumk2 + enddo + enddo + enddo + + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo_mo3(jt,iprsm)*rwgt(iprsm+192) + enddo + kb_mo3(jt,igc) = sumk + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+192) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+192) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(13) + sumf = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm) + enddo + fracrefb(igc) = sumf + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(13) + sumf = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb13 + +!*************************************************************************** + subroutine cmbgb14 +!*************************************************************************** +! +! band 14: 2250-2380 cm-1 (low - co2; high - co2) +! +! old band 14: 2250-2380 cm-1 (low - co2; high - co2) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng14 + use rrlw_kg14_f, only: fracrefao, fracrefbo, kao, kbo, & + selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, & + selfref, forref + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(14) + sumf1= 0. + sumf2= 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumf1= sumf1+ fracrefao(iprsm) + sumf2= sumf2+ fracrefbo(iprsm) + enddo + fracrefa(igc) = sumf1 + fracrefb(igc) = sumf2 + enddo + + end subroutine cmbgb14 + +!*************************************************************************** + subroutine cmbgb15 +!*************************************************************************** +! +! band 15: 2380-2600 cm-1 (low - n2o,co2; low minor - n2) +! (high - nothing) +! +! old band 15: 2380-2600 cm-1 (low - n2o,co2; high - nothing) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng15 + use rrlw_kg15_f, only: fracrefao, kao, kao_mn2, selfrefo, forrefo, & + fracrefa, absa, ka, ka_mn2, selfref, forref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(15) + sumk = 0. + do ipr = 1, ngn(ngs(14)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+224) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,9 + do jt = 1,19 + iprsm = 0 + do igc = 1,ngc(15) + sumk = 0. + do ipr = 1, ngn(ngs(14)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao_mn2(jn,jt,iprsm)*rwgt(iprsm+224) + enddo + ka_mn2(jn,jt,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(15) + sumk = 0. + do ipr = 1, ngn(ngs(14)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+224) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(15) + sumk = 0. + do ipr = 1, ngn(ngs(14)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+224) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(15) + sumf = 0. + do ipr = 1, ngn(ngs(14)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb15 + +!*************************************************************************** + subroutine cmbgb16 +!*************************************************************************** +! +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +! +! old band 16: 2600-3000 cm-1 (low - h2o,ch4; high - nothing) +!*************************************************************************** + + use parrrtm_f, only : mg, nbndlw, ngptlw, ng16 + use rrlw_kg16_f, only: fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo, & + fracrefa, fracrefb, absa, ka, absb, kb, selfref, forref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(16) + sumk = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+240) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(16) + sumk = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+240) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(16) + sumk = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+240) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(16) + sumk = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+240) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(16) + sumf = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefbo(iprsm) + enddo + fracrefb(igc) = sumf + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(16) + sumf = 0. + do ipr = 1, ngn(ngs(15)+igc) + iprsm = iprsm + 1 + sumf = sumf + fracrefao(iprsm,jp) + enddo + fracrefa(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb16 + +!*************************************************************************** + subroutine lwcldpr +!*************************************************************************** + +! --------- Modules ---------- + + use rrlw_cld_f, only: abscld1, absliq0, absliq1, & + absice0, absice1, absice2, absice3 + + save + +! ABSCLDn is the liquid water absorption coefficient (m2/g). +! For INFLAG = 1. + abscld1 = 0.0602410 +! +! Everything below is for INFLAG = 2. + +! ABSICEn(J,IB) are the parameters needed to compute the liquid water +! absorption coefficient in spectral region IB for ICEFLAG=n. The units +! of ABSICEn(1,IB) are m2/g and ABSICEn(2,IB) has units (microns (m2/g)). +! For ICEFLAG = 0. + + absice0(:)= (/0.005 , 1.0 /) + +! For ICEFLAG = 1. + absice1(1,:) = (/0.0036 , 0.0068 , 0.0003 , 0.0016 , 0.0020 /) + absice1(2,:) = (/1.136 , 0.600 , 1.338 , 1.166 , 1.118 /) + +! For ICEFLAG = 2. In each band, the absorption +! coefficients are listed for a range of effective radii from 5.0 +! to 131.0 microns in increments of 3.0 microns. +! Spherical Ice Particle Parameterization +! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)] + absice2(:,1) = (/ & +! band 1 + 7.798999e-02 ,6.340479e-02 ,5.417973e-02 ,4.766245e-02 ,4.272663e-02 , & + 3.880939e-02 ,3.559544e-02 ,3.289241e-02 ,3.057511e-02 ,2.855800e-02 , & + 2.678022e-02 ,2.519712e-02 ,2.377505e-02 ,2.248806e-02 ,2.131578e-02 , & + 2.024194e-02 ,1.925337e-02 ,1.833926e-02 ,1.749067e-02 ,1.670007e-02 , & + 1.596113e-02 ,1.526845e-02 ,1.461739e-02 ,1.400394e-02 ,1.342462e-02 , & + 1.287639e-02 ,1.235656e-02 ,1.186279e-02 ,1.139297e-02 ,1.094524e-02 , & + 1.051794e-02 ,1.010956e-02 ,9.718755e-03 ,9.344316e-03 ,8.985139e-03 , & + 8.640223e-03 ,8.308656e-03 ,7.989606e-03 ,7.682312e-03 ,7.386076e-03 , & + 7.100255e-03 ,6.824258e-03 ,6.557540e-03 /) + absice2(:,2) = (/ & +! band 2 + 2.784879e-02 ,2.709863e-02 ,2.619165e-02 ,2.529230e-02 ,2.443225e-02 , & + 2.361575e-02 ,2.284021e-02 ,2.210150e-02 ,2.139548e-02 ,2.071840e-02 , & + 2.006702e-02 ,1.943856e-02 ,1.883064e-02 ,1.824120e-02 ,1.766849e-02 , & + 1.711099e-02 ,1.656737e-02 ,1.603647e-02 ,1.551727e-02 ,1.500886e-02 , & + 1.451045e-02 ,1.402132e-02 ,1.354084e-02 ,1.306842e-02 ,1.260355e-02 , & + 1.214575e-02 ,1.169460e-02 ,1.124971e-02 ,1.081072e-02 ,1.037731e-02 , & + 9.949167e-03 ,9.526021e-03 ,9.107615e-03 ,8.693714e-03 ,8.284096e-03 , & + 7.878558e-03 ,7.476910e-03 ,7.078974e-03 ,6.684586e-03 ,6.293589e-03 , & + 5.905839e-03 ,5.521200e-03 ,5.139543e-03 /) + absice2(:,3) = (/ & +! band 3 + 1.065397e-01 ,8.005726e-02 ,6.546428e-02 ,5.589131e-02 ,4.898681e-02 , & + 4.369932e-02 ,3.947901e-02 ,3.600676e-02 ,3.308299e-02 ,3.057561e-02 , & + 2.839325e-02 ,2.647040e-02 ,2.475872e-02 ,2.322164e-02 ,2.183091e-02 , & + 2.056430e-02 ,1.940407e-02 ,1.833586e-02 ,1.734787e-02 ,1.643034e-02 , & + 1.557512e-02 ,1.477530e-02 ,1.402501e-02 ,1.331924e-02 ,1.265364e-02 , & + 1.202445e-02 ,1.142838e-02 ,1.086257e-02 ,1.032445e-02 ,9.811791e-03 , & + 9.322587e-03 ,8.855053e-03 ,8.407591e-03 ,7.978763e-03 ,7.567273e-03 , & + 7.171949e-03 ,6.791728e-03 ,6.425642e-03 ,6.072809e-03 ,5.732424e-03 , & + 5.403748e-03 ,5.086103e-03 ,4.778865e-03 /) + absice2(:,4) = (/ & +! band 4 + 1.804566e-01 ,1.168987e-01 ,8.680442e-02 ,6.910060e-02 ,5.738174e-02 , & + 4.902332e-02 ,4.274585e-02 ,3.784923e-02 ,3.391734e-02 ,3.068690e-02 , & + 2.798301e-02 ,2.568480e-02 ,2.370600e-02 ,2.198337e-02 ,2.046940e-02 , & + 1.912777e-02 ,1.793016e-02 ,1.685420e-02 ,1.588193e-02 ,1.499882e-02 , & + 1.419293e-02 ,1.345440e-02 ,1.277496e-02 ,1.214769e-02 ,1.156669e-02 , & + 1.102694e-02 ,1.052412e-02 ,1.005451e-02 ,9.614854e-03 ,9.202335e-03 , & + 8.814470e-03 ,8.449077e-03 ,8.104223e-03 ,7.778195e-03 ,7.469466e-03 , & + 7.176671e-03 ,6.898588e-03 ,6.634117e-03 ,6.382264e-03 ,6.142134e-03 , & + 5.912913e-03 ,5.693862e-03 ,5.484308e-03 /) + absice2(:,5) = (/ & +! band 5 + 2.131806e-01 ,1.311372e-01 ,9.407171e-02 ,7.299442e-02 ,5.941273e-02 , & + 4.994043e-02 ,4.296242e-02 ,3.761113e-02 ,3.337910e-02 ,2.994978e-02 , & + 2.711556e-02 ,2.473461e-02 ,2.270681e-02 ,2.095943e-02 ,1.943839e-02 , & + 1.810267e-02 ,1.692057e-02 ,1.586719e-02 ,1.492275e-02 ,1.407132e-02 , & + 1.329989e-02 ,1.259780e-02 ,1.195618e-02 ,1.136761e-02 ,1.082583e-02 , & + 1.032552e-02 ,9.862158e-03 ,9.431827e-03 ,9.031157e-03 ,8.657217e-03 , & + 8.307449e-03 ,7.979609e-03 ,7.671724e-03 ,7.382048e-03 ,7.109032e-03 , & + 6.851298e-03 ,6.607615e-03 ,6.376881e-03 ,6.158105e-03 ,5.950394e-03 , & + 5.752942e-03 ,5.565019e-03 ,5.385963e-03 /) + absice2(:,6) = (/ & +! band 6 + 1.546177e-01 ,1.039251e-01 ,7.910347e-02 ,6.412429e-02 ,5.399997e-02 , & + 4.664937e-02 ,4.104237e-02 ,3.660781e-02 ,3.300218e-02 ,3.000586e-02 , & + 2.747148e-02 ,2.529633e-02 ,2.340647e-02 ,2.174723e-02 ,2.027731e-02 , & + 1.896487e-02 ,1.778492e-02 ,1.671761e-02 ,1.574692e-02 ,1.485978e-02 , & + 1.404543e-02 ,1.329489e-02 ,1.260066e-02 ,1.195636e-02 ,1.135657e-02 , & + 1.079664e-02 ,1.027257e-02 ,9.780871e-03 ,9.318505e-03 ,8.882815e-03 , & + 8.471458e-03 ,8.082364e-03 ,7.713696e-03 ,7.363817e-03 ,7.031264e-03 , & + 6.714725e-03 ,6.413021e-03 ,6.125086e-03 ,5.849958e-03 ,5.586764e-03 , & + 5.334707e-03 ,5.093066e-03 ,4.861179e-03 /) + absice2(:,7) = (/ & +! band 7 + 7.583404e-02 ,6.181558e-02 ,5.312027e-02 ,4.696039e-02 ,4.225986e-02 , & + 3.849735e-02 ,3.538340e-02 ,3.274182e-02 ,3.045798e-02 ,2.845343e-02 , & + 2.667231e-02 ,2.507353e-02 ,2.362606e-02 ,2.230595e-02 ,2.109435e-02 , & + 1.997617e-02 ,1.893916e-02 ,1.797328e-02 ,1.707016e-02 ,1.622279e-02 , & + 1.542523e-02 ,1.467241e-02 ,1.395997e-02 ,1.328414e-02 ,1.264164e-02 , & + 1.202958e-02 ,1.144544e-02 ,1.088697e-02 ,1.035218e-02 ,9.839297e-03 , & + 9.346733e-03 ,8.873057e-03 ,8.416980e-03 ,7.977335e-03 ,7.553066e-03 , & + 7.143210e-03 ,6.746888e-03 ,6.363297e-03 ,5.991700e-03 ,5.631422e-03 , & + 5.281840e-03 ,4.942378e-03 ,4.612505e-03 /) + absice2(:,8) = (/ & +! band 8 + 9.022185e-02 ,6.922700e-02 ,5.710674e-02 ,4.898377e-02 ,4.305946e-02 , & + 3.849553e-02 ,3.484183e-02 ,3.183220e-02 ,2.929794e-02 ,2.712627e-02 , & + 2.523856e-02 ,2.357810e-02 ,2.210286e-02 ,2.078089e-02 ,1.958747e-02 , & + 1.850310e-02 ,1.751218e-02 ,1.660205e-02 ,1.576232e-02 ,1.498440e-02 , & + 1.426107e-02 ,1.358624e-02 ,1.295474e-02 ,1.236212e-02 ,1.180456e-02 , & + 1.127874e-02 ,1.078175e-02 ,1.031106e-02 ,9.864433e-03 ,9.439878e-03 , & + 9.035637e-03 ,8.650140e-03 ,8.281981e-03 ,7.929895e-03 ,7.592746e-03 , & + 7.269505e-03 ,6.959238e-03 ,6.661100e-03 ,6.374317e-03 ,6.098185e-03 , & + 5.832059e-03 ,5.575347e-03 ,5.327504e-03 /) + absice2(:,9) = (/ & +! band 9 + 1.294087e-01 ,8.788217e-02 ,6.728288e-02 ,5.479720e-02 ,4.635049e-02 , & + 4.022253e-02 ,3.555576e-02 ,3.187259e-02 ,2.888498e-02 ,2.640843e-02 , & + 2.431904e-02 ,2.253038e-02 ,2.098024e-02 ,1.962267e-02 ,1.842293e-02 , & + 1.735426e-02 ,1.639571e-02 ,1.553060e-02 ,1.474552e-02 ,1.402953e-02 , & + 1.337363e-02 ,1.277033e-02 ,1.221336e-02 ,1.169741e-02 ,1.121797e-02 , & + 1.077117e-02 ,1.035369e-02 ,9.962643e-03 ,9.595509e-03 ,9.250088e-03 , & + 8.924447e-03 ,8.616876e-03 ,8.325862e-03 ,8.050057e-03 ,7.788258e-03 , & + 7.539388e-03 ,7.302478e-03 ,7.076656e-03 ,6.861134e-03 ,6.655197e-03 , & + 6.458197e-03 ,6.269543e-03 ,6.088697e-03 /) + absice2(:,10) = (/ & +! band 10 + 1.593628e-01 ,1.014552e-01 ,7.458955e-02 ,5.903571e-02 ,4.887582e-02 , & + 4.171159e-02 ,3.638480e-02 ,3.226692e-02 ,2.898717e-02 ,2.631256e-02 , & + 2.408925e-02 ,2.221156e-02 ,2.060448e-02 ,1.921325e-02 ,1.799699e-02 , & + 1.692456e-02 ,1.597177e-02 ,1.511961e-02 ,1.435289e-02 ,1.365933e-02 , & + 1.302890e-02 ,1.245334e-02 ,1.192576e-02 ,1.144037e-02 ,1.099230e-02 , & + 1.057739e-02 ,1.019208e-02 ,9.833302e-03 ,9.498395e-03 ,9.185047e-03 , & + 8.891237e-03 ,8.615185e-03 ,8.355325e-03 ,8.110267e-03 ,7.878778e-03 , & + 7.659759e-03 ,7.452224e-03 ,7.255291e-03 ,7.068166e-03 ,6.890130e-03 , & + 6.720536e-03 ,6.558794e-03 ,6.404371e-03 /) + absice2(:,11) = (/ & +! band 11 + 1.656227e-01 ,1.032129e-01 ,7.487359e-02 ,5.871431e-02 ,4.828355e-02 , & + 4.099989e-02 ,3.562924e-02 ,3.150755e-02 ,2.824593e-02 ,2.560156e-02 , & + 2.341503e-02 ,2.157740e-02 ,2.001169e-02 ,1.866199e-02 ,1.748669e-02 , & + 1.645421e-02 ,1.554015e-02 ,1.472535e-02 ,1.399457e-02 ,1.333553e-02 , & + 1.273821e-02 ,1.219440e-02 ,1.169725e-02 ,1.124104e-02 ,1.082096e-02 , & + 1.043290e-02 ,1.007336e-02 ,9.739338e-03 ,9.428223e-03 ,9.137756e-03 , & + 8.865964e-03 ,8.611115e-03 ,8.371686e-03 ,8.146330e-03 ,7.933852e-03 , & + 7.733187e-03 ,7.543386e-03 ,7.363597e-03 ,7.193056e-03 ,7.031072e-03 , & + 6.877024e-03 ,6.730348e-03 ,6.590531e-03 /) + absice2(:,12) = (/ & +! band 12 + 9.194591e-02 ,6.446867e-02 ,4.962034e-02 ,4.042061e-02 ,3.418456e-02 , & + 2.968856e-02 ,2.629900e-02 ,2.365572e-02 ,2.153915e-02 ,1.980791e-02 , & + 1.836689e-02 ,1.714979e-02 ,1.610900e-02 ,1.520946e-02 ,1.442476e-02 , & + 1.373468e-02 ,1.312345e-02 ,1.257858e-02 ,1.209010e-02 ,1.164990e-02 , & + 1.125136e-02 ,1.088901e-02 ,1.055827e-02 ,1.025531e-02 ,9.976896e-03 , & + 9.720255e-03 ,9.483022e-03 ,9.263160e-03 ,9.058902e-03 ,8.868710e-03 , & + 8.691240e-03 ,8.525312e-03 ,8.369886e-03 ,8.224042e-03 ,8.086961e-03 , & + 7.957917e-03 ,7.836258e-03 ,7.721400e-03 ,7.612821e-03 ,7.510045e-03 , & + 7.412648e-03 ,7.320242e-03 ,7.232476e-03 /) + absice2(:,13) = (/ & +! band 13 + 1.437021e-01 ,8.872535e-02 ,6.392420e-02 ,4.991833e-02 ,4.096790e-02 , & + 3.477881e-02 ,3.025782e-02 ,2.681909e-02 ,2.412102e-02 ,2.195132e-02 , & + 2.017124e-02 ,1.868641e-02 ,1.743044e-02 ,1.635529e-02 ,1.542540e-02 , & + 1.461388e-02 ,1.390003e-02 ,1.326766e-02 ,1.270395e-02 ,1.219860e-02 , & + 1.174326e-02 ,1.133107e-02 ,1.095637e-02 ,1.061442e-02 ,1.030126e-02 , & + 1.001352e-02 ,9.748340e-03 ,9.503256e-03 ,9.276155e-03 ,9.065205e-03 , & + 8.868808e-03 ,8.685571e-03 ,8.514268e-03 ,8.353820e-03 ,8.203272e-03 , & + 8.061776e-03 ,7.928578e-03 ,7.803001e-03 ,7.684443e-03 ,7.572358e-03 , & + 7.466258e-03 ,7.365701e-03 ,7.270286e-03 /) + absice2(:,14) = (/ & +! band 14 + 1.288870e-01 ,8.160295e-02 ,5.964745e-02 ,4.703790e-02 ,3.888637e-02 , & + 3.320115e-02 ,2.902017e-02 ,2.582259e-02 ,2.330224e-02 ,2.126754e-02 , & + 1.959258e-02 ,1.819130e-02 ,1.700289e-02 ,1.598320e-02 ,1.509942e-02 , & + 1.432666e-02 ,1.364572e-02 ,1.304156e-02 ,1.250220e-02 ,1.201803e-02 , & + 1.158123e-02 ,1.118537e-02 ,1.082513e-02 ,1.049605e-02 ,1.019440e-02 , & + 9.916989e-03 ,9.661116e-03 ,9.424457e-03 ,9.205005e-03 ,9.001022e-03 , & + 8.810992e-03 ,8.633588e-03 ,8.467646e-03 ,8.312137e-03 ,8.166151e-03 , & + 8.028878e-03 ,7.899597e-03 ,7.777663e-03 ,7.662498e-03 ,7.553581e-03 , & + 7.450444e-03 ,7.352662e-03 ,7.259851e-03 /) + absice2(:,15) = (/ & +! band 15 + 8.254229e-02 ,5.808787e-02 ,4.492166e-02 ,3.675028e-02 ,3.119623e-02 , & + 2.718045e-02 ,2.414450e-02 ,2.177073e-02 ,1.986526e-02 ,1.830306e-02 , & + 1.699991e-02 ,1.589698e-02 ,1.495199e-02 ,1.413374e-02 ,1.341870e-02 , & + 1.278883e-02 ,1.223002e-02 ,1.173114e-02 ,1.128322e-02 ,1.087900e-02 , & + 1.051254e-02 ,1.017890e-02 ,9.873991e-03 ,9.594347e-03 ,9.337044e-03 , & + 9.099589e-03 ,8.879842e-03 ,8.675960e-03 ,8.486341e-03 ,8.309594e-03 , & + 8.144500e-03 ,7.989986e-03 ,7.845109e-03 ,7.709031e-03 ,7.581007e-03 , & + 7.460376e-03 ,7.346544e-03 ,7.238978e-03 ,7.137201e-03 ,7.040780e-03 , & + 6.949325e-03 ,6.862483e-03 ,6.779931e-03 /) + absice2(:,16) = (/ & +! band 16 + 1.382062e-01 ,8.643227e-02 ,6.282935e-02 ,4.934783e-02 ,4.063891e-02 , & + 3.455591e-02 ,3.007059e-02 ,2.662897e-02 ,2.390631e-02 ,2.169972e-02 , & + 1.987596e-02 ,1.834393e-02 ,1.703924e-02 ,1.591513e-02 ,1.493679e-02 , & + 1.407780e-02 ,1.331775e-02 ,1.264061e-02 ,1.203364e-02 ,1.148655e-02 , & + 1.099099e-02 ,1.054006e-02 ,1.012807e-02 ,9.750215e-03 ,9.402477e-03 , & + 9.081428e-03 ,8.784143e-03 ,8.508107e-03 ,8.251146e-03 ,8.011373e-03 , & + 7.787140e-03 ,7.577002e-03 ,7.379687e-03 ,7.194071e-03 ,7.019158e-03 , & + 6.854061e-03 ,6.697986e-03 ,6.550224e-03 ,6.410138e-03 ,6.277153e-03 , & + 6.150751e-03 ,6.030462e-03 ,5.915860e-03 /) + +! ICEFLAG = 3; Fu parameterization. Particle size 5 - 140 micron in +! increments of 3 microns. +! units = m2/g +! Hexagonal Ice Particle Parameterization +! absorption units (abs coef/iwc): [(m^-1)/(g m^-3)] + absice3(:,1) = (/ & +! band 1 + 3.110649e-03 ,4.666352e-02 ,6.606447e-02 ,6.531678e-02 ,6.012598e-02 , & + 5.437494e-02 ,4.906411e-02 ,4.441146e-02 ,4.040585e-02 ,3.697334e-02 , & + 3.403027e-02 ,3.149979e-02 ,2.931596e-02 ,2.742365e-02 ,2.577721e-02 , & + 2.433888e-02 ,2.307732e-02 ,2.196644e-02 ,2.098437e-02 ,2.011264e-02 , & + 1.933561e-02 ,1.863992e-02 ,1.801407e-02 ,1.744812e-02 ,1.693346e-02 , & + 1.646252e-02 ,1.602866e-02 ,1.562600e-02 ,1.524933e-02 ,1.489399e-02 , & + 1.455580e-02 ,1.423098e-02 ,1.391612e-02 ,1.360812e-02 ,1.330413e-02 , & + 1.300156e-02 ,1.269801e-02 ,1.239127e-02 ,1.207928e-02 ,1.176014e-02 , & + 1.143204e-02 ,1.109334e-02 ,1.074243e-02 ,1.037786e-02 ,9.998198e-03 , & + 9.602126e-03 /) + absice3(:,2) = (/ & +! band 2 + 3.984966e-04 ,1.681097e-02 ,2.627680e-02 ,2.767465e-02 ,2.700722e-02 , & + 2.579180e-02 ,2.448677e-02 ,2.323890e-02 ,2.209096e-02 ,2.104882e-02 , & + 2.010547e-02 ,1.925003e-02 ,1.847128e-02 ,1.775883e-02 ,1.710358e-02 , & + 1.649769e-02 ,1.593449e-02 ,1.540829e-02 ,1.491429e-02 ,1.444837e-02 , & + 1.400704e-02 ,1.358729e-02 ,1.318654e-02 ,1.280258e-02 ,1.243346e-02 , & + 1.207750e-02 ,1.173325e-02 ,1.139941e-02 ,1.107487e-02 ,1.075861e-02 , & + 1.044975e-02 ,1.014753e-02 ,9.851229e-03 ,9.560240e-03 ,9.274003e-03 , & + 8.992020e-03 ,8.713845e-03 ,8.439074e-03 ,8.167346e-03 ,7.898331e-03 , & + 7.631734e-03 ,7.367286e-03 ,7.104742e-03 ,6.843882e-03 ,6.584504e-03 , & + 6.326424e-03 /) + absice3(:,3) = (/ & +! band 3 + 6.933163e-02 ,8.540475e-02 ,7.701816e-02 ,6.771158e-02 ,5.986953e-02 , & + 5.348120e-02 ,4.824962e-02 ,4.390563e-02 ,4.024411e-02 ,3.711404e-02 , & + 3.440426e-02 ,3.203200e-02 ,2.993478e-02 ,2.806474e-02 ,2.638464e-02 , & + 2.486516e-02 ,2.348288e-02 ,2.221890e-02 ,2.105780e-02 ,1.998687e-02 , & + 1.899552e-02 ,1.807490e-02 ,1.721750e-02 ,1.641693e-02 ,1.566773e-02 , & + 1.496515e-02 ,1.430509e-02 ,1.368398e-02 ,1.309865e-02 ,1.254634e-02 , & + 1.202456e-02 ,1.153114e-02 ,1.106409e-02 ,1.062166e-02 ,1.020224e-02 , & + 9.804381e-03 ,9.426771e-03 ,9.068205e-03 ,8.727578e-03 ,8.403876e-03 , & + 8.096160e-03 ,7.803564e-03 ,7.525281e-03 ,7.260560e-03 ,7.008697e-03 , & + 6.769036e-03 /) + absice3(:,4) = (/ & +! band 4 + 1.765735e-01 ,1.382700e-01 ,1.095129e-01 ,8.987475e-02 ,7.591185e-02 , & + 6.554169e-02 ,5.755500e-02 ,5.122083e-02 ,4.607610e-02 ,4.181475e-02 , & + 3.822697e-02 ,3.516432e-02 ,3.251897e-02 ,3.021073e-02 ,2.817876e-02 , & + 2.637607e-02 ,2.476582e-02 ,2.331871e-02 ,2.201113e-02 ,2.082388e-02 , & + 1.974115e-02 ,1.874983e-02 ,1.783894e-02 ,1.699922e-02 ,1.622280e-02 , & + 1.550296e-02 ,1.483390e-02 ,1.421064e-02 ,1.362880e-02 ,1.308460e-02 , & + 1.257468e-02 ,1.209611e-02 ,1.164628e-02 ,1.122287e-02 ,1.082381e-02 , & + 1.044725e-02 ,1.009154e-02 ,9.755166e-03 ,9.436783e-03 ,9.135163e-03 , & + 8.849193e-03 ,8.577856e-03 ,8.320225e-03 ,8.075451e-03 ,7.842755e-03 , & + 7.621418e-03 /) + absice3(:,5) = (/ & +! band 5 + 2.339673e-01 ,1.692124e-01 ,1.291656e-01 ,1.033837e-01 ,8.562949e-02 , & + 7.273526e-02 ,6.298262e-02 ,5.537015e-02 ,4.927787e-02 ,4.430246e-02 , & + 4.017061e-02 ,3.669072e-02 ,3.372455e-02 ,3.116995e-02 ,2.894977e-02 , & + 2.700471e-02 ,2.528842e-02 ,2.376420e-02 ,2.240256e-02 ,2.117959e-02 , & + 2.007567e-02 ,1.907456e-02 ,1.816271e-02 ,1.732874e-02 ,1.656300e-02 , & + 1.585725e-02 ,1.520445e-02 ,1.459852e-02 ,1.403419e-02 ,1.350689e-02 , & + 1.301260e-02 ,1.254781e-02 ,1.210941e-02 ,1.169468e-02 ,1.130118e-02 , & + 1.092675e-02 ,1.056945e-02 ,1.022757e-02 ,9.899560e-03 ,9.584021e-03 , & + 9.279705e-03 ,8.985479e-03 ,8.700322e-03 ,8.423306e-03 ,8.153590e-03 , & + 7.890412e-03 /) + absice3(:,6) = (/ & +! band 6 + 1.145369e-01 ,1.174566e-01 ,9.917866e-02 ,8.332990e-02 ,7.104263e-02 , & + 6.153370e-02 ,5.405472e-02 ,4.806281e-02 ,4.317918e-02 ,3.913795e-02 , & + 3.574916e-02 ,3.287437e-02 ,3.041067e-02 ,2.828017e-02 ,2.642292e-02 , & + 2.479206e-02 ,2.335051e-02 ,2.206851e-02 ,2.092195e-02 ,1.989108e-02 , & + 1.895958e-02 ,1.811385e-02 ,1.734245e-02 ,1.663573e-02 ,1.598545e-02 , & + 1.538456e-02 ,1.482700e-02 ,1.430750e-02 ,1.382150e-02 ,1.336499e-02 , & + 1.293447e-02 ,1.252685e-02 ,1.213939e-02 ,1.176968e-02 ,1.141555e-02 , & + 1.107508e-02 ,1.074655e-02 ,1.042839e-02 ,1.011923e-02 ,9.817799e-03 , & + 9.522962e-03 ,9.233688e-03 ,8.949041e-03 ,8.668171e-03 ,8.390301e-03 , & + 8.114723e-03 /) + absice3(:,7) = (/ & +! band 7 + 1.222345e-02 ,5.344230e-02 ,5.523465e-02 ,5.128759e-02 ,4.676925e-02 , & + 4.266150e-02 ,3.910561e-02 ,3.605479e-02 ,3.342843e-02 ,3.115052e-02 , & + 2.915776e-02 ,2.739935e-02 ,2.583499e-02 ,2.443266e-02 ,2.316681e-02 , & + 2.201687e-02 ,2.096619e-02 ,2.000112e-02 ,1.911044e-02 ,1.828481e-02 , & + 1.751641e-02 ,1.679866e-02 ,1.612598e-02 ,1.549360e-02 ,1.489742e-02 , & + 1.433392e-02 ,1.380002e-02 ,1.329305e-02 ,1.281068e-02 ,1.235084e-02 , & + 1.191172e-02 ,1.149171e-02 ,1.108936e-02 ,1.070341e-02 ,1.033271e-02 , & + 9.976220e-03 ,9.633021e-03 ,9.302273e-03 ,8.983216e-03 ,8.675161e-03 , & + 8.377478e-03 ,8.089595e-03 ,7.810986e-03 ,7.541170e-03 ,7.279706e-03 , & + 7.026186e-03 /) + absice3(:,8) = (/ & +! band 8 + 6.711058e-02 ,6.918198e-02 ,6.127484e-02 ,5.411944e-02 ,4.836902e-02 , & + 4.375293e-02 ,3.998077e-02 ,3.683587e-02 ,3.416508e-02 ,3.186003e-02 , & + 2.984290e-02 ,2.805671e-02 ,2.645895e-02 ,2.501733e-02 ,2.370689e-02 , & + 2.250808e-02 ,2.140532e-02 ,2.038609e-02 ,1.944018e-02 ,1.855918e-02 , & + 1.773609e-02 ,1.696504e-02 ,1.624106e-02 ,1.555990e-02 ,1.491793e-02 , & + 1.431197e-02 ,1.373928e-02 ,1.319743e-02 ,1.268430e-02 ,1.219799e-02 , & + 1.173682e-02 ,1.129925e-02 ,1.088393e-02 ,1.048961e-02 ,1.011516e-02 , & + 9.759543e-03 ,9.421813e-03 ,9.101089e-03 ,8.796559e-03 ,8.507464e-03 , & + 8.233098e-03 ,7.972798e-03 ,7.725942e-03 ,7.491940e-03 ,7.270238e-03 , & + 7.060305e-03 /) + absice3(:,9) = (/ & +! band 9 + 1.236780e-01 ,9.222386e-02 ,7.383997e-02 ,6.204072e-02 ,5.381029e-02 , & + 4.770678e-02 ,4.296928e-02 ,3.916131e-02 ,3.601540e-02 ,3.335878e-02 , & + 3.107493e-02 ,2.908247e-02 ,2.732282e-02 ,2.575276e-02 ,2.433968e-02 , & + 2.305852e-02 ,2.188966e-02 ,2.081757e-02 ,1.982974e-02 ,1.891599e-02 , & + 1.806794e-02 ,1.727865e-02 ,1.654227e-02 ,1.585387e-02 ,1.520924e-02 , & + 1.460476e-02 ,1.403730e-02 ,1.350416e-02 ,1.300293e-02 ,1.253153e-02 , & + 1.208808e-02 ,1.167094e-02 ,1.127862e-02 ,1.090979e-02 ,1.056323e-02 , & + 1.023786e-02 ,9.932665e-03 ,9.646744e-03 ,9.379250e-03 ,9.129409e-03 , & + 8.896500e-03 ,8.679856e-03 ,8.478852e-03 ,8.292904e-03 ,8.121463e-03 , & + 7.964013e-03 /) + absice3(:,10) = (/ & +! band 10 + 1.655966e-01 ,1.134205e-01 ,8.714344e-02 ,7.129241e-02 ,6.063739e-02 , & + 5.294203e-02 ,4.709309e-02 ,4.247476e-02 ,3.871892e-02 ,3.559206e-02 , & + 3.293893e-02 ,3.065226e-02 ,2.865558e-02 ,2.689288e-02 ,2.532221e-02 , & + 2.391150e-02 ,2.263582e-02 ,2.147549e-02 ,2.041476e-02 ,1.944089e-02 , & + 1.854342e-02 ,1.771371e-02 ,1.694456e-02 ,1.622989e-02 ,1.556456e-02 , & + 1.494415e-02 ,1.436491e-02 ,1.382354e-02 ,1.331719e-02 ,1.284339e-02 , & + 1.239992e-02 ,1.198486e-02 ,1.159647e-02 ,1.123323e-02 ,1.089375e-02 , & + 1.057679e-02 ,1.028124e-02 ,1.000607e-02 ,9.750376e-03 ,9.513303e-03 , & + 9.294082e-03 ,9.092003e-03 ,8.906412e-03 ,8.736702e-03 ,8.582314e-03 , & + 8.442725e-03 /) + absice3(:,11) = (/ & +! band 11 + 1.775615e-01 ,1.180046e-01 ,8.929607e-02 ,7.233500e-02 ,6.108333e-02 , & + 5.303642e-02 ,4.696927e-02 ,4.221206e-02 ,3.836768e-02 ,3.518576e-02 , & + 3.250063e-02 ,3.019825e-02 ,2.819758e-02 ,2.643943e-02 ,2.487953e-02 , & + 2.348414e-02 ,2.222705e-02 ,2.108762e-02 ,2.004936e-02 ,1.909892e-02 , & + 1.822539e-02 ,1.741975e-02 ,1.667449e-02 ,1.598330e-02 ,1.534084e-02 , & + 1.474253e-02 ,1.418446e-02 ,1.366325e-02 ,1.317597e-02 ,1.272004e-02 , & + 1.229321e-02 ,1.189350e-02 ,1.151915e-02 ,1.116859e-02 ,1.084042e-02 , & + 1.053338e-02 ,1.024636e-02 ,9.978326e-03 ,9.728357e-03 ,9.495613e-03 , & + 9.279327e-03 ,9.078798e-03 ,8.893383e-03 ,8.722488e-03 ,8.565568e-03 , & + 8.422115e-03 /) + absice3(:,12) = (/ & +! band 12 + 9.465447e-02 ,6.432047e-02 ,5.060973e-02 ,4.267283e-02 ,3.741843e-02 , & + 3.363096e-02 ,3.073531e-02 ,2.842405e-02 ,2.651789e-02 ,2.490518e-02 , & + 2.351273e-02 ,2.229056e-02 ,2.120335e-02 ,2.022541e-02 ,1.933763e-02 , & + 1.852546e-02 ,1.777763e-02 ,1.708528e-02 ,1.644134e-02 ,1.584009e-02 , & + 1.527684e-02 ,1.474774e-02 ,1.424955e-02 ,1.377957e-02 ,1.333549e-02 , & + 1.291534e-02 ,1.251743e-02 ,1.214029e-02 ,1.178265e-02 ,1.144337e-02 , & + 1.112148e-02 ,1.081609e-02 ,1.052642e-02 ,1.025178e-02 ,9.991540e-03 , & + 9.745130e-03 ,9.512038e-03 ,9.291797e-03 ,9.083980e-03 ,8.888195e-03 , & + 8.704081e-03 ,8.531306e-03 ,8.369560e-03 ,8.218558e-03 ,8.078032e-03 , & + 7.947730e-03 /) + absice3(:,13) = (/ & +! band 13 + 1.560311e-01 ,9.961097e-02 ,7.502949e-02 ,6.115022e-02 ,5.214952e-02 , & + 4.578149e-02 ,4.099731e-02 ,3.724174e-02 ,3.419343e-02 ,3.165356e-02 , & + 2.949251e-02 ,2.762222e-02 ,2.598073e-02 ,2.452322e-02 ,2.321642e-02 , & + 2.203516e-02 ,2.096002e-02 ,1.997579e-02 ,1.907036e-02 ,1.823401e-02 , & + 1.745879e-02 ,1.673819e-02 ,1.606678e-02 ,1.544003e-02 ,1.485411e-02 , & + 1.430574e-02 ,1.379215e-02 ,1.331092e-02 ,1.285996e-02 ,1.243746e-02 , & + 1.204183e-02 ,1.167164e-02 ,1.132567e-02 ,1.100281e-02 ,1.070207e-02 , & + 1.042258e-02 ,1.016352e-02 ,9.924197e-03 ,9.703953e-03 ,9.502199e-03 , & + 9.318400e-03 ,9.152066e-03 ,9.002749e-03 ,8.870038e-03 ,8.753555e-03 , & + 8.652951e-03 /) + absice3(:,14) = (/ & +! band 14 + 1.559547e-01 ,9.896700e-02 ,7.441231e-02 ,6.061469e-02 ,5.168730e-02 , & + 4.537821e-02 ,4.064106e-02 ,3.692367e-02 ,3.390714e-02 ,3.139438e-02 , & + 2.925702e-02 ,2.740783e-02 ,2.578547e-02 ,2.434552e-02 ,2.305506e-02 , & + 2.188910e-02 ,2.082842e-02 ,1.985789e-02 ,1.896553e-02 ,1.814165e-02 , & + 1.737839e-02 ,1.666927e-02 ,1.600891e-02 ,1.539279e-02 ,1.481712e-02 , & + 1.427865e-02 ,1.377463e-02 ,1.330266e-02 ,1.286068e-02 ,1.244689e-02 , & + 1.205973e-02 ,1.169780e-02 ,1.135989e-02 ,1.104492e-02 ,1.075192e-02 , & + 1.048004e-02 ,1.022850e-02 ,9.996611e-03 ,9.783753e-03 ,9.589361e-03 , & + 9.412924e-03 ,9.253977e-03 ,9.112098e-03 ,8.986903e-03 ,8.878039e-03 , & + 8.785184e-03 /) + absice3(:,15) = (/ & +! band 15 + 1.102926e-01 ,7.176622e-02 ,5.530316e-02 ,4.606056e-02 ,4.006116e-02 , & + 3.579628e-02 ,3.256909e-02 ,3.001360e-02 ,2.791920e-02 ,2.615617e-02 , & + 2.464023e-02 ,2.331426e-02 ,2.213817e-02 ,2.108301e-02 ,2.012733e-02 , & + 1.925493e-02 ,1.845331e-02 ,1.771269e-02 ,1.702531e-02 ,1.638493e-02 , & + 1.578648e-02 ,1.522579e-02 ,1.469940e-02 ,1.420442e-02 ,1.373841e-02 , & + 1.329931e-02 ,1.288535e-02 ,1.249502e-02 ,1.212700e-02 ,1.178015e-02 , & + 1.145348e-02 ,1.114612e-02 ,1.085730e-02 ,1.058633e-02 ,1.033263e-02 , & + 1.009564e-02 ,9.874895e-03 ,9.669960e-03 ,9.480449e-03 ,9.306014e-03 , & + 9.146339e-03 ,9.001138e-03 ,8.870154e-03 ,8.753148e-03 ,8.649907e-03 , & + 8.560232e-03 /) + absice3(:,16) = (/ & +! band 16 + 1.688344e-01 ,1.077072e-01 ,7.994467e-02 ,6.403862e-02 ,5.369850e-02 , & + 4.641582e-02 ,4.099331e-02 ,3.678724e-02 ,3.342069e-02 ,3.065831e-02 , & + 2.834557e-02 ,2.637680e-02 ,2.467733e-02 ,2.319286e-02 ,2.188299e-02 , & + 2.071701e-02 ,1.967121e-02 ,1.872692e-02 ,1.786931e-02 ,1.708641e-02 , & + 1.636846e-02 ,1.570743e-02 ,1.509665e-02 ,1.453052e-02 ,1.400433e-02 , & + 1.351407e-02 ,1.305631e-02 ,1.262810e-02 ,1.222688e-02 ,1.185044e-02 , & + 1.149683e-02 ,1.116436e-02 ,1.085153e-02 ,1.055701e-02 ,1.027961e-02 , & + 1.001831e-02 ,9.772141e-03 ,9.540280e-03 ,9.321966e-03 ,9.116517e-03 , & + 8.923315e-03 ,8.741803e-03 ,8.571472e-03 ,8.411860e-03 ,8.262543e-03 , & + 8.123136e-03 /) + +! For LIQFLAG = 0. + absliq0 = 0.0903614 + +! For LIQFLAG = 1. In each band, the absorption +! coefficients are listed for a range of effective radii from 2.5 +! to 59.5 microns in increments of 1.0 micron. + absliq1(:, 1) = (/ & +! band 1 + 1.64047e-03 , 6.90533e-02 , 7.72017e-02 , 7.78054e-02 , 7.69523e-02 , & + 7.58058e-02 , 7.46400e-02 , 7.35123e-02 , 7.24162e-02 , 7.13225e-02 , & + 6.99145e-02 , 6.66409e-02 , 6.36582e-02 , 6.09425e-02 , 5.84593e-02 , & + 5.61743e-02 , 5.40571e-02 , 5.20812e-02 , 5.02245e-02 , 4.84680e-02 , & + 4.67959e-02 , 4.51944e-02 , 4.36516e-02 , 4.21570e-02 , 4.07015e-02 , & + 3.92766e-02 , 3.78747e-02 , 3.64886e-02 , 3.53632e-02 , 3.41992e-02 , & + 3.31016e-02 , 3.20643e-02 , 3.10817e-02 , 3.01490e-02 , 2.92620e-02 , & + 2.84171e-02 , 2.76108e-02 , 2.68404e-02 , 2.61031e-02 , 2.53966e-02 , & + 2.47189e-02 , 2.40678e-02 , 2.34418e-02 , 2.28392e-02 , 2.22586e-02 , & + 2.16986e-02 , 2.11580e-02 , 2.06356e-02 , 2.01305e-02 , 1.96417e-02 , & + 1.91682e-02 , 1.87094e-02 , 1.82643e-02 , 1.78324e-02 , 1.74129e-02 , & + 1.70052e-02 , 1.66088e-02 , 1.62231e-02 /) + absliq1(:, 2) = (/ & +! band 2 + 2.19486e-01 , 1.80687e-01 , 1.59150e-01 , 1.44731e-01 , 1.33703e-01 , & + 1.24355e-01 , 1.15756e-01 , 1.07318e-01 , 9.86119e-02 , 8.92739e-02 , & + 8.34911e-02 , 7.70773e-02 , 7.15240e-02 , 6.66615e-02 , 6.23641e-02 , & + 5.85359e-02 , 5.51020e-02 , 5.20032e-02 , 4.91916e-02 , 4.66283e-02 , & + 4.42813e-02 , 4.21236e-02 , 4.01330e-02 , 3.82905e-02 , 3.65797e-02 , & + 3.49869e-02 , 3.35002e-02 , 3.21090e-02 , 3.08957e-02 , 2.97601e-02 , & + 2.86966e-02 , 2.76984e-02 , 2.67599e-02 , 2.58758e-02 , 2.50416e-02 , & + 2.42532e-02 , 2.35070e-02 , 2.27997e-02 , 2.21284e-02 , 2.14904e-02 , & + 2.08834e-02 , 2.03051e-02 , 1.97536e-02 , 1.92271e-02 , 1.87239e-02 , & + 1.82425e-02 , 1.77816e-02 , 1.73399e-02 , 1.69162e-02 , 1.65094e-02 , & + 1.61187e-02 , 1.57430e-02 , 1.53815e-02 , 1.50334e-02 , 1.46981e-02 , & + 1.43748e-02 , 1.40628e-02 , 1.37617e-02 /) + absliq1(:, 3) = (/ & +! band 3 + 2.95174e-01 , 2.34765e-01 , 1.98038e-01 , 1.72114e-01 , 1.52083e-01 , & + 1.35654e-01 , 1.21613e-01 , 1.09252e-01 , 9.81263e-02 , 8.79448e-02 , & + 8.12566e-02 , 7.44563e-02 , 6.86374e-02 , 6.36042e-02 , 5.92094e-02 , & + 5.53402e-02 , 5.19087e-02 , 4.88455e-02 , 4.60951e-02 , 4.36124e-02 , & + 4.13607e-02 , 3.93096e-02 , 3.74338e-02 , 3.57119e-02 , 3.41261e-02 , & + 3.26610e-02 , 3.13036e-02 , 3.00425e-02 , 2.88497e-02 , 2.78077e-02 , & + 2.68317e-02 , 2.59158e-02 , 2.50545e-02 , 2.42430e-02 , 2.34772e-02 , & + 2.27533e-02 , 2.20679e-02 , 2.14181e-02 , 2.08011e-02 , 2.02145e-02 , & + 1.96561e-02 , 1.91239e-02 , 1.86161e-02 , 1.81311e-02 , 1.76673e-02 , & + 1.72234e-02 , 1.67981e-02 , 1.63903e-02 , 1.59989e-02 , 1.56230e-02 , & + 1.52615e-02 , 1.49138e-02 , 1.45791e-02 , 1.42565e-02 , 1.39455e-02 , & + 1.36455e-02 , 1.33559e-02 , 1.30761e-02 /) + absliq1(:, 4) = (/ & +! band 4 + 3.00925e-01 , 2.36949e-01 , 1.96947e-01 , 1.68692e-01 , 1.47190e-01 , & + 1.29986e-01 , 1.15719e-01 , 1.03568e-01 , 9.30028e-02 , 8.36658e-02 , & + 7.71075e-02 , 7.07002e-02 , 6.52284e-02 , 6.05024e-02 , 5.63801e-02 , & + 5.27534e-02 , 4.95384e-02 , 4.66690e-02 , 4.40925e-02 , 4.17664e-02 , & + 3.96559e-02 , 3.77326e-02 , 3.59727e-02 , 3.43561e-02 , 3.28662e-02 , & + 3.14885e-02 , 3.02110e-02 , 2.90231e-02 , 2.78948e-02 , 2.69109e-02 , & + 2.59884e-02 , 2.51217e-02 , 2.43058e-02 , 2.35364e-02 , 2.28096e-02 , & + 2.21218e-02 , 2.14700e-02 , 2.08515e-02 , 2.02636e-02 , 1.97041e-02 , & + 1.91711e-02 , 1.86625e-02 , 1.81769e-02 , 1.77126e-02 , 1.72683e-02 , & + 1.68426e-02 , 1.64344e-02 , 1.60427e-02 , 1.56664e-02 , 1.53046e-02 , & + 1.49565e-02 , 1.46214e-02 , 1.42985e-02 , 1.39871e-02 , 1.36866e-02 , & + 1.33965e-02 , 1.31162e-02 , 1.28453e-02 /) + absliq1(:, 5) = (/ & +! band 5 + 2.64691e-01 , 2.12018e-01 , 1.78009e-01 , 1.53539e-01 , 1.34721e-01 , & + 1.19580e-01 , 1.06996e-01 , 9.62772e-02 , 8.69710e-02 , 7.87670e-02 , & + 7.29272e-02 , 6.70920e-02 , 6.20977e-02 , 5.77732e-02 , 5.39910e-02 , & + 5.06538e-02 , 4.76866e-02 , 4.50301e-02 , 4.26374e-02 , 4.04704e-02 , & + 3.84981e-02 , 3.66948e-02 , 3.50394e-02 , 3.35141e-02 , 3.21038e-02 , & + 3.07957e-02 , 2.95788e-02 , 2.84438e-02 , 2.73790e-02 , 2.64390e-02 , & + 2.55565e-02 , 2.47263e-02 , 2.39437e-02 , 2.32047e-02 , 2.25056e-02 , & + 2.18433e-02 , 2.12149e-02 , 2.06177e-02 , 2.00495e-02 , 1.95081e-02 , & + 1.89917e-02 , 1.84984e-02 , 1.80269e-02 , 1.75755e-02 , 1.71431e-02 , & + 1.67283e-02 , 1.63303e-02 , 1.59478e-02 , 1.55801e-02 , 1.52262e-02 , & + 1.48853e-02 , 1.45568e-02 , 1.42400e-02 , 1.39342e-02 , 1.36388e-02 , & + 1.33533e-02 , 1.30773e-02 , 1.28102e-02 /) + absliq1(:, 6) = (/ & +! band 6 + 8.81182e-02 , 1.06745e-01 , 9.79753e-02 , 8.99625e-02 , 8.35200e-02 , & + 7.81899e-02 , 7.35939e-02 , 6.94696e-02 , 6.56266e-02 , 6.19148e-02 , & + 5.83355e-02 , 5.49306e-02 , 5.19642e-02 , 4.93325e-02 , 4.69659e-02 , & + 4.48148e-02 , 4.28431e-02 , 4.10231e-02 , 3.93332e-02 , 3.77563e-02 , & + 3.62785e-02 , 3.48882e-02 , 3.35758e-02 , 3.23333e-02 , 3.11536e-02 , & + 3.00310e-02 , 2.89601e-02 , 2.79365e-02 , 2.70502e-02 , 2.62618e-02 , & + 2.55025e-02 , 2.47728e-02 , 2.40726e-02 , 2.34013e-02 , 2.27583e-02 , & + 2.21422e-02 , 2.15522e-02 , 2.09869e-02 , 2.04453e-02 , 1.99260e-02 , & + 1.94280e-02 , 1.89501e-02 , 1.84913e-02 , 1.80506e-02 , 1.76270e-02 , & + 1.72196e-02 , 1.68276e-02 , 1.64500e-02 , 1.60863e-02 , 1.57357e-02 , & + 1.53975e-02 , 1.50710e-02 , 1.47558e-02 , 1.44511e-02 , 1.41566e-02 , & + 1.38717e-02 , 1.35960e-02 , 1.33290e-02 /) + absliq1(:, 7) = (/ & +! band 7 + 4.32174e-02 , 7.36078e-02 , 6.98340e-02 , 6.65231e-02 , 6.41948e-02 , & + 6.23551e-02 , 6.06638e-02 , 5.88680e-02 , 5.67124e-02 , 5.38629e-02 , & + 4.99579e-02 , 4.86289e-02 , 4.70120e-02 , 4.52854e-02 , 4.35466e-02 , & + 4.18480e-02 , 4.02169e-02 , 3.86658e-02 , 3.71992e-02 , 3.58168e-02 , & + 3.45155e-02 , 3.32912e-02 , 3.21390e-02 , 3.10538e-02 , 3.00307e-02 , & + 2.90651e-02 , 2.81524e-02 , 2.72885e-02 , 2.62821e-02 , 2.55744e-02 , & + 2.48799e-02 , 2.42029e-02 , 2.35460e-02 , 2.29108e-02 , 2.22981e-02 , & + 2.17079e-02 , 2.11402e-02 , 2.05945e-02 , 2.00701e-02 , 1.95663e-02 , & + 1.90824e-02 , 1.86174e-02 , 1.81706e-02 , 1.77411e-02 , 1.73281e-02 , & + 1.69307e-02 , 1.65483e-02 , 1.61801e-02 , 1.58254e-02 , 1.54835e-02 , & + 1.51538e-02 , 1.48358e-02 , 1.45288e-02 , 1.42322e-02 , 1.39457e-02 , & + 1.36687e-02 , 1.34008e-02 , 1.31416e-02 /) + absliq1(:, 8) = (/ & +! band 8 + 1.41881e-01 , 7.15419e-02 , 6.30335e-02 , 6.11132e-02 , 6.01931e-02 , & + 5.92420e-02 , 5.78968e-02 , 5.58876e-02 , 5.28923e-02 , 4.84462e-02 , & + 4.60839e-02 , 4.56013e-02 , 4.45410e-02 , 4.31866e-02 , 4.17026e-02 , & + 4.01850e-02 , 3.86892e-02 , 3.72461e-02 , 3.58722e-02 , 3.45749e-02 , & + 3.33564e-02 , 3.22155e-02 , 3.11494e-02 , 3.01541e-02 , 2.92253e-02 , & + 2.83584e-02 , 2.75488e-02 , 2.67925e-02 , 2.57692e-02 , 2.50704e-02 , & + 2.43918e-02 , 2.37350e-02 , 2.31005e-02 , 2.24888e-02 , 2.18996e-02 , & + 2.13325e-02 , 2.07870e-02 , 2.02623e-02 , 1.97577e-02 , 1.92724e-02 , & + 1.88056e-02 , 1.83564e-02 , 1.79241e-02 , 1.75079e-02 , 1.71070e-02 , & + 1.67207e-02 , 1.63482e-02 , 1.59890e-02 , 1.56424e-02 , 1.53077e-02 , & + 1.49845e-02 , 1.46722e-02 , 1.43702e-02 , 1.40782e-02 , 1.37955e-02 , & + 1.35219e-02 , 1.32569e-02 , 1.30000e-02 /) + absliq1(:, 9) = (/ & +! band 9 + 6.72726e-02 , 6.61013e-02 , 6.47866e-02 , 6.33780e-02 , 6.18985e-02 , & + 6.03335e-02 , 5.86136e-02 , 5.65876e-02 , 5.39839e-02 , 5.03536e-02 , & + 4.71608e-02 , 4.63630e-02 , 4.50313e-02 , 4.34526e-02 , 4.17876e-02 , & + 4.01261e-02 , 3.85171e-02 , 3.69860e-02 , 3.55442e-02 , 3.41954e-02 , & + 3.29384e-02 , 3.17693e-02 , 3.06832e-02 , 2.96745e-02 , 2.87374e-02 , & + 2.78662e-02 , 2.70557e-02 , 2.63008e-02 , 2.52450e-02 , 2.45424e-02 , & + 2.38656e-02 , 2.32144e-02 , 2.25885e-02 , 2.19873e-02 , 2.14099e-02 , & + 2.08554e-02 , 2.03230e-02 , 1.98116e-02 , 1.93203e-02 , 1.88482e-02 , & + 1.83944e-02 , 1.79578e-02 , 1.75378e-02 , 1.71335e-02 , 1.67440e-02 , & + 1.63687e-02 , 1.60069e-02 , 1.56579e-02 , 1.53210e-02 , 1.49958e-02 , & + 1.46815e-02 , 1.43778e-02 , 1.40841e-02 , 1.37999e-02 , 1.35249e-02 , & + 1.32585e-02 , 1.30004e-02 , 1.27502e-02 /) + absliq1(:,10) = (/ & +! band 10 + 7.97040e-02 , 7.63844e-02 , 7.36499e-02 , 7.13525e-02 , 6.93043e-02 , & + 6.72807e-02 , 6.50227e-02 , 6.22395e-02 , 5.86093e-02 , 5.37815e-02 , & + 5.14682e-02 , 4.97214e-02 , 4.77392e-02 , 4.56961e-02 , 4.36858e-02 , & + 4.17569e-02 , 3.99328e-02 , 3.82224e-02 , 3.66265e-02 , 3.51416e-02 , & + 3.37617e-02 , 3.24798e-02 , 3.12887e-02 , 3.01812e-02 , 2.91505e-02 , & + 2.81900e-02 , 2.72939e-02 , 2.64568e-02 , 2.54165e-02 , 2.46832e-02 , & + 2.39783e-02 , 2.33017e-02 , 2.26531e-02 , 2.20314e-02 , 2.14359e-02 , & + 2.08653e-02 , 2.03187e-02 , 1.97947e-02 , 1.92924e-02 , 1.88106e-02 , & + 1.83483e-02 , 1.79043e-02 , 1.74778e-02 , 1.70678e-02 , 1.66735e-02 , & + 1.62941e-02 , 1.59286e-02 , 1.55766e-02 , 1.52371e-02 , 1.49097e-02 , & + 1.45937e-02 , 1.42885e-02 , 1.39936e-02 , 1.37085e-02 , 1.34327e-02 , & + 1.31659e-02 , 1.29075e-02 , 1.26571e-02 /) + absliq1(:,11) = (/ & +! band 11 + 1.49438e-01 , 1.33535e-01 , 1.21542e-01 , 1.11743e-01 , 1.03263e-01 , & + 9.55774e-02 , 8.83382e-02 , 8.12943e-02 , 7.42533e-02 , 6.70609e-02 , & + 6.38761e-02 , 5.97788e-02 , 5.59841e-02 , 5.25318e-02 , 4.94132e-02 , & + 4.66014e-02 , 4.40644e-02 , 4.17706e-02 , 3.96910e-02 , 3.77998e-02 , & + 3.60742e-02 , 3.44947e-02 , 3.30442e-02 , 3.17079e-02 , 3.04730e-02 , & + 2.93283e-02 , 2.82642e-02 , 2.72720e-02 , 2.61789e-02 , 2.53277e-02 , & + 2.45237e-02 , 2.37635e-02 , 2.30438e-02 , 2.23615e-02 , 2.17140e-02 , & + 2.10987e-02 , 2.05133e-02 , 1.99557e-02 , 1.94241e-02 , 1.89166e-02 , & + 1.84317e-02 , 1.79679e-02 , 1.75238e-02 , 1.70983e-02 , 1.66901e-02 , & + 1.62983e-02 , 1.59219e-02 , 1.55599e-02 , 1.52115e-02 , 1.48761e-02 , & + 1.45528e-02 , 1.42411e-02 , 1.39402e-02 , 1.36497e-02 , 1.33690e-02 , & + 1.30976e-02 , 1.28351e-02 , 1.25810e-02 /) + absliq1(:,12) = (/ & +! band 12 + 3.71985e-02 , 3.88586e-02 , 3.99070e-02 , 4.04351e-02 , 4.04610e-02 , & + 3.99834e-02 , 3.89953e-02 , 3.74886e-02 , 3.54551e-02 , 3.28870e-02 , & + 3.32576e-02 , 3.22444e-02 , 3.12384e-02 , 3.02584e-02 , 2.93146e-02 , & + 2.84120e-02 , 2.75525e-02 , 2.67361e-02 , 2.59618e-02 , 2.52280e-02 , & + 2.45327e-02 , 2.38736e-02 , 2.32487e-02 , 2.26558e-02 , 2.20929e-02 , & + 2.15579e-02 , 2.10491e-02 , 2.05648e-02 , 1.99749e-02 , 1.95704e-02 , & + 1.91731e-02 , 1.87839e-02 , 1.84032e-02 , 1.80315e-02 , 1.76689e-02 , & + 1.73155e-02 , 1.69712e-02 , 1.66362e-02 , 1.63101e-02 , 1.59928e-02 , & + 1.56842e-02 , 1.53840e-02 , 1.50920e-02 , 1.48080e-02 , 1.45318e-02 , & + 1.42631e-02 , 1.40016e-02 , 1.37472e-02 , 1.34996e-02 , 1.32586e-02 , & + 1.30239e-02 , 1.27954e-02 , 1.25728e-02 , 1.23559e-02 , 1.21445e-02 , & + 1.19385e-02 , 1.17376e-02 , 1.15417e-02 /) + absliq1(:,13) = (/ & +! band 13 + 3.11868e-02 , 4.48357e-02 , 4.90224e-02 , 4.96406e-02 , 4.86806e-02 , & + 4.69610e-02 , 4.48630e-02 , 4.25795e-02 , 4.02138e-02 , 3.78236e-02 , & + 3.74266e-02 , 3.60384e-02 , 3.47074e-02 , 3.34434e-02 , 3.22499e-02 , & + 3.11264e-02 , 3.00704e-02 , 2.90784e-02 , 2.81463e-02 , 2.72702e-02 , & + 2.64460e-02 , 2.56698e-02 , 2.49381e-02 , 2.42475e-02 , 2.35948e-02 , & + 2.29774e-02 , 2.23925e-02 , 2.18379e-02 , 2.11793e-02 , 2.07076e-02 , & + 2.02470e-02 , 1.97981e-02 , 1.93613e-02 , 1.89367e-02 , 1.85243e-02 , & + 1.81240e-02 , 1.77356e-02 , 1.73588e-02 , 1.69935e-02 , 1.66392e-02 , & + 1.62956e-02 , 1.59624e-02 , 1.56393e-02 , 1.53259e-02 , 1.50219e-02 , & + 1.47268e-02 , 1.44404e-02 , 1.41624e-02 , 1.38925e-02 , 1.36302e-02 , & + 1.33755e-02 , 1.31278e-02 , 1.28871e-02 , 1.26530e-02 , 1.24253e-02 , & + 1.22038e-02 , 1.19881e-02 , 1.17782e-02 /) + absliq1(:,14) = (/ & +! band 14 + 1.58988e-02 , 3.50652e-02 , 4.00851e-02 , 4.07270e-02 , 3.98101e-02 , & + 3.83306e-02 , 3.66829e-02 , 3.50327e-02 , 3.34497e-02 , 3.19609e-02 , & + 3.13712e-02 , 3.03348e-02 , 2.93415e-02 , 2.83973e-02 , 2.75037e-02 , & + 2.66604e-02 , 2.58654e-02 , 2.51161e-02 , 2.44100e-02 , 2.37440e-02 , & + 2.31154e-02 , 2.25215e-02 , 2.19599e-02 , 2.14282e-02 , 2.09242e-02 , & + 2.04459e-02 , 1.99915e-02 , 1.95594e-02 , 1.90254e-02 , 1.86598e-02 , & + 1.82996e-02 , 1.79455e-02 , 1.75983e-02 , 1.72584e-02 , 1.69260e-02 , & + 1.66013e-02 , 1.62843e-02 , 1.59752e-02 , 1.56737e-02 , 1.53799e-02 , & + 1.50936e-02 , 1.48146e-02 , 1.45429e-02 , 1.42782e-02 , 1.40203e-02 , & + 1.37691e-02 , 1.35243e-02 , 1.32858e-02 , 1.30534e-02 , 1.28270e-02 , & + 1.26062e-02 , 1.23909e-02 , 1.21810e-02 , 1.19763e-02 , 1.17766e-02 , & + 1.15817e-02 , 1.13915e-02 , 1.12058e-02 /) + absliq1(:,15) = (/ & +! band 15 + 5.02079e-03 , 2.17615e-02 , 2.55449e-02 , 2.59484e-02 , 2.53650e-02 , & + 2.45281e-02 , 2.36843e-02 , 2.29159e-02 , 2.22451e-02 , 2.16716e-02 , & + 2.11451e-02 , 2.05817e-02 , 2.00454e-02 , 1.95372e-02 , 1.90567e-02 , & + 1.86028e-02 , 1.81742e-02 , 1.77693e-02 , 1.73866e-02 , 1.70244e-02 , & + 1.66815e-02 , 1.63563e-02 , 1.60477e-02 , 1.57544e-02 , 1.54755e-02 , & + 1.52097e-02 , 1.49564e-02 , 1.47146e-02 , 1.43684e-02 , 1.41728e-02 , & + 1.39762e-02 , 1.37797e-02 , 1.35838e-02 , 1.33891e-02 , 1.31961e-02 , & + 1.30051e-02 , 1.28164e-02 , 1.26302e-02 , 1.24466e-02 , 1.22659e-02 , & + 1.20881e-02 , 1.19131e-02 , 1.17412e-02 , 1.15723e-02 , 1.14063e-02 , & + 1.12434e-02 , 1.10834e-02 , 1.09264e-02 , 1.07722e-02 , 1.06210e-02 , & + 1.04725e-02 , 1.03269e-02 , 1.01839e-02 , 1.00436e-02 , 9.90593e-03 , & + 9.77080e-03 , 9.63818e-03 , 9.50800e-03 /) + absliq1(:,16) = (/ & +! band 16 + 5.64971e-02 , 9.04736e-02 , 8.11726e-02 , 7.05450e-02 , 6.20052e-02 , & + 5.54286e-02 , 5.03503e-02 , 4.63791e-02 , 4.32290e-02 , 4.06959e-02 , & + 3.74690e-02 , 3.52964e-02 , 3.33799e-02 , 3.16774e-02 , 3.01550e-02 , & + 2.87856e-02 , 2.75474e-02 , 2.64223e-02 , 2.53953e-02 , 2.44542e-02 , & + 2.35885e-02 , 2.27894e-02 , 2.20494e-02 , 2.13622e-02 , 2.07222e-02 , & + 2.01246e-02 , 1.95654e-02 , 1.90408e-02 , 1.84398e-02 , 1.80021e-02 , & + 1.75816e-02 , 1.71775e-02 , 1.67889e-02 , 1.64152e-02 , 1.60554e-02 , & + 1.57089e-02 , 1.53751e-02 , 1.50531e-02 , 1.47426e-02 , 1.44428e-02 , & + 1.41532e-02 , 1.38734e-02 , 1.36028e-02 , 1.33410e-02 , 1.30875e-02 , & + 1.28420e-02 , 1.26041e-02 , 1.23735e-02 , 1.21497e-02 , 1.19325e-02 , & + 1.17216e-02 , 1.15168e-02 , 1.13177e-02 , 1.11241e-02 , 1.09358e-02 , & + 1.07525e-02 , 1.05741e-02 , 1.04003e-02 /) + + end subroutine lwcldpr + + end module rrtmg_lw_init_f + + module rrtmg_lw_rad_f + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2009, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- +! + +#ifdef _ACCEL + use cudafor +#endif + + use gpu_mcica_subcol_gen_lw + + use gpu_rrtmg_lw_rtrnmc + use gpu_rrtmg_lw_setcoef + use gpu_rrtmg_lw_cldprmc + + use gpu_rrtmg_lw_taumol, only: taumolg, copyGPUTaumol + use rrlw_cld_f, only: abscld1, absliq0, absliq1, & + absice0, absice1, absice2, absice3 + use rrlw_wvn_f, only: ngb, ngs + use rrlw_tbl_f, only: tblint, bpade, tau_tbl, exp_tbl, tfn_tbl, ntbl + use rrlw_con_f, only: fluxfac, heatfac, oneminus, pi, grav, avogad + use rrlw_vsn_f + + implicit none + +#ifdef _ACCEL + integer _gpudev, allocatable :: ngbd(:) + integer, allocatable _gpudev :: ncbandsd(:) + integer, allocatable _gpudev :: icbd(:) + integer, allocatable _gpudev :: icldlyr(:,:) + real _gpudev, allocatable :: fracsd(:,:,:) + real _gpudev, allocatable :: taug(:,:,:) +!$OMP THREADPRIVATE(ngbd,ncbandsd,icbd,icldlyr,fracsd,taug) +#endif + + real :: timings(10) + +!------------------------------------------------------------------ + contains +!------------------------------------------------------------------ + subroutine rrtmg_lw( & + ncol ,nlay ,icld ,idrv , & + play ,plev ,tlay ,tlev ,tsfc , & + h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , & + cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , & + inflglw ,iceflglw,liqflglw,cldfrac , & + tauc ,ciwp ,clwp ,cswp ,rei ,rel , res , & + tauaer , & + uflx ,dflx ,hr ,uflxc ,dflxc ,hrc , & + duflx_dt,duflxc_dt) +! -------- Description -------- + +! This program is the driver subroutine for RRTMG_LW, the AER LW radiation +! model for application to GCMs, that has been adapted from RRTM_LW for +! improved efficiency. +! +! NOTE: The call to RRTMG_LW_INI should be moved to the GCM initialization +! area, since this has to be called only once. +! +! This routine: +! a) calls INATM to read in the atmospheric profile from GCM; +! all layering in RRTMG is ordered from surface to toa. +! b) calls CLDPRMC to set cloud optical depth for McICA based +! on input cloud properties +! c) calls SETCOEF to calculate various quantities needed for +! the radiative transfer algorithm +! d) calls TAUMOL to calculate gaseous optical depths for each +! of the 16 spectral bands +! e) calls RTRNMC (for both clear and cloudy profiles) to perform the +! radiative transfer calculation using McICA, the Monte-Carlo +! Independent Column Approximation, to represent sub-grid scale +! cloud variability +! f) passes the necessary fluxes and cooling rates back to GCM +! +! Two modes of operation are possible: +! The mode is chosen by using either rrtmg_lw.nomcica.f90 (to not use +! McICA) or rrtmg_lw.f90 (to use McICA) to interface with a GCM. +! +! 1) Standard, single forward model calculation (imca = 0) +! 2) Monte Carlo Independent Column Approximation (McICA, Pincus et al., +! JC, 2003) method is applied to the forward model calculation (imca = 1) +! +! This call to RRTMG_LW must be preceeded by a call to the module +! mcica_subcol_gen_lw.f90 to run the McICA sub-column cloud generator, +! which will provide the cloud physical or cloud optical properties +! on the RRTMG quadrature point (ngpt) dimension. +! Two random number generators are available for use when imca = 1. +! This is chosen by setting flag irnd on input to mcica_subcol_gen_lw. +! 1) KISSVEC (irnd = 0) +! 2) Mersenne-Twister (irnd = 1) +! +! Two methods of cloud property input are possible: +! Cloud properties can be input in one of two ways (controlled by input +! flags inflglw, iceflglw, and liqflglw; see text file rrtmg_lw_instructions +! and subroutine rrtmg_lw_cldprmc.f90 for further details): +! +! 1) Input cloud fraction and cloud optical depth directly (inflglw = 0) +! 2) Input cloud fraction and cloud physical properties (inflglw = 1 or 2); +! cloud optical properties are calculated by cldprmc or cldprmc based +! on input settings of iceflglw and liqflglw. Ice particle size provided +! must be appropriately defined for the ice parameterization selected. +! +! One method of aerosol property input is possible: +! Aerosol properties can be input in only one way (controlled by input +! flag iaer; see text file rrtmg_lw_instructions for further details): +! +! 1) Input aerosol optical depth directly by layer and spectral band (iaer=10); +! band average optical depth at the mid-point of each spectral band. +! RRTMG_LW currently treats only aerosol absorption; +! scattering capability is not presently available. +! +! The optional calculation of the change in upward flux as a function of surface +! temperature is available (controlled by input flag idrv). This can be utilized +! to approximate adjustments to the upward flux profile caused only by a change in +! surface temperature between full radiation calls. This feature uses the pre- +! calculated derivative of the Planck function with respect to surface temperature. +! +! 1) Normal forward calculation for the input profile (idrv=0) +! 2) Normal forward calculation with optional calculation of the change +! in upward flux as a function of surface temperature for clear sky +! and total sky flux. Flux partial derivatives are provided in arrays +! duflx_dt and duflxc_dt for total and clear sky. (idrv=1) +! +! +! ------- Modifications ------- +! +! This version of RRTMG_LW has been modified from RRTM_LW to use a reduced +! set of g-points for application to GCMs. +! +!-- Original version (derived from RRTM_LW), reduction of g-points, other +! revisions for use with GCMs. +! 1999: M. J. Iacono, AER, Inc. +!-- Adapted for use with NCAR/CAM. +! May 2004: M. J. Iacono, AER, Inc. +!-- Revised to add McICA capability. +! Nov 2005: M. J. Iacono, AER, Inc. +!-- Conversion to F90 formatting for consistency with rrtmg_sw. +! Feb 2007: M. J. Iacono, AER, Inc. +!-- Modifications to formatting to use assumed-shape arrays. +! Aug 2007: M. J. Iacono, AER, Inc. +!-- Modified to add longwave aerosol absorption. +! Apr 2008: M. J. Iacono, AER, Inc. +!-- Added capability to calculate derivative of upward flux wrt surface temperature. +! Nov 2009: M. J. Iacono, E. J. Mlawer, AER, Inc. +!-- Added capability to run on GPU +! Aug 2012: David Berthiaume, AER, Inc. +! --------- Modules ---------- + + use parrrtm_f, only : nbndlw, ngptlw, maxxsec, mxmol, mxlay, nbndlw + use rrlw_con_f, only: fluxfac, heatfac, oneminus, pi + use rrlw_wvn_f, only: ng, ngb, nspa, nspb, wavenum1, wavenum2, delwave + +! ------- Declarations ------- + + ! integer , parameter:: maxlay = 203 + ! integer , parameter:: mxmol = 38 + + +! ----- Input ----- +! Note: All volume mixing ratios are in dimensionless units of mole fraction obtained +! by scaling mass mixing ratio (g/g) with the appropriate molecular weights (g/mol) + integer , intent(in) :: ncol ! Number of horizontal columns + integer , intent(in) :: nlay ! Number of model layers + integer , intent(inout) :: icld ! Cloud overlap method + ! 0: Clear only + ! 1: Random + ! 2: Maximum/random + ! 3: Maximum + ! 4: Exponential (inactive) + integer , intent(in) :: idrv ! Flag for calculation of dFdT, the change + ! in upward flux as a function of + ! surface temperature [0=off, 1=on] + ! 0: Normal forward calculation + ! 1: Normal forward calculation with + ! duflx_dt and duflxc_dt output + +! integer , intent(in) :: cloudMH, cloudHH ! cloud layer heights for cloudFlag + real , intent(in) :: play(:,:) ! Layer pressures (hPa, mb) + ! Dimensions: (ncol,nlay) + real , intent(in) :: plev(:,0:) ! Interface pressures (hPa, mb) + ! Dimensions: (ncol,nlay+1) + real , intent(in) :: tlay(:,:) ! Layer temperatures (K) + ! Dimensions: (ncol,nlay) + real , intent(in) :: tlev(:,0:) ! Interface temperatures (K) + ! Dimensions: (ncol,nlay+1) + real , intent(in) :: tsfc(:) ! Surface temperature (K) + ! Dimensions: (ncol) + real , intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: cfc11vmr(:, :) ! CFC11 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: cfc12vmr(:, :) ! CFC12 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: cfc22vmr(:, :) ! CFC22 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: ccl4vmr(:, :) ! CCL4 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: emis(:, :) ! Surface emissivity + ! Dimensions: (ncol,nbndlw) + + integer , intent(in) :: inflglw ! Flag for cloud optical properties + integer , intent(in) :: iceflglw ! Flag for ice particle specification + integer , intent(in) :: liqflglw ! Flag for liquid droplet specification + + real , intent(in) :: cldfrac(:,:) ! Cloud fraction + ! Dimensions: (ncol,nlay) + real , intent(in) :: ciwp(:,:) ! In-cloud ice water path (g/m2) + ! Dimensions: (ncol,nlay) + real , intent(in) :: clwp(:,:) ! In-cloud liquid water path (g/m2) + ! Dimensions: (ncol,nlay) + real , intent(in) :: cswp(:,:) ! In-cloud snow water path (g/m2) + ! Dimensions: (ncol,nlay) + real , intent(in) :: rei(:,:) ! Cloud ice particle effective size (microns) + ! Dimensions: (ncol,nlay) + ! specific definition of reicmcl depends on setting of iceflglw: + ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec must be >= 10.0 microns + ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflglw = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + real , intent(in) :: rel(:, :) ! Cloud water drop effective radius (microns) + ! Dimensions: (ncol,nlay) + real , intent(in) :: res(:, :) ! Cloud snow effective radius (microns) + ! Dimensions: (ncol,nlay) + real , intent(in) :: tauc(:, :, :) ! In-cloud optical depth + ! Dimensions: (ncol,nbndlw,nlay) + real , intent(in) :: tauaer(:,:,:) ! aerosol optical depth + ! at mid-point of LW spectral bands + ! Dimensions: (ncol,nlay,nbndlw) + +! ----- Output ----- + + real , intent(out) :: uflx(:,:) ! Total sky longwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: dflx(:,:) ! Total sky longwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: hr(:,:) ! Total sky longwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + real , intent(out) :: uflxc(:,:) ! Clear sky longwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: dflxc(:,:) ! Clear sky longwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: hrc(:,:) ! Clear sky longwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + +! ----- Optional Output ----- + real , intent(out), optional :: duflx_dt(:,:) + ! change in upward longwave flux (w/m2/K) + ! with respect to surface temperature + ! Dimensions: (ncol,nlay) + real , intent(out), optional :: duflxc_dt(:,:) + ! change in clear sky upward longwave flux (w/m2/K) + ! with respect to surface temperature + ! Dimensions: (ncol,nlay) +! integer , intent(out), optional :: cloudFlag(:,:) + + real, pointer :: alp(:,:) + + integer :: pncol + integer :: colstart + integer :: cn, ns, i, np, mns + real :: minmem + integer :: hetflag + integer :: numDevices, err + + integer :: numThreads +integer,external :: omp_get_thread_num + + ! Cuda device information +#ifdef _ACCEL + type(cudadeviceprop) :: prop +#endif + ! store the available device global and constant memory + real gmem, cmem +! mji - time + real t1,t2 + +!jm write(0,*)__FILE__,__LINE__,omp_get_thread_num() +#ifdef _ACCEL + + err = cudaGetDeviceProperties( prop, 0) + gmem = prop%totalGlobalMem +! print *, "total GPU global memory is ", gmem / (1024.0*1024.0) , "MB" + +#endif + +! (dmb 2012) Here we calculate the number of groups to partition +! the inputs. + +! determine the minimum GPU memory +! force the GPUFlag off if there are no devices available + +#ifdef _ACCEL + minmem = gmem +#else + +! on the CPU partiion the inputs into 2 GB chunks. Runtime +! is pretty constant on the CPU as a function of the number +! of steps, so we pick a quantity that uses a relatively low +! amount of CPU memory. + minmem = 2.0 * (1024.0**3) + +! set the number of 'devices' to the available number of CPUs +#endif +! print *, "available working memory is ", int(minmem / (1024*1024)) , " MB" + +#ifdef _ACCEL +! use the available memory to determine the minumum number +! of steps that will be required. +! We use 1500 profiles per available GB as a conservative +! lower bound. + cn = minmem * 1500 / (1024**3) + +! with device emulation (for debugging) make sure there is a lower +! limit to the number of supported columns + if (cn < 500) then + cn = 500 + end if +! Set number of columns per partition to be no larger than total number of columns + if (cn > ncol) then + cn = ncol + end if +#else + cn = CHNK +#endif +! + print *, "RRTMG_LWF: Number of columns is ", ncol + print *, "RRTMG_LWF: Number of columns per partition is ", cn + ns = ceiling( real(ncol) / real(cn) ) + print *, "RRTMG_LWF: Number of partitions is ", ns + +! mji - time + call cpu_time(t1) + + do i = 1, ns + +!jm if ( i .eq. IDEBUG_BASE ) then +!jm call setdebug +!jm else +!jm call unsetdebug +!jm endif + + + +!write(0,*)__FILE__,__LINE__,i + call rrtmg_lw_part & + (ns, ncol, (i-1)*cn + 1, min(cn, ncol - (i-1)*cn), & + nlay ,icld ,idrv,& + play ,plev ,tlay ,tlev ,tsfc , & + h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , & + cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , & + inflglw ,iceflglw,liqflglw,cldfrac , & + tauc ,ciwp ,clwp ,cswp ,rei ,rel ,res , & + tauaer , & + uflx ,dflx ,hr ,uflxc ,dflxc, hrc, & + duflx_dt,duflxc_dt) +!write(0,*)__FILE__,__LINE__,i,'uflx ',uflx(10,10) +!write(0,*)__FILE__,__LINE__,i,'dflx ',dflx(10,10) + end do + +! mji - time + call cpu_time(t2) + print *, "------------------------------------------------" + print *, "TOTAL RRTMG_LWF RUN TIME IS ", t2-t1 + print *, "------------------------------------------------" + + end subroutine + + subroutine rrtmg_lw_part & + (npart, ncol , colstart, pncol , & + nlay ,icld ,idrv , & + play ,plev ,tlay ,tlev ,tsfc , & + h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , & + cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , & + inflglw ,iceflglw,liqflglw,cldfrac , & + tauc ,ciwp ,clwp ,cswp ,rei ,rel ,res , & + tauaer , & + uflx ,dflx ,hr ,uflxc ,dflxc, hrc, & + duflx_dt,duflxc_dt) + + use gpu_mcica_subcol_gen_lw, only: mcica_subcol_lwg, generate_stochastic_cloudsg + + use parrrtm_f, only : nbndlw, ngptlw, maxxsec, mxmol, mxlay, nbndlw, nmol + use rrlw_con_f, only: fluxfac, heatfac, oneminus, pi + use rrlw_wvn_f, only: ng, ngb, nspa, nspb, wavenum1, wavenum2, delwave, ixindx + + +! ----- Input ----- +! Note: All volume mixing ratios are in dimensionless units of mole fraction obtained +! by scaling mass mixing ratio (g/g) with the appropriate molecular weights (g/mol) + integer , intent(in) :: npart + integer , intent(in) :: ncol ! Number of horizontal columns + integer , intent(in) :: nlay ! Number of model layers + integer , intent(inout) :: icld ! Cloud overlap method + ! 0: Clear only + ! 1: Random + ! 2: Maximum/random + ! 3: Maximum + ! 4: Exponential (inactive) + integer , intent(in) :: idrv ! Flag for calculation of dFdT, the change + ! in upward flux as a function of + ! surface temperature [0=off, 1=on] + ! 0: Normal forward calculation + ! 1: Normal forward calculation with + ! duflx_dt and duflxc_dt output + + real , intent(in) :: play(:,:) ! Layer pressures (hPa, mb) + ! Dimensions: (ncol,nlay) + real , intent(in) :: plev(:,0:) ! Interface pressures (hPa, mb) + ! Dimensions: (ncol,nlay+1) + real , intent(in) :: tlay(:,:) ! Layer temperatures (K) + ! Dimensions: (ncol,nlay) + real , intent(in) :: tlev(:,0:) ! Interface temperatures (K) + ! Dimensions: (ncol,nlay+1) + real , intent(in) :: tsfc(:) ! Surface temperature (K) + ! Dimensions: (ncol) + real , intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: cfc11vmr(:, :) ! CFC11 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: cfc12vmr(:, :) ! CFC12 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: cfc22vmr(:, :) ! CFC22 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: ccl4vmr(:, :) ! CCL4 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: emis(:, :) ! Surface emissivity + ! Dimensions: (ncol,nbndlw) + + integer , intent(in) :: inflglw ! Flag for cloud optical properties + integer , intent(in) :: iceflglw ! Flag for ice particle specification + integer , intent(in) :: liqflglw ! Flag for liquid droplet specification + + real , intent(in) :: cldfrac(:,:) ! Cloud fraction + ! Dimensions: (ngptlw,ncol,nlay) + real , intent(in) :: ciwp(:,:) ! In-cloud ice water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real , intent(in) :: clwp(:,:) ! In-cloud liquid water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real , intent(in) :: cswp(:,:) ! In-cloud snow water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real , intent(in) :: rei(:,:) ! Cloud ice particle effective size (microns) + ! Dimensions: (ncol,nlay) + ! specific definition of reicmcl depends on setting of iceflglw: + ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec must be >= 10.0 microns + ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflglw = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + real , intent(in) :: rel(:, :) ! Cloud water drop effective radius (microns) + ! Dimensions: (ncol,nlay) + real , intent(in) :: res(:, :) ! Cloud snow effective radius (microns) + ! Dimensions: (ncol,nlay) + real , intent(in) :: tauc(:, :,:) ! In-cloud optical depth + ! Dimensions: (ncol,nbndlw,nlay) + + real , intent(in) :: tauaer(:,:,:) ! aerosol optical depth + ! at mid-point of LW spectral bands + ! Dimensions: (ncol,nlay,nbndlw) + + integer , intent(in) :: pncol + integer , intent(in) :: colstart + +#ifndef _ACCEL +# define pncol CHNK +#endif + +! ----- Output ----- + + real , intent(out) :: uflx(:,:) ! Total sky longwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: dflx(:,:) ! Total sky longwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: hr(:,:) ! Total sky longwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + real , intent(out) :: uflxc(:,:) ! Clear sky longwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: dflxc(:,:) ! Clear sky longwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: hrc(:,:) ! Clear sky longwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + +! ----- Optional Output ----- + real , intent(out), optional :: duflx_dt(:,:) + ! change in upward longwave flux (w/m2/K) + ! with respect to surface temperature + ! Dimensions: (ncol,nlay) + real , intent(out), optional :: duflxc_dt(:,:) + ! change in clear sky upward longwave flux (w/m2/K) + ! with respect to surface temperature + ! Dimensions: (ncol,nlay) +! integer , intent(out), optional :: cloudFlag(:,:) +#ifdef _ACCEL + real _gpudeva :: cldfmcd(:,:,:) ! layer cloud fraction [mcica] + ! Dimensions: (ngptlw,nlayers) +#else + real :: cldfmcd(pncol, ngptlw, nlay+1) ! layer cloud fraction [mcica] + +#endif + +! ----- Local ----- + +#ifndef _ACCEL + integer ncol_,nlayers_,nbndlw_,ngptlw_ ! for passing through argument list + integer ncol__,nlayers__,nbndlw__,ngptlw__ ! for passing through argument list +! here is where the previously allocatable things are made local variables + real :: pmid(pncol, nlay) + + real :: relqmc(pncol, nlay+1), reicmc(pncol, nlay+1) + real :: resnmc(pncol, nlay+1) + + real :: ciwpmcd(pncol, ngptlw, nlay+1) + real :: clwpmcd(pncol, ngptlw, nlay+1) + real :: cswpmcd(pncol, ngptlw, nlay+1) + + real :: taucmcd(pncol, ngptlw, nlay+1) + real :: pzd(pncol, 0:nlay+1) + real :: pwvcmd(pncol) + real :: semissd(pncol, nbndlw) + real :: planklayd(pncol,nlay+1,nbndlw) + real :: planklevd(pncol, 0:nlay+1, nbndlw) + real :: plankbndd(pncol,nbndlw) + real :: gurad(pncol,ngptlw,0:nlay+1) ! upward longwave flux (w/m2) + real :: gdrad(pncol,ngptlw,0:nlay+1) ! downward longwave flux (w/m2) + real :: gclrurad(pncol,ngptlw,0:nlay+1) ! clear sky upward longwave flux (w/m2) + real :: gclrdrad(pncol,ngptlw,0:nlay+1) ! clear sky downward longwave flux (w/m2) + + real :: gdtotuflux_dtd( pncol, ngptlw, 0:nlay+1) + real :: gdtotuclfl_dtd( pncol, ngptlw, 0:nlay+1) + + real :: totufluxd(pncol, 0:nlay+1) ! upward longwave flux (w/m2) + real :: totdfluxd(pncol, 0:nlay+1) ! downward longwave flux (w/m2) + real :: fnetd(pncol, 0:nlay+1) ! net longwave flux (w/m2) + real :: htrd(pncol, 0:nlay+1) ! longwave heating rate (k/day) + real :: totuclfld(pncol, 0:nlay+1) ! clear sky upward longwave flux (w/m2) + real :: totdclfld(pncol, 0:nlay+1) ! clear sky downward longwave flux (w/m2) + real :: fnetcd(pncol, 0:nlay+1) ! clear sky net longwave flux (w/m2) + real :: htrcd(pncol, 0:nlay+1) ! clear sky longwave heating rate (k/day) + real :: dtotuflux_dtd(pncol, 0:nlay+1) ! change in upward longwave flux (w/m2/k) + real :: dtotuclfl_dtd(pncol, 0:nlay+1) + real :: dplankbnd_dtd(pncol,nbndlw) + + real :: taveld( pncol, nlay) + real :: tzd( pncol, 0:nlay) + real :: tboundd( pncol ) + real :: wbroadd( pncol, nlay) + + real :: wx1( pncol, nlay ) + real :: wx2( pncol, nlay ) + real :: wx3( pncol, nlay ) + real :: wx4( pncol, nlay ) + + real :: tauaa( pncol, nlay, nbndlw ) +!jm integer :: nspad( nbndlw ) +!jm integer :: nspbd( nbndlw ) + + integer :: icbd(16) + integer :: ncbandsd(pncol) + integer :: icldlyr(pncol, nlay+1) + real :: fracsd( pncol, nlay+1, ngptlw ) + real :: taug( pncol, nlay+1, ngptlw ) +#endif + + +! Control + integer(kind=4) :: nlayers ! total number of layers + integer(kind=4) :: istart ! beginning band of calculation + integer(kind=4) :: iend ! ending band of calculation + integer(kind=4) :: iout ! output option flag (inactive) + integer :: iaer ! aerosol option flag + integer(kind=4) :: iplon ! column loop index + integer :: imca ! flag for mcica [0=off, 1=on] + integer :: ims ! value for changing mcica permute seed + integer :: k ! layer loop index + integer :: ig ! g-point loop index + real :: t1, t2 + +! Atmosphere + real :: pavel(pncol,nlay+1) ! layer pressures (mb) + real :: tavel(pncol,nlay+1) ! layer temperatures (K) + real :: pz(pncol,0:nlay+1) ! level (interface) pressures (hPa, mb) + real :: tz(pncol,0:nlay+1) ! level (interface) temperatures (K) + real :: tbound(pncol) ! surface temperature (K) + real :: coldry(pncol,nlay+1) ! dry air column density (mol/cm2) + real :: wbrodl(pncol,nlay+1) ! broadening gas column density (mol/cm2) + real :: wkl(pncol,mxmol,nlay+1) ! molecular amounts (mol/cm-2) + real :: wx(pncol,maxxsec,nlay+1) ! cross-section amounts (mol/cm-2) + real :: pwvcm(pncol) ! precipitable water vapor (cm) + real :: semiss(pncol,nbndlw) ! lw surface emissivity + real :: fracs(pncol,nlay+1,ngptlw) ! + + real :: taut(pncol,nlay+1,ngptlw) ! gaseous + aerosol optical depths + + real :: taua(pncol,nlay+1,nbndlw) ! aerosol optical depth +! real :: ssaa(pncol,nlay+1,nbndlw) ! aerosol single scattering albedo + ! for future expansion + ! (lw aerosols/scattering not yet available) +! real :: asma(pncol,nlay+1,nbndlw) ! aerosol asymmetry parameter + ! for future expansion + ! (lw aerosols/scattering not yet available) + +! Atmosphere - setcoef + integer :: laytrop(pncol) ! tropopause layer index + integer :: jp(pncol,nlay+1) ! lookup table index + integer :: jt(pncol,nlay+1) ! lookup table index + integer :: jt1(pncol,nlay+1) ! lookup table index + real :: planklay(pncol,nlay+1,nbndlw) ! + real :: planklev(pncol,0:nlay+1,nbndlw) ! + real :: plankbnd(pncol,nbndlw) ! + real :: dplankbnd_dt(pncol,nbndlw) ! + + real :: colh2o(pncol,nlay+1) ! column amount (h2o) + real :: colco2(pncol,nlay+1) ! column amount (co2) + real :: colo3(pncol,nlay+1) ! column amount (o3) + real :: coln2o(pncol,nlay+1) ! column amount (n2o) + real :: colco(pncol,nlay+1) ! column amount (co) + real :: colch4(pncol,nlay+1) ! column amount (ch4) + real :: colo2(pncol,nlay+1) ! column amount (o2) + real :: colbrd(pncol,nlay+1) ! column amount (broadening gases) + + integer :: indself(pncol,nlay+1) + integer :: indfor(pncol,nlay+1) + real :: selffac(pncol,nlay+1) + real :: selffrac(pncol,nlay+1) + real :: forfac(pncol,nlay+1) + real :: forfrac(pncol,nlay+1) + + integer :: indminor(pncol,nlay+1) + real :: minorfrac(pncol,nlay+1) + real :: scaleminor(pncol,nlay+1) + real :: scaleminorn2(pncol,nlay+1) + + real :: & ! + fac00(pncol,nlay+1), fac01(pncol,nlay+1), & + fac10(pncol,nlay+1), fac11(pncol,nlay+1) + real :: & ! + rat_h2oco2(pncol,nlay+1),rat_h2oco2_1(pncol,nlay+1), & + rat_h2oo3(pncol,nlay+1),rat_h2oo3_1(pncol,nlay+1), & + rat_h2on2o(pncol,nlay+1),rat_h2on2o_1(pncol,nlay+1), & + rat_h2och4(pncol,nlay+1),rat_h2och4_1(pncol,nlay+1), & + rat_n2oco2(pncol,nlay+1),rat_n2oco2_1(pncol,nlay+1), & + rat_o3co2(pncol,nlay+1),rat_o3co2_1(pncol,nlay+1) + +! Atmosphere/clouds - cldprop + integer :: ncbands(pncol) ! number of cloud spectral bands + integer :: inflag(pncol) ! flag for cloud property method + integer :: iceflag(pncol) ! flag for ice cloud properties + integer :: liqflag(pncol) ! flag for liquid cloud properties + + +! Output + real :: totuflux(pncol,0:nlay+1) ! upward longwave flux (w/m2) + real :: totdflux(pncol,0:nlay+1) ! downward longwave flux (w/m2) + real :: fnet(pncol,0:nlay+1) ! net longwave flux (w/m2) + real :: htr(pncol,0:nlay+1) ! longwave heating rate (k/day) + real :: totuclfl(pncol,0:nlay+1) ! clear sky upward longwave flux (w/m2) + real :: totdclfl(pncol,0:nlay+1) ! clear sky downward longwave flux (w/m2) + real :: fnetc(pncol,0:nlay+1) ! clear sky net longwave flux (w/m2) + real :: htrc(pncol,0:nlay+1) ! clear sky longwave heating rate (k/day) + real :: dtotuflux_dt(pncol,0:nlay+1) ! change in upward longwave flux (w/m2/k) + ! with respect to surface temperature + real :: dtotuclfl_dt(pncol,0:nlay+1) ! change in clear sky upward longwave flux (w/m2/k) + ! with respect to surface temperature + real :: curad(pncol,ngptlw,0:nlay+1) ! upward longwave flux (w/m2) + real :: cdrad(pncol,ngptlw,0:nlay+1) ! downward longwave flux (w/m2) + real :: cclrurad(pncol,ngptlw,0:nlay+1) ! clear sky upward longwave flux (w/m2) + real :: cclrdrad(pncol,ngptlw,0:nlay+1) ! clear sky downward longwave flux (w/m2) + + real :: cldfracq(pncol,mxlay+1) ! Cloud fraction + ! Dimensions: (ngptlw,ncol,nlay) + real :: ciwpq(pncol,mxlay+1) ! In-cloud ice water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real :: clwpq(pncol,mxlay+1) ! In-cloud liquid water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real :: cswpq(pncol,mxlay+1) ! In-cloud snow water path (g/m2) + ! Dimensions: (ngptlw,ncol,nlay) + real :: reiq(pncol,mxlay) ! Cloud ice particle effective size (microns) + ! Dimensions: (ncol,nlay) + ! specific definition of reicmcl depends on setting of iceflglw: + ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec must be >= 10.0 microns + ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflglw = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + real :: relq(pncol, mxlay) ! Cloud water drop effective radius (microns) + ! Dimensions: (ncol,nlay) + real :: resq(pncol, mxlay) ! Cloud snow effective radius (microns) + ! Dimensions: (ncol,nlay) + real :: taucq(pncol, nbndlw, mxlay) ! In-cloud optical depth + ! Dimensions: (ncol,nbndlw,nlay) +! mji - tauaq dimensions? + real :: tauaq(pncol, mxlay, nbndlw) ! aerosol optical depth + ! Dimensions: (ncol,nlay,nbndlw) + + + integer :: permuteseed ! this is set, below + integer :: icb(16) + + ! local looping variables + integer :: i,j,kk, piplon + + ! cuda return code + integer :: ierr + ! cuda thread and grid block dimensions +#ifdef _ACCEL + type(dim3) :: dimGrid, dimBlock +#endif + + real , dimension(16) :: a0 =(/ 1.66 , 1.55 , 1.58 , 1.66 , & + 1.54 , 1.454 , 1.89 , 1.33 , & + 1.668 , 1.66 , 1.66 , 1.66 , & + 1.66 , 1.66 , 1.66 , 1.66 /) + real , dimension(16) :: a1=(/ 0.00 , 0.25 , 0.22 , 0.00 , & + 0.13 , 0.446 , -0.10 , 0.40 , & + -0.006 , 0.00 , 0.00 , 0.00 , & + 0.00 , 0.00 , 0.00 , 0.00 /) + real , dimension(16) :: a2 =(/ 0.00 , -12.0 , -11.7 , 0.00 , & + -0.72 ,-0.243 , 0.19 ,-0.062 , & + 0.414 , 0.00 , 0.00 , 0.00 , & + 0.00 , 0.00 , 0.00 , 0.00 /) + real , parameter :: amd = 28.9660 ! Effective molecular weight of dry air (g/mol) + real , parameter :: amw = 18.0160 ! Molecular weight of water vapor (g/mol) + +! (dmb 2012) these arrays were moved to the main routine so that we can bypass some of the +! inatm inefficiencies when running on the GPU + real , parameter :: amdw = 1.607793 ! Molecular weight of dry air / water vapor + real , parameter :: amdc = 0.658114 ! Molecular weight of dry air / carbon dioxide + real , parameter :: amdo = 0.603428 ! Molecular weight of dry air / ozone + real , parameter :: amdm = 1.805423 ! Molecular weight of dry air / methane + real , parameter :: amdn = 0.658090 ! Molecular weight of dry air / nitrous oxide + real , parameter :: amdo2 = 0.905140 ! Molecular weight of dry air / oxygen + real , parameter :: amdc1 = 0.210852 ! Molecular weight of dry air / CFC11 + real , parameter :: amdc2 = 0.239546 ! Molecular weight of dry air / CFC12 + real :: amm, amttl, wvttl, wvsh, summol + integer :: isp, l, ix, n, imol, ib ! Loop indices + integer, save :: counter =0 + real :: btemp +!real :: gwiff1,gwiff2,gwiff3,gwiff4 +!integer :: ilay, iplon, igp +! integer :: cloudFlagq(pncol, 4) + integer _gpudev :: pncold, nlayd, icldd +integer,external :: omp_get_thread_num + +! +!write(0,*)__FILE__,__LINE__ +#ifndef _ACCEL +# undef pncol + ncol_ = pncol ; nlayers_ = nlay ; nbndlw_ = nbndlw ; ngptlw_ = ngptlw ! for passing through argument list + ncol__ = pncol ; nlayers__ = nlay ; nbndlw__ = nbndlw ; ngptlw__ = ngptlw ! for passing through argument list +#endif +! Initializations + icb(:) = (/ 1,2,3,3,3,4,4,4,5, 5, 5, 5, 5, 5, 5, 5 /) + + oneminus = 1. - 1.e-6 + pi = 2. * asin(1. ) + fluxfac = pi * 2.e4 ! orig: fluxfac = pi * 2.d4 + istart = 1 + iend = 16 + iout = 0 + ims = 1 + pncold = pncol + nlayd = nlay + + cldfracq(1:pncol,1:nlay) = cldfrac(colstart:(colstart+pncol-1), 1:nlay) + ciwpq(1:pncol,1:nlay) = ciwp(colstart:(colstart+pncol-1), 1:nlay) + clwpq(1:pncol,1:nlay) = clwp(colstart:(colstart+pncol-1), 1:nlay) + cswpq(1:pncol,1:nlay) = cswp(colstart:(colstart+pncol-1), 1:nlay) + reiq(1:pncol,1:nlay) = rei(colstart:(colstart+pncol-1), 1:nlay) + relq(1:pncol,1:nlay) = rel(colstart:(colstart+pncol-1), 1:nlay) + resq(1:pncol,1:nlay) = res(colstart:(colstart+pncol-1), 1:nlay) + taucq(1:pncol,1:nbndlw,1:nlay) = tauc(colstart:(colstart+pncol-1), 1:nbndlw, 1:nlay) + tauaq(1:pncol,1:nlay,1:nbndlw) = tauaer(colstart:(colstart+pncol-1), 1:nlay, 1:nbndlw) + +#ifdef _ACCEL + allocate( cldfmcd(pncol, ngptlw, nlay+1)) + allocate( ngbd(140) ) +#endif + + +#ifndef _ACCEL +# define pncol CHNK +#endif +#ifdef _ACCEL + allocate( icbd(16)) + allocate( ncbandsd(pncol)) + allocate( icldlyr(pncol, nlay+1)) + +!write(0,*)__FILE__,__LINE__ + call allocateGPUcldprmcg(pncol, nlay, ngptlw) + call allocateGPUrtrnmcg(pncol, nlay, ngptlw, idrv) +!write(0,*)__FILE__,__LINE__ + + ngbd = ngb + ngsd = ngs + icldd = icld +#else +# define nspad nspa +# define nspbd nspb +# define icbd icb +# define fracsd fracs +# define ngbd ngb +# define ngsd ngs +# define icldd icld +#endif + +! Set imca to select calculation type: +! imca = 0, use standard forward model calculation +! imca = 1, use McICA for Monte Carlo treatment of sub-grid cloud variability + +! *** This version uses McICA (imca = 1) *** + +! Set icld to select of clear or cloud calculation and cloud overlap method +! icld = 0, clear only +! icld = 1, with clouds using random cloud overlap +! icld = 2, with clouds using maximum/random cloud overlap +! icld = 3, with clouds using maximum cloud overlap (McICA only) +! icld = 4, with clouds using exponential cloud overlap (INACTIVE; McICA only) + if (icld.lt.0.or.icld.gt.4) icld = 2 + +! Set iaer to select aerosol option +! iaer = 0, no aerosols +! icld = 10, input total aerosol optical depth (tauaer) directly + iaer = 10 + +! Call model and data initialization, compute lookup tables, perform +! reduction of g-points from 256 to 140 for input absorption coefficient +! data and other arrays. +! +! In a GCM this call should be placed in the model initialization +! area, since this has to be called only once. +! call rrtmg_lw_ini(cpdair) + +! call rrtmg_lw_ini(1.004 ) +! This is the main longitude/column loop within RRTMG. +! Prepare atmospheric profile from GCM for use in RRTMG, and define +! other input parameters. + +! (dmb 2012) + + nlayers = nlay + + +!write(0,*)__FILE__,__LINE__ + call allocateGPUTaumol( pncol, nlayers, npart) +!write(0,*)__FILE__,__LINE__ + +#ifdef _ACCEL + allocate( fracsd( pncol, nlayers+1, ngptlw )) + allocate( taug( pncol, nlayers+1, ngptlw )) +#endif +!write(0,*)__FILE__,__LINE__ + tbound = tsfc(colstart:(colstart+pncol-1)) + pz(:,0:nlay) = plev(colstart:(colstart+pncol-1),0:nlay) + tz(:,0:nlay) = tlev(colstart:(colstart+pncol-1),0:nlay) + pavel(:,1:nlay) = play(colstart:(colstart+pncol-1),1:nlay) + tavel(:,1:nlay) = tlay(colstart:(colstart+pncol-1),1:nlay) +!write(0,*)__FILE__,__LINE__ + +#ifdef _ACCEL + call copyGPUTaumolMol( colstart, pncol, nlayers, h2ovmr, co2vmr, o3vmr, n2ovmr, ch4vmr, & + o2vmr, ccl4vmr, cfc11vmr, cfc12vmr, cfc22vmr, npart) +#else + colh2o(1:pncol, 1:nlayers) = h2ovmr( colstart:(colstart+pncol-1), 1:nlayers) + colco2(1:pncol, 1:nlayers) = co2vmr( colstart:(colstart+pncol-1), 1:nlayers) + colo3(1:pncol, 1:nlayers) = o3vmr( colstart:(colstart+pncol-1), 1:nlayers) + coln2o(1:pncol, 1:nlayers) = n2ovmr( colstart:(colstart+pncol-1), 1:nlayers) + + colch4(1:pncol, 1:nlayers) = ch4vmr( colstart:(colstart+pncol-1), 1:nlayers) + colo2(1:pncol, 1:nlayers) = o2vmr( colstart:(colstart+pncol-1), 1:nlayers) + wx1(1:pncol, 1:nlayers) = ccl4vmr(colstart:(colstart+pncol-1), 1:nlayers) + wx2(1:pncol, 1:nlayers) = cfc11vmr(colstart:(colstart+pncol-1), 1:nlayers) + wx3(1:pncol, 1:nlayers) = cfc12vmr(colstart:(colstart+pncol-1), 1:nlayers) + wx4(1:pncol, 1:nlayers) = cfc22vmr(colstart:(colstart+pncol-1), 1:nlayers) + colco(1:pncol, :) = 0 + if (npart > 1) then + tauaa(1:pncol, :, :) = tauaer(colstart:(colstart+pncol-1), :, :) + else + tauaa = tauaer + endif +#endif + +#ifndef _ACCEL +# undef pncol +#endif + +!write(0,*)__FILE__,__LINE__ + permuteseed=150 ! if you change this, change value in module_ra_rrtmg_lw.F + call mcica_subcol_lwg(colstart, pncol, nlay, icld, counter, permuteseed, & +#ifndef _ACCEL + pmid,clwp,ciwp,cswp,tauc, & +#endif + play, cldfracq, ciwpq, & + clwpq, cswpq, taucq,ngbd, cldfmcd, ciwpmcd, clwpmcd, cswpmcd, & + taucmcd) +!write(0,*)__FILE__,__LINE__ +!jm write(0,*)__FILE__,__LINE__,omp_get_thread_num() + +! Generate the stochastic subcolumns of cloud optical properties for the longwave; +#ifdef _ACCEL + dimGrid = dim3( (ncol+255)/256,(140+1)/2, 1) + dimBlock = dim3( 256,2,1) +#endif + if (icld > 0) then +!write(0,*)__FILE__,__LINE__ + call generate_stochastic_cloudsg _gpuchv (pncold, nlayd, icldd, ngbd, & +#ifndef _ACCEL + pmid,cldfracq,clwpq,ciwpq,cswpq,taucq,permuteseed, & +#endif + cldfmcd, clwpmcd, ciwpmcd, cswpmcd, taucmcd) +!write(0,*)__FILE__,__LINE__ + end if +!write(0,*)__FILE__,__LINE__ + +!jm write(0,*)__FILE__,__LINE__,omp_get_thread_num() + do iplon = 1, pncol + + piplon = iplon + colstart - 1 + amttl = 0.0 + wvttl = 0.0 + do l = 1, nlayers + amm = (1. - h2ovmr(piplon,l)) * amd +h2ovmr(piplon,l) * amw + coldry(iplon, l) = (pz(iplon, l-1)-pz(iplon, l)) * 1.e3 * avogad / & + (1.e2 * grav * amm * (1. + h2ovmr(piplon,l))) + end do + + do l = 1, nlayers + summol = co2vmr(piplon,l) + o3vmr(piplon,l) + n2ovmr(piplon,l) + ch4vmr(piplon,l) + o2vmr(piplon,l) + btemp = h2ovmr(piplon, l) * coldry(iplon, l) + wbrodl(iplon, l) = coldry(iplon, l) * (1. - summol) + amttl = amttl + coldry(iplon, l)+btemp + wvttl = wvttl + btemp + enddo + + wvsh = (amw * wvttl) / (amd * amttl) + pwvcm(iplon) = wvsh * (1.e3 * pz(iplon, 0)) / (1.e2 * grav) + +! Transfer aerosol optical properties to RRTM variable; +! modify to reverse layer indexing here if necessary. + + if (icld .ge. 1) then + inflag(iplon) = inflglw + iceflag(iplon) = iceflglw + liqflag(iplon) = liqflglw + +! Move incoming GCM cloud arrays to RRTMG cloud arrays. +! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflglw) + + endif + enddo + +!write(0,*)__FILE__,__LINE__ +#ifdef _ACCEL + deallocate( pmidd, cldfracd) + deallocate( clwpd, ciwpd, cswpd, taucd) + +! For cloudy atmosphere, use cldprmc to set cloud optical properties based on +! input cloud physical properties. Select method based on choices described +! in cldprmc. Cloud fraction, water path, liquid droplet and ice particle +! effective radius must be passed into cldprmc. Cloud fraction and cloud +! optical depth are transferred to rrtmg_lw arrays in cldprmc. + +! If the GPU flag is active, then we call the GPU code. Otherwise, call the CPU code + +! (dmb 2012) Copy the needed arrays over to the GPU for the cldprmc subroutine. + call copyGPUcldprmcg( inflag, iceflag, liqflag,& + absice0, absice1, absice2, absice3, absliq1 ) + +! copy common arrays over to the GPU + icbd = icb + a0d=a0 + a1d=a1 + a2d=a2 + delwaved=delwave + relqmcd = relq + reicmcd = reiq + resnmcd = resq +#else +# define a0d a0 +# define a1d a1 +# define a2d a2 +# define delwaved delwave +# define relqmcd relq +# define reicmcd reiq +# define resnmcd resq +#endif + + icldlyr = 0.0 + +#ifdef _ACCEL +! (dmb 2012) Allocate the arrays for the SetCoef and Taumol kernels + call allocateGPUSetCoef( pncol, nlayers) + +! (dmb 2012) Copy the needed data of to the GPU for the SetCoef and Taumol kernels + +!write(0,*)__FILE__,__LINE__ + call copyGPUTaumol( pavel, wx, coldry, tauaer, pncol, colstart, nlay , npart) +!write(0,*)__FILE__,__LINE__ + + call copyGPUSetCoef( ) +! (dmb 2012) Copy over additional common arrays + taveld = tavel + tzd = tz + tboundd = tbound + wbroadd = wbrodl +! wkld = wkl + semissd(1:pncol,1:nbndlw) = emis(colstart:(colstart+pncol-1),1:nbndlw) + + call copyToGPUref() + call copyGPUrtrnmcg(pz, pwvcm, idrv, taut) +#else + + semissd(1:pncol,1:nbndlw) = emis(colstart:(colstart+pncol-1),1:nbndlw) + +# define tzd tz +# define taveld tavel +# define tboundd tbound +# define wbroadd wbrodl + +# define pzd pz +# define pwvcmd pwvcm +# define idrvd idrv +# define bpaded bpade +# define heatfacd heatfac +# define fluxfacd fluxfac +# define oneminusd oneminus +#endif + +! (dmb 2012) Here we configure the grids and blocks to run the cldpmcd kernel +! on the GPU. I decided to keep the block dimensions to 16x16 to coincide with +! coalesced memory access when I am able to parition the profiles to multiples +! of 32. +#ifdef _ACCEL + dimGrid = dim3( (pncol+255)/256,(nlayers)/1, ngptlw) + dimBlock = dim3( 256,1,1) +#endif +! clwpmcd = 0 +! clwpmcd = clwpmc +! (dmb 2012) Call the cldprmcg kernel +!write(0,*)__FILE__,__LINE__ + call cldprmcg _gpuchv (pncol, nlayers, & +#ifndef _ACCEL + inflag,iceflag,liqflag,ciwpmcd,clwpmcd,cswpmcd,relqmcd,reicmcd,resnmcd, & + absice0,absice1,absice2,absice3,absliq1, & +#endif + cldfmcd, taucmcd, ngbd, icbd, ncbandsd, icldlyr) + +!write(0,*)__FILE__,__LINE__ +! synchronize the GPU with the CPU before taking timing results or passing data back to the CPU +#ifdef _ACCEL + ierr = cudaThreadSynchronize() +#endif + + +! Calculate information needed by the radiative transfer routine +! that is specific to this atmosphere, especially some of the +! coefficients and indices needed to compute the optical depths +! by interpolating data from stored reference atmospheres. + +! (dmb 2012) Initialize the grid and block dimensions and call the setcoefg kernel +#ifdef _ACCEL + dimGrid = dim3( (pncol+255)/256,1, 1) + dimBlock = dim3( 256,1,1) +#endif + call setcoefg _gpuchv (pncol, nlayers, istart & +# include "rrtmg_lw_cpu_args.h" +# include "taug_cpu_args.h" +#ifndef _ACCEL + ,tavel,tz,tbound,wbroadd,totplnk,totplk16,totplnkderiv,totplk16deriv & +#endif + ) +!write(0,*)__FILE__,__LINE__ + +! (dmb 2012) end if GPU flag + +! Calculate the gaseous optical depths and Planck fractions for +! each longwave spectral band. + +! (dmb 2012) Call the taumolg subroutine. This subroutine calls all of the individal taumol kernels. + call taumolg(1, pncol,nlayers, ngbd, taug, fracsd & +# include "taug_cpu_args.h" + ) + +! Call the radiative transfer routine. +! Either routine can be called to do clear sky calculation. If clouds +! are present, then select routine based on cloud overlap assumption +! to be used. Clear sky calculation is done simultaneously. +! For McICA, RTRNMC is called for clear and cloudy calculations. + + +#ifdef _ACCEL + ierr = cudaThreadSynchronize() +#endif + +#ifdef _ACCEL + dimGrid = dim3( (pncol+255)/256, 70, 1) + dimBlock = dim3( 256,2,1) +#endif + + call rtrnmcg _gpuchv (pncol,nlayers, istart, iend, iout & +#include "rrtmg_lw_cpu_args.h" + ,ngbd, icldlyr, taug, fracsd, cldfmcd) + +#ifdef _ACCEL + ierr = cudaThreadSynchronize() +#endif + +!jm write(0,*)__FILE__,__LINE__,omp_get_thread_num() + +! sum up the results + + totufluxd = 0.0 + totdfluxd = 0.0 + totuclfld = 0.0 + totdclfld = 0.0 + dtotuflux_dtd = 0.0 + dtotuclfl_dtd = 0.0 + +#ifdef _ACCEL + dimGrid = dim3( (pncol+255)/256,nlayers+1,1) + dimBlock = dim3( 256, 1, 1) +#endif + +!!zap +!do ierr = 1, ngptlw +!write(0,*)'gurad before rtrnadd',gurad(5,ierr,1) +!enddo +!ierr = 0 +!!zap + uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,1:(nlayers+1)) +!write(0,*)__FILE__,__LINE__,i,'uflx ',uflx(10,10) + dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,1:(nlayers+1)) +!write(0,*)__FILE__,__LINE__,i,'dflx ',dflx(10,10) + +!write(0,*)__FILE__,__LINE__ + +! (dmb 2012) Here we integrate across the g-point fluxes to arrive at total fluxes +! This functionality was factored out of the original rtrnmc routine so that I could +! parallelize across multiple dimensions. +!write(0,*)__FILE__,__LINE__,i,'totufluxd ',totufluxd(10,10) +!write(0,*)__FILE__,__LINE__,i,'totdfluxd ',totdfluxd(10,10) + call rtrnadd _gpuchv (pncol, nlayers, ngptlw, idrv & +#include "rrtmg_lw_cpu_args.h" + ) + uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,1:(nlayers+1)) +!write(0,*)__FILE__,__LINE__,'uflx ',uflx(10,10) + dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,1:(nlayers+1)) +!write(0,*)__FILE__,__LINE__,'dflx ',dflx(10,10) + +#ifdef _ACCEL + ierr = cudaThreadSynchronize() + dimGrid = dim3( (pncol+255)/256,nlayers,1) +#endif + +!jm write(0,*)__FILE__,__LINE__,omp_get_thread_num() +! (dmb 2012) Calculate the heating rates. + call rtrnheatrates _gpuchv (pncol, nlayers & +#include "rrtmg_lw_cpu_args.h" + ) +#ifdef _ACCEL + ierr = cudaThreadSynchronize() +#endif + +! copy the partition data back to the CPU +!write(0,*)__FILE__,__LINE__,i,'totufluxd ',totufluxd(10,10) +!write(0,*)__FILE__,__LINE__,i,'totdfluxd ',totdfluxd(10,10) + uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,1:(nlayers+1)) +!write(0,*)__FILE__,__LINE__,i,'uflx ',uflx(10,10) + dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,1:(nlayers+1)) +!write(0,*)__FILE__,__LINE__,i,'dflx ',dflx(10,10) + uflxc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totuclfld(1:pncol,1:(nlayers+1)) + dflxc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdclfld(1:pncol,1:(nlayers+1)) + hr(colstart:(colstart+pncol-1), 1:(nlayers+1)) = htrd(1:pncol,1:(nlayers+1)) + hrc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = htrcd(1:pncol,1:(nlayers+1)) + + if (idrv .eq. 1) then + + duflx_dt(colstart:(colstart+pncol-1), 1:(nlayers+1)) = dtotuflux_dtd(1:pncol,1:(nlayers+1)) + duflxc_dt(colstart:(colstart+pncol-1), 1:(nlayers+1)) = dtotuclfl_dtd(1:pncol,1:(nlayers+1)) + + end if + +!jm write(0,*)__FILE__,__LINE__,omp_get_thread_num() + +! Transfer up and down fluxes and heating rate to output arrays. +! Vertical indexing goes from bottom to top; reverse here for GCM if necessary. +#ifdef _ACCEL + deallocate( cldfmcd) + deallocate( icbd) + deallocate( ncbandsd) + deallocate( icldlyr) + + call deallocateGPUTaumol() + deallocate( fracsd) + deallocate( taug) + deallocate( ngbd) + call deallocateGPUcldprmcg() + call deallocateGPUrtrnmcg(idrv) + call deallocateGPUSetCoef( ) +#else +# undef tzd +# undef taveld +# undef tboundd +# undef wbroadd + +# undef ngbd +# undef ngsd +# undef icldd +# undef pzd +# undef pwvcmd +# undef idrvd +# undef bpaded +# undef heatfacd +# undef fluxfacd +# undef a0d +# undef a1d +# undef a2d +# undef delwaved +# undef oneminusd +# undef nspad +# undef nspbd +# undef icbd +# undef fracsd +#endif + +!write(0,*)__FILE__,__LINE__ + end subroutine rrtmg_lw_part + + end module rrtmg_lw_rad_f + +#ifndef _ACCEL +# undef pncol +# undef pncold +#endif + + +!------------------------------------------------------------------ + MODULE module_ra_rrtmg_lwf + + use module_model_constants, only : cp + use module_wrf_error +! use module_dm + + use parrrtm_f, only : nbndlw, ngptlw + use rrtmg_lw_init_f, only: rrtmg_lw_ini + use rrtmg_lw_rad_f, only: rrtmg_lw +! use mcica_subcol_gen_lw, only: mcica_subcol_lw + + real retab(95) + data retab / & + 5.92779, 6.26422, 6.61973, 6.99539, 7.39234, & + 7.81177, 8.25496, 8.72323, 9.21800, 9.74075, 10.2930, & + 10.8765, 11.4929, 12.1440, 12.8317, 13.5581, 14.2319, & + 15.0351, 15.8799, 16.7674, 17.6986, 18.6744, 19.6955, & + 20.7623, 21.8757, 23.0364, 24.2452, 25.5034, 26.8125, & + 27.7895, 28.6450, 29.4167, 30.1088, 30.7306, 31.2943, & + 31.8151, 32.3077, 32.7870, 33.2657, 33.7540, 34.2601, & + 34.7892, 35.3442, 35.9255, 36.5316, 37.1602, 37.8078, & + 38.4720, 39.1508, 39.8442, 40.5552, 41.2912, 42.0635, & + 42.8876, 43.7863, 44.7853, 45.9170, 47.2165, 48.7221, & + 50.4710, 52.4980, 54.8315, 57.4898, 60.4785, 63.7898, & + 65.5604, 71.2885, 75.4113, 79.7368, 84.2351, 88.8833, & + 93.6658, 98.5739, 103.603, 108.752, 114.025, 119.424, & + 124.954, 130.630, 136.457, 142.446, 148.608, 154.956, & + 161.503, 168.262, 175.248, 182.473, 189.952, 197.699, & + 205.728, 214.055, 222.694, 231.661, 240.971, 250.639/ + ! + save retab + ! For buffer layer adjustment. Steven Cavallo, Dec 2010. + integer , save :: nlayers + real, PARAMETER :: deltap = 4. ! Pressure interval for buffer layer in mb + + CONTAINS + +!------------------------------------------------------------------ + SUBROUTINE RRTMG_LWRAD_FAST( & + rthratenlw, & + lwupt, lwuptc, lwdnt, lwdntc, & + lwupb, lwupbc, lwdnb, lwdnbc, & +! lwupflx, lwupflxc, lwdnflx, lwdnflxc, & + glw, olr, lwcf, emiss, & + p8w, p3d, pi3d, & + dz8w, tsk, t3d, t8w, rho3d, r, g, & + icloud, warm_rain, cldfra3d, & + lradius,iradius, & + is_cammgmp_used, & + f_ice_phy, f_rain_phy, & + xland, xice, snow, & + qv3d, qc3d, qr3d, & + qi3d, qs3d, qg3d, & + o3input, o33d, & + f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, & + re_cloud, re_ice, re_snow, & ! G. Thompson + has_reqc, has_reqi, has_reqs, & ! G. Thompson + tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao + tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao + tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao + tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16, & ! czhao + aer_ra_feedback, & !czhao +!jdfcz progn,prescribe, & !czhao + progn, & !czhao + qndrop3d,f_qndrop, & !czhao +!ccc added for time varying gases. + yr,julian, & +!ccc + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + lwupflx, lwupflxc, lwdnflx, lwdnflxc & + ) +!------------------------------------------------------------------ +!ccc To use clWRF time varying trace gases + USE MODULE_RA_CLWRF_SUPPORT, ONLY : read_CAMgases + + IMPLICIT NONE +!------------------------------------------------------------------ + LOGICAL, INTENT(IN ) :: warm_rain + LOGICAL, INTENT(IN ) :: is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: ICLOUD +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: dz8w, & + t3d, & + t8w, & + p8w, & + p3d, & + pi3d, & + rho3d + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RTHRATENLW + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: GLW, & + OLR, & + LWCF + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: EMISS, & + TSK + + REAL, INTENT(IN ) :: R,G + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: XLAND, & + XICE, & + SNOW +!ccc Added for time-varying trace gases. + INTEGER, INTENT(IN ) :: yr + REAL, INTENT(IN ) :: julian +!ccc + +! +! Optional +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: & + CLDFRA3D, & + LRADIUS, & + IRADIUS, & + + QV3D, & + QC3D, & + QR3D, & + QI3D, & + QS3D, & + QG3D, & + QNDROP3D + +!..Added by G. Thompson to couple cloud physics effective radii. + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: & + re_cloud, & + re_ice, & + re_snow + INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs + + real pi,third,relconst,lwpmin,rhoh2o + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: & + F_ICE_PHY, & + F_RAIN_PHY + + LOGICAL, OPTIONAL, INTENT(IN) :: & + F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP +! Optional + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & + INTENT(IN ) :: tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao + tauaerlw5,tauaerlw6,tauaerlw7,tauaerlw8, & ! czhao + tauaerlw9,tauaerlw10,tauaerlw11,tauaerlw12, & ! czhao + tauaerlw13,tauaerlw14,tauaerlw15,tauaerlw16 + + INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback +!jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe + INTEGER, INTENT(IN ), OPTIONAL :: progn +! Ozone + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: O33D + INTEGER, OPTIONAL, INTENT(IN ) :: o3input + + real, parameter :: thresh=1.e-9 + real slope + character(len=200) :: msg + + +! Top of atmosphere and surface longwave fluxes (W m-2) + REAL, DIMENSION( ims:ime, jms:jme ), & + OPTIONAL, INTENT(INOUT) :: & + LWUPT,LWUPTC,LWDNT,LWDNTC, & + LWUPB,LWUPBC,LWDNB,LWDNBC + +! Layer longwave fluxes (including extra layer above model top) +! Vertical ordering is from bottom to top (W m-2) + REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), & + OPTIONAL, INTENT(OUT) :: & + LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC + +! LOCAL VARS + + REAL, DIMENSION( kts:kte+1 ) :: Pw1D, & + Tw1D + + REAL, DIMENSION( kts:kte ) :: TTEN1D, & + CLDFRA1D, & + DZ1D, & + P1D, & + T1D, & + QV1D, & + QC1D, & + QR1D, & + QI1D, & + QS1D, & + QG1D, & + O31D, & + qndrop1d + +! Added local arrays for RRTMG + integer :: ncol, & + nlay, & + idrv, & + icld, & + inflglw, & + iceflglw, & + liqflglw +! the mod in the macro below is to quiet range checking +#define TILEPTS (jte-jts+1)*(ite-its+1)+mod((jte-jts+1)*(ite-its+1),CHNK) +! Dimension with extra layer from model top to TOA + real, dimension( TILEPTS, kts:nlayers+1 ) :: & + plev, & + tlev + real, dimension( TILEPTS, kts:nlayers ) :: & + play, & + tlay, & + h2ovmr, & + o3vmr, & + co2vmr, & + o2vmr, & + ch4vmr, & + n2ovmr, & + cfc11vmr, & + cfc12vmr, & + cfc22vmr, & + ccl4vmr + real, dimension( kts:nlayers ) :: o3mmr +! For old cloud property specification for rrtm_lw + real, dimension( kts:kte ) :: clwp, & + ciwp, & + cswp, & + plwp, & + piwp +! Surface emissivity (for 16 LW spectral bands) + real, dimension( TILEPTS, nbndlw ) :: & + emis +! Dimension with extra layer from model top to TOA, +! though no clouds are allowed in extra layer + real, dimension( TILEPTS, kts:nlayers ) :: & + clwpth, & + ciwpth, & + cswpth, & + rel, & + rei, & + res, & + cldfrac + real, dimension( TILEPTS, nbndlw, kts:nlayers ) :: & + taucld + real, dimension( TILEPTS, kts:nlayers, nbndlw ) :: & + tauaer + real, dimension( TILEPTS, kts:nlayers+1 ) :: & + uflx, & + dflx, & + uflxc, & + dflxc + real, dimension( TILEPTS, kts:nlayers+1 ) :: & + duflx_dt, & + duflxc_dt + real, dimension( TILEPTS, kts:nlayers+1 ) :: & + hr, & + hrc + + real, dimension ( TILEPTS ) :: & + tsfc, & + ps + real :: ro, & + dz + real:: snow_mass_factor + +!..We can use message interface regardless of what options are running, +!.. so let us ask for it here. + CHARACTER(LEN=256) :: message + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + +!ccc To add time-varying trace gases (CO2, N2O and CH4). Read the conc. from file +! then interpolate to date of run. +#ifdef CLWRFGHG +! CLWRF-UC June.09 + REAL(8) :: co2, n2o, ch4, cfc11, cfc12 +#else + +! Set trace gas volume mixing ratios, 2005 values, IPCC (2007) +! carbon dioxide (379 ppmv) + real :: co2 + data co2 / 379.e-6 / +! methane (1774 ppbv) + real :: ch4 + data ch4 / 1774.e-9 / +! nitrous oxide (319 ppbv) + real :: n2o + data n2o / 319.e-9 / +! cfc-11 (251 ppt) + real :: cfc11 + data cfc11 / 0.251e-9 / +! cfc-12 (538 ppt) + real :: cfc12 + data cfc12 / 0.538e-9 / +#endif +! cfc-22 (169 ppt) + real :: cfc22 + data cfc22 / 0.169e-9 / +! ccl4 (93 ppt) + real :: ccl4 + data ccl4 / 0.093e-9 / +! Set oxygen volume mixing ratio (for o2mmr=0.23143) + real :: o2 + data o2 / 0.209488 / + + integer :: iplon, irng, permuteseed + integer :: nb + +! For old cloud property specification for rrtm_lw +! Cloud and precipitation absorption coefficients + real :: abcw,abice,abrn,absn + data abcw /0.144/ + data abice /0.0735/ + data abrn /0.330e-3/ + data absn /2.34e-3/ + +! Molecular weights and ratios for converting mmr to vmr units +! real :: amd ! Effective molecular weight of dry air (g/mol) +! real :: amw ! Molecular weight of water vapor (g/mol) +! real :: amo ! Molecular weight of ozone (g/mol) +! real :: amo2 ! Molecular weight of oxygen (g/mol) +! Atomic weights for conversion from mass to volume mixing ratios +! data amd / 28.9660 / +! data amw / 18.0160 / +! data amo / 47.9998 / +! data amo2 / 31.9999 / + + real :: amdw ! Molecular weight of dry air / water vapor + real :: amdo ! Molecular weight of dry air / ozone + real :: amdo2 ! Molecular weight of dry air / oxygen + data amdw / 1.607793 / + data amdo / 0.603461 / + data amdo2 / 0.905190 / + +!! + real, dimension( (jte-jts+1)*(ite-its+1), 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb) + + real, dimension( (jte-jts+1)*(ite-its+1), 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path + cliqwp, & ! in-cloud cloud liquid water path + csnowp, & ! in-cloud snow water path + reliq, & ! effective drop radius (microns) + reice ! effective ice crystal size (microns) + real, dimension( (jte-jts+1)*(ite-its+1), 1:kte-kts+1):: recloud1d, & + reice1d, & + resnow1d + + real :: gliqwp, gicewp, gsnowp, gravmks + +! +! REAL :: TSFC,GLW0,OLR0,EMISS0,FP + + real, dimension ((jte-jts+1)*(ite-its+1)) :: landfrac, landm, snowh, icefrac + + integer :: pcols, pver + integer :: icol +! + INTEGER :: i,j,K, idx_rei + REAL :: corr + LOGICAL :: predicate + +! Added for top of model adjustment. Steven Cavallo NCAR/MMM December 2010 + INTEGER, PARAMETER :: nproflevs = 60 ! Constant, from the table + INTEGER :: L, LL, klev ! Loop indices + REAL, DIMENSION( kts:nlayers+1 ) :: varint + REAL :: wght,vark,vark1 + REAL :: PPROF(nproflevs), TPROF(nproflevs) + ! Weighted mean pressure and temperature profiles from midlatitude + ! summer (MLS),midlatitude winter (MLW), sub-Arctic + ! winter (SAW),sub-Arctic summer (SAS), and tropical (TROP) + ! standard atmospheres. + DATA PPROF /1000.00,855.47,731.82,626.05,535.57,458.16, & + 391.94,335.29,286.83,245.38,209.91,179.57, & + 153.62,131.41,112.42,96.17,82.27,70.38, & + 60.21,51.51,44.06,37.69,32.25,27.59, & + 23.60,20.19,17.27,14.77,12.64,10.81, & + 9.25,7.91,6.77,5.79,4.95,4.24, & + 3.63,3.10,2.65,2.27,1.94,1.66, & + 1.42,1.22,1.04,0.89,0.76,0.65, & + 0.56,0.48,0.41,0.35,0.30,0.26, & + 0.22,0.19,0.16,0.14,0.12,0.10/ + DATA TPROF /286.96,281.07,275.16,268.11,260.56,253.02, & + 245.62,238.41,231.57,225.91,221.72,217.79, & + 215.06,212.74,210.25,210.16,210.69,212.14, & + 213.74,215.37,216.82,217.94,219.03,220.18, & + 221.37,222.64,224.16,225.88,227.63,229.51, & + 231.50,233.73,236.18,238.78,241.60,244.44, & + 247.35,250.33,253.32,256.30,259.22,262.12, & + 264.80,266.50,267.59,268.44,268.69,267.76, & + 266.13,263.96,261.54,258.93,256.15,253.23, & + 249.89,246.67,243.48,240.25,236.66,233.86/ +!------------------------------------------------------------------ +#if ( WRF_CHEM == 1 ) + IF ( aer_ra_feedback == 1) then + IF ( .NOT. & + ( PRESENT(tauaerlw1) .AND. & + PRESENT(tauaerlw2) .AND. & + PRESENT(tauaerlw3) .AND. & + PRESENT(tauaerlw4) .AND. & + PRESENT(tauaerlw5) .AND. & + PRESENT(tauaerlw6) .AND. & + PRESENT(tauaerlw7) .AND. & + PRESENT(tauaerlw8) .AND. & + PRESENT(tauaerlw9) .AND. & + PRESENT(tauaerlw10) .AND. & + PRESENT(tauaerlw11) .AND. & + PRESENT(tauaerlw12) .AND. & + PRESENT(tauaerlw13) .AND. & + PRESENT(tauaerlw14) .AND. & + PRESENT(tauaerlw15) .AND. & + PRESENT(tauaerlw16) ) ) THEN + CALL wrf_error_fatal & + ('Warning: missing fields required for aerosol radiation' ) + ENDIF + ENDIF +#endif + +!write(0,*)__FILE__,__LINE__ + +!-----CALCULATE LONG WAVE RADIATION +! +! All fields are ordered vertically from bottom to top +! Pressures are in mb +! +!ccc Read time-varying trace gases concentrations and interpolate them to run date. +! +#ifdef CLWRFGHG + + CALL read_CAMgases(yr,julian,"RRTMG",co2,n2o,ch4,cfc11,cfc12) + + IF ( wrf_dm_on_monitor() ) THEN + WRITE(message,*)'CAM-CLWRF interpolated values______ year:',yr,' julian day:',julian + call wrf_debug( 100, message) + WRITE(message,*)' CAM-CLWRF co2vmr: ',co2,' n2ovmr:',n2o,' ch4vmr:',ch4,' cfc11vmr:',cfc11,' cfc12vmr:',cfc12 + call wrf_debug( 100, message) + ENDIF + +#endif +!ccc + + ncol = (jte-jts+1)*(ite-its+1) + +! latitude loop + j_loop: do j = jts,jte + +! longitude loop + i_loop: do i = its,ite + + icol = i-its+1 + (j-jts)*(ite-its+1) + + do k=kts,kte+1 + Pw1D(K) = p8w(I,K,J)/100. + Tw1D(K) = t8w(I,K,J) + enddo + + DO K=kts,kte + QV1D(K)=0. + QC1D(K)=0. + QR1D(K)=0. + QI1D(K)=0. + QS1D(K)=0. + CLDFRA1D(k)=0. + ENDDO + + DO K=kts,kte + QV1D(K)=QV3D(I,K,J) + QV1D(K)=max(0.,QV1D(K)) + ENDDO + + IF (PRESENT(O33D)) THEN + DO K=kts,kte + O31D(K)=O33D(I,K,J) + ENDDO + ELSE + DO K=kts,kte + O31D(K)=0.0 + ENDDO + ENDIF + + DO K=kts,kte + TTEN1D(K)=0. + T1D(K)=T3D(I,K,J) + P1D(K)=P3D(I,K,J)/100. + DZ1D(K)=dz8w(I,K,J) + ENDDO + +! moist variables + + IF (ICLOUD .ne. 0) THEN + IF ( PRESENT( CLDFRA3D ) ) THEN + DO K=kts,kte + CLDFRA1D(k)=CLDFRA3D(I,K,J) + ENDDO + ENDIF + + IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN + IF ( F_QC) THEN + DO K=kts,kte + QC1D(K)=QC3D(I,K,J) + QC1D(K)=max(0.,QC1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN + IF ( F_QR) THEN + DO K=kts,kte + QR1D(K)=QR3D(I,K,J) + QR1D(K)=max(0.,QR1D(K)) + ENDDO + ENDIF + ENDIF + + IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN + IF (F_QNDROP) THEN + DO K=kts,kte + qndrop1d(K)=qndrop3d(I,K,J) + ENDDO + ENDIF + ENDIF + +! This logic is tortured because cannot test F_QI unless +! it is present, and order of evaluation of expressions +! is not specified in Fortran + + IF ( PRESENT ( F_QI ) ) THEN + predicate = F_QI + ELSE + predicate = .FALSE. + ENDIF + +! For MP option 3 + IF (.NOT. predicate .and. .not. warm_rain) THEN + DO K=kts,kte + IF (T1D(K) .lt. 273.15) THEN + QI1D(K)=QC1D(K) + QS1D(K)=QR1D(K) + QC1D(K)=0. + QR1D(K)=0. + ENDIF + ENDDO + ENDIF + + IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN + IF (F_QI) THEN + DO K=kts,kte + QI1D(K)=QI3D(I,K,J) + QI1D(K)=max(0.,QI1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN + IF (F_QS) THEN + DO K=kts,kte + QS1D(K)=QS3D(I,K,J) + QS1D(K)=max(0.,QS1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN + IF (F_QG) THEN + DO K=kts,kte + QG1D(K)=QG3D(I,K,J) + QG1D(K)=max(0.,QG1D(K)) + ENDDO + ENDIF + ENDIF + +! mji - For MP option 5 + IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN + IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN + DO K=kts,kte + qi1d(k) = 0.1*qs3d(i,k,j) + qs1d(k) = 0.9*qs3d(i,k,j) + qc1d(k) = qc3d(i,k,j) + qi1d(k) = max(0.,qi1d(k)) + qc1d(k) = max(0.,qc1d(k)) + ENDDO + ENDIF + ENDIF + + ENDIF + +! EMISS0=EMISS(I,J) +! GLW0=0. +! OLR0=0. +! TSFC=TSK(I,J) + DO K=kts,kte + QV1D(K)=AMAX1(QV1D(K),1.E-12) + ENDDO + +! Set up input for longwave +! ncol = 1 +! Add extra layer from top of model to top of atmosphere +! nlay = (kte - kts + 1) + 1 +! Edited for top of model adjustment (nlayers = kte + 1). +! Steven Cavallo, December 2010 + nlay = nlayers ! Keep these indices the same + +! For optional calculation of the approximate change in upward flux as a function +! of surface temperature only between full radiation calls (0=off, 1=on) + idrv = 0 + +! Select cloud liquid and ice optics parameterization options +! For passing in cloud optical properties directly: +! icld = 2 +! inflglw = 0 +! iceflglw = 0 +! liqflglw = 0 +! For passing in cloud physical properties; cloud optics parameterized in RRTMG: + icld = 2 + inflglw = 2 + iceflglw = 3 + liqflglw = 1 + +!Mukul change the flags here with reference to the new effective cloud/ice/snow radius + IF (ICLOUD .ne. 0) THEN + IF ( has_reqc .ne. 0) THEN + IF ( wrf_dm_on_monitor() ) THEN + WRITE(message,*)'RRTMG: pre-computed cloud droplet effective '// & + 'radius found, setting inflglw=3' + call wrf_debug(150, message) + ENDIF + inflglw = 3 + DO K=kts,kte + recloud1D(icol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6) + if (recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean + recloud1D(icol,K) = 10.5 + elseif(recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land + recloud1D(icol,K) = 7.5 + endif + ENDDO + ELSE + DO K=kts,kte + recloud1D(icol,K) = 5.0 + ENDDO + ENDIF + + IF ( has_reqi .ne. 0) THEN + IF ( wrf_dm_on_monitor() ) THEN + WRITE(message,*)'RRTMG: pre-computed cloud ice effective radius found, setting inflglw=4 and iceflglw=4' + call wrf_debug(150, message) + ENDIF + inflglw = 4 + iceflglw = 4 + DO K=kts,kte + reice1D(icol,K) = MAX(10., re_ice(I,K,J)*1.E6) + if (recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean + recloud1D(icol,K) = 10.5 + elseif(recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land + recloud1D(icol,K) = 7.5 + endif + ENDDO + ELSE + DO K=kts,kte + reice1D(icol,K) = 10.0 + ENDDO + ENDIF + + IF ( has_reqs .ne. 0) THEN + IF ( wrf_dm_on_monitor() ) THEN + WRITE(message,*)'RRTMG: pre-computed snow effective radius found, setting inflglw=5 and iceflglw=5' + call wrf_debug(150, message) + ENDIF + inflglw = 5 + iceflglw = 5 + DO K=kts,kte + resnow1D(icol,K) = MAX(10., re_snow(I,K,J)*1.E6) + ENDDO + ELSE + DO K=kts,kte + resnow1D(icol,K) = 10.0 + ENDDO + ENDIF + ENDIF + +! Layer indexing goes bottom to top here for all fields. +! Water vapor and ozone are converted from mmr to vmr. +! Pressures are in units of mb here. + plev(icol,1) = pw1d(1) + + + tlev(icol,1) = tw1d(1) + tsfc(icol) = tsk(i,j) + do k = kts, kte + play(icol,k) = p1d(k) + plev(icol,k+1) = pw1d(k+1) + pdel(icol,k) = plev(icol,k) - plev(icol,k+1) + tlay(icol,k) = t1d(k) + tlev(icol,k+1) = tw1d(k+1) + h2ovmr(icol,k) = qv1d(k) * amdw + co2vmr(icol,k) = co2 + o2vmr(icol,k) = o2 + ch4vmr(icol,k) = ch4 + n2ovmr(icol,k) = n2o + cfc11vmr(icol,k) = cfc11 + cfc12vmr(icol,k) = cfc12 + cfc22vmr(icol,k) = cfc22 + ccl4vmr(icol,k) = ccl4 + enddo + +! This section is replaced with a new method to deal with model top + if ( 1 == 0 ) then + +! Define profile values for extra layer from model top to top of atmosphere. +! The top layer temperature for all gridpoints is set to the top layer-1 +! temperature plus a constant (0 K) that represents an isothermal layer +! above ptop. Top layer interface temperatures are linearly interpolated +! from the layer temperatures. + + play(icol,kte+1) = 0.5 * plev(icol,kte+1) + tlay(icol,kte+1) = tlev(icol,kte+1) + 0.0 + plev(icol,kte+2) = 1.0e-5 + tlev(icol,kte+2) = tlev(icol,kte+1) + 0.0 + h2ovmr(icol,kte+1) = h2ovmr(icol,kte) + co2vmr(icol,kte+1) = co2vmr(icol,kte) + o2vmr(icol,kte+1) = o2vmr(icol,kte) + ch4vmr(icol,kte+1) = ch4vmr(icol,kte) + n2ovmr(icol,kte+1) = n2ovmr(icol,kte) + cfc11vmr(icol,kte+1) = cfc11vmr(icol,kte) + cfc12vmr(icol,kte+1) = cfc12vmr(icol,kte) + cfc22vmr(icol,kte+1) = cfc22vmr(icol,kte) + ccl4vmr(icol,kte+1) = ccl4vmr(icol,kte) + + endif + +! Set up values for extra layers to the top of the atmosphere. +! Temperature is calculated based on an average temperature profile given +! here in a table. The input table data is linearly interpolated to the +! column pressure. Mixing ratios are held constant except for ozone. +! Caution should be used if model top pressure is less than 5 hPa. +! Steven Cavallo, NCAR/MMM, December 2010 + ! Calculate the column pressure buffer levels above the + ! model top + do L=kte+1,nlayers,1 + plev(icol,L+1) = plev(icol,L) - deltap + play(icol,L) = 0.5*(plev(icol,L) + plev(icol,L+1)) + enddo + ! Add zero as top level. This gets the temperature max at the + ! stratopause, reducing the downward flux errors in the top + ! levels. If zero happened to be the top level already, + ! this will add another level with zero, but will not affect + ! the radiative transfer calculation. + plev(icol,nlayers+1) = 0.00 + play(icol,nlayers) = 0.5*(plev(icol,nlayers) + plev(icol,nlayers+1)) + + ! Interpolate the table temperatures to column pressure levels + do L=1,nlayers+1,1 + if ( PPROF(nproflevs) .lt. plev(icol,L) ) then + do LL=2,nproflevs,1 + if ( PPROF(LL) .lt. plev(icol,L) ) then + klev = LL - 1 + exit + endif + enddo + + else + klev = nproflevs + endif + + if (klev .ne. nproflevs ) then + vark = TPROF(klev) + vark1 = TPROF(klev+1) + wght=(plev(icol,L)-PPROF(klev) )/( PPROF(klev+1)-PPROF(klev)) + else + vark = TPROF(klev) + vark1 = TPROF(klev) + wght = 0.0 + endif + varint(L) = wght*(vark1-vark)+vark + + enddo + + ! Match the interpolated table temperature profile to WRF column + do L=kte+1,nlayers+1,1 + tlev(icol,L) = varint(L) + (tlev(icol,kte) - varint(kte)) + !if ( L .le. nlay ) then + tlay(icol,L-1) = 0.5*(tlev(icol,L) + tlev(icol,L-1)) + !endif + enddo + + ! Now the chemical species (except for ozone) + do L=kte+1,nlayers,1 + h2ovmr(icol,L) = h2ovmr(icol,kte) + co2vmr(icol,L) = co2vmr(icol,kte) + o2vmr(icol,L) = o2vmr(icol,kte) + ch4vmr(icol,L) = ch4vmr(icol,kte) + n2ovmr(icol,L) = n2ovmr(icol,kte) + cfc11vmr(icol,L) = cfc11vmr(icol,kte) + cfc12vmr(icol,L) = cfc12vmr(icol,kte) + cfc22vmr(icol,L) = cfc22vmr(icol,kte) + ccl4vmr(icol,L) = ccl4vmr(icol,kte) + enddo +! End top of model buffer +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Get ozone profile including amount in extra layer above model top. +! Steven Cavallo: Must pass nlay-1 into subroutine to get nlayers +! dimension for o3mmr +! call inirad (o3mmr,plev,kts,nlay-1) + call inirad (o3mmr,plev(icol,:),kts,nlay-1) + +! Steven Cavallo: Changed to nlayers from kte+1 + if(present(o33d)) then + do k = kts, nlayers + o3vmr(icol,k) = o3mmr(k) * amdo + IF ( PRESENT( O33D ) ) THEN + if(o3input .eq. 2)then + if(k.le.kte)then + o3vmr(icol,k) = o31d(k) + else +! apply shifted climatology profile above model top + o3vmr(icol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo + if(o3vmr(icol,k) .le. 0.)o3vmr(icol,k) = o3mmr(k)*amdo + endif + endif + ENDIF + enddo + else + do k = kts, nlayers + o3vmr(icol,k) = o3mmr(k) * amdo + enddo + endif + +! Set surface emissivity in each RRTMG longwave band + do nb = 1, nbndlw + emis(icol, nb) = emiss(i,j) + enddo + +! Define cloud optical properties for radiation (inflglw = 0) +! This is approach used with older RRTM_LW; +! Cloud and precipitation paths in g/m2 +! qi=0 if no ice phase +! qs=0 if no ice phase + if (inflglw .eq. 0) then + do k = kts,kte + ro = p1d(k) / (r * t1d(k))*100. + dz = dz1d(k) + clwp(k) = ro*qc1d(k)*dz*1000. + ciwp(k) = ro*qi1d(k)*dz*1000. + plwp(k) = (ro*qr1d(k))**0.75*dz*1000. + piwp(k) = (ro*qs1d(k))**0.75*dz*1000. + enddo + +! Cloud fraction and cloud optical depth; old approach used with RRTM_LW + do k = kts, kte + cldfrac(icol,k) = cldfra1d(k) + do nb = 1, nbndlw + taucld(icol,nb,k) = abcw*clwp(k) + abice*ciwp(k) & + +abrn*plwp(k) + absn*piwp(k) + if (taucld(icol,nb,k) .gt. 0.01) cldfrac(icol,k) = 1. + enddo + enddo + +! Zero out cloud physical property arrays; not used when passing optical properties +! into radiation + do k = kts, kte + clwpth(icol,k) = 0.0 + ciwpth(icol,k) = 0.0 + rel(icol,k) = 10.0 + rei(icol,k) = 10.0 + enddo + endif + +! Define cloud physical properties for radiation (inflglw = 1 or 2) +! Cloud fraction +! Set cloud arrays if passing cloud physical properties into radiation + if (inflglw .gt. 0) then + do k = kts, kte + cldfrac(icol,k) = cldfra1d(k) + enddo + +! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method) + pcols = ncol + pver = kte - kts + 1 + gravmks = g + landfrac(icol) = 2.-XLAND(I,J) + landm(icol) = landfrac(icol) + snowh(icol) = 0.001*SNOW(I,J) + icefrac(icol) = XICE(I,J) + +! From module_ra_cam: Convert liquid and ice mixing ratios to water paths; +! pdel is in mb here; convert back to Pa (*100.) +! Water paths are in units of g/m2 +! snow added as ice cloud (JD 091022) + do k = kts, kte + gicewp = (qi1d(k)+qs1d(k)) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path. + gliqwp = qc1d(k) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path. + cicewp(icol,k) = gicewp / max(0.01,cldfrac(icol,k)) ! In-cloud ice water path. + cliqwp(icol,k) = gliqwp / max(0.01,cldfrac(icol,k)) ! In-cloud liquid water path. + end do + + +! Mukul +!..The ice water path is already sum of cloud ice and snow, but when we have explicit +!.. ice effective radius, overwrite the ice path with only the cloud ice variable, +!.. leaving out the snow for its own effect. + if(iceflglw.ge.4)then + do k = kts, kte + gicewp = qi1d(k) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path. + cicewp(icol,k) = gicewp / max(0.01,cldfrac(icol,k)) ! In-cloud ice water path. + end do + end if + +!..Here the snow path is adjusted if (radiation) effective radius of snow is +!.. larger than what we currently have in the lookup tables. Since mass goes +!.. rather close to diameter squared, adjust the mixing ratio of snow used +!.. to compute its water path in combination with the max diameter. Not a +!.. perfect fix, but certainly better than using all snow mass when diameter is +!.. far larger than table currently contains and crystal sizes much larger than +!.. about 140 microns have lesser impact than those much smaller sizes. + + if(iceflglw.eq.5)then + do k = kts, kte + snow_mass_factor = 1.0 + if (resnow1d(icol,k) .gt. 130.)then + snow_mass_factor = (130.0/resnow1d(icol,k))*(130.0/resnow1d(icol,k)) + resnow1d(icol,k) = 130.0 + IF ( wrf_dm_on_monitor() ) THEN + WRITE(message,*)'RRTMG: reducing snow mass (cloud path) to ', & + nint(snow_mass_factor*100.), ' percent of full value' + call wrf_debug(150, message) + ENDIF + endif + gsnowp = qs1d(k) * snow_mass_factor * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box snow water path. + csnowp(icol,k) = gsnowp / max(0.01,cldfrac(icol,k)) + end do + end if + + +!link the aerosol feedback to cloud -czhao + if( PRESENT( progn ) ) then + if (progn == 1) then +!jdfcz if(prescribe==0) then + + pi = 4.*atan(1.0) + third=1./3. + rhoh2o=1.e3 + relconst=3/(4.*pi*rhoh2o) +! minimun liquid water path to calculate rel +! corresponds to optical depth of 1.e-3 for radius 4 microns. + lwpmin=3.e-5 + do k = kts, kte + reliq(icol,k) = 10. + if( PRESENT( F_QNDROP ) ) then + if( F_QNDROP ) then + if ( qc1d(k)*pdel(icol,k).gt.lwpmin.and. & + qndrop1d(k).gt.1000. ) then + reliq(icol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m +! apply scaling from Martin et al., JAS 51, 1830. + reliq(icol,k)=1.1*reliq(icol,k) + reliq(icol,k)=reliq(icol,k)*1.e6 ! convert from m to microns + reliq(icol,k)=max(reliq(icol,k),4.) + reliq(icol,k)=min(reliq(icol,k),20.) + end if + end if + end if + end do +!jdfcz else ! prescribe +! following Kiehl +! call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) +! write(0,*) 'lw prescribe aerosol',maxval(qndrop3d) +!jdfcz endif + else ! progn + call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) + endif + else !present(progn) + call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) + endif + +! following Kristjansson and Mitchell + call reicalc(icol, pcols, pver, tlay, reice) + + +!..If we already have effective radius of cloud and ice, then just overwrite what +!.. was computed in the relcalc and reicalc subroutines above. + + if (inflglw .ge. 3) then + do k = kts, kte + reliq(icol,k) = recloud1d(icol,k) + end do + endif + if (iceflglw .ge. 4) then + do k = kts, kte + reice(icol,k) = reice1d(icol,k) + end do + endif + +! Limit upper bound of reice for Fu ice parameterization and convert +! from effective radius to generalized effective size (*1.0315; Fu, 1996) + if (iceflglw .eq. 3) then + do k = kts, kte + reice(icol,k) = reice(icol,k) * 1.0315 + reice(icol,k) = min(140.0,reice(icol,k)) + end do + endif +!if CAMMGMP is used, use output from CAMMGMP + if(is_CAMMGMP_used) then + do k = kts, kte + if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then + reice(icol,k) = iradius(i,k,j) + else + reice(icol,k) = 25. + end if + reice(icol,k) = max(5., min(140.0,reice(icol,k))) + if ( qc1d(k) .gt. 1.e-20) then + reliq(icol,k) = lradius(i,k,j) + else + reliq(icol,k) = 10. + end if + reliq(icol,k) = max(2.5, min(60.0,reliq(icol,k))) + enddo + endif + + +! Set cloud physical property arrays + do k = kts, kte + clwpth(icol,k) = cliqwp(icol,k) + ciwpth(icol,k) = cicewp(icol,k) + rel(icol,k) = reliq(icol,k) + rei(icol,k) = reice(icol,k) + enddo + +!Mukul + if (inflglw .eq. 5) then + do k = kts, kte + cswpth(icol,k) = csnowp(icol,k) + res(icol,k) = resnow1d(icol,k) + end do + else + do k = kts, kte + cswpth(icol,k) = 0. + res(icol,k) = 10. + end do + endif + +! Zero out cloud optical properties here; not used when passing physical properties +! to radiation and taucld is calculated in radiation + do k = kts, kte + do nb = 1, nbndlw + taucld(icol,nb,k) = 0.0 + enddo + enddo + endif + +! No clouds are allowed in the extra layer from model top to TOA + ! Steven Cavallo: Edited out for buffer adjustment below + if ( 1 == 0 ) then + + + clwpth(icol,kte+1) = 0. + ciwpth(icol,kte+1) = 0. + cswpth(icol,kte+1) = 0. + rel(icol,kte+1) = 10. + rei(icol,kte+1) = 10. + res(icol,kte+1) = 10. + cldfrac(icol,kte+1) = 0. + do nb = 1, nbndlw + taucld(icol,nb,kte+1) = 0. + enddo + + endif + + ! Buffer adjustment. Steven Cavallo December 2010 + do k=kte+1,nlayers + clwpth(icol,k) = 0. + ciwpth(icol,k) = 0. + cswpth(icol,k) = 0. + rel(icol,k) = 10. + rei(icol,k) = 10. + res(icol,k) = 10. + cldfrac(icol,k) = 0. + do nb = 1,nbndlw + taucld(icol,nb,k) = 0. + enddo + enddo + +! mji - mcica sub-column generator called inside rrtmg_lw for gpu +! iplon = 1 +! irng = 0 +! Sub-column generator for McICA +! call mcica_subcol_lw(iplon, ncol, nlay, icld, permuteseed, irng, play, & +! cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, cldfmcl, & +! ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, taucmcl) + +!-------------------------------------------------------------------------- +! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010 +!-------------------------------------------------------------------------- +! Aerosol optical depth by layer for each RRTMG longwave band +! No aerosols in layer above model top (kte+1) +! Steven Cavallo: Upper bound of loop changed to nlayers from kte+1 +! do nb = 1, nbndlw +! do k = kts, kte+1 +! tauaer(ncol,k,nb) = 0. +! enddo +! enddo + +! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao +! + do nb = 1, nbndlw + do k = kts,nlayers + tauaer(icol,k,nb) = 0. + end do + end do + +#if ( WRF_CHEM == 1 ) + IF ( AER_RA_FEEDBACK == 1) then +! do nb = 1, nbndlw + do k = kts,kte !wig + if(tauaerlw1(i,k,j).gt.thresh .and. tauaerlw16(i,k,j).gt.thresh) then + tauaer(icol,k,1)=tauaerlw1(i,k,j) + tauaer(icol,k,2)=tauaerlw2(i,k,j) + tauaer(icol,k,3)=tauaerlw3(i,k,j) + tauaer(icol,k,4)=tauaerlw4(i,k,j) + tauaer(icol,k,5)=tauaerlw5(i,k,j) + tauaer(icol,k,6)=tauaerlw6(i,k,j) + tauaer(icol,k,7)=tauaerlw7(i,k,j) + tauaer(icol,k,8)=tauaerlw8(i,k,j) + tauaer(icol,k,9)=tauaerlw9(i,k,j) + tauaer(icol,k,10)=tauaerlw10(i,k,j) + tauaer(icol,k,11)=tauaerlw11(i,k,j) + tauaer(icol,k,12)=tauaerlw12(i,k,j) + tauaer(icol,k,13)=tauaerlw13(i,k,j) + tauaer(icol,k,14)=tauaerlw14(i,k,j) + tauaer(icol,k,15)=tauaerlw15(i,k,j) + tauaer(icol,k,16)=tauaerlw16(i,k,j) + endif + enddo ! k +! end do ! nb + +!wig beg + do nb = 1, nbndlw + slope = 0. !use slope as a sum holder + do k = kts,kte + slope = slope + tauaer(icol,k,nb) + end do + if( slope < 0. ) then + write(msg,'("ERROR: Negative total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb + call wrf_error_fatal(msg) + else if( slope > 5. ) then + call wrf_message("-------------------------") + write(msg,'("WARNING: Large total lw optical depth of ",f8.2," at point i,j,nb=",3i5)') slope,i,j,nb + call wrf_message(msg) + + call wrf_message("Diagnostics 1: k, tauaerlw1, tauaerlw16") + do k=kts,kte + write(msg,'(i4,2f8.2)') k, tauaerlw1(i,k,j), tauaerlw16(i,k,j) + call wrf_message(msg) + end do + call wrf_message("-------------------------") + endif + enddo ! nb + endif ! aer_ra_feedback +#endif + +! + end do i_loop + end do j_loop +!write(0,*)'zap before rrtmg_lw duflx_dt ',duflx_dt +!write(0,*)'zap before rrtmg_lw duflxc_dt ',duflxc_dt + +!write(0,*)__FILE__,__LINE__ +! Call RRTMG longwave radiation model for full grid for gpu + call rrtmg_lw & + (ncol ,nlay ,icld ,idrv , & + play ,plev ,tlay ,tlev ,tsfc , & + h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , & + cfc11vmr,cfc12vmr,cfc22vmr,ccl4vmr ,emis , & + inflglw ,iceflglw,liqflglw,cldfrac , & + taucld ,ciwpth ,clwpth ,cswpth ,rei ,rel ,res , & + tauaer , & + uflx ,dflx ,hr ,uflxc ,dflxc, hrc, & + duflx_dt,duflxc_dt) +!write(0,*)__FILE__,__LINE__,'h2ovmr ',h2ovmr(10,10) +!write(0,*)__FILE__,__LINE__,'uflx ',uflx(10,10) +!write(0,*)__FILE__,__LINE__,'dflx ',dflx(10,10) + +! Output downard surface flux, and outgoing longwave flux and cloud forcing +! at the top of atmosphere (W/m2) + +! latitude loop + j_loop2: do j = jts,jte + +! longitude loop + i_loop2: do i = its,ite + + icol = i-its+1 + (j-jts)*(ite-its+1) + + glw(i,j) = dflx(icol,1) +! olr(i,j) = uflx(icol,kte+2) +! lwcf(i,j) = uflxc(icol,kte+2) - uflx(icol,kte+2) +! Steven Cavallo: Changed OLR to be valid at the top of atmosphere instead +! of top of model. Dec 2010. + olr(i,j) = uflx(icol,nlayers+1) + lwcf(i,j) = uflxc(icol,nlayers+1) - uflx(icol,nlayers+1) + + if (present(lwupt)) then +! Output up and down toa fluxes for total and clear sky + lwupt(i,j) = uflx(icol,kte+2) + lwuptc(i,j) = uflxc(icol,kte+2) + lwdnt(i,j) = dflx(icol,kte+2) + lwdntc(i,j) = dflxc(icol,kte+2) +! Output up and down surface fluxes for total and clear sky + lwupb(i,j) = uflx(icol,1) + lwupbc(i,j) = uflxc(icol,1) + lwdnb(i,j) = dflx(icol,1) + lwdnbc(i,j) = dflxc(icol,1) + endif + +! Output up and down layer fluxes for total and clear sky. +! Vertical ordering is from bottom to top in units of W m-2. + if ( present (lwupflx) ) then + do k=kts,kte+2 + lwupflx(i,k,j) = uflx(icol,k) + lwupflxc(i,k,j) = uflxc(icol,k) + lwdnflx(i,k,j) = dflx(icol,k) + lwdnflxc(i,k,j) = dflxc(icol,k) + enddo + endif + +! Output heating rate tendency; convert heating rate from K/d to K/s +! Heating rate arrays are ordered vertically from bottom to top here. + do k=kts,kte + tten1d(k) = hr(icol,k)/86400. + rthratenlw(i,k,j) = tten1d(k)/pi3d(i,k,j) + enddo +! + end do i_loop2 + end do j_loop2 + +!------------------------------------------------------------------- + + END SUBROUTINE RRTMG_LWRAD_FAST + + +!------------------------------------------------------------------------- + SUBROUTINE INIRAD (O3PROF,Plev, kts, kte) +!------------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: kts,kte + + REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF + + REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev + +! LOCAL VAR + + INTEGER :: k + +! +! COMPUTE OZONE MIXING RATIO DISTRIBUTION +! + DO K=kts,kte+1 + O3PROF(K)=0. + ENDDO + + CALL O3DATA(O3PROF, Plev, kts, kte) + + END SUBROUTINE INIRAD + +!------------------------------------------------------------------------- + SUBROUTINE O3DATA (O3PROF, Plev, kts, kte) +!------------------------------------------------------------------------- + IMPLICIT NONE +!------------------------------------------------------------------------- +! + INTEGER, INTENT(IN ) :: kts, kte +! + REAL, DIMENSION( kts:kte+1 ),INTENT(INOUT) :: O3PROF + + REAL, DIMENSION( kts:kte+2 ),INTENT(IN ) :: Plev + +! LOCAL VAR + INTEGER :: K, JJ + + REAL :: PRLEVH(kts:kte+2),PPWRKH(32), & + O3WRK(31),PPWRK(31),O3SUM(31),PPSUM(31), & + O3WIN(31),PPWIN(31),O3ANN(31),PPANN(31) + + REAL :: PB1, PB2, PT1, PT2 + + DATA O3SUM /5.297E-8,5.852E-8,6.579E-8,7.505E-8, & + 8.577E-8,9.895E-8,1.175E-7,1.399E-7,1.677E-7,2.003E-7, & + 2.571E-7,3.325E-7,4.438E-7,6.255E-7,8.168E-7,1.036E-6, & + 1.366E-6,1.855E-6,2.514E-6,3.240E-6,4.033E-6,4.854E-6, & + 5.517E-6,6.089E-6,6.689E-6,1.106E-5,1.462E-5,1.321E-5, & + 9.856E-6,5.960E-6,5.960E-6/ + + DATA PPSUM /955.890,850.532,754.599,667.742,589.841, & + 519.421,455.480,398.085,347.171,301.735,261.310,225.360, & + 193.419,165.490,141.032,120.125,102.689, 87.829, 75.123, & + 64.306, 55.086, 47.209, 40.535, 34.795, 29.865, 19.122, & + 9.277, 4.660, 2.421, 1.294, 0.647/ +! + DATA O3WIN /4.629E-8,4.686E-8,5.017E-8,5.613E-8, & + 6.871E-8,8.751E-8,1.138E-7,1.516E-7,2.161E-7,3.264E-7, & + 4.968E-7,7.338E-7,1.017E-6,1.308E-6,1.625E-6,2.011E-6, & + 2.516E-6,3.130E-6,3.840E-6,4.703E-6,5.486E-6,6.289E-6, & + 6.993E-6,7.494E-6,8.197E-6,9.632E-6,1.113E-5,1.146E-5, & + 9.389E-6,6.135E-6,6.135E-6/ + + DATA PPWIN /955.747,841.783,740.199,649.538,568.404, & + 495.815,431.069,373.464,322.354,277.190,237.635,203.433, & + 174.070,148.949,127.408,108.915, 93.114, 79.551, 67.940, & + 58.072, 49.593, 42.318, 36.138, 30.907, 26.362, 16.423, & + 7.583, 3.620, 1.807, 0.938, 0.469/ +! + + DO K=1,31 + PPANN(K)=PPSUM(K) + ENDDO +! + O3ANN(1)=0.5*(O3SUM(1)+O3WIN(1)) +! + DO K=2,31 + O3ANN(K)=O3WIN(K-1)+(O3WIN(K)-O3WIN(K-1))/(PPWIN(K)-PPWIN(K-1))* & + (PPSUM(K)-PPWIN(K-1)) + ENDDO +! + DO K=2,31 + O3ANN(K)=0.5*(O3ANN(K)+O3SUM(K)) + ENDDO +! + DO K=1,31 + O3WRK(K)=O3ANN(K) + PPWRK(K)=PPANN(K) + ENDDO +! +! CALCULATE HALF PRESSURE LEVELS FOR MODEL AND DATA LEVELS +! + +! Plev is total P at model levels, from bottom to top +! Plev is in mb + + DO K=kts,kte+2 + PRLEVH(K)=Plev(K) + ENDDO +! + PPWRKH(1)=1100. + DO K=2,31 + PPWRKH(K)=(PPWRK(K)+PPWRK(K-1))/2. + ENDDO + PPWRKH(32)=0. + DO K=kts,kte+1 + DO 25 JJ=1,31 + IF((-(PRLEVH(K)-PPWRKH(JJ))).GE.0.)THEN + PB1=0. + ELSE + PB1=PRLEVH(K)-PPWRKH(JJ) + ENDIF + IF((-(PRLEVH(K)-PPWRKH(JJ+1))).GE.0.)THEN + PB2=0. + ELSE + PB2=PRLEVH(K)-PPWRKH(JJ+1) + ENDIF + IF((-(PRLEVH(K+1)-PPWRKH(JJ))).GE.0.)THEN + PT1=0. + ELSE + PT1=PRLEVH(K+1)-PPWRKH(JJ) + ENDIF + IF((-(PRLEVH(K+1)-PPWRKH(JJ+1))).GE.0.)THEN + PT2=0. + ELSE + PT2=PRLEVH(K+1)-PPWRKH(JJ+1) + ENDIF + O3PROF(K)=O3PROF(K)+(PB2-PB1-PT2+PT1)*O3WRK(JJ) + 25 CONTINUE + O3PROF(K)=O3PROF(K)/(PRLEVH(K)-PRLEVH(K+1)) + + ENDDO +! + END SUBROUTINE O3DATA + +!------------------------------------------------------------------ + +!==================================================================== + SUBROUTINE rrtmg_lwinit_fast( & + p_top, allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + + LOGICAL , INTENT(IN) :: allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + REAL, INTENT(IN) :: p_top + +! Steven Cavallo. Added for buffer layer adjustment. December 2010. + NLAYERS = kme + nint(p_top*0.01/deltap)- 1 ! Model levels plus new levels. + ! nlayers will subsequently + ! replace kte+1 + +! Read in absorption coefficients and other data + IF ( allowed_to_read ) THEN + CALL rrtmg_lwlookuptable + ENDIF + +! Perform g-point reduction and other initializations +! Specific heat of dry air (cp) used in flux to heating rate conversion factor. + call rrtmg_lw_ini(cp) + + END SUBROUTINE rrtmg_lwinit_fast + + +! ************************************************************************** + SUBROUTINE rrtmg_lwlookuptable +! ************************************************************************** + +IMPLICIT NONE + +! Local + INTEGER :: i + LOGICAL :: opened + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + + CHARACTER*80 errmess + INTEGER rrtmg_unit + + IF ( wrf_dm_on_monitor() ) THEN + DO i = 10,99 + INQUIRE ( i , OPENED = opened ) + IF ( .NOT. opened ) THEN + rrtmg_unit = i + GOTO 2010 + ENDIF + ENDDO + rrtmg_unit = -1 + 2010 CONTINUE + ENDIF + CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE ) + IF ( rrtmg_unit < 0 ) THEN + CALL wrf_error_fatal ( 'module_ra_rrtmg_lwf: rrtm_lwlookuptable: Can not '// & + 'find unused fortran unit to read in lookup table.' ) + ENDIF + + IF ( wrf_dm_on_monitor() ) THEN + OPEN(rrtmg_unit,FILE='RRTMG_LW_DATA', & + FORM='UNFORMATTED',STATUS='OLD',ERR=9009) + ENDIF + + call lw_kgb01(rrtmg_unit) + call lw_kgb02(rrtmg_unit) + call lw_kgb03(rrtmg_unit) + call lw_kgb04(rrtmg_unit) + call lw_kgb05(rrtmg_unit) + call lw_kgb06(rrtmg_unit) + call lw_kgb07(rrtmg_unit) + call lw_kgb08(rrtmg_unit) + call lw_kgb09(rrtmg_unit) + call lw_kgb10(rrtmg_unit) + call lw_kgb11(rrtmg_unit) + call lw_kgb12(rrtmg_unit) + call lw_kgb13(rrtmg_unit) + call lw_kgb14(rrtmg_unit) + call lw_kgb15(rrtmg_unit) + call lw_kgb16(rrtmg_unit) + + IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit) + + RETURN +9009 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error opening RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + END SUBROUTINE rrtmg_lwlookuptable + +! ************************************************************************** +! RRTMG Longwave Radiative Transfer Model +! Atmospheric and Environmental Research, Inc., Cambridge, MA +! +! Original version: E. J. Mlawer, et al. +! Revision for GCMs: Michael J. Iacono; October, 2002 +! Revision for F90 formatting: Michael J. Iacono; June 2006 +! +! This file contains 16 READ statements that include the +! absorption coefficients and other data for each of the 16 longwave +! spectral bands used in RRTMG_LW. Here, the data are defined for 16 +! g-points, or sub-intervals, per band. These data are combined and +! weighted using a mapping procedure in module RRTMG_LW_INIT to reduce +! the total number of g-points from 256 to 140 for use in the GCM. +! ************************************************************************** + +! ************************************************************************** + subroutine lw_kgb01(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg01_f, only : fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, & + absa, absb, & + selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: P = 212.7250 mbar, T = 223.06 K + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The arrays kao_mn2 and kbo_mn2 contain the coefficients of the +! nitrogen continuum for the upper and lower atmosphere. +! Minor gas mapping levels: +! Lower - n2: P = 142.5490 mbar, T = 215.70 K +! Upper - n2: P = 142.5490 mbar, T = 215.70 K + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, kao_mn2, kbo_mn2, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(kao_mn2) + DM_BCAST_MACRO(kbo_mn2) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb01 + +! ************************************************************************** + subroutine lw_kgb02(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg02_f, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 1053.630 mbar, T = 294.2 K +! Upper: P = 3.206e-2 mb, T = 197.92 K + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb02 + +! ************************************************************************** + subroutine lw_kgb03(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg03_f, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, & + kbo_mn2o, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 212.7250 mbar, T = 223.06 K +! Upper: P = 95.8 mbar, T = 215.7 k + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amounts ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 to +! that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(kao_mn2o) + DM_BCAST_MACRO(kbo_mn2o) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb03 + +! ************************************************************************** + subroutine lw_kgb04(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg04_f, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower : P = 142.5940 mbar, T = 215.70 K +! Upper : P = 95.58350 mb, T = 215.70 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels < ~100mb, temperatures, and ratios +! of H2O to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index, JT, which +! runs from 1 to 5, corresponds to different temperatures. More +! specifically, JT = 3 means that the data are for the corresponding +! reference temperature TREF for this pressure level, JT = 2 refers +! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and +! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and +! refers to the corresponding pressure level in PREF (e.g. JP = 13 is +! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to +! 16, and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb04 + +! ************************************************************************** + subroutine lw_kgb05(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg05_f, only : fracrefao, fracrefbo, kao, kbo, kao_mo3, & + selfrefo, forrefo, ccl4o + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 473.42 mb, T = 259.83 +! Upper: P = 0.2369280 mbar, T = 253.60 K + +! The arrays kao_mo3 and ccl4o contain the coefficients for +! ozone and ccl4 in the lower atmosphere. +! Minor gas mapping level: +! Lower - o3: P = 317.34 mbar, T = 240.77 k +! Lower - ccl4: + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels < ~100mb, temperatures, and ratios +! of H2O to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index, JT, which +! runs from 1 to 5, corresponds to different temperatures. More +! specifically, JT = 3 means that the data are for the corresponding +! reference temperature TREF for this pressure level, JT = 2 refers +! to the TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and +! JT = 5 is for TREF+30. The third index, JP, runs from 13 to 59 and +! refers to the corresponding pressure level in PREF (e.g. JP = 13 is +! for a pressure of 95.5835 mb). The fourth index, IG, goes from 1 to +! 16, and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, kao_mo3, ccl4o, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(kao_mo3) + DM_BCAST_MACRO(ccl4o) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb05 + +! ************************************************************************** + subroutine lw_kgb06(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg06_f, only : fracrefao, kao, kao_mco2, selfrefo, forrefo, & + cfc11adjo, cfc12o + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: : P = 473.4280 mb, T = 259.83 K + +! The arrays kao_mco2, cfc11adjo and cfc12o contain the coefficients for +! carbon dioxide in the lower atmosphere and cfc11 and cfc12 in the upper +! atmosphere. +! Original cfc11 is multiplied by 1.385 to account for the 1060-1107 cm-1 band. +! Minor gas mapping level: +! Lower - co2: P = 706.2720 mb, T = 294.2 k +! Upper - cfc11, cfc12 + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, kao, kao_mco2, cfc11adjo, cfc12o, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kao_mco2) + DM_BCAST_MACRO(cfc11adjo) + DM_BCAST_MACRO(cfc12o) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb06 + +! ************************************************************************** + subroutine lw_kgb07(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg07_f, only : fracrefao, fracrefbo, kao, kbo, kao_mco2, & + kbo_mco2, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower : P = 706.27 mb, T = 278.94 K +! Upper : P = 95.58 mbar, T= 215.70 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296_rb,260_rb,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(kao_mco2) + DM_BCAST_MACRO(kbo_mco2) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb07 + +! ************************************************************************** + subroutine lw_kgb08(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg08_f, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mn2o, & + kao_mo3, kbo, kbo_mco2, kbo_mn2o, selfrefo, forrefo, & + cfc12o, cfc22adjo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P=473.4280 mb, T = 259.83 K +! Upper: P=95.5835 mb, T= 215.7 K + +! The arrays kao_mco2, kbo_mco2, kao_mn2o, kbo_mn2o contain the coefficients for +! carbon dioxide and n2o in the lower and upper atmosphere. +! The array kao_mo3 contains the coefficients for ozone in the lower atmosphere, +! and arrays cfc12o and cfc12adjo contain the coefficients for cfc12 and cfc22. +! Original cfc22 is multiplied by 1.485 to account for the 780-850 cm-1 +! and 1290-1335 cm-1 bands. +! Minor gas mapping level: +! Lower - co2: P = 1053.63 mb, T = 294.2 k +! Lower - o3: P = 317.348 mb, T = 240.77 k +! Lower - n2o: P = 706.2720 mb, T= 278.94 k +! Lower - cfc12, cfc22 +! Upper - co2: P = 35.1632 mb, T = 223.28 k +! Upper - n2o: P = 8.716e-2 mb, T = 226.03 k + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, kao_mco2, kbo_mco2, kao_mn2o, & + kbo_mn2o, kao_mo3, cfc12o, cfc22adjo, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(kao_mco2) + DM_BCAST_MACRO(kbo_mco2) + DM_BCAST_MACRO(kao_mn2o) + DM_BCAST_MACRO(kbo_mn2o) + DM_BCAST_MACRO(kao_mo3) + DM_BCAST_MACRO(cfc12o) + DM_BCAST_MACRO(cfc22adjo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb08 + +! ************************************************************************** + subroutine lw_kgb09(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg09_f, only : fracrefao, fracrefbo, kao, kbo, kao_mn2o, & + kbo_mn2o, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P=212.7250 mb, T = 223.06 K +! Upper: P=3.20e-2 mb, T = 197.92 k + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, kao_mn2o, kbo_mn2o, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(kao_mn2o) + DM_BCAST_MACRO(kbo_mn2o) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb09 + +! ************************************************************************** + subroutine lw_kgb10(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg10_f, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 212.7250 mb, T = 223.06 K +! Upper: P = 95.58350 mb, T = 215.70 K + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb10 + +! ************************************************************************** + subroutine lw_kgb11(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg11_f, only : fracrefao, fracrefbo, kao, kbo, kao_mo2, & + kbo_mo2, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P=1053.63 mb, T= 294.2 K +! Upper: P=0.353 mb, T = 262.11 K + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels > ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the corresponding TREF for this pressure level, +! JT = 2 refers to the temperatureTREF-15, JT = 1 is for TREF-30, +! JT = 4 is for TREF+15, and JT = 5 is for TREF+30. The second +! index, JP, runs from 1 to 13 and refers to the corresponding +! pressure level in PREF (e.g. JP = 1 is for a pressure of 1053.63 mb). +! The third index, IG, goes from 1 to 16, and tells us which +! g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, kao_mo2, kbo_mo2, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(kao_mo2) + DM_BCAST_MACRO(kbo_mo2) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb11 + +! ************************************************************************** + subroutine lw_kgb12(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg12_f, only : fracrefao, kao, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 174.1640 mbar, T= 215.78 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, kao, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb12 + +! ************************************************************************** + subroutine lw_kgb13(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg13_f, only : fracrefao, fracrefbo, kao, kao_mco2, kao_mco, & + kbo_mo3, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P=473.4280 mb, T = 259.83 K +! Upper: P=4.758820 mb, T = 250.85 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KAO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array KBO_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level above 100~ mb. The first index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The second index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kao_mco2, kao_mco, kbo_mo3, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kao_mco2) + DM_BCAST_MACRO(kao_mco) + DM_BCAST_MACRO(kbo_mo3) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb13 + +! ************************************************************************** + subroutine lw_kgb14(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg14_f, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 142.5940 mb, T = 215.70 K +! Upper: P = 4.758820 mb, T = 250.85 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb14 + +! ************************************************************************** + subroutine lw_kgb15(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg15_f, only : fracrefao, kao, kao_mn2, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 1053. mb, T = 294.2 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KA_Mxx contains the absorption coefficient for +! a minor species at the 16 chosen g-values for a reference pressure +! level below 100~ mb. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. The second index refers to temperature +! in 7.2 degree increments. For instance, JT = 1 refers to a +! temperature of 188.0, JT = 2 refers to 195.2, etc. The third index +! runs over the g-channel (1 to 16). + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, kao, kao_mn2, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kao_mn2) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb15 + +! ************************************************************************** + subroutine lw_kgb16(rrtmg_unit) +! ************************************************************************** + + use rrlw_kg16_f, only : fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Arrays fracrefao and fracrefbo are the Planck fractions for the lower +! and upper atmosphere. +! Planck fraction mapping levels: +! Lower: P = 387.6100 mbar, T = 250.17 K +! Upper: P=95.58350 mb, T = 215.70 K + +! The array KAO contains absorption coefs for each of the 16 g-intervals +! for a range of pressure levels > ~100mb, temperatures, and ratios +! of water vapor to CO2. The first index in the array, JS, runs +! from 1 to 10, and corresponds to different gas column amount ratios, +! as expressed through the binary species parameter eta, defined as +! eta = gas1/(gas1 + (rat) * gas2), where rat is the +! ratio of the reference MLS column amount value of gas 1 +! to that of gas2. +! The 2nd index in the array, JT, which runs from 1 to 5, corresponds +! to different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature +! TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the reference pressure level (e.g. JP = 1 is for a +! pressure of 1053.63 mb). The fourth index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + fracrefao, fracrefbo, kao, kbo, selfrefo, forrefo + DM_BCAST_MACRO(fracrefao) + DM_BCAST_MACRO(fracrefbo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_lwf: error reading RRTMG_LW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine lw_kgb16 + +!=============================================================================== + subroutine relcalc(icol, pcols, pver, t, landfrac, landm, icefrac, rel, snowh) +!----------------------------------------------------------------------- +! +! Purpose: +! Compute cloud water size +! +! Method: +! analytic formula following the formulation originally developed by J. T. Kiehl +! +! Author: Phil Rasch +! +!----------------------------------------------------------------------- + implicit none +!------------------------------Arguments-------------------------------- +! +! Input arguments +! + integer, intent(in) :: icol + integer, intent(in) :: pcols, pver + real, intent(in) :: landfrac(pcols) ! Land fraction + real, intent(in) :: icefrac(pcols) ! Ice fraction + real, intent(in) :: snowh(pcols) ! Snow depth over land, water equivalent (m) + real, intent(in) :: landm(pcols) ! Land fraction ramping to zero over ocean + real, intent(in) :: t(pcols,pver) ! Temperature + +! +! Output arguments +! + real, intent(out) :: rel(pcols,pver) ! Liquid effective drop size (microns) +! +!---------------------------Local workspace----------------------------- +! + integer i,k ! Lon, lev indices + real tmelt ! freezing temperature of fresh water (K) + real rliqland ! liquid drop size if over land + real rliqocean ! liquid drop size if over ocean + real rliqice ! liquid drop size if over sea ice +! +!----------------------------------------------------------------------- +! + tmelt = 273.16 + rliqocean = 14.0 + rliqice = 14.0 + rliqland = 8.0 + do k=1,pver +! do i=1,ncol +! jrm Reworked effective radius algorithm + ! Start with temperature-dependent value appropriate for continental air + ! Note: findmcnew has a pressure dependence here + rel(icol,k) = rliqland + (rliqocean-rliqland) * min(1.0,max(0.0,(tmelt-t(icol,k))*0.05)) + ! Modify for snow depth over land + rel(icol,k) = rel(icol,k) + (rliqocean-rel(icol,k)) * min(1.0,max(0.0,snowh(icol)*10.)) + ! Ramp between polluted value over land to clean value over ocean. + rel(icol,k) = rel(icol,k) + (rliqocean-rel(icol,k)) * min(1.0,max(0.0,1.0-landm(icol))) + ! Ramp between the resultant value and a sea ice value in the presence of ice. + rel(icol,k) = rel(icol,k) + (rliqice-rel(icol,k)) * min(1.0,max(0.0,icefrac(icol))) +! end jrm +! end do + end do + end subroutine relcalc +!=============================================================================== + subroutine reicalc(icol, pcols, pver, t, re) + ! + + integer, intent(in) :: icol, pcols, pver + real, intent(out) :: re(pcols,pver) + real, intent(in) :: t(pcols,pver) + real corr + integer i + integer k + integer index + ! + ! Tabulated values of re(T) in the temperature interval + ! 180 K -- 274 K; hexagonal columns assumed: + ! + ! + do k=1,pver +! do i=1,ncol + index = int(t(icol,k)-179.) + index = min(max(index,1),94) + corr = t(icol,k) - int(t(icol,k)) + re(icol,k) = retab(index)*(1.-corr) & + +retab(index+1)*corr + ! re(icol,k) = amax1(amin1(re(icol,k),30.),10.) +! end do + end do + ! + return + end subroutine reicalc +!------------------------------------------------------------------ + +END MODULE module_ra_rrtmg_lwf diff --git a/wrfv2_fire/phys/module_ra_rrtmg_sw.F b/wrfv2_fire/phys/module_ra_rrtmg_sw.F index 0d5ec52f..05cdafd9 100644 --- a/wrfv2_fire/phys/module_ra_rrtmg_sw.F +++ b/wrfv2_fire/phys/module_ra_rrtmg_sw.F @@ -2049,7 +2049,7 @@ subroutine cldprmc_sw(nlayers, inflag, iceflag, liqflag, cldfmc, & ! Initialize - hvrclc = '$Revision: 1.3 $' +!jm not thread safe hvrclc = '$Revision: 1.3 $' ! Some of these initializations are done elsewhere do lay = 1, nlayers @@ -2517,7 +2517,7 @@ subroutine reftra_sw(nlayers, lrtchk, pgg, prmuz, ptau, pw, & ! Initialize - hvrrft = '$Revision: 1.3 $' +!jm not thread safe hvrrft = '$Revision: 1.3 $' zsr3=sqrt(3._rb) zwcrit=0.9999995_rb @@ -3266,7 +3266,7 @@ subroutine taumol_sw(nlayers, & ! real(kind=rb), intent(out) :: ssa(:,:) ! single scattering albedo (inactive) ! Dimensions: (nlayers,ngptsw) - hvrtau = '$Revision: 1.3 $' +!jm not thread safe hvrtau = '$Revision: 1.3 $' ! Calculate gaseous optical depth and planck fractions for each spectral band. @@ -4607,7 +4607,7 @@ subroutine rrtmg_sw_ini(cpdair) ! BPADE Inverse of the Pade approximation constant ! - hvrini = '$Revision: 1.3 $' +!jm not thread safe hvrini = '$Revision: 1.3 $' ! Initialize model data call swdatinit(cpdair) @@ -4705,7 +4705,7 @@ subroutine swdatinit(cpdair) use rrsw_con, only: heatfac, grav, planck, boltz, & clight, avogad, alosmt, gascon, radcn1, radcn2, & - sbcnst, secdy + sbcnst, secdy, oneminus, pi use rrsw_vsn save @@ -4751,6 +4751,11 @@ subroutine swdatinit(cpdair) ! (W cm-2 K-4) secdy = 8.6400e4_rb ! Number of seconds per day ! (s d-1) + +!jm 20141107 moved here for thread safety + oneminus = 1.0_rb - 1.e-06_rb ! zepsec + pi = 2._rb * asin(1._rb) + ! ! units are generally cgs ! @@ -6061,7 +6066,6 @@ end subroutine cmbgb29 !*********************************************************************** subroutine swcldpr -!*********************************************************************** ! Purpose: Define cloud extinction coefficient, single scattering albedo ! and asymmetry parameter data. @@ -6113,14 +6117,17 @@ subroutine swcldpr ! ice particles larger than 140.0 microns. ! LIQFLAG = 1: The water droplet effective radius (microns) is input ! and the optical depths due to water clouds are computed -! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993). +! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993) with +! modified coefficients derived from Mie scattering calculations. ! The values for absorption coefficients appropriate for -! the spectral bands in RRTM have been obtained for a +! the spectral bands in RRTM/RRTMG have been obtained for a ! range of effective radii by an averaging procedure ! based on the work of J. Pinto (private communication). ! Linear interpolation is used to get the absorption ! coefficients for the input effective radius. ! +!..Updated tables suggested by Peter Blossey (Univ. Washington) that came from RRTM v3.9 from AER, Inc. +! ! ------------------------------------------------------------------ ! Everything below is for INFLAG = 2. @@ -6139,557 +6146,597 @@ subroutine swcldpr fbari(:) = (/ & & 5.851e-04_rb,5.665e-04_rb,7.204e-04_rb,7.463e-04_rb,1.076e-04_rb /) -! Extinction coefficient +! LIQFLAG==1 extinction coefficients, single scattering albedos, and asymmetry parameters +! Derived from on Mie scattering computations; based on Hu & Stamnes coefficients +! BAND 16 extliq1(:, 16) = (/ & - & 8.981463e-01_rb,6.317895e-01_rb,4.557508e-01_rb,3.481624e-01_rb,2.797950e-01_rb,& - & 2.342753e-01_rb,2.026934e-01_rb,1.800102e-01_rb,1.632408e-01_rb,1.505384e-01_rb,& - & 1.354524e-01_rb,1.246520e-01_rb,1.154342e-01_rb,1.074756e-01_rb,1.005353e-01_rb,& - & 9.442987e-02_rb,8.901760e-02_rb,8.418693e-02_rb,7.984904e-02_rb,7.593229e-02_rb,& - & 7.237827e-02_rb,6.913887e-02_rb,6.617415e-02_rb,6.345061e-02_rb,6.094001e-02_rb,& - & 5.861834e-02_rb,5.646506e-02_rb,5.446250e-02_rb,5.249596e-02_rb,5.081114e-02_rb,& - & 4.922243e-02_rb,4.772189e-02_rb,4.630243e-02_rb,4.495766e-02_rb,4.368189e-02_rb,& - & 4.246995e-02_rb,4.131720e-02_rb,4.021941e-02_rb,3.917276e-02_rb,3.817376e-02_rb,& - & 3.721926e-02_rb,3.630635e-02_rb,3.543237e-02_rb,3.459491e-02_rb,3.379171e-02_rb,& - & 3.302073e-02_rb,3.228007e-02_rb,3.156798e-02_rb,3.088284e-02_rb,3.022315e-02_rb,& - & 2.958753e-02_rb,2.897468e-02_rb,2.838340e-02_rb,2.781258e-02_rb,2.726117e-02_rb,& - & 2.672821e-02_rb,2.621278e-02_rb,2.5714e-02_rb /) + & 9.004493E-01_rb,6.366723E-01_rb,4.542354E-01_rb,3.468253E-01_rb,2.816431E-01_rb,& + & 2.383415E-01_rb,2.070854E-01_rb,1.831854E-01_rb,1.642115E-01_rb,1.487539E-01_rb,& + & 1.359169E-01_rb,1.250900E-01_rb,1.158354E-01_rb,1.078400E-01_rb,1.008646E-01_rb,& + & 9.472307E-02_rb,8.928000E-02_rb,8.442308E-02_rb,8.005924E-02_rb,7.612231E-02_rb,& + & 7.255153E-02_rb,6.929539E-02_rb,6.631769E-02_rb,6.358153E-02_rb,6.106231E-02_rb,& + & 5.873077E-02_rb,5.656924E-02_rb,5.455769E-02_rb,5.267846E-02_rb,5.091923E-02_rb,& + & 4.926692E-02_rb,4.771154E-02_rb,4.623923E-02_rb,4.484385E-02_rb,4.351539E-02_rb,& + & 4.224615E-02_rb,4.103385E-02_rb,3.986538E-02_rb,3.874077E-02_rb,3.765462E-02_rb,& + & 3.660077E-02_rb,3.557384E-02_rb,3.457615E-02_rb,3.360308E-02_rb,3.265000E-02_rb,& + & 3.171770E-02_rb,3.080538E-02_rb,2.990846E-02_rb,2.903000E-02_rb,2.816461E-02_rb,& + & 2.731539E-02_rb,2.648231E-02_rb,2.566308E-02_rb,2.485923E-02_rb,2.407000E-02_rb,& + & 2.329615E-02_rb,2.253769E-02_rb,2.179615E-02_rb /) +! BAND 17 extliq1(:, 17) = (/ & - & 8.293797e-01_rb,6.048371e-01_rb,4.465706e-01_rb,3.460387e-01_rb,2.800064e-01_rb,& - & 2.346584e-01_rb,2.022399e-01_rb,1.782626e-01_rb,1.600153e-01_rb,1.457903e-01_rb,& - & 1.334061e-01_rb,1.228548e-01_rb,1.138396e-01_rb,1.060486e-01_rb,9.924856e-02_rb,& - & 9.326208e-02_rb,8.795158e-02_rb,8.320883e-02_rb,7.894750e-02_rb,7.509792e-02_rb,& - & 7.160323e-02_rb,6.841653e-02_rb,6.549889e-02_rb,6.281763e-02_rb,6.034516e-02_rb,& - & 5.805802e-02_rb,5.593615e-02_rb,5.396226e-02_rb,5.202302e-02_rb,5.036246e-02_rb,& - & 4.879606e-02_rb,4.731610e-02_rb,4.591565e-02_rb,4.458852e-02_rb,4.332912e-02_rb,& - & 4.213243e-02_rb,4.099390e-02_rb,3.990941e-02_rb,3.887522e-02_rb,3.788792e-02_rb,& - & 3.694440e-02_rb,3.604183e-02_rb,3.517760e-02_rb,3.434934e-02_rb,3.355485e-02_rb,& - & 3.279211e-02_rb,3.205925e-02_rb,3.135458e-02_rb,3.067648e-02_rb,3.002349e-02_rb,& - & 2.939425e-02_rb,2.878748e-02_rb,2.820200e-02_rb,2.763673e-02_rb,2.709062e-02_rb,& - & 2.656272e-02_rb,2.605214e-02_rb,2.5558e-02_rb /) + & 6.741200e-01_rb,5.390739e-01_rb,4.198767e-01_rb,3.332553e-01_rb,2.735633e-01_rb,& + & 2.317727e-01_rb,2.012760e-01_rb,1.780400e-01_rb,1.596927e-01_rb,1.447980e-01_rb,& + & 1.324480e-01_rb,1.220347e-01_rb,1.131327e-01_rb,1.054313e-01_rb,9.870534e-02_rb,& + & 9.278200e-02_rb,8.752599e-02_rb,8.282933e-02_rb,7.860600e-02_rb,7.479133e-02_rb,& + & 7.132800e-02_rb,6.816733e-02_rb,6.527401e-02_rb,6.261266e-02_rb,6.015934e-02_rb,& + & 5.788867e-02_rb,5.578134e-02_rb,5.381667e-02_rb,5.198133e-02_rb,5.026067e-02_rb,& + & 4.864466e-02_rb,4.712267e-02_rb,4.568066e-02_rb,4.431200e-02_rb,4.300867e-02_rb,& + & 4.176600e-02_rb,4.057400e-02_rb,3.942534e-02_rb,3.832066e-02_rb,3.725068e-02_rb,& + & 3.621400e-02_rb,3.520533e-02_rb,3.422333e-02_rb,3.326400e-02_rb,3.232467e-02_rb,& + & 3.140535e-02_rb,3.050400e-02_rb,2.962000e-02_rb,2.875267e-02_rb,2.789800e-02_rb,& + & 2.705934e-02_rb,2.623667e-02_rb,2.542667e-02_rb,2.463200e-02_rb,2.385267e-02_rb,& + & 2.308667e-02_rb,2.233667e-02_rb,2.160067e-02_rb /) +! BAND 18 extliq1(:, 18) = (/ & - & 9.193685e-01_rb,6.128292e-01_rb,4.344150e-01_rb,3.303048e-01_rb,2.659500e-01_rb,& - & 2.239727e-01_rb,1.953457e-01_rb,1.751012e-01_rb,1.603515e-01_rb,1.493360e-01_rb,& - & 1.323791e-01_rb,1.219335e-01_rb,1.130076e-01_rb,1.052926e-01_rb,9.855839e-02_rb,& - & 9.262925e-02_rb,8.736918e-02_rb,8.267112e-02_rb,7.844965e-02_rb,7.463585e-02_rb,& - & 7.117343e-02_rb,6.801601e-02_rb,6.512503e-02_rb,6.246815e-02_rb,6.001806e-02_rb,& - & 5.775154e-02_rb,5.564872e-02_rb,5.369250e-02_rb,5.176284e-02_rb,5.011536e-02_rb,& - & 4.856099e-02_rb,4.709211e-02_rb,4.570193e-02_rb,4.438430e-02_rb,4.313375e-02_rb,& - & 4.194529e-02_rb,4.081443e-02_rb,3.973712e-02_rb,3.870966e-02_rb,3.772866e-02_rb,& - & 3.679108e-02_rb,3.589409e-02_rb,3.503514e-02_rb,3.421185e-02_rb,3.342206e-02_rb,& - & 3.266377e-02_rb,3.193513e-02_rb,3.123447e-02_rb,3.056018e-02_rb,2.991081e-02_rb,& - & 2.928502e-02_rb,2.868154e-02_rb,2.809920e-02_rb,2.753692e-02_rb,2.699367e-02_rb,& - & 2.646852e-02_rb,2.596057e-02_rb,2.5469e-02_rb /) + & 9.250861e-01_rb,6.245692e-01_rb,4.347038e-01_rb,3.320208e-01_rb,2.714869e-01_rb,& + & 2.309516e-01_rb,2.012592e-01_rb,1.783315e-01_rb,1.600369e-01_rb,1.451000e-01_rb,& + & 1.326838e-01_rb,1.222069e-01_rb,1.132554e-01_rb,1.055146e-01_rb,9.876000e-02_rb,& + & 9.281386e-02_rb,8.754000e-02_rb,8.283078e-02_rb,7.860077e-02_rb,7.477769e-02_rb,& + & 7.130847e-02_rb,6.814461e-02_rb,6.524615e-02_rb,6.258462e-02_rb,6.012847e-02_rb,& + & 5.785462e-02_rb,5.574231e-02_rb,5.378000e-02_rb,5.194461e-02_rb,5.022462e-02_rb,& + & 4.860846e-02_rb,4.708462e-02_rb,4.564154e-02_rb,4.427462e-02_rb,4.297231e-02_rb,& + & 4.172769e-02_rb,4.053693e-02_rb,3.939000e-02_rb,3.828462e-02_rb,3.721692e-02_rb,& + & 3.618000e-02_rb,3.517077e-02_rb,3.418923e-02_rb,3.323077e-02_rb,3.229154e-02_rb,& + & 3.137154e-02_rb,3.047154e-02_rb,2.959077e-02_rb,2.872308e-02_rb,2.786846e-02_rb,& + & 2.703077e-02_rb,2.620923e-02_rb,2.540077e-02_rb,2.460615e-02_rb,2.382693e-02_rb,& + & 2.306231e-02_rb,2.231231e-02_rb,2.157923e-02_rb /) +! BAND 19 extliq1(:, 19) = (/ & - & 9.136931e-01_rb,5.743244e-01_rb,4.080708e-01_rb,3.150572e-01_rb,2.577261e-01_rb,& - & 2.197900e-01_rb,1.933037e-01_rb,1.740212e-01_rb,1.595056e-01_rb,1.482756e-01_rb,& - & 1.312164e-01_rb,1.209246e-01_rb,1.121227e-01_rb,1.045095e-01_rb,9.785967e-02_rb,& - & 9.200149e-02_rb,8.680170e-02_rb,8.215531e-02_rb,7.797850e-02_rb,7.420361e-02_rb,& - & 7.077530e-02_rb,6.764798e-02_rb,6.478369e-02_rb,6.215063e-02_rb,5.972189e-02_rb,& - & 5.747458e-02_rb,5.538913e-02_rb,5.344866e-02_rb,5.153216e-02_rb,4.989745e-02_rb,& - & 4.835476e-02_rb,4.689661e-02_rb,4.551629e-02_rb,4.420777e-02_rb,4.296563e-02_rb,& - & 4.178497e-02_rb,4.066137e-02_rb,3.959081e-02_rb,3.856963e-02_rb,3.759452e-02_rb,& - & 3.666244e-02_rb,3.577061e-02_rb,3.491650e-02_rb,3.409777e-02_rb,3.331227e-02_rb,& - & 3.255803e-02_rb,3.183322e-02_rb,3.113617e-02_rb,3.046530e-02_rb,2.981918e-02_rb,& - & 2.919646e-02_rb,2.859591e-02_rb,2.801635e-02_rb,2.745671e-02_rb,2.691599e-02_rb,& - & 2.639324e-02_rb,2.588759e-02_rb,2.5398e-02_rb /) + & 9.298960e-01_rb,5.776460e-01_rb,4.083450e-01_rb,3.211160e-01_rb,2.666390e-01_rb,& + & 2.281990e-01_rb,1.993250e-01_rb,1.768080e-01_rb,1.587810e-01_rb,1.440390e-01_rb,& + & 1.317720e-01_rb,1.214150e-01_rb,1.125540e-01_rb,1.048890e-01_rb,9.819600e-02_rb,& + & 9.230201e-02_rb,8.706900e-02_rb,8.239698e-02_rb,7.819500e-02_rb,7.439899e-02_rb,& + & 7.095300e-02_rb,6.780700e-02_rb,6.492900e-02_rb,6.228600e-02_rb,5.984600e-02_rb,& + & 5.758599e-02_rb,5.549099e-02_rb,5.353801e-02_rb,5.171400e-02_rb,5.000500e-02_rb,& + & 4.840000e-02_rb,4.688500e-02_rb,4.545100e-02_rb,4.409300e-02_rb,4.279700e-02_rb,& + & 4.156100e-02_rb,4.037700e-02_rb,3.923800e-02_rb,3.813800e-02_rb,3.707600e-02_rb,& + & 3.604500e-02_rb,3.504300e-02_rb,3.406500e-02_rb,3.310800e-02_rb,3.217700e-02_rb,& + & 3.126600e-02_rb,3.036800e-02_rb,2.948900e-02_rb,2.862400e-02_rb,2.777500e-02_rb,& + & 2.694200e-02_rb,2.612300e-02_rb,2.531700e-02_rb,2.452800e-02_rb,2.375100e-02_rb,& + & 2.299100e-02_rb,2.224300e-02_rb,2.151201e-02_rb /) +! BAND 20 extliq1(:, 20) = (/ & - & 8.447548e-01_rb,5.326840e-01_rb,3.921523e-01_rb,3.119082e-01_rb,2.597055e-01_rb,& - & 2.228737e-01_rb,1.954157e-01_rb,1.741155e-01_rb,1.570881e-01_rb,1.431520e-01_rb,& - & 1.302034e-01_rb,1.200491e-01_rb,1.113571e-01_rb,1.038330e-01_rb,9.725657e-02_rb,& - & 9.145949e-02_rb,8.631112e-02_rb,8.170840e-02_rb,7.756901e-02_rb,7.382641e-02_rb,& - & 7.042616e-02_rb,6.732338e-02_rb,6.448069e-02_rb,6.186672e-02_rb,5.945494e-02_rb,& - & 5.722277e-02_rb,5.515089e-02_rb,5.322262e-02_rb,5.132153e-02_rb,4.969799e-02_rb,& - & 4.816556e-02_rb,4.671686e-02_rb,4.534525e-02_rb,4.404480e-02_rb,4.281014e-02_rb,& - & 4.163643e-02_rb,4.051930e-02_rb,3.945479e-02_rb,3.843927e-02_rb,3.746945e-02_rb,& - & 3.654234e-02_rb,3.565518e-02_rb,3.480547e-02_rb,3.399088e-02_rb,3.320930e-02_rb,& - & 3.245876e-02_rb,3.173745e-02_rb,3.104371e-02_rb,3.037600e-02_rb,2.973287e-02_rb,& - & 2.911300e-02_rb,2.851516e-02_rb,2.793818e-02_rb,2.738101e-02_rb,2.684264e-02_rb,& - & 2.632214e-02_rb,2.581863e-02_rb,2.5331e-02_rb /) + & 8.780964e-01_rb,5.407031e-01_rb,3.961100e-01_rb,3.166645e-01_rb,2.640455e-01_rb,& + & 2.261070e-01_rb,1.974820e-01_rb,1.751775e-01_rb,1.573415e-01_rb,1.427725e-01_rb,& + & 1.306535e-01_rb,1.204195e-01_rb,1.116650e-01_rb,1.040915e-01_rb,9.747550e-02_rb,& + & 9.164800e-02_rb,8.647649e-02_rb,8.185501e-02_rb,7.770200e-02_rb,7.394749e-02_rb,& + & 7.053800e-02_rb,6.742700e-02_rb,6.457999e-02_rb,6.196149e-02_rb,5.954450e-02_rb,& + & 5.730650e-02_rb,5.522949e-02_rb,5.329450e-02_rb,5.148500e-02_rb,4.979000e-02_rb,& + & 4.819600e-02_rb,4.669301e-02_rb,4.527050e-02_rb,4.391899e-02_rb,4.263500e-02_rb,& + & 4.140500e-02_rb,4.022850e-02_rb,3.909500e-02_rb,3.800199e-02_rb,3.694600e-02_rb,& + & 3.592000e-02_rb,3.492250e-02_rb,3.395050e-02_rb,3.300150e-02_rb,3.207250e-02_rb,& + & 3.116250e-02_rb,3.027100e-02_rb,2.939500e-02_rb,2.853500e-02_rb,2.768900e-02_rb,& + & 2.686000e-02_rb,2.604350e-02_rb,2.524150e-02_rb,2.445350e-02_rb,2.368049e-02_rb,& + & 2.292150e-02_rb,2.217800e-02_rb,2.144800e-02_rb /) +! BAND 21 extliq1(:, 21) = (/ & - & 7.727642e-01_rb,5.034865e-01_rb,3.808673e-01_rb,3.080333e-01_rb,2.586453e-01_rb,& - & 2.224989e-01_rb,1.947060e-01_rb,1.725821e-01_rb,1.545096e-01_rb,1.394456e-01_rb,& - & 1.288683e-01_rb,1.188852e-01_rb,1.103317e-01_rb,1.029214e-01_rb,9.643967e-02_rb,& - & 9.072239e-02_rb,8.564194e-02_rb,8.109758e-02_rb,7.700875e-02_rb,7.331026e-02_rb,& - & 6.994879e-02_rb,6.688028e-02_rb,6.406807e-02_rb,6.148133e-02_rb,5.909400e-02_rb,& - & 5.688388e-02_rb,5.483197e-02_rb,5.292185e-02_rb,5.103763e-02_rb,4.942905e-02_rb,& - & 4.791039e-02_rb,4.647438e-02_rb,4.511453e-02_rb,4.382497e-02_rb,4.260043e-02_rb,& - & 4.143616e-02_rb,4.032784e-02_rb,3.927155e-02_rb,3.826375e-02_rb,3.730117e-02_rb,& - & 3.638087e-02_rb,3.550013e-02_rb,3.465646e-02_rb,3.384759e-02_rb,3.307141e-02_rb,& - & 3.232598e-02_rb,3.160953e-02_rb,3.092040e-02_rb,3.025706e-02_rb,2.961810e-02_rb,& - & 2.900220e-02_rb,2.840814e-02_rb,2.783478e-02_rb,2.728106e-02_rb,2.674599e-02_rb,& - & 2.622864e-02_rb,2.572816e-02_rb,2.5244e-02_rb /) + & 7.937480e-01_rb,5.123036e-01_rb,3.858181e-01_rb,3.099622e-01_rb,2.586829e-01_rb,& + & 2.217587e-01_rb,1.939755e-01_rb,1.723397e-01_rb,1.550258e-01_rb,1.408600e-01_rb,& + & 1.290545e-01_rb,1.190661e-01_rb,1.105039e-01_rb,1.030848e-01_rb,9.659387e-02_rb,& + & 9.086775e-02_rb,8.577807e-02_rb,8.122452e-02_rb,7.712711e-02_rb,7.342193e-02_rb,& + & 7.005387e-02_rb,6.697840e-02_rb,6.416000e-02_rb,6.156903e-02_rb,5.917484e-02_rb,& + & 5.695807e-02_rb,5.489968e-02_rb,5.298097e-02_rb,5.118806e-02_rb,4.950645e-02_rb,& + & 4.792710e-02_rb,4.643581e-02_rb,4.502484e-02_rb,4.368547e-02_rb,4.241001e-02_rb,& + & 4.118936e-02_rb,4.002193e-02_rb,3.889711e-02_rb,3.781322e-02_rb,3.676387e-02_rb,& + & 3.574549e-02_rb,3.475548e-02_rb,3.379033e-02_rb,3.284678e-02_rb,3.192420e-02_rb,& + & 3.102032e-02_rb,3.013484e-02_rb,2.926258e-02_rb,2.840839e-02_rb,2.756742e-02_rb,& + & 2.674258e-02_rb,2.593064e-02_rb,2.513258e-02_rb,2.435000e-02_rb,2.358064e-02_rb,& + & 2.282581e-02_rb,2.208548e-02_rb,2.135936e-02_rb /) +! BAND 22 extliq1(:, 22) = (/ & - & 7.416833e-01_rb,4.959591e-01_rb,3.775057e-01_rb,3.056353e-01_rb,2.565943e-01_rb,& - & 2.206935e-01_rb,1.931479e-01_rb,1.712860e-01_rb,1.534837e-01_rb,1.386906e-01_rb,& - & 1.281198e-01_rb,1.182344e-01_rb,1.097595e-01_rb,1.024137e-01_rb,9.598552e-02_rb,& - & 9.031320e-02_rb,8.527093e-02_rb,8.075927e-02_rb,7.669869e-02_rb,7.302481e-02_rb,& - & 6.968491e-02_rb,6.663542e-02_rb,6.384008e-02_rb,6.126838e-02_rb,5.889452e-02_rb,& - & 5.669654e-02_rb,5.465558e-02_rb,5.275540e-02_rb,5.087937e-02_rb,4.927904e-02_rb,& - & 4.776796e-02_rb,4.633895e-02_rb,4.498557e-02_rb,4.370202e-02_rb,4.248306e-02_rb,& - & 4.132399e-02_rb,4.022052e-02_rb,3.916878e-02_rb,3.816523e-02_rb,3.720665e-02_rb,& - & 3.629011e-02_rb,3.541290e-02_rb,3.457257e-02_rb,3.376685e-02_rb,3.299365e-02_rb,& - & 3.225105e-02_rb,3.153728e-02_rb,3.085069e-02_rb,3.018977e-02_rb,2.955310e-02_rb,& - & 2.893940e-02_rb,2.834742e-02_rb,2.777606e-02_rb,2.722424e-02_rb,2.669099e-02_rb,& - & 2.617539e-02_rb,2.567658e-02_rb,2.5194e-02_rb /) + & 7.533129e-01_rb,5.033129e-01_rb,3.811271e-01_rb,3.062757e-01_rb,2.558729e-01_rb,& + & 2.196828e-01_rb,1.924372e-01_rb,1.711714e-01_rb,1.541086e-01_rb,1.401114e-01_rb,& + & 1.284257e-01_rb,1.185200e-01_rb,1.100243e-01_rb,1.026529e-01_rb,9.620142e-02_rb,& + & 9.050714e-02_rb,8.544428e-02_rb,8.091714e-02_rb,7.684000e-02_rb,7.315429e-02_rb,& + & 6.980143e-02_rb,6.673999e-02_rb,6.394000e-02_rb,6.136000e-02_rb,5.897715e-02_rb,& + & 5.677000e-02_rb,5.472285e-02_rb,5.281286e-02_rb,5.102858e-02_rb,4.935429e-02_rb,& + & 4.778000e-02_rb,4.629714e-02_rb,4.489142e-02_rb,4.355857e-02_rb,4.228715e-02_rb,& + & 4.107285e-02_rb,3.990857e-02_rb,3.879000e-02_rb,3.770999e-02_rb,3.666429e-02_rb,& + & 3.565000e-02_rb,3.466286e-02_rb,3.370143e-02_rb,3.276143e-02_rb,3.184143e-02_rb,& + & 3.094000e-02_rb,3.005714e-02_rb,2.919000e-02_rb,2.833714e-02_rb,2.750000e-02_rb,& + & 2.667714e-02_rb,2.586714e-02_rb,2.507143e-02_rb,2.429143e-02_rb,2.352428e-02_rb,& + & 2.277143e-02_rb,2.203429e-02_rb,2.130857e-02_rb /) +! BAND 23 extliq1(:, 23) = (/ & - & 7.058580e-01_rb,4.866573e-01_rb,3.712238e-01_rb,2.998638e-01_rb,2.513441e-01_rb,& - & 2.161972e-01_rb,1.895576e-01_rb,1.686669e-01_rb,1.518437e-01_rb,1.380046e-01_rb,& - & 1.267564e-01_rb,1.170399e-01_rb,1.087026e-01_rb,1.014704e-01_rb,9.513729e-02_rb,& - & 8.954555e-02_rb,8.457221e-02_rb,8.012009e-02_rb,7.611136e-02_rb,7.248294e-02_rb,& - & 6.918317e-02_rb,6.616934e-02_rb,6.340584e-02_rb,6.086273e-02_rb,5.851465e-02_rb,& - & 5.634001e-02_rb,5.432027e-02_rb,5.243946e-02_rb,5.058070e-02_rb,4.899628e-02_rb,& - & 4.749975e-02_rb,4.608411e-02_rb,4.474303e-02_rb,4.347082e-02_rb,4.226237e-02_rb,& - & 4.111303e-02_rb,4.001861e-02_rb,3.897528e-02_rb,3.797959e-02_rb,3.702835e-02_rb,& - & 3.611867e-02_rb,3.524791e-02_rb,3.441364e-02_rb,3.361360e-02_rb,3.284577e-02_rb,& - & 3.210823e-02_rb,3.139923e-02_rb,3.071716e-02_rb,3.006052e-02_rb,2.942791e-02_rb,& - & 2.881806e-02_rb,2.822974e-02_rb,2.766185e-02_rb,2.711335e-02_rb,2.658326e-02_rb,& - & 2.607066e-02_rb,2.557473e-02_rb,2.5095e-02_rb /) + & 7.079894e-01_rb,4.878198e-01_rb,3.719852e-01_rb,3.001873e-01_rb,2.514795e-01_rb,& + & 2.163013e-01_rb,1.897100e-01_rb,1.689033e-01_rb,1.521793e-01_rb,1.384449e-01_rb,& + & 1.269666e-01_rb,1.172326e-01_rb,1.088745e-01_rb,1.016224e-01_rb,9.527085e-02_rb,& + & 8.966240e-02_rb,8.467543e-02_rb,8.021144e-02_rb,7.619344e-02_rb,7.255676e-02_rb,& + & 6.924996e-02_rb,6.623030e-02_rb,6.346261e-02_rb,6.091499e-02_rb,5.856325e-02_rb,& + & 5.638385e-02_rb,5.435930e-02_rb,5.247156e-02_rb,5.070699e-02_rb,4.905230e-02_rb,& + & 4.749499e-02_rb,4.602611e-02_rb,4.463581e-02_rb,4.331543e-02_rb,4.205647e-02_rb,& + & 4.085241e-02_rb,3.969978e-02_rb,3.859033e-02_rb,3.751877e-02_rb,3.648168e-02_rb,& + & 3.547468e-02_rb,3.449553e-02_rb,3.354072e-02_rb,3.260732e-02_rb,3.169438e-02_rb,& + & 3.079969e-02_rb,2.992146e-02_rb,2.905875e-02_rb,2.821201e-02_rb,2.737873e-02_rb,& + & 2.656052e-02_rb,2.575586e-02_rb,2.496511e-02_rb,2.418783e-02_rb,2.342500e-02_rb,& + & 2.267646e-02_rb,2.194177e-02_rb,2.122146e-02_rb /) +! BAND 24 extliq1(:, 24) = (/ & - & 6.822779e-01_rb,4.750373e-01_rb,3.634834e-01_rb,2.940726e-01_rb,2.468060e-01_rb,& - & 2.125768e-01_rb,1.866586e-01_rb,1.663588e-01_rb,1.500326e-01_rb,1.366192e-01_rb,& - & 1.253472e-01_rb,1.158052e-01_rb,1.076101e-01_rb,1.004954e-01_rb,9.426089e-02_rb,& - & 8.875268e-02_rb,8.385090e-02_rb,7.946063e-02_rb,7.550578e-02_rb,7.192466e-02_rb,& - & 6.866669e-02_rb,6.569001e-02_rb,6.295971e-02_rb,6.044642e-02_rb,5.812526e-02_rb,& - & 5.597500e-02_rb,5.397746e-02_rb,5.211690e-02_rb,5.027505e-02_rb,4.870703e-02_rb,& - & 4.722555e-02_rb,4.582373e-02_rb,4.449540e-02_rb,4.323497e-02_rb,4.203742e-02_rb,& - & 4.089821e-02_rb,3.981321e-02_rb,3.877867e-02_rb,3.779118e-02_rb,3.684762e-02_rb,& - & 3.594514e-02_rb,3.508114e-02_rb,3.425322e-02_rb,3.345917e-02_rb,3.269698e-02_rb,& - & 3.196477e-02_rb,3.126082e-02_rb,3.058352e-02_rb,2.993141e-02_rb,2.930310e-02_rb,& - & 2.869732e-02_rb,2.811289e-02_rb,2.754869e-02_rb,2.700371e-02_rb,2.647698e-02_rb,& - & 2.596760e-02_rb,2.547473e-02_rb,2.4998e-02_rb /) + & 6.850164e-01_rb,4.762468e-01_rb,3.642001e-01_rb,2.946012e-01_rb,2.472001e-01_rb,& + & 2.128588e-01_rb,1.868537e-01_rb,1.664893e-01_rb,1.501142e-01_rb,1.366620e-01_rb,& + & 1.254147e-01_rb,1.158721e-01_rb,1.076732e-01_rb,1.005530e-01_rb,9.431306e-02_rb,& + & 8.879891e-02_rb,8.389232e-02_rb,7.949714e-02_rb,7.553857e-02_rb,7.195474e-02_rb,& + & 6.869413e-02_rb,6.571444e-02_rb,6.298286e-02_rb,6.046779e-02_rb,5.814474e-02_rb,& + & 5.599141e-02_rb,5.399114e-02_rb,5.212443e-02_rb,5.037870e-02_rb,4.874321e-02_rb,& + & 4.720219e-02_rb,4.574813e-02_rb,4.437160e-02_rb,4.306460e-02_rb,4.181810e-02_rb,& + & 4.062603e-02_rb,3.948252e-02_rb,3.838256e-02_rb,3.732049e-02_rb,3.629192e-02_rb,& + & 3.529301e-02_rb,3.432190e-02_rb,3.337412e-02_rb,3.244842e-02_rb,3.154175e-02_rb,& + & 3.065253e-02_rb,2.978063e-02_rb,2.892367e-02_rb,2.808221e-02_rb,2.725478e-02_rb,& + & 2.644174e-02_rb,2.564175e-02_rb,2.485508e-02_rb,2.408303e-02_rb,2.332365e-02_rb,& + & 2.257890e-02_rb,2.184824e-02_rb,2.113224e-02_rb /) +! BAND 25 extliq1(:, 25) = (/ & - & 6.666233e-01_rb,4.662044e-01_rb,3.579517e-01_rb,2.902984e-01_rb,2.440475e-01_rb,& - & 2.104431e-01_rb,1.849277e-01_rb,1.648970e-01_rb,1.487555e-01_rb,1.354714e-01_rb,& - & 1.244173e-01_rb,1.149913e-01_rb,1.068903e-01_rb,9.985323e-02_rb,9.368351e-02_rb,& - & 8.823009e-02_rb,8.337507e-02_rb,7.902511e-02_rb,7.510529e-02_rb,7.155482e-02_rb,& - & 6.832386e-02_rb,6.537113e-02_rb,6.266218e-02_rb,6.016802e-02_rb,5.786408e-02_rb,& - & 5.572939e-02_rb,5.374598e-02_rb,5.189830e-02_rb,5.006825e-02_rb,4.851081e-02_rb,& - & 4.703906e-02_rb,4.564623e-02_rb,4.432621e-02_rb,4.307349e-02_rb,4.188312e-02_rb,& - & 4.075060e-02_rb,3.967183e-02_rb,3.864313e-02_rb,3.766111e-02_rb,3.672269e-02_rb,& - & 3.582505e-02_rb,3.496559e-02_rb,3.414196e-02_rb,3.335198e-02_rb,3.259362e-02_rb,& - & 3.186505e-02_rb,3.116454e-02_rb,3.049052e-02_rb,2.984152e-02_rb,2.921617e-02_rb,& - & 2.861322e-02_rb,2.803148e-02_rb,2.746986e-02_rb,2.692733e-02_rb,2.640295e-02_rb,& - & 2.589582e-02_rb,2.540510e-02_rb,2.4930e-02_rb /) + & 6.673017e-01_rb,4.664520e-01_rb,3.579398e-01_rb,2.902234e-01_rb,2.439904e-01_rb,& + & 2.104149e-01_rb,1.849277e-01_rb,1.649234e-01_rb,1.488087e-01_rb,1.355515e-01_rb,& + & 1.244562e-01_rb,1.150329e-01_rb,1.069321e-01_rb,9.989310e-02_rb,9.372070e-02_rb,& + & 8.826450e-02_rb,8.340622e-02_rb,7.905378e-02_rb,7.513109e-02_rb,7.157859e-02_rb,& + & 6.834588e-02_rb,6.539114e-02_rb,6.268150e-02_rb,6.018621e-02_rb,5.788098e-02_rb,& + & 5.574351e-02_rb,5.375699e-02_rb,5.190412e-02_rb,5.017099e-02_rb,4.854497e-02_rb,& + & 4.701490e-02_rb,4.557030e-02_rb,4.420249e-02_rb,4.290304e-02_rb,4.166427e-02_rb,& + & 4.047820e-02_rb,3.934232e-02_rb,3.824778e-02_rb,3.719236e-02_rb,3.616931e-02_rb,& + & 3.517597e-02_rb,3.420856e-02_rb,3.326566e-02_rb,3.234346e-02_rb,3.144122e-02_rb,& + & 3.055684e-02_rb,2.968798e-02_rb,2.883519e-02_rb,2.799635e-02_rb,2.717228e-02_rb,& + & 2.636182e-02_rb,2.556424e-02_rb,2.478114e-02_rb,2.401086e-02_rb,2.325657e-02_rb,& + & 2.251506e-02_rb,2.178594e-02_rb,2.107301e-02_rb /) +! BAND 26 extliq1(:, 26) = (/ & - & 6.535669e-01_rb,4.585865e-01_rb,3.529226e-01_rb,2.867245e-01_rb,2.413848e-01_rb,& - & 2.083956e-01_rb,1.833191e-01_rb,1.636150e-01_rb,1.477247e-01_rb,1.346392e-01_rb,& - & 1.236449e-01_rb,1.143095e-01_rb,1.062828e-01_rb,9.930773e-02_rb,9.319029e-02_rb,& - & 8.778150e-02_rb,8.296497e-02_rb,7.864847e-02_rb,7.475799e-02_rb,7.123343e-02_rb,& - & 6.802549e-02_rb,6.509332e-02_rb,6.240285e-02_rb,5.992538e-02_rb,5.763657e-02_rb,& - & 5.551566e-02_rb,5.354483e-02_rb,5.170870e-02_rb,4.988866e-02_rb,4.834061e-02_rb,& - & 4.687751e-02_rb,4.549264e-02_rb,4.417999e-02_rb,4.293410e-02_rb,4.175006e-02_rb,& - & 4.062344e-02_rb,3.955019e-02_rb,3.852663e-02_rb,3.754943e-02_rb,3.661553e-02_rb,& - & 3.572214e-02_rb,3.486669e-02_rb,3.404683e-02_rb,3.326040e-02_rb,3.250542e-02_rb,& - & 3.178003e-02_rb,3.108254e-02_rb,3.041139e-02_rb,2.976511e-02_rb,2.914235e-02_rb,& - & 2.854187e-02_rb,2.796247e-02_rb,2.740309e-02_rb,2.686271e-02_rb,2.634038e-02_rb,& - & 2.583520e-02_rb,2.534636e-02_rb,2.4873e-02_rb /) + & 6.552414e-01_rb,4.599454e-01_rb,3.538626e-01_rb,2.873547e-01_rb,2.418033e-01_rb,& + & 2.086660e-01_rb,1.834885e-01_rb,1.637142e-01_rb,1.477767e-01_rb,1.346583e-01_rb,& + & 1.236734e-01_rb,1.143412e-01_rb,1.063148e-01_rb,9.933905e-02_rb,9.322026e-02_rb,& + & 8.780979e-02_rb,8.299230e-02_rb,7.867554e-02_rb,7.478450e-02_rb,7.126053e-02_rb,& + & 6.805276e-02_rb,6.512143e-02_rb,6.243211e-02_rb,5.995541e-02_rb,5.766712e-02_rb,& + & 5.554484e-02_rb,5.357246e-02_rb,5.173222e-02_rb,5.001069e-02_rb,4.839505e-02_rb,& + & 4.687471e-02_rb,4.543861e-02_rb,4.407857e-02_rb,4.278577e-02_rb,4.155331e-02_rb,& + & 4.037322e-02_rb,3.924302e-02_rb,3.815376e-02_rb,3.710172e-02_rb,3.608296e-02_rb,& + & 3.509330e-02_rb,3.412980e-02_rb,3.319009e-02_rb,3.227106e-02_rb,3.137157e-02_rb,& + & 3.048950e-02_rb,2.962365e-02_rb,2.877297e-02_rb,2.793726e-02_rb,2.711500e-02_rb,& + & 2.630666e-02_rb,2.551206e-02_rb,2.473052e-02_rb,2.396287e-02_rb,2.320861e-02_rb,& + & 2.246810e-02_rb,2.174162e-02_rb,2.102927e-02_rb /) +! BAND 27 extliq1(:, 27) = (/ & - & 6.448790e-01_rb,4.541425e-01_rb,3.503348e-01_rb,2.850494e-01_rb,2.401966e-01_rb,& - & 2.074811e-01_rb,1.825631e-01_rb,1.629515e-01_rb,1.471142e-01_rb,1.340574e-01_rb,& - & 1.231462e-01_rb,1.138628e-01_rb,1.058802e-01_rb,9.894286e-02_rb,9.285818e-02_rb,& - & 8.747802e-02_rb,8.268676e-02_rb,7.839271e-02_rb,7.452230e-02_rb,7.101580e-02_rb,& - & 6.782418e-02_rb,6.490685e-02_rb,6.222991e-02_rb,5.976484e-02_rb,5.748742e-02_rb,& - & 5.537703e-02_rb,5.341593e-02_rb,5.158883e-02_rb,4.977355e-02_rb,4.823172e-02_rb,& - & 4.677430e-02_rb,4.539465e-02_rb,4.408680e-02_rb,4.284533e-02_rb,4.166539e-02_rb,& - & 4.054257e-02_rb,3.947283e-02_rb,3.845256e-02_rb,3.747842e-02_rb,3.654737e-02_rb,& - & 3.565665e-02_rb,3.480370e-02_rb,3.398620e-02_rb,3.320198e-02_rb,3.244908e-02_rb,& - & 3.172566e-02_rb,3.103002e-02_rb,3.036062e-02_rb,2.971600e-02_rb,2.909482e-02_rb,& - & 2.849582e-02_rb,2.791785e-02_rb,2.735982e-02_rb,2.682072e-02_rb,2.629960e-02_rb,& - & 2.579559e-02_rb,2.530786e-02_rb,2.4836e-02_rb /) + & 6.430901e-01_rb,4.532134e-01_rb,3.496132e-01_rb,2.844655e-01_rb,2.397347e-01_rb,& + & 2.071236e-01_rb,1.822976e-01_rb,1.627640e-01_rb,1.469961e-01_rb,1.340006e-01_rb,& + & 1.231069e-01_rb,1.138441e-01_rb,1.058706e-01_rb,9.893678e-02_rb,9.285166e-02_rb,& + & 8.746871e-02_rb,8.267411e-02_rb,7.837656e-02_rb,7.450257e-02_rb,7.099318e-02_rb,& + & 6.779929e-02_rb,6.487987e-02_rb,6.220168e-02_rb,5.973530e-02_rb,5.745636e-02_rb,& + & 5.534344e-02_rb,5.337986e-02_rb,5.154797e-02_rb,4.983404e-02_rb,4.822582e-02_rb,& + & 4.671228e-02_rb,4.528321e-02_rb,4.392997e-02_rb,4.264325e-02_rb,4.141647e-02_rb,& + & 4.024259e-02_rb,3.911767e-02_rb,3.803309e-02_rb,3.698782e-02_rb,3.597140e-02_rb,& + & 3.498774e-02_rb,3.402852e-02_rb,3.309340e-02_rb,3.217818e-02_rb,3.128292e-02_rb,& + & 3.040486e-02_rb,2.954230e-02_rb,2.869545e-02_rb,2.786261e-02_rb,2.704372e-02_rb,& + & 2.623813e-02_rb,2.544668e-02_rb,2.466788e-02_rb,2.390313e-02_rb,2.315136e-02_rb,& + & 2.241391e-02_rb,2.168921e-02_rb,2.097903e-02_rb /) +! BAND 28 extliq1(:, 28) = (/ & - & 6.422688e-01_rb,4.528453e-01_rb,3.497232e-01_rb,2.847724e-01_rb,2.400815e-01_rb,& - & 2.074403e-01_rb,1.825502e-01_rb,1.629415e-01_rb,1.470934e-01_rb,1.340183e-01_rb,& - & 1.230935e-01_rb,1.138049e-01_rb,1.058201e-01_rb,9.888245e-02_rb,9.279878e-02_rb,& - & 8.742053e-02_rb,8.263175e-02_rb,7.834058e-02_rb,7.447327e-02_rb,7.097000e-02_rb,& - & 6.778167e-02_rb,6.486765e-02_rb,6.219400e-02_rb,5.973215e-02_rb,5.745790e-02_rb,& - & 5.535059e-02_rb,5.339250e-02_rb,5.156831e-02_rb,4.975308e-02_rb,4.821235e-02_rb,& - & 4.675596e-02_rb,4.537727e-02_rb,4.407030e-02_rb,4.282968e-02_rb,4.165053e-02_rb,& - & 4.052845e-02_rb,3.945941e-02_rb,3.843980e-02_rb,3.746628e-02_rb,3.653583e-02_rb,& - & 3.564567e-02_rb,3.479326e-02_rb,3.397626e-02_rb,3.319253e-02_rb,3.244008e-02_rb,& - & 3.171711e-02_rb,3.102189e-02_rb,3.035289e-02_rb,2.970866e-02_rb,2.908784e-02_rb,& - & 2.848920e-02_rb,2.791156e-02_rb,2.735385e-02_rb,2.681507e-02_rb,2.629425e-02_rb,& - & 2.579053e-02_rb,2.530308e-02_rb,2.4831e-02_rb /) + & 6.367074e-01_rb,4.495768e-01_rb,3.471263e-01_rb,2.826149e-01_rb,2.382868e-01_rb,& + & 2.059640e-01_rb,1.813562e-01_rb,1.619881e-01_rb,1.463436e-01_rb,1.334402e-01_rb,& + & 1.226166e-01_rb,1.134096e-01_rb,1.054829e-01_rb,9.858838e-02_rb,9.253790e-02_rb,& + & 8.718582e-02_rb,8.241830e-02_rb,7.814482e-02_rb,7.429212e-02_rb,7.080165e-02_rb,& + & 6.762385e-02_rb,6.471838e-02_rb,6.205388e-02_rb,5.959726e-02_rb,5.732871e-02_rb,& + & 5.522402e-02_rb,5.326793e-02_rb,5.144230e-02_rb,4.973440e-02_rb,4.813188e-02_rb,& + & 4.662283e-02_rb,4.519798e-02_rb,4.384833e-02_rb,4.256541e-02_rb,4.134253e-02_rb,& + & 4.017136e-02_rb,3.904911e-02_rb,3.796779e-02_rb,3.692364e-02_rb,3.591182e-02_rb,& + & 3.492930e-02_rb,3.397230e-02_rb,3.303920e-02_rb,3.212572e-02_rb,3.123278e-02_rb,& + & 3.035519e-02_rb,2.949493e-02_rb,2.864985e-02_rb,2.781840e-02_rb,2.700197e-02_rb,& + & 2.619682e-02_rb,2.540674e-02_rb,2.462966e-02_rb,2.386613e-02_rb,2.311602e-02_rb,& + & 2.237846e-02_rb,2.165660e-02_rb,2.094756e-02_rb /) +! BAND 29 extliq1(:, 29) = (/ & - & 4.614710e-01_rb,4.556116e-01_rb,4.056568e-01_rb,3.529833e-01_rb,3.060334e-01_rb,& - & 2.658127e-01_rb,2.316095e-01_rb,2.024325e-01_rb,1.773749e-01_rb,1.556867e-01_rb,& - & 1.455558e-01_rb,1.332882e-01_rb,1.229052e-01_rb,1.140067e-01_rb,1.062981e-01_rb,& - & 9.955703e-02_rb,9.361333e-02_rb,8.833420e-02_rb,8.361467e-02_rb,7.937071e-02_rb,& - & 7.553420e-02_rb,7.204942e-02_rb,6.887031e-02_rb,6.595851e-02_rb,6.328178e-02_rb,& - & 6.081286e-02_rb,5.852854e-02_rb,5.640892e-02_rb,5.431269e-02_rb,5.252561e-02_rb,& - & 5.084345e-02_rb,4.925727e-02_rb,4.775910e-02_rb,4.634182e-02_rb,4.499907e-02_rb,& - & 4.372512e-02_rb,4.251484e-02_rb,4.136357e-02_rb,4.026710e-02_rb,3.922162e-02_rb,& - & 3.822365e-02_rb,3.727004e-02_rb,3.635790e-02_rb,3.548457e-02_rb,3.464764e-02_rb,& - & 3.384488e-02_rb,3.307424e-02_rb,3.233384e-02_rb,3.162192e-02_rb,3.093688e-02_rb,& - & 3.027723e-02_rb,2.964158e-02_rb,2.902864e-02_rb,2.843722e-02_rb,2.786621e-02_rb,& - & 2.731457e-02_rb,2.678133e-02_rb,2.6266e-02_rb /) - -! Single scattering albedo + & 4.298416e-01_rb,4.391639e-01_rb,3.975030e-01_rb,3.443028e-01_rb,2.957345e-01_rb,& + & 2.556461e-01_rb,2.234755e-01_rb,1.976636e-01_rb,1.767428e-01_rb,1.595611e-01_rb,& + & 1.452636e-01_rb,1.332156e-01_rb,1.229481e-01_rb,1.141059e-01_rb,1.064208e-01_rb,& + & 9.968527e-02_rb,9.373833e-02_rb,8.845221e-02_rb,8.372112e-02_rb,7.946667e-02_rb,& + & 7.561807e-02_rb,7.212029e-02_rb,6.893166e-02_rb,6.600944e-02_rb,6.332277e-02_rb,& + & 6.084277e-02_rb,5.854721e-02_rb,5.641361e-02_rb,5.442639e-02_rb,5.256750e-02_rb,& + & 5.082499e-02_rb,4.918556e-02_rb,4.763694e-02_rb,4.617222e-02_rb,4.477861e-02_rb,& + & 4.344861e-02_rb,4.217999e-02_rb,4.096111e-02_rb,3.978638e-02_rb,3.865361e-02_rb,& + & 3.755473e-02_rb,3.649028e-02_rb,3.545361e-02_rb,3.444361e-02_rb,3.345666e-02_rb,& + & 3.249167e-02_rb,3.154722e-02_rb,3.062083e-02_rb,2.971250e-02_rb,2.882083e-02_rb,& + & 2.794611e-02_rb,2.708778e-02_rb,2.624500e-02_rb,2.541750e-02_rb,2.460528e-02_rb,& + & 2.381194e-02_rb,2.303250e-02_rb,2.226833e-02_rb /) +! BAND 16 ssaliq1(:, 16) = (/ & - & 8.143821e-01_rb,7.836739e-01_rb,7.550722e-01_rb,7.306269e-01_rb,7.105612e-01_rb,& - & 6.946649e-01_rb,6.825556e-01_rb,6.737762e-01_rb,6.678448e-01_rb,6.642830e-01_rb,& - & 6.679741e-01_rb,6.584607e-01_rb,6.505598e-01_rb,6.440951e-01_rb,6.388901e-01_rb,& - & 6.347689e-01_rb,6.315549e-01_rb,6.290718e-01_rb,6.271432e-01_rb,6.255928e-01_rb,& - & 6.242441e-01_rb,6.229207e-01_rb,6.214464e-01_rb,6.196445e-01_rb,6.173388e-01_rb,& - & 6.143527e-01_rb,6.105099e-01_rb,6.056339e-01_rb,6.108290e-01_rb,6.073939e-01_rb,& - & 6.043073e-01_rb,6.015473e-01_rb,5.990913e-01_rb,5.969173e-01_rb,5.950028e-01_rb,& - & 5.933257e-01_rb,5.918636e-01_rb,5.905944e-01_rb,5.894957e-01_rb,5.885453e-01_rb,& - & 5.877209e-01_rb,5.870003e-01_rb,5.863611e-01_rb,5.857811e-01_rb,5.852381e-01_rb,& - & 5.847098e-01_rb,5.841738e-01_rb,5.836081e-01_rb,5.829901e-01_rb,5.822979e-01_rb,& - & 5.815089e-01_rb,5.806011e-01_rb,5.795521e-01_rb,5.783396e-01_rb,5.769413e-01_rb,& - & 5.753351e-01_rb,5.734986e-01_rb,5.7141e-01_rb /) + & 8.362119e-01_rb,8.098460e-01_rb,7.762291e-01_rb,7.486042e-01_rb,7.294172e-01_rb,& + & 7.161000e-01_rb,7.060656e-01_rb,6.978387e-01_rb,6.907193e-01_rb,6.843551e-01_rb,& + & 6.785668e-01_rb,6.732450e-01_rb,6.683191e-01_rb,6.637264e-01_rb,6.594307e-01_rb,& + & 6.554033e-01_rb,6.516115e-01_rb,6.480295e-01_rb,6.446429e-01_rb,6.414306e-01_rb,& + & 6.383783e-01_rb,6.354750e-01_rb,6.327068e-01_rb,6.300665e-01_rb,6.275376e-01_rb,& + & 6.251245e-01_rb,6.228136e-01_rb,6.205944e-01_rb,6.184720e-01_rb,6.164330e-01_rb,& + & 6.144742e-01_rb,6.125962e-01_rb,6.108004e-01_rb,6.090740e-01_rb,6.074200e-01_rb,& + & 6.058381e-01_rb,6.043209e-01_rb,6.028681e-01_rb,6.014836e-01_rb,6.001626e-01_rb,& + & 5.988957e-01_rb,5.976864e-01_rb,5.965390e-01_rb,5.954379e-01_rb,5.943972e-01_rb,& + & 5.934019e-01_rb,5.924624e-01_rb,5.915579e-01_rb,5.907025e-01_rb,5.898913e-01_rb,& + & 5.891213e-01_rb,5.883815e-01_rb,5.876851e-01_rb,5.870158e-01_rb,5.863868e-01_rb,& + & 5.857821e-01_rb,5.852111e-01_rb,5.846579e-01_rb /) +! BAND 17 ssaliq1(:, 17) = (/ & - & 8.165821e-01_rb,8.002015e-01_rb,7.816921e-01_rb,7.634131e-01_rb,7.463721e-01_rb,& - & 7.312469e-01_rb,7.185883e-01_rb,7.088975e-01_rb,7.026671e-01_rb,7.004020e-01_rb,& - & 7.042138e-01_rb,6.960930e-01_rb,6.894243e-01_rb,6.840459e-01_rb,6.797957e-01_rb,& - & 6.765119e-01_rb,6.740325e-01_rb,6.721955e-01_rb,6.708391e-01_rb,6.698013e-01_rb,& - & 6.689201e-01_rb,6.680339e-01_rb,6.669805e-01_rb,6.655982e-01_rb,6.637250e-01_rb,& - & 6.611992e-01_rb,6.578588e-01_rb,6.535420e-01_rb,6.584449e-01_rb,6.553992e-01_rb,& - & 6.526547e-01_rb,6.501917e-01_rb,6.479905e-01_rb,6.460313e-01_rb,6.442945e-01_rb,& - & 6.427605e-01_rb,6.414094e-01_rb,6.402217e-01_rb,6.391775e-01_rb,6.382573e-01_rb,& - & 6.374413e-01_rb,6.367099e-01_rb,6.360433e-01_rb,6.354218e-01_rb,6.348257e-01_rb,& - & 6.342355e-01_rb,6.336313e-01_rb,6.329935e-01_rb,6.323023e-01_rb,6.315383e-01_rb,& - & 6.306814e-01_rb,6.297122e-01_rb,6.286110e-01_rb,6.273579e-01_rb,6.259333e-01_rb,& - & 6.243176e-01_rb,6.224910e-01_rb,6.2043e-01_rb /) + & 6.995459e-01_rb,7.158012e-01_rb,7.076001e-01_rb,6.927244e-01_rb,6.786434e-01_rb,& + & 6.673545e-01_rb,6.585859e-01_rb,6.516314e-01_rb,6.459010e-01_rb,6.410225e-01_rb,& + & 6.367574e-01_rb,6.329554e-01_rb,6.295119e-01_rb,6.263595e-01_rb,6.234462e-01_rb,& + & 6.207274e-01_rb,6.181755e-01_rb,6.157678e-01_rb,6.134880e-01_rb,6.113173e-01_rb,& + & 6.092495e-01_rb,6.072689e-01_rb,6.053717e-01_rb,6.035507e-01_rb,6.018001e-01_rb,& + & 6.001134e-01_rb,5.984951e-01_rb,5.969294e-01_rb,5.954256e-01_rb,5.939698e-01_rb,& + & 5.925716e-01_rb,5.912265e-01_rb,5.899270e-01_rb,5.886771e-01_rb,5.874746e-01_rb,& + & 5.863185e-01_rb,5.852077e-01_rb,5.841460e-01_rb,5.831249e-01_rb,5.821474e-01_rb,& + & 5.812078e-01_rb,5.803173e-01_rb,5.794616e-01_rb,5.786443e-01_rb,5.778617e-01_rb,& + & 5.771236e-01_rb,5.764191e-01_rb,5.757400e-01_rb,5.750971e-01_rb,5.744842e-01_rb,& + & 5.739012e-01_rb,5.733482e-01_rb,5.728175e-01_rb,5.723214e-01_rb,5.718383e-01_rb,& + & 5.713827e-01_rb,5.709471e-01_rb,5.705330e-01_rb /) +! BAND 18 ssaliq1(:, 18) = (/ & - & 9.900163e-01_rb,9.854307e-01_rb,9.797730e-01_rb,9.733113e-01_rb,9.664245e-01_rb,& - & 9.594976e-01_rb,9.529055e-01_rb,9.470112e-01_rb,9.421695e-01_rb,9.387304e-01_rb,& - & 9.344918e-01_rb,9.305302e-01_rb,9.267048e-01_rb,9.230072e-01_rb,9.194289e-01_rb,& - & 9.159616e-01_rb,9.125968e-01_rb,9.093260e-01_rb,9.061409e-01_rb,9.030330e-01_rb,& - & 8.999940e-01_rb,8.970154e-01_rb,8.940888e-01_rb,8.912058e-01_rb,8.883579e-01_rb,& - & 8.855368e-01_rb,8.827341e-01_rb,8.799413e-01_rb,8.777423e-01_rb,8.749566e-01_rb,& - & 8.722298e-01_rb,8.695605e-01_rb,8.669469e-01_rb,8.643875e-01_rb,8.618806e-01_rb,& - & 8.594246e-01_rb,8.570179e-01_rb,8.546589e-01_rb,8.523459e-01_rb,8.500773e-01_rb,& - & 8.478516e-01_rb,8.456670e-01_rb,8.435219e-01_rb,8.414148e-01_rb,8.393439e-01_rb,& - & 8.373078e-01_rb,8.353047e-01_rb,8.333330e-01_rb,8.313911e-01_rb,8.294774e-01_rb,& - & 8.275904e-01_rb,8.257282e-01_rb,8.238893e-01_rb,8.220721e-01_rb,8.202751e-01_rb,& - & 8.184965e-01_rb,8.167346e-01_rb,8.1499e-01_rb /) + & 9.929711e-01_rb,9.896942e-01_rb,9.852408e-01_rb,9.806820e-01_rb,9.764512e-01_rb,& + & 9.725375e-01_rb,9.688677e-01_rb,9.653832e-01_rb,9.620552e-01_rb,9.588522e-01_rb,& + & 9.557475e-01_rb,9.527265e-01_rb,9.497731e-01_rb,9.468756e-01_rb,9.440270e-01_rb,& + & 9.412230e-01_rb,9.384592e-01_rb,9.357287e-01_rb,9.330369e-01_rb,9.303778e-01_rb,& + & 9.277502e-01_rb,9.251546e-01_rb,9.225907e-01_rb,9.200553e-01_rb,9.175521e-01_rb,& + & 9.150773e-01_rb,9.126352e-01_rb,9.102260e-01_rb,9.078485e-01_rb,9.055057e-01_rb,& + & 9.031978e-01_rb,9.009306e-01_rb,8.987010e-01_rb,8.965177e-01_rb,8.943774e-01_rb,& + & 8.922869e-01_rb,8.902430e-01_rb,8.882551e-01_rb,8.863182e-01_rb,8.844373e-01_rb,& + & 8.826143e-01_rb,8.808499e-01_rb,8.791413e-01_rb,8.774940e-01_rb,8.759019e-01_rb,& + & 8.743650e-01_rb,8.728941e-01_rb,8.714712e-01_rb,8.701065e-01_rb,8.688008e-01_rb,& + & 8.675409e-01_rb,8.663295e-01_rb,8.651714e-01_rb,8.640637e-01_rb,8.629943e-01_rb,& + & 8.619762e-01_rb,8.609995e-01_rb,8.600581e-01_rb /) +! BAND 19 ssaliq1(:, 19) = (/ & - & 9.999916e-01_rb,9.987396e-01_rb,9.966900e-01_rb,9.950738e-01_rb,9.937531e-01_rb,& - & 9.925912e-01_rb,9.914525e-01_rb,9.902018e-01_rb,9.887046e-01_rb,9.868263e-01_rb,& - & 9.849039e-01_rb,9.832372e-01_rb,9.815265e-01_rb,9.797770e-01_rb,9.779940e-01_rb,& - & 9.761827e-01_rb,9.743481e-01_rb,9.724955e-01_rb,9.706303e-01_rb,9.687575e-01_rb,& - & 9.668823e-01_rb,9.650100e-01_rb,9.631457e-01_rb,9.612947e-01_rb,9.594622e-01_rb,& - & 9.576534e-01_rb,9.558734e-01_rb,9.541275e-01_rb,9.522059e-01_rb,9.504258e-01_rb,& - & 9.486459e-01_rb,9.468676e-01_rb,9.450921e-01_rb,9.433208e-01_rb,9.415548e-01_rb,& - & 9.397955e-01_rb,9.380441e-01_rb,9.363022e-01_rb,9.345706e-01_rb,9.328510e-01_rb,& - & 9.311445e-01_rb,9.294524e-01_rb,9.277761e-01_rb,9.261167e-01_rb,9.244755e-01_rb,& - & 9.228540e-01_rb,9.212534e-01_rb,9.196748e-01_rb,9.181197e-01_rb,9.165894e-01_rb,& - & 9.150851e-01_rb,9.136080e-01_rb,9.121596e-01_rb,9.107410e-01_rb,9.093536e-01_rb,& - & 9.079987e-01_rb,9.066775e-01_rb,9.0539e-01_rb /) + & 9.910612e-01_rb,9.854226e-01_rb,9.795008e-01_rb,9.742920e-01_rb,9.695996e-01_rb,& + & 9.652274e-01_rb,9.610648e-01_rb,9.570521e-01_rb,9.531397e-01_rb,9.493086e-01_rb,& + & 9.455413e-01_rb,9.418362e-01_rb,9.381902e-01_rb,9.346016e-01_rb,9.310718e-01_rb,& + & 9.275957e-01_rb,9.241757e-01_rb,9.208038e-01_rb,9.174802e-01_rb,9.142058e-01_rb,& + & 9.109753e-01_rb,9.077895e-01_rb,9.046433e-01_rb,9.015409e-01_rb,8.984784e-01_rb,& + & 8.954572e-01_rb,8.924748e-01_rb,8.895367e-01_rb,8.866395e-01_rb,8.837864e-01_rb,& + & 8.809819e-01_rb,8.782267e-01_rb,8.755231e-01_rb,8.728712e-01_rb,8.702802e-01_rb,& + & 8.677443e-01_rb,8.652733e-01_rb,8.628678e-01_rb,8.605300e-01_rb,8.582593e-01_rb,& + & 8.560596e-01_rb,8.539352e-01_rb,8.518782e-01_rb,8.498915e-01_rb,8.479790e-01_rb,& + & 8.461384e-01_rb,8.443645e-01_rb,8.426613e-01_rb,8.410229e-01_rb,8.394495e-01_rb,& + & 8.379428e-01_rb,8.364967e-01_rb,8.351117e-01_rb,8.337820e-01_rb,8.325091e-01_rb,& + & 8.312874e-01_rb,8.301169e-01_rb,8.289985e-01_rb /) +! BAND 20 ssaliq1(:, 20) = (/ & - & 9.979493e-01_rb,9.964113e-01_rb,9.950014e-01_rb,9.937045e-01_rb,9.924964e-01_rb,& - & 9.913546e-01_rb,9.902575e-01_rb,9.891843e-01_rb,9.881136e-01_rb,9.870238e-01_rb,& - & 9.859934e-01_rb,9.849372e-01_rb,9.838873e-01_rb,9.828434e-01_rb,9.818052e-01_rb,& - & 9.807725e-01_rb,9.797450e-01_rb,9.787225e-01_rb,9.777047e-01_rb,9.766914e-01_rb,& - & 9.756823e-01_rb,9.746771e-01_rb,9.736756e-01_rb,9.726775e-01_rb,9.716827e-01_rb,& - & 9.706907e-01_rb,9.697014e-01_rb,9.687145e-01_rb,9.678060e-01_rb,9.668108e-01_rb,& - & 9.658218e-01_rb,9.648391e-01_rb,9.638629e-01_rb,9.628936e-01_rb,9.619313e-01_rb,& - & 9.609763e-01_rb,9.600287e-01_rb,9.590888e-01_rb,9.581569e-01_rb,9.572330e-01_rb,& - & 9.563176e-01_rb,9.554108e-01_rb,9.545128e-01_rb,9.536239e-01_rb,9.527443e-01_rb,& - & 9.518741e-01_rb,9.510137e-01_rb,9.501633e-01_rb,9.493230e-01_rb,9.484931e-01_rb,& - & 9.476740e-01_rb,9.468656e-01_rb,9.460683e-01_rb,9.452824e-01_rb,9.445080e-01_rb,& - & 9.437454e-01_rb,9.429948e-01_rb,9.4226e-01_rb /) + & 9.969802e-01_rb,9.950445e-01_rb,9.931448e-01_rb,9.914272e-01_rb,9.898652e-01_rb,& + & 9.884250e-01_rb,9.870637e-01_rb,9.857482e-01_rb,9.844558e-01_rb,9.831755e-01_rb,& + & 9.819068e-01_rb,9.806477e-01_rb,9.794000e-01_rb,9.781666e-01_rb,9.769461e-01_rb,& + & 9.757386e-01_rb,9.745459e-01_rb,9.733650e-01_rb,9.721953e-01_rb,9.710398e-01_rb,& + & 9.698936e-01_rb,9.687583e-01_rb,9.676334e-01_rb,9.665192e-01_rb,9.654132e-01_rb,& + & 9.643208e-01_rb,9.632374e-01_rb,9.621625e-01_rb,9.611003e-01_rb,9.600518e-01_rb,& + & 9.590144e-01_rb,9.579922e-01_rb,9.569864e-01_rb,9.559948e-01_rb,9.550239e-01_rb,& + & 9.540698e-01_rb,9.531382e-01_rb,9.522280e-01_rb,9.513409e-01_rb,9.504772e-01_rb,& + & 9.496360e-01_rb,9.488220e-01_rb,9.480327e-01_rb,9.472693e-01_rb,9.465333e-01_rb,& + & 9.458211e-01_rb,9.451344e-01_rb,9.444732e-01_rb,9.438372e-01_rb,9.432268e-01_rb,& + & 9.426391e-01_rb,9.420757e-01_rb,9.415308e-01_rb,9.410102e-01_rb,9.405115e-01_rb,& + & 9.400326e-01_rb,9.395716e-01_rb,9.391313e-01_rb /) +! BAND 21 ssaliq1(:, 21) = (/ & - & 9.988742e-01_rb,9.982668e-01_rb,9.976935e-01_rb,9.971497e-01_rb,9.966314e-01_rb,& - & 9.961344e-01_rb,9.956545e-01_rb,9.951873e-01_rb,9.947286e-01_rb,9.942741e-01_rb,& - & 9.938457e-01_rb,9.933947e-01_rb,9.929473e-01_rb,9.925032e-01_rb,9.920621e-01_rb,& - & 9.916237e-01_rb,9.911875e-01_rb,9.907534e-01_rb,9.903209e-01_rb,9.898898e-01_rb,& - & 9.894597e-01_rb,9.890304e-01_rb,9.886015e-01_rb,9.881726e-01_rb,9.877435e-01_rb,& - & 9.873138e-01_rb,9.868833e-01_rb,9.864516e-01_rb,9.860698e-01_rb,9.856317e-01_rb,& - & 9.851957e-01_rb,9.847618e-01_rb,9.843302e-01_rb,9.839008e-01_rb,9.834739e-01_rb,& - & 9.830494e-01_rb,9.826275e-01_rb,9.822083e-01_rb,9.817918e-01_rb,9.813782e-01_rb,& - & 9.809675e-01_rb,9.805598e-01_rb,9.801552e-01_rb,9.797538e-01_rb,9.793556e-01_rb,& - & 9.789608e-01_rb,9.785695e-01_rb,9.781817e-01_rb,9.777975e-01_rb,9.774171e-01_rb,& - & 9.770404e-01_rb,9.766676e-01_rb,9.762988e-01_rb,9.759340e-01_rb,9.755733e-01_rb,& - & 9.752169e-01_rb,9.748649e-01_rb,9.7452e-01_rb /) + & 9.980034e-01_rb,9.968572e-01_rb,9.958696e-01_rb,9.949747e-01_rb,9.941241e-01_rb,& + & 9.933043e-01_rb,9.924971e-01_rb,9.916978e-01_rb,9.909023e-01_rb,9.901046e-01_rb,& + & 9.893087e-01_rb,9.885146e-01_rb,9.877195e-01_rb,9.869283e-01_rb,9.861379e-01_rb,& + & 9.853523e-01_rb,9.845715e-01_rb,9.837945e-01_rb,9.830217e-01_rb,9.822567e-01_rb,& + & 9.814935e-01_rb,9.807356e-01_rb,9.799815e-01_rb,9.792332e-01_rb,9.784845e-01_rb,& + & 9.777424e-01_rb,9.770042e-01_rb,9.762695e-01_rb,9.755416e-01_rb,9.748152e-01_rb,& + & 9.740974e-01_rb,9.733873e-01_rb,9.726813e-01_rb,9.719861e-01_rb,9.713010e-01_rb,& + & 9.706262e-01_rb,9.699647e-01_rb,9.693144e-01_rb,9.686794e-01_rb,9.680596e-01_rb,& + & 9.674540e-01_rb,9.668657e-01_rb,9.662926e-01_rb,9.657390e-01_rb,9.652019e-01_rb,& + & 9.646820e-01_rb,9.641784e-01_rb,9.636945e-01_rb,9.632260e-01_rb,9.627743e-01_rb,& + & 9.623418e-01_rb,9.619227e-01_rb,9.615194e-01_rb,9.611341e-01_rb,9.607629e-01_rb,& + & 9.604057e-01_rb,9.600622e-01_rb,9.597322e-01_rb /) +! BAND 22 ssaliq1(:, 22) = (/ & - & 9.994441e-01_rb,9.991608e-01_rb,9.988949e-01_rb,9.986439e-01_rb,9.984054e-01_rb,& - & 9.981768e-01_rb,9.979557e-01_rb,9.977396e-01_rb,9.975258e-01_rb,9.973120e-01_rb,& - & 9.971011e-01_rb,9.968852e-01_rb,9.966708e-01_rb,9.964578e-01_rb,9.962462e-01_rb,& - & 9.960357e-01_rb,9.958264e-01_rb,9.956181e-01_rb,9.954108e-01_rb,9.952043e-01_rb,& - & 9.949987e-01_rb,9.947937e-01_rb,9.945892e-01_rb,9.943853e-01_rb,9.941818e-01_rb,& - & 9.939786e-01_rb,9.937757e-01_rb,9.935728e-01_rb,9.933922e-01_rb,9.931825e-01_rb,& - & 9.929739e-01_rb,9.927661e-01_rb,9.925592e-01_rb,9.923534e-01_rb,9.921485e-01_rb,& - & 9.919447e-01_rb,9.917421e-01_rb,9.915406e-01_rb,9.913403e-01_rb,9.911412e-01_rb,& - & 9.909435e-01_rb,9.907470e-01_rb,9.905519e-01_rb,9.903581e-01_rb,9.901659e-01_rb,& - & 9.899751e-01_rb,9.897858e-01_rb,9.895981e-01_rb,9.894120e-01_rb,9.892276e-01_rb,& - & 9.890447e-01_rb,9.888637e-01_rb,9.886845e-01_rb,9.885070e-01_rb,9.883314e-01_rb,& - & 9.881576e-01_rb,9.879859e-01_rb,9.8782e-01_rb /) + & 9.988219e-01_rb,9.981767e-01_rb,9.976168e-01_rb,9.971066e-01_rb,9.966195e-01_rb,& + & 9.961566e-01_rb,9.956995e-01_rb,9.952481e-01_rb,9.947982e-01_rb,9.943495e-01_rb,& + & 9.938955e-01_rb,9.934368e-01_rb,9.929825e-01_rb,9.925239e-01_rb,9.920653e-01_rb,& + & 9.916096e-01_rb,9.911552e-01_rb,9.907067e-01_rb,9.902594e-01_rb,9.898178e-01_rb,& + & 9.893791e-01_rb,9.889453e-01_rb,9.885122e-01_rb,9.880837e-01_rb,9.876567e-01_rb,& + & 9.872331e-01_rb,9.868121e-01_rb,9.863938e-01_rb,9.859790e-01_rb,9.855650e-01_rb,& + & 9.851548e-01_rb,9.847491e-01_rb,9.843496e-01_rb,9.839521e-01_rb,9.835606e-01_rb,& + & 9.831771e-01_rb,9.827975e-01_rb,9.824292e-01_rb,9.820653e-01_rb,9.817124e-01_rb,& + & 9.813644e-01_rb,9.810291e-01_rb,9.807020e-01_rb,9.803864e-01_rb,9.800782e-01_rb,& + & 9.797821e-01_rb,9.794958e-01_rb,9.792179e-01_rb,9.789509e-01_rb,9.786940e-01_rb,& + & 9.784460e-01_rb,9.782090e-01_rb,9.779789e-01_rb,9.777553e-01_rb,9.775425e-01_rb,& + & 9.773387e-01_rb,9.771420e-01_rb,9.769529e-01_rb /) +! BAND 23 ssaliq1(:, 23) = (/ & - & 9.999138e-01_rb,9.998730e-01_rb,9.998338e-01_rb,9.997965e-01_rb,9.997609e-01_rb,& - & 9.997270e-01_rb,9.996944e-01_rb,9.996629e-01_rb,9.996321e-01_rb,9.996016e-01_rb,& - & 9.995690e-01_rb,9.995372e-01_rb,9.995057e-01_rb,9.994744e-01_rb,9.994433e-01_rb,& - & 9.994124e-01_rb,9.993817e-01_rb,9.993510e-01_rb,9.993206e-01_rb,9.992903e-01_rb,& - & 9.992600e-01_rb,9.992299e-01_rb,9.991998e-01_rb,9.991698e-01_rb,9.991398e-01_rb,& - & 9.991098e-01_rb,9.990799e-01_rb,9.990499e-01_rb,9.990231e-01_rb,9.989920e-01_rb,& - & 9.989611e-01_rb,9.989302e-01_rb,9.988996e-01_rb,9.988690e-01_rb,9.988386e-01_rb,& - & 9.988084e-01_rb,9.987783e-01_rb,9.987485e-01_rb,9.987187e-01_rb,9.986891e-01_rb,& - & 9.986598e-01_rb,9.986306e-01_rb,9.986017e-01_rb,9.985729e-01_rb,9.985443e-01_rb,& - & 9.985160e-01_rb,9.984879e-01_rb,9.984600e-01_rb,9.984324e-01_rb,9.984050e-01_rb,& - & 9.983778e-01_rb,9.983509e-01_rb,9.983243e-01_rb,9.982980e-01_rb,9.982719e-01_rb,& - & 9.982461e-01_rb,9.982206e-01_rb,9.9820e-01_rb /) + & 9.998902e-01_rb,9.998395e-01_rb,9.997915e-01_rb,9.997442e-01_rb,9.997016e-01_rb,& + & 9.996600e-01_rb,9.996200e-01_rb,9.995806e-01_rb,9.995411e-01_rb,9.995005e-01_rb,& + & 9.994589e-01_rb,9.994178e-01_rb,9.993766e-01_rb,9.993359e-01_rb,9.992948e-01_rb,& + & 9.992533e-01_rb,9.992120e-01_rb,9.991723e-01_rb,9.991313e-01_rb,9.990906e-01_rb,& + & 9.990510e-01_rb,9.990113e-01_rb,9.989716e-01_rb,9.989323e-01_rb,9.988923e-01_rb,& + & 9.988532e-01_rb,9.988140e-01_rb,9.987761e-01_rb,9.987373e-01_rb,9.986989e-01_rb,& + & 9.986597e-01_rb,9.986239e-01_rb,9.985861e-01_rb,9.985485e-01_rb,9.985123e-01_rb,& + & 9.984762e-01_rb,9.984415e-01_rb,9.984065e-01_rb,9.983722e-01_rb,9.983398e-01_rb,& + & 9.983078e-01_rb,9.982758e-01_rb,9.982461e-01_rb,9.982157e-01_rb,9.981872e-01_rb,& + & 9.981595e-01_rb,9.981324e-01_rb,9.981068e-01_rb,9.980811e-01_rb,9.980580e-01_rb,& + & 9.980344e-01_rb,9.980111e-01_rb,9.979908e-01_rb,9.979690e-01_rb,9.979492e-01_rb,& + & 9.979316e-01_rb,9.979116e-01_rb,9.978948e-01_rb /) +! BAND 24 ssaliq1(:, 24) = (/ & - & 9.999985e-01_rb,9.999979e-01_rb,9.999972e-01_rb,9.999966e-01_rb,9.999961e-01_rb,& - & 9.999955e-01_rb,9.999950e-01_rb,9.999944e-01_rb,9.999938e-01_rb,9.999933e-01_rb,& - & 9.999927e-01_rb,9.999921e-01_rb,9.999915e-01_rb,9.999910e-01_rb,9.999904e-01_rb,& - & 9.999899e-01_rb,9.999893e-01_rb,9.999888e-01_rb,9.999882e-01_rb,9.999877e-01_rb,& - & 9.999871e-01_rb,9.999866e-01_rb,9.999861e-01_rb,9.999855e-01_rb,9.999850e-01_rb,& - & 9.999844e-01_rb,9.999839e-01_rb,9.999833e-01_rb,9.999828e-01_rb,9.999823e-01_rb,& - & 9.999817e-01_rb,9.999812e-01_rb,9.999807e-01_rb,9.999801e-01_rb,9.999796e-01_rb,& - & 9.999791e-01_rb,9.999786e-01_rb,9.999781e-01_rb,9.999776e-01_rb,9.999770e-01_rb,& - & 9.999765e-01_rb,9.999761e-01_rb,9.999756e-01_rb,9.999751e-01_rb,9.999746e-01_rb,& - & 9.999741e-01_rb,9.999736e-01_rb,9.999732e-01_rb,9.999727e-01_rb,9.999722e-01_rb,& - & 9.999718e-01_rb,9.999713e-01_rb,9.999709e-01_rb,9.999705e-01_rb,9.999701e-01_rb,& - & 9.999697e-01_rb,9.999692e-01_rb,9.9997e-01_rb /) + & 9.999978e-01_rb,9.999948e-01_rb,9.999915e-01_rb,9.999905e-01_rb,9.999896e-01_rb,& + & 9.999887e-01_rb,9.999888e-01_rb,9.999888e-01_rb,9.999870e-01_rb,9.999854e-01_rb,& + & 9.999855e-01_rb,9.999856e-01_rb,9.999839e-01_rb,9.999834e-01_rb,9.999829e-01_rb,& + & 9.999809e-01_rb,9.999816e-01_rb,9.999793e-01_rb,9.999782e-01_rb,9.999779e-01_rb,& + & 9.999772e-01_rb,9.999764e-01_rb,9.999756e-01_rb,9.999744e-01_rb,9.999744e-01_rb,& + & 9.999736e-01_rb,9.999729e-01_rb,9.999716e-01_rb,9.999706e-01_rb,9.999692e-01_rb,& + & 9.999690e-01_rb,9.999675e-01_rb,9.999673e-01_rb,9.999660e-01_rb,9.999654e-01_rb,& + & 9.999647e-01_rb,9.999647e-01_rb,9.999625e-01_rb,9.999620e-01_rb,9.999614e-01_rb,& + & 9.999613e-01_rb,9.999607e-01_rb,9.999604e-01_rb,9.999594e-01_rb,9.999589e-01_rb,& + & 9.999586e-01_rb,9.999567e-01_rb,9.999550e-01_rb,9.999557e-01_rb,9.999542e-01_rb,& + & 9.999546e-01_rb,9.999539e-01_rb,9.999536e-01_rb,9.999526e-01_rb,9.999523e-01_rb,& + & 9.999508e-01_rb,9.999534e-01_rb,9.999507e-01_rb /) +! BAND 25 ssaliq1(:, 25) = (/ & - & 9.999999e-01_rb,9.999998e-01_rb,9.999997e-01_rb,9.999997e-01_rb,9.999997e-01_rb,& - & 9.999996e-01_rb,9.999996e-01_rb,9.999995e-01_rb,9.999995e-01_rb,9.999994e-01_rb,& - & 9.999994e-01_rb,9.999993e-01_rb,9.999993e-01_rb,9.999992e-01_rb,9.999992e-01_rb,& - & 9.999991e-01_rb,9.999991e-01_rb,9.999991e-01_rb,9.999990e-01_rb,9.999989e-01_rb,& - & 9.999989e-01_rb,9.999989e-01_rb,9.999988e-01_rb,9.999988e-01_rb,9.999987e-01_rb,& - & 9.999987e-01_rb,9.999986e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999985e-01_rb,& - & 9.999984e-01_rb,9.999984e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999983e-01_rb,& - & 9.999982e-01_rb,9.999982e-01_rb,9.999982e-01_rb,9.999981e-01_rb,9.999980e-01_rb,& - & 9.999980e-01_rb,9.999980e-01_rb,9.999979e-01_rb,9.999979e-01_rb,9.999978e-01_rb,& - & 9.999978e-01_rb,9.999977e-01_rb,9.999977e-01_rb,9.999977e-01_rb,9.999976e-01_rb,& - & 9.999976e-01_rb,9.999975e-01_rb,9.999975e-01_rb,9.999974e-01_rb,9.999974e-01_rb,& - & 9.999974e-01_rb,9.999973e-01_rb,1.0000e+00_rb /) + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,9.999995e-01_rb,& + & 9.999995e-01_rb,9.999990e-01_rb,9.999991e-01_rb,9.999991e-01_rb,9.999990e-01_rb,& + & 9.999989e-01_rb,9.999988e-01_rb,9.999988e-01_rb,9.999986e-01_rb,9.999988e-01_rb,& + & 9.999986e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999985e-01_rb,& + & 9.999985e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999983e-01_rb,9.999981e-01_rb,& + & 9.999981e-01_rb,9.999986e-01_rb,9.999985e-01_rb,9.999983e-01_rb,9.999984e-01_rb,& + & 9.999982e-01_rb,9.999983e-01_rb,9.999982e-01_rb,9.999980e-01_rb,9.999981e-01_rb,& + & 9.999978e-01_rb,9.999979e-01_rb,9.999985e-01_rb,9.999985e-01_rb,9.999983e-01_rb,& + & 9.999983e-01_rb,9.999983e-01_rb,9.999983e-01_rb /) +! BAND 26 ssaliq1(:, 26) = (/ & - & 9.999997e-01_rb,9.999995e-01_rb,9.999993e-01_rb,9.999992e-01_rb,9.999990e-01_rb,& - & 9.999989e-01_rb,9.999988e-01_rb,9.999987e-01_rb,9.999986e-01_rb,9.999985e-01_rb,& - & 9.999984e-01_rb,9.999983e-01_rb,9.999982e-01_rb,9.999981e-01_rb,9.999980e-01_rb,& - & 9.999978e-01_rb,9.999977e-01_rb,9.999976e-01_rb,9.999975e-01_rb,9.999974e-01_rb,& - & 9.999973e-01_rb,9.999972e-01_rb,9.999970e-01_rb,9.999969e-01_rb,9.999968e-01_rb,& - & 9.999967e-01_rb,9.999966e-01_rb,9.999965e-01_rb,9.999964e-01_rb,9.999963e-01_rb,& - & 9.999962e-01_rb,9.999961e-01_rb,9.999959e-01_rb,9.999958e-01_rb,9.999957e-01_rb,& - & 9.999956e-01_rb,9.999955e-01_rb,9.999954e-01_rb,9.999953e-01_rb,9.999952e-01_rb,& - & 9.999951e-01_rb,9.999949e-01_rb,9.999949e-01_rb,9.999947e-01_rb,9.999946e-01_rb,& - & 9.999945e-01_rb,9.999944e-01_rb,9.999943e-01_rb,9.999942e-01_rb,9.999941e-01_rb,& - & 9.999940e-01_rb,9.999939e-01_rb,9.999938e-01_rb,9.999937e-01_rb,9.999936e-01_rb,& - & 9.999935e-01_rb,9.999934e-01_rb,9.9999e-01_rb /) + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,& + & 1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,1.000000e+00_rb,9.999991e-01_rb,& + & 9.999990e-01_rb,9.999992e-01_rb,9.999995e-01_rb,9.999986e-01_rb,9.999994e-01_rb,& + & 9.999985e-01_rb,9.999980e-01_rb,9.999984e-01_rb,9.999983e-01_rb,9.999979e-01_rb,& + & 9.999969e-01_rb,9.999977e-01_rb,9.999971e-01_rb,9.999969e-01_rb,9.999969e-01_rb,& + & 9.999965e-01_rb,9.999970e-01_rb,9.999985e-01_rb,9.999973e-01_rb,9.999961e-01_rb,& + & 9.999968e-01_rb,9.999952e-01_rb,9.999970e-01_rb,9.999974e-01_rb,9.999965e-01_rb,& + & 9.999969e-01_rb,9.999970e-01_rb,9.999970e-01_rb,9.999960e-01_rb,9.999923e-01_rb,& + & 9.999958e-01_rb,9.999937e-01_rb,9.999960e-01_rb,9.999953e-01_rb,9.999946e-01_rb,& + & 9.999946e-01_rb,9.999957e-01_rb,9.999951e-01_rb /) +! BAND 27 ssaliq1(:, 27) = (/ & - & 9.999984e-01_rb,9.999976e-01_rb,9.999969e-01_rb,9.999962e-01_rb,9.999956e-01_rb,& - & 9.999950e-01_rb,9.999945e-01_rb,9.999940e-01_rb,9.999935e-01_rb,9.999931e-01_rb,& - & 9.999926e-01_rb,9.999920e-01_rb,9.999914e-01_rb,9.999908e-01_rb,9.999903e-01_rb,& - & 9.999897e-01_rb,9.999891e-01_rb,9.999886e-01_rb,9.999880e-01_rb,9.999874e-01_rb,& - & 9.999868e-01_rb,9.999863e-01_rb,9.999857e-01_rb,9.999851e-01_rb,9.999846e-01_rb,& - & 9.999840e-01_rb,9.999835e-01_rb,9.999829e-01_rb,9.999824e-01_rb,9.999818e-01_rb,& - & 9.999812e-01_rb,9.999806e-01_rb,9.999800e-01_rb,9.999795e-01_rb,9.999789e-01_rb,& - & 9.999783e-01_rb,9.999778e-01_rb,9.999773e-01_rb,9.999767e-01_rb,9.999761e-01_rb,& - & 9.999756e-01_rb,9.999750e-01_rb,9.999745e-01_rb,9.999739e-01_rb,9.999734e-01_rb,& - & 9.999729e-01_rb,9.999723e-01_rb,9.999718e-01_rb,9.999713e-01_rb,9.999708e-01_rb,& - & 9.999703e-01_rb,9.999697e-01_rb,9.999692e-01_rb,9.999687e-01_rb,9.999683e-01_rb,& - & 9.999678e-01_rb,9.999673e-01_rb,9.9997e-01_rb /) + & 1.000000e+00_rb,1.000000e+00_rb,9.999983e-01_rb,9.999979e-01_rb,9.999965e-01_rb,& + & 9.999949e-01_rb,9.999948e-01_rb,9.999918e-01_rb,9.999917e-01_rb,9.999923e-01_rb,& + & 9.999908e-01_rb,9.999889e-01_rb,9.999902e-01_rb,9.999895e-01_rb,9.999881e-01_rb,& + & 9.999882e-01_rb,9.999876e-01_rb,9.999866e-01_rb,9.999866e-01_rb,9.999858e-01_rb,& + & 9.999860e-01_rb,9.999852e-01_rb,9.999836e-01_rb,9.999831e-01_rb,9.999818e-01_rb,& + & 9.999808e-01_rb,9.999816e-01_rb,9.999800e-01_rb,9.999783e-01_rb,9.999780e-01_rb,& + & 9.999763e-01_rb,9.999746e-01_rb,9.999731e-01_rb,9.999713e-01_rb,9.999762e-01_rb,& + & 9.999740e-01_rb,9.999670e-01_rb,9.999703e-01_rb,9.999687e-01_rb,9.999666e-01_rb,& + & 9.999683e-01_rb,9.999667e-01_rb,9.999611e-01_rb,9.999635e-01_rb,9.999600e-01_rb,& + & 9.999635e-01_rb,9.999594e-01_rb,9.999601e-01_rb,9.999586e-01_rb,9.999559e-01_rb,& + & 9.999569e-01_rb,9.999558e-01_rb,9.999523e-01_rb,9.999535e-01_rb,9.999529e-01_rb,& + & 9.999553e-01_rb,9.999495e-01_rb,9.999490e-01_rb /) +! BAND 28 ssaliq1(:, 28) = (/ & - & 9.999981e-01_rb,9.999973e-01_rb,9.999965e-01_rb,9.999958e-01_rb,9.999951e-01_rb,& - & 9.999943e-01_rb,9.999937e-01_rb,9.999930e-01_rb,9.999924e-01_rb,9.999918e-01_rb,& - & 9.999912e-01_rb,9.999905e-01_rb,9.999897e-01_rb,9.999890e-01_rb,9.999883e-01_rb,& - & 9.999876e-01_rb,9.999869e-01_rb,9.999862e-01_rb,9.999855e-01_rb,9.999847e-01_rb,& - & 9.999840e-01_rb,9.999834e-01_rb,9.999827e-01_rb,9.999819e-01_rb,9.999812e-01_rb,& - & 9.999805e-01_rb,9.999799e-01_rb,9.999791e-01_rb,9.999785e-01_rb,9.999778e-01_rb,& - & 9.999771e-01_rb,9.999764e-01_rb,9.999757e-01_rb,9.999750e-01_rb,9.999743e-01_rb,& - & 9.999736e-01_rb,9.999729e-01_rb,9.999722e-01_rb,9.999715e-01_rb,9.999709e-01_rb,& - & 9.999701e-01_rb,9.999695e-01_rb,9.999688e-01_rb,9.999682e-01_rb,9.999675e-01_rb,& - & 9.999669e-01_rb,9.999662e-01_rb,9.999655e-01_rb,9.999649e-01_rb,9.999642e-01_rb,& - & 9.999636e-01_rb,9.999630e-01_rb,9.999624e-01_rb,9.999618e-01_rb,9.999612e-01_rb,& - & 9.999606e-01_rb,9.999600e-01_rb,9.9996e-01_rb /) + & 9.999920e-01_rb,9.999873e-01_rb,9.999855e-01_rb,9.999832e-01_rb,9.999807e-01_rb,& + & 9.999778e-01_rb,9.999754e-01_rb,9.999721e-01_rb,9.999692e-01_rb,9.999651e-01_rb,& + & 9.999621e-01_rb,9.999607e-01_rb,9.999567e-01_rb,9.999546e-01_rb,9.999521e-01_rb,& + & 9.999491e-01_rb,9.999457e-01_rb,9.999439e-01_rb,9.999403e-01_rb,9.999374e-01_rb,& + & 9.999353e-01_rb,9.999315e-01_rb,9.999282e-01_rb,9.999244e-01_rb,9.999234e-01_rb,& + & 9.999189e-01_rb,9.999130e-01_rb,9.999117e-01_rb,9.999073e-01_rb,9.999020e-01_rb,& + & 9.998993e-01_rb,9.998987e-01_rb,9.998922e-01_rb,9.998893e-01_rb,9.998869e-01_rb,& + & 9.998805e-01_rb,9.998778e-01_rb,9.998751e-01_rb,9.998708e-01_rb,9.998676e-01_rb,& + & 9.998624e-01_rb,9.998642e-01_rb,9.998582e-01_rb,9.998547e-01_rb,9.998546e-01_rb,& + & 9.998477e-01_rb,9.998487e-01_rb,9.998466e-01_rb,9.998403e-01_rb,9.998412e-01_rb,& + & 9.998406e-01_rb,9.998342e-01_rb,9.998326e-01_rb,9.998333e-01_rb,9.998328e-01_rb,& + & 9.998290e-01_rb,9.998276e-01_rb,9.998249e-01_rb /) +! BAND 29 ssaliq1(:, 29) = (/ & - & 8.505737e-01_rb,8.465102e-01_rb,8.394829e-01_rb,8.279508e-01_rb,8.110806e-01_rb,& - & 7.900397e-01_rb,7.669615e-01_rb,7.444422e-01_rb,7.253055e-01_rb,7.124831e-01_rb,& - & 7.016434e-01_rb,6.885485e-01_rb,6.767340e-01_rb,6.661029e-01_rb,6.565577e-01_rb,& - & 6.480013e-01_rb,6.403373e-01_rb,6.334697e-01_rb,6.273034e-01_rb,6.217440e-01_rb,& - & 6.166983e-01_rb,6.120740e-01_rb,6.077796e-01_rb,6.037249e-01_rb,5.998207e-01_rb,& - & 5.959788e-01_rb,5.921123e-01_rb,5.881354e-01_rb,5.891285e-01_rb,5.851143e-01_rb,& - & 5.814653e-01_rb,5.781606e-01_rb,5.751792e-01_rb,5.724998e-01_rb,5.701016e-01_rb,& - & 5.679634e-01_rb,5.660642e-01_rb,5.643829e-01_rb,5.628984e-01_rb,5.615898e-01_rb,& - & 5.604359e-01_rb,5.594158e-01_rb,5.585083e-01_rb,5.576924e-01_rb,5.569470e-01_rb,& - & 5.562512e-01_rb,5.555838e-01_rb,5.549239e-01_rb,5.542503e-01_rb,5.535420e-01_rb,& - & 5.527781e-01_rb,5.519374e-01_rb,5.509989e-01_rb,5.499417e-01_rb,5.487445e-01_rb,& - & 5.473865e-01_rb,5.458466e-01_rb,5.4410e-01_rb /) - -! asymmetry parameter + & 8.383753e-01_rb,8.461471e-01_rb,8.373325e-01_rb,8.212889e-01_rb,8.023834e-01_rb,& + & 7.829501e-01_rb,7.641777e-01_rb,7.466000e-01_rb,7.304023e-01_rb,7.155998e-01_rb,& + & 7.021259e-01_rb,6.898840e-01_rb,6.787615e-01_rb,6.686479e-01_rb,6.594414e-01_rb,& + & 6.510417e-01_rb,6.433668e-01_rb,6.363335e-01_rb,6.298788e-01_rb,6.239398e-01_rb,& + & 6.184633e-01_rb,6.134055e-01_rb,6.087228e-01_rb,6.043786e-01_rb,6.003439e-01_rb,& + & 5.965910e-01_rb,5.930917e-01_rb,5.898280e-01_rb,5.867798e-01_rb,5.839264e-01_rb,& + & 5.812576e-01_rb,5.787592e-01_rb,5.764163e-01_rb,5.742189e-01_rb,5.721598e-01_rb,& + & 5.702286e-01_rb,5.684182e-01_rb,5.667176e-01_rb,5.651237e-01_rb,5.636253e-01_rb,& + & 5.622228e-01_rb,5.609074e-01_rb,5.596713e-01_rb,5.585089e-01_rb,5.574223e-01_rb,& + & 5.564002e-01_rb,5.554411e-01_rb,5.545397e-01_rb,5.536914e-01_rb,5.528967e-01_rb,& + & 5.521495e-01_rb,5.514457e-01_rb,5.507818e-01_rb,5.501623e-01_rb,5.495750e-01_rb,& + & 5.490192e-01_rb,5.484980e-01_rb,5.480046e-01_rb /) +! BAND 16 asyliq1(:, 16) = (/ & - & 8.133297e-01_rb,8.133528e-01_rb,8.173865e-01_rb,8.243205e-01_rb,8.333063e-01_rb,& - & 8.436317e-01_rb,8.546611e-01_rb,8.657934e-01_rb,8.764345e-01_rb,8.859837e-01_rb,& - & 8.627394e-01_rb,8.824569e-01_rb,8.976887e-01_rb,9.089541e-01_rb,9.167699e-01_rb,& - & 9.216517e-01_rb,9.241147e-01_rb,9.246743e-01_rb,9.238469e-01_rb,9.221504e-01_rb,& - & 9.201045e-01_rb,9.182299e-01_rb,9.170491e-01_rb,9.170862e-01_rb,9.188653e-01_rb,& - & 9.229111e-01_rb,9.297468e-01_rb,9.398950e-01_rb,9.203269e-01_rb,9.260693e-01_rb,& - & 9.309373e-01_rb,9.349918e-01_rb,9.382935e-01_rb,9.409030e-01_rb,9.428809e-01_rb,& - & 9.442881e-01_rb,9.451851e-01_rb,9.456331e-01_rb,9.456926e-01_rb,9.454247e-01_rb,& - & 9.448902e-01_rb,9.441503e-01_rb,9.432661e-01_rb,9.422987e-01_rb,9.413094e-01_rb,& - & 9.403594e-01_rb,9.395102e-01_rb,9.388230e-01_rb,9.383594e-01_rb,9.381810e-01_rb,& - & 9.383489e-01_rb,9.389251e-01_rb,9.399707e-01_rb,9.415475e-01_rb,9.437167e-01_rb,& - & 9.465399e-01_rb,9.500786e-01_rb,9.5439e-01_rb /) + & 8.038165e-01_rb,8.014154e-01_rb,7.942381e-01_rb,7.970521e-01_rb,8.086621e-01_rb,& + & 8.233392e-01_rb,8.374127e-01_rb,8.495742e-01_rb,8.596945e-01_rb,8.680497e-01_rb,& + & 8.750005e-01_rb,8.808589e-01_rb,8.858749e-01_rb,8.902403e-01_rb,8.940939e-01_rb,& + & 8.975379e-01_rb,9.006450e-01_rb,9.034741e-01_rb,9.060659e-01_rb,9.084561e-01_rb,& + & 9.106675e-01_rb,9.127198e-01_rb,9.146332e-01_rb,9.164194e-01_rb,9.180970e-01_rb,& + & 9.196658e-01_rb,9.211421e-01_rb,9.225352e-01_rb,9.238443e-01_rb,9.250841e-01_rb,& + & 9.262541e-01_rb,9.273620e-01_rb,9.284081e-01_rb,9.294002e-01_rb,9.303395e-01_rb,& + & 9.312285e-01_rb,9.320715e-01_rb,9.328716e-01_rb,9.336271e-01_rb,9.343427e-01_rb,& + & 9.350219e-01_rb,9.356647e-01_rb,9.362728e-01_rb,9.368495e-01_rb,9.373956e-01_rb,& + & 9.379113e-01_rb,9.383987e-01_rb,9.388608e-01_rb,9.392986e-01_rb,9.397132e-01_rb,& + & 9.401063e-01_rb,9.404776e-01_rb,9.408299e-01_rb,9.411641e-01_rb,9.414800e-01_rb,& + & 9.417787e-01_rb,9.420633e-01_rb,9.423364e-01_rb /) +! BAND 17 asyliq1(:, 17) = (/ & - & 8.794448e-01_rb,8.819306e-01_rb,8.837667e-01_rb,8.853832e-01_rb,8.871010e-01_rb,& - & 8.892675e-01_rb,8.922584e-01_rb,8.964666e-01_rb,9.022940e-01_rb,9.101456e-01_rb,& - & 8.839999e-01_rb,9.035610e-01_rb,9.184568e-01_rb,9.292315e-01_rb,9.364282e-01_rb,& - & 9.405887e-01_rb,9.422554e-01_rb,9.419703e-01_rb,9.402759e-01_rb,9.377159e-01_rb,& - & 9.348345e-01_rb,9.321769e-01_rb,9.302888e-01_rb,9.297166e-01_rb,9.310075e-01_rb,& - & 9.347080e-01_rb,9.413643e-01_rb,9.515216e-01_rb,9.306286e-01_rb,9.361781e-01_rb,& - & 9.408374e-01_rb,9.446692e-01_rb,9.477363e-01_rb,9.501013e-01_rb,9.518268e-01_rb,& - & 9.529756e-01_rb,9.536105e-01_rb,9.537938e-01_rb,9.535886e-01_rb,9.530574e-01_rb,& - & 9.522633e-01_rb,9.512688e-01_rb,9.501370e-01_rb,9.489306e-01_rb,9.477126e-01_rb,& - & 9.465459e-01_rb,9.454934e-01_rb,9.446183e-01_rb,9.439833e-01_rb,9.436519e-01_rb,& - & 9.436866e-01_rb,9.441508e-01_rb,9.451073e-01_rb,9.466195e-01_rb,9.487501e-01_rb,& - & 9.515621e-01_rb,9.551185e-01_rb,9.5948e-01_rb /) + & 8.941000e-01_rb,9.054049e-01_rb,9.049510e-01_rb,9.027216e-01_rb,9.021636e-01_rb,& + & 9.037878e-01_rb,9.069852e-01_rb,9.109817e-01_rb,9.152013e-01_rb,9.193040e-01_rb,& + & 9.231177e-01_rb,9.265712e-01_rb,9.296606e-01_rb,9.324048e-01_rb,9.348419e-01_rb,& + & 9.370131e-01_rb,9.389529e-01_rb,9.406954e-01_rb,9.422727e-01_rb,9.437088e-01_rb,& + & 9.450221e-01_rb,9.462308e-01_rb,9.473488e-01_rb,9.483830e-01_rb,9.493492e-01_rb,& + & 9.502541e-01_rb,9.510999e-01_rb,9.518971e-01_rb,9.526455e-01_rb,9.533554e-01_rb,& + & 9.540249e-01_rb,9.546571e-01_rb,9.552551e-01_rb,9.558258e-01_rb,9.563603e-01_rb,& + & 9.568713e-01_rb,9.573569e-01_rb,9.578141e-01_rb,9.582485e-01_rb,9.586604e-01_rb,& + & 9.590525e-01_rb,9.594218e-01_rb,9.597710e-01_rb,9.601052e-01_rb,9.604181e-01_rb,& + & 9.607159e-01_rb,9.609979e-01_rb,9.612655e-01_rb,9.615184e-01_rb,9.617564e-01_rb,& + & 9.619860e-01_rb,9.622009e-01_rb,9.624031e-01_rb,9.625957e-01_rb,9.627792e-01_rb,& + & 9.629530e-01_rb,9.631171e-01_rb,9.632746e-01_rb /) +! BAND 18 asyliq1(:, 18) = (/ & - & 8.478817e-01_rb,8.269312e-01_rb,8.161352e-01_rb,8.135960e-01_rb,8.173586e-01_rb,& - & 8.254167e-01_rb,8.357072e-01_rb,8.461167e-01_rb,8.544952e-01_rb,8.586776e-01_rb,& - & 8.335562e-01_rb,8.524273e-01_rb,8.669052e-01_rb,8.775014e-01_rb,8.847277e-01_rb,& - & 8.890958e-01_rb,8.911173e-01_rb,8.913038e-01_rb,8.901669e-01_rb,8.882182e-01_rb,& - & 8.859692e-01_rb,8.839315e-01_rb,8.826164e-01_rb,8.825356e-01_rb,8.842004e-01_rb,& - & 8.881223e-01_rb,8.948131e-01_rb,9.047837e-01_rb,8.855951e-01_rb,8.911796e-01_rb,& - & 8.959229e-01_rb,8.998837e-01_rb,9.031209e-01_rb,9.056939e-01_rb,9.076609e-01_rb,& - & 9.090812e-01_rb,9.100134e-01_rb,9.105167e-01_rb,9.106496e-01_rb,9.104712e-01_rb,& - & 9.100404e-01_rb,9.094159e-01_rb,9.086568e-01_rb,9.078218e-01_rb,9.069697e-01_rb,& - & 9.061595e-01_rb,9.054499e-01_rb,9.048999e-01_rb,9.045683e-01_rb,9.045142e-01_rb,& - & 9.047962e-01_rb,9.054730e-01_rb,9.066037e-01_rb,9.082472e-01_rb,9.104623e-01_rb,& - & 9.133079e-01_rb,9.168427e-01_rb,9.2113e-01_rb /) + & 8.574638e-01_rb,8.351383e-01_rb,8.142977e-01_rb,8.083068e-01_rb,8.129284e-01_rb,& + & 8.215827e-01_rb,8.307238e-01_rb,8.389963e-01_rb,8.460481e-01_rb,8.519273e-01_rb,& + & 8.568153e-01_rb,8.609116e-01_rb,8.643892e-01_rb,8.673941e-01_rb,8.700248e-01_rb,& + & 8.723707e-01_rb,8.744902e-01_rb,8.764240e-01_rb,8.782057e-01_rb,8.798593e-01_rb,& + & 8.814063e-01_rb,8.828573e-01_rb,8.842261e-01_rb,8.855196e-01_rb,8.867497e-01_rb,& + & 8.879164e-01_rb,8.890316e-01_rb,8.900941e-01_rb,8.911118e-01_rb,8.920832e-01_rb,& + & 8.930156e-01_rb,8.939091e-01_rb,8.947663e-01_rb,8.955888e-01_rb,8.963786e-01_rb,& + & 8.971350e-01_rb,8.978617e-01_rb,8.985590e-01_rb,8.992243e-01_rb,8.998631e-01_rb,& + & 9.004753e-01_rb,9.010602e-01_rb,9.016192e-01_rb,9.021542e-01_rb,9.026644e-01_rb,& + & 9.031535e-01_rb,9.036194e-01_rb,9.040656e-01_rb,9.044894e-01_rb,9.048933e-01_rb,& + & 9.052789e-01_rb,9.056481e-01_rb,9.060004e-01_rb,9.063343e-01_rb,9.066544e-01_rb,& + & 9.069604e-01_rb,9.072512e-01_rb,9.075290e-01_rb /) +! BAND 19 asyliq1(:, 19) = (/ & - & 8.216697e-01_rb,7.982871e-01_rb,7.891147e-01_rb,7.909083e-01_rb,8.003833e-01_rb,& - & 8.142516e-01_rb,8.292290e-01_rb,8.420356e-01_rb,8.493945e-01_rb,8.480316e-01_rb,& - & 8.212381e-01_rb,8.394984e-01_rb,8.534095e-01_rb,8.634813e-01_rb,8.702242e-01_rb,& - & 8.741483e-01_rb,8.757638e-01_rb,8.755808e-01_rb,8.741095e-01_rb,8.718604e-01_rb,& - & 8.693433e-01_rb,8.670686e-01_rb,8.655464e-01_rb,8.652872e-01_rb,8.668006e-01_rb,& - & 8.705973e-01_rb,8.771874e-01_rb,8.870809e-01_rb,8.678284e-01_rb,8.732315e-01_rb,& - & 8.778084e-01_rb,8.816166e-01_rb,8.847146e-01_rb,8.871603e-01_rb,8.890116e-01_rb,& - & 8.903266e-01_rb,8.911632e-01_rb,8.915796e-01_rb,8.916337e-01_rb,8.913834e-01_rb,& - & 8.908869e-01_rb,8.902022e-01_rb,8.893873e-01_rb,8.885001e-01_rb,8.875986e-01_rb,& - & 8.867411e-01_rb,8.859852e-01_rb,8.853891e-01_rb,8.850111e-01_rb,8.849089e-01_rb,& - & 8.851405e-01_rb,8.857639e-01_rb,8.868372e-01_rb,8.884185e-01_rb,8.905656e-01_rb,& - & 8.933368e-01_rb,8.967899e-01_rb,9.0098e-01_rb /) + & 8.349569e-01_rb,8.034579e-01_rb,7.932136e-01_rb,8.010156e-01_rb,8.137083e-01_rb,& + & 8.255339e-01_rb,8.351938e-01_rb,8.428286e-01_rb,8.488944e-01_rb,8.538187e-01_rb,& + & 8.579255e-01_rb,8.614473e-01_rb,8.645338e-01_rb,8.672908e-01_rb,8.697947e-01_rb,& + & 8.720843e-01_rb,8.742015e-01_rb,8.761718e-01_rb,8.780160e-01_rb,8.797479e-01_rb,& + & 8.813810e-01_rb,8.829250e-01_rb,8.843907e-01_rb,8.857822e-01_rb,8.871059e-01_rb,& + & 8.883724e-01_rb,8.895810e-01_rb,8.907384e-01_rb,8.918456e-01_rb,8.929083e-01_rb,& + & 8.939284e-01_rb,8.949060e-01_rb,8.958463e-01_rb,8.967486e-01_rb,8.976129e-01_rb,& + & 8.984463e-01_rb,8.992439e-01_rb,9.000094e-01_rb,9.007438e-01_rb,9.014496e-01_rb,& + & 9.021235e-01_rb,9.027699e-01_rb,9.033859e-01_rb,9.039772e-01_rb,9.045419e-01_rb,& + & 9.050819e-01_rb,9.055975e-01_rb,9.060907e-01_rb,9.065607e-01_rb,9.070093e-01_rb,& + & 9.074389e-01_rb,9.078475e-01_rb,9.082388e-01_rb,9.086117e-01_rb,9.089678e-01_rb,& + & 9.093081e-01_rb,9.096307e-01_rb,9.099410e-01_rb /) +! BAND 20 asyliq1(:, 20) = (/ & - & 8.063610e-01_rb,7.938147e-01_rb,7.921304e-01_rb,7.985092e-01_rb,8.101339e-01_rb,& - & 8.242175e-01_rb,8.379913e-01_rb,8.486920e-01_rb,8.535547e-01_rb,8.498083e-01_rb,& - & 8.224849e-01_rb,8.405509e-01_rb,8.542436e-01_rb,8.640770e-01_rb,8.705653e-01_rb,& - & 8.742227e-01_rb,8.755630e-01_rb,8.751004e-01_rb,8.733491e-01_rb,8.708231e-01_rb,& - & 8.680365e-01_rb,8.655035e-01_rb,8.637381e-01_rb,8.632544e-01_rb,8.645665e-01_rb,& - & 8.681885e-01_rb,8.746346e-01_rb,8.844188e-01_rb,8.648180e-01_rb,8.700563e-01_rb,& - & 8.744672e-01_rb,8.781087e-01_rb,8.810393e-01_rb,8.833174e-01_rb,8.850011e-01_rb,& - & 8.861485e-01_rb,8.868183e-01_rb,8.870687e-01_rb,8.869579e-01_rb,8.865441e-01_rb,& - & 8.858857e-01_rb,8.850412e-01_rb,8.840686e-01_rb,8.830263e-01_rb,8.819726e-01_rb,& - & 8.809658e-01_rb,8.800642e-01_rb,8.793260e-01_rb,8.788099e-01_rb,8.785737e-01_rb,& - & 8.786758e-01_rb,8.791746e-01_rb,8.801283e-01_rb,8.815955e-01_rb,8.836340e-01_rb,& - & 8.863024e-01_rb,8.896592e-01_rb,8.9376e-01_rb /) + & 8.109692e-01_rb,7.846657e-01_rb,7.881928e-01_rb,8.009509e-01_rb,8.131208e-01_rb,& + & 8.230400e-01_rb,8.309448e-01_rb,8.372920e-01_rb,8.424837e-01_rb,8.468166e-01_rb,& + & 8.504947e-01_rb,8.536642e-01_rb,8.564256e-01_rb,8.588513e-01_rb,8.610011e-01_rb,& + & 8.629122e-01_rb,8.646262e-01_rb,8.661720e-01_rb,8.675752e-01_rb,8.688582e-01_rb,& + & 8.700379e-01_rb,8.711300e-01_rb,8.721485e-01_rb,8.731027e-01_rb,8.740010e-01_rb,& + & 8.748499e-01_rb,8.756564e-01_rb,8.764239e-01_rb,8.771542e-01_rb,8.778523e-01_rb,& + & 8.785211e-01_rb,8.791601e-01_rb,8.797725e-01_rb,8.803589e-01_rb,8.809173e-01_rb,& + & 8.814552e-01_rb,8.819705e-01_rb,8.824611e-01_rb,8.829311e-01_rb,8.833791e-01_rb,& + & 8.838078e-01_rb,8.842148e-01_rb,8.846044e-01_rb,8.849756e-01_rb,8.853291e-01_rb,& + & 8.856645e-01_rb,8.859841e-01_rb,8.862904e-01_rb,8.865801e-01_rb,8.868551e-01_rb,& + & 8.871182e-01_rb,8.873673e-01_rb,8.876059e-01_rb,8.878307e-01_rb,8.880462e-01_rb,& + & 8.882501e-01_rb,8.884453e-01_rb,8.886339e-01_rb /) +! BAND 21 asyliq1(:, 21) = (/ & - & 7.885899e-01_rb,7.937172e-01_rb,8.020658e-01_rb,8.123971e-01_rb,8.235502e-01_rb,& - & 8.343776e-01_rb,8.437336e-01_rb,8.504711e-01_rb,8.534421e-01_rb,8.514978e-01_rb,& - & 8.238888e-01_rb,8.417463e-01_rb,8.552057e-01_rb,8.647853e-01_rb,8.710038e-01_rb,& - & 8.743798e-01_rb,8.754319e-01_rb,8.746786e-01_rb,8.726386e-01_rb,8.698303e-01_rb,& - & 8.667724e-01_rb,8.639836e-01_rb,8.619823e-01_rb,8.612870e-01_rb,8.624165e-01_rb,& - & 8.658893e-01_rb,8.722241e-01_rb,8.819394e-01_rb,8.620216e-01_rb,8.671239e-01_rb,& - & 8.713983e-01_rb,8.749032e-01_rb,8.776970e-01_rb,8.798385e-01_rb,8.813860e-01_rb,& - & 8.823980e-01_rb,8.829332e-01_rb,8.830500e-01_rb,8.828068e-01_rb,8.822623e-01_rb,& - & 8.814750e-01_rb,8.805031e-01_rb,8.794056e-01_rb,8.782407e-01_rb,8.770672e-01_rb,& - & 8.759432e-01_rb,8.749275e-01_rb,8.740784e-01_rb,8.734547e-01_rb,8.731146e-01_rb,& - & 8.731170e-01_rb,8.735199e-01_rb,8.743823e-01_rb,8.757625e-01_rb,8.777191e-01_rb,& - & 8.803105e-01_rb,8.835953e-01_rb,8.8763e-01_rb /) + & 7.838510e-01_rb,7.803151e-01_rb,7.980477e-01_rb,8.144160e-01_rb,8.261784e-01_rb,& + & 8.344240e-01_rb,8.404278e-01_rb,8.450391e-01_rb,8.487593e-01_rb,8.518741e-01_rb,& + & 8.545484e-01_rb,8.568890e-01_rb,8.589560e-01_rb,8.607983e-01_rb,8.624504e-01_rb,& + & 8.639408e-01_rb,8.652945e-01_rb,8.665301e-01_rb,8.676634e-01_rb,8.687121e-01_rb,& + & 8.696855e-01_rb,8.705933e-01_rb,8.714448e-01_rb,8.722454e-01_rb,8.730014e-01_rb,& + & 8.737180e-01_rb,8.743982e-01_rb,8.750436e-01_rb,8.756598e-01_rb,8.762481e-01_rb,& + & 8.768089e-01_rb,8.773427e-01_rb,8.778532e-01_rb,8.783434e-01_rb,8.788089e-01_rb,& + & 8.792530e-01_rb,8.796784e-01_rb,8.800845e-01_rb,8.804716e-01_rb,8.808411e-01_rb,& + & 8.811923e-01_rb,8.815276e-01_rb,8.818472e-01_rb,8.821504e-01_rb,8.824408e-01_rb,& + & 8.827155e-01_rb,8.829777e-01_rb,8.832269e-01_rb,8.834631e-01_rb,8.836892e-01_rb,& + & 8.839034e-01_rb,8.841075e-01_rb,8.843021e-01_rb,8.844866e-01_rb,8.846631e-01_rb,& + & 8.848304e-01_rb,8.849910e-01_rb,8.851425e-01_rb /) +! BAND 22 asyliq1(:, 22) = (/ & - & 7.811516e-01_rb,7.962229e-01_rb,8.096199e-01_rb,8.212996e-01_rb,8.312212e-01_rb,& - & 8.393430e-01_rb,8.456236e-01_rb,8.500214e-01_rb,8.524950e-01_rb,8.530031e-01_rb,& - & 8.251485e-01_rb,8.429043e-01_rb,8.562461e-01_rb,8.656954e-01_rb,8.717737e-01_rb,& - & 8.750020e-01_rb,8.759022e-01_rb,8.749953e-01_rb,8.728027e-01_rb,8.698461e-01_rb,& - & 8.666466e-01_rb,8.637257e-01_rb,8.616047e-01_rb,8.608051e-01_rb,8.618483e-01_rb,& - & 8.652557e-01_rb,8.715487e-01_rb,8.812485e-01_rb,8.611645e-01_rb,8.662052e-01_rb,& - & 8.704173e-01_rb,8.738594e-01_rb,8.765901e-01_rb,8.786678e-01_rb,8.801517e-01_rb,& - & 8.810999e-01_rb,8.815713e-01_rb,8.816246e-01_rb,8.813185e-01_rb,8.807114e-01_rb,& - & 8.798621e-01_rb,8.788290e-01_rb,8.776713e-01_rb,8.764470e-01_rb,8.752152e-01_rb,& - & 8.740343e-01_rb,8.729631e-01_rb,8.720602e-01_rb,8.713842e-01_rb,8.709936e-01_rb,& - & 8.709475e-01_rb,8.713041e-01_rb,8.721221e-01_rb,8.734602e-01_rb,8.753774e-01_rb,& - & 8.779319e-01_rb,8.811825e-01_rb,8.8519e-01_rb /) + & 7.760783e-01_rb,7.890215e-01_rb,8.090192e-01_rb,8.230252e-01_rb,8.321369e-01_rb,& + & 8.384258e-01_rb,8.431529e-01_rb,8.469558e-01_rb,8.501499e-01_rb,8.528899e-01_rb,& + & 8.552899e-01_rb,8.573956e-01_rb,8.592570e-01_rb,8.609098e-01_rb,8.623897e-01_rb,& + & 8.637169e-01_rb,8.649184e-01_rb,8.660097e-01_rb,8.670096e-01_rb,8.679338e-01_rb,& + & 8.687896e-01_rb,8.695880e-01_rb,8.703365e-01_rb,8.710422e-01_rb,8.717092e-01_rb,& + & 8.723378e-01_rb,8.729363e-01_rb,8.735063e-01_rb,8.740475e-01_rb,8.745661e-01_rb,& + & 8.750560e-01_rb,8.755275e-01_rb,8.759731e-01_rb,8.764000e-01_rb,8.768071e-01_rb,& + & 8.771942e-01_rb,8.775628e-01_rb,8.779126e-01_rb,8.782483e-01_rb,8.785626e-01_rb,& + & 8.788610e-01_rb,8.791482e-01_rb,8.794180e-01_rb,8.796765e-01_rb,8.799207e-01_rb,& + & 8.801522e-01_rb,8.803707e-01_rb,8.805777e-01_rb,8.807749e-01_rb,8.809605e-01_rb,& + & 8.811362e-01_rb,8.813047e-01_rb,8.814647e-01_rb,8.816131e-01_rb,8.817588e-01_rb,& + & 8.818930e-01_rb,8.820230e-01_rb,8.821445e-01_rb /) +! BAND 23 asyliq1(:, 23) = (/ & - & 7.865744e-01_rb,8.093340e-01_rb,8.257596e-01_rb,8.369940e-01_rb,8.441574e-01_rb,& - & 8.483602e-01_rb,8.507096e-01_rb,8.523139e-01_rb,8.542834e-01_rb,8.577321e-01_rb,& - & 8.288960e-01_rb,8.465308e-01_rb,8.597175e-01_rb,8.689830e-01_rb,8.748542e-01_rb,& - & 8.778584e-01_rb,8.785222e-01_rb,8.773728e-01_rb,8.749370e-01_rb,8.717419e-01_rb,& - & 8.683145e-01_rb,8.651816e-01_rb,8.628704e-01_rb,8.619077e-01_rb,8.628205e-01_rb,& - & 8.661356e-01_rb,8.723803e-01_rb,8.820815e-01_rb,8.616715e-01_rb,8.666389e-01_rb,& - & 8.707753e-01_rb,8.741398e-01_rb,8.767912e-01_rb,8.787885e-01_rb,8.801908e-01_rb,& - & 8.810570e-01_rb,8.814460e-01_rb,8.814167e-01_rb,8.810283e-01_rb,8.803395e-01_rb,& - & 8.794095e-01_rb,8.782971e-01_rb,8.770613e-01_rb,8.757610e-01_rb,8.744553e-01_rb,& - & 8.732031e-01_rb,8.720634e-01_rb,8.710951e-01_rb,8.703572e-01_rb,8.699086e-01_rb,& - & 8.698084e-01_rb,8.701155e-01_rb,8.708887e-01_rb,8.721872e-01_rb,8.740698e-01_rb,& - & 8.765957e-01_rb,8.798235e-01_rb,8.8381e-01_rb /) + & 7.847907e-01_rb,8.099917e-01_rb,8.257428e-01_rb,8.350423e-01_rb,8.411971e-01_rb,& + & 8.457241e-01_rb,8.493010e-01_rb,8.522565e-01_rb,8.547660e-01_rb,8.569311e-01_rb,& + & 8.588181e-01_rb,8.604729e-01_rb,8.619296e-01_rb,8.632208e-01_rb,8.643725e-01_rb,& + & 8.654050e-01_rb,8.663363e-01_rb,8.671835e-01_rb,8.679590e-01_rb,8.686707e-01_rb,& + & 8.693308e-01_rb,8.699433e-01_rb,8.705147e-01_rb,8.710490e-01_rb,8.715497e-01_rb,& + & 8.720219e-01_rb,8.724669e-01_rb,8.728849e-01_rb,8.732806e-01_rb,8.736550e-01_rb,& + & 8.740099e-01_rb,8.743435e-01_rb,8.746601e-01_rb,8.749610e-01_rb,8.752449e-01_rb,& + & 8.755143e-01_rb,8.757688e-01_rb,8.760095e-01_rb,8.762375e-01_rb,8.764532e-01_rb,& + & 8.766579e-01_rb,8.768506e-01_rb,8.770323e-01_rb,8.772049e-01_rb,8.773690e-01_rb,& + & 8.775226e-01_rb,8.776679e-01_rb,8.778062e-01_rb,8.779360e-01_rb,8.780587e-01_rb,& + & 8.781747e-01_rb,8.782852e-01_rb,8.783892e-01_rb,8.784891e-01_rb,8.785824e-01_rb,& + & 8.786705e-01_rb,8.787546e-01_rb,8.788336e-01_rb /) +! BAND 24 asyliq1(:, 24) = (/ & - & 8.069513e-01_rb,8.262939e-01_rb,8.398241e-01_rb,8.486352e-01_rb,8.538213e-01_rb,& - & 8.564743e-01_rb,8.576854e-01_rb,8.585455e-01_rb,8.601452e-01_rb,8.635755e-01_rb,& - & 8.337383e-01_rb,8.512655e-01_rb,8.643049e-01_rb,8.733896e-01_rb,8.790535e-01_rb,& - & 8.818295e-01_rb,8.822518e-01_rb,8.808533e-01_rb,8.781676e-01_rb,8.747284e-01_rb,& - & 8.710690e-01_rb,8.677229e-01_rb,8.652236e-01_rb,8.641047e-01_rb,8.648993e-01_rb,& - & 8.681413e-01_rb,8.743640e-01_rb,8.841007e-01_rb,8.633558e-01_rb,8.682719e-01_rb,& - & 8.723543e-01_rb,8.756621e-01_rb,8.782547e-01_rb,8.801915e-01_rb,8.815318e-01_rb,& - & 8.823347e-01_rb,8.826598e-01_rb,8.825663e-01_rb,8.821135e-01_rb,8.813608e-01_rb,& - & 8.803674e-01_rb,8.791928e-01_rb,8.778960e-01_rb,8.765366e-01_rb,8.751738e-01_rb,& - & 8.738670e-01_rb,8.726755e-01_rb,8.716585e-01_rb,8.708755e-01_rb,8.703856e-01_rb,& - & 8.702483e-01_rb,8.705229e-01_rb,8.712687e-01_rb,8.725448e-01_rb,8.744109e-01_rb,& - & 8.769260e-01_rb,8.801496e-01_rb,8.8414e-01_rb /) + & 8.054324e-01_rb,8.266282e-01_rb,8.378075e-01_rb,8.449848e-01_rb,8.502166e-01_rb,& + & 8.542268e-01_rb,8.573477e-01_rb,8.598022e-01_rb,8.617689e-01_rb,8.633859e-01_rb,& + & 8.647536e-01_rb,8.659354e-01_rb,8.669807e-01_rb,8.679143e-01_rb,8.687577e-01_rb,& + & 8.695222e-01_rb,8.702207e-01_rb,8.708591e-01_rb,8.714446e-01_rb,8.719836e-01_rb,& + & 8.724812e-01_rb,8.729426e-01_rb,8.733689e-01_rb,8.737665e-01_rb,8.741373e-01_rb,& + & 8.744834e-01_rb,8.748070e-01_rb,8.751131e-01_rb,8.754011e-01_rb,8.756676e-01_rb,& + & 8.759219e-01_rb,8.761599e-01_rb,8.763857e-01_rb,8.765984e-01_rb,8.767999e-01_rb,& + & 8.769889e-01_rb,8.771669e-01_rb,8.773373e-01_rb,8.774969e-01_rb,8.776469e-01_rb,& + & 8.777894e-01_rb,8.779237e-01_rb,8.780505e-01_rb,8.781703e-01_rb,8.782820e-01_rb,& + & 8.783886e-01_rb,8.784894e-01_rb,8.785844e-01_rb,8.786736e-01_rb,8.787584e-01_rb,& + & 8.788379e-01_rb,8.789130e-01_rb,8.789849e-01_rb,8.790506e-01_rb,8.791141e-01_rb,& + & 8.791750e-01_rb,8.792324e-01_rb,8.792867e-01_rb /) +! BAND 25 asyliq1(:, 25) = (/ & - & 8.252182e-01_rb,8.379244e-01_rb,8.471709e-01_rb,8.535760e-01_rb,8.577540e-01_rb,& - & 8.603183e-01_rb,8.618820e-01_rb,8.630578e-01_rb,8.644587e-01_rb,8.666970e-01_rb,& - & 8.362159e-01_rb,8.536817e-01_rb,8.666387e-01_rb,8.756240e-01_rb,8.811746e-01_rb,& - & 8.838273e-01_rb,8.841191e-01_rb,8.825871e-01_rb,8.797681e-01_rb,8.761992e-01_rb,& - & 8.724174e-01_rb,8.689593e-01_rb,8.663623e-01_rb,8.651632e-01_rb,8.658988e-01_rb,& - & 8.691064e-01_rb,8.753226e-01_rb,8.850847e-01_rb,8.641620e-01_rb,8.690500e-01_rb,& - & 8.731026e-01_rb,8.763795e-01_rb,8.789400e-01_rb,8.808438e-01_rb,8.821503e-01_rb,& - & 8.829191e-01_rb,8.832095e-01_rb,8.830813e-01_rb,8.825938e-01_rb,8.818064e-01_rb,& - & 8.807787e-01_rb,8.795704e-01_rb,8.782408e-01_rb,8.768493e-01_rb,8.754557e-01_rb,& - & 8.741193e-01_rb,8.728995e-01_rb,8.718561e-01_rb,8.710484e-01_rb,8.705360e-01_rb,& - & 8.703782e-01_rb,8.706347e-01_rb,8.713650e-01_rb,8.726285e-01_rb,8.744849e-01_rb,& - & 8.769933e-01_rb,8.802136e-01_rb,8.8421e-01_rb /) + & 8.249534e-01_rb,8.391988e-01_rb,8.474107e-01_rb,8.526860e-01_rb,8.563983e-01_rb,& + & 8.592389e-01_rb,8.615144e-01_rb,8.633790e-01_rb,8.649325e-01_rb,8.662504e-01_rb,& + & 8.673841e-01_rb,8.683741e-01_rb,8.692495e-01_rb,8.700309e-01_rb,8.707328e-01_rb,& + & 8.713650e-01_rb,8.719432e-01_rb,8.724676e-01_rb,8.729498e-01_rb,8.733922e-01_rb,& + & 8.737981e-01_rb,8.741745e-01_rb,8.745225e-01_rb,8.748467e-01_rb,8.751512e-01_rb,& + & 8.754315e-01_rb,8.756962e-01_rb,8.759450e-01_rb,8.761774e-01_rb,8.763945e-01_rb,& + & 8.766021e-01_rb,8.767970e-01_rb,8.769803e-01_rb,8.771511e-01_rb,8.773151e-01_rb,& + & 8.774689e-01_rb,8.776147e-01_rb,8.777533e-01_rb,8.778831e-01_rb,8.780050e-01_rb,& + & 8.781197e-01_rb,8.782301e-01_rb,8.783323e-01_rb,8.784312e-01_rb,8.785222e-01_rb,& + & 8.786096e-01_rb,8.786916e-01_rb,8.787688e-01_rb,8.788411e-01_rb,8.789122e-01_rb,& + & 8.789762e-01_rb,8.790373e-01_rb,8.790954e-01_rb,8.791514e-01_rb,8.792018e-01_rb,& + & 8.792517e-01_rb,8.792990e-01_rb,8.793429e-01_rb /) +! BAND 26 asyliq1(:, 26) = (/ & - & 8.370583e-01_rb,8.467920e-01_rb,8.537769e-01_rb,8.585136e-01_rb,8.615034e-01_rb,& - & 8.632474e-01_rb,8.642468e-01_rb,8.650026e-01_rb,8.660161e-01_rb,8.677882e-01_rb,& - & 8.369760e-01_rb,8.543821e-01_rb,8.672699e-01_rb,8.761782e-01_rb,8.816454e-01_rb,& - & 8.842103e-01_rb,8.844114e-01_rb,8.827872e-01_rb,8.798766e-01_rb,8.762179e-01_rb,& - & 8.723500e-01_rb,8.688112e-01_rb,8.661403e-01_rb,8.648758e-01_rb,8.655563e-01_rb,& - & 8.687206e-01_rb,8.749072e-01_rb,8.846546e-01_rb,8.636289e-01_rb,8.684849e-01_rb,& - & 8.725054e-01_rb,8.757501e-01_rb,8.782785e-01_rb,8.801503e-01_rb,8.814249e-01_rb,& - & 8.821620e-01_rb,8.824211e-01_rb,8.822620e-01_rb,8.817440e-01_rb,8.809268e-01_rb,& - & 8.798699e-01_rb,8.786330e-01_rb,8.772756e-01_rb,8.758572e-01_rb,8.744374e-01_rb,& - & 8.730760e-01_rb,8.718323e-01_rb,8.707660e-01_rb,8.699366e-01_rb,8.694039e-01_rb,& - & 8.692271e-01_rb,8.694661e-01_rb,8.701803e-01_rb,8.714293e-01_rb,8.732727e-01_rb,& - & 8.757702e-01_rb,8.789811e-01_rb,8.8297e-01_rb /) + & 8.323091e-01_rb,8.429776e-01_rb,8.498123e-01_rb,8.546929e-01_rb,8.584295e-01_rb,& + & 8.613489e-01_rb,8.636324e-01_rb,8.654303e-01_rb,8.668675e-01_rb,8.680404e-01_rb,& + & 8.690174e-01_rb,8.698495e-01_rb,8.705666e-01_rb,8.711961e-01_rb,8.717556e-01_rb,& + & 8.722546e-01_rb,8.727063e-01_rb,8.731170e-01_rb,8.734933e-01_rb,8.738382e-01_rb,& + & 8.741590e-01_rb,8.744525e-01_rb,8.747295e-01_rb,8.749843e-01_rb,8.752210e-01_rb,& + & 8.754437e-01_rb,8.756524e-01_rb,8.758472e-01_rb,8.760288e-01_rb,8.762030e-01_rb,& + & 8.763603e-01_rb,8.765122e-01_rb,8.766539e-01_rb,8.767894e-01_rb,8.769130e-01_rb,& + & 8.770310e-01_rb,8.771422e-01_rb,8.772437e-01_rb,8.773419e-01_rb,8.774355e-01_rb,& + & 8.775221e-01_rb,8.776047e-01_rb,8.776802e-01_rb,8.777539e-01_rb,8.778216e-01_rb,& + & 8.778859e-01_rb,8.779473e-01_rb,8.780031e-01_rb,8.780562e-01_rb,8.781097e-01_rb,& + & 8.781570e-01_rb,8.782021e-01_rb,8.782463e-01_rb,8.782845e-01_rb,8.783235e-01_rb,& + & 8.783610e-01_rb,8.783953e-01_rb,8.784273e-01_rb /) +! BAND 27 asyliq1(:, 27) = (/ & - & 8.430819e-01_rb,8.510060e-01_rb,8.567270e-01_rb,8.606533e-01_rb,8.631934e-01_rb,& - & 8.647554e-01_rb,8.657471e-01_rb,8.665760e-01_rb,8.676496e-01_rb,8.693754e-01_rb,& - & 8.384298e-01_rb,8.557913e-01_rb,8.686214e-01_rb,8.774605e-01_rb,8.828495e-01_rb,& - & 8.853287e-01_rb,8.854393e-01_rb,8.837215e-01_rb,8.807161e-01_rb,8.769639e-01_rb,& - & 8.730053e-01_rb,8.693812e-01_rb,8.666321e-01_rb,8.652988e-01_rb,8.659219e-01_rb,& - & 8.690419e-01_rb,8.751999e-01_rb,8.849360e-01_rb,8.638013e-01_rb,8.686371e-01_rb,& - & 8.726369e-01_rb,8.758605e-01_rb,8.783674e-01_rb,8.802176e-01_rb,8.814705e-01_rb,& - & 8.821859e-01_rb,8.824234e-01_rb,8.822429e-01_rb,8.817038e-01_rb,8.808658e-01_rb,& - & 8.797887e-01_rb,8.785323e-01_rb,8.771560e-01_rb,8.757196e-01_rb,8.742828e-01_rb,& - & 8.729052e-01_rb,8.716467e-01_rb,8.705666e-01_rb,8.697250e-01_rb,8.691812e-01_rb,& - & 8.689950e-01_rb,8.692264e-01_rb,8.699346e-01_rb,8.711795e-01_rb,8.730209e-01_rb,& - & 8.755181e-01_rb,8.787312e-01_rb,8.8272e-01_rb /) + & 8.396448e-01_rb,8.480172e-01_rb,8.535934e-01_rb,8.574145e-01_rb,8.600835e-01_rb,& + & 8.620347e-01_rb,8.635500e-01_rb,8.648003e-01_rb,8.658758e-01_rb,8.668248e-01_rb,& + & 8.676697e-01_rb,8.684220e-01_rb,8.690893e-01_rb,8.696807e-01_rb,8.702046e-01_rb,& + & 8.706676e-01_rb,8.710798e-01_rb,8.714478e-01_rb,8.717778e-01_rb,8.720747e-01_rb,& + & 8.723431e-01_rb,8.725889e-01_rb,8.728144e-01_rb,8.730201e-01_rb,8.732129e-01_rb,& + & 8.733907e-01_rb,8.735541e-01_rb,8.737100e-01_rb,8.738533e-01_rb,8.739882e-01_rb,& + & 8.741164e-01_rb,8.742362e-01_rb,8.743485e-01_rb,8.744530e-01_rb,8.745512e-01_rb,& + & 8.746471e-01_rb,8.747373e-01_rb,8.748186e-01_rb,8.748973e-01_rb,8.749732e-01_rb,& + & 8.750443e-01_rb,8.751105e-01_rb,8.751747e-01_rb,8.752344e-01_rb,8.752902e-01_rb,& + & 8.753412e-01_rb,8.753917e-01_rb,8.754393e-01_rb,8.754843e-01_rb,8.755282e-01_rb,& + & 8.755662e-01_rb,8.756039e-01_rb,8.756408e-01_rb,8.756722e-01_rb,8.757072e-01_rb,& + & 8.757352e-01_rb,8.757653e-01_rb,8.757932e-01_rb /) +! BAND 28 asyliq1(:, 28) = (/ & - & 8.452284e-01_rb,8.522700e-01_rb,8.572973e-01_rb,8.607031e-01_rb,8.628802e-01_rb,& - & 8.642215e-01_rb,8.651198e-01_rb,8.659679e-01_rb,8.671588e-01_rb,8.690853e-01_rb,& - & 8.383803e-01_rb,8.557485e-01_rb,8.685851e-01_rb,8.774303e-01_rb,8.828245e-01_rb,& - & 8.853077e-01_rb,8.854207e-01_rb,8.837034e-01_rb,8.806962e-01_rb,8.769398e-01_rb,& - & 8.729740e-01_rb,8.693393e-01_rb,8.665761e-01_rb,8.652247e-01_rb,8.658253e-01_rb,& - & 8.689182e-01_rb,8.750438e-01_rb,8.847424e-01_rb,8.636140e-01_rb,8.684449e-01_rb,& - & 8.724400e-01_rb,8.756589e-01_rb,8.781613e-01_rb,8.800072e-01_rb,8.812559e-01_rb,& - & 8.819671e-01_rb,8.822007e-01_rb,8.820165e-01_rb,8.814737e-01_rb,8.806322e-01_rb,& - & 8.795518e-01_rb,8.782923e-01_rb,8.769129e-01_rb,8.754737e-01_rb,8.740342e-01_rb,& - & 8.726542e-01_rb,8.713934e-01_rb,8.703111e-01_rb,8.694677e-01_rb,8.689222e-01_rb,& - & 8.687344e-01_rb,8.689646e-01_rb,8.696715e-01_rb,8.709156e-01_rb,8.727563e-01_rb,& - & 8.752531e-01_rb,8.784659e-01_rb,8.8245e-01_rb /) + & 8.374590e-01_rb,8.465669e-01_rb,8.518701e-01_rb,8.547627e-01_rb,8.565745e-01_rb,& + & 8.579065e-01_rb,8.589717e-01_rb,8.598632e-01_rb,8.606363e-01_rb,8.613268e-01_rb,& + & 8.619560e-01_rb,8.625340e-01_rb,8.630689e-01_rb,8.635601e-01_rb,8.640084e-01_rb,& + & 8.644180e-01_rb,8.647885e-01_rb,8.651220e-01_rb,8.654218e-01_rb,8.656908e-01_rb,& + & 8.659294e-01_rb,8.661422e-01_rb,8.663334e-01_rb,8.665037e-01_rb,8.666543e-01_rb,& + & 8.667913e-01_rb,8.669156e-01_rb,8.670242e-01_rb,8.671249e-01_rb,8.672161e-01_rb,& + & 8.672993e-01_rb,8.673733e-01_rb,8.674457e-01_rb,8.675103e-01_rb,8.675713e-01_rb,& + & 8.676267e-01_rb,8.676798e-01_rb,8.677286e-01_rb,8.677745e-01_rb,8.678178e-01_rb,& + & 8.678601e-01_rb,8.678986e-01_rb,8.679351e-01_rb,8.679693e-01_rb,8.680013e-01_rb,& + & 8.680334e-01_rb,8.680624e-01_rb,8.680915e-01_rb,8.681178e-01_rb,8.681428e-01_rb,& + & 8.681654e-01_rb,8.681899e-01_rb,8.682103e-01_rb,8.682317e-01_rb,8.682498e-01_rb,& + & 8.682677e-01_rb,8.682861e-01_rb,8.683041e-01_rb /) +! BAND 29 asyliq1(:, 29) = (/ & - & 7.800869e-01_rb,8.091120e-01_rb,8.325369e-01_rb,8.466266e-01_rb,8.515495e-01_rb,& - & 8.499371e-01_rb,8.456203e-01_rb,8.430521e-01_rb,8.470286e-01_rb,8.625431e-01_rb,& - & 8.402261e-01_rb,8.610822e-01_rb,8.776608e-01_rb,8.904485e-01_rb,8.999294e-01_rb,& - & 9.065860e-01_rb,9.108995e-01_rb,9.133503e-01_rb,9.144187e-01_rb,9.145855e-01_rb,& - & 9.143320e-01_rb,9.141402e-01_rb,9.144933e-01_rb,9.158754e-01_rb,9.187716e-01_rb,& - & 9.236677e-01_rb,9.310503e-01_rb,9.414058e-01_rb,9.239108e-01_rb,9.300719e-01_rb,& - & 9.353612e-01_rb,9.398378e-01_rb,9.435609e-01_rb,9.465895e-01_rb,9.489829e-01_rb,& - & 9.508000e-01_rb,9.521002e-01_rb,9.529424e-01_rb,9.533860e-01_rb,9.534902e-01_rb,& - & 9.533143e-01_rb,9.529177e-01_rb,9.523596e-01_rb,9.516997e-01_rb,9.509973e-01_rb,& - & 9.503121e-01_rb,9.497037e-01_rb,9.492317e-01_rb,9.489558e-01_rb,9.489356e-01_rb,& - & 9.492311e-01_rb,9.499019e-01_rb,9.510077e-01_rb,9.526084e-01_rb,9.547636e-01_rb,& - & 9.575331e-01_rb,9.609766e-01_rb,9.6515e-01_rb /) + & 7.877069e-01_rb,8.244281e-01_rb,8.367971e-01_rb,8.409074e-01_rb,8.429859e-01_rb,& + & 8.454386e-01_rb,8.489350e-01_rb,8.534141e-01_rb,8.585814e-01_rb,8.641267e-01_rb,& + & 8.697999e-01_rb,8.754223e-01_rb,8.808785e-01_rb,8.860944e-01_rb,8.910354e-01_rb,& + & 8.956837e-01_rb,9.000392e-01_rb,9.041091e-01_rb,9.079071e-01_rb,9.114479e-01_rb,& + & 9.147462e-01_rb,9.178234e-01_rb,9.206903e-01_rb,9.233663e-01_rb,9.258668e-01_rb,& + & 9.282006e-01_rb,9.303847e-01_rb,9.324288e-01_rb,9.343418e-01_rb,9.361356e-01_rb,& + & 9.378176e-01_rb,9.393939e-01_rb,9.408736e-01_rb,9.422622e-01_rb,9.435670e-01_rb,& + & 9.447900e-01_rb,9.459395e-01_rb,9.470199e-01_rb,9.480335e-01_rb,9.489852e-01_rb,& + & 9.498782e-01_rb,9.507168e-01_rb,9.515044e-01_rb,9.522470e-01_rb,9.529409e-01_rb,& + & 9.535946e-01_rb,9.542071e-01_rb,9.547838e-01_rb,9.553256e-01_rb,9.558351e-01_rb,& + & 9.563139e-01_rb,9.567660e-01_rb,9.571915e-01_rb,9.575901e-01_rb,9.579685e-01_rb,& + & 9.583239e-01_rb,9.586602e-01_rb,9.589766e-01_rb /) + ! Spherical Ice Particle Parameterization ! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)] @@ -9095,8 +9142,8 @@ subroutine rrtmg_sw & iout = 0 !BSINGH(PNNL) initializing iout to zero(Might be wrong!) as this variable is never initialized but used in spcvmc_sw zepsec = 1.e-06_rb zepzen = 1.e-10_rb - oneminus = 1.0_rb - zepsec - pi = 2._rb * asin(1._rb) +!jm not thread safe oneminus = 1.0_rb - zepsec +!jm not thread safe pi = 2._rb * asin(1._rb) istart = jpb1 iend = jpb2 @@ -9762,7 +9809,7 @@ MODULE module_ra_rrtmg_sw use rrtmg_sw_rad, only: rrtmg_sw use mcica_subcol_gen_sw, only: mcica_subcol_sw -use module_ra_rrtmg_lw, only : inirad, o3data, relcalc, reicalc +use module_ra_rrtmg_lw, only : inirad, o3data, relcalc, reicalc, retab ! mcica_random_numbers, randomNumberSequence, & ! new_RandomNumberSequence, getRandomReal @@ -9880,7 +9927,7 @@ SUBROUTINE RRTMG_SWRAD( & swddif ! All-sky broadband surface diffuse irradiance real, optional, intent(in) :: & julian ! julian day (1-366) - real, dimension(ims:ime,jms:jme), optional, intent(in) :: & + real, dimension(ims:ime,jms:jme), intent(in) :: & xcoszen ! cosine of the solar zenith angle real, dimension(ims:ime,kms:kme,jms:jme,nbndsw), optional, & intent(in) :: tauaer3d_sw, & @@ -10068,6 +10115,9 @@ SUBROUTINE RRTMG_SWRAD( & snow_mass_factor integer :: dyofyr + integer:: idx_rei + real:: corr + ! Set trace gas volume mixing ratios, 2005 values, IPCC (2007) ! carbon dioxide (379 ppmv) real :: co2 @@ -10136,15 +10186,13 @@ SUBROUTINE RRTMG_SWRAD( & integer :: pcols, pver - REAL :: XT24, TLOCTM, HRANG, XXLAT - INTEGER :: i,j,K, na LOGICAL :: predicate REAL :: da, eot ! jararias, 14/08/2013 !------------------------------------------------------------------ -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( aer_ra_feedback == 1) then IF ( .NOT. & ( PRESENT(tauaer300) .AND. & @@ -10170,11 +10218,6 @@ SUBROUTINE RRTMG_SWRAD( & ! All fields are ordered vertically from bottom to top ! Pressures are in mb - ! jararias, 14/08/2013 - if (present(xcoszen)) then - call wrf_debug(100,'coszen from radiation driver') - end if - ! latitude loop j_loop: do j = jts,jte @@ -10186,26 +10229,9 @@ SUBROUTINE RRTMG_SWRAD( & ! Cosine solar zenith angle for current time step ! -! xt24 is the fractional part of simulation days plus half of radt expressed in -! units of minutes -! julian is in days -! radt is in minutes ! jararias, 14/08/2013 - if (present(xcoszen)) then - coszr(i,j)=xcoszen(i,j) - coszrs=xcoszen(i,j) - else -! da=6.2831853071795862*(julian-1)/365. -! eot=(0.000075+0.001868*cos(da)-0.032077*sin(da) & -! -0.014615*cos(2*da)-0.04089*sin(2*da))*(229.18) - xt24 = mod(xtime+radt*0.5,1440.)+eot - tloctm = gmt + xt24/60. + xlong(i,j)/15. - hrang = 15. * (tloctm-12.) * degrad - xxlat = xlat(i,j) * degrad - coszrs = sin(xxlat) * sin(declin) & - + cos(xxlat) * cos(declin) * cos(hrang) - coszr(i,j) = coszrs - end if + coszr(i,j)=xcoszen(i,j) + coszrs=xcoszen(i,j) ! Set flag to prevent shortwave calculation when sun below horizon if (coszrs.le.0.0) dorrsw = .false. @@ -10379,6 +10405,13 @@ SUBROUTINE RRTMG_SWRAD( & inflgsw = 3 DO K=kts,kte recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6) + if (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean + recloud1D(ncol,K) = 10.5 + elseif (recloud1D(ncol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land + recloud1D(ncol,K) = 7.5 + endif ENDDO ELSE DO K=kts,kte @@ -10391,10 +10424,18 @@ SUBROUTINE RRTMG_SWRAD( & iceflgsw = 4 DO K=kts,kte reice1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6) + if (reice1D(ncol,K).LE.10..AND.cldfra3d(i,k,j).gt.0.) then + idx_rei = int(t3d(i,k,j)-179.) + idx_rei = min(max(idx_rei,1),75) + corr = t3d(i,k,j) - int(t3d(i,k,j)) + reice1D(ncol,K) = retab(idx_rei)*(1.-corr) + & + & retab(idx_rei+1)*corr + reice1D(ncol,K) = MAX(reice1D(ncol,K), 10.0) + endif ENDDO ELSE DO K=kts,kte - reice1D(ncol,K) = 10.0 + reice1D(ncol,K) = 10. ENDDO ENDIF @@ -10792,7 +10833,7 @@ SUBROUTINE RRTMG_SWRAD( & end if end if -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( AER_RA_FEEDBACK == 1) then do nb = 1, nbndsw wavemid(nb)=0.5*(wavemin(nb)+wavemax(nb)) ! um @@ -12174,3 +12215,4 @@ end subroutine sw_kgb29 !------------------------------------------------------------------ END MODULE module_ra_rrtmg_sw +!*********************************************************************** diff --git a/wrfv2_fire/phys/module_ra_rrtmg_swf.F b/wrfv2_fire/phys/module_ra_rrtmg_swf.F new file mode 100644 index 00000000..fa2692d0 --- /dev/null +++ b/wrfv2_fire/phys/module_ra_rrtmg_swf.F @@ -0,0 +1,13730 @@ +!!MODULE module_ra_rrtmg_swf +#define CHNK 8 +!#define CHNK 1849 +!#define CHNK 43 +!#define CHNK 1 + +! -------------------------------------------------------------------------- +! | | +! | Copyright 2002-2013, Atmospheric & Environmental Research, Inc. (AER). | +! | This software may be used, copied, or redistributed as long as it is | +! | not sold and this copyright notice is reproduced on each copy made. | +! | This model is provided as is without any express or implied warranties. | +! | (http://www.rtweb.aer.com/) | +! | | +! -------------------------------------------------------------------------- + +#ifndef _ACCEL +! this set of macros reverses the storage order of some of the array variables +! defined in rrtmg_sw_sub and used in various sections of the code. Here is a +! correspondencet table for the variables as they are known in rrtmg_sw_sub and +! in the subroutines that rrtmg_sw_sub calls: + +!jm rrtmg_sw_sub +!jm | mcica_sw +!jm | | cldprmc_sw +!jm | | | spcvmc_sw +!jm | | | | reftra_sw +!jm tauc tauc | | | +!jm ssac ssac | | | +!jm asmc asmc | | | +!jm fsfc fsfc | | | +!jm taucmc tauc_stoch | ptaucmc | +!jm taormc | | ptaormc | +!jm ssacmc ssac_stoch | pomgcmc | +!jm asmcmc asmc_stoch | pasycmc | +!jm fsfcmc fsfc_stoch | | | +!jm cldfmcl cld_stoch cldmfc pcldfmc pcldfmc +!jm ciwpmcl ciwp_stoch ciwpmc | +!jm clwpmcl clwp_stoch clwpmc | +!jm cswpmcl cswp_stoch cswpmc | +!jm ztauc | +!jm ztaucorig | +!jm zasyc | +!jm zomgc | +!jm taua ptaua +!jm asya pasya +!jm omga pomga + +#define tauc(A,B,C) TAUC(A,C,B) +#define ssac(A,B,C) SSAC(A,C,B) +#define asmc(A,B,C) ASMC(A,C,B) +#define fsfc(A,B,C) FSFC(A,C,B) +#define taucmc(A,B,C) TAUCMC(A,C,B) +#define tauc_stoch(A,B,C) TAUC_STOCH(A,C,B) +#define ptaucmc(A,B,C) pTAUCMC(A,C,B) +#define taormc(A,B,C) TAORMC(A,C,B) +#define ptaormc(A,B,C) pTAORMC(A,C,B) +#define ssacmc(A,B,C) SSACMC(A,C,B) +#define ssac_stoch(A,B,C) SSAC_STOCH(A,C,B) +#define pomgcmc(A,B,C) pOMGCMC(A,C,B) +#define asmcmc(A,B,C) ASMCMC(A,C,B) +#define asmc_stoch(A,B,C) ASMC_STOCH(A,C,B) +#define pasycmc(A,B,C) pASYCMC(A,C,B) +#define fsfcmc(A,B,C) FSFCMC(A,C,B) +#define fsfc_stoch(A,B,C) FSFC_STOCH(A,C,B) + +#define cldfmcl(A,B,C) CLDFMCL(A,C,B) +#define cld_stoch(A,B,C) CLD_STOCH(A,C,B) +#define cldfmc(A,B,C) CLDFMC(A,C,B) +#define pcldfmc(A,B,C) pCLDFMC(A,C,B) + +#define ciwpmcl(A,B,C) CIWPMCL(A,C,B) +#define ciwp_stoch(A,B,C) CIWP_STOCH(A,C,B) +#define ciwpmc(A,B,C) CIWPMC(A,C,B) + +#define clwpmcl(A,B,C) CLWPMCL(A,C,B) +#define clwp_stoch(A,B,C) CLWP_STOCH(A,C,B) +#define clwpmc(A,B,C) CLWPMC(A,C,B) + +#define cswpmcl(A,B,C) CSWPMCL(A,C,B) +#define cswp_stoch(A,B,C) CSWP_STOCH(A,C,B) +#define cswpmc(A,B,C) CSWPMC(A,C,B) + +#define taua(A,B,C) TAUA(A,C,B) +#define asya(A,B,C) ASYA(A,C,B) +#define omga(A,B,C) OMGA(A,C,B) +#define ptaua(A,B,C) pTAUA(A,C,B) +#define pasya(A,B,C) pASYA(A,C,B) +#define pomga(A,B,C) pOMGA(A,C,B) + +#endif + +! Uncomment to use GPU, or comment to use CPU +!#define _ACCEL + +#ifdef _ACCEL +#define gpu_device ,device +#else +#define gpu_device +#endif + + module parrrsw_f + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw main parameters +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! mxlay : integer: maximum number of layers +! mg : integer: number of original g-intervals per spectral band +! nbndsw : integer: number of spectral bands +! naerec : integer: number of aerosols (iaer=6, ecmwf aerosol option) +! ngptsw : integer: total number of reduced g-intervals for rrtmg_lw +! ngNN : integer: number of reduced g-intervals per spectral band +! ngsNN : integer: cumulative number of g-intervals per band +!------------------------------------------------------------------ + + integer , parameter :: mxlay = 203 !jplay, klev + integer , parameter :: mg = 16 !jpg + integer , parameter :: nbndsw = 14 !jpsw, ksw + integer , parameter :: naerec = 6 !jpaer + integer , parameter :: mxmol = 38 + integer , parameter :: nstr = 2 + integer , parameter :: nmol = 7 +! Use for 112 g-point model + integer , parameter :: ngptsw = 112 !jpgpt +! Use for 224 g-point model +! integer , parameter :: ngptsw = 224 !jpgpt + +! may need to rename these - from v2.6 + integer , parameter :: jpband = 29 + integer , parameter :: jpb1 = 16 !istart + integer , parameter :: jpb2 = 29 !iend + + integer , parameter :: jmcmu = 32 + integer , parameter :: jmumu = 32 + integer , parameter :: jmphi = 3 + integer , parameter :: jmxang = 4 + integer , parameter :: jmxstr = 16 +! ^ + +! Use for 112 g-point model + integer , parameter :: ng16 = 6 + integer , parameter :: ng17 = 12 + integer , parameter :: ng18 = 8 + integer , parameter :: ng19 = 8 + integer , parameter :: ng20 = 10 + integer , parameter :: ng21 = 10 + integer , parameter :: ng22 = 2 + integer , parameter :: ng23 = 10 + integer , parameter :: ng24 = 8 + integer , parameter :: ng25 = 6 + integer , parameter :: ng26 = 6 + integer , parameter :: ng27 = 8 + integer , parameter :: ng28 = 6 + integer , parameter :: ng29 = 12 + + integer , parameter :: ngs16 = 6 + integer , parameter :: ngs17 = 18 + integer , parameter :: ngs18 = 26 + integer , parameter :: ngs19 = 34 + integer , parameter :: ngs20 = 44 + integer , parameter :: ngs21 = 54 + integer , parameter :: ngs22 = 56 + integer , parameter :: ngs23 = 66 + integer , parameter :: ngs24 = 74 + integer , parameter :: ngs25 = 80 + integer , parameter :: ngs26 = 86 + integer , parameter :: ngs27 = 94 + integer , parameter :: ngs28 = 100 + integer , parameter :: ngs29 = 112 + +! Use for 224 g-point model +! integer , parameter :: ng16 = 16 +! integer , parameter :: ng17 = 16 +! integer , parameter :: ng18 = 16 +! integer , parameter :: ng19 = 16 +! integer , parameter :: ng20 = 16 +! integer , parameter :: ng21 = 16 +! integer , parameter :: ng22 = 16 +! integer , parameter :: ng23 = 16 +! integer , parameter :: ng24 = 16 +! integer , parameter :: ng25 = 16 +! integer , parameter :: ng26 = 16 +! integer , parameter :: ng27 = 16 +! integer , parameter :: ng28 = 16 +! integer , parameter :: ng29 = 16 + +! integer , parameter :: ngs16 = 16 +! integer , parameter :: ngs17 = 32 +! integer , parameter :: ngs18 = 48 +! integer , parameter :: ngs19 = 64 +! integer , parameter :: ngs20 = 80 +! integer , parameter :: ngs21 = 96 +! integer , parameter :: ngs22 = 112 +! integer , parameter :: ngs23 = 128 +! integer , parameter :: ngs24 = 144 +! integer , parameter :: ngs25 = 160 +! integer , parameter :: ngs26 = 176 +! integer , parameter :: ngs27 = 192 +! integer , parameter :: ngs28 = 208 +! integer , parameter :: ngs29 = 224 + +! Source function solar constant + real , parameter :: rrsw_scon = 1.36822e+03 ! W/m2 + + end module parrrsw_f + + module rrsw_aer_f + + use parrrsw_f, only : nbndsw, naerec + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw aerosol optical properties +! +! Data derived from six ECMWF aerosol types and defined for +! the rrtmg_sw spectral intervals +! +! Initial: J.-J. Morcrette, ECMWF, mar2003 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ +! +!-- The six ECMWF aerosol types are respectively: +! +! 1/ continental average 2/ maritime +! 3/ desert 4/ urban +! 5/ volcanic active 6/ stratospheric background +! +! computed from Hess and Koepke (con, mar, des, urb) +! from Bonnel et al. (vol, str) +! +! rrtmg_sw 14 spectral intervals (microns): +! 3.846 - 3.077 +! 3.077 - 2.500 +! 2.500 - 2.150 +! 2.150 - 1.942 +! 1.942 - 1.626 +! 1.626 - 1.299 +! 1.299 - 1.242 +! 1.242 - 0.7782 +! 0.7782- 0.6250 +! 0.6250- 0.4415 +! 0.4415- 0.3448 +! 0.3448- 0.2632 +! 0.2632- 0.2000 +! 12.195 - 3.846 +! +!------------------------------------------------------------------ +! +! name type purpose +! ----- : ---- : ---------------------------------------------- +! rsrtaua : real : ratio of average optical thickness in +! spectral band to that at 0.55 micron +! rsrpiza : real : average single scattering albedo (unitless) +! rsrasya : real : average asymmetry parameter (unitless) +!------------------------------------------------------------------ + + real :: rsrtaua(nbndsw,naerec) + real :: rsrpiza(nbndsw,naerec) + real :: rsrasya(nbndsw,naerec) + + end module rrsw_aer_f + + module rrsw_cld_f + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw cloud property coefficients +! +! Initial: J.-J. Morcrette, ECMWF, oct1999 +! Revised: J. Delamere/MJIacono, AER, aug2005 +! Revised: MJIacono, AER, nov2005 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ +! +! name type purpose +! ----- : ---- : ---------------------------------------------- +! xxxliq1 : real : optical properties (extinction coefficient, single +! scattering albedo, assymetry factor) from +! Hu & Stamnes, j. clim., 6, 728-742, 1993. +! xxxice2 : real : optical properties (extinction coefficient, single +! scattering albedo, assymetry factor) from streamer v3.0, +! Key, streamer user's guide, cooperative institude +! for meteorological studies, 95 pp., 2001. +! xxxice3 : real : optical properties (extinction coefficient, single +! scattering albedo, assymetry factor) from +! Fu, j. clim., 9, 1996. +! xbari : real : optical property coefficients for five spectral +! intervals (2857-4000, 4000-5263, 5263-7692, 7692-14285, +! and 14285-40000 wavenumbers) following +! Ebert and Curry, jgr, 97, 3831-3836, 1992. +!------------------------------------------------------------------ + + real :: extliq1(58,16:29), ssaliq1(58,16:29), asyliq1(58,16:29) + real :: extice2(43,16:29), ssaice2(43,16:29), asyice2(43,16:29) + real :: extice3(46,16:29), ssaice3(46,16:29), asyice3(46,16:29) + real :: fdlice3(46,16:29) + real :: abari(5),bbari(5),cbari(5),dbari(5),ebari(5),fbari(5) + + end module rrsw_cld_f + + module rrsw_con_f + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw constants + +! Initial version: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! fluxfac: real : radiance to flux conversion factor +! heatfac: real : flux to heating rate conversion factor +!oneminus: real : 1.-1.e-6 +! pi : real : pi +! grav : real : acceleration of gravity +! planck : real : planck constant +! boltz : real : boltzmann constant +! clight : real : speed of light +! avogad : real : avogadro constant +! alosmt : real : loschmidt constant +! gascon : real : molar gas constant +! radcn1 : real : first radiation constant +! radcn2 : real : second radiation constant +! sbcnst : real : stefan-boltzmann constant +! secdy : real : seconds per day +!------------------------------------------------------------------ + + real :: fluxfac, heatfac + real :: oneminus, pi, grav + real :: planck, boltz, clight + real :: avogad, alosmt, gascon + real :: radcn1, radcn2 + real :: sbcnst, secdy + + end module rrsw_con_f + + module rrsw_kg16_f + + use parrrsw_f, only : ng16 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 16 +! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer , parameter :: no16 = 16 + + real :: kao(9,5,13,no16) + real :: kbo(5,13:59,no16) + real :: selfrefo(10,no16), forrefo(3,no16) + real :: sfluxrefo(no16) + + integer :: layreffr + real :: rayl, strrat1 + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 16 +! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real :: ka(9,5,13,ng16) , absa(585,ng16) + real :: kb(5,13:59,ng16), absb(235,ng16) + real :: selfref(10,ng16), forref(3,ng16) + real :: sfluxref(ng16) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg16_f + + module rrsw_kg17_f + + use parrrsw_f, only : ng17 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 17 +! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer , parameter :: no17 = 16 + + real :: kao(9,5,13,no17) + real :: kbo(5,5,13:59,no17) + real :: selfrefo(10,no17), forrefo(4,no17) + real :: sfluxrefo(no17,5) + + integer :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 17 +! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real :: ka(9,5,13,ng17) , absa(585,ng17) + real :: kb(5,5,13:59,ng17), absb(1175,ng17) + real :: selfref(10,ng17), forref(4,ng17) + real :: sfluxref(ng17,5) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1)) + + end module rrsw_kg17_f + + module rrsw_kg18_f + + use parrrsw_f, only : ng18 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 18 +! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer , parameter :: no18 = 16 + + real :: kao(9,5,13,no18) + real :: kbo(5,13:59,no18) + real :: selfrefo(10,no18), forrefo(3,no18) + real :: sfluxrefo(no18,9) + + integer :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 18 +! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real :: ka(9,5,13,ng18), absa(585,ng18) + real :: kb(5,13:59,ng18), absb(235,ng18) + real :: selfref(10,ng18), forref(3,ng18) + real :: sfluxref(ng18,9) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg18_f + + module rrsw_kg19_f + + use parrrsw_f, only : ng19 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 19 +! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer , parameter :: no19 = 16 + + real :: kao(9,5,13,no19) + real :: kbo(5,13:59,no19) + real :: selfrefo(10,no19), forrefo(3,no19) + real :: sfluxrefo(no19,9) + + integer :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 19 +! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real :: ka(9,5,13,ng19), absa(585,ng19) + real :: kb(5,13:59,ng19), absb(235,ng19) + real :: selfref(10,ng19), forref(3,ng19) + real :: sfluxref(ng19,9) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg19_f + + module rrsw_kg20_f + + use parrrsw_f, only : ng20 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 20 +! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +! absch4o : real +!----------------------------------------------------------------- + + integer , parameter :: no20 = 16 + + real :: kao(5,13,no20) + real :: kbo(5,13:59,no20) + real :: selfrefo(10,no20), forrefo(4,no20) + real :: sfluxrefo(no20) + real :: absch4o(no20) + + integer :: layreffr + real :: rayl + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 20 +! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +! absch4 : real +!----------------------------------------------------------------- + + real :: ka(5,13,ng20), absa(65,ng20) + real :: kb(5,13:59,ng20), absb(235,ng20) + real :: selfref(10,ng20), forref(4,ng20) + real :: sfluxref(ng20) + real :: absch4(ng20) + + equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg20_f + + module rrsw_kg21_f + + use parrrsw_f, only : ng21 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 21 +! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer , parameter :: no21 = 16 + + real :: kao(9,5,13,no21) + real :: kbo(5,5,13:59,no21) + real :: selfrefo(10,no21), forrefo(4,no21) + real :: sfluxrefo(no21,9) + + integer :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 21 +! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real :: ka(9,5,13,ng21), absa(585,ng21) + real :: kb(5,5,13:59,ng21), absb(1175,ng21) + real :: selfref(10,ng21), forref(4,ng21) + real :: sfluxref(ng21,9) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1)) + + end module rrsw_kg21_f + + module rrsw_kg22_f + + use parrrsw_f, only : ng22 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 22 +! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer , parameter :: no22 = 16 + + real :: kao(9,5,13,no22) + real :: kbo(5,13:59,no22) + real :: selfrefo(10,no22), forrefo(3,no22) + real :: sfluxrefo(no22,9) + + integer :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 22 +! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real :: ka(9,5,13,ng22), absa(585,ng22) + real :: kb(5,13:59,ng22), absb(235,ng22) + real :: selfref(10,ng22), forref(3,ng22) + real :: sfluxref(ng22,9) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg22_f + + module rrsw_kg23_f + + use parrrsw_f, only : ng23 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 23 +! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer , parameter :: no23 = 16 + + real :: kao(5,13,no23) + real :: selfrefo(10,no23), forrefo(3,no23) + real :: sfluxrefo(no23) + real :: raylo(no23) + + integer :: layreffr + real :: givfac + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 23 +! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +!----------------------------------------------------------------- + + real :: ka(5,13,ng23), absa(65,ng23) + real :: selfref(10,ng23), forref(3,ng23) + real :: sfluxref(ng23), rayl(ng23) + + equivalence (ka(1,1,1),absa(1,1)) + + end module rrsw_kg23_f + + module rrsw_kg24_f + + use parrrsw_f, only : ng24 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 24 +! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +! abso3ao : real +! abso3bo : real +! raylao : real +! raylbo : real +!----------------------------------------------------------------- + + integer , parameter :: no24 = 16 + + real :: kao(9,5,13,no24) + real :: kbo(5,13:59,no24) + real :: selfrefo(10,no24), forrefo(3,no24) + real :: sfluxrefo(no24,9) + real :: abso3ao(no24), abso3bo(no24) + real :: raylao(no24,9), raylbo(no24) + + integer :: layreffr + real :: strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 24 +! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! selfref : real +! forref : real +! sfluxref: real +! abso3a : real +! abso3b : real +! rayla : real +! raylb : real +!----------------------------------------------------------------- + + real :: ka(9,5,13,ng24), absa(585,ng24) + real :: kb(5,13:59,ng24), absb(235,ng24) + real :: selfref(10,ng24), forref(3,ng24) + real :: sfluxref(ng24,9) + real :: abso3a(ng24), abso3b(ng24) + real :: rayla(ng24,9), raylb(ng24) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg24_f + + module rrsw_kg25_f + + use parrrsw_f, only : ng25 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 25 +! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +!sfluxrefo: real +! abso3ao : real +! abso3bo : real +! raylo : real +!----------------------------------------------------------------- + + integer , parameter :: no25 = 16 + + real :: kao(5,13,no25) + real :: sfluxrefo(no25) + real :: abso3ao(no25), abso3bo(no25) + real :: raylo(no25) + + integer :: layreffr + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 25 +! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! absa : real +! sfluxref: real +! abso3a : real +! abso3b : real +! rayl : real +!----------------------------------------------------------------- + + real :: ka(5,13,ng25), absa(65,ng25) + real :: sfluxref(ng25) + real :: abso3a(ng25), abso3b(ng25) + real :: rayl(ng25) + + equivalence (ka(1,1,1),absa(1,1)) + + end module rrsw_kg25_f + + module rrsw_kg26_f + + use parrrsw_f, only : ng26 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 26 +! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +!sfluxrefo: real +! raylo : real +!----------------------------------------------------------------- + + integer , parameter :: no26 = 16 + + real :: sfluxrefo(no26) + real :: raylo(no26) + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 26 +! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! sfluxref: real +! rayl : real +!----------------------------------------------------------------- + + real :: sfluxref(ng26) + real :: rayl(ng26) + + end module rrsw_kg26_f + + module rrsw_kg27_f + + use parrrsw_f, only : ng27 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 27 +! band 27: 29000-38000 cm-1 (low - o3; high - o3) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +!sfluxrefo: real +! raylo : real +!----------------------------------------------------------------- + + integer , parameter :: no27 = 16 + + real :: kao(5,13,no27) + real :: kbo(5,13:59,no27) + real :: sfluxrefo(no27) + real :: raylo(no27) + + integer :: layreffr + real :: scalekur + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 27 +! band 27: 29000-38000 cm-1 (low - o3; high - o3) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! absa : real +! absb : real +! sfluxref: real +! rayl : real +!----------------------------------------------------------------- + + real :: ka(5,13,ng27), absa(65,ng27) + real :: kb(5,13:59,ng27), absb(235,ng27) + real :: sfluxref(ng27) + real :: rayl(ng27) + + equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg27_f + + module rrsw_kg28_f + + use parrrsw_f, only : ng28 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 28 +! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +!sfluxrefo: real +!----------------------------------------------------------------- + + integer , parameter :: no28 = 16 + + real :: kao(9,5,13,no28) + real :: kbo(5,5,13:59,no28) + real :: sfluxrefo(no28,5) + + integer :: layreffr + real :: rayl, strrat + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 28 +! band 28: 38000-50000 cm-1 (low - o3, o2; high - o3, o2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! sfluxref: real +!----------------------------------------------------------------- + + real :: ka(9,5,13,ng28), absa(585,ng28) + real :: kb(5,5,13:59,ng28), absb(1175,ng28) + real :: sfluxref(ng28,5) + + equivalence (ka(1,1,1,1),absa(1,1)), (kb(1,1,13,1),absb(1,1)) + + end module rrsw_kg28_f + + module rrsw_kg29_f + + use parrrsw_f, only : ng29 + +! implicit none + save + +!----------------------------------------------------------------- +! rrtmg_sw ORIGINAL abs. coefficients for interval 29 +! band 29: 820-2600 cm-1 (low - h2o; high - co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! kao : real +! kbo : real +! selfrefo: real +! forrefo : real +!sfluxrefo: real +! absh2oo : real +! absco2o : real +!----------------------------------------------------------------- + + integer , parameter :: no29 = 16 + + real :: kao(5,13,no29) + real :: kbo(5,13:59,no29) + real :: selfrefo(10,no29), forrefo(4,no29) + real :: sfluxrefo(no29) + real :: absh2oo(no29), absco2o(no29) + + integer :: layreffr + real :: rayl + +!----------------------------------------------------------------- +! rrtmg_sw COMBINED abs. coefficients for interval 29 +! band 29: 820-2600 cm-1 (low - h2o; high - co2) +! +! Initial version: JJMorcrette, ECMWF, oct1999 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!----------------------------------------------------------------- +! +! name type purpose +! ---- : ---- : --------------------------------------------- +! ka : real +! kb : real +! selfref : real +! forref : real +! sfluxref: real +! absh2o : real +! absco2 : real +!----------------------------------------------------------------- + + real :: ka(5,13,ng29), absa(65,ng29) + real :: kb(5,13:59,ng29), absb(235,ng29) + real :: selfref(10,ng29), forref(4,ng29) + real :: sfluxref(ng29) + real :: absh2o(ng29), absco2(ng29) + + equivalence (ka(1,1,1),absa(1,1)), (kb(1,13,1),absb(1,1)) + + end module rrsw_kg29_f + + module rrsw_ref_f + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw reference atmosphere +! Based on standard mid-latitude summer profile +! +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jun2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! pref : real : Reference pressure levels +! preflog: real : Reference pressure levels, ln(pref) +! tref : real : Reference temperature levels for MLS profile +!------------------------------------------------------------------ + + real , dimension(59) :: pref + real , dimension(59) :: preflog + real , dimension(59) :: tref + + end module rrsw_ref_f + + module rrsw_tbl_f + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw lookup table arrays + +! Initial version: MJIacono, AER, may2007 +! Revised: MJIacono, AER, aug2007 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! ntbl : integer: Lookup table dimension +! tblint : real : Lookup table conversion factor +! tau_tbl: real : Clear-sky optical depth +! exp_tbl: real : Exponential lookup table for transmittance +! od_lo : real : Value of tau below which expansion is used +! : in place of lookup table +! pade : real : Pade approximation constant +! bpade : real : Inverse of Pade constant +!------------------------------------------------------------------ + + integer , parameter :: ntbl = 10000 + + real , parameter :: tblint = 10000.0 + + real , parameter :: od_lo = 0.06 + + real :: tau_tbl + real , dimension(0:ntbl) :: exp_tbl + + real , parameter :: pade = 0.278 + real :: bpade + + end module rrsw_tbl_f + + module rrsw_vsn_f + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw version information + +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +!hnamrtm :character: +!hnamini :character: +!hnamcld :character: +!hnamclc :character: +!hnamrft :character: +!hnamspv :character: +!hnamspc :character: +!hnamset :character: +!hnamtau :character: +!hnamvqd :character: +!hnamatm :character: +!hnamutl :character: +!hnamext :character: +!hnamkg :character: +! +! hvrrtm :character: +! hvrini :character: +! hvrcld :character: +! hvrclc :character: +! hvrrft :character: +! hvrspv :character: +! hvrspc :character: +! hvrset :character: +! hvrtau :character: +! hvrvqd :character: +! hvratm :character: +! hvrutl :character: +! hvrext :character: +! hvrkg :character: +!------------------------------------------------------------------ + + character*18 hvrrtm,hvrini,hvrcld,hvrclc,hvrrft,hvrspv, & + hvrspc,hvrset,hvrtau,hvrvqd,hvratm,hvrutl,hvrext + character*20 hnamrtm,hnamini,hnamcld,hnamclc,hnamrft,hnamspv, & + hnamspc,hnamset,hnamtau,hnamvqd,hnamatm,hnamutl,hnamext + + character*18 hvrkg + character*20 hnamkg + + end module rrsw_vsn_f + + module rrsw_wvn_f + + use parrrsw_f, only : nbndsw, mg, ngptsw, jpb1, jpb2 + +! implicit none + save + +!------------------------------------------------------------------ +! rrtmg_sw spectral information + +! Initial version: JJMorcrette, ECMWF, jul1998 +! Revised: MJIacono, AER, jul2006 +! Revised: MJIacono, AER, aug2008 +!------------------------------------------------------------------ + +! name type purpose +! ----- : ---- : ---------------------------------------------- +! ng : integer: Number of original g-intervals in each spectral band +! nspa : integer: +! nspb : integer: +!wavenum1: real : Spectral band lower boundary in wavenumbers +!wavenum2: real : Spectral band upper boundary in wavenumbers +! delwave: real : Spectral band width in wavenumbers +! +! ngc : integer: The number of new g-intervals in each band +! ngs : integer: The cumulative sum of new g-intervals for each band +! ngm : integer: The index of each new g-interval relative to the +! original 16 g-intervals in each band +! ngn : integer: The number of original g-intervals that are +! combined to make each new g-intervals in each band +! ngb : integer: The band index for each new g-interval +! wt : real : RRTM weights for the original 16 g-intervals +! rwgt : real : Weights for combining original 16 g-intervals +! (224 total) into reduced set of g-intervals +! (112 total) +!------------------------------------------------------------------ + + integer :: ng(jpb1:jpb2) + integer :: nspa(jpb1:jpb2) + integer :: nspb(jpb1:jpb2) + + real :: wavenum1(jpb1:jpb2) + real :: wavenum2(jpb1:jpb2) + real :: delwave(jpb1:jpb2) + integer :: icxa(jpb1:jpb2) + + integer :: ngc(nbndsw) + integer :: ngs(nbndsw) + integer :: ngn(ngptsw) + integer :: ngb(ngptsw) + integer :: ngm(nbndsw*mg) + + real :: wt(mg) + real :: rwgt(nbndsw*mg) + + end module rrsw_wvn_f + + + module mcica_subcol_gen_sw_f + + use parrrsw_f, only : nbndsw, ngptsw + use rrsw_con_f, only: grav + use rrsw_wvn_f, only: ngb + use rrsw_vsn_f + + implicit none + + public :: mcica_sw + + contains +!------------------------------------------------------------------------------------------------- + subroutine mcica_sw(ncol, nlay, nsubcol, icld, irng, play, cld, ciwp, clwp, cswp, & + tauc, ssac, asmc, fsfc, cld_stoch, ciwp_stoch, clwp_stoch, cswp_stoch, & + tauc_stoch, ssac_stoch, asmc_stoch, fsfc_stoch, changeSeed ) +!------------------------------------------------------------------------------------------------- + + !---------------------------------------------------------------------------------------------------------------- + ! --------------------- + ! Contact: Cecile Hannay (hannay@ucar.edu) + ! + ! Original code: Based on Raisanen et al., QJRMS, 2004. + ! + ! Modifications: Generalized for use with RRTMG and added Mersenne Twister as the default + ! random number generator, which can be changed to the optional kissvec random number generator + ! with flag 'irng'. Some extra functionality has been commented or removed. + ! Michael J. Iacono, AER, Inc., February 2007 + ! + ! Given a profile of cloud fraction, cloud water and cloud ice, we produce a set of subcolumns. + ! Each layer within each subcolumn is homogeneous, with cloud fraction equal to zero or one + ! and uniform cloud liquid and cloud ice concentration. + ! The ensemble as a whole reproduces the probability function of cloud liquid and ice within each layer + ! and obeys an overlap assumption in the vertical. + ! + ! Overlap assumption: + ! The cloud are consistent with 4 overlap assumptions: random, maximum, maximum-random and exponential. + ! The default option is maximum-random (option 3) + ! The options are: 1=random overlap, 2=max/random, 3=maximum overlap, 4=exponential overlap + ! This is set with the variable "overlap" + !mji - Exponential overlap option (overlap=4) has been deactivated in this version + ! The exponential overlap uses also a length scale, Zo. (real, parameter :: Zo = 2500. ) + ! + ! Seed: + ! If the stochastic cloud generator is called several times during the same timestep, + ! one should change the seed between the call to insure that the subcolumns are different. + ! This is done by changing the argument 'changeSeed' + ! For example, if one wants to create a set of columns for the shortwave and another set for the longwave , + ! use 'changeSeed = 1' for the first call and'changeSeed = 2' for the second call + ! + ! PDF assumption: + ! We can use arbitrary complicated PDFS. + ! In the present version, we produce homogeneuous clouds (the simplest case). + ! Future developments include using the PDF scheme of Ben Johnson. + ! + ! History file: + ! Option to add diagnostics variables in the history file. (using FINCL in the namelist) + ! nsubcol = number of subcolumns + ! overlap = overlap type (1-3) + ! Zo = length scale + ! CLOUD_S = mean of the subcolumn cloud fraction ('_S" means Stochastic) + ! CLDLIQ_S = mean of the subcolumn cloud water + ! CLDICE_S = mean of the subcolumn cloud ice + ! + ! Note: + ! Here: we force that the cloud condensate to be consistent with the cloud fraction + ! i.e we only have cloud condensate when the cell is cloudy. + ! In CAM: The cloud condensate and the cloud fraction are obtained from 2 different equations + ! and the 2 quantities can be inconsistent (i.e. CAM can produce cloud fraction + ! without cloud condensate or the opposite). + !--------------------------------------------------------------------------------------------------------------- + + use mcica_random_numbers_f +! The Mersenne Twister random number engine + !use MersenneTwister, only: randomNumberSequence, & + ! new_RandomNumberSequence, getRandomReal + + !type(randomNumberSequence) :: randomNumbers + +! -- Arguments + + integer , intent(in) :: ncol ! number of layers + integer , intent(in) :: nlay ! number of layers + integer , intent(in) :: icld ! clear/cloud, cloud overlap flag + integer , intent(inout) :: irng ! flag for random number generator + ! 0 = kissvec + ! 1 = Mersenne Twister + integer , intent(in) :: nsubcol ! number of sub-columns (g-point intervals) + integer , optional, intent(in) :: changeSeed ! allows permuting seed + +! Column state (cloud fraction, cloud water, cloud ice) + variables needed to read physics state + real , intent(in) :: play(:,:) ! layer pressure (Pa) + ! Dimensions: (ncol,nlay) + real , intent(in) :: cld(:,:) ! cloud fraction + ! Dimensions: (ncol,nlay) + real , intent(in) :: clwp(:,:) ! in-cloud liquid water path (g/m2) + ! Dimensions: (ncol,nlay) + real , intent(in) :: ciwp(:,:) ! in-cloud ice water path (g/m2) + ! Dimensions: (ncol,nlay) + real , intent(in) :: cswp(:,:) ! in-cloud snow water path (g/m2) + ! Dimensions: (ncol,nlay) + real , intent(in) :: tauc(:,:,:) ! in-cloud optical depth (non-delta scaled) + ! Dimensions: (ncol,nlay,nbndsw) + real , intent(in) :: ssac(:,:,:) ! in-cloud single scattering albedo (non-delta scaled) + ! Dimensions: (ncol,nlay,nbndsw) + real , intent(in) :: asmc(:,:,:) ! in-cloud asymmetry parameter (non-delta scaled) + ! Dimensions: (ncol,nlay,nbndsw) + real , intent(in) :: fsfc(:,:,:) ! in-cloud forward scattering fraction (non-delta scaled) + ! Dimensions: (ncol,nlay,nbndsw) + + real , intent(out) :: cld_stoch(:,:,:) ! subcolumn cloud fraction + ! Dimensions: (ngptsw,ncol,nlay) + real , intent(out) :: clwp_stoch(:,:,:) ! subcolumn in-cloud liquid water path + ! Dimensions: (ngptsw,ncol,nlay) + real , intent(out) :: ciwp_stoch(:,:,:) ! subcolumn in-cloud ice water path + ! Dimensions: (ngptsw,ncol,nlay) + real , intent(out) :: cswp_stoch(:,:,:) ! subcolumn in-cloud snow water path + ! Dimensions: (ngptsw,ncol,nlay) + real , intent(out) :: tauc_stoch(:,:,:) ! subcolumn in-cloud optical depth + ! Dimensions: (ncol,nlay,ngptsw) + real , intent(out) :: ssac_stoch(:,:,:) ! subcolumn in-cloud single scattering albedo + ! Dimensions: (ncol,nlay,ngptsw) + real , intent(out) :: asmc_stoch(:,:,:) ! subcolumn in-cloud asymmetry parameter + ! Dimensions: (ncol,nlay,ngptsw) + real , intent(out) :: fsfc_stoch(:,:,:) ! subcolumn in-cloud forward scattering fraction + ! Dimensions: (ncol,nlay,ngptsw) + +! -- Local variables + +! Constants (min value for cloud fraction and cloud water and ice) + real , parameter :: cldmin = 1.0e-20 ! min cloud fraction + +#ifndef _ACCEL +# define ncol CHNK +#endif + +! Variables related to random number and seed + + real, dimension(ncol, nlay, nsubcol) gpu_device :: CDF +#ifdef _ACCEL + integer :: seed1, seed2, seed3, seed4 ! seed to create random number +#else + integer, dimension(ncol) :: seed1, seed2, seed3, seed4 ! seed to create random number +#endif + + integer :: iseed ! seed to create random number (Mersenne Twister) +! real :: rand_num_mt ! random number (Mersenne Twister) + real :: kiss + + +! Indices + integer :: ilev, isubcol, i, n, ngbm, iplon ! indices +#ifndef _ACCEL + integer :: m, k +! inline function + m(k, n) = ieor (k, ishft (k, n) ) +#endif +!------------------------------------------------------------------------------------------ + +! Check that irng is in bounds; if not, set to default +! Note: in GPU version of code, only kissvec method is used, Mersenne Twister not installed + +! Pass input cloud overlap setting to local variable + + +! ------ Apply overlap assumption -------- + +! generate the random numbers + +! Random cloud overlap + if (icld==1) then +!$acc kernels + +#ifdef _ACCEL + do ilev = 1,nlay + do i = 1, ncol + seed1 = (play(i,1) - int(play(i,1))) * 100000000 - ilev + seed2 = (play(i,2) - int(play(i,2))) * 100000000 + ilev + seed3 = (play(i,3) - int(play(i,3))) * 100000000 + ilev * 6.2 + seed4 = (play(i,4) - int(play(i,4))) * 100000000 + do isubcol = 1,nsubcol + seed1 = 69069 * seed1 + 132721785 + seed2 = 11002 * iand (seed2, 65535 ) + ishft (seed2, - 16 ) + seed3 = 18000 * iand (seed3, 65535 ) + ishft (seed3, - 16 ) + seed4 = 30903 * iand (seed4, 65535 ) + ishft (seed4, - 16 ) + kiss = seed1 + seed2 + ishft (seed3, 16 ) + seed4 + CDF(i,ilev,isubcol) = kiss*2.328306e-10 + 0.5 + end do + end do + end do +#else + CALL wrf_error_fatal("icld == 1 not supported in module_ra_rrtmg_swf.F") +#endif + +!$acc end kernels + endif + +! Maximum-Random cloud overlap + if (icld==2) then +#ifdef _ACCEL +!$acc kernels + + do ilev = 1,nlay + do i = 1, ncol + seed1 = (play(i,1) - int(play(i,1))) * 100000000 - ilev + seed2 = (play(i,2) - int(play(i,2))) * 100000000 + ilev + seed3 = (play(i,3) - int(play(i,3))) * 100000000 + ilev * 6.2 + seed4 = (play(i,4) - int(play(i,4))) * 100000000 + do isubcol = 1,nsubcol + seed1 = 69069 * seed1 + 132721785 + seed2 = 11002 * iand (seed2, 65535 ) + ishft (seed2, - 16 ) + seed3 = 18000 * iand (seed3, 65535 ) + ishft (seed3, - 16 ) + seed4 = 30903 * iand (seed4, 65535 ) + ishft (seed4, - 16 ) + kiss = seed1 + seed2 + ishft (seed3, 16 ) + seed4 + CDF(i,ilev,isubcol) = kiss*2.328306e-10 + 0.5 + end do + end do + end do + + do ilev = 2,nlay + do i = 1, ncol + do isubcol = 1,nsubcol + if (CDF(i,ilev-1,isubcol) > 1. - cld(i, ilev-1)) then + CDF(i,ilev,isubcol) = CDF(i,ilev-1,isubcol) + else + CDF(i,ilev,isubcol) = CDF(i,ilev,isubcol) * (1. - cld(i, ilev-1)) + end if + end do + end do + end do + +!$acc end kernels +#else +!jm set up to match the ra_sw_physics=4 random number generator ' + +!jm moved isubcol loop out of here and put in the ilev.eq.1 conditional for initial +!jm computation of seeds so we get the same results as the ra_sw_physics=4 option + do isubcol = 1,nsubcol + do ilev = 1,nlay + do i = 1, ncol + if (ilev.eq.1.and.isubcol.eq.1)then + seed1(i) = (play(i,1)*100 - int(play(i,1)*100)) * 1000000000 !jm + seed2(i) = (play(i,2)*100 - int(play(i,2)*100)) * 1000000000 !jm + seed3(i) = (play(i,3)*100 - int(play(i,3)*100)) * 1000000000 !jm + seed4(i) = (play(i,4)*100 - int(play(i,4)*100)) * 1000000000 + seed1(i) = 69069 * seed1(i) + 1327217885 + seed2(i) = m (m (m (seed2(i), 13), - 17), 5) + seed3(i) = 18000 * iand (seed3(i), 65535 ) + ishft (seed3(i), - 16 ) + seed4(i) = 30903 * iand (seed4(i), 65535 ) + ishft (seed4(i), - 16 ) + kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16 ) + seed4(i) + endif + + seed1(i) = 69069 * seed1(i) + 1327217885 + seed2(i) = m (m (m (seed2(i), 13), - 17), 5) + seed3(i) = 18000 * iand (seed3(i), 65535 ) + ishft (seed3(i), - 16 ) + seed4(i) = 30903 * iand (seed4(i), 65535 ) + ishft (seed4(i), - 16 ) + kiss = seed1(i) + seed2(i) + ishft (seed3(i), 16 ) + seed4(i) + + CDF(i,ilev,isubcol) = kiss*2.328306e-10 + 0.5 + end do + end do + end do + + do ilev = 2,nlay + do i = 1, ncol + do isubcol = 1,nsubcol + if (CDF(i,ilev-1,isubcol) > 1. - cld(i, ilev-1)) then + CDF(i,ilev,isubcol) = CDF(i,ilev-1,isubcol) + else + CDF(i,ilev,isubcol) = CDF(i,ilev,isubcol) * (1. - cld(i, ilev-1)) + end if + end do + end do + end do +#endif + endif + +! Maximum cloud overlap + if (icld==3) then +!$acc kernels + +#ifdef _ACCEL + do i = 1, ncol + seed1 = (play(i,1) - int(play(i,1))) * 100000000 - ilev + seed2 = (play(i,2) - int(play(i,2))) * 100000000 + ilev + seed3 = (play(i,3) - int(play(i,3))) * 100000000 + ilev * 6.2 + seed4 = (play(i,4) - int(play(i,4))) * 100000000 + do isubcol = 1,nsubcol + seed1 = 69069 * seed1 + 132721785 + seed2 = 11002 * iand (seed2, 65535 ) + ishft (seed2, - 16 ) + seed3 = 18000 * iand (seed3, 65535 ) + ishft (seed3, - 16 ) + seed4 = 30903 * iand (seed4, 65535 ) + ishft (seed4, - 16 ) + kiss = seed1 + seed2 + ishft (seed3, 16 ) + seed4 + do ilev = 1,nlay + CDF(i,ilev,isubcol) = kiss*2.328306e-10 + 0.5 + end do + end do + end do +#else + CALL wrf_error_fatal("icld == 3 not supported in module_ra_rrtmg_swf.F") +#endif + +!$acc end kernels + endif + + ngbm = ngb(1) - 1 +!$acc kernels + do ilev = 1,nlay + do i = 1, ncol + do isubcol = 1, nsubcol + + if ( CDF(i,ilev,isubcol)>=(1.0 - cld(i,ilev)) ) then + cld_stoch(i,ilev,isubcol) = 1.0 + clwp_stoch(i,ilev,isubcol) = clwp(i,ilev) + ciwp_stoch(i,ilev,isubcol) = ciwp(i,ilev) + cswp_stoch(i,ilev,isubcol) = cswp(i,ilev) + n = ngb(isubcol) - ngbm + tauc_stoch(i,ilev,isubcol) = tauc(i,ilev,n) + ssac_stoch(i,ilev,isubcol) = ssac(i,ilev,n) + asmc_stoch(i,ilev,isubcol) = asmc(i,ilev,n) + fsfc_stoch(i,ilev,isubcol) = fsfc(i,ilev,n) + else + cld_stoch(i,ilev,isubcol) = 0. + clwp_stoch(i,ilev,isubcol) = 0. + ciwp_stoch(i,ilev,isubcol) = 0. + cswp_stoch(i,ilev,isubcol) = 0. + tauc_stoch(i,ilev,isubcol) = 0. + ssac_stoch(i,ilev,isubcol) = 1. + asmc_stoch(i,ilev,isubcol) = 0. + fsfc_stoch(i,ilev,isubcol) = 0. + endif + enddo + enddo + enddo +!$acc end kernels +#ifndef _ACCEL +# undef ncol +#endif + + end subroutine mcica_sw + + end module mcica_subcol_gen_sw_f + + module rrtmg_sw_cldprmc_f + +! ------- Modules ------- + + use parrrsw_f, only : ngptsw, jpband, jpb1, jpb2 + use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, & + extice2, ssaice2, asyice2, & + extice3, ssaice3, asyice3, fdlice3, & + abari, bbari, cbari, dbari, ebari, fbari + use rrsw_wvn_f, only : wavenum2, ngb, icxa + use rrsw_vsn_f, only : hvrclc, hnamclc + + implicit none + + contains + +! ---------------------------------------------------------------------------- + subroutine cldprmc_sw(ncol, nlayers, inflag, iceflag, liqflag, cldfmc, & + ciwpmc, clwpmc, cswpmc, reicmc, relqmc, resnmc, & + taormc, taucmc, ssacmc, asmcmc, fsfcmc) +! ---------------------------------------------------------------------------- + +! Purpose: Compute the cloud optical properties for each cloudy layer +! and g-point interval for use by the McICA method. +! Note: Only inflag = 0 and inflag=2/liqflag=1/iceflag=1,2,3 are available; +! (Hu & Stamnes, Ebert and Curry, Key, and Fu) are implemented. + +! ------- Input ------- + + integer , intent(in) :: nlayers ! total number of layers + integer , intent(in) :: inflag ! see definitions + integer , intent(in) :: iceflag ! see definitions + integer , intent(in) :: liqflag ! see definitions + integer , intent(in) :: ncol + + real , intent(in) :: cldfmc(:,:,:) ! cloud fraction [mcica] + ! Dimensions: (ngptsw,nlayers) + real , intent(in) :: ciwpmc(:,:,:) ! cloud ice water path [mcica] + ! Dimensions: (ngptsw,nlayers) + real , intent(in) :: clwpmc(:,:,:) ! cloud liquid water path [mcica] + ! Dimensions: (ngptsw,nlayers) + real , intent(in) :: cswpmc(:,:,:) ! cloud snow water path [mcica] + ! Dimensions: (ngptsw,nlayers) + real , intent(in) :: relqmc(:,:) ! cloud liquid particle effective radius (microns) + ! Dimensions: (nlayers) + real , intent(in) :: resnmc(:,:) ! cloud snow particle effective radius (microns) + ! Dimensions: (nlayers) + real , intent(in) :: reicmc(:,:) ! cloud ice particle effective radius (microns) + ! Dimensions: (nlayers) + ! specific definition of reicmc depends on setting of iceflag: + ! iceflag = 0: (inactive) + ! + ! iceflag = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflag = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflag = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + real , intent(in) :: fsfcmc(:,:,:) ! cloud forward scattering fraction + ! Dimensions: (ngptsw,nlayers) + +! ------- Output ------- + + real , intent(inout) :: taucmc(:,:,:) ! cloud optical depth (delta scaled) + ! Dimensions: (ncol,nlayers,ngptsw) + real , intent(inout) :: ssacmc(:,:,:) ! single scattering albedo (delta scaled) + ! Dimensions: (ncol,nlayers,ngptsw) + real , intent(inout) :: asmcmc(:,:,:) ! asymmetry parameter (delta scaled) + ! Dimensions: (ncol,nlayers,ngptsw) + real , intent(out) :: taormc(:,:,:) ! cloud optical depth (non-delta scaled) + ! Dimensions: (ncol,nlayers,ngptsw) + +! ------- Local ------- + +! integer :: ncbands + integer :: ib, lay, istr, index, icx, ig, iplon + + real , parameter :: eps = 1.e-06 ! epsilon + real , parameter :: cldmin = 1.e-20 ! minimum value for cloud quantities + real :: cwp ! total cloud water path + real :: radliq ! cloud liquid droplet radius (microns) + real :: radice ! cloud ice effective size (microns) + real :: radsno ! cloud snow effective size (microns) + real :: factor + real :: fint + + real :: taucldorig_a, taucloud_a, ssacloud_a, ffp, ffp1, ffpssa + real :: tauiceorig, scatice, ssaice, tauice, tauliqorig, scatliq, ssaliq, tauliq + real :: tausnoorig, scatsno, ssasno, tausno + + real :: fdelta + real :: extcoice, gice + real :: ssacoice, forwice + real :: extcoliq, gliq + real :: ssacoliq, forwliq + real :: extcosno, gsno + real :: ssacosno, forwsno + +! Initialize + + +!$acc kernels + + taormc = taucmc + +!$acc end kernels + +#ifndef _ACCEL +# define ncol CHNK +#endif + +! Main layer loop + +!$acc kernels loop present(cldfmc, ciwpmc, clwpmc, cswpmc, relqmc, reicmc, resnmc, fsfcmc,taucmc, ssacmc, asmcmc, taormc) + do iplon = 1, ncol + !$acc loop + do lay = 1, nlayers + + !$acc loop private(fdelta,extcoice,gice,ssacoice,forwice,extcoliq,gliq,ssacoliq,forwliq,gsno,forwsno,scatsno) + do ig = 1, ngptsw + cwp = ciwpmc(iplon,lay,ig) + clwpmc(iplon,lay,ig) + cswpmc(iplon,lay,ig) + + if (cldfmc(iplon,lay,ig) .ge. cldmin .and. & + (cwp .ge. cldmin .or. taucmc(iplon,lay,ig) .ge. cldmin)) then + +! (inflag=0): Cloud optical properties input directly + if (inflag .eq. 0) then +! Cloud optical properties already defined in taucmc, ssacmc, asmcmc are unscaled; +! Apply delta-M scaling here (using Henyey-Greenstein approximation) + taucldorig_a = taucmc(iplon,lay,ig) + ffp = fsfcmc(iplon,lay,ig) + ffp1 = 1.0 - ffp + ffpssa = 1.0 - ffp * ssacmc(iplon,lay,ig) + ssacloud_a = ffp1 * ssacmc(iplon,lay,ig) / ffpssa + taucloud_a = ffpssa * taucldorig_a + + taormc(iplon,lay,ig) = taucldorig_a + ssacmc(iplon,lay,ig) = ssacloud_a + taucmc(iplon,lay,ig) = taucloud_a + asmcmc(iplon,lay,ig) = (asmcmc(iplon,lay,ig) - ffp) / (ffp1) + +! (inflag=2): Separate treatement of ice clouds and water clouds. + elseif (inflag .ge. 2) then + radice = reicmc(iplon,lay) + +! Calculation of absorption coefficients due to ice clouds. + if (ciwpmc(iplon,lay,ig) + cswpmc(iplon,lay,ig) .eq. 0.0 ) then + extcoice = 0.0 + ssacoice = 0.0 + gice = 0.0 + forwice = 0.0 + + extcosno = 0.0 + ssacosno = 0.0 + gsno = 0.0 + forwsno = 0.0 + +! (iceflag = 1): +! Note: This option uses Ebert and Curry approach for all particle sizes similar to +! CAM3 implementation, though this is somewhat unjustified for large ice particles + elseif (iceflag .eq. 1) then + + ib = ngb(ig ) + ib = icxa(ib) + + extcoice = (abari(ib) + bbari(ib)/radice) + ssacoice = 1. - cbari(ib) - dbari(ib) * radice + gice = ebari(ib) + fbari(ib) * radice +! Check to ensure upper limit of gice is within physical limits for large particles + if (gice.ge.1. ) gice = 1. - eps + forwice = gice*gice +! Check to ensure all calculated quantities are within physical limits. +! mji - added checks below + if (extcoice .lt. 0.0) extcoice = 0.0 + if (ssacoice .gt. 1.0) ssacoice = 1.0 + if (ssacoice .lt. 0.0) ssacoice = 0.0 + if (gice .gt. 1.0) gice = 1.0 + if (gice .lt. 0.0) gice = 0.0 + + +! For iceflag=2 option, ice particle effective radius is limited to 5.0 to 131.0 microns + + elseif (iceflag .eq. 2) then + + factor = (radice - 2. )/3. + index = int(factor) +! mji - temporary fix to prevent out of range subscripts + if (index .le. 0) index = 1 + if (index .ge. 43) index = 42 +! if (index .eq. 43) index = 42 + fint = factor - float(index) + ib = ngb(ig) + extcoice = extice2(index,ib) + fint * & + (extice2(index+1,ib) - extice2(index,ib)) + ssacoice = ssaice2(index,ib) + fint * & + (ssaice2(index+1,ib) - ssaice2(index,ib)) + gice = asyice2(index,ib) + fint * & + (asyice2(index+1,ib) - asyice2(index,ib)) + forwice = gice*gice +! Check to ensure all calculated quantities are within physical limits. +! mji - added checks below + if (extcoice .lt. 0.0) extcoice = 0.0 + if (ssacoice .gt. 1.0) ssacoice = 1.0 + if (ssacoice .lt. 0.0) ssacoice = 0.0 + if (gice .gt. 1.0) gice = 1.0 + if (gice .lt. 0.0) gice = 0.0 + + +! For iceflag=3 option, ice particle generalized effective size is limited to 5.0 to 140.0 microns + + elseif (iceflag .ge. 3) then + + factor = (radice - 2. )/3. + index = int(factor) +! mji - temporary fix to prevent out of range subscripts + if (index .le. 0) index = 1 + if (index .ge. 46) index = 45 +! if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) + extcoice = extice3(index,ib) + fint * & + (extice3(index+1,ib) - extice3(index,ib)) + ssacoice = ssaice3(index,ib) + fint * & + (ssaice3(index+1,ib) - ssaice3(index,ib)) + gice = asyice3(index,ib) + fint * & + (asyice3(index+1,ib) - asyice3(index,ib)) + fdelta = fdlice3(index,ib) + fint * & + (fdlice3(index+1,ib) - fdlice3(index,ib)) + + forwice = fdelta + 0.5 / ssacoice +! See Fu 1996 p. 2067 + if (forwice .gt. gice) forwice = gice +! Check to ensure all calculated quantities are within physical limits. +! mji - added checks below + if (extcoice .lt. 0.0) extcoice = 0.0 + if (ssacoice .gt. 1.0) ssacoice = 1.0 + if (ssacoice .lt. 0.0) ssacoice = 0.0 + if (gice .gt. 1.0) gice = 1.0 + if (gice .lt. 0.0) gice = 0.0 + + endif + +!!!!!!!!!!!!!!!!!! Mukul !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! INSERT THE EQUIVALENT SNOW VARIABLE CODE HERE +!!!! Although far from perfect, the snow will utilize the +!!!! same lookup table constants as cloud ice. Changes +!!!! to those constants for larger particle snow would be +!!!! an improvement. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + if (cswpmc(iplon,lay,ig).gt.0.0 .and. iceflag .eq. 5) then + radsno = resnmc(iplon,lay) + factor = (radsno - 2.)/3. + index = int(factor) +! mji - temporary fix to prevent out of range subscripts + if (index .le. 0) index = 1 + if (index .ge. 46) index = 45 +! if (index .eq. 46) index = 45 + fint = factor - float(index) + ib = ngb(ig) + extcosno = extice3(index,ib) + fint * & + (extice3(index+1,ib) - extice3(index,ib)) + ssacosno = ssaice3(index,ib) + fint * & + (ssaice3(index+1,ib) - ssaice3(index,ib)) + gsno = asyice3(index,ib) + fint * & + (asyice3(index+1,ib) - asyice3(index,ib)) + fdelta = fdlice3(index,ib) + fint * & + (fdlice3(index+1,ib) - fdlice3(index,ib)) + forwsno = fdelta + 0.5 / ssacosno +! See Fu 1996 p. 2067 + if (forwsno .gt. gsno) forwsno = gsno +! Check to ensure all calculated quantities are within physical limits. +! mji - added checks below + if (extcosno .lt. 0.0) extcosno = 0.0 + if (ssacosno .gt. 1.0) ssacosno = 1.0 + if (ssacosno .lt. 0.0) ssacosno = 0.0 + if (gsno .gt. 1.0) gsno = 1.0 + if (gsno .lt. 0.0) gsno = 0.0 +! + else + extcosno = 0.0 + ssacosno = 0.0 + gsno = 0.0 + forwsno = 0.0 + endif + +! Calculation of absorption coefficients due to water clouds. + if (clwpmc(iplon,lay,ig) .eq. 0.0 ) then + extcoliq = 0.0 + ssacoliq = 0.0 + gliq = 0.0 + forwliq = 0.0 + + elseif (liqflag .eq. 1) then + radliq = relqmc(iplon,lay) + + index = int(radliq - 1.5 ) +! mji - temporary fix to prevent out of range subscripts + if (index .le. 0) index = 1 + if (index .ge. 58) index = 57 +! if (index .eq. 0) index = 1 +! if (index .eq. 58) index = 57 + fint = radliq - 1.5 - float(index) + ib = ngb(ig) + extcoliq = extliq1(index,ib) + fint * & + (extliq1(index+1,ib) - extliq1(index,ib)) + ssacoliq = ssaliq1(index,ib) + fint * & + (ssaliq1(index+1,ib) - ssaliq1(index,ib)) + if (fint .lt. 0. .and. ssacoliq .gt. 1. ) & + ssacoliq = ssaliq1(index,ib) + gliq = asyliq1(index,ib) + fint * & + (asyliq1(index+1,ib) - asyliq1(index,ib)) + forwliq = gliq*gliq +! Check to ensure all calculated quantities are within physical limits. +! mji - added checks below + if (extcoliq .lt. 0.0) extcoliq = 0.0 + if (ssacoliq .gt. 1.0) ssacoliq = 1.0 + if (ssacoliq .lt. 0.0) ssacoliq = 0.0 + if (gliq .gt. 1.0) gliq = 1.0 + if (gliq .lt. 0.0) gliq = 0.0 +! + endif + + if (iceflag .lt. 5) then + tauliqorig = clwpmc(iplon,lay,ig) * extcoliq + tauiceorig = ciwpmc(iplon,lay,ig) * extcoice + taormc(iplon,lay,ig) = tauliqorig + tauiceorig + + ssaliq = ssacoliq * (1. - forwliq) / & + (1. - forwliq * ssacoliq) + tauliq = (1. - forwliq * ssacoliq) * tauliqorig + ssaice = ssacoice * (1. - forwice) / & + (1. - forwice * ssacoice) + tauice = (1. - forwice * ssacoice) * tauiceorig + + scatliq = ssaliq * tauliq + scatice = ssaice * tauice + taucmc(iplon,lay,ig) = tauliq + tauice + else + tauliqorig = clwpmc(iplon,lay,ig) * extcoliq + tauiceorig = ciwpmc(iplon,lay,ig) * extcoice + tausnoorig = cswpmc(iplon,lay,ig) * extcosno + taormc(iplon,lay,ig) = tauliqorig + tauiceorig + tausnoorig + + ssaliq = ssacoliq * (1. - forwliq) / & + (1. - forwliq * ssacoliq) + tauliq = (1. - forwliq * ssacoliq) * tauliqorig + ssaice = ssacoice * (1. - forwice) / & + (1. - forwice * ssacoice) + tauice = (1. - forwice * ssacoice) * tauiceorig + ssasno = ssacosno * (1. - forwsno) / & + (1. - forwsno * ssacosno) + tausno = (1. - forwsno * ssacosno) * tausnoorig + + scatliq = ssaliq * tauliq + scatice = ssaice * tauice + scatsno = ssasno * tausno + taucmc(iplon,lay,ig) = tauliq + tauice + tausno + endif + +! Ensure non-zero taucmc and scatice + if(taucmc(iplon,lay,ig) .eq.0.) taucmc(iplon,lay,ig) = cldmin + if(scatice.eq.0.) scatice = cldmin + if(scatsno.eq.0.) scatsno = cldmin + + if (iceflag .lt. 5) then + ssacmc(iplon,lay,ig) = (scatliq + scatice) / taucmc(iplon,lay,ig) + else + ssacmc(iplon,lay,ig) = (scatliq + scatice + scatsno) / taucmc(iplon,lay,ig) + endif + + if (iceflag .eq. 3 .or. iceflag.eq.4) then +! In accordance with the 1996 Fu paper, equation A.3, +! the moments for ice were calculated depending on whether using spheres +! or hexagonal ice crystals. +! Set asymetry parameter to first moment (istr=1) + istr = 1 + asmcmc(iplon,lay,ig) = (1.0 /(scatliq+scatice))* & + (scatliq*(gliq**istr - forwliq) / & + (1.0 - forwliq) + scatice * ((gice-forwice)/ & + (1.0 - forwice))**istr) + + elseif (iceflag .eq. 5) then + istr = 1 + asmcmc(iplon,lay,ig) = (1.0 /(scatliq+scatice+scatsno)) * & + (scatliq*(gliq**istr - forwliq)/(1.0 - forwliq) & + + scatice * ((gice-forwice)/(1.0 - forwice)) & + + scatsno * ((gsno-forwsno)/(1.0 - forwsno))**istr) + + else +! This code is the standard method for delta-m scaling. +! Set asymetry parameter to first moment (istr=1) + istr = 1 + asmcmc(iplon,lay,ig) = (scatliq * & + (gliq**istr - forwliq) / & + (1.0 - forwliq) + scatice * (gice**istr - forwice) / & + (1.0 - forwice))/(scatliq + scatice) + endif + + endif + + endif + +! End g-point interval loop + enddo + +! End layer loop + enddo +! End column loop + enddo +!$acc end kernels +#ifndef _ACCEL +# undef ncol +#endif + + end subroutine cldprmc_sw + + end module rrtmg_sw_cldprmc_f + + module rrtmg_sw_setcoef_f + +! ------- Modules ------- + + use parrrsw_f, only : mxmol + use rrsw_ref_f, only : pref, preflog, tref + use rrsw_vsn_f, only : hvrset, hnamset + + implicit none + + contains + +!---------------------------------------------------------------------------- + subroutine setcoef_sw(ncol, nlayers, pavel, tavel, pz, tz, tbound, coldry, wkl, & + laytrop, layswtch, laylow, jp, jt, jt1, & + co2mult, colch4, colco2, colh2o, colmol, coln2o, & + colo2, colo3, fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor) +!---------------------------------------------------------------------------- +! +! Purpose: For a given atmosphere, calculate the indices and +! fractions related to the pressure and temperature interpolations. + +! Modifications: +! Original: J. Delamere, AER, Inc. (version 2.5, 02/04/01) +! Revised: Rewritten and adapted to ECMWF F90, JJMorcrette 030224 +! Revised: For uniform rrtmg formatting, MJIacono, Jul 2006 + +! ------ Declarations ------- + +! ----- Input ----- + integer, intent(in) :: ncol + + integer , intent(in) :: nlayers ! total number of layers + + real , intent(in) :: pavel(:,:) ! layer pressures (mb) + ! Dimensions: (nlayers) + real , intent(in) :: tavel(:,:) ! layer temperatures (K) + ! Dimensions: (nlayers) + real , intent(in) :: pz(:,0:) ! level (interface) pressures (hPa, mb) + ! Dimensions: (0:nlayers) + real , intent(in) :: tz(:,0:) ! level (interface) temperatures (K) + ! Dimensions: (0:nlayers) + real , intent(in) :: tbound(:) ! surface temperature (K) + real , intent(in) :: coldry(:,:) ! dry air column density (mol/cm2) + ! Dimensions: (nlayers) + real , intent(in) :: wkl(:,:,:) ! molecular amounts (mol/cm-2) + ! Dimensions: (mxmol,nlayers) + +! ----- Output ----- + integer , intent(out) :: laytrop(:) ! tropopause layer index + integer , intent(out) :: layswtch(:) ! + integer , intent(out) :: laylow(:) ! + + integer , intent(out) :: jp(:,:) ! + ! Dimensions: (nlayers) + integer , intent(out) :: jt(:,:) ! + ! Dimensions: (nlayers) + integer , intent(out) :: jt1(:,:) ! + ! Dimensions: (nlayers) + + real , intent(out) :: colh2o(:,:) ! column amount (h2o) + ! Dimensions: (nlayers) + real , intent(out) :: colco2(:,:) ! column amount (co2) + ! Dimensions: (nlayers) + real , intent(out) :: colo3(:,:) ! column amount (o3) + ! Dimensions: (nlayers) + real , intent(out) :: coln2o(:,:) ! column amount (n2o) + ! Dimensions: (nlayers) + real , intent(out) :: colch4(:,:) ! column amount (ch4) + ! Dimensions: (nlayers) + real , intent(out) :: colo2(:,:) ! column amount (o2) + ! Dimensions: (nlayers) + real , intent(out) :: colmol(:,:) ! + ! Dimensions: (nlayers) + real , intent(out) :: co2mult(:,:) ! + ! Dimensions: (nlayers) + + integer , intent(out) :: indself(:,:) + ! Dimensions: (nlayers) + integer , intent(out) :: indfor(:,:) + ! Dimensions: (nlayers) + real , intent(out) :: selffac(:,:) + ! Dimensions: (nlayers) + real , intent(out) :: selffrac(:,:) + ! Dimensions: (nlayers) + real , intent(out) :: forfac(:,:) + ! Dimensions: (nlayers) + real , intent(out) :: forfrac(:,:) + ! Dimensions: (nlayers) + + real , intent(out) :: fac00(:,:) , fac01(:,:) , fac10(:,:) , fac11(:,:) + +! ----- Local ----- + + integer :: indbound + integer :: indlev0 + integer :: lay + integer :: jp1 + integer :: iplon + + real :: stpfac + real :: tbndfrac + real :: t0frac + real :: plog + real :: fp + real :: ft + real :: ft1 + real :: water + real :: scalefac + real :: factor + real :: co2reg + real :: compfp + +#ifndef _ACCEL +# define ncol CHNK +#endif + + +! Initializations + stpfac = 296. /1013. + + +!$acc kernels present(pavel, layswtch, laytrop, laylow) + layswtch = 0 + laytrop = 0 + laylow = 0 + do iplon = 1, ncol + do lay = 1, nlayers + plog = log(pavel(iplon,lay) ) + if (plog .ge. 4.56) laytrop(iplon) = laytrop(iplon) + 1 + if (plog .ge. 6.62) laylow(iplon) = laylow(iplon) + 1 + end do + end do +!$acc end kernels + + +!$acc kernels loop present(pavel, tavel, pz, tz, tbound) & +!$acc present(coldry, wkl, jp, jt, jt1, colh2o, colco2) & +!$acc present(colo3, coln2o, colch4, colo2, colmol, co2mult, indself) & +!$acc present(indfor, selffac, selffrac, forfac, forfrac, fac00, fac01, fac10, fac11) + +! Begin column loop + do iplon = 1, ncol + + indbound = tbound(iplon) - 159. + tbndfrac = tbound(iplon) - int(tbound(iplon)) + + indlev0 = tz(iplon,0) - 159. + t0frac = tz(iplon,0) - int(tz(iplon,0) ) + +! Begin layer loop + + do lay = 1, nlayers +! Find the two reference pressures on either side of the +! layer pressure. Store them in JP and JP1. Store in FP the +! fraction of the difference (in ln(pressure)) between these +! two values that the layer pressure lies. + + plog = log(pavel(iplon,lay) ) + jp(iplon,lay) = int(36. - 5*(plog+0.04 )) + if (jp(iplon,lay) .lt. 1) then + jp(iplon,lay) = 1 + elseif (jp(iplon,lay) .gt. 58) then + jp(iplon,lay) = 58 + endif + jp1 = jp(iplon,lay) + 1 + fp = 5. * (preflog(jp(iplon,lay) ) - plog) + +! Determine, for each reference pressure (JP and JP1), which +! reference temperature (these are different for each +! reference pressure) is nearest the layer temperature but does +! not exceed it. Store these indices in JT and JT1, resp. +! Store in FT (resp. FT1) the fraction of the way between JT +! (JT1) and the next highest reference temperature that the +! layer temperature falls. + + jt(iplon,lay) = int(3. + (tavel(iplon,lay) -tref(jp(iplon,lay) ))/15. ) + if (jt(iplon,lay) .lt. 1) then + jt(iplon,lay) = 1 + elseif (jt(iplon,lay) .gt. 4) then + jt(iplon,lay) = 4 + endif + ft = ((tavel(iplon,lay) -tref(jp(iplon,lay) ))/15. ) - float(jt(iplon,lay) -3) + jt1(iplon,lay) = int(3. + (tavel(iplon,lay) -tref(jp1))/15. ) + if (jt1(iplon,lay) .lt. 1) then + jt1(iplon,lay) = 1 + elseif (jt1(iplon,lay) .gt. 4) then + jt1(iplon,lay) = 4 + endif + ft1 = ((tavel(iplon,lay) -tref(jp1))/15. ) - float(jt1(iplon,lay) -3) + + water = wkl(iplon,1,lay) /coldry(iplon,lay) + scalefac = pavel(iplon,lay) * stpfac / tavel(iplon,lay) + +! If the pressure is less than ~100mb, perform a different +! set of species interpolations. + + if (plog .le. 4.56 ) then + + forfac(iplon,lay) = scalefac / (1.+water) + factor = (tavel(iplon,lay) -188.0 )/36.0 + indfor(iplon,lay) = 3 + forfrac(iplon,lay) = factor - 1.0 + +! Calculate needed column amounts. + + colh2o(iplon,lay) = 1.e-20 * wkl(iplon,1,lay) + colco2(iplon,lay) = 1.e-20 * wkl(iplon,2,lay) + colo3(iplon,lay) = 1.e-20 * wkl(iplon,3,lay) + coln2o(iplon,lay) = 1.e-20 * wkl(iplon,4,lay) + colch4(iplon,lay) = 1.e-20 * wkl(iplon,6,lay) + colo2(iplon,lay) = 1.e-20 * wkl(iplon,7,lay) + colmol(iplon,lay) = 1.e-20 * coldry(iplon,lay) + colh2o(iplon,lay) + if (colco2(iplon,lay) .eq. 0. ) colco2(iplon,lay) = 1.e-32 * coldry(iplon,lay) + if (coln2o(iplon,lay) .eq. 0. ) coln2o(iplon,lay) = 1.e-32 * coldry(iplon,lay) + if (colch4(iplon,lay) .eq. 0. ) colch4(iplon,lay) = 1.e-32 * coldry(iplon,lay) + if (colo2(iplon,lay) .eq. 0. ) colo2(iplon,lay) = 1.e-32 * coldry(iplon,lay) + co2reg = 3.55e-24 * coldry(iplon,lay) + co2mult(iplon,lay) = (colco2(iplon,lay) - co2reg) * & + 272.63 *exp(-1919.4 /tavel(iplon,lay) )/(8.7604e-4 *tavel(iplon,lay) ) + + selffac(iplon,lay) = 0. + selffrac(iplon,lay) = 0. + indself(iplon,lay) = 0 + + + else + + +! Set up factors needed to separately include the water vapor +! foreign-continuum in the calculation of absorption coefficient. + + forfac(iplon,lay) = scalefac / (1.+water) + factor = (332.0 -tavel(iplon,lay) )/36.0 + indfor(iplon,lay) = min(2, max(1, int(factor))) + forfrac(iplon,lay) = factor - float(indfor(iplon,lay) ) + +! Set up factors needed to separately include the water vapor +! self-continuum in the calculation of absorption coefficient. + + selffac(iplon,lay) = water * forfac(iplon,lay) + factor = (tavel(iplon,lay) -188.0 )/7.2 + indself(iplon,lay) = min(9, max(1, int(factor)-7)) + selffrac(iplon,lay) = factor - float(indself(iplon,lay) + 7) + +! Calculate needed column amounts. + + colh2o(iplon,lay) = 1.e-20 * wkl(iplon,1,lay) + colco2(iplon,lay) = 1.e-20 * wkl(iplon,2,lay) + colo3(iplon,lay) = 1.e-20 * wkl(iplon,3,lay) +! colo3(lay) = 0. +! colo3(lay) = colo3(lay)/1.16 + coln2o(iplon,lay) = 1.e-20 * wkl(iplon,4,lay) + colch4(iplon,lay) = 1.e-20 * wkl(iplon,6,lay) + colo2(iplon,lay) = 1.e-20 * wkl(iplon,7,lay) + colmol(iplon,lay) = 1.e-20 * coldry(iplon,lay) + colh2o(iplon,lay) +! colco2(lay) = 0. +! colo3(lay) = 0. +! coln2o(lay) = 0. +! colch4(lay) = 0. +! colo2(lay) = 0. +! colmol(lay) = 0. + if (colco2(iplon,lay) .eq. 0. ) colco2(iplon,lay) = 1.e-32 * coldry(iplon,lay) + if (coln2o(iplon,lay) .eq. 0. ) coln2o(iplon,lay) = 1.e-32 * coldry(iplon,lay) + if (colch4(iplon,lay) .eq. 0. ) colch4(iplon,lay) = 1.e-32 * coldry(iplon,lay) + if (colo2(iplon,lay) .eq. 0. ) colo2(iplon,lay) = 1.e-32 * coldry(iplon,lay) +! Using E = 1334.2 cm-1. + co2reg = 3.55e-24 * coldry(iplon,lay) + co2mult(iplon,lay) = (colco2(iplon,lay) - co2reg) * & + 272.63 *exp(-1919.4 /tavel(iplon,lay) )/(8.7604e-4 *tavel(iplon,lay) ) + + end if +! We have now isolated the layer ln pressure and temperature, +! between two reference pressures and two reference temperatures +! (for each reference pressure). We multiply the pressure +! fraction FP with the appropriate temperature fractions to get +! the factors that will be needed for the interpolation that yields +! the optical depths (performed in routines TAUGBn for band n). + + compfp = 1. - fp + fac10(iplon,lay) = compfp * ft + fac00(iplon,lay) = compfp * (1. - ft) + fac11(iplon,lay) = fp * ft1 + fac01(iplon,lay) = fp * (1. - ft1) + +! End layer loop + end do + +! End column loop + end do +!$acc end kernels +#ifndef _ACCEL +# undef ncol +#endif + +end subroutine setcoef_sw + +!*************************************************************************** + subroutine swatmref +!*************************************************************************** + + save + +! These pressures are chosen such that the ln of the first pressure +! has only a few non-zero digits (i.e. ln(PREF(1)) = 6.96000) and +! each subsequent ln(pressure) differs from the previous one by 0.2. + + pref(:) = (/ & + 1.05363e+03 ,8.62642e+02 ,7.06272e+02 ,5.78246e+02 ,4.73428e+02 , & + 3.87610e+02 ,3.17348e+02 ,2.59823e+02 ,2.12725e+02 ,1.74164e+02 , & + 1.42594e+02 ,1.16746e+02 ,9.55835e+01 ,7.82571e+01 ,6.40715e+01 , & + 5.24573e+01 ,4.29484e+01 ,3.51632e+01 ,2.87892e+01 ,2.35706e+01 , & + 1.92980e+01 ,1.57998e+01 ,1.29358e+01 ,1.05910e+01 ,8.67114e+00 , & + 7.09933e+00 ,5.81244e+00 ,4.75882e+00 ,3.89619e+00 ,3.18993e+00 , & + 2.61170e+00 ,2.13828e+00 ,1.75067e+00 ,1.43333e+00 ,1.17351e+00 , & + 9.60789e-01 ,7.86628e-01 ,6.44036e-01 ,5.27292e-01 ,4.31710e-01 , & + 3.53455e-01 ,2.89384e-01 ,2.36928e-01 ,1.93980e-01 ,1.58817e-01 , & + 1.30029e-01 ,1.06458e-01 ,8.71608e-02 ,7.13612e-02 ,5.84256e-02 , & + 4.78349e-02 ,3.91639e-02 ,3.20647e-02 ,2.62523e-02 ,2.14936e-02 , & + 1.75975e-02 ,1.44076e-02 ,1.17959e-02 ,9.65769e-03 /) + + preflog(:) = (/ & + 6.9600e+00 , 6.7600e+00 , 6.5600e+00 , 6.3600e+00 , 6.1600e+00 , & + 5.9600e+00 , 5.7600e+00 , 5.5600e+00 , 5.3600e+00 , 5.1600e+00 , & + 4.9600e+00 , 4.7600e+00 , 4.5600e+00 , 4.3600e+00 , 4.1600e+00 , & + 3.9600e+00 , 3.7600e+00 , 3.5600e+00 , 3.3600e+00 , 3.1600e+00 , & + 2.9600e+00 , 2.7600e+00 , 2.5600e+00 , 2.3600e+00 , 2.1600e+00 , & + 1.9600e+00 , 1.7600e+00 , 1.5600e+00 , 1.3600e+00 , 1.1600e+00 , & + 9.6000e-01 , 7.6000e-01 , 5.6000e-01 , 3.6000e-01 , 1.6000e-01 , & + -4.0000e-02 ,-2.4000e-01 ,-4.4000e-01 ,-6.4000e-01 ,-8.4000e-01 , & + -1.0400e+00 ,-1.2400e+00 ,-1.4400e+00 ,-1.6400e+00 ,-1.8400e+00 , & + -2.0400e+00 ,-2.2400e+00 ,-2.4400e+00 ,-2.6400e+00 ,-2.8400e+00 , & + -3.0400e+00 ,-3.2400e+00 ,-3.4400e+00 ,-3.6400e+00 ,-3.8400e+00 , & + -4.0400e+00 ,-4.2400e+00 ,-4.4400e+00 ,-4.6400e+00 /) + +! These are the temperatures associated with the respective +! pressures for the MLS standard atmosphere. + + tref(:) = (/ & + 2.9420e+02 , 2.8799e+02 , 2.7894e+02 , 2.6925e+02 , 2.5983e+02 , & + 2.5017e+02 , 2.4077e+02 , 2.3179e+02 , 2.2306e+02 , 2.1578e+02 , & + 2.1570e+02 , 2.1570e+02 , 2.1570e+02 , 2.1706e+02 , 2.1858e+02 , & + 2.2018e+02 , 2.2174e+02 , 2.2328e+02 , 2.2479e+02 , 2.2655e+02 , & + 2.2834e+02 , 2.3113e+02 , 2.3401e+02 , 2.3703e+02 , 2.4022e+02 , & + 2.4371e+02 , 2.4726e+02 , 2.5085e+02 , 2.5457e+02 , 2.5832e+02 , & + 2.6216e+02 , 2.6606e+02 , 2.6999e+02 , 2.7340e+02 , 2.7536e+02 , & + 2.7568e+02 , 2.7372e+02 , 2.7163e+02 , 2.6955e+02 , 2.6593e+02 , & + 2.6211e+02 , 2.5828e+02 , 2.5360e+02 , 2.4854e+02 , 2.4348e+02 , & + 2.3809e+02 , 2.3206e+02 , 2.2603e+02 , 2.2000e+02 , 2.1435e+02 , & + 2.0887e+02 , 2.0340e+02 , 1.9792e+02 , 1.9290e+02 , 1.8809e+02 , & + 1.8329e+02 , 1.7849e+02 , 1.7394e+02 , 1.7212e+02 /) + + end subroutine swatmref + + end module rrtmg_sw_setcoef_f + + module rrtmg_sw_taumol_f + +! ------- Modules ------- + + use rrsw_con_f, only: oneminus + use rrsw_wvn_f, only: nspa, nspb + use rrsw_vsn_f, only: hvrtau, hnamtau + + implicit none + + contains + +!---------------------------------------------------------------------------- + subroutine taumol_sw(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- + + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real , intent(inout) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real , intent(inout) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real , intent(inout) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Calculate gaseous optical depth and planck fractions for each spectral band. + + call taumol16(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol17(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol18(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol19(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol20(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol21(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol22(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol23(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol24(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol25(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol26(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol27(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol28(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + call taumol29(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) + + end subroutine + + +!---------------------------------------------------------------------------- + subroutine taumol16(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 16: 2600-3250 cm-1 (low - h2o,ch4; high - ch4) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng16 + use rrsw_kg16_f, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat1 +! sfluxref, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(inout) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(inout) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(inout) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL +# define IKLOOP1_S do iplon=1,ncol;do lay=1,nlayers +# define IKLOOP1_E enddo;enddo +# define IKLOOP2_S do iplon=1,ncol;laysolfr=nlayers;do lay=laytrop(iplon)+1,nlayers;if(jp(iplon,lay-1).lt.layreffr.and.jp(iplon,lay).ge.layreffr)laysolfr=lay +# define IKLOOP2_E +#else +# define ncol CHNK +# define IKLOOP1_S do lay = 1, nlayers ; do iplon = 1, ncol +# define IKLOOP1_E enddo;enddo +# define IKLOOP2_S do lay=2,nlayers;do iplon=1,ncol;if(lay>laytrop(iplon))then;laysolfr=nlayers +# define IKLOOP2_E endif;enddo;enddo +#endif + + + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr +! real :: fac000, fac001, fac010, fac011, fac100, fac101, & +! fac110, fac111, fs, speccomb, specmult, specparm, & +! tauray, strrat1 + integer :: iplon +! strrat1 = 252.131 +! layreffr = 18 +!$acc kernels +#ifdef _ACCEL + do iplon=1,ncol +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, nlayers +#else +IKLOOP1_S +#endif + if (lay <= laytrop(iplon)) then + speccomb = colh2o(iplon,lay) + strrat1*colch4(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs) * fac01(iplon,lay) + fac011 = (1. - fs) * fac11(iplon,lay) + fac101 = fs * fac01(iplon,lay) + fac111 = fs * fac11(iplon,lay) + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(16) + js + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(16) + js + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng16 + taug(iplon,lay,ig) = speccomb * & + (fac000 * absa(ind0 ,ig) + & + fac100 * absa(ind0 +1,ig) + & + fac010 * absa(ind0 +9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1 ,ig) + & + fac101 * absa(ind1 +1,ig) + & + fac011 * absa(ind1 +9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(iplon,lay) * & + (selffac(iplon,lay) * (selfref(inds,ig) + & + selffrac(iplon,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ig) = tauray/taug(lay,ig) + taur(iplon,lay,ig) = tauray + enddo + end if +#ifdef _ACCEL + enddo + enddo +!$acc end kernels + +! Upper atmosphere loop +!$acc kernels + do iplon=1,ncol + laysolfr = nlayers +! mji - fix for out of bounds issue on absb - added to pass bounds checking; FINAL + do lay = laytrop(iplon)+1, nlayers +! if (lay > laytrop(iplon)) then +! !do lay = laytrop(iplon) +1, nlayers + if (jp(iplon,lay-1) .lt. layreffr .and. jp(iplon,lay) .ge. layreffr) then + laysolfr = lay + end if +#else +IKLOOP1_E +IKLOOP2_S +#endif + +!#ifdef _ACCEL +! do iplon=1,ncol +! laysolfr = nlayers +!! mji - fix for out of bounds issue on absb - added to pass bounds checking; FINAL +! do lay = laytrop(iplon)+1, nlayers +!! if (lay > laytrop(iplon)) then +!! !do lay = laytrop(iplon) +1, nlayers +! if (jp(iplon,lay-1) .lt. layreffr .and. jp(iplon,lay) .ge. layreffr) then +! laysolfr = lay +! end if +!#else +! do lay = minval(laytrop(1:ncol)),nlayers +! do iplon=1,ncol +! if (lay > laytrop(iplon)) then +! laysolfr = nlayers +! +!#endif + ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(16) + 1 + ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(16) + 1 + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng16 + taug(iplon,lay,ig) = colch4(iplon,lay) * & + (fac00(iplon,lay) * absb(ind0 ,ig) + & + fac10(iplon,lay) * absb(ind0+1,ig) + & + fac01(iplon,lay) * absb(ind1 ,ig) + & + fac11(iplon,lay) * absb(ind1+1,ig)) + + if (laysolfr == lay) sfluxzen(iplon,ig) = sfluxref(ig) + taur(iplon,lay,ig) = tauray + enddo +#ifdef _ACCEL + enddo + enddo +#else +IKLOOP2_E +#endif +!$acc end kernels +# undef ncol + end subroutine taumol16 + +!---------------------------------------------------------------------------- + subroutine taumol17(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng17, ngs16 + use rrsw_kg17_f, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat +! use rrsw_kg17_f, only : absa, ka, absb, kb, forref, selfref, & +! sfluxref, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifndef _ACCEL +# define ncol CHNK +#endif + + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr +! real :: fac000, fac001, fac010, fac011, fac100, fac101, & +! fac110, fac111, fs, speccomb, specmult, specparm, & +! tauray, strrat + integer :: iplon + +! layreffr = 30 +! strrat = 0.364641 + +#ifdef _ACCEL +!$acc kernels loop + do iplon=1,ncol +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop +!$acc loop private(js, fs) + do lay = 1, nlayers +#else +IKLOOP1_S +#endif + if (lay <= laytrop(iplon)) then + !do lay = 1, laytrop(iplon) + speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs) * fac01(iplon,lay) + fac011 = (1. - fs) * fac11(iplon,lay) + fac101 = fs * fac01(iplon,lay) + fac111 = fs * fac11(iplon,lay) + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(17) + js + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(17) + js + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng17 + taug(iplon,lay,ngs16+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(iplon,lay) * & + (selffac(iplon,lay) * (selfref(inds,ig) + & + selffrac(iplon,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) + taur(iplon,lay,ngs16+ig) = tauray + enddo + + else + + + speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 4. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs) * fac01(iplon,lay) + fac011 = (1. - fs) * fac11(iplon,lay) + fac101 = fs * fac01(iplon,lay) + fac111 = fs * fac11(iplon,lay) + ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(17) + js + ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(17) + js + indf = indfor(iplon,lay) + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng17 + taug(iplon,lay,ngs16+ig) = speccomb * & + (fac000 * absb(ind0,ig) + & + fac100 * absb(ind0+1,ig) + & + fac010 * absb(ind0+5,ig) + & + fac110 * absb(ind0+6,ig) + & + fac001 * absb(ind1,ig) + & + fac101 * absb(ind1+1,ig) + & + fac011 * absb(ind1+5,ig) + & + fac111 * absb(ind1+6,ig)) + & + colh2o(iplon,lay) * & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) +! ssa(lay,ngs16+ig) = tauray/taug(lay,ngs16+ig) + + taur(iplon,lay,ngs16+ig) = tauray + enddo + endif + enddo + enddo +!$acc end kernels + +!$acc kernels +#ifdef _ACCEL + do iplon = 1, ncol +! Upper atmosphere loop + laysolfr = nlayers + do lay = 2, nlayers + if (lay > laytrop(iplon)) then +#else +IKLOOP2_S +#endif + + if ((jp(iplon,lay-1) .lt. layreffr) .and. (jp(iplon,lay) .ge. layreffr)) then + laysolfr = lay + end if + + if (lay == laysolfr) then + + speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 4. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + do ig = 1, ng17 + sfluxzen(iplon,ngs16+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + end do + end if +#ifdef _ACCEL + end if + enddo + enddo +#else +IKLOOP2_E +#endif +!$acc end kernels +# undef ncol + end subroutine taumol17 + +!---------------------------------------------------------------------------- + subroutine taumol18(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng18, ngs17 + use rrsw_kg18_f, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat +! use rrsw_kg18_f, only : absa, ka, absb, kb, forref, selfref, & +! sfluxref, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifndef _ACCEL +# define ncol CHNK +#endif + +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr +! real :: fac000, fac001, fac010, fac011, fac100, fac101, & +! fac110, fac111, fs, speccomb, specmult, specparm, & +! tauray, strrat + integer :: iplon + + +! strrat = 38.9589 +! layreffr = 6 +!$acc kernels + +#ifdef _ACCEL + do iplon = 1, ncol + laysolfr = laytrop(iplon) + do lay = 1, laytrop(iplon) +#else + laysolfr = laytrop +#define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay <= laytrop(iplon)) then +#endif + speccomb = colh2o(iplon,lay) + strrat*colch4(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop(iplon) ) + do ig = 1, ng18 + if (lay .eq. laysolfr) sfluxzen(iplon,ngs17+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + end do +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + end do + end do +!$acc end kernels + +!$acc kernels +IKLOOP1_S + if (lay <= laytrop(iplon)) then + !do lay = 1, laytrop(iplon) + + speccomb = colh2o(iplon,lay) + strrat*colch4(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs) * fac01(iplon,lay) + fac011 = (1. - fs) * fac11(iplon,lay) + fac101 = fs * fac01(iplon,lay) + fac111 = fs * fac11(iplon,lay) + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(18) + js + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(18) + js + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng18 + taug(iplon,lay,ngs17+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(iplon,lay) * & + (selffac(iplon,lay) * (selfref(inds,ig) + & + selffrac(iplon,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) + + taur(iplon,lay,ngs17+ig) = tauray + enddo + + else + +! Upper atmosphere loop + +!do lay = laytrop(iplon) +1, nlayers + ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(18) + 1 + ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(18) + 1 + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng18 + taug(iplon,lay,ngs17+ig) = colch4(iplon,lay) * & + (fac00(iplon,lay) * absb(ind0,ig) + & + fac10(iplon,lay) * absb(ind0+1,ig) + & + fac01(iplon,lay) * absb(ind1,ig) + & + fac11(iplon,lay) * absb(ind1+1,ig)) +! ssa(lay,ngs17+ig) = tauray/taug(lay,ngs17+ig) + taur(iplon,lay,ngs17+ig) = tauray + enddo + end if +IKLOOP1_E + +!$acc end kernels +# undef ncol + end subroutine taumol18 + +!---------------------------------------------------------------------------- + subroutine taumol19(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng19, ngs18 + use rrsw_kg19_f, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat +! use rrsw_kg19_f, only : absa, ka, absb, kb, forref, selfref, & +! sfluxref, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL +#else +# define ncol CHNK +#endif + +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr +! real :: fac000, fac001, fac010, fac011, fac100, fac101, & +! fac110, fac111, fs, speccomb, specmult, specparm, & +! tauray, strrat + integer :: iplon + + + strrat = 5.49281 + layreffr = 3 + +#ifdef _ACCEL +!$acc kernels + do iplon=1,ncol + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + laysolfr = laytrop(iplon) + +! Lower atmosphere loop + do lay = 1, laytrop(iplon) +#else + laysolfr = laytrop +# define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay <= laytrop(iplon)) then +#endif + + if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop(iplon) ) + + if (lay .eq. laysolfr) then + speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + + do ig = 1 , ng19 + sfluxzen(iplon,ngs18+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + end do + endif +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + + end do + end do +!$acc end kernels + + +!$acc kernels +IKLOOP1_S + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + + speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs) * fac01(iplon,lay) + fac011 = (1. - fs) * fac11(iplon,lay) + fac101 = fs * fac01(iplon,lay) + fac111 = fs * fac11(iplon,lay) + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(19) + js + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(19) + js + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + tauray = colmol(iplon,lay) * rayl + + do ig = 1 , ng19 + taug(iplon,lay,ngs18+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(iplon,lay) * & + (selffac(iplon,lay) * (selfref(inds,ig) + & + selffrac(iplon,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) + taur(iplon,lay,ngs18+ig) = tauray + enddo + else + +! Upper atmosphere loop + + ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(19) + 1 + ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(19) + 1 + tauray = colmol(iplon,lay) * rayl + + do ig = 1 , ng19 + taug(iplon,lay,ngs18+ig) = colco2(iplon,lay) * & + (fac00(iplon,lay) * absb(ind0,ig) + & + fac10(iplon,lay) * absb(ind0+1,ig) + & + fac01(iplon,lay) * absb(ind1,ig) + & + fac11(iplon,lay) * absb(ind1+1,ig)) +! ssa(lay,ngs18+ig) = tauray/taug(lay,ngs18+ig) + taur(iplon,lay,ngs18+ig) = tauray + enddo + end if +IKLOOP1_E +!$acc end kernels +# undef ncol + end subroutine taumol19 + +!---------------------------------------------------------------------------- + subroutine taumol20(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng20, ngs19 + use rrsw_kg20_f, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, absch4, rayl, layreffr +! use rrsw_kg20_f, only : absa, ka, absb, kb, forref, selfref, & +! sfluxref, absch4, rayl + + implicit none + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else +# define ncol CHNK + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + integer :: iplon + +! layreffr = 3 + +#ifdef _ACCEL +!$acc kernels loop independent private(laysolfr) + do iplon = 1, ncol + laysolfr = laytrop(iplon) + do lay = 1, laytrop(iplon) +#else + laysolfr = laytrop +# define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay <= laytrop(iplon)) then +#endif + + if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop(iplon) ) + if (lay .eq. laysolfr) then + do ig = 1, ng20 + sfluxzen(iplon,ngs19+ig) = sfluxref(ig) + end do + end if +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + end do + end do +!$acc end kernels + +!$acc kernels +IKLOOP1_S + if (lay <= laytrop(iplon)) then + + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(20) + 1 + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(20) + 1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng20 + taug(iplon,lay,ngs19+ig) = colh2o(iplon,lay) * & + ((fac00(iplon,lay) * absa(ind0,ig) + & + fac10(iplon,lay) * absa(ind0+1,ig) + & + fac01(iplon,lay) * absa(ind1,ig) + & + fac11(iplon,lay) * absa(ind1+1,ig)) + & + selffac(iplon,lay) * (selfref(inds,ig) + & + selffrac(iplon,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) & + + colch4(iplon,lay) * absch4(ig) +! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) + taur(iplon,lay,ngs19+ig) = tauray + + enddo + else + +! Upper atmosphere loop + + ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(20) + 1 + ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(20) + 1 + indf = indfor(iplon,lay) + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng20 + taug(iplon,lay,ngs19+ig) = colh2o(iplon,lay) * & + (fac00(iplon,lay) * absb(ind0,ig) + & + fac10(iplon,lay) * absb(ind0+1,ig) + & + fac01(iplon,lay) * absb(ind1,ig) + & + fac11(iplon,lay) * absb(ind1+1,ig) + & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) + & + colch4(iplon,lay) * absch4(ig) +! ssa(lay,ngs19+ig) = tauray/taug(lay,ngs19+ig) + taur(iplon,lay,ngs19+ig) = tauray + enddo + end if +IKLOOP1_E + +!$acc end kernels +# undef ncol + end subroutine taumol20 + +!---------------------------------------------------------------------------- + subroutine taumol21(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng21, ngs20 + use rrsw_kg21_f, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat +! use rrsw_kg21_f, only : absa, ka, absb, kb, forref, selfref, & +! sfluxref, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else +# define ncol CHNK + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr +! real :: fac000, fac001, fac010, fac011, fac100, fac101, & +! fac110, fac111, fs, speccomb, specmult, specparm, & +! tauray, strrat + integer :: iplon + +! strrat = 0.0045321 +! layreffr = 8 + +#ifdef _ACCEL +!$acc kernels loop independent private(laysolfr) + do iplon = 1, ncol + laysolfr = laytrop(iplon) + do lay = 1, laytrop(iplon) +#else + laysolfr = laytrop +# define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay <= laytrop(iplon)) then +#endif + + if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop(iplon) ) + if (lay .eq. laysolfr) then + speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + do ig = 1, ng21 + sfluxzen(iplon,ngs20+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + end do + end if + +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + end do + end do +!$acc end kernels + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + +!$acc kernels +IKLOOP1_S + if (lay <= laytrop(iplon)) then + speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs) * fac01(iplon,lay) + fac011 = (1. - fs) * fac11(iplon,lay) + fac101 = fs * fac01(iplon,lay) + fac111 = fs * fac11(iplon,lay) + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(21) + js + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(21) + js + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng21 + taug(iplon,lay,ngs20+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(iplon,lay) * & + (selffac(iplon,lay) * (selfref(inds,ig) + & + selffrac(iplon,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) + + taur(iplon,lay,ngs20+ig) = tauray + enddo + else + +! Upper atmosphere loop + + speccomb = colh2o(iplon,lay) + strrat*colco2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 4. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs) * fac01(iplon,lay) + fac011 = (1. - fs) * fac11(iplon,lay) + fac101 = fs * fac01(iplon,lay) + fac111 = fs * fac11(iplon,lay) + ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(21) + js + ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(21) + js + indf = indfor(iplon,lay) + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng21 + taug(iplon,lay,ngs20+ig) = speccomb * & + (fac000 * absb(ind0,ig) + & + fac100 * absb(ind0+1,ig) + & + fac010 * absb(ind0+5,ig) + & + fac110 * absb(ind0+6,ig) + & + fac001 * absb(ind1,ig) + & + fac101 * absb(ind1+1,ig) + & + fac011 * absb(ind1+5,ig) + & + fac111 * absb(ind1+6,ig)) + & + colh2o(iplon,lay) * & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig))) +! ssa(lay,ngs20+ig) = tauray/taug(lay,ngs20+ig) + taur(iplon,lay,ngs20+ig) = tauray + enddo + end if +IKLOOP1_E + +!$acc end kernels +# undef ncol + end subroutine taumol21 + +!---------------------------------------------------------------------------- + subroutine taumol22(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng22, ngs21 + use rrsw_kg22_f, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, rayl, layreffr, strrat +! use rrsw_kg22_f, only : absa, ka, absb, kb, forref, selfref, & +! sfluxref, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else +# define ncol CHNK + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray, o2adj, o2cont +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr +! real :: fac000, fac001, fac010, fac011, fac100, fac101, & +! fac110, fac111, fs, speccomb, specmult, specparm, & +! tauray, o2adj, o2cont, strrat + integer :: iplon + +! The following factor is the ratio of total O2 band intensity (lines +! and Mate continuum) to O2 band intensity (line only). It is needed +! to adjust the optical depths since the k's include only lines. + o2adj = 1.6 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! strrat = 0.022708 +! layreffr = 2 + +#ifdef _ACCEL +!$acc kernels loop independent private(laysolfr) + do iplon=1,ncol + + laysolfr = laytrop(iplon) + +! Lower atmosphere loop +!$acc loop seq + do lay = 1, laytrop(iplon) +#else + laysolfr = laytrop +# define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay <= laytrop(iplon)) then +#endif + + if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop(iplon) ) + + if (lay .eq. laysolfr) then + speccomb = colh2o(iplon,lay) + o2adj*strrat*colo2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + ! odadj = specparm + o2adj * (1. - specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + do ig = 1, ng22 + + sfluxzen(iplon,ngs21+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + end do + end if +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + end do + end do + !$acc end kernels + +! Lower atmosphere loop +!$acc kernels +IKLOOP1_S + + if (lay<=laytrop(iplon)) then + + o2cont = 4.35e-4 *colo2(iplon,lay) /(350.0 *2.0 ) + speccomb = colh2o(iplon,lay) + o2adj*strrat*colo2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) +! odadj = specparm + o2adj * (1. - specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs) * fac01(iplon,lay) + fac011 = (1. - fs) * fac11(iplon,lay) + fac101 = fs * fac01(iplon,lay) + fac111 = fs * fac11(iplon,lay) + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(22) + js + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(22) + js + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng22 + taug(iplon,lay,ngs21+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colh2o(iplon,lay) * & + (selffac(iplon,lay) * (selfref(inds,ig) + & + selffrac(iplon,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) & + + o2cont +! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) + + taur(iplon,lay,ngs21+ig) = tauray + enddo + + else + +! Upper atmosphere loop + + o2cont = 4.35e-4 *colo2(iplon,lay) /(350.0 *2.0 ) + ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(22) + 1 + ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(22) + 1 + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng22 + taug(iplon,lay,ngs21+ig) = colo2(iplon,lay) * o2adj * & + (fac00(iplon,lay) * absb(ind0,ig) + & + fac10(iplon,lay) * absb(ind0+1,ig) + & + fac01(iplon,lay) * absb(ind1,ig) + & + fac11(iplon,lay) * absb(ind1+1,ig)) + & + o2cont +! ssa(lay,ngs21+ig) = tauray/taug(lay,ngs21+ig) + taur(iplon,lay,ngs21+ig) = tauray + enddo + end if +IKLOOP1_E + +!$acc end kernels +# undef ncol + end subroutine taumol22 + +!---------------------------------------------------------------------------- + subroutine taumol23(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng23, ngs22 + use rrsw_kg23_f, only : absa, ka, forref, selfref, & + sfluxref, rayl, layreffr, givfac +! use rrsw_kg23_f, only : absa, ka, forref, selfref, & +! sfluxref, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else +# define ncol CHNK + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr +! real :: fac000, fac001, fac010, fac011, fac100, fac101, & +! fac110, fac111, fs, speccomb, specmult, specparm, & +! tauray, givfac + integer :: iplon + + +! Average Giver et al. correction factor for this band. +! givfac = 1.029 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! layreffr = 6 + +#ifdef _ACCEL +!$acc kernels loop independent private(laysolfr) + do iplon=1,ncol + + laysolfr = laytrop(iplon) + +! Lower atmosphere loop +!$acc loop seq + do lay = 1, laytrop(iplon) +#else + laysolfr = laytrop +# define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay <= laytrop(iplon)) then +#endif + + if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop(iplon) ) + + if (lay .eq. laysolfr) then + do ig = 1, ng23 + sfluxzen(iplon,ngs22+ig) = sfluxref(ig) + end do + end if +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + end do + end do +!$acc end kernels + + +! Lower atmosphere loop +!$acc kernels +IKLOOP1_S + if (lay <= laytrop(iplon)) then + if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop(iplon) ) + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(23) + 1 + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(23) + 1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + + do ig = 1, ng23 + tauray = colmol(iplon,lay) * rayl(ig) + taug(iplon,lay,ngs22+ig) = colh2o(iplon,lay) * & + (givfac * (fac00(iplon,lay) * absa(ind0,ig) + & + fac10(iplon,lay) * absa(ind0+1,ig) + & + fac01(iplon,lay) * absa(ind1,ig) + & + fac11(iplon,lay) * absa(ind1+1,ig)) + & + selffac(iplon,lay) * (selfref(inds,ig) + & + selffrac(iplon,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ngs22+ig) = tauray/taug(lay,ngs22+ig) + + taur(iplon,lay,ngs22+ig) = tauray + enddo + + else + +! Upper atmosphere loop + + do ig = 1, ng23 +! taug(lay,ngs22+ig) = colmol(lay) * rayl(ig) +! ssa(lay,ngs22+ig) = 1.0 + taug(iplon,lay,ngs22+ig) = 0. + taur(iplon,lay,ngs22+ig) = colmol(iplon,lay) * rayl(ig) + enddo + end if + +IKLOOP1_E + +!$acc end kernels +# undef ncol + end subroutine taumol23 + +!---------------------------------------------------------------------------- + subroutine taumol24(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng24, ngs23 + use rrsw_kg24_f, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, abso3a, abso3b, rayla, raylb, & + layreffr, strrat +! use rrsw_kg24_f, only : absa, ka, absb, kb, forref, selfref, & +! sfluxref, abso3a, abso3b, rayla, raylb + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else +# define ncol CHNK + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr +! real :: fac000, fac001, fac010, fac011, fac100, fac101, & +! fac110, fac111, fs, speccomb, specmult, specparm, & +! tauray, strrat + integer :: iplon + +! strrat = 0.124692 +! layreffr = 1 + +#ifdef _ACCEL +!$acc kernels loop independent private(laysolfr) + do iplon=1,ncol +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + + laysolfr = laytrop(iplon) + +! Lower atmosphere loop +!$acc loop independent + do lay = 1, laytrop(iplon) +#else + laysolfr = laytrop +# define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay <= laytrop(iplon)) then +#endif + + if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop(iplon) ) + if (lay .eq. laysolfr) then + speccomb = colh2o(iplon,lay) + strrat*colo2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + do ig = 1, ng24 + sfluxzen(iplon,ngs23+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + end do + end if +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + end do + end do +!$acc end kernels + +!$acc kernels +IKLOOP1_S +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + if (lay <= laytrop(iplon)) then + + speccomb = colh2o(iplon,lay) + strrat*colo2(iplon,lay) + specparm = colh2o(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs) * fac01(iplon,lay) + fac011 = (1. - fs) * fac11(iplon,lay) + fac101 = fs * fac01(iplon,lay) + fac111 = fs * fac11(iplon,lay) + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(24) + js + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(24) + js + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + + do ig = 1, ng24 + tauray = colmol(iplon,lay) * (rayla(ig,js) + & + fs * (rayla(ig,js+1) - rayla(ig,js))) + taug(iplon,lay,ngs23+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) + & + colo3(iplon,lay) * abso3a(ig) + & + colh2o(iplon,lay) * & + (selffac(iplon,lay) * (selfref(inds,ig) + & + selffrac(iplon,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) +! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) + + taur(iplon,lay,ngs23+ig) = tauray + enddo + + else + +! Upper atmosphere loop + + ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(24) + 1 + ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(24) + 1 + + do ig = 1, ng24 + tauray = colmol(iplon,lay) * raylb(ig) + taug(iplon,lay,ngs23+ig) = colo2(iplon,lay) * & + (fac00(iplon,lay) * absb(ind0,ig) + & + fac10(iplon,lay) * absb(ind0+1,ig) + & + fac01(iplon,lay) * absb(ind1,ig) + & + fac11(iplon,lay) * absb(ind1+1,ig)) + & + colo3(iplon,lay) * abso3b(ig) +! ssa(lay,ngs23+ig) = tauray/taug(lay,ngs23+ig) + taur(iplon,lay,ngs23+ig) = tauray + enddo + endif + +IKLOOP1_E + +!$acc end kernels +# undef ncol + end subroutine taumol24 + +!---------------------------------------------------------------------------- + subroutine taumol25(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng25, ngs24 + use rrsw_kg25_f, only : absa, ka, & + sfluxref, abso3a, abso3b, rayl, layreffr +! use rrsw_kg25_f, only : absa, ka, & +! sfluxref, abso3a, abso3b, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else +# define ncol CHNK + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + + +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + integer :: iplon + +#ifdef _ACCEL +!$acc kernels + do iplon=1,ncol +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! layreffr = 2 + laysolfr = laytrop(iplon) + +! Lower atmosphere loop + do lay = 1, laytrop(iplon) +#else + laysolfr = laytrop +# define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay <= laytrop(iplon)) then +#endif + if (jp(iplon,lay) .lt. layreffr .and. jp(iplon,lay+1) .ge. layreffr) & + laysolfr = min(lay+1,laytrop(iplon) ) + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(25) + 1 + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(25) + 1 + + do ig = 1, ng25 + tauray = colmol(iplon,lay) * rayl(ig) + taug(iplon,lay,ngs24+ig) = colh2o(iplon,lay) * & + (fac00(iplon,lay) * absa(ind0,ig) + & + fac10(iplon,lay) * absa(ind0+1,ig) + & + fac01(iplon,lay) * absa(ind1,ig) + & + fac11(iplon,lay) * absa(ind1+1,ig)) + & + colo3(iplon,lay) * abso3a(ig) +! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) + if (lay .eq. laysolfr) sfluxzen(iplon,ngs24+ig) = sfluxref(ig) + taur(iplon,lay,ngs24+ig) = tauray + enddo +#ifdef _ACCEL + enddo +! Upper atmosphere loop + do lay = laytrop(iplon) +1, nlayers +#else + else +#endif + + do ig = 1, ng25 + tauray = colmol(iplon,lay) * rayl(ig) + taug(iplon,lay,ngs24+ig) = colo3(iplon,lay) * abso3b(ig) +! ssa(lay,ngs24+ig) = tauray/taug(lay,ngs24+ig) + taur(iplon,lay,ngs24+ig) = tauray + enddo +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + enddo + enddo + +!$acc end kernels +# undef ncol + end subroutine taumol25 + +!---------------------------------------------------------------------------- + subroutine taumol26(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng26, ngs25 + use rrsw_kg26_f, only : sfluxref, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else +# define ncol CHNK + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + integer :: iplon + +#ifdef _ACCEL +!$acc kernels + do iplon=1,ncol +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + + laysolfr = laytrop(iplon) + +! Lower atmosphere loop + do lay = 1, laytrop(iplon) +#else + laysolfr = laytrop +# define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay <= laytrop(iplon)) then +#endif + do ig = 1, ng26 +! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig) +! ssa(lay,ngs25+ig) = 1.0 + if (lay .eq. laysolfr) sfluxzen(iplon,ngs25+ig) = sfluxref(ig) + taug(iplon,lay,ngs25+ig) = 0. + taur(iplon,lay,ngs25+ig) = colmol(iplon,lay) * rayl(ig) + enddo +#ifdef _ACCEL + enddo + do lay = laytrop(iplon) +1, nlayers +#else + else +#endif + +! Upper atmosphere loop + do ig = 1, ng26 +! taug(lay,ngs25+ig) = colmol(lay) * rayl(ig) +! ssa(lay,ngs25+ig) = 1.0 + taug(iplon,lay,ngs25+ig) = 0. + taur(iplon,lay,ngs25+ig) = colmol(iplon,lay) * rayl(ig) + enddo +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + enddo + enddo + +!$acc end kernels +# undef ncol + end subroutine taumol26 + +!---------------------------------------------------------------------------- + subroutine taumol27(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 27: 29000-38000 cm-1 (low - o3; high - o3) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng27, ngs26 + use rrsw_kg27_f, only : absa, ka, absb, kb, & + sfluxref, rayl, layreffr, scalekur +! use rrsw_kg27_f, only : absa, ka, absb, kb, sfluxref, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else +# define ncol CHNK + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr +! real :: fac000, fac001, fac010, fac011, fac100, fac101, & +! fac110, fac111, fs, speccomb, specmult, specparm, & +! tauray, scalekur + integer :: iplon + +#ifdef _ACCEL +!$acc kernels + do iplon=1,ncol +! Kurucz solar source function +! The values in sfluxref were obtained using the "low resolution" +! version of the Kurucz solar source function. For unknown reasons, +! the total irradiance in this band differs from the corresponding +! total in the "high-resolution" version of the Kurucz function. +! Therefore, these values are scaled below by the factor SCALEKUR. + +! scalekur = 50.15 /48.37 + +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! layreffr = 32 + +! Lower atmosphere loop + do lay = 1, laytrop(iplon) +#else + laysolfr = nlayers +# define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay <= laytrop(iplon)) then +#endif + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(27) + 1 + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(27) + 1 + + do ig = 1, ng27 + tauray = colmol(iplon,lay) * rayl(ig) + taug(iplon,lay,ngs26+ig) = colo3(iplon,lay) * & + (fac00(iplon,lay) * absa(ind0,ig) + & + fac10(iplon,lay) * absa(ind0+1,ig) + & + fac01(iplon,lay) * absa(ind1,ig) + & + fac11(iplon,lay) * absa(ind1+1,ig)) +! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) + taur(iplon,lay,ngs26+ig) = tauray + enddo +#ifdef _ACCEL + enddo + + laysolfr = nlayers + +! Upper atmosphere loop + do lay = laytrop(iplon) +1, nlayers +#else + else +#endif + if (jp(iplon,lay-1) .lt. layreffr .and. jp(iplon,lay) .ge. layreffr) & + laysolfr = lay + ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(27) + 1 + ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(27) + 1 + + do ig = 1, ng27 + tauray = colmol(iplon,lay) * rayl(ig) + taug(iplon,lay,ngs26+ig) = colo3(iplon,lay) * & + (fac00(iplon,lay) * absb(ind0,ig) + & + fac10(iplon,lay) * absb(ind0+1,ig) + & + fac01(iplon,lay) * absb(ind1,ig) + & + fac11(iplon,lay) * absb(ind1+1,ig)) +! ssa(lay,ngs26+ig) = tauray/taug(lay,ngs26+ig) + if (lay.eq.laysolfr) sfluxzen(iplon,ngs26+ig) = scalekur * sfluxref(ig) + taur(iplon,lay,ngs26+ig) = tauray + enddo +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + enddo + enddo + +!$acc end kernels +# undef ncol + end subroutine taumol27 + +!---------------------------------------------------------------------------- + subroutine taumol28(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng28, ngs27 + use rrsw_kg28_f, only : absa, ka, absb, kb, & + sfluxref, rayl, layreffr, strrat +! use rrsw_kg28_f, only : absa, ka, absb, kb, sfluxref, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else +# define ncol CHNK + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr +! real :: fac000, fac001, fac010, fac011, fac100, fac101, & +! fac110, fac111, fs, speccomb, specmult, specparm, & +! tauray, strrat + integer :: iplon + +#ifdef _ACCEL +!$acc kernels + do iplon=1,ncol +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! strrat = 6.67029e-07 +! layreffr = 58 + +! Lower atmosphere loop + do lay = 1, laytrop(iplon) +#else + laysolfr = nlayers +# define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay <= laytrop(iplon)) then +#endif + speccomb = colo3(iplon,lay) + strrat*colo2(iplon,lay) + specparm = colo3(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 8. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs) * fac01(iplon,lay) + fac011 = (1. - fs) * fac11(iplon,lay) + fac101 = fs * fac01(iplon,lay) + fac111 = fs * fac11(iplon,lay) + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(28) + js + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(28) + js + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng28 + taug(iplon,lay,ngs27+ig) = speccomb * & + (fac000 * absa(ind0,ig) + & + fac100 * absa(ind0+1,ig) + & + fac010 * absa(ind0+9,ig) + & + fac110 * absa(ind0+10,ig) + & + fac001 * absa(ind1,ig) + & + fac101 * absa(ind1+1,ig) + & + fac011 * absa(ind1+9,ig) + & + fac111 * absa(ind1+10,ig)) +! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) + taur(iplon,lay,ngs27+ig) = tauray + enddo +#ifdef _ACCEL + enddo + + laysolfr = nlayers + +! Upper atmosphere loop + do lay = laytrop(iplon) +1, nlayers +#else + else +#endif + if (jp(iplon,lay-1) .lt. layreffr .and. jp(iplon,lay) .ge. layreffr) & + laysolfr = lay + speccomb = colo3(iplon,lay) + strrat*colo2(iplon,lay) + specparm = colo3(iplon,lay) /speccomb + if (specparm .ge. oneminus) specparm = oneminus + specmult = 4. *(specparm) + js = 1 + int(specmult) + fs = mod(specmult, 1. ) + fac000 = (1. - fs) * fac00(iplon,lay) + fac010 = (1. - fs) * fac10(iplon,lay) + fac100 = fs * fac00(iplon,lay) + fac110 = fs * fac10(iplon,lay) + fac001 = (1. - fs) * fac01(iplon,lay) + fac011 = (1. - fs) * fac11(iplon,lay) + fac101 = fs * fac01(iplon,lay) + fac111 = fs * fac11(iplon,lay) + ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(28) + js + ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(28) + js + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng28 + taug(iplon,lay,ngs27+ig) = speccomb * & + (fac000 * absb(ind0,ig) + & + fac100 * absb(ind0+1,ig) + & + fac010 * absb(ind0+5,ig) + & + fac110 * absb(ind0+6,ig) + & + fac001 * absb(ind1,ig) + & + fac101 * absb(ind1+1,ig) + & + fac011 * absb(ind1+5,ig) + & + fac111 * absb(ind1+6,ig)) +! ssa(lay,ngs27+ig) = tauray/taug(lay,ngs27+ig) + if (lay .eq. laysolfr) sfluxzen(iplon,ngs27+ig) = sfluxref(ig,js) & + + fs * (sfluxref(ig,js+1) - sfluxref(ig,js)) + taur(iplon,lay,ngs27+ig) = tauray + enddo +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + enddo + enddo + +!$acc end kernels +# undef ncol + end subroutine taumol28 + +!---------------------------------------------------------------------------- + subroutine taumol29(ncol, nlayers, & + colh2o, colco2, colch4, colo2, colo3, colmol, & + laytrop, jp, jt, jt1, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + sfluxzen, taug, taur) +!---------------------------------------------------------------------------- +! +! band 29: 820-2600 cm-1 (low - h2o; high - co2) +! +!---------------------------------------------------------------------------- + +! ------- Modules ------- + + use parrrsw_f, only : ng29, ngs28 + use rrsw_kg29_f, only : absa, ka, absb, kb, forref, selfref, & + sfluxref, absh2o, absco2, rayl, layreffr +! use rrsw_kg29_f, only : absa, ka, absb, kb, forref, selfref, & +! sfluxref, absh2o, absco2, rayl + +! ------- Declarations ------- + integer , intent(in) :: ncol + integer , intent(in) :: nlayers ! total number of layers + + integer , intent(in) :: laytrop(:) ! tropopause layer index + integer , intent(in) :: jp(:,:) ! + integer , intent(in) :: jt(:,:) ! + integer , intent(in) :: jt1(:,:) ! + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: colh2o(:,:) ! column amount (h2o) + real , intent(in) :: colco2(:,:) ! column amount (co2) + real , intent(in) :: colo3(:,:) ! column amount (o3) + real , intent(in) :: colch4(:,:) ! column amount (ch4) + real , intent(in) :: colo2(:,:) ! column amount (o2) + real , intent(in) :: colmol(:,:) ! + ! Dimensions: (ncol,nlayers) + + integer , intent(in) :: indself(:,:) + integer , intent(in) :: indfor(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: & ! + fac00(:,:) , fac01(:,:) , & + fac10(:,:) , fac11(:,:) + ! Dimensions: (ncol,nlayers) + +! ----- Output ----- + real, intent(out) gpu_device :: sfluxzen(:,:) ! solar source function + ! Dimensions: (ncol,ngptsw) + real, intent(out) gpu_device :: taug(:,:,:) ! gaseous optical depth + ! Dimensions: (ncol,nlayers,ngptsw) + real, intent(out) gpu_device :: taur(:,:,:) ! Rayleigh + ! Dimensions: (ncol,nlayers,ngptsw) + +! Local +#ifdef _ACCEL + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr +#else +# define ncol CHNK + integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr(ncol) +#endif + +! integer :: ig, ind0, ind1, inds, indf, js, lay, laysolfr, & +! layreffr + real :: fac000, fac001, fac010, fac011, fac100, fac101, & + fac110, fac111, fs, speccomb, specmult, specparm, & + tauray + integer :: iplon + +! layreffr = 49 + +#ifdef _ACCEL +!$acc kernels loop independent private (laysolfr) + do iplon=1,ncol + + laysolfr = nlayers +!$acc loop seq + do lay = laytrop(iplon) +1, nlayers +#else + laysolfr = nlayers +# define laysolfr LAYSOLFR(iplon) + do lay = 1, nlayers + do iplon = 1, ncol + if (lay > laytrop(iplon)) then +#endif + if (jp(iplon,lay-1) .lt. layreffr .and. jp(iplon,lay) .ge. layreffr) & + laysolfr = lay + + if (lay .eq. laysolfr) then + do ig = 1, ng29 + sfluxzen(iplon,ngs28+ig) = sfluxref(ig) + end do + end if +#ifdef _ACCEL +#else +# undef laysolfr + endif +#endif + end do + end do +!$acc end kernels + +#ifdef _ACCEL +!$acc kernels + do iplon=1,ncol +! Compute the optical depth by interpolating in ln(pressure), +! temperature, and appropriate species. Below LAYTROP, the water +! vapor self-continuum is interpolated (in temperature) separately. + +! Lower atmosphere loop + do lay = 1, nlayers +#else + do lay = 1, nlayers + do iplon=1,ncol +#endif + if (lay <= laytrop(iplon)) then + ind0 = ((jp(iplon,lay) -1)*5+(jt(iplon,lay) -1))*nspa(29) + 1 + ind1 = (jp(iplon,lay) *5+(jt1(iplon,lay) -1))*nspa(29) + 1 + inds = indself(iplon,lay) + indf = indfor(iplon,lay) + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng29 + taug(iplon,lay,ngs28+ig) = colh2o(iplon,lay) * & + ((fac00(iplon,lay) * absa(ind0,ig) + & + fac10(iplon,lay) * absa(ind0+1,ig) + & + fac01(iplon,lay) * absa(ind1,ig) + & + fac11(iplon,lay) * absa(ind1+1,ig)) + & + selffac(iplon,lay) * (selfref(inds,ig) + & + selffrac(iplon,lay) * & + (selfref(inds+1,ig) - selfref(inds,ig))) + & + forfac(iplon,lay) * (forref(indf,ig) + & + forfrac(iplon,lay) * & + (forref(indf+1,ig) - forref(indf,ig)))) & + + colco2(iplon,lay) * absco2(ig) +! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) + taur(iplon,lay,ngs28+ig) = tauray + enddo + + else + +! Upper atmosphere loop + ind0 = ((jp(iplon,lay) -13)*5+(jt(iplon,lay) -1))*nspb(29) + 1 + ind1 = ((jp(iplon,lay) -12)*5+(jt1(iplon,lay) -1))*nspb(29) + 1 + tauray = colmol(iplon,lay) * rayl + + do ig = 1, ng29 + taug(iplon,lay,ngs28+ig) = colco2(iplon,lay) * & + (fac00(iplon,lay) * absb(ind0,ig) + & + fac10(iplon,lay) * absb(ind0+1,ig) + & + fac01(iplon,lay) * absb(ind1,ig) + & + fac11(iplon,lay) * absb(ind1+1,ig)) & + + colh2o(iplon,lay) * absh2o(ig) +! ssa(lay,ngs28+ig) = tauray/taug(lay,ngs28+ig) + + taur(iplon,lay,ngs28+ig) = tauray + enddo + end if + + enddo + enddo + +!$acc end kernels +# undef ncol + end subroutine taumol29 + +# undef IKLOOP1_S +# undef IKLOOP1_E +# undef IKLOOP2_S +# undef IKLOOP2_E + + end module rrtmg_sw_taumol_f + + module rrtmg_sw_init_f + +! ------- Modules ------- + + use rrsw_wvn_f + use rrtmg_sw_setcoef_f, only: swatmref + + implicit none + + public rrtmg_sw_ini + + contains + +! ************************************************************************** + subroutine rrtmg_sw_ini(cpdair) +! ************************************************************************** +! +! Original version: Michael J. Iacono; February, 2004 +! Revision for F90 formatting: M. J. Iacono, July, 2006 +! +! This subroutine performs calculations necessary for the initialization +! of the shortwave model. Lookup tables are computed for use in the SW +! radiative transfer, and input absorption coefficient data for each +! spectral band are reduced from 224 g-point intervals to 112. +! ************************************************************************** + + use parrrsw_f, only : mg, nbndsw, ngptsw + use rrsw_tbl_f, only: ntbl, tblint, pade, bpade, tau_tbl, exp_tbl + use rrsw_vsn_f, only: hvrini, hnamini + + real , intent(in) :: cpdair ! Specific heat capacity of dry air + ! at constant pressure at 273 K + ! (J kg-1 K-1) + +! ------- Local ------- + + integer :: ibnd, igc, ig, ind, ipr + integer :: igcsm, iprsm + integer :: itr + + real :: wtsum, wtsm(mg) + real :: tfn + + real , parameter :: expeps = 1.e-20 ! Smallest value for exponential table + +! ------- Definitions ------- +! Arrays for 10000-point look-up tables: +! TAU_TBL Clear-sky optical depth +! EXP_TBL Exponential lookup table for transmittance +! PADE Pade approximation constant (= 0.278) +! BPADE Inverse of the Pade approximation constant +! + + hvrini = '$Revision: 1.5 $' + +! Initialize model data + call swdatinit(cpdair) + call swcmbdat ! g-point interval reduction data + call swaerpr ! aerosol optical properties + call swcldpr ! cloud optical properties + call swatmref ! reference MLS profile +! Moved to module_ra_rrtmg_swf for WRF +! call sw_kgb16 ! molecular absorption coefficients +! call sw_kgb17 +! call sw_kgb18 +! call sw_kgb19 +! call sw_kgb20 +! call sw_kgb21 +! call sw_kgb22 +! call sw_kgb23 +! call sw_kgb24 +! call sw_kgb25 +! call sw_kgb26 +! call sw_kgb27 +! call sw_kgb28 +! call sw_kgb29 + +! Define exponential lookup tables for transmittance. Tau is +! computed as a function of the tau transition function, and transmittance +! is calculated as a function of tau. All tables are computed at intervals +! of 0.0001. The inverse of the constant used in the Pade approximation to +! the tau transition function is set to bpade. + + exp_tbl(0) = 1.0 + exp_tbl(ntbl) = expeps + bpade = 1.0 / pade + do itr = 1, ntbl-1 + tfn = float(itr) / float(ntbl) + tau_tbl = bpade * tfn / (1. - tfn) + exp_tbl(itr) = exp(-tau_tbl) + if (exp_tbl(itr) .le. expeps) exp_tbl(itr) = expeps + enddo + +! Perform g-point reduction from 16 per band (224 total points) to +! a band dependent number (112 total points) for all absorption +! coefficient input data and Planck fraction input data. +! Compute relative weighting for new g-point combinations. + + igcsm = 0 + do ibnd = 1,nbndsw + iprsm = 0 + if (ngc(ibnd).lt.mg) then + do igc = 1,ngc(ibnd) + igcsm = igcsm + 1 + wtsum = 0. + do ipr = 1, ngn(igcsm) + iprsm = iprsm + 1 + wtsum = wtsum + wt(iprsm) + enddo + wtsm(igc) = wtsum + enddo + do ig = 1, ng(ibnd+15) + ind = (ibnd-1)*mg + ig + rwgt(ind) = wt(ig)/wtsm(ngm(ind)) + enddo + else + do ig = 1, ng(ibnd+15) + igcsm = igcsm + 1 + ind = (ibnd-1)*mg + ig + rwgt(ind) = 1.0 + enddo + endif + enddo + +! Reduce g-points for absorption coefficient data in each LW spectral band. + + call cmbgb16s + call cmbgb17 + call cmbgb18 + call cmbgb19 + call cmbgb20 + call cmbgb21 + call cmbgb22 + call cmbgb23 + call cmbgb24 + call cmbgb25 + call cmbgb26 + call cmbgb27 + call cmbgb28 + call cmbgb29 + + end subroutine rrtmg_sw_ini + +!*************************************************************************** + subroutine swdatinit(cpdair) +!*************************************************************************** + +! --------- Modules ---------- + + use rrsw_con_f, only: heatfac, grav, planck, boltz, & + clight, avogad, alosmt, gascon, radcn1, radcn2, & + sbcnst, secdy + use rrsw_vsn_f + + save + + real , intent(in) :: cpdair ! Specific heat capacity of dry air + ! at constant pressure at 273 K + ! (J kg-1 K-1) + +! Shortwave spectral band limits (wavenumbers) + wavenum1(:) = (/2600. , 3250. , 4000. , 4650. , 5150. , 6150. , 7700. , & + 8050. ,12850. ,16000. ,22650. ,29000. ,38000. , 820. /) + wavenum2(:) = (/3250. , 4000. , 4650. , 5150. , 6150. , 7700. , 8050. , & + 12850. ,16000. ,22650. ,29000. ,38000. ,50000. , 2600. /) + delwave(:) = (/ 650. , 750. , 650. , 500. , 1000. , 1550. , 350. , & + 4800. , 3150. , 6650. , 6350. , 9000. ,12000. , 1780. /) + +! Spectral band information + ng(:) = (/16,16,16,16,16,16,16,16,16,16,16,16,16,16/) + nspa(:) = (/9,9,9,9,1,9,9,1,9,1,0,1,9,1/) + nspb(:) = (/1,5,1,1,1,5,1,0,1,0,0,1,5,1/) + icxa(:) = (/ 5 ,5 ,4 ,4 ,3 ,3 ,2 ,2 ,1 ,1 ,1 ,1 ,1 ,5/) + +! Fundamental physical constants from NIST 2002 + + grav = 9.8066 ! Acceleration of gravity + ! (m s-2) + planck = 6.62606876e-27 ! Planck constant + ! (ergs s; g cm2 s-1) + boltz = 1.3806503e-16 ! Boltzmann constant + ! (ergs K-1; g cm2 s-2 K-1) + clight = 2.99792458e+10 ! Speed of light in a vacuum + ! (cm s-1) + avogad = 6.02214199e+23 ! Avogadro constant + ! (mol-1) + alosmt = 2.6867775e+19 ! Loschmidt constant + ! (cm-3) + gascon = 8.31447200e+07 ! Molar gas constant + ! (ergs mol-1 K-1) + radcn1 = 1.191042772e-12 ! First radiation constant + ! (W cm2 sr-1) + radcn2 = 1.4387752 ! Second radiation constant + ! (cm K) + sbcnst = 5.670400e-04 ! Stefan-Boltzmann constant + ! (W cm-2 K-4) + secdy = 8.6400e4 ! Number of seconds per day + ! (s d-1) +! +! units are generally cgs +! +! The first and second radiation constants are taken from NIST. +! They were previously obtained from the relations: +! radcn1 = 2.*planck*clight*clight*1.e-07 +! radcn2 = planck*clight/boltz + +! Heatfac is the factor by which delta-flux / delta-pressure is +! multiplied, with flux in W/m-2 and pressure in mbar, to get +! the heating rate in units of degrees/day. It is equal to: +! Original value: +! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p) +! Here, cpdair (1.004) is in units of J g-1 K-1, and the +! constant (1.e-5) converts mb to Pa and g-1 to kg-1. +! = (9.8066)(86400)(1e-5)/(1.004) +! heatfac = 8.4391 +! +! Modified value for consistency with CAM3: +! (g)x(#sec/day)x(1e-5)/(specific heat of air at const. p) +! Here, cpdair (1.00464) is in units of J g-1 K-1, and the +! constant (1.e-5) converts mb to Pa and g-1 to kg-1. +! = (9.80616)(86400)(1e-5)/(1.00464) +! heatfac = 8.43339130434 +! +! Calculated value (from constants above and input cpdair) +! (grav) x (#sec/day) / (specific heat of dry air at const. p x 1.e2) +! Here, cpdair is in units of J kg-1 K-1, and the constant (1.e2) +! converts mb to Pa when heatfac is multiplied by W m-2 mb-1. + heatfac = grav * secdy / (cpdair * 1.e2 ) + + end subroutine swdatinit + +!*************************************************************************** + subroutine swcmbdat +!*************************************************************************** + + save + +! ------- Definitions ------- +! Arrays for the g-point reduction from 224 to 112 for the 16 LW bands: +! This mapping from 224 to 112 points has been carefully selected to +! minimize the effect on the resulting fluxes and cooling rates, and +! caution should be used if the mapping is modified. The full 224 +! g-point set can be restored with ngpt=224, ngc=16*16, ngn=224*1., etc. +! ngpt The total number of new g-points +! ngc The number of new g-points in each band +! ngs The cumulative sum of new g-points for each band +! ngm The index of each new g-point relative to the original +! 16 g-points for each band. +! ngn The number of original g-points that are combined to make +! each new g-point in each band. +! ngb The band index for each new g-point. +! wt RRTM weights for 16 g-points. + +! Use this set for 112 quadrature point (g-point) model +! ------- Data statements ------- + ngc(:) = (/ 6,12, 8, 8,10,10, 2,10, 8, 6, 6, 8, 6,12 /) + ngs(:) = (/ 6,18,26,34,44,54,56,66,74,80,86,94,100,112 /) + ngm(:) = (/ 1,1,2,2,3,3,4,4,5,5,5,5,6,6,6,6, & ! band 16 + 1,2,3,4,5,6,6,7,8,8,9,10,10,11,12,12, & ! band 17 + 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 18 + 1,2,3,4,5,5,6,6,7,7,7,7,8,8,8,8, & ! band 19 + 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 20 + 1,2,3,4,5,6,7,8,9,9,10,10,10,10,10,10, & ! band 21 + 1,1,1,1,1,1,1,1,2,2,2,2,2,2,2,2, & ! band 22 + 1,1,2,2,3,4,5,6,7,8,9,9,10,10,10,10, & ! band 23 + 1,1,2,2,3,3,4,4,5,5,6,6,7,7,8,8, & ! band 24 + 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 25 + 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 26 + 1,2,3,4,5,6,7,7,7,7,8,8,8,8,8,8, & ! band 27 + 1,2,3,3,4,4,5,5,5,5,6,6,6,6,6,6, & ! band 28 + 1,2,3,4,5,5,6,6,7,7,8,8,9,10,11,12 /) ! band 29 + ngn(:) = (/ 2,2,2,2,4,4, & ! band 16 + 1,1,1,1,1,2,1,2,1,2,1,2, & ! band 17 + 1,1,1,1,2,2,4,4, & ! band 18 + 1,1,1,1,2,2,4,4, & ! band 19 + 1,1,1,1,1,1,1,1,2,6, & ! band 20 + 1,1,1,1,1,1,1,1,2,6, & ! band 21 + 8,8, & ! band 22 + 2,2,1,1,1,1,1,1,2,4, & ! band 23 + 2,2,2,2,2,2,2,2, & ! band 24 + 1,1,2,2,4,6, & ! band 25 + 1,1,2,2,4,6, & ! band 26 + 1,1,1,1,1,1,4,6, & ! band 27 + 1,1,2,2,4,6, & ! band 28 + 1,1,1,1,2,2,2,2,1,1,1,1 /) ! band 29 + ngb(:) = (/ 16,16,16,16,16,16, & ! band 16 + 17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17 + 18,18,18,18,18,18,18,18, & ! band 18 + 19,19,19,19,19,19,19,19, & ! band 19 + 20,20,20,20,20,20,20,20,20,20, & ! band 20 + 21,21,21,21,21,21,21,21,21,21, & ! band 21 + 22,22, & ! band 22 + 23,23,23,23,23,23,23,23,23,23, & ! band 23 + 24,24,24,24,24,24,24,24, & ! band 24 + 25,25,25,25,25,25, & ! band 25 + 26,26,26,26,26,26, & ! band 26 + 27,27,27,27,27,27,27,27, & ! band 27 + 28,28,28,28,28,28, & ! band 28 + 29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29 + +! Use this set for full 224 quadrature point (g-point) model +! ------- Data statements ------- +! ngc(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16 /) +! ngs(:) = (/ 16,32,48,64,80,96,112,128,144,160,176,192,208,224 /) +! ngm(:) = (/ 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 16 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 17 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 18 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 19 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 20 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 21 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 22 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 23 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 24 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 25 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 26 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 27 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16, & ! band 28 +! 1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16 /) ! band 29 +! ngn(:) = (/ 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 16 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 17 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 18 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 19 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 20 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 21 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 22 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 23 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 24 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 25 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 26 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 27 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, & ! band 28 +! 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1 /) ! band 29 +! ngb(:) = (/ 16,16,16,16,16,16,16,16,16,16,16,16,16,16,16,16, & ! band 16 +! 17,17,17,17,17,17,17,17,17,17,17,17,17,17,17,17, & ! band 17 +! 18,18,18,18,18,18,18,18,18,18,18,18,18,18,18,18, & ! band 18 +! 19,19,19,19,19,19,19,19,19,19,19,19,19,19,19,19, & ! band 19 +! 20,20,20,20,20,20,20,20,20,20,20,20,20,20,20,20, & ! band 20 +! 21,21,21,21,21,21,21,21,21,21,21,21,21,21,21,21, & ! band 21 +! 22,22,22,22,22,22,22,22,22,22,22,22,22,22,22,22, & ! band 22 +! 23,23,23,23,23,23,23,23,23,23,23,23,23,23,23,23, & ! band 23 +! 24,24,24,24,24,24,24,24,24,24,24,24,24,24,24,24, & ! band 24 +! 25,25,25,25,25,25,25,25,25,25,25,25,25,25,25,25, & ! band 25 +! 26,26,26,26,26,26,26,26,26,26,26,26,26,26,26,26, & ! band 26 +! 27,27,27,27,27,27,27,27,27,27,27,27,27,27,27,27, & ! band 27 +! 28,28,28,28,28,28,28,28,28,28,28,28,28,28,28,28, & ! band 28 +! 29,29,29,29,29,29,29,29,29,29,29,29,29,29,29,29 /) ! band 29 + + + wt(:) = (/ 0.1527534276 , 0.1491729617 , 0.1420961469 , & + 0.1316886544 , 0.1181945205 , 0.1019300893 , & + 0.0832767040 , 0.0626720116 , 0.0424925000 , & + 0.0046269894 , 0.0038279891 , 0.0030260086 , & + 0.0022199750 , 0.0014140010 , 0.0005330000 , & + 0.0000750000 /) + + end subroutine swcmbdat + +!*************************************************************************** + subroutine swaerpr +!*************************************************************************** + +! Purpose: Define spectral aerosol properties for six ECMWF aerosol types +! as used in the ECMWF IFS model (see module rrsw_aer.F90 for details) +! +! Original: Defined for rrtmg_sw 14 spectral bands, JJMorcrette, ECMWF Feb 2003 +! Revision: Reformatted for consistency with rrtmg_lw, MJIacono, AER, Jul 2006 + + use rrsw_aer_f, only : rsrtaua, rsrpiza, rsrasya + + save + + rsrtaua( 1, :) = (/ & + 0.10849 , 0.66699 , 0.65255 , 0.11600 , 0.06529 , 0.04468 /) + rsrtaua( 2, :) = (/ & + 0.10849 , 0.66699 , 0.65255 , 0.11600 , 0.06529 , 0.04468 /) + rsrtaua( 3, :) = (/ & + 0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /) + rsrtaua( 4, :) = (/ & + 0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /) + rsrtaua( 5, :) = (/ & + 0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /) + rsrtaua( 6, :) = (/ & + 0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /) + rsrtaua( 7, :) = (/ & + 0.20543 , 0.84642 , 0.84958 , 0.21673 , 0.28270 , 0.10915 /) + rsrtaua( 8, :) = (/ & + 0.52838 , 0.93285 , 0.93449 , 0.53078 , 0.67148 , 0.46608 /) + rsrtaua( 9, :) = (/ & + 0.52838 , 0.93285 , 0.93449 , 0.53078 , 0.67148 , 0.46608 /) + rsrtaua(10, :) = (/ & + 1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /) + rsrtaua(11, :) = (/ & + 1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /) + rsrtaua(12, :) = (/ & + 1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /) + rsrtaua(13, :) = (/ & + 1.69446 , 1.11855 , 1.09212 , 1.72145 , 1.03858 , 1.12044 /) + rsrtaua(14, :) = (/ & + 0.10849 , 0.66699 , 0.65255 , 0.11600 , 0.06529 , 0.04468 /) + + rsrpiza( 1, :) = (/ & + .5230504 , .7868518 , .8531531 , .4048149 , .8748231 , .2355667 /) + rsrpiza( 2, :) = (/ & + .5230504 , .7868518 , .8531531 , .4048149 , .8748231 , .2355667 /) + rsrpiza( 3, :) = (/ & + .8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /) + rsrpiza( 4, :) = (/ & + .8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /) + rsrpiza( 5, :) = (/ & + .8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /) + rsrpiza( 6, :) = (/ & + .8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /) + rsrpiza( 7, :) = (/ & + .8287144 , .9949396 , .9279543 , .6765051 , .9467578 , .9955938 /) + rsrpiza( 8, :) = (/ & + .8970131 , .9984940 , .9245594 , .7768385 , .9532763 , .9999999 /) + rsrpiza( 9, :) = (/ & + .8970131 , .9984940 , .9245594 , .7768385 , .9532763 , .9999999 /) + rsrpiza(10, :) = (/ & + .9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /) + rsrpiza(11, :) = (/ & + .9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /) + rsrpiza(12, :) = (/ & + .9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /) + rsrpiza(13, :) = (/ & + .9148907 , .9956173 , .7504584 , .8131335 , .9401905 , .9999999 /) + rsrpiza(14, :) = (/ & + .5230504 , .7868518 , .8531531 , .4048149 , .8748231 , .2355667 /) + + rsrasya( 1, :) = (/ & + 0.700610 , 0.818871 , 0.702399 , 0.689886 , .4629866 , .1907639 /) + rsrasya( 2, :) = (/ & + 0.700610 , 0.818871 , 0.702399 , 0.689886 , .4629866 , .1907639 /) + rsrasya( 3, :) = (/ & + 0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /) + rsrasya( 4, :) = (/ & + 0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /) + rsrasya( 5, :) = (/ & + 0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /) + rsrasya( 6, :) = (/ & + 0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /) + rsrasya( 7, :) = (/ & + 0.636342 , 0.802467 , 0.691305 , 0.627497 , .6105750 , .4760794 /) + rsrasya( 8, :) = (/ & + 0.668431 , 0.788530 , 0.698682 , 0.657422 , .6735182 , .6519706 /) + rsrasya( 9, :) = (/ & + 0.668431 , 0.788530 , 0.698682 , 0.657422 , .6735182 , .6519706 /) + rsrasya(10, :) = (/ & + 0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /) + rsrasya(11, :) = (/ & + 0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /) + rsrasya(12, :) = (/ & + 0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /) + rsrasya(13, :) = (/ & + 0.729019 , 0.803129 , 0.784592 , 0.712208 , .7008249 , .7270548 /) + rsrasya(14, :) = (/ & + 0.700610 , 0.818871 , 0.702399 , 0.689886 , .4629866 , .1907639 /) + + end subroutine swaerpr + +!*************************************************************************** + subroutine cmbgb16s +!*************************************************************************** +! +! Original version: MJIacono; July 1998 +! Revision for RRTM_SW: MJIacono; November 2002 +! Revision for RRTMG_SW: MJIacono; December 2003 +! Revision for F90 reformatting: MJIacono; July 2006 +! +! The subroutines CMBGB16->CMBGB29 input the absorption coefficient +! data for each band, which are defined for 16 g-points and 14 spectral +! bands. The data are combined with appropriate weighting following the +! g-point mapping arrays specified in RRTMG_SW_INIT. Solar source +! function data in array SFLUXREF are combined without weighting. All +! g-point reduced data are put into new arrays for use in RRTMG_SW. +! +! band 16: 2600-3250 cm-1 (low key- h2o,ch4; high key - ch4) +! +!----------------------------------------------------------------------- + + use rrsw_kg16_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(1) + sumk = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(1) + sumf = 0. + do ipr = 1, ngn(igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm) + enddo + sfluxref(igc) = sumf + enddo + + end subroutine cmbgb16s + +!*************************************************************************** + subroutine cmbgb17 +!*************************************************************************** +! +! band 17: 3250-4000 cm-1 (low - h2o,co2; high - h2o,co2) +!----------------------------------------------------------------------- + + use rrsw_kg17_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+16) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+16) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+16) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(2) + sumk = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+16) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,5 + iprsm = 0 + do igc = 1,ngc(2) + sumf = 0. + do ipr = 1, ngn(ngs(1)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb17 + +!*************************************************************************** + subroutine cmbgb18 +!*************************************************************************** +! +! band 18: 4000-4650 cm-1 (low - h2o,ch4; high - ch4) +!----------------------------------------------------------------------- + + use rrsw_kg18_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+32) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+32) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+32) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(3) + sumk = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+32) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(3) + sumf = 0. + do ipr = 1, ngn(ngs(2)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb18 + +!*************************************************************************** + subroutine cmbgb19 +!*************************************************************************** +! +! band 19: 4650-5150 cm-1 (low - h2o,co2; high - co2) +!----------------------------------------------------------------------- + + use rrsw_kg19_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+48) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+48) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+48) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(4) + sumk = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+48) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(4) + sumf = 0. + do ipr = 1, ngn(ngs(3)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb19 + +!*************************************************************************** + subroutine cmbgb20 +!*************************************************************************** +! +! band 20: 5150-6150 cm-1 (low - h2o; high - h2o) +!----------------------------------------------------------------------- + + use rrsw_kg20_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, absch4o, & + absa, ka, absb, kb, selfref, forref, sfluxref, absch4 + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+64) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+64) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+64) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(5) + sumk = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+64) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(5) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(4)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm) + sumf2 = sumf2 + absch4o(iprsm)*rwgt(iprsm+64) + enddo + sfluxref(igc) = sumf1 + absch4(igc) = sumf2 + enddo + + end subroutine cmbgb20 + +!*************************************************************************** + subroutine cmbgb21 +!*************************************************************************** +! +! band 21: 6150-7700 cm-1 (low - h2o,co2; high - h2o,co2) +!----------------------------------------------------------------------- + + use rrsw_kg21_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+80) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+80) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+80) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(6) + sumk = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+80) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(6) + sumf = 0. + do ipr = 1, ngn(ngs(5)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb21 + +!*************************************************************************** + subroutine cmbgb22 +!*************************************************************************** +! +! band 22: 7700-8050 cm-1 (low - h2o,o2; high - o2) +!----------------------------------------------------------------------- + + use rrsw_kg22_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absa, ka, absb, kb, selfref, forref, sfluxref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+96) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+96) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+96) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(7) + sumk = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+96) + enddo + forref(jt,igc) = sumk + enddo + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(7) + sumf = 0. + do ipr = 1, ngn(ngs(6)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb22 + +!*************************************************************************** + subroutine cmbgb23 +!*************************************************************************** +! +! band 23: 8050-12850 cm-1 (low - h2o; high - nothing) +!----------------------------------------------------------------------- + + use rrsw_kg23_f, only : kao, selfrefo, forrefo, sfluxrefo, raylo, & + absa, ka, selfref, forref, sfluxref, rayl + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+112) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+112) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(8) + sumk = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+112) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(8) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(7)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm) + sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+112) + enddo + sfluxref(igc) = sumf1 + rayl(igc) = sumf2 + enddo + + end subroutine cmbgb23 + +!*************************************************************************** + subroutine cmbgb24 +!*************************************************************************** +! +! band 24: 12850-16000 cm-1 (low - h2o,o2; high - o2) +!----------------------------------------------------------------------- + + use rrsw_kg24_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + abso3ao, abso3bo, raylao, raylbo, & + absa, ka, absb, kb, selfref, forref, sfluxref, & + abso3a, abso3b, rayla, raylb + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf1, sumf2, sumf3 + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+128) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+128) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+128) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,3 + iprsm = 0 + do igc = 1,ngc(9) + sumk = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+128) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(9) + sumf1 = 0. + sumf2 = 0. + sumf3 = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + raylbo(iprsm)*rwgt(iprsm+128) + sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+128) + sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+128) + enddo + raylb(igc) = sumf1 + abso3a(igc) = sumf2 + abso3b(igc) = sumf3 + enddo + + do jp = 1,9 + iprsm = 0 + do igc = 1,ngc(9) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(8)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm,jp) + sumf2 = sumf2 + raylao(iprsm,jp)*rwgt(iprsm+128) + enddo + sfluxref(igc,jp) = sumf1 + rayla(igc,jp) = sumf2 + enddo + enddo + + end subroutine cmbgb24 + +!*************************************************************************** + subroutine cmbgb25 +!*************************************************************************** +! +! band 25: 16000-22650 cm-1 (low - h2o; high - nothing) +!----------------------------------------------------------------------- + + use rrsw_kg25_f, only : kao, sfluxrefo, & + abso3ao, abso3bo, raylo, & + absa, ka, sfluxref, & + abso3a, abso3b, rayl + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumf1, sumf2, sumf3, sumf4 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(10) + sumk = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+144) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(10) + sumf1 = 0. + sumf2 = 0. + sumf3 = 0. + sumf4 = 0. + do ipr = 1, ngn(ngs(9)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm) + sumf2 = sumf2 + abso3ao(iprsm)*rwgt(iprsm+144) + sumf3 = sumf3 + abso3bo(iprsm)*rwgt(iprsm+144) + sumf4 = sumf4 + raylo(iprsm)*rwgt(iprsm+144) + enddo + sfluxref(igc) = sumf1 + abso3a(igc) = sumf2 + abso3b(igc) = sumf3 + rayl(igc) = sumf4 + enddo + + end subroutine cmbgb25 + +!*************************************************************************** + subroutine cmbgb26 +!*************************************************************************** +! +! band 26: 22650-29000 cm-1 (low - nothing; high - nothing) +!----------------------------------------------------------------------- + + use rrsw_kg26_f, only : sfluxrefo, raylo, & + sfluxref, rayl + +! ------- Local ------- + integer :: igc, ipr, iprsm + real :: sumf1, sumf2 + + + iprsm = 0 + do igc = 1,ngc(11) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(10)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + raylo(iprsm)*rwgt(iprsm+160) + sumf2 = sumf2 + sfluxrefo(iprsm) + enddo + rayl(igc) = sumf1 + sfluxref(igc) = sumf2 + enddo + + end subroutine cmbgb26 + +!*************************************************************************** + subroutine cmbgb27 +!*************************************************************************** +! +! band 27: 29000-38000 cm-1 (low - o3; high - o3) +!----------------------------------------------------------------------- + + use rrsw_kg27_f, only : kao, kbo, sfluxrefo, raylo, & + absa, ka, absb, kb, sfluxref, rayl + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumf1, sumf2 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(12) + sumk = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+176) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(12) + sumk = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+176) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(12) + sumf1 = 0. + sumf2 = 0. + do ipr = 1, ngn(ngs(11)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm) + sumf2 = sumf2 + raylo(iprsm)*rwgt(iprsm+176) + enddo + sfluxref(igc) = sumf1 + rayl(igc) = sumf2 + enddo + + end subroutine cmbgb27 + +!*************************************************************************** + subroutine cmbgb28 +!*************************************************************************** +! +! band 28: 38000-50000 cm-1 (low - o3,o2; high - o3,o2) +!----------------------------------------------------------------------- + + use rrsw_kg28_f, only : kao, kbo, sfluxrefo, & + absa, ka, absb, kb, sfluxref + +! ------- Local ------- + integer :: jn, jt, jp, igc, ipr, iprsm + real :: sumk, sumf + + + do jn = 1,9 + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jn,jt,jp,iprsm)*rwgt(iprsm+192) + enddo + ka(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jn = 1,5 + do jt = 1,5 + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(13) + sumk = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jn,jt,jp,iprsm)*rwgt(iprsm+192) + enddo + kb(jn,jt,jp,igc) = sumk + enddo + enddo + enddo + enddo + + do jp = 1,5 + iprsm = 0 + do igc = 1,ngc(13) + sumf = 0. + do ipr = 1, ngn(ngs(12)+igc) + iprsm = iprsm + 1 + sumf = sumf + sfluxrefo(iprsm,jp) + enddo + sfluxref(igc,jp) = sumf + enddo + enddo + + end subroutine cmbgb28 + +!*************************************************************************** + subroutine cmbgb29 +!*************************************************************************** +! +! band 29: 820-2600 cm-1 (low - h2o; high - co2) +!----------------------------------------------------------------------- + + use rrsw_kg29_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absh2oo, absco2o, & + absa, ka, absb, kb, selfref, forref, sfluxref, & + absh2o, absco2 + +! ------- Local ------- + integer :: jt, jp, igc, ipr, iprsm + real :: sumk, sumf1, sumf2, sumf3 + + + do jt = 1,5 + do jp = 1,13 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + kao(jt,jp,iprsm)*rwgt(iprsm+208) + enddo + ka(jt,jp,igc) = sumk + enddo + enddo + do jp = 13,59 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + kbo(jt,jp,iprsm)*rwgt(iprsm+208) + enddo + kb(jt,jp,igc) = sumk + enddo + enddo + enddo + + do jt = 1,10 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + selfrefo(jt,iprsm)*rwgt(iprsm+208) + enddo + selfref(jt,igc) = sumk + enddo + enddo + + do jt = 1,4 + iprsm = 0 + do igc = 1,ngc(14) + sumk = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumk = sumk + forrefo(jt,iprsm)*rwgt(iprsm+208) + enddo + forref(jt,igc) = sumk + enddo + enddo + + iprsm = 0 + do igc = 1,ngc(14) + sumf1 = 0. + sumf2 = 0. + sumf3 = 0. + do ipr = 1, ngn(ngs(13)+igc) + iprsm = iprsm + 1 + sumf1 = sumf1 + sfluxrefo(iprsm) + sumf2 = sumf2 + absco2o(iprsm)*rwgt(iprsm+208) + sumf3 = sumf3 + absh2oo(iprsm)*rwgt(iprsm+208) + enddo + sfluxref(igc) = sumf1 + absco2(igc) = sumf2 + absh2o(igc) = sumf3 + enddo + + end subroutine cmbgb29 + +!*********************************************************************** + subroutine swcldpr +!*********************************************************************** + +! Purpose: Define cloud extinction coefficient, single scattering albedo +! and asymmetry parameter data. +! + +! ------- Modules ------- + + use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, & + extice2, ssaice2, asyice2, & + extice3, ssaice3, asyice3, fdlice3, & + abari, bbari, cbari, dbari, ebari, fbari + + save + +!----------------------------------------------------------------------- +! +! Explanation of the method for each value of INFLAG. A value of +! 0 for INFLAG do not distingish being liquid and ice clouds. +! INFLAG = 2 does distinguish between liquid and ice clouds, and +! requires further user input to specify the method to be used to +! compute the aborption due to each. +! INFLAG = 0: For each cloudy layer, the cloud fraction, the cloud optical +! depth, the cloud single-scattering albedo, and the +! moments of the phase function (0:NSTREAM). Note +! that these values are delta-m scaled within this +! subroutine. + +! INFLAG = 2: For each cloudy layer, the cloud fraction, cloud +! water path (g/m2), and cloud ice fraction are input. +! ICEFLAG = 2: The ice effective radius (microns) is input and the +! optical properties due to ice clouds are computed from +! the optical properties stored in the RT code, STREAMER v3.0 +! (Reference: Key. J., Streamer User's Guide, Cooperative +! Institute for Meteorological Satellite Studies, 2001, 96 pp.). +! Valid range of values for re are between 5.0 and +! 131.0 micron. +! This version uses Ebert and Curry, JGR, (1992) method for +! ice particles larger than 131.0 microns. +! ICEFLAG = 3: The ice generalized effective size (dge) is input +! and the optical depths, single-scattering albedo, +! and phase function moments are calculated as in +! Q. Fu, J. Climate, (1996). Q. Fu provided high resolution +! tables which were appropriately averaged for the +! bands in RRTM_SW. Linear interpolation is used to +! get the coefficients from the stored tables. +! Valid range of values for dge are between 5.0 and +! 140.0 micron. +! This version uses Ebert and Curry, JGR, (1992) method for +! ice particles larger than 140.0 microns. +! LIQFLAG = 1: The water droplet effective radius (microns) is input +! and the optical depths due to water clouds are computed +! as in Hu and Stamnes, J., Clim., 6, 728-742, (1993) with +! modified coefficients derived from Mie scattering calculations. +! The values for absorption coefficients appropriate for +! the spectral bands in RRTM/RRTMG have been obtained for a +! range of effective radii by an averaging procedure +! based on the work of J. Pinto (private communication). +! Linear interpolation is used to get the absorption +! coefficients for the input effective radius. +! ..Updated tables suggested by Peter Blossey (Univ. Washington) +! and came from RRTMG_SW_v3.9 from AER, Inc. +! +! ------------------------------------------------------------------ + +! Everything below is for INFLAG = 2. + +! Coefficients for Ebert and Curry method + abari(:) = (/ & + & 3.448e-03 ,3.448e-03 ,3.448e-03 ,3.448e-03 ,3.448e-03 /) + bbari(:) = (/ & + & 2.431e+00 ,2.431e+00 ,2.431e+00 ,2.431e+00 ,2.431e+00 /) + cbari(:) = (/ & + & 1.000e-05 ,1.100e-04 ,1.240e-02 ,3.779e-02 ,4.666e-01 /) + dbari(:) = (/ & + & 0.000e+00 ,1.405e-05 ,6.867e-04 ,1.284e-03 ,2.050e-05 /) + ebari(:) = (/ & + & 7.661e-01 ,7.730e-01 ,7.865e-01 ,8.172e-01 ,9.595e-01 /) + fbari(:) = (/ & + & 5.851e-04 ,5.665e-04 ,7.204e-04 ,7.463e-04 ,1.076e-04 /) + +! LIQFLAG==1 extinction coefficients, single scattering albedos, and asymmetry parameters +! Derived from on Mie scattering computations; based on Hu & Stamnes coefficients + +! Extinction coefficient +! BAND 16 + extliq1(:, 16) = (/ & + & 9.004493E-01,6.366723E-01,4.542354E-01,3.468253E-01,2.816431E-01,& + & 2.383415E-01,2.070854E-01,1.831854E-01,1.642115E-01,1.487539E-01,& + & 1.359169E-01,1.250900E-01,1.158354E-01,1.078400E-01,1.008646E-01,& + & 9.472307E-02,8.928000E-02,8.442308E-02,8.005924E-02,7.612231E-02,& + & 7.255153E-02,6.929539E-02,6.631769E-02,6.358153E-02,6.106231E-02,& + & 5.873077E-02,5.656924E-02,5.455769E-02,5.267846E-02,5.091923E-02,& + & 4.926692E-02,4.771154E-02,4.623923E-02,4.484385E-02,4.351539E-02,& + & 4.224615E-02,4.103385E-02,3.986538E-02,3.874077E-02,3.765462E-02,& + & 3.660077E-02,3.557384E-02,3.457615E-02,3.360308E-02,3.265000E-02,& + & 3.171770E-02,3.080538E-02,2.990846E-02,2.903000E-02,2.816461E-02,& + & 2.731539E-02,2.648231E-02,2.566308E-02,2.485923E-02,2.407000E-02,& + & 2.329615E-02,2.253769E-02,2.179615E-02 /) +! BAND 17 + extliq1(:, 17) = (/ & + & 6.741200e-01,5.390739e-01,4.198767e-01,3.332553e-01,2.735633e-01,& + & 2.317727e-01,2.012760e-01,1.780400e-01,1.596927e-01,1.447980e-01,& + & 1.324480e-01,1.220347e-01,1.131327e-01,1.054313e-01,9.870534e-02,& + & 9.278200e-02,8.752599e-02,8.282933e-02,7.860600e-02,7.479133e-02,& + & 7.132800e-02,6.816733e-02,6.527401e-02,6.261266e-02,6.015934e-02,& + & 5.788867e-02,5.578134e-02,5.381667e-02,5.198133e-02,5.026067e-02,& + & 4.864466e-02,4.712267e-02,4.568066e-02,4.431200e-02,4.300867e-02,& + & 4.176600e-02,4.057400e-02,3.942534e-02,3.832066e-02,3.725068e-02,& + & 3.621400e-02,3.520533e-02,3.422333e-02,3.326400e-02,3.232467e-02,& + & 3.140535e-02,3.050400e-02,2.962000e-02,2.875267e-02,2.789800e-02,& + & 2.705934e-02,2.623667e-02,2.542667e-02,2.463200e-02,2.385267e-02,& + & 2.308667e-02,2.233667e-02,2.160067e-02 /) +! BAND 18 + extliq1(:, 18) = (/ & + & 9.250861e-01,6.245692e-01,4.347038e-01,3.320208e-01,2.714869e-01,& + & 2.309516e-01,2.012592e-01,1.783315e-01,1.600369e-01,1.451000e-01,& + & 1.326838e-01,1.222069e-01,1.132554e-01,1.055146e-01,9.876000e-02,& + & 9.281386e-02,8.754000e-02,8.283078e-02,7.860077e-02,7.477769e-02,& + & 7.130847e-02,6.814461e-02,6.524615e-02,6.258462e-02,6.012847e-02,& + & 5.785462e-02,5.574231e-02,5.378000e-02,5.194461e-02,5.022462e-02,& + & 4.860846e-02,4.708462e-02,4.564154e-02,4.427462e-02,4.297231e-02,& + & 4.172769e-02,4.053693e-02,3.939000e-02,3.828462e-02,3.721692e-02,& + & 3.618000e-02,3.517077e-02,3.418923e-02,3.323077e-02,3.229154e-02,& + & 3.137154e-02,3.047154e-02,2.959077e-02,2.872308e-02,2.786846e-02,& + & 2.703077e-02,2.620923e-02,2.540077e-02,2.460615e-02,2.382693e-02,& + & 2.306231e-02,2.231231e-02,2.157923e-02 /) +! BAND 19 + extliq1(:, 19) = (/ & + & 9.298960e-01,5.776460e-01,4.083450e-01,3.211160e-01,2.666390e-01,& + & 2.281990e-01,1.993250e-01,1.768080e-01,1.587810e-01,1.440390e-01,& + & 1.317720e-01,1.214150e-01,1.125540e-01,1.048890e-01,9.819600e-02,& + & 9.230201e-02,8.706900e-02,8.239698e-02,7.819500e-02,7.439899e-02,& + & 7.095300e-02,6.780700e-02,6.492900e-02,6.228600e-02,5.984600e-02,& + & 5.758599e-02,5.549099e-02,5.353801e-02,5.171400e-02,5.000500e-02,& + & 4.840000e-02,4.688500e-02,4.545100e-02,4.409300e-02,4.279700e-02,& + & 4.156100e-02,4.037700e-02,3.923800e-02,3.813800e-02,3.707600e-02,& + & 3.604500e-02,3.504300e-02,3.406500e-02,3.310800e-02,3.217700e-02,& + & 3.126600e-02,3.036800e-02,2.948900e-02,2.862400e-02,2.777500e-02,& + & 2.694200e-02,2.612300e-02,2.531700e-02,2.452800e-02,2.375100e-02,& + & 2.299100e-02,2.224300e-02,2.151201e-02 /) +! BAND 20 + extliq1(:, 20) = (/ & + & 8.780964e-01,5.407031e-01,3.961100e-01,3.166645e-01,2.640455e-01,& + & 2.261070e-01,1.974820e-01,1.751775e-01,1.573415e-01,1.427725e-01,& + & 1.306535e-01,1.204195e-01,1.116650e-01,1.040915e-01,9.747550e-02,& + & 9.164800e-02,8.647649e-02,8.185501e-02,7.770200e-02,7.394749e-02,& + & 7.053800e-02,6.742700e-02,6.457999e-02,6.196149e-02,5.954450e-02,& + & 5.730650e-02,5.522949e-02,5.329450e-02,5.148500e-02,4.979000e-02,& + & 4.819600e-02,4.669301e-02,4.527050e-02,4.391899e-02,4.263500e-02,& + & 4.140500e-02,4.022850e-02,3.909500e-02,3.800199e-02,3.694600e-02,& + & 3.592000e-02,3.492250e-02,3.395050e-02,3.300150e-02,3.207250e-02,& + & 3.116250e-02,3.027100e-02,2.939500e-02,2.853500e-02,2.768900e-02,& + & 2.686000e-02,2.604350e-02,2.524150e-02,2.445350e-02,2.368049e-02,& + & 2.292150e-02,2.217800e-02,2.144800e-02 /) +! BAND 21 + extliq1(:, 21) = (/ & + & 7.937480e-01,5.123036e-01,3.858181e-01,3.099622e-01,2.586829e-01,& + & 2.217587e-01,1.939755e-01,1.723397e-01,1.550258e-01,1.408600e-01,& + & 1.290545e-01,1.190661e-01,1.105039e-01,1.030848e-01,9.659387e-02,& + & 9.086775e-02,8.577807e-02,8.122452e-02,7.712711e-02,7.342193e-02,& + & 7.005387e-02,6.697840e-02,6.416000e-02,6.156903e-02,5.917484e-02,& + & 5.695807e-02,5.489968e-02,5.298097e-02,5.118806e-02,4.950645e-02,& + & 4.792710e-02,4.643581e-02,4.502484e-02,4.368547e-02,4.241001e-02,& + & 4.118936e-02,4.002193e-02,3.889711e-02,3.781322e-02,3.676387e-02,& + & 3.574549e-02,3.475548e-02,3.379033e-02,3.284678e-02,3.192420e-02,& + & 3.102032e-02,3.013484e-02,2.926258e-02,2.840839e-02,2.756742e-02,& + & 2.674258e-02,2.593064e-02,2.513258e-02,2.435000e-02,2.358064e-02,& + & 2.282581e-02,2.208548e-02,2.135936e-02 /) +! BAND 22 + extliq1(:, 22) = (/ & + & 7.533129e-01,5.033129e-01,3.811271e-01,3.062757e-01,2.558729e-01,& + & 2.196828e-01,1.924372e-01,1.711714e-01,1.541086e-01,1.401114e-01,& + & 1.284257e-01,1.185200e-01,1.100243e-01,1.026529e-01,9.620142e-02,& + & 9.050714e-02,8.544428e-02,8.091714e-02,7.684000e-02,7.315429e-02,& + & 6.980143e-02,6.673999e-02,6.394000e-02,6.136000e-02,5.897715e-02,& + & 5.677000e-02,5.472285e-02,5.281286e-02,5.102858e-02,4.935429e-02,& + & 4.778000e-02,4.629714e-02,4.489142e-02,4.355857e-02,4.228715e-02,& + & 4.107285e-02,3.990857e-02,3.879000e-02,3.770999e-02,3.666429e-02,& + & 3.565000e-02,3.466286e-02,3.370143e-02,3.276143e-02,3.184143e-02,& + & 3.094000e-02,3.005714e-02,2.919000e-02,2.833714e-02,2.750000e-02,& + & 2.667714e-02,2.586714e-02,2.507143e-02,2.429143e-02,2.352428e-02,& + & 2.277143e-02,2.203429e-02,2.130857e-02 /) +! BAND 23 + extliq1(:, 23) = (/ & + & 7.079894e-01,4.878198e-01,3.719852e-01,3.001873e-01,2.514795e-01,& + & 2.163013e-01,1.897100e-01,1.689033e-01,1.521793e-01,1.384449e-01,& + & 1.269666e-01,1.172326e-01,1.088745e-01,1.016224e-01,9.527085e-02,& + & 8.966240e-02,8.467543e-02,8.021144e-02,7.619344e-02,7.255676e-02,& + & 6.924996e-02,6.623030e-02,6.346261e-02,6.091499e-02,5.856325e-02,& + & 5.638385e-02,5.435930e-02,5.247156e-02,5.070699e-02,4.905230e-02,& + & 4.749499e-02,4.602611e-02,4.463581e-02,4.331543e-02,4.205647e-02,& + & 4.085241e-02,3.969978e-02,3.859033e-02,3.751877e-02,3.648168e-02,& + & 3.547468e-02,3.449553e-02,3.354072e-02,3.260732e-02,3.169438e-02,& + & 3.079969e-02,2.992146e-02,2.905875e-02,2.821201e-02,2.737873e-02,& + & 2.656052e-02,2.575586e-02,2.496511e-02,2.418783e-02,2.342500e-02,& + & 2.267646e-02,2.194177e-02,2.122146e-02 /) +! BAND 24 + extliq1(:, 24) = (/ & + & 6.850164e-01,4.762468e-01,3.642001e-01,2.946012e-01,2.472001e-01,& + & 2.128588e-01,1.868537e-01,1.664893e-01,1.501142e-01,1.366620e-01,& + & 1.254147e-01,1.158721e-01,1.076732e-01,1.005530e-01,9.431306e-02,& + & 8.879891e-02,8.389232e-02,7.949714e-02,7.553857e-02,7.195474e-02,& + & 6.869413e-02,6.571444e-02,6.298286e-02,6.046779e-02,5.814474e-02,& + & 5.599141e-02,5.399114e-02,5.212443e-02,5.037870e-02,4.874321e-02,& + & 4.720219e-02,4.574813e-02,4.437160e-02,4.306460e-02,4.181810e-02,& + & 4.062603e-02,3.948252e-02,3.838256e-02,3.732049e-02,3.629192e-02,& + & 3.529301e-02,3.432190e-02,3.337412e-02,3.244842e-02,3.154175e-02,& + & 3.065253e-02,2.978063e-02,2.892367e-02,2.808221e-02,2.725478e-02,& + & 2.644174e-02,2.564175e-02,2.485508e-02,2.408303e-02,2.332365e-02,& + & 2.257890e-02,2.184824e-02,2.113224e-02 /) +! BAND 25 + extliq1(:, 25) = (/ & + & 6.673017e-01,4.664520e-01,3.579398e-01,2.902234e-01,2.439904e-01,& + & 2.104149e-01,1.849277e-01,1.649234e-01,1.488087e-01,1.355515e-01,& + & 1.244562e-01,1.150329e-01,1.069321e-01,9.989310e-02,9.372070e-02,& + & 8.826450e-02,8.340622e-02,7.905378e-02,7.513109e-02,7.157859e-02,& + & 6.834588e-02,6.539114e-02,6.268150e-02,6.018621e-02,5.788098e-02,& + & 5.574351e-02,5.375699e-02,5.190412e-02,5.017099e-02,4.854497e-02,& + & 4.701490e-02,4.557030e-02,4.420249e-02,4.290304e-02,4.166427e-02,& + & 4.047820e-02,3.934232e-02,3.824778e-02,3.719236e-02,3.616931e-02,& + & 3.517597e-02,3.420856e-02,3.326566e-02,3.234346e-02,3.144122e-02,& + & 3.055684e-02,2.968798e-02,2.883519e-02,2.799635e-02,2.717228e-02,& + & 2.636182e-02,2.556424e-02,2.478114e-02,2.401086e-02,2.325657e-02,& + & 2.251506e-02,2.178594e-02,2.107301e-02 /) +! BAND 26 + extliq1(:, 26) = (/ & + & 6.552414e-01,4.599454e-01,3.538626e-01,2.873547e-01,2.418033e-01,& + & 2.086660e-01,1.834885e-01,1.637142e-01,1.477767e-01,1.346583e-01,& + & 1.236734e-01,1.143412e-01,1.063148e-01,9.933905e-02,9.322026e-02,& + & 8.780979e-02,8.299230e-02,7.867554e-02,7.478450e-02,7.126053e-02,& + & 6.805276e-02,6.512143e-02,6.243211e-02,5.995541e-02,5.766712e-02,& + & 5.554484e-02,5.357246e-02,5.173222e-02,5.001069e-02,4.839505e-02,& + & 4.687471e-02,4.543861e-02,4.407857e-02,4.278577e-02,4.155331e-02,& + & 4.037322e-02,3.924302e-02,3.815376e-02,3.710172e-02,3.608296e-02,& + & 3.509330e-02,3.412980e-02,3.319009e-02,3.227106e-02,3.137157e-02,& + & 3.048950e-02,2.962365e-02,2.877297e-02,2.793726e-02,2.711500e-02,& + & 2.630666e-02,2.551206e-02,2.473052e-02,2.396287e-02,2.320861e-02,& + & 2.246810e-02,2.174162e-02,2.102927e-02 /) +! BAND 27 + extliq1(:, 27) = (/ & + & 6.430901e-01,4.532134e-01,3.496132e-01,2.844655e-01,2.397347e-01,& + & 2.071236e-01,1.822976e-01,1.627640e-01,1.469961e-01,1.340006e-01,& + & 1.231069e-01,1.138441e-01,1.058706e-01,9.893678e-02,9.285166e-02,& + & 8.746871e-02,8.267411e-02,7.837656e-02,7.450257e-02,7.099318e-02,& + & 6.779929e-02,6.487987e-02,6.220168e-02,5.973530e-02,5.745636e-02,& + & 5.534344e-02,5.337986e-02,5.154797e-02,4.983404e-02,4.822582e-02,& + & 4.671228e-02,4.528321e-02,4.392997e-02,4.264325e-02,4.141647e-02,& + & 4.024259e-02,3.911767e-02,3.803309e-02,3.698782e-02,3.597140e-02,& + & 3.498774e-02,3.402852e-02,3.309340e-02,3.217818e-02,3.128292e-02,& + & 3.040486e-02,2.954230e-02,2.869545e-02,2.786261e-02,2.704372e-02,& + & 2.623813e-02,2.544668e-02,2.466788e-02,2.390313e-02,2.315136e-02,& + & 2.241391e-02,2.168921e-02,2.097903e-02 /) +! BAND 28 + extliq1(:, 28) = (/ & + & 6.367074e-01,4.495768e-01,3.471263e-01,2.826149e-01,2.382868e-01,& + & 2.059640e-01,1.813562e-01,1.619881e-01,1.463436e-01,1.334402e-01,& + & 1.226166e-01,1.134096e-01,1.054829e-01,9.858838e-02,9.253790e-02,& + & 8.718582e-02,8.241830e-02,7.814482e-02,7.429212e-02,7.080165e-02,& + & 6.762385e-02,6.471838e-02,6.205388e-02,5.959726e-02,5.732871e-02,& + & 5.522402e-02,5.326793e-02,5.144230e-02,4.973440e-02,4.813188e-02,& + & 4.662283e-02,4.519798e-02,4.384833e-02,4.256541e-02,4.134253e-02,& + & 4.017136e-02,3.904911e-02,3.796779e-02,3.692364e-02,3.591182e-02,& + & 3.492930e-02,3.397230e-02,3.303920e-02,3.212572e-02,3.123278e-02,& + & 3.035519e-02,2.949493e-02,2.864985e-02,2.781840e-02,2.700197e-02,& + & 2.619682e-02,2.540674e-02,2.462966e-02,2.386613e-02,2.311602e-02,& + & 2.237846e-02,2.165660e-02,2.094756e-02 /) +! BAND 29 + extliq1(:, 29) = (/ & + & 4.298416e-01,4.391639e-01,3.975030e-01,3.443028e-01,2.957345e-01,& + & 2.556461e-01,2.234755e-01,1.976636e-01,1.767428e-01,1.595611e-01,& + & 1.452636e-01,1.332156e-01,1.229481e-01,1.141059e-01,1.064208e-01,& + & 9.968527e-02,9.373833e-02,8.845221e-02,8.372112e-02,7.946667e-02,& + & 7.561807e-02,7.212029e-02,6.893166e-02,6.600944e-02,6.332277e-02,& + & 6.084277e-02,5.854721e-02,5.641361e-02,5.442639e-02,5.256750e-02,& + & 5.082499e-02,4.918556e-02,4.763694e-02,4.617222e-02,4.477861e-02,& + & 4.344861e-02,4.217999e-02,4.096111e-02,3.978638e-02,3.865361e-02,& + & 3.755473e-02,3.649028e-02,3.545361e-02,3.444361e-02,3.345666e-02,& + & 3.249167e-02,3.154722e-02,3.062083e-02,2.971250e-02,2.882083e-02,& + & 2.794611e-02,2.708778e-02,2.624500e-02,2.541750e-02,2.460528e-02,& + & 2.381194e-02,2.303250e-02,2.226833e-02 /) + +! Single scattering albedo +! BAND 16 + ssaliq1(:, 16) = (/ & + & 8.362119e-01,8.098460e-01,7.762291e-01,7.486042e-01,7.294172e-01,& + & 7.161000e-01,7.060656e-01,6.978387e-01,6.907193e-01,6.843551e-01,& + & 6.785668e-01,6.732450e-01,6.683191e-01,6.637264e-01,6.594307e-01,& + & 6.554033e-01,6.516115e-01,6.480295e-01,6.446429e-01,6.414306e-01,& + & 6.383783e-01,6.354750e-01,6.327068e-01,6.300665e-01,6.275376e-01,& + & 6.251245e-01,6.228136e-01,6.205944e-01,6.184720e-01,6.164330e-01,& + & 6.144742e-01,6.125962e-01,6.108004e-01,6.090740e-01,6.074200e-01,& + & 6.058381e-01,6.043209e-01,6.028681e-01,6.014836e-01,6.001626e-01,& + & 5.988957e-01,5.976864e-01,5.965390e-01,5.954379e-01,5.943972e-01,& + & 5.934019e-01,5.924624e-01,5.915579e-01,5.907025e-01,5.898913e-01,& + & 5.891213e-01,5.883815e-01,5.876851e-01,5.870158e-01,5.863868e-01,& + & 5.857821e-01,5.852111e-01,5.846579e-01 /) +! BAND 17 + ssaliq1(:, 17) = (/ & + & 6.995459e-01,7.158012e-01,7.076001e-01,6.927244e-01,6.786434e-01,& + & 6.673545e-01,6.585859e-01,6.516314e-01,6.459010e-01,6.410225e-01,& + & 6.367574e-01,6.329554e-01,6.295119e-01,6.263595e-01,6.234462e-01,& + & 6.207274e-01,6.181755e-01,6.157678e-01,6.134880e-01,6.113173e-01,& + & 6.092495e-01,6.072689e-01,6.053717e-01,6.035507e-01,6.018001e-01,& + & 6.001134e-01,5.984951e-01,5.969294e-01,5.954256e-01,5.939698e-01,& + & 5.925716e-01,5.912265e-01,5.899270e-01,5.886771e-01,5.874746e-01,& + & 5.863185e-01,5.852077e-01,5.841460e-01,5.831249e-01,5.821474e-01,& + & 5.812078e-01,5.803173e-01,5.794616e-01,5.786443e-01,5.778617e-01,& + & 5.771236e-01,5.764191e-01,5.757400e-01,5.750971e-01,5.744842e-01,& + & 5.739012e-01,5.733482e-01,5.728175e-01,5.723214e-01,5.718383e-01,& + & 5.713827e-01,5.709471e-01,5.705330e-01 /) +! BAND 18 + ssaliq1(:, 18) = (/ & + & 9.929711e-01,9.896942e-01,9.852408e-01,9.806820e-01,9.764512e-01,& + & 9.725375e-01,9.688677e-01,9.653832e-01,9.620552e-01,9.588522e-01,& + & 9.557475e-01,9.527265e-01,9.497731e-01,9.468756e-01,9.440270e-01,& + & 9.412230e-01,9.384592e-01,9.357287e-01,9.330369e-01,9.303778e-01,& + & 9.277502e-01,9.251546e-01,9.225907e-01,9.200553e-01,9.175521e-01,& + & 9.150773e-01,9.126352e-01,9.102260e-01,9.078485e-01,9.055057e-01,& + & 9.031978e-01,9.009306e-01,8.987010e-01,8.965177e-01,8.943774e-01,& + & 8.922869e-01,8.902430e-01,8.882551e-01,8.863182e-01,8.844373e-01,& + & 8.826143e-01,8.808499e-01,8.791413e-01,8.774940e-01,8.759019e-01,& + & 8.743650e-01,8.728941e-01,8.714712e-01,8.701065e-01,8.688008e-01,& + & 8.675409e-01,8.663295e-01,8.651714e-01,8.640637e-01,8.629943e-01,& + & 8.619762e-01,8.609995e-01,8.600581e-01 /) +! BAND 19 + ssaliq1(:, 19) = (/ & + & 9.910612e-01,9.854226e-01,9.795008e-01,9.742920e-01,9.695996e-01,& + & 9.652274e-01,9.610648e-01,9.570521e-01,9.531397e-01,9.493086e-01,& + & 9.455413e-01,9.418362e-01,9.381902e-01,9.346016e-01,9.310718e-01,& + & 9.275957e-01,9.241757e-01,9.208038e-01,9.174802e-01,9.142058e-01,& + & 9.109753e-01,9.077895e-01,9.046433e-01,9.015409e-01,8.984784e-01,& + & 8.954572e-01,8.924748e-01,8.895367e-01,8.866395e-01,8.837864e-01,& + & 8.809819e-01,8.782267e-01,8.755231e-01,8.728712e-01,8.702802e-01,& + & 8.677443e-01,8.652733e-01,8.628678e-01,8.605300e-01,8.582593e-01,& + & 8.560596e-01,8.539352e-01,8.518782e-01,8.498915e-01,8.479790e-01,& + & 8.461384e-01,8.443645e-01,8.426613e-01,8.410229e-01,8.394495e-01,& + & 8.379428e-01,8.364967e-01,8.351117e-01,8.337820e-01,8.325091e-01,& + & 8.312874e-01,8.301169e-01,8.289985e-01 /) +! BAND 20 + ssaliq1(:, 20) = (/ & + & 9.969802e-01,9.950445e-01,9.931448e-01,9.914272e-01,9.898652e-01,& + & 9.884250e-01,9.870637e-01,9.857482e-01,9.844558e-01,9.831755e-01,& + & 9.819068e-01,9.806477e-01,9.794000e-01,9.781666e-01,9.769461e-01,& + & 9.757386e-01,9.745459e-01,9.733650e-01,9.721953e-01,9.710398e-01,& + & 9.698936e-01,9.687583e-01,9.676334e-01,9.665192e-01,9.654132e-01,& + & 9.643208e-01,9.632374e-01,9.621625e-01,9.611003e-01,9.600518e-01,& + & 9.590144e-01,9.579922e-01,9.569864e-01,9.559948e-01,9.550239e-01,& + & 9.540698e-01,9.531382e-01,9.522280e-01,9.513409e-01,9.504772e-01,& + & 9.496360e-01,9.488220e-01,9.480327e-01,9.472693e-01,9.465333e-01,& + & 9.458211e-01,9.451344e-01,9.444732e-01,9.438372e-01,9.432268e-01,& + & 9.426391e-01,9.420757e-01,9.415308e-01,9.410102e-01,9.405115e-01,& + & 9.400326e-01,9.395716e-01,9.391313e-01 /) +! BAND 21 + ssaliq1(:, 21) = (/ & + & 9.980034e-01,9.968572e-01,9.958696e-01,9.949747e-01,9.941241e-01,& + & 9.933043e-01,9.924971e-01,9.916978e-01,9.909023e-01,9.901046e-01,& + & 9.893087e-01,9.885146e-01,9.877195e-01,9.869283e-01,9.861379e-01,& + & 9.853523e-01,9.845715e-01,9.837945e-01,9.830217e-01,9.822567e-01,& + & 9.814935e-01,9.807356e-01,9.799815e-01,9.792332e-01,9.784845e-01,& + & 9.777424e-01,9.770042e-01,9.762695e-01,9.755416e-01,9.748152e-01,& + & 9.740974e-01,9.733873e-01,9.726813e-01,9.719861e-01,9.713010e-01,& + & 9.706262e-01,9.699647e-01,9.693144e-01,9.686794e-01,9.680596e-01,& + & 9.674540e-01,9.668657e-01,9.662926e-01,9.657390e-01,9.652019e-01,& + & 9.646820e-01,9.641784e-01,9.636945e-01,9.632260e-01,9.627743e-01,& + & 9.623418e-01,9.619227e-01,9.615194e-01,9.611341e-01,9.607629e-01,& + & 9.604057e-01,9.600622e-01,9.597322e-01 /) +! BAND 22 + ssaliq1(:, 22) = (/ & + & 9.988219e-01,9.981767e-01,9.976168e-01,9.971066e-01,9.966195e-01,& + & 9.961566e-01,9.956995e-01,9.952481e-01,9.947982e-01,9.943495e-01,& + & 9.938955e-01,9.934368e-01,9.929825e-01,9.925239e-01,9.920653e-01,& + & 9.916096e-01,9.911552e-01,9.907067e-01,9.902594e-01,9.898178e-01,& + & 9.893791e-01,9.889453e-01,9.885122e-01,9.880837e-01,9.876567e-01,& + & 9.872331e-01,9.868121e-01,9.863938e-01,9.859790e-01,9.855650e-01,& + & 9.851548e-01,9.847491e-01,9.843496e-01,9.839521e-01,9.835606e-01,& + & 9.831771e-01,9.827975e-01,9.824292e-01,9.820653e-01,9.817124e-01,& + & 9.813644e-01,9.810291e-01,9.807020e-01,9.803864e-01,9.800782e-01,& + & 9.797821e-01,9.794958e-01,9.792179e-01,9.789509e-01,9.786940e-01,& + & 9.784460e-01,9.782090e-01,9.779789e-01,9.777553e-01,9.775425e-01,& + & 9.773387e-01,9.771420e-01,9.769529e-01 /) +! BAND 23 + ssaliq1(:, 23) = (/ & + & 9.998902e-01,9.998395e-01,9.997915e-01,9.997442e-01,9.997016e-01,& + & 9.996600e-01,9.996200e-01,9.995806e-01,9.995411e-01,9.995005e-01,& + & 9.994589e-01,9.994178e-01,9.993766e-01,9.993359e-01,9.992948e-01,& + & 9.992533e-01,9.992120e-01,9.991723e-01,9.991313e-01,9.990906e-01,& + & 9.990510e-01,9.990113e-01,9.989716e-01,9.989323e-01,9.988923e-01,& + & 9.988532e-01,9.988140e-01,9.987761e-01,9.987373e-01,9.986989e-01,& + & 9.986597e-01,9.986239e-01,9.985861e-01,9.985485e-01,9.985123e-01,& + & 9.984762e-01,9.984415e-01,9.984065e-01,9.983722e-01,9.983398e-01,& + & 9.983078e-01,9.982758e-01,9.982461e-01,9.982157e-01,9.981872e-01,& + & 9.981595e-01,9.981324e-01,9.981068e-01,9.980811e-01,9.980580e-01,& + & 9.980344e-01,9.980111e-01,9.979908e-01,9.979690e-01,9.979492e-01,& + & 9.979316e-01,9.979116e-01,9.978948e-01 /) +! BAND 24 + ssaliq1(:, 24) = (/ & + & 9.999978e-01,9.999948e-01,9.999915e-01,9.999905e-01,9.999896e-01,& + & 9.999887e-01,9.999888e-01,9.999888e-01,9.999870e-01,9.999854e-01,& + & 9.999855e-01,9.999856e-01,9.999839e-01,9.999834e-01,9.999829e-01,& + & 9.999809e-01,9.999816e-01,9.999793e-01,9.999782e-01,9.999779e-01,& + & 9.999772e-01,9.999764e-01,9.999756e-01,9.999744e-01,9.999744e-01,& + & 9.999736e-01,9.999729e-01,9.999716e-01,9.999706e-01,9.999692e-01,& + & 9.999690e-01,9.999675e-01,9.999673e-01,9.999660e-01,9.999654e-01,& + & 9.999647e-01,9.999647e-01,9.999625e-01,9.999620e-01,9.999614e-01,& + & 9.999613e-01,9.999607e-01,9.999604e-01,9.999594e-01,9.999589e-01,& + & 9.999586e-01,9.999567e-01,9.999550e-01,9.999557e-01,9.999542e-01,& + & 9.999546e-01,9.999539e-01,9.999536e-01,9.999526e-01,9.999523e-01,& + & 9.999508e-01,9.999534e-01,9.999507e-01 /) +! BAND 25 + ssaliq1(:, 25) = (/ & + & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& + & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& + & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& + & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,9.999995e-01,& + & 9.999995e-01,9.999990e-01,9.999991e-01,9.999991e-01,9.999990e-01,& + & 9.999989e-01,9.999988e-01,9.999988e-01,9.999986e-01,9.999988e-01,& + & 9.999986e-01,9.999987e-01,9.999986e-01,9.999985e-01,9.999985e-01,& + & 9.999985e-01,9.999985e-01,9.999983e-01,9.999983e-01,9.999981e-01,& + & 9.999981e-01,9.999986e-01,9.999985e-01,9.999983e-01,9.999984e-01,& + & 9.999982e-01,9.999983e-01,9.999982e-01,9.999980e-01,9.999981e-01,& + & 9.999978e-01,9.999979e-01,9.999985e-01,9.999985e-01,9.999983e-01,& + & 9.999983e-01,9.999983e-01,9.999983e-01 /) +! BAND 26 + ssaliq1(:, 26) = (/ & + & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& + & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& + & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,& + & 1.000000e+00,1.000000e+00,1.000000e+00,1.000000e+00,9.999991e-01,& + & 9.999990e-01,9.999992e-01,9.999995e-01,9.999986e-01,9.999994e-01,& + & 9.999985e-01,9.999980e-01,9.999984e-01,9.999983e-01,9.999979e-01,& + & 9.999969e-01,9.999977e-01,9.999971e-01,9.999969e-01,9.999969e-01,& + & 9.999965e-01,9.999970e-01,9.999985e-01,9.999973e-01,9.999961e-01,& + & 9.999968e-01,9.999952e-01,9.999970e-01,9.999974e-01,9.999965e-01,& + & 9.999969e-01,9.999970e-01,9.999970e-01,9.999960e-01,9.999923e-01,& + & 9.999958e-01,9.999937e-01,9.999960e-01,9.999953e-01,9.999946e-01,& + & 9.999946e-01,9.999957e-01,9.999951e-01 /) +! BAND 27 + ssaliq1(:, 27) = (/ & + & 1.000000e+00,1.000000e+00,9.999983e-01,9.999979e-01,9.999965e-01,& + & 9.999949e-01,9.999948e-01,9.999918e-01,9.999917e-01,9.999923e-01,& + & 9.999908e-01,9.999889e-01,9.999902e-01,9.999895e-01,9.999881e-01,& + & 9.999882e-01,9.999876e-01,9.999866e-01,9.999866e-01,9.999858e-01,& + & 9.999860e-01,9.999852e-01,9.999836e-01,9.999831e-01,9.999818e-01,& + & 9.999808e-01,9.999816e-01,9.999800e-01,9.999783e-01,9.999780e-01,& + & 9.999763e-01,9.999746e-01,9.999731e-01,9.999713e-01,9.999762e-01,& + & 9.999740e-01,9.999670e-01,9.999703e-01,9.999687e-01,9.999666e-01,& + & 9.999683e-01,9.999667e-01,9.999611e-01,9.999635e-01,9.999600e-01,& + & 9.999635e-01,9.999594e-01,9.999601e-01,9.999586e-01,9.999559e-01,& + & 9.999569e-01,9.999558e-01,9.999523e-01,9.999535e-01,9.999529e-01,& + & 9.999553e-01,9.999495e-01,9.999490e-01 /) +! BAND 28 + ssaliq1(:, 28) = (/ & + & 9.999920e-01,9.999873e-01,9.999855e-01,9.999832e-01,9.999807e-01,& + & 9.999778e-01,9.999754e-01,9.999721e-01,9.999692e-01,9.999651e-01,& + & 9.999621e-01,9.999607e-01,9.999567e-01,9.999546e-01,9.999521e-01,& + & 9.999491e-01,9.999457e-01,9.999439e-01,9.999403e-01,9.999374e-01,& + & 9.999353e-01,9.999315e-01,9.999282e-01,9.999244e-01,9.999234e-01,& + & 9.999189e-01,9.999130e-01,9.999117e-01,9.999073e-01,9.999020e-01,& + & 9.998993e-01,9.998987e-01,9.998922e-01,9.998893e-01,9.998869e-01,& + & 9.998805e-01,9.998778e-01,9.998751e-01,9.998708e-01,9.998676e-01,& + & 9.998624e-01,9.998642e-01,9.998582e-01,9.998547e-01,9.998546e-01,& + & 9.998477e-01,9.998487e-01,9.998466e-01,9.998403e-01,9.998412e-01,& + & 9.998406e-01,9.998342e-01,9.998326e-01,9.998333e-01,9.998328e-01,& + & 9.998290e-01,9.998276e-01,9.998249e-01 /) +! BAND 29 + ssaliq1(:, 29) = (/ & + & 8.383753e-01,8.461471e-01,8.373325e-01,8.212889e-01,8.023834e-01,& + & 7.829501e-01,7.641777e-01,7.466000e-01,7.304023e-01,7.155998e-01,& + & 7.021259e-01,6.898840e-01,6.787615e-01,6.686479e-01,6.594414e-01,& + & 6.510417e-01,6.433668e-01,6.363335e-01,6.298788e-01,6.239398e-01,& + & 6.184633e-01,6.134055e-01,6.087228e-01,6.043786e-01,6.003439e-01,& + & 5.965910e-01,5.930917e-01,5.898280e-01,5.867798e-01,5.839264e-01,& + & 5.812576e-01,5.787592e-01,5.764163e-01,5.742189e-01,5.721598e-01,& + & 5.702286e-01,5.684182e-01,5.667176e-01,5.651237e-01,5.636253e-01,& + & 5.622228e-01,5.609074e-01,5.596713e-01,5.585089e-01,5.574223e-01,& + & 5.564002e-01,5.554411e-01,5.545397e-01,5.536914e-01,5.528967e-01,& + & 5.521495e-01,5.514457e-01,5.507818e-01,5.501623e-01,5.495750e-01,& + & 5.490192e-01,5.484980e-01,5.480046e-01 /) + +! Asymmetry parameter +! BAND 16 + asyliq1(:, 16) = (/ & + & 8.038165e-01,8.014154e-01,7.942381e-01,7.970521e-01,8.086621e-01,& + & 8.233392e-01,8.374127e-01,8.495742e-01,8.596945e-01,8.680497e-01,& + & 8.750005e-01,8.808589e-01,8.858749e-01,8.902403e-01,8.940939e-01,& + & 8.975379e-01,9.006450e-01,9.034741e-01,9.060659e-01,9.084561e-01,& + & 9.106675e-01,9.127198e-01,9.146332e-01,9.164194e-01,9.180970e-01,& + & 9.196658e-01,9.211421e-01,9.225352e-01,9.238443e-01,9.250841e-01,& + & 9.262541e-01,9.273620e-01,9.284081e-01,9.294002e-01,9.303395e-01,& + & 9.312285e-01,9.320715e-01,9.328716e-01,9.336271e-01,9.343427e-01,& + & 9.350219e-01,9.356647e-01,9.362728e-01,9.368495e-01,9.373956e-01,& + & 9.379113e-01,9.383987e-01,9.388608e-01,9.392986e-01,9.397132e-01,& + & 9.401063e-01,9.404776e-01,9.408299e-01,9.411641e-01,9.414800e-01,& + & 9.417787e-01,9.420633e-01,9.423364e-01 /) +! BAND 17 + asyliq1(:, 17) = (/ & + & 8.941000e-01,9.054049e-01,9.049510e-01,9.027216e-01,9.021636e-01,& + & 9.037878e-01,9.069852e-01,9.109817e-01,9.152013e-01,9.193040e-01,& + & 9.231177e-01,9.265712e-01,9.296606e-01,9.324048e-01,9.348419e-01,& + & 9.370131e-01,9.389529e-01,9.406954e-01,9.422727e-01,9.437088e-01,& + & 9.450221e-01,9.462308e-01,9.473488e-01,9.483830e-01,9.493492e-01,& + & 9.502541e-01,9.510999e-01,9.518971e-01,9.526455e-01,9.533554e-01,& + & 9.540249e-01,9.546571e-01,9.552551e-01,9.558258e-01,9.563603e-01,& + & 9.568713e-01,9.573569e-01,9.578141e-01,9.582485e-01,9.586604e-01,& + & 9.590525e-01,9.594218e-01,9.597710e-01,9.601052e-01,9.604181e-01,& + & 9.607159e-01,9.609979e-01,9.612655e-01,9.615184e-01,9.617564e-01,& + & 9.619860e-01,9.622009e-01,9.624031e-01,9.625957e-01,9.627792e-01,& + & 9.629530e-01,9.631171e-01,9.632746e-01 /) +! BAND 18 + asyliq1(:, 18) = (/ & + & 8.574638e-01,8.351383e-01,8.142977e-01,8.083068e-01,8.129284e-01,& + & 8.215827e-01,8.307238e-01,8.389963e-01,8.460481e-01,8.519273e-01,& + & 8.568153e-01,8.609116e-01,8.643892e-01,8.673941e-01,8.700248e-01,& + & 8.723707e-01,8.744902e-01,8.764240e-01,8.782057e-01,8.798593e-01,& + & 8.814063e-01,8.828573e-01,8.842261e-01,8.855196e-01,8.867497e-01,& + & 8.879164e-01,8.890316e-01,8.900941e-01,8.911118e-01,8.920832e-01,& + & 8.930156e-01,8.939091e-01,8.947663e-01,8.955888e-01,8.963786e-01,& + & 8.971350e-01,8.978617e-01,8.985590e-01,8.992243e-01,8.998631e-01,& + & 9.004753e-01,9.010602e-01,9.016192e-01,9.021542e-01,9.026644e-01,& + & 9.031535e-01,9.036194e-01,9.040656e-01,9.044894e-01,9.048933e-01,& + & 9.052789e-01,9.056481e-01,9.060004e-01,9.063343e-01,9.066544e-01,& + & 9.069604e-01,9.072512e-01,9.075290e-01 /) +! BAND 19 + asyliq1(:, 19) = (/ & + & 8.349569e-01,8.034579e-01,7.932136e-01,8.010156e-01,8.137083e-01,& + & 8.255339e-01,8.351938e-01,8.428286e-01,8.488944e-01,8.538187e-01,& + & 8.579255e-01,8.614473e-01,8.645338e-01,8.672908e-01,8.697947e-01,& + & 8.720843e-01,8.742015e-01,8.761718e-01,8.780160e-01,8.797479e-01,& + & 8.813810e-01,8.829250e-01,8.843907e-01,8.857822e-01,8.871059e-01,& + & 8.883724e-01,8.895810e-01,8.907384e-01,8.918456e-01,8.929083e-01,& + & 8.939284e-01,8.949060e-01,8.958463e-01,8.967486e-01,8.976129e-01,& + & 8.984463e-01,8.992439e-01,9.000094e-01,9.007438e-01,9.014496e-01,& + & 9.021235e-01,9.027699e-01,9.033859e-01,9.039772e-01,9.045419e-01,& + & 9.050819e-01,9.055975e-01,9.060907e-01,9.065607e-01,9.070093e-01,& + & 9.074389e-01,9.078475e-01,9.082388e-01,9.086117e-01,9.089678e-01,& + & 9.093081e-01,9.096307e-01,9.099410e-01 /) +! BAND 20 + asyliq1(:, 20) = (/ & + & 8.109692e-01,7.846657e-01,7.881928e-01,8.009509e-01,8.131208e-01,& + & 8.230400e-01,8.309448e-01,8.372920e-01,8.424837e-01,8.468166e-01,& + & 8.504947e-01,8.536642e-01,8.564256e-01,8.588513e-01,8.610011e-01,& + & 8.629122e-01,8.646262e-01,8.661720e-01,8.675752e-01,8.688582e-01,& + & 8.700379e-01,8.711300e-01,8.721485e-01,8.731027e-01,8.740010e-01,& + & 8.748499e-01,8.756564e-01,8.764239e-01,8.771542e-01,8.778523e-01,& + & 8.785211e-01,8.791601e-01,8.797725e-01,8.803589e-01,8.809173e-01,& + & 8.814552e-01,8.819705e-01,8.824611e-01,8.829311e-01,8.833791e-01,& + & 8.838078e-01,8.842148e-01,8.846044e-01,8.849756e-01,8.853291e-01,& + & 8.856645e-01,8.859841e-01,8.862904e-01,8.865801e-01,8.868551e-01,& + & 8.871182e-01,8.873673e-01,8.876059e-01,8.878307e-01,8.880462e-01,& + & 8.882501e-01,8.884453e-01,8.886339e-01 /) +! BAND 21 + asyliq1(:, 21) = (/ & + & 7.838510e-01,7.803151e-01,7.980477e-01,8.144160e-01,8.261784e-01,& + & 8.344240e-01,8.404278e-01,8.450391e-01,8.487593e-01,8.518741e-01,& + & 8.545484e-01,8.568890e-01,8.589560e-01,8.607983e-01,8.624504e-01,& + & 8.639408e-01,8.652945e-01,8.665301e-01,8.676634e-01,8.687121e-01,& + & 8.696855e-01,8.705933e-01,8.714448e-01,8.722454e-01,8.730014e-01,& + & 8.737180e-01,8.743982e-01,8.750436e-01,8.756598e-01,8.762481e-01,& + & 8.768089e-01,8.773427e-01,8.778532e-01,8.783434e-01,8.788089e-01,& + & 8.792530e-01,8.796784e-01,8.800845e-01,8.804716e-01,8.808411e-01,& + & 8.811923e-01,8.815276e-01,8.818472e-01,8.821504e-01,8.824408e-01,& + & 8.827155e-01,8.829777e-01,8.832269e-01,8.834631e-01,8.836892e-01,& + & 8.839034e-01,8.841075e-01,8.843021e-01,8.844866e-01,8.846631e-01,& + & 8.848304e-01,8.849910e-01,8.851425e-01 /) +! BAND 22 + asyliq1(:, 22) = (/ & + & 7.760783e-01,7.890215e-01,8.090192e-01,8.230252e-01,8.321369e-01,& + & 8.384258e-01,8.431529e-01,8.469558e-01,8.501499e-01,8.528899e-01,& + & 8.552899e-01,8.573956e-01,8.592570e-01,8.609098e-01,8.623897e-01,& + & 8.637169e-01,8.649184e-01,8.660097e-01,8.670096e-01,8.679338e-01,& + & 8.687896e-01,8.695880e-01,8.703365e-01,8.710422e-01,8.717092e-01,& + & 8.723378e-01,8.729363e-01,8.735063e-01,8.740475e-01,8.745661e-01,& + & 8.750560e-01,8.755275e-01,8.759731e-01,8.764000e-01,8.768071e-01,& + & 8.771942e-01,8.775628e-01,8.779126e-01,8.782483e-01,8.785626e-01,& + & 8.788610e-01,8.791482e-01,8.794180e-01,8.796765e-01,8.799207e-01,& + & 8.801522e-01,8.803707e-01,8.805777e-01,8.807749e-01,8.809605e-01,& + & 8.811362e-01,8.813047e-01,8.814647e-01,8.816131e-01,8.817588e-01,& + & 8.818930e-01,8.820230e-01,8.821445e-01 /) +! BAND 23 + asyliq1(:, 23) = (/ & + & 7.847907e-01,8.099917e-01,8.257428e-01,8.350423e-01,8.411971e-01,& + & 8.457241e-01,8.493010e-01,8.522565e-01,8.547660e-01,8.569311e-01,& + & 8.588181e-01,8.604729e-01,8.619296e-01,8.632208e-01,8.643725e-01,& + & 8.654050e-01,8.663363e-01,8.671835e-01,8.679590e-01,8.686707e-01,& + & 8.693308e-01,8.699433e-01,8.705147e-01,8.710490e-01,8.715497e-01,& + & 8.720219e-01,8.724669e-01,8.728849e-01,8.732806e-01,8.736550e-01,& + & 8.740099e-01,8.743435e-01,8.746601e-01,8.749610e-01,8.752449e-01,& + & 8.755143e-01,8.757688e-01,8.760095e-01,8.762375e-01,8.764532e-01,& + & 8.766579e-01,8.768506e-01,8.770323e-01,8.772049e-01,8.773690e-01,& + & 8.775226e-01,8.776679e-01,8.778062e-01,8.779360e-01,8.780587e-01,& + & 8.781747e-01,8.782852e-01,8.783892e-01,8.784891e-01,8.785824e-01,& + & 8.786705e-01,8.787546e-01,8.788336e-01 /) +! BAND 24 + asyliq1(:, 24) = (/ & + & 8.054324e-01,8.266282e-01,8.378075e-01,8.449848e-01,8.502166e-01,& + & 8.542268e-01,8.573477e-01,8.598022e-01,8.617689e-01,8.633859e-01,& + & 8.647536e-01,8.659354e-01,8.669807e-01,8.679143e-01,8.687577e-01,& + & 8.695222e-01,8.702207e-01,8.708591e-01,8.714446e-01,8.719836e-01,& + & 8.724812e-01,8.729426e-01,8.733689e-01,8.737665e-01,8.741373e-01,& + & 8.744834e-01,8.748070e-01,8.751131e-01,8.754011e-01,8.756676e-01,& + & 8.759219e-01,8.761599e-01,8.763857e-01,8.765984e-01,8.767999e-01,& + & 8.769889e-01,8.771669e-01,8.773373e-01,8.774969e-01,8.776469e-01,& + & 8.777894e-01,8.779237e-01,8.780505e-01,8.781703e-01,8.782820e-01,& + & 8.783886e-01,8.784894e-01,8.785844e-01,8.786736e-01,8.787584e-01,& + & 8.788379e-01,8.789130e-01,8.789849e-01,8.790506e-01,8.791141e-01,& + & 8.791750e-01,8.792324e-01,8.792867e-01 /) +! BAND 25 + asyliq1(:, 25) = (/ & + & 8.249534e-01,8.391988e-01,8.474107e-01,8.526860e-01,8.563983e-01,& + & 8.592389e-01,8.615144e-01,8.633790e-01,8.649325e-01,8.662504e-01,& + & 8.673841e-01,8.683741e-01,8.692495e-01,8.700309e-01,8.707328e-01,& + & 8.713650e-01,8.719432e-01,8.724676e-01,8.729498e-01,8.733922e-01,& + & 8.737981e-01,8.741745e-01,8.745225e-01,8.748467e-01,8.751512e-01,& + & 8.754315e-01,8.756962e-01,8.759450e-01,8.761774e-01,8.763945e-01,& + & 8.766021e-01,8.767970e-01,8.769803e-01,8.771511e-01,8.773151e-01,& + & 8.774689e-01,8.776147e-01,8.777533e-01,8.778831e-01,8.780050e-01,& + & 8.781197e-01,8.782301e-01,8.783323e-01,8.784312e-01,8.785222e-01,& + & 8.786096e-01,8.786916e-01,8.787688e-01,8.788411e-01,8.789122e-01,& + & 8.789762e-01,8.790373e-01,8.790954e-01,8.791514e-01,8.792018e-01,& + & 8.792517e-01,8.792990e-01,8.793429e-01 /) +! BAND 26 + asyliq1(:, 26) = (/ & + & 8.323091e-01,8.429776e-01,8.498123e-01,8.546929e-01,8.584295e-01,& + & 8.613489e-01,8.636324e-01,8.654303e-01,8.668675e-01,8.680404e-01,& + & 8.690174e-01,8.698495e-01,8.705666e-01,8.711961e-01,8.717556e-01,& + & 8.722546e-01,8.727063e-01,8.731170e-01,8.734933e-01,8.738382e-01,& + & 8.741590e-01,8.744525e-01,8.747295e-01,8.749843e-01,8.752210e-01,& + & 8.754437e-01,8.756524e-01,8.758472e-01,8.760288e-01,8.762030e-01,& + & 8.763603e-01,8.765122e-01,8.766539e-01,8.767894e-01,8.769130e-01,& + & 8.770310e-01,8.771422e-01,8.772437e-01,8.773419e-01,8.774355e-01,& + & 8.775221e-01,8.776047e-01,8.776802e-01,8.777539e-01,8.778216e-01,& + & 8.778859e-01,8.779473e-01,8.780031e-01,8.780562e-01,8.781097e-01,& + & 8.781570e-01,8.782021e-01,8.782463e-01,8.782845e-01,8.783235e-01,& + & 8.783610e-01,8.783953e-01,8.784273e-01 /) +! BAND 27 + asyliq1(:, 27) = (/ & + & 8.396448e-01,8.480172e-01,8.535934e-01,8.574145e-01,8.600835e-01,& + & 8.620347e-01,8.635500e-01,8.648003e-01,8.658758e-01,8.668248e-01,& + & 8.676697e-01,8.684220e-01,8.690893e-01,8.696807e-01,8.702046e-01,& + & 8.706676e-01,8.710798e-01,8.714478e-01,8.717778e-01,8.720747e-01,& + & 8.723431e-01,8.725889e-01,8.728144e-01,8.730201e-01,8.732129e-01,& + & 8.733907e-01,8.735541e-01,8.737100e-01,8.738533e-01,8.739882e-01,& + & 8.741164e-01,8.742362e-01,8.743485e-01,8.744530e-01,8.745512e-01,& + & 8.746471e-01,8.747373e-01,8.748186e-01,8.748973e-01,8.749732e-01,& + & 8.750443e-01,8.751105e-01,8.751747e-01,8.752344e-01,8.752902e-01,& + & 8.753412e-01,8.753917e-01,8.754393e-01,8.754843e-01,8.755282e-01,& + & 8.755662e-01,8.756039e-01,8.756408e-01,8.756722e-01,8.757072e-01,& + & 8.757352e-01,8.757653e-01,8.757932e-01 /) +! BAND 28 + asyliq1(:, 28) = (/ & + & 8.374590e-01,8.465669e-01,8.518701e-01,8.547627e-01,8.565745e-01,& + & 8.579065e-01,8.589717e-01,8.598632e-01,8.606363e-01,8.613268e-01,& + & 8.619560e-01,8.625340e-01,8.630689e-01,8.635601e-01,8.640084e-01,& + & 8.644180e-01,8.647885e-01,8.651220e-01,8.654218e-01,8.656908e-01,& + & 8.659294e-01,8.661422e-01,8.663334e-01,8.665037e-01,8.666543e-01,& + & 8.667913e-01,8.669156e-01,8.670242e-01,8.671249e-01,8.672161e-01,& + & 8.672993e-01,8.673733e-01,8.674457e-01,8.675103e-01,8.675713e-01,& + & 8.676267e-01,8.676798e-01,8.677286e-01,8.677745e-01,8.678178e-01,& + & 8.678601e-01,8.678986e-01,8.679351e-01,8.679693e-01,8.680013e-01,& + & 8.680334e-01,8.680624e-01,8.680915e-01,8.681178e-01,8.681428e-01,& + & 8.681654e-01,8.681899e-01,8.682103e-01,8.682317e-01,8.682498e-01,& + & 8.682677e-01,8.682861e-01,8.683041e-01 /) +! BAND 29 + asyliq1(:, 29) = (/ & + & 7.877069e-01,8.244281e-01,8.367971e-01,8.409074e-01,8.429859e-01,& + & 8.454386e-01,8.489350e-01,8.534141e-01,8.585814e-01,8.641267e-01,& + & 8.697999e-01,8.754223e-01,8.808785e-01,8.860944e-01,8.910354e-01,& + & 8.956837e-01,9.000392e-01,9.041091e-01,9.079071e-01,9.114479e-01,& + & 9.147462e-01,9.178234e-01,9.206903e-01,9.233663e-01,9.258668e-01,& + & 9.282006e-01,9.303847e-01,9.324288e-01,9.343418e-01,9.361356e-01,& + & 9.378176e-01,9.393939e-01,9.408736e-01,9.422622e-01,9.435670e-01,& + & 9.447900e-01,9.459395e-01,9.470199e-01,9.480335e-01,9.489852e-01,& + & 9.498782e-01,9.507168e-01,9.515044e-01,9.522470e-01,9.529409e-01,& + & 9.535946e-01,9.542071e-01,9.547838e-01,9.553256e-01,9.558351e-01,& + & 9.563139e-01,9.567660e-01,9.571915e-01,9.575901e-01,9.579685e-01,& + & 9.583239e-01,9.586602e-01,9.589766e-01 /) + + +! Spherical Ice Particle Parameterization +! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)] + extice2(:, 16) = (/ & +! band 16 + & 4.101824e-01 ,2.435514e-01 ,1.713697e-01 ,1.314865e-01 ,1.063406e-01 ,& + & 8.910701e-02 ,7.659480e-02 ,6.711784e-02 ,5.970353e-02 ,5.375249e-02 ,& + & 4.887577e-02 ,4.481025e-02 ,4.137171e-02 ,3.842744e-02 ,3.587948e-02 ,& + & 3.365396e-02 ,3.169419e-02 ,2.995593e-02 ,2.840419e-02 ,2.701091e-02 ,& + & 2.575336e-02 ,2.461293e-02 ,2.357423e-02 ,2.262443e-02 ,2.175276e-02 ,& + & 2.095012e-02 ,2.020875e-02 ,1.952199e-02 ,1.888412e-02 ,1.829018e-02 ,& + & 1.773586e-02 ,1.721738e-02 ,1.673144e-02 ,1.627510e-02 ,1.584579e-02 ,& + & 1.544122e-02 ,1.505934e-02 ,1.469833e-02 ,1.435654e-02 ,1.403251e-02 ,& + & 1.372492e-02 ,1.343255e-02 ,1.315433e-02 /) + extice2(:, 17) = (/ & +! band 17 + & 3.836650e-01 ,2.304055e-01 ,1.637265e-01 ,1.266681e-01 ,1.031602e-01 ,& + & 8.695191e-02 ,7.511544e-02 ,6.610009e-02 ,5.900909e-02 ,5.328833e-02 ,& + & 4.857728e-02 ,4.463133e-02 ,4.127880e-02 ,3.839567e-02 ,3.589013e-02 ,& + & 3.369280e-02 ,3.175027e-02 ,3.002079e-02 ,2.847121e-02 ,2.707493e-02 ,& + & 2.581031e-02 ,2.465962e-02 ,2.360815e-02 ,2.264363e-02 ,2.175571e-02 ,& + & 2.093563e-02 ,2.017592e-02 ,1.947015e-02 ,1.881278e-02 ,1.819901e-02 ,& + & 1.762463e-02 ,1.708598e-02 ,1.657982e-02 ,1.610330e-02 ,1.565390e-02 ,& + & 1.522937e-02 ,1.482768e-02 ,1.444706e-02 ,1.408588e-02 ,1.374270e-02 ,& + & 1.341619e-02 ,1.310517e-02 ,1.280857e-02 /) + extice2(:, 18) = (/ & +! band 18 + & 4.152673e-01 ,2.436816e-01 ,1.702243e-01 ,1.299704e-01 ,1.047528e-01 ,& + & 8.756039e-02 ,7.513327e-02 ,6.575690e-02 ,5.844616e-02 ,5.259609e-02 ,& + & 4.781531e-02 ,4.383980e-02 ,4.048517e-02 ,3.761891e-02 ,3.514342e-02 ,& + & 3.298525e-02 ,3.108814e-02 ,2.940825e-02 ,2.791096e-02 ,2.656858e-02 ,& + & 2.535869e-02 ,2.426297e-02 ,2.326627e-02 ,2.235602e-02 ,2.152164e-02 ,& + & 2.075420e-02 ,2.004613e-02 ,1.939091e-02 ,1.878296e-02 ,1.821744e-02 ,& + & 1.769015e-02 ,1.719741e-02 ,1.673600e-02 ,1.630308e-02 ,1.589615e-02 ,& + & 1.551298e-02 ,1.515159e-02 ,1.481021e-02 ,1.448726e-02 ,1.418131e-02 ,& + & 1.389109e-02 ,1.361544e-02 ,1.335330e-02 /) + extice2(:, 19) = (/ & +! band 19 + & 3.873250e-01 ,2.331609e-01 ,1.655002e-01 ,1.277753e-01 ,1.038247e-01 ,& + & 8.731780e-02 ,7.527638e-02 ,6.611873e-02 ,5.892850e-02 ,5.313885e-02 ,& + & 4.838068e-02 ,4.440356e-02 ,4.103167e-02 ,3.813804e-02 ,3.562870e-02 ,& + & 3.343269e-02 ,3.149539e-02 ,2.977414e-02 ,2.823510e-02 ,2.685112e-02 ,& + & 2.560015e-02 ,2.446411e-02 ,2.342805e-02 ,2.247948e-02 ,2.160789e-02 ,& + & 2.080438e-02 ,2.006139e-02 ,1.937238e-02 ,1.873177e-02 ,1.813469e-02 ,& + & 1.757689e-02 ,1.705468e-02 ,1.656479e-02 ,1.610435e-02 ,1.567081e-02 ,& + & 1.526192e-02 ,1.487565e-02 ,1.451020e-02 ,1.416396e-02 ,1.383546e-02 ,& + & 1.352339e-02 ,1.322657e-02 ,1.294392e-02 /) + extice2(:, 20) = (/ & +! band 20 + & 3.784280e-01 ,2.291396e-01 ,1.632551e-01 ,1.263775e-01 ,1.028944e-01 ,& + & 8.666975e-02 ,7.480952e-02 ,6.577335e-02 ,5.866714e-02 ,5.293694e-02 ,& + & 4.822153e-02 ,4.427547e-02 ,4.092626e-02 ,3.804918e-02 ,3.555184e-02 ,& + & 3.336440e-02 ,3.143307e-02 ,2.971577e-02 ,2.817912e-02 ,2.679632e-02 ,& + & 2.554558e-02 ,2.440903e-02 ,2.337187e-02 ,2.242173e-02 ,2.154821e-02 ,& + & 2.074249e-02 ,1.999706e-02 ,1.930546e-02 ,1.866212e-02 ,1.806221e-02 ,& + & 1.750152e-02 ,1.697637e-02 ,1.648352e-02 ,1.602010e-02 ,1.558358e-02 ,& + & 1.517172e-02 ,1.478250e-02 ,1.441413e-02 ,1.406498e-02 ,1.373362e-02 ,& + & 1.341872e-02 ,1.311911e-02 ,1.283371e-02 /) + extice2(:, 21) = (/ & +! band 21 + & 3.719909e-01 ,2.259490e-01 ,1.613144e-01 ,1.250648e-01 ,1.019462e-01 ,& + & 8.595358e-02 ,7.425064e-02 ,6.532618e-02 ,5.830218e-02 ,5.263421e-02 ,& + & 4.796697e-02 ,4.405891e-02 ,4.074013e-02 ,3.788776e-02 ,3.541071e-02 ,& + & 3.324008e-02 ,3.132280e-02 ,2.961733e-02 ,2.809071e-02 ,2.671645e-02 ,& + & 2.547302e-02 ,2.434276e-02 ,2.331102e-02 ,2.236558e-02 ,2.149614e-02 ,& + & 2.069397e-02 ,1.995163e-02 ,1.926272e-02 ,1.862174e-02 ,1.802389e-02 ,& + & 1.746500e-02 ,1.694142e-02 ,1.644994e-02 ,1.598772e-02 ,1.555225e-02 ,& + & 1.514129e-02 ,1.475286e-02 ,1.438515e-02 ,1.403659e-02 ,1.370572e-02 ,& + & 1.339124e-02 ,1.309197e-02 ,1.280685e-02 /) + extice2(:, 22) = (/ & +! band 22 + & 3.713158e-01 ,2.253816e-01 ,1.608461e-01 ,1.246718e-01 ,1.016109e-01 ,& + & 8.566332e-02 ,7.399666e-02 ,6.510199e-02 ,5.810290e-02 ,5.245608e-02 ,& + & 4.780702e-02 ,4.391478e-02 ,4.060989e-02 ,3.776982e-02 ,3.530374e-02 ,& + & 3.314296e-02 ,3.123458e-02 ,2.953719e-02 ,2.801794e-02 ,2.665043e-02 ,& + & 2.541321e-02 ,2.428868e-02 ,2.326224e-02 ,2.232173e-02 ,2.145688e-02 ,& + & 2.065899e-02 ,1.992067e-02 ,1.923552e-02 ,1.859808e-02 ,1.800356e-02 ,& + & 1.744782e-02 ,1.692721e-02 ,1.643855e-02 ,1.597900e-02 ,1.554606e-02 ,& + & 1.513751e-02 ,1.475137e-02 ,1.438586e-02 ,1.403938e-02 ,1.371050e-02 ,& + & 1.339793e-02 ,1.310050e-02 ,1.281713e-02 /) + extice2(:, 23) = (/ & +! band 23 + & 3.605883e-01 ,2.204388e-01 ,1.580431e-01 ,1.229033e-01 ,1.004203e-01 ,& + & 8.482616e-02 ,7.338941e-02 ,6.465105e-02 ,5.776176e-02 ,5.219398e-02 ,& + & 4.760288e-02 ,4.375369e-02 ,4.048111e-02 ,3.766539e-02 ,3.521771e-02 ,& + & 3.307079e-02 ,3.117277e-02 ,2.948303e-02 ,2.796929e-02 ,2.660560e-02 ,& + & 2.537086e-02 ,2.424772e-02 ,2.322182e-02 ,2.228114e-02 ,2.141556e-02 ,& + & 2.061649e-02 ,1.987661e-02 ,1.918962e-02 ,1.855009e-02 ,1.795330e-02 ,& + & 1.739514e-02 ,1.687199e-02 ,1.638069e-02 ,1.591845e-02 ,1.548276e-02 ,& + & 1.507143e-02 ,1.468249e-02 ,1.431416e-02 ,1.396486e-02 ,1.363318e-02 ,& + & 1.331781e-02 ,1.301759e-02 ,1.273147e-02 /) + extice2(:, 24) = (/ & +! band 24 + & 3.527890e-01 ,2.168469e-01 ,1.560090e-01 ,1.216216e-01 ,9.955787e-02 ,& + & 8.421942e-02 ,7.294827e-02 ,6.432192e-02 ,5.751081e-02 ,5.199888e-02 ,& + & 4.744835e-02 ,4.362899e-02 ,4.037847e-02 ,3.757910e-02 ,3.514351e-02 ,& + & 3.300546e-02 ,3.111382e-02 ,2.942853e-02 ,2.791775e-02 ,2.655584e-02 ,& + & 2.532195e-02 ,2.419892e-02 ,2.317255e-02 ,2.223092e-02 ,2.136402e-02 ,& + & 2.056334e-02 ,1.982160e-02 ,1.913258e-02 ,1.849087e-02 ,1.789178e-02 ,& + & 1.733124e-02 ,1.680565e-02 ,1.631187e-02 ,1.584711e-02 ,1.540889e-02 ,& + & 1.499502e-02 ,1.460354e-02 ,1.423269e-02 ,1.388088e-02 ,1.354670e-02 ,& + & 1.322887e-02 ,1.292620e-02 ,1.263767e-02 /) + extice2(:, 25) = (/ & +! band 25 + & 3.477874e-01 ,2.143515e-01 ,1.544887e-01 ,1.205942e-01 ,9.881779e-02 ,& + & 8.366261e-02 ,7.251586e-02 ,6.397790e-02 ,5.723183e-02 ,5.176908e-02 ,& + & 4.725658e-02 ,4.346715e-02 ,4.024055e-02 ,3.746055e-02 ,3.504080e-02 ,& + & 3.291583e-02 ,3.103507e-02 ,2.935891e-02 ,2.785582e-02 ,2.650042e-02 ,& + & 2.527206e-02 ,2.415376e-02 ,2.313142e-02 ,2.219326e-02 ,2.132934e-02 ,& + & 2.053122e-02 ,1.979169e-02 ,1.910456e-02 ,1.846448e-02 ,1.786680e-02 ,& + & 1.730745e-02 ,1.678289e-02 ,1.628998e-02 ,1.582595e-02 ,1.538835e-02 ,& + & 1.497499e-02 ,1.458393e-02 ,1.421341e-02 ,1.386187e-02 ,1.352788e-02 ,& + & 1.321019e-02 ,1.290762e-02 ,1.261913e-02 /) + extice2(:, 26) = (/ & +! band 26 + & 3.453721e-01 ,2.130744e-01 ,1.536698e-01 ,1.200140e-01 ,9.838078e-02 ,& + & 8.331940e-02 ,7.223803e-02 ,6.374775e-02 ,5.703770e-02 ,5.160290e-02 ,& + & 4.711259e-02 ,4.334110e-02 ,4.012923e-02 ,3.736150e-02 ,3.495208e-02 ,& + & 3.283589e-02 ,3.096267e-02 ,2.929302e-02 ,2.779560e-02 ,2.644517e-02 ,& + & 2.522119e-02 ,2.410677e-02 ,2.308788e-02 ,2.215281e-02 ,2.129165e-02 ,& + & 2.049602e-02 ,1.975874e-02 ,1.907365e-02 ,1.843542e-02 ,1.783943e-02 ,& + & 1.728162e-02 ,1.675847e-02 ,1.626685e-02 ,1.580401e-02 ,1.536750e-02 ,& + & 1.495515e-02 ,1.456502e-02 ,1.419537e-02 ,1.384463e-02 ,1.351139e-02 ,& + & 1.319438e-02 ,1.289246e-02 ,1.260456e-02 /) + extice2(:, 27) = (/ & +! band 27 + & 3.417883e-01 ,2.113379e-01 ,1.526395e-01 ,1.193347e-01 ,9.790253e-02 ,& + & 8.296715e-02 ,7.196979e-02 ,6.353806e-02 ,5.687024e-02 ,5.146670e-02 ,& + & 4.700001e-02 ,4.324667e-02 ,4.004894e-02 ,3.729233e-02 ,3.489172e-02 ,& + & 3.278257e-02 ,3.091499e-02 ,2.924987e-02 ,2.775609e-02 ,2.640859e-02 ,& + & 2.518695e-02 ,2.407439e-02 ,2.305697e-02 ,2.212303e-02 ,2.126273e-02 ,& + & 2.046774e-02 ,1.973090e-02 ,1.904610e-02 ,1.840801e-02 ,1.781204e-02 ,& + & 1.725417e-02 ,1.673086e-02 ,1.623902e-02 ,1.577590e-02 ,1.533906e-02 ,& + & 1.492634e-02 ,1.453580e-02 ,1.416571e-02 ,1.381450e-02 ,1.348078e-02 ,& + & 1.316327e-02 ,1.286082e-02 ,1.257240e-02 /) + extice2(:, 28) = (/ & +! band 28 + & 3.416111e-01 ,2.114124e-01 ,1.527734e-01 ,1.194809e-01 ,9.804612e-02 ,& + & 8.310287e-02 ,7.209595e-02 ,6.365442e-02 ,5.697710e-02 ,5.156460e-02 ,& + & 4.708957e-02 ,4.332850e-02 ,4.012361e-02 ,3.736037e-02 ,3.495364e-02 ,& + & 3.283879e-02 ,3.096593e-02 ,2.929589e-02 ,2.779751e-02 ,2.644571e-02 ,& + & 2.522004e-02 ,2.410369e-02 ,2.308271e-02 ,2.214542e-02 ,2.128195e-02 ,& + & 2.048396e-02 ,1.974429e-02 ,1.905679e-02 ,1.841614e-02 ,1.781774e-02 ,& + & 1.725754e-02 ,1.673203e-02 ,1.623807e-02 ,1.577293e-02 ,1.533416e-02 ,& + & 1.491958e-02 ,1.452727e-02 ,1.415547e-02 ,1.380262e-02 ,1.346732e-02 ,& + & 1.314830e-02 ,1.284439e-02 ,1.255456e-02 /) + extice2(:, 29) = (/ & +! band 29 + & 4.196611e-01 ,2.493642e-01 ,1.761261e-01 ,1.357197e-01 ,1.102161e-01 ,& + & 9.269376e-02 ,7.992985e-02 ,7.022538e-02 ,6.260168e-02 ,5.645603e-02 ,& + & 5.139732e-02 ,4.716088e-02 ,4.356133e-02 ,4.046498e-02 ,3.777303e-02 ,& + & 3.541094e-02 ,3.332137e-02 ,3.145954e-02 ,2.978998e-02 ,2.828419e-02 ,& + & 2.691905e-02 ,2.567559e-02 ,2.453811e-02 ,2.349350e-02 ,2.253072e-02 ,& + & 2.164042e-02 ,2.081464e-02 ,2.004652e-02 ,1.933015e-02 ,1.866041e-02 ,& + & 1.803283e-02 ,1.744348e-02 ,1.688894e-02 ,1.636616e-02 ,1.587244e-02 ,& + & 1.540539e-02 ,1.496287e-02 ,1.454295e-02 ,1.414392e-02 ,1.376423e-02 ,& + & 1.340247e-02 ,1.305739e-02 ,1.272784e-02 /) + +! single-scattering albedo: unitless + ssaice2(:, 16) = (/ & +! band 16 + & 6.630615e-01 ,6.451169e-01 ,6.333696e-01 ,6.246927e-01 ,6.178420e-01 ,& + & 6.121976e-01 ,6.074069e-01 ,6.032505e-01 ,5.995830e-01 ,5.963030e-01 ,& + & 5.933372e-01 ,5.906311e-01 ,5.881427e-01 ,5.858395e-01 ,5.836955e-01 ,& + & 5.816896e-01 ,5.798046e-01 ,5.780264e-01 ,5.763429e-01 ,5.747441e-01 ,& + & 5.732213e-01 ,5.717672e-01 ,5.703754e-01 ,5.690403e-01 ,5.677571e-01 ,& + & 5.665215e-01 ,5.653297e-01 ,5.641782e-01 ,5.630643e-01 ,5.619850e-01 ,& + & 5.609381e-01 ,5.599214e-01 ,5.589328e-01 ,5.579707e-01 ,5.570333e-01 ,& + & 5.561193e-01 ,5.552272e-01 ,5.543558e-01 ,5.535041e-01 ,5.526708e-01 ,& + & 5.518551e-01 ,5.510561e-01 ,5.502729e-01 /) + ssaice2(:, 17) = (/ & +! band 17 + & 7.689749e-01 ,7.398171e-01 ,7.205819e-01 ,7.065690e-01 ,6.956928e-01 ,& + & 6.868989e-01 ,6.795813e-01 ,6.733606e-01 ,6.679838e-01 ,6.632742e-01 ,& + & 6.591036e-01 ,6.553766e-01 ,6.520197e-01 ,6.489757e-01 ,6.461991e-01 ,& + & 6.436531e-01 ,6.413075e-01 ,6.391375e-01 ,6.371221e-01 ,6.352438e-01 ,& + & 6.334876e-01 ,6.318406e-01 ,6.302918e-01 ,6.288315e-01 ,6.274512e-01 ,& + & 6.261436e-01 ,6.249022e-01 ,6.237211e-01 ,6.225953e-01 ,6.215201e-01 ,& + & 6.204914e-01 ,6.195055e-01 ,6.185592e-01 ,6.176492e-01 ,6.167730e-01 ,& + & 6.159280e-01 ,6.151120e-01 ,6.143228e-01 ,6.135587e-01 ,6.128177e-01 ,& + & 6.120984e-01 ,6.113993e-01 ,6.107189e-01 /) + ssaice2(:, 18) = (/ & +! band 18 + & 9.956167e-01 ,9.814770e-01 ,9.716104e-01 ,9.639746e-01 ,9.577179e-01 ,& + & 9.524010e-01 ,9.477672e-01 ,9.436527e-01 ,9.399467e-01 ,9.365708e-01 ,& + & 9.334672e-01 ,9.305921e-01 ,9.279118e-01 ,9.253993e-01 ,9.230330e-01 ,& + & 9.207954e-01 ,9.186719e-01 ,9.166501e-01 ,9.147199e-01 ,9.128722e-01 ,& + & 9.110997e-01 ,9.093956e-01 ,9.077544e-01 ,9.061708e-01 ,9.046406e-01 ,& + & 9.031598e-01 ,9.017248e-01 ,9.003326e-01 ,8.989804e-01 ,8.976655e-01 ,& + & 8.963857e-01 ,8.951389e-01 ,8.939233e-01 ,8.927370e-01 ,8.915785e-01 ,& + & 8.904464e-01 ,8.893392e-01 ,8.882559e-01 ,8.871951e-01 ,8.861559e-01 ,& + & 8.851373e-01 ,8.841383e-01 ,8.831581e-01 /) + ssaice2(:, 19) = (/ & +! band 19 + & 9.723177e-01 ,9.452119e-01 ,9.267592e-01 ,9.127393e-01 ,9.014238e-01 ,& + & 8.919334e-01 ,8.837584e-01 ,8.765773e-01 ,8.701736e-01 ,8.643950e-01 ,& + & 8.591299e-01 ,8.542942e-01 ,8.498230e-01 ,8.456651e-01 ,8.417794e-01 ,& + & 8.381324e-01 ,8.346964e-01 ,8.314484e-01 ,8.283687e-01 ,8.254408e-01 ,& + & 8.226505e-01 ,8.199854e-01 ,8.174348e-01 ,8.149891e-01 ,8.126403e-01 ,& + & 8.103808e-01 ,8.082041e-01 ,8.061044e-01 ,8.040765e-01 ,8.021156e-01 ,& + & 8.002174e-01 ,7.983781e-01 ,7.965941e-01 ,7.948622e-01 ,7.931795e-01 ,& + & 7.915432e-01 ,7.899508e-01 ,7.884002e-01 ,7.868891e-01 ,7.854156e-01 ,& + & 7.839779e-01 ,7.825742e-01 ,7.812031e-01 /) + ssaice2(:, 20) = (/ & +! band 20 + & 9.933294e-01 ,9.860917e-01 ,9.811564e-01 ,9.774008e-01 ,9.743652e-01 ,& + & 9.718155e-01 ,9.696159e-01 ,9.676810e-01 ,9.659531e-01 ,9.643915e-01 ,& + & 9.629667e-01 ,9.616561e-01 ,9.604426e-01 ,9.593125e-01 ,9.582548e-01 ,& + & 9.572607e-01 ,9.563227e-01 ,9.554347e-01 ,9.545915e-01 ,9.537888e-01 ,& + & 9.530226e-01 ,9.522898e-01 ,9.515874e-01 ,9.509130e-01 ,9.502643e-01 ,& + & 9.496394e-01 ,9.490366e-01 ,9.484542e-01 ,9.478910e-01 ,9.473456e-01 ,& + & 9.468169e-01 ,9.463039e-01 ,9.458056e-01 ,9.453212e-01 ,9.448499e-01 ,& + & 9.443910e-01 ,9.439438e-01 ,9.435077e-01 ,9.430821e-01 ,9.426666e-01 ,& + & 9.422607e-01 ,9.418638e-01 ,9.414756e-01 /) + ssaice2(:, 21) = (/ & +! band 21 + & 9.900787e-01 ,9.828880e-01 ,9.779258e-01 ,9.741173e-01 ,9.710184e-01 ,& + & 9.684012e-01 ,9.661332e-01 ,9.641301e-01 ,9.623352e-01 ,9.607083e-01 ,& + & 9.592198e-01 ,9.578474e-01 ,9.565739e-01 ,9.553856e-01 ,9.542715e-01 ,& + & 9.532226e-01 ,9.522314e-01 ,9.512919e-01 ,9.503986e-01 ,9.495472e-01 ,& + & 9.487337e-01 ,9.479549e-01 ,9.472077e-01 ,9.464897e-01 ,9.457985e-01 ,& + & 9.451322e-01 ,9.444890e-01 ,9.438673e-01 ,9.432656e-01 ,9.426826e-01 ,& + & 9.421173e-01 ,9.415684e-01 ,9.410351e-01 ,9.405164e-01 ,9.400115e-01 ,& + & 9.395198e-01 ,9.390404e-01 ,9.385728e-01 ,9.381164e-01 ,9.376707e-01 ,& + & 9.372350e-01 ,9.368091e-01 ,9.363923e-01 /) + ssaice2(:, 22) = (/ & +! band 22 + & 9.986793e-01 ,9.985239e-01 ,9.983911e-01 ,9.982715e-01 ,9.981606e-01 ,& + & 9.980562e-01 ,9.979567e-01 ,9.978613e-01 ,9.977691e-01 ,9.976798e-01 ,& + & 9.975929e-01 ,9.975081e-01 ,9.974251e-01 ,9.973438e-01 ,9.972640e-01 ,& + & 9.971855e-01 ,9.971083e-01 ,9.970322e-01 ,9.969571e-01 ,9.968830e-01 ,& + & 9.968099e-01 ,9.967375e-01 ,9.966660e-01 ,9.965951e-01 ,9.965250e-01 ,& + & 9.964555e-01 ,9.963867e-01 ,9.963185e-01 ,9.962508e-01 ,9.961836e-01 ,& + & 9.961170e-01 ,9.960508e-01 ,9.959851e-01 ,9.959198e-01 ,9.958550e-01 ,& + & 9.957906e-01 ,9.957266e-01 ,9.956629e-01 ,9.955997e-01 ,9.955367e-01 ,& + & 9.954742e-01 ,9.954119e-01 ,9.953500e-01 /) + ssaice2(:, 23) = (/ & +! band 23 + & 9.997944e-01 ,9.997791e-01 ,9.997664e-01 ,9.997547e-01 ,9.997436e-01 ,& + & 9.997327e-01 ,9.997219e-01 ,9.997110e-01 ,9.996999e-01 ,9.996886e-01 ,& + & 9.996771e-01 ,9.996653e-01 ,9.996533e-01 ,9.996409e-01 ,9.996282e-01 ,& + & 9.996152e-01 ,9.996019e-01 ,9.995883e-01 ,9.995743e-01 ,9.995599e-01 ,& + & 9.995453e-01 ,9.995302e-01 ,9.995149e-01 ,9.994992e-01 ,9.994831e-01 ,& + & 9.994667e-01 ,9.994500e-01 ,9.994329e-01 ,9.994154e-01 ,9.993976e-01 ,& + & 9.993795e-01 ,9.993610e-01 ,9.993422e-01 ,9.993230e-01 ,9.993035e-01 ,& + & 9.992837e-01 ,9.992635e-01 ,9.992429e-01 ,9.992221e-01 ,9.992008e-01 ,& + & 9.991793e-01 ,9.991574e-01 ,9.991352e-01 /) + ssaice2(:, 24) = (/ & +! band 24 + & 9.999949e-01 ,9.999947e-01 ,9.999943e-01 ,9.999939e-01 ,9.999934e-01 ,& + & 9.999927e-01 ,9.999920e-01 ,9.999913e-01 ,9.999904e-01 ,9.999895e-01 ,& + & 9.999885e-01 ,9.999874e-01 ,9.999863e-01 ,9.999851e-01 ,9.999838e-01 ,& + & 9.999824e-01 ,9.999810e-01 ,9.999795e-01 ,9.999780e-01 ,9.999764e-01 ,& + & 9.999747e-01 ,9.999729e-01 ,9.999711e-01 ,9.999692e-01 ,9.999673e-01 ,& + & 9.999653e-01 ,9.999632e-01 ,9.999611e-01 ,9.999589e-01 ,9.999566e-01 ,& + & 9.999543e-01 ,9.999519e-01 ,9.999495e-01 ,9.999470e-01 ,9.999444e-01 ,& + & 9.999418e-01 ,9.999392e-01 ,9.999364e-01 ,9.999336e-01 ,9.999308e-01 ,& + & 9.999279e-01 ,9.999249e-01 ,9.999219e-01 /) + ssaice2(:, 25) = (/ & +! band 25 + & 9.999997e-01 ,9.999997e-01 ,9.999997e-01 ,9.999996e-01 ,9.999996e-01 ,& + & 9.999995e-01 ,9.999994e-01 ,9.999993e-01 ,9.999993e-01 ,9.999992e-01 ,& + & 9.999991e-01 ,9.999989e-01 ,9.999988e-01 ,9.999987e-01 ,9.999986e-01 ,& + & 9.999984e-01 ,9.999983e-01 ,9.999981e-01 ,9.999980e-01 ,9.999978e-01 ,& + & 9.999976e-01 ,9.999974e-01 ,9.999972e-01 ,9.999971e-01 ,9.999969e-01 ,& + & 9.999966e-01 ,9.999964e-01 ,9.999962e-01 ,9.999960e-01 ,9.999957e-01 ,& + & 9.999955e-01 ,9.999953e-01 ,9.999950e-01 ,9.999947e-01 ,9.999945e-01 ,& + & 9.999942e-01 ,9.999939e-01 ,9.999936e-01 ,9.999934e-01 ,9.999931e-01 ,& + & 9.999928e-01 ,9.999925e-01 ,9.999921e-01 /) + ssaice2(:, 26) = (/ & +! band 26 + & 9.999997e-01 ,9.999996e-01 ,9.999996e-01 ,9.999995e-01 ,9.999994e-01 ,& + & 9.999993e-01 ,9.999992e-01 ,9.999991e-01 ,9.999990e-01 ,9.999989e-01 ,& + & 9.999987e-01 ,9.999986e-01 ,9.999984e-01 ,9.999982e-01 ,9.999980e-01 ,& + & 9.999978e-01 ,9.999976e-01 ,9.999974e-01 ,9.999972e-01 ,9.999970e-01 ,& + & 9.999967e-01 ,9.999965e-01 ,9.999962e-01 ,9.999959e-01 ,9.999956e-01 ,& + & 9.999954e-01 ,9.999951e-01 ,9.999947e-01 ,9.999944e-01 ,9.999941e-01 ,& + & 9.999938e-01 ,9.999934e-01 ,9.999931e-01 ,9.999927e-01 ,9.999923e-01 ,& + & 9.999920e-01 ,9.999916e-01 ,9.999912e-01 ,9.999908e-01 ,9.999904e-01 ,& + & 9.999899e-01 ,9.999895e-01 ,9.999891e-01 /) + ssaice2(:, 27) = (/ & +! band 27 + & 9.999987e-01 ,9.999987e-01 ,9.999985e-01 ,9.999984e-01 ,9.999982e-01 ,& + & 9.999980e-01 ,9.999978e-01 ,9.999976e-01 ,9.999973e-01 ,9.999970e-01 ,& + & 9.999967e-01 ,9.999964e-01 ,9.999960e-01 ,9.999956e-01 ,9.999952e-01 ,& + & 9.999948e-01 ,9.999944e-01 ,9.999939e-01 ,9.999934e-01 ,9.999929e-01 ,& + & 9.999924e-01 ,9.999918e-01 ,9.999913e-01 ,9.999907e-01 ,9.999901e-01 ,& + & 9.999894e-01 ,9.999888e-01 ,9.999881e-01 ,9.999874e-01 ,9.999867e-01 ,& + & 9.999860e-01 ,9.999853e-01 ,9.999845e-01 ,9.999837e-01 ,9.999829e-01 ,& + & 9.999821e-01 ,9.999813e-01 ,9.999804e-01 ,9.999796e-01 ,9.999787e-01 ,& + & 9.999778e-01 ,9.999768e-01 ,9.999759e-01 /) + ssaice2(:, 28) = (/ & +! band 28 + & 9.999989e-01 ,9.999989e-01 ,9.999987e-01 ,9.999986e-01 ,9.999984e-01 ,& + & 9.999982e-01 ,9.999980e-01 ,9.999978e-01 ,9.999975e-01 ,9.999972e-01 ,& + & 9.999969e-01 ,9.999966e-01 ,9.999962e-01 ,9.999958e-01 ,9.999954e-01 ,& + & 9.999950e-01 ,9.999945e-01 ,9.999941e-01 ,9.999936e-01 ,9.999931e-01 ,& + & 9.999925e-01 ,9.999920e-01 ,9.999914e-01 ,9.999908e-01 ,9.999902e-01 ,& + & 9.999896e-01 ,9.999889e-01 ,9.999883e-01 ,9.999876e-01 ,9.999869e-01 ,& + & 9.999861e-01 ,9.999854e-01 ,9.999846e-01 ,9.999838e-01 ,9.999830e-01 ,& + & 9.999822e-01 ,9.999814e-01 ,9.999805e-01 ,9.999796e-01 ,9.999787e-01 ,& + & 9.999778e-01 ,9.999769e-01 ,9.999759e-01 /) + ssaice2(:, 29) = (/ & +! band 29 + & 7.042143e-01 ,6.691161e-01 ,6.463240e-01 ,6.296590e-01 ,6.166381e-01 ,& + & 6.060183e-01 ,5.970908e-01 ,5.894144e-01 ,5.826968e-01 ,5.767343e-01 ,& + & 5.713804e-01 ,5.665256e-01 ,5.620867e-01 ,5.579987e-01 ,5.542101e-01 ,& + & 5.506794e-01 ,5.473727e-01 ,5.442620e-01 ,5.413239e-01 ,5.385389e-01 ,& + & 5.358901e-01 ,5.333633e-01 ,5.309460e-01 ,5.286277e-01 ,5.263988e-01 ,& + & 5.242512e-01 ,5.221777e-01 ,5.201719e-01 ,5.182280e-01 ,5.163410e-01 ,& + & 5.145062e-01 ,5.127197e-01 ,5.109776e-01 ,5.092766e-01 ,5.076137e-01 ,& + & 5.059860e-01 ,5.043911e-01 ,5.028266e-01 ,5.012904e-01 ,4.997805e-01 ,& + & 4.982951e-01 ,4.968326e-01 ,4.953913e-01 /) + +! asymmetry factor: unitless + asyice2(:, 16) = (/ & +! band 16 + & 7.946655e-01 ,8.547685e-01 ,8.806016e-01 ,8.949880e-01 ,9.041676e-01 ,& + & 9.105399e-01 ,9.152249e-01 ,9.188160e-01 ,9.216573e-01 ,9.239620e-01 ,& + & 9.258695e-01 ,9.274745e-01 ,9.288441e-01 ,9.300267e-01 ,9.310584e-01 ,& + & 9.319665e-01 ,9.327721e-01 ,9.334918e-01 ,9.341387e-01 ,9.347236e-01 ,& + & 9.352551e-01 ,9.357402e-01 ,9.361850e-01 ,9.365942e-01 ,9.369722e-01 ,& + & 9.373225e-01 ,9.376481e-01 ,9.379516e-01 ,9.382352e-01 ,9.385010e-01 ,& + & 9.387505e-01 ,9.389854e-01 ,9.392070e-01 ,9.394163e-01 ,9.396145e-01 ,& + & 9.398024e-01 ,9.399809e-01 ,9.401508e-01 ,9.403126e-01 ,9.404670e-01 ,& + & 9.406144e-01 ,9.407555e-01 ,9.408906e-01 /) + asyice2(:, 17) = (/ & +! band 17 + & 9.078091e-01 ,9.195850e-01 ,9.267250e-01 ,9.317083e-01 ,9.354632e-01 ,& + & 9.384323e-01 ,9.408597e-01 ,9.428935e-01 ,9.446301e-01 ,9.461351e-01 ,& + & 9.474555e-01 ,9.486259e-01 ,9.496722e-01 ,9.506146e-01 ,9.514688e-01 ,& + & 9.522476e-01 ,9.529612e-01 ,9.536181e-01 ,9.542251e-01 ,9.547883e-01 ,& + & 9.553124e-01 ,9.558019e-01 ,9.562601e-01 ,9.566904e-01 ,9.570953e-01 ,& + & 9.574773e-01 ,9.578385e-01 ,9.581806e-01 ,9.585054e-01 ,9.588142e-01 ,& + & 9.591083e-01 ,9.593888e-01 ,9.596569e-01 ,9.599135e-01 ,9.601593e-01 ,& + & 9.603952e-01 ,9.606219e-01 ,9.608399e-01 ,9.610499e-01 ,9.612523e-01 ,& + & 9.614477e-01 ,9.616365e-01 ,9.618192e-01 /) + asyice2(:, 18) = (/ & +! band 18 + & 8.322045e-01 ,8.528693e-01 ,8.648167e-01 ,8.729163e-01 ,8.789054e-01 ,& + & 8.835845e-01 ,8.873819e-01 ,8.905511e-01 ,8.932532e-01 ,8.955965e-01 ,& + & 8.976567e-01 ,8.994887e-01 ,9.011334e-01 ,9.026221e-01 ,9.039791e-01 ,& + & 9.052237e-01 ,9.063715e-01 ,9.074349e-01 ,9.084245e-01 ,9.093489e-01 ,& + & 9.102154e-01 ,9.110303e-01 ,9.117987e-01 ,9.125253e-01 ,9.132140e-01 ,& + & 9.138682e-01 ,9.144910e-01 ,9.150850e-01 ,9.156524e-01 ,9.161955e-01 ,& + & 9.167160e-01 ,9.172157e-01 ,9.176959e-01 ,9.181581e-01 ,9.186034e-01 ,& + & 9.190330e-01 ,9.194478e-01 ,9.198488e-01 ,9.202368e-01 ,9.206126e-01 ,& + & 9.209768e-01 ,9.213301e-01 ,9.216731e-01 /) + asyice2(:, 19) = (/ & +! band 19 + & 8.116560e-01 ,8.488278e-01 ,8.674331e-01 ,8.788148e-01 ,8.865810e-01 ,& + & 8.922595e-01 ,8.966149e-01 ,9.000747e-01 ,9.028980e-01 ,9.052513e-01 ,& + & 9.072468e-01 ,9.089632e-01 ,9.104574e-01 ,9.117713e-01 ,9.129371e-01 ,& + & 9.139793e-01 ,9.149174e-01 ,9.157668e-01 ,9.165400e-01 ,9.172473e-01 ,& + & 9.178970e-01 ,9.184962e-01 ,9.190508e-01 ,9.195658e-01 ,9.200455e-01 ,& + & 9.204935e-01 ,9.209130e-01 ,9.213067e-01 ,9.216771e-01 ,9.220262e-01 ,& + & 9.223560e-01 ,9.226680e-01 ,9.229636e-01 ,9.232443e-01 ,9.235112e-01 ,& + & 9.237652e-01 ,9.240074e-01 ,9.242385e-01 ,9.244594e-01 ,9.246708e-01 ,& + & 9.248733e-01 ,9.250674e-01 ,9.252536e-01 /) + asyice2(:, 20) = (/ & +! band 20 + & 8.047113e-01 ,8.402864e-01 ,8.570332e-01 ,8.668455e-01 ,8.733206e-01 ,& + & 8.779272e-01 ,8.813796e-01 ,8.840676e-01 ,8.862225e-01 ,8.879904e-01 ,& + & 8.894682e-01 ,8.907228e-01 ,8.918019e-01 ,8.927404e-01 ,8.935645e-01 ,& + & 8.942943e-01 ,8.949452e-01 ,8.955296e-01 ,8.960574e-01 ,8.965366e-01 ,& + & 8.969736e-01 ,8.973740e-01 ,8.977422e-01 ,8.980820e-01 ,8.983966e-01 ,& + & 8.986889e-01 ,8.989611e-01 ,8.992153e-01 ,8.994533e-01 ,8.996766e-01 ,& + & 8.998865e-01 ,9.000843e-01 ,9.002709e-01 ,9.004474e-01 ,9.006146e-01 ,& + & 9.007731e-01 ,9.009237e-01 ,9.010670e-01 ,9.012034e-01 ,9.013336e-01 ,& + & 9.014579e-01 ,9.015767e-01 ,9.016904e-01 /) + asyice2(:, 21) = (/ & +! band 21 + & 8.179122e-01 ,8.480726e-01 ,8.621945e-01 ,8.704354e-01 ,8.758555e-01 ,& + & 8.797007e-01 ,8.825750e-01 ,8.848078e-01 ,8.865939e-01 ,8.880564e-01 ,& + & 8.892765e-01 ,8.903105e-01 ,8.911982e-01 ,8.919689e-01 ,8.926446e-01 ,& + & 8.932419e-01 ,8.937738e-01 ,8.942506e-01 ,8.946806e-01 ,8.950702e-01 ,& + & 8.954251e-01 ,8.957497e-01 ,8.960477e-01 ,8.963223e-01 ,8.965762e-01 ,& + & 8.968116e-01 ,8.970306e-01 ,8.972347e-01 ,8.974255e-01 ,8.976042e-01 ,& + & 8.977720e-01 ,8.979298e-01 ,8.980784e-01 ,8.982188e-01 ,8.983515e-01 ,& + & 8.984771e-01 ,8.985963e-01 ,8.987095e-01 ,8.988171e-01 ,8.989195e-01 ,& + & 8.990172e-01 ,8.991104e-01 ,8.991994e-01 /) + asyice2(:, 22) = (/ & +! band 22 + & 8.169789e-01 ,8.455024e-01 ,8.586925e-01 ,8.663283e-01 ,8.713217e-01 ,& + & 8.748488e-01 ,8.774765e-01 ,8.795122e-01 ,8.811370e-01 ,8.824649e-01 ,& + & 8.835711e-01 ,8.845073e-01 ,8.853103e-01 ,8.860068e-01 ,8.866170e-01 ,& + & 8.871560e-01 ,8.876358e-01 ,8.880658e-01 ,8.884533e-01 ,8.888044e-01 ,& + & 8.891242e-01 ,8.894166e-01 ,8.896851e-01 ,8.899324e-01 ,8.901612e-01 ,& + & 8.903733e-01 ,8.905706e-01 ,8.907545e-01 ,8.909265e-01 ,8.910876e-01 ,& + & 8.912388e-01 ,8.913812e-01 ,8.915153e-01 ,8.916419e-01 ,8.917617e-01 ,& + & 8.918752e-01 ,8.919829e-01 ,8.920851e-01 ,8.921824e-01 ,8.922751e-01 ,& + & 8.923635e-01 ,8.924478e-01 ,8.925284e-01 /) + asyice2(:, 23) = (/ & +! band 23 + & 8.387642e-01 ,8.569979e-01 ,8.658630e-01 ,8.711825e-01 ,8.747605e-01 ,& + & 8.773472e-01 ,8.793129e-01 ,8.808621e-01 ,8.821179e-01 ,8.831583e-01 ,& + & 8.840361e-01 ,8.847875e-01 ,8.854388e-01 ,8.860094e-01 ,8.865138e-01 ,& + & 8.869634e-01 ,8.873668e-01 ,8.877310e-01 ,8.880617e-01 ,8.883635e-01 ,& + & 8.886401e-01 ,8.888947e-01 ,8.891298e-01 ,8.893477e-01 ,8.895504e-01 ,& + & 8.897393e-01 ,8.899159e-01 ,8.900815e-01 ,8.902370e-01 ,8.903833e-01 ,& + & 8.905214e-01 ,8.906518e-01 ,8.907753e-01 ,8.908924e-01 ,8.910036e-01 ,& + & 8.911094e-01 ,8.912101e-01 ,8.913062e-01 ,8.913979e-01 ,8.914856e-01 ,& + & 8.915695e-01 ,8.916498e-01 ,8.917269e-01 /) + asyice2(:, 24) = (/ & +! band 24 + & 8.522208e-01 ,8.648132e-01 ,8.711224e-01 ,8.749901e-01 ,8.776354e-01 ,& + & 8.795743e-01 ,8.810649e-01 ,8.822518e-01 ,8.832225e-01 ,8.840333e-01 ,& + & 8.847224e-01 ,8.853162e-01 ,8.858342e-01 ,8.862906e-01 ,8.866962e-01 ,& + & 8.870595e-01 ,8.873871e-01 ,8.876842e-01 ,8.879551e-01 ,8.882032e-01 ,& + & 8.884316e-01 ,8.886425e-01 ,8.888380e-01 ,8.890199e-01 ,8.891895e-01 ,& + & 8.893481e-01 ,8.894968e-01 ,8.896366e-01 ,8.897683e-01 ,8.898926e-01 ,& + & 8.900102e-01 ,8.901215e-01 ,8.902272e-01 ,8.903276e-01 ,8.904232e-01 ,& + & 8.905144e-01 ,8.906014e-01 ,8.906845e-01 ,8.907640e-01 ,8.908402e-01 ,& + & 8.909132e-01 ,8.909834e-01 ,8.910507e-01 /) + asyice2(:, 25) = (/ & +! band 25 + & 8.578202e-01 ,8.683033e-01 ,8.735431e-01 ,8.767488e-01 ,8.789378e-01 ,& + & 8.805399e-01 ,8.817701e-01 ,8.827485e-01 ,8.835480e-01 ,8.842152e-01 ,& + & 8.847817e-01 ,8.852696e-01 ,8.856949e-01 ,8.860694e-01 ,8.864020e-01 ,& + & 8.866997e-01 ,8.869681e-01 ,8.872113e-01 ,8.874330e-01 ,8.876360e-01 ,& + & 8.878227e-01 ,8.879951e-01 ,8.881548e-01 ,8.883033e-01 ,8.884418e-01 ,& + & 8.885712e-01 ,8.886926e-01 ,8.888066e-01 ,8.889139e-01 ,8.890152e-01 ,& + & 8.891110e-01 ,8.892017e-01 ,8.892877e-01 ,8.893695e-01 ,8.894473e-01 ,& + & 8.895214e-01 ,8.895921e-01 ,8.896597e-01 ,8.897243e-01 ,8.897862e-01 ,& + & 8.898456e-01 ,8.899025e-01 ,8.899572e-01 /) + asyice2(:, 26) = (/ & +! band 26 + & 8.625615e-01 ,8.713831e-01 ,8.755799e-01 ,8.780560e-01 ,8.796983e-01 ,& + & 8.808714e-01 ,8.817534e-01 ,8.824420e-01 ,8.829953e-01 ,8.834501e-01 ,& + & 8.838310e-01 ,8.841549e-01 ,8.844338e-01 ,8.846767e-01 ,8.848902e-01 ,& + & 8.850795e-01 ,8.852484e-01 ,8.854002e-01 ,8.855374e-01 ,8.856620e-01 ,& + & 8.857758e-01 ,8.858800e-01 ,8.859759e-01 ,8.860644e-01 ,8.861464e-01 ,& + & 8.862225e-01 ,8.862935e-01 ,8.863598e-01 ,8.864218e-01 ,8.864800e-01 ,& + & 8.865347e-01 ,8.865863e-01 ,8.866349e-01 ,8.866809e-01 ,8.867245e-01 ,& + & 8.867658e-01 ,8.868050e-01 ,8.868423e-01 ,8.868778e-01 ,8.869117e-01 ,& + & 8.869440e-01 ,8.869749e-01 ,8.870044e-01 /) + asyice2(:, 27) = (/ & +! band 27 + & 8.587495e-01 ,8.684764e-01 ,8.728189e-01 ,8.752872e-01 ,8.768846e-01 ,& + & 8.780060e-01 ,8.788386e-01 ,8.794824e-01 ,8.799960e-01 ,8.804159e-01 ,& + & 8.807660e-01 ,8.810626e-01 ,8.813175e-01 ,8.815390e-01 ,8.817335e-01 ,& + & 8.819057e-01 ,8.820593e-01 ,8.821973e-01 ,8.823220e-01 ,8.824353e-01 ,& + & 8.825387e-01 ,8.826336e-01 ,8.827209e-01 ,8.828016e-01 ,8.828764e-01 ,& + & 8.829459e-01 ,8.830108e-01 ,8.830715e-01 ,8.831283e-01 ,8.831817e-01 ,& + & 8.832320e-01 ,8.832795e-01 ,8.833244e-01 ,8.833668e-01 ,8.834071e-01 ,& + & 8.834454e-01 ,8.834817e-01 ,8.835164e-01 ,8.835495e-01 ,8.835811e-01 ,& + & 8.836113e-01 ,8.836402e-01 ,8.836679e-01 /) + asyice2(:, 28) = (/ & +! band 28 + & 8.561110e-01 ,8.678583e-01 ,8.727554e-01 ,8.753892e-01 ,8.770154e-01 ,& + & 8.781109e-01 ,8.788949e-01 ,8.794812e-01 ,8.799348e-01 ,8.802952e-01 ,& + & 8.805880e-01 ,8.808300e-01 ,8.810331e-01 ,8.812058e-01 ,8.813543e-01 ,& + & 8.814832e-01 ,8.815960e-01 ,8.816956e-01 ,8.817839e-01 ,8.818629e-01 ,& + & 8.819339e-01 ,8.819979e-01 ,8.820560e-01 ,8.821089e-01 ,8.821573e-01 ,& + & 8.822016e-01 ,8.822425e-01 ,8.822801e-01 ,8.823150e-01 ,8.823474e-01 ,& + & 8.823775e-01 ,8.824056e-01 ,8.824318e-01 ,8.824564e-01 ,8.824795e-01 ,& + & 8.825011e-01 ,8.825215e-01 ,8.825408e-01 ,8.825589e-01 ,8.825761e-01 ,& + & 8.825924e-01 ,8.826078e-01 ,8.826224e-01 /) + asyice2(:, 29) = (/ & +! band 29 + & 8.311124e-01 ,8.688197e-01 ,8.900274e-01 ,9.040696e-01 ,9.142334e-01 ,& + & 9.220181e-01 ,9.282195e-01 ,9.333048e-01 ,9.375689e-01 ,9.412085e-01 ,& + & 9.443604e-01 ,9.471230e-01 ,9.495694e-01 ,9.517549e-01 ,9.537224e-01 ,& + & 9.555057e-01 ,9.571316e-01 ,9.586222e-01 ,9.599952e-01 ,9.612656e-01 ,& + & 9.624458e-01 ,9.635461e-01 ,9.645756e-01 ,9.655418e-01 ,9.664513e-01 ,& + & 9.673098e-01 ,9.681222e-01 ,9.688928e-01 ,9.696256e-01 ,9.703237e-01 ,& + & 9.709903e-01 ,9.716280e-01 ,9.722391e-01 ,9.728258e-01 ,9.733901e-01 ,& + & 9.739336e-01 ,9.744579e-01 ,9.749645e-01 ,9.754546e-01 ,9.759294e-01 ,& + & 9.763901e-01 ,9.768376e-01 ,9.772727e-01 /) + +! Hexagonal Ice Particle Parameterization +! extinction units (ext coef/iwc): [(m^-1)/(g m^-3)] + extice3(:, 16) = (/ & +! band 16 + & 5.194013e-01 ,3.215089e-01 ,2.327917e-01 ,1.824424e-01 ,1.499977e-01 ,& + & 1.273492e-01 ,1.106421e-01 ,9.780982e-02 ,8.764435e-02 ,7.939266e-02 ,& + & 7.256081e-02 ,6.681137e-02 ,6.190600e-02 ,5.767154e-02 ,5.397915e-02 ,& + & 5.073102e-02 ,4.785151e-02 ,4.528125e-02 ,4.297296e-02 ,4.088853e-02 ,& + & 3.899690e-02 ,3.727251e-02 ,3.569411e-02 ,3.424393e-02 ,3.290694e-02 ,& + & 3.167040e-02 ,3.052340e-02 ,2.945654e-02 ,2.846172e-02 ,2.753188e-02 ,& + & 2.666085e-02 ,2.584322e-02 ,2.507423e-02 ,2.434967e-02 ,2.366579e-02 ,& + & 2.301926e-02 ,2.240711e-02 ,2.182666e-02 ,2.127551e-02 ,2.075150e-02 ,& + & 2.025267e-02 ,1.977725e-02 ,1.932364e-02 ,1.889035e-02 ,1.847607e-02 ,& + & 1.807956e-02 /) + extice3(:, 17) = (/ & +! band 17 + & 4.901155e-01 ,3.065286e-01 ,2.230800e-01 ,1.753951e-01 ,1.445402e-01 ,& + & 1.229417e-01 ,1.069777e-01 ,9.469760e-02 ,8.495824e-02 ,7.704501e-02 ,& + & 7.048834e-02 ,6.496693e-02 ,6.025353e-02 ,5.618286e-02 ,5.263186e-02 ,& + & 4.950698e-02 ,4.673585e-02 ,4.426164e-02 ,4.203904e-02 ,4.003153e-02 ,& + & 3.820932e-02 ,3.654790e-02 ,3.502688e-02 ,3.362919e-02 ,3.234041e-02 ,& + & 3.114829e-02 ,3.004234e-02 ,2.901356e-02 ,2.805413e-02 ,2.715727e-02 ,& + & 2.631705e-02 ,2.552828e-02 ,2.478637e-02 ,2.408725e-02 ,2.342734e-02 ,& + & 2.280343e-02 ,2.221264e-02 ,2.165242e-02 ,2.112043e-02 ,2.061461e-02 ,& + & 2.013308e-02 ,1.967411e-02 ,1.923616e-02 ,1.881783e-02 ,1.841781e-02 ,& + & 1.803494e-02 /) + extice3(:, 18) = (/ & +! band 18 + & 5.056264e-01 ,3.160261e-01 ,2.298442e-01 ,1.805973e-01 ,1.487318e-01 ,& + & 1.264258e-01 ,1.099389e-01 ,9.725656e-02 ,8.719819e-02 ,7.902576e-02 ,& + & 7.225433e-02 ,6.655206e-02 ,6.168427e-02 ,5.748028e-02 ,5.381296e-02 ,& + & 5.058572e-02 ,4.772383e-02 ,4.516857e-02 ,4.287317e-02 ,4.079990e-02 ,& + & 3.891801e-02 ,3.720217e-02 ,3.563133e-02 ,3.418786e-02 ,3.285686e-02 ,& + & 3.162569e-02 ,3.048352e-02 ,2.942104e-02 ,2.843018e-02 ,2.750395e-02 ,& + & 2.663621e-02 ,2.582160e-02 ,2.505539e-02 ,2.433337e-02 ,2.365185e-02 ,& + & 2.300750e-02 ,2.239736e-02 ,2.181878e-02 ,2.126937e-02 ,2.074699e-02 ,& + & 2.024968e-02 ,1.977567e-02 ,1.932338e-02 ,1.889134e-02 ,1.847823e-02 ,& + & 1.808281e-02 /) + extice3(:, 19) = (/ & +! band 19 + & 4.881605e-01 ,3.055237e-01 ,2.225070e-01 ,1.750688e-01 ,1.443736e-01 ,& + & 1.228869e-01 ,1.070054e-01 ,9.478893e-02 ,8.509997e-02 ,7.722769e-02 ,& + & 7.070495e-02 ,6.521211e-02 ,6.052311e-02 ,5.647351e-02 ,5.294088e-02 ,& + & 4.983217e-02 ,4.707539e-02 ,4.461398e-02 ,4.240288e-02 ,4.040575e-02 ,& + & 3.859298e-02 ,3.694016e-02 ,3.542701e-02 ,3.403655e-02 ,3.275444e-02 ,& + & 3.156849e-02 ,3.046827e-02 ,2.944481e-02 ,2.849034e-02 ,2.759812e-02 ,& + & 2.676226e-02 ,2.597757e-02 ,2.523949e-02 ,2.454400e-02 ,2.388750e-02 ,& + & 2.326682e-02 ,2.267909e-02 ,2.212176e-02 ,2.159253e-02 ,2.108933e-02 ,& + & 2.061028e-02 ,2.015369e-02 ,1.971801e-02 ,1.930184e-02 ,1.890389e-02 ,& + & 1.852300e-02 /) + extice3(:, 20) = (/ & +! band 20 + & 5.103703e-01 ,3.188144e-01 ,2.317435e-01 ,1.819887e-01 ,1.497944e-01 ,& + & 1.272584e-01 ,1.106013e-01 ,9.778822e-02 ,8.762610e-02 ,7.936938e-02 ,& + & 7.252809e-02 ,6.676701e-02 ,6.184901e-02 ,5.760165e-02 ,5.389651e-02 ,& + & 5.063598e-02 ,4.774457e-02 ,4.516295e-02 ,4.284387e-02 ,4.074922e-02 ,& + & 3.884792e-02 ,3.711438e-02 ,3.552734e-02 ,3.406898e-02 ,3.272425e-02 ,& + & 3.148038e-02 ,3.032643e-02 ,2.925299e-02 ,2.825191e-02 ,2.731612e-02 ,& + & 2.643943e-02 ,2.561642e-02 ,2.484230e-02 ,2.411284e-02 ,2.342429e-02 ,& + & 2.277329e-02 ,2.215686e-02 ,2.157231e-02 ,2.101724e-02 ,2.048946e-02 ,& + & 1.998702e-02 ,1.950813e-02 ,1.905118e-02 ,1.861468e-02 ,1.819730e-02 ,& + & 1.779781e-02 /) + extice3(:, 21) = (/ & +! band 21 + & 5.031161e-01 ,3.144511e-01 ,2.286942e-01 ,1.796903e-01 ,1.479819e-01 ,& + & 1.257860e-01 ,1.093803e-01 ,9.676059e-02 ,8.675183e-02 ,7.861971e-02 ,& + & 7.188168e-02 ,6.620754e-02 ,6.136376e-02 ,5.718050e-02 ,5.353127e-02 ,& + & 5.031995e-02 ,4.747218e-02 ,4.492952e-02 ,4.264544e-02 ,4.058240e-02 ,& + & 3.870979e-02 ,3.700242e-02 ,3.543933e-02 ,3.400297e-02 ,3.267854e-02 ,& + & 3.145345e-02 ,3.031691e-02 ,2.925967e-02 ,2.827370e-02 ,2.735203e-02 ,& + & 2.648858e-02 ,2.567798e-02 ,2.491555e-02 ,2.419710e-02 ,2.351893e-02 ,& + & 2.287776e-02 ,2.227063e-02 ,2.169491e-02 ,2.114821e-02 ,2.062840e-02 ,& + & 2.013354e-02 ,1.966188e-02 ,1.921182e-02 ,1.878191e-02 ,1.837083e-02 ,& + & 1.797737e-02 /) + extice3(:, 22) = (/ & +! band 22 + & 4.949453e-01 ,3.095918e-01 ,2.253402e-01 ,1.771964e-01 ,1.460446e-01 ,& + & 1.242383e-01 ,1.081206e-01 ,9.572235e-02 ,8.588928e-02 ,7.789990e-02 ,& + & 7.128013e-02 ,6.570559e-02 ,6.094684e-02 ,5.683701e-02 ,5.325183e-02 ,& + & 5.009688e-02 ,4.729909e-02 ,4.480106e-02 ,4.255708e-02 ,4.053025e-02 ,& + & 3.869051e-02 ,3.701310e-02 ,3.547745e-02 ,3.406631e-02 ,3.276512e-02 ,& + & 3.156153e-02 ,3.044494e-02 ,2.940626e-02 ,2.843759e-02 ,2.753211e-02 ,& + & 2.668381e-02 ,2.588744e-02 ,2.513839e-02 ,2.443255e-02 ,2.376629e-02 ,& + & 2.313637e-02 ,2.253990e-02 ,2.197428e-02 ,2.143718e-02 ,2.092649e-02 ,& + & 2.044032e-02 ,1.997694e-02 ,1.953478e-02 ,1.911241e-02 ,1.870855e-02 ,& + & 1.832199e-02 /) + extice3(:, 23) = (/ & +! band 23 + & 5.052816e-01 ,3.157665e-01 ,2.296233e-01 ,1.803986e-01 ,1.485473e-01 ,& + & 1.262514e-01 ,1.097718e-01 ,9.709524e-02 ,8.704139e-02 ,7.887264e-02 ,& + & 7.210424e-02 ,6.640454e-02 ,6.153894e-02 ,5.733683e-02 ,5.367116e-02 ,& + & 5.044537e-02 ,4.758477e-02 ,4.503066e-02 ,4.273629e-02 ,4.066395e-02 ,& + & 3.878291e-02 ,3.706784e-02 ,3.549771e-02 ,3.405488e-02 ,3.272448e-02 ,& + & 3.149387e-02 ,3.035221e-02 ,2.929020e-02 ,2.829979e-02 ,2.737397e-02 ,& + & 2.650663e-02 ,2.569238e-02 ,2.492651e-02 ,2.420482e-02 ,2.352361e-02 ,& + & 2.287954e-02 ,2.226968e-02 ,2.169136e-02 ,2.114220e-02 ,2.062005e-02 ,& + & 2.012296e-02 ,1.964917e-02 ,1.919709e-02 ,1.876524e-02 ,1.835231e-02 ,& + & 1.795707e-02 /) + extice3(:, 24) = (/ & +! band 24 + & 5.042067e-01 ,3.151195e-01 ,2.291708e-01 ,1.800573e-01 ,1.482779e-01 ,& + & 1.260324e-01 ,1.095900e-01 ,9.694202e-02 ,8.691087e-02 ,7.876056e-02 ,& + & 7.200745e-02 ,6.632062e-02 ,6.146600e-02 ,5.727338e-02 ,5.361599e-02 ,& + & 5.039749e-02 ,4.754334e-02 ,4.499500e-02 ,4.270580e-02 ,4.063815e-02 ,& + & 3.876135e-02 ,3.705016e-02 ,3.548357e-02 ,3.404400e-02 ,3.271661e-02 ,& + & 3.148877e-02 ,3.034969e-02 ,2.929008e-02 ,2.830191e-02 ,2.737818e-02 ,& + & 2.651279e-02 ,2.570039e-02 ,2.493624e-02 ,2.421618e-02 ,2.353650e-02 ,& + & 2.289390e-02 ,2.228541e-02 ,2.170840e-02 ,2.116048e-02 ,2.063950e-02 ,& + & 2.014354e-02 ,1.967082e-02 ,1.921975e-02 ,1.878888e-02 ,1.837688e-02 ,& + & 1.798254e-02 /) + extice3(:, 25) = (/ & +! band 25 + & 5.022507e-01 ,3.139246e-01 ,2.283218e-01 ,1.794059e-01 ,1.477544e-01 ,& + & 1.255984e-01 ,1.092222e-01 ,9.662516e-02 ,8.663439e-02 ,7.851688e-02 ,& + & 7.179095e-02 ,6.612700e-02 ,6.129193e-02 ,5.711618e-02 ,5.347351e-02 ,& + & 5.026796e-02 ,4.742530e-02 ,4.488721e-02 ,4.260724e-02 ,4.054790e-02 ,& + & 3.867866e-02 ,3.697435e-02 ,3.541407e-02 ,3.398029e-02 ,3.265824e-02 ,& + & 3.143535e-02 ,3.030085e-02 ,2.924551e-02 ,2.826131e-02 ,2.734130e-02 ,& + & 2.647939e-02 ,2.567026e-02 ,2.490919e-02 ,2.419203e-02 ,2.351509e-02 ,& + & 2.287507e-02 ,2.226903e-02 ,2.169434e-02 ,2.114862e-02 ,2.062975e-02 ,& + & 2.013578e-02 ,1.966496e-02 ,1.921571e-02 ,1.878658e-02 ,1.837623e-02 ,& + & 1.798348e-02 /) + extice3(:, 26) = (/ & +! band 26 + & 5.068316e-01 ,3.166869e-01 ,2.302576e-01 ,1.808693e-01 ,1.489122e-01 ,& + & 1.265423e-01 ,1.100080e-01 ,9.728926e-02 ,8.720201e-02 ,7.900612e-02 ,& + & 7.221524e-02 ,6.649660e-02 ,6.161484e-02 ,5.739877e-02 ,5.372093e-02 ,& + & 5.048442e-02 ,4.761431e-02 ,4.505172e-02 ,4.274972e-02 ,4.067050e-02 ,& + & 3.878321e-02 ,3.706244e-02 ,3.548710e-02 ,3.403948e-02 ,3.270466e-02 ,& + & 3.146995e-02 ,3.032450e-02 ,2.925897e-02 ,2.826527e-02 ,2.733638e-02 ,& + & 2.646615e-02 ,2.564920e-02 ,2.488078e-02 ,2.415670e-02 ,2.347322e-02 ,& + & 2.282702e-02 ,2.221513e-02 ,2.163489e-02 ,2.108390e-02 ,2.056002e-02 ,& + & 2.006128e-02 ,1.958591e-02 ,1.913232e-02 ,1.869904e-02 ,1.828474e-02 ,& + & 1.788819e-02 /) + extice3(:, 27) = (/ & +! band 27 + & 5.077707e-01 ,3.172636e-01 ,2.306695e-01 ,1.811871e-01 ,1.491691e-01 ,& + & 1.267565e-01 ,1.101907e-01 ,9.744773e-02 ,8.734125e-02 ,7.912973e-02 ,& + & 7.232591e-02 ,6.659637e-02 ,6.170530e-02 ,5.748120e-02 ,5.379634e-02 ,& + & 5.055367e-02 ,4.767809e-02 ,4.511061e-02 ,4.280423e-02 ,4.072104e-02 ,& + & 3.883015e-02 ,3.710611e-02 ,3.552776e-02 ,3.407738e-02 ,3.274002e-02 ,& + & 3.150296e-02 ,3.035532e-02 ,2.928776e-02 ,2.829216e-02 ,2.736150e-02 ,& + & 2.648961e-02 ,2.567111e-02 ,2.490123e-02 ,2.417576e-02 ,2.349098e-02 ,& + & 2.284354e-02 ,2.223049e-02 ,2.164914e-02 ,2.109711e-02 ,2.057222e-02 ,& + & 2.007253e-02 ,1.959626e-02 ,1.914181e-02 ,1.870770e-02 ,1.829261e-02 ,& + & 1.789531e-02 /) + extice3(:, 28) = (/ & +! band 28 + & 5.062281e-01 ,3.163402e-01 ,2.300275e-01 ,1.807060e-01 ,1.487921e-01 ,& + & 1.264523e-01 ,1.099403e-01 ,9.723879e-02 ,8.716516e-02 ,7.898034e-02 ,& + & 7.219863e-02 ,6.648771e-02 ,6.161254e-02 ,5.740217e-02 ,5.372929e-02 ,& + & 5.049716e-02 ,4.763092e-02 ,4.507179e-02 ,4.277290e-02 ,4.069649e-02 ,& + & 3.881175e-02 ,3.709331e-02 ,3.552008e-02 ,3.407442e-02 ,3.274141e-02 ,& + & 3.150837e-02 ,3.036447e-02 ,2.930037e-02 ,2.830801e-02 ,2.738037e-02 ,& + & 2.651132e-02 ,2.569547e-02 ,2.492810e-02 ,2.420499e-02 ,2.352243e-02 ,& + & 2.287710e-02 ,2.226604e-02 ,2.168658e-02 ,2.113634e-02 ,2.061316e-02 ,& + & 2.011510e-02 ,1.964038e-02 ,1.918740e-02 ,1.875471e-02 ,1.834096e-02 ,& + & 1.794495e-02 /) + extice3(:, 29) = (/ & +! band 29 + & 1.338834e-01 ,1.924912e-01 ,1.755523e-01 ,1.534793e-01 ,1.343937e-01 ,& + & 1.187883e-01 ,1.060654e-01 ,9.559106e-02 ,8.685880e-02 ,7.948698e-02 ,& + & 7.319086e-02 ,6.775669e-02 ,6.302215e-02 ,5.886236e-02 ,5.517996e-02 ,& + & 5.189810e-02 ,4.895539e-02 ,4.630225e-02 ,4.389823e-02 ,4.171002e-02 ,& + & 3.970998e-02 ,3.787493e-02 ,3.618537e-02 ,3.462471e-02 ,3.317880e-02 ,& + & 3.183547e-02 ,3.058421e-02 ,2.941590e-02 ,2.832256e-02 ,2.729724e-02 ,& + & 2.633377e-02 ,2.542675e-02 ,2.457136e-02 ,2.376332e-02 ,2.299882e-02 ,& + & 2.227443e-02 ,2.158707e-02 ,2.093400e-02 ,2.031270e-02 ,1.972091e-02 ,& + & 1.915659e-02 ,1.861787e-02 ,1.810304e-02 ,1.761055e-02 ,1.713899e-02 ,& + & 1.668704e-02 /) + +! single-scattering albedo: unitless + ssaice3(:, 16) = (/ & +! band 16 + & 6.749442e-01 ,6.649947e-01 ,6.565828e-01 ,6.489928e-01 ,6.420046e-01 ,& + & 6.355231e-01 ,6.294964e-01 ,6.238901e-01 ,6.186783e-01 ,6.138395e-01 ,& + & 6.093543e-01 ,6.052049e-01 ,6.013742e-01 ,5.978457e-01 ,5.946030e-01 ,& + & 5.916302e-01 ,5.889115e-01 ,5.864310e-01 ,5.841731e-01 ,5.821221e-01 ,& + & 5.802624e-01 ,5.785785e-01 ,5.770549e-01 ,5.756759e-01 ,5.744262e-01 ,& + & 5.732901e-01 ,5.722524e-01 ,5.712974e-01 ,5.704097e-01 ,5.695739e-01 ,& + & 5.687747e-01 ,5.679964e-01 ,5.672238e-01 ,5.664415e-01 ,5.656340e-01 ,& + & 5.647860e-01 ,5.638821e-01 ,5.629070e-01 ,5.618452e-01 ,5.606815e-01 ,& + & 5.594006e-01 ,5.579870e-01 ,5.564255e-01 ,5.547008e-01 ,5.527976e-01 ,& + & 5.507005e-01 /) + ssaice3(:, 17) = (/ & +! band 17 + & 7.628550e-01 ,7.567297e-01 ,7.508463e-01 ,7.451972e-01 ,7.397745e-01 ,& + & 7.345705e-01 ,7.295775e-01 ,7.247881e-01 ,7.201945e-01 ,7.157894e-01 ,& + & 7.115652e-01 ,7.075145e-01 ,7.036300e-01 ,6.999044e-01 ,6.963304e-01 ,& + & 6.929007e-01 ,6.896083e-01 ,6.864460e-01 ,6.834067e-01 ,6.804833e-01 ,& + & 6.776690e-01 ,6.749567e-01 ,6.723397e-01 ,6.698109e-01 ,6.673637e-01 ,& + & 6.649913e-01 ,6.626870e-01 ,6.604441e-01 ,6.582561e-01 ,6.561163e-01 ,& + & 6.540182e-01 ,6.519554e-01 ,6.499215e-01 ,6.479099e-01 ,6.459145e-01 ,& + & 6.439289e-01 ,6.419468e-01 ,6.399621e-01 ,6.379686e-01 ,6.359601e-01 ,& + & 6.339306e-01 ,6.318740e-01 ,6.297845e-01 ,6.276559e-01 ,6.254825e-01 ,& + & 6.232583e-01 /) + ssaice3(:, 18) = (/ & +! band 18 + & 9.924147e-01 ,9.882792e-01 ,9.842257e-01 ,9.802522e-01 ,9.763566e-01 ,& + & 9.725367e-01 ,9.687905e-01 ,9.651157e-01 ,9.615104e-01 ,9.579725e-01 ,& + & 9.544997e-01 ,9.510901e-01 ,9.477416e-01 ,9.444520e-01 ,9.412194e-01 ,& + & 9.380415e-01 ,9.349165e-01 ,9.318421e-01 ,9.288164e-01 ,9.258373e-01 ,& + & 9.229027e-01 ,9.200106e-01 ,9.171589e-01 ,9.143457e-01 ,9.115688e-01 ,& + & 9.088263e-01 ,9.061161e-01 ,9.034362e-01 ,9.007846e-01 ,8.981592e-01 ,& + & 8.955581e-01 ,8.929792e-01 ,8.904206e-01 ,8.878803e-01 ,8.853562e-01 ,& + & 8.828464e-01 ,8.803488e-01 ,8.778616e-01 ,8.753827e-01 ,8.729102e-01 ,& + & 8.704421e-01 ,8.679764e-01 ,8.655112e-01 ,8.630445e-01 ,8.605744e-01 ,& + & 8.580989e-01 /) + ssaice3(:, 19) = (/ & +! band 19 + & 9.629413e-01 ,9.517182e-01 ,9.409209e-01 ,9.305366e-01 ,9.205529e-01 ,& + & 9.109569e-01 ,9.017362e-01 ,8.928780e-01 ,8.843699e-01 ,8.761992e-01 ,& + & 8.683536e-01 ,8.608204e-01 ,8.535873e-01 ,8.466417e-01 ,8.399712e-01 ,& + & 8.335635e-01 ,8.274062e-01 ,8.214868e-01 ,8.157932e-01 ,8.103129e-01 ,& + & 8.050336e-01 ,7.999432e-01 ,7.950294e-01 ,7.902798e-01 ,7.856825e-01 ,& + & 7.812250e-01 ,7.768954e-01 ,7.726815e-01 ,7.685711e-01 ,7.645522e-01 ,& + & 7.606126e-01 ,7.567404e-01 ,7.529234e-01 ,7.491498e-01 ,7.454074e-01 ,& + & 7.416844e-01 ,7.379688e-01 ,7.342485e-01 ,7.305118e-01 ,7.267468e-01 ,& + & 7.229415e-01 ,7.190841e-01 ,7.151628e-01 ,7.111657e-01 ,7.070811e-01 ,& + & 7.028972e-01 /) + ssaice3(:, 20) = (/ & +! band 20 + & 9.942270e-01 ,9.909206e-01 ,9.876775e-01 ,9.844960e-01 ,9.813746e-01 ,& + & 9.783114e-01 ,9.753049e-01 ,9.723535e-01 ,9.694553e-01 ,9.666088e-01 ,& + & 9.638123e-01 ,9.610641e-01 ,9.583626e-01 ,9.557060e-01 ,9.530928e-01 ,& + & 9.505211e-01 ,9.479895e-01 ,9.454961e-01 ,9.430393e-01 ,9.406174e-01 ,& + & 9.382288e-01 ,9.358717e-01 ,9.335446e-01 ,9.312456e-01 ,9.289731e-01 ,& + & 9.267255e-01 ,9.245010e-01 ,9.222980e-01 ,9.201147e-01 ,9.179496e-01 ,& + & 9.158008e-01 ,9.136667e-01 ,9.115457e-01 ,9.094359e-01 ,9.073358e-01 ,& + & 9.052436e-01 ,9.031577e-01 ,9.010763e-01 ,8.989977e-01 ,8.969203e-01 ,& + & 8.948423e-01 ,8.927620e-01 ,8.906778e-01 ,8.885879e-01 ,8.864907e-01 ,& + & 8.843843e-01 /) + ssaice3(:, 21) = (/ & +! band 21 + & 9.934014e-01 ,9.899331e-01 ,9.865537e-01 ,9.832610e-01 ,9.800523e-01 ,& + & 9.769254e-01 ,9.738777e-01 ,9.709069e-01 ,9.680106e-01 ,9.651862e-01 ,& + & 9.624315e-01 ,9.597439e-01 ,9.571212e-01 ,9.545608e-01 ,9.520605e-01 ,& + & 9.496177e-01 ,9.472301e-01 ,9.448954e-01 ,9.426111e-01 ,9.403749e-01 ,& + & 9.381843e-01 ,9.360370e-01 ,9.339307e-01 ,9.318629e-01 ,9.298313e-01 ,& + & 9.278336e-01 ,9.258673e-01 ,9.239302e-01 ,9.220198e-01 ,9.201338e-01 ,& + & 9.182700e-01 ,9.164258e-01 ,9.145991e-01 ,9.127874e-01 ,9.109884e-01 ,& + & 9.091999e-01 ,9.074194e-01 ,9.056447e-01 ,9.038735e-01 ,9.021033e-01 ,& + & 9.003320e-01 ,8.985572e-01 ,8.967766e-01 ,8.949879e-01 ,8.931888e-01 ,& + & 8.913770e-01 /) + ssaice3(:, 22) = (/ & +! band 22 + & 9.994833e-01 ,9.992055e-01 ,9.989278e-01 ,9.986500e-01 ,9.983724e-01 ,& + & 9.980947e-01 ,9.978172e-01 ,9.975397e-01 ,9.972623e-01 ,9.969849e-01 ,& + & 9.967077e-01 ,9.964305e-01 ,9.961535e-01 ,9.958765e-01 ,9.955997e-01 ,& + & 9.953230e-01 ,9.950464e-01 ,9.947699e-01 ,9.944936e-01 ,9.942174e-01 ,& + & 9.939414e-01 ,9.936656e-01 ,9.933899e-01 ,9.931144e-01 ,9.928390e-01 ,& + & 9.925639e-01 ,9.922889e-01 ,9.920141e-01 ,9.917396e-01 ,9.914652e-01 ,& + & 9.911911e-01 ,9.909171e-01 ,9.906434e-01 ,9.903700e-01 ,9.900967e-01 ,& + & 9.898237e-01 ,9.895510e-01 ,9.892784e-01 ,9.890062e-01 ,9.887342e-01 ,& + & 9.884625e-01 ,9.881911e-01 ,9.879199e-01 ,9.876490e-01 ,9.873784e-01 ,& + & 9.871081e-01 /) + ssaice3(:, 23) = (/ & +! band 23 + & 9.999343e-01 ,9.998917e-01 ,9.998492e-01 ,9.998067e-01 ,9.997642e-01 ,& + & 9.997218e-01 ,9.996795e-01 ,9.996372e-01 ,9.995949e-01 ,9.995528e-01 ,& + & 9.995106e-01 ,9.994686e-01 ,9.994265e-01 ,9.993845e-01 ,9.993426e-01 ,& + & 9.993007e-01 ,9.992589e-01 ,9.992171e-01 ,9.991754e-01 ,9.991337e-01 ,& + & 9.990921e-01 ,9.990505e-01 ,9.990089e-01 ,9.989674e-01 ,9.989260e-01 ,& + & 9.988846e-01 ,9.988432e-01 ,9.988019e-01 ,9.987606e-01 ,9.987194e-01 ,& + & 9.986782e-01 ,9.986370e-01 ,9.985959e-01 ,9.985549e-01 ,9.985139e-01 ,& + & 9.984729e-01 ,9.984319e-01 ,9.983910e-01 ,9.983502e-01 ,9.983094e-01 ,& + & 9.982686e-01 ,9.982279e-01 ,9.981872e-01 ,9.981465e-01 ,9.981059e-01 ,& + & 9.980653e-01 /) + ssaice3(:, 24) = (/ & +! band 24 + & 9.999978e-01 ,9.999965e-01 ,9.999952e-01 ,9.999939e-01 ,9.999926e-01 ,& + & 9.999913e-01 ,9.999900e-01 ,9.999887e-01 ,9.999873e-01 ,9.999860e-01 ,& + & 9.999847e-01 ,9.999834e-01 ,9.999821e-01 ,9.999808e-01 ,9.999795e-01 ,& + & 9.999782e-01 ,9.999769e-01 ,9.999756e-01 ,9.999743e-01 ,9.999730e-01 ,& + & 9.999717e-01 ,9.999704e-01 ,9.999691e-01 ,9.999678e-01 ,9.999665e-01 ,& + & 9.999652e-01 ,9.999639e-01 ,9.999626e-01 ,9.999613e-01 ,9.999600e-01 ,& + & 9.999587e-01 ,9.999574e-01 ,9.999561e-01 ,9.999548e-01 ,9.999535e-01 ,& + & 9.999522e-01 ,9.999509e-01 ,9.999496e-01 ,9.999483e-01 ,9.999470e-01 ,& + & 9.999457e-01 ,9.999444e-01 ,9.999431e-01 ,9.999418e-01 ,9.999405e-01 ,& + & 9.999392e-01 /) + ssaice3(:, 25) = (/ & +! band 25 + & 9.999994e-01 ,9.999993e-01 ,9.999991e-01 ,9.999990e-01 ,9.999989e-01 ,& + & 9.999987e-01 ,9.999986e-01 ,9.999984e-01 ,9.999983e-01 ,9.999982e-01 ,& + & 9.999980e-01 ,9.999979e-01 ,9.999977e-01 ,9.999976e-01 ,9.999975e-01 ,& + & 9.999973e-01 ,9.999972e-01 ,9.999970e-01 ,9.999969e-01 ,9.999967e-01 ,& + & 9.999966e-01 ,9.999965e-01 ,9.999963e-01 ,9.999962e-01 ,9.999960e-01 ,& + & 9.999959e-01 ,9.999957e-01 ,9.999956e-01 ,9.999954e-01 ,9.999953e-01 ,& + & 9.999952e-01 ,9.999950e-01 ,9.999949e-01 ,9.999947e-01 ,9.999946e-01 ,& + & 9.999944e-01 ,9.999943e-01 ,9.999941e-01 ,9.999940e-01 ,9.999939e-01 ,& + & 9.999937e-01 ,9.999936e-01 ,9.999934e-01 ,9.999933e-01 ,9.999931e-01 ,& + & 9.999930e-01 /) + ssaice3(:, 26) = (/ & +! band 26 + & 9.999997e-01 ,9.999995e-01 ,9.999992e-01 ,9.999990e-01 ,9.999987e-01 ,& + & 9.999985e-01 ,9.999983e-01 ,9.999980e-01 ,9.999978e-01 ,9.999976e-01 ,& + & 9.999973e-01 ,9.999971e-01 ,9.999969e-01 ,9.999967e-01 ,9.999965e-01 ,& + & 9.999963e-01 ,9.999960e-01 ,9.999958e-01 ,9.999956e-01 ,9.999954e-01 ,& + & 9.999952e-01 ,9.999950e-01 ,9.999948e-01 ,9.999946e-01 ,9.999944e-01 ,& + & 9.999942e-01 ,9.999939e-01 ,9.999937e-01 ,9.999935e-01 ,9.999933e-01 ,& + & 9.999931e-01 ,9.999929e-01 ,9.999927e-01 ,9.999925e-01 ,9.999923e-01 ,& + & 9.999920e-01 ,9.999918e-01 ,9.999916e-01 ,9.999914e-01 ,9.999911e-01 ,& + & 9.999909e-01 ,9.999907e-01 ,9.999905e-01 ,9.999902e-01 ,9.999900e-01 ,& + & 9.999897e-01 /) + ssaice3(:, 27) = (/ & +! band 27 + & 9.999991e-01 ,9.999985e-01 ,9.999980e-01 ,9.999974e-01 ,9.999968e-01 ,& + & 9.999963e-01 ,9.999957e-01 ,9.999951e-01 ,9.999946e-01 ,9.999940e-01 ,& + & 9.999934e-01 ,9.999929e-01 ,9.999923e-01 ,9.999918e-01 ,9.999912e-01 ,& + & 9.999907e-01 ,9.999901e-01 ,9.999896e-01 ,9.999891e-01 ,9.999885e-01 ,& + & 9.999880e-01 ,9.999874e-01 ,9.999869e-01 ,9.999863e-01 ,9.999858e-01 ,& + & 9.999853e-01 ,9.999847e-01 ,9.999842e-01 ,9.999836e-01 ,9.999831e-01 ,& + & 9.999826e-01 ,9.999820e-01 ,9.999815e-01 ,9.999809e-01 ,9.999804e-01 ,& + & 9.999798e-01 ,9.999793e-01 ,9.999787e-01 ,9.999782e-01 ,9.999776e-01 ,& + & 9.999770e-01 ,9.999765e-01 ,9.999759e-01 ,9.999754e-01 ,9.999748e-01 ,& + & 9.999742e-01 /) + ssaice3(:, 28) = (/ & +! band 28 + & 9.999975e-01 ,9.999961e-01 ,9.999946e-01 ,9.999931e-01 ,9.999917e-01 ,& + & 9.999903e-01 ,9.999888e-01 ,9.999874e-01 ,9.999859e-01 ,9.999845e-01 ,& + & 9.999831e-01 ,9.999816e-01 ,9.999802e-01 ,9.999788e-01 ,9.999774e-01 ,& + & 9.999759e-01 ,9.999745e-01 ,9.999731e-01 ,9.999717e-01 ,9.999702e-01 ,& + & 9.999688e-01 ,9.999674e-01 ,9.999660e-01 ,9.999646e-01 ,9.999631e-01 ,& + & 9.999617e-01 ,9.999603e-01 ,9.999589e-01 ,9.999574e-01 ,9.999560e-01 ,& + & 9.999546e-01 ,9.999532e-01 ,9.999517e-01 ,9.999503e-01 ,9.999489e-01 ,& + & 9.999474e-01 ,9.999460e-01 ,9.999446e-01 ,9.999431e-01 ,9.999417e-01 ,& + & 9.999403e-01 ,9.999388e-01 ,9.999374e-01 ,9.999359e-01 ,9.999345e-01 ,& + & 9.999330e-01 /) + ssaice3(:, 29) = (/ & +! band 29 + & 4.526500e-01 ,5.287890e-01 ,5.410487e-01 ,5.459865e-01 ,5.485149e-01 ,& + & 5.498914e-01 ,5.505895e-01 ,5.508310e-01 ,5.507364e-01 ,5.503793e-01 ,& + & 5.498090e-01 ,5.490612e-01 ,5.481637e-01 ,5.471395e-01 ,5.460083e-01 ,& + & 5.447878e-01 ,5.434946e-01 ,5.421442e-01 ,5.407514e-01 ,5.393309e-01 ,& + & 5.378970e-01 ,5.364641e-01 ,5.350464e-01 ,5.336582e-01 ,5.323140e-01 ,& + & 5.310283e-01 ,5.298158e-01 ,5.286914e-01 ,5.276704e-01 ,5.267680e-01 ,& + & 5.260000e-01 ,5.253823e-01 ,5.249311e-01 ,5.246629e-01 ,5.245946e-01 ,& + & 5.247434e-01 ,5.251268e-01 ,5.257626e-01 ,5.266693e-01 ,5.278653e-01 ,& + & 5.293698e-01 ,5.312022e-01 ,5.333823e-01 ,5.359305e-01 ,5.388676e-01 ,& + & 5.422146e-01 /) + +! asymmetry factor: unitless + asyice3(:, 16) = (/ & +! band 16 + & 8.340752e-01 ,8.435170e-01 ,8.517487e-01 ,8.592064e-01 ,8.660387e-01 ,& + & 8.723204e-01 ,8.780997e-01 ,8.834137e-01 ,8.882934e-01 ,8.927662e-01 ,& + & 8.968577e-01 ,9.005914e-01 ,9.039899e-01 ,9.070745e-01 ,9.098659e-01 ,& + & 9.123836e-01 ,9.146466e-01 ,9.166734e-01 ,9.184817e-01 ,9.200886e-01 ,& + & 9.215109e-01 ,9.227648e-01 ,9.238661e-01 ,9.248304e-01 ,9.256727e-01 ,& + & 9.264078e-01 ,9.270505e-01 ,9.276150e-01 ,9.281156e-01 ,9.285662e-01 ,& + & 9.289806e-01 ,9.293726e-01 ,9.297557e-01 ,9.301435e-01 ,9.305491e-01 ,& + & 9.309859e-01 ,9.314671e-01 ,9.320055e-01 ,9.326140e-01 ,9.333053e-01 ,& + & 9.340919e-01 ,9.349861e-01 ,9.360000e-01 ,9.371451e-01 ,9.384329e-01 ,& + & 9.398744e-01 /) + asyice3(:, 17) = (/ & +! band 17 + & 8.728160e-01 ,8.777333e-01 ,8.823754e-01 ,8.867535e-01 ,8.908785e-01 ,& + & 8.947611e-01 ,8.984118e-01 ,9.018408e-01 ,9.050582e-01 ,9.080739e-01 ,& + & 9.108976e-01 ,9.135388e-01 ,9.160068e-01 ,9.183106e-01 ,9.204595e-01 ,& + & 9.224620e-01 ,9.243271e-01 ,9.260632e-01 ,9.276788e-01 ,9.291822e-01 ,& + & 9.305817e-01 ,9.318853e-01 ,9.331012e-01 ,9.342372e-01 ,9.353013e-01 ,& + & 9.363013e-01 ,9.372450e-01 ,9.381400e-01 ,9.389939e-01 ,9.398145e-01 ,& + & 9.406092e-01 ,9.413856e-01 ,9.421511e-01 ,9.429131e-01 ,9.436790e-01 ,& + & 9.444561e-01 ,9.452517e-01 ,9.460729e-01 ,9.469270e-01 ,9.478209e-01 ,& + & 9.487617e-01 ,9.497562e-01 ,9.508112e-01 ,9.519335e-01 ,9.531294e-01 ,& + & 9.544055e-01 /) + asyice3(:, 18) = (/ & +! band 18 + & 7.897566e-01 ,7.948704e-01 ,7.998041e-01 ,8.045623e-01 ,8.091495e-01 ,& + & 8.135702e-01 ,8.178290e-01 ,8.219305e-01 ,8.258790e-01 ,8.296792e-01 ,& + & 8.333355e-01 ,8.368524e-01 ,8.402343e-01 ,8.434856e-01 ,8.466108e-01 ,& + & 8.496143e-01 ,8.525004e-01 ,8.552737e-01 ,8.579384e-01 ,8.604990e-01 ,& + & 8.629597e-01 ,8.653250e-01 ,8.675992e-01 ,8.697867e-01 ,8.718916e-01 ,& + & 8.739185e-01 ,8.758715e-01 ,8.777551e-01 ,8.795734e-01 ,8.813308e-01 ,& + & 8.830315e-01 ,8.846799e-01 ,8.862802e-01 ,8.878366e-01 ,8.893534e-01 ,& + & 8.908350e-01 ,8.922854e-01 ,8.937090e-01 ,8.951099e-01 ,8.964925e-01 ,& + & 8.978609e-01 ,8.992192e-01 ,9.005718e-01 ,9.019229e-01 ,9.032765e-01 ,& + & 9.046369e-01 /) + asyice3(:, 19) = (/ & +! band 19 + & 7.812615e-01 ,7.887764e-01 ,7.959664e-01 ,8.028413e-01 ,8.094109e-01 ,& + & 8.156849e-01 ,8.216730e-01 ,8.273846e-01 ,8.328294e-01 ,8.380166e-01 ,& + & 8.429556e-01 ,8.476556e-01 ,8.521258e-01 ,8.563753e-01 ,8.604131e-01 ,& + & 8.642481e-01 ,8.678893e-01 ,8.713455e-01 ,8.746254e-01 ,8.777378e-01 ,& + & 8.806914e-01 ,8.834948e-01 ,8.861566e-01 ,8.886854e-01 ,8.910897e-01 ,& + & 8.933779e-01 ,8.955586e-01 ,8.976402e-01 ,8.996311e-01 ,9.015398e-01 ,& + & 9.033745e-01 ,9.051436e-01 ,9.068555e-01 ,9.085185e-01 ,9.101410e-01 ,& + & 9.117311e-01 ,9.132972e-01 ,9.148476e-01 ,9.163905e-01 ,9.179340e-01 ,& + & 9.194864e-01 ,9.210559e-01 ,9.226505e-01 ,9.242784e-01 ,9.259476e-01 ,& + & 9.276661e-01 /) + asyice3(:, 20) = (/ & +! band 20 + & 7.640720e-01 ,7.691119e-01 ,7.739941e-01 ,7.787222e-01 ,7.832998e-01 ,& + & 7.877304e-01 ,7.920177e-01 ,7.961652e-01 ,8.001765e-01 ,8.040551e-01 ,& + & 8.078044e-01 ,8.114280e-01 ,8.149294e-01 ,8.183119e-01 ,8.215791e-01 ,& + & 8.247344e-01 ,8.277812e-01 ,8.307229e-01 ,8.335629e-01 ,8.363046e-01 ,& + & 8.389514e-01 ,8.415067e-01 ,8.439738e-01 ,8.463560e-01 ,8.486568e-01 ,& + & 8.508795e-01 ,8.530274e-01 ,8.551039e-01 ,8.571122e-01 ,8.590558e-01 ,& + & 8.609378e-01 ,8.627618e-01 ,8.645309e-01 ,8.662485e-01 ,8.679178e-01 ,& + & 8.695423e-01 ,8.711251e-01 ,8.726697e-01 ,8.741792e-01 ,8.756571e-01 ,& + & 8.771065e-01 ,8.785307e-01 ,8.799331e-01 ,8.813169e-01 ,8.826854e-01 ,& + & 8.840419e-01 /) + asyice3(:, 21) = (/ & +! band 21 + & 7.602598e-01 ,7.651572e-01 ,7.699014e-01 ,7.744962e-01 ,7.789452e-01 ,& + & 7.832522e-01 ,7.874205e-01 ,7.914538e-01 ,7.953555e-01 ,7.991290e-01 ,& + & 8.027777e-01 ,8.063049e-01 ,8.097140e-01 ,8.130081e-01 ,8.161906e-01 ,& + & 8.192645e-01 ,8.222331e-01 ,8.250993e-01 ,8.278664e-01 ,8.305374e-01 ,& + & 8.331153e-01 ,8.356030e-01 ,8.380037e-01 ,8.403201e-01 ,8.425553e-01 ,& + & 8.447121e-01 ,8.467935e-01 ,8.488022e-01 ,8.507412e-01 ,8.526132e-01 ,& + & 8.544210e-01 ,8.561675e-01 ,8.578554e-01 ,8.594875e-01 ,8.610665e-01 ,& + & 8.625951e-01 ,8.640760e-01 ,8.655119e-01 ,8.669055e-01 ,8.682594e-01 ,& + & 8.695763e-01 ,8.708587e-01 ,8.721094e-01 ,8.733308e-01 ,8.745255e-01 ,& + & 8.756961e-01 /) + asyice3(:, 22) = (/ & +! band 22 + & 7.568957e-01 ,7.606995e-01 ,7.644072e-01 ,7.680204e-01 ,7.715402e-01 ,& + & 7.749682e-01 ,7.783057e-01 ,7.815541e-01 ,7.847148e-01 ,7.877892e-01 ,& + & 7.907786e-01 ,7.936846e-01 ,7.965084e-01 ,7.992515e-01 ,8.019153e-01 ,& + & 8.045011e-01 ,8.070103e-01 ,8.094444e-01 ,8.118048e-01 ,8.140927e-01 ,& + & 8.163097e-01 ,8.184571e-01 ,8.205364e-01 ,8.225488e-01 ,8.244958e-01 ,& + & 8.263789e-01 ,8.281993e-01 ,8.299586e-01 ,8.316580e-01 ,8.332991e-01 ,& + & 8.348831e-01 ,8.364115e-01 ,8.378857e-01 ,8.393071e-01 ,8.406770e-01 ,& + & 8.419969e-01 ,8.432682e-01 ,8.444923e-01 ,8.456706e-01 ,8.468044e-01 ,& + & 8.478952e-01 ,8.489444e-01 ,8.499533e-01 ,8.509234e-01 ,8.518561e-01 ,& + & 8.527528e-01 /) + asyice3(:, 23) = (/ & +! band 23 + & 7.575066e-01 ,7.606912e-01 ,7.638236e-01 ,7.669035e-01 ,7.699306e-01 ,& + & 7.729046e-01 ,7.758254e-01 ,7.786926e-01 ,7.815060e-01 ,7.842654e-01 ,& + & 7.869705e-01 ,7.896211e-01 ,7.922168e-01 ,7.947574e-01 ,7.972428e-01 ,& + & 7.996726e-01 ,8.020466e-01 ,8.043646e-01 ,8.066262e-01 ,8.088313e-01 ,& + & 8.109796e-01 ,8.130709e-01 ,8.151049e-01 ,8.170814e-01 ,8.190001e-01 ,& + & 8.208608e-01 ,8.226632e-01 ,8.244071e-01 ,8.260924e-01 ,8.277186e-01 ,& + & 8.292856e-01 ,8.307932e-01 ,8.322411e-01 ,8.336291e-01 ,8.349570e-01 ,& + & 8.362244e-01 ,8.374312e-01 ,8.385772e-01 ,8.396621e-01 ,8.406856e-01 ,& + & 8.416476e-01 ,8.425479e-01 ,8.433861e-01 ,8.441620e-01 ,8.448755e-01 ,& + & 8.455263e-01 /) + asyice3(:, 24) = (/ & +! band 24 + & 7.568829e-01 ,7.597947e-01 ,7.626745e-01 ,7.655212e-01 ,7.683337e-01 ,& + & 7.711111e-01 ,7.738523e-01 ,7.765565e-01 ,7.792225e-01 ,7.818494e-01 ,& + & 7.844362e-01 ,7.869819e-01 ,7.894854e-01 ,7.919459e-01 ,7.943623e-01 ,& + & 7.967337e-01 ,7.990590e-01 ,8.013373e-01 ,8.035676e-01 ,8.057488e-01 ,& + & 8.078802e-01 ,8.099605e-01 ,8.119890e-01 ,8.139645e-01 ,8.158862e-01 ,& + & 8.177530e-01 ,8.195641e-01 ,8.213183e-01 ,8.230149e-01 ,8.246527e-01 ,& + & 8.262308e-01 ,8.277483e-01 ,8.292042e-01 ,8.305976e-01 ,8.319275e-01 ,& + & 8.331929e-01 ,8.343929e-01 ,8.355265e-01 ,8.365928e-01 ,8.375909e-01 ,& + & 8.385197e-01 ,8.393784e-01 ,8.401659e-01 ,8.408815e-01 ,8.415240e-01 ,& + & 8.420926e-01 /) + asyice3(:, 25) = (/ & +! band 25 + & 7.548616e-01 ,7.575454e-01 ,7.602153e-01 ,7.628696e-01 ,7.655067e-01 ,& + & 7.681249e-01 ,7.707225e-01 ,7.732978e-01 ,7.758492e-01 ,7.783750e-01 ,& + & 7.808735e-01 ,7.833430e-01 ,7.857819e-01 ,7.881886e-01 ,7.905612e-01 ,& + & 7.928983e-01 ,7.951980e-01 ,7.974588e-01 ,7.996789e-01 ,8.018567e-01 ,& + & 8.039905e-01 ,8.060787e-01 ,8.081196e-01 ,8.101115e-01 ,8.120527e-01 ,& + & 8.139416e-01 ,8.157764e-01 ,8.175557e-01 ,8.192776e-01 ,8.209405e-01 ,& + & 8.225427e-01 ,8.240826e-01 ,8.255585e-01 ,8.269688e-01 ,8.283117e-01 ,& + & 8.295856e-01 ,8.307889e-01 ,8.319198e-01 ,8.329767e-01 ,8.339579e-01 ,& + & 8.348619e-01 ,8.356868e-01 ,8.364311e-01 ,8.370930e-01 ,8.376710e-01 ,& + & 8.381633e-01 /) + asyice3(:, 26) = (/ & +! band 26 + & 7.491854e-01 ,7.518523e-01 ,7.545089e-01 ,7.571534e-01 ,7.597839e-01 ,& + & 7.623987e-01 ,7.649959e-01 ,7.675737e-01 ,7.701303e-01 ,7.726639e-01 ,& + & 7.751727e-01 ,7.776548e-01 ,7.801084e-01 ,7.825318e-01 ,7.849230e-01 ,& + & 7.872804e-01 ,7.896020e-01 ,7.918862e-01 ,7.941309e-01 ,7.963345e-01 ,& + & 7.984951e-01 ,8.006109e-01 ,8.026802e-01 ,8.047009e-01 ,8.066715e-01 ,& + & 8.085900e-01 ,8.104546e-01 ,8.122636e-01 ,8.140150e-01 ,8.157072e-01 ,& + & 8.173382e-01 ,8.189063e-01 ,8.204096e-01 ,8.218464e-01 ,8.232148e-01 ,& + & 8.245130e-01 ,8.257391e-01 ,8.268915e-01 ,8.279682e-01 ,8.289675e-01 ,& + & 8.298875e-01 ,8.307264e-01 ,8.314824e-01 ,8.321537e-01 ,8.327385e-01 ,& + & 8.332350e-01 /) + asyice3(:, 27) = (/ & +! band 27 + & 7.397086e-01 ,7.424069e-01 ,7.450955e-01 ,7.477725e-01 ,7.504362e-01 ,& + & 7.530846e-01 ,7.557159e-01 ,7.583283e-01 ,7.609199e-01 ,7.634888e-01 ,& + & 7.660332e-01 ,7.685512e-01 ,7.710411e-01 ,7.735009e-01 ,7.759288e-01 ,& + & 7.783229e-01 ,7.806814e-01 ,7.830024e-01 ,7.852841e-01 ,7.875246e-01 ,& + & 7.897221e-01 ,7.918748e-01 ,7.939807e-01 ,7.960380e-01 ,7.980449e-01 ,& + & 7.999995e-01 ,8.019000e-01 ,8.037445e-01 ,8.055311e-01 ,8.072581e-01 ,& + & 8.089235e-01 ,8.105255e-01 ,8.120623e-01 ,8.135319e-01 ,8.149326e-01 ,& + & 8.162626e-01 ,8.175198e-01 ,8.187025e-01 ,8.198089e-01 ,8.208371e-01 ,& + & 8.217852e-01 ,8.226514e-01 ,8.234338e-01 ,8.241306e-01 ,8.247399e-01 ,& + & 8.252599e-01 /) + asyice3(:, 28) = (/ & +! band 28 + & 7.224533e-01 ,7.251681e-01 ,7.278728e-01 ,7.305654e-01 ,7.332444e-01 ,& + & 7.359078e-01 ,7.385539e-01 ,7.411808e-01 ,7.437869e-01 ,7.463702e-01 ,& + & 7.489291e-01 ,7.514616e-01 ,7.539661e-01 ,7.564408e-01 ,7.588837e-01 ,& + & 7.612933e-01 ,7.636676e-01 ,7.660049e-01 ,7.683034e-01 ,7.705612e-01 ,& + & 7.727767e-01 ,7.749480e-01 ,7.770733e-01 ,7.791509e-01 ,7.811789e-01 ,& + & 7.831556e-01 ,7.850791e-01 ,7.869478e-01 ,7.887597e-01 ,7.905131e-01 ,& + & 7.922062e-01 ,7.938372e-01 ,7.954044e-01 ,7.969059e-01 ,7.983399e-01 ,& + & 7.997047e-01 ,8.009985e-01 ,8.022195e-01 ,8.033658e-01 ,8.044357e-01 ,& + & 8.054275e-01 ,8.063392e-01 ,8.071692e-01 ,8.079157e-01 ,8.085768e-01 ,& + & 8.091507e-01 /) + asyice3(:, 29) = (/ & +! band 29 + & 8.850026e-01 ,9.005489e-01 ,9.069242e-01 ,9.121799e-01 ,9.168987e-01 ,& + & 9.212259e-01 ,9.252176e-01 ,9.289028e-01 ,9.323000e-01 ,9.354235e-01 ,& + & 9.382858e-01 ,9.408985e-01 ,9.432734e-01 ,9.454218e-01 ,9.473557e-01 ,& + & 9.490871e-01 ,9.506282e-01 ,9.519917e-01 ,9.531904e-01 ,9.542374e-01 ,& + & 9.551461e-01 ,9.559298e-01 ,9.566023e-01 ,9.571775e-01 ,9.576692e-01 ,& + & 9.580916e-01 ,9.584589e-01 ,9.587853e-01 ,9.590851e-01 ,9.593729e-01 ,& + & 9.596632e-01 ,9.599705e-01 ,9.603096e-01 ,9.606954e-01 ,9.611427e-01 ,& + & 9.616667e-01 ,9.622826e-01 ,9.630060e-01 ,9.638524e-01 ,9.648379e-01 ,& + & 9.659788e-01 ,9.672916e-01 ,9.687933e-01 ,9.705014e-01 ,9.724337e-01 ,& + & 9.746084e-01 /) + +! fdelta: unitless + fdlice3(:, 16) = (/ & +! band 16 + & 4.959277e-02 ,4.685292e-02 ,4.426104e-02 ,4.181231e-02 ,3.950191e-02 ,& + & 3.732500e-02 ,3.527675e-02 ,3.335235e-02 ,3.154697e-02 ,2.985578e-02 ,& + & 2.827395e-02 ,2.679666e-02 ,2.541909e-02 ,2.413640e-02 ,2.294378e-02 ,& + & 2.183639e-02 ,2.080940e-02 ,1.985801e-02 ,1.897736e-02 ,1.816265e-02 ,& + & 1.740905e-02 ,1.671172e-02 ,1.606585e-02 ,1.546661e-02 ,1.490917e-02 ,& + & 1.438870e-02 ,1.390038e-02 ,1.343939e-02 ,1.300089e-02 ,1.258006e-02 ,& + & 1.217208e-02 ,1.177212e-02 ,1.137536e-02 ,1.097696e-02 ,1.057210e-02 ,& + & 1.015596e-02 ,9.723704e-03 ,9.270516e-03 ,8.791565e-03 ,8.282026e-03 ,& + & 7.737072e-03 ,7.151879e-03 ,6.521619e-03 ,5.841467e-03 ,5.106597e-03 ,& + & 4.312183e-03 /) + fdlice3(:, 17) = (/ & +! band 17 + & 5.071224e-02 ,5.000217e-02 ,4.933872e-02 ,4.871992e-02 ,4.814380e-02 ,& + & 4.760839e-02 ,4.711170e-02 ,4.665177e-02 ,4.622662e-02 ,4.583426e-02 ,& + & 4.547274e-02 ,4.514007e-02 ,4.483428e-02 ,4.455340e-02 ,4.429544e-02 ,& + & 4.405844e-02 ,4.384041e-02 ,4.363939e-02 ,4.345340e-02 ,4.328047e-02 ,& + & 4.311861e-02 ,4.296586e-02 ,4.282024e-02 ,4.267977e-02 ,4.254248e-02 ,& + & 4.240640e-02 ,4.226955e-02 ,4.212995e-02 ,4.198564e-02 ,4.183462e-02 ,& + & 4.167494e-02 ,4.150462e-02 ,4.132167e-02 ,4.112413e-02 ,4.091003e-02 ,& + & 4.067737e-02 ,4.042420e-02 ,4.014854e-02 ,3.984840e-02 ,3.952183e-02 ,& + & 3.916683e-02 ,3.878144e-02 ,3.836368e-02 ,3.791158e-02 ,3.742316e-02 ,& + & 3.689645e-02 /) + fdlice3(:, 18) = (/ & +! band 18 + & 1.062938e-01 ,1.065234e-01 ,1.067822e-01 ,1.070682e-01 ,1.073793e-01 ,& + & 1.077137e-01 ,1.080693e-01 ,1.084442e-01 ,1.088364e-01 ,1.092439e-01 ,& + & 1.096647e-01 ,1.100970e-01 ,1.105387e-01 ,1.109878e-01 ,1.114423e-01 ,& + & 1.119004e-01 ,1.123599e-01 ,1.128190e-01 ,1.132757e-01 ,1.137279e-01 ,& + & 1.141738e-01 ,1.146113e-01 ,1.150385e-01 ,1.154534e-01 ,1.158540e-01 ,& + & 1.162383e-01 ,1.166045e-01 ,1.169504e-01 ,1.172741e-01 ,1.175738e-01 ,& + & 1.178472e-01 ,1.180926e-01 ,1.183080e-01 ,1.184913e-01 ,1.186405e-01 ,& + & 1.187538e-01 ,1.188291e-01 ,1.188645e-01 ,1.188580e-01 ,1.188076e-01 ,& + & 1.187113e-01 ,1.185672e-01 ,1.183733e-01 ,1.181277e-01 ,1.178282e-01 ,& + & 1.174731e-01 /) + fdlice3(:, 19) = (/ & +! band 19 + & 1.076195e-01 ,1.065195e-01 ,1.054696e-01 ,1.044673e-01 ,1.035099e-01 ,& + & 1.025951e-01 ,1.017203e-01 ,1.008831e-01 ,1.000808e-01 ,9.931116e-02 ,& + & 9.857151e-02 ,9.785939e-02 ,9.717230e-02 ,9.650774e-02 ,9.586322e-02 ,& + & 9.523623e-02 ,9.462427e-02 ,9.402484e-02 ,9.343544e-02 ,9.285358e-02 ,& + & 9.227675e-02 ,9.170245e-02 ,9.112818e-02 ,9.055144e-02 ,8.996974e-02 ,& + & 8.938056e-02 ,8.878142e-02 ,8.816981e-02 ,8.754323e-02 ,8.689919e-02 ,& + & 8.623517e-02 ,8.554869e-02 ,8.483724e-02 ,8.409832e-02 ,8.332943e-02 ,& + & 8.252807e-02 ,8.169175e-02 ,8.081795e-02 ,7.990419e-02 ,7.894796e-02 ,& + & 7.794676e-02 ,7.689809e-02 ,7.579945e-02 ,7.464834e-02 ,7.344227e-02 ,& + & 7.217872e-02 /) + fdlice3(:, 20) = (/ & +! band 20 + & 1.119014e-01 ,1.122706e-01 ,1.126690e-01 ,1.130947e-01 ,1.135456e-01 ,& + & 1.140199e-01 ,1.145154e-01 ,1.150302e-01 ,1.155623e-01 ,1.161096e-01 ,& + & 1.166703e-01 ,1.172422e-01 ,1.178233e-01 ,1.184118e-01 ,1.190055e-01 ,& + & 1.196025e-01 ,1.202008e-01 ,1.207983e-01 ,1.213931e-01 ,1.219832e-01 ,& + & 1.225665e-01 ,1.231411e-01 ,1.237050e-01 ,1.242561e-01 ,1.247926e-01 ,& + & 1.253122e-01 ,1.258132e-01 ,1.262934e-01 ,1.267509e-01 ,1.271836e-01 ,& + & 1.275896e-01 ,1.279669e-01 ,1.283134e-01 ,1.286272e-01 ,1.289063e-01 ,& + & 1.291486e-01 ,1.293522e-01 ,1.295150e-01 ,1.296351e-01 ,1.297104e-01 ,& + & 1.297390e-01 ,1.297189e-01 ,1.296480e-01 ,1.295244e-01 ,1.293460e-01 ,& + & 1.291109e-01 /) + fdlice3(:, 21) = (/ & +! band 21 + & 1.133298e-01 ,1.136777e-01 ,1.140556e-01 ,1.144615e-01 ,1.148934e-01 ,& + & 1.153492e-01 ,1.158269e-01 ,1.163243e-01 ,1.168396e-01 ,1.173706e-01 ,& + & 1.179152e-01 ,1.184715e-01 ,1.190374e-01 ,1.196108e-01 ,1.201897e-01 ,& + & 1.207720e-01 ,1.213558e-01 ,1.219389e-01 ,1.225194e-01 ,1.230951e-01 ,& + & 1.236640e-01 ,1.242241e-01 ,1.247733e-01 ,1.253096e-01 ,1.258309e-01 ,& + & 1.263352e-01 ,1.268205e-01 ,1.272847e-01 ,1.277257e-01 ,1.281415e-01 ,& + & 1.285300e-01 ,1.288893e-01 ,1.292173e-01 ,1.295118e-01 ,1.297710e-01 ,& + & 1.299927e-01 ,1.301748e-01 ,1.303154e-01 ,1.304124e-01 ,1.304637e-01 ,& + & 1.304673e-01 ,1.304212e-01 ,1.303233e-01 ,1.301715e-01 ,1.299638e-01 ,& + & 1.296983e-01 /) + fdlice3(:, 22) = (/ & +! band 22 + & 1.145360e-01 ,1.153256e-01 ,1.161453e-01 ,1.169929e-01 ,1.178666e-01 ,& + & 1.187641e-01 ,1.196835e-01 ,1.206227e-01 ,1.215796e-01 ,1.225522e-01 ,& + & 1.235383e-01 ,1.245361e-01 ,1.255433e-01 ,1.265579e-01 ,1.275779e-01 ,& + & 1.286011e-01 ,1.296257e-01 ,1.306494e-01 ,1.316703e-01 ,1.326862e-01 ,& + & 1.336951e-01 ,1.346950e-01 ,1.356838e-01 ,1.366594e-01 ,1.376198e-01 ,& + & 1.385629e-01 ,1.394866e-01 ,1.403889e-01 ,1.412678e-01 ,1.421212e-01 ,& + & 1.429469e-01 ,1.437430e-01 ,1.445074e-01 ,1.452381e-01 ,1.459329e-01 ,& + & 1.465899e-01 ,1.472069e-01 ,1.477819e-01 ,1.483128e-01 ,1.487976e-01 ,& + & 1.492343e-01 ,1.496207e-01 ,1.499548e-01 ,1.502346e-01 ,1.504579e-01 ,& + & 1.506227e-01 /) + fdlice3(:, 23) = (/ & +! band 23 + & 1.153263e-01 ,1.161445e-01 ,1.169932e-01 ,1.178703e-01 ,1.187738e-01 ,& + & 1.197016e-01 ,1.206516e-01 ,1.216217e-01 ,1.226099e-01 ,1.236141e-01 ,& + & 1.246322e-01 ,1.256621e-01 ,1.267017e-01 ,1.277491e-01 ,1.288020e-01 ,& + & 1.298584e-01 ,1.309163e-01 ,1.319736e-01 ,1.330281e-01 ,1.340778e-01 ,& + & 1.351207e-01 ,1.361546e-01 ,1.371775e-01 ,1.381873e-01 ,1.391820e-01 ,& + & 1.401593e-01 ,1.411174e-01 ,1.420540e-01 ,1.429671e-01 ,1.438547e-01 ,& + & 1.447146e-01 ,1.455449e-01 ,1.463433e-01 ,1.471078e-01 ,1.478364e-01 ,& + & 1.485270e-01 ,1.491774e-01 ,1.497857e-01 ,1.503497e-01 ,1.508674e-01 ,& + & 1.513367e-01 ,1.517554e-01 ,1.521216e-01 ,1.524332e-01 ,1.526880e-01 ,& + & 1.528840e-01 /) + fdlice3(:, 24) = (/ & +! band 24 + & 1.160842e-01 ,1.169118e-01 ,1.177697e-01 ,1.186556e-01 ,1.195676e-01 ,& + & 1.205036e-01 ,1.214616e-01 ,1.224394e-01 ,1.234349e-01 ,1.244463e-01 ,& + & 1.254712e-01 ,1.265078e-01 ,1.275539e-01 ,1.286075e-01 ,1.296664e-01 ,& + & 1.307287e-01 ,1.317923e-01 ,1.328550e-01 ,1.339149e-01 ,1.349699e-01 ,& + & 1.360179e-01 ,1.370567e-01 ,1.380845e-01 ,1.390991e-01 ,1.400984e-01 ,& + & 1.410803e-01 ,1.420429e-01 ,1.429840e-01 ,1.439016e-01 ,1.447936e-01 ,& + & 1.456579e-01 ,1.464925e-01 ,1.472953e-01 ,1.480642e-01 ,1.487972e-01 ,& + & 1.494923e-01 ,1.501472e-01 ,1.507601e-01 ,1.513287e-01 ,1.518511e-01 ,& + & 1.523252e-01 ,1.527489e-01 ,1.531201e-01 ,1.534368e-01 ,1.536969e-01 ,& + & 1.538984e-01 /) + fdlice3(:, 25) = (/ & +! band 25 + & 1.168725e-01 ,1.177088e-01 ,1.185747e-01 ,1.194680e-01 ,1.203867e-01 ,& + & 1.213288e-01 ,1.222923e-01 ,1.232750e-01 ,1.242750e-01 ,1.252903e-01 ,& + & 1.263187e-01 ,1.273583e-01 ,1.284069e-01 ,1.294626e-01 ,1.305233e-01 ,& + & 1.315870e-01 ,1.326517e-01 ,1.337152e-01 ,1.347756e-01 ,1.358308e-01 ,& + & 1.368788e-01 ,1.379175e-01 ,1.389449e-01 ,1.399590e-01 ,1.409577e-01 ,& + & 1.419389e-01 ,1.429007e-01 ,1.438410e-01 ,1.447577e-01 ,1.456488e-01 ,& + & 1.465123e-01 ,1.473461e-01 ,1.481483e-01 ,1.489166e-01 ,1.496492e-01 ,& + & 1.503439e-01 ,1.509988e-01 ,1.516118e-01 ,1.521808e-01 ,1.527038e-01 ,& + & 1.531788e-01 ,1.536037e-01 ,1.539764e-01 ,1.542951e-01 ,1.545575e-01 ,& + & 1.547617e-01 /) + fdlice3(:, 26) = (/ & +!band 26 + & 1.180509e-01 ,1.189025e-01 ,1.197820e-01 ,1.206875e-01 ,1.216171e-01 ,& + & 1.225687e-01 ,1.235404e-01 ,1.245303e-01 ,1.255363e-01 ,1.265564e-01 ,& + & 1.275888e-01 ,1.286313e-01 ,1.296821e-01 ,1.307392e-01 ,1.318006e-01 ,& + & 1.328643e-01 ,1.339284e-01 ,1.349908e-01 ,1.360497e-01 ,1.371029e-01 ,& + & 1.381486e-01 ,1.391848e-01 ,1.402095e-01 ,1.412208e-01 ,1.422165e-01 ,& + & 1.431949e-01 ,1.441539e-01 ,1.450915e-01 ,1.460058e-01 ,1.468947e-01 ,& + & 1.477564e-01 ,1.485888e-01 ,1.493900e-01 ,1.501580e-01 ,1.508907e-01 ,& + & 1.515864e-01 ,1.522428e-01 ,1.528582e-01 ,1.534305e-01 ,1.539578e-01 ,& + & 1.544380e-01 ,1.548692e-01 ,1.552494e-01 ,1.555767e-01 ,1.558490e-01 ,& + & 1.560645e-01 /) + fdlice3(:, 27) = (/ & +! band 27 + & 1.200480e-01 ,1.209267e-01 ,1.218304e-01 ,1.227575e-01 ,1.237059e-01 ,& + & 1.246739e-01 ,1.256595e-01 ,1.266610e-01 ,1.276765e-01 ,1.287041e-01 ,& + & 1.297420e-01 ,1.307883e-01 ,1.318412e-01 ,1.328988e-01 ,1.339593e-01 ,& + & 1.350207e-01 ,1.360813e-01 ,1.371393e-01 ,1.381926e-01 ,1.392396e-01 ,& + & 1.402783e-01 ,1.413069e-01 ,1.423235e-01 ,1.433263e-01 ,1.443134e-01 ,& + & 1.452830e-01 ,1.462332e-01 ,1.471622e-01 ,1.480681e-01 ,1.489490e-01 ,& + & 1.498032e-01 ,1.506286e-01 ,1.514236e-01 ,1.521863e-01 ,1.529147e-01 ,& + & 1.536070e-01 ,1.542614e-01 ,1.548761e-01 ,1.554491e-01 ,1.559787e-01 ,& + & 1.564629e-01 ,1.568999e-01 ,1.572879e-01 ,1.576249e-01 ,1.579093e-01 ,& + & 1.581390e-01 /) + fdlice3(:, 28) = (/ & +! band 28 + & 1.247813e-01 ,1.256496e-01 ,1.265417e-01 ,1.274560e-01 ,1.283905e-01 ,& + & 1.293436e-01 ,1.303135e-01 ,1.312983e-01 ,1.322964e-01 ,1.333060e-01 ,& + & 1.343252e-01 ,1.353523e-01 ,1.363855e-01 ,1.374231e-01 ,1.384632e-01 ,& + & 1.395042e-01 ,1.405441e-01 ,1.415813e-01 ,1.426140e-01 ,1.436404e-01 ,& + & 1.446587e-01 ,1.456672e-01 ,1.466640e-01 ,1.476475e-01 ,1.486157e-01 ,& + & 1.495671e-01 ,1.504997e-01 ,1.514117e-01 ,1.523016e-01 ,1.531673e-01 ,& + & 1.540073e-01 ,1.548197e-01 ,1.556026e-01 ,1.563545e-01 ,1.570734e-01 ,& + & 1.577576e-01 ,1.584054e-01 ,1.590149e-01 ,1.595843e-01 ,1.601120e-01 ,& + & 1.605962e-01 ,1.610349e-01 ,1.614266e-01 ,1.617693e-01 ,1.620614e-01 ,& + & 1.623011e-01 /) + fdlice3(:, 29) = (/ & +! band 29 + & 1.006055e-01 ,9.549582e-02 ,9.063960e-02 ,8.602900e-02 ,8.165612e-02 ,& + & 7.751308e-02 ,7.359199e-02 ,6.988496e-02 ,6.638412e-02 ,6.308156e-02 ,& + & 5.996942e-02 ,5.703979e-02 ,5.428481e-02 ,5.169657e-02 ,4.926719e-02 ,& + & 4.698880e-02 ,4.485349e-02 ,4.285339e-02 ,4.098061e-02 ,3.922727e-02 ,& + & 3.758547e-02 ,3.604733e-02 ,3.460497e-02 ,3.325051e-02 ,3.197604e-02 ,& + & 3.077369e-02 ,2.963558e-02 ,2.855381e-02 ,2.752050e-02 ,2.652776e-02 ,& + & 2.556772e-02 ,2.463247e-02 ,2.371415e-02 ,2.280485e-02 ,2.189670e-02 ,& + & 2.098180e-02 ,2.005228e-02 ,1.910024e-02 ,1.811781e-02 ,1.709709e-02 ,& + & 1.603020e-02 ,1.490925e-02 ,1.372635e-02 ,1.247363e-02 ,1.114319e-02 ,& + & 9.727157e-03 /) + + end subroutine swcldpr + + end module rrtmg_sw_init_f + + module rrtmg_sw_spcvmc_f + +! ------- Modules ------- + + use parrrsw_f, only : nbndsw, ngptsw, mxmol, jpband, mxlay + use rrsw_tbl_f, only : tblint, bpade, od_lo, exp_tbl + use rrsw_vsn_f, only : hvrspc, hnamspc + use rrsw_wvn_f, only : ngc, ngs, ngb + + use rrtmg_sw_taumol_f, only: taumol_sw + + implicit none + + contains + +! --------------------------------------------------------------------------- + subroutine spcvmc_sw & + (cc,tncol, ncol, nlayers, istart, iend, icpr, idelm, iout, & + pavel, tavel, pz, tz, tbound, palbd, palbp, & + pcldfmc, ptaucmc, pasycmc, pomgcmc, ptaormc, & + ptaua, pasya, pomga, prmu0, coldry, adjflux, & + laytrop, layswtch, laylow, jp, jt, jt1, & + co2mult, colch4, colco2, colh2o, colmol, coln2o, colo2, colo3, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + pbbfd, pbbfu, pbbcd, pbbcu, puvfd, puvcd, pnifd, pnicd, & + pbbfddir, pbbcddir, puvfddir, puvcddir, pnifddir, pnicddir, & + zgco,zomco,zrdnd,zref,zrefo,zrefd,zrefdo,ztauo,zdbt,ztdbt, & + ztra,ztrao,ztrad,ztrado,zfd,zfu,ztaug, ztaur, zsflxzen) +! --------------------------------------------------------------------------- +! +! Purpose: Contains spectral loop to compute the shortwave radiative fluxes, +! using the two-stream method of H. Barker and McICA, the Monte-Carlo +! Independent Column Approximation, for the representation of +! sub-grid cloud variability (i.e. cloud overlap). +! +! Interface: *spcvmc_sw* is called from *rrtmg_sw.F90* or rrtmg_sw.1col.F90* +! +! Method: +! Adapted from two-stream model of H. Barker; +! Two-stream model options (selected with kmodts in rrtmg_sw_reftra.F90): +! 1: Eddington, 2: PIFM, Zdunkowski et al., 3: discret ordinates +! +! Modifications: +! +! Original: H. Barker +! Revision: Merge with RRTMG_SW: J.-J.Morcrette, ECMWF, Feb 2003 +! Revision: Add adjustment for Earth/Sun distance : MJIacono, AER, Oct 2003 +! Revision: Bug fix for use of PALBP and PALBD: MJIacono, AER, Nov 2003 +! Revision: Bug fix to apply delta scaling to clear sky: AER, Dec 2004 +! Revision: Code modified so that delta scaling is not done in cloudy profiles +! if routine cldprop is used; delta scaling can be applied by swithcing +! code below if cldprop is not used to get cloud properties. +! AER, Jan 2005 +! Revision: Modified to use McICA: MJIacono, AER, Nov 2005 +! Revision: Uniform formatting for RRTMG: MJIacono, AER, Jul 2006 +! Revision: Use exponential lookup table for transmittance: MJIacono, AER, +! Aug 2007 +! +! ------------------------------------------------------------------ + +! ------- Declarations ------ + +! ------- Input ------- + + integer , intent(in) :: tncol, ncol,cc + integer , intent(in) :: nlayers + integer , intent(in) :: istart + integer , intent(in) :: iend + integer , intent(in) :: icpr + integer , intent(in) :: idelm ! delta-m scaling flag + ! [0 = direct and diffuse fluxes are unscaled] + ! [1 = direct and diffuse fluxes are scaled] + integer , intent(in) :: iout + integer , intent(in) :: laytrop(:) + integer , intent(in) :: layswtch(:) + integer , intent(in) :: laylow(:) + + integer , intent(in) :: indfor(:,:) + integer , intent(in) :: indself(:,:) + integer , intent(in) :: jp(:,:) + integer , intent(in) :: jt(:,:) + integer , intent(in) :: jt1(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: pavel(:,:) ! layer pressure (hPa, mb) + ! Dimensions: (ncol,nlayers) + real , intent(in) :: tavel(:,:) ! layer temperature (K) + ! Dimensions: (ncol,nlayers) + real , intent(in) :: pz(:,0:) ! level (interface) pressure (hPa, mb) + ! Dimensions: (ncol,0:nlayers) + real , intent(in) :: tz(:,0:) ! level temperatures (hPa, mb) + ! Dimensions: (ncol,0:nlayers) + real , intent(in) :: tbound(:) ! surface temperature (K) + ! Dimensions: (ncol) + real , intent(in) :: coldry(:,:) ! dry air column density (mol/cm2) + ! Dimensions: (ncol,nlayers) + real , intent(in) :: colmol(:,:) + ! Dimensions: (ncol,nlayers) + real , intent(in) :: adjflux(:) ! Earth/Sun distance adjustment + ! Dimensions: (jpband) + + real , intent(in) :: palbd(:,:) ! surface albedo (diffuse) + ! Dimensions: (ncol,nbndsw) + real , intent(in) :: palbp(:,:) ! surface albedo (direct) + ! Dimensions: (ncol,nbndsw) + real , intent(in) :: prmu0(:) ! cosine of solar zenith angle + ! Dimensions: (ncol) + + real , intent(in) :: pcldfmc(:,:,:) ! cloud fraction [mcica] + real , intent(in) :: ptaucmc(:,:,:) ! cloud optical depth [mcica] + real , intent(in) :: pasycmc(:,:,:) ! cloud asymmetry parameter [mcica] + real , intent(in) :: pomgcmc(:,:,:) ! cloud single scattering albedo [mcica] + real , intent(in) :: ptaormc(:,:,:) ! cloud optical depth, non-delta scaled [mcica] + ! Dimensions: (ncol,nlayers,ngptsw) + + real , intent(in) :: ptaua(:,:,:) ! aerosol optical depth + real , intent(in) :: pasya(:,:,:) ! aerosol asymmetry parameter + real , intent(in) :: pomga(:,:,:) ! aerosol single scattering albedo + ! Dimensions: (ncol,nlayers,nbndsw) + + real , intent(in) :: colh2o(:,:) + real , intent(in) :: colco2(:,:) + real , intent(in) :: colch4(:,:) + real , intent(in) :: co2mult(:,:) + real , intent(in) :: colo3(:,:) + real , intent(in) :: colo2(:,:) + real , intent(in) :: coln2o(:,:) + ! Dimensions: (ncol,nlayers) + + real , intent(in) :: forfac(:,:) + real , intent(in) :: forfrac(:,:) + real , intent(in) :: selffac(:,:) + real , intent(in) :: selffrac(:,:) + real , intent(in) :: fac00(:,:) + real , intent(in) :: fac01(:,:) + real , intent(in) :: fac10(:,:) + real , intent(in) :: fac11(:,:) + ! Dimensions: (ncol,nlayers) + + real, intent(inout) gpu_device :: zgco(tncol,ngptsw,nlayers+1), zomco(tncol,ngptsw,nlayers+1) + real, intent(inout) gpu_device :: zrdnd(tncol,ngptsw,nlayers+1) + real, intent(inout) gpu_device :: zref(tncol,ngptsw,nlayers+1) , zrefo(tncol,ngptsw,nlayers+1) + real, intent(inout) gpu_device :: zrefd(tncol,ngptsw,nlayers+1) , zrefdo(tncol,ngptsw,nlayers+1) + real, intent(inout) gpu_device :: ztauo(tncol,ngptsw,nlayers) + real, intent(inout) gpu_device :: zdbt(tncol,ngptsw,nlayers+1) ,ztdbt(tncol,ngptsw,nlayers+1) + real, intent(inout) gpu_device :: ztra(tncol,ngptsw,nlayers+1) , ztrao(tncol,ngptsw,nlayers+1) + real, intent(inout) gpu_device :: ztrad(tncol,ngptsw,nlayers+1) , ztrado(tncol,ngptsw,nlayers+1) + real, intent(inout) gpu_device :: zfd(tncol,ngptsw,nlayers+1) , zfu(tncol,ngptsw,nlayers+1) +real gpu_device :: zcd(tncol,ngptsw,nlayers+1) , zcu(tncol,ngptsw,nlayers+1) + real, intent(inout) gpu_device :: ztaur(tncol,nlayers,ngptsw), ztaug(tncol,nlayers,ngptsw) + real, intent(inout) gpu_device :: zsflxzen(tncol,ngptsw) + + +! ------- Output ------- + ! All Dimensions: (ncol,nlayers+1) + real , intent(out) :: pbbcd(:,:) + real , intent(out) :: pbbcu(:,:) + real , intent(out) :: pbbfd(:,:) + real , intent(out) :: pbbfu(:,:) + real , intent(out) :: pbbfddir(:,:) + real , intent(out) :: pbbcddir(:,:) + + real , intent(out) :: puvcd(:,:) + real , intent(out) :: puvfd(:,:) + real , intent(out) :: puvcddir(:,:) + real , intent(out) :: puvfddir(:,:) + + real , intent(out) :: pnicd(:,:) + real , intent(out) :: pnifd(:,:) + real , intent(out) :: pnicddir(:,:) + real , intent(out) :: pnifddir(:,:) + +! ------- Local ------- + + integer :: klev + integer :: ibm, ikl, ikp, ikx + integer :: iw, jb, jg, jl, jk + + integer :: itind + + real :: tblind, ze1 + real :: zclear, zcloud + + real :: zincflx, ze2 + + real :: zdbtmc, zdbtmo, zf, zgw, zreflect + real :: zwf, tauorig, repclc + + real :: zdbt_nodel(tncol,ngptsw,nlayers+1) + real :: zdbtc_nodel(tncol,ngptsw,nlayers+1) + real :: ztdbt_nodel(tncol,ngptsw,nlayers+1) + real :: ztdbtc_nodel(tncol,ngptsw,nlayers+1) + + +! Arrays from rrtmg_sw_vrtqdr routine + + integer :: iplon + +! ------------------------------------------------------------------ + +!$acc update host(pomga, ptaua) + +!print *, "aerosol values" +!print *, pomga(1, :, :) +!print *, ptaua(1, :, :) + +!$acc kernels + pbbcd =0. + pbbcu =0. + pbbfd =0. + pbbfu =0. + pbbcddir =0. + pbbfddir =0. + puvcd =0. + puvfd =0. + puvcddir =0. + puvfddir =0. + pnicd =0. + pnifd =0. + pnicddir =0. + pnifddir =0. + zsflxzen = 0. +! znirr=0. +! znirf=0. +! zparr=0. +! zparf=0. +! zuvrr=0. +! zuvrf=0. + klev = nlayers +!$acc end kernels + +#ifndef _ACCEL +# define ncol CHNK +#endif + + +! Calculate the optical depths for gaseous absorption and Rayleigh scattering + call taumol_sw(ncol,nlayers, & + colh2o , colco2 , colch4 , colo2 , & + colo3 , colmol , & + laytrop , jp , jt , jt1 , & + fac00 , fac01 , fac10 , fac11 , & + selffac , selffrac , indself , forfac , forfrac ,& + indfor , & + zsflxzen , ztaug, ztaur) + + + repclc = 1.e-12 + +#ifdef _ACCEL +# define ILOOP_S_CPU +# define ILOOP_E_CPU +# define ILOOP_S_GPU do iplon = 1, ncol +# define ILOOP_E_GPU enddo +# define WLOOP_S_CPU +# define WLOOP_E_CPU +# define WLOOP_S_GPU do iw = 1, 112 +# define WLOOP_E_GPU enddo +#else +# define ILOOP_S_GPU +# define ILOOP_E_GPU +# define ILOOP_S_CPU do iplon = 1, ncol +# define ILOOP_E_CPU enddo +# define WLOOP_S_GPU +# define WLOOP_E_GPU +# define WLOOP_S_CPU do iw = 1, 112 +# define WLOOP_E_CPU enddo +#endif + + +!$acc kernels + + ILOOP_S_GPU + WLOOP_S_CPU + + WLOOP_S_GPU + ILOOP_S_CPU + +! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14 + + jb = ngb(iw) + ibm = jb-15 + +! Clear-sky +! TOA direct beam + + ztdbtc_nodel(iplon,iw,1)=1.0 !jm + +! Cloudy-sky +! Surface values + ztrao(iplon,iw,klev+1) =0.0 + ztrado(iplon,iw,klev+1) =0.0 + zrefo(iplon,iw,klev+1) =palbp(iplon,ibm) + zrefdo(iplon,iw,klev+1) =palbd(iplon,ibm) + +! Total sky +! TOA direct beam + ztdbt(iplon,iw,1) =1.0 + ztdbt_nodel(iplon,iw,1)=1.0 + + +! Surface values + zdbt(iplon,iw,klev+1) =0.0 + ztra(iplon,iw,klev+1) =0.0 + ztrad(iplon,iw,klev+1) =0.0 + zref(iplon,iw,klev+1) =palbp(iplon,ibm) + zrefd(iplon,iw,klev+1) =palbd(iplon,ibm) + + enddo + enddo + +!$acc end kernels + + +!$acc kernels loop + + ILOOP_S_GPU +!$acc loop private(zf, zwf, ibm, ikl, jb) + WLOOP_S_GPU + !$acc loop seq + do jk=1,klev + + ikl=klev+1-jk + WLOOP_S_CPU + jb = ngb(iw) + ibm = jb-15 + ILOOP_S_CPU + ! Clear-sky optical parameters including aerosols + ztauo(iplon,iw,jk) = ztaur(iplon,ikl,iw) + ztaug(iplon,ikl,iw) + ptaua(iplon,ikl,ibm) + +#ifndef _ACCEL +! Use exponential lookup table for transmittance, or expansion of +! exponential for low tau + zclear = 1.0 - pcldfmc(iplon,ikl,iw) + zcloud = pcldfmc(iplon,ikl,iw) + + ze1 = ztauo(iplon,iw,jk) / prmu0(iplon) ! ztauo corresponds to ztauc at this point in _sw.F version + if (ze1 .le. od_lo) then + zdbtmc = 1. - ze1 + 0.5 * ze1 * ze1 + else + tblind = ze1 / (bpade + ze1) + itind = tblint * tblind + 0.5 + zdbtmc = exp_tbl(itind) + endif + + zdbtc_nodel(iplon,iw,jk) = zdbtmc + ztdbtc_nodel(iplon,iw,jk+1) = zdbtc_nodel(iplon,iw,jk) * ztdbtc_nodel(iplon,iw,jk) + + tauorig = ztauo(iplon,iw,jk) + ptaormc(iplon,ikl,iw) ! ztauo corresponds to ztauc at this point in _sw.F version + ze1 = tauorig / prmu0(iplon) + if (ze1 .le. od_lo) then + zdbtmo = 1. - ze1 + 0.5 * ze1 * ze1 + else + tblind = ze1 / (bpade + ze1) + itind = tblint * tblind + 0.5 + zdbtmo = exp_tbl(itind) + endif + + zdbt_nodel(iplon,iw,jk) = zclear*zdbtmc + zcloud*zdbtmo + ztdbt_nodel(iplon,iw,jk+1) = zdbt_nodel(iplon,iw,jk) * ztdbt_nodel(iplon,iw,jk) + +#endif + + zomco(iplon,iw,jk) = ztaur(iplon,ikl,iw) + ptaua(iplon,ikl,ibm) * pomga(iplon,ikl,ibm) + zgco(iplon,iw,jk) = pasya(iplon,ikl,ibm) * pomga(iplon,ikl,ibm) * ptaua(iplon,ikl,ibm) / zomco(iplon,iw,jk) + zomco(iplon,iw,jk) = zomco(iplon,iw,jk) / ztauo(iplon,iw,jk) + + zf = zgco(iplon, iw, jk) + zf = zf * zf + zwf = zomco(iplon, iw, jk) * zf + + ztauo(iplon, iw, jk) = (1.0 - zwf) * ztauo(iplon, iw, jk) + zomco(iplon, iw, jk) = (zomco(iplon, iw, jk) - zwf) / (1.0 - zwf) + zgco(iplon, iw, jk) = (zgco(iplon, iw, jk) - zf) / (1.0 - zf) + + end do + end do + end do +!$acc end kernels + + +! Clear sky reflectivities + call reftra_sw (ncol, nlayers, & + pcldfmc, zgco, prmu0, ztauo, zomco, & + zrefo, zrefdo, ztrao, ztrado, 1) + + +!$acc kernels loop + ILOOP_S_GPU + +! Combine clear and cloudy reflectivies and optical depths + +!$acc loop + WLOOP_S_GPU + +!$acc loop seq + do jk=1,klev + + WLOOP_S_CPU + ILOOP_S_CPU +! Combine clear and cloudy contributions for total sky + !ikl = klev+1-jk + +! Direct beam transmittance + + ze1 = (ztauo(iplon,iw,jk)) / prmu0(iplon) +#ifdef _ACCEL + zdbtmc = exp(-ze1) +#else + ze1 = ztauo(iplon,iw,jk) / prmu0(iplon) + if (ze1 .le. od_lo) then + zdbtmc = 1. - ze1 + 0.5 * ze1 * ze1 + else + tblind = ze1 / (bpade + ze1) + itind = tblint * tblind + 0.5 + zdbtmc = exp_tbl(itind) + endif +#endif + zdbt(iplon,iw,jk) = zdbtmc + ztdbt(iplon,iw,jk+1) = zdbt(iplon,iw,jk) *ztdbt(iplon,iw,jk) + + end do + end do + end do +!$acc end kernels + +! compute the fluxes from the optical depths and reflectivities + + +! Vertical quadrature for clear-sky fluxes + +!$acc kernels + ILOOP_S_GPU + WLOOP_S_GPU + WLOOP_S_CPU + jb = ngb(iw) + ibm = jb-15 + ILOOP_S_CPU + +! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14 + + + zgco(iplon,iw,klev+1) =palbp(iplon,ibm) + zomco(iplon,iw,klev+1) =palbd(iplon,ibm) + + end do + end do +!$acc end kernels + + + call vrtqdr_sw(ncol, klev, & + zrefo , zrefdo , ztrao , ztrado , & + zdbt , zrdnd , zgco, zomco, ztdbt , & + zcd , zcu , ztra) + +! perform band integration for clear cases +!$acc kernels loop + ILOOP_S_GPU + +!$acc loop + do ikl=1,klev+1 + + !$acc loop seq + do iw = 1, 112 + jb = ngb(iw) + + jk=klev+2-ikl + ibm = jb-15 +!DIR$ SIMD + ILOOP_S_CPU + zincflx = adjflux(jb) * zsflxzen(iplon,iw) * prmu0(iplon) + +! Accumulate spectral fluxes over whole spectrum + + pbbcu(iplon,ikl) = pbbcu(iplon,ikl) + zincflx*zcu(iplon,iw,jk) + pbbcd(iplon,ikl) = pbbcd(iplon,ikl) + zincflx*zcd(iplon,iw,jk) + pbbcddir(iplon,ikl) = pbbcddir(iplon,ikl) + zincflx*ztdbtc_nodel(iplon,iw,jk) + + +! Accumulate direct fluxes for UV/visible bands + if (ibm >= 10 .and. ibm <= 13) then + puvcd(iplon,ikl) = puvcd(iplon,ikl) + zincflx*zcd(iplon,iw,jk) + puvcddir(iplon,ikl) = puvcddir(iplon,ikl) + zincflx*ztdbtc_nodel(iplon,iw,jk) + +! Accumulate direct fluxes for near-IR bands + else if (ibm == 14 .or. ibm <= 9) then + pnicd(iplon,ikl) = pnicd(iplon,ikl) + zincflx*zcd(iplon,iw,jk) + pnicddir(iplon,ikl) = pnicddir(iplon,ikl) + zincflx*ztdbtc_nodel(iplon,iw,jk) + + endif + + enddo + +! End loop on jb, spectral band + enddo + +! End of longitude loop + enddo +!$acc end kernels + + + + if (cc==2) then + +!$acc kernels + ILOOP_S_GPU + WLOOP_S_GPU + do jk=1,klev + + ikl=klev+1-jk + WLOOP_S_CPU + jb = ngb(iw) + ibm = jb-15 +!DIR$ SIMD + ILOOP_S_CPU + ! since the cloudy cases are now computed in a separate partition from the clear cases, we must + ! recompute the needed clear sky prerequisites. + ze1 = ztaur(iplon,ikl,iw) + ptaua(iplon,ikl,ibm) * pomga(iplon, ikl, ibm) + ze2 = pasya(iplon, ikl, ibm) * pomga(iplon, ikl, ibm) * ptaua(iplon, ikl, ibm) / ze1 + ze1 = ze1/ (ztaur(iplon,ikl,iw) + ztaug(iplon,ikl,iw) + ptaua(iplon,ikl,ibm) ) + + ! compute delta scaled coefficients + zf = ze2*ze2 + zwf = ze1*zf + ze1 = (ze1 - zwf) / (1.0 - zwf) + ze2 = (ze2 - zf) / (1.0 - zf) + + ! direct calculation of delta scaled values + zomco(iplon,iw,jk) = (ztauo(iplon,iw,jk) * ze1 + ptaucmc(iplon,ikl,iw) * pomgcmc(iplon,ikl,iw)) + + zgco(iplon, iw, jk) = (ptaucmc(iplon,ikl,iw) * pomgcmc(iplon,ikl,iw) * pasycmc(iplon,ikl,iw) ) + & + (ztauo(iplon, iw, jk) * ze1 * ze2) + + ztauo(iplon,iw,jk) = ztauo(iplon,iw,jk) + ptaucmc(iplon,ikl,iw) + + zgco(iplon,iw,jk) = zgco(iplon, iw, jk) / zomco(iplon, iw, jk) + zomco(iplon,iw,jk) = zomco(iplon,iw,jk) / ztauo(iplon,iw,jk) + + end do + end do + end do +!$acc end kernels + + +! Total sky reflectivities + call reftra_sw (ncol, nlayers, & + pcldfmc, zgco, prmu0, ztauo, zomco, & + zref, zrefd, ztra, ztrad, 0) + + + klev = nlayers + + +!$acc kernels loop + ILOOP_S_GPU + +!$acc loop + WLOOP_S_GPU + +!$acc loop seq + do jk=1,klev + +! Combine clear and cloudy contributions for total sky + ikl = klev+1-jk + WLOOP_S_CPU + ILOOP_S_CPU + zclear = 1.0 - pcldfmc(iplon,ikl,iw) + zcloud = pcldfmc(iplon,ikl,iw) + + zref(iplon,iw,jk) = zclear*zrefo(iplon,iw,jk) + zcloud*zref(iplon,iw,jk) + zrefd(iplon,iw,jk) = zclear*zrefdo(iplon,iw,jk) + zcloud*zrefd(iplon,iw,jk) + ztra(iplon,iw,jk) = zclear*ztrao(iplon,iw,jk) + zcloud*ztra(iplon,iw,jk) + ztrad(iplon,iw,jk) = zclear*ztrado(iplon,iw,jk) + zcloud*ztrad(iplon,iw,jk) + +! Clear + Cloud + + ze1 = ztauo(iplon,iw,jk ) / prmu0(iplon) +#ifdef _ACCEL + zdbtmo = exp(-ze1) +#else + if (ze1 .le. od_lo) then + zdbtmo = 1. - ze1 + 0.5 * ze1 * ze1 + else + tblind = ze1 / (bpade + ze1) + itind = tblint * tblind + 0.5 + zdbtmo = exp_tbl(itind) + endif +#endif + ze1 = (ztauo(iplon,iw,jk) - ptaucmc(iplon,ikl,iw)) / prmu0(iplon) +#ifdef _ACCEL + zdbtmc = exp(-ze1) +#else + if (ze1 .le. od_lo) then + zdbtmc = 1. - ze1 + 0.5 * ze1 * ze1 + else + tblind = ze1 / (bpade + ze1) + itind = tblint * tblind + 0.5 + zdbtmc = exp_tbl(itind) + endif +#endif + + zdbt(iplon,iw,jk) = zclear*zdbtmc + zcloud*zdbtmo + ztdbt(iplon,iw,jk+1) = zdbt(iplon,iw,jk) *ztdbt(iplon,iw,jk) + + enddo + end do + end do +!$acc end kernels + +!$acc kernels + zrdnd = 0.0 + zgco = 0.0 + zomco = 0.0 + zfd = 0.0 + zfu = 0.0 +!$acc end kernels + + +!$acc kernels + ILOOP_S_GPU + WLOOP_S_GPU + +! Top of shortwave spectral band loop, jb = 16 -> 29; ibm = 1 -> 14 + + WLOOP_S_CPU + jb = ngb(iw) + ibm = jb-15 + ILOOP_S_CPU + + zgco(iplon,iw,klev+1) =palbp(iplon,ibm) + zomco(iplon,iw,klev+1) =palbd(iplon,ibm) + + end do + end do +!$acc end kernels + + +! Vertical quadrature for cloudy fluxes + + + call vrtqdr_sw(ncol, klev, & + zref , zrefd , ztra , ztrad , & + zdbt , zrdnd , zgco, zomco , ztdbt , & + zfd , zfu , ztrao) + +! Upwelling and downwelling fluxes at levels +! Two-stream calculations go from top to bottom; +! layer indexing is reversed to go bottom to top for output arrays + + klev = nlayers + repclc = 1.e-12 + +!$acc kernels loop + ILOOP_S_GPU + +!$acc loop + do ikl=1,klev+1 +!$acc loop seq + WLOOP_S_GPU + WLOOP_S_CPU + jb = ngb(iw) + jk=klev+2-ikl + ibm = jb-15 + ILOOP_S_CPU + zincflx = adjflux(jb) * zsflxzen(iplon,iw) * prmu0(iplon) + +! Accumulate spectral fluxes over whole spectrum + pbbfu(iplon,ikl) = pbbfu(iplon,ikl) + zincflx*zfu(iplon,iw,jk) + pbbfd(iplon,ikl) = pbbfd(iplon,ikl) + zincflx*zfd(iplon,iw,jk) + pbbfddir(iplon,ikl) = pbbfddir(iplon,ikl) + zincflx*ztdbt_nodel(iplon,iw,jk) + +! Accumulate direct fluxes for UV/visible bands + if (ibm >= 10 .and. ibm <= 13) then + + puvfd(iplon,ikl) = puvfd(iplon,ikl) + zincflx*zfd(iplon,iw,jk) + puvfddir(iplon,ikl) = puvfddir(iplon,ikl) + zincflx*ztdbt_nodel(iplon,iw,jk) + + +! Accumulate direct fluxes for near-IR bands + else if (ibm == 14 .or. ibm <= 9) then + + pnifd(iplon,ikl) = pnifd(iplon,ikl) + zincflx*zfd(iplon,iw,jk) + pnifddir(iplon,ikl) = pnifddir(iplon,ikl) + zincflx*ztdbt_nodel(iplon,iw,jk) + + + endif + + enddo + +! End loop on jb, spectral band + enddo + +! End of longitude loop + enddo +!$acc end kernels + + + else ! cc = 1 +!$acc kernels + pbbfd = pbbcd + pbbfu = pbbcu + puvfd = puvcd + puvfddir = puvcddir + pnifd = pnicd + pnifddir = pnicddir +!$acc end kernels + end if ! if cc=2, else, endif + + +!$acc kernels + ILOOP_S_GPU + WLOOP_S_GPU + WLOOP_S_CPU + jb = ngb(iw) + ibm = jb - 15 + ILOOP_S_CPU + zincflx = adjflux(jb) * zsflxzen(iplon,iw) * prmu0(iplon) + + end do + end do +!$acc end kernels + +!!$acc end data +# undef ILOOP_S_GPU +# undef ILOOP_E_GPU +# undef ILOOP_S_CPU +# undef ILOOP_E_CPU +# undef WLOOP_S_GPU +# undef WLOOP_E_GPU +# undef WLOOP_S_CPU +# undef WLOOP_E_CPU +#ifndef _ACCEL +# undef ncol +#endif + +! !!!!!!!!!!!!!!!!!!!!! +! END CLEAR !!!!!!!!! +! !!!!!!!!!!!!!!!!!!!!! + + end subroutine spcvmc_sw + +! -------------------------------------------------------------------- + subroutine reftra_sw(ncol, nlayers, pcldfmc, pgg, prmuzl, ptau, pw, & + pref, prefd, ptra, ptrad, ac) +! -------------------------------------------------------------------- + +! Purpose: computes the reflectivity and transmissivity of a clear or +! cloudy layer using a choice of various approximations. +! +! Interface: *rrtmg_sw_reftra* is called by *rrtmg_sw_spcvrt* +! +! Description: +! explicit arguments : +! -------------------- +! inputs +! ------ +! lrtchk = .t. for all layers in clear profile +! lrtchk = .t. for cloudy layers in cloud profile +! = .f. for clear layers in cloud profile +! pgg = assymetry factor +! prmuz = cosine solar zenith angle +! ptau = optical thickness +! pw = single scattering albedo +! +! outputs +! ------- +! pref : collimated beam reflectivity +! prefd : diffuse beam reflectivity +! ptra : collimated beam transmissivity +! ptrad : diffuse beam transmissivity +! +! +! Method: +! ------- +! standard delta-eddington, p.i.f.m., or d.o.m. layer calculations. +! kmodts = 1 eddington (joseph et al., 1976) +! = 2 pifm (zdunkowski et al., 1980) +! = 3 discrete ordinates (liou, 1973) +! +! ac = 1 -- clear +! ac = 0 -- total (clear and cloudy) +! +! Modifications: +! -------------- +! Original: J-JMorcrette, ECMWF, Feb 2003 +! Revised for F90 reformatting: MJIacono, AER, Jul 2006 +! Revised to add exponential lookup table: MJIacono, AER, Aug 2007 +! +! ------------------------------------------------------------------ + +! ------- Declarations ------ + +! ------- Input ------- + + integer , intent(in) :: nlayers + integer , intent(in) :: ncol + + real, intent(in) :: pcldfmc(:,:,:) ! Logical flag for reflectivity and + ! and transmissivity calculation; + ! Dimensions: (ncol,nlayers,ngptsw) + + real , intent(in) gpu_device :: pgg(:,:,:) ! asymmetry parameter + real , intent(in) gpu_device :: ptau(:,:,:) ! optical depth + real , intent(in) gpu_device :: pw(:,:,:) ! single scattering albedo + ! Dimensions: (ncol,nlayers,ngptsw) + + real , intent(in) :: prmuzl(:) ! cosine of solar zenith angle + ! Dimensions: (ncol) + integer, intent(in) :: ac + +! ------- Output ------- + + real , intent(out) gpu_device :: pref(:,:,:) ! direct beam reflectivity + real , intent(out) gpu_device :: prefd(:,:,:) ! diffuse beam reflectivity + real , intent(out) gpu_device :: ptra(:,:,:) ! direct beam transmissivity + real , intent(out) gpu_device :: ptrad(:,:,:) ! diffuse beam transmissivity + ! Dimensions: (ncol,nlayers,ngptsw) + +! ------- Local ------- + + integer :: jk, jl, kmodts + integer :: itind, iplon, iw + + real :: tblind + real :: za, za1, za2 + real :: zbeta, zdend, zdenr, zdent + real :: ze1, ze2, zem1, zem2, zemm, zep1, zep2 + real :: zg, zg3, zgamma1, zgamma2, zgamma3, zgamma4, zgt + real :: zr1, zr2, zr3, zr4, zr5 + real :: zrk, zrk2, zrkg, zrm1, zrp, zrp1, zrpp + real :: zsr3, zt1, zt2, zt3, zt4, zt5, zto1 + real :: zw, zwcrit, zwo, prmuz + + real , parameter :: eps = 1.e-08 + +! ------------------------------------------------------------------ + +! Initialize + + zsr3=sqrt(3. ) + zwcrit=0.9999995 + kmodts=2 + +!$acc kernels loop + do iplon=1,ncol +!$acc loop + do iw=1,112 +!$acc loop private(zgamma1, zgamma2, zgamma3, zgamma4) + do jk=1, nlayers + prmuz = prmuzl(iplon) + if ((.not.(pcldfmc(iplon,nlayers+1-jk,iw)) > 1.e-12) .and. ac==0 ) then + pref(iplon,iw,jk) =0. + ptra(iplon,iw,jk) =1. + prefd(iplon,iw,jk) =0. + ptrad(iplon,iw,jk) =1. + else + zto1=ptau(iplon,iw,jk) + zw =pw(iplon,iw,jk) + zg =pgg(iplon,iw,jk) + +! General two-stream expressions + + zg3= 3. * zg + + zgamma1= (8. - zw * (5. + zg3)) * 0.25 + zgamma2= 3. *(zw * (1. - zg )) * 0.25 + zgamma3= (2. - zg3 * prmuz ) * 0.25 + + zgamma4= 1. - zgamma3 + +! Recompute original s.s.a. to test for conservative solution + + zwo= zw / (1. - (1. - zw) * (zg / (1. - zg))**2) + + if (zwo >= zwcrit) then +! Conservative scattering + + za = zgamma1 * prmuz + za1 = za - zgamma3 + zgt = zgamma1 * zto1 + +! Homogeneous reflectance and transmittance, +! collimated beam + + ze1 = min ( zto1 / prmuz , 500. ) + + + ze2 = exp(-ze1) + pref(iplon,iw,jk) = (zgt - za1 * (1. - ze2)) / (1. + zgt) + ptra(iplon,iw,jk) = 1. - pref(iplon,iw,jk) + +! isotropic incidence + + prefd(iplon,iw,jk) = zgt / (1. + zgt) + ptrad(iplon,iw,jk) = 1. - prefd(iplon,iw,jk) + +! This is applied for consistency between total (delta-scaled) and direct (unscaled) +! calculations at very low optical depths (tau < 1.e-4) when the exponential lookup +! table returns a transmittance of 1.0. + if (ze2 .eq. 1.0 ) then + pref(iplon,iw,jk) = 0.0 + ptra(iplon,iw,jk) = 1.0 + prefd(iplon,iw,jk) = 0.0 + ptrad(iplon,iw,jk) = 1.0 + endif + + else +! Non-conservative scattering + + za1 = zgamma1 * zgamma4 + zgamma2 * zgamma3 + za2 = zgamma1 * zgamma3 + zgamma2 * zgamma4 + zrk = sqrt ( zgamma1**2 - zgamma2**2) + zrp = zrk * prmuz + zrp1 = 1. + zrp + zrm1 = 1. - zrp + zrk2 = 2. * zrk + zrpp = 1. - zrp*zrp + zrkg = zrk + zgamma1 + zr1 = zrm1 * (za2 + zrk * zgamma3) + zr2 = zrp1 * (za2 - zrk * zgamma3) + zr3 = zrk2 * (zgamma3 - za2 * prmuz ) + zr4 = zrpp * zrkg + zr5 = zrpp * (zrk - zgamma1) + zt1 = zrp1 * (za1 + zrk * zgamma4) + zt2 = zrm1 * (za1 - zrk * zgamma4) + zt3 = zrk2 * (zgamma4 + za1 * prmuz ) + zt4 = zr4 + zt5 = zr5 + +! mji - reformulated code to avoid potential floating point exceptions +! zbeta = - zr5 / zr4 + zbeta = (zgamma1 - zrk) / zrkg +!! + +! Homogeneous reflectance and transmittance + + ze1 = min ( zrk * zto1, 5. ) + ze2 = min ( zto1 / prmuz , 5. ) + +! Use exponential lookup table for transmittance, or expansion of +! exponential for low tau + if (ze1 .le. od_lo) then + zem1 = 1. - ze1 + 0.5 * ze1 * ze1 + zep1 = 1. / zem1 + else + zem1 = exp(-ze1) + zep1 = 1. / zem1 + endif + if (ze2 .le. od_lo) then + zem2 = 1. - ze2 + 0.5 * ze2 * ze2 + zep2 = 1. / zem2 + else + zem2 = exp(-ze2) + zep2 = 1. / zem2 + endif + + zdenr = zr4*zep1 + zr5*zem1 + zdent = zt4*zep1 + zt5*zem1 + if (zdenr .ge. -eps .and. zdenr .le. eps) then + pref(iplon,iw,jk) = eps + ptra(iplon,iw,jk) = zem2 + else + pref(iplon,iw,jk) = zw * (zr1*zep1 - zr2*zem1 - zr3*zem2) / zdenr + ptra(iplon,iw,jk) = zem2 - zem2 * zw * (zt1*zep1 - zt2*zem1 - zt3*zep2) / zdent + endif + +! diffuse beam + + zemm = zem1*zem1 + zdend = 1. / ( (1. - zbeta*zemm ) * zrkg) + prefd(iplon,iw,jk) = zgamma2 * (1. - zemm) * zdend + ptrad(iplon,iw,jk) = zrk2*zem1*zdend + + endif + + endif + + end do + end do + end do +!$acc end kernels + + end subroutine reftra_sw + +! -------------------------------------------------------------------------- + subroutine vrtqdr_sw(ncol, klev, & + pref, prefd, ptra, ptrad, & + pdbt, prdnd, prup, prupd, ptdbt, & + pfd, pfu, ztdn) +! -------------------------------------------------------------------------- + +! Purpose: This routine performs the vertical quadrature integration +! +! Interface: *vrtqdr_sw* is called from *spcvrt_sw* and *spcvmc_sw* +! +! Modifications. +! +! Original: H. Barker +! Revision: Integrated with rrtmg_sw, J.-J. Morcrette, ECMWF, Oct 2002 +! Revision: Reformatted for consistency with rrtmg_lw: MJIacono, AER, Jul 2006 +! +!----------------------------------------------------------------------- + +! ------- Declarations ------- + +! Input + + integer , intent (in) :: klev ! number of model layers + integer , intent (in) :: ncol + + +#ifdef _ACCEL + real , intent(in) gpu_device :: pref(:,:,:) ! direct beam reflectivity + real , intent(in) gpu_device :: prefd(:,:,:) ! diffuse beam reflectivity + real , intent(in) gpu_device :: ptra(:,:,:) ! direct beam transmissivity + real , intent(in) gpu_device :: ptrad(:,:,:) ! diffuse beam transmissivity + real , intent(in) gpu_device :: pdbt(:,:,:) + real , intent(in) gpu_device :: ptdbt(:,:,:) + real , intent(out) gpu_device :: prdnd(:,:,:) + real , intent(inout) gpu_device :: prup(:,:,:) + real , intent(inout) gpu_device :: prupd(:,:,:) + real, intent(inout) gpu_device :: ztdn(:,:,:) + ! Dimensions: (ncol,nlayers,ngptsw) + +! Output + real , intent(out) gpu_device :: pfd(:,:,:) ! downwelling flux (W/m2) + ! unadjusted for earth/sun distance or zenith angle + real , intent(inout) gpu_device :: pfu(:,:,:) ! upwelling flux (W/m2) + ! unadjusted for earth/sun distance or zenith angle + ! Dimensions: (ncol,nlayers,ngptsw) +#else + real , intent(in) :: pref(CHNK,112,klev+1) ! direct beam reflectivity + real , intent(in) :: prefd(CHNK,112,klev+1) ! diffuse beam reflectivity + real , intent(in) :: ptra(CHNK,112,klev+1) ! direct beam transmissivity + real , intent(in) :: ptrad(CHNK,112,klev+1) ! diffuse beam transmissivity + real , intent(in) :: pdbt(CHNK,112,klev+1) + real , intent(in) :: ptdbt(CHNK,112,klev+1) + real , intent(out) :: prdnd(CHNK,112,klev+1) + real , intent(inout) :: prup(CHNK,112,klev+1) + real , intent(inout) :: prupd(CHNK,112,klev+1) + real, intent(inout) :: ztdn(CHNK,112,klev+1) + ! Dimensions: (ncol,nlayers,ngptsw) + +! Output + real , intent(out) gpu_device :: pfd(CHNK,112,klev+1) ! downwelling flux (W/m2) + ! unadjusted for earth/sun distance or zenith angle + real , intent(inout) gpu_device :: pfu(CHNK,112,klev+1) ! upwelling flux (W/m2) + ! unadjusted for earth/sun distance or zenith angle + ! Dimensions: (ncol,nlayers,ngptsw) +#endif + +! Local + + integer :: ikp, ikx, jk, iplon, iw + +#ifdef _ACCEL + + real :: zreflect, zreflectj + +# define ILOOP_S_CPU +# define ILOOP_E_CPU +# define ILOOP_S_GPU do iplon = 1, ncol +# define ILOOP_E_GPU enddo +# define WLOOP_S_CPU +# define WLOOP_E_CPU +# define WLOOP_S_GPU do iw = 1, 112 +# define WLOOP_E_GPU enddo + +#else + +! real, dimension(CHNK) :: zreflect, zreflectj + real :: zreflect, zreflectj + +# define ncol CHNK + +# define ILOOP_S_GPU +# define ILOOP_E_GPU +# define ILOOP_S_CPU do iplon = 1, ncol +# define ILOOP_E_CPU enddo +# define WLOOP_S_GPU +# define WLOOP_E_GPU +# define WLOOP_S_CPU do iw = 1, 112 +# define WLOOP_E_CPU enddo + +!# define zreflect ZREFLECT(iplon) +!# define zreflectj ZREFLECTJ(iplon) + +#endif + +! Definitions +! +! pref(jk) direct reflectance +! prefd(jk) diffuse reflectance +! ptra(jk) direct transmittance +! ptrad(jk) diffuse transmittance +! +! pdbt(jk) layer mean direct beam transmittance +! ptdbt(jk) total direct beam transmittance at levels +! +!----------------------------------------------------------------------------- + +! Link lowest layer with surface +! this kernel has a lot of dependencies + +! CHNK hardcode klev+1 +! pref 8 112 52 +! prefd 8 112 52 +! ptra 8 112 52 +! ptrad 8 112 52 +! pdbt 8 112 52 +! ptdbt 8 112 52 +! prdnd 8 112 52 +! prup 8 112 52 +! prupd 8 112 52 +! ztdn 8 112 52 +! pfd 8 112 52 +! pfu 8 112 52 +!DIR$ ASSUME_ALIGNED pref:64,prefd:64,ptra:64,ptrad:64 +!DIR$ ASSUME_ALIGNED pdbt:64,ptdbt:64,prdnd:64,prup:64,prupd:64,ztdn:64,pfd:64,pfu:64 + +#if 0 +write(0,*)'pref ',shape( pref) ! direct beam reflectivity +write(0,*)'prefd ',shape( prefd) ! diffuse beam reflectivity +write(0,*)'ptra ',shape( ptra) ! direct beam transmissivity +write(0,*)'ptrad ',shape( ptrad) ! diffuse beam transmissivity +write(0,*)'pdbt ',shape( pdbt) +write(0,*)'ptdbt ',shape( ptdbt) +write(0,*)'prdnd ',shape( prdnd) +write(0,*)'prup ',shape( prup) +write(0,*)'prupd ',shape( prupd) +write(0,*)'ztdn ',shape( ztdn) +write(0,*)'pfd ',shape( pfd) ! downwelling flux (W/m2) +write(0,*)'pfu ',shape( pfu) ! upwelling flux (W/m2) +#endif + + + +!$acc kernels loop + ILOOP_S_GPU + +!$acc loop private(zreflect) + WLOOP_S_GPU + WLOOP_S_CPU +!DIR$ VECTOR ALIGNED + ILOOP_S_CPU + zreflect = 1. / (1. - prefd(iplon,iw,klev+1) * prefd(iplon,iw,klev) ) + prup(iplon,iw,klev) = pref(iplon,iw,klev) + (ptrad(iplon,iw,klev) * & + ((ptra(iplon,iw,klev) - pdbt(iplon,iw,klev) ) * prefd(iplon,iw,klev+1) + & + pdbt(iplon,iw,klev) * pref(iplon,iw,klev+1) )) * zreflect + prupd(iplon,iw,klev) = prefd(iplon,iw,klev) + ptrad(iplon,iw,klev) * ptrad(iplon,iw,klev) * & + prefd(iplon,iw,klev+1) * zreflect + ILOOP_E_CPU + WLOOP_E_GPU + WLOOP_E_CPU + ILOOP_E_GPU +!$acc end kernels + +! Pass from bottom to top +!$acc kernels loop + ILOOP_S_GPU + +!$acc loop + WLOOP_S_GPU + +!$acc loop seq + do jk = 1,klev-1 + ikp = klev+1-jk + ikx = ikp-1 + WLOOP_S_CPU +!DIR$ VECTOR ALIGNED + ILOOP_S_CPU + zreflectj = 1. / (1. -prupd(iplon,iw,ikp) * prefd(iplon,iw,ikx) ) + prup(iplon,iw,ikx) = pref(iplon,iw,ikx) + (ptrad(iplon,iw,ikx) * & + ((ptra(iplon,iw,ikx) - pdbt(iplon,iw,ikx) ) * prupd(iplon,iw,ikp) + & + pdbt(iplon,iw,ikx) * prup(iplon,iw,ikp) )) * zreflectj + prupd(iplon,iw,ikx) = prefd(iplon,iw,ikx) + ptrad(iplon,iw,ikx) * ptrad(iplon,iw,ikx) * & + prupd(iplon,iw,ikp) * zreflectj + ILOOP_E_CPU + WLOOP_E_CPU + end do + WLOOP_E_GPU + ILOOP_E_GPU +!$acc end kernels + +!$acc kernels loop + ILOOP_S_GPU +!$acc loop + WLOOP_S_GPU + WLOOP_S_CPU + +! Upper boundary conditions +!DIR$ VECTOR ALIGNED + ILOOP_S_CPU + ztdn(iplon, iw, 1) = 1. + prdnd(iplon,iw,1) = 0. + ztdn(iplon, iw, 2) = ptra(iplon,iw,1) + prdnd(iplon,iw,2) = prefd(iplon,iw,1) + ILOOP_E_CPU + WLOOP_E_GPU + WLOOP_E_CPU + ILOOP_E_GPU +!$acc end kernels + +!$acc kernels loop + ILOOP_S_GPU +!$acc loop + WLOOP_S_GPU + +! Pass from top to bottom +!$acc loop seq + do jk = 2,klev + ikp = jk+1 + WLOOP_S_CPU +!DIR$ VECTOR ALIGNED + ILOOP_S_CPU + zreflect = 1. / (1. - prefd(iplon,iw,jk) * prdnd(iplon,iw,jk) ) + ztdn(iplon, iw, ikp) = ptdbt(iplon,iw,jk) * ptra(iplon,iw,jk) + & + (ptrad(iplon,iw,jk) * ((ztdn(iplon, iw, jk) - ptdbt(iplon,iw,jk) ) + & + ptdbt(iplon,iw,jk) * pref(iplon,iw,jk) * prdnd(iplon,iw,jk) )) * zreflect + prdnd(iplon,iw,ikp) = prefd(iplon,iw,jk) + ptrad(iplon,iw,jk) * ptrad(iplon,iw,jk) * & + prdnd(iplon,iw,jk) * zreflect + ILOOP_E_CPU + WLOOP_E_CPU + end do + WLOOP_E_GPU + ILOOP_E_GPU +!$acc end kernels + +! Up and down-welling fluxes at levels + +!$acc kernels loop + ILOOP_S_GPU +!$acc loop + WLOOP_S_GPU +!$acc loop + do jk = 1,klev+1 + WLOOP_S_CPU +!DIR$ VECTOR ALIGNED + ILOOP_S_CPU + zreflect = 1. / (1. - prdnd(iplon,iw,jk) * prupd(iplon,iw,jk) ) + pfu(iplon,iw,jk) = (ptdbt(iplon,iw,jk) * prup(iplon,iw,jk) + & + (ztdn(iplon, iw, jk) - ptdbt(iplon,iw,jk) ) * prupd(iplon,iw,jk) ) * zreflect + pfd(iplon,iw,jk) = ptdbt(iplon,iw,jk) + (ztdn(iplon, iw, jk) - ptdbt(iplon,iw,jk) + & + ptdbt(iplon,iw,jk) * prup(iplon,iw,jk) * prdnd(iplon,iw,jk) ) * zreflect + ILOOP_E_CPU + WLOOP_E_CPU + end do + WLOOP_E_GPU + ILOOP_E_GPU +!$acc end kernels + + end subroutine vrtqdr_sw + + end module rrtmg_sw_spcvmc_f +# undef ILOOP_S_GPU +# undef ILOOP_E_GPU +# undef ILOOP_S_CPU +# undef ILOOP_E_CPU +# undef WLOOP_S_GPU +# undef WLOOP_E_GPU +# undef WLOOP_S_CPU +# undef WLOOP_E_CPU +# undef zreflect +# undef zreflectj +# undef ncol + + module rrtmg_sw_rad_f +! +! **************************************************************************** +! * * +! * RRTMG_SW * +! * * +! * * +! * * +! * a rapid radiative transfer model * +! * for the solar spectral region * +! * for application to general circulation models * +! * * +! * * +! * Atmospheric and Environmental Research, Inc. * +! * 131 Hartwell Avenue * +! * Lexington, MA 02421 * +! * * +! * * +! * Eli J. Mlawer * +! * Jennifer S. Delamere * +! * Michael J. Iacono * +! * Shepard A. Clough * +! * David M. Berthiaume * +! * * +! * * +! * * +! * * +! * * +! * email: miacono@aer.com * +! * email: emlawer@aer.com * +! * email: jdelamer@aer.com * +! * * +! * The authors wish to acknowledge the contributions of the * +! * following people: Steven J. Taubman, Patrick D. Brown, * +! * Ronald E. Farren, Luke Chen, Robert Bergstrom. * +! * * +! **************************************************************************** + +! --------- Modules --------- + + use rrsw_vsn_f + use mcica_subcol_gen_sw_f, only: mcica_sw + use rrtmg_sw_cldprmc_f, only: cldprmc_sw + use rrtmg_sw_setcoef_f, only: setcoef_sw + use rrtmg_sw_spcvmc_f, only: spcvmc_sw + + implicit none + + public :: rrtmg_sw, earth_sun + + contains + + subroutine rrtmg_sw & + (rpart ,ncol ,nlay ,icld ,iaer , & + play ,plev ,tlay ,tlev ,tsfc , & + h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , & + asdir ,asdif ,aldir ,aldif , & + coszen ,adjes ,dyofyr ,scon , & + inflgsw ,iceflgsw,liqflgsw,cld , & + tauc ,ssac ,asmc ,fsfc , & + ciwp ,clwp ,cswp ,rei ,rel ,res , & + tauaer ,ssaaer ,asmaer ,ecaer , & + swuflx ,swdflx ,swhr ,swuflxc ,swdflxc,swhrc , & +! --------- Add the following four compenants for ssib shortwave down radiation ---! +! ------------------- by Zhenxin 2011-06-20 --------------------------------! + sibvisdir, sibvisdif, sibnirdir, sibnirdif, & +! ---------------------- End, Zhenxin 2011-06-20 --------------------------------! + swdkdir, swdkdif & ! jararias, 2013/08/10 + ) + + + use parrrsw_f, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol, & + jpband, jpb1, jpb2, rrsw_scon + use rrsw_aer_f, only : rsrtaua, rsrpiza, rsrasya + use rrsw_con_f, only : heatfac, oneminus, pi, grav, avogad + use rrsw_wvn_f, only : wavenum1, wavenum2 + use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, & + extice2, ssaice2, asyice2, & + extice3, ssaice3, asyice3, fdlice3, & + abari, bbari, cbari, dbari, ebari, fbari + use rrsw_wvn_f, only : wavenum2, ngb + use rrsw_ref_f, only : preflog, tref + +#ifdef _ACCEL + use cudafor +#endif + + +! ------- Declarations + + integer , intent(in) :: rpart ! The number of columns in each partition + integer , intent(in) :: ncol ! Number of horizontal columns + integer , intent(in) :: nlay ! Number of model layers + integer , intent(inout) :: icld ! Cloud overlap method + ! 0: Clear only + ! 1: Random + ! 2: Maximum/random + ! 3: Maximum + integer , intent(in) :: iaer ! Aerosol option flag + real , intent(in) :: play(:,:) ! Layer pressures (hPa, mb) + ! Dimensions: (ncol,nlay) + real , intent(in) :: plev(:,:) ! Interface pressures (hPa, mb) + ! Dimensions: (ncol,nlay+1) + real , intent(in) :: tlay(:,:) ! Layer temperatures (K) + ! Dimensions: (ncol,nlay) + real , intent(in) :: tlev(:,:) ! Interface temperatures (K) + ! Dimensions: (ncol,nlay+1) + real , intent(in) :: tsfc(:) ! Surface temperature (K) + ! Dimensions: (ncol) + real , intent(in) :: h2ovmr(:,:) ! H2O volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: o3vmr(:,:) ! O3 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: co2vmr(:,:) ! CO2 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: ch4vmr(:,:) ! Methane volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: n2ovmr(:,:) ! Nitrous oxide volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: o2vmr(:,:) ! Oxygen volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: asdir(:) ! UV/vis surface albedo direct rad + ! Dimensions: (ncol) + real , intent(in) :: aldir(:) ! Near-IR surface albedo direct rad + ! Dimensions: (ncol) + real , intent(in) :: asdif(:) ! UV/vis surface albedo: diffuse rad + ! Dimensions: (ncol) + real , intent(in) :: aldif(:) ! Near-IR surface albedo: diffuse rad + ! Dimensions: (ncol) + + integer , intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun + ! distance if adjflx not provided) + real , intent(in) :: adjes ! Flux adjustment for Earth/Sun distance + real , intent(in) :: coszen(:) ! Cosine of solar zenith angle + ! Dimensions: (ncol) + real , intent(in) :: scon ! Solar constant (W/m2) + + integer , intent(in) :: inflgsw ! Flag for cloud optical properties + integer , intent(in) :: iceflgsw ! Flag for ice particle specification + integer , intent(in) :: liqflgsw ! Flag for liquid droplet specification + + real , intent(in) :: cld(:,:) ! Cloud fraction + ! Dimensions: (ncol,nlay) + real , intent(in) :: tauc(:,:,:) ! In-cloud optical depth + ! Dimensions: (ncol,nlay,nbndlw) + real , intent(in) :: ssac(:,:,:) ! In-cloud single scattering albedo + ! Dimensions: (ncol,nlay,nbndlw) + real , intent(in) :: asmc(:,:,:) ! In-cloud asymmetry parameter + ! Dimensions: (ncol,nlay,nbndlw) + real , intent(in) :: fsfc(:,:,:) ! In-cloud forward scattering fraction + ! Dimensions: (ncol,nlay,nbndlw) + real , intent(in) :: ciwp(:,:) ! In-cloud ice water path (g/m2) + ! Dimensions: (ncol, nlay) + real , intent(in) :: clwp(:,:) ! In-cloud liquid water path (g/m2) + ! Dimensions: (ncol, nlay) + real , intent(in) :: cswp(:,:) ! In-cloud snow water path (g/m2) + ! Dimensions: (ncol, nlay) + real , intent(in) :: rei(:,:) ! Cloud ice effective radius (microns) + ! Dimensions: (ncol, nlay) + ! specific definition of rei depends on setting of iceflglw: + ! iceflglw = 0: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec must be >= 10.0 microns + ! iceflglw = 1: ice effective radius, r_ec, (Ebert and Curry, 1992), + ! r_ec range is limited to 13.0 to 130.0 microns + ! iceflglw = 2: ice effective radius, r_k, (Key, Streamer Ref. Manual, 1996) + ! r_k range is limited to 5.0 to 131.0 microns + ! iceflglw = 3: generalized effective size, dge, (Fu, 1996), + ! dge range is limited to 5.0 to 140.0 microns + ! [dge = 1.0315 * r_ec] + real , intent(in) :: rel(:,:) ! Cloud water drop effective radius (microns) + ! Dimensions: (ncol,nlay) + real , intent(in) :: res(:,:) ! Cloud snow effective radius (microns) + ! Dimensions: (ncol,nlay) + real , intent(in) :: tauaer(:,:,:) ! Aerosol optical depth (iaer=10 only) + ! Dimensions: (ncol,nlay,nbndsw) + ! (non-delta scaled) + real , intent(in) :: ssaaer(:,:,:) ! Aerosol single scattering albedo (iaer=10 only) + ! Dimensions: (ncol,nlay,nbndsw) + ! (non-delta scaled) + real , intent(in) :: asmaer(:,:,:) ! Aerosol asymmetry parameter (iaer=10 only) + ! Dimensions: (ncol,nlay,nbndsw) + ! (non-delta scaled) + real , intent(in) :: ecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only) + ! Dimensions: (ncol,nlay,naerec) + ! (non-delta scaled) + +! ----- Output ----- + + real , intent(out) :: swuflx(:,:) ! Total sky shortwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: swdflx(:,:) ! Total sky shortwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: swhr(:,:) ! Total sky shortwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + real , intent(out) :: swuflxc(:,:) ! Clear sky shortwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: swdflxc(:,:) ! Clear sky shortwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: swhrc(:,:) ! Clear sky shortwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + + real, intent(out) :: sibvisdir(:,:) ! visible direct downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real, intent(out) :: sibvisdif(:,:) ! visible diffusion downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real, intent(out) :: sibnirdir(:,:) ! Near IR direct downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real, intent(out) :: sibnirdif(:,:) ! Near IR diffusion downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real, intent(out) :: swdkdir(:,:) ! Total shortwave downward direct flux (W/m2) + ! Dimensions: (ncol,nlay+1) jararias, 2013/08/10 + real, intent(out) :: swdkdif(:,:) ! Total shortwave downward diffuse flux (W/m2) + ! Dimensions: (ncol,nlay+1) jararias, 2013/08/10 + + integer :: npart, pncol, ns + +! mji - time + real :: t1, t2 + +#ifdef _ACCEL + type(cudadeviceprop) :: prop + real :: gmem + integer :: err + integer :: munits +#endif + + if (rpart > 0) then + pncol = rpart + else + +#ifdef _ACCEL + + err = cudaGetDeviceProperties( prop, 0) + gmem = prop%totalGlobalMem / (1024.0 * 1024.0) +! print *, "Total GPU global memory is ", gmem , "MB" + + ! dmb 2013 + ! Here + ! The optimal partition size is determined by the following conditions + ! 1. Powers of 2 are the most efficient. + ! 2. The second to largest power of 2 that can fit on + ! the GPU is most efficient. + ! 3. Having a small remainder for the final partiion is inefficient. + + if (gmem > 5000) then + pncol = 4096 + else if (gmem > 3000) then + pncol = 2048 + else if (gmem > 1000) then + pncol = 1024 + else + pncol = 512 + end if + + ! the smallest allowed partition size is 32 + do err = 1, 6 + if (pncol > ncol .and. pncol>32) then + pncol = pncol/2 + end if + end do + + ! if we have a very large number of columns, account for the + ! static ncol memory requirement + if (ncol>29000 .and. pncol>4000) then + pncol = pncol/2 + end if + +#else + pncol = 2 + pncol = 4 +!jm pncol = CHNK redundant, since this is passed in + +#endif + + end if + + print *, "RRTMG_SWF: Number of columns is ", ncol + print *, "RRTMG_SWF: Number of columns per partition is ", pncol + ns = ceiling( real(ncol) / real(pncol) ) + print *, "RRTMG_SWF: Number of partitions is ", ns + + call cpu_time(t1) + + call rrtmg_sw_sub & + (pncol ,ncol ,nlay ,icld ,iaer , & + play ,plev ,tlay ,tlev ,tsfc , & + h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , & + asdir ,asdif ,aldir ,aldif , & + coszen ,adjes ,dyofyr ,scon , & + inflgsw ,iceflgsw,liqflgsw,cld , & + tauc ,ssac ,asmc ,fsfc , & + ciwp ,clwp ,cswp ,rei ,rel ,res , & + tauaer ,ssaaer ,asmaer ,ecaer , & + swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, & + sibvisdir, sibvisdif, sibnirdir, sibnirdif, & + swdkdir , swdkdif & ! jararias, 2013/08/10 + ) + call cpu_time(t2) + print *, "------------------------------------------------" + print *, "TOTAL RRTMG_SWF RUN TIME IS ", t2-t1 + print *, "------------------------------------------------" + + + end subroutine rrtmg_sw + + + subroutine rrtmg_sw_sub & + (ncol ,gncol ,nlay ,icld ,iaer , & + gplay ,gplev ,gtlay ,gtlev ,gtsfc , & + gh2ovmr ,go3vmr ,gco2vmr ,gch4vmr ,gn2ovmr ,go2vmr , & + gasdir ,gasdif ,galdir ,galdif , & + gcoszen ,adjes ,dyofyr ,scon , & + inflgsw ,iceflgsw,liqflgsw,gcld , & + gtauc ,gssac ,gasmc ,gfsfc , & + gciwp ,gclwp ,gcswp ,grei ,grel ,gres , & + gtauaer ,gssaaer ,gasmaer ,gecaer , & + swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, & + sibvisdir, sibvisdif, sibnirdir, sibnirdif, & + swdkdir , swdkdif & ! jararias, 2013/08/10 + ) + use parrrsw_f, only : nbndsw, ngptsw, naerec, nstr, nmol, mxmol, & + jpband, jpb1, jpb2, rrsw_scon + use rrsw_aer_f, only : rsrtaua, rsrpiza, rsrasya + use rrsw_con_f, only : heatfac, oneminus, pi, grav, avogad + use rrsw_wvn_f, only : wavenum1, wavenum2 + use rrsw_cld_f, only : extliq1, ssaliq1, asyliq1, & + extice2, ssaice2, asyice2, & + extice3, ssaice3, asyice3, fdlice3, & + abari, bbari, cbari, dbari, ebari, fbari + use rrsw_wvn_f, only : wavenum2, ngb, icxa, nspa, nspb + use rrsw_ref_f, only : preflog, tref + use rrsw_kg16_f, kao16 => kao, kbo16 => kbo, selfrefo16 => selfrefo, forrefo16 => forrefo, sfluxrefo16 => sfluxrefo + use rrsw_kg16_f, ka16 => ka, kb16 => kb, selfref16 => selfref, forref16 => forref, sfluxref16 => sfluxref + + use rrsw_kg17_f, kao17 => kao, kbo17 => kbo, selfrefo17 => selfrefo, forrefo17 => forrefo, sfluxrefo17 => sfluxrefo + use rrsw_kg17_f, ka17 => ka, kb17 => kb, selfref17 => selfref, forref17 => forref, sfluxref17 => sfluxref + + use rrsw_kg18_f, kao18 => kao, kbo18 => kbo, selfrefo18 => selfrefo, forrefo18 => forrefo, sfluxrefo18 => sfluxrefo + use rrsw_kg18_f, ka18 => ka, kb18 => kb, selfref18 => selfref, forref18 => forref, sfluxref18 => sfluxref + + use rrsw_kg19_f, kao19 => kao, kbo19 => kbo, selfrefo19 => selfrefo, forrefo19 => forrefo, sfluxrefo19 => sfluxrefo + use rrsw_kg19_f, ka19 => ka, kb19 => kb, selfref19 => selfref, forref19 => forref, sfluxref19 => sfluxref + + use rrsw_kg20_f, kao20 => kao, kbo20 => kbo, selfrefo20 => selfrefo, forrefo20 => forrefo, & + sfluxrefo20 => sfluxrefo, absch4o20 => absch4o + use rrsw_kg20_f, ka20 => ka, kb20 => kb, selfref20 => selfref, forref20 => forref, & + sfluxref20 => sfluxref, absch420 => absch4 + + use rrsw_kg21_f, kao21 => kao, kbo21 => kbo, selfrefo21 => selfrefo, forrefo21 => forrefo, sfluxrefo21 => sfluxrefo + use rrsw_kg21_f, ka21 => ka, kb21 => kb, selfref21 => selfref, forref21 => forref, sfluxref21 => sfluxref + + use rrsw_kg22_f, kao22 => kao, kbo22 => kbo, selfrefo22 => selfrefo, forrefo22 => forrefo, sfluxrefo22 => sfluxrefo + use rrsw_kg22_f, ka22 => ka, kb22 => kb, selfref22 => selfref, forref22 => forref, sfluxref22 => sfluxref + + use rrsw_kg23_f, kao23 => kao, selfrefo23 => selfrefo, forrefo23 => forrefo, sfluxrefo23 => sfluxrefo, raylo23 => raylo + use rrsw_kg23_f, ka23 => ka, selfref23 => selfref, forref23 => forref, sfluxref23 => sfluxref, rayl23 => rayl + + use rrsw_kg24_f, kao24 => kao, kbo24 => kbo, selfrefo24 => selfrefo, forrefo24 => forrefo, sfluxrefo24 => sfluxrefo + use rrsw_kg24_f, abso3ao24 => abso3ao, abso3bo24 => abso3bo, raylao24 => raylao, raylbo24 => raylbo + use rrsw_kg24_f, ka24 => ka, kb24 => kb, selfref24 => selfref, forref24 => forref, sfluxref24 => sfluxref + use rrsw_kg24_f, abso3a24 => abso3a, abso3b24 => abso3b, rayla24 => rayla, raylb24 => raylb + + use rrsw_kg25_f, kao25 => kao, sfluxrefo25=>sfluxrefo + use rrsw_kg25_f, abso3ao25 => abso3ao, abso3bo25 => abso3bo, raylo25 => raylo + use rrsw_kg25_f, ka25 => ka, sfluxref25=>sfluxref + use rrsw_kg25_f, abso3a25 => abso3a, abso3b25 => abso3b, rayl25 => rayl + + use rrsw_kg26_f, sfluxrefo26 => sfluxrefo + use rrsw_kg26_f, sfluxref26 => sfluxref + + use rrsw_kg27_f, kao27 => kao, kbo27 => kbo, sfluxrefo27 => sfluxrefo, rayl27=>rayl + use rrsw_kg27_f, ka27 => ka, kb27 => kb, sfluxref27 => sfluxref, raylo27=>raylo + + use rrsw_kg28_f, kao28 => kao, kbo28 => kbo, sfluxrefo28 => sfluxrefo + use rrsw_kg28_f, ka28 => ka, kb28 => kb, sfluxref28 => sfluxref + + use rrsw_kg29_f, kao29 => kao, kbo29 => kbo, selfrefo29 => selfrefo, forrefo29 => forrefo, sfluxrefo29 => sfluxrefo + use rrsw_kg29_f, absh2oo29 => absh2oo, absco2o29 => absco2o + use rrsw_kg29_f, ka29 => ka, kb29 => kb, selfref29 => selfref, forref29 => forref, sfluxref29 => sfluxref + use rrsw_kg29_f, absh2o29 => absh2o, absco229 => absco2 + +! ------- Declarations + + integer , intent(in) :: ncol + integer , intent(in) :: gncol ! Number of horizontal columns + integer , intent(in) :: nlay ! Number of model layers + integer , intent(inout) :: icld ! Cloud overlap method + ! 0: Clear only + ! 1: Random + ! 2: Maximum/random + ! 3: Maximum + integer , intent(in) :: iaer + integer , intent(in) :: dyofyr ! Day of the year (used to get Earth/Sun + ! distance if adjflx not provided) + real , intent(in) :: adjes ! Flux adjustment for Earth/Sun distance + real , intent(in) :: scon ! Solar constant (W/m2) + + integer , intent(in) :: inflgsw ! Flag for cloud optical properties + integer , intent(in) :: iceflgsw ! Flag for ice particle specification + integer , intent(in) :: liqflgsw ! Flag for liquid droplet specification + + real , intent(in) :: gcld(gncol, nlay) ! Cloud fraction + ! Dimensions: (ncol,nlay) + real , intent(in) :: gtauc(gncol,nlay,nbndsw) ! In-cloud optical depth + ! Dimensions: (ncol,nlay,nbndsw) + real , intent(in) :: gssac(gncol,nlay,nbndsw) ! In-cloud single scattering albedo + ! Dimensions: (ncol,nlay,nbndsw) + real , intent(in) :: gasmc(gncol,nlay,nbndsw) ! In-cloud asymmetry parameter + ! Dimensions: (ncol,nlay,nbndsw) + real , intent(in) :: gfsfc(gncol,nlay,nbndsw) ! In-cloud forward scattering fraction + ! Dimensions: (ncol,nlay,nbndsw) + real , intent(in) :: gciwp(gncol, nlay) ! In-cloud ice water path (g/m2) + ! Dimensions: (ncol,nlay) + real , intent(in) :: gclwp(gncol, nlay) ! In-cloud liquid water path (g/m2) + ! Dimensions: (ncol,nlay) + real , intent(in) :: gcswp(gncol, nlay) ! In-cloud snow water path (g/m2) + ! Dimensions: (ncol,nlay) + + real , intent(in) :: grei(gncol, nlay) ! Cloud ice effective radius (microns) + ! Dimensions: (ncol,nlay) + real , intent(in) :: grel(gncol, nlay) ! Cloud water drop effective radius (microns) + ! Dimensions: (ncol,nlay) + real , intent(in) :: gres(gncol, nlay) ! Cloud snow drop effective radius (microns) + ! Dimensions: (ncol,nlay) + + + real , intent(in) :: gplay(gncol,nlay) ! Layer pressures (hPa, mb) + ! Dimensions: (ncol,nlay) + real , intent(in) :: gplev(gncol,nlay+1) ! Interface pressures (hPa, mb) + ! Dimensions: (ncol,nlay+1) + real , intent(in) :: gtlay(gncol,nlay) ! Layer temperatures (K) + ! Dimensions: (ncol,nlay) + real , intent(in) :: gtlev(gncol,nlay+1) ! Interface temperatures (K) + ! Dimensions: (ncol,nlay+1) + real , intent(in) :: gtsfc(gncol) ! Surface temperature (K) + ! Dimensions: (ncol) + real , intent(in) :: gh2ovmr(gncol,nlay) ! H2O volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: go3vmr(gncol,nlay) ! O3 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: gco2vmr(gncol,nlay) ! CO2 volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: gch4vmr(gncol,nlay) ! Methane volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: gn2ovmr(gncol,nlay) ! Nitrous oxide volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: go2vmr(gncol,nlay) ! Oxygen volume mixing ratio + ! Dimensions: (ncol,nlay) + real , intent(in) :: gasdir(gncol) ! UV/vis surface albedo direct rad + ! Dimensions: (ncol) + real , intent(in) :: galdir(gncol) ! Near-IR surface albedo direct rad + ! Dimensions: (ncol) + real , intent(in) :: gasdif(gncol) ! UV/vis surface albedo: diffuse rad + ! Dimensions: (ncol) + real , intent(in) :: galdif(gncol) ! Near-IR surface albedo: diffuse rad + ! Dimensions: (ncol) + + + real , intent(in) :: gcoszen(gncol) ! Cosine of solar zenith angle + ! Dimensions: (ncol) + + real , intent(in) :: gtauaer(gncol,nlay,nbndsw) ! Aerosol optical depth (iaer=10 only) + ! Dimensions: (ncol,nlay,nbndsw) + ! (non-delta scaled) + real , intent(in) :: gssaaer(gncol,nlay,nbndsw) ! Aerosol single scattering albedo (iaer=10 only) + ! Dimensions: (ncol,nlay,nbndsw) + ! (non-delta scaled) + real , intent(in) :: gasmaer(gncol,nlay,nbndsw) ! Aerosol asymmetry parameter (iaer=10 only) + ! Dimensions: (ncol,nlay,nbndsw) + ! (non-delta scaled) + real , intent(in) :: gecaer(:,:,:) ! Aerosol optical depth at 0.55 micron (iaer=6 only) + ! Dimensions: (ncol,nlay,naerec) + ! (non-delta scaled) +! integer , intent(in) :: normFlx ! Normalize fluxes flag + ! 0 = no normalization + ! 1 = normalize fluxes ( / (scon * coszen) ) + +! ----- Output ----- + + real , intent(out) :: swuflx(:,:) ! Total sky shortwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: swdflx(:,:) ! Total sky shortwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: swhr(:,:) ! Total sky shortwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + real , intent(out) :: swuflxc(:,:) ! Clear sky shortwave upward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: swdflxc(:,:) ! Clear sky shortwave downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) + real , intent(out) :: swhrc(:,:) ! Clear sky shortwave radiative heating rate (K/d) + ! Dimensions: (ncol,nlay) + + real, intent(out) :: sibvisdir(:,:) ! visible direct downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real, intent(out) :: sibvisdif(:,:) ! visible diffusion downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real, intent(out) :: sibnirdir(:,:) ! Near IR direct downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real, intent(out) :: sibnirdif(:,:) ! Near IR diffusion downward flux (W/m2) + ! Dimensions: (ncol,nlay+1) Zhenxin (2011/06/20) + real, intent(out) :: swdkdir(:,:) ! Total shortwave downward direct flux (W/m2) + ! Dimensions: (ncol,nlay+1) jararias, 2013/08/10 + real, intent(out) :: swdkdif(:,:) ! Total shortwave downward diffuse flux (W/m2) + ! Dimensions: (ncol,nlay+1) jararias, 2013/08/10 + +! ----- Local ----- + +! Control + + integer :: istart ! beginning band of calculation + integer :: iend ! ending band of calculation + integer :: icpr ! cldprop/cldprmc use flag + integer :: iout ! output option flag + + integer :: idelm ! delta-m scaling flag + ! [0 = direct and diffuse fluxes are unscaled] + ! [1 = direct and diffuse fluxes are scaled] + ! (total downward fluxes are always delta scaled) + integer :: isccos ! instrumental cosine response flag (inactive) + integer :: iplon ! column loop index + integer :: i ! layer loop index ! jk + integer :: ib ! band loop index ! jsw + integer :: ia, ig ! indices + integer :: k ! layer loop index + integer :: ims ! value for changing mcica permute seed + integer :: imca ! flag for mcica [0=off, 1=on] + + real :: zepsec, zepzen ! epsilon + real :: zdpgcp ! flux to heating conversion ratio + +#ifndef _ACCEL +# define ncol CHNK +#endif + +! Atmosphere + + real :: coldry(ncol,nlay+1) ! dry air column amount + real :: wkl(ncol,mxmol,nlay) ! molecular amounts (mol/cm-2) + + real :: cossza(ncol) ! Cosine of solar zenith angle + real :: adjflux(jpband) ! adjustment for current Earth/Sun distance + + ! default value of 1368.22 Wm-2 at 1 AU + real :: albdir(ncol,nbndsw) ! surface albedo, direct ! zalbp + real :: albdif(ncol,nbndsw) ! surface albedo, diffuse ! zalbd + +! real :: rdl(ncol), adl(ncol) + +! Atmosphere - setcoef + integer :: laytrop(ncol) ! tropopause layer index + integer :: layswtch(ncol) ! tropopause layer index + integer :: laylow(ncol) ! tropopause layer index + integer :: jp(ncol,nlay+1) ! + integer :: jt(ncol,nlay+1) ! + integer :: jt1(ncol,nlay+1) ! + + real :: colh2o(ncol,nlay+1) ! column amount (h2o) + real :: colco2(ncol,nlay+1) ! column amount (co2) + real :: colo3(ncol,nlay+1) ! column amount (o3) + real :: coln2o(ncol,nlay+1) ! column amount (n2o) + real :: colch4(ncol,nlay+1) ! column amount (ch4) + real :: colo2(ncol,nlay+1) ! column amount (o2) + real :: colmol(ncol,nlay+1) ! column amount + real :: co2mult(ncol,nlay+1) ! column amount + + integer :: indself(ncol,nlay+1) + integer :: indfor(ncol,nlay+1) + real :: selffac(ncol,nlay+1) + real :: selffrac(ncol,nlay+1) + real :: forfac(ncol,nlay+1) + real :: forfrac(ncol,nlay+1) + + real :: & ! + fac00(ncol,nlay+1) , fac01(ncol,nlay+1) , & + fac10(ncol,nlay+1) , fac11(ncol,nlay+1) + + real :: play(ncol,nlay) ! Layer pressures (hPa, mb) + ! Dimensions: (ncol,nlay) + real :: plev(ncol,nlay+1) ! Interface pressures (hPa, mb) + ! Dimensions: (ncol,nlay+1) + real :: tlay(ncol,nlay) ! Layer temperatures (K) + ! Dimensions: (ncol,nlay) + real :: tlev(ncol,nlay+1) ! Interface temperatures (K) + ! Dimensions: (ncol,nlay+1) + real :: tsfc(ncol) ! Surface temperature (K) + ! Dimensions: (ncol) + real :: coszen(ncol) + +! Atmosphere/clouds - cldprop + integer :: ncbands ! number of cloud spectral bands + + real :: cld(ncol,nlay) ! Cloud fraction + real :: tauc(ncol,nlay,nbndsw) ! In-cloud optical depth + real :: ssac(ncol,nlay,nbndsw) ! In-cloud single scattering + real :: asmc(ncol,nlay,nbndsw) ! In-cloud asymmetry parameter + real :: fsfc(ncol,nlay,nbndsw) ! In-cloud forward scattering fraction + real :: ciwp(ncol,nlay) ! In-cloud ice water path (g/m2) + real :: clwp(ncol,nlay) ! In-cloud liquid water path (g/m2) + real :: cswp(ncol,nlay) ! In-cloud snow water path (g/m2) + real :: rei(ncol,nlay) ! Cloud ice effective radius (microns) + real :: rel(ncol,nlay) ! Cloud water drop effective radius (microns) + real :: res(ncol,nlay) ! Cloud snow effective radius (microns) + + real :: taucmc(ncol,nlay+1,ngptsw) ! in-cloud optical depth [mcica] + real :: taormc(ncol,nlay+1,ngptsw) ! unscaled in-cloud optical depth [mcica] + real :: ssacmc(ncol,nlay+1,ngptsw) ! in-cloud single scattering albedo [mcica] + real :: asmcmc(ncol,nlay+1,ngptsw) ! in-cloud asymmetry parameter [mcica] + real :: fsfcmc(ncol,nlay+1,ngptsw) ! in-cloud forward scattering fraction [mcica] + + real :: cldfmcl(ncol,nlay+1,ngptsw) ! cloud fraction [mcica] + real :: ciwpmcl(ncol,nlay+1,ngptsw) ! in-cloud ice water path [mcica] + real :: clwpmcl(ncol,nlay+1,ngptsw) ! in-cloud liquid water path [mcica] + real :: cswpmcl(ncol,nlay+1,ngptsw) ! in-cloud liquid water path [mcica] + +! Atmosphere/clouds/aerosol - spcvrt,spcvmc + real :: ztauc(ncol,nlay+1,nbndsw) ! cloud optical depth + real :: ztaucorig(ncol,nlay+1,nbndsw) ! unscaled cloud optical depth + real :: zasyc(ncol,nlay+1,nbndsw) ! cloud asymmetry parameter + ! (first moment of phase function) + real :: zomgc(ncol,nlay+1,nbndsw) ! cloud single scattering albedo + + real :: taua(ncol, nlay+1, nbndsw) + real :: asya(ncol, nlay+1, nbndsw) + real :: omga(ncol, nlay+1, nbndsw) + + real :: zbbfu(ncol,nlay+2) ! temporary upward shortwave flux (w/m2) + real :: zbbfd(ncol,nlay+2) ! temporary downward shortwave flux (w/m2) + real :: zbbcu(ncol,nlay+2) ! temporary clear sky upward shortwave flux (w/m2) + real :: zbbcd(ncol,nlay+2) ! temporary clear sky downward shortwave flux (w/m2) + real :: zbbfddir(ncol,nlay+2) ! temporary downward direct shortwave flux (w/m2) + real :: zbbcddir(ncol,nlay+2) ! temporary clear sky downward direct shortwave flux (w/m2) + real :: zuvfd(ncol,nlay+2) ! temporary UV downward shortwave flux (w/m2) + real :: zuvcd(ncol,nlay+2) ! temporary clear sky UV downward shortwave flux (w/m2) + real :: zuvfddir(ncol,nlay+2) ! temporary UV downward direct shortwave flux (w/m2) + real :: zuvcddir(ncol,nlay+2) ! temporary clear sky UV downward direct shortwave flux (w/m2) + real :: znifd(ncol,nlay+2) ! temporary near-IR downward shortwave flux (w/m2) + real :: znicd(ncol,nlay+2) ! temporary clear sky near-IR downward shortwave flux (w/m2) + real :: znifddir(ncol,nlay+2) ! temporary near-IR downward direct shortwave flux (w/m2) + real :: znicddir(ncol,nlay+2) ! temporary clear sky near-IR downward direct shortwave flux (w/m2) + +! Optional output fields + real :: swnflx(ncol,nlay+2) ! Total sky shortwave net flux (W/m2) + real :: swnflxc(ncol,nlay+2) ! Clear sky shortwave net flux (W/m2) + real :: dirdflux(ncol,nlay+2) ! Direct downward shortwave surface flux + real :: difdflux(ncol,nlay+2) ! Diffuse downward shortwave surface flux + real :: uvdflx(ncol,nlay+2) ! Total sky downward shortwave flux, UV/vis + real :: nidflx(ncol,nlay+2) ! Total sky downward shortwave flux, near-IR + real :: dirdnuv(ncol,nlay+2) ! Direct downward shortwave flux, UV/vis + real :: difdnuv(ncol,nlay+2) ! Diffuse downward shortwave flux, UV/vis + real :: dirdnir(ncol,nlay+2) ! Direct downward shortwave flux, near-IR + real :: difdnir(ncol,nlay+2) ! Diffuse downward shortwave flux, near-IR + + real gpu_device :: zgco(ncol,ngptsw,nlay+1) , zomco(ncol,ngptsw,nlay+1) + real gpu_device :: zrdnd(ncol,ngptsw,nlay+1) + real gpu_device :: zref(ncol,ngptsw,nlay+1) , zrefo(ncol,ngptsw,nlay+1) + real gpu_device :: zrefd(ncol,ngptsw,nlay+1) , zrefdo(ncol,ngptsw,nlay+1) + real gpu_device :: ztauo(ncol,ngptsw,nlay) + real gpu_device :: zdbt(ncol,ngptsw,nlay+1) , ztdbt(ncol,ngptsw,nlay+1) + real gpu_device :: ztra(ncol,ngptsw,nlay+1) , ztrao(ncol,ngptsw,nlay+1) + real gpu_device :: ztrad(ncol,ngptsw,nlay+1) , ztrado(ncol,ngptsw,nlay+1) + real gpu_device :: zfd(ncol,ngptsw,nlay+1) , zfu(ncol,ngptsw,nlay+1) + real gpu_device :: zsflxzen(ncol,ngptsw) + real gpu_device :: ztaur(ncol,nlay,ngptsw) , ztaug(ncol,nlay,ngptsw) +#ifndef _ACCEL +# undef ncol +#endif + + integer :: npartc, npart, npartb, cldflag(gncol), profic(gncol), profi(gncol) + + real , parameter :: amd = 28.9660 ! Effective molecular weight of dry air (g/mol) + real , parameter :: amw = 18.0160 ! Molecular weight of water vapor (g/mol) + +! Set molecular weight ratios (for converting mmr to vmr) +! e.g. h2ovmr = h2ommr * amdw) + real , parameter :: amdw = 1.607793 ! Molecular weight of dry air / water vapor + real , parameter :: amdc = 0.658114 ! Molecular weight of dry air / carbon dioxide + real , parameter :: amdo = 0.603428 ! Molecular weight of dry air / ozone + real , parameter :: amdm = 1.805423 ! Molecular weight of dry air / methane + real , parameter :: amdn = 0.658090 ! Molecular weight of dry air / nitrous oxide + real , parameter :: amdo2 = 0.905140 ! Molecular weight of dry air / oxygen + + real , parameter :: sbc = 5.67e-08 ! Stefan-Boltzmann constant (W/m2K4) + integer ii,jj,kk,iw + integer :: isp, l, ix, n, imol ! Loop indices + real :: amm, summol ! + real :: adjflx ! flux adjustment for Earth/Sun distance + integer :: prt + integer :: piplon + + integer :: ipart, cols, cole, colr, ncolc, ncolb + integer :: irng, cc, ncolst + +! Initializations + + zepsec = 1.e-06 + zepzen = 1.e-10 + oneminus = 1.0 - zepsec + pi = 2. * asin(1. ) + irng = 0 + + istart = jpb1 + iend = jpb2 + iout = 0 + icpr = 1 + ims = 2 + + adjflx = adjes + if (dyofyr .gt. 0) then + adjflx = earth_sun(dyofyr) + endif + + do ib = jpb1, jpb2 + adjflux(ib) = adjflx * scon / rrsw_scon + end do + + if (icld.lt.0.or.icld.gt.3) icld = 2 + + +! determine cloud profile + cldflag=0 + do iplon = 1, gncol + if (any(gcld(iplon,:) > 0)) cldflag(iplon)=1 + end do + + +! build profile separation + cols = 0 + cole = 0 + + do iplon = 1, gncol + if (cldflag(iplon)==1) then + cole=cole+1 + profi(cole) = iplon + else + cols=cols+1 + profic(cols) = iplon + end if + end do + + +!$acc data copyout(swuflxc, swdflxc, swuflx, swdflx, swnflxc, swnflx, swhrc, swhr) & +!$acc create(laytrop, layswtch, laylow, jp, jt, jt1, & +!$acc co2mult, colch4, colco2, colh2o, colmol, coln2o, & +!$acc colo2, colo3, fac00, fac01, fac10, fac11, & +!$acc selffac, selffrac, indself, forfac, forfrac, indfor, & +!$acc zbbfu, zbbfd, zbbcu, zbbcd,zbbfddir, zbbcddir, zuvfd, zuvcd, zuvfddir, & +!$acc zuvcddir, znifd, znicd, znifddir,znicddir, & +!$acc cldfmcl, ciwpmcl, clwpmcl, cswpmcl, & +!$acc taormc, taucmc, ssacmc, asmcmc, fsfcmc) & +!$acc deviceptr(zref,zrefo,zrefd,zrefdo,& +!$acc ztauo,ztdbt,& +!$acc ztra,ztrao,ztrad,ztrado,& +!$acc zfd,zfu,zdbt,zgco,& +!$acc zomco,zrdnd,ztaug, ztaur,zsflxzen)& +!$acc create(ciwp, clwp, cswp, cld, tauc, ssac, asmc, fsfc, rei, rel, res) & +!$acc create(play, tlay, plev, tlev, tsfc, cldflag, coszen) & +!$acc create(coldry, wkl) & +!$acc create(extliq1, ssaliq1, asyliq1, extice2, ssaice2, asyice2) & +!$acc create(extice3, ssaice3, asyice3, fdlice3, abari, bbari, cbari, dbari, ebari, fbari) & +!$acc create(taua, asya, omga,gtauaer,gssaaer,gasmaer) & +!$acc copyin(wavenum2, ngb) & +!$acc copyin(tref, preflog, albdif, albdir, cossza)& +!$acc copyin(icxa, adjflux, nspa, nspb)& +!$acc copyin(kao16,kbo16,selfrefo16,forrefo16,sfluxrefo16)& +!$acc copyin(ka16,kb16,selfref16,forref16,sfluxref16)& +!$acc copyin(kao17,kbo17,selfrefo17,forrefo17,sfluxrefo17)& +!$acc copyin(ka17,kb17,selfref17,forref17,sfluxref17)& +!$acc copyin(kao18,kbo18,selfrefo18,forrefo18,sfluxrefo18)& +!$acc copyin(ka18,kb18,selfref18,forref18,sfluxref18)& +!$acc copyin(kao19,kbo19,selfrefo19,forrefo19,sfluxrefo19)& +!$acc copyin(ka19,kb19,selfref19,forref19,sfluxref19)& +!$acc copyin(kao20,kbo20,selfrefo20,forrefo20,sfluxrefo20,absch4o20)& +!$acc copyin(ka20,kb20,selfref20,forref20,sfluxref20,absch420)& +!$acc copyin(kao21,kbo21,selfrefo21,forrefo21,sfluxrefo21)& +!$acc copyin(ka21,kb21,selfref21,forref21,sfluxref21)& +!$acc copyin(kao22,kbo22,selfrefo22,forrefo22,sfluxrefo22)& +!$acc copyin(ka22,kb22,selfref22,forref22,sfluxref22)& +!$acc copyin(kao23,selfrefo23,forrefo23,sfluxrefo23,raylo23)& +!$acc copyin(ka23,selfref23,forref23,sfluxref23,rayl23)& +!$acc copyin(kao24,kbo24,selfrefo24,forrefo24,sfluxrefo24,abso3ao24,abso3bo24,raylao24,raylbo24)& +!$acc copyin(ka24,kb24,selfref24,forref24,sfluxref24,abso3a24,abso3b24,rayla24,raylb24)& +!$acc copyin(kao25,sfluxrefo25,abso3ao25,abso3bo25,raylo25)& +!$acc copyin(ka25,sfluxref25,abso3a25,abso3b25,rayl25)& +!$acc copyin(sfluxrefo26)& +!$acc copyin(sfluxref26)& +!$acc copyin(kao27,kbo27,sfluxrefo27, raylo27)& +!$acc copyin(ka27,kb27,sfluxref27, rayl27)& +!$acc copyin(kao28,kbo28,sfluxrefo28)& +!$acc copyin(ka28,kb28,sfluxref28,gtauc, gssac, gasmc, gfsfc)& +!$acc copyin(kao29,kbo29,selfrefo29,forrefo29,sfluxrefo29,absh2oo29,absco2o29)& +!$acc copyin(ka29,kb29,selfref29,forref29,sfluxref29,absh2o29,absco229)& +!$acc copyin(gh2ovmr, gco2vmr, go3vmr, gn2ovmr, gch4vmr, go2vmr)& +!$acc copyin(gcld, gciwp, gclwp, gcswp, grei, grel, gres, gplay, gplev, gtlay, gtlev, gtsfc)& +!$acc copyin(gasdir, galdir, gasdif, galdif,profi,profic,gcoszen)& +!$acc copyout(sibvisdir,sibvisdif,sibnirdir,sibnirdif,swdkdir,swdkdif) + +!$acc update device(extliq1, ssaliq1, asyliq1, extice2, ssaice2, asyice2) & +!$acc device(extice3, ssaice3, asyice3, fdlice3, abari, bbari, cbari, dbari, ebari, fbari) & +!$acc device(preflog) + + + ncolc = cols + ncolb = cole + + npartc = ceiling( real(ncolc) / real(ncol) ) + npartb = ceiling( real(ncolb) / real(ncol) ) + + +!$acc kernels + cldfmcl = 0.0 + ciwpmcl = 0.0 + clwpmcl = 0.0 + cswpmcl = 0.0 +!$acc end kernels + + idelm = 1 + +!$acc kernels + taua = 0.0 + asya = 0.0 + omga = 1.0 +!$acc end kernels + + if (iaer==10) then + +!$acc update device(gtauaer,gssaaer,gasmaer) + + end if + + + + +! PARTITION LOOP ---------------------------------------------------------------------------- + do cc = 1, 2 + + if (cc==1) then + + npart = npartc + ncolst = ncolc + + else + + npart = npartb + ncolst = ncolb + + end if + + do ipart = 0,npart-1 +!jm call unsetdebug +!jm if (ipart.eq.IDEBUG-1) then +!jm write(0,*)'setting setdebug ipart = ',ipart+1,' npart ',npart +!jm call setdebug +!jm endif + cols = ipart * ncol + 1 + cole = (ipart + 1) * ncol + if (cole>ncolst) cole=ncolst + colr = cole - cols + 1 + +!$acc kernels + taormc = 0.0 + taucmc = 0.0 + ssacmc = 1.0 + asmcmc = 0.0 + fsfcmc = 0.0 +!$acc end kernels + +! Clear cases + if (cc==1) then +!$acc kernels loop private(piplon) + do iplon = 1, colr + piplon = profic(iplon + cols - 1) + + do ib=1,8 + albdir(iplon,ib) = galdir(piplon) + albdif(iplon,ib) = galdif(piplon) + enddo + albdir(iplon,nbndsw) = galdir(piplon) + albdif(iplon,nbndsw) = galdif(piplon) +! UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron + + do ib=10,13 + albdir(iplon,ib) = gasdir(piplon) + albdif(iplon,ib) = gasdif(piplon) + enddo + +! Transition band 9, 12850-16000 cm-1, 0.625-0.778 micron, Take average + albdir(iplon, 9) = (gasdir(piplon)+galdir(piplon))/2. + albdif(iplon, 9) = (gasdif(piplon)+galdif(piplon))/2. + end do +!$acc end kernels + +!$acc kernels + do iplon = 1, colr + piplon = profic(iplon + cols - 1) + play(iplon,:) = gplay(piplon, 1:nlay) + plev(iplon,:) = gplev(piplon, 1:nlay+1) + tlay(iplon,:) = gtlay(piplon, 1:nlay) + tlev(iplon,:) = gtlev(piplon, 1:nlay+1) + tsfc(iplon) = gtsfc(piplon) + end do +!$acc end kernels + + if (iaer==10) then +!$acc kernels + do iw=1,nbndsw + do kk=1,nlay + do iplon = 1, colr + piplon = profic(iplon + cols - 1) + taua(iplon, kk, iw) = gtauaer(piplon, kk, iw) + asya(iplon, kk, iw) = gasmaer(piplon, kk, iw) + omga(iplon, kk, iw) = gssaaer(piplon, kk, iw) + end do + end do + end do +!$acc end kernels + end if + +!$acc kernels + do iplon = 1, colr + piplon = profic(iplon + cols - 1) + wkl(iplon,1,:) = gh2ovmr(piplon,1:nlay) + wkl(iplon,2,:) = gco2vmr(piplon,1:nlay) + wkl(iplon,3,:) = go3vmr(piplon,1:nlay) + wkl(iplon,4,:) = gn2ovmr(piplon,1:nlay) + wkl(iplon,5,:) = 0.0 + wkl(iplon,6,:) = gch4vmr(piplon,1:nlay) + wkl(iplon,7,:) = go2vmr(piplon,1:nlay) + coszen(iplon) = gcoszen(piplon) + end do +!$acc end kernels + +!************** cloudy cases *************** + else + +!$acc kernels loop private(piplon) + do iplon = 1, colr + piplon = profi(iplon + cols - 1) + + do ib=1,8 + albdir(iplon,ib) = galdir(piplon) + albdif(iplon,ib) = galdif(piplon) + enddo + albdir(iplon,nbndsw) = galdir(piplon) + albdif(iplon,nbndsw) = galdif(piplon) + +! UV/visible bands 25-28 (10-13), 16000-50000 cm-1, 0.200-0.625 micron + do ib=10,13 + albdir(iplon,ib) = gasdir(piplon) + albdif(iplon,ib) = gasdif(piplon) + enddo + +! Transition band 9, 12850-16000 cm-1, 0.625-0.778 micron, Take average + albdir(iplon, 9) = (gasdir(piplon)+galdir(piplon))/2. + albdif(iplon, 9) = (gasdif(piplon)+galdif(piplon))/2. + end do +!$acc end kernels + +!$acc kernels + do iplon = 1, colr + piplon = profi(iplon + cols - 1) + play(iplon,:) = gplay(piplon, 1:nlay) + plev(iplon,:) = gplev(piplon, 1:nlay+1) + tlay(iplon,:) = gtlay(piplon, 1:nlay) + tlev(iplon,:) = gtlev(piplon, 1:nlay+1) + tsfc(iplon) = gtsfc(piplon) + cld(iplon,:) = gcld(piplon, 1:nlay) + ciwp(iplon,:) = gciwp(piplon, 1:nlay) + clwp(iplon,:) = gclwp(piplon, 1:nlay) + cswp(iplon,:) = gcswp(piplon, 1:nlay) + rei(iplon,:) = grei(piplon, 1:nlay) + rel(iplon,:) = grel(piplon, 1:nlay) + res(iplon,:) = gres(piplon, 1:nlay) + end do + +!$acc end kernels + if (iaer==10) then + +!$acc kernels + do iw=1,nbndsw + do kk=1,nlay + do iplon = 1, colr + piplon = profi(iplon + cols - 1) + taua(iplon, kk, iw) = gtauaer(piplon, kk, iw) + asya(iplon, kk, iw) = gasmaer(piplon, kk, iw) + omga(iplon, kk, iw) = gssaaer(piplon, kk, iw) + end do + end do + end do +!$acc end kernels + end if + + +! Copy the direct cloud optical properties over to the temp arrays +! and then onto the GPU +! We are on the CPU here + +!$acc kernels + do iw=1,nbndsw + do kk=1,nlay + do iplon = 1, colr + piplon = profi(iplon + cols - 1) + tauc(iplon, kk, iw) = gtauc(piplon, kk, iw) + ssac(iplon, kk, iw) = gssac(piplon, kk, iw) + asmc(iplon, kk, iw) = gasmc(piplon, kk, iw) + fsfc(iplon, kk, iw) = gfsfc(piplon, kk, iw) + end do + end do + end do +!$acc end kernels + +!$acc kernels + do iplon = 1, colr + piplon = profi(iplon + cols - 1) + wkl(iplon,1,:) = gh2ovmr(piplon,1:nlay) + wkl(iplon,2,:) = gco2vmr(piplon,1:nlay) + wkl(iplon,3,:) = go3vmr(piplon,1:nlay) + wkl(iplon,4,:) = gn2ovmr(piplon,1:nlay) + wkl(iplon,5,:) = 0.0 + wkl(iplon,6,:) = gch4vmr(piplon,1:nlay) + wkl(iplon,7,:) = go2vmr(piplon,1:nlay) + coszen(iplon) = gcoszen(piplon) + end do +!$acc end kernels + end if ! if-else-endif cc=1 (clear and cloudy cases) + +!$acc kernels + cossza = max(zepzen,coszen) +!$acc end kernels + +!$acc kernels + do iplon = 1,colr + do l = 1,nlay + coldry(iplon, l) = (plev(iplon, l)-plev(iplon, l+1)) * 1.e3 * avogad / & + (1.e2 * grav * ((1. - wkl(iplon, 1,l)) * amd + wkl(iplon, 1,l) * amw) * & + (1. + wkl(iplon, 1,l))) + end do + end do +!$acc end kernels + +!$acc kernels + do iplon = 1,colr + do l = 1,nlay + do imol = 1, nmol + wkl(iplon,imol,l) = coldry(iplon,l) * wkl(iplon,imol,l) + end do + end do + end do +!$acc end kernels + +#ifndef _ACCEL +! Use Tom Henderson's technique to pad out and vector remainder +! with valid data so that we can have a static loop range over +! columns without having to test for short vectors. + IF ( colr < CHNK ) THEN + + DO jj = 1,ngptsw + DO kk = 1,nlay+1 + DO ii = colr+1, CHNK + taormc(ii,kk,jj) = taormc(colr,kk,jj) + taucmc(ii,kk,jj) = taucmc(colr,kk,jj) + ssacmc(ii,kk,jj) = ssacmc(colr,kk,jj) + asmcmc(ii,kk,jj) = asmcmc(colr,kk,jj) + fsfcmc(ii,kk,jj) = fsfcmc(colr,kk,jj) + ENDDO + ENDDO + ENDDO + DO ib = 1,13 + DO ii = colr+1, CHNK + albdir(ii,ib) = albdir(colr,ib) + albdif(ii,ib) = albdif(colr,ib) + ENDDO + ENDDO + DO kk = 1,nlay+1 + DO ii = colr+1, CHNK + plev(ii,kk) = plev(colr,kk) + tlev(ii,kk) = tlev(colr,kk) + coldry(ii,kk) = coldry(colr,kk) + ENDDO + ENDDO + DO kk = 1,nlay + DO ii = colr+1, CHNK + play(ii,kk) = play(colr,kk) + tlay(ii,kk) = tlay(colr,kk) + cld(ii,kk) = cld(colr,kk) + ciwp(ii,kk) = ciwp(colr,kk) + clwp(ii,kk) = clwp(colr,kk) + cswp(ii,kk) = cswp(colr,kk) + rei(ii,kk) = rei(colr,kk) + rel(ii,kk) = rel(colr,kk) + res(ii,kk) = res(colr,kk) + ENDDO + ENDDO + DO ii = colr+1, CHNK + tsfc(ii) = tsfc(colr) + ENDDO + IF ( iaer==10 ) THEN + DO jj = 1,nbndsw + DO kk = 1,nlay+1 + DO ii = colr+1, CHNK + taua(ii,kk,jj) = taua(colr,kk,jj) + asya(ii,kk,jj) = asya(colr,kk,jj) + omga(ii,kk,jj) = omga(colr,kk,jj) + ENDDO + ENDDO + ENDDO + ENDIF + DO jj = 1,nbndsw + DO kk = 1,nlay + DO ii = colr+1, CHNK + tauc(ii,kk,jj) = tauc(colr,kk,jj) + ssac(ii,kk,jj) = ssac(colr,kk,jj) + asmc(ii,kk,jj) = asmc(colr,kk,jj) + fsfc(ii,kk,jj) = fsfc(colr,kk,jj) + ENDDO + ENDDO + ENDDO + DO kk = 1,nlay + DO jj = 1,mxmol + DO ii = colr+1, CHNK + wkl(ii,jj,kk) = wkl(colr,jj,kk) + ENDDO + ENDDO + ENDDO + DO ii = colr+1, CHNK + coszen(ii) = coszen(colr) + ENDDO + + ENDIF +#endif + +#ifndef _ACCEL +# define colr CHNK +#endif + + if (cc==2) then ! call mcica for cloudy cases + call mcica_sw(colr, nlay, 112, icld, irng, play, & + cld, ciwp, clwp, cswp, tauc, ssac, asmc, fsfc, & + cldfmcl, ciwpmcl, clwpmcl, cswpmcl, & + taucmc, ssacmc, asmcmc, fsfcmc, 1 ) + end if + + if (cc==2) then ! call cldprmc for cloudy cases + call cldprmc_sw(colr, nlay, inflgsw, iceflgsw, liqflgsw, & + cldfmcl, ciwpmcl, clwpmcl, cswpmcl, rei, rel, res, & + taormc, taucmc, ssacmc, asmcmc, fsfcmc) + end if + + call setcoef_sw(colr, nlay, play , tlay , plev , tlev , tsfc , & + coldry , wkl , & + laytrop, layswtch, laylow, jp , jt , jt1 , & + co2mult , colch4 , colco2 , colh2o , colmol , coln2o , & + colo2 , colo3 , fac00 , fac01 , fac10 , fac11 , & + selffac , selffrac , indself , forfac , forfrac , indfor ) + + call spcvmc_sw(cc, ncol, colr, nlay, istart, iend, icpr, idelm, iout, & + play, tlay, plev, tlev, & + tsfc, albdif, albdir, & + cldfmcl, taucmc, asmcmc, ssacmc, taormc, & + taua, asya, omga, cossza, coldry, adjflux, & + laytrop, layswtch, laylow, jp, jt, jt1, & + co2mult, colch4, colco2, colh2o, colmol, & + coln2o, colo2, colo3, & + fac00, fac01, fac10, fac11, & + selffac, selffrac, indself, forfac, forfrac, indfor, & + zbbfd, zbbfu, zbbcd, zbbcu, zuvfd, & + zuvcd, znifd, znicd, & + zbbfddir, zbbcddir, zuvfddir, zuvcddir, znifddir, znicddir,& + zgco,zomco,zrdnd,zref,zrefo,zrefd,zrefdo,ztauo,zdbt,ztdbt,& + ztra,ztrao,ztrad,ztrado,zfd,zfu,ztaug, ztaur, zsflxzen) + +#ifndef _ACCEL +# undef colr +#endif + +! Transfer up and down, clear and total sky fluxes to output arrays. +! Vertical indexing goes from bottom to top; reverse here for GCM if necessary. + + if (cc==1) then ! clear +!$acc kernels loop independent + do iplon = 1, colr + piplon = profic(iplon + cols - 1) + + do i = 1, nlay+1 + swuflxc(piplon,i) = zbbcu(iplon,i) + swdflxc(piplon,i) = zbbcd(iplon,i) + swuflx(piplon,i) = zbbfu(iplon,i) + swdflx(piplon,i) = zbbfd(iplon,i) + +! All-sky downwward direct and diffuse fluxes + swdkdir(piplon,i) = zbbfddir(iplon,i) + swdkdif(piplon,i) = zbbfd(iplon,i) - zbbfddir(iplon,i) +! UV/visible downward direct/diffuse fluxes + sibvisdir(piplon,i) = zuvfddir(iplon,i) + sibvisdif(piplon,i) = zuvfd(iplon,i) - zuvfddir(iplon,i) +! Near-IR downward direct/diffuse fluxes + sibnirdir(piplon,i) = znifddir(iplon,i) + sibnirdif(piplon,i) = znifd(iplon,i) - znifddir(iplon,i) + enddo + +! Total and clear sky net fluxes + + do i = 1, nlay+1 + swnflxc(iplon,i) = swdflxc(piplon,i) - swuflxc(piplon,i) + swnflx(iplon,i) = swdflx(piplon,i) - swuflx(piplon,i) + enddo + +! Total and clear sky heating rates + + do i = 1, nlay + zdpgcp = heatfac / (plev(iplon, i) - plev(iplon, i+1)) + swhrc(piplon,i) = (swnflxc(iplon,i+1) - swnflxc(iplon,i) ) * zdpgcp + swhr(piplon,i) = (swnflx(iplon,i+1) - swnflx(iplon,i) ) * zdpgcp + enddo + swhrc(piplon,nlay) = 0. + swhr(piplon,nlay) = 0. + +! End longitude loop + enddo +!$acc end kernels + + else ! cc = 2, cloudy +!$acc kernels loop independent + do iplon = 1, colr + piplon = profi(iplon + cols - 1) + + do i = 1, nlay+1 + swuflxc(piplon,i) = zbbcu(iplon,i) + swdflxc(piplon,i) = zbbcd(iplon,i) + swuflx(piplon,i) = zbbfu(iplon,i) + swdflx(piplon,i) = zbbfd(iplon,i) + +! All-sky downwward direct and diffuse fluxes + swdkdir(piplon,i) = zbbfddir(iplon,i) + swdkdif(piplon,i) = zbbfd(iplon,i) - zbbfddir(iplon,i) +! UV/visible downward direct/diffuse fluxes + sibvisdir(piplon,i) = zuvfddir(iplon,i) + sibvisdif(piplon,i) = zuvfd(iplon,i) - zuvfddir(iplon,i) +! Near-IR downward direct/diffuse fluxes + sibnirdir(piplon,i) = znifddir(iplon,i) + sibnirdif(piplon,i) = znifd(iplon,i) - znifddir(iplon,i) + enddo + +! Total and clear sky net fluxes + + do i = 1, nlay+1 + swnflxc(iplon,i) = swdflxc(piplon,i) - swuflxc(piplon,i) + swnflx(iplon,i) = swdflx(piplon,i) - swuflx(piplon,i) + enddo + +! Total and clear sky heating rates + + do i = 1, nlay + zdpgcp = heatfac / (plev(iplon, i) - plev(iplon, i+1)) + swhrc(piplon,i) = (swnflxc(iplon,i+1) - swnflxc(iplon,i) ) * zdpgcp + swhr(piplon,i) = (swnflx(iplon,i+1) - swnflx(iplon,i) ) * zdpgcp + enddo + swhrc(piplon,nlay) = 0. + swhr(piplon,nlay) = 0. + +! End longitude loop + enddo +!$acc end kernels + + end if ! if-else-endif clear-cloudy + +! End partition loops + end do + + end do + +!$acc end data + + end subroutine rrtmg_sw_sub + +!************************************************************************* + real function earth_sun(idn) +!************************************************************************* +! +! Purpose: Function to calculate the correction factor of Earth's orbit +! for current day of the year + +! idn : Day of the year +! earth_sun : square of the ratio of mean to actual Earth-Sun distance + +! ------- Modules ------- + + use rrsw_con_f, only : pi + + integer , intent(in) :: idn + + real :: gamma + + gamma = 2. *pi*(idn-1)/365. + +! Use Iqbal's equation 1.2.1 + + earth_sun = 1.000110 + .034221 * cos(gamma) + .001289 * sin(gamma) + & + .000719 * cos(2. *gamma) + .000077 * sin(2. *gamma) + + end function earth_sun + + end module rrtmg_sw_rad_f + +!------------------------------------------------------------------ + MODULE module_ra_rrtmg_swf + + use module_model_constants, only : cp + USE module_wrf_error +! USE module_dm + + use parrrsw_f, only : nbndsw, ngptsw, naerec + use rrtmg_sw_init_f, only: rrtmg_sw_ini + use rrtmg_sw_rad_f, only: rrtmg_sw +! use mcica_subcol_gen_sw, only: mcica_subcol_sw + + use module_ra_rrtmg_lwf, only : inirad, o3data, relcalc, reicalc, retab +! mcica_random_numbers, randomNumberSequence, & +! new_RandomNumberSequence, getRandomReal + + CONTAINS + +!------------------------------------------------------------------ + SUBROUTINE RRTMG_SWRAD_FAST( & + rthratensw, & + swupt, swuptc, swdnt, swdntc, & + swupb, swupbc, swdnb, swdnbc, & +! swupflx, swupflxc, swdnflx, swdnflxc, & + swcf, gsw, & + xtime, gmt, xlat, xlong, & + radt, degrad, declin, & + coszr, julday, solcon, & + albedo, t3d, t8w, tsk, & + p3d, p8w, pi3d, rho3d, & + dz8w, cldfra3d, lradius, iradius, & + is_cammgmp_used, r, g, & + re_cloud,re_ice,re_snow, & + has_reqc,has_reqi,has_reqs, & + icloud, warm_rain, & + f_ice_phy, f_rain_phy, & + xland, xice, snow, & + qv3d, qc3d, qr3d, & + qi3d, qs3d, qg3d, & + o3input, o33d, & + aer_opt, aerod, no_src, & + alswvisdir, alswvisdif, & !Zhenxin ssib alb comp (06/20/2011) + alswnirdir, alswnirdif, & !Zhenxin ssib alb comp (06/20/2011) + swvisdir, swvisdif, & !Zhenxin ssib swr comp (06/20/2011) + swnirdir, swnirdif, & !Zhenxin ssib swi comp (06/20/2011) + sf_surface_physics, & !Zhenxin + f_qv, f_qc, f_qr, f_qi, f_qs, f_qg, & + tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao + gaer300,gaer400,gaer600,gaer999, & ! czhao + waer300,waer400,waer600,waer999, & ! czhao + aer_ra_feedback, & +!jdfcz progn,prescribe, & + progn, & + qndrop3d,f_qndrop, & !czhao + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + swupflx, swupflxc, swdnflx, swdnflxc, & + tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw, & ! jararias 2013/11 + swddir, swddni, swddif, & ! jararias 2013/08 + xcoszen,julian & ! jararias 2013/08 + ) +!------------------------------------------------------------------ + IMPLICIT NONE +!------------------------------------------------------------------ + LOGICAL, INTENT(IN ) :: warm_rain + LOGICAL, INTENT(IN ) :: is_CAMMGMP_used ! Added for CAM5 RRTMG<->CAMMGMP +! + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + + INTEGER, INTENT(IN ) :: ICLOUD +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(IN ) :: dz8w, & + t3d, & + t8w, & + p3d, & + p8w, & + pi3d, & + rho3d + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RTHRATENSW + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: GSW, & + SWCF, & + COSZR + + INTEGER, INTENT(IN ) :: JULDAY + REAL, INTENT(IN ) :: RADT,DEGRAD, & + XTIME,DECLIN,SOLCON,GMT + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(IN ) :: XLAT, & + XLONG, & + XLAND, & + XICE, & + SNOW, & + TSK, & + ALBEDO +! +!!! ------------------- Zhenxin (2011-06/20) ------------------ + REAL, DIMENSION( ims:ime, jms:jme ) , & + OPTIONAL , & + INTENT(IN) :: ALSWVISDIR, & ! ssib albedo of sw and lw + ALSWVISDIF, & + ALSWNIRDIR, & + ALSWNIRDIF + + REAL, DIMENSION( ims:ime, jms:jme ) , & + OPTIONAL , & + INTENT(OUT) :: SWVISDIR, & + SWVISDIF, & + SWNIRDIR, & + SWNIRDIF ! ssib sw dir and diff rad + INTEGER, INTENT(IN) :: sf_surface_physics ! ssib para + +! ----------------------- end Zhenxin -------------------------- +! + +! ------------------------ jararias 2013/08/10 ----------------- + real, dimension(ims:ime,jms:jme), intent(out) :: & + swddir, & ! All-sky broadband surface direct horiz irradiance + swddni, & ! All-sky broadband surface direct normal irradiance + swddif ! All-sky broadband surface diffuse irradiance + real, optional, intent(in) :: & + julian ! julian day (1-366) + real, dimension(ims:ime,jms:jme), optional, intent(in) :: & + xcoszen ! cosine of the solar zenith angle + real, dimension(ims:ime,kms:kme,jms:jme,nbndsw), optional, & + intent(in) :: tauaer3d_sw, & + ssaaer3d_sw, & + asyaer3d_sw +! ------------------------ jararias end snippet ----------------- + + + REAL, INTENT(IN ) :: R,G +! +! Optional +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: & + CLDFRA3D, & + LRADIUS, & + IRADIUS, & + QV3D, & + QC3D, & + QR3D, & + QI3D, & + QS3D, & + QG3D, & + QNDROP3D + +!..Added by G. Thompson to couple cloud physics effective radii. + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: & + RE_CLOUD, & + RE_ICE, & + RE_SNOW + INTEGER, INTENT(IN):: has_reqc, has_reqi, has_reqs + + real pi,third,relconst,lwpmin,rhoh2o + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: & + F_ICE_PHY, & + F_RAIN_PHY + + LOGICAL, OPTIONAL, INTENT(IN) :: & + F_QV,F_QC,F_QR,F_QI,F_QS,F_QG,F_QNDROP + +! Optional + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & + INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! czhao + gaer300,gaer400,gaer600,gaer999, & ! czhao + waer300,waer400,waer600,waer999 ! czhao + + INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback +!jdfcz INTEGER, INTENT(IN ), OPTIONAL :: progn,prescribe + INTEGER, INTENT(IN ), OPTIONAL :: progn +! Ozone + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + OPTIONAL , & + INTENT(IN ) :: O33D + INTEGER, OPTIONAL, INTENT(IN ) :: o3input +! EC aerosol: no_src = naerec = 6 + INTEGER, INTENT(IN ) :: no_src + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:no_src ) , & + OPTIONAL , & + INTENT(IN ) :: aerod + INTEGER, OPTIONAL, INTENT(IN ) :: aer_opt + +!wavelength corresponding to wavenum1 and wavenum2 (cm-1) + real, save :: wavemin(nbndsw) ! Min wavelength (um) of 14 intervals + data wavemin /3.077,2.500,2.150,1.942,1.626,1.299, & + 1.242,0.778,0.625,0.442,0.345,0.263,0.200,3.846/ + real, save :: wavemax(nbndsw) ! Max wavelength (um) of interval + data wavemax/3.846,3.077,2.500,2.150,1.942,1.626, & + 1.299,1.242,0.778,0.625,0.442,0.345,0.263,12.195/ + real wavemid(nbndsw) ! Mid wavelength (um) of interval + real, parameter :: thresh=1.e-9 + real ang,slope + character(len=200) :: msg + +! Top of atmosphere and surface shortwave fluxes (W m-2) + REAL, DIMENSION( ims:ime, jms:jme ), & + OPTIONAL, INTENT(INOUT) :: & + SWUPT,SWUPTC,SWDNT,SWDNTC, & + SWUPB,SWUPBC,SWDNB,SWDNBC + +! Layer shortwave fluxes (including extra layer above model top) +! Vertical ordering is from bottom to top (W m-2) + REAL, DIMENSION( ims:ime, kms:kme+2, jms:jme ), & + OPTIONAL, INTENT(OUT) :: & + SWUPFLX,SWUPFLXC,SWDNFLX,SWDNFLXC + +! LOCAL VARS + + REAL, DIMENSION( kts:kte+1 ) :: Pw1D, & + Tw1D + + REAL, DIMENSION( kts:kte ) :: TTEN1D, & + CLDFRA1D, & + DZ1D, & + P1D, & + T1D, & + QV1D, & + QC1D, & + QR1D, & + QI1D, & + QS1D, & + QG1D, & + O31D, & + qndrop1d + +! Added local arrays for RRTMG + integer :: ncol, & + nlay, & + icld, & + iaer, & + inflgsw, & + iceflgsw, & + liqflgsw +! Dimension with extra layer from model top to TOA + real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+2 ) :: plev, & + tlev + real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1 ) :: play, & + tlay, & + h2ovmr, & + o3vmr, & + co2vmr, & + o2vmr, & + ch4vmr, & + n2ovmr + real, dimension( kts:kte+1 ) :: o3mmr +! Surface albedo (for UV/visible and near-IR spectral regions, +! and for direct and diffuse radiation) + real, dimension( (jte-jts+1)*(ite-its+1) ) :: asdir, & + asdif, & + aldir, & + aldif +! Dimension with extra layer from model top to TOA, +! though no clouds are allowed in extra layer + real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1 ) :: clwpth, & + ciwpth, & + cswpth, & + rel, & + rei, & + res, & + cldfrac +! cldfrac, & +! relqmcl, & +! reicmcl, & +! resnmcl + real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1, nbndsw ) :: taucld, & + ssacld, & + asmcld, & + fsfcld +! real, dimension( ngptsw, (jte-jts+1)*(ite-its+1), kts:kte+1 ) :: cldfmcl, & +! clwpmcl, & +! ciwpmcl, & +! cswpmcl, & +! taucmcl, & +! ssacmcl, & +! asmcmcl, & +! fsfcmcl + real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1, nbndsw ) :: tauaer, & + ssaaer, & + asmaer + real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1, naerec ) :: ecaer + +! Output arrays contain extra layer from model top to TOA + real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+2 ) :: swuflx, & + swdflx, & + swuflxc, & + swdflxc, & + sibvisdir, & ! Zhenxin 2011-06-20 + sibvisdif, & + sibnirdir, & + sibnirdif ! Zhenxin 2011-06-20 + + real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+2 ) :: swdkdir, & ! jararias, 2013/08/10 + swdkdif ! jararias, 2013/08/10 + + real, dimension( (jte-jts+1)*(ite-its+1), kts:kte+1 ) :: swhr, & + swhrc + + real, dimension ( (jte-jts+1)*(ite-its+1) ) :: tsfc, & + ps, & + coszen + real :: ro, & + dz, & + adjes, & + scon, & + snow_mass_factor + integer :: dyofyr + + integer:: idx_rei + real:: corr + +! Set trace gas volume mixing ratios, 2005 values, IPCC (2007) +! carbon dioxide (379 ppmv) + real :: co2 + data co2 / 379.e-6 / +! methane (1774 ppbv) + real :: ch4 + data ch4 / 1774.e-9 / +! nitrous oxide (319 ppbv) + real :: n2o + data n2o / 319.e-9 / +! Set oxygen volume mixing ratio (for o2mmr=0.23143) + real :: o2 + data o2 / 0.209488 / + + integer :: iplon, irng, permuteseed + integer :: nb + +! For old lw cloud property specification +! Cloud and precipitation absorption coefficients +! real :: abcw,abice,abrn,absn +! data abcw /0.144/ +! data abice /0.0735/ +! data abrn /0.330e-3/ +! data absn /2.34e-3/ + +! Molecular weights and ratios for converting mmr to vmr units +! real :: amd ! Effective molecular weight of dry air (g/mol) +! real :: amw ! Molecular weight of water vapor (g/mol) +! real :: amo ! Molecular weight of ozone (g/mol) +! real :: amo2 ! Molecular weight of oxygen (g/mol) +! Atomic weights for conversion from mass to volume mixing ratios +! data amd / 28.9660 / +! data amw / 18.0160 / +! data amo / 47.9998 / +! data amo2 / 31.9999 / + + real :: amdw ! Molecular weight of dry air / water vapor + real :: amdo ! Molecular weight of dry air / ozone + real :: amdo2 ! Molecular weight of dry air / oxygen + data amdw / 1.607793 / + data amdo / 0.603461 / + data amdo2 / 0.905190 / + +!! + real, dimension((jte-jts+1)*(ite-its+1), 1:kte-kts+1 ) :: pdel ! Layer pressure thickness (mb) + + real, dimension((jte-jts+1)*(ite-its+1), 1:kte-kts+1) :: cicewp, & ! in-cloud cloud ice water path + cliqwp, & ! in-cloud cloud liquid water path + csnowp, & ! in-cloud snow water path + reliq, & ! effective drop radius (microns) + reice ! ice effective drop size (microns) + real, dimension((jte-jts+1)*(ite-its+1), 1:kte-kts+1):: recloud1d, & + reice1d, & + resnow1d + real :: gliqwp, gicewp, gsnowp, gravmks + +! +! REAL :: TSFC,GLW0,OLR0,EMISS0,FP + REAL :: FP + +! real, dimension(1:ite-its+1 ) :: clat ! latitude in radians for columns + real :: coszrs ! Cosine of solar zenith angle for present latitude + logical :: dorrsw ! Flag to allow shortwave calculation + + real, dimension ((jte-jts+1)*(ite-its+1)) :: landfrac, landm, snowh, icefrac + + integer :: pcols, pver + integer :: icol + integer :: rpart + + REAL :: XT24, TLOCTM, HRANG, XXLAT + + INTEGER :: i,j,K, na + LOGICAL :: predicate + + REAL :: da, eot ! jararias, 14/08/2013 + + integer :: icnt + +! mji - write +! REAL, DIMENSION( ims:ime, jms:jme ) :: SWDB, SWUT + +!------------------------------------------------------------------ +#if ( WRF_CHEM == 1 ) + IF ( aer_ra_feedback == 1) then + IF ( .NOT. & + ( PRESENT(tauaer300) .AND. & + PRESENT(tauaer400) .AND. & + PRESENT(tauaer600) .AND. & + PRESENT(tauaer999) .AND. & + PRESENT(gaer300) .AND. & + PRESENT(gaer400) .AND. & + PRESENT(gaer600) .AND. & + PRESENT(gaer999) .AND. & + PRESENT(waer300) .AND. & + PRESENT(waer400) .AND. & + PRESENT(waer600) .AND. & + PRESENT(waer999) ) ) THEN + CALL wrf_error_fatal & + ('Warning: missing fields required for aerosol radiation' ) + ENDIF + ENDIF +#endif + +! Initial value of number of columns per partition; +! Use 2 for CPU; for GPU set to 0 here to allow selection +! of appropriate value in rrtmg_sw +#ifdef _ACCEL + rpart = 0 +#else + rpart = CHNK +#endif + + +!-----CALCULATE SHORT WAVE RADIATION +! +! All fields are ordered vertically from bottom to top +! Pressures are in mb + +! jararias, 14/08/2013 + if (present(xcoszen)) then + call wrf_debug(100,'coszen from radiation driver') + end if + +! Number of columns to process + ncol = (jte-jts+1)*(ite-its+1) + + icnt = 0 +! latitude loop + j_loop: do j = jts,jte + +! longitude loop + i_loop: do i = its,ite +! + icol = i-its+1 + (j-jts)*(ite-its+1) + +! Do shortwave by default, deactivate below if sun below horizon + dorrsw = .true. + +! Cosine solar zenith angle for current time step +! +! xt24 is the fractional part of simulation days plus half of radt expressed in +! units of minutes +! julian is in days +! radt is in minutes +! jararias, 14/08/2013 + if (present(xcoszen)) then + coszr(i,j)=xcoszen(i,j) + coszrs=xcoszen(i,j) + else +! da=6.2831853071795862*(julian-1)/365. +! eot=(0.000075+0.001868*cos(da)-0.032077*sin(da) & +! -0.014615*cos(2*da)-0.04089*sin(2*da))*(229.18) + xt24 = mod(xtime+radt*0.5,1440.)+eot + tloctm = gmt + xt24/60. + xlong(i,j)/15. + hrang = 15. * (tloctm-12.) * degrad + xxlat = xlat(i,j) * degrad + coszrs = sin(xxlat) * sin(declin) & + + cos(xxlat) * cos(declin) * cos(hrang) + coszr(i,j) = coszrs + end if + +! mji - count daytime points to not process fully nighttime scenes + if (coszrs .gt. 0.0) icnt = icnt + 1 + +! Set flag to prevent shortwave calculation when sun below horizon +! mji - must set up input everywhere to run model at all grid points on +! GPU when any daytime points present +! if (coszrs.le.0.0) dorrsw = .false. + +! Perform shortwave calculation if sun above horizon + if (dorrsw) then + + do k=kts,kte+1 + Pw1D(K) = p8w(I,K,J)/100. + Tw1D(K) = t8w(I,K,J) + enddo + + DO K=kts,kte + QV1D(K)=0. + QC1D(K)=0. + QR1D(K)=0. + QI1D(K)=0. + QS1D(K)=0. + CLDFRA1D(k)=0. + QNDROP1D(k)=0. + ENDDO + + DO K=kts,kte + QV1D(K)=QV3D(I,K,J) + QV1D(K)=max(0.,QV1D(K)) + ENDDO + + IF (PRESENT(O33D)) THEN + DO K=kts,kte + O31D(K)=O33D(I,K,J) + ENDDO + ELSE + DO K=kts,kte + O31D(K)=0.0 + ENDDO + ENDIF + + DO K=kts,kte + TTEN1D(K)=0. + T1D(K)=t3d(I,K,J) + P1D(K)=p3d(I,K,J)/100. + DZ1D(K)=dz8w(I,K,J) + ENDDO + +! moist variables + + IF (ICLOUD .ne. 0) THEN + IF ( PRESENT( CLDFRA3D ) ) THEN + DO K=kts,kte + CLDFRA1D(k)=CLDFRA3D(I,K,J) + ENDDO + ENDIF + + IF (PRESENT(F_QC) .AND. PRESENT(QC3D)) THEN + IF ( F_QC) THEN + DO K=kts,kte + QC1D(K)=QC3D(I,K,J) + QC1D(K)=max(0.,QC1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QR) .AND. PRESENT(QR3D)) THEN + IF ( F_QR) THEN + DO K=kts,kte + QR1D(K)=QR3D(I,K,J) + QR1D(K)=max(0.,QR1D(K)) + ENDDO + ENDIF + ENDIF + + IF ( PRESENT(F_QNDROP).AND.PRESENT(QNDROP3D)) THEN + IF (F_QNDROP) THEN + DO K=kts,kte + qndrop1d(K)=qndrop3d(I,K,J) + ENDDO + ENDIF + ENDIF + +! This logic is tortured because cannot test F_QI unless +! it is present, and order of evaluation of expressions +! is not specified in Fortran + + IF ( PRESENT ( F_QI ) ) THEN + predicate = F_QI + ELSE + predicate = .FALSE. + ENDIF + +! For MP option 3 + IF (.NOT. predicate .and. .not. warm_rain) THEN + DO K=kts,kte + IF (T1D(K) .lt. 273.15) THEN + QI1D(K)=QC1D(K) + QS1D(K)=QR1D(K) + QC1D(K)=0. + QR1D(K)=0. + ENDIF + ENDDO + ENDIF + + IF (PRESENT(F_QI) .AND. PRESENT(QI3D)) THEN + IF (F_QI) THEN + DO K=kts,kte + QI1D(K)=QI3D(I,K,J) + QI1D(K)=max(0.,QI1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QS) .AND. PRESENT(QS3D)) THEN + IF (F_QS) THEN + DO K=kts,kte + QS1D(K)=QS3D(I,K,J) + QS1D(K)=max(0.,QS1D(K)) + ENDDO + ENDIF + ENDIF + + IF (PRESENT(F_QG) .AND. PRESENT(QG3D)) THEN + IF (F_QG) THEN + DO K=kts,kte + QG1D(K)=QG3D(I,K,J) + QG1D(K)=max(0.,QG1D(K)) + ENDDO + ENDIF + ENDIF + +! mji - For MP option 5 + IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) .and. PRESENT(F_ICE_PHY) ) THEN + IF ( F_QC .and. .not. F_QI .and. F_QS ) THEN + DO K=kts,kte + qi1d(k) = 0.1*qs3d(i,k,j) + qs1d(k) = 0.9*qs3d(i,k,j) + qc1d(k) = qc3d(i,k,j) + qi1d(k) = max(0.,qi1d(k)) + qc1d(k) = max(0.,qc1d(k)) + ENDDO + ENDIF + ENDIF + + ENDIF + +! EMISS0=EMISS(I,J) +! GLW0=0. +! OLR0=0. +! TSFC=TSK(I,J) + DO K=kts,kte + QV1D(K)=AMAX1(QV1D(K),1.E-12) + ENDDO + +! Set up input for shortwave +! ncol = 1 +! Add extra layer from top of model to top of atmosphere + nlay = (kte - kts + 1) + 1 + +! Select cloud liquid and ice optics parameterization options +! For passing in cloud optical properties directly: +! icld = 2 +! inflgsw = 0 +! iceflgsw = 0 +! liqflgsw = 0 +! For passing in cloud physical properties; cloud optics parameterized in RRTMG: + icld = 2 + inflgsw = 2 + iceflgsw = 3 + liqflgsw = 1 + +!Mukul change the flags here with reference to the new effective cloud/ice/snow radius + IF (ICLOUD .ne. 0) THEN + IF ( has_reqc .ne. 0) THEN + inflgsw = 3 + DO K=kts,kte + recloud1D(icol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6) + if (recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean + recloud1D(icol,K) = 10.5 + elseif (recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & + & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land + recloud1D(icol,K) = 7.5 + endif + ENDDO + ELSE + DO K=kts,kte + recloud1D(icol,K) = 5.0 + ENDDO + ENDIF + + IF ( has_reqi .ne. 0) THEN + inflgsw = 4 + iceflgsw = 4 + DO K=kts,kte + reice1D(icol,K) = MAX(10., re_ice(I,K,J)*1.E6) + if (reice1D(icol,K).LE.10..AND.cldfra3d(i,k,j).gt.0.) then + idx_rei = int(t3d(i,k,j)-179.) + idx_rei = min(max(idx_rei,1),75) + corr = t3d(i,k,j) - int(t3d(i,k,j)) + reice1D(icol,K) = retab(idx_rei)*(1.-corr) + & + & retab(idx_rei+1)*corr + reice1D(icol,K) = MAX(reice1D(icol,K), 10.0) + endif + ENDDO + ELSE + DO K=kts,kte + reice1D(icol,K) = 10.0 + ENDDO + ENDIF + + IF ( has_reqs .ne. 0) THEN + inflgsw = 5 + iceflgsw = 5 + DO K=kts,kte + resnow1D(icol,K) = MAX(10., re_snow(I,K,J)*1.E6) + ENDDO + ELSE + DO K=kts,kte + resnow1D(icol,K) = 10. + ENDDO + ENDIF + ENDIF + +! Set cosine of solar zenith angle + coszen(icol) = coszrs +! Set solar constant + scon = solcon +! For Earth/Sun distance adjustment in RRTMG +! dyofyr = julday +! adjes = 0.0 +! For WRF, solar constant is already provided with eccentricity adjustment, +! so do not do this in RRTMG + dyofyr = 0 + adjes = 1.0 + +! Layer indexing goes bottom to top here for all fields. +! Water vapor and ozone are converted from mmr to vmr. +! Pressures are in units of mb here. + plev(icol,1) = pw1d(1) + tlev(icol,1) = tw1d(1) + tsfc(icol) = tsk(i,j) + do k = kts, kte + play(icol,k) = p1d(k) + plev(icol,k+1) = pw1d(k+1) + pdel(icol,k) = plev(icol,k) - plev(icol,k+1) + tlay(icol,k) = t1d(k) + tlev(icol,k+1) = tw1d(k+1) + h2ovmr(icol,k) = qv1d(k) * amdw + co2vmr(icol,k) = co2 + o2vmr(icol,k) = o2 + ch4vmr(icol,k) = ch4 + n2ovmr(icol,k) = n2o + enddo + +! Define profile values for extra layer from model top to top of atmosphere. +! The top layer temperature for all gridpoints is set to the top layer-1 +! temperature plus a constant (0 K) that represents an isothermal layer +! above ptop. Top layer interface temperatures are linearly interpolated +! from the layer temperatures. + + play(icol,kte+1) = 0.5 * plev(icol,kte+1) + tlay(icol,kte+1) = tlev(icol,kte+1) + 0.0 + plev(icol,kte+2) = 1.0e-5 + tlev(icol,kte+2) = tlev(icol,kte+1) + 0.0 + tlev(icol,kte+2) = tlev(icol,kte+1) + 0.0 + h2ovmr(icol,kte+1) = h2ovmr(icol,kte) + co2vmr(icol,kte+1) = co2vmr(icol,kte) + o2vmr(icol,kte+1) = o2vmr(icol,kte) + ch4vmr(icol,kte+1) = ch4vmr(icol,kte) + n2ovmr(icol,kte+1) = n2ovmr(icol,kte) + +! Get ozone profile including amount in extra layer above model top +! call inirad (o3mmr,plev,kts,kte) + call inirad (o3mmr,plev(icol,:),kts,kte) + + if(present(o33d)) then + do k = kts, kte+1 + o3vmr(icol,k) = o3mmr(k) * amdo + IF ( PRESENT( O33D ) ) THEN + if(o3input .eq. 2)then + if(k.le.kte)then + o3vmr(icol,k) = o31d(k) + else +! apply shifted climatology profile above model top + o3vmr(icol,k) = o31d(kte) - o3mmr(kte)*amdo + o3mmr(k)*amdo + if(o3vmr(icol,k) .le. 0.)o3vmr(icol,k) = o3mmr(k)*amdo + endif + endif + ENDIF + enddo + else + do k = kts, kte+1 + o3vmr(icol,k) = o3mmr(k) * amdo + enddo + endif + +! Set surface albedo for direct and diffuse radiation in UV/visible and +! near-IR spectral regions +! -------------- Zhenxin 2011-06-20 ----------- ! + +! ------- 1. Commented by Zhenxin 2011-06-20 for SSiB coupling modified ---- ! +! asdir(icol) = albedo(i,j) +! asdif(icol) = albedo(i,j) +! aldir(icol) = albedo(i,j) +! aldif(icol) = albedo(i,j) +! ------- End of Comments ------ ! + +! ------- 2. New Addition ------ ! + IF ( sf_surface_physics .eq. 8 .AND. XLAND(i,j) .LT. 1.5) THEN + asdir(icol) = ALSWVISDIR(I,J) + asdif(icol) = ALSWVISDIF(I,J) + aldir(icol) = ALSWNIRDIR(I,J) + aldif(icol) = ALSWNIRDIF(I,J) + ELSE + asdir(icol) = albedo(i,j) + asdif(icol) = albedo(i,j) + aldir(icol) = albedo(i,j) + aldif(icol) = albedo(i,j) + ENDIF + +! ---------- End of Addition ------! +! ---------- End of fds_Zhenxin 2011-06-20 --------------! + +! Define cloud optical properties for radiation (inflgsw = 0) +! This option is not currently active +! Cloud and precipitation paths in g/m2 +! qi=0 if no ice phase +! qs=0 if no ice phase + if (inflgsw .eq. 0) then + +! Set cloud fraction and cloud optical properties here; not yet active + do k = kts, kte + cldfrac(icol,k) = cldfra1d(k) + do nb = 1, nbndsw + taucld(icol,k,nb) = 0.0 + ssacld(icol,k,nb) = 1.0 + asmcld(icol,k,nb) = 0.0 + fsfcld(icol,k,nb) = 0.0 + enddo + enddo + +! Zero out cloud physical property arrays; not used when passing optical properties +! into radiation + do k = kts, kte + clwpth(icol,k) = 0.0 + ciwpth(icol,k) = 0.0 + rel(icol,k) = 10.0 + rei(icol,k) = 10. + enddo + endif + +! Define cloud physical properties for radiation (inflgsw = 1 or 2) +! Cloud fraction +! Set cloud arrays if passing cloud physical properties into radiation + if (inflgsw .gt. 0) then + do k = kts, kte + cldfrac(icol,k) = cldfra1d(k) + enddo + +! Compute cloud water/ice paths and particle sizes for input to radiation (CAM method) + pcols = ncol + pver = kte - kts + 1 + gravmks = g + landfrac(icol) = 2.-XLAND(I,J) + landm(icol) = landfrac(icol) + snowh(icol) = 0.001*SNOW(I,J) + icefrac(icol) = XICE(I,J) + +! From module_ra_cam: Convert liquid and ice mixing ratios to water paths; +! pdel is in mb here; convert back to Pa (*100.) +! Water paths are in units of g/m2 +! snow added as ice cloud (JD 091022) + do k = kts, kte + gicewp = (qi1d(k)+qs1d(k)) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path. + gliqwp = qc1d(k) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box liquid water path. + cicewp(icol,k) = gicewp / max(0.01,cldfrac(icol,k)) ! In-cloud ice water path. + cliqwp(icol,k) = gliqwp / max(0.01,cldfrac(icol,k)) ! In-cloud liquid water path. + end do + +! Mukul +!..The ice water path is already sum of cloud ice and snow, but when we have explicit +!.. ice effective radius, overwrite the ice path with only the cloud ice variable, +!.. leaving out the snow for its own effect. + if(iceflgsw.ge.4)then + do k = kts, kte + gicewp = qi1d(k) * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box ice water path. + cicewp(icol,k) = gicewp / max(0.01,cldfrac(icol,k)) ! In-cloud ice water path. + end do + end if + +!..Here the snow path is adjusted if (radiation) effective radius of snow is +!.. larger than what we currently have in the lookup tables. Since mass goes +!.. rather close to diameter squared, adjust the mixing ratio of snow used +!.. to compute its water path in combination with the max diameter. Not a +!.. perfect fix, but certainly better than using all snow mass when diameter is +!.. far larger than table currently contains and crystal sizes much larger than +!.. about 140 microns have lesser impact than those much smaller sizes. + + if(iceflgsw.eq.5)then + do k = kts, kte + snow_mass_factor = 1.0 + if (resnow1d(icol,k) .gt. 130.)then + snow_mass_factor = (130.0/resnow1d(icol,k))*(130.0/resnow1d(icol,k)) + resnow1d(icol,k) = 130.0 + endif + gsnowp = qs1d(k) * snow_mass_factor * pdel(icol,k)*100.0 / gravmks * 1000.0 ! Grid box snow water path. + csnowp(icol,k) = gsnowp / max(0.01,cldfrac(icol,k)) + end do + end if + + +!link the aerosol feedback to cloud -czhao + if( PRESENT( progn ) ) then + if (progn == 1) then +!jdfcz if(prescribe==0) then + + pi = 4.*atan(1.0) + third=1./3. + rhoh2o=1.e3 + relconst=3/(4.*pi*rhoh2o) +! minimun liquid water path to calculate rel +! corresponds to optical depth of 1.e-3 for radius 4 microns. + lwpmin=3.e-5 + do k = kts, kte + reliq(icol,k) = 10. + if( PRESENT( F_QNDROP ) ) then + if( F_QNDROP ) then + if ( qc1d(k)*pdel(icol,k).gt.lwpmin.and. & + qndrop1d(k).gt.1000. ) then + reliq(icol,k)=(relconst*qc1d(k)/qndrop1d(k))**third ! effective radius in m +! apply scaling from Martin et al., JAS 51, 1830. + reliq(icol,k)=1.1*reliq(icol,k) + reliq(icol,k)=reliq(icol,k)*1.e6 ! convert from m to microns + reliq(icol,k)=max(reliq(icol,k),4.) + reliq(icol,k)=min(reliq(icol,k),20.) + end if + end if + end if + end do +!jdfcz else ! prescribe +! following Kiehl +! call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) +! write(0,*) 'sw prescribe aerosol',maxval(qndrop3d) +!jdfcz endif + else ! progn (progn=1) + call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) + endif + else !progn (PRESENT) + call relcalc(icol, pcols, pver, tlay, landfrac, landm, icefrac, reliq, snowh) + endif + +! following Kristjansson and Mitchell + call reicalc(icol, pcols, pver, tlay, reice) + + + +!..If we already have effective radius of cloud and ice, then just overwrite what +!.. was computed in the relcalc and reicalc subroutines above. + + if (inflgsw .ge. 3) then + do k = kts, kte + reliq(icol,k) = recloud1d(icol,k) + end do + endif + if (iceflgsw .ge. 4) then + do k = kts, kte + reice(icol,k) = reice1d(icol,k) + end do + endif + + +! Limit upper bound of reice for Fu ice parameterization and convert +! from effective radius to generalized effective size (*1.0315; Fu, 1996) + if (iceflgsw .eq. 3) then + do k = kts, kte + reice(icol,k) = reice(icol,k) * 1.0315 + reice(icol,k) = min(140.0,reice(icol,k)) + end do + endif + +!if CAMMGMP is used, use output from CAMMGMP +!PMA + if(is_CAMMGMP_used) then + do k = kts, kte + if ( qi1d(k) .gt. 1.e-20 .or. qs1d(k) .gt. 1.e-20) then + reice(icol,k) = iradius(i,k,j) + else + reice(icol,k) = 25. + end if + reice(icol,k) = max(5., min(140.0,reice(icol,k))) + if ( qc1d(k) .gt. 1.e-20) then + reliq(icol,k) = lradius(i,k,j) + else + reliq(icol,k) = 10. + end if + reliq(icol,k) = max(2.5, min(60.0,reliq(icol,k))) + enddo + endif + +! Set cloud physical property arrays + do k = kts, kte + clwpth(icol,k) = cliqwp(icol,k) + ciwpth(icol,k) = cicewp(icol,k) + rel(icol,k) = reliq(icol,k) + rei(icol,k) = reice(icol,k) + enddo + +!Mukul + if (inflgsw .eq. 5) then + do k = kts, kte + cswpth(icol,k) = csnowp(icol,k) + res(icol,k) = resnow1d(icol,k) + end do + else + do k = kts, kte + cswpth(icol,k) = 0.0 + res(icol,k) = 10.0 + end do + endif + +! Zero out cloud optical properties here, calculated in radiation + do k = kts, kte + do nb = 1, nbndsw + taucld(icol,k,nb) = 0.0 + ssacld(icol,k,nb) = 1.0 + asmcld(icol,k,nb) = 0.0 + fsfcld(icol,k,nb) = 0.0 + enddo + enddo + endif + +! No clouds are allowed in the extra layer from model top to TOA + clwpth(icol,kte+1) = 0. + ciwpth(icol,kte+1) = 0. + cswpth(icol,kte+1) = 0. + rel(icol,kte+1) = 10. + rei(icol,kte+1) = 10. + res(icol,kte+1) = 10. + cldfrac(icol,kte+1) = 0. + do nb = 1, nbndsw + taucld(icol,kte+1,nb) = 0. + ssacld(icol,kte+1,nb) = 1. + asmcld(icol,kte+1,nb) = 0. + fsfcld(icol,kte+1,nb) = 0. + enddo + +! mji - mcica sub-column generator called inside rrtmg_sw for gpu +! iplon = 1 +! irng = 0 +! permuteseed = 1 +! Sub-column generator for McICA +! call mcica_subcol_sw(iplon, icol, nlay, icld, permuteseed, irng, play, & +! cldfrac, ciwpth, clwpth, cswpth, rei, rel, res, taucld, ssacld, asmcld, fsfcld, & +! cldfmcl, ciwpmcl, clwpmcl, cswpmcl, reicmcl, relqmcl, resnmcl, & +! taucmcl, ssacmcl, asmcmcl, fsfcmcl) + +!-------------------------------------------------------------------------- +! Aerosol optical depth, single scattering albedo and asymmetry parameter -czhao 03/2010 +!-------------------------------------------------------------------------- +! by layer for each RRTMG shortwave band +! No aerosols in top layer above model top (kte+1). +!cz do nb = 1, nbndsw +!cz do k = kts, kte+1 +!cz tauaer(icol,k,nb) = 0. +!cz ssaaer(icol,k,nb) = 1. +!cz asmaer(icol,k,nb) = 0. +!cz enddo +!cz enddo + +! ... Aerosol effects. Added aerosol feedbacks from Chem , 03/2010 -czhao +! + do nb = 1, nbndsw + do k = kts,kte+1 + tauaer(icol,k,nb) = 0. + ssaaer(icol,k,nb) = 1. + asmaer(icol,k,nb) = 0. + end do + end do + + if ( present (tauaer3d_sw) ) then +! ---- jararias 11/2012 + if ( aer_opt .eq. 2) then + do nb=1,nbndsw + do k=kts,kte + tauaer(icol,k,nb)=tauaer3d_sw(i,k,j,nb) + ssaaer(icol,k,nb)=ssaaer3d_sw(i,k,j,nb) + asmaer(icol,k,nb)=asyaer3d_sw(i,k,j,nb) + end do + end do + end if + end if + +#if ( WRF_CHEM == 1 ) + IF ( AER_RA_FEEDBACK == 1) then + do nb = 1, nbndsw + wavemid(nb)=0.5*(wavemin(nb)+wavemax(nb)) ! um + do k = kts,kte !wig + +! convert optical properties at 300,400,600, and 999 to conform to the band wavelengths +! tauaer - use angstrom exponent + if(tauaer300(i,k,j).gt.thresh .and. tauaer999(i,k,j).gt.thresh) then + ang=alog(tauaer300(i,k,j)/tauaer999(i,k,j))/alog(999./300.) + tauaer(icol,k,nb)=tauaer400(i,k,j)*(0.4/wavemid(nb))**ang + !tauaer(icol,k,nb)=tauaer600(i,k,j)*(0.6/wavemid(nb))**ang +!jm TODO need to fix these so they are not writing to stderr, stdout 20141218 + if (i==30.and.j==49.and.k==2.and.nb==12) then + write(0,*) 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j) + print*, 'TAU from 600 vs 400 in RRTMG',tauaer600(i,k,j),tauaer400(i,k,j) + write(0,*) tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang + print*, tauaer600(i,k,j)*(0.6/wavemid(nb))**ang,tauaer400(i,k,j)*(0.4/wavemid(nb))**ang + endif +! ssa - linear interpolation; extrapolation + slope=(waer600(i,k,j)-waer400(i,k,j))/.2 + ssaaer(icol,k,nb) = slope*(wavemid(nb)-.6)+waer600(i,k,j) + if(ssaaer(icol,k,nb).lt.0.4) ssaaer(icol,k,nb)=0.4 + if(ssaaer(icol,k,nb).ge.1.0) ssaaer(icol,k,nb)=1.0 +! g - linear interpolation;extrapolation + slope=(gaer600(i,k,j)-gaer400(i,k,j))/.2 + asmaer(icol,k,nb) = slope*(wavemid(nb)-.6)+gaer600(i,k,j) ! notice reversed varaibles + if(asmaer(icol,k,nb).lt.0.5) asmaer(icol,k,nb)=0.5 + if(asmaer(icol,k,nb).ge.1.0) asmaer(icol,k,nb)=1.0 + endif + end do ! k + end do ! nb + +!wig beg + do nb = 1, nbndsw + slope = 0. !use slope as a sum holder + do k = kts,kte + slope = slope + tauaer(icol,k,nb) + end do + if( slope < 0. ) then + write(msg,'("ERROR: Negative total optical depth of ",f8.2,& + " at point i,j,nb=",3i5)') slope,i,j,nb + call wrf_error_fatal(msg) + else if( slope > 6. ) then + call wrf_message("-------------------------") + write(msg,'("WARNING: Large total sw optical depth of ",f8.2,& + " at point i,j,nb=",3i5)') slope,i,j,nb + call wrf_message(msg) + + call wrf_message("Diagnostics 1: k, tauaer300, tauaer400,& + tauaer600, tauaer999, tauaer") + do k=kts,kte + write(msg,'(i4,5f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), & + tauaer600(i,k,j), tauaer999(i,k,j),tauaer(icol,k,nb) + call wrf_message(msg) + !czhao set an up-limit here to avoid segmentation fault + !from extreme AOD + tauaer(icol,k,nb)=tauaer(icol,k,nb)*6.0/slope + end do + + call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600,& + gaer999") + do k=kts,kte + write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), & + gaer600(i,k,j), gaer999(i,k,j) + call wrf_message(msg) + end do + + call wrf_message("Diagnostics 3: k, waer300, waer400, waer600,& + waer999") + do k=kts,kte + write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), & + waer600(i,k,j), waer999(i,k,j) + call wrf_message(msg) + end do + + call wrf_message("Diagnostics 4: k, ssaal, asyal, taual") + do k=kts-1,kte + write(msg,'(i4,3f8.2)') k, ssaaer(i,k,nb), asmaer(i,k,nb), tauaer(i,k,nb) + call wrf_message(msg) + end do + call wrf_message("-------------------------") + endif + enddo ! nb + endif ! aer_ra_feedback +#endif + + +! Zero array for input of aerosol optical thickness for use with +! ECMWF aerosol types (not used) + iaer = 0 + do na = 1, naerec + do k = kts, kte+1 + ecaer(icol,k,na) = 0. + enddo + enddo + + IF ( PRESENT( aerod ) ) THEN + if ( aer_opt .eq. 0 .or. aer_opt .eq. 2 ) then + iaer = 10 + do na = 1, naerec + do k = kts, kte+1 + ecaer(icol,k,na) = 0. + enddo + enddo + else if ( aer_opt .eq. 1 ) then + iaer = 6 + do na = 1, naerec + do k = kts, kte + ecaer(icol,k,na) = aerod(i,k,j,na) + enddo +! assuming 0 or same value at the top? +! ecaer(icol,kte+1,na) = ecaer(icol,kte,na) + ecaer(icol,kte+1,na) = 0. + enddo + endif + ENDIF +! +! End of dorrsw check + endif +! End of grid loops + enddo i_loop + enddo j_loop + +! Call RRTMG shortwave radiation model +! Perform shortwave calculation if sun above horizon in any part of grid +! Do not perform shortwave calculations if all of grid is in darkness + if (icnt .eq. 0) dorrsw = .false. + if (dorrsw) then + + call rrtmg_sw & + (rpart ,ncol ,nlay ,icld ,iaer , & + play ,plev ,tlay ,tlev ,tsfc , & + h2ovmr ,o3vmr ,co2vmr ,ch4vmr ,n2ovmr ,o2vmr , & + asdir ,asdif ,aldir ,aldif , & + coszen ,adjes ,dyofyr ,scon , & + inflgsw ,iceflgsw,liqflgsw,cldfrac , & + taucld ,ssacld ,asmcld ,fsfcld , & + ciwpth ,clwpth ,cswpth ,rei ,rel ,res, & + tauaer ,ssaaer ,asmaer ,ecaer , & + swuflx ,swdflx ,swhr ,swuflxc ,swdflxc ,swhrc, & +! ----- Zhenxin added for ssib coupiling 2011-06-20 --------! + sibvisdir, sibvisdif, sibnirdir, sibnirdif, & +! -------------------- End of addition by Zhenxin 2011-06-20 ------! + swdkdir, swdkdif & ! jararias, 2012/08/10 + ) + + endif + + +! Output net absorbed shortwave surface flux and shortwave cloud forcing +! at the top of atmosphere (W/m2) + +! latitude loop + j_loop2: do j = jts,jte +! longitude loop + i_loop2: do i = its,ite + +! Use calculated output only if in daylight, otherwise output is zero + dorrsw = .true. + if (coszr(i,j).le.0.0) dorrsw = .false. +! Complete shortwave calculation if sun above horizon + if (dorrsw) then + + if (present(xcoszen)) then + coszr(i,j)=xcoszen(i,j) + coszrs=xcoszen(i,j) + else + call wrf_error_fatal('xcoszen must be passed into RRTMG_SWRAD_FAST') + endif + + + icol = i-its+1 + (j-jts)*(ite-its+1) + + gsw(i,j) = swdflx(icol,1) - swuflx(icol,1) + swcf(i,j) = (swdflx(icol,kte+2) - swuflx(icol,kte+2)) - (swdflxc(icol,kte+2) - swuflxc(icol,kte+2)) + +! mji - write +! swut(i,j) = swuflx(icol,kte+2) +! swdb(i,j) = swdflx(icol,1) +! + if (present(swupt)) then +! Output up and down toa fluxes for total and clear sky + swupt(i,j) = swuflx(icol,kte+2) + swuptc(i,j) = swuflxc(icol,kte+2) + swdnt(i,j) = swdflx(icol,kte+2) + swdntc(i,j) = swdflxc(icol,kte+2) +! Output up and down surface fluxes for total and clear sky + swupb(i,j) = swuflx(icol,1) + swupbc(i,j) = swuflxc(icol,1) + swdnb(i,j) = swdflx(icol,1) +! Added by Zhenxin for 4 compenants of swdown radiation + swvisdir(i,j) = sibvisdir(icol,1) + swvisdif(i,j) = sibvisdif(icol,1) + swnirdir(i,j) = sibnirdir(icol,1) + swnirdif(i,j) = sibnirdif(icol,1) +! Ended, Zhenxin (2011/06/20) + swdnbc(i,j) = swdflxc(icol,1) + endif + swddir(i,j) = swdkdir(icol,1) ! jararias 2013/08/10 + swddni(i,j) = swddir(i,j) / coszrs ! jararias 2013/08/10 + swddif(i,j) = swdkdif(icol,1) ! jararias 2013/08/10 + +! Output up and down layer fluxes for total and clear sky. +! Vertical ordering is from bottom to top in units of W m-2. + if ( present (swupflx) ) then + do k=kts,kte+2 + swupflx(i,k,j) = swuflx(icol,k) + swupflxc(i,k,j) = swuflxc(icol,k) + swdnflx(i,k,j) = swdflx(icol,k) + swdnflxc(i,k,j) = swdflxc(icol,k) + enddo + endif + +! Output heating rate tendency; convert heating rate from K/d to K/s +! Heating rate arrays are ordered vertically from bottom to top here. + do k=kts,kte + tten1d(k) = swhr(icol,k)/86400. + rthratensw(i,k,j) = tten1d(k)/pi3d(i,k,j) + enddo + + else + if (present(swupt)) then +! Output up and down toa fluxes for total and clear sky + swupt(i,j) = 0. + swuptc(i,j) = 0. + swdnt(i,j) = 0. + swdntc(i,j) = 0. +! Output up and down surface fluxes for total and clear sky + swupb(i,j) = 0. + swupbc(i,j) = 0. + swdnb(i,j) = 0. + swdnbc(i,j) = 0. + swvisdir(i,j) = 0. ! Add by Zhenxin (2011/06/20) + swvisdif(i,j) = 0. + swnirdir(i,j) = 0. + swnirdif(i,j) = 0. ! Add by Zhenxin (2011/06/20) + endif + swddir(i,j) = 0. ! jararias 2013/08/10 + swddni(i,j) = 0. ! jararias 2013/08/10 + swddif(i,j) = 0. ! jararias 2013/08/10 + + endif + + end do i_loop2 + end do j_loop2 + +! mji - write +! do j=jts,jte +! write(62,995) (swut(i,j),i=its,ite) +! enddo +! do j=jts,jte +! write(62,995) (swdb(i,j),i=its,ite) +! enddo +! 995 format(1p6e12.5) + +!------------------------------------------------------------------- + + END SUBROUTINE RRTMG_SWRAD_FAST + + +!==================================================================== + SUBROUTINE rrtmg_swinit_fast( & + allowed_to_read , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + + LOGICAL , INTENT(IN) :: allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + +! Read in absorption coefficients and other data + IF ( allowed_to_read ) THEN + CALL rrtmg_swlookuptable + ENDIF + +! Perform g-point reduction and other initializations +! Specific heat of dry air (cp) used in flux to heating rate conversion factor. + call rrtmg_sw_ini(cp) + + END SUBROUTINE rrtmg_swinit_fast + + +! ************************************************************************** + SUBROUTINE rrtmg_swlookuptable +! ************************************************************************** + + IMPLICIT NONE + +! Local + INTEGER :: i + LOGICAL :: opened + LOGICAL , EXTERNAL :: wrf_dm_on_monitor + + CHARACTER*80 errmess + INTEGER rrtmg_unit + + IF ( wrf_dm_on_monitor() ) THEN + DO i = 10,99 + INQUIRE ( i , OPENED = opened ) + IF ( .NOT. opened ) THEN + rrtmg_unit = i + GOTO 2010 + ENDIF + ENDDO + rrtmg_unit = -1 + 2010 CONTINUE + ENDIF + CALL wrf_dm_bcast_bytes ( rrtmg_unit , IWORDSIZE ) + IF ( rrtmg_unit < 0 ) THEN + CALL wrf_error_fatal ( 'module_ra_rrtmg_swf: rrtm_swlookuptable: Can not '// & + 'find unused fortran unit to read in lookup table.' ) + ENDIF + + IF ( wrf_dm_on_monitor() ) THEN + OPEN(rrtmg_unit,FILE='RRTMG_SW_DATA', & + FORM='UNFORMATTED',STATUS='OLD',ERR=9009) + ENDIF + + call sw_kgb16(rrtmg_unit) + call sw_kgb17(rrtmg_unit) + call sw_kgb18(rrtmg_unit) + call sw_kgb19(rrtmg_unit) + call sw_kgb20(rrtmg_unit) + call sw_kgb21(rrtmg_unit) + call sw_kgb22(rrtmg_unit) + call sw_kgb23(rrtmg_unit) + call sw_kgb24(rrtmg_unit) + call sw_kgb25(rrtmg_unit) + call sw_kgb26(rrtmg_unit) + call sw_kgb27(rrtmg_unit) + call sw_kgb28(rrtmg_unit) + call sw_kgb29(rrtmg_unit) + + IF ( wrf_dm_on_monitor() ) CLOSE (rrtmg_unit) + + RETURN +9009 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error opening '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + END SUBROUTINE rrtmg_swlookuptable + +! ************************************************************************** +! RRTMG Shortwave Radiative Transfer Model +! Atmospheric and Environmental Research, Inc., Cambridge, MA +! +! Original by J.Delamere, Atmospheric & Environmental Research. +! Reformatted for F90: JJMorcrette, ECMWF +! Revision for GCMs: Michael J. Iacono, AER, July 2002 +! Further F90 reformatting: Michael J. Iacono, AER, June 2006 +! +! This file contains 14 READ statements that include the +! absorption coefficients and other data for each of the 14 shortwave +! spectral bands used in RRTMG_SW. Here, the data are defined for 16 +! g-points, or sub-intervals, per band. These data are combined and +! weighted using a mapping procedure in module RRTMG_SW_INIT to reduce +! the total number of g-points from 224 to 112 for use in the GCM. +! ************************************************************************** + +! ************************************************************************** + subroutine sw_kgb16(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg16_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat1, layreffr +! use rrsw_kg16_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl +! use rrtmg_sw_taumol, only : strrat1, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 2925 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + rayl, strrat1, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo + DM_BCAST_REAL(rayl) + DM_BCAST_REAL(strrat1) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb16 + +! ************************************************************************** + subroutine sw_kgb17(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg17_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat, layreffr +! use rrsw_kg17_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl +! use rrtmg_sw_taumol, only : strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 3625 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo + DM_BCAST_REAL(rayl) + DM_BCAST_REAL(strrat) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb17 + +! ************************************************************************** + subroutine sw_kgb18(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg18_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat, layreffr +! use rrsw_kg18_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl +! use rrtmg_sw_taumol, only : strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 4325 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo + DM_BCAST_REAL(rayl) + DM_BCAST_REAL(strrat) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb18 + +! ************************************************************************** + subroutine sw_kgb19(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg19_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat, layreffr +! use rrsw_kg19_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl +! use rrtmg_sw_taumol, only : strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 4900 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo + DM_BCAST_REAL(rayl) + DM_BCAST_REAL(strrat) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb19 + +! ************************************************************************** + subroutine sw_kgb20(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg20_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absch4o, rayl, layreffr +! use rrsw_kg20_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & +! absch4o, rayl +! use rrtmg_sw_taumol, only : layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 5670 cm-1. + +! Array absch4o contains the absorption coefficients for methane. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + rayl, layreffr, absch4o, kao, kbo, selfrefo, forrefo, sfluxrefo + DM_BCAST_REAL(rayl) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(absch4o) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb20 + +! ************************************************************************** + subroutine sw_kgb21(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg21_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat, layreffr +! use rrsw_kg21_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl +! use rrtmg_sw_taumol, only : strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 6925 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo + DM_BCAST_REAL(rayl) + DM_BCAST_REAL(strrat) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb21 + +! ************************************************************************** + subroutine sw_kgb22(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg22_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + rayl, strrat, layreffr +! use rrsw_kg22_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, rayl +! use rrtmg_sw_taumol, only : strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at v = 8000 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + rayl, strrat, layreffr, kao, kbo, selfrefo, forrefo, sfluxrefo + DM_BCAST_REAL(rayl) + DM_BCAST_REAL(strrat) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb22 + +! ************************************************************************** + subroutine sw_kgb23(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg23_f, only : kao, selfrefo, forrefo, sfluxrefo, & + raylo, givfac, layreffr +! use rrsw_kg23_f, only : kao, selfrefo, forrefo, sfluxrefo, raylo +! use rrtmg_sw_taumol, only : givfac, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array raylo contains the Rayleigh extinction coefficient at all v for this band + +! Array givfac is the average Giver et al. correction factor for this band. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + raylo, givfac, layreffr, kao, selfrefo, forrefo, sfluxrefo + DM_BCAST_MACRO(raylo) + DM_BCAST_REAL(givfac) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb23 + +! ************************************************************************** + subroutine sw_kgb24(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg24_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + raylao, raylbo, abso3ao, abso3bo, strrat, layreffr +! use rrsw_kg24_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & +! raylao, raylbo, abso3ao, abso3bo +! use rrtmg_sw_taumol, only : strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Arrays raylao and raylbo contain the Rayleigh extinction coefficient at +! all v for this band for the upper and lower atmosphere. + +! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at +! all v for this band for the upper and lower atmosphere. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + raylao, raylbo, strrat, layreffr, abso3ao, abso3bo, kao, kbo, selfrefo, & + forrefo, sfluxrefo + DM_BCAST_MACRO(raylao) + DM_BCAST_MACRO(raylbo) + DM_BCAST_REAL(strrat) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(abso3ao) + DM_BCAST_MACRO(abso3bo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb24 + +! ************************************************************************** + subroutine sw_kgb25(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg25_f, only : kao, sfluxrefo, & + raylo, abso3ao, abso3bo, layreffr +! use rrsw_kg25_f, only : kao, sfluxrefo, raylo, abso3ao, abso3bo +! use rrtmg_sw_taumol, only : layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1. + +! Arrays abso3ao and abso3bo contain the ozone absorption coefficient at +! all v for this band for the upper and lower atmosphere. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + raylo, layreffr, abso3ao, abso3bo, kao, sfluxrefo + DM_BCAST_MACRO(raylo) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(abso3ao) + DM_BCAST_MACRO(abso3bo) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb25 + +! ************************************************************************** + subroutine sw_kgb26(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg26_f, only : sfluxrefo, raylo + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array raylo contains the Rayleigh extinction coefficient at all v for this band. + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + raylo, sfluxrefo + DM_BCAST_MACRO(raylo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb26 + +! ************************************************************************** + subroutine sw_kgb27(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg27_f, only : kao, kbo, sfluxrefo, raylo, & + scalekur, layreffr +! use rrsw_kg27_f, only : kao, kbo, sfluxrefo, raylo +! use rrtmg_sw_taumol, only : scalekur, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. +! The values in array sfluxrefo were obtained using the "low resolution" +! version of the Kurucz solar source function. For unknown reasons, +! the total irradiance in this band differs from the corresponding +! total in the "high-resolution" version of the Kurucz function. +! Therefore, these values are scaled by the factor SCALEKUR. + +! Array raylo contains the Rayleigh extinction coefficient at all v = 2925 cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + raylo, scalekur, layreffr, kao, kbo, sfluxrefo + DM_BCAST_MACRO(raylo) + DM_BCAST_REAL(scalekur) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb27 + +! ************************************************************************** + subroutine sw_kgb28(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg28_f, only : kao, kbo, sfluxrefo, & + rayl, strrat, layreffr +! use rrsw_kg28_f, only : kao, kbo, sfluxrefo, rayl +! use rrtmg_sw_taumol, only : strrat, layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array raylo contains the Rayleigh extinction coefficient at all v = ???? cm-1. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + rayl, strrat, layreffr, kao, kbo, sfluxrefo + DM_BCAST_REAL(rayl) + DM_BCAST_REAL(strrat) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb28 + +! ************************************************************************** + subroutine sw_kgb29(rrtmg_unit) +! ************************************************************************** + + use rrsw_kg29_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & + absh2oo, absco2o, rayl, layreffr +! use rrsw_kg29_f, only : kao, kbo, selfrefo, forrefo, sfluxrefo, & +! absh2oo, absco2o, rayl +! use rrtmg_sw_taumol, only : layreffr + + implicit none + save + +! Input + integer, intent(in) :: rrtmg_unit + +! Local + character*80 errmess + logical, external :: wrf_dm_on_monitor + +! Array sfluxrefo contains the Kurucz solar source function for this band. + +! Array rayl contains the Rayleigh extinction coefficient at all v = 2200 cm-1. + +! Array absh2oo contains the water vapor absorption coefficient for this band. + +! Array absco2o contains the carbon dioxide absorption coefficient for this band. + +! The array KAO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels> ~100mb, temperatures, and binary +! species parameters (see taumol.f for definition). The first +! index in the array, JS, runs from 1 to 9, and corresponds to +! different values of the binary species parameter. For instance, +! JS=1 refers to dry air, JS = 2 corresponds to the paramter value 1/8, +! JS = 3 corresponds to the parameter value 2/8, etc. The second index +! in the array, JT, which runs from 1 to 5, corresponds to different +! temperatures. More specifically, JT = 3 means that the data are for +! the reference temperature TREF for this pressure level, JT = 2 refers +! to TREF-15, JT = 1 is for TREF-30, JT = 4 is for TREF+15, and JT = 5 +! is for TREF+30. The third index, JP, runs from 1 to 13 and refers +! to the JPth reference pressure level (see taumol.f for these levels +! in mb). The fourth index, IG, goes from 1 to 16, and indicates +! which g-interval the absorption coefficients are for. + +! The array KBO contains absorption coefs at the 16 chosen g-values +! for a range of pressure levels < ~100mb and temperatures. The first +! index in the array, JT, which runs from 1 to 5, corresponds to +! different temperatures. More specifically, JT = 3 means that the +! data are for the reference temperature TREF for this pressure +! level, JT = 2 refers to the temperature TREF-15, JT = 1 is for +! TREF-30, JT = 4 is for TREF+15, and JT = 5 is for TREF+30. +! The second index, JP, runs from 13 to 59 and refers to the JPth +! reference pressure level (see taumol.f for the value of these +! pressure levels in mb). The third index, IG, goes from 1 to 16, +! and tells us which g-interval the absorption coefficients are for. + +! The array FORREFO contains the coefficient of the water vapor +! foreign-continuum (including the energy term). The first +! index refers to reference temperature (296,260,224,260) and +! pressure (970,475,219,3 mbar) levels. The second index +! runs over the g-channel (1 to 16). + +! The array SELFREFO contains the coefficient of the water vapor +! self-continuum (including the energy term). The first index +! refers to temperature in 7.2 degree increments. For instance, +! JT = 1 refers to a temperature of 245.6, JT = 2 refers to 252.8, +! etc. The second index runs over the g-channel (1 to 16). + +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * RWORDSIZE ) +#define DM_BCAST_REAL(A) CALL wrf_dm_bcast_real ( A , 1 ) +#define DM_BCAST_INTEGER(A) CALL wrf_dm_bcast_integer ( A , 1 ) + + IF ( wrf_dm_on_monitor() ) READ (rrtmg_unit,ERR=9010) & + rayl, layreffr, absh2oo, absco2o, kao, kbo, selfrefo, forrefo, sfluxrefo + DM_BCAST_REAL(rayl) + DM_BCAST_INTEGER(layreffr) + DM_BCAST_MACRO(absh2oo) + DM_BCAST_MACRO(absco2o) + DM_BCAST_MACRO(kao) + DM_BCAST_MACRO(kbo) + DM_BCAST_MACRO(selfrefo) + DM_BCAST_MACRO(forrefo) + DM_BCAST_MACRO(sfluxrefo) + + RETURN +9010 CONTINUE + WRITE( errmess , '(A,I4)' ) 'module_ra_rrtmg_swf: error reading '// & + 'RRTMG_SW_DATA on unit ',rrtmg_unit + CALL wrf_error_fatal(errmess) + + end subroutine sw_kgb29 + +!------------------------------------------------------------------ + + END MODULE module_ra_rrtmg_swf diff --git a/wrfv2_fire/phys/module_radiation_driver.F b/wrfv2_fire/phys/module_radiation_driver.F index 8c33b0bc..1de41833 100644 --- a/wrfv2_fire/phys/module_radiation_driver.F +++ b/wrfv2_fire/phys/module_radiation_driver.F @@ -21,6 +21,7 @@ SUBROUTINE radiation_driver ( & ,AER_OPT, aerod & ,swint_opt & ,P8W ,P ,PI & + ,p_top & ,RADT ,RA_CALL_OFFSET & ,RHO ,RLWTOA & ,RSWTOA ,RTHRATEN & @@ -55,7 +56,7 @@ SUBROUTINE radiation_driver ( & , SLWDN, SLWUP & ! goddard schemes , TSWDN, TSWUP & ! goddard schemes , SSWDN, SSWUP & ! goddard schemes - , CLDFRA,CLDFRA_MP_ALL & + , CLDFRA,CLDFRA_MP_ALL,CLDT,ZNU & #if (EM_CORE == 1) , lradius,iradius & #endif @@ -115,6 +116,8 @@ SUBROUTINE radiation_driver ( & ,progn & ,slope_rad,topo_shading & ,shadowmask,ht,dx,dy & + ,dxkm & + ,diffuse_frac & ,SWUPFLX,SWUPFLXC,SWDNFLX,SWDNFLXC & ! Optional ,LWUPFLX,LWUPFLXC,LWDNFLX,LWDNFLXC & ! Optional ,radtacttime & @@ -139,6 +142,7 @@ SUBROUTINE radiation_driver ( & ! !USES: USE module_state_description, ONLY : RRTMSCHEME, GFDLLWSCHEME & ,RRTMG_LWSCHEME, RRTMG_SWSCHEME & + ,RRTMG_LWSCHEME_FAST, RRTMG_SWSCHEME_FAST & ,SWRADSCHEME, GSFCSWSCHEME & ,GFDLSWSCHEME, CAMLWSCHEME, CAMSWSCHEME & ,HELDSUAREZ & @@ -164,6 +168,8 @@ SUBROUTINE radiation_driver ( & USE module_ra_rrtm , ONLY : rrtmlwrad USE module_ra_rrtmg_lw , ONLY : rrtmg_lwrad USE module_ra_rrtmg_sw , ONLY : rrtmg_swrad + USE module_ra_rrtmg_lwf , ONLY : rrtmg_lwrad_fast + USE module_ra_rrtmg_swf , ONLY : rrtmg_swrad_fast USE module_ra_cam , ONLY : camrad USE module_ra_gfdleta , ONLY : etara #ifdef HWRF @@ -564,6 +570,11 @@ SUBROUTINE radiation_driver ( & TSWDN, TSWUP, & SSWDN, SSWUP ! for Goddard schemes +! Added by ZCX for low and total cloud fraction + REAL, DIMENSION( kms:kme ), OPTIONAL, INTENT(IN) :: znu ! eta values on half (mass)levels + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT) :: & + cldt + ! Optional (only used by CAM lw scheme) REAL, DIMENSION( ims:ime, kms:kme, cam_abs_dim2, jms:jme ), OPTIONAL ,& @@ -620,18 +631,25 @@ SUBROUTINE radiation_driver ( & OPTIONAL, & INTENT(INOUT) :: taucldi,taucldc + REAL, OPTIONAL, INTENT(IN) :: dxkm + ! Variables for slope-dependent radiation REAL, OPTIONAL, INTENT(IN) :: dx,dy INTEGER, OPTIONAL, INTENT(IN) :: slope_rad,topo_shading REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: ht INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: shadowmask + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(OUT) :: diffuse_frac REAL , OPTIONAL, INTENT(INOUT) :: radtacttime ! Storing the time in s when radiation is called next REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & OPTIONAL, & INTENT(INOUT) :: o3rad + ! vert nesting + REAL, OPTIONAL , INTENT(IN ) :: p_top + REAL :: p_top_dummy + ! LOCAL VAR REAL, DIMENSION( ims:ime, jms:jme ) :: GLAT,GLON @@ -652,10 +670,15 @@ SUBROUTINE radiation_driver ( & DJUL,RJUL,ECCFAC REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qi_temp,qc_temp REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qi_save,qc_save + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qs_save - REAL :: next_rad_time + REAL :: gridkm + + REAL :: next_rad_time, DTaccum LOGICAL :: run_param , doing_adapt_dt , decided LOGICAL :: flg_lw, flg_sw +!ZCX + REAL :: cldji,cldlji !ckay REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: cldfra_cu !------------------------------------------------------------------ @@ -672,6 +695,7 @@ SUBROUTINE radiation_driver ( & ! jararias 2013/11 real, dimension(:,:,:,:), allocatable :: tauaer_sw, ssaaer_sw, asyaer_sw + #ifdef HWRF CHARACTER(len=265) :: wrf_err_message #endif @@ -685,11 +709,32 @@ SUBROUTINE radiation_driver ( & expl_conv=.true. ! backward compatibility for ARW endif + IF ( ICLOUD == 3 ) THEN + IF (PRESENT(dxkm)) then + gridkm = 1.414*SQRT(dxkm*dxkm + dy*0.001*dy*0.001) + ELSE IF (PRESENT(dx)) then + gridkm = SQRT(dx*0.001*dx*0.001 + dy*0.001*dy*0.001) + endif + + if (itimestep .LE. 100) then + WRITE ( wrf_err_message , * ) 'Grid spacing in km ', dx, dy, gridkm + CALL wrf_debug (100, wrf_err_message) + endif + END IF + CALL wrf_debug (1, 'Top of Radiation Driver') ! WRITE ( wrf_err_message , * ) 'itimestep = ',itimestep,', dt = ',dt,', lw and sw options = ',lw_physics,sw_physics ! CALL wrf_debug (1, wrf_err_message ) if (lw_physics .eq. 0 .and. sw_physics .eq. 0) return +! amontornes-bcodina (2014-05-02) :: improving the namelist settings consistency for the FLG scheme +! if (lw_physics .ne. FLGLWSCHEME .and. sw_physics .eq. FLGSWSCHEME) then +! call wrf_error_fatal('SW and LW schemes are in conflict. SW is FLG and LW is a different scheme!') +! end if +! if (lw_physics .eq. FLGLWSCHEME .and. sw_physics .ne. FLGSWSCHEME) then +! call wrf_error_fatal('SW and LW schemes are in conflict. LW is FLG and SW is a different scheme!') +! end if + ! ra_call_offset = -1 gives old method where radiation may be called just before output ! ra_call_offset = 0 gives new method where radiation may be called just after output ! and is also consistent with removal of offset in new XTIME @@ -801,7 +846,7 @@ SUBROUTINE radiation_driver ( & allocate(ssaaer_sw(ims:ime, kms:kme, jms:jme, 1:11)) allocate(asyaer_sw(ims:ime, kms:kme, jms:jme, 1:11)) - case(RRTMG_SWSCHEME) + case(RRTMG_SWSCHEME,RRTMG_SWSCHEME_FAST) allocate(tauaer_sw(ims:ime, kms:kme, jms:jme, 1:14)) allocate(ssaaer_sw(ims:ime, kms:kme, jms:jme, 1:14)) allocate(asyaer_sw(ims:ime, kms:kme, jms:jme, 1:14)) @@ -815,7 +860,7 @@ SUBROUTINE radiation_driver ( & allocate(ssaaer_sw(1, 1, 1, 1)) allocate(asyaer_sw(1, 1, 1, 1)) - case(RRTMG_SWSCHEME) + case(RRTMG_SWSCHEME,RRTMG_SWSCHEME_FAST) allocate(tauaer_sw(1, 1, 1, 1)) allocate(ssaaer_sw(1, 1, 1, 1)) allocate(asyaer_sw(1, 1, 1, 1)) @@ -989,7 +1034,7 @@ SUBROUTINE radiation_driver ( & PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN ! Call to cloud fraction routine based on Randall 1994 (Hong Pan 1998) - CALL wrf_debug (1, 'CALL cldfra2') + CALL wrf_debug (1, 'CALL cldfra1') CALL cal_cldfra1(CLDFRA,qv,qc,qi,qs, & F_QV,F_QC,F_QI,F_QS,t,p, & F_ICE_PHY,F_RAIN_PHY, & @@ -1040,12 +1085,56 @@ SUBROUTINE radiation_driver ( & IF ( PRESENT ( CLDFRA ) .AND. & PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN + CALL wrf_debug (1, 'CALL cldfra2') CALL cal_cldfra2(CLDFRA,qc,qi,F_QC,F_QI, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) ENDIF +!+---+-----------------------------------------------------------------+ +!..New cloud fraction scheme added by G. Thompson (2014Oct31) +!+---+-----------------------------------------------------------------+ + + ELSEIF (ICLOUD == 3) THEN + IF (PRESENT(CLDFRA) .AND. & + PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + qc_save(i,k,j) = qc(i,k,j) + qi_save(i,k,j) = qi(i,k,j) + ENDDO + ENDDO + ENDDO + IF (PRESENT(F_QS)) THEN + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + qs_save(i,k,j) = qs(i,k,j) + ENDDO + ENDDO + ENDDO + ELSE + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + qs_save(i,k,j) = 0.0 + ENDDO + ENDDO + ENDDO + ENDIF + + CALL wrf_debug (150, 'DEBUG: using gthompsn cloud fraction scheme') + CALL cal_cldfra3(CLDFRA, qv, qc, qi, qs, & + & p,t,rho, XLAND, gridkm, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte) + + ENDIF + END IF ! ww: Interpolating climatological ozone and aerosol to model time and levels @@ -1091,8 +1180,14 @@ SUBROUTINE radiation_driver ( & CASE (RRTMSCHEME) CALL wrf_debug (100, 'CALL rrtm') + IF ( PRESENT(p_top) ) THEN + p_top_dummy = p_top + ELSE + p_top_dummy = -1. ! not used by NMM + END IF CALL RRTMLWRAD( & - RTHRATEN=RTHRATEN,GLW=GLW,OLR=RLWTOA,EMISS=EMISS & + P_TOP=p_top_dummy & + ,RTHRATEN=RTHRATEN,GLW=GLW,OLR=RLWTOA,EMISS=EMISS & ,QV3D=QV & ,QC3D=QC & ,QR3D=QR & @@ -1245,6 +1340,7 @@ SUBROUTINE radiation_driver ( & ,SWVISDIR=swvisdir ,SWVISDIF=swvisdif & !fds ssib swr comp (06/2010) ,SWNIRDIR=swnirdir ,SWNIRDIF=swnirdif & !fds ssib swr comp (06/2010) ,SF_SURFACE_PHYSICS=sf_surface_physics & !fds + ,SWDDIR=swddir,SWDDIF=swddif,SWDDNI=swddni & !amontornes-bcodina (2014-04-20) ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg & ,f_ice_phy=f_ice_phy,f_rain_phy=f_rain_phy & @@ -1271,7 +1367,6 @@ SUBROUTINE radiation_driver ( & CASE (RRTMG_LWSCHEME) CALL wrf_debug (100, 'CALL rrtmg_lw') - CALL RRTMG_LWRAD( & RTHRATENLW=RTHRATEN, & LWUPT=LWUPT,LWUPTC=LWUPTC, & @@ -1299,18 +1394,72 @@ SUBROUTINE radiation_driver ( & F_QI=F_QI,F_QS=F_QS,F_QG=F_QG, & RE_CLOUD=re_cloud,RE_ICE=re_ice,RE_SNOW=re_snow, & ! G. Thompson has_reqc=has_reqc,has_reqi=has_reqi,has_reqs=has_reqs, & ! G. Thompson -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) + TAUAERLW1=tauaerlw1,TAUAERLW2=tauaerlw2, & ! jcb + TAUAERLW3=tauaerlw3,TAUAERLW4=tauaerlw4, & ! jcb + TAUAERLW5=tauaerlw5,TAUAERLW6=tauaerlw6, & ! jcb + TAUAERLW7=tauaerlw7,TAUAERLW8=tauaerlw8, & ! jcb + TAUAERLW9=tauaerlw9,TAUAERLW10=tauaerlw10, & ! jcb + TAUAERLW11=tauaerlw11,TAUAERLW12=tauaerlw12, & ! jcb + TAUAERLW13=tauaerlw13,TAUAERLW14=tauaerlw14, & ! jcb + TAUAERLW15=tauaerlw15,TAUAERLW16=tauaerlw16, & ! jcb + aer_ra_feedback=aer_ra_feedback, & +!jdfcz progn=progn,prescribe=prescribe, & + progn=progn, & +#endif + QNDROP3D=qndrop,F_QNDROP=f_qndrop, & +!ccc Added for time-varying trace gases. + YR=YR,JULIAN=JULIAN, & +!ccc + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde,& + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme,& + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte,& + LWUPFLX=LWUPFLX,LWUPFLXC=LWUPFLXC, & + LWDNFLX=LWDNFLX,LWDNFLXC=LWDNFLXC & + ) + + CASE (RRTMG_LWSCHEME_FAST) + CALL wrf_debug (100, 'CALL rrtmg_lw') + + CALL RRTMG_LWRAD_FAST( & + RTHRATENLW=RTHRATEN, & + LWUPT=LWUPT,LWUPTC=LWUPTC, & + LWDNT=LWDNT,LWDNTC=LWDNTC, & + LWUPB=LWUPB,LWUPBC=LWUPBC, & + LWDNB=LWDNB,LWDNBC=LWDNBC, & + GLW=GLW,OLR=RLWTOA,LWCF=LWCF, & + EMISS=EMISS, & + P8W=p8w,P3D=p,PI3D=pi,DZ8W=dz8w,TSK=tsk,T3D=t, & + T8W=t8w,RHO3D=rho,R=R_d,G=G, & + ICLOUD=icloud,WARM_RAIN=warm_rain,CLDFRA3D=CLDFRA,& +#if (EM_CORE == 1) + LRADIUS=lradius, IRADIUS=iradius, & +#endif + IS_CAMMGMP_USED=is_cammgmp_used, & + +!ckay +! CLDFRA_KF3D=cldfra_KF,QC_KF3D=qc_KF,QI_KF3D=qi_KF,& + F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY, & + XLAND=XLAND,XICE=XICE,SNOW=SNOW, & + QV3D=QV,QC3D=QC,QR3D=QR, & + QI3D=QI,QS3D=QS,QG3D=QG, & + O3INPUT=O3INPUT,O33D=O3RAD, & + F_QV=F_QV,F_QC=F_QC,F_QR=F_QR, & + F_QI=F_QI,F_QS=F_QS,F_QG=F_QG, & + RE_CLOUD=re_cloud,RE_ICE=re_ice,RE_SNOW=re_snow, & ! G. Thompson + has_reqc=has_reqc,has_reqi=has_reqi,has_reqs=has_reqs, & ! G. Thompson +#if ( WRF_CHEM == 1 ) TAUAERLW1=tauaerlw1,TAUAERLW2=tauaerlw2, & ! jcb TAUAERLW3=tauaerlw3,TAUAERLW4=tauaerlw4, & ! jcb TAUAERLW5=tauaerlw5,TAUAERLW6=tauaerlw6, & ! jcb TAUAERLW7=tauaerlw7,TAUAERLW8=tauaerlw8, & ! jcb - TAUAERLW9=tauaerlw9,TAUAERLW10=tauaerlw10, & ! jcb - TAUAERLW11=tauaerlw11,TAUAERLW12=tauaerlw12, & ! jcb - TAUAERLW13=tauaerlw13,TAUAERLW14=tauaerlw14, & ! jcb - TAUAERLW15=tauaerlw15,TAUAERLW16=tauaerlw16, & ! jcb + TAUAERLW9=tauaerlw9,TAUAERLW10=tauaerlw10, & ! jcb + TAUAERLW11=tauaerlw11,TAUAERLW12=tauaerlw12, & ! jcb + TAUAERLW13=tauaerlw13,TAUAERLW14=tauaerlw14, & ! jcb + TAUAERLW15=tauaerlw15,TAUAERLW16=tauaerlw16, & ! jcb aer_ra_feedback=aer_ra_feedback, & !jdfcz progn=progn,prescribe=prescribe, & - progn=progn, & + progn=progn, & #endif QNDROP3D=qndrop,F_QNDROP=f_qndrop, & !ccc Added for time-varying trace gases. @@ -1365,10 +1514,11 @@ SUBROUTINE radiation_driver ( & ,kms=kms,kmax=kme & ,its=its,ite=ite,jts=jts,jte=jte & ,kts=kts,kte=kte & - ,uswtop=RSWTOA,ulwtop=RLWTOA & - ,NETSWBOT=GSW,DLWBOT=GLW & - ,DSWBOT=SWDOWN,deltat=RTHRATEN & - ,dtshort=RTHRATENSW,dtlongwv=RTHRATENLW & + ,uswtop=RSWTOA,ulwtop=RLWTOA & + ,NETSWBOT=GSW,DLWBOT=GLW & + ,DSWBOT=SWDOWN,deltat=RTHRATEN & + ,dtshort=RTHRATENSW,dtlongwv=RTHRATENLW & + ,SWDDIR=swddir,SWDDIF=swddif,SWDDNI=swddni & ! amontornes-bcodina (2014-04-20) ) CALL wrf_debug(100, 'a4 Fu_Liou-Gu') @@ -1425,7 +1575,7 @@ SUBROUTINE radiation_driver ( & end do end do - case(RRTMG_SWSCHEME) + case(RRTMG_SWSCHEME,RRTMG_SWSCHEME_FAST) call wrf_debug(100, 'call calc_aerosol_rrtmg_sw') call calc_aerosol_rrtmg_sw(ht,dz8w,p,t,qv,aer_type,aer_aod550_opt,aer_angexp_opt, & aer_ssa_opt,aer_asy_opt,aer_aod550_val,aer_angexp_val, & @@ -1452,7 +1602,7 @@ SUBROUTINE radiation_driver ( & CALL SWRAD( & DT=dt,RTHRATEN=rthraten,GSW=gsw & ,XLAT=xlat,XLONG=xlong,ALBEDO=albedo & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ,PM2_5_DRY=pm2_5_dry,PM2_5_WATER=pm2_5_water & ,PM2_5_DRY_EC=pm2_5_dry_ec & #endif @@ -1478,17 +1628,18 @@ SUBROUTINE radiation_driver ( & CASE (GSFCSWSCHEME) CALL wrf_debug(100, 'CALL gsfcswrad') CALL GSFCSWRAD( & - RTHRATEN=rthraten,GSW=gsw,XLAT=xlat,XLONG=xlong & + RTHRATEN=rthraten,GSW=gsw & ! PAJ: xlat and xlong removed. ,ALB=albedo,T3D=t,P3D=p,P8W3D=p8w,pi3D=pi & ,DZ8W=dz8w,RHO_PHY=rho & ,CLDFRA3D=cldfra,RSWTOA=rswtoa & - ,GMT=gmt,CP=cp,G=g & - ,JULDAY=julday,XTIME=xtime & - ,DECLIN=declin,SOLCON=solcon & - ,RADFRQ=radt,DEGRAD=degrad & + ,CP=cp,G=g & ! PAJ: GMT removed. + ,JULDAY=julday & ! PAJ: XTIME removed. + ,SOLCON=solcon & ! PAJ: declin removed +! ,RADFRQ=radt,DEGRAD=degrad & ! PAJ: degrad and radfrq removed ,TAUCLDI=taucldi,TAUCLDC=taucldc & ,WARM_RAIN=warm_rain & -#ifdef WRF_CHEM + +#if ( WRF_CHEM == 1 ) ,TAUAER300=tauaer300,TAUAER400=tauaer400 & ! jcb ,TAUAER600=tauaer600,TAUAER999=tauaer999 & ! jcb ,GAER300=gaer300,GAER400=gaer400 & ! jcb @@ -1510,6 +1661,7 @@ SUBROUTINE radiation_driver ( & ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg & ,F_QNDROP=f_qndrop & + ,COSZEN=coszen & ) CASE (goddardswscheme) @@ -1582,6 +1734,7 @@ SUBROUTINE radiation_driver ( & ,SWVISDIR=swvisdir ,SWVISDIF=swvisdif & !fds ssib swr comp (06/2010) ,SWNIRDIR=swnirdir ,SWNIRDIF=swnirdif & !fds ssib swr comp (06/2010) ,SF_SURFACE_PHYSICS=sf_surface_physics & !fds + ,SWDDIR=swddir,SWDDIF=swddif,SWDDNI=swddni & !amontornes-bcodina (2014-04-20) ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & ,F_QI=f_qi,F_QS=f_qs,F_QG=f_qg & ,f_ice_phy=f_ice_phy,f_rain_phy=f_rain_phy & @@ -1651,7 +1804,76 @@ SUBROUTINE radiation_driver ( & F_QI=f_qi,F_QS=f_qs,F_QG=f_qg, & RE_CLOUD=re_cloud,RE_ICE=re_ice,RE_SNOW=re_snow, & ! G. Thompson has_reqc=has_reqc,has_reqi=has_reqi,has_reqs=has_reqs, & ! G. Thompson -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) + TAUAER300=tauaer300,TAUAER400=tauaer400, & ! jcb + TAUAER600=tauaer600,TAUAER999=tauaer999, & ! jcb + GAER300=gaer300,GAER400=gaer400, & ! jcb + GAER600=gaer600,GAER999=gaer999, & ! jcb + WAER300=waer300,WAER400=waer400, & ! jcb + WAER600=waer600,WAER999=waer999, & ! jcb + aer_ra_feedback=aer_ra_feedback, & +!jdfcz progn=progn,prescribe=prescribe, & + progn=progn, & +#endif + QNDROP3D=qndrop,F_QNDROP=f_qndrop, & + IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde,& + IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme,& + ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte,& + SWUPFLX=SWUPFLX,SWUPFLXC=SWUPFLXC, & + SWDNFLX=SWDNFLX,SWDNFLXC=SWDNFLXC, & + tauaer3d_sw=tauaer_sw, & ! jararias 2013/11 + ssaaer3d_sw=ssaaer_sw, & ! jararias 2013/11 + asyaer3d_sw=asyaer_sw, & ! jararias 2013/11 + swddir=swddir,swddni=swddni,swddif=swddif, & ! jararias 2013/08/10 + xcoszen=coszen,julian=julian ) ! jararias 2013/08/14 + + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + RTHRATEN(I,K,J)=RTHRATEN(I,K,J)+RTHRATENSW(I,K,J) + ENDDO + ENDDO + ENDDO + + CASE (RRTMG_SWSCHEME_FAST) + CALL wrf_debug(100, 'CALL rrtmg_sw_fast') + CALL RRTMG_SWRAD_FAST( & + RTHRATENSW=RTHRATENSW, & + SWUPT=SWUPT,SWUPTC=SWUPTC, & + SWDNT=SWDNT,SWDNTC=SWDNTC, & + SWUPB=SWUPB,SWUPBC=SWUPBC, & + SWDNB=SWDNB,SWDNBC=SWDNBC, & + SWCF=SWCF,GSW=GSW, & + XTIME=XTIME,GMT=GMT,XLAT=XLAT,XLONG=XLONG, & + RADT=RADT,DEGRAD=DEGRAD,DECLIN=DECLIN, & + COSZR=COSZR,JULDAY=JULDAY,SOLCON=SOLCON, & + ALBEDO=ALBEDO,t3d=t,t8w=t8w,TSK=TSK, & + p3d=p,p8w=p8w,pi3d=pi,rho3d=rho, & + dz8w=dz8w,CLDFRA3D=CLDFRA, & +#if (EM_CORE == 1) + LRADIUS=lradius, IRADIUS=iradius, & +#endif + IS_CAMMGMP_USED=is_cammgmp_used, & + R=R_D,G=G, & +!ckay +! CLDFRA_KF3D=cldfra_KF,QC_KF3D=qc_KF,QI_KF3D=qi_KF,& + ICLOUD=icloud,WARM_RAIN=warm_rain, & + F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY, & + XLAND=XLAND,XICE=XICE,SNOW=SNOW, & + QV3D=qv,QC3D=qc,QR3D=qr, & + QI3D=qi,QS3D=qs,QG3D=qg, & + O3INPUT=O3INPUT,O33D=O3RAD, & + AER_OPT=AER_OPT,aerod=aerod,no_src=no_src_types, & + ALSWVISDIR=alswvisdir ,ALSWVISDIF=alswvisdif, & !Zhenxin ssib alb comp (06/2010) + ALSWNIRDIR=alswnirdir ,ALSWNIRDIF=alswnirdif, & !Zhenxin ssib alb comp (06/2010) + SWVISDIR=swvisdir ,SWVISDIF=swvisdif, & !Zhenxin ssib swr comp (06/2010) + SWNIRDIR=swnirdir ,SWNIRDIF=swnirdif, & !Zhenxin ssib swr comp (06/2010) + SF_SURFACE_PHYSICS=sf_surface_physics, & !Zhenxin ssib sw_phy (06/2010) + F_QV=f_qv,F_QC=f_qc,F_QR=f_qr, & + F_QI=f_qi,F_QS=f_qs,F_QG=f_qg, & + RE_CLOUD=re_cloud,RE_ICE=re_ice,RE_SNOW=re_snow, & ! G. Thompson + has_reqc=has_reqc,has_reqi=has_reqi,has_reqs=has_reqs, & ! G. Thompson +#if ( WRF_CHEM == 1 ) TAUAER300=tauaer300,TAUAER400=tauaer400, & ! jcb TAUAER600=tauaer600,TAUAER999=tauaer999, & ! jcb GAER300=gaer300,GAER400=gaer400, & ! jcb @@ -1801,59 +2023,85 @@ SUBROUTINE radiation_driver ( & ! jararias, 14/08/2013 ! surface direct and diffuse SW fluxes computation. Only for schemes other than RRTMG and Goddard ! Backup method in case sw scheme in use does not provide surface SW direct and diffuse irradiances - if ((sw_physics .ne. rrtmg_swscheme) .and. (sw_physics .ne. goddardswscheme)) then - do j=jts,jte - do i=its,ite - if (coszen(i,j).gt.1e-3) then + IF ((sw_physics .NE. RRTMG_SWSCHEME) .AND. (sw_physics .NE. RRTMG_SWSCHEME_FAST) & + .AND. (sw_physics .NE. FLGSWSCHEME) .AND. (sw_physics .NE. CAMSWSCHEME) & ! amontornes-bcodina (2014-04-20) + .AND. (sw_physics .ne. GODDARDSWSCHEME)) THEN + DO j=jts,jte + DO i=its,ite + IF (coszen(i,j).GT.1e-3) THEN ioh=solcon*coszen(i,j) ! TOA irradiance kt=swdown(i,j)/max(ioh,1e-3) ! clearness index - ! Optical air mass: Rigollier et al. (2000) doi: 10.1016/S0038-092X(99)00055-9 + ! Optical air mass: Rigollier et al. (2000) doi: + ! 10.1016/S0038-092X(99)00055-9 airmass=exp(-ht(i,j)/8434.5)/(coszen(i,j)+ & 0.50572*(asin(coszen(i,j))*57.295779513082323+6.07995)**(-1.6364)) - ! kt correction for air-mass at large sza: Perez et al. (1990) doi: 10.1016/0038-092X(90)90036-C + ! kt correction for air-mass at large sza: Perez et al. (1990) + ! doi: 10.1016/0038-092X(90)90036-C kt=kt/(0.1+1.031*exp(-1.4/(0.9+(9.4/max(airmass,1e-3))))) - ! Diffuse fraction: Ruiz-Arias et al. (2010) (Eq 33) doi: 10.1016/j.enconman.2009.11.024 + ! Diffuse fraction: Ruiz-Arias et al. (2010) (Eq 33) doi: + ! 10.1016/j.enconman.2009.11.024 kd=0.952-1.041*exp(-exp(2.300-4.702*kt)) swddif(i,j)=kd*swdown(i,j) swddir(i,j)=(1.-kd)*swdown(i,j) swddni(i,j)=swddir(i,j)/max(coszen(i,j),1e-4) - end if - end do - end do - end if - - IF ( PRESENT( qc ) .AND. PRESENT( qc_cu ) ) THEN - IF ( icloud_cu .NE. 0 ) THEN - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - qc(i,k,j) = qc_save(i,k,j) + ENDIF ENDDO ENDDO - ENDDO - ENDIF ENDIF - IF ( PRESENT( qi ) .AND. PRESENT( qi_cu ) ) THEN - IF ( icloud_cu .NE. 0 ) THEN + IF ( PRESENT( qs ) .AND. ICLOUD.eq.3) THEN DO j=jts,jte DO k=kts,kte DO i=its,ite - qi(i,k,j) = qi_save(i,k,j) + qs(i,k,j) = qs_save(i,k,j) ENDDO ENDDO ENDDO - ENDIF ENDIF - ! jararias, aug 2013, updated 2013/11 - ! parameters update for SW surface fluxes interpolation - if (swint_opt.eq.1) then - ! interpolation applies on all-sky fluxes (swddir, swdown) - call update_swinterp_parameters(ims,ime,jms,jme,its,ite,jts,jte, & - coszen,coszen_loc,swddir,swdown, & - swddir_ref,bb,Bx,swdown_ref,gg,Gx, & - coszen_ref ) - end if + IF ( PRESENT( diffuse_frac ) ) THEN + DO j=jts,jte + DO i=its,ite + if (coszen(i,j).gt.1e-3) then + diffuse_frac(i,j) = swddif(i,j)/swdown(i,j) + else + diffuse_frac(i,j) = 0. + endif + ENDDO + ENDDO + ENDIF + + IF ( PRESENT( qc ) .AND. PRESENT( qc_cu ) ) THEN + IF ( icloud_cu .NE. 0 ) THEN + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + qc(i,k,j) = qc_save(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + IF ( PRESENT( qi ) .AND. PRESENT( qi_cu ) ) THEN + IF ( icloud_cu .NE. 0 ) THEN + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + qi(i,k,j) = qi_save(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + ! jararias, aug 2013, updated 2013/11 + ! parameters update for SW surface fluxes interpolation + IF (swint_opt.EQ.1) THEN + ! interpolation applies on all-sky fluxes (swddir, swdown) + CALL update_swinterp_parameters(ims,ime,jms,jme,its,ite,jts,jte, & + coszen,coszen_loc,swddir,swdown, & + swddir_ref,bb,Bx,swdown_ref,gg,Gx, & + coszen_ref ) + ENDIF ENDDO !$OMP END PARALLEL DO @@ -1879,16 +2127,22 @@ SUBROUTINE radiation_driver ( & jte = j_end(ij) call interp_sw_radiation(ims,ime,jms,jme,its,ite,jts,jte, & coszen_ref,coszen_loc,swddir_ref, & - bb,Bx,swdown_ref,gg,Gx, & - swdown,swddir,swddni,swddif ) + bb,Bx,swdown_ref,gg,Gx,albedo, & + swdown,swddir,swddni,swddif,gsw ) enddo !$OMP END PARALLEL DO end if accumulate_lw_select: SELECT CASE(lw_physics) - CASE (CAMLWSCHEME,RRTMG_LWSCHEME) + CASE (CAMLWSCHEME,RRTMG_LWSCHEME,RRTMG_LWSCHEME_FAST) IF(PRESENT(LWUPTC))THEN +! NMM calls the driver every RADT time steps, EM calls every DT +#if (EM_CORE == 1) + DTaccum = DT +#else + DTaccum = RADT*60 +#endif !$OMP PARALLEL DO & !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte) @@ -1900,14 +2154,14 @@ SUBROUTINE radiation_driver ( & DO j=jts,jte DO i=its,ite - ACLWUPT(I,J) = ACLWUPT(I,J) + LWUPT(I,J)*DT - ACLWUPTC(I,J) = ACLWUPTC(I,J) + LWUPTC(I,J)*DT - ACLWDNT(I,J) = ACLWDNT(I,J) + LWDNT(I,J)*DT - ACLWDNTC(I,J) = ACLWDNTC(I,J) + LWDNTC(I,J)*DT - ACLWUPB(I,J) = ACLWUPB(I,J) + LWUPB(I,J)*DT - ACLWUPBC(I,J) = ACLWUPBC(I,J) + LWUPBC(I,J)*DT - ACLWDNB(I,J) = ACLWDNB(I,J) + LWDNB(I,J)*DT - ACLWDNBC(I,J) = ACLWDNBC(I,J) + LWDNBC(I,J)*DT + ACLWUPT(I,J) = ACLWUPT(I,J) + LWUPT(I,J)*DTaccum + ACLWUPTC(I,J) = ACLWUPTC(I,J) + LWUPTC(I,J)*DTaccum + ACLWDNT(I,J) = ACLWDNT(I,J) + LWDNT(I,J)*DTaccum + ACLWDNTC(I,J) = ACLWDNTC(I,J) + LWDNTC(I,J)*DTaccum + ACLWUPB(I,J) = ACLWUPB(I,J) + LWUPB(I,J)*DTaccum + ACLWUPBC(I,J) = ACLWUPBC(I,J) + LWUPBC(I,J)*DTaccum + ACLWDNB(I,J) = ACLWDNB(I,J) + LWDNB(I,J)*DTaccum + ACLWDNBC(I,J) = ACLWDNBC(I,J) + LWDNBC(I,J)*DTaccum ENDDO ENDDO ENDDO @@ -1918,8 +2172,14 @@ SUBROUTINE radiation_driver ( & accumulate_sw_select: SELECT CASE(sw_physics) - CASE (CAMSWSCHEME,RRTMG_SWSCHEME) + CASE (CAMSWSCHEME,RRTMG_SWSCHEME,RRTMG_SWSCHEME_FAST) IF(PRESENT(SWUPTC))THEN +! NMM calls the driver every RADT time steps, EM calls every DT +#if (EM_CORE == 1) + DTaccum = DT +#else + DTaccum = RADT*60 +#endif !$OMP PARALLEL DO & !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte) @@ -1931,14 +2191,14 @@ SUBROUTINE radiation_driver ( & DO j=jts,jte DO i=its,ite - ACSWUPT(I,J) = ACSWUPT(I,J) + SWUPT(I,J)*DT - ACSWUPTC(I,J) = ACSWUPTC(I,J) + SWUPTC(I,J)*DT - ACSWDNT(I,J) = ACSWDNT(I,J) + SWDNT(I,J)*DT - ACSWDNTC(I,J) = ACSWDNTC(I,J) + SWDNTC(I,J)*DT - ACSWUPB(I,J) = ACSWUPB(I,J) + SWUPB(I,J)*DT - ACSWUPBC(I,J) = ACSWUPBC(I,J) + SWUPBC(I,J)*DT - ACSWDNB(I,J) = ACSWDNB(I,J) + SWDNB(I,J)*DT - ACSWDNBC(I,J) = ACSWDNBC(I,J) + SWDNBC(I,J)*DT + ACSWUPT(I,J) = ACSWUPT(I,J) + SWUPT(I,J)*DTaccum + ACSWUPTC(I,J) = ACSWUPTC(I,J) + SWUPTC(I,J)*DTaccum + ACSWDNT(I,J) = ACSWDNT(I,J) + SWDNT(I,J)*DTaccum + ACSWDNTC(I,J) = ACSWDNTC(I,J) + SWDNTC(I,J)*DTaccum + ACSWUPB(I,J) = ACSWUPB(I,J) + SWUPB(I,J)*DTaccum + ACSWUPBC(I,J) = ACSWUPBC(I,J) + SWUPBC(I,J)*DTaccum + ACSWDNB(I,J) = ACSWDNB(I,J) + SWDNB(I,J)*DTaccum + ACSWDNBC(I,J) = ACSWDNBC(I,J) + SWDNBC(I,J)*DTaccum ENDDO ENDDO ENDDO @@ -1948,6 +2208,36 @@ SUBROUTINE radiation_driver ( & CASE DEFAULT END SELECT accumulate_sw_select +! compute cloud diagnosis (random overlapping) +! by ZCX + IF ( PRESENT ( CLDFRA ) .AND. PRESENT ( CLDT ) .AND. & + PRESENT ( F_QC ) .AND. PRESENT ( F_QI ) ) THEN + + DO ij = 1 , num_tiles + its = i_start(ij) + ite = i_end(ij) + jts = j_start(ij) + jte = j_end(ij) + + DO j=jts,jte + DO i=its,ite + cldji=1.0 + do k=kte-1,kts,-1 + cldji=cldji*(1.0-cldfra(i,k,j)) + enddo + cldt(i,j)=1.0-cldji +! cldlji=1.0 +! do k=kte-1,kts,-1 +! if(znu(k).ge.0.69) then +! cldlji=cldlji*(1.0-cldfra(i,k,j)) +! endif +! enddo +! cldl(i,j)=1.0-cldlji + END DO + END DO + END DO + END IF + END SUBROUTINE radiation_driver SUBROUTINE pre_radiation_driver ( grid, config_flags & @@ -2289,16 +2579,18 @@ end subroutine update_swinterp_parameters subroutine interp_sw_radiation(ims,ime,jms,jme,its,ite,jts,jte, & coszen_ref,coszen_loc,swddir_ref, & - bb,Bx,swdown_ref,gg,Gx, & - swdown,swddir,swddni,swddif ) + bb,Bx,swdown_ref,gg,Gx,albedo, & + swdown,swddir,swddni,swddif,gsw ) ! Author: jararias 2013/11 implicit None integer, intent(in) :: ims,ime,jms,jme,its,ite,jts,jte real, dimension(ims:ime,jms:jme), intent(in) :: coszen_ref,coszen_loc, & swddir_ref,Bx,bb, & - swdown_ref,Gx,gg + swdown_ref,Gx,gg, & + albedo + real, dimension(ims:ime,jms:jme), intent(inout) :: swddir,swdown, & - swddif,swddni + swddif,swddni, gsw integer :: i,j real, parameter :: coszen_min=1e-4 @@ -2319,11 +2611,13 @@ subroutine interp_sw_radiation(ims,ime,jms,jme,its,ite,jts,jte, & end if swddif(i,j) =swdown(i,j)-swddir(i,j) swddni(i,j) =swddir(i,j)/coszen_loc(i,j) + gsw(i,j) =swdown(i,j)*(1.-albedo(i,j)) else swddir(i,j) =0. swdown(i,j) =0. swddif(i,j) =0. swddni(i,j) =0. + gsw(i,j) =0. end if end do end do @@ -2613,6 +2907,456 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & END SUBROUTINE cal_cldfra1 +!+---+-----------------------------------------------------------------+ +!..Cloud fraction scheme by G. Thompson (NCAR-RAL), not intended for +!.. combining with any cumulus or shallow cumulus parameterization +!.. scheme cloud fractions. This is intended as a stand-alone for +!.. cloud fraction and is relatively good at getting widespread stratus +!.. and stratoCu without caring whether any deep/shallow Cu param schemes +!.. is making sub-grid-spacing clouds/precip. Under the hood, this +!.. scheme follows Mocko and Cotton (1995) in applicaiton of the +!.. Sundqvist et al (1989) scheme but using a grid-scale dependent +!.. RH threshold, one each for land v. ocean points based on +!.. experiences with HWRF testing. +!+---+-----------------------------------------------------------------+ +! +!+---+-----------------------------------------------------------------+ + + SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs, & + & p,t,rho, XLAND, gridkm, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte) +! + USE module_mp_thompson , ONLY : rsif, rslf + IMPLICIT NONE +! + INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte + + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: qv,p,t,rho + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT):: qc,qi,qs + REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN):: XLAND + + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT):: cldfra + REAL, INTENT(IN):: gridkm + +!..Local vars. + REAL:: RH_00L, RH_00O, RH_00, RHI_max + REAL, DIMENSION(ims:ime,kms:kme,jms:jme):: qvsat + INTEGER:: i,j,k + REAL:: TK, TC, qvsi, qvsw, RHUM + REAL, DIMENSION(kms:kme):: qvs1d, cfr1d, T1d, & + & P1d, R1d, qc1d, qi1d, qs1d + + character*512 dbg_msg + LOGICAL:: debug_flag + +!+---+ + +!..First cut scale-aware. Higher resolution should require closer to +!.. saturated grid box for higher cloud fraction. Simple functions +!.. chosen based on Mocko and Cotton (1995) starting point and desire +!.. to get near 100% RH as grid spacing moves toward 1.0km, but higher +!.. RH over ocean required as compared to over land. + + RH_00L = 0.839 + SQRT(1./(50.0+gridkm*gridkm*gridkm*0.5)) + RH_00O = 0.879 + SQRT(1./(100.0+gridkm*gridkm)) + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + RHI_max = 0.0 + CLDFRA(I,K,J) = 0.0 + + if (qc(i,k,j)+qi(i,k,j) .gt. 1.E-8) then + CLDFRA(I,K,J) = 1.0 + qvsat(i,k,j) = qv(i,k,j) + else + + TK = t(i,k,j) + TC = TK - 273.16 + + qvsw = rslf(P(i,k,j), TK) + qvsi = rsif(P(i,k,j), TK) + + if (tc .ge. -12.0) then + qvsat(i,k,j) = qvsw + elseif (tc .lt. -30.0) then + qvsat(i,k,j) = qvsi + else + qvsat(i,k,j) = qvsw - (qvsw-qvsi)*(-12.0-tc)/(-12.0+30.) + endif + RHUM = qv(i,k,j)/qvsat(i,k,j) + + IF ((XLAND(I,J)-1.5).GT.0.) THEN !--- Ocean + RH_00 = RH_00O + ELSE !--- Land + RH_00 = RH_00L + ENDIF + + if (tc .ge. -12.0) then + RHUM = MIN(0.999, RHUM) + CLDFRA(I,K,J) = MAX(0.0, 1.0-SQRT((1.0-RHUM)/(1.-RH_00))) + elseif (tc.lt.-12..and.tc.gt.-70. .and. RHUM.gt.RH_00O) then + RHI_max = MAX(RHUM+1.E-6, qvsw/qvsi) + CLDFRA(I,K,J) = MAX(0., ((RH_00O-RHUM)/(RH_00O-RHI_max)) & + & *((RH_00O-RHUM)/(RH_00O-RHI_max))) + endif + + CLDFRA(I,K,J) = MAX(0.0, MIN(CLDFRA(I,K,J), 0.95)) + + endif + ENDDO + ENDDO + ENDDO + +!..Prepare for a 1-D column to find various cloud layers. + + DO j = jts,jte + DO i = its,ite +! if (i.gt.10.and.i.le.20 .and. j.gt.10.and.j.le.20) then +! debug_flag = .true. +! else +! debug_flag = .false. +! endif + DO k = kts,kte + qvs1d(k) = qvsat(i,k,j) + cfr1d(k) = cldfra(i,k,j) + T1d(k) = t(i,k,j) + P1d(k) = p(i,k,j) + R1d(k) = rho(i,k,j) + qc1d(k) = qc(i,k,j) + qi1d(k) = qi(i,k,j) + qs1d(k) = qs(i,k,j) + ENDDO + +! if (debug_flag) then +! WRITE (dbg_msg,*) 'DEBUG-GT: finding cloud layers at point (', i, ', ', j, ')' +! CALL wrf_debug (150, dbg_msg) +! endif + call find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, & + & debug_flag, qc1d, qi1d, qs1d, kts,kte) + + DO k = kts,kte + cldfra(i,k,j) = cfr1d(k) + qc(i,k,j) = qc1d(k) + qi(i,k,j) = qi1d(k) + ENDDO + ENDDO + ENDDO + + END SUBROUTINE cal_cldfra3 + +!+---+-----------------------------------------------------------------+ +!..From cloud fraction array, find clouds of multi-level depth and compute +!.. a reasonable value of LWP or IWP that might be contained in that depth, +!.. unless existing LWC/IWC is already there. + + SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, & + & debugfl, qc1d, qi1d, qs1d, kts,kte) +! + IMPLICIT NONE +! + INTEGER, INTENT(IN):: kts, kte + LOGICAL, INTENT(IN):: debugfl + REAL, DIMENSION(kts:kte), INTENT(IN):: qvs1d,T1d,P1d,R1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: cfr1d + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc1d, qi1d, qs1d + +!..Local vars. + REAL, DIMENSION(kts:kte):: theta, dz + REAL:: Z1, Z2, theta1, theta2, ht1, ht2 + INTEGER:: k, k2, k_tropo, k_m12C, k_m40C, k_cldb, k_cldt, kbot + LOGICAL:: in_cloud + character*512 dbg_msg + +!+---+ + + k_m12C = 0 + k_m40C = 0 + DO k = kte, kts, -1 + theta(k) = T1d(k)*((100000.0/P1d(k))**(287.05/1004.)) + if (T1d(k)-273.16 .gt. -40.0) k_m40C = MAX(k_m40C, k) + if (T1d(k)-273.16 .gt. -12.0) k_m12C = MAX(k_m12C, k) + ENDDO + if (k_m40C .le. kts) k_m40C = kts + if (k_m12C .le. kts) k_m12C = kts + + Z2 = 44307.692 * (1.0 - (P1d(kte)/101325.)**0.190) + DO k = kte-1, kts, -1 + Z1 = 44307.692 * (1.0 - (P1d(k)/101325.)**0.190) + dz(k+1) = Z2 - Z1 + Z2 = Z1 + ENDDO + dz(kts) = dz(kts+1) + +!..Find tropopause height, best surrogate, because we would not really +!.. wish to put fake clouds into the stratosphere. The 10/1500 ratio +!.. d(Theta)/d(Z) approximates a vertical line on typical SkewT chart +!.. near typical (mid-latitude) tropopause height. Since messy data +!.. could give us a false signal of such a transition, do the check over +!.. three K-level change, not just a level-to-level check. This method +!.. has potential failure in arctic-like conditions with extremely low +!.. tropopause height, as would any other diagnostic, so ensure resulting +!.. k_tropo level is above 4km. + + DO k = kte-3, kts, -1 + theta1 = theta(k) + theta2 = theta(k+2) + ht1 = 44307.692 * (1.0 - (P1d(k)/101325.)**0.190) + ht2 = 44307.692 * (1.0 - (P1d(k+2)/101325.)**0.190) + if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND. & + & (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then + goto 86 + endif + ENDDO + 86 continue + k_tropo = MAX(kts+2, k+2) + +! if (debugfl) then +! print*, ' FOUND TROPOPAUSE ', k_tropo, ' near ', ht2, ' m' +! WRITE (dbg_msg,*) 'DEBUG-GT: FOUND TROPOPAUSE ', k_tropo, ' near ', ht2, ' m' +! CALL wrf_debug (150, dbg_msg) +! endif + +!..Eliminate possible fractional clouds above supposed tropopause. + DO k = k_tropo+1, kte + if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.0.999) then + cfr1d(k) = 0. + endif + ENDDO + +!..We would like to prevent fractional clouds below LCL in idealized +!.. situation with deep well-mixed convective PBL, that otherwise is +!.. likely to get clouds in more realistic capping inversion layer. + + kbot = kts+2 + DO k = kbot, k_m12C + if ( (theta(k)-theta(k-1)) .gt. 0.05E-3*dz(k)) EXIT + ENDDO + kbot = MAX(kts+1, k-1) + DO k = kts, kbot + if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.0.999) cfr1d(k) = 0. + ENDDO + + +!..Starting below tropo height, if cloud fraction greater than 1 percent, +!.. compute an approximate total layer depth of cloud, determine a total +!.. liquid water/ice path (LWP/IWP), then reduce that amount with tuning +!.. parameter to represent entrainment factor, then divide up LWP/IWP +!.. into delta-Z weighted amounts for individual levels per cloud layer. + + k_cldb = k_tropo + in_cloud = .false. + k = k_tropo + DO WHILE (.not. in_cloud .AND. k.gt.k_m12C) + k_cldt = 0 + if (cfr1d(k).ge.0.01) then + in_cloud = .true. + k_cldt = MAX(k_cldt, k) + endif + if (in_cloud) then + DO k2 = k_cldt-1, k_m12C, -1 + if (cfr1d(k2).lt.0.01 .or. k2.eq.k_m12C) then + k_cldb = k2+1 + goto 87 + endif + ENDDO + 87 continue + in_cloud = .false. + endif + if ((k_cldt - k_cldb + 1) .ge. 2) then +! if (debugfl) then +! print*, 'An ice cloud layer is found between ', k_cldt, k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 +! WRITE (dbg_msg,*) 'DEBUG-GT: An ice cloud layer is found between ', k_cldt, k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 +! CALL wrf_debug (150, dbg_msg) +! endif + call adjust_cloudIce(cfr1d, qi1d, qs1d, qvs1d, T1d,R1d,dz, & + & k_cldb,k_cldt,kts,kte) + k = k_cldb + endif + k = k - 1 + ENDDO + + + k_cldb = k_tropo + in_cloud = .false. + k = k_m12C + DO WHILE (.not. in_cloud .AND. k.gt.kbot) + k_cldt = 0 + if (cfr1d(k).ge.0.01) then + in_cloud = .true. + k_cldt = MAX(k_cldt, k) + endif + if (in_cloud) then + DO k2 = k_cldt-1, kbot, -1 + if (cfr1d(k2).lt.0.01 .or. k2.eq.kbot) then + k_cldb = k2+1 + goto 88 + endif + ENDDO + 88 continue + in_cloud = .false. + endif + if ((k_cldt - k_cldb + 1) .ge. 2) then +! if (debugfl) then +! print*, 'A water cloud layer is found between ', k_cldt, k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 +! WRITE (dbg_msg,*) 'DEBUG-GT: A water cloud layer is found between ', k_cldt, k_cldb, P1d(k_cldt)*0.01, P1d(k_cldb)*0.01 +! CALL wrf_debug (150, dbg_msg) +! endif + call adjust_cloudH2O(cfr1d, qc1d, qvs1d, T1d,R1d,dz, & + & k_cldb,k_cldt,kts,kte) + k = k_cldb + endif + k = k - 1 + ENDDO + +!..Do a final total column adjustment since we may have added more than 1mm +!.. LWP/IWP for multiple cloud decks. + + call adjust_cloudFinal(cfr1d, qc1d, qi1d, R1d,dz, kts,kte,k_tropo) + +! if (debugfl) then +! print*, ' Made-up fake profile of clouds' +! do k = kte, kts, -1 +! write(*,'(i3, 2x, f8.2, 2x, f9.2, 2x, f6.2, 2x, f15.7, 2x, f15.7)') & +! & K, T1d(k)-273.15, P1d(k)*0.01, cfr1d(k)*100., qc1d(k)*1000.,qi1d(k)*1000. +! enddo +! WRITE (dbg_msg,*) 'DEBUG-GT: Made-up fake profile of clouds' +! CALL wrf_debug (150, dbg_msg) +! do k = kte, kts, -1 +! write(dbg_msg,'(f8.2, 2x, f9.2, 2x, f6.2, 2x, f15.7, 2x, f15.7)') & +! & T1d(k)-273.15, P1d(k)*0.01, cfr1d(k)*100., qc1d(k)*1000.,qi1d(k)*1000. +! CALL wrf_debug (150, dbg_msg) +! enddo +! endif + + END SUBROUTINE find_cloudLayers + +!+---+-----------------------------------------------------------------+ + + SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs, T,Rho,dz, k1,k2,kts,kte) +! + IMPLICIT NONE +! + INTEGER, INTENT(IN):: k1,k2, kts,kte + REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, qvs, T, Rho, dz + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qi, qs + REAL:: iwp, xiwp, max_iwp, tdz, this_iwp, iwp_exists + INTEGER:: k + REAL, PARAMETER:: entr=0.35 + + max_iwp = ABS(qvs(k2-1)-qvs(k2))*Rho(k2-1)*dz(k2-1) + + tdz = 0. + iwp = 0. + iwp_exists = 0. + do k = k1, k2 + tdz = tdz + dz(k) + iwp = iwp + MAX(0., (qvs(k-1)-qvs(k))*Rho(k)*dz(k)) + iwp_exists = iwp_exists + (qi(k)+qs(k))*Rho(k)*dz(k) + enddo + if (iwp_exists .gt. 1.0) RETURN + max_iwp = MAX(max_iwp*(1.-entr), MIN(1.0, iwp*(1.0-entr))) + + do k = k1, k2 + this_iwp = max_iwp*dz(k)/tdz + if (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).ge.203.16) then + qi(k) = qi(k) + cfr(k)*cfr(k)*this_iwp/Rho(k)/dz(k) + endif + enddo + + END SUBROUTINE adjust_cloudIce + +!+---+-----------------------------------------------------------------+ + + SUBROUTINE adjust_cloudH2O(cfr, qc, qvs, T,Rho,dz, k1,k2,kts,kte) +! + IMPLICIT NONE +! + INTEGER, INTENT(IN):: k1,k2, kts,kte + REAL, DIMENSION(kts:kte):: cfr, qc, qvs, T, Rho, dz + REAL:: lwp, xlwp, max_lwp, tdz, this_lwp, lwp_exists + INTEGER:: k + REAL, PARAMETER:: entr=0.35 + + max_lwp = ABS(qvs(k2-1)-qvs(k2))*Rho(k2-1)*dz(k2-1) + + tdz = 0. + lwp = 0. + lwp_exists = 0. + do k = k1, k2 + tdz = tdz + dz(k) + lwp = lwp + MAX(0., (qvs(k-1)-qvs(k))*Rho(k)*dz(k)) + lwp_exists = lwp_exists + qc(k)*Rho(k)*dz(k) + enddo + if (lwp_exists .gt. 1.0) RETURN + max_lwp = MAX(max_lwp*(1.-entr), MIN(1.0, lwp*(1.0-entr))) + + do k = k1, k2 + this_lwp = max_lwp*dz(k)/tdz + if (cfr(k).gt.0.95.and.qc(k).lt.1.E-7.and.T(k).lt.253.16) then + qc(k) = qc(k) + 0.05*this_lwp/Rho(k)/dz(k) + elseif (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).lt.273.16.and.T(k).ge.253.16) then + qc(k) = qc(k) + cfr(k)*this_lwp/Rho(k)/dz(k) + elseif (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).le.298.16.and.T(k).ge.273.16) then + qc(k) = qc(k) + cfr(k)*cfr(k)*this_lwp/Rho(k)/dz(k) + endif + enddo + + END SUBROUTINE adjust_cloudH2O + +!+---+-----------------------------------------------------------------+ +!..Do not alter any grid-explicitly resolved hydrometeors, rather only +!.. the supposed amounts due to the cloud fraction scheme. + + SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte,k_tropo) +! + IMPLICIT NONE +! + INTEGER, INTENT(IN):: kts,kte,k_tropo + REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, Rho, dz + REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc, qi + REAL:: lwp, iwp, xfac + INTEGER:: k + + lwp = 0. + do k = kts, k_tropo + if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then + lwp = lwp + qc(k)*Rho(k)*dz(k) + endif + enddo + + iwp = 0. + do k = kts, k_tropo + if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then + iwp = iwp + qi(k)*Rho(k)*dz(k) + endif + enddo + + if (lwp .gt. 1.0) then + xfac = 1./lwp + do k = kts, k_tropo + if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then + qc(k) = qc(k)*xfac + endif + enddo + endif + + if (iwp .gt. 1.0) then + xfac = 1./iwp + do k = kts, k_tropo + if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then + qi(k) = qi(k)*xfac + endif + enddo + endif + + END SUBROUTINE adjust_cloudFinal + +!+---+-----------------------------------------------------------------+ SUBROUTINE toposhad_init(ht_shad,ht_loc,shadowmask,nested,iter, & ids,ide, jds,jde, kds,kde, & diff --git a/wrfv2_fire/phys/module_sf_clm.F b/wrfv2_fire/phys/module_sf_clm.F index d3e6c208..17388e46 100644 --- a/wrfv2_fire/phys/module_sf_clm.F +++ b/wrfv2_fire/phys/module_sf_clm.F @@ -1178,8 +1178,8 @@ subroutine var_par cover(:,4) = (/0.,0.,0.,0.,0.,0.,0.,0., 0.,0.,& 0.,0.,0.,0.,0.,0.,0.,50.,0.,0./) else - write(6,*)'CLM works only for USGS (24) and MODIS(20) land use types,& - but the current number of land use types is ',num_landcover_types + write(6,*)'CLM works only for USGS (24) and MODIS(20) land use types, ' + write(6,*)'but the current number of land use types is ',num_landcover_types call endrun() end if end subroutine var_par @@ -3828,6 +3828,7 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & ,inest, sf_urban_physics,nlcat, & !Optional urban CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF, & + CMGR_SFCDIF,CHGR_SFCDIF, & tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d, & !H urban uc_urb2d, & !H urban xxxr_urb2d,xxxb_urb2d,xxxg_urb2d,xxxc_urb2d, & !H urban @@ -3840,9 +3841,12 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & xlat_urb2d, & !I urban num_roof_layers, num_wall_layers, & !I urban num_road_layers, DZR, DZB, DZG, & !I urban - FRC_URB2D, UTYPE_URB2D & ! urban + FRC_URB2D, UTYPE_URB2D, & ! urban + cmcr_urb2d,tgr_urb2d,tgrl_urb3d,smr_urb3d, & ! urban + drelr_urb2d,drelb_urb2d,drelg_urb2d, & ! urban + flxhumr_urb2d,flxhumb_urb2d,flxhumg_urb2d, & ! subgrids - ,numc,nump,sabv,sabg,lwup,snl, & + numc,nump,sabv,sabg,lwup,snl, & snowdp,wtc,wtp,h2osno,t_grnd,t_veg, & h2ocan,h2ocan_col,t2m_max,t2m_min,t2clm , & t_ref2m,h2osoi_liq_s1, & @@ -3911,6 +3915,7 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & USE module_date_time USE module_sf_urban, only: urban + USE module_ra_gfdleta, only: cal_mon_day USE module_configure implicit none @@ -4196,6 +4201,30 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & REAL, DIMENSION(1:num_wall_layers) :: TBL_URB ! wall layer temp [K] REAL, DIMENSION(1:num_road_layers) :: TGL_URB ! road layer temp [K] LOGICAL :: LSOLAR_URB + +!===Yang,2014/10/08,hydrological variable for single layer UCM=== + INTEGER :: jmonth, jday + REAL :: DRELR_URB + REAL :: DRELB_URB + REAL :: DRELG_URB + REAL :: FLXHUMR_URB + REAL :: FLXHUMB_URB + REAL :: FLXHUMG_URB + REAL :: CMCR_URB + REAL :: TGR_URB + REAL, DIMENSION(1:num_roof_layers) :: SMR_URB ! green roof layer moisture + REAL, DIMENSION(1:num_roof_layers) :: TGRL_URB ! green roof layer temp [K] + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TGRL_URB3D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: SMR_URB3D ! state variable surface_driver <--> lsm <--> urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D @@ -4219,10 +4248,12 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D - REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB + REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB, CMGR_URB, CHGR_URB REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMGR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHGR_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF @@ -5141,6 +5172,8 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & DO K = 1,num_roof_layers TRL_URB(K) = TRL_URB3D(I,K,J) + SMR_URB(K) = SMR_URB3D(I,K,J) + TGRL_URB(K)= TGRL_URB3D(I,K,J) END DO DO K = 1,num_wall_layers TBL_URB(K) = TBL_URB3D(I,K,J) @@ -5149,6 +5182,15 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & TGL_URB(K) = TGL_URB3D(I,K,J) END DO + TGR_URB = TGR_URB2D(I,J) + CMCR_URB = CMCR_URB2D(I,J) + FLXHUMR_URB = FLXHUMR_URB2D(I,J) + FLXHUMB_URB = FLXHUMB_URB2D(I,J) + FLXHUMG_URB = FLXHUMG_URB2D(I,J) + DRELR_URB = DRELR_URB2D(I,J) + DRELB_URB = DRELB_URB2D(I,J) + DRELG_URB = DRELG_URB2D(I,J) + XXXR_URB = XXXR_URB2D(I,J) XXXB_URB = XXXB_URB2D(I,J) XXXG_URB = XXXG_URB2D(I,J) @@ -5160,6 +5202,8 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & IF (PRESENT(CMR_SFCDIF)) THEN CMR_URB = CMR_SFCDIF(I,J) CHR_URB = CHR_SFCDIF(I,J) + CMGR_URB = CMGR_SFCDIF(I,J) + CHGR_URB = CHGR_SFCDIF(I,J) CMC_URB = CMC_SFCDIF(I,J) CHC_URB = CHC_SFCDIF(I,J) ENDIF @@ -5177,6 +5221,7 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & ! ! Call urban + CALL cal_mon_day(julday,julyr,jmonth,jday) CALL urban(LSOLAR_URB, & ! I num_roof_layers,num_wall_layers,num_road_layers, & ! C DZR,DZB,DZG, & ! C @@ -5194,7 +5239,10 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & CMR_URB, CHR_URB, CMC_URB, CHC_URB, & U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0 - hgt_urb,frc_urb,lb_urb, check) + hgt_urb,frc_urb,lb_urb, check,CMCR_URB,TGR_URB, & ! H + TGRL_URB,SMR_URB,CMGR_URB, CHGR_URB, jmonth, & ! H + DRELR_URB,DRELB_URB, & ! H + DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB) TS_URB2D(I,J) = TS_URB @@ -5218,6 +5266,8 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & DO K = 1,num_roof_layers TRL_URB3D(I,K,J) = TRL_URB(K) + SMR_URB3D(I,K,J) = SMR_URB(K) + TGRL_URB3D(I,K,J)= TGRL_URB(K) END DO DO K = 1,num_wall_layers TBL_URB3D(I,K,J) = TBL_URB(K) @@ -5225,6 +5275,16 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & DO K = 1,num_road_layers TGL_URB3D(I,K,J) = TGL_URB(K) END DO + + TGR_URB2D(I,J) =TGR_URB + CMCR_URB2D(I,J)=CMCR_URB + FLXHUMR_URB2D(I,J)=FLXHUMR_URB + FLXHUMB_URB2D(I,J)=FLXHUMB_URB + FLXHUMG_URB2D(I,J)=FLXHUMG_URB + DRELR_URB2D(I,J) = DRELR_URB + DRELB_URB2D(I,J) = DRELB_URB + DRELG_URB2D(I,J) = DRELG_URB + XXXR_URB2D(I,J) = XXXR_URB XXXB_URB2D(I,J) = XXXB_URB XXXG_URB2D(I,J) = XXXG_URB @@ -5246,6 +5306,8 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & IF (PRESENT(CMR_SFCDIF)) THEN CMR_SFCDIF(I,J) = CMR_URB CHR_SFCDIF(I,J) = CHR_URB + CMGR_SFCDIF(I,J) = CMGR_URB + CHGR_SFCDIF(I,J) = CHGR_URB CMC_SFCDIF(I,J) = CMC_URB CHC_SFCDIF(I,J) = CHC_URB ENDIF @@ -6356,7 +6418,7 @@ subroutine CLMDebug( str ) #if (defined DEBUGCLM) print*, TRIM(str) - call flush(6) + flush(6) #endif end subroutine CLMDebug diff --git a/wrfv2_fire/phys/module_sf_gfdl.F b/wrfv2_fire/phys/module_sf_gfdl.F index 718bdaef..ccfcbc8e 100755 --- a/wrfv2_fire/phys/module_sf_gfdl.F +++ b/wrfv2_fire/phys/module_sf_gfdl.F @@ -421,6 +421,16 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D, & BR(i,j)=rib(i) CHS(I,J)=CH(I)*wspd (i,j) CHS2(I,J)=USTAR(I)*KARMAN/FH2(I) + +!!!2014-0922 cap CHS over land points + if (xland(i,j) .lt. 1.9) then + CHS(I,J)=amin1(CHS(I,J), 0.05) + CHS2(I,J)=amin1(CHS2(I,J), 0.05) + if (chs2(i,j) < 0) chs2(i,j)=1.0e-6 + endif +!!! + + CPM(I,J)=CP*(1.+0.8*QV3D(i,kts,j)) esat = fpvs(t1(i)) QGH(I,J)=ep2*esat/(1000.*ps(i)-esat) @@ -810,7 +820,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mz ! cor1 = .120 cor2 = 720. - yz= -0.0001344 + yz= 0.0001344 y1= 3.015e-05 y2= 1.517e-06 y3= -3.567e-08 diff --git a/wrfv2_fire/phys/module_sf_lake.F b/wrfv2_fire/phys/module_sf_lake.F index ae49ac79..caf0ba70 100644 --- a/wrfv2_fire/phys/module_sf_lake.F +++ b/wrfv2_fire/phys/module_sf_lake.F @@ -4879,8 +4879,7 @@ subroutine LakeDebug( str ) IMPLICIT NONE CHARACTER*(*), str - print*, TRIM(str) - call flush(6) + CALL wrf_debug( 0 , TRIM(str) ) end subroutine LakeDebug diff --git a/wrfv2_fire/phys/module_sf_mynn.F b/wrfv2_fire/phys/module_sf_mynn.F index 3b585ebd..b5639be4 100644 --- a/wrfv2_fire/phys/module_sf_mynn.F +++ b/wrfv2_fire/phys/module_sf_mynn.F @@ -231,7 +231,9 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & TH2,T2,Q2 REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm + INTENT(OUT) :: ck,cka,cd,cda + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: ustm ! REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: REGIME, & @@ -433,7 +435,9 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & TH2,T2,Q2 REAL, OPTIONAL, DIMENSION( ims:ime ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm + INTENT(OUT) :: ck,cka,cd,cda + REAL, OPTIONAL, DIMENSION( ims:ime ) , & + INTENT(INOUT) :: ustm !-------------------------------------------- !JOE-additinal output REAL, DIMENSION( ims:ime ) :: zratio,BRi,wstar,qstar, & @@ -1091,12 +1095,12 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & !---------------------------------- IF(XLAND(I)-1.5.GT.0.)THEN !WATER HFX(I)=FLHC(I)*(THGB(I)-TH1D(I)) - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX.NE.0 ) THEN - ! AHW: add dissipative heating term - HFX(I)=HFX(I)+RHO1D(I)*USTM(I)*USTM(I)*WSPDI(I) - ENDIF - ENDIF +! IF ( PRESENT(ISFTCFLX) ) THEN +! IF ( ISFTCFLX.NE.0 ) THEN +! ! AHW: add dissipative heating term (commented out in 3.6.1 +! HFX(I)=HFX(I)+RHO1D(I)*USTM(I)*USTM(I)*WSPDI(I) +! ENDIF +! ENDIF ELSEIF(XLAND(I)-1.5.LT.0.)THEN !LAND HFX(I)=FLHC(I)*(THGB(I)-TH1D(I)) HFX(I)=MAX(HFX(I),-250.) diff --git a/wrfv2_fire/phys/module_sf_noahdrv.F b/wrfv2_fire/phys/module_sf_noahdrv.F index 5864f094..ef9e0130 100644 --- a/wrfv2_fire/phys/module_sf_noahdrv.F +++ b/wrfv2_fire/phys/module_sf_noahdrv.F @@ -11,11 +11,12 @@ MODULE module_sf_noahdrv & SMLOW_DATA, SMHIGH_DATA, LVCOEF_DATA, NSLOPE, & & FRH2O,ZTOPVTBL,ZBOTVTBL - USE module_sf_urban, only: urban + USE module_sf_urban, only: urban, oasis, IRI_SCHEME USE module_sf_noahlsm_glacial_only, only: sflx_glacial USE module_sf_bep, only: bep USE module_sf_bep_bem, only: bep_bem -#ifdef WRF_CHEM + USE module_ra_gfdleta, only: cal_mon_day +#if ( WRF_CHEM == 1 ) USE module_data_gocart_dust #endif !------------------------------- @@ -54,6 +55,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & its,ite, jts,jte, kts,kte, & sf_urban_physics, & CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF, & + CMGR_SFCDIF,CHGR_SFCDIF, & !Optional Urban TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !H urban UC_URB2D, & !H urban @@ -67,6 +69,10 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & XLAT_URB2D, & !I urban num_roof_layers, num_wall_layers, & !I urban num_road_layers, DZR, DZB, DZG, & !I urban + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !H urban + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !H urban + FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !H urban + julian, julyr, & !H urban FRC_URB2D,UTYPE_URB2D, & !O num_urban_layers, & !I multi-layer urban num_urban_hi, & !I multi-layer urban @@ -230,6 +236,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & INTEGER, INTENT(IN ) :: sf_urban_physics !urban INTEGER, INTENT(IN ) :: isurban INTEGER, INTENT(IN ) :: isice + INTEGER, INTENT(IN ) :: julian, julyr !urban !added by Wei Yu for routing REAL, DIMENSION( ims:ime, jms:jme ) , & @@ -330,6 +337,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMGR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHGR_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF ! Local variables (moved here from driver to make routine thread safe, 20031007 jm) @@ -453,6 +462,34 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL, DIMENSION(1:num_wall_layers) :: TBL_URB ! wall layer temp [K] REAL, DIMENSION(1:num_road_layers) :: TGL_URB ! road layer temp [K] LOGICAL :: LSOLAR_URB + +!===Yang,2014/10/08,hydrological variable for single layer UCM=== + INTEGER :: jmonth, jday, tloc + INTEGER :: IRIOPTION, USOIL, DSOIL + REAL :: AOASIS, OMG + REAL :: DRELR_URB + REAL :: DRELB_URB + REAL :: DRELG_URB + REAL :: FLXHUMR_URB + REAL :: FLXHUMB_URB + REAL :: FLXHUMG_URB + REAL :: CMCR_URB + REAL :: TGR_URB + REAL, DIMENSION(1:num_roof_layers) :: SMR_URB ! green roof layer moisture + REAL, DIMENSION(1:num_roof_layers) :: TGRL_URB ! green roof layer temp [K] + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TGRL_URB3D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: SMR_URB3D + + ! state variable surface_driver <--> lsm <--> urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D @@ -581,7 +618,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL, DIMENSION(its:ite,jts:jte) ::GRDFLX_URB REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM REAL :: r1,r2,r3 - REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB + REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB, CMGR_URB, CHGR_URB REAL :: frc_urb,lb_urb REAL :: check ! ---------------------------------------------------------------------- @@ -845,6 +882,42 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDIF ENDIF +!===Yang, 2014/10/08, hydrological processes for urban vegetation in single layer UCM=== + AOASIS = 1.0 + USOIL = 1 + DSOIL = 2 + IRIOPTION=IRI_SCHEME + IF(SF_URBAN_PHYSICS == 1) THEN + OMG= OMG_URB2D(I,J) + tloc=mod(int(OMG/3.14159*180./15.+12.+0.5 ),24) + if (tloc.lt.0) tloc=tloc+24 + if (tloc==0) tloc=24 + CALL cal_mon_day(julian,julyr,jmonth,jday) + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & + IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + AOASIS = oasis ! urban oasis effect + IF (IRIOPTION ==1) THEN + IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm + IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN +! IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= SMCREF +! IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= SMCREF + IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= REFSMC(ISLTYP(I,J)) + IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= REFSMC(ISLTYP(I,J)) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + + IF(SF_URBAN_PHYSICS == 2 .or. SF_URBAN_PHYSICS == 3) THEN + IF(AOASIS > 1.0) THEN + CALL wrf_error_fatal('Urban oasis option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + IF(IRIOPTION == 1) THEN + CALL wrf_error_fatal('Urban irrigation option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + ENDIF + #if 0 IF(IPRINT) THEN ! @@ -889,31 +962,31 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ELSEIF (ICE == 0) THEN ! Non-glacial land - - CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C - LOCAL, & !L - LUTYPE, SLTYPE, & !CL - LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F - DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used - TH2,Q2SAT,DQSDT2, & !I - VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I - ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S + + CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C + LOCAL, & !L + LUTYPE, SLTYPE, & !CL + LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F + DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used + TH2,Q2SAT,DQSDT2, & !I + VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I + ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,& !H - ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O - EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O - BETA,ETP,SSOIL, & !O - FLX1,FLX2,FLX3, & !O - FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA - SNOMLT,SNCOVR, & !O - RUNOFF1,RUNOFF2,RUNOFF3, & !O - RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O - SOILW,SOILM,Q1,SMAV, & !D - RDLAI2D,USEMONALB, & - SNOTIME1, & - RIBB, & - SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & + ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O + BETA,ETP,SSOIL, & !O + FLX1,FLX2,FLX3, & !O + FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA + SNOMLT,SNCOVR, & !O + RUNOFF1,RUNOFF2,RUNOFF3, & !O + RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O + SOILW,SOILM,Q1,SMAV, & !D + RDLAI2D,USEMONALB, & + SNOTIME1, & + RIBB, & + SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & sfcheadrt(i,j), & !I - INFXSRT(i,j),ETPND1 & !O + INFXSRT(i,j),ETPND1,AOASIS & !O ) #ifdef WRF_HYDRO @@ -1099,8 +1172,19 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & QC_URB = QC_URB2D(I,J) UC_URB = UC_URB2D(I,J) + TGR_URB = TGR_URB2D(I,J) + CMCR_URB = CMCR_URB2D(I,J) + FLXHUMR_URB = FLXHUMR_URB2D(I,J) + FLXHUMB_URB = FLXHUMB_URB2D(I,J) + FLXHUMG_URB = FLXHUMG_URB2D(I,J) + DRELR_URB = DRELR_URB2D(I,J) + DRELB_URB = DRELB_URB2D(I,J) + DRELG_URB = DRELG_URB2D(I,J) + DO K = 1,num_roof_layers TRL_URB(K) = TRL_URB3D(I,K,J) + SMR_URB(K) = SMR_URB3D(I,K,J) + TGRL_URB(K)= TGRL_URB3D(I,K,J) END DO DO K = 1,num_wall_layers TBL_URB(K) = TBL_URB3D(I,K,J) @@ -1116,14 +1200,14 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ! ! ! Limits to avoid dividing by small number - if (CHS(I,J) < 1.0E-02) then - CHS(I,J) = 1.0E-02 + if (CHS(I,J) < 1.0E-04) then + CHS(I,J) = 1.0E-04 endif - if (CHS2(I,J) < 1.0E-02) then - CHS2(I,J) = 1.0E-02 + if (CHS2(I,J) < 1.0E-04) then + CHS2(I,J) = 1.0E-04 endif - if (CQS2(I,J) < 1.0E-02) then - CQS2(I,J) = 1.0E-02 + if (CQS2(I,J) < 1.0E-04) then + CQS2(I,J) = 1.0E-04 endif ! CHS_URB = CHS(I,J) @@ -1131,6 +1215,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & IF (PRESENT(CMR_SFCDIF)) THEN CMR_URB = CMR_SFCDIF(I,J) CHR_URB = CHR_SFCDIF(I,J) + CMGR_URB = CMGR_SFCDIF(I,J) + CHGR_URB = CHGR_SFCDIF(I,J) CMC_URB = CMC_SFCDIF(I,J) CHC_URB = CHC_SFCDIF(I,J) ENDIF @@ -1152,7 +1238,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & end if ! ! Call urban - + CALL cal_mon_day(julian,julyr,jmonth,jday) CALL urban(LSOLAR_URB, & ! I num_roof_layers,num_wall_layers,num_road_layers, & ! C DZR,DZB,DZG, & ! C @@ -1170,7 +1256,10 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & CMR_URB, CHR_URB, CMC_URB, CHC_URB, & U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0 - hgt_urb,frc_urb,lb_urb, check) !O + hgt_urb,frc_urb,lb_urb, check,CMCR_URB,TGR_URB, & ! H + TGRL_URB,SMR_URB,CMGR_URB,CHGR_URB,jmonth, & ! H + DRELR_URB,DRELB_URB, & ! H + DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB) #if 0 IF(IPRINT) THEN @@ -1240,8 +1329,19 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & QC_URB2D(I,J) = QC_URB UC_URB2D(I,J) = UC_URB + TGR_URB2D(I,J) =TGR_URB + CMCR_URB2D(I,J)=CMCR_URB + FLXHUMR_URB2D(I,J)=FLXHUMR_URB + FLXHUMB_URB2D(I,J)=FLXHUMB_URB + FLXHUMG_URB2D(I,J)=FLXHUMG_URB + DRELR_URB2D(I,J) = DRELR_URB + DRELB_URB2D(I,J) = DRELB_URB + DRELG_URB2D(I,J) = DRELG_URB + DO K = 1,num_roof_layers TRL_URB3D(I,K,J) = TRL_URB(K) + SMR_URB3D(I,K,J) = SMR_URB(K) + TGRL_URB3D(I,K,J)= TGRL_URB(K) END DO DO K = 1,num_wall_layers TBL_URB3D(I,K,J) = TBL_URB(K) @@ -1270,6 +1370,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & IF (PRESENT(CMR_SFCDIF)) THEN CMR_SFCDIF(I,J) = CMR_URB CHR_SFCDIF(I,J) = CHR_URB + CMGR_SFCDIF(I,J) = CMGR_URB + CHGR_SFCDIF(I,J) = CHGR_URB CMC_SFCDIF(I,J) = CMC_URB CHC_SFCDIF(I,J) = CHC_URB ENDIF @@ -1555,15 +1657,18 @@ SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & CALL SOIL_VEG_GEN_PARM( MMINLU, MMINSL ) ENDIF -#ifdef WRF_CHEM -! -! need this parameter for dust parameterization in wrf/chem -! - do I=1,NSLTYPE - porosity(i)=maxsmc(i) - drypoint(i)=drysmc(i) - enddo -#endif +! GAC--> +! 20130219 - No longer need these - see module_data_gocart_dust +!#if ( WRF_CHEM == 1 ) +!! +!! need this parameter for dust parameterization in wrf/chem +!! +! do I=1,NSLTYPE +! porosity(i)=maxsmc(i) +! drypoint(i)=drysmc(i) +! enddo +!#endif +! <--GAC IF(.not.restart)THEN @@ -1732,7 +1837,7 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) LUMATCH=1 ELSE call wrf_message ( "Skipping over LUTYPE = " // TRIM ( LUTYPE ) ) - DO LC = 1, LUCATS+12 + DO LC = 1, LUCATS+14 read(19,*) ENDDO ENDIF @@ -2011,6 +2116,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & its,ite, jts,jte, kts,kte, & sf_urban_physics, & CMR_SFCDIF,CHR_SFCDIF,CMC_SFCDIF,CHC_SFCDIF, & + CMGR_SFCDIF,CHGR_SFCDIF, & !Optional Urban TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !H urban UC_URB2D, & !H urban @@ -2033,6 +2139,10 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & XLAT_URB2D, & !I urban num_roof_layers, num_wall_layers, & !I urban num_road_layers, DZR, DZB, DZG, & !I urban + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !H urban + julian,julyr, & !H urban + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !H urban + FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !H urban FRC_URB2D,UTYPE_URB2D, & !O num_urban_layers, & !I multi-layer urban num_urban_hi, & !I multi-layer urban @@ -2196,6 +2306,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & INTEGER, INTENT(IN ) :: sf_urban_physics !urban INTEGER, INTENT(IN ) :: isurban INTEGER, INTENT(IN ) :: isice + INTEGER, INTENT(IN ) :: julian,julyr !added by Wei Yu for routing REAL, DIMENSION( ims:ime, jms:jme ) , & @@ -2297,6 +2408,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMGR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHGR_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF ! Local variables (moved here from driver to make routine thread safe, 20031007 jm) @@ -2420,6 +2533,33 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL, DIMENSION(1:num_wall_layers) :: TBL_URB ! wall layer temp [K] REAL, DIMENSION(1:num_road_layers) :: TGL_URB ! road layer temp [K] LOGICAL :: LSOLAR_URB + +!===Yang,2014/10/08,hydrological variable for single layer UCM=== + INTEGER :: jmonth, jday, tloc + INTEGER :: IRIOPTION, USOIL, DSOIL + REAL :: AOASIS, OMG + REAL :: DRELR_URB + REAL :: DRELB_URB + REAL :: DRELG_URB + REAL :: FLXHUMR_URB + REAL :: FLXHUMB_URB + REAL :: FLXHUMG_URB + REAL :: CMCR_URB + REAL :: TGR_URB + REAL, DIMENSION(1:num_roof_layers) :: SMR_URB ! green roof layer moisture + REAL, DIMENSION(1:num_roof_layers) :: TGRL_URB ! green roof layer temp [K] + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TGRL_URB3D + REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: SMR_URB3D + ! state variable surface_driver <--> lsm <--> urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D @@ -2547,7 +2687,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL, DIMENSION(its:ite,jts:jte) ::GRDFLX_URB REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM REAL :: r1,r2,r3 - REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB + REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB, CMGR_URB, CHGR_URB REAL :: frc_urb,lb_urb REAL :: check ! ---------------------------------------------------------------------- @@ -2953,7 +3093,41 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDIF - ENDIF + ENDIF + +!===Yang, 2014/10/08, hydrological processes for urban vegetation in single layer UCM=== + AOASIS = 1.0 + USOIL = 1 + DSOIL = 2 + IRIOPTION=IRI_SCHEME + OMG= OMG_URB2D(I,J) + tloc=mod(int(OMG/3.14159*180./15.+12.+0.5 ),24) + if (tloc.lt.0) tloc=tloc+24 + if (tloc==0) tloc=24 + CALL cal_mon_day(julian,julyr,jmonth,jday) + IF(SF_URBAN_PHYSICS == 1) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & + IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + AOASIS = oasis ! urban oasis effect + IF (IRIOPTION ==1) THEN + IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm + IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN + IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= REFSMC(ISLTYP(I,J)) + IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= REFSMC(ISLTYP(I,J)) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + + IF(SF_URBAN_PHYSICS == 2 .or. SF_URBAN_PHYSICS == 3) THEN + IF(AOASIS > 1.0) THEN + CALL wrf_error_fatal('Urban oasis option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + IF(IRIOPTION == 1) THEN + CALL wrf_error_fatal('Urban irrigation option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + ENDIF IF( SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN ! print*, 'MOSAIC is not designed to work with SF_URBAN_PHYSICS=2 or SF_URBAN_PHYSICS=3' @@ -3005,30 +3179,30 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ! Non-glacial land - CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C - LOCAL, & !L - LUTYPE, SLTYPE, & !CL - LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F - DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used - TH2,Q2SAT,DQSDT2, & !I - VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I - ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S + CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C + LOCAL, & !L + LUTYPE, SLTYPE, & !CL + LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F + DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used + TH2,Q2SAT,DQSDT2, & !I + VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I + ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,& !H - ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O - EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O - BETA,ETP,SSOIL, & !O - FLX1,FLX2,FLX3, & !O - FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA - SNOMLT,SNCOVR, & !O - RUNOFF1,RUNOFF2,RUNOFF3, & !O - RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O - SOILW,SOILM,Q1,SMAV, & !D - RDLAI2D,USEMONALB, & - SNOTIME1, & - RIBB, & - SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & + ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O + BETA,ETP,SSOIL, & !O + FLX1,FLX2,FLX3, & !O + FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA + SNOMLT,SNCOVR, & !O + RUNOFF1,RUNOFF2,RUNOFF3, & !O + RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O + SOILW,SOILM,Q1,SMAV, & !D + RDLAI2D,USEMONALB, & + SNOTIME1, & + RIBB, & + SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & sfcheadrt(i,j), & !I - INFXSRT(i,j),ETPND1 & !O + INFXSRT(i,j),ETPND1,AOASIS & !O ) #ifdef WRF_HYDRO @@ -3243,6 +3417,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & DO K = 1,num_roof_layers TRL_URB(K) = TRL_URB3D(I,K,J) + SMR_URB(K) = SMR_URB3D(I,K,J) + TGRL_URB(K)= TGRL_URB3D(I,K,J) END DO DO K = 1,num_wall_layers TBL_URB(K) = TBL_URB3D(I,K,J) @@ -3250,6 +3426,15 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & DO K = 1,num_road_layers TGL_URB(K) = TGL_URB3D(I,K,J) END DO + + TGR_URB = TGR_URB2D(I,J) + CMCR_URB = CMCR_URB2D(I,J) + FLXHUMR_URB = FLXHUMR_URB2D(I,J) + FLXHUMB_URB = FLXHUMB_URB2D(I,J) + FLXHUMG_URB = FLXHUMG_URB2D(I,J) + DRELR_URB = DRELR_URB2D(I,J) + DRELB_URB = DRELB_URB2D(I,J) + DRELG_URB = DRELG_URB2D(I,J) XXXR_URB = XXXR_URB2D(I,J) XXXB_URB = XXXB_URB2D(I,J) @@ -3272,6 +3457,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & IF (PRESENT(CMR_SFCDIF)) THEN CMR_URB = CMR_SFCDIF(I,J) CHR_URB = CHR_SFCDIF(I,J) + CMGR_URB = CMGR_SFCDIF(I,J) + CHGR_URB = CHGR_SFCDIF(I,J) CMC_URB = CMC_SFCDIF(I,J) CHC_URB = CHC_SFCDIF(I,J) ENDIF @@ -3293,7 +3480,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & end if ! ! Call urban - + CALL cal_mon_day(julian,julyr,jmonth,jday) CALL urban(LSOLAR_URB, & ! I num_roof_layers,num_wall_layers,num_road_layers, & ! C DZR,DZB,DZG, & ! C @@ -3311,7 +3498,10 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & CMR_URB, CHR_URB, CMC_URB, CHC_URB, & U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0 - hgt_urb,frc_urb,lb_urb, check) !O + hgt_urb,frc_urb,lb_urb, check,CMCR_URB,TGR_URB, & ! H + TGRL_URB,SMR_URB,CMGR_URB,CHGR_URB,jmonth, & ! H + DRELR_URB,DRELB_URB, & ! H + DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB) #if 0 IF(IPRINT) THEN @@ -3382,6 +3572,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & DO K = 1,num_roof_layers TRL_URB3D(I,K,J) = TRL_URB(K) + SMR_URB3D(I,K,J) = SMR_URB(K) + TGRL_URB3D(I,K,J)= TGRL_URB(K) END DO DO K = 1,num_wall_layers TBL_URB3D(I,K,J) = TBL_URB(K) @@ -3389,6 +3581,16 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & DO K = 1,num_road_layers TGL_URB3D(I,K,J) = TGL_URB(K) END DO + + TGR_URB2D(I,J) =TGR_URB + CMCR_URB2D(I,J)=CMCR_URB + FLXHUMR_URB2D(I,J)=FLXHUMR_URB + FLXHUMB_URB2D(I,J)=FLXHUMB_URB + FLXHUMG_URB2D(I,J)=FLXHUMG_URB + DRELR_URB2D(I,J) = DRELR_URB + DRELB_URB2D(I,J) = DRELB_URB + DRELG_URB2D(I,J) = DRELG_URB + XXXR_URB2D(I,J) = XXXR_URB XXXB_URB2D(I,J) = XXXB_URB XXXG_URB2D(I,J) = XXXG_URB @@ -3410,6 +3612,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & IF (PRESENT(CMR_SFCDIF)) THEN CMR_SFCDIF(I,J) = CMR_URB CHR_SFCDIF(I,J) = CHR_URB + CMGR_SFCDIF(I,J) = CMGR_URB + CHGR_SFCDIF(I,J) = CHGR_URB CMC_SFCDIF(I,J) = CMC_URB CHC_SFCDIF(I,J) = CHC_URB ENDIF @@ -3769,6 +3973,42 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & VEGTYP = ISURBAN ENDIF ENDIF + + +!===Yang, 2014/10/08, hydrological processes for urban vegetation in single layer UCM=== + AOASIS = 1.0 + USOIL = 1 + DSOIL = 2 + IRIOPTION=IRI_SCHEME + OMG= OMG_URB2D(I,J) + tloc=mod(int(OMG/3.14159*180./15.+12.+0.5 ),24) + if (tloc.lt.0) tloc=tloc+24 + if (tloc==0) tloc=24 + CALL cal_mon_day(julian,julyr,jmonth,jday) + IF(SF_URBAN_PHYSICS == 1) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & + IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + AOASIS = oasis ! urban oasis effect + IF (IRIOPTION ==1) THEN + IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm + IF (jmonth==5 .or. jmonth==6 .or. jmonth==7 .or. jmonth==8 .or. jmonth==9) THEN + IF (SMC(USOIL) .LT. SMCREF) SMC(USOIL)= REFSMC(ISLTYP(I,J)) + IF (SMC(DSOIL) .LT. SMCREF) SMC(DSOIL)= REFSMC(ISLTYP(I,J)) + ENDIF + ENDIF + ENDIF + ENDIF + ENDIF + + IF(SF_URBAN_PHYSICS == 2 .or. SF_URBAN_PHYSICS == 3) THEN + IF(AOASIS > 1.0) THEN + CALL wrf_error_fatal('Urban oasis option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + IF(IRIOPTION == 1) THEN + CALL wrf_error_fatal('Urban irrigation option is for SF_URBAN_PHYSICS == 1 only') + ENDIF + ENDIF + #if 0 IF(IPRINT) THEN ! @@ -3814,30 +4054,30 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ! Non-glacial land - CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C - LOCAL, & !L - LUTYPE, SLTYPE, & !CL - LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F - DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used - TH2,Q2SAT,DQSDT2, & !I - VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I - ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S + CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C + LOCAL, & !L + LUTYPE, SLTYPE, & !CL + LWDN,SOLDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,DUMMY, & !F + DUMMY,DUMMY, DUMMY, & !F PRCPRAIN not used + TH2,Q2SAT,DQSDT2, & !I + VEGTYP,SOILTYP,SLOPETYP,SHDFAC,SHMIN,SHMAX, & !I + ALBBRD, SNOALB1,TBOT, Z0BRD, Z0K, EMISSI, EMBRD, & !S CMC,T1,STC,SMC,SWC,SNOWHK,SNEQV,ALBEDOK,CHK,dummy,& !H - ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O - EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O - BETA,ETP,SSOIL, & !O - FLX1,FLX2,FLX3, & !O - FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA - SNOMLT,SNCOVR, & !O - RUNOFF1,RUNOFF2,RUNOFF3, & !O - RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O - SOILW,SOILM,Q1,SMAV, & !D - RDLAI2D,USEMONALB, & - SNOTIME1, & - RIBB, & - SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & + ETA,SHEAT, ETA_KINEMATIC,FDOWN, & !O + EC,EDIR,ET,ETT,ESNOW,DRIP,DEW, & !O + BETA,ETP,SSOIL, & !O + FLX1,FLX2,FLX3, & !O + FLX4,FVB,FBUR,FGSN,UA_PHYS, & !UA + SNOMLT,SNCOVR, & !O + RUNOFF1,RUNOFF2,RUNOFF3, & !O + RC,PC,RSMIN,XLAI,RCS,RCT,RCQ,RCSOIL, & !O + SOILW,SOILM,Q1,SMAV, & !D + RDLAI2D,USEMONALB, & + SNOTIME1, & + RIBB, & + SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & sfcheadrt(i,j), & !I - INFXSRT(i,j),ETPND1 & !O + INFXSRT(i,j),ETPND1,AOASIS & !O ) #ifdef WRF_HYDRO @@ -4019,6 +4259,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & DO K = 1,num_roof_layers TRL_URB(K) = TRL_URB3D(I,K,J) + SMR_URB(K) = SMR_URB3D(I,K,J) + TGRL_URB(K)= TGRL_URB3D(I,K,J) END DO DO K = 1,num_wall_layers TBL_URB(K) = TBL_URB3D(I,K,J) @@ -4026,6 +4268,15 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & DO K = 1,num_road_layers TGL_URB(K) = TGL_URB3D(I,K,J) END DO + + TGR_URB = TGR_URB2D(I,J) + CMCR_URB = CMCR_URB2D(I,J) + FLXHUMR_URB = FLXHUMR_URB2D(I,J) + FLXHUMB_URB = FLXHUMB_URB2D(I,J) + FLXHUMG_URB = FLXHUMG_URB2D(I,J) + DRELR_URB = DRELR_URB2D(I,J) + DRELB_URB = DRELB_URB2D(I,J) + DRELG_URB = DRELG_URB2D(I,J) XXXR_URB = XXXR_URB2D(I,J) XXXB_URB = XXXB_URB2D(I,J) @@ -4048,6 +4299,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & IF (PRESENT(CMR_SFCDIF)) THEN CMR_URB = CMR_SFCDIF(I,J) CHR_URB = CHR_SFCDIF(I,J) + CMGR_URB = CMGR_SFCDIF(I,J) + CHGR_URB = CHGR_SFCDIF(I,J) CMC_URB = CMC_SFCDIF(I,J) CHC_URB = CHC_SFCDIF(I,J) ENDIF @@ -4069,7 +4322,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & end if ! ! Call urban - + CALL cal_mon_day(julian,julyr,jmonth,jday) CALL urban(LSOLAR_URB, & ! I num_roof_layers,num_wall_layers,num_road_layers, & ! C DZR,DZB,DZG, & ! C @@ -4087,7 +4340,10 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & CMR_URB, CHR_URB, CMC_URB, CHC_URB, & U10_URB, V10_URB, TH2_URB, Q2_URB, & ! O UST_URB,mh_urb, stdh_urb, lf_urb, lp_urb, & ! 0 - hgt_urb,frc_urb,lb_urb, check) !O + hgt_urb,frc_urb,lb_urb, check,CMCR_URB,TGR_URB, & ! H + TGRL_URB,SMR_URB,CMGR_URB,CHGR_URB,jmonth, & ! H + DRELR_URB,DRELB_URB, & ! H + DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB) #if 0 IF(IPRINT) THEN @@ -4157,6 +4413,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & DO K = 1,num_roof_layers TRL_URB3D(I,K,J) = TRL_URB(K) + SMR_URB3D(I,K,J) = SMR_URB(K) + TGRL_URB3D(I,K,J)= TGRL_URB(K) END DO DO K = 1,num_wall_layers TBL_URB3D(I,K,J) = TBL_URB(K) @@ -4164,6 +4422,16 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & DO K = 1,num_road_layers TGL_URB3D(I,K,J) = TGL_URB(K) END DO + + TGR_URB2D(I,J) =TGR_URB + CMCR_URB2D(I,J)=CMCR_URB + FLXHUMR_URB2D(I,J)=FLXHUMR_URB + FLXHUMB_URB2D(I,J)=FLXHUMB_URB + FLXHUMG_URB2D(I,J)=FLXHUMG_URB + DRELR_URB2D(I,J) = DRELR_URB + DRELB_URB2D(I,J) = DRELB_URB + DRELG_URB2D(I,J) = DRELG_URB + XXXR_URB2D(I,J) = XXXR_URB XXXB_URB2D(I,J) = XXXB_URB XXXG_URB2D(I,J) = XXXG_URB @@ -4185,6 +4453,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & IF (PRESENT(CMR_SFCDIF)) THEN CMR_SFCDIF(I,J) = CMR_URB CHR_SFCDIF(I,J) = CHR_URB + CMGR_SFCDIF(I,J) = CMGR_URB + CHGR_SFCDIF(I,J) = CHGR_URB CMC_SFCDIF(I,J) = CMC_URB CHC_SFCDIF(I,J) = CHC_URB ENDIF diff --git a/wrfv2_fire/phys/module_sf_noahlsm.F b/wrfv2_fire/phys/module_sf_noahlsm.F index d490f920..de487051 100644 --- a/wrfv2_fire/phys/module_sf_noahlsm.F +++ b/wrfv2_fire/phys/module_sf_noahlsm.F @@ -74,7 +74,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C RIBB, & SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & SFHEAD1RT, & !I - INFXS1RT,ETPND1 ) !P + INFXS1RT,ETPND1,AOASIS ) !P ! ---------------------------------------------------------------------- ! SUBROUTINE SFLX - UNIFIED NOAHLSM VERSION 1.0 JULY 2007 ! ---------------------------------------------------------------------- @@ -298,7 +298,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C REAL, INTENT(IN) :: SHDMIN,SHDMAX,DT,DQSDT2,LWDN,PRCP,PRCPRAIN, & Q2,Q2SAT,SFCPRS,SFCSPD,SFCTMP, SNOALB, & SOLDN,SOLNET,TBOT,TH2,ZLVL, & - FFROZP + FFROZP,AOASIS REAL, INTENT(OUT) :: EMBRD REAL, INTENT(OUT) :: ALBEDO REAL, INTENT(INOUT):: COSZ, SOLARDIRECT,CH,CM, & @@ -697,7 +697,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C CALL PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, & - DQSDT2,FLX2,EMISSI,SNEQV,T1,SNCOVR, & + DQSDT2,FLX2,EMISSI,SNEQV,T1,SNCOVR,AOASIS, & ALBEDO,SOLDN,FVB,GAMA,STC(1),ETPN,FLX4,UA_PHYS) ! ! ---------------------------------------------------------------------- @@ -752,7 +752,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C VEGTYP, & ETPN,FLX4,UA_PHYS, & SFHEAD1RT,INFXS1RT,ETPND1) - ETA_KINEMATIC = ESNOW + ETNS + ETA_KINEMATIC = ESNOW + ETNS - 1000.0*DEW END IF ! Calculate effective mixing ratio at grnd level (skin) @@ -2027,7 +2027,7 @@ END SUBROUTINE NOPAC SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & & Q2,Q2SAT,ETP,RCH,EPSCA,RR,SNOWNG,FRZGRA, & - & DQSDT2,FLX2,EMISSI_IN,SNEQV,T1,SNCOVR, & + & DQSDT2,FLX2,EMISSI_IN,SNEQV,T1,SNCOVR,AOASIS, & ALBEDO,SOLDN,FVB,GAMA,STC1,ETPN,FLX4,UA_PHYS) ! ---------------------------------------------------------------------- @@ -2041,7 +2041,7 @@ SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & LOGICAL, INTENT(IN) :: SNOWNG, FRZGRA REAL, INTENT(IN) :: CH, DQSDT2,FDOWN,PRCP, & Q2, Q2SAT,SSOIL, SFCPRS, SFCTMP, & - T2V, TH2,EMISSI_IN,SNEQV + T2V, TH2,EMISSI_IN,SNEQV,AOASIS REAL, INTENT(IN) :: T1 , SNCOVR REAL, INTENT(IN) :: ALBEDO,SOLDN,FVB,GAMA,STC1 LOGICAL, INTENT(IN) :: UA_PHYS @@ -2131,6 +2131,8 @@ SUBROUTINE PENMAN (SFCTMP,SFCPRS,CH,T2V,TH2,PRCP,FDOWN,T24,SSOIL, & ! A = ELCP * (Q2SAT - Q2) A = ELCP1 * (Q2SAT - Q2) EPSCA = (A * RR + RAD * DELTA) / (DELTA + RR) +! Fei-Mike + IF (EPSCA>0.) EPSCA = EPSCA * AOASIS ! ETP = EPSCA * RCH / LSUBC ETP = EPSCA * RCH / LVS @@ -3928,7 +3930,7 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) REAL, INTENT(OUT) :: DF REAL :: AKE, GAMMD, THKDRY, THKICE, THKO, & THKQTZ,THKSAT,THKS,THKW,SATRATIO,XU, & - XUNFROZ + XUNFROZ,AKEI,AKEL ! ---------------------------------------------------------------------- ! WE NOW GET QUARTZ AS AN INPUT ARGUMENT (SET IN ROUTINE REDPRM): @@ -3992,11 +3994,9 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) ! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD) ! FROZEN - IF ( (SH2O + 0.0005) < SMC ) THEN - AKE = SATRATIO + AKEI = SATRATIO ! UNFROZEN ! RANGE OF VALIDITY FOR THE KERSTEN NUMBER (AKE) - ELSE ! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT ! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) @@ -4004,16 +4004,16 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) IF ( SATRATIO > 0.1 ) THEN - AKE = LOG10 (SATRATIO) + 1.0 + AKEL = LOG10 (SATRATIO) + 1.0 ! USE K = KDRY ELSE - AKE = 0.0 + AKEL = 0.0 END IF + AKE = ((SMC-SH2O)*AKEI + SH2O*AKEL)/SMC ! THERMAL CONDUCTIVITY - END IF DF = AKE * (THKSAT - THKDRY) + THKDRY ! ---------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_sf_noahmp_glacier.F b/wrfv2_fire/phys/module_sf_noahmp_glacier.F index c8b12a82..c1e852d9 100644 --- a/wrfv2_fire/phys/module_sf_noahmp_glacier.F +++ b/wrfv2_fire/phys/module_sf_noahmp_glacier.F @@ -157,7 +157,11 @@ SUBROUTINE NOAHMP_GLACIER (& FSA ,FSR ,FIRA ,FSH ,FGEV ,SSOIL , & ! OUT : TRAD ,EDIR ,RUNSRF ,RUNSUB ,SAG ,ALBEDO , & ! OUT : QSNBOT ,PONDING ,PONDING1,PONDING2,T2M ,Q2E , & ! OUT : - EMISSI, FPICE, CH2B) ! OUT : + EMISSI, FPICE, CH2B & ! OUT : +#ifdef WRF_HYDRO + , sfcheadrt & +#endif + ) ! -------------------------------------------------------------------------------------------------- ! Initial code: Guo-Yue Niu, Oct. 2007 @@ -185,6 +189,10 @@ SUBROUTINE NOAHMP_GLACIER (& REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD!ice fraction at last timestep REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) +#ifdef WRF_HYDRO + REAL , INTENT(INOUT) :: sfcheadrt +#endif + ! input/output : need arbitary intial values REAL , INTENT(INOUT) :: QSNOW !snowfall [mm/s] REAL , INTENT(INOUT) :: SNEQVO !snow mass at last time step (mm) @@ -297,7 +305,11 @@ SUBROUTINE NOAHMP_GLACIER (& QVAP ,QDEW ,FICEOLD,ZSOIL , & !in ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ ,STC , & !inout DZSNSO ,SH2O ,SICE ,PONDING,ZSNSO , & !inout - RUNSRF ,RUNSUB ,QSNOW ,PONDING1 ,PONDING2,QSNBOT,FPICE) !out + RUNSRF ,RUNSUB ,QSNOW ,PONDING1 ,PONDING2,QSNBOT,FPICE & !out +#ifdef WRF_HYDRO + , sfcheadrt & +#endif + ) IF(MAXVAL(SICE) < 0.0001) THEN WRITE(message,*) "GLACIER HAS MELTED AT:",ILOC,JLOC," ARE YOU SURE THIS SHOULD BE A GLACIER POINT?" @@ -1912,7 +1924,11 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in QVAP ,QDEW ,FICEOLD,ZSOIL , & !in ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ ,STC , & !inout DZSNSO ,SH2O ,SICE ,PONDING,ZSNSO , & !inout - RUNSRF ,RUNSUB ,QSNOW ,PONDING1 ,PONDING2,QSNBOT,FPICE ) !out + RUNSRF ,RUNSUB ,QSNOW ,PONDING1 ,PONDING2,QSNBOT,FPICE & !out +#ifdef WRF_HYDRO + , sfcheadrt & +#endif + ) !out ! ---------------------------------------------------------------------- ! Code history: ! Initial code: Guo-Yue Niu, Oct. 2007 @@ -1967,6 +1983,10 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in REAL, DIMENSION( 1:NSOIL) :: SH2O_SAVE !soil liquid water content [m3/m3] INTEGER :: ILEV +#ifdef WRF_HYDRO + REAL , INTENT(INOUT) :: sfcheadrt +#endif + ! ---------------------------------------------------------------------- ! initialize @@ -1981,7 +2001,7 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in ! Jordan (1991) - IF(OPT_SNF == 1) THEN + IF(OPT_SNF == 1 .OR. OPT_SNF == 4) THEN IF(SFCTMP > TFRZ+2.5)THEN FPICE = 0. ELSE @@ -2015,7 +2035,7 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in ! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625 ! fresh snow density - BDFALL = MIN(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59)) + BDFALL = MIN(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59)) !MB: change to MIN v3.7 QRAIN = PRCP * (1.-FPICE) QSNOW = PRCP * FPICE @@ -2064,6 +2084,10 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in ELSE RUNSRF = RUNSRF + QSNBOT ENDIF + +#ifdef WRF_HYDRO + RUNSRF = RUNSRF + sfcheadrt/DT !sfcheadrt units (mm) +#endif REPLACE = 0.0 DO ILEV = 1,NSOIL @@ -2924,6 +2948,7 @@ SUBROUTINE ERROR_GLACIER (ILOC ,JLOC ,SWDOWN ,FSA ,FSR ,FIRA , & END_WB = SNEQV ERRWAT = END_WB-BEG_WB-(PRCP-EDIR-RUNSRF-RUNSUB)*DT +#ifndef WRF_HYDRO IF(ABS(ERRWAT) > 0.1) THEN if (ERRWAT > 0) then call wrf_message ('The model is gaining water (ERRWAT is positive)') @@ -2939,6 +2964,7 @@ SUBROUTINE ERROR_GLACIER (ILOC ,JLOC ,SWDOWN ,FSA ,FSR ,FIRA , & call wrf_message(trim(message)) call wrf_error_fatal("Water budget problem in NOAHMP GLACIER") END IF +#endif END SUBROUTINE ERROR_GLACIER ! ================================================================================================== diff --git a/wrfv2_fire/phys/module_sf_noahmp_groundwater.F b/wrfv2_fire/phys/module_sf_noahmp_groundwater.F index 0f1f6f86..70fada6f 100644 --- a/wrfv2_fire/phys/module_sf_noahmp_groundwater.F +++ b/wrfv2_fire/phys/module_sf_noahmp_groundwater.F @@ -7,8 +7,6 @@ MODULE module_sf_noahmp_groundwater ! November 2012 !=============================================================================== - USE module_sf_noahlsm, only: MAXSMC,BB,SATPSI,SATDK,WLTSMC - CONTAINS SUBROUTINE WTABLE_mmf_noahmp (NSOIL ,XLAND ,XICE ,XICE_THRESHOLD ,ISICE ,& !in @@ -21,6 +19,8 @@ SUBROUTINE WTABLE_mmf_noahmp (NSOIL ,XLAND ,XICE ,XICE_THRESHOLD ,ISI ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: BEXP, DKSAT, SMCMAX, PSISAT, SMCWLT ! SOIL DEPENDENT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -80,7 +80,7 @@ SUBROUTINE WTABLE_mmf_noahmp (NSOIL ,XLAND ,XICE ,XICE_THRESHOLD ,ISI REAL, DIMENSION( 0:NSOIL) :: ZSOIL !depth of soil layer-bottom [m] REAL, DIMENSION( 1:NSOIL) :: SMCEQ !equilibrium soil water content [m3/m3] REAL, DIMENSION( 1:NSOIL) :: SMC,SH2O - REAL :: DELTAT,RCOND,TOTWATER,SMCMAX, PSISAT, BEXP, SMCWLT ,DKSAT,PSI & + REAL :: DELTAT,RCOND,TOTWATER,PSI & ,WFLUXDEEP,WCNDDEEP,DDZ,SMCWTDMID & ,WPLUS,WMINUS REAL, DIMENSION( ims:ime, jms:jme ) :: QLAT @@ -133,11 +133,6 @@ SUBROUTINE WTABLE_mmf_noahmp (NSOIL ,XLAND ,XICE ,XICE_THRESHOLD ,ISI DO I=its,ite IF(LANDMASK(I,J).GT.0)THEN - BEXP = BB(ISLTYP(I,J)) - DKSAT = SATDK (ISLTYP(I,J)) - SMCMAX = MAXSMC(ISLTYP(I,J)) - PSISAT = -SATPSI(ISLTYP(I,J)) - SMCWLT = WLTSMC (ISLTYP(I,J)) IF(IVGTYP(I,J)==ISURBAN)THEN SMCMAX = 0.45 SMCWLT = 0.40 @@ -202,6 +197,8 @@ SUBROUTINE LATERALFLOW (ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA & ,ids,ide,jds,jde,kds,kde & ,ims,ime,jms,jme,kms,kme & ,its,ite,jts,jte,kts,kte ) +! ---------------------------------------------------------------------- + USE NOAHMP_SOIL_PARAMETERS, ONLY : DKSAT_TABLE ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -237,7 +234,7 @@ SUBROUTINE LATERALFLOW (ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA & DO J=jtsh,jteh DO I=itsh,iteh IF(FDEPTH(I,J).GT.0.)THEN - KLAT = SATDK(ISLTYP(I,J)) * KLATFACTOR(ISLTYP(I,J)) + KLAT = DKSAT_TABLE(ISLTYP(I,J)) * KLATFACTOR(ISLTYP(I,J)) IF(WTD(I,J) < -1.5)THEN KCELL(I,J) = FDEPTH(I,J) * KLAT * EXP( (WTD(I,J) + 1.5) / FDEPTH(I,J) ) ELSE diff --git a/wrfv2_fire/phys/module_sf_noahmpdrv.F b/wrfv2_fire/phys/module_sf_noahmpdrv.F index f1334be0..c511525c 100644 --- a/wrfv2_fire/phys/module_sf_noahmpdrv.F +++ b/wrfv2_fire/phys/module_sf_noahmpdrv.F @@ -2,13 +2,8 @@ MODULE module_sf_noahmpdrv !------------------------------- USE module_sf_noahmplsm - USE module_sf_urban - USE module_sf_noahdrv, ONLY : SOIL_VEG_GEN_PARM - USE module_sf_noah_seaice USE module_sf_noahmp_glacier - USE MODULE_RA_GFDLETA, ONLY: CAL_MON_DAY - USE module_sf_noahmp_groundwater, ONLY : LATERALFLOW -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_data_gocart_dust #endif !------------------------------- @@ -19,16 +14,17 @@ MODULE module_sf_noahmpdrv SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN : Time/Space-related DZ8W, DT, DZS, NSOIL, DX, & ! IN : Model configuration IVGTYP, ISLTYP, VEGFRA, VEGMAX, TMN, & ! IN : Vegetation/Soil characteristics - XLAND, XICE,XICE_THRES, ISICE, ISURBAN, & ! IN : Vegetation/Soil characteristics + XLAND, XICE,XICE_THRES, & ! IN : Vegetation/Soil characteristics IDVEG, IOPT_CRS, IOPT_BTR, IOPT_RUN, IOPT_SFC, IOPT_FRZ, & ! IN : User options IOPT_INF, IOPT_RAD, IOPT_ALB, IOPT_SNF,IOPT_TBOT, IOPT_STC, & ! IN : User options IZ0TLND, & ! IN : User options T3D, QV3D, U_PHY, V_PHY, SWDOWN, GLW, & ! IN : Forcing - P8W3D, RAINBL, & ! IN : Forcing + P8W3D,PRECIP_IN, SR, & ! IN : Forcing TSK, HFX, QFX, LH, GRDFLX, SMSTAV, & ! IN/OUT LSM eqv SMSTOT,SFCRUNOFF, UDRUNOFF, ALBEDO, SNOWC, SMOIS, & ! IN/OUT LSM eqv SH2O, TSLB, SNOW, SNOWH, CANWAT, ACSNOM, & ! IN/OUT LSM eqv ACSNOW, EMISS, QSFC, & ! IN/OUT LSM eqv + Z0, ZNT, & ! IN/OUT LSM eqv ISNOWXY, TVXY, TGXY, CANICEXY, CANLIQXY, EAHXY, & ! IN/OUT Noah MP only TAHXY, CMXY, CHXY, FWETXY, SNEQVOXY, ALBOLDXY, & ! IN/OUT Noah MP only QSNOWXY, WSLAKEXY, ZWTXY, WAXY, WTXY, TSNOXY, & ! IN/OUT Noah MP only @@ -48,7 +44,10 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN #endif ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, & + MP_RAINC, MP_RAINNC, MP_SHCV, MP_SNOW, MP_GRAUP, MP_HAIL ) +!---------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: TRANSFER_MP_PARAMETERS, CO2, O2, ISICE !---------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------- @@ -73,8 +72,6 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XLAND ! =2 ocean; =1 land/seaice REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: XICE ! fraction of grid that is seaice REAL, INTENT(IN ) :: XICE_THRES! fraction of grid determining seaice - INTEGER, INTENT(IN ) :: ISICE ! land cover category for ice - INTEGER, INTENT(IN ) :: ISURBAN ! land cover category for urban INTEGER, INTENT(IN ) :: IDVEG ! dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 INTEGER, INTENT(IN ) :: IOPT_CRS ! canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis) INTEGER, INTENT(IN ) :: IOPT_BTR ! soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB) @@ -95,7 +92,16 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SWDOWN ! solar down at surface [W m-2] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: GLW ! longwave down at surface [W m-2] REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: P8W3D ! 3D pressure, valid at interface [Pa] - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: RAINBL ! precipitation entering land model [mm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: PRECIP_IN ! total input precipitation [mm] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: SR ! frozen precipitation ratio [-] + +!Optional Detailed Precipitation Partitioning Inputs + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_RAINC ! convective precipitation entering land model [mm] ! MB/AN : v3.7 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_RAINNC ! large-scale precipitation entering land model [mm]! MB/AN : v3.7 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_SHCV ! shallow conv precip entering land model [mm] ! MB/AN : v3.7 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_SNOW ! snow precipitation entering land model [mm] ! MB/AN : v3.7 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_GRAUP ! graupel precipitation entering land model [mm] ! MB/AN : v3.7 + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ), OPTIONAL :: MP_HAIL ! hail precipitation entering land model [mm] ! MB/AN : v3.7 #ifdef WRF_HYDRO REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfcheadrt,INFXSRT,soldrain ! for WRF-Hydro #endif @@ -123,6 +129,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ACSNOW ! accumulated snow on grid REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: EMISS ! surface bulk emissivity REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QSFC ! bulk surface specific humidity + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: Z0 ! combined z0 sent to coupled model + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ZNT ! combined z0 sent to coupled model ! INOUT (with no Noah LSM equivalent) @@ -232,7 +240,14 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL :: LWDN ! longwave down at surface [W m-2] REAL :: P_ML ! pressure, valid at interface [Pa] REAL :: PSFC ! surface pressure [Pa] - REAL :: PRCP ! precipitation entering land model [mm] + REAL :: PRCP ! total precipitation entering [mm] ! MB/AN : v3.7 + REAL :: PRCPCONV ! convective precipitation entering [mm] ! MB/AN : v3.7 + REAL :: PRCPNONC ! non-convective precipitation entering [mm] ! MB/AN : v3.7 + REAL :: PRCPSHCV ! shallow convective precip entering [mm] ! MB/AN : v3.7 + REAL :: PRCPSNOW ! snow entering land model [mm] ! MB/AN : v3.7 + REAL :: PRCPGRPL ! graupel entering land model [mm] ! MB/AN : v3.7 + REAL :: PRCPHAIL ! hail entering land model [mm] ! MB/AN : v3.7 + REAL :: PRCPOTHR ! other precip, e.g. fog [mm] ! MB/AN : v3.7 ! INOUT (with generic LSM equivalent) @@ -286,6 +301,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN ! OUT (with no Noah LSM equivalent) + REAL :: Z0WRF ! combined z0 sent to coupled model REAL :: T2MV ! 2m temperature of vegetation part REAL :: T2MB ! 2m temperature of bare ground part REAL :: Q2MV ! 2m mixing ratio of vegetation part @@ -330,6 +346,10 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL :: CHUC ! under canopy exchange coefficient REAL :: CHV2 ! veg 2m exchange coefficient REAL :: CHB2 ! bare 2m exchange coefficient + REAL :: PAHV !precipitation advected heat - vegetation net (W/m2) + REAL :: PAHG !precipitation advected heat - under canopy net (W/m2) + REAL :: PAHB !precipitation advected heat - bare ground net (W/m2) + REAL :: PAH !precipitation advected heat - total (W/m2) ! Intermediate terms @@ -362,17 +382,14 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN INTEGER :: SLOPETYP LOGICAL :: IPRINT - INTEGER :: ISC ! soil color index + INTEGER :: SOILCOLOR ! soil color index INTEGER :: IST ! surface type 1-soil; 2-lake INTEGER :: YEARLEN INTEGER, PARAMETER :: NSNOW = 3 ! number of snow layers fixed to 3 - REAL, PARAMETER :: CO2 = 395.e-06 - REAL, PARAMETER :: O2 = 0.209 REAL, PARAMETER :: undefined_value = -1.E36 -! ---------------------------------------------------------------------- ! ---------------------------------------------------------------------- CALL NOAHMP_OPTIONS(IDVEG ,IOPT_CRS ,IOPT_BTR ,IOPT_RUN ,IOPT_SFC ,IOPT_FRZ , & @@ -426,15 +443,6 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN IF (XICE(I,J) >= XICE_THRES) THEN ICE = 1 ! Sea-ice point - ELSE IF ( IVGTYP(I,J) == ISICE ) THEN - ICE = -1 ! Land-ice point - ELSE - ICE=0 ! Neither sea ice or land ice. - ENDIF - - IF((XLAND(I,J)-1.5) >= 0.) CYCLE ILOOP ! Open water case - - IF ( ICE == 1) THEN SH2O (i,1:NSOIL,j) = 1.0 XLAIXY(i,j) = 0.01 @@ -443,6 +451,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN ELSE + IF((XLAND(I,J)-1.5) >= 0.) CYCLE ILOOP ! Open water case + ! 2D to 1D ! IN only @@ -464,7 +474,30 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN P_ML =(P8W3D(I,KTS+1,J)+P8W3D(I,KTS,J))*0.5 ! surface pressure defined at intermediate level [Pa] ! consistent with temperature, mixing ratio PSFC = P8W3D(I,1,J) ! surface pressure defined a full levels [Pa] - PRCP = RAINBL(I,J)/DT ! timestep precipitation [mm/s] + PRCP = PRECIP_IN (I,J) / DT ! timestep total precip rate (glacier) [mm/s]! MB: v3.7 + + IF (PRESENT(MP_RAINC) .AND. PRESENT(MP_RAINNC) .AND. PRESENT(MP_SHCV) .AND. & + PRESENT(MP_SNOW) .AND. PRESENT(MP_GRAUP) .AND. PRESENT(MP_HAIL) ) THEN + + PRCPCONV = MP_RAINC (I,J)/DT ! timestep convective precip rate [mm/s] ! MB: v3.7 + PRCPNONC = MP_RAINNC(I,J)/DT ! timestep non-convective precip rate [mm/s] ! MB: v3.7 + PRCPSHCV = MP_SHCV(I,J) /DT ! timestep shallow conv precip rate [mm/s] ! MB: v3.7 + PRCPSNOW = MP_SNOW(I,J) /DT ! timestep snow precip rate [mm/s] ! MB: v3.7 + PRCPGRPL = MP_GRAUP(I,J) /DT ! timestep graupel precip rate [mm/s] ! MB: v3.7 + PRCPHAIL = MP_HAIL(I,J) /DT ! timestep hail precip rate [mm/s] ! MB: v3.7 + + PRCPOTHR = PRCP - PRCPCONV - PRCPNONC - PRCPSHCV ! take care of other (fog) contained in rainbl + PRCPOTHR = MAX(0.0,PRCPOTHR) + PRCPNONC = PRCPNONC + PRCPOTHR + PRCPSNOW = PRCPSNOW + SR(I,J) * PRCPOTHR + ELSE + PRCPCONV = 0. + PRCPNONC = PRCP + PRCPSHCV = 0. + PRCPSNOW = SR(I,J) * PRCP + PRCPGRPL = 0. + PRCPHAIL = 0. + ENDIF ! IN/OUT fields @@ -512,6 +545,18 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN RECH = 0. DEEPRECH = 0. + SLOPETYP = 1 ! set underground runoff slope term + IST = 1 ! MP surface type: 1 = land; 2 = lake + SOILCOLOR = 4 ! soil color: assuming a middle color category ????????? + + IF(SOILTYP == 14 .AND. XICE(I,J) == 0.) THEN + IF(IPRINT) PRINT *, ' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT' + IF(IPRINT) PRINT *, i,j,'RESET SOIL in surfce.F' + SOILTYP = 7 + ENDIF + + CALL TRANSFER_MP_PARAMETERS(VEGTYP,SOILTYP,SLOPETYP,SOILCOLOR) + ! Initialized local FICEOLD = 0.0 @@ -523,21 +568,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN QC = undefined_value ! test dummy value PBLH = undefined_value ! test dummy value ! PBL height DZ8W1D = DZ8W (I,1,J) ! thickness of atmospheric layers - SLOPETYP = 1 ! set underground runoff slope term - IST = 1 ! MP surface type: 1 = land; 2 = lake - ISC = 4 ! soil color: assuming a middle color category ????????? - - IF(SOILTYP == 14 .AND. XICE(I,J) == 0.) THEN - IF(IPRINT) PRINT *, ' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT' - IF(IPRINT) PRINT *, i,j,'RESET SOIL in surfce.F' - SOILTYP = 7 - ENDIF - - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN - VEGTYP = ISURBAN - ENDIF IF(VEGTYP == 25) FVEG = 0.0 ! Set playa, lava, sand to bare IF(VEGTYP == 25) PLAI = 0.0 IF(VEGTYP == 26) FVEG = 0.0 ! hard coded for USGS @@ -545,16 +576,13 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN IF(VEGTYP == 27) FVEG = 0.0 IF(VEGTYP == 27) PLAI = 0.0 - CALL REDPRM (VEGTYP,SOILTYP,SLOPETYP,ZSOIL,NSOIL,ISURBAN) - - IF ( ICE == -1 ) THEN - - - CALL NOAHMP_OPTIONS_GLACIER(IDVEG ,IOPT_CRS ,IOPT_BTR ,IOPT_RUN ,IOPT_SFC ,IOPT_FRZ , & + IF ( VEGTYP == ISICE ) THEN + ICE = -1 ! Land-ice point + CALL NOAHMP_OPTIONS_GLACIER(IDVEG ,IOPT_CRS ,IOPT_BTR ,IOPT_RUN ,IOPT_SFC ,IOPT_FRZ , & IOPT_INF ,IOPT_RAD ,IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC ) - TBOT = MIN(TBOT,263.15) ! set deep temp to at most -10C - CALL NOAHMP_GLACIER( I, J, COSZ, NSNOW, NSOIL, DT, & ! IN : Time/Space/Model-related + TBOT = MIN(TBOT,263.15) ! set deep temp to at most -10C + CALL NOAHMP_GLACIER( I, J, COSZ, NSNOW, NSOIL, DT, & ! IN : Time/Space/Model-related T_ML, P_ML, U_ML, V_ML, Q_ML, SWDN, & ! IN : Forcing PRCP, LWDN, TBOT, Z_ML, FICEOLD, ZSOIL, & ! IN : Forcing QSNOW, SNEQVO, ALBOLD, CM, CH, ISNOW, & ! IN/OUT : @@ -563,127 +591,83 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN FSA, FSR, FIRA, FSH, FGEV, SSOIL, & ! OUT : TRAD, ESOIL, RUNSF, RUNSB, SAG, SALB, & ! OUT : QSNBOT,PONDING,PONDING1,PONDING2, T2MB, Q2MB, & ! OUT : - EMISSI, FPICE, CHB2 ) ! OUT : - - FSNO = 1.0 - TV = undefined_value ! Output from standard Noah-MP undefined for glacier points - TGB = TG - CANICE = undefined_value - CANLIQ = undefined_value - EAH = undefined_value - TAH = undefined_value - FWET = undefined_value - WSLAKE = undefined_value - ZWT = undefined_value - WA = undefined_value - WT = undefined_value - LFMASS = undefined_value - RTMASS = undefined_value - STMASS = undefined_value - WOOD = undefined_value - STBLCP = undefined_value - FASTCP = undefined_value - PLAI = undefined_value - PSAI = undefined_value - T2MV = undefined_value - Q2MV = undefined_value - NEE = undefined_value - GPP = undefined_value - NPP = undefined_value - FVEGMP = 0.0 - ECAN = undefined_value - ETRAN = undefined_value - APAR = undefined_value - PSN = undefined_value - SAV = undefined_value - RSSUN = undefined_value - RSSHA = undefined_value - BGAP = undefined_value - WGAP = undefined_value - TGV = undefined_value - CHV = undefined_value - CHB = CH - IRC = undefined_value - IRG = undefined_value - SHC = undefined_value - SHG = undefined_value - EVG = undefined_value - GHV = undefined_value - IRB = FIRA - SHB = FSH - EVB = FGEV - GHB = SSOIL - TR = undefined_value - EVC = undefined_value - CHLEAF = undefined_value - CHUC = undefined_value - CHV2 = undefined_value - FCEV = undefined_value - FCTR = undefined_value - - QFX(I,J) = ESOIL - LH (I,J) = FGEV + EMISSI, FPICE, CHB2 & ! OUT : +#ifdef WRF_HYDRO + , sfcheadrt(i,j) & +#endif + ) + + FSNO = 1.0 + TV = undefined_value ! Output from standard Noah-MP undefined for glacier points + TGB = TG + CANICE = undefined_value + CANLIQ = undefined_value + EAH = undefined_value + TAH = undefined_value + FWET = undefined_value + WSLAKE = undefined_value + ZWT = undefined_value + WA = undefined_value + WT = undefined_value + LFMASS = undefined_value + RTMASS = undefined_value + STMASS = undefined_value + WOOD = undefined_value + STBLCP = undefined_value + FASTCP = undefined_value + PLAI = undefined_value + PSAI = undefined_value + T2MV = undefined_value + Q2MV = undefined_value + NEE = undefined_value + GPP = undefined_value + NPP = undefined_value + FVEGMP = 0.0 + ECAN = undefined_value + ETRAN = undefined_value + APAR = undefined_value + PSN = undefined_value + SAV = undefined_value + RSSUN = undefined_value + RSSHA = undefined_value + BGAP = undefined_value + WGAP = undefined_value + TGV = undefined_value + CHV = undefined_value + CHB = CH + IRC = undefined_value + IRG = undefined_value + SHC = undefined_value + SHG = undefined_value + EVG = undefined_value + GHV = undefined_value + IRB = FIRA + SHB = FSH + EVB = FGEV + GHB = SSOIL + TR = undefined_value + EVC = undefined_value + CHLEAF = undefined_value + CHUC = undefined_value + CHV2 = undefined_value + FCEV = undefined_value + FCTR = undefined_value + Z0WRF = 0.002 + QFX(I,J) = ESOIL + LH (I,J) = FGEV ELSE - goto 1000 -if(i==1.and.j==8) then - print*,I , J , LAT , YEARLEN , JULIAN , COSZ - print*,'DT' - print*,DT , DX , DZ8W1D , NSOIL , ZSOIL , 3 - print*,'FVEG' - print*,FVEG , FVGMAX , VEGTYP , ISURBAN , ICE , IST - print*,ISC - print*,IZ0TLND - print*,'T_ML' - print*,T_ML , P_ML , PSFC , U_ML , V_ML , Q_ML - print*,'QC' - print*,QC , SWDN , LWDN , PRCP , TBOT , CO2PP - print*,'O2PP' - print*,O2PP , FOLN , FICEOLD , PBLH , Z_ML - print*,'ALBOLD' - print*,ALBOLD , SNEQVO - print*,'STC' - print*,STC , SMH2O , SMC , TAH , EAH , FWET - print*,'CANLIQ' - print*,CANLIQ , CANICE , TV , TG , QSFC1D , QSNOW - print*,'ISNOW' - print*,ISNOW , ZSNSO , SNDPTH , SWE , SNICE , SNLIQ - print*,'ZWT' - print*,ZWT , WA , WT , WSLAKE , LFMASS , RTMASS - print*,'STMASS' - print*,STMASS , WOOD , STBLCP , FASTCP , PLAI , PSAI - print*,'CM' - print*,CM , CH , TAUSS - print*,'FSA' - print*,FSA , FSR , FIRA , FSH , SSOIL , FCEV - print*,'FGEV' - print*,FGEV , FCTR , ECAN , ETRAN , ESOIL , TRAD - print*,'TGB' - print*, TGB , TGV , T2MV , T2MB - print*,'Q2MV' - print*, Q2MV , Q2MB , RUNSF , RUNSB , APAR - print*,'PSN' - print*,PSN , SAV , SAG , FSNO , NEE , GPP - print*,'NPP' - print*,NPP , FVEGMP , SALB , QSNBOT , PONDING , PONDING1 - print*,'PONDING2' - print*,PONDING2, RSSUN , RSSHA , BGAP , WGAP - print*,'CHV' - print*, CHV , CHB , EMISSI -end if -! stop999 -1000 continue - - CALL NOAHMP_SFLX (& + ICE=0 ! Neither sea ice or land ice. + CALL NOAHMP_SFLX (& I , J , LAT , YEARLEN , JULIAN , COSZ , & ! IN : Time/Space-related DT , DX , DZ8W1D , NSOIL , ZSOIL , NSNOW , & ! IN : Model configuration - FVEG , FVGMAX , VEGTYP , ISURBAN , ICE , IST , & ! IN : Vegetation/Soil characteristics - ISC , SMCEQ , & ! IN : Vegetation/Soil characteristics - IZ0TLND , & ! IN : User options + FVEG , FVGMAX , VEGTYP , ICE , IST , & ! IN : Vegetation/Soil characteristics + SMCEQ , & ! IN : Vegetation/Soil characteristics T_ML , P_ML , PSFC , U_ML , V_ML , Q_ML , & ! IN : Forcing - QC , SWDN , LWDN , PRCP , TBOT , CO2PP , & ! IN : Forcing - O2PP , FOLN , FICEOLD , PBLH , Z_ML , & ! IN : Forcing + QC , SWDN , LWDN , & ! IN : Forcing + PRCPCONV, PRCPNONC, PRCPSHCV, PRCPSNOW, PRCPGRPL, PRCPHAIL, & ! IN : Forcing + TBOT , CO2PP , O2PP , FOLN , FICEOLD , Z_ML , & ! IN : Forcing ALBOLD , SNEQVO , & ! IN/OUT : STC , SMH2O , SMC , TAH , EAH , FWET , & ! IN/OUT : CANLIQ , CANICE , TV , TG , QSFC1D , QSNOW , & ! IN/OUT : @@ -692,6 +676,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN STMASS , WOOD , STBLCP , FASTCP , PLAI , PSAI , & ! IN/OUT : CM , CH , TAUSS , & ! IN/OUT : SMCWTD ,DEEPRECH , RECH , & ! IN/OUT : + Z0WRF , & FSA , FSR , FIRA , FSH , SSOIL , FCEV , & ! OUT : FGEV , FCTR , ECAN , ETRAN , ESOIL , TRAD , & ! OUT : TGB , TGV , T2MV , T2MB , Q2MV , Q2MB , & ! OUT : @@ -701,7 +686,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN BGAP , WGAP , CHV , CHB , EMISSI , & ! OUT : SHG , SHC , SHB , EVG , EVB , GHV , & ! OUT : GHB , IRG , IRC , IRB , TR , EVC , & ! OUT : - CHLEAF , CHUC , CHV2 , CHB2 , FPICE & + CHLEAF , CHUC , CHV2 , CHB2 , FPICE , PAHV , & + PAHG , PAHB , PAH & #ifdef WRF_HYDRO , sfcheadrt(i,j) & #endif @@ -710,12 +696,15 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN QFX(I,J) = ECAN + ESOIL + ETRAN LH (I,J) = FCEV + FGEV + FCTR + ENDIF ! glacial split ends + #ifdef WRF_HYDRO - soldrain(i,j) = RUNSB*dt !mm , underground runoff +!AD_CHANGE: Glacier cells can produce small negative subsurface runoff for mass balance. +! This will crash channel routing, so only pass along positive runoff. + soldrain(i,j) = max(RUNSB*dt, 0.) !mm , underground runoff INFXSRT(i,j) = RUNSF*dt !mm , surface runoff #endif - ENDIF ! glacial split ends ! INPUT/OUTPUT @@ -774,6 +763,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN ! OUTPUT + Z0 (I,J) = Z0WRF + ZNT (I,J) = Z0WRF T2MVXY (I,J) = T2MV T2MBXY (I,J) = T2MB Q2MVXY (I,J) = Q2MV/(1.0 - Q2MV) ! specific humidity to mixing ratio @@ -831,13 +822,13 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN END SUBROUTINE noahmplsm !------------------------------------------------------ - SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, ISURBAN, & - TSLB , SMOIS , SH2O , DZS , FNDSOILW , FNDSNOWH , ISICE,iswater , & + SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & + TSLB , SMOIS , SH2O , DZS , FNDSOILW , FNDSNOWH , & TSK, isnowxy , tvxy ,tgxy ,canicexy , TMN, XICE, & canliqxy ,eahxy ,tahxy ,cmxy ,chxy , & fwetxy ,sneqvoxy ,alboldxy ,qsnowxy ,wslakexy ,zwtxy ,waxy , & wtxy ,tsnoxy ,zsnsoxy ,snicexy ,snliqxy ,lfmassxy ,rtmassxy , & - stmassxy ,woodxy ,stblcpxy ,fastcpxy ,xsaixy , & + stmassxy ,woodxy ,stblcpxy ,fastcpxy ,xsaixy ,lai , & !jref:start t2mvxy ,t2mbxy ,chstarxy, & !jref:end @@ -850,13 +841,19 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, ISUR wtddt ,stepwtd ,dt ,qrfsxy ,qspringsxy , qslatxy , & ! Optional groundwater fdepthxy ,ht ,riverbedxy ,eqzwt ,rivercondxy ,pexpxy ) ! Optional groundwater + USE NOAHMP_VEG_PARAMETERS + USE NOAHMP_SOIL_PARAMETERS + USE NOAHMP_RAD_PARAMETERS + + IMPLICIT NONE + ! Initializing Canopy air temperature to 287 K seems dangerous to me [KWM]. INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN) :: NSOIL, ISICE, ISWATER, ISURBAN,iopt_run + INTEGER, INTENT(IN) :: NSOIL, iopt_run LOGICAL, INTENT(IN) :: restart, & & allowed_to_read @@ -913,6 +910,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, ISUR REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: stblcpxy !stable carbon in deep soil [g/m2] REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fastcpxy !short-lived carbon, shallow soil [g/m2] REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: xsaixy !stem area index + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: lai !leaf area index ! IOPT_RUN = 5 option @@ -944,8 +942,8 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, ISUR REAL, DIMENSION(1:NSOIL) :: ZSOIL ! Depth of the soil layer bottom (m) from ! the surface (negative) - REAL :: BX, SMCMAX, PSISAT - REAL :: FK + REAL :: BEXP, SMCMAX, PSISAT + REAL :: FK, masslai,masssai REAL, PARAMETER :: BLIM = 5.5 REAL, PARAMETER :: HLICE = 3.335E5 @@ -960,14 +958,8 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, ISUR MMINSL='STAS' call read_mp_veg_parameters(trim(MMINLU)) - - ! - ! initialize three Noah LSM related tables - ! - IF ( allowed_to_read ) THEN - CALL wrf_message( 'INITIALIZE THREE Noah LSM RELATED TABLES' ) - CALL SOIL_VEG_GEN_PARM( MMINLU, MMINSL ) - ENDIF + call read_mp_soil_parameters() + call read_mp_rad_parameters() IF( .NOT. restart ) THEN @@ -1001,20 +993,23 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, ISUR CALL wrf_error_fatal( "module_sf_noahlsm.F: lsminit: out of range value "// & "of ISLTYP. Is this field in the input?" ) ENDIF -#ifdef WRF_CHEM - ! - ! need this parameter for dust parameterization in wrf/chem - ! - do I=1,NSLTYPE - porosity(i)=maxsmc(i) - enddo -#endif +! GAC-->LATERALFLOW +! 20130219 - No longer need this - see module_data_gocart_dust +!#if ( WRF_CHEM == 1 ) +! ! +! ! need this parameter for dust parameterization in wrf/chem +! ! +! do I=1,NSLTYPE +! porosity(i)=maxsmc(i) +! enddo +!#endif +! <--GAC ! initialize soil liquid water content SH2O DO J = jts , jtf DO I = its , itf - IF(IVGTYP(I,J)==ISICE .AND. XICE(I,J) <= 0.0) THEN + IF(IVGTYP(I,J)==ISICE_TABLE .AND. XICE(I,J) <= 0.0) THEN DO NS=1, NSOIL SMOIS(I,NS,J) = 1.0 ! glacier starts all frozen SH2O(I,NS,J) = 0.0 @@ -1025,17 +1020,18 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, ISUR SNOWH(I,J)=SNOW(I,J)*0.01 ! SNOW in mm and SNOWH in m ELSE - BX = BB(ISLTYP(I,J)) - SMCMAX = MAXSMC(ISLTYP(I,J)) + BEXP = BEXP_TABLE(ISLTYP(I,J)) + SMCMAX = SMCMAX_TABLE(ISLTYP(I,J)) + PSISAT = PSISAT_TABLE(ISLTYP(I,J)) + DO NS=1, NSOIL IF ( SMOIS(I,NS,J) > SMCMAX ) SMOIS(I,NS,J) = SMCMAX END DO - PSISAT = SATPSI(ISLTYP(I,J)) - IF ( ( BX > 0.0 ) .AND. ( SMCMAX > 0.0 ) .AND. ( PSISAT > 0.0 ) ) THEN + IF ( ( BEXP > 0.0 ) .AND. ( SMCMAX > 0.0 ) .AND. ( PSISAT > 0.0 ) ) THEN DO NS=1, NSOIL IF ( TSLB(I,NS,J) < 273.149 ) THEN ! Use explicit as initial soil ice FK=(( (HLICE/(GRAV*(-PSISAT))) * & - ((TSLB(I,NS,J)-T0)/TSLB(I,NS,J)) )**(-1/BX) )*SMCMAX + ((TSLB(I,NS,J)-T0)/TSLB(I,NS,J)) )**(-1/BEXP) )*SMCMAX FK = MAX(FK, 0.02) SH2O(I,NS,J) = MIN( FK, SMOIS(I,NS,J) ) ELSE @@ -1092,13 +1088,32 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, ISUR areaxy (I,J) = (DX * DY) / ( MSFTX(I,J) * MSFTY(I,J) ) endif - lfmassxy (I,J) = 50. ! - stmassxy (I,J) = 50.0 ! - rtmassxy (I,J) = 500.0 ! - woodxy (I,J) = 500.0 ! - stblcpxy (I,J) = 1000.0 ! - fastcpxy (I,J) = 1000.0 ! - xsaixy (I,J) = 0.1 ! + IF(IVGTYP(I,J) == ISBARREN_TABLE .OR. IVGTYP(I,J) == ISICE_TABLE .OR. & + IVGTYP(I,J) == ISURBAN_TABLE .OR. IVGTYP(I,J) == ISWATER_TABLE ) THEN + + lai (I,J) = 0.0 + xsaixy (I,J) = 0.0 + lfmassxy (I,J) = 0.0 + stmassxy (I,J) = 0.0 + rtmassxy (I,J) = 0.0 + woodxy (I,J) = 0.0 + stblcpxy (I,J) = 0.0 + fastcpxy (I,J) = 0.0 + + ELSE + + lai (I,J) = max(lai(i,j),0.05) ! at least start with 0.05 for arbitrary initialization (v3.7) + xsaixy (I,J) = max(0.1*lai(I,J),0.05) ! MB: arbitrarily initialize SAI using input LAI (v3.7) + masslai = 1000. / max(SLA_TABLE(IVGTYP(I,J)),1.0) ! conversion from lai to mass (v3.7) + lfmassxy (I,J) = lai(i,j)*masslai ! use LAI to initialize (v3.7) + masssai = 1000. / 3.0 ! conversion from lai to mass (v3.7) + stmassxy (I,J) = xsaixy(i,j)*masssai ! use SAI to initialize (v3.7) + rtmassxy (I,J) = 500.0 ! these are all arbitrary and probably should be + woodxy (I,J) = 500.0 ! in the table or read from initialization + stblcpxy (I,J) = 1000.0 ! + fastcpxy (I,J) = 1000.0 ! + + END IF enddo enddo @@ -1145,7 +1160,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, ISUR STEPWTD = max(STEPWTD,1) CALL groundwater_init ( & - & nsoil, zsoil , dzs ,isltyp, ivgtyp, isurban, isice ,iswater ,wtddt , & + & nsoil, zsoil , dzs ,isltyp, ivgtyp, isurban_TABLE, isice_TABLE ,iswater_TABLE ,wtddt , & & fdepthxy, ht, riverbedxy, eqzwt, rivercondxy, pexpxy , areaxy, zwtxy, & & smois,sh2o, smoiseq, smcwtdxy, deeprechxy, rechxy, qslatxy, qrfsxy, qspringsxy, & & ids,ide, jds,jde, kds,kde, & @@ -1276,6 +1291,9 @@ SUBROUTINE GROUNDWATER_INIT ( & & its,ite, jts,jte, kts,kte ) + USE NOAHMP_SOIL_PARAMETERS, ONLY : BEXP_TABLE,SMCMAX_TABLE,PSISAT_TABLE,SMCWLT_TABLE,DWSAT_TABLE,DKSAT_TABLE + USE module_sf_noahmp_groundwater, ONLY : LATERALFLOW + ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -1302,7 +1320,7 @@ SUBROUTINE GROUNDWATER_INIT ( & QSPRINGSXY ! local INTEGER :: I,J,K,ITER,itf,jtf - REAL :: BX,SMCMAX,PSISAT,SMCWLT,DWSAT,DKSAT + REAL :: BEXP,SMCMAX,PSISAT,SMCWLT,DWSAT,DKSAT REAL :: FRLIQ,SMCEQDEEP REAL :: DELTAT,RCOND REAL :: AA,BBB,CC,DD,DX,FUNC,DFUNC,DDZ,EXPON,SMC,FLUX @@ -1356,19 +1374,19 @@ SUBROUTINE GROUNDWATER_INIT ( & DO J = jts,jtf DO I = its,itf - BX = BB(ISLTYP(I,J)) - SMCMAX = MAXSMC(ISLTYP(I,J)) - SMCWLT = WLTSMC (ISLTYP(I,J)) + BEXP = BEXP_TABLE(ISLTYP(I,J)) + SMCMAX = SMCMAX_TABLE(ISLTYP(I,J)) + SMCWLT = SMCWLT_TABLE(ISLTYP(I,J)) IF(IVGTYP(I,J)==ISURBAN)THEN SMCMAX = 0.45 SMCWLT = 0.40 ENDIF - DWSAT = SATDW (ISLTYP(I,J)) - DKSAT = SATDK (ISLTYP(I,J)) - PSISAT = -SATPSI(ISLTYP(I,J)) - IF ( ( bx > 0.0 ) .AND. ( smcmax > 0.0 ) .AND. ( -psisat > 0.0 ) ) THEN + DWSAT = DWSAT_TABLE(ISLTYP(I,J)) + DKSAT = DKSAT_TABLE(ISLTYP(I,J)) + PSISAT = -PSISAT_TABLE(ISLTYP(I,J)) + IF ( ( BEXP > 0.0 ) .AND. ( smcmax > 0.0 ) .AND. ( -psisat > 0.0 ) ) THEN !initialize equilibrium soil moisture for water table diagnostic - CALL EQSMOISTURE(NSOIL , ZSOIL , SMCMAX , SMCWLT ,DWSAT, DKSAT ,BX , & !in + CALL EQSMOISTURE(NSOIL , ZSOIL , SMCMAX , SMCWLT ,DWSAT, DKSAT ,BEXP , & !in SMCEQ ) !out SMOISEQ (I,1:NSOIL,J) = SMCEQ (1:NSOIL) @@ -1380,7 +1398,7 @@ SUBROUTINE GROUNDWATER_INIT ( & !initialize deep soil moisture so that the flux compensates qlat+qrf !use Newton-Raphson method to find soil moisture - EXPON = 2. * BX + 3. + EXPON = 2. * BEXP + 3. DDZ = ZSOIL(NSOIL) - WTD(I,J) CC = PSISAT/DDZ FLUX = (QLAT(I,J)-QRF(I,J))/DELTAT @@ -1390,10 +1408,10 @@ SUBROUTINE GROUNDWATER_INIT ( & DO ITER = 1, 100 DD = (SMC+SMCMAX)/(2.*SMCMAX) AA = -DKSAT * DD ** EXPON - BBB = CC * ( (SMCMAX/SMC)**BX - 1. ) + 1. + BBB = CC * ( (SMCMAX/SMC)**BEXP - 1. ) + 1. FUNC = AA * BBB - FLUX DFUNC = -DKSAT * (EXPON/(2.*SMCMAX)) * DD ** (EXPON - 1.) * BBB & - + AA * CC * (-BX) * SMCMAX ** BX * SMC ** (-BX-1.) + + AA * CC * (-BEXP) * SMCMAX ** BEXP * SMC ** (-BEXP-1.) DX = FUNC/DFUNC SMC = SMC - DX @@ -1403,7 +1421,7 @@ SUBROUTINE GROUNDWATER_INIT ( & SMCWTDXY(I,J) = MAX(SMC,1.E-4) ELSEIF(WTD(I,J) < ZSOIL(NSOIL))THEN - SMCEQDEEP = SMCMAX * ( PSISAT / ( PSISAT - DZS(NSOIL) ) ) ** (1./BX) + SMCEQDEEP = SMCMAX * ( PSISAT / ( PSISAT - DZS(NSOIL) ) ) ** (1./BEXP) ! SMCEQDEEP = MAX(SMCEQDEEP,SMCWLT) SMCEQDEEP = MAX(SMCEQDEEP,1.E-4) SMCWTDXY(I,J) = SMCMAX * ( WTD(I,J) - (ZSOIL(NSOIL)-DZS(NSOIL))) + & diff --git a/wrfv2_fire/phys/module_sf_noahmplsm.F b/wrfv2_fire/phys/module_sf_noahmplsm.F index 1af9c19f..336656a1 100644 --- a/wrfv2_fire/phys/module_sf_noahmplsm.F +++ b/wrfv2_fire/phys/module_sf_noahmplsm.F @@ -1,131 +1,7 @@ module noahmp_globals - - ! Maybe most of these can be moved to a REDPRM use statement? - use module_sf_noahlsm, only: & - & SLCATS, & - & LUCATS, & - & CSOIL_DATA, & - & BB, & - & SATDK, & - & SATDW, & - & F11, & - & SATPSI, & - & QTZ, & - & DRYSMC, & - & MAXSMC, & - & REFSMC, & - & WLTSMC, & - & RSTBL, & - & RGLTBL, & - & HSTBL, & - & NROTBL, & - & TOPT_DATA, & - & RSMAX_DATA, & - & ZBOT_DATA, & - & CZIL_DATA, & - & FRZK_DATA, & - & SLOPE_DATA, & - & REFDK_DATA, & - & REFKDT_DATA implicit none -! ================================================================================================== -!------------------------------------------------------------------------------------------! -! Physical Constants: ! -!------------------------------------------------------------------------------------------! - - REAL, PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) - REAL, PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) - REAL, PARAMETER :: VKC = 0.40 !von Karman constant - REAL, PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) - REAL, PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) - REAL, PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) - REAL, PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) - REAL, PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) - REAL, PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) - REAL, PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) - REAL, PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) - REAL, PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) - REAL, PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) - REAL, PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) - REAL, PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) - REAL, PARAMETER :: DENH2O = 1000. !density of water (kg/m3) - REAL, PARAMETER :: DENICE = 917. !density of ice (kg/m3) - -!------------------------------------------------------------------------------------------! -! From the VEGPARM.TBL tables, as functions of vegetation category. -!------------------------------------------------------------------------------------------! - INTEGER :: NROOT !rooting depth [as the number of layers] ( Assigned in REDPRM ) - REAL :: RGL !parameter used in radiation stress function ( Assigned in REDPRM ) - REAL :: RSMIN !minimum Canopy Resistance [s/m] ( Assigned in REDPRM ) - REAL :: HS !parameter used in vapor pressure deficit function ( Assigned in REDPRM ) - REAL :: RSMAX !maximum stomatal resistance ( Assigned in REDPRM ) - REAL :: TOPT !optimum transpiration air temperature. - -!KWM CHARACTER(LEN=256) :: LUTYPE -!KWM INTEGER :: LUCATS, BARE -!KWM INTEGER, PARAMETER :: NLUS=50 -!KWM INTEGER, DIMENSION(1:NLUS) :: NROTBL -!KWM REAL, DIMENSION(1:NLUS) :: RSTBL, RGLTBL, HSTBL -!KWM REAL :: TOPT_DATA,RSMAX_DATA - -! not further used in this version (niu): - -!KWM REAL, DIMENSION(1:NLUS) :: SNUPTBL, LAITBL, & -!KWM ALBTBL, SHDTBL, MAXALB -!KWM REAL :: CMCMAX_DATA,CFACTR_DATA,SBETA_DATA,& -!KWM SALP_DATA ,SMLOW_DATA ,SMHIGH_DATA - -!KWM REAL, DIMENSION(NLUS) :: LAIMINTBL !KWM -!KWM REAL, DIMENSION(NLUS) :: LAIMAXTBL !KWM -!KWM REAL, DIMENSION(NLUS) :: EMISSMINTBL !KWM -!KWM REAL, DIMENSION(NLUS) :: EMISSMAXTBL !KWM -!KWM REAL, DIMENSION(NLUS) :: ALBEDOMINTBL !KWM -!KWM REAL, DIMENSION(NLUS) :: ALBEDOMAXTBL !KWM -!KWM REAL, DIMENSION(NLUS) :: Z0MINTBL !KWM -!KWM REAL, DIMENSION(NLUS) :: Z0MAXTBL !KWM - - -!------------------------------------------------------------------------------------------! -! From the SOILPARM.TBL tables, as functions of soil category. -!------------------------------------------------------------------------------------------! - REAL :: BEXP !B parameter ( Assigned in REDPRM ) - REAL :: SMCDRY !dry soil moisture threshold where direct evap from top - !layer ends (volumetric) ( Assigned in REDPRM ) - REAL :: F1 !soil thermal diffusivity/conductivity coef ( Assigned in REDPRM ) - REAL :: SMCMAX !porosity, saturated value of soil moisture (volumetric) - REAL :: SMCREF !reference soil moisture (field capacity) (volumetric) ( Assigned in REDPRM ) - REAL :: PSISAT !saturated soil matric potential ( Assigned in REDPRM ) - REAL :: DKSAT !saturated soil hydraulic conductivity ( Assigned in REDPRM ) - REAL :: DWSAT !saturated soil hydraulic diffusivity ( Assigned in REDPRM ) - REAL :: SMCWLT !wilting point soil moisture (volumetric) ( Assigned in REDPRM ) - REAL :: QUARTZ !soil quartz content ( Assigned in REDPRM ) - -!KWM CHARACTER*4 SLTYPE -!KWM INTEGER :: SLCATS -!KWM INTEGER, PARAMETER :: NSLTYPE=30 -!KWM REAL, DIMENSION (1:NSLTYPE) :: BB,DRYSMC,F11, & -!KWM MAXSMC, REFSMC,SATPSI,SATDK,SATDW, WLTSMC,QTZ -!------------------------------------------------------------------------------------------! -! From the GENPARM.TBL file -!------------------------------------------------------------------------------------------! - REAL :: SLOPE !slope index (0 - 1) ( Assigned in REDPRM ) - REAL :: CSOIL !vol. soil heat capacity [j/m3/K] ( Assigned in REDPRM ) - REAL :: ZBOT !Depth (m) of lower boundary soil temperature ( Assigned in REDPRM ) - REAL :: CZIL !Calculate roughness length of heat ( Assigned in REDPRM ) - - REAL :: KDT !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) - REAL :: FRZX !used in compute maximum infiltration rate (in INFIL) ( Assigned in REDPRM ) - -! LSM GENERAL PARAMETERS - -!KWM INTEGER :: SLPCATS -!KWM INTEGER, PARAMETER :: NSLOPE=30 -!KWM REAL, DIMENSION (1:NSLOPE) :: SLOPE_DATA -!KWM REAL :: FXEXP_DATA,CSOIL_DATA,REFDK_DATA , & -!KWM REFKDT_DATA,FRZK_DATA ,ZBOT_DATA ,CZIL_DATA - ! =====================================options for different schemes================================ ! options for dynamic vegetation: ! 1 -> off (use table LAI; use FVEG = SHDFAC from input) @@ -200,17 +76,6 @@ module noahmp_globals INTEGER :: OPT_STC != 1 !(suggested 1) ! ================================================================================================== -! runoff parameters used for SIMTOP and SIMGM: - REAL, PARAMETER :: TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) - REAL, PARAMETER :: FSATMX = 0.38 !maximum surface saturated fraction (global mean) - -! adjustable parameters for snow processes - - REAL, PARAMETER :: M = 2.50 !melting factor (-) - REAL, PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) - REAL, PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) - REAL, PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) - !equivalent to 10mm depth (density = 100 kg/m3) ! NOTES: things to add or improve ! 1. lake model: explicit representation of lake water storage, sunlight through lake @@ -220,154 +85,176 @@ module noahmp_globals ! 4. irrigation !------------------------------------------------------------------------------------------! END MODULE NOAHMP_GLOBALS -!------------------------------------------------------------------------------------------! -!------------------------------------------------------------------------------------------! + +! ================================================================================================== + MODULE NOAHMP_VEG_PARAMETERS IMPLICIT NONE - INTEGER, PARAMETER :: MAX_VEG_PARAMS = 33 - INTEGER, PARAMETER :: MVT = 27 - INTEGER, PARAMETER :: MBAND = 2 + INTEGER, PRIVATE, PARAMETER :: MVT = 27 + INTEGER, PRIVATE, PARAMETER :: MBAND = 2 + + INTEGER :: ISURBAN_TABLE + INTEGER :: ISWATER_TABLE + INTEGER :: ISBARREN_TABLE + INTEGER :: ISICE_TABLE + INTEGER :: EBLFOREST_TABLE + + REAL :: CH2OP_TABLE(MVT) !maximum intercepted h2o per unit lai+sai (mm) + REAL :: DLEAF_TABLE(MVT) !characteristic leaf dimension (m) + REAL :: Z0MVT_TABLE(MVT) !momentum roughness length (m) + REAL :: HVT_TABLE(MVT) !top of canopy (m) + REAL :: HVB_TABLE(MVT) !bottom of canopy (m) + REAL :: DEN_TABLE(MVT) !tree density (no. of trunks per m2) + REAL :: RC_TABLE(MVT) !tree crown radius (m) + REAL :: MFSNO_TABLE(MVT) !snowmelt curve parameter () + REAL :: SAIM_TABLE(MVT,12) !monthly stem area index, one-sided + REAL :: LAIM_TABLE(MVT,12) !monthly leaf area index, one-sided + REAL :: SLA_TABLE(MVT) !single-side leaf area per Kg [m2/kg] + REAL :: DILEFC_TABLE(MVT) !coeficient for leaf stress death [1/s] + REAL :: DILEFW_TABLE(MVT) !coeficient for leaf stress death [1/s] + REAL :: FRAGR_TABLE(MVT) !fraction of growth respiration !original was 0.3 + REAL :: LTOVRC_TABLE(MVT) !leaf turnover [1/s] + + REAL :: C3PSN_TABLE(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 + REAL :: KC25_TABLE(MVT) !co2 michaelis-menten constant at 25c (pa) + REAL :: AKC_TABLE(MVT) !q10 for kc25 + REAL :: KO25_TABLE(MVT) !o2 michaelis-menten constant at 25c (pa) + REAL :: AKO_TABLE(MVT) !q10 for ko25 + REAL :: VCMX25_TABLE(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + REAL :: AVCMX_TABLE(MVT) !q10 for vcmx25 + REAL :: BP_TABLE(MVT) !minimum leaf conductance (umol/m**2/s) + REAL :: MP_TABLE(MVT) !slope of conductance-to-photosynthesis relationship + REAL :: QE25_TABLE(MVT) !quantum efficiency at 25c (umol co2 / umol photon) + REAL :: AQE_TABLE(MVT) !q10 for qe25 + REAL :: RMF25_TABLE(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) + REAL :: RMS25_TABLE(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: RMR25_TABLE(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: ARM_TABLE(MVT) !q10 for maintenance respiration + REAL :: FOLNMX_TABLE(MVT) !foliage nitrogen concentration when f(n)=1 (%) + REAL :: TMIN_TABLE(MVT) !minimum temperature for photosynthesis (k) + + REAL :: XL_TABLE(MVT) !leaf/stem orientation index + REAL :: RHOL_TABLE(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir + REAL :: RHOS_TABLE(MVT,MBAND) !stem reflectance: 1=vis, 2=nir + REAL :: TAUL_TABLE(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir + REAL :: TAUS_TABLE(MVT,MBAND) !stem transmittance: 1=vis, 2=nir + + REAL :: MRP_TABLE(MVT) !microbial respiration parameter (umol co2 /kg c/ s) + REAL :: CWPVT_TABLE(MVT) !empirical canopy wind parameter + + REAL :: WRRAT_TABLE(MVT) !wood to non-wood ratio + REAL :: WDPOOL_TABLE(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] + REAL :: TDLEF_TABLE(MVT) !characteristic T for leaf freezing [K] + + REAL :: NROOT_TABLE(MVT) !number of soil layers with root present + REAL :: RGL_TABLE(MVT) !Parameter used in radiation stress function + REAL :: RS_TABLE(MVT) !Minimum stomatal resistance [s m-1] + REAL :: HS_TABLE(MVT) !Parameter used in vapor pressure deficit function + REAL :: TOPT_TABLE(MVT) !Optimum transpiration air temperature [K] + REAL :: RSMAX_TABLE(MVT) !Maximal stomatal resistance [s m-1] INTEGER, PRIVATE :: ISURBAN - INTEGER :: ISWATER - INTEGER :: ISBARREN - INTEGER :: ISSNOW - INTEGER :: EBLFOREST - - REAL :: CH2OP(MVT) !maximum intercepted h2o per unit lai+sai (mm) - REAL :: DLEAF(MVT) !characteristic leaf dimension (m) - REAL :: Z0MVT(MVT) !momentum roughness length (m) - REAL :: HVT(MVT) !top of canopy (m) - REAL :: HVB(MVT) !bottom of canopy (m) - REAL :: DEN(MVT) !tree density (no. of trunks per m2) - REAL :: RC(MVT) !tree crown radius (m) - REAL :: SAIM(MVT,12) !monthly stem area index, one-sided - REAL :: LAIM(MVT,12) !monthly leaf area index, one-sided - REAL :: SLA(MVT) !single-side leaf area per Kg [m2/kg] - REAL :: DILEFC(MVT) !coeficient for leaf stress death [1/s] - REAL :: DILEFW(MVT) !coeficient for leaf stress death [1/s] - REAL :: FRAGR(MVT) !fraction of growth respiration !original was 0.3 - REAL :: LTOVRC(MVT) !leaf turnover [1/s] - - REAL :: C3PSN(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 - REAL :: KC25(MVT) !co2 michaelis-menten constant at 25c (pa) - REAL :: AKC(MVT) !q10 for kc25 - REAL :: KO25(MVT) !o2 michaelis-menten constant at 25c (pa) - REAL :: AKO(MVT) !q10 for ko25 - REAL :: VCMX25(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) - REAL :: AVCMX(MVT) !q10 for vcmx25 - REAL :: BP(MVT) !minimum leaf conductance (umol/m**2/s) - REAL :: MP(MVT) !slope of conductance-to-photosynthesis relationship - REAL :: QE25(MVT) !quantum efficiency at 25c (umol co2 / umol photon) - REAL :: AQE(MVT) !q10 for qe25 - REAL :: RMF25(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) - REAL :: RMS25(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) - REAL :: RMR25(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) - REAL :: ARM(MVT) !q10 for maintenance respiration - REAL :: FOLNMX(MVT) !foliage nitrogen concentration when f(n)=1 (%) - REAL :: TMIN(MVT) !minimum temperature for photosynthesis (k) - - REAL :: XL(MVT) !leaf/stem orientation index - REAL :: RHOL(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir - REAL :: RHOS(MVT,MBAND) !stem reflectance: 1=vis, 2=nir - REAL :: TAUL(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir - REAL :: TAUS(MVT,MBAND) !stem transmittance: 1=vis, 2=nir - - REAL :: MRP(MVT) !microbial respiration parameter (umol co2 /kg c/ s) - REAL :: CWPVT(MVT) !empirical canopy wind parameter - - REAL :: WRRAT(MVT) !wood to non-wood ratio - REAL :: WDPOOL(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] - REAL :: TDLEF(MVT) !characteristic T for leaf freezing [K] - - INTEGER :: IK,IM - REAL :: TMP10(MVT*MBAND) - REAL :: TMP11(MVT*MBAND) - REAL :: TMP12(MVT*MBAND) - REAL :: TMP13(MVT*MBAND) - REAL :: TMP14(MVT*12) - REAL :: TMP15(MVT*12) - REAL :: TMP16(MVT*5) - - real slarea(MVT) - real eps(MVT,5) - + INTEGER, PRIVATE :: ISWATER + INTEGER, PRIVATE :: ISBARREN + INTEGER, PRIVATE :: ISICE + INTEGER, PRIVATE :: EBLFOREST + + REAL, DIMENSION(MVT), PRIVATE :: SAI_JAN,SAI_FEB,SAI_MAR,SAI_APR,SAI_MAY,SAI_JUN, & + SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC + REAL, DIMENSION(MVT), PRIVATE :: LAI_JAN,LAI_FEB,LAI_MAR,LAI_APR,LAI_MAY,LAI_JUN, & + LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC + REAL, DIMENSION(MVT), PRIVATE :: RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, & + TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR + REAL, DIMENSION(MVT), PRIVATE :: CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, & + AVCMX, AQE, LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , & + BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & + SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 + CONTAINS + subroutine read_mp_veg_parameters(DATASET_IDENTIFIER) implicit none character(len=*), intent(in) :: DATASET_IDENTIFIER integer :: ierr - - ! Temporary arrays used in reshaping namelist arrays - REAL :: TMP10(MVT*MBAND) - REAL :: TMP11(MVT*MBAND) - REAL :: TMP12(MVT*MBAND) - REAL :: TMP13(MVT*MBAND) - REAL :: TMP14(MVT*12) - REAL :: TMP15(MVT*12) - REAL :: TMP16(MVT*5) + INTEGER :: IK,IM integer :: NVEG character(len=256) :: VEG_DATASET_DESCRIPTION NAMELIST / noah_mp_usgs_veg_categories / VEG_DATASET_DESCRIPTION, NVEG - NAMELIST / noah_mp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISSNOW, EBLFOREST, & - CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, RHOL, RHOS, TAUL, TAUS, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & + NAMELIST / noah_mp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, EBLFOREST, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, & - FOLNMX, WDPOOL, WRRAT, MRP, SAIM, LAIM, SLAREA, EPS - + FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & + SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN,SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC, & + LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN,LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC, & + RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR, SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 + NAMELIST / noah_mp_modis_veg_categories / VEG_DATASET_DESCRIPTION, NVEG - NAMELIST / noah_mp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISSNOW, EBLFOREST, & - CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, RHOL, RHOS, TAUL, TAUS, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & + NAMELIST / noah_mp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, EBLFOREST, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, & - FOLNMX, WDPOOL, WRRAT, MRP, SAIM, LAIM, SLAREA, EPS + FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & + SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN,SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC, & + LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN,LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC, & + RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR, SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. - CH2OP = -1.E36 - DLEAF = -1.E36 - Z0MVT = -1.E36 - HVT = -1.E36 - HVB = -1.E36 - DEN = -1.E36 - RC = -1.E36 - RHOL = -1.E36 - RHOS = -1.E36 - TAUL = -1.E36 - TAUS = -1.E36 - XL = -1.E36 - CWPVT = -1.E36 - C3PSN = -1.E36 - KC25 = -1.E36 - AKC = -1.E36 - KO25 = -1.E36 - AKO = -1.E36 - AVCMX = -1.E36 - AQE = -1.E36 - LTOVRC = -1.E36 - DILEFC = -1.E36 - DILEFW = -1.E36 - RMF25 = -1.E36 - SLA = -1.E36 - FRAGR = -1.E36 - TMIN = -1.E36 - VCMX25 = -1.E36 - TDLEF = -1.E36 - BP = -1.E36 - MP = -1.E36 - QE25 = -1.E36 - RMS25 = -1.E36 - RMR25 = -1.E36 - ARM = -1.E36 - FOLNMX = -1.E36 - WDPOOL = -1.E36 - WRRAT = -1.E36 - MRP = -1.E36 - SAIM = -1.E36 - LAIM = -1.E36 - SLAREA = -1.E36 - EPS = -1.E36 + CH2OP_TABLE = -1.E36 + DLEAF_TABLE = -1.E36 + Z0MVT_TABLE = -1.E36 + HVT_TABLE = -1.E36 + HVB_TABLE = -1.E36 + DEN_TABLE = -1.E36 + RC_TABLE = -1.E36 + MFSNO_TABLE = -1.E36 + RHOL_TABLE = -1.E36 + RHOS_TABLE = -1.E36 + TAUL_TABLE = -1.E36 + TAUS_TABLE = -1.E36 + XL_TABLE = -1.E36 + CWPVT_TABLE = -1.E36 + C3PSN_TABLE = -1.E36 + KC25_TABLE = -1.E36 + AKC_TABLE = -1.E36 + KO25_TABLE = -1.E36 + AKO_TABLE = -1.E36 + AVCMX_TABLE = -1.E36 + AQE_TABLE = -1.E36 + LTOVRC_TABLE = -1.E36 + DILEFC_TABLE = -1.E36 + DILEFW_TABLE = -1.E36 + RMF25_TABLE = -1.E36 + SLA_TABLE = -1.E36 + FRAGR_TABLE = -1.E36 + TMIN_TABLE = -1.E36 + VCMX25_TABLE = -1.E36 + TDLEF_TABLE = -1.E36 + BP_TABLE = -1.E36 + MP_TABLE = -1.E36 + QE25_TABLE = -1.E36 + RMS25_TABLE = -1.E36 + RMR25_TABLE = -1.E36 + ARM_TABLE = -1.E36 + FOLNMX_TABLE = -1.E36 + WDPOOL_TABLE = -1.E36 + WRRAT_TABLE = -1.E36 + MRP_TABLE = -1.E36 + SAIM_TABLE = -1.E36 + LAIM_TABLE = -1.E36 + NROOT_TABLE = -1.E36 + RGL_TABLE = -1.E36 + RS_TABLE = -1.E36 + HS_TABLE = -1.E36 + TOPT_TABLE = -1.E36 + RSMAX_TABLE = -1.E36 + ISURBAN_TABLE = -99999 + ISWATER_TABLE = -99999 + ISBARREN_TABLE = -99999 + ISICE_TABLE = -99999 + EBLFOREST_TABLE = -99999 open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) if (ierr /= 0) then @@ -391,84 +278,599 @@ subroutine read_mp_veg_parameters(DATASET_IDENTIFIER) endif close(15) - ! Problem. Namelist reading of 2-d arrays doesn't work well when the arrays are declared with larger dimension than the - ! variables in the provided namelist. So we need to reshape the 2-d arrays after we've read them. - - if ( MVT > NVEG ) then - - ! - ! Reshape the 2-d arrays: - ! - - TMP10 = reshape( RHOL, (/ MVT*size(RHOL,2) /)) - TMP11 = reshape( RHOS, (/ MVT*size(RHOS,2) /)) - TMP12 = reshape( TAUL, (/ MVT*size(TAUL,2) /)) - TMP13 = reshape( TAUS, (/ MVT*size(TAUS,2) /)) - TMP14 = reshape( SAIM, (/ MVT*size(SAIM,2) /)) - TMP15 = reshape( LAIM, (/ MVT*size(LAIM,2) /)) - TMP16 = reshape( EPS, (/ MVT*size(EPS ,2) /)) - - RHOL(1:NVEG,:) = reshape( TMP10, (/ NVEG, size(RHOL,2) /)) - RHOS(1:NVEG,:) = reshape( TMP11, (/ NVEG, size(RHOS,2) /)) - TAUL(1:NVEG,:) = reshape( TMP12, (/ NVEG, size(TAUL,2) /)) - TAUS(1:NVEG,:) = reshape( TMP13, (/ NVEG, size(TAUS,2) /)) - SAIM(1:NVEG,:) = reshape( TMP14, (/ NVEG, size(SAIM,2) /)) - LAIM(1:NVEG,:) = reshape( TMP15, (/ NVEG, size(LAIM,2) /)) - EPS(1:NVEG,:) = reshape( TMP16, (/ NVEG, size(EPS,2) /)) - - RHOL(NVEG+1:MVT,:) = -1.E36 - RHOS(NVEG+1:MVT,:) = -1.E36 - TAUL(NVEG+1:MVT,:) = -1.E36 - TAUS(NVEG+1:MVT,:) = -1.E36 - SAIM(NVEG+1:MVT,:) = -1.E36 - LAIM(NVEG+1:MVT,:) = -1.E36 - EPS( NVEG+1:MVT,:) = -1.E36 - endif + ISURBAN_TABLE = ISURBAN + ISWATER_TABLE = ISWATER + ISBARREN_TABLE = ISBARREN + ISICE_TABLE = ISICE + EBLFOREST_TABLE = EBLFOREST + + CH2OP_TABLE(1:NVEG) = CH2OP(1:NVEG) + DLEAF_TABLE(1:NVEG) = DLEAF(1:NVEG) + Z0MVT_TABLE(1:NVEG) = Z0MVT(1:NVEG) + HVT_TABLE(1:NVEG) = HVT(1:NVEG) + HVB_TABLE(1:NVEG) = HVB(1:NVEG) + DEN_TABLE(1:NVEG) = DEN(1:NVEG) + RC_TABLE(1:NVEG) = RC(1:NVEG) + MFSNO_TABLE(1:NVEG) = MFSNO(1:NVEG) + XL_TABLE(1:NVEG) = XL(1:NVEG) + CWPVT_TABLE(1:NVEG) = CWPVT(1:NVEG) + C3PSN_TABLE(1:NVEG) = C3PSN(1:NVEG) + KC25_TABLE(1:NVEG) = KC25(1:NVEG) + AKC_TABLE(1:NVEG) = AKC(1:NVEG) + KO25_TABLE(1:NVEG) = KO25(1:NVEG) + AKO_TABLE(1:NVEG) = AKO(1:NVEG) + AVCMX_TABLE(1:NVEG) = AVCMX(1:NVEG) + AQE_TABLE(1:NVEG) = AQE(1:NVEG) + LTOVRC_TABLE(1:NVEG) = LTOVRC(1:NVEG) + DILEFC_TABLE(1:NVEG) = DILEFC(1:NVEG) + DILEFW_TABLE(1:NVEG) = DILEFW(1:NVEG) + RMF25_TABLE(1:NVEG) = RMF25(1:NVEG) + SLA_TABLE(1:NVEG) = SLA(1:NVEG) + FRAGR_TABLE(1:NVEG) = FRAGR(1:NVEG) + TMIN_TABLE(1:NVEG) = TMIN(1:NVEG) + VCMX25_TABLE(1:NVEG) = VCMX25(1:NVEG) + TDLEF_TABLE(1:NVEG) = TDLEF(1:NVEG) + BP_TABLE(1:NVEG) = BP(1:NVEG) + MP_TABLE(1:NVEG) = MP(1:NVEG) + QE25_TABLE(1:NVEG) = QE25(1:NVEG) + RMS25_TABLE(1:NVEG) = RMS25(1:NVEG) + RMR25_TABLE(1:NVEG) = RMR25(1:NVEG) + ARM_TABLE(1:NVEG) = ARM(1:NVEG) + FOLNMX_TABLE(1:NVEG) = FOLNMX(1:NVEG) + WDPOOL_TABLE(1:NVEG) = WDPOOL(1:NVEG) + WRRAT_TABLE(1:NVEG) = WRRAT(1:NVEG) + MRP_TABLE(1:NVEG) = MRP(1:NVEG) + NROOT_TABLE(1:NVEG) = NROOT(1:NVEG) + RGL_TABLE(1:NVEG) = RGL(1:NVEG) + RS_TABLE(1:NVEG) = RS(1:NVEG) + HS_TABLE(1:NVEG) = HS(1:NVEG) + TOPT_TABLE(1:NVEG) = TOPT(1:NVEG) + RSMAX_TABLE(1:NVEG) = RSMAX(1:NVEG) + + ! Put LAI and SAI into 2d array from monthly lines in table; same for canopy radiation properties + + SAIM_TABLE(1:NVEG, 1) = SAI_JAN(1:NVEG) + SAIM_TABLE(1:NVEG, 2) = SAI_FEB(1:NVEG) + SAIM_TABLE(1:NVEG, 3) = SAI_MAR(1:NVEG) + SAIM_TABLE(1:NVEG, 4) = SAI_APR(1:NVEG) + SAIM_TABLE(1:NVEG, 5) = SAI_MAY(1:NVEG) + SAIM_TABLE(1:NVEG, 6) = SAI_JUN(1:NVEG) + SAIM_TABLE(1:NVEG, 7) = SAI_JUL(1:NVEG) + SAIM_TABLE(1:NVEG, 8) = SAI_AUG(1:NVEG) + SAIM_TABLE(1:NVEG, 9) = SAI_SEP(1:NVEG) + SAIM_TABLE(1:NVEG,10) = SAI_OCT(1:NVEG) + SAIM_TABLE(1:NVEG,11) = SAI_NOV(1:NVEG) + SAIM_TABLE(1:NVEG,12) = SAI_DEC(1:NVEG) + + LAIM_TABLE(1:NVEG, 1) = LAI_JAN(1:NVEG) + LAIM_TABLE(1:NVEG, 2) = LAI_FEB(1:NVEG) + LAIM_TABLE(1:NVEG, 3) = LAI_MAR(1:NVEG) + LAIM_TABLE(1:NVEG, 4) = LAI_APR(1:NVEG) + LAIM_TABLE(1:NVEG, 5) = LAI_MAY(1:NVEG) + LAIM_TABLE(1:NVEG, 6) = LAI_JUN(1:NVEG) + LAIM_TABLE(1:NVEG, 7) = LAI_JUL(1:NVEG) + LAIM_TABLE(1:NVEG, 8) = LAI_AUG(1:NVEG) + LAIM_TABLE(1:NVEG, 9) = LAI_SEP(1:NVEG) + LAIM_TABLE(1:NVEG,10) = LAI_OCT(1:NVEG) + LAIM_TABLE(1:NVEG,11) = LAI_NOV(1:NVEG) + LAIM_TABLE(1:NVEG,12) = LAI_DEC(1:NVEG) + + RHOL_TABLE(1:NVEG,1) = RHOL_VIS(1:NVEG) !leaf reflectance: 1=vis, 2=nir + RHOL_TABLE(1:NVEG,2) = RHOL_NIR(1:NVEG) !leaf reflectance: 1=vis, 2=nir + RHOS_TABLE(1:NVEG,1) = RHOS_VIS(1:NVEG) !stem reflectance: 1=vis, 2=nir + RHOS_TABLE(1:NVEG,2) = RHOS_NIR(1:NVEG) !stem reflectance: 1=vis, 2=nir + TAUL_TABLE(1:NVEG,1) = TAUL_VIS(1:NVEG) !leaf transmittance: 1=vis, 2=nir + TAUL_TABLE(1:NVEG,2) = TAUL_NIR(1:NVEG) !leaf transmittance: 1=vis, 2=nir + TAUS_TABLE(1:NVEG,1) = TAUS_VIS(1:NVEG) !stem transmittance: 1=vis, 2=nir + TAUS_TABLE(1:NVEG,2) = TAUS_NIR(1:NVEG) !stem transmittance: 1=vis, 2=nir end subroutine read_mp_veg_parameters END MODULE NOAHMP_VEG_PARAMETERS + ! ================================================================================================== + +MODULE NOAHMP_SOIL_PARAMETERS + + IMPLICIT NONE + + INTEGER, PARAMETER :: MAX_SOILTYP = 30 + + INTEGER :: SLCATS + + REAL :: BEXP_TABLE(MAX_SOILTYP) !maximum intercepted h2o per unit lai+sai (mm) + REAL :: SMCDRY_TABLE(MAX_SOILTYP) !characteristic leaf dimension (m) + REAL :: F1_TABLE(MAX_SOILTYP) !momentum roughness length (m) + REAL :: SMCMAX_TABLE(MAX_SOILTYP) !top of canopy (m) + REAL :: SMCREF_TABLE(MAX_SOILTYP) !bottom of canopy (m) + REAL :: PSISAT_TABLE(MAX_SOILTYP) !tree density (no. of trunks per m2) + REAL :: DKSAT_TABLE(MAX_SOILTYP) !tree crown radius (m) + REAL :: DWSAT_TABLE(MAX_SOILTYP) !monthly stem area index, one-sided + REAL :: SMCWLT_TABLE(MAX_SOILTYP) !monthly leaf area index, one-sided + REAL :: QUARTZ_TABLE(MAX_SOILTYP) !single-side leaf area per Kg [m2/kg] + + REAL :: SLOPE_TABLE(9) !slope factor for soil drainage + + REAL :: CSOIL_TABLE !Soil heat capacity [J m-3 K-1] + REAL :: REFDK_TABLE !Parameter in the surface runoff parameterization + REAL :: REFKDT_TABLE !Parameter in the surface runoff parameterization + REAL :: FRZK_TABLE !Frozen ground parameter + REAL :: ZBOT_TABLE !Depth [m] of lower boundary soil temperature + REAL :: CZIL_TABLE !Parameter used in the calculation of the roughness length for heat + +CONTAINS + + subroutine read_mp_soil_parameters() + IMPLICIT NONE + INTEGER :: IERR + CHARACTER*4 :: SLTYPE + INTEGER :: ITMP, NUM_SLOPE, LC + CHARACTER(len=256) :: message + + + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + BEXP_TABLE = -1.E36 + SMCDRY_TABLE = -1.E36 + F1_TABLE = -1.E36 + SMCMAX_TABLE = -1.E36 + SMCREF_TABLE = -1.E36 + PSISAT_TABLE = -1.E36 + DKSAT_TABLE = -1.E36 + DWSAT_TABLE = -1.E36 + SMCWLT_TABLE = -1.E36 + QUARTZ_TABLE = -1.E36 + SLOPE_TABLE = -1.E36 + CSOIL_TABLE = -1.E36 + REFDK_TABLE = -1.E36 + REFKDT_TABLE = -1.E36 + FRZK_TABLE = -1.E36 + ZBOT_TABLE = -1.E36 + CZIL_TABLE = -1.E36 + +! +!-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL +! + OPEN(19, FILE='SOILPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) + IF(ierr .NE. 0 ) THEN + WRITE(message,FMT='(A)') 'module_sf_noahmpdrv.F: read_mp_soil_parameters: failure opening SOILPARM.TBL' + CALL wrf_error_fatal ( message ) + END IF + + READ (19,*) + READ (19,*) SLTYPE + READ (19,*) SLCATS + WRITE( message , * ) 'SOIL TEXTURE CLASSIFICATION = ', TRIM ( SLTYPE ) , ' FOUND', & + SLCATS,' CATEGORIES' + CALL wrf_message ( message ) + + DO LC=1,SLCATS + READ (19,*) ITMP,BEXP_TABLE(LC),SMCDRY_TABLE(LC),F1_TABLE(LC),SMCMAX_TABLE(LC), & + SMCREF_TABLE(LC),PSISAT_TABLE(LC),DKSAT_TABLE(LC), DWSAT_TABLE(LC), & + SMCWLT_TABLE(LC), QUARTZ_TABLE(LC) + ENDDO + + CLOSE (19) + +! +!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL +! + OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) + IF(ierr .NE. 0 ) THEN + WRITE(message,FMT='(A)') 'module_sf_noahlsm.F: read_mp_soil_parameters: failure opening GENPARM.TBL' + CALL wrf_error_fatal ( message ) + END IF + + READ (19,*) + READ (19,*) + READ (19,*) NUM_SLOPE + + DO LC=1,NUM_SLOPE + READ (19,*) SLOPE_TABLE(LC) + ENDDO + + READ (19,*) + READ (19,*) + READ (19,*) + READ (19,*) + READ (19,*) + READ (19,*) CSOIL_TABLE + READ (19,*) + READ (19,*) + READ (19,*) + READ (19,*) REFDK_TABLE + READ (19,*) + READ (19,*) REFKDT_TABLE + READ (19,*) + READ (19,*) FRZK_TABLE + READ (19,*) + READ (19,*) ZBOT_TABLE + READ (19,*) + READ (19,*) CZIL_TABLE + READ (19,*) + READ (19,*) + READ (19,*) + READ (19,*) + + CLOSE (19) + + end subroutine read_mp_soil_parameters + +END MODULE NOAHMP_SOIL_PARAMETERS + ! ================================================================================================== + MODULE NOAHMP_RAD_PARAMETERS IMPLICIT NONE - INTEGER I ! loop index - INTEGER, PARAMETER :: MSC = 9 - INTEGER, PARAMETER :: MBAND = 2 + INTEGER, PRIVATE, PARAMETER :: MSC = 8 + INTEGER, PRIVATE, PARAMETER :: MBAND = 2 + + REAL :: ALBSAT_TABLE(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir + REAL :: ALBDRY_TABLE(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir + REAL :: ALBICE_TABLE(MBAND) !albedo land ice: 1=vis, 2=nir + REAL :: ALBLAK_TABLE(MBAND) !albedo frozen lakes: 1=vis, 2=nir + REAL :: OMEGAS_TABLE(MBAND) !two-stream parameter omega for snow + REAL :: BETADS_TABLE !two-stream parameter betad for snow + REAL :: BETAIS_TABLE !two-stream parameter betad for snow + REAL :: EG_TABLE(2) !emissivity + + REAL, PRIVATE :: ALBICE(MBAND),ALBLAK(MBAND),OMEGAS(MBAND),BETADS,BETAIS,EG(2) + REAL, PRIVATE :: ALBSAT_VIS(MSC) + REAL, PRIVATE :: ALBSAT_NIR(MSC) + REAL, PRIVATE :: ALBDRY_VIS(MSC) + REAL, PRIVATE :: ALBDRY_NIR(MSC) - REAL :: ALBSAT(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir - REAL :: ALBDRY(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir - REAL :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir - REAL :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir - REAL :: OMEGAS(MBAND) !two-stream parameter omega for snow - REAL :: BETADS !two-stream parameter betad for snow - REAL :: BETAIS !two-stream parameter betad for snow - REAL :: EG(2) !emissivity +CONTAINS -! saturated soil albedos: 1=vis, 2=nir - DATA(ALBSAT(I,1),I=1,8)/0.15,0.11,0.10,0.09,0.08,0.07,0.06,0.05/ - DATA(ALBSAT(I,2),I=1,8)/0.30,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ + subroutine read_mp_rad_parameters() + implicit none + integer :: ierr + + NAMELIST / noah_mp_rad_parameters / ALBSAT_VIS,ALBSAT_NIR,ALBDRY_VIS,ALBDRY_NIR,ALBICE,ALBLAK,OMEGAS,BETADS,BETAIS,EG -! dry soil albedos: 1=vis, 2=nir - DATA(ALBDRY(I,1),I=1,8)/0.27,0.22,0.20,0.18,0.16,0.14,0.12,0.10/ - DATA(ALBDRY(I,2),I=1,8)/0.54,0.44,0.40,0.36,0.32,0.28,0.24,0.20/ -! albedo land ice: 1=vis, 2=nir - DATA (ALBICE(I),I=1,MBAND) /0.80, 0.55/ + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + ALBSAT_TABLE = -1.E36 + ALBDRY_TABLE = -1.E36 + ALBICE_TABLE = -1.E36 + ALBLAK_TABLE = -1.E36 + OMEGAS_TABLE = -1.E36 + BETADS_TABLE = -1.E36 + BETAIS_TABLE = -1.E36 + EG_TABLE = -1.E36 + + open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) + if (ierr /= 0) then + write(*,'("****** Error ******************************************************")') + write(*,'("Cannot find file MPTABLE.TBL")') + write(*,'("STOP")') + write(*,'("*******************************************************************")') + call wrf_error_fatal("STOP in Noah-MP read_mp_rad_parameters") + endif -! albedo frozen lakes: 1=vis, 2=nir - DATA (ALBLAK(I),I=1,MBAND) /0.60, 0.40/ + read(15,noah_mp_rad_parameters) + close(15) -! omega,betad,betai for snow - DATA (OMEGAS(I),I=1,MBAND) /0.8, 0.4/ - DATA BETADS, BETAIS /0.5, 0.5/ + ALBSAT_TABLE(:,1) = ALBSAT_VIS ! saturated soil albedos: 1=vis, 2=nir + ALBSAT_TABLE(:,2) = ALBSAT_NIR ! saturated soil albedos: 1=vis, 2=nir + ALBDRY_TABLE(:,1) = ALBDRY_VIS ! dry soil albedos: 1=vis, 2=nir + ALBDRY_TABLE(:,2) = ALBDRY_NIR ! dry soil albedos: 1=vis, 2=nir + ALBICE_TABLE = ALBICE + ALBLAK_TABLE = ALBLAK + OMEGAS_TABLE = OMEGAS + BETADS_TABLE = BETADS + BETAIS_TABLE = BETAIS + EG_TABLE = EG -! emissivity ground surface - DATA EG /0.97, 0.98/ ! 1-soil;2-lake + end subroutine read_mp_rad_parameters END MODULE NOAHMP_RAD_PARAMETERS + +! ================================================================================================== + +MODULE NOAHMP_PARAMETERS + + IMPLICIT NONE + +!------------------------------------------------------------------------------------------! +! Physical Constants: ! +!------------------------------------------------------------------------------------------! + + REAL, PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) + REAL, PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) + REAL, PARAMETER :: VKC = 0.40 !von Karman constant + REAL, PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) + REAL, PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) + REAL, PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) + REAL, PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) + REAL, PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) + REAL, PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) + REAL, PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) + REAL, PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) + REAL, PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) + REAL, PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) (not used MB: 20140718) + REAL, PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) + REAL, PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) + REAL, PARAMETER :: DENH2O = 1000. !density of water (kg/m3) + REAL, PARAMETER :: DENICE = 917. !density of ice (kg/m3) + +! atmospheric constituants + + REAL, PARAMETER :: CO2 = 395.e-06 !co2 partial pressure + REAL, PARAMETER :: O2 = 0.209 !o2 partial pressure + +! runoff parameters used for SIMTOP and SIMGM: + + REAL, PARAMETER :: TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) + REAL, PARAMETER :: FSATMX = 0.38 !maximum surface saturated fraction (global mean) + +! adjustable parameters for snow processes + +! REAL, PARAMETER :: MFSNO = 2.50 !melting factor (-) ! MB: move to MPTABLE in v3.7 + REAL, PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) + REAL, PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + REAL, PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) + !equivalent to 10mm depth (density = 100 kg/m3) + + INTEGER, PRIVATE, PARAMETER :: MVT = 27 + INTEGER, PRIVATE, PARAMETER :: MBAND = 2 +!------------------------------------------------------------------------------------------! +! From the veg section of MPTABLE.TBL +!------------------------------------------------------------------------------------------! + + INTEGER :: ISURBAN + INTEGER :: ISWATER + INTEGER :: ISBARREN + INTEGER :: ISICE + INTEGER :: EBLFOREST + + REAL :: CH2OP !maximum intercepted h2o per unit lai+sai (mm) + REAL :: DLEAF !characteristic leaf dimension (m) + REAL :: Z0MVT !momentum roughness length (m) + REAL :: HVT !top of canopy (m) + REAL :: HVB !bottom of canopy (m) + REAL :: DEN !tree density (no. of trunks per m2) + REAL :: RC !tree crown radius (m) + REAL :: MFSNO !snowmelt m parameter () + REAL :: SAIM(12) !monthly stem area index, one-sided + REAL :: LAIM(12) !monthly leaf area index, one-sided + REAL :: SLA !single-side leaf area per Kg [m2/kg] + REAL :: DILEFC !coeficient for leaf stress death [1/s] + REAL :: DILEFW !coeficient for leaf stress death [1/s] + REAL :: FRAGR !fraction of growth respiration !original was 0.3 + REAL :: LTOVRC !leaf turnover [1/s] + + REAL :: C3PSN !photosynthetic pathway: 0. = c4, 1. = c3 + REAL :: KC25 !co2 michaelis-menten constant at 25c (pa) + REAL :: AKC !q10 for kc25 + REAL :: KO25 !o2 michaelis-menten constant at 25c (pa) + REAL :: AKO !q10 for ko25 + REAL :: VCMX25 !maximum rate of carboxylation at 25c (umol co2/m**2/s) + REAL :: AVCMX !q10 for vcmx25 + REAL :: BP !minimum leaf conductance (umol/m**2/s) + REAL :: MP !slope of conductance-to-photosynthesis relationship + REAL :: QE25 !quantum efficiency at 25c (umol co2 / umol photon) + REAL :: AQE !q10 for qe25 + REAL :: RMF25 !leaf maintenance respiration at 25c (umol co2/m**2/s) + REAL :: RMS25 !stem maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: RMR25 !root maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: ARM !q10 for maintenance respiration + REAL :: FOLNMX !foliage nitrogen concentration when f(n)=1 (%) + REAL :: TMIN !minimum temperature for photosynthesis (k) + + REAL :: XL !leaf/stem orientation index + REAL :: RHOL(MBAND) !leaf reflectance: 1=vis, 2=nir + REAL :: RHOS(MBAND) !stem reflectance: 1=vis, 2=nir + REAL :: TAUL(MBAND) !leaf transmittance: 1=vis, 2=nir + REAL :: TAUS(MBAND) !stem transmittance: 1=vis, 2=nir + + REAL :: MRP !microbial respiration parameter (umol co2 /kg c/ s) + REAL :: CWPVT !empirical canopy wind parameter + + REAL :: WRRAT !wood to non-wood ratio + REAL :: WDPOOL !wood pool (switch 1 or 0) depending on woody or not [-] + REAL :: TDLEF !characteristic T for leaf freezing [K] + + INTEGER :: NROOT !number of soil layers with root present + REAL :: RGL !Parameter used in radiation stress function + REAL :: RSMIN !Minimum stomatal resistance [s m-1] + REAL :: HS !Parameter used in vapor pressure deficit function + REAL :: TOPT !Optimum transpiration air temperature [K] + REAL :: RSMAX !Maximal stomatal resistance [s m-1] + + REAL SLAREA + REAL EPS(5) + +!------------------------------------------------------------------------------------------! +! From the rad section of MPTABLE.TBL +!------------------------------------------------------------------------------------------! + + REAL :: ALBSAT(MBAND) !saturated soil albedos: 1=vis, 2=nir + REAL :: ALBDRY(MBAND) !dry soil albedos: 1=vis, 2=nir + REAL :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir + REAL :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir + REAL :: OMEGAS(MBAND) !two-stream parameter omega for snow + REAL :: BETADS !two-stream parameter betad for snow + REAL :: BETAIS !two-stream parameter betad for snow + REAL :: EG(2) !emissivity +!------------------------------------------------------------------------------------------! +! From the SOILPARM.TBL tables, as functions of soil category. +!------------------------------------------------------------------------------------------! + REAL :: BEXP !B parameter + REAL :: SMCDRY !dry soil moisture threshold where direct evap from top + !layer ends (volumetric) (not used MB: 20140718) + REAL :: SMCWLT !wilting point soil moisture (volumetric) + REAL :: SMCREF !reference soil moisture (field capacity) (volumetric) + REAL :: SMCMAX !porosity, saturated value of soil moisture (volumetric) + REAL :: F1 !soil thermal diffusivity/conductivity coef (not used MB: 20140718) + REAL :: PSISAT !saturated soil matric potential + REAL :: DKSAT !saturated soil hydraulic conductivity + REAL :: DWSAT !saturated soil hydraulic diffusivity + REAL :: QUARTZ !soil quartz content +!------------------------------------------------------------------------------------------! +! From the GENPARM.TBL file +!------------------------------------------------------------------------------------------! + REAL :: SLOPE !slope index (0 - 1) + REAL :: CSOIL !vol. soil heat capacity [j/m3/K] + REAL :: ZBOT !Depth (m) of lower boundary soil temperature + REAL :: CZIL !Calculate roughness length of heat + + REAL :: KDT !used in compute maximum infiltration rate (in INFIL) + REAL :: FRZX !used in compute maximum infiltration rate (in INFIL) + + INTEGER :: BARE + INTEGER :: NATURAL + + +CONTAINS + + SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR) + + USE NOAHMP_VEG_PARAMETERS + USE NOAHMP_SOIL_PARAMETERS + USE NOAHMP_RAD_PARAMETERS + + implicit none + + INTEGER, INTENT(INOUT) :: VEGTYPE + INTEGER, INTENT(IN) :: SOILTYPE + INTEGER, INTENT(IN) :: SLOPETYPE + INTEGER, INTENT(IN) :: SOILCOLOR + + REAL :: REFDK + REAL :: REFKDT + REAL :: FRZK + REAL :: FRZFACT + + ISURBAN = ISURBAN_TABLE + ISWATER = ISWATER_TABLE + ISBARREN = ISBARREN_TABLE + ISICE = ISICE_TABLE + EBLFOREST = EBLFOREST_TABLE + + IF( VEGTYPE == 31 .or.VEGTYPE == 32 .or. VEGTYPE == 33) THEN + VEGTYPE = ISURBAN + ENDIF + +!------------------------------------------------------------------------------------------! +! Transfer veg parameters +!------------------------------------------------------------------------------------------! + + CH2OP = CH2OP_TABLE(VEGTYPE) !maximum intercepted h2o per unit lai+sai (mm) + DLEAF = DLEAF_TABLE(VEGTYPE) !characteristic leaf dimension (m) + Z0MVT = Z0MVT_TABLE(VEGTYPE) !momentum roughness length (m) + HVT = HVT_TABLE(VEGTYPE) !top of canopy (m) + HVB = HVB_TABLE(VEGTYPE) !bottom of canopy (m) + DEN = DEN_TABLE(VEGTYPE) !tree density (no. of trunks per m2) + RC = RC_TABLE(VEGTYPE) !tree crown radius (m) + MFSNO = MFSNO_TABLE(VEGTYPE) !snowmelt m parameter () + SAIM = SAIM_TABLE(VEGTYPE,:) !monthly stem area index, one-sided + LAIM = LAIM_TABLE(VEGTYPE,:) !monthly leaf area index, one-sided + SLA = SLA_TABLE(VEGTYPE) !single-side leaf area per Kg [m2/kg] + DILEFC = DILEFC_TABLE(VEGTYPE) !coeficient for leaf stress death [1/s] + DILEFW = DILEFW_TABLE(VEGTYPE) !coeficient for leaf stress death [1/s] + FRAGR = FRAGR_TABLE(VEGTYPE) !fraction of growth respiration !original was 0.3 + LTOVRC = LTOVRC_TABLE(VEGTYPE) !leaf turnover [1/s] + + C3PSN = C3PSN_TABLE(VEGTYPE) !photosynthetic pathway: 0. = c4, 1. = c3 + KC25 = KC25_TABLE(VEGTYPE) !co2 michaelis-menten constant at 25c (pa) + AKC = AKC_TABLE(VEGTYPE) !q10 for kc25 + KO25 = KO25_TABLE(VEGTYPE) !o2 michaelis-menten constant at 25c (pa) + AKO = AKO_TABLE(VEGTYPE) !q10 for ko25 + VCMX25 = VCMX25_TABLE(VEGTYPE) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + AVCMX = AVCMX_TABLE(VEGTYPE) !q10 for vcmx25 + BP = BP_TABLE(VEGTYPE) !minimum leaf conductance (umol/m**2/s) + MP = MP_TABLE(VEGTYPE) !slope of conductance-to-photosynthesis relationship + QE25 = QE25_TABLE(VEGTYPE) !quantum efficiency at 25c (umol co2 / umol photon) + AQE = AQE_TABLE(VEGTYPE) !q10 for qe25 + RMF25 = RMF25_TABLE(VEGTYPE) !leaf maintenance respiration at 25c (umol co2/m**2/s) + RMS25 = RMS25_TABLE(VEGTYPE) !stem maintenance respiration at 25c (umol co2/kg bio/s) + RMR25 = RMR25_TABLE(VEGTYPE) !root maintenance respiration at 25c (umol co2/kg bio/s) + ARM = ARM_TABLE(VEGTYPE) !q10 for maintenance respiration + FOLNMX = FOLNMX_TABLE(VEGTYPE) !foliage nitrogen concentration when f(n)=1 (%) + TMIN = TMIN_TABLE(VEGTYPE) !minimum temperature for photosynthesis (k) + + XL = XL_TABLE(VEGTYPE) !leaf/stem orientation index + RHOL = RHOL_TABLE(VEGTYPE,:) !leaf reflectance: 1=vis, 2=nir + RHOS = RHOS_TABLE(VEGTYPE,:) !stem reflectance: 1=vis, 2=nir + TAUL = TAUL_TABLE(VEGTYPE,:) !leaf transmittance: 1=vis, 2=nir + TAUS = TAUS_TABLE(VEGTYPE,:) !stem transmittance: 1=vis, 2=nir + + MRP = MRP_TABLE(VEGTYPE) !microbial respiration parameter (umol co2 /kg c/ s) + CWPVT = CWPVT_TABLE(VEGTYPE) !empirical canopy wind parameter + + WRRAT = WRRAT_TABLE(VEGTYPE) !wood to non-wood ratio + WDPOOL = WDPOOL_TABLE(VEGTYPE) !wood pool (switch 1 or 0) depending on woody or not [-] + TDLEF = TDLEF_TABLE(VEGTYPE) !characteristic T for leaf freezing [K] + + NROOT = NROOT_TABLE(VEGTYPE) !number of soil layers with root present + RGL = RGL_TABLE(VEGTYPE) !Parameter used in radiation stress function + RSMIN = RS_TABLE(VEGTYPE) !Minimum stomatal resistance [s m-1] + HS = HS_TABLE(VEGTYPE) !Parameter used in vapor pressure deficit function + TOPT = TOPT_TABLE(VEGTYPE) !Optimum transpiration air temperature [K] + RSMAX = RSMAX_TABLE(VEGTYPE) !Maximal stomatal resistance [s m-1] + +!------------------------------------------------------------------------------------------! +! Transfer rad parameters +!------------------------------------------------------------------------------------------! + + ALBSAT = ALBSAT_TABLE(SOILCOLOR,:) + ALBDRY = ALBDRY_TABLE(SOILCOLOR,:) + ALBICE = ALBICE_TABLE + ALBLAK = ALBLAK_TABLE ! not used + OMEGAS = OMEGAS_TABLE + BETADS = BETADS_TABLE + BETAIS = BETAIS_TABLE + EG = EG_TABLE + +! ---------------------------------------------------------------------- +! Transfer soil parameters +! ---------------------------------------------------------------------- + + BEXP = BEXP_TABLE (SOILTYPE) + DKSAT = DKSAT_TABLE (SOILTYPE) + DWSAT = DWSAT_TABLE (SOILTYPE) + F1 = F1_TABLE (SOILTYPE) + PSISAT = PSISAT_TABLE (SOILTYPE) + QUARTZ = QUARTZ_TABLE (SOILTYPE) + SMCDRY = SMCDRY_TABLE (SOILTYPE) + SMCMAX = SMCMAX_TABLE (SOILTYPE) + SMCREF = SMCREF_TABLE (SOILTYPE) + SMCWLT = SMCWLT_TABLE (SOILTYPE) + +! ---------------------------------------------------------------------- +! Transfer GENPARM parameters +! ---------------------------------------------------------------------- + CSOIL = CSOIL_TABLE + ZBOT = ZBOT_TABLE + CZIL = CZIL_TABLE + + FRZK = FRZK_TABLE + REFDK = REFDK_TABLE + REFKDT = REFKDT_TABLE + KDT = REFKDT * DKSAT / REFDK + SLOPE = SLOPE_TABLE(SLOPETYPE) + + IF(VEGTYPE==ISURBAN)THEN ! Hardcoding some urban parameters for soil + SMCMAX = 0.45 + SMCREF = 0.42 + SMCWLT = 0.40 + SMCDRY = 0.40 + CSOIL = 3.E6 + ENDIF + +! adjust FRZK parameter to actual soil type: FRZK * FRZFACT + + IF(SOILTYPE /= 14) then + FRZFACT = (SMCMAX / SMCREF) * (0.412 / 0.468) + FRZX = FRZK * FRZFACT + END IF + + END SUBROUTINE TRANSFER_MP_PARAMETERS + +END MODULE NOAHMP_PARAMETERS + ! ================================================================================================== MODULE NOAHMP_ROUTINES @@ -477,11 +879,11 @@ MODULE NOAHMP_ROUTINES public :: noahmp_options public :: NOAHMP_SFLX - public :: REDPRM public :: FRH2O private :: ATM private :: PHENOLOGY + private :: PRECIP_HEAT private :: ENERGY private :: THERMOPROP private :: CSNOW @@ -537,17 +939,17 @@ MODULE NOAHMP_ROUTINES contains ! -! ================================================================================================== +!== begin noahmp_sflx ============================================================================== SUBROUTINE NOAHMP_SFLX (& ILOC , JLOC , LAT , YEARLEN , JULIAN , COSZ , & ! IN : Time/Space-related DT , DX , DZ8W , NSOIL , ZSOIL , NSNOW , & ! IN : Model configuration - SHDFAC , SHDMAX , VEGTYP , ISURBAN , ICE , IST , & ! IN : Vegetation/Soil characteristics - ISC , SMCEQ , & ! IN : Vegetation/Soil characteristics - IZ0TLND , & ! IN : User options + SHDFAC , SHDMAX , VEGTYP , ICE , IST , & ! IN : Vegetation/Soil characteristics + SMCEQ , & ! IN : Vegetation/Soil characteristics SFCTMP , SFCPRS , PSFC , UU , VV , Q2 , & ! IN : Forcing - QC , SOLDN , LWDN , PRCP , TBOT , CO2AIR , & ! IN : Forcing - O2AIR , FOLN , FICEOLD , PBLH , ZLVL , & ! IN : Forcing + QC , SOLDN , LWDN , & ! IN : Forcing + PRCPCONV, PRCPNONC, PRCPSHCV, PRCPSNOW, PRCPGRPL, PRCPHAIL, & ! IN : Forcing + TBOT , CO2AIR , O2AIR , FOLN , FICEOLD , ZLVL , & ! IN : Forcing ALBOLD , SNEQVO , & ! IN/OUT : STC , SH2O , SMC , TAH , EAH , FWET , & ! IN/OUT : CANLIQ , CANICE , TV , TG , QSFC , QSNOW , & ! IN/OUT : @@ -556,6 +958,7 @@ SUBROUTINE NOAHMP_SFLX (& STMASS , WOOD , STBLCP , FASTCP , LAI , SAI , & ! IN/OUT : CM , CH , TAUSS , & ! IN/OUT : SMCWTD ,DEEPRECH , RECH , & ! IN/OUT : + Z0WRF , & FSA , FSR , FIRA , FSH , SSOIL , FCEV , & ! OUT : FGEV , FCTR , ECAN , ETRAN , EDIR , TRAD , & ! OUT : TGB , TGV , T2MV , T2MB , Q2V , Q2B , & ! OUT : @@ -565,7 +968,8 @@ SUBROUTINE NOAHMP_SFLX (& BGAP , WGAP , CHV , CHB , EMISSI , & ! OUT : SHG , SHC , SHB , EVG , EVB , GHV , & ! OUT : GHB , IRG , IRC , IRB , TR , EVC , & ! OUT : - CHLEAF , CHUC , CHV2 , CHB2 , FPICE & + CHLEAF , CHUC , CHV2 , CHB2 , FPICE , PAHV , & + PAHG , PAHB , PAH & #ifdef WRF_HYDRO ,SFCHEADRT & ! IN/OUT : #endif @@ -574,8 +978,8 @@ SUBROUTINE NOAHMP_SFLX (& ! -------------------------------------------------------------------------------------------------- ! Initial code: Guo-Yue Niu, Oct. 2007 ! -------------------------------------------------------------------------------------------------- - USE NOAHMP_VEG_PARAMETERS - USE NOAHMP_RAD_PARAMETERS + USE NOAHMP_PARAMETERS, ONLY: NROOT, & ! VEG DEPENDENT + ISBARREN, ISURBAN ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- implicit none ! -------------------------------------------------------------------------------------------------- @@ -583,7 +987,6 @@ SUBROUTINE NOAHMP_SFLX (& INTEGER , INTENT(IN) :: ICE !ice (ice = 1) INTEGER , INTENT(IN) :: IST !surface type 1->soil; 2->lake INTEGER , INTENT(IN) :: VEGTYP !vegetation type - INTEGER , INTENT(IN) :: ISC !soil color type (1-lighest; 8-darkest) INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers INTEGER , INTENT(IN) :: NSOIL !no. of soil layers INTEGER , INTENT(IN) :: ILOC !grid index @@ -595,7 +998,6 @@ SUBROUTINE NOAHMP_SFLX (& REAL , INTENT(IN) :: UU !wind speed in eastward dir (m/s) REAL , INTENT(IN) :: VV !wind speed in northward dir (m/s) REAL , INTENT(IN) :: SOLDN !downward shortwave radiation (w/m2) - REAL , INTENT(IN) :: PRCP !precipitation rate (kg m-2 s-1) REAL , INTENT(IN) :: LWDN !downward longwave radiation (w/m2) REAL , INTENT(IN) :: SFCPRS !pressure (pa) REAL , INTENT(INOUT) :: ZLVL !reference height (m) @@ -608,12 +1010,15 @@ SUBROUTINE NOAHMP_SFLX (& REAL , INTENT(IN) :: LAT !latitude (radians) REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD!ice fraction at last timestep REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] + REAL , INTENT(IN) :: PRCPCONV ! convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPNONC ! non-convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSHCV ! shallow convective precip entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSNOW ! snow entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPGRPL ! graupel entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPHAIL ! hail entering land model [mm/s] ! MB/AN : v3.7 !jref:start; in - INTEGER , INTENT(IN) :: ISURBAN - INTEGER , INTENT(IN) :: IZ0TLND REAL , INTENT(IN) :: QC !cloud water mixing ratio - REAL , INTENT(IN) :: PBLH !planetary boundary layer height REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer REAL , INTENT(IN) :: PSFC !pressure at lowest model layer REAL , INTENT(IN) :: DZ8W !thickness of lowest layer @@ -659,6 +1064,7 @@ SUBROUTINE NOAHMP_SFLX (& REAL, INTENT(INOUT) :: RECH !recharge to or from the water table when shallow [m] (diagnostic) ! output + REAL , INTENT(OUT) :: Z0WRF !combined z0 sent to coupled model REAL , INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) REAL , INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) REAL , INTENT(OUT) :: FIRA !total net LW rad (w/m2) [+ to atm] @@ -722,7 +1128,6 @@ SUBROUTINE NOAHMP_SFLX (& REAL :: BEVAP !soil water evaporation factor (0 - 1) REAL, DIMENSION( 1:NSOIL) :: BTRANI !Soil water transpiration factor (0 - 1) REAL :: BTRAN !soil water transpiration factor (0 - 1) - REAL :: HTOP !top of canopy layer (m) REAL :: QIN !groundwater recharge [mm/s] REAL :: QDIS !groundwater discharge [mm/s] REAL, DIMENSION( 1:NSOIL) :: SICE !soil ice content (m3/m3) @@ -751,6 +1156,10 @@ SUBROUTINE NOAHMP_SFLX (& REAL,INTENT(OUT) :: EVC !canopy evap. heat [w/m2] [+ to atm] REAL,INTENT(OUT) :: TR !transpiration heat [w/m2] [+ to atm] REAL, INTENT(OUT) :: FPICE !snow fraction in precipitation + REAL, INTENT(OUT) :: PAHV !precipitation advected heat - vegetation net (W/m2) + REAL, INTENT(OUT) :: PAHG !precipitation advected heat - under canopy net (W/m2) + REAL, INTENT(OUT) :: PAHB !precipitation advected heat - bare ground net (W/m2) + REAL, INTENT(OUT) :: PAH !precipitation advected heat - total (W/m2) !jref:start REAL :: FSRV @@ -789,6 +1198,20 @@ SUBROUTINE NOAHMP_SFLX (& REAL :: AUTORS !net ecosystem respiration (g/m2/s C) REAL :: HETERS !organic respiration (g/m2/s C) REAL :: TROOT !root-zone averaged temperature (k) + REAL :: BDFALL !bulk density of new snow (kg/m3) ! MB/AN: v3.7 + REAL :: RAIN !rain rate (mm/s) ! MB/AN: v3.7 + REAL :: SNOW !liquid equivalent snow rate (mm/s) ! MB/AN: v3.7 + REAL :: FP ! MB/AN: v3.7 + REAL :: PRCP ! MB/AN: v3.7 +!more local variables for precip heat MB + REAL :: QINTR !interception rate for rain (mm/s) + REAL :: QDRIPR !drip rate for rain (mm/s) + REAL :: QTHROR !throughfall for rain (mm/s) + REAL :: QINTS !interception (loading) rate for snowfall (mm/s) + REAL :: QDRIPS !drip (unloading) rate for intercepted snow (mm/s) + REAL :: QTHROS !throughfall of snowfall (mm/s) + REAL :: QRAIN !rain at ground srf (mm/s) [+] + REAL :: SNOWHIN !snow depth increasing rate (m/s) REAL :: LATHEAV !latent heat vap./sublimation (j/kg) REAL :: LATHEAG !latent heat vap./sublimation (j/kg) LOGICAL :: FROZEN_GROUND ! used to define latent heat pathway @@ -799,13 +1222,19 @@ SUBROUTINE NOAHMP_SFLX (& nee = 0.0 npp = 0.0 gpp = 0.0 + PAHV = 0. + PAHG = 0. + PAHB = 0. + PAH = 0. ! -------------------------------------------------------------------------------------------------- ! re-process atmospheric forcing - CALL ATM (SFCPRS ,SFCTMP ,Q2 ,PRCP ,SOLDN ,COSZ ,THAIR , & - QAIR ,EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD ,SOLAI , & - SWDOWN ) + CALL ATM (SFCPRS ,SFCTMP ,Q2 , & + PRCPCONV, PRCPNONC,PRCPSHCV,PRCPSNOW,PRCPGRPL,PRCPHAIL, & + SOLDN ,COSZ ,THAIR ,QAIR , & + EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD ,SOLAI , & + SWDOWN ,BDFALL ,RAIN ,SNOW ,FP ,FPICE , PRCP ) ! snow/soil layer thickness (m) @@ -835,32 +1264,19 @@ SUBROUTINE NOAHMP_SFLX (& ! vegetation phenology - CALL PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULIAN , & !in - LAI , SAI , TROOT , HTOP , ELAI , ESAI ,IGS) + CALL PHENOLOGY (VEGTYP , SNOWH , TV , LAT , YEARLEN , JULIAN , & !in + LAI , SAI , TROOT , ELAI , ESAI ,IGS) !input GVF should be consistent with LAI -! IF(DVEG == 1) THEN -! FVEG = SHDFAC -! IF(FVEG <= 0.05) FVEG = 0.05 -! ELSE IF (DVEG == 2 .or. DVEG == 3) THEN -! FVEG = 1.-EXP(-0.52*(LAI+SAI)) -! IF(FVEG <= 0.05) FVEG = 0.05 -! ELSE IF (DVEG == 4) THEN -! FVEG = SHDMAX -! IF(FVEG <= 0.05) FVEG = 0.05 -! ELSE -! WRITE(*,*) "-------- FATAL CALLED IN SFLX -----------" -! CALL wrf_error_fatal("Namelist parameter DVEG unknown") -! ENDIF IF(DVEG == 1) THEN FVEG = SHDFAC - IF(FVEG <= 0.01) FVEG = 0.01 + IF(FVEG <= 0.05) FVEG = 0.05 ELSE IF (DVEG == 2 .or. DVEG == 3) THEN FVEG = 1.-EXP(-0.52*(LAI+SAI)) - IF(FVEG <= 0.01) FVEG = 0.01 + IF(FVEG <= 0.05) FVEG = 0.05 ELSE IF (DVEG == 4 .or. DVEG == 5) THEN FVEG = SHDMAX - IF(FVEG <= 0.01) FVEG = 0.01 + IF(FVEG <= 0.05) FVEG = 0.05 ELSE WRITE(*,*) "-------- FATAL CALLED IN SFLX -----------" CALL wrf_error_fatal("Namelist parameter DVEG unknown") @@ -868,20 +1284,25 @@ SUBROUTINE NOAHMP_SFLX (& IF(VEGTYP == ISURBAN .OR. VEGTYP == ISBARREN) FVEG = 0.0 IF(ELAI+ESAI == 0.0) FVEG = 0.0 -! CALL PHENOLOGY (VEGTYP,IMONTH ,IDAY ,SNOWH ,TV ,LAT , & !in -! LAI ,SAI ,TROOT , & !in -! HTOP ,ELAI ,ESAI ,IGS ) !out + CALL PRECIP_HEAT(ILOC ,JLOC ,VEGTYP ,DT ,UU ,VV , & !in + ELAI ,ESAI ,FVEG ,IST , & !in + BDFALL ,RAIN ,SNOW ,FP , & !in + CANLIQ ,CANICE ,TV ,SFCTMP ,TG , & !in + QINTR ,QDRIPR ,QTHROR ,QINTS ,QDRIPS ,QTHROS , & !out + PAHV ,PAHG ,PAHB ,QRAIN ,QSNOW ,SNOWHIN, & !out + FWET ,CMC ) !out ! compute energy budget (momentum & energy fluxes and phase changes) - CALL ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in - ISNOW ,NROOT ,DT ,RHOAIR ,SFCPRS ,QAIR , & !in + CALL ENERGY (ICE ,VEGTYP ,IST ,NSNOW ,NSOIL , & !in + ISNOW ,DT ,RHOAIR ,SFCPRS ,QAIR , & !in SFCTMP ,THAIR ,LWDN ,UU ,VV ,ZLVL , & !in CO2AIR ,O2AIR ,SOLAD ,SOLAI ,COSZ ,IGS , & !in - EAIR ,HTOP ,TBOT ,ZBOT ,ZSNSO ,ZSOIL , & !in - ELAI ,ESAI ,CSOIL ,FWET ,FOLN , & !in - FVEG , & !in + EAIR ,TBOT ,ZSNSO ,ZSOIL , & !in + ELAI ,ESAI ,FWET ,FOLN , & !in + FVEG ,PAHV ,PAHG ,PAHB , & !in QSNOW ,DZSNSO ,LAT ,CANLIQ ,CANICE ,iloc, jloc , & !in + Z0WRF , & IMELT ,SNICEV ,SNLIQV ,EPORE ,T2M ,FSNO , & !out SAV ,SAG ,QMELT ,FSA ,FSR ,TAUX , & !out TAUY ,FIRA ,FSH ,FCEV ,FGEV ,FCTR , & !out @@ -892,11 +1313,11 @@ SUBROUTINE NOAHMP_SFLX (& ALBOLD ,CM ,CH ,DX ,DZ8W ,Q2 , & !inout TAUSS , & !inout !jref:start - QC ,PBLH ,QSFC ,PSFC ,ISURBAN,IZ0TLND, & !in + QC ,QSFC ,PSFC , & !in T2MV ,T2MB ,FSRV , & FSRG ,RSSUN ,RSSHA ,BGAP ,WGAP, TGV,TGB,& Q1 ,Q2V ,Q2B ,Q2E ,CHV ,CHB , & !out - EMISSI,& + EMISSI ,PAH , & SHG,SHC,SHB,EVG,EVB,GHV,GHB,IRG,IRC,IRB,TR,EVC,CHLEAF,CHUC,CHV2,CHB2 ) !out !jref:end @@ -913,14 +1334,15 @@ SUBROUTINE NOAHMP_SFLX (& VV ,FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , & !in ESAI ,SFCTMP ,QVAP ,QDEW ,ZSOIL ,BTRANI , & !in FICEOLD,PONDING,TG ,IST ,FVEG ,iloc,jloc , SMCEQ , & !in - LATHEAV , LATHEAG , frozen_canopy,frozen_ground, & !in MB + BDFALL ,FP ,RAIN ,SNOW , & !in MB/AN: v3.7 + QSNOW ,QRAIN ,SNOWHIN,LATHEAV,LATHEAG,frozen_canopy,frozen_ground, & !in MB ISNOW ,CANLIQ ,CANICE ,TV ,SNOWH ,SNEQV , & !inout SNICE ,SNLIQ ,STC ,ZSNSO ,SH2O ,SMC , & !inout SICE ,ZWT ,WA ,WT ,DZSNSO ,WSLAKE , & !inout SMCWTD ,DEEPRECH,RECH , & !inout CMC ,ECAN ,ETRAN ,FWET ,RUNSRF ,RUNSUB , & !out - QIN ,QDIS ,QSNOW ,PONDING1 ,PONDING2,& - ISURBAN,QSNBOT,FPICE & + QIN ,QDIS ,PONDING1 ,PONDING2,& + QSNBOT & #ifdef WRF_HYDRO ,sfcheadrt & #endif @@ -931,10 +1353,10 @@ SUBROUTINE NOAHMP_SFLX (& ! compute carbon budgets (carbon storages and co2 & bvoc fluxes) IF (DVEG == 2 .OR. DVEG == 5) THEN - CALL CARBON (NSNOW ,NSOIL ,VEGTYP ,NROOT ,DT ,ZSOIL , & !in + CALL CARBON (NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL , & !in DZSNSO ,STC ,SMC ,TV ,TG ,PSN , & !in - FOLN ,SMCMAX ,BTRAN ,APAR ,FVEG ,IGS , & !in - TROOT ,IST ,LAT ,iloc ,jloc ,ISURBAN, & !in + FOLN ,BTRAN ,APAR ,FVEG ,IGS , & !in + TROOT ,IST ,LAT ,iloc ,jloc , & !in LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP , & !inout GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC , & !out TOTLB ,LAI ,SAI ) !out @@ -947,7 +1369,8 @@ SUBROUTINE NOAHMP_SFLX (& SNEQV ,WA ,SMC ,DZSNSO ,PRCP ,ECAN , & !in ETRAN ,EDIR ,RUNSRF ,RUNSUB ,DT ,NSOIL , & !in NSNOW ,IST ,ERRWAT ,ILOC , JLOC ,FVEG , & - SAV ,SAG ,FSRV ,FSRG ,ZWT ) !in ( Except ERRWAT, which is out ) + SAV ,SAG ,FSRV ,FSRG ,ZWT ,PAH , & + PAHV ,PAHG ,PAHB ) !in ( Except ERRWAT, which is out ) ! urban - jref QFX = ETRAN + ECAN + EDIR @@ -969,12 +1392,18 @@ SUBROUTINE NOAHMP_SFLX (& END SUBROUTINE NOAHMP_SFLX -! ================================================================================================== - SUBROUTINE ATM (SFCPRS ,SFCTMP ,Q2 ,PRCP ,SOLDN ,COSZ ,THAIR , & - QAIR ,EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD ,SOLAI , & - SWDOWN ) + +!== begin atm ====================================================================================== + + SUBROUTINE ATM (SFCPRS ,SFCTMP ,Q2 , & + PRCPCONV,PRCPNONC ,PRCPSHCV,PRCPSNOW,PRCPGRPL,PRCPHAIL , & + SOLDN ,COSZ ,THAIR ,QAIR , & + EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD , SOLAI , & + SWDOWN ,BDFALL ,RAIN ,SNOW ,FP , FPICE ,PRCP ) ! -------------------------------------------------------------------------------------------------- ! re-process atmospheric forcing +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: RAIR, CPAIR, TFRZ ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -983,8 +1412,13 @@ SUBROUTINE ATM (SFCPRS ,SFCTMP ,Q2 ,PRCP ,SOLDN ,COSZ ,THAIR , & REAL , INTENT(IN) :: SFCPRS !pressure (pa) REAL , INTENT(IN) :: SFCTMP !surface air temperature [k] REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) + REAL , INTENT(IN) :: PRCPCONV ! convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPNONC ! non-convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSHCV ! shallow convective precip entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSNOW ! snow entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPGRPL ! graupel entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPHAIL ! hail entering land model [mm/s] ! MB/AN : v3.7 REAL , INTENT(IN) :: SOLDN !downward shortwave radiation (w/m2) - REAL , INTENT(IN) :: PRCP !precipitation rate (kg m-2 s-1) REAL , INTENT(IN) :: COSZ !cosine solar zenith angle [0-1] ! outputs @@ -992,31 +1426,36 @@ SUBROUTINE ATM (SFCPRS ,SFCTMP ,Q2 ,PRCP ,SOLDN ,COSZ ,THAIR , & REAL , INTENT(OUT) :: THAIR !potential temperature (k) REAL , INTENT(OUT) :: QAIR !specific humidity (kg/kg) (q2/(1+q2)) REAL , INTENT(OUT) :: EAIR !vapor pressure air (pa) - REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAD !incoming direct solar radiation (w/m2) - REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL , INTENT(OUT) :: RHOAIR !density air (kg/m3) REAL , INTENT(OUT) :: QPRECC !convective precipitation (mm/s) REAL , INTENT(OUT) :: QPRECL !large-scale precipitation (mm/s) - REAL , INTENT(OUT) :: RHOAIR !density air (kg/m3) + REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAD !incoming direct solar radiation (w/m2) + REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAI !incoming diffuse solar radiation (w/m2) REAL , INTENT(OUT) :: SWDOWN !downward solar filtered by sun angle [w/m2] + REAL , INTENT(OUT) :: BDFALL !!bulk density of snowfall (kg/m3) AJN + REAL , INTENT(OUT) :: RAIN !rainfall (mm/s) AJN + REAL , INTENT(OUT) :: SNOW !liquid equivalent snowfall (mm/s) AJN + REAL , INTENT(OUT) :: FP !fraction of area receiving precipitation AJN + REAL , INTENT(OUT) :: FPICE !fraction of ice AJN + REAL , INTENT(OUT) :: PRCP !total precipitation [mm/s] ! MB/AN : v3.7 !locals REAL :: PAIR !atm bottom level pressure (pa) + REAL :: PRCP_FROZEN !total frozen precipitation [mm/s] ! MB/AN : v3.7 + REAL, PARAMETER :: RHO_GRPL = 500.0 ! graupel bulk density [kg/m3] ! MB/AN : v3.7 + REAL, PARAMETER :: RHO_HAIL = 917.0 ! hail bulk density [kg/m3] ! MB/AN : v3.7 ! -------------------------------------------------------------------------------------------------- !jref: seems like PAIR should be P1000mb?? PAIR = SFCPRS ! atm bottom level pressure (pa) THAIR = SFCTMP * (SFCPRS/PAIR)**(RAIR/CPAIR) -! QAIR = Q2 / (1.0+Q2) ! mixing ratio to specific humidity [kg/kg] QAIR = Q2 ! In WRF, driver converts to specific humidity EAIR = QAIR*SFCPRS / (0.622+0.378*QAIR) RHOAIR = (SFCPRS-0.378*EAIR) / (RAIR*SFCTMP) - QPRECC = 0.10 * PRCP ! should be from the atmospheric model - QPRECL = 0.90 * PRCP ! should be from the atmospheric model - IF(COSZ <= 0.) THEN SWDOWN = 0. ELSE @@ -1028,22 +1467,94 @@ SUBROUTINE ATM (SFCPRS ,SFCTMP ,Q2 ,PRCP ,SOLDN ,COSZ ,THAIR , & SOLAI(1) = SWDOWN*0.3*0.5 ! diffuse vis SOLAI(2) = SWDOWN*0.3*0.5 ! diffuse nir + PRCP = PRCPCONV + PRCPNONC + PRCPSHCV + + IF(OPT_SNF == 4) THEN + QPRECC = PRCPCONV + PRCPSHCV + QPRECL = PRCPNONC + ELSE + QPRECC = 0.10 * PRCP ! should be from the atmospheric model + QPRECL = 0.90 * PRCP ! should be from the atmospheric model + END IF + +! fractional area that receives precipitation (see, Niu et al. 2005) + + FP = 0.0 + IF(QPRECC + QPRECL > 0.) & + FP = (QPRECC + QPRECL) / (10.*QPRECC + QPRECL) + +! partition precipitation into rain and snow. Moved from CANWAT MB/AN: v3.7 + +! Jordan (1991) + + IF(OPT_SNF == 1) THEN + IF(SFCTMP > TFRZ+2.5)THEN + FPICE = 0. + ELSE + IF(SFCTMP <= TFRZ+0.5)THEN + FPICE = 1.0 + ELSE IF(SFCTMP <= TFRZ+2.)THEN + FPICE = 1.-(-54.632 + 0.2*SFCTMP) + ELSE + FPICE = 0.6 + ENDIF + ENDIF + ENDIF + + IF(OPT_SNF == 2) THEN + IF(SFCTMP >= TFRZ+2.2) THEN + FPICE = 0. + ELSE + FPICE = 1.0 + ENDIF + ENDIF + + IF(OPT_SNF == 3) THEN + IF(SFCTMP >= TFRZ) THEN + FPICE = 0. + ELSE + FPICE = 1.0 + ENDIF + ENDIF + +! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625 +! fresh snow density + + BDFALL = MIN(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59)) !MB/AN: change to MIN + IF(OPT_SNF == 4) THEN + PRCP_FROZEN = PRCPSNOW + PRCPGRPL + PRCPHAIL + IF(PRCPNONC > 0. .and. PRCP_FROZEN > 0.) THEN + FPICE = MIN(1.0,PRCP_FROZEN/PRCPNONC) + FPICE = MAX(0.0,FPICE) + BDFALL = BDFALL*(PRCPSNOW/PRCP_FROZEN) + RHO_GRPL*(PRCPGRPL/PRCP_FROZEN) + & + RHO_HAIL*(PRCPHAIL/PRCP_FROZEN) + ELSE + FPICE = 0.0 + ENDIF + + ENDIF + + RAIN = PRCP * (1.-FPICE) + SNOW = PRCP * FPICE + + END SUBROUTINE ATM -! ================================================================================================== -! -------------------------------------------------------------------------------------------------- - SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULIAN , & !in - LAI , SAI , TROOT , HTOP , ELAI , ESAI , IGS) + +!== begin phenology ================================================================================ + + SUBROUTINE PHENOLOGY (VEGTYP , SNOWH , TV , LAT , YEARLEN , JULIAN , & !in + LAI , SAI , TROOT , ELAI , ESAI , IGS) ! -------------------------------------------------------------------------------------------------- ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time ! -------------------------------------------------------------------------------------------------- - USE NOAHMP_VEG_PARAMETERS + USE NOAHMP_PARAMETERS, ONLY : LAIM, SAIM, HVT, HVB, TMIN, & ! VEGETATION DEPENDENT + ISBARREN, ISICE, ISURBAN, ISWATER ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! inputs INTEGER , INTENT(IN ) :: VEGTYP !vegetation type - INTEGER , INTENT(IN ) :: ISURBAN!urban category REAL , INTENT(IN ) :: SNOWH !snow height [m] REAL , INTENT(IN ) :: TV !vegetation temperature (k) REAL , INTENT(IN ) :: LAT !latitude (radians) @@ -1054,7 +1565,6 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULI REAL , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow ! outputs - REAL , INTENT(OUT ) :: HTOP !top of canopy layer (m) REAL , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow REAL , INTENT(OUT ) :: ESAI !stem area index, after burying by snow REAL , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) @@ -1075,64 +1585,295 @@ SUBROUTINE PHENOLOGY (VEGTYP , ISURBAN, SNOWH , TV , LAT , YEARLEN , JULI IF ( DVEG == 1 .or. DVEG == 3 .or. DVEG == 4 ) THEN - IF (LAT >= 0.) THEN - ! Northern Hemisphere - DAY = JULIAN - ELSE - ! Southern Hemisphere. DAY is shifted by 1/2 year. - DAY = MOD ( JULIAN + ( 0.5 * YEARLEN ) , REAL(YEARLEN) ) - ENDIF + IF (LAT >= 0.) THEN + ! Northern Hemisphere + DAY = JULIAN + ELSE + ! Southern Hemisphere. DAY is shifted by 1/2 year. + DAY = MOD ( JULIAN + ( 0.5 * YEARLEN ) , REAL(YEARLEN) ) + ENDIF + + T = 12. * DAY / REAL(YEARLEN) + IT1 = T + 0.5 + IT2 = IT1 + 1 + WT1 = (IT1+0.5) - T + WT2 = 1.-WT1 + IF (IT1 .LT. 1) IT1 = 12 + IF (IT2 .GT. 12) IT2 = 1 + + LAI = WT1*LAIM(IT1) + WT2*LAIM(IT2) + SAI = WT1*SAIM(IT1) + WT2*SAIM(IT2) + ENDIF + IF (SAI < 0.05) SAI = 0.0 ! MB: SAI CHECK, change to 0.05 v3.6 + IF (LAI < 0.05 .OR. SAI == 0.0) LAI = 0.0 ! MB: LAI CHECK + + IF ( ( VEGTYP == ISWATER ) .OR. ( VEGTYP == ISBARREN ) .OR. ( VEGTYP == ISICE ) .or. ( VEGTYP == ISURBAN) ) THEN + LAI = 0. + SAI = 0. + ENDIF + +!buried by snow + + DB = MIN( MAX(SNOWH - HVB,0.), HVT-HVB ) + FB = DB / MAX(1.E-06,HVT-HVB) + + IF(HVT> 0. .AND. HVT <= 1.0) THEN !MB: change to 1.0 and 0.2 to reflect + SNOWHC = HVT*EXP(-SNOWH/0.2) ! changes to HVT in MPTABLE + FB = MIN(SNOWH,SNOWHC)/SNOWHC + ENDIF + + ELAI = LAI*(1.-FB) + ESAI = SAI*(1.-FB) + IF (ESAI < 0.05) ESAI = 0.0 ! MB: ESAI CHECK, change to 0.05 v3.6 + IF (ELAI < 0.05 .OR. ESAI == 0.0) ELAI = 0.0 ! MB: LAI CHECK + + IF (TV .GT. TMIN) THEN + IGS = 1. + ELSE + IGS = 0. + ENDIF + + END SUBROUTINE PHENOLOGY + +!== begin precip_heat ============================================================================== + + SUBROUTINE PRECIP_HEAT (ILOC ,JLOC ,VEGTYP ,DT ,UU ,VV , & !in + ELAI ,ESAI ,FVEG ,IST , & !in + BDFALL ,RAIN ,SNOW ,FP , & !in + CANLIQ ,CANICE ,TV ,SFCTMP ,TG , & !in + QINTR ,QDRIPR ,QTHROR ,QINTS ,QDRIPS ,QTHROS , & !out + PAHV ,PAHG ,PAHB ,QRAIN ,QSNOW ,SNOWHIN, & !out + FWET ,CMC ) !out + +! ------------------------ code history ------------------------------ +! Michael Barlage: Oct 2013 - split CANWATER to calculate precip movement for +! tracking of advected heat +! -------------------------------------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY : CH2OP, CWAT, CICE, TFRZ ! VEGETATION DEPENDENT +! -------------------------------------------------------------------- + IMPLICIT NONE +! ------------------------ input/output variables -------------------- +! input + INTEGER,INTENT(IN) :: ILOC !grid index + INTEGER,INTENT(IN) :: JLOC !grid index + INTEGER,INTENT(IN) :: VEGTYP !vegetation type + INTEGER,INTENT(IN) :: IST !surface type 1-soil; 2-lake + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: UU !u-direction wind speed [m/s] + REAL, INTENT(IN) :: VV !v-direction wind speed [m/s] + REAL, INTENT(IN) :: ELAI !leaf area index, after burying by snow + REAL, INTENT(IN) :: ESAI !stem area index, after burying by snow + REAL, INTENT(IN) :: FVEG !greeness vegetation fraction (-) + REAL, INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) + REAL, INTENT(IN) :: RAIN !rainfall (mm/s) + REAL, INTENT(IN) :: SNOW !snowfall (mm/s) + REAL, INTENT(IN) :: FP !fraction of the gridcell that receives precipitation + REAL, INTENT(IN) :: TV !vegetation temperature (k) + REAL, INTENT(IN) :: SFCTMP !model-level temperature (k) + REAL, INTENT(IN) :: TG !ground temperature (k) + +! input & output + REAL, INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) + REAL, INTENT(INOUT) :: CANICE !intercepted ice mass (mm) + +! output + REAL, INTENT(OUT) :: QINTR !interception rate for rain (mm/s) + REAL, INTENT(OUT) :: QDRIPR !drip rate for rain (mm/s) + REAL, INTENT(OUT) :: QTHROR !throughfall for rain (mm/s) + REAL, INTENT(OUT) :: QINTS !interception (loading) rate for snowfall (mm/s) + REAL, INTENT(OUT) :: QDRIPS !drip (unloading) rate for intercepted snow (mm/s) + REAL, INTENT(OUT) :: QTHROS !throughfall of snowfall (mm/s) + REAL, INTENT(OUT) :: PAHV !precipitation advected heat - vegetation net (W/m2) + REAL, INTENT(OUT) :: PAHG !precipitation advected heat - under canopy net (W/m2) + REAL, INTENT(OUT) :: PAHB !precipitation advected heat - bare ground net (W/m2) + REAL, INTENT(OUT) :: QRAIN !rain at ground srf (mm/s) [+] + REAL, INTENT(OUT) :: QSNOW !snow at ground srf (mm/s) [+] + REAL, INTENT(OUT) :: SNOWHIN !snow depth increasing rate (m/s) + REAL, INTENT(OUT) :: FWET !wetted or snowed fraction of the canopy (-) + REAL, INTENT(OUT) :: CMC !intercepted water (mm) +! -------------------------------------------------------------------- + +! ------------------------ local variables --------------------------- + REAL :: MAXSNO !canopy capacity for snow interception (mm) + REAL :: MAXLIQ !canopy capacity for rain interception (mm) + REAL :: FT !temperature factor for unloading rate + REAL :: FV !wind factor for unloading rate + REAL :: PAH_AC !precipitation advected heat - air to canopy (W/m2) + REAL :: PAH_CG !precipitation advected heat - canopy to ground (W/m2) + REAL :: PAH_AG !precipitation advected heat - air to ground (W/m2) + REAL :: ICEDRIP !canice unloading +! -------------------------------------------------------------------- +! initialization + + QINTR = 0. + QDRIPR = 0. + QTHROR = 0. + QINTR = 0. + QINTS = 0. + QDRIPS = 0. + QTHROS = 0. + PAH_AC = 0. + PAH_CG = 0. + PAH_AG = 0. + PAHV = 0. + PAHG = 0. + PAHB = 0. + QRAIN = 0.0 + QSNOW = 0.0 + SNOWHIN = 0.0 + ICEDRIP = 0.0 +! print*, "precip_heat begin canopy balance:",canliq+canice+(rain+snow)*dt +! print*, "precip_heat snow*3600.0:",snow*3600.0 +! print*, "precip_heat rain*3600.0:",rain*3600.0 +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq + +! --------------------------- liquid water ------------------------------ +! maximum canopy water + + MAXLIQ = CH2OP * (ELAI+ ESAI) + +! average interception and throughfall + + IF((ELAI+ ESAI).GT.0.) THEN + QINTR = FVEG * RAIN * FP ! interception capability + QINTR = MIN(QINTR, (MAXLIQ - CANLIQ)/DT * (1.-EXP(-RAIN*DT/MAXLIQ)) ) + QINTR = MAX(QINTR, 0.) + QDRIPR = FVEG * RAIN - QINTR + QTHROR = (1.-FVEG) * RAIN + CANLIQ=MAX(0.,CANLIQ+QINTR*DT) + ELSE + QINTR = 0. + QDRIPR = 0. + QTHROR = RAIN + IF(CANLIQ > 0.) THEN ! FOR CASE OF CANOPY GETTING BURIED + QDRIPR = QDRIPR + CANLIQ/DT + CANLIQ = 0.0 + END IF + END IF + +! heat transported by liquid water + + PAH_AC = FVEG * RAIN * (CWAT/1000.0) * (SFCTMP - TV) + PAH_CG = QDRIPR * (CWAT/1000.0) * (TV - TG) + PAH_AG = QTHROR * (CWAT/1000.0) * (SFCTMP - TG) +! print*, "precip_heat PAH_AC:",PAH_AC +! print*, "precip_heat PAH_CG:",PAH_CG +! print*, "precip_heat PAH_AG:",PAH_AG + +! --------------------------- canopy ice ------------------------------ +! for canopy ice + + MAXSNO = 6.6*(0.27+46./BDFALL) * (ELAI+ ESAI) + + IF((ELAI+ ESAI).GT.0.) THEN + QINTS = FVEG * SNOW * FP + QINTS = MIN(QINTS, (MAXSNO - CANICE)/DT * (1.-EXP(-SNOW*DT/MAXSNO)) ) + QINTS = MAX(QINTS, 0.) + FT = MAX(0.0,(TV - 270.15) / 1.87E5) + FV = SQRT(UU*UU + VV*VV) / 1.56E5 + ! MB: changed below to reflect the rain assumption that all precip gets intercepted + ICEDRIP = MAX(0.,CANICE) * (FV+FT) !MB: removed /DT + QDRIPS = (FVEG * SNOW - QINTS) + ICEDRIP + QTHROS = (1.0-FVEG) * SNOW + CANICE= MAX(0.,CANICE + (QINTS - ICEDRIP)*DT) + ELSE + QINTS = 0. + QDRIPS = 0. + QTHROS = SNOW + IF(CANICE > 0.) THEN ! FOR CASE OF CANOPY GETTING BURIED + QDRIPS = QDRIPS + CANICE/DT + CANICE = 0.0 + END IF + ENDIF +! print*, "precip_heat canopy through:",3600.0*(FVEG * SNOW - QINTS) +! print*, "precip_heat canopy drip:",3600.0*MAX(0.,CANICE) * (FV+FT) + +! wetted fraction of canopy - T = 12. * DAY / REAL(YEARLEN) - IT1 = T + 0.5 - IT2 = IT1 + 1 - WT1 = (IT1+0.5) - T - WT2 = 1.-WT1 - IF (IT1 .LT. 1) IT1 = 12 - IF (IT2 .GT. 12) IT2 = 1 + IF(CANICE.GT.0.) THEN + FWET = MAX(0.,CANICE) / MAX(MAXSNO,1.E-06) + ELSE + FWET = MAX(0.,CANLIQ) / MAX(MAXLIQ,1.E-06) + ENDIF + FWET = MIN(FWET, 1.) ** 0.667 - LAI = WT1*LAIM(VEGTYP,IT1) + WT2*LAIM(VEGTYP,IT2) - SAI = WT1*SAIM(VEGTYP,IT1) + WT2*SAIM(VEGTYP,IT2) - ENDIF - IF (SAI < 0.05) SAI = 0.0 ! MB: SAI CHECK, change to 0.05 v3.6 - IF (LAI < 0.05 .OR. SAI == 0.0) LAI = 0.0 ! MB: LAI CHECK +! total canopy water - IF ( ( VEGTYP == ISWATER ) .OR. ( VEGTYP == ISBARREN ) .OR. ( VEGTYP == ISSNOW ) .or. ( VEGTYP == ISURBAN) ) THEN - LAI = 0. - SAI = 0. - ENDIF + CMC = CANLIQ + CANICE -!buried by snow +! heat transported by snow/ice - DB = MIN( MAX(SNOWH - HVB(VEGTYP),0.), HVT(VEGTYP)-HVB(VEGTYP) ) - FB = DB / MAX(1.E-06,HVT(VEGTYP)-HVB(VEGTYP)) + PAH_AC = PAH_AC + FVEG * SNOW * (CICE/1000.0) * (SFCTMP - TV) + PAH_CG = PAH_CG + QDRIPS * (CICE/1000.0) * (TV - TG) + PAH_AG = PAH_AG + QTHROS * (CICE/1000.0) * (SFCTMP - TG) + + PAHV = PAH_AC - PAH_CG + PAHG = PAH_CG + PAHB = PAH_AG + + IF (FVEG > 0.0 .AND. FVEG < 1.0) THEN + PAHG = PAHG / FVEG ! these will be multiplied by fraction later + PAHB = PAHB / (1.0-FVEG) + ELSEIF (FVEG <= 0.0) THEN + PAHB = PAHG + PAHB ! for case of canopy getting buried + PAHG = 0.0 + PAHV = 0.0 + ELSEIF (FVEG >= 1.0) THEN + PAHB = 0.0 + END IF + + PAHV = MAX(PAHV,-20.0) ! Put some artificial limits here for stability + PAHV = MIN(PAHV,20.0) + PAHG = MAX(PAHG,-20.0) + PAHG = MIN(PAHG,20.0) + PAHB = MAX(PAHB,-20.0) + PAHB = MIN(PAHB,20.0) + +! print*, 'precip_heat sfctmp,tv,tg:',sfctmp,tv,tg +! print*, 'precip_heat 3600.0*qints+qdrips+qthros:',3600.0*(qints+qdrips+qthros) +! print*, "precip_heat maxsno:",maxsno +! print*, "precip_heat PAH_AC:",PAH_AC +! print*, "precip_heat PAH_CG:",PAH_CG +! print*, "precip_heat PAH_AG:",PAH_AG + +! print*, "precip_heat PAHV:",PAHV +! print*, "precip_heat PAHG:",PAHG +! print*, "precip_heat PAHB:",PAHB +! print*, "precip_heat fveg:",fveg +! print*, "precip_heat qints*3600.0:",qints*3600.0 +! print*, "precip_heat qdrips*3600.0:",qdrips*3600.0 +! print*, "precip_heat qthros*3600.0:",qthros*3600.0 + +! rain or snow on the ground - IF(HVT(VEGTYP)> 0. .AND. HVT(VEGTYP) <= 1.0) THEN !MB: change to 1.0 and 0.2 to reflect - SNOWHC = HVT(VEGTYP)*EXP(-SNOWH/0.2) ! changes to HVT in MPTABLE - FB = MIN(SNOWH,SNOWHC)/SNOWHC - ENDIF + QRAIN = QDRIPR + QTHROR + QSNOW = QDRIPS + QTHROS + SNOWHIN = QSNOW/BDFALL - ELAI = LAI*(1.-FB) - ESAI = SAI*(1.-FB) - IF (ESAI < 0.05) ESAI = 0.0 ! MB: ESAI CHECK, change to 0.05 v3.6 - IF (ELAI < 0.05 .OR. ESAI == 0.0) ELAI = 0.0 ! MB: LAI CHECK + IF (IST == 2 .AND. TG > TFRZ) THEN + QSNOW = 0. + SNOWHIN = 0. + END IF +! print*, "precip_heat qsnow*3600.0:",qsnow*3600.0 +! print*, "precip_heat qrain*3600.0:",qrain*3600.0 +! print*, "precip_heat SNOWHIN:",SNOWHIN +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq +! print*, "precip_heat end canopy balance:",canliq+canice+(qrain+qsnow)*dt + - IF (TV .GT. TMIN(VEGTYP)) THEN - IGS = 1. - ELSE - IGS = 0. - ENDIF + END SUBROUTINE PRECIP_HEAT - HTOP = HVT(VEGTYP) +!== begin error ==================================================================================== - END SUBROUTINE PHENOLOGY -! ================================================================================================== SUBROUTINE ERROR (SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , & FGEV ,FCTR ,SSOIL ,BEG_WB ,CANLIQ ,CANICE , & SNEQV ,WA ,SMC ,DZSNSO ,PRCP ,ECAN , & ETRAN ,EDIR ,RUNSRF ,RUNSUB ,DT ,NSOIL , & NSNOW ,IST ,ERRWAT, ILOC ,JLOC ,FVEG , & - SAV ,SAG ,FSRV ,FSRG ,ZWT) + SAV ,SAG ,FSRV ,FSRG ,ZWT ,PAH , & + PAHV ,PAHG ,PAHB ) ! -------------------------------------------------------------------------------------------------- ! check surface energy balance and water balance ! -------------------------------------------------------------------------------------------------- @@ -1175,6 +1916,10 @@ SUBROUTINE ERROR (SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , & REAL , INTENT(IN) :: DT !time step [sec] REAL , INTENT(IN) :: BEG_WB !water storage at begin of a timesetp [mm] REAL , INTENT(OUT) :: ERRWAT !error in water balance [mm/timestep] + REAL, INTENT(IN) :: PAH !precipitation advected heat - total (W/m2) + REAL, INTENT(IN) :: PAHV !precipitation advected heat - total (W/m2) + REAL, INTENT(IN) :: PAHG !precipitation advected heat - total (W/m2) + REAL, INTENT(IN) :: PAHB !precipitation advected heat - total (W/m2) INTEGER :: IZ !do-loop index REAL :: END_WB !water storage at end of a timestep [mm] @@ -1209,13 +1954,31 @@ SUBROUTINE ERROR (SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , & call wrf_error_fatal("Stop in Noah-MP") END IF - ERRENG = SAV+SAG-(FIRA+FSH+FCEV+FGEV+FCTR+SSOIL) + ERRENG = SAV+SAG-(FIRA+FSH+FCEV+FGEV+FCTR+SSOIL) +PAH ! ERRENG = FVEG*SAV+SAG-(FIRA+FSH+FCEV+FGEV+FCTR+SSOIL) ! WRITE(*,*) "ERRENG =",ERRENG IF(ABS(ERRENG) > 0.01) THEN - write(message,*) 'ERRENG =',ERRENG + write(message,*) 'ERRENG =',ERRENG,' at i,j: ',ILOC,JLOC + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Net solar: ",FSA + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Net longwave: ",FIRA call wrf_message(trim(message)) - WRITE(message,'(i6,1x,i6,1x,7F10.4)')ILOC,JLOC,FSA,FIRA,FSH,FCEV,FGEV,FCTR,SSOIL + WRITE(message,'(a17,F10.4)') "Total sensible: ",FSH + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Canopy evap: ",FCEV + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Ground evap: ",FGEV + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Transpiration: ",FCTR + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Total ground: ",SSOIL + call wrf_message(trim(message)) + WRITE(message,'(a17,4F10.4)') "Precip advected: ",PAH,PAHV,PAHG,PAHB + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Precip: ",PRCP + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Veg fraction: ",FVEG call wrf_message(trim(message)) call wrf_error_fatal("Energy budget problem in NOAHMP LSM") END IF @@ -1250,16 +2013,18 @@ SUBROUTINE ERROR (SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , & ENDIF END SUBROUTINE ERROR -! ================================================================================================== -! -------------------------------------------------------------------------------------------------- - SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in - ISNOW ,NROOT ,DT ,RHOAIR ,SFCPRS ,QAIR , & !in + +!== begin energy =================================================================================== + + SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,NSNOW ,NSOIL , & !in + ISNOW ,DT ,RHOAIR ,SFCPRS ,QAIR , & !in SFCTMP ,THAIR ,LWDN ,UU ,VV ,ZREF , & !in CO2AIR ,O2AIR ,SOLAD ,SOLAI ,COSZ ,IGS , & !in - EAIR ,HTOP ,TBOT ,ZBOT ,ZSNSO ,ZSOIL , & !in - ELAI ,ESAI ,CSOIL ,FWET ,FOLN , & !in - FVEG , & !in + EAIR ,TBOT ,ZSNSO ,ZSOIL , & !in + ELAI ,ESAI ,FWET ,FOLN , & !in + FVEG ,PAHV ,PAHG ,PAHB , & !in QSNOW ,DZSNSO ,LAT ,CANLIQ ,CANICE ,ILOC , JLOC, & !in + Z0WRF , & IMELT ,SNICEV ,SNLIQV ,EPORE ,T2M ,FSNO , & !out SAV ,SAG ,QMELT ,FSA ,FSR ,TAUX , & !out TAUY ,FIRA ,FSH ,FCEV ,FGEV ,FCTR , & !out @@ -1270,17 +2035,13 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in ALBOLD ,CM ,CH ,DX ,DZ8W ,Q2 , & !inout TAUSS , & !inout !jref:start - QC ,PBLH ,QSFC ,PSFC ,ISURBAN,IZ0TLND, & !in + QC ,QSFC ,PSFC , & !in T2MV ,T2MB ,FSRV , & FSRG ,RSSUN ,RSSHA ,BGAP ,WGAP,TGV,TGB,& - Q1 ,Q2V ,Q2B ,Q2E ,CHV ,CHB, EMISSI,& + Q1 ,Q2V ,Q2B ,Q2E ,CHV ,CHB, EMISSI,PAH ,& SHG,SHC,SHB,EVG,EVB,GHV,GHB,IRG,IRC,IRB,TR,EVC,CHLEAF,CHUC,CHV2,CHB2 ) !out !jref:end -! -------------------------------------------------------------------------------------------------- -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_VEG_PARAMETERS - USE NOAHMP_RAD_PARAMETERS ! -------------------------------------------------------------------------------------------------- ! we use different approaches to deal with subgrid features of radiation transfer and turbulent ! transfer. We use 'tile' approach to compute turbulent fluxes, while we use modified two- @@ -1313,6 +2074,13 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in ! / O O O O O O O O / within the gridcell with 100% veg ! / | | | | | | | | / fraction, but with gaps. The 'tile' ! -------------------------------------- approach overlaps too much shadows. +! -------------------------------------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX, SMCREF, SMCWLT, & ! SOIL DEPENDENT + HVT, Z0MVT, CWPVT, NROOT, & ! VEGETATION DEPENDENT + EG, & ! SURFACE DEPENDENT + Z0SNO, MFSNO, & ! SNOW GLOBAL + GRAV, SB, TFRZ, RW, HVAP, HSUB, CPAIR, & ! MP CONSTANT + ISURBAN ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -1322,10 +2090,8 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in INTEGER , INTENT(IN) :: ICE !ice (ice = 1) INTEGER , INTENT(IN) :: VEGTYP !vegetation physiology type INTEGER , INTENT(IN) :: IST !surface type: 1->soil; 2->lake - INTEGER , INTENT(IN) :: ISC !soil color type (1-lighest; 8-darkest) INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers INTEGER , INTENT(IN) :: NSOIL !number of soil layers - INTEGER , INTENT(IN) :: NROOT !number of root layers INTEGER , INTENT(IN) :: ISNOW !actual no. of snow layers REAL , INTENT(IN) :: DT !time step [sec] REAL , INTENT(IN) :: QSNOW !snowfall on the ground (mm/s) @@ -1343,9 +2109,7 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in REAL , INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) REAL , INTENT(IN) :: ELAI !LAI adjusted for burying by snow REAL , INTENT(IN) :: ESAI !LAI adjusted for burying by snow - REAL , INTENT(IN) :: CSOIL !vol. soil heat capacity [j/m3/k] REAL , INTENT(IN) :: FWET !fraction of canopy that is wet [-] - REAL , INTENT(IN) :: HTOP !top of canopy layer (m) REAL , INTENT(IN) :: FVEG !greeness vegetation fraction (-) REAL , INTENT(IN) :: LAT !latitude (radians) REAL , INTENT(IN) :: CANLIQ !canopy-intercepted liquid water (mm) @@ -1357,16 +2121,15 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in REAL , INTENT(IN) :: ZREF !reference height (m) REAL , INTENT(IN) :: TBOT !bottom condition for soil temp. (k) - REAL , INTENT(IN) :: ZBOT !depth for TBOT [m] REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !layer-bottom depth from snow surf [m] REAL , DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf [m] REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !depth of snow & soil layer-bottom [m] + REAL, INTENT(IN) :: PAHV !precipitation advected heat - vegetation net (W/m2) + REAL, INTENT(IN) :: PAHG !precipitation advected heat - under canopy net (W/m2) + REAL, INTENT(IN) :: PAHB !precipitation advected heat - bare ground net (W/m2) !jref:start; in - INTEGER , INTENT(IN) :: ISURBAN - INTEGER , INTENT(IN) :: IZ0TLND REAL , INTENT(IN) :: QC !cloud water mixing ratio - REAL , INTENT(IN) :: PBLH !planetary boundary layer height REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer REAL , INTENT(IN) :: PSFC !pressure at lowest model layer REAL , INTENT(IN) :: DX !horisontal resolution @@ -1375,6 +2138,7 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in !jref:end ! outputs + REAL , INTENT(OUT) :: Z0WRF !combined z0 sent to coupled model INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT !phase change index [1-melt; 2-freeze] REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume ice [m3/m3] REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume liq. water [m3/m3] @@ -1441,6 +2205,7 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in REAL , INTENT(INOUT) :: Q1 ! REAL :: Q2E REAL, INTENT(OUT) :: EMISSI + REAL, INTENT(OUT) :: PAH !precipitation advected heat - total (W/m2) ! local INTEGER :: IZ !do-loop index @@ -1570,7 +2335,7 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in FSNO = 0. IF(SNOWH.GT.0.) THEN BDSNO = SNEQV / SNOWH - FMELT = (BDSNO/100.)**M + FMELT = (BDSNO/100.)**MFSNO FSNO = TANH( SNOWH /(2.5* Z0 * FMELT)) ENDIF @@ -1590,34 +2355,34 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in ZPDG = SNOWH IF(VEG) THEN - Z0M = Z0MVT(VEGTYP) - ZPD = 0.65 * HTOP + Z0M = Z0MVT + ZPD = 0.65 * HVT IF(SNOWH.GT.ZPD) ZPD = SNOWH ELSE Z0M = Z0MG ZPD = ZPDG END IF - ZLVL = MAX(ZPD,HTOP) + ZREF + ZLVL = MAX(ZPD,HVT) + ZREF IF(ZPDG >= ZLVL) ZLVL = ZPDG + ZREF ! UR = UR*LOG(ZLVL/Z0M)/LOG(10./Z0M) !input UR is at 10m ! canopy wind absorption coeffcient - CWP = CWPVT(VEGTYP) + CWP = CWPVT ! Thermal properties of soil, snow, lake, and frozen soil CALL THERMOPROP (NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , & !in - DT ,SNOWH ,SNICE ,SNLIQ ,CSOIL , & !in + DT ,SNOWH ,SNICE ,SNLIQ , & !in SMC ,SH2O ,TG ,STC ,UR , & !in - LAT ,Z0M ,ZLVL ,VEGTYP ,ISURBAN , & !in + LAT ,Z0M ,ZLVL ,VEGTYP , & !in DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , & !out FACT ) !out ! Solar radiation: absorbed & reflected by the ground and canopy - CALL RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in + CALL RADIATION (VEGTYP ,IST ,ICE ,NSOIL , & !in SNEQVO ,SNEQV ,DT ,COSZ ,SNOWH , & !in TG ,TV ,FSNO ,QSNOW ,FWET , & !in ELAI ,ESAI ,SMC ,SOLAD ,SOLAI , & !in @@ -1730,20 +2495,20 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in UU ,VV ,SFCTMP ,THAIR ,QAIR , & !in EAIR ,RHOAIR ,SNOWH ,VAI ,GAMMAV ,GAMMAG , & !in FWET ,LAISUN ,LAISHA ,CWP ,DZSNSO , & !in - HTOP ,ZLVL ,ZPD ,Z0M ,FVEG , & !in - Z0MG ,EMV ,EMG ,CANLIQ , & !in + ZLVL ,ZPD ,Z0M ,FVEG , & !in + Z0MG ,EMV ,EMG ,CANLIQ ,FSNO, & !in CANICE ,STC ,DF ,RSSUN ,RSSHA , & !in RSURF ,LATHEAV ,LATHEAG ,PARSUN ,PARSHA ,IGS , & !in FOLN ,CO2AIR ,O2AIR ,BTRAN ,SFCPRS , & !in - RHSUR ,ILOC ,JLOC ,Q2 , & !in + RHSUR ,ILOC ,JLOC ,Q2 ,PAHV ,PAHG , & !in EAH ,TAH ,TV ,TGV ,CMV , & !inout CHV ,DX ,DZ8W , & !inout TAUXV ,TAUYV ,IRG ,IRC ,SHG , & !out SHC ,EVG ,EVC ,TR ,GHV , & !out T2MV ,PSNSUN ,PSNSHA , & !out !jref:start - QC ,PBLH ,QSFC ,PSFC ,ISURBAN , & !in - IZ0TLND ,Q2V ,CHV2, CHLEAF, CHUC) !inout + QC ,QSFC ,PSFC , & !in + Q2V ,CHV2, CHLEAF, CHUC) !inout !jref:end END IF @@ -1753,15 +2518,15 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in CALL BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in LWDN ,UR ,UU ,VV ,SFCTMP , & !in THAIR ,QAIR ,EAIR ,RHOAIR ,SNOWH , & !in - DZSNSO ,ZLVL ,ZPDG ,Z0MG , & !in + DZSNSO ,ZLVL ,ZPDG ,Z0MG ,FSNO, & !in EMG ,STC ,DF ,RSURF ,LATHEAG , & !in - GAMMAG ,RHSUR ,ILOC ,JLOC ,Q2 , & !in + GAMMAG ,RHSUR ,ILOC ,JLOC ,Q2 ,PAHB , & !in TGB ,CMB ,CHB , & !inout TAUXB ,TAUYB ,IRB ,SHB ,EVB , & !out GHB ,T2MB ,DX ,DZ8W ,VEGTYP , & !out !jref:start - QC ,PBLH ,QSFC ,PSFC ,ISURBAN , & !in - IZ0TLND ,SFCPRS ,Q2B, CHB2) !in + QC ,QSFC ,PSFC , & !in + SFCPRS ,Q2B, CHB2) !in !jref:end !energy balance at vege canopy: SAV =(IRC+SHC+EVC+TR) *FVEG at FVEG @@ -1777,6 +2542,7 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in SSOIL = FVEG * GHV + (1.0 - FVEG) * GHB FCEV = EVC FCTR = TR + PAH = FVEG * PAHG + (1.0 - FVEG) * PAHB + PAHV TG = FVEG * TGV + (1.0 - FVEG) * TGB T2M = FVEG * T2MV + (1.0 - FVEG) * T2MB TS = FVEG * TV + (1.0 - FVEG) * TGB @@ -1784,6 +2550,7 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in CH = FVEG * CHV + (1.0 - FVEG) * CHB Q1 = FVEG * (EAH*0.622/(SFCPRS - 0.378*EAH)) + (1.0 - FVEG)*QSFC Q2E = FVEG * Q2V + (1.0 - FVEG) * Q2B + Z0WRF = Z0M ELSE TAUX = TAUXB TAUY = TAUYB @@ -1795,6 +2562,7 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in T2M = T2MB FCEV = 0. FCTR = 0. + PAH = PAHB TS = TG CM = CMB CH = CHB @@ -1804,6 +2572,7 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in RSSHA = 0.0 TGV = TGB CHV = CHB + Z0WRF = Z0MG END IF FIRE = LWDN + FIRA @@ -1836,7 +2605,7 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in CALL TSNOSOI (ICE ,NSOIL ,NSNOW ,ISNOW ,IST , & !in TBOT ,ZSNSO ,SSOIL ,DF ,HCPCT , & !in - ZBOT ,SAG ,DT ,SNOWH ,DZSNSO , & !in + SAG ,DT ,SNOWH ,DZSNSO , & !in TG ,ILOC ,JLOC , & !in STC ) !inout @@ -1865,14 +2634,19 @@ SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,ISC ,NSNOW ,NSOIL , & !in END SUBROUTINE ENERGY -! ================================================================================================== + +!== begin thermoprop =============================================================================== + SUBROUTINE THERMOPROP (NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , & !in - DT ,SNOWH ,SNICE ,SNLIQ ,CSOIL , & !in + DT ,SNOWH ,SNICE ,SNLIQ , & !in SMC ,SH2O ,TG ,STC ,UR , & !in - LAT ,Z0M ,ZLVL ,VEGTYP ,ISURBAN , & !in + LAT ,Z0M ,ZLVL ,VEGTYP , & !in DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , & !out FACT ) !out ! ------------------------------------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: CSOIL, SMCMAX, & ! SOIL DEPENDENT + TFRZ, TKICE, TKWAT, CICE, CWAT, CPAIR, & ! MP CONSTANT + ISURBAN ! MP CONSTANT ! ------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -1888,7 +2662,6 @@ SUBROUTINE THERMOPROP (NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , & !in REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice + liq.) [m3/m3] REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SH2O !liquid soil moisture [m3/m3] REAL , INTENT(IN) :: SNOWH !snow height [m] - REAL , INTENT(IN) :: CSOIL !vol. soil heat capacity [j/m3/k] REAL, INTENT(IN) :: TG !surface temperature (k) REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil/lake temp. (k) REAL, INTENT(IN) :: UR !wind speed at ZLVL (m/s) @@ -1896,7 +2669,6 @@ SUBROUTINE THERMOPROP (NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , & !in REAL, INTENT(IN) :: Z0M !roughness length (m) REAL, INTENT(IN) :: ZLVL !reference height (m) INTEGER , INTENT(IN) :: VEGTYP !vegtyp type - INTEGER , INTENT(IN) :: ISURBAN !urban type ! outputs REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: DF !thermal conductivity [w/m/k] @@ -1976,12 +2748,15 @@ SUBROUTINE THERMOPROP (NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , & !in END SUBROUTINE THERMOPROP -! ================================================================================================== -! -------------------------------------------------------------------------------------------------- + +!== begin csnow ==================================================================================== + SUBROUTINE CSNOW (ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , & !in TKSNO ,CVSNO ,SNICEV ,SNLIQV ,EPORE ) !out ! -------------------------------------------------------------------------------------------------- ! Snow bulk density,volumetric capacity, and thermal conductivity +!--------------------------------------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: DENICE, DENH2O, CICE, CWAT ! MP CONSTANT !--------------------------------------------------------------------------------------------------- IMPLICIT NONE !--------------------------------------------------------------------------------------------------- @@ -2033,8 +2808,9 @@ SUBROUTINE CSNOW (ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , & !in ENDDO END SUBROUTINE CSNOW -!=================================================================================================== -! -------------------------------------------------------------------------------------------------- + +!== begin tdfcnd =================================================================================== + SUBROUTINE TDFCND ( DF, SMC, SH2O) ! -------------------------------------------------------------------------------------------------- ! Calculate thermal diffusivity and conductivity of the soil. @@ -2042,6 +2818,9 @@ SUBROUTINE TDFCND ( DF, SMC, SH2O) ! -------------------------------------------------------------------------------------------------- ! Code history: ! June 2001 changes: frozen soil condition. +! -------------------------------------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: QUARTZ, SMCMAX, & ! SOIL DEPENDENT + TKICE ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE REAL, INTENT(IN) :: SMC ! total soil water @@ -2140,8 +2919,10 @@ SUBROUTINE TDFCND ( DF, SMC, SH2O) end subroutine TDFCND -! ================================================================================================== - SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in + +!== begin radiation ================================================================================ + + SUBROUTINE RADIATION (VEGTYP ,IST ,ICE ,NSOIL , & !in SNEQVO ,SNEQV ,DT ,COSZ ,SNOWH , & !in TG ,TV ,FSNO ,QSNOW ,FWET , & !in ELAI ,ESAI ,SMC ,SOLAD ,SOLAI , & !in @@ -2158,7 +2939,6 @@ SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in INTEGER, INTENT(IN) :: JLOC INTEGER, INTENT(IN) :: VEGTYP !vegetation type INTEGER, INTENT(IN) :: IST !surface type - INTEGER, INTENT(IN) :: ISC !soil color type (1-lighest; 8-darkest) INTEGER, INTENT(IN) :: ICE !ice (ice = 1) INTEGER, INTENT(IN) :: NSOIL !number of soil layers @@ -2229,7 +3009,7 @@ SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in ! surface abeldo - CALL ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in + CALL ALBEDO (VEGTYP ,IST ,ICE ,NSOIL , & !in DT ,COSZ ,FAGE ,ELAI ,ESAI , & !in TG ,TV ,SNOWH ,FSNO ,FWET , & !in SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , & !in @@ -2262,9 +3042,10 @@ SUBROUTINE RADIATION (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in FSRG) END SUBROUTINE RADIATION -! ================================================================================================== -! -------------------------------------------------------------------------------------------------- - SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in + +!== begin albedo =================================================================================== + + SUBROUTINE ALBEDO (VEGTYP ,IST ,ICE ,NSOIL , & !in DT ,COSZ ,FAGE ,ELAI ,ESAI , & !in TG ,TV ,SNOWH ,FSNO ,FWET , & !in SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , & !in @@ -2280,7 +3061,7 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in ! radiation) reflected, transmitted, and absorbed by vegetation. ! also sunlit fraction of the canopy. ! -------------------------------------------------------------------------------------------------- - USE NOAHMP_VEG_PARAMETERS + USE NOAHMP_PARAMETERS, ONLY: RHOL, RHOS, TAUL, TAUS ! VEGETATION AND RAD DEPENDENT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -2290,7 +3071,6 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in INTEGER, INTENT(IN) :: NSOIL !number of soil layers INTEGER, INTENT(IN) :: VEGTYP !vegetation type INTEGER, INTENT(IN) :: IST !surface type - INTEGER, INTENT(IN) :: ISC !soil color type (1-lighest; 8-darkest) INTEGER, INTENT(IN) :: ICE !ice (ice = 1) REAL, INTENT(IN) :: DT !time step [sec] @@ -2385,8 +3165,8 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in VAI = ELAI + ESAI WL = ELAI / MAX(VAI,MPE) WS = ESAI / MAX(VAI,MPE) - RHO(IB) = MAX(RHOL(VEGTYP,IB)*WL+RHOS(VEGTYP,IB)*WS, MPE) - TAU(IB) = MAX(TAUL(VEGTYP,IB)*WL+TAUS(VEGTYP,IB)*WS, MPE) + RHO(IB) = MAX(RHOL(IB)*WL+RHOS(IB)*WS, MPE) + TAU(IB) = MAX(TAUL(IB)*WL+TAUS(IB)*WS, MPE) END DO ! snow age @@ -2404,7 +3184,7 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in ! ground surface albedo - CALL GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in + CALL GROUNDALB (NSOIL ,NBAND ,ICE ,IST , & !in FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , & !in TG ,ILOC ,JLOC , & !in ALBGRD ,ALBGRI ) !out @@ -2445,8 +3225,9 @@ SUBROUTINE ALBEDO (VEGTYP ,IST ,ISC ,ICE ,NSOIL , & !in 100 CONTINUE END SUBROUTINE ALBEDO -! ================================================================================================== -! -------------------------------------------------------------------------------------------------- + +!== begin surrad =================================================================================== + SUBROUTINE SURRAD (MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in LAISUN ,LAISHA ,SOLAD ,SOLAI ,FABD , & !in FABI ,FTDD ,FTID ,FTII ,ALBGRD , & !in @@ -2568,9 +3349,13 @@ SUBROUTINE SURRAD (MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in END SUBROUTINE SURRAD -! ================================================================================================== -! -------------------------------------------------------------------------------------------------- + +!== begin snow_age ================================================================================= + SUBROUTINE SNOW_AGE (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: SWEMX, & ! SNOW GLOBAL + TFRZ ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! ------------------------ code history ------------------------------------------------------------ @@ -2620,8 +3405,9 @@ SUBROUTINE SNOW_AGE (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) FAGE= TAUSS/(TAUSS+1.) END SUBROUTINE SNOW_AGE -! ================================================================================================== -! -------------------------------------------------------------------------------------------------- + +!== begin snowalb_bats ============================================================================= + SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE @@ -2673,9 +3459,12 @@ SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) ALBSND(2)=ALBSNI(2)+0.4*FZEN*(1.-ALBSNI(2)) ! nir direct END SUBROUTINE SNOWALB_BATS -! ================================================================================================== -! -------------------------------------------------------------------------------------------------- + +!== begin snowalb_class ============================================================================ + SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: SWEMX ! SNOW GLOBAL ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -2715,7 +3504,7 @@ SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) ! here assume 1cm snow depth will fully cover the old snow IF (QSNOW > 0.) then - ALB = ALB + MIN(QSNOW*DT,SWEMX) * (0.84-ALB)/(SWEMX) + ALB = ALB + MIN(QSNOW,SWEMX/DT) * (0.84-ALB)/(SWEMX/DT) ENDIF ALBSNI(1)= ALB ! vis diffuse @@ -2724,14 +3513,16 @@ SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) ALBSND(2)= ALB ! nir direct END SUBROUTINE SNOWALB_CLASS -! ================================================================================================== -! -------------------------------------------------------------------------------------------------- - SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in + +!== begin groundalb ================================================================================ + + SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST , & !in FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , & !in TG ,ILOC ,JLOC , & !in ALBGRD ,ALBGRI ) !out ! -------------------------------------------------------------------------------------------------- - USE NOAHMP_RAD_PARAMETERS + USE NOAHMP_PARAMETERS, ONLY: ALBSAT, ALBDRY, ALBLAK, & ! SOIL/SURFACE AND RAD DEPENDENT + TFRZ ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -2743,7 +3534,6 @@ SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in INTEGER, INTENT(IN) :: NBAND !number of solar radiation waveband classes INTEGER, INTENT(IN) :: ICE !value of ist for land ice INTEGER, INTENT(IN) :: IST !surface type - INTEGER, INTENT(IN) :: ISC !soil color class (1-lighest; 8-darkest) REAL, INTENT(IN) :: FSNO !fraction of surface covered with snow (-) REAL, INTENT(IN) :: TG !ground temperature (k) REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) @@ -2767,7 +3557,7 @@ SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in DO IB = 1, NBAND INC = MAX(0.11-0.40*SMC(1), 0.) IF (IST .EQ. 1) THEN !soil - ALBSOD = MIN(ALBSAT(ISC,IB)+INC,ALBDRY(ISC,IB)) + ALBSOD = MIN(ALBSAT(IB)+INC,ALBDRY(IB)) ALBSOI = ALBSOD ELSE IF (TG .GT. TFRZ) THEN !unfrozen lake, wetland ALBSOD = 0.06/(MAX(0.01,COSZ)**1.7 + 0.15) @@ -2779,18 +3569,19 @@ SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST ,ISC , & !in ! increase desert and semi-desert albedos - IF (IST .EQ. 1 .AND. ISC .EQ. 9) THEN - ALBSOD = ALBSOD + 0.10 - ALBSOI = ALBSOI + 0.10 - end if +! IF (IST .EQ. 1 .AND. ISC .EQ. 9) THEN +! ALBSOD = ALBSOD + 0.10 +! ALBSOI = ALBSOI + 0.10 +! end if ALBGRD(IB) = ALBSOD*(1.-FSNO) + ALBSND(IB)*FSNO ALBGRI(IB) = ALBSOI*(1.-FSNO) + ALBSNI(IB)*FSNO END DO END SUBROUTINE GROUNDALB -! ================================================================================================== -! -------------------------------------------------------------------------------------------------- + +!== begin twostream ================================================================================ + SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in FWET ,T ,ALBGRD ,ALBGRI ,RHO , & !in TAU ,FVEG ,IST ,ILOC ,JLOC , & !in @@ -2804,8 +3595,9 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in ! and transmitted through vegetation for unit incoming direct or diffuse ! flux given an underlying surface with known albedo. ! -------------------------------------------------------------------------------------------------- - USE NOAHMP_VEG_PARAMETERS - USE NOAHMP_RAD_PARAMETERS + USE NOAHMP_PARAMETERS, ONLY: RC, HVT, HVB, DEN, XL, & ! VEGETATION DEPENDENT + OMEGAS, BETADS, BETAIS, & ! RAD DEPENDENT + TFRZ ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -2889,13 +3681,13 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in KOPEN = 1.0 ELSE IF(OPT_RAD == 1) THEN - DENFVEG = -LOG(MAX(1.0-FVEG,0.01))/(PAI*RC(VEGTYP)**2) - HD = HVT(VEGTYP) - HVB(VEGTYP) + DENFVEG = -LOG(MAX(1.0-FVEG,0.01))/(PAI*RC**2) + HD = HVT - HVB BB = 0.5 * HD - THETAP = ATAN(BB/RC(VEGTYP) * TAN(ACOS(MAX(0.01,COSZ))) ) - ! BGAP = EXP(-DEN(VEGTYP) * PAI * RC(VEGTYP)**2/COS(THETAP) ) - BGAP = EXP(-DENFVEG * PAI * RC(VEGTYP)**2/COS(THETAP) ) - FA = VAI/(1.33 * PAI * RC(VEGTYP)**3.0 *(BB/RC(VEGTYP))*DENFVEG) + THETAP = ATAN(BB/RC * TAN(ACOS(MAX(0.01,COSZ))) ) + ! BGAP = EXP(-DEN * PAI * RC**2/COS(THETAP) ) + BGAP = EXP(-DENFVEG * PAI * RC**2/COS(THETAP) ) + FA = VAI/(1.33 * PAI * RC**3.0 *(BB/RC)*DENFVEG) NEWVAI = HD*FA WGAP = (1.0-BGAP) * EXP(-0.5*NEWVAI/COSZ) GAP = MIN(1.0-FVEG, BGAP+WGAP) @@ -2922,7 +3714,7 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in ! weights of leaf and stem values. COSZI = MAX(0.001, COSZ) - CHIL = MIN( MAX(XL(VEGTYP), -0.4), 0.6) + CHIL = MIN( MAX(XL, -0.4), 0.6) IF (ABS(CHIL) .LE. 0.01) CHIL = 0.01 PHI1 = 0.5 - 0.633*CHIL - 0.330*CHIL*CHIL PHI2 = 0.877 * (1.-2.*PHI1) @@ -3040,25 +3832,27 @@ SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in !end if END SUBROUTINE TWOSTREAM -! ================================================================================================== + +!== begin vege_flux ================================================================================ + SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in DT ,SAV ,SAG ,LWDN ,UR , & !in UU ,VV ,SFCTMP ,THAIR ,QAIR , & !in EAIR ,RHOAIR ,SNOWH ,VAI ,GAMMAV ,GAMMAG, & !in FWET ,LAISUN ,LAISHA ,CWP ,DZSNSO , & !in - HTOP ,ZLVL ,ZPD ,Z0M ,FVEG , & !in - Z0MG ,EMV ,EMG ,CANLIQ , & !in + ZLVL ,ZPD ,Z0M ,FVEG , & !in + Z0MG ,EMV ,EMG ,CANLIQ ,FSNO, & !in CANICE ,STC ,DF ,RSSUN ,RSSHA , & !in RSURF ,LATHEAV ,LATHEAG ,PARSUN ,PARSHA ,IGS , & !in FOLN ,CO2AIR ,O2AIR ,BTRAN ,SFCPRS , & !in - RHSUR ,ILOC ,JLOC ,Q2 , & !in + RHSUR ,ILOC ,JLOC ,Q2 ,PAHV ,PAHG , & !in EAH ,TAH ,TV ,TG ,CM , & !inout CH ,DX ,DZ8W , & ! TAUXV ,TAUYV ,IRG ,IRC ,SHG , & !out SHC ,EVG ,EVC ,TR ,GH , & !out T2MV ,PSNSUN ,PSNSHA , & !out - QC ,PBLH ,QSFC ,PSFC ,ISURBAN , & !in - IZ0TLND ,Q2V ,CAH2,CHLEAF,CHUC) !inout + QC ,QSFC ,PSFC , & !in + Q2V ,CAH2 ,CHLEAF ,CHUC ) !inout ! -------------------------------------------------------------------------------------------------- ! use newton-raphson iteration to solve for vegetation (tv) and @@ -3068,8 +3862,8 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in ! -SAV + IRC[TV] + SHC[TV] + EVC[TV] + TR[TV] = 0 ! -SAG + IRG[TG] + SHG[TG] + EVG[TG] + GH[TG] = 0 ! -------------------------------------------------------------------------------------------------- - USE NOAHMP_VEG_PARAMETERS - USE MODULE_MODEL_CONSTANTS + USE NOAHMP_PARAMETERS, ONLY: HVT, & ! VEGETATION DEPENDENT + SB, VKC, TFRZ, CPAIR ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -3094,10 +3888,10 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in REAL, INTENT(IN) :: QAIR !specific humidity at zlvl (kg/kg) REAL, INTENT(IN) :: RHOAIR !density air (kg/m**3) REAL, INTENT(IN) :: DT !time step (s) + REAL, INTENT(IN) :: FSNO !snow fraction REAL, INTENT(IN) :: SNOWH !actual snow depth [m] REAL, INTENT(IN) :: FWET !wetted fraction of canopy - REAL, INTENT(IN) :: HTOP !top of canopy layer (m) REAL, INTENT(IN) :: CWP !canopy wind parameter REAL, INTENT(IN) :: VAI !total leaf area index + stem area index @@ -3132,15 +3926,14 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in REAL, INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) REAL, INTENT(IN) :: RHSUR !raltive humidity in surface soil/snow air space (-) - INTEGER , INTENT(IN) :: ISURBAN - INTEGER , INTENT(IN) :: IZ0TLND REAL , INTENT(IN) :: QC !cloud water mixing ratio - REAL , INTENT(IN) :: PBLH !planetary boundary layer height REAL , INTENT(IN) :: PSFC !pressure at lowest model layer REAL , INTENT(IN) :: DX !grid spacing REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) REAL , INTENT(IN) :: DZ8W !thickness of lowest layer REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer + REAL, INTENT(IN) :: PAHV !precipitation advected heat - canopy net IN (W/m2) + REAL, INTENT(IN) :: PAHG !precipitation advected heat - ground net IN (W/m2) ! input/output REAL, INTENT(INOUT) :: EAH !canopy air vapor pressure (pa) @@ -3282,6 +4075,7 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in ! --------------------------------------------------------------------------------------------- DTV = 0. DTG = 0. + MOZ = 0. MOZSGN = 0 MOZOLD = 0. HG = 0. @@ -3310,8 +4104,9 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in ! canopy height - HCAN = HTOP + HCAN = HVT UC = UR*LOG(HCAN/Z0M)/LOG(ZLVL/Z0M) + UC = UR*LOG((HCAN-ZPD+Z0M)/Z0M)/LOG(ZLVL/Z0M) ! MB: add ZPD v3.7 IF((HCAN-ZPD) <= 0.) THEN WRITE(message,*) "CRITICAL PROBLEM: HCAN <= ZPD" call wrf_message ( message ) @@ -3353,7 +4148,7 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in IF(OPT_SFC == 2) THEN CALL SFCDIF2(ITER ,Z0M ,TAH ,THAIR ,UR , & !in - CZIL ,ZLVL ,ILOC ,JLOC , & !in + ZLVL ,ILOC ,JLOC , & !in CM ,CH ,MOZ ,WSTAR , & !in FV ) !out ! Undo the multiplication by windspeed that SFCDIF2 @@ -3362,44 +4157,10 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in CM = CM / UR ENDIF - IF(OPT_SFC == 3) THEN - CALL SFCDIF3(ILOC ,JLOC ,TAH ,QSFC ,PSFC ,& !in - PBLH ,Z0M ,Z0MG ,VEGTYP ,ISURBAN,& !in - IZ0TLND,UC ,ITER ,NITERC ,SFCTMP ,& !in - THAIR ,QAIR ,QC ,ZLVL , & !in - SFCPRS ,FV ,CM ,CH ,CH2V ,& !inout - CQ2V ,MOZ) !out - ! Undo the multiplication by windspeed that SFCDIF3 - ! applies to exchange coefficients CH and CM: - CH = CH / UR - CM = CM / UR - CH2V = CH2V / UR - ENDIF - - IF(OPT_SFC == 4) THEN - CALL SFCDIF4(ILOC ,JLOC ,UU ,VV ,SFCTMP ,& !in - SFCPRS ,PSFC ,PBLH ,DX ,Z0M ,& - TAH ,QAIR ,ZLVL ,IZ0TLND,QSFC ,& - H ,QFX ,CM ,CH ,CH2V ,& - CQ2V ,MOZ ,FV ,U10V ,V10V) - ! Undo the multiplication by windspeed that SFCDIF4 - ! applies to exchange coefficients CH and CM: - CH = CH / UR - CM = CM / UR - CH2V = CH2V / UR - ENDIF - RAMC = MAX(1.,1./(CM*UR)) RAHC = MAX(1.,1./(CH*UR)) RAWC = RAHC - IF (OPT_SFC == 3 .OR. OPT_SFC == 4 ) THEN - RAHC2 = MAX(1.,1./(CH2V*UR)) - RAWC2 = RAHC2 - CAH2 = 1./RAHC2 - CQ2V = CAH2 - ENDIF - ! aerodyn resistance between heights z0g and d+z0v, RAG, and leaf ! boundary layer resistance, RB @@ -3482,7 +4243,7 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in EVC = MIN(CANICE*LATHEAV/DT,EVC) END IF - B = SAV-IRC-SHC-EVC-TR !additional w/m2 + B = SAV-IRC-SHC-EVC-TR+PAHV !additional w/m2 A = FVEG*(4.*CIR*TV**3 + CSH + (CEV+CTR)*DESTV) !volumetric heat capacity DTV = B/A @@ -3502,11 +4263,6 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in ! consistent specific humidity from canopy air vapor pressure QSFC = (0.622*EAH)/(SFCPRS-0.378*EAH) -! added moisture flux for sfcdif4 - IF ( OPT_SFC == 4 ) THEN - QFX = (QSFC-QAIR)*RHOAIR*CAW !*CPAIR/GAMMAV - ENDIF - IF (LITER == 1) THEN exit loop1 ENDIF @@ -3541,7 +4297,7 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in EVG = CEV * (ESTG*RHSUR - EAH ) GH = CGH * (TG - STC(ISNOW+1)) - B = SAG-IRG-SHG-EVG-GH + B = SAG-IRG-SHG-EVG-GH+PAHG A = 4.*CIR*TG**3+CSH+CEV*DESTG+CGH DTG = B/A @@ -3557,13 +4313,14 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in ! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes. - IF(OPT_STC == 1) THEN + IF(OPT_STC == 1 .OR. OPT_STC == 3) THEN IF (SNOWH > 0.05 .AND. TG > TFRZ) THEN TG = TFRZ + IF(OPT_STC == 3) TG = (1.-FSNO)*TG + FSNO*TFRZ ! MB: allow TG>0C during melt v3.7 IRG = CIR*TG**4 - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4 SHG = CSH * (TG - TAH) EVG = CEV * (ESTG*RHSUR - EAH) - GH = SAG - (IRG+SHG+EVG) + GH = SAG+PAHG - (IRG+SHG+EVG) END IF END IF @@ -3596,35 +4353,26 @@ SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in ENDIF ENDIF -! myj/ysu consistent 2m temperature over vegetation (if CQ2V .lt. 1e-5? ) - IF (OPT_SFC == 3 .OR. OPT_SFC == 4 ) THEN - IF (CAH2 .LT. 1.E-5 ) THEN - T2MV = TAH - Q2V = (EAH*0.622/(SFCPRS - 0.378*EAH)) - ELSE - T2MV = TAH - (SHG+SHC)/(RHOAIR*CPAIR*CAH2) - Q2V = (EAH*0.622/(SFCPRS - 0.378*EAH)) - QFX/(RHOAIR*CQ2V) - ENDIF - ENDIF - ! update CH for output CH = CAH CHLEAF = CVH CHUC = 1./RAHG END SUBROUTINE VEGE_FLUX -! ================================================================================================== + +!== begin bare_flux ================================================================================ + SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in LWDN ,UR ,UU ,VV ,SFCTMP , & !in THAIR ,QAIR ,EAIR ,RHOAIR ,SNOWH , & !in - DZSNSO ,ZLVL ,ZPD ,Z0M , & !in + DZSNSO ,ZLVL ,ZPD ,Z0M ,FSNO , & !in EMG ,STC ,DF ,RSURF ,LATHEA , & !in - GAMMA ,RHSUR ,ILOC ,JLOC ,Q2 , & !in + GAMMA ,RHSUR ,ILOC ,JLOC ,Q2 ,PAHB , & !in TGB ,CM ,CH , & !inout TAUXB ,TAUYB ,IRB ,SHB ,EVB , & !out GHB ,T2MB ,DX ,DZ8W ,IVGTYP , & !out - QC ,PBLH ,QSFC ,PSFC ,ISURBAN , & !in - IZ0TLND ,SFCPRS ,Q2B ,EHB2) !in + QC ,QSFC ,PSFC , & !in + SFCPRS ,Q2B ,EHB2 ) !in ! -------------------------------------------------------------------------------------------------- ! use newton-raphson iteration to solve ground (tg) temperature @@ -3633,8 +4381,7 @@ SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in ! bare soil: ! -SAB + IRB[TG] + SHB[TG] + EVB[TG] + GHB[TG] = 0 ! ---------------------------------------------------------------------- - USE NOAHMP_VEG_PARAMETERS - USE MODULE_MODEL_CONSTANTS + USE NOAHMP_PARAMETERS, ONLY: SB, VKC, TFRZ, CPAIR, ISURBAN ! MP CONSTANT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -3667,13 +4414,11 @@ SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in REAL, INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg) REAL, INTENT(IN) :: GAMMA !psychrometric constant (pa/k) REAL, INTENT(IN) :: RHSUR !raltive humidity in surface soil/snow air space (-) + REAL, INTENT(IN) :: FSNO !snow fraction !jref:start; in - INTEGER , INTENT(IN) :: ISURBAN INTEGER , INTENT(IN) :: IVGTYP - INTEGER , INTENT(IN) :: IZ0TLND REAL , INTENT(IN) :: QC !cloud water mixing ratio - REAL , INTENT(IN) :: PBLH !planetary boundary layer height REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer REAL , INTENT(IN) :: PSFC !pressure at lowest model layer REAL , INTENT(IN) :: SFCPRS !pressure at lowest model layer @@ -3681,6 +4426,7 @@ SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) REAL , INTENT(IN) :: DZ8W !thickness of lowest layer !jref:end + REAL, INTENT(IN) :: PAHB !precipitation advected heat - ground net IN (W/m2) ! input/output REAL, INTENT(INOUT) :: TGB !ground temperature (k) @@ -3782,6 +4528,7 @@ SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in ! ----------------------------------------------------------------- MPE = 1E-6 DTG = 0. + MOZ = 0. MOZSGN = 0 MOZOLD = 0. H = 0. @@ -3810,7 +4557,7 @@ SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in IF(OPT_SFC == 2) THEN CALL SFCDIF2(ITER ,Z0M ,TGB ,THAIR ,UR , & !in - CZIL ,ZLVL ,ILOC ,JLOC , & !in + ZLVL ,ILOC ,JLOC , & !in CM ,CH ,MOZ ,WSTAR , & !in FV ) !out ! Undo the multiplication by windspeed that SFCDIF2 @@ -3824,49 +4571,6 @@ SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in ENDIF - IF(OPT_SFC == 3) THEN - VEGTYP = ISBARREN - CALL SFCDIF3(ILOC ,JLOC ,TGB ,QSFC ,PSFC ,& !in - PBLH ,Z0M ,Z0M ,VEGTYP ,ISURBAN,& !in - IZ0TLND,UR ,ITER ,NITERB ,SFCTMP ,& !in - THAIR ,QAIR ,QC ,ZLVL , & !in - SFCPRS ,FV ,CM ,CH ,CH2B ,& !inout - CQ2B ,MOZ) !out - ! Undo the multiplication by windspeed that SFCDIF3 - ! applies to exchange coefficients CH and CM: - CH = CH / UR - CM = CM / UR - CH2B = CH2B / UR - - IF(SNOWH > 0.) THEN ! jref: does this still count?? - CM = MIN(0.01,CM) ! CM & CH are too large, causing - CH = MIN(0.01,CH) ! computational instability - CH2B = MIN(0.01,CH2B) - CQ2B = MIN(0.01,CQ2B) - END IF - ENDIF - - IF(OPT_SFC == 4) THEN - CALL SFCDIF4(ILOC ,JLOC ,UU ,VV ,SFCTMP ,& !in - SFCPRS ,PSFC ,PBLH ,DX ,Z0M ,& - TGB ,QAIR ,ZLVL ,IZ0TLND,QSFC ,& - H ,QFX ,CM ,CH ,CH2B ,& - CQ2B ,MOZ ,FV ,U10B ,V10B) - ! Undo the multiplication by windspeed that SFCDIF4 - ! applies to exchange coefficients CH and CM: - CH = CH / UR - CM = CM / UR - CH2B = CH2B / UR - - IF(SNOWH > 0.) THEN ! jref: does this still count?? - CM = MIN(0.01,CM) ! CM & CH are too large, causing - CH = MIN(0.01,CH) ! computational instability - CH2B = MIN(0.01,CH2B) - CQ2B = MIN(0.01,CQ2B) - END IF - - ENDIF - RAMB = MAX(1.,1./(CM*UR)) RAHB = MAX(1.,1./(CH*UR)) RAWB = RAHB @@ -3874,11 +4578,6 @@ SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in !jref - variables for diagnostics EMB = 1./RAMB EHB = 1./RAHB - IF (OPT_SFC == 3 .OR. OPT_SFC == 4) THEN - RAHB2 = MAX(1.,1./(CH2B*UR)) - EHB2 = 1./RAHB2 - CQ2B = EHB2 - END IF ! es and d(es)/dt evaluated at tg @@ -3902,7 +4601,7 @@ SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in EVB = CEV * (ESTG*RHSUR - EAIR ) GHB = CGH * (TGB - STC(ISNOW+1)) - B = SAG-IRB-SHB-EVB-GHB + B = SAG-IRB-SHB-EVB-GHB+PAHB A = 4.*CIR*TGB**3 + CSH + CEV*DESTG + CGH DTG = B/A @@ -3933,13 +4632,14 @@ SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in ! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes. - IF(OPT_STC == 1) THEN + IF(OPT_STC == 1 .OR. OPT_STC == 3) THEN IF (SNOWH > 0.05 .AND. TGB > TFRZ) THEN TGB = TFRZ + IF(OPT_STC == 3) TGB = (1.-FSNO)*TGB + FSNO*TFRZ ! MB: allow TG>0C during melt v3.7 IRB = CIR * TGB**4 - EMG*LWDN SHB = CSH * (TGB - SFCTMP) EVB = CEV * (ESTG*RHSUR - EAIR ) !ESTG reevaluate ? - GHB = SAG - (IRB+SHB+EVB) + GHB = SAG+PAHB - (IRB+SHB+EVB) END IF END IF @@ -3964,25 +4664,13 @@ SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in IF (IVGTYP == ISURBAN) Q2B = QSFC END IF -! myj consistent 2m temperature over bare soil - IF(OPT_SFC ==3 .OR. OPT_SFC == 4) THEN - IF (EHB2.lt.1.E-5 ) THEN - T2MB = TGB - Q2B = QSFC - ELSE - T2MB = TGB - SHB/(RHOAIR*CPAIR*EHB2) - Q2B = QSFC - QFX/(RHOAIR*CQ2B) - END IF -! IF (IVGTYP == ISURBAN) THEN -! Q2B = QSFC -! END IF - END IF - ! update CH CH = EHB END SUBROUTINE BARE_FLUX -! ================================================================================================== + +!== begin ragrb ==================================================================================== + SUBROUTINE RAGRB(ITER ,VAI ,RHOAIR ,HG ,TAH , & !in ZPD ,Z0MG ,Z0HG ,HCAN ,UC , & !in Z0H ,FV ,CWP ,VEGTYP ,MPE , & !in @@ -3992,7 +4680,8 @@ SUBROUTINE RAGRB(ITER ,VAI ,RHOAIR ,HG ,TAH , & !in ! compute under-canopy aerodynamic resistance RAG and leaf boundary layer ! resistance RB ! -------------------------------------------------------------------------------------------------- - USE NOAHMP_VEG_PARAMETERS + USE NOAHMP_PARAMETERS, ONLY: DLEAF, & ! VEGETATION DEPENDENT + GRAV, VKC, CPAIR ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -4077,12 +4766,12 @@ SUBROUTINE RAGRB(ITER ,VAI ,RHOAIR ,HG ,TAH , & !in ! leaf boundary layer resistance TMPRB = CWPC*50. / (1. - EXP(-CWPC/2.)) - RB = TMPRB * SQRT(DLEAF(VEGTYP)/UC) + RB = TMPRB * SQRT(DLEAF/UC) ! RB = 200 END SUBROUTINE RAGRB -! ================================================================================================== +!== begin sfcdif1 ================================================================================== SUBROUTINE SFCDIF1(ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in & ZLVL ,ZPD ,Z0M ,Z0H ,UR , & !in @@ -4091,6 +4780,8 @@ SUBROUTINE SFCDIF1(ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in & CM ,CH ,FV ,CH2 ) !out ! ------------------------------------------------------------------------------------------------- ! computing surface drag coefficient CM for momentum and CH for heat +! ------------------------------------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: GRAV, VKC, CPAIR ! MP CONSTANT ! ------------------------------------------------------------------------------------------------- IMPLICIT NONE ! ------------------------------------------------------------------------------------------------- @@ -4245,10 +4936,10 @@ SUBROUTINE SFCDIF1(ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in END SUBROUTINE SFCDIF1 -! ================================================================================================== +!== begin sfcdif2 ================================================================================== SUBROUTINE SFCDIF2(ITER ,Z0 ,THZ0 ,THLM ,SFCSPD , & !in - CZIL ,ZLM ,ILOC ,JLOC , & !in + ZLM ,ILOC ,JLOC , & !in AKMS ,AKHS ,RLMO ,WSTAR2 , & !in USTAR ) !out @@ -4258,12 +4949,14 @@ SUBROUTINE SFCDIF2(ITER ,Z0 ,THZ0 ,THLM ,SFCSPD , & !in ! CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS. ! SEE CHEN ET AL (1997, BLM) ! ------------------------------------------------------------------------------------------------- - + USE NOAHMP_PARAMETERS, ONLY: CZIL, & ! GENPARM DEPENDENT + GRAV ! MP CONSTANT +! ---------------------------------------------------------------------- IMPLICIT NONE INTEGER, INTENT(IN) :: ILOC INTEGER, INTENT(IN) :: JLOC INTEGER, INTENT(IN) :: ITER - REAL, INTENT(IN) :: ZLM, Z0, THZ0, THLM, SFCSPD, CZIL + REAL, INTENT(IN) :: ZLM, Z0, THZ0, THLM, SFCSPD REAL, intent(INOUT) :: AKMS REAL, intent(INOUT) :: AKHS REAL, intent(INOUT) :: RLMO @@ -4446,855 +5139,9 @@ SUBROUTINE SFCDIF2(ITER ,Z0 ,THZ0 ,THLM ,SFCSPD , & !in ! END DO ! ---------------------------------------------------------------------- END SUBROUTINE SFCDIF2 -!jref:start -! ================================================================================================== - SUBROUTINE SFCDIF3(ILOC ,JLOC ,TSK ,QS ,PSFC ,& !in - PBLH ,Z0 ,Z0BASE ,VEGTYP ,ISURBAN,& !in - IZ0TLND,SFCSPD ,ITER ,ITRMX ,TLOW ,& !in - THLOW ,QLOW ,CWMLOW ,ZSL , & !in - PLOW ,USTAR ,AKMS ,AKHS ,CHS2 ,& !inout - CQS2 ,RLMO ) !out - - USE MODULE_SF_MYJSFC, ONLY : & - & EPSU2 , & - & EPSUST , & - & EPSZT , & - & BETA , & - & EXCML , & - & RIC , & - & SQVISC , & - & ZTFC , & - & BTG , & - & CZIV , & - & PI , & - & PIHF , & - & KZTM , & - & KZTM2 , & - & DZETA1 , & - & DZETA2 , & - & FH01 , & - & FH02 , & - & WWST2 , & - & WWST , & - & ZTMAX1 , & - & ZTMAX2 , & - & ZTMIN1 , & - & ZTMIN2 , & - & PSIH1 , & - & PSIH2 , & - & PSIM1 , & - & PSIM2 - - USE MODULE_MODEL_CONSTANTS - -!---------------------------------------------------------------------- -! computing surface drag coefficient CM for momentum and CH for heat -! Joakim Refslund, 2011, MYJ SFCLAY -!---------------------------------------------------------------------- - IMPLICIT NONE -!---------------------------------------------------------------------- -! input - INTEGER,INTENT(IN) :: ILOC - INTEGER,INTENT(IN) :: JLOC - REAL ,INTENT(IN) :: TSK - REAL ,INTENT(IN) :: PSFC - REAL ,INTENT(IN) :: PBLH - INTEGER,INTENT(IN) :: VEGTYP !in routine - INTEGER,INTENT(IN) :: ISURBAN !in veg_parm - INTEGER,INTENT(IN) :: IZ0TLND - REAL ,INTENT(IN) :: QLOW - REAL ,INTENT(IN) :: THLOW - REAL ,INTENT(IN) :: TLOW - REAL ,INTENT(IN) :: CWMLOW - REAL ,INTENT(IN) :: SFCSPD - REAL ,INTENT(IN) :: PLOW - REAL ,INTENT(IN) :: ZSL - REAL ,INTENT(IN) :: Z0BASE - INTEGER,INTENT(IN) :: ITER - INTEGER,INTENT(IN) :: ITRMX - -! output - REAL ,INTENT(OUT) :: CHS2 - REAL ,INTENT(OUT) :: CQS2 - REAL ,INTENT(OUT) :: RLMO - -! input/output - REAL ,INTENT(INOUT) :: AKHS - REAL ,INTENT(INOUT) :: AKMS - REAL :: QZ0 - REAL ,INTENT(INOUT) :: USTAR - REAL ,INTENT(IN) :: Z0 - REAL ,INTENT(INOUT):: QS - REAL :: RIB - -! local - INTEGER :: ITR,K - REAL :: THZ0 - REAL :: THVLOW - REAL :: CT - REAL :: BTGH - REAL :: BTGX - REAL :: CXCHL - REAL :: DTHV - REAL :: DU2 - REAL :: ELFC - REAL :: PSH02 - REAL :: PSH10 - REAL :: PSHZ - REAL :: PSHZL - REAL :: PSM10 - REAL :: PSMZ - REAL :: PSMZL - REAL :: RDZ - REAL :: RDZT - REAL :: RLMA !??? - REAL :: RLMN !??? - REAL :: RLOGT - REAL :: RLOGU - REAL :: RZ - REAL :: SIMH - REAL :: SIMM - REAL :: USTARK - REAL :: WSTAR2 - REAL :: WSTAR - REAL :: CHS - REAL :: RZSU - REAL :: RZST - REAL :: X,XLT,XLT4,XLU,XLU4,XT,XT4,XU,XU4,ZETALT,ZETALU , & - ZETAT,ZETAU,ZQ,ZSLT,ZSLU,ZT,ZU,TOPOTERM,ZZIL - REAL :: AKHS02,AKHS10,AKMS02,AKMS10 - REAL :: ZU10 - REAL :: ZT02 - REAL :: ZT10 - REAL :: RLNU10 - REAL :: RLNT02 - REAL :: RLNT10 - REAL :: ZTAU10 - REAL :: ZTAT02 - REAL :: ZTAT10 - REAL :: SIMM10 - REAL :: SIMH02 - REAL :: SIMH10 - REAL :: ZUUZ - REAL :: EKMS10 - REAL :: test - REAL :: E1 - - REAL, PARAMETER :: VKRM = 0.40 - REAL, PARAMETER :: CZETMAX = 10. - -! diagnostic terms - - REAL :: CZIL - REAL :: ZILFC - -! KTMZ,KTMZ2,DZETA1,DZETA2,FH01,FH02,ZTMAX1,ZTMAX2,ZTMIN1,ZTMIN2, -! PSIH1,PSIH2,PSIM1,PSIM2 ARE DEFINED IN MODULE_SF_MYJSFC - -!---------------------------------------------------------------------- -! IF (ILOC.eq.39 .and. JLOC.eq.63 .and. ITER == 1 ) then -! write(*,*) "THZ0=",THZ0 -! write(*,*) "QS =",QS -! write(*,*) "PSFC=",PSFC -! write(*,*) "PBLH=",PBLH -! write(*,*) "Z0=",Z0 -! write(*,*) "Z0BASE=",Z0BASE -! write(*,*) "VEGTYP=",VEGTYP -! write(*,*) "ISURBAN=",ISURBAN -! write(*,*) "IZ0TLND=",IZ0TLND -! write(*,*) "SFCSPD=",SFCSPD -! write(*,*) "TLOW=",TLOW -! write(*,*) "THLOW=",THLOW -! write(*,*) "THVLOW=",THVLOW -! write(*,*) "QLOW=",QLOW -! write(*,*) "CWMLOW=",CWMLOW -! write(*,*) "ZSL=",ZSL -! write(*,*) "PLOW=",PLOW -! write(*,*) "USTAR=",USTAR -! write(*,*) "AKMS=",AKMS -! write(*,*) "AKHS=",AKHS -! write(*,*) "CHS2=",CHS2 -! write(*,*) "CQS2=",CQS2 -! write(*,*) "RLMO=",RLMO -! write(*,*) "ITER=",ITER -! call wrf_error_fatal("STOP in SFCDIF3") -! ENDIF - -! calculate potential and virtual potential temperatures - THVLOW = THLOW*(1.+EP_1*QLOW) - THZ0 = TSK*(P1000mb/PSFC)**RCP - -! calculate initial values - ZU = Z0 - ZT = ZU*ZTFC !ZTFC = ZOH/ZOM =<1 set to 1 at beginning - ZQ = ZT - QZ0 = QS - - RDZ = 1./ZSL - CXCHL = EXCML*RDZ - DTHV = THVLOW-THZ0*(0.608*QZ0+1.) !delta pot. virtual temperature - - BTGX=GRAV/THLOW - ELFC=VKRM*BTGX - -! Minimum PBLH is >= 1000. - IF(PBLH > 1000.)THEN - BTGH = BTGX*PBLH - ELSE - BTGH = BTGX*1000. - ENDIF - - DU2 = MAX(SFCSPD*SFCSPD,EPSU2) !Wind speed - EPSU2 parm = 1*10^-6 - RIB = BTGX*DTHV*ZSL/DU2 !Bulk richardson stability - - ZSLU = ZSL+ZU - RZSU = ZSLU/ZU - RLOGU = LOG(RZSU) !log(z/z0) - - ZSLT = ZSL + ZU - - IF ( (IZ0TLND==0) .or. (VEGTYP == ISURBAN) ) THEN ! ARE IZ0TLND DEFINED HERE? - ! Just use the original CZIL value. - CZIL = 0.1 - ELSE - ! Modify CZIL according to Chen & Zhang, 2009 - ! CZIL = 10 ** -0.40 H, ( where H = 10*Zo ) - CZIL = 10.0 ** ( -0.40 * ( Z0 / 0.07 ) ) - ENDIF - ZILFC=-CZIL*VKRM*SQVISC !SQVISC parm - -! stable - IF(DTHV>0.)THEN - IF (RIBTHZ0.AND.(TH02THLOW).OR. & -! THLOWTHZ0.OR.TH02THZ0.AND.(TH10THLOW).OR. & -! THLOWTHZ0.OR.TH10 input variable T1D - REAL :: TVIR ! temporal variable SRC4 -> TVIR - REAL :: THGB ! Potential temperature ground - REAL :: PSFC ! Surface pressure - REAL :: BR ! bulk richardson number - REAL :: CPM - REAL :: MOL - REAL :: ZOL - REAL :: QGH - REAL :: WSPD - - INTEGER :: N,I,K,KK,L,NZOL,NK,NZOL2,NZOL10 - - REAL :: PL,THCON,TVCON,E1 - REAL :: ZL,TSKV,DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10 - REAL :: DTG,PSIX,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2,PSIQ10 - REAL :: FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,RESTAR2 -!------------------------------------------------------------------- - - MOL = 1./RMOL - ZL=0.01 - PSFC=PSFCPA/1000. - -! convert (tah or tgb = tsk) temperature to potential temperature. - TGDSA = TSK - THGB = TSK*(P1000mb/PSFCPA)**RCP - -! store virtual, virtual potential and potential temperature - PL = P1D/1000. - THX = T1D*(P1000mb*0.001/PL)**RCP - THVX = THX*(1.+EP_1*QX) - TVIR = T1D*(1.+EP_1*QX) - -! for land points QSFC can come from previous time step - !QSFC=EP_2*E1/(PSFC-E1) - IF (QSFC.LE.0.0) THEN - !testing this - E1=SVP1*EXP(SVP2*(TGDSA-SVPT0)/(TGDSA-SVP3)) - QSFC=EP_2*E1/(PSFC-E1) - write(*,*) "JREF: IN SFCDIF4, QSFC WAS NEG. NOW = ",QSFC - ENDIF +!== begin esat ===================================================================================== -! qgh changed to use lowest-level air temp consistent with myjsfc change -! q2sat = qgh in lsm -!jref: canres and esat is calculated in the loop so should that be changed?? -! QGH=EP_2*E1/(PL-E1) - CPM=CP*(1.+0.8*QX) - -! compute the height of half-sigma levels above ground level - !ZA=0.5*DZ8W - ZA = ZLVL - -! compute density and part of monin-obukhov length L - RHOX=PSFC*1000./(R_D*TVIR) - GOVRTH=G/THX - -! calculate bulk richardson no. of surface layer, -! according to akb(1976), eq(12). - GZ1OZ0=ALOG(ZA/ZNT) - GZ2OZ0=ALOG(2./ZNT) - GZ10OZ0=ALOG(10./ZNT) - WSPD=SQRT(UX*UX+VX*VX) - -! virtual pot. temperature difference between input layer and lowest model layer - TSKV=THGB*(1.+EP_1*QSFC) - DTHVDZ=(THVX-TSKV) - -! convective velocity scale Vc and subgrid-scale velocity Vsg -! following Beljaars (1995, QJRMS) and Mahrt and Sun (1995, MWR) -! ... HONG Aug. 2001 -! -! VCONV = 0.25*sqrt(g/tskv*pblh(i)*dthvm) -! use Beljaars over land, old MM5 (Wyngaard) formula over water - -!jref:start commented out to see if stability is affected. - FLUXC = MAX(HFX/RHOX/CP + EP_1*TSKV*QFX/RHOX,0.) - VCONV = VCONVC*(G/TGDSA*PBLH*FLUXC)**.33 -! VCONV = 0 -!jref:end - -! Mahrt and Sun low-res correction - VSGD = 0.32 * (max(dx/5000.-1.,0.))**.33 - WSPD=SQRT(WSPD*WSPD+VCONV*VCONV+VSGD*VSGD) - WSPD=AMAX1(WSPD,0.1) - BR=GOVRTH*ZA*DTHVDZ/(WSPD*WSPD) -! if previously unstable, do not let into regimes 1 and 2 - IF(MOL.LT.0.) BR=AMIN1(BR,0.0) - RMOL=-GOVRTH*DTHVDZ*ZA*KARMAN - -!----------------------------------------------------------------------- -! diagnose basic parameters for the appropriated stability class: -! -! the stability classes are determined by br (bulk richardson no.) -! and hol (height of pbl/monin-obukhov length). -! -! criteria for the classes are as follows: -! -! 1. br .ge. 0.2; -! represents nighttime stable conditions (regime=1), -! -! 2. br .lt. 0.2 .and. br .gt. 0.0; -! represents damped mechanical turbulent conditions -! (regime=2), -! -! 3. br .eq. 0.0 -! represents forced convection conditions (regime=3), -! -! 4. br .lt. 0.0 -! represents free convection conditions (regime=4). -! -!----------------------------------------------------------------------- - - IF (BR.GE.0.2) REGIME=1 - IF (BR.LT.0.2 .AND. BR.GT.0.0) REGIME=2 - IF (BR.EQ.0.0) REGIME=3 - IF (BR.LT.0.0) REGIME=4 - - SELECT CASE(REGIME) - CASE(1) ! class 1; stable (nighttime) conditions: - PSIM=-10.*GZ1OZ0 -! lower limit on psi in stable conditions - PSIM=AMAX1(PSIM,-10.) - PSIH=PSIM - PSIM10=10./ZA*PSIM - PSIM10=AMAX1(PSIM10,-10.) - PSIH10=PSIM10 - PSIM2=2./ZA*PSIM - PSIM2=AMAX1(PSIM2,-10.) - PSIH2=PSIM2 - -! 1.0 over Monin-Obukhov length - IF(UST.LT.0.01)THEN - RMOL=BR*GZ1OZ0 !ZA/L - ELSE - RMOL=KARMAN*GOVRTH*ZA*MOL/(UST*UST) !ZA/L - ENDIF - RMOL=AMIN1(RMOL,9.999) ! ZA/L - RMOL = RMOL/ZA !1.0/L - - CASE(2) ! class 2; damped mechanical turbulence: - PSIM=-5.0*BR*GZ1OZ0/(1.1-5.0*BR) -! lower limit on psi in stable conditions - PSIM=AMAX1(PSIM,-10.) -! AKB(1976), EQ(16). - PSIH=PSIM - PSIM10=10./ZA*PSIM - PSIM10=AMAX1(PSIM10,-10.) - PSIH10=PSIM10 - PSIM2=2./ZA*PSIM - PSIM2=AMAX1(PSIM2,-10.) - PSIH2=PSIM2 - - ! Linear form: PSIM = -0.5*ZA/L; e.g, see eqn 16 of - ! Blackadar, Modeling the nocturnal boundary layer, Preprints, - ! Third Symposium on Atmospheric Turbulence Diffusion and Air Quality, - ! Raleigh, NC, 1976 - ZOL = BR*GZ1OZ0/(1.00001-5.0*BR) - - IF ( ZOL .GT. 0.5 ) THEN ! linear form ok - ! Holtslag and de Bruin, J. App. Meteor 27, 689-704, 1988; - ! see also, Launiainen, Boundary-Layer Meteor 76,165-179, 1995 - ! Eqn (8) of Launiainen, 1995 - ZOL = ( 1.89*GZ1OZ0 + 44.2 ) * BR*BR & - + ( 1.18*GZ1OZ0 - 1.37 ) * BR - ZOL=AMIN1(ZOL,9.999) - END IF - -! 1.0 over Monin-Obukhov length - RMOL= ZOL/ZA - - CASE(3) ! class 3; forced convection: - PSIM=0.0 - PSIH=PSIM - PSIM10=0. - PSIH10=PSIM10 - PSIM2=0. - PSIH2=PSIM2 - IF(UST.LT.0.01)THEN - ZOL=BR*GZ1OZ0 - ELSE - ZOL=KARMAN*GOVRTH*ZA*MOL/(UST*UST) - ENDIF - - RMOL = ZOL/ZA - - CASE(4) ! class 4; free convection: - IF(UST.LT.0.01)THEN - ZOL=BR*GZ1OZ0 - ELSE - ZOL=KARMAN*GOVRTH*ZA*MOL/(UST*UST) - ENDIF - ZOL10=10./ZA*ZOL - ZOL2=2./ZA*ZOL - ZOL=AMIN1(ZOL,0.) - ZOL=AMAX1(ZOL,-9.9999) - ZOL10=AMIN1(ZOL10,0.) - ZOL10=AMAX1(ZOL10,-9.9999) - ZOL2=AMIN1(ZOL2,0.) - ZOL2=AMAX1(ZOL2,-9.9999) - NZOL=INT(-ZOL*100.) - RZOL=-ZOL*100.-NZOL - NZOL10=INT(-ZOL10*100.) - RZOL10=-ZOL10*100.-NZOL10 - NZOL2=INT(-ZOL2*100.) - RZOL2=-ZOL2*100.-NZOL2 - PSIM=PSIMTB(NZOL)+RZOL*(PSIMTB(NZOL+1)-PSIMTB(NZOL)) - PSIH=PSIHTB(NZOL)+RZOL*(PSIHTB(NZOL+1)-PSIHTB(NZOL)) - PSIM10=PSIMTB(NZOL10)+RZOL10*(PSIMTB(NZOL10+1)-PSIMTB(NZOL10)) - PSIH10=PSIHTB(NZOL10)+RZOL10*(PSIHTB(NZOL10+1)-PSIHTB(NZOL10)) - PSIM2=PSIMTB(NZOL2)+RZOL2*(PSIMTB(NZOL2+1)-PSIMTB(NZOL2)) - PSIH2=PSIHTB(NZOL2)+RZOL2*(PSIHTB(NZOL2+1)-PSIHTB(NZOL2)) - -! limit psih and psim in the case of thin layers and high roughness -! this prevents denominator in fluxes from getting too small -! PSIH=AMIN1(PSIH,0.9*GZ1OZ0) -! PSIM=AMIN1(PSIM,0.9*GZ1OZ0) - PSIH=AMIN1(PSIH,0.9*GZ1OZ0) - PSIM=AMIN1(PSIM,0.9*GZ1OZ0) - PSIH2=AMIN1(PSIH2,0.9*GZ2OZ0) - PSIM10=AMIN1(PSIM10,0.9*GZ10OZ0) -! AHW: mods to compute ck, cd - PSIH10=AMIN1(PSIH10,0.9*GZ10OZ0) - - RMOL = ZOL/ZA - - END SELECT ! stability regime done - -! compute the frictional velocity: ZA(1982) EQS(2.60),(2.61). - DTG=THX-THGB - PSIX=GZ1OZ0-PSIM - PSIX10=GZ10OZ0-PSIM10 - -! lower limit added to prevent large flhc in soil model -! activates in unstable conditions with thin layers or high z0 - PSIT=AMAX1(GZ1OZ0-PSIH,2.) !does this still apply???? jref - PSIQ=ALOG(KARMAN*UST*ZA/XKA+ZA/ZL)-PSIH - PSIT2=GZ2OZ0-PSIH2 - PSIQ2=ALOG(KARMAN*UST*2./XKA+2./ZL)-PSIH2 -! AHW: mods to compute ck, cd - PSIQ10=ALOG(KARMAN*UST*10./XKA+10./ZL)-PSIH10 - -!jref:start - commented out since these values can be produced by sfclay routine -! IF(PRESENT(ck) .and. PRESENT(cd) .and. PRESENT(cka) .and. PRESENT(cda)) THEN -! Ck=(karman/psix10)*(karman/psiq10) -! Cd=(karman/psix10)*(karman/psix10) -! Cka=(karman/psix)*(karman/psiq) -! Cda=(karman/psix)*(karman/psix) -! ENDIF - -! WRITE(*,*) "KARMAN=",KARMAN -! WRITE(*,*) "UST=",UST -! WRITE(*,*) "XKA=",XKA -! WRITE(*,*) "ZA =",ZA -! WRITE(*,*) "ZL =",ZL -! WRITE(*,*) "PSIH=",PSIH -! WRITE(*,*) "PSIQ=",PSIQ,"PSIT=",PSIT - - IF ( PRESENT(IZ0TLND) ) THEN - IF ( IZ0TLND.EQ.1 ) THEN - ZL=ZNT -! czil related changes for land - VISC=(1.32+0.009*(T1D-273.15))*1.E-5 - RESTAR=UST*ZL/VISC -! modify CZIL according to Chen & Zhang, 2009 - - CZIL = 10.0 ** ( -0.40 * ( ZL / 0.07 ) ) - - PSIT=GZ1OZ0-PSIH+CZIL*KARMAN*SQRT(RESTAR) - PSIQ=GZ1OZ0-PSIH+CZIL*KARMAN*SQRT(RESTAR) - PSIT2=GZ2OZ0-PSIH2+CZIL*KARMAN*SQRT(RESTAR) - PSIQ2=GZ2OZ0-PSIH2+CZIL*KARMAN*SQRT(RESTAR) - ENDIF - ENDIF - - -! to prevent oscillations average with old value - UST=0.5*UST+0.5*KARMAN*WSPD/PSIX - UST=AMAX1(UST,0.1) -!jref: should this be converted to RMOL??? - MOL=KARMAN*DTG/PSIT/PRT - DENOMQ=PSIQ - DENOMQ2=PSIQ2 - DENOMT2=PSIT2 -! WRITE(*,*) "ILOC,JLOC=",ILOC,JLOC,"DENOMQ=",DENOMQ -! WRITE(*,*) "UST=",UST,"PSIT=",PSIT -! call wrf_error_fatal("stop in sfcdif4") - -! calculate exchange coefficients -!jref: start exchange coefficient for momentum - CM =KARMAN*KARMAN/(PSIX*PSIX) -!jref:end - CHS=UST*KARMAN/DENOMQ -! GZ2OZ0=ALOG(2./ZNT) -! PSIM2=-10.*GZ2OZ0 -! PSIM2=AMAX1(PSIM2,-10.) -! PSIH2=PSIM2 - CQS2=UST*KARMAN/DENOMQ2 - CHS2=UST*KARMAN/DENOMT2 -! jref: in last iteration calculate diagnostics - - U10=UX*PSIX10/PSIX - V10=VX*PSIX10/PSIX - -! jref: check the following for correct calculation -! TH2=THGB+DTG*PSIT2/PSIT -! Q2=QSFC+(QX-QSFC)*PSIQ2/PSIQ -! T2 = TH2*(PSFCPA/P1000mb)**RCP - - END SUBROUTINE SFCDIF4 -!jref:end -! ================================================================================================== SUBROUTINE ESAT(T, ESW, ESI, DESW, DESI) !--------------------------------------------------------------------------------------------------- ! use polynomials to calculate saturation vapor pressure and derivative with @@ -5345,14 +5192,17 @@ SUBROUTINE ESAT(T, ESW, ESI, DESW, DESI) DESI = 100.*(D0+T*(D1+T*(D2+T*(D3+T*(D4+T*(D5+T*D6)))))) END SUBROUTINE ESAT -! ================================================================================================== -! ---------------------------------------------------------------------- + +!== begin stomata ================================================================================== + SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in TV ,EI ,EA ,SFCTMP ,SFCPRS , & !in O2 ,CO2 ,IGS ,BTRAN ,RB , & !in RS ,PSN ) !out ! -------------------------------------------------------------------------------------------------- - USE NOAHMP_VEG_PARAMETERS + USE NOAHMP_PARAMETERS, ONLY: BP, MP, FOLNMX, QE25, KC25, KO25, & ! VEGETATION DEPENDENT + AKC, AKO, VCMX25, AVCMX, C3PSN, & ! VEGETATION DEPENDENT + TFRZ ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -5423,24 +5273,24 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in ! for APAR > 0, in which case RS <= RSMAX and PSN >= 0 CF = SFCPRS/(8.314*SFCTMP)*1.e06 - RS = 1./BP(VEGTYP) * CF + RS = 1./BP * CF PSN = 0. IF (APAR .LE. 0.) RETURN - FNF = MIN( FOLN/MAX(MPE,FOLNMX(VEGTYP)), 1.0 ) + FNF = MIN( FOLN/MAX(MPE,FOLNMX), 1.0 ) TC = TV-TFRZ PPF = 4.6*APAR - J = PPF*QE25(VEGTYP) - KC = KC25(VEGTYP) * F1(AKC(VEGTYP),TC) - KO = KO25(VEGTYP) * F1(AKO(VEGTYP),TC) + J = PPF*QE25 + KC = KC25 * F1(AKC,TC) + KO = KO25 * F1(AKO,TC) AWC = KC * (1.+O2/KO) CP = 0.5*KC/KO*O2*0.21 - VCMX = VCMX25(VEGTYP) / F2(TC) * FNF * BTRAN * F1(AVCMX(VEGTYP),TC) + VCMX = VCMX25 / F2(TC) * FNF * BTRAN * F1(AVCMX,TC) ! first guess ci - CI = 0.7*CO2*C3PSN(VEGTYP) + 0.4*CO2*(1.-C3PSN(VEGTYP)) + CI = 0.7*CO2*C3PSN + 0.4*CO2*(1.-C3PSN) ! rb: s/m -> s m**2 / umol @@ -5448,19 +5298,19 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in ! constrain ea - CEA = MAX(0.25*EI*C3PSN(VEGTYP)+0.40*EI*(1.-C3PSN(VEGTYP)), MIN(EA,EI) ) + CEA = MAX(0.25*EI*C3PSN+0.40*EI*(1.-C3PSN), MIN(EA,EI) ) ! ci iteration !jref: C3PSN is equal to 1 for all veg types. DO ITER = 1, NITER - WJ = MAX(CI-CP,0.)*J/(CI+2.*CP)*C3PSN(VEGTYP) + J*(1.-C3PSN(VEGTYP)) - WC = MAX(CI-CP,0.)*VCMX/(CI+AWC)*C3PSN(VEGTYP) + VCMX*(1.-C3PSN(VEGTYP)) - WE = 0.5*VCMX*C3PSN(VEGTYP) + 4000.*VCMX*CI/SFCPRS*(1.-C3PSN(VEGTYP)) + WJ = MAX(CI-CP,0.)*J/(CI+2.*CP)*C3PSN + J*(1.-C3PSN) + WC = MAX(CI-CP,0.)*VCMX/(CI+AWC)*C3PSN + VCMX*(1.-C3PSN) + WE = 0.5*VCMX*C3PSN + 4000.*VCMX*CI/SFCPRS*(1.-C3PSN) PSN = MIN(WJ,WC,WE) * IGS CS = MAX( CO2-1.37*RLB*SFCPRS*PSN, MPE ) - A = MP(VEGTYP)*PSN*SFCPRS*CEA / (CS*EI) + BP(VEGTYP) - B = ( MP(VEGTYP)*PSN*SFCPRS/CS + BP(VEGTYP) ) * RLB - 1. + A = MP*PSN*SFCPRS*CEA / (CS*EI) + BP + B = ( MP*PSN*SFCPRS/CS + BP ) * RLB - 1. C = -RLB IF (B .GE. 0.) THEN Q = -0.5*( B + SQRT(B*B-4.*A*C) ) @@ -5478,7 +5328,9 @@ SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in RS = RS*CF END SUBROUTINE STOMATA -! ================================================================================================== + +!== begin canres =================================================================================== + SUBROUTINE CANRES (PAR ,SFCTMP,RCSOIL ,EAH ,SFCPRS , & !in RC ,PSN ,ILOC ,JLOC ) !out @@ -5493,6 +5345,8 @@ SUBROUTINE CANRES (PAR ,SFCTMP,RCSOIL ,EAH ,SFCPRS , & !in ! eqns 12-14 and table 2 of sec. 3.1.2 ! -------------------------------------------------------------------------------------------------- !niu USE module_Noahlsm_utility +! -------------------------------------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: RGL, RSMIN, RSMAX, HS, TOPT ! VEGETATION DEPENDENT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -5559,7 +5413,9 @@ SUBROUTINE CANRES (PAR ,SFCTMP,RCSOIL ,EAH ,SFCPRS , & !in PSN = -999.99 ! PSN not applied for dynamic carbon END SUBROUTINE CANRES -! ================================================================================================== + +!== begin calhum =================================================================================== + SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) IMPLICIT NONE @@ -5587,16 +5443,20 @@ SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) Q2SAT = Q2SAT / 1.E3 END SUBROUTINE CALHUM -! ================================================================================================== + +!== begin tsnosoi ================================================================================== + SUBROUTINE TSNOSOI (ICE ,NSOIL ,NSNOW ,ISNOW ,IST , & !in TBOT ,ZSNSO ,SSOIL ,DF ,HCPCT , & !in - ZBOT ,SAG ,DT ,SNOWH ,DZSNSO , & !in + SAG ,DT ,SNOWH ,DZSNSO , & !in TG ,ILOC ,JLOC , & !in STC ) !inout ! -------------------------------------------------------------------------------------------------- ! Compute snow (up to 3L) and soil (4L) temperature. Note that snow temperatures ! during melting season may exceed melting point (TFRZ) but later in PHASECHANGE ! subroutine the snow temperatures are reset to TFRZ for melting snow. +! -------------------------------------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: ZBOT ! GENPARM DEPENDENT ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- @@ -5615,7 +5475,6 @@ SUBROUTINE TSNOSOI (ICE ,NSOIL ,NSNOW ,ISNOW ,IST , & !in REAL, INTENT(IN) :: SSOIL !ground heat flux (w/m2) REAL, INTENT(IN) :: SAG !solar rad. absorbed by ground (w/m2) REAL, INTENT(IN) :: SNOWH !snow depth (m) - REAL, INTENT(IN) :: ZBOT !from soil surface (m) REAL, INTENT(IN) :: TG !ground temperature (k) REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !layer-bot. depth from snow surf.(m) REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness (m) @@ -5704,8 +5563,9 @@ SUBROUTINE TSNOSOI (ICE ,NSOIL ,NSNOW ,ISNOW ,IST , & !in END IF END SUBROUTINE TSNOSOI -! ================================================================================================== -! ---------------------------------------------------------------------- + +!== begin hrt ====================================================================================== + SUBROUTINE HRT (NSNOW ,NSOIL ,ISNOW ,ZSNSO , & STC ,TBOT ,ZBOT ,DT , & DF ,HCPCT ,SSOIL ,PHI , & @@ -5804,8 +5664,9 @@ SUBROUTINE HRT (NSNOW ,NSOIL ,ISNOW ,ZSNSO , & END DO END SUBROUTINE HRT -! ================================================================================================== -! ---------------------------------------------------------------------- + +!== begin hstep ==================================================================================== + SUBROUTINE HSTEP (NSNOW ,NSOIL ,ISNOW ,DT , & AI ,BI ,CI ,RHSTS , & STC ) @@ -5859,7 +5720,9 @@ SUBROUTINE HSTEP (NSNOW ,NSOIL ,ISNOW ,DT , & END DO END SUBROUTINE HSTEP -! ================================================================================================== + +!== begin rosr12 =================================================================================== + SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NTOP,NSOIL,NSNOW) ! ---------------------------------------------------------------------- ! SUBROUTINE ROSR12 @@ -5918,8 +5781,9 @@ SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NTOP,NSOIL,NSNOW) END DO ! ---------------------------------------------------------------------- END SUBROUTINE ROSR12 -! ---------------------------------------------------------------------- -! ================================================================================================== + +!== begin phasechange ============================================================================== + SUBROUTINE PHASECHANGE (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in DZSNSO ,HCPCT ,IST ,ILOC ,JLOC , & !in STC ,SNICE ,SNLIQ ,SNEQV ,SNOWH , & !inout @@ -5927,6 +5791,9 @@ SUBROUTINE PHASECHANGE (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in QMELT ,IMELT ,PONDING ) !out ! ---------------------------------------------------------------------- ! melting/freezing of snow water and soil water +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX, & ! SOIL DEPENDENT + GRAV, TFRZ, HFUS ! MP CONSTANT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -6127,7 +5994,9 @@ SUBROUTINE PHASECHANGE (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in END DO END SUBROUTINE PHASECHANGE -! ================================================================================================== + +!== begin frh2o ==================================================================================== + SUBROUTINE FRH2O (FREE,TKELV,SMC,SH2O) ! ---------------------------------------------------------------------- @@ -6156,6 +6025,9 @@ SUBROUTINE FRH2O (FREE,TKELV,SMC,SH2O) ! OUTPUT: ! FREE..........SUPERCOOLED LIQUID WATER CONTENT [m3/m3] +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX, & ! SOIL DEPENDENT + GRAV, TFRZ, HFUS ! MP CONSTANT ! ---------------------------------------------------------------------- IMPLICIT NONE REAL, INTENT(IN) :: SH2O,SMC,TKELV @@ -6206,7 +6078,7 @@ SUBROUTINE FRH2O (FREE,TKELV,SMC,SH2O) 1001 Continue IF (.NOT.( (NLOG < 10) .AND. (KCOUNT == 0))) goto 1002 NLOG = NLOG +1 - DF = ALOG ( ( PSISAT * GRAV / hfus ) * ( ( 1. + CK * SWL )**2.) * & + DF = ALOG ( ( PSISAT * GRAV / HFUS ) * ( ( 1. + CK * SWL )**2.) * & ( SMCMAX / (SMC - SWL) )** BX) - ALOG ( - ( & TKELV - TFRZ)/ TKELV) DENOM = 2. * CK / ( 1. + CK * SWL ) + BX / ( SMC - SWL ) @@ -6248,7 +6120,7 @@ SUBROUTINE FRH2O (FREE,TKELV,SMC,SH2O) IF (KCOUNT == 0) THEN write(message, '("Flerchinger used in NEW version. Iterations=", I6)') NLOG call wrf_message(trim(message)) - FK = ( ( (hfus / (GRAV * ( - PSISAT)))* & + FK = ( ( (HFUS / (GRAV * ( - PSISAT)))* & ( (TKELV - TFRZ)/ TKELV))** ( -1/ BX))* SMCMAX IF (FK < 0.02) FK = 0.02 FREE = MIN (FK, SMC) @@ -6263,18 +6135,22 @@ END SUBROUTINE FRH2O ! ================================================================================================== ! **********************End of energy subroutines*********************** ! ================================================================================================== + +!== begin water ==================================================================================== + SUBROUTINE WATER (VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in VV ,FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , & !in ESAI ,SFCTMP ,QVAP ,QDEW ,ZSOIL ,BTRANI , & !in FICEOLD,PONDING,TG ,IST ,FVEG ,ILOC ,JLOC ,SMCEQ , & !in - LATHEAV , LATHEAG , frozen_canopy,frozen_ground, & !in MB + BDFALL ,FP ,RAIN ,SNOW, & !in MB/AN: v3.7 + QSNOW ,QRAIN ,SNOWHIN,LATHEAV,LATHEAG,frozen_canopy,frozen_ground, & !in MB ISNOW ,CANLIQ ,CANICE ,TV ,SNOWH ,SNEQV , & !inout SNICE ,SNLIQ ,STC ,ZSNSO ,SH2O ,SMC , & !inout SICE ,ZWT ,WA ,WT ,DZSNSO ,WSLAKE , & !inout SMCWTD ,DEEPRECH,RECH , & !inout CMC ,ECAN ,ETRAN ,FWET ,RUNSRF ,RUNSUB , & !out - QIN ,QDIS ,QSNOW ,PONDING1 ,PONDING2,& - ISURBAN,QSNBOT,FPICE & + QIN ,QDIS ,PONDING1 ,PONDING2, & + QSNBOT & #ifdef WRF_HYDRO ,sfcheadrt & #endif @@ -6282,6 +6158,8 @@ SUBROUTINE WATER (VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in ! ---------------------------------------------------------------------- ! Code history: ! Initial code: Guo-Yue Niu, Oct. 2007 +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: NROOT ! VEG DEPENDENT ! ---------------------------------------------------------------------- implicit none ! ---------------------------------------------------------------------- @@ -6311,7 +6189,14 @@ SUBROUTINE WATER (VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in ! REAL , INTENT(IN) :: PONDING ![mm] REAL , INTENT(IN) :: TG !ground temperature (k) REAL , INTENT(IN) :: FVEG !greeness vegetation fraction (-) + REAL , INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) ! MB/AN: v3.7 + REAL , INTENT(IN) :: FP !fraction of the gridcell that receives precipitation ! MB/AN: v3.7 + REAL , INTENT(IN) :: RAIN !rainfall (mm/s) ! MB/AN: v3.7 + REAL , INTENT(IN) :: SNOW !snowfall (mm/s) ! MB/AN: v3.7 REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] (used in m-m&f groundwater dynamics) + REAL , INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] + REAL , INTENT(IN) :: QRAIN !rain at ground srf (mm) [+] + REAL , INTENT(IN) :: SNOWHIN !snow depth increasing rate (m/s) ! input/output INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers @@ -6347,27 +6232,22 @@ SUBROUTINE WATER (VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in REAL, INTENT(OUT) :: RUNSUB !baseflow (sturation excess) [mm/s] REAL, INTENT(OUT) :: QIN !groundwater recharge [mm/s] REAL, INTENT(OUT) :: QDIS !groundwater discharge [mm/s] - REAL, INTENT(OUT) :: QSNOW !snow at ground srf (mm/s) [+] REAL, INTENT(OUT) :: PONDING1 REAL, INTENT(OUT) :: PONDING2 REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] - REAL, INTENT(OUT) :: FPICE !snow fraction in precipitation REAL , INTENT(IN) :: LATHEAV !latent heat vap./sublimation (j/kg) REAL , INTENT(IN) :: LATHEAG !latent heat vap./sublimation (j/kg) LOGICAL , INTENT(IN) :: FROZEN_GROUND ! used to define latent heat pathway LOGICAL , INTENT(IN) :: FROZEN_CANOPY ! used to define latent heat pathway - INTEGER, INTENT(IN) :: ISURBAN ! local INTEGER :: IZ REAL :: QINSUR !water input on soil surface [m/s] - REAL :: QRAIN !rain at ground srf (mm) [+] REAL :: QSEVA !soil surface evap rate [mm/s] REAL :: QSDEW !soil surface dew rate [mm/s] REAL :: QSNFRO !snow surface frost rate[mm/s] REAL :: QSNSUB !snow surface sublimation rate [mm/s] - REAL :: SNOWHIN !snow depth increasing rate (m/s) REAL, DIMENSION( 1:NSOIL) :: ETRANI !transpiration rate (mm/s) [+] REAL, DIMENSION( 1:NSOIL) :: WCND !hydraulic conductivity (m/s) REAL :: QDRAIN !soil-bottom free drainage [mm/s] @@ -6390,13 +6270,13 @@ SUBROUTINE WATER (VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in ! canopy-intercepted snowfall/rainfall, drips, and throughfall - CALL CANWATER (VEGTYP ,DT ,SFCTMP ,UU ,VV , & !in - FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , & !in - ESAI ,IST ,TG ,FVEG ,ILOC , JLOC, & !in - FROZEN_CANOPY, & !in + CALL CANWATER (VEGTYP ,DT , & !in + FCEV ,FCTR ,ELAI , & !in + ESAI ,TG ,FVEG ,ILOC , JLOC, & !in + BDFALL ,FROZEN_CANOPY , & !in CANLIQ ,CANICE ,TV , & !inout - CMC ,ECAN ,ETRAN ,QRAIN ,QSNOW , & !out - SNOWHIN,FWET ,FPICE ) !out + CMC ,ECAN ,ETRAN , & !out + FWET ) !out ! sublimation, frost, evaporation, and dew @@ -6460,7 +6340,7 @@ SUBROUTINE WATER (VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in ELSE ! soil CALL SOILWATER (NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in QINSUR ,QSEVA ,ETRANI ,SICE ,ILOC , JLOC , & !in - SH2O ,SMC ,ZWT ,VEGTYP ,ISURBAN, & !inout + SH2O ,SMC ,ZWT ,VEGTYP , & !inout SMCWTD, DEEPRECH , & !inout RUNSRF ,QDRAIN ,RUNSUB ,WCND ,FCRMAX ) !out @@ -6495,19 +6375,22 @@ SUBROUTINE WATER (VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in RUNSUB = RUNSUB + SNOFLOW !mm/s END SUBROUTINE WATER -! ================================================================================================== - SUBROUTINE CANWATER (VEGTYP ,DT ,SFCTMP ,UU ,VV , & !in - FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , & !in - ESAI ,IST ,TG ,FVEG ,ILOC , JLOC , & !in - FROZEN_CANOPY, & !in + +!== begin canwater ================================================================================= + + SUBROUTINE CANWATER (VEGTYP ,DT , & !in + FCEV ,FCTR ,ELAI , & !in + ESAI ,TG ,FVEG ,ILOC , JLOC , & !in + BDFALL ,FROZEN_CANOPY , & !in CANLIQ ,CANICE ,TV , & !inout - CMC ,ECAN ,ETRAN ,QRAIN ,QSNOW , & !out - SNOWHIN,FWET ,FPICE ) !out + CMC ,ECAN ,ETRAN , & !out + FWET ) !out ! ------------------------ code history ------------------------------ ! canopy hydrology ! -------------------------------------------------------------------- - USE NOAHMP_VEG_PARAMETERS + USE NOAHMP_PARAMETERS, ONLY: CH2OP, & ! VEGETATION DEPENDENT + TFRZ, DENH2O, DENICE, CICE, CWAT, HVAP, HSUB, HFUS ! MP CONSTANT ! -------------------------------------------------------------------- IMPLICIT NONE ! ------------------------ input/output variables -------------------- @@ -6516,19 +6399,14 @@ SUBROUTINE CANWATER (VEGTYP ,DT ,SFCTMP ,UU ,VV , & !in INTEGER,INTENT(IN) :: JLOC !grid index INTEGER,INTENT(IN) :: VEGTYP !vegetation type REAL, INTENT(IN) :: DT !main time step (s) - REAL, INTENT(IN) :: SFCTMP !air temperature (k) - REAL, INTENT(IN) :: UU !u-direction wind speed [m/s] - REAL, INTENT(IN) :: VV !v-direction wind speed [m/s] REAL, INTENT(IN) :: FCEV !canopy evaporation (w/m2) [+ = to atm] REAL, INTENT(IN) :: FCTR !transpiration (w/m2) [+ = to atm] - REAL, INTENT(IN) :: QPRECC !convective precipitation (mm/s) - REAL, INTENT(IN) :: QPRECL !large-scale precipitation (mm/s) REAL, INTENT(IN) :: ELAI !leaf area index, after burying by snow REAL, INTENT(IN) :: ESAI !stem area index, after burying by snow - INTEGER,INTENT(IN) :: IST !surface type 1-soil; 2-lake REAL, INTENT(IN) :: TG !ground temperature (k) REAL, INTENT(IN) :: FVEG !greeness vegetation fraction (-) LOGICAL , INTENT(IN) :: FROZEN_CANOPY ! used to define latent heat pathway + REAL , INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) ! MB/AN: v3.7 ! input & output REAL, INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) @@ -6539,118 +6417,28 @@ SUBROUTINE CANWATER (VEGTYP ,DT ,SFCTMP ,UU ,VV , & !in REAL, INTENT(OUT) :: CMC !intercepted water (mm) REAL, INTENT(OUT) :: ECAN !evaporation of intercepted water (mm/s) [+] REAL, INTENT(OUT) :: ETRAN !transpiration rate (mm/s) [+] - REAL, INTENT(OUT) :: QRAIN !rain at ground srf (mm/s) [+] - REAL, INTENT(OUT) :: QSNOW !snow at ground srf (mm/s) [+] - REAL, INTENT(OUT) :: SNOWHIN !snow depth increasing rate (m/s) REAL, INTENT(OUT) :: FWET !wetted or snowed fraction of the canopy (-) - REAL, INTENT(OUT) :: FPICE !snow fraction in precipitation ! -------------------------------------------------------------------- ! ------------------------ local variables --------------------------- REAL :: MAXSNO !canopy capacity for snow interception (mm) REAL :: MAXLIQ !canopy capacity for rain interception (mm) - REAL :: FP !fraction of the gridcell that receives precipitation - REAL :: BDFALL !bulk density of snowfall (kg/m3) - REAL :: QINTR !interception rate for rain (mm/s) - REAL :: QDRIPR !drip rate for rain (mm/s) - REAL :: QTHROR !throughfall for rain (mm/s) - REAL :: QINTS !interception (loading) rate for snowfall (mm/s) - REAL :: QDRIPS !drip (unloading) rate for intercepted snow (mm/s) - REAL :: QTHROS !throughfall of snowfall (mm/s) REAL :: QEVAC !evaporation rate (mm/s) REAL :: QDEWC !dew rate (mm/s) REAL :: QFROC !frost rate (mm/s) REAL :: QSUBC !sublimation rate (mm/s) - REAL :: FT !temperature factor for unloading rate - REAL :: FV !wind factor for unloading rate REAL :: QMELTC !melting rate of canopy snow (mm/s) REAL :: QFRZC !refreezing rate of canopy liquid water (mm/s) - REAL :: RAIN !rainfall (mm/s) - REAL :: SNOW !snowfall (mm/s) REAL :: CANMAS !total canopy mass (kg/m2) ! -------------------------------------------------------------------- ! initialization - FP = 0.0 - RAIN = 0.0 - SNOW = 0.0 - QINTR = 0. - QDRIPR = 0. - QTHROR = 0. - QINTR = 0. - QINTS = 0. - QDRIPS = 0.0 - QTHROS = 0. - QRAIN = 0.0 - QSNOW = 0.0 - SNOWHIN = 0.0 ECAN = 0.0 -! -------------------------------------------------------------------- -! partition precipitation into rain and snow. - -! Jordan (1991) - - IF(OPT_SNF == 1) THEN - IF(SFCTMP > TFRZ+2.5)THEN - FPICE = 0. - ELSE - IF(SFCTMP <= TFRZ+0.5)THEN - FPICE = 1.0 - ELSE IF(SFCTMP <= TFRZ+2.)THEN - FPICE = 1.-(-54.632 + 0.2*SFCTMP) - ELSE - FPICE = 0.6 - ENDIF - ENDIF - ENDIF - - IF(OPT_SNF == 2) THEN - IF(SFCTMP >= TFRZ+2.2) THEN - FPICE = 0. - ELSE - FPICE = 1.0 - ENDIF - ENDIF - - IF(OPT_SNF == 3) THEN - IF(SFCTMP >= TFRZ) THEN - FPICE = 0. - ELSE - FPICE = 1.0 - ENDIF - ENDIF - -! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625 -! fresh snow density - - BDFALL = MIN(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59)) ! Barlage: change to MIN in v3.6 - - RAIN = (QPRECC + QPRECL) * (1.-FPICE) - SNOW = (QPRECC + QPRECL) * FPICE - -! fractional area that receives precipitation (see, Niu et al. 2005) - - IF(QPRECC + QPRECL > 0.) & - FP = (QPRECC + QPRECL) / (10.*QPRECC + QPRECL) ! --------------------------- liquid water ------------------------------ ! maximum canopy water - MAXLIQ = CH2OP(VEGTYP) * (ELAI+ ESAI) - -! average interception and throughfall - - IF((ELAI+ ESAI).GT.0.) THEN - QINTR = FVEG * RAIN * FP ! interception capability - QINTR = MIN(QINTR, (MAXLIQ - CANLIQ)/DT * (1.-EXP(-RAIN*DT/MAXLIQ)) ) - QINTR = MAX(QINTR, 0.) - QDRIPR = FVEG * RAIN - QINTR - QTHROR = (1.-FVEG) * RAIN - ELSE - QINTR = 0. - QDRIPR = 0. - QTHROR = RAIN - END IF + MAXLIQ = CH2OP * (ELAI+ ESAI) ! evaporation, transpiration, and dew @@ -6672,7 +6460,7 @@ SUBROUTINE CANWATER (VEGTYP ,DT ,SFCTMP ,UU ,VV , & !in ! maxh2o or else would have to re-adjust drip QEVAC = MIN(CANLIQ/DT,QEVAC) - CANLIQ=MAX(0.,CANLIQ+(QINTR+QDEWC-QEVAC)*DT) + CANLIQ=MAX(0.,CANLIQ+(QDEWC-QEVAC)*DT) IF(CANLIQ <= 1.E-06) CANLIQ = 0.0 ! --------------------------- canopy ice ------------------------------ @@ -6680,22 +6468,8 @@ SUBROUTINE CANWATER (VEGTYP ,DT ,SFCTMP ,UU ,VV , & !in MAXSNO = 6.6*(0.27+46./BDFALL) * (ELAI+ ESAI) - IF((ELAI+ ESAI).GT.0.) THEN - QINTS = FVEG * SNOW * FP - QINTS = MIN(QINTS, (MAXSNO - CANICE)/DT * (1.-EXP(-SNOW*DT/MAXSNO)) ) - QINTS = MAX(QINTS, 0.) - FT = MAX(0.0,(TV - 270.15) / 1.87E5) - FV = SQRT(UU*UU + VV*VV) / 1.56E5 - QDRIPS = MAX(0.,CANICE) * (FV+FT) - QTHROS = (1.0-FVEG) * SNOW + (FVEG * SNOW - QINTS) - ELSE - QINTS = 0. - QDRIPS = 0. - QTHROS = SNOW - ENDIF - QSUBC = MIN(CANICE/DT,QSUBC) - CANICE= MAX(0.,CANICE+(QINTS-QDRIPS)*DT + (QFROC-QSUBC)*DT) + CANICE= MAX(0.,CANICE + (QFROC-QSUBC)*DT) IF(CANICE.LE.1.E-6) CANICE = 0. ! wetted fraction of canopy @@ -6734,21 +6508,10 @@ SUBROUTINE CANWATER (VEGTYP ,DT ,SFCTMP ,UU ,VV , & !in ECAN = QEVAC + QSUBC - QDEWC - QFROC -! rain or snow on the ground - - QRAIN = QDRIPR + QTHROR - QSNOW = QDRIPS + QTHROS - SNOWHIN = QSNOW/BDFALL - + END SUBROUTINE CANWATER - IF (IST == 2 .AND. TG > TFRZ) THEN - QSNOW = 0. - SNOWHIN = 0. - END IF +!== begin snowwater ================================================================================ - END SUBROUTINE CANWATER -! ================================================================================================== -! ---------------------------------------------------------------------- SUBROUTINE SNOWWATER (NSNOW ,NSOIL ,IMELT ,DT ,ZSOIL , & !in SFCTMP ,SNOWHIN,QSNOW ,QSNFRO ,QSNSUB , & !in QRAIN ,FICEOLD,ILOC ,JLOC , & !in @@ -6878,7 +6641,9 @@ SUBROUTINE SNOWWATER (NSNOW ,NSOIL ,IMELT ,DT ,ZSOIL , & !in END DO END SUBROUTINE SNOWWATER -! ================================================================================================== + +!== begin snowfall ================================================================================= + SUBROUTINE SNOWFALL (NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN , & !in SFCTMP ,ILOC ,JLOC , & !in ISNOW ,SNOWH ,DZSNSO ,STC ,SNICE , & !inout @@ -6945,7 +6710,9 @@ SUBROUTINE SNOWFALL (NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN , & !in ! ---------------------------------------------------------------------- END SUBROUTINE SNOWFALL -! ================================================================================================== + +!== begin combine ================================================================================== + SUBROUTINE COMBINE (NSNOW ,NSOIL ,ILOC ,JLOC , & !in ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout @@ -7128,9 +6895,13 @@ SUBROUTINE COMBINE (NSNOW ,NSOIL ,ILOC ,JLOC , & !in END IF END SUBROUTINE COMBINE -! ================================================================================================== + +!== begin divide =================================================================================== + SUBROUTINE DIVIDE (NSNOW ,NSOIL , & !in ISNOW ,STC ,SNICE ,SNLIQ ,DZSNSO ) !inout +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: TFRZ ! MP CONSTANT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -7253,10 +7024,12 @@ SUBROUTINE DIVIDE (NSNOW ,NSOIL , & !in ! END DO END SUBROUTINE DIVIDE -! ================================================================================================== -! ---------------------------------------------------------------------- +!== begin combo ==================================================================================== + SUBROUTINE COMBO(DZ, WLIQ, WICE, T, DZ2, WLIQ2, WICE2, T2) +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: TFRZ, CICE, CWAT, HFUS ! MP CONSTANT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -7306,12 +7079,14 @@ SUBROUTINE COMBO(DZ, WLIQ, WICE, T, DZ2, WLIQ2, WICE2, T2) T = TC END SUBROUTINE COMBO -! ================================================================================================== -! ---------------------------------------------------------------------- + +!== begin compact ================================================================================== + SUBROUTINE COMPACT (NSNOW ,NSOIL ,DT ,STC ,SNICE , & !in SNLIQ ,ZSOIL ,IMELT ,FICEOLD,ILOC , JLOC , & !in ISNOW ,DZSNSO ,ZSNSO ) !inout ! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: TFRZ, DENH2O, DENICE ! MP CONSTANT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -7410,7 +7185,9 @@ SUBROUTINE COMPACT (NSNOW ,NSOIL ,DT ,STC ,SNICE , & !in END DO END SUBROUTINE COMPACT -! ================================================================================================== + +!== begin snowh2o ================================================================================== + SUBROUTINE SNOWH2O (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in QRAIN ,ILOC ,JLOC , & !in ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout @@ -7419,6 +7196,9 @@ SUBROUTINE SNOWH2O (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in ! ---------------------------------------------------------------------- ! Renew the mass of ice lens (SNICE) and liquid (SNLIQ) of the ! surface snow layer resulting from sublimation (frost) / evaporation (dew) +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: SSI, & ! SNOW GLOBAL + DENH2O, DENICE ! MP CONSTANT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -7560,16 +7340,22 @@ SUBROUTINE SNOWH2O (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in QSNBOT = QOUT / DT ! mm/s END SUBROUTINE SNOWH2O -! ================================================================================================== + +!== begin soilwater ================================================================================ + SUBROUTINE SOILWATER (NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in QINSUR ,QSEVA ,ETRANI ,SICE ,ILOC , JLOC, & !in - SH2O ,SMC ,ZWT ,ISURBAN,VEGTYP ,& !inout + SH2O ,SMC ,ZWT ,VEGTYP ,& !inout SMCWTD, DEEPRECH ,& !inout RUNSRF ,QDRAIN ,RUNSUB ,WCND ,FCRMAX ) !out ! ---------------------------------------------------------------------- ! calculate surface runoff and soil moisture. ! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: SMCMAX, & ! SOIL DEPENDENT + TIMEAN, FSATMX, & ! RUNOFF GLOBAL + ISURBAN ! MP CONSTANT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -7587,7 +7373,6 @@ SUBROUTINE SOILWATER (NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE !soil ice content [m3/m3] INTEGER, INTENT(IN) :: VEGTYP - INTEGER, INTENT(IN) :: ISURBAN ! input & output REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water content [m3/m3] @@ -7818,10 +7603,14 @@ SUBROUTINE SOILWATER (NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in END IF END SUBROUTINE SOILWATER -! ================================================================================================== + +!== begin zwteq ==================================================================================== + SUBROUTINE ZWTEQ (NSOIL ,NSNOW ,ZSOIL ,DZSNSO ,SH2O ,ZWT) ! ---------------------------------------------------------------------- ! calculate equilibrium water table depth (Niu et al., 2005) +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX ! SOIL DEPENDENT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -7871,14 +7660,18 @@ SUBROUTINE ZWTEQ (NSOIL ,NSNOW ,ZSOIL ,DZSNSO ,SH2O ,ZWT) ENDDO END SUBROUTINE ZWTEQ -! ---------------------------------------------------------------------- -! ================================================================================================== + +!== begin infil ==================================================================================== + SUBROUTINE INFIL (NSOIL ,DT ,ZSOIL ,SH2O ,SICE , & !in SICEMAX,QINSUR , & !in PDDUM ,RUNSRF ) !out ! -------------------------------------------------------------------------------- ! compute inflitration rate at soil surface and surface runoff ! -------------------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: SMCMAX, KDT, FRZX, SMCWLT, & ! SOIL DEPENDENT + ISURBAN ! MP CONSTANT +! ---------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------- ! inputs @@ -7969,7 +7762,9 @@ SUBROUTINE INFIL (NSOIL ,DT ,ZSOIL ,SH2O ,SICE , & !in END IF END SUBROUTINE INFIL -! ================================================================================================== + +!== begin srt ====================================================================================== + SUBROUTINE SRT (NSOIL ,ZSOIL ,DT ,PDDUM ,ETRANI , & !in QSEVA ,SH2O ,SMC ,ZWT ,FCR , & !in SICEMAX,FCRMAX ,ILOC ,JLOC ,SMCWTD , & !in @@ -7979,6 +7774,8 @@ SUBROUTINE SRT (NSOIL ,ZSOIL ,DT ,PDDUM ,ETRANI , & !in ! calculate the right hand side of the time tendency term of the soil ! water diffusion equation. also to compute ( prepare ) the matrix ! coefficients for the tri-diagonal matrix of the implicit time scheme. +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: SLOPE ! GENPARM DEPENDENT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -8099,8 +7896,9 @@ SUBROUTINE SRT (NSOIL ,ZSOIL ,DT ,PDDUM ,ETRANI , & !in ! ---------------------------------------------------------------------- END SUBROUTINE SRT -! ---------------------------------------------------------------------- -! ================================================================================================== + +!== begin sstep ==================================================================================== + SUBROUTINE SSTEP (NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in SICE ,ILOC ,JLOC ,ZWT , & !in SH2O ,SMC ,AI ,BI ,CI , & !inout @@ -8109,6 +7907,8 @@ SUBROUTINE SSTEP (NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in ! ---------------------------------------------------------------------- ! calculate/update soil moisture content values +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: SMCMAX ! SOIL DEPENDENT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -8208,10 +8008,14 @@ SUBROUTINE SSTEP (NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in SH2O(1) = MIN(EPORE,SH2O(1)) END SUBROUTINE SSTEP -! ================================================================================================== + +!== begin wdfcnd1 ================================================================================== + SUBROUTINE WDFCND1 (WDF,WCND,SMC,FCR) ! ---------------------------------------------------------------------- ! calculate soil water diffusivity and soil hydraulic conductivity. +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: BEXP, DKSAT, DWSAT, SMCMAX ! SOIL DEPENDENT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -8243,10 +8047,14 @@ SUBROUTINE WDFCND1 (WDF,WCND,SMC,FCR) WCND = WCND * (1.0 - FCR) END SUBROUTINE WDFCND1 -! ================================================================================================== + +!== begin wdfcnd2 ================================================================================== + SUBROUTINE WDFCND2 (WDF,WCND,SMC,SICE) ! ---------------------------------------------------------------------- ! calculate soil water diffusivity and soil hydraulic conductivity. +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: BEXP, DKSAT, DWSAT, SMCMAX ! SOIL DEPENDENT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -8281,12 +8089,16 @@ SUBROUTINE WDFCND2 (WDF,WCND,SMC,SICE) WCND = DKSAT * FACTR ** EXPON END SUBROUTINE WDFCND2 -! ================================================================================================== -! ---------------------------------------------------------------------- + +!== begin groundwater ============================================================================== + SUBROUTINE GROUNDWATER(NSNOW ,NSOIL ,DT ,SICE ,ZSOIL , & !in STC ,WCND ,FCRMAX ,ILOC ,JLOC , & !in SH2O ,ZWT ,WA ,WT , & !inout QIN ,QDIS ) !out +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX, & ! SOIL DEPENDENT + TIMEAN ! RUNOFF GLOBAL ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -8466,14 +8278,17 @@ SUBROUTINE GROUNDWATER(NSNOW ,NSOIL ,DT ,SICE ,ZSOIL , & !in END DO END SUBROUTINE GROUNDWATER -! ================================================================================================== -! ---------------------------------------------------------------------- + +!== begin shallowwatertable ======================================================================== + SUBROUTINE SHALLOWWATERTABLE (NSNOW ,NSOIL ,ZSOIL, DT , & !in DZSNSO ,SMCEQ ,ILOC ,JLOC , & !in SMC ,WTD ,SMCWTD ,RECH, QDRAIN ) !inout ! ---------------------------------------------------------------------- !Diagnoses water table depth and computes recharge when the water table is within the resolved soil layers, !according to the Miguez-Macho&Fan scheme +! ---------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX ! SOIL DEPENDENT ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -8603,15 +8418,19 @@ END SUBROUTINE SHALLOWWATERTABLE ! ================================================================================================== ! ********************* end of water subroutines ****************************************** ! ================================================================================================== - SUBROUTINE CARBON (NSNOW ,NSOIL ,VEGTYP ,NROOT ,DT ,ZSOIL , & !in + +!== begin carbon =================================================================================== + + SUBROUTINE CARBON (NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL , & !in DZSNSO ,STC ,SMC ,TV ,TG ,PSN , & !in - FOLN ,SMCMAX ,BTRAN ,APAR ,FVEG ,IGS , & !in - TROOT ,IST ,LAT ,ILOC ,JLOC ,ISURBAN, & !in + FOLN ,BTRAN ,APAR ,FVEG ,IGS , & !in + TROOT ,IST ,LAT ,ILOC ,JLOC , & !in LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP , & !inout GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC , & !out TOTLB ,XLAI ,XSAI ) !out ! ------------------------------------------------------------------------------------------ - USE NOAHMP_VEG_PARAMETERS + USE NOAHMP_PARAMETERS, ONLY: SMCMAX, SLA, NROOT, & ! SOIL AND VEGETATION DEPENDENT + ISBARREN, ISICE, ISWATER, ISURBAN ! MP CONSTANT ! ------------------------------------------------------------------------------------------ IMPLICIT NONE ! ------------------------------------------------------------------------------------------ @@ -8620,10 +8439,8 @@ SUBROUTINE CARBON (NSNOW ,NSOIL ,VEGTYP ,NROOT ,DT ,ZSOIL , & !in INTEGER , INTENT(IN) :: ILOC !grid index INTEGER , INTENT(IN) :: JLOC !grid index INTEGER , INTENT(IN) :: VEGTYP !vegetation type - INTEGER , INTENT(IN) :: ISURBAN!Urban category INTEGER , INTENT(IN) :: NSNOW !number of snow layers INTEGER , INTENT(IN) :: NSOIL !number of soil layers - INTEGER , INTENT(IN) :: NROOT !no. of root layers REAL , INTENT(IN) :: LAT !latitude (radians) REAL , INTENT(IN) :: DT !time step (s) REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil surface @@ -8633,7 +8450,6 @@ SUBROUTINE CARBON (NSNOW ,NSOIL ,VEGTYP ,NROOT ,DT ,ZSOIL , & !in REAL , INTENT(IN) :: TV !vegetation temperature (k) REAL , INTENT(IN) :: TG !ground temperature (k) REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) - REAL , INTENT(IN) :: SMCMAX !soil porosity (m3/m3) REAL , INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) REAL , INTENT(IN) :: PSN !total leaf photosyn (umolco2/m2/s) [+] REAL , INTENT(IN) :: APAR !PAR by canopy (w/m2) @@ -8672,7 +8488,7 @@ SUBROUTINE CARBON (NSNOW ,NSOIL ,VEGTYP ,NROOT ,DT ,ZSOIL , & !in REAL :: LAPM !leaf area per unit mass [m2/g] ! ------------------------------------------------------------------------------------------ - IF ( ( VEGTYP == ISWATER ) .OR. ( VEGTYP == ISBARREN ) .OR. ( VEGTYP == ISSNOW ) .or. (VEGTYP == ISURBAN) ) THEN + IF ( ( VEGTYP == ISWATER ) .OR. ( VEGTYP == ISBARREN ) .OR. ( VEGTYP == ISICE ) .or. (VEGTYP == ISURBAN) ) THEN XLAI = 0. XSAI = 0. GPP = 0. @@ -8692,7 +8508,7 @@ SUBROUTINE CARBON (NSNOW ,NSOIL ,VEGTYP ,NROOT ,DT ,ZSOIL , & !in RETURN END IF - LAPM = SLA(VEGTYP) / 1000. ! m2/kg -> m2/g + LAPM = SLA / 1000. ! m2/kg -> m2/g ! water stress @@ -8716,7 +8532,9 @@ SUBROUTINE CARBON (NSNOW ,NSOIL ,VEGTYP ,NROOT ,DT ,ZSOIL , & !in ! CALL CH4 END SUBROUTINE CARBON -! ================================================================================================== + +!== begin co2flux ================================================================================== + SUBROUTINE CO2FLUX (NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in DZSNSO ,STC ,PSN ,TROOT ,TV , & !in WROOT ,WSTRES ,FOLN ,LAPM , & !in @@ -8728,8 +8546,10 @@ SUBROUTINE CO2FLUX (NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in ! ----------------------------------------------------------------------------------------- ! The original code is from RE Dickinson et al.(1998), modifed by Guo-Yue Niu, 2004 ! ----------------------------------------------------------------------------------------- - USE NOAHMP_VEG_PARAMETERS -! ----------------------------------------------------------------------------------------- + USE NOAHMP_PARAMETERS, ONLY: FOLNMX, ARM, RMF25, RMR25, RMS25, WDPOOL, WRRAT, LTOVRC, & + TDLEF, DILEFW, DILEFC, FRAGR, TMIN, MRP, & ! VEGETATION DEPENDENT + EBLFOREST ! VEG CONSTANT +! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! ----------------------------------------------------------------------------------------- @@ -8846,7 +8666,7 @@ SUBROUTINE CO2FLUX (NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in BF = 0.90 !original was 0.90 ! carbon to roots WSTRC = 100.0 LAIMIN = 0.05 - XSAMIN = 0.01 + XSAMIN = 0.05 ! MB: change to prevent vegetation from not growing back in spring SAPM = 3.*0.001 ! m2/kg -->m2/g LFMSMN = laimin/lapm @@ -8861,14 +8681,14 @@ SUBROUTINE CO2FLUX (NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in RF = 1.0 ENDIF - FNF = MIN( FOLN/MAX(1.E-06,FOLNMX(VEGTYP)), 1.0 ) - TF = ARM(VEGTYP)**( (TV-298.16)/10. ) - RESP = RMF25(VEGTYP) * TF * FNF * XLAI * RF * (1.-WSTRES) ! umol/m2/s - RSLEAF = MIN(LFMASS/DT,RESP*12.e-6) ! g/m2/s + FNF = MIN( FOLN/MAX(1.E-06,FOLNMX), 1.0 ) + TF = ARM**( (TV-298.16)/10. ) + RESP = RMF25 * TF * FNF * XLAI * RF * (1.-WSTRES) ! umol/m2/s + RSLEAF = MIN((LFMASS-LFMSMN)/DT,RESP*12.e-6) ! g/m2/s - RSROOT = RMR25(VEGTYP)*(RTMASS*1E-3)*TF *RF* 12.e-6 ! g/m2/s - RSSTEM = RMS25(VEGTYP)*(STMASS*1E-3)*TF *RF* 12.e-6 ! g/m2/s - RSWOOD = RSWOODC * R(TV) * WOOD*WDPOOL(VEGTYP) + RSROOT = RMR25*(RTMASS*1E-3)*TF *RF* 12.e-6 ! g/m2/s + RSSTEM = RMS25*((STMASS-STMSMN)*1E-3)*TF *RF* 12.e-6 ! g/m2/s + RSWOOD = RSWOODC * R(TV) * WOOD*WDPOOL ! carbon assimilation ! 1 mole -> 12 g carbon or 44 g CO2; 1 umol -> 12.e-6 g carbon; @@ -8881,13 +8701,13 @@ SUBROUTINE CO2FLUX (NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in IF(VEGTYP ==EBLFOREST) LEAFPT = EXP(0.01*(1.-EXP(0.50*XLAI))*XLAI) NONLEF = 1.0 - LEAFPT - STEMPT = XLAI/10.0 + STEMPT = XLAI/10.0*LEAFPT LEAFPT = LEAFPT - STEMPT ! fraction of carbon into wood versus root IF(WOOD.GT.0) THEN - WOODF = (1.-EXP(-BF*(WRRAT(VEGTYP)*RTMASS/WOOD))/BF)*WDPOOL(VEGTYP) + WOODF = (1.-EXP(-BF*(WRRAT*RTMASS/WOOD))/BF)*WDPOOL ELSE WOODF = 0. ENDIF @@ -8897,32 +8717,34 @@ SUBROUTINE CO2FLUX (NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in ! leaf and root turnover per time step - LFTOVR = LTOVRC(VEGTYP)*1.E-6*LFMASS - STTOVR = LTOVRC(VEGTYP)*1.E-6*STMASS + LFTOVR = LTOVRC*5.E-7*LFMASS + STTOVR = LTOVRC*5.E-7*STMASS RTTOVR = RTOVRC*RTMASS WDTOVR = 9.5E-10*WOOD ! seasonal leaf die rate dependent on temp and water stress ! water stress is set to 1 at permanent wilting point - SC = EXP(-0.3*MAX(0.,TV-TDLEF(VEGTYP))) * (LFMASS/120.) + SC = EXP(-0.3*MAX(0.,TV-TDLEF)) * (LFMASS/120.) SD = EXP((WSTRES-1.)*WSTRC) - DIELF = LFMASS*1.E-6*(DILEFW(VEGTYP) * SD + DILEFC(VEGTYP)*SC) - DIEST = STMASS*1.E-6*(DILEFW(VEGTYP) * SD + DILEFC(VEGTYP)*SC) + DIELF = LFMASS*1.E-6*(DILEFW * SD + DILEFC*SC) + DIEST = STMASS*1.E-6*(DILEFW * SD + DILEFC*SC) ! calculate growth respiration for leaf, rtmass and wood - GRLEAF = MAX(0.0,FRAGR(VEGTYP)*(LEAFPT*CARBFX - RSLEAF)) - GRSTEM = MAX(0.0,FRAGR(VEGTYP)*(STEMPT*CARBFX - RSSTEM)) - GRROOT = MAX(0.0,FRAGR(VEGTYP)*(ROOTPT*CARBFX - RSROOT)) - GRWOOD = MAX(0.0,FRAGR(VEGTYP)*(WOODPT*CARBFX - RSWOOD)) + GRLEAF = MAX(0.0,FRAGR*(LEAFPT*CARBFX - RSLEAF)) + GRSTEM = MAX(0.0,FRAGR*(STEMPT*CARBFX - RSSTEM)) + GRROOT = MAX(0.0,FRAGR*(ROOTPT*CARBFX - RSROOT)) + GRWOOD = MAX(0.0,FRAGR*(WOODPT*CARBFX - RSWOOD)) ! Impose lower T limit for photosynthesis ADDNPPLF = MAX(0.,LEAFPT*CARBFX - GRLEAF-RSLEAF) ADDNPPST = MAX(0.,STEMPT*CARBFX - GRSTEM-RSSTEM) - IF(TV.LT.TMIN(VEGTYP)) ADDNPPLF =0. - IF(TV.LT.TMIN(VEGTYP)) ADDNPPST =0. +! ADDNPPLF = LEAFPT*CARBFX - GRLEAF-RSLEAF ! MB: test Kjetil +! ADDNPPST = STEMPT*CARBFX - GRSTEM-RSSTEM ! MB: test Kjetil + IF(TV.LT.TMIN) ADDNPPLF =0. + IF(TV.LT.TMIN) ADDNPPST =0. ! update leaf, root, and wood carbon ! avoid reducing leaf mass below its minimum value but conserve mass @@ -8949,15 +8771,15 @@ SUBROUTINE CO2FLUX (NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in RTTOVR = NPPR RTMASS = 0.0 ENDIF - WOOD = (WOOD+(NPPW-WDTOVR)*DT)*WDPOOL(VEGTYP) + WOOD = (WOOD+(NPPW-WDTOVR)*DT)*WDPOOL ! soil carbon budgets - FASTCP = FASTCP + (RTTOVR+LFTOVR+STTOVR+WDTOVR+DIELF)*DT + FASTCP = FASTCP + (RTTOVR+LFTOVR+STTOVR+WDTOVR+DIELF+DIEST)*DT ! MB: add DIEST v3.7 FST = 2.0**( (STC(1)-283.16)/10. ) FSW = WROOT / (0.20+WROOT) * 0.23 / (0.23+WROOT) - RSSOIL = FSW * FST * MRP(VEGTYP)* MAX(0.,FASTCP*1.E-3)*12.E-6 + RSSOIL = FSW * FST * MRP* MAX(0.,FASTCP*1.E-3)*12.E-6 STABLC = 0.1*RSSOIL FASTCP = FASTCP - (RSSOIL + STABLC)*DT @@ -8965,19 +8787,19 @@ SUBROUTINE CO2FLUX (NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in ! total carbon flux - CFLUX = - CARBFX + RSLEAF + RSROOT + RSWOOD + RSSTEM & - + RSSOIL + GRLEAF + GRROOT + GRWOOD ! g/m2/s + CFLUX = - CARBFX + RSLEAF + RSROOT + RSWOOD + RSSTEM & ! MB: add RSSTEM,GRSTEM,0.9*RSSOIL v3.7 + + 0.9*RSSOIL + GRLEAF + GRROOT + GRWOOD + GRSTEM ! g/m2/s ! for outputs GPP = CARBFX !g/m2/s C - NPP = NPPL + NPPW + NPPR !g/m2/s C - AUTORS = RSROOT + RSWOOD + RSLEAF + & !g/m2/s C - GRLEAF + GRROOT + GRWOOD !g/m2/s C - HETERS = RSSOIL !g/m2/s C + NPP = NPPL + NPPW + NPPR +NPPS !g/m2/s C + AUTORS = RSROOT + RSWOOD + RSLEAF + RSSTEM + & !g/m2/s C MB: add RSSTEM, GRSTEM v3.7 + GRLEAF + GRROOT + GRWOOD + GRSTEM !g/m2/s C MB: add 0.9* v3.7 + HETERS = 0.9*RSSOIL !g/m2/s C NEE = (AUTORS + HETERS - GPP)*44./12. !g/m2/s CO2 TOTSC = FASTCP + STBLCP !g/m2 C - TOTLB = LFMASS + RTMASS + WOOD !g/m2 C + TOTLB = LFMASS + RTMASS +STMASS + WOOD !g/m2 C MB: add STMASS v3.7 ! leaf area index and stem area index @@ -8985,16 +8807,17 @@ SUBROUTINE CO2FLUX (NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in XSAI = MAX(STMASS*SAPM,XSAMIN) END SUBROUTINE CO2FLUX -! ================================================================================================== -! ------------------------------------------------------------------------------------------ - SUBROUTINE BVOCFLUX(VOCFLX, VEGTYP, VEGFRAC, APAR, TV ) - use NOAHMP_VEG_PARAMETERS , ONLY : SLAREA, EPS -! ------------------------------------------------------------------------------------------ +!== begin bvocflux ================================================================================= + +! SUBROUTINE BVOCFLUX(VOCFLX, VEGTYP, VEGFRAC, APAR, TV ) +! use NOAHMP_VEG_PARAMETERS , ONLY : SLAREA, EPS +! ------------------------------------------------------------------------------------------ +! ! ------------------------------------------------------------------------------------------ - implicit none +! implicit none ! ------------------------------------------------------------------------------------------ - +! ! ------------------------ code history --------------------------- ! source file: BVOC ! purpose: BVOC emissions @@ -9016,221 +8839,74 @@ SUBROUTINE BVOCFLUX(VOCFLX, VEGTYP, VEGFRAC, APAR, TV ) ! 2. may wish to place epsilon values directly in pft-physiology file ! ------------------------ input/output variables ----------------- ! input - integer ,INTENT(IN) :: vegtyp !vegetation type - real ,INTENT(IN) :: vegfrac !green vegetation fraction [0.0-1.0] - real ,INTENT(IN) :: apar !photosynthesis active energy by canopy (w/m2) - real ,INTENT(IN) :: tv !vegetation canopy temperature (k) - +! integer ,INTENT(IN) :: vegtyp !vegetation type +! real ,INTENT(IN) :: vegfrac !green vegetation fraction [0.0-1.0] +! real ,INTENT(IN) :: apar !photosynthesis active energy by canopy (w/m2) +! real ,INTENT(IN) :: tv !vegetation canopy temperature (k) +! ! output - real ,INTENT(OUT) :: vocflx(5) ! voc fluxes [ug C m-2 h-1] - +! real ,INTENT(OUT) :: vocflx(5) ! voc fluxes [ug C m-2 h-1] +! ! Local Variables - - real, parameter :: R = 8.314 ! univ. gas constant [J K-1 mol-1] - real, parameter :: alpha = 0.0027 ! empirical coefficient - real, parameter :: cl1 = 1.066 ! empirical coefficient - real, parameter :: ct1 = 95000.0 ! empirical coefficient [J mol-1] - real, parameter :: ct2 = 230000.0 ! empirical coefficient [J mol-1] - real, parameter :: ct3 = 0.961 ! empirical coefficient - real, parameter :: tm = 314.0 ! empirical coefficient [K] - real, parameter :: tstd = 303.0 ! std temperature [K] - real, parameter :: bet = 0.09 ! beta empirical coefficient [K-1] - - integer ivoc ! do-loop index - integer ityp ! do-loop index - real epsilon(5) - real gamma(5) - real density - real elai - real par,cl,reciprod,ct - +! +! real, parameter :: R = 8.314 ! univ. gas constant [J K-1 mol-1] +! real, parameter :: alpha = 0.0027 ! empirical coefficient +! real, parameter :: cl1 = 1.066 ! empirical coefficient +! real, parameter :: ct1 = 95000.0 ! empirical coefficient [J mol-1] +! real, parameter :: ct2 = 230000.0 ! empirical coefficient [J mol-1] +! real, parameter :: ct3 = 0.961 ! empirical coefficient +! real, parameter :: tm = 314.0 ! empirical coefficient [K] +! real, parameter :: tstd = 303.0 ! std temperature [K] +! real, parameter :: bet = 0.09 ! beta empirical coefficient [K-1] +! +! integer ivoc ! do-loop index +! integer ityp ! do-loop index +! real epsilon(5) +! real gamma(5) +! real density +! real elai +! real par,cl,reciprod,ct +! ! epsilon : - - do ivoc = 1, 5 - epsilon(ivoc) = eps(VEGTYP,ivoc) - end do - +! +! do ivoc = 1, 5 +! epsilon(ivoc) = eps(VEGTYP,ivoc) +! end do +! ! gamma : Activity factor. Units [dimensionless] - - reciprod = 1. / (R * tv * tstd) - ct = exp(ct1 * (tv - tstd) * reciprod) / & - (ct3 + exp(ct2 * (tv - tm) * reciprod)) - - par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s) - cl = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5) - - gamma(1) = cl * ct ! for isoprenes - - do ivoc = 2, 5 - gamma(ivoc) = exp(bet * (tv - tstd)) - end do - +! +! reciprod = 1. / (R * tv * tstd) +! ct = exp(ct1 * (tv - tstd) * reciprod) / & +! (ct3 + exp(ct2 * (tv - tm) * reciprod)) +! +! par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s) +! cl = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5) +! +! gamma(1) = cl * ct ! for isoprenes +! +! do ivoc = 2, 5 +! gamma(ivoc) = exp(bet * (tv - tstd)) +! end do +! ! Foliage density - +! ! transform vegfrac to lai - - elai = max(0.0,-6.5/2.5*alog((1.-vegfrac))) - density = elai / (slarea(VEGTYP) * 0.5) - +! +! elai = max(0.0,-6.5/2.5*alog((1.-vegfrac))) +! density = elai / (slarea(VEGTYP) * 0.5) +! ! calculate the voc flux - - do ivoc = 1, 5 - vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density - end do - - end subroutine bvocflux +! +! do ivoc = 1, 5 +! vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density +! end do +! +! end subroutine bvocflux ! ================================================================================================== ! ********************************* end of carbon subroutines ***************************** ! ================================================================================================== - SUBROUTINE REDPRM (VEGTYP,SOILTYP,SLOPETYP,ZSOIL,NSOIL,ISURBAN) - -!niu use module_sf_noahlsm_param_init - - IMPLICIT NONE -! ---------------------------------------------------------------------- -! Internally set (default valuess) -! all soil and vegetation parameters required for the execusion oF -! the Noah lsm are defined in VEGPARM.TBL, SOILPARM.TB, and GENPARM.TBL. -! ---------------------------------------------------------------------- -! Vegetation parameters: -! CMXTBL: MAX CNPY Capacity -! NROOT: Rooting depth -! -! ---------------------------------------------------------------------- -! Soil parameters: -! SSATPSI: SAT (saturation) soil potential -! SSATDW: SAT soil diffusivity -! F1: Soil thermal diffusivity/conductivity coef. -! QUARTZ: Soil quartz content -! Modified by F. Chen (12/22/97) to use the STATSGO soil map -! Modified By F. Chen (01/22/00) to include PLaya, Lava, and White San -! Modified By F. Chen (08/05/02) to include additional parameters for the Noah -! NOTE: SATDW = BB*SATDK*(SATPSI/MAXSMC) -! F11 = ALOG10(SATPSI) + BB*ALOG10(MAXSMC) + 2.0 -! REFSMC1=MAXSMC*(5.79E-9/SATDK)**(1/(2*BB+3)) 5.79E-9 m/s= 0.5 mm -! REFSMC=REFSMC1+1./3.(MAXSMC-REFSMC1) -! WLTSMC1=MAXSMC*(200./SATPSI)**(-1./BB) (Wetzel and Chang, 198 -! WLTSMC=WLTSMC1-0.5*WLTSMC1 -! Note: the values for playa is set for it to have a thermal conductivit -! as sand and to have a hydrulic conductivity as clay -! -! ---------------------------------------------------------------------- -! BLANK OCEAN/SEA -! CSOIL_DATA: soil heat capacity [J M-3 K-1] -! ZBOT_DATA: depth[M] of lower boundary soil temperature -! CZIL_DATA: calculate roughness length of heat -! SMLOW_DATA and MHIGH_DATA: two soil moisture wilt, soil moisture referen -! parameters -! Set maximum number of soil- and veg- in data statement. -! ---------------------------------------------------------------------- - INTEGER, PARAMETER :: MAX_SOILTYP=30,MAX_VEGTYP=30 - -! Veg parameters - INTEGER, INTENT(IN) :: VEGTYP - INTEGER, INTENT(IN) :: ISURBAN -! Soil parameters - INTEGER, INTENT(IN) :: SOILTYP -! General parameters - INTEGER, INTENT(IN) :: SLOPETYP -! General parameters - INTEGER, INTENT(IN) :: NSOIL -! Layer parameters - REAL,DIMENSION(NSOIL),INTENT(IN) :: ZSOIL - -! Locals - REAL :: REFDK - REAL :: REFKDT - REAL :: FRZK - REAL :: FRZFACT - INTEGER :: I - CHARACTER(len=256) :: message -! ---------------------------------------------------------------------- -! - IF (SOILTYP .gt. SLCATS) THEN - call wrf_message('SOILTYP must be less than SLCATS:') - write(message, '("SOILTYP = ", I6, "; SLCATS = ", I6)') SOILTYP, SLCATS - call wrf_message(trim(message)) - call wrf_error_fatal ('REDPRM: Error: too many input soil types') - END IF - IF (VEGTYP .gt. LUCATS) THEN - call wrf_message('VEGTYP must be less than LUCATS:') - write(message, '("VEGTYP = ", I6, "; LUCATS = ", I6)') VEGTYP, LUCATS - call wrf_message(trim(message)) - call wrf_error_fatal ('Error: too many input landuse types') - END IF - -! ---------------------------------------------------------------------- -! SET-UP SOIL PARAMETERS -! ---------------------------------------------------------------------- - CSOIL = CSOIL_DATA - BEXP = BB (SOILTYP) - DKSAT = SATDK (SOILTYP) - DWSAT = SATDW (SOILTYP) - F1 = F11 (SOILTYP) - PSISAT = SATPSI (SOILTYP) - QUARTZ = QTZ (SOILTYP) - SMCDRY = DRYSMC (SOILTYP) - SMCMAX = MAXSMC (SOILTYP) - SMCREF = REFSMC (SOILTYP) - SMCWLT = WLTSMC (SOILTYP) - - IF(VEGTYP==ISURBAN)THEN - SMCMAX = 0.45 - SMCREF = 0.42 - SMCWLT = 0.40 - SMCDRY = 0.40 - CSOIL = 3.E6 - ENDIF - -! ---------------------------------------------------------------------- -! Set-up universal parameters (not dependent on SOILTYP, VEGTYP) -! ---------------------------------------------------------------------- - ZBOT = ZBOT_DATA - CZIL = CZIL_DATA - - FRZK = FRZK_DATA - REFDK = REFDK_DATA - REFKDT = REFKDT_DATA - KDT = REFKDT * DKSAT / REFDK - SLOPE = SLOPE_DATA (SLOPETYP) - -! adjust FRZK parameter to actual soil type: FRZK * FRZFACT - - if(SOILTYP /= 14) then - FRZFACT = (SMCMAX / SMCREF) * (0.412 / 0.468) - FRZX = FRZK * FRZFACT - end if - -! write(*,*) FRZK, FRZX, KDT, SLOPE, SLOPETYP -! ---------------------------------------------------------------------- -! SET-UP VEGETATION PARAMETERS -! ---------------------------------------------------------------------- - ! Six redprm_canres variables: - TOPT = TOPT_DATA - RGL = RGLTBL (VEGTYP) - RSMAX = RSMAX_DATA - RSMIN = RSTBL (VEGTYP) - HS = HSTBL (VEGTYP) - NROOT = NROTBL (VEGTYP) - - IF(VEGTYP==ISURBAN)THEN - RSMIN=400.0 - ENDIF - -! SHDFAC = SHDTBL(VEGTYP) -! IF (VEGTYP .eq. BARE) SHDFAC = 0.0 - - IF (NROOT .gt. NSOIL) THEN - WRITE (*,*) 'Warning: too many root layers' - write (*,*) 'NROOT = ', nroot - write (*,*) 'NSOIL = ', nsoil - call wrf_error_fatal("STOP in Noah-MP") - END IF - -! ---------------------------------------------------------------------- - END SUBROUTINE REDPRM -! ================================================================================================== +!== begin noahmp_options =========================================================================== subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) @@ -9271,12 +8947,13 @@ subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc end subroutine noahmp_options END MODULE NOAHMP_ROUTINES -! ================================================================================================== + + +!== begin footer =================================================================================== MODULE MODULE_SF_NOAHMPLSM USE NOAHMP_ROUTINES USE NOAHMP_GLOBALS - USE NOAHMP_VEG_PARAMETERS END MODULE MODULE_SF_NOAHMPLSM diff --git a/wrfv2_fire/phys/module_sf_oml.F b/wrfv2_fire/phys/module_sf_oml.F index 4e8f2fce..bf0549ed 100644 --- a/wrfv2_fire/phys/module_sf_oml.F +++ b/wrfv2_fire/phys/module_sf_oml.F @@ -90,7 +90,7 @@ SUBROUTINE OML1D(I,J,TML,T0ML,H,H0,HUML, & ! time step - q=(-hfx-lh+gsw+glw-stbolt*emiss*tml*tml*tml*tml)/(rhowater*cwater) + q=(-hfx-lh+gsw+glw*emiss-stbolt*emiss*tml*tml*tml*tml)/(rhowater*cwater) ! wspd=max(sqrt(uair*uair+vair*vair),0.1) wspd=sqrt(uair*uair+vair*vair) if (wspd .lt. 1.e-10 ) then diff --git a/wrfv2_fire/phys/module_sf_pxlsm.F b/wrfv2_fire/phys/module_sf_pxlsm.F index 6d5b0ceb..a6051534 100755 --- a/wrfv2_fire/phys/module_sf_pxlsm.F +++ b/wrfv2_fire/phys/module_sf_pxlsm.F @@ -26,12 +26,12 @@ MODULE module_sf_pxlsm !------------------------------------------------------------------------- SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & PSFC, GSW, GLW, RAINBL, EMISS, & - ITIMESTEP,CURR_SECS, NSOIL, DT, ANAL_INTERVAL, & - XLAND, XICE, ALBBCK, ALBEDO, SNOALB, & - SMOIS, TSLB, MAVAIL, TA2, QA2, & - ZS,DZS, PSIH, & + ITIMESTEP,CURR_SECS,NSOIL,DT,ANAL_INTERVAL, & + XLAND, XICE, ALBBCK, ALBEDO, & + SNOALB, SMOIS, TSLB, MAVAIL, TA2, & + QA2, ZS,DZS, PSIH, & LANDUSEF,SOILCTOP,SOILCBOT,VEGFRA,VEGF_PX, & - ISLTYP,RA,RS,LAI,NLCAT,NSCAT, & + ISLTYP,RA,RS,LAI,IMPERV,CANFRA,NLCAT,NSCAT, & HFX,QFX,LH,TSK,SST,ZNT,CANWAT, & GRDFLX,SHDMIN,SHDMAX, & SNOWC,PBLH,RMOL,UST,CAPG,DTBL, & @@ -74,7 +74,7 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & ! assimilation. J. Appl. Meteoro., Vol. 42, 1811-1822. ! ! Pleim and Gilliam, 2009: An Indirect Data Assimilation Scheme for Deep Soil Temperature in the -! Pleim–Xiu Land Surface Model. J. Appl. Meteor. Climatol., 48, 1362–1376. +! Pleim-Xiu Land Surface Model. J. Appl. Meteor. Climatol., 48, 1362-1376. ! ! Gilliam and Pleim, 2010: Performance assessment of new land-surface and planetary boundary layer ! physics in the WRF-ARW. Journal of Applied Meteorology and Climatology, 49, 760-774. @@ -97,52 +97,67 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & ! For the NLCD40 and NLCD50 roughness and leaf area were made consistent between the US NLCD and ! outside US MODIS datasets. Prior, US boundaries created boundaries of roughness and LAI. ! -! +! RG 10/2014 - Wetlands soil moisture treatment. Grid cell soil moisture cannot fall less than fraction of a grid +! cells wetland area * soil saturation (e.g., SMOIS of cell with 50% wetlands cannot fall below 50% of WSAT) +! - Both soil levels are initialized using MVAVAIL (Soil moisture availability) instead of just layer 2. +! - Veg Cv (heat capacity) changed from 8x10-6 to 1.2x10-5 (K-M2/J) +! - Alternate empirical stomatal function of PAR (F1) to better replicate photosynthesis-conductance models. +! The main effect is to reduce stomatal conductance for low PAR. +! - Snow albedo is now computed using fractional land-use weighting. Values for each land-use class +! are defined like other PX landuse parameters in module_sf_pxlsm_data.F. These are based on values +! used by NOAH LSM MODIS in VEGPARM.TBL (MAXALB), but tuned to better match satellite values in maxsnowalb +! dataset. Tuning reduced the MAXALB for all forest classes from values in the 50-60% range to 30-40% range. +! These static values are more representative of albedo after snow has melted of fallen from trees. These +! values were also cross verified with http://www.globalbedo.org/global.php +! - USGS 28 category added as an option +! - Impervious surface and canopy fraction data can be used if processed (otherwise 0% so no impact) +! to alter surface heat capacity (See SURFPX subroutine for details) in urban areas and refine +! LAI and VEGF_PX estimations (see VEGLAND subroutine). !-------------------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------------------- ! ARGUMENT LIST: ! !... Inputs: -!-- U3D 3D u-velocity interpolated to theta points (m/s) -!-- V3D 3D v-velocity interpolated to theta points (m/s) -!-- DZ8W dz between full levels (m) -!-- QV3D 3D mixing ratio -!-- T3D Temperature (K) -!-- TH3D Theta (K) -!-- RHO 3D dry air density (kg/m^3) - -!-- PSFC surface pressure (Pa) -!-- GSW downward short wave flux at ground surface (W/m^2) -!-- GLW downward long wave flux at ground surface (W/m^2) -!-- RAINBL Timestep rainfall -!-- EMISS surface emissivity (between 0 and 1) - -!-- ITIMESTEP time step number -!-- NSOIL number of soil layers -!-- DT time step (second) -!-- CURR_SECS time on model domain in seconds, universal WRF variable +!-- U3D 3D u-velocity interpolated to theta points (m/s) +!-- V3D 3D v-velocity interpolated to theta points (m/s) +!-- DZ8W dz between full levels (m) +!-- QV3D 3D mixing ratio +!-- T3D Temperature (K) +!-- TH3D Theta (K) +!-- RHO 3D dry air density (kg/m^3) + +!-- PSFC surface pressure (Pa) +!-- GSW downward short wave flux at ground surface (W/m^2) +!-- GLW downward long wave flux at ground surface (W/m^2) +!-- RAINBL Timestep rainfall +!-- EMISS surface emissivity (between 0 and 1) + +!-- ITIMESTEP time step number +!-- NSOIL number of soil layers +!-- DT time step (second) +!-- CURR_SECS time on model domain in seconds, universal WRF variable !-- ANAL_INTERVAL Interval of analyses used for soil moisture and temperature nudging -!-- XLAND land mask (1 for land, 2 for water) -!-- XICE Sea ice -!-- ALBBCK Background Albedo -!-- ALBEDO surface albedo with snow cover effects -!-- SNOALB Albedo of snow +!-- XLAND land mask (1 for land, 2 for water) +!-- XICE Sea ice +!-- ALBBCK Background Albedo +!-- ALBEDO surface albedo with snow cover effects +!-- SNOALB Albedo of snow -!-- SMOIS total soil moisture content (volumetric fraction) -!-- TSLB soil temp (k) -!-- MAVAIL Moisture availibility of soil -!-- TA2 2-m temperature -!-- QA2 2-m mixing ratio +!-- SMOIS total soil moisture content (volumetric fraction) +!-- TSLB soil temp (k) +!-- MAVAIL Moisture availibility of soil +!-- TA2 2-m temperature +!-- QA2 2-m mixing ratio -!-- SVPT0 constant for saturation vapor pressure (K) -!-- SVP1 constant for saturation vapor pressure (kPa) -!-- SVP2 constant for saturation vapor pressure (dimensionless) -!-- SVP3 constant for saturation vapor pressure (K) +!-- SVPT0 constant for saturation vapor pressure (K) +!-- SVP1 constant for saturation vapor pressure (kPa) +!-- SVP2 constant for saturation vapor pressure (dimensionless) +!-- SVP3 constant for saturation vapor pressure (K) -!-- ZS depths of centers of soil layers -!-- DZS thicknesses of soil layers -!-- PSIH similarity stability function for heat +!-- ZS depths of centers of soil layers +!-- DZS thicknesses of soil layers +!-- PSIH similarity stability function for heat !-- LANDUSEF Landuse fraction !-- SOILCTOP Top soil fraction @@ -154,42 +169,44 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & !-- RA Aerodynamic resistence !-- RS Stomatal resistence !-- LAI Leaf area index (weighted according to fractional landuse) +!-- IMPERV Fraction (percent) of grid cell that is impervious surface (concrete/road/non-veg) +!-- CANFRA Fraction (percent) of grid cell that is covered with tree canopy !-- NLCAT Number of landuse categories !-- NSCAT Number of soil categories -!-- HFX net upward heat flux at the surface (W/m^2) -!-- QFX net upward moisture flux at the surface (kg/m^2/s) -!-- LH net upward latent heat flux at surface (W/m^2) -!-- TSK surface skin temperature (K) -!-- SST sea surface temperature -!-- ZNT rougness length -!-- CANWAT Canopy water (mm) +!-- HFX net upward heat flux at the surface (W/m^2) +!-- QFX net upward moisture flux at the surface (kg/m^2/s) +!-- LH net upward latent heat flux at surface (W/m^2) +!-- TSK surface skin temperature (K) +!-- SST sea surface temperature +!-- ZNT rougness length +!-- CANWAT Canopy water (mm) -!-- GRDFLX Ground heat flux -!-- SFCEVP Evaportation from surface +!-- GRDFLX Ground heat flux +!-- SFCEVP Evaportation from surface !-- SHDMIN Minimum annual vegetation fraction for each grid cell !-- SHDMAX Maximum annual vegetation fraction for each grid cell -!-- SNOWC flag indicating snow coverage (1 for snow cover) -!-- PBLH PBL height (m) -!-- RMOL 1/L Reciprocal of Monin-Obukhov length -!-- UST u* in similarity theory (m/s) -!-- CAPG heat capacity for soil (J/K/m^3) -!-- DTBL time step of boundary layer calls - -!-- T2_NDG_OLD Analysis temperature prior to current time -!-- T2_NDG_NEW Analysis temperature ahead of current time -!-- Q2_NDG_OLD Analysis mixing ratio prior to current time -!-- Q2_NDG_NEW Analysis mixing ratio ahead of current time - -!-- SN_NDG_OLD Analysis snow water prior to current time -!-- SN_NDG_NEW Analysis snow water ahead of current time -!-- SNOW Snow water equivalent -!-- SNOWH Physical snow depth -!-- SNOWNCV Time step accumulated snow - -!-- T2OBS Analysis temperature interpolated from prior and next in time analysese -!-- Q2OBS Analysis moisture interpolated from prior and next in time analysese +!-- SNOWC flag indicating snow coverage (1 for snow cover) +!-- PBLH PBL height (m) +!-- RMOL 1/L Reciprocal of Monin-Obukhov length +!-- UST u* in similarity theory (m/s) +!-- CAPG heat capacity for soil (J/K/m^3) +!-- DTBL time step of boundary layer calls + +!-- T2_NDG_OLD Analysis temperature prior to current time +!-- T2_NDG_NEW Analysis temperature ahead of current time +!-- Q2_NDG_OLD Analysis mixing ratio prior to current time +!-- Q2_NDG_NEW Analysis mixing ratio ahead of current time + +!-- SN_NDG_OLD Analysis snow water prior to current time +!-- SN_NDG_NEW Analysis snow water ahead of current time +!-- SNOW Snow water equivalent +!-- SNOWH Physical snow depth +!-- SNOWNCV Time step accumulated snow + +!-- T2OBS Analysis temperature interpolated from prior and next in time analysese +!-- Q2OBS Analysis moisture interpolated from prior and next in time analysese !-- PXLSM_SMOIS_INIT Flag to intialize deep soil moisture to a value derived from moisture availiability. !-- PXLSM_SOIL_NUDGE Flag to use soil moisture and temperature nudging in the PX LSM ! This is typically done for the first simulation. @@ -245,10 +262,10 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(IN) :: PSFC, GSW, GLW, RAINBL, & - EMISS, SNOALB, & ALBBCK, SHDMIN, SHDMAX, & PBLH, RMOL, SNOWNCV, & - UST, MAVAIL, SST + UST, MAVAIL, SST, EMISS + REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(IN) :: T2_NDG_OLD, T2_NDG_NEW, & Q2_NDG_OLD, Q2_NDG_NEW, & @@ -258,9 +275,9 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(INOUT) :: CAPG,CANWAT, QFX, HFX, LH, & - PSIH,VEGFRA, VEGF_PX, SNOW, & - SNOWH, SNOWC, ALBEDO, XLAND, XICE - + PSIH,VEGFRA, VEGF_PX, SNOW, SNOALB, & + SNOWH, SNOWC, ALBEDO, XLAND, XICE, & + IMPERV, CANFRA LOGICAL :: radiation @@ -281,7 +298,7 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & !---- REALS REAL, DIMENSION( ims:ime, jms:jme ) :: XLAI, XLAIMN, RSTMIN, & XVEG, XVEGMN, XSNUP, & - XALB + XALB, XSNOALB, WETFRA REAL, DIMENSION( ims:ime, jms:jme ) :: RADNET, EG, ER, ETR, QST @@ -313,10 +330,12 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & LAND_USE_TYPE = 'NLCD40' ELSE IF (NLCAT == 20) THEN LAND_USE_TYPE = 'MODIS' + ELSE IF (NLCAT == 21) THEN + LAND_USE_TYPE = 'MODIS' ELSE IF (NLCAT == 24) THEN LAND_USE_TYPE = 'USGS' ELSE IF (NLCAT == 28) THEN - LAND_USE_TYPE = 'USGS' + LAND_USE_TYPE = 'USGS28' ELSE call wrf_error_fatal("Error: Unknown Land Use Category") END IF @@ -338,28 +357,28 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & !----------------------------------------------------------------------------------- !--- Compute time relatve to old and new analysis time for timestep interpolation IF(PXLSM_SOIL_NUDGE .EQ. 1) THEN - DT_FDDA = ANAL_INTERVAL * 1.0 ! Convert DT of Analysis to real + DT_FDDA = ANAL_INTERVAL * 1.0 ! Convert DT of Analysis to real TIME_BETWEEN_ANALYSIS = MOD(CURR_SECS,DT_FDDA) - IF (TIME_BETWEEN_ANALYSIS .EQ. 0.0) THEN - CORB = 1.0 + IF (TIME_BETWEEN_ANALYSIS .EQ. 0.0) THEN + CORB = 1.0 CORE = 0.0 - ELSE - CORE = TIME_BETWEEN_ANALYSIS / DT_FDDA - CORB = 1.0 - CORE + ELSE + CORE = TIME_BETWEEN_ANALYSIS / DT_FDDA + CORB = 1.0 - CORE ENDIF ENDIF !----------------------------------------------------------------------------------- ! Compute vegetation and land-use characteristics by land-use fraction weighting - ! These parameters include LAI, VEGF, ZNT, ALBEDO, RS, etc. + ! These parameters include LAI, VEGF, ZNT, ALBEDO, SNOALB, RS, etc. CALL VEGELAND(LANDUSEF, VEGFRA, SHDMIN, SHDMAX, & SOILCTOP, SOILCBOT, NLCAT, NSCAT, & - ZNT,XLAI,XLAIMN,RSTMIN,XVEG,XVEGMN,XSNUP,& - XLAND, XALB, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & + ZNT,XLAI,XLAIMN,RSTMIN,XVEG,XVEGMN,XSNUP, & + XLAND, XALB,XSNOALB,WETFRA,IMPERV,CANFRA, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, LAND_USE_TYPE ) !----------------------------------------------------------------------------------- - + !----------------------------------------------------------------------------------- ! Main loop over individual grid cells DO J = jts,jte !-- J LOOP @@ -375,7 +394,9 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & ITIMESTEP, MAVAIL(I,J), & PXLSM_SMOIS_INIT, & FWSAT,FWFC,FWWLT,FB,FCGSAT, & - FJP,FAS,FC2R,FC1SAT,ISTI,SMOIS(I,2,J) ) + FJP,FAS,FC2R,FC1SAT,ISTI,SMOIS(I,1,J), & + SMOIS(I,2,J)) + !---------------------------------------------------------- !---------------------------------------------------------- ISLTYP(I,J) = ISTI ELSE @@ -397,7 +418,7 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & PRECIP = MAX ( 1.0E-3*RAINBL(i,j)/DTBL,0.0) ! accumulated precip. rate during DT (=dtpbl) ! convert RAINBL from mm to m for PXLSM WR = 1.0E-3*CANWAT(I,J) ! convert CANWAT from mm to m for PXLSM - THETA1 = TH3D(i,1,j) ! potential temp at first layer + THETA1 = TH3D(i,1,j) ! potential temp at first layer SNOBS = SNOW(I,J) ! Set snow cover to existing model value ! this is overwritten below if snow analysis is availiable ! otherwise snow cover remains constant through simulation @@ -420,13 +441,16 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & USTAR = MAX(UST(I,J),0.005) - IF (IFLAND .GT. 1.5) THEN ! if over water + IF (IFLAND .GE. 1.5) THEN ! if over water ZNT(I,J) = CZO * UST(I,J) * UST(I,J) / G + OZO ENDIF - Z0 = ZNT(I,J) - CPAIR = CPD * (1.0 + 0.84 * QV1) ! J/(K KG) + Z0 = ZNT(I,J) + CPAIR = CPD * (1.0 + 0.84 * QV1) ! J/(K KG) + ! Set WRF Snow albedo to PX snow albedo based on fractional landuse + ! Snow albedo for each landuse class is defined in module_sf_pxlsm_data.F + SNOALB(I,J) = XSNOALB(I,J) !------------------------------------------------------------- ! Compute fractional snow area and snow albedo CALL PXSNOW (ITIMESTEP, SNOBS, SNOWNCV(I,J), SNOW(I,J), & @@ -439,7 +463,7 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & ! Sea Ice from analysis and water cells that are very cold, but more than 50% water ! are converted to ice/snow for more reasonable treatment. IF( (XICE(I,J).GE.0.5) .OR. & - (SST(I,J).LE.270.0.AND.XLAND(I,J).GT.1.50) ) THEN + (SST(I,J).LE.270.0.AND.XLAND(I,J).GE.1.50) ) THEN XLAND(I,J) = 1.0 IFLAND = 1.0 ZNT(I,J) = 0.001 ! Ice @@ -466,8 +490,9 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & VEGF_PX(I,J) = XVEGMN(I,J) + FSEAS*(XVEG(I,J) - XVEGMN(I,J)) ! Ensure veg algorithms not used for water - IF (IFLAND .GT. 1.5) THEN - VEGF_PX(I,J) = 0.0 + IF (IFLAND .GE. 1.5) THEN + VEGF_PX(I,J) = 0.0 + LAI(I,J) = 0.0 ENDIF !------------------------------------------------------------- @@ -492,7 +517,8 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & QST12 = KARMAN * ZFUNC*(QV2-QV1) / (ZA2-ZLVL) -!--- LSM sub-time loop too prevent dt > 40 sec + !------------------------------------------------------------- + !-- LSM sub-time loop too prevent dt > 40 sec NTSPS = INT(DT / (DTPBLX + 0.000001) + 1.0) DTPBL = DT / NTSPS @@ -520,16 +546,16 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & THETA1, PRECIP, & !in CPAIR, PSIH(I,J), & !in RH2OBS,T2OBS(I,J), & !in - VEGF_PX(I,J), ISTI, LAI(I,J), BETAP, & !in - RSTMIN(I,J), HC_SNOW, SNOW_FRA, & !in + VEGF_PX(I,J), ISTI, LAI(I,J), IMPERV(I,J), CANFRA(I,J), & !in + BETAP, RSTMIN(I,J), HC_SNOW, SNOW_FRA, WETFRA(I,J), & !in FWWLT, FWFC, FCGSAT, FWSAT, FB, & !in FC1SAT,FC2R,FAS,FJP,DZS(1),DZS(2),QST12, & !in RADNET(I,J), GRDFLX(I,J), HFX(I,J), QFX(I,J), LH(I,J), & !out EG(I,J), ER(I,J), ETR(I,J), & !out QST(I,J), CAPG(I,J), RS(I,J), RA(I,J), & !out TSLB(I,1,J), TSLB(I,2,J), & !out - SMOIS(I,1,J), SMOIS(I,2,J), WR, TA2(I,J), QA2(I,J), & - LAND_USE_TYPE ) + SMOIS(I,1,J), SMOIS(I,2,J), WR, & + TA2(I,J), QA2(I,J), LAND_USE_TYPE,I,J ) !------------------------------------------------------------------------- END DO ! Time internal PX time loop @@ -548,15 +574,15 @@ END SUBROUTINE pxlsm !------------------------------------------------------------------------- !------------------------------------------------------------------------- - SUBROUTINE VEGELAND( landusef, vegfra, & + SUBROUTINE VEGELAND( landusef, vegfra, & shdmin, shdmax, & - soilctop, soilcbot, nlcat, nscat, & - znt, xlai, xlaimn, rstmin, xveg, xvegmn, & - xsnup, xland, xalb, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & + soilctop, soilcbot, nlcat, nscat,znt, xlai, & + xlaimn, rstmin, xveg, xvegmn, xsnup, xland, & + xalb, xsnoalb, wetfra, imperv, canfra, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & - LAND_USE_TYPE ) + LAND_USE_TYPE ) !------------------------------------------------------------------------- ! ! CALLED FROM Sub. bl_init in module_physics.init.F @@ -587,28 +613,32 @@ SUBROUTINE VEGELAND( landusef, vegfra, & REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: VEGFRA, SHDMIN, SHDMAX - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ZNT + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ZNT, IMPERV, CANFRA REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: XLAI, XLAIMN, RSTMIN, XALB, & - XVEG, XVEGMN, XSNUP, XLAND + XVEG, XVEGMN, XSNUP, XLAND, & + WETFRA, XSNOALB CHARACTER (LEN = 6), INTENT(IN) :: LAND_USE_TYPE !... local variables - INTEGER :: itf, jtf, k, j, i - REAL :: SUMLAI, SUMLMN, SUMRSI, SUMLZ0, SUMVEG, SUMVMN, ALAI, VEGF, SUMSNUP - REAL :: VFMX, VFMN, VSEAS, FAREA, FWAT, ZNOTC, SUMALB - REAL, DIMENSION( NLCAT ) :: LAIMX, LAIMN, Z0, VEG, VEGMN, SNUP - REAL, PARAMETER :: ZNOTCMN = 5.0 ! CM, MIN Zo FOR CROPS - REAL, PARAMETER :: ZNOTCMX = 15.0 ! CM, MAX Zo FOR CROPS + INTEGER :: ITF, JTF, K, J, I + REAL :: SUMLAI, SUMLMN, SUMRSI, SUMLZ0, SUMVEG, SUMVMN, & + ALAI, VEGF, SUMSNUP, SUMALB, SUMSNOALB + + REAL :: VFMX, VFMN, VSEAS, FAREA, FWAT, ZNOTC, FCAN, FIMP, FORFRA, EXTFOR + REAL, DIMENSION( NLCAT ) :: LAIMX, LAIMN, Z0, VEG, VEGMN, SNUP, ALB, SNOALB + + REAL, PARAMETER :: ZNOTCMN = 5.0 ! CM, MIN Zo FOR CROPS + REAL, PARAMETER :: ZNOTCMX = 15.0 ! CM, MAX Zo FOR CROPS - REAL, SAVE, DIMENSION(:), POINTER :: RSMIN, Z00, VEG0, VEGMN0, LAI0, LAIMN0, SNUP0, ALBF + REAL, SAVE, DIMENSION(:), POINTER :: RSMIN, Z00, VEG0, VEGMN0, LAI0, & + LAIMN0, SNUP0, ALBF, SNOALBF !---- INITIALIZE PARAMETERS + INTEGER, SAVE :: KWAT, LIMIT1, LIMIT2 - INTEGER, SAVE :: KWAT - INTEGER, SAVE :: LIMIT1, LIMIT2 ! Initialize LU characteristics by LU Dataset IF (LAND_USE_TYPE == 'USGS') THEN KWAT = 16 @@ -620,6 +650,20 @@ SUBROUTINE VEGELAND( landusef, vegfra, & LAIMN0 => LAIMN0_USGS SNUP0 => SNUP0_USGS ALBF => ALBF_USGS + SNOALBF=> SNOALB_USGS + LIMIT1 = 2 + LIMIT1 = 6 + ELSE IF (LAND_USE_TYPE == 'USGS28') THEN + KWAT = 16 + RSMIN => RSMIN_USGS28 + Z00 => Z00_USGS28 + VEG0 => VEG0_USGS28 + VEGMN0 => VEGMN0_USGS28 + LAI0 => LAI0_USGS28 + LAIMN0 => LAIMN0_USGS28 + SNUP0 => SNUP0_USGS28 + ALBF => ALBF_USGS28 + SNOALBF=> SNOALB_USGS28 LIMIT1 = 2 LIMIT1 = 6 ELSE IF (LAND_USE_TYPE == 'NLCD50') THEN @@ -632,6 +676,7 @@ SUBROUTINE VEGELAND( landusef, vegfra, & LAIMN0 => LAIMN0_NLCD50 SNUP0 => SNUP0_NLCD50 ALBF => ALBF_NLCD50 + SNOALBF=> SNOALB_NLCD50 LIMIT1 = 20 LIMIT1 = 43 ELSE IF (LAND_USE_TYPE == 'NLCD40') THEN @@ -644,6 +689,7 @@ SUBROUTINE VEGELAND( landusef, vegfra, & LAIMN0 => LAIMN0_NLCD40 SNUP0 => SNUP0_NLCD40 ALBF => ALBF_NLCD40 + SNOALBF=> SNOALB_NLCD40 LIMIT1 = 20 LIMIT1 = 43 ELSE IF (LAND_USE_TYPE == 'MODIS') THEN @@ -656,6 +702,7 @@ SUBROUTINE VEGELAND( landusef, vegfra, & LAIMN0 => LAIMN0_MODIS SNUP0 => SNUP0_MODIS ALBF => ALBF_MODIS + SNOALBF=> SNOALB_MODIS LIMIT1 = 12 LIMIT1 = 14 END IF @@ -669,34 +716,43 @@ SUBROUTINE VEGELAND( landusef, vegfra, & XVEGMN(I,J) = 0.0 XSNUP(I,J) = 0.0 XALB(I,J) = 0.0 + XSNOALB(I,J)= 0.0 + + ! Code that may be needed in case these arrays are not intialized + ! with zero by real.exe when not defined by GEOGRID or present + ! in met_em* files + !IMPERV(I,J) = AMAX1(0.0001,IMPERV(I,J)) + !CANFRA(I,J) = AMAX1(0.0001,CANFRA(I,J)) + ENDDO ! END LOOP THROUGH GRID CELLS ENDDO ! END LOOP THROUGH GRID CELLS !-------------------------------------------------------------------- DO J = jts,jte DO I = its,ite - - !-- Initialize 2 and 3-D veg parameters to be caculated - DO K=1,NLCAT + DO K=1,NLCAT LAIMX(K) = LAI0(K) LAIMN(K) = LAIMN0(K) Z0(K) = Z00(K) VEG(K) = VEG0(K) VEGMN(K) = VEGMN0(K) SNUP(K) = SNUP0(K) + ALB(K) = ALBF(K) + SNOALB(K)= SNOALBF(K) ENDDO !-- INITIALIZE SUMS - SUMLAI = 0.0 - SUMLMN = 0.0 - SUMRSI = 0.0 - SUMLZ0 = 0.0 - SUMVEG = 0.0 - SUMVMN = 0.0 - ALAI = 0.0 - SUMSNUP= 0.0 - SUMALB = 0.0 + SUMLAI = 0.0 + SUMLMN = 0.0 + SUMRSI = 0.0 + SUMLZ0 = 0.0 + SUMVEG = 0.0 + SUMVMN = 0.0 + ALAI = 0.0 + SUMSNUP = 0.0 + SUMALB = 0.0 + SUMSNOALB = 0.0 !-- ESTIMATE CROP EMERGANCE DATE FROM VEGFRAC VFMX = SHDMAX(I,J) @@ -714,7 +770,6 @@ SUBROUTINE VEGELAND( landusef, vegfra, & ZNOTC = ZNOTCMN * (1-VSEAS) + ZNOTCMX * VSEAS ! Zo FOR CROPS DO K = 1, NLCAT IF (LAND_USE_TYPE == 'MODIS') THEN - !-- USE THE VEGFRAC DATA ONLY FOR CROPS IF (K.EQ.12 .OR. K.EQ.14) THEN LAIMX(K) = LAIMN0(K) * (1-VSEAS) + LAI0(K) * VSEAS @@ -774,6 +829,22 @@ SUBROUTINE VEGELAND( landusef, vegfra, & Z0(K) = 0.5 * (ZNOTC + Z00(K)) ENDIF ENDIF + ELSE IF (LAND_USE_TYPE == 'USGS28') THEN + !-- USE THE VEGFRAC DATA ONLY FOR CROPS + IF (K .GE. 2 .AND. K .LE. 6) THEN + LAIMX(K) = LAIMN0(K) * (1-VSEAS) + LAI0(K) * VSEAS + LAIMN(K) = LAIMX(K) + VEG(K) = VEGMN0(K) * (1-VSEAS) + VEG0(K) * VSEAS + VEGMN(K) = VEG(K) + !-- SEASONALLY VARY Zo FOR DryCrop (k=2) OR Irigated Crop (k=3) OR Mix Crop (k=4) + IF (K .GE. 2 .AND. K .LE. 4) THEN + Z0(K) = ZNOTC + !-- CrGrM (k=5) or CrWdM (k=6) USE AVG WITH GRASS AND FOREST + ELSE IF (K .GE.5 .AND. K .LE. 6) THEN + Z0(K) = 0.5 * (ZNOTC + Z00(K)) + ENDIF + ENDIF + END IF ENDDO @@ -783,21 +854,23 @@ SUBROUTINE VEGELAND( landusef, vegfra, & !------------------------------------- !-- LOOP THROUGH LANDUSE Fraction and compute totals DO K = 1, NLCAT - FAREA = LANDUSEF(I,K,J) - SUMLAI = SUMLAI + LAIMX(K) * FAREA - SUMLMN = SUMLMN + LAIMN(K) * FAREA - ALAI = ALAI + FAREA - SUMRSI = SUMRSI + FAREA * LAIMX(K) / RSMIN(K) - SUMLZ0 = SUMLZ0 + FAREA * ALOG(Z0(K)) - SUMVEG = SUMVEG + FAREA * VEG(K) - SUMVMN = SUMVMN + FAREA * VEGMN(K) - SUMSNUP= SUMSNUP+ FAREA * SNUP(K) - SUMALB = SUMALB + FAREA * ALBF(K) + FAREA = LANDUSEF(I,K,J) + SUMLAI = SUMLAI + LAIMX(K) * FAREA + SUMLMN = SUMLMN + LAIMN(K) * FAREA + ALAI = ALAI + FAREA + SUMRSI = SUMRSI + FAREA * LAIMX(K) / RSMIN(K) + SUMLZ0 = SUMLZ0 + FAREA * ALOG(Z0(K)) + SUMVEG = SUMVEG + FAREA * VEG(K) + SUMVMN = SUMVMN + FAREA * VEGMN(K) + SUMSNUP = SUMSNUP+ FAREA * SNUP(K) + SUMALB = SUMALB + FAREA * ALB(K) + SUMSNOALB= SUMSNOALB + FAREA * SNOALB(K) ENDDO - !-- CHECK FOR WATER FWAT = LANDUSEF(I,KWAT,J) - IF (FWAT .GT. 0.999) THEN + !-- CHECK FOR WATER + IF (FWAT .GE. 0.50) THEN ! Changed WRFV3.7 +! IF (FWAT .GE. 0.9999) THEN XLAI(I,J) = LAIMX(KWAT) XLAIMN(I,J) = LAIMN(KWAT) RSTMIN(I,J) = RSMIN(KWAT) @@ -805,7 +878,8 @@ SUBROUTINE VEGELAND( landusef, vegfra, & XVEG(I,J) = VEG(KWAT) XVEGMN(I,J) = VEGMN(KWAT) XSNUP(I,J) = SNUP(KWAT) - XALB(I,J) = ALBF(KWAT) + XALB(I,J) = ALB(KWAT) + XSNOALB(I,J)= SNOALB(KWAT) ELSE IF (FWAT .GT. 0.10) THEN ALAI = ALAI - FWAT @@ -817,21 +891,56 @@ SUBROUTINE VEGELAND( landusef, vegfra, & ZNT(I,J) = EXP(SUMLZ0/ALAI) XVEG(I,J) = SUMVEG / ALAI XVEGMN(I,J) = SUMVMN / ALAI - XSNUP(I,J) = SUMSNUP/ALAI - XALB(I,J) = SUMALB/ALAI + XSNUP(I,J) = SUMSNUP + XALB(I,J) = SUMALB + XSNOALB(I,J)= SUMSNOALB ENDIF IF (FWAT .GT. 0.50) THEN - ZNT(I,J) = Z0(KWAT) - XALB(I,J)= ALBF(KWAT) + ZNT(I,J) = Z0(KWAT) + XALB(I,J) = ALB(KWAT) + XSNOALB(I,J)= SNOALB(KWAT) ENDIF + !-- Compute wetlands fraction for proper MMLUIN data set + !-- Note: if LU categories change, these hard coded indicies must be updated + IF (LAND_USE_TYPE == 'USGS') THEN + WETFRA(I,J) = LANDUSEF(I,17,J)+LANDUSEF(I,18,J) + ELSE IF (LAND_USE_TYPE == 'USGS28') THEN + WETFRA(I,J) = LANDUSEF(I,17,J)+LANDUSEF(I,18,J) + ELSE IF (LAND_USE_TYPE == 'NLCD50') THEN + WETFRA(I,J) = LANDUSEF(I,22,J)+LANDUSEF(I,23,J)+LANDUSEF(I,27,J)+LANDUSEF(I,28,J)+LANDUSEF(I,42,J) + ELSE IF (LAND_USE_TYPE == 'NLCD40') THEN + WETFRA(I,J) = LANDUSEF(I,39,J)+LANDUSEF(I,40,J)+LANDUSEF(I,11,J) + ELSE IF (LAND_USE_TYPE == 'MODIS') THEN + WETFRA(I,J) = LANDUSEF(I,11,J) + END IF + ZNT(I,J) = ZNT(I,J) * 0.01 !CONVERT TO M XVEG(I,J) = XVEG(I,J) * 0.01 !CONVERT TO FRAC XVEGMN(I,J) = XVEGMN(I,J) * 0.01 XLAND(I,J) = 1.0 + FWAT XALB(I,J) = XALB(I,J) * 0.01 + XSNOALB(I,J)= XSNOALB(I,J) * 0.01 + !-------Adjustment according to CANFRA and IMPERV fo NLCD40 only ----------- + FIMP = IMPERV(I,J) * 0.01 + FCAN = CANFRA(I,J) * 0.01 + IF (LAND_USE_TYPE == 'NLCD40') THEN + XVEG(I,J) = MIN(XVEG(I,J),1.0-FIMP) + XVEGMN(I,J) = MIN(XVEGMN(I,J),1.0-FIMP) + XVEG(I,J) = MAX(XVEG(I,J),FCAN) + XVEGMN(I,J) = MAX(XVEGMN(I,J),FCAN) + + FORFRA = LANDUSEF(I,39,J)+LANDUSEF(I,30,J)+LANDUSEF(I,29,J)+LANDUSEF(I,28,J) + EXTFOR = FCAN - FORFRA + IF (EXTFOR.GE.0.01) THEN + XLAI(I,J) = LAIMX(30) * EXTFOR + XLAI(I,J) * (1-EXTFOR) + XLAIMN(I,J) = LAIMN(30) * EXTFOR + XLAIMN(I,J) * (1-EXTFOR) + ENDIF + ENDIF + !-------------------------------------------------------------------------- + ENDDO ! END LOOP THROUGH GRID CELLS ENDDO ! END LOOP THROUGH GRID CELLS !-------------------------------------------------------------------- @@ -840,20 +949,15 @@ END SUBROUTINE vegeland !------------------------------------------------------------------------------ !------------------------------------------------------------------------------ - SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in - SOLDN, GSW, LWDN, EMISSI, Z1, & !in - MOL, ZNT, UST, & !in - PSURF, DENS1, QV1, QSS, TA1, & !in - THETA1, PRECIP, & !in - CPAIR, PSIH, & !in - RH2OBS, T2OBS, & !in - VEGFRC, ISTI, LAI, BETAP, & !in - RSTMIN, HC_SNOW, SNOW_FRA, & !in - WWLT, WFC, CGSAT, WSAT, B, & !in - C1SAT, C2R, AS, JP, DS1, DS2,QST12, & !in + SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, SOLDN, GSW, & !in + LWDN, EMISSI, Z1, MOL, ZNT, UST, PSURF, DENS1, & !in + QV1, QSS, TA1, THETA1, PRECIP, CPAIR, PSIH, & !in + RH2OBS, T2OBS, VEGFRC, ISTI,LAI,IMPERV,CANFRA,BETAP, & !in + RSTMIN, HC_SNOW, SNOW_FRA, WETFRA, WWLT, WFC, & !in + CGSAT, WSAT, B, C1SAT, C2R, AS, JP, DS1, DS2, QST12, & !in RADNET, GRDFLX, HFX, QFX, LH, EG, ER, ETR, & !out - QST, CAPG, RS, RA, TG, T2, & !out - WG, W2, WR, TA2, QA2, LAND_USE_TYPE ) !out + QST, CAPG, RS, RA, TG, T2, WG, W2, WR, & !out + TA2, QA2, LAND_USE_TYPE, I, J ) !out !------------------------------------------------------------------------------ ! @@ -893,7 +997,10 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in ! VEGFRC: Vegetation coverage ! ISTI: soil type ! LAI: Leaf area index +! IMPERV: Percentage of IMPERVIOUS Fraction +! CANFRA: Percentage of Canopy/Tree Fraction ! BETAP: Coefficient for bare soil evaporation +! WETFRA: Fraction of Wetlands area ! THZ1OB: Observed TEMP FROM ANAL OF OBS TEMPS AT SCREEN HT ! RHOBS: Observed relative humidity at SCREEN HT ! RSTMIN Minimum Stomatol resistence @@ -928,7 +1035,7 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in !.......Arguments !.. Integer - INTEGER , INTENT(IN) :: ISTI, NUDGEX + INTEGER , INTENT(IN) :: ISTI, NUDGEX, I, J !... Real REAL , INTENT(IN) :: DTPBL, DS1, DS2 @@ -937,8 +1044,8 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in REAL , INTENT(IN) :: ZNT REAL , INTENT(IN) :: PSURF, DENS1, QV1, QSS, TA1, THETA1, PRECIP REAL , INTENT(IN) :: CPAIR - REAL , INTENT(IN) :: VEGFRC, LAI - REAL , INTENT(IN) :: RSTMIN, HC_SNOW, SNOW_FRA + REAL , INTENT(IN) :: VEGFRC, LAI, IMPERV, CANFRA + REAL , INTENT(IN) :: RSTMIN, HC_SNOW, SNOW_FRA, WETFRA REAL , INTENT(IN) :: WWLT, WFC, CGSAT, WSAT, B, C1SAT, C2R, AS, JP REAL , INTENT(IN) :: RH2OBS,T2OBS REAL , INTENT(IN) :: QST12 @@ -954,7 +1061,7 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in !... Local Variables !... Real - REAL :: HF, LV, CQ4 + REAL :: HF, LV, CQ4, WETSAT, SM2 REAL :: RAH, RAW, ET, W2CG, CG, CT, SOILFLX, CPOT, THETAG REAL :: ZOL, ZOBOL, ZNTOL, Y, Y0, PSIH15, YNT REAL :: WGNUDG, W2NUDG, ALPH1, ALPH2, BET1, BET2, T1P5 @@ -965,21 +1072,46 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in REAL :: ALN10, TMP1, TMP2, TMP3, AA, AB, TST, RBH, CTVEG REAL :: QST1,PHIH,PSIOB REAL :: T2NUD, T2NUDF - REAL :: VAPPRS, QSBT, RH2MOD + REAL :: VAPPRS, QSBT, RH2MOD, IMF, VEGF, SOILF !... Parameters - REAL :: ZOBS, GAMAH, BETAH, SIGF, BH, CT_SNOW - REAL, PARAMETER :: CV = 8.0E-6 ! K-M2/J - PARAMETER (ZOBS = 1.5) ! height for observed screen temp., (m) + REAL :: ZOBS, GAMAH, BETAH, SIGF, BH, CT_SNOW, CT_IMPERV + + REAL, PARAMETER :: CV = 1.2E-5 ! K-M2/J Note: Update from 8E-6 10/14 Jon Pleim + + PARAMETER (ZOBS = 1.5) ! height for observed screen temp., (m) PARAMETER (BH = 15.7) PARAMETER (GAMAH = 16. ) !11.6) PARAMETER (BETAH = 5.0 ) !8.21) - PARAMETER (SIGF = 0.5) ! rain interception see LSM (can be 0-1) - !PARAMETER (CT_SNOW = 5.54E-5) -! New value of CT_SNOW calibrated using multilayer soil model where csnow=6.9E5 J/(m3 K) -! from NCAR CSM + PARAMETER (SIGF = 0.5) ! rain interception see LSM (can be 0-1) + !-------------------------------------------------------------------- + ! OLD PX legacy value from MM5 ... unknown origin PARAMETER (CT_SNOW = 5.54E-5) + ! New value of CT_SNOW calibrated using multilayer soil model where csnow=6.9E5 J/(m3 K) + ! from NCAR (WRFV3.2 -WRFV3.6.1) CSM PARAMETER (CT_SNOW = 2.0E-5) PARAMETER (CT_SNOW = 2.0E-5) - ALN10 = ALOG(10.0) + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! CS for concrete/asphalt/road material (http://www.engineeringtoolbox.com/specific-heat-capacity-d_391.html) + ! cs_imperv = 920 J kg-1 K-1 + ! CS for asphalt and concrete from 0.1785 to 0.20 cal g-1 K-1 (http://pages.towson.edu/morgan/files/Impervious.pdf) + ! the values above translate to ~750 to 850 J kg-1 K-1 + ! + ! CAPG used for WRF urban physics ranges from 1.0E6 for roof and building walls to 1.4E6 J m-3 K-1 for roads/urban ground + ! Using these values to back out CS along with 0.15 m thickness 1.4E6 J m-3 K-1 * 0.15 m = 2.1E5 J m-2 K-1 + ! inverse of the value above gives CT_IMPERV value of 1/0.000021 = 4.762E-6 K m2 J-1 + + ! The middle value will be used for now. 850 J kg-1 K-1. This needs to be converted from J/K per kg to area using + ! the approxiate concrete/asphalt density and layer thickness or represenative thickness. For starters (12/2011) + ! well not use the PX first layer thickness, but representative thickness of most roads/parkinglots/buildings. + ! for now welll use 6 inches or about 15 cm or 0.15 m. Density of concrete (normal) from + ! Dorf, Richard. Engineering Handbook. New York: CRC Press, 1996. is ~2400 kg m-3. + ! Using these values 850 J kg-1 K-1 * 2400 kg m-3 * 0.15 m = 3.06E5 J m-2 K-1 or in CT form (inverse) 3.268E-6 K m2 J-1 + ! If you look at the range of possible values considering density differences of concrete/asphalt/etc + ! Values can range from 2.5 to 6.0 E-6 + PARAMETER (CT_IMPERV = 3.268E-6) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + ALN10 = ALOG(10.0) RADNET = SOLDN - (EMISSI *(STBOLT *TG **4 - LWDN)) ! NET RADIATION !-------------------------------------------------------------------- CPOT= (100.0 / PSURF) ** ROVCP ! rcp is global constant(module_model_constants) @@ -1023,6 +1155,17 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in RA=PR0* ( ALOG(Z1/ZNT) - PSIH )/(KARMAN*UST) RAH = RA + 5.0 / UST RAW = RA + 4.503 / UST + + !-------------------------------------------------------------------- + ! Compute soil moisture layer 2 that considers fraction of saturated + ! wetlands. If 100% of cell is wetland, soil moisture can be no lower + ! than full soil saturation. If half wetland, no less than half saturated + IF (IFLAND .LT. 1.5 ) THEN + WETSAT = 1.00 * WSAT ! Wetlands soil moisture + SM2 = (WETFRA * WETSAT) ! + W2 = AMAX1(SM2, W2) ! In case that W2 > Field capacity (heavy precip), use wetter W2 + ENDIF + !-------------------------------------------------------------------- !-- COMPUTE MOISTURE FLUX CALL QFLUX( DENS1, QV1, TA1, SOLDN, RAW, QSS, & @@ -1033,7 +1176,7 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in !-------------------------------------------------------------------- !-------------------------------------------------------------------- - !..........Total evaporation (ET) + ! Compute Total evaporation (ET) from various modes of moisture flux ET = EG + ER + ETR QST = -ET / (DENS1 * UST) @@ -1070,7 +1213,13 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in W2CG = AMAX1(W2,WWLT) CG = CGSAT * 1.0E-6 * (WSAT/ W2CG) ** & (0.5 * B / ALN10) - CT = 1./((1-VEGFRC)/CG + VEGFRC/CV) + ! IMPERVIOUS weighting scheme -- Subtract highly accurate impervious fraction from cell + ! remainder is split between ground and vegetation. CT is a weighted fractional average. + ! Snow CT is then applied for final heat capacity + IMF = AMAX1(0.0,IMPERV/100.0) + VEGF = (1.0 - IMF) * VEGFRC + SOILF= (1.0 - IMF) * (1.0 - VEGFRC) + CT = 1./( IMF/CT_IMPERV + VEGF/CV + SOILF/CG) CT = 1./(SNOW_FRA/CT_SNOW + (1-SNOW_FRA)/CT) CAPG = 1.0/CT @@ -1098,7 +1247,6 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in IF (W2 .GE. WFC) W2NUDG = AMIN1(W2NUDG,0.0) IF (W2 .LE. WWLT) W2NUDG = AMAX1(W2NUDG,0.0) T2NUD = T2NUDF * (T2OBS - TA2) - !print *, 'T2NUD =',T2NUD,T2NUDF ENDIF ENDIF !----------------------------------------------------------------------------------------- @@ -1192,7 +1340,7 @@ SUBROUTINE SURFPX(DTPBL, IFLAND, ISNOW, NUDGEX, XICE1, & !in C1 = C1SAT * (WSAT / WWLT) ** (0.5 * B + 1.0) ENDIF C2 = C2R * W2HLF / (WSAT - W2HLF + 1.E-11) - IF (W2HLF .EQ. WSAT) THEN + IF (W2HLF .GE. WSAT) THEN WEQ = WSAT ELSE WEQ = W2HLF - AS * WSAT * W2REL ** JP * & @@ -1285,7 +1433,7 @@ SUBROUTINE QFLUX (DENS1, QV1, TA1, RG, RAW, QSS, & ! in REAL :: WRMAX, DELTA, SIGG, RADL, RADF, W2AVAIL, W2MXAV REAL :: FTOT, F1, F2, F3, F4 REAL :: FSHELT, GS, GA, FX - + REAL :: PAR, F1MAX !... Parameters @@ -1330,12 +1478,17 @@ SUBROUTINE QFLUX (DENS1, QV1, TA1, RG, RAW, QSS, & ! in !!!-RADIATION IF (RSTMIN .GT. 130.0) THEN - RADL = 30.0 ! W/M2 +! RADL = 30.0 ! W/M2 + F1MAX = 1.-0.03*LAI ELSE - RADL = 100.0 ! W/M2 +! RADL = 100.0 ! W/M2 + F1MAX = 1.-0.05*LAI ENDIF - RADF = 1.1 * RG / (RADL * LAI) ! NP89 - EQN34 - F1 = (RSTMIN / RSMAX + RADF) / (1.0 + RADF) +! RADF = 1.1 * RG / (RADL * LAI) ! NP89 - EQN34 +! F1 = (RSTMIN / RSMAX + RADF) / (1.0 + RADF) + PAR = 0.45 * RG + F1 = F1MAX*(2./(1.+EXP(-0.014*PAR))-1.) + F1 = AMAX1(F1,RSTMIN / RSMAX) !!!-SOIL MOISTURE W2AVAIL = W2 - WWLT @@ -1447,7 +1600,7 @@ END SUBROUTINE smass SUBROUTINE SOILPROP (SOILCBOT,WEIGHT, ITIMESTEP, MAVAIL, & ! IN PXLSM_SMOIS_INIT, & ! IN FWSAT,FWFC,FWWLT,FB,FCGSAT, & ! OUT - FJP,FAS,FC2R,FC1SAT,ISTI, W2 ) ! OUT + FJP,FAS,FC2R,FC1SAT,ISTI, WG, W2 ) ! OUT !------------------------------------------------------------------------ ! SOILPROP COMPUTES SOIL PARAMETERS FOR BOTH BOTTOM AND TOP LAYERS ! USING FRACTIONAL SOIL TYPE. A HARD CODED OPTION IS AVAILIABLE @@ -1461,14 +1614,14 @@ SUBROUTINE SOILPROP (SOILCBOT,WEIGHT, ITIMESTEP, MAVAIL, & ! IN ! 2 LOAMY SAND .410 .150 .075 4.38 3.057 4 .404 3.7 .098 ! 3 SANDY LOAM .435 .195 .114 4.90 3.560 4 .219 1.8 .132 ! 4 SILT LOAM .485 .255 .179 5.30 4.418 6 .105 0.8 .153 - ! 4 SILT .485 .255 .179 5.30 4.418 6 .105 0.8 .153 NP89 does not have Silt so mapped to Silt Loam - ! 5 LOAM .451 .240 .155 5.39 4.111 6 .148 0.8 .191 - ! 6 SND CLY LM .420 .255 .175 7.12 3.670 6 .135 0.8 .213 - ! 7 SLT CLY LM .477 .322 .218 7.75 3.593 8 .127 0.4 .385 - ! 8 CLAY LOAM .476 .325 .250 8.52 3.995 10 .084 0.6 .227 - ! 9 SANDY CLAY .426 .310 .219 10.40 3.058 8 .139 0.3 .421 - ! 10 SILTY CLAY .482 .370 .283 10.40 3.729 10 .075 0.3 .375 - ! 11 CLAY .482 .367 .286 11.40 3.600 12 .083 0.3 .342 + ! 5 SILT .485 .255 .179 5.30 4.418 6 .105 0.8 .153 NP89 does not have Silt so mapped to Silt Loam + ! 6 LOAM .451 .240 .155 5.39 4.111 6 .148 0.8 .191 + ! 7 SND CLY LM .420 .255 .175 7.12 3.670 6 .135 0.8 .213 + ! 8 SLT CLY LM .477 .322 .218 7.75 3.593 8 .127 0.4 .385 + ! 9 CLAY LOAM .476 .325 .250 8.52 3.995 10 .084 0.6 .227 + ! 10 SANDY CLAY .426 .310 .219 10.40 3.058 8 .139 0.3 .421 + ! 11 SILTY CLAY .482 .370 .283 10.40 3.729 10 .075 0.3 .375 + ! 12 CLAY .482 .367 .286 11.40 3.600 12 .083 0.3 .342 !------------------------------------------------------------------------ !------------------------------------------------------------------------------------------ !------------------------------------------------------------------------------------------ @@ -1483,7 +1636,7 @@ SUBROUTINE SOILPROP (SOILCBOT,WEIGHT, ITIMESTEP, MAVAIL, & ! IN REAL, DIMENSION(1:NSCAT), INTENT(IN) :: SOILCBOT REAL, INTENT(OUT) :: FWSAT,FWFC,FWWLT,FB,FCGSAT, & FJP,FAS,FC2R,FC1SAT - REAL, INTENT(INOUT) :: W2 + REAL, INTENT(INOUT) :: W2, WG INTEGER, INTENT(OUT) :: ISTI @@ -1672,6 +1825,7 @@ SUBROUTINE SOILPROP (SOILCBOT,WEIGHT, ITIMESTEP, MAVAIL, & ! IN ! Compute W2 using soil moisture availiability if pxlsm_smois_init (in namelist) is not zero IF (ITIMESTEP .EQ. 1 .AND. PXLSM_SMOIS_INIT .GT. 0) THEN + WG = FWWLT + (0.5*(FWSAT+FWFC) - FWWLT) * MAVAIL W2 = FWWLT + (0.5*(FWSAT+FWFC) - FWWLT) * MAVAIL ENDIF diff --git a/wrfv2_fire/phys/module_sf_pxlsm_data.F b/wrfv2_fire/phys/module_sf_pxlsm_data.F index 7a741b00..ea1c1e64 100644 --- a/wrfv2_fire/phys/module_sf_pxlsm_data.F +++ b/wrfv2_fire/phys/module_sf_pxlsm_data.F @@ -1,79 +1,82 @@ !WRF:MODEL_LAYER:PHYSICS ! +! RG 10/2014 - Added LU-based SNOALB that is used for LU fraction weighted value if specificed. +! +! + MODULE module_sf_pxlsm_data !***************************************************************************** ! MODIS-ONLY (1XX)/MODIS (2XX) LU characterization ... !------------------------------------------------------------------------------- -!Index Rstmin Zo Mxfr MnFr MxLA MnLA ALB -!------------------------------------------------------------------------------- -!Index Rstmin Zo Mxfr MnFr MxLA MnLA SNUP ALB -! 1 175. 100. 90. 80. 4.0 3.0 0.08 12. Evergreen Needleleaf Forest -! 2 120. 90. 95. 85. 5.0 4.0 0.08 12. Evergreen Broadleaf Forest -! 3 175. 100. 95. 50. 5.0 1.0 0.08 14. Deciduous Needleleaf Forest -! 4 200. 100. 95. 50. 5.0 1.0 0.08 16. Deciduous Broadleaf Forest' -! 5 200. 100. 95. 60. 5.0 2.0 0.08 13. Mixed Forest -! 6 200. 15. 90. 50. 3.0 1.0 0.03 22. Closed Shrublands -! 7 200. 15. 75. 50. 2.5 1.0 0.035 20. Open Shrublands -! 8 150. 25. 80. 60. 2.5 1.0 0.03 22. Woody Savanna -! 9 120. 15. 70. 50 2.0 1.0 0.04 20. Savanna +!Index Rstmin Zo Mxfr MnFr MxLA MnLA SNUP ALB SNOALB +! 1 175. 100. 90. 80. 4.0 3.0 0.08 12. 30. Evergreen Needleleaf Forest +! 2 120. 90. 95. 85. 5.0 4.0 0.08 12. 30. Evergreen Broadleaf Forest +! 3 175. 100. 95. 50. 5.0 1.0 0.08 14. 40. Deciduous Needleleaf Forest +! 4 200. 100. 95. 50. 5.0 1.0 0.08 16. 40. Deciduous Broadleaf Forest' +! 5 200. 100. 95. 60. 5.0 2.0 0.08 13. 35. Mixed Forest +! 6 200. 15. 90. 50. 3.0 1.0 0.03 22. 50. Closed Shrublands +! 7 200. 15. 75. 50. 2.5 1.0 0.035 20. 60. Open Shrublands +! 8 150. 25. 80. 60. 2.5 1.0 0.03 22. 50. Woody Savanna +! 9 120. 15. 70. 50 2.0 1.0 0.04 20. 50. Savanna !------------------------------------------------------------------------------- -! 10 100. 7. 85. 60. 2.5 1.0 0.04 19. Grasslands -! 11 160 20. 75. 45. 3.0 1.0 0.015 14. Perminent Wetlands -! 12 70. 10. 95. 10. 3.0 0.5 0.04 18. Croplands -! 13 150. 80. 40. 20. 3.0 1.0 0.04 11. Urban andBuilt-up' -! 14 100. 30. 95. 40. 3.0 1.0 0.04 18. Cropland/Natural Vegetation Mosaic -! 15 9999. 1.2 5. 02. 0.1 0.1 0.02 60. Snow and Ice -! 16 100. 5. 20. 5. 1.0 0.5 0.02 25. Barren or Sparsely Vegetated -! 17 9999. 0.1 00. 00. 0.0 0.0 0.01 8. IGBP water -! 18 175. 30. 70. 50. 3.4 2.0 0.80 15. Wooded Tundra -! 19 120. 15. 40. 20. 2.4 1.0 0.40 15. Mixed Tundra -! 20 100. 10. 20. 5. 1.4 0.1 0.015 25. Barren Tundra +! 10 100. 7. 85. 60. 2.5 1.0 0.04 19. 70. Grasslands +! 11 200 20. 90. 80. 3.0 2.0 0.08 15. 59. Perminent Wetlands +! 12 70. 10. 95. 10. 3.0 0.5 0.04 18. 66. Croplands +! 13 150. 80. 40. 20. 3.0 1.0 0.04 11. 46. Urban andBuilt-up' +! 14 100. 30. 95. 40. 3.0 1.0 0.04 18. 68. Cropland/Natural Vegetation Mosaic +! 15 9999. 1.2 5. 02. 0.1 0.1 0.02 60. 82. Snow and Ice +! 16 100. 5. 20. 5. 1.0 0.5 0.02 25. 75. Barren or Sparsely Vegetated +! 17 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 08. IGBP water +! 18 175. 30. 70. 50. 3.4 2.0 0.80 15. 45. wooded tundra +! 19 120. 15. 40. 20. 2.4 1.0 0.40 15. 50. mixed tundra +! 20 100. 10. 20. 5. 1.4 0.1 .015 25. 75. barren tundra !------------------------------------------------------------------------------------ !**************************************************************************************** !**************************************************************************************** REAL, DIMENSION(20), TARGET :: RSMIN_MODIS, Z00_MODIS, & VEG0_MODIS, VEGMN0_MODIS, & LAI0_MODIS, LAIMN0_MODIS, & - SNUP0_MODIS, ALBF_MODIS + SNUP0_MODIS, ALBF_MODIS, & + SNOALB_MODIS - DATA RSMIN_MODIS & + DATA RSMIN_MODIS & / 175.0, 120.0, 175.0, 200.0, 200.0, & 200.0, 200.0, 150.0, 120.0, 100.0, & 160.0, 70.0, 150.0, 100.0, 9999.0, & 100.0, 9999.0, 175.0, 120.0, 100.0 / - DATA Z00_MODIS & + DATA Z00_MODIS & / 100.0, 90.0, 100.0, 100.0, 100.0, & 15.0, 15.0, 25.0, 15.0, 7.0, & 20.0, 10.0, 80.0, 30.0, 1.2, & 5.0, 0.1, 30.0, 15.0, 10.0 / - DATA VEG0_MODIS & + DATA VEG0_MODIS & / 90.0, 95.0, 95.0, 95.0, 95.0, & 90.0, 75.0, 80.0, 70.0, 85.0, & 75.0, 95.0, 40.0, 95.0, 5.0, & 20.0, 0.0, 70.0, 40.0, 20.0 / - DATA VEGMN0_MODIS & + DATA VEGMN0_MODIS & / 80.0, 85.0, 50.0, 50.0, 60.0, & 50.0, 50.0, 60.0, 50.0, 60.0, & 45.0, 10.0, 20.0, 40.0, 2.0, & 5.0, 0.0, 50.0, 20.0, 5.0 / - DATA LAI0_MODIS & + DATA LAI0_MODIS & / 4.0, 5.0, 5.0, 5.0, 5.0, & 3.0, 2.5, 2.5, 2.0, 2.5, & 3.0, 3.0, 3.0, 3.0, 0.1, & 1.0, 0.0, 3.4, 2.4, 1.4 / - DATA LAIMN0_MODIS & + DATA LAIMN0_MODIS & / 3.0, 4.0, 1.0, 1.0, 2.0, & 1.0, 1.0, 1.0, 1.0, 1.0, & 1.0, 0.5, 1.0, 1.0, 0.1, & 0.5, 0.0, 2.0, 1.0, 0.1 / - DATA SNUP0_MODIS & + DATA SNUP0_MODIS & / 0.08, 0.08, 0.08, 0.08, 0.08, & 0.03, 0.035, 0.03, 0.04, 0.04, & 0.015, 0.04, 0.04, 0.04, 0.02, & @@ -85,71 +88,78 @@ MODULE module_sf_pxlsm_data 14.0, 18.0, 11.0, 18.0, 60.0, & 25.0, 8.0, 15.0, 15.0, 25.0 / + DATA SNOALB_MODIS & + / 30.0, 30.0, 40.0, 40.0, 35.0, & + 50.0, 60.0, 50.0, 50.0, 70.0, & + 59.0, 66.0, 46.0, 68.0, 82.0, & + 75.0, 8.0, 45.0, 55.0, 75.0 / + !**************************************************************************************** !**************************************************************************************** ! 50 CLASS NLCD (US only, cats 1-30)/MODIS (Outside US, cats 31-50) LU characterization !--------------------------------------------------------------------------------------- -!Index Rstmin Zo Mxfr MnFr MxLA MnLA ALB Cat Desc. -! 1 9999. 0.1 00. 00. 0.0 0.0 8 Open water -! 2 9999. 1.2 5. 02. 0.1 0.1 60 Perennial Ice/snow -! 3 120. 30. 90. 80. 3.0 1.0 12 Developed, Open space -! 4 120. 40. 70 60. 3.0 1.0 11 Developed, Low Intensity -! 5 140. 60. 40. 30. 3.0 1.0 10 Developed, Medium Intensity -! 6 160. 100. 15. 5. 3.0 1.0 10 Developed, High Intensity -! 7 100. 5. 20. 5. 1.0 0.5 20 Barren land -! 8 100. 5. 15. 5. 0.5 0.2 35 Unconsolidated Shore -! 9 200. 100. 95. 50. 5.0 1.0 15 Deciduous Forest -! 10 175. 100. 90. 80. 4.0 3.0 10 Evergreen Forest +!Index Rstmin Zo Mxfr MnFr MxLA MnLA ALB SNOALB Cat Desc. +! 1 9999. 0.1 00. 00. 0.0 0.0 8 70. Open water +! 2 9999. 1.2 5. 02. 0.1 0.1 60 82. Perennial Ice/snow +! 3 120. 30. 90. 80. 3.0 1.0 12 60. Developed, Open space +! 4 120. 40. 70 60. 3.0 1.0 11 46. Developed, Low Intensity +! 5 140. 60. 40. 30. 3.0 1.0 10 43. Developed, Medium Intensity +! 6 160. 100. 15. 5. 3.0 1.0 10 40. Developed, High Intensity +! 7 100. 5. 20. 5. 1.0 0.5 20 75. Barren land +! 8 100. 5. 15. 5. 0.5 0.2 35 75. Unconsolidated Shore +! 9 200. 100. 95. 50. 5.0 1.0 15 40. Deciduous Forest +! 10 175. 100. 90. 80. 4.0 3.0 10 30. Evergreen Forest !------------------------------------------------------------------------------- -! 11 200. 100. 95. 60. 5.0 2.0 13 Mixed Forest -! 12 200. 10. 50. 20. 2.0 1.0 20 Dwarf Scrub -! 13 200. 15. 75. 50. 2.5 1.0 20 Shrub/Scrub -! 14 100. 7. 85. 60. 2.5 1.0 19 Grassland/Herbaceous -! 15 100. 7. 80. 20. 2.0 1.0 23 Sedge/Herbaceous -! 16 100. 5. 80. 20. 1.0 1.0 20 Lichens -! 17 100. 5. 80. 20. 1.0 1.0 20 Moss -! 18 100. 5. 50. 20. 1.0 1.0 15 Tundra -! 19 80. 7. 95. 80. 3.0 1.0 18 Pasture/Hay' -! 20 70. 10. 95. 10. 3.0 0.5 18 Cultivated Crops +! 11 200. 100. 95. 60. 5.0 2.0 13 35. Mixed Forest +! 12 200. 10. 50. 20. 2.0 1.0 20 65. Dwarf Scrub +! 13 200. 15. 75. 50. 2.5 1.0 20 60. Shrub/Scrub +! 14 100. 7. 85. 60. 2.5 1.0 19 70. Grassland/Herbaceous +! 15 100. 7. 80. 20. 2.0 1.0 23 60. Sedge/Herbaceous +! 16 100. 5. 80. 20. 1.0 1.0 20 60. Lichens +! 17 100. 5. 80. 20. 1.0 1.0 20 60. Moss +! 18 100. 5. 50. 20. 1.0 1.0 15 75. Tundra +! 19 80. 7. 95. 80. 3.0 1.0 18 68. Pasture/Hay' +! 20 70. 10. 95. 10. 3.0 0.5 18 66. Cultivated Crops !------------------------------------------------------------------------------- -! 21 200. 55. 90. 80. 5.0 2.0 15 Woody Wetland -! 22 200. 80. 90. 80. 5.0 2.0 15 Palustrine Forested Wetland -! 23 164. 30. 90. 80. 3.0 1.0 15 Palustrine Scrub/Shrub Wetland -! 24 200. 60. 90. 80. 5.0 2.0 15 Estuarine Forested Wetland -! 25 164. 30. 90. 80. 3.0 1.0 15 Estuarine Scrub/Shrub Wetland -! 26 120. 11. 60. 40. 2.0 1.0 18 Emergent Herbaceous Wetland -! 27 120. 11. 80. 40. 2.0 1.0 18 Palustrine Emergent Wetland -! 28 120. 11. 80. 40. 2.0 1.0 18 Estuarine Emergent Wetland -! 29 100. 5. 60. 20. 1.0 0.5 10 Palustrine Aquatic Bed -! 30 100. 5. 60. 20. 1.0 0.5 10 Estuarine Aquatic Bed +! 21 200. 55. 90. 80. 5.0 2.0 15 40. Woody Wetland +! 22 200. 80. 90. 80. 5.0 2.0 15 40. Palustrine Forested Wetland +! 23 164. 30. 90. 80. 3.0 1.0 15 50. Palustrine Scrub/Shrub Wetland +! 24 200. 60. 90. 80. 5.0 2.0 15 50. Estuarine Forested Wetland +! 25 164. 30. 90. 80. 3.0 1.0 15 50. Estuarine Scrub/Shrub Wetland +! 26 120. 11. 85. 40. 2.0 1.0 18 59. Emergent Herbaceous Wetland +! 27 120. 11. 85. 40. 2.0 1.0 18 59. Palustrine Emergent Wetland +! 28 120. 11. 85. 40. 2.0 1.0 18 59. Estuarine Emergent Wetland +! 29 100. 5. 60. 20. 1.0 0.5 10 50. Palustrine Aquatic Bed +! 30 100. 5. 60. 20. 1.0 0.5 10 50. Estuarine Aquatic Bed !------------------------------------------------------------------------------- -! 31 9999. 0.1 00. 00. 0.0 0.0 8 Open water (mapped to 1) -! 32 175. 100. 90. 80. 4.0 3.0 12 Evergreen Needleleaf Forest -! 33 120. 90. 95. 85. 5.0 4.0 12 Evergreen Broadleaf Forest -! 34 175. 100. 95. 50. 5.0 1.0 14 Deciduous Needleleaf Forest -! 35 200. 100. 95. 50. 5.0 1.0 16 Deciduous Broadleaf Forest' -! 36 200. 100. 95. 60. 5.0 2.0 13 Mixed Forest -! 37 200. 15. 90. 50. 3.0 1.0 22 Closed Shrublands -! 38 200. 15. 75. 50. 2.5 1.0 20 Open Shrublands -! 39 150. 25. 80. 60. 2.5 1.0 22 Woody Savanna -! 40 120. 15. 70. 50 2.0 1.0 20 Savanna +! 31 9999. 0.1 00. 00. 0.0 0.0 8 8. Open water (mapped to 1) +! 32 175. 100. 90. 80. 4.0 3.0 12 30. Evergreen Needleleaf Forest +! 33 120. 90. 95. 85. 5.0 4.0 12 30. Evergreen Broadleaf Forest +! 34 175. 100. 95. 50. 5.0 1.0 14 40. Deciduous Needleleaf Forest +! 35 200. 100. 95. 50. 5.0 1.0 16 40. Deciduous Broadleaf Forest' +! 36 200. 100. 95. 60. 5.0 2.0 13 35. Mixed Forest +! 37 200. 15. 90. 50. 3.0 1.0 22 50. Closed Shrublands +! 38 200. 15. 75. 50. 2.5 1.0 20 60. Open Shrublands +! 39 150. 25. 80. 60. 2.5 1.0 22 50. Woody Savanna +! 40 120. 15. 70. 50 2.0 1.0 20 50. Savanna !------------------------------------------------------------------------------- -! 41 100. 7. 85. 60. 2.5 1.0 19 Grasslands -! 42 160. 20. 75. 45. 3.0 1.0 14 Perminent Wetlands -! 43 70. 10. 95. 10. 3.0 0.5 18 Croplands -! 44 150. 80. 40. 20. 3.0 1.0 11 Urban andBuilt-up' -! 45 100. 30. 95. 40. 3.0 1.0 18 Cropland/Natural Vegetation Mosaic -! 46 9999. 1.2 5. 02. 0.1 0.1 60 Snow and Ice -! 47 100. 5. 20. 5. 1.0 0.5 25 Barren or Sparsely Vegetated -! 48 9999. 0.1 00. 00. 0.0 0.0 8 IGBP water -! 49 9999. 0.1 00. 00. 0.0 0.0 8 unclassified -! 50 9999. 0.1 00. 00. 0.0 0.0 8 fill value (normally ocean water) +! 41 100. 7. 85. 60. 2.5 1.0 19 70. Grasslands +! 42 160. 20. 75. 45. 3.0 1.0 14 59. Perminent Wetlands +! 43 70. 10. 95. 10. 3.0 0.5 18 66. Croplands +! 44 150. 80. 40. 20. 3.0 1.0 11 46. Urban andBuilt-up' +! 45 100. 30. 95. 40. 3.0 1.0 18 68. Cropland/Natural Vegetation Mosaic +! 46 9999. 1.2 5. 02. 0.1 0.1 60 82. Snow and Ice +! 47 100. 5. 20. 5. 1.0 0.5 25 75. Barren or Sparsely Vegetated +! 48 9999. 0.1 00. 00. 0.0 0.0 8 08. IGBP water +! 49 9999. 0.1 00. 00. 0.0 0.0 8 60. unclassified +! 50 9999. 0.1 00. 00. 0.0 0.0 8 75. fill value (normally ocean water) !------------------------------------------------------------------------------------ REAL, DIMENSION(50), TARGET :: RSMIN_NLCD50, Z00_NLCD50, & VEG0_NLCD50, VEGMN0_NLCD50, & LAI0_NLCD50, LAIMN0_NLCD50, & - SNUP0_NLCD50, ALBF_NLCD50 + SNUP0_NLCD50, ALBF_NLCD50, & + SNOALB_NLCD50 DATA RSMIN_NLCD50 & / 9999.0, 9999.0, 120.0, 120.0, 140.0, & @@ -181,7 +191,7 @@ MODULE module_sf_pxlsm_data 95.0, 50.0, 75.0, 85.0, 80.0, & 80.0, 80.0, 50.0, 95.0, 95.0, & 90.0, 90.0, 90.0, 90.0, 90.0, & - 60.0, 80.0, 80.0, 60.0, 60.0, & + 85.0, 85.0, 85.0, 60.0, 60.0, & 0.0, 90.0, 95.0, 95.0, 95.0, & 95.0, 90.0, 75.0, 80.0, 70.0, & 85.0, 75.0, 95.0, 40.0, 95.0, & @@ -246,6 +256,19 @@ MODULE module_sf_pxlsm_data 13.0, 22.0, 20.0, 22.0, 20.0, & 19.0, 14.0, 18.0, 11.0, 18.0, & 60.0, 25.0, 8.0, 8.0, 8.0 / + + DATA SNOALB_NLCD50 & + / 70.0, 82.0, 60.0, 46.0, 43.0, & + 40.0, 75.0, 75.0, 40.0, 30.0, & + 35.0, 65.0, 60.0, 70.0, 60.0, & + 60.0, 60.0, 75.0, 68.0, 66.0, & + 40.0, 40.0, 50.0, 50.0, 50.0, & + 59.0, 59.0, 59.0, 50.0, 50.0, & + 8.0, 30.0, 30.0, 40.0, 40.0, & + 35.0, 50.0, 60.0, 50.0, 50.0, & + 70.0, 59.0, 66.0, 46.0, 68.0, & + 82.0, 75.0, 8.0, 60.0, 75.0 / + !**************************************************************************************** !**************************************************************************************** @@ -254,61 +277,62 @@ MODULE module_sf_pxlsm_data !**************************************************************************************** ! 40 CLASS MODIS (Outside US, cats 1-20)/NLCD (US only, cats 21-40) LU characterization !------------------------------------------------------------------------------- -!Index Rstmin Zo Mxfr MnFr MxLA MnLA SNUP ALB -! 1 175. 100. 90. 80. 4.0 3.0 0.08 12. Evergreen Needleleaf Forest -! 2 120. 90. 95. 85. 5.0 4.0 0.08 12. Evergreen Broadleaf Forest -! 3 175. 100. 95. 50. 5.0 1.0 0.08 14. Deciduous Needleleaf Forest -! 4 200. 100. 95. 50. 5.0 1.0 0.08 16. Deciduous Broadleaf Forest' -! 5 200. 100. 95. 60. 5.0 2.0 0.08 13. Mixed Forest -! 6 200. 15. 90. 50. 3.0 1.0 0.03 22. Closed Shrublands -! 7 200. 15. 75. 50. 2.5 1.0 0.035 20. Open Shrublands -! 8 150. 25. 80. 60. 2.5 1.0 0.03 22. Woody Savanna -! 9 120. 15. 70. 50 2.0 1.0 0.04 20. Savanna +!Index Rstmin Zo Mxfr MnFr MxLA MnLA SNUP ALB SNOALB +! 1 175. 100. 90. 80. 4.0 3.0 0.08 12. 30. Evergreen Needleleaf Forest +! 2 120. 90. 95. 85. 5.0 4.0 0.08 12. 30. Evergreen Broadleaf Forest +! 3 175. 100. 95. 50. 5.0 1.0 0.08 14. 30. Deciduous Needleleaf Forest +! 4 200. 100. 95. 50. 5.0 1.0 0.08 16. 40. Deciduous Broadleaf Forest' +! 5 200. 100. 95. 60. 5.0 2.0 0.08 13. 35. Mixed Forest +! 6 200. 15. 90. 50. 3.0 1.0 0.03 22. 50. Closed Shrublands +! 7 200. 15. 75. 50. 2.5 1.0 0.035 20. 60. Open Shrublands +! 8 150. 25. 80. 60. 2.5 1.0 0.03 22. 50. Woody Savanna +! 9 120. 15. 70. 50 2.0 1.0 0.04 20. 50. Savanna !------------------------------------------------------------------------------- -! 10 100. 7. 85. 60. 2.5 1.0 0.04 19. Grasslands -! 11 160 20. 75. 45. 3.0 1.0 0.015 14. Perminent Wetlands -! 12 70. 10. 95. 10. 3.0 0.5 0.04 18. Croplands -! 13 150. 80. 40. 20. 3.0 1.0 0.04 11. Urban andBuilt-up' -! 14 100. 30. 95. 40. 3.0 1.0 0.04 18. Cropland/Natural Vegetation Mosaic -! 15 9999. 1.2 5. 02. 0.1 0.1 0.02 60. Snow and Ice -! 16 100. 5. 20. 5. 1.0 0.5 0.02 25. Barren or Sparsely Vegetated -! 17 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 IGBP water -! 18 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 unclassified -! 19 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 fill value (normally ocean water) -! 20 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 unclassified -! 21 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 Open water -! 22 9999. 1.2 5. 02. 0.1 0.1 0.02 60. Perennial Ice/snow -! 23 120. 30. 90. 80. 3.0 1.0 0.04 12. Developed, Open space -! 24 120. 40. 70 60. 3.0 1.0 0.04 11. Developed, Low Intensity -! 25 140. 60. 40. 30. 3.0 1.0 0.04 10. Developed, Medium Intensity -! 26 160. 100. 15. 5. 3.0 1.0 0.04 10. Developed, High Intensity -! 27 100. 5. 20. 5. 1.0 0.5 0.02 20. Barren land -! 28 200. 100. 95. 50. 5.0 1.0 0.08 15. Deciduous Forest -! 29 175. 100. 90. 80. 4.0 3.0 0.08 12. Evergreen Forest +! 10 100. 7. 85. 60. 2.5 1.0 0.04 19. 70. Grasslands +! 11 200 20. 90. 80. 3.0 2.0 0.08 15. 50. Perminent Wetlands +! 12 70. 10. 95. 10. 3.0 0.5 0.04 18. 66. Croplands +! 13 150. 80. 40. 20. 3.0 1.0 0.04 11. 46. Urban andBuilt-up' +! 14 100. 30. 95. 40. 3.0 1.0 0.04 18. 68. Cropland/Natural Vegetation Mosaic +! 15 9999. 1.2 5. 02. 0.1 0.1 0.02 60. 82. Snow and Ice +! 16 100. 5. 20. 5. 1.0 0.5 0.02 25. 75. Barren or Sparsely Vegetated +! 17 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 08. IGBP water +! 18 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 55. wooded tundra +! 19 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 60. mixed tundra +! 20 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 75. barren tundra +! 21 9999. 0.1 00. 00. 0.0 0.0 0.01 8.0 08. Open water +! 22 9999. 1.2 5. 02. 0.1 0.1 0.02 60. 82. Perennial Ice/snow +! 23 120. 30. 90. 80. 2.0 1.0 0.04 16. 60. Developed, Open space +! 24 120. 80. 70 60. 2.0 1.0 0.04 13. 46. Developed, Low Intensity +! 25 140. 120. 40. 30. 2.0 1.0 0.04 11. 43. Developed, Medium Intensity +! 26 160. 200. 15. 5. 2.0 1.0 0.04 10. 40. Developed, High Intensity +! 27 100. 5. 20. 5. 1.0 0.5 0.02 20. 75. Barren land +! 28 200. 100. 95. 50. 5.0 1.0 0.08 15. 40. Deciduous Forest +! 29 175. 100. 90. 80. 4.0 3.0 0.08 12. 30. Evergreen Forest !------------------------------------------------------------------------------- -! 30 200. 100. 95. 60. 5.0 2.0 0.08 13. Mixed Forest -! 31 200. 10. 50. 20. 2.0 1.0 0.04 20. Dwarf Scrub -! 32 200. 15. 75. 50. 2.5 1.0 0.04 20. Shrub/Scrub -! 33 100. 7. 85. 60. 2.5 1.0 0.04 19. Grassland/Herbaceous -! 34 100. 7. 80. 20. 2.0 1.0 0.01 23. Sedge/Herbaceous -! 35 100. 5. 80. 20. 1.0 1.0 0.01 20. Lichens -! 36 100. 5. 80. 20. 1.0 1.0 0.01 20. Moss -! 37 80. 7. 95. 80. 3.0 1.0 0.04 18. Pasture/Hay' -! 38 70. 10. 95. 10. 3.0 0.5 0.04 18. Cultivated Crops +! 30 200. 100. 95. 60. 5.0 2.0 0.08 13. 35. Mixed Forest +! 31 200. 10. 50. 20. 2.0 1.0 0.04 20. 65. Dwarf Scrub +! 32 200. 15. 75. 50. 2.5 1.0 0.04 20. 60. Shrub/Scrub +! 33 100. 7. 85. 60. 2.5 1.0 0.04 19. 70. Grassland/Herbaceous +! 34 100. 7. 80. 20. 2.0 1.0 0.01 23. 60. Sedge/Herbaceous +! 35 100. 5. 80. 20. 1.0 1.0 0.01 20. 60. Lichens +! 36 100. 5. 80. 20. 1.0 1.0 0.01 20. 60. Moss +! 37 80. 7. 95. 80. 3.0 1.0 0.04 18. 68. Pasture/Hay' +! 38 70. 10. 95. 10. 3.0 0.5 0.04 18. 66. Cultivated Crops !------------------------------------------------------------------------------- -! 39 200. 55. 90. 80. 5.0 2.0 0.08 15. Woody Wetland -! 40 120. 11. 60. 40. 2.0 1.0 0.04 18. Emergent Herbaceous Wetland +! 39 200. 55. 90. 80. 5.0 2.0 0.08 15. 40. Woody Wetland +! 40 120. 11. 85. 40. 2.0 1.0 0.04 18. 50. Emergent Herbaceous Wetland !------------------------------------------------------------------------------------ REAL, DIMENSION(40), TARGET :: RSMIN_NLCD40, Z00_NLCD40, & VEG0_NLCD40, VEGMN0_NLCD40, & LAI0_NLCD40, LAIMN0_NLCD40, & - SNUP0_NLCD40, ALBF_NLCD40 + SNUP0_NLCD40, ALBF_NLCD40, & + SNOALB_NLCD40 DATA RSMIN_NLCD40 & / 175.0, 120.0, 175.0, 200.0, 200.0, & 200.0, 200.0, 150.0, 120.0, 100.0, & - 160.0, 70.0, 150.0, 100.0, 9999.0, & + 200.0, 70.0, 150.0, 100.0, 9999.0, & 100.0, 9999.0, 9999.0, 9999.0, 9999.0, & 9999.0, 9999.0, 120.0, 120.0, 140.0, & 160.0, 100.0, 200.0, 175.0, 200.0, & @@ -320,25 +344,25 @@ MODULE module_sf_pxlsm_data 15.0, 15.0, 25.0, 15.0, 7.0, & 20.0, 10.0, 80.0, 30.0, 1.2, & 5.0, 0.1, 0.1, 0.1, 0.1, & - 0.10, 1.20, 30.0, 40.0, 60.0, & - 100.0, 5.0, 100.0, 100.0, 100.0, & + 0.10, 1.20, 30.0, 80.0, 120.0, & + 200.0, 5.0, 100.0, 100.0, 100.0, & 10.0, 15.0, 7.0, 7.0, 5.0, & 5.0, 7.0, 10.0, 55.0, 11.0 / DATA VEG0_NLCD40 & / 90.0, 95.0, 95.0, 95.0, 95.0, & 90.0, 75.0, 80.0, 70.0, 85.0, & - 75.0, 95.0, 40.0, 95.0, 5.0, & + 90.0, 95.0, 40.0, 95.0, 5.0, & 20.0, 0.0, 0.0, 0.0, 0.0, & 0.0, 5.0, 90.0, 70.0, 40.0, & 15.0, 20.0, 95.0, 90.0, 95.0, & 50.0, 75.0, 85.0, 80.0, 80.0, & - 80.0, 95.0, 95.0, 90.0, 60.0 / + 80.0, 95.0, 95.0, 90.0, 85.0 / DATA VEGMN0_NLCD40 & / 80.0, 85.0, 50.0, 50.0, 60.0, & 50.0, 50.0, 60.0, 50.0, 60.0, & - 45.0, 10.0, 20.0, 40.0, 2.0, & + 80.0, 10.0, 20.0, 40.0, 2.0, & 5.0, 0.0, 0.0, 0.0, 0.0, & 0.0, 2.0, 80.0, 60.0, 30.0, & 05.0, 05.0, 50.0, 80.0, 60.0, & @@ -350,15 +374,15 @@ MODULE module_sf_pxlsm_data 3.0, 2.5, 2.5, 2.0, 2.5, & 3.0, 3.0, 3.0, 3.0, 0.1, & 1.0, 0.0, 0.0, 0.0, 0.0, & - 0.0, 0.1, 3.0, 3.0, 3.0, & - 3.0, 1.0, 5.0, 4.0, 5.0, & + 0.0, 0.1, 2.0, 2.0, 2.0, & + 2.0, 1.0, 5.0, 4.0, 5.0, & 2.0, 2.5, 2.5, 2.0, 1.0, & 1.0, 3.0, 3.0, 5.0, 2.0 / DATA LAIMN0_NLCD40 & / 3.0, 4.0, 1.0, 1.0, 2.0, & 1.0, 1.0, 1.0, 1.0, 1.0, & - 1.0, 0.5, 1.0, 1.0, 0.1, & + 2.0, 0.5, 1.0, 1.0, 0.1, & 0.5, 0.0, 0.0, 0.0, 0.0, & 0.0, 0.1, 1.0, 1.0, 1.0, & 1.0, 0.5, 1.0, 3.0, 2.0, & @@ -368,7 +392,7 @@ MODULE module_sf_pxlsm_data DATA SNUP0_NLCD40 & / 0.08, 0.08, 0.08, 0.08, 0.08, & 0.03, 0.035, 0.03, 0.04, 0.04, & - 0.015, 0.04, 0.04, 0.04, 0.02, & + 0.08, 0.04, 0.04, 0.04, 0.02, & 0.02, 0.01, 0.01, 0.01, 0.01, & 0.01, 0.02, 0.04, 0.04, 0.04, & 0.04, 0.02, 0.08, 0.08, 0.08, & @@ -378,48 +402,69 @@ MODULE module_sf_pxlsm_data DATA ALBF_NLCD40 & / 12.0, 12.0, 14.0, 16.0, 13.0, & 22.0, 20.0, 22.0, 20.0, 19.0, & - 14.0, 18.0, 11.0, 18.0, 60.0, & + 17.0, 18.0, 11.0, 18.0, 60.0, & 25.0, 8.0, 8.0, 8.0, 8.0, & 8.0, 60.0, 12.0, 11.0, 10.0, & 10.0, 20.0, 15.0, 12.0, 13.0, & 20.0, 20.0, 19.0, 23.0, 20.0, & 20.0, 18.0, 18.0, 15.0, 18.0 / + DATA ALBF_NLCD40 & + / 12.0, 12.0, 14.0, 16.0, 13.0, & + 22.0, 20.0, 22.0, 20.0, 19.0, & + 17.0, 18.0, 11.0, 18.0, 60.0, & + 25.0, 8.0, 8.0, 8.0, 8.0, & + 8.0, 60.0, 12.0, 11.0, 10.0, & + 10.0, 20.0, 15.0, 12.0, 13.0, & + 20.0, 20.0, 19.0, 23.0, 20.0, & + 20.0, 18.0, 18.0, 15.0, 18.0 / + + DATA SNOALB_NLCD40 & + / 30.0, 30.0, 30.0, 40.0, 35.0, & + 50.0, 60.0, 50.0, 50.0, 70.0, & + 50.0, 66.0, 46.0, 68.0, 82.0, & + 75.0, 8.0, 55.0, 60.0, 75.0, & + 8.0, 82.0, 60.0, 46.0, 43.0, & + 40.0, 75.0, 40.0, 30.0, 35.0, & + 65.0, 60.0, 70.0, 60.0, 60.0, & + 60.0, 68.0, 66.0, 40.0, 50.0 / + !**************************************************************************************** !**************************************************************************************** ! USGS LU characterization !--------------------------- -! Name Rstmin Zo Mxfr MnFr MxLA MnLA ALB -! 1 Urban 150. 50. 40. 20. 2.0 0.5 15 Urban or Built-up Land -! 2 DrCrp 70. 10. 95. 15. 3.0 0.5 17 Dryland Cropland and Pasture -! 3 IrCrp 60. 10. 95. 10. 3.0 0.5 18 Irrigated Cropland and Pasture -! 4 MixCp 70. 10. 95. 15. 3.0 0.5 18 Mixed Dry/Irr Crop and Past -! 5 CrGrM 80. 10. 95. 35. 2.5 1.0 18 Grassland/Cropland Mosaic -! 6 CrWdM 180. 40. 95. 40. 4.0 1.5 16 Woodland/Cropland Mosaic -! 7 GrsLd 100. 7. 95. 70. 2.5 1.0 19 Grassland -! 8 ShrLd 200. 20. 70. 50. 3.0 1.0 22 Shrubland -! 9 ShrGr 150. 20. 85. 60. 3.0 1.0 20 Mixed Shrubland/Grassland -! 10 Savan 120. 20. 80. 60. 2.0 1.0 20 Savanna -! 11 DBFst 200. 50. 95. 50. 5.0 1.0 16 Broadleaf Deciduous Forest -! 12 DNFst 175. 50. 95. 50. 5.0 1.0 14 Deciduous Coniferous Forest -! 13 EBFst 120. 40. 95. 85. 5.0 4.0 12 Evergreen Broadleaf Forest (Palm?) -! 14 ENFst 175. 50. 90. 80. 4.0 3.0 12 Evergreen Coniferous Forest -! 15 MxFst 200. 50. 95. 60. 5.0 2.0 13 Mixed forest -! 16 Water 9999. 0.1 00. 00. 0.0 0.0 08 Water -! 17 HWtld 164. 15. 60. 40. 2.0 1.0 14 Herbaceous Wetland (none in east) -! 18 WWtld 200. 45. 90. 80. 5.0 3.0 14 Forested Wetlands (e.g. Everglades) -! 19 BarSp 100. 5. 10. 05. 0.5 0.2 25 Barren or Sparsely Vegetated -! 20 HrTun 150. 10. 20. 10. 1.0 0.5 15 Herbaceous Tundra -! 21 WdTun 200. 10. 30. 10. 1.0 0.5 15 Shrub and Brush Tundra -! 22 MxTun 150. 5. 20. 05. 1.0 0.5 15 Mixed Tundra -! 23 BGTun 100. 5. 5. 02. 0.1 0.1 25 Bare Ground Tundra -! 24 SnwIc 300. 5. 5. 02. 0.1 0.1 55 Perennial Snowfields or Glaciers +! Name Rstmin Zo Mxfr MnFr MxLA MnLA ALB SNOALB +! 1 Urban 150. 50. 40. 20. 2.0 0.5 15 46. Urban or Built-up Land +! 2 DrCrp 70. 10. 95. 15. 3.0 0.5 17 66. Dryland Cropland and Pasture +! 3 IrCrp 60. 10. 95. 10. 3.0 0.5 18 66. Irrigated Cropland and Pasture +! 4 MixCp 70. 10. 95. 15. 3.0 0.5 18 66. Mixed Dry/Irr Crop and Past +! 5 CrGrM 80. 10. 95. 35. 2.5 1.0 18 70. Grassland/Cropland Mosaic +! 6 CrWdM 180. 40. 95. 40. 4.0 1.5 16 50. Woodland/Cropland Mosaic +! 7 GrsLd 100. 7. 95. 70. 2.5 1.0 19 70. Grassland +! 8 ShrLd 200. 20. 70. 50. 3.0 1.0 22 50. Shrubland +! 9 ShrGr 150. 20. 85. 60. 3.0 1.0 20 60. Mixed Shrubland/Grassland +! 10 Savan 120. 20. 80. 60. 2.0 1.0 20 50. Savanna +! 11 DBFst 200. 50. 95. 50. 5.0 1.0 16 40. Broadleaf Deciduous Forest +! 12 DNFst 175. 50. 95. 50. 5.0 1.0 14 30. Deciduous Coniferous Forest +! 13 EBFst 120. 40. 95. 85. 5.0 4.0 12 30. Evergreen Broadleaf Forest (Palm?) +! 14 ENFst 175. 50. 90. 80. 4.0 3.0 12 30. Evergreen Coniferous Forest +! 15 MxFst 200. 50. 95. 60. 5.0 2.0 13 35. Mixed forest +! 16 Water 9999. 0.1 00. 00. 0.0 0.0 08 08. Water +! 17 HWtld 164. 15. 60. 40. 2.0 1.0 14 50. Herbaceous Wetland (none in east) +! 18 WWtld 200. 45. 90. 80. 5.0 3.0 14 40. Forested Wetlands (e.g. Everglades) +! 19 BarSp 100. 5. 10. 05. 0.5 0.2 25 75. Barren or Sparsely Vegetated +! 20 HrTun 150. 10. 20. 10. 1.0 0.5 15 55. Herbaceous Tundra +! 21 WdTun 200. 10. 30. 10. 1.0 0.5 15 60. Shrub and Brush Tundra +! 22 MxTun 150. 5. 20. 05. 1.0 0.5 15 60. Mixed Tundra +! 23 BGTun 100. 5. 5. 02. 0.1 0.1 25 75. Bare Ground Tundra +! 24 SnwIc 300. 5. 5. 02. 0.1 0.1 55 82. Perennial Snowfields or Glaciers !----------------------------------------------------------------------------- REAL, DIMENSION(24), TARGET :: RSMIN_USGS, Z00_USGS, & VEG0_USGS, VEGMN0_USGS, & LAI0_USGS, LAIMN0_USGS, & - SNUP0_USGS, ALBF_USGS + SNUP0_USGS, ALBF_USGS, & + SNOALB_USGS DATA RSMIN_USGS & / 150.0, 70.0, 60.0, 70.0, 80.0, & @@ -427,12 +472,14 @@ MODULE module_sf_pxlsm_data 200.0, 175.0, 120.0, 175.0, 200.0, & 9999.0, 164.0, 200.0, 100.0, 150.0, & 200.0, 150.0, 100.0, 300.0 / + DATA Z00_USGS & / 50.0, 10.0, 10.0, 10.0, 10.0, & 40.0, 7.0, 20.0, 20.0, 20.0, & 50.0, 50.0, 40.0, 50.0, 50.0, & 0.1, 15.0, 45.0, 5.0, 10.0, & 10.0, 5.0, 5.0, 5.0 / + DATA VEG0_USGS & / 40.0, 95.0, 95.0, 95.0, 95.0, & 95.0, 95.0, 70.0, 85.0, 80.0, & @@ -474,6 +521,128 @@ MODULE module_sf_pxlsm_data 16.0, 14.0, 12.0, 12.0, 13.0, & 8.0, 14.0, 14.0, 25.0, 15.0, & 15.0, 15.0, 25.0, 55.0 / + + DATA SNOALB_USGS & + / 46.0, 66.0, 66.0, 66.0, 70.0, & + 50.0, 70.0, 50.0, 60.0, 50.0, & + 40.0, 40.0, 40.0, 30.0, 35.0, & + 8.0, 50.0, 40.0, 75.0, 55.0, & + 60.0, 60.0, 75.0, 82.0 / + +!**************************************************************************************** +!**************************************************************************************** +!**************************************************************************************** +! USGS LU characterization +!--------------------------- +! Name Rstmin Zo Mxfr MnFr MxLA MnLA ALB SNOALB +! 1 Urban 150. 50. 40. 20. 2.0 0.5 15 46. Urban or Built-up Land +! 2 DrCrp 70. 10. 95. 15. 3.0 0.5 17 66. Dryland Cropland and Pasture +! 3 IrCrp 60. 10. 95. 10. 3.0 0.5 18 66. Irrigated Cropland and Pasture +! 4 MixCp 70. 10. 95. 15. 3.0 0.5 18 66. Mixed Dry/Irr Crop and Past +! 5 CrGrM 80. 10. 95. 35. 2.5 1.0 18 70. Grassland/Cropland Mosaic +! 6 CrWdM 180. 40. 95. 40. 4.0 1.5 16 50. Woodland/Cropland Mosaic +! 7 GrsLd 100. 7. 95. 70. 2.5 1.0 19 70. Grassland +! 8 ShrLd 200. 20. 70. 50. 3.0 1.0 22 50. Shrubland +! 9 ShrGr 150. 20. 85. 60. 3.0 1.0 20 60. Mixed Shrubland/Grassland +! 10 Savan 120. 20. 80. 60. 2.0 1.0 20 50. Savanna +! 11 DBFst 200. 50. 95. 50. 5.0 1.0 16 40. Broadleaf Deciduous Forest +! 12 DNFst 175. 50. 95. 50. 5.0 1.0 14 30. Deciduous Coniferous Forest +! 13 EBFst 120. 40. 95. 85. 5.0 4.0 12 30. Evergreen Broadleaf Forest (Palm?) +! 14 ENFst 175. 50. 90. 80. 4.0 3.0 12 30. Evergreen Coniferous Forest +! 15 MxFst 200. 50. 95. 60. 5.0 2.0 13 35. Mixed forest +! 16 Water 9999. 0.1 00. 00. 0.0 0.0 08 08. Water +! 17 HWtld 164. 15. 60. 40. 2.0 1.0 14 50. Herbaceous Wetland (none in east) +! 18 WWtld 200. 45. 90. 80. 5.0 3.0 14 40. Forested Wetlands (e.g. Everglades) +! 19 BarSp 100. 5. 10. 05. 0.5 0.2 25 75. Barren or Sparsely Vegetated +! 20 HrTun 150. 10. 20. 10. 1.0 0.5 15 55. Herbaceous Tundra +! 21 WdTun 200. 10. 30. 10. 1.0 0.5 15 60. Shrub and Brush Tundra +! 22 MxTun 150. 5. 20. 05. 1.0 0.5 15 60. Mixed Tundra +! 23 BGTun 100. 5. 5. 02. 0.1 0.1 25 75. Bare Ground Tundra +! 24 SnwIc 300. 5. 5. 02. 0.1 0.1 55 82. Perennial Snowfields or Glaciers +! 25 playa 100. 5. 10. 05. 0.5 0.2 25 75. Playa +! 26 lava 100. 5. 10. 05. 0.5 0.2 25 75. Lava +! 27 sand 100. 5. 10. 05. 0.5 0.2 25 75. White Sand +! 28 nana 100. 5. 10. 05. 0.5 0.2 25 75. Unassigned +!----------------------------------------------------------------------------- + + REAL, DIMENSION(28), TARGET :: RSMIN_USGS28, Z00_USGS28, & + VEG0_USGS28, VEGMN0_USGS28, & + LAI0_USGS28, LAIMN0_USGS28, & + SNUP0_USGS28, ALBF_USGS28, & + SNOALB_USGS28 + + DATA RSMIN_USGS28 & + / 150.0, 70.0, 60.0, 70.0, 80.0, & + 180.0, 100.0, 200.0, 150.0, 120.0, & + 200.0, 175.0, 120.0, 175.0, 200.0, & + 9999.0, 164.0, 200.0, 100.0, 150.0, & + 200.0, 150.0, 100.0, 300.0, 100.0, & + 100.0, 100.0, 100.0 / + + DATA Z00_USGS28 & + / 50.0, 10.0, 10.0, 10.0, 10.0, & + 40.0, 7.0, 20.0, 20.0, 20.0, & + 50.0, 50.0, 40.0, 50.0, 50.0, & + 0.1, 15.0, 45.0, 5.0, 10.0, & + 10.0, 5.0, 5.0, 5.0, 5.0, & + 5.0, 5.0, 5.0 / + + DATA VEG0_USGS28 & + / 40.0, 95.0, 95.0, 95.0, 95.0, & + 95.0, 95.0, 70.0, 85.0, 80.0, & + 95.0, 95.0, 95.0, 90.0, 95.0, & + 0.00, 60.0, 90.0, 10.0, 20.0, & + 30.0, 20.0, 5.0, 5.0, 5.0, & + 5.0, 5.0, 5.0 / + + DATA VEGMN0_USGS28 & + / 20.0, 15.0, 10.0, 15.0, 35.0, & + 40.0, 70.0, 50.0, 60.0, 60.0, & + 50.0, 50.0, 85.0, 80.0, 60.0, & + 0.0, 40.0, 80.0, 5.0, 10.0, & + 10.0, 5.0, 2.0, 2.0, 2.0, & + 2.0, 2.0, 2.0 / + + DATA LAI0_USGS28 & + / 2.0, 3.0, 3.0, 3.0, 2.5, & + 4.0, 2.5, 3.0, 3.0, 2.0, & + 5.0, 5.0, 5.0, 4.0, 5.0, & + 0.0, 2.0, 5.0, 0.50, 1.0, & + 1.0, 1.0, 0.1, 0.1, 0.1, & + 0.1, 0.1, 0.1 / + + DATA LAIMN0_USGS28 & + / 0.50, 0.50, 0.50, 0.50, 1.0, & + 1.5, 1.0, 1.0, 1.0, 1.0, & + 1.0, 1.0, 4.0, 3.0, 2.0, & + 0.0, 1.0, 3.0, 0.20, 0.50, & + 0.50, 0.50, 0.10, 0.10, 0.10, & + 0.10, 0.10, 0.10 / + + DATA SNUP0_USGS28 & + / 0.04, 0.04, 0.04, 0.04, 0.04, & + 0.04, 0.04, 0.03, 0.035, 0.04, & + 0.08, 0.08, 0.08, 0.08, 0.08, & + 0.01, 0.01, 0.01, 0.02, 0.02, & + 0.025, 0.025, 0.025, 0.02, 0.02, & + 0.02, 0.02, 0.02 / + + DATA ALBF_USGS28 & + / 15.0, 17.0, 18.0, 18.0, 18.0, & + 16.0, 19.0, 22.0, 20.0, 20.0, & + 16.0, 14.0, 12.0, 12.0, 13.0, & + 8.0, 14.0, 14.0, 25.0, 15.0, & + 15.0, 15.0, 25.0, 55.0, 25.0, & + 10.0, 50.0, 50.0 / + + DATA SNOALB_USGS28 & + / 46.0, 66.0, 66.0, 66.0, 70.0, & + 50.0, 70.0, 50.0, 60.0, 50.0, & + 40.0, 40.0, 40.0, 30.0, 35.0, & + 8.0, 50.0, 40.0, 75.0, 55.0, & + 60.0, 60.0, 75.0, 82.0, 75.0, & + 75.0, 75.0, 75.0 / + !**************************************************************************************** !**************************************************************************************** diff --git a/wrfv2_fire/phys/module_sf_ruclsm.F b/wrfv2_fire/phys/module_sf_ruclsm.F index 1dde23ce..1e0004e7 100644 --- a/wrfv2_fire/phys/module_sf_ruclsm.F +++ b/wrfv2_fire/phys/module_sf_ruclsm.F @@ -7,7 +7,7 @@ MODULE module_sf_ruclsm USE module_wrf_error ! VEGETATION PARAMETERS - INTEGER :: LUCATS , BARE, NATURAL + INTEGER :: LUCATS , BARE, NATURAL, CROP integer, PARAMETER :: NLUS=50 CHARACTER*8 LUTYPE INTEGER, DIMENSION(1:NLUS) :: IFORTBL @@ -37,8 +37,13 @@ MODULE module_sf_ruclsm !----------------------------------------------------------------- SUBROUTINE LSMRUC( & - DT,KTAU,NSL,ZS, & - RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & + DT,KTAU,NSL, & +#if (EM_CORE==1) + lakemodel,lakemask, & + graupelncv,snowncv,rainncv, & +#endif + ZS,RAINBL,SNOW,SNOWH,SNOWC,FRZFRAC,frpcpn, & + rhosnf,precipfr, & ! pass it out to module_diagnostics Z3D,P8W,T3D,QV3D,QC3D,RHO3D, & !p8W in [PA] GLW,GSW,EMISS,CHKLOWQ, CHS, & FLQC,FLHC,MAVAIL,CANWAT,VEGFRA,ALB,ZNT, & @@ -52,7 +57,7 @@ SUBROUTINE LSMRUC( & SOILMOIS,SH2O,SMAVAIL,SMMAX, & TSO,SOILT,HFX,QFX,LH, & SFCRUNOFF,UDRUNOFF,SFCEXC, & - SFCEVP,GRDFLX,ACSNOW,SNOM, & + SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM, & SMFR3D,KEEPFR3DFLAG, & myj,shdmin,shdmax,rdlai2d, & ids,ide, jds,jde, kds,kde, & @@ -80,6 +85,7 @@ SUBROUTINE LSMRUC( & !-- RAINNCV one time step grid scale precipitation (mm/step) ! SNOW - snow water equivalent [mm] ! FRAZFRAC - fraction of frozen precipitation +!-- PRECIPFR (mm) - time step frozen precipitation !-- SNOWC flag indicating snow coverage (1 for snow cover) !-- Z3D heights (m) !-- P8W 3D pressure (Pa) @@ -114,10 +120,11 @@ SUBROUTINE LSMRUC( & !-- QFX upward moisture flux at the surface (kg/m^2/s) !-- LH upward latent heat flux (W/m^2) ! SFCRUNOFF - ground surface runoff [mm] -! UDRUNOFF - underground runoff [mm] -! SFCEVP - total evaporation in [kg/m^2] -! GRDFLX - soil heat flux (W/m^2: negative, if downward from surface) -! ACSNOW - accumulation of snow water [m] +! UDRUNOFF - underground runoff [mm] +! SFCEVP - total evaporation in [kg/m^2] +! GRDFLX - soil heat flux (W/m^2: negative, if downward from surface) +! SNOWFALLAC - run-total snowfall accumulation [mm] +! ACSNOW - run-toral SWE of snowfall [mm] !-- CHKLOWQ - is either 0 or 1 (so far set equal to 1). !-- used only in MYJPBL. !-- tice - sea ice temperture (C) @@ -163,9 +170,20 @@ SUBROUTINE LSMRUC( & EMISS, & XICE, & XLAND, & +! ALBBCK, & VEGFRA, & TBOT +#if (EM_CORE==1) + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: GRAUPELNCV, & + SNOWNCV, & + RAINNCV + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(IN ) :: lakemask + INTEGER, INTENT(IN ) :: LakeModel +#endif + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMAX REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN LOGICAL, intent(in) :: rdlai2d @@ -174,7 +192,7 @@ SUBROUTINE LSMRUC( & REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: & - SNOW, & !new + SNOW, & SNOWH, & SNOWC, & CANWAT, & ! new @@ -242,20 +260,36 @@ SUBROUTINE LSMRUC( & ETT, & SUBLIM, & sflx, & + smf, & EVAPL, & PRCPL, & SEAICE, & INFILTR +! Energy and water budget variables: + REAL, DIMENSION( its:ite, jts:jte ) :: & + budget, & + acbudget, & + waterbudget, & + acwaterbudget, & + smtotold, & + snowold, & + canwatold + -!--- soil/snow properties REAL, DIMENSION( ims:ime, 1:nsl, jms:jme) & :: KEEPFR3DFLAG, & SMFR3D + REAL, DIMENSION( ims:ime, jms:jme ) :: & + RHOSNF, & !RHO of snowfall + PRECIPFR, & ! time-step frozen precip + SNOWFALLAC +!--- soil/snow properties REAL & :: RHOCS, & - RHOSN, & RHONEWSN, & + RHOSN, & + RHOSNFALL, & BCLH, & DQM, & KSAT, & @@ -284,7 +318,7 @@ SUBROUTINE LSMRUC( & REAL, DIMENSION(1:2*(nsl-2)) :: DTDZS - REAL, DIMENSION(1:4001) :: TBQ + REAL, DIMENSION(1:5001) :: TBQ REAL, DIMENSION( 1:nsl ) :: SOILM1D, & @@ -304,6 +338,10 @@ SUBROUTINE LSMRUC( & REAL :: PRCPMS, & NEWSNMS, & + prcpncliq, & + prcpncfr, & + prcpculiq, & + prcpcufr, & PATM, & PATMB, & TABS, & @@ -314,10 +352,15 @@ SUBROUTINE LSMRUC( & RHO, & QKMS, & TKMS, & + snowrat, & + grauprat, & + icerat, & + curat, & INFILTRP REAL :: cq,r61,r273,arp,brp,x,evs,eis + REAL :: cropsm - REAL :: meltfactor + REAL :: meltfactor, ac,as INTEGER :: NROOT INTEGER :: ILAND,ISOIL,IFOREST @@ -337,7 +380,7 @@ SUBROUTINE LSMRUC( & ARP=77455.*41.9/461.525 BRP=64.*41.9/461.525 - DO K=1,4001 + DO K=1,5001 CQ=CQ+.05 ! TBQ(K)=R61*EXP(ARP*(R273-1./CQ)-BRP*LOG(CQ*R273)) EVS=EXP(17.67*(CQ-273.15)/(CQ-29.65)) @@ -362,8 +405,6 @@ SUBROUTINE LSMRUC( & DO J=jts,jte DO i=its,ite do k=1,nsl -! smfr3d (i,k,j)=soilmois(i,k,j)/900.*1.e3 -! sh2o (i,k,j)=soilmois(i,k,j)-smfr3d(i,k,j)/1.e3*900. keepfr3dflag(i,k,j)=0. enddo !--- initializing snow fraction, thereshold = 32 mm of snow water @@ -396,11 +437,13 @@ SUBROUTINE LSMRUC( & CALL wrf_debug ( 0 , message ) ENDIF ENDIF -! qvg (i,j) =qv3d(i,1,j) -! qsfc(i,j) = qsg(i,j)/(1.+qsg(i,j)) qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) SMELT(i,j) = 0. SNOM (i,j) = 0. + ACSNOW(i,j) = 0. + SNOWFALLAC(i,j) = 0. + PRECIPFR(i,j) = 0. + RHOSNF(i,j) = -1.e3 ! non-zero flag SNFLX(i,j) = 0. DEW (i,j) = 0. PC (i,j) = 0. @@ -410,8 +453,14 @@ SUBROUTINE LSMRUC( & SFCRUNOFF(i,j) = 0. UDRUNOFF(i,j) = 0. emissl (i,j) = 0. + budget(i,j) = 0. + acbudget(i,j) = 0. + waterbudget(i,j) = 0. + acwaterbudget(i,j) = 0. + smtotold(i,j)=0. + canwatold(i,j)=0. ! Temporarily!!! - canwat(i,j)=0. +! canwat(i,j)=0. ! For RUC LSM CHKLOWQ needed for MYJPBL should ! 1 because is actual specific humidity at the surface, and @@ -424,6 +473,7 @@ SUBROUTINE LSMRUC( & ett (i,j) = 0. sublim(i,j) = 0. sflx (i,j) = 0. + smf (i,j) = 0. evapl (i,j) = 0. prcpl (i,j) = 0. ENDDO @@ -438,6 +488,11 @@ SUBROUTINE LSMRUC( & !----------------------------------------------------------------- PRCPMS = 0. + newsnms = 0. + prcpncliq = 0. + prcpculiq = 0. + prcpncfr = 0. + prcpcufr = 0. DO J=jts,jte @@ -474,33 +529,77 @@ SUBROUTINE LSMRUC( & !-- (u and v are also at the half of first sigma level) CONFLX = Z3D(i,kms,j)*0.5 RHO = RHO3D(I,kms,J) -!--- 1*e-3 is to convert from mm/s to m/s +! -- initialize snow, graupel and ice fractions in frozen precip + snowrat = 0. + grauprat = 0. + icerat = 0. + curat = 0. IF(FRPCPN) THEN +#if (EM_CORE==1) + prcpncliq = rainncv(i,j)*(1.-frzfrac(i,j)) + prcpncfr = rainncv(i,j)*frzfrac(i,j) +!- apply the same frozen precipitation fraction to convective precip + prcpculiq = max(0.,(rainbl(i,j)-rainncv(i,j))*(1-frzfrac(i,j))) + prcpcufr = max(0.,(rainbl(i,j)-rainncv(i,j))*frzfrac(i,j)) +!--- 1*e-3 is to convert from mm/s to m/s + PRCPMS = (prcpncliq + prcpculiq)/DT*1.e-3 + NEWSNMS = (prcpncfr + prcpcufr)/DT*1.e-3 +! PRCPMS = (RAINBL(i,j)/DT*1.e-3)*(1-FRZFRAC(I,J)) +! NEWSNMS = (RAINBL(i,j)/DT*1.e-3)*FRZFRAC(I,J) + + if((prcpncfr + prcpcufr) > 0.) then +! -- calculate snow, graupel and ice fractions in falling frozen precip + snowrat=min(1.,max(0.,snowncv(i,j)/(prcpncfr + prcpcufr))) + grauprat=min(1.,max(0.,graupelncv(i,j)/(prcpncfr + prcpcufr))) + icerat=min(1.,max(0.,(prcpncfr-snowncv(i,j)-graupelncv(i,j)) & + /(prcpncfr + prcpcufr))) + curat=min(1.,max(0.,(prcpcufr/(prcpncfr + prcpcufr)))) + endif +#else PRCPMS = (RAINBL(i,j)/DT*1.e-3)*(1-FRZFRAC(I,J)) NEWSNMS = (RAINBL(i,j)/DT*1.e-3)*FRZFRAC(I,J) - ELSE + if(newsnms == 0.) then + snowrat = 0. + else + snowrat = min(1.,newsnms/(newsnms+prcpms)) + endif +#endif + + ELSE ! .not. FRPCPN if (tabs.le.273.15) then PRCPMS = 0. NEWSNMS = RAINBL(i,j)/DT*1.e-3 +!-- here no info about constituents of frozen precipitation, +!-- suppose it is all snow + snowrat = 1. else PRCPMS = RAINBL(i,j)/DT*1.e-3 NEWSNMS = 0. endif ENDIF + +! -- save time-step water equivalent of frozen precipitation in PRECIPFR array to be used in +! module_diagnostics + precipfr(i,j) = NEWSNMS * DT *1.e3 + if (myj) then QKMS=CHS(i,j) TKMS=CHS(i,j) else !--- convert exchange coeff QKMS to [m/s] QKMS=FLQC(I,J)/RHO/MAVAIL(I,J) - TKMS=FLHC(I,J)/RHO/CP +! TKMS=FLHC(I,J)/RHO/CP + TKMS=FLHC(I,J)/RHO/(CP*(1.+0.84*QVATM)) ! mynnsfc uses CPM endif !--- convert incoming snow and canwat from mm to m SNWE=SNOW(I,J)*1.E-3 SNHEI=SNOWH(I,J) CANWATR=CANWAT(I,J)*1.E-3 + SNOWFRAC=SNOWC(I,J) + RHOSNFALL=RHOSNF(I,J) + snowold(i,j)=snwe !----- zsmain(1)=0. zshalf(1)=0. @@ -573,7 +672,7 @@ SUBROUTINE LSMRUC( & ENDIF !--- initializing soil and surface properties CALL SOILVEGIN ( mosaic_lu, mosaic_soil,soilfrac,nscat,shdmin(i,j),shdmax(i,j),& - NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J), & + NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J)*0.01,& EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),RDLAI2D, & QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j ) IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN @@ -602,7 +701,7 @@ SUBROUTINE LSMRUC( & meltfactor = 2.0 do k=2,nzs - if(zsmain(k).ge.0.4) then + if(zsmain(k).ge.0.6) then NROOT=K goto 111 endif @@ -635,6 +734,14 @@ SUBROUTINE LSMRUC( & ENDIF !!*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS +! if(i.eq.397.and.j.eq.562) then +! print *,'RUC LSM - xland(i,j),xice(i,j),snow(i,j)',i,j,xland(i,j),xice(i,j),snow(i,j) +! endif + +#if (EM_CORE==1) + if(lakemodel==1. .and. lakemask(i,j)==1.) goto 2999 +!Lakes +#endif IF((XLAND(I,J)-1.5).GE.0.)THEN !-- Water @@ -644,6 +751,8 @@ SUBROUTINE LSMRUC( & SNOWH(I,J)=0.0 SNOWC(I,J)=0.0 LMAVAIL(I,J)=1.0 +! accumulated water equivalent of frozen precipitation over water [mm] + acsnow(i,j)=acsnow(i,j)+precipfr(i,j) ILAND=iswater ! ILAND=16 @@ -686,19 +795,24 @@ SUBROUTINE LSMRUC( & ILAND = isice ISOIL = 16 ZNT(I,J) = 0.011 - snoalb(i,j) = 0.8 - albbck(i,j) = 0.7 + snoalb(i,j) = 0.75 dqm = 1. ref = 1. qmin = 0. wilt = 0. emissl(i,j) = 1.0 + patmb=P8w(i,1,j)*1.e-2 + qvg (i,j) = QSN(SOILT(i,j),TBQ)/PATMB + qsg (i,j) = qvg(i,j) + qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j)) + DO K=1,NZS soilmois(i,k,j) = 1. smfr3d(i,k,j) = 1. sh2o(i,k,j) = 0. keepfr3dflag(i,k,j) = 0. + tso(i,k,j) = min(271.4,tso(i,k,j)) ENDDO ENDIF @@ -739,17 +853,29 @@ SUBROUTINE LSMRUC( & print *,'SMFRKEEP,KEEPFR ',SMFRKEEP,KEEPFR ENDIF + smtotold(i,j)=0. + do k=1,nzs-1 + smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(k))* & + (zshalf(k+1)-zshalf(k)) + enddo + + smtotold(i,j)=smtotold(i,j)+(qmin+soilm1d(nzs))* & + (zsmain(nzs)-zshalf(nzs)) + + canwatold(i,j) = canwatr !----------------------------------------------------------------- CALL SFCTMP (dt,ktau,conflx,i,j, & !--- input variables nzs,nddzs,nroot,meltfactor, & !added meltfactor iland,isoil,xland(i,j),ivgtyp(i,j),PRCPMS, & - NEWSNMS,SNWE,SNHEI,SNOWFRAC,RHOSN,RHONEWSN, & + NEWSNMS,SNWE,SNHEI,SNOWFRAC, & + RHOSN,RHONEWSN,RHOSNFALL, & + snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,RHO, & GLW(I,J),GSW(I,J),EMISSL(I,J), & QKMS,TKMS,PC(I,J),LMAVAIL(I,J), & canwatr,vegfra(I,J),alb(I,J),znt(I,J), & - snoalb(i,j),albbck(i,j), & !new + snoalb(i,j),albbck(i,j),lai(i,j), & !new myj,seaice(i,j),isice, & !--- soil fixed fields QWRTZ, & @@ -764,13 +890,56 @@ SUBROUTINE LSMRUC( & soilm1d,tso1d,smfrkeep,keepfr, & soilt(I,J),soilt1(i,j),tsnav(i,j),dew(I,J), & qvg(I,J),qsg(I,J),qcg(I,J),SMELT(I,J), & - SNOH(I,J),SNFLX(I,J),SNOM(I,J),ACSNOW(I,J), & - edir(I,J),ec(I,J),ett(I,J),qfx(I,J), & + SNOH(I,J),SNFLX(I,J),SNOM(I,J),SNOWFALLAC(I,J), & + ACSNOW(I,J),edir(I,J),ec(I,J),ett(I,J),qfx(I,J), & lh(I,J),hfx(I,J),sflx(I,J),sublim(I,J), & - evapl(I,J),prcpl(I,J),runoff1(I,J), & - runoff2(I,J),soilice,soiliqw,infiltrp) + evapl(I,J),prcpl(I,J),budget(i,j),runoff1(i,j), & + runoff2(I,J),soilice,soiliqw,infiltrp,smf(i,j)) !----------------------------------------------------------------- +! Fraction of cropland category in the grid box should not have soil moisture below +! wilting point during the growing season. +! Let's keep soil moisture 20% above wilting point for the fraction of grid box under +! croplands. +! This change violates LSM moisture budget, but +! can be considered as a compensation for irrigation not included into LSM. + + IF (lufrac(crop) > 0 .and. lai(i,j) > 1.1) THEN +! IF (ivgtyp(i,j) == crop .and. lai(i,j) > 1.1) THEN +! cropland + do k=1,nroot + cropsm=1.1*wilt - qmin + if(soilm1d(k) < cropsm*lufrac(crop)) then + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +print * ,'Soil moisture is below wilting in cropland category at time step',ktau & + ,'i,j,lufrac(crop),k,soilm1d(k),wilt,cropsm', & + i,j,lufrac(crop),k,soilm1d(k),wilt,cropsm + ENDIF + soilm1d(k) = cropsm*lufrac(crop) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print * ,'Added soil water to cropland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) + ENDIF + endif + enddo + + ELSEIF (ivgtyp(i,j) == natural .and. lai(i,j) > 0.7) THEN +! grassland: assume that 40% of grassland is irrigated cropland + do k=1,nroot + cropsm=1.2*wilt - qmin + if(soilm1d(k) < cropsm*lufrac(natural)*0.4) then + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +print * ,'Soil moisture is below wilting in mixed grassland/cropland category at time step',ktau & + ,'i,j,lufrac(natural),k,soilm1d(k),wilt', & + i,j,lufrac(natural),k,soilm1d(k),wilt + ENDIF + soilm1d(k) = cropsm * lufrac(natural)*0.4 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print * ,'Added soil water to grassland category, i,j,k,soilm1d(k)',i,j,k,soilm1d(k) + ENDIF + endif + enddo + ENDIF + !*** DIAGNOSTICS !--- available and maximum soil moisture content in the soil !--- domain @@ -792,9 +961,10 @@ SUBROUTINE LSMRUC( & !--- Convert the water unit into mm SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0 - UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*1000.0 + UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0 SMAVAIL (I,J) = SMAVAIL(I,J) * 1000. SMMAX (I,J) = SMMAX(I,J) * 1000. + smtotold (I,J) = smtotold(I,J) * 1000. do k=1,nzs @@ -842,6 +1012,7 @@ SUBROUTINE LSMRUC( & SNOW (i,j) = SNWE*1000. SNOWH (I,J) = SNHEI CANWAT (I,J) = CANWATR*1000. + INFILTR(I,J) = INFILTRP MAVAIL (i,j) = LMAVAIL(I,J) @@ -852,9 +1023,13 @@ SUBROUTINE LSMRUC( & SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT GRDFLX (I,J) = -1. * sflx(I,J) - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' QFX after change, LH ', i,j, QFX(i,j),LH(I,J) - ENDIF +! if(smf(i,j) .ne.0.) then +!tgs - SMF.NE.0. when there is phase change in the top soil layer +! The heat of soil water freezing/thawing is not computed explicitly +! and is responsible for the residual in the energy budget. +! print *,'Budget',budget(i,j),i,j,smf(i,j) +! endif + !--- SNOWC snow cover flag if(snowfrac > 0. .and. xice(i,j).ge.xice_threshold ) then SNOWFRAC = SNOWFRAC*XICE(I,J) @@ -862,16 +1037,73 @@ SUBROUTINE LSMRUC( & SNOWC(I,J)=SNOWFRAC +!--- RHOSNF - density of snowfall + RHOSNF(I,J)=RHOSNFALL + +! Accumulated moisture flux [kg/m^2] + SFCEVP (I,J) = SFCEVP (I,J) + QFX (I,J) * DT + +!TEST!!!! for test put heat budget term in GRDFLX + +! acbudget(i,j)=acbudget(i,j)+budget(i,j)-smf(i,j) +! GRDFLX (I,J) = acbudget(i,j) + +! if(smf(i,j) .ne.0.) then +!tgs - SMF.NE.0. when there is phase change in the top soil layer +! The heat of freezing/thawing of soil water is not computed explicitly +! and is responsible for the residual in the energy budget. +! endif + budget(i,j)=budget(i,j)-smf(i,j) + + ac=0. + as=0. + + ac=max(0.,canwat(i,j)-canwatold(i,j)) + as=max(0.,snwe-snowold(i,j)) + runoff2(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source + -qfx(i,j)*dt & +! -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 & + -runoff1(i,j)*dt*1.e3 & + -ac-as - (smavail(i,j)-smtotold(i,j)) + + waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source + -qfx(i,j)*dt & + -runoff1(i,j)*dt*1.e3-runoff2(i,j) & + -ac-as - (smavail(i,j)-smtotold(i,j)) + + +! waterbudget(i,j)=rainbl(i,j)-qfx(i,j)*dt-(smavail(i,j)-smtotold(i,j)) & + acwaterbudget(i,j)=acwaterbudget(i,j)+waterbudget(i,j) + +!!!!TEST use LH to check water budget +! GRDFLX (I,J) = waterbudget(i,j) + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'Smf=',smf(i,j),i,j + print *,'Budget',budget(i,j),i,j + print *,'RUNOFF2= ', i,j,runoff2(i,j) + print *,'Water budget ', i,j,waterbudget(i,j) + print *,'rainbl,qfx*dt,runoff1,smelt*dt*1.e3,smchange', & + i,j,rainbl(i,j),qfx(i,j)*dt,runoff1(i,j)*dt*1.e3, & + smelt(i,j)*dt*1.e3, & + (smavail(i,j)-smtotold(i,j)) + + print *,'SNOW-SNOWold',i,j,snwe,snowold(i,j) + print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) + print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) + print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) + ENDIF + -!--- get 3d soil fields IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'LAND, i,j,tso1d,soilm1d - end of time step', & - i,j,tso1d,soilm1d + print *,'LAND, i,j,tso1d,soilm1d,soilt - end of time step', & + i,j,tso1d,soilm1d,soilt(i,j) + print *,'LAND, QFX, HFX after SFCTMP', i,j,lh(i,j),hfx(i,j) ENDIF !--- end of a land or sea ice point ENDIF - +2999 continue ! lakes ENDDO ENDDO @@ -886,11 +1118,13 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & !--- input variables nzs,nddzs,nroot,meltfactor, & ILAND,ISOIL,XLAND,IVGTYP,PRCPMS, & - NEWSNMS,SNWE,SNHEI,SNOWFRAC,RHOSN,RHONEWSN, & + NEWSNMS,SNWE,SNHEI,SNOWFRAC, & + RHOSN,RHONEWSN,RHOSNFALL, & + snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,rho, & GLW,GSW,EMISS,QKMS,TKMS,PC, & MAVAIL,CST,VEGFRA,ALB,ZNT, & - ALB_SNOW,ALB_SNOW_FREE, & + ALB_SNOW,ALB_SNOW_FREE,lai, & MYJ,SEAICE,ISICE, & !--- soil fixed fields QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & @@ -902,10 +1136,10 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & snweprint,snheiprint,rsm, & soilm1d,ts1d,smfrkeep,keepfr,soilt,soilt1, & tsnav,dew,qvg,qsg,qcg, & - SMELT,SNOH,SNFLX,SNOM,ACSNOW, & + SMELT,SNOH,SNFLX,SNOM,SNOWFALLAC,ACSNOW, & edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, & - evapl,prcpl,runoff1,runoff2,soilice, & - soiliqw,infiltr) + evapl,prcpl,fltot,runoff1,runoff2,soilice, & + soiliqw,infiltr,smf) !----------------------------------------------------------------- IMPLICIT NONE !----------------------------------------------------------------- @@ -930,6 +1164,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & PC, & VEGFRA, & ALB_SNOW_FREE, & + lai, & SEAICE, & XLAND, & RHO, & @@ -977,7 +1212,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables @@ -988,6 +1223,9 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & SMFRKEEP REAL, DIMENSION( 1:nzs ) , & INTENT(INOUT) :: KEEPFR + + REAL, DIMENSION(1:NZS), INTENT(INOUT) :: SOILICE, & + SOILIQW INTEGER, INTENT(INOUT) :: ILAND,ISOIL @@ -1003,6 +1241,11 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & INFILTR, & RHOSN, & RHONEWSN, & + rhosnfall, & + snowrat, & + grauprat, & + icerat, & + curat, & SUBLIM, & PRCPL, & QVG, & @@ -1010,10 +1253,13 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & QCG, & QFX, & HFX, & + fltot, & + smf, & S, & RUNOFF1, & RUNOFF2, & ACSNOW, & + SNOWFALLAC, & SNWE, & SNHEI, & SMELT, & @@ -1029,14 +1275,40 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & tice, & rhosice, & capice, & - thdifice + thdifice, & + TS1DS, & + SOILM1DS, & + SMFRKEEPS, & + SOILIQWS, & + SOILICES, & + KEEPFRS !-------- 1-d variables - REAL, DIMENSION(1:NZS), INTENT(OUT) :: SOILICE, & - SOILIQW + REAL :: & + DEWS, & + MAVAILS, & + EDIR1s, & + EC1s, & + csts, & + ETT1s, & + EETAs, & + EVAPLs, & + INFILTRs, & + PRCPLS, & + QVGS, & + QSGS, & + QCGS, & + QFXS, & + HFXS, & + fltots, & + RUNOFF1S, & + RUNOFF2s, & + SS, & + SOILTs + - REAL, INTENT(OUT) :: RSM, & + REAL, INTENT(INOUT) :: RSM, & SNWEPRINT, & SNHEIPRINT !--- Local variables @@ -1047,10 +1319,13 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & RAINF, SNTH, NEWSN, PRCPMS, NEWSNMS , & T3, UPFLUX, XINET REAL :: snhei_crit, snhei_crit_newsn, keep_snow_albedo, SNOWFRACnewsn + REAL :: newsnowratio, dd1 + + REAL :: rhonewgr,rhonewice - REAL :: RNET,GSWNEW,EMISSN,ZNTSN + REAL :: RNET,GSWNEW,EMISSN,ZNTSN, GSWin REAL :: VEGFRAC - real :: cice, albice, albsn + real :: cice, albice, albsn, drip, dripsn, dripnosn !----------------------------------------------------------------- integer, parameter :: ilsnow=99 @@ -1061,12 +1336,17 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & ENDIF NEWSN=0. + newsnowratio = 0. snowfracnewsn=0. + if(snhei == 0.) snowfrac=0. + smelt = 0. RAINF = 0. RSM=0. + DD1=0. INFILTR=0. VEGFRAC=0.01*VEGFRA -! if(VEGFRAC.le.0.01) VEGFRAC=0. + dripsn = 0. + dripnosn = 0. !---initialize local arrays for sea ice do k=1,nzs @@ -1078,8 +1358,11 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & enddo GSWnew=GSW + GSWin=GSW/(1.-alb) ALBice=ALB_SNOW_FREE ALBsn=alb_snow + EMISSN = 0.98 + !--- sea ice properties !--- N.N Zubov "Arctic Ice" !--- no salinity dependence because we consider the ice pack @@ -1106,22 +1389,13 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE ENDIF - SNHEI = SNWE * 1000. / RHOSN -!-------------- - T3 = STBOLT*SOILT*SOILT*SOILT - UPFLUX = T3 *SOILT - XINET = EMISS*(GLW-UPFLUX) -! - at this point GSWnew=GSW - RNET = GSWnew + XINET - -!Calculate the amount (m) of fresh snow - if(snhei.gt.0.0081*1.e3/rhosn) then -!*** Correct snow density for current temperature (Koren et al. 1999) - BSN=delt/3600.*c1sn*exp(0.08*tsnav-c2sn*rhosn*1.e-3) +!*** Update snow density for current temperature (Koren et al. 1999) + BSN=delt/3600.*c1sn*exp(0.08*min(0.,tsnav)-c2sn*rhosn*1.e-3) if(bsn*snwe*100..lt.1.e-4) goto 777 XSN=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.) - rhosn=MIN(MAX(100.,XSN),400.) + rhosn=MIN(MAX(62.5,XSN),890.) +! rhosn=MIN(MAX(100.,XSN),400.) ! rhosn=MIN(MAX(50.,XSN),400.) 777 continue @@ -1131,43 +1405,58 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & endif newsn=newsnms*delt -!---- ACSNOW - accumulated snow water [kg m-2] +!---- ACSNOW - run-total snowfall water [mm] acsnow=acsnow+newsn*1.e3 IF(NEWSN.GT.0.) THEN ! IF(NEWSN.GE.1.E-8) THEN -!*** Calculate fresh snow density (t > -15C, else MIN value) -!*** Eq. 10 from Koren et al. (1999) IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *, 'THERE IS NEW SNOW, newsn', newsn ENDIF - if(tabs.lt.258.15) then -! rhonewsn=50. - rhonewsn=100. - else - rhonewsn=1.e3*max((0.10+0.0017*(Tabs-273.15+15.)**1.5) & - , 0.10) -! rhonewsn=1.e3*max((0.05+0.0017*(Tabs-273.15+15.)**1.5) & -! , 0.05) - rhonewsn=MIN(rhonewsn,400.) +!*** Calculate fresh snow density (t > -15C, else MIN value) +!*** Eq. 10 from Koren et al. (1999) +!--- old formulation from Koren (1999) +! if(tabs.lt.258.15) then +! rhonewsn=50. ! rhonewsn=100. - endif +! rhonewsn=62.5 + +! else +! rhonewsn=MIN(rhonewsn,400.) +! endif +!--- end of old formulation + +!--- 27 Feb 2014 - empirical formulations from John M. Brown + rhonewsn=min(250.,rhowater/max(4.179,(13.*tanh((274.15-Tabs)*0.3333)))) + rhonewgr=min(500.,rhowater/max(2.,(3.5*tanh((274.15-Tabs)*0.3333)))) + rhonewice=rhonewsn + +!--- compute density of "snowfall" from weighted contribution +! of snow, graupel and ice fractions + + rhosnfall = min(500.,max(76.9,(rhonewsn*snowrat + & + rhonewgr*grauprat + rhonewice*icerat + rhonewgr*curat))) +! from now on rhonewsn is the density of falling frozen precipitation + rhonewsn=rhosnfall !*** Define average snow density of the snow pack considering !*** the amount of fresh snow (eq. 9 in Koren et al.(1999) !*** without snow melt ) xsn=(rhosn*snwe+rhonewsn*newsn)/ & (snwe+newsn) - rhosn=MIN(MAX(100.,XSN),400.) + rhosn=MIN(MAX(76.9,XSN),500.) +! rhosn=MIN(MAX(100.,XSN),500.) ! rhosn=MIN(MAX(50.,XSN),400.) +!Update snow on the ground snwe=snwe+newsn - snhei=snwe*1.E3/rhosn - NEWSN=NEWSN*1.E3/rhonewsn - ENDIF + newsnowratio = min(1.,newsn/snwe) + snhei=snwe*rhowater/rhosn + NEWSN=NEWSN*rhowater/rhonewsn + ENDIF ! end NEWSN > 0. IF(PRCPMS.NE.0.) THEN @@ -1180,42 +1469,71 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & RAINF=1. ENDIF - IF(SNHEI.GT.0.0) THEN +! Update water intercepted by the canopy + drip = 0. + IF (vegfrac.GT.0.) THEN + dd1=CST+(DELT*PRCPMS+NEWSN*RHOnewSN*1.E-3)*vegfrac + CST=DD1 + IF(CST.GT.SAT) THEN + CST=SAT + DRIP=DD1-SAT + ENDIF + ENDIF + + IF(SNHEI.GT.0.0) THEN +!-- SNOW on the ground !--- Land-use category should be changed to snow/ice for grid points with snow>0 ILAND=ISICE - +! SNHEI_CRIT is a threshold for fractional snow SNHEI_CRIT=0.01601*1.e3/rhosn SNHEI_CRIT_newsn=0.0005*1.e3/rhosn -! SNOWFRAC=MIN(1.,SNHEI/SNHEI_CRIT) - SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) - if(newsn > 0. ) SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) -!--- EMISS = 0.98 for snow - if(newsn > 0. .and. SNOWFRACnewsn > 0.99) then - EMISS = 0.98 - else - EMISS = EMISS*(1.-snowfrac)+0.98*snowfrac - endif + SNOWFRAC=MIN(1.,SNHEI/SNHEI_CRIT) + + if(newsn > 0. ) then +! new snow + SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) + endif + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SNHEI_CRIT,SNOWFRAC,SNHEI_CRIT_newsn,SNOWFRACnewsn', & + SNHEI_CRIT,SNOWFRAC,SNHEI_CRIT_newsn,SNOWFRACnewsn + ENDIF !-- Set znt for snow from VEGPARM table (snow/ice landuse), except for !-- land-use types with higher roughness (forests, urban). !5mar12 IF(znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) - IF(znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) +! IF(newsn==0. .and. znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland) + IF(newsn.eq.0. .and. znt.lt.0.2 .and. IVGTYP.ne.isice) then + if( snhei .gt. 2.*SNHEI_CRIT .and. snhei .le. 4.*SNHEI_CRIT)then + znt=0.55*znt+0.45*z0tbl(iland) + elseif(snhei > 4.*SNHEI_CRIT) then + znt=0.2*znt+0.8*z0tbl(iland) + endif + ENDIF + KEEP_SNOW_ALBEDO = 0. IF (NEWSN > 0. .and. snowfracnewsn > 0.99) KEEP_SNOW_ALBEDO = 1. !--- GSWNEW in-coming solar for snow on land or on ice - GSWNEW=GSWnew/(1.-ALB) +! GSWNEW=GSWnew/(1.-ALB) +!-- Time to update snow and ice albedo IF(SEAICE .LT. 0.5) THEN !----- SNOW on soil !-- ALB dependence on snow depth - ALBsn = MAX(keep_snow_albedo*alb_snow, & - MIN((alb_snow_free + & - (alb_snow - alb_snow_free) * snowfrac), alb_snow)) -!28mar11 if canopy is covered with snow to its capacity and snow depth is -! higher than patchy snow treshold - then snow albedo is not less than 0.7 - if(cst.ge.sat .and. snowfrac .gt.0.99) albsn=max(alb_snow,0.7) +! ALB_SNOW across Canada's forested areas is very low - 0.27-0.35, this +! causes significant warm biases. Limiting ALB in these areas to be higher than 0.4 +! hwlps with these biases.. + ALBsn=max(0.4,alb_snow) +! ALBsn = MAX(keep_snow_albedo*alb_snow, & +! MIN((alb_snow_free + & +! (alb_snow - alb_snow_free) * snowfrac), alb_snow)) +!28mar11 if canopy is covered with snow to 95% of its capacity and snow depth is +! higher than patchy snow treshold - then snow albedo is not less than 0.55 +! (inspired by the flight from Fairbanks to Seatle) + if(cst.ge.0.95*sat .and. snowfrac .gt.0.99)then + albsn=max(alb_snow,0.55) + endif !-- ALB dependence on snow temperature. When snow temperature is !-- below critical value of -10C - no change to albedo. @@ -1223,7 +1541,8 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & !-- The minimum albedo at t=0C for snow on land is 15% less than !-- albedo of temperatures below -10C. if(albsn.lt.0.4) then - ALB=ALBsn +! ALB=ALBsn + ALBsn=max(0.4,alb_snow) else !-- change albedo when no fresh snow and snow albedo is higher than 0.5 ALB = MIN(ALBSN,MAX(ALBSN - 0.1*(soilt - 263.15)/ & @@ -1231,8 +1550,9 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & endif ELSE !----- SNOW on ice - ALBsn = MAX(keep_snow_albedo*alb_snow, & - MIN((albice + (alb_snow - albice) * snowfrac), alb_snow)) +! ALBsn = MAX(keep_snow_albedo*alb_snow, & +! MIN((albice + (alb_snow - albice) * snowfrac), alb_snow)) + ALBsn=alb_snow !-- ALB dependence on snow temperature. When snow temperature is !-- below critical value of -10C - no change to albedo. @@ -1247,29 +1567,145 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & ENDIF -!--- recompute absorbed solar radiation and net radiation -!--- for new value of albedo - gswnew=gswnew*(1.-alb) +!may 2014 - treat separately snow-free and snow-covered areas + if (snowfrac < 1.) then +! portion not covered with snow +! compute absorbed GSW for snow-free portion -! Recompute RNET with current GSWnew - RNET = GSWnew + XINET + gswnew=GSWin*(1.-alb_snow_free) +!-------------- + T3 = STBOLT*SOILT*SOILT*SOILT + UPFLUX = T3 *SOILT + XINET = EMISS*(GLW-UPFLUX) + RNET = GSWnew + XINET + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! if(i.eq.266.and.j.eq.447) then + print *,'Fractional snow - snowfrac=',snowfrac + print *,'Snowfrac<1 GSWnew -',GSWnew,'SOILT, RNET',soilt,rnet + ENDIF + if(SEAICE .LT. 0.5) then +! LAND + do k=1,nzs + soilm1ds(k) = soilm1d(k) + ts1ds(k) = ts1d(k) + smfrkeeps(k) = smfrkeep(k) + keepfrs(k) = keepfr(k) + soilices(k) = soilice(k) + soiliqws(k) = soiliqw(k) + enddo + soilts = soilt + qvgs = qvg + qsgs = qsg + qcgs = qcg + csts = cst + mavails = mavail + smelt=0. + + dripnosn=drip*(1.-snowfrac) + CALL SOIL( & +!--- input variables + i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & + PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & +!test PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & + EMISS,RNET,QKMS,TKMS,PC,csts,dripnosn, & + rho,vegfrac,lai, & +!--- soil fixed fields + QWRTZ,rhocs,dqm,qmin,ref,wilt, & + psis,bclh,ksat,sat,cn, & + zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + lv,CP,rovcp,G0,cw,stbolt,tabs, & + KQWRTZ,KICE,KWT, & +!--- output variables for snow-free portion + soilm1ds,ts1ds,smfrkeeps,keepfrs, & + dews,soilts,qvgs,qsgs,qcgs,edir1s,ec1s, & + ett1s,eetas,qfxs,hfxs,ss,evapls,prcpls,fltots,runoff1s, & + runoff2s,mavails,soilices,soiliqws, & + infiltrs,smf) + else +! SEA ICE + do k=1,nzs + ts1ds(k) = ts1d(k) + enddo + soilts = soilt + qvgs = qvg + qsgs = qsg + qcgs = qcg + smelt=0. + + CALL SICE( & +!--- input variables + i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & + PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & +! PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & + EMISS,RNET,QKMS,TKMS,rho, & +!--- sea ice parameters + tice,rhosice,capice,thdifice, & + zsmain,zshalf,DTDZS,DTDZS2,tbq, & +!--- constants + lv,CP,rovcp,cw,stbolt,tabs, & +!--- output variable + ts1ds,dews,soilts,qvgs,qsgs,qcgs, & + eetas,qfxs,hfxs,ss,evapls,prcpls,fltots & + ) + edir1 = eeta + ec1 = 0. + ett1 = 0. + runoff1 = prcpms + runoff2 = 0. + mavail = 1. + infiltr=0. + cst=0. + do k=1,nzs + soilm1d(k)=1. + soiliqw(k)=0. + soilice(k)=1. + smfrkeep(k)=1. + keepfr(k)=0. + enddo + endif ! seaice < 0.5 + +!return gswnew to incoming solar IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'SNOW - I,J,GSW,GSWnew,GLW,UPFLUX,ALB',& - i,j,GSW,GSWnew,GLW,UPFLUX,ALB +! if(i.eq.266.and.j.eq.447) then + print *,'gswnew,alb_snow_free,alb',gswnew,alb_snow_free,alb ENDIF +! gswnew=gswnew/(1.-alb_snow_free) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! if(i.eq.266.and.j.eq.447) then + print *,'Incoming GSWnew snowfrac<1 -',gswnew + ENDIF + endif ! snowfrac < 1. + +!--- recompute absorbed solar radiation and net radiation +!--- for updated value of snow albedo - ALB + gswnew=GSWin*(1.-alb) +! print *,'SNOW fraction GSWnew',gswnew,'alb=',alb +!-------------- + T3 = STBOLT*SOILT*SOILT*SOILT + UPFLUX = T3 *SOILT + XINET = EMISSN*(GLW-UPFLUX) + RNET = GSWnew + XINET + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! if(i.eq.266.and.j.eq.447) then + print *,'RNET=',rnet + print *,'SNOW - I,J,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB',& + i,j,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB + ENDIF if (SEAICE .LT. 0.5) then ! LAND + dripsn = drip*snowfrac CALL SNOWSOIL ( & !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & meltfactor,rhonewsn, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snowfrac, & RHOSN,PATM,QVATM,QCATM, & - GLW,GSWnew,EMISS,RNET,IVGTYP, & - QKMS,TKMS,PC,CST, & - RHO,VEGFRAC,ALB,ZNT, & + GLW,GSWnew,EMISSN,RNET,IVGTYP, & + QKMS,TKMS,PC,CST,dripsn, & + RHO,VEGFRAC,ALB,ZNT,lai, & MYJ, & !--- soil fixed fields QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & @@ -1282,7 +1718,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & soilm1d,ts1d,smfrkeep,keepfr, & dew,soilt,soilt1,tsnav,qvg,qsg,qcg, & SMELT,SNOH,SNFLX,SNOM,edir1,ec1,ett1,eeta, & - qfx,hfx,s,sublim,prcpl,runoff1,runoff2, & + qfx,hfx,s,sublim,prcpl,fltot,runoff1,runoff2, & mavail,soilice,soiliqw,infiltr ) else ! SEA ICE @@ -1291,7 +1727,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & meltfactor,rhonewsn, & ! new ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snowfrac, & RHOSN,PATM,QVATM,QCATM, & - GLW,GSWnew,EMISS,RNET, & + GLW,GSWnew,EMISSN,RNET, & QKMS,TKMS,RHO, & !--- sea ice parameters ALB,ZNT, & @@ -1303,7 +1739,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & ilnb,snweprint,snheiprint,rsm,ts1d, & dew,soilt,soilt1,tsnav,qvg,qsg,qcg, & SMELT,SNOH,SNFLX,SNOM,eeta, & - qfx,hfx,s,sublim,prcpl & + qfx,hfx,s,sublim,prcpl,fltot & ) edir1 = eeta ec1 = 0. @@ -1328,10 +1764,115 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & iland=ivgtyp endif - ELSE +! May 2014 - now combine snow covered and snow-free land fluxes, soil temp, moist, +! etc. + if (snowfrac < 1.) then + if(SEAICE .LT. 0.5) then +! LAND + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! print *,'SOILT snow on land', soilt +! print *,'SOILT on snow-free land', soilts + if(i.eq.416.and.j.eq.116) then + print *,' Ground flux on snow-covered land',i,j, s + print *,' Ground flux on snow-free land', i,j,ss + print *,' CSTS, CST', i,j,csts,cst + endif + ENDIF + do k=1,nzs + soilm1d(k) = soilm1ds(k)*(1.-snowfrac) + soilm1d(k)*snowfrac + ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac + smfrkeep(k) = smfrkeeps(k)*(1.-snowfrac) + smfrkeep(k)*snowfrac + keepfr(k) = keepfrs(k)*(1.-snowfrac) + keepfr(k)*snowfrac + soilice(k) = soilices(k)*(1.-snowfrac) + soilice(k)*snowfrac + soiliqw(k) = soiliqws(k)*(1.-snowfrac) + soiliqw(k)*snowfrac + enddo + dew = dews*(1.-snowfrac) + dew*snowfrac + soilt = soilts*(1.-snowfrac) + soilt*snowfrac + qvg = qvgs*(1.-snowfrac) + qvg*snowfrac + qsg = qsgs*(1.-snowfrac) + qsgs*snowfrac + qcg = qcgs*(1.-snowfrac) + qcgs*snowfrac + edir1 = edir1s*(1.-snowfrac) + edir1*snowfrac + ec1 = ec1s*(1.-snowfrac) + ec1*snowfrac + cst = csts*(1.-snowfrac) + cst*snowfrac + ett1 = ett1s*(1.-snowfrac) + ett1*snowfrac + eeta = eetas*(1.-snowfrac) + eeta*snowfrac + qfx = qfxs*(1.-snowfrac) + qfx*snowfrac + hfx = hfxs*(1.-snowfrac) + hfx*snowfrac + s = ss*(1.-snowfrac) + s*snowfrac + evapl = evapls*(1.-snowfrac) + evapl*snowfrac + sublim = sublim*snowfrac + prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac + fltot = fltots*(1.-snowfrac) + fltot*snowfrac +!alb + alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac + +! if(abs(fltot) > 2.) then +! print *,'i,j,fltot,snowfrac,fltots',fltot,snowfrac,fltots,i,j +! endif + runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac + runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac + smelt = smelt * snowfrac + snoh = snoh * snowfrac + snflx = snflx * snowfrac + snom = snom * snowfrac + mavail = mavails*(1.-snowfrac) + 1.*snowfrac + infiltr = infiltrs*(1.-snowfrac) + infiltr*snowfrac + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if(i.eq.266.and.j.eq.447) then + print *,' Ground flux combined', i,j, s + endif + print *,'SOILT combined on land', soilt + ENDIF + else +! SEA ICE +! Now combine fluxes for snow-free sea ice and snow-covered area + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SOILT snow on ice', soilt + ENDIF + do k=1,nzs + ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac + enddo + dew = dews*(1.-snowfrac) + dew*snowfrac + soilt = soilts*(1.-snowfrac) + soilt*snowfrac + qvg = qvgs*(1.-snowfrac) + qvg*snowfrac + qsg = qsgs*(1.-snowfrac) + qsgs*snowfrac + qcg = qcgs*(1.-snowfrac) + qcgs*snowfrac + eeta = eetas*(1.-snowfrac) + eeta*snowfrac + qfx = qfxs*(1.-snowfrac) + qfx*snowfrac + hfx = hfxs*(1.-snowfrac) + hfx*snowfrac + s = ss*(1.-snowfrac) + s*snowfrac + evapl = evapls*(1.-snowfrac) + evapl*snowfrac + prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac + fltot = fltots*(1.-snowfrac) + fltot*snowfrac +!alb + alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac + runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac + runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac + smelt = smelt * snowfrac + snoh = snoh * snowfrac + snflx = snflx * snowfrac + snom = snom * snowfrac + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SOILT combined on ice', soilt + ENDIF + endif + endif ! snowfrac < 1. + + ELSE !--- no snow snheiprint=0. snweprint=0. + smelt=0. + +!-------------- + T3 = STBOLT*SOILT*SOILT*SOILT + UPFLUX = T3 *SOILT + XINET = EMISS*(GLW-UPFLUX) + RNET = GSWnew + XINET + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'NO snow on the ground GSWnew -',GSWnew,'RNET=',rnet + ENDIF if(SEAICE .LT. 0.5) then ! LAND @@ -1339,7 +1880,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & - EMISS,RNET,QKMS,TKMS,PC,cst,rho,vegfrac, & + EMISS,RNET,QKMS,TKMS,PC,cst,drip,rho,vegfrac,lai, & !--- soil fixed fields QWRTZ,rhocs,dqm,qmin,ref,wilt, & psis,bclh,ksat,sat,cn, & @@ -1350,9 +1891,9 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & !--- output variables soilm1d,ts1d,smfrkeep,keepfr, & dew,soilt,qvg,qsg,qcg,edir1,ec1, & - ett1,eeta,qfx,hfx,s,evapl,prcpl,runoff1, & + ett1,eeta,qfx,hfx,s,evapl,prcpl,fltot,runoff1, & runoff2,mavail,soilice,soiliqw, & - infiltr) + infiltr,smf) else ! SEA ICE ! If current ice albedo is not the same as from the previous time step, then @@ -1373,7 +1914,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & lv,CP,rovcp,cw,stbolt,tabs, & !--- output variables ts1d,dew,soilt,qvg,qsg,qcg, & - eeta,qfx,hfx,s,evapl,prcpl & + eeta,qfx,hfx,s,evapl,prcpl,fltot & ) edir1 = eeta ec1 = 0. @@ -1393,9 +1934,9 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & endif ENDIF -! ENDIF +! run-total accumulated snow based on snowfall and snowmelt in [m] -! + snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio)) ! RETURN ! END @@ -1436,7 +1977,7 @@ SUBROUTINE SOIL ( & i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,& PRCPMS,RAINF,PATM,QVATM,QCATM, & GLW,GSW,EMISS,RNET, & - QKMS,TKMS,PC,cst,rho,vegfrac, & + QKMS,TKMS,PC,cst,drip,rho,vegfrac,lai, & !--- soil fixed fields QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq, & @@ -1447,8 +1988,8 @@ SUBROUTINE SOIL ( & soilmois,tso,smfrkeep,keepfr, & dew,soilt,qvg,qsg,qcg, & edir1,ec1,ett1,eeta,qfx,hfx,s,evapl, & - prcpl,runoff1,runoff2,mavail,soilice, & - soiliqw,infiltrp) + prcpl,fltot,runoff1,runoff2,mavail,soilice, & + soiliqw,infiltrp,smf) !************************************************************* ! Energy and moisture budget for vegetated surfaces @@ -1529,6 +2070,7 @@ SUBROUTINE SOIL ( & RHO, & PC, & VEGFRAC, & + lai, & QKMS, & TKMS @@ -1559,7 +2101,7 @@ SUBROUTINE SOIL ( & REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables @@ -1576,6 +2118,7 @@ SUBROUTINE SOIL ( & REAL, & INTENT(INOUT) :: DEW, & CST, & + DRIP, & EDIR1, & EC1, & ETT1, & @@ -1609,13 +2152,13 @@ SUBROUTINE SOIL ( & q1,ras,rhoice,sph , & trans,zn,ci,cvw,tln,tavln,pi , & DD1,CMC2MS,DRYCAN,WETCAN , & - INFMAX,RIW + INFMAX,RIW, X REAL, DIMENSION(1:NZS) :: transp,cap,diffu,hydro , & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - REAL :: drip + REAL :: soiltold,smf INTEGER :: nzs1,nzs2,k @@ -1631,6 +2174,12 @@ SUBROUTINE SOIL ( & ! SAT=0.0004 prcpl=prcpms + smf=0. + soiltold = soilt + + wetcan=0. + drycan=1. + !--- Initializing local arrays DO K=1,NZS TRANSP (K)=0. @@ -1745,8 +2294,8 @@ SUBROUTINE SOIL ( & !******************************************************************** !--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW - DRIP=0. - DD1=0. +! DRIP=0. +! DD1=0. FQ=QKMS @@ -1756,33 +2305,37 @@ SUBROUTINE SOIL ( & IF(QVATM.GE.QSG)THEN DEW=FQ*(QVATM-QSG) ENDIF - IF(DEW.NE.0.)THEN - DD1=CST+DELT*(PRCPMS +DEW*RAS)*vegfrac - ELSE - DD1=CST+ & - DELT*PRCPMS*vegfrac+RAS*FQ*(QVATM-QSG) & - *(CST/SAT)**CN - ENDIF - IF(DD1.LT.0.) DD1=0. - if(vegfrac.eq.0.)then - cst=0. - drip=0. - endif - IF (vegfrac.GT.0.) THEN - CST=DD1 - IF(CST.GT.SAT) THEN - CST=SAT - DRIP=DD1-SAT - ENDIF - ENDIF +! IF(DEW.NE.0.)THEN +! DD1=CST+DELT*(PRCPMS +DEW*RAS) +! ELSE +! DD1=CST+ & +! DELT*(PRCPMS+RAS*FQ*(QVATM-QSG) & +! *(CST/SAT)**CN) +! ENDIF +! DD1=CST+DELT*PRCPMS + +! IF(DD1.LT.0.) DD1=0. +! if(vegfrac.eq.0.)then +! cst=0. +! drip=0. +! endif +! IF (vegfrac.GT.0.) THEN +! CST=DD1 +! IF(CST.GT.SAT) THEN +! CST=SAT +! DRIP=DD1-SAT +! ENDIF +! ENDIF +! !--- WETCAN is the fraction of vegetated area covered by canopy !--- water, and DRYCAN is the fraction of vegetated area where !--- transpiration may take place. WETCAN=(CST/SAT)**CN DRYCAN=1.-WETCAN + if(lai > 1.) wetcan=wetcan/lai !************************************************************** ! TRANSF computes transpiration function @@ -1820,7 +2373,7 @@ SUBROUTINE SOIL ( & !--- constants xlv,CP,G0_P,cvw,stbolt, & !--- output variables - tso,soilt,qvg,qsg,qcg) + tso,soilt,qvg,qsg,qcg,x) !************************************************************************ @@ -1846,7 +2399,7 @@ SUBROUTINE SOIL ( & enddo ENDIF -!-- Recalculating of volumetric content of frozen water in soil +!-- Recalculate volumetric content of frozen water in soil DO K=1,NZS !- main levels tln=log(tso(k)/273.15) @@ -1879,7 +2432,6 @@ SUBROUTINE SOIL ( & zsmain,zshalf,diffu,hydro, & QSG,QVG,QCG,QCATM,QVATM,-PRCPMS, & QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC, & -! QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC, & !-- soil properties DQM,QMIN,REF,KSAT,RAS,INFMAX, & !-- output @@ -1904,15 +2456,19 @@ SUBROUTINE SOIL ( & endif endif enddo + !--- THE DIAGNOSTICS OF SURFACE FLUXES - T3 = STBOLT*SOILT*SOILT*SOILT - UPFLUX = T3 *SOILT + T3 = STBOLT*SOILTold*SOILTold*SOILTold + UPFLUX = T3 * 0.5*(SOILTold+SOILT) XINET = EMISS*(GLW-UPFLUX) - RNET = GSW + XINET - HFT=-TKMS*CP*RHO*(TABS-SOILT) & +! RNET = GSW + XINET + HFT=-TKMS*CP*RHO*(TABS-SOILT) + HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001/Patm)**ROVCP Q1=-QKMS*RAS*(QVATM - QSG) + + CMC2MS = 0. IF (Q1.LE.0.) THEN ! --- condensation EC1=0. @@ -1920,29 +2476,82 @@ SUBROUTINE SOIL ( & ETT1=0. !-- moisture flux for coupling with MYJ PBL EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then + print *,'Cond MYJ EETA',eeta,eeta*xlv + ENDIF QFX= XLV*EETA !-- actual moisture flux from RUC LSM EETA= - RHO*DEW + CST=CST+DELT*DEW*RAS * vegfrac + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then + print *,'Cond RUC LSM EETA',EETA,eeta*xlv + ENDIF ELSE ! --- evaporation - EDIR1 =-(1.-vegfrac)*QKMS*RAS* & + EDIR1 =-(1.-vegfrac)*QKMS*RAS* & (QVATM-QVG) - EC1 = Q1 * WETCAN - CMC2MS=CST/DELT - if(EC1.gt.CMC2MS*RAS) cst=0. - EC1=MIN(CMC2MS*RAS,EC1) + CMC2MS=CST/DELT*RAS + EC1 = Q1 * WETCAN*vegfrac + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then + print *,'CST before update=',cst + print *,'EC1=',EC1,'CMC2MS=',CMC2MS + ENDIF + ENDIF + + CST=max(0.,CST-EC1 * DELT) + +! if (EC1 > CMC2MS) then +!test EC1 = min(cmc2ms,ec1) +! CST = 0. +! endif + !-- moisture flux for coupling with MYJ PBL EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 -! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ QFX= XLV * EETA + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then + print *,'QKMS,RAS,QVATM/(1.+QVATM),QVG/(1.+QVG),QSG ', & + QKMS,RAS,QVATM/(1.+QVATM),QVG/(1.+QVG),QSG + print *,'Q1*(1.-vegfrac),EDIR1',Q1*(1.-vegfrac),EDIR1 + print *,'CST,WETCAN,DRYCAN',CST,WETCAN,DRYCAN + print *,'EC1=',EC1,'ETT1=',ETT1,'CMC2MS=',CMC2MS,'CMC2MS*ras=',CMC2MS*ras + print *,'MYJ EETA',eeta,eeta*xlv + ENDIF !-- actual moisture flux from RUC LSM EETA = (EDIR1 + EC1 + ETT1)*1.E3 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! IF(i.eq.440.and.j.eq.180 .or. qfx.gt.1000..or.i.eq.417.and.j.eq.540) then + print *,'RUC LSM EETA',EETA,eeta*xlv + ENDIF ENDIF + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'potential temp HFT ',HFT + print *,'abs temp HFX ',HFX + ENDIF EVAPL=EETA S=THDIF(1)*CAP(1)*DZSTOP*(TSO(1)-TSO(2)) - HFX=HFT - FLTOT=RNET-HFT-QFX-S +! Energy budget + FLTOT=RNET-HFT-XLV*EETA-S-X + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! IF(i.eq.440.and.j.eq.180 .or. qfx.gt.1000..or.i.eq.417.and.j.eq.540) then + print *,'SOIL - FLTOT,RNET,HFT,QFX,S,X=',i,j,FLTOT,RNET,HFT,XLV*EETA,s,x + print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,cmc2ms*ras,vegfrac',& + edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,cmc2ms*ras,vegfrac + ENDIF + if(detal(1) .ne. 0.) then +! SMF - energy of phase change in the first soil layer +! smf=xlmelt*1.e3*(soiliqwm(1)-soiliqwmold(1))/delt + smf=fltot + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'detal(1),xlmelt,soiliqwm(1),delt',detal(1),xlmelt,soiliqwm(1),delt + print *,'Implicit phase change in the first layer - smf=',smf + ENDIF + endif + 222 CONTINUE @@ -1950,10 +2559,6 @@ SUBROUTINE SOIL ( & 1133 FORMAT(I7,8E12.4) 123 format(i6,f6.2,7f8.1) 122 FORMAT(1X,2I3,6F8.1,F8.3,F8.2) - - -! RETURN -! END !------------------------------------------------------------------- END SUBROUTINE SOIL !------------------------------------------------------------------- @@ -1970,7 +2575,7 @@ SUBROUTINE SICE ( & xlv,CP,rovcp,cw,stbolt,tabs, & !--- output variables tso,dew,soilt,qvg,qsg,qcg, & - eeta,qfx,hfx,s,evapl,prcpl & + eeta,qfx,hfx,s,evapl,prcpl,fltot & ) !***************************************************************** @@ -2020,7 +2625,7 @@ SUBROUTINE SICE ( & REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables @@ -2051,9 +2656,9 @@ SUBROUTINE SICE ( & REAL :: FKT,D1,D2,D9,D10,DID,R211,R21,R22,R6,R7,D11 , & PI,H,FKQ,R210,AA,BB,PP,Q1,QS1,TS1,TQ2,TX2 , & - TDENOM + TDENOM,QGOLD,SNOH - REAL :: AA1,RHCS + REAL :: AA1,RHCS, icemelt REAL, DIMENSION(1:NZS) :: cotso,rhtso @@ -2132,6 +2737,7 @@ SUBROUTINE SICE ( & print *,'tn,aa1,bb,pp,fkq,r210', & tn,aa1,bb,pp,fkq,r210 ENDIF + QGOLD=QSG CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) !--- it is saturation over sea ice QVG=QS1 @@ -2150,35 +2756,66 @@ SUBROUTINE SICE ( & DEW=0. !--- THE DIAGNOSTICS OF SURFACE FLUXES - T3 = STBOLT*SOILT*SOILT*SOILT - UPFLUX = T3 *SOILT + T3 = STBOLT*TN*TN*TN + UPFLUX = T3 *0.5*(TN+SOILT) XINET = EMISS*(GLW-UPFLUX) - RNET = GSW + XINET - HFT=-TKMS*CP*RHO*(TABS-SOILT) & +! RNET = GSW + XINET + HFT=-TKMS*CP*RHO*(TABS-SOILT) + HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001/Patm)**ROVCP Q1=-QKMS*RAS*(QVATM - QSG) IF (Q1.LE.0.) THEN ! --- condensation !-- moisture flux for coupling with MYJ PBL EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'MYJ EETA',eeta + ENDIF QFX= XLS*EETA !-- actual moisture flux from RUC LSM DEW=QKMS*(QVATM-QSG) EETA= - RHO*DEW + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'RUC LSM EETA',eeta + ENDIF ELSE ! --- evaporation !-- moisture flux for coupling with MYJ PBL EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 -! EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'MYJ EETA',eeta + ENDIF ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ QFX= XLS * EETA !-- actual moisture flux from RUC LSM -! EETA = Q1*1.E3 + EETA = Q1*1.E3 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'RUC LSM EETA',eeta + ENDIF ENDIF EVAPL=EETA + S=THDIFICE(1)*CAPICE(1)*DZSTOP*(TSO(1)-TSO(2)) - HFX=HFT - FLTOT=RNET-HFT-QFX-S +! heat storage in surface layer + SNOH=0. +! There is ice melt + X= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + & + XLS*rho*r211*(QSG-QGOLD) + X=X & +! "heat" from rain + -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + +!-- excess energy spent on sea ice melt + icemelt=RNET-XLS*EETA -HFT -S -X + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'icemelt=',icemelt + ENDIF + + FLTOT=RNET-XLS*EETA-HFT-S-X-icemelt + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SICE - FLTOT,RNET,HFT,QFX,S,SNOH,X=', & + FLTOT,RNET,HFT,XLS*EETA,s,icemelt,X + ENDIF !------------------------------------------------------------------- END SUBROUTINE SICE @@ -2194,7 +2831,7 @@ SUBROUTINE SNOWSOIL ( & RHOSN, & PATM,QVATM,QCATM, & GLW,GSW,EMISS,RNET,IVGTYP, & - QKMS,TKMS,PC,cst,rho,vegfrac,alb,znt, & + QKMS,TKMS,PC,cst,drip,rho,vegfrac,alb,znt,lai, & MYJ, & !--- soil fixed fields QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat, & @@ -2208,7 +2845,7 @@ SUBROUTINE SNOWSOIL ( & dew,soilt,soilt1,tsnav, & qvg,qsg,qcg,SMELT,SNOH,SNFLX,SNOM, & edir1,ec1,ett1,eeta,qfx,hfx,s,sublim, & - prcpl,runoff1,runoff2,mavail,soilice, & + prcpl,fltot,runoff1,runoff2,mavail,soilice, & soiliqw,infiltrp ) !*************************************************************** @@ -2304,6 +2941,7 @@ SUBROUTINE SNOWSOIL ( & RHO, & PC, & VEGFRAC, & + lai, & QKMS, & TKMS @@ -2336,7 +2974,7 @@ SUBROUTINE SNOWSOIL ( & REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables @@ -2357,6 +2995,7 @@ SUBROUTINE SNOWSOIL ( & REAL , & INTENT(INOUT) :: DEW, & CST, & + DRIP, & EDIR1, & EC1, & ETT1, & @@ -2416,9 +3055,9 @@ SUBROUTINE SNOWSOIL ( & thdif,tranf,tav,soilmoism , & soilicem,soiliqwm,detal , & fwsat,lwsat,told,smold - REAL :: drip + REAL :: soiltold, qgold - REAL :: RNET + REAL :: RNET, X !----------------------------------------------------------------- @@ -2439,14 +3078,24 @@ SUBROUTINE SNOWSOIL ( & !--- the top soil layer. SNTH is computed using snwe=0.016 m, and !--- equals 4 cm for snow density 400 kg/m^3. +!save SOILT and QVG + soiltold=soilt + qgold=qsg + + x=0. + ! increase thinkness of top snow layer from 3 cm SWE to 5 cm SWE DELTSN=0.05*1.e3/rhosn snth=0.01601*1.e3/rhosn ! when the snow depth is marginally higher than DELTSN, ! reset DELTSN to half of snow depth. - IF(SNHEI.GE.DELTSN+SNTH) THEN - if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) + IF(SNHEI.GE.DELTSN.and.SNHEI.lt.DELTSN+SNTH) THEN + deltsn=0.5*snhei +! if(snhei-deltsn-snth.lt.snth) deltsn=0.5*snhei + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'DELTSN is changed,deltsn,snhei,snth',i,j,deltsn,snhei,snth + ENDIF ENDIF RHOICE=900. @@ -2577,9 +3226,9 @@ SUBROUTINE SNOWSOIL ( & !******************************************************************** !--- CALCULATION OF CANOPY WATER (Smirnova et al., 1996, EQ.16) AND DEW - DRIP=0. +! DRIP=0. SMELT=0. - DD1=0. +! DD1=0. H=1. FQ=QKMS @@ -2592,45 +3241,51 @@ SUBROUTINE SNOWSOIL ( & UMVEG=1.-vegfrac EPOT = -FQ*(QVATM-QSG) - IF(vegfrac.EQ.0.) then - cst=0. - drip=0. - ELSE - IF(EPOT.GE.0.) THEN -! Evaporation -! DD1=CST+(NEWSNOW*RHOSN*1.E-3 & - DD1=CST+NEWSNOW*RHOnewSN*1.E-3*vegfrac & -!-- this change will not let liquid waer be intercepted by the canopy.... - -DELT*RAS*EPOT & -! -DELT*(-PRCPMS+RAS*EPOT & - *(CST/SAT)**CN - ELSE -! Sublimation - DEW = - EPOT -! DD1=CST+(NEWSNOW*RHOSN*1.E-3+delt*( & - DD1=CST+(NEWSNOW*RHOnewSN*1.E-3+delt*( & -! DD1=CST+(NEWSNOW*RHOSN*1.E-3+delt*(PRCPMS & - +DEW*RAS)) *vegfrac - ENDIF - - IF(DD1.LT.0.) DD1=0. - IF (vegfrac.GT.0.) THEN - CST=DD1 - IF(CST.GT.SAT) THEN - CST=SAT - DRIP=DD1-SAT - ENDIF - ENDIF +! IF(vegfrac.EQ.0.) then +! cst=0. +! drip=0. +! ELSE +! IF(EPOT.GE.0.) THEN +!! DD1=CST+ NEWSNOW*RHOnewSN*1.E-3 & +!! -DELT*RAS*EPOT*(CST/SAT)**CN +! IF ( 1==2 ) THEN +! print *,'DD1=',dd1,cst,sat +! ENDIF +! ELSE + +!! Sublimation +! DEW = - EPOT +!! DD1=CST+(NEWSNOW*RHOnewSN*1.E-3+delt*DEW*RAS) +! IF ( 1==2 ) THEN +! print *,'Sublimation DD1=',dd1,cst,sat +! ENDIF +! ENDIF + +! DD1=CST+NEWSNOW*RHOnewSN*1.E-3 + +!! IF(DD1.LT.0.) DD1=0. +! IF (vegfrac.GT.0.) THEN +! CST=DD1 +! IF(CST.GT.SAT) THEN +! CST=SAT +! DRIP=DD1-SAT +! ENDIF +! ENDIF !--- With vegetation part of NEWSNOW can be intercepted by canopy until !--- the saturation is reached. After the canopy saturation is reached !--- DRIP in the solid form will be added to SNOW cover. - SNWE=SNHEI*RHOSN*1.e-3-vegfrac*NEWSNOW*RHOnewSN*1.E-3 & + SNWE=SNWE-vegfrac*NEWSNOW*RHOnewSN*1.E-3 & +! SNWE=SNHEI*RHOSN*1.e-3-vegfrac*NEWSNOW*RHOnewSN*1.E-3 & + DRIP - ENDIF + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SNWE after subtracting intercepted snow - snwe=',snwe,vegfrac,cst + ENDIF + +! ENDIF ! vegfrac=0. DRIP=0. SNHEI=SNWE*1.e3/RHOSN @@ -2642,11 +3297,11 @@ SUBROUTINE SNOWSOIL ( & IF(EPDT.gt.0. .and. SNWEPR.LE.EPDT) THEN BETA=SNWEPR/max(1.e-8,EPDT) SNWE=0. - SNHEI=0. ENDIF WETCAN=(CST/SAT)**CN DRYCAN=1.-WETCAN + if(lai > 1.) wetcan=wetcan/lai !************************************************************** ! TRANSF computes transpiration function @@ -2692,21 +3347,20 @@ SUBROUTINE SNOWSOIL ( & !--- output variables snweprint,snheiprint,rsm, & tso,soilt,soilt1,tsnav,qvg,qsg,qcg, & - smelt,snoh,snflx,ilnb) + smelt,snoh,snflx,ilnb,x) !************************************************************************ !--- RECALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW DEW=0. ETT1=0. PP=PATM*1.E3 - QSG= QSN(SOILT,TBQ)/PP EPOT = -FQ*(QVATM-QSG) - IF(EPOT.GE.0.) THEN + IF(EPOT.GT.0.) THEN ! Evaporation DO K=1,NROOT TRANSP(K)=vegfrac*RAS*FQ*(QVATM-QSG) & *PC*tranf(K)*DRYCAN/zshalf(NROOT+1) - IF(TRANSP(K).GT.0.) TRANSP(K)=0. +! IF(TRANSP(K).GT.0.) TRANSP(K)=0. ETT1=ETT1-TRANSP(K) ENDDO DO k=nroot+1,nzs @@ -2766,9 +3420,6 @@ SUBROUTINE SNOWSOIL ( & !-- Restore land-use parameters if all snow is melted IF(SNHEI.EQ.0.) then tsnav=soilt-273.15 - smelt=smelt+snwe/delt - rsm=0. -! snwe=0. ENDIF ! 21apr2009 @@ -2795,12 +3446,19 @@ SUBROUTINE SNOWSOIL ( & enddo !--- THE DIAGNOSTICS OF SURFACE FLUXES - T3 = STBOLT*SOILT*SOILT*SOILT - UPFLUX = T3 *SOILT + T3 = STBOLT*SOILTold*SOILTold*SOILTold + UPFLUX = T3 *0.5*(SOILTold+SOILT) XINET = EMISS*(GLW-UPFLUX) - RNET = GSW + XINET - HFT=-TKMS*CP*RHO*(TABS-SOILT) & +! RNET = GSW + XINET + HFX=-TKMS*CP*RHO*(TABS-SOILT) & *(P1000mb*0.00001/Patm)**ROVCP + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'potential temp HFX',hfx + ENDIF + HFT=-TKMS*CP*RHO*(TABS-SOILT) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'abs temp HFX',hft + ENDIF Q1 = - FQ*RAS* (QVATM - QSG) IF (Q1.LT.0.) THEN @@ -2811,32 +3469,57 @@ SUBROUTINE SNOWSOIL ( & ! --- condensation !-- moisture flux for coupling with MYJ PBL EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'MYJ EETA cond', EETA + ENDIF QFX= XLVm*EETA !-- actual moisture flux from RUC LSM DEW=QKMS*(QVATM-QSG) EETA= - RHO*DEW + CST=CST+DELT*DEW*RAS * vegfrac + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'RUC LSM EETA cond',EETA + ENDIF ELSE ! --- evaporation EDIR1 = Q1*UMVEG *BETA - EC1 = Q1 * WETCAN - CMC2MS=CST/DELT - if(EC1.gt.CMC2MS*RAS) cst=0. - EC1=MIN(CMC2MS*RAS,EC1) + CMC2MS=CST/DELT*RAS + EC1 = Q1 * WETCAN * vegfrac + + CST=max(0.,CST-EC1 * DELT) + +! if(EC1 > CMC2MS) then +! EC1 = min(cmc2ms,ec1) +! CST = 0. +! endif + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print*,'Q1,umveg,beta',Q1,umveg,beta + print *,'wetcan,vegfrac',wetcan,vegfrac + print *,'EC1,CMC2MS',EC1,CMC2MS + ENDIF + !-- moisture flux for coupling with MYJ PBL - EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3 -! EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3 + EETA=-(QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3)*BETA + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'MYJ EETA', EETA*XLVm,EETA + ENDIF ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ QFX= XLVm * EETA !-- actual moisture flux from RUC LSM EETA = (EDIR1 + EC1 + ETT1)*1.E3 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'RUC LSM EETA',EETA*XLVm,EETA + ENDIF ENDIF - if(snhei.gt.0.)then - s=snflx - else - s=THDIF(1)*CAP(1)*dzstop*(tso(1)-tso(2)) - endif - HFX=HFT - FLTOT=RNET-HFT-QFX-S-SNOH + S=SNFLX +! Energy budget + FLTOT=RNET-HFT-XLVm*EETA-S-SNOH-x + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SNOWSOIL - FLTOT,RNET,HFT,QFX,S,SNOH,X=',FLTOT,RNET,HFT,XLVm*EETA,s,SNOH,X + print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,cmc2ms*ras,vegfrac,beta',& + edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,cmc2ms*ras,vegfrac,beta + ENDIF 222 CONTINUE @@ -2845,9 +3528,6 @@ SUBROUTINE SNOWSOIL ( & 123 format(i6,f6.2,7f8.1) 122 FORMAT(1X,2I3,6F8.1,F8.3,F8.2) - -! RETURN -! END !------------------------------------------------------------------- END SUBROUTINE SNOWSOIL !------------------------------------------------------------------- @@ -2869,7 +3549,7 @@ SUBROUTINE SNOWSEAICE( & ilnb,snweprint,snheiprint,rsm,tso, & dew,soilt,soilt1,tsnav,qvg,qsg,qcg, & SMELT,SNOH,SNFLX,SNOM,eeta, & - qfx,hfx,s,sublim,prcpl & + qfx,hfx,s,sublim,prcpl,fltot & ) !*************************************************************** ! Solving energy budget for snow on sea ice and heat diffusion @@ -2920,7 +3600,7 @@ SUBROUTINE SNOWSEAICE( & REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables !-------- 3-d soil moisture and temperature @@ -2986,8 +3666,8 @@ SUBROUTINE SNOWSEAICE( & SNODIF,SOH,TNOLD,QGOLD,SNOHGNEW REAL, DIMENSION(1:NZS) :: cotso,rhtso - REAL :: RNET,rsmfrac,soiltfrac,hsn - integer :: nmelt + REAL :: RNET,rsmfrac,soiltfrac,hsn,icemelt,rr + integer :: nmelt !----------------------------------------------------------------- @@ -3013,8 +3693,13 @@ SUBROUTINE SNOWSEAICE( & ! when the snow depth is marginlly higher than DELTSN, ! reset DELTSN to half of snow depth. - IF(SNHEI.GE.DELTSN+SNTH) THEN - if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) + IF(SNHEI.GE.DELTSN.and.SNHEI.lt.DELTSN+SNTH) THEN + deltsn=0.5*snhei +! if(snhei-deltsn-snth.lt.snth) deltsn=0.5*snhei + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'DELTSN ICE is changed,deltsn,snhei,snth', & + i,j, deltsn,snhei,snth + ENDIF ENDIF @@ -3042,13 +3727,12 @@ SUBROUTINE SNOWSEAICE( & RSMFRAC = 0. fsn=1. fso=0. - hsn=snhei cvw=cw NZS1=NZS-1 NZS2=NZS-2 - QGOLD=QVG + QGOLD=QSG TNOLD=SOILT DZSTOP=1./(ZSMAIN(2)-ZSMAIN(1)) @@ -3072,10 +3756,9 @@ SUBROUTINE SNOWSEAICE( & BETA=1. EPOT = -FQ*(QVATM-QSG) EPDT = EPOT * RAS *DELT - IF(SNWEPR.LE.EPDT) THEN + IF(EPDT.GT.0. .and. SNWEPR.LE.EPDT) THEN BETA=SNWEPR/max(1.e-8,EPDT) SNWE=0. - SNHEI=0. ENDIF !****************************************************************************** @@ -3148,7 +3831,7 @@ SUBROUTINE SNOWSEAICE( & endif ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GE.0.) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first sea ice layer. fsn=SNHEI/(SNHEI+zsmain(2)) @@ -3156,7 +3839,7 @@ SUBROUTINE SNOWSEAICE( & soilt1=tso(1) tsob=tso(2) snprim=SNHEI+zsmain(2) - XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) + XSN = DELT/2./(zshalf(3)+0.5*snprim) DDZSN = XSN /snprim X1SN = DDZSN * (fsn*thdifsn+fso*thdifice(1)) X2=DTDZS(2)*THDIFICE(2) @@ -3225,14 +3908,10 @@ SUBROUTINE SNOWSEAICE( & R22SN = R22 D1SN = D1 D2SN = D2 - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' SNHEI = 0, D9SN,R22SN,D1SN,D2SN: ',D9SN,R22SN,D1SN,D2SN - ENDIF ENDIF + !---- TDENOM for snow -!18apr08 - the iteration start point - 212 continue TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7 & +RAINF*CVW*PRCPMS & +RHOnewCSN*NEWSNOW/DELT @@ -3245,16 +3924,18 @@ SUBROUTINE SNOWSEAICE( & +R210*QVG)+D11+D9SN*(D2SN+R22SN*TN) & +RAINF*CVW*PRCPMS*max(273.15,TABS) & + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS) & -!18apr08 - add heat of snow phase change - -SNOH & )/TDENOM AA1=AA PP=PATM*1.E3 AA1=AA1/PP +!18apr08 - the iteration start point + 212 continue + BB=BB-SNOH/TDENOM IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *,'VILKA-SNOW on SEAICE' print *,'tn,aa1,bb,pp,fkq,r210', & tn,aa1,bb,pp,fkq,r210 + print *,'TABS,QVATM,TN,QVG=',TABS,QVATM,TN,QVG ENDIF CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) @@ -3274,7 +3955,7 @@ SUBROUTINE SNOWSEAICE( & IF(SNHEI.GE.SNTH) THEN if(snhei.gt.DELTSN+SNTH) then !-- 2-layer snow model - SOILT1=rhtsn+cotsn*SOILT + SOILT1=min(273.15,rhtsn+cotsn*SOILT) TSO(1)=min(271.4,(rhtso(NZS)+cotso(NZS)*SOILT1)) tsob=soilt1 else @@ -3283,39 +3964,47 @@ SUBROUTINE SNOWSEAICE( & SOILT1=TSO(1) tsob=tso(1) endif + ELSEIF (SNHEI > 0. .and. SNHEI < SNTH) THEN +! blended + TSO(2)=min(271.4,(rhtso(NZS1)+cotso(NZS1)*SOILT)) + tso(1)=min(271.4,(tso(2)+(soilt-tso(2))*fso)) + SOILT1=SOILT + tsob=TSO(2) ELSE - TSO(1)=SOILT +! snow is melted + TSO(1)=min(271.4,SOILT) SOILT1=SOILT - tsob=SOILT + tsob=tso(2) ENDIF !---- Final solution for TSO in sea ice + IF (SNHEI > 0. .and. SNHEI < SNTH) THEN +! blended or snow is melted + DO K=3,NZS + KK=NZS-K+1 + TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) + END DO + ELSE DO K=2,NZS KK=NZS-K+1 - TSO(K)=min(271.4,(rhtso(KK)+cotso(KK)*TSO(K-1))) + TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO -!--- For thin snow layer combined with the top sea ice layer -!--- TSO(1) is computed by linear inmterpolation between SOILT -!--- and TSO(2) - - if(SNHEI.LT.SNTH.AND.SNHEI.GT.0.)then - tso(1)=min(271.4,(tso(2)+(soilt-tso(2))*fso)) - SOILT1=TSO(1) - tsob=tso(2) -!!! tsob=tso(1) - endif + ENDIF if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen - IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN +! IF(SOILT.GT.273.15.AND.SNWE.GT.0.) THEN +! if all snow can evaporate, then there is nothing to melt + IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0.) THEN +! nmelt = 1 - soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT - QSG= QSN(soiltfrac,TBQ)/PP - QVG=QSG - T3 = STBOLT*SOILTfrac*SOILTfrac*SOILTfrac - UPFLUX = T3 * SOILTfrac + soiltfrac=273.15 + + QSG= QSN(soiltfrac,TBQ)/PP + T3 = STBOLT*TNold*TNold*TNold + UPFLUX = T3 * 0.5*(TNold+SOILT) XINET = EMISS*(GLW-UPFLUX) - RNET = GSW + XINET +! RNET = GSW + XINET EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS @@ -3346,68 +4035,101 @@ SUBROUTINE SNOWSEAICE( & XLVM*R210*(QSG-QGOLD) !-- SNOH is energy flux of snow phase change SNOH=RNET+QFX +HFX & - +RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-TN) & + +RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac) & -SOH-X+RAINF*CVW*PRCPMS* & - (max(273.15,TABS)-TN) + (max(273.15,TABS)-soiltfrac) + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SNOWSEAICE melt I,J,SNOH,RNET,QFX,HFX,SOH,X',i,j,SNOH,RNET,QFX,HFX,SOH,X + print *,'RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac)', & + RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac) + print *,'RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac)', & + RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac) + ENDIF SNOH=AMAX1(0.,SNOH) !-- SMELT is speed of melting in M/S SMELT= SNOH /XLMELT*1.E-3 SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) SMELT=AMAX1(0.,SMELT) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'1-SMELT i,j',smelt,i,j + ENDIF !18apr08 - Egglston limit ! SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15))) SMELT= amin1 (smelt, 5.6E-8*meltfactor*max(1.,(soilt-273.15))) -!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack -!!! rsm=0.13*smelt*delt - if(snwepr.gt.0.) then - rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) - endif - - rsm=rsmfrac*smelt*delt -!18apr08 rsm is part of melted water that stays in snow as liquid - SMELT=AMAX1(0.,SMELT-rsm/delt) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'2-SMELT i,j',smelt,i,j + ENDIF +! rr - potential melting + rr=SNWEPR/delt-BETA*EPOT*RAS + SMELT=min(SMELT,rr) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'3- SMELT i,j,smelt,rr',i,j,smelt,rr + ENDIF SNOHGNEW=SMELT*XLMELT*1.E3 SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) SNOH=SNOHGNEW + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print*,'soiltfrac,soilt,SNOHGNEW,SNODIF=', & + i,j,soiltfrac,soilt,snohgnew,snodif + print *,'SNOH,SNODIF',SNOH,SNODIF + ENDIF -!18apr08 - if snow melt occurred then go into iteration for energy budget -! solution -!-- correction of liquid equivalent of snow depth -!-- due to evaporation and snow melt +!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack + rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) + if(snhei > 0.01) then + rsm=rsmfrac*smelt*delt + else +! do not keep melted water if snow depth is less that 1 cm + rsm=0. + endif +!18apr08 rsm is part of melted water that stays in snow as liquid + SMELT=AMAX1(0.,SMELT-rsm/delt) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'4-SMELT i,j,smelt,rsm,snwepr,rsmfrac', & + i,j,smelt,rsm,snwepr,rsmfrac + ENDIF + +!-- update liquid equivalent of snow depth +!-- for evaporation and snow melt SNWE = AMAX1(0.,(SNWEPR- & - (SMELT+BETA*EPOT*RAS)*DELT & + (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & ) ) + soilt=soiltfrac !--- If there is no snow melting then just evaporation -!--- or condensation cxhanges SNWE +!--- or condensation changes SNWE ELSE + if(snhei.ne.0.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & - BETA*EPOT*RAS*DELT)) + BETA*EPOT*RAS*DELT*snowfrac)) + endif ENDIF - if(nmelt.eq.1) goto 212 ! second iteration +! no iteration for snow on sea ice, because it will produce +! skin temperature higher than it is possible with snow on sea ice +! if(nmelt.eq.1) goto 212 ! second iteration 220 continue -!--- If all snow melts, then 13% of snow melt we kept in the -!--- snow pack should be added back to snow melt and infiltrate -!--- into soil. - if(rsm.gt.0.) then + + if(smelt > 0..and. rsm > 0.) then if(snwe.le.rsm) then - smelt=smelt+rsm/delt - snwe=0. - rsm=0. + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SEAICE SNWE QSG .and. iter==0) then +!condensation regime + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'turn off canopy evaporation and transpiration' + print *,' QVATM,QVG,QSG,TS1',QVATM,QVG,QSG,TS1 + ENDIF + can=0. + umveg=1. + iter=1 + goto 2111 + endif + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if(iter == 1) then + print *,'QVATM,QVG,QSG,QCG,TS1',QVATM,QVG,QSG,QCG,TS1 + endif + ENDIF !--- SOILT - skin temperature SOILT=TS1 @@ -3778,6 +4549,24 @@ SUBROUTINE SOILTEMP( & TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) END DO + X= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + & + XLV*rho*r211*(QVG-QGOLD) + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print*,'SOILTEMP storage, i,j,x,soilt,tn,qvg,qvgold', & + i,j,x,soilt,tn,qvg,qgold + print *,'TEMP term (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN)',& + (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + print *,'QV term XLV*rho*r211*(QVG-QGOLD)',XLV*rho*r211*(QVG-QGOLD) + ENDIF + X=X & +! "heat" from rain + -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'x=',x + ENDIF + !-------------------------------------------------------------------- END SUBROUTINE SOILTEMP !-------------------------------------------------------------------- @@ -3803,7 +4592,7 @@ SUBROUTINE SNOWTEMP( & !--- output variables SNWEPRINT,SNHEIPRINT,RSM, & TSO,SOILT,SOILT1,TSNAV,QVG,QSG,QCG, & - SMELT,SNOH,SNFLX,ILNB) + SMELT,SNOH,SNFLX,ILNB,X) !******************************************************************** ! Energy budget equation and heat diffusion eqn are @@ -3906,7 +4695,7 @@ SUBROUTINE SNOWTEMP( & REAL, DIMENSION(1:NDDZS), INTENT(IN) :: DTDZS - REAL, DIMENSION(1:4001), INTENT(IN) :: TBQ + REAL, DIMENSION(1:5001), INTENT(IN) :: TBQ !--- input/output variables @@ -3972,11 +4761,13 @@ SUBROUTINE SNOWTEMP( & qfx, & hfx - REAL :: RNET,rsmfrac,soiltfrac,hsn - integer :: nmelt + REAL :: RNET,rsmfrac,soiltfrac,hsn,rr + integer :: nmelt, iter !----------------------------------------------------------------- + iter = 0 + do k=1,nzs transp (k)=0. cotso (k)=0. @@ -4004,13 +4795,12 @@ SUBROUTINE SNOWTEMP( & RSMFRAC = 0. fsn=1. fso=0. - hsn=snhei +! hsn=snhei NZS1=NZS-1 NZS2=NZS-2 - QGOLD=QVG - TNOLD=SOILT + QGOLD=QSG DZSTOP=1./(ZSMAIN(2)-ZSMAIN(1)) !****************************************************************************** @@ -4040,6 +4830,9 @@ SUBROUTINE SNOWTEMP( & IF(SNHEI.GE.SNTH) then if(snhei.le.DELTSN+SNTH) then !-- 1-layer snow model + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'1-layer - snth,snhei,deltsn',snth,snhei,deltsn + ENDIF ilnb=1 snprim=snhei tsob=tso(1) @@ -4061,10 +4854,13 @@ SUBROUTINE SNOWTEMP( & else !-- 2 layers in snow, SOILT1 is temperasture at DELTSN depth + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'2-layer - snth,snhei,deltsn',snth,snhei,deltsn + ENDIF ilnb=2 snprim=deltsn tsob=soilt1 - XSN = DELT/2./(0.5*SNPRIM) + XSN = DELT/2./(0.5*SNHEI) XSN1= DELT/2./(zshalf(2)+0.5*(SNHEI-DELTSN)) DDZSN = XSN / DELTSN DDZSN1 = XSN1 / (SNHEI-DELTSN) @@ -4087,8 +4883,8 @@ SUBROUTINE SNOWTEMP( & -273.15 endif ENDIF - - IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then +! IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GE.0.) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first soil layer. fsn=SNHEI/(SNHEI+zsmain(2)) @@ -4096,7 +4892,7 @@ SUBROUTINE SNOWTEMP( & soilt1=tso(1) tsob=tso(2) snprim=SNHEI+zsmain(2) - XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) + XSN = DELT/2./(zshalf(3)+0.5*snprim) DDZSN = XSN /snprim X1SN = DDZSN * (fsn*thdifsn+fso*thdif(1)) X2=DTDZS(2)*THDIF(2) @@ -4120,15 +4916,10 @@ SUBROUTINE SNOWTEMP( & nmelt=0 SNOH=0. - ETT1=0. - EPOT=-QKMS*(QVATM-QSG) + EPOT=-QKMS*(QVATM-QGOLD) RHCS=CAP(1) H=1. - IF(DEW.NE.0.)THEN - DRYCAN=0. - WETCAN=1. - ENDIF TRANS=PC*TRANSUM*DRYCAN/ZSHALF(NROOT+1) CAN=WETCAN+TRANS UMVEG=1.-VEGFRAC @@ -4150,13 +4941,22 @@ SUBROUTINE SNOWTEMP( & !--- 1-layer snow D1SN = cotso(NZS) D2SN = rhtso(NZS) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'1 layer d1sn,d2sn',i,j,d1sn,d2sn + ENDIF else !--- 2-layer snow D1SN = cotsn D2SN = rhtsn + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'2 layers d1sn,d2sn',i,j,d1sn,d2sn + ENDIF endif D9SN= THDIFSN*RHOCSN / SNPRIM R22SN = SNPRIM*SNPRIM*0.5/(THDIFSN*DELT) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'1 or 2 layers D9sn,R22sn',d9sn,r22sn + ENDIF ENDIF IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then @@ -4168,7 +4968,6 @@ SUBROUTINE SNOWTEMP( & R22SN = snprim*snprim*0.5 & /((fsn*THDIFSN+fso*THDIF(1))*delt) ENDIF - IF(SNHEI.eq.0.)then !--- all snow is sublimated D9SN = D9 @@ -4180,9 +4979,12 @@ SUBROUTINE SNOWTEMP( & ENDIF ENDIF -!---- TDENOM for snow -!18apr08 - the iteration start point + 2211 continue + +!18apr08 - the snow melt iteration start point 212 continue + +!---- TDENOM for snow TDENOM = D9SN*(1.-D1SN +R22SN)+D10+R21+R7 & +RAINF*CVW*PRCPMS & +RHOnewCSN*NEWSNOW/DELT @@ -4194,39 +4996,77 @@ SUBROUTINE SNOWTEMP( & AA=XLVM*(BETA*FKQ*UMVEG+R210)/TDENOM BB=(D10*TABS+R21*TN+XLVM*(QVATM* & (BETA*FKQ*UMVEG+C) & - +R210*QVG)+D11+D9SN*(D2SN+R22SN*TN) & + +R210*QGOLD)+D11+D9SN*(D2SN+R22SN*TN) & +RAINF*CVW*PRCPMS*max(273.15,TABS) & + RHOnewCSN*NEWSNOW/DELT*min(273.15,TABS) & -!18apr08 - added heat of snow phase change computed in the first iteration - -SNOH & )/TDENOM AA1=AA+CC PP=PATM*1.E3 AA1=AA1/PP - IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'VILKA-SNOW' - print *,'tn,aa1,bb,pp,umveg,fkq,r210,vegfrac', & - tn,aa1,bb,pp,umveg,fkq,r210,vegfrac - ENDIF + BB=BB-SNOH/TDENOM CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) -!--- it is saturation over snow - QVG=QS1 + TQ2=QVATM + TX2=TQ2*(1.-H) + Q1=TX2+H*QS1 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 + ENDIF + IF(Q1.LT.QS1) GOTO 100 +!--- if no saturation - goto 100 +!--- if saturation - goto 90 + 90 QVG=QS1 + QSG=QS1 + QCG=max(0.,Q1-QS1) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'90 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) + ENDIF + GOTO 200 + 100 BB=BB-AA*TX2 + AA=(AA*H+CC)/PP + CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) + Q1=TX2+H*QS1 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'VILKA2 - TS1,QS1,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 + ENDIF + IF(Q1.GT.QS1) GOTO 90 QSG=QS1 + QVG=Q1 QCG=0. -!--- SOILT - skin temperature - SOILT=TS1 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'No Saturation QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1) + ENDIF + 200 CONTINUE + if(qvatm > QSG .and. iter==0) then +!condensation regime IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,' AFTER VILKA-SNOW' - print *,' TS1,QS1: ', ts1,qs1 + print *,'SNOW turn off canopy evaporation and transpiration' + print *,' QVATM,QVG,QSG,TS1',QVATM,QVG,QSG,TS1 + ENDIF + can=0. + umveg=1. + iter=1 + goto 2211 + endif + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + if(iter==1) then + print *,'SNOW - QVATM,QVG,QSG,QCG,TS1',QVATM,QVG,QSG,QCG,TS1 + endif ENDIF +!--- SOILT - skin temperature + SOILT=TS1 + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + IF(i.eq.266.and.j.eq.447) then + print *,'snwe,snhei,soilt,soilt1,tso',i,j,snwe,snhei,soilt,soilt1,tso + endif + ENDIF ! Solution for temperature at 7.5 cm depth and snow-soil interface IF(SNHEI.GE.SNTH) THEN if(snhei.gt.DELTSN+SNTH) then !-- 2-layer snow model - SOILT1=min(273.,rhtsn+cotsn*SOILT) + SOILT1=min(273.15,rhtsn+cotsn*SOILT) TSO(1)=rhtso(NZS)+cotso(NZS)*SOILT1 tsob=soilt1 else @@ -4235,58 +5075,70 @@ SUBROUTINE SNOWTEMP( & SOILT1=TSO(1) tsob=tso(1) endif + ELSEIF (SNHEI > 0. .and. SNHEI < SNTH) THEN +! blended + TSO(2)=rhtso(NZS1)+cotso(NZS1)*SOILT + tso(1)=(tso(2)+(soilt-tso(2))*fso) + SOILT1=SOILT + tsob=TSO(2) ELSE +! snow is melted TSO(1)=SOILT SOILT1=SOILT - tsob=SOILT + tsob=tso(2) ENDIF !---- Final solution for TSO + IF (SNHEI > 0. .and. SNHEI < SNTH) THEN +! blended or snow is melted + DO K=3,NZS + KK=NZS-K+1 + TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) + END DO + + ELSE DO K=2,NZS KK=NZS-K+1 TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) END DO -!--- For thin snow layer combined with the top soil layer -!--- TSO is computed by linear inmterpolation between SOILT -!--- and TSO(2) + ENDIF - if(SNHEI.LT.SNTH.AND.SNHEI.GT.0.)then - tso(1)=tso(2)+(soilt-tso(2))*fso - SOILT1=TSO(1) - tsob=tso(2) -!!! tsob=tso(1) - endif + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! IF(i.eq.266.and.j.eq.447) then + print *,'SOILT,SOILT1,tso,TSOB,QSG',i,j,SOILT,SOILT1,tso,TSOB,QSG,'nmelt=',nmelt + ENDIF if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen - IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN +! IF(SOILT.GT.273.15.AND.SNHEI.GT.0.) THEN +! if all snow can evaporate, then there is nothing to melt + IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0.AND.SNHEI.GT.0.) THEN nmelt = 1 - soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT - QSG= QSN(soiltfrac,TBQ)/PP - QVG=QSG - T3 = STBOLT*SOILTfrac*SOILTfrac*SOILTfrac - UPFLUX = T3 * SOILTfrac + soiltfrac=273.15 + QSG=min(QSG, QSN(soiltfrac,TBQ)/PP) + T3 = STBOLT*TN*TN*TN + UPFLUX = T3 * 0.5*(TN + SOILTfrac) XINET = EMISS*(GLW-UPFLUX) - RNET = GSW + XINET +! RNET = GSW + XINET EPOT = -QKMS*(QVATM-QSG) Q1=EPOT*RAS - IF (Q1.LE.0.) THEN + IF (Q1.LE.0..or.iter==1) THEN ! --- condensation DEW=-EPOT DO K=1,NZS TRANSP(K)=0. ENDDO - QFX= XLVM*RHO*DEW - EETA=QFX/XLVM + QFX = -XLVM*RHO*DEW + EETA = QFX/XLVM ELSE ! --- evaporation DO K=1,NROOT TRANSP(K)=-VEGFRAC*q1 & *PC*TRANF(K)*DRYCAN/zshalf(NROOT+1) - IF(TRANSP(K).GT.0.) TRANSP(K)=0. +! IF(TRANSP(K).GT.0.) TRANSP(K)=0. ETT1=ETT1-TRANSP(K) ENDDO DO k=nroot+1,nzs @@ -4294,16 +5146,15 @@ SUBROUTINE SNOWTEMP( & enddo EDIR1 = Q1*UMVEG * BETA - EC1 = Q1 * WETCAN - CMC2MS=CST/DELT - if(EC1.gt.CMC2MS*RAS) cst=0. - EC1=MIN(CMC2MS*RAS,EC1) + EC1 = Q1 * WETCAN*vegfrac + CMC2MS=CST/DELT*RAS +! EC1=MIN(CMC2MS,EC1) EETA = (EDIR1 + EC1 + ETT1)*1.E3 ! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************ - QFX= - XLVM * EETA + QFX= XLVM * EETA ENDIF - HFX=D10*(TABS-soiltfrac) + HFX=-D10*(TABS-soiltfrac) IF(SNHEI.GE.SNTH)then SOH=thdifsn*RHOCSN*(soiltfrac-TSOB)/SNPRIM @@ -4314,52 +5165,81 @@ SUBROUTINE SNOWTEMP( & SNFLX=SOH ENDIF - X= (R21+D9SN*R22SN)*(soiltfrac-TNOLD) + & +! + X= (R21+D9SN*R22SN)*(soiltfrac-TN) + & XLVM*R210*(QSG-QGOLD) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SNOWTEMP storage ',i,j,x + print *,'R21,D9sn,r22sn,soiltfrac,tn,qsg,qgold,snprim', & + R21,D9sn,r22sn,soiltfrac,tn,qsg,qgold,snprim + ENDIF + !-- SNOH is energy flux of snow phase change - SNOH=RNET+QFX +HFX & - +RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-TN) & - -SOH-X+RAINF*CVW*PRCPMS* & - (max(273.15,TABS)-TN) + SNOH=RNET-QFX -HFX - SOH - X & + +RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-soiltfrac) & + +RAINF*CVW*PRCPMS*(max(273.15,TABS)-soiltfrac) SNOH=AMAX1(0.,SNOH) !-- SMELT is speed of melting in M/S SMELT= SNOH /XLMELT*1.E-3 -! SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS*UMVEG) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'1- SMELT',i,j,smelt + ENDIF SMELT=AMIN1(SMELT,SNWEPR/DELT-BETA*EPOT*RAS) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'2- SMELT',i,j,smelt + ENDIF SMELT=AMAX1(0.,SMELT) !18apr08 - Egglston limit ! SMELT= amin1 (smelt, 5.6E-7*meltfactor*max(1.,(soilt-273.15))) SMELT= amin1 (smelt, 5.6E-8*meltfactor*max(1.,(soilt-273.15))) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'3- SMELT',i,j,smelt + ENDIF -!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack -!!! rsm=0.13*smelt*delt - if(snwepr.gt.0.) then - rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) - endif - - rsm=rsmfrac*smelt*delt -!18apr08 rsm is part of melted water that stays in snow as liquid - SMELT=AMAX1(0.,SMELT-rsm/delt) - +! rr - potential melting + rr=SNWEPR/delt-BETA*EPOT*RAS + SMELT=min(SMELT,rr) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'4- SMELT i,j,smelt,rr',i,j,smelt,rr + ENDIF SNOHGNEW=SMELT*XLMELT*1.E3 SNODIF=AMAX1(0.,(SNOH-SNOHGNEW)) SNOH=SNOHGNEW + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SNOH,SNODIF',SNOH,SNODIF + ENDIF + +!*** From Koren et al. (1999) 13% of snow melt stays in the snow pack + rsmfrac=min(0.18,(max(0.08,snwepr/0.10*0.13))) + if(snhei > 0.01) then + rsm=rsmfrac*smelt*delt + else +! do not keep melted water if snow depth is less that 1 cm + rsm=0. + endif +!18apr08 rsm is part of melted water that stays in snow as liquid + SMELT=SMELT-rsm/delt + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & + i,j,smelt,rsm,snwepr,rsmfrac + ENDIF -!-- correction of liquid equivalent of snow depth +!-- update of liquid equivalent of snow depth !-- due to evaporation and snow melt SNWE = AMAX1(0.,(SNWEPR- & - (SMELT+BETA*EPOT*RAS)*DELT & + (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & ! (SMELT+BETA*EPOT*RAS*UMVEG)*DELT & ) ) !--- If there is no snow melting then just evaporation !--- or condensation cxhanges SNWE ELSE + if(snhei.ne.0.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & - BETA*EPOT*RAS*DELT)) -! BETA*EPOT*RAS*UMVEG*DELT)) + BETA*EPOT*RAS*DELT*snowfrac)) + endif ENDIF !18apr08 - if snow melt occurred then go into iteration for energy budget @@ -4367,17 +5247,18 @@ SUBROUTINE SNOWTEMP( & if(nmelt.eq.1) goto 212 ! second interation 220 continue - if(rsm.gt.0.) then + if(smelt.gt.0..and.rsm.gt.0.) then if(snwe.le.rsm) then - smelt=smelt+rsm/delt - snwe=0. - rsm=0. + IF ( 1==1 ) THEN + print *,'SNWE 0.) THEN + if (snhei.GT.deltsn+snth) then hsn = snhei - deltsn + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print*,'2 layer snow - snhei,hsn',snhei,hsn + ENDIF else + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print*,'1 layer snow or blended - snhei',snhei + ENDIF hsn = snhei endif - soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1) + soiltfrac=273.15 - SNOHG=(TSO(1)-soiltfrac)*(RHCS*zshalf(2)+ & + SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & RHOCSN*0.5*hsn) / DELT SNOHG=AMAX1(0.,SNOHG) - SNODIF=0. + SNODIF=0. SMELTG=SNOHG/XLMELT*1.E-3 ! Egglston - empirical limit on snow melt from the bottom of snow pack SMELTG=AMIN1(SMELTG, 5.8e-9) - if(SNWE-SMELTG*DELT.ge.rsm) then - SNWE = AMAX1(0.,SNWE-SMELTG*DELT) - else - smeltg=snwe/delt - snwe=0. - rsm=0. - hsn=0. - endif +! rr - potential melting + rr=SNWE/delt + SMELTG=AMIN1(SMELTG, rr) SNOHGNEW=SMELTG*XLMELT*1.e3 SNODIF=AMAX1(0.,(SNOHG-SNOHGNEW)) - TSO(1) = soiltfrac -! + SNODIF/(RHCS*zshalf(2)+ RHOCSN*0.5*hsn)* DELT) - SMELT=SMELT+SMELTG - SNOH=SNOH+SNOHGNEW - - ENDIF + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! if(i.eq.266.and.j.eq.447) then + print *,'TSO(1),soiltfrac,smeltg,SNODIF',TSO(1),soiltfrac,smeltg,SNODIF + ENDIF + snwe=max(0.,snwe-smeltg*delt*snowfrac) SNHEI=SNWE *1.E3 / RHOSN - snweprint=snwe + + if(snhei > 0.) TSO(1) = soiltfrac + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! if(i.eq.266.and.j.eq.447) then + print *,'Melt from the bottom snwe,snhei',snwe,snhei + if (snhei==0.) & + print *,'Snow is all melted on the warm ground' + ENDIF + + ENDIF + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SNHEI,SNOH',i,j,SNHEI,SNOH + ENDIF ! & -!--- if VEGFRAC.ne.0. then some snow stays on the canopy -!--- and should be added to SNWE for water conservation -! 4 Nov 07 +cst + snweprint=snwe snheiprint=snweprint*1.E3 / RHOSN IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *, 'snweprint : ',snweprint print *, 'D9SN,SOILT,TSOB : ', D9SN,SOILT,TSOB ENDIF -!--- Compute flux in the top snow layer - SNFLX=D9SN*(SOILT-TSOB) + + X= (R21+D9SN*R22SN)*(soilt-TN) + & + XLVM*R210*(QSG-QGOLD) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SNOWTEMP storage ',i,j,x + print *,'R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim', & + R21,D9sn,r22sn,soiltfrac,soilt,tn,qsg,qgold,snprim + ENDIF + + X=X & +! "heat" from snow and rain + -RHOnewCSN*NEWSNOW/DELT*(min(273.15,TABS)-SOILT) & + -RAINF*CVW*PRCPMS*(max(273.15,TABS)-SOILT) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'x=',x + print *,'SNHEI=',snhei + print *,'SNFLX=',snflx + ENDIF + IF(SNHEI.GT.0.) THEN if(ilnb.gt.1) then tsnav=0.5/snhei*((soilt+soilt1)*deltsn & @@ -4451,8 +5370,6 @@ SUBROUTINE SNOWTEMP( & endif ENDIF -! return -! end !------------------------------------------------------------------------ END SUBROUTINE SNOWTEMP !------------------------------------------------------------------------ @@ -4586,6 +5503,34 @@ SUBROUTINE SOILMOIST ( & RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & DID)/DENOM +! RHSMC(1)=(SOILMOIS(NZS)*DID/DELT & +! +TRANSP(NZS)-(HYDRO(NZS)*SOILMOIS(NZS) & +! -HYDRO(NZS1)*SOILMOIS(NZS1))*DID & +! /X1) /DENOM + +!12 June 2014 - low boundary condition: 1 - zero diffusion below the lowest +! level; 2 - soil moisture at the low boundary can be lost due to the root uptake. +! So far - no interaction with the water table. + + DENOM=1.+DIFFU(nzs1)/X1/DID*DELT +!orig DENOM=(1.+DIFFU(nzs1)/X1/DID*DELT+HYDRO(NZS)/DID*DELT) +!orig COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & +!orig +HYDRO(NZS1)/2./DID)/DENOM + COSMC(1)=DELT*(DIFFU(nzs1)/DID/X1 & + +HYDRO(NZS1)/DID)/DENOM + +! RHSMC(1)=(SOILMOIS(NZS)+TRANSP(NZS)*DELT/ & +! DID)/DENOM + + RHSMC(1)=(SOILMOIS(NZS)-HYDRO(NZS)*DELT/DID*soilmois(nzs) & + +TRANSP(NZS)*DELT/DID)/DENOM +!test RHSMC(1)=SOILMOIS(NZS)-HYDRO(NZS)*soilmois(nzs) + +!test!!! +!this test gave smoother soil moisture, ovwerall better results + COSMC(1)=0. + RHSMC(1)=SOILMOIS(NZS) +! DO 330 K=1,NZS2 KN=NZS-K K1=2*KN-3 @@ -4595,7 +5540,11 @@ SUBROUTINE SOILMOIST ( & Q2=X2-HYDRO(KN+1)*DTDZS2(KN-1) DENOM=1.+X2+X4-Q2*COSMC(K) COSMC(K+1)=Q4/DENOM - 330 RHSMC(K+1)=(SOILMOIS(KN)+Q2*RHSMC(K) & + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k' & + ,q2,soilmois(kn),DIFFU(KN),x2,HYDRO(KN+1),DTDZS2(KN-1),kn,k + ENDIF + 330 RHSMC(K+1)=(SOILMOIS(KN)+Q2*RHSMC(K) & +TRANSP(KN) & /(ZSHALF(KN+1)-ZSHALF(KN)) & *DELT)/DENOM @@ -4622,6 +5571,12 @@ SUBROUTINE SOILMOIST ( & 191 format (f23.19) TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', & + UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT + ENDIF + +!test 16 may TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT !30july13 TOTLIQ=UMVEG*PRCP-DRIP/DELT-SMELT FLX=TOTLIQ @@ -4663,6 +5618,9 @@ SUBROUTINE SOILMOIST ( & ELSE INFMAX1 = 0. ENDIF + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'INFMAX1 before frozen part',INFMAX1 + ENDIF ! ----------- FROZEN GROUND VERSION -------------------------- ! REDUCTION OF INFILTRATION BASED ON FROZEN GROUND PARAMETERS @@ -4684,17 +5642,26 @@ SUBROUTINE SOILMOIST ( & END DO FCR = 1. - EXP(-ACRT) * SUM END IF -! print *,'FCR--------',fcr + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'FCR--------',fcr + print *,'DICE=',dice + ENDIF INFMAX1 = INFMAX1* FCR ! ------------------------------------------------------------------- INFMAX = MAX(INFMAX1,HYDRO(1)*SOILMOIS(1)) INFMAX = MIN(INFMAX, -TOTLIQ) - + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +print *,'INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ', & + INFMAX,INFMAX1,HYDRO(1)*SOILIQW(1),-TOTLIQ + ENDIF !---- IF (-TOTLIQ.GT.INFMAX)THEN RUNOFF=-TOTLIQ-INFMAX FLX=-INFMAX + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'FLX,RUNOFF1=',flx,runoff + ENDIF ENDIF ! INFILTRP is total infiltration flux in M/S INFILTRP=FLX @@ -4719,38 +5686,60 @@ SUBROUTINE SOILMOIST ( & END IF IF(QQ.LT.0.) THEN +! print *,'negative QQ=',qq SOILMOIS(1)=1.e-8 ELSE IF(QQ.GT.DQM) THEN !-- saturation SOILMOIS(1)=DQM - RUNOFF2=(FLXSAT-FLX)*DELT + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'FLXSAT,FLX,DELT',FLXSAT,FLX,DELT,RUNOFF2 + ENDIF +! RUNOFF2=(FLXSAT-FLX)*DELT RUNOFF=RUNOFF+(FLXSAT-FLX) ELSE SOILMOIS(1)=min(dqm,max(1.e-8,QQ)) END IF + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'SOILMOIS,SOILIQW, soilice',SOILMOIS,SOILIQW,soilice*riw + print *,'COSMC,RHSMC',COSMC,RHSMC + ENDIF !--- FINAL SOLUTION FOR SOILMOIS - DO K=2,NZS + DO K=2,NZS1 +! DO K=2,NZS KK=NZS-K+1 QQ=COSMC(KK)*SOILMOIS(K-1)+RHSMC(KK) ! QQ=COSMC(KK)*SOILIQW(K-1)+RHSMC(KK) IF (QQ.LT.0.) THEN +! print *,'negative QQ=',qq SOILMOIS(K)=1.e-8 ELSE IF(QQ.GT.DQM) THEN !-- saturation SOILMOIS(K)=DQM - IF(K.EQ.NZS)THEN - RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSMAIN(K)-ZSHALF(K)) - ELSE - RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSHALF(K+1)-ZSHALF(K)) - ENDIF +! IF(K.EQ.NZS)THEN + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'hydro(k),QQ,DQM,k',hydro(k),QQ,DQM,k + ENDIF +! RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSMAIN(K)-ZSHALF(K)) +! RUNOFF2=RUNOFF2+(QQ-DQM)*hydro(k) +! print *,'RUNOFF2=',RUNOFF2 +! ELSE +! print *,'QQ,DQM,k',QQ,DQM,k +! RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSHALF(K+1)-ZSHALF(K)) +! RUNOFF2=RUNOFF2+(QQ-DQM)*hydro(k) +! ENDIF ELSE SOILMOIS(K)=min(dqm,max(1.e-8,QQ)) END IF END DO + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'END soilmois,soiliqw,soilice',soilmois,SOILIQW,soilice*riw + ENDIF + +! RUNOFF2=RUNOFF2+hydro(nzs)*SOILMOIS(NZS) MAVAIL=max(.00001,min(1.,SOILMOIS(1)/(REF-QMIN))) ! MAVAIL=max(.00001,min(1.,SOILMOIS(1)/DQM)) @@ -4943,6 +5932,9 @@ SUBROUTINE SOILPROP( & END DO + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'soilice*riw,soiliqw,soilmois,ws',soilice*riw,soiliqw,soilmois,ws + ENDIF DO K=1,NZS if((ws-riw*soilice(k)).lt.0.12)then @@ -4953,13 +5945,17 @@ SUBROUTINE SOILPROP( & fach=1.-riw*soilice(k)/max(1.e-8,soilmois(k)) am=max(1.e-8,dqm-riw*soilice(k)) !--- HYDRO is hydraulic conductivity of soil water - hydro(K)=KSAT/am* & + hydro(K)=min(KSAT,KSAT/am* & (soiliqw(K)/am) & **(2.*BCLH+2.) & - * fach + * fach) + if(hydro(k)<1.e-10)hydro(k)=0. endif ENDDO + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'hydro=',hydro + ENDIF ! RETURN ! END @@ -5057,8 +6053,10 @@ SUBROUTINE TRANSF( & TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID ENDIF !-- uncomment next line for non-linear root distribution -!cc TRANF(1)=part(1) - TRANF(1)=TRANF(1)*FTEM +! change made in Nov.2014 + TRANF(1)=part(1) +! linear root distribution +! TRANF(1)=TRANF(1)*FTEM DO K=2,NROOT totliq=soiliqw(k)+qmin @@ -5092,8 +6090,6 @@ SUBROUTINE TRANSF( & transum=transum+tranf(k) END DO -! RETURN -! END !----------------------------------------------------------------- END SUBROUTINE TRANSF !----------------------------------------------------------------- @@ -5104,7 +6100,7 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) !--- VILKA finds the solution of energy budget at the surface !--- using table T,QS computed from Clausius-Klapeiron !-------------------------------------------------------------- - REAL, DIMENSION(1:4001), INTENT(IN ) :: TT + REAL, DIMENSION(1:5001), INTENT(IN ) :: TT REAL, INTENT(IN ) :: TN,D1,D2,PP INTEGER, INTENT(IN ) :: NSTEP,ii,j,iland,isoil @@ -5118,25 +6114,23 @@ SUBROUTINE VILKA(TN,D1,D2,PP,QS,TS,TT,NSTEP,ii,j,iland,isoil) F1=T1+D1*TT(I)-D2 I1=I-F1/(.05+D1*(TT(I+1)-TT(I))) I=I1 - IF(I.GT.4000.OR.I.LT.1) GOTO 1 + IF(I.GT.5000.OR.I.LT.1) GOTO 1 10 I1=I T1=173.1+FLOAT(I)*.05 F1=T1+D1*TT(I)-D2 RN=F1/(.05+D1*(TT(I+1)-TT(I))) I=I-INT(RN) - IF(I.GT.4000.OR.I.LT.1) GOTO 1 + IF(I.GT.5000.OR.I.LT.1) GOTO 1 IF(I1.NE.I) GOTO 10 TS=T1-.05*RN QS=(TT(I)+(TT(I)-TT(I+1))*RN)/PP GOTO 20 ! 1 PRINT *,'Crash in surface energy budget - STOP' - 1 PRINT *,' AVOST IN VILKA ' + 1 PRINT *,' AVOST IN VILKA Table index= ',I ! PRINT *,TN,D1,D2,PP,NSTEP,I,TT(i),ii,j,iland,isoil print *,'I,J=',ii,j,'LU_index = ',iland, 'Psfc[hPa] = ',pp, 'Tsfc = ',tn CALL wrf_error_fatal (' Crash in surface energy budget ' ) 20 CONTINUE -! RETURN -! END !----------------------------------------------------------------------- END SUBROUTINE VILKA !----------------------------------------------------------------------- @@ -5413,7 +6407,7 @@ SUBROUTINE SOILVEGIN ( mosaic_lu,mosaic_soil,soilfrac,nscat, & ! INTEGER, DIMENSION( 1:50 ) :: if1 INTEGER :: kstart, kfin, lstart, lfin INTEGER :: k - REAL :: area, crop, deltalai, factor, znt1, lb + REAL :: area, deltalai, factor, znt1, lb REAL, DIMENSION( 1:NLCAT ) :: ZNTtoday, LAItoday !*********************************************************************** @@ -5435,17 +6429,14 @@ SUBROUTINE SOILVEGIN ( mosaic_lu,mosaic_soil,soilfrac,nscat, & endif ENDIF - crop = 0. deltalai = 0. - if(IFORTBL(ivgtyp) == 7) crop = 1. - ! 11oct2012 - seasonal correction on ZNT for crops and LAI for all veg. types ! factor = 1 with minimum greenness --> vegfrac = shdmin (cold season) - if((shdmax - shdmin) .lt. 1) then + if((vegfrac - shdmin) .le. 0.) then factor = 1. else - factor = 1. - max(0.,min(1.,(vegfrac - shdmin)/max(1.,(shdmax-shdmin)))) + factor = 1. - max(0.,min(1.,((vegfrac - shdmin)/(shdmax-shdmin)))) endif do k = 1,nlcat @@ -5471,8 +6462,8 @@ SUBROUTINE SOILVEGIN ( mosaic_lu,mosaic_soil,soilfrac,nscat, & IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN if(i.eq.358.and.j.eq.260)then - print *,'ivgtyp,factor,vegfrac,shdmin,shdmax,crop,deltalai,laitoday(ivgtyp),znttoday(ivgtyp)', & - i,j,ivgtyp,factor,vegfrac,shdmin,shdmax,crop,deltalai,laitoday(ivgtyp),znttoday(ivgtyp) + print *,'ivgtyp,factor,vegfrac,shdmin,shdmax,deltalai,laitoday(ivgtyp),znttoday(ivgtyp)', & + i,j,ivgtyp,factor,vegfrac,shdmin,shdmax,deltalai,laitoday(ivgtyp),znttoday(ivgtyp) endif ENDIF @@ -5620,7 +6611,7 @@ SUBROUTINE RUCLSMINIT( SH2O,SMFR3D,TSLB,SMOIS,ISLTYP,IVGTYP, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_data_gocart_dust #endif IMPLICIT NONE @@ -5683,16 +6674,16 @@ SUBROUTINE RUCLSMINIT( SH2O,SMFR3D,TSLB,SMOIS,ISLTYP,IVGTYP, & call RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) ENDIF -#ifdef WRF_CHEM +!#if ( WRF_CHEM == 1 ) ! ! need this parameter for dust parameterization in wrf/chem ! - do I=1,NSLTYPE - porosity(i)=maxsmc(i) - drypoint(i)=drysmc(i) - enddo -#endif - +! do I=1,NSLTYPE +! porosity(i)=maxsmc(i) +! drypoint(i)=drysmc(i) +! enddo +!#endif +! IF(.not.restart)THEN itf=min0(ite,ide-1) @@ -5903,6 +6894,8 @@ SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) READ (19,*)BARE READ (19,*) READ (19,*)NATURAL + READ (19,*) + READ (19,*)CROP ENDIF 2002 CONTINUE @@ -5940,6 +6933,8 @@ SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) CALL wrf_dm_bcast_real ( CFACTR_DATA , 1 ) CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 ) CALL wrf_dm_bcast_integer ( BARE , 1 ) + CALL wrf_dm_bcast_integer ( NATURAL , 1 ) + CALL wrf_dm_bcast_integer ( CROP , 1 ) ! !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL diff --git a/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F b/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F index b7b0f699..484df2b2 100644 --- a/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F +++ b/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F @@ -4,9 +4,9 @@ MODULE module_sf_sfcdiags_ruclsm CONTAINS - SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS2,CQS2,T2,TH2,Q2, & + SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS,CHS2,CQS2,T2,TH2,Q2, & T3D,QV3D,RHO3D,P3D, & - PSFC,CP,R_d,ROVCP, & + CP,R_d,ROVCP, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -26,7 +26,8 @@ SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS2,CQS2,T2,TH2,Q2, & TH2, & T2 REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN) :: PSFC, & + INTENT(IN) :: & + CHS, & CHS2, & CQS2 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & @@ -38,62 +39,98 @@ SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS2,CQS2,T2,TH2,Q2, & REAL, INTENT(IN ) :: CP,R_d,ROVCP ! LOCAL VARS INTEGER :: I,J - REAL :: RHO, x2m, qlev1, tempc, qsat, p2m + REAL :: RHO, x2m, qlev1, tempc, qsat, p2m, qsfcprox, qsfcmr, psfc + LOGICAL :: FLUX + + flux = .true. +! flux = .false. DO J=jts,jte DO I=its,ite -! RHO = PSFC(I,J)/(R_d * TSK(I,J)) - RHO = RHO3D(i,1,j) - P2m = PSFC(I,J)*EXP(-0.068283/t3d(i,1,j)) - - if(CHS2(I,J).lt.1.E-5) then + RHO = RHO3D(i,kms,j) + PSFC = P3D(I,kms,J) +! Assume that 2-m pressure also equal to PSFC +! P2m = PSFC(I,J)*EXP(-0.068283/t3d(i,1,j)) + +!!! 2-m Temperature - T2 + if(CHS2(I,J).lt.1.E-5) then +! may be to small treshold? +! if(CHS2(I,J).lt.3.E-3 .AND. HFX(I,J).lt.0.) then ! TH2(I,J) = TSK(I,J)*(1.E5/PSFC(I,J))**ROVCP - TH2(I,J) = t3d(i,1,j)*(1.E5/P2m)**ROVCP + TH2(I,J) = t3d(i,kms,j)*(1.E5/PSFC)**ROVCP else - TH2(I,J) = TSK(I,J)*(1.E5/PSFC(I,J))**ROVCP - HFX(I,J)/(RHO*CP*CHS2(I,J)) -!tgs T2(I,J) = TSK(I,J) - HFX(I,J)/(RHO*CP*CHS2(I,J)) + TH2(I,J) = TSK(I,J)*(1.E5/PSFC)**ROVCP - HFX(I,J)/(RHO*CP*CHS2(I,J)) +! T2(I,J) = TSK(I,J) - HFX(I,J)/(RHO*CP*CHS2(I,J)) endif -!tgs TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**ROVCP - T2(I,J) = TH2(I,J)*(1.E-5*P2m)**ROVCP -!tgs check that T2 values lie in the range between TSK and T at the 1st level - x2m = MAX(MIN(tsk(i,j),t3d(i,1,j)) , t2(i,j)) - t2(i,j) = MIN(MAX(tsk(i,j),t3d(i,1,j)) , x2m) - - TH2(I,J) = T2(I,J)*(1.E5/P2m)**ROVCP - -!tgs check that Q2 values in the lie between QSFC and Q at the 1st level - qlev1 = qv3d(i,1,j) -!tgs saturation check - tempc=t3d(i,1,j)-273.15 +! TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**ROVCP + T2(I,J) = TH2(I,J)*(1.E-5*PSFC)**ROVCP +! check that T2 values lie in the range between TSK and T at the 1st level + x2m = MAX(MIN(tsk(i,j),t3d(i,kms,j)) , t2(i,j)) + t2(i,j) = MIN(MAX(tsk(i,j),t3d(i,kms,j)) , x2m) + + TH2(I,J) = T2(I,J)*(1.E5/PSFC)**ROVCP + +!!! 2-m Water vapor mixing ratio - Q2 + qlev1 = qv3d(i,kms,j) +! saturation check + tempc=t3d(i,kms,j)-273.15 if (tempc .le. 0.0) then -! qsat - mixing ratio - qsat = rsif(p3d(i,1,j), t3d(i,1,j)) +! over ice + qsat = rsif(p3d(i,kms,j), t3d(i,kms,j)) else - qsat = rslf(p3d(i,1,j), t3d(i,1,j)) + qsat = rslf(p3d(i,kms,j), t3d(i,kms,j)) endif +!remove oversaturation at level 1 qlev1 = min(qsat, qlev1) +! Compute QSFC proxy from QFX, qlev1 and CHS +! Use of QSFCprox is more accurate diagnostics for densely vegetated areas, +! like cropland in summer + qsfcprox=qlev1+QFX(I,J)/(RHO*CHS(I,J)) + qsfcmr = qsfc(i,j)/(1.-qsfc(i,j)) + +! if(i.eq.426.and.j.eq.250) then +!! cropland point +! print *,'qsfc,qsfcmr,qsfcprox,qlev1',qsfc(i,j),qsfcmr,qsfcprox,qlev1 +! print *,'(qsfcprox-qsfcmr)/qsfcmr =', (qsfcprox-qsfcmr)/qsfcmr +! endif + + if ( flux ) then if(CQS2(I,J).lt.1.E-5) then -!tgs - here Q2 is 2-m water vapor mixing ratio +! - under very stable conditions use first level for 2-m mixing ratio Q2(I,J)=qlev1 else - x2m = QSFC(I,J) - QFX(I,J)/(RHO*CQS2(I,J)) - Q2(I,J)=x2m/(1.-x2m) +! x2m = QSFCmr - QFX(I,J)/(RHO*CQS2(I,J)) + x2m = QSFCprox - QFX(I,J)/(RHO*CQS2(I,J)) + q2(i,j) = x2m endif + else +! QFX is not used + Q2(I,J) = qsfcmr - CHS(I,J)/CHS2(I,J)*(qsfcmr - qlev1) + endif + +! Check that Q2 values lie between QSFCmr and qlev1 + x2m = MAX(MIN(qsfcmr,qlev1) , q2(i,j)) + q2(i,j) = MIN(MAX(qsfcmr,qlev1) , x2m) - x2m = MAX(MIN(qsfc(i,j)/(1.-qsfc(i,j)),qlev1) , q2(i,j)) - q2(i,j) = MIN(MAX(qsfc(i,j)/(1.-qsfc(i,j)),qlev1) , x2m) -!tgs saturation check +! saturation check tempc=t2(i,j)-273.15 if (tempc .le. 0.0) then -! qsat - mixing ratio - qsat = rsif(psfc(i,j), t2(i,j)) +! ice and supercooled water + qsat = rsif(psfc, t2(i,j)) else - qsat = rslf(psfc(i,j), t2(i,j)) +! water + qsat = rslf(psfc, t2(i,j)) endif q2(i,j) = min(qsat, q2(i,j)) +! if(i.eq.426.and.j.eq.250) then +!! cropland point +! print *,'FINAL - qsfc,qsfcmr,qsfcprox,q2(i,j),qlev1', & +! qsfc(i,j),qsfcmr,qsfcprox,q2(i,j),qlev1 +! print *,'(q2-qlev1)/qlev1 =', (q2(i,j)-qlev1)/qlev1 +! endif ENDDO ENDDO diff --git a/wrfv2_fire/phys/module_sf_sfclay.F b/wrfv2_fire/phys/module_sf_sfclay.F index bc46a34e..0bc72358 100644 --- a/wrfv2_fire/phys/module_sf_sfclay.F +++ b/wrfv2_fire/phys/module_sf_sfclay.F @@ -28,6 +28,12 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- +! Changes in V3.7 over water surfaces: +! 1. for ZNT/Cd, replacing constant OZO with 0.11*1.5E-5/UST(I) +! the COARE 3.5 (Edson et al. 2013) formulation is also available +! 2. for VCONV, reducing magnitude by half +! 3. for Ck, replacing Carlson-Boland with COARE 3 +!------------------------------------------------------------------- !-- U3D 3D u-velocity interpolated to theta points (m/s) !-- V3D 3D v-velocity interpolated to theta points (m/s) !-- T3D temperature (K) @@ -174,12 +180,13 @@ SUBROUTINE SFCLAY(U3D,V3D,T3D,QV3D,P3D,dz8w, & INTENT(INOUT) :: & QGH - - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm + INTENT(OUT) :: ck,cka,cd,cda + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: USTM INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX @@ -325,7 +332,9 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & T1D REAL, OPTIONAL, DIMENSION( ims:ime ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm + INTENT(OUT) :: ck,cka,cd,cda + REAL, OPTIONAL, DIMENSION( ims:ime ) , & + INTENT(INOUT) :: USTM INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX @@ -363,6 +372,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & REAL :: DTG,PSIX,DTTHX,PSIX10,PSIT,PSIT2,PSIQ,PSIQ2,PSIQ10 REAL :: FLUXC,VSGD,Z0Q,VISC,RESTAR,CZIL,GZ0OZQ,GZ0OZT REAL :: ZW, ZN1, ZN2 + REAL :: Z0T, CZC !------------------------------------------------------------------- KL=kte @@ -477,7 +487,7 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & TSKV=THGB(I)*(1.+EP1*QSFC(I)) DTHVDZ=(THVX(I)-TSKV) ! Convective velocity scale Vc and subgrid-scale velocity Vsg -! following Beljaars (1995, QJRMS) and Mahrt and Sun (1995, MWR) +! following Beljaars (1994, QJRMS) and Mahrt and Sun (1995, MWR) ! ... HONG Aug. 2001 ! ! VCONV = 0.25*sqrt(g/tskv*pblh(i)*dthvm) @@ -492,7 +502,9 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ELSE DTHVM=0. ENDIF - VCONV = 2.*SQRT(DTHVM) +! VCONV = 2.*SQRT(DTHVM) +! V3.7: reducing contribution in calm conditions + VCONV = SQRT(DTHVM) endif ! Mahrt and Sun low-res correction VSGD = 0.32 * (max(dx/5000.-1.,0.))**.33 @@ -686,6 +698,26 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & PSIQ2=ALOG(KARMAN*UST(I)*2./XKA+2./ZL)-PSIH2(I) ! AHW: mods to compute ck, cd PSIQ10=ALOG(KARMAN*UST(I)*10./XKA+10./ZL)-PSIH10(I) + +! V3.7: using Fairall 2003 to compute z0q and z0t over water: +! adapted from module_sf_mynn.F + IF ( (XLAND(I)-1.5).GE.0. ) THEN + VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5 +! VISC=1.326e-5*(1. + 6.542e-3*SCR3(I) + 8.301e-6*SCR3(I)*SCR3(I) & +! - 4.84e-9*SCR3(I)*SCR3(I)*SCR3(I)) + RESTAR=UST(I)*ZNT(I)/VISC + Z0T = (5.5e-5)*(RESTAR**(-0.60)) + Z0T = MIN(Z0T,1.0e-4) + Z0T = MAX(Z0T,2.0e-9) + Z0Q = Z0T + + PSIQ=max(ALOG((ZA(I)+Z0Q)/Z0Q)-PSIH(I), 2.) + PSIT=max(ALOG((ZA(I)+Z0T)/Z0T)-PSIH(I), 2.) + PSIQ2=max(ALOG((2.+Z0Q)/Z0Q)-PSIH2(I), 2.) + PSIT2=max(ALOG((2.+Z0T)/Z0T)-PSIH2(I), 2.) + PSIQ10=max(ALOG((10.+Z0Q)/Z0Q)-PSIH10(I), 2.) + ENDIF + IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX.EQ.1 .AND. (XLAND(I)-1.5).GE.0. ) THEN ! v3.1 @@ -789,7 +821,13 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & DO 360 I=its,ite IF((XLAND(I)-1.5).GE.0)THEN - ZNT(I)=CZO*UST(I)*UST(I)/G+OZO +! ZNT(I)=CZO*UST(I)*UST(I)/G+OZO +! Since V3.7 (ref: EC Physics document for Cy36r1) + ZNT(I)=CZO*UST(I)*UST(I)/G+0.11*1.5E-5/UST(I) +! COARE 3.5 (Edson et al. 2013) +! CZC = 0.0017*WSPD(I)-0.005 +! CZC = min(CZC,0.028) +! ZNT(I)=CZC*UST(I)*UST(I)/G+0.11*1.5E-5/UST(I) ! AHW: change roughness length, and hence the drag coefficients Ck and Cd IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX.NE.0 ) THEN @@ -845,12 +883,12 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & DO 400 I=its,ite IF(XLAND(I)-1.5.GT.0.)THEN HFX(I)=FLHC(I)*(THGB(I)-THX(I)) - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX.NE.0 ) THEN -! AHW: add dissipative heating term - HFX(I)=HFX(I)+RHOX(I)*USTM(I)*USTM(I)*WSPDI(I) - ENDIF - ENDIF +! IF ( PRESENT(ISFTCFLX) ) THEN +! IF ( ISFTCFLX.NE.0 ) THEN +! AHW: add dissipative heating term (commented out in 3.6.1) +! HFX(I)=HFX(I)+RHOX(I)*USTM(I)*USTM(I)*WSPDI(I) +! ENDIF +! ENDIF ELSEIF(XLAND(I)-1.5.LT.0.)THEN HFX(I)=FLHC(I)*(THGB(I)-THX(I)) HFX(I)=AMAX1(HFX(I),-250.) diff --git a/wrfv2_fire/phys/module_sf_sfclayrev.F b/wrfv2_fire/phys/module_sf_sfclayrev.F index 931e6229..dd12722f 100644 --- a/wrfv2_fire/phys/module_sf_sfclayrev.F +++ b/wrfv2_fire/phys/module_sf_sfclayrev.F @@ -6,7 +6,7 @@ MODULE module_sf_sfclayrev REAL , PARAMETER :: CZO=0.0185 REAL , PARAMETER :: OZO=1.59E-5 - REAL, DIMENSION(0:1000 ),SAVE :: PSIMTB,PSIHTB + REAL, DIMENSION(0:1000 ),SAVE :: psim_stab,psim_unstab,psih_stab,psih_unstab CONTAINS @@ -28,6 +28,12 @@ SUBROUTINE SFCLAYREV(U3D,V3D,T3D,QV3D,P3D,dz8w, & !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- +! Changes in V3.7 over water surfaces: +! 1. for ZNT/Cd, replacing constant OZO with 0.11*1.5E-5/UST(I) +! the COARE 3.5 (Edson et al. 2013) formulation is also available +! 2. for VCONV, reducing magnitude by half +! 3. for Ck, replacing Carlson-Boland with COARE 3 +!------------------------------------------------------------------- !-- U3D 3D u-velocity interpolated to theta points (m/s) !-- V3D 3D v-velocity interpolated to theta points (m/s) !-- T3D temperature (K) @@ -173,13 +179,14 @@ SUBROUTINE SFCLAYREV(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: & QGH - - REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm + INTENT(OUT) :: ck,cka,cd,cda + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: USTM INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX @@ -324,7 +331,9 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & T1D REAL, OPTIONAL, DIMENSION( ims:ime ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm + INTENT(OUT) :: ck,cka,cd,cda + REAL, OPTIONAL, DIMENSION( ims:ime ) , & + INTENT(INOUT) :: USTM INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX, IZ0TLND INTEGER, OPTIONAL, INTENT(IN ) :: SCM_FORCE_FLUX @@ -365,8 +374,10 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ! ! .... paj ... ! - REAL :: zolri,zolri2,zolzz,zol0 - REAL :: psih_stable,psim_stable,psih_unstable,psim_unstable + REAL :: zolzz,zol0 +! REAL :: zolri,zolri2 +! REAL :: psih_stable,psim_stable,psih_unstable,psim_unstable +! REAL :: psih_stable_full,psim_stable_full,psih_unstable_full,psim_unstable_full REAL :: zl2,zl10,z0t REAL, DIMENSION( its:ite ) :: pq,pq2,pq10 @@ -485,7 +496,7 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & TSKV=THGB(I)*(1.+EP1*QSFC(I)) DTHVDZ=(THVX(I)-TSKV) ! Convective velocity scale Vc and subgrid-scale velocity Vsg -! following Beljaars (1995, QJRMS) and Mahrt and Sun (1995, MWR) +! following Beljaars (1994, QJRMS) and Mahrt and Sun (1995, MWR) ! ... HONG Aug. 2001 ! ! VCONV = 0.25*sqrt(g/tskv*pblh(i)*dthvm) @@ -500,7 +511,9 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ELSE DTHVM=0. ENDIF - VCONV = 2.*SQRT(DTHVM) +! VCONV = 2.*SQRT(DTHVM) +! V3.7: reducing contribution in calm conditions + VCONV = SQRT(DTHVM) endif ! Mahrt and Sun low-res correction VSGD = 0.32 * (max(dx/5000.-1.,0.))**.33 @@ -684,6 +697,24 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & ! AHW: mods to compute ck, cd PSIQ10=ALOG(KARMAN*UST(I)*10./XKA+10./ZL)-pq10(I) + +! V3.7: using Fairall 2003 to compute z0q and z0t over water: +! adapted from module_sf_mynn.F + IF ( (XLAND(I)-1.5).GE.0. ) THEN + VISC=(1.32+0.009*(SCR3(I)-273.15))*1.E-5 + RESTAR=UST(I)*ZNT(I)/VISC + Z0T = (5.5e-5)*(RESTAR**(-0.60)) + Z0T = MIN(Z0T,1.0e-4) + Z0T = MAX(Z0T,2.0e-9) + Z0Q = Z0T + + PSIQ=max(ALOG((ZA(I)+Z0Q)/Z0Q)-PSIH(I), 2.) + PSIT=max(ALOG((ZA(I)+Z0T)/Z0T)-PSIH(I), 2.) + PSIQ2=max(ALOG((2.+Z0Q)/Z0Q)-PSIH2(I), 2.) + PSIT2=max(ALOG((2.+Z0T)/Z0T)-PSIH2(I), 2.) + PSIQ10=max(ALOG((10.+Z0Q)/Z0Q)-PSIH10(I), 2.) + ENDIF + IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX.EQ.1 .AND. (XLAND(I)-1.5).GE.0. ) THEN ! v3.1 @@ -891,7 +922,13 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & DO 360 I=its,ite IF((XLAND(I)-1.5).GE.0)THEN - ZNT(I)=CZO*UST(I)*UST(I)/G+OZO +! ZNT(I)=CZO*UST(I)*UST(I)/G+OZO +! Since V3.7 (ref: EC Physics document for Cy36r1) + ZNT(I)=CZO*UST(I)*UST(I)/G+0.11*1.5E-5/UST(I) +! COARE 3.5 (Edson et al. 2013) +! CZC = 0.0017*WSPD(I)-0.005 +! CZC = min(CZC,0.028) +! ZNT(I)=CZC*UST(I)*UST(I)/G+0.11*1.5E-5/UST(I) ! AHW: change roughness length, and hence the drag coefficients Ck and Cd IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX.NE.0 ) THEN @@ -948,12 +985,12 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & DO 400 I=its,ite IF(XLAND(I)-1.5.GT.0.)THEN HFX(I)=FLHC(I)*(THGB(I)-THX(I)) - IF ( PRESENT(ISFTCFLX) ) THEN - IF ( ISFTCFLX.NE.0 ) THEN -! AHW: add dissipative heating term - HFX(I)=HFX(I)+RHOX(I)*USTM(I)*USTM(I)*WSPDI(I) - ENDIF - ENDIF +! IF ( PRESENT(ISFTCFLX) ) THEN +! IF ( ISFTCFLX.NE.0 ) THEN +! AHW: add dissipative heating term (commented out in 3.6.1) +! HFX(I)=HFX(I)+RHOX(I)*USTM(I)*USTM(I)*WSPDI(I) +! ENDIF +! ENDIF ELSEIF(XLAND(I)-1.5.LT.0.)THEN HFX(I)=FLHC(I)*(THGB(I)-THX(I)) HFX(I)=AMAX1(HFX(I),-250.) @@ -999,65 +1036,54 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d, & END SUBROUTINE SFCLAYREV1D !==================================================================== - SUBROUTINE sfclayrevinit( allowed_to_read ) + SUBROUTINE sfclayrevinit -! LOGICAL , INTENT(IN) :: allowed_to_read -! INTEGER :: N -! REAL :: ZOLN,X,Y + INTEGER :: N + REAL :: zolf -! DO N=0,1000 -! ZOLN=-FLOAT(N)*0.1 -! X=(1-16.*ZOLN)**0.25 -! PSIMTB(N)=2*ALOG(0.5*(1+X))+ALOG(0.5*(1+X*X))- & -! 2.*ATAN(X)+2.*ATAN(1.) -! Y=(1-16*ZOLN)**0.5 -! PSIHTB(N)=2*ALOG(0.5*(1+Y)) -! ENDDO - - END SUBROUTINE sfclayrevinit + DO N=0,1000 +! stable function tables + zolf = float(n)*0.01 + psim_stab(n)=psim_stable_full(zolf) + psih_stab(n)=psih_stable_full(zolf) + +! unstable function tables + zolf = -float(n)*0.01 + psim_unstab(n)=psim_unstable_full(zolf) + psih_unstab(n)=psih_unstable_full(zolf) -!------------------------------------------------------------------- + ENDDO -END MODULE module_sf_sfclayrev + END SUBROUTINE sfclayrevinit -! -! ---------------------------------------------------------- -! function zolri(ri,z,z0) -! - real right,left,midpoint ! if (ri.lt.0.)then - left=-1200. - right=0. + x1=-5. + x2=0. else - left=0. - right=20000. + x1=0. + x2=5. endif ! - Do While (abs(right - left) > 0.01) - midpoint=(right+left)/2. - a=zolri2(left,ri,z,z0) - b=zolri2(midpoint,ri,z,z0) - c=zolri2(right,ri,z,z0) -! - if ((a * b) < 0) then - right = midpoint + fx1=zolri2(x1,ri,z,z0) + fx2=zolri2(x2,ri,z,z0) + Do While (abs(x1 - x2) > 0.01) + if(abs(fx2).lt.abs(fx1))then + x1=x1-fx1/(fx2-fx1)*(x2-x1) + fx1=zolri2(x1,ri,z,z0) + zolri=x1 else - if ((c * b) < 0) then - left = midpoint - else - goto 11 - endif + x2=x2-fx2/(fx2-fx1)*(x2-x1) + fx2=zolri2(x2,ri,z,z0) + zolri=x2 endif ! enddo - 11 continue ! - zolri=midpoint return - end + end function ! ! ----------------------------------------------------------------------- @@ -1078,43 +1104,103 @@ function zolri2(zol2,ri2,z,z0) zolri2=zol2*psih2/psix2**2-ri2 ! return - end + end function ! ! ... integrated similarity functions ... ! - function psim_stable(zolf) - psim_stable=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) + function psim_stable_full(zolf) + psim_stable_full=-6.1*log(zolf+(1+zolf**2.5)**(1./2.5)) return - end + end function - function psih_stable(zolf) - psih_stable=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) + function psih_stable_full(zolf) + psih_stable_full=-5.3*log(zolf+(1+zolf**1.1)**(1./1.1)) return - end + end function - function psim_unstable(zolf) + function psim_unstable_full(zolf) x=(1.-16.*zolf)**.25 psimk=2*ALOG(0.5*(1+X))+ALOG(0.5*(1+X*X))-2.*ATAN(X)+2.*ATAN(1.) ! ym=(1.-10.*zolf)**0.33 psimc=(3./2.)*log((ym**2.+ym+1.)/3.)-sqrt(3.)*ATAN((2.*ym+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) ! - psim_unstable=(psimk+zolf**2*(psimc))/(1+zolf**2.) + psim_unstable_full=(psimk+zolf**2*(psimc))/(1+zolf**2.) return - end + end function - function psih_unstable(zolf) + function psih_unstable_full(zolf) y=(1.-16.*zolf)**.5 psihk=2.*log((1+y)/2.) ! yh=(1.-34.*zolf)**0.33 psihc=(3./2.)*log((yh**2.+yh+1.)/3.)-sqrt(3.)*ATAN((2.*yh+1)/sqrt(3.))+4.*ATAN(1.)/sqrt(3.) ! - psih_unstable=(psihk+zolf**2*(psihc))/(1+zolf**2.) + psih_unstable_full=(psihk+zolf**2*(psihc))/(1+zolf**2.) + + return + end function + +! look-up table functions + function psim_stable(zolf) + integer :: nzol + real :: rzol + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .le. 1000)then + psim_stable = psim_stab(nzol) + rzol*(psim_stab(nzol+1)-psim_stab(nzol)) + else + psim_stable = psim_stable_full(zolf) + endif + return + end function + + function psih_stable(zolf) + integer :: nzol + real :: rzol + nzol = int(zolf*100.) + rzol = zolf*100. - nzol + if(nzol+1 .le. 1000)then + psih_stable = psih_stab(nzol) + rzol*(psih_stab(nzol+1)-psih_stab(nzol)) + else + psih_stable = psih_stable_full(zolf) + endif + return + end function + + function psim_unstable(zolf) + integer :: nzol + real :: rzol + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .le. 1000)then + psim_unstable = psim_unstab(nzol) + rzol*(psim_unstab(nzol+1)-psim_unstab(nzol)) + else + psim_unstable = psim_unstable_full(zolf) + endif + return + end function + function psih_unstable(zolf) + integer :: nzol + real :: rzol + nzol = int(-zolf*100.) + rzol = -zolf*100. - nzol + if(nzol+1 .le. 1000)then + psih_unstable = psih_unstab(nzol) + rzol*(psih_unstab(nzol+1)-psih_unstab(nzol)) + else + psih_unstable = psih_unstable_full(zolf) + endif return - end + end function +!------------------------------------------------------------------- + +END MODULE module_sf_sfclayrev + +! +! ---------------------------------------------------------- +! diff --git a/wrfv2_fire/phys/module_sf_ssib.F b/wrfv2_fire/phys/module_sf_ssib.F index 70d117ef..acdc1cee 100755 --- a/wrfv2_fire/phys/module_sf_ssib.F +++ b/wrfv2_fire/phys/module_sf_ssib.F @@ -978,9 +978,11 @@ SUBROUTINE SSIB( IX, JX, DDTT, ITIME, ZLAT, SUNANGLE, & REAL, DIMENSION (2,2,2) :: RADFAC INTEGER, DIMENSION (24) :: IVUSGS + INTEGER, DIMENSION (20) :: IVMODIS REAL, DIMENSION (13) :: TD_DEPTH INTEGER :: sw_physics !choice of SW radiation scheme CHARACTER(LEN=*), INTENT(IN ) :: MMINLU !type of landuse/vegetation map + CHARACTER*256 :: message !snow REAL, DIMENSION (N2) :: SS,SSO,POROSITY,H,HO,BI,BIO,DZ,DZO,BW,BWO,BL REAL, DIMENSION (N2) :: BLO,TSSN,TSSNO,W,WO,WF,FI,FIO, FL,FLO,DMLT @@ -994,16 +996,24 @@ SUBROUTINE SSIB( IX, JX, DDTT, ITIME, ZLAT, SUNANGLE, & DATA TD_DEPTH/1.5, 1.5, 1.5, 1.5, 1.5, 1.5, 1.0, 1.0, 1.0 & & , 0.5, 0.5, 1.5, 1.5/ ! -! Check vegetation/landuse map choice -! If using USGS, translate to SSIB types (IVUSGS) +! Check vegetation/land use map choice +! USGS-SSIB vegetation type conversion DATA IVUSGS / 7, 12, 12, 12, 12, 12, 7, 9, & 8, 6, 2, 5, 1, 4, 3, 0, & 10, 3, 11, 10, 10, 10, 10, 13/ - +! MODIS-SSIB vegetation type conversion (fds Jan/2015) + DATA IVMODIS / 4, 1, 5, 2, 3, 8, 9, 6, & + 6, 7, 7, 12, 11, 12, 13, 11, & + 0, 10, 10, 10/ +! Converts vegetation/land use types IF(MMINLU.EQ.'SSIB') THEN ITYPE=IVGTYP ELSEIF(MMINLU.EQ.'USGS') THEN ITYPE=IVUSGS(IVGTYP) + ELSEIF(MMINLU.EQ.'MODIS') THEN + ITYPE=IVMODIS(IVGTYP) + ELSE IF (MMINLU .EQ. 'MODIFIED_IGBP_MODIS_NOAH') THEN + ITYPE=IVMODIS(IVGTYP) ELSE CALL wrf_error_fatal ( 'SSIB LSM only works with SSIB or USGS vegetation (landuse) map' ) ENDIF @@ -1200,9 +1210,19 @@ SUBROUTINE SSIB( IX, JX, DDTT, ITIME, ZLAT, SUNANGLE, & RSTPAR, CTLPA) ! RSTUN = RST(1) + +!*************************************************************************************** +! For water balance check later + TOTWB = WWW(1) * POROS * ZDEPTH(1) & + + WWW(2) * POROS * ZDEPTH(2) & + + WWW(3) * POROS * ZDEPTH(3) & + + CAPAC(1) + CAPAC(2) +!*************************************************************************************** +! CALL INTERCS (DTT,VCOVER,ZLT,TM,TC,TGS,CAPAC,WWW,PPC,PPL, & ROFF,ZDEPTH,POROS,CCX,CG,SATCO,SATCAP,SPWET, & EXTK,ISNOW,P0,CSOIL,dzsoil,CHISL,SMELT) +! CALL SET0(TSSNO,BWO,BLO,BIO,HO,FLO,FIO,WO,DZO, & SSO,CTO,BTO,DMLTO,WF,DHP) ! @@ -1286,6 +1306,28 @@ SUBROUTINE SSIB( IX, JX, DDTT, ITIME, ZLAT, SUNANGLE, & END IF ROFF=ROFF+SNROFF ! +!*************************************************************************************** +! Check water and energy balances (fds Jan/2015) + ENDWB = WWW(1) * POROS * ZDEPTH(1) & + + WWW(2) * POROS * ZDEPTH(2) & + + WWW(3) * POROS * ZDEPTH(3) & + + CAPAC(1) + CAPAC(2) - (PPC+PPL)/1000. + ETMASS/1000. + ROFF + ERRW = TOTWB - ENDWB + IF(ABS(ERRW) .GT. 0.0001) THEN + WRITE(message,*) 'SSIB WATER BALANCE WARNING: ',ERRW + CALL wrf_message ( message ) + ENDIF +! + ZLHS = RADT(1) + RADT(2) - CHF - SHF + ZRHS = HFLUX + (ECT + ECI + EGT + EGI + EGS)/DTT + ERRH = ZLHS - ZRHS + IF(ABS(ERRH) .GT. 1.) THEN + WRITE(message,*) 'SSIB ENERGY BALANCE WARNING: ',ERRH + CALL wrf_message ( message ) + ENDIF +!*************************************************************************************** + + !------------------------------------------------------------------------ SOILM=(WWW(1)*ZDEPTH(1)+WWW(2)*ZDEPTH(2)+WWW(3)*ZDEPTH(3))*POROS !------------------------------------------------------------------------ diff --git a/wrfv2_fire/phys/module_sf_urban.F b/wrfv2_fire/phys/module_sf_urban.F index 186efc17..772ee954 100644 --- a/wrfv2_fire/phys/module_sf_urban.F +++ b/wrfv2_fire/phys/module_sf_urban.F @@ -19,6 +19,7 @@ MODULE module_sf_urban REAL, ALLOCATABLE, DIMENSION(:) :: RW_TBL REAL, ALLOCATABLE, DIMENSION(:) :: HGT_TBL REAL, ALLOCATABLE, DIMENSION(:) :: AH_TBL + REAL, ALLOCATABLE, DIMENSION(:) :: ALH_TBL REAL, ALLOCATABLE, DIMENSION(:) :: BETR_TBL REAL, ALLOCATABLE, DIMENSION(:) :: BETB_TBL REAL, ALLOCATABLE, DIMENSION(:) :: BETG_TBL @@ -67,6 +68,20 @@ MODULE module_sf_urban REAL, DIMENSION(1:24) :: ahdiuprf ! ah diurnal profile, tloc: 1-24 REAL, DIMENSION(1:24) :: hsequip_tbl +!===Yang, 2014/10/08, urban hydrological processes for single layer UCM=== + INTEGER :: IMP_SCHEME, IRI_SCHEME + INTEGER :: alhoption ! anthropogenic latent heat option + INTEGER :: groption ! anthropogenic latent heat option + REAL :: fgr ! green roof fraction + REAL :: oasis ! urban oasis parameter + REAL, DIMENSION(1:4) :: DZGR ! Layer depth of green roof + REAL, DIMENSION(1:4) :: alhseason ! seasonal variation of alh + REAL, DIMENSION(1:48) :: alhdiuprf ! alh diurnal profile, tloc2: 1-48 + REAL, DIMENSION(1:3) :: porimp ! porosity of pavement over impervious surface + REAL, DIMENSION(1:3) :: dengimp ! maximum water-holding depth of pavement + +!===end hydrological processes=== + INTEGER :: allocate_status ! INTEGER :: num_roof_layers @@ -189,6 +204,7 @@ MODULE module_sf_urban ! Following parameter are assigned in run/URBPARM.TBL ! ! AH [ W m{-2} ] : anthropogenic heat ( W m{-2} in the table, converted internally to cal cm{-2} ) +! ALH [ W m{-2} ] : anthropogenic latent heat ( W m{-2} in the table, converted internally to cal cm{-2} ) ! CAPR[ J m{-3} K{-1} ] : heat capacity of roof ( units converted in code to [ cal cm{-3} deg{-1} ] ) ! CAPB[ J m{-3} K{-1} ] : heat capacity of building wall ( units converted in code to [ cal cm{-3} deg{-1} ] ) ! CAPG[ J m{-3} K{-1} ] : heat capacity of road ( units converted in code to [ cal cm{-3} deg{-1} ] ) @@ -222,7 +238,11 @@ MODULE module_sf_urban ! [1: M-O Similarity Theory, 2: Empirical Form (recommend)] ! TS_SCHEME [integer 1 or 2] : Scheme for computing surface temperature (for roof, wall, and road) ! [1: 4-layer model, 2: Force-Restore method] -! +! IMP_SCHEME[integer 1 or 2] : Evaporation scheme for impervious surfaces (roof, wall, and road) +! [1: Hypothesized evaporation during large rainfall events +! [2: Water-holding scheme over impervious surface +! IRI_SCHEME[integer 0 or 1] : Scheme for urban irrigation +! [0: No irrigation, 1: Summertime (May-Sep) irrigation everyday at 9pm] !for BEP ! numdir [ - ] : Number of street directions defined for a particular urban category ! street_direction [ deg ] : Direction of streets for a particular urban category and a particular street direction @@ -251,6 +271,7 @@ MODULE module_sf_urban ! Kusaka et al. (2001) Bound.-Layer Meteor., vol.101, p329-358 ! ! History: +! 2014/10, modified by Jiachuan Yang (ASU) ! 2006/06 modified by H. Kusaka (Univ. Tsukuba), M. Tewari ! 2005/10/26, modified by Fei Chen, Mukul Tewari ! 2003/07/21 WRF , modified by H. Kusaka of CRIEPI (NCAR/MMM) @@ -277,7 +298,9 @@ SUBROUTINE urban(LSOLAR, & ! L GZ1OZ0, & ! O CMR_URB,CHR_URB,CMC_URB,CHC_URB, & ! I/O U10,V10,TH2,Q2,UST,mh_urb,stdh_urb,lf_urb, & ! O - lp_urb,hgt_urb,frc_urb,lb_urb,zo_check) + lp_urb,hgt_urb,frc_urb,lb_urb,zo_check, & ! O + CMCR,TGR,TGRL,SMR,CMGR_URB,CHGR_URB,jmonth, & ! H + DRELR,DRELB,DRELG,FLXHUMR,FLXHUMB,FLXHUMG) IMPLICIT NONE @@ -320,7 +343,7 @@ SUBROUTINE urban(LSOLAR, & ! L INTEGER, INTENT(IN) :: UTYPE ! urban type [1=Commercial/Industrial, 2=High-intensity residential, ! 3=low-intensity residential] - + INTEGER, INTENT(IN) :: jmonth! current month REAL, INTENT(IN) :: TA ! potential temp at 1st atmospheric level [K] REAL, INTENT(IN) :: QA ! mixing ratio at 1st atmospheric level [kg/kg] REAL, INTENT(IN) :: UA ! wind speed at 1st atmospheric level [m/s] @@ -408,11 +431,30 @@ SUBROUTINE urban(LSOLAR, & ! L REAL, DIMENSION(1:num_wall_layers), INTENT(INOUT) :: TBL REAL, DIMENSION(1:num_road_layers), INTENT(INOUT) :: TGL +!===Yang,2014/10/08, urban hydrological variables for single layer UCM=== +! FLXHUMR: evaporation over roof [m/s]; FLXHUMRP: at previous time step [m/s] +! FLXHUMB: evaporation over wall [m/s]; FLXHUMBP: at previous time step [m/s] +! FLXHUMG: evaporation over road [m/s]; FLXHUMGP: at previous time step [m/s] + +! DRELR: water retention depth on roof [m]; DRELRP: at previous time stp [m] +! DRELB: water retention depth on wall [m]; DRELBP: at previous time stp [m] +! DRELG: water retention depth on road [m]; DRELGP: at previous time stp [m] + +! TGR: green roof surface temperature [K]; TGRP: at previous time step [K] +! CMCR: Canopy intercepted water on green roof; CMCRP: at previous time step +! SMR: soil moisture at each layer on roof [-]; SMRP: at previous time step +! TGRL:layer temperature on green roof [K] + + REAL, INTENT(INOUT):: FLXHUMR,FLXHUMB,FLXHUMG,DRELR,DRELB,DRELG + REAL, INTENT(INOUT):: TGR,CMCR,CHGR_URB,CMGR_URB + REAL, DIMENSION(1:num_roof_layers), INTENT(INOUT) :: SMR + REAL, DIMENSION(1:num_roof_layers), INTENT(INOUT) :: TGRL + !------------------------------------------------------------------------------- ! L: Local variables from read_param !------------------------------------------------------------------------------- - REAL :: ZR, Z0C, Z0HC, ZDC, SVF, R, RW, HGT, AH + REAL :: ZR, Z0C, Z0HC, ZDC, SVF, R, RW, HGT, AH, ALH REAL :: SIGMA_ZED REAL :: CAPR, CAPB, CAPG, AKSR, AKSB, AKSG, ALBR, ALBB, ALBG REAL :: EPSR, EPSB, EPSG, Z0R, Z0B, Z0G, Z0HB, Z0HG @@ -449,12 +491,12 @@ SUBROUTINE urban(LSOLAR, & ! L REAL :: W, VFGS, VFGW, VFWG, VFWS, VFWW REAL :: HOUI1, HOUI2, HOUI3, HOUI4, HOUI5, HOUI6, HOUI7, HOUI8 REAL :: SLX, SLX1, SLX2, SLX3, SLX4, SLX5, SLX6, SLX7, SLX8 - REAL :: FLXTHR, FLXTHB, FLXTHG, FLXHUMR, FLXHUMB, FLXHUMG + REAL :: FLXTHR, FLXTHB, FLXTHG REAL :: SR, SB, SG, RR, RB, RG REAL :: SR1, SR2, SB1, SB2, SG1, SG2, RR1, RR2, RB1, RB2, RG1, RG2 REAL :: HR, HB, HG, ELER, ELEB, ELEG, G0R, G0B, G0G REAL :: ALPHAC, ALPHAR, ALPHAB, ALPHAG - REAL :: CHC, CHR, CHB, CHG, CDC, CDR, CDB, CDG + REAL :: CHC, CHR, CHB, CHG, CDC, CDR, CDB, CDG, CDGR REAL :: C1R, C1B, C1G, TE, TC1, TC2, QC1, QC2, QS0R, QS0B, QS0G,RHO,ES REAL :: DESDT @@ -492,7 +534,50 @@ SUBROUTINE urban(LSOLAR, & ! L REAL :: lambda_f,alpha_macd,beta_macd,lambda_fr INTEGER :: iteration, K, NUDAPT - INTEGER :: tloc + INTEGER :: tloc, tloc2, Kalh + +!===Yang,2014/10/08, urban hydrological variables for single layer UCM=== + REAL :: FLXHUMRP, FLXHUMBP, FLXHUMGP + REAL :: DRELRP, DRELBP, DRELGP + REAL :: TGRP, CMCRP + REAL, DIMENSION(1:num_roof_layers) :: ZSOILR, ETR, SMRP +!===Define parameters for green roof=== + INTEGER :: KZ + REAL :: RUNOFF1, RUNOFF2, RUNOFF3 + REAL :: SGR, SGR1, T1VGR, CHGR, ALPHAGR + REAL :: FLXTHGR, FLXHUMGR, HGR, ELEGR, G0GR + REAL :: QS0GR, EPGR, EDIR, ETTR, FV, DTGR, DRIP +! REAL :: DQS0GRDTGR, ETR, ECR,RAIN1, RAINDR, DEW, ETAR, BETGR + REAL :: DQS0GRDTGR, ECR,RAIN1, RAINDR, DEW, ETAR, BETGR +! REAL :: DF1, RGR, RGRR, RCH, RR1, RR2, YY, ZZ1, SSOILR + REAL :: DF1, RGR, RGRR, RCH, YY, ZZ1, SSOILR + REAL :: DRRDTGR, DHRDTGR, DELERDTGR, DG0RDTGR, DFDVT + real,parameter :: SHDFAC = 0.80 ! Vegetated area fraction of green roof vegetation + real,parameter :: ALBV = 0.20 ! green roof albedo + real,parameter :: EPSV = 0.93 ! green roof emissivity + real,parameter :: LAI = 1.50 ! leaf area index on green roof + real,parameter :: CMCMAX = 0.5E-3 ! Maximum canopy interception capacity + real,parameter :: SMCREF = 0.329 ! Reference soil moisture + real,parameter :: SMCDRY = 0.066 ! Residual soil moisture + real,parameter :: SMCWLT = 0.084 ! Wilting point + real,parameter :: SMCMAX = 0.439 ! Saturated soil moisture + real,parameter :: RSMAX = 5000 ! Maximum stomatal resistance + real,parameter :: RSMIN = 100 ! Minimum stomatal resistance + real,parameter :: RGL = 100 ! Radiation limit where photosynthesis begins + real,parameter :: CFACTR = 0.5 ! Parameter used in the canopy inteception calculation + real,parameter :: DWSAT = 0.143E-4 ! Saturated soil conductivity + real,parameter :: DKSAT = 3.38E-6 ! Saturated soil diffusivity + real,parameter :: BEXP = 5.25 ! B parameter in soil hydraulic calculation + real,parameter :: FXEXP = 2.0 ! Parameter for computing direct soil evaporation + real,parameter :: ZBOT = -2.0 + real,parameter :: QUARTZ = 0.40 + real,parameter :: CSOIL = 2.0E+6 + real,parameter :: HS = 36 + integer,parameter :: NROOT = 2 ! Root depth layer of green roof + integer,parameter :: NGR = 4 ! Layer of green roof + integer,parameter :: IMPR = 1 + integer,parameter :: IMPB = 2 + integer,parameter :: IMPG = 3 !------------------------------------------------------------------------------- ! Set parameters @@ -501,8 +586,15 @@ SUBROUTINE urban(LSOLAR, & ! L ! Miao, 2007/01/17, cal. ah if(ahoption==1) then tloc=mod(int(OMG/PI*180./15.+12.+0.5 ),24) + if(tloc.lt.0) tloc=tloc+24 if(tloc==0) tloc=24 endif +! Yang, 2014/10/08, cal. alh + if(alhoption==1) then + tloc2=mod(int((OMG/PI*180./15.+12.)*2.+0.5 ),48) + if(tloc2.lt.0) tloc2=tloc2+48 + if(tloc2==0) tloc2=48 + endif CALL read_param(UTYPE,ZR,SIGMA_ZED,Z0C,Z0HC,ZDC,SVF,R,RW,HGT, & AH,CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB, & @@ -514,7 +606,7 @@ SUBROUTINE urban(LSOLAR, & ! L HPERCENT_BIN, & !end BEP BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME, & - AKANDA_URBAN) + AKANDA_URBAN,ALH) ! Glotfelty, 2012/07/05, NUDAPT Modification @@ -665,6 +757,16 @@ SUBROUTINE urban(LSOLAR, & ! L ! Miao, 2007/01/17, cal. ah if(ahoption==1) AH=AH*ahdiuprf(tloc) +! Yang, 2014/10/08, cal. alh + Kalh=0 + if(alhoption==1) THEN + if(jmonth==3 .or. jmonth==4 .or. jmonth==5) Kalh=1 + if(jmonth==6 .or. jmonth==7 .or. jmonth==8) Kalh=2 + if(jmonth==9 .or. jmonth==10.or. jmonth==11)Kalh=3 + if(jmonth==12.or. jmonth==1 .or. jmonth==2) Kalh=4 + endif + if(alhoption==1) ALH = ALH*alhdiuprf(tloc2)*alhseason(Kalh) + IF( ZDC+Z0C+2. >= ZA) THEN CALL wrf_error_fatal ("ZDC + Z0C + 2m is larger than the 1st WRF level "// & "Stop in subroutine urban - change ZDC and Z0C" ) @@ -701,6 +803,29 @@ SUBROUTINE urban(LSOLAR, & ! L TCP=TC QCP=QC +!===Yang,2014/10/08, urban hydrological variables for single layer UCM=== + FLXHUMRP = FLXHUMR + FLXHUMBP = FLXHUMB + FLXHUMGP = FLXHUMG + DRELRP = DRELR + DRELBP = DRELB + DRELGP = DRELG + TGRP = TGR + CMCRP = CMCR + SMRP = SMR + +!===Yang,2014/10/08, urban irrigation, May-Sep, 9-10pm + IF(IRI_SCHEME==1) THEN + IF (tloc==21 .or. tloc==22) THEN + IF(jmonth==5 .or. jmonth==6 .or. jmonth ==7 .or. & + jmonth==8 .or. jmonth==9 ) THEN + DO KZ = 1,2 + SMRP(KZ)= SMCREF + END DO + ENDIF + ENDIF + ENDIF + TAV=TA*(1.+0.61*QA) PS=RHOO*287.*TAV/100. ![hPa] @@ -733,6 +858,7 @@ SUBROUTINE urban(LSOLAR, & ! L IF(.NOT.SHADOW) THEN ! no shadow effects model SR1=SX*(1.-ALBR) + SGR1=SX*(1.-ALBV) SG1=SX*VFGS*(1.-ALBG) SB1=SX*VFWS*(1.-ALBB) SG2=SB1*ALBB/(1.-ALBB)*VFGW*(1.-ALBG) @@ -778,6 +904,7 @@ SUBROUTINE urban(LSOLAR, & ! L SLX=(SLX1+SLX2+SLX3+SLX4+SLX5+SLX6+SLX7+SLX8)/8. SR1=SD*(1.-ALBR)+SQ*(1.-ALBR) + SGR1=SD*(1.-ALBV)+SQ*(1.-ALBV) SG1=SD*(RW-SLX)/RW*(1.-ALBG)+SQ*VFGS*(1.-ALBG) SB1=SD*SLX/W*(1.-ALBB)+SQ*VFWS*(1.-ALBB) SG2=SB1*ALBB/(1.-ALBB)*VFGW*(1.-ALBG) @@ -786,15 +913,21 @@ SUBROUTINE urban(LSOLAR, & ! L END IF SR=SR1 + SGR=SGR1 SG=SG1+SG2 SB=SB1+SB2 + IF (GROPTION ==1) THEN + SNET=R*FGR*SGR+R*(1.-FGR)*SR+W*SB+RW*SG + ELSE SNET=R*SR+W*SB+RW*SG + ENDIF ELSE SR=0. SG=0. + SGR=0. SB=0. SNET=0. @@ -824,7 +957,30 @@ SUBROUTINE urban(LSOLAR, & ! L ALPHAR = RHO*CP*CHR_URB CHR=ALPHAR/RHO/CP/UA - IF(RAIN > 1.) BETR=0.7 +! Yang, 03/12/2014 -- LH for impervious roof surface + RAIN1 = RAIN * 0.001 /3600 ! CONVERT FROM mm/hr to m/s + IF (IMP_SCHEME==1) then + IF (RAIN > 1.) BETR=0.7 + ENDIF + + IF (IMP_SCHEME==2) then + IF (FLXHUMRP <= 0.) FLXHUMRP = 0. +! Compute water retention depth from previous time step + DrelR = DrelRP+(RAIN1-FLXHUMRP)*DELT/porimp(IMPR) + IF (RAIN > 0. .AND. DrelR < DrelRP) DrelR = DrelRP + + IF (DrelR <= 0.) then + DrelR = 0.0 + BETR = 0.0 + ELSEIf (DrelR <= dengimp(IMPR)) then + BETR = DrelR/dengimp(IMPR)*porimp(IMPR) + ELSE + DrelR = dengimp(IMPR) + BETR = porimp(IMPR) + ENDIF + + IF ( BETR < 1.E-5 ) BETR = 0.0 + ENDIF IF (TS_SCHEME == 1) THEN @@ -897,6 +1053,113 @@ SUBROUTINE urban(LSOLAR, & ! L FLXTHR=HR/RHO/CP/100. FLXHUMR=ELER/RHO/EL/100. +!------------------------------------------------------------------------------- +! Green Roof +! Must use multiple layers scheme (TS_SCHEME=1) +!------------------------------------------------------------------------------- + IF (GROPTION == 1) THEN + T1VGR = TGRP* (1.0+ 0.61 * QA) + RLMO_URB=0.0 + CALL SFCDIF_URB (ZA,Z0R,T1VGR,TH2V,UA,AKANDA_URBAN,CMGR_URB,CHGR_URB,RLMO_URB,CDGR) + ALPHAGR = RHO*CP*CHGR_URB + CHGR=ALPHAGR/RHO/CP/UA + RUNOFF1 = 0.0 + RUNOFF2 = 0.0 + RUNOFF3 = 0.0 + + KZ = 1 + ZSOILR (KZ) = - DZGR (KZ) + DO KZ = 2,NGR + ZSOILR (KZ) = - DZGR(KZ) + ZSOILR (KZ -1) + END DO + + DO ITERATION=1,100 + KZ=1 + ES=6.11*EXP( (2.5*10.**6./461.51)*(TGRP-273.15)/(273.15*TGRP) ) + DESDT=(2.5*10.**6./461.51)*ES/(TGRP**2.) + QS0GR=0.622*ES/(PS-0.378*ES) + DQS0GRDTGR = DESDT*0.622*PS/((PS-0.378*ES)**2.) + EPGR=RHOO*CHGR*UA*(QS0GR-QA) ! Potential evaporation [kg/m2/s] + + IF (EPGR > 0.0) THEN + ! Direct evaporation from soil on green roof + CALL DIREVAP (EDIR,EPGR,SMRP(KZ),SHDFAC,SMCMAX,SMCDRY,FXEXP) + ! Evapotranspiration and canopy intercepted evaporation + CALL TRANSP (ETTR,ETR,ECR,SHDFAC,EPGR,CMCRP,CFACTR,CMCMAX,LAI,RSMIN,RSMAX,RGL,SX, & + TGRP,TA,QA,SMRP,SMCWLT,SMCREF,CPP,PS,CHGR,EPSV,DELT,NROOT,NGR,DZGR, & + ZSOILR,HS) + ! Update moisture in soil layers + CALL SMFLX (SMRP,SMR,NGR,CMCRP,CMCR,DELT,RAIN,ZSOILR,SMCMAX,BEXP,SMCWLT,DKSAT,& + DWSAT,SHDFAC,CMCMAX,RUNOFF1,RUNOFF2,RUNOFF3,EDIR,ECR,ETR,DRIP) + else + DEW = - EPGR + RAINDR = RAIN + DEW * 3600. + EDIR=0.0 + ECR =0.0 + ETTR=0.0 + CALL SMFLX (SMRP,SMR,NGR,CMCRP,CMCR,DELT,RAINDR,ZSOILR,SMCMAX,BEXP,SMCWLT,DKSAT,& + DWSAT,SHDFAC,CMCMAX,RUNOFF1,RUNOFF2,RUNOFF3,EDIR,ECR,ETR,DRIP) + END IF +! ---------------------------------------------------------------------- +! CONVERT MODELED EVAPOTRANSPIRATION FROM M S-1 TO KG M-2 S-1. +! ---------------------------------------------------------------------- + EDIR = EDIR * 1000.0 + ETTR = ETTR * 1000.0 + ECR = ECR * 1000.0 + ETAR = EDIR + ETTR + ECR + IF (ETAR < 1.E-20) ETAR = 0.0 + + IF ( EPGR <= 0.0 ) THEN + BETGR = 0.0 + ELSE + BETGR = ETAR / EPGR + END IF + ELEGR= ETAR* RHO * EL /RHOO * 100 + + CALL TDFCND (DF1,SMR(KZ), QUARTZ, SMCMAX ) + DF1 = DF1 * EXP(-2.0 * SHDFAC) + RGR = EPSV*(RX-SIG*(TGRP**4.)/60.) + RGRR= (SGR+RGR) * 697.7 * 60. + RCH = RHOO*CPP*CHGR + RR1 = EPSV*(TA**4) * 6.48E-8 / (PS* CHGR) + 1.0 + IF (RAIN > 0.0) then + RR2 = RR1 + RAIN / 3600 * 4.218E+3 / RCH + else + RR2 = RR1 + end if + YY = TA + (RGRR / RCH - BETGR * EPGR * ELL/ RCH) / RR2 + ZZ1 = DF1 / (-0.5 * ZSOILR (KZ) * RCH * RR2 ) + 1.0 + ! Update temperature in soil layer + CALL SHFLX (SSOILR,TGRL,SMR,SMCMAX,NGR,TGRP,DELT,YY,ZZ1,ZSOILR, & + TRLEND,ZBOT,SMCWLT,DF1,QUARTZ,CSOIL,CAPR) + + HGR=RHO*CP*CHGR*UA*(TGRP-TA)*100. + RUNOFF3 = RUNOFF3/ DELT + RUNOFF2 = RUNOFF2+ RUNOFF3 + G0GR = SSOILR / 697.7 / 60 + + FV = SGR + RGR - HGR - ELEGR - G0GR + DRRDTGR = (-4.*EPSV*SIG*TGRP**3.)/60. + DHRDTGR = RHO*CP*CHGR*UA*100. + DELERDTGR = RHO*EL*CHGR*UA*BETGR*DQS0GRDTGR*100. + DG0RDTGR = 2.*DF1/ DZGR(KZ) * ( 1.0 / 4.1868 ) * 1.E-4 + DFDVT = DRRDTGR - DHRDTGR - DELERDTGR - DG0RDTGR + DTGR = FV/DFDVT/ 6 + TGR = TGRP - DTGR + TGRP = TGR + + IF( ABS(FV) < 0.0001 .AND. ABS(DTGR) < 0.001 ) then + EXIT + ENDIF + END DO + + FLXTHGR=HGR/RHO/CP/100. + FLXHUMGR=ELEGR/RHO/EL/100. +ELSE + FLXTHGR=0. + FLXHUMGR=0. +ENDIF + !------------------------------------------------------------------------------- ! Wall and Road !------------------------------------------------------------------------------- @@ -941,8 +1204,45 @@ SUBROUTINE urban(LSOLAR, & ! L CHB=ALPHAB/RHO/CP/UC CHG=ALPHAG/RHO/CP/UC +!Yang 10/10/2013 -- LH from impervious wall and ground + IF (IMP_SCHEME==1) then BETB=0.0 IF(RAIN > 1.) BETG=0.7 + ENDIF + + IF (IMP_SCHEME==2) then + IF (FLXHUMBP <= 0.) FLXHUMBP = 0. + IF (FLXHUMGP <= 0.) FLXHUMGP = 0. +! Compute water retention from previous time step for wall and ground + DrelB = DrelBP+(RAIN1-FLXHUMBP)*DELT/porimp(IMPB) + IF (RAIN > 0. .AND. DrelB < DrelBP) DrelB = DrelBP + DrelG = DrelGP+(RAIN1-FLXHUMGP)*DELT/porimp(IMPG) + IF (RAIN > 0. .AND. DrelG < DrelGP) DrelG = DrelGP + + IF (DrelB <= 0.) then + DrelB = 0.0 + BETB = 0.0 + ELSEIf (DrelB <= dengimp(IMPB)) then + BETB = DrelB/dengimp(IMPB)*porimp(IMPB) + ELSE + DrelB = dengimp(IMPB) + BETB = porimp(IMPB) + ENDIF + + IF (DrelG <= 0.) then + DrelG = 0.0 + BETG = 0.0 + ELSEIf (DrelG <= dengimp(IMPG)) then + BETG = DrelG/dengimp(IMPG)*porimp(IMPG) + ELSE + DrelG = dengimp(IMPG) + BETG = porimp(IMPG) + ENDIF + + if ( BETG < 1.E-5 ) BETG = 0.0 + if ( BETB < 1.E-5 ) BETB = 0.0 + +ENDIF IF (TS_SCHEME == 1) THEN @@ -1143,17 +1443,36 @@ SUBROUTINE urban(LSOLAR, & ! L !------------------------------------------------------------------------------- ! Total Fluxes from Urban Canopy !------------------------------------------------------------------------------- - - FLXUV = ( R*CDR + RW*CDC )*UA*UA -! Miao, 2007/01/17, cal. ah +!===Yang, 2014/10/08, cal. ah. alh. green roof=== + if(groption==1) then + if(ahoption==1) then + FLXTH = ((1.-FGR)*R*FLXTHR + FGR*R*FLXTHGR + W*FLXTHB + RW*FLXTHG)+ AH/RHOO/CPP + else + FLXTH = ((1.-FGR)*R*FLXTHR + FGR*R*FLXTHGR + W*FLXTHB + RW*FLXTHG) + endif + if(alhoption==1) then + FLXHUM = ((1.-FGR)*R*FLXHUMR + FGR*R*FLXHUMGR + W*FLXHUMB + RW*FLXHUMG)+ ALH/RHOO/ELL + else + FLXHUM = ((1.-FGR)*R*FLXHUMR + FGR*R*FLXHUMGR + W*FLXHUMB + RW*FLXHUMG) + endif + FLXUV = ((1.-FGR)*R*CDR + FGR*R*CDGR + RW*CDC )*UA*UA + FLXG = ((1.-FGR)*R*G0R + FGR*R*G0GR+ W*G0B + RW*G0G) + LNET = (1.-FGR) * R * RR + FGR *R* RGR + W * RB + RW * RG + else if(ahoption==1) then FLXTH = ( R*FLXTHR + W*FLXTHB + RW*FLXTHG ) + AH/RHOO/CPP else FLXTH = ( R*FLXTHR + W*FLXTHB + RW*FLXTHG ) endif - FLXHUM = ( R*FLXHUMR + W*FLXHUMB + RW*FLXHUMG ) + if(alhoption==1) then + FLXHUM = ( R*FLXHUMR + W*FLXHUMB + RW*FLXHUMG )+ ALH/RHOO/ELL + else + FLXHUM = ( R*FLXHUMR + W*FLXHUMB + RW*FLXHUMG ) + endif + FLXUV = ( R*CDR + RW*CDC )*UA*UA FLXG = ( R*G0R + W*G0B + RW*G0G ) LNET = R*RR + W*RB + RW*RG + endif !---------------------------------------------------------------------------- ! Convert Unit: FLUXES and u* T* q* --> WRF @@ -1522,11 +1841,11 @@ SUBROUTINE read_param(UTYPE, & ! in HPERCENT_BIN, & ! out !end BEP BOUNDR,BOUNDB,BOUNDG,CH_SCHEME,TS_SCHEME, & ! out - AKANDA_URBAN) ! out + AKANDA_URBAN,ALH) ! out INTEGER, INTENT(IN) :: UTYPE - REAL, INTENT(OUT) :: ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH, & + REAL, INTENT(OUT) :: ZR,Z0C,Z0HC,ZDC,SVF,R,RW,HGT,AH,ALH, & CAPR,CAPB,CAPG,AKSR,AKSB,AKSG,ALBR,ALBB,ALBG, & SIGMA_ZED, & EPSR,EPSB,EPSG,Z0R,Z0B,Z0G,Z0HB,Z0HG, & @@ -1555,6 +1874,7 @@ SUBROUTINE read_param(UTYPE, & ! in RW= RW_TBL(UTYPE) HGT= HGT_TBL(UTYPE) AH= AH_TBL(UTYPE) + ALH= ALH_TBL(UTYPE) BETR= BETR_TBL(UTYPE) BETB= BETB_TBL(UTYPE) BETG= BETG_TBL(UTYPE) @@ -1708,6 +2028,8 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating HGT_TBL in urban_param_init') ALLOCATE( AH_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating AH_TBL in urban_param_init') + ALLOCATE( ALH_TBL(ICATE), stat=allocate_status ) + if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating ALH_TBL in urban_param_init') ALLOCATE( BETR_TBL(ICATE), stat=allocate_status ) if(allocate_status /= 0) CALL wrf_error_fatal('Error allocating BETR_TBL in urban_param_init') ALLOCATE( BETB_TBL(ICATE), stat=allocate_status ) @@ -1826,6 +2148,8 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) road_width(1:icate) else if (name == "AH") then read(string(indx+1:),*) ah_tbl(1:icate) + else if (name == "ALH") then + read(string(indx+1:),*) alh_tbl(1:icate) else if (name == "FRC_URB") then read(string(indx+1:),*) frc_urb_tbl(1:icate) else if (name == "CAPR") then @@ -1902,6 +2226,28 @@ SUBROUTINE urban_param_init(DZR,DZB,DZG,num_soil_layers, & read(string(indx+1:),*) ahoption else if (name == "AHDIUPRF") then read(string(indx+1:),*) ahdiuprf(1:24) + else if (name == "ALHOPTION") then + read(string(indx+1:),*) alhoption + else if (name == "ALHSEASON") then + read(string(indx+1:),*) alhseason(1:4) + else if (name == "ALHDIUPRF") then + read(string(indx+1:),*) alhdiuprf(1:48) + else if (name == "PORIMP") then + read(string(indx+1:),*) porimp(1:3) + else if (name == "DENGIMP") then + read(string(indx+1:),*) dengimp(1:3) + else if (name == "IMP_SCHEME") then + read(string(indx+1:),*) imp_scheme + else if (name == "IRI_SCHEME") then + read(string(indx+1:),*) iri_scheme + else if (name == "OASIS") then + read(string(indx+1:),*) oasis + else if (name == "GROPTION") then + read(string(indx+1:),*) groption + else if (name == "FGR") then + read(string(indx+1:),*) fgr + else if (name == "DZGR") then + read(string(indx+1:),*) dzgr(1:4) !for BEP else if (name == "STREET PARAMETERS") then @@ -2073,9 +2419,12 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, SFVENT_URB3D,LFVENT_URB3D, & ! inout SFWIN1_URB3D,SFWIN2_URB3D, & ! inout SFW1_URB3D,SFW2_URB3D,SFR_URB3D,SFG_URB3D, & ! inout - LP_URB2D,HI_URB2D,LB_URB2D, & !inout - HGT_URB2D,MH_URB2D,STDH_URB2D, & !inout - LF_URB2D, & !inout + LP_URB2D,HI_URB2D,LB_URB2D, & ! inout + HGT_URB2D,MH_URB2D,STDH_URB2D, & ! inout + LF_URB2D, & ! inout + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & ! inout + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & ! inout + FLXHUMR_URB2D, FLXHUMB_URB2D, FLXHUMG_URB2D, & ! inout A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP, & ! inout multi-layer urban A_E_BEP,B_U_BEP,B_V_BEP, & ! inout multi-layer urban B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP, & ! inout multi-layer urban @@ -2105,12 +2454,23 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D + ! REAL, DIMENSION(ims:ime, 1:num_roof_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D ! REAL, DIMENSION(ims:ime, 1:num_wall_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D ! REAL, DIMENSION(ims:ime, 1:num_road_layers, jms:jme), INTENT(INOUT) :: TGL_URB3D REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TRL_URB3D REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TBL_URB3D REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TGL_URB3D + REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: TGRL_URB3D + REAL, DIMENSION(ims:ime, 1:num_soil_layers, jms:jme), INTENT(INOUT) :: SMR_URB3D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D @@ -2360,7 +2720,15 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, XXXG_URB2D(I,J)=0. XXXC_URB2D(I,J)=0. + DRELR_URB2D(I,J) = 0. + DRELB_URB2D(I,J) = 0. + DRELG_URB2D(I,J) = 0. + FLXHUMR_URB2D(I,J) = 0. + FLXHUMB_URB2D(I,J) = 0. + FLXHUMG_URB2D(I,J) = 0. + CMCR_URB2D(I,J) = 0. + TGR_URB2D(I,J)=TSURFACE0_URB(I,J)+0. TC_URB2D(I,J)=TSURFACE0_URB(I,J)+0. TR_URB2D(I,J)=TSURFACE0_URB(I,J)+0. TB_URB2D(I,J)=TSURFACE0_URB(I,J)+0. @@ -2379,6 +2747,16 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, TRL_URB3D(I,2,J)=0.5*(TLAYER0_URB(I,1,J)+TLAYER0_URB(I,2,J)) TRL_URB3D(I,3,J)=TLAYER0_URB(I,2,J)+0. TRL_URB3D(I,4,J)=TLAYER0_URB(I,2,J)+(TLAYER0_URB(I,3,J)-TLAYER0_URB(I,2,J))*0.29 + + TGRL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0. + TGRL_URB3D(I,2,J)=0.5*(TLAYER0_URB(I,1,J)+TLAYER0_URB(I,2,J)) + TGRL_URB3D(I,3,J)=TLAYER0_URB(I,2,J)+0. + TGRL_URB3D(I,4,J)=TLAYER0_URB(I,2,J)+(TLAYER0_URB(I,3,J)-TLAYER0_URB(I,2,J))*0.29 + + SMR_URB3D(I,1,J)=0.2 + SMR_URB3D(I,2,J)=0.2 + SMR_URB3D(I,3,J)=0.2 + SMR_URB3D(I,4,J)=0. ! END DO ! DO K=1,num_wall_layers @@ -2795,4 +3173,856 @@ SUBROUTINE SFCDIF_URB (ZLM,Z0,THZ0,THLM,SFCSPD,AKANDA,AKMS,AKHS,RLMO,CD) END SUBROUTINE SFCDIF_URB ! ---------------------------------------------------------------------- !=========================================================================== +! DIREVAP +! CALCULATE DIRECT SOIL EVAPORATION +!=========================================================================== + SUBROUTINE DIREVAP (EDIR,ETP,SMC,SHDFAC,SMCMAX,SMCDRY,FXEXP) + + REAL, INTENT(IN) :: ETP,SMC,SHDFAC,SMCMAX,SMCDRY,FXEXP + REAL, INTENT(OUT) :: EDIR + REAL :: FX, SRATIO + +! ---------------------------------------------------------------------- +! FX > 1 REPRESENTS DEMAND CONTROL +! FX < 1 REPRESENTS FLUX CONTROL +! ---------------------------------------------------------------------- + SRATIO = (SMC - SMCDRY) / (SMCMAX - SMCDRY) + IF (SRATIO > 0.) THEN + FX = SRATIO**FXEXP + FX = MAX ( MIN ( FX, 1. ) ,0. ) + ELSE + FX = 0. + ENDIF + EDIR = FX * ( 1.0- SHDFAC ) * ETP * 0.001 + + END SUBROUTINE DIREVAP +!=========================================================================== +! TRANSP +! CALCULATE EVAPOTRANSPIRATION FOR VEGETATIO SURFACE +!=========================================================================== + + SUBROUTINE TRANSP (ETT,ET,EC,SHDFAC,ETP1,CMC,CFACTR,CMCMAX,LAI,RSMIN,RSMAX,RGL,SX, & + TS,TA,QA,SMC,SMCWLT,SMCREF,CPP,PS,CH,EPSV,DELT, NROOT,NSOIL, & + DZVR, ZSOIL, HS) + INTEGER, INTENT(IN) :: NROOT, NSOIL + REAL, INTENT(IN) :: SHDFAC,ETP1,CMC,CFACTR,CMCMAX,LAI,RSMIN,RSMAX,RGL,SX,TA + REAL, INTENT(IN) :: TS,QA, SMCWLT, SMCREF, CPP, PS,CH, EPSV, DELT, HS + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL, DZVR, SMC + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: ET + REAL, INTENT(OUT) :: EC, ETT + REAL :: RC, RCS, RCT, RCQ, RCSOIL, FF, WS, SLV, DESDT + REAL :: SIGMA, PC, CMC2MS, SGX, DENOM, RTX, ETT1 + INTEGER :: K + REAL, DIMENSION(1:NROOT) :: PART, GX + + SLV = 2.501E+6 + SIGMA = 5.67E-8 + ETT = 0.0 + DO K = 1, NSOIL + ET(K) = 0. + END DO + +! ---------------------------------------------------------------------- +! INITIALIZE CANOPY RESISTANCE MULTIPLIER TERMS. +! ---------------------------------------------------------------------- + RCS = 0.0 + RCT = 0.0 + RCQ = 0.0 + RCSOIL = 0.0 + +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO INCOMING SOLAR RADIATION +! ---------------------------------------------------------------------- + FF = 0.55*2.0* SX*697.7 * 60/ (RGL * LAI) + RCS = (FF + RSMIN / RSMAX) / (1.0+ FF) + RCS = MAX (RCS,0.0001) +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO AIR TEMPERATURE AT FIRST MODEL LEVEL ABOVE GROUND +! RCT EXPRESSION FROM NOILHAN AND PLANTON (1989, MWR). +! ---------------------------------------------------------------------- + RCT = 1.0- 0.0016* ( (298 - TA)**2.0) + RCT = MAX (RCT,0.0001) +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO VAPOR PRESSURE DEFICIT AT FIRST MODEL LEVEL. +! RCQ EXPRESSION FROM SSIB (Niyogi and Raman, 1997) +! ---------------------------------------------------------------------- + EA = 6.11*EXP((2.5*10.**6./461.51)*(TA-273.15)/(273.15*TA) ) + WS = 0.622*EA/1013 + RCQ = 1.0/ (1.0+ HS * (WS - QA)) + RCQ = MAX (RCQ,0.01) +! ---------------------------------------------------------------------- +! CONTRIBUTION DUE TO SOIL MOISTURE AVAILABILITY. +! DETERMINE CONTRIBUTION FROM EACH SOIL LAYER, THEN ADD THEM UP. +! ---------------------------------------------------------------------- + DO K = 1, NROOT + GX(K) = (SMC(K) - SMCWLT) / (SMCREF - SMCWLT) + IF (GX(K) > 1.) GX(K) = 1. + IF (GX(K) < 0.) GX(K) = 0. + PART (K) = ( -DZVR (K)/ ZSOIL (3)) * GX(K) + END DO + + SGX =0.0 + DO K = 1, NROOT + SGX = SGX + GX (K) + RCSOIL = RCSOIL + PART (K) + END DO + SGX =SGX / NROOT + + RCSOIL = MAX (RCSOIL,0.0001) + + RC = RSMIN / (LAI * RCS * RCT * RCQ * RCSOIL) + DESDT = 0.622*SLV*EA/461.51/TA/TA/1013 + DELTA = (SLV / CPP)* DESDT + RR = (4.* EPSV *SIGMA * 287.04 / CPP)* (TA **4.)/ (TS * CH) + 1.0 + PC = (RR + DELTA)/ (RR * (1. + RC * CH) + DELTA) + + IF (CMC .ne. 0.0) THEN + ETT1 = SHDFAC * PC * ETP1 * (1.0- (CMC / CMCMAX) ** CFACTR) * 0.001 + ELSE + ETT1 = SHDFAC * PC * ETP1 * 0.001 + ENDIF + + DENOM = 0. + DO K = 1, NROOT + RTX= (-DZVR (K)/ ZSOIL (3)) + GX(K) - SGX + GX (K) = GX (K) * MAX ( RTX, 0. ) + DENOM = DENOM + GX (K) + END DO + IF (DENOM .le. 0.0) DENOM =1. + + DO K = 1, NROOT + ET(K) = ETT1 * GX (K) / DENOM + ETT = ETT + ET (K) + END DO + + + IF (CMC > 0.0) THEN + EC = SHDFAC * ( ( CMC / CMCMAX ) ** CFACTR ) * ETP1 * 0.001 + ELSE + EC = 0.0 + END IF + CMC2MS = CMC / DELT + EC = MIN ( CMC2MS, EC ) + + END SUBROUTINE TRANSP +! ---------------------------------------------------------------------- +! SUBROUTINE SMFLX +! ---------------------------------------------------------------------- + + SUBROUTINE SMFLX (SMCP,SMC,NSOIL,CMCP,CMC,DT,PRCP1,ZSOIL, & + & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & + & SHDFAC,CMCMAX,RUNOFF1,RUNOFF2,RUNOFF3, & + EDIR,EC,ET,DRIP) + +! CALCULATE SOIL MOISTURE FLUX. THE SOIL MOISTURE CONTENT IS UPDATED WITH +! PROGNOSTIC EQNS. THE CANOPY MOISTURE CONTENT (CMC) IS ALSO UPDATED. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I,K + REAL, INTENT(IN) :: BEXP, CMCMAX, DKSAT,DWSAT, DT, EC, EDIR, & + PRCP1, SHDFAC, SMCMAX, SMCWLT + REAL, INTENT(OUT) :: DRIP, RUNOFF1, RUNOFF2, RUNOFF3 + REAL, INTENT(IN) :: CMCP + REAL, INTENT(OUT) :: CMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL, ET + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMCP + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SMC + REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS, RHSTT + REAL :: EXCESS,PCPDRP,RHSCT,TRHSCT + + +! ---------------------------------------------------------------------- +! ADD PRECIPITATION TO EXISTING CMC.IF RESULTING AMT EXCEEDS MAX CAPACITY, +! IT BECOMES DRIP AND WILL FALL TO THE GRND. +! ---------------------------------------------------------------------- + RHSCT = SHDFAC * PRCP1 * 0.001 /3600. - EC + DRIP = 0. + TRHSCT = DT * RHSCT + EXCESS = CMCP + TRHSCT + +! ---------------------------------------------------------------------- +! PCPDRP IS THE COMBINED PRCP1 AND DRIP (FROM CMCP) THAT GOES INTO THE +! SOIL +! ---------------------------------------------------------------------- + IF (EXCESS > CMCMAX) DRIP = EXCESS - CMCMAX + PCPDRP = (1. - SHDFAC) * PRCP1 * 0.001 /3600. + DRIP / DT + +! ---------------------------------------------------------------------- +! CALL SUBROUTINES SRT AND SSTEP TO SOLVE THE SOIL MOISTURE +! TENDENCY EQUATIONS. +! ---------------------------------------------------------------------- + CALL SRT (RHSTT,EDIR,ET,SMCP,NSOIL,PCPDRP,ZSOIL,DWSAT,DKSAT, & + SMCMAX,BEXP,RUNOFF1,RUNOFF2,DT,SMCWLT,AI,BI,CI) + + CALL SSTEP (SMCP,SMC,CMCP,CMC,RHSTT,RHSCT,DT,NSOIL,SMCMAX, & + CMCMAX,RUNOFF3,ZSOIL,AI,BI,CI) +! ---------------------------------------------------------------------- + END SUBROUTINE SMFLX +! ---------------------------------------------------------------------- + + SUBROUTINE SRT (RHSTT,EDIR,ET,SMCP,NSOIL,PCPDRP,ZSOIL,DWSAT, & + DKSAT,SMCMAX,BEXP,RUNOFF1, & + RUNOFF2,DT,SMCWLT,AI,BI,CI) + +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! WATER DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K, KS + + REAL, INTENT(IN) :: BEXP, DKSAT, DT, DWSAT, EDIR, & + PCPDRP, SMCMAX, SMCWLT + REAL, INTENT(OUT) :: RUNOFF1, RUNOFF2 + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMCP, ZSOIL, ET + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTT + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: DDMAX + REAL :: DD, DDT, DDZ, DDZ2, DENOM, & + DENOM2, DSMDZ, DSMDZ2, DT1, & + INFMAX,MXSMC,MXSMC2,NUMER,PDDUM, & + PX,SMCAV, SSTT, PAR, & + VAL, WCND, WCND2, WDF, WDF2,KDT + +! ---------------------------------------------------------------------- +! DETERMINE RAINFALL INFILTRATION RATE AND RUNOFF. INCLUDE THE +! INFILTRATION FORMULE FROM SCHAAKE AND KOREN MODEL. +! MODIFIED BY Q DUAN +! ---------------------------------------------------------------------- + + PDDUM = PCPDRP + RUNOFF1 = 0.0 + PAR = 2.0E-6 + + IF (PCPDRP /= 0.0) THEN + SMCAV = SMCMAX - SMCWLT + DDMAX (1) = - ZSOIL (1)* SMCAV + DDMAX (1) = DDMAX (1)* (1.0- (SMCP (1) - SMCWLT)/ SMCAV) + DDMAX (2) = (ZSOIL (1) - ZSOIL (2))* SMCAV + DDMAX (2) = DDMAX (2)* (1.0- (SMCP (2) - SMCWLT)/ SMCAV) + DDMAX (3) = (ZSOIL (2) - ZSOIL (3))* SMCAV + DDMAX (3) = DDMAX (3)* (1.0- (SMCP (3) - SMCWLT)/ SMCAV) + + DD = DDMAX(1)+DDMAX(2)+DDMAX(3) + DT1 = DT/86400 + KDT = 3.0 * DKSAT / PAR + VAL = (1. - EXP ( - KDT * DT1)) + DDT = DD * VAL + PX = PCPDRP * DT + IF (PX < 0.0) PX = 0.0 + + INFMAX = (PX * (DDT / (PX + DDT)))/ DT + MXSMC = SMCP (1) + CALL WDFCND (WDF,WCND,MXSMC,SMCMAX,BEXP,DKSAT,DWSAT) + INFMAX = MAX (INFMAX,WCND) + INFMAX = MIN (INFMAX,PX/DT) + + + IF (PCPDRP > INFMAX) THEN + RUNOFF1 = PCPDRP - INFMAX + PDDUM = INFMAX + END IF + END IF +! ---------------------------------------------------------------------- +! TOP LAYER +! ---------------------------------------------------------------------- + CALL WDFCND (WDF,WCND,SMCP(1),SMCMAX,BEXP,DKSAT,DWSAT) + DDZ = 1. / ( - .5 * ZSOIL (2) ) + AI (1) = 0.0 + BI (1) = WDF * DDZ / ( - ZSOIL (1) ) + CI (1) = - BI (1) + DSMDZ = (SMCP (1) - SMCP (2) )/( - 0.5 * ZSOIL(2)) + RHSTT (1) = (WDF * DSMDZ + WCND- PDDUM + EDIR + ET(1))/ ZSOIL (1) + SSTT = WDF * DSMDZ + WCND+ EDIR + ET(1) + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABV PROCESS +! ---------------------------------------------------------------------- + DDZ2 = 0.0 + DO K = 2,NSOIL-1 + DENOM2 = (ZSOIL (K -1) - ZSOIL (K)) + IF (K /= NSOIL-1) THEN + MXSMC2 = SMCP (K) + CALL WDFCND (WDF2,WCND2,MXSMC2,SMCMAX,BEXP,DKSAT,DWSAT) + DENOM = (ZSOIL (K -1) - ZSOIL (K +1)) + DSMDZ2 = (SMCP (K) - SMCP (K +1)) / (DENOM * 0.5) + DDZ2 = 2.0 / DENOM + CI (K) = - WDF2 * DDZ2 / DENOM2 + ELSE + CALL WDFCND (WDF2,WCND2,SMCP(NSOIL-1),SMCMAX,BEXP,DKSAT,DWSAT) + DSMDZ2 = 0.0 + CI (K) = 0.0 + END IF + NUMER = (WDF2 * DSMDZ2) - (WDF * DSMDZ) & + - WCND+ ET(K) + RHSTT (K) = NUMER / ( - DENOM2) + AI (K) = - WDF * DDZ / DENOM2 + BI (K) = - ( AI (K) + CI (K) ) + IF (K .eq. NSOIL-1) THEN + RUNOFF2 = 0.0 + END IF + IF (K .ne. NSOIL-1) THEN + WDF = WDF2 + WCND = WCND2 + DSMDZ = DSMDZ2 + DDZ = DDZ2 + END IF + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE SRT +! ---------------------------------------------------------------------- + + SUBROUTINE SSTEP (SMCP,SMC,CMCP,CMC,RHSTT,RHSCT,DT, & + NSOIL,SMCMAX,CMCMAX,RUNOFF3,ZSOIL, & + AI,BI,CI) + +! ---------------------------------------------------------------------- +! SUBROUTINE SSTEP +! ---------------------------------------------------------------------- +! CALCULATE/UPDATE SOIL MOISTURE CONTENT VALUES AND CANOPY MOISTURE +! CONTENT VALUES. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I, K, KK11 + + REAL, INTENT(IN) :: CMCMAX, DT, SMCMAX + REAL, INTENT(OUT) :: RUNOFF3 + REAL, INTENT(IN) :: CMCP + REAL, INTENT(OUT) :: CMC + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMCP, ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: SMC + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI, BI, CI + REAL, DIMENSION(1:NSOIL) :: RHSTTin, SMCOUT,SMCIN + REAL, DIMENSION(1:NSOIL) :: CIin + REAL :: DDZ, RHSCT, WPLUS, STOT + +! ---------------------------------------------------------------------- +! CREATE 'AMOUNT' VALUES OF VARIABLES TO BE INPUT TO THE +! TRI-DIAGONAL MATRIX ROUTINE. +! ---------------------------------------------------------------------- + DO K = 1,NSOIL-1 + RHSTT (K) = RHSTT (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL-1 + RHSTTin (K) = RHSTT (K) + END DO + DO K = 1,NSOIL-1 + CIin (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! CALL ROSR12 TO SOLVE THE TRI-DIAGONAL MATRIX +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTTin,RHSTT,NSOIL-1) +! ---------------------------------------------------------------------- +! SUM THE PREVIOUS SMC VALUE AND THE MATRIX SOLUTION TO GET A +! NEW VALUE. MIN ALLOWABLE VALUE OF SMC WILL BE 0.02. +! RUNOFF3: RUNOFF WITHIN SOIL LAYERS +! ---------------------------------------------------------------------- + WPLUS = 0.0 + RUNOFF3 = 0. + + DDZ = - ZSOIL (1) + DO K = 1,NSOIL-1 + IF (K /= 1) DDZ = ZSOIL (K - 1) - ZSOIL (K) + SMCOUT (K) = SMCP (K) + CI (K) + WPLUS / DDZ + STOT = SMCOUT (K) + IF (STOT > SMCMAX) THEN + IF (K .eq. 1) THEN + DDZ = - ZSOIL (1) + ELSE + KK11 = K - 1 + DDZ = - ZSOIL (K) + ZSOIL (KK11) + END IF + WPLUS = (STOT - SMCMAX) * DDZ + ELSE + WPLUS = 0. + END IF + SMC (K) = MAX ( MIN (STOT,SMCMAX),0.066 ) + END DO + +! ---------------------------------------------------------------------- +! UPDATE CANOPY WATER CONTENT/INTERCEPTION (CMC). CONVERT RHSCT TO +! AN 'AMOUNT' VALUE AND ADD TO PREVIOUS CMC VALUE TO GET NEW CMC. +! ---------------------------------------------------------------------- + RUNOFF3 = WPLUS + CMC = CMCP + DT * RHSCT + IF (CMC < 1.E-20) CMC = 0.0 + CMC = MIN (CMC,CMCMAX) + +! ---------------------------------------------------------------------- + END SUBROUTINE SSTEP +! ---------------------------------------------------------------------- + + SUBROUTINE WDFCND (WDF,WCND,SMC,SMCMAX,BEXP,DKSAT,DWSAT) + +! ---------------------------------------------------------------------- +! SUBROUTINE WDFCND +! ---------------------------------------------------------------------- +! CALCULATE SOIL WATER DIFFUSIVITY AND SOIL HYDRAULIC CONDUCTIVITY. +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL BEXP + REAL DKSAT + REAL DWSAT + REAL EXPON + REAL FACTR1 + REAL FACTR2 + REAL SMC + REAL SMCMAX + REAL WCND + +! ---------------------------------------------------------------------- +! CALC THE RATIO OF THE ACTUAL TO THE MAX PSBL SOIL H2O CONTENT +! ---------------------------------------------------------------------- + REAL WDF + FACTR1 = 0.05 / SMCMAX + +! ---------------------------------------------------------------------- +! PREP AN EXPNTL COEF AND CALC THE SOIL WATER DIFFUSIVITY AND CONDUCTIVITY +! ---------------------------------------------------------------------- + FACTR2 = SMC / SMCMAX + FACTR1 = MIN(FACTR1,FACTR2) + EXPON = BEXP + 2.0 + WDF = DWSAT * FACTR2 ** EXPON + EXPON = (2.0 * BEXP) + 3.0 + WCND = DKSAT * FACTR2 ** EXPON + +! ---------------------------------------------------------------------- + END SUBROUTINE WDFCND +! ---------------------------------------------------------------------- +! SUBROUTINE ROSR12 +! ---------------------------------------------------------------------- +! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: +! ### ### ### ### ### ### +! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # +! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # +! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# +! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# +! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + + SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NSOIL) + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K, KK + + REAL, DIMENSION(1:NSOIL), INTENT(IN):: A, B, D + REAL, DIMENSION(1:NSOIL),INTENT(INOUT):: C,P,DELTA + +! ---------------------------------------------------------------------- +! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + C (NSOIL) = 0.0 + P (1) = - C (1) / B (1) + DELTA (1) = D (1) / B (1) + DO K = 2,NSOIL + P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) ) + DELTA (K) = (D (K) - A (K)* DELTA (K -1))* (1.0/ (B (K) + A (K)& + * P (K -1))) + END DO +! ---------------------------------------------------------------------- +! SET P TO DELTA FOR LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + P (NSOIL) = DELTA (NSOIL) + +! ---------------------------------------------------------------------- +! ADJUST P FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = 2,NSOIL + KK = NSOIL - K + 1 + P (KK) = P (KK) * P (KK +1) + DELTA (KK) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE ROSR12 +!---------------------------------------------------------------------- + + SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & + TBOT,ZBOT,SMCWLT,DF1,QUARTZ,CSOIL,CAPR) + +! ---------------------------------------------------------------------- +! SUBROUTINE SHFLX +! ---------------------------------------------------------------------- +! UPDATE THE TEMPERATURE STATE OF THE SOIL COLUMN BASED ON THE THERMAL +! DIFFUSION EQUATION AND UPDATE THE FROZEN SOIL MOISTURE CONTENT BASED +! ON THE TEMPERATURE. +! ---------------------------------------------------------------------- + IMPLICIT NONE + + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I + + REAL, INTENT(IN) :: DF1,DT,SMCMAX, SMCWLT, TBOT,YY, ZBOT,ZZ1, QUARTZ + REAL, INTENT(IN) :: CSOIL, CAPR + REAL, INTENT(INOUT) :: T1 + REAL, INTENT(OUT) :: SSOIL + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: STC + REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS + +! ---------------------------------------------------------------------- +! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN +! ---------------------------------------------------------------------- + + ! Land case + + CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, & + ZBOT,DT,DF1,AI,BI,CI,QUARTZ,CSOIL,CAPR) + + CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) + + DO I = 1,NSOIL + STC (I) = STCF (I) + ENDDO + +! ---------------------------------------------------------------------- +! CALCULATE SURFACE SOIL HEAT FLUX +! ---------------------------------------------------------------------- + T1 = (YY + (ZZ1- 1.0) * STC (1)) / ZZ1 + SSOIL = DF1 * (STC (1) - T1) / (0.5 * ZSOIL (1)) + +! ---------------------------------------------------------------------- + END SUBROUTINE SHFLX +! ---------------------------------------------------------------------- +! SUBROUTINE HRT +! ---------------------------------------------------------------------- +! CALCULATE THE RIGHT HAND SIDE OF THE TIME TENDENCY TERM OF THE SOIL +! THERMAL DIFFUSION EQUATION. ALSO TO COMPUTE ( PREPARE ) THE MATRIX +! COEFFICIENTS FOR THE TRI-DIAGONAL MATRIX OF THE IMPLICIT TIME SCHEME. +! ---------------------------------------------------------------------- + + SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & + TBOT,ZBOT,DT,DF1,AI,BI,CI,QUARTZ,CSOIL,CAPR) + + IMPLICIT NONE + LOGICAL :: ITAVG + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: I, K + + REAL, INTENT(IN) :: DF1, DT,SMCMAX ,TBOT,YY,ZZ1, ZBOT, QUARTZ, CSOIL, CAPR + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC,STC,ZSOIL + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTS + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI, BI,CI + REAL :: DDZ, DDZ2, DENOM, DF1K, DTSDZ,DF1N, & + DTSDZ2,HCPCT,QTOT,SSOIL,SICE,TAVG,TBK, & + TBK1,TSNSR,TSURF + REAL, PARAMETER :: CAIR = 1004.0, CH2O = 4.2E6 + + +! ---------------------------------------------------------------------- +! INITIALIZE LOGICAL FOR SOIL LAYER TEMPERATURE AVERAGING. +! ---------------------------------------------------------------------- + ITAVG = .TRUE. + +! ---------------------------------------------------------------------- +! TOP SOIL LAYER +! ---------------------------------------------------------------------- + HCPCT = SMC (1)* CH2O + (1.0- SMCMAX)* CSOIL + (SMCMAX - SMC (1))& + * CAIR + DDZ = 1.0 / ( -0.5 * ZSOIL (2) ) + AI (1) = 0.0 + CI (1) = (DF1 * DDZ) / (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! CALCULATE THE VERTICAL SOIL TEMP GRADIENT BTWN THE 1ST AND 2ND SOIL +! LAYERS. THEN CALCULATE THE SUBSURFACE HEAT FLUX. +! ---------------------------------------------------------------------- + BI (1) = - CI (1) + DF1 / (0.5 * ZSOIL (1) * ZSOIL (1)* HCPCT * & + ZZ1) + DTSDZ = (STC (1) - STC (2)) / (-0.5 * ZSOIL (2)) + SSOIL = DF1 * (STC (1) - YY) / (0.5 * ZSOIL (1) * ZZ1) + DENOM = (ZSOIL (1) * HCPCT) + +! ---------------------------------------------------------------------- +! NEXT CAPTURE THE VERTICAL DIFFERENCE OF THE HEAT FLUX AT TOP AND +! BOTTOM OF FIRST SOIL LAYER FOR USE IN HEAT FLUX CONSTRAINT +! ---------------------------------------------------------------------- + RHSTS (1) = (DF1 * DTSDZ - SSOIL) / DENOM + QTOT = -1.0* RHSTS (1)* DENOM + IF (ITAVG) THEN + TSURF = (YY + (ZZ1-1) * STC (1)) / ZZ1 + CALL TBND (STC (1),STC (2),ZSOIL,ZBOT,1,NSOIL,TBK) + ENDIF + DDZ2 = 0.0 + DF1N = DF1 + +! ---------------------------------------------------------------------- +! LOOP THRU THE REMAINING SOIL LAYERS, REPEATING THE ABOVE PROCESS +! (EXCEPT SUBSFC OR "GROUND" HEAT FLUX NOT REPEATED IN LOWER LAYERS) +! ---------------------------------------------------------------------- + DO K = 2,NSOIL +! ---------------------------------------------------------------------- +! THIS SECTION FOR LAYER 2 OR GREATER, BUT NOT LAST LAYER. +! ---------------------------------------------------------------------- + IF (K < NSOIL-1 ) THEN + HCPCT = SMC (K)* CH2O + (1.0- SMCMAX)* CSOIL + (SMCMAX - SMC ( & + K))* CAIR + CALL TDFCND (DF1K, SMC(K), QUARTZ, SMCMAX) + DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) ) + DTSDZ2 = (STC (K) - STC (K +1) ) / DENOM + DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1)) + +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAYER. +! ---------------------------------------------------------------------- + CI (K) = - DF1K * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K)) * & + HCPCT) + IF (ITAVG) THEN + CALL TBND (STC (K),STC (K +1),ZSOIL,ZBOT,K,NSOIL,TBK1) + END IF + + ELSEIF (K == NSOIL-1) THEN + + HCPCT = SMC (K)* CH2O + (1.0- SMCMAX)* CSOIL + (SMCMAX- SMC ( & + K))* CAIR + CALL TDFCND (DF1K, SMC(K), QUARTZ, SMCMAX) + DENOM = 0.5 * ( ZSOIL (K -1) - ZSOIL (K +1) ) + DTSDZ2 = (STC (K) - STC (K +1) ) / DENOM + DDZ2 = 2. / (ZSOIL (K -1) - ZSOIL (K +1)) +!----------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAST LAYER. +! ---------------------------------------------------------------------- + CI (K) = - DF1K * DDZ2 / ( (ZSOIL (K -1) - ZSOIL (K)) * & + HCPCT) + IF (ITAVG) THEN + CALL TBND (STC (K),TBOT,ZSOIL,ZBOT,K,NSOIL,TBK1) + END IF + ELSE +! ---------------------------------------------------------------------- +! SPECIAL CASE OF BOTTOM LAYER (CONCRETE ROOF) +! ---------------------------------------------------------------------- + HCPCT = CAPR * 4.1868 * 1.E6 + DF1K = 3.24 +! ---------------------------------------------------------------------- +! CALC THE VERTICAL TEMP GRADIENT THRU BOTTOM LAYER. +! ---------------------------------------------------------------------- + DENOM = .5 * (ZSOIL (K -1) + ZSOIL (K)) - ZBOT + DTSDZ2 = (STC (K) - TBOT) / DENOM +! ---------------------------------------------------------------------- +! IF TEMPERATURE AVERAGING INVOKED (ITAVG=TRUE; ELSE SKIP): CALCULATE +! TEMP AT BOTTOM OF LAST LAYER. +! ---------------------------------------------------------------------- + CI (K) = 0. + IF (ITAVG) THEN + CALL TBND (STC (K),TBOT,ZSOIL,ZBOT,K,NSOIL,TBK1) + END IF +! ---------------------------------------------------------------------- +! THIS ENDS SPECIAL LOOP FOR BOTTOM LAYER. + END IF +! ---------------------------------------------------------------------- +! CALCULATE RHSTS FOR THIS LAYER AFTER CALC'NG A PARTIAL PRODUCT. +! ---------------------------------------------------------------------- + DENOM = ( ZSOIL (K) - ZSOIL (K -1) ) * HCPCT + RHSTS (K) = ( DF1K * DTSDZ2- DF1N * DTSDZ ) / DENOM + QTOT = -1.0* DENOM * RHSTS (K) + +! ---------------------------------------------------------------------- +! CALC MATRIX COEFS, AI, AND BI FOR THIS LAYER. +! ---------------------------------------------------------------------- + AI (K) = - DF1N * DDZ / ( (ZSOIL (K -1) - ZSOIL (K)) * HCPCT) + +! ---------------------------------------------------------------------- +! RESET VALUES OF DF1, DTSDZ, DDZ, AND TBK FOR LOOP TO NEXT SOIL LAYER. +! ---------------------------------------------------------------------- + BI (K) = - (AI (K) + CI (K)) + TBK = TBK1 + DF1N = DF1K + DTSDZ = DTSDZ2 + DDZ = DDZ2 + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HRT +! ---------------------------------------------------------------------- + + SUBROUTINE HSTEP (STCOUT,STCIN,RHSTS,DT,NSOIL,AI,BI,CI) +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K + + REAL, DIMENSION(1:NSOIL), INTENT(IN):: STCIN + REAL, DIMENSION(1:NSOIL), INTENT(OUT):: STCOUT + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: RHSTS + REAL, DIMENSION(1:NSOIL), INTENT(INOUT):: AI,BI,CI + REAL, DIMENSION(1:NSOIL) :: RHSTSin + REAL, DIMENSION(1:NSOIL) :: CIin + REAL :: DT + +! ---------------------------------------------------------------------- +! CREATE FINITE DIFFERENCE VALUES FOR USE IN ROSR12 ROUTINE +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTS (K) = RHSTS (K) * DT + AI (K) = AI (K) * DT + BI (K) = 1. + BI (K) * DT + CI (K) = CI (K) * DT + END DO +! ---------------------------------------------------------------------- +! COPY VALUES FOR INPUT VARIABLES BEFORE CALL TO ROSR12 +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + RHSTSin (K) = RHSTS (K) + END DO + DO K = 1,NSOIL + CIin (K) = CI (K) + END DO +! ---------------------------------------------------------------------- +! SOLVE THE TRI-DIAGONAL MATRIX EQUATION +! ---------------------------------------------------------------------- + CALL ROSR12 (CI,AI,BI,CIin,RHSTSin,RHSTS,NSOIL) +! ---------------------------------------------------------------------- +! CALC/UPDATE THE SOIL TEMPS USING MATRIX SOLUTION +! ---------------------------------------------------------------------- + DO K = 1,NSOIL + STCOUT (K) = STCIN (K) + CI (K) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE HSTEP +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- + + SUBROUTINE TBND (TU,TB,ZSOIL,ZBOT,K,NSOIL,TBND1) + +! ---------------------------------------------------------------------- +! SUBROUTINE TBND +! ---------------------------------------------------------------------- +! CALCULATE TEMPERATURE ON THE BOUNDARY OF THE LAYER BY INTERPOLATION OF +! THE MIDDLE LAYER TEMPERATURES +! ---------------------------------------------------------------------- + IMPLICIT NONE + INTEGER, INTENT(IN) :: NSOIL + INTEGER :: K + REAL, INTENT(IN) :: TB, TU, ZBOT + REAL, INTENT(OUT) :: TBND1 + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL + REAL :: ZB, ZUP + +! ---------------------------------------------------------------------- +! USE SURFACE TEMPERATURE ON THE TOP OF THE FIRST LAYER +! ---------------------------------------------------------------------- + IF (K == 1) THEN + ZUP = 0. + ELSE + ZUP = ZSOIL (K -1) + END IF +! ---------------------------------------------------------------------- +! USE DEPTH OF THE CONSTANT BOTTOM TEMPERATURE WHEN INTERPOLATE +! TEMPERATURE INTO THE LAST LAYER BOUNDARY +! ---------------------------------------------------------------------- + IF (K == NSOIL) THEN + ZB = 2.* ZBOT - ZSOIL (K) + ELSE + ZB = ZSOIL (K +1) + END IF +! ---------------------------------------------------------------------- +! LINEAR INTERPOLATION BETWEEN THE AVERAGE LAYER TEMPERATURES +! ---------------------------------------------------------------------- + + TBND1 = TU + (TB - TU)* (ZUP - ZSOIL (K))/ (ZUP - ZB) +! ---------------------------------------------------------------------- + END SUBROUTINE TBND +! ---------------------------------------------------------------------- + SUBROUTINE TDFCND (DF, SMC, QZ, SMCMAX) +! ---------------------------------------------------------------------- +! CALCULATE THERMAL CONDUCTIVITY OF THE SOIL +! ---------------------------------------------------------------------- +! PETERS-LIDARD APPROACH (PETERS-LIDARD et al., 1998) +! ---------------------------------------------------------------------- + IMPLICIT NONE + REAL, INTENT(IN) :: QZ, SMC, SMCMAX + REAL, INTENT(OUT) :: DF + REAL :: AKE, GAMMD, THKDRY, THKO, & + THKQTZ,THKSAT,THKS,THKW,SATRATIO + +! ---------------------------------------------------------------------- +! IF THE SOIL HAS ANY MOISTURE CONTENT COMPUTE A PARTIAL SUM/PRODUCT +! OTHERWISE USE A CONSTANT VALUE WHICH WORKS WELL WITH MOST SOILS +! ---------------------------------------------------------------------- +! THKW ......WATER THERMAL CONDUCTIVITY +! THKQTZ ....THERMAL CONDUCTIVITY FOR QUARTZ +! THKO ......THERMAL CONDUCTIVITY FOR OTHER SOIL COMPONENTS +! THKS ......THERMAL CONDUCTIVITY FOR THE SOLIDS COMBINED(QUARTZ+OTHER) +! SMCMAX ....POROSITY (= SMCMAX) +! QZ .........QUARTZ CONTENT (SOIL TYPE DEPENDENT) +! ---------------------------------------------------------------------- +! USE AS IN PETERS-LIDARD, 1998 (MODIF. FROM JOHANSEN, 1975). + +! PABLO GRUNMANN, 08/17/98 +! REFS.: +! FAROUKI, O.T.,1986: THERMAL PROPERTIES OF SOILS. SERIES ON ROCK +! AND SOIL MECHANICS, VOL. 11, TRANS TECH, 136 PP. +! JOHANSEN, O., 1975: THERMAL CONDUCTIVITY OF SOILS. PH.D. THESIS, +! UNIVERSITY OF TRONDHEIM, +! PETERS-LIDARD, C. D., ET AL., 1998: THE EFFECT OF SOIL THERMAL +! CONDUCTIVITY PARAMETERIZATION ON SURFACE ENERGY FLUXES +! AND TEMPERATURES. JOURNAL OF THE ATMOSPHERIC SCIENCES, +! VOL. 55, PP. 1209-1224. +! ---------------------------------------------------------------------- +! NEEDS PARAMETERS +! POROSITY(SOIL TYPE): +! POROS = SMCMAX +! SATURATION RATIO: +! PARAMETERS W/(M.K) + SATRATIO = SMC / SMCMAX +! WATER CONDUCTIVITY: + THKW = 0.57 +! THERMAL CONDUCTIVITY OF "OTHER" SOIL COMPONENTS +! IF (QZ .LE. 0.2) THKO = 3.0 + THKO = 2.0 +! QUARTZ' CONDUCTIVITY + THKQTZ = 7.7 +! SOLIDS' CONDUCTIVITY + THKS = (THKQTZ ** QZ)* (THKO ** (1. - QZ)) + +! SATURATED THERMAL CONDUCTIVITY + THKSAT = THKS ** (1. - SMCMAX)* THKW ** (SMCMAX) + +! DRY DENSITY IN KG/M3 + GAMMD = (1. - SMCMAX)*2700. + +! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 + THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD) + +! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT +! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) +! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998). + + IF ( SATRATIO > 0.1 ) THEN + + AKE = LOG10 (SATRATIO) + 1.0 + +! USE K = KDRY + ELSE + + AKE = 0.0 + END IF +! THERMAL CONDUCTIVITY + + DF = AKE * (THKSAT - THKDRY) + THKDRY +! ---------------------------------------------------------------------- + END SUBROUTINE TDFCND +! ---------------------------------------------------------------------- +!=========================================================================== END MODULE module_sf_urban diff --git a/wrfv2_fire/phys/module_shallowcu_driver.F b/wrfv2_fire/phys/module_shallowcu_driver.F index 3a77e42f..f228a15f 100644 --- a/wrfv2_fire/phys/module_shallowcu_driver.F +++ b/wrfv2_fire/phys/module_shallowcu_driver.F @@ -28,7 +28,7 @@ SUBROUTINE shallowcu_driver( & ,qv_curr, qc_curr, qr_curr & ,qi_curr, qs_curr, qg_curr & ,qnc_curr,qni_curr & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ,chem, chem_opt & #endif ! Optional output arguments for CAMZM scheme @@ -65,7 +65,7 @@ SUBROUTINE shallowcu_driver( & USE module_shcu_grims USE module_dm USE module_domain, ONLY: domain -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_state_description, ONLY: num_chem #endif @@ -225,7 +225,7 @@ SUBROUTINE shallowcu_driver( & ims,ime, jms,jme, kms,kme, & kts,kte, & itimestep, num_tiles -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) INTEGER, INTENT(IN ) :: chem_opt #endif @@ -240,7 +240,7 @@ SUBROUTINE shallowcu_driver( & REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & INTENT(INOUT) :: & moist -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & INTENT(INOUT) :: & chem @@ -423,7 +423,7 @@ SUBROUTINE shallowcu_driver( & ,T_PHY=t, U_PHY=u, V_PHY=v & ,MOIST=moist, QV=qv_curr, QC=qc_curr, QI=qi_curr & ,QNC=qnc_curr, QNI=qni_curr & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ,CHEM=chem, CHEM_OPT=chem_opt & #endif ,PBLH_IN=pblh, TKE_PBL=tke_pbl & diff --git a/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F b/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F index 7eb5cff1..f4658142 100644 --- a/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F +++ b/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F @@ -35,7 +35,7 @@ SUBROUTINE camuwshcu_driver( & ,p, p8w, pi_phy, z, z_at_w, dz8w & ,t_phy, u_phy, v_phy & ,moist, qv, qc, qi, qnc, qni & -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ,chem, chem_opt & #endif ,pblh_in, tke_pbl, cldfra, cldfra_old & @@ -60,14 +60,14 @@ SUBROUTINE camuwshcu_driver( & USE module_state_description, only: param_first_scalar, & p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni USE module_cam_support, only: pcols, pver, pcnst =>pcnst_runtime -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) USE module_cam_support, only: cam_mam_aerosols #endif USE constituents, only: cnst_get_ind USE physconst, only: latice,cpair, gravit, latvap USE uwshcu, only: compute_uwshcu_inv USE wv_saturation, only: fqsatd -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) use module_state_description, only: num_chem, param_first_scalar,CBMZ_CAM_MAM3_NOAQ, & CBMZ_CAM_MAM3_AQ,CBMZ_CAM_MAM7_NOAQ,CBMZ_CAM_MAM7_AQ use module_data_cam_mam_asect, only: lptr_chem_to_q, factconv_chem_to_q @@ -80,13 +80,13 @@ SUBROUTINE camuwshcu_driver( & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & num_moist,itimestep -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) INTEGER, INTENT(IN ) :: chem_opt #endif REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), INTENT(IN) :: & moist !moist tracer array -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), INTENT(INOUT) :: & chem !moist tracer array #endif @@ -241,7 +241,7 @@ SUBROUTINE camuwshcu_driver( & real(r8) :: state_s(pcols,kte) real(r8) :: ptend_s(pcols,kte) !Dummy arguments for physics_update call -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !BSINGH:02/01/2013: Sanity check for Non-MAM simulations if(.NOT.cam_mam_aerosols .AND. chem_opt .NE. 0) then write(msg,*)'CAMUWSHACU DRIVER - camuwshcu_driver is valid for only MAM aerosols ', & @@ -339,12 +339,12 @@ SUBROUTINE camuwshcu_driver( & call cnst_get_ind( 'NUMICE', m ) moist8(1,kflip,m) = max(0.0,qni(i,k,j)/(1. + qv(i,k,j))) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !Following Do-Loop is obtained from chem/module_cam_mam_aerchem_driver.F do l = param_first_scalar, num_chem l2 = lptr_chem_to_q(l) if ((l2 >= 1) .and. (l2 <= pcnst)) then - moist8(1,kflip,l2) = max(0.0_r8,chem(i,k,j,l)*factconv_chem_to_q(l)) + moist8(1,kflip,l2) = max(0.0,chem(i,k,j,l)*factconv_chem_to_q(l)) end if end do ! l #endif @@ -433,7 +433,7 @@ SUBROUTINE camuwshcu_driver( & end do !k-loop to kte !PMA< -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !BSINGH - update moist8 by physics update call !Update chem array and state constituents !populate state_s, ptend_s, ptend_ls with dummy values (zeros) for physics update call diff --git a/wrfv2_fire/phys/module_surface_driver.F b/wrfv2_fire/phys/module_surface_driver.F index ac4365da..8c246753 100644 --- a/wrfv2_fire/phys/module_surface_driver.F +++ b/wrfv2_fire/phys/module_surface_driver.F @@ -6,7 +6,7 @@ MODULE module_surface_driver SUBROUTINE surface_driver( & & HYDRO_dt,sfcheadrt,INFXSRT,soldrain, & & acgrdflx,achfx,aclhf & - & ,acsnom,acsnow,akhs,akms,albedo,br,canwat & + & ,acsnom,acsnow,snowfallac,akhs,akms,albedo,br,canwat & & ,chklowq,dt,dx,dz8w,dzs,glw & & ,grdflx,gsw,swdown,gz1oz0,hfx,ht,ifsnow,isfflx & & ,fractional_seaice,seaice_albedo_opt & @@ -47,8 +47,8 @@ SUBROUTINE surface_driver( & & ,sf_sfclay_physics,sf_surface_physics,ra_lw_physics & & ,mosaic_lu,mosaic_soil & & ,landusef,soilctop,soilcbot,ra,rs,nlcat,nscat,vegf_px & ! PX-LSM - & ,snowncv, anal_interval, lai, pxlsm_smois_init & ! PX-LSM - & ,pxlsm_soil_nudge & ! PX-LSM + & ,snowncv, anal_interval, lai, imperv, canfra & ! PX-LSM + & ,pxlsm_smois_init, pxlsm_soil_nudge & ! PX-LSM & ,idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz & & ,iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot ,iopt_stc & & ,isnowxy ,tvxy ,tgxy ,canicexy ,canliqxy ,eahxy & @@ -153,17 +153,21 @@ SUBROUTINE surface_driver( & #endif ! Optional urban & ,slope_rad,topo_shading,shadowmask & !I solar - & ,swnorm,slope,slp_azi & !I solar + & ,swnorm,slope,slp_azi,diffuse_frac & !I solar & ,declin,solcon,coszen,hrang,xlat_urb2d & !I solar/urban & ,num_roof_layers, num_wall_layers & !I urban & ,num_road_layers, dzr, dzb, dzg & !I urban & ,tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d & !H urban & ,uc_urb2d & !H urban & ,xxxr_urb2d,xxxb_urb2d,xxxg_urb2d,xxxc_urb2d & !H urban + & ,cmcr_urb2d,tgr_urb2d,tgrl_urb3d,smr_urb3d & !H urban + & ,julian,julyr,drelr_urb2d,drelb_urb2d,drelg_urb2d & !H urban + & ,flxhumr_urb2d,flxhumb_urb2d,flxhumg_urb2d & !H urban & ,trl_urb3d,tbl_urb3d,tgl_urb3d & !H urban & ,sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d,ts_urb2d & !H urban & ,frc_urb2d, utype_urb2d & !H urban & ,cmr_sfcdif,chr_sfcdif,cmc_sfcdif,chc_sfcdif & + & ,cmgr_sfcdif,chgr_sfcdif & !-----SSiB LSM (fds 06/2010)--------------------------------------------------- & ,alswvisdir, alswvisdif, alswnirdir, alswnirdif & ! ssib & ,swvisdir, swvisdif, swnirdir, swnirdif & ! ssib @@ -195,9 +199,9 @@ SUBROUTINE surface_driver( & & ,f_qi,f_qs,f_qg & ! Other optionals (more or less em specific) & ,capg,hol,mol & - & ,rainncv,rainshv,rainbl,regime,thc & + & ,rainncv,rainshv,rainbl,regime,thc,graupelncv,hailncv & & ,qsg,qvg,qcg,soilt1,tsnav & - & ,smfr3d,keepfr3dflag,dew & + & ,smfr3d,keepfr3dflag,dew,rhosnf,precipfr & ! Other optionals (more or less nmm specific) & ,potevp,snopcx,soiltb,sr & ! Optional observation PX LSM surface nudging @@ -257,6 +261,7 @@ SUBROUTINE surface_driver( & & ,G_URB2D_mosaic,RN_URB2D_mosaic & !danli mosaic & ,TS_URB2D_mosaic & !danli mosaic & ,TS_RUL2D_mosaic & !danli mosaic + & ,ZOL & !ckay & ) #if ( ! NMM_CORE == 1 ) @@ -488,8 +493,11 @@ SUBROUTINE surface_driver( & !-- LANDUSEF Landuse fraction ! P-X LSM !-- SOILCTOP Top soil fraction ! P-X LSM !-- SOILCBOT Bottom soil fraction ! P-X LSM -!-- RA Aerodynamic resistence ! P-X LSM +!-- RA Aerodynamic resistence ! P-X LSM !-- RS Stomatal resistence ! P-X LSM +!-- VEGF_PX PX LSM internal LU-based Veg Fraction ! P-X LSM +!-- IMPERV Impervious surface fraction ! P-X LSM +!-- CANFRA Canopy/Tree fraction ! P-X LSM !-- NLCAT Number of landuse categories ! P-X LSM !-- NSCAT Number of soil categories ! P-X LSM !-- ch - drag coefficient for heat/moisture ! MYNN LSM @@ -796,22 +804,31 @@ SUBROUTINE surface_driver( & REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ):: SHDMIN REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT ):: Z0 - INTEGER, OPTIONAL, INTENT(IN) :: idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc, iopt_frz, iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, iopt_stc - INTEGER, OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: ISNOWXY - REAL, OPTIONAL, DIMENSION(ims:ime ,-2:num_soil_layers, jms:jme), INTENT(INOUT) :: zsnsoxy - REAL, OPTIONAL, DIMENSION(ims:ime ,-2:0, jms:jme), INTENT(INOUT) :: tsnoxy, snicexy, snliqxy - REAL, OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: tvxy, tgxy, canicexy, canliqxy, eahxy, tahxy, cmxy, chxy, & - fwetxy, sneqvoxy, alboldxy, qsnowxy, wslakexy, zwtxy, waxy, wtxy, lfmassxy, rtmassxy, stmassxy, woodxy, stblcpxy, fastcpxy, & - xsaixy, taussxy, t2mvxy ,t2mbxy, q2mvxy, q2mbxy ,tradxy, neexy, gppxy, nppxy, fvegxy, runsfxy, runsbxy, ecanxy, edirxy, etranxy, fsaxy, firaxy, & - aparxy, psnxy, savxy, sagxy - REAL, OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: rssunxy, rsshaxy, bgapxy,wgapxy, & - tgvxy ,tgbxy, chvxy, chbxy,SHGXY,SHCXY,SHBXY,EVGXY,EVBXY,GHVXY,GHBXY,IRGXY,IRCXY,IRBXY,TRXY,EVCXY,CHLEAFXY,CHUCXY,CHV2XY,CHB2XY,chstarxy - - REAL, OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: smcwtdxy ,rechxy ,deeprechxy, fdepthxy, areaxy, & - rivercondxy,riverbedxy,eqzwt,pexpxy,qrfxy,qspringxy,qslatxy,qrfsxy,qspringsxy - REAL, OPTIONAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT):: smoiseq - REAL, OPTIONAL, INTENT(IN) :: wtddt - INTEGER, OPTIONAL, INTENT(IN ) :: stepwtd +! NoahMP specific fields + + INTEGER, OPTIONAL, INTENT(IN) :: idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc , iopt_frz, & + iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, iopt_stc + + INTEGER, OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: ISNOWXY + REAL, OPTIONAL, DIMENSION(ims:ime ,-2:num_soil_layers, jms:jme), INTENT(INOUT) :: ZSNSOXY + REAL, OPTIONAL, DIMENSION(ims:ime ,-2:0, jms:jme), INTENT(INOUT) :: TSNOXY, SNICEXY, SNLIQXY + REAL, OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: & + TVXY, TGXY,CANICEXY,CANLIQXY, EAHXY, TAHXY, CMXY, CHXY, FWETXY,SNEQVOXY,ALBOLDXY, & + QSNOWXY,WSLAKEXY, ZWTXY, WAXY, WTXY,LFMASSXY,RTMASSXY,STMASSXY, WOODXY,STBLCPXY,FASTCPXY, & + XSAIXY, TAUSSXY, T2MVXY, T2MBXY, Q2MVXY, Q2MBXY, TRADXY, NEEXY, GPPXY, & + NPPXY, FVEGXY, RUNSFXY, RUNSBXY, ECANXY, EDIRXY, ETRANXY, FSAXY, FIRAXY, APARXY, PSNXY, & + SAVXY, SAGXY, RSSUNXY, RSSHAXY, BGAPXY, WGAPXY, TGVXY, TGBXY, CHVXY, CHBXY, SHGXY, & + SHCXY, SHBXY, EVGXY, EVBXY, GHVXY, GHBXY, IRGXY, IRCXY, IRBXY, TRXY, EVCXY, & + CHLEAFXY, CHUCXY, CHV2XY, CHB2XY,CHSTARXY + +! NoahMP specific fields - runoff option 5 + + INTEGER, OPTIONAL, INTENT(IN) :: stepwtd + REAL, OPTIONAL, INTENT(IN) :: wtddt + REAL, OPTIONAL, DIMENSION(ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT):: smoiseq + REAL, OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: & + SMCWTDXY, RECHXY, DEEPRECHXY, FDEPTHXY, AREAXY, RIVERCONDXY, RIVERBEDXY, & + EQZWT, PEXPXY, QRFXY, QSPRINGXY, QSLATXY, QRFSXY, QSPRINGSXY ! Noah UA changes LOGICAL, INTENT(IN) :: ua_phys @@ -869,7 +886,8 @@ SUBROUTINE surface_driver( & ! arguments for Ocean Mixed Layer Model REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT ):: TML, T0ML, HML, H0ML, HUML, HVML REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(IN ):: F, TMOML - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(OUT ):: CK, CKA, CD, CDA, USTM + REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(OUT ):: CK, CKA, CD, CDA + REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT ):: USTM REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT ):: TSK_SAVE @@ -892,6 +910,7 @@ SUBROUTINE surface_driver( & INTEGER, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN):: shadowmask REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: swnorm REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN):: slope,slp_azi + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN):: diffuse_frac INTEGER, OPTIONAL, INTENT(IN ):: ISFTCFLX,IZ0TLND INTEGER, OPTIONAL, INTENT(IN ):: SF_OCEAN_PHYSICS @@ -909,10 +928,11 @@ SUBROUTINE surface_driver( & INTEGER, OPTIONAL, INTENT(IN) :: pxlsm_smois_init, pxlsm_soil_nudge, ANAL_INTERVAL REAL, DIMENSION( ims:ime, NLCAT, jms:jme ) , OPTIONAL, INTENT(INOUT):: LANDUSEF REAL, DIMENSION( ims:ime, NSCAT, jms:jme ) , OPTIONAL, INTENT(INOUT):: SOILCTOP, SOILCBOT - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT):: VEGF_PX - REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT):: RA - REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT):: RS - REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT):: LAI + REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT):: IMPERV, CANFRA + REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT):: VEGF_PX + REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT):: RA + REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT):: RS + REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT):: LAI REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(OUT):: T2OBS REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(OUT):: Q2OBS @@ -946,6 +966,8 @@ SUBROUTINE surface_driver( & qv_curr, qc_curr, qr_curr & ,qi_curr, qs_curr, qg_curr REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: snowncv + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: graupelncv + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(IN) :: hailncv REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: capg REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: emiss REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: hol @@ -968,8 +990,12 @@ SUBROUTINE surface_driver( & REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: sr ! NMM and RUC LSM REAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), OPTIONAL, INTENT(INOUT):: smfr3d REAL, DIMENSION( ims:ime, 1:num_soil_layers, jms:jme ), OPTIONAL, INTENT(INOUT):: keepfr3dflag + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: rhosnf ! density of snowfall + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(OUT) :: precipfr ! time-step frozen precip from RUC LSM + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, INTENT(INOUT):: snowfallac ! density of snowfall REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT), OPTIONAL :: NOAHRES + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT) :: ZOL INTEGER, INTENT(IN) :: MAXPATCH, inest @@ -1058,8 +1084,6 @@ SUBROUTINE surface_driver( & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) ::v_phytmp REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) ::u_phytmp - REAL, DIMENSION( ims:ime, jms:jme ) :: ZOL - REAL, DIMENSION( ims:ime, jms:jme ) :: & QGH, & CHS, & @@ -1086,6 +1110,8 @@ SUBROUTINE surface_driver( & !------------------------------------------------- REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMR_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMGR_SFCDIF + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHGR_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMC_SFCDIF REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CHC_SFCDIF REAL, OPTIONAL, INTENT(IN) :: DECLIN, SOLCON @@ -1095,6 +1121,7 @@ SUBROUTINE surface_driver( & INTEGER, INTENT(IN) :: num_roof_layers !urban INTEGER, INTENT(IN) :: num_wall_layers !urban INTEGER, INTENT(IN) :: num_road_layers !urban + INTEGER, INTENT(IN), OPTIONAL :: julian,julyr !urban REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(IN) :: DZR !urban REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(IN) :: DZB !urban REAL, OPTIONAL, DIMENSION(1:num_soil_layers), INTENT(IN) :: DZG !urban @@ -1109,6 +1136,20 @@ SUBROUTINE surface_driver( & REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: XXXB_URB2D !urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: XXXG_URB2D !urban REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT):: XXXC_URB2D !urban + + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: DRELG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMB_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FLXHUMG_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: CMCR_URB2D + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TGR_URB2D + + REAL, OPTIONAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & !urban + INTENT(INOUT) :: TGRL_URB3D !urban + REAL, OPTIONAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & !urban + INTENT(INOUT) :: SMR_URB3D !urban REAL, OPTIONAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & !urban INTENT(INOUT) :: TRL_URB3D !urban REAL, OPTIONAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), & !urban @@ -1309,7 +1350,6 @@ SUBROUTINE surface_driver( & ENDDO ENDDO DO i = i_start(ij),i_end(ij) - ZOL(i,j) = 0. QGH(i,j) = 0. CHS(i,j) = 0. CPM(i,j) = 0. @@ -1499,6 +1539,7 @@ SUBROUTINE surface_driver( & XICE_save(I,J) = XICEM(I,J) XICEM(i,j) = XICE(i,j) + TSK_SAVE(I,J) = TSK(I, J) ENDDO ENDDO @@ -1634,7 +1675,7 @@ SUBROUTINE surface_driver( & !$OMP PRIVATE ( ij, i, j, k ) DO ij = 1 , num_tiles CALL TOPO_RAD_ADJ_DRVR (XLAT,XLONG,COSZEN, & - shadowmask, & + shadowmask,diffuse_frac, & declin, & SWDOWN,GSW,SWNORM,GSWSAVE,solcon,hrang, & slope,slp_azi, & @@ -1833,7 +1874,7 @@ SUBROUTINE surface_driver( & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & - ustm,ck,cka,cd,cda,isftcflx,iz0tlnd ) + ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, scm_force_flux ) #if ( EM_CORE==1) DO j = j_start(ij),j_end(ij) DO i = i_start(ij),i_end(ij) @@ -1854,7 +1895,6 @@ SUBROUTINE surface_driver( & .TRUE. ) THEN CALL wrf_debug( 100, 'in PX Surface Layer scheme' ) IF ( FRACTIONAL_SEAICE == 1 ) THEN - CALL WRF_ERROR_FATAL("PXSFCLAY not adapted for FRACTIONAL_SEAICE=1 option") CALL PXSFCLAY_SEAICE_WRAPPER(u_phytmp,v_phytmp,t_phy,th_phy,qv_curr,& p_phy,dz8w,cp,g,rcp,r_d,xlv,psfc,chs,chs2,cqs2,cpm, & znt,ust,pblh,mavail,zol,mol,regime,psim,psih, & @@ -2438,6 +2478,7 @@ SUBROUTINE surface_driver( & sf_urban_physics & !Optional urban ,cmr_sfcdif,chr_sfcdif,cmc_sfcdif,chc_sfcdif & + ,cmgr_sfcdif,chgr_sfcdif & ,tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d, & !H urban uc_urb2d, & !H urban xxxr_urb2d,xxxb_urb2d,xxxg_urb2d,xxxc_urb2d, & !H urban @@ -2459,6 +2500,10 @@ SUBROUTINE surface_driver( & xlat_urb2d, & !I urban num_roof_layers, num_wall_layers, & !I urban num_road_layers, DZR, DZB, DZG, & !I urban + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !H urban + julian,julyr, & !H urban + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !H urban + FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !H urban FRC_URB2D, UTYPE_URB2D, & !I urban num_urban_layers, & !I multi-layer urban num_urban_hi, & !I multi-layer urban @@ -2515,6 +2560,7 @@ SUBROUTINE surface_driver( & sf_urban_physics & !Optional urban ,cmr_sfcdif,chr_sfcdif,cmc_sfcdif,chc_sfcdif & + ,cmgr_sfcdif,chgr_sfcdif & ,tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d, & !H urban uc_urb2d, & !H urban xxxr_urb2d,xxxb_urb2d,xxxg_urb2d,xxxc_urb2d, & !H urban @@ -2527,6 +2573,10 @@ SUBROUTINE surface_driver( & xlat_urb2d, & !I urban num_roof_layers, num_wall_layers, & !I urban num_road_layers, DZR, DZB, DZG, & !I urban + CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D, & !H urban + DRELR_URB2D,DRELB_URB2D,DRELG_URB2D, & !H urban + FLXHUMR_URB2D,FLXHUMB_URB2D,FLXHUMG_URB2D, & !H urban + julian, julyr, & !H urban FRC_URB2D, UTYPE_URB2D, & !I urban num_urban_layers, & !I multi-layer urban num_urban_hi, & !I multi-layer urban @@ -2711,9 +2761,7 @@ SUBROUTINE surface_driver( & #endif .TRUE. ) THEN !------------------------------------------------------------------ - IF( PRESENT(sr) ) THEN - frpcpn=.true. - ENDIF + IF ( FRACTIONAL_SEAICE == 1) THEN ! The fields passed to LSM need to represent the full ice values, not @@ -2759,16 +2807,17 @@ SUBROUTINE surface_driver( & CALL noahmplsm(ITIMESTEP, YR, JULIAN_IN, COSZEN, XLAT_URB2D, & DZ8W, DTBL, DZS, NUM_SOIL_LAYERS, DX, & IVGTYP, ISLTYP, VEGFRA, SHDMAX, TMN, & - XLAND, XICE, XICE_THRESHOLD, ISICE, ISURBAN, & + XLAND, XICE, XICE_THRESHOLD, & IDVEG, IOPT_CRS, IOPT_BTR, IOPT_RUN, IOPT_SFC, IOPT_FRZ, & IOPT_INF, IOPT_RAD, IOPT_ALB, IOPT_SNF, IOPT_TBOT, IOPT_STC, & IZ0TLND, & T_PHY, QV_CURR, U_PHY, V_PHY, SWDOWN, GLW, & - P8W, RAINBL, & + P8W, RAINBL, SR, & TSK, HFX, QFX, LH, GRDFLX, SMSTAV, & SMSTOT,SFCRUNOFF, UDRUNOFF, ALBEDO, SNOWC, SMOIS, & SH2O, TSLB, SNOW, SNOWH, CANWAT, ACSNOM, & ACSNOW, EMISS, QSFC, & + Z0, ZNT, & ! IN/OUT LSM eqv ISNOWXY, TVXY, TGXY, CANICEXY, CANLIQXY, EAHXY, & TAHXY, CMXY, CHXY, FWETXY, SNEQVOXY, ALBOLDXY, & QSNOWXY, WSLAKEXY, ZWTXY, WAXY, WTXY, TSNOXY, & @@ -2788,7 +2837,10 @@ SUBROUTINE surface_driver( & #endif ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & +! variables below are optional + MP_RAINC = RAINCV, MP_RAINNC = RAINNCV, MP_SHCV = RAINSHV,& + MP_SNOW = SNOWNCV, MP_GRAUP = GRAUPELNCV, MP_HAIL = HAILNCV ) if(iopt_run.eq.5.and.mod(itimestep,STEPWTD).eq.0)then CALL wrf_debug( 100, 'calling WTABLE' ) @@ -2962,6 +3014,8 @@ SUBROUTINE surface_driver( & IF ( ( XICE(I,J) .GE. XICE_THRESHOLD ) .AND. ( XICE(i,j) .LE. 1 ) ) THEN ALBEDO(I,J) = (ALBEDO(I,J) - (1.-XICE(I,J))*0.08) / XICE(I,J) EMISS(I,J) = (EMISS(I,J) - (1.-XICE(I,J))*0.98) / XICE(I,J) +! also set skin temperature to saved sea-ice portion only + TSK(I,J) = TSK_SAVE(I,J) ENDIF ENDDO ENDDO @@ -2990,8 +3044,13 @@ SUBROUTINE surface_driver( & ENDIF CALL LSMRUC(dtbl,itimestep,num_soil_layers, & +#if (EM_CORE==1) + lakemodel,lakemask, & + graupelncv,snowncv,rainncv, & +#endif zs,rainbl,snow,snowh,snowc,sr,frpcpn, & - dz8w,p8w,t_phy,qv_curr,qc_curr,rho, & !p8w in [pa] + rhosnf,precipfr, & + dz8w,p_phy,t_phy,qv_curr,qc_curr,rho, & !p_phy in [pa] glw,gsw,emiss,chklowq, & chs,flqc,flhc,mavail,canwat,vegfra,albedo,znt, & z0,snoalb, albbck, lai, & !new @@ -3003,7 +3062,7 @@ SUBROUTINE surface_driver( & cp,rovcp,g,xlv,stbolt, & smois,sh2o,smstav,smstot,tslb,tsk,hfx,qfx,lh, & sfcrunoff,udrunoff,sfcexc, & - sfcevp,grdflx,acsnow,acsnom, & + sfcevp,grdflx,snowfallac,acsnow,acsnom, & smfr3d,keepfr3dflag, & myj,shdmin,shdmax,rdlai2d, & ids,ide, jds,jde, kds,kde, & @@ -3059,9 +3118,9 @@ SUBROUTINE surface_driver( & endif ENDIF - CALL SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CQS2,CQS2,T2,TH2,Q2, & - T_PHY,QV_CURR,RHO,P8W, & - PSFC,CP,R_d,RCP, & + CALL SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS,CHS2,CQS2,T2,TH2,Q2, & + T_PHY,QV_CURR,RHO,P_PHY, & + CP,R_d,RCP, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) @@ -3078,8 +3137,6 @@ SUBROUTINE surface_driver( & .TRUE. ) THEN IF ( FRACTIONAL_SEAICE == 1 ) THEN - CALL WRF_ERROR_FATAL("PXLSM not adapted for FRACTIONAL_SEAICE=1 option") - IF ( isisfc ) THEN ! ! use surface layer routine values from the ice portion of grid point @@ -3105,18 +3162,18 @@ SUBROUTINE surface_driver( & CALL wrf_debug(100,'in P-X LSM') CALL PXLSM(u_phy, v_phy, dz8w, qv_curr, t_phy, th_phy, rho,& psfc, gsw, glw, rainbl, emiss, & - ITIMESTEP, curr_secs, num_soil_layers, DT, anal_interval, & - xland, xice, albbck, albedo, snoalb, smois, tslb, & - mavail,T2, Q2, & + ITIMESTEP, curr_secs, num_soil_layers, DT, & + anal_interval, xland, xice, albbck, albedo, & + snoalb, smois, tslb, mavail,T2, Q2, & zs, dzs, psih, & landusef,soilctop,soilcbot,vegfra, vegf_px, & - isltyp,ra,rs,lai,nlcat,nscat, & + isltyp,ra,rs,lai,imperv,canfra,nlcat,nscat, & hfx,qfx,lh,tsk,sst,znt,canwat, & grdflx,shdmin,shdmax, & snowc,pblh,rmol,ust,capg,dtbl, & t2_ndg_old,t2_ndg_new,q2_ndg_old,q2_ndg_new, & sn_ndg_old, sn_ndg_new, snow, snowh,snowncv, & - t2obs, q2obs, pxlsm_smois_init, pxlsm_soil_nudge, & + t2obs, q2obs,pxlsm_smois_init,pxlsm_soil_nudge, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte) @@ -3142,10 +3199,7 @@ SUBROUTINE surface_driver( & !save old tsk_ice tsk_save(i,j) = tsk(i,j) tsk(i,j) = ( tsk(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * TSK_SEA(i,j) ) - psih(i,j) = ( psih(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * PSIH_SEA(i,j) ) pblh(i,j) = ( pblh(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * PBLH_SEA(i,j) ) - rmol(i,j) = ( rmol(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * RMOL_SEA(i,j) ) - ust(i,j) = ( ust(i,j) * XICE(i,j) ) + ( (1.0-XICE(i,j)) * UST_SEA(i,j) ) ENDIF ENDDO ENDDO @@ -3259,6 +3313,7 @@ SUBROUTINE surface_driver( & inest,sf_urban_physics, nlcat & !Optional urban ,cmr_sfcdif,chr_sfcdif,cmc_sfcdif,chc_sfcdif & + ,cmgr_sfcdif,chgr_sfcdif & ,tr_urb2d,tb_urb2d,tg_urb2d,tc_urb2d,qc_urb2d, & !H urban uc_urb2d, & !H urban xxxr_urb2d,xxxb_urb2d,xxxg_urb2d,xxxc_urb2d, & !H urban @@ -3271,9 +3326,12 @@ SUBROUTINE surface_driver( & xlat_urb2d, & !I urban num_roof_layers, num_wall_layers, & !I urban num_road_layers, DZR, DZB, DZG, & !I urban - FRC_URB2D, UTYPE_URB2D & !I urban + FRC_URB2D, UTYPE_URB2D, & !I urban + cmcr_urb2d,tgr_urb2d,tgrl_urb3d,smr_urb3d, & ! urban + drelr_urb2d,drelb_urb2d,drelg_urb2d, & ! urban + flxhumr_urb2d,flxhumb_urb2d,flxhumg_urb2d, & ! CLM subgrids - ,numc,nump,sabv,sabg,lwup,snl, & + numc,nump,sabv,sabg,lwup,snl, & snowdp,wtc,wtp,h2osno,t_grnd,t_veg, & h2ocan,h2ocan_col,t2m_max,t2m_min,t2clm , & t_ref2m,h2osoi_liq_s1, & @@ -4552,7 +4610,9 @@ SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & &th3d,pi3d,tsq,qsq,cov,Sh3d,el_pbl REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm + INTENT(OUT) :: ck,cka,cd,cda + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: ustm INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX,IZ0TLND !-------------------------------------------------------------------- @@ -5137,17 +5197,17 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,EOMEG,STBOLT, & P1000, & -XICE,SST,TSK_SEA, & -CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, & -HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & -ITIMESTEP,TICE2TSK_IF2COLD,XICE_THRESHOLD, & + XICE,SST,TSK_SEA, & + CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, & + HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & + ITIMESTEP,TICE2TSK_IF2COLD,XICE_THRESHOLD, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ustm,ck,cka,cd,cda,isftcflx,iz0tlnd, & sf_surface_physics ) - USE module_sf_sfclay + USE module_sf_sfclayrev implicit none INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & @@ -5216,7 +5276,9 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm + INTENT(OUT) :: ck,cka,cd,cda + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: ustm INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX,IZ0TLND @@ -5377,7 +5439,7 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & ! land/frozen-water call - call sfclay(U3D,V3D,T3D,QV3D,P3D,dz8w, & ! I + call sfclayrev(U3D,V3D,T3D,QV3D,P3D,dz8w, & ! I CP,G,ROVCP,R,XLV,PSFC,CHS,CHS2,CQS2,CPM, & ! I,I,I,I,I,I,IO,IO,IO,IO, ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, & FM,FH, & @@ -5460,7 +5522,7 @@ SUBROUTINE sfclayrev_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & ZOL_SEA = ZOL_HOLD ! ! open-water call - call sfclay(U3D,V3D,T3D,QV3D,P3D,dz8w, & ! I + call sfclayrev(U3D,V3D,T3D,QV3D,P3D,dz8w, & ! I CP,G,ROVCP,R,XLV,PSFC, & ! I CHS_SEA,CHS2_SEA,CQS2_SEA,CPM_SEA, & ! I/O ZNT_SEA,UST_SEA, & ! I/O @@ -5629,7 +5691,9 @@ SUBROUTINE sfclay_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, INTENT(IN ) :: CP,G,ROVCP,R,XLV,DX REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT) :: ck,cka,cd,cda,ustm + INTENT(OUT) :: ck,cka,cd,cda + REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: ustm INTEGER, OPTIONAL, INTENT(IN ) :: ISFTCFLX,IZ0TLND @@ -6250,7 +6314,7 @@ END SUBROUTINE pxsfclay_seaice_wrapper !------------------------------------------------------------------------- SUBROUTINE TOPO_RAD_ADJ_DRVR (XLAT,XLONG,COSZEN, & - shadowmask, & + shadowmask, diffuse_frac, & declin, & SWDOWN,GSW,SWNORM,GSWSAVE,solcon,hrang2d, & slope_in,slp_azi_in, & @@ -6265,6 +6329,8 @@ SUBROUTINE TOPO_RAD_ADJ_DRVR (XLAT,XLONG,COSZEN, & ids,ide,jds,jde,kds,kde INTEGER, DIMENSION( ims:ime, jms:jme ), & INTENT(IN) :: shadowmask + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(IN) :: diffuse_frac REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(IN ) :: XLAT,XLONG REAL, DIMENSION( ims:ime, jms:jme ), & @@ -6298,7 +6364,7 @@ SUBROUTINE TOPO_RAD_ADJ_DRVR (XLAT,XLONG,COSZEN, & XLAT1 = XLAT(i,j) XLONG1 = XLONG(i,j) CALL TOPO_RAD_ADJ (XLAT1,XLONG1,COSZEN(i,j), & - DECLIN,DEGRAD, & + diffuse_frac(i,j),DECLIN,DEGRAD, & SWDOWN_IN,solcon,hrang2d(i,j),SWDOWN_teradj, & kts,kte, & slope_in(i,j),slp_azi_in(i,j), & @@ -6318,7 +6384,7 @@ END SUBROUTINE TOPO_RAD_ADJ_DRVR !------------------------------------------------------------------ !------------------------------------------------------------------ SUBROUTINE TOPO_RAD_ADJ (XLAT1,XLONG1,COSZEN, & - DECLIN,DEGRAD, & + diffuse_frac_in,DECLIN,DEGRAD, & SWDOWN_IN,solcon,hrang,SWDOWN_teradj, & kts,kte, & slope,slp_azi, & @@ -6334,6 +6400,7 @@ SUBROUTINE TOPO_RAD_ADJ (XLAT1,XLONG1,COSZEN, & REAL, INTENT(IN) :: SWDOWN_IN,solcon,hrang INTEGER, INTENT(IN) :: shadow REAL, INTENT(IN) :: slp_azi,slope + REAL, INTENT(IN) :: diffuse_frac_in REAL, INTENT(OUT) :: SWDOWN_teradj @@ -6351,12 +6418,16 @@ SUBROUTINE TOPO_RAD_ADJ (XLAT1,XLONG1,COSZEN, & XXLAT=XLAT1*DEGRAD ! RETURN IF NIGHT - IF(CSZA.LE.1.E-9) return + IF(CSZA.LE.1.E-4) return -! Parameterize diffuse fraction of global solar radiation as a function of the ratio between TOA radiation and surface global radiation - diffuse_frac = min(1.,1./(max(0.1,2.1-2.8*log(log(csza*solcon/max(SWDOWN_IN,1.e-3)))))) - if ((slope.eq.0).or.(diffuse_frac.eq.1).or.(csza.lt.1.e-2)) then ! no topographic effects when all radiation diffuse or sun too close to horizon +! Parameterize diffuse fraction of global solar radiation as a function of the ratio +! between TOA radiation and surface global radiation +! diffuse_frac = min(1.,1./(max(0.1,2.1-2.8*log(log(csza*solcon/max(SWDOWN_IN,1.e-3)))))) + diffuse_frac = diffuse_frac_in + if ((slope.eq.0).or.(diffuse_frac.eq.1).or.(csza.le.1.e-4)) then +! no topographic effects when all radiation diffuse or sun too close to horizon corr_fac = 1 + if(shadow.eq.1) corr_fac = diffuse_frac goto 140 endif @@ -6371,7 +6442,8 @@ SUBROUTINE TOPO_RAD_ADJ (XLAT1,XLONG1,COSZEN, & ! Topographic shading if (shadow.eq.1) csza_slp = 0 -! Correction factor for sloping topography; the diffuse fraction of solar radiation is assumed to be unaffected by the slope +! Correction factor for sloping topography; the diffuse fraction of solar radiation +! is assumed to be unaffected by the slope corr_fac = diffuse_frac + (1-diffuse_frac)*csza_slp/csza 140 continue diff --git a/wrfv2_fire/phys/rrtmg_lw_cpu_args.h b/wrfv2_fire/phys/rrtmg_lw_cpu_args.h new file mode 100644 index 00000000..30aa7977 --- /dev/null +++ b/wrfv2_fire/phys/rrtmg_lw_cpu_args.h @@ -0,0 +1,7 @@ +#ifndef _ACCEL + ,ncol_,nlayers_,nbndlw_,ngptlw_ & + ,taucmcd,pzd,pwvcmd,semissd,planklayd,planklevd,plankbndd,gurad,gdrad,gclrurad,gclrdrad & + ,gdtotuflux_dtd,gdtotuclfl_dtd,idrvd,bpaded,heatfacd,fluxfacd,a0d,a1d,a2d & + ,delwaved,totufluxd,totdfluxd,fnetd,htrd,totuclfld,totdclfld,fnetcd,htrcd,dtotuflux_dtd & + ,dtotuclfl_dtd,dplankbnd_dtd & +#endif diff --git a/wrfv2_fire/phys/rrtmg_lw_cpu_defs.h b/wrfv2_fire/phys/rrtmg_lw_cpu_defs.h new file mode 100644 index 00000000..3f6edfc1 --- /dev/null +++ b/wrfv2_fire/phys/rrtmg_lw_cpu_defs.h @@ -0,0 +1,58 @@ +#ifndef _ACCEL + integer :: ncol_,nlayers_,nbndlw_,ngptlw_ +! changed to arguments for thread safety +# ifndef ncol_ +# define ncol_ CHNK +# endif + integer :: ngsd(nbndlw) + +! Atmosphere + real :: taucmcd(ncol_, ngptlw_, nlayers_+1) + + real , dimension(ncol_, 0:nlayers_+1) :: pzd ! level (interface) pressures (hPa, mb) + ! Dimensions: (ncol,0:nlayers) + real , dimension(ncol_) :: pwvcmd ! precipitable water vapor (cm) + ! Dimensions: (ncol) + real , dimension(ncol_,nbndlw_) :: semissd ! lw surface emissivity + ! Dimensions: (ncol,nbndlw) + real , dimension(ncol_,nlayers_+1,nbndlw_) :: planklayd ! + ! Dimensions: (ncol,nlayers+1,nbndlw) + real , dimension(ncol_,0:nlayers_+1,nbndlw_) :: planklevd ! + ! Dimensions: (ncol,0:nlayers+1,nbndlw) + real, dimension(ncol_,nbndlw_) :: plankbndd ! + ! Dimensions: (ncol,nbndlw) + + real :: gurad(ncol_,ngptlw_,0:nlayers_+1) ! upward longwave flux (w/m2) + real :: gdrad(ncol_,ngptlw_,0:nlayers_+1) ! downward longwave flux (w/m2) + real :: gclrurad(ncol_,ngptlw_,0:nlayers_+1) ! clear sky upward longwave flux (w/m2) + real :: gclrdrad(ncol_,ngptlw_,0:nlayers_+1) ! clear sky downward longwave flux (w/m2) + + real :: gdtotuflux_dtd(ncol_, ngptlw_, 0:nlayers_+1) ! change in upward longwave flux (w/m1/k) + ! with respect to surface temperature + + real :: gdtotuclfl_dtd(ncol_, ngptlw_, 0:nlayers_+1) ! change in clear sky upward longwave flux (w/m2/k) + ! with respect to surface temperature + +! Clouds + integer :: idrvd ! flag for calculation of dF/dt from + ! Planck derivative [0=off, 1=on] + real :: bpaded + real :: heatfacd + real :: fluxfacd + real :: a0d(nbndlw_), a1d(nbndlw_), a2d(nbndlw_) + real :: delwaved(nbndlw_) + real :: totufluxd(ncol_, 0:nlayers_+1) ! upward longwave flux (w/m2) + real :: totdfluxd(ncol_, 0:nlayers_+1) ! downward longwave flux (w/m2) + real :: fnetd(ncol_, 0:nlayers_+1) ! net longwave flux (w/m2) + real :: htrd(ncol_, 0:nlayers_+1) ! longwave heating rate (k/day) + real :: totuclfld(ncol_, 0:nlayers_+1) ! clear sky upward longwave flux (w/m2) + real :: totdclfld(ncol_, 0:nlayers_+1) ! clear sky downward longwave flux (w/m2) + real :: fnetcd(ncol_, 0:nlayers_+1) ! clear sky net longwave flux (w/m2) + real :: htrcd(ncol_, 0:nlayers_+1) ! clear sky longwave heating rate (k/day) + real :: dtotuflux_dtd(ncol_, 0:nlayers_+1) ! change in upward longwave flux (w/m2/k) + ! with respect to surface temperature + real :: dtotuclfl_dtd(ncol_, 0:nlayers_+1) ! change in clear sky upward longwave flux (w/m2/k) + ! with respect to surface temperature + real :: dplankbnd_dtd(ncol_,nbndlw_) +# undef ncol_ +#endif diff --git a/wrfv2_fire/phys/taug_cpu_args.h b/wrfv2_fire/phys/taug_cpu_args.h new file mode 100644 index 00000000..f1efb650 --- /dev/null +++ b/wrfv2_fire/phys/taug_cpu_args.h @@ -0,0 +1,9 @@ +#ifndef _ACCEL + ,ncol__,nlayers__,nbndlw__,ngptlw__ & + ,pavel,wx1,wx2,wx3,wx4,coldry,laytrop,jp,jt,jt1,colh2o,colco2,colo3,coln2o & + ,colco,colch4,colo2,colbrd,indself,indfor,selffac,selffrac,forfac,forfrac & + ,indminor,minorfrac,scaleminor,scaleminorn2,fac00,fac01,fac10,fac11 & + ,rat_h2oco2,rat_h2oco2_1,rat_h2oo3,rat_h2oo3_1,rat_h2on2o,rat_h2on2o_1 & + ,rat_h2och4,rat_h2och4_1,rat_n2oco2,rat_n2oco2_1,rat_o3co2,rat_o3co2_1 & + ,tauaa,nspad,nspbd,oneminusd & +#endif diff --git a/wrfv2_fire/phys/taug_cpu_defs.h b/wrfv2_fire/phys/taug_cpu_defs.h new file mode 100644 index 00000000..1ee62dc1 --- /dev/null +++ b/wrfv2_fire/phys/taug_cpu_defs.h @@ -0,0 +1,50 @@ +#ifndef _ACCEL + integer :: ncol__,nlayers__,nbndlw__,ngptlw__ +! changed to arguments for thread safety (could reduce this list a bit) +# ifndef ncol__ +# define ncol__ CHNK +# endif + real :: pavel(ncol__, nlayers__) + real :: wx1(ncol__,nlayers__) + real :: wx2(ncol__,nlayers__) + real :: wx3(ncol__,nlayers__) + real :: wx4(ncol__,nlayers__) + real :: coldry(ncol__, nlayers__) + integer :: laytrop(ncol__) + integer :: jp(ncol__,nlayers__) + integer :: jt(ncol__,nlayers__) + integer :: jt1(ncol__,nlayers__) + real :: colh2o(ncol__,nlayers__) + real :: colco2(ncol__,nlayers__) + real :: colo3(ncol__,nlayers__) + real :: coln2o(ncol__,nlayers__) + real :: colco(ncol__,nlayers__) + real :: colch4(ncol__,nlayers__) + real :: colo2(ncol__,nlayers__) + real :: colbrd(ncol__,nlayers__) + integer :: indself(ncol__,nlayers__) + integer :: indfor(ncol__,nlayers__) + real :: selffac(ncol__,nlayers__) + real :: selffrac(ncol__,nlayers__) + real :: forfac(ncol__,nlayers__) + real :: forfrac(ncol__,nlayers__) + integer :: indminor(ncol__,nlayers__) + real :: minorfrac(ncol__,nlayers__) + real :: scaleminor(ncol__,nlayers__) + real :: scaleminorn2(ncol__,nlayers__) + real :: fac00(ncol__,nlayers__), fac01(ncol__,nlayers__), fac10(ncol__,nlayers__), fac11(ncol__,nlayers__) + real :: rat_h2oco2(ncol__,nlayers__),rat_h2oco2_1(ncol__,nlayers__), & + rat_h2oo3(ncol__,nlayers__),rat_h2oo3_1(ncol__,nlayers__), & + rat_h2on2o(ncol__,nlayers__),rat_h2on2o_1(ncol__,nlayers__), & + rat_h2och4(ncol__,nlayers__),rat_h2och4_1(ncol__,nlayers__), & + rat_n2oco2(ncol__,nlayers__),rat_n2oco2_1(ncol__,nlayers__), & + rat_o3co2(ncol__,nlayers__),rat_o3co2_1(ncol__,nlayers__) + ! Dimensions: (ncol__,nlayers__) + real :: tauaa(ncol__, nlayers__, nbndlw__) + ! Dimensions: (ncol__,nlayers__,ngptlw__) + + integer :: nspad(nbndlw__) + integer :: nspbd(nbndlw__) + real :: oneminusd +# undef ncol__ +#endif diff --git a/wrfv2_fire/run/MPTABLE.TBL b/wrfv2_fire/run/MPTABLE.TBL index 97990c7e..d225d1f2 100644 --- a/wrfv2_fire/run/MPTABLE.TBL +++ b/wrfv2_fire/run/MPTABLE.TBL @@ -35,7 +35,7 @@ ISURBAN = 1 ISWATER = 16 ISBARREN = 19 - ISSNOW = 24 + ISICE = 24 EBLFOREST = 13 !--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -48,26 +48,27 @@ HVB = 1.00, 0.10, 0.10, 0.10, 0.10, 0.15, 0.05, 0.10, 0.10, 0.10, 11.5, 7.00, 8.00, 8.50, 10.0, 0.00, 0.05, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, DEN = 0.01, 25.0, 25.0, 25.0, 25.0, 25.0, 100., 10.0, 10.0, 0.02, 0.10, 0.28, 0.02, 0.28, 0.10, 0.01, 10.0, 0.10, 0.01, 1.00, 1.00, 1.00, 1.00, 0.00, 0.01, 0.01, 0.01, RC = 1.00, 0.08, 0.08, 0.08, 0.08, 0.08, 0.03, 0.12, 0.12, 3.00, 1.40, 1.20, 3.60, 1.20, 1.40, 0.01, 0.10, 1.40, 0.01, 0.30, 0.30, 0.30, 0.30, 0.00, 0.01, 0.01, 0.01, + MFSNO = 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, ! Row 1: Vis ! Row 2: Near IR - RHOL = 0.00, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.07, 0.10, 0.10, 0.10, 0.07, 0.10, 0.07, 0.10, 0.00, 0.11, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, - 0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.35, 0.45, 0.00, 0.58, 0.45, 0.00, 0.45, 0.45, 0.45, 0.45, 0.00, 0.45, 0.00, 0.00, + RHOL_VIS=0.00, 0.11, 0.11, 0.11, 0.11, 0.11, 0.11, 0.07, 0.10, 0.10, 0.10, 0.07, 0.10, 0.07, 0.10, 0.00, 0.11, 0.10, 0.00, 0.10, 0.10, 0.10, 0.10, 0.00, 0.10, 0.00, 0.00, + RHOL_NIR=0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.35, 0.45, 0.45, 0.45, 0.35, 0.45, 0.35, 0.45, 0.00, 0.58, 0.45, 0.00, 0.45, 0.45, 0.45, 0.45, 0.00, 0.45, 0.00, 0.00, ! Row 1: Vis ! Row 2: Near IR - RHOS = 0.00, 0.36, 0.36, 0.36, 0.36, 0.36, 0.36, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.00, 0.36, 0.16, 0.00, 0.16, 0.16, 0.16, 0.16, 0.00, 0.16, 0.00, 0.00, - 0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.00, 0.58, 0.39, 0.00, 0.39, 0.39, 0.39, 0.39, 0.00, 0.39, 0.00, 0.00, + RHOS_VIS=0.00, 0.36, 0.36, 0.36, 0.36, 0.36, 0.36, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.00, 0.36, 0.16, 0.00, 0.16, 0.16, 0.16, 0.16, 0.00, 0.16, 0.00, 0.00, + RHOS_NIR=0.00, 0.58, 0.58, 0.58, 0.58, 0.58, 0.58, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.00, 0.58, 0.39, 0.00, 0.39, 0.39, 0.39, 0.39, 0.00, 0.39, 0.00, 0.00, ! Row 1: Vis ! Row 2: Near IR - TAUL = 0.00, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.00, 0.07, 0.05, 0.00, 0.05, 0.05, 0.05, 0.05, 0.00, 0.05, 0.00, 0.00, - 0.00, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.10, 0.10, 0.25, 0.25, 0.10, 0.25, 0.10, 0.25, 0.00, 0.25, 0.25, 0.00, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, + TAUL_VIS=0.00, 0.07, 0.07, 0.07, 0.07, 0.07, 0.07, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.00, 0.07, 0.05, 0.00, 0.05, 0.05, 0.05, 0.05, 0.00, 0.05, 0.00, 0.00, + TAUL_NIR=0.00, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.10, 0.10, 0.25, 0.25, 0.10, 0.25, 0.10, 0.25, 0.00, 0.25, 0.25, 0.00, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, ! Row 1: Vis ! Row 2: Near IR - TAUS = 0.000, 0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.220, 0.001, 0.000, 0.220, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, - 0.000, 0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.380, 0.001, 0.000, 0.380, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + TAUS_VIS=0.00, 0.220, 0.220, 0.220, 0.220, 0.220, 0.220, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.220, 0.001, 0.000, 0.220, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, + TAUS_NIR=0.00, 0.380, 0.380, 0.380, 0.380, 0.380, 0.380, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.000, 0.380, 0.001, 0.000, 0.380, 0.001, 0.001, 0.001, 0.000, 0.001, 0.000, 0.000, XL = 0.000, -0.30, -0.30, -0.30, -0.30, -0.30, -0.30, 0.010, 0.250, 0.010, 0.250, 0.010, 0.010, 0.010, 0.250, 0.000, -0.30, 0.250, 0.000, -0.30, 0.250, 0.250, 0.250, 0.000, 0.250, 0.000, 0.000, ! CWPVT = 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, @@ -99,47 +100,48 @@ WDPOOL= 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.00, 1.00, 0.00, 0.00, 1.00, 1.00, 0.00, 0.00, 0.00, 0.00, 0.00, WRRAT = 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 3.00, 30.0, 30.0, 30.0, 30.0, 30.0, 0.00, 0.00, 30.0, 0.00, 0.00, 3.00, 3.00, 0.00, 0.00, 0.00, 0.00, 0.00, MRP = 0.00, 0.23, 0.23, 0.23, 0.23, 0.23, 0.17, 0.19, 0.19, 0.40, 0.40, 0.37, 0.23, 0.37, 0.30, 0.00, 0.17, 0.40, 0.00, 0.17, 0.23, 0.20, 0.00, 0.00, 0.20, 0.00, 0.00, + NROOT = 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, 4, 4, 4, 4, 4, 0, 2, 2, 1, 3, 3, 3, 2, 1, 1, 0, 0, + RGL = 999.0, 100.0, 100.0, 100.0, 100.0, 65.0, 100.0, 100.0, 100.0, 65.0, 30.0, 30.0, 30.0, 30.0, 30.0, 30.0, 100.0, 30.0, 999.0, 100.0, 100.0, 100.0, 100.0, 999.0, 100.0, 999.0, 999.0, + RS = 200.0, 40.0, 40.0, 40.0, 40.0, 70.0, 40.0, 300.0, 170.0, 70.0, 100.0, 150.0, 150.0, 125.0, 125.0, 100.0, 40.0, 100.0, 999.0, 150.0, 150.0, 150.0, 200.0, 999.0, 40.0, 999.0, 999.0, + HS = 999.0, 36.25, 36.25, 36.25, 36.25, 44.14, 36.35, 42.00, 39.18, 54.53, 54.53, 47.35, 41.69, 47.35, 51.93, 51.75, 60.00, 51.93, 999.0, 42.00, 42.00, 42.00, 42.00, 999.0, 36.25, 999.0, 999.0, + TOPT = 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, + RSMAX = 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., ! Monthly values, one row for each month: - SAIM = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.3, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.2, 0.2, 0.2, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.4, 0.4, 0.0, 0.3, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.3, 0.3, 0.3, 0.4, 0.4, 0.4, 0.2, 0.3, 0.4, 0.4, 0.7, 0.5, 0.5, 0.4, 0.0, 0.4, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.4, 0.4, 0.4, 0.6, 0.6, 0.8, 0.4, 0.6, 0.8, 0.9, 1.3, 0.5, 0.5, 0.7, 0.0, 0.6, 0.6, 0.0, 0.4, 0.4, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.5, 0.5, 0.5, 0.9, 0.9, 1.3, 0.6, 0.9, 1.2, 1.2, 1.2, 0.5, 0.6, 0.8, 0.0, 0.9, 0.9, 0.0, 0.6, 0.6, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.4, 0.4, 0.4, 0.7, 1.0, 1.1, 0.8, 1.0, 1.3, 1.6, 1.0, 0.5, 0.6, 1.0, 0.0, 0.7, 1.0, 0.0, 0.7, 0.8, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.3, 0.3, 0.3, 0.3, 0.8, 0.4, 0.7, 0.6, 0.7, 1.4, 0.8, 0.5, 0.7, 1.0, 0.0, 0.3, 0.8, 0.0, 0.5, 0.7, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.3, 0.3, 0.3, 0.3, 0.4, 0.4, 0.3, 0.3, 0.4, 0.6, 0.6, 0.5, 0.6, 0.5, 0.0, 0.3, 0.4, 0.0, 0.3, 0.3, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.4, 0.2, 0.3, 0.4, 0.4, 0.5, 0.5, 0.5, 0.4, 0.0, 0.3, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_JAN = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_FEB = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_MAR = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.3, 0.5, 0.4, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_APR = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.3, 0.4, 0.0, 0.2, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_MAY = 0.0, 0.2, 0.2, 0.2, 0.3, 0.3, 0.3, 0.2, 0.2, 0.3, 0.4, 0.4, 0.5, 0.4, 0.4, 0.0, 0.3, 0.3, 0.0, 0.1, 0.2, 0.1, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_JUN = 0.0, 0.3, 0.3, 0.3, 0.4, 0.4, 0.4, 0.2, 0.3, 0.4, 0.4, 0.7, 0.5, 0.5, 0.4, 0.0, 0.4, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_JUL = 0.0, 0.4, 0.4, 0.4, 0.6, 0.6, 0.8, 0.4, 0.6, 0.8, 0.9, 1.3, 0.5, 0.5, 0.7, 0.0, 0.6, 0.6, 0.0, 0.4, 0.4, 0.4, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_AUG = 0.0, 0.5, 0.5, 0.5, 0.9, 0.9, 1.3, 0.6, 0.9, 1.2, 1.2, 1.2, 0.5, 0.6, 0.8, 0.0, 0.9, 0.9, 0.0, 0.6, 0.6, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_SEP = 0.0, 0.4, 0.4, 0.4, 0.7, 1.0, 1.1, 0.8, 1.0, 1.3, 1.6, 1.0, 0.5, 0.6, 1.0, 0.0, 0.7, 1.0, 0.0, 0.7, 0.8, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_OCT = 0.0, 0.3, 0.3, 0.3, 0.3, 0.8, 0.4, 0.7, 0.6, 0.7, 1.4, 0.8, 0.5, 0.7, 1.0, 0.0, 0.3, 0.8, 0.0, 0.5, 0.7, 0.5, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_NOV = 0.0, 0.3, 0.3, 0.3, 0.3, 0.4, 0.4, 0.3, 0.3, 0.4, 0.6, 0.6, 0.5, 0.6, 0.5, 0.0, 0.3, 0.4, 0.0, 0.3, 0.3, 0.3, 0.0, 0.0, 0.0, 0.0, 0.0, + SAI_DEC = 0.0, 0.3, 0.3, 0.3, 0.3, 0.3, 0.4, 0.2, 0.3, 0.4, 0.4, 0.5, 0.5, 0.5, 0.4, 0.0, 0.3, 0.4, 0.0, 0.2, 0.2, 0.2, 0.0, 0.0, 0.0, 0.0, 0.0, - LAIM = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.3, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.0, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.0, 0.0, 0.0, 0.4, 0.6, 0.7, 0.6, 0.7, 0.8, 1.2, 0.6, 4.5, 4.0, 2.6, 0.0, 0.4, 0.6, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 1.0, 1.0, 1.0, 1.1, 2.0, 1.2, 1.5, 1.4, 1.8, 3.0, 1.2, 4.5, 4.0, 3.5, 0.0, 1.1, 2.0, 0.0, 0.6, 1.7, 1.2, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 2.0, 2.0, 2.0, 2.5, 3.3, 3.0, 2.3, 2.6, 3.6, 4.7, 2.0, 4.5, 4.0, 4.3, 0.0, 2.5, 3.3, 0.0, 1.5, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 3.0, 3.0, 3.0, 3.2, 3.7, 3.5, 2.3, 2.9, 3.8, 4.5, 2.6, 4.5, 4.0, 4.3, 0.0, 3.2, 3.7, 0.0, 1.7, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 3.0, 3.0, 3.0, 2.2, 3.2, 1.5, 1.7, 1.6, 2.1, 3.4, 1.7, 4.5, 4.0, 3.7, 0.0, 2.2, 3.2, 0.0, 0.8, 1.8, 1.3, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 1.5, 1.5, 1.5, 1.1, 1.3, 0.7, 0.6, 0.7, 0.9, 1.2, 1.0, 4.5, 4.0, 2.6, 0.0, 1.1, 1.3, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.5, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.2, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_JAN = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_FEB = 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.3, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_MAR = 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.0, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_APR = 0.0, 0.0, 0.0, 0.0, 0.4, 0.6, 0.7, 0.6, 0.7, 0.8, 1.2, 0.6, 4.5, 4.0, 2.6, 0.0, 0.4, 0.6, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_MAY = 0.0, 1.0, 1.0, 1.0, 1.1, 2.0, 1.2, 1.5, 1.4, 1.8, 3.0, 1.2, 4.5, 4.0, 3.5, 0.0, 1.1, 2.0, 0.0, 0.6, 1.7, 1.2, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_JUN = 0.0, 2.0, 2.0, 2.0, 2.5, 3.3, 3.0, 2.3, 2.6, 3.6, 4.7, 2.0, 4.5, 4.0, 4.3, 0.0, 2.5, 3.3, 0.0, 1.5, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_JUL = 0.0, 3.0, 3.0, 3.0, 3.2, 3.7, 3.5, 2.3, 2.9, 3.8, 4.5, 2.6, 4.5, 4.0, 4.3, 0.0, 3.2, 3.7, 0.0, 1.7, 2.1, 1.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_AUG = 0.0, 3.0, 3.0, 3.0, 2.2, 3.2, 1.5, 1.7, 1.6, 2.1, 3.4, 1.7, 4.5, 4.0, 3.7, 0.0, 2.2, 3.2, 0.0, 0.8, 1.8, 1.3, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_SEP = 0.0, 1.5, 1.5, 1.5, 1.1, 1.3, 0.7, 0.6, 0.7, 0.9, 1.2, 1.0, 4.5, 4.0, 2.6, 0.0, 1.1, 1.3, 0.0, 0.4, 1.3, 0.8, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_OCT = 0.0, 0.0, 0.0, 0.0, 0.3, 0.2, 0.6, 0.2, 0.4, 0.5, 0.3, 0.5, 4.5, 4.0, 2.2, 0.0, 0.3, 0.3, 0.0, 0.3, 1.1, 0.7, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_NOV = 0.0, 0.0, 0.0, 0.0, 0.3, 0.0, 0.5, 0.0, 0.3, 0.3, 0.0, 0.2, 4.5, 4.0, 2.0, 0.0, 0.3, 0.3, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, + LAI_DEC = 0.0, 0.0, 0.0, 0.0, 0.2, 0.0, 0.4, 0.0, 0.2, 0.3, 0.0, 0.0, 4.5, 4.0, 2.0, 0.0, 0.2, 0.2, 0.0, 0.2, 1.0, 0.6, 0.0, 0.0, 0.0, 0.0, 0.0, SLAREA=0.0228,0.0200,0.0200,0.0295,0.0223,0.0277,0.0060,0.0227,0.0188,0.0236,0.0258,0.0200,0.0200,0.0090,0.0223,0.0422,0.0390, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, 0.02, -! Five types, one row for each type. - EPS = 41.87, 0.00, 0.00, 2.52, 0.04, 17.11, 0.02, 21.62, 0.11, 22.80, 46.86, 0.00, 0.00, 0.46, 30.98, 2.31, 1.63, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.98, 0.00, 0.00, 0.16, 0.09, 0.28, 0.05, 0.92, 0.22, 0.59, 0.38, 0.00, 0.00, 3.34, 0.96, 1.47, 1.07, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, - 1.82, 0.00, 0.00, 0.23, 0.05, 0.81, 0.03, 1.73, 1.26, 1.37, 1.84, 0.00, 0.00, 1.85, 1.84, 1.70, 1.21, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, -/ - -&noah_mp_modis_veg_categories - VEG_DATASET_DESCRIPTION = "modified igbp modis noah" - NVEG = 20 +! Five types, one row for each type (BVOC currently not active). + EPS1 = 41.87, 0.00, 0.00, 2.52, 0.04, 17.11, 0.02, 21.62, 0.11, 22.80, 46.86, 0.00, 0.00, 0.46, 30.98, 2.31, 1.63, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + EPS2 = 0.98, 0.00, 0.00, 0.16, 0.09, 0.28, 0.05, 0.92, 0.22, 0.59, 0.38, 0.00, 0.00, 3.34, 0.96, 1.47, 1.07, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + EPS3 = 1.82, 0.00, 0.00, 0.23, 0.05, 0.81, 0.03, 1.73, 1.26, 1.37, 1.84, 0.00, 0.00, 1.85, 1.84, 1.70, 1.21, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + EPS4 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + EPS5 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, / &noah_mp_modis_veg_categories @@ -172,7 +174,7 @@ ISURBAN = 13 ISWATER = 17 ISBARREN = 16 - ISSNOW = 15 + ISICE = 15 EBLFOREST = 2 !--------------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -185,26 +187,27 @@ HVB = 8.50, 8.00, 7.00, 11.5, 10.0, 0.10, 0.10, 0.10, 0.10, 0.05, 0.10, 0.10, 1.00, 0.10, 0.00, 0.00, 0.00, 0.30, 0.20, 0.10, DEN = 0.28, 0.02, 0.28, 0.10, 0.10, 10.0, 10.0, 10.0, 0.02, 100., 5.05, 25.0, 0.01, 25.0, 0.00, 0.01, 0.01, 1.00, 1.00, 1.00, RC = 1.20, 3.60, 1.20, 1.40, 1.40, 0.12, 0.12, 0.12, 3.00, 0.03, 0.75, 0.08, 1.00, 0.08, 0.00, 0.01, 0.01, 0.30, 0.30, 0.30, + MFSNO = 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, 2.50, ! Row 1: Vis ! Row 2: Near IR - RHOL = 0.07, 0.10, 0.07, 0.10, 0.10, 0.07, 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, 0.10, 0.10, - 0.35, 0.45, 0.35, 0.45, 0.45, 0.35, 0.35, 0.35, 0.45, 0.58, 0.515, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.45, 0.45, 0.45, + RHOL_VIS=0.07, 0.10, 0.07, 0.10, 0.10, 0.07, 0.07, 0.07, 0.10, 0.11, 0.105, 0.11, 0.00, 0.11, 0.00, 0.00, 0.00, 0.10, 0.10, 0.10, + RHOL_NIR=0.35, 0.45, 0.35, 0.45, 0.45, 0.35, 0.35, 0.35, 0.45, 0.58, 0.515, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.45, 0.45, 0.45, ! Row 1: Vis ! Row 2: Near IR - RHOS = 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.36, 0.26, 0.36, 0.00, 0.36, 0.00, 0.00, 0.00, 0.16, 0.16, 0.16, - 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.58, 0.485, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.39, 0.39, 0.39, + RHOS_VIS=0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.16, 0.36, 0.26, 0.36, 0.00, 0.36, 0.00, 0.00, 0.00, 0.16, 0.16, 0.16, + RHOS_NIR=0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.39, 0.58, 0.485, 0.58, 0.00, 0.58, 0.00, 0.00, 0.00, 0.39, 0.39, 0.39, ! Row 1: Vis ! Row 2: Near IR - TAUL = 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.07, 0.06, 0.07, 0.00, 0.07, 0.00, 0.00, 0.00, 0.05, 0.05, 0.05, - 0.10, 0.25, 0.10, 0.25, 0.25, 0.10, 0.10, 0.10, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, 0.00, 0.25, 0.25, 0.25, + TAUL_VIS=0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.07, 0.06, 0.07, 0.00, 0.07, 0.00, 0.00, 0.00, 0.05, 0.05, 0.05, + TAUL_NIR=0.10, 0.25, 0.10, 0.25, 0.25, 0.10, 0.10, 0.10, 0.25, 0.25, 0.25, 0.25, 0.00, 0.25, 0.00, 0.00, 0.00, 0.25, 0.25, 0.25, ! Row 1: Vis ! Row 2: Near IR - TAUS = 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220, 0.1105, 0.220, 0.000, 0.220, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, - 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380, 0.1905, 0.380, 0.000, 0.380, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, + TAUS_VIS=0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.220, 0.1105, 0.220, 0.000, 0.220, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, + TAUS_NIR=0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.001, 0.380, 0.1905, 0.380, 0.000, 0.380, 0.000, 0.000, 0.000, 0.001, 0.001, 0.001, XL = 0.010, 0.010, 0.010, 0.250, 0.250, 0.010, 0.010, 0.010, 0.010, -0.30, -0.025, -0.30, 0.000, -0.30, 0.000, 0.000, 0.000, 0.250, 0.250, 0.250, ! CWPVT = 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, 3.0, @@ -236,53 +239,64 @@ WDPOOL= 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 1.00, 0.00, 0.5, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 1.00, 1.00, 0.00, WRRAT = 30.0, 30.0, 30.0, 30.0, 30.0, 3.00, 3.00, 3.00, 3.00, 0.00, 15.0, 0.00, 0.00, 0.00, 0.00, 0.00, 0.00, 3.00, 3.00, 0.00, MRP = 0.37, 0.23, 0.37, 0.40, 0.30, 0.19, 0.19, 0.19, 0.40, 0.17, 0.285, 0.23, 0.00, 0.23, 0.00, 0.00, 0.00, 0.23, 0.20, 0.00, + NROOT = 4, 4, 4, 4, 4, 3, 3, 3, 3, 3, 2, 3, 1, 3, 1, 1, 0, 3, 3, 2, + RGL = 30.0, 30.0, 30.0, 30.0, 30.0, 100.0, 100.0, 100.0, 65.0, 100.0, 65.0, 100.0, 999.0, 100.0, 999.0, 999.0, 30.0, 100.0, 100.0, 100.0, + RS = 125.0, 150.0, 150.0, 100.0, 125.0, 300.0, 170.0, 300.0, 70.0, 40.0, 70.0, 40.0, 200.0, 40.0, 999.0, 999.0, 100.0, 150.0, 150.0, 200.0, + HS = 47.35, 41.69, 47.35, 54.53, 51.93, 42.00, 39.18, 42.00, 54.53, 36.35, 55.97, 36.25, 999.0, 36.25, 999.0, 999.0, 51.75, 42.00, 42.00, 42.00, + TOPT = 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, 298.0, + RSMAX = 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., 5000., ! Monthly values, one row for each month: - SAIM = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, - 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, - 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, - 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, - 0.4, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, - 0.5, 0.5, 0.7, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.4, 0.3, 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, - 0.5, 0.5, 1.3, 0.9, 0.7, 0.6, 0.4, 0.7, 0.8, 0.8, 0.6, 0.4, 0.0, 0.6, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, - 0.6, 0.5, 1.2, 1.2, 0.8, 0.9, 0.6, 1.2, 1.2, 1.3, 0.9, 0.5, 0.0, 0.9, 0.0, 0.0, 0.0, 0.6, 0.6, 0.0, - 0.6, 0.5, 1.0, 1.6, 1.0, 1.2, 0.8, 1.4, 1.3, 1.1, 0.9, 0.4, 0.0, 0.7, 0.0, 0.0, 0.0, 0.8, 0.7, 0.0, - 0.7, 0.5, 0.8, 1.4, 1.0, 0.9, 0.7, 1.1, 0.7, 0.4, 0.6, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.7, 0.5, 0.0, - 0.6, 0.5, 0.6, 0.6, 0.5, 0.4, 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.3, 0.3, 0.0, - 0.5, 0.5, 0.5, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, + SAI_JAN = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_FEB = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_MAR = 0.4, 0.5, 0.3, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_APR = 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_MAY = 0.4, 0.5, 0.4, 0.4, 0.4, 0.3, 0.2, 0.4, 0.3, 0.3, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.1, 0.0, + SAI_JUN = 0.5, 0.5, 0.7, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.4, 0.3, 0.0, 0.4, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, + SAI_JUL = 0.5, 0.5, 1.3, 0.9, 0.7, 0.6, 0.4, 0.7, 0.8, 0.8, 0.6, 0.4, 0.0, 0.6, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, + SAI_AUG = 0.6, 0.5, 1.2, 1.2, 0.8, 0.9, 0.6, 1.2, 1.2, 1.3, 0.9, 0.5, 0.0, 0.9, 0.0, 0.0, 0.0, 0.6, 0.6, 0.0, + SAI_SEP = 0.6, 0.5, 1.0, 1.6, 1.0, 1.2, 0.8, 1.4, 1.3, 1.1, 0.9, 0.4, 0.0, 0.7, 0.0, 0.0, 0.0, 0.8, 0.7, 0.0, + SAI_OCT = 0.7, 0.5, 0.8, 1.4, 1.0, 0.9, 0.7, 1.1, 0.7, 0.4, 0.6, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.7, 0.5, 0.0, + SAI_NOV = 0.6, 0.5, 0.6, 0.6, 0.5, 0.4, 0.3, 0.5, 0.4, 0.4, 0.4, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.3, 0.3, 0.0, + SAI_DEC = 0.5, 0.5, 0.5, 0.4, 0.4, 0.3, 0.2, 0.4, 0.4, 0.4, 0.3, 0.3, 0.0, 0.3, 0.0, 0.0, 0.0, 0.2, 0.2, 0.0, - LAIM = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, - 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, - 4.0, 4.5, 0.0, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, - 4.0, 4.5, 0.6, 1.2, 2.6, 0.9, 0.6, 1.0, 0.8, 0.7, 0.5, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, - 4.0, 4.5, 1.2, 3.0, 3.5, 2.2, 1.5, 2.4, 1.8, 1.2, 1.5, 1.0, 0.0, 1.1, 0.0, 0.0, 0.0, 1.7, 1.2, 0.0, - 4.0, 4.5, 2.0, 4.7, 4.3, 3.5, 2.3, 4.1, 3.6, 3.0, 2.9, 2.0, 0.0, 2.5, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, - 4.0, 4.5, 2.6, 4.5, 4.3, 3.5, 2.3, 4.1, 3.8, 3.5, 3.5, 3.0, 0.0, 3.2, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, - 4.0, 4.5, 1.7, 3.4, 3.7, 2.5, 1.7, 2.7, 2.1, 1.5, 2.7, 3.0, 0.0, 2.2, 0.0, 0.0, 0.0, 1.8, 1.3, 0.0, - 4.0, 4.5, 1.0, 1.2, 2.6, 0.9, 0.6, 1.0, 0.9, 0.7, 1.2, 1.5, 0.0, 1.1, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, - 4.0, 4.5, 0.5, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, - 4.0, 4.5, 0.2, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, - 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, - -! LAIM = 5.1, 3.3, 0.0, 1.9, 3.0, 1.0, 0.8, 0.5, 0.5, 0.7, 0.3, 1.8, 0.0, 2.4, 0.0, 0.0, 0.0, 0.6, 0.7, 0.0, -! 5.0, 3.6, 0.0, 1.9, 2.9, 1.0, 0.6, 1.0, 1.0, 0.7, 0.45, 1.9, 0.0, 2.6, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, -! 5.1, 4.4, 0.0, 2.1, 3.3, 1.0, 0.8, 1.8, 1.7, 1.1, 0.5, 2.6, 0.0, 2.9, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, -! 5.3, 5.4, 0.6, 2.5, 4.0, 1.0, 0.9, 2.6, 2.9, 1.7, 0.55, 3.9, 0.0, 3.4, 0.0, 0.0, 0.0, 0.4, 0.4, 0.0, -! 5.9, 6.2, 1.2, 3.1, 5.0, 1.0, 1.5, 3.4, 3.6, 2.5, 0.85, 5.2, 0.0, 4.0, 0.0, 0.0, 0.0, 0.8, 1.0, 0.0, -! 6.3, 6.4, 2.0, 3.3, 5.4, 1.0, 2.1, 3.6, 3.5, 2.7, 1.85, 5.6, 0.0, 4.2, 0.0, 0.0, 0.0, 2.0, 2.3, 0.0, -! 6.4, 5.9, 2.6, 3.3, 5.4, 1.0, 2.6, 3.4, 2.9, 2.8, 2.6, 5.3, 0.0, 4.1, 0.0, 0.0, 0.0, 3.3, 3.3, 0.0, -! 6.1, 5.6, 1.7, 3.1, 5.0, 1.0, 2.4, 3.2, 2.7, 2.4, 2.25, 4.5, 0.0, 3.8, 0.0, 0.0, 0.0, 3.3, 3.0, 0.0, -! 6.0, 5.3, 1.0, 2.9, 4.8, 1.0, 2.2, 2.9, 2.4, 2.1, 1.6, 4.1, 0.0, 3.7, 0.0, 0.0, 0.0, 2.8, 3.0, 0.0, -! 5.5, 4.7, 0.5, 2.6, 4.1, 1.0, 1.6, 2.3, 1.8, 1.7, 1.1, 3.2, 0.0, 3.2, 0.0, 0.0, 0.0, 1.4, 1.4, 0.0, -! 5.2, 4.0, 0.2, 2.2, 3.4, 1.0, 1.0, 1.5, 1.4, 1.3, 0.65, 2.3, 0.0, 2.7, 0.0, 0.0, 0.0, 0.5, 0.7, 0.0, -! 5.1, 3.2, 0.0, 1.9, 3.0, 1.0, 0.9, 0.7, 0.7, 0.8, 0.4, 1.7, 0.0, 2.4, 0.0, 0.0, 0.0, 0.8, 0.7, 0.0, + LAI_JAN = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + LAI_FEB = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + LAI_MAR = 4.0, 4.5, 0.0, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, + LAI_APR = 4.0, 4.5, 0.6, 1.2, 2.6, 0.9, 0.6, 1.0, 0.8, 0.7, 0.5, 0.0, 0.0, 0.4, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, + LAI_MAY = 4.0, 4.5, 1.2, 3.0, 3.5, 2.2, 1.5, 2.4, 1.8, 1.2, 1.5, 1.0, 0.0, 1.1, 0.0, 0.0, 0.0, 1.7, 1.2, 0.0, + LAI_JUN = 4.0, 4.5, 2.0, 4.7, 4.3, 3.5, 2.3, 4.1, 3.6, 3.0, 2.9, 2.0, 0.0, 2.5, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, + LAI_JUL = 4.0, 4.5, 2.6, 4.5, 4.3, 3.5, 2.3, 4.1, 3.8, 3.5, 3.5, 3.0, 0.0, 3.2, 0.0, 0.0, 0.0, 2.1, 1.8, 0.0, + LAI_AUG = 4.0, 4.5, 1.7, 3.4, 3.7, 2.5, 1.7, 2.7, 2.1, 1.5, 2.7, 3.0, 0.0, 2.2, 0.0, 0.0, 0.0, 1.8, 1.3, 0.0, + LAI_SEP = 4.0, 4.5, 1.0, 1.2, 2.6, 0.9, 0.6, 1.0, 0.9, 0.7, 1.2, 1.5, 0.0, 1.1, 0.0, 0.0, 0.0, 1.3, 0.8, 0.0, + LAI_OCT = 4.0, 4.5, 0.5, 0.3, 2.2, 0.3, 0.2, 0.4, 0.5, 0.6, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.1, 0.7, 0.0, + LAI_NOV = 4.0, 4.5, 0.2, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.5, 0.3, 0.0, 0.0, 0.3, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, + LAI_DEC = 4.0, 4.5, 0.0, 0.0, 2.0, 0.0, 0.0, 0.2, 0.3, 0.4, 0.2, 0.0, 0.0, 0.2, 0.0, 0.0, 0.0, 1.0, 0.6, 0.0, SLAREA=0.0090, 0.0200, 0.0200, 0.0258, 0.0223, 0.0227, 0.0188, 0.0227, 0.0236, 0.0060, 0.0295, 0.0200, 0.0228, 0.0223, 0.02, 0.02, 0.0422, 0.02, 0.02, 0.02, -! Five types, one row for each type. - EPS = 0.46, 0.00, 0.00, 46.86, 30.98, 21.62, 0.11, 21.62, 22.80, 0.02, 0.815, 0.00, 41.87, 0.04, 0.0, 0.0, 2.31, 0.0, 0.0, 0.0, - 3.34, 0.00, 0.00, 0.38, 0.96, 0.92, 0.22, 0.92, 0.59, 0.05, 0.535, 0.00, 0.98, 0.09, 0.0, 0.0, 1.47, 0.0, 0.0, 0.0, - 1.85, 0.00, 0.00, 1.84, 1.84, 1.73, 1.26, 1.73, 1.37, 0.03, 0.605, 0.00, 1.82, 0.05, 0.0, 0.0, 1.70, 0.0, 0.0, 0.0, - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, - 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, +! Five types, one row for each type (BVOC currently not active). + EPS1 = 0.46, 0.00, 0.00, 46.86, 30.98, 21.62, 0.11, 21.62, 22.80, 0.02, 0.815, 0.00, 41.87, 0.04, 0.0, 0.0, 2.31, 0.0, 0.0, 0.0, + EPS2 = 3.34, 0.00, 0.00, 0.38, 0.96, 0.92, 0.22, 0.92, 0.59, 0.05, 0.535, 0.00, 0.98, 0.09, 0.0, 0.0, 1.47, 0.0, 0.0, 0.0, + EPS3 = 1.85, 0.00, 0.00, 1.84, 1.84, 1.73, 1.26, 1.73, 1.37, 0.03, 0.605, 0.00, 1.82, 0.05, 0.0, 0.0, 1.70, 0.0, 0.0, 0.0, + EPS4 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + EPS5 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, + +/ + +&noah_mp_rad_parameters + !------------------------------------------------------------------------------ + ! 1 2 3 4 5 6 7 8 soil color index for soil albedo + !------------------------------------------------------------------------------ + ALBSAT_VIS = 0.15, 0.11, 0.10, 0.09, 0.08, 0.07, 0.06, 0.05 ! saturated soil albedos + ALBSAT_NIR = 0.30, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10 ! saturated soil albedos + ALBDRY_VIS = 0.27, 0.22, 0.20, 0.18, 0.16, 0.14, 0.12, 0.10 ! dry soil albedos + ALBDRY_NIR = 0.54, 0.44, 0.40, 0.36, 0.32, 0.28, 0.24, 0.20 ! dry soil albedos + ALBICE = 0.80, 0.55 ! albedo land ice: 1=vis, 2=nir + ALBLAK = 0.60, 0.40 ! albedo frozen lakes: 1=vis, 2=nir + OMEGAS = 0.8 , 0.4 ! two-stream parameter omega for snow + BETADS = 0.5 ! two-stream parameter betad for snow + BETAIS = 0.5 ! two-stream parameter betaI for snow + EG = 0.97, 0.98 ! emissivity soil surface 1-soil;2-lake + / diff --git a/wrfv2_fire/run/README.namelist b/wrfv2_fire/run/README.namelist index d7125532..49dbed83 100644 --- a/wrfv2_fire/run/README.namelist +++ b/wrfv2_fire/run/README.namelist @@ -82,6 +82,9 @@ information on NMM specific settings (http://www.dtcenter.org/wrf-nmm/users) adjust_output_times = .false., ; adjust output times to the nearest hour override_restart_timers = .false., ; whether to change the alarms from what is previously set write_hist_at_0h_rst = .false., ; whether to output history file at the start of restart run + output_ready_flag = .true., ; asks the model to write-out an empty file with the name 'wrfoutReady_d_. + Useful in production runs so that post-processing code can check on the + completeness of this file To choose between SI and WPS input to real for EM core: auxinput1_inname = "met_em.d." ; Input to real from WPS (default since 3.0) @@ -116,6 +119,7 @@ For additional regional climate surface fields io_form_auxhist3 = 2 ; netcdf auxhist3_interval = 1440 ; minutes between outputs (1440 gives daily max/min) frames_per_auxhist3 = 1 ; output times per file + Note: do restart only at multiple of auxhist3_intervals For observation nudging: auxinput11_interval = 10 ; interval in minutes for observation data. It should be @@ -223,6 +227,18 @@ Namelist variables specifically for the WPS input for real: ; through this many eta levels ; 0 = perform traditional trapping interpolation ; n = first n eta levels directly use surface level + maxw_horiz_pres_diff = 5000 ; Pressure threshold (Pa). For using the level of max winds, when the + ; pressure differnce between neighboring values exceeds this maximum, + ; the variable is NOT inserted into the column for vertical interpolation. + ; ARW real only. + trop_horiz_pres_diff = 5000 ; Pressure threshold (Pa). For using the tropopause level, when the + ; pressure differnce between neighboring values exceeds this maximum, + ; the variable is NOT inserted into the column for vertical interpolation. + ; ARW real only. + maxw_above_this_level = 30000 ; Minimum height (actually it is pressure in Pa) to allow using the + ; level of max wind information in real. With a value of 300 hPa, then + ; a max wind value at 500 hPa will be ignored. + ; ARW real only. sfcp_to_sfcp = .false. ; Optional method to compute model's surface pressure when incoming ; data only has surface pressure and terrain, but not SLP smooth_cg_topo = .false. ; Smooth the outer rows and columns of domain 1's topography w.r.t. @@ -270,6 +286,37 @@ a known first several layers, then generates equi-height spaced levels up to the 0.150, 0.127, 0.106, 0.088, 0.070, 0.055, 0.040, 0.026, 0.013, 0.000 + = 0,2, ; this allows vertical nesting in the nest domain + Note that with vertical nesting one can only use RRTM and RRTMG radiation physics + + An example to define vertical nested levels (in program real): + + e_vert = 35, 45, + eta_levels(1:35) = 1., 0.993, 0.983, 0.97, 0.954, 0.934, 0.909, 0.88, 0.8406663, 0.8013327, + 0.761999, 0.7226653, 0.6525755, 0.5877361, 0.5278192, 0.472514, + 0.4215262, 0.3745775, 0.3314044, 0.2917579, 0.2554026, 0.2221162, + 0.1916888, 0.1639222, 0.1386297, 0.1156351, 0.09525016, 0.07733481, + 0.06158983, 0.04775231, 0.03559115, 0.02490328, 0.0155102, 0.007255059, 0. + eta_levels(36:81) = 1.0000, 0.9946, 0.9875, 0.9789, 0.9685, 0.9562, 0.9413, 0.9238, 0.9037, 0.8813, 0.8514, + 0.8210, 0.7906, 0.7602, 0.7298, 0.6812, 0.6290, 0.5796, 0.5333, 0.4901, 0.4493, 0.4109, + 0.3746, 0.3412, 0.3098, 0.2802, 0.2524, 0.2267, 0.2028, 0.1803, 0.1593, 0.1398, 0.1219, + 0.1054, 0.0904, 0.0766, 0.0645, 0.0534, 0.0433, 0.0341, 0.0259, 0.0185, 0.0118, 0.0056, 0. + +Horizontal interpolation options, coarse grid to fine grid. The default is to use +the Smolarkiewicz "SINT" method. However, this is known to break with the +implementation inside of WRF for large refinement ratios (such as 15:1). For those +extreme (and quite rare occurrences), other schemes are available. For options +1, 3, 4, and 12, the FG lateral boundaries use the same horizontal scheme for the +lateral BC computations. + interp_method_type = 1 ! bi-linear interpolation + = 2 ! SINT, default + = 3 ! nearest neighbor - only to be used for + ! testing purposes + = 4 ! overlapping quadratic + =12 ! again for testing, uses SINT horizontal + ! interpolation, and same scheme for + ! computation of FG lateral boundaries + Variables specifically for the 3d ocean initialization with a single profile. Set the ocean physics option to #2. Specify a number of levels. For each of those levels, provide a depth (m) below the surface. At each depth provide a temperature (K) and @@ -416,6 +463,8 @@ Namelist variables for controlling the adaptive time step option: = 16, WDM 6-class scheme = 17, NSSL 2-moment 4-ice scheme (steady background CCN) = 18, NSSL 2-moment 4-ice scheme with predicted CCN (better for idealized than real cases) + ; to set a global CCN value, use + nssl_cccn = 0.7e9 ; CCN for NSSL scheme (18). Also sets same value to ccn_conc for mp_physics=18 = 19, NSSL 1-moment (7 class: qv,qc,qr,qi,qs,qg,qh; predicts graupel density) = 21, NSSL 1-moment, (6-class), very similar to Gilmore et al. 2004 Can set intercepts and particle densities in physics namelist, e.g., nssl_cnor @@ -461,6 +510,10 @@ Namelist variables for controlling the adaptive time step option: (only used in very extreme situation) default value = 0 gsfcgce_hail is ignored if gsfcgce_2ice is set to 1 or 2. + hail_opt = 0 ; hail switch for WSM6, WDM6 and Morrison schemes: 0 - off, 1 - on (new in 3.6.1) + progn = 0 ; switch to use mix-activate scheme (Only for Morrison, WDM6, WDM5, + and NSSL_2MOMCCN/NSSL_2MOM + ccn_conc = 1.E8 ; CCN concentration, used by WDM schemes (new in 3.6.1) no_mp_heating = 0 ; normal = 1 ; turn off latent heating from a microphysics scheme @@ -474,6 +527,7 @@ Namelist variables for controlling the adaptive time step option: also requires levsiz, paerlev, cam_abs_dim1/2 (see below) = 4, rrtmg scheme (Default values for GHG in V3.5: co2vmr=379.e-6, n2ovmr=319.e-9, ch4vmr=1774.e-9) + = 24, fast rrtmg scheme for GPU and MIC (since 3.7) = 5, Goddard longwave scheme = 7, FLG (UCLA) scheme = 31, Earth Held-Suarez forcing @@ -487,13 +541,15 @@ Namelist variables for controlling the adaptive time step option: = 3, cam scheme also must set levsiz, paerlev, cam_abs_dim1/2 (see below) = 4, rrtmg scheme + = 24, fast rrtmg scheme for GPU and MIC (since 3.7) = 5, Goddard shortwave scheme = 7, FLG (UCLA) scheme = 99, GFDL (Eta) longwave (semi-supported) also must use co2tf = 1 for ARW radt (max_dom) = 30, ; minutes between radiation physics calls - recommend 1 min per km of dx (e.g. 10 for 10 km) + recommend 1 min per km of dx (e.g. 10 for 10 km); + use the same value for all nests. nrads (max_dom) = FOR NMM: number of fundamental timesteps between calls to shortwave radiation; the value @@ -600,8 +656,8 @@ Namelist variables for controlling the adaptive time step option: = 9, UW boundary layer scheme from CAM5 (CESM 1_0_1) = 10, TEMF (Total Energy Mass Flux) scheme (ARW only) sf_sfclay_physics=10 + = 11, Shin-Hong 'scale-aware' PBL scheme = 12, Grenier-Bretherton-McCaa scheme (ARW only) - = 94, Quasi-Normal Scale Elimination PBL = 99, MRF scheme bldt (max_dom) = 0, ; minutes between boundary-layer physics calls @@ -617,6 +673,7 @@ Namelist variables for controlling the adaptive time step option: the value is set in Registry.NMM but is overridden by namelist value; bldt will be computed from this. + ysu_topdown_pblmix = 0,; whether to turn on top-down, radiation-driven mixing (1=yes) mfshconv (max_dom) = 1,; whether to turn on new day-time EDMF QNSE (0=no) topo_wind (max_dom) = 0, turn off, = 1, turn on topographic surface wind correction from Jimenez @@ -626,10 +683,13 @@ Namelist variables for controlling the adaptive time step option: bl_mynn_tkeadvect (max_dom) = .false., default off; = .true. do MYNN tke advection scalar_pblmix (max_dom) = 1 ; mix scalar fields consistent with PBL option (exch_h) tracer_pblmix (max_dom) = 1 ; mix tracer fields consistent with PBL option (exch_h) + shinhong_tke_diag (max_dom) = 0 ; diagnostic TKE and mixing length from Shin-Hong PBL sf_surface_mosaic option to mosaic landuse categories for Noah LSM = 0 ; default; use dominant category only = 1 ; use mosaic landuse categories mosaic_cat = 3 ; number of mosaic landuse categories in a grid cell + mosaic_lu = 1 ; use mosaic landuse categories in RUC; default is 0 + mosaic_soil = 1 ; use mosaic soil categories in RUC; default is 0 cu_physics (max_dom) cumulus option = 0, no cumulus @@ -640,7 +700,9 @@ Namelist variables for controlling the adaptive time step option: = 5, Grell 3D ensemble scheme = 6, Modifed Tiedtke scheme (ARW only) = 7, Zhang-McFarlane scheme from CAM5 (CESM 1_0_1) + = 11, Multi-scale Kain-Fritsch scheme = 14, New GFS simplified Arakawa-Schubert scheme from YSU (ARW only) + = 16, A newer Tiedtke scheme = 84, New GFS simplified Arakawa-Schubert scheme (HWRF) = 93, Grell-Devenyi ensemble scheme = 99, previous Kain-Fritsch scheme @@ -653,20 +715,21 @@ Namelist variables for controlling the adaptive time step option: ishallow = 1, Shallow convection used with Grell 3D ensemble schemes (cu_physics = 3 or 5) clos_choice = 0, closure choice (place holder only) - cu_diag = 0, additional t-averaged stuff for cu physics (cu_phys = 3, 5 and 93 only) convtrans_avglen_m = 30, averaging time for variables used by convective transport (call cu_phys options) and radiation routines (only cu_phys=3,5 and 93) (minutes) - + cu_rad_feedback (max_dom) = .false. ; sub-grid cloud effect to the optical depth in radiation + currently it works only for GF, G3, GD and KF scheme + One also needs to set cu_diag = 1 for GF, G3 and GD schemes cudt = 0, ; minutes between cumulus physics calls - kfeta_trigger KF trigger option (cu_physics=1 only): = 1, default option = 2, moisture-advection based trigger (Ma and Tan [2009]) - ARW only = 3, RH-dependent additional perturbation to option 1 (JMA) - cugd_avedx ; number of grid boxes over which subsidence is spread. = 1, default, for large grid distances = 3, for small grid distances (DX < 5 km) + nsas_dx_factor = 0, default option + = 1, NSAS grid-distance dependent option (new in 3.6) ncnvc (max_dom) = FOR NMM: number of fundamental timesteps between calls to convection; the value is set in Registry.NMM @@ -689,6 +752,8 @@ Namelist variables for controlling the adaptive time step option: and tke_heat_flux in vertical diffusion 2 = use drag from sf_sfclay_physics and heat flux from tke_heat_flux with bl_pbl_physics=0 + ideal_xland = 1, ; sets XLAND (1=land,2=water) for ideal cases with no input land-use + run-time switch for wrf.exe physics_init (default 1 as before) ifsnow = 0, ; snow-cover effects (only works for sf_surface_physics = 1) 1 = with snow-cover effect @@ -699,10 +764,10 @@ Namelist variables for controlling the adaptive time step option: 1 = with cloud effect, and use cloud fraction option 1 (Xu-Randall method) 0 = without cloud effect - 2 = with cloud effect, and use cloud fraction option 2 - cu_rad_feedback (max_dom) = .false. ; sub-grid cloud effect to the optical depth in radiation - currently it works only for GF, G3, GD and KF scheme - One also needs to set cu_diag = 1 for GF, G3 and GD schemes + 2 = with cloud effect, and use cloud fraction option 2 (0/1 based + on threshold + 3 = with cloud effect, and use cloud fraction option 3, based on + Sundqvist et al. (1989) (since 3.7) swrad_scat = 1. ; scattering tuning parameter (default 1. is 1.e-5 m2/kg) (works for ra_sw_physics = 1 option only) surface_input_source = 1, ; where landuse and soil category data come from: @@ -828,6 +893,7 @@ Namelist variables for lake module: do_radar_ref = 1, and mp_physics = 2,4,6,7,8,10,14, or 16) = 2 ; PR92 based on 20 dBZ top, redistributes flashes within dBZ > 20 (for convection resolved runs; must also use do_radar_ref = 1, and mp_physics = 2,4,6,7,8,10,14, or 16) + = 3 ; Predicting the potential for lightning activity (based on Yair et al, 2010, J. Geophys. Res., 115, D04205, doi:10.1029/2008JD010868) = 11 ; PR92 based on level of neutral buoyancy from convective parameterization (for scales where a CPS is used, intended for use at 10 < dx < 50 km; must also use cu_physics = 5 or 93) lightning_dt (max_dom) = 0. ; time interval (seconds) for calling lightning parameterization. Default uses model time step @@ -858,6 +924,23 @@ Options for wind turbine drag parameterization: ; 1 = The coordinate of the turbines are defined in terms of grid points +Stochastic parameterization schemes: + +&stoch + skebs = 1 ; stochastic kinetic-energy backscatter scheme, 1: on + tot_backscat_psi = 1.0E-05 ; total backscattered dissipation for streamfunction; + ; determines amplitude of streamfunction perturbations + tot_backscat_t = 1.0E-06 ; total backscattered dissipation for potential temperature + ztau_psi = 10800.0 ; decorrelation time scale of noise for streamfunction perturbations + rand_perturb = 1 ; generate array with random perturbations for user determined use, 1: on + gridpt_stddev_rand_pert = 0.03 ; standard deviation of random perturbations at each gridpoint + ; determines amplitude of random perturbations + stddev_cutoff_rand_pert = 3.0 ; cutoff tails of pdf above this threshold standard deviation + lengthscale_rand_pert = 500000.0 ; correlation length scale in meters + timescale_rand_pert = 21600.0 ; decorrelation time scale in s + nens = 1 ; creates different seed for random number streams in either stochastic scheme + ; must be different for each member in ensemble forecasts + Options for stochastic kinetic-energy backscatter scheme: stoch_force_opt (max_dom) = 0, : No stochastic parameterization @@ -884,20 +967,27 @@ Options for stochastic kinetic-energy backscatter scheme: lmaxforc = 1000000 ; max. forcing wavenumber in lat. for psi perturb kmaxforct = 1000000 ; max. forcing wavenumber in lon. for theta perturb lmaxforct = 1000000 ; max. forcing wavenumber in lat. for theta perturb + perturb_chem_bdy ; Options for perturbing lateral boundaries of chemical tracers: + 0 = off; 1 = on with RAND_PERTURB pattern + perturb_bdy = 0 ; No boundary perturbations + 1 ; Use SKEBS pattern for boundary perturbations + 2 ; Use other user-provided pattern for boundary perturbations Options for use with the Noah-MP Land Surface Model: &noah_mp dveg = 4, ; Noah-MP Dynamic Vegetation option: ; 1 = Off (LAI from table; FVEG = shdfac) - ; 2 = On + ; 2 = On (LAI predicted; FVEG calculated) ; 3 = Off (LAI from table; FVEG calculated) ; 4 = Off (LAI from table; FVEG = maximum veg. fraction) + ; 5 = On (LAI predicted; FVEG = maximum veg. fraction) opt_crs = 1, ; Noah-MP Stomatal Resistance option: ; 1 = Ball-Berry; 2 = Jarvis opt_sfc = 1 ; Noah-MP surface layer drag coefficient calculation ; 1 = Monin-Obukhov; 2 = original Noah (Chen97); ; 3 = MYJ consistent; 4 = YSU consistent. + ; options 3 and 4 removed in 3.7 opt_btr = 1, ; Noah-MP Soil Moisture Factor for Stomatal Resistance ; 1 = Noah; 2 = CLM; 3 = SSiB opt_run = 1, ; Noah-MP Runoff and Groundwater option @@ -920,12 +1010,14 @@ Options for use with the Noah-MP Land Surface Model: ; 1 = Jordan (1991) ; 2 = BATS: Snow when SFCTMP < TFRZ+2.2 ; 3 = Snow when SFCTMP < TFRZ + ; 4 = Use WRF precipitation partitioning opt_tbot = 2, ; Noah-MP Soil Temperature Lower Boundary Condition ; 1 = Zero heat flux ; 2 = TBOT at 8 m from input file opt_stc = 1, ; Noah-MP Snow/Soil temperature time scheme ; 1 = semi-implicit ; 2 = full-implicit + ; 3 = semi-implicit where Ts uses snow cover fraction / &fdda @@ -1101,6 +1193,15 @@ The following are for observation nudging: not for real-data cases) 3 = with w-Rayleigh damping (dampcoef inverse time scale [1/s] e.g. .05; for real-data cases) + use_theta_m = 0 ; 1: use theta_m=theta(1+1.61Qv) + 0: use dry theta in dynamics + use_q_diabatic = 0 ; whether to include QV and QC tendencies in advection (new in 3.7) + 0 = default, old behavior + 1 = include QV and QC tendencies - this helps to produce correct solution + in an idealized 'moist benchmark' test case (Bryan, 2014). + In real data testing, time step needs to be reduce to maintain stable solution + c_s = 0.25 ; Smagorinsky coeff + c_k = 0.15 ; TKE coeff diff_6th_opt = 0, ; 6th-order numerical diffusion 0 = no 6th-order diffusion (default) 1 = 6th-order numerical diffusion (not recommended) @@ -1115,7 +1216,11 @@ The following are for observation nudging: base_temp = 290., ; real-data, em ONLY, base sea-level temp (K) base_pres = 10^5 ; real-data, em ONLY, base sea-level pres (Pa), DO NOT CHANGE base_lapse = 50., ; real-data, em ONLY, lapse rate (K), DO NOT CHANGE - iso_temp = 0., ; real-data, em ONLY, reference temp in stratosphere + iso_temp = 200., ; real-data, em ONLY, reference temp in stratosphere, US Standard atmosphere 216.5 K + base_pres_strat = 5500. ; real-data, em ONLY, base state pressure (Pa) at bottom of the stratosphere, + US Standard atmosphere 55 hPa + base_lapse_strat = 0. ; real-data, em ONLY, base state lapse rate ( dT / d(lnP) ) in stratosphere, + approx to US Standard atmosphere -12 K use_baseparam_fr_nml = .f., ; whether to use base state parameters from the namelist use_input_w = .f., ; whether to use vertical velocity from input file khdif (max_dom) = 0, ; horizontal diffusion constant (m^2/s) @@ -1163,7 +1268,10 @@ The following are for observation nudging: do_curvature (max_dom) = .true., ; whether to do curvature calculations (idealized) (inactive) do_gradp (max_dom) = .true., ; whether to do horizontal pressure gradient calculations (idealized) (inactive) fft_filter_lat = 45. ; the latitude above which the polar filter is turned on - + coupled_filtering = .true. ; T/F mu coupled scalar arrays are run through the polar filters + pos_def = .false. ; T/F remove negative values of scalar arrays by setting minimum value to zero + swap_pole_with_next_j = .false. ; T/F replace the entire j=1 (jds-1) with the values from j=2 (jds-2) + actual_distance_average = .false. ; T/F average the field at each i location in the j-loop with a number of grid points based on a map-factor ratio gwd_opt = 0 ; for running without gravity wave drag = 1 ; for running the WRF-ARW with its gravity wave drag = 2 ; for running the WRF-NMM with its gravity wave drag @@ -1183,6 +1291,8 @@ The following are for observation nudging: spec_exp = 0. ; exponential multiplier for relaxation zone ramp for specified=.t. (0.=linear ramp default, e.g. 0.33=~3*dx exp decay factor) constant_bc = .false. ; constant boundary condition used with DFI + spec_bdy_final_mu = 0, ; whether to call spec_bdy_final for mu (since 3.7): + = 0, no call; = 1: call (this may cause different restart results) periodic_x (max_dom) = .false., ; periodic boundary conditions in x direction symmetric_xs (max_dom) = .false., ; symmetric boundary conditions at x start (west) @@ -1197,9 +1307,6 @@ The following are for observation nudging: nested (max_dom) = .false., ; nested boundary conditions (must be used for nests) polar = .false., ; polar boundary condition (v=0 at polarward-most v-point) - perturb_bdy = 0 ; No boundary perturbations - 1 ; Use SKEBS pattern for boundary perturbations - 2 ; Use other user-provided pattern for boundary perturbations have_bcs_moist = .false., ; model run after ndown only: do not use microphysics variables in bdy file = .true. , ; use microphysics variables in bdy file have_bcs_scalar = .false., ; model run after ndown only: do not use scalar variables in bdy file @@ -1270,7 +1377,9 @@ afwa_severe_opt (max_dom) = 0, ; Severe Wx option, 1: on afwa_icing_opt (max_dom) = 0, ; Icing option, 1: on afwa_vis_opt (max_dom) = 0, ; Visibility option, 1: on afwa_cloud_opt (max_dom) = 0, ; Cloud option, 1: on +afwa_therm_opt (max_dom) = 0, ; Thermal indices option, 1: on +afwa_turb_opt (max_dom) = 0, ; Turbulence option, 1: on +afwa_buoy_opt (max_dom) = 0, ; Buoyancy option, 1: on +afwa_hailcast_opt (max_dom) = 0, ; Hailcast option, 1: on afwa_ptype_ccn_tmp = 264.15, ; CCN temperature for precipitation type calculation afwa_ptype_tot_melt = 50, ; Total melting energy for precipitation type calculation -afwa_ccn_conc = 1.0E8, ; CCN concentration -afwa_hail_opt = 0, ; Hail/Graupel switch, 1:hail, 0:graupel diff --git a/wrfv2_fire/run/SOILPARM.TBL b/wrfv2_fire/run/SOILPARM.TBL index 5e11e462..4d18a3cc 100644 --- a/wrfv2_fire/run/SOILPARM.TBL +++ b/wrfv2_fire/run/SOILPARM.TBL @@ -23,23 +23,23 @@ STAS Soil Parameters STAS-RUC 19,1 'BB DRYSMC HC MAXSMC REFSMC SATPSI SATDK SATDW WLTSMC QTZ ' -1, 4.05, 0.045, 1.47, 0.395, 0.174, 0.121, 1.76E-4, 0.608E-6, 0.068, 0.92, 'SAND' -2, 4.38, 0.057, 1.41, 0.410, 0.179, 0.090, 1.56E-4, 0.514E-5, 0.075, 0.82, 'LOAMY SAND' -3, 4.90, 0.065, 1.34, 0.435, 0.249, 0.218, 3.47E-5, 0.805E-5, 0.114, 0.60, 'SANDY LOAM' -4, 5.30, 0.067, 1.27, 0.485, 0.369, 0.786, 7.20E-6, 0.239E-4, 0.179, 0.25, 'SILT LOAM' -5, 5.30, 0.034, 1.27, 0.485, 0.369, 0.786, 7.20E-6, 0.239E-4, 0.179, 0.10, 'SILT' -6, 5.39, 0.078, 1.21, 0.451, 0.314, 0.478, 6.95E-6, 0.143E-4, 0.155, 0.40, 'LOAM' -7, 7.12, 0.100, 1.18, 0.420, 0.299, 0.299, 6.30E-6, 0.990E-5, 0.175, 0.60, 'SANDY CLAY LOAM' -8, 7.75, 0.089, 1.32, 0.477, 0.357, 0.356, 1.70E-6, 0.237E-4, 0.218, 0.10, 'SILTY CLAY LOAM' -9, 8.52, 0.095, 1.23, 0.476, 0.391, 0.630, 2.45E-6, 0.113E-4, 0.250, 0.35, 'CLAY LOAM' -10, 10.40, 0.100, 1.18, 0.426, 0.316, 0.153, 2.17E-6, 0.187E-4, 0.219, 0.52, 'SANDY CLAY' -11, 10.40, 0.070, 1.15, 0.492, 0.409, 0.490, 1.03E-6, 0.964E-5, 0.283, 0.10, 'SILTY CLAY' -12, 11.40, 0.068, 1.09, 0.482, 0.400, 0.405, 1.28E-6, 0.112E-4, 0.286, 0.25, 'CLAY' -13, 5.39, 0.078, 1.21, 0.451, 0.314, 0.478, 6.95E-6, 0.143E-4, 0.155, 0.05, 'ORGANIC MATERIAL' +1, 4.05, 0.002, 1.47, 0.395, 0.174, 0.121, 1.76E-4, 0.608E-6, 0.033, 0.92, 'SAND' +2, 4.38, 0.035, 1.41, 0.410, 0.179, 0.090, 1.56E-4, 0.514E-5, 0.055, 0.82, 'LOAMY SAND' +3, 4.90, 0.041, 1.34, 0.435, 0.249, 0.218, 3.47E-5, 0.805E-5, 0.095, 0.60, 'SANDY LOAM' +4, 5.30, 0.034, 1.27, 0.485, 0.369, 0.786, 7.20E-6, 0.239E-4, 0.143, 0.25, 'SILT LOAM' +5, 5.30, 0.034, 1.27, 0.485, 0.369, 0.786, 7.20E-6, 0.239E-4, 0.143, 0.10, 'SILT' +6, 5.39, 0.050, 1.21, 0.451, 0.314, 0.478, 6.95E-6, 0.143E-4, 0.137, 0.40, 'LOAM' +7, 7.12, 0.068, 1.18, 0.420, 0.299, 0.299, 6.30E-6, 0.990E-5, 0.148, 0.60, 'SANDY CLAY LOAM' +8, 7.75, 0.060, 1.32, 0.477, 0.357, 0.356, 1.70E-6, 0.237E-4, 0.208, 0.10, 'SILTY CLAY LOAM' +9, 8.52, 0.085, 1.23, 0.476, 0.391, 0.630, 2.45E-6, 0.113E-4, 0.230, 0.35, 'CLAY LOAM' +10, 10.40, 0.100, 1.18, 0.426, 0.316, 0.153, 2.17E-6, 0.187E-4, 0.210, 0.52, 'SANDY CLAY' +11, 10.40, 0.070, 1.15, 0.492, 0.409, 0.490, 1.03E-6, 0.964E-5, 0.250, 0.10, 'SILTY CLAY' +12, 11.40, 0.068, 1.09, 0.482, 0.400, 0.405, 1.28E-6, 0.112E-4, 0.268, 0.25, 'CLAY' +13, 5.39, 0.027, 1.21, 0.451, 0.314, 0.478, 6.95E-6, 0.143E-4, 0.117, 0.05, 'ORGANIC MATERIAL' 14, 0.0, 0.0, 4.18, 1.0, 1.0, 0.0, 0.0, 0.0, 0.0, 0.00, 'WATER' 15, 4.05, 0.004, 2.03, 0.200, 0.10 , 0.121, 1.41E-4, 0.136E-3, 0.006, 0.60, 'BEDROCK' 16, 4.90, 0.065, 2.10, 0.435, 0.249, 0.218, 3.47E-5, 0.514E-5, 0.114, 0.05, 'OTHER(land-ice)' 17, 11.40, 0.030, 1.41, 0.468, 0.454, 0.468, 9.74E-7, 0.112E-4, 0.030, 0.60, 'PLAYA' -18, 4.05, 0.006, 1.41, 0.200, 0.17, 0.069, 1.41E-4, 0.136E-3, 0.060, 0.52, 'LAVA' +18, 4.05, 0.006, 1.41, 0.200, 0.17, 0.069, 1.41E-4, 0.136E-3, 0.006, 0.52, 'LAVA' 19, 4.05, 0.01, 1.47, 0.339, 0.236, 0.069, 1.76E-4, 0.608E-6, 0.060, 0.92, 'WHITE SAND' diff --git a/wrfv2_fire/run/URBPARM.TBL b/wrfv2_fire/run/URBPARM.TBL index f9d179e4..5c0a3d56 100644 --- a/wrfv2_fire/run/URBPARM.TBL +++ b/wrfv2_fire/run/URBPARM.TBL @@ -49,6 +49,14 @@ ROAD_WIDTH: 10.0, 9.4, 8.3 AH: 90.0, 50.0, 20.0 + +# +# ALH: Anthropogenic latent heat [ W m{-2} ] +# (sf_urban_physics=1) +# + +ALH: 40.0, 25.0, 20.0 + # # FRC_URB: Fraction of the urban landscape which does not have natural # vegetation. [ Fraction ] @@ -410,6 +418,88 @@ AHOPTION: 0 # held constant until the next hour. # (sf_urban_physics=1) # -# AHDIUPRF: 0.16 0.13 0.08 0.07 0.08 0.26 0.67 0.99 0.89 0.79 0.74 0.73 0.75 0.76 0.82 0.90 1.00 0.95 0.68 0.61 0.53 0.35 0.21 0.18 + +# +# ALHOPTION [ 0: No anthropogenic latent heat, 1: Anthropogenic heating will be added to latent heat flux term ] +# (sf_urban_physics=1) +# + +ALHOPTION: 0 + +# +# Anthropogenic latent heat: seasonal coefficient of daily maximum values +# From left to right in order: Spring (MAM), Summer(JJA), Fall(SON), Winter(DJF) +# (sf_urban_physics=1) +# + +ALHSEASON: 0.43 1.00 0.54 0.40 + +# +# Anthropogenic latent heat diurnal profile. +# Multiplication factor applied to seasonal ALH (as defined above) +# Half-hourly values ( 48 of them ), starting at 00:30 hours Local Time. +# (sf_urban_physics=1) +# + +ALHDIUPRF: 0.436 0.421 0.391 0.356 0.311 0.301 0.306 0.295 0.253 0.205 0.177 0.162 0.148 0.121 0.118 0.146 0.210 0.250 0.227 0.162 0.127 0.184 0.306 0.413 0.487 0.559 0.639 0.728 0.754 0.812 0.867 0.969 1.000 0.949 0.840 0.775 0.758 0.756 0.706 0.658 0.637 0.632 0.636 0.633 0.639 0.615 0.553 0.485 + +# Oasis effect +# Multiplication factor applied to potential ET of vegetation in urban areas +# Value should be larger than 1 when actived +# (sf_urban_physics=1) + +OASIS: 1.0 + +# Evaporation scheme for impervious surfaces (for roof, wall, and road) +# [1: Hypothesized evaporation during large rainfall events (Original) +# [2: Water-holding scheme over impervious surface, Yang et al., 2014 +# (sf_urban_physics=1) + +IMP_SCHEME: 1 + +# Porosity of pavement materials on impervious surface +# For calculating latent heat flux over impervious surface +# From left to right in order: roof, wall, road +# (sf_urban_physics=1,IMP_SCHEME=2) +# + +PORIMP: 0.45 0.45 0.45 + +# Maximum water-holding depth of pavement materials on impervious surface [m] +# For calculating latent heat flux over impervious surface +# From left to right in order: roof, wall, road +# (sf_urban_physics=1,IMP_SCHEME=2) +# + +DENGIMP: 0.001 0.0002 0.001 + +# Urban irrigation scheme, for vegetation in urban area and green roof +# [0: No irrigation +# [1: Summertime (May-Sep) irrigation everyday at 9pm +# (sf_urban_physics=1) + +IRI_SCHEME: 0 + +# +# GROPTION [ 0: No green roof, 1: Enable green roof simulation] +# (sf_urban_physics=1) +# + +GROPTION: 0 + +# Surface fraction of green roof over urban rooftop (0-1) +# (sf_urban_physics=1) +# + +FGR: 0.0 + +# +# DZGR: Thickness of each layer on green roof [ m ] +# Green roof structure: 4-layers +# 1: Top Soil layer 2:Soil layer 3: Growing Medium layer +# 4: concrete roof (depth depends on DDZR defined earlier in this table) +# (sf_urban_physics=1) + +DZGR: 0.05 0.10 0.15 0.20 diff --git a/wrfv2_fire/run/VEGPARM.TBL b/wrfv2_fire/run/VEGPARM.TBL index 2d53237a..0e9b5b7b 100644 --- a/wrfv2_fire/run/VEGPARM.TBL +++ b/wrfv2_fire/run/VEGPARM.TBL @@ -40,6 +40,8 @@ BARE 19 NATURAL 5 +CROP +3 Vegetation Parameters MODIFIED_IGBP_MODIS_NOAH 20,1, 'SHDFAC NROOT RS RGL HS SNUP MAXALB LAIMIN LAIMAX EMISSMIN EMISSMAX ALBEDOMIN ALBEDOMAX Z0MIN Z0MAX ZTOPV ZBOTV' @@ -75,10 +77,12 @@ BARE 16 NATURAL 14 +CROP +12 Vegetation Parameters USGS-RUC 28,1, 'ALBEDO Z0 LEMI PC SHDFAC IFOR RS RGL HS SNUP LAI MAXALB' -1, .18, 2.0, .88, .40, .10, 9, 200., 999., 999.0, 0.04, 1.00, 40., 'Urban and Built-Up Land' +1, .18, 1.0, .88, .40, .10, 9, 200., 999., 999.0, 0.04, 1.00, 40., 'Urban and Built-Up Land' 2, .17, .06, .92, .30, .80, 7, 40., 100., 36.25, 0.04, 5.68, 64., 'Dryland Cropland and Pasture' 3, .18, .075, .92, .40, .80, 7, 40., 100., 36.25, 0.04, 5.68, 64., 'Irrigated Cropland and Pasture' 4, .18, .125, .92, .40, .80, 7, 40., 100., 36.25, 0.04, 4.50, 64., 'Mixed Dryland/Irrigated Cropland and Pasture' @@ -118,6 +122,8 @@ BARE 19 NATURAL 5 +CROP +3 Vegetation Parameters MODI-RUC 21,1, 'ALBEDO Z0 LEMI PC SHDFAC IFOR RS RGL HS SNUP LAI MAXALB' @@ -132,9 +138,9 @@ MODI-RUC 9, .20, .15, .920, .40, .50, 5, 70., 65., 54.53, 0.04, 3.66, 50., 'Savannas' 10, .19, .075, .920, .40, .80, 5, 40., 100., 36.35, 0.04, 2.90, 70., 'Grasslands' 11 .14, .30, .950, .40, .60, 4, 70., 65., 55.97 0.015 5.72, 59., 'Permanent wetlands' -12, .18, .15, .935, .40, .80, 7, 40., 100., 36.25, 0.04, 5.68, 66., 'Croplands' -13, .18, 2.0, .880, .40, .10, 9, 200., 999., 999.0, 0.04, 1.00, 46., 'Urban and Built-Up' -14 .16, .14, .920, .40, .80, 7, 40., 100., 36.25, 0.04, 4.29, 68., 'cropland/natural vegetation mosaic' +12, .18, .20, .935, .40, .80, 7, 40., 100., 36.25, 0.04, 5.68, 66., 'Croplands' +13, .18, 1.0, .880, .40, .10, 9, 200., 999., 999.0, 0.04, 1.00, 46., 'Urban and Built-Up' +14 .16, .20, .920, .40, .80, 7, 40., 100., 36.25, 0.04, 4.29, 68., 'cropland/natural vegetation mosaic' 15, .55, .011, .980, .00, .00, 9, 999., 999., 999.0, 0.02, 0.01, 82., 'Snow and Ice' 16, .25, .065, .850, .30, .01, 5, 999., 999., 999.0, 0.02, 0.75, 75., 'Barren or Sparsely Vegetated' 17, .08, .0001, .980, .00, .00, 9, 100., 30., 51.75, 0.01, 0.01, 70., 'Water' @@ -153,7 +159,9 @@ RSMAX_DATA BARE 16 NATURAL -14 +10 +CROP +12 Vegetation Parameters NLCD40 40,1, 'SHDFAC NROOT RS RGL HS SNUP MAXALB LAIMIN LAIMAX EMISSMIN EMISSMAX ALBEDOMIN ALBEDOMAX Z0MIN Z0MAX ZTOPV ZBOTV' @@ -209,3 +217,5 @@ BARE 16 NATURAL 14 +CROP +12 diff --git a/wrfv2_fire/share/dfi.F b/wrfv2_fire/share/dfi.F index 2d86d05a..b3762d5e 100644 --- a/wrfv2_fire/share/dfi.F +++ b/wrfv2_fire/share/dfi.F @@ -40,9 +40,6 @@ SUBROUTINE dfi_accumulate( grid ) grid%dfi_al(:,:,:) = grid%dfi_al(:,:,:) + grid%al(:,:,:) * hn grid%dfi_alt(:,:,:) = grid%dfi_alt(:,:,:) + grid%alt(:,:,:) * hn grid%dfi_pb(:,:,:) = grid%dfi_pb(:,:,:) + grid%pb(:,:,:) * hn - ! neg. check on hydrometeor and scalar variables - grid%moist(:,:,:,:) = max(0.,grid%moist(:,:,:,:)) - grid%dfi_scalar(:,:,:,:) = max(0.,grid%dfi_scalar(:,:,:,:)) ! dfi_savehydmeteors is a namelist parameter, default =0 which means hydrometeor ! and scalar fields will be spinning up in DFI; if dfi_savehydmeteors=1 then ! hydrometeor fields will stay unchanged in DFI, but water vapor mixing ratio @@ -50,6 +47,9 @@ SUBROUTINE dfi_accumulate( grid ) IF ( grid%dfi_savehydmeteors .EQ. 0 ) then grid%dfi_moist(:,:,:,:) = grid%dfi_moist(:,:,:,:) + grid%moist(:,:,:,:) * hn grid%dfi_scalar(:,:,:,:) = grid%dfi_scalar(:,:,:,:) + grid%scalar(:,:,:,:) * hn + grid%dfi_re_cloud(:,:,:) = grid%dfi_re_cloud(:,:,:) + grid%re_cloud(:,:,:) * hn + grid%dfi_re_ice(:,:,:) = grid%dfi_re_ice(:,:,:) + grid%re_ice(:,:,:) * hn + grid%dfi_re_snow(:,:,:) = grid%dfi_re_snow(:,:,:) + grid%re_snow(:,:,:) * hn ELSE grid%dfi_moist(:,:,:,P_QV) = grid%dfi_moist(:,:,:,P_QV) + grid%moist(:,:,:,P_QV) * hn ENDIF @@ -132,6 +132,13 @@ END SUBROUTINE rebalance_driver_dfi grid%dfi_stage = DFI_BCK +#if (EM_CORE == 1) + if(grid%cycling) then +! print *,' Rebalancing is on ' + CALL rebalance_driver_dfi ( grid ) + endif +#endif + ! Negate time step IF ( grid%time_step_dfi .gt. 0 ) THEN CALL nl_set_time_step ( 1, -grid%time_step_dfi ) @@ -145,6 +152,7 @@ END SUBROUTINE rebalance_driver_dfi !tgs 7apr11 - need to call start_domain here to reset bc initialization for negative dt CALL start_domain ( grid , .TRUE. ) !tgs 7apr11 - save arrays should be done after start_domain to get correct grid%p field + ! used in computation of initial RH. CALL dfi_save_arrays ( grid ) ! set physics options to zero @@ -169,7 +177,7 @@ END SUBROUTINE rebalance_driver_dfi CALL nl_set_use_adaptive_time_step( grid%id, .false. ) #endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! set chemistry option to zero CALL nl_set_chem_opt (grid%id, 0) CALL nl_set_aer_ra_feedback (grid%id, 0) @@ -190,9 +198,7 @@ END SUBROUTINE rebalance_driver_dfi CALL nl_set_km_opt( grid%id, 1) CALL nl_set_diff_opt( grid%id, 0) CALL nl_set_moist_adv_dfi_opt( grid%id, grid%moist_adv_dfi_opt) - IF ( grid%moist_adv_opt == 2 ) THEN - CALL nl_set_moist_adv_opt( grid%id, 0) - ENDIF + CALL nl_set_moist_adv_opt( grid%id,grid%moist_adv_dfi_opt) #endif ! If a request to do pressure level diags, then shut it off @@ -245,14 +251,6 @@ END SUBROUTINE rebalance_driver_dfi !tgs need to call start_domain here to reset bc initialization for negative dt CALL start_domain ( grid , .TRUE. ) - !tgs need to call rebalance here to remove imbalances in initial fields - ! when config_flags%cycling=.true. -#if (EM_CORE == 1) - if(grid%cycling) then -! print *,' Rebalancing is on ' - CALL rebalance_driver_dfi ( grid ) - endif -#endif END SUBROUTINE dfi_bck_init @@ -268,6 +266,7 @@ SUBROUTINE dfi_fwd_init ( grid ) TYPE (domain) , POINTER :: grid INTEGER rc CHARACTER*80 mess + INTEGER n_moist,nm,n_scalar,ns INTERFACE SUBROUTINE Setup_Timekeeping(grid) @@ -381,7 +380,7 @@ END SUBROUTINE start_domain #endif -!#ifdef WRF_CHEM +!#if ( WRF_CHEM == 1 ) ! ! reset chem option to normal ! CALL nl_set_chem_opt( grid%id, grid%chem_opt) ! CALL nl_set_aer_ra_feedback (grid%id, grid%aer_ra_feedback) @@ -412,6 +411,22 @@ END SUBROUTINE start_domain !tgs need to call it here to reset bc initialization for positive time_step CALL start_domain ( grid , .TRUE. ) + !tgs After start_domain moist and scalar arrays are fully dimentioned, + !and initial values should be restored here if grid%dfi_savehydmeteors .EQ. 1: + IF ( grid%dfi_savehydmeteors .EQ. 1 ) then + n_moist = num_moist +! print *,'FWD n_moist,PARAM_FIRST_SCALAR,P_QV,P_QC,P_QR,P_QI,P_QS,P_QG', & +! n_moist,PARAM_FIRST_SCALAR,P_QV,P_QC,P_QR,P_QI,P_QS,P_QG +! print *,'FWD num_scalar,P_QNC,P_QNI,P_QNR,P_QNWFA,P_QNIFA',P_QNC,P_QNI,P_QNR,P_QNWFA,P_QNIFA + DO nm=PARAM_FIRST_SCALAR+1,n_moist + grid%moist(:,:,:,nm)=grid%dfi_moist(:,:,:,nm) + ENDDO + n_scalar = num_scalar - 1 + DO ns=PARAM_FIRST_SCALAR,n_scalar + grid%scalar(:,:,:,ns) = grid%dfi_scalar(:,:,:,ns) + ENDDO + ENDIF + END SUBROUTINE dfi_fwd_init SUBROUTINE dfi_fst_init ( grid ) @@ -423,6 +438,7 @@ SUBROUTINE dfi_fst_init ( grid ) TYPE (domain) , POINTER :: grid CHARACTER (LEN=80) :: wrf_error_message + INTEGER n_moist,nm INTERFACE SUBROUTINE Setup_Timekeeping(grid) @@ -477,7 +493,7 @@ END SUBROUTINE start_domain #endif CALL nl_set_feedback( grid%id, grid%feedback ) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! reset chem option to normal CALL nl_set_chem_opt( grid%id, grid%chem_opt) CALL nl_set_aer_ra_feedback (grid%id, grid%aer_ra_feedback) @@ -623,6 +639,7 @@ SUBROUTINE dfi_array_reset( grid ) INTEGER :: its, ite, jts, jte, kts, kte, & i, j, k + INTEGER :: n_moist, nm, n_scalar, ns ! Input data. TYPE(domain) , POINTER :: grid @@ -665,6 +682,9 @@ SUBROUTINE dfi_array_reset( grid ) ! print *,'Normal DFI' grid%moist(:,:,:,:) = max(0.,grid%dfi_moist(:,:,:,:) / grid%hcoeff_tot) grid%scalar(:,:,:,:) = max(0.,grid%dfi_scalar(:,:,:,:) / grid%hcoeff_tot) + grid%re_cloud(:,:,:) = max(0.,grid%dfi_re_cloud(:,:,:) / grid%hcoeff_tot) + grid%re_ice(:,:,:) = max(0.,grid%dfi_re_ice(:,:,:) / grid%hcoeff_tot) + grid%re_snow(:,:,:) = max(0.,grid%dfi_re_snow(:,:,:) / grid%hcoeff_tot) ELSE ! print *,'In dfi_array_reset, QV comp, dfi_save_hydrometeors=1' grid%moist(:,:,:,P_QV) = max(0.,grid%dfi_moist(:,:,:,P_QV) / grid%hcoeff_tot) @@ -730,12 +750,19 @@ SUBROUTINE dfi_array_reset( grid ) IF ( grid%dfi_savehydmeteors .EQ. 1 ) then ! print *,'In dfi_array_reset - restore initial hydrometeors' ! grid%moist(:,:,:,:) = grid%dfi_moist(:,:,:,:) !tgs - grid%moist(:,:,:,P_QC) = grid%dfi_moist(:,:,:,P_QC) !tgs - grid%moist(:,:,:,P_QR) = grid%dfi_moist(:,:,:,P_QR) !tgs - grid%moist(:,:,:,P_QI) = grid%dfi_moist(:,:,:,P_QI) !tgs - grid%moist(:,:,:,P_QS) = grid%dfi_moist(:,:,:,P_QS) !tgs - grid%moist(:,:,:,P_QG) = grid%dfi_moist(:,:,:,P_QG) !tgs - grid%scalar(:,:,:,:) = grid%dfi_scalar(:,:,:,:) + n_moist = num_moist + n_scalar = num_scalar-1 + if (grid%dfi_stage .EQ. DFI_BCK) then +!tgs - backward integration changed only QV + n_moist = P_QV + n_scalar = PARAM_FIRST_SCALAR - 1 + endif + DO nm=PARAM_FIRST_SCALAR+1,n_moist + grid%moist(:,:,:,nm)=grid%dfi_moist(:,:,:,nm) + ENDDO + DO ns=PARAM_FIRST_SCALAR,n_scalar + grid%scalar(:,:,:,ns) = grid%dfi_scalar(:,:,:,ns) + ENDDO if(grid%dfi_stage .EQ. DFI_FWD) then !tgs change QV to restore initial RH field after the diabatic DFI @@ -925,6 +952,9 @@ SUBROUTINE dfi_clear_accumulation( grid ) ! print *,'normal DFI' grid%dfi_moist(:,:,:,:) = 0. grid%dfi_scalar(:,:,:,:) = 0. + grid%dfi_re_cloud(:,:,:) = 0. + grid%dfi_re_ice(:,:,:) = 0. + grid%dfi_re_snow(:,:,:) = 0. ELSE ! print *,'In dfi_clear_accumulation, clear dfi_QV - dfi_savehydmeteors=1' grid%dfi_moist(:,:,:,P_QV) = 0. @@ -966,7 +996,7 @@ SUBROUTINE dfi_save_arrays( grid ) IMPLICIT NONE INTEGER :: its, ite, jts, jte, kts, kte, & - i, j, k + i, j, k, n_moist, nm ! Input data. TYPE(domain) , POINTER :: grid @@ -1014,13 +1044,13 @@ SUBROUTINE dfi_save_arrays( grid ) ! save hydrometeor and scalar fields IF ( grid%dfi_savehydmeteors .EQ. 1 ) then !tgs ! print *,'In dfi_save_arrays - save initial hydrometeors' -!! grid%dfi_moist(:,:,:,:) = grid%moist(:,:,:,:) - grid%dfi_moist(:,:,:,P_QC) = grid%moist(:,:,:,P_QC) - grid%dfi_moist(:,:,:,P_QR) = grid%moist(:,:,:,P_QR) - grid%dfi_moist(:,:,:,P_QI) = grid%moist(:,:,:,P_QI) - grid%dfi_moist(:,:,:,P_QS) = grid%moist(:,:,:,P_QS) - grid%dfi_moist(:,:,:,P_QG) = grid%moist(:,:,:,P_QG) - grid%dfi_scalar(:,:,:,:) = grid%scalar(:,:,:,:) + n_moist = num_moist +! print *,'SAVE n_moist,PARAM_FIRST_SCALAR,P_QV,P_QC,P_QR,P_QI,P_QS,P_QG', & +! n_moist,PARAM_FIRST_SCALAR,P_QV,P_QC,P_QR,P_QI,P_QS,P_QG + DO nm=PARAM_FIRST_SCALAR+1,n_moist + grid%dfi_moist(:,:,:,nm)=max(0.,grid%moist(:,:,:,nm)) + ENDDO + grid%dfi_scalar(:,:,:,:) = max(0.,grid%scalar(:,:,:,:)) ENDIF if(grid%dfi_stage .EQ. DFI_BCK) then @@ -2829,7 +2859,7 @@ END SUBROUTINE Setup_Timekeeping CALL nl_set_constant_bc( grid%id, head_grid%constant_bc) #endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! set chemistry option to zero CALL nl_set_chem_opt (grid%id, 0) CALL nl_set_aer_ra_feedback (grid%id, 0) @@ -2849,9 +2879,7 @@ END SUBROUTINE Setup_Timekeeping CALL nl_set_km_opt( grid%id, grid%km_opt_dfi) CALL nl_set_diff_opt( grid%id, grid%diff_opt_dfi) CALL nl_set_moist_adv_dfi_opt( grid%id, grid%moist_adv_dfi_opt) - IF ( grid%moist_adv_opt == 2 ) THEN - CALL nl_set_moist_adv_opt( grid%id, 0) - ENDIF + CALL nl_set_moist_adv_opt( grid%id,grid%moist_adv_dfi_opt) #endif ! If a request to do pressure level diags, then shut it off @@ -3328,7 +3356,8 @@ SUBROUTINE rebalance_dfi ( grid & ! the half eta levels and the base-profile surface pressure. Compute 1/rho ! from equation of state. The potential temperature is a perturbation from t0. - n_moist = num_moist-1 + n_moist = num_moist +! n_moist = num_moist-1 ! print *,'n_moist,PARAM_FIRST_SCALAR',n_moist,PARAM_FIRST_SCALAR diff --git a/wrfv2_fire/share/input_wrf.F b/wrfv2_fire/share/input_wrf.F index e7a848e8..69cbd783 100644 --- a/wrfv2_fire/share/input_wrf.F +++ b/wrfv2_fire/share/input_wrf.F @@ -10,6 +10,7 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) USE module_date_time USE module_bc_time_utilities USE module_utility + IMPLICIT NONE #include #include @@ -48,7 +49,7 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) CHARACTER*19 new_date CHARACTER*24 base_date CHARACTER*80 fname - CHARACTER*80 dname, memord + CHARACTER*80 dname, memord, sim_type LOGICAL dryrun INTEGER idt INTEGER itmp @@ -92,8 +93,7 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) ! Local variables: are we are using the correct hypsometric option for ARW ideal cases. CHARACTER (LEN=80) :: input_name - LOGICAL :: this_is_an_ideal_run - INTEGER :: loop, hypsometric_opt + INTEGER :: loop, hypsometric_opt, icount CHARACTER (LEN=256) :: a_message @@ -107,7 +107,7 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) ! ! - WRITE(wrf_err_message,*)'input_wrf: begin, fid = ',fid + WRITE(wrf_err_message,*)'input_wrf: begin' CALL wrf_debug( 300 , wrf_err_message ) CALL modify_io_masks ( grid%id ) ! this adjusts the I/O masks according to the users run-time specs, if any @@ -126,7 +126,7 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) CALL wrf_error_fatal( wrf_err_message ) ENDIF - WRITE(wrf_err_message,*)'input_wrf: fid,filestate = ',fid,filestate + WRITE(wrf_err_message,*)'input_wrf: filestate = ',filestate CALL wrf_debug( 300 , wrf_err_message ) dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) @@ -136,25 +136,9 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) check_if_dryrun : IF ( .NOT. dryrun ) THEN -#if (EM_CORE == 1) - IF ( switch .EQ. input_only ) THEN - - ! Make sure for ARW ideal cases that the hypsometric option, the - ! way that we integrate the heigh field, is set to 1. This is the - ! method that is used in all of the "ideal" programs to get the - ! base-state height (phb). - - CALL wrf_get_dom_ti_char ( fid , 'TITLE' , input_name , ierr ) - grid%this_is_an_ideal_run = INDEX(TRIM(input_name) , 'IDEAL' ) .NE. 0 - IF ( grid%this_is_an_ideal_run ) THEN - grid%hypsometric_opt = 1 - config_flags%hypsometric_opt = 1 - DO loop = 1 , grid%max_dom - CALL nl_set_hypsometric_opt ( loop , 1 ) - END DO - WRITE(wrf_err_message,*)'Ideal cases do not support the hypsometric option.' - CALL wrf_debug( 0 , wrf_err_message ) - END IF +#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) ) + IF ( switch .EQ. boundary_only ) THEN + grid%just_read_boundary = .true. END IF #endif @@ -267,6 +251,7 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_START_DATE' , simulation_start_date , ierr ) CALL nl_get_reset_simulation_start ( 1, reset_simulation_start ) + IF ( ( ierr .EQ. 0 ) .AND. ( .NOT. reset_simulation_start ) ) THEN ! Overwrite simulation start date with metadata. #ifdef PLANET @@ -288,11 +273,11 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) CALL nl_set_simulation_start_minute ( 1 , simulation_start_minute ) CALL nl_set_simulation_start_second ( 1 , simulation_start_second ) IF ( switch .EQ. input_only ) THEN - WRITE(wrf_err_message,*)fid,' input_wrf, input_only: SIMULATION_START_DATE = ', & + WRITE(wrf_err_message,*) ' input_wrf, input_only: SIMULATION_START_DATE = ', & simulation_start_date(1:19) CALL wrf_debug ( 300 , TRIM(wrf_err_message ) ) ELSE IF ( switch .EQ. restart_only ) THEN - WRITE(wrf_err_message,*)fid,' input_wrf, restart_only: SIMULATION_START_DATE = ', & + WRITE(wrf_err_message,*) ' input_wrf, restart_only: SIMULATION_START_DATE = ', & simulation_start_date(1:19) CALL wrf_debug ( 300 , TRIM(wrf_err_message ) ) ENDIF @@ -358,29 +343,11 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) #if (EM_CORE == 1) - IF ( ( switch .EQ. input_only ) .AND. ( config_flags%io_form_input .EQ. 2 ) ) THEN - - ! For backward compatibility. If we do not find the hypsometric_opt defined - ! in the input data, this is pre version 3.4. Most likely, the hypsometric_opt - ! was the default value, 1. - - hypsometric_opt = -1 - CALL wrf_get_dom_ti_integer ( fid , 'HYPSOMETRIC_OPT' , hypsometric_opt , 1 , icnt , ierr ) - IF ( ( hypsometric_opt .NE. 1 ) .AND. ( hypsometric_opt .NE. 2 ) ) THEN - grid%hypsometric_opt = 1 - config_flags%hypsometric_opt = 1 - DO loop = 1 , grid%max_dom - CALL nl_set_hypsometric_opt ( loop , 1 ) - END DO - WRITE(wrf_err_message,*)'Resetting the hypsometric_opt from default value of 2 to 1' - CALL wrf_debug( 0 , wrf_err_message ) - END IF - END IF - ! Test to make sure that the grid distances are the right size. CALL wrf_get_dom_ti_real ( fid , 'DX' , dx_compare , 1 , icnt , ierr ) CALL wrf_get_dom_ti_real ( fid , 'DY' , dy_compare , 1 , icnt , ierr ) + IF ( ( ABS ( dx_compare - config_flags%dx ) .GT. 1.E-5 * dx_compare ) .OR. & ( ABS ( dy_compare - config_flags%dy ) .GT. 1.E-5 * dy_compare ) ) THEN IF ( ( config_flags%polar ) .AND. ( config_flags%grid_id .EQ. 1 ) ) THEN @@ -399,12 +366,13 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) #if (EM_CORE == 1) IF ( ( switch .EQ. input_only ) .OR. ( switch .EQ. auxinput2_only ) .OR. ( switch .EQ. auxinput1_only ) ) THEN - ierr = 0 - IF ( ( switch .EQ. input_only ) .OR. ( switch .EQ. auxinput2_only ) ) THEN + ierr = 0 + ierr3 = 0 + IF ( ( ( switch .EQ. input_only ) .AND. ( grid%id .GE. 2 ) ) .OR. ( switch .EQ. auxinput2_only ) ) THEN CALL wrf_get_dom_ti_integer ( fid , 'I_PARENT_START' , itmp , 1 , icnt , ierr3 ) ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .GE. 2 ) ) THEN CALL wrf_get_dom_ti_integer ( fid , 'i_parent_start' , itmp , 1 , icnt , ierr3 ) - ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .EQ. 1 ) ) THEN + ELSE IF ( ( ( switch .EQ. auxinput1_only ) .OR. ( switch .EQ. input_only ) ) .AND. ( grid%id .EQ. 1 ) ) THEN itmp = config_flags%i_parent_start ierr3 = 0 END IF @@ -416,11 +384,11 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) WRITE(wrf_err_message,*)'i_parent_start from gridded input file = ',itmp CALL wrf_message(wrf_err_message) END IF - IF ( ( switch .EQ. input_only ) .OR. ( switch .EQ. auxinput2_only ) ) THEN + IF ( ( ( switch .EQ. input_only ) .AND. ( grid%id .GE. 2 ) ) .OR. ( switch .EQ. auxinput2_only ) ) THEN CALL wrf_get_dom_ti_integer ( fid , 'J_PARENT_START' , itmp , 1 , icnt , ierr3 ) ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .GE. 2 ) ) THEN CALL wrf_get_dom_ti_integer ( fid , 'j_parent_start' , itmp , 1 , icnt , ierr3 ) - ELSE IF ( ( switch .EQ. auxinput1_only ) .AND. ( grid%id .EQ. 1 ) ) THEN + ELSE IF ( ( ( switch .EQ. auxinput1_only ) .OR. ( switch .EQ. input_only ) ) .AND. ( grid%id .EQ. 1 ) ) THEN itmp = config_flags%j_parent_start ierr3 = 0 END IF @@ -534,28 +502,36 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) grid%map_proj = config_flags%map_proj CALL wrf_get_dom_ti_char ( fid , 'MMINLU', mminlu , ierr ) - IF ( ierr .NE. 0 ) THEN -#ifdef WRF_CHEM - IF ( config_flags%chem_opt == MOZART_MOSAIC_4BIN_VBS0_KPP ) then - WRITE(wrf_err_message,*)'MMINLU error on input - will set mminlu to MODIFIED_IGBP_MODIS_NOAH in share/input_wrf.F' - mminlu = "MODIFIED_IGBP_MODIS_NOAH" - ELSE +#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) ) + IF ( ( ( switch .EQ. input_only ) .OR. ( switch .EQ. restart_only ) ) .AND. & + ( ( config_flags%io_form_input .EQ. 2 ) .OR. & + ( config_flags%io_form_input .EQ. 11 ) ) ) THEN + CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_INITIALIZATION_TYPE', sim_type , icnt ) + IF ( TRIM(sim_type) .NE. "IDEALIZED DATA" ) THEN + IF ( ierr .NE. 0 ) THEN + WRITE(wrf_err_message,*)'MMINLU error on input' + mminlu = " " + CALL wrf_debug ( 0 , wrf_err_message ) + END IF + END IF + ELSE IF ( ( switch .EQ. input_only ) .OR. ( switch .EQ. restart_only ) ) THEN + IF ( ierr .NE. 0 ) THEN WRITE(wrf_err_message,*)'MMINLU error on input' mminlu = " " - ENDIF -#else - WRITE(wrf_err_message,*)'MMINLU error on input' - mminlu = " " + CALL wrf_debug ( 0 , wrf_err_message ) + END IF + END IF #endif - CALL wrf_debug ( 0 , wrf_err_message ) - ELSE IF ( ( ( mminlu(1:1) .GE. "A" ) .AND. ( mminlu(1:1) .LE. "Z" ) ) .OR. & - ( ( mminlu(1:1) .GE. "a" ) .AND. ( mminlu(1:1) .LE. "z" ) ) .OR. & - ( ( mminlu(1:1) .GE. "0" ) .AND. ( mminlu(1:1) .LE. "9" ) ) ) THEN - ! no-op, the mminlu field is probably OK - ELSE IF ( mminlu(1:1) .EQ. " " ) THEN - mminlu = " " - ELSE - mminlu = " " + IF ( ierr .EQ. 0 ) THEN + IF ( ( ( mminlu(1:1) .GE. "A" ) .AND. ( mminlu(1:1) .LE. "Z" ) ) .OR. & + ( ( mminlu(1:1) .GE. "a" ) .AND. ( mminlu(1:1) .LE. "z" ) ) .OR. & + ( ( mminlu(1:1) .GE. "0" ) .AND. ( mminlu(1:1) .LE. "9" ) ) ) THEN + ! no-op, the mminlu field is probably OK + ELSE IF ( mminlu(1:1) .EQ. " " ) THEN + mminlu = " " + ELSE + mminlu = " " + END IF END IF call wrf_debug( 1 , "mminlu = '" // TRIM(mminlu) // "'") if (index(mminlu, char(0)) > 0) mminlu(index(mminlu, char(0)):) = " " @@ -567,7 +543,9 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) ! The default is set to 24 somewhere, from the number of categories ! in the traditional USGS dataset - IF ( switch .EQ. input_only ) THEN + IF ( ( switch .EQ. input_only ) .OR. & + ( switch .EQ. auxinput1_only ) .OR. & + ( switch .EQ. auxinput2_only ) ) THEN call wrf_get_dom_ti_integer(fid, "NUM_LAND_CAT", num_land_cat_compare, 1, icnt, ierr) if ( (ierr .NE. 0) .OR. ( num_land_cat_compare .LT. 1 ) .OR. ( num_land_cat_compare .GT. 1000 ) ) then IF (mminlu == 'MODIFIED_IGBP_MODIS_NOAH') THEN @@ -621,7 +599,7 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) END IF #if 0 -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! Dust erosion static data. CALL wrf_get_dom_ti_integer ( fid, 'EROSION_DIM', itmp, 1, icnt, ierr ) @@ -836,11 +814,77 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) call wrf_message(wrf_err_message) call wrf_error_fatal("Mismatch between namelist and global attribute HYPSOMETRIC_OPT") END IF + ELSE + ! For WRFDA backward compatibility. If hypsometric_opt is not defined in the fg file, it is + ! pre-version 3.4 WRF input data. For older versions, hypsometric_opt should be 1. + hypsometric_opt = -1 + CALL wrf_get_dom_ti_integer ( fid , 'HYPSOMETRIC_OPT' , hypsometric_opt, 1 , icnt , ierr ) + IF ( ( hypsometric_opt .NE. 1 ) .AND. ( hypsometric_opt .NE. 2 ) ) THEN + grid%hypsometric_opt = 1 + config_flags%hypsometric_opt = 1 + DO loop = 1 , grid%max_dom + CALL nl_set_hypsometric_opt ( loop , 1 ) + END DO + WRITE(wrf_err_message,*)'Background (fg) file appears to be from earlier than WRF V3.4;' + call wrf_message(wrf_err_message) + WRITE(wrf_err_message,*)'Resetting the hypsometric_opt from default value of 2 to 1' + CALL wrf_message(wrf_err_message) + END IF + END IF END IF #endif +#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) ) + IF ( ( switch .EQ. input_only ) .OR. ( switch .EQ. restart_only ) ) THEN + + ! Make sure for ARW ideal cases that the hypsometric option, the + ! way that we integrate the height field, is set to 1. This is the + ! method that is used in all of the "ideal" programs to get the + ! base-state height (phb). + + CALL wrf_get_dom_ti_char ( fid , 'SIMULATION_INITIALIZATION_TYPE', sim_type , ierr ) + IF ( TRIM(sim_type) .EQ. "IDEALIZED DATA" ) THEN + grid%this_is_an_ideal_run = .TRUE. + ELSE IF ( TRIM(sim_type) .EQ. "REAL-DATA CASE" ) THEN + grid%this_is_an_ideal_run = .FALSE. + ELSE IF ( ierr .NE. 0 ) THEN + CALL wrf_get_dom_ti_char ( fid , 'START_DATE' , input_name , ierr ) + grid%this_is_an_ideal_run = INDEX(TRIM(input_name) , '0001-' ) .NE. 0 + END IF + + IF ( grid%this_is_an_ideal_run ) THEN + grid%hypsometric_opt = 1 + config_flags%hypsometric_opt = 1 + DO loop = 1 , grid%max_dom + CALL nl_set_hypsometric_opt ( loop , 1 ) + END DO + WRITE(wrf_err_message,*)'NOTE: Ideal cases always use hypsometric_opt=1, regardless of namelist setting' + CALL wrf_debug( 1 , wrf_err_message ) + END IF + END IF + + IF ( ( switch .EQ. input_only ) .AND. ( config_flags%io_form_input .EQ. 2 ) ) THEN + + ! For backward compatibility. If we do not find the hypsometric_opt defined + ! in the input data, this is pre version 3.4. Most likely, the hypsometric_opt + ! was the default value, 1. + + hypsometric_opt = -1 + CALL wrf_get_dom_ti_integer ( fid , 'HYPSOMETRIC_OPT' , hypsometric_opt , 1 , icnt , ierr ) + IF ( ( hypsometric_opt .NE. 1 ) .AND. ( hypsometric_opt .NE. 2 ) ) THEN + grid%hypsometric_opt = 1 + config_flags%hypsometric_opt = 1 + DO loop = 1 , grid%max_dom + CALL nl_set_hypsometric_opt ( loop , 1 ) + END DO + WRITE(wrf_err_message,*)'Resetting the hypsometric_opt from default value of 2 to 1' + CALL wrf_debug( 0 , wrf_err_message ) + END IF + END IF +#endif + ENDIF check_if_dryrun ! @@ -878,7 +922,7 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) auxinput3_only, auxinput4_only, auxinput5_only, & auxinput6_only, auxinput7_only, auxinput8_only, & auxinput9_only, auxinput10_only ) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF( (config_flags%io_style_emissions .eq. 1) .and. & ((switch.eq.auxinput5_only) .or. (switch.eq.auxinput6_only) .or. & (switch.eq.auxinput7_only) .or. (switch.eq.auxinput8_only)) ) then @@ -904,7 +948,7 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) GOTO 3003 ENDIF #endif -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ENDIF #endif CASE DEFAULT @@ -917,19 +961,91 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) ! iterate forward to the correct interval in the input LBC file ! IF ( switch .EQ. boundary_only ) THEN - CALL domain_clock_get( grid, current_time=currentTime ) - CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr ) - CALL wrf_atotime( this_datestr(1:19), grid%this_bdy_time ) - CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr ) - CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time ) + IF ( config_flags%restart ) THEN + ! get WRF time of current_date position in boundary file + CALL wrf_atotime( current_date(1:19), time ) + ! jump straight to the restart time + CALL domain_clock_get( grid, current_time=currentTime, & + current_timestr=currtimestr ) + write(wrf_err_message, '(4a)') "WRF restart, LBC starts at ", & + & trim(current_date), " and restart starts at ", trim(currtimestr) + CALL wrf_debug( 0 , wrf_err_message ) + CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr ) + CALL wrf_atotime( this_datestr(1:19), grid%this_bdy_time ) + CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr ) + CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time ) + + WRITE ( wrf_err_message , * ) 'LBC for restart: Starting valid date = ',this_datestr(1:19),', Ending valid date = ',next_datestr(1:19) + CALL wrf_message( TRIM(wrf_err_message) ) + WRITE ( wrf_err_message , * ) 'LBC for restart: Restart time = ',trim(currtimestr) + CALL wrf_message( TRIM(wrf_err_message) ) + + IF ( ( grid%this_bdy_time .LE. currentTime ) .AND. ( grid%next_bdy_time .GT. currentTime ) ) THEN + WRITE ( wrf_err_message , * ) 'LBC for restart: Found the correct bounding LBC time periods' + CALL wrf_message( TRIM(wrf_err_message) ) + ELSE + + WRITE ( wrf_err_message , * ) 'LBC for restart: Looking for a bounding time' + CALL wrf_message( TRIM(wrf_err_message) ) + + ! While the lateral BC time is less than the restart time, advance forward to the next LBC time. + + icount = 0 + DO WHILE ( ( currentTime .GE. grid%next_bdy_time ) .AND. ( icount < 10000 ) ) + CALL wrf_get_next_time(fid, current_date , ierr) + IF ( ierr .NE. 0 ) THEN + CALL wrf_error_fatal ( 'Cannot find a valid time to start the LBC during this restart, likely ran out of time periods to test' ) + END IF + CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr ) + CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr ) + CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time ) + WRITE ( wrf_err_message , * ) 'LBC for restart: Starting valid date = ',this_datestr(1:19),', Ending valid date = ',next_datestr(1:19) + CALL wrf_message( TRIM(wrf_err_message) ) + icount = icount + 1 + END DO + + ! Now the LBC time either matches or is beyond the restart time. If it matches, we are at the + ! right time. If we have gone too far, then back up one time period, and we are good to go. + + IF ( time .eq. currentTime ) THEN + CALL wrf_debug ( 0 , 'Found correct time, LBC matches the restart interval.' ) + ELSE IF ( time .gt. currentTime ) THEN + CALL wrf_debug ( 0 , 'Went one LBC interval too far, backing up for restart.' ) + CALL wrf_get_previous_time(fid, current_date , ierr) + IF ( ierr .EQ. 0 ) THEN + CALL wrf_atotime(current_date(1:19), time) + WRITE(wrf_err_message,*) 'LBC: wrf_get_prev_time current_date: ',& + & current_date(1:19),' Status = ',ierr + CALL wrf_debug ( 0 , TRIM(wrf_err_message ) ) + CALL wrf_debug ( 0 , 'LBC is now correctly positioned for requested restart time' ) + ELSE + CALL wrf_error_fatal ( 'Problems backing up in the LBC file to find startig location for restart' ) + END IF + END IF + END IF + + CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr ) + CALL wrf_atotime( this_datestr(1:19), grid%this_bdy_time ) + CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr ) + CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time ) + WRITE ( wrf_err_message , * ) 'LBC for restart: Found the correct bounding LBC time periods for restart time = ',trim(currtimestr) + CALL wrf_message ( TRIM(wrf_err_message) ) + + ELSE IF ( .NOT. config_flags%restart ) THEN + CALL domain_clock_get( grid, current_time=currentTime ) + CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' , current_date(1:19), this_datestr , ierr ) + CALL wrf_atotime( this_datestr(1:19), grid%this_bdy_time ) + CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' , current_date(1:19), next_datestr , ierr ) + CALL wrf_atotime( next_datestr(1:19), grid%next_bdy_time ) + END IF #if (DA_CORE != 1) - IF( currentTime .GE. grid%next_bdy_time ) THEN + IF( currentTime .GE. grid%next_bdy_time ) THEN IF ( wrf_dm_on_monitor() ) THEN - write(a_message,*) 'THIS TIME ',this_datestr(1:19),'NEXT TIME ',next_datestr(1:19) + write(a_message,*) 'THIS TIME ',this_datestr(1:19),', NEXT TIME ',next_datestr(1:19) CALL wrf_message ( a_message ) END IF RETURN - ENDIF + ENDIF #endif ENDIF @@ -963,9 +1079,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%rfield_0d , & ! Field WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask '0' , & ! MemoryOrder '' , & ! Stagger @@ -981,9 +1096,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%dfield_0d , & ! Field WRF_DOUBLE , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask '0' , & ! MemoryOrder '' , & ! Stagger @@ -999,9 +1113,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%ifield_0d , & ! Field WRF_INTEGER , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask '0' , & ! MemoryOrder '' , & ! Stagger @@ -1017,9 +1130,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%lfield_0d , & ! Field WRF_LOGICAL , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask '0' , & ! MemoryOrder '' , & ! Stagger @@ -1062,11 +1174,10 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) fid , & ! DataHandle current_date(1:19) , & ! DateStr TRIM(dname) , & ! Data Name - f_vint_1d , & ! Field + f_vint_1d , & ! Field WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder p%Stagger , & ! Stagger @@ -1088,9 +1199,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%rfield_1d , & ! Field WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder p%Stagger , & ! Stagger @@ -1107,9 +1217,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%dfield_1d , & ! Field WRF_DOUBLE , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1125,9 +1234,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%ifield_1d , & ! Field WRF_INTEGER , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1143,9 +1251,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%lfield_1d , & ! Field WRF_LOGICAL , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1175,9 +1282,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%rfield_2d , & ! Field WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1193,9 +1299,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%dfield_2d , & ! Field WRF_DOUBLE , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1211,9 +1316,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%ifield_2d , & ! Field WRF_INTEGER , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1229,9 +1333,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%lfield_2d , & ! Field WRF_LOGICAL , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1278,9 +1381,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name f_vint_3d , & ! Field WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1305,9 +1407,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%rfield_3d , & ! Field WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1342,9 +1443,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) TRIM(dname) , & ! Data Name p%ifield_3d , & ! Field WRF_INTEGER , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1396,9 +1496,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) 1, 1, 1 , & ! see comment above RWORDSIZE , & WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1425,9 +1524,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) 1, 1, 1 , & ! see comment above RWORDSIZE , & WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1447,9 +1545,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) 1, 1, 1 , & ! see comment above DWORDSIZE , & WRF_DOUBLE , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger @@ -1468,9 +1565,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) 1, 1, 1 , & ! see comment above IWORDSIZE , & WRF_INTEGER , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm - grid%domdesc , & ! Comm + grid , & ! grid + grid%domdesc , & ! domdesc grid%bdy_mask , & ! bdy_mask TRIM(memord) , & ! MemoryOrder TRIM(p%Stagger) , & ! Stagger diff --git a/wrfv2_fire/share/interp_fcn.F b/wrfv2_fire/share/interp_fcn.F index 3715101d..56259156 100644 --- a/wrfv2_fire/share/interp_fcn.F +++ b/wrfv2_fire/share/interp_fcn.F @@ -1,30 +1,54 @@ +MODULE module_interp_info + INTEGER , PARAMETER :: NOT_DEFINED_YET = 0 + INTEGER , PARAMETER :: BILINEAR = 1 + INTEGER , PARAMETER :: SINT = 2 + INTEGER , PARAMETER :: NEAREST_NEIGHBOR = 3 + INTEGER , PARAMETER :: QUADRATIC = 4 + INTEGER , PARAMETER :: SPLINE = 5 + INTEGER , PARAMETER :: SINT_NEW = 12 + + INTEGER :: interp_method_type = 0 +CONTAINS + SUBROUTINE interp_info_init +#if (EM_CORE == 1) + CALL nl_get_interp_method_type ( 1 , interp_method_type ) +#else + interp_method_type = 2 +#endif + END SUBROUTINE interp_info_init +END MODULE module_interp_info + !WRF:MEDIATION_LAYER:INTERPOLATIONFUNCTION ! +! -#if (DA_CORE != 1) -#define MM5_SINT -#endif -!#define DUMBCOPY +!========================================================================= -! Note, NMM-specific routines moved to end. 20080612. JM + SUBROUTINE interp_init + USE module_interp_info + CALL interp_info_init + END SUBROUTINE interp_init - SUBROUTINE interp_fcn ( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj ) ! nest ratios - USE module_timing - USE module_configure - IMPLICIT NONE +!========================================================================= + +#if ! defined(NMM_CORE) || NMM_CORE!=1 + SUBROUTINE interp_fcn ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! Nest ratio, i- and j-directions + USE module_interp_info + + IMPLICIT NONE INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & @@ -41,136 +65,77 @@ SUBROUTINE interp_fcn ( cfld, & ! CD field REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - ! Local - -!logical first - - INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, nioff, njoff -#if (( DA_CORE == 1 ) || ( defined( MM5_SINT ) ) ) - INTEGER nfx, ior - PARAMETER (ior=2) - INTEGER nf - REAL psca(cims:cime,cjms:cjme,nri*nrj) - LOGICAL icmask( cims:cime, cjms:cjme ) - INTEGER i,j,k - INTEGER nrio2, nrjo2 -#endif - - ! Iterate over the ND tile and compute the values - ! from the CD tile. - -#if ( ( DA_CORE == 1 ) || ( defined( MM5_SINT ) ) ) - - ioff = 0 ; joff = 0 - nioff = 0 ; njoff = 0 - IF ( xstag ) THEN - ioff = (nri-1)/2 - nioff = nri - ENDIF - IF ( ystag ) THEN - joff = (nrj-1)/2 - njoff = nrj - ENDIF - - nrio2 = nri/2 - nrjo2 = nrj/2 - - nfx = nri * nrj - !$OMP PARALLEL DO & - !$OMP PRIVATE ( i,j,k,ni,nj,ci,cj,ip,jp,nk,ck,nf,icmask,psca ) - DO k = ckts, ckte - icmask = .FALSE. - DO nf = 1,nfx - DO j = cjms,cjme - nj = (j-jpos) * nrj + ( nrjo2 + 1 ) ! j point on nest - DO i = cims,cime - ni = (i-ipos) * nri + ( nrio2 + 1 ) ! i point on nest - if ( ni .ge. nits-nioff-nrio2 .and. & - ni .le. nite+nioff+nrio2 .and. & - nj .ge. njts-njoff-nrjo2 .and. & - nj .le. njte+njoff+nrjo2 ) then -! if ( imask(ni,nj) .eq. 1 .or. imask(ni-nioff,nj-njoff) .eq. 1 ) then -! icmask( i, j ) = .TRUE. -! endif - if ( ni.ge.nims.and.ni.le.nime.and.nj.ge.njms.and.nj.le.njme) then - if ( imask(ni,nj) .eq. 1 ) then - icmask( i, j ) = .TRUE. - endif - endif - if ( ni-nioff.ge.nims.and.ni.le.nime.and.nj-njoff.ge.njms.and.nj.le.njme) then - if (ni .ge. nits-nioff .and. nj .ge. njts-njoff ) then - if ( imask(ni-nioff,nj-njoff) .eq. 1) then - icmask( i, j ) = .TRUE. - endif - endif - endif - endif - psca(i,j,nf) = cfld(i,k,j) - ENDDO - ENDDO - ENDDO - -! tile dims in this call to sint are 1-over to account for the fact -! that the number of cells on the nest local subdomain is not -! necessarily a multiple of the nest ratio in a given dim. -! this could be a little less ham-handed. - -!call start_timing - - CALL sint( psca, & - cims, cime, cjms, cjme, icmask, & - cits-1, cite+1, cjts-1, cjte+1, nrj*nri, xstag, ystag ) - -!call end_timing( ' sint ' ) - - DO nj = njts, njte+joff - cj = jpos + (nj-1) / nrj ! j coord of CD point - jp = mod ( nj-1 , nrj ) ! coord of ND w/i CD point - nk = k - ck = nk - DO ni = nits, nite+ioff - ci = ipos + (ni-1) / nri ! i coord of CD point - ip = mod ( ni-1 , nri ) ! coord of ND w/i CD point - if ( imask ( ni, nj ) .eq. 1 .or. imask ( ni-ioff, nj-joff ) .eq. 1 ) then - nfld( ni-ioff, nk, nj-joff ) = psca( ci , cj, ip+1 + (jp)*nri ) - endif - ENDDO - ENDDO - ENDDO - !$OMP END PARALLEL DO -#endif - -#ifdef DUMBCOPY -!write(0,'(") cims:cime, ckms:ckme, cjms:cjme ",6i4)')cims,cime, ckms,ckme, cjms,cjme -!write(0,'(") nims:nime, nkms:nkme, njms:njme ",6i4)')nims,nime, nkms,nkme, njms,njme -!write(0,'(") cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte -!write(0,'(") nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte - - DO nj = njts, njte - cj = jpos + (nj-1) / nrj ! j coord of CD point - jp = mod ( nj , nrj ) ! coord of ND w/i CD point - DO nk = nkts, nkte - ck = nk - DO ni = nits, nite - ci = ipos + (ni-1) / nri ! j coord of CD point - ip = mod ( ni , nri ) ! coord of ND w/i CD point - ! This is a trivial implementation of the interp_fcn; just copies - ! the values from the CD into the ND - if ( imask ( ni, nj ) .eq. 1 ) then - nfld( ni, nk, nj ) = cfld( ci , ck , cj ) - endif - ENDDO - ENDDO - ENDDO -#endif + IF ( interp_method_type .EQ. NOT_DEFINED_YET ) THEN + interp_method_type = SINT + END IF - RETURN + IF ( interp_method_type .EQ. BILINEAR ) THEN + CALL interp_fcn_blint ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj) ! Nest ratio, i- and j-directions + ELSE IF ( MOD(interp_method_type,10) .EQ. SINT ) THEN + CALL interp_fcn_sint ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj) ! Nest ratio, i- and j-directions + ELSE IF ( interp_method_type .EQ. NEAREST_NEIGHBOR ) THEN + CALL interp_fcn_nn ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj) ! Nest ratio, i- and j-directions + ELSE IF ( interp_method_type .EQ. QUADRATIC ) THEN + CALL interp_fcn_lagr ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj) ! Nest ratio, i- and j-directions + ELSE + CALL wrf_error_fatal ('Hold on there cowboy, we need to know which interpolation option you want') + END IF END SUBROUTINE interp_fcn !========================================================================= - SUBROUTINE interp_fcn_bl ( cfld, & ! CD field +! Overlapping linear horizontal iterpolation for mass, u, and v staggerings. + + SUBROUTINE interp_fcn_blint ( cfld, & ! CD field cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -182,22 +147,10 @@ SUBROUTINE interp_fcn_bl ( cfld, & ! CD field imask, & ! interpolation mask xstag, ystag, & ! staggering of field ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! Nest ratio, i- and j-directions - cht, nht, & ! topography for CG and FG - ct_max_p,nt_max_p, & ! temperature (K) at max press, want CG value - cght_max_p,nght_max_p, & ! height (m) at max press, want CG value - cmax_p,nmax_p, & ! max pressure (Pa) in column, want CG value - ct_min_p,nt_min_p, & ! temperature (K) at min press, want CG value - cght_min_p,nght_min_p, & ! height (m) at min press, want CG value - cmin_p,nmin_p, & ! min pressure (Pa) in column, want CG value - zn, p_top ) ! eta levels - USE module_timing - USE module_configure - USE module_model_constants , ONLY : g , r_d, cp, p1000mb, t0 + nri, nrj) ! Nest ratio, i- and j-directions IMPLICIT NONE - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -212,39 +165,17 @@ SUBROUTINE interp_fcn_bl ( cfld, & ! CD field REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cht, ct_max_p, cght_max_p, cmax_p, ct_min_p, cght_min_p, cmin_p - REAL, DIMENSION ( nims:nime, njms:njme ) :: nht, nt_max_p, nght_max_p, nmax_p, nt_min_p, nght_min_p, nmin_p - REAL, DIMENSION ( ckms:ckme ) :: zn - REAL :: p_top - REAL, EXTERNAL :: v_interp_col ! Local - INTEGER ci, cj, ni, nj, nk, istag, jstag, i, j, k - REAL :: wx, wy, nprs, cfld_ll, cfld_lr, cfld_ul, cfld_ur - REAL , DIMENSION(ckms:ckme) :: cprs - REAL :: p00 , t00 , a , tiso , p_surf - - ! Yes, memory sized to allow "outside the tile" indexing for horiz interpolation. This - ! is really an intermediate domain that has quite a bit of usable real estate surrounding - ! the tile dimensions. - - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cpb - - ! A bit larger than tile sized to allow horizontal interpolation on the CG. - - REAL, DIMENSION ( cits-2:cite+2, cjts-2:cjte+2 ) :: cfld_max_p, cfld_min_p - - ! The usual tile size for the FG local array. - - REAL, DIMENSION ( nits:nite, nkts:nkte, njts:njte ) :: npb + INTEGER ci, cj, ck, ni, nj, nk, istag, jstag, ioff, joff, i, j, k + REAL :: wx, wy, cfld_ll, cfld_lr, cfld_ul, cfld_ur + REAL :: cxp0, cxp1, nx, cyp0, cyp1, ny - ! Get base state constants + ! Fortran functions. Yes, yes, I know, probably pretty slow. - CALL nl_get_base_pres ( 1 , p00 ) - CALL nl_get_base_temp ( 1 , t00 ) - CALL nl_get_base_lapse ( 1 , a ) - CALL nl_get_iso_temp ( 1 , tiso ) + REAL, EXTERNAL :: nest_loc_of_cg + INTEGER, EXTERNAL :: compute_CGLL ! This stag stuff is to keep us away from the outer most row ! and column for the unstaggered directions. We are going to @@ -255,59 +186,23 @@ SUBROUTINE interp_fcn_bl ( cfld, & ! CD field IF ( xstag ) THEN istag = 0 + ioff = 1 ELSE istag = 1 + ioff = 0 END IF IF ( ystag ) THEN jstag = 0 + joff = 1 ELSE jstag = 1 + joff = 0 END IF - ! Compute the reference pressure for the CG, function only of constants and elevation. - ! We extend the i,j range to allow us to do horizontal interpolation. We only need - ! one extra grid cell surrounding the nest, and the intermediate domain has plenty of - ! room with the halos set up for higher-order interpolations. For intermediate domains, - ! it turns out that the "domain" size actually fits within the "tile" size. Yeppers, - ! that is backwards from what usually happens. That intermediate domain size is a couple - ! grid points larger than necessary, and the tile is a couple of grid cells larger still. - ! For our low-order interpolation, we can use the tile size for the CG, and we will have - ! plenty of data on our boundaries. + ! Loop over each j-index on this tile for the nested domain. - DO j = cjts-2 , cjte+2 - DO i = cits-2 , cite+2 - p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*cht(i,j)/a/r_d ) **0.5 ) - DO k = ckts , ckte - cpb(i,k,j) = zn(k)*(p_surf - p_top) + p_top - END DO - IF ( ckte .EQ. ckme ) THEN - cfld_max_p(i,j) = cght_max_p(i,j) * g - cfld_min_p(i,j) = cght_min_p(i,j) * g - ELSE - cfld_max_p(i,j) = ct_max_p(i,j) * (p1000mb/cmax_p(i,j))**(r_d/cp) - t0 - cfld_min_p(i,j) = ct_min_p(i,j) * (p1000mb/cmin_p(i,j))**(r_d/cp) - t0 - END IF - END DO - END DO - - ! Compute the reference pressure for the FG. This is actually the size of the entire - ! domain, not some chopped down piece of intermediate domain, as in the parent - ! grid. We do the traditional MAX(dom end -1,tile end), since we know a priori that the - ! pressure is a mass point field (because the topo elevation is a mass point field). - - DO j = njts , MIN(njde-1,njte) - DO i = nits , MIN(nide-1,nite) - p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*nht(i,j)/a/r_d ) **0.5 ) - DO k = nkts , nkte - npb(i,k,j) = zn(k)*(p_surf - p_top) + p_top - END DO - END DO - END DO - - ! Loop over each j-index on this tile for the nested domain. - - j_loop : DO nj = njts, MIN(njde-jstag,njte) + j_loop : DO nj = njts, MIN(njde-jstag,njte) ! This is the lower-left j-index of the CG. @@ -336,28 +231,15 @@ SUBROUTINE interp_fcn_bl ( cfld, & ! CD field ! 5 => B ! 6 => B ! 7 => B - ! We want an equation that returns the CG LL: - ! CG LL = ipos (the starting point of the nest in the CG) - ! + (ni-1)/nri (gives us the CG cell, based on the nri-groups of FG cells - ! - istag (a correction term, this is either zero for u in the x-dir, - ! since we are doing an "i" example, or 1 for anything else) - ! + (MOD(ni-1,nri)+1 + nri/2)/nri (gives us specifically related CG point for each of the nri - ! FG points, for example, we want points "1", "4", and "7" all - ! to point to the CG at the left for the LL point) - ! For grid points 4, 5, 6, we want the CG LL (sans the first two terms) to be -1, 0, 0 (which - ! means that the CG point for "4" is to the left, and the CG LL point for "5" and "6" - ! is in the current CG index. - - cj = jpos + (nj-1)/nrj - jstag + (MOD(nj-1,nrj)+1 + nrj/2)/nrj + cj = compute_CGLL ( nj , jpos , nrj , jstag ) + ny = REAL(nj) + cyp0 = nest_loc_of_cg ( cj , jpos , nrj , joff ) + cyp1 = nest_loc_of_cg ( cj+1 , jpos , nrj , joff ) ! What is the weighting for this CG point to the FG point, j-weight only. - IF ( ystag ) THEN - wy = 1. - ( REAL(MOD(nj+(nrj-1)/2,nrj)) / REAL(nrj) + 1. / REAL (2 * nrj) ) - ELSE - wy = 1. - ( REAL(MOD(nj+(nrj-1)/2,nrj)) / REAL(nrj) ) - END IF + wy = ( cyp1 - ny ) / ( cyp1 - cyp0 ) ! Vertical dim of the nest domain. @@ -366,565 +248,410 @@ SUBROUTINE interp_fcn_bl ( cfld, & ! CD field ! Loop over each i-index on this tile for the nested domain. i_loop : DO ni = nits, MIN(nide-istag,nite) + + IF ( imask ( ni, nj ) .EQ. 1 ) THEN - ! The coarse grid location that is to the lower left of the FG point. + ! The coarse grid location that is to the lower left of the FG point. + + ci = compute_CGLL ( ni , ipos , nri , istag ) + nx = REAL(ni) + cxp0 = nest_loc_of_cg ( ci , ipos , nri , ioff ) + cxp1 = nest_loc_of_cg ( ci+1 , ipos , nri , ioff ) + + wx = ( cxp1 - nx ) / ( cxp1 - cxp0 ) + + ! The four surrounding CG values. + + cfld_ll = cfld(ci ,nk,cj ) + cfld_lr = cfld(ci+1,nk,cj ) + cfld_ul = cfld(ci ,nk,cj+1) + cfld_ur = cfld(ci+1,nk,cj+1) - ci = ipos + (ni-1)/nri - istag + (MOD(ni-1,nri)+1 + nri/2)/nri + ! Bilinear interpolation in horizontal. - ! Weights in the x-direction. + nfld( ni , nk , nj ) = wy * ( cfld_ll * wx + cfld_lr * (1.-wx) ) + & + (1.-wy) * ( cfld_ul * wx + cfld_ur * (1.-wx) ) - IF ( xstag ) THEN - wx = 1. - ( REAL(MOD(ni+(nri-1)/2,nri)) / REAL(nri) + 1. / REAL (2 * nri) ) - ELSE - wx = 1. - ( REAL(MOD(ni+(nri-1)/2,nri)) / REAL(nri) ) END IF + END DO i_loop + END DO k_loop + END DO j_loop - ! The pressure of the FG point. + END SUBROUTINE interp_fcn_blint - IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN - nprs = npb( ni , nk , nj ) - ELSE IF ( xstag ) THEN - nprs = ( npb( ni-1, nk , nj ) + npb( ni , nk , nj ) ) * 0.5 - ELSE IF ( ystag ) THEN - nprs = ( npb( ni , nk , nj-1) + npb( ni , nk , nj ) ) * 0.5 - END IF +!========================================================================= - ! The four surrounding CG values. +! Lagrange interpolating polynomials, set up as a quadratic, with an average of +! the overlap. + + SUBROUTINE interp_fcn_lagr ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj) ! Nest ratio, i- and j-directions - IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN - cprs(:) = cpb(ci ,:,cj ) - cfld_ll = v_interp_col ( cfld(ci ,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj , & - cfld_max_p(ci ,cj ) , cmax_p(ci ,cj ) , cfld_min_p(ci ,cj ) , cmin_p(ci ,cj ) ) - cprs(:) = cpb(ci+1,:,cj ) - cfld_lr = v_interp_col ( cfld(ci+1,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj , & - cfld_max_p(ci+1,cj ) , cmax_p(ci+1,cj ) , cfld_min_p(ci+1,cj ) , cmin_p(ci+1,cj ) ) - cprs(:) = cpb(ci ,:,cj+1) - cfld_ul = v_interp_col ( cfld(ci ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj+1, & - cfld_max_p(ci ,cj+1) , cmax_p(ci ,cj+1) , cfld_min_p(ci ,cj+1) , cmin_p(ci ,cj+1) ) - cprs(:) = cpb(ci+1,:,cj+1) - cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, & - cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) ) + IMPLICIT NONE - ELSE IF ( xstag ) THEN - cprs(:) = ( cpb(ci ,:,cj ) + cpb(ci-1,:,cj ) )*0.5 - cfld_ll = v_interp_col ( cfld(ci ,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj , & - cfld_max_p(ci ,cj ) , cmax_p(ci ,cj ) , cfld_min_p(ci ,cj ) , cmin_p(ci ,cj ) ) - cprs(:) = ( cpb(ci+1,:,cj ) + cpb(ci ,:,cj ) )*0.5 - cfld_lr = v_interp_col ( cfld(ci+1,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj , & - cfld_max_p(ci+1,cj ) , cmax_p(ci+1,cj ) , cfld_min_p(ci+1,cj ) , cmin_p(ci+1,cj ) ) - cprs(:) = ( cpb(ci ,:,cj+1) + cpb(ci-1,:,cj+1) )*0.5 - cfld_ul = v_interp_col ( cfld(ci ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj+1, & - cfld_max_p(ci ,cj+1) , cmax_p(ci ,cj+1) , cfld_min_p(ci ,cj+1) , cmin_p(ci ,cj+1) ) - cprs(:) = ( cpb(ci+1,:,cj+1) + cpb(ci ,:,cj+1) )*0.5 - cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, & - cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) ) - ELSE IF ( ystag ) THEN - cprs(:) = ( cpb(ci ,:,cj ) + cpb(ci ,:,cj-1) )*0.5 - cfld_ll = v_interp_col ( cfld(ci ,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj , & - cfld_max_p(ci ,cj ) , cmax_p(ci ,cj ) , cfld_min_p(ci ,cj ) , cmin_p(ci ,cj ) ) - cprs(:) = ( cpb(ci+1,:,cj ) + cpb(ci+1,:,cj-1) )*0.5 - cfld_lr = v_interp_col ( cfld(ci+1,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj , & - cfld_max_p(ci+1,cj ) , cmax_p(ci+1,cj ) , cfld_min_p(ci+1,cj ) , cmin_p(ci+1,cj ) ) - cprs(:) = ( cpb(ci ,:,cj+1) + cpb(ci ,:,cj ) )*0.5 - cfld_ul = v_interp_col ( cfld(ci ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj+1, & - cfld_max_p(ci ,cj+1) , cmax_p(ci ,cj+1) , cfld_min_p(ci ,cj+1) , cmin_p(ci ,cj+1) ) - cprs(:) = ( cpb(ci+1,:,cj+1) + cpb(ci+1,:,cj ) )*0.5 - cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, & - cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) ) - END IF + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag - ! Bilinear interpolation in horizontal with vertically corrected CG field values. + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - nfld( ni , nk , nj ) = wy * ( cfld_ll * wx + cfld_lr * (1.-wx) ) + & - (1.-wy) * ( cfld_ul * wx + cfld_ur * (1.-wx) ) + ! Local - END DO i_loop - END DO k_loop - END DO j_loop + INTEGER ci, cj, ck, ni, nj, nk, istag, jstag, i, j, k + REAL :: nx, x0, x1, x2, x3, x + REAL :: ny, y0, y1, y2, y3 + REAL :: cxm1, cxp0, cxp1, cxp2, nfld_m1, nfld_p0, nfld_p1, nfld_p2 + REAL :: cym1, cyp0, cyp1, cyp2 + INTEGER :: ioff, joff - ! If this is ph_2, make the values at k=1 all zero + ! Fortran functions. - IF ( ckme .EQ. ckte ) THEN - DO nj = njts,njte - DO ni = nits, nite - nfld(ni,nkts,nj) = 0.0 - END DO - END DO + REAL, EXTERNAL :: lagrange_quad_avg + REAL, EXTERNAL :: nest_loc_of_cg + INTEGER, EXTERNAL :: compute_CGLL + + ! This stag stuff is to keep us away from the outer most row + ! and column for the unstaggered directions. We are going to + ! consider "U" an xstag variable and "V" a ystag variable. The + ! vertical staggering is handled in the actual arguments. The + ! ckte and nkte are the ending vertical dimensions for computations + ! for this particular variable. + + ! The ioff and joff are offsets due to the staggering. It is a lot + ! simpler with ioff and joff if + ! u var => ioff=1 + ! v var => joff=1 + ! otherwise zero. + ! Note that is OPPOSITE of the istag, jstag vars. The stag variables are + ! used for the domain dimensions, the offset guys are used in the + ! determination of grid points between the CG and FG + + IF ( xstag ) THEN + istag = 0 + ioff = 1 + ELSE + istag = 1 + ioff = 0 END IF - END SUBROUTINE interp_fcn_bl + IF ( ystag ) THEN + jstag = 0 + joff = 1 + ELSE + jstag = 1 + joff = 0 + END IF -!================================== + ! Loop over each j-index on this tile for the nested domain. - FUNCTION v_interp_col ( cfld_orig , cprs_orig , ckms , ckme , ckte , nprs, ni, nj, nk, ci, cj, & - cfld_max_p , cmax_p , cfld_min_p , cmin_p ) RESULT ( cfld_interp ) + j_loop : DO nj = njts, MIN(njde-jstag,njte) - IMPLICIT NONE + ! This is the lower-left j-index of the CG. - INTEGER , INTENT(IN) :: ni, nj, nk, ci, cj - INTEGER , INTENT(IN) :: ckms , ckme , ckte - REAL , DIMENSION(ckms:ckme) , INTENT(IN) :: cfld_orig , cprs_orig - REAL , INTENT(IN) :: cfld_max_p , cmax_p , cfld_min_p , cmin_p - REAL , INTENT(IN) :: nprs - REAL :: cfld_interp + ! Example is 3:1 ratio, mass-point staggering. We have listed sixteen CG values + ! as an example: A through P. For a 3:1 ratio, each of these CG cells has + ! nine associated FG points. - ! Local + ! |=========|=========|=========|=========| + ! | - - - | - - - | - - - | - - - | + ! | | | | | + ! | - M - | - N d | - O - | - P - | + ! | | | | | + ! | - - - | - - - | - - - | - - - | + ! |=========|=========|=========|=========| + ! | - - - | - - - | - - - | - - - | + ! | | | | | + ! | - I - | - J c | - K - | - L - | + ! | | | | | + ! | - - - | - - - | - - - | - - - | + ! |=========|=========|=========|=========| + ! | - 1 2 | 3 4 5 | 6 7 8 | - - - | + ! | | | | | + ! | - E - | - F b | - G - | - H - | + ! | | | | | + ! | - - - | - - - | - - - | - - - | + ! |=========|=========|=========|=========| + ! | - - - | - - - | - - - | - - - | + ! | | | | | + ! | - A - | - B a | - C - | - D - | + ! | | | | | + ! | - - - | - - - | - - - | - - - | + ! |=========|=========|=========|=========| + + ! To interpolate to FG point 4, 5, or 6 we will use CG points: A through P. It is + ! sufficient to find the lower left corner of a 4-point interpolation, and then extend + ! each side by one unit. + + ! Here are the lower left hand corners of the following FG points: + ! 1 => E + ! 2 => E + ! 3 => E + ! 4 => F + ! 5 => F + ! 6 => F + ! 7 => G + ! 8 => G + + cj = compute_CGLL ( nj , jpos , nrj , jstag ) - INTEGER :: ck - LOGICAL :: found - CHARACTER(LEN=256) :: joe_mess - REAL , DIMENSION(ckms:ckme+1+1) :: cfld , cprs + ! Vertical dim of the nest domain. - ! Fill input arrays + k_loop : DO nk = nkts, nkte - cfld(1) = cfld_max_p - cprs(1) = cmax_p + ! Loop over each i-index on this tile for the nested domain. - cfld(ckte+2) = cfld_min_p - cprs(ckte+2) = cmin_p + i_loop : DO ni = nits, MIN(nide-istag,nite) + + ! The coarse grid location that is to the lower left of the FG point. - DO ck = ckms , ckte - cfld(ck+1) = cfld_orig(ck) - cprs(ck+1) = cprs_orig(ck) - END DO + ci = compute_CGLL ( ni , ipos , nri , istag ) - found = .FALSE. + ! To interpolate to point "*" (look in grid cell "F"): + ! 1. Use ABC to get a quadratic valid at "a" + ! Use BCD to get a quadratic valid at "a" + ! Average these to get the final value for "a" + ! 2. Use EFG to get a quadratic valid at "b" + ! Use FGH to get a quadratic valid at "b" + ! Average these to get the final value for "b" + ! 3. Use IJK to get a quadratic valid at "c" + ! Use JKL to get a quadratic valid at "c" + ! Average these to get the final value for "c" + ! 4. Use MNO to get a quadratic valid at "d" + ! Use NOP to get a quadratic valid at "d" + ! Average these to get the final value for "d" + ! 5. Use abc to get a quadratic valid at "*" + ! Use bcd to get a quadratic valid at "*" + ! Average these to get the final value for "*" - IF ( cprs(ckms) .LT. nprs ) THEN - cfld_interp = cfld(ckms) - RETURN - ELSE IF ( cprs(ckte+2) .GE. nprs ) THEN - cfld_interp = cfld(ckte+2) - RETURN - END IF + ! |=========|=========|=========|=========| + ! | - - - | - - - | - - - | - - - | + ! | | | | | + ! | - M - | - N d | - O - | - P - | + ! | | | | | + ! | - - - | - - - | - - - | - - - | + ! |=========|=========|=========|=========| + ! | - - - | - - - | - - - | - - - | + ! | | | | | + ! | - I - | - J c | - K - | - L - | + ! | | | | | + ! | - - - | - - - | - - - | - - - | + ! |=========|=========|=========|=========| + ! | - - - | - - * | - - - | - - - | + ! | | | | | + ! | - E - | - F b | - G - | - H - | + ! | | | | | + ! | - - - | - - - | - - - | - - - | + ! |=========|=========|=========|=========| + ! | - - - | - - - | - - - | - - - | + ! | | | | | + ! | - A - | - B a | - C - | - D - | + ! | | | | | + ! | - - - | - - - | - - - | - - - | + ! |=========|=========|=========|=========| - DO ck = ckms , ckte+1 - IF ( ( cprs(ck ) .GE. nprs ) .AND. & - ( cprs(ck+1) .LT. nprs ) ) THEN - cfld_interp = ( cfld(ck ) * ( nprs - cprs(ck+1) ) + & - cfld(ck+1) * ( cprs(ck) - nprs ) ) / & - ( cprs(ck) - cprs(ck+1) ) - RETURN - END IF - END DO + ! Overlapping quadratic interpolation. -print *,'Hey we should not be here' -print *,'nest pres to find = ',nprs -print *,'column of cg pres = ',cprs - CALL wrf_error_fatal ( 'ERROR -- vertical interpolation for nest interp cannot find trapping pressures' ) - - END FUNCTION v_interp_col + IF ( imask ( ni, nj ) .EQ. 1 ) THEN -!================================== -! this is the default function used in feedback. + ! I-direction location of "*" - SUBROUTINE copy_fcn ( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj ) ! nest ratios - USE module_configure - IMPLICIT NONE + nx = REAL(ni) + ! I-direction location of "A", "E", "I", "M" - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag + cxm1 = nest_loc_of_cg ( ci-1 , ipos , nri , ioff ) - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ),INTENT(IN) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN) :: imask + ! I-direction location of "B", "F", "J", "N" - ! Local + cxp0 = nest_loc_of_cg ( ci , ipos , nri , ioff ) - INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa - INTEGER :: icmin,icmax,jcmin,jcmax - INTEGER :: istag,jstag, ipoints,jpoints,ijpoints - INTEGER , PARAMETER :: passes = 2 - INTEGER spec_zone + ! I-direction location of "C", "G", "K", "O" - ! Loop over the coarse grid in the area of the fine mesh. Do not - ! process the coarse grid values that are along the lateral BC - ! provided to the fine grid. Since that is in the specified zone - ! for the fine grid, it should not be used in any feedback to the - ! coarse grid as it should not have changed. + cxp1 = nest_loc_of_cg ( ci+1 , ipos , nri , ioff ) - ! Due to peculiarities of staggering, it is simpler to handle the feedback - ! for the staggerings based upon whether it is a even ratio (2::1, 4::1, etc.) or - ! an odd staggering ratio (3::1, 5::1, etc.). + ! I-direction location of "D", "H", "L", "P" - ! Though there are separate grid ratios for the i and j directions, this code - ! is not general enough to handle aspect ratios .NE. 1 for the fine grid cell. - - ! These are local integer increments in the looping. Basically, istag=1 means - ! that we will assume one less point in the i direction. Note that ci and cj - ! have a maximum value that is decreased by istag and jstag, respectively. + cxp2 = nest_loc_of_cg ( ci+2 , ipos , nri , ioff ) - ! Horizontal momentum feedback is along the face, not within the cell. For a - ! 3::1 ratio, temperature would use 9 pts for feedback, while u and v use - ! only 3 points for feedback from the nest to the parent. + ! Value at "a" - CALL nl_get_spec_zone( 1 , spec_zone ) - istag = 1 ; jstag = 1 - IF ( xstag ) istag = 0 - IF ( ystag ) jstag = 0 + nfld_m1 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, cfld(ci-1,nk,cj-1), cfld(ci+0,nk,cj-1), cfld(ci+1,nk,cj-1), cfld(ci+2,nk,cj-1) ) - IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio + ! Value at "b" - IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN - DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) - nj = (cj-jpos)*nrj + jstag + 1 - DO ck = ckts, ckte - nk = ck - DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) - ni = (ci-ipos)*nri + istag + 1 - cfld( ci, ck, cj ) = 0. - DO ijpoints = 1 , nri * nrj - ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1 - jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1 - cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & - 1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints ) - END DO -! cfld( ci, ck, cj ) = 1./9. * & -! ( nfld( ni-1, nk , nj-1) + & -! nfld( ni , nk , nj-1) + & -! nfld( ni+1, nk , nj-1) + & -! nfld( ni-1, nk , nj ) + & -! nfld( ni , nk , nj ) + & -! nfld( ni+1, nk , nj ) + & -! nfld( ni-1, nk , nj+1) + & -! nfld( ni , nk , nj+1) + & -! nfld( ni+1, nk , nj+1) ) - ENDDO - ENDDO - ENDDO + nfld_p0 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, cfld(ci-1,nk,cj+0), cfld(ci+0,nk,cj+0), cfld(ci+1,nk,cj+0), cfld(ci+2,nk,cj+0) ) - ELSE IF ( ( xstag ) .AND. ( .NOT. ystag ) ) THEN - DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) - nj = (cj-jpos)*nrj + jstag + 1 - DO ck = ckts, ckte - nk = ck - DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) - ni = (ci-ipos)*nri + istag + 1 - cfld( ci, ck, cj ) = 0. - DO ijpoints = (nri+1)/2 , (nri+1)/2 + nri*(nri-1) , nri - ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1 - jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1 - cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & - 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints ) - END DO -! cfld( ci, ck, cj ) = 1./3. * & -! ( nfld( ni , nk , nj-1) + & -! nfld( ni , nk , nj ) + & -! nfld( ni , nk , nj+1) ) - ENDDO - ENDDO - ENDDO + ! Value at "c" - ELSE IF ( ( .NOT. xstag ) .AND. ( ystag ) ) THEN - DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) - nj = (cj-jpos)*nrj + jstag + 1 - DO ck = ckts, ckte - nk = ck - DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) - ni = (ci-ipos)*nri + istag + 1 - cfld( ci, ck, cj ) = 0. - DO ijpoints = ( nrj*nrj +1 )/2 - nrj/2 , ( nrj*nrj +1 )/2 - nrj/2 + nrj-1 - ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1 - jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1 - cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & - 1./REAL( nrj) * nfld( ni+ipoints , nk , nj+jpoints ) - END DO -! cfld( ci, ck, cj ) = 1./3. * & -! ( nfld( ni-1, nk , nj ) + & -! nfld( ni , nk , nj ) + & -! nfld( ni+1, nk , nj ) ) - ENDDO - ENDDO - ENDDO + nfld_p1 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, cfld(ci-1,nk,cj+1), cfld(ci+0,nk,cj+1), cfld(ci+1,nk,cj+1), cfld(ci+2,nk,cj+1) ) - END IF + ! Value at "d" - ! Even refinement ratio + nfld_p2 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, cfld(ci-1,nk,cj+2), cfld(ci+0,nk,cj+2), cfld(ci+1,nk,cj+2), cfld(ci+2,nk,cj+2) ) - ELSE IF ( MOD(nrj,2) .EQ. 0) THEN - IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN + ! J-direction location of "*" - ! This is a simple schematic of the feedback indexing used in the even - ! ratio nests. For simplicity, a 2::1 ratio is depicted. Only the - ! mass variable staggering is shown. - ! Each of - ! the boxes with a "T" and four small "t" represents a coarse grid (CG) - ! cell, that is composed of four (2::1 ratio) fine grid (FG) cells. - - ! Shown below is the area of the CG that is in the area of the FG. The - ! first grid point of the depicted CG is the starting location of the nest - ! in the parent domain (ipos,jpos - i_parent_start and j_parent_start from - ! the namelist). - - ! For each of the CG points, the feedback loop is over each of the FG points - ! within the CG cell. For a 2::1 ratio, there are four total points (this is - ! the ijpoints loop). The feedback value to the CG is the arithmetic mean of - ! all of the FG values within each CG cell. + ny = REAL(nj) -! |-------------||-------------| |-------------||-------------| -! | t t || t t | | t t || t t | -! jpos+ | || | | || | -! (njde-njds)- | T || T | | T || T | -! jstag | || | | || | -! | t t || t t | | t t || t t | -! |-------------||-------------| |-------------||-------------| -! |-------------||-------------| |-------------||-------------| -! | t t || t t | | t t || t t | -! | || | | || | -! | T || T | | T || T | -! | || | | || | -! | t t || t t | | t t || t t | -! |-------------||-------------| |-------------||-------------| -! -! ... -! ... -! ... -! ... -! ... + ! J-direction location of "A", "B", "C", "D" -! |-------------||-------------| |-------------||-------------| -! jpoints = 1 | t t || t t | | t t || t t | -! | || | | || | -! | T || T | | T || T | -! | || | | || | -! jpoints = 0, | t t || t t | | t t || t t | -! nj=3 |-------------||-------------| |-------------||-------------| -! |-------------||-------------| |-------------||-------------| -! jpoints = 1 | t t || t t | | t t || t t | -! | || | | || | -! jpos | T || T | ... | T || T | -! | || | ... | || | -! jpoints = 0, | t t || t t | ... | t t || t t | -! nj=1 |-------------||-------------| |-------------||-------------| -! ^ ^ -! | | -! | | -! ipos ipos+ -! ni = 1 3 (nide-nids)/nri -! ipoints= 0 1 0 1 -istag -! + cym1 = nest_loc_of_cg ( cj-1 , jpos , nrj , joff ) - ! For performance benefits, users can comment out the inner most loop (and cfld=0) and - ! hardcode the loop feedback. For example, it is set up to run a 2::1 ratio - ! if uncommented. This lacks generality, but is likely to gain timing benefits - ! with compilers unable to unroll inner loops that do not have parameterized sizes. - - ! The extra +1 ---------/ and the extra -1 ----\ (both for ci and cj) - ! / \ keeps the feedback out of the - ! / \ outer row/col, since that CG data - ! / \ specified the nest boundary originally - ! / \ This - ! / \ is just - ! / \ a sentence to not end a line - ! / \ with a stupid backslash - DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) - nj = (cj-jpos)*nrj + jstag - DO ck = ckts, ckte - nk = ck - DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) - ni = (ci-ipos)*nri + istag - cfld( ci, ck, cj ) = 0. - DO ijpoints = 1 , nri * nrj - ipoints = MOD((ijpoints-1),nri) - jpoints = (ijpoints-1)/nri - cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & - 1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints ) - END DO -! cfld( ci, ck, cj ) = 1./4. * & -! ( nfld( ni , nk , nj ) + & -! nfld( ni+1, nk , nj ) + & -! nfld( ni , nk , nj+1) + & -! nfld( ni+1, nk , nj+1) ) - END DO - END DO - END DO + ! J-direction location of "E", "F", "G", "H" - ! U + cyp0 = nest_loc_of_cg ( cj , jpos , nrj , joff ) - ELSE IF ( ( xstag ) .AND. ( .NOT. ystag ) ) THEN -! |---------------| -! | | -! jpoints = 1 u u | -! | | -! U | -! | | -! jpoints = 0, u u | -! nj=3 | | -! |---------------| -! |---------------| -! | | -! jpoints = 1 u u | -! | | -! jpos U | -! | | -! jpoints = 0, u u | -! nj=1 | | -! |---------------| -! -! ^ -! | -! | -! ipos -! ni = 1 3 -! ipoints= 0 1 0 -! + ! J-direction location of "I", "J", "K", "L" - DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) - nj = (cj-jpos)*nrj + 1 - DO ck = ckts, ckte - nk = ck - DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) - ni = (ci-ipos)*nri + 1 - cfld( ci, ck, cj ) = 0. - DO ijpoints = 1 , nri*nrj , nri - ipoints = MOD((ijpoints-1),nri) - jpoints = (ijpoints-1)/nri - cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & - 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints ) - END DO -! cfld( ci, ck, cj ) = 1./2. * & -! ( nfld( ni , nk , nj ) + & -! nfld( ni , nk , nj+1) ) - ENDDO - ENDDO - ENDDO + cyp1 = nest_loc_of_cg ( cj+1 , jpos , nrj , joff ) - ! V + ! J-direction location of "M", "N", "O", "P" - ELSE IF ( ( .NOT. xstag ) .AND. ( ystag ) ) THEN - DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) - nj = (cj-jpos)*nrj + 1 - DO ck = ckts, ckte - nk = ck - DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) - ni = (ci-ipos)*nri + 1 - cfld( ci, ck, cj ) = 0. - DO ijpoints = 1 , nri - ipoints = MOD((ijpoints-1),nri) - jpoints = (ijpoints-1)/nri - cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & - 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints ) - END DO -! cfld( ci, ck, cj ) = 1./2. * & -! ( nfld( ni , nk , nj ) + & -! nfld( ni+1, nk , nj ) ) - ENDDO - ENDDO - ENDDO - END IF - END IF + cyp2 = nest_loc_of_cg ( cj+2 , jpos , nrj , joff ) - RETURN + ! Value at "*" - END SUBROUTINE copy_fcn + nfld(ni,nk,nj) = lagrange_quad_avg ( ny, cym1, cyp0, cyp1, cyp2, nfld_m1, nfld_p0, nfld_p1, nfld_p2 ) -!================================== -! this is the 1pt function used in feedback. + END IF + + END DO i_loop + END DO k_loop + END DO j_loop + + END SUBROUTINE interp_fcn_lagr + +!================================================================================= + + REAL FUNCTION lagrange_quad ( x , x0, x1, x2, y0, y1, y2 ) + + IMPLICIT NONE + + REAL :: x , x0, x1, x2, y0, y1, y2 + + ! Lagrange = sum prod ( x - xj ) + ! i=0,n ( j=0,n --------- * yi ) + ! j<>i ( xi - xj ) + + ! For a quadratic, in the above equation, we are setting n=2. Three points + ! required for a quadratic, points x0, x1, x2 (hence n=2). + + lagrange_quad = & + (x-x1)*(x-x2)*y0 / ( (x0-x1)*(x0-x2) ) + & + (x-x0)*(x-x2)*y1 / ( (x1-x0)*(x1-x2) ) + & + (x-x0)*(x-x1)*y2 / ( (x2-x0)*(x2-x1) ) + + END FUNCTION lagrange_quad + +!================================================================================= + + REAL FUNCTION lagrange_quad_avg ( x , x0, x1, x2, x3, y0, y1, y2, y3 ) - SUBROUTINE copy_fcnm ( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj ) ! nest ratios - USE module_configure - USE module_wrf_error IMPLICIT NONE + REAL, EXTERNAL :: lagrange_quad + REAL :: x , x0, x1, x2, x3, y0, y1, y2, y3 - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag + ! Since there are three points required for a quadratic, we compute it twice + ! (once with x0, x1, x2 and once with x1, x2, x3), and then average those values. This will + ! reduce overshoot. The "x" point is where we are interpolating TO. + + ! x0 x1 x x2 + ! x1 x x2 x3 - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask + lagrange_quad_avg = & +! ( lagrange_quad ( x , x0, x1, x2, y0, y1, y2 ) + & +! lagrange_quad ( x , x1, x2, x3, y1, y2, y3 ) ) / & +! 2. + ( lagrange_quad ( x , x0, x1, x2, y0, y1, y2 ) * ( x2 - x ) + & + lagrange_quad ( x , x1, x2, x3, y1, y2, y3 ) * ( x - x1 ) ) / & + ( x2 - x1 ) - ! Local + END FUNCTION lagrange_quad_avg - INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa - INTEGER :: icmin,icmax,jcmin,jcmax - INTEGER :: istag,jstag, ipoints,jpoints,ijpoints - INTEGER , PARAMETER :: passes = 2 - INTEGER spec_zone +!================================================================================= - CALL nl_get_spec_zone( 1, spec_zone ) - istag = 1 ; jstag = 1 - IF ( xstag ) istag = 0 - IF ( ystag ) jstag = 0 + REAL FUNCTION nest_loc_of_cg ( ci , ipos , nri , ioff ) - IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio + ! I and J direction equations for mass and momentum values for even + ! and odd ratios: Given that the starting value of the nest in the + ! CG grid cell is defined as (1,1), what is the location of the CG + ! location in FG index units. Example, for a 2:1 ratio, the location + ! of the mass point T is 1.5 (3:1 ratio = 2, 4:1 ratio = 2.5, etc). + ! Note that for momentum points, the CG U point is defined as "1", the + ! same as the I-direction of the (1,1) location of the FG U point. + ! Same for V, but in the J-direction. - DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) - nj = (cj-jpos)*nrj + jstag + 1 - DO ck = ckts, ckte - nk = ck - DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) - ni = (ci-ipos)*nri + istag + 1 - cfld( ci, ck, cj ) = nfld( ni , nk , nj ) - ENDDO - ENDDO - ENDDO + IMPLICIT NONE - ELSE ! even refinement ratio, pick nearest neighbor on SW corner - DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) - nj = (cj-jpos)*nrj + 1 - DO ck = ckts, ckte - nk = ck - DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) - ni = (ci-ipos)*nri + 1 - ipoints = nri/2 -1 - jpoints = nrj/2 -1 - cfld( ci, ck, cj ) = nfld( ni+ipoints , nk , nj+jpoints ) - END DO - END DO - END DO + INTEGER :: ci , ipos , nri , ioff - END IF + nest_loc_of_cg = & + ( ci - ipos ) * nri + ( 1 - ioff ) * REAL ( nri + 1 ) / 2. + ioff - RETURN + END FUNCTION nest_loc_of_cg - END SUBROUTINE copy_fcnm +!================================================================================= -!================================== -! this is the 1pt function used in feedback for integers + FUNCTION compute_CGLL ( ni , ipos , nri , istag ) RESULT ( CGLL_loc ) - SUBROUTINE copy_fcni ( cfld, & ! CD field + IMPLICIT NONE + + INTEGER , INTENT(IN ) :: ni , ipos , nri , istag + INTEGER :: CGLL_loc + + ! Local vars + + INTEGER :: starting_position , increments_of_CG_cells + INTEGER :: location_of_LL_wrt_this_CG + INTEGER :: ioff + INTEGER , PARAMETER :: MOMENTUM_STAG = 0 + INTEGER , PARAMETER :: MASS_POINT_STAG = 1 + + starting_position = ipos + increments_of_CG_cells = ( ni - 1 ) / nri + ioff = MOD ( nri , 2 ) + + IF ( istag .EQ. MOMENTUM_STAG ) THEN + location_of_LL_wrt_this_CG = MOD ( ( ni - 1 ) , nri ) / ( nri + ioff ) - istag ! zero + ELSE IF ( istag .EQ. MASS_POINT_STAG ) THEN + location_of_LL_wrt_this_CG = ( MOD ( ( ni - 1 ) , nri ) + ioff ) / ( ( nri + ioff ) / 2 ) - istag + ELSE + CALL wrf_error_fatal ( 'Hold on there pard, there are only two staggerings I accept.' ) + END IF + + CGLL_loc = starting_position + increments_of_CG_cells + location_of_LL_wrt_this_CG +! WRITE ( 6 , '(a,i4, i4, i4, i4)') 'ni ipos nri stag', ni, ipos, nri, istag +! WRITE ( 6 , '(a,i4, i4, i4, i4)') 'strt inc loc CGLL', starting_position , increments_of_CG_cells , location_of_LL_wrt_this_CG , CGLL_loc +! print *,' ' + + END FUNCTION compute_CGLL + +!================================================================================= + +! Smolarkiewicz positive definite, monotonic transport. + + SUBROUTINE interp_fcn_sint ( cfld, & ! CD field cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -938,9 +665,8 @@ SUBROUTINE copy_fcni ( cfld, & ! CD field ipos, jpos, & ! Position of lower left of nest in CD nri, nrj ) ! nest ratios USE module_configure - USE module_wrf_error - IMPLICIT NONE + IMPLICIT NONE INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & @@ -953,73 +679,116 @@ SUBROUTINE copy_fcni ( cfld, & ! CD field nri, nrj LOGICAL, INTENT(IN) :: xstag, ystag - INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld - INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask ! Local - INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa - INTEGER :: icmin,icmax,jcmin,jcmax - INTEGER :: istag,jstag, ipoints,jpoints,ijpoints - INTEGER , PARAMETER :: passes = 2 - INTEGER spec_zone + INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, nioff, njoff + INTEGER nfx, ior + PARAMETER (ior=2) + INTEGER nf + REAL psca(cims:cime,cjms:cjme,nri*nrj) + LOGICAL icmask( cims:cime, cjms:cjme ) + INTEGER i,j,k + INTEGER nrio2, nrjo2 - CALL nl_get_spec_zone( 1, spec_zone ) - istag = 1 ; jstag = 1 - IF ( xstag ) istag = 0 - IF ( ystag ) jstag = 0 + ! Iterate over the ND tile and compute the values + ! from the CD tile. - IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio + ioff = 0 ; joff = 0 + nioff = 0 ; njoff = 0 + IF ( xstag ) THEN + ioff = (nri-1)/2 + nioff = nri + ENDIF + IF ( ystag ) THEN + joff = (nrj-1)/2 + njoff = nrj + ENDIF - DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) - nj = (cj-jpos)*nrj + jstag + 1 - DO ck = ckts, ckte - nk = ck - DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) - ni = (ci-ipos)*nri + istag + 1 - cfld( ci, ck, cj ) = nfld( ni , nk , nj ) - ENDDO - ENDDO - ENDDO + nrio2 = nri/2 + nrjo2 = nrj/2 - ELSE ! even refinement ratio - DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) - nj = (cj-jpos)*nrj + 1 - DO ck = ckts, ckte - nk = ck - DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) - ni = (ci-ipos)*nri + 1 - ipoints = nri/2 -1 - jpoints = nrj/2 -1 - cfld( ci, ck, cj ) = nfld( ni+ipoints , nk , nj+jpoints ) - END DO - END DO - END DO + nfx = nri * nrj + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i,j,k,ni,nj,ci,cj,ip,jp,nk,ck,nf,icmask,psca ) + DO k = ckts, ckte + icmask = .FALSE. + DO nf = 1,nfx + DO j = cjms,cjme + nj = (j-jpos) * nrj + ( nrjo2 + 1 ) ! j point on nest + DO i = cims,cime + ni = (i-ipos) * nri + ( nrio2 + 1 ) ! i point on nest + if ( ni .ge. nits-nioff-nrio2 .and. & + ni .le. nite+nioff+nrio2 .and. & + nj .ge. njts-njoff-nrjo2 .and. & + nj .le. njte+njoff+nrjo2 ) then + if ( ni.ge.nims.and.ni.le.nime.and.nj.ge.njms.and.nj.le.njme) then + if ( imask(ni,nj) .eq. 1 ) then + icmask( i, j ) = .TRUE. + endif + endif + if ( ni-nioff.ge.nims.and.ni.le.nime.and.nj-njoff.ge.njms.and.nj.le.njme) then + if (ni .ge. nits-nioff .and. nj .ge. njts-njoff ) then + if ( imask(ni-nioff,nj-njoff) .eq. 1) then + icmask( i, j ) = .TRUE. + endif + endif + endif + endif + psca(i,j,nf) = cfld(i,k,j) + ENDDO ! i + ENDDO ! j + ENDDO ! nf - END IF +! tile dims in this call to sint are 1-over to account for the fact +! that the number of cells on the nest local subdomain is not +! necessarily a multiple of the nest ratio in a given dim. +! this could be a little less ham-handed. - RETURN + CALL sint( psca, & + cims, cime, cjms, cjme, icmask, & + cits-1, cite+1, cjts-1, cjte+1, nrj*nri, xstag, ystag ) - END SUBROUTINE copy_fcni + DO nj = njts, njte+joff + cj = jpos + (nj-1) / nrj ! j coord of CD point + jp = mod ( nj-1 , nrj ) ! coord of ND w/i CD point + nk = k + ck = nk + DO ni = nits, nite+ioff + ci = ipos + (ni-1) / nri ! i coord of CD point + ip = mod ( ni-1 , nri ) ! coord of ND w/i CD point + if ( ( ni-ioff .ge. nits ) .and. ( nj-joff .ge. njts ) ) then + if ( imask ( ni, nj ) .eq. 1 .or. imask ( ni-ioff, nj-joff ) .eq. 1 ) then + nfld( ni-ioff, nk, nj-joff ) = psca( ci , cj, ip+1 + (jp)*nri ) + endif + endif + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO -!================================== + END SUBROUTINE interp_fcn_sint - SUBROUTINE p2c ( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj & ! nest ratios - ) - USE module_configure +!========================================================================= + +! Nearest neighbor interpolation. + + SUBROUTINE interp_fcn_nn ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios IMPLICIT NONE INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & @@ -1031,146 +800,63 @@ SUBROUTINE p2c ( cfld, & ! CD field shw, & ipos, jpos, & nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - CALL interp_fcn (cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj ) ! nest ratios + INTEGER ci, cj, ck, ni, nj, nk - END SUBROUTINE p2c + ! Iterate over the ND tile and assign the values + ! from the CD tile. This is a trivial implementation + ! of the interp_fcn; just copies the values from the CD into the ND -!================================== + DO nj = njts, njte + cj = jpos + (nj-1) / nrj ! j coord of CD point + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + if ( imask ( ni, nj ) .eq. 1 ) then + ci = ipos + (ni-1) / nri ! i coord of CD point + nfld( ni, nk, nj ) = cfld( ci , ck , cj ) + endif + ENDDO + ENDDO + ENDDO - SUBROUTINE c2f_interp ( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios -! cbdy_xs, nbdy_xs, & -! cbdy_xe, nbdy_xe, & -! cbdy_ys, nbdy_ys, & -! cbdy_ye, nbdy_ye, & -! cbdy_txs, nbdy_txs, & -! cbdy_txe, nbdy_txe, & -! cbdy_tys, nbdy_tys, & -! cbdy_tye, nbdy_tye, & - parent_id,nest_id &!cyl - ) ! boundary arrays - USE module_configure - IMPLICIT NONE - -!------------------------------------------------------------ -! Subroutine c2f_interp interpolate field from coarse resolution domain -! to its nested domain. It is written by Dave Gill in NCAR for the purpose -! running phys/module_sf_oml.F-DPWP in only d01 and d02 -! Chiaying Lee RSMAS/UM -!------------------------------------------------------------ - - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj,parent_id,nest_id !cyl - - LOGICAL, INTENT(IN) :: xstag, ystag - - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask -! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs, nbdy_xs, nbdy_txs -! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe, nbdy_xe, nbdy_txe -! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys, nbdy_ys, nbdy_tys -! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye, nbdy_ye, nbdy_tye - REAL cdt, ndt - - ! Local - - INTEGER ci, cj, ck, ni, nj, nk, ip, jp - - ! Iterate over the ND tile and compute the values - ! from the CD tile. - -!write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte -!write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte -! write(0,*)'cyl parentid',parent_id -! write(0,*)'cyl nestid',nest_id -! If ( nest_id .le. 2 .and. (1.0/rdx .ge. 3000.0 .and. 1.0/rdy .ge. 3000.0) ) then ! cyl: only run it in the nest domain with dx, dy < 3 km - If ( nest_id .eq. 3 ) then - DO nj = njts, njte - - cj = jpos + (nj-1) / nrj ! j coord of CD point - jp = mod ( nj , nrj ) ! coord of ND w/i CD point - DO nk = nkts, nkte - ck = nk - DO ni = nits, nite - ci = ipos + (ni-1) / nri ! j coord of CD point - ip = mod ( ni , nri ) ! coord of ND w/i CD point - ! This is a trivial implementation of the interp_fcn; just copies - ! the values from the CD into the ND - nfld( ni, nk, nj ) = cfld( ci , ck , cj ) - ENDDO - ENDDO - ENDDO - ENDIF ! cyl - RETURN + END SUBROUTINE interp_fcn_nn - END SUBROUTINE c2f_interp +!========================================================================= -!================================== + SUBROUTINE interp_fcn_bl ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! Nest ratio, i- and j-directions + cht, nht, & ! topography for CG and FG + ct_max_p,nt_max_p, & ! temperature (K) at max press, want CG value + cght_max_p,nght_max_p, & ! height (m) at max press, want CG value + cmax_p,nmax_p, & ! max pressure (Pa) in column, want CG value + ct_min_p,nt_min_p, & ! temperature (K) at min press, want CG value + cght_min_p,nght_min_p, & ! height (m) at min press, want CG value + cmin_p,nmin_p, & ! min pressure (Pa) in column, want CG value + zn, p_top ) ! eta levels + USE module_timing +! USE module_configure + USE module_model_constants , ONLY : g , r_d, cp, p1000mb, t0 - SUBROUTINE bdy_interp ( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - cbdy_xs, nbdy_xs, & - cbdy_xe, nbdy_xe, & - cbdy_ys, nbdy_ys, & - cbdy_ye, nbdy_ye, & - cbdy_txs, nbdy_txs, & - cbdy_txe, nbdy_txe, & - cbdy_tys, nbdy_tys, & - cbdy_tye, nbdy_tye, & - cdt, ndt & - ) ! boundary arrays - USE module_configure IMPLICIT NONE + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -1180,388 +866,318 @@ SUBROUTINE bdy_interp ( cfld, & ! CD field shw, & ipos, jpos, & nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs, nbdy_xs, nbdy_txs - REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe, nbdy_xe, nbdy_txe - REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys, nbdy_ys, nbdy_tys - REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye, nbdy_ye, nbdy_tye - REAL cdt, ndt + REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cht, ct_max_p, cght_max_p, cmax_p, ct_min_p, cght_min_p, cmin_p + REAL, DIMENSION ( nims:nime, njms:njme ) :: nht, nt_max_p, nght_max_p, nmax_p, nt_min_p, nght_min_p, nmin_p + REAL, DIMENSION ( ckms:ckme ) :: zn + REAL :: p_top + REAL, EXTERNAL :: v_interp_col ! Local - INTEGER nijds, nijde, spec_bdy_width - - nijds = min(nids, njds) - nijde = max(nide, njde) - CALL nl_get_spec_bdy_width( 1, spec_bdy_width ) + INTEGER ci, cj, ni, nj, nk, istag, jstag, i, j, k + REAL :: wx, wy, nprs, cfld_ll, cfld_lr, cfld_ul, cfld_ur + REAL , DIMENSION(ckms:ckme) :: cprs + REAL :: p00 , t00 , a , tiso , p_surf - CALL bdy_interp1( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nijds, nijde , spec_bdy_width , & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, imask, & - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & - cbdy_xs, nbdy_xs, & - cbdy_xe, nbdy_xe, & - cbdy_ys, nbdy_ys, & - cbdy_ye, nbdy_ye, & - cbdy_txs, nbdy_txs, & - cbdy_txe, nbdy_txe, & - cbdy_tys, nbdy_tys, & - cbdy_tye, nbdy_tye, & - cdt, ndt & - ) + ! Yes, memory sized to allow "outside the tile" indexing for horiz interpolation. This + ! is really an intermediate domain that has quite a bit of usable real estate surrounding + ! the tile dimensions. - RETURN + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cpb + + ! A bit larger than tile sized to allow horizontal interpolation on the CG. - END SUBROUTINE bdy_interp + REAL, DIMENSION ( cits-2:cite+2, cjts-2:cjte+2 ) :: cfld_max_p, cfld_min_p - SUBROUTINE bdy_interp1( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nijds, nijde, spec_bdy_width , & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw1, & - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & - cbdy_xs, bdy_xs, & - cbdy_xe, bdy_xe, & - cbdy_ys, bdy_ys, & - cbdy_ye, bdy_ye, & - cbdy_txs, bdy_txs, & - cbdy_txe, bdy_txe, & - cbdy_tys, bdy_tys, & - cbdy_tye, bdy_tye, & - cdt, ndt & - ) + ! The usual tile size for the FG local array. - USE module_configure - use module_state_description - IMPLICIT NONE + REAL, DIMENSION ( nits:nite, nkts:nkte, njts:njte ) :: npb - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw1, & ! ignore - ipos, jpos, & - nri, nrj - INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width - LOGICAL, INTENT(IN) :: xstag, ystag + ! Get base state constants - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs ! not used - REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe ! not used - REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys ! not used - REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye ! not used - REAL :: cdt, ndt - REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xs, bdy_txs - REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xe, bdy_txe - REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ys, bdy_tys - REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ye, bdy_tye + CALL nl_get_base_pres ( 1 , p00 ) + CALL nl_get_base_temp ( 1 , t00 ) + CALL nl_get_base_lapse ( 1 , a ) + CALL nl_get_iso_temp ( 1 , tiso ) - ! Local + ! This stag stuff is to keep us away from the outer most row + ! and column for the unstaggered directions. We are going to + ! consider "U" an xstag variable and "V" a ystag variable. The + ! vertical staggering is handled in the actual arguments. The + ! ckte and nkte are the ending vertical dimensions for computations + ! for this particular variable. - REAL*8 rdt - INTEGER ci, cj, ck, ni, nj, nk, ni1, nj1, nk1, ip, jp, ioff, joff -#ifdef MM5_SINT - INTEGER nfx, ior - PARAMETER (ior=2) - INTEGER nf - REAL psca1(cims:cime,cjms:cjme,nri*nrj) - REAL psca(cims:cime,cjms:cjme,nri*nrj) - LOGICAL icmask( cims:cime, cjms:cjme ) - INTEGER i,j,k -#endif - INTEGER shw - INTEGER spec_zone - INTEGER relax_zone - INTEGER sz - INTEGER n2ci,n - INTEGER n2cj + IF ( xstag ) THEN + istag = 0 + ELSE + istag = 1 + END IF -! statement functions for converting a nest index to coarse - n2ci(n) = (n+ipos*nri-1)/nri - n2cj(n) = (n+jpos*nrj-1)/nrj + IF ( ystag ) THEN + jstag = 0 + ELSE + jstag = 1 + END IF - rdt = 1.D0/cdt - - shw = 0 + ! Compute the reference pressure for the CG, function only of constants and elevation. + ! We extend the i,j range to allow us to do horizontal interpolation. We only need + ! one extra grid cell surrounding the nest, and the intermediate domain has plenty of + ! room with the halos set up for higher-order interpolations. For intermediate domains, + ! it turns out that the "domain" size actually fits within the "tile" size. Yeppers, + ! that is backwards from what usually happens. That intermediate domain size is a couple + ! grid points larger than necessary, and the tile is a couple of grid cells larger still. + ! For our low-order interpolation, we can use the tile size for the CG, and we will have + ! plenty of data on our boundaries. - ioff = 0 ; joff = 0 - IF ( xstag ) THEN - ioff = MAX((nri-1)/2,1) - ENDIF - IF ( ystag ) THEN - joff = MAX((nrj-1)/2,1) - ENDIF + DO j = cjts-2 , cjte+2 + DO i = cits-2 , cite+2 + p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*cht(i,j)/a/r_d ) **0.5 ) + DO k = ckts , ckte + cpb(i,k,j) = zn(k)*(p_surf - p_top) + p_top + END DO + IF ( ckte .EQ. ckme ) THEN + cfld_max_p(i,j) = cght_max_p(i,j) * g + cfld_min_p(i,j) = cght_min_p(i,j) * g + ELSE + cfld_max_p(i,j) = ct_max_p(i,j) * (p1000mb/cmax_p(i,j))**(r_d/cp) - t0 + cfld_min_p(i,j) = ct_min_p(i,j) * (p1000mb/cmin_p(i,j))**(r_d/cp) - t0 + END IF + END DO + END DO - ! Iterate over the ND tile and compute the values - ! from the CD tile. + ! Compute the reference pressure for the FG. This is actually the size of the entire + ! domain, not some chopped down piece of intermediate domain, as in the parent + ! grid. We do the traditional MAX(dom end -1,tile end), since we know a priori that the + ! pressure is a mass point field (because the topo elevation is a mass point field). -#ifdef MM5_SINT - CALL nl_get_spec_zone( 1, spec_zone ) - CALL nl_get_relax_zone( 1, relax_zone ) - sz = MIN(MAX( spec_zone, relax_zone + 1 ),spec_bdy_width) + DO j = njts , MIN(njde-1,njte) + DO i = nits , MIN(nide-1,nite) + p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*nht(i,j)/a/r_d ) **0.5 ) + DO k = nkts , nkte + npb(i,k,j) = zn(k)*(p_surf - p_top) + p_top + END DO + END DO + END DO - nfx = nri * nrj + ! Loop over each j-index on this tile for the nested domain. - !$OMP PARALLEL DO & - !$OMP PRIVATE ( i,j,k,ni,nj,ni1,nj1,ci,cj,ip,jp,nk,ck,nf,icmask,psca,psca1 ) - DO k = ckts, ckte + j_loop : DO nj = njts, MIN(njde-jstag,njte) - DO nf = 1,nfx - DO j = cjms,cjme - nj = (j-jpos) * nrj + ( nrj / 2 + 1 ) ! j point on nest - DO i = cims,cime - ni = (i-ipos) * nri + ( nri / 2 + 1 ) ! i point on nest - psca1(i,j,nf) = cfld(i,k,j) - ENDDO - ENDDO - ENDDO -! hopefully less ham handed but still correct and more efficient -! sintb ignores icmask so it does not matter that icmask is not set -! -! SOUTH BDY - IF ( njts .ge. njds .and. njts .le. njds + sz + joff ) THEN - CALL sintb( psca1, psca, & - cims, cime, cjms, cjme, icmask, & - n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njds)), n2cj(MIN(njte,njds+sz+joff)), nrj*nri, xstag, ystag ) - ENDIF -! NORTH BDY - IF ( njte .le. njde .and. njte .ge. njde - sz - joff ) THEN - CALL sintb( psca1, psca, & - cims, cime, cjms, cjme, icmask, & - n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njde-sz-joff)), n2cj(MIN(njte,njde-1+joff)), nrj*nri, xstag, ystag ) - ENDIF -! WEST BDY - IF ( nits .ge. nids .and. nits .le. nids + sz + ioff ) THEN - CALL sintb( psca1, psca, & - cims, cime, cjms, cjme, icmask, & - n2ci(MAX(nits,nids)), n2ci(MIN(nite,nids+sz+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag ) - ENDIF -! EAST BDY - IF ( nite .le. nide .and. nite .ge. nide - sz - ioff ) THEN - CALL sintb( psca1, psca, & - cims, cime, cjms, cjme, icmask, & - n2ci(MAX(nits,nide-sz-ioff)), n2ci(MIN(nite,nide-1+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag ) - ENDIF + ! This is the lower-left j-index of the CG. - DO nj1 = MAX(njds,njts-1), MIN(njde+joff,njte+joff+1) - cj = jpos + (nj1-1) / nrj ! j coord of CD point - jp = mod ( nj1-1 , nrj ) ! coord of ND w/i CD point - nk = k - ck = nk - DO ni1 = MAX(nids,nits-1), MIN(nide+ioff,nite+ioff+1) - ci = ipos + (ni1-1) / nri ! j coord of CD point - ip = mod ( ni1-1 , nri ) ! coord of ND w/i CD point + ! Example is 3:1 ratio, mass-point staggering. We have listed six CG values + ! as an example: A, B, C, D, E, F. For a 3:1 ratio, each of these CG cells has + ! nine associated FG points. + ! |=========|=========|=========| + ! | - - - | - - - | - - - | + ! | | | | + ! | - D - | - E - | - F - | + ! | | | | + ! | 1 2 3 | 4 5 6 | 7 8 9 | + ! |=========|=========|=========| + ! | - - - | - - - | - - - | + ! | | | | + ! | - A - | - B - | - C - | + ! | | | | + ! | - - - | - - - | - - - | + ! |=========|=========|=========| + ! To interpolate to FG point 4, we will use CG points: A, B, D, E. It is adequate to + ! find the lower left point. The lower left (LL) point for "4" is "A". Below + ! are a few more points. + ! 2 => A + ! 3 => A + ! 4 => A + ! 5 => B + ! 6 => B + ! 7 => B + ! We want an equation that returns the CG LL: + ! CG LL = ipos (the starting point of the nest in the CG) + ! + (ni-1)/nri (gives us the CG cell, based on the nri-groups of FG cells + ! - istag (a correction term, this is either zero for u in the x-dir, + ! since we are doing an "i" example, or 1 for anything else) + ! + (MOD(ni-1,nri)+1 + nri/2)/nri (gives us specifically related CG point for each of the nri + ! FG points, for example, we want points "1", "4", and "7" all + ! to point to the CG at the left for the LL point) + ! For grid points 4, 5, 6, we want the CG LL (sans the first two terms) to be -1, 0, 0 (which + ! means that the CG point for "4" is to the left, and the CG LL point for "5" and "6" + ! is in the current CG index. - ni = ni1-ioff - nj = nj1-joff + cj = jpos + (nj-1)/nrj - jstag + (MOD(nj-1,nrj)+1 + nrj/2)/nrj - IF ( ( ni.LT.nids) .OR. (nj.LT.njds) ) THEN - CYCLE - END IF -!bdy contains the value at t-dt. psca contains the value at t -!compute dv/dt and store in bdy_t -!afterwards store the new value of v at t into bdy - ! WEST - IF ( ni .ge. nids .and. ni .lt. nids + sz ) THEN - bdy_txs( nj,k,ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_xs( nj,k,ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) - ENDIF + ! What is the weighting for this CG point to the FG point, j-weight only. - ! SOUTH - IF ( nj .ge. njds .and. nj .lt. njds + sz ) THEN - bdy_tys( ni,k,nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_ys( ni,k,nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) - ENDIF + IF ( ystag ) THEN + wy = 1. - ( REAL(MOD(nj+(nrj-1)/2,nrj)) / REAL(nrj) + 1. / REAL (2 * nrj) ) + ELSE + wy = 1. - ( REAL(MOD(nj+(nrj-1)/2,nrj)) / REAL(nrj) ) + END IF - ! EAST - IF ( xstag ) THEN - IF ( ni .ge. nide - sz + 1 .AND. ni .le. nide ) THEN - bdy_txe( nj,k,nide-ni+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_xe( nj,k,nide-ni+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) - ENDIF - ELSE - IF ( ni .ge. nide - sz .AND. ni .le. nide-1 ) THEN - bdy_txe( nj,k,nide-ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_xe( nj,k,nide-ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) - ENDIF - ENDIF + ! Vertical dim of the nest domain. - ! NORTH - IF ( ystag ) THEN - IF ( nj .ge. njde - sz + 1 .AND. nj .le. njde ) THEN - bdy_tye( ni,k,njde-nj+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_ye( ni,k,njde-nj+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) - ENDIF - ELSE - IF ( nj .ge. njde - sz .AND. nj .le. njde-1 ) THEN - bdy_tye(ni,k,njde-nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_ye( ni,k,njde-nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) - ENDIF - ENDIF + k_loop : DO nk = nkts, nkte - ENDDO - ENDDO - ENDDO - !$OMP END PARALLEL DO -#endif + ! Loop over each i-index on this tile for the nested domain. - RETURN + i_loop : DO ni = nits, MIN(nide-istag,nite) + + ! The coarse grid location that is to the lower left of the FG point. - END SUBROUTINE bdy_interp1 + ci = ipos + (ni-1)/nri - istag + (MOD(ni-1,nri)+1 + nri/2)/nri + ! Weights in the x-direction. + IF ( xstag ) THEN + wx = 1. - ( REAL(MOD(ni+(nri-1)/2,nri)) / REAL(nri) + 1. / REAL (2 * nri) ) + ELSE + wx = 1. - ( REAL(MOD(ni+(nri-1)/2,nri)) / REAL(nri) ) + END IF - SUBROUTINE interp_fcni( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj ) ! nest ratios - USE module_configure - IMPLICIT NONE + ! The pressure of the FG point. + IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN + nprs = npb( ni , nk , nj ) + ELSE IF ( xstag ) THEN + nprs = ( npb( ni-1, nk , nj ) + npb( ni , nk , nj ) ) * 0.5 + ELSE IF ( ystag ) THEN + nprs = ( npb( ni , nk , nj-1) + npb( ni , nk , nj ) ) * 0.5 + END IF - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag + ! The four surrounding CG values. - INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN + cprs(:) = cpb(ci ,:,cj ) + cfld_ll = v_interp_col ( cfld(ci ,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj , & + cfld_max_p(ci ,cj ) , cmax_p(ci ,cj ) , cfld_min_p(ci ,cj ) , cmin_p(ci ,cj ) ) + cprs(:) = cpb(ci+1,:,cj ) + cfld_lr = v_interp_col ( cfld(ci+1,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj , & + cfld_max_p(ci+1,cj ) , cmax_p(ci+1,cj ) , cfld_min_p(ci+1,cj ) , cmin_p(ci+1,cj ) ) + cprs(:) = cpb(ci ,:,cj+1) + cfld_ul = v_interp_col ( cfld(ci ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj+1, & + cfld_max_p(ci ,cj+1) , cmax_p(ci ,cj+1) , cfld_min_p(ci ,cj+1) , cmin_p(ci ,cj+1) ) + cprs(:) = cpb(ci+1,:,cj+1) + cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, & + cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) ) - ! Local + ELSE IF ( xstag ) THEN + cprs(:) = ( cpb(ci ,:,cj ) + cpb(ci-1,:,cj ) )*0.5 + cfld_ll = v_interp_col ( cfld(ci ,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj , & + cfld_max_p(ci ,cj ) , cmax_p(ci ,cj ) , cfld_min_p(ci ,cj ) , cmin_p(ci ,cj ) ) + cprs(:) = ( cpb(ci+1,:,cj ) + cpb(ci ,:,cj ) )*0.5 + cfld_lr = v_interp_col ( cfld(ci+1,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj , & + cfld_max_p(ci+1,cj ) , cmax_p(ci+1,cj ) , cfld_min_p(ci+1,cj ) , cmin_p(ci+1,cj ) ) + cprs(:) = ( cpb(ci ,:,cj+1) + cpb(ci-1,:,cj+1) )*0.5 + cfld_ul = v_interp_col ( cfld(ci ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj+1, & + cfld_max_p(ci ,cj+1) , cmax_p(ci ,cj+1) , cfld_min_p(ci ,cj+1) , cmin_p(ci ,cj+1) ) + cprs(:) = ( cpb(ci+1,:,cj+1) + cpb(ci ,:,cj+1) )*0.5 + cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, & + cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) ) + ELSE IF ( ystag ) THEN + cprs(:) = ( cpb(ci ,:,cj ) + cpb(ci ,:,cj-1) )*0.5 + cfld_ll = v_interp_col ( cfld(ci ,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj , & + cfld_max_p(ci ,cj ) , cmax_p(ci ,cj ) , cfld_min_p(ci ,cj ) , cmin_p(ci ,cj ) ) + cprs(:) = ( cpb(ci+1,:,cj ) + cpb(ci+1,:,cj-1) )*0.5 + cfld_lr = v_interp_col ( cfld(ci+1,:,cj ) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj , & + cfld_max_p(ci+1,cj ) , cmax_p(ci+1,cj ) , cfld_min_p(ci+1,cj ) , cmin_p(ci+1,cj ) ) + cprs(:) = ( cpb(ci ,:,cj+1) + cpb(ci ,:,cj ) )*0.5 + cfld_ul = v_interp_col ( cfld(ci ,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci , cj+1, & + cfld_max_p(ci ,cj+1) , cmax_p(ci ,cj+1) , cfld_min_p(ci ,cj+1) , cmin_p(ci ,cj+1) ) + cprs(:) = ( cpb(ci+1,:,cj+1) + cpb(ci+1,:,cj ) )*0.5 + cfld_ur = v_interp_col ( cfld(ci+1,:,cj+1) , cprs(:) , ckms , ckme , ckte, nprs, ni, nj, nk, ci+1, cj+1, & + cfld_max_p(ci+1,cj+1) , cmax_p(ci+1,cj+1) , cfld_min_p(ci+1,cj+1) , cmin_p(ci+1,cj+1) ) + END IF - INTEGER ci, cj, ck, ni, nj, nk, ip, jp + ! Bilinear interpolation in horizontal with vertically corrected CG field values. - ! Iterate over the ND tile and compute the values - ! from the CD tile. + nfld( ni , nk , nj ) = wy * ( cfld_ll * wx + cfld_lr * (1.-wx) ) + & + (1.-wy) * ( cfld_ul * wx + cfld_ur * (1.-wx) ) -!write(0,'("cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte -!write(0,'("nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte + END DO i_loop + END DO k_loop + END DO j_loop - DO nj = njts, njte - cj = jpos + (nj-1) / nrj ! j coord of CD point - jp = mod ( nj , nrj ) ! coord of ND w/i CD point - DO nk = nkts, nkte - ck = nk + ! If this is ph_2, make the values at k=1 all zero + + IF ( ckme .EQ. ckte ) THEN + DO nj = njts,njte DO ni = nits, nite - if ( imask(ni,nj) .NE. 1 ) cycle - ci = ipos + (ni-1) / nri ! j coord of CD point - ip = mod ( ni , nri ) ! coord of ND w/i CD point - ! This is a trivial implementation of the interp_fcn; just copies - ! the values from the CD into the ND - nfld( ni, nk, nj ) = cfld( ci , ck , cj ) - ENDDO - ENDDO - ENDDO + nfld(ni,nkts,nj) = 0.0 + END DO + END DO + END IF - RETURN + END SUBROUTINE interp_fcn_bl - END SUBROUTINE interp_fcni +!================================== - SUBROUTINE interp_fcnm( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj ) ! nest ratios - USE module_configure - IMPLICIT NONE + FUNCTION v_interp_col ( cfld_orig , cprs_orig , ckms , ckme , ckte , nprs, ni, nj, nk, ci, cj, & + cfld_max_p , cmax_p , cfld_min_p , cmin_p ) RESULT ( cfld_interp ) + IMPLICIT NONE - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag + INTEGER , INTENT(IN) :: ni, nj, nk, ci, cj + INTEGER , INTENT(IN) :: ckms , ckme , ckte + REAL , DIMENSION(ckms:ckme) , INTENT(IN) :: cfld_orig , cprs_orig + REAL , INTENT(IN) :: cfld_max_p , cmax_p , cfld_min_p , cmin_p + REAL , INTENT(IN) :: nprs + REAL :: cfld_interp - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + ! Local - ! Local + INTEGER :: ck + LOGICAL :: found + CHARACTER(LEN=256) :: joe_mess + REAL , DIMENSION(ckms:ckme+1+1) :: cfld , cprs - INTEGER ci, cj, ck, ni, nj, nk, ip, jp + ! Fill input arrays - ! Iterate over the ND tile and compute the values - ! from the CD tile. + cfld(1) = cfld_max_p + cprs(1) = cmax_p -!write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte -!write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte + cfld(ckte+2) = cfld_min_p + cprs(ckte+2) = cmin_p - DO nj = njts, njte - cj = jpos + (nj-1) / nrj ! j coord of CD point - jp = mod ( nj , nrj ) ! coord of ND w/i CD point - DO nk = nkts, nkte - ck = nk - DO ni = nits, nite - ci = ipos + (ni-1) / nri ! j coord of CD point - ip = mod ( ni , nri ) ! coord of ND w/i CD point - ! This is a trivial implementation of the interp_fcn; just copies - ! the values from the CD into the ND - nfld( ni, nk, nj ) = cfld( ci , ck , cj ) - ENDDO - ENDDO - ENDDO + DO ck = ckms , ckte + cfld(ck+1) = cfld_orig(ck) + cprs(ck+1) = cprs_orig(ck) + END DO - RETURN + found = .FALSE. - END SUBROUTINE interp_fcnm + IF ( cprs(ckms) .LT. nprs ) THEN + cfld_interp = cfld(ckms) + RETURN + ELSE IF ( cprs(ckte+2) .GE. nprs ) THEN + cfld_interp = cfld(ckte+2) + RETURN + END IF - SUBROUTINE interp_fcnm_lu( cfld, & ! CD field + DO ck = ckms , ckte+1 + IF ( ( cprs(ck ) .GE. nprs ) .AND. & + ( cprs(ck+1) .LT. nprs ) ) THEN + cfld_interp = ( cfld(ck ) * ( nprs - cprs(ck+1) ) + & + cfld(ck+1) * ( cprs(ck) - nprs ) ) / & + ( cprs(ck) - cprs(ck+1) ) + RETURN + END IF + END DO + +print *,'Hey we should not be here' +print *,'nest pres to find = ',nprs +print *,'column of cg pres = ',cprs + CALL wrf_error_fatal ( 'ERROR -- vertical interpolation for nest interp cannot find trapping pressures' ) + + END FUNCTION v_interp_col + +!================================== +! this is the default function used in feedback. + + SUBROUTINE copy_fcn ( cfld, & ! CD field cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -1569,17 +1185,12 @@ SUBROUTINE interp_fcnm_lu( cfld, & ! CD field nids, nide, nkds, nkde, njds, njde, & nims, nime, nkms, nkme, njms, njme, & nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width + shw, & ! stencil half width for interp imask, & ! interpolation mask xstag, ystag, & ! staggering of field ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - cxlat, nxlat, & - cxlong, nxlong, & - cdx, ndx, & - cid, nid ) + nri, nrj ) ! nest ratios USE module_configure - IMPLICIT NONE @@ -1591,676 +1202,306 @@ SUBROUTINE interp_fcnm_lu( cfld, & ! CD field nits, nite, nkts, nkte, njts, njte, & shw, & ipos, jpos, & - nri, nrj, & - cid, nid - LOGICAL, INTENT(IN) :: xstag, ystag - - REAL, INTENT(IN) :: cdx, ndx - - REAL, INTENT(IN), DIMENSION ( cims:cime, cjms:cjme ) :: cxlat, cxlong - REAL, INTENT(IN), DIMENSION ( nims:nime, njms:njme ) :: nxlat, nxlong - + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ),INTENT(IN) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN) :: imask ! Local - INTEGER i, ci, cj, ck, ni, nj, nk, ip, jp, ierr - -#ifdef TERRAIN_AND_LANDUSE - INTEGER, DIMENSION(256) :: ipath ! array for integer coded ascii for passing path down to get_landuse - - REAL , ALLOCATABLE, DIMENSION(:,:) :: xlat_g, xlon_g, landuse_g - CHARACTER*256 :: message - CHARACTER*256 :: rsmas_data_path - - LOGICAL :: input_from_hires, input_from_file - - INTEGER, EXTERNAL :: get_landuse - LOGICAL, EXTERNAL :: wrf_dm_on_monitor + INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa + INTEGER :: icmin,icmax,jcmin,jcmax + INTEGER :: istag,jstag, ipoints,jpoints,ijpoints + INTEGER , PARAMETER :: passes = 2 + INTEGER spec_zone - CALL nl_get_input_from_hires( nid , input_from_hires) - CALL nl_get_input_from_file ( nid , input_from_file ) + ! Loop over the coarse grid in the area of the fine mesh. Do not + ! process the coarse grid values that are along the lateral BC + ! provided to the fine grid. Since that is in the specified zone + ! for the fine grid, it should not be used in any feedback to the + ! coarse grid as it should not have changed. - IF ( input_from_file .AND. input_from_hires ) THEN - Write(message, '(a,i3,a)') & - "Warning : input_from_file turned on for domain ", nid, ", input_from_hires disabled" - CALL wrf_message(message) - END IF + ! Due to peculiarities of staggering, it is simpler to handle the feedback + ! for the staggerings based upon whether it is a even ratio (2::1, 4::1, etc.) or + ! an odd staggering ratio (3::1, 5::1, etc.). - IF ( .NOT. input_from_file .AND. input_from_hires ) THEN + ! Though there are separate grid ratios for the i and j directions, this code + ! is not general enough to handle aspect ratios .NE. 1 for the fine grid cell. + + ! These are local integer increments in the looping. Basically, istag=1 means + ! that we will assume one less point in the i direction. Note that ci and cj + ! have a maximum value that is decreased by istag and jstag, respectively. - allocate(xlat_g(nids:nide,njds:njde)) - allocate(xlon_g(nids:nide,njds:njde)) - allocate(landuse_g(nids:nide,njds:njde)) + ! Horizontal momentum feedback is along the face, not within the cell. For a + ! 3::1 ratio, temperature would use 9 pts for feedback, while u and v use + ! only 3 points for feedback from the nest to the parent. - CALL nl_get_rsmas_data_path(1,rsmas_data_path) + CALL nl_get_spec_zone( 1 , spec_zone ) + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 - DO i = 1, LEN(TRIM(rsmas_data_path)) - ipath(i) = ICHAR(rsmas_data_path(i:i)) - ENDDO + IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio -#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) - CALL wrf_patch_to_global_real ( nxlat, xlat_g , nid, ' ' , 'xy' , & - nids, nide-1 , njds , njde-1 , 1 , 1 , & - nims, nime , njms , njme , 1 , 1 , & - nits, nite , njts , njte , 1 , 1 ) - CALL wrf_patch_to_global_real ( nxlong, xlon_g, nid, ' ' , 'xy' , & - nids, nide-1 , njds , njde-1 , 1 , 1 , & - nims, nime , njms , njme , 1 , 1 , & - nits, nite , njts , njte , 1 , 1 ) - IF ( wrf_dm_on_monitor() ) THEN - ierr = get_landuse ( ndx/1000., xlat_g, xlon_g, & - landuse_g, & - nide-nids+1,njde-njds+1,nide-nids+1,njde-njds+1, & - ipath, LEN(TRIM(rsmas_data_path)) ) - IF ( ierr == 1 ) THEN - WRITE(message,fmt='(a)') 'get_landuse : aborted!' - CALL wrf_error_fatal(TRIM(message)) - ENDIF - ENDIF - - CALL wrf_global_to_patch_real ( landuse_g , nfld(:,1,:), nid, ' ' , 'xy' , & - nids, nide-1 , njds , njde-1 , 1 , 1 , & - nims, nime , njms , njme , 1 , 1 , & - nits, nite , njts , njte , 1 , 1 ) - -#else - ierr = get_landuse ( ndx/1000., nxlat(nids:nide,njds:njde), nxlong(nids:nide,njds:njde), & - nfld(nids:nide,1,njds:njde), & - nide-nids+1,njde-njds+1,nide-nids+1,njde-njds+1, & - ipath, LEN(TRIM(rsmas_data_path)) ) -#endif - deallocate(xlat_g) - deallocate(xlon_g) - deallocate(landuse_g) - ELSE -#endif - ! Iterate over the ND tile and compute the values - ! from the CD tile. - DO nj = njts, njte - cj = jpos + (nj-1) / nrj ! j coord of CD point - jp = mod ( nj , nrj ) ! coord of ND w/i CD point - DO nk = nkts, nkte - ck = nk - DO ni = nits, nite - ci = ipos + (ni-1) / nri ! j coord of CD point - ip = mod ( ni , nri ) ! coord of ND w/i CD point - ! This is a trivial implementation of the interp_fcn; just copies - ! the values from the CD into the ND - if ( imask(ni,nj) .eq. 1 ) then - nfld( ni, nk, nj ) = cfld( ci , ck , cj ) - endif + IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = 0. + DO ijpoints = 1 , nri * nrj + ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1 + jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1 + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./9. * & +! ( nfld( ni-1, nk , nj-1) + & +! nfld( ni , nk , nj-1) + & +! nfld( ni+1, nk , nj-1) + & +! nfld( ni-1, nk , nj ) + & +! nfld( ni , nk , nj ) + & +! nfld( ni+1, nk , nj ) + & +! nfld( ni-1, nk , nj+1) + & +! nfld( ni , nk , nj+1) + & +! nfld( ni+1, nk , nj+1) ) + ENDDO + ENDDO ENDDO - ENDDO - ENDDO -#ifdef TERRAIN_AND_LANDUSE - END IF -#endif - RETURN - END SUBROUTINE interp_fcnm_lu + ELSE IF ( ( xstag ) .AND. ( .NOT. ystag ) ) THEN + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = 0. + DO ijpoints = (nri+1)/2 , (nri+1)/2 + nri*(nri-1) , nri + ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1 + jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1 + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./3. * & +! ( nfld( ni , nk , nj-1) + & +! nfld( ni , nk , nj ) + & +! nfld( ni , nk , nj+1) ) + ENDDO + ENDDO + ENDDO + ELSE IF ( ( .NOT. xstag ) .AND. ( ystag ) ) THEN + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = 0. + DO ijpoints = ( nrj*nrj +1 )/2 - nrj/2 , ( nrj*nrj +1 )/2 - nrj/2 + nrj-1 + ipoints = MOD((ijpoints-1),nri) + 1 - nri/2 - 1 + jpoints = (ijpoints-1)/nri + 1 - nrj/2 - 1 + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL( nrj) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./3. * & +! ( nfld( ni-1, nk , nj ) + & +! nfld( ni , nk , nj ) + & +! nfld( ni+1, nk , nj ) ) + ENDDO + ENDDO + ENDDO - SUBROUTINE interp_fcnm_imask( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj ) ! nest ratios - USE module_configure - IMPLICIT NONE + END IF + ! Even refinement ratio - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag + ELSE IF ( MOD(nrj,2) .EQ. 0) THEN + IF ( ( .NOT. xstag ) .AND. ( .NOT. ystag ) ) THEN - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + ! This is a simple schematic of the feedback indexing used in the even + ! ratio nests. For simplicity, a 2::1 ratio is depicted. Only the + ! mass variable staggering is shown. + ! Each of + ! the boxes with a "T" and four small "t" represents a coarse grid (CG) + ! cell, that is composed of four (2::1 ratio) fine grid (FG) cells. + + ! Shown below is the area of the CG that is in the area of the FG. The + ! first grid point of the depicted CG is the starting location of the nest + ! in the parent domain (ipos,jpos - i_parent_start and j_parent_start from + ! the namelist). + + ! For each of the CG points, the feedback loop is over each of the FG points + ! within the CG cell. For a 2::1 ratio, there are four total points (this is + ! the ijpoints loop). The feedback value to the CG is the arithmetic mean of + ! all of the FG values within each CG cell. - ! Local +! |-------------||-------------| |-------------||-------------| +! | t t || t t | | t t || t t | +! jpos+ | || | | || | +! (njde-njds)- | T || T | | T || T | +! jstag | || | | || | +! | t t || t t | | t t || t t | +! |-------------||-------------| |-------------||-------------| +! |-------------||-------------| |-------------||-------------| +! | t t || t t | | t t || t t | +! | || | | || | +! | T || T | | T || T | +! | || | | || | +! | t t || t t | | t t || t t | +! |-------------||-------------| |-------------||-------------| +! +! ... +! ... +! ... +! ... +! ... - INTEGER ci, cj, ck, ni, nj, nk, ip, jp +! |-------------||-------------| |-------------||-------------| +! jpoints = 1 | t t || t t | | t t || t t | +! | || | | || | +! | T || T | | T || T | +! | || | | || | +! jpoints = 0, | t t || t t | | t t || t t | +! nj=3 |-------------||-------------| |-------------||-------------| +! |-------------||-------------| |-------------||-------------| +! jpoints = 1 | t t || t t | | t t || t t | +! | || | | || | +! jpos | T || T | ... | T || T | +! | || | ... | || | +! jpoints = 0, | t t || t t | ... | t t || t t | +! nj=1 |-------------||-------------| |-------------||-------------| +! ^ ^ +! | | +! | | +! ipos ipos+ +! ni = 1 3 (nide-nids)/nri +! ipoints= 0 1 0 1 -istag +! - ! Iterate over the ND tile and compute the values - ! from the CD tile. + ! For performance benefits, users can comment out the inner most loop (and cfld=0) and + ! hardcode the loop feedback. For example, it is set up to run a 2::1 ratio + ! if uncommented. This lacks generality, but is likely to gain timing benefits + ! with compilers unable to unroll inner loops that do not have parameterized sizes. + + ! The extra +1 ---------/ and the extra -1 ----\ (both for ci and cj) + ! / \ keeps the feedback out of the + ! / \ outer row/col, since that CG data + ! / \ specified the nest boundary originally + ! / \ This + ! / \ is just + ! / \ a sentence to not end a line + ! / \ with a stupid backslash + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + cfld( ci, ck, cj ) = 0. + DO ijpoints = 1 , nri * nrj + ipoints = MOD((ijpoints-1),nri) + jpoints = (ijpoints-1)/nri + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL(nri*nrj) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./4. * & +! ( nfld( ni , nk , nj ) + & +! nfld( ni+1, nk , nj ) + & +! nfld( ni , nk , nj+1) + & +! nfld( ni+1, nk , nj+1) ) + END DO + END DO + END DO -!write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte,cjts,cjte -!write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte,njts,njte + ! U - DO nj = njts, njte - cj = jpos + (nj-1) / nrj ! j coord of CD point - jp = mod ( nj , nrj ) ! coord of ND w/i CD point - DO nk = nkts, nkte - ck = nk - DO ni = nits, nite - ci = ipos + (ni-1) / nri ! j coord of CD point - ip = mod ( ni , nri ) ! coord of ND w/i CD point - ! This is a trivial implementation of the interp_fcn; just copies - ! the values from the CD into the ND - if ( imask(ni,nj) .eq. 1 ) then - nfld( ni, nk, nj ) = cfld( ci , ck , cj ) - endif - ENDDO - ENDDO - ENDDO - - RETURN - - END SUBROUTINE interp_fcnm_imask - - - SUBROUTINE interp_mask_land_field ( enable, & ! says whether to allow interpolation or just the bcasts - cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - clu, nlu ) - - USE module_configure - USE module_wrf_error - USE module_dm, only : wrf_dm_sum_reals, wrf_dm_sum_integers - - IMPLICIT NONE - - - LOGICAL, INTENT(IN) :: enable - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag - - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - - REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu - REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu - - ! Local - - INTEGER ci, cj, ck, ni, nj, nk, ip, jp - INTEGER :: icount , ii , jj , ist , ien , jst , jen , iswater, ierr - REAL :: avg , sum , dx , dy - INTEGER , PARAMETER :: max_search = 5 - CHARACTER(LEN=255) :: message - INTEGER :: icount_n(nkts:nkte), idummy(nkts:nkte) - REAL :: avg_n(nkts:nkte), sum_n(nkts:nkte), dummy(nkts:nkte) - - ! Find out what the water value is. - - CALL nl_get_iswater(1,iswater) - - ! Right now, only mass point locations permitted. - - IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN - - ! Loop over each i,k,j in the nested domain. - - IF ( enable ) THEN - - DO nj = njts, njte - IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN - cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point - ELSE - cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point - END IF - DO nk = nkts, nkte - ck = nk - DO ni = nits, nite - IF ( imask(ni, nj) .NE. 1 ) cycle - IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN - ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point - ELSE - ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point - END IF - - - - - ! - ! (ci,cj+1) (ci+1,cj+1) - ! - ------------- - ! 1-dy | | | - ! | | | - ! - | * | - ! dy | | (ni,nj) | - ! | | | - ! - ------------- - ! (ci,cj) (ci+1,cj) - ! - ! |--|--------| - ! dx 1-dx - - - ! For odd ratios, at (nri+1)/2, we are on the coarse grid point, so dx = 0 - - IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN - dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri ) - ELSE - dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri ) - END IF - IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN - dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj ) - ELSE - dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj ) - END IF - - ! This is a "land only" field. If this is a water point, no operations required. - - IF ( ( NINT(nlu(ni ,nj )) .EQ. iswater ) ) THEN - nfld(ni,nk,nj) = cfld(ci ,ck,cj ) - - ! If this is a nested land point, and the surrounding coarse values are all land points, - ! then this is a simple 4-pt interpolation. - - ELSE IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) .AND. & - ( NINT(clu(ci ,cj )) .NE. iswater ) .AND. & - ( NINT(clu(ci+1,cj )) .NE. iswater ) .AND. & - ( NINT(clu(ci ,cj+1)) .NE. iswater ) .AND. & - ( NINT(clu(ci+1,cj+1)) .NE. iswater ) ) THEN - nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + & - dy * cfld(ci ,ck,cj+1) ) + & - dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + & - dy * cfld(ci+1,ck,cj+1) ) - - ! If this is a nested land point and there are NO coarse land values surrounding, - ! we temporarily punt. - - ELSE IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) .AND. & - ( NINT(clu(ci ,cj )) .EQ. iswater ) .AND. & - ( NINT(clu(ci+1,cj )) .EQ. iswater ) .AND. & - ( NINT(clu(ci ,cj+1)) .EQ. iswater ) .AND. & - ( NINT(clu(ci+1,cj+1)) .EQ. iswater ) ) THEN - nfld(ni,nk,nj) = -1 - - ! If there are some water points and some land points, take an average. - - ELSE IF ( NINT(nlu(ni ,nj )) .NE. iswater ) THEN - icount = 0 - sum = 0 - IF ( NINT(clu(ci ,cj )) .NE. iswater ) THEN - icount = icount + 1 - sum = sum + cfld(ci ,ck,cj ) - END IF - IF ( NINT(clu(ci+1,cj )) .NE. iswater ) THEN - icount = icount + 1 - sum = sum + cfld(ci+1,ck,cj ) - END IF - IF ( NINT(clu(ci ,cj+1)) .NE. iswater ) THEN - icount = icount + 1 - sum = sum + cfld(ci ,ck,cj+1) - END IF - IF ( NINT(clu(ci+1,cj+1)) .NE. iswater ) THEN - icount = icount + 1 - sum = sum + cfld(ci+1,ck,cj+1) - END IF - nfld(ni,nk,nj) = sum / REAL ( icount ) - END IF - END DO - END DO - END DO - - - ! Get an average of the whole domain for problem locations. - - sum_n = 0 - icount_n = 0 - DO nj = njts, njte - DO nk = nkts, nkte - DO ni = nits, nite - IF ( nfld(ni,nk,nj) .NE. -1 ) THEN - IF ( NINT(nlu(ni,nj)) .NE. iswater ) THEN - icount_n(nk) = icount_n(nk) + 1 - sum_n(nk) = sum_n(nk) + nfld(ni,nk,nj) - END IF - END IF - END DO - END DO - END DO - - CALL wrf_dm_sum_reals( sum_n(nkts:nkte), dummy(nkts:nkte)) - sum_n = dummy - CALL wrf_dm_sum_integers(icount_n(nkts:nkte), idummy(nkts:nkte)) - icount_n = idummy - DO nk = nkts, nkte - IF ( icount_n(nk) .GT. 0 ) & - avg_n(nk) = sum_n(nk) / icount_n(nk) - END DO - ENDIF - - IF ( enable ) THEN - IF ( ANY(nfld .EQ. -1) ) THEN - - ! OK, if there were any of those island situations, we try to search a bit broader - ! of an area in the coarse grid. - - DO nj = njts, njte - DO nk = nkts, nkte - DO ni = nits, nite - IF ( imask(ni, nj) .NE. 1 ) cycle - IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN - IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN - cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point - ELSE - cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point - END IF - IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN - ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point - ELSE - ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point - END IF - ist = MAX (ci-max_search,cits) - ien = MIN (ci+max_search,cite,cide-1) - jst = MAX (cj-max_search,cjts) - jen = MIN (cj+max_search,cjte,cjde-1) - icount = 0 - sum = 0 - DO jj = jst,jen - DO ii = ist,ien - IF ( NINT(clu(ii,jj)) .NE. iswater ) THEN - icount = icount + 1 - sum = sum + cfld(ii,nk,jj) - END IF - END DO - END DO - IF ( icount .GT. 0 ) THEN - nfld(ni,nk,nj) = sum / REAL ( icount ) - ELSE - Write(message,fmt='(a,i4,a,i4,a,f10.4)') & - 'horizontal interp error - island (', ni, ',', nj, '), using average ', avg_n(nk) - CALL wrf_message ( message ) - nfld(ni,nk,nj) = avg_n(nk) - END IF - END IF - END DO - END DO - END DO - ENDIF - ENDIF - ELSE - CALL wrf_error_fatal ( "only unstaggered fields right now" ) - END IF - - END SUBROUTINE interp_mask_land_field - - SUBROUTINE interp_mask_water_field ( enable, & ! says whether to allow interpolation or just the bcasts - cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - clu, nlu, cflag, nflag ) - - USE module_configure - USE module_wrf_error - USE module_dm, only : wrf_dm_sum_reals, wrf_dm_sum_integers - - IMPLICIT NONE - - - LOGICAL, INTENT(IN) :: enable - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj, cflag, nflag - LOGICAL, INTENT(IN) :: xstag, ystag - - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - - REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu - REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu - - ! Local - - INTEGER ci, cj, ck, ni, nj, nk, ip, jp - INTEGER :: icount , ii , jj , ist , ien , jst , jen, ierr - REAL :: avg , sum , dx , dy - INTEGER , PARAMETER :: max_search = 5 - INTEGER :: icount_n(nkts:nkte), idummy(nkts:nkte) - REAL :: avg_n(nkts:nkte), sum_n(nkts:nkte), dummy(nkts:nkte) - CHARACTER(LEN=255) :: message - - ! Right now, only mass point locations permitted. - - IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN - - IF ( enable ) THEN - ! Loop over each i,k,j in the nested domain. - - DO nj = njts, njte - IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN - cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point - ELSE - cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point - END IF - DO nk = nkts, nkte - ck = nk - DO ni = nits, nite -!dave IF ( imask(ni, nj) .NE. 1 ) cycle - IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN - ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point - ELSE - ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point - END IF - - - - - ! - ! (ci,cj+1) (ci+1,cj+1) - ! - ------------- - ! 1-dy | | | - ! | | | - ! - | * | - ! dy | | (ni,nj) | - ! | | | - ! - ------------- - ! (ci,cj) (ci+1,cj) - ! - ! |--|--------| - ! dx 1-dx - - - ! At ni=2, we are on the coarse grid point, so dx = 0 - - IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN - dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri ) - ELSE - dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri ) - END IF - IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN - dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj ) - ELSE - dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj ) - END IF - - ! This is a "water only" field. If this is a land point, no operations required. - - IF ( ( NINT(nlu(ni ,nj )) .NE. nflag ) ) THEN - nfld(ni,nk,nj) = cfld(ci ,ck,cj ) - - ! If this is a nested water point, and the surrounding coarse values are all water points, - ! then this is a simple 4-pt interpolation. - - ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. nflag ) .AND. & - ( NINT(clu(ci ,cj )) .EQ. nflag ) .AND. & - ( NINT(clu(ci+1,cj )) .EQ. nflag ) .AND. & - ( NINT(clu(ci ,cj+1)) .EQ. nflag ) .AND. & - ( NINT(clu(ci+1,cj+1)) .EQ. nflag ) ) THEN - nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + & - dy * cfld(ci ,ck,cj+1) ) + & - dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + & - dy * cfld(ci+1,ck,cj+1) ) - - ! If this is a nested water point and there are NO coarse water values surrounding, - ! we temporarily punt. - - ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. nflag ) .AND. & - ( NINT(clu(ci ,cj )) .NE. nflag ) .AND. & - ( NINT(clu(ci+1,cj )) .NE. nflag ) .AND. & - ( NINT(clu(ci ,cj+1)) .NE. nflag ) .AND. & - ( NINT(clu(ci+1,cj+1)) .NE. nflag ) ) THEN - nfld(ni,nk,nj) = -1 - - ! If there are some land points and some water points, take an average. - - ELSE IF ( NINT(nlu(ni ,nj )) .EQ. nflag ) THEN - icount = 0 - sum = 0 - IF ( NINT(clu(ci ,cj )) .EQ. nflag ) THEN - icount = icount + 1 - sum = sum + cfld(ci ,ck,cj ) - END IF - IF ( NINT(clu(ci+1,cj )) .EQ. nflag ) THEN - icount = icount + 1 - sum = sum + cfld(ci+1,ck,cj ) - END IF - IF ( NINT(clu(ci ,cj+1)) .EQ. nflag ) THEN - icount = icount + 1 - sum = sum + cfld(ci ,ck,cj+1) - END IF - IF ( NINT(clu(ci+1,cj+1)) .EQ. nflag ) THEN - icount = icount + 1 - sum = sum + cfld(ci+1,ck,cj+1) - END IF - nfld(ni,nk,nj) = sum / REAL ( icount ) - END IF - END DO - END DO - END DO - - ! Get an average of the whole domain for problem locations. - - sum_n = 0 - icount_n = 0 - DO nj = njts, njte - DO nk = nkts, nkte - DO ni = nits, nite - IF ( nfld(ni,nk,nj) .NE. -1 ) THEN - IF ( NINT(nlu(ni,nj)) .EQ. nflag ) THEN - icount_n(nk) = icount_n(nk) + 1 - sum_n(nk) = sum_n(nk) + nfld(ni,nk,nj) - END IF - END IF - END DO - END DO - END DO + ELSE IF ( ( xstag ) .AND. ( .NOT. ystag ) ) THEN +! |---------------| +! | | +! jpoints = 1 u u | +! | | +! U | +! | | +! jpoints = 0, u u | +! nj=3 | | +! |---------------| +! |---------------| +! | | +! jpoints = 1 u u | +! | | +! jpos U | +! | | +! jpoints = 0, u u | +! nj=1 | | +! |---------------| +! +! ^ +! | +! | +! ipos +! ni = 1 3 +! ipoints= 0 1 0 +! - CALL wrf_dm_sum_reals( sum_n(nkts:nkte), dummy(nkts:nkte)) - sum_n = dummy - CALL wrf_dm_sum_integers(icount_n(nkts:nkte), idummy(nkts:nkte)) - icount_n = idummy - DO nk = nkts, nkte - IF ( icount_n(nk) .GT. 0 ) & - avg_n(nk) = sum_n(nk) / icount_n(nk) - END DO - ENDIF + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + 1 + cfld( ci, ck, cj ) = 0. + DO ijpoints = 1 , nri*nrj , nri + ipoints = MOD((ijpoints-1),nri) + jpoints = (ijpoints-1)/nri + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./2. * & +! ( nfld( ni , nk , nj ) + & +! nfld( ni , nk , nj+1) ) + ENDDO + ENDDO + ENDDO - IF ( enable ) THEN - IF ( ANY(nfld .EQ. -1) ) THEN + ! V - ! OK, if there were any of those lake situations, we try to search a bit broader - ! of an area in the coarse grid. + ELSE IF ( ( .NOT. xstag ) .AND. ( ystag ) ) THEN + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + 1 + cfld( ci, ck, cj ) = 0. + DO ijpoints = 1 , nri + ipoints = MOD((ijpoints-1),nri) + jpoints = (ijpoints-1)/nri + cfld( ci, ck, cj ) = cfld( ci, ck, cj ) + & + 1./REAL(nri ) * nfld( ni+ipoints , nk , nj+jpoints ) + END DO +! cfld( ci, ck, cj ) = 1./2. * & +! ( nfld( ni , nk , nj ) + & +! nfld( ni+1, nk , nj ) ) + ENDDO + ENDDO + ENDDO + END IF + END IF - DO nj = njts, njte - DO nk = nkts, nkte - DO ni = nits, nite -!dave IF ( imask(ni, nj) .NE. 1 ) cycle - IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN - IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN - cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point - ELSE - cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point - END IF - IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN - ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point - ELSE - ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point - END IF - ist = MAX (ci-max_search,cits) - ien = MIN (ci+max_search,cite,cide-1) - jst = MAX (cj-max_search,cjts) - jen = MIN (cj+max_search,cjte,cjde-1) - icount = 0 - sum = 0 - DO jj = jst,jen - DO ii = ist,ien - IF ( NINT(clu(ii,jj)) .EQ. nflag ) THEN - icount = icount + 1 - sum = sum + cfld(ii,nk,jj) - END IF - END DO - END DO - IF ( icount .GT. 0 ) THEN - nfld(ni,nk,nj) = sum / REAL ( icount ) - ELSE - Write(message,fmt='(a,i4,a,i4,a,f10.4)') & - 'horizontal interp error - lake (', ni, ',', nj, '), using average ', avg_n(nk) - CALL wrf_message ( message ) - nfld(ni,nk,nj) = avg_n(nk) - END IF - END IF - END DO - END DO - END DO - ENDIF - ENDIF - ELSE - CALL wrf_error_fatal ( "only unstaggered fields right now" ) - END IF + RETURN - END SUBROUTINE interp_mask_water_field + END SUBROUTINE copy_fcn - SUBROUTINE p2c_mask ( cfld, & ! CD field +!================================== +! this is the 1pt function used in feedback. + + SUBROUTINE copy_fcnm ( cfld, & ! CD field cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -2268,410 +1509,494 @@ SUBROUTINE p2c_mask ( cfld, & ! CD field nids, nide, nkds, nkde, njds, njde, & nims, nime, nkms, nkme, njms, njme, & nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width + shw, & ! stencil half width for interp imask, & ! interpolation mask xstag, ystag, & ! staggering of field ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - clu, nlu, & ! land use categories - ctslb,ntslb, & ! soil temps - cnum_soil_layers,nnum_soil_layers, & ! number of soil layers for tslb - ciswater, niswater ) ! iswater category + nri, nrj ) ! nest ratios + USE module_configure + USE module_wrf_error + IMPLICIT NONE - USE module_configure - USE module_wrf_error - IMPLICIT NONE - - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj, & - cnum_soil_layers, nnum_soil_layers, & - ciswater, niswater + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag - LOGICAL, INTENT(IN) :: xstag, ystag - - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - - REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu - REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask - REAL, DIMENSION ( cims:cime, 1:cnum_soil_layers, cjms:cjme ) :: ctslb - REAL, DIMENSION ( nims:nime, 1:nnum_soil_layers, njms:njme ) :: ntslb + ! Local - ! Local - - INTEGER ci, cj, ck, ni, nj, nk - INTEGER :: icount - REAL :: sum , dx , dy + INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa + INTEGER :: icmin,icmax,jcmin,jcmax + INTEGER :: istag,jstag, ipoints,jpoints,ijpoints + INTEGER , PARAMETER :: passes = 2 + INTEGER spec_zone - ! Right now, only mass point locations permitted. - - IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN + CALL nl_get_spec_zone( 1, spec_zone ) + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 - ! Loop over each i,k,j in the nested domain. + IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio - DO nj = njts, MIN(njde-1,njte) - IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN - cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point - ELSE - cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point - END IF - DO nk = nkts, nkte - ck = nk - DO ni = nits, MIN(nide-1,nite) - IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN - ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point - ELSE - ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point - END IF + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = nfld( ni , nk , nj ) + ENDDO + ENDDO + ENDDO - ! - ! (ci,cj+1) (ci+1,cj+1) - ! - ------------- - ! 1-dy | | | - ! | | | - ! - | * | - ! dy | | (ni,nj) | - ! | | | - ! - ------------- - ! (ci,cj) (ci+1,cj) - ! - ! |--|--------| - ! dx 1-dx + ELSE ! even refinement ratio, pick nearest neighbor on SW corner + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + 1 + ipoints = nri/2 -1 + jpoints = nrj/2 -1 + cfld( ci, ck, cj ) = nfld( ni+ipoints , nk , nj+jpoints ) + END DO + END DO + END DO + + END IF + RETURN - ! At ni=2, we are on the coarse grid point, so dx = 0 + END SUBROUTINE copy_fcnm - IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN - dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri ) - ELSE - dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri ) - END IF - IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN - dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj ) - ELSE - dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj ) - END IF - - ! This is a "water only" field. If this is a land point, no operations required. +!================================== +! this is the 1pt function used in feedback for integers - IF ( ( NINT(nlu(ni ,nj )) .NE. niswater ) ) THEN - nfld(ni,nk,nj) = 273.18 + SUBROUTINE copy_fcni ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios + USE module_configure + USE module_wrf_error + IMPLICIT NONE - ! If this is a nested water point, and the surrounding coarse values are all water points, - ! then this is a simple 4-pt interpolation. - ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. niswater ) .AND. & - ( NINT(clu(ci ,cj )) .EQ. niswater ) .AND. & - ( NINT(clu(ci+1,cj )) .EQ. niswater ) .AND. & - ( NINT(clu(ci ,cj+1)) .EQ. niswater ) .AND. & - ( NINT(clu(ci+1,cj+1)) .EQ. niswater ) ) THEN - nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + & - dy * cfld(ci ,ck,cj+1) ) + & - dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + & - dy * cfld(ci+1,ck,cj+1) ) + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag - ! If this is a nested water point and there are NO coarse water values surrounding, - ! we manufacture something from the deepest CG soil temp. + INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld + INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask - ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. niswater ) .AND. & - ( NINT(clu(ci ,cj )) .NE. niswater ) .AND. & - ( NINT(clu(ci+1,cj )) .NE. niswater ) .AND. & - ( NINT(clu(ci ,cj+1)) .NE. niswater ) .AND. & - ( NINT(clu(ci+1,cj+1)) .NE. niswater ) ) THEN - nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * ctslb(ci ,cnum_soil_layers,cj ) + & - dy * ctslb(ci ,cnum_soil_layers,cj+1) ) + & - dx * ( ( 1. - dy ) * ctslb(ci+1,cnum_soil_layers,cj ) + & - dy * ctslb(ci+1,cnum_soil_layers,cj+1) ) + ! Local - ! If there are some land points and some water points, take an average of the water points. - - ELSE IF ( NINT(nlu(ni ,nj )) .EQ. niswater ) THEN - icount = 0 - sum = 0 - IF ( NINT(clu(ci ,cj )) .EQ. niswater ) THEN - icount = icount + 1 - sum = sum + cfld(ci ,ck,cj ) - END IF - IF ( NINT(clu(ci+1,cj )) .EQ. niswater ) THEN - icount = icount + 1 - sum = sum + cfld(ci+1,ck,cj ) - END IF - IF ( NINT(clu(ci ,cj+1)) .EQ. niswater ) THEN - icount = icount + 1 - sum = sum + cfld(ci ,ck,cj+1) - END IF - IF ( NINT(clu(ci+1,cj+1)) .EQ. niswater ) THEN - icount = icount + 1 - sum = sum + cfld(ci+1,ck,cj+1) - END IF - nfld(ni,nk,nj) = sum / REAL ( icount ) - END IF - END DO - END DO - END DO + INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa + INTEGER :: icmin,icmax,jcmin,jcmax + INTEGER :: istag,jstag, ipoints,jpoints,ijpoints + INTEGER , PARAMETER :: passes = 2 + INTEGER spec_zone - ELSE - CALL wrf_error_fatal ( "only unstaggered fields right now" ) - END IF + CALL nl_get_spec_zone( 1, spec_zone ) + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 - END SUBROUTINE p2c_mask + IF( MOD(nrj,2) .NE. 0) THEN ! odd refinement ratio - SUBROUTINE none - END SUBROUTINE none + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = nfld( ni , nk , nj ) + ENDDO + ENDDO + ENDDO + + ELSE ! even refinement ratio + DO cj = MAX(jpos+spec_zone,cjts),MIN(jpos+(njde-njds)/nrj-jstag-spec_zone,cjte) + nj = (cj-jpos)*nrj + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+spec_zone,cits),MIN(ipos+(nide-nids)/nri-istag-spec_zone,cite) + ni = (ci-ipos)*nri + 1 + ipoints = nri/2 -1 + jpoints = nrj/2 -1 + cfld( ci, ck, cj ) = nfld( ni+ipoints , nk , nj+jpoints ) + END DO + END DO + END DO - SUBROUTINE smoother ( cfld , & - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in - nri, nrj & - ) - - USE module_configure - IMPLICIT NONE - - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - nri, nrj, & - ipos, jpos - LOGICAL, INTENT(IN) :: xstag, ystag - INTEGER :: smooth_option, feedback , spec_zone - - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + END IF - ! If there is no feedback, there can be no smoothing. + RETURN - CALL nl_get_feedback ( 1, feedback ) - IF ( feedback == 0 ) RETURN - CALL nl_get_spec_zone ( 1, spec_zone ) + END SUBROUTINE copy_fcni - ! These are the 2d smoothers used on the fedback data. These filters - ! are run on the coarse grid data (after the nested info has been - ! fedback). Only the area of the nest in the coarse grid is filtered. +!================================== - CALL nl_get_smooth_option ( 1, smooth_option ) + SUBROUTINE vert_interp_vert_nesting ( cfld, & ! CD field + ids, ide, kds, kde, jds, jde, & + ims, ime, kms, kme, jms, jme, & + its, ite, kts, kte, jts, jte, & + pgrid_s_vert, pgrid_e_vert, & ! vertical dimensions of parent grid + cf1_c, cf2_c, cf3_c, cfn_c, cfn1_c, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) - IF ( smooth_option == 0 ) THEN -! no op - ELSE IF ( smooth_option == 1 ) THEN - CALL sm121 ( cfld , & - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - xstag, ystag, & ! staggering of field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - nri, nrj, & - ipos, jpos & ! Position of lower left of nest in - ) - ELSE IF ( smooth_option == 2 ) THEN - CALL smdsm ( cfld , & - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - xstag, ystag, & ! staggering of field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - nri, nrj, & - ipos, jpos & ! Position of lower left of nest in - ) - END IF +!KAL vertical interpolation for u, v, and mass points (w is below in a different subroutine) for vertical nesting - END SUBROUTINE smoother + IMPLICIT NONE + REAL, DIMENSION ( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: cfld + INTEGER, INTENT(IN) :: ids, ide, kds, kde, jds, jde, & + ims, ime, kms, kme, jms, jme, & + its, ite, kts, kte, jts, jte + INTEGER, INTENT(IN) :: pgrid_s_vert, pgrid_e_vert ! vertical dimensions of the parent grid + REAL, INTENT(IN) :: cf1_c, cf2_c, cf3_c, cfn_c, cfn1_c + REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert+1), INTENT(IN) :: alt_u_c + REAL, DIMENSION(kde+1), INTENT(IN) :: alt_u_n - SUBROUTINE sm121 ( cfld , & - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - xstag, ystag, & ! staggering of field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - nri, nrj, & - ipos, jpos & ! Position of lower left of nest in - ) - USE module_configure - IMPLICIT NONE + !local - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - nri, nrj, & - ipos, jpos - LOGICAL, INTENT(IN) :: xstag, ystag + INTEGER :: i,j,k + REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert+1) :: pro_u_c ! variable in 1D on the coarse grid + REAL, DIMENSION(kde+1) :: pro_u_n - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfldnew + DO j = jms,jme + DO i = ims,ime - INTEGER :: i , j , k , loop - INTEGER :: istag,jstag + ! pro_u_c is u on the 1D coarse grid + + do k = pgrid_s_vert,pgrid_e_vert-1 + pro_u_c(k+1) = cfld(i,k,j) + enddo + + !KAL fill in the surface value and the top value using extrapolation + + pro_u_c(1 ) = cf1_c*cfld(i,1,j) & + + cf2_c*cfld(i,2,j) & + + cf3_c*cfld(i,3,j) + + pro_u_c(pgrid_e_vert+1) = cfn_c *cfld(i,pgrid_e_vert-1,j) & + + cfn1_c*cfld(i,pgrid_e_vert-2,j) + + call inter_wrf_copy(pro_u_c, alt_u_c, pgrid_e_vert+1, pro_u_n, alt_u_n, kde+1) + + do k = 1,kde-1 + cfld(i,k,j) = pro_u_n(k+1) + enddo + + ENDDO + ENDDO + + + END SUBROUTINE vert_interp_vert_nesting + + !================================== - INTEGER, PARAMETER :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt) + SUBROUTINE vert_interp_vert_nesting_w ( cfld, & ! CD field + ids, ide, kds, kde, jds, jde, & + ims, ime, kms, kme, jms, jme, & + its, ite, kts, kte, jts, jte, & + pgrid_s_vert, pgrid_e_vert, & ! vertical dimensions of parent grid + alt_w_c, alt_w_n) + +!KAL vertical interpolation at w points for vertical nesting + + IMPLICIT NONE + REAL, DIMENSION ( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: cfld + INTEGER, INTENT(IN) :: ids, ide, kds, kde, jds, jde, & + ims, ime, kms, kme, jms, jme, & + its, ite, kts, kte, jts, jte + INTEGER, INTENT(IN) :: pgrid_s_vert, pgrid_e_vert ! vertical dimensions of the parent grid + REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert), INTENT(IN) :: alt_w_c + REAL, DIMENSION(kde), INTENT(IN) :: alt_w_n - istag = 1 ; jstag = 1 - IF ( xstag ) istag = 0 - IF ( ystag ) jstag = 0 - ! Simple 1-2-1 smoother. + !local - smoothing_passes : DO loop = 1 , smooth_passes + INTEGER :: i,j,k + REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert) :: pro_w_c ! variable in 1D on the coarse grid + REAL, DIMENSION(kde) :: pro_w_n - DO k = ckts , ckte + DO j = jms,jme + DO i = ims,ime - ! Initialize dummy cfldnew + ! pro_w_c is w on the 1D coarse grid + + do k = pgrid_s_vert,pgrid_e_vert + pro_w_c(k) = cfld(i,k,j) + enddo + + call inter_wrf_copy(pro_w_c, alt_w_c, pgrid_e_vert, pro_w_n, alt_w_n, kde) + + do k = 1,kde + cfld(i,k,j) = pro_w_n(k) + enddo + + ENDDO + ENDDO + + + END SUBROUTINE vert_interp_vert_nesting_w - DO i = MAX(ipos,cits-3) , MIN(ipos+(nide-nids)/nri,cite+3) - DO j = MAX(jpos,cjts-3) , MIN(jpos+(njde-njds)/nrj,cjte+3) - cfldnew(i,j) = cfld(i,k,j) - END DO - END DO +!----------------------------------------------------------------------------------------- - ! 1-2-1 smoothing in the j direction first, - - DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) - DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) - cfldnew(i,j) = 0.25 * ( cfld(i,k,j+1) + 2.*cfld(i,k,j) + cfld(i,k,j-1) ) - END DO - END DO + SUBROUTINE vert_interp_vert_nesting_1d ( cfld, & ! CD field + ids, ide, kds, kde, jds, jde, & + ims, ime, kms, kme, jms, jme, & + its, ite, kts, kte, jts, jte, & + pgrid_s_vert, pgrid_e_vert, & ! vertical dimensions of parent grid + cf1_c, cf2_c, cf3_c, cfn_c, cfn1_c, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) - ! then 1-2-1 smoothing in the i direction last - - DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) - DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) - cfld(i,k,j) = 0.25 * ( cfldnew(i+1,j) + 2.*cfldnew(i,j) + cfldnew(i-1,j) ) - END DO - END DO - - END DO - - END DO smoothing_passes - - END SUBROUTINE sm121 +!KAL vertical interpolation for u, v, and mass points (w is below in a different subroutine) for vertical nesting + + IMPLICIT NONE + REAL, DIMENSION (kms:kme),INTENT(INOUT) :: cfld + INTEGER, INTENT(IN) :: ids, ide, kds, kde, jds, jde, & + ims, ime, kms, kme, jms, jme, & + its, ite, kts, kte, jts, jte + INTEGER, INTENT(IN) :: pgrid_s_vert, pgrid_e_vert ! vertical dimensions of the parent grid + REAL, INTENT(IN) :: cf1_c, cf2_c, cf3_c, cfn_c, cfn1_c + REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert+1), INTENT(IN) :: alt_u_c + REAL, DIMENSION(kde+1), INTENT(IN) :: alt_u_n - SUBROUTINE smdsm ( cfld , & - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - xstag, ystag, & ! staggering of field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - nri, nrj, & - ipos, jpos & ! Position of lower left of nest in - ) - USE module_configure - IMPLICIT NONE + !local - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - nri, nrj, & - ipos, jpos - LOGICAL, INTENT(IN) :: xstag, ystag + INTEGER :: i,j,k + REAL, DIMENSION(pgrid_s_vert:pgrid_e_vert+1) :: pro_u_c ! variable in 1D on the coarse grid + REAL, DIMENSION(kde+1) :: pro_u_n - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfldnew + + ! pro_u_c is u on the 1D coarse grid + + do k = pgrid_s_vert,pgrid_e_vert-1 + pro_u_c(k+1) = cfld(k) + enddo + + !KAL fill in the surface value and the top value using extrapolation + + pro_u_c(1 ) = cf1_c*cfld(1) & + + cf2_c*cfld(2) & + + cf3_c*cfld(3) - REAL , DIMENSION ( 2 ) :: xnu - INTEGER :: i , j , k , loop , n - INTEGER :: istag,jstag + pro_u_c(pgrid_e_vert+1) = cfn_c *cfld(pgrid_e_vert-1) & + + cfn1_c*cfld(pgrid_e_vert-2) + + call inter_wrf_copy(pro_u_c, alt_u_c, pgrid_e_vert+1, pro_u_n, alt_u_n, kde+1) + + do k = 1,kde-1 + cfld(k) = pro_u_n(k+1) + enddo + + + END SUBROUTINE vert_interp_vert_nesting_1d + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!KAL this is a direct copy of a subroutine from ndown, but a dependency on ndown will not work because it is not always compiled (for ideal cases), and most likely not compliled in the order needed. - INTEGER, PARAMETER :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt) + SUBROUTINE inter_wrf_copy(pro_c,alt_c,kde_c,pro_n,alt_n,kde_n) + +!KAL this routine has been added for vertical nesting + + IMPLICIT NONE + INTEGER , INTENT(IN) :: kde_c,kde_n + REAL , DIMENSION(kde_c) , INTENT(IN ) :: pro_c,alt_c + REAL , DIMENSION(kde_n) , INTENT(IN ) :: alt_n + REAL , DIMENSION(kde_n) , INTENT(OUT) :: pro_n + + real ,dimension(kde_c) :: a,b,c,d + real :: p + integer :: i,j + + + call coeff_mon_wrf_copy(alt_c,pro_c,a,b,c,d,kde_c) + + do i = 1,kde_n-1 + + do j=1,kde_c-1 + + if ( (alt_n(i) .ge. alt_c(j)).and.(alt_n(i) .lt. alt_c(j+1)) ) then + p = alt_n(i)-alt_c(j) + pro_n(i) = p*( p*(a(j)*p+b(j))+c(j)) + d(j) + goto 20 + endif + enddo +20 continue + enddo + + pro_n(kde_n) = pro_c(kde_c) + + + END SUBROUTINE inter_wrf_copy + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!11 +!KAL this is a direct copy of a subroutine from ndown, but a dependency on ndown will not work because it is not always compiled (for ideal cases), and most likely not compliled in the order needed. + + subroutine coeff_mon_wrf_copy(x,y,a,b,c,d,n) + +!KAL this routine has been added for vertical nesting + + implicit none + + integer :: n + real ,dimension(n) :: x,y,a,b,c,d + real ,dimension(n) :: h,s,p,yp + + integer :: i + + + do i=1,n-1 + h(i) = (x(i+1)-x(i)) + s(i) = (y(i+1)-y(i)) / h(i) + enddo + + do i=2,n-1 + p(i) = (s(i-1)*h(i)+s(i)*h(i-1)) / (h(i-1)+h(i)) + enddo + + p(1) = s(1) + p(n) = s(n-1) + + do i=1,n + yp(i) = p(i) + enddo +!!!!!!!!!!!!!!!!!!!!! + + do i=2,n-1 + yp(i) = (sign(1.,s(i-1))+sign(1.,s(i)))* min( abs(s(i-1)),abs(s(i)),0.5*abs(p(i))) + enddo + + do i = 1,n-1 + a(i) = (yp(i)+yp(i+1)-2.*s(i))/(h(i)*h(i)) + b(i) = (3.*s(i)-2.*yp(i)-yp(i+1))/h(i) + c(i) = yp(i) + d(i) = y(i) + enddo + + end subroutine coeff_mon_wrf_copy + + !----------------------------------------------------------------------------------------- + + +!================================== + + SUBROUTINE p2c ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj & ! nest ratios + ) + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + + CALL interp_fcn (cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios - xnu = (/ 0.50 , -0.52 /) - - istag = 1 ; jstag = 1 - IF ( xstag ) istag = 0 - IF ( ystag ) jstag = 0 - - ! The odd number passes of this are the "smoother", the even - ! number passes are the "de-smoother" (note the different signs on xnu). - - smoothing_passes : DO loop = 1 , smooth_passes * 2 - - n = 2 - MOD ( loop , 2 ) - - DO k = ckts , ckte - - DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) - DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) - cfldnew(i,j) = cfld(i,k,j) + xnu(n) * ((cfld(i,k,j+1) + cfld(i,k,j-1)) * 0.5-cfld(i,k,j)) - END DO - END DO - - DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) - DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) - cfld(i,k,j) = cfldnew(i,j) - END DO - END DO - - DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) - DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) - cfldnew(i,j) = cfld(i,k,j) + xnu(n) * ((cfld(i+1,k,j) + cfld(i-1,k,j)) * 0.5-cfld(i,k,j)) - END DO - END DO - - DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) - DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) - cfld(i,k,j) = cfldnew(i,j) - END DO - END DO - - END DO - - END DO smoothing_passes - - END SUBROUTINE smdsm + END SUBROUTINE p2c !================================== -! this is used to modify a field over the nest so we can see where the nest is - SUBROUTINE mark_domain ( cfld, & ! CD field + SUBROUTINE c2f_interp ( cfld, & ! CD field cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & nfld, & ! ND field nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & + nims, nime, nkms, nkme, njms, njme, & nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp + shw, & ! stencil half width imask, & ! interpolation mask xstag, ystag, & ! staggering of field ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj ) ! nest ratios + nri, nrj, & ! nest ratios +! cbdy_xs, nbdy_xs, & +! cbdy_xe, nbdy_xe, & +! cbdy_ys, nbdy_ys, & +! cbdy_ye, nbdy_ye, & +! cbdy_txs, nbdy_txs, & +! cbdy_txe, nbdy_txe, & +! cbdy_tys, nbdy_tys, & +! cbdy_tye, nbdy_tye, & + parent_id,nest_id &!cyl + ) ! boundary arrays USE module_configure - USE module_wrf_error IMPLICIT NONE - +!------------------------------------------------------------ +! Subroutine c2f_interp interpolate field from coarse resolution domain +! to its nested domain. It is written by Dave Gill in NCAR for the purpose +! running phys/module_sf_oml.F-DPWP in only d01 and d02 +! Chiaying Lee RSMAS/UM +!------------------------------------------------------------ + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -2680,1220 +2005,621 @@ SUBROUTINE mark_domain ( cfld, & ! CD field nits, nite, nkts, nkte, njts, njte, & shw, & ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag - - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask + nri, nrj,parent_id,nest_id !cyl + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask +! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs, nbdy_xs, nbdy_txs +! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe, nbdy_xe, nbdy_txe +! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys, nbdy_ys, nbdy_tys +! REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye, nbdy_ye, nbdy_tye + REAL cdt, ndt + ! Local - INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa - INTEGER :: icmin,icmax,jcmin,jcmax - INTEGER :: istag,jstag, ipoints,jpoints,ijpoints + INTEGER ci, cj, ck, ni, nj, nk, ip, jp - istag = 1 ; jstag = 1 - IF ( xstag ) istag = 0 - IF ( ystag ) jstag = 0 + ! Iterate over the ND tile and compute the values + ! from the CD tile. - DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-jstag-1,cjte) - nj = (cj-jpos)*nrj + jstag + 1 - DO ck = ckts, ckte - nk = ck - DO ci = MAX(ipos+1,cits),MIN(ipos+(nide-nids)/nri-istag-1,cite) - ni = (ci-ipos)*nri + istag + 1 - cfld( ci, ck, cj ) = 9021000. !magic number: Beverly Hills * 100. +!write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte +!write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte +! write(0,*)'cyl parentid',parent_id +! write(0,*)'cyl nestid',nest_id +! If ( nest_id .le. 2 .and. (1.0/rdx .ge. 3000.0 .and. 1.0/rdy .ge. 3000.0) ) then ! cyl: only run it in the nest domain with dx, dy < 3 km + If ( nest_id .eq. 3 ) then + DO nj = njts, njte + + cj = jpos + (nj-1) / nrj ! j coord of CD point + jp = mod ( nj , nrj ) ! coord of ND w/i CD point + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + ci = ipos + (ni-1) / nri ! j coord of CD point + ip = mod ( ni , nri ) ! coord of ND w/i CD point + ! This is a trivial implementation of the interp_fcn; just copies + ! the values from the CD into the ND + nfld( ni, nk, nj ) = cfld( ci , ck , cj ) ENDDO ENDDO ENDDO + ENDIF ! cyl + RETURN - END SUBROUTINE mark_domain - -#if ( NMM_CORE == 1 ) -!======================================================================================= -! E grid interpolation for mass with addition of terrain adjustments. First routine -! pertains to initial conditions and the next one corresponds to boundary conditions -! This is gopal's doing -!======================================================================================= - - SUBROUTINE interp_mass_nmm (cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights - CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, HBWGT4, & ! dummys for weights - CZ3d, Z3d, & ! Z3d interpolated from CZ3d - CFIS,FIS, & ! CFIS dummy on fine domain - CSM,SM, & ! CSM is dummy - CPDTOP,PDTOP, & - CPTOP,PTOP, & - CPSTD,PSTD, & - CKZMAX,KZMAX ) - - USE MODULE_MODEL_CONSTANTS - USE module_timing - IMPLICIT NONE - - LOGICAL,INTENT(IN) :: xstag, ystag - INTEGER,INTENT(IN) :: ckzmax,kzmax - INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw,ipos,jpos,nri,nrj - - INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK - -! parent domain - - INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3 - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT4,CFIS,CSM - REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CFLD - REAL,DIMENSION(cims:cime,cjms:cjme,1:KZMAX), INTENT(IN) :: CZ3d - REAL,DIMENSION(1:KZMAX), INTENT(IN) :: CPSTD - REAL,INTENT(IN) :: CPDTOP,CPTOP - -! nested domain - - INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3 - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT4 - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: FIS,SM - REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(INOUT) :: NFLD - REAL,DIMENSION(1:KZMAX), INTENT(IN) :: PSTD - REAL,DIMENSION(nims:nime,njms:njme,1:KZMAX), INTENT(OUT) :: Z3d - REAL,INTENT(IN) :: PDTOP,PTOP - -! local - - INTEGER,PARAMETER :: JTB=134 - REAL, PARAMETER :: LAPSR=6.5E-3,GI=1./G, D608=0.608 - REAL, PARAMETER :: COEF3=R_D*GI*LAPSR - INTEGER :: I,J,K,IDUM - REAL :: dlnpdz,tvout,pmo - REAL,DIMENSION(nims:nime,njms:njme) :: ZS,DUM2d - REAL,DIMENSION(JTB) :: PIN,ZIN,Y2,PIO,ZOUT,DUM1,DUM2 - CHARACTER (LEN=256) :: a_message -!----------------------------------------------------------------------------------------------------- -! -!*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION -! - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) & - CALL wrf_error_fatal ('mass points:check domain bounds along x' ) - IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) & - CALL wrf_error_fatal ('mass points:check domain bounds along y' ) - ENDDO - ENDDO - - IF(KZMAX .GT. (JTB-10)) & - CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm') + END SUBROUTINE c2f_interp -! WRITE(21,*)'------------- MED NEST INITIAL 1 ----------------' -! DO J=NJTS,MIN(NJTE,NJDE-1) -! DO I=NITS,MIN(NITE,NIDE-1) -! WRITE(21,*)I,J,IMASK(I,J),NFLD(I,1,J) -! ENDDO -! ENDDO -! WRITE(21,*) +!================================== -! -!*** DEFINE LOCAL TOPOGRAPHY ON THE BASIS OF FIS. ALSO CHECK IF SM IS LAND (SM=0) OVER TOPO -!*** YOU DON'T WANT MOUNTAINS INSIDE WATER BODIES! -! + SUBROUTINE bdy_interp ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + cbdy_xs, nbdy_xs, & ! Boundary components, for the CG and FG, + cbdy_xe, nbdy_xe, & ! for each of the four sides (x start, e end, y start, y end) + cbdy_ys, nbdy_ys, & ! and also for the two components of the LBC: + cbdy_ye, nbdy_ye, & ! the "starting" value and the tendency + cbdy_txs, nbdy_txs, & + cbdy_txe, nbdy_txe, & ! The CG is at a parent time step ahead of the FG + cbdy_tys, nbdy_tys, & + cbdy_tye, nbdy_tye, & + cdt, ndt ) ! Time step size for CG and FG + + USE module_interp_info - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - ZS(I,J)=FIS(I,J)/G - ENDDO - ENDDO + IMPLICIT NONE -! -!*** Interpolate GPMs DERIVED FROM STANDARD ATMOSPHERIC LAPSE RATE FROM THE PARENT TO -!*** THE NESTED DOMAIN -! -!*** INDEX CONVENTIONS -!*** HBWGT4 -!*** 4 -!*** -!*** -!*** -!*** h -!*** 1 2 -!*** HBWGT1 HBWGT2 -!*** -!*** -!*** 3 -!*** HBWGT3 + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj - Z3d=0.0 - DO K=NKTS,KZMAX ! Please note that we are still in isobaric surfaces - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) -! - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CZ3d(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CZ3d(IIH(I,J), JJH(I,J)+1,K) - ELSE - Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)+1,K) + LOGICAL, INTENT(IN) :: xstag, ystag - ENDIF -! - ENDDO - ENDDO - ENDDO + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs, nbdy_xs, nbdy_txs + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe, nbdy_xe, nbdy_txe + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys, nbdy_ys, nbdy_tys + REAL, DIMENSION( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye, nbdy_ye, nbdy_tye + REAL cdt, ndt -! RECONSTRUCT PDs ON THE BASIS OF TOPOGRAPHY AND THE INTERPOLATED HEIGHTS + ! Local - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) -! - IF (ZS(I,J) .LT. Z3d(I,J,1)) THEN - dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(i,j,1)-Z3d(i,j,2)) - dum2d(i,j) = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(i,j,1))) - dum2d(i,j) = dum2d(i,j) - PDTOP -PTOP - ELSE ! target level bounded by input levels - DO K =NKTS,KZMAX-1 ! still in the isobaric surfaces - IF(ZS(I,J) .GE. Z3d(I,J,K) .AND. ZS(I,J) .LT. Z3d(I,J,K+1))THEN - dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(I,J,K)-Z3d(I,J,K+1)) - dum2d(i,j) = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(I,J,K))) - dum2d(i,j) = dum2d(i,j) - PDTOP -PTOP - ENDIF - ENDDO - ENDIF - IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN - WRITE(a_message,*)'I=',I,'J=',J,'K=',KZMAX,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX) - CALL wrf_message ( a_message ) - CALL wrf_error_fatal3 ( "interp_fcn.b" , 176 , "MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH") - ENDIF -! - ENDDO - ENDDO + INTEGER nijds, nijde, spec_bdy_width - DO K=NKDS,NKDE ! NKTE is 1, nevertheless let us pretend religious - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN - NFLD(I,J,K)= dum2d(i,j) ! PD defined in the nested domain - ENDIF - ENDDO - ENDDO - ENDDO + nijds = min(nids, njds) + nijde = max(nide, njde) + CALL nl_get_spec_bdy_width( 1, spec_bdy_width ) -! - END SUBROUTINE interp_mass_nmm -! -!-------------------------------------------------------------------------------------- + IF ( interp_method_type .EQ. NOT_DEFINED_YET ) THEN + interp_method_type = SINT + END IF - SUBROUTINE nmm_bdymass_hinterp ( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - c_bxs,n_bxs, & - c_bxe,n_bxe, & - c_bys,n_bys, & - c_bye,n_bye, & - c_btxs,n_btxs, & - c_btxe,n_btxe, & - c_btys,n_btys, & - c_btye,n_btye, & - CTEMP_B,NTEMP_B, & ! These temp arrays should be removed - CTEMP_BT,NTEMP_BT, & ! later on - CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights - CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, HBWGT4, & ! dummys - CZ3d, Z3d, & ! Z3d dummy on nested domain - CFIS,FIS, & ! CFIS dummy on fine domain - CSM,SM, & ! CSM is dummy - CPDTOP,PDTOP, & - CPTOP,PTOP, & - CPSTD,PSTD, & - CKZMAX,KZMAX ) + IF ( interp_method_type .EQ. SINT ) THEN + CALL bdy_interp1( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde , & ! start and end of nest LBC size in the LONG direction + spec_bdy_width , & ! width of the LBC, the SHORT direction + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, imask, & + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & + cbdy_xs, nbdy_xs, & ! Boundary components, for the CG and FG, + cbdy_xe, nbdy_xe, & ! for each of the four sides (x start, e end, y start, y end) + cbdy_ys, nbdy_ys, & ! and also for the two components of the LBC: + cbdy_ye, nbdy_ye, & ! the "starting" value and the tendency + cbdy_txs, nbdy_txs, & + cbdy_txe, nbdy_txe, & ! The CG is at a parent time step ahead of the FG + cbdy_tys, nbdy_tys, & + cbdy_tye, nbdy_tye, & + cdt, ndt & ! Time step size for CG and FG + ) + + ELSE IF ( ( interp_method_type .EQ. BILINEAR ) .OR. & + ( interp_method_type .EQ. NEAREST_NEIGHBOR ) .OR. & + ( interp_method_type .EQ. QUADRATIC ) .OR. & + ( interp_method_type .EQ. SPLINE ) .OR. & + ( interp_method_type .EQ. SINT_NEW ) ) THEN + CALL bdy_interp2( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde , & ! start and end of nest LBC size in the LONG direction + spec_bdy_width , & ! width of the LBC, the SHORT direction + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, imask, & + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & + cbdy_xs, nbdy_xs, & ! Boundary components, for the CG and FG, + cbdy_xe, nbdy_xe, & ! for each of the four sides (x start, e end, y start, y end) + cbdy_ys, nbdy_ys, & ! and also for the two components of the LBC: + cbdy_ye, nbdy_ye, & ! the "starting" value and the tendency + cbdy_txs, nbdy_txs, & + cbdy_txe, nbdy_txe, & ! The CG is at a parent time step ahead of the FG + cbdy_tys, nbdy_tys, & + cbdy_tye, nbdy_tye, & + cdt, ndt & ! Time step size for CG and FG + ) + ELSE + CALL wrf_error_fatal ('Hold on there cowboy #2, we need to know which nested lateral boundary interpolation option you want') + END IF - USE MODULE_MODEL_CONSTANTS - USE module_configure - USE module_wrf_error + END SUBROUTINE bdy_interp - IMPLICIT NONE +!================================== + + SUBROUTINE bdy_interp1( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde, spec_bdy_width , & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw1, & + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & + cbdy_xs, bdy_xs, & + cbdy_xe, bdy_xe, & + cbdy_ys, bdy_ys, & + cbdy_ye, bdy_ye, & + cbdy_txs, bdy_txs, & + cbdy_txe, bdy_txe, & + cbdy_tys, bdy_tys, & + cbdy_tye, bdy_tye, & + cdt, ndt & + ) +! USE module_configure , ONLY : nl_get_spec_zone, nl_get_relax_zone + USE module_state_description + + IMPLICIT NONE - INTEGER, INTENT(IN) :: ckzmax,kzmax INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & nids, nide, nkds, nkde, njds, njde, & nims, nime, nkms, nkme, njms, njme, & nits, nite, nkts, nkte, njts, njte, & - shw, & + shw1, & ! ignore ipos, jpos, & nri, nrj + INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width + LOGICAL, INTENT(IN) :: xstag, ystag + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs ! not used + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe ! not used + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys ! not used + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye ! not used + REAL :: cdt, ndt + REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xs, bdy_txs + REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xe, bdy_txe + REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ys, bdy_tys + REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ye, bdy_tye - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(OUT) :: ctemp_b,ctemp_bt - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ), INTENT(OUT) :: ntemp_b,ntemp_bt - LOGICAL, INTENT(IN) :: xstag, ystag - REAL, DIMENSION( * ), INTENT(INOUT) :: c_bxs,n_bxs,c_bxe,n_bxe,c_bys,n_bys,c_bye,n_bye - REAL, DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye - -! parent domain - - INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK - INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3 - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT4,CFIS,CSM - REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CFLD - REAL,DIMENSION(cims:cime,cjms:cjme,1:KZMAX), INTENT(IN) :: CZ3d - REAL,DIMENSION(1:KZMAX), INTENT(IN) :: CPSTD - REAL,INTENT(IN) :: CPDTOP,CPTOP - -! nested domain + ! Local - INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3 - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT4 - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: FIS,SM - REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(INOUT) :: NFLD - REAL,DIMENSION(1:KZMAX), INTENT(IN) :: PSTD - REAL,DIMENSION(nims:nime,njms:njme,1:KZMAX), INTENT(OUT) :: Z3d - REAL,INTENT(IN) :: PDTOP,PTOP + REAL*8 rdt + INTEGER ci, cj, ck, ni, nj, nk, ni1, nj1, nk1, ip, jp, ioff, joff + INTEGER nfx, ior + PARAMETER (ior=2) + INTEGER nf + REAL psca1(cims:cime,cjms:cjme,nri*nrj) + REAL psca(cims:cime,cjms:cjme,nri*nrj) + LOGICAL icmask( cims:cime, cjms:cjme ) + INTEGER i,j,k + INTEGER shw + INTEGER spec_zone + INTEGER relax_zone + INTEGER sz + INTEGER n2ci,n + INTEGER n2cj -! Local +! statement functions for converting a nest index to coarse + n2ci(n) = (n+ipos*nri-1)/nri + n2cj(n) = (n+jpos*nrj-1)/nrj - INTEGER :: nijds, nijde, spec_bdy_width,i,j,k - REAL :: dlnpdz,dum2d - REAL,DIMENSION(nims:nime,njms:njme) :: zs + rdt = 1.D0/cdt - INTEGER,PARAMETER :: JTB=134 - INTEGER :: ii,jj - REAL, DIMENSION (nims:nime,njms:njme) :: CWK1,CWK2,CWK3,CWK4 - CHARACTER (LEN=256) :: a_message + shw = 0 - nijds = min(nids, njds) - nijde = max(nide, njde) - CALL nl_get_spec_bdy_width( 1, spec_bdy_width ) + ioff = 0 ; joff = 0 + IF ( xstag ) THEN + ioff = MAX((nri-1)/2,1) + ENDIF + IF ( ystag ) THEN + joff = MAX((nrj-1)/2,1) + ENDIF -! -!*** DEFINE LOCAL TOPOGRAPHY ON THE BASIS OF FIS. ASLO CHECK IF SM IS LAND (SM=0) OVER TOPO -!*** YOU DON'T WANT MOUNTAINS INSIDE WATER BODIES! -! - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - ZS(I,J)=FIS(I,J)/G - ENDDO - ENDDO + ! Iterate over the ND tile and compute the values + ! from the CD tile. -! X start boundary + CALL nl_get_spec_zone( 1, spec_zone ) + CALL nl_get_relax_zone( 1, relax_zone ) + sz = MIN(MAX( spec_zone, relax_zone + 1 ),spec_bdy_width) - NMM_XS: IF(NITS .EQ. NIDS)THEN -! WRITE(0,*)'ENTERING X1 START BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1) - I = NIDS + nfx = nri * nrj - DO K=NKTS,KZMAX - DO J = NJTS,MIN(NJTE,NJDE-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain - Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CZ3d(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CZ3d(IIH(I,J), JJH(I,J)+1,K) - ELSE - Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF - END DO - END DO + !$OMP PARALLEL DO & + !$OMP PRIVATE ( i,j,k,ni,nj,ni1,nj1,ci,cj,ip,jp,nk,ck,nf,icmask,psca,psca1 ) + DO k = ckts, ckte - DO J = NJTS,MIN(NJTE,NJDE-1) - IF(MOD(J,2) .NE. 0)THEN - IF (ZS(I,J) .LT. Z3d(I,J,2)) THEN ! level 2 has to be changed - dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(I,J,1)-Z3d(I,J,2)) - dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(I,J,1))) - CWK1(I,J) = dum2d -PDTOP -PTOP - ELSE ! target level bounded by input levels - DO K =NKTS,KZMAX-1 - IF(ZS(I,J) .GE. Z3d(I,J,K) .AND. ZS(I,J) .LT. Z3d(I,J,K+1))THEN - dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(I,J,K)-Z3d(I,J,K+1)) - dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(I,J,K))) - CWK1(I,J) = dum2d -PDTOP -PTOP - ENDIF + DO nf = 1,nfx + DO j = cjms,cjme + nj = (j-jpos) * nrj + ( nrj / 2 + 1 ) ! j point on nest + DO i = cims,cime + ni = (i-ipos) * nri + ( nri / 2 + 1 ) ! i point on nest + psca1(i,j,nf) = cfld(i,k,j) ENDDO - ENDIF - IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN - WRITE(a_message,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX) - CALL wrf_message ( a_message ) - CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH") - ENDIF - ELSE - CWK1(I,J)=0. - ENDIF + ENDDO ENDDO - - DO J = NJTS,MIN(NJTE,NJDE-1) - DO K = NKDS,NKDE - ntemp_b(i,j,k) = CWK1(I,J) - ntemp_bt(i,j,k) = 0.0 - END DO - END DO - ENDIF NMM_XS - -! X end boundary - - NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN -! WRITE(0,*)'ENTERING X END BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1) - I = NIDE-1 - II = NIDE - I - - DO K=NKTS,KZMAX - DO J=NJTS,MIN(NJTE,NJDE-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CZ3d(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CZ3d(IIH(I,J), JJH(I,J)+1,K) - ELSE - Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF - ENDDO - ENDDO - - DO J = NJTS,MIN(NJTE,NJDE-1) - IF(MOD(J,2) .NE.0)THEN ! 1,3,5,7 of nested domain - IF (ZS(I,J) .LT. Z3d(I,J,2)) THEN ! level 2 has to be changed - dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(I,J,1)-Z3d(I,J,2)) - dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(I,J,1))) - CWK2(I,J) = dum2d -PDTOP -PTOP - ELSE ! target level bounded by input levels - DO K =NKTS,KZMAX-1 - IF(ZS(I,J) .GE. Z3d(I,J,K) .AND. ZS(I,J) .LT. Z3d(I,J,K+1))THEN - dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(I,J,K)-Z3d(I,J,K+1)) - dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(I,J,K))) - CWK2(I,J) = dum2d -PDTOP -PTOP +! hopefully less ham handed but still correct and more efficient +! sintb ignores icmask so it does not matter that icmask is not set +! +! SOUTH BDY + IF ( njts .ge. njds .and. njts .le. njds + sz + joff ) THEN + CALL sintb( psca1, psca, & + cims, cime, cjms, cjme, icmask, & + n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njds)), n2cj(MIN(njte,njds+sz+joff)), nrj*nri, xstag, ystag ) ENDIF - ENDDO - ENDIF - IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN - WRITE(a_message,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX) - CALL wrf_message ( a_message ) - CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH") - ENDIF - ELSE - CWK2(I,J) = 0.0 - ENDIF - ENDDO - - DO J = NJTS,MIN(NJTE,NJDE-1) - DO K = NKDS,NKDE - ntemp_b(i,j,k) = CWK2(I,J) - ntemp_bt(i,j,k) = 0.0 - END DO - END DO - ENDIF NMM_XE - -! Y start boundary - - NMM_YS: IF(NJTS .EQ. NJDS)THEN -! WRITE(20,*)'ENTERING Y START BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1) - J = NJDS - DO K=NKTS,KZMAX - DO I = NITS,MIN(NITE,NIDE-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CZ3d(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CZ3d(IIH(I,J), JJH(I,J)+1,K) - ELSE - Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF - END DO - END DO - - DO I = NITS,MIN(NITE,NIDE-1) - IF (ZS(I,J) .LT. Z3d(I,J,2)) THEN ! level 2 has to be changed - dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(I,J,1)-Z3d(I,J,2)) - dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(I,J,1))) - CWK3(I,J) = dum2d -PDTOP -PTOP - ELSE ! target level bounded by input levels - DO K =NKTS,KZMAX-1 - IF(ZS(I,J) .GE. Z3d(I,J,K) .AND. ZS(I,J) .LT. Z3d(I,J,K+1))THEN - dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(I,J,K)-Z3d(I,J,K+1)) - dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(I,J,K))) - CWK3(I,J) = dum2d -PDTOP -PTOP +! NORTH BDY + IF ( njte .le. njde .and. njte .ge. njde - sz - joff ) THEN + CALL sintb( psca1, psca, & + cims, cime, cjms, cjme, icmask, & + n2ci(nits)-1, n2ci(nite)+1, n2cj(MAX(njts,njde-sz-joff)), n2cj(MIN(njte,njde-1+joff)), nrj*nri, xstag, ystag ) ENDIF - ENDDO - ENDIF - IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN - WRITE(a_message,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX) - CALL wrf_message ( a_message ) - CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH") - ENDIF - ENDDO - - DO K = NKDS, NKDE - DO I = NITS,MIN(NITE,NIDE-1) - ntemp_b(i,j,k) = CWK3(I,J) - ntemp_bt(i,j,k) = 0.0 - END DO - END DO - END IF NMM_YS - -! Y end boundary - - NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN -! WRITE(20,*)'ENTERING Y END BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1) - J = NJDE-1 - JJ = NJDE - J - DO K=NKTS,KZMAX - DO I = NITS,MIN(NITE,NIDE-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CZ3d(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CZ3d(IIH(I,J), JJH(I,J)+1,K) - ELSE - Z3d(I,J,K) = HBWGT1(I,J)*CZ3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CZ3d(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF - END DO - END DO - - DO I = NITS,MIN(NITE,NIDE-1) - IF (ZS(I,J) .LT. Z3d(I,J,2)) THEN ! level 2 has to be changed - dlnpdz = (log(PSTD(1))-log(PSTD(2)) )/(Z3d(I,J,1)-Z3d(I,J,2)) - dum2d = exp(log(PSTD(1)) + dlnpdz*(ZS(I,J) - Z3d(I,J,1))) - CWK4(I,J) = dum2d -PDTOP -PTOP - ELSE ! target level bounded by input levels - DO K =NKTS,KZMAX-1 - IF(ZS(I,J) .GE. Z3d(I,J,K) .AND. ZS(I,J) .LT. Z3d(I,J,K+1))THEN - dlnpdz = (log(PSTD(K))-log(PSTD(K+1)) ) /(Z3d(I,J,K)-Z3d(I,J,K+1)) - dum2d = exp(log(PSTD(K)) + dlnpdz*(ZS(I,J)- Z3d(I,J,K))) - CWK4(I,J) = dum2d -PDTOP -PTOP +! WEST BDY + IF ( nits .ge. nids .and. nits .le. nids + sz + ioff ) THEN + CALL sintb( psca1, psca, & + cims, cime, cjms, cjme, icmask, & + n2ci(MAX(nits,nids)), n2ci(MIN(nite,nids+sz+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag ) + ENDIF +! EAST BDY + IF ( nite .le. nide .and. nite .ge. nide - sz - ioff ) THEN + CALL sintb( psca1, psca, & + cims, cime, cjms, cjme, icmask, & + n2ci(MAX(nits,nide-sz-ioff)), n2ci(MIN(nite,nide-1+ioff)), n2cj(njts)-1, n2cj(njte)+1, nrj*nri, xstag, ystag ) ENDIF - ENDDO - ENDIF - IF(ZS(I,J) .GE. Z3d(I,J,KZMAX))THEN - WRITE(a_message,*)'I=',I,'J=',J,'K=',K,'TERRAIN HEIGHT',ZS(I,J),'Z3d',Z3d(I,J,KZMAX) - CALL wrf_message ( a_message ) - CALL wrf_error_fatal("BC:MOUNTAIN TOO HIGH TO FIT THE MODEL DEPTH") - ENDIF - ENDDO - - DO K = NKDS,NKDE - DO I = NITS,MIN(NITE,NIDE-1) - ntemp_b(i,j,k) = CWK4(I,J) - ntemp_bt(i,j,k) = 0.0 - END DO - END DO - END IF NMM_YE - - RETURN - - END SUBROUTINE nmm_bdymass_hinterp -! -!======================================================================================= -! -! ADDED FOR INCLUDING MOISTURE AND THERMODYNAMIC ENERGY BALANCE -! -!======================================================================================= - - SUBROUTINE interp_scalar_nmm (cfld, & ! CD field - cids,cide,ckds,ckde,cjds,cjde, & - cims,cime,ckms,ckme,cjms,cjme, & - cits,cite,ckts,ckte,cjts,cjte, & - nfld, & ! ND field - nids,nide,nkds,nkde,njds,njde, & - nims,nime,nkms,nkme,njms,njme, & - nits,nite,nkts,nkte,njts,njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag,ystag, & ! staggering of field - ipos,jpos, & ! Position of lower left of nest in CD - nri,nrj, & ! nest ratios - CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights - CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, HBWGT4, & ! dummys for weights - CC3d,C3d, & - CPD,PD, & - CPSTD,PSTD, & - CPDTOP,PDTOP, & - CPTOP,PTOP, & - CETA1,ETA1,CETA2,ETA2 ) - - USE MODULE_MODEL_CONSTANTS - USE module_timing - IMPLICIT NONE - - LOGICAL,INTENT(IN) :: xstag, ystag - INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw,ipos,jpos,nri,nrj - - INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK - -! parent domain - - INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2 - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT3,CBWGT4 - REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CFLD - REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CC3d ! scalar input on constant pressure levels - REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CPSTD - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CPD - REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CETA1,CETA2 - REAL, INTENT(IN) :: CPDTOP,CPTOP + DO nj1 = MAX(njds,njts-1), MIN(njde+joff,njte+joff+1) + cj = jpos + (nj1-1) / nrj ! j coord of CD point + jp = mod ( nj1-1 , nrj ) ! coord of ND w/i CD point + nk = k + ck = nk + DO ni1 = MAX(nids,nits-1), MIN(nide+ioff,nite+ioff+1) + ci = ipos + (ni1-1) / nri ! j coord of CD point + ip = mod ( ni1-1 , nri ) ! coord of ND w/i CD point -! nested domain + ni = ni1-ioff + nj = nj1-joff - INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2 - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT3,HBWGT4 + IF ( ( ni.LT.nids) .OR. (nj.LT.njds) ) THEN + CYCLE + END IF - REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(OUT):: NFLD ! This is scalar on hybrid levels - REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(OUT):: C3d ! Scalar on constant pressure levels - REAL,DIMENSION(nkms:nkme), INTENT(IN) :: PSTD - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: PD - REAL,DIMENSION(nkms:nkme), INTENT(IN) :: ETA1,ETA2 - REAL,INTENT(IN) :: PDTOP,PTOP +!bdy contains the value at t-dt. psca contains the value at t +!compute dv/dt and store in bdy_t +!afterwards store the new value of v at t into bdy + ! WEST + IF ( ni .ge. nids .and. ni .lt. nids + sz ) THEN + bdy_txs( nj,k,ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_xs( nj,k,ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF -! local + ! SOUTH + IF ( nj .ge. njds .and. nj .lt. njds + sz ) THEN + bdy_tys( ni,k,nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_ys( ni,k,nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF - INTEGER,PARAMETER :: JTB=134 - INTEGER :: I,J,K - REAL,DIMENSION(JTB) :: PIN,CIN,Y2,PIO,PTMP,COUT,DUM1,DUM2 - CHARACTER (LEN=256) :: a_message + ! EAST + IF ( xstag ) THEN + IF ( ni .ge. nide - sz + 1 .AND. ni .le. nide ) THEN + bdy_txe( nj,k,nide-ni+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_xe( nj,k,nide-ni+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF + ELSE + IF ( ni .ge. nide - sz .AND. ni .le. nide-1 ) THEN + bdy_txe( nj,k,nide-ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_xe( nj,k,nide-ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF + ENDIF -!----------------------------------------------------------------------------------------------------- -! -! -! *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE OR LINEAR INTERPOLATION -! - IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) & - CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm') + ! NORTH + IF ( ystag ) THEN + IF ( nj .ge. njde - sz + 1 .AND. nj .le. njde ) THEN + bdy_tye( ni,k,njde-nj+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_ye( ni,k,njde-nj+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF + ELSE + IF ( nj .ge. njde - sz .AND. nj .le. njde-1 ) THEN + bdy_tye(ni,k,njde-nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) + bdy_ye( ni,k,njde-nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + ENDIF + ENDIF -! -! FIRST, HORIZONTALLY INTERPOLATE MOISTURE NOW AVAILABLE ON CONSTANT PRESSURE SURFACE (LEVELS) FROM THE -! PARENT TO THE NESTED DOMAIN -! -!*** INDEX CONVENTIONS -!*** HBWGT4 -!*** 4 -!*** -!*** -!*** -!*** h -!*** 1 2 -!*** HBWGT1 HBWGT2 -!*** -!*** -!*** 3 -!*** HBWGT3 + ENDDO + ENDDO + ENDDO + !$OMP END PARALLEL DO + + RETURN - C3d=0.0 - DO K=NKDS,NKDE-1 ! Please note that we are still in isobaric surfaces - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CC3d(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CC3d(IIH(I,J), JJH(I,J)+1,K) + END SUBROUTINE bdy_interp1 - ELSE - C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)+1,K) +!================================== - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO + SUBROUTINE bdy_interp2( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nijds, nijde, spec_bdy_width , & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw1, & + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & + cbdy_xs, bdy_xs, & + cbdy_xe, bdy_xe, & + cbdy_ys, bdy_ys, & + cbdy_ye, bdy_ye, & + cbdy_txs, bdy_txs, & + cbdy_txe, bdy_txe, & + cbdy_tys, bdy_tys, & + cbdy_tye, bdy_tye, & + cdt, ndt & + ) -! -! RECOVER THE SCALARS FROM CONSTANT PRESSURE SURFACES (LEVELS) ON TO HYBRID SURFACES -! - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN +! USE module_configure , ONLY : nl_get_spec_zone, nl_get_relax_zone +! USE module_state_description + USE module_interp_info -! clean local array before use of spline or linear interpolation + IMPLICIT NONE - CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw1, & ! ignore + ipos, jpos, & + nri, nrj + INTEGER, INTENT(IN) :: nijds, nijde, spec_bdy_width + LOGICAL, INTENT(IN) :: xstag, ystag - DO K=NKDS+1,NKDE ! inputs at standard levels - PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5) - CIN(K-1) = C3d(I,J,NKDE-K+1) - ENDDO + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(INOUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(INOUT) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xs, cbdy_txs ! not used + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_xe, cbdy_txe ! not used + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ys, cbdy_tys ! not used + REAL, DIMENSION ( * ), INTENT(INOUT) :: cbdy_ye, cbdy_tye ! not used + REAL :: cdt, ndt + REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xs, bdy_txs + REAL, DIMENSION ( njms:njme, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_xe, bdy_txe + REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ys, bdy_tys + REAL, DIMENSION ( nims:nime, nkms:nkme, spec_bdy_width ), INTENT(INOUT) :: bdy_ye, bdy_tye - Y2(1 )=0. - Y2(NKDE-1)=0. + ! Local - DO K=NKDS,NKDE ! target points in model interface levels (pint) - PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP - ENDDO + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld_horiz_interp ! mem dimensioned on purpose + ! to allow interpolating routine + ! to assume this is a mem + ! sized array + INTEGER ni, nj, nk, istag, jstag + INTEGER shw + INTEGER spec_zone + INTEGER relax_zone + INTEGER sz + REAL*8 rdt - DO K=NKDS,NKDE-1 ! target points in model levels - PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5) - ENDDO + shw = 0 ! dummy, not used, but needed for the calling interface - IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary - PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all - WRITE(a_message,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD' - CALL wrf_message ( a_message ) - WRITE(a_message,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1) - CALL wrf_message ( a_message ) - ENDIF + ! Horizontally interpolate the CG to the FG, store in nfld_horiz_interp - CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate + CALL interp_fcn ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld_horiz_interp, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + MAX(nits-nri,nids),MIN(nite+nri,nide),& + nkts, nkte, & + MAX(njts-nrj,njds),MIN(njte+nrj,njde),& + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD +! ipos-1, jpos-1, & ! Position of lower left of nest in CD + nri, nrj ) ! Nest ratio, i- and j-directions + + ! Staggering, to determine loop indexes - DO K=1,NKDE-1 - NFLD(I,J,K)= COUT(K) ! scalar in the nested domain - ENDDO + IF ( xstag ) THEN + istag = 0 + ELSE + istag = 1 + END IF + IF ( ystag ) THEN + jstag = 0 + ELSE + jstag = 1 + END IF - ENDIF - ENDDO - ENDDO + ! CG time step reciprocal, for computing tendencies. - END SUBROUTINE interp_scalar_nmm -! -!=========================================================================================== -! - SUBROUTINE nmm_bdy_scalar (cfld, & ! CD field - cids,cide,ckds,ckde,cjds,cjde, & - cims,cime,ckms,ckme,cjms,cjme, & - cits,cite,ckts,ckte,cjts,cjte, & - nfld, & ! ND field - nids,nide,nkds,nkde,njds,njde, & - nims,nime,nkms,nkme,njms,njme, & - nits,nite,nkts,nkte,njts,njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag,ystag, & ! staggering of field - ipos,jpos, & ! Position of lower left of nest in CD - nri,nrj, & ! nest ratios - c_bxs,n_bxs, & - c_bxe,n_bxe, & - c_bys,n_bys, & - c_bye,n_bye, & - c_btxs,n_btxs, & - c_btxe,n_btxe, & - c_btys,n_btys, & - c_btye,n_btye, & - cdt, ndt, & - CTEMP_B,NTEMP_B, & ! to be removed - CTEMP_BT,NTEMP_BT, & - CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights - CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, HBWGT4, & ! dummys for weights - CC3d,C3d, & - CPD,PD, & - CPSTD,PSTD, & - CPDTOP,PDTOP, & - CPTOP,PTOP, & - CETA1,ETA1,CETA2,ETA2 ) - USE MODULE_MODEL_CONSTANTS - USE module_timing - IMPLICIT NONE + rdt = 1.D0/cdt - LOGICAL,INTENT(IN) :: xstag, ystag - REAL, INTENT(INOUT) :: cdt, ndt - INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw,ipos,jpos,nri,nrj - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(OUT) :: ctemp_b,ctemp_bt - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ), INTENT(OUT) :: ntemp_b,ntemp_bt - REAL, DIMENSION( * ), INTENT(INOUT) :: c_bxs,n_bxs,c_bxe,n_bxe,c_bys,n_bys,c_bye,n_bye - REAL, DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye - - - INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK - -! parent domain - - INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2 - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT3,CBWGT4 - REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CFLD - REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(IN) :: CC3d ! scalar input on constant pressure levels - REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CPSTD - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CPD - REAL,DIMENSION(ckms:ckme), INTENT(IN) :: CETA1,CETA2 - REAL, INTENT(IN) :: CPDTOP,CPTOP - -! nested domain - - INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2 - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT3,HBWGT4 - REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(OUT):: NFLD - REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(OUT):: C3d !Scalar on constant pressure levels - REAL,DIMENSION(nkms:nkme), INTENT(IN) :: PSTD - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: PD - REAL,DIMENSION(nkms:nkme), INTENT(IN) :: ETA1,ETA2 - REAL,INTENT(IN) :: PDTOP,PTOP - -! local - - INTEGER,PARAMETER :: JTB=134 - INTEGER :: I,J,K,II,JJ - REAL,DIMENSION(JTB) :: PIN,CIN,Y2,PIO,PTMP,COUT,DUM1,DUM2 - REAL, DIMENSION (nims:nime,njms:njme,nkms:nkme) :: CWK1,CWK2,CWK3,CWK4 - CHARACTER (LEN=256) :: a_message -!----------------------------------------------------------------------------------------------------- -! -! -! *** CHECK VERTICAL BOUNDS BEFORE USING SPLINE INTERPOLATION -! - IF(nkme .GT. (JTB-10) .OR. NKDE .GT. (JTB-10)) & - CALL wrf_error_fatal ('mass points: increase JTB in interp_mass_nmm') - -! X start boundary - - NMM_XS: IF(NITS .EQ. NIDS)THEN -! WRITE(0,*)'ENTERING X1 START BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1) - I = NIDS - DO K=NKDS,NKDE-1 ! Please note that we are still in isobaric surfaces - DO J = NJTS,MIN(NJTE,NJDE-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain - C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CC3d(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CC3d(IIH(I,J), JJH(I,J)+1,K) - ELSE - C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF - ENDDO - ENDDO -! - DO J=NJTS,MIN(NJTE,NJDE-1) - IF(MOD(J,2) .NE. 0)THEN - CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array - DO K=NKDS+1,NKDE ! inputs at standard levels - PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5) - CIN(K-1) = C3d(I,J,NKDE-K+1) - ENDDO - Y2(1 )=0. - Y2(NKDE-1)=0. - DO K=NKDS,NKDE ! target points in model interface levels (pint) - PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP - ENDDO - DO K=NKDS,NKDE-1 ! target points in model levels - PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5) - ENDDO - IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary - PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all - WRITE(a_message,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD' - CALL wrf_message ( a_message ) - WRITE(a_message,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1) - CALL wrf_message ( a_message ) - ENDIF + CALL nl_get_spec_zone( 1, spec_zone ) + CALL nl_get_relax_zone( 1, relax_zone ) - CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate + ! Belt and suspenders ... sz is just spec_bdy_width. - DO K=1,NKDE-1 - CWK1(I,J,K)= COUT(K) ! scalar in the nested domain - ENDDO - ELSE - DO K=NKDS,NKDE-1 - CWK1(I,J,K)=0.0 - ENDDO - ENDIF - ENDDO + sz = MIN(MAX( spec_zone, relax_zone + 1 ),spec_bdy_width) - DO J = NJTS,MIN(NJTE,NJDE-1) - DO K = NKDS,NKDE-1 - ntemp_b(i,j,k) = CWK1(I,J,K) - ntemp_bt(i,j,k) = 0.0 - END DO - END DO + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ni,nj,nk ) + + DO nj = MAX ( njts-nrj, njds ) , MIN ( njte+nrj, njde-jstag ) + DO nk = nkts, nkte + DO ni = MAX( nits-nri, nids ) , MIN ( nite+nri, nide-istag ) - ENDIF NMM_XS - - -! X end boundary - - NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN -! WRITE(0,*)'ENTERING X END BOUNDARY AT T POINTS',NJTS,MIN(NJTE,NJDE-1) - I = NIDE-1 - DO K=NKDS,NKDE-1 ! Please note that we are still in isobaric surfaces - DO J = NJTS,MIN(NJTE,NJDE-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain - C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CC3d(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CC3d(IIH(I,J), JJH(I,J)+1,K) - ELSE - C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF - ENDDO - ENDDO + ! WEST boundary - DO J=NJTS,MIN(NJTE,NJDE-1) - IF(MOD(J,2) .NE. 0)THEN - CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array - DO K=NKDS+1,NKDE ! inputs at standard levels - PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5) - CIN(K-1) = C3d(I,J,NKDE-K+1) - ENDDO - Y2(1 )=0. - Y2(NKDE-1)=0. - DO K=NKDS,NKDE ! target points in model interface levels (pint) - PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP - ENDDO - DO K=NKDS,NKDE-1 ! target points in model levels - PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5) - ENDDO - IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary - PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all - WRITE(a_message,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD' - CALL wrf_message ( a_message ) - WRITE(a_message,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1) - CALL wrf_message ( a_message ) - ENDIF + IF ( ni .LT. nids + sz ) THEN + bdy_txs(nj,nk,ni) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) + bdy_xs (nj,nk,ni) = nfld_horiz_interp(ni,nk,nj) + END IF - CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate + ! SOUTH boundary - DO K=1,NKDE-1 - CWK2(I,J,K)= COUT(K) ! scalar in the nested domain - ENDDO - ELSE - DO K=NKDS,NKDE-1 - CWK2(I,J,K)=0.0 - ENDDO - ENDIF - ENDDO + IF ( nj .LT. njds + sz ) THEN + bdy_tys(ni,nk,nj) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) + bdy_ys (ni,nk,nj) = nfld_horiz_interp(ni,nk,nj) + END IF - DO J = NJTS,MIN(NJTE,NJDE-1) - DO K = NKDS,MIN(NKTE,NKDE-1) - ntemp_b(i,j,k) = CWK2(I,J,K) - ntemp_bt(i,j,k) = 0.0 - END DO - END DO - - ENDIF NMM_XE - -! Y start boundary - - NMM_YS: IF(NJTS .EQ. NJDS)THEN -! WRITE(0,*)'ENTERING Y START BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1) - J = NJDS - DO K=NKDS,NKDE-1 - DO I = NITS,MIN(NITE,NIDE-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain - C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CC3d(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CC3d(IIH(I,J), JJH(I,J)+1,K) - ELSE - C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)+1,K) - - ENDIF - ENDDO - ENDDO -! - DO I=NITS,MIN(NITE,NIDE-1) - CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array - DO K=NKDS+1,NKDE ! inputs at standard levels - PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5) - CIN(K-1) = C3d(I,J,NKDE-K+1) - ENDDO - Y2(1 )=0. - Y2(NKDE-1)=0. - DO K=NKDS,NKDE ! target points in model interface levels (pint) - PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP - ENDDO - DO K=NKDS,NKDE-1 ! target points in model levels - PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5) - ENDDO - IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary - PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all - WRITE(a_message,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD' - CALL wrf_message ( a_message ) - WRITE(a_message,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1) - CALL wrf_message ( a_message ) - ENDIF + ! EAST boundary - CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate + IF ( xstag ) THEN + IF ( ( ni .GE. nide - sz + 1 ) .AND. ( ni .LE. nide ) ) THEN + bdy_txe(nj,nk,nide-ni+1) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) + bdy_xe (nj,nk,nide-ni+1) = nfld_horiz_interp(ni,nk,nj) + END IF + ELSE + IF ( ( ni .GE. nide - sz ) .AND. ( ni .LE. nide-1 ) ) THEN + bdy_txe(nj,nk,nide-ni ) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) + bdy_xe (nj,nk,nide-ni ) = nfld_horiz_interp(ni,nk,nj) + END IF + END IF - DO K=1,NKDE-1 - CWK3(I,J,K)= COUT(K) ! scalar in the nested domain - ENDDO - ENDDO + ! NORTH boundary - DO K = NKDS,NKDE-1 - DO I = NITS,MIN(NITE,NIDE-1) - ntemp_b(i,J,K) = CWK3(I,J,K) - ntemp_bt(i,J,K) = 0.0 - ENDDO - ENDDO + IF ( ystag ) THEN + IF ( ( nj .GE. njde - sz + 1 ) .AND. ( nj .LE. njde ) ) THEN + bdy_tye(ni,nk,njde-nj+1) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) + bdy_ye (ni,nk,njde-nj+1) = nfld_horiz_interp(ni,nk,nj) + END IF + ELSE + IF ( ( nj .GE. njde - sz ) .AND. ( nj .LE. njde-1 ) ) THEN + bdy_tye(ni,nk,njde-nj ) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) + bdy_ye (ni,nk,njde-nj ) = nfld_horiz_interp(ni,nk,nj) + END IF + END IF - ENDIF NMM_YS - -! Y end boundary - - NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN -! WRITE(0,*)'ENTERING Y END BOUNDARY AT T POINTS',NITS,MIN(NITE,NIDE-1) - J = NJDE-1 - DO K=NKDS,NKDE-1 - DO I = NITS,MIN(NITE,NIDE-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain - C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CC3d(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CC3d(IIH(I,J), JJH(I,J)+1,K) - ELSE - C3d(I,J,K) = HBWGT1(I,J)*CC3d(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CC3d(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CC3d(IIH(I,J)+1,JJH(I,J)+1,K) - - ENDIF - ENDDO - ENDDO + END DO ! nest i + END DO ! nest k + END DO ! nest j - DO I=NITS,MIN(NITE,NIDE-1) - CIN=0.;PIN=0.;Y2=0;PIO=0.;PTMP=0.;COUT=0.;DUM1=0.;DUM2=0. ! clean up local array - DO K=NKDS+1,NKDE ! inputs at standard levels - PIN(K-1) = EXP((ALOG(PSTD(NKDE-K+1))+ALOG(PSTD(NKDE-K+2)))*0.5) - CIN(K-1) = C3d(I,J,NKDE-K+1) - ENDDO - Y2(1 )=0. - Y2(NKDE-1)=0. - DO K=NKDS,NKDE ! target points in model interface levels (pint) - PTMP(K) = ETA1(K)*PDTOP + ETA2(K)*PD(I,J) + PTOP - ENDDO - DO K=NKDS,NKDE-1 ! target points in model levels - PIO(K) = EXP((ALOG(PTMP(K))+ALOG(PTMP(K+1)))*0.5) - ENDDO - IF(PTMP(1) .GE. PSTD(1))THEN ! if lower boundary is higher than PMSL(1) re-set lower boundary - PIN(NKDE-1) = PIO(1) ! be consistent with target. This may not happen at all - WRITE(a_message,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD' - CALL wrf_message ( a_message ) - WRITE(a_message,*)'I,J,PIO(1),PSTD(1)',I,J,PIO(1),PSTD(1) - CALL wrf_message ( a_message ) - ENDIF + !$OMP END PARALLEL DO - CALL SPLINE2(I,J,JTB,NKDE-1,PIN,CIN,Y2,NKDE-1,PIO,COUT,DUM1,DUM2) ! interpolate + END SUBROUTINE bdy_interp2 - DO K=1,NKDE-1 - CWK4(I,J,K)= COUT(K) ! scalar in the nested domain - ENDDO - ENDDO +!================================== - DO K = NKDS,NKDE-1 - DO I = NITS,MIN(NITE,NIDE-1) - ntemp_b(i,J,K) = CWK4(I,J,K) - ntemp_bt(i,J,K) = 0.0 - END DO - END DO + SUBROUTINE interp_fcni( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios + USE module_configure + IMPLICIT NONE - ENDIF NMM_YE - END SUBROUTINE nmm_bdy_scalar -! -! -!======================================================================================= - SUBROUTINE SPLINE2(I,J,JTBX,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) -! -! ****************************************************************** -! * * -! * THIS IS A ONE-DIMENSIONAL CUBIC SPLINE FITTING ROUTINE * -! * PROGRAMED FOR A SMALL SCALAR MACHINE. * -! * * -! * PROGRAMER Z. JANJIC * -! * * -! * NOLD - NUMBER OF GIVEN VALUES OF THE FUNCTION. MUST BE GE 3. * -! * XOLD - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE * -! * FUNCTION ARE GIVEN. MUST BE IN ASCENDING ORDER. * -! * YOLD - THE GIVEN VALUES OF THE FUNCTION AT THE POINTS XOLD. * -! * Y2 - THE SECOND DERIVATIVES AT THE POINTS XOLD. IF NATURAL * -! * SPLINE IS FITTED Y2(1)=0. AND Y2(NOLD)=0. MUST BE * -! * SPECIFIED. * -! * NNEW - NUMBER OF VALUES OF THE FUNCTION TO BE CALCULATED. * -! * XNEW - LOCATIONS OF THE POINTS AT WHICH THE VALUES OF THE * -! * FUNCTION ARE CALCULATED. XNEW(K) MUST BE GE XOLD(1) * -! * AND LE XOLD(NOLD). * -! * YNEW - THE VALUES OF THE FUNCTION TO BE CALCULATED. * -! * P, Q - AUXILIARY VECTORS OF THE LENGTH NOLD-2. * -! * * -! ****************************************************************** -!--------------------------------------------------------------------- - IMPLICIT NONE -!--------------------------------------------------------------------- - INTEGER,INTENT(IN) :: I,J,JTBX,NNEW,NOLD - REAL,DIMENSION(JTBX),INTENT(IN) :: XNEW,XOLD,YOLD - REAL,DIMENSION(JTBX),INTENT(INOUT) :: P,Q,Y2 - REAL,DIMENSION(JTBX),INTENT(OUT) :: YNEW -! - INTEGER :: II,JJ,K,K1,K2,KOLD,NOLDM1 - REAL :: AK,BK,CK,DEN,DX,DXC,DXL,DXR,DYDXL,DYDXR & - ,RDX,RTDXC,X,XK,XSQ,Y2K,Y2KP1 - CHARACTER (LEN=256) :: a_message -!--------------------------------------------------------------------- - -! debug - - II=9999 - JJ=9999 - IF(I.eq.II.and.J.eq.JJ)THEN - WRITE(a_message,*)'DEBUG in SPLINE2: I,J',I,J - CALL wrf_message ( a_message ) - WRITE(a_message,*)'DEBUG in SPLINE2:HSO= ',xnew(1:nold) - CALL wrf_message ( a_message ) - DO K=1,NOLD - WRITE(a_message,*)'DEBUG in SPLINE2:L,ZETAI,PINTI= ',K,YOLD(K),XOLD(K) - CALL wrf_message ( a_message ) - ENDDO - ENDIF -! - NOLDM1=NOLD-1 -! - DXL=XOLD(2)-XOLD(1) - DXR=XOLD(3)-XOLD(2) - DYDXL=(YOLD(2)-YOLD(1))/DXL - DYDXR=(YOLD(3)-YOLD(2))/DXR - RTDXC=0.5/(DXL+DXR) -! - P(1)= RTDXC*(6.*(DYDXR-DYDXL)-DXL*Y2(1)) - Q(1)=-RTDXC*DXR -! - IF(NOLD.EQ.3)GO TO 150 -!--------------------------------------------------------------------- - K=3 -! - 100 DXL=DXR - DYDXL=DYDXR - DXR=XOLD(K+1)-XOLD(K) - DYDXR=(YOLD(K+1)-YOLD(K))/DXR - DXC=DXL+DXR - DEN=1./(DXL*Q(K-2)+DXC+DXC) -! - P(K-1)= DEN*(6.*(DYDXR-DYDXL)-DXL*P(K-2)) - Q(K-1)=-DEN*DXR -! - K=K+1 - IF(K.LT.NOLD)GO TO 100 -!----------------------------------------------------------------------- - 150 K=NOLDM1 -! - 200 Y2(K)=P(K-1)+Q(K-1)*Y2(K+1) -! - K=K-1 - IF(K.GT.1)GO TO 200 -!----------------------------------------------------------------------- - K1=1 -! - 300 XK=XNEW(K1) -! - DO 400 K2=2,NOLD -! - IF(XOLD(K2).GT.XK)THEN - KOLD=K2-1 - GO TO 450 - ENDIF -! - 400 CONTINUE -! - YNEW(K1)=YOLD(NOLD) - GO TO 600 -! - 450 IF(K1.EQ.1)GO TO 500 - IF(K.EQ.KOLD)GO TO 550 -! - 500 K=KOLD -! - Y2K=Y2(K) - Y2KP1=Y2(K+1) - DX=XOLD(K+1)-XOLD(K) - RDX=1./DX -! - AK=.1666667*RDX*(Y2KP1-Y2K) - BK=0.5*Y2K - CK=RDX*(YOLD(K+1)-YOLD(K))-.1666667*DX*(Y2KP1+Y2K+Y2K) -! - 550 X=XK-XOLD(K) - XSQ=X*X -! - YNEW(K1)=AK*XSQ*X+BK*XSQ+CK*X+YOLD(K) + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag -! debug + INTEGER, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + INTEGER, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - IF(I.eq.II.and.J.eq.JJ)THEN - WRITE(a_message,*) 'DEBUG:: k1,xnew(k1),ynew(k1): ', K1,XNEW(k1),YNEW(k1) - CALL wrf_message ( a_message ) - ENDIF + ! Local -! - 600 K1=K1+1 - IF(K1.LE.NNEW)GO TO 300 + INTEGER ci, cj, ck, ni, nj, nk, ip, jp - RETURN + ! Iterate over the ND tile and compute the values + ! from the CD tile. - END SUBROUTINE SPLINE2 +!write(0,'("cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte +!write(0,'("nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte -!======================================================================================= -! E grid interpolation for H and V points -!======================================================================================= + DO nj = njts, njte + cj = jpos + (nj-1) / nrj ! j coord of CD point + jp = mod ( nj , nrj ) ! coord of ND w/i CD point + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + if ( imask(ni,nj) .NE. 1 ) cycle + ci = ipos + (ni-1) / nri ! j coord of CD point + ip = mod ( ni , nri ) ! coord of ND w/i CD point + ! This is a trivial implementation of the interp_fcn; just copies + ! the values from the CD into the ND + nfld( ni, nk, nj ) = cfld( ci , ck , cj ) + ENDDO + ENDDO + ENDDO + + RETURN + + END SUBROUTINE interp_fcni - SUBROUTINE interp_h_nmm (cfld, & ! CD field + SUBROUTINE interp_fcnm( cfld, & ! CD field cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -3901,17 +2627,15 @@ SUBROUTINE interp_h_nmm (cfld, & ! CD field nids, nide, nkds, nkde, njds, njde, & nims, nime, nkms, nkme, njms, njme, & nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp + shw, & ! stencil half width imask, & ! interpolation mask xstag, ystag, & ! staggering of field ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights - CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, HBWGT4 ) ! dummys for weights - USE module_timing + nri, nrj ) ! nest ratios + USE module_configure IMPLICIT NONE + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -3923,67 +2647,40 @@ SUBROUTINE interp_h_nmm (cfld, & ! CD field nri, nrj LOGICAL, INTENT(IN) :: xstag, ystag - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld - REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy - REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 - INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask -! local - INTEGER i,j,k -! -!*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION -! - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) & - CALL wrf_error_fatal ('hpoints:check domain bounds along x' ) - IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) & - CALL wrf_error_fatal ('hpoints:check domain bounds along y' ) - ENDDO - ENDDO -! -!*** INDEX CONVENTIONS -!*** HBWGT4 -!*** 4 -!*** -!*** -!*** -!*** h -!*** 1 2 -!*** HBWGT1 HBWGT2 -!*** -!*** -!*** 3 -!*** HBWGT3 + ! Local - DO K=NKDS,NKDE - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN -! - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - NFLD(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CFLD(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CFLD(IIH(I,J), JJH(I,J)+1,K) - ELSE - NFLD(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF -! - ENDIF + INTEGER ci, cj, ck, ni, nj, nk, ip, jp + + ! Iterate over the ND tile and compute the values + ! from the CD tile. + +!write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte, cjts,cjte +!write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte, njts,njte + + DO nj = njts, njte + cj = jpos + (nj-1) / nrj ! j coord of CD point + jp = mod ( nj , nrj ) ! coord of ND w/i CD point + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + ci = ipos + (ni-1) / nri ! j coord of CD point + ip = mod ( ni , nri ) ! coord of ND w/i CD point + ! This is a trivial implementation of the interp_fcn; just copies + ! the values from the CD into the ND + nfld( ni, nk, nj ) = cfld( ci , ck , cj ) + ENDDO ENDDO - ENDDO ENDDO - END SUBROUTINE interp_h_nmm -! - SUBROUTINE interp_v_nmm (cfld, & ! CD field + RETURN + + END SUBROUTINE interp_fcnm + + SUBROUTINE interp_fcnm_lu( cfld, & ! CD field cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -3991,17 +2688,20 @@ SUBROUTINE interp_v_nmm (cfld, & ! CD field nids, nide, nkds, nkde, njds, njde, & nims, nime, nkms, nkme, njms, njme, & nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp + shw, & ! stencil half width imask, & ! interpolation mask xstag, ystag, & ! staggering of field ipos, jpos, & ! Position of lower left of nest in CD nri, nrj, & ! nest ratios - CII, IIV, CJJ, JJV, CBWGT1, VBWGT1, & ! south-western grid locs and weights - CBWGT2, VBWGT2, CBWGT3, VBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, VBWGT4 ) ! dummys - USE module_timing + cxlat, nxlat, & + cxlong, nxlong, & + cdx, ndx, & + cid, nid ) + USE module_configure + IMPLICIT NONE + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -4010,213 +2710,136 @@ SUBROUTINE interp_v_nmm (cfld, & ! CD field nits, nite, nkts, nkte, njts, njte, & shw, & ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag - - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld - REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy - REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4 - INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIV,JJV - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + nri, nrj, & + cid, nid + LOGICAL, INTENT(IN) :: xstag, ystag -! local - INTEGER i,j,k + REAL, INTENT(IN) :: cdx, ndx + REAL, INTENT(IN), DIMENSION ( cims:cime, cjms:cjme ) :: cxlat, cxlong + REAL, INTENT(IN), DIMENSION ( nims:nime, njms:njme ) :: nxlat, nxlong -! -!*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION -! - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IIV(i,j).LT.(CIDS-shw) .OR. IIV(i,j).GT.(CIDE+shw)) & - CALL wrf_error_fatal ('vpoints:check domain bounds along x' ) - IF(JJV(i,j).LT.(CJDS-shw) .OR. JJV(i,j).GT.(CJDE+shw)) & - CALL wrf_error_fatal ('vpoints:check domain bounds along y' ) - ENDDO - ENDDO -! -!*** INDEX CONVENTIONS -!*** VBWGT4 -!*** 4 -!*** -!*** -!*** -!*** h -!*** 1 2 -!*** VBWGT1 VBWGT2 -!*** -!*** -!*** 3 -!*** VBWGT3 - DO K=NKDS,NKDE - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 - NFLD(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J), JJV(I,J) ,K) & - + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J) ,K) & - + VBWGT3(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)-1,K) & - + VBWGT4(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)+1,K) - ELSE - NFLD(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J), JJV(I,J) ,K) & - + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J) ,K) & - + VBWGT3(I,J)*CFLD(IIV(I,J), JJV(I,J)-1,K) & - + VBWGT4(I,J)*CFLD(IIV(I,J), JJV(I,J)+1,K) - ENDIF + ! Local - ENDIF - ENDDO - ENDDO - ENDDO + INTEGER i, ci, cj, ck, ni, nj, nk, ip, jp, ierr - END SUBROUTINE interp_v_nmm -! -!======================================================================================= -! E grid nearest neighbour interpolation for H points. -! This routine assumes cfld and nfld are in IJK -!======================================================================================= -! - SUBROUTINE interp_hnear_nmm (cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights - CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, HBWGT4 ) ! just dummys - USE module_timing - IMPLICIT NONE +#ifdef TERRAIN_AND_LANDUSE + INTEGER, DIMENSION(256) :: ipath ! array for integer coded ascii for passing path down to get_landuse - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag + REAL , ALLOCATABLE, DIMENSION(:,:) :: xlat_g, xlon_g, landuse_g + CHARACTER*256 :: message + CHARACTER*256 :: rsmas_data_path - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld - REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy - REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 - INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + LOGICAL :: input_from_hires, input_from_file -! local + INTEGER, EXTERNAL :: get_landuse + LOGICAL, EXTERNAL :: wrf_dm_on_monitor - LOGICAL FLIP - INTEGER i,j,k,n - REAL SUM,AMAXVAL - REAL, DIMENSION (4, nims:nime, njms:njme ) :: NBWGT + CALL nl_get_input_from_hires( nid , input_from_hires) + CALL nl_get_input_from_file ( nid , input_from_file ) -! -!*** INDEX CONVENTIONS -!*** NBWGT4=0 -!*** 4 -!*** -!*** -!*** -!*** h -!*** 1 2 -!*** NBWGT1=1 NBWGT2=0 -!*** -!*** -!*** 3 -!*** NBWGT3=0 + IF ( input_from_file .AND. input_from_hires ) THEN + Write(message, '(a,i3,a)') & + "Warning : input_from_file turned on for domain ", nid, ", input_from_hires disabled" + CALL wrf_message(message) + END IF - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN - NBWGT(1,I,J)=HBWGT1(I,J) - NBWGT(2,I,J)=HBWGT2(I,J) - NBWGT(3,I,J)=HBWGT3(I,J) - NBWGT(4,I,J)=HBWGT4(I,J) - ENDIF - ENDDO - ENDDO + IF ( .NOT. input_from_file .AND. input_from_hires ) THEN - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN + allocate(xlat_g(nids:nide,njds:njde)) + allocate(xlon_g(nids:nide,njds:njde)) + allocate(landuse_g(nids:nide,njds:njde)) - AMAXVAL=0. - DO N=1,4 - AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL) - ENDDO + CALL nl_get_rsmas_data_path(1,rsmas_data_path) - FLIP=.TRUE. - SUM=0.0 - DO N=1,4 - IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN - NBWGT(N,I,J)=1.0 - FLIP=.FALSE. - ELSE - NBWGT(N,I,J)=0.0 - ENDIF - SUM=SUM+NBWGT(N,I,J) - IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" ) - ENDDO + DO i = 1, LEN(TRIM(rsmas_data_path)) + ipath(i) = ICHAR(rsmas_data_path(i:i)) + ENDDO +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + CALL wrf_patch_to_global_real ( nxlat, xlat_g , nid, ' ' , 'xy' , & + nids, nide-1 , njds , njde-1 , 1 , 1 , & + nims, nime , njms , njme , 1 , 1 , & + nits, nite , njts , njte , 1 , 1 ) + CALL wrf_patch_to_global_real ( nxlong, xlon_g, nid, ' ' , 'xy' , & + nids, nide-1 , njds , njde-1 , 1 , 1 , & + nims, nime , njms , njme , 1 , 1 , & + nits, nite , njts , njte , 1 , 1 ) + IF ( wrf_dm_on_monitor() ) THEN + ierr = get_landuse ( ndx/1000., xlat_g, xlon_g, & + landuse_g, & + nide-nids+1,njde-njds+1,nide-nids+1,njde-njds+1, & + ipath, LEN(TRIM(rsmas_data_path)) ) + IF ( ierr == 1 ) THEN + WRITE(message,fmt='(a)') 'get_landuse : aborted!' + CALL wrf_error_fatal(TRIM(message)) + ENDIF ENDIF - ENDDO - ENDDO - DO K=NKDS,NKDE - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - NFLD(I,J,K) = NBWGT(1,I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + NBWGT(3,I,J)*CFLD(IIH(I,J), JJH(I,J)-1,K) & - + NBWGT(4,I,J)*CFLD(IIH(I,J), JJH(I,J)+1,K) - ELSE - NFLD(I,J,K) = NBWGT(1,I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) & - + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF - ENDIF + CALL wrf_global_to_patch_real ( landuse_g , nfld(:,1,:), nid, ' ' , 'xy' , & + nids, nide-1 , njds , njde-1 , 1 , 1 , & + nims, nime , njms , njme , 1 , 1 , & + nits, nite , njts , njte , 1 , 1 ) + +#else + ierr = get_landuse ( ndx/1000., nxlat(nids:nide,njds:njde), nxlong(nids:nide,njds:njde), & + nfld(nids:nide,1,njds:njde), & + nide-nids+1,njde-njds+1,nide-nids+1,njde-njds+1, & + ipath, LEN(TRIM(rsmas_data_path)) ) +#endif + deallocate(xlat_g) + deallocate(xlon_g) + deallocate(landuse_g) + ELSE +#endif + ! Iterate over the ND tile and compute the values + ! from the CD tile. + DO nj = njts, njte + cj = jpos + (nj-1) / nrj ! j coord of CD point + jp = mod ( nj , nrj ) ! coord of ND w/i CD point + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + ci = ipos + (ni-1) / nri ! j coord of CD point + ip = mod ( ni , nri ) ! coord of ND w/i CD point + ! This is a trivial implementation of the interp_fcn; just copies + ! the values from the CD into the ND + if ( imask(ni,nj) .eq. 1 ) then + nfld( ni, nk, nj ) = cfld( ci , ck , cj ) + endif + ENDDO ENDDO - ENDDO ENDDO +#ifdef TERRAIN_AND_LANDUSE + END IF +#endif + RETURN - END SUBROUTINE interp_hnear_nmm - SUBROUTINE force_sst_nmm (cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights - CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, HBWGT4, CCSST, CSST ) ! just dummys - USE module_timing + END SUBROUTINE interp_fcnm_lu + + + SUBROUTINE interp_fcnm_imask( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj ) ! nest ratios + USE module_configure IMPLICIT NONE + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -4228,946 +2851,935 @@ SUBROUTINE force_sst_nmm (cfld, & ! CD field nri, nrj LOGICAL, INTENT(IN) :: xstag, ystag - REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfld - REAL, DIMENSION ( nims:nime, njms:njme ) :: nfld - REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy - REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 - INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - INTEGER , INTENT(IN) :: csst(*), ccsst(*) -! local - LOGICAL FLIP - INTEGER i,j,k,n - REAL SUM,AMAXVAL - REAL, DIMENSION (4, nims:nime, njms:njme ) :: NBWGT + ! Local - if(csst(1) /= 1) return + INTEGER ci, cj, ck, ni, nj, nk, ip, jp -! -!*** INDEX CONVENTIONS -!*** NBWGT4=0 -!*** 4 -!*** -!*** -!*** -!*** h -!*** 1 2 -!*** NBWGT1=1 NBWGT2=0 -!*** -!*** -!*** 3 -!*** NBWGT3=0 + ! Iterate over the ND tile and compute the values + ! from the CD tile. - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - NBWGT(1,I,J)=HBWGT1(I,J) - NBWGT(2,I,J)=HBWGT2(I,J) - NBWGT(3,I,J)=HBWGT3(I,J) - NBWGT(4,I,J)=HBWGT4(I,J) - ENDDO +!write(0,'("mask cits:cite, ckts:ckte, cjts:cjte ",6i4)')cits,cite, ckts,ckte,cjts,cjte +!write(0,'("mask nits:nite, nkts:nkte, njts:njte ",6i4)')nits,nite, nkts,nkte,njts,njte + + DO nj = njts, njte + cj = jpos + (nj-1) / nrj ! j coord of CD point + jp = mod ( nj , nrj ) ! coord of ND w/i CD point + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + ci = ipos + (ni-1) / nri ! j coord of CD point + ip = mod ( ni , nri ) ! coord of ND w/i CD point + ! This is a trivial implementation of the interp_fcn; just copies + ! the values from the CD into the ND + if ( imask(ni,nj) .eq. 1 ) then + nfld( ni, nk, nj ) = cfld( ci , ck , cj ) + endif + ENDDO + ENDDO ENDDO - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - AMAXVAL=0. - DO N=1,4 - AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL) - ENDDO + RETURN - FLIP=.TRUE. - SUM=0.0 - DO N=1,4 - IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN - NBWGT(N,I,J)=1.0 - FLIP=.FALSE. - ELSE - NBWGT(N,I,J)=0.0 - ENDIF - SUM=SUM+NBWGT(N,I,J) - IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" ) - ENDDO - ENDDO - ENDDO + END SUBROUTINE interp_fcnm_imask +#endif +! end of first block of ARW-only routines - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - NFLD(I,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), JJH(I,J) ) & - + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ) & - + NBWGT(3,I,J)*CFLD(IIH(I,J), JJH(I,J)-1) & - + NBWGT(4,I,J)*CFLD(IIH(I,J), JJH(I,J)+1) +! NMM: We still allow interp_mask_land_field because it is needed, but no +! equivalent exists. Use of this in WRF-NMM is an error and will have +! unintended consequences. + SUBROUTINE interp_mask_land_field ( enable, & ! says whether to allow interpolation or just the bcasts + cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + clu, nlu ) + + USE module_configure + USE module_wrf_error + USE module_dm, only : wrf_dm_sum_reals, wrf_dm_sum_integers + + IMPLICIT NONE + + + LOGICAL, INTENT(IN) :: enable + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + + REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu + REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp + INTEGER :: icount , ii , jj , ist , ien , jst , jen , iswater, ierr + REAL :: avg , sum , dx , dy + INTEGER , PARAMETER :: max_search = 5 + CHARACTER(LEN=255) :: message + INTEGER :: icount_n(nkts:nkte), idummy(nkts:nkte) + REAL :: avg_n(nkts:nkte), sum_n(nkts:nkte), dummy(nkts:nkte) + + ! Find out what the water value is. + + CALL nl_get_iswater(1,iswater) + + ! Right now, only mass point locations permitted. + + IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN + + ! Loop over each i,k,j in the nested domain. + + IF ( enable ) THEN + + DO nj = njts, njte + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point ELSE - NFLD(I,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), JJH(I,J) ) & - + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ) & - + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1) & - + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1) - ENDIF - ENDDO - ENDDO + cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + END IF + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite + IF ( imask(ni, nj) .NE. 1 ) cycle + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + ELSE + ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + END IF + - END SUBROUTINE force_sst_nmm -!======================================================================================= -! E grid nearest neighbour interpolation for H points. -! This routine assumes cfld and nfld are in IKJ or ILJ -!======================================================================================= -! - SUBROUTINE interp_hnear_ikj_nmm (cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights - CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, HBWGT4 ) ! just dummys - USE module_timing - IMPLICIT NONE - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag + ! + ! (ci,cj+1) (ci+1,cj+1) + ! - ------------- + ! 1-dy | | | + ! | | | + ! - | * | + ! dy | | (ni,nj) | + ! | | | + ! - ------------- + ! (ci,cj) (ci+1,cj) + ! + ! |--|--------| + ! dx 1-dx - REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld - REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy - REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 - INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask -! local + ! For odd ratios, at (nri+1)/2, we are on the coarse grid point, so dx = 0 + + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri ) + ELSE + dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri ) + END IF + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj ) + ELSE + dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj ) + END IF + + ! This is a "land only" field. If this is a water point, no operations required. + + IF ( ( NINT(nlu(ni ,nj )) .EQ. iswater ) ) THEN + nfld(ni,nk,nj) = cfld(ci ,ck,cj ) + + ! If this is a nested land point, and the surrounding coarse values are all land points, + ! then this is a simple 4-pt interpolation. + + ELSE IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) .AND. & + ( NINT(clu(ci ,cj )) .NE. iswater ) .AND. & + ( NINT(clu(ci+1,cj )) .NE. iswater ) .AND. & + ( NINT(clu(ci ,cj+1)) .NE. iswater ) .AND. & + ( NINT(clu(ci+1,cj+1)) .NE. iswater ) ) THEN + nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + & + dy * cfld(ci ,ck,cj+1) ) + & + dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + & + dy * cfld(ci+1,ck,cj+1) ) - LOGICAL FLIP - INTEGER i,j,k,n - REAL SUM,AMAXVAL - REAL, DIMENSION (4, nims:nime, njms:njme ) :: NBWGT + ! If this is a nested land point and there are NO coarse land values surrounding, + ! we temporarily punt. -! -!*** INDEX CONVENTIONS -!*** NBWGT4=0 -!*** 4 -!*** -!*** -!*** -!*** h -!*** 1 2 -!*** NBWGT1=1 NBWGT2=0 -!*** -!*** -!*** 3 -!*** NBWGT3=0 + ELSE IF ( ( NINT(nlu(ni ,nj )) .NE. iswater ) .AND. & + ( NINT(clu(ci ,cj )) .EQ. iswater ) .AND. & + ( NINT(clu(ci+1,cj )) .EQ. iswater ) .AND. & + ( NINT(clu(ci ,cj+1)) .EQ. iswater ) .AND. & + ( NINT(clu(ci+1,cj+1)) .EQ. iswater ) ) THEN + nfld(ni,nk,nj) = -1 - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN - NBWGT(1,I,J)=HBWGT1(I,J) - NBWGT(2,I,J)=HBWGT2(I,J) - NBWGT(3,I,J)=HBWGT3(I,J) - NBWGT(4,I,J)=HBWGT4(I,J) - ENDIF - ENDDO - ENDDO + ! If there are some water points and some land points, take an average. + + ELSE IF ( NINT(nlu(ni ,nj )) .NE. iswater ) THEN + icount = 0 + sum = 0 + IF ( NINT(clu(ci ,cj )) .NE. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci ,ck,cj ) + END IF + IF ( NINT(clu(ci+1,cj )) .NE. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci+1,ck,cj ) + END IF + IF ( NINT(clu(ci ,cj+1)) .NE. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci ,ck,cj+1) + END IF + IF ( NINT(clu(ci+1,cj+1)) .NE. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci+1,ck,cj+1) + END IF + nfld(ni,nk,nj) = sum / REAL ( icount ) + END IF + END DO + END DO + END DO - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN - AMAXVAL=0. - DO N=1,4 - AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL) - ENDDO + ! Get an average of the whole domain for problem locations. - FLIP=.TRUE. - SUM=0.0 - DO N=1,4 - IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN - NBWGT(N,I,J)=1.0 - FLIP=.FALSE. - ELSE - NBWGT(N,I,J)=0.0 - ENDIF - SUM=SUM+NBWGT(N,I,J) - IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" ) - ENDDO + sum_n = 0 + icount_n = 0 + DO nj = njts, njte + DO nk = nkts, nkte + DO ni = nits, nite + IF ( nfld(ni,nk,nj) .NE. -1 ) THEN + IF ( NINT(nlu(ni,nj)) .NE. iswater ) THEN + icount_n(nk) = icount_n(nk) + 1 + sum_n(nk) = sum_n(nk) + nfld(ni,nk,nj) + END IF + END IF + END DO + END DO + END DO + CALL wrf_dm_sum_reals( sum_n(nkts:nkte), dummy(nkts:nkte)) + sum_n = dummy + CALL wrf_dm_sum_integers(icount_n(nkts:nkte), idummy(nkts:nkte)) + icount_n = idummy + DO nk = nkts, nkte + IF ( icount_n(nk) .GT. 0 ) & + avg_n(nk) = sum_n(nk) / icount_n(nk) + END DO ENDIF - ENDDO - ENDDO - - DO J=NJTS,MIN(NJTE,NJDE-1) - DO K=NKDS,NKDE - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), K,JJH(I,J) ) & - + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K,JJH(I,J) ) & - + NBWGT(3,I,J)*CFLD(IIH(I,J), K,JJH(I,J)-1) & - + NBWGT(4,I,J)*CFLD(IIH(I,J), K,JJH(I,J)+1) - ELSE - NFLD(I,K,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), K,JJH(I,J) ) & - + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,K,JJH(I,J) ) & - + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,K,JJH(I,J)-1) & - + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,K,JJH(I,J)+1) - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE interp_hnear_ikj_nmm -! -!======================================================================================= -! E grid nearest neighbour interpolation for integer H points -!======================================================================================= -! - SUBROUTINE interp_int_hnear_nmm (cfld, & ! CD field; integers - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field; integers - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! lower left of nest in CD - nri, nrj, & ! nest ratios - CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! s-w grid locs and weights - CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, HBWGT4 ) ! just dummys - USE module_timing - IMPLICIT NONE + IF ( enable ) THEN + IF ( ANY(nfld .EQ. -1) ) THEN - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag + ! OK, if there were any of those island situations, we try to search a bit broader + ! of an area in the coarse grid. - INTEGER, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld - INTEGER, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld - REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy - REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 - INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + DO nj = njts, njte + DO nk = nkts, nkte + DO ni = nits, nite + IF ( imask(ni, nj) .NE. 1 ) cycle + IF ( nfld(ni,nk,nj) .EQ. -1 ) THEN + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + ELSE + cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + END IF + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + ELSE + ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + END IF + ist = MAX (ci-max_search,cits) + ien = MIN (ci+max_search,cite,cide-1) + jst = MAX (cj-max_search,cjts) + jen = MIN (cj+max_search,cjte,cjde-1) + icount = 0 + sum = 0 + DO jj = jst,jen + DO ii = ist,ien + IF ( NINT(clu(ii,jj)) .NE. iswater ) THEN + icount = icount + 1 + sum = sum + cfld(ii,nk,jj) + END IF + END DO + END DO + IF ( icount .GT. 0 ) THEN + nfld(ni,nk,nj) = sum / REAL ( icount ) + ELSE + Write(message,fmt='(a,i4,a,i4,a,f10.4)') & + 'horizontal interp error - island (', ni, ',', nj, '), using average ', avg_n(nk) + CALL wrf_message ( message ) + nfld(ni,nk,nj) = avg_n(nk) + END IF + END IF + END DO + END DO + END DO + ENDIF + ENDIF + ELSE + CALL wrf_error_fatal ( "only unstaggered fields right now" ) + END IF -! local + END SUBROUTINE interp_mask_land_field - LOGICAL FLIP - INTEGER i,j,k,n - REAL SUM,AMAXVAL - REAL, DIMENSION (4, nims:nime, njms:njme ) :: NBWGT + SUBROUTINE interp_mask_water_field ( enable, & ! says whether to allow interpolation or just the bcasts + cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + clu, nlu, cflag, nflag ) -! -!*** INDEX CONVENTIONS -!*** NBWGT4=0 -!*** 4 -!*** -!*** -!*** -!*** h -!*** 1 2 -!*** NBWGT1=1 NBWGT2=0 -!*** -!*** -!*** 3 -!*** NBWGT3=0 + USE module_configure + USE module_wrf_error + USE module_dm, only : wrf_dm_sum_reals, wrf_dm_sum_integers - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN - NBWGT(1,I,J)=HBWGT1(I,J) - NBWGT(2,I,J)=HBWGT2(I,J) - NBWGT(3,I,J)=HBWGT3(I,J) - NBWGT(4,I,J)=HBWGT4(I,J) - ENDIF - ENDDO - ENDDO + IMPLICIT NONE + + + LOGICAL, INTENT(IN) :: enable + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj, cflag, nflag + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + + REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu + REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu + + ! Local + + INTEGER ci, cj, ck, ni, nj, nk, ip, jp + INTEGER :: icount , ii , jj , ist , ien , jst , jen, ierr + REAL :: avg , sum , dx , dy + INTEGER , PARAMETER :: max_search = 5 + INTEGER :: icount_n(nkts:nkte), idummy(nkts:nkte) + REAL :: avg_n(nkts:nkte), sum_n(nkts:nkte), dummy(nkts:nkte) + CHARACTER(LEN=255) :: message - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN + ! Right now, only mass point locations permitted. + + IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN - AMAXVAL=0. - DO N=1,4 - AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL) - ENDDO + IF ( enable ) THEN + ! Loop over each i,k,j in the nested domain. - FLIP=.TRUE. - SUM=0.0 - DO N=1,4 - IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN - NBWGT(N,I,J)=1.0 - FLIP=.FALSE. - ELSE - NBWGT(N,I,J)=0.0 - ENDIF - SUM=SUM+NBWGT(N,I,J) - IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" ) - ENDDO -! - ENDIF - ENDDO - ENDDO + DO nj = njts, njte + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + ELSE + cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + END IF + DO nk = nkts, nkte + ck = nk + DO ni = nits, nite +!dave IF ( imask(ni, nj) .NE. 1 ) cycle + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + ELSE + ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + END IF + - DO J=NJTS,MIN(NJTE,NJDE-1) - DO K=NKTS,NKTS - DO I=NITS,MIN(NITE,NIDE-1) - IF(IMASK(I,J) .NE. 1)THEN - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - NFLD(I,J,K) = NBWGT(1,I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + NBWGT(3,I,J)*CFLD(IIH(I,J), JJH(I,J)-1,K) & - + NBWGT(4,I,J)*CFLD(IIH(I,J), JJH(I,J)+1,K) - ELSE - NFLD(I,J,K) = NBWGT(1,I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) & - + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO - END SUBROUTINE interp_int_hnear_nmm -! -!-------------------------------------------------------------------------------------- -! - SUBROUTINE nmm_bdy_hinterp (cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - c_bxs,n_bxs, & - c_bxe,n_bxe, & - c_bys,n_bys, & - c_bye,n_bye, & - c_btxs,n_btxs, & - c_btxe,n_btxe, & - c_btys,n_btys, & - c_btye,n_btye, & - CTEMP_B,NTEMP_B, & ! These temp arrays should be removed - CTEMP_BT,NTEMP_BT, & ! later on - CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights - CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, HBWGT4 ) ! dummys -! use module_state_description - USE module_configure - USE module_wrf_error + ! + ! (ci,cj+1) (ci+1,cj+1) + ! - ------------- + ! 1-dy | | | + ! | | | + ! - | * | + ! dy | | (ni,nj) | + ! | | | + ! - ------------- + ! (ci,cj) (ci+1,cj) + ! + ! |--|--------| + ! dx 1-dx - IMPLICIT NONE + ! At ni=2, we are on the coarse grid point, so dx = 0 - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri ) + ELSE + dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri ) + END IF + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj ) + ELSE + dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj ) + END IF + + ! This is a "water only" field. If this is a land point, no operations required. - LOGICAL, INTENT(IN) :: xstag, ystag + IF ( ( NINT(nlu(ni ,nj )) .NE. nflag ) ) THEN + nfld(ni,nk,nj) = cfld(ci ,ck,cj ) - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld -! - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: ctemp_b,ctemp_bt - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: ntemp_b,ntemp_bt -! - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - REAL, DIMENSION( * ), INTENT(INOUT) :: c_bxs,n_bxs,c_bxe,n_bxe,c_bys,n_bys,c_bye,n_bye - REAL, DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye - REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy - REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 - INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + ! If this is a nested water point, and the surrounding coarse values are all water points, + ! then this is a simple 4-pt interpolation. -! Local + ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. nflag ) .AND. & + ( NINT(clu(ci ,cj )) .EQ. nflag ) .AND. & + ( NINT(clu(ci+1,cj )) .EQ. nflag ) .AND. & + ( NINT(clu(ci ,cj+1)) .EQ. nflag ) .AND. & + ( NINT(clu(ci+1,cj+1)) .EQ. nflag ) ) THEN + nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + & + dy * cfld(ci ,ck,cj+1) ) + & + dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + & + dy * cfld(ci+1,ck,cj+1) ) - INTEGER :: i,j,k - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: cwk1,cwk2,cwk3,cwk4 + ! If this is a nested water point and there are NO coarse water values surrounding, + ! we temporarily punt. -! X start boundary + ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. nflag ) .AND. & + ( NINT(clu(ci ,cj )) .NE. nflag ) .AND. & + ( NINT(clu(ci+1,cj )) .NE. nflag ) .AND. & + ( NINT(clu(ci ,cj+1)) .NE. nflag ) .AND. & + ( NINT(clu(ci+1,cj+1)) .NE. nflag ) ) THEN + nfld(ni,nk,nj) = -4 - NMM_XS: IF(NITS .EQ. NIDS)THEN -! WRITE(0,*)'ENTERING X1 START BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1) - I = NIDS - DO K = NKDS,NKDE - DO J = NJTS,MIN(NJTE,NJDE-1) - IF(MOD(J,2) .NE.0)THEN ! 1,3,5,7 of nested domain - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain - CWK1(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CFLD(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CFLD(IIH(I,J), JJH(I,J)+1,K) + ! If there are some land points and some water points, take an average. + + ELSE IF ( NINT(nlu(ni ,nj )) .EQ. nflag ) THEN + icount = 0 + sum = 0 + IF ( NINT(clu(ci ,cj )) .EQ. nflag ) THEN + icount = icount + 1 + sum = sum + cfld(ci ,ck,cj ) + END IF + IF ( NINT(clu(ci+1,cj )) .EQ. nflag ) THEN + icount = icount + 1 + sum = sum + cfld(ci+1,ck,cj ) + END IF + IF ( NINT(clu(ci ,cj+1)) .EQ. nflag ) THEN + icount = icount + 1 + sum = sum + cfld(ci ,ck,cj+1) + END IF + IF ( NINT(clu(ci+1,cj+1)) .EQ. nflag ) THEN + icount = icount + 1 + sum = sum + cfld(ci+1,ck,cj+1) + END IF + nfld(ni,nk,nj) = sum / REAL ( icount ) + END IF + END DO + END DO + END DO + ! Get an average of the whole domain for problem locations. - ELSE - CWK1(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF - ELSE - CWK1(I,J,K) = 0.0 ! even rows at mass points of the nested domain - ENDIF - ntemp_b(i,J,K) = CWK1(I,J,K) - ntemp_bt(i,J,K) = 0.0 - END DO - END DO - ENDIF NMM_XS - -! X end boundary - - NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN -! WRITE(0,*)'ENTERING X END BOUNDARY AT MASS POINTS',NJTS,MIN(NJTE,NJDE-1) - I = NIDE-1 - DO K = NKDS,NKDE - DO J = NJTS,MIN(NJTE,NJDE-1) - IF(MOD(J,2) .NE.0)THEN ! 1,3,5,7 of the nested domain - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain - CWK2(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CFLD(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CFLD(IIH(I,J), JJH(I,J)+1,K) - ELSE - CWK2(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF - ELSE - CWK2(I,J,K) = 0.0 ! even rows at mass points - ENDIF - ntemp_b(i,J,K) = CWK2(I,J,K) - ntemp_bt(i,J,K) = 0.0 - END DO - END DO - ENDIF NMM_XE - -! Y start boundary - - NMM_YS: IF(NJTS .EQ. NJDS)THEN -! WRITE(0,*)'ENTERING Y START BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1) - J = NJDS - DO K = NKDS, NKDE - DO I = NITS,MIN(NITE,NIDE-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - CWK3(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CFLD(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CFLD(IIH(I,J), JJH(I,J)+1,K) - ELSE - CWK3(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K) - ENDIF - ntemp_b(i,J,K) = CWK3(I,J,K) - ntemp_bt(i,J,K) = 0.0 - END DO - END DO - END IF NMM_YS - -! Y end boundary - - NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN -! WRITE(0,*)'ENTERING Y END BOUNDARY AT MASS POINTS',NITS,MIN(NITE,NIDE-1) - J = NJDE-1 - DO K = NKDS,NKDE - DO I = NITS,MIN(NITE,NIDE-1) - IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 - CWK4(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CFLD(IIH(I,J), JJH(I,J)-1,K) & - + HBWGT4(I,J)*CFLD(IIH(I,J), JJH(I,J)+1,K) - ELSE - CWK4(I,J,K) = HBWGT1(I,J)*CFLD(IIH(I,J), JJH(I,J) ,K) & - + HBWGT2(I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ,K) & - + HBWGT3(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1,K) & - + HBWGT4(I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1,K) - - ENDIF - ntemp_b(i,J,K) = CWK4(I,J,K) - ntemp_bt(i,J,K) = 0.0 + sum_n = 0 + icount_n = 0 + DO nj = njts, njte + DO nk = nkts, nkte + DO ni = nits, nite + IF ( nfld(ni,nk,nj) .NE. -1 ) THEN + IF ( NINT(nlu(ni,nj)) .EQ. nflag ) THEN + icount_n(nk) = icount_n(nk) + 1 + sum_n(nk) = sum_n(nk) + nfld(ni,nk,nj) + END IF + END IF + END DO + END DO END DO - END DO - END IF NMM_YE - RETURN + CALL wrf_dm_sum_reals( sum_n(nkts:nkte), dummy(nkts:nkte)) + sum_n = dummy + CALL wrf_dm_sum_integers(icount_n(nkts:nkte), idummy(nkts:nkte)) + icount_n = idummy + DO nk = nkts, nkte + IF ( icount_n(nk) .GT. 0 ) & + avg_n(nk) = sum_n(nk) / icount_n(nk) + END DO + ENDIF - END SUBROUTINE nmm_bdy_hinterp + IF ( enable ) THEN + IF ( ANY(nfld .EQ. -4) ) THEN -!-------------------------------------------------------------------------------------- + ! OK, if there were any of those lake situations, we try to search a bit broader + ! of an area in the coarse grid. - SUBROUTINE nmm_bdy_vinterp ( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - c_bxs,n_bxs, & - c_bxe,n_bxe, & - c_bys,n_bys, & - c_bye,n_bye, & - c_btxs,n_btxs, & - c_btxe,n_btxe, & - c_btys,n_btys, & - c_btye,n_btye, & - CTEMP_B,NTEMP_B, & ! These temp arrays should be removed - CTEMP_BT,NTEMP_BT, & ! later on - CII, IIV, CJJ, JJV, CBWGT1, VBWGT1, & ! south-western grid locs and weights - CBWGT2, VBWGT2, CBWGT3, VBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, VBWGT4 ) ! dummys - -! use module_state_description - USE module_configure - USE module_wrf_error + DO nj = njts, njte + DO nk = nkts, nkte + DO ni = nits, nite +!dave IF ( imask(ni, nj) .NE. 1 ) cycle + IF ( nfld(ni,nk,nj) .EQ. -4 ) THEN + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + ELSE + cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + END IF + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + ELSE + ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + END IF + ist = MAX (ci-max_search,cits) + ien = MIN (ci+max_search,cite,cide-1) + jst = MAX (cj-max_search,cjts) + jen = MIN (cj+max_search,cjte,cjde-1) + icount = 0 + sum = 0 + DO jj = jst,jen + DO ii = ist,ien + IF ( NINT(clu(ii,jj)) .EQ. nflag ) THEN + icount = icount + 1 + sum = sum + cfld(ii,nk,jj) + END IF + END DO + END DO + IF ( icount .GT. 0 ) THEN + nfld(ni,nk,nj) = sum / REAL ( icount ) + ELSE + Write(message,fmt='(a,i4,a,i4,a,f10.4)') & + 'horizontal interp error - lake (', ni, ',', nj, '), using average ', avg_n(nk) + CALL wrf_message ( message ) + nfld(ni,nk,nj) = avg_n(nk) + END IF + END IF + END DO + END DO + END DO + ENDIF + ENDIF + ELSE + CALL wrf_error_fatal ( "only unstaggered fields right now" ) + END IF - IMPLICIT NONE + END SUBROUTINE interp_mask_water_field +! Begin second block of ARW-only routines +#if ! defined(NMM_CORE) || NMM_CORE!=1 + SUBROUTINE p2c_mask ( cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + clu, nlu, & ! land use categories + ctslb,ntslb, & ! soil temps + cnum_soil_layers,nnum_soil_layers, & ! number of soil layers for tslb + ciswater, niswater ) ! iswater category - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj + USE module_configure + USE module_wrf_error - LOGICAL, INTENT(IN) :: xstag, ystag + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj, & + cnum_soil_layers, nnum_soil_layers, & + ciswater, niswater - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld -! - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: ctemp_b,ctemp_bt - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: ntemp_b,ntemp_bt -! - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask - REAL, DIMENSION( * ), INTENT(INOUT) :: c_bxs,n_bxs,c_bxe,n_bxe,c_bys,n_bys,c_bye,n_bye - REAL, DIMENSION( * ), INTENT(INOUT) :: c_btxs,n_btxs,c_btxe,n_btxe,c_btys,n_btys,c_btye,n_btye - REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy - REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4 - INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIV,JJV - -! Local - - INTEGER :: i,j,k - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: cwk1,cwk2,cwk3,cwk4 - -! X start boundary - - NMM_XS: IF(NITS .EQ. NIDS)THEN -! WRITE(0,*)'ENTERING X START BOUNDARY AT VELOCITY POINTS',NITS,NIDS,NJTS,MIN(NJTE,NJDE-1) - I = NIDS - DO K = NKDS,NKDE - DO J = NJTS,MIN(NJTE,NJDE-1) - IF(MOD(J,2) .EQ.0)THEN ! 1,3,5,7 of nested domain - IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain - CWK1(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J), JJV(I,J) ,K) & - + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J) ,K) & - + VBWGT3(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)-1,K) & - + VBWGT4(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)+1,K) - ELSE - CWK1(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J), JJV(I,J) ,K) & - + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J) ,K) & - + VBWGT3(I,J)*CFLD(IIV(I,J), JJV(I,J)-1,K) & - + VBWGT4(I,J)*CFLD(IIV(I,J), JJV(I,J)+1,K) - ENDIF - ELSE - CWK1(I,J,K) = 0.0 ! odd rows along J, at mass points have zero velocity - ENDIF - ntemp_b(i,J,K) = CWK1(I,J,K) - ntemp_bt(i,J,K) = 0.0 - END DO - END DO - ENDIF NMM_XS - -! X end boundary - - NMM_XE: IF(NITE-1 .EQ. NIDE-1)THEN -! WRITE(0,*)'ENTERING X END BOUNDARY AT VELOCITY POINTS',NITE-1,NIDE-1,NJTS,MIN(NJTE,NJDE-1) - I = NIDE-1 - DO K = NKDS,NKDE - DO J = NJTS,MIN(NJTE,NJDE-1) - IF(MOD(J,2) .EQ.0)THEN ! 1,3,5,7 of the nested domain - IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 of the parent domain - CWK2(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J), JJV(I,J) ,K) & - + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J) ,K) & - + VBWGT3(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)-1,K) & - + VBWGT4(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)+1,K) - ELSE - CWK2(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J), JJV(I,J) ,K) & - + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J) ,K) & - + VBWGT3(I,J)*CFLD(IIV(I,J), JJV(I,J)-1,K) & - + VBWGT4(I,J)*CFLD(IIV(I,J), JJV(I,J)+1,K) - ENDIF - ELSE - CWK2(I,J,K) = 0.0 ! odd rows at mass points - ENDIF - ntemp_b(i,J,K) = CWK2(I,J,K) - ntemp_bt(i,J,K) = 0.0 - END DO - END DO - ENDIF NMM_XE - -! Y start boundary - - NMM_YS: IF(NJTS .EQ. NJDS)THEN -! WRITE(0,*)'ENTERING Y START BOUNDARY AT VELOCITY POINTS',NJTS,NJDS,NITS,MIN(NITE,NIDE-1) - J = NJDS - DO K = NKDS, NKDE - DO I = NITS,MIN(NITE,NIDE-2) ! NIDE-1 SHOULD NOT MATTER IF WE FILL UP PHANTOM CELL - IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 - CWK3(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J), JJV(I,J) ,K) & - + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J) ,K) & - + VBWGT3(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)-1,K) & - + VBWGT4(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)+1,K) - ELSE - CWK3(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J), JJV(I,J) ,K) & - + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J) ,K) & - + VBWGT3(I,J)*CFLD(IIV(I,J), JJV(I,J)-1,K) & - + VBWGT4(I,J)*CFLD(IIV(I,J), JJV(I,J)+1,K) - ENDIF - ntemp_b(i,J,K) = CWK3(I,J,K) - ntemp_bt(i,J,K) = 0.0 - END DO - END DO - END IF NMM_YS - -! Y end boundary - - NMM_YE: IF(NJTE-1 .EQ. NJDE-1)THEN -! WRITE(0,*)'ENTERING Y END BOUNDARY AT VELOCITY POINTS',NJTE-1,NJDE-1,NITS,MIN(NITE,NIDE-1) - J = NJDE-1 - DO K = NKDS,NKDE - DO I = NITS,MIN(NITE,NIDE-2) ! NIDE-1 SHOULD NOT MATTER IF WE FILL UP PHANTOM CELL - IF(MOD(JJV(I,J),2) .NE. 0)THEN ! 1,3,5,7 - CWK4(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J), JJV(I,J) ,K) & - + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J) ,K) & - + VBWGT3(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)-1,K) & - + VBWGT4(I,J)*CFLD(IIV(I,J)+1,JJV(I,J)+1,K) - ELSE - CWK4(I,J,K) = VBWGT1(I,J)*CFLD(IIV(I,J), JJV(I,J) ,K) & - + VBWGT2(I,J)*CFLD(IIV(I,J)+1,JJV(I,J) ,K) & - + VBWGT3(I,J)*CFLD(IIV(I,J), JJV(I,J)-1,K) & - + VBWGT4(I,J)*CFLD(IIV(I,J), JJV(I,J)+1,K) - ENDIF - ntemp_b(i,J,K) = CWK4(I,J,K) - ntemp_bt(i,J,K) = 0.0 - END DO - END DO - END IF NMM_YE + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + + REAL, DIMENSION ( cims:cime, cjms:cjme ) :: clu + REAL, DIMENSION ( nims:nime, njms:njme ) :: nlu - RETURN + REAL, DIMENSION ( cims:cime, 1:cnum_soil_layers, cjms:cjme ) :: ctslb + REAL, DIMENSION ( nims:nime, 1:nnum_soil_layers, njms:njme ) :: ntslb - END SUBROUTINE nmm_bdy_vinterp + ! Local + + INTEGER ci, cj, ck, ni, nj, nk + INTEGER :: icount + REAL :: sum , dx , dy -! -!======================================================================================= -! E grid interpolation: simple copy from parent to mother domain -!======================================================================================= -! + ! Right now, only mass point locations permitted. + + IF ( ( .NOT. xstag) .AND. ( .NOT. ystag ) ) THEN - SUBROUTINE nmm_copy ( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - CII, IIH, CJJ, JJH ) + ! Loop over each i,k,j in the nested domain. - USE module_timing - IMPLICIT NONE + DO nj = njts, MIN(njde-1,njte) + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + cj = ( nj + (nrj/2)-1 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + ELSE + cj = ( nj + (nrj-1)/2 ) / nrj + jpos -1 ! first coarse position equal to or below nest point + END IF + DO nk = nkts, nkte + ck = nk + DO ni = nits, MIN(nide-1,nite) + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + ci = ( ni + (nri/2)-1 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + ELSE + ci = ( ni + (nri-1)/2 ) / nri + ipos -1 ! first coarse position equal to or to the left of nest point + END IF - LOGICAL, INTENT(IN) :: xstag, ystag - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(IN) :: cfld - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ), INTENT(INOUT) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask - INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + ! + ! (ci,cj+1) (ci+1,cj+1) + ! - ------------- + ! 1-dy | | | + ! | | | + ! - | * | + ! dy | | (ni,nj) | + ! | | | + ! - ------------- + ! (ci,cj) (ci+1,cj) + ! + ! |--|--------| + ! dx 1-dx -! local - INTEGER i,j,k - DO J=NJTS,MIN(NJTE,NJDE-1) - DO K=NKTS,NKTE - DO I=NITS,MIN(NITE,NIDE-1) - NFLD(I,J,K) = CFLD(IIH(I,J),JJH(I,J),K) - ENDDO - ENDDO - ENDDO + ! At ni=2, we are on the coarse grid point, so dx = 0 - RETURN + IF ( MOD ( nri , 2 ) .EQ. 0 ) THEN + dx = ( REAL ( MOD ( ni+(nri-1)/2 , nri ) ) + 0.5 ) / REAL ( nri ) + ELSE + dx = REAL ( MOD ( ni+(nri-1)/2 , nri ) ) / REAL ( nri ) + END IF + IF ( MOD ( nrj , 2 ) .EQ. 0 ) THEN + dy = ( REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) + 0.5 ) / REAL ( nrj ) + ELSE + dy = REAL ( MOD ( nj+(nrj-1)/2 , nrj ) ) / REAL ( nrj ) + END IF + + ! This is a "water only" field. If this is a land point, no operations required. - END SUBROUTINE nmm_copy -! -!======================================================================================= -! E grid test for mass point coincidence -!======================================================================================= -! - SUBROUTINE test_nmm (cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights - CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are - CBWGT4, HBWGT4 ) ! dummys for weights - USE module_timing - IMPLICIT NONE + IF ( ( NINT(nlu(ni ,nj )) .NE. niswater ) ) THEN + nfld(ni,nk,nj) = 273.18 - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - LOGICAL, INTENT(IN) :: xstag, ystag + ! If this is a nested water point, and the surrounding coarse values are all water points, + ! then this is a simple 4-pt interpolation. - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfld - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ) :: nfld - REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy - REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 - INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy - INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH - INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. niswater ) .AND. & + ( NINT(clu(ci ,cj )) .EQ. niswater ) .AND. & + ( NINT(clu(ci+1,cj )) .EQ. niswater ) .AND. & + ( NINT(clu(ci ,cj+1)) .EQ. niswater ) .AND. & + ( NINT(clu(ci+1,cj+1)) .EQ. niswater ) ) THEN + nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * cfld(ci ,ck,cj ) + & + dy * cfld(ci ,ck,cj+1) ) + & + dx * ( ( 1. - dy ) * cfld(ci+1,ck,cj ) + & + dy * cfld(ci+1,ck,cj+1) ) -! local - INTEGER i,j,k - REAL,PARAMETER :: error=0.0001,error1=1.0 - REAL :: diff - CHARACTER (LEN=256) :: a_message -! -!*** CHECK DOMAIN BOUNDS BEFORE INTERPOLATION -! - DO J=NJTS,MIN(NJTE,NJDE-1) - DO I=NITS,MIN(NITE,NIDE-1) - IF(IIH(i,j).LT.(CIDS-shw) .OR. IIH(i,j).GT.(CIDE+shw)) & - CALL wrf_error_fatal ('hpoints:check domain bounds along x' ) - IF(JJH(i,j).LT.(CJDS-shw) .OR. JJH(i,j).GT.(CJDE+shw)) & - CALL wrf_error_fatal ('hpoints:check domain bounds along y' ) - ENDDO - ENDDO + ! If this is a nested water point and there are NO coarse water values surrounding, + ! we manufacture something from the deepest CG soil temp. -! -!*** INDEX CONVENTIONS -!*** HBWGT4 -!*** 4 -!*** -!*** -!*** -!*** h -!*** 1 2 -!*** HBWGT1 HBWGT2 -!*** -!*** -!*** 3 -!*** HBWGT3 + ELSE IF ( ( NINT(nlu(ni ,nj )) .EQ. niswater ) .AND. & + ( NINT(clu(ci ,cj )) .NE. niswater ) .AND. & + ( NINT(clu(ci+1,cj )) .NE. niswater ) .AND. & + ( NINT(clu(ci ,cj+1)) .NE. niswater ) .AND. & + ( NINT(clu(ci+1,cj+1)) .NE. niswater ) ) THEN + nfld(ni,nk,nj) = ( 1. - dx ) * ( ( 1. - dy ) * ctslb(ci ,cnum_soil_layers,cj ) + & + dy * ctslb(ci ,cnum_soil_layers,cj+1) ) + & + dx * ( ( 1. - dy ) * ctslb(ci+1,cnum_soil_layers,cj ) + & + dy * ctslb(ci+1,cnum_soil_layers,cj+1) ) + + ! If there are some land points and some water points, take an average of the water points. + + ELSE IF ( NINT(nlu(ni ,nj )) .EQ. niswater ) THEN + icount = 0 + sum = 0 + IF ( NINT(clu(ci ,cj )) .EQ. niswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci ,ck,cj ) + END IF + IF ( NINT(clu(ci+1,cj )) .EQ. niswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci+1,ck,cj ) + END IF + IF ( NINT(clu(ci ,cj+1)) .EQ. niswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci ,ck,cj+1) + END IF + IF ( NINT(clu(ci+1,cj+1)) .EQ. niswater ) THEN + icount = icount + 1 + sum = sum + cfld(ci+1,ck,cj+1) + END IF + nfld(ni,nk,nj) = sum / REAL ( icount ) + END IF + END DO + END DO + END DO + ELSE + CALL wrf_error_fatal ( "only unstaggered fields right now" ) + END IF -! WRITE(0,*)NITS,MIN(NITE,NIDE-1),CITS,CITE - DO J=NJTS,MIN(NJTE,NJDE-1) - DO K=NKDS,NKDE - DO I=NITS,MIN(NITE,NIDE-1) - IF(ABS(1.0-HBWGT1(I,J)) .LE. ERROR)THEN - DIFF=ABS(NFLD(I,J,K)-CFLD(IIH(I,J),JJH(I,J),K)) - IF(DIFF .GT. ERROR)THEN - CALL wrf_debug(1,"dyn_nmm: NON-COINCIDENT, NESTED MASS POINT") - WRITE(a_message,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,J,K),CFLD(IIH(I,J),JJH(I,J),K),DIFF - CALL wrf_message ( a_message ) - ENDIF - IF(DIFF .GT. ERROR1)THEN - WRITE(a_message,*)I,IIH(I,J),J,JJH(I,J),HBWGT1(I,J),NFLD(I,J,K),CFLD(IIH(I,J),JJH(I,J),K),DIFF - CALL wrf_message ( a_message ) - CALL wrf_error_fatal ('dyn_nmm: NON-COINCIDENT, NESTED MASS POINT') - ENDIF - ENDIF - ENDDO - ENDDO - ENDDO + END SUBROUTINE p2c_mask - END SUBROUTINE test_nmm + SUBROUTINE none + END SUBROUTINE none -!================================== -! this is the default function used in nmm feedback at mass points. + SUBROUTINE smoother ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in + nri, nrj & + ) + + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos + LOGICAL, INTENT(IN) :: xstag, ystag + INTEGER :: smooth_option, feedback , spec_zone + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld - SUBROUTINE nmm_feedback ( cfld, & ! CD field - cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nfld, & ! ND field - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & ! stencil half width for interp - imask, & ! interpolation mask - xstag, ystag, & ! staggering of field - ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - CII, IIH, CJJ, JJH, & - CBWGT1, HBWGT1, CBWGT2, HBWGT2, & - CBWGT3, HBWGT3, CBWGT4, HBWGT4 ) - USE module_configure - IMPLICIT NONE + ! If there is no feedback, there can be no smoothing. + CALL nl_get_feedback ( 1, feedback ) + IF ( feedback == 0 ) RETURN + CALL nl_get_spec_zone ( 1, spec_zone ) - INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & - cims, cime, ckms, ckme, cjms, cjme, & - cits, cite, ckts, ckte, cjts, cjte, & - nids, nide, nkds, nkde, njds, njde, & - nims, nime, nkms, nkme, njms, njme, & - nits, nite, nkts, nkte, njts, njte, & - shw, & - ipos, jpos, & - nri, nrj - INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy - INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIH,JJH - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 - LOGICAL, INTENT(IN) :: xstag, ystag + ! These are the 2d smoothers used on the fedback data. These filters + ! are run on the coarse grid data (after the nested info has been + ! fedback). Only the area of the nest in the coarse grid is filtered. - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(OUT) :: cfld - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ), INTENT(IN) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN) :: imask + CALL nl_get_smooth_option ( 1, smooth_option ) - ! Local + IF ( smooth_option == 0 ) THEN +! no op + ELSE IF ( smooth_option == 1 ) THEN + CALL sm121 ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + xstag, ystag, & ! staggering of field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos & ! Position of lower left of nest in + ) + ELSE IF ( smooth_option == 2 ) THEN + CALL smdsm ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + xstag, ystag, & ! staggering of field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos & ! Position of lower left of nest in + ) + END IF - INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa - INTEGER :: icmin,icmax,jcmin,jcmax - INTEGER :: is, ipoints,jpoints,ijpoints - INTEGER , PARAMETER :: passes = 2 - REAL :: AVGH + END SUBROUTINE smoother -!===================================================================================== -! + SUBROUTINE sm121 ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + xstag, ystag, & ! staggering of field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos & ! Position of lower left of nest in + ) + + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfldnew + + INTEGER :: i , j , k , loop + INTEGER :: istag,jstag - IF(nri .ne. 3 .OR. nrj .ne. 3) & - CALL wrf_error_fatal ('Feedback works for only 1:3 ratios, currently. Modify the namelist' ) + INTEGER, PARAMETER :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt) -! WRITE(0,*)'SIMPLE FEED BACK IS SWITCHED ON FOR MASS' + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 + + ! Simple 1-2-1 smoother. + + smoothing_passes : DO loop = 1 , smooth_passes + + DO k = ckts , ckte + + ! Initialize dummy cfldnew - CFLD = 9999.0 + DO i = MAX(ipos,cits-3) , MIN(ipos+(nide-nids)/nri,cite+3) + DO j = MAX(jpos,cjts-3) , MIN(jpos+(njde-njds)/nrj,cjte+3) + cfldnew(i,j) = cfld(i,k,j) + END DO + END DO - DO ck = ckts, ckte - nk = ck - DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs - nj = (cj-jpos)*nrj + 1 - if(mod(cj,2) .eq. 0)THEN - is=0 ! even rows for mass points (2,4,6,8) - else - is=1 ! odd rows for mass points (1,3,5,7) - endif - DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs - ni = (ci-ipos)*nri + 2 -is - IF(IS==0)THEN ! (2,4,6,8) -! AVGH = NFLD(NI,NJ+1,NK) + NFLD(NI,NJ-1,NK) + NFLD(NI+1,NJ+1,NK)+ NFLD(NI+1,NJ-1,NK) & -! + NFLD(NI+1,NJ,NK) + NFLD(NI-1,NJ,NK) + NFLD(NI,NJ+2,NK) + NFLD(NI,NJ-2,NK) & -! + NFLD(NI+1,NJ+2,NK)+ NFLD(NI-1,NJ+2,NK)+ NFLD(NI+1,NJ-2,NK)+ NFLD(NI-1,NJ-2,NK) - - AVGH = NFLD(NI,NJ+2,NK) & - + NFLD(NI ,NJ+1,NK) + NFLD(NI+1,NJ+1,NK) & - + NFLD(NI-1,NJ ,NK) + NFLD(NI,NJ ,NK) + NFLD(NI+1,NJ ,NK) & - + NFLD(NI ,NJ-1,NK) + NFLD(NI+1,NJ-1,NK) & - + NFLD(NI,NJ-2,NK) - - ELSE -! AVGH = NFLD(NI,NJ+1,NK) + NFLD(NI,NJ-1,NK) + NFLD(NI-1,NJ+1,NK)+ NFLD(NI-1,NJ-1,NK) & -! + NFLD(NI+1,NJ,NK) + NFLD(NI-1,NJ,NK) + NFLD(NI,NJ+2,NK) + NFLD(NI,NJ-2,NK) & -! + NFLD(NI+1,NJ+2,NK)+ NFLD(NI-1,NJ+2,NK)+ NFLD(NI+1,NJ-2,NK)+ NFLD(NI-1,NJ-2,NK) - - AVGH = NFLD(NI,NJ+2,NK) & - + NFLD(NI-1,NJ+1,NK) + NFLD(NI,NJ+1,NK) & - + NFLD(NI-1,NJ ,NK) + NFLD(NI,NJ ,NK) + NFLD(NI+1,NJ ,NK) & - + NFLD(NI-1,NJ-1,NK) + NFLD(NI,NJ-1,NK) & - + NFLD(NI,NJ-2,NK) + ! 1-2-1 smoothing in the j direction first, + + DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) + DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) + cfldnew(i,j) = 0.25 * ( cfld(i,k,j+1) + 2.*cfld(i,k,j) + cfld(i,k,j-1) ) + END DO + END DO - ENDIF -!dusan CFLD(CI,CK,CJ) = 0.5*CFLD(CI,CK,CJ) + 0.5*(NFLD(NI,NK,NJ)+AVGH)/13.0 -! CFLD(CI,CJ,CK) = (NFLD(NI,NJ,NK)+AVGH)/13.0 - CFLD(CI,CJ,CK) = AVGH/9.0 - ENDDO - ENDDO - ENDDO + ! then 1-2-1 smoothing in the i direction last + + DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) + DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) + cfld(i,k,j) = 0.25 * ( cfldnew(i+1,j) + 2.*cfldnew(i,j) + cfldnew(i-1,j) ) + END DO + END DO + + END DO + + END DO smoothing_passes + + END SUBROUTINE sm121 + + SUBROUTINE smdsm ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + xstag, ystag, & ! staggering of field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos & ! Position of lower left of nest in + ) + + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos + LOGICAL, INTENT(IN) :: xstag, ystag + + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld + REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfldnew + + REAL , DIMENSION ( 2 ) :: xnu + INTEGER :: i , j , k , loop , n + INTEGER :: istag,jstag + + INTEGER, PARAMETER :: smooth_passes = 1 ! More passes requires a larger stencil (currently 48 pt) - END SUBROUTINE nmm_feedback + xnu = (/ 0.50 , -0.52 /) + + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 + + ! The odd number passes of this are the "smoother", the even + ! number passes are the "de-smoother" (note the different signs on xnu). + + smoothing_passes : DO loop = 1 , smooth_passes * 2 + + n = 2 - MOD ( loop , 2 ) + + DO k = ckts , ckte + + DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) + DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) + cfldnew(i,j) = cfld(i,k,j) + xnu(n) * ((cfld(i,k,j+1) + cfld(i,k,j-1)) * 0.5-cfld(i,k,j)) + END DO + END DO + + DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) + DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) + cfld(i,k,j) = cfldnew(i,j) + END DO + END DO + + DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) + DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) + cfldnew(i,j) = cfld(i,k,j) + xnu(n) * ((cfld(i+1,k,j) + cfld(i-1,k,j)) * 0.5-cfld(i,k,j)) + END DO + END DO + + DO j = MAX(jpos+2,cjts-2) , MIN(jpos+(njde-njds)/nrj-2-jstag,cjte+2) + DO i = MAX(ipos+2,cits-2) , MIN(ipos+(nide-nids)/nri-2-istag,cite+2) + cfld(i,k,j) = cfldnew(i,j) + END DO + END DO + + END DO + + END DO smoothing_passes + + END SUBROUTINE smdsm -!=========================================================================================== +!================================== +! this is used to modify a field over the nest so we can see where the nest is - SUBROUTINE nmm_vfeedback ( cfld, & ! CD field + SUBROUTINE mark_domain ( cfld, & ! CD field cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -5179,11 +3791,9 @@ SUBROUTINE nmm_vfeedback ( cfld, & ! CD field imask, & ! interpolation mask xstag, ystag, & ! staggering of field ipos, jpos, & ! Position of lower left of nest in CD - nri, nrj, & ! nest ratios - CII, IIV, CJJ, JJV, & - CBWGT1, VBWGT1, CBWGT2, VBWGT2, & - CBWGT3, VBWGT3, CBWGT4, VBWGT4 ) + nri, nrj ) ! nest ratios USE module_configure + USE module_wrf_error IMPLICIT NONE @@ -5196,79 +3806,155 @@ SUBROUTINE nmm_vfeedback ( cfld, & ! CD field shw, & ipos, jpos, & nri, nrj - INTEGER,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CII,CJJ ! dummy - INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IIV,JJV - REAL,DIMENSION(cims:cime,cjms:cjme), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 - REAL,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: VBWGT1,VBWGT2,VBWGT3,VBWGT4 - LOGICAL, INTENT(IN) :: xstag, ystag + LOGICAL, INTENT(IN) :: xstag, ystag - REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(OUT) :: cfld - REAL, DIMENSION ( nims:nime, njms:njme, nkms:nkme ), INTENT(IN) :: nfld - INTEGER, DIMENSION ( nims:nime, njms:njme ),INTENT(IN) :: imask + REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ), INTENT(OUT) :: cfld + REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ), INTENT(IN) :: nfld + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: imask ! Local INTEGER ci, cj, ck, ni, nj, nk, ip, jp, ioff, joff, ioffa, joffa INTEGER :: icmin,icmax,jcmin,jcmax - INTEGER :: is, ipoints,jpoints,ijpoints - INTEGER , PARAMETER :: passes = 2 - REAL :: AVGV + INTEGER :: istag,jstag, ipoints,jpoints,ijpoints -!===================================================================================== -! + istag = 1 ; jstag = 1 + IF ( xstag ) istag = 0 + IF ( ystag ) jstag = 0 - IF(nri .ne. 3 .OR. nrj .ne. 3) & - CALL wrf_error_fatal ('Feedback works for only 1:3 ratios, currently. Modify the namelist') + DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-jstag-1,cjte) + nj = (cj-jpos)*nrj + jstag + 1 + DO ck = ckts, ckte + nk = ck + DO ci = MAX(ipos+1,cits),MIN(ipos+(nide-nids)/nri-istag-1,cite) + ni = (ci-ipos)*nri + istag + 1 + cfld( ci, ck, cj ) = 9021000. !magic number: Beverly Hills * 100. + ENDDO + ENDDO + ENDDO -! WRITE(0,*)'SIMPLE FEED BACK IS SWITCHED ON FOR VELOCITY' + END SUBROUTINE mark_domain +#endif +! end of second block of WRF-ARW-specific interpolation schemes - CFLD = 9999.0 +#if ( NMM_CORE == 1 ) +!======================================================================================= +! Old circa 2007 interpolation schemes that are still in use +! This is gopal's doing +!======================================================================================= + SUBROUTINE force_sst_nmm (cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj, & ! nest ratios + CII, IIH, CJJ, JJH, CBWGT1, HBWGT1, & ! south-western grid locs and weights + CBWGT2, HBWGT2, CBWGT3, HBWGT3, & ! note that "C"ourse grid ones are + CBWGT4, HBWGT4, CCSST, CSST ) ! just dummys + USE module_timing + IMPLICIT NONE - DO ck = ckts, ckte - nk = ck - DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs - nj = (cj-jpos)*nrj + 1 - if(mod(cj,2) .eq. 0)THEN - is=1 ! even rows for velocity points (2,4,6,8) - else - is=0 ! odd rows for velocity points (1,3,5,7) - endif - DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs - ni = (ci-ipos)*nri + 2 -is - IF(IS==0)THEN ! (1,3,5,7) -! AVGV = NFLD(NI,NK,NJ+1) + NFLD(NI,NK,NJ-1) + NFLD(NI+1,NK,NJ+1)+ NFLD(NI+1,NK,NJ-1) & -! + NFLD(NI+1,NK,NJ) + NFLD(NI-1,NK,NJ) + NFLD(NI,NK,NJ+2) + NFLD(NI,NK,NJ-2) & -! + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2) - - AVGV = NFLD(NI,NJ+2,NK) & - + NFLD(NI ,NJ+1,NK) + NFLD(NI+1,NJ+1,NK) & - + NFLD(NI-1,NJ ,NK) + NFLD(NI,NJ ,NK) + NFLD(NI+1,NJ ,NK) & - + NFLD(NI ,NJ-1,NK) + NFLD(NI+1,NJ-1,NK) & - + NFLD(NI,NJ-2,NK) - - ELSE -! AVGV = NFLD(NI,NK,NJ+1) + NFLD(NI,NK,NJ-1) + NFLD(NI-1,NK,NJ+1)+ NFLD(NI-1,NK,NJ-1) & -! + NFLD(NI+1,NK,NJ) + NFLD(NI-1,NK,NJ) + NFLD(NI,NK,NJ+2) + NFLD(NI,NK,NJ-2) & -! + NFLD(NI+1,NK,NJ+2)+ NFLD(NI-1,NK,NJ+2)+ NFLD(NI+1,NK,NJ-2)+ NFLD(NI-1,NK,NJ-2) - - AVGV = NFLD(NI,NJ+2,NK) & - + NFLD(NI-1,NJ+1,NK) + NFLD(NI,NJ+1,NK) & - + NFLD(NI-1,NJ ,NK) + NFLD(NI,NJ ,NK) + NFLD(NI+1,NJ ,NK) & - + NFLD(NI-1,NJ-1,NK) + NFLD(NI,NJ-1,NK) & - + NFLD(NI,NJ-2,NK) + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & + ipos, jpos, & + nri, nrj + LOGICAL, INTENT(IN) :: xstag, ystag - ENDIF -!dusan CFLD(CI,CK,CJ) = 0.5*CFLD(CI,CK,CJ) + 0.5*(NFLD(NI,NK,NJ)+AVGV)/13.0 -! CFLD(CI,CK,CJ) = (NFLD(NI,NK,NJ)+AVGV)/13.0 - CFLD(CI,CJ,CK) = AVGV/9.0 + REAL, DIMENSION ( cims:cime, cjms:cjme ) :: cfld + REAL, DIMENSION ( nims:nime, njms:njme ) :: nfld + REAL, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CBWGT1,CBWGT2,CBWGT3,CBWGT4 ! dummy + REAL, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: HBWGT1,HBWGT2,HBWGT3,HBWGT4 + INTEGER, DIMENSION ( cims:cime, cjms:cjme ), INTENT(IN) :: CII,CJJ ! dummy + INTEGER, DIMENSION ( nims:nime, njms:njme ), INTENT(IN) :: IIH,JJH + INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask + INTEGER , INTENT(IN) :: csst(*), ccsst(*) +! local + + LOGICAL FLIP + INTEGER i,j,k,n + REAL SUM,AMAXVAL + REAL, DIMENSION (4, nims:nime, njms:njme ) :: NBWGT + + if(csst(1) /= 1) return + +! +!*** INDEX CONVENTIONS +!*** NBWGT4=0 +!*** 4 +!*** +!*** +!*** +!*** h +!*** 1 2 +!*** NBWGT1=1 NBWGT2=0 +!*** +!*** +!*** 3 +!*** NBWGT3=0 + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + NBWGT(1,I,J)=HBWGT1(I,J) + NBWGT(2,I,J)=HBWGT2(I,J) + NBWGT(3,I,J)=HBWGT3(I,J) + NBWGT(4,I,J)=HBWGT4(I,J) + ENDDO ENDDO - ENDDO - ENDDO - END SUBROUTINE nmm_vfeedback + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + AMAXVAL=0. + DO N=1,4 + AMAXVAL=amax1(NBWGT(N,I,J),AMAXVAL) + ENDDO + + FLIP=.TRUE. + SUM=0.0 + DO N=1,4 + IF(AMAXVAL .EQ. NBWGT(N,I,J) .AND. FLIP)THEN + NBWGT(N,I,J)=1.0 + FLIP=.FALSE. + ELSE + NBWGT(N,I,J)=0.0 + ENDIF + SUM=SUM+NBWGT(N,I,J) + IF(SUM .GT. 1.0)CALL wrf_error_fatal ( "horizontal interp error - interp_hnear_nmm" ) + ENDDO + ENDDO + ENDDO + + DO J=NJTS,MIN(NJTE,NJDE-1) + DO I=NITS,MIN(NITE,NIDE-1) + IF(MOD(JJH(I,J),2) .NE. 0)THEN ! 1,3,5,7 + NFLD(I,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), JJH(I,J) ) & + + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ) & + + NBWGT(3,I,J)*CFLD(IIH(I,J), JJH(I,J)-1) & + + NBWGT(4,I,J)*CFLD(IIH(I,J), JJH(I,J)+1) + ELSE + NFLD(I,J) = NBWGT(1,I,J)*CFLD(IIH(I,J), JJH(I,J) ) & + + NBWGT(2,I,J)*CFLD(IIH(I,J)+1,JJH(I,J) ) & + + NBWGT(3,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)-1) & + + NBWGT(4,I,J)*CFLD(IIH(I,J)+1,JJH(I,J)+1) + ENDIF + ENDDO + ENDDO + + END SUBROUTINE force_sst_nmm - SUBROUTINE nmm_smoother ( cfld , & + SUBROUTINE nmm_smoother_ikj ( cfld , & cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -5350,10 +4036,95 @@ SUBROUTINE nmm_smoother ( cfld , & ENDDO ! do npass - END SUBROUTINE nmm_smoother + END SUBROUTINE nmm_smoother_ikj + + + SUBROUTINE nmm_smoother_ijk ( cfld , & + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + xstag, ystag, & + ipos, jpos, & + nri, nrj & + ) + + USE module_configure + IMPLICIT NONE + + INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + nri, nrj, & + ipos, jpos + REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ), INTENT(INOUT) :: cfld + LOGICAL, INTENT(IN) :: xstag, ystag + + + ! Local + + INTEGER :: feedback + INTEGER, PARAMETER :: smooth_passes = 5 + + REAL, DIMENSION ( cims:cime, cjms:cjme, ckms:ckme ) :: cfldnew + INTEGER :: ci, cj, ck + INTEGER :: is, npass + REAL :: AVGH + CHARACTER (LEN=256) :: a_message + + RETURN + ! If there is no feedback, there can be no smoothing. + + CALL nl_get_feedback ( 1, feedback ) + IF ( feedback == 0 ) RETURN + + WRITE(a_message,*)'SIMPLE SMOOTHER IS SWITCHED ON FOR HEIGHT' + CALL wrf_message ( a_message ) + + DO npass = 1, smooth_passes + + DO ck = ckts, ckte + DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs + if(mod(cj,2) .eq. 0)THEN + is=0 ! even rows for mass points (2,4,6,8) + else + is=1 ! odd rows for mass points (1,3,5,7) + endif + DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs + IF(IS==0)THEN ! (2,4,6,8) + AVGH = CFLD(CI,CJ+1,CK) + CFLD(CI,CJ-1,CK) + CFLD(CI+1,CJ+1,CK) + CFLD(CI+1,CJ-1,CK) + ELSE + AVGH = CFLD(CI,CJ+1,CK) + CFLD(CI,CJ-1,CK) + CFLD(CI-1,CJ+1,CK) + CFLD(CI-1,CJ-1,CK) + ENDIF + CFLDNEW(CI,CJ,CK) = (AVGH + 4*CFLD(CI,CJ,CK)) / 8.0 + ENDDO + ENDDO + ENDDO + + DO ck = ckts, ckte + DO cj = MAX(jpos+1,cjts),MIN(jpos+(njde-njds)/nrj-1,cjte) ! exclude top and bottom BCs + if(mod(cj,2) .eq. 0)THEN + is=0 ! even rows for mass points (2,4,6,8) + else + is=1 ! odd rows for mass points (1,3,5,7) + endif + DO ci = MAX(ipos+is,cits),MIN(ipos+(nide-nids)/nri-1,cite) ! excludes LBCs + CFLD(CI,CJ,CK) = CFLDNEW(CI,CJ,CK) + ENDDO + ENDDO + ENDDO + + ENDDO ! do npass + + END SUBROUTINE nmm_smoother_ijk - SUBROUTINE nmm_vsmoother ( cfld , & + SUBROUTINE nmm_vsmoother_ikj ( cfld , & cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & cits, cite, ckts, ckte, cjts, cjte, & @@ -5435,7 +4206,7 @@ SUBROUTINE nmm_vsmoother ( cfld , & ENDDO - END SUBROUTINE nmm_vsmoother + END SUBROUTINE nmm_vsmoother_ikj !====================================================================================== ! End of gopal's doing !====================================================================================== @@ -6036,6 +4807,56 @@ subroutine UpCopy (cfld, & ! CD field endif end subroutine UpCopy + subroutine UpMax (cfld, & ! CD field + cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nfld, & ! ND field + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw, & ! stencil half width for interp + imask, & ! interpolation mask + xstag, ystag, & ! staggering of field + ipos, jpos, & ! Position of lower left of nest in CD + nri, nrj) ! nest ratios + + use module_interp_nmm, only: n2c_max3d, n2c_max2d + implicit none + LOGICAL,INTENT(IN) :: xstag, ystag + INTEGER,INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde, & + cims, cime, ckms, ckme, cjms, cjme, & + cits, cite, ckts, ckte, cjts, cjte, & + nids, nide, nkds, nkde, njds, njde, & + nims, nime, nkms, nkme, njms, njme, & + nits, nite, nkts, nkte, njts, njte, & + shw,ipos,jpos,nri,nrj + + INTEGER,DIMENSION(nims:nime,njms:njme), INTENT(IN) :: IMASK + REAL,DIMENSION(cims:cime,cjms:cjme,ckms:ckme), INTENT(OUT) :: CFLD + REAL,DIMENSION(nims:nime,njms:njme,nkms:nkme), INTENT(IN) :: nfld + + if(nkts==nkte) then + call n2c_max2d(& + cfld,nfld,ipos,jpos, & + cids, cide, cjds, cjde, & + cims, cime, cjms, cjme, & + cits, cite, cjts, cjte, & + nids, nide, njds, njde, & + nims, nime, njms, njme, & + nits, nite, njts, njte, .true.) + else + call n2c_max3d(& + cfld,nfld,ipos,jpos, & + cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cits, cite, cjts, cjte, ckts, ckte, & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nits, nite, njts, njte, nkts, nkte, .true.) + endif + end subroutine UpMax + subroutine DownCopy (cfld, & ! CD field cids, cide, ckds, ckde, cjds, cjde, & cims, cime, ckms, ckme, cjms, cjme, & @@ -6569,6 +5390,8 @@ END SUBROUTINE BdyINear #endif +! Third block of ARW-specific routines +#if ! defined(NMM_CORE) || NMM_CORE!=1 SUBROUTINE interp_mask_field ( enable, & ! says whether to allow interpolation or just the bcasts cfld, & ! CD field @@ -6976,3 +5799,5 @@ SUBROUTINE interp_mask_soil ( enable, & ! says whether to allo deallocate (icount_land) END SUBROUTINE interp_mask_soil +#endif +! End of third block of ARW-only routines diff --git a/wrfv2_fire/share/landread.c b/wrfv2_fire/share/landread.c index f8075c0f..40325876 100644 --- a/wrfv2_fire/share/landread.c +++ b/wrfv2_fire/share/landread.c @@ -95,8 +95,8 @@ static TsFileInfo tsfTopo; static TsFileInfo tsfOcean; static TsFileInfo tsfLU; -static int tsFileInfo_initialized = 0 ; -//static float last_adx = 0.0 ; +static int tsFileInfo_initialized = 0; +/* static float last_adx = 0.0 ; */ static char tsfTopo_fn[MAXLEN]; static char tsfLU_fn[MAXLEN]; @@ -458,7 +458,7 @@ int tsInitFileInfo (char path[]) return(-1); } - //skipps header + /* skipps header */ fgets(buff, MAXLEN, fp); while (fscanf(fp, "%s %s %s", type, res, fn) != EOF) { @@ -593,8 +593,8 @@ int GET_LANDUSE ( float *adx, if ( tsFileInfo_initialized == -1 ) { return(1); } } -//if ( fabs(last_adx - *adx) > 1.0E-6 ) { -// last_adx = *adx; +/* if ( fabs(last_adx - *adx) > 1.0E-6 ) { */ +/* last_adx = *adx; */ if ( tsfLU.num > 0 ) { strcpy(tsfLU_fn, tsfLU.fn[tsfLU.num-1]); for ( i = 0; i < tsfLU.num; i++) { @@ -612,7 +612,7 @@ int GET_LANDUSE ( float *adx, # endif return(1); } -//} +/* } */ /* Get the land use. */ if (tsInitTileSet(tsfLU_fn)) { return(1); } @@ -666,8 +666,8 @@ int GET_TERRAIN ( float *adx, /* Use the data with the largest spacing less than the grid spacing specified in the argument list. */ -//if ( fabs(last_adx - *adx) > 1.0E-6 ) { -// last_adx = *adx; +/* if ( fabs(last_adx - *adx) > 1.0E-6 ) { */ +/* last_adx = *adx; */ if ( tsfTopo.num > 0 ) { strcpy(tsfTopo_fn, tsfTopo.fn[tsfTopo.num-1]); for (i = 0; i < tsfTopo.num; i++) { @@ -702,7 +702,7 @@ fprintf(stderr,"%d fn %s dx %f adx %f\n",i,tsfTopo.fn[i],tsfTopo.dx[i],*adx ) ; return(1); } #endif -//} +/* } */ /* First get the terrain from GTOPO30. */ if (tsInitTileSet(tsfTopo_fn)) { return(1); } diff --git a/wrfv2_fire/share/mediation_feedback_domain.F b/wrfv2_fire/share/mediation_feedback_domain.F index 8ce8e52f..ddc53cb3 100644 --- a/wrfv2_fire/share/mediation_feedback_domain.F +++ b/wrfv2_fire/share/mediation_feedback_domain.F @@ -2,9 +2,13 @@ !WRF:MEDIATION_LAYER:NESTING ! SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) + USE module_timing, only: now_time USE module_domain USE module_configure USE module_intermediate_nmm +#ifdef NMM_FIND_LOAD_IMBALANCE + USE module_dm, only: local_communicator +#endif IMPLICIT NONE TYPE(domain), POINTER :: parent_grid , nested_grid TYPE(domain), POINTER :: grid @@ -16,6 +20,19 @@ SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y +#ifdef NMM_FIND_LOAD_IMBALANCE + REAL(kind=8), save :: total_time(40)=0. +#if(NMM_NEST==1) + REAL(kind=8), save :: p2i_1_time(40)=0. + REAL(kind=8), save :: p2i_2_time(40)=0. + REAL(kind=8) :: p2i_1_now, p2i_2_now +#endif + REAL(kind=8), save :: feed1_time(40)=0. + REAL(kind=8), save :: feed2_time(40)=0. + REAL(kind=8) :: this_time,ttime, feed1_now, feed2_now + integer :: ierr +#endif + character*255 :: message ! ---------------------------------------------------------- ! ------------------------------------------------------ ! Interface blocks @@ -118,6 +135,9 @@ END SUBROUTINE feedback_domain_nmm_part2 ! ---------------------------------------------------------- ! Executable code ! ---------------------------------------------------------- +#ifdef NMM_FIND_LOAD_IMBALANCE + this_time=now_time() +#endif ! ---------------------------------------------------------- ! Feedback calls for EM CORE. ! ---------------------------------------------------------- @@ -204,20 +224,53 @@ END SUBROUTINE feedback_domain_nmm_part2 grid => parent_grid #if (NMM_NEST==1) !# include "deref_kludge.h" + +#ifdef NMM_FIND_LOAD_IMBALANCE + ttime=now_time() + call mpi_barrier(local_communicator,ierr) +#endif + call parent_to_inter_part1(parent_grid, nested_grid%intermediate_grid, & nested_grid, config_flags) +#ifdef NMM_FIND_LOAD_IMBALANCE + call mpi_barrier(local_communicator,ierr) + p2i_1_now=now_time()-ttime + p2i_1_time(nested_grid%id)=p2i_1_time(nested_grid%id)+p2i_1_now + + ttime=now_time() + call mpi_barrier(local_communicator,ierr) +#endif + grid => nested_grid%intermediate_grid call parent_to_inter_part2(nested_grid%intermediate_grid, config_flags) + +#ifdef NMM_FIND_LOAD_IMBALANCE + call mpi_barrier(local_communicator,ierr) + p2i_2_now=now_time()-ttime + p2i_2_time(nested_grid%id)=p2i_2_time(nested_grid%id)+p2i_2_now +#endif #endif ! STEP 2: Interpolate from nest grid to intermediate grid grid => nested_grid%intermediate_grid !# include "deref_kludge.h" +#ifdef NMM_FIND_LOAD_IMBALANCE + ttime=now_time() + call mpi_barrier(local_communicator,ierr) +#endif CALL feedback_domain_nmm_part1 ( grid, nested_grid, config_flags & ! # include "actual_new_args.inc" ! ) +#ifdef NMM_FIND_LOAD_IMBALANCE + call mpi_barrier(local_communicator,ierr) + feed1_now=now_time()-ttime + feed1_time(nested_grid%id)=feed1_time(nested_grid%id)+feed1_now + ttime=now_time() + call mpi_barrier(local_communicator,ierr) +#endif + grid => parent_grid !# include "deref_kludge.h" @@ -227,8 +280,13 @@ END SUBROUTINE feedback_domain_nmm_part2 # include "actual_new_args.inc" ! ) +#ifdef NMM_FIND_LOAD_IMBALANCE + call mpi_barrier(local_communicator,ierr) + feed2_now=now_time()-ttime + feed2_time(nested_grid%id)=feed2_time(nested_grid%id)+feed2_now grid => nested_grid%intermediate_grid #endif +#endif ! ------------------------------------------------------ ! End of Feedback calls for NMM. ! ------------------------------------------------------ @@ -241,6 +299,25 @@ END SUBROUTINE feedback_domain_nmm_part2 ! ------------------------------------------------------ ! End of Feedback calls for COAMPS. ! ------------------------------------------------------ +#ifdef NMM_FIND_LOAD_IMBALANCE + this_time=now_time()-this_time + total_time(nested_grid%id)=total_time(nested_grid%id)+this_time +30 format('med_feedback_domain for grid ',I0,' to grid ',I0,': ',F12.6,'s; running total: ',F12.6,'s') + write(message,30) nested_grid%id,parent_grid%id,this_time,total_time(nested_grid%id) + call wrf_debug(1,message) +#if (NMM_NEST==1) +40 format(' feedback parts: p2i1=',F7.4,'/',F10.4,' (',F6.2,'%) p2i2=',F7.4,'/',F10.4,' (',F6.2,'%)') + write(message,40) & + p2i_1_now,p2i_1_time(nested_grid%id),p2i_1_time(nested_grid%id)/total_time(nested_grid%id)*100., & + p2i_2_now,p2i_2_time(nested_grid%id),p2i_2_time(nested_grid%id)/total_time(nested_grid%id)*100. + call wrf_debug(1,message) +#endif +50 format(' feedback parts: feed1=',F7.4,'/',F10.4,' (',F6.2,'%) feed2=',F7.4,'/',F10.4,' (',F6.2,'%)') + write(message,50) & + feed1_now,feed1_time(nested_grid%id),feed1_time(nested_grid%id)/total_time(nested_grid%id)*100., & + feed2_now,feed2_time(nested_grid%id),feed2_time(nested_grid%id)/total_time(nested_grid%id)*100. + call wrf_debug(1,message) +#endif RETURN END SUBROUTINE med_feedback_domain diff --git a/wrfv2_fire/share/mediation_force_domain.F b/wrfv2_fire/share/mediation_force_domain.F index 61fb3895..69043c2e 100644 --- a/wrfv2_fire/share/mediation_force_domain.F +++ b/wrfv2_fire/share/mediation_force_domain.F @@ -2,6 +2,9 @@ !WRF:MEDIATION_LAYER:NESTING ! SUBROUTINE med_force_domain ( parent_grid , nested_grid ) +#ifdef NMM_FIND_LOAD_IMBALANCE + USE module_timing, only: now_time +#endif USE module_domain USE module_configure USE module_intermediate_nmm @@ -9,6 +12,11 @@ SUBROUTINE med_force_domain ( parent_grid , nested_grid ) TYPE(domain), POINTER :: parent_grid , nested_grid TYPE(domain), POINTER :: grid INTEGER nlev, msize +#ifdef NMM_FIND_LOAD_IMBALANCE + REAL(kind=8), save :: total_time(40)=0 + REAL(kind=8) :: this_time + character*255 :: message +#endif #if !defined(MAC_KLUDGE) TYPE (grid_config_rec_type) :: config_flags #endif @@ -41,7 +49,7 @@ SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags # include END SUBROUTINE interp_domain_em_part1 - SUBROUTINE force_domain_em_part2 ( grid, nested_grid, config_flags & + SUBROUTINE force_domain_em_part2 ( grid, nested_grid, parent_grid, config_flags & ! # include "dummy_new_args.inc" ! @@ -50,6 +58,7 @@ SUBROUTINE force_domain_em_part2 ( grid, nested_grid, config_flags & USE module_configure TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: nested_grid + TYPE(domain), POINTER :: parent_grid ! KAL added for vertical nesting TYPE (grid_config_rec_type) :: config_flags # include END SUBROUTINE force_domain_em_part2 @@ -131,11 +140,13 @@ END SUBROUTINE force_domain_nmm_part2 ! ---------------------------------------------------------- ! End of Interface blocks ! ---------------------------------------------------------- - ! ---------------------------------------------------------- ! ---------------------------------------------------------- ! Executable code ! ---------------------------------------------------------- +#ifdef NMM_FIND_LOAD_IMBALANCE +this_time=now_time() +#endif ! ---------------------------------------------------------- ! Forcing calls for EM CORE. ! ---------------------------------------------------------- @@ -196,7 +207,7 @@ END SUBROUTINE force_domain_nmm_part2 ! and compute the values for the nest boundaries ! note that this is all local (no communication) CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) - CALL force_domain_em_part2 ( grid, nested_grid, config_flags & + CALL force_domain_em_part2 ( grid, nested_grid, parent_grid, config_flags & ! # include "actual_new_args.inc" ! @@ -333,6 +344,13 @@ END SUBROUTINE force_domain_nmm_part2 ! ------------------------------------------------------ ! End of Forcing calls for COAMPS. ! ------------------------------------------------------ +#ifdef NMM_FIND_LOAD_IMBALANCE + this_time=now_time()-this_time + total_time(parent_grid%id)=total_time(parent_grid%id)+this_time +30 format('med_force_domain for grid ',I0,' to grid ',I0,': ',F12.6,'s; running total: ',F12.6,'s') + write(message,30) parent_grid%id,nested_grid%id,this_time,total_time(parent_grid%id) + call wrf_debug(1,message) +#endif RETURN END SUBROUTINE med_force_domain diff --git a/wrfv2_fire/share/mediation_integrate.F b/wrfv2_fire/share/mediation_integrate.F index 352f1ca1..09f033c1 100644 --- a/wrfv2_fire/share/mediation_integrate.F +++ b/wrfv2_fire/share/mediation_integrate.F @@ -103,7 +103,7 @@ SUBROUTINE med_before_solve_io ( grid , config_flags ) DO ialarm = first_auxinput, last_auxinput IF ( .FALSE.) THEN rc = 1 ! dummy statement -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! - Get chemistry data ELSE IF( ialarm .EQ. AUXINPUT5_ALARM .AND. config_flags%chem_opt > 0 ) THEN IF( config_flags%emiss_inpt_opt /= 0 ) THEN @@ -120,7 +120,8 @@ SUBROUTINE med_before_solve_io ( grid , config_flags ) CALL WRFU_AlarmRingerOff( grid%alarms( ialarm ), rc=rc ) ENDIF ENDIF - ELSE IF( ialarm .EQ. AUXINPUT7_ALARM .AND. config_flags%chem_opt > 0 ) THEN + ELSE IF(( ialarm .EQ. AUXINPUT7_ALARM .AND. config_flags%chem_opt > 0 ) .or. & + ( ialarm .EQ. AUXINPUT7_ALARM .AND. config_flags%tracer_opt > 0 ) )THEN IF( config_flags%biomass_burn_opt /= 0 ) THEN IF( WRFU_AlarmIsRinging( grid%alarms( ialarm ), rc=rc ) .OR. & ((config_flags%restart) .AND. ( currTime .EQ. startTime ))) THEN @@ -341,6 +342,14 @@ SUBROUTINE med_interp_domain ( parent , nest ) TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_interp_domain + !KAL + SUBROUTINE init_domain_vert_nesting ( parent, nest ) + !KAL this is a driver to initialize the vertical coordinates for the nest when vertical nesting is used. + USE module_domain, ONLY : domain + IMPLICIT NONE + TYPE(domain), POINTER :: parent, nest + END SUBROUTINE init_domain_vert_nesting + SUBROUTINE med_interp_domain_small ( parent , nest ) USE module_domain , ONLY : domain TYPE(domain) , POINTER :: parent , nest @@ -407,6 +416,8 @@ END SUBROUTINE wrf_tsin END INTERFACE + CALL interp_init + CALL domain_clock_get( parent, start_time=strt_time, current_time=cur_time ) IF ( .not. ( config_flags%restart .AND. strt_time .EQ. cur_time ) ) THEN @@ -425,6 +436,12 @@ END SUBROUTINE wrf_tsin ! initialize some other constants (and 1d arrays in z) CALL init_domain_constants ( parent, nest ) + + if (nest%e_vert /= parent%e_vert) then + ! set up coordinate variables for nest with vertical grid refinement (1d variables in z are done later in med_interp_domain) + CALL init_domain_vert_nesting ( parent, nest ) + endif + ! fill in entire fine grid domain with interpolated coarse grid data CALL med_interp_domain( parent, nest ) @@ -924,7 +941,8 @@ END SUBROUTINE start_domain CALL nl_set_julyr (nest%id, config_flags%julyr) CALL nl_set_julday ( nest%id , config_flags%julday ) !zhang test ends - CALL med_analysis_out ( nest, config_flags ) + CALL model_to_grid_config_rec ( nest%id , model_config_rec , nest_config_flags ) + CALL med_analysis_out ( nest, nest_config_flags ) ELSE @@ -1591,6 +1609,20 @@ SUBROUTINE med_hist_out ( grid , stream, config_flags ) CALL wrf_error_fatal( message ) ENDIF +#ifdef HWRF + ! HWRF special: auxhist2 and auxhist3 are duplicates of + ! history (0), so there is no point in outputting more than one of + ! them at the same time. Prefer 0 over 2, and 2 over 3: + if ( (stream==HISTORY_ALARM .or. stream==AUXHIST2_ALARM) .and. & + WRFU_AlarmIsRinging( grid%alarms(AUXHIST3_ALARM) ) ) then + CALL WRFU_AlarmRingerOff(grid%alarms(AUXHIST3_ALARM)) + endif + if ( stream==HISTORY_ALARM .and. & + WRFU_AlarmIsRinging( grid%alarms(AUXHIST2_ALARM) ) ) then + CALL WRFU_AlarmRingerOff(grid%alarms(AUXHIST2_ALARM)) + endif +#endif + SELECT CASE( stream ) CASE ( HISTORY_ALARM ) CALL open_hist_w( grid, config_flags, stream, HISTORY_ALARM, & @@ -1624,6 +1656,11 @@ SUBROUTINE med_hist_out ( grid , stream, config_flags ) CALL end_timing ( TRIM(message) ) END IF +#if (NMM_CORE == 1) + ! Reset tornado genesis fields after output: + call nmm_request_tg_reset(grid,config_flags,stream) +#endif + RETURN END SUBROUTINE med_hist_out @@ -2021,7 +2058,6 @@ SUBROUTINE open_hist_w ( grid , config_flags, stream, alarm_id, & USE module_configure , ONLY : grid_config_rec_type ! USE module_bc_time_utilities USE module_utility - IMPLICIT NONE ! Arguments TYPE(domain) :: grid @@ -2083,13 +2119,14 @@ SUBROUTINE open_hist_w ( grid , config_flags, stream, alarm_id, & TRIM ( fname ), ierr CALL wrf_message( message ) ENDIF + RETURN END SUBROUTINE open_hist_w !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) SUBROUTINE med_read_wrf_chem_input ( grid , config_flags ) ! Driver layer diff --git a/wrfv2_fire/share/mediation_interp_domain.F b/wrfv2_fire/share/mediation_interp_domain.F index 72984cea..09733308 100644 --- a/wrfv2_fire/share/mediation_interp_domain.F +++ b/wrfv2_fire/share/mediation_interp_domain.F @@ -10,7 +10,11 @@ SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) TYPE(domain), POINTER :: grid INTEGER nlev, msize TYPE (grid_config_rec_type) :: config_flags - +#ifdef NMM_FIND_LOAD_IMBALANCE + REAL(kind=8), save :: total_time(40)=0 + REAL(kind=8) :: this_time + character*255 :: message +#endif ! ---------------------------------------------------------- ! ---------------------------------------------------------- ! Interface blocks @@ -38,7 +42,7 @@ SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags # include END SUBROUTINE interp_domain_em_part1 - SUBROUTINE interp_domain_em_part2 ( grid, nested_grid, config_flags & + SUBROUTINE interp_domain_em_part2 ( grid, nested_grid, parent_grid, config_flags & ! # include "dummy_new_args.inc" ! @@ -47,6 +51,7 @@ SUBROUTINE interp_domain_em_part2 ( grid, nested_grid, config_flags & USE module_configure TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: nested_grid + TYPE(domain), POINTER :: parent_grid !KAL added for vertical nesting TYPE (grid_config_rec_type) :: config_flags # include END SUBROUTINE interp_domain_em_part2 @@ -103,6 +108,9 @@ END SUBROUTINE interp_domain_nmm_part2 ! ---------------------------------------------------------- ! Executable code ! ---------------------------------------------------------- +#ifdef NMM_FIND_LOAD_IMBALANCE + this_time=now_time() +#endif ! ---------------------------------------------------------- ! Interpolation calls for EM CORE. The called ! routines below are supplied by module_dm.F @@ -134,7 +142,8 @@ END SUBROUTINE interp_domain_nmm_part2 ) grid => nested_grid%intermediate_grid CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) - CALL interp_domain_em_part2 ( grid, nested_grid, config_flags & + + CALL interp_domain_em_part2 ( grid, nested_grid, parent_grid, config_flags & ! # include "actual_new_args.inc" ! @@ -214,6 +223,13 @@ END SUBROUTINE interp_domain_nmm_part2 ! ------------------------------------------------------ ! End of Interpolation calls for COAMPS. ! ------------------------------------------------------ +#ifdef NMM_FIND_LOAD_IMBALANCE + this_time=now_time()-this_time + total_time(parent_grid%id)=total_time(parent_grid%id)+this_time +30 format('med_interp_domain for grid ',I0,' to grid ',I0,': ',F12.6,'s; running total: ',F12.6,'s') + write(message,30) parent_grid%id,nested_grid%id,this_time,total_time(parent_grid%id) + call wrf_debug(1,message) +#endif RETURN END SUBROUTINE med_interp_domain diff --git a/wrfv2_fire/share/mediation_nest_move.F b/wrfv2_fire/share/mediation_nest_move.F index 389662ea..2c937638 100644 --- a/wrfv2_fire/share/mediation_nest_move.F +++ b/wrfv2_fire/share/mediation_nest_move.F @@ -1505,7 +1505,6 @@ LOGICAL FUNCTION direction_of_move ( parent , grid , move_cd_x, move_cd_y ) ! ORIGINAL DATE: 10/12/2009 ! Modified: 2/28/2010 ! PURPOSE: DEICDE THE DIRECTION OF MOVE - USE module_domain USE module_configure USE module_dm @@ -1585,7 +1584,7 @@ end subroutine init_hnear END INTERFACE ! executable ! -! Simplifying assumption: domains in moving nest simulations have only +! Simplifying assumption: moving domains in moving nest simulations have only ! one parent and only one child. IF ( grid%num_nests .GT. 1 ) THEN @@ -1606,55 +1605,14 @@ end subroutine init_hnear IF ( grid%num_nests .EQ. 0 ) THEN ! code that executes on innermost nest - !------------------- BEGIN DEAD CODE ------------------- - - ! SGT: disabled this code because it does nothing (it's a very - ! expensive and complicated no-op). - - ! Unless someone knows of a good reason for it to be here, - ! it should be deleted. - if(0==1) then - par => grid%parents(1)%ptr - nst => grid - -100 CONTINUE - CALL get_ijk_from_grid ( nst , & - nids, nide, njds, njde, nkds, nkde, & - nims, nime, njms, njme, nkms, nkme, & - nips, nipe, njps, njpe, nkps, nkpe ) - CALL get_ijk_from_grid ( par , & - cids, cide, cjds, cjde, ckds, ckde, & - cims, cime, cjms, cjme, ckms, ckme, & - cips, cipe, cjps, cjpe, ckps, ckpe ) - CALL nl_get_parent_grid_ratio ( nst%id , pgr ) - - IF ( par%id .EQ. 1 ) THEN -! IF ( would_move_x .NE. 0 .AND. move_cd_x .NE. 0 ) THEN - CALL wrf_message('MOAD can not move. Cancelling nest move in X') -! if ( grid%num_nests .eq. 0 ) grid%vc_i = grid%vc_i + move_cd_x * pgr ! cancel effect of move -! move_cd_x = 0 -! ENDIF -! IF ( would_move_y .NE. 0 .AND. move_cd_y .NE. 0 ) THEN - CALL wrf_message('MOAD can not move. Cancelling nest move in Y') -! if ( grid%num_nests .eq. 0 ) grid%vc_j = grid%vc_j + move_cd_y * pgr ! cancel effect of move -! move_cd_y = 0 -! ENDIF - ELSE - nst => par - par => nst%parents(1)%ptr - GOTO 100 - ENDIF ! bottom of until loop - endif - !-------------------- END DEAD CODE -------------------- - direction_of_move = ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 ) ELSE ! move this domain (the parent containing the moving nest) ! in a direction that reestablishes the distance from ! the boundary. - IF ( direction_of_move ) THEN - IF ( grid%id .EQ. 1 ) THEN + move_domain: IF ( direction_of_move ) THEN + no_nests: IF ( grid%id .EQ. 1 ) THEN CALL wrf_message( 'DANGER: Nest has moved too close to boundary of outermost domain.' ) move_cd_x = 0 @@ -1662,6 +1620,7 @@ end subroutine init_hnear direction_of_move = .FALSE. ELSE + CALL get_ijk_from_grid ( grid%nests(kid)%ptr , & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & @@ -1736,8 +1695,31 @@ end subroutine init_hnear IMS,IME,JMS,JME,KMS,KME, & ITS,ITE,JTS,JTE,KTS,KTE ) - ENDIF - ENDIF + ENDIF no_nests + if(grid%vortex_tracker == 6 .or. grid%vortex_tracker == 7) then + ! Update storm center gridpoint location, radius from + ! storm center and angle to storm center: + call nmm_med_tracker_post_move(grid) + endif + + if(grid%swath_mode==1) then + ! Will need to update area of interest after domain shift: + grid%update_interest=.true. + + ! Parent must also update area of interest after its nest + ! moves if the parent has interest_kids set: + if(parent%interest_kids/=0) then +38 format('grid ',I2,' updating grid ',I2,' area of interest due to nest motion') + write(message,38) grid%id,parent%id + call wrf_debug(1,trim(message)) + parent%update_interest=.true. + else +39 format('grid ',I2,' not updating grid ',I2,' area of interest because interest_kids is 0') + write(message,39) grid%id,parent%id + call wrf_debug(1,trim(message)) + endif + endif + ENDIF move_domain ENDIF diff --git a/wrfv2_fire/share/module_bc.F b/wrfv2_fire/share/module_bc.F index 74c23c2c..7b494fff 100644 --- a/wrfv2_fire/share/module_bc.F +++ b/wrfv2_fire/share/module_bc.F @@ -1594,6 +1594,7 @@ SUBROUTINE spec_bdytend_perturb ( field_tend, & mu_2, mub, variable_in, & msf, config_flags, & spec_bdy_width, spec_zone, & + kme_stoch, & ! stoch dims ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims ips,ipe, jps,jpe, kps,kpe, & ! patch dims @@ -1607,18 +1608,18 @@ SUBROUTINE spec_bdytend_perturb ( field_tend, & IMPLICIT NONE INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde - INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme, kme_stoch INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte INTEGER, INTENT(IN ) :: spec_bdy_width, spec_zone CHARACTER, INTENT(IN ) :: variable_in - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT ) :: field_tend - REAL, DIMENSION( ims:ime , kms:kme , jms:kme ), INTENT(IN ) :: field_tend_perturb - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: mu_2 - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: mub - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: msf + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT ) :: field_tend + REAL, DIMENSION( ims:ime , kms:kme_stoch , jms:kme ), INTENT(IN ) :: field_tend_perturb + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: mu_2 + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: mub + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: msf TYPE( grid_config_rec_type ) config_flags @@ -1633,7 +1634,7 @@ SUBROUTINE spec_bdytend_perturb ( field_tend, & IF (variable == 'U') variable = 'u' IF (variable == 'V') variable = 'v' - IF (variable == 'M') variable = 'm' + IF (variable == 'T') variable = 't' IF (variable == 'H') variable = 'h' ibs = ids @@ -1647,7 +1648,7 @@ SUBROUTINE spec_bdytend_perturb ( field_tend, & IF (variable == 'u') itf = min(ite,ide) IF (variable == 'v') jbe = jde IF (variable == 'v') jtf = min(jte,jde) - IF (variable == 'm') ktf = kte + IF (variable == 't') ktf = kte IF (variable == 'h') ktf = kte IF (jts - jbs .lt. spec_zone) THEN @@ -1661,15 +1662,18 @@ SUBROUTINE spec_bdytend_perturb ( field_tend, & DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) IF (variable == 't') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j)) + field_tend_perturb(i,min(k,kme_stoch),j) * & + (mu_2(i,j)+mub(i,j)) ENDIF IF (variable == 'u') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j) + field_tend_perturb(i,min(k,kme_stoch),j) * & + 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j) ENDIF IF (variable == 'v') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j) + field_tend_perturb(i,min(k,kme_stoch),j) * & + 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j) ENDIF ENDDO ENDDO @@ -1687,15 +1691,15 @@ SUBROUTINE spec_bdytend_perturb ( field_tend, & DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) IF (variable == 't') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j)) + field_tend_perturb(i,min(k,kme_stoch),j) * (mu_2(i,j)+mub(i,j)) ENDIF IF (variable == 'u') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j) + field_tend_perturb(i,min(k,kme_stoch),j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j) ENDIF IF (variable == 'v') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j) + field_tend_perturb(i,min(k,kme_stoch),j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j) ENDIF ENDDO ENDDO @@ -1711,15 +1715,15 @@ SUBROUTINE spec_bdytend_perturb ( field_tend, & DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) IF (variable == 't') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j)) + field_tend_perturb(i,min(k,kme_stoch),j) * (mu_2(i,j)+mub(i,j)) ENDIF IF (variable == 'u') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j) + field_tend_perturb(i,min(k,kme_stoch),j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j) ENDIF IF (variable == 'v') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j) + field_tend_perturb(i,min(k,kme_stoch),j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j) ENDIF ENDDO ENDDO @@ -1734,15 +1738,15 @@ SUBROUTINE spec_bdytend_perturb ( field_tend, & DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) IF (variable == 't') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * (mu_2(i,j)+mub(i,j)) + field_tend_perturb(i,min(k,kme_stoch),j) * (mu_2(i,j)+mub(i,j)) ENDIF IF (variable == 'u') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j) + field_tend_perturb(i,min(k,kme_stoch),j) * 0.5*(mu_2(i,j)+mu_2(i-1,j) + mub(i,j)+mub(i-1,j)) / msf(i,j) ENDIF IF (variable == 'v') THEN field_tend(i,k,j) = field_tend(i,k,j) + & - field_tend_perturb(i,k,j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j) + field_tend_perturb(i,min(k,kme_stoch),j) * 0.5*(mu_2(i,j)+mu_2(i,j-1) + mub(i,j)+mub(i,j-1)) / msf(i,j) ENDIF ENDDO ENDDO @@ -1753,6 +1757,116 @@ SUBROUTINE spec_bdytend_perturb ( field_tend, & END SUBROUTINE spec_bdytend_perturb +!------------------------------------------------------------------------ + + SUBROUTINE spec_bdytend_perturb_chem ( field_bdy_tend_xs, field_bdy_tend_xe, & + field_bdy_tend_ys, field_bdy_tend_ye, & + field_scalar_perturb, & + variable_in, & + periodic_x, & + spec_bdy_width, spec_zone, & + kme_stoch, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + ips,ipe, jps,jpe, kps,kpe, & + its,ite, jts,jte, kts,kte ) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme, kme_stoch + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: spec_bdy_width, spec_zone + CHARACTER, INTENT(IN ) :: variable_in + LOGICAL, INTENT(IN ) :: periodic_x + + REAL, DIMENSION( ims:ime , kms:kme_stoch , jms:kme ) , INTENT(IN ) :: field_scalar_perturb + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(INOUT) :: field_bdy_tend_xs, field_bdy_tend_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(INOUT) :: field_bdy_tend_ys, field_bdy_tend_ye + + CHARACTER :: variable + INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf + INTEGER :: b_dist, b_limit + + variable = variable_in + IF (variable == 'C') variable = 'c' + + IF (variable /= 'c') THEN + write( wrf_err_message ,*) ' *** Error in spec_bdytend_perturb_chem' + CALL wrf_message ( wrf_err_message ) + ENDIF + + ibs = ids + ibe = ide-1 + itf = min(ite,ide-1) + jbs = jds + jbe = jde-1 + jtf = min(jte,jde-1) + ktf = kde-1 + !ktf = kte + + IF (jts - jbs .lt. spec_zone) THEN +! Y-start boundary + DO j = jts, min(jtf,jbs+spec_zone-1) + b_dist = j - jbs + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + field_bdy_tend_ys(i,k,b_dist+1) = field_bdy_tend_ys(i,k,b_dist+1) * & + (1.0 + field_scalar_perturb(i,min(k,kme_stoch),j)) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (jbe - jtf .lt. spec_zone) THEN +! Y-end boundary + DO j = max(jts,jbe-spec_zone+1), jtf + b_dist = jbe - j + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + field_bdy_tend_ye(i,k,b_dist+1) = field_bdy_tend_ye(i,k,b_dist+1) * & + (1.0 + field_scalar_perturb(i,min(k,kme_stoch),j)) + ENDDO + ENDDO + ENDDO + ENDIF + + IF(.NOT.periodic_x)THEN + + IF (its - ibs .lt. spec_zone) THEN +! X-start boundary + DO i = its, min(itf,ibs+spec_zone-1) + b_dist = i - ibs + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + field_bdy_tend_xs(j,k,b_dist+1) = field_bdy_tend_xs(j,k,b_dist+1) * & + (1.0 + field_scalar_perturb(i,min(k,kme_stoch),j)) + ENDDO + ENDDO + ENDDO + ENDIF + + IF (ibe - itf .lt. spec_zone) THEN +! X-end boundary + DO i = max(its,ibe-spec_zone+1), itf + b_dist = ibe - i + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + field_bdy_tend_xe(j,k,b_dist+1) = field_bdy_tend_xe(j,k,b_dist+1) * (1.0 + field_scalar_perturb(i,k,j)) + ENDDO + ENDDO + ENDDO + ENDIF + + ENDIF ! IF(.NOT.periodic_x)THEN + + END SUBROUTINE spec_bdytend_perturb_chem + !------------------------------------------------------------------------ SUBROUTINE spec_bdyfield ( field, & @@ -1980,6 +2094,158 @@ SUBROUTINE spec_bdyupdate( field, & END SUBROUTINE spec_bdyupdate !------------------------------------------------------------------------ + SUBROUTINE spec_bdy_final ( field, mu, msf, & + field_bdy_xs, field_bdy_xe, & + field_bdy_ys, field_bdy_ye, & + field_bdy_tend_xs, field_bdy_tend_xe, & + field_bdy_tend_ys, field_bdy_tend_ye, & + variable_in, config_flags, & + spec_bdy_width, spec_zone, & + dtbc, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ips,ipe, jps,jpe, kps,kpe, & ! patch dims + its,ite, jts,jte, kts,kte ) + +! This subroutine forces the boundary to match the boundary file value for specified +! boundary conditions. Added to avoid drift due to round-off error using just tendencies. +! Boundary-file coupling is u,v,w:mu/msf other fields:mu +! Correctly staggered mu and msf are passed in (as seen in small_step_finish) +! spec_bdy_width is only used to dimension the boundary arrays. +! relax_zone is the inner edge of the boundary relaxation zone treated here. +! spec_zone is the width of the outer specified b.c.s that are not changed here. +! (JD Jan 2015) + + IMPLICIT NONE + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: spec_bdy_width, spec_zone + REAL, INTENT(IN ) :: dtbc + CHARACTER, INTENT(IN ) :: variable_in + + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field + REAL, DIMENSION( ims:ime , jms:jme), INTENT(IN ) :: mu, msf + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_xs, field_bdy_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_ys, field_bdy_ye + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_tend_xs, field_bdy_tend_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: field_bdy_tend_ys, field_bdy_tend_ye + TYPE( grid_config_rec_type ) config_flags + + CHARACTER :: variable + INTEGER :: i, j, k, ibs, ibe, jbs, jbe, itf, jtf, ktf, im1, ip1 + INTEGER :: b_dist, b_limit + REAL :: bfield, xmsf, xmu + LOGICAL :: periodic_x, msfcouple, mucouple + + periodic_x = config_flags%periodic_x + variable = variable_in + + IF (variable == 'U') variable = 'u' + IF (variable == 'V') variable = 'v' + IF (variable == 'W') variable = 'w' + IF (variable == 'M') variable = 'm' + IF (variable == 'T') variable = 't' + IF (variable == 'H') variable = 'h' + + ibs = ids + ibe = ide-1 + itf = min(ite,ide-1) + jbs = jds + jbe = jde-1 + jtf = min(jte,jde-1) + ktf = kde-1 + IF (variable == 'u') ibe = ide + IF (variable == 'u') itf = min(ite,ide) + IF (variable == 'v') jbe = jde + IF (variable == 'v') jtf = min(jte,jde) + IF (variable == 't') ktf = kte + IF (variable == 'm') ktf = kte + IF (variable == 'h') ktf = kde + IF (variable == 'w') ktf = kde + + msfcouple = .false. + mucouple = .true. + IF (variable == 'u' .OR. variable == 'v' .OR. variable == 'w')msfcouple = .true. + IF (variable == 'm' )mucouple = .false. + xmsf = 1. + xmu = 1. + + IF (jts - jbs .lt. spec_zone) THEN +! Y-start boundary + DO j = jts, min(jtf,jbs+spec_zone-1) + b_dist = j - jbs + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + bfield = field_bdy_ys(i, k, b_dist+1) & + + dtbc * field_bdy_tend_ys(i, k, b_dist+1) + if(msfcouple)xmsf = msf(i,j) + if(mucouple)xmu = mu(i,j) + field(i,k,j) = xmsf*bfield/xmu + ENDDO + ENDDO + ENDDO + ENDIF + + IF (jbe - jtf .lt. spec_zone) THEN +! Y-end boundary + DO j = max(jts,jbe-spec_zone+1), jtf + b_dist = jbe - j + b_limit = b_dist + IF(periodic_x)b_limit = 0 + DO k = kts, ktf + DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) + bfield = field_bdy_ye(i, k, b_dist+1) & + + dtbc * field_bdy_tend_ye(i, k, b_dist+1) + if(msfcouple)xmsf = msf(i,j) + if(mucouple)xmu = mu(i,j) + field(i,k,j) = xmsf*bfield/xmu + ENDDO + ENDDO + ENDDO + ENDIF + + IF(.NOT.periodic_x)THEN + IF (its - ibs .lt. spec_zone) THEN +! X-start boundary + DO i = its, min(itf,ibs+spec_zone-1) + b_dist = i - ibs + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + bfield = field_bdy_xs(j, k, b_dist+1) & + + dtbc * field_bdy_tend_xs(j, k, b_dist+1) + if(msfcouple)xmsf = msf(i,j) + if(mucouple)xmu = mu(i,j) + field(i,k,j) = xmsf*bfield/xmu + ENDDO + ENDDO + ENDDO + ENDIF + + IF (ibe - itf .lt. spec_zone) THEN +! X-end boundary + DO i = max(its,ibe-spec_zone+1), itf + b_dist = ibe - i + DO k = kts, ktf + DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) + bfield = field_bdy_xe(j, k, b_dist+1) & + + dtbc * field_bdy_tend_xe(j, k, b_dist+1) + if(msfcouple)xmsf = msf(i,j) + if(mucouple)xmu = mu(i,j) + field(i,k,j) = xmsf*bfield/xmu + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + + END SUBROUTINE spec_bdy_final +!------------------------------------------------------------------------ SUBROUTINE zero_grad_bdy ( field, & variable_in, config_flags, & @@ -2225,6 +2491,7 @@ END SUBROUTINE flow_dep_bdy SUBROUTINE flow_dep_bdy_qnn ( field, & u, v, config_flags, & spec_zone, & + ccn_conc, & ! RAS ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims ips,ipe, jps,jpe, kps,kpe, & ! patch dims @@ -2243,6 +2510,7 @@ SUBROUTINE flow_dep_bdy_qnn ( field, & INTEGER, INTENT(IN ) :: ips,ipe, jps,jpe, kps,kpe INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte INTEGER, INTENT(IN ) :: spec_zone + REAL, INTENT(IN ) :: ccn_conc ! RAS REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field @@ -2278,7 +2546,7 @@ SUBROUTINE flow_dep_bdy_qnn ( field, & IF(v(i,k,j) .lt. 0.)THEN field(i,k,j) = field(i_inner,k,jbs+spec_zone) ELSE - field(i,k,j) = n_ccn0 + field(i,k,j) = ccn_conc ! RAS ENDIF ENDDO ENDDO @@ -2298,7 +2566,7 @@ SUBROUTINE flow_dep_bdy_qnn ( field, & IF(v(i,k,j+1) .gt. 0.)THEN field(i,k,j) = field(i_inner,k,jbe-spec_zone) ELSE - field(i,k,j) = n_ccn0 + field(i,k,j) = ccn_conc ! RAS ENDIF ENDDO ENDDO @@ -2317,7 +2585,7 @@ SUBROUTINE flow_dep_bdy_qnn ( field, & IF(u(i,k,j) .lt. 0.)THEN field(i,k,j) = field(ibs+spec_zone,k,j_inner) ELSE - field(i,k,j) = n_ccn0 + field(i,k,j) = ccn_conc ! RAS ENDIF ENDDO ENDDO @@ -2335,7 +2603,7 @@ SUBROUTINE flow_dep_bdy_qnn ( field, & IF(u(i+1,k,j) .gt. 0.)THEN field(i,k,j) = field(ibe-spec_zone,k,j_inner) ELSE - field(i,k,j) = n_ccn0 + field(i,k,j) = ccn_conc ! RAS ENDIF ENDDO ENDDO diff --git a/wrfv2_fire/share/module_check_a_mundo.F b/wrfv2_fire/share/module_check_a_mundo.F index dbafb736..b00716db 100644 --- a/wrfv2_fire/share/module_check_a_mundo.F +++ b/wrfv2_fire/share/module_check_a_mundo.F @@ -56,8 +56,48 @@ SUBROUTINE check_nml_consistency model_config_rec % wrf_hydro = 0 #endif +#if (defined MOVE_NESTS) && (defined VORTEX_CENTER) +!----------------------------------------------------------------------- +! A known problem with moving nests. Users with number of eta levels +! above 55 get a model crash. +!----------------------------------------------------------------------- + + IF ( ( model_config_rec % max_dom .GT. 1 ) .AND. & + ( model_config_rec %e_vert(1) .GT. 55 ) ) THEN + wrf_err_message = '--- ERROR: Known problem. Moving nests need e_vert .LE. 55' + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + END IF +#endif #if (EM_CORE == 1) +!----------------------------------------------------------------------- +! There are restrictions for the use_theta_m option: +! 1. The option to include moist theta in the WRF solver only works with a single domain. +! 2. The option may not be used in conjunction with damp_opt=2. +! 3. The option may not be used with rad_nudge. +!----------------------------------------------------------------------- + + IF ( ( model_config_rec % max_dom .GT. 1 ) .AND. & + ( model_config_rec % use_theta_m .EQ. 1 ) ) THEN + wrf_err_message = '--- ERROR: The use_theta_m option is only available for single domain cases' + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + END IF + + IF ( ( model_config_rec % use_theta_m .EQ. 1 ) .AND. & + ( model_config_rec % damp_opt .EQ. 2 ) ) THEN + CALL wrf_message ( "The use_theta_m option may not be paired with damp_opt=2." ) + wrf_err_message = '--- ERROR: Either turn off use_theta_m, or select a different damp_opt option' + CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + END IF + + IF ( ( model_config_rec % use_theta_m .EQ. 1 ) .AND. & + ( model_config_rec % rad_nudge .EQ. 1 ) ) THEN + CALL wrf_message ( "The use_theta_m option may not be paired with rad_nudge=1." ) + wrf_err_message = '--- ERROR: Either turn off use_theta_m, or turn off the rad_nudge option' + CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + END IF + + !----------------------------------------------------------------------- ! Check that all values of diff_opt and km_opt are filled in. A flag ! value of "-1" from the nml file means that this column (domain) is not @@ -96,11 +136,44 @@ SUBROUTINE check_nml_consistency IF ( ( model_config_rec % km_opt(1) .EQ. -1 ) .OR. & ( model_config_rec % diff_opt(1) .EQ. -1 ) ) THEN - wrf_err_message = 'Both km_opt and diff_opt need to be set in the namelist.input file.' + wrf_err_message = '--- ERROR: Both km_opt and diff_opt need to be set in the namelist.input file.' CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) END IF #endif +!----------------------------------------------------------------------- +! Check that NSSL microphysics is not allowed for WRF-NMM run +!----------------------------------------------------------------------- +#if (NMM_CORE == 1) || (HWRF == 1) + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec % mp_physics(i) == nssl_2mom .OR. & + model_config_rec % mp_physics(i) == nssl_2momccn .OR. & + model_config_rec % mp_physics(i) == nssl_1mom .OR. & + model_config_rec % mp_physics(i) == nssl_1momlfo .OR. & + model_config_rec % mp_physics(i) == nssl_2momg ) THEN + wrf_err_message = '--- ERROR: NSSL scheme cannot run with WRF-NMM ' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = '--- Fix mp_physics in namelist.input ' + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + END IF + ENDDO +#endif + +!----------------------------------------------------------------------- +! Check: if ETAMPNEW microphysics is selected, this has moved to option 95 +!----------------------------------------------------------------------- + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec % mp_physics(i) == etamp_hr ) THEN + wrf_err_message = '--- RESET: ETAMPNEW scheme is now mp_physics=95' + CALL wrf_message ( wrf_err_message ) + model_config_rec % mp_physics(i) = etampnew + END IF + IF ( model_config_rec % mp_physics_dfi(i) == etamp_hr_dfi ) THEN + wrf_err_message = '--- RESET: ETAMPNEW_DFI scheme is now mp_physics_dfi=95' + CALL wrf_message ( wrf_err_message ) + model_config_rec % mp_physics_dfi(i) = etampnew_dfi + END IF + ENDDO !----------------------------------------------------------------------- ! Check that all values of sf_surface_physics are the same for all domains @@ -230,6 +303,14 @@ SUBROUTINE check_nml_consistency #if (EM_CORE == 1) +!----------------------------------------------------------------------- +! Check that if num_metgrid_levels < 20, lagrange_order should be 1 +!----------------------------------------------------------------------- + IF ( model_config_rec%num_metgrid_levels .LE. 20 ) THEN + CALL wrf_message ( 'Linear vertical interpolation is recommended with input vertical resolution this coarse, changing lagrange_order to 1' ) + model_config_rec%lagrange_order = 1 + END IF + !----------------------------------------------------------------------- ! Check for consistency in the Noah-MP options !----------------------------------------------------------------------- @@ -272,35 +353,143 @@ SUBROUTINE check_nml_consistency #endif +#if (NMM_CORE == 1) || (HWRF == 1) +!----------------------------------------------------------------------- +! Check that NOAH-MP LSM is not allowed for WRF-NMM run +!----------------------------------------------------------------------- + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec%sf_surface_physics(i) == NOAHMPSCHEME ) THEN + WRITE(wrf_err_message, '(" --- ERROR: Noah-MP LSM scheme (sf_surface_physics==", I2, ")")') NOAHMPSCHEME + CALL wrf_message ( TRIM ( wrf_err_message ) ) + WRITE(wrf_err_message, '(" does not work with NMM ")') + CALL wrf_message ( TRIM ( wrf_err_message ) ) + WRITE(wrf_err_message, '("Select a different LSM scheme ")') + CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + END IF + END DO +#endif + #if (EM_CORE == 1) + !----------------------------------------------------------------------- -! Check that if any stochastic perturbation scheme is turned on in any domain, -! if so, set grid%stoch_force_global_opt=1 +! Check if any stochastic perturbation scheme is turned on in any domain, +! if so, set derived variable sppt_on=1 and/or rand_perturb_on and/or skebs_on=1 !----------------------------------------------------------------------- - model_config_rec % stoch_force_global_opt=0 !also set in registry.stoch - ! check if stochastic perturbations are turned on in any domain DO i = 1, model_config_rec % max_dom - IF ( model_config_rec % stoch_force_opt(i) .NE. 0) then - model_config_rec % stoch_force_global_opt=1 + IF ( model_config_rec % sppt(i) .ne. 0) then + model_config_rec % sppt_on=1 + IF (( model_config_rec%KMINFORCT .ne. 1) .or. (model_config_rec%KMAXFORCT .ne. 1000000) .or. & + ( model_config_rec%LMINFORCT .ne. 1) .or. (model_config_rec%LMAXFORCT .ne. 1000000)) then + wrf_err_message = '--- Warning: the namelist parameter "kminforct" etc. are for SKEBS only' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = ' and should not be changed from their default value for SPPT' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = '--- ERROR: If you really want to modify "kminforct" etc., edit module_check a_mundo.' + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + endif endif - ENDDO + ENDDO + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec % rand_perturb(i) .ne. 0) then + model_config_rec % rand_perturb_on=1 + IF (( model_config_rec%KMINFORCT .ne. 1) .or. (model_config_rec%KMAXFORCT .ne. 1000000) .or. & + ( model_config_rec%LMINFORCT .ne. 1) .or. (model_config_rec%LMAXFORCT .ne. 1000000)) then + wrf_err_message = '--- Warning: the namelist parameter "kminforct" etc are for SKEBS only' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = ' and should not be changed from their default value for RAND_PERTURB' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = ' ABORT. If you really want to modify "kminforct" etc., edit module_check a_mundo.' + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + endif + endif + ENDDO + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec % stoch_vertstruc_opt(i) ==1 ) then + model_config_rec % skebs_vertstruc=1 ! parameter stoch_vertstruc_opt is being replaced with skebs_vertstruc + ! stoch_vertstruc_opt is obsolete starting with V3.7 + wrf_err_message = '--- WARNING: the namelist parameter "stoch_vertstruc_opt" is obsolete.' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = ' Please replace with namelist parameter "skebs_vertstruc" in V3.7 and later versions.' + CALL wrf_message ( wrf_err_message ) + endif + ENDDO + + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec % stoch_force_opt(i) ==1 ) then + model_config_rec % skebs(i)=1 ! parameter stoch_forc_opt is being replaced with skebs; + ! stoch_vertstruc_opt is obsolete starting with V3.7 + wrf_err_message = '--- WARNING: the namelist parameter "stoch_force_opt" is obsolete.' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = ' Please replace with namelist parameter "skebs" in V3.7 and later versions.' + CALL wrf_message ( wrf_err_message ) + endif + ENDDO + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec % skebs(i) .ne. 0) then + model_config_rec % skebs_on=1 + endif + ENDDO + +!----------------------------------------------------------------------- +! Random fields are by default thin 3D arrays (:,1,:). +! If random fields have vertical structures (stoch_vertstruc_opt .ne. 0) +! make them full 3D array arrays +!----------------------------------------------------------------------- + IF ( model_config_rec % skebs_vertstruc .ne. 99 ) then + model_config_rec % num_stoch_levels = model_config_rec %e_vert(1) + ENDIF + IF ( model_config_rec % sppt_vertstruc .ne. 99 ) then + model_config_rec % num_stoch_levels = model_config_rec %e_vert(1) + ENDIF + IF ( model_config_rec % rand_pert_vertstruc .ne. 99 ) then + model_config_rec % num_stoch_levels = model_config_rec %e_vert(1) + ENDIF !-------------------------------------------------------------------------------- -! KRS: 9/12/2012 ! Check if boundary perturbations is turned on and set to '1' (perturb_bdy=1). -! If so, make sure stoch_force_global_opt is also turned on. (stoch_force_opt=1) +! If so, make sure skebs_on is also turned on. !-------------------------------------------------------------------------------- IF ( model_config_rec % perturb_bdy .EQ. 1 ) then - model_config_rec % stoch_force_global_opt=1 + model_config_rec % skebs_on=1 wrf_err_message = '--- WARNING: perturb_bdy=1 option uses SKEBS pattern and may' CALL wrf_message ( wrf_err_message ) wrf_err_message = ' increase computation time.' CALL wrf_message ( wrf_err_message ) ENDIF +!-------------------------------------------------------------------------------- +! Check if chemistry boundary perturbations is turned on and set to '1' (perturb_chem_bdy=1). +! If so, make sure rand_perturb_on is also turned on. +! perturb_chem_bdy can be turned on only if WRF_CHEM is also compiled. +! If perturb_chem_bdy=1, then have_bcs_chem should be turned on as well. +!-------------------------------------------------------------------------------- + + IF ( model_config_rec % perturb_chem_bdy .EQ. 1 ) then + +#if (WRF_CHEM != 1) + wrf_err_message = '--- ERROR: This option is only for WRF_CHEM.' + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) +#endif + + model_config_rec % rand_perturb_on=1 + wrf_err_message = '--- WARNING: perturb_chem_bdy=1 option uses RAND pattern and may' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = ' increase computation time.' + CALL wrf_message ( wrf_err_message ) + +#if (WRF_CHEM == 1) + IF ( .NOT. model_config_rec % have_bcs_chem(1) ) THEN + wrf_err_message = '--- ERROR: This perturb_chem_bdy option needs '// & + 'have_bcs_chem = .true. in chem.' + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ENDIF +#endif + + ENDIF + !---------------------------------------------------------------------------- -! If trajectory option is turned off, make sure the number of trajectories is +! If trajectory option is turned off, make sure the number of trajectories is ! zero. !---------------------------------------------------------------------------- IF ( ( model_config_rec%traj_opt .EQ. 0 ) .AND. & @@ -326,6 +515,54 @@ SUBROUTINE check_nml_consistency ENDIF #endif +#if (EM_CORE == 1) +!----------------------------------------------------------------------- +! cu_physics = 11 (scale-aware KF) only works with YSU PBL. +!----------------------------------------------------------------------- + + oops = 0 + DO i = 1, model_config_rec % max_dom + IF ( ( model_config_rec%bl_pbl_physics(i) .NE. YSUSCHEME ) .AND. & + ( model_config_rec%cu_physics(i) .EQ. MSKFSCHEME ) ) THEN + oops = oops + 1 + END IF + ENDDO ! Loop over domains + IF ( oops .GT. 0 ) THEN + wrf_err_message = '--- ERROR: bl_pbl_physics must be set to 1 for cu_physics = 11 ' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = '--- Fix bl_pbl_physics in namelist.input OR use another cu_physics option ' + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + END IF + + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec%cu_physics(i) .EQ. MSKFSCHEME ) THEN + WRITE (wrf_err_message, FMT='(A,A)') '--- NOTE: cu_physics is 11, ', & + 'setting icloud = 1 and cu_rad_feedback = T' + CALL wrf_message ( wrf_err_message ) + model_config_rec%cu_rad_feedback(i) = .true. + model_config_rec%icloud = 1 + END IF + ENDDO + +!----------------------------------------------------------------------- +! cu_physics = 10 (Cumulus-potential KF) does not work in 3.7 yet +!----------------------------------------------------------------------- + + oops = 0 + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec%cu_physics(i) .EQ. KFCUPSCHEME ) THEN + oops = oops + 1 + END IF + ENDDO ! Loop over domains + IF ( oops .GT. 0 ) THEN + wrf_err_message = '--- ERROR: cu_physics = 10 is not available in 3.7 ' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = '--- Please select another cu_physics option ' + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + END IF + +#endif + !----------------------------------------------------------------------- ! If sst_update = 0, set io_form_auxinput4 to 0 so WRF will not try to ! input the data; auxinput_interval must also be 0 @@ -353,6 +590,23 @@ SUBROUTINE check_nml_consistency END IF END IF +!----------------------------------------------------------------------- +! The qndropsource relies on the flag PROGN (when not running chemistry) +! and is always allocated when running WRF Chem. +!----------------------------------------------------------------------- + +#if ( (EM_CORE == 1) && (WRF_CHEM != 1) ) + model_config_rec%alloc_qndropsource = 0 + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec%progn(i) .EQ. 1 ) THEN + model_config_rec%alloc_qndropsource = 1 + END IF + END DO + +#elif (WRF_CHEM == 1) + model_config_rec%alloc_qndropsource = 1 +#endif + #if ((EM_CORE == 1) && (DA_CORE != 1)) !----------------------------------------------------------------------- ! Check that if grid_sfdda is one, grid_fdda is also 1 @@ -451,7 +705,7 @@ SUBROUTINE check_nml_consistency END IF ENDDO ! Loop over domains IF ( oops .GT. 0 ) THEN - wrf_err_message = 'bl_pbl_physics /= 4, implies mfshconv must be 0, resetting' + wrf_err_message = '--- NOTE: bl_pbl_physics /= 4, implies mfshconv must be 0, resetting' CALL wrf_message ( wrf_err_message ) END IF @@ -473,10 +727,34 @@ SUBROUTINE check_nml_consistency END IF ENDDO ! Loop over domains IF ( oops .GT. 0 ) THEN - wrf_err_message = 'bl_pbl_physics /= 1,5,6 implies shcu_physics cannot be 3, resetting' + wrf_err_message = '--- NOTE: bl_pbl_physics /= 1,5,6 implies shcu_physics cannot be 3, resetting' CALL wrf_message ( wrf_err_message ) END IF +!----------------------------------------------------------------------- +! We need to know if any of the cumulus schemes are active. This +! allows the model to allocate space. +!----------------------------------------------------------------------- + + model_config_rec%cu_used = 0 + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec%cu_physics(i) .NE. NOCUSCHEME ) THEN + model_config_rec%cu_used = 1 + END IF + ENDDO + +!----------------------------------------------------------------------- +! We need to know if any of the shallow cumulus schemes are active. This +! allows the model to allocate space. +!----------------------------------------------------------------------- + + model_config_rec%shcu_used = 0 + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec%shcu_physics(i) .NE. NOSHCUSCHEME ) THEN + model_config_rec%shcu_used = 1 + END IF + ENDDO + !----------------------------------------------------------------------- ! gwd_opt = 1 only works with YSU PBL. !----------------------------------------------------------------------- @@ -490,7 +768,7 @@ SUBROUTINE check_nml_consistency END IF ENDDO ! Loop over domains IF ( oops .GT. 0 ) THEN - wrf_err_message = 'bl_pbl_physics /= 1, implies gwd_opt cannot be 1, resetting' + wrf_err_message = '--- NOTE: bl_pbl_physics /= 1, implies gwd_opt cannot be 1, resetting' CALL wrf_message ( wrf_err_message ) END IF @@ -629,6 +907,7 @@ SUBROUTINE check_nml_consistency IF ( model_config_rec%cu_diag(i) .EQ. G3TAVE ) THEN IF ( ( model_config_rec%cu_physics(i) .NE. GDSCHEME ) .AND. & ( model_config_rec%cu_physics(i) .NE. GFSCHEME ) .AND. & + ( model_config_rec%cu_physics(i) .NE. KFCUPSCHEME ) .AND. & ( model_config_rec%cu_physics(i) .NE. G3SCHEME ) ) THEN wrf_err_message = '--- ERROR: Using cu_diag=1 requires use of one of the following CU schemes:' CALL wrf_message ( wrf_err_message ) @@ -664,6 +943,7 @@ SUBROUTINE check_nml_consistency DO i = 1, model_config_rec % max_dom IF ( ( model_config_rec%cu_physics(i) .EQ. GDSCHEME ) .OR. & ( model_config_rec%cu_physics(i) .EQ. GFSCHEME ) .OR. & + ( model_config_rec%cu_physics(i) .EQ. KFCUPSCHEME ) .OR. & ( model_config_rec%cu_physics(i) .EQ. G3SCHEME ) ) THEN model_config_rec%cu_diag(i) = 1 ELSE @@ -687,6 +967,16 @@ SUBROUTINE check_nml_consistency END IF ENDDO ! Loop over domains +!----------------------------------------------------------------------- +! Need to set lagday to 150 if tmn_update is 1 +!----------------------------------------------------------------------- + + IF ( model_config_rec%tmn_update .EQ. 1 .AND. & + model_config_rec%lagday .EQ. 1 ) THEN + wrf_err_message = '--- ERROR: Using tmn_update=1 requires lagday=150 ' + CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + END IF + !----------------------------------------------------------------------- ! Do not allow digital filtering to be run with TEMF. !----------------------------------------------------------------------- @@ -699,6 +989,14 @@ SUBROUTINE check_nml_consistency END IF ENDDO ! Loop over domains +!----------------------------------------------------------------------- +! If this is a restart, shut off the DFI. +!----------------------------------------------------------------------- + + IF ( model_config_rec%restart ) THEN + model_config_rec%dfi_opt = DFI_NODFI + END IF + !----------------------------------------------------------------------- ! The CLM scheme may not even be compiled, so make sure it is not allowed ! to be run if the code is not available. @@ -734,7 +1032,7 @@ SUBROUTINE check_nml_consistency END IF ENDDO ! Loop over domains IF ( oops .GT. 0 ) THEN - wrf_err_message = 'mp_physics == 28, already has gravitational fog settling; resetting grav_settling to 0' + wrf_err_message = '--- NOTE: mp_physics == 28, already has gravitational fog settling; resetting grav_settling to 0' CALL wrf_message ( wrf_err_message ) END IF @@ -751,12 +1049,74 @@ SUBROUTINE check_nml_consistency END IF ENDDO ! Loop over domains IF ( oops .GT. 0 ) THEN - wrf_err_message = 'For mp_physics == 28 and use_aero_icbc is true, recommend to turn on scalar_pblmix' + wrf_err_message = '--- WARNING: For mp_physics == 28 and use_aero_icbc is true, recommend to turn on scalar_pblmix' CALL wrf_message ( wrf_err_message ) wrf_err_message = 'resetting scalar_pblmix = 1' CALL wrf_message ( wrf_err_message ) END IF +!----------------------------------------------------------------------- +! Check that vertical levels are defined in a logical way. +!----------------------------------------------------------------------- + + DO i = 1, model_config_rec % max_dom + IF (model_config_rec%vert_refine_method(i) .EQ. 1) THEN + IF (i .EQ. 1) THEN + wrf_err_message = '--- INFO: vert_refine_method=1 for d01, must be 0., resetting value internally' + CALL wrf_message ( wrf_err_message ) + model_config_rec%vert_refine_method(i) = 0 + ELSE + IF (MOD((model_config_rec%e_vert(i)-1),(model_config_rec%e_vert(i-1)-1)) .NE. 0) THEN + wrf_err_message = '--- ERROR: incompatible e_vert for use with int-refinement.' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + ENDIF + ELSEIF (model_config_rec%vert_refine_method(i) .EQ. 2) THEN + IF (i .EQ. 1) THEN + wrf_err_message = '--- ERROR: vert_refine_method=2 for d01, must be 0.' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! Consistency checks between vertical refinement and radiation +! scheme selection. For "choose any vertical levels" for the nest, +! only RRTM and RRTMG are eligible. +!----------------------------------------------------------------------- + + DO i = 2, model_config_rec % max_dom + IF (model_config_rec%vert_refine_method(i) .EQ. 2) THEN + IF ( ( ( model_config_rec%ra_lw_physics(i) .EQ. RRTMSCHEME ) .OR. & + ( model_config_rec%ra_lw_physics(i) .EQ. RRTMG_LWSCHEME ) .OR. & + ( model_config_rec%ra_lw_physics(i) .EQ. RRTMG_LWSCHEME_FAST ) ) .AND. & + ( ( model_config_rec%ra_sw_physics(i) .EQ. SWRADSCHEME ) .OR. & + ( model_config_rec%ra_sw_physics(i) .EQ. RRTMG_SWSCHEME ) .OR. & + ( model_config_rec%ra_sw_physics(i) .EQ. RRTMG_SWSCHEME_FAST ) ) ) THEN + ! We are OK, I just hate writing backwards / negative / convoluted if tests + ! that are not easily comprehensible. + ELSE + wrf_err_message = '--- ERROR: vert_refine_method=2 only works with either RRTM or RRTMG' + CALL wrf_error_fatal ( wrf_err_message ) + END IF + END IF + END DO + +!----------------------------------------------------------------------- +! Set the namelist parameter o3input to 0 for the radiation schemes other +! than RRTMG_LWSCHEME and RRTMG_SWSCHEME. +!----------------------------------------------------------------------- + + IF ( ( model_config_rec % ra_lw_physics(1) .NE. RRTMG_LWSCHEME ) .OR. & + ( model_config_rec % ra_sw_physics(1) .NE. RRTMG_SWSCHEME ) .OR. & + ( model_config_rec % ra_lw_physics(1) .NE. RRTMG_LWSCHEME_FAST ) .OR. & + ( model_config_rec % ra_sw_physics(1) .NE. RRTMG_SWSCHEME_FAST ) ) THEN + model_config_rec % o3input = 0 + wrf_err_message = '--- NOTE: RRTMG radiation is not used, setting: ' // & + 'o3input=0 to avoid data pre-processing' + CALL wrf_message ( wrf_err_message ) + END IF + !----------------------------------------------------------------------- ! Remapping namelist variables for gridded and surface fdda to aux streams 9 and 10. ! Relocated here so that the remappings are after checking the namelist for inconsistencies. @@ -783,10 +1143,12 @@ SUBROUTINE set_physics_rconfigs IMPLICIT NONE + INTEGER :: numsoiltemp , nummosaictemp + INTEGER :: i + !----------------------------------------------------------------------- ! Set the namelist mosaic_cat_soil parameter for the Noah-mosaic scheme if sf_surface_mosaic == 1. !----------------------------------------------------------------------- - INTEGER :: numsoiltemp , nummosaictemp IF ( model_config_rec % sf_surface_mosaic .EQ. 1 ) THEN @@ -801,6 +1163,39 @@ SUBROUTINE set_physics_rconfigs END IF +#if ( (NMM_CORE != 1) && (DA_CORE != 1) ) +!----------------------------------------------------------------------- +! If this is a WRF run with polar boundary conditions, then this is a +! global domain. A global domain needs to have the FFT arrays allocated. +!----------------------------------------------------------------------- + + model_config_rec % fft_used = 0 + IF ( ( model_config_rec % polar(1) ) .AND. & + ( model_config_rec % fft_filter_lat .LT. 90. ) ) THEN + model_config_rec % fft_used = 1 + END IF + +!----------------------------------------------------------------------- +! If any CAM scheme is turned on, then there are a few shared variables. +! These need to be allocated when any CAM scheme is active. +!----------------------------------------------------------------------- + +#if ( (EM_CORE == 1) && (WRF_CHEM != 1) ) + model_config_rec % cam_used = 0 + DO i = 1, model_config_rec % max_dom + IF ( ( model_config_rec % mp_physics(i) .EQ. CAMMGMPSCHEME ) .OR. & + ( model_config_rec % bl_pbl_physics(i) .EQ. CAMUWPBLSCHEME ) .OR. & + ( model_config_rec % shcu_physics(i) .EQ. CAMUWSHCUSCHEME ) ) THEN + model_config_rec % cam_used = 1 + END IF + ENDDO + +#elif (WRF_CHEM == 1) + model_config_rec % cam_used = 1 +#endif + +#endif + !----------------------------------------------------------------------- ! Set the namelist parameters for the CAM radiation scheme if either ! ra_lw_physics = CAMLWSCHEME or ra_sw_physics = CAMSWSCHEME. @@ -818,6 +1213,26 @@ SUBROUTINE set_physics_rconfigs CALL wrf_message ( wrf_err_message ) END IF + +!----------------------------------------------------------------------- +! If a user requested to compute the radar reflectivity .OR. if this is +! one of the schemes that ALWAYS computes the radar reflectivity, then +! turn on the switch that says allocate the space for the refl_10cm array. +!----------------------------------------------------------------------- + + DO i = 1, model_config_rec % max_dom + IF ( ( model_config_rec % mp_physics(i) .EQ. MILBRANDT2MOM ) .OR. & +#if (EM_CORE == 1) + ( model_config_rec % mp_physics(i) .EQ. NSSL_2MOM ) .OR. & + ( model_config_rec % mp_physics(i) .EQ. NSSL_2MOMG ) .OR. & + ( model_config_rec % mp_physics(i) .EQ. NSSL_2MOMCCN ) .OR. & + ( model_config_rec % mp_physics(i) .EQ. NSSL_1MOM ) .OR. & + ( model_config_rec % mp_physics(i) .EQ. NSSL_1MOMLFO ) .OR. & +#endif + ( model_config_rec % do_radar_ref .EQ. 1 ) ) THEN + model_config_rec % compute_radar_ref = 1 + END IF + ENDDO !----------------------------------------------------------------------- ! Set the namelist parameters for the RRTMG radiation scheme if either diff --git a/wrfv2_fire/share/module_date_time.F b/wrfv2_fire/share/module_date_time.F index 3dc24c2d..82b4f8b0 100644 --- a/wrfv2_fire/share/module_date_time.F +++ b/wrfv2_fire/share/module_date_time.F @@ -200,7 +200,7 @@ SUBROUTINE geth_idts (ndate, odate, idts) scold = 0 olen = LEN(odate) - READ(odate(1:4), '(I4)') yrold + READ(odate(1:4), '(I4.4)') yrold #ifdef PLANET READ(odate(6:10), '(I5)') dyold moold=0. @@ -225,7 +225,7 @@ SUBROUTINE geth_idts (ndate, odate, idts) scnew = 0 nlen = LEN(ndate) - READ(ndate(1:4), '(I4)') yrnew + READ(ndate(1:4), '(I4.4)') yrnew #ifdef PLANET READ(ndate(6:10), '(I5)') dynew monew=0. @@ -509,7 +509,7 @@ SUBROUTINE geth_newdate (ndate, odate, idt) ! Use internal READ statements to convert the CHARACTER string ! date into INTEGER components. - READ(odate(1:4), '(I4)') yrold + READ(odate(1:4), '(I4.4)') yrold #ifdef PLANET READ(odate(6:10), '(I5)') dyold moold=0. @@ -773,20 +773,20 @@ SUBROUTINE geth_newdate (ndate, odate, idt) ELSE IF (nlen.eq.19.or.nlen.eq.20) THEN WRITE(ndate(1:19),19) yrnew, monew, dynew, hrnew, minew, scnew - 19 format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2) + 19 format(I4.4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2) IF (nlen.eq.20) ndate = ndate(1:19)//'.' ELSE IF (nlen.eq.16) THEN WRITE(ndate,16) yrnew, monew, dynew, hrnew, minew - 16 format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2) + 16 format(I4.4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2) ELSE IF (nlen.eq.13) THEN WRITE(ndate,13) yrnew, monew, dynew, hrnew - 13 format(I4,'-',I2.2,'-',I2.2,'_',I2.2) + 13 format(I4.4,'-',I2.2,'-',I2.2,'_',I2.2) ELSE IF (nlen.eq.10) THEN WRITE(ndate,10) yrnew, monew, dynew - 10 format(I4,'-',I2.2,'-',I2.2) + 10 format(I4.4,'-',I2.2,'-',I2.2) END IF @@ -835,18 +835,18 @@ SUBROUTINE split_date_char ( date , century_year , month , day , hour , minute , INTEGER , INTENT(OUT) :: century_year , month , day , hour , minute , second , ten_thousandth - READ(date,FMT='( I4)') century_year + READ(date,FMT='( I4.4)') century_year #ifdef PLANET month = 0 - READ(date,FMT='( 5X,I5)') day + READ(date,FMT='( 5X,I5.5)') day #else - READ(date,FMT='( 5X,I2)') month - READ(date,FMT='( 8X,I2)') day + READ(date,FMT='( 5X,I2.2)') month + READ(date,FMT='( 8X,I2.2)') day #endif - READ(date,FMT='(11X,I2)') hour - READ(date,FMT='(14X,I2)') minute - READ(date,FMT='(17X,I2)') second - READ(date,FMT='(20X,I4)') ten_thousandth + READ(date,FMT='(11X,I2.2)') hour + READ(date,FMT='(14X,I2.2)') minute + READ(date,FMT='(17X,I2.2)') second + READ(date,FMT='(20X,I4.4)') ten_thousandth END SUBROUTINE split_date_char diff --git a/wrfv2_fire/share/module_get_file_names.F b/wrfv2_fire/share/module_get_file_names.F index b04e2acf..979e95fb 100644 --- a/wrfv2_fire/share/module_get_file_names.F +++ b/wrfv2_fire/share/module_get_file_names.F @@ -100,7 +100,11 @@ SUBROUTINE unix_ls ( root , id ) CALL wrf_dm_bcast_integer ( number_of_eligible_files, 1 ) ! Allocate space for this many files. + ! GAC 20140321 - Addition to prevent attempts to reallocate same variable. + ! This used to be a bug when running convert_emiss for nested domains + ! a while back, now it is probably just a paranoid check. + IF ( ALLOCATED ( eligible_file_name ) ) DEALLOCATE ( eligible_file_name ) ALLOCATE ( eligible_file_name(number_of_eligible_files) , STAT=ierr ) ! Did the allocate work OK? diff --git a/wrfv2_fire/share/module_interp_nmm.F b/wrfv2_fire/share/module_interp_nmm.F index a077c792..e23715b1 100644 --- a/wrfv2_fire/share/module_interp_nmm.F +++ b/wrfv2_fire/share/module_interp_nmm.F @@ -38,61 +38,77 @@ + W4(i,j)*C(II(i,j)+a,JJ(i,j)+1)) ! Copying from N array to C array: -#define UPCOPY(C,N,i,j,k,ni,nj)\ - C(k,i-istart+1)=(N(ni,nj+2,k)\ - +N(ni-a,nj+1,k)+N(ni+1-a,nj+1,k)\ - +N(ni-1,nj,k)+N(ni,nj,k)+N(ni+1,nj,k)\ - +N(ni-a,nj-1,k)+N(ni+1-a,nj-1,k)\ - +N(ni,nj-2,k)\ - )/9 - -!AveragetoCpointsfromNpointswithoutassignment: -#define NGRAB(N,ni,nj,nk)\ - (N(ni,nj+2,nk)\ - +N(ni-a,nj+1,nk)+N(ni+1-a,nj+1,nk)\ - +N(ni-1,nj,nk)+N(ni,nj,nk)+N(ni+1,nj,nk)\ - +N(ni-a,nj-1,nk)+N(ni+1-a,nj-1,nk)\ - +N(ni,nj-2,nk)\ - )/9 - -!AveragetoCpointsfromNpointswithoutassignmentonanIKJgrid: -#define NGRABIKJ(N,ni,nk,nj)\ - (N(ni,nk,nj+2)\ - +N(ni-a,nk,nj+1)+N(ni+1-a,nk,nj+1)\ - +N(ni-1,nk,nj)+N(ni,nk,nj)+N(ni+1,nk,nj)\ - +N(ni-a,nk,nj-1)+N(ni+1-a,nk,nj-1)\ - +N(ni,nk,nj-2)\ - )/9 - -!AveragetoCpointsfromNpointswithoutassignment,noverticallevels: -#define NGRAB2D(N,ni,nj)\ - (N(ni,nj+2)\ - +N(ni-a,nj+1)+N(ni+1-a,nj+1)\ - +N(ni-1,nj)+N(ni,nj)+N(ni+1,nj)\ - +N(ni-a,nj-1)+N(ni+1-a,nj-1)\ - +N(ni,nj-2)\ - )/9 - -!CopyingfromNarraytoIarray: -#define N2ICOPY(C,N,i,j,k,ni,nj)\ - C(i,j,k)=(N(ni,nj+2,k)\ - +N(ni-a,nj+1,k)+N(ni+1-a,nj+1,k)\ - +N(ni-1,nj,k)+N(ni,nj,k)+N(ni+1,nj,k)\ - +N(ni-a,nj-1,k)+N(ni+1-a,nj-1,k)\ - +N(ni,nj-2,k)\ - )/9 +#define UPCOPY(C,N,i,j,k,ni,nj) \ + C(k,i-istart+1)=(N(ni,nj+2,k) \ + + N(ni-a ,nj+1,k)+ N(ni+1-a,nj+1,k) \ + + N(ni-1,nj ,k)+ N(ni,nj ,k) + N(ni+1,nj ,k) \ + + N(ni-a ,nj-1,k)+ N(ni+1-a,nj-1,k) \ + + N(ni,nj-2,k) \ + ) / 9 + +! Average to C points from N points without assignment: +#define NGRAB(N,ni,nj,nk) \ +(N(ni,nj+2,nk) \ + + N(ni-a ,nj+1,nk)+ N(ni+1-a,nj+1,nk)\ + + N(ni-1,nj ,nk) + N(ni,nj ,nk) + N(ni+1,nj ,nk)\ + + N(ni-a ,nj-1,nk)+ N(ni+1-a,nj-1,nk)\ + + N(ni,nj-2,nk) \ + ) / 9 + +! Average to C points from N points without assignment on an IKJ grid: +#define NGRABIKJ(N,ni,nk,nj) \ +(N(ni,nk,nj+2) \ + + N(ni-a ,nk,nj+1)+ N(ni+1-a,nk,nj+1) \ + + N(ni-1,nk,nj ) + N(ni,nk,nj ) + N(ni+1,nk,nj )\ + + N(ni-a ,nk,nj-1)+ N(ni+1-a,nk,nj-1)\ + + N(ni,nk,nj-2) \ + ) / 9 + +! Average to C points from N points without assignment, no vertical levels: +#define NGRAB2D(N,ni,nj) \ +(N(ni,nj+2) \ + + N(ni-a ,nj+1)+ N(ni+1-a,nj+1)\ + + N(ni-1,nj ) + N(ni,nj ) + N(ni+1,nj )\ + + N(ni-a ,nj-1)+ N(ni+1-a,nj-1)\ + + N(ni,nj-2) \ + ) / 9 + +! Copying from N array to I array: +#define N2ICOPY(C,N,i,j,k,ni,nj) \ + C(i,j,k)=( N(ni,nj+2,k) \ + + N(ni-a ,nj+1,k)+ N(ni+1-a,nj+1,k) \ + + N(ni-1,nj ,k)+ N(ni,nj ,k) + N(ni+1,nj ,k) \ + + N(ni-a ,nj-1,k)+ N(ni+1-a,nj-1,k) \ + + N(ni,nj-2,k) \ + ) / 9 + +! Maximum value from N array to C array: +#define N2I_SET_MAX(C,N,i,j,k,ni,nj) \ + C(i,j,k)=max(C(i,j,k),max(N(ni,nj+2,k), \ + max(N(ni-1,nj ,k),max(N(ni,nj ,k), max(N(ni+1,nj ,k),\ + max(N(ni-a ,nj-1,k),max(N(ni+1-a,nj-1,k),\ + N(ni,nj-2,k) ))))))) + +! Maximum value from N array to C array: +#define N2I_SET_MAX_IJ(C,N,i,j,ni,nj) \ + C(i,j)=max(C(i,j), max(N(ni,nj+2),\ + max(N(ni-1,nj ),max(N(ni,nj ), max(N(ni+1,nj ), \ + max(N(ni-a ,nj-1),max(N(ni+1-a,nj-1), \ + N(ni,nj-2) ))))))) + module module_interp_nmm use module_model_constants, only: g, R_D, p608 implicit none private - public :: interp_T_PD_Q + public :: interp_T_PD_Q, find_kpres public :: nmm_interp_pd, nmm_keep_pd, nmm_method_linear public :: c2b_fulldom, c2n_fulldom, n2c_fulldom - + public :: n2c_max2d, n2c_max3d + public :: c2b_fulldom_new, n2c_fulldom_new public :: c2b_mass, c2n_mass, n2c_mass public :: c2n_massikj, n2c_massikj public :: c2b_copy3d, c2n_copy3d, n2c_copy3d @@ -618,6 +634,50 @@ subroutine n2c_copy2d (& enddo bigj end subroutine n2c_copy2d + subroutine n2c_max2d (& + cfield,nfield,ipos,jpos, & + cids, cide, cjds, cjde, & + cims, cime, cjms, cjme, & + cits, cite, cjts, cjte, & + nids, nide, njds, njde, & + nims, nime, njms, njme, & + nits, nite, njts, njte, & + hgrid) + implicit none + integer, intent(in) :: & + cids, cide, cjds, cjde, & + cims, cime, cjms, cjme, & + cits, cite, cjts, cjte, & + nids, nide, njds, njde, & + nims, nime, njms, njme, & + nits, nite, njts, njte, & + ipos,jpos + real, intent(out) :: cfield(cims:cime,cjms:cjme) + real, intent(in) :: nfield(nims:nime,njms:njme) + logical, intent(in) :: hgrid + + integer, parameter :: nri=3, nrj=3 ! parent:nest ratio, must be 3 in NMM + integer :: nz,jstart,jend,istart,iend,ni,nj,a,i,j + + jstart=MAX(jpos+1,cjts) + jend=MIN(jpos+(njde-njds)/nrj-1,cjte) + + bigj: do j=jstart,jend + a=mod(j,2) + if(.not.hgrid) then + a=1-a + endif + istart=MAX(ipos+a,cits) + iend=MIN(ipos+(nide-nids)/nri-1,cite) + nj = (j-jpos)*nrj + 1 + + iloop: do i=istart,iend + ni = (i-ipos)*nri + 2 - a + N2I_SET_MAX_IJ(cfield,nfield,i,j,ni,nj) + enddo iloop + enddo bigj + end subroutine n2c_max2d + subroutine c2n_copy2d (II,JJ,W1,W2,W3,W4, & cfield,nfield,imask, & cims, cime, cjms, cjme, & @@ -837,6 +897,57 @@ subroutine n2c_copy3d (& enddo bigj end subroutine n2c_copy3d + subroutine n2c_max3d (& + cfield,nfield,ipos,jpos, & + cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cits, cite, cjts, cjte, ckts, ckte, & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nits, nite, njts, njte, nkts, nkte, & + hgrid) + implicit none + logical, intent(in) :: hgrid + integer, intent(in) :: & + cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cits, cite, cjts, cjte, ckts, ckte, & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nits, nite, njts, njte, nkts, nkte, & + ipos,jpos + real, intent(out) :: cfield(cims:cime,cjms:cjme,ckms:ckme) + real, intent(in) :: nfield(nims:nime,njms:njme,nkms:nkme) + + integer, parameter :: nri=3, nrj=3 ! parent:nest ratio, must be 3 in NMM + integer :: nx,nz,jstart,jend,istart,iend,ni,nj,a,i,j,k,nk + real :: weight + + nx=min(nide-2,nite)-max(nids+1,nits)+1 + nz=nkde-nkds+1 + + jstart=MAX(jpos+1,cjts) + jend=MIN(jpos+(njde-njds)/nrj-1,cjte) + + bigj: do j=jstart,jend + if(hgrid) then + a=mod(j,2) + else + a=1-mod(j,2) + endif + istart=MAX(ipos+a,cits) + iend=MIN(ipos+(nide-nids)/nri-1,cite) + nj = (j-jpos)*nrj + 1 + + iloop: do i=istart,iend + do k=nkds,nkde + ni = (i-ipos)*nri + 2 - a + N2I_SET_MAX(cfield,nfield,i,j,k,ni,nj) + enddo + enddo iloop + enddo bigj + end subroutine n2c_max3d + subroutine c2n_copy3d (II,JJ,W1,W2,W3,W4, & cfield,nfield,imask, & cims, cime, cjms, cjme, ckms, ckme, & @@ -892,6 +1003,7 @@ subroutine c2b_mass (II,JJ,W1,W2,W3,W4,cfield, & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nits, nite, njts, njte, nkts, nkte) + use module_interp_store, only: kpres implicit none integer, parameter :: bdyw = 1 @@ -934,7 +1046,10 @@ subroutine c2b_mass (II,JJ,W1,W2,W3,W4,cfield, & i=1 do j=j1,j2,2 a=1-mod(JJ(i,j),2) - kloop1: do k=nkds,min(nkde,nkte) + kcopy1: do k=min(nkde,nkte),kpres+1,-1 + fbxs(j,k,1) = ICOPY(cfield,i,j,k) + enddo kcopy1 + kloop1: do k=kpres,nkds,-1 weight=wbxs(j,k,1) ck=ibxs(j,k,1) @@ -960,7 +1075,10 @@ subroutine c2b_mass (II,JJ,W1,W2,W3,W4,cfield, & i=nide-1 do j=j1,j2,2 a=1-mod(JJ(i,j),2) - kloop2: do k=nkds,min(nkde,nkte) + kcopy2: do k=min(nkde,nkte),kpres+1,-1 + fbxe(j,k,1)=ICOPY(cfield,i,j,k) + enddo kcopy2 + kloop2: do k=kpres,nkds,-1 weight=wbxe(j,k,1) ck=ibxe(j,k,1) @@ -986,7 +1104,10 @@ subroutine c2b_mass (II,JJ,W1,W2,W3,W4,cfield, & j=1 do i=max(nits-1,nids),min(nite+1,nide-1) a=1-mod(JJ(i,j),2) - kloop3: do k=nkts,min(nkde,nkte) + kcopy3: do k=min(nkde,nkte),kpres+1,-1 + fbys(i,k,1) = ICOPY(cfield,i,j,k) + enddo kcopy3 + kloop3: do k=kpres,nkds,-1 weight=wbys(i,k,1) ck=ibys(i,k,1) @@ -1012,7 +1133,10 @@ subroutine c2b_mass (II,JJ,W1,W2,W3,W4,cfield, & j=njde-1 do i=max(nits-1,nids),min(nite+1,nide-1) a=1-mod(JJ(i,j),2) - kloop4: do k=nkts,min(nkde,nkte) + kcopy4: do k=min(nkde,nkte),kpres+1,-1 + fbye(i,k,1) = ICOPY(cfield,i,j,k) + enddo kcopy4 + kloop4: do k=kpres,nkds,-1 weight=wbye(i,k,1) ck=ibye(i,k,1) @@ -1045,6 +1169,7 @@ subroutine n2c_mass (& nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nits, nite, njts, njte, nkts, nkte) + use module_interp_store, only: kpres implicit none integer, intent(in) :: & cids, cide, cjds, cjde, ckds, ckde, & @@ -1069,6 +1194,19 @@ subroutine n2c_mass (& jstart=MAX(jpos+1,cjts) jend=MIN(jpos+(njde-njds)/nrj-1,cjte) + kcopy: do k=ckde,kpres+1,-1 + jcopy: do j=jstart,jend + a=mod(j,2) + istart=MAX(ipos+a,cits) + iend=MIN(ipos+(nide-nids)/nri-1,cite) + nj = (j-jpos)*nrj + 1 + icopy: do i=istart,iend + ni = (i-ipos)*nri + 2 - a + cfield(i,j,k) = NGRAB(nfield,ni,nj,k) + enddo icopy + enddo jcopy + enddo kcopy + bigj: do j=jstart,jend a=mod(j,2) istart=MAX(ipos+a,cits) @@ -1077,7 +1215,7 @@ subroutine n2c_mass (& iloop: do i=istart,iend ni = (i-ipos)*nri + 2 - a - kinterploop: do k=nkds,nkde + kinterploop: do k=kpres,ckds,-1 weight=winfo(i,j,k) nk=iinfo(i,j,k) @@ -1112,6 +1250,7 @@ subroutine n2c_massikj (& nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nits, nite, njts, njte, nkts, nkte) + use module_interp_store, only: kpres implicit none integer, intent(in) :: & cids, cide, cjds, cjde, ckds, ckde, & @@ -1142,7 +1281,14 @@ subroutine n2c_massikj (& iend=MIN(ipos+(nide-nids)/nri-1,cite) nj = (j-jpos)*nrj + 1 - kinterploop: do k=nkds,nkde + kcopyloop: do k=nkde,kpres+1,-1 + icopyloop: do i=istart,iend + ni = (i-ipos)*nri + 2 - a + cfield(i,k,j) = NGRABIKJ(nfield,ni,k,nj) + enddo icopyloop + enddo kcopyloop + + kinterploop: do k=kpres+1,nkds,-1 iloop: do i=istart,iend ni = (i-ipos)*nri + 2 - a weight=winfo(i,j,k) @@ -1177,6 +1323,7 @@ subroutine c2n_mass (II,JJ,W1,W2,W3,W4, & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nits, nite, njts, njte, nkts, nkte) + use module_interp_store, only: kpres implicit none real, intent(in), dimension(nims:nime,njms:njme) :: & W1,W2,W3,W4 @@ -1192,19 +1339,35 @@ subroutine c2n_mass (II,JJ,W1,W2,W3,W4, & integer, intent(in), dimension(nims:nime,njms:njme) :: imask real, intent(in) :: cfield(cims:cime,cjms:cjme,ckms:ckme) real, intent(out) :: nfield(nims:nime,njms:njme,nkms:nkme) - + character*255 :: message integer :: j,i,a,nx,nz,ck,k real :: weight nx=min(nide-1,nite)-max(nids,nits)+1 nz=nkde-nkds+1 - + if(kpres<=nkds .or. kpres>=nkde) then + call wrf_error_fatal('invalid kpres: outside domain bounds') + end if bigj: do j=max(njds,njts),min(njde-1,njte) interploop: do i=max(nids,nits),min(nide-1,nite) if(imask(i,j)/=0) cycle interploop - kinterploop: do k=nkds,nkde - a=1-mod(JJ(i,j),2) - + a=1-mod(JJ(i,j),2) + kcopyloop: do k=nkde,kpres+1,-1 + nfield(i,j,k)=ICOPY(cfield,i,j,k) + !weight=winfo(i,j,k) + ck=iinfo(i,j,k) +! if(1.-weight>1e-5) then +! 2000 format(I0,", ",I0,", ",I0,": invalid weight at constant pressure level: w=",F0.5," i=",I0) +! write(message,2000) i,j,k, weight,ck +! call wrf_error_fatal(message) +! endif +! if(ck/=k) then +! 2001 format(I0,", ",I0,", ",I0,": invalid iinfo at constant pressure level: w=",F0.5," i=",I0) +! write(message,2000) i,j,k, weight,ck +! call wrf_error_fatal(message) +! endif + enddo kcopyloop + kinterploop: do k=kpres,nkds,-1 weight=winfo(i,j,k) ck=iinfo(i,j,k) @@ -1236,6 +1399,7 @@ subroutine c2n_massikj (II,JJ,W1,W2,W3,W4, & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nits, nite, njts, njte, nkts, nkte) + use module_interp_store, only: kpres implicit none real, intent(in), dimension(nims:nime,njms:njme) :: & W1,W2,W3,W4 @@ -1261,9 +1425,11 @@ subroutine c2n_massikj (II,JJ,W1,W2,W3,W4, & bigj: do j=max(njds,njts),min(njde-1,njte) interploop: do i=max(nids,nits),min(nide-1,nite) if(imask(i,j)/=0) cycle interploop - kinterploop: do k=nkds,nkde - a=1-mod(JJ(i,j),2) - + a=1-mod(JJ(i,j),2) + kcopyloop: do k=nkde,kpres+1,-1 + nfield(i,k,j)=IKJCOPY(cfield,i,k,j) + end do kcopyloop + kinterploop: do k=kpres,nkds,-1 weight=winfo(i,j,k) ck=iinfo(i,j,k) @@ -1288,6 +1454,26 @@ subroutine c2n_massikj (II,JJ,W1,W2,W3,W4, & end subroutine c2n_massikj + subroutine find_kpres(kpres, eta2, kds,kde, kms,kme) + ! Find the level at which the pressure/sigma transition occurs. + ! All levels above this are pure pressure levels, whereas kpres + ! and below are sigma. + integer, intent(out) :: kpres + real, intent(in) :: eta2(kms:kme) + integer, intent(in) :: kds,kde, kms,kme + + integer :: k + + k=kde-1 + do while(eta2(k) < 1e-5 .and. eta2(k-1) < 1e-5) + k=k-1 + if(k<=kds) then + call wrf_error_fatal('New NMM interpolation routines do not work in a constant pressure space.') + endif + enddo + kpres=k + end subroutine find_kpres + ! ******************************************************************** ! subs *_FULLDOM -- recalculates PD and PINT based on FIS if ! requested. Also, generates vertical interpolation arrays for use @@ -1303,10 +1489,10 @@ subroutine n2c_fulldom ( & nfis,npint,nt,npd,nq, & ipos,jpos, & ! nri,nrj & - out_iinfo,out_winfo, & + out_iinfo,out_winfo, & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & - nits, nite, njts, njte, nkts, nkte) + nits, nite, njts, njte, nkts, nkte, kpres) implicit none @@ -1317,7 +1503,7 @@ subroutine n2c_fulldom ( & integer, intent(in):: & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & - nits, nite, njts, njte, nkts, nkte + nits, nite, njts, njte, nkts, nkte, kpres integer, intent(in):: & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & @@ -1386,7 +1572,7 @@ subroutine n2c_fulldom ( & ! Step 2: Interpolate coarse grid to fine grid in reordered ! arrays: call interp_T_PD_Q(nmm_method_linear, nmm_keep_pd, nx,nz, & - deta1,deta2,eta1,eta2,ptop,pdtop, & + deta1,deta2,eta1,eta2,ptop,pdtop, kpres, & inFIS,icFIS, inPINT,icPINT, inT0, icT, inPD,icPD, inQ,icQ, & iinfo, winfo) @@ -1418,6 +1604,148 @@ subroutine n2c_fulldom ( & end do bigj end subroutine n2c_fulldom + subroutine n2c_fulldom_new ( & + deta1,deta2, eta1,eta2, ptop,pdtop, & + cfis,cpint,ct,cpd,cq, & + cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cits, cite, cjts, cjte, ckts, ckte, & + nfis,npint,nt,npd,nq, & + ipos,jpos, & +! nri,nrj & + out_iinfo,out_winfo, & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nits, nite, njts, njte, nkts, nkte, kpres) + + implicit none + + integer, intent(in) :: ipos,jpos +! integer, intent(in) :: nri,nrj + integer, parameter :: nri=3, nrj=3 ! parent:nest ratio, must be 3 in NMM + + integer, intent(in):: & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nits, nite, njts, njte, nkts, nkte, kpres + integer, intent(in):: & + cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cits, cite, cjts, cjte, ckts, ckte + real, intent(out), dimension(cims:cime,cjms:cjme,ckms:ckme) :: cT,cQ,cPINT + real, intent(inout), dimension(cims:cime,cjms:cjme,1) :: cPD,cFIS + + real, intent(out), dimension(cims:cime,cjms:cjme,ckms:ckme) :: out_winfo + integer, intent(out), dimension(cims:cime,cjms:cjme,ckms:ckme) :: out_iinfo + + real, intent(in), dimension(nims:nime,njms:njme,nkms:nkme) :: nT,nQ + real, intent(in), dimension(nims:nime,njms:njme,nkms:nkme) :: nPINT + real, intent(in), dimension(nims:nime,njms:njme,1) :: nFIS + real, intent(in), dimension(nims:nime,njms:njme,1) :: nPD + + real, intent(in), dimension(nkms:nkme) :: eta1,eta2,deta1,deta2 + real, intent(in) :: ptop,pdtop + + real, dimension(1,nite-nits+1) :: inFIS,inPD,icFIS,icPD + real, dimension(kpres+1,nite-nits+1) :: inT0,inQ,icT,icQ, qinfo,winfo + real, dimension(kpres+2,nite-nits+1) :: inPINT,icPINT + integer, dimension(kpres+1,nite-nits+1) :: iinfo + integer :: nx,nz,k,i,a,j, istart,iend,jstart,jend, ni,nj,jprint,itest,jtest + character*255 :: message + logical bad + + nx=min(cide-2,cite)-max(cids+1,cits)+1 + nz=ckde-ckds+1 + + jstart=MAX(jpos+1,cjts) + jend=MIN(jpos+(njde-njds)/nrj-1,cjte) + + bigj: do j=jstart,jend + nj = (j-jpos)*nrj + 1 + + a=mod(j,2) + istart=MAX(ipos+a,cits) + iend=MIN(ipos+(nide-nids)/nri-1,cite) + nx=iend-istart+1 + + ! STEP 1: Copy coarse and fine nest data into + ! temporary arrays, reordering dimensions: + qtloop: do k=ckts,kpres+1 + do i=istart,iend + ni = (i-ipos)*nri + 2 - a + + UPCOPY(inT0,nT,i,j,k,ni,nj) + UPCOPY(inQ,nQ,i,j,k,ni,nj) + UPCOPY(inPINT,nPINT,i,j,k,ni,nj) + enddo + enddo qtloop + + k=kpres+1 + loop2d: do i=istart,iend + ni = (i-ipos)*nri + 2 - a + + UPCOPY(inPINT,nPINT,i,j,k,ni,nj) + UPCOPY(inPD,nPD,i,j,1,ni,nj) + UPCOPY(inFIS,nFIS,i,j,1,ni,nj) + + icPD(1,i-istart+1)=cPD(i,j,1) +! icPD(1,i-istart+1)=use_this_pd(i,j,1) + icFIS(1,i-istart+1)=cFIS(i,j,1) + enddo loop2d + + ! Step 2: Interpolate coarse grid to fine grid in reordered + ! arrays: + call interp_T_PD_Q_kpres(nmm_method_linear, nmm_keep_pd, nx,nz, & + deta1,deta2,eta1,eta2,ptop,pdtop, kpres, kpres+2, & + inFIS,icFIS, inPINT,icPINT, inT0, icT, inPD,icPD, inQ,icQ, & + iinfo, winfo) + + ! Step 3: Copy back from reordered arrays to final nest arrays: + + qtloop2: do k=ckts,kpres+1 + do i=istart,iend + cT(i,j,k)=icT(k,i-istart+1) + cQ(i,j,k)=icQ(k,i-istart+1) + enddo + enddo qtloop2 + + izloop: do k=ckts,kpres+1 + ixloop: do i=istart,iend + out_iinfo(i,j,k)=iinfo(k,i-istart+1) + out_winfo(i,j,k)=winfo(k,i-istart+1) + enddo ixloop + enddo izloop + + k=nkte+1 + loop2d2: do i=istart,iend + cPD(i,j,1)=icPD(1,i-istart+1) + enddo loop2d2 + end do bigj + + kcopy: do k=kpres+1,ckde-1 + jcopy: do j=jstart,jend + nj = (j-jpos)*nrj + 1 + + a=mod(j,2) + istart=MAX(ipos+a,cits) + iend=MIN(ipos+(nide-nids)/nri-1,cite) + icopy: do i=istart,iend + ni = (i-ipos)*nri + 2 - a + cT(i,j,k)=NGRAB(nT,ni,nj,k) + cQ(i,j,k)=NGRAB(nQ,ni,nj,k) + out_iinfo(i,j,k)=k + out_winfo(i,j,k)=1.0 + enddo icopy + if(k==ckde-1) then + icopy2: do i=istart,iend + out_iinfo(i,j,nkde)=nkde + out_winfo(i,j,nkde)=1.0 + enddo icopy2 + endif + end do jcopy + end do kcopy + end subroutine n2c_fulldom_new + subroutine c2b_fulldom (II,JJ,W1,W2,W3,W4,& deta1,deta2, eta1,eta2, ptop,pdtop, & cfis,cpint,ct,cpd,cq, nfis, & @@ -1425,6 +1753,7 @@ subroutine c2b_fulldom (II,JJ,W1,W2,W3,W4,& nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nits, nite, njts, njte, nkts, nkte, & + kpres, & ibxs, ibxe, ibys, ibye, & wbxs, wbxe, wbys, wbye, & pdbxs, pdbxe, pdbys, pdbye, & @@ -1444,6 +1773,7 @@ subroutine c2b_fulldom (II,JJ,W1,W2,W3,W4,& integer, intent(in), dimension(nims:nime,njms:njme) :: II,JJ real, intent(in), dimension(nkms:nkme) :: eta1,eta2,deta1,deta2 real, intent(in) :: ptop,pdtop + integer, intent(in) :: kpres ! Parent fields: real, intent(in), dimension(cims:cime,cjms:cjme,ckms:ckme) :: cT,cQ,cPINT @@ -1492,9 +1822,9 @@ subroutine c2b_fulldom (II,JJ,W1,W2,W3,W4,& i=nide-1 endif do j=j1,j2,2 + a=1-mod(JJ(i,j),2) used=used+1 do k=nkts,nkte-1 - a=1-mod(JJ(i,j),2) uFCOPY(icT,cT,i,j,k) uFCOPY(icQ,cQ,i,j,k) uFCOPY(icPINT,cPINT,i,j,k) @@ -1546,8 +1876,8 @@ subroutine c2b_fulldom (II,JJ,W1,W2,W3,W4,& return endif - call interp_T_PD_Q(nmm_method_linear, nmm_interp_pd, used,nz, & - deta1,deta2,eta1,eta2,ptop,pdtop, & + call interp_T_PD_Q_kpres(nmm_method_linear, nmm_interp_pd, used,nz, & + deta1,deta2,eta1,eta2,ptop,pdtop, kpres, nz, & icFIS,inFIS, icPINT,inPINT, icT, inT, icPD,inPD, icQ,inQ, & iinfo, winfo) @@ -1624,28 +1954,276 @@ subroutine c2b_fulldom (II,JJ,W1,W2,W3,W4,& end subroutine c2b_fulldom - subroutine c2n_fulldom (II,JJ,W1,W2,W3,W4,& + ! #################################################################### + + subroutine c2b_fulldom_new (II,JJ,W1,W2,W3,W4,& deta1,deta2, eta1,eta2, ptop,pdtop, & - cfis,cpint,ct,cpd,cq, & + cfis,cpint,ct,cpd,cq, nfis, & cims, cime, cjms, cjme, ckms, ckme, & - nfis,npint,nt,npd,nq, & - out_iinfo,out_winfo,imask,& nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & - nits, nite, njts, njte, nkts, nkte) + nits, nite, njts, njte, nkts, nkte, & + kpres, & + ibxs, ibxe, ibys, ibye, & + wbxs, wbxe, wbys, wbye, & + pdbxs, pdbxe, pdbys, pdbye, & + tbxs, tbxe, tbys, tbye, & + qbxs, qbxe, qbys, qbye) implicit none - integer, intent(in):: cims, cime, cjms, cjme, ckms, ckme, & + integer, intent(in):: & + cims, cime, cjms, cjme, ckms, ckme, & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nits, nite, njts, njte, nkts, nkte - real, intent(in), dimension(cims:cime,cjms:cjme,ckms:ckme) :: cT,cQ,cPINT - real, intent(in), dimension(cims:cime,cjms:cjme,1) :: cPD,cFIS - real, intent(out), dimension(nims:nime,njms:njme,nkms:nkme) :: out_winfo - integer, intent(out), dimension(nims:nime,njms:njme,nkms:nkme) :: out_iinfo + integer, parameter :: bdyw=1 - real, intent(out), dimension(nims:nime,njms:njme,nkms:nkme) :: nT,nQ - real, intent(in), dimension(nims:nime,njms:njme,nkms:nkme) :: nPINT + ! Domain info: + real, intent(in), dimension(nims:nime,njms:njme) :: W1,W2,W3,W4 + integer, intent(in), dimension(nims:nime,njms:njme) :: II,JJ + real, intent(in), dimension(nkms:nkme) :: eta1,eta2,deta1,deta2 + real, intent(in) :: ptop,pdtop + integer, intent(in) :: kpres + + ! Parent fields: + real, intent(in), dimension(cims:cime,cjms:cjme,ckms:ckme) :: cT,cQ,cPINT + real, intent(in), dimension(cims:cime,cjms:cjme,1) :: cPD,cFIS + + ! Nest terrain info: + real, intent(in), dimension(nims:nime,njms:njme,1) :: nFIS + + ! T, Q, PINT, PD boundary info: + real,dimension(nims:nime,nkms:nkme,bdyw) :: tbys,tbye,qbys,qbye + real,dimension(njms:njme,nkms:nkme,bdyw) :: tbxs,tbxe,qbxs,qbxe + real,dimension(nims:nime,1,bdyw) :: pdbys,pdbye + real,dimension(njms:njme,1,bdyw) :: pdbxs,pdbxe + + ! Weights and indices: + real,dimension(nims:nime,nkms:nkme,bdyw) :: wbys,wbye + real,dimension(njms:njme,nkms:nkme,bdyw) :: wbxs,wbxe + integer,dimension(nims:nime,nkms:nkme,bdyw) :: ibys,ibye + integer,dimension(njms:njme,nkms:nkme,bdyw) :: ibxs,ibxe + + integer :: i,j,k,a,b,nx,nz,used,j1,j2,used1 + + real, dimension(1,2*(nite-nits+5)+2*(njte-njts+5)) :: inFIS,inPD,icFIS,icPD + real, dimension(kpres+1,2*(nite-nits+5)+2*(njte-njts+5)) :: inT,inQ,icT,icQ,winfo + integer, dimension(kpres+1,2*(nite-nits+5)+2*(njte-njts+5)) :: iinfo + real, dimension(kpres+2,2*(nite-nits+5)+2*(njte-njts+5)) :: inPINT,icPINT + + nx=min(nide-1,nite)-max(nids,nits)+1 + nz=nkde-nkds+1 + + j1=max(njts-1,njds) + if(mod(j1,2)/=1) j1=j1+1 + + j2=min(njte+1,njde-1) + if(mod(j2,2)/=1) j2=j2-1 + + used=0 + bdyloop: do b=1,4 + if_xbdy: if(b==1 .or. b==2) then + if(b==1) then + if(nits/=1) cycle bdyloop + i=1 + endif + if(b==2) then + if(nite=nide-1) then + i=nide-1 + do j=j1,j2,2 + used=used+1 + do k=nkts,kpres + tbxe(j,k,1)=inT(k,used) + qbxe(j,k,1)=inQ(k,used) + ibxe(j,k,1)=iinfo(k,used) + wbxe(j,k,1)=winfo(k,used) + enddo + ibxe(j,nkde,1)=nkde + wbxe(j,nkde,1)=1.0 + pdbxe(j,1,1)=inPD(1,used) + enddo + do k=kpres+1,nkde-1 + do j=j1,j2,2 + a=1-mod(JJ(i,j),2) + tbxe(j,k,1)=ICOPY(cT,i,j,k) + qbxe(j,k,1)=ICOPY(cQ,i,j,k) + ibxe(j,k,1)=k + wbxe(j,k,1)=1.0 + enddo + enddo + endif if_bxe + + if_bys: if(njts==1) then + j=1 + do i=max(nits-1,nids),min(nite+1,nide-1) + used=used+1 + do k=nkts,kpres + tbys(i,k,1)=inT(k,used) + qbys(i,k,1)=inQ(k,used) + ibys(i,k,1)=iinfo(k,used) + wbys(i,k,1)=winfo(k,used) + enddo + ibys(i,nkde,1)=nkde + wbys(i,nkde,1)=1.0 + pdbys(i,1,1)=inPD(1,used) + enddo + do k=kpres+1,nkde-1 + do i=max(nits-1,nids),min(nite+1,nide-1) + a=1-mod(JJ(i,j),2) + tbys(i,k,1)=ICOPY(cT,i,j,k) + qbys(i,k,1)=ICOPY(cQ,i,j,k) + ibys(i,k,1)=k + wbys(i,k,1)=1.0 + enddo + enddo + endif if_bys + + if_bye: if(njte>=njde-1) then + j=njde-1 + do i=max(nits-1,nids),min(nite+1,nide-1) + used=used+1 + do k=nkts,kpres + tbye(i,k,1)=inT(k,used) + qbye(i,k,1)=inQ(k,used) + ibye(i,k,1)=iinfo(k,used) + wbye(i,k,1)=winfo(k,used) + enddo + ibye(i,nkde,1)=nkde + wbye(i,nkde,1)=1.0 + pdbye(i,1,1)=inPD(1,used) + enddo + do k=kpres+1,nkde-1 + do i=max(nits-1,nids),min(nite+1,nide-1) + a=1-mod(JJ(i,j),2) + tbye(i,k,1)=ICOPY(cT,i,j,k) + qbye(i,k,1)=ICOPY(cQ,i,j,k) + ibye(i,k,1)=k + wbye(i,k,1)=1.0 + enddo + enddo + endif if_bye + + if(used/=used1) then + call wrf_error_fatal('Number of input and output points does not match.') + endif + + end subroutine c2b_fulldom_new + + ! #################################################################### + + subroutine c2n_fulldom (II,JJ,W1,W2,W3,W4,& + deta1,deta2, eta1,eta2, ptop,pdtop, & + cfis,cpint,ct,cpd,cq, & + cims, cime, cjms, cjme, ckms, ckme, & + nfis,npint,nt,npd,nq, & + out_iinfo,out_winfo,imask,& + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nits, nite, njts, njte, nkts, nkte, kpres) + implicit none + integer, intent(in):: cims, cime, cjms, cjme, ckms, ckme, & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nits, nite, njts, njte, nkts, nkte, kpres + real, intent(in), dimension(cims:cime,cjms:cjme,ckms:ckme) :: cT,cQ,cPINT + real, intent(in), dimension(cims:cime,cjms:cjme,1) :: cPD,cFIS + + real, intent(out), dimension(nims:nime,njms:njme,nkms:nkme) :: out_winfo + integer, intent(out), dimension(nims:nime,njms:njme,nkms:nkme) :: out_iinfo + + real, intent(out), dimension(nims:nime,njms:njme,nkms:nkme) :: nT,nQ + real, intent(in), dimension(nims:nime,njms:njme,nkms:nkme) :: nPINT real, intent(in), dimension(nims:nime,njms:njme,1) :: nFIS real, intent(inout), dimension(nims:nime,njms:njme,1) :: nPD integer, intent(in), dimension(nims:nime,njms:njme) :: imask @@ -1710,7 +2288,7 @@ subroutine c2n_fulldom (II,JJ,W1,W2,W3,W4,& cycle bigj else call interp_T_PD_Q(nmm_method_linear, nmm_interp_pd, used,nz, & - deta1,deta2,eta1,eta2,ptop,pdtop, & + deta1,deta2,eta1,eta2,ptop,pdtop,kpres, & icFIS,inFIS, icPINT,inPINT, icT, inT, icPD,inPD, icQ,inQ, & iinfo, winfo) endif @@ -1771,12 +2349,12 @@ end subroutine c2n_fulldom ! ******************************************************************** subroutine interp_T_PD_Q(method, pd_interp, nx, nz, & - deta1,deta2, eta1,eta2, ptop,pdtop, & + deta1,deta2, eta1,eta2, ptop,pdtop, kpres, & fisA,fisB, pintA,pintB, tA,tB, pdA,pdB, qA,qB, & iinfo, winfo) implicit none - integer, intent(in) :: pd_interp,method + integer, intent(in) :: pd_interp,method, kpres ! real, intent(in) :: dtA,dtB ! Coordinate system definitions must be the same for all domains: @@ -1948,7 +2526,7 @@ subroutine interp_T_PD_Q(method, pd_interp, nx, nz, & outer: do ix=1,nx ! For constant pressure levels, do a straight level-by-level copy: iz=nz-1 - copyloop: do while(eta2(iz) < 1e-5 .and. eta2(iz-1) < 1e-5) + copyloop: do while(iz>kpres) tB(iz,ix)=tA(iz,ix) qB(iz,ix)=qA(iz,ix) @@ -2077,6 +2655,314 @@ subroutine interp_T_PD_Q(method, pd_interp, nx, nz, & enddo extraploop enddo outer end subroutine interp_T_PD_Q + + subroutine interp_T_PD_Q_kpres(method, pd_interp, nx, nz, & + deta1,deta2, eta1,eta2, ptop,pdtop, kpres, nz2, & + fisA,fisB, pintA,pintB, tA,tB, pdA,pdB, qA,qB, & + iinfo, winfo) + implicit none + + integer, intent(in) :: pd_interp,method, kpres, nz2 + ! real, intent(in) :: dtA,dtB + + ! Coordinate system definitions must be the same for all domains: + real, intent(in) :: deta1(nz),deta2(nz),eta1(nz),eta2(nz),ptop,pdtop + integer, intent(in) :: nx,nz + + ! Surface height and mass field information for source (A): + real, intent(in) :: fisA(nx),tA(nz2-1,nx),pdA(nx),qA(nz2-1,nx),pintA(nz2,nx) + + ! Surface height and mass field information for target (B): + real, intent(inout) :: fisB(nx),tB(nz2-1,nx),pdB(nx),qB(nz2-1,nx),pintB(nz2,nx) + + ! Interpolation or extrapolation information for use in other + ! calls later on: + real, intent(out) :: winfo(nz2-1,nx) + integer, intent(out) :: iinfo(nz2-1,nx) + + ! ==================== Local variables ==================== + + character*255 :: message + integer :: ix,iz,izA,izB,xpr + real :: zA,zB,znext,apelp,rtopp,dz,weight,A,B,pstd1,z,pstd2,pstd12 + real :: tsfc(nx), slp(nx), zmslp(nx), z0mid(nx), zbelow(nx), & + tbelow(nx), RHbelow(nx) + real :: pb,pb1,pb2,pa,pa1,pa2,pnext,pa3, wnum,wdenom, QC, P0 + + ! Constants from UPP params.f for RH calculation (all mks): + real, parameter :: PQ0=379.90516 + real, parameter :: A2=17.2693882 + real, parameter :: A3=273.16 + real, parameter :: A4=35.86 + real, parameter :: RHmin=1.0E-6 ! minimal RH bound + + if(method/=nmm_method_linear) then + call wrf_error_fatal('only linear interpolation is supported') + endif + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Step 1: calculate near-surface values !!!!!!!!!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + pstd1=p_ref ! pstd(1) from base_state_parent + ! pstd(2) from base_state_parent: + pstd2=eta1(2)*pdtop + eta2(2)*(p_ref-pdtop-ptop) + ptop + pstd12=exp((alog(pstd1)+alog(pstd2))*0.5) + + do ix=1,nx + ! These calculations are from base_state_parent: + APELP = (pintA(2,ix)+pintA(1,ix)) + RTOPP = TRG*tA(1,ix)*(1.0+qA(1,ix)*P608)/APELP + DZ = RTOPP*(DETA1(1)*PDTOP+DETA2(1)*pdA(ix)) + + Z0MID(ix) = fisA(ix)/g + dz/2 + + zA=fisA(ix)/g + + TSFC(ix) = TA(1,ix)*(1.+D608*QA(1,ix)) & + + LAPSR*(zA + zA+dz)*0.5 + + A = LAPSR*zA/TSFC(ix) + SLP(ix) = PINTA(1,ix)*(1-A)**COEF2 ! sea level pressure + B = (pstd1/SLP(ix))**COEF3 + ZMSLP(ix)= TSFC(ix)*LAPSI*(1.0 - B) ! Height at 1030. mb level + + TBELOW(ix) = TA(1,ix) + LAPSR*(Z0MID(ix)-ZMSLP(ix)) + + ! Calculate lowest level RH. This calculation is from UPP + ! CALRH.f: + P0=pdA(ix)+ptop+pdtop ! Use hydrostatic lowest model level P + QC=PQ0/P0*EXP(A2*(TA(1,ix)-A3)/(TA(1,ix)-A4)) + RHbelow(ix)=max(RHmin,min(1.0,QA(1,ix)/QC)) + enddo + + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Step 2: figure out the new surface pressures !!!!!!!!!!!!!! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + if_pd_interp: if(pd_interp==nmm_keep_pd) then + ! PD interpolation is turned off, so we use the original PD. + elseif(pd_interp==nmm_interp_pd) then + ! PD interpolation is requested. As with the old base_state_parent, + ! determine PD by interpolating or extrapolating the non-hydrostatic + ! pressure field (PINT) in source grid to the surface height of the + ! target grid. + xloop: do ix=1,nx + if(pintA(1,ix)>p_ref) then + ! Cannot extrapolate PD below ground because pressure is + ! unrealistically high. Follow base_state_parent method: + ! when this happens, assign input pressure to output + ! pressure. + WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD' + WRITE(0,*)'PINT(1),PD(1),PSTD(1)',pintA(1,ix),pdA(ix),p_ref + pdB(ix)=pdA(ix) + cycle xloop + endif + + zA=fisA(ix)/g + zB=fisB(ix)/g + + if(zBkpres) + tB(iz,ix)=tA(iz,ix) + qB(iz,ix)=qA(iz,ix) + + ! Save interpolation information + iinfo(iz,ix)=iz + winfo(iz,ix)=1.0 + + iz=iz-1 + enddo copyloop + + ! For sigma levels where target domain lies within source, + ! interpolate from top down, stopping when we go below ground + ! in the source domain. + izA=iz + izB=iz + + ! FIXME: REMOVE THIS CHECK + if(iz>nz2) then + ! Make sure the entire vertical extent isn't sigma levels: + call wrf_error_fatal('ERROR: WRF-NMM does not support pure sigma levels (only sigma-pressure hybrid)') + endif + + pB2=log(eta1(izB)*pdtop + eta2(izB)*pdB(ix) + ptop) + pB1=log(eta1(izB+1)*pdtop + eta2(izB+1)*pdB(ix) + ptop) + pB=(pB2+pB1)*0.5 + + pA2=log(eta1(izA)*pdtop + eta2(izA)*pdA(ix) + ptop) + pA1=log(eta1(izA+1)*pdtop + eta2(izA+1)*pdA(ix) + ptop) + pA=(pA2+pA1)*0.5 + + ! Find the lowest mass level izA that is above pB + interpinit: do while(izA>1) + pA3=log(eta1(izA-1)*pdtop + eta2(izA-1)*pdA(ix) + ptop) + pnext=(pA2+pA3)*0.5 + wdenom=pnext-pA + wnum=pnext-pb + if(pA<=pB .and. wnum>1e-5) then + exit interpinit + else + pA1=pA2 + pA2=pa3 + izA=izA-1 + pA=pnext + endif + enddo interpinit + + ! Loop over all remaining B points, interpolating to them. + interploop: do while(izB>0 .and. izA>1) + ! Find the source domain levels that this target domain level lies between: + zinterp: do while(izA>1) + if(pnext>=pB) then + ! We found the two levels, so interpolate and move on to + ! the next target level: + weight=max(0.,wnum/wdenom) + tB(izB,ix)=weight*tA(izA,ix) + (1.0-weight)*tA(izA-1,ix) + qB(izB,ix)=weight*qA(izA,ix) + (1.0-weight)*qA(izA-1,ix) + + ! Save interpolation info + iinfo(izB,ix)=izA ! upper level + winfo(izB,ix)=weight ! linear interpolation weight + + ! We interpolated to a B point, so go to the next one: + pB1=pB2 + izB=izB-1 + if(izB>0) then + pB2=log(eta1(izB)*pdtop + eta2(izB)*pdB(ix) + ptop) + pB=(pb1+pb2)*0.5 + else + exit interploop + endif + wnum=pnext-pb + + exit zinterp + else + izA=izA-1 + pA1=pA2 + pA2=pa3 + pA=pnext + if(izA>1) then + pA3=log(eta1(izA-1)*pdtop + eta2(izA-1)*pdA(ix) + ptop) + pnext=(pA2+pA3)*0.5 + wdenom=pnext-pa + wnum=pnext-pb + else + exit interploop + endif + endif + enddo zinterp + enddo interploop + + ! Follow what base_state_parent did for temperature: + ! interpolate between the second to last level and P_REF using + ! a lapse rate atmosphere. For Q, we use constant RH below + ! ground, as suggested by Greg Thompson. + extraploop: do while(izB>=1) + ! Decide extrapolation weight: + weight=(pB-pA)/(pstd12-pA) + + ! Extrapolate Q by copying lowest sigma layer value: + !qB(izB,ix)=qA(1,ix) + + ! Extrapolate Q by linearly interpolating between 0 and surface value: + !qB(izB,ix)=(1.0-weight)*qA(1,ix) + + ! Extrapolate T using a lapse rate atmosphere + tB(izB,ix)=weight*tbelow(ix) + (1.0-weight)*tA(1,ix) + + ! Extrapolate Q using constant RH below ground, as suggested + ! by Greg Thompson. This is the inversion of the RH + ! calculation used earlier in this function: + P0=eta1(izB)*pdtop + eta2(izB)*pdB(ix) + ptop + QC=PQ0/P0*EXP(A2*(TB(izB,ix)-A3)/(TB(izB,ix)-A4)) + QB(izB,ix)=QC*RHbelow(ix) + + ! Save extrapolation information + iinfo(izB,ix)=0 + winfo(izB,ix)=weight + + ! Move to the next B level + izB=izB-1 + if(izB>0) then + pB1=pB2 + pB2=log(eta1(izB)*pdtop + eta2(izB)*pdB(ix) + ptop) + pB=(pb1+pb2)*0.5 + endif + enddo extraploop + enddo outer + end subroutine interp_T_PD_Q_kpres end module module_interp_nmm ! ******************************************************************** @@ -2097,8 +2983,8 @@ subroutine ext_c2n_fulldom (II,JJ,W1,W2,W3,W4,& nits, nite, njts, njte, nkts, nkte) ! This subroutine is an alias for c2n_fulldom. It exists to allow ! the routine to be called from module_dm - use module_interp_store, only: parent_fis, nest_fis - use module_interp_nmm, only: c2n_fulldom + use module_interp_store, only: parent_fis, nest_fis, kpres + use module_interp_nmm, only: c2n_fulldom, find_kpres implicit none integer, intent(in):: cims, cime, cjms, cjme, ckms, ckme, & nids, nide, njds, njde, nkds, nkde, & @@ -2121,8 +3007,10 @@ subroutine ext_c2n_fulldom (II,JJ,W1,W2,W3,W4,& real, intent(in), dimension(nkms:nkme) :: eta1,eta2,deta1,deta2 real, intent(in) :: ptop,pdtop -integer :: i,j,k -logical :: badbad + integer :: i,j,k + logical :: badbad + + call find_kpres(kpres,eta2,nkds,nkde,nkms,nkme) call c2n_fulldom(II,JJ,W1,W2,W3,W4,& deta1,deta2, eta1,eta2, ptop,pdtop, & parent_fis,cpint,ct,cpd,cq, & @@ -2131,7 +3019,8 @@ subroutine ext_c2n_fulldom (II,JJ,W1,W2,W3,W4,& out_iinfo,out_winfo,imask, & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & - nits, nite, njts, njte, nkts, nkte) + nits, nite, njts, njte, nkts, nkte, & + kpres) end subroutine ext_c2n_fulldom @@ -2149,8 +3038,8 @@ subroutine ext_n2c_fulldom ( & nits, nite, njts, njte, nkts, nkte) ! This subroutine is an alias for n2c_fulldom. It exists to allow ! the routine to be called from module_dm - use module_interp_store, only: parent_fis, nest_fis - use module_interp_nmm, only: n2c_fulldom + use module_interp_store, only: parent_fis, nest_fis, kpres + use module_interp_nmm, only: n2c_fulldom, find_kpres, n2c_fulldom_new implicit none integer, intent(in):: cims, cime, cjms, cjme, ckms, ckme, & cids, cide, cjds, cjde, ckds, ckde, & @@ -2171,7 +3060,9 @@ subroutine ext_n2c_fulldom ( & real, intent(in), dimension(nkms:nkme) :: eta1,eta2,deta1,deta2 real, intent(in) :: ptop,pdtop - call n2c_fulldom( & + + call find_kpres(kpres,eta2,nkds,nkde,nkms,nkme) + call n2c_fulldom_new( & deta1,deta2, eta1,eta2, ptop,pdtop, & parent_fis,cpint,ct,cpd,cq, & cids, cide, cjds, cjde, ckds, ckde, & @@ -2182,7 +3073,7 @@ subroutine ext_n2c_fulldom ( & out_iinfo,out_winfo, & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & - nits, nite, njts, njte, nkts, nkte) + nits, nite, njts, njte, nkts, nkte, kpres) end subroutine ext_n2c_fulldom subroutine ext_c2b_fulldom (II,JJ,W1,W2,W3,W4,& @@ -2197,8 +3088,8 @@ subroutine ext_c2b_fulldom (II,JJ,W1,W2,W3,W4,& pdbxs, pdbxe, pdbys, pdbye, & tbxs, tbxe, tbys, tbye, & qbxs, qbxe, qbys, qbye) - use module_interp_nmm, only: c2b_fulldom - use module_interp_store, only: parent_fis, nest_fis + use module_interp_nmm, only: c2b_fulldom, find_kpres, c2b_fulldom_new + use module_interp_store, only: parent_fis, nest_fis, kpres implicit none integer, intent(in):: & cims, cime, cjms, cjme, ckms, ckme, & @@ -2227,14 +3118,16 @@ subroutine ext_c2b_fulldom (II,JJ,W1,W2,W3,W4,& real,dimension(njms:njme,nkms:nkme,bdyw) :: wbxs,wbxe integer,dimension(nims:nime,nkms:nkme,bdyw) :: ibys,ibye integer,dimension(njms:njme,nkms:nkme,bdyw) :: ibxs,ibxe - - call c2b_fulldom (II,JJ,W1,W2,W3,W4,& + + call find_kpres(kpres,eta2,nkds,nkde,nkms,nkme) + call c2b_fulldom_new (II,JJ,W1,W2,W3,W4,& deta1,deta2, eta1,eta2, ptop,pdtop, & parent_fis,cpint,ct,cpd,cq,nest_fis, & cims, cime, cjms, cjme, ckms, ckme, & nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nits, nite, njts, njte, nkts, nkte, & + kpres, & ibxs, ibxe, ibys, ibye, & wbxs, wbxe, wbys, wbye, & pdbxs, pdbxe, pdbys, pdbye, & diff --git a/wrfv2_fire/share/module_interp_store.F b/wrfv2_fire/share/module_interp_store.F index ad124a14..d246c7c3 100644 --- a/wrfv2_fire/share/module_interp_store.F +++ b/wrfv2_fire/share/module_interp_store.F @@ -11,6 +11,8 @@ module module_interp_store ! AUTHOR: Samuel Trahan ! HISTORY: ! August, 2012 - initial creation + ! December, 2013 - added kpres, which stores the pressure-sigma + ! transition level implicit none integer, pointer, dimension(:,:) :: IIH,JJH,IIV,JJV @@ -25,7 +27,7 @@ module module_interp_store winfo_bxs, winfo_bxe, & winfo_bys, winfo_bye integer, pointer, dimension(:,:) :: hnear_i, hnear_j - + integer :: kpres real, pointer, dimension(:,:) :: parent_fis, nest_fis end module module_interp_store @@ -37,18 +39,12 @@ subroutine store_interp_info(grid, parent_grid) type(domain), intent(in) :: grid, parent_grid #if (NMM_CORE == 1 && NMM_NEST == 1) - + kpres=-99999 grid_id=grid%id parent_grid_id=parent_grid%id -parent_fis=>parent_grid%fis -nest_fis=>grid%fis - ! if(parent_grid_id==1) then - ! parent_fis=>parent_grid%fis - ! else - ! parent_fis=>parent_grid%hres_fis - ! endif - ! nest_fis=>grid%hres_fis + parent_fis=>parent_grid%fis + nest_fis=>grid%fis hnear_i=>grid%hnear_i hnear_j=>grid%hnear_j diff --git a/wrfv2_fire/share/module_io_domain.F b/wrfv2_fire/share/module_io_domain.F index 7dd3f4f4..14b0391a 100644 --- a/wrfv2_fire/share/module_io_domain.F +++ b/wrfv2_fire/share/module_io_domain.F @@ -19,8 +19,7 @@ SUBROUTINE open_r_dataset ( id , fname , grid , config_flags , sysdepinfo, ierr CHARACTER*128 :: DataSet, tmp LOGICAL :: anyway CALL wrf_open_for_read ( fname , & - grid%communicator , & - grid%iocommunicator , & + grid , & sysdepinfo , & id , & ierr ) @@ -45,8 +44,7 @@ SUBROUTINE open_w_dataset ( id , fname , grid , config_flags , outsub , sysdepin write(sysdepinfo_tmp,'(a,i2)')TRIM(sysdepinfo)//',GRIDID=',grid%id ENDIF CALL wrf_open_for_write_begin ( fname , & - grid%communicator , & - grid%iocommunicator , & + grid , & sysdepinfo_tmp , & id , & ierr ) @@ -57,8 +55,7 @@ SUBROUTINE open_w_dataset ( id , fname , grid , config_flags , outsub , sysdepin ENDIF IF ( ierr .LE. 0 ) THEN CALL wrf_debug ( 100 , 'calling wrf_open_for_write_commit in open_w_dataset' ) - CALL wrf_open_for_write_commit ( id , & - ierr ) + CALL wrf_open_for_write_commit ( id , ierr ) CALL wrf_debug ( 100 , 'back from wrf_open_for_write_commit in open_w_dataset' ) ENDIF END SUBROUTINE open_w_dataset @@ -75,8 +72,7 @@ SUBROUTINE open_u_dataset ( id , fname , grid , config_flags , insub , sysdepinf LOGICAL :: anyway CALL wrf_debug ( 100 , 'calling wrf_open_for_read_begin in open_u_dataset' ) CALL wrf_open_for_read_begin ( fname , & - grid%communicator , & - grid%iocommunicator , & + grid , & sysdepinfo , & id , & ierr ) @@ -86,8 +82,7 @@ SUBROUTINE open_u_dataset ( id , fname , grid , config_flags , insub , sysdepinf ENDIF IF ( ierr .LE. 0 ) THEN CALL wrf_debug ( 100 , 'calling wrf_open_for_read_commit in open_u_dataset' ) - CALL wrf_open_for_read_commit ( id , & - ierr ) + CALL wrf_open_for_read_commit ( id , ierr ) CALL wrf_debug ( 100 , 'back from wrf_open_for_read_commit in open_u_dataset' ) ENDIF END SUBROUTINE open_u_dataset @@ -268,6 +263,8 @@ SUBROUTINE construct_filename4( result , basename , fld1 , len1 , date_char , io ext = '.nc ' ELSE IF ( use_package(io_form) .EQ. IO_PNETCDF ) THEN ext = '.nc ' + ELSE IF ( use_package(io_form) .EQ. IO_PIO ) THEN + ext = '.nc ' ELSE IF ( use_package(io_form) .EQ. IO_GRIB1 ) THEN ext = '.gb ' ELSE @@ -300,6 +297,8 @@ SUBROUTINE construct_filename4a( result , basename , fld1 , len1 , date_char , i ext = '.nc ' ELSE IF ( use_package(io_form) .EQ. IO_PNETCDF ) THEN ext = '.nc ' + ELSE IF ( use_package(io_form) .EQ. IO_PIO ) THEN + ext = '.nc ' ELSE IF ( use_package(io_form) .EQ. IO_GRIB1 ) THEN ext = '.gb ' ELSE @@ -403,6 +402,8 @@ SUBROUTINE maybe_remove_colons( FileName ) DO i = 3, l IF ( FileName(i:i) .EQ. ':' ) THEN FileName(i:i) = '_' + ELSE IF ( FileName(i:i) .EQ. '-' ) THEN + FileName(i:i) = '_' ENDIF ENDDO ENDIF diff --git a/wrfv2_fire/share/module_model_constants.F b/wrfv2_fire/share/module_model_constants.F index 113528a0..468a83c1 100644 --- a/wrfv2_fire/share/module_model_constants.F +++ b/wrfv2_fire/share/module_model_constants.F @@ -64,7 +64,8 @@ MODULE module_model_constants REAL , PARAMETER :: rhosnow = 100. REAL , PARAMETER :: rhoair0 = 1.28 ! - REAL , PARAMETER :: n_ccn0 = 1.0E8 +! Now namelist-specified parameter: ccn_conc - RAS +! REAL , PARAMETER :: n_ccn0 = 1.0E8 ! REAL , PARAMETER :: piconst = 3.1415926535897932384626433 REAL , PARAMETER :: DEGRAD = piconst/180. diff --git a/wrfv2_fire/share/module_optional_input.F b/wrfv2_fire/share/module_optional_input.F index 8f94b89c..cf8bd022 100644 --- a/wrfv2_fire/share/module_optional_input.F +++ b/wrfv2_fire/share/module_optional_input.F @@ -1,10 +1,13 @@ MODULE module_optional_input INTEGER :: flag_metgrid , flag_tavgsfc , flag_psfc , flag_soilhgt , flag_mf_xy , flag_slp , & - flag_snow , flag_snowh , flag_tsk , flag_pinterp + flag_snow , flag_snowh , flag_tsk , flag_pinterp , flag_prho INTEGER :: flag_qv , flag_qc , flag_qr , flag_qi , flag_qs , & - flag_qg , flag_qh , flag_qni , flag_qnr , flag_qnwfa , flag_qnifa , flag_sh + flag_qg , flag_qh , & + flag_qni , flag_qnr , & + flag_qnwfa , flag_qnifa , & + flag_sh , flag_speccldl , flag_speccldf INTEGER :: flag_soil_levels, flag_soil_layers @@ -29,6 +32,13 @@ MODULE module_optional_input INTEGER :: flag_excluded_middle + INTEGER :: flag_um_soil + INTEGER :: flag_icepct + + INTEGER :: flag_hgtmaxw , flag_pmaxw , flag_tmaxw , flag_umaxw , flag_vmaxw , & + flag_hgttrop , flag_ptrop , flag_ttrop , flag_utrop , flag_vtrop + INTEGER :: flag_extra_levels + INTEGER :: num_soil_levels_input INTEGER :: num_st_levels_input , num_sm_levels_input , num_sw_levels_input INTEGER :: num_st_levels_alloc , num_sm_levels_alloc , num_sw_levels_alloc @@ -212,6 +222,11 @@ SUBROUTINE optional_input ( grid , fid, config_flags ) ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) + CALL optional_levels ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + flag_soil_levels = 0 flag_soil_layers = 0 @@ -303,6 +318,8 @@ SUBROUTINE optional_moist ( grid , fid , & flag_qnwfa = 0 flag_qnifa = 0 flag_sh = 0 + flag_speccldl = 0 + flag_speccldf = 0 flag_name(1:8) = 'QV ' CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) @@ -364,6 +381,16 @@ SUBROUTINE optional_moist ( grid , fid , & IF ( ierr .EQ. 0 ) THEN flag_sh = itmp END IF + flag_name(1:8) = 'SPECCLDL' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_speccldl = itmp + END IF + flag_name(1:8) = 'SPECCLDF' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_speccldf = itmp + END IF END SUBROUTINE optional_moist @@ -457,6 +484,100 @@ END SUBROUTINE optional_sst !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE optional_levels ( grid , fid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + USE module_io_wrf + USE module_domain , ONLY : domain +USE module_configure , ONLY : grid_config_rec_type +USE module_io_domain + + IMPLICIT NONE + + TYPE ( domain ) :: grid + INTEGER , INTENT(IN) :: fid + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + INTEGER :: itmp , icnt , ierr + + flag_name = ' ' + + flag_hgtmaxw = 0 + flag_pmaxw = 0 + flag_tmaxw = 0 + flag_umaxw = 0 + flag_vmaxw = 0 + flag_hgttrop = 0 + flag_ptrop = 0 + flag_ttrop = 0 + flag_utrop = 0 + flag_vtrop = 0 + flag_extra_levels = 0 + + flag_name(1:8) = 'HGTMAXW ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_hgtmaxw = itmp + END IF + flag_name(1:8) = 'PMAXW ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_pmaxw = itmp + END IF + flag_name(1:8) = 'TMAXW ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_tmaxw = itmp + END IF + flag_name(1:8) = 'UMAXW ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_umaxw = itmp + END IF + flag_name(1:8) = 'VMAXW ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_vmaxw = itmp + END IF + flag_name(1:8) = 'HGTTROP ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_hgttrop = itmp + END IF + flag_name(1:8) = 'PTROP ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_ptrop = itmp + END IF + flag_name(1:8) = 'TTROP ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_ttrop = itmp + END IF + flag_name(1:8) = 'UTROP ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_utrop = itmp + END IF + flag_name(1:8) = 'VTROP ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_vtrop = itmp + END IF + + flag_extra_levels = flag_hgtmaxw*flag_pmaxw*flag_tmaxw*flag_umaxw*flag_vmaxw* & + flag_hgttrop*flag_ptrop*flag_ttrop*flag_utrop*flag_vtrop + + END SUBROUTINE optional_levels + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE optional_lake ( grid , fid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -657,6 +778,12 @@ SUBROUTINE optional_sfc ( grid , fid , & IF ( ierr .EQ. 0 ) THEN flag_slp = itmp END IF + + flag_name(1:8) = 'UM_SOIL ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_um_soil = itmp + END IF grid%flag_soilhgt = flag_soilhgt grid%flag_slp = flag_slp @@ -705,6 +832,12 @@ SUBROUTINE optional_ice ( grid , fid , & flag_icefrac = itmp END IF + flag_name(1:8) = 'ICEPCT ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_icepct = itmp + END IF + flag_name(1:8) = 'ICEDEPTH' CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) IF ( ierr .EQ. 0 ) THEN @@ -800,6 +933,16 @@ SUBROUTINE optional_ptheta ( grid , fid , & flag_ptheta = itmp END IF + flag_name = ' ' + + flag_prho = 0 + + flag_name(1:8) = 'PRHO ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_prho = itmp + END IF + END SUBROUTINE optional_ptheta !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -959,10 +1102,25 @@ SUBROUTINE optional_lsm_levels ( grid , fid , & ! Calculate mid-point of each layer and set to st_levels_input ! Flip the input soil depths upside down to make k=1 closest to the sfc !------------------------------------------------------------- - st_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 - sm_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 - sw_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 - level_above = grid%soil_layers(its,num_st_levels_input + 1 - k,jts) + !st_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 + !sm_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 + !sw_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 + !level_above = grid%soil_layers(its,num_st_levels_input + 1 - k,jts) + !------------------------------------------------------------- + ! If UM soil input, levels are cumulative (0-10cm, 0-25cm, + ! etc.) so we simply take the midpoint of each level - GAC + !------------------------------------------------------------- + IF ( flag_um_soil == 1 ) THEN + st_levels_input(k) = (grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 + sm_levels_input(k) = (grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 + sw_levels_input(k) = (grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 + ELSE + st_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 + sm_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 + sw_levels_input(k) = (level_above + grid%soil_layers(its,num_st_levels_input + 1 - k,jts))/2 + level_above = grid%soil_layers(its,num_st_levels_input + 1 - k,jts) + END IF + END DO !---------------------------------------------------------------- @@ -979,6 +1137,19 @@ SUBROUTINE optional_lsm_levels ( grid , fid , & END DO END DO + !---------------------------------------------------------------- + ! UM input is in kg/m2, convert to volumetric soil moisture here + !---------------------------------------------------------------- + IF ( flag_um_soil == 1 ) THEN + DO j = jts, MIN(jde-1,jte) + DO k = 1, num_sm_levels_input + DO i = its, MIN(ide-1,ite) + sm_input(i,k+1,j)=100.*sm_input(i,k+1,j)/(2*sm_levels_input(k)*1000.) + END DO + END DO + END DO + END IF + END IF ! flag_soil_layers == 1 #endif diff --git a/wrfv2_fire/share/module_soil_pre.F b/wrfv2_fire/share/module_soil_pre.F index f8487c56..fa1b55ff 100644 --- a/wrfv2_fire/share/module_soil_pre.F +++ b/wrfv2_fire/share/module_soil_pre.F @@ -430,7 +430,7 @@ SUBROUTINE process_percent_cat_new ( landmask , & INTEGER :: i , j , l , ll, dominant_index REAL :: dominant_value -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! REAL :: lwthresh = .99 REAL :: lwthresh = .50 #else @@ -3354,7 +3354,7 @@ SUBROUTINE process_percent_cat_new ( landmask , & INTEGER :: i , j , l , ll, dominant_index REAL :: dominant_value -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! REAL :: lwthresh = .99 REAL :: lwthresh = .50 #else diff --git a/wrfv2_fire/share/output_wrf.F b/wrfv2_fire/share/output_wrf.F index 8d3995c2..6514ea59 100644 --- a/wrfv2_fire/share/output_wrf.F +++ b/wrfv2_fire/share/output_wrf.F @@ -38,14 +38,19 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) REAL gmt, cen_lat, cen_lon, bdyfrq , truelat1 , truelat2 , moad_cen_lat , stand_lon INTEGER km_opt, diff_opt, damp_opt, & mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & - sf_surface_physics, bl_pbl_physics, cu_physics, hypsometric_opt, sf_lake_physics + sf_surface_physics, bl_pbl_physics, cu_physics, hypsometric_opt, sf_lake_physics, & + use_theta_m INTEGER swint_opt, aer_type,aer_aod550_opt,aer_angexp_opt,aer_ssa_opt,aer_asy_opt, aer_opt REAL aer_aod550_val,aer_angexp_val,aer_ssa_val,aer_asy_val REAL khdif, kvdif, swrad_scat, dampcoef,radt,bldt,cudt REAL dt, adapt_dt_start, adapt_dt_min, adapt_dt_max INTEGER sf_urban_physics, w_damping, smooth_option, feedback, surface_input_source, sst_update - INTEGER stoch_force_opt, stoch_vertstruc_opt, nens - REAL tot_backscat_psi, tot_backscat_t + INTEGER skebs_on, sppt_on, rand_perturb_on, nens,ISEED_SKEBS,ISEED_SPPT,ISEED_RAND_PERT + INTEGER skebs_vertstruc, sppt_vertstruc, rand_pert_vertstruc + INTEGER LMINFORC,LMAXFORC,KMINFORC,KMAXFORC,LMINFORCT,LMAXFORCT,KMINFORCT,KMAXFORCT + REAL gridpt_stddev_rand_pert,stddev_cutoff_rand_pert,timescale_rand_pert + REAL gridpt_stddev_sppt,stddev_cutoff_sppt,timescale_sppt + REAL tot_backscat_psi,tot_backscat_t,REXPONENT_PSI,REXPONENT_T,ZTAU_PSI,ZTAU_T #if (EM_CORE == 1) INTEGER grid_id , parent_id , i_parent_start , j_parent_start , parent_grid_ratio INTEGER diff_6th_opt @@ -58,7 +63,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) REAL guv_sfc, gt_sfc, gq_sfc, rinblw INTEGER moist_adv_opt, scalar_adv_opt, tke_adv_opt INTEGER save_topo_orig - INTEGER scalar_pblmix, tracer_pblmix, grav_settling + INTEGER scalar_pblmix, tracer_pblmix, grav_settling, ysu_topdown_pblmix #endif CHARACTER (len=19) simulation_start_date CHARACTER (len=len_current_date) current_date_save @@ -91,6 +96,9 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TYPE(WRFU_TimeInterval) :: interval, tmpinterval CHARACTER*80 alarmname, timestring, debuggal INTEGER seconds, seconds2, iring + INTEGER :: nio_tasks_per_group + + LOGICAL, EXTERNAL :: wrf_dm_on_monitor WRITE(wrf_err_message,*)'output_wrf: begin, fid = ',fid CALL wrf_debug( 300 , wrf_err_message ) @@ -167,6 +175,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) #if (EM_CORE == 1) call nl_get_hypsometric_opt ( 1, hypsometric_opt ) + call nl_get_use_theta_m ( 1, use_theta_m ) CALL nl_get_moist_adv_opt ( grid%id , moist_adv_opt ) CALL nl_get_scalar_adv_opt ( grid%id , scalar_adv_opt ) CALL nl_get_tke_adv_opt ( grid%id , tke_adv_opt ) @@ -180,6 +189,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL nl_get_auxinput9_interval_m ( grid%id , sgfdda_interval_m ) CALL nl_get_scalar_pblmix ( grid%id , scalar_pblmix ) CALL nl_get_tracer_pblmix ( grid%id , tracer_pblmix ) + CALL nl_get_ysu_topdown_pblmix ( grid%id , ysu_topdown_pblmix ) CALL nl_get_grav_settling ( grid%id , grav_settling ) IF ( grid_fdda == 1 ) THEN @@ -224,11 +234,36 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) ENDIF #if ( DA_CORE != 1) - CALL nl_get_stoch_force_opt ( grid%id, stoch_force_opt ) - CALL nl_get_stoch_vertstruc_opt ( grid%id, stoch_vertstruc_opt ) - CALL nl_get_nens ( grid%id, nens ) + CALL nl_get_skebs_on ( grid%id, skebs_on ) + CALL nl_get_sppt_on ( grid%id, sppt_on ) + CALL nl_get_rand_perturb_on ( grid%id, rand_perturb_on ) + CALL nl_get_skebs_vertstruc ( grid%id, skebs_vertstruc ) CALL nl_get_tot_backscat_psi ( grid%id, tot_backscat_psi ) CALL nl_get_tot_backscat_t ( grid%id, tot_backscat_t ) + CALL nl_get_REXPONENT_PSI ( grid%id, REXPONENT_PSI ) + CALL nl_get_REXPONENT_T ( grid%id, REXPONENT_T ) + CALL nl_get_ZTAU_T ( grid%id, ZTAU_T ) + CALL nl_get_ZTAU_PSI ( grid%id, ZTAU_PSI ) + CALL nl_get_LMINFORC ( grid%id, LMINFORC ) + CALL nl_get_LMAXFORC ( grid%id, LMAXFORC ) + CALL nl_get_KMINFORC ( grid%id, KMINFORC ) + CALL nl_get_KMAXFORC ( grid%id, KMAXFORC ) + CALL nl_get_LMINFORCT ( grid%id, LMINFORCT ) + CALL nl_get_LMAXFORCT ( grid%id, LMAXFORCT ) + CALL nl_get_KMINFORCT ( grid%id, KMINFORCT ) + CALL nl_get_KMAXFORCT ( grid%id, KMAXFORCT ) + CALL nl_get_ISEED_SKEBS ( grid%id, ISEED_SKEBS ) + CALL nl_get_ISEED_SPPT ( grid%id, ISEED_SPPT ) + CALL nl_get_ISEED_RAND_PERT ( grid%id, ISEED_RAND_PERT ) + CALL nl_get_nens ( grid%id, nens ) + CALL nl_get_sppt_vertstruc ( grid%id, sppt_vertstruc ) + CALL nl_get_rand_pert_vertstruc ( grid%id, rand_pert_vertstruc ) + CALL nl_get_gridpt_stddev_sppt ( grid%id, gridpt_stddev_sppt ) + CALL nl_get_stddev_cutoff_sppt ( grid%id, stddev_cutoff_sppt ) + CALL nl_get_timescale_sppt ( grid%id, timescale_sppt ) + CALL nl_get_gridpt_stddev_rand_pert ( grid%id, gridpt_stddev_rand_pert ) + CALL nl_get_stddev_cutoff_rand_pert ( grid%id, stddev_cutoff_rand_pert ) + CALL nl_get_timescale_rand_pert ( grid%id, timescale_rand_pert ) #endif #endif @@ -296,7 +331,11 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL wrf_put_dom_ti_char ( fid , 'START_DATE', TRIM(start_date) , ierr ) IF ( switch .EQ. input_only) THEN CALL wrf_put_dom_ti_char ( fid , 'SIMULATION_START_DATE', TRIM(start_date) , ierr ) +#ifdef HWRF + ELSE +#else ELSE IF ( ( switch .EQ. restart_only ) .OR. ( switch .EQ. history_only ) ) THEN +#endif CALL nl_get_simulation_start_year ( 1, simulation_start_year ) CALL nl_get_simulation_start_month ( 1, simulation_start_month ) CALL nl_get_simulation_start_day ( 1, simulation_start_day ) @@ -355,8 +394,18 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) ELSE write(alarmname,'("WRF_ALARM_SECS_TIL_NEXT_RING_",i2)')i ENDIF - CALL WRFU_TimeIntervalGet(interval,S=seconds) - CALL WRFU_TimeIntervalGet(tmpinterval,S=seconds2) + +#ifdef DM_PARALLEL + if(wrf_dm_on_monitor()) then +#endif + CALL WRFU_TimeIntervalGet(interval,S=seconds) + CALL WRFU_TimeIntervalGet(tmpinterval,S=seconds2) +#ifdef DM_PARALLEL + endif + + call wrf_dm_bcast_integer(seconds, 1) + call wrf_dm_bcast_integer(seconds2, 1) +#endif IF ( seconds .GE. 1700000000 .OR. seconds .LE. -1700000000 ) THEN ! it is a forever value, do not change it CALL wrf_put_dom_ti_integer( fid, TRIM(alarmname), seconds, 1, ierr ) ELSE @@ -483,16 +532,59 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) END IF IF (switch .EQ. history_only) THEN - CALL wrf_put_dom_ti_integer( fid, 'STOCH_FORCE_OPT' , stoch_force_opt , 1, ierr ) - IF ( stoch_force_opt .NE. 0 ) THEN - CALL wrf_put_dom_ti_integer( fid, 'STOCH_VERTSTRUC_OPT' , stoch_vertstruc_opt , 1, ierr ) - CALL wrf_put_dom_ti_integer( fid, 'NENS' , nens , 1, ierr ) - CALL wrf_put_dom_ti_real ( fid, 'tot_backscat_psi' , tot_backscat_psi , 1, ierr ) - CALL wrf_put_dom_ti_real ( fid, 'tot_backscat_t' , tot_backscat_t , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'SKEBS_ON' , config_flags%skebs_on , 1, ierr ) + IF ( config_flags%skebs_on .NE. 0 ) THEN + CALL wrf_put_dom_ti_real ( fid, 'TOT_BACKSCAT_PSI' , config_flags%tot_backscat_psi , 1, ierr ) + CALL wrf_put_dom_ti_real ( fid, 'TOT_BACKSCAT_T' , config_flags%tot_backscat_t , 1, ierr ) + CALL wrf_put_dom_ti_real ( fid, 'REXPONENT_PSI' , config_flags%REXPONENT_PSI , 1, ierr ) + CALL wrf_put_dom_ti_real ( fid, 'REXPONENT_T' , config_flags%REXPONENT_T , 1, ierr ) + CALL wrf_put_dom_ti_real ( fid, 'ZTAU_PSI' , config_flags%ZTAU_PSI , 1, ierr ) + CALL wrf_put_dom_ti_real ( fid, 'ZTAU_T ' , config_flags%ZTAU_T , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'LMINFORC' , config_flags%LMINFORC , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'LMAXFORC' , config_flags%LMAXFORC , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'KMINFORC' , config_flags%KMINFORC , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'KMAXFORC' , config_flags%KMAXFORC , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'LMINFORCT' , config_flags%LMINFORCT , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'LMAXFORCT' , config_flags%LMAXFORCT , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'KMINFORCT' , config_flags%KMINFORCT , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'KMAXFORCT' , config_flags%KMAXFORCT , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'SKEBS_VERTSTRUC' , config_flags%skebs_vertstruc , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'NENS' , config_flags%nens , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'ISEED_SKEBS' , config_flags%ISEED_SKEBS , 1, ierr ) END IF + IF ( config_flags%rand_perturb_on .NE. 0 ) THEN + CALL wrf_put_dom_ti_real ( fid, 'GRIDPT_STDDEV_RAND_PERT', config_flags%gridpt_stddev_rand_pert, 1, ierr ) + CALL wrf_put_dom_ti_real ( fid, 'STDDEV_CUTOFF_RAND_PERT', config_flags%stddev_cutoff_rand_pert, 1, ierr ) + CALL wrf_put_dom_ti_real ( fid, 'LENGTHSCALE_RAND_PERT', config_flags%lengthscale_rand_pert, 1, ierr ) + CALL wrf_put_dom_ti_real ( fid, 'TIMESCALE_RAND_PERT', config_flags%timescale_rand_pert, 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'RAND_PERT_VERTSTRUC', config_flags%rand_pert_vertstruc, 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'NENS' , config_flags%nens , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'ISEED_RAND_PERT' , config_flags%ISEED_RAND_PERT , 1, ierr ) + END IF + IF ( config_flags%sppt_on .NE. 0 ) THEN + CALL wrf_put_dom_ti_real ( fid, 'GRIDPT_STDDEV_SPPT', config_flags%gridpt_stddev_sppt, 1, ierr ) + CALL wrf_put_dom_ti_real ( fid, 'STDDEV_CUTOFF_SPPT', config_flags%stddev_cutoff_sppt, 1, ierr ) + CALL wrf_put_dom_ti_real ( fid, 'LENGTHSCALE_SPPT', config_flags%lengthscale_sppt, 1, ierr ) + CALL wrf_put_dom_ti_real ( fid, 'TIMESCALE_SPPT', config_flags%timescale_sppt, 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'SPPT_VERTSTRUC', config_flags%sppt_vertstruc, 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'NENS' ,config_flags%nens , 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'ISEED_SPPT' ,config_flags% ISEED_SPPT , 1, ierr ) + END IF + IF ( config_flags%perturb_bdy .NE. 0 ) THEN + CALL wrf_put_dom_ti_integer( fid, 'PERTURB_BDY', config_flags%perturb_bdy, 1, ierr ) + END IF + CALL wrf_put_dom_ti_integer( fid, 'SPEC_BDY_FINAL_MU', config_flags%spec_bdy_final_mu, 1, ierr ) + CALL wrf_put_dom_ti_integer( fid, 'USE_Q_DIABATIC', config_flags%use_q_diabatic, 1, ierr ) END IF #endif +! added by SYHA (09-19-2014) +#if ((WRF_CHEM == 1) && (EM_CORE == 1)) + IF ( config_flags%perturb_chem_bdy .NE. 0 ) THEN + CALL wrf_put_dom_ti_integer( fid, 'PERTURB_CHEM_BDY', config_flags%perturb_chem_bdy, 1, ierr ) + END IF +#endif + ! added this metadatum for H. Chuan, NCEP, 030417, JM #if (NMM_CORE == 1) CALL wrf_put_dom_ti_char ( fid , 'GRIDTYPE', 'E' , ierr ) @@ -537,6 +629,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) ! added netcdf-specific metadata: IF ( ( use_package( io_form ) == IO_NETCDF ) .OR. & ( use_package( io_form ) == IO_PHDF5 ) .OR. & + ( use_package( io_form ) == IO_PIO ) .OR. & ( use_package( io_form ) == IO_PNETCDF ) ) THEN CALL wrf_put_dom_ti_integer ( fid, 'SURFACE_INPUT_SOURCE', surface_input_source , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'SST_UPDATE', sst_update , 1 , ierr ) @@ -548,6 +641,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'SGFDDA_INTERVAL_M', sgfdda_interval_m , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'SGFDDA_END_H', sgfdda_end_h , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'HYPSOMETRIC_OPT', hypsometric_opt , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'USE_THETA_M', use_theta_m , 1 , ierr ) #endif IF ( switch .EQ. history_only ) THEN @@ -645,6 +739,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'ICLOUD_CU', config_flags%icloud_cu , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'TRACER_PBLMIX', tracer_pblmix , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'SCALAR_PBLMIX', scalar_pblmix , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'YSU_TOPDOWN_PBLMIX', ysu_topdown_pblmix , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'GRAV_SETTLING', grav_settling , 1 , ierr ) #endif @@ -668,6 +763,18 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'DFI_OPT', config_flags%dfi_opt , 1 , ierr ) ENDIF ! history_only + +#if (EM_CORE == 1) && ( DA_CORE != 1) + IF ( ( switch .EQ. input_only ) .OR. & + ( switch .EQ. history_only ) .OR. & + ( switch .EQ. restart_only ) ) THEN + IF ( grid%this_is_an_ideal_run ) THEN + CALL wrf_put_dom_ti_char ( fid , 'SIMULATION_INITIALIZATION_TYPE', "IDEALIZED DATA" , ierr ) + ELSE + CALL wrf_put_dom_ti_char ( fid , 'SIMULATION_INITIALIZATION_TYPE', "REAL-DATA CASE" , ierr ) + END IF + END IF +#endif ENDIF ! added these fields for use by reassembly programs , 010831, JM @@ -860,6 +967,25 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) dname = p%DataName IF (p%Ntl.GT.0.AND.switch.NE.restart_only)dname=dname(1:len(TRIM(dname))-2) memord = p%MemoryOrder + +#if (EM_CORE == 1) + ! CF compliancy would have us put the string "minutes since" // simulation_start_date + ! as the ouput in the units attribute. After the WRF p%Units string has the "minutes since" + ! substring, we wipe out the rest of the string and add the model's original (pre-restart) + ! starting date. This is only for the time variable in WRF (XTIME), which is now considered + ! the time coordinate in netcdf. + + IF (TRIM(p%DataName).EQ."XTIME") THEN + WRITE ( simulation_start_date , FMT = '(I4.4,"-",I2.2,"-",I2.2," ",I2.2,":",I2.2,":",I2.2)' ) & + simulation_start_year,simulation_start_month,simulation_start_day,& + simulation_start_hour,simulation_start_minute,simulation_start_second + IF ( TRIM(p%Description(1:14)) .EQ. 'minutes since ' ) THEN + p%Description(15:33) = TRIM(simulation_start_date) + p%Units (15:33) = TRIM(simulation_start_date) + ENDIF + ENDIF +#endif + IF ( p%Type .EQ. 'r' ) THEN CALL wrf_ext_write_field ( & fid , & ! DataHandle @@ -867,8 +993,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(p%DataName) , & ! Data Name p%rfield_0d , & ! Field WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -891,8 +1016,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(p%DataName) , & ! Data Name p%dfield_0d , & ! Field WRF_DOUBLE , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -915,8 +1039,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(p%DataName) , & ! Data Name p%ifield_0d , & ! Field WRF_INTEGER , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -939,8 +1062,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(p%DataName) , & ! Data Name p%lfield_0d , & ! Field WRF_LOGICAL , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -973,8 +1095,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(dname) , & ! Data Name p%rfield_1d , & ! Field WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -997,8 +1118,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(dname) , & ! Data Name p%dfield_1d , & ! Field WRF_DOUBLE , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1021,8 +1141,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(dname) , & ! Data Name p%ifield_1d , & ! Field WRF_INTEGER , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1045,8 +1164,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(dname) , & ! Data Name p%lfield_1d , & ! Field WRF_LOGICAL , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1083,8 +1201,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(dname) , & ! Data Name p%rfield_2d , & ! Field WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1107,8 +1224,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(dname) , & ! Data Name p%dfield_2d , & ! Field WRF_DOUBLE , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1131,8 +1247,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(dname) , & ! Data Name p%ifield_2d , & ! Field WRF_INTEGER , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1155,8 +1270,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(dname) , & ! Data Name p%lfield_2d , & ! Field WRF_LOGICAL , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1193,8 +1307,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(dname) , & ! Data Name p%rfield_3d , & ! Field WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1217,8 +1330,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(dname) , & ! Data Name p%dfield_3d , & ! Field WRF_DOUBLE , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1241,8 +1353,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) TRIM(dname) , & ! Data Name p%ifield_3d , & ! Field WRF_INTEGER , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1284,8 +1395,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) 1, 1, 1 , & ! see comment above RWORDSIZE , & WRF_FLOAT , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1311,8 +1421,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) 1, 1, 1 , & ! see comment above DWORDSIZE , & WRF_DOUBLE , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1338,8 +1447,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) 1, 1, 1 , & ! see comment above IWORDSIZE , & WRF_INTEGER , & ! FieldType - grid%communicator , & ! Comm - grid%iocommunicator , & ! Comm + grid , & ! grid grid%domdesc , & ! Comm grid%bdy_mask , & ! bdy_mask dryrun , & ! flag @@ -1384,6 +1492,28 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL wrf_debug ( 300 , 'output_wrf: calling wrf_iosync ' ) CALL wrf_iosync ( fid , ierr ) CALL wrf_debug ( 300 , 'output_wrf: back from wrf_iosync ' ) + + ! If output_ready_flag is set: + ! Write wrfoutReady file if finished dumping + ! history file, unless we're quilting, in which + ! case this file would get dumped before history + ! file was completely written. When quilting + ! this file is written after the file handler + ! is closed in the quilt() subroutine instead of + ! here. (This is diagnosed by checking whether + ! nio_tasks_in_group is zero) GAC 20140321 + + IF ( switch .EQ. history_only .AND. config_flags%output_ready_flag ) THEN + WRITE ( wrf_err_message , FMT='(I2.2)' ) grid%id + CALL get_nio_tasks_in_group ( nio_tasks_per_group ) + IF ( nio_tasks_per_group .EQ. 0 ) THEN + OPEN ( UNIT = 99 , & + FILE = 'wrfoutReady_d' // wrf_err_message(1:2) // '_' // TRIM(current_date) , & + STATUS = 'UNKNOWN' , & + ACCESS = 'SEQUENTIAL' ) + CLOSE (99) + ENDIF + ENDIF ENDIF WRITE(wrf_err_message,*)'output_wrf: end, fid = ',fid diff --git a/wrfv2_fire/share/set_timekeeping.F b/wrfv2_fire/share/set_timekeeping.F index 384a10b6..f0f064e8 100644 --- a/wrfv2_fire/share/set_timekeeping.F +++ b/wrfv2_fire/share/set_timekeeping.F @@ -481,7 +481,7 @@ SUBROUTINE Setup_Timekeeping ( grid ) CALL domain_alarm_create( grid, INPUTOUT_ALARM, interval, begin_time, end_time ) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) ! AUXINPUT5_ INTERVAL ! auxinput5_interval is left there (and means minutes) for consistency, but ! auxinput5_interval_m will take precedence if specified @@ -540,7 +540,7 @@ SUBROUTINE Setup_Timekeeping ( grid ) !TBH: Should be OK to remove the "#else" section and the code it contains !TBH: because later code overwrites grid%alarms( AUXINPUT5_ALARM )... !TBH: In fact, by setting namelist values for auxinput5 correctly, it ought -!TBH: to be possible to get rid of all "#ifdef WRF_CHEM" bits in this file... +!TBH: to be possible to get rid of all "#if ( WRF_CHEM == 1 )" bits in this file... CALL WRFU_AlarmEnable( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) CALL WRFU_AlarmRingerOn( grid%alarms( AUXINPUT5_ALARM ), rc=rc ) ! TBH: NOTE: Proper setting of namelist variables for auxinput5 ought to @@ -558,7 +558,7 @@ SUBROUTINE Setup_Timekeeping ( grid ) ! the nests. Parallel NetCDF does a header check on all the metadata being written ! from multiple processors and if it differs, it throws up an error. This avoids that. IF ( grid%id .EQ. 1 ) THEN ! only moad can have specified boundaries - CALL domain_alarm_create( grid, BOUNDARY_ALARM ) + CALL domain_alarm_create( grid, BOUNDARY_ALARM, interval ) CALL WRFU_AlarmEnable( grid%alarms( BOUNDARY_ALARM ), rc=rc ) CALL wrf_check_error( WRFU_SUCCESS, rc, & 'WRFU_AlarmEnable(BOUNDARY_ALARM) FAILED', & diff --git a/wrfv2_fire/share/solve_interface.F b/wrfv2_fire/share/solve_interface.F index 334c5032..5084a6c3 100644 --- a/wrfv2_fire/share/solve_interface.F +++ b/wrfv2_fire/share/solve_interface.F @@ -41,8 +41,8 @@ SUBROUTINE solve_interface ( grid ) ! ) -# ifdef WRF_CHEM - IF ( config_flags%chem_opt > 0 ) THEN +# if ( WRF_CHEM == 1 ) + IF ( config_flags%chem_opt > 0 .or. config_flags%tracer_opt > 0 ) THEN CALL chem_driver ( grid , config_flags & ! @@ -58,7 +58,7 @@ SUBROUTINE solve_interface ( grid ) # include ! ) -# ifdef WRF_CHEM +# if ( WRF_CHEM == 1 ) IF ( config_flags%chem_opt > 0 ) THEN CALL chem_driver ( grid , config_flags & diff --git a/wrfv2_fire/share/track_driver.F b/wrfv2_fire/share/track_driver.F index 21a25098..92094ce0 100644 --- a/wrfv2_fire/share/track_driver.F +++ b/wrfv2_fire/share/track_driver.F @@ -79,7 +79,7 @@ SUBROUTINE track_driver( grid ) !-- output chemical species -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( model_config_rec%chem_opt(grid%id) > 0 .and. grid%track_chem_num > 0 ) THEN do m= 1,grid%track_chem_num chem_name = TRIM(model_config_rec%track_chem_name(m)) @@ -147,7 +147,7 @@ SUBROUTINE track_driver( grid ) !-- output chem -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( model_config_rec%chem_opt(grid%id) > 0 .and. grid%track_chem_num > 0 ) THEN do m= 1,grid%track_chem_num @@ -257,14 +257,20 @@ SUBROUTINE write_track( grid ) #ifdef DM_PARALLEL REAL, ALLOCATABLE, DIMENSION(:,:) :: track_buf2 -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) REAL, ALLOCATABLE, DIMENSION(:,:,:) :: track_buf3 #endif #endif !==================================================================================== +#if 1 +!We actually always need to include 'netcdf.inc', +!as this routine won't compile without netcdf. +include 'netcdf.inc' +#else #ifdef NETCDF include 'netcdf.inc' +#endif #endif @@ -330,7 +336,7 @@ SUBROUTINE write_track( grid ) track_buf2(:,:) = grid%track_qvapor(:,:) CALL wrf_dm_min_reals(track_buf2(:,:),grid%track_qvapor(:,:),grid%track_loc_in*level) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF (model_config_rec%chem_opt(grid%id) > 0) THEN !o31d track_buf2(:,:) = grid%track_o31d(:,:) @@ -366,7 +372,7 @@ SUBROUTINE write_track( grid ) DEALLOCATE(track_buf2) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !--put chem output in grid%track_chem(:,:,:) !chem @@ -434,7 +440,7 @@ SUBROUTINE write_track( grid ) astat = NF_DEF_DIM(ncid, 'DateStrLen' , DateStrLen , Times_dim) astat = NF_DEF_DIM(ncid, 'level_stag' , level_stag , level_stag_dim) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( model_config_rec%chem_opt(grid%id) > 0 .and. model_config_rec%phot_opt(grid%id) == 3 ) THEN astat = NF_DEF_DIM(ncid, 'level_zref' , level_zref , level_zref_dim) astat = NF_DEF_DIM(ncid, 'num_rad' , num_rad , rad_dim) @@ -451,7 +457,7 @@ SUBROUTINE write_track( grid ) !-- define 1-D variables -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( model_config_rec%chem_opt(grid%id) > 0 .and. model_config_rec%phot_opt(grid%id) == 3 ) THEN !wc description = 'Wavelength' @@ -589,7 +595,7 @@ SUBROUTINE write_track( grid ) astat = NF_PUT_ATT_TEXT(ncid,var_id,'description', len_trim(description),description) astat = NF_PUT_ATT_TEXT(ncid,var_id,'units', len_trim(units), units ) -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( model_config_rec%chem_opt(grid%id) > 0 .and. grid%track_chem_num > 0 ) THEN !chem @@ -711,7 +717,7 @@ SUBROUTINE write_track( grid ) !-- write 1-D variables -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) IF ( model_config_rec%chem_opt(grid%id) > 0 .and. grid%track_chem_num > 0 ) THEN if ( model_config_rec%phot_opt(grid%id) == 3 )then !wc @@ -845,7 +851,7 @@ SUBROUTINE write_track( grid ) astat = NF_PUT_VARA_REAL(ncid,var_id,start(1:2),count(1:2),grid%track_qvapor(m,:)) end do -#ifdef WRF_CHEM +#if ( WRF_CHEM == 1 ) !chem IF ( model_config_rec%chem_opt(grid%id) > 0 .and. grid%track_chem_num > 0 ) THEN diff --git a/wrfv2_fire/share/wrf_ext_read_field.F b/wrfv2_fire/share/wrf_ext_read_field.F index 500e7221..212983c6 100644 --- a/wrfv2_fire/share/wrf_ext_read_field.F +++ b/wrfv2_fire/share/wrf_ext_read_field.F @@ -5,7 +5,7 @@ SUBROUTINE wrf_ext_read_field_arr(DataHandle,DateStr,Var & ,idx4, idx5, idx6, idx7 & ,nx4 , nx5 , nx6 & ,TypeSizeInBytes & - ,FieldType,Comm,IOComm & + ,FieldType, grid & ,DomainDesc & ,bdy_mask & ,MemoryOrder & @@ -18,6 +18,7 @@ SUBROUTINE wrf_ext_read_field_arr(DataHandle,DateStr,Var & USE module_wrf_error USE module_state_description USE module_timing + USE module_domain IMPLICIT NONE INTEGER, INTENT(IN) :: idx4, idx5, idx6, idx7 @@ -28,8 +29,7 @@ SUBROUTINE wrf_ext_read_field_arr(DataHandle,DateStr,Var & CHARACTER*(*) ,INTENT(IN ) :: Var INTEGER ,INTENT(INOUT) :: Field(*) INTEGER ,INTENT(IN ) :: FieldType - INTEGER ,INTENT(IN ) :: Comm - INTEGER ,INTENT(IN ) :: IOComm + TYPE(domain) :: grid INTEGER ,INTENT(IN ) :: DomainDesc CHARACTER*(*) ,INTENT(IN ) :: MemoryOrder LOGICAL, DIMENSION(4) ,INTENT(IN ) :: bdy_mask @@ -59,7 +59,7 @@ SUBROUTINE wrf_ext_read_field_arr(DataHandle,DateStr,Var & +(idx5-1)*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) & +(idx6-1)*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) & +(idx7-1)*nx6*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1))) & - ,FieldType,Comm,IOComm & + ,FieldType, grid & ,DomainDesc & ,bdy_mask & ,MemoryOrder & @@ -71,7 +71,7 @@ SUBROUTINE wrf_ext_read_field_arr(DataHandle,DateStr,Var & END SUBROUTINE wrf_ext_read_field_arr - SUBROUTINE wrf_ext_read_field( DataHandle,DateStr,Var,Field,FieldType,Comm,IOComm, & + SUBROUTINE wrf_ext_read_field( DataHandle,DateStr,Var,Field,FieldType,grid, & DomainDesc, bdy_mask, MemoryOrder,Stagger, & debug_message , & ds1, de1, ds2, de2, ds3, de3, & @@ -79,6 +79,8 @@ SUBROUTINE wrf_ext_read_field( DataHandle,DateStr,Var,Field,FieldType,Comm,IOCom ps1, pe1, ps2, pe2, ps3, pe3, Status ) USE module_io USE module_wrf_error + USE module_domain + IMPLICIT NONE integer :: DataHandle @@ -86,8 +88,7 @@ SUBROUTINE wrf_ext_read_field( DataHandle,DateStr,Var,Field,FieldType,Comm,IOCom character*(*) :: Var integer :: Field(*) integer :: FieldType - integer :: Comm - integer :: IOComm + TYPE(domain) :: grid integer :: DomainDesc logical, dimension(4) :: bdy_mask character*(*) :: MemoryOrder @@ -140,8 +141,7 @@ SUBROUTINE wrf_ext_read_field( DataHandle,DateStr,Var,Field,FieldType,Comm,IOCom ,Var & ! Data Name ,Field & ! Field ,FieldType & ! FieldType - ,Comm & ! Comm - ,IOComm & ! IOComm + ,grid & ! domain grid ,DomainDesc & ! DomainDesc ,bdy_mask & ! bdy_mask ,MemoryOrder & ! MemoryOrder diff --git a/wrfv2_fire/share/wrf_ext_write_field.F b/wrfv2_fire/share/wrf_ext_write_field.F index 12e362fd..eaf44bf7 100644 --- a/wrfv2_fire/share/wrf_ext_write_field.F +++ b/wrfv2_fire/share/wrf_ext_write_field.F @@ -4,7 +4,7 @@ SUBROUTINE wrf_ext_write_field_arr(DataHandle,DateStr,Var & ,idx4, idx5, idx6, idx7 & ,nx4 , nx5 , nx6 & ,TypeSizeInBytes & - ,FieldType,Comm,IOComm & + ,FieldType,grid & ,DomainDesc & ,bdy_mask & ,dryrun & @@ -20,6 +20,8 @@ SUBROUTINE wrf_ext_write_field_arr(DataHandle,DateStr,Var & USE module_wrf_error USE module_state_description USE module_timing + USE module_domain + IMPLICIT NONE INTEGER, INTENT(IN) :: idx4, idx5, idx6, idx7 @@ -30,8 +32,7 @@ SUBROUTINE wrf_ext_write_field_arr(DataHandle,DateStr,Var & CHARACTER*(*) ,INTENT(IN ) :: Var INTEGER ,INTENT(IN ) :: Field(*) INTEGER ,INTENT(IN ) :: FieldType - INTEGER ,INTENT(IN ) :: Comm - INTEGER ,INTENT(IN ) :: IOComm + TYPE(domain) :: grid INTEGER ,INTENT(IN ) :: DomainDesc LOGICAL ,INTENT(IN ) :: dryrun CHARACTER*(*) ,INTENT(IN ) :: MemoryOrder @@ -64,7 +65,7 @@ SUBROUTINE wrf_ext_write_field_arr(DataHandle,DateStr,Var & +(idx5-1)*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) & +(idx6-1)*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1) & +(idx7-1)*nx6*nx5*nx4*(me3-ms3+1)*(me2-ms2+1)*(me1-ms1+1))) & - ,FieldType,Comm,IOComm & + ,FieldType,grid & ,DomainDesc & ,bdy_mask & ,dryrun & @@ -80,7 +81,7 @@ SUBROUTINE wrf_ext_write_field_arr(DataHandle,DateStr,Var & END SUBROUTINE wrf_ext_write_field_arr - SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOComm, & + SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,grid, & DomainDesc, & bdy_mask , & dryrun , & @@ -96,6 +97,8 @@ SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOCom USE module_wrf_error USE module_state_description USE module_timing + USE module_domain + IMPLICIT NONE INTEGER ,INTENT(IN ) :: DataHandle @@ -103,8 +106,7 @@ SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOCom CHARACTER*(*) ,INTENT(IN ) :: Var INTEGER ,INTENT(IN ) :: Field(*) INTEGER ,INTENT(IN ) :: FieldType - INTEGER ,INTENT(IN ) :: Comm - INTEGER ,INTENT(IN ) :: IOComm + TYPE(domain) :: grid INTEGER ,INTENT(IN ) :: DomainDesc LOGICAL ,INTENT(IN ) :: dryrun CHARACTER*(*) ,INTENT(IN ) :: MemoryOrder @@ -126,9 +128,10 @@ SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOCom integer ,intent(inout) :: Status LOGICAL for_out, horiz_stagger - INTEGER Hndl, io_form + INTEGER io_form LOGICAL, EXTERNAL :: has_char INTEGER, EXTERNAL :: use_package + INTEGER Hndl IF ( wrf_at_debug_level( 500 ) ) THEN call start_timing @@ -164,15 +167,13 @@ SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOCom #endif Status = 0 - CALL wrf_write_field ( & DataHandle & ! DataHandle ,DateStr & ! DateStr ,Var & ! Data Name ,Field & ! Field ,FieldType & ! FieldType - ,Comm & ! Comm - ,IOComm & ! IOComm + ,grid & ! grid ,DomainDesc & ! DomainDesc ,bdy_mask & ! bdy_mask ,MemoryOrder & ! MemoryOrder @@ -189,6 +190,7 @@ SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOCom CALL get_handle ( Hndl, io_form , for_out, DataHandle ) IF ( ( dryrun .AND. ( use_package(io_form) .EQ. IO_NETCDF .OR. & + use_package(io_form) .EQ. IO_PIO .OR. & use_package(io_form) .EQ. IO_PNETCDF ) ) .OR. & ( use_package(io_form) .EQ. IO_PHDF5 ) ) THEN @@ -218,20 +220,17 @@ SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOCom ! TBH: named "XLONG", "XLAT", "XLONG_U", "XLAT_U", "XLONG_V", and ! TBH: "XLAT_V" for EM_CORE. We need a more general way to handle ! TBH: this, possibly via the Registry. -! TBH: TODO: Leave this on all the time or make it namelist-selectable? ! TBH: TODO: Use dimnames(*) == south_north || west_east instead of ! TBH: MemoryOrder and Stagger? It would also work for both ARW ! TBH: and NMM and be easier to handle via Registry... -! IF ( ( ( MemoryOrder(1:2) == 'XY' ) .OR. & -! ( MemoryOrder(1:3) == 'XZY' ) ) .AND. & -! ( Var(1:5) /= 'XLONG' ) .AND. & -! ( Var(1:4) /= 'XLAT' ) ) THEN -! JM used trim instead, to avoid spurious errors when bounds checking on - IF ( ( ( TRIM(MemoryOrder) == 'XY' ) .OR. & - ( TRIM(MemoryOrder) == 'XZY' ) .OR. & - ( TRIM(MemoryOrder) == 'XYZ' ) ) .AND. & - ( TRIM(Var) /= 'XLONG' ) .AND. & - ( TRIM(Var) /= 'XLAT' ) ) THEN + + IF ( ( TRIM(MemoryOrder) == 'XY' ) .AND. & + ( ( TRIM(Var) == 'XLONG' ) .OR. & + ( TRIM(Var) == 'XLAT' ) .OR. & + ( TRIM(Var) == 'XLONG_U' ) .OR. & + ( TRIM(Var) == 'XLAT_U' ) .OR. & + ( TRIM(Var) == 'XLONG_V' ) .OR. & + ( TRIM(Var) == 'XLAT_V' ) ) ) THEN horiz_stagger = .FALSE. IF ( LEN_TRIM(Stagger) == 1 ) THEN IF ( has_char( Stagger, 'x' ) ) THEN @@ -260,6 +259,37 @@ SUBROUTINE wrf_ext_write_field(DataHandle,DateStr,Var,Field,FieldType,Comm,IOCom ,"XLONG XLAT" & ! Data ,Status ) ENDIF + ELSE IF ( ( TRIM(MemoryOrder) == 'XY' ) .OR. & + ( TRIM(MemoryOrder) == 'XZY' ) .OR. & + ( TRIM(MemoryOrder) == 'XYZ' ) ) THEN + horiz_stagger = .FALSE. + IF ( LEN_TRIM(Stagger) == 1 ) THEN + IF ( has_char( Stagger, 'x' ) ) THEN + horiz_stagger = .TRUE. + CALL wrf_put_var_ti_char( & + DataHandle & ! DataHandle + ,"coordinates" & ! Element + ,Var & ! Data Name + ,"XLONG_U XLAT_U XTIME" & ! Data + ,Status ) + ELSE IF ( has_char( Stagger, 'y' ) ) THEN + horiz_stagger = .TRUE. + CALL wrf_put_var_ti_char( & + DataHandle & ! DataHandle + ,"coordinates" & ! Element + ,Var & ! Data Name + ,"XLONG_V XLAT_V XTIME" & ! Data + ,Status ) + ENDIF + ENDIF + IF ( .NOT. horiz_stagger ) THEN + CALL wrf_put_var_ti_char( & + DataHandle & ! DataHandle + ,"coordinates" & ! Element + ,Var & ! Data Name + ,"XLONG XLAT XTIME" & ! Data + ,Status ) + ENDIF ENDIF #endif ENDIF diff --git a/wrfv2_fire/test/em_convrad/README.convrad b/wrfv2_fire/test/em_convrad/README.convrad new file mode 100644 index 00000000..16199646 --- /dev/null +++ b/wrfv2_fire/test/em_convrad/README.convrad @@ -0,0 +1,26 @@ + +The purpose of this case is to demonstrate an idealized convective-radiative +equilibrium 3d run driven by the SST. Run for weeks to months, this develops +a steady-state convection in a weak wind background typical of the tropics +with a grid size small enough (1 km) to resolve individual updrafts. +The test case domain and run length are small compared to typical runs and +serve only as a demonstration. + +The initialization makes use of the full physics initialization in the +sea-breeze case but, new in V3.7, the SST can be specified in input_sounding +via the surface temperature in the first line and the surface is all-ocean +by default. There is a small Coriolis force of 2.5e-5 and a random low-level +temperature perturbation to initiate the convection. + +The input sounding has u=5 m/s, and SST=300 K with a moist profile to support +convection. +pert_coriolis is true so the input_sounding wind is taken to be geostrophically +balanced. +Use the run_me_first.csh script to copy necessary data files for radiation. + +This setup is for a 3D case with 101x101 grid points, dx=1 km, and 35 eta levels. +The top is at 30 km. The physics choices are WSM6 microphysics, RRTMG radiation, +the 5-layer slab model (inactive due to water surface), and YSU PBL scheme. +There are periodic boundaries and w-Rayleigh damping at the top. +Buckets are turned on for rainfall and radiation budgets because this is designed +to be a long run that may be a month or more to obtain equilibrium. diff --git a/wrfv2_fire/test/em_convrad/input_sounding b/wrfv2_fire/test/em_convrad/input_sounding new file mode 100644 index 00000000..f50846fa --- /dev/null +++ b/wrfv2_fire/test/em_convrad/input_sounding @@ -0,0 +1,28 @@ + 1000.00 300.0 18.20000 + 132.0000 299.1500 17.60000 5.0 0.0 + 583.0000 300.5175 15.30000 5.0 0.0 + 1054.000 301.8932 13.00000 5.0 0.0 + 1547.000 304.2399 11.00000 5.0 0.0 + 2063.000 306.6724 8.400000 5.0 0.0 + 2609.000 309.3341 7.100000 5.0 0.0 + 3182.000 311.9428 5.800000 5.0 0.0 + 3792.000 314.6532 4.600000 5.0 0.0 + 4442.000 317.6435 3.600000 5.0 0.0 + 5138.000 321.0051 3.200000 5.0 0.0 + 5888.000 324.4946 2.100000 5.0 0.0 + 6703.000 328.1210 1.400000 5.0 0.0 + 7595.000 331.8052 0.0 5.0 0.0 + 8581.000 335.1144 0.0 5.0 0.0 + 9682.000 338.3430 0.0 5.0 0.0 + 10935.00 341.4132 0.0 5.0 0.0 + 12396.00 345.0262 0.0 5.0 0.0 + 13236.00 348.0688 0.0 5.0 0.0 + 14177.00 353.2416 0.0 5.0 0.0 + 15260.00 363.7825 0.0 5.0 0.0 + 16568.00 385.1966 0.0 5.0 0.0 + 17883.00 418.1352 0.0 5.0 0.0 + 19620.00 467.0863 0.0 5.0 0.0 + 20743.00 499.7953 0.0 5.0 0.0 + 22139.00 540.9318 0.0 5.0 0.0 + 23971.00 596.1987 0.0 5.0 0.0 + 30000.00 778.0787 0.0 5.0 0.0 diff --git a/wrfv2_fire/test/em_convrad/namelist.input b/wrfv2_fire/test/em_convrad/namelist.input new file mode 100644 index 00000000..94768715 --- /dev/null +++ b/wrfv2_fire/test/em_convrad/namelist.input @@ -0,0 +1,113 @@ + &time_control + run_days = 0, + run_hours = 1, + run_minutes = 0, + run_seconds = 0, + start_year = 2007, + start_month = 06, + start_day = 01, + start_hour = 0, + start_minute = 00, + start_second = 00, + end_year = 2007, + end_month = 07, + end_day = 1, + end_hour = 0, + end_minute = 00, + end_second = 00, + history_interval = 60, + frames_per_outfile = 1000, + restart = .false., + restart_interval = 1440, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 5, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, + e_we = 101, + s_sn = 1, + e_sn = 101, + s_vert = 1, + e_vert = 35, + dx = 1000, + dy = 1000, + ztop = 30000., + eta_levels = 1.000, 0.993, 0.983, 0.970, 0.954, + 0.934, 0.909, 0.880, 0.845, 0.807, + 0.765, 0.719, 0.672, 0.622, 0.571, + 0.520, 0.468, 0.420, 0.376, 0.335, + 0.298, 0.263, 0.231, 0.202, 0.175, + 0.150, 0.127, 0.106, 0.088, 0.070, + 0.055, 0.040, 0.026, 0.013, 0.000 + + / + + &physics + mp_physics = 6, + ra_lw_physics = 4, + ra_sw_physics = 4, + radt = 5, + sf_sfclay_physics = 1, + sf_surface_physics = 1, + bl_pbl_physics = 1, + bldt = 0, + cu_physics = 0, + cudt = 0, + num_soil_layers = 5, + bucket_mm =10., + bucket_J =1.e8, + / + + &fdda + / + + &dynamics + rk_ord = 3, + diff_opt = 1, 1, 1, + km_opt = 4, 4, 4, + damp_opt = 3, + dampcoef = .2, + zdamp = 5000., + khdif = 0, + kvdif = 0, + smdiv = 0.1, + emdiv = 0.01, + epssm = 0.1, + time_step_sound = 6, + h_mom_adv_order = 5, + v_mom_adv_order = 3, + h_sca_adv_order = 5, + v_sca_adv_order = 3, + mix_full_fields = .true., + non_hydrostatic = .true., + pert_coriolis = .true., + / + + &bdy_control + periodic_x = .true., + symmetric_xs = .false., + symmetric_xe = .false., + open_xs = .false., + open_xe = .false., + periodic_y = .true., + symmetric_ys = .false., + symmetric_ye = .false., + open_ys = .false., + open_ye = .false., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_convrad/run_me_first.csh b/wrfv2_fire/test/em_convrad/run_me_first.csh new file mode 100755 index 00000000..f9fe64ba --- /dev/null +++ b/wrfv2_fire/test/em_convrad/run_me_first.csh @@ -0,0 +1,12 @@ +#!/bin/csh + +echo Setting up seabreeze2d_x case by linking data files into this directory + +echo linking to some physics data files in ../../run directory + +ln -sf ../../run/LANDUSE.TBL . +ln -sf ../../run/RRTM_DATA . +ln -sf ../../run/RRTMG_LW_DATA . +ln -sf ../../run/RRTMG_SW_DATA . + +echo done diff --git a/wrfv2_fire/test/em_les/README.les b/wrfv2_fire/test/em_les/README.les index 55f7cb54..8d897db2 100644 --- a/wrfv2_fire/test/em_les/README.les +++ b/wrfv2_fire/test/em_les/README.les @@ -40,3 +40,14 @@ the u and v equations for LESs with non-zero geostrophic wind. Note, parameterization constants, c_s and c_k in this namelist are different from the defaults and are the ones recommended to use with LES. +========================================================================= +Shallow convection case (added in V3.7) +Copy namelist.input_shalconv to namelist.input +Copy input_sounding_shalconv to input_sounding +Re-run ideal.exe +As LES case but larger domain (100x100), top still at 2 km. +Differences are sounding 10 K cooler, geostrophic u-wind 10 m/s, isfflx=1 using +input_sounding's surface theta = 295 K as SST, water surface, monotonic +moist and scalar advection, mp_physics =6, no other physics except sf_sfclay_physics=1. +This produces a shallow cloud layer capped by a strong inversion that +grows in response to warmer SST. diff --git a/wrfv2_fire/test/em_les/input_sounding_shalconv b/wrfv2_fire/test/em_les/input_sounding_shalconv new file mode 100644 index 00000000..252d9741 --- /dev/null +++ b/wrfv2_fire/test/em_les/input_sounding_shalconv @@ -0,0 +1,42 @@ + 1000.000 295.0000 14.00000 + 25.000 290.000 10.000 10.000 0.000 + 75.000 290.000 10.000 10.000 0.000 + 125.000 290.000 10.000 10.000 0.000 + 175.000 290.000 10.000 10.000 0.000 + 225.000 290.000 10.000 10.000 0.000 + 275.000 290.000 10.000 10.000 0.000 + 325.000 290.000 10.000 10.000 0.000 + 375.000 290.000 10.000 10.000 0.000 + 425.000 290.000 10.000 10.000 0.000 + 475.000 290.000 10.000 10.000 0.000 + 525.000 290.000 10.000 10.000 0.000 + 575.000 290.000 10.000 10.000 0.000 + 625.000 290.000 10.000 10.000 0.000 + 675.000 290.000 10.000 10.000 0.000 + 725.000 290.000 10.000 10.000 0.000 + 775.000 290.000 10.000 10.000 0.000 + 825.000 290.000 10.000 10.000 0.000 + 875.000 290.000 10.000 10.000 0.000 + 925.000 290.000 10.000 10.000 0.000 + 975.000 292.430 10.000 10.000 0.000 + 1025.000 295.630 4.000 10.000 0.000 + 1075.000 298.050 4.000 10.000 0.000 + 1125.000 298.200 4.000 10.000 0.000 + 1175.000 298.350 4.000 10.000 0.000 + 1225.000 298.500 4.000 10.000 0.000 + 1275.000 298.650 4.000 10.000 0.000 + 1325.000 298.800 4.000 10.000 0.000 + 1375.000 298.950 4.000 10.000 0.000 + 1425.000 299.100 4.000 10.000 0.000 + 1475.000 299.250 4.000 10.000 0.000 + 1525.000 299.400 4.000 10.000 0.000 + 1575.000 299.550 4.000 10.000 0.000 + 1625.000 299.700 4.000 10.000 0.000 + 1675.000 299.850 4.000 10.000 0.000 + 1725.000 300.000 4.000 10.000 0.000 + 1775.000 300.150 4.000 10.000 0.000 + 1825.000 300.300 4.000 10.000 0.000 + 1875.000 300.450 4.000 10.000 0.000 + 1925.000 300.600 4.000 10.000 0.000 + 1975.000 300.750 4.000 10.000 0.000 + 2025.000 300.900 4.000 10.000 0.000 diff --git a/wrfv2_fire/test/em_les/namelist.input b/wrfv2_fire/test/em_les/namelist.input index 1256a068..11b993d9 100644 --- a/wrfv2_fire/test/em_les/namelist.input +++ b/wrfv2_fire/test/em_les/namelist.input @@ -93,6 +93,7 @@ mix_full_fields = .true., .true., .true., non_hydrostatic = .true., .true., .true., pert_coriolis = .true., .true., .true., + use_theta_m = 1, / &bdy_control diff --git a/wrfv2_fire/test/em_les/namelist.input_shalconv b/wrfv2_fire/test/em_les/namelist.input_shalconv new file mode 100644 index 00000000..aad3986e --- /dev/null +++ b/wrfv2_fire/test/em_les/namelist.input_shalconv @@ -0,0 +1,121 @@ + &time_control + run_days = 0, + run_hours = 1, + run_minutes = 00, + run_seconds = 00, + start_year = 0001, 0001, 0001, + start_month = 01, 01, 01, + start_day = 01, 01, 01, + start_hour = 00, 01, 00, + start_minute = 00, 30, 00, + start_second = 00, 00, 00, + end_year = 0001, 0001, 0001, + end_month = 01, 01, 01, + end_day = 01, 01, 01, + end_hour = 01, 02, 00, + end_minute = 00, 30, 00, + end_second = 00, 00, 00, + history_interval_m = 60, 10, 1, + history_interval_s = 00, 00, 1, + frames_per_outfile = 1000, 1000, 1000, + restart = .false., + restart_interval_m = 60, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 1, + time_step_fract_num = 0, + time_step_fract_den = 1, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 100, 100, 151, + s_sn = 1, 1, 1, + e_sn = 100, 100, 151, + s_vert = 1, 1, 1, + e_vert = 40, 100, 41, + dx = 100, 50, 16.6667, + dy = 100, 50, 16.6667, + ztop = 2000, 2000, 2000, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 0, 10, 15, + j_parent_start = 0, 10, 15, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 0, + smooth_option = 0 + / + + &physics + mp_physics = 6, 0, 0, + ra_lw_physics = 0, 0, 0, + ra_sw_physics = 0, 0, 0, + radt = 0, 0, 0, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 0, 0, 0, + bl_pbl_physics = 0, 0, 0, + bldt = 0, 0, 0, + cu_physics = 0, 0, 0, + cudt = 0, 0, 0, + isfflx = 1, + ideal_xland = 2, + num_soil_layers = 5, + / + + &fdda + / + + &dynamics + rk_ord = 3, + diff_opt = 2, 2, 2, + km_opt = 2, 2, 2, + damp_opt = 0, + zdamp = 15000., 5000., 5000., + dampcoef = 0.1, 0.2, 0.2 + khdif = 1., 1., .05, + kvdif = 1., 1., .05, + c_s = 0.18 + c_k = 0.10 + mix_isotropic = 1 + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1 + time_step_sound = 6, 6, 6, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + moist_adv_opt = 2 + scalar_adv_opt = 2 + mix_full_fields = .true., .true., .true., + non_hydrostatic = .true., .true., .true., + pert_coriolis = .true., .true., .true., + use_theta_m = 1, + / + + &bdy_control + periodic_x = .true., .false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .false.,.false.,.false., + open_xe = .false.,.false.,.false., + periodic_y = .true., .false.,.false., + symmetric_ys = .false.,.false.,.false., + symmetric_ye = .false.,.false.,.false., + open_ys = .false.,.false.,.false., + open_ye = .false.,.false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_real/examples.namelist b/wrfv2_fire/test/em_real/examples.namelist index 4552681c..fc0a6c72 100755 --- a/wrfv2_fire/test/em_real/examples.namelist +++ b/wrfv2_fire/test/em_real/examples.namelist @@ -42,20 +42,19 @@ Note, this is not a namelist.input file. Find what interests you, and cut and pa sf_surface_physics = 4 &noah_mp - dveg = 4, - opt_crs = 1, - opt_btr = 2, - opt_sfc = 1, - opt_run = 1, - opt_frz = 1, - opt_inf = 1, - opt_rad = 3, - opt_alb = 2, - opt_snf = 1, - opt_tbot = 1, - opt_stc = 1, - / - + dveg = 4, + opt_crs = 1, + opt_btr = 1, + opt_run = 1, + opt_sfc = 1, + opt_frz = 1, + opt_inf = 1, + opt_rad = 3, + opt_alb = 2, + opt_snf = 1, + opt_tbot = 2, + opt_stc = 1, +/ ** Using lake model &physics @@ -417,6 +416,64 @@ Price, J. F., T. B. Sanford, and G. Z. Forristal, 1994: Forced stage response to traj_opt = 1, +** Vertical nesting + +The WRF model now supports vertical nesting for a coincident (online) +model simulation (during a single model run, differing numbers of +vertical levels may be used per domain). This is activated with a switch +to turn on the option (vert_refine_method). The namelist array eta_levels +is manually filled in for each domain. Below is an example for two +domains. + +NOTE: The user is restricted to either the RRTM or RRTMG radiation schemes. + + &domains + max_dom = 2, + e_vert = 35, 45, + eta_levels(1:35) = 1., 0.993, 0.983, 0.97, 0.954, 0.934, 0.909, 0.88, 0.8406663, 0.8013327, + 0.761999, 0.7226653, 0.6525755, 0.5877361, 0.5278192, 0.472514, + 0.4215262, 0.3745775, 0.3314044, 0.2917579, 0.2554026, 0.2221162, + 0.1916888, 0.1639222, 0.1386297, 0.1156351, 0.09525016, 0.07733481, + 0.06158983, 0.04775231, 0.03559115, 0.02490328, 0.0155102, 0.007255059, 0. + eta_levels(36:81) = 1.0000, 0.9946, 0.9875, 0.9789, 0.9685, 0.9562, 0.9413, 0.9238, 0.9037, 0.8813, 0.8514, + 0.8210, 0.7906, 0.7602, 0.7298, 0.6812, 0.6290, 0.5796, 0.5333, 0.4901, 0.4493, 0.4109, + 0.3746, 0.3412, 0.3098, 0.2802, 0.2524, 0.2267, 0.2028, 0.1803, 0.1593, 0.1398, 0.1219, + 0.1054, 0.0904, 0.0766, 0.0645, 0.0534, 0.0433, 0.0341, 0.0259, 0.0185, 0.0118, 0.0056, 0. + vert_refine_method = 0, 2, + + + +** Tropopause data level of max winds data, for program real.exe only + +When information (mostly NCEP supplied through GFS or NAM) is available +in the Grib2 file, AND extracted with ungrib, the metgrid program inserts +flag information into the data stream that is input by real. The real +program is able to use the available u, v, T, height fields (each may be on +a tropopause .OR. the level of max winds) in the vertical interpolation. +To "tune" the data, the user may select a level below which the max wind +inforamtion is ignored. The default is 300 hPa. The user may also +select the level that when exceeded the trop and maxw fields are ignored +(due to the horizontal pressure difference detecting a user-defined +discontinuity, and the metgrid horizontal interpolation across the +discontinuity would be suspect). + +Default (all units Pa): + &domains + maxw_horiz_pres_diff = 5000 + trop_horiz_pres_diff = 5000 + maxw_above_this_level = 30000 + +To test the sensitivity, a user may shut off the usage of the new data +by making the minimum acceptable vertical level for max winds ABOVE anything +physically possible inside of real, and also by setting the horizontal +pressure difference SMALLER than anything possible. + &domains + maxw_horiz_pres_diff = -1 + trop_horiz_pres_diff = -1 + maxw_above_this_level = 1 + + + ** Using aerosol option aer_opt = 2: &physics @@ -443,3 +500,8 @@ specifics of the wind turbine type: wind-turbine-1.tbl The location of wind turbines are specified as lat lon, and the turbine type: windturbines.txt +** Using stochastic schemes +&stoch + skebs = 1, 1, 1, + rand_perturb = 1, 1, 1, + diff --git a/wrfv2_fire/tools/data.h b/wrfv2_fire/tools/data.h index da97483d..39d77de7 100644 --- a/wrfv2_fire/tools/data.h +++ b/wrfv2_fire/tools/data.h @@ -16,7 +16,7 @@ typedef struct node_struct { int stag_x ; int stag_y ; int stag_z ; - int nmm_v_grid, mp_var ; + int nmm_v_grid, mp_var, full_feedback ; int subject_to_communication ; int boundary_array ; int boundary_array_4d ; diff --git a/wrfv2_fire/tools/fortran_2003_fflush_test.F b/wrfv2_fire/tools/fortran_2003_fflush_test.F new file mode 100644 index 00000000..646dab8a --- /dev/null +++ b/wrfv2_fire/tools/fortran_2003_fflush_test.F @@ -0,0 +1,14 @@ + PROGRAM fortran_2003_test + + IMPLICIT NONE + + REAL :: x + INTEGER :: i + + x = 1.e+10 + i = 1 + + WRITE (6,*) x,i + CALL FFLUSH ( 6 ) + + END PROGRAM fortran_2003_test diff --git a/wrfv2_fire/tools/fortran_2003_flush_test.F b/wrfv2_fire/tools/fortran_2003_flush_test.F new file mode 100644 index 00000000..02bb1323 --- /dev/null +++ b/wrfv2_fire/tools/fortran_2003_flush_test.F @@ -0,0 +1,14 @@ + PROGRAM fortran_2003_test + + IMPLICIT NONE + + REAL :: x + INTEGER :: i + + x = 1.e+10 + i = 1 + + WRITE (6,*) x,i + FLUSH ( 6 ) + + END PROGRAM fortran_2003_test diff --git a/wrfv2_fire/tools/gen_interp.c b/wrfv2_fire/tools/gen_interp.c index d5abc83e..a4a50422 100644 --- a/wrfv2_fire/tools/gen_interp.c +++ b/wrfv2_fire/tools/gen_interp.c @@ -68,6 +68,38 @@ int contains_tok( char *s1, char *s2, char *delims ) /* Had to increase size for SOA from 4*4096 to 4*7000 */ char halo_define[4*7000], halo_use[NAMELEN], halo_id[NAMELEN], x[NAMELEN] ; +/*KAL added this for vertical interpolation */ +/*DJW 131202 modified to create files required for vertical interpolation from parent to nest */ +int +gen_nest_v_interp ( char * dirname ) +{ + char * fnlst[] = { "nest_forcedown_interp_vert.inc", + "nest_interpdown_interp_vert.inc", + 0L }; + int down_path[] = { FORCE_DOWN , INTERP_DOWN }; + int ipath; + char **fnp ; char *fn; + char fname[NAMELEN]; + FILE *fp; + + for ( fnp=fnlst , ipath=0 ; *fnp ; fnp++, ipath++ ) + { + fn = *fnp; + if ( dirname == NULL ) return(1); + if ( strlen(dirname) > 0 ) + { sprintf(fname,"%s/%s",dirname,fn); } + else + { sprintf(fname,"%s",fn); } + if ((fp = fopen( fname, "w" )) == NULL ) return(1); + print_warning(fp,fname); + + gen_nest_interp2( fp, Domain.fields, NULL, down_path[ipath], (down_path[ipath]==FORCE_DOWN)?2:2 ); + + close_the_file(fp); + } + return(0); +} + int gen_nest_interp ( char * dirname ) { @@ -79,6 +111,8 @@ gen_nest_interp ( char * dirname ) char ** fnp ; char * fn ; char fname[NAMELEN] ; FILE * fp ; + + /*KAL FORCE_DOWN, etc are integers defined in registry.h, so down_path is an array of integers*/ for ( fnp = fnlst , ipath = 0 ; *fnp ; fnp++ , ipath++ ) { @@ -462,3 +496,149 @@ fprintf(fp,"ENDIF\n") ; /* in_use_from_config */ return(0) ; } +/* DJW 131202 Modified this to include only variables that have a vertical dimension + * (excluding soil layers and other extra dimensions) and inserts a different + * function call depending on variable staggering in z. */ +int +gen_nest_interp2 ( FILE * fp , node_t * node, char * fourdname, int down_path , int use_nest_time_level ) +{ + node_t *p, *p1 ; + int xdex, ydex, nest_mask ; + char ddim[3][2][NAMELEN] ; + char mdim[3][2][NAMELEN] ; + char pdim[3][2][NAMELEN] ; + char vname[NAMELEN], vname2[NAMELEN] ; + char tag[NAMELEN], tag2[NAMELEN] ; + char dexes[NAMELEN] ; + char ndexes[NAMELEN] ; + char *grid ; + char *colon,r[10],tx[80],temp[80],moredims[80] ; + int d ; + char zstag[NAMELEN]; + char fcn_name[NAMELEN]; + + for ( p1 = node ; p1 != NULL ; p1 = p1->next ) + { + + /* KAL-get the nest mask to see what path the variable is on */ + if ( p1->node_kind & FOURD ) + { + if ( p1->members->next ) { + nest_mask = p1->members->next->nest_mask ; + } else { + continue ; + } + } + else + { + nest_mask = p1->nest_mask ; + } + p = p1 ; + + + + if ( nest_mask & down_path ) + { + /*KAL get the dimensions of the variable and only work on ones with vertical extents*/ + if ( p1->node_kind & FOURD ) { + set_dim_strs2 ( p->members->next , ddim , mdim , pdim , "", 1 ) ; + } else { + set_dim_strs2 ( p , ddim , mdim , pdim , "", 1 ) ; + } + if ( !strcmp ( ddim[0][1], "kde") || + ( ddim[1][1], "kde") || + ( ddim[2][1], "kde")) { + + if ( p->ntl > 1 ) { sprintf(tag,"_2") ; sprintf(tag2,"_%d", use_nest_time_level) ; } + else { sprintf(tag,"") ; sprintf(tag2,"") ; } + + /* construct variable name */ + if ( p->node_kind & FOURD ) { + sprintf(x, "%s%s", p->name, tag ) ; + strcpy(moredims,"") ; + for ( d = 3 ; d < p->ndims ; d++ ) { + sprintf(temp,"idim%d",d-2) ; + strcat(moredims,",") ; strcat(moredims,temp) ; + } + strcat(moredims,",") ; + strcpy(dexes,"grid%sm31,grid%sm32,grid%sm33") ; + sprintf(vname,"%s%s(%s%sitrace)",p->name,tag,dexes,moredims) ; + strcpy(ndexes,"ngrid%sm31,ngrid%sm32,ngrid%sm33") ; + sprintf(vname2,"%s%s(%s%sitrace)",p->name,tag2,ndexes,moredims) ; + } + else + { + sprintf(vname,"%s%s",p->name,tag) ; + sprintf(vname2,"%s%s",p->name,tag2) ; + } + + if ( p1->node_kind & FOURD ) { + grid = "" ; + xdex = get_index_for_coord( p->members->next , COORD_X ) ; + ydex = get_index_for_coord( p->members->next , COORD_Y ) ; + } else { + grid = "grid%" ; + xdex = get_index_for_coord( p , COORD_X ) ; + ydex = get_index_for_coord( p , COORD_Y ) ; + } + + if ( p->stag_z ) { + strcpy( zstag, ".TRUE." ); + strcpy(fcn_name,"vert_interp_vert_nesting_w"); + } else { + strcpy( zstag, ".FALSE." ); + strcpy(fcn_name,"vert_interp_vert_nesting"); + } + + /* DJW 131202 The condition for the if-statement below is really really poorly written. + * I'm attempting to say "if the variable has a vertical dimension that spans multiple + * eta levels. Note that this is complicated because some variables have a vertical + * dimension that describes the number of soil levels they use. There are also other + * vertical dimensions that we need be wary of... hence my hack to make this work since + * at the moment all the variables I want to interpolate have kde points in the vertical!*/ + if ( strcmp("kde",ddim[1][1]) == 0 ) { + if ( p->node_kind & FOURD ) { + fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",p->name ) ; + for ( d = p->ndims-1 ; d >= 3 ; d-- ) { + strcpy(r,"") ; + range_of_dimension( r, tx, d, p, "config_flags%" ) ; + colon = index(tx,':') ; *colon = ',' ; + sprintf(temp,"idim%d",d-2) ; + strcat(moredims,",") ; strcat(moredims,temp) ; + fprintf(fp," DO %s = %s\n",temp,tx) ; + } + fprintf(fp,"IF ( SIZE( %s%s, %d ) * SIZE( %s%s, %d ) .GT. 1 ) THEN \n", p->name,tag,xdex+1,p->name,tag,ydex+1 ) ; + } else { + fprintf(fp,"IF ( SIZE( %s%s, %d ) * SIZE( %s%s, %d ) .GT. 1 ) THEN \n", grid,vname2,xdex+1,grid,vname2,ydex+1 ) ; + } + + fprintf(fp," CALL %s( &\n",fcn_name); + fprintf(fp," %s%s, & !CD field\n",grid,(p->node_kind & FOURD)?vname:vname2); + fprintf(fp," %s, %s, %s, %s, %s, %s, & !CD dims\n",ddim[0][0],ddim[0][1],ddim[1][0],ddim[1][1],ddim[2][0],ddim[2][1]); + fprintf(fp," %s, %s, %s, %s, %s, %s, & !CD dims\n",mdim[0][0],mdim[0][1],mdim[1][0],mdim[1][1],mdim[2][0],mdim[2][1]); + fprintf(fp," %s, %s, %s, MIN( (%s-1), %s ), %s, %s, & !CD dims\n",pdim[0][0],pdim[0][1],pdim[1][0],ddim[1][1],pdim[1][1],pdim[2][0],pdim[2][1]); + fprintf(fp," pgrid%%s_vert, pgrid%%e_vert, & !vertical dimension of the parent grid\n"); + if ( strcmp(zstag,".TRUE.") != 0 ) { + fprintf(fp," pgrid%%cf1, pgrid%%cf2, pgrid%%cf3, pgrid%%cfn, pgrid%%cfn1, & !coarse grid extrapolation constants\n"); + fprintf(fp," alt_u_c, alt_u_n ) !coordinates for parent and nest\n"); + } else { + fprintf(fp," alt_w_c, alt_w_n ) !coordinates for parent and nest\n"); + } + + if ( p->node_kind & FOURD ) + { + fprintf(fp,"ENDIF\n") ; + for ( d = p->ndims-1 ; d >= 3 ; d-- ) { + fprintf(fp,"ENDDO\n") ; + } + fprintf(fp,"ENDDO\n") ; + } else { + fprintf(fp,"ENDIF\n") ; /* in_use_from_config */ + } + } /* end of if variable has > 1 vertical level*/ + } /* end of if variable has vertical dimension*/ + } /* end of mask for down_path*/ + } /*end of loop over nodes*/ + return(0) ; +} + diff --git a/wrfv2_fire/tools/gen_wrf_io.c b/wrfv2_fire/tools/gen_wrf_io.c index cf8fea0f..a9dd1bad 100644 --- a/wrfv2_fire/tools/gen_wrf_io.c +++ b/wrfv2_fire/tools/gen_wrf_io.c @@ -230,8 +230,7 @@ if ( sw_new_bdys && ! sw_new_with_old_bdys ) { /* 20070207 */ } else { fprintf(fp," WRF_%s , & ! FieldType \n" , p->members->type->name ) ; } -fprintf(fp," grid%%communicator , & ! Comm\n") ; -fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; +fprintf(fp," grid , & ! grid\n") ; fprintf(fp," grid%%domdesc , & ! Comm\n") ; fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n") ; if ( sw_io == GEN_OUTPUT ) { @@ -412,8 +411,7 @@ fprintf(fp, "ENDDO\n") ; } else { fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; } - fprintf(fp," grid%%communicator , & ! Comm\n") ; - fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; + fprintf(fp," grid , & ! grid\n") ; fprintf(fp," grid%%domdesc , & ! Comm\n") ; fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n" ) ; fprintf(fp," '%s' , & ! MemoryOrder\n",memord ) ; @@ -462,8 +460,7 @@ fprintf(fp, "ENDDO\n") ; } else { fprintf(fp," WRF_%s , & ! FieldType \n" , p->type->name ) ; } - fprintf(fp," grid%%communicator , & ! Comm\n") ; - fprintf(fp," grid%%iocommunicator , & ! Comm\n") ; + fprintf(fp," grid , & ! grid\n") ; fprintf(fp," grid%%domdesc , & ! Comm\n") ; fprintf(fp," grid%%bdy_mask , & ! bdy_mask\n" ) ; fprintf(fp," dryrun , & ! flag\n" ) ; diff --git a/wrfv2_fire/tools/misc.c b/wrfv2_fire/tools/misc.c index 97148640..e0a00938 100644 --- a/wrfv2_fire/tools/misc.c +++ b/wrfv2_fire/tools/misc.c @@ -693,6 +693,19 @@ get_mask ( unsigned int * mask , int e ) } } +int dims_ikj_inner(node_t * field_struct) { + return field_struct->ndims>=3 + && !strcmp(field_struct->dims[0]->dim_name,"i") + && !strcmp(field_struct->dims[1]->dim_name,"k") + && !strcmp(field_struct->dims[2]->dim_name,"j"); +} + +int dims_ij_inner(node_t * field_struct) { + return field_struct->ndims>=2 + && !strcmp(field_struct->dims[0]->dim_name,"i") + && !strcmp(field_struct->dims[1]->dim_name,"j"); +} + #if 0 main() { diff --git a/wrfv2_fire/tools/protos.h b/wrfv2_fire/tools/protos.h index d3a207b0..976bdfea 100644 --- a/wrfv2_fire/tools/protos.h +++ b/wrfv2_fire/tools/protos.h @@ -129,7 +129,7 @@ int gen_scalar_tables_init ( FILE *); int gen_scalar_indices_init ( FILE *); int hash(char *); int gen_nest_interp1 ( FILE *, node_t *, char *, int, int ); -int gen_packs_halo ( FILE *fp , node_t *p, char *shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname ); +int gen_packs_halo ( FILE *fp , node_t *p, char *shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname, int always_interp_mp /* 1 for ARW, varies for NMM */ ); int gen_packs ( FILE *fp , node_t *p, int shw, int xy /* 0=y,1=x */ , int pu /* 0=pack,1=unpack */, char * packname, char * commname ); int gen_periods ( char * dirname , node_t * periods ); int gen_swaps ( char * dirname , node_t * swaps ); @@ -149,7 +149,8 @@ int gen_debug ( char * dirname ); void reset_mask ( unsigned int * mask , int e ) ; void set_mask ( unsigned int * mask , int e ) ; int get_mask ( unsigned int * mask , int e ) ; - +int dims_ikj_inner(node_t *); +int dims_ij_inner(node_t *); #define PROTOS_H #endif diff --git a/wrfv2_fire/tools/reg_parse.c b/wrfv2_fire/tools/reg_parse.c index 40f33ed6..78f5496f 100644 --- a/wrfv2_fire/tools/reg_parse.c +++ b/wrfv2_fire/tools/reg_parse.c @@ -452,6 +452,7 @@ reg_parse( FILE * infile ) if ( field_struct->ntl > max_time_level && field_struct->ntl <= 3 ) max_time_level = field_struct->ntl ; field_struct->stag_x = 0 ; field_struct->stag_y = 0 ; field_struct->stag_z = 0 ; + field_struct->mp_var = 0 ; field_struct->nmm_v_grid=0 ; field_struct->full_feedback = 0; for ( i = 0 ; i < strlen(tokens[FIELD_STAG]) ; i++ ) { if ( tolower(tokens[FIELD_STAG][i]) == 'x' || sw_all_x_staggered ) field_struct->stag_x = 1 ; @@ -461,6 +462,8 @@ reg_parse( FILE * infile ) field_struct->nmm_v_grid = 1 ; if ( tolower(tokens[FIELD_STAG][i]) == 'm' ) field_struct->mp_var = 1; + if ( tolower(tokens[FIELD_STAG][i]) == 'f' ) + field_struct->full_feedback = 1; } field_struct->restart = 0 ; field_struct->boundary = 0 ; @@ -586,10 +589,67 @@ reg_parse( FILE * infile ) } else { +#if NMM_CORE==1 + int found_interp=0; + if(field_struct->type && field_struct->type->name + && (x=='f'||x=='d'||x=='u'||x=='s')) { + if(dims_ij_inner(field_struct)) { + if(x=='u') { + if(!strcasecmp(field_struct->type->name,"real")) + found_interp=!!strcpy(fcn_name,"UpCopy"); + else if(!strcasecmp(field_struct->type->name,"integer")) + found_interp=!!strcpy(fcn_name,"UpINear"); + } else if(x=='d') { + if(!strcasecmp(field_struct->type->name,"real")) + found_interp=!!strcpy(fcn_name,"DownCopy"); + else if(!strcasecmp(field_struct->type->name,"integer")) + found_interp=!!strcpy(fcn_name,"DownINear"); + } else if(x=='f') { + if(!strcasecmp(field_struct->type->name,"real")) + found_interp=!!strcpy(fcn_name,"BdyCopy"); + else if(!strcasecmp(field_struct->type->name,"integer")) + found_interp=!!strcpy(fcn_name,"BdyINear"); + } else if(x=='s') { + if(!strcasecmp(field_struct->type->name,"real")) + found_interp=!!strcpy(fcn_name,"nmm_smoother_ijk"); + } + } else if(dims_ikj_inner(field_struct)) { + if(x=='d') { + if(!strcasecmp(field_struct->type->name,"real")) + found_interp=!!strcpy(fcn_name,"DownNearIKJ"); + } else if(x=='s') { + if(!strcasecmp(field_struct->type->name,"real")) + found_interp=!!strcpy(fcn_name,"nmm_smoother_ikj"); + } + } + } + if(!found_interp) { + fprintf(stderr,"ERROR: %s %c function invalid. You must specify the function to call in f=, d=, u= or s= when using the NMM cores. The ARW interp functions do not correctly handle the E grid.\n",tokens[FIELD_SYM],x); + exit(1); + } else { + /* warning should no longer be needed + fprintf(stderr,"WARNING: %c interpolation unspecified for %s. Using %s.\n", + x,tokens[FIELD_SYM],fcn_name); + */ + } +#else if ( x == 'f' || x == 'd' ) strcpy(fcn_name,"interp_fcn") ; if ( x == 'u' ) strcpy(fcn_name,"copy_fcn") ; if ( x == 's' ) strcpy(fcn_name,"smoother") ; +#endif } +#if NMM_CORE==1 + if(dims_ikj_inner(field_struct) && !strcasestr(fcn_name,"ikj")) { + fprintf(stderr,"ERROR: %s %c %s: you must use IKJ interpolators for IKJ arrays.\n", + tokens[FIELD_SYM],x,fcn_name); + exit(1); + } + if(dims_ij_inner(field_struct) && strcasestr(fcn_name,"ikj")) { + fprintf(stderr,"ERROR: %s %c %s: you cannot use IKJ interpolators for IJ arrays.\n", + tokens[FIELD_SYM],x,fcn_name); + exit(1); + } +#endif if ( x == 'f' ) { field_struct->nest_mask |= FORCE_DOWN ; strcpy(field_struct->force_fcn_name, fcn_name ) ; diff --git a/wrfv2_fire/tools/registry.c b/wrfv2_fire/tools/registry.c index 0ae3485a..84e7e9e9 100644 --- a/wrfv2_fire/tools/registry.c +++ b/wrfv2_fire/tools/registry.c @@ -201,6 +201,7 @@ main( int argc, char *argv[], char *env[] ) gen_wrf_io( "inc" ) ; gen_model_data_ord( "inc" ) ; gen_nest_interp( "inc" ) ; + gen_nest_v_interp( "inc") ; /*KAL added this for vertical interpolation*/ gen_scalar_derefs( "inc" ) ; gen_streams("inc") ; diff --git a/wrfv2_fire/tools/registry.h b/wrfv2_fire/tools/registry.h index 6cdd4df7..b0379a49 100644 --- a/wrfv2_fire/tools/registry.h +++ b/wrfv2_fire/tools/registry.h @@ -1,6 +1,6 @@ #ifndef REGISTRY_H #define NAMELEN 512 -#define NAMELEN_LONG 12500 /*changed from 8192 to 12500 by PNNL on 12/22/2010*/ +#define NAMELEN_LONG 125000 #define MAXDIMS 21 #define MAX_DYNCORES 50 /* ha ha, just kidding */ /* #define MAX_ARGLINE 175 WRF uses 128 by default, but the nested chem version hit the continuation line limit for efc so it had to be increased, wig 14-Oct-2004 */ From e2c38465f37f6dfa1cc38a883771e4e2bc8470d2 Mon Sep 17 00:00:00 2001 From: Jan Mandel Date: Sat, 23 Apr 2016 22:23:48 -0600 Subject: [PATCH 03/15] WRFV3.8 --- wrfv2_fire/Makefile | 64 +- wrfv2_fire/README | 22 +- wrfv2_fire/README.DA | 51 + wrfv2_fire/README.rsl_output | 2 +- wrfv2_fire/Registry/Registry.EM | 1 + wrfv2_fire/Registry/Registry.EM_CHEM | 1 + wrfv2_fire/Registry/Registry.EM_COMMON | 152 +- wrfv2_fire/Registry/Registry.EM_COMMON.var | 9 + wrfv2_fire/Registry/Registry.NMM | 122 +- wrfv2_fire/Registry/registry.chem | 68 +- wrfv2_fire/Registry/registry.diags | 43 +- wrfv2_fire/Registry/registry.elec | 58 + wrfv2_fire/Registry/registry.var | 24 +- wrfv2_fire/arch/Config_new.pl | 29 +- wrfv2_fire/arch/configure_new.defaults | 279 +- wrfv2_fire/arch/md_calls.inc | 144 +- wrfv2_fire/arch/postamble_new | 8 +- ...s_to_update_rconst_racm_soa_vbs_aqchem.inc | 1 + ...args_update_rconst_racm_soa_vbs_aqchem.inc | 1 + ...ecls_update_rconst_racm_soa_vbs_aqchem.inc | 1 + .../kpp_mechd_a_racm_soa_vbs_aqchem.inc | 1 + .../kpp_mechd_b_racm_soa_vbs_aqchem.inc | 1 + .../kpp_mechd_e_racm_soa_vbs_aqchem.inc | 1 + .../kpp_mechd_ia_racm_soa_vbs_aqchem.inc | 125 + .../kpp_mechd_ib_racm_soa_vbs_aqchem.inc | 1 + .../kpp_mechd_ibu_racm_soa_vbs_aqchem.inc | 1 + .../kpp_mechd_l_racm_soa_vbs_aqchem.inc | 12 + .../kpp_mechd_u_racm_soa_vbs_aqchem.inc | 16 + .../mechanisms/racm_soa_vbs_aqchem/atoms_red | 107 + .../racm_soa_vbs_aqchem.def | 57 + .../racm_soa_vbs_aqchem.eqn | 258 + .../racm_soa_vbs_aqchem.kpp | 10 + .../racm_soa_vbs_aqchem.spc | 98 + .../racm_soa_vbs_aqchem_wrfkpp.equiv | 9 + .../chem/KPP/util/write_decomp/write_decomp.F | 2 +- wrfv2_fire/chem/Makefile | 3 + wrfv2_fire/chem/aerosol_driver.F | 4 +- wrfv2_fire/chem/chem_driver.F | 42 +- wrfv2_fire/chem/chemics_init.F | 126 +- wrfv2_fire/chem/depend.chem | 22 +- wrfv2_fire/chem/dry_dep_driver.F | 30 +- wrfv2_fire/chem/emissions_driver.F | 13 +- wrfv2_fire/chem/module_aerosols_soa_vbs.F | 102 +- wrfv2_fire/chem/module_aerosols_sorgam.F | 589 +- wrfv2_fire/chem/module_bioemi_megan2.F | 4 +- wrfv2_fire/chem/module_chem_cup.F | 4 +- .../chem/module_chem_plumerise_scalar.F | 3 +- wrfv2_fire/chem/module_ctrans_grell.F | 11 +- wrfv2_fire/chem/module_data_uoc_wd.F | 48 + wrfv2_fire/chem/module_dep_simple.F | 5 +- wrfv2_fire/chem/module_dust_load.F | 1 + wrfv2_fire/chem/module_gocart_settling.F | 32 +- wrfv2_fire/chem/module_input_chem_data.F | 11 +- wrfv2_fire/chem/module_mixactivate_wrappers.F | 106 +- wrfv2_fire/chem/module_mosaic_driver.F | 253 + wrfv2_fire/chem/module_mosaic_therm.F | 5 +- wrfv2_fire/chem/module_mozcart_wetscav.F | 196 +- wrfv2_fire/chem/module_optical_averaging.F | 1095 +- wrfv2_fire/chem/module_prep_wetscav_sorgam.F | 1100 ++ wrfv2_fire/chem/module_qf03.F | 1103 +- wrfv2_fire/chem/module_soilpsd.F | 191 +- wrfv2_fire/chem/module_sorgam_aqchem.F | 58 +- wrfv2_fire/chem/module_uoc_dust.F | 690 +- wrfv2_fire/chem/module_uoc_dustwd.F | 1228 ++ wrfv2_fire/chem/module_wetscav_driver.F | 30 +- wrfv2_fire/compile | 43 +- wrfv2_fire/configure | 32 +- wrfv2_fire/dyn_em/couple_or_uncouple_em.F | 3 +- wrfv2_fire/dyn_em/depend.dyn_em | 1 + wrfv2_fire/dyn_em/interp_domain_em.F | 2 +- wrfv2_fire/dyn_em/module_advect_em.F | 256 + wrfv2_fire/dyn_em/module_bc_em.F | 50 +- .../dyn_em/module_big_step_utilities_em.F | 69 +- wrfv2_fire/dyn_em/module_diffusion_em.F | 2 +- wrfv2_fire/dyn_em/module_em.F | 5 +- .../dyn_em/module_first_rk_step_part1.F | 69 +- .../dyn_em/module_first_rk_step_part2.F | 3 +- wrfv2_fire/dyn_em/module_initialize_b_wave.F | 10 +- wrfv2_fire/dyn_em/module_initialize_convrad.F | 12 +- wrfv2_fire/dyn_em/module_initialize_fire.F | 10 +- .../dyn_em/module_initialize_grav2d_x.F | 12 +- .../dyn_em/module_initialize_heldsuarez.F | 8 +- .../dyn_em/module_initialize_hill2d_x.F | 8 +- wrfv2_fire/dyn_em/module_initialize_les.F | 79 +- .../dyn_em/module_initialize_quarter_ss.F | 10 +- wrfv2_fire/dyn_em/module_initialize_real.F | 950 +- wrfv2_fire/dyn_em/module_initialize_scm_xy.F | 10 +- .../dyn_em/module_initialize_seabreeze2d_x.F | 12 +- .../dyn_em/module_initialize_squall2d_x.F | 10 +- .../dyn_em/module_initialize_squall2d_y.F | 10 +- .../module_initialize_tropical_cyclone.F | 14 +- wrfv2_fire/dyn_em/module_sfs_nba.F | 2 +- wrfv2_fire/dyn_em/module_stoch.F | 9 +- wrfv2_fire/dyn_em/nest_init_utils.F | 384 +- wrfv2_fire/dyn_em/shift_domain_em.F | 18 +- wrfv2_fire/dyn_em/solve_em.F | 77 +- wrfv2_fire/dyn_em/start_em.F | 241 +- wrfv2_fire/dyn_exp/module_initialize_exp.F | 10 +- wrfv2_fire/dyn_exp/solve_exp.F | 10 +- wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F | 348 +- wrfv2_fire/dyn_nmm/depend.dyn_nmm | 10 +- wrfv2_fire/dyn_nmm/module_DIFFUSION_NMM.F | 10 +- wrfv2_fire/dyn_nmm/module_HIFREQ.F | 62 +- wrfv2_fire/dyn_nmm/module_IGWAVE_ADJUST.F | 2 +- wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F | 115 +- wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F | 42 +- wrfv2_fire/dyn_nmm/module_TERRAIN.F | 15 +- wrfv2_fire/dyn_nmm/module_initialize_real.F | 111 +- .../module_initialize_tropical_cyclone.F | 44 +- wrfv2_fire/dyn_nmm/module_membrane_mslp.F | 35 +- wrfv2_fire/dyn_nmm/module_swath.F | 2 +- wrfv2_fire/dyn_nmm/module_tracker.F | 6 +- wrfv2_fire/dyn_nmm/shift_domain_nmm.F | 22 +- wrfv2_fire/dyn_nmm/solve_nmm.F | 334 +- wrfv2_fire/dyn_nmm/start_domain_nmm.F | 374 +- wrfv2_fire/external/RSL_LITE/c_code.c | 24 +- wrfv2_fire/external/RSL_LITE/gen_comms.c | 95 +- wrfv2_fire/external/RSL_LITE/module_dm.F | 2558 ++- wrfv2_fire/external/RSL_LITE/rsl_bcast.c | 220 +- wrfv2_fire/external/RSL_LITE/rsl_lite.h | 6 + wrfv2_fire/external/RSL_LITE/rsl_malloc.c | 2 +- wrfv2_fire/external/RSL_LITE/tfp_tester.F | 2 +- wrfv2_fire/external/atm_ocn/mpi_more.F | 18 + .../external/esmf_time_f90/ESMF_TimeMgr.inc | 2 +- .../external/io_grib1/grib1_util/read_grib.c | 4 - wrfv2_fire/external/io_int/makefile | 2 +- wrfv2_fire/external/io_netcdf/wrf_io.F90 | 2 +- wrfv2_fire/external/io_pnetcdf/wrf_io.F90 | 6 +- wrfv2_fire/frame/Makefile | 2 + wrfv2_fire/frame/module_alloc_space.h | 7 +- wrfv2_fire/frame/module_clear_halos.F | 4 + wrfv2_fire/frame/module_configure.F | 96 +- wrfv2_fire/frame/module_dm_stubs.F | 24 + wrfv2_fire/frame/module_domain.F | 126 +- wrfv2_fire/frame/module_domain_type.F | 5 +- wrfv2_fire/frame/module_driver_constants.F | 6 +- wrfv2_fire/frame/module_integrate.F | 87 +- wrfv2_fire/frame/module_intermediate_nmm.F | 80 +- wrfv2_fire/frame/module_io.F | 14 +- wrfv2_fire/frame/module_io_quilt.F | 5171 +---- wrfv2_fire/frame/module_io_quilt_new.F | 5335 ++++++ wrfv2_fire/frame/module_io_quilt_old.F | 5194 +++++ wrfv2_fire/frame/module_wrf_error.F | 17 +- wrfv2_fire/hydro/.svn/all-wcprops | 17 - wrfv2_fire/hydro/.svn/entries | 117 - .../hydro/.svn/prop-base/configure.svn-base | 5 - .../.svn/prop-base/wrf_hydro_config.svn-base | 5 - .../hydro/.svn/text-base/configure.svn-base | 107 - .../.svn/text-base/wrf_hydro_config.svn-base | 28 - wrfv2_fire/hydro/CPL/.svn/all-wcprops | 5 - wrfv2_fire/hydro/CPL/.svn/entries | 31 - wrfv2_fire/hydro/CPL/WRF_cpl/.svn/all-wcprops | 29 - wrfv2_fire/hydro/CPL/WRF_cpl/.svn/entries | 164 - .../.svn/text-base/Makefile.cpl.svn-base | 9 - .../WRF_cpl/.svn/text-base/Makefile.svn-base | 34 - .../text-base/module_wrf_HYDRO.F.svn-base | 341 - .../.svn/text-base/wrf_drv_HYDRO.F.svn-base | 31 - wrfv2_fire/hydro/CPL/WRF_cpl/Makefile | 34 - wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl | 9 - .../hydro/CPL/WRF_cpl/module_wrf_HYDRO.F | 341 - wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F | 31 - wrfv2_fire/hydro/Data_Rec/.svn/all-wcprops | 47 - wrfv2_fire/hydro/Data_Rec/.svn/entries | 266 - .../Data_Rec/.svn/text-base/Makefile.svn-base | 28 - .../text-base/gw_field_include.inc.svn-base | 26 - .../module_GW_baseflow_data.F.svn-base | 9 - .../.svn/text-base/module_RT_data.F.svn-base | 10 - .../.svn/text-base/module_namelist.F.svn-base | 203 - .../.svn/text-base/namelist.inc.svn-base | 39 - .../.svn/text-base/rt_include.inc.svn-base | 178 - wrfv2_fire/hydro/Data_Rec/Makefile | 28 - .../hydro/Data_Rec/gw_field_include.inc | 26 - .../hydro/Data_Rec/module_GW_baseflow_data.F | 9 - wrfv2_fire/hydro/Data_Rec/module_RT_data.F | 10 - wrfv2_fire/hydro/Data_Rec/module_namelist.F | 203 - wrfv2_fire/hydro/Data_Rec/namelist.inc | 39 - wrfv2_fire/hydro/Data_Rec/rt_include.inc | 178 - wrfv2_fire/hydro/HYDRO_drv/.svn/all-wcprops | 17 - wrfv2_fire/hydro/HYDRO_drv/.svn/entries | 96 - .../.svn/text-base/Makefile.svn-base | 28 - .../text-base/module_HYDRO_drv.F.svn-base | 1071 -- wrfv2_fire/hydro/HYDRO_drv/Makefile | 28 - wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F | 1071 -- wrfv2_fire/hydro/MPP/.svn/all-wcprops | 23 - wrfv2_fire/hydro/MPP/.svn/entries | 130 - .../MPP/.svn/text-base/CPL_WRF.F.svn-base | 159 - .../MPP/.svn/text-base/Makefile.svn-base | 26 - .../MPP/.svn/text-base/mpp_land.F.svn-base | 1876 -- wrfv2_fire/hydro/MPP/CPL_WRF.F | 159 - wrfv2_fire/hydro/MPP/Makefile | 26 - wrfv2_fire/hydro/MPP/mpp_land.F | 1876 -- wrfv2_fire/hydro/Routing/.svn/all-wcprops | 71 - wrfv2_fire/hydro/Routing/.svn/entries | 402 - .../Routing/.svn/text-base/Makefile.svn-base | 53 - .../text-base/Noah_distr_routing.F.svn-base | 2768 --- .../text-base/module_GW_baseflow.F.svn-base | 856 - .../.svn/text-base/module_HYDRO_io.F.svn-base | 6340 ------- .../text-base/module_HYDRO_utils.F.svn-base | 414 - .../.svn/text-base/module_RT.F.svn-base | 927 - .../module_channel_routing.F.svn-base | 1329 -- .../module_date_utilities_rt.F.svn-base | 1040 - .../text-base/module_lsm_forcing.F.svn-base | 2276 --- .../module_noah_chan_param_init_rt.F.svn-base | 87 - .../.svn/text-base/rtFunction.F.svn-base | 222 - wrfv2_fire/hydro/Routing/Makefile | 53 - wrfv2_fire/hydro/Routing/Noah_distr_routing.F | 2768 --- wrfv2_fire/hydro/Routing/module_GW_baseflow.F | 856 - wrfv2_fire/hydro/Routing/module_HYDRO_io.F | 6340 ------- wrfv2_fire/hydro/Routing/module_HYDRO_utils.F | 414 - wrfv2_fire/hydro/Routing/module_RT.F | 927 - .../hydro/Routing/module_channel_routing.F | 1329 -- .../hydro/Routing/module_date_utilities_rt.F | 1040 - wrfv2_fire/hydro/Routing/module_lsm_forcing.F | 2276 --- .../Routing/module_noah_chan_param_init_rt.F | 87 - wrfv2_fire/hydro/Routing/rtFunction.F | 222 - wrfv2_fire/hydro/Run/.svn/all-wcprops | 17 - wrfv2_fire/hydro/Run/.svn/entries | 96 - .../Run/.svn/text-base/HYDRO.TBL.svn-base | 51 - .../.svn/text-base/hydro.namelist.svn-base | 105 - wrfv2_fire/hydro/Run/HYDRO.TBL | 51 - wrfv2_fire/hydro/Run/hydro.namelist | 105 - wrfv2_fire/hydro/arc/.svn/all-wcprops | 65 - wrfv2_fire/hydro/arc/.svn/entries | 368 - .../arc/.svn/text-base/Makefile.mpp.svn-base | 17 - .../arc/.svn/text-base/Makefile.seq.svn-base | 30 - .../text-base/macros.mpp.IBM.xlf90_r.svn-base | 37 - .../.svn/text-base/macros.mpp.gfort.svn-base | 33 - .../.svn/text-base/macros.mpp.ifort.svn-base | 36 - .../.svn/text-base/macros.mpp.linux.svn-base | 35 - .../text-base/macros.seq.IBM.xlf90_r.svn-base | 36 - .../.svn/text-base/macros.seq.gfort.svn-base | 34 - .../.svn/text-base/macros.seq.ifort.svn-base | 36 - .../.svn/text-base/macros.seq.linux.svn-base | 36 - wrfv2_fire/hydro/arc/Makefile.mpp | 17 - wrfv2_fire/hydro/arc/Makefile.seq | 30 - wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r | 37 - wrfv2_fire/hydro/arc/macros.mpp.gfort | 33 - wrfv2_fire/hydro/arc/macros.mpp.ifort | 36 - wrfv2_fire/hydro/arc/macros.mpp.linux | 35 - wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r | 36 - wrfv2_fire/hydro/arc/macros.seq.gfort | 34 - wrfv2_fire/hydro/arc/macros.seq.ifort | 36 - wrfv2_fire/hydro/arc/macros.seq.linux | 36 - wrfv2_fire/hydro/configure | 107 - wrfv2_fire/hydro/wrf_hydro_config | 28 - wrfv2_fire/inc/version_decl | 2 +- wrfv2_fire/main/Makefile | 16 +- wrfv2_fire/main/depend.common | 14 +- wrfv2_fire/main/ideal_nmm.F | 30 +- wrfv2_fire/main/module_wrf_top.F | 22 +- wrfv2_fire/main/ndown_em.F | 59 +- wrfv2_fire/main/nup_em.F | 2 +- wrfv2_fire/main/real_em.F | 25 +- wrfv2_fire/main/real_nmm.F | 26 +- wrfv2_fire/main/tc_em.F | 4 +- wrfv2_fire/main/wrf_SST_ESMF.F | 4 +- wrfv2_fire/phys/Makefile | 5 +- wrfv2_fire/phys/module_bl_acm.F | 21 +- wrfv2_fire/phys/module_bl_camuwpbl_driver.F | 4 +- wrfv2_fire/phys/module_bl_gfs.F | 24 +- wrfv2_fire/phys/module_bl_mynn.F | 4652 ++++- wrfv2_fire/phys/module_bl_shinhong.F | 1577 +- wrfv2_fire/phys/module_bl_ysu.F | 29 +- wrfv2_fire/phys/module_cu_camzm_driver.F | 21 +- wrfv2_fire/phys/module_cu_kf.F | 70 +- wrfv2_fire/phys/module_cu_kfcup.F | 20 +- wrfv2_fire/phys/module_cu_kfeta.F | 133 +- wrfv2_fire/phys/module_cu_mesosas.F | 2 +- wrfv2_fire/phys/module_cu_mskf.F | 157 +- wrfv2_fire/phys/module_cu_ntiedtke.F | 256 +- wrfv2_fire/phys/module_cu_osas.F | 2 +- wrfv2_fire/phys/module_cu_sas.F | 33 +- wrfv2_fire/phys/module_cumulus_driver.F | 42 +- wrfv2_fire/phys/module_data_gocart_dust.F | 66 +- wrfv2_fire/phys/module_diag_cl.F | 49 +- wrfv2_fire/phys/module_diag_misc.F | 12 +- wrfv2_fire/phys/module_diag_zld.F | 214 + wrfv2_fire/phys/module_diagnostics_driver.F | 78 +- wrfv2_fire/phys/module_fdda_psufddagd.F | 362 +- wrfv2_fire/phys/module_fddagd_driver.F | 174 +- wrfv2_fire/phys/module_fr_fire_phys.F | 12 +- wrfv2_fire/phys/module_fr_fire_util.F | 22 +- wrfv2_fire/phys/module_gfs_funcphys.F | 44 + wrfv2_fire/phys/module_microphysics_driver.F | 117 +- wrfv2_fire/phys/module_mp_HWRF.F | 22 + wrfv2_fire/phys/module_mp_fast_sbm.F | 4 +- wrfv2_fire/phys/module_mp_fer_hires.F | 3097 +++ wrfv2_fire/phys/module_mp_full_sbm.F | 12 +- wrfv2_fire/phys/module_mp_nssl_2mom.F | 1667 +- wrfv2_fire/phys/module_mp_thompson.F | 57 +- wrfv2_fire/phys/module_mp_wdm5.F | 5 +- wrfv2_fire/phys/module_mp_wdm6.F | 11 +- wrfv2_fire/phys/module_mp_wsm5.F | 4 +- wrfv2_fire/phys/module_mp_wsm6.F | 6 +- wrfv2_fire/phys/module_pbl_driver.F | 153 +- wrfv2_fire/phys/module_physics_init.F | 142 +- wrfv2_fire/phys/module_ra_aerosol.F | 110 +- wrfv2_fire/phys/module_ra_cam.F | 4 +- wrfv2_fire/phys/module_ra_cam_support.F | 67 +- wrfv2_fire/phys/module_ra_goddard.F | 16 +- wrfv2_fire/phys/module_ra_rrtmg_lw.F | 63 +- wrfv2_fire/phys/module_ra_rrtmg_lwf.F | 245 +- wrfv2_fire/phys/module_ra_rrtmg_sw.F | 80 +- wrfv2_fire/phys/module_ra_rrtmg_swf.F | 39 +- wrfv2_fire/phys/module_radiation_driver.F | 623 +- wrfv2_fire/phys/module_sf_3dpwp.F | 4 +- wrfv2_fire/phys/module_sf_clm.F | 14 +- wrfv2_fire/phys/module_sf_exchcoef.F | 224 + wrfv2_fire/phys/module_sf_gfdl.F | 110 +- wrfv2_fire/phys/module_sf_mynn.F | 518 +- wrfv2_fire/phys/module_sf_noah_seaice.F | 5 +- wrfv2_fire/phys/module_sf_noahdrv.F | 214 +- wrfv2_fire/phys/module_sf_noahlsm.F | 266 +- .../phys/module_sf_noahlsm_glacial_only.F | 3 +- wrfv2_fire/phys/module_sf_noahmp_glacier.F | 304 +- .../phys/module_sf_noahmp_groundwater.F | 12 +- wrfv2_fire/phys/module_sf_noahmpdrv.F | 317 +- wrfv2_fire/phys/module_sf_noahmplsm.F | 15825 ++++++++-------- wrfv2_fire/phys/module_sf_ocean_driver.F | 7 +- wrfv2_fire/phys/module_sf_oml.F | 19 +- wrfv2_fire/phys/module_sf_pxlsm.F | 31 +- wrfv2_fire/phys/module_sf_pxsfclay.F | 61 +- wrfv2_fire/phys/module_sf_ruclsm.F | 531 +- wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F | 54 +- wrfv2_fire/phys/module_sf_sfclayrev.F | 2 + wrfv2_fire/phys/module_sf_ssib.F | 8 +- wrfv2_fire/phys/module_sf_urban.F | 26 +- .../phys/module_shcu_camuwshcu_driver.F | 10 +- wrfv2_fire/phys/module_surface_driver.F | 165 +- wrfv2_fire/run/MPTABLE.TBL | 193 +- wrfv2_fire/run/README.namelist | 99 +- wrfv2_fire/run/URBPARM.TBL | 429 +- wrfv2_fire/run/URBPARM_UZE.TBL | 56 +- wrfv2_fire/run/VEGPARM.TBL | 136 +- wrfv2_fire/share/dfi.F | 4 +- wrfv2_fire/share/init_modules.F | 28 +- wrfv2_fire/share/input_wrf.F | 10 +- wrfv2_fire/share/interp_fcn.F | 24 +- wrfv2_fire/share/mediation_feedback_domain.F | 119 +- wrfv2_fire/share/mediation_force_domain.F | 119 +- wrfv2_fire/share/mediation_integrate.F | 414 +- wrfv2_fire/share/mediation_interp_domain.F | 64 +- wrfv2_fire/share/mediation_nest_move.F | 385 +- wrfv2_fire/share/mediation_wrfmain.F | 71 +- wrfv2_fire/share/module_check_a_mundo.F | 661 +- wrfv2_fire/share/module_interp_nmm.F | 4 +- wrfv2_fire/share/module_io_domain.F | 108 +- wrfv2_fire/share/module_model_constants.F | 4 +- wrfv2_fire/share/module_optional_input.F | 33 + wrfv2_fire/share/module_soil_pre.F | 2 - wrfv2_fire/share/output_wrf.F | 26 +- wrfv2_fire/share/set_timekeeping.F | 4 +- wrfv2_fire/share/sint.F | 147 +- wrfv2_fire/share/solve_interface.F | 20 +- wrfv2_fire/share/start_domain.F | 6 +- wrfv2_fire/share/track_input.F | 4 +- wrfv2_fire/share/wrf_bdyin.F | 6 +- wrfv2_fire/share/wrf_bdyout.F | 6 +- wrfv2_fire/share/wrf_fddaobs_in.F | 32 +- wrfv2_fire/share/wrf_restartin.F | 6 +- wrfv2_fire/share/wrf_restartout.F | 6 +- wrfv2_fire/share/wrf_timeseries.F | 10 + wrfv2_fire/share/wrf_tsin.F | 4 +- wrfv2_fire/test/em_convrad/run_me_first.csh | 5 +- wrfv2_fire/test/em_les/input_sounding.SGP | 737 + wrfv2_fire/test/em_les/namelist.input | 2 +- wrfv2_fire/test/em_les/namelist.input.SGP | 139 + .../test/em_les/namelist.input_shalconv | 2 +- wrfv2_fire/test/em_real/examples.namelist | 58 +- wrfv2_fire/test/em_real/namelist.input | 3 +- wrfv2_fire/test/em_real/namelist.input.4km | 3 +- wrfv2_fire/test/em_real/namelist.input.chem | 3 +- wrfv2_fire/test/em_real/namelist.input.diags | 3 +- wrfv2_fire/test/em_real/namelist.input.fire | 3 +- wrfv2_fire/test/em_real/namelist.input.global | 3 +- wrfv2_fire/test/em_real/namelist.input.jan00 | 3 +- wrfv2_fire/test/em_real/namelist.input.jun01 | 3 +- .../test/em_real/namelist.input.ndown_1 | 3 +- .../test/em_real/namelist.input.ndown_2 | 3 +- .../test/em_real/namelist.input.ndown_3 | 3 +- wrfv2_fire/test/em_real/namelist.input.volc | 3 +- wrfv2_fire/test/em_scm_xy/README.scm | 4 +- .../test/nmm_tropical_cyclone/namelist.input | 33 +- wrfv2_fire/tools/check_for_bad_includes.pl | 81 + wrfv2_fire/tools/commit_form.txt | 42 + wrfv2_fire/tools/data.h | 2 +- wrfv2_fire/tools/gen_allocs.c | 2 +- wrfv2_fire/tools/gen_scalar_indices.c | 29 +- wrfv2_fire/tools/reg_parse.c | 10 +- wrfv2_fire/tools/standard.c | 1 + 390 files changed, 48108 insertions(+), 65813 deletions(-) create mode 100644 wrfv2_fire/Registry/registry.elec create mode 100644 wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_args_to_update_rconst_racm_soa_vbs_aqchem.inc create mode 100644 wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_args_update_rconst_racm_soa_vbs_aqchem.inc create mode 100644 wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_decls_update_rconst_racm_soa_vbs_aqchem.inc create mode 100644 wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_a_racm_soa_vbs_aqchem.inc create mode 100644 wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_b_racm_soa_vbs_aqchem.inc create mode 100644 wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_e_racm_soa_vbs_aqchem.inc create mode 100644 wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ia_racm_soa_vbs_aqchem.inc create mode 100644 wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ib_racm_soa_vbs_aqchem.inc create mode 100644 wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ibu_racm_soa_vbs_aqchem.inc create mode 100644 wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_l_racm_soa_vbs_aqchem.inc create mode 100644 wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_u_racm_soa_vbs_aqchem.inc create mode 100755 wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/atoms_red create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.def create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.eqn create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.kpp create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.spc create mode 100644 wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem_wrfkpp.equiv create mode 100755 wrfv2_fire/chem/module_data_uoc_wd.F create mode 100644 wrfv2_fire/chem/module_prep_wetscav_sorgam.F create mode 100755 wrfv2_fire/chem/module_uoc_dustwd.F create mode 100644 wrfv2_fire/frame/module_io_quilt_new.F create mode 100644 wrfv2_fire/frame/module_io_quilt_old.F delete mode 100644 wrfv2_fire/hydro/.svn/all-wcprops delete mode 100644 wrfv2_fire/hydro/.svn/entries delete mode 100644 wrfv2_fire/hydro/.svn/prop-base/configure.svn-base delete mode 100644 wrfv2_fire/hydro/.svn/prop-base/wrf_hydro_config.svn-base delete mode 100644 wrfv2_fire/hydro/.svn/text-base/configure.svn-base delete mode 100644 wrfv2_fire/hydro/.svn/text-base/wrf_hydro_config.svn-base delete mode 100644 wrfv2_fire/hydro/CPL/.svn/all-wcprops delete mode 100644 wrfv2_fire/hydro/CPL/.svn/entries delete mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/all-wcprops delete mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/entries delete mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.cpl.svn-base delete mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.svn-base delete mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/module_wrf_HYDRO.F.svn-base delete mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/wrf_drv_HYDRO.F.svn-base delete mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/Makefile delete mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl delete mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F delete mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F delete mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/all-wcprops delete mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/entries delete mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/Makefile.svn-base delete mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/gw_field_include.inc.svn-base delete mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_GW_baseflow_data.F.svn-base delete mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_RT_data.F.svn-base delete mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_namelist.F.svn-base delete mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/namelist.inc.svn-base delete mode 100644 wrfv2_fire/hydro/Data_Rec/.svn/text-base/rt_include.inc.svn-base delete mode 100644 wrfv2_fire/hydro/Data_Rec/Makefile delete mode 100644 wrfv2_fire/hydro/Data_Rec/gw_field_include.inc delete mode 100644 wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F delete mode 100644 wrfv2_fire/hydro/Data_Rec/module_RT_data.F delete mode 100644 wrfv2_fire/hydro/Data_Rec/module_namelist.F delete mode 100644 wrfv2_fire/hydro/Data_Rec/namelist.inc delete mode 100644 wrfv2_fire/hydro/Data_Rec/rt_include.inc delete mode 100644 wrfv2_fire/hydro/HYDRO_drv/.svn/all-wcprops delete mode 100644 wrfv2_fire/hydro/HYDRO_drv/.svn/entries delete mode 100644 wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/Makefile.svn-base delete mode 100644 wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/module_HYDRO_drv.F.svn-base delete mode 100644 wrfv2_fire/hydro/HYDRO_drv/Makefile delete mode 100644 wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F delete mode 100644 wrfv2_fire/hydro/MPP/.svn/all-wcprops delete mode 100644 wrfv2_fire/hydro/MPP/.svn/entries delete mode 100644 wrfv2_fire/hydro/MPP/.svn/text-base/CPL_WRF.F.svn-base delete mode 100644 wrfv2_fire/hydro/MPP/.svn/text-base/Makefile.svn-base delete mode 100644 wrfv2_fire/hydro/MPP/.svn/text-base/mpp_land.F.svn-base delete mode 100644 wrfv2_fire/hydro/MPP/CPL_WRF.F delete mode 100644 wrfv2_fire/hydro/MPP/Makefile delete mode 100644 wrfv2_fire/hydro/MPP/mpp_land.F delete mode 100644 wrfv2_fire/hydro/Routing/.svn/all-wcprops delete mode 100644 wrfv2_fire/hydro/Routing/.svn/entries delete mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/Makefile.svn-base delete mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/Noah_distr_routing.F.svn-base delete mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_GW_baseflow.F.svn-base delete mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_HYDRO_io.F.svn-base delete mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_HYDRO_utils.F.svn-base delete mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_RT.F.svn-base delete mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_channel_routing.F.svn-base delete mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_date_utilities_rt.F.svn-base delete mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_lsm_forcing.F.svn-base delete mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/module_noah_chan_param_init_rt.F.svn-base delete mode 100644 wrfv2_fire/hydro/Routing/.svn/text-base/rtFunction.F.svn-base delete mode 100644 wrfv2_fire/hydro/Routing/Makefile delete mode 100644 wrfv2_fire/hydro/Routing/Noah_distr_routing.F delete mode 100644 wrfv2_fire/hydro/Routing/module_GW_baseflow.F delete mode 100644 wrfv2_fire/hydro/Routing/module_HYDRO_io.F delete mode 100644 wrfv2_fire/hydro/Routing/module_HYDRO_utils.F delete mode 100644 wrfv2_fire/hydro/Routing/module_RT.F delete mode 100644 wrfv2_fire/hydro/Routing/module_channel_routing.F delete mode 100644 wrfv2_fire/hydro/Routing/module_date_utilities_rt.F delete mode 100644 wrfv2_fire/hydro/Routing/module_lsm_forcing.F delete mode 100644 wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F delete mode 100644 wrfv2_fire/hydro/Routing/rtFunction.F delete mode 100644 wrfv2_fire/hydro/Run/.svn/all-wcprops delete mode 100644 wrfv2_fire/hydro/Run/.svn/entries delete mode 100644 wrfv2_fire/hydro/Run/.svn/text-base/HYDRO.TBL.svn-base delete mode 100644 wrfv2_fire/hydro/Run/.svn/text-base/hydro.namelist.svn-base delete mode 100644 wrfv2_fire/hydro/Run/HYDRO.TBL delete mode 100644 wrfv2_fire/hydro/Run/hydro.namelist delete mode 100644 wrfv2_fire/hydro/arc/.svn/all-wcprops delete mode 100644 wrfv2_fire/hydro/arc/.svn/entries delete mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/Makefile.mpp.svn-base delete mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/Makefile.seq.svn-base delete mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.IBM.xlf90_r.svn-base delete mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.gfort.svn-base delete mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.ifort.svn-base delete mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.linux.svn-base delete mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.IBM.xlf90_r.svn-base delete mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.gfort.svn-base delete mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.ifort.svn-base delete mode 100644 wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.linux.svn-base delete mode 100644 wrfv2_fire/hydro/arc/Makefile.mpp delete mode 100644 wrfv2_fire/hydro/arc/Makefile.seq delete mode 100644 wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r delete mode 100644 wrfv2_fire/hydro/arc/macros.mpp.gfort delete mode 100644 wrfv2_fire/hydro/arc/macros.mpp.ifort delete mode 100644 wrfv2_fire/hydro/arc/macros.mpp.linux delete mode 100644 wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r delete mode 100644 wrfv2_fire/hydro/arc/macros.seq.gfort delete mode 100644 wrfv2_fire/hydro/arc/macros.seq.ifort delete mode 100644 wrfv2_fire/hydro/arc/macros.seq.linux delete mode 100755 wrfv2_fire/hydro/configure delete mode 100755 wrfv2_fire/hydro/wrf_hydro_config create mode 100644 wrfv2_fire/phys/module_diag_zld.F create mode 100755 wrfv2_fire/phys/module_mp_fer_hires.F create mode 100755 wrfv2_fire/phys/module_sf_exchcoef.F create mode 100644 wrfv2_fire/test/em_les/input_sounding.SGP create mode 100644 wrfv2_fire/test/em_les/namelist.input.SGP create mode 100755 wrfv2_fire/tools/check_for_bad_includes.pl create mode 100644 wrfv2_fire/tools/commit_form.txt diff --git a/wrfv2_fire/Makefile b/wrfv2_fire/Makefile index a9bc14b9..8cbdfa50 100644 --- a/wrfv2_fire/Makefile +++ b/wrfv2_fire/Makefile @@ -98,10 +98,10 @@ wrf : framework_only if [ $(WRF_NMM_CORE) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" nmm_core ; fi if [ $(WRF_EXP_CORE) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" exp_core ; fi if [ $(WRF_HYDRO) -eq 1 ] ; then $(MAKE) MODULE_DIRS="$(ALL_MODULES)" wrf_hydro ; fi - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em em_wrf ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em em_wrf ) ( cd run ; /bin/rm -f wrf.exe ; ln -s ../main/wrf.exe . ) if [ $(ESMF_COUPLING) -eq 1 ] ; then \ - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em em_wrf_SST_ESMF ) ; \ + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em em_wrf_SST_ESMF ) ; \ fi @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -129,6 +129,14 @@ all_wrfvar : @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` +gen_be : + $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" ext + $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" toolsdir + ( cd var/build; make depend; $(MAKE) $(J) gen_be ) + @echo "build started: $(START_OF_COMPILE)" + @echo "build completed:" `date` + + ### 3.a. rules to build the framework and then the experimental core exp_wrf : configcheck @@ -136,7 +144,7 @@ exp_wrf : configcheck $(MAKE) MODULE_DIRS="$(ALL_MODULES)" toolsdir $(MAKE) MODULE_DIRS="$(ALL_MODULES)" framework $(MAKE) MODULE_DIRS="$(ALL_MODULES)" shared - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=exp exp_wrf ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=exp exp_wrf ) nmm_wrf : wrf @@ -148,7 +156,7 @@ em_fire : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=fire em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=fire em_ideal ) ( cd test/em_fire ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_fire ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_fire ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -165,7 +173,7 @@ em_quarter_ss : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=quarter_ss em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=quarter_ss em_ideal ) ( cd test/em_quarter_ss ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_quarter_ss ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_quarter_ss ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -208,7 +216,7 @@ em_squall2d_x : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=squall2d_x em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=squall2d_x em_ideal ) ( cd test/em_squall2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_squall2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_squall2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -243,7 +251,7 @@ em_squall2d_y : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=squall2d_y em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=squall2d_y em_ideal ) ( cd test/em_squall2d_y ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_squall2d_y ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_squall2d_y ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -276,7 +284,7 @@ em_b_wave : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=b_wave em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=b_wave em_ideal ) ( cd test/em_b_wave ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_b_wave ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_b_wave ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -309,7 +317,7 @@ em_les : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=les em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=les em_ideal ) ( cd test/em_les ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_les ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_les ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -342,7 +350,7 @@ em_seabreeze2d_x : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=seabreeze2d_x em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=seabreeze2d_x em_ideal ) ( cd test/em_seabreeze2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_seabreeze2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_seabreeze2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -373,7 +381,7 @@ em_seabreeze2d_x : wrf em_convrad : wrf @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=convrad em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=convrad em_ideal ) ( cd test/em_convrad ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_convrad ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_convrad ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -389,7 +397,7 @@ em_tropical_cyclone : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=tropical_cyclone em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=tropical_cyclone em_ideal ) ( cd test/em_tropical_cyclone ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_tropical_cyclone ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_tropical_cyclone ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -422,7 +430,7 @@ em_scm_xy : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=scm_xy em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=scm_xy em_ideal ) ( cd test/em_scm_xy ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_scm_xy ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_scm_xy ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -453,7 +461,7 @@ em_scm_xy : wrf convert_em : framework_only if [ $(WRF_CONVERT) -eq 1 ] ; then \ - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" convert_em ) ; \ + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" convert_em ) ; \ fi # Link wrf.exe and wrf_SST_ESMF.exe into @@ -467,10 +475,10 @@ em_real : wrf @/bin/rm -f ndown.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real em_real ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real em_real ) ( cd test/em_real ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) if [ $(ESMF_COUPLING) -eq 1 ] ; then \ - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real em_wrf_SST_ESMF ) ; \ + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=real em_wrf_SST_ESMF ) ; \ ( cd test/em_esmf_exp ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ; \ ( cd test/em_esmf_exp ; /bin/rm -f wrf_SST_ESMF.exe ; ln -s ../../main/wrf_SST_ESMF.exe . ) ; \ ( cd test/em_esmf_exp ; /bin/rm -f real.exe ; ln -s ../../main/real.exe . ) ; \ @@ -619,7 +627,7 @@ em_hill2d_x : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=hill2d_x em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=hill2d_x em_ideal ) ( cd test/em_hill2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_hill2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_hill2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -652,7 +660,7 @@ em_grav2d_x : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=grav2d_x em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=grav2d_x em_ideal ) ( cd test/em_grav2d_x ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_grav2d_x ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_grav2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -685,7 +693,7 @@ em_heldsuarez : wrf @/bin/rm -f ideal.exe > /dev/null 2>&1 @/bin/rm -f wrf.exe > /dev/null 2>&1 @ echo '--------------------------------------' - ( cd main ; $(MAKE) MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=heldsuarez em_ideal ) + ( cd main ; $(MAKE) RLFLAGS="$(RLFLAGS)" MODULE_DIRS="$(ALL_MODULES)" SOLVER=em IDEAL_CASE=heldsuarez em_ideal ) ( cd test/em_heldsuarez ; /bin/rm -f wrf.exe ; ln -s ../../main/wrf.exe . ) ( cd test/em_heldsuarez ; /bin/rm -f ideal.exe ; ln -s ../../main/ideal.exe . ) ( cd test/em_heldsuarez ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) @@ -845,7 +853,8 @@ nmm_real : nmm_wrf io : @ echo '--------------------------------------' ( cd tools ; $(MAKE) standard.exe ) - ( cd frame ; $(MAKE) io_only ) + ( $(MAKE) io_only ) + ( $(MAKE) MODULE_DIRS="$(ALL_MODULES)" toolsdir ) ( cd frame ; $(MAKE) module_driver_constants.o pack_utils.o module_machine.o module_internal_header_util.o wrf_debug.o ) ( cd frame ; $(AR) $(ARFLAGS) ../main/libwrflib.a module_driver_constants.o pack_utils.o module_machine.o \ module_internal_header_util.o module_wrf_error.o wrf_debug.o ) @@ -862,13 +871,13 @@ framework : CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR" diffwrf; \ - cd ../external/io_netcdf ; \ + cd ../io_netcdf ; \ $(MAKE) NETCDFPATH="$(NETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR"; \ - cd ../external/io_pio ; \ - $(MAKE) NETCDFPATH="$(PNETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \ + cd ../io_pio ; \ + echo SKIPPING PIO BUILD $(MAKE) NETCDFPATH="$(PNETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR"; \ @@ -878,15 +887,6 @@ framework : ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR" diffwrf ; \ cd ../../frame ) -# cd ../external/io_netcdf ; \ -# $(MAKE) NETCDFPATH="$(NETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \ -# CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ -# ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="$(AR)" ARFLAGS+"$(ARFLAGS)" diffwrf; \ -# cd ../io_int ; \ -# $(MAKE) SFC="$(SFC) $(FCBASEOPTS)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ -# TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ -# ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="$(AR)" "$(ARFLAGS)" diffwrf ; \ - shared : @ echo '--------------------------------------' if [ "`echo $(J) | sed -e 's/-j//g' -e 's/ \+//g'`" -gt "6" ] ; then \ diff --git a/wrfv2_fire/README b/wrfv2_fire/README index 815519c0..17d5db9b 100644 --- a/wrfv2_fire/README +++ b/wrfv2_fire/README @@ -1,4 +1,4 @@ -WRF Model Version 3.7 (April 17, 2015) +WRF Model Version 3.8 (April 8, 2016) http://wrf-model.org/users/users.php ------------------------ @@ -27,7 +27,20 @@ infringement actions. This is the main directory for the WRF Version 3 source code release. ====================================== -V3.7 Release Notes (4/17/15) (rev 8350): +V3.8 Release Notes (4/8/16) (rev 9345): +------------------- + +- For more information on WRF V3.8 release, visit WRF User's home pages + http://www2.mmm.ucar.edu/wrf/users/, and + http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide. + +V3.7.1 Release Notes (8/14/15) (rev 8584): +------------------- + +- For more information on WRF V3.7.1 release, visit WRF User's home pages + http://www2.mmm.ucar.edu/wrf/users/ + +V3.7 Release Notes (4/17/15) (rev 8345): ------------------- - For more information on WRF V3.7 release, visit WRF User's home pages @@ -343,7 +356,8 @@ What is in WRF V3? Grell-Freitas ensemble / Tiedtke (with shallow conv and momentum transport) / NSAS (with shallow conv and momentum transport) / SAS (with shallow conv for ARW) / Zhang-McFarlane (with momentum transport) ) / - New Tiedtke (with shallow conv and momentum transport) / Multi-scale KF (with shallow convection) + New Tiedtke (with shallow conv and momentum transport) / Multi-scale KF (with shallow convection) / + Kain-Fritsch Cumulus Potential (with shallow convection) * UW shallow convection / GRIMS shallow convection * planetary boundary layer (Yosei University / Mellor-Yamada-Janjic / ACM2 / QNSE-EDMF / MYNN / BouLac / UW / TEMF / Grenier-Bretherton-McCaa ) / Shin-Hong @@ -369,7 +383,7 @@ What is in WRF V3? * windfarm drag - Nudging: - * three-dimensional and surface analysis nudging + * three-dimensional, surface analysis nudging, and flux-adjusting surface data nudging * observation nudging * spectral nudging diff --git a/wrfv2_fire/README.DA b/wrfv2_fire/README.DA index 3a1c3490..9f60c14b 100644 --- a/wrfv2_fire/README.DA +++ b/wrfv2_fire/README.DA @@ -23,6 +23,57 @@ WRFDA, including infringement actions. This is the main directory for the WRFDA Version 3 source code release. ====================================== +V3.8 Release Notes : +------------------- + +Version 3.8 was released on April 8, 2016. + + For more information about WRFDA, visit the WRFDA Users home page + http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html + + New features: + + - A new observation type: AMSR2 radiance + - A new dynamic constraint for 3DVAR and Hybrid assimilation + + Updates: + + - The CV7 Background Error feature has been updated with major bug fixes + - Fixed problems with excessive noise in moisture field for some radar options (use_radar_rhv, use_radar_rqv) + - Improved assimilation of surface pressure obs for sfc_assi_options=1 + - Improved consistency of surface diagnostics (T2, Q2, U10, and V10) between WRFDA and WRF + - Updated libraries: + - RTTOV interface now supports RTTOV Version 11.1, 11.2, or 11.3 + - Many bug fixes and performance improvements + - WRFPLUS has been upgraded to V3.8 and is consistent with the released WRF version 3.8. + +See http://www2.mmm.ucar.edu/wrf/users/wrfda/updates-3.8.html for a full list of updates + +====================================== + +V3.7.1 Release Notes : +------------------- + +Version 3.7.1 was released on August 14, 2015. + + For more information about WRFDA, visit the WRFDA Users home page + http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html + + Updated features: + + - A number of issues have been fixed for this release, including: + - A fix for the new radar option "use_radar_rqv" + - A fix for crashes and/or incorrect results for 4DVAR when assimilating radiance data with + RTTOV with the option "rttov_emis_atlas_ir=1" + - Fixing display problems in OBSPROC for large numbers of observations + - Avoiding problems in OBSPROC with default observation error values + - An incorrect interpolation of U and V in new CV7 option in GEN_BE has been fixed + - WRFPLUS has been upgraded to V3.7.1 + +See http://www2.mmm.ucar.edu/wrf/users/wrfda/updates-3.7.1.html for a full list of updates + +====================================== + V3.7 Release Notes : ------------------- diff --git a/wrfv2_fire/README.rsl_output b/wrfv2_fire/README.rsl_output index f867e29e..53ae6f1d 100644 --- a/wrfv2_fire/README.rsl_output +++ b/wrfv2_fire/README.rsl_output @@ -12,7 +12,7 @@ Include -DNCEP_DEBUG_MULTIDIR in CFLAGS of configure.wrf to have the rsl.output files in separate task numbered directories. All of these directories will be in a single TASKOUTPUT directory under the run directory, i.e., /TASKOUTPUT/0000/rsl.error.0000 . -Include -DNCEP_DEBUG_GLOBALSTDOUT in CFLAGS of configure.wrf to have all rsl.error and rsl.out information written to +Include -DNCEP_DEBUG_MULTIDIR -DNCEP_DEBUG_GLOBALSTDOUT in CFLAGS of configure.wrf to have all rsl.error and rsl.out information written to the global stderr and stdout for the job (2 files). If you do not include either flag, the default is to have the rsl output/error data written to separate files in the diff --git a/wrfv2_fire/Registry/Registry.EM b/wrfv2_fire/Registry/Registry.EM index 22bf4d5f..f2e5491f 100644 --- a/wrfv2_fire/Registry/Registry.EM +++ b/wrfv2_fire/Registry/Registry.EM @@ -16,6 +16,7 @@ include registry.lake include registry.diags include registry.afwa include registry.sbm +include registry.elec include registry.bdy_perturb # added to output 5 for ESMF diff --git a/wrfv2_fire/Registry/Registry.EM_CHEM b/wrfv2_fire/Registry/Registry.EM_CHEM index 7706ad5a..5a377781 100644 --- a/wrfv2_fire/Registry/Registry.EM_CHEM +++ b/wrfv2_fire/Registry/Registry.EM_CHEM @@ -16,6 +16,7 @@ include registry.ssib include registry.sbm include registry.diags include registry.afwa +include registry.elec include registry.bdy_perturb state real landmask ij misc 1 - i012rh0d=(interp_fcnm_imask)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" diff --git a/wrfv2_fire/Registry/Registry.EM_COMMON b/wrfv2_fire/Registry/Registry.EM_COMMON index c252e063..bc008654 100644 --- a/wrfv2_fire/Registry/Registry.EM_COMMON +++ b/wrfv2_fire/Registry/Registry.EM_COMMON @@ -50,8 +50,8 @@ # table entries are of the form #
# -state real XLAT ij misc 1 - i0123rh01{23}du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" -state real XLONG ij misc 1 - i0123rh01{23}du=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLAT ij misc 1 - i0123rh01{22}{23}du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG ij misc 1 - i0123rh01{22}{23}du=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" # It is required that LU_INDEX appears before any variable that is # interpolated with a mask, as lu_index supplies that mask. @@ -92,7 +92,7 @@ state real xlat_gc ij dyn_em 1 - i1 "XLAT_M" state real xlong_gc ij dyn_em 1 - i1 "XLONG_M" "longitude, positive east" "degrees" state real ht_gc ij dyn_em 1 - i1 "HGT_M" "topography elevation" "m" state real var_sso ij dyn_em 1 - i01hr "var_sso" "variance of subgrid-scale orography" "m2" -state real lap_hgt ij dyn_em 1 - hr "lap_hgt" "Laplacian of orography" "m" +state real lap_hgt ij dyn_em 1 - r "lap_hgt" "Laplacian of orography" "m" state real tsk_gc ij dyn_em 1 - i1 "SKINTEMP" "skin temperature" "K" state real tavgsfc ij dyn_em 1 - i1 "TAVGSFC" "daily mean of surface air temperature" "K" state real tmn_gc ij dyn_em 1 - i1 "SOILTEMP" "annual mean deep soil temperature" "K" @@ -160,7 +160,9 @@ state real min_p ij dyn_em 1 - i0d "MIN_P" state real hgtmaxw ij dyn_em 1 - i1 "HGTMAXW" "Height of the max wind speed" "m" state real hgttrop ij dyn_em 1 - i1 "HGTTROP" "Height of the tropopause" "m" state real pmaxw ij dyn_em 1 - i1 "PMAXW" "Pressure of the max wind speed" "Pa" +state real pmaxwnn ij dyn_em 1 - i1 "PMAXWNN" "PMAXW, nearest neighbor interp" "Pa" state real ptrop ij dyn_em 1 - i1 "PTROP" "Pressure of the tropopause" "Pa" +state real ptropnn ij dyn_em 1 - i1 "PTROPNN" "PTROP, nearest neighbor interp" "Pa" state real tmaxw ij dyn_em 1 - i1 "TMAXW" "Temperature of the max wind speed" "K" state real ttrop ij dyn_em 1 - i1 "TTROP" "Temperature of the tropopause" "K" state real umaxw ij dyn_em 1 X i1 "UMAXW" "U-component of the max wind speed" "m s-1" @@ -387,15 +389,15 @@ state real p_hyd ikj dyn_em 1 - irh " state real p_hyd_w ikj dyn_em 1 Z r "p_hyd_w" "hydrostatic pressure at full levels" "Pa" # 2m and 10m output diagnostics -state real Q2 ij misc 1 - irh0{23}du "Q2" "QV at 2 M" "kg kg-1" -state real T2 ij misc 1 - i01rh0{23}du "T2" "TEMP at 2 M" "K" +state real Q2 ij misc 1 - irh0{22}{23}du "Q2" "QV at 2 M" "kg kg-1" +state real T2 ij misc 1 - i01rh0{22}{23}du "T2" "TEMP at 2 M" "K" state real TH2 ij misc 1 - irhdu "TH2" "POT TEMP at 2 M" "K" state real PSFC ij misc 1 - i01rhdu "PSFC" "SFC PRESSURE" "Pa" # these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling # with wave model, only if compiled with -DMCELIO, JM 2003/05/29 -state real U10 ij misc 1 - irh01du "U10" "U at 10 M" "m s-1" -state real V10 ij misc 1 - irh01du "V10" "V at 10 M" "m s-1" +state real U10 ij misc 1 - irh01{22}{23}du "U10" "U at 10 M" "m s-1" +state real V10 ij misc 1 - irh01{22}{23}du "V10" "V at 10 M" "m s-1" # LPI state real LPI ij misc 1 - rhdu "LPI" "Lightning Potential Index" "m^2 s-2" @@ -529,6 +531,9 @@ state real qvolg ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" state real qvolh ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QVHAIL" "Hail Particle Volume" "m(3) kg(-1)" +state real qrimef ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QRIMEF" "rime factor * qi" "kg kg-1" + state real - ikjftb dfi_scalar 1 - - - state real dfi_qndrop ikjftb dfi_scalar 1 - \ @@ -736,7 +741,7 @@ state integer IFNDALBSI - misc 1 - ir "F state integer IFNDSNOWSI - misc 1 - ir "FNDSNOWSI" "SNOWSI_LOGICAL" state integer IFNDICEDEPTH - misc 1 - ir "FNDICEDEPTH" "ICEDEPTH_LOGICAL" # SKIN SST -state real SSTSK ij misc 1 - rhd=(interp_mask_field:lu_index,iswater) "SSTSK" "SKIN SEA SURFACE TEMPERATURE" "K" +state real SSTSK ij misc 1 - rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SSTSK" "SKIN SEA SURFACE TEMPERATURE" "K" state real lake_depth ij misc 1 - i012rd=(interp_mask_water_field:lu_index,islake) "lake_depth" "lake depth" "m" state real DTW ij misc 1 - r "DTW" "WARM LAYER TEMP DIFF" "C" # Ocean surface currents @@ -871,7 +876,7 @@ state real FM ij misc 1 - - "FM" state real FH ij misc 1 - - "FH" "INTEGRATED FUNCTION FOR HEAT" "" i1 real WSPD ij misc 1 - - "WSPD" "Wind speed" "m s-1" i1 real GZ1OZ0 ij misc 1 - - "GZ1OZ0" "LOG OF Z1 over Z0" "" -i1 real BR ij misc 1 - - "BR" "Bulk Richardson" "" +state real BR ij misc 1 - - "BR" "Bulk Richardson" "" state real ZOL ij misc 1 - - "ZOL" "z/L" "" # ysupbl variables for grims shallow convection @@ -939,7 +944,6 @@ state real wm_temf ij misc 1 - rh "wm # MYNN PBL variables state real qke_adv ikjftb scalar 1 - i0rusdf=(bdy_interp:dt) "qke_adv" "twice TKE from MYNN" "m2 s-2" state real qke ikj misc 1 - irh "qke" "twice TKE from MYNN" "m2 s-2" -#state real EL_MYNN ikj misc 1 Z h "el_mynn" "MIXING LENGTH FROM MYNN" "m" state real qSHEAR ikj misc 1 Z h "qSHEAR" "TKE Production - shear" "m2 s-2" state real qBUOY ikj misc 1 Z h "qBUOY" "TKE Production - buoyancy" "m2 s-2" state real qDISS ikj misc 1 Z h "qDISS" "TKE dissipation" "m2 s-2" @@ -953,6 +957,13 @@ state real ch ij misc 1 - - "ch #state real K_m ikj misc 1 - - "K_m" "EXCHANGE COEFFICIENT for momentum " #state real K_h ikj misc 1 - - "K_h" "EXCHANGE COEFFICIENT for heat " #state real K_q ikj misc 1 - - "K_q" "EXCHANGE COEFFICIENT for qke " +#MYNN-EDMF VARIABLES +state real edmf_a ikj misc 1 - h "edmf_a" "EDMF relative updraft area - moist updrafts" "-" +state real edmf_w ikj misc 1 - h "edmf_w" "EDMF vertical velocity - mean moist updrafts" "m s-1" +state real edmf_thl ikj misc 1 - h "edmf_thl" "EDMF thetaL - mean moist updrafts" "K" +state real edmf_qt ikj misc 1 - h "edmf_qt" "EDMF qt - mean moist updrafts" "kg kg-1" +state real edmf_ent ikj misc 1 - h "edmf_ent" "EDMF entrainment - mean moist updrafts" "m-1" +state real edmf_qc ikj misc 1 - h "edmf_qc" "EDMF qc - mean moist updrafts" "kg kg-1" #FogDES variables state real fgdp ij misc 1 - - "fgdp" "Accumulated fog deposition" "mm" @@ -1278,6 +1289,9 @@ state real SNOWNCV ij misc 1 - r "S state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" state real HAILNCV ij misc 1 - r "HAILNCV" "TIME-STEP NONCONVECTIVE HAIL" "mm" state real refl_10cm ikj dyn_em 1 - hdu "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" +# LIGHTNING NUDGING +#state real ltg_dat ij misc 1 - r "ltg_dat" "gridded lightning data" "Flash per xkm x xkm per LAD_INT sec" +# END LIGHTNING NUDGING state real NCA ij misc 1 - r "NCA" "COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME" "" state integer LOWLYR ij misc 1 - - "LOWLYR" "INDEX OF LOWEST MODEL LAYER ABOVE THE GROUND IN BMJ SCHEME" "" state real MASS_FLUX ij misc 1 - r "MASS_FLUX" "DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME" "mb hour-1" @@ -1285,6 +1299,11 @@ state real MASS_FLUX ij misc 1 - r "M state real cldfra_dp ikj misc 1 - r "CLDFRA_DP" "DEEP CONVECTIVE CLOUD FRACTION FROM KF" "" state real cldfra_sh ikj misc 1 - r "CLDFRA_SH" "SHALLOW CONVECTIVE CLOUD FRACTION FROM KF" "" state real w_up ikj misc 1 - rdu "W_UP" "EFFECTIVE SUBGRID VELOCITY FROM KF" "m s-1" +state real udr_kf ikj misc 1 - rh "UDR_KF" "UPDRAFT DETRAINMENT RATE FROM KF" "kg s-1" +state real ddr_kf ikj misc 1 - rh "DDR_KF" "DOWNDRAFT DETRAINMENT RATE FROM KF" "kg s-1" +state real uer_kf ikj misc 1 - rh "UER_KF" "UPDRAFT ENTRAINMENT RATE FROM KF" "kg s-1" +state real der_kf ikj misc 1 - rh "DER_KF" "DOWNDRAFT ENTRAINMENT RATE FROM KF" "kg s-1" +state real timec_kf ij misc 1 - rh "TIMEC_KF" "CONVECTIVE TIMESCALE FROM MSKF" "s" state real apr_gr ij misc 1 - r "APR_GR" "PRECIP FROM CLOSURE OLD_GRELL" "mm hour-1" state real apr_w ij misc 1 - r "APR_W" "PRECIP FROM CLOSURE W" "mm hour-1" state real apr_mc ij misc 1 - r "APR_MC" "PRECIP FROM CLOSURE KRISH MV" "mm hour-1" @@ -1317,6 +1336,7 @@ state real GD_CLOUD_A ikj misc 1 - r "G state real GD_CLOUD2_A ikj misc 1 - r "GD_CLOUD2_A" "taveragd cloud ice mix ratio in GD" "kg kg-1" state real QC_CU ikj misc 1 - r "QC_CU" "CLOUD WATER MIXING RATIO FROM A CU SCHEME" "kg kg-1" state real QI_CU ikj misc 1 - r "QI_CU" "CLOUD ICE MIXUNG RATIO FROM A CU SCHEME" "kg kg-1" +state real QC_BL ikj misc 1 - r "QC_BL" "CLOUD WATER MIXING RATIO IN PBL schemes" "kg kg-1" state integer STEPAVE_COUNT - misc 1 - r "STEPAVE_COUNT" "time steps contained in averages for convective transport" "" # @@ -1330,6 +1350,7 @@ state real RTHRATENLW ikj misc 1 - r "R state real RTHRATENSW ikj misc 1 - r "RTHRATSW" "UNCOUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION" "K s-1" state real CLDFRA ikj misc 1 - rh "CLDFRA" "CLOUD FRACTION" "" state real CLDFRA_OLD ikj misc 1 - r "CLDFRA_OLD" "previous time level cldfra" "" +state real CLDFRA_BL ikj misc 1 - - "CLDFRA_BL" "CLOUD FRACTION pbl" "" state real CLDT ij misc 1 - - "CFRACT" "TOTAL CLOUD FRACTION" "" #state real CLDL ij misc 1 - - "CFRACL" "LOW CLOUD FRACTION (ETA GREATER THAN 0.69)" "" #state real LWP ij misc 1 - - "LWP" "LIQUID CLOUD WATER PATH" "kg m-2" @@ -1338,7 +1359,7 @@ state real SWDOWNC ij misc 1 - - "S state real GSW ij misc 1 - rd "GSW" "NET SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" state real GLW ij misc 1 - rhd "GLW" "DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" state real SWNORM ij misc 1 - rhd "SWNORM" "NORMAL SHORT WAVE FLUX AT GROUND SURFACE (SLOPE-DEPENDENT)" "W m-2" -state real diffuse_frac ij misc 1 - rhd "DIFFUSE_FRAC" "DIFFUSE FRACTION OF SURFACE SHORTWAVE IRRADIANCE" "" +state real diffuse_frac ij misc 1 - rd "DIFFUSE_FRAC" "DIFFUSE FRACTION OF SURFACE SHORTWAVE IRRADIANCE" "" # WRF-Solar state real swddir ij misc 1 - rd "SWDDIR" "Shortwave surface downward direct irradiance" "W m-2" "" state real swddni ij misc 1 - rd "SWDDNI" "Shortwave surface downward direct normal irradiance" "W m-2" "" @@ -1356,6 +1377,8 @@ state real angexp2d ij misc 1 - i{15}r "ANGEXP2 state real aerssa2d ij misc 1 - i{15}r "AERSSA2D" "Aerosol single-scattering albedo" "" state real aerasy2d ij misc 1 - i{15}r "AERASY2D" "Aerosol asymmetry factor" "" state real aod5503d ikj misc 1 - r "AOD5503D" "3D aerosol optical depth at 550 nm" "" +state real taod5503d ikj misc 1 - r "TAOD5503D" "3D aerosol optical depth at 550 nm (MP=28)" "" +state real taod5502d ij misc 1 - rh "TAOD5502D" "2D aerosol optical depth at 550 nm (MP=28)" "" # CLWRF-WRF4G state real T2MIN ij misc 1 - rh3 "T2MIN" "MINIMUM TEMPERATURE AT 2M HEIGHT IN DIAGNOSTIC OUTPUT INTERVAL" "K" @@ -1506,6 +1529,8 @@ state real lfmassxy ij - 1 - i02rhd=(interp_mask_fiel state real rtmassxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "rtmass" "mass of fine roots" "g/m2" state real stmassxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "stmass" "stem mass" "g/m2" state real woodxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "wood" "mass of wood" "g/m2" +state real grainxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "grain" "mass of grain" "g/m2" +state real gddxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "gdd" "growing degree days" "" state real stblcpxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "stblcp" "stable carbon pool" "g/m2" state real fastcpxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "fastcp" "short-lived carbon" "g/m2" state real xsaixy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "xsai" "stem area index" "-" @@ -1759,6 +1784,15 @@ state real ODIS_NDG_NEW ij misc 1 - i9r state real SN_NDG_NEW ij misc 1 - i9r "SN_NDG_NEW" "NEW Snow Water Equivalent" "mm" state real SN_NDG_OLD ij misc 1 - i9r "SN_NDG_OLD" "OLD Snow Water Equivalent" "mm" +#FASDAS +state real SDA_HFX ij misc 1 - r "SDA_HFX" "THETA TENDENCY AT THE FIRST MODEL LAYER" "K s-1" +state real SDA_QFX ij misc 1 - r "SDA_QFX" "MOISTURE TENDENCY AT THE FIRST MODEL LAYER" "kg kg-1 s-1" +state real QNORM ij misc 1 - r "QNORM" "NORMALIZED QV FACTOR" "dimless" +state real HFX_BOTH ij misc 1 - rh "HFX_BOTH" "UPWARD HEAT FLUX AT THE SURFACE" "W m-2" +state real QFX_BOTH ij misc 1 - rh "QFX_BOTH" "UPWARD MOISTURE FLUX AT THE SURFACE" "kg m-2 s-1" +state real HFX_FDDA ikj misc 1 - rh "HFX_FDDA" "PSEUDO RADIATIVE HEAT FLUX FROM TEMPERATURE FDDA" "W m-2" +# + # flag for nest movement state logical moved - misc 1 - - @@ -1790,9 +1824,9 @@ state real HAIL_MAX2D ij misc 1 - rh02 state real max_cfl - misc 1 - - "max_cfl" "maximum CFL value in grid at a time" "-" -state real prec_acc_c ij misc 1 - rh "prec_acc_c" "ACCUMULATED CUMULUS PRECIPITATION OVER prec_acc_dt PERIODS OF TIME" "mm" -state real prec_acc_nc ij misc 1 - rh "prec_acc_nc" "ACCUMULATED GRID SCALE PRECIPITATION OVER prec_acc_dt PERIODS OF TIME" "mm" -state real snow_acc_nc ij misc 1 - rh "snow_acc_nc" "ACCUMULATED SNOW WATER EQUIVALENT OVER prec_acc_dt PERIODS OF TIME" "mm" +state real prec_acc_c ij misc 1 - rhdu "prec_acc_c" "ACCUMULATED CUMULUS PRECIPITATION OVER prec_acc_dt PERIODS OF TIME" "mm" +state real prec_acc_nc ij misc 1 - rhdu "prec_acc_nc" "ACCUMULATED GRID SCALE PRECIPITATION OVER prec_acc_dt PERIODS OF TIME" "mm" +state real snow_acc_nc ij misc 1 - rhdu "snow_acc_nc" "ACCUMULATED SNOW WATER EQUIVALENT OVER prec_acc_dt PERIODS OF TIME" "mm" # Placeholder for decoupled advective tendency diagnostics for non-chem state real - ikjf advh_t 1 - - - @@ -1915,10 +1949,10 @@ rconfig integer dfi_bckstop_minute namelist,dfi_control 1 00 rh rconfig integer dfi_bckstop_second namelist,dfi_control 1 00 rh "dfi_bckstop_second" "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS" # Domains -rconfig integer time_step namelist,domains 1 - ih "time_step" +rconfig integer time_step namelist,domains 1 -1 ih "time_step" rconfig integer time_step_fract_num namelist,domains 1 0 ih "time_step_fract_num" rconfig integer time_step_fract_den namelist,domains 1 1 ih "time_step_fract_den" -rconfig integer time_step_dfi namelist,domains 1 - ih "time_step_dfi" +rconfig integer time_step_dfi namelist,domains 1 -1 ih "time_step_dfi" rconfig integer min_time_step namelist,domains max_domains -1 h "min_time_step" rconfig integer min_time_step_den namelist,domains max_domains 0 h "min_time_step denominator" @@ -1947,8 +1981,9 @@ rconfig integer num_metgrid_soil_levels namelist,domains 1 4 rconfig real p_top_requested namelist,domains 1 5000 irh "p_top_requested" "Pa" "" rconfig logical interp_theta namelist,domains 1 .false. irh "interp_theta" "inside real, vertically interpolate theta (T) or temperature (F)" "" rconfig integer interp_type namelist,domains 1 2 irh "interp_type" "1=interp in pressure, 2=interp in LOG pressure" "" -rconfig integer vert_refine_method namelist,domains max_domains 0 irh "vert_refine_method" "0=no vertical nesting, 1=integer refinement, 2=native WRF" "" -rconfig integer vert_refine_fact namelist,domains 1 1 irh "vertical refinment factor for ndown or for vertical nesting in a concurrent run" "" "" +rconfig integer rebalance namelist,domains 1 0 irh "rebalance" "0=no; 1=yes, always; 2=yes, but only when doing vertical nesting" +rconfig integer vert_refine_method namelist,domains max_domains 0 irh "vert_refine_method" "0=no vertical nesting, 1=integer refinement, 2=use specified eta levels or compute_eta routine" "" +rconfig integer vert_refine_fact namelist,domains 1 1 irh "vertical refinment factor for ndown, not used for concurrent vertical grid nesting" "" "" rconfig integer extrap_type namelist,domains 1 2 irh "extrap_type" "1= use 2 lowest levels, 2=constant" "" rconfig integer t_extrap_type namelist,domains 1 2 irh "t_extrap_type" "1=isothermal, 2=6.5 K/km, 3=adiabatic" "" rconfig integer hypsometric_opt namelist,domains 1 2 irh "hypsometric_opt" "Z relates P, 1=linearly, 2=LOG-linearly" "" @@ -1962,6 +1997,8 @@ rconfig real zap_close_levels namelist,domains 1 500 rconfig real maxw_horiz_pres_diff namelist,domains 1 5000 irh "maxw_horiz_pres_diff" "pressure limit (Pa), when horiz diff exceeded do not use max_wind level in real" rconfig real trop_horiz_pres_diff namelist,domains 1 5000 irh "trop_horiz_pres_diff" "pressure limit (Pa), when horiz diff exceeded do not use tropopause level in real" rconfig real maxw_above_this_level namelist,domains 1 30000 irh "maxw_above_this_level" "pressure limit (Pa), only use the max_wind data at or above this level" +rconfig integer use_maxw_level namelist,domains 1 0 irh "use_maxw_level" "0=no/1=yes: in real, use the input metgrid U, V, T, GHT at the level of max wind speed" +rconfig integer use_trop_level namelist,domains 1 0 irh "use_trop_level" "0=no/1=yes: in real, use the input metgrid U, V, T, GHT at the tropopause level" rconfig logical sfcp_to_sfcp namelist,domains 1 .false. irh "sfcp_to_sfcp" "T/F use incoming sfc pres to compute new sfc pres" "flag" rconfig logical adjust_heights namelist,domains 1 .false. irh "adjust_heights" "T/F adjust pressure level input to match 500 mb height" "flag" rconfig logical smooth_cg_topo namelist,domains 1 .false. irh "smooth_cg_topo" "T/F smooth CG topo on boundarries" "flag" @@ -1976,6 +2013,7 @@ rconfig real qv_max_value namelist,domains 1 3 rconfig real qv_min_p_safe namelist,domains 1 110000 irh "qv_min_p_safe" "Threshhold pressure, Qv < flag set to value" "Pa" rconfig real qv_min_flag namelist,domains 1 1.E-6 irh "qv_min_flag" "Qv flag for min" "kg kg{-1}" rconfig real qv_min_value namelist,domains 1 1.E-6 irh "qv_min_value" "Qv value for min" "kg kg{-1}" +rconfig integer ideal_init_method namelist,domains 1 1 irh "ideal_init_method" "inside start_em: 1=alb from phb, 2=alb from t_init" " " rconfig real dx namelist,domains max_domains 200 h "dx" "X HORIZONTAL RESOLUTION" "METERS" rconfig real dy namelist,domains max_domains 200 h "dy" "Y HORIZONTAL RESOLUTION" "METERS" rconfig integer grid_id namelist,domains max_domains 1 irh "id" "" "" @@ -2071,6 +2109,18 @@ rconfig real nssl_cnos namelist,physics max_domains 3.e rconfig real nssl_rho_qh namelist,physics max_domains 500. rh "Graupel particle density" "" "" rconfig real nssl_rho_qhl namelist,physics max_domains 900. rh "Hail particle density" "" "" rconfig real nssl_rho_qs namelist,physics max_domains 100. rh "Snow particle density" "" "" + + +# Lightning Qv Nudging +rconfig integer nudge_lightning namelist,physics max_domains 0 rh "flag for lightning Qv nudging" "" "" +rconfig integer nudge_light_times namelist,physics max_domains 0 rh "start time in sec (domain relative) for lightning Qv nudging" "" "" +rconfig integer nudge_light_timee namelist,physics max_domains 7200 rh "end time in sec (domain relative) for lightning Qv nudging" "" "" +rconfig integer nudge_light_int namelist,physics max_domains 600 rh "time interval in sec of input lightning data files" "" "" +rconfig character path_to_files namelist,physics 1 "~/WRFV3/" rh "path on local machine of input lightning data files" "" "" + + + + rconfig integer gsfcgce_hail namelist,physics 1 0 rh "gsfcgce select hail/graupel" "" "" rconfig integer gsfcgce_2ice namelist,physics 1 0 rh "gsfcgce select 2ice/3ice" "" "" rconfig integer progn namelist,physics max_domains 0 rh "progn" "" "" @@ -2090,13 +2140,22 @@ rconfig integer bl_mynn_tkebudget namelist,physics max_domains 0 rconfig integer ysu_topdown_pblmix namelist,physics 1 0 rh "ysu_topdown_pblmix" "" "" rconfig integer shinhong_tke_diag namelist,physics max_domains 0 rh "shinhong_tke_diag" "" "" rconfig logical bl_mynn_tkeadvect namelist,physics max_domains .false. rh "bl_mynn_tkeadvect" "" "" -rconfig integer bl_mynn_cloudpdf namelist,physics 1 0 irh "bl_mynn_cloudpdf" "" "" +rconfig integer bl_mynn_cloudpdf namelist,physics 1 2 irh "bl_mynn_cloudpdf" "" "" +rconfig integer bl_mynn_mixlength namelist,physics 1 1 irh "bl_mynn_mixlength" "0:original,1:RAP/HRRR,2:new blending&cloud mix length" "" +rconfig integer bl_mynn_edmf namelist,physics max_domains 0 irh "bl_mynn_edmf" "0:off,1:activate mass-flux in mynn" "" +rconfig integer bl_mynn_edmf_mom namelist,physics max_domains 1 irh "bl_mynn_edmf_mom" "0:off,1:activate mass-flux transport of momentum" "" +rconfig integer bl_mynn_edmf_tke namelist,physics max_domains 0 irh "bl_mynn_edmf_tke" "0:off,1:activate mass-flux transport of tke" "" +rconfig integer bl_mynn_edmf_part namelist,physics max_domains 0 irh "bl_mynn_edmf_part" "0:off,1:activate areal partitioning of ed and mf" "" +rconfig integer bl_mynn_cloudmix namelist,physics max_domains 1 irh "bl_mynn_cloudmix" "0:off,1:activate mixing of all cloud species" "" +rconfig integer bl_mynn_mixqt namelist,physics max_domains 0 irh "bl_mynn_mixqt" "0:mix moisture species separate,1: mix total water" "" +rconfig integer icloud_bl namelist,physics 1 1 irh "icloud_bl" "0:no subgrid cloud-radiation coupling,1:activated" "" rconfig integer mfshconv namelist,physics max_domains 1 rh "mfshconv" "To activate mass flux scheme with qnse, 1=true or 0=false" "" rconfig integer sf_urban_physics namelist,physics max_domains 0 rh "sf_urban_physics" "activate urban model 0=no, 1=Noah_UCM 2=BEP_UCM" "" rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" rconfig integer shcu_physics namelist,physics max_domains 0 rh "shcu_physics" "" "" rconfig integer cu_diag namelist,physics max_domains 0 rh "cu_diag" "additional t-averaged stuff for cuphys" "" +rconfig integer kf_edrates namelist,physics max_domains 0 rh "kf_edrates" "output entrainment/detrainment rates and convective timescale for KF schemes" "" rconfig integer kfeta_trigger namelist,physics 1 1 rh "KFETA Trigger function" "" "" rconfig integer nsas_dx_factor namelist,physics 1 0 rh "NSAS DX-dependent option" "" "" rconfig real CUDT namelist,physics max_domains 0 h "CUDT" "" "" @@ -2106,7 +2165,7 @@ rconfig integer IFSNOW namelist,physics 1 1 rconfig integer ICLOUD namelist,physics 1 1 irh "ICLOUD" "" "" rconfig integer ideal_xland namelist,physics 1 1 rh "IDEAL_XLAND" "land=1(def), water=2, for ideal cases with no land-use" "" rconfig real swrad_scat namelist,physics 1 1 irh "SWRAD_SCAT" "SCATTERING FACTOR IN SWRAD" "" -rconfig integer surface_input_source namelist,physics 1 1 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=dominant cateogry from metgrid" "" +rconfig integer surface_input_source namelist,physics 1 3 irh "surface_input_source" "1=static (fractional), 2=time dependent (dominant), 3=dominant cateogry from metgrid" "" rconfig integer num_soil_layers namelist,physics 1 5 irh "num_soil_layers" "" "" rconfig integer maxpatch namelist,physics 1 10 irh "maxpatch" "" "" rconfig integer num_snow_layers namelist,physics 1 3 irh "num_snow_layers" "" "" @@ -2129,7 +2188,7 @@ rconfig integer clos_choice namelist,physics 1 0 rconfig integer imomentum namelist,physics 1 0 rh "imomentum" "momentum transport in G3 scheme" "" rconfig integer ishallow namelist,physics 1 0 rh "ishallow" "shallow convection in G3 scheme" "" rconfig real convtrans_avglen_m namelist,physics 1 30 rh "convtrans_avglen_m" "averaging time for convective transport output variables (minutes)" "" -rconfig integer num_land_cat namelist,physics 1 24 - "num_land_cat" "" "" +rconfig integer num_land_cat namelist,physics 1 21 - "num_land_cat" "" "" rconfig integer num_soil_cat namelist,physics 1 16 - "num_soil_cat" "" "" rconfig integer mp_zero_out namelist,physics 1 0 - "mp_zero_out" "microphysics fields set to zero 0=no action taken, 1=all fields but Qv, 2=all fields including Qv" "flag" rconfig real mp_zero_out_thresh namelist,physics 1 1.e-8 - "mp_zero_out_thresh" "minimum threshold for non-Qv moist fields, below are set to zero" "kg/kg" @@ -2142,6 +2201,7 @@ rconfig logical usemonalb namelist,physics 1 .fa rconfig logical rdmaxalb namelist,physics 1 .true. h "rdmaxalb" "false set it to table values" "" rconfig logical rdlai2d namelist,physics 1 .false. h "rdlai2d" "false set it to table values" "" rconfig logical ua_phys namelist,physics 1 .false. h "ua_phys" "activate UA Noah changes" "" +rconfig integer opt_thcnd namelist,physics 1 1 h "opt_thcnd" "thermal conductivity option in Noah LSM" "" rconfig integer co2tf namelist,physics 1 1 - "co2tf" "GFDL radiation co2 flag" "" rconfig integer ra_call_offset namelist,physics 1 0 - "ra_call_offset" "radiation call offset in timesteps (-1=old, 0=new offset)" "" rconfig real cam_abs_freq_s namelist,physics 1 21600. - "cam_abs_freq_s" "CAM radiation frequency for clear-sky longwave calculations" "s" @@ -2149,7 +2209,7 @@ rconfig integer levsiz namelist,physics 1 1 rconfig integer paerlev namelist,physics 1 1 - "paerlev" "Number of aerosol data levels for CAM radiation (29)" "" rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" -rconfig integer lagday namelist,physics 1 1 - "lagday" "" "" +rconfig integer lagday namelist,physics 1 150 - "lagday" "" "" rconfig integer no_src_types namelist,physics 1 1 - "no_src_types" "Number of aerosoal types from EC (6)" "" rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" rconfig integer o3input namelist,physics 1 2 - "o3input" "ozone input for RRTMG for CG domain: original = 0; CAM ozone = 2" "" @@ -2168,13 +2228,13 @@ rconfig logical cu_rad_feedback namelist,physics max_domains .f #BSINGH - added shallowcu_forced_ra, numBins, thBinSize, rBinSize, minDeepFreq, minShallowFreq, shcu_aerosols_opt for CuP scheme -rconfig logical shallowcu_forced_ra namelist,physics max_domains .true. - "force radiative impact of shallow Cu (KF-Eta and KF-CuP)" +rconfig logical shallowcu_forced_ra namelist,physics max_domains .false. - "force radiative impact of shallow Cu (KF-Eta and KF-CuP)" rconfig integer numBins namelist,physics max_domains 1 - "number of bins to use in the CuP PDF" rconfig real thBinSize namelist,physics max_domains 1 - "bin size of theta bins of PDF" rconfig real rBinSize namelist,physics max_domains 1 - "bin size of mixing ratio bins of PDF" rconfig real minDeepFreq namelist,physics max_domains 1 - "Minimum frequency required for deep convection" rconfig real minShallowFreq namelist,physics max_domains 1 - "Minimum frequency required for shallow convection" -rconfig integer shcu_aerosols_opt namelist,physics max_domains 0 - "aerosols in shcu: 0=none, 1=prescribed, 2=prognostic, 10=prognostic and do aerosol processing" "" +rconfig integer shcu_aerosols_opt namelist,physics max_domains 0 - "aerosols in shcu: 0=none, 2=prognostic " "" rconfig integer ICLOUD_CU derived 1 0 - "ICLOUD_CU" "" "" rconfig integer pxlsm_smois_init namelist,physics max_domains 1 irh "PXLSM_SMOIS_INIT" "Soil moisture initialization option 0-From analysis 1-From MAVAIL" "" @@ -2185,6 +2245,7 @@ rconfig integer tracercall namelist,physics 1 0 rconfig real OMDT namelist,physics 1 1 h "OMDT" "Timestep of ocean model" "s" rconfig real oml_hml0 namelist,physics 1 50 h "oml_hml0" "oml initial mixed layer depth value" "m" rconfig real oml_gamma namelist,physics 1 0.14 h "oml_gamma" "oml deep water lapse rate" "K m-1" +rconfig real oml_relaxation_time namelist,physics 1 0. h "oml_relaxation_time" "Relaxation time of mixed layer ocean model back to original values" "s" rconfig integer isftcflx namelist,physics 1 0 h "isftcflx" "switch to control sfc fluxes" "" rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" rconfig real shadlen namelist,physics 1 25000. - "shadow_length" "maximum length of orographic shadow" "m" @@ -2216,6 +2277,7 @@ rconfig integer scalar_pblmix namelist,physics max_domains 0 rconfig integer tracer_pblmix namelist,physics max_domains 1 h "mix 4d tracer variables with pbl scheme 0=no 1=yes" "" rconfig logical use_aero_icbc namelist,physics 1 .false. rh "use_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero" "logical flag" rconfig logical use_rap_aero_icbc namelist,physics 1 .false. r "use_rap_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero from RAP" "logical flag" +rconfig integer use_mp_re namelist,physics 1 1 h "use_mp_re" "use effective radii computed in some mp schemes in RRTMG" "flag" # The following two options are hooked into various microphysics schemes to allow for ensemble perturbations of CCN and hail/graupel PSDs - GAC (AFWA) rconfig real ccn_conc namelist,physics 1 1.0E8 h "ccn_conc" "CCN concentration" "# m-3" @@ -2234,6 +2296,8 @@ rconfig integer opt_alb namelist,noah_mp 1 2 h " rconfig integer opt_snf namelist,noah_mp 1 1 h "opt_snf" "rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah)" "" rconfig integer opt_tbot namelist,noah_mp 1 2 h "opt_tbot" "lower boundary of soil temperature (1->zero-flux; 2->Noah)" "" rconfig integer opt_stc namelist,noah_mp 1 1 h "opt_stc" "soil/snow temperature time scheme 1->semi-implicit; 2->full-implicit (original Noah)" "" +rconfig integer opt_gla namelist,noah_mp 1 1 h "opt_gla" "glacier treatment option 1->includes phase change; 2->slab ice (Noah)" "" +rconfig integer opt_rsf namelist,noah_mp 1 1 h "opt_rsf" "surface evaporation resistance option" "" rconfig real WTDDT namelist,physics max_domains 30. h "wtddt" "minutes between calls to lateral hydro" "" # For WRF Hydro @@ -2269,11 +2333,14 @@ rconfig real gq_sfc namelist,fdda max_domains 0 rconfig real gph namelist,fdda max_domains 0 rh "grid_fdda" "" "" rconfig real dtramp_min namelist,fdda 1 0 h "grid_fdda" "" "" rconfig integer if_ramping namelist,fdda 1 0 h "grid_fdda" "" "" -rconfig real rinblw namelist,fdda 1 0 h "grid_fdda" "" "" +rconfig real rinblw namelist,fdda max_domains 0 h "grid_fdda" "" "" rconfig integer xwavenum namelist,fdda max_domains 0 rh "grid_fdda" "top wave number to nudge in x direction" "" rconfig integer ywavenum namelist,fdda max_domains 0 rh "grid_fdda" "top wave number to nudge in y direction" "" rconfig integer pxlsm_soil_nudge namelist,fdda max_domains 0 rh "pxlsm_soil_nudge" "nudge pxlsm soil" "" +#FASDAS +rconfig integer fasdas derived max_domains 0 - "fasdas" "" "" + #Observational Nudging rconfig integer obs_nudge_opt namelist,fdda max_domains 0 rh "obs_nudge_opt" "Obs-nudging flag for domain" "" rconfig integer max_obs namelist,fdda 1 0 h "max_obs" "Maximum number of observations" "" @@ -2451,7 +2518,7 @@ rconfig logical open_ye namelist,bdy_control max_domains .f rconfig logical polar namelist,bdy_control max_domains .false. rh "polar" "" "" rconfig logical nested namelist,bdy_control max_domains .false. rh "nested" "" "" rconfig real spec_exp namelist,bdy_control 1 0. irh "spec_exp" "" "" -rconfig integer spec_bdy_final_mu namelist,bdy_control 1 0 rh "call spec_bdy_final for mu" "" "" +rconfig integer spec_bdy_final_mu namelist,bdy_control 1 1 rh "call spec_bdy_final for mu" "" "" rconfig integer real_data_init_type namelist,bdy_control 1 1 irh "real_data_init_type" "REAL DATA INITIALIZATION OPTIONS: 1=SI, 2=MM5, 3=GENERIC" "PRE-PROCESSOR TYPES" rconfig logical have_bcs_moist namelist,bdy_control max_domains .false. rh "have_bcs_moist" "" "" rconfig logical have_bcs_scalar namelist,bdy_control max_domains .false. rh "have_bcs_scalar" "" "" @@ -2522,23 +2589,24 @@ package kesslerscheme mp_physics==1 - moist:qv,qc package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg package wsm3scheme mp_physics==3 - moist:qv,qc,qr;state:re_cloud,re_ice,re_snow package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs;state:re_cloud,re_ice,re_snow -package etamp_hr mp_physics==5 - moist:qv,qc,qr,qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy +package fer_mp_hires mp_physics==5 - moist:qv,qc,qr,qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy +package fer_mp_hires_advect mp_physics==15 - moist:qv,qc,qr,qi;scalar:qrimef package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg;state:re_cloud,re_ice,re_snow package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr;state:re_cloud,re_ice,re_snow package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh -package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng +package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qns,qnr,qng;state:rqrcuten,rqscuten,rqicuten package cammgmpscheme mp_physics==11 - moist:qv,qc,qi,qr,qs;scalar:qnc,qni,qnr,qns;state:rh_old_mp,lcd_old_mp,cldfra_old_mp,cldfra_mp,cldfra_mp_all,cldfra_conv,cldfrai,cldfral,turbtype3d,smaw3d,wsedl3d,icwmrdp3d,dp3d,shfrc3d,dlf,dlf2,tke_pbl,lradius,iradius #package milbrandt3mom mp_physics==12 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qzr,qzi,qzs,qzg,qzh package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs;state:rimi package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;scalar:qnn,qnc,qnr;state:re_cloud,re_ice,re_snow -package nssl_2mom mp_physics==17 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qndrop,qnr,qni,qns,qng,qnh,qvolg,qvolh;state:re_cloud,re_ice,re_snow +package nssl_2mom mp_physics==17 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qndrop,qnr,qni,qns,qng,qnh,qvolg,qvolh;state:re_cloud,re_ice,re_snow package nssl_2momccn mp_physics==18 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qndrop,qnr,qni,qns,qng,qnh,qvolg,qvolh;state:re_cloud,re_ice,re_snow package nssl_1mom mp_physics==19 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qvolg package nssl_1momlfo mp_physics==21 - moist:qv,qc,qr,qi,qs,qg package nssl_2momg mp_physics==22 - moist:qv,qc,qr,qi,qs,qg;scalar:qndrop,qnr,qni,qns,qng,qvolg;state:re_cloud,re_ice,re_snow -package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow,qnwfa2d +package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow,qnwfa2d,taod5503d,taod5502d package etampnew mp_physics==95 - moist:qv,qc,qr,qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy package radar_refl compute_radar_ref==1 - state:refl_10cm,refd_max @@ -2550,7 +2618,7 @@ package kesslerscheme_dfi mp_physics_dfi==1 - dfi_moist:dfi package linscheme_dfi mp_physics_dfi==2 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package wsm3scheme_dfi mp_physics_dfi==3 - dfi_moist:dfi_qv,dfi_qc,dfi_qr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package etamp_hr_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt +package fer_mp_hires_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow @@ -2560,8 +2628,8 @@ package morr_two_moment_dfi mp_physics_dfi==10 - dfi_moist:dfi #package sbu_ylinscheme_dfi mp_physics==13 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:rimi package wdm5scheme_dfi mp_physics_dfi==14 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wdm6scheme_dfi mp_physics_dfi==16 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package nssl_2mom_dfi mp_physics_dfi==17 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnc,dfi_qndrop,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg,dfi_qvolh;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package nssl_2mom_dficcn mp_physics_dfi==18 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qnn,dfi_qnc,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package nssl_2mom_dfi mp_physics_dfi==17 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg,dfi_qvolh;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package nssl_2mom_dficcn mp_physics_dfi==18 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qndrop,dfi_qnn,dfi_qnr,dfi_qni,dfi_qns,dfi_qng,dfi_qnh,dfi_qvolg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package nssl_1mom_dfi mp_physics_dfi==19 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qvolg package nssl_1momlfo_dfi mp_physics_dfi==21 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow @@ -2595,7 +2663,7 @@ package sfclayrevscheme sf_sfclay_physics==1 - - package myjsfcscheme sf_sfclay_physics==2 - state:tke_pbl package gfssfcscheme sf_sfclay_physics==3 - - package qnsesfcscheme sf_sfclay_physics==4 - - -package mynnsfcscheme sf_sfclay_physics==5 - state:sh3d,tsq,qsq,cov +package mynnsfcscheme sf_sfclay_physics==5 - - package pxsfcscheme sf_sfclay_physics==7 - - package temfsfcscheme sf_sfclay_physics==10 - state:wm_temf package idealscmsfcscheme sf_sfclay_physics==89 - - @@ -2608,7 +2676,7 @@ package bep_bemscheme sf_urban_physics==3 - state:a_u_bep package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn,smcrel package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag,soilt1,rhosnf,snowfallac,precipfr -package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy,fdepthxy,areaxy,rivercondxy,riverbedxy,eqzwt,pexpxy,qrfxy,qrfsxy,qspringxy,qspringsxy,qslatxy,stepwtd +package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy,fdepthxy,areaxy,rivercondxy,riverbedxy,eqzwt,pexpxy,qrfxy,qrfsxy,qspringxy,qspringsxy,qslatxy,stepwtd,gddxy,grainxy package clmscheme sf_surface_physics==5 - state:numc,nump,sabv,sabg,lwup,lhsoi,lhveg,lhtran,snl,snowdp,wtc,wtp,h2osno,t_grnd,t_veg,h2ocan,h2ocan_col,t2m_max,t2m_min,t2clm,t_ref2m,h2osoi_liq_s1,h2osoi_liq_s2,h2osoi_liq_s3,h2osoi_liq_s4,h2osoi_liq_s5,h2osoi_liq1,h2osoi_liq2,h2osoi_liq3,h2osoi_liq4,h2osoi_liq5,h2osoi_liq6,h2osoi_liq7,h2osoi_liq8,h2osoi_liq9,h2osoi_liq10,h2osoi_ice_s1,h2osoi_ice_s2,h2osoi_ice_s3,h2osoi_ice_s4,h2osoi_ice_s5,h2osoi_ice1,h2osoi_ice2,h2osoi_ice3,h2osoi_ice4,h2osoi_ice5,h2osoi_ice6,h2osoi_ice7,h2osoi_ice8,h2osoi_ice9,h2osoi_ice10,t_soisno_s1,t_soisno_s2,t_soisno_s3,t_soisno_s4,t_soisno_s5,t_soisno1,t_soisno2,t_soisno3,t_soisno4,t_soisno5,t_soisno6,t_soisno7,t_soisno8,t_soisno9,t_soisno10,dzsnow1,dzsnow2,dzsnow3,dzsnow4,dzsnow5,snowrds1,snowrds2,snowrds3,snowrds4,snowrds5,t_lake1,t_lake2,t_lake3,t_lake4,t_lake5,t_lake6,t_lake7,t_lake8,t_lake9,t_lake10,h2osoi_vol1,h2osoi_vol2,h2osoi_vol3,h2osoi_vol4,h2osoi_vol5,h2osoi_vol6,h2osoi_vol7,h2osoi_vol8,h2osoi_vol9,h2osoi_vol10,albedosubgrid,lhsubgrid,hfxsubgrid,lwupsubgrid,q2subgrid,sabvsubgrid,sabgsubgrid,nrasubgrid,swupsubgrid package pxlsmscheme sf_surface_physics==7 - state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old,vegf_px,imperv,canfra package ssibscheme sf_surface_physics==8 - state:ssib_fm,ssib_fh,ssib_cm,ssibxdd,ssib_br,ssib_lhf,ssib_shf,ssib_ghf,ssib_egs,ssib_eci,ssib_ect,ssib_egi,ssib_egt,ssib_sdn,ssib_sup,ssib_ldn,ssib_lup,ssib_wat,ssib_shc,ssib_shg,ssib_lai,ssib_vcf,ssib_z00,ssib_veg,isnow,swe,snowden,snowdepth,tkair,dzo1,wo1,tssn1,tssno1,bwo1,bto1,cto1,fio1,flo1,bio1,blo1,ho1,dzo2,wo2,tssn2,tssno2,bwo2,bto2,cto2,fio2,flo2,bio2,blo2,ho2,dzo3,wo3,tssn3,tssno3,bwo3,bto3,cto3,fio3,flo3,bio3,blo3,ho3,dzo4,wo4,tssn4,tssno4,bwo4,bto4,cto4,fio4,flo4,bio4,blo4,ho4 @@ -2630,6 +2698,9 @@ package gbmpblscheme bl_pbl_physics==12 - state:exch_tk package mrfscheme bl_pbl_physics==99 - - package mynn_tkebudget bl_mynn_tkebudget==1 - state:qSHEAR,qBUOY,qDISS,qWT,dqke +package mynn_stem_edmf bl_mynn_edmf==1 - state:edmf_a,edmf_w,edmf_thl,edmf_qt,edmf_ent,edmf_qc +package mynn_temf_edmf bl_mynn_edmf==2 - state:edmf_a,edmf_w,edmf_thl,edmf_qt,edmf_ent,edmf_qc +package pbl_cloud icloud_bl==1 - state:cldfra_bl,qc_bl package nocuscheme cu_physics==0 - - package kfetascheme cu_physics==1 - state:w0avg @@ -2650,6 +2721,8 @@ package kfscheme cu_physics==99 - state:w0avg package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep +package kfedrates kf_edrates==1 - state:udr_kf,ddr_kf,uer_kf,der_kf,timec_kf + package no_cu_used cu_used==0 - - package any_cu_used cu_used==1 - state:rucuten,rvcuten,rthcuten,rqvcuten,rqrcuten,rqccuten,rqscuten,rqicuten,rqcncuten,rqincuten @@ -2668,14 +2741,15 @@ package fogsettling0 grav_settling==0 - state:vdfg package fogsettling1 grav_settling==1 - state:vdfg,fgdp,dfgdp package fogsettling2 grav_settling==2 - state:vdfg,fgdp,dfgdp -package psufddagd grid_fdda==1 - fdda3d:u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,ph_ndg_old,u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,ph_ndg_new;fdda2d:mu_ndg_old,mu_ndg_new;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten +package psufddagd grid_fdda==1 - fdda3d:u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,ph_ndg_old,u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,ph_ndg_new;fdda2d:mu_ndg_old,mu_ndg_new;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten,hfx_fdda package spnudging grid_fdda==2 - fdda3d:u_ndg_old,v_ndg_old,t_ndg_old,q_ndg_old,ph_ndg_old,u_ndg_new,v_ndg_new,t_ndg_new,q_ndg_new,ph_ndg_new;fdda2d:mu_ndg_old,mu_ndg_new;state:rundgdten,rvndgdten,rthndgdten,rphndgdten,rqvndgdten,rmundgdten,dif_analysis,dif_xxx,dif_yyy -package psusfddagd grid_sfdda==1 - state:u10_ndg_old,v10_ndg_old,t2_ndg_old,th2_ndg_old,q2_ndg_old,rh_ndg_old,psl_ndg_old,ps_ndg_old,u10_ndg_new,v10_ndg_new,t2_ndg_new,th2_ndg_new,q2_ndg_new,rh_ndg_new,psl_ndg_new,ps_ndg_new,tob_ndg_old,odis_ndg_old,tob_ndg_new,odis_ndg_new - +package psusfddagd grid_sfdda==1 - state:u10_ndg_old,v10_ndg_old,t2_ndg_old,th2_ndg_old,q2_ndg_old,rh_ndg_old,psl_ndg_old,ps_ndg_old,u10_ndg_new,v10_ndg_new,t2_ndg_new,th2_ndg_new,q2_ndg_new,rh_ndg_new,psl_ndg_new,ps_ndg_new,tob_ndg_old,odis_ndg_old,tob_ndg_new,odis_ndg_new,hfx_fdda package obsnudging obs_nudge_opt==1 - state:obs_savwt,fdob +package fasdas grid_sfdda==2 - state:u10_ndg_old,v10_ndg_old,t2_ndg_old,th2_ndg_old,q2_ndg_old,rh_ndg_old,psl_ndg_old,ps_ndg_old,u10_ndg_new,v10_ndg_new,t2_ndg_new,th2_ndg_new,q2_ndg_new,rh_ndg_new,psl_ndg_new,ps_ndg_new,tob_ndg_old,odis_ndg_old,tob_ndg_new,odis_ndg_new,sda_hfx,sda_qfx,qnorm,hfx_both,qfx_both,hfx_fdda + package aeropt1 aer_opt==1 - state:aerodm package aeropt2 aer_opt==2 - state:aod5503d @@ -2808,7 +2882,7 @@ halo HALO_EM_INIT_3 dyn_em 48:ph0,php,t_init,mub,mu0,p,al,alt,alb halo HALO_EM_INIT_4 dyn_em 48:pb,h_diabatic,qv_diabatic,qc_diabatic,msftx,msfty,msfux,msfuy,msfvx,msfvy,msfvx_inv,f,e,sina,cosa,ht,potevp,snopcx,soiltb,xlat,xlong,xlat_u,xlat_v,xlong_u,xlong_v,clat halo HALO_EM_INIT_5 dyn_em 48:moist,chem,scalar,tracer halo HALO_EM_INIT_6 dyn_em 48:om_tmp,om_s,om_u,om_v,om_depth,om_tini,om_sini,om_lat,om_lon,om_ml -halo HALO_EM_VINTERP_UV_1 dyn_em 24:pd_gc,pb,pmaxw,ptrop +halo HALO_EM_VINTERP_UV_1 dyn_em 48:pd_gc,pb,pmaxw,ptrop,pmaxwnn,ptropnn halo HALO_EM_A dyn_em 8:ru,rv,rw,ww,php,alt,al,p,muu,muv,mut halo HALO_EM_PHYS_A dyn_em 4:u_2,v_2 halo HALO_EM_PHYS_PBL dyn_em 4:rublten,rvblten diff --git a/wrfv2_fire/Registry/Registry.EM_COMMON.var b/wrfv2_fire/Registry/Registry.EM_COMMON.var index 47b81d52..81876811 100644 --- a/wrfv2_fire/Registry/Registry.EM_COMMON.var +++ b/wrfv2_fire/Registry/Registry.EM_COMMON.var @@ -128,6 +128,7 @@ state real Q2 ij misc 1 - irh0{23}du state real T2 ij misc 1 - i01rh0{23}du "T2" "TEMP at 2 M" "K" state real TH2 ij misc 1 - irhdu "TH2" "POT TEMP at 2 M" "K" state real PSFC ij misc 1 - i01rhdu "PSFC" "SFC PRESSURE" "Pa" +state real QSFC ij misc 1 - irh "QSFC" "SPECIFIC HUMIDITY AT LOWER BOUNDARY" "kg kg-1" # these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling # with wave model, only if compiled with -DMCELIO, JM 2003/05/29 @@ -334,6 +335,14 @@ state real TMN ij misc 1 - i012rhd=(int state real XLAND ij misc 1 - i02rhd=(interp_fcnm)u=(copy_fcnm) "XLAND" "LAND MASK (1 FOR LAND, 2 FOR WATER)" "" state real SNOWC ij misc 1 - irhd=(interp_mask_land_field:lu_index)u=(copy_fcnm) "SNOWC" "FLAG INDICATING SNOW COVERAGE (1 FOR SNOW COVER)" "" +state real ZNT ij misc 1 - irh "ZNT" "TIME-VARYING ROUGHNESS LENGTH" "m" +state real UST ij misc 1 - irh "UST" "U* IN SIMILARITY THEORY" "m s-1" +state real MOL ij misc 1 - irh "MOL" "T* IN SIMILARITY THEORY" "K" +state real PBLH ij misc 1 - irh "PBLH" "PBL HEIGHT" "m" +state real HFX ij misc 1 - irh "HFX" "UPWARD HEAT FLUX AT THE SURFACE" "W m-2" +state real QFX ij misc 1 - irh "QFX" "UPWARD MOISTURE FLUX AT THE SURFACE" "kg m-2 s-1" +state real REGIME ij misc 1 - irh "REGIME" "FLAGS: 1=Night/Stable, 2=Mechanical Turbulent, 3=Forced Conv, 4=Free Conv" "" + # #--------------------------------------------------------------------------------------------------------------------------------------- # diff --git a/wrfv2_fire/Registry/Registry.NMM b/wrfv2_fire/Registry/Registry.NMM index d70b0434..4ed53c67 100644 --- a/wrfv2_fire/Registry/Registry.NMM +++ b/wrfv2_fire/Registry/Registry.NMM @@ -162,6 +162,11 @@ ifdef HWRF=1 include registry.tracker endif +# Nest motion safeguard: don't let nest get close to parent boundary. +# Default values are lowest possible - anything lower would read +# outside of memory in intermediate domain. +rconfig integer corral_x namelist,domains max_domains 5 h "corral_x" "Minimum parent gridpoints on each side of nest in X direction." "" +rconfig integer corral_y namelist,domains max_domains 5 h "corral_y" "Minimum parent gridpoints on each side of nest in Y direction." "" # # For the moving nest. This is gopal's doing @@ -427,6 +432,9 @@ state real AKMS_OUT ij dyn_nmm 1 - rh023 "AKMS_OUT" "Outp # # module_PHYS # +state real cd_out ij dyn_nmm 1 - rh023 "CD_OUT" "sfc exch coeff for momentum" "m2 s-1" +state real ch_out ij dyn_nmm 1 - rh023 "CH_OUT" "sfc exch coeff for heat" "m2 s-1" + state real albase ij dyn_nmm 1 - i01rh023d=(DownCopy) "ALBASE" "Base albedo" "" state real albedo ij dyn_nmm 1 - irh023 "ALBEDO" "Dynamic albedo" "" state real cnvbot ij dyn_nmm 1 - irh023 "CNVBOT" "Lowest convec cloud bottom lyr between outputs" "" @@ -602,7 +610,7 @@ state real dwdtmx ij dyn_nmm 1 - - "DWDTMX" "Maximum state real baro ij dyn_nmm 1 - - "BARO" "external mode vvel" "m s-1" state real dwdt ijk dyn_nmm 1 - rd=(DownCopy) "DWDT" "dwdt and 1+(dwdt)/g" "m s-2" state real pdwdt ijk dyn_nmm 1 - r -state real pint ijk dyn_nmm 1 Z irh023d=(DownCopy)u=(NoInterp)f=(NoInterp) "PINT" "Model layer interface pressure" "Pa" +state real pint ijk dyn_nmm 1 Zn irh023d=(DownCopy)u=(NoInterp)f=(NoInterp) "PINT" "Model layer interface pressure" "Pa" state real w ijk dyn_nmm 1 Z rd=(DownCopy) "W_nonhydro" "Vertical velocity (non-hydrostatic component only)" "m s-1" state real w_tot ijk dyn_nmm 1 Z h023d=(DownCopy) "W" "Vertical velocity" "m s-1" state real z ijk dyn_nmm 1 Z hd=(DownCopy) "Z" "Distance from ground" "m" @@ -792,7 +800,7 @@ state real qr ijkfbt moist 1 m rh023u=(UpMa state real qi ijkfbt moist 1 m rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QICE" "Ice mixing ratio" "kg kg-1" state real qs ijkfbt moist 1 m rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QSNOW" "Snow mixing ratio" "kg kg-1" state real qg ijkfbt moist 1 m rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QGRAUP" "Graupel mixing ratio" "kg kg-1" -state real qh ijkfbt moist 1 m rhu=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QHAIL" "Hail mixing ratio" "kg kg-1" +state real qh ijkfbt moist 1 m rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QHAIL" "Hail mixing ratio" "kg kg-1" state real - ijkfbt dfi_moist 1 m - - @@ -810,16 +818,18 @@ state real dfi_qh ijkfbt dfi_moist 1 m r " state real - ijkftb scalar 1 m - - state real qni ijkftb scalar 1 m i01h023ru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNICE" "Ice Number concentration" "# kg(-1)" state real qt ikjftb scalar 1 m i01h023ru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QT" "Total condensate mixing ratio" "kg kg-1" -state real qns ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNSNOW" "Snow Number concentration" "# kg(-1)" +state real qns ijkftb scalar 1 m i01h023ru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNSNOW" "Snow Number concentration" "# kg(-1)" state real qnr ijkftb scalar 1 m i01h023ru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNRAIN" "Rain Number concentration" "# kg(-1)" -state real qng ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNGRAUP" "Graupel Number concentration" "# kg(-1)" -state real qnh ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNHAIL" "Hail Number concentration" "# kg(-1)" -state real qnn ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCCN" "CCN Number concentration" "# kg(-1)" -state real qnc ijkftb scalar 1 m i01hru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" -state real qvolg ikjftb scalar 1 m i01hru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" -state real qnwfa ikjftb scalar 1 m i01hru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" -state real qnifa ikjftb scalar 1 m i01hru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" +state real qng ijkftb scalar 1 m i01h023ru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNGRAUP" "Graupel Number concentration" "# kg(-1)" +state real qnh ijkftb scalar 1 m i01h023ru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNHAIL" "Hail Number concentration" "# kg(-1)" +state real qnn ijkftb scalar 1 m i01h023ru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCCN" "CCN Number concentration" "# kg(-1)" +state real qnc ijkftb scalar 1 m i01h023ru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" +state real qvolg ikjftb scalar 1 m i01h023ru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" +state real qvolh ikjftb scalar 1 m i01h023ru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0. 0) "QVHAIL" "Hail Particle Volume" "m(3) kg(-1)" +state real qnwfa ikjftb scalar 1 m i01h023ru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" +state real qnifa ikjftb scalar 1 m i01h023ru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" state real qndrop ikjftb scalar 1 m i01h023ru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "QNDROP" "Droplet number mixing ratio" "# kg-1" +state real qrimef ijkftb scalar 1 m i01h023ru=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "QRIMEF" "rime factor * qi" "kg kg-1" state real - ijkftb dfi_scalar 1 m - - @@ -845,7 +855,6 @@ state real dfi_qnwfa ikjftb dfi_scalar 1 m \ rsu=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "DFI_QNWFA" "DFI water-friendly aerosol number con" "# kg(-1)" state real dfi_qnifa ikjftb dfi_scalar 1 m \ rsu=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0.0) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" -state real qvolh ikjftb scalar 1 m i01hru=(UpMassIKJ:@ECopy,0.0)d=(DownMassIKJ:@ECopy,0.0)f=(BdyMassIKJ:@ECopy,0. 0) "QVHAIL" "Hail Particle Volume" "m(3) kg(-1)" #----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -912,10 +921,11 @@ state real lake_depth ij misc 1 - rd=(interp_m # variables added for CHEMISTRY compatibility with ARW core - kludge ################################################################# state real GSW ij misc 1 - - "" "" -state real XLAT ij misc 1 - - "" "" -state real XLONG ij misc 1 - - "" "" state real XLAND ij misc 1 - - "" "" state real RAINCV ij misc 1 - - "" "" +state real RAINSH ij misc 1 - - "" "" +state real RAINSHV ij misc 1 - - "" "" +state real SHALL ij misc 1 - - "" "" @@ -1016,6 +1026,11 @@ state real apr_capme ij misc 1 - r "AP state real apr_capmi ij misc 1 - r "APR_CAPMI" "PRECIP FROM MIN CAP" "mm/hour" state real xf_ens ije misc 1 Z r "XF_ENS" "MASS FLUX PDF IN GRELL CUMULUS SCHEME" "mb hour-1" state real pr_ens ije misc 1 Z r "PR_ENS" "PRECIP RATE PDF IN GRELL CUMULUS SCHEME" "mb hour-1" +state real udr_kf ikj misc 1 - rh "UDR_KF" "UPDRAFT DETRAINMENT RATE FROM KF" "kg s-1" +state real ddr_kf ikj misc 1 - rh "DDR_KF" "DOWNDRAFT DETRAINMENT RATE FROM KF" "kg s-1" +state real uer_kf ikj misc 1 - rh "UER_KF" "UPDRAFT ENTRAINMENT RATE FROM KF" "kg s-1" +state real der_kf ikj misc 1 - rh "DER_KF" "DOWNDRAFT ENTRAINMENT RATE FROM KF" "kg s-1" +state real timec_kf ij misc 1 - rh "TIMEC_KF" "CONVECTIVE TIMESCALE FROM MSKF" "s" state real RTHFTEN ikj misc 1 - r "RTHFTEN" "TOTAL ADVECTIVE POTENTIAL TEMPERATURE TENDENCY" "K s-1" state real RQVFTEN ikj misc 1 - r "RQVFTEN" "TOTAL ADVECTIVE MOISTURE TENDENCY" "kg kg-1 s-1" @@ -1042,6 +1057,8 @@ rconfig integer opt_alb namelist,noah_mp 1 2 h rconfig integer opt_snf namelist,noah_mp 1 1 h "opt_snf" "rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah)" "" rconfig integer opt_tbot namelist,noah_mp 1 2 h "opt_tbot" "lower boundary of soil temperature (1->zero-flux; 2->Noah)" "" rconfig integer opt_stc namelist,noah_mp 1 1 h "opt_stc" "soil/snow temperature time scheme 1->semi-implicit; 2->full-implicit (original Noah)" "" +rconfig integer opt_gla namelist,noah_mp 1 1 h "opt_gla" "glacier treatment option 1->includes phase change; 2->slab ice (Noah)" "" +rconfig integer opt_rsf namelist,noah_mp 1 1 h "opt_rsf" "surface evaporation resistance option" "" # For WRF Hydro rconfig integer wrf_hydro derived 1 0 h "wrf_hydro" "descrip" "unit" @@ -1078,6 +1095,8 @@ state real lfmassxy ij - 1 - i02rhd=(interp_mask_land state real rtmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "rtmass" "mass of fine roots" "g/m2" state real stmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "stmass" "stem mass" "g/m2" state real woodxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "wood" "mass of wood" "g/m2" +state real grainxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "grain" "mass of grain" "g/m2" +state real gddxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "gdd" "growing degree days" "" state real stblcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "stblcp" "stable carbon pool" "g/m2" state real fastcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "fastcp" "short-lived carbon" "g/m2" state real xsaixy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "xsai" "stem area index" "-" @@ -1156,7 +1175,7 @@ state real power ij misc 1 - irh "Pow # State for derived time quantities. #for HWRF: add to restart state integer itimestep - - - - rh "itimestep" "" "" -state real xtime - - - - h "xtime" "minutes since simulation start" "" +state real xtime - - - - h0123 "xtime" "minutes since simulation start" "" state real julian - - - - - "julian" "day of year, 0.0 at 0Z on 1 Jan." "days" # input file descriptor for lbcs on parent domain @@ -1254,7 +1273,7 @@ rconfig integer dfi_bckstop_minute namelist,dfi_control 1 00 rh rconfig integer dfi_bckstop_second namelist,dfi_control 1 00 rh "dfi_bckstop_second" "2 DIGIT SECOND OF THE MINUTE OF END OF DFI" "SECONDS" # Domains -rconfig integer time_step namelist,domains 1 - ih0123 "time_step" +rconfig integer time_step namelist,domains 1 -1 ih0123 "time_step" rconfig integer time_step_fract_num namelist,domains 1 0 ih0123 "time_step_fract_num" rconfig integer time_step_fract_den namelist,domains 1 1 ih0123 "time_step_fract_den" rconfig integer time_step_dfi namelist,domains 1 - ih0123 "time_step_dfi" @@ -1297,6 +1316,9 @@ rconfig integer max_ts_locs namelist,domains 1 5 rconfig integer num_moves namelist,domains 1 0 rconfig integer vortex_interval namelist,domains max_domains 15 - "" "" "minutes" rconfig integer corral_dist namelist,domains max_domains 8 +#for HWRF -- set to true for one storm, false for > 1 this gets inferred from the way the nests are configured in frame/module_domain.F +rconfig logical multi_storm derived 1 .true. +rconfig logical no_ocean namelist,domains 1 .false. # added 20151204 jm rconfig integer move_id namelist,domains max_moves 0 rconfig integer move_interval namelist,domains max_moves 999999999 rconfig integer move_cd_x namelist,domains max_moves 0 @@ -1317,6 +1339,20 @@ rconfig logical use_prep_hybrid namelist,domains 1 .false. # Physics rconfig logical force_read_thompson namelist,physics 1 .false. rconfig logical write_thompson_tables namelist,physics 1 .true. +rconfig real nssl_cccn namelist,physics max_domains 0.5e9 rh "Base CCN concentration for NSSL microphysics" "" "" +rconfig real nssl_alphah namelist,physics max_domains 0 rh "Graupel PSD shape paramter" "" "" +rconfig real nssl_alphahl namelist,physics max_domains 1 rh "Hail PSD shape paramter" "" "" +rconfig real nssl_cnoh namelist,physics max_domains 4.e5 rh "Graupel intercept paramter" "" "" +rconfig real nssl_cnohl namelist,physics max_domains 4.e4 rh "Hail intercept paramter" "" "" +rconfig real nssl_cnor namelist,physics max_domains 8.e5 rh "Rain intercept paramter" "" "" +rconfig real nssl_cnos namelist,physics max_domains 3.e6 rh "Snow intercept paramter" "" "" +rconfig real nssl_rho_qh namelist,physics max_domains 500. rh "Graupel particle density" "" "" +rconfig real nssl_rho_qhl namelist,physics max_domains 900. rh "Hail particle density" "" "" +rconfig real nssl_rho_qs namelist,physics max_domains 100. rh "Snow particle density" "" "" +rconfig integer elec_physics namelist,physics 1 0 irh "elec_physics" "" "" +# Explicit lightning (for EM core, but here for code compatibility +rconfig integer nssl_ipelec namelist,physics max_domains 0 rh "Electrification selection" "" "" +rconfig integer nssl_isaund namelist,physics 1 12 rh "Charge separation selection" "" "" #for HWRF: rconfig integer mp_physics namelist,physics max_domains 0 rh0123 "mp_physics" "" "" @@ -1340,6 +1376,7 @@ rconfig real BLDT namelist,physics max_domains 0 rconfig integer cu_physics namelist,physics max_domains 0 rh0123 "cu_physics" "" "" rconfig integer shcu_physics namelist,physics max_domains 0 rh0123 "shcu_physics" "" "" rconfig integer cu_diag namelist,physics max_domains 0 rh0123 "cu_diag" " additional t-averaged stuff for cuphys" "" +rconfig integer kf_edrates namelist,physics max_domains 0 rh "kf_edrates" "output entrainment/detrainment rates and convective timescale for KF schemes" "" ifdef HWRF=1 rconfig real gfs_alpha namelist,physics max_domains 1 irh0123 "boundary depth factor" "" "" @@ -1388,6 +1425,7 @@ rconfig logical usemonalb namelist,physics 1 .tr rconfig logical rdmaxalb namelist,physics 1 .true. h "rdmaxalb" "false set it to table values" "" rconfig logical rdlai2d namelist,physics 1 .false. h "rdlai2d" "false set it to table values" "" rconfig logical ua_phys namelist,physics 1 .false. h "ua_phys" "activate UA Noah changes" "" +rconfig integer opt_thcnd namelist,physics 1 1 h "opt_thcnd" "thermal conductivity option in Noah LSM" "" ifdef HWRF=1 rconfig integer gwd_opt namelist,physics max_domains 2 irh "gwd_opt" "activate gravity wave drag: 0=off, 1=ARW, 2=NMM" "" @@ -1408,13 +1446,18 @@ endif rconfig integer random_seed namelist,physics max_domains 0 irh "random_seed" "random number generator seed" +rconfig integer icoef_sf namelist,physics max_domains 0 irh012 3 "icoef_sf" "Option for exchange coefficients in the surface flux scheme" "" +rconfig logical lcurr_sf namelist,physics max_domains .false. irh012 3 "lcurr_sf" "Option to include ocean currents in the surface flux calculations" "" + ifdef HWRF=1 #added by Zhan Zhang for perturbings for SAS and PBL rconfig integer ens_random_seed namelist,physics max_domains -1 irh "ens_random_seed" "ensemble random number generator initial seed" rconfig logical pert_sas namelist,physics 1 .false. irh "pert_sas" "ensemble choice:F, no pert, T, pert SAS" rconfig logical pert_pbl namelist,physics 1 .false. irh "pert_pbl" "ensemble choice:F, no pert, T, pert PBL" +rconfig logical pert_Cd namelist,physics 1 .false. irh "pert_Cd" "ensemble choice:F, no pert, T, pert Cd" rconfig real ens_sasamp namelist,physics max_domains 50. irh "sas perturbation Amplitude" "unit: hPa" rconfig real ens_pblamp namelist,physics max_domains 0.2 irh "sas perturbation Amplitude" "unit: 100*%" +rconfig real ens_Cdamp namelist,physics max_domains 0.2 irh "Cd perturbation Amplitude" "unit: 100*%" endif @@ -1444,20 +1487,40 @@ rconfig integer cam_abs_dim1 namelist,physics 1 1 rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" rconfig integer no_src_types namelist,physics 1 1 - "no_src_types" "Number of aerosoal types from EC (6)" "" rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" -rconfig integer o3input namelist,physics 1 0 - "o3input" "ozone input option for radiation" "" +rconfig integer o3input namelist,physics 1 2 - "o3input" "ozone input option for radiation" "" rconfig integer aer_opt namelist,physics 1 0 - "aer_opt" "aerosol input option for radiation" "" rconfig logical cu_rad_feedback namelist,physics max_domains .false. - "feedback of cumulus cloud to radiation" rconfig integer ICLOUD_CU derived 1 0 - "ICLOUD_CU" "" "" rconfig real h_diff namelist,physics max_domains 0.1 irh "nmm input 9" +# cam radiation variables +state real - i{ls}jf ozmixm 1 - - - +state real mth01 i{ls}jf ozmixm 1 - - "OZMIXMTH01" "Month 1 CAM ozone mixing ratio" +state real mth02 i{ls}jf ozmixm 1 - - "OZMIXMTH02" "Month 2 CAM ozone mixing ratio" +state real mth03 i{ls}jf ozmixm 1 - - "OZMIXMTH03" "Month 3 CAM ozone mixing ratio" +state real mth04 i{ls}jf ozmixm 1 - - "OZMIXMTH04" "Month 4 CAM ozone mixing ratio" +state real mth05 i{ls}jf ozmixm 1 - - "OZMIXMTH05" "Month 5 CAM ozone mixing ratio" +state real mth06 i{ls}jf ozmixm 1 - - "OZMIXMTH06" "Month 6 CAM ozone mixing ratio" +state real mth07 i{ls}jf ozmixm 1 - - "OZMIXMTH07" "Month 7 CAM ozone mixing ratio" +state real mth08 i{ls}jf ozmixm 1 - - "OZMIXMTH08" "Month 8 CAM ozone mixing ratio" +state real mth09 i{ls}jf ozmixm 1 - - "OZMIXMTH09" "Month 9 CAM ozone mixing ratio" +state real mth10 i{ls}jf ozmixm 1 - - "OZMIXMTH10" "Month 10 CAM ozone mixing ratio" +state real mth11 i{ls}jf ozmixm 1 - - "OZMIXMTH11" "Month 11 CAM ozone mixing ratio" +state real mth12 i{ls}jf ozmixm 1 - - "OZMIXMTH12" "Month 12 CAM ozone mixing ratio" +state real pin {ls} misc 1 - - "PIN" "PRESSURE LEVEL OF OZONE MIXING RATIO" "millibar" + +# new rad variables +state real o3rad ikj misc 1 - irh "o3rad" "RADIATION 3D OZONE" "ppmv" + ifdef HWRF=1 -rconfig integer movemin namelist,physics max_domains 10 irh "movemin" "nest movement timestep (multiples of nphs)" +rconfig integer ntrack namelist,physics max_domains 10 irh "ntrack" "nest movement timestep (multiples of nphs)" endif -rconfig integer movemin namelist,physics max_domains 0 irh "movemin" "nest movement timestep (multiples of nphs)" +rconfig integer ntrack namelist,physics max_domains 0 irh "ntrack" "nest movement timestep (multiples of nphs)" rconfig integer num_snso_layers namelist,physics 1 7 irh "num_snso_layers" "" "" rconfig integer num_snow_layers namelist,physics 1 3 irh "num_snow_layers" "" "" rconfig logical use_aero_icbc namelist,physics 1 .false. rh "use_aero_icbc" "Use GOCART climo 3D aerosols IC/BC data in Thompson-MP-Aero" "logical flag" +rconfig integer use_mp_re namelist,physics 1 1 h "use_mp_re" "use effective radii computed in some mp schemes in RRTMG" "flag" # The following two options are hooked into various microphysics schemes to allow for ensemble perturbations of CCN and hail/graupel PSDs - GAC (AFWA) rconfig real ccn_conc namelist,physics 1 1.0E8 h "ccn_conc" "CCN concentration" "# m-3" @@ -1488,6 +1551,7 @@ rconfig real c_k namelist,dynamics max_domains 0 rconfig real smdiv namelist,dynamics max_domains 0. h "smdiv" "" "" rconfig real emdiv namelist,dynamics max_domains 0. h "emdiv" "" "" rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" +rconfig logical keepnh namelist,dynamics max_domains .true. rh "KEEPNH" "When .false., non-hydrostatic state is discarded at nest move." "" rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" rconfig integer time_step_sound namelist,dynamics max_domains 10 h "time_step_sound" "" "" rconfig integer h_mom_adv_order namelist,dynamics max_domains 3 rh "h_mom_adv_order" "" "" @@ -1575,6 +1639,7 @@ rconfig integer isoilwater derived max_domains rconfig integer map_proj derived max_domains 0 - "map_proj" "domain map projection" "0=none, 1=Lambert, 2=polar, 3=Mercator" rconfig integer dfi_stage derived 1 3 - "dfi_stage" "current stage of DFI processing" "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast" rconfig integer mp_physics_dfi derived max_domains -1 - "mp_physics_dfi" "" "-1 = no DFI and so no need to allocate DFI moistnd scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package" +rconfig integer use_wps_input derived 1 0 - "use_wps_input" "0/1 flag, using wps input" "0=no, 1=real" #rconfig integer simulation_start_year derived 1 0 h "simulation_start_year" "start of simulation through restarts" "4-digit year" #rconfig integer simulation_start_month derived 1 0 h "simulation_start_month" "start of simulation through restarts" "2-digit month" @@ -1602,7 +1667,8 @@ package kesslerscheme mp_physics==1 - moist:qv,qc,q package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg package wsm3scheme mp_physics==3 - moist:qv,qc,qr;state:re_cloud,re_ice,re_snow package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs;state:re_cloud,re_ice,re_snow -package etamp_hr mp_physics==5 - moist:qv,qc,qr,qs;state:f_ice,f_rain,f_rimef +package fer_mp_hires mp_physics==5 - moist:qv,qc,qr,qi,qs;state:f_ice,f_rain,f_rimef +package fer_mp_hires_advect mp_physics==15 - moist:qv,qc,qr,qi;scalar:qrimef package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg;state:re_cloud,re_ice,re_snow package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr;state:re_cloud,re_ice,re_snow @@ -1627,7 +1693,7 @@ package kesslerscheme_dfi mp_physics_dfi==1 - dfi_moist:dfi package linscheme_dfi mp_physics_dfi==2 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package wsm3scheme_dfi mp_physics_dfi==3 - dfi_moist:dfi_qv,dfi_qc,dfi_qr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package etamp_hr_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs +package fer_mp_hires_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow @@ -1643,23 +1709,23 @@ package etampnew_dfi mp_physics_dfi==95 - dfi_moist:dfi # package progndrop progn==1 - scalar:qndrop;dfi_scalar:dfi_qndrop package rrtmscheme ra_lw_physics==1 - - -package camlwscheme ra_lw_physics==3 - state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc -package rrtmg_lwscheme ra_lw_physics==4 - state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc +package camlwscheme ra_lw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,o3rad +package rrtmg_lwscheme ra_lw_physics==4 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,o3rad package rrtmg_lwscheme_fast ra_lw_physics==24 - - package goddardlwscheme ra_lw_physics==5 - - package flglwscheme ra_lw_physics==7 - - package gfdllwscheme ra_lw_physics==99 - - -package hwrflwscheme ra_lw_physics==98 - - +package hwrflwscheme ra_lw_physics==98 - state:o3rad package swradscheme ra_sw_physics==1 - - package gsfcswscheme ra_sw_physics==2 - - -package camswscheme ra_sw_physics==3 - state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc -package rrtmg_swscheme ra_sw_physics==4 - state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc +package camswscheme ra_sw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,o3rad +package rrtmg_swscheme ra_sw_physics==4 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,o3rad package rrtmg_swscheme_fast ra_sw_physics==24 - - package goddardswscheme ra_sw_physics==5 - - package flgswscheme ra_sw_physics==7 - - package gfdlswscheme ra_sw_physics==99 - - -package hwrfswscheme ra_sw_physics==98 +package hwrfswscheme ra_sw_physics==98 - state:o3rad package heldsuarez ra_lw_physics==31 - - package sfclayscheme sf_sfclay_physics==91 - - @@ -1707,6 +1773,8 @@ package gfscheme cu_physics==3 - - package camzmscheme cu_physics==7 - - package kfcupscheme cu_physics==10 - - package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep +package kfedrates kf_edrates==1 - state:udr_kf,ddr_kf,uer_kf,der_kf,timec_kf + package tiedtkescheme cu_physics==6 - - package ntiedtkescheme cu_physics==16 - - package nsasscheme cu_physics==14 - - @@ -1864,7 +1932,7 @@ halo HALO_NMM_VT4_NOISE dyn_nmm 8:mslp_noisy endif halo HALO_NMM_INTERP_INFO dyn_nmm 8:pd,iinfo,winfo,pint -halo HALO_NMM_INT_UP dyn_nmm 8:pd,fis,hres_fis,sm +halo HALO_NMM_INT_UP dyn_nmm 120:pd,fis,hres_fis,sm halo HALO_NMM_MEMBRANE_RELAX dyn_nmm 8:relaxwork halo HALO_NMM_MEMBRANE_MASK dyn_nmm 8:relaximask diff --git a/wrfv2_fire/Registry/registry.chem b/wrfv2_fire/Registry/registry.chem index c56ef1dc..32091f49 100644 --- a/wrfv2_fire/Registry/registry.chem +++ b/wrfv2_fire/Registry/registry.chem @@ -178,30 +178,44 @@ state real e_dms i+jf emis_ant 1 Z i5r "E # soiltexturef is texture category fraction for each grid cell state real ust_t ij misc 1 - i012rh "UST_T" "Threshold Friction Velocity" "m s-1" -state real rough_cor ij misc 1 - r "Rough_cor" "roughness elements correction" "" -state real smois_cor ij misc 1 - r "Smois_cor" "soil moisture correction" "" -state real dustload_1 ij misc 1 - r "dustload_1" "dust loading for size 1" "ug/m2" -state real dustload_2 ij misc 1 - r "dustload_2" "dust loading for size 2" "ug/m2" -state real dustload_3 ij misc 1 - r "dustload_3" "dust loading for size 3" "ug/m2" -state real dustload_4 ij misc 1 - r "dustload_4" "dust loading for size 4" "ug/m2" -state real dustload_5 ij misc 1 - r "dustload_5" "total dust loading" "ug/m2" -state real depvelocity ij misc 1 - r "drydepvel" "dust dry deposition velocity " "m/s" +state real rough_cor ij misc 1 - rh "Rough_cor" "roughness elements correction" "" +state real smois_cor ij misc 1 - rh "Smois_cor" "soil moisture correction" "" +state real dustload_1 ij misc 1 - rh "dustload_1" "dust loading for size 1" "ug/m2" +state real dustload_2 ij misc 1 - rh "dustload_2" "dust loading for size 2" "ug/m2" +state real dustload_3 ij misc 1 - rh "dustload_3" "dust loading for size 3" "ug/m2" +state real dustload_4 ij misc 1 - rh "dustload_4" "dust loading for size 4" "ug/m2" +state real dustload_5 ij misc 1 - rh "dustload_5" "total dust loading" "ug/m2" +state real depvelocity ij misc 1 - rh "drydepvel" "dust dry deposition velocity " "m/s" state real setvel_1 ij misc 1 - r "setvel_1" "dust gravitational settling velocity for size 1" "m/s" state real setvel_2 ij misc 1 - r "setvel_2" "dust gravitational settling velocity for size 2" "m/s" state real setvel_3 ij misc 1 - r "setvel_3" "dust gravitational settling velocity for size 3" "m/s" state real setvel_4 ij misc 1 - r "setvel_4" "dust gravitational settling velocity for size 4" "m/s" state real setvel_5 ij misc 1 - r "setvel_5" "effective gravitational settling velocity for total" "m/s" -state real dustgraset_1 ij misc 1 - r "graset_1" "dust gravitational settling for size 1" "ug/m2/s" -state real dustgraset_2 ij misc 1 - r "graset_2" "dust gravitational settling for size 2" "ug/m2/s" -state real dustgraset_3 ij misc 1 - r "graset_3" "dust gravitational settling for size 3" "ug/m2/s" -state real dustgraset_4 ij misc 1 - r "graset_4" "dust gravitational settling for size 4" "ug/m2/s" -state real dustgraset_5 ij misc 1 - r "graset_5" "dust gravitational settling for size 5" "ug/m2/s" -state real dustdrydep_1 ij misc 1 - r "drydep_1" "dust dry deposition for size 1" "ug/m2/s" -state real dustdrydep_2 ij misc 1 - r "drydep_2" "dust dry deposition for size 2" "ug/m2/s" -state real dustdrydep_3 ij misc 1 - r "drydep_3" "dust dry deposition for size 3" "ug/m2/s" -state real dustdrydep_4 ij misc 1 - r "drydep_4" "dust dry deposition for size 4" "ug/m2/s" -state real dustdrydep_5 ij misc 1 - r "drydep_5" "dust dry deposition for size 5" "ug/m2/s" - +state real dustgraset_1 ij misc 1 - rh "graset_1" "dust gravitational settling for size 1" "ug/m2/s" +state real dustgraset_2 ij misc 1 - rh "graset_2" "dust gravitational settling for size 2" "ug/m2/s" +state real dustgraset_3 ij misc 1 - rh "graset_3" "dust gravitational settling for size 3" "ug/m2/s" +state real dustgraset_4 ij misc 1 - rh "graset_4" "dust gravitational settling for size 4" "ug/m2/s" +state real dustgraset_5 ij misc 1 - rh "graset_5" "dust gravitational settling for size 5" "ug/m2/s" +state real dustdrydep_1 ij misc 1 - rh "drydep_1" "dust dry deposition for size 1" "ug/m2/s" +state real dustdrydep_2 ij misc 1 - rh "drydep_2" "dust dry deposition for size 2" "ug/m2/s" +state real dustdrydep_3 ij misc 1 - rh "drydep_3" "dust dry deposition for size 3" "ug/m2/s" +state real dustdrydep_4 ij misc 1 - rh "drydep_4" "dust dry deposition for size 4" "ug/m2/s" +state real dustdrydep_5 ij misc 1 - rh "drydep_5" "dust dry deposition for size 5" "ug/m2/s" +state real dustwd_1 ikj misc 1 - r "dustwd_1" "dust loss by wet deposition for size 1" "ug/kg-dryair" +state real dustwd_2 ikj misc 1 - r "dustwd_2" "dust loss by wet deposition for size 2" "ug/kg-dryair" +state real dustwd_3 ikj misc 1 - r "dustwd_3" "dust loss by wet deposition for size 3" "ug/kg-dryair" +state real dustwd_4 ikj misc 1 - r "dustwd_4" "dust loss by wet deposition for size 4" "ug/kg-dryair" +state real dustwd_5 ikj misc 1 - r "dustwd_5" "dust loss by wet deposition for size 5" "ug/kg-dryair" +state real wetdep_1 ij misc 1 - r "wetdep_1" "dust wet deposition for size 1" "ug/m2/s" +state real wetdep_2 ij misc 1 - r "wetdep_2" "dust wet deposition for size 2" "ug/m2/s" +state real wetdep_3 ij misc 1 - r "wetdep_3" "dust wet deposition for size 3" "ug/m2/s" +state real wetdep_4 ij misc 1 - r "wetdep_4" "dust wet deposition for size 4" "ug/m2/s" +state real wetdep_5 ij misc 1 - r "wetdep_5" "dust wet deposition for size 5" "ug/m2/s" +state real dustwdload_1 ij misc 1 - r "dustwdload_1" "dustload loss by wet deposition for size 1" "ug/m2" +state real dustwdload_2 ij misc 1 - r "dustwdload_2" "dustload loss by wet deposition for size 2" "ug/m2" +state real dustwdload_3 ij misc 1 - r "dustwdload_3" "dustload loss by wet deposition for size 3" "ug/m2" +state real dustwdload_4 ij misc 1 - r "dustwdload_4" "dustload loss by wet deposition for size 4" "ug/m2" +state real dustwdload_5 ij misc 1 - r "dustwdload_5" "dustload loss by wet deposition for size 5" "ug/m2" #SAPRCNOV additional emissions, automatically created using diff_mechEmiss_wrfRegistry.m script (pablo-saide@uiowa.edu) state real e_c2h2 i+jf emis_ant 1 Z i5r "E_C2H2" "C2H2 emissions" "mol km^-2 hr^-1" state real e_alk3 i+jf emis_ant 1 Z i5r "E_ALK3" "ALK3 emissions" "mol km^-2 hr^-1" @@ -277,11 +291,11 @@ state real e_hum i+jf emis_ant 1 Z i5 "E_H # dust and seas emission arrays state real - i{dust}jf emis_dust - - - - "Dust Emissions" "" -state real edust1 i{dust}jf emis_dust 1 Z - "EDUST1" "DUST emissions bin1" "" -state real edust2 i{dust}jf emis_dust 1 Z - "EDUST2" "DUST emissions bin2" "" -state real edust3 i{dust}jf emis_dust 1 Z - "EDUST3" "DUST emissions bin3" "" -state real edust4 i{dust}jf emis_dust 1 Z - "EDUST4" "DUST emissions bin4" "" -state real edust5 i{dust}jf emis_dust 1 Z - "EDUST5" "DUST emissions bin5" "" +state real edust1 i{dust}jf emis_dust 1 Z h "EDUST1" "DUST emissions bin1" "" +state real edust2 i{dust}jf emis_dust 1 Z h "EDUST2" "DUST emissions bin2" "" +state real edust3 i{dust}jf emis_dust 1 Z h "EDUST3" "DUST emissions bin3" "" +state real edust4 i{dust}jf emis_dust 1 Z h "EDUST4" "DUST emissions bin4" "" +state real edust5 i{dust}jf emis_dust 1 Z h "EDUST5" "DUST emissions bin5" "" state real - i{dust}jf emis_seas - - - - "Sea-Salt Emissions" "" state real eseas1 i{dust}jf emis_seas 1 Z - "ESEAS1" "Sea-Salt emissions bin1 " "" state real eseas2 i{dust}jf emis_seas 1 Z - "ESEAS2" "Sea-Salt emissions bin2 " "" @@ -3717,6 +3731,7 @@ rconfig integer chem_opt namelist,chem max_domains rconfig integer gaschem_onoff namelist,chem max_domains 1 rh "gaschem_onoff" "" "" rconfig integer aerchem_onoff namelist,chem max_domains 1 rh "aerchem_onoff" "" "" rconfig integer wetscav_onoff namelist,chem max_domains 0 rh "wetscav_onoff" "" "" +rconfig integer dustwd_onoff namelist,chem max_domains 0 rh "dustwd_onoff" "" "" rconfig integer cldchem_onoff namelist,chem max_domains 0 rh "cldchem_onoff" "" "" rconfig integer vertmix_onoff namelist,chem max_domains 1 rh "vertmix_onoff" "" "" rconfig integer chem_in_opt namelist,chem max_domains 0 rh "chem_in_opt" "" "" @@ -3848,6 +3863,9 @@ package racm_esrlsorg_kpp chem_opt==107 - che # new scheme for better SOA simulations package racm_soa_vbs_kpp chem_opt==108 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,hace,ishp,ison,mahp,mpan,nald,sesq,mbo,cvasoa1,cvasoa2,cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,asoa1j,asoa1i,asoa2j,asoa2i,asoa3j,asoa3i,asoa4j,asoa4i,bsoa1j,bsoa1i,bsoa2j,bsoa2i,bsoa3j,bsoa3i,bsoa4j,bsoa4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn +# new scheme for better SOA simulations + AQ chem +package racm_soa_vbs_aqchem_kpp chem_opt==109 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ete,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,co2,ch4,udd,hket,api,lim,dien,macr,hace,ishp,ison,mahp,mpan,nald,sesq,mbo,cvasoa1,cvasoa2,cvasoa3,cvasoa4,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4,ho,ho2,so4aj,so4ai,nh4aj,nh4ai,no3aj,no3ai,naaj,naai,claj,clai,asoa1j,asoa1i,asoa2j,asoa2i,asoa3j,asoa3i,asoa4j,asoa4i,bsoa1j,bsoa1i,bsoa2j,bsoa2i,bsoa3j,bsoa3i,bsoa4j,bsoa4i,orgpaj,orgpai,ecj,eci,p25j,p25i,antha,seas,soila,nu0,ac0,corn,so4cwj,so4cwi,nh4cwj,nh4cwi,no3cwj,no3cwi,nacwj,nacwi,clcwj,clcwi,asoa1cwj,asoa1cwi,asoa2cwj,asoa2cwi,asoa3cwj,asoa2cwi,asoa3cwj,asoa3cwi,asoa4cwj,asoa4cwi,bsoa1cwj,bsoa1cwi,bsoa2cwj,bsoa2cwi,bsoa3cwj,bsoa3cwi,bsoa4cwj,bsoa4cwi,orgpacwj,orgpacwi,eccwj,eccwi,p25cwj,p25cwi,anthcw,seascw,soilcw,nu0cw,ac0cw,corncw + package cbm4_kpp chem_opt==110 - chem:no,no2,no3,n2o5,hono,hno3,pna,nh3,so2,sulf,o1d_cb4,o,ho,o3,h2o2,hcho,ald2,c2o3,pan,par,ror,ole,eth,tol,cres,to2,cro,open,xyl,mgly,iso,xo2,xo2n,co,ho2 # KPP mechanism from mozart package mozart_kpp chem_opt==111 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,c10h16,terpo2,tol,cres,to2,xoh,onit,isopn,dms,nh3,meko2 @@ -3879,7 +3897,7 @@ package saprc99_mosaic_4bin_vbs2_kpp chem_opt==198 - chem:o3,h2o2,no, #package mozart_mosaic_4bin_vbs0_kpp chem_opt==201 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,c10h16,terpo2,tol,cres,to2,xoh,onit,isopn,dms,nh3,nume,den,voca,vocbb,smpa,smpbb,biog1_c,biog1_o,meko2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,smpa_a01,smpbb_a01,biog1_c_a01,biog1_o_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,smpa_a02,smpbb_a02,biog1_c_a02,biog1_o_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,smpa_a03,smpbb_a03,biog1_c_a03,biog1_o_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,smpa_a04,smpbb_a04,biog1_c_a04,biog1_o_a04,num_a04,ca_a01,ca_a02,ca_a03,ca_a04,co3_a01,co3_a02,co3_a03,co3_a04 package mozart_mosaic_4bin_kpp chem_opt==201 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,hcooh,c2h2,hoch2oo,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,apin,bpin,limon,myrc,bcary,terprod1,terprod2,terp2o2,terp2ooh,nterpo2,terpo2,tol,cres,to2,onit,isopn,dms,mbo,mboo2,hmprop,hmpropo2,mboooh,mbono3o2,nh3,nume,den,voca,vocbb,smpa,smpbb,biog1_c,biog1_o,benzene,phen,bepomuc,benzo2,pheno2,pheno,phenooh,c6h5o2,c6h5ooh,benzooh,bigald1,bigald2,bigald3,bigald4,malo2,tepomuc,bzoo,bzooh,bald,acbzo2,dicarbo2,mdialo2,xyl,xylol,xylolo2,xylolooh,xyleno2,xylenooh,pbznit,hono,meko2,so4_a01,no3_a01,smpa_a01,smpbb_a01,glysoa_sfc_a01,biog1_c_a01,biog1_o_a01,cl_a01,co3_a01,nh4_a01,na_a01,ca_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,smpa_a02,smpbb_a02,glysoa_sfc_a02,biog1_c_a02,biog1_o_a02,cl_a02,co3_a02,nh4_a02,na_a02,ca_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,smpa_a03,smpbb_a03,glysoa_sfc_a03,biog1_c_a03,biog1_o_a03,cl_a03,co3_a03,nh4_a03,na_a03,ca_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,smpa_a04,smpbb_a04,glysoa_sfc_a04,biog1_c_a04,biog1_o_a04,cl_a04,co3_a04,nh4_a04,na_a04,ca_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04 # complete aq-phase chem. and wet scavenging version with MOZART, HONO, VOC reactivity + VBS SOA -package mozart_mosaic_4bin_aq_kpp chem_opt==202 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,hcooh,c2h2,hoch2oo,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,apin,bpin,limon,myrc,bcary,terprod1,terprod2,terp2o2,terp2ooh,nterpo2,terpo2,tol,cres,to2,onit,isopn,dms,mbo,mboo2,hmprop,hmpropo2,mboooh,mbono3o2,nh3,nume,den,cvasoaX,cvasoa1,cvasoa2,cvasoa3,cvasoa4,cvbsoaX,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4,benzene,phen,bepomuc,benzo2,pheno2,pheno,phenooh,c6h5o2,c6h5ooh,benzooh,bigald1,bigald2,bigald3,bigald4,malo2,tepomuc,bzoo,bzooh,bald,acbzo2,dicarbo2,mdialo2,xyl,xylol,xylolo2,xylolooh,xyleno2,xylenooh,pbznit,hono,meko2,so4_a01,no3_a01,asoaX_a01,asoa1_a01,asoa2_a01,asoa3_a01,asoa4_a01,bsoaX_a01,bsoa1_a01,bsoa2_a01,bsoa3_a01,bsoa4_a01,glysoa_r1_a01,glysoa_r2_a01,glysoa_sfc_a01,glysoa_nh4_a01,glysoa_oh_a01,cl_a01,co3_a01,nh4_a01,na_a01,ca_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,asoaX_a02,asoa1_a02,asoa2_a02,asoa3_a02,asoa4_a02,bsoaX_a02,bsoa1_a02,bsoa2_a02,bsoa3_a02,bsoa4_a02,glysoa_r1_a02,glysoa_r2_a02,glysoa_sfc_a02,glysoa_nh4_a02,glysoa_oh_a02,cl_a02,co3_a02,nh4_a02,na_a02,ca_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,asoaX_a03,asoa1_a03,asoa2_a03,asoa3_a03,asoa4_a03,bsoaX_a03,bsoa1_a03,bsoa2_a03,bsoa3_a03,bsoa4_a03,glysoa_r1_a03,glysoa_r2_a03,glysoa_sfc_a03,glysoa_nh4_a03,glysoa_oh_a03,cl_a03,co3_a03,nh4_a03,na_a03,ca_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,asoaX_a04,asoa1_a04,asoa2_a04,asoa3_a04,asoa4_a04,bsoaX_a04,bsoa1_a04,bsoa2_a04,bsoa3_a04,bsoa4_a04,glysoa_r1_a04,glysoa_r2_a04,glysoa_sfc_a04,glysoa_nh4_a04,glysoa_oh_a04,cl_a04,co3_a04,nh4_a04,na_a04,ca_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_cw01,no3_cw01,asoaX_cw01,asoa1_cw01,asoa2_cw01,asoa3_cw01,asoa4_cw01,bsoaX_cw01,bsoa1_cw01,bsoa2_cw01,bsoa3_cw01,bsoa4_cw01,glysoa_r1_cw01,glysoa_r2_cw01,glysoa_sfc_cw01,glysoa_nh4_cw01,glysoa_oh_cw01,cl_cw01,co3_cw01,nh4_cw01,na_cw01,ca_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,asoaX_cw02,asoa1_cw02,asoa2_cw02,asoa3_cw02,asoa4_cw02,bsoaX_cw02,bsoa1_cw02,bsoa2_cw02,bsoa3_cw02,bsoa4_cw02,glysoa_r1_cw02,glysoa_r2_cw02,glysoa_sfc_cw02,glysoa_nh4_cw02,glysoa_oh_cw02,cl_cw02,co3_cw02,nh4_cw02,na_cw02,ca_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,asoaX_cw03,asoa1_cw03,asoa2_cw03,asoa3_cw03,asoa4_cw03,bsoaX_cw03,bsoa1_cw03,bsoa2_cw03,bsoa3_cw03,bsoa4_cw03,glysoa_r1_cw03,glysoa_r2_cw03,glysoa_sfc_cw03,glysoa_nh4_cw03,glysoa_oh_cw03,cl_cw03,co3_cw03,nh4_cw03,na_cw03,ca_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,asoaX_cw04,asoa1_cw04,asoa2_cw04,asoa3_cw04,asoa4_cw04,bsoaX_cw04,bsoa1_cw04,bsoa2_cw04,bsoa3_cw04,bsoa4_cw04,glysoa_r1_cw04,glysoa_r2_cw04,glysoa_sfc_cw04,glysoa_nh4_cw04,glysoa_oh_cw04,cl_cw04,co3_cw04,nh4_cw04,na_cw04,ca_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04,wd_so4_sc,wd_no3_sc,wd_nh4_sc,wd_oa_sc,wd_so4_cu,wd_no3_cu,wd_nh4_cu,wd_oa_cu +package mozart_mosaic_4bin_aq_kpp chem_opt==202 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,hcooh,c2h2,hoch2oo,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,apin,bpin,limon,myrc,bcary,terprod1,terprod2,terp2o2,terp2ooh,nterpo2,terpo2,tol,cres,to2,onit,isopn,dms,mbo,mboo2,hmprop,hmpropo2,mboooh,mbono3o2,nh3,nume,den,cvasoaX,cvasoa1,cvasoa2,cvasoa3,cvasoa4,cvbsoaX,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4,benzene,phen,bepomuc,benzo2,pheno2,pheno,phenooh,c6h5o2,c6h5ooh,benzooh,bigald1,bigald2,bigald3,bigald4,malo2,tepomuc,bzoo,bzooh,bald,acbzo2,dicarbo2,mdialo2,xyl,xylol,xylolo2,xylolooh,xyleno2,xylenooh,pbznit,hono,meko2,so4_a01,no3_a01,asoaX_a01,asoa1_a01,asoa2_a01,asoa3_a01,asoa4_a01,bsoaX_a01,bsoa1_a01,bsoa2_a01,bsoa3_a01,bsoa4_a01,glysoa_r1_a01,glysoa_r2_a01,glysoa_sfc_a01,glysoa_nh4_a01,glysoa_oh_a01,cl_a01,co3_a01,nh4_a01,na_a01,ca_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,asoaX_a02,asoa1_a02,asoa2_a02,asoa3_a02,asoa4_a02,bsoaX_a02,bsoa1_a02,bsoa2_a02,bsoa3_a02,bsoa4_a02,glysoa_r1_a02,glysoa_r2_a02,glysoa_sfc_a02,glysoa_nh4_a02,glysoa_oh_a02,cl_a02,co3_a02,nh4_a02,na_a02,ca_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,asoaX_a03,asoa1_a03,asoa2_a03,asoa3_a03,asoa4_a03,bsoaX_a03,bsoa1_a03,bsoa2_a03,bsoa3_a03,bsoa4_a03,glysoa_r1_a03,glysoa_r2_a03,glysoa_sfc_a03,glysoa_nh4_a03,glysoa_oh_a03,cl_a03,co3_a03,nh4_a03,na_a03,ca_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,asoaX_a04,asoa1_a04,asoa2_a04,asoa3_a04,asoa4_a04,bsoaX_a04,bsoa1_a04,bsoa2_a04,bsoa3_a04,bsoa4_a04,glysoa_r1_a04,glysoa_r2_a04,glysoa_sfc_a04,glysoa_nh4_a04,glysoa_oh_a04,cl_a04,co3_a04,nh4_a04,na_a04,ca_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_cw01,no3_cw01,asoaX_cw01,asoa1_cw01,asoa2_cw01,asoa3_cw01,asoa4_cw01,bsoaX_cw01,bsoa1_cw01,bsoa2_cw01,bsoa3_cw01,bsoa4_cw01,glysoa_r1_cw01,glysoa_r2_cw01,glysoa_sfc_cw01,glysoa_nh4_cw01,glysoa_oh_cw01,cl_cw01,co3_cw01,nh4_cw01,na_cw01,ca_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,asoaX_cw02,asoa1_cw02,asoa2_cw02,asoa3_cw02,asoa4_cw02,bsoaX_cw02,bsoa1_cw02,bsoa2_cw02,bsoa3_cw02,bsoa4_cw02,glysoa_r1_cw02,glysoa_r2_cw02,glysoa_sfc_cw02,glysoa_nh4_cw02,glysoa_oh_cw02,cl_cw02,co3_cw02,nh4_cw02,na_cw02,ca_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,asoaX_cw03,asoa1_cw03,asoa2_cw03,asoa3_cw03,asoa4_cw03,bsoaX_cw03,bsoa1_cw03,bsoa2_cw03,bsoa3_cw03,bsoa4_cw03,glysoa_r1_cw03,glysoa_r2_cw03,glysoa_sfc_cw03,glysoa_nh4_cw03,glysoa_oh_cw03,cl_cw03,co3_cw03,nh4_cw03,na_cw03,ca_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,asoaX_cw04,asoa1_cw04,asoa2_cw04,asoa3_cw04,asoa4_cw04,bsoaX_cw04,bsoa1_cw04,bsoa2_cw04,bsoa3_cw04,bsoa4_cw04,glysoa_r1_cw04,glysoa_r2_cw04,glysoa_sfc_cw04,glysoa_nh4_cw04,glysoa_oh_cw04,cl_cw04,co3_cw04,nh4_cw04,na_cw04,ca_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04 package saprc99_mosaic_8bin_vbs2_aq_kpp chem_opt==203 - chem:o3,h2o2,no,no2,no3,n2o5,hono,hno3,hno4,so2,h2so4,co,hcho,ccho,rcho,acet,mek,hcooh,meoh,etoh,cco_oh,rco_oh,gly,mgly,bacl,cres,bald,isoprod,methacro,mvk,prod2,dcb1,dcb2,dcb3,ethene,isoprene,c2h6,c3h8,c2h2,c3h6,alk3,alk4,alk5,aro1,aro2,ole1,ole2,terp,rno3,nphe,phen,pan,pan2,pbzn,ma_pan,co2,cco_ooh,rco_o2,rco_ooh,xn,xc,ho,ho2,c_o2,cooh,rooh,ro2_r,r2o2,ro2_n,cco_o2,bzco_o2,ma_rco3,sesq,pcg1_b_c,pcg2_b_c,pcg1_b_o,pcg2_b_o,opcg1_b_c,opcg1_b_o,pcg1_f_c,pcg2_f_c,pcg1_f_o,pcg2_f_o,opcg1_f_c,opcg1_f_o,psd1,psd2,nh3,hcl,nume,den,ant1_c,biog1_c,ch4,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,pcg1_b_c_a01,pcg1_b_o_a01,opcg1_b_c_a01,opcg1_b_o_a01,pcg1_f_c_a01,pcg1_f_o_a01,opcg1_f_c_a01,opcg1_f_o_a01,ant1_c_a01,biog1_c_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,pcg1_b_c_a02,pcg1_b_o_a02,opcg1_b_c_a02,opcg1_b_o_a02,pcg1_f_c_a02,pcg1_f_o_a02,opcg1_f_c_a02,opcg1_f_o_a02,ant1_c_a02,biog1_c_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,pcg1_b_c_a03,pcg1_b_o_a03,opcg1_b_c_a03,opcg1_b_o_a03,pcg1_f_c_a03,pcg1_f_o_a03,opcg1_f_c_a03,opcg1_f_o_a03,ant1_c_a03,biog1_c_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,pcg1_b_c_a04,pcg1_b_o_a04,opcg1_b_c_a04,opcg1_b_o_a04,pcg1_f_c_a04,pcg1_f_o_a04,opcg1_f_c_a04,opcg1_f_o_a04,ant1_c_a04,biog1_c_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,pcg1_b_c_a05,pcg1_b_o_a05,opcg1_b_c_a05,opcg1_b_o_a05,pcg1_f_c_a05,pcg1_f_o_a05,opcg1_f_c_a05,opcg1_f_o_a05,ant1_c_a05,biog1_c_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,pcg1_b_c_a06,pcg1_b_o_a06,opcg1_b_c_a06,opcg1_b_o_a06,pcg1_f_c_a06,pcg1_f_o_a06,opcg1_f_c_a06,opcg1_f_o_a06,ant1_c_a06,biog1_c_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,pcg1_b_c_a07,pcg1_b_o_a07,opcg1_b_c_a07,opcg1_b_o_a07,pcg1_f_c_a07,pcg1_f_o_a07,opcg1_f_c_a07,opcg1_f_o_a07,ant1_c_a07,biog1_c_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,pcg1_b_c_a08,pcg1_b_o_a08,opcg1_b_c_a08,opcg1_b_o_a08,pcg1_f_c_a08,pcg1_f_o_a08,opcg1_f_c_a08,opcg1_f_o_a08,ant1_c_a08,biog1_c_a08,num_a08,so4_cw01,no3_cw01,cl_cw01,nh4_cw01,na_cw01,oin_cw01,oc_cw01,bc_cw01,pcg1_b_c_cw01,pcg1_b_o_cw01,opcg1_b_c_cw01,opcg1_b_o_cw01,pcg1_f_c_cw01,pcg1_f_o_cw01,opcg1_f_c_cw01,opcg1_f_o_cw01,ant1_c_cw01,biog1_c_cw01,num_cw01,so4_cw02,no3_cw02,cl_cw02,nh4_cw02,na_cw02,oin_cw02,oc_cw02,bc_cw02,pcg1_b_c_cw02,pcg1_b_o_cw02,opcg1_b_c_cw02,opcg1_b_o_cw02,pcg1_f_c_cw02,pcg1_f_o_cw02,opcg1_f_c_cw02,opcg1_f_o_cw02,ant1_c_cw02,biog1_c_cw02,num_cw02,so4_cw03,no3_cw03,cl_cw03,nh4_cw03,na_cw03,oin_cw03,oc_cw03,bc_cw03,pcg1_b_c_cw03,pcg1_b_o_cw03,opcg1_b_c_cw03,opcg1_b_o_cw03,pcg1_f_c_cw03,pcg1_f_o_cw03,opcg1_f_c_cw03,opcg1_f_o_cw03,ant1_c_cw03,biog1_c_cw03,num_cw03,so4_cw04,no3_cw04,cl_cw04,nh4_cw04,na_cw04,oin_cw04,oc_cw04,bc_cw04,pcg1_b_c_cw04,pcg1_b_o_cw04,opcg1_b_c_cw04,opcg1_b_o_cw04,pcg1_f_c_cw04,pcg1_f_o_cw04,opcg1_f_c_cw04,opcg1_f_o_cw04,ant1_c_cw04,biog1_c_cw04,num_cw04,so4_cw05,no3_cw05,cl_cw05,nh4_cw05,na_cw05,oin_cw05,oc_cw05,bc_cw05,pcg1_b_c_cw05,pcg1_b_o_cw05,opcg1_b_c_cw05,opcg1_b_o_cw05,pcg1_f_c_cw05,pcg1_f_o_cw05,opcg1_f_c_cw05,opcg1_f_o_cw05,ant1_c_cw05,biog1_c_cw05,num_cw05,so4_cw06,no3_cw06,cl_cw06,nh4_cw06,na_cw06,oin_cw06,oc_cw06,bc_cw06,pcg1_b_c_cw06,pcg1_b_o_cw06,opcg1_b_c_cw06,opcg1_b_o_cw06,pcg1_f_c_cw06,pcg1_f_o_cw06,opcg1_f_c_cw06,opcg1_f_o_cw06,ant1_c_cw06,biog1_c_cw06,num_cw06,so4_cw07,no3_cw07,cl_cw07,nh4_cw07,na_cw07,oin_cw07,oc_cw07,bc_cw07,pcg1_b_c_cw07,pcg1_b_o_cw07,opcg1_b_c_cw07,opcg1_b_o_cw07,pcg1_f_c_cw07,pcg1_f_o_cw07,opcg1_f_c_cw07,opcg1_f_o_cw07,ant1_c_cw07,biog1_c_cw07,num_cw07,so4_cw08,no3_cw08,cl_cw08,nh4_cw08,na_cw08,oin_cw08,oc_cw08,bc_cw08,pcg1_b_c_cw08,pcg1_b_o_cw08,opcg1_b_c_cw08,opcg1_b_o_cw08,pcg1_f_c_cw08,pcg1_f_o_cw08,opcg1_f_c_cw08,opcg1_f_o_cw08,ant1_c_cw08,biog1_c_cw08,num_cw08 diff --git a/wrfv2_fire/Registry/registry.diags b/wrfv2_fire/Registry/registry.diags index 4e155f68..573b2b4f 100644 --- a/wrfv2_fire/Registry/registry.diags +++ b/wrfv2_fire/Registry/registry.diags @@ -1,5 +1,6 @@ -# Registry file specifically for some additional diagnostic output -# from WRF. +# Registry file specifically for some additional diagnostic output from WRF. + +# PRESSURE # The new dimspec. We need to have the number of pressure levels to interpolate to. @@ -35,3 +36,41 @@ state real q_pl i{np}j misc 1 Z h{23} "Q_PL" "Pressure level package skip_press_diags p_lev_diags==0 - - package press_diags p_lev_diags==1 - state:p_pl,u_pl,v_pl,t_pl,rh_pl,ght_pl,s_pl,td_pl,q_pl + + + + +# HEIGHT and AGL + +# The new dimspec. We need to have the number of height levels to interpolate to. + +dimspec nz 2 namelist=num_z_levels z num_z_levels + +# Namelist parameters + +rconfig integer z_lev_diags namelist,diags 1 0 - "flag to process vertical interp diagnostics: 0=nope, 1=yep" "flag" +rconfig integer z_lev_diags_dfi namelist,diags 1 0 - "when doing z_level diags and dfi, turn off diags during 'non forecast'" +rconfig integer num_z_levels namelist,diags 1 0 - "number of height levels to interpolate diagnostics to" "index" +rconfig real z_levels namelist,diags max_zlevs 0 - "array of height levels to interpolate diagnostics to" "m" +rconfig real z_lev_missing namelist,diags 1 -999 - "missing values below ground, no extrapolation" "constant" + +# Derived, this is interval in seconds that is from auxhist22 interval, computed in check_a_mundo + +rconfig real z_lev_interval derived max_domains 0 - "interval to compute/output z level diags" "s" + +# Arrays that will be filled with interpolated values + +state real z_zl {nz} misc 1 Z h{22} "Z_ZL" "Height level data, Height" "m" +state real u_zl i{nz}j misc 1 Z h{22} "U_ZL" "Height level data, U wind" "m s-1" +state real v_zl i{nz}j misc 1 Z h{22} "V_ZL" "Height level data, V wind" "m s-1" +state real t_zl i{nz}j misc 1 Z h{22} "T_ZL" "Height level data, Temperature" "K" +state real rh_zl i{nz}j misc 1 Z h{22} "RH_ZL" "Height level data, Relative humidity" "%" +state real ght_zl i{nz}j misc 1 Z h{22} "GHT_ZL" "Height level data, Geopotential Height" "m" +state real s_zl i{nz}j misc 1 Z h{22} "S_ZL" "Height level data, Speed" "m s-1" +state real td_zl i{nz}j misc 1 Z h{22} "TD_ZL" "Height level data, Dew point temperature" "K" +state real q_zl i{nz}j misc 1 Z h{22} "Q_ZL" "Height level data, Mixing ratio" "kg/kg" + +# Package declarations + +package skip_z_diags z_lev_diags==0 - - +package z_diags z_lev_diags==1 - state:z_zl,u_zl,v_zl,t_zl,rh_zl,ght_zl,s_zl,td_zl,q_zl diff --git a/wrfv2_fire/Registry/registry.elec b/wrfv2_fire/Registry/registry.elec new file mode 100644 index 00000000..067ce4cd --- /dev/null +++ b/wrfv2_fire/Registry/registry.elec @@ -0,0 +1,58 @@ +# SPACE CHARGE EXPLICIT LIGHTNING +state real scr ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "SCR" "Rain space charge mixing ratio" "# C kg(-1)" +state real scw ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "SCW" "cloud water space charge mixing ratio" "# C kg(-1)" +state real sci ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "SCI" "cloud ice space charge mixing ratio" "# C kg(-1)" +state real scs ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "SCS" "snow space charge mixing ratio" "# C kg(-1)" +state real sch ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "SCH" "graupel water space charge mixing ratio" "# C kg(-1)" +state real schl ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "SCHL" "hail water space charge mixing ratio" "# C kg(-1)" +state real sciona ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "SCIONA" "Passive net ion space charge" "# C kg(-1)" +state real clnox ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "CLNOX" "Lightning NOx concentration" "# moles kg(-1)" +# END SPACE CHARGE EXPLICIT LIGHTNING + +# EXPLICIT LIGHTNING +# +state real rscghis_2d ij misc 1 - irh "rscghis_2d" "MAX NONINDUCTIVE CHARGING 2D" "C m-2" +state real induc ikj misc 1 - irh "induc" "TOTAL INDUCTIVE CHARGING " "C m-3" +state real noninduc ikj misc 1 - irh "noninduc" "TOTAL NONINDUCTIVE CHARGING" "C m-3" +state real sctot ikj misc 1 - irh "sctot" "Total Space Charge Density" "C m-3" +state real elecmag ikj misc 1 - irh "elecmag" "EFIELD MAGNITUDE" "V m-1" +state real elecx ikj misc 1 - irh "elecx" "EFIELD X-Component" "V m-1" +state real elecy ikj misc 1 - irh "elecy" "EFIELD Y-Component" "V m-1" +state real elecz ikj misc 1 - irh "elecz" "EFIELD Z-Component" "V m-1" +state real pot ikj misc 1 - irh "pot" "POTENTIAL" "V" +state real light ij misc 1 - irh "light" "lightning flash" "flash origin density" +state real lightdens ij misc 1 - irh "lightdens" "lightning flash density" "flash column-1" +state integer lightdis ij misc 1 - irh "lightdis" "lightning source density" "Source column-1" +state real flshi ikj misc 1 - irh "flshi" "Lightning init points" "count" +state real flshn ikj misc 1 - irh "flshn" "Negative channels" "count" +state real flshp ikj misc 1 - irh "flshp" "Positive channels" "count" +# END EXPLICIT LIGHTNING + + +# Explicit lightning +rconfig integer nssl_ipelec namelist,physics max_domains 0 rh "Electrification selection" "" "" +rconfig integer nssl_isaund namelist,physics 1 12 rh "Charge separation selection" "" "" +rconfig integer nssl_iscreen namelist,physics 1 0 rh "Screening layer parameterization flag" "" "" +rconfig real nssl_lightrad namelist,physics 1 12000 rh "discharge cylinder radius (m)" "" "" +rconfig integer nssl_idischarge namelist,physics 1 1 rh "lightning discharge flag" "" "" +rconfig integer nssl_ibrkd namelist,physics 1 4 rh "Critical Breakeven Efield profile selection" "" "" +rconfig real nssl_ecrit namelist,physics 1 120000 rh "Critical Breakeven Efield magnitude for discharge (V/m) assuming height-constant Ecrit profile" "" "" +rconfig real nssl_disfrac namelist,physics 1 0.3 rh "percentile of charge removed upon discharge (BLM)" "" "" +# end Explicit lightning + +rconfig integer elec_physics namelist,physics 1 0 irh "elec_physics" "" "" + +# external WRF-ELEC package +package noelec elec_physics==0 - - +package eleclgt1d elec_physics==1 - scalar:scr,scw,sci,scs,sch,schl,sciona;state:rscghis_2d,sctot,noninduc,induc,pot,elecmag,elecx,elecy,elecz,light,lightdens,lightdis +package eleclgtmsz elec_physics==2 - scalar:scr,scw,sci,scs,sch,schl,sciona;state:rscghis_2d,sctot,noninduc,induc,pot,elecmag,elecx,elecy,elecz,light,lightdens,lightdis,flshi,flshn,flshp +package eleclgtmsznox elec_physics==3 - scalar:scr,scw,sci,scs,sch,schl,sciona,clnox;state:rscghis_2d,sctot,noninduc,induc,pot,elecmag,elecx,elecy,elecz,light,lightdens,lightdis,flshi,flshn,flshp + diff --git a/wrfv2_fire/Registry/registry.var b/wrfv2_fire/Registry/registry.var index fd05984d..91a0f099 100644 --- a/wrfv2_fire/Registry/registry.var +++ b/wrfv2_fire/Registry/registry.var @@ -79,6 +79,8 @@ state real A_RAINNCV ij misc 1 - r "A # Variables that are set at run-time to control configuration (namelist-settable) # #
+rconfig logical update_sfcdiags namelist,wrfvar1 1 .false. - "update_sfcdiags" "" "" +rconfig logical use_wrf_sfcinfo namelist,wrfvar1 1 .true. - "use_wrf_sfcinfo" "" "" rconfig logical use_background_errors namelist,wrfvar1 1 .true. - "use_background_errors" "" "" rconfig logical write_increments namelist,wrfvar1 1 .false. - "write_increments" "" "" rconfig logical var4d namelist,wrfvar1 1 .false. - "var4d" "" "" @@ -176,6 +178,7 @@ rconfig logical use_hsbobs namelist,wrfvar4 1 .false. - "use rconfig logical use_ssmisobs namelist,wrfvar4 1 .false. - "use_ssmisobs" "" "" rconfig logical use_iasiobs namelist,wrfvar4 1 .false. - "use_iasiobs" "" "" rconfig logical use_seviriobs namelist,wrfvar4 1 .false. - "use_seviriobs" "" "" +rconfig logical use_amsr2obs namelist,wrfvar4 1 .false. - "use_amsr2obs" "" "" rconfig logical use_kma1dvar namelist,wrfvar4 1 .false. - "use_kma1dvar" "" "" rconfig logical use_filtered_rad namelist,wrfvar4 1 .false. - "use_filtered_rad" "" "" rconfig logical use_obs_errfac namelist,wrfvar4 1 .false. - "use_obs_errfac" "" "" @@ -316,13 +319,16 @@ rconfig logical test_dm_exact namelist,wrfvar10 1 .false. - "te rconfig integer cv_options_hum namelist,wrfvar11 1 1 - "cv_options_hum" "" "" rconfig integer check_rh namelist,wrfvar11 1 0 - "check_rh" "" "" rconfig real set_omb_rand_fac namelist,wrfvar11 1 1.0 - "set_omb_rand_fac" "" "" -rconfig integer seed_array1 namelist,wrfvar11 1 0 - "seed_array1" "" "" -rconfig integer seed_array2 namelist,wrfvar11 1 0 - "seed_array2" "" "" +rconfig integer seed_array1 namelist,wrfvar11 1 1 - "seed_array1" "" "" +rconfig integer seed_array2 namelist,wrfvar11 1 1 - "seed_array2" "" "" rconfig integer sfc_assi_options namelist,wrfvar11 1 1 - "sfc_assi_options" "" "" +rconfig logical psfc_from_slp namelist,wrfvar11 1 .false. - "psfc_from_slp" "" "" rconfig logical calculate_cg_cost_fn namelist,wrfvar11 1 .false. - "calculate_cg_cost_fn" "" "" rconfig logical lat_stats_option namelist,wrfvar11 1 .false. - "lat_stats_option" "" "" rconfig integer interp_option namelist,wrfvar11 1 1 - "interp_option" "" "" -rconfig integer balance_type namelist,wrfvar12 1 1 - "balance_type" "" "" +rconfig integer balance_type namelist,wrfvar12 1 3 - "balance_type" "" "For use_wpec: 1 = geostrophic; 2 = cyclostrophic; 3 = both" +rconfig logical use_wpec namelist,wrfvar12 1 .false. - "use_wpec" "" "" +rconfig real wpec_factor namelist,wrfvar12 1 0.001 - "wpec_factor" "" "Inverse of WPEC gamma factor" rconfig integer vert_corr namelist,wrfvar13 1 2 - "vert_corr" "" "" rconfig integer vertical_ip namelist,wrfvar13 1 0 - "vertical_ip" "" "" rconfig integer vert_evalue namelist,wrfvar13 1 1 - "vert_evalue" "" "" @@ -401,7 +407,7 @@ rconfig logical use_clddet_mmr namelist,wrfvar14 1 .false. - "us rconfig logical use_clddet_ecmwf namelist,wrfvar14 1 .false. - "use_clddet_ecmwf" "" "" rconfig logical airs_warmest_fov namelist,wrfvar14 1 .false. - "airs_warmest_fov" "" "" rconfig logical use_satcv namelist,wrfvar14 2 .false. - "use_satcv" "" "" -rconfig logical use_blacklist_rad namelist,wrfvar14 1 .false. - "use_blacklist_rad" "" "" +rconfig logical use_blacklist_rad namelist,wrfvar14 1 .true. - "use_blacklist_rad" "" "" rconfig logical calc_weightfunc namelist,wrfvar14 1 .false. - "calc_weightfunc" "" "" rconfig character crtm_coef_path namelist,wrfvar14 1 "./crtm_coeffs" - "crtm_coef_path" "" "" rconfig character crtm_irwater_coef namelist,wrfvar14 1 "Nalli.IRwater.EmisCoeff.bin" - "crtm_irwater_coef" "" "" @@ -496,10 +502,14 @@ halo HALO_PSICHI_UV dyn_em 24:vp%v1,vp%v2,vp6%v1,vp6%v2,xb%cori,xb%rho, halo HALO_BAL_EQN_ADJ dyn_em 24:xp%v1z halo HALO_PSICHI_UV_ADJ dyn_em 24:xa%u,xa%v,xa%psfc halo HALO_XA_A dyn_em 4:xa%u,xa%v +halo HALO_WPEC dyn_em 24:xa%grad_p_x,xa%grad_p_y +halo HALO_WPEC_ADJ dyn_em 24:xa%u,xa%v,xa%geoh,xa%p halo HALO_X6A_A dyn_em 4:x6a%u,x6a%v halo HALO_EM_C_TL dyn_em 4:g_u_2,g_v_2,g_rainc,g_rainnc halo HALO_XB dyn_em 24:xb%psac,xb%rough,xb%u,xb%v,xb%w,xb%wh,xb%t,xb%p,xb%q,xb%qs,xb%qrn,xb%qcw,xb%qci,xb%qsn,xb%qgr,xb%qt,xb%rho,xb%rh,xb%h,xb%hf,xb%u10,xb%v10,xb%t2,xb%q2,xb%psfc,xb%regime,xb%ztd,xb%tpw,xb%speed,xb%tb19v,xb%tb19h,xb%tb22v,xb%tb37v,xb%tb37h,xb%tb85v,xb%tb85h,xb%ref,xb%reflog,xb%delt,xb%slp,xb%tsk,xb%smois,xb%tslb,xb%xice,xb%ivgtyp,xb%isltyp,xb%vegfra,xb%snowh,xb%snow halo HALO_XA dyn_em 24:xa%u,xa%v,xa%q,xa%p,xa%t,xa%rho,xa%rh,xa%psfc,xa%qcw,xa%qrn,xa%qci,xa%qt,xa%qsn,xa%qgr +halo HALO_XA_ALL dyn_em 24:xa%u,xa%v,xa%q,xa%p,xa%t,xa%rho,xa%rh,xa%psfc,xa%qcw,xa%qrn,xa%qci,xa%qt,xa%qsn,xa%qgr,xa%geoh,xa%mu +halo HALO_XB_ALL dyn_em 24:xb%u,xb%v,xb%p,xb%rho,xb%h halo HALO_XA_CLOUD dyn_em 24:xa%q,xa%t,xa%qcw,xa%qrn,xa%qci,xa%qsn,xa%qgr halo HALO_SFC_XA dyn_em 24:xa%u10,xa%v10,xa%t2,xa%q2 halo HALO_SSMI_XA dyn_em 24:xa%ztd,xa%tpw,xa%speed,xa%tb19v,xa%tb19h,xa%tb22v,xa%tb37v,xa%tb37h,xa%tb85v,xa%tb85h,xa%ref @@ -583,6 +593,8 @@ typedef xb_type real qsn ijk - 1 - typedef xb_type real qgr ijk - 1 - - typedef xb_type real qt ijk - 1 - - typedef xb_type real delt ijk - 1 - - +typedef xb_type real xb_p_x ijk - 1 - - +typedef xb_type real xb_p_y ijk - 1 - - typedef xb_type real h ijk - 1 - - typedef xb_type real hf ijk - 1 - - typedef xb_type real wh ijk - 1 - - @@ -649,9 +661,12 @@ typedef x_type real w ijk - 1 - typedef x_type real t ijk - 1 - - typedef x_type real q ijk - 1 - - typedef x_type real p ijk - 1 - - +typedef x_type real geoh ijk - 1 - - typedef x_type real rh ijk - 1 - - typedef x_type real rho ijk - 1 - - typedef x_type real wh ijk - 1 - - +typedef x_type real grad_p_x ijk - 1 - - +typedef x_type real grad_p_y ijk - 1 - - typedef x_type real qrn ijk - 1 - - typedef x_type real qcw ijk - 1 - - typedef x_type real qci ijk - 1 - - @@ -660,6 +675,7 @@ typedef x_type real qgr ijk - 1 - typedef x_type real qt ijk - 1 - - typedef x_type real tgrn ij - 1 - - typedef x_type real psfc ij - 1 - - +typedef x_type real mu ij - 1 - - typedef x_type real u10 ij - 1 - - typedef x_type real v10 ij - 1 - - typedef x_type real t2 ij - 1 - - diff --git a/wrfv2_fire/arch/Config_new.pl b/wrfv2_fire/arch/Config_new.pl index 56ab8a29..34415a91 100644 --- a/wrfv2_fire/arch/Config_new.pl +++ b/wrfv2_fire/arch/Config_new.pl @@ -9,6 +9,7 @@ $sw_perl_path = perl ; $sw_netcdf_path = "" ; $sw_pnetcdf_path = "" ; +$sw_hdf5_path=""; $sw_phdf5_path=""; $sw_jasperlib_path=""; $sw_jasperinc_path=""; @@ -23,6 +24,7 @@ $sw_crtm_flag = "" ; $sw_cloudcv_flag = "" ; $sw_4dvar_flag = "" ; +$sw_wrfplus_path = "" ; $sw_wavelet_flag = "" ; $WRFCHEM = 0 ; $sw_os = "ARCH" ; # ARCH will match any @@ -36,7 +38,8 @@ $sw_dmparallel = "" ; $sw_ompparallel = "" ; $sw_stubmpi = "" ; -$sw_usenetcdff = "" ; # for 3.6.2 and greater, the fortran bindings might be in a separate lib file +$sw_usenetcdff = "" ; # UNIDATA switches around library names a bit +$sw_usenetcdf = "" ; $sw_time = "" ; # name of a timer to time fortran compiles, e.g. timex or time $sw_ifort_r8 = 0 ; $sw_hdf5 = "-lhdf5 -lhdf5_hl"; @@ -88,6 +91,10 @@ { $sw_pnetcdf_path = substr( $ARGV[0], 9 ) ; } + if ( substr( $ARGV[0], 1, 5 ) eq "hdf5=" ) + { + $sw_hdf5_path = substr( $ARGV[0], 6 ) ; + } if ( substr( $ARGV[0], 1, 6 ) eq "phdf5=" ) { $sw_phdf5_path = substr( $ARGV[0], 7 ) ; @@ -108,6 +115,10 @@ { $sw_usenetcdff = substr( $ARGV[0], 12 ) ; } + if ( substr( $ARGV[0], 1, 10 ) eq "USENETCDF=" ) + { + $sw_usenetcdf = substr( $ARGV[0], 11 ) ; + } if ( substr( $ARGV[0], 1, 5 ) eq "time=" ) { $sw_time = substr( $ARGV[0], 6 ) ; @@ -263,6 +274,7 @@ if ( $sw_wrf_core eq "4D_DA_CORE" ) { $sw_4dvar_flag = "-DVAR4D"; + $sw_wrfplus_path= $ENV{WRFPLUS_DIR}; } if ( $ENV{WAVELET} ) { @@ -406,6 +418,7 @@ $_ =~ s/CONFIGURE_PERL_PATH/$sw_perl_path/g ; $_ =~ s/CONFIGURE_NETCDF_PATH/$sw_netcdf_path/g ; $_ =~ s/CONFIGURE_PNETCDF_PATH/$sw_pnetcdf_path/g ; + $_ =~ s/CONFIGURE_HDF5_PATH/$sw_hdf5_path/g ; $_ =~ s/CONFIGURE_PHDF5_PATH/$sw_phdf5_path/g ; $_ =~ s/CONFIGURE_LDFLAGS/$sw_ldflags/g ; $_ =~ s/CONFIGURE_COMPILEFLAGS/$sw_compileflags/g ; @@ -422,6 +435,7 @@ $_ =~ s/CONFIGURE_STUBMPI/$sw_stubmpi/g ; $_ =~ s/CONFIGURE_NESTOPT/$sw_nest_opt/g ; $_ =~ s/CONFIGURE_4DVAR_FLAG/$sw_4dvar_flag/g ; + $_ =~ s/CONFIGURE_WRFPLUS_PATH/$sw_wrfplus_path/g ; $_ =~ s/CONFIGURE_CRTM_FLAG/$sw_crtm_flag/g ; $_ =~ s/CONFIGURE_RTTOV_FLAG/$sw_rttov_flag/g ; $_ =~ s/CONFIGURE_RTTOV_INC/$sw_rttov_inc/g ; @@ -444,9 +458,9 @@ if ( $ENV{NETCDF_LDFLAGS} ) { $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:\$\(WRF_SRC_ROOT_DIR\)/external/io_netcdf/libwrfio_nf.a $ENV{NETCDF_LDFLAGS} : ; } elsif ( $sw_os eq "Interix" ) { - $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:\$\(WRF_SRC_ROOT_DIR\)/external/io_netcdf/libwrfio_nf.a -L$sw_netcdf_path/lib $sw_usenetcdff -lnetcdf : ; + $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:\$\(WRF_SRC_ROOT_DIR\)/external/io_netcdf/libwrfio_nf.a -L$sw_netcdf_path/lib $sw_usenetcdff $sw_usenetcdf : ; } else { - $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:-L\$\(WRF_SRC_ROOT_DIR\)/external/io_netcdf -lwrfio_nf -L$sw_netcdf_path/lib $sw_usenetcdff -lnetcdf : ; + $_ =~ s:CONFIGURE_NETCDF_LIB_PATH:-L\$\(WRF_SRC_ROOT_DIR\)/external/io_netcdf -lwrfio_nf -L$sw_netcdf_path/lib $sw_usenetcdff $sw_usenetcdf : ; } } else @@ -470,6 +484,15 @@ $_ =~ s:CONFIGURE_PNETCDF_LIB_PATH::g ; } + if ( $sw_hdf5_path ) + { $_ =~ s:CONFIGURE_HDF5_LIB_PATH:-L$sw_hdf5_path/lib -lhdf5_fortran -lhdf5 -lm -lz: ; + $_ =~ s:CONFIGURE_HDF5_FLAG:-DHDF5: ; + } + else + { $_ =~ s:CONFIGURE_HDF5_LIB_PATH::g ; + $_ =~ s:CONFIGURE_HDF5_FLAG::g ; + } + if ( $sw_phdf5_path ) { $_ =~ s/CONFIGURE_WRFIO_PHDF5/wrfio_phdf5/g ; diff --git a/wrfv2_fire/arch/configure_new.defaults b/wrfv2_fire/arch/configure_new.defaults index 99679784..112e72fd 100644 --- a/wrfv2_fire/arch/configure_new.defaults +++ b/wrfv2_fire/arch/configure_new.defaults @@ -16,7 +16,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = #-fdefault-real-8 -ARCH_LOCAL = -DNEC -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DNEC -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -c #-DNCARIBM_NOC99 -Xa -Kc99 LDFLAGS_LOCAL = -Wl,-h nodefs @@ -39,6 +39,7 @@ AR = sxar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ls +RLFLAGS = #ranlib CC_TOOLS = cc @@ -60,7 +61,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = #-fdefault-real-8 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -c LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -68,7 +69,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O2 -ftree-vectorize -funroll-loops FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -FCDEBUG = # -g $(FCNOOPT) # -fbacktrace -ggdb -fbounds-check -ffpe-trap=invalid,zero,overflow +FCDEBUG = # -g $(FCNOOPT) # -fbacktrace -ggdb -fcheck=bounds,do,mem,pointer -ffpe-trap=invalid,zero,overflow FORMAT_FIXED = -ffixed-form FORMAT_FREE = -ffree-form -ffree-line-length-none FCSUFFIX = @@ -82,6 +83,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -102,7 +104,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DF2CSTYLE -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DF2CSTYLE -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -DF2CSTYLE LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -124,6 +126,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -144,7 +147,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -166,6 +169,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -186,7 +190,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 LDFLAGS_LOCAL = -L$(MPI_ROOT)/lib -lmpi CPLUSPLUSLIB = @@ -208,6 +212,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -228,7 +233,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -D_ACCEL -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -D_ACCEL -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -249,6 +254,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -302,7 +308,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars LDFLAGS_LOCAL = -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common CPLUSPLUSLIB = @@ -310,7 +316,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -fno-inline -no-ip -FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = @@ -324,6 +330,7 @@ AR = ar ARFLAGS = ru M4 = m4 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -345,7 +352,7 @@ CC = $(DM_CC) LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DCHUNK=16 -DXEON_OPTIMIZED_WSM5 -DXEON_SIMD -DOPTIMIZE_CFL_TEST -DFSEEKO64_OK -DINTEL_YSU_KLUDGE -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DCHUNK=16 -DXEON_OPTIMIZED_WSM5 -DXEON_SIMD -DOPTIMIZE_CFL_TEST -DFSEEKO64_OK -DINTEL_YSU_KLUDGE -DWRF_USE_CLM OPTNOSIMD = OPTKNC = -fimf-precision=low -fimf-domain-exclusion=15 -opt-assume-safe-padding -opt-streaming-stores always -opt-streaming-cache-evict=0 -mP2OPT_hlo_pref_use_outer_strategy=F CFLAGS_LOCAL = -w -O3 $(OPTKNC) @@ -355,7 +362,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 $(OPTKNC) FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -fno-inline -no-ip -FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = @@ -369,6 +376,7 @@ AR = ar ARFLAGS = ru M4 = m4 RANLIB = ranlib +RLFLAGS = CC_TOOLS = gcc ########################################################### @@ -390,7 +398,7 @@ CC = $(DM_CC) LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DCHUNK=64 -DXEON_OPTIMIZED_WSM5 -DOPTIMIZE_CFL_TEST -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DCHUNK=64 -DXEON_OPTIMIZED_WSM5 -DOPTIMIZE_CFL_TEST -DWRF_USE_CLM OPTNOSIMD = OPTAVX = -xAVX CFLAGS_LOCAL = -w -O3 $(OPTAVX) @@ -400,7 +408,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 $(OPTAVX) FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -fno-inline -no-ip -FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = @@ -414,6 +422,7 @@ AR = ar ARFLAGS = ru M4 = m4 RANLIB = ranlib +RLFLAGS = CC_TOOLS = gcc ########################################################### @@ -461,7 +470,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars LDFLAGS_LOCAL = -ip -lmpi #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common CPLUSPLUSLIB = @@ -469,7 +478,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -fno-inline -no-ip -FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = @@ -483,6 +492,7 @@ AR = ar ARFLAGS = ru M4 = m4 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -508,7 +518,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars LDFLAGS_LOCAL = -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common CPLUSPLUSLIB = @@ -516,7 +526,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -fno-inline -no-ip -FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = @@ -530,6 +540,7 @@ AR = ar ARFLAGS = ru M4 = m4 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -585,7 +596,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars LDFLAGS_LOCAL = -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common CPLUSPLUSLIB = @@ -593,7 +604,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -fno-inline -no-ip -FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = @@ -609,6 +620,7 @@ AR = ar ARFLAGS = ru M4 = m4 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -666,7 +678,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars LDFLAGS_LOCAL = -ip #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common CPLUSPLUSLIB = @@ -674,7 +686,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -fno-inline -no-ip -FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = @@ -690,6 +702,7 @@ AR = ar ARFLAGS = ru M4 = m4 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -710,7 +723,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM -D__PATHSCALE__ +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM -D__PATHSCALE__ CFLAGS_LOCAL = LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -732,6 +745,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -752,7 +766,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = #-fdefault-real-8 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -c LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -760,7 +774,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O2 -ftree-vectorize -funroll-loops FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -FCDEBUG = # -g $(FCNOOPT) # -ggdb -fbacktrace -fbounds-check -ffpe-trap=invalid,zero,overflow +FCDEBUG = # -g $(FCNOOPT) # -ggdb -fbacktrace -fcheck=bounds,do,mem,pointer -ffpe-trap=invalid,zero,overflow FORMAT_FIXED = -ffixed-form FORMAT_FREE = -ffree-form -ffree-line-length-none FCSUFFIX = @@ -774,6 +788,7 @@ AR = ar ARFLAGS = ru M4 = m4 -G RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -794,7 +809,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -DMACOS LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -816,6 +831,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = -c CC_TOOLS = cc ########################################################### @@ -836,7 +852,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 -ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM +ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -ip -DMACOS #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars -DMACOS # increase stack size; also note that for OpenMP, set environment OMP_STACKSIZE 4G or greater LDFLAGS_LOCAL = -ip -Wl,-stack_addr,0xF10000000 -Wl,-stack_size,0x64000000 #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common @@ -845,7 +861,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -fno-inline -no-ip -FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = @@ -860,10 +876,11 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = -c CC_TOOLS = cc ########################################################### -#ARCH Darwin (MACOS) intel compiler with cc #serial smpar dmpar dm+sm +#ARCH Darwin (MACOS) intel compiler with clang EDIT FOR OPENMPI #serial smpar dmpar dm+sm # DESCRIPTION = INTEL ($SFC/$SCC) DMPARALLEL = # 1 @@ -871,31 +888,30 @@ OMPCPP = # -D_OPENMP OMP = # -openmp -fpp -auto OMPCC = # -openmp SFC = ifort -SCC = cc -CCOMP = cc +SCC = clang +CCOMP = clang DM_FC = mpif90 -f90=$(SFC) -DM_CC = mpicc -cc=$(SCC) +DM_CC = mpicc -cc=$(SCC) # the -cc=cc option causes openmpi mpicc to fail (unrecognized option) FC = CONFIGURE_FC CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 -ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM -CFLAGS_LOCAL = -w -O3 -ip -DMACOS #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars -DMACOS +ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM +CFLAGS_LOCAL = -w -O3 -DMACOS #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars -DMACOS # increase stack size; also note that for OpenMP, set environment OMP_STACKSIZE 4G or greater -LDFLAGS_LOCAL = -ip -Wl,-stack_addr,0xF10000000 -Wl,-stack_size,0x64000000 #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common +LDFLAGS_LOCAL = -Wl,-stack_addr,0xF10000000 -Wl,-stack_size,0x64000000 #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O3 FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -fno-inline -no-ip -FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian -# added -fno-common at suggestion of R. Dubtsov as workaround for failing to link program_name -FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common +FCBASEOPTS_NO_G = -fp-model precise -w -ftz -align all -fno-alias -fno-common $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = TRADFLAG = -traditional @@ -904,6 +920,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = -c CC_TOOLS = cc ########################################################### @@ -924,7 +941,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DG95 -DMACOS -DF2CSTYLE -DNONSTANDARD_SYSTEM_SUBR -DRCONFIG_CHARLEN=64 -DWRF_USE_CLM +ARCH_LOCAL = -DG95 -DMACOS -DF2CSTYLE -DNONSTANDARD_SYSTEM_SUBR -DRCONFIG_CHARLEN=64 -DWRF_USE_CLM CFLAGS_LOCAL = -DMACOS -DF2CSTYLE LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -947,6 +964,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib -c +RLFLAGS = -c CC_TOOLS = $(SCC) ########################################################### @@ -967,7 +985,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = #-fdefault-real-8 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DMACOS -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DMACOS -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -c -DMACOS LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -975,7 +993,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -O2 -ftree-vectorize -funroll-loops FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -FCDEBUG = # -g $(FCNOOPT) # -fbacktrace -ggdb -fbounds-check -ffpe-trap=invalid,zero,overflow +FCDEBUG = # -g $(FCNOOPT) # -fbacktrace -ggdb -fcheck=bounds,do,mem,pointer -ffpe-trap=invalid,zero,overflow FORMAT_FIXED = -ffixed-form FORMAT_FREE = -ffree-form -ffree-line-length-none FCSUFFIX = @@ -989,8 +1007,52 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = -c CC_TOOLS = $(SCC) +########################################################### +#ARCH Darwin (MACOS) gfortran with clang #serial smpar dmpar dm+sm +# +DESCRIPTION = GNU ($SFC/clang) +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -fopenmp +OMPCC = # -fopenmp +SFC = gfortran +SCC = clang +CCOMP = clang +DM_FC = mpif90 -f90=$(SFC) +DM_CC = mpicc -cc=clang +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = #-fdefault-real-8 +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DMACOS -DWRF_USE_CLM +CFLAGS_LOCAL = -w -O3 -c -DMACOS +LDFLAGS_LOCAL = +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -O2 -ftree-vectorize -funroll-loops +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 +FCDEBUG = # -g $(FCNOOPT) # -fbacktrace -ggdb -fcheck=bounds,do,mem,pointer -ffpe-trap=invalid,zero,overflow +FORMAT_FIXED = -ffixed-form +FORMAT_FREE = -ffree-form -ffree-line-length-none +FCSUFFIX = +BYTESWAPIO = -fconvert=big-endian -frecord-marker=4 +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = +TRADFLAG = -traditional +CPP = cpp -P -xassembler-with-cpp +AR = ar +ARFLAGS = ru +M4 = m4 -B 14000 +RANLIB = ranlib +RLFLAGS = -c +CC_TOOLS = clang + ########################################################### #ARCH Darwin (MACOS) xlf #serial dmpar # @@ -1009,7 +1071,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 -ARCH_LOCAL = -DMAC_KLUDGE -DF2CSTYLE -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DMAC_KLUDGE -DF2CSTYLE -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -DMACOS -DF2CSTYLE LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -1033,6 +1095,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = -c CC_TOOLS = $(SCC) ########################################################### @@ -1054,7 +1117,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DNATIVE_MASSV -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DNATIVE_MASSV -DWRF_USE_CLM CFLAGS_LOCAL = -DNOUNDERSCORE LDFLAGS_LOCAL = -lmass -lmassv -bnoquiet # print diagnostic messages CPLUSPLUSLIB = -lC @@ -1074,12 +1137,13 @@ BYTESWAPIO = FCBASEOPTS_NO_G = -w -qspill=81920 -qmaxmem=-1 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap -C # -qinitauto=7FF7FFFF FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional +TRADFLAG = #-traditional # causing troubles with xl cpp on AIX, -traditional removed fom default settings CPP = /lib/cpp -P AR = ar ARFLAGS = ru -M4 = m4 -B 14000 +M4 = m4 -B 20000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = cc ########################################################### @@ -1101,7 +1165,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DNATIVE_MASSV -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DNATIVE_MASSV -DWRF_USE_CLM CFLAGS_LOCAL = -DNOUNDERSCORE LDFLAGS_LOCAL = -lmass_64 -lmassvp7_64 -q64 -bnoquiet # linking diagnostics CPLUSPLUSLIB = -lC @@ -1130,6 +1194,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = cc ########################################################### @@ -1191,6 +1256,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -1206,7 +1272,7 @@ OMPCPP = # -D_OPENMP OMP = # -homp OMPCC = # -homp SFC = ftn -SCC = gcc +SCC = cc CCOMP = gcc DM_FC = ftn DM_CC = cc @@ -1215,7 +1281,7 @@ CC = $(DM_CC) LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -s integer32 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -O3 LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -1237,6 +1303,7 @@ AR = ar ARFLAGS = ru M4 = m4 RANLIB = ranlib +RLFLAGS = CC_TOOLS = gcc ########################################################### @@ -1258,7 +1325,7 @@ CC = $(DM_CC) LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM OPTNOSIMD = # set this to override Cray 'craype' module setting #OPTAVX = -xAVX @@ -1269,7 +1336,7 @@ ESMF_LDFLAG = $(CPLUSPLUSLIB) FCOPTIM = -ip -O3 $(OPTAVX) FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O0 -fno-inline -fno-ip -FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check all -ftrapuv -unroll0 -u +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = @@ -1283,6 +1350,7 @@ AR = ar ARFLAGS = ru M4 = m4 RANLIB = ranlib +RLFLAGS = CC_TOOLS = gcc ########################################################### @@ -1303,7 +1371,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -CcdRR$(RWORDSIZE) -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -Kfast -Xg -DSUN LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -1325,6 +1393,7 @@ AR = ar ARFLAGS = ru M4 = m4 RANLIB = ranlib +RLFLAGS = CC_TOOLS = /usr/bin/gcc -Wall ########################################################### @@ -1349,7 +1418,7 @@ LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 # If system has even more processors, set VERY_LARGE_MAXPROC to that number -ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DVERY_LARGE_MAXPROC=36768 -DBLUEGENE -DWRF_USE_CLM +ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DVERY_LARGE_MAXPROC=36768 -DBLUEGENE -DWRF_USE_CLM CFLAGS_LOCAL = -DNOUNDERSCORE -DNCARIBM_NOC99 $(MPI_INC) LIB_LOCAL = $(MPI_LIB) LDFLAGS_LOCAL = -Wl,--allow-multiple-definition -qstatic @@ -1375,6 +1444,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = cc ########################################################### #ARCH Linux ppc64 BG /P xlf compiler with xlc # smpar dmpar dm+sm @@ -1397,7 +1467,7 @@ LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 # If system has even more processors, set VERY_LARGE_MAXPROC to that number -ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DVERY_LARGE_MAXPROC=36768 -DBLUEGENE -DWRF_USE_CLM +ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DVERY_LARGE_MAXPROC=36768 -DBLUEGENE -DWRF_USE_CLM CFLAGS_LOCAL = -DNOUNDERSCORE LIB_LOCAL = LDFLAGS_LOCAL = -Wl,--allow-multiple-definition,--relax -qstatic @@ -1421,6 +1491,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = cc ########################################################### #ARCH Linux ppc64 IBM Blade Server xlf compiler with xlc # dmpar @@ -1442,7 +1513,7 @@ LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -qrealsize=$(RWORDSIZE) -qintsize=4 # If system has even more processors, set VERY_LARGE_MAXPROC to that number -ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DVERY_LARGE_MAXPROC=36768 -DWRF_USE_CLM +ARCH_LOCAL = -DMOVE_NL_OUTSIDE_MODULE_CONFIGURE -DNONSTANDARD_SYSTEM_SUBR -DVERY_LARGE_MAXPROC=36768 -DWRF_USE_CLM CFLAGS_LOCAL = -DNOUNDERSCORE LDFLAGS_LOCAL = CPLUSPLUSLIB = -lC @@ -1464,6 +1535,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = xlc -q64 ########################################################### @@ -1484,7 +1556,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -1506,6 +1578,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -1526,7 +1599,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -D_WIN32 -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -D_WIN32 -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 -DMEMCPY_FOR_BCOPY LDFLAGS_LOCAL = Ws2_32.lib # -lnetcdff CPLUSPLUSLIB = @@ -1548,6 +1621,7 @@ AR = ar ARFLAGS = cr M4 = NA RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) LIB_EXTERNAL = \ @@ -1582,7 +1656,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -1604,6 +1678,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) ########################################################### @@ -1624,7 +1699,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -DMACOS LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -1646,6 +1721,7 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = -c CC_TOOLS = cc ########################################################### @@ -1666,7 +1742,7 @@ CC = CONFIGURE_CC LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE PROMOTION = -r$(RWORDSIZE) -i4 -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -w -O3 LDFLAGS_LOCAL = CPLUSPLUSLIB = @@ -1688,6 +1764,93 @@ AR = ar ARFLAGS = ru M4 = m4 -B 14000 RANLIB = ranlib +RLFLAGS = +CC_TOOLS = $(SCC) + +########################################################### +#ARCH Linux x86_64 ppc64le i486 i586 i686 #serial smpar dmpar dm+sm +# +DESCRIPTION = INTEL ($SFC/$SCC): HSW/BDW +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -openmp -fpp -auto +OMPCC = # -openmp -fpp -auto +SFC = ifort +SCC = icc +CCOMP = icc +DM_FC = mpif90 -f90=$(SFC) +DM_CC = mpicc -cc=$(SCC) +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM +CFLAGS_LOCAL = -w -O3 -ip -xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars -xCORE-AVX2 +LDFLAGS_LOCAL = -ip -xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common -xCORE-AVX2 +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -O3 +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 -fno-inline -no-ip +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u +FORMAT_FIXED = -FI +FORMAT_FREE = -FR +FCSUFFIX = +BYTESWAPIO = -convert big_endian +FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) -xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common -xCORE-AVX2 +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = +TRADFLAG = -traditional +CPP = /lib/cpp -P +AR = ar +ARFLAGS = ru +M4 = m4 +RANLIB = ranlib +RLFLAGS = +CC_TOOLS = $(SCC) + +########################################################### +#ARCH Linux x86_64 ppc64le i486 i586 i686 #serial smpar dmpar dm+sm +# +DESCRIPTION = INTEL ($SFC/$SCC): KNL MIC +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -openmp -fpp -auto +OMPCC = # -openmp -fpp -auto +SFC = ifort +SCC = icc +CCOMP = icc +DM_FC = mpif90 -f90=$(SFC) +DM_CC = mpicc -cc=$(SCC) +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM +CFLAGS_LOCAL = -w -O3 -ip -xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars -xMIC-AVX512 +LDFLAGS_LOCAL = -ip -xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common -xMIC-AVX512 +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -O3 +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 -fno-inline -no-ip +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u +FORMAT_FIXED = -FI +FORMAT_FREE = -FR +FCSUFFIX = +BYTESWAPIO = -convert big_endian +FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) -xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common -xMIC-AVX512 +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = +TRADFLAG = -traditional +CPP = /lib/cpp -P +AR = ar +ARFLAGS = ru +M4 = m4 +RANLIB = ranlib +RLFLAGS = CC_TOOLS = $(SCC) diff --git a/wrfv2_fire/arch/md_calls.inc b/wrfv2_fire/arch/md_calls.inc index 77d24983..46acd2b7 100644 --- a/wrfv2_fire/arch/md_calls.inc +++ b/wrfv2_fire/arch/md_calls.inc @@ -235,7 +235,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -438,7 +438,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -643,7 +643,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -846,7 +846,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -1051,7 +1051,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -1209,7 +1209,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -1369,7 +1369,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -1527,7 +1527,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -1687,7 +1687,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -1845,7 +1845,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -2005,7 +2005,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -2163,7 +2163,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -2323,7 +2323,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -2481,7 +2481,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -2641,7 +2641,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -2799,7 +2799,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -2959,7 +2959,7 @@ CHARACTER*(*) , INTENT(IN) :: Element INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -3119,7 +3119,7 @@ CHARACTER*(*) , INTENT(IN) :: Element INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -3280,7 +3280,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -3483,7 +3483,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -3688,7 +3688,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -3891,7 +3891,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -4096,7 +4096,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -4254,7 +4254,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -4414,7 +4414,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -4572,7 +4572,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -4732,7 +4732,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -4890,7 +4890,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -5050,7 +5050,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -5208,7 +5208,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -5368,7 +5368,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -5526,7 +5526,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -5686,7 +5686,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -5844,7 +5844,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -6004,7 +6004,7 @@ CHARACTER*(*) , INTENT(IN) :: DateStr INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -6164,7 +6164,7 @@ CHARACTER*(*) , INTENT(IN) :: DateStr INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -6325,7 +6325,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -6528,7 +6528,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -6733,7 +6733,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -6936,7 +6936,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -7141,7 +7141,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -7299,7 +7299,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -7459,7 +7459,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -7617,7 +7617,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -7777,7 +7777,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -7935,7 +7935,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -8095,7 +8095,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -8253,7 +8253,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -8413,7 +8413,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -8571,7 +8571,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -8731,7 +8731,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -8889,7 +8889,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -9049,7 +9049,7 @@ CHARACTER*(*) , INTENT(IN) :: VarName INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -9209,7 +9209,7 @@ CHARACTER*(*) , INTENT(IN) :: VarName INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -9370,7 +9370,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -9573,7 +9573,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -9778,7 +9778,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -9981,7 +9981,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -10186,7 +10186,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -10344,7 +10344,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -10504,7 +10504,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -10662,7 +10662,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -10822,7 +10822,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -10980,7 +10980,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -11140,7 +11140,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -11298,7 +11298,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -11458,7 +11458,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -11616,7 +11616,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: OutCount INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -11776,7 +11776,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -11934,7 +11934,7 @@ INTEGER , INTENT(IN) :: Count INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -12094,7 +12094,7 @@ CHARACTER*(*) , INTENT(IN) :: VarName INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package @@ -12254,7 +12254,7 @@ CHARACTER*(*) , INTENT(IN) :: VarName INTEGER , INTENT(OUT) :: Status -#include +#include "wrf_status_codes.h" INTEGER :: len_of_str LOGICAL :: for_out INTEGER, EXTERNAL :: use_package diff --git a/wrfv2_fire/arch/postamble_new b/wrfv2_fire/arch/postamble_new index 1738c3ef..31ede179 100644 --- a/wrfv2_fire/arch/postamble_new +++ b/wrfv2_fire/arch/postamble_new @@ -14,6 +14,7 @@ ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZ CONFIGURE_GRIB2_FLAG \ CONFIGURE_RTTOV_FLAG \ CONFIGURE_CRTM_FLAG \ + CONFIGURE_HDF5_FLAG \ CONFIGURE_CLOUDCV_FLAG \ CONFIGURE_4DVAR_FLAG \ CONFIGURE_WAVELET_FLAG \ @@ -21,6 +22,7 @@ ARCHFLAGS = $(COREDEFS) -DIWORDSIZE=$(IWORDSIZE) -DDWORDSIZE=$(DWORDSIZ -DUSE_ALLOCATABLES \ -DGRIB1 \ -DINTIO \ + -DKEEP_INT_AROUND \ -DLIMIT_ARGS \ -DCONFIG_BUF_LEN=$(CONFIG_BUF_LEN) \ -DMAX_DOMAINS_F=$(MAX_DOMAINS) \ @@ -58,13 +60,15 @@ CC_TOOLS_CFLAGS = CONFIGURE_NMM_CORE #NOWIN $(WRF_SRC_ROOT_DIR)/frame/pack_utils.o #NOWIN LIB_EXTERNAL = \ -#NOWIN CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PNETCDF_LIB_PATH CONFIGURE_GRIB2_LIB CONFIGURE_ATMOCN_LIB +#NOWIN CONFIGURE_NETCDF_LIB_PATH CONFIGURE_PNETCDF_LIB_PATH CONFIGURE_GRIB2_LIB CONFIGURE_ATMOCN_LIB CONFIGURE_HDF5_LIB_PATH LIB = $(LIB_BUNDLED) $(LIB_EXTERNAL) $(LIB_LOCAL) $(LIB_WRF_HYDRO) LDFLAGS = $(OMP) $(FCFLAGS) $(LDFLAGS_LOCAL) CONFIGURE_LDFLAGS ENVCOMPDEFS = CONFIGURE_COMPILEFLAGS CPPFLAGS = $(ARCHFLAGS) $(ENVCOMPDEFS) -I$(LIBINCLUDE) $(TRADFLAG) CONFIGURE_COMMS_INCLUDE NETCDFPATH = CONFIGURE_NETCDF_PATH +HDF5PATH = CONFIGURE_HDF5_PATH +WRFPLUSPATH = CONFIGURE_WRFPLUS_PATH PNETCDFPATH = CONFIGURE_PNETCDF_PATH bundled: io_only CONFIGURE_ATMOCN @@ -121,7 +125,7 @@ wrfio_grib2 : wrfio_int : ( cd $(WRF_SRC_ROOT_DIR)/external/io_int ; \ - make $(J) CC="$(CC)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ + make $(J) CC="$(CC)" CFLAGS_LOCAL="$(CFLAGS_LOCAL)" RM="$(RM)" RANLIB="$(RANLIB)" CPP="$(CPP)" \ FC="$(FC) $(PROMOTION) $(FCDEBUG) $(FCBASEOPTS) $(OMP)" FGREP="$(FGREP)" \ TRADFLAG="$(TRADFLAG)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ARCHFLAGS="$(ARCHFLAGS)" all ) diff --git a/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_args_to_update_rconst_racm_soa_vbs_aqchem.inc b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_args_to_update_rconst_racm_soa_vbs_aqchem.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_args_to_update_rconst_racm_soa_vbs_aqchem.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_args_update_rconst_racm_soa_vbs_aqchem.inc b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_args_update_rconst_racm_soa_vbs_aqchem.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_args_update_rconst_racm_soa_vbs_aqchem.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_decls_update_rconst_racm_soa_vbs_aqchem.inc b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_decls_update_rconst_racm_soa_vbs_aqchem.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/extra_decls_update_rconst_racm_soa_vbs_aqchem.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_a_racm_soa_vbs_aqchem.inc b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_a_racm_soa_vbs_aqchem.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_a_racm_soa_vbs_aqchem.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_b_racm_soa_vbs_aqchem.inc b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_b_racm_soa_vbs_aqchem.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_b_racm_soa_vbs_aqchem.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_e_racm_soa_vbs_aqchem.inc b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_e_racm_soa_vbs_aqchem.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_e_racm_soa_vbs_aqchem.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ia_racm_soa_vbs_aqchem.inc b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ia_racm_soa_vbs_aqchem.inc new file mode 100644 index 00000000..46d5712c --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ia_racm_soa_vbs_aqchem.inc @@ -0,0 +1,125 @@ +! RAR: modified to handle the new SOA mechanism based on the VBS approach and multi-generational +! VOC oxidation mechanism +! Correspondence between RACM and SAPRC-99 SOA precursors +! 1) OLT -> OLE1 +! 2) OLI -> OLE2 +! 3) TOL -> ARO1 +! 4) XYL -> ARO2 +! 5) CSL -> ARO2 +! 6) HC5 -> ALK4 +! 7) HC8 -> ALK5 +! 8) ISO -> ISO +! 9) API -> TERP +!10) LIM -> TERP +!11) SESQ-> SESQ +! +if(p_nu0.gt.1)then + + ! OLT + roltho = RCONST(66) + rolto3 = RCONST(106) + roltno3 = RCONST(98) + + ! OLI + roliho = RCONST(67) + rolio3 = RCONST(107) + rolino3 = RCONST(99) + + ! TOL + rtolho = RCONST(72) + + ! XYL + rxylho = RCONST(73) + + ! CSL + rcslho = RCONST(74) + rcslno3 = RCONST(96) + + ! HC5 + rhc5ho = RCONST(63) + + ! HC8 + rhc8ho = RCONST(64) + + ! ISO + risoho = RCONST(69) + risoo3 = RCONST(109) + risono3 = RCONST(101) + + ! API + rapiho = RCONST(70) + rapio3 = RCONST(110) + rapino3 = RCONST(102) + + ! LIM + rlimho = RCONST(71) + rlimo3 = RCONST(111) + rlimno3 = RCONST(103) + + ! SESQ + rsesqho = RCONST(245) + rsesqo3 = RCONST(246) + rsesqno3 = RCONST(247) + + ! Isoprene radical + risopno = RCONST(138) + risopho2 = RCONST(152) + risopmo2 = RCONST(178) + risopaco3= RCONST(198) + risopisop= RCONST(237) + + ! production from anthropogenic VOCs + PRDROG(PALK4)= rhc5ho*var(ind_hc5)*var(ind_ho) + PRDROG(PALK5)= rhc8ho*var(ind_hc8)*var(ind_ho) + + PRDROG(POLE1)= roltho*var(ind_olt)*var(ind_ho) + rolto3*var(ind_olt)*var(ind_o3) + roltno3*var(ind_olt)*var(ind_no3) + PRDROG(POLE2)= roliho*var(ind_oli)*var(ind_ho) + rolio3*var(ind_oli)*var(ind_o3) + rolino3*var(ind_oli)*var(ind_no3) + + PRDROG(PARO1)= rtolho*var(ind_tol)*var(ind_ho) + + PRDROG(PARO2)= rxylho*var(ind_xyl)*var(ind_ho) + PRDROG(PARO2)= PRDROG(PARO2) + rcslho*var(ind_csl)*var(ind_ho) + rcslno3*var(ind_csl)*var(ind_no3) + + ! Biogenic + PRDROG(PISOP)= risoho*var(ind_iso)*var(ind_ho) + risoo3*var(ind_iso)*var(ind_o3) + risono3*var(ind_iso)*var(ind_no3) + + PRDROG(PTERP)= rapiho*var(ind_api)*var(ind_ho) + rapio3*var(ind_api)*var(ind_o3) + rapino3*var(ind_api)*var(ind_no3) + PRDROG(PTERP)= PRDROG(PTERP) + rlimho*var(ind_lim)*var(ind_ho) + rlimo3*var(ind_lim)*var(ind_o3) + rlimno3*var(ind_lim)*var(ind_no3) + + PRDROG(PSESQ)= rsesqho*var(ind_sesq)*var(ind_ho) + rsesqo3*var(ind_sesq)*var(ind_o3) + rsesqno3*var(ind_sesq)*var(ind_no3) + +! RAR: to calculate the branching ratios to determine high NOx versus low NOx + + PRDROG(PBRCH)= risopno*var(ind_no) + + ! VDROG carrying the branching ratios + if (PRDROG(PBRCH)>1.E-12) then + ro2loss= PRDROG(PBRCH) + risopho2*var(ind_ho2) + risopmo2*var(ind_mo2) + risopaco3*var(ind_aco3) + & + risopisop*var(ind_isop) + VDROG3_VBS( i,k,j,LDROG_VBS )= MIN( 1.D0,(PRDROG(PBRCH)/ro2loss) ) + else + VDROG3_VBS( i,k,j,LDROG_VBS )= 0. + end if + + DO n = 1, LDROG_VBS-1 + VDROG3_VBS( i,k,j,n ) = oconv* PRDROG( n ) * DTSTEPC + VDROG3_VBS( i,k,j,n ) = MAX( 0., VDROG3_VBS( i,k,j,n ) ) + ENDDO +endif + +! RAR: debugging +!if (i==8 .AND. j==18) then +! if (k==1) then +! write(*,*)'rhch5ho',rhc5ho,'rhc8ho',rhc8ho,'rhc8ho',roltho,'roliho',roliho, & +! 'rtolho',rtolho,'rxylho',rxylho,'rsesqno3',rsesqno3 +! write(*,*)'ind_tol',ind_tol,'var(ind_tol)',var(ind_tol) +! write(*,*)'ind_ho',ind_ho,'var(ind_ho)',var(ind_ho) +! write(*,*)'ind_iso',ind_iso,'risoho',risoho +! write(*,*)'PRDROG(PBRCH)', PRDROG(PBRCH),'ro2loss=',ro2loss +! write(*,*)'VDROG3(8,1,18,:)', VDROG3(i,k,j,:) +! end if +!end if +! +!if (j==18 .AND. k==1) then +! write(*,*)'VDROG3(:,18,1,:)', VDROG3(i,k,j,:) +!end if diff --git a/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ib_racm_soa_vbs_aqchem.inc b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ib_racm_soa_vbs_aqchem.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ib_racm_soa_vbs_aqchem.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ibu_racm_soa_vbs_aqchem.inc b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ibu_racm_soa_vbs_aqchem.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_ibu_racm_soa_vbs_aqchem.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_l_racm_soa_vbs_aqchem.inc b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_l_racm_soa_vbs_aqchem.inc new file mode 100644 index 00000000..45e6eb2d --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_l_racm_soa_vbs_aqchem.inc @@ -0,0 +1,12 @@ +REAL(KIND=dp) :: roltho,rolto3,roltno3,roliho,rolio3,rolino3,rtolho,rxylho, & + rcslho,rcslno3,rhc5ho,rhc8ho,risoho,risoo3,risono3, & + rapiho,rapio3,rapino3,rlimho,rlimo3,rlimno3, & + rsesqho,rsesqo3,rsesqno3, & + risopno,risopho2,risopmo2,risopaco3,risopisop + +REAL(KIND=dp) , DIMENSION(ldrog_vbs) :: PRDROG +REAL(KIND=dp) :: ro2loss + +! for nrc_2o5 +REAL :: es, qvs, rh +REAL( KIND = dp ) :: rc_n2o5 diff --git a/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_u_racm_soa_vbs_aqchem.inc b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_u_racm_soa_vbs_aqchem.inc new file mode 100644 index 00000000..6f4f3bee --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/racm_soa_vbs_aqchem/kpp_mechd_u_racm_soa_vbs_aqchem.inc @@ -0,0 +1,16 @@ +! +INTEGER, PARAMETER :: palk4=1 +INTEGER, PARAMETER :: palk5=2 +INTEGER, PARAMETER :: pole1=3 +INTEGER, PARAMETER :: pole2=4 +INTEGER, PARAMETER :: paro1=5 +INTEGER, PARAMETER :: paro2=6 + +! biogenic +INTEGER, PARAMETER :: pisop=7 +INTEGER, PARAMETER :: pterp=8 +INTEGER, PARAMETER :: psesq=9 + +! for branching +INTEGER, PARAMETER :: pbrch=10 +!USE module_data_soa_vbs, ONLY : palk4,palk5,pole1,pole2,paro1,paro2,pisop,pterp,psesq,pbrch diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.def b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.def new file mode 100644 index 00000000..63a9de97 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.def @@ -0,0 +1,57 @@ +#include atoms_red +#include ./racm_soa_vbs_aqchem.spc +#include ./racm_soa_vbs_aqchem.eqn + +#INLINE F90_RATES +REAL(KIND=dp) FUNCTION k45( TEMP, C_M ) + REAL(KIND=dp), INTENT(IN) :: temp, c_m + REAL(KIND=dp) :: k0, k2, k3 + + k0=2.4E-14_dp * EXP(460._dp/TEMP) + k2=2.7E-17_dp * EXP(2199._dp/TEMP) + k3=6.5E-34_dp * EXP(1335._dp/TEMP) * c_m + + k45=k0+k3/(1+k3/k2) + +END FUNCTION k45 + +REAL(kind=dp) FUNCTION k57( TEMP, C_M ) + + INTRINSIC LOG10 + + REAL(KIND=dp), INTENT(IN) :: temp ! temperature [K] + REAL(KIND=dp), INTENT(IN) :: c_m ! air concentration [molecules/cm3] + REAL(KIND=dp) :: k0_300Kn ! low pressure limit at 300 K + REAL(KIND=dp) :: nn ! exponent for low pressure limit + REAL(KIND=dp) :: kinf_300Kn ! high pressure limit at 300 K + REAL(KIND=dp) :: mn ! exponent for high pressure limit + REAL(KIND=dp) :: zt_help, k0_T, kinf_T, k_ratio + REAL(KIND=dp) :: k57troe, k57cact + + k0_300Kn = 5.9e-33_dp + nn = 1.4_dp + kinf_300Kn = 1.1e-12_dp + mn = -1.3_dp + + zt_help = 300._dp/temp + k0_T = k0_300Kn * zt_help**(nn) * c_m ! k_0 at current T + kinf_T = kinf_300Kn * zt_help**(mn) ! k_inf at current T + k_ratio = k0_T/kinf_T + k57troe = k0_T/(1._dp+k_ratio)*0.6_dp**(1._dp/(1._dp+LOG10(k_ratio)**2)) + + k0_300Kn = 1.5e-13_dp + nn = -0.6_dp + kinf_300Kn = 2.9e9_dp + mn = -6.1_dp + + k0_T = k0_300Kn * zt_help**(nn)! k_0 at current T + kinf_T = kinf_300Kn * zt_help**(mn) / c_m ! k_inf at current T + k_ratio = k0_T/kinf_T + k57cact = k0_T/(1._dp+k_ratio)*0.6_dp**(1._dp/(1._dp+LOG10(k_ratio)**2)) + + k57 = k57troe + k57cact + +END FUNCTION k57 + +#ENDINLINE + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.eqn b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.eqn new file mode 100644 index 00000000..5780cb1f --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.eqn @@ -0,0 +1,258 @@ +#EQUATIONS {} + {001:J01} NO2+hv=O3P+NO : j(Pj_no2) ; + {002:J02} O3+hv=O1D{+O2} : j(Pj_o31d) ; + {003:J03} O3+hv=O3P{+O2} : j(Pj_o33p) ; + {004:J04} HONO+hv=HO+NO : j(Pj_hno2) ; + {005:J05} HNO3+hv=HO+NO2 : j(Pj_hno3) ; + {006:J06} HNO4+hv=0.65 HO2+0.65 NO2+0.35 HO+0.35 NO3 : j(Pj_hno4) ; + {007:J07} NO3+hv=NO{+O2} : j(Pj_no3o2) ; + {008:J08} NO3+hv=NO2+O3P : j(Pj_no3o) ; + {009:J09} H2O2+hv=HO+HO : j(Pj_h2o2) ; + {010:J10} HCHO+hv=CO{+H2} : j(Pj_ch2om) ; + {011:J11} HCHO+hv=HO2+HO2+CO : j(Pj_ch2or) ; + {012:J12} ALD+hv=MO2+HO2+CO : j(Pj_ch3cho) ; + {013:J13} OP1+hv=HCHO+HO2+HO : j(Pj_ch3o2h) ; + {014:J14} OP2+hv=ALD+HO2+HO : j(Pj_ch3coch3) ; + {015:J15} PAA+hv=MO2+HO : j(Pj_ch3coo2h) ; + {016:J16} KET+hv=ACO3+ETHP : j(Pj_ch3coc2h5) ; + {017:J17} GLY+hv=0.13 HCHO+1.87 CO{+0.87 H2} : j(Pj_hcocho) ; + {018:J18} GLY+hv=0.45 HCHO+1.55 CO+0.80 HO2{+0.15 H2} : j(Pj_hcochob) ; + {019:J19} MGLY+hv=ACO3+HO2+CO : j(Pj_ch3cocho) ; + {020:J20} DCB+hv=HO2+TCO3 : j(Pj_hcochest) ; + {021:J21} ONIT+hv=0.20 ALD+0.80 KET+HO2+NO2 : j(Pj_ch3ono2) ; + {022:J22} MACR+hv=CO+HCHO+HO2+ACO3 : j(Pj_macr) ; + {023:J23} HKET+hv=HCHO+HO2+ACO3 : j(Pj_ch3coc2h5) ; + {024:001} O3P+M{O2}=O3 : (C_M *6.00D-34*(TEMP/300.0)**(-2.4)) ; + {025:002} O3P+O3=M {2O2} : ARR2( 8.00D-12 , 2060.0_dp, TEMP) ; + {026:003} O1D + M = O3P : .78084*ARR2(2.15D-11 , -110.0_dp, TEMP) + .20946*ARR2( 3.30D-11 , -55.0_dp , TEMP ) ; + {027:004} O1D+H2O=HO+HO : ARR2( 1.63D-10 , -60.0_dp, TEMP ) ; + {028:005} O3+HO=HO2{+O2} : ARR2( 1.70D-12 , 940.0_dp, TEMP ) ; + {029:006} O3+HO2=HO{+2.0 O2} : ARR2( 1.0D-14 , 490.0_dp, TEMP ) ; + {030:007} HO+HO2=H2O{+O2} : ARR2( 4.80D-11 , -250.0_dp, TEMP ) ; + {031:008} H2O2+HO=HO2+H2O : 1.8D-12 ; + {032:009} HO2+HO2=H2O2{+O2} : (3.5D-13*EXP(430./TEMP) + 1.7D-33* C_M *EXP(1000./TEMP)) ; + {033:010} HO2+HO2+H2O=H2O2+H2O{+O2} : (4.9D-34* EXP(2630./TEMP)+ 2.38D-54* C_M *EXP(3200./TEMP)) ; + {034:011} O3P+NO=NO2 : TROE( 9.00D-32 , 1.5_dp , 3.00D-11 , 0.0_dp , TEMP, C_M) ; + {035:012} O3P+NO2=NO{+O2} : ARR2( 5.1D-12 , -210.0_dp, TEMP) ; + {036:013} O3P+NO2=NO3 : TROE( 2.5D-31 , 1.8_dp , 2.20D-11 , 0.7_dp , TEMP, C_M) ; + {037:014} NO+HO=HONO : TROE( 7.00D-31 , 2.6_dp , 3.6D-11 , 0.1_dp , TEMP, C_M) ; + {038:015} HO+NO2=HNO3 : TROE( 1.8D-30 , 3.0_dp , 2.8D-11 , 0.0_dp , TEMP, C_M) ; + {039:016} HO+NO3=NO2+HO2 : 2.20D-11 ; + {040:017} HO2+NO=NO2+HO : ARR2( 3.50D-12 , -250.0_dp, TEMP ) ; + {041:018} HO2+NO2=HNO4 : TROE( 2.0D-31 , 3.4_dp , 2.9D-12 , 1.1_dp , TEMP, C_M) ; + {042:019} HNO4=HO2+NO2 : TROEE( 4.76D26,10900.0_dp, 2.0D-31 , 3.4_dp , 2.9D-12 , 1.1_dp, TEMP, C_M ) ; + {043:020} HO2+NO3=0.3 HNO3+0.7 NO2+0.7 HO{+O2} : 3.50D-12 ; + {044:021} HO+HONO=NO2+H2O : ARR2( 1.80D-11 , 390.0_dp, TEMP ) ; + {045:022} HO+HNO3=NO3+H2O : k45(TEMP,C_M) ; + {046:023} HO+HNO4=NO2+H2O{+O2} : ARR2( 1.30D-12 , -380.0_dp, TEMP ) ; + {047:024} O3+NO=NO2{+O2} : ARR2( 3.0D-12 , 1500.0_dp, TEMP ) ; + {048:025} O3+NO2=NO3{+O2} : ARR2( 1.20D-13 , 2450.0_dp, TEMP ) ; + {049:026} NO+NO+M{O2}=NO2+NO2 : (.20946D0*ARR2( 3.30D-39 , -530.0_dp, TEMP )) ; + {050:027} NO3+NO=NO2+NO2 : ARR2( 1.50D-11 , -170.0_dp , TEMP) ; + {051:028} NO3+NO2=NO+NO2{+O2} : ARR2( 4.50D-14, 1260.0_dp, TEMP ) ; + {052:029} NO3+NO2=N2O5 : TROE( 2.0D-30 , 4.4_dp , 1.4D-12 , 0.7_dp , TEMP, C_M) ; + {053:030} N2O5=NO2+NO3 : TROEE(3.70D26,11000.0_dp, 2.0D-30 , 4.4_dp , 1.4D-12 , 0.7_dp, TEMP, C_M ) ; + {054:031} NO3+NO3=NO2+NO2{+O2} : ARR2( 8.50D-13 , 2450.0_dp, TEMP ) ; + {055:032} HO+M{=H2}=H2O+HO2 : (5.31D-7*ARR2( 2.8D-12 , 1800.0_dp, TEMP )) ;{fixed H2 (531ppb) Novelli '99} + {056:033} HO+SO2=SULF+HO2 : TROE( 3.3D-31 , 4.3_dp , 1.6D-12 , 0.0_dp , TEMP, C_M) ; + {057:034} CO+HO=HO2+CO2 : k57(TEMP,C_M) ; + {058:035} NALD+HO=HCHO+CO+NO2 : ARR2( 5.60D-12 , -270.0_dp, TEMP ) ; + {059:036} HACE+HO=MGLY+HO2 : 3.00D-12 ; + {060:037} CH4+HO=MO2+H2O : ARR2( 2.45D-12 , 1775.0_dp, TEMP ) ; + {061:038} ETH+HO=ETHP+H2O : ARR2( 8.7D-12 , 1070.0_dp, TEMP ); + {062:039} HC3+HO=0.583 HC3P+0.381 HO2+0.335 ALD+0.036 ORA1+0.036 CO+0.036 GLY+0.036 HO+0.010 HCHO+H2O : ARR2( 5.26D-12 , 260.0_dp, TEMP ) ; + {063:040} HC5+HO=0.75 HC5P+0.25 KET+0.25 HO2+H2O : ARR2( 8.02D-12 , 155.0_dp, TEMP ) ; + {064:041} HC8+HO=0.9511 HC8P+0.025 ALD+0.024 HKET+0.049 HO2+H2O : ARR2( 1.64D-11 , 125.0_dp, TEMP ) ; + {065:042} ETE+HO=ETEP : TROE( 1.0D-28 , 4.5_dp , 8.8D-12 , 0.85_dp , TEMP, C_M) ; + {066:043} OLT+HO=OLTP : ARR2( 5.72D-12 , -500.0_dp, TEMP ) ; + {067:044} OLI+HO=OLIP : ARR2( 1.33D-11 , -500.0_dp, TEMP ) ; + {068:045} DIEN+HO=ISOP : ARR2( 1.48D-11 , -448.0_dp, TEMP ) ; + {069:046} ISO+HO=ISOP : ARR2( 2.54D-11 , -410.0_dp, TEMP ) ; + {070:047} API+HO=APIP : ARR2( 1.21D-11 , -444.0_dp, TEMP ) ; + {071:048} LIM+HO=LIMP : 1.71D-10 ; + {072:049} TOL+HO=0.90 ADDT+0.10 XO2+0.10 HO2 : ARR2( 1.81D-12 , -338.0_dp, TEMP ) ; + {073:050} XYL+HO=0.90 ADDX+0.10 XO2+0.10 HO2 : ARR2( 7.30D-12 , -355.0_dp, TEMP ) ; + {074:051} CSL+HO=0.85 ADDC+0.10 PHO+0.05 HO2+0.05 XO2 : 6.8D-11 ; + {075:052} HCHO+HO=HO2+CO+H2O : ARR2( 5.5D-12 , -125.0_dp, TEMP ) ; + {076:053} ALD+HO=ACO3+H2O : ARR2( 5.6D-12 , -270.0_dp, TEMP ) ; + {077:054} KET+HO=KETP+H2O : (THERMAL_T2(5.68D-18, -92.0_dp,TEMP )) ; + {078:055} HKET+HO=HO2+MGLY+H2O : 3.00D-12 ; + {079:056} GLY+HO=HO2+2.0 CO+H2O : 1.15D-11 ; + {080:057} MGLY+HO=ACO3+CO+H2O : 1.72D-11 ; + {081:058} MACR+HO=MACP : .5*(4.13D-12*EXP(425./TEMP) + 1.86D-11*EXP(175./TEMP)) ; + {082:059} DCB+HO=0.50 TCO3+0.50 HO2+0.50 XO2+0.35 UDD+0.15 GLY+0.15 MGLY : ARR2( 2.80D-11 , -175.0_dp, TEMP ) ; + {083:060} UDD+HO=0.88 ALD+0.12 KET+HO2 : 2.70D-10 ; + {084:061} OP1+HO=0.65 MO2+0.35 HCHO+0.35 HO : ARR2( 3.8D-12 , -200.0_dp, TEMP ) ; + {085:062} OP2+HO=0.44 HC3P+0.08 ALD+0.41 KET+0.49 HO+0.07 XO2 : ARR2( 3.40D-12 , -190.0_dp, TEMP ) ; + {086:063} PAA+HO=0.35 HCHO+0.65 ACO3+0.35 HO2+0.35 XO2 : ARR2( 3.8D-12 , -200.0_dp, TEMP ) ; + {087:064} PAN+HO=HCHO+XO2+H2O+NO3 : 4.00D-14 ; + {088:065} TPAN+HO=0.60 HKET+0.40 HCHO+0.40 HO2+XO2+0.40 PAN+0.60 NO3 : ARR2( 3.25D-13 , -500.0_dp, TEMP ) ; + {089:066} ONIT+HO=HC3P+NO2+H2O : ARR2( 5.31D-12 , 260.0_dp , TEMP) ; + {090:067} HCHO+NO3=HO2+HNO3+CO : ARR2( 3.40D-13 , 1900.0_dp, TEMP ) ; + {091:068} ALD+NO3=ACO3+HNO3 : ARR2( 1.40D-12 , 1900.0_dp, TEMP ) ; + {092:069} GLY+NO3=HNO3+HO2+2.0 CO : ARR2( 2.90D-12 , 1900.0_dp, TEMP ) ; + {093:070} MGLY+NO3=HNO3+ACO3+CO : ARR2( 1.40D-12 , 1900.0_dp, TEMP ) ; + {094:071} MAHP+HO=MACP : 3.00D-11 ; + {095:072} DCB+NO3=0.5 TCO3+0.5 HO2+0.5 XO2+0.25 GLY+0.25 ALD+0.03 KET+0.25 MGLY+0.5 HNO3+0.5 NO2 : ARR2( 2.87D-13 , 1000.0_dp, TEMP ) ; + {096:073} CSL+NO3=HNO3+PHO : 2.20D-11 ; + {097:074} ETE+NO3=0.80 OLNN+0.20 OLND : (THERMAL_T2( 4.88D-18 , 2282.0_dp,TEMP )) ; + {098:075} OLT+NO3=0.43 OLNN+0.57 OLND : ARR2( 1.79D-13 , 450.0_dp, TEMP ) ; + {099:076} OLI+NO3=0.11 OLNN+0.89 OLND : ARR2( 8.64D-13 , -450.0_dp, TEMP ) ; + {100:077} DIEN+NO3=0.90 OLNN+0.10 OLND+0.90 MACR : 1.00D-13 ; + {101:078} ISO+NO3=ISON : ARR2( 3.03D-12 , 446.0_dp, TEMP ) ; + {102:079} API+NO3=0.10 OLNN+0.90 OLND : ARR2( 1.19D-12 , -490.0_dp, TEMP ) ; + {103:080} LIM+NO3=0.13 OLNN+0.87 OLND : 1.22D-11 ; + {104:081} TPAN+NO3=0.60 ONIT+0.60 NO3+0.40 PAN+0.40 HCHO+0.40 NO2+XO2 : ARR2( 2.20D-14 , 500.0_dp, TEMP ) ; + {105:082} ETE+O3=HCHO+0.43 CO+0.37 ORA1+0.26 HO2+0.12 HO{+0.13 H2} : ARR2( 1.2D-14 , 2630.0_dp, TEMP ) ; + {106:083} OLT+O3=0.64 HCHO+0.44 ALD+0.37 CO+0.14 ORA1+0.10 ORA2+0.25 HO2+0.40 HO+0.03 KET+0.03 KETP+0.06 CH4 +0.006 H2O2+0.03 ETH+0.19 MO2+0.10 ETHP{+0.05 H2} : ARR2( 4.33D-15, 1800.0_dp, TEMP ) ; + {107:084} OLI+O3=0.02 HCHO+0.99 ALD+0.16 KET+0.30 CO+0.011 H2O2+0.14 ORA2+0.07 CH4+0.22 HO2+0.63 HO+0.23 MO2+0.12 KETP+0.06 ETH+0.18 ETHP : ARR2( 4.40D-15 , 845.0_dp, TEMP ) ; + {108:085} DIEN+O3=0.90 HCHO+0.39 MACR+0.36 CO+0.15 ORA1+0.09 O3P+0.30 HO2+0.35 OLT+0.28 HO+0.15 ACO3+0.03 MO2+0.02 KETP+0.13 XO2+0.001 H2O2{+0.05 H2} : ARR2( 1.34D-14 , 2283.0_dp, TEMP ) ; + {109:086} ISO+O3=0.65 MACR+0.58 HCHO+0.1 MACP+0.1 ACO3+0.08 MO2+0.28 ORA1+0.14 CO+0.09 H2O2+0.25 HO2+0.25 HO : ARR2( 7.86D-15 , 1913.0_dp, TEMP ) ; + {110:087} API+O3=0.65 ALD+0.53 KET+0.14 CO+0.20 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2 : ARR2( 1.01D-15 , 732.0_dp, TEMP ) ; + {111:088} LIM+O3=0.04 HCHO+0.46 OLT+0.14 CO+0.16 ETHP+0.42 KETP+0.85 HO+0.10 HO2+0.02 H2O2+0.79 MACR+0.01 ORA1+0.07 ORA2 : 2.00D-16 ; + {112:089} MACR+O3=0.9 MGLY+0.45 ORA1+0.32 HO2+0.22 CO+0.19 HO+0.1 ACO3 : .5*(1.36D-15*EXP(-2112./TEMP)+7.51D-16*EXP(-1521./TEMP)) ; + {113:090} DCB+O3=0.21 HO+0.29 HO2+0.66 CO+0.50 GLY+0.28 ACO3+0.16 ALD+0.62 MGLY+0.11 PAA+0.11 ORA1+0.21 ORA2 : 2.00D-18 ; + {114:091} TPAN+O3=0.70 HCHO+0.30 PAN+0.70 NO2+0.13 CO+0.11 ORA1+0.08 HO2+0.036 HO+0.70 ACO3{+0.04 H2} : ARR2( 2.46D-15 , 1700.0_dp, TEMP ) ; + {115:092} PHO+NO2=0.10 CSL+ONIT : 2.00D-11 ; + {116:093} PHO+HO2=CSL : 1.00D-11 ; + {117:094} ADDT+NO2=CSL+HONO : 3.60D-11 ; + {118:095} ADDT+M {O2}=0.98 TOLP+0.02 CSL+0.02 HO2 : (.20946D0*ARR2( 1.66D-17 , -1044.0_dp, TEMP )) ; + {119:096} ADDT+O3=CSL+HO : 5.00D-11 ; + {120:097} ADDX+NO2=CSL+HONO : 3.60D-11 ; + {121:098} ADDX+M{O2}=0.98 XYLP+0.02 CSL+0.02 HO2 : (.20946D0*ARR2( 1.66D-17 , -1044.0_dp, TEMP )) ; + {122:099} ADDX+O3=CSL+HO : 1.00D-11 ; + {123:100} ADDC+NO2=CSL+HONO : 3.60D-11 ; + {124:101} ADDC+M{O2}=0.98 CSLP+0.02 CSL+0.02 HO2 : (.20946D0*ARR2( 1.66D-17 , -1044.0_dp, TEMP )) ; + {125:102} ADDC+O3=CSL+HO : 5.00D-11 ; + {126:103} ACO3+NO2=PAN : TROE( 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M) ; + {127:104} PAN=ACO3+NO2 : TROEE(1.11D28,14000.0_dp, 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M) ; + {128:105} TCO3+NO2=TPAN : TROE( 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M) ; + {129:106} TPAN=TCO3+NO2 : TROEE(1.11D28,14000.0_dp, 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M ) ; + {130:107} MO2+NO=HCHO+HO2+NO2 : ARR2( 2.8D-12 , -300.0_dp, TEMP ) ; + {131:108} ETHP+NO=ALD+HO2+NO2 : ARR2( 2.6D-12 , -365.0_dp, TEMP ); + {132:109} HC3P+NO=0.047 HCHO+0.233 ALD+0.623 KET+0.063 GLY+0.742 HO2+0.15 MO2+0.048 ETHP+0.048 XO2+0.059 ONIT+0.941 NO2 : 4.00D-12 ; + {133:110} HC5P+NO=0.021 HCHO+0.211 ALD+0.722 KET+0.599 HO2+0.031 MO2+0.245 ETHP+0.334 XO2+0.124 ONIT+0.876 NO2 : 4.00D-12 ; + {134:111} HC8P+NO=0.15 ALD+0.642 KET+0.133 ETHP+0.261 ONIT+0.739 NO2+0.606 HO2+0.416 XO2 : 4.00D-12 ; + {135:112} ETEP+NO=1.6 HCHO+HO2+NO2+0.2 ALD : 9.00D-12 ; + {136:113} OLTP+NO=0.94 ALD+HCHO+HO2+NO2+0.06 KET : 4.00D-12 ; + {137:114} OLIP+NO=HO2+1.71 ALD+0.29 KET+NO2 : 4.00D-12 ; + {138:115} ISOP+NO=MACR+NO2+HCHO+HO2+0.046 ISON : ARR2( 2.43D-12 , -360.0_dp, TEMP ) ; + {139:116} APIP+NO=0.80 HO2+0.80 ALD+0.80 KET+0.20 ONIT+0.80 NO2 : 4.00D-12 ; + {140:117} LIMP+NO=0.65 HO2+0.40 MACR+0.25 OLI+0.25 HCHO+0.35 ONIT+0.65 NO2 : 4.00D-12 ; + {141:118} TOLP+NO=0.95 NO2+0.95 HO2+0.65 MGLY+1.20 GLY+0.50 DCB+0.05 ONIT : 4.00D-12 ; + {142:119} XYLP+NO=0.95 NO2+0.95 HO2+0.60 MGLY+0.35 GLY+0.95 DCB+0.05 ONIT : 4.00D-12 ; + {143:120} CSLP+NO=GLY+MGLY+HO2+NO2 : 4.00D-12 ; + {144:121} ACO3+NO=MO2+NO2 : ARR2( 8.1D-12 , -270.0_dp, TEMP ) ; + {145:122} TCO3+NO=ACO3+HCHO+NO2 : ARR2( 8.1D-12 , -270.0_dp, TEMP ) ; + {146:123} KETP+NO=0.54 MGLY+0.46 ALD+0.23 ACO3+0.77 HO2+0.16 XO2+NO2 : 4.00D-12 ; + {147:124} OLNN+NO=HO2+ONIT+NO2 : 4.00D-12 ; + {148:125} OLND+NO=0.287 HCHO+1.24 ALD+0.464 KET+2.0 NO2 : 4.00D-12 ; + {149:126} MO2+HO2=OP1 : ARR2( 4.1D-13 , -750.0_dp, TEMP ) ; + {150:127} ETHP+HO2=OP2 : ARR2( 7.4D-13 , -700.0_dp, TEMP ) ; + {151:128} HC3P+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {152:129} HC5P+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {153:130} HC8P+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {154:131} ETEP+HO2=OP2 : ARR2( 1.90D-13 , -1300.0_dp, TEMP ) ; + {155:132} OLTP+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {156:133} OLIP+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {157:134} ISOP+HO2=ISHP : ARR2( 2.05D-13 , -1300.0_dp, TEMP ) ; + {158:135} APIP+HO2=OP2 : 1.50D-11 ; + {159:136} LIMP+HO2=OP2 : 1.50D-11 ; + {160:137} TOLP+HO2=OP2 : ARR2( 3.75D-13 , -980.0_dp, TEMP ) ; + {161:138} XYLP+HO2=OP2 : ARR2( 3.75D-13 , -980.0_dp, TEMP) ; + {162:139} CSLP+HO2=OP2 : ARR2( 3.75D-13 , -980.0_dp, TEMP ) ; + {163:140} ACO3+HO2=PAA : 4.3D-13*EXP(1040./TEMP)/(1.+0.027*EXP(660./TEMP)) ; + {164:141} ACO3+HO2=ORA2+O3 : 4.3D-13*EXP(1040./TEMP)/(1.+37.*EXP(-660./TEMP)) ; + {165:142} TCO3+HO2=OP2 : 4.3D-13*EXP(1040./TEMP)/(1.+0.027*EXP(660./TEMP)) ; + {166:143} TCO3+HO2=ORA2+O3 : 4.3D-13*EXP(1040./TEMP)/(1.+37.*EXP(-660./TEMP)) ; + {167:144} KETP+HO2=OP2 : ARR2( 1.15D-13 , -1300.0_dp, TEMP ) ; + {168:145} OLNN+HO2=ONIT : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {169:146} OLND+HO2=ONIT : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {170:147} MO2+MO2=1.33 HCHO+0.66 HO2 : ARR2( 9.5D-14 , -390.0_dp, TEMP ) ; + {171:148} ETHP+MO2=0.75 HCHO+HO2+0.75 ALD : ARR2( 1.18D-13 , -158.0_dp, TEMP ) ; + {172:149} HC3P+MO2=0.81 HCHO+0.992 HO2+0.58 ALD+0.018 KET+0.007 MO2+0.005 MGLY+0.085 XO2+0.119 GLY : ARR2( 9.46D-14 , -431.0_dp , TEMP) ; + {173:150} HC5P+MO2=0.829 HCHO+0.946 HO2+0.523 ALD+0.24 KET+0.014 ETHP+0.049 MO2+0.245 XO2 : ARR2( 1.00D-13 , -467.0_dp, TEMP ) ; + {174:151} HC8P+MO2=0.753 HCHO+0.993 HO2+0.411 ALD+0.419 KET+0.322 XO2+0.013 ETHP : ARR2( 4.34D-14 , -633.0_dp, TEMP ) ; + {175:152} ETEP+MO2=1.55 HCHO+HO2+0.35 ALD : ARR2( 1.71D-13 , -708.0_dp, TEMP ) ; + {176:153} OLTP+MO2=1.25 HCHO+HO2+0.669 ALD+0.081 KET : ARR2( 1.46D-13 , -708.0_dp, TEMP ) ; + {177:154} OLIP+MO2=0.755 HCHO+HO2+0.932 ALD+0.313 KET : ARR2( 9.18D-14 , -708.0_dp, TEMP ) ; + {178:155} ISOP+MO2=0.550 MACR+0.370 OLT+HO2+0.08 OLI+1.09 HCHO : ARR2( 1.36D-13 , -708.0_dp, TEMP ) ; + {179:156} APIP+MO2=HCHO+ALD+KET+2.0 HO2 : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {180:157} LIMP+MO2=1.4 HCHO+0.60 MACR+0.40 OLI+2.0 HO2 : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {181:158} TOLP+MO2=HCHO+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {182:159} XYLP+MO2=HCHO+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {183:160} CSLP+MO2=GLY+MGLY+HCHO+2.0 HO2 : ARR2( 3.56D-14 , -708.0_dp, TEMP ) ; + {184:161} ACO3+MO2=HCHO+HO2+MO2 : ARR2( 1.8D-12 , -500.0_dp, TEMP ) ; + {185:162} ACO3+MO2=HCHO+ORA2 : ARR2( 2.0D-13 , -500.0_dp, TEMP ) ; + {186:163} TCO3+MO2=2.0 HCHO+HO2+ACO3 : ARR2( 1.8D-12 , -500.0_dp, TEMP ) ; + {187:164} TCO3+MO2=HCHO+ORA2 : ARR2( 2.0D-13 , -500.0_dp, TEMP ) ; + {188:165} KETP+MO2=0.75 HCHO+0.88 HO2+0.40 MGLY+0.30 ALD+0.30 HKET+0.12 ACO3+0.08 XO2 : ARR2( 6.91D-13 , -508.0_dp, TEMP ) ; + {189:166} OLNN+MO2=0.75 HCHO+HO2+ONIT : ARR2( 1.60D-13 , -708.0_dp, TEMP ) ; + {190:167} OLND+MO2=0.96 HCHO+0.5 HO2+0.64 ALD+0.149 KET+0.5 NO2+0.5 ONIT : ARR2( 9.68D-14 , -708.0_dp, TEMP ) ; + {191:168} ETHP+ACO3=ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 1.03D-12 , -211.0_dp, TEMP ) ; + {192:169} HC3P+ACO3=0.724 ALD+0.127 KET+0.488 HO2+0.508 MO2+0.006 ETHP+0.071 XO2+0.091 HCHO+0.10 GLY+0.499 ORA2+0.004 MGLY : ARR2( 6.90D-13 , -460.0_dp, TEMP ) ; + {193:170} HC5P+ACO3=0.677 ALD+0.33 KET+0.438 HO2+0.554 MO2+0.495 ORA2+0.018 ETHP+0.237 XO2+0.076 HCHO : ARR2( 5.59D-13 , -522.0_dp, TEMP ) ; + {194:171} HC8P+ACO3=0.497 ALD+0.581 KET+0.489 HO2+0.507 MO2+0.495 ORA2+0.015 ETHP+0.318 XO2 : ARR2( 2.47D-13 , -683.0_dp, TEMP ) ; + {195:172} ETEP+ACO3=0.8 HCHO+0.6 ALD+0.5 HO2+0.5 MO2+0.5 ORA2 : ARR2( 9.48D-13 , -765.0_dp, TEMP ) ; + {196:173} OLTP+ACO3=0.859 ALD+0.501 HCHO+0.501 HO2+0.501 MO2+0.499 ORA2+0.141 KET : ARR2( 8.11D-13 , -765.0_dp, TEMP ) ; + {197:174} OLIP+ACO3=0.941 ALD+0.569 KET+0.51 HO2+0.51 MO2+0.49 ORA2 : ARR2( 5.09D-13 , -765.0_dp, TEMP ) ; + {198:175} ISOP+ACO3=0.771 MACR+0.229 OLT+0.506 HO2+0.494 ORA2+0.340 HCHO+0.506 MO2 : ARR2( 7.60D-13 , -765.0_dp, TEMP ) ; + {199:176} APIP+ACO3=ALD+KET+HO2+MO2 : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {200:177} LIMP+ACO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+MO2 : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {201:178} TOLP+ACO3=MO2+HO2+0.35 MGLY+0.65 GLY+DCB : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {202:179} XYLP+ACO3=MO2+HO2+0.63 MGLY+0.37 GLY+DCB : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {203:180} CSLP+ACO3=GLY+MGLY+MO2+HO2 : ARR2( 7.40D-13 , -765.0_dp, TEMP ) ; + {204:181} ACO3+ACO3=2.0 MO2 : ARR2( 2.5D-12 , -500.0_dp, TEMP ) ; + {205:182} TCO3+ACO3=MO2+ACO3+HCHO : ARR2( 2.5D-12 , -500.0_dp, TEMP ) ; + {206:183} KETP+ACO3=0.54 MGLY+0.35 ALD+0.11 KET+0.12 ACO3+0.38 HO2+0.08 XO2+0.5 MO2+0.5 ORA2 : ARR2( 7.51D-13 , -565.0_dp, TEMP ) ; + {207:184} OLNN+ACO3=ONIT+0.5 ORA2+0.5 MO2+0.5 HO2 : ARR2( 8.85D-13 , -765.0_dp, TEMP ) ; + {208:185} OLND+ACO3=0.207 HCHO+0.65 ALD+0.167 KET+0.484 ORA2+0.484 ONIT+0.516 NO2+0.516 MO2 : ARR2( 5.37D-13 , -765.0_dp, TEMP ) ; + {209:186} OLNN+OLNN=2.0 ONIT+HO2 : ARR2( 7.00D-14 , -1000.0_dp , TEMP) ; + {210:187} OLNN+OLND=0.202 HCHO+0.64 ALD+0.149 KET+0.50 HO2+1.50 ONIT+0.50 NO2 : ARR2( 4.25D-14 , -1000.0_dp, TEMP ) ; + {211:188} OLND+OLND=0.504 HCHO+1.21 ALD+0.285 KET+ONIT+NO2 : ARR2( 2.96D-14 , -1000.0_dp, TEMP ) ; + {212:189} MO2+NO3=HCHO+HO2+NO2 : 1.20D-12 ; + {213:190} ETHP+NO3=ALD+HO2+NO2 : 1.20D-12 ; + {214:191} HC3P+NO3=0.048 HCHO+0.243 ALD+0.67 KET+0.063 GLY+0.792 HO2+0.155 MO2+0.053 ETHP+0.051 XO2+NO2 : 1.20D-12 ; + {215:192} HC5P+NO3=0.021 HCHO+0.239 ALD+0.828 KET+0.699 HO2+0.04 MO2+0.262 ETHP+0.391 XO2+NO2 : 1.20D-12 ; + {216:193} HC8P+NO3=0.187 ALD+0.88 KET+0.845 HO2+0.155 ETHP+0.587 XO2+NO2 : 1.20D-12 ; + {217:194} ETEP+NO3=1.6 HCHO+0.2 ALD+HO2+NO2 : 1.20D-12 ; + {218:195} OLTP+NO3=HCHO+0.94 ALD+0.06 KET+HO2+NO2 : 1.20D-12 ; + {219:196} OLIP+NO3=1.71 ALD+0.29 KET+HO2+NO2 : 1.20D-12 ; + {220:197} MPAN+HO=HACE+NO2 : 3.2D-11 ; + {221:198} APIP+NO3=ALD+KET+HO2+NO2 : 1.20D-12 ; + {222:199} LIMP+NO3=0.60 MACR+0.40 OLI+0.40 HCHO+HO2+NO2 : 1.20D-12 ; + {223:200} TOLP+NO3=0.70 MGLY+1.30 GLY+0.50 DCB+HO2+NO2 : 1.20D-12 ; + {224:201} XYLP+NO3=1.26 MGLY+0.74 GLY+DCB+HO2+NO2 : 1.20D-12 ; + {225:202} CSLP+NO3=GLY+MGLY+HO2+NO2 : 1.20D-12; + {226:203} ACO3+NO3=MO2+NO2 : 4.00D-12; + {227:204} TCO3+NO3=HCHO+ACO3+NO2 : 4.00D-12; + {228:205} KETP+NO3=0.54 MGLY+0.46 ALD+0.77 HO2+0.23 ACO3+0.16 XO2+NO2 : 1.20D-12 ; + {229:206} OLNN+NO3=ONIT+HO2+NO2 : 1.20D-12 ; + {230:207} OLND+NO3=0.28 HCHO+1.24 ALD+0.469 KET+2.0 NO2 : 1.20D-12 ; + {231:208} XO2+HO2=OP2 : ARR2( 1.66D-13 , -1300.0_dp, TEMP ) ; + {232:209} XO2+MO2=HCHO+HO2 : ARR2( 5.99D-15 , -1510.0_dp, TEMP ) ; + {233:210} XO2+ACO3=MO2 : ARR2( 3.40D-14 , -1560.0_dp, TEMP ) ; + {234:211} XO2+XO2=M{O2} : ARR2( 7.13D-17 , -2950.0_dp, TEMP ) ; + {235:212} XO2+NO=NO2 : 4.00D-12 ; + {236:213} XO2+NO3=NO2 : 1.20D-12 ; + {237:214} ISOP+ISOP=2. MACR+HCHO+HO2 : 2.00D-12 ; + {238:215} ISHP+HO=MACR+HO : 1.00D-10 ; + {239:216} ISON+HO=HACE+NALD : 1.30D-11 ; + {240:217} MACP+NO=NO2+0.25 HACE+0.25 CO+0.25 ACO3+0.5 MGLY+0.75 HCHO+0.75 HO2 : ARR2( 2.54D-12 , -360.0_dp, TEMP ) ; + {241:218} MACP+HO2=MAHP : ARR2( 1.82D-13 , -1300.0_dp, TEMP ) ; + {242:219} MACP+MACP=HACE+MGLY+0.5 HCHO+0.5 CO+HO2 : 2.00D-12 ; + {243:220} MACP+NO2=MPAN : TROE( 9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M) ; + {244:221} MPAN=MACP+NO2 : TROEE(1.11D28,14000.0_dp,9.70D-29 , 5.6_dp , 9.30D-12 , 1.5_dp , TEMP, C_M ) ; + {245:222} SESQ+HO=0.36 KET+0.3 HCHO+0.05 ORA1+0.19 OLIP : 2.52D-10 ; + {246:223} SESQ+O3=0.51 HCHO+0.85 ALD+0.039 ORA1+0.23 KET+0.053 ORA2+0.63 HO : 5.60D-16 ; + {247:224} SESQ+NO3=0.9 OLNN+0.10 OLND+0.9 MACR : 2.20D-11 ; + {248:225} MBO+HO=OLIP : ARR2( 1.33D-11 , -500.0_dp, TEMP ) ; + {249:226} MBO+NO3=0.11 OLNN+0.89 OLND : ARR2( 8.64D-13 , -450.0_dp, TEMP ) ; + {250:227} MBO+O3=0.02 HCHO+0.99 ALD+0.16 KET+0.30 CO+0.011 H2O2+0.14 ORA2+0.07 CH4+0.22 HO2+0.63 HO+0.23 MO2+0.12 KETP+0.06 ETH+0.18 ETHP : ARR2( 4.40D-15 , 845.0_dp, TEMP ) ; + {251:228} CVASOA4+HO=1.075 CVASOA3+HO : ARR2(1.0D-11, 0.0_dp, TEMP); + {252:229} CVASOA3+HO=1.075 CVASOA2+HO : ARR2(1.0D-11, 0.0_dp, TEMP); + {253:230} CVASOA2+HO=1.075 CVASOA1+HO : ARR2(1.0D-11, 0.0_dp, TEMP); + {254:231} CVBSOA4+HO=1.075 CVBSOA3+HO : ARR2(1.0D-11, 0.0_dp, TEMP); + {255:232} CVBSOA3+HO=1.075 CVBSOA2+HO : ARR2(1.0D-11, 0.0_dp, TEMP); + {256:233} CVBSOA2+HO=1.075 CVBSOA1+HO : ARR2(1.0D-11, 0.0_dp, TEMP); + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.kpp b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.kpp new file mode 100644 index 00000000..a9417869 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.kpp @@ -0,0 +1,10 @@ +#MODEL racm_soa_vbs_aqchem +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.spc b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.spc new file mode 100644 index 00000000..8c038095 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem.spc @@ -0,0 +1,98 @@ +#DEFVAR + O3 =IGNORE ; + H2O2 =IGNORE ; + NO =IGNORE ; + NO2 =IGNORE ; + NO3 =IGNORE ; + N2O5 =IGNORE ; + HONO =IGNORE ; + HNO3 =IGNORE ; + HNO4 =IGNORE ; + SO2 =IGNORE ; + SULF =IGNORE ; + CO =IGNORE ; + CO2 =IGNORE ; + CH4 =IGNORE ; + ETH =IGNORE ; + HC3 =IGNORE ; + HC5 =IGNORE ; + HC8 =IGNORE ; + ETE =IGNORE ; + OLT =IGNORE ; + OLI =IGNORE ; + DIEN =IGNORE ; + ISO =IGNORE ; + API =IGNORE ; + LIM =IGNORE ; + TOL =IGNORE ; + XYL =IGNORE ; + CSL =IGNORE ; + HCHO =IGNORE ; + ALD =IGNORE ; + KET =IGNORE ; + GLY =IGNORE ; + MGLY =IGNORE ; + DCB =IGNORE ; + MACR =IGNORE ; + UDD =IGNORE ; + HKET =IGNORE ; + ONIT =IGNORE ; + PAN =IGNORE ; + TPAN =IGNORE ; + OP1 =IGNORE ; + OP2 =IGNORE ; + PAA =IGNORE ; + ORA1 =IGNORE ; + ORA2 =IGNORE ; + HO =IGNORE ; + HO2 =IGNORE ; + O3P =IGNORE ; + O1D =IGNORE ; + MO2 =IGNORE ; + ETHP =IGNORE ; + HC3P =IGNORE ; + HC5P =IGNORE ; + HC8P =IGNORE ; + ETEP =IGNORE ; + OLTP =IGNORE ; + OLIP =IGNORE ; + ISOP =IGNORE ; + APIP =IGNORE ; + LIMP =IGNORE ; + PHO =IGNORE ; + ADDT =IGNORE ; + ADDX =IGNORE ; + ADDC =IGNORE ; + TOLP =IGNORE ; + XYLP =IGNORE ; + CSLP =IGNORE ; + ACO3 =IGNORE ; + TCO3 =IGNORE ; + KETP =IGNORE ; + OLNN =IGNORE ; + OLND =IGNORE ; + XO2 =IGNORE ; + HACE =IGNORE ; + ISHP =IGNORE ; + ISON =IGNORE ; + MACP =IGNORE ; + MAHP =IGNORE ; + MPAN =IGNORE ; + NALD =IGNORE ; + SESQ =IGNORE ; + MBO =IGNORE ; + CVASOA4 =IGNORE; + CVASOA3 =IGNORE; + CVASOA2 =IGNORE; + CVASOA1 =IGNORE; + CVBSOA4 =IGNORE; + CVBSOA3 =IGNORE; + CVBSOA2 =IGNORE; + CVBSOA1 =IGNORE; +#DEFFIX + H2O = IGNORE ; {water} + M = IGNORE ; +{ H2O = H+2O ;} +{ N2 = N+N ;} +{ O2 = IGNORE ;} +{ H2 = IGNORE ;} diff --git a/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem_wrfkpp.equiv new file mode 100644 index 00000000..e4c23b7a --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/racm_soa_vbs_aqchem/racm_soa_vbs_aqchem_wrfkpp.equiv @@ -0,0 +1,9 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +rpho pho + diff --git a/wrfv2_fire/chem/KPP/util/write_decomp/write_decomp.F b/wrfv2_fire/chem/KPP/util/write_decomp/write_decomp.F index 325aa1bc..215c0b60 100644 --- a/wrfv2_fire/chem/KPP/util/write_decomp/write_decomp.F +++ b/wrfv2_fire/chem/KPP/util/write_decomp/write_decomp.F @@ -4,7 +4,7 @@ PROGRAM write_decomp ! inspired by a code from Edwin Spee, CWI, Amsterdam ! -#include +#include "decomp_uses.inc" IMPLICIT NONE diff --git a/wrfv2_fire/chem/Makefile b/wrfv2_fire/chem/Makefile index d61256c7..cdc7351d 100755 --- a/wrfv2_fire/chem/Makefile +++ b/wrfv2_fire/chem/Makefile @@ -78,6 +78,8 @@ MODULES = \ module_qf03.o \ module_soilpsd.o \ module_dust_load.o \ + module_uoc_dustwd.o \ + module_data_uoc_wd.o \ module_mosaic_addemiss.o \ module_mosaic_initmixrats.o \ module_mosaic_movesect.o \ @@ -121,6 +123,7 @@ MODULES = \ module_plumerise1.o \ module_mosaic_drydep.o \ module_wetscav_driver.o \ + module_prep_wetscav_sorgam.o \ module_input_chem_bioemiss.o \ module_input_dust_errosion.o \ module_input_gocart_dms.o \ diff --git a/wrfv2_fire/chem/aerosol_driver.F b/wrfv2_fire/chem/aerosol_driver.F index 873fe8e4..c16c3300 100755 --- a/wrfv2_fire/chem/aerosol_driver.F +++ b/wrfv2_fire/chem/aerosol_driver.F @@ -289,7 +289,7 @@ SUBROUTINE aerosols_driver (id,curr_secs,ktau,dtstep,ktauc, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE ( RACM_SOA_VBS_KPP ) + CASE ( RACM_SOA_VBS_KPP, RACM_SOA_VBS_AQCHEM_KPP ) CALL wrf_debug(15,'aerosols_driver calling soa_vbs_driver') do ii=its,ite do kk=kts,kte @@ -482,7 +482,7 @@ SUBROUTINE sum_pm_driver ( config_flags, & config_flags%dust_opt,ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (CB05_SORG_VBS_AQ_KPP) + CASE (CB05_SORG_VBS_AQ_KPP) CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_sorgam_vbs') CALL sum_pm_sorgam_vbs ( & alt, chem, h2oaj, h2oai, & diff --git a/wrfv2_fire/chem/chem_driver.F b/wrfv2_fire/chem/chem_driver.F index 60b8c43f..4a5b00f2 100755 --- a/wrfv2_fire/chem/chem_driver.F +++ b/wrfv2_fire/chem/chem_driver.F @@ -40,6 +40,7 @@ subroutine chem_driver ( grid , config_flags & USE module_input_tracer, only: set_tracer USE module_wetscav_driver, only: wetscav_driver USE module_wetdep_ls, only:wetdep_ls + USE module_uoc_dustwd ! Claudia, 3 April 2014 [mklose 03082015] USE module_input_chem_data, only: last_chem_time, & #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K)) chem_dbg, & @@ -192,7 +193,7 @@ end SUBROUTINE sum_pm_driver TYPE(domain) , TARGET :: grid ! ! Definitions of dummy arguments to solve -# include +# include "dummy_new_decl.inc" # define NO_I1_OLD TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags @@ -280,6 +281,7 @@ end SUBROUTINE sum_pm_driver ! emissions_driver ! photolysis_driver ! dry_dep_driver +! uoc_dustwd_driver ! grelldrvct (convective tracer transport) ! mechanism_driver (gases) ! cloud_chem_driver @@ -475,6 +477,10 @@ end SUBROUTINE sum_pm_driver CASE (RACM_SOA_VBS_KPP) CALL wrf_debug(15,'calling racm_soa_vbs_kpp aerosols driver from chem_driver') haveaer = .false. +!!! TUCCELLA + CASE (RACM_SOA_VBS_AQCHEM_KPP) + CALL wrf_debug(15,'calling racm_soa_vbs_aqchem_kpp aerosols driver from chem_driver') + haveaer = .false. CASE (GOCART_SIMPLE) CALL wrf_debug(15,'calling only gocart aerosols driver from chem_driver') haveaer = .false. @@ -627,8 +633,10 @@ end SUBROUTINE sum_pm_driver enddo enddo select case (config_flags%chem_opt) +!!! TUCCELLA case (RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & - RACM_ESRLSORG_KPP,RACMSORG_AQ,RACMSORG_KPP, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RACM_SOA_VBS_KPP) + RACM_ESRLSORG_KPP,RACMSORG_AQ,RACMSORG_KPP, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, & + RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) do j=jps,jpe do k=kps,kpe do i=ips,ipe @@ -1028,8 +1036,32 @@ end SUBROUTINE sum_pm_driver end if - - +! cfrick - 2014 - WET DEPOSITION OF DUST FOLLOWING JUNG (2004) - mklose [03082015] + if(config_flags%dustwd_onoff>0)then + if(config_flags%mp_physics.ne.2 .and. config_flags%mp_physics.ne.10) then ! mklose [03032015] + write(msg,*)'CHEM_DRIVER - UoC wet deposition is not yet implemented for this & + & microphysics option, mp_physics=', config_flags%mp_physics, & + & ' and dustwd_onoff=', config_flags%dustwd_onoff + call wrf_error_fatal( msg ) + endif + + call wrf_debug(15,'UoC dust wet deposition') + call uoc_dustwd_driver(grid%precr,chem,p_phy,t_phy, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + dtstepc, & + grid%dustwd_1, grid%dustwd_2, & + grid%dustwd_3, grid%dustwd_4, & + grid%dustwd_5, & + grid%wetdep_1, grid%wetdep_2, & + grid%wetdep_3, grid%wetdep_4, & + grid%wetdep_5, & + grid%dustwdload_1, grid%dustwdload_2, & + grid%dustwdload_3, grid%dustwdload_4, & + grid%dustwdload_5, & + rri, dz8w, epsilc ) + endif ! ! convective transport/wet deposition ! @@ -1173,7 +1205,7 @@ end SUBROUTINE sum_pm_driver moist, & vdrog3, ldrog, vdrog3_vbs, ldrog_vbs, & ! -#include +#include "call_to_kpp_mech_drive.inc" ! ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & diff --git a/wrfv2_fire/chem/chemics_init.F b/wrfv2_fire/chem/chemics_init.F index 249e5460..90f10502 100755 --- a/wrfv2_fire/chem/chemics_init.F +++ b/wrfv2_fire/chem/chemics_init.F @@ -59,6 +59,10 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, USE module_cam_mam_wetscav, only:wetscav_cam_mam_driver_init USE module_cam_support, only: numgas_mam, gas_pcnst_modal_aero,gas_pcnst_modal_aero_pos !BSINGH - Fix for non-MAM simulations + +!!! TUCCELLA (BUG) + USE module_prep_wetscav_sorgam, only: aerosols_sorgam_init_aercld_ptrs, aerosols_soa_vbs_init_aercld_ptrs + IMPLICIT NONE real , intent(in) :: bioemdt,photdt,chemdt,dt,gmt @@ -212,6 +216,12 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, numgas_mam = numgas CALL wrf_debug(15,'calling RACM/MADE/SORGAM with AQCHEM chemistry from chem_driver') call wrf_message("WARNING: RACM_ESRLSORG_AQCHEM_KPP chemistry option is highly experimental and not recommended for use.") +! call wrf_error_fatal("ERROR: experimental option selected, please contact wrfchemhelp for assistance") +!!! TUCCELLA + CASE (RACM_SOA_VBS_AQCHEM_KPP ) + numgas_mam = numgas + CALL wrf_debug(15,'calling RACM/MADE/SOA-VBS with AQCHEM chemistry from chem_driver') + call wrf_message("WARNING: RACM_SOA_VBS_AQCHEM_KPP chemistry option is highly experimental and not recommended for use.") ! call wrf_error_fatal("ERROR: experimental option selected, please contact wrfchemhelp for assistance") CASE (CO2_TRACER, GHG_TRACER ) call wrf_message("WARNING: Users interested in the GHG options should check the comments/references in header of module_ghg_fluxes") @@ -244,6 +254,10 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_message("WARNING: dust option 1 currently works only with the GOCART aerosol option.") endif + if ( config_flags%dust_opt == 2 ) then + call wrf_error_fatal("WARNING: dust option 2 currently does not function properly and has been disabled.") + endif + if ( config_flags%seas_opt == 1 ) then call wrf_message("WARNING: sea salt option 1 currently works only with the GOCART aerosol option.") endif @@ -267,6 +281,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, its, ite, jts, jte, kts ) endif +!!! TUCCELLA if ( config_flags%wetscav_onoff == 1 ) then if( config_flags%chem_opt /= MOZART_KPP .and. & @@ -279,10 +294,11 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ( config_flags%chem_opt == 131 ) .OR. ( config_flags%chem_opt == 132 ) .OR. & ( config_flags%chem_opt == 503 .OR. config_flags%chem_opt == 504) .OR. & ( config_flags%chem_opt == 203).OR. & !BSINGH(12/17/2013): Added for SAPRC 8 bin vbs - ( config_flags%chem_opt == 601 .OR. config_flags%chem_opt == 611) ) then + ( config_flags%chem_opt == 601 .OR. config_flags%chem_opt == 611) .OR. & + (config_flags%chem_opt == 109) ) then call wrf_debug( 15, 'Chemics_init: Wet scavenging turned on' ) else - call wrf_error_fatal("ERROR: wet scavenging option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 42 or 503 or 504 or 601 or 611 to function.") + call wrf_error_fatal("ERROR: wet scavenging option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 42 or 109 or 503 or 504 or 601 or 611 to function.") endif if ( config_flags%mp_physics /= 2 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 11 & .and. config_flags%mp_physics /= 17 .and. config_flags%mp_physics /= 18 .and. config_flags%mp_physics /= 22) then @@ -300,6 +316,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif endif +!!! TUCCELLA if ( config_flags%cldchem_onoff == 1 ) then if( ( config_flags%chem_opt >= 8 .AND. config_flags%chem_opt <= 13) .OR. & ( config_flags%chem_opt >= 31 .AND. config_flags%chem_opt <= 36) .OR. & @@ -307,10 +324,11 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ( config_flags%chem_opt >= 41 .AND. config_flags%chem_opt <= 43) .OR. & ( config_flags%chem_opt == 203).OR. & ( config_flags%chem_opt == 131 ) .OR. ( config_flags%chem_opt == 132 ) .OR. & - ( config_flags%chem_opt >= 601 .AND. config_flags%chem_opt <= 611) ) then + ( config_flags%chem_opt >= 601 .AND. config_flags%chem_opt <= 611) .OR. & + config_flags%chem_opt == 109 .OR. config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP ) then call wrf_debug( 15, 'Chemics_init: Cloud chemistry turned on' ) else - call wrf_error_fatal("ERROR: cloud chemistry option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 43 to function.") + call wrf_error_fatal("ERROR: cloud chemistry option requires chem_opt = 8 through 13 or 31 to 36 or 41 to 43 or 109 to function.") endif if ( config_flags%mp_physics /= 2 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 11 & .and. config_flags%mp_physics /= 17 .and. config_flags%mp_physics /= 18 .and. config_flags%mp_physics /= 22 ) then @@ -601,10 +619,11 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_error_fatal("The number of chemistry species has changed between nests. Are you trying to mix chem_opt settings between nests? Shame on you!") end if +!!! TUCCELLA if( .NOT. config_flags%restart ) then kpp_select: SELECT CASE(config_flags%chem_opt) CASE (GOCARTRACM_KPP,RACM_KPP,RACMPM_KPP,RACMSORG_KPP,RACM_MIM_KPP,RACM_ESRLSORG_KPP, & - RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACM_SOA_VBS_KPP) + RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP) if(config_flags%chem_in_opt == 0 )then do j=jts,jte do k=kts,kte @@ -1675,6 +1694,12 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, config_flags ) + +!!!TUCCELLA (BUG, before it was called in module_aerosols_sorgam.F) + ! initialize pointers used by aerosol-cloud-interaction routines + call aerosols_sorgam_init_aercld_ptrs( & + num_chem, is_aerosol, config_flags ) + !...Convert aerosols to mixing ratio if( .NOT. config_flags%restart ) then if(config_flags%chem_in_opt == 0 .and. num_chem.gt.numgas)then @@ -1692,7 +1717,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif chem(its:ite,kts:min(kte,kde-1),jts:jte,:)=max(chem(its:ite,kts:min(kte,kde-1),jts:jte,:),epsilc) ! - CASE (CB05_SORG_VBS_AQ_KPP) + CASE (RACM_SOA_VBS_AQCHEM_KPP,CB05_SORG_VBS_AQ_KPP) CALL wrf_debug(15,'call MADE/SOA_VBS aerosols initialization') call aerosols_sorgam_vbs_init(chem,convfac,z_at_w, & @@ -1728,6 +1753,12 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, config_flags ) + +!!!TUCCELLA (BUG, before it was called in module_aerosols_soa_vbs.F) + ! initialize pointers used by aerosol-cloud-interaction routines + call aerosols_soa_vbs_init_aercld_ptrs( & + num_chem, is_aerosol, config_flags ) + !...Convert aerosols to mixing ratio if( .NOT. config_flags%restart ) then if(config_flags%chem_in_opt == 0 .and. num_chem.gt.numgas)then @@ -1790,9 +1821,10 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, END SELECT aer_select +!!! TUCCELLA progn_sanity_check : SELECT CASE(config_flags%chem_opt) CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, & - CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_DMS_4BIN_AQ, & + RACM_SOA_VBS_AQCHEM_KPP, CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ, CBMZ_MOSAIC_DMS_4BIN_AQ, & CBMZ_MOSAIC_DMS_8BIN_AQ,CBMZSORG_AQ,CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, & MOZART_MOSAIC_4BIN_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, & CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP) @@ -2056,8 +2088,9 @@ subroutine print_chem_species_index( chem_opt ) print*,p_iso,"iso" print*,p_ho,"ho" print*,p_ho2,"ho2" +!!! TUCCELLA case (RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RACM_KPP, RACMPM_KPP, RACMSORG_KPP, & - RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP) + RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) print*,p_so2,"so2" print*,p_sulf,"sulf" print*,p_no2,"no2" @@ -3279,6 +3312,83 @@ subroutine print_chem_species_index( chem_opt ) print*,p_nu0,"nu0" print*,p_ac0,"ac0" print*,p_corn,"corn" +!!! TUCCELLA +case (RACM_SOA_VBS_AQCHEM_KPP) + print*,p_so4aj,"so4aj" + print*,p_so4ai,"so4ai" + print*,p_nh4aj,"nh4aj" + print*,p_nh4ai,"nh4ai" + print*,p_no3aj,"no3aj" + print*,p_no3ai,"no3ai" + + print*,p_asoa1j,"asoa1j" + print*,p_asoa1i,"asoa1i" + print*,p_asoa2j,"asoa2j" + print*,p_asoa2i,"asoa2i" + print*,p_asoa3j,"asoa3j" + print*,p_asoa3i,"asoa3i" + print*,p_asoa4j,"asoa4j" + print*,p_asoa4i,"asoa4i" + + print*,p_bsoa1j,"bsoa1j" + print*,p_bsoa1i,"bsoa1i" + print*,p_bsoa2j,"bsoa2j" + print*,p_bsoa2i,"bsoa2i" + print*,p_bsoa3j,"bsoa3j" + print*,p_bsoa3i,"bsoa3i" + print*,p_bsoa4j,"bsoa4j" + print*,p_bsoa4i,"bsoa4i" + + print*,p_orgpaj,"orgpaj" + print*,p_orgpai,"orgpai" + print*,p_ecj,"ecj" + print*,p_eci,"eci" + print*,p_p25j,"p25j" + print*,p_p25i,"p25i" + print*,p_antha,"antha" + print*,p_seas,"seas" + print*,p_soila,"soila" + print*,p_nu0,"nu0" + print*,p_ac0,"ac0" + print*,p_corn,"corn" + + print*,p_so4acwj,"so4acwj" + print*,p_so4acwi,"so4acwi" + print*,p_nh4acwj,"nh4acwj" + print*,p_nh4acwi,"nh4acwi" + print*,p_no3acwj,"no3acwj" + print*,p_no3acwi,"no3acwi" + + print*,p_asoa1cwj,"asoa1cwj" + print*,p_asoa1cwi,"asoa1cwi" + print*,p_asoa2cwj,"asoa2cwj" + print*,p_asoa2cwi,"asoa2cwi" + print*,p_asoa3cwj,"asoa3cwj" + print*,p_asoa3cwi,"asoa3cwi" + print*,p_asoa4cwj,"asoa4cwj" + print*,p_asoa4cwi,"asoa4cwi" + + print*,p_bsoa1cwj,"bsoa1cwj" + print*,p_bsoa1cwi,"bsoa1cwi" + print*,p_bsoa2cwj,"bsoa2cwj" + print*,p_bsoa2cwi,"bsoa2cwi" + print*,p_bsoa3cwj,"bsoa3cwj" + print*,p_bsoa3cwi,"bsoa3cwi" + print*,p_bsoa4cwj,"bsoa4cwj" + print*,p_bsoa4cwi,"bsoa4cwi" + + print*,p_orgpacwj,"orgpacwj" + print*,p_orgpacwi,"orgpacwi" + print*,p_eccwj,"eccwj" + print*,p_eccwi,"eccwi" + print*,p_p25cwj,"p25cwj" + print*,p_p25cwi,"p25cwi" + print*,p_anthacw,"anthacw" + print*,p_seascw,"seascw" + print*,p_soilacw,"soilacw" + print*,p_nu0cw,"nu0cw" + print*,p_ac0cw,"ac0cw" + print*,p_corncw,"corncw" end select end subroutine print_chem_species_index #endif diff --git a/wrfv2_fire/chem/depend.chem b/wrfv2_fire/chem/depend.chem index e00a0eda..71d9b206 100644 --- a/wrfv2_fire/chem/depend.chem +++ b/wrfv2_fire/chem/depend.chem @@ -49,7 +49,9 @@ module_gocart_dust.o: ../phys/module_data_gocart_dust.o module_gocart_dust_afwa.o: ../phys/module_data_gocart_dust.o module_data_sorgam.o -module_uoc_dust.o: module_qf03.o module_soilpsd.o +module_uoc_dust.o: module_qf03.o module_soilpsd.o ../phys/module_sf_noahlsm.o ../phys/module_sf_noahmplsm.o ../phys/module_sf_ruclsm.o + +module_uoc_dustwd.o: module_data_uoc_wd.o module_gocart_seasalt.o: module_data_gocart_seas.o @@ -123,7 +125,9 @@ module_input_dust_errosion.o: module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_input_gocart_dms.o: module_aerosols_sorgam.o module_aerosols_soa_vbs.o -module_dep_simple.o: module_data_sorgam.o module_aerosols_soa_vbs.o +module_dep_simple.o: module_data_sorgam.o module_aerosols_soa_vbs.o + +module_mosaic_wetscav.o: module_dep_simple.o module_bioemi_simple.o: module_data_radm2.o @@ -163,13 +167,15 @@ module_data_mosaic_therm.o: module_mosaic_addemiss.o: module_data_mosaic_asect.o -module_mosaic_wetscav.o: module_dep_simple.o +module_dep_simple.o: module_data_sorgam.o module_aerosols_soa_vbs.o module_mozcart_wetscav.o: +module_prep_wetscav_sorgam.o: module_mosaic_wetscav.o module_data_sorgam.o module_data_soa_vbs.o + module_aerosols_sorgam.o: module_data_sorgam.o module_mosaic_addemiss.o module_radm.o module_mosaic_wetscav.o -module_aerosols_soa_vbs.o: module_data_soa_vbs.o module_radm.o module_mosaic_addemiss.o +module_aerosols_soa_vbs.o: module_data_soa_vbs.o module_radm.o module_mosaic_addemiss.o module_aerosols_sorgam_vbs.o: module_data_sorgam_vbs.o module_mosaic_wetscav.o @@ -179,7 +185,7 @@ module_mosaic_initmixrats.o: module_peg_util.o module_data_mosaic_asect.o module module_mosaic_movesect.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o -module_mosaic_therm.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o module_data_mosaic_therm.o module_mosaic_movesect.o +module_mosaic_therm.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o module_data_mosaic_therm.o module_mosaic_movesect.o module_mosaic_gly.o module_mosaic_newnuc.o: module_peg_util.o module_data_mosaic_asect.o module_data_mosaic_other.o module_mosaic_movesect.o @@ -209,7 +215,7 @@ module_fastj_data.o: module_data_mosaic_other.o module_fastj_mie.o: module_peg_util.o module_data_mosaic_therm.o -module_optical_averaging.o: module_data_sorgam.o module_data_rrtmgaeropt.o module_data_gocart_seas.o module_peg_util.o module_data_sorgam_vbs.o +module_optical_averaging.o: module_data_sorgam.o module_data_soa_vbs.o module_data_rrtmgaeropt.o module_data_gocart_seas.o module_peg_util.o module_data_sorgam_vbs.o module_ctrans_grell.o: module_dep_simple.o module_input_chem_data.o @@ -252,7 +258,7 @@ module_aer_drydep.o: module_data_sorgam.o module_aerosols_sorgam.o module_aeroso module_interpolate.o: -chemics_init.o: module_cbm4_initmixrats.o module_cbmz_initmixrats.o module_gocart_aerosols.o ../phys/module_data_gocart_dust.o module_data_gocart_seas.o module_data_gocartchem.o module_gocart_chem.o module_dep_simple.o module_ftuv_driver.o module_phot_mad.o module_gocart_chem.o module_aerosols_sorgam.o module_aerosols_sorgam_vbs.o module_aerosols_soa_vbs.o module_mixactivate_wrappers.o module_mosaic_driver.o module_input_chem_data.o module_cam_mam_init.o module_cam_mam_wetscav.o +chemics_init.o: module_cbm4_initmixrats.o module_cbmz_initmixrats.o module_gocart_aerosols.o ../phys/module_data_gocart_dust.o module_data_gocart_seas.o module_data_gocartchem.o module_gocart_chem.o module_dep_simple.o module_ftuv_driver.o module_phot_mad.o module_gocart_chem.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_aerosols_soa_vbs.o module_mixactivate_wrappers.o module_mosaic_driver.o module_input_chem_data.o module_cam_mam_init.o module_cam_mam_wetscav.o module_prep_wetscav_sorgam.o module_aerosols_sorgam_vbs.o module_tropopause.o: module_interpolate.o @@ -278,7 +284,7 @@ emissions_driver.o: module_add_emiss_burn.o module_data_radm2.o module_radm.o mo dry_dep_driver.o: module_data_radm2.o module_aer_drydep.o module_dep_simple.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_aerosols_sorgam_vbs.o module_mosaic_drydep.o ../phys/module_mixactivate.o module_cam_mam_drydep.o ../phys/module_data_cam_mam_asect.o ../phys/module_data_cam_mam_aero.o ../phys/module_cam_support.o -module_wetscav_driver.o: module_mosaic_wetscav.o module_aerosols_sorgam.o module_aerosols_sorgam_vbs.o module_mozcart_wetscav.o ../phys/module_data_cam_mam_aero.o module_cam_mam_wetscav.o +module_wetscav_driver.o: module_mosaic_wetscav.o module_aerosols_sorgam.o module_aerosols_sorgam_vbs.o module_mozcart_wetscav.o ../phys/module_data_cam_mam_aero.o module_cam_mam_wetscav.o module_aerosols_soa_vbs.o module_prep_wetscav_sorgam.o module_sorgam_aqchem.o: module_ctrans_aqchem.o module_data_sorgam.o diff --git a/wrfv2_fire/chem/dry_dep_driver.F b/wrfv2_fire/chem/dry_dep_driver.F index b71fd05c..f496ec6a 100755 --- a/wrfv2_fire/chem/dry_dep_driver.F +++ b/wrfv2_fire/chem/dry_dep_driver.F @@ -48,7 +48,7 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & USE module_gocart_drydep USE module_mosaic_drydep, only: mosaic_drydep_driver USE module_mixactivate_wrappers, only: mosaic_mixactivate, sorgam_mixactivate, & - sorgam_vbs_mixactivate + sorgam_vbs_mixactivate, soa_vbs_mixactivate USE module_aer_drydep USE module_aerosols_soa_vbs, only: soa_vbs_depdriver @@ -462,8 +462,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & idrydep_onoff = 1 aer_mech_id_select: SELECT CASE(config_flags%chem_opt) +!!! TUCCELLA CASE (RADM2SORG,RADM2SORG_AQ,RADM2SORG_AQCHEM,RADM2SORG_KPP, & - RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP, & + RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP, & CBMZSORG,CBMZSORG_AQ, & CB05_SORG_AQ_KPP,CB05_SORG_VBS_AQ_KPP) aer_mech_id = 1 @@ -563,7 +564,8 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE ( RACM_SOA_VBS_KPP ) +!!! TUCCELLA + CASE ( RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP ) CALL wrf_debug(15,'DOING DRY DEP VELOCITIES FOR SOA_VBS AEROSOLS') call soa_vbs_depdriver (id,config_flags,ktau,dtstep, & ust,t_phy,moist,p8w,t8w,rmol,znt,pbl, & @@ -728,9 +730,10 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & mix_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, CBMZ_MOSAIC_4BIN_AQ, & - CBMZ_MOSAIC_8BIN_AQ, CBMZSORG_AQ, CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ, & - MOZART_MOSAIC_4BIN_AQ_KPP, & - CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, & + CBMZ_MOSAIC_8BIN_AQ, CBMZSORG_AQ, CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN, CBMZ_MOSAIC_DMS_4BIN_AQ, & + CBMZ_MOSAIC_DMS_8BIN_AQ, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP, & + MOZART_MOSAIC_4BIN_AQ_KPP, RACM_SOA_VBS_AQCHEM_KPP, & + SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, & CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP) if(.not.is_aerosol(nv))then ! mix gases not aerosol call vertmx(dtstep,pblst,ekmfull,dryrho_1d, & @@ -1061,6 +1064,18 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) + CALL wrf_debug(15,'call mixactivate for soa-vbs aerosol') + call soa_vbs_mixactivate ( & + id, ktau, dtstep, config_flags, idrydep_onoff, & + dryrho_phy, t_phy, w, cldfra, cldfra_old, & + ddvel, z, dz8w, p8w, t8w, exch_h, & + moist(ims,kms,jms,P_QV), moist(ims,kms,jms,P_QC),moist(ims,kms,jms,P_QI), & + scalar(ims,kms,jms,P_QNDROP), f_qc, f_qi, chem, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) CASE (CB05_SORG_VBS_AQ_KPP) CALL wrf_debug(15,'call mixactivate for sorgam_vbs aerosol') call sorgam_vbs_mixactivate ( & @@ -1351,8 +1366,9 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & IF((config_flags%dust_opt .EQ. 1) .OR. (config_flags%dust_opt .GE. 3) .OR. & (config_flags%seas_opt .GE. 1) ) THEN settling_select: SELECT CASE(config_flags%chem_opt) +!!! TUCCELLA CASE (DUST,GOCART_SIMPLE,GOCARTRACM_KPP,MOZCART_KPP,RADM2SORG,RADM2SORG_AQ, & - RADM2SORG_AQCHEM,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP) + RADM2SORG_AQCHEM,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP,RACM_SOA_VBS_AQCHEM_KPP) CALL wrf_debug(15,'call gocart settling routine') call gocart_settling_driver(dtstep,config_flags,t_phy,moist, & chem,rho_phy,dz8w,p8w,p_phy, & diff --git a/wrfv2_fire/chem/emissions_driver.F b/wrfv2_fire/chem/emissions_driver.F index ef32b766..1ee719f8 100755 --- a/wrfv2_fire/chem/emissions_driver.F +++ b/wrfv2_fire/chem/emissions_driver.F @@ -814,13 +814,14 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) endif +!!! TUCCELLA CASE (BEIS314) if( do_bioemiss ) then beis314_check_mechanism_ok: SELECT CASE(config_flags%chem_opt) CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ,RACMSORG_AQCHEM_KPP, & RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP,RACM_ESRLSORG_KPP, RACM_SOA_VBS_KPP, & - CBM4_KPP, NMHC9_KPP, GOCARTRACM_KPP,GOCARTRADM2) + RACM_SOA_VBS_AQCHEM_KPP,CBM4_KPP, NMHC9_KPP, GOCARTRACM_KPP,GOCARTRADM2) CASE DEFAULT CALL wrf_error_fatal( & "emissions_driver: beis3.1.4 biogenic emis. implemented for RADM2 & RACM only") @@ -888,11 +889,12 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & !!! **************** END BIOGENICS, ADD EMISSIONS FOR VARIOUS PACKAGES ! +!!! TUCCELLA gas_addemiss_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP, & - RACM_SOA_VBS_KPP, RACM_ESRLSORG_KPP, & - MOZART_KPP, MOZCART_KPP, MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP, & + RACM_SOA_VBS_KPP, RACM_SOA_VBS_AQCHEM_KPP, RACM_ESRLSORG_KPP, MOZART_KPP, MOZCART_KPP, & + MOZART_MOSAIC_4BIN_KPP, MOZART_MOSAIC_4BIN_AQ_KPP, & CRIMECH_KPP, CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP ) IF(config_flags%emiss_inpt_opt /= 3 ) then IF(config_flags%kemit .GT. kte-ksub) THEN @@ -1172,7 +1174,7 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (SAPRC99_MOSAIC_4BIN_VBS2_KPP) !FIX FOR SAPRC07A + CASE (SAPRC99_MOSAIC_4BIN_VBS2_KPP, SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP) !FIX FOR SAPRC07A!BSINGH(12/11/2013): Added SAPRC 8 bin if(config_flags%emiss_opt == 13 ) then do j=jts,jte do i=its,ite @@ -1479,7 +1481,8 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & its,ite, jts,jte, kts,kte ) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - CASE (RACM_SOA_VBS_KPP) +!!! TUCCELLA + CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) call wrf_debug(15,'emissions_driver calling soa_vbs_addemiss') call soa_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, & ebu, & diff --git a/wrfv2_fire/chem/module_aerosols_soa_vbs.F b/wrfv2_fire/chem/module_aerosols_soa_vbs.F index 6cd6cf44..5b31c763 100644 --- a/wrfv2_fire/chem/module_aerosols_soa_vbs.F +++ b/wrfv2_fire/chem/module_aerosols_soa_vbs.F @@ -21,8 +21,6 @@ MODULE module_aerosols_soa_vbs ! Ackermann, I. J., H. Hass, M. Memmesheimer, A. Ebel, F. S. Binkowski, and U. Shankar (1998), ! Modal aerosol dynamics model for Europe: Development and first applications, Atmos. Environ., 32(17), 2981-2999. ! -!!WARNING! This aerosol option does not support cloud phase aerosol! -! !!WARNING! The deposition of organic condensable vapours (cvasoa* and cvbsoa*) are highly uncertain due to lack of observations. ! Currently this process is parameterized using modeled dry deposition velocities of HNO3 (multiplied by "depo_fact" for OCVs). ! Paper by Ahmadov et al. (2012) desribes this approach. The default value for "depo_fact" in WRF-CHEM is 0.25. @@ -30,7 +28,8 @@ MODULE module_aerosols_soa_vbs ! !!WARNING! Another uncertainty is wet removal of OCVs! This is neglected in the current version of the WRF-CHEM code. ! -! +! 30/06/2014: Modified by Paolo Tuccella +! The module has been modified in order to include the aqueous phase ! USE module_state_description ! USE module_data_radm2 @@ -529,6 +528,14 @@ SUBROUTINE sum_pm_soa_vbs ( & do n=p_so4aj,p_p25i pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n) enddo + +!!! TUCCELLA + if( p_p25cwi .gt. p_p25i) then + do n=p_so4cwj,p_p25cwi + pm2_5_dry(i,k,j) = pm2_5_dry(i,k,j)+chem(ii,k,jj,n) + enddo + endif + pm2_5_dry_ec(i,k,j) = pm2_5_dry_ec(i,k,j)+chem(ii,k,jj,p_ecj) & + chem(ii,k,jj,p_eci) pm2_5_water(i,k,j) = pm2_5_water(i,k,j)+h2oaj(i,k,j) & @@ -550,6 +557,13 @@ SUBROUTINE sum_pm_soa_vbs ( & + ( chem(ii,k,jj,p_antha) & + chem(ii,k,jj,p_soila) & + chem(ii,k,jj,p_seas) ) / alt(ii,k,jj) +!!!TUCCELLA + if( p_p25cwi .gt. p_p25i) then + pm10(i,k,j) = pm10(i,k,j) & + + ( chem(ii,k,jj,p_anthcw) & + + chem(ii,k,jj,p_soilcw) & + + chem(ii,k,jj,p_seascw) ) / alt(ii,k,jj) + endif enddo enddo enddo @@ -6227,6 +6241,8 @@ SUBROUTINE aerosols_soa_vbs_init(chem,convfac,z_at_w, its,ite, jts,jte, kts,kte, config_flags ) USE module_configure, only: grid_config_rec_type +!!! TUCCELLA (BUG, commented the line below) + !USE module_prep_wetscav_sorgam,only: aerosols_soa_vbs_init_aercld_ptrs implicit none INTEGER, INTENT(IN ) :: chem_in_opt,aer_ic_opt @@ -6366,9 +6382,12 @@ SUBROUTINE aerosols_soa_vbs_init(chem,convfac,z_at_w, ccofm_org = alphaorg*sqrt(pirs*rgasuniv/(2.0*mworg)) mwso4=96.03 -! initialize pointers used by aerosol-cloud-interaction routines -! call aerosols_soa_vbs_init_aercld_ptrs( & -! num_chem, is_aerosol, config_flags ) +! initialize pointers used by aerosol-cloud-interaction routines +! TUCCELLA (BUG, now aerosols_soa_vbs_aercld_ptrs is called chemics_init.F ! +! and was moved to module_prep_wetscav_sorgam.F) + + !call aerosols_soa_vbs_init_aercld_ptrs( & + ! num_chem, is_aerosol, config_flags ) pm2_5_dry(its:ite, kts:kte-1, jts:jte) = 0. pm2_5_water(its:ite, kts:kte-1, jts:jte) = 0. @@ -7436,7 +7455,78 @@ END SUBROUTINE soa_vbs_source_du !=========================================================================== +!!!TUCCELLA (BUG, now wetscav_sorgam_driver is in module_prep_wetscav_sorgam.F) + !=========================================================================== +! subroutine wetscav_soa_vbs_driver (id,ktau,dtstep,ktauc,config_flags, & +! dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & +! qlsink,precr,preci,precs,precg,qsrflx, & +! gas_aqfrac, numgas_aqfrac, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) + +! wet removal by grid-resolved precipitation +! scavenging of cloud-phase aerosols and gases by collection, freezing, ... +! scavenging of interstitial-phase aerosols by impaction +! scavenging of gas-phase gases by mass transfer and reaction + +!---------------------------------------------------------------------- +! USE module_configure +! USE module_state_description +! USE module_data_soa_vbs +! USE module_mosaic_wetscav,only: wetscav +!---------------------------------------------------------------------- +! IMPLICIT NONE + +! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + +! INTEGER, INTENT(IN ) :: & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte, & +! id, ktau, ktauc, numgas_aqfrac +! REAL, INTENT(IN ) :: dtstep,dtstepc + +! all advected chemical species +! +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & +! INTENT(INOUT ) :: chem + +! fraction of gas species in cloud water +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), & +! INTENT(IN ) :: gas_aqfrac + +! +! +! input from meteorology +! REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & +! INTENT(IN ) :: & +! alt, & +! t_phy, & +! p_phy, & +! t8w,p8w, & +! qlsink,precr,preci,precs,precg, & +! rho_phy,cldfra +! REAL, DIMENSION( ims:ime, jms:jme, num_chem ), & +! INTENT(OUT ) :: qsrflx ! column change due to scavening + +! call wetscav (id,ktau,dtstep,ktauc,config_flags, & +! dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & +! qlsink,precr,preci,precs,precg,qsrflx, & +! gas_aqfrac, numgas_aqfrac, & +! ntype_aer, nsize_aer, ncomp_aer, & +! massptr_aer, dens_aer, numptr_aer, & +! maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, & +! volumcen_sect, volumlo_sect, volumhi_sect, & +! waterptr_aer, dens_water_aer, & +! scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd,dlndg_nimptblgrow, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) + +! end subroutine wetscav_soa_vbs_driver +!=========================================================================== END Module module_aerosols_soa_vbs diff --git a/wrfv2_fire/chem/module_aerosols_sorgam.F b/wrfv2_fire/chem/module_aerosols_sorgam.F index a7105168..03ce44df 100644 --- a/wrfv2_fire/chem/module_aerosols_sorgam.F +++ b/wrfv2_fire/chem/module_aerosols_sorgam.F @@ -7344,7 +7344,9 @@ SUBROUTINE aerosols_sorgam_init(chem,convfac,z_at_w, & its,ite, jts,jte, kts,kte, config_flags ) USE module_configure,only: grid_config_rec_type - +!!! TUCCELLA (BUG, commented the line below) + !USE module_prep_wetscav_sorgam,only: aerosols_sorgam_init_aercld_ptrs + implicit none INTEGER, INTENT(IN ) :: chem_in_opt,aer_ic_opt INTEGER, INTENT(IN ) :: & @@ -7487,8 +7489,12 @@ SUBROUTINE aerosols_sorgam_init(chem,convfac,z_at_w, & mwso4=96.03 ! initialize pointers used by aerosol-cloud-interaction routines - call aerosols_sorgam_init_aercld_ptrs( & - num_chem, is_aerosol, config_flags ) + +! TUCCELLA (BUG, now aerosols_sorgam_init_aercld_ptrs is called chemics_init.F ! +! and was moved to module_prep_wetscav_sorgam.F) + + !call aerosols_sorgam_init_aercld_ptrs( & + ! num_chem, is_aerosol, config_flags ) pm2_5_dry(its:ite, kts:kte-1, jts:jte) = 0. @@ -7594,483 +7600,6 @@ SUBROUTINE aerosols_sorgam_init(chem,convfac,z_at_w, & return END SUBROUTINE aerosols_sorgam_init - - - SUBROUTINE aerosols_sorgam_init_aercld_ptrs( & - num_chem, is_aerosol, config_flags ) -! -! initialize pointers used by aerosol-cloud-interaction routines -! - USE module_configure,only: grid_config_rec_type - USE module_mosaic_wetscav,only: initwet - - implicit none - INTEGER, INTENT(IN) :: num_chem - LOGICAL, INTENT(OUT) :: is_aerosol(num_chem) - TYPE (grid_config_rec_type) , INTENT (in) :: config_flags - - - integer iphase, isize, itype, l, ll, n, p1st - REAL dp_meanvol_tmp - - - nphase_aer = 1 - if(p_so4cwj.ge. param_first_scalar) then - nphase_aer = 2 - endif - ai_phase=-999888777 - cw_phase=-999888777 - ci_phase=-999888777 - cr_phase=-999888777 - cs_phase=-999888777 - cg_phase=-999888777 - if(nphase_aer>=1)ai_phase=1 - if(nphase_aer>=2)cw_phase=2 - if(nphase_aer>=3)cr_phase=3 - if(nphase_aer>=4)ci_phase=4 - if(nphase_aer>=5)cw_phase=5 - if(nphase_aer>=6)cg_phase=6 - -! aitken and accum mode have same set of species -! so are treated as isize=1,2 of itype=1 -! coarse mode has different set of species -! so is treated as isize=1 of itype=2 - ntype_aer = 2 - nsize_aer(1)=2 - nsize_aer(2)=1 - - msectional = 0 - maerosolincw = 0 -#if defined ( cw_species_are_in_registry ) - maerosolincw = 1 -#endif - name_mastercomp_aer( 1) = 'sulfate' - dens_mastercomp_aer( 1) = dens_so4_aer - mw_mastercomp_aer( 1) = mw_so4_aer - hygro_mastercomp_aer(1) = hygro_so4_aer - - name_mastercomp_aer( 2) = 'nitrate' - dens_mastercomp_aer( 2) = dens_no3_aer - mw_mastercomp_aer( 2) = mw_no3_aer - hygro_mastercomp_aer(2) = hygro_no3_aer - - name_mastercomp_aer( 3) = 'ammonium' - dens_mastercomp_aer( 3) = dens_nh4_aer - mw_mastercomp_aer( 3) = mw_nh4_aer - hygro_mastercomp_aer(3) = hygro_nh4_aer - - name_mastercomp_aer( 4) = 'orgaro1' - dens_mastercomp_aer( 4) = dens_oc_aer - mw_mastercomp_aer( 4) = mw_oc_aer - hygro_mastercomp_aer(4) = hygro_oc_aer - - name_mastercomp_aer( 5) = 'orgaro2' - dens_mastercomp_aer( 5) = dens_oc_aer - mw_mastercomp_aer( 5) = mw_oc_aer - hygro_mastercomp_aer(5) = hygro_oc_aer - - name_mastercomp_aer( 6) = 'orgalk' - dens_mastercomp_aer( 6) = dens_oc_aer - mw_mastercomp_aer( 6) = mw_oc_aer - hygro_mastercomp_aer(6) = hygro_oc_aer - - name_mastercomp_aer( 7) = 'orgole' - dens_mastercomp_aer( 7) = dens_oc_aer - mw_mastercomp_aer( 7) = mw_oc_aer - hygro_mastercomp_aer(7) = hygro_oc_aer - - name_mastercomp_aer( 8) = 'orgba1' - dens_mastercomp_aer( 8) = dens_oc_aer - mw_mastercomp_aer( 8) = mw_oc_aer - hygro_mastercomp_aer(8) = hygro_oc_aer - - name_mastercomp_aer( 9) = 'orgba2' - dens_mastercomp_aer( 9) = dens_oc_aer - mw_mastercomp_aer( 9) = mw_oc_aer - hygro_mastercomp_aer(9) = hygro_oc_aer - - name_mastercomp_aer( 10) = 'orgba3' - dens_mastercomp_aer( 10) = dens_oc_aer - mw_mastercomp_aer( 10) = mw_oc_aer - hygro_mastercomp_aer(10) = hygro_oc_aer - - name_mastercomp_aer( 11) = 'orgba4' - dens_mastercomp_aer( 11) = dens_oc_aer - mw_mastercomp_aer( 11) = mw_oc_aer - hygro_mastercomp_aer(11) = hygro_oc_aer - - name_mastercomp_aer( 12) = 'orgpa' - dens_mastercomp_aer( 12) = dens_oc_aer - mw_mastercomp_aer( 12) = mw_oc_aer - hygro_mastercomp_aer(12) = hygro_oc_aer - - name_mastercomp_aer( 13) = 'ec' - dens_mastercomp_aer( 13) = dens_ec_aer - mw_mastercomp_aer( 13) = mw_ec_aer - hygro_mastercomp_aer(13) = hygro_ec_aer - name_mastercomp_aer( 14) = 'p25' - dens_mastercomp_aer( 14) = dens_oin_aer - mw_mastercomp_aer( 14) = mw_oin_aer - hygro_mastercomp_aer(14) = hygro_oin_aer - - name_mastercomp_aer( 15) = 'anth' - dens_mastercomp_aer( 15) = dens_oin_aer - mw_mastercomp_aer( 15) = mw_oin_aer - hygro_mastercomp_aer(15) = hygro_oin_aer - - name_mastercomp_aer( 16) = 'seas' - dens_mastercomp_aer( 16) = dens_seas_aer - mw_mastercomp_aer( 16) = mw_seas_aer - hygro_mastercomp_aer(16) = hygro_seas_aer - - name_mastercomp_aer( 17) = 'soil' - dens_mastercomp_aer( 17) = dens_dust_aer - mw_mastercomp_aer( 17) = mw_dust_aer - hygro_mastercomp_aer(17) = hygro_dust_aer - - name_mastercomp_aer(18) = 'sodium' - dens_mastercomp_aer(18) = dens_na_aer - mw_mastercomp_aer( 18) = mw_na_aer - hygro_mastercomp_aer(18) = hygro_na_aer - - name_mastercomp_aer(19) = 'chloride' - dens_mastercomp_aer(19) = dens_cl_aer - mw_mastercomp_aer( 19) = mw_cl_aer - hygro_mastercomp_aer(19) = hygro_cl_aer - - lptr_so4_aer( :,:,:) = 1 - lptr_nh4_aer( :,:,:) = 1 - lptr_no3_aer( :,:,:) = 1 - lptr_na_aer( :,:,:) = 1 - lptr_cl_aer( :,:,:) = 1 - lptr_orgaro1_aer(:,:,:) = 1 - lptr_orgaro2_aer(:,:,:) = 1 - lptr_orgalk_aer( :,:,:) = 1 - lptr_orgole_aer( :,:,:) = 1 - lptr_orgba1_aer( :,:,:) = 1 - lptr_orgba2_aer( :,:,:) = 1 - lptr_orgba3_aer( :,:,:) = 1 - lptr_orgba4_aer( :,:,:) = 1 - lptr_orgpa_aer( :,:,:) = 1 - lptr_ec_aer( :,:,:) = 1 - lptr_p25_aer( :,:,:) = 1 - lptr_anth_aer( :,:,:) = 1 - lptr_seas_aer( :,:,:) = 1 - lptr_soil_aer( :,:,:) = 1 - numptr_aer( :,:,:) = 1 - - do_cloudchem_aer(:,:) = .false. - - -! Aitken mode - itype = 1 - isize = 1 - ncomp_aer(itype) = 16 - numptr_aer( isize,itype,ai_phase) = p_nu0 - lptr_so4_aer( isize,itype,ai_phase) = p_so4ai - lptr_nh4_aer( isize,itype,ai_phase) = p_nh4ai - lptr_no3_aer( isize,itype,ai_phase) = p_no3ai - lptr_na_aer( isize,itype,ai_phase) = p_naai - lptr_cl_aer( isize,itype,ai_phase) = p_clai - lptr_orgaro1_aer(isize,itype,ai_phase) = p_orgaro1i - lptr_orgaro2_aer(isize,itype,ai_phase) = p_orgaro2i - lptr_orgalk_aer( isize,itype,ai_phase) = p_orgalk1i - lptr_orgole_aer( isize,itype,ai_phase) = p_orgole1i - lptr_orgba1_aer( isize,itype,ai_phase) = p_orgba1i - lptr_orgba2_aer( isize,itype,ai_phase) = p_orgba2i - lptr_orgba3_aer( isize,itype,ai_phase) = p_orgba3i - lptr_orgba4_aer( isize,itype,ai_phase) = p_orgba4i - lptr_orgpa_aer( isize,itype,ai_phase) = p_orgpai - lptr_ec_aer( isize,itype,ai_phase) = p_eci - lptr_p25_aer( isize,itype,ai_phase) = p_p25i -! aerosol in cloud water - if(cw_phase.gt.0)then - numptr_aer( isize,itype,cw_phase) = p_nu0cw - lptr_so4_aer( isize,itype,cw_phase) = p_so4cwi - lptr_nh4_aer( isize,itype,cw_phase) = p_nh4cwi - lptr_no3_aer( isize,itype,cw_phase) = p_no3cwi - lptr_na_aer( isize,itype,ai_phase) = p_nacwi - lptr_cl_aer( isize,itype,ai_phase) = p_clcwi - lptr_orgaro1_aer(isize,itype,cw_phase) = p_orgaro1cwi - lptr_orgaro2_aer(isize,itype,cw_phase) = p_orgaro2cwi - lptr_orgalk_aer( isize,itype,cw_phase) = p_orgalk1cwi - lptr_orgole_aer( isize,itype,cw_phase) = p_orgole1cwi - lptr_orgba1_aer( isize,itype,cw_phase) = p_orgba1cwi - lptr_orgba2_aer( isize,itype,cw_phase) = p_orgba2cwi - lptr_orgba3_aer( isize,itype,cw_phase) = p_orgba3cwi - lptr_orgba4_aer( isize,itype,cw_phase) = p_orgba4cwi - lptr_orgpa_aer( isize,itype,cw_phase) = p_orgpacwi - lptr_ec_aer( isize,itype,cw_phase) = p_eccwi - lptr_p25_aer( isize,itype,cw_phase) = p_p25cwi - do_cloudchem_aer(isize,itype) = .true. - endif - -! Accumulation mode - itype = 1 - isize = 2 - ncomp_aer(itype) = 16 - numptr_aer( isize,itype,ai_phase) = p_ac0 - lptr_so4_aer( isize,itype,ai_phase) = p_so4aj - lptr_nh4_aer( isize,itype,ai_phase) = p_nh4aj - lptr_no3_aer( isize,itype,ai_phase) = p_no3aj - lptr_na_aer( isize,itype,ai_phase) = p_naaj - lptr_cl_aer( isize,itype,ai_phase) = p_claj - lptr_orgaro1_aer(isize,itype,ai_phase) = p_orgaro1j - lptr_orgaro2_aer(isize,itype,ai_phase) = p_orgaro2j - lptr_orgalk_aer( isize,itype,ai_phase) = p_orgalk1j - lptr_orgole_aer( isize,itype,ai_phase) = p_orgole1j - lptr_orgba1_aer( isize,itype,ai_phase) = p_orgba1j - lptr_orgba2_aer( isize,itype,ai_phase) = p_orgba2j - lptr_orgba3_aer( isize,itype,ai_phase) = p_orgba3j - lptr_orgba4_aer( isize,itype,ai_phase) = p_orgba4j - lptr_orgpa_aer( isize,itype,ai_phase) = p_orgpaj - lptr_ec_aer( isize,itype,ai_phase) = p_ecj - lptr_p25_aer( isize,itype,ai_phase) = p_p25j -! aerosol in cloud water - if(cw_phase.gt.0)then - numptr_aer( isize,itype,cw_phase) = p_ac0cw - lptr_so4_aer( isize,itype,cw_phase) = p_so4cwj - lptr_nh4_aer( isize,itype,cw_phase) = p_nh4cwj - lptr_no3_aer( isize,itype,cw_phase) = p_no3cwj - lptr_na_aer( isize,itype,ai_phase) = p_nacwj - lptr_cl_aer( isize,itype,ai_phase) = p_clcwj - lptr_orgaro1_aer(isize,itype,cw_phase) = p_orgaro1cwj - lptr_orgaro2_aer(isize,itype,cw_phase) = p_orgaro2cwj - lptr_orgalk_aer( isize,itype,cw_phase) = p_orgalk1cwj - lptr_orgole_aer( isize,itype,cw_phase) = p_orgole1cwj - lptr_orgba1_aer( isize,itype,cw_phase) = p_orgba1cwj - lptr_orgba2_aer( isize,itype,cw_phase) = p_orgba2cwj - lptr_orgba3_aer( isize,itype,cw_phase) = p_orgba3cwj - lptr_orgba4_aer( isize,itype,cw_phase) = p_orgba4cwj - lptr_orgpa_aer( isize,itype,cw_phase) = p_orgpacwj - lptr_ec_aer( isize,itype,cw_phase) = p_eccwj - lptr_p25_aer( isize,itype,cw_phase) = p_p25cwj - do_cloudchem_aer(isize,itype) = .true. - endif - -! coarse mode - itype = 2 - isize = 1 - ncomp_aer(itype) = 3 - numptr_aer( isize,itype,ai_phase) = p_corn - lptr_anth_aer( isize,itype,ai_phase) = p_antha - lptr_seas_aer( isize,itype,ai_phase) = p_seas - lptr_soil_aer( isize,itype,ai_phase) = p_soila -! aerosol in cloud water - if(cw_phase.gt.0)then - numptr_aer( isize,itype,cw_phase) = p_corncw - lptr_anth_aer( isize,itype,cw_phase) = p_anthcw - lptr_seas_aer( isize,itype,cw_phase) = p_seascw - lptr_soil_aer( isize,itype,cw_phase) = p_soilcw -! no cloudchem for coarse mode because it has no so4/nh4/no3 species - do_cloudchem_aer(isize,itype) = .false. - endif - - massptr_aer(:,:,:,:) = -999888777 - mastercompptr_aer(:,:) = -999888777 - - p1st = param_first_scalar - - do iphase=1,nphase_aer - do itype=1,ntype_aer - do n = 1, nsize_aer(itype) - ll = 0 - if (lptr_so4_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_so4_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 1 - end if - if (lptr_no3_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_no3_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 2 - end if - if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_nh4_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 3 - end if - if (lptr_orgaro1_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_orgaro1_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 4 - end if - if (lptr_orgaro2_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_orgaro2_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 5 - end if - if (lptr_orgalk_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_orgalk_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 6 - end if - if (lptr_orgole_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_orgole_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 7 - end if - if (lptr_orgba1_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_orgba1_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 8 - end if - if (lptr_orgba2_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_orgba2_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 9 - end if - if (lptr_orgba3_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_orgba3_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 10 - end if - if (lptr_orgba4_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_orgba4_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 11 - end if - if (lptr_orgpa_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_orgpa_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 12 - end if - if (lptr_ec_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_ec_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 13 - end if - if (lptr_p25_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_p25_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 14 - end if - if (lptr_anth_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_anth_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 15 - end if - if (lptr_seas_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_seas_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 16 - end if - if (lptr_soil_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_soil_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 17 - end if - if (lptr_na_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_na_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 18 - end if - if (lptr_cl_aer(n,itype,iphase) .ge. p1st) then - ll = ll + 1 - massptr_aer(ll,n,itype,iphase) = lptr_cl_aer(n,itype,iphase) - mastercompptr_aer(ll,itype) = 19 - endif - ncomp_aer_nontracer(itype) = ll - - ncomp_aer(itype) = ll - - mprognum_aer(n,itype,iphase) = 0 - if (numptr_aer(n,itype,iphase) .ge. p1st) then - mprognum_aer(n,itype,iphase) = 1 - end if - - end do ! size - end do ! type - end do ! phase - - waterptr_aer(:,:) = 0 - - do itype=1,ntype_aer - do ll=1,ncomp_aer(itype) - dens_aer(ll,itype) = dens_mastercomp_aer(mastercompptr_aer(ll,itype)) - mw_aer(ll,itype) = mw_mastercomp_aer(mastercompptr_aer(ll,itype)) - hygro_aer(ll,itype) = hygro_mastercomp_aer(mastercompptr_aer(ll,itype)) - name_aer(ll,itype) = name_mastercomp_aer(mastercompptr_aer(ll,itype)) - end do - end do - - is_aerosol(:) = .false. - do iphase=1,nphase_aer - do itype=1,ntype_aer - do n = 1, nsize_aer(itype) - do ll = 1, ncomp_aer(itype) - is_aerosol(massptr_aer(ll,n,itype,iphase))=.true. - end do - is_aerosol(numptr_aer(n,itype,iphase))=.true. - end do ! size - end do ! type - end do ! phase - -! for sectional -! the dhi/dlo_sect are the upper/lower bounds for -! mean-volume diameter for a section/bin -! for modal -! they should be set to reasonable upper/lower -! bounds for mean-volume diameters of each modes -! they are primarily used to put reasonable bounds -! on number (in relation to mass/volume) -! the dcen_sect are used by initwet for the impaction scavenging -! lookup tables, and should represent a "base" mean-volume diameter -! dp_meanvol_tmp (below) is the made-sorgam default initial value -! for mean-volume diameter (in cm) -! terminology: (pi/6) * (mean-volume diameter)**3 == -! (volume mixing ratio of section/mode)/(number mixing ratio) -! - dhi_sect(:,:) = 0.0 - dlo_sect(:,:) = 0.0 - - itype = 1 - isize = 1 - sigmag_aer(isize,itype) = sginin ! aitken - dp_meanvol_tmp = 1.0e2*dginin*exp(1.5*l2sginin) ! aitken - dcen_sect(isize,itype) = dp_meanvol_tmp - dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 - dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 - - itype = 1 - isize = 2 - sigmag_aer(isize,itype) = sginia ! accum - dp_meanvol_tmp = 1.0e2*dginia*exp(1.5*l2sginia) ! accum - dcen_sect(isize,itype) = dp_meanvol_tmp - dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 - dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 - - itype = 2 - isize = 1 - sigmag_aer(isize,itype) = sginic ! coarse - dp_meanvol_tmp = 1.0e2*dginic*exp(1.5*l2sginic) ! coarse - dcen_sect(isize,itype) = dp_meanvol_tmp - dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 - dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 - - do itype = 1, ntype_aer - do isize = 1, nsize_aer(itype) - volumcen_sect(isize,itype) = (pirs/6.0)*(dcen_sect(isize,itype)**3) - volumlo_sect(isize,itype) = (pirs/6.0)*(dlo_sect(isize,itype)**3) - volumhi_sect(isize,itype) = (pirs/6.0)*(dhi_sect(isize,itype)**3) - end do - end do - - -! do initialization of the impaction/interception scavenging -! lookup tables - call initwet( & - ntype_aer, nsize_aer, ncomp_aer, & - massptr_aer, dens_aer, numptr_aer, & - maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, & - dcen_sect, sigmag_aer, & - waterptr_aer, dens_water_aer, & - scavimptblvol, scavimptblnum, nimptblgrow_mind, & - nimptblgrow_maxd, dlndg_nimptblgrow ) - - END SUBROUTINE aerosols_sorgam_init_aercld_ptrs - - !**************************************************************** ! * ! SUBROUTINE TO INITIALIZE AEROSOL VALUES USING THE * @@ -9215,13 +8744,15 @@ END SUBROUTINE sorgam_source_du !=========================================================================== - subroutine wetscav_sorgam_driver (id,ktau,dtstep,ktauc,config_flags, & - dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & - qlsink,precr,preci,precs,precg,qsrflx, & - gas_aqfrac, numgas_aqfrac, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) +!!!TUCCELLA (BUG, now wetscav_sorgam_driver is in module_prep_wetscav_sorgam.F) + +! subroutine wetscav_sorgam_driver (id,ktau,dtstep,ktauc,config_flags, & +! dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & +! qlsink,precr,preci,precs,precg,qsrflx, & +! gas_aqfrac, numgas_aqfrac, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) ! wet removal by grid-resolved precipitation ! scavenging of cloud-phase aerosols and gases by collection, freezing, ... @@ -9229,61 +8760,61 @@ subroutine wetscav_sorgam_driver (id,ktau,dtstep,ktauc,config_flags, & ! scavenging of gas-phase gases by mass transfer and reaction !---------------------------------------------------------------------- - USE module_configure - USE module_state_description - USE module_data_sorgam - USE module_mosaic_wetscav,only: wetscav +! USE module_configure +! USE module_state_description +! USE module_data_sorgam +! USE module_mosaic_wetscav,only: wetscav !---------------------------------------------------------------------- - IMPLICIT NONE +! IMPLICIT NONE - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags +! TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - INTEGER, INTENT(IN ) :: & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte, & - id, ktau, ktauc, numgas_aqfrac - REAL, INTENT(IN ) :: dtstep,dtstepc +! INTEGER, INTENT(IN ) :: & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte, & +! id, ktau, ktauc, numgas_aqfrac +! REAL, INTENT(IN ) :: dtstep,dtstepc ! ! all advected chemical species ! - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & +! INTENT(INOUT ) :: chem ! fraction of gas species in cloud water - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), & - INTENT(IN ) :: gas_aqfrac +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), & +! INTENT(IN ) :: gas_aqfrac ! ! ! input from meteorology - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & - INTENT(IN ) :: & - alt, & - t_phy, & - p_phy, & - t8w,p8w, & - qlsink,precr,preci,precs,precg, & - rho_phy,cldfra - REAL, DIMENSION( ims:ime, jms:jme, num_chem ), & - INTENT(OUT ) :: qsrflx ! column change due to scavening - - call wetscav (id,ktau,dtstep,ktauc,config_flags, & - dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & - qlsink,precr,preci,precs,precg,qsrflx, & - gas_aqfrac, numgas_aqfrac, & - ntype_aer, nsize_aer, ncomp_aer, & - massptr_aer, dens_aer, numptr_aer, & - maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, & - volumcen_sect, volumlo_sect, volumhi_sect, & - waterptr_aer, dens_water_aer, & - scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd, dlndg_nimptblgrow, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - - end subroutine wetscav_sorgam_driver +! REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & +! INTENT(IN ) :: & +! alt, & +! t_phy, & +! p_phy, & +! t8w,p8w, & +! qlsink,precr,preci,precs,precg, & +! rho_phy,cldfra +! REAL, DIMENSION( ims:ime, jms:jme, num_chem ), & +! INTENT(OUT ) :: qsrflx ! column change due to scavening + +! call wetscav (id,ktau,dtstep,ktauc,config_flags, & +! dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & +! qlsink,precr,preci,precs,precg,qsrflx, & +! gas_aqfrac, numgas_aqfrac, & +! ntype_aer, nsize_aer, ncomp_aer, & +! massptr_aer, dens_aer, numptr_aer, & +! maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, & +! volumcen_sect, volumlo_sect, volumhi_sect, & +! waterptr_aer, dens_water_aer, & +! scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd, dlndg_nimptblgrow, & +! ids,ide, jds,jde, kds,kde, & +! ims,ime, jms,jme, kms,kme, & +! its,ite, jts,jte, kts,kte ) + +! end subroutine wetscav_sorgam_driver END Module module_aerosols_sorgam diff --git a/wrfv2_fire/chem/module_bioemi_megan2.F b/wrfv2_fire/chem/module_bioemi_megan2.F index 93b9528c..50d7ef27 100644 --- a/wrfv2_fire/chem/module_bioemi_megan2.F +++ b/wrfv2_fire/chem/module_bioemi_megan2.F @@ -454,7 +454,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ! get p_of_megan2racm(:), p_of_racm(:), and racm_per_megan(:) CALL get_megan2racm_table - CASE (RACM_SOA_VBS_KPP) + CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) !get p_of_megan2racm(:), p_of_racm(:), and racm_per_megan(:) CALL get_megan2racmSOA_table @@ -1137,7 +1137,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & END DO - CASE (CB05_SORG_AQ_KPP) + CASE (RACM_SOA_VBS_AQCHEM_KPP,CB05_SORG_AQ_KPP) DO icount = 1, n_megan2cb05 IF ( p_of_cb05 (icount) .NE. non_react ) THEN diff --git a/wrfv2_fire/chem/module_chem_cup.F b/wrfv2_fire/chem/module_chem_cup.F index 4cc37186..2de7926e 100644 --- a/wrfv2_fire/chem/module_chem_cup.F +++ b/wrfv2_fire/chem/module_chem_cup.F @@ -1587,14 +1587,14 @@ subroutine chem_cup_1d( & end if do_updraft_mixratio_calc + chem_dn(:,:) = 0.0_r8 !BSINGH(03/11/2015): Moved out of the if(do_dndraft) condition to avoid uninitilized chem_dn + zav_chem_dn(:) = 0.0_r8 !BSINGH(03/11/2015): Moved out of the if(do_dndraft) condition to avoid uninitilized zav_chem_dn ! ! calculate aerosol and gas profiles in the dndraft ! do_dndraft_mixratio_calc: & if ( do_dndraft ) then - chem_dn(:,:) = 0.0_r8 - zav_chem_dn(:) = 0.0_r8 tmp_mfxchem_dn = 0.0_r8 dndraft_mixratio_k_loop: & diff --git a/wrfv2_fire/chem/module_chem_plumerise_scalar.F b/wrfv2_fire/chem/module_chem_plumerise_scalar.F index 8500de7b..543b1905 100644 --- a/wrfv2_fire/chem/module_chem_plumerise_scalar.F +++ b/wrfv2_fire/chem/module_chem_plumerise_scalar.F @@ -606,8 +606,9 @@ SUBROUTINE MAKEPLUME ( kmt,ztopmax,ixx,imm) tmelt, heatsubl, heatfus, heatcond, tfreeze, & ztopmax, wmax, rmaxtime, es, esat, heat,dt_save !ESAT_PR, character (len=2) :: cixx +! Set threshold to be the same as dz=100., the constant grid spacing of plume grid model(meters) found in set_grid() + REAL :: DELZ_THRESOLD = 100. - REAL :: DELZ_THRESOLD INTEGER :: imm ! real, external:: esat_pr! diff --git a/wrfv2_fire/chem/module_ctrans_grell.F b/wrfv2_fire/chem/module_ctrans_grell.F index f4245859..e3d64ff9 100755 --- a/wrfv2_fire/chem/module_ctrans_grell.F +++ b/wrfv2_fire/chem/module_ctrans_grell.F @@ -1465,10 +1465,11 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte,ipr,jpr,j,npr,num_chem,name) ! USE module_configure +!!!TUCCELLA USE module_state_description, only: RADM2SORG,RADM2SORG_AQ,RACMSORG_AQ,RACMSORG_KPP, & RADM2SORG_KPP,RACM_ESRLSORG_KPP,RACM_SOA_VBS_KPP, & RADM2SORG_AQCHEM,RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP, & - CB05_SORG_VBS_AQ_KPP + RACM_SOA_VBS_AQCHEM_KPP,CB05_SORG_VBS_AQ_KPP USE module_ctrans_aqchem USE module_input_chem_data, only: get_last_gas implicit none @@ -1669,13 +1670,13 @@ SUBROUTINE cup_up_tracer(ierr,tcrit,t,pre,z_cup,p,tracer,tre_cup,tr_up, & ! ! Aqueous chemistry ! - +!!! TUCCELLA if ((chemopt .EQ. RADM2SORG .OR. chemopt .EQ. RADM2SORG_AQ .OR. chemopt .EQ. RACMSORG_AQ .OR. & chemopt .EQ. RACMSORG_KPP .OR. chemopt .EQ. RADM2SORG_KPP .OR. chemopt .EQ. RACM_ESRLSORG_KPP .OR. & chemopt .EQ. RACM_SOA_VBS_KPP .OR. chemopt .EQ. RADM2SORG_AQCHEM .OR. chemopt .EQ. RACMSORG_AQCHEM_KPP .OR. & - chemopt .EQ. RACM_ESRLSORG_AQCHEM_KPP .OR. & - chemopt .EQ. CB05_SORG_VBS_AQ_KPP) & - .AND. conv_tr_aqchem == 1 ) then + chemopt .EQ. CB05_SORG_VBS_AQ_KPP .OR. & + chemopt .EQ. RACM_ESRLSORG_AQCHEM_KPP .OR. chemopt .EQ. RACM_SOA_VBS_AQCHEM_KPP) & + .and. (conv_tr_aqchem == 1)) then ! ! For MADE/SORGAM derived schemes with aqueous chemistry diff --git a/wrfv2_fire/chem/module_data_uoc_wd.F b/wrfv2_fire/chem/module_data_uoc_wd.F new file mode 100755 index 00000000..7cfd0e54 --- /dev/null +++ b/wrfv2_fire/chem/module_data_uoc_wd.F @@ -0,0 +1,48 @@ +MODULE module_data_uoc_wd +! + integer, parameter :: wmax = 17 + real, dimension(wmax) :: rainwd, dustwd + real, dimension(wmax, wmax) :: edatawd +! + data rainwd /50, 63, 79, 100, 126, 158, 200, 251, 316, 398, 501, 600, 1000, 1400, 1800, 2400, 3000/ + data dustwd /1.0,1.1,1.2,1.4,1.6,1.8,2.0,2.30,3.00,3.98,5.01,6.31,7.94,10.0,12.6,15.8,20.0/ +! + data edatawd(1, :) /0.611E-02, 0.471E-02, 0.367E-02, 0.285E-02, 0.223E-02, 0.176E-02, 0.137E-02, & + & 0.108E-02, 0.853E-03, 0.671E-03, 0.526E-03, 0.432E-03, 0.245E-03, 0.167E-03, & + & 0.125E-03, 0.893E-04, 0.688E-04/ + data edatawd(2, :) /0.710E-02, 0.555E-02, 0.443E-02, 0.360E-02, 0.280E-02, 0.220E-02, 1.700e-3, & + & 1.380E-03, 1.090E-03, 0.850E-03, 0.660E-03, 0.540E-03, 0.300E-03, 0.210E-03, & + & 0.155E-03, 1.100E-04, 0.860E-04/ + data edatawd(3, :) /0.825E-02, 0.660E-02, 0.540E-02, 0.450E-02, 0.360E-02, 0.300E-02, 2.40E-03, & + & 2.000e-03, 1.500E-03, 1.200e-03, 0.900E-03, 0.732E-03, 0.400E-03, 0.290E-03, & + & 0.205E-03, 1.550E-04, 1.200E-04/ + data edatawd(4, :) /1.10e-2, 8.95e-3, 8.05e-3, 7.45e-3, 6.65e-3, 5.80e-3, 4.85e-3, 4.50e-3, 3.50e-3, & + & 2.70e-3, 2.15e-3, 1.75e-3, 9.40e-4, 7.50e-4, 5.20e-4, 4.20e-4, 3.65e-4/ + data edatawd(5, :) /1.42e-2, 1.20e-2, 1.17e-2, 1.15e-2, 1.20e-2, 1.15e-2, 1.05e-2, 9.70e-3, 8.50e-3, & + & 7.00e-3, 5.95e-3, 5.05e-3, 2.90e-3, 2.20e-3, 1.70e-3, 1.30e-3, 1.10e-3/ + data edatawd(6, :) /0.018, 0.0155, 0.0165, 0.018, 0.020, 0.021, 2.05e-2, 2.00e-2, 1.90e-2, 1.65e-2, & + & 1.45e-2, 1.30e-2, 8.15e-3, 6.05e-3, 4.60e-3, 3.9e-3, 3.15e-3/ + data edatawd(7, :) /0.022, 0.020, 0.023, 0.027, 0.031, 0.035, 0.037, 0.038, 0.039, 0.035, 0.032, 0.030, & + & 0.020, 1.45e-2, 1.25e-2, 1.00e-2, 7.85e-3/ + data edatawd(8, :) /0.030, 0.029, 0.038, 0.048, 0.058, 0.070, 0.080, 0.085, 0.090, 0.092, 0.090, 0.085, & + & 0.065, 0.051, 0.043, 0.035, 0.030/ + data edatawd(9, :) /0.055, 0.063, 0.098, 0.140, 0.175, 0.210, 0.240, 0.260, 0.275, 0.285, 0.290, 0.284, & + & 0.257, 0.230, 0.210, 0.185, 0.160/ + data edatawd(10,:) /0.110, 0.148, 0.230, 0.321, 0.385, 0.427, 0.461, 0.488, 0.502, 0.510, 0.517, 0.520, & + & 0.490, 0.457, 0.427, 0.387, 0.327/ + data edatawd(11,:) /0.195, 0.288, 0.407, 0.489, 0.548, 0.590, 0.613, 0.632, 0.642, 0.650, 0.655, 0.654, & + & 0.647, 0.620, 0.585, 0.528, 0.454/ + data edatawd(12,:) /0.305, 0.452, 0.554, 0.627, 0.669, 0.694, 0.713, 0.729, 0.740, 0.747, 0.751, 0.752, & + & 0.745, 0.734, 0.704, 0.645, 0.578/ + data edatawd(13,:) /0.435, 0.596, 0.679, 0.725, 0.761, 0.786, 0.806, 0.817, 0.824, 0.828, 0.831, 0.832, & + & 0.831, 0.823, 0.798, 0.751, 0.706/ + data edatawd(14,:) /0.583, 0.696, 0.763, 0.814, 0.842, 0.859, 0.868, 0.873, 0.879, 0.880, 0.882, 0.883, & + & 0.887, 0.878, 0.864, 0.837, 0.810/ + data edatawd(15,:) /0.695, 0.773, 0.833, 0.872, 0.891, 0.898, 0.906, 0.910, 0.915, 0.918, 0.921, 0.922, & + & 0.920, 0.917, 0.908, 0.888, 0.866/ + data edatawd(16,:) /0.737, 0.832, 0.886, 0.912, 0.925, 0.933, 0.938, 0.943, 0.947, 0.951, 0.954, 0.956, & + & 0.955, 0.951, 0.944, 0.928, 0.908/ + data edatawd(17,:) /0.754, 0.887, 0.924, 0.941, 0.950, 0.955, 0.960, 0.965, 0.969, 0.973, 0.977, 0.979, & + & 0.981, 0.977, 0.970, 0.959, 0.941/ +! +END MODULE module_data_uoc_wd \ No newline at end of file diff --git a/wrfv2_fire/chem/module_dep_simple.F b/wrfv2_fire/chem/module_dep_simple.F index 45fd3d67..4f640154 100755 --- a/wrfv2_fire/chem/module_dep_simple.F +++ b/wrfv2_fire/chem/module_dep_simple.F @@ -334,8 +334,9 @@ SUBROUTINE wesely_driver( id, ktau, dtstep, config_flags, current_month, & end do end do end if -! - if (config_flags%chem_opt == RACM_SOA_VBS_KPP) then +!!!!TUCCELLA + if (config_flags%chem_opt == RACM_SOA_VBS_KPP .OR. & + config_flags%chem_opt == RACM_SOA_VBS_AQCHEM_KPP) then do j=jts,jte do i=its,ite ddvel(i,j,p_cvasoa1) = dep_vap*ddvel(i,j,p_hno3) diff --git a/wrfv2_fire/chem/module_dust_load.F b/wrfv2_fire/chem/module_dust_load.F index 41fc1499..54ee373c 100644 --- a/wrfv2_fire/chem/module_dust_load.F +++ b/wrfv2_fire/chem/module_dust_load.F @@ -49,6 +49,7 @@ SUBROUTINE dust_load_driver ( config_flags, & dustload_3(i,j)= dustload_3(i,j) + chem(i,k,j,p_dust_3)/alt(i,k,j) * dz8w(i,k,j) dustload_4(i,j)= dustload_4(i,j) + chem(i,k,j,p_dust_4)/alt(i,k,j) * dz8w(i,k,j) dustload_5(i,j)= dustload_5(i,j) + chem(i,k,j,p_dust_5)/alt(i,k,j) * dz8w(i,k,j) +! if (j.eq.int(0.5*(ite-its)).and.i.eq.int(0.5*(jte-jts))) write(6,*) 'dload', chem(i,k,j,p_dust_5) enddo enddo enddo diff --git a/wrfv2_fire/chem/module_gocart_settling.F b/wrfv2_fire/chem/module_gocart_settling.F index 457d2c73..75e0bae4 100644 --- a/wrfv2_fire/chem/module_gocart_settling.F +++ b/wrfv2_fire/chem/module_gocart_settling.F @@ -204,7 +204,7 @@ END SUBROUTINE gocart_settling_driver subroutine settling(imx,jmx,lmx,nmx,g0,dyn_visc,tc,tmp,p_mid,delz, & imod,graset, grasetvel, uoc, & - den,reff,dt,rh,idust,iseas) + den_in,reff_in,dt,rh,idust,iseas) ! **************************************************************************** ! * * @@ -226,7 +226,7 @@ subroutine settling(imx,jmx,lmx,nmx,g0,dyn_visc,tc,tmp,p_mid,delz, & REAL*8, INTENT(IN) :: tmp(imx,jmx,lmx), delz(imx,jmx,lmx), & rh(imx,jmx,lmx), p_mid(imx,jmx,lmx) ! - REAL*8 :: den(nmx), reff(nmx) + REAL*8, INTENT(IN) :: den_in(nmx), reff_in(nmx) REAL*8, INTENT(INOUT) :: tc(imx,jmx,lmx,nmx) @@ -234,6 +234,7 @@ subroutine settling(imx,jmx,lmx,nmx,g0,dyn_visc,tc,tmp,p_mid,delz, & REAL*8, INTENT(INOUT) :: graset(imx,jmx,nmx) REAL*8, INTENT(OUT) :: grasetvel(imx,jmx,nmx) + REAL*8 :: den(nmx), reff(nmx) ! local variables here REAL*8 :: dt_settl(nmx), rcm(nmx), rho(nmx) INTEGER :: ndt_settl(nmx) REAL*8 :: dzmin, vsettl, dtmax, pres, rhb, rwet(nmx), ratio_r(nmx) @@ -251,23 +252,15 @@ subroutine settling(imx,jmx,lmx,nmx,g0,dyn_visc,tc,tmp,p_mid,delz, & IF ( idust.ne.1 .and. iseas.ne.1 ) RETURN WHERE ( tc(:,:,:,:) < 0.0 ) tc(:,:,:,:) = 1.0D-32 + den = den_in + reff = reff_in dzmin = MINVAL(delz(:,:,:)) IF (idust == 1) growth_fac = 1.0 IF (iseas == 1) growth_fac = 3.0 -! -! For dust_opt = 4 (UoC dust): -! Change dust radius according to the size cut in module_qf03.F -! Size cut: 2.5, 5, 10, 20 [um] in diameter, so far only 4 size bins -! chem(i,k,j,p_dust_5) is for the sum over the size bins; -! So update chem(i,k,j,p_dust_5) by summation of chem(i,k,j,p_dust_1)...(p_dust_4). -! The fifth component of reff_dust is meaningless. ! IF (idust == 1 .and. uoc == 1) then - reff(1) = 1.25D-6 - reff(2) = 2.5D-6 - reff(3) = 5.0D-6 - reff(4) = 10.0D-6 - den(1) = 2560. !also, change dust density for the first size bin + den(1) = 2650. ! constant density is use in UoC dust emission schemes; +! dust radii are now consistent with GOCART dust schemes. [mklose, 03082015] ENDIF DO k = 1, nmx ! k for different size bins @@ -363,17 +356,6 @@ subroutine settling(imx,jmx,lmx,nmx,g0,dyn_visc,tc,tmp,p_mid,delz, & ENDDO !n, time ENDDO !k, bin ! -! For UoC dust schemes, there are 4 size bins: chem(i,k,j,p_dust_5) is the sum -! - IF (uoc .eq. 1) THEN - IF ( idust.eq.1 ) THEN - DO l = 1, lmx - tc(i,j,l,5)=tc(i,j,l,1)+tc(i,j,l,2)+tc(i,j,l,3)+tc(i,j,l,4) - ENDDO - graset(i,j,5)=graset(i,j,1)+graset(i,j,2)+graset(i,j,3)+graset(i,j,4) - ENDIF - ENDIF - ENDDO !i END DO !j !$OMP END PARALLEL DO diff --git a/wrfv2_fire/chem/module_input_chem_data.F b/wrfv2_fire/chem/module_input_chem_data.F index c0ba7fc1..21e2ac31 100755 --- a/wrfv2_fire/chem/module_input_chem_data.F +++ b/wrfv2_fire/chem/module_input_chem_data.F @@ -318,11 +318,12 @@ MODULE module_input_chem_data SUBROUTINE setup_gasprofile_maps(chem_opt, numgas) integer, intent(in) :: chem_opt, numgas +!!! TUCCELLA select case(chem_opt) case (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & RACM_ESRLSORG_AQCHEM_KPP, RACM_ESRLSORG_KPP, RACMSORG_KPP, RACM_SOA_VBS_KPP,& - GOCARTRACM_KPP, GOCARTRADM2,CHEM_TRACER, CHEM_TRACE2) + RACM_SOA_VBS_AQCHEM_KPP,GOCARTRACM_KPP, GOCARTRADM2, CHEM_TRACER, CHEM_TRACE2) call setup_gasprofile_map_radm_racm case (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & @@ -1468,7 +1469,7 @@ SUBROUTINE flow_dep_bdy_chem ( chem, & i_bdy_method = 0 if ((ic .ge. p_so2) .and. (ic .le. p_ho2)) then i_bdy_method = 1 - +!!! TUCCELLA if (config_flags%chem_opt == RACM_KPP .or. & config_flags%chem_opt == GOCARTRACM_KPP .or. & config_flags%chem_opt == RACMSORG_KPP .or. & @@ -1476,7 +1477,8 @@ SUBROUTINE flow_dep_bdy_chem ( chem, & config_flags%chem_opt == RACM_SOA_VBS_KPP .or. & config_flags%chem_opt == RACM_MIM_KPP .or. & config_flags%chem_opt == RACMSORG_AQCHEM_KPP .or. & - config_flags%chem_opt == RACM_ESRLSORG_AQCHEM_KPP ) then + config_flags%chem_opt == RACM_ESRLSORG_AQCHEM_KPP .or. & + config_flags%chem_opt == RACM_SOA_VBS_AQCHEM_KPP ) then i_bdy_method = 9 end if if (config_flags%chem_opt == RACMPM_KPP ) then @@ -2173,10 +2175,11 @@ integer FUNCTION get_last_gas(chem_opt) case (0) get_last_gas = 0 +!!! TUCCELLA case (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & RACM_ESRLSORG_AQCHEM_KPP, RACM_ESRLSORG_KPP, RACMSORG_KPP, RACM_SOA_VBS_KPP,& - GOCARTRACM_KPP,GOCARTRADM2) + RACM_SOA_VBS_AQCHEM_KPP,GOCARTRACM_KPP,GOCARTRADM2) get_last_gas = p_ho2 case (SAPRC99_KPP,SAPRC99_MOSAIC_4BIN_VBS2_KPP, & diff --git a/wrfv2_fire/chem/module_mixactivate_wrappers.F b/wrfv2_fire/chem/module_mixactivate_wrappers.F index f3ccfcb1..71d5292b 100644 --- a/wrfv2_fire/chem/module_mixactivate_wrappers.F +++ b/wrfv2_fire/chem/module_mixactivate_wrappers.F @@ -308,12 +308,116 @@ subroutine sorgam_mixactivate ( & end subroutine sorgam_mixactivate +!!! TUCCELLA + subroutine soa_vbs_mixactivate ( & + id, ktau, dtstep, config_flags, idrydep_onoff, & + rho_phy, t_phy, w, cldfra, cldfra_old, & + ddvel, z, dz8w, p_at_w, t_at_w, exch_h, & + qv, qc, qi, qndrop3d, f_qc, f_qi, chem, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure, only: grid_config_rec_type + use module_state_description, only: num_chem + use module_data_soa_vbs + use module_mixactivate, only: mixactivate + +! wrapper to call mixactivate for sorgam description of aerosol + + implicit none + +! subr arguments + integer, intent(in) :: & + id, ktau, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + idrydep_onoff + + real, intent(in) :: dtstep + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + rho_phy, t_phy, w, & + z, dz8w, p_at_w, t_at_w, exch_h + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme ) :: cldfra, cldfra_old + + real, intent(in), & + dimension( its:ite, jts:jte, num_chem ) :: ddvel + + real, intent(in), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + qv, qc, qi + + LOGICAL, intent(in) :: f_qc, f_qi + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme ) :: & + qndrop3d + + real, intent(inout), & + dimension( ims:ime, kms:kme, jms:jme, 1:num_chem ) :: & + chem + real, intent(out), dimension(ims:ime,kms:kme,jms:jme) :: nsource, & + ccn1,ccn2,ccn3,ccn4,ccn5,ccn6 ! number conc of aerosols activated at supersat + + type(grid_config_rec_type), intent(in) :: config_flags ! local vars + real qsrflx(ims:ime, jms:jme, num_chem) ! dry deposition flux of aerosol + real sumhygro,sumvol + integer i,j,k,l,m,n + real hygro( its:ite, kts:kte, jts:jte,maxd_asize, maxd_atype ) + +! calculate volume-weighted bulk hygroscopicity for each type and size + + do 100 j=jts,jte + do 100 k=kts,kte + do 100 i=its,ite + do n=1,ntype_aer + do m=1,nsize_aer(n) + sumhygro=0 + sumvol=0 + do l=1,ncomp_aer(n) + sumhygro = sumhygro+hygro_aer(l,n)* & + chem(i,k,j,massptr_aer(l,m,n,ai_phase))/dens_aer(l,n) + sumvol = sumvol+chem(i,k,j,massptr_aer(l,m,n,ai_phase))/dens_aer(l,n) + end do ! comp + hygro(i,k,j,m,n)=sumhygro/sumvol + end do ! size + end do ! type + 100 continue + + +! check arguments of mixactivate for consistency between send, receive +! 06-nov-2005 rce - id & ktau added to arg list + call mixactivate( msectional, & + chem, num_chem, qv, qc, qi, qndrop3d, & + t_phy, w, ddvel, idrydep_onoff, & + maxd_acomp, maxd_asize, maxd_atype, maxd_aphase, & + ncomp_aer, nsize_aer, ntype_aer, nphase_aer, & + numptr_aer, massptr_aer, dlo_sect, dhi_sect, sigmag_aer, dcen_sect, & + dens_aer, mw_aer, & + waterptr_aer, hygro, ai_phase, cw_phase, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + rho_phy, z, dz8w, p_at_w, t_at_w, exch_h, & + cldfra, cldfra_old, qsrflx, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + id, ktau, dtstep, & + f_qc, f_qi ) + + end subroutine soa_vbs_mixactivate + subroutine sorgam_vbs_mixactivate ( & id, ktau, dtstep, config_flags, idrydep_onoff, & rho_phy, t_phy, w, cldfra, cldfra_old, & ddvel, z, dz8w, p_at_w, t_at_w, exch_h, & qv, qc, qi, qndrop3d, f_qc, f_qi, chem, & - ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & + ccn1, ccn2, ccn3, ccn4, ccn5, ccn6, nsource, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) diff --git a/wrfv2_fire/chem/module_mosaic_driver.F b/wrfv2_fire/chem/module_mosaic_driver.F index 421c9b8c..52d4247c 100644 --- a/wrfv2_fire/chem/module_mosaic_driver.F +++ b/wrfv2_fire/chem/module_mosaic_driver.F @@ -2109,7 +2109,260 @@ subroutine sum_vbs2 ( & enddo enddo enddo ! type + iphase = 1 + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_a05(i,k,j)= (chem(i,k,j,lptr_pcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(5,itype,iphase))) + + bboa_a05(i,k,j)= (chem(i,k,j,lptr_pcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(5,itype,iphase))) + + soa_a05(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(5,itype,iphase))) + + arosoa_a05(i,k,j)= chem(i,k,j,lptr_ant1_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(5,itype,iphase)) + + + bbsoa_a05(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(5,itype,iphase))) + + hsoa_a05(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(5,itype,iphase))) + + biog_a05(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(5,itype,iphase))) + + + + totoa_a05(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(5,itype,iphase))) + + + enddo + enddo + enddo + enddo ! type + + + iphase = 1 + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_a06(i,k,j)= (chem(i,k,j,lptr_pcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(6,itype,iphase))) + + bboa_a06(i,k,j)= (chem(i,k,j,lptr_pcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(6,itype,iphase))) + + soa_a06(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(6,itype,iphase))) + + arosoa_a06(i,k,j)= chem(i,k,j,lptr_ant1_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(6,itype,iphase)) + + + bbsoa_a06(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(6,itype,iphase))) + + hsoa_a06(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(6,itype,iphase))) + + biog_a06(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(6,itype,iphase))) + + + + totoa_a06(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(6,itype,iphase))) + + + enddo + enddo + enddo + enddo ! type + + iphase = 1 + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_a07(i,k,j)= (chem(i,k,j,lptr_pcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(7,itype,iphase))) + + bboa_a07(i,k,j)= (chem(i,k,j,lptr_pcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(7,itype,iphase))) + + soa_a07(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(7,itype,iphase))) + + arosoa_a07(i,k,j)= chem(i,k,j,lptr_ant1_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(7,itype,iphase)) + + + bbsoa_a07(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(7,itype,iphase))) + + hsoa_a07(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(7,itype,iphase))) + + biog_a07(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(7,itype,iphase))) + + + + totoa_a07(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(7,itype,iphase))) + + + enddo + enddo + enddo + enddo ! type + + + iphase = 1 + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + hoa_a08(i,k,j)= (chem(i,k,j,lptr_pcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(8,itype,iphase))) + + bboa_a08(i,k,j)= (chem(i,k,j,lptr_pcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(8,itype,iphase))) + + soa_a08(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(8,itype,iphase))) + + arosoa_a08(i,k,j)= chem(i,k,j,lptr_ant1_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(8,itype,iphase)) + + + bbsoa_a08(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(8,itype,iphase))) + + hsoa_a08(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(8,itype,iphase))) + + biog_a08(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(8,itype,iphase))) + + + + totoa_a08(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(8,itype,iphase))) + + + enddo + enddo + enddo + enddo ! type end subroutine sum_vbs2 diff --git a/wrfv2_fire/chem/module_mosaic_therm.F b/wrfv2_fire/chem/module_mosaic_therm.F index 7c17b52c..cc5d6178 100644 --- a/wrfv2_fire/chem/module_mosaic_therm.F +++ b/wrfv2_fire/chem/module_mosaic_therm.F @@ -8517,8 +8517,9 @@ subroutine aerosolmtc(vbs_nbin) else start_ind = ipcg1_b_c_g end if - - do iv = start_ind, ngas_ioa + ngas_soa + !BSINGH(03/10/2015): Added 2 in the following do-loop to accomodate oh and gly species. + ! *IMPORTANT*:This is a TEMPORARY fix, we need a better fix for this problem. + do iv = start_ind, ngas_ioa + ngas_soa+2 speed = mean_molecular_speed(t_k,mw_vol(iv)) ! cm/s dg(iv) = 0.1 ! cm^2/s (increased from 0.2 to 0.035 by Manish Shrivastava) freepath(iv) = 3.*dg(iv)/speed diff --git a/wrfv2_fire/chem/module_mozcart_wetscav.F b/wrfv2_fire/chem/module_mozcart_wetscav.F index 6bab3008..75a3d1b7 100644 --- a/wrfv2_fire/chem/module_mozcart_wetscav.F +++ b/wrfv2_fire/chem/module_mozcart_wetscav.F @@ -12,9 +12,11 @@ MODULE module_mozcart_wetscav save +! 20130716 acd_ck_vbsmoz start ! added OVOC washout ! integer, parameter :: wetscav_tab_cnt = 37 integer, parameter :: wetscav_tab_cnt = 37 + 10 +! 20130716 acd_ck_vbsmoz end real, parameter :: zero = 0. real, parameter :: one = 1. real, parameter :: four = 4. @@ -39,6 +41,9 @@ MODULE module_mozcart_wetscav real :: heff(6) real :: molecw logical :: ice_uptake +!++mmb + real :: reteff +!--mmb end type wet_scav type(wet_scav), allocatable :: wet_scav_tab(:) @@ -80,60 +85,75 @@ subroutine wetscav_mozcart_init( id, numgas, config_flags ) call wrf_error_fatal("mozcart_wetscav_init: failed to allocate wet_scav_tab") endif +! 20140707 acd_ck_comment start ! not true anymore, comment can be removed !!---------------------------------------------------------------------- !! NOTE: this table does NOT include an entry for SO4 !!---------------------------------------------------------------------- - wet_scav_tab(1) = wet_scav( 'h2o2', p_h2o2, (/8.33e+04, 7379., 2.2e-12, -3730., 0., 0./), 34.0135994, .false. ) - wet_scav_tab(2) = wet_scav( 'hno3', p_hno3, (/0., 0., 2.6e+06, 8700., 0., 0./), 63.0123405, .true. ) - wet_scav_tab(3) = wet_scav( 'hcho', p_hcho, (/6.30e+03, 6425., 0., 0., 0., 0./), 30.0251999, .false. ) - wet_scav_tab(4) = wet_scav( 'ch3ooh', p_ch3ooh, (/3.11e+02, 5241., 0., 0., 0., 0./), 48.0393982, .false. ) - wet_scav_tab(5) = wet_scav( 'c3h6ooh', p_c3h6ooh, (/2.20e+02, 5653., 0., 0., 0., 0./), 75.0835953, .false. ) - wet_scav_tab(6) = wet_scav( 'paa', p_paa, (/8.37e+02, 5308., 1.8e-04, -1510., 0., 0./), 76.0498047, .false. ) - wet_scav_tab(7) = wet_scav( 'hno4', p_hno4, (/0., 0., 3.2e+01, 0., 0., 0./), 79.0117416, .false. ) - wet_scav_tab(8) = wet_scav( 'onit', p_onit, (/1.00e+03, 6000., 0., 0., 0., 0./), 119.074341, .false. ) - wet_scav_tab(9) = wet_scav( 'mvk', p_mvk, (/1.7e-03, 0., 0., 0., 0., 0./), 70.0878067, .false. ) - wet_scav_tab(10) = wet_scav( 'macr', p_macr, (/1.70e-03, 0., 0., 0., 0., 0./), 70.0878067, .false. ) - wet_scav_tab(11) = wet_scav( 'etooh', p_etooh, (/3.36e+02, 5995., 0., 0., 0., 0./), 62.065197, .false. ) - wet_scav_tab(12) = wet_scav( 'prooh', p_prooh, (/3.36e+02, 5995., 0., 0., 0., 0./), 76.0909958, .false. ) - wet_scav_tab(13) = wet_scav( 'acetp', p_acetp, (/3.36e+02, 5995., 0., 0., 0., 0./), 90.0755997, .false. ) - wet_scav_tab(14) = wet_scav( 'mgly', p_mgly, (/3.71e+03, 7541., 0., 0., 0., 0./), 72.0614014, .false. ) - wet_scav_tab(15) = wet_scav( 'mvkooh', p_mvkooh, (/0., 0., 2.6e+06, 8700., 0., 0./), 120.1008, .false. ) - wet_scav_tab(16) = wet_scav( 'onitr', p_onitr, (/7.51e+03, 6485., 0., 0., 0., 0./), 147.125946, .false. ) - wet_scav_tab(17) = wet_scav( 'isooh', p_isooh, (/0., 0., 2.6e+06, 8700., 0., 0./), 118.127205, .false. ) - wet_scav_tab(18) = wet_scav( 'ch3oh', p_ch3oh, (/2.20e+02, 4934., 0., 0., 0., 0./), 32.0400009, .false. ) - wet_scav_tab(19) = wet_scav( 'c2h5oh', p_c2h5oh, (/2.00e+02, 6500., 0., 0., 0., 0./), 46.0657997, .false. ) - wet_scav_tab(20) = wet_scav( 'glyald', p_glyald, (/4.14e+04, 4630., 0., 0., 0., 0./), 60.0504036, .false. ) - wet_scav_tab(21) = wet_scav( 'hydrald', p_hydrald, (/7.00e+01, 6000., 0., 0., 0., 0./), 100.113007, .false. ) - wet_scav_tab(22) = wet_scav( 'ald', p_ald, (/1.14e+01, 6267., 0., 0., 0., 0./), 44.0510025, .false. ) - wet_scav_tab(23) = wet_scav( 'isopn', p_isopn, (/1.00e+01, 0., 0., 0., 0., 0./), 162.117935, .false. ) - wet_scav_tab(24) = wet_scav( 'alkooh', p_alkooh, (/3.11e+02, 5241., 0., 0., 0., 0./), 104.142501, .false. ) - wet_scav_tab(25) = wet_scav( 'mekooh', p_mekooh, (/3.11e+02, 5241., 0., 0., 0., 0./), 104.101395, .false. ) - wet_scav_tab(26) = wet_scav( 'tolooh', p_tolooh, (/3.11e+02, 5241., 0., 0., 0., 0./), 142.1492, .false. ) - wet_scav_tab(27) = wet_scav( 'terpooh', p_terpooh, (/3.11e+02, 5241., 0., 0., 0., 0./), 186.241394, .false. ) - wet_scav_tab(28) = wet_scav( 'xhno3', -1, (/0., 0., 2.6e+06, 8700., 0., 0./), 63.0123405, .true. ) - wet_scav_tab(29) = wet_scav( 'nh3', p_nh3, (/7.40e+01, 3400., 1.7e-05, -450., 1.0e-14, -6716./), 17.0289402, .false. ) - wet_scav_tab(30) = wet_scav( 'xho2no2', -1, (/0., 0., 3.2e+01, 0., 0., 0./), 79.0117416, .false. ) - wet_scav_tab(31) = wet_scav( 'xisopno3', -1, (/1.00e+01, 0., 0., 0., 0., 0./), 162.117935, .false. ) - wet_scav_tab(32) = wet_scav( 'xonit', -1, (/1.00e+03, 6000., 0., 0., 0., 0./), 119.074341, .false. ) - wet_scav_tab(33) = wet_scav( 'xonitr', -1, (/7.51e+03, 6485., 0., 0., 0., 0./), 147.125946, .false. ) - wet_scav_tab(34) = wet_scav( 'xooh', p_xooh, (/90.5, 5607., 0., 0., 0., 0./), 134.126602, .false. ) - wet_scav_tab(35) = wet_scav( 'ch3cooh', p_ch3cooh, (/4.1e3, 6300., 0., 0., 0., 0./), 60.0503998, .false. ) - wet_scav_tab(36) = wet_scav( 'so2', p_so2, (/1.2, 3100., 1.3e-02, 1965., 0., 0./), 63.961901, .false. ) - wet_scav_tab(37) = wet_scav( 'sulf', p_sulf, (/1e+11, 0., 0., 0., 0., 0./), 98.078, .false. ) ! order of magnitude approx. (Gmitro and Vermeulen, 1964) - +! 20140707 acd_ck_comment end +!++mmb h2o2 ice scavenging ON +! wet_scav_tab(1) = wet_scav( 'h2o2', p_h2o2, (/8.33e+04, 7379., 2.2e-12, -3730., 0., 0./), 34.0135994, .false. ) + wet_scav_tab(1) = wet_scav( 'h2o2', p_h2o2, (/8.33e+04, 7379., 2.2e-12, -3730., 0., 0./), 34.0135994, .true., 0.64 ) +!--mmb + wet_scav_tab(2) = wet_scav( 'hno3', p_hno3, (/0., 0., 2.6e+06, 8700., 0., 0./), 63.0123405, .true., 1. ) +!++mmb KH Sander et al. (2006) +! wet_scav_tab(3) = wet_scav( 'hcho', p_hcho, (/6.30e+03, 6425., 0., 0., 0., 0./), 30.0251999, .false. ) + wet_scav_tab(3) = wet_scav( 'hcho', p_hcho, (/3.23e+03, 7100., 0., 0., 0., 0./), 30.0251999, .true., 0.64 ) +!--mmb + wet_scav_tab(4) = wet_scav( 'ch3ooh', p_ch3ooh, (/3.11e+02, 5241., 0., 0., 0., 0./), 48.0393982, .true., 0.02 ) + wet_scav_tab(5) = wet_scav( 'c3h6ooh', p_c3h6ooh, (/2.20e+02, 5653., 0., 0., 0., 0./), 75.0835953, .false., 0. ) + wet_scav_tab(6) = wet_scav( 'paa', p_paa, (/8.37e+02, 5308., 1.8e-04, -1510., 0., 0./), 76.0498047, .false., 0. ) + wet_scav_tab(7) = wet_scav( 'hno4', p_hno4, (/0., 0., 3.2e+01, 0., 0., 0./), 79.0117416, .false., 0. ) + wet_scav_tab(8) = wet_scav( 'onit', p_onit, (/1.00e+03, 6000., 0., 0., 0., 0./), 119.074341, .false., 0. ) + wet_scav_tab(9) = wet_scav( 'mvk', p_mvk, (/1.7e-03, 0., 0., 0., 0., 0./), 70.0878067, .false., 0. ) + wet_scav_tab(10) = wet_scav( 'macr', p_macr, (/1.70e-03, 0., 0., 0., 0., 0./), 70.0878067, .false., 0. ) + wet_scav_tab(11) = wet_scav( 'etooh', p_etooh, (/3.36e+02, 5995., 0., 0., 0., 0./), 62.065197, .false., 0. ) + wet_scav_tab(12) = wet_scav( 'prooh', p_prooh, (/3.36e+02, 5995., 0., 0., 0., 0./), 76.0909958, .false., 0. ) + wet_scav_tab(13) = wet_scav( 'acetp', p_acetp, (/3.36e+02, 5995., 0., 0., 0., 0./), 90.0755997, .false., 0. ) + wet_scav_tab(14) = wet_scav( 'mgly', p_mgly, (/3.71e+03, 7541., 0., 0., 0., 0./), 72.0614014, .false., 0. ) + wet_scav_tab(15) = wet_scav( 'mvkooh', p_mvkooh, (/0., 0., 2.6e+06, 8700., 0., 0./), 120.1008, .false., 0. ) + wet_scav_tab(16) = wet_scav( 'onitr', p_onitr, (/7.51e+03, 6485., 0., 0., 0., 0./), 147.125946, .false., 0. ) + wet_scav_tab(17) = wet_scav( 'isooh', p_isooh, (/0., 0., 2.6e+06, 8700., 0., 0./), 118.127205, .false., 0. ) + wet_scav_tab(18) = wet_scav( 'ch3oh', p_ch3oh, (/2.20e+02, 4934., 0., 0., 0., 0./), 32.0400009, .false., 0. ) + wet_scav_tab(19) = wet_scav( 'c2h5oh', p_c2h5oh, (/2.00e+02, 6500., 0., 0., 0., 0./), 46.0657997, .false., 0. ) + wet_scav_tab(20) = wet_scav( 'glyald', p_glyald, (/4.14e+04, 4630., 0., 0., 0., 0./), 60.0504036, .false., 0. ) + wet_scav_tab(21) = wet_scav( 'hydrald', p_hydrald, (/7.00e+01, 6000., 0., 0., 0., 0./), 100.113007, .false., 0. ) + wet_scav_tab(22) = wet_scav( 'ald', p_ald, (/1.14e+01, 6267., 0., 0., 0., 0./), 44.0510025, .false., 0. ) + wet_scav_tab(23) = wet_scav( 'isopn', p_isopn, (/1.00e+01, 0., 0., 0., 0., 0./), 162.117935, .false., 0. ) + wet_scav_tab(24) = wet_scav( 'alkooh', p_alkooh, (/3.11e+02, 5241., 0., 0., 0., 0./), 104.142501, .false., 0. ) + wet_scav_tab(25) = wet_scav( 'mekooh', p_mekooh, (/3.11e+02, 5241., 0., 0., 0., 0./), 104.101395, .false., 0. ) + wet_scav_tab(26) = wet_scav( 'tolooh', p_tolooh, (/3.11e+02, 5241., 0., 0., 0., 0./), 142.1492, .false., 0. ) + wet_scav_tab(27) = wet_scav( 'terpooh', p_terpooh, (/3.11e+02, 5241., 0., 0., 0., 0./), 186.241394, .false., 0. ) + wet_scav_tab(28) = wet_scav( 'xhno3', -1, (/0., 0., 2.6e+06, 8700., 0., 0./), 63.0123405, .true., 0. ) + wet_scav_tab(29) = wet_scav( 'nh3', p_nh3, (/7.40e+01, 3400., 1.7e-05, -450., 1.0e-14, -6716./), 17.0289402, .false., 0. ) + wet_scav_tab(30) = wet_scav( 'xho2no2', -1, (/0., 0., 3.2e+01, 0., 0., 0./), 79.0117416, .false., 0. ) + wet_scav_tab(31) = wet_scav( 'xisopno3', -1, (/1.00e+01, 0., 0., 0., 0., 0./), 162.117935, .false., 0. ) + wet_scav_tab(32) = wet_scav( 'xonit', -1, (/1.00e+03, 6000., 0., 0., 0., 0./), 119.074341, .false., 0. ) + wet_scav_tab(33) = wet_scav( 'xonitr', -1, (/7.51e+03, 6485., 0., 0., 0., 0./), 147.125946, .false., 0. ) + wet_scav_tab(34) = wet_scav( 'xooh', p_xooh, (/90.5, 5607., 0., 0., 0., 0./), 134.126602, .false., 0. ) + wet_scav_tab(35) = wet_scav( 'ch3cooh', p_ch3cooh, (/4.1e3, 6300., 0., 0., 0., 0./), 60.0503998, .false., 0. ) +! 20131125 acd_ck_bugfix start +! 20140619 acd_mb_bugfix start + wet_scav_tab(36) = wet_scav( 'so2', p_so2, (/1.2, 3100., 1.3e-02, 1965., 0., 0./), 63.961901, .true., 0.02 ) +! 20140619 acd_mb_bugfix end + wet_scav_tab(37) = wet_scav( 'sulf', p_sulf, (/1e+11, 0., 0., 0., 0., 0./), 98.078, .false., 0. ) ! order of magnitude approx. (Gmitro and Vermeulen, 1964) +! 20131125 acd_ck_bugfix end + +! 20130729 acd_ck_vbsmoz start +! 20130911 acd_ck_vbsdep mark IF (config_flags%chem_opt == MOZART_MOSAIC_4BIN_AQ_KPP) THEN - wet_scav_tab(38) = wet_scav( 'cvasoaX', p_cvasoaX, (/0.0e+00, 0., 0., 0., 0., 0./), 150.0, .false. ) - wet_scav_tab(39) = wet_scav( 'cvasoa1', p_cvasoa1, (/1.06E+08, 6014., 0., 0., 0., 0./), 150.0, .false. ) - wet_scav_tab(40) = wet_scav( 'cvasoa2', p_cvasoa2, (/1.84E+07, 6014., 0., 0., 0., 0./), 150.0, .false. ) - wet_scav_tab(41) = wet_scav( 'cvasoa3', p_cvasoa3, (/3.18E+06, 6014., 0., 0., 0., 0./), 150.0, .false. ) - wet_scav_tab(42) = wet_scav( 'cvasoa4', p_cvasoa4, (/5.50E+05, 6014., 0., 0., 0., 0./), 150.0, .false. ) - wet_scav_tab(43) = wet_scav( 'cvbsoaX', p_cvbsoaX, (/0.0e+00, 0., 0., 0., 0., 0./), 180.0, .false. ) - wet_scav_tab(44) = wet_scav( 'cvbsoa1', p_cvbsoa1, (/5.25E+09, 6014., 0., 0., 0., 0./), 180.0, .false. ) - wet_scav_tab(45) = wet_scav( 'cvbsoa2', p_cvbsoa2, (/7.00E+08, 6014., 0., 0., 0., 0./), 180.0, .false. ) - wet_scav_tab(46) = wet_scav( 'cvbsoa3', p_cvbsoa3, (/9.33E+07, 6014., 0., 0., 0., 0./), 180.0, .false. ) - wet_scav_tab(47) = wet_scav( 'cvbsoa4', p_cvbsoa4, (/1.24E+07, 6014., 0., 0., 0., 0./), 180.0, .false. ) + wet_scav_tab(38) = wet_scav( 'cvasoaX', p_cvasoaX, (/0.0e+00, 0., 0., 0., 0., 0./), 150.0, .false., 0. ) + wet_scav_tab(39) = wet_scav( 'cvasoa1', p_cvasoa1, (/1.06E+08, 6014., 0., 0., 0., 0./), 150.0, .false., 0. ) + wet_scav_tab(40) = wet_scav( 'cvasoa2', p_cvasoa2, (/1.84E+07, 6014., 0., 0., 0., 0./), 150.0, .false., 0. ) + wet_scav_tab(41) = wet_scav( 'cvasoa3', p_cvasoa3, (/3.18E+06, 6014., 0., 0., 0., 0./), 150.0, .false., 0. ) + wet_scav_tab(42) = wet_scav( 'cvasoa4', p_cvasoa4, (/5.50E+05, 6014., 0., 0., 0., 0./), 150.0, .false., 0. ) + wet_scav_tab(43) = wet_scav( 'cvbsoaX', p_cvbsoaX, (/0.0e+00, 0., 0., 0., 0., 0./), 180.0, .false., 0. ) + wet_scav_tab(44) = wet_scav( 'cvbsoa1', p_cvbsoa1, (/5.25E+09, 6014., 0., 0., 0., 0./), 180.0, .false., 0. ) + wet_scav_tab(45) = wet_scav( 'cvbsoa2', p_cvbsoa2, (/7.00E+08, 6014., 0., 0., 0., 0./), 180.0, .false., 0. ) + wet_scav_tab(46) = wet_scav( 'cvbsoa3', p_cvbsoa3, (/9.33E+07, 6014., 0., 0., 0., 0./), 180.0, .false., 0. ) + wet_scav_tab(47) = wet_scav( 'cvbsoa4', p_cvbsoa4, (/1.24E+07, 6014., 0., 0., 0., 0./), 180.0, .false., 0. ) ENDIF + ! 20130729 acd_ck_vbsmoz end hetcnt = 0 do m = param_first_scalar,numgas @@ -199,8 +219,10 @@ subroutine wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, qv_b4mp, qc_b4mp, qi_b4mp, qs_b4mp, & gas_aqfrac, numgas_aqfrac, dz8w, dx, dy, & qv, qc, qi, qs, & +! 20131125 acd_ck_washout start ! hno3_col_mdel, & delta_mass_col, & +! 20131125 acd_ck_washout end ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -260,11 +282,13 @@ subroutine wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & INTENT(INOUT ) :: cldfra +! 20131125 acd_ck_washout start ! REAL, DIMENSION( ims:ime , jms:jme ) , & ! INTENT(INOUT ) :: hno3_col_mdel REAL, DIMENSION( ims:ime , jms:jme, num_chem ) , & INTENT(OUT ) :: delta_mass_col +! 20131125 acd_ck_washout end !---------------------------------------------------------------------- ! local variables @@ -306,6 +330,10 @@ subroutine wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, logical :: is_hno3 logical :: tckaqb(hetcnt) +!++mmb + REAL :: reteff(hetcnt) +!--mmb + character(len=128) :: message has_wet_scav : & @@ -326,8 +354,10 @@ subroutine wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, diff(:,:,:) = 0. cld_col_cnt = 0 precip_col_cnt = 0 +! 20131125 acd_ck_washout start ! hno3_col_mdel(:,:) = 0. delta_mass_col(:,:,:) = 0. +! 20131125 acd_ck_washout end max_rls = 0. jloop : & do j = jts,jte @@ -401,6 +431,9 @@ subroutine wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, endif endif tckaqb(m) = any( heff(kts:ktem1,m) > henry_thres ) +!++mmb + reteff(m) = wet_scav_tab(m1)%reteff +!--mmb end do species_loop !---------------------------------------------------------------------- @@ -409,17 +442,22 @@ subroutine wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, CALL washout( kte-kts+1, hetcnt, dtstep, trc_mass, layer_mass, & p, dz8w(i,kts:kte,j), rls, qc_b4mp(i,kts:kte,j), qi_b4mp(i,kts:kte,j), & cldfra(i,kts:kte,j), t, evaprate, area, heff, & - mol_wght, tckaqb, ice_uptake, i, j ) +!++mmb +! mol_wght, tckaqb, ice_uptake, i, j ) + mol_wght, tckaqb, ice_uptake, i, j, reteff ) +!--mmb species_loop1 : & do m = 1,hetcnt m1 = wrf2tab(m) pndx = wet_scav_tab(m1)%p_ndx is_hno3 = pndx == p_hno3 +! 20131125 acd_ck_washout start ! if( is_hno3 ) then ! hno3_col_mdel(i,j) = sum( trc_mass(kts:ktem1,m) ) - wrk_mass(m) ! endif delta_mass_col(i,j,pndx) = sum( trc_mass(kts:ktem1,m) ) - wrk_mass(m) +! 20131125 acd_ck_washout end wrk(kts:ktem1) = 1.e6*mwdry*trc_mass(kts:ktem1,m)/mol_wght(m) chem(i,kts:ktem1,j,pndx) = wrk(kts:ktem1)/layer_mass(kts:ktem1) @@ -705,7 +743,10 @@ END SUBROUTINE cal_cldfra2 subroutine WASHOUT( LPAR, NTRACE, DTSCAV, QTTJFL, QM, & POFL, DELZ, RLS, CLWC, CIWC, & CFR, TEM, EVAPRATE, GAREA, HSTAR, & - TCMASS, TCKAQB, TCNION, ii, jj ) +!++mmb +! TCMASS, TCKAQB, TCNION, ii, jj ) + TCMASS, TCKAQB, TCNION, ii, jj, RETEFF ) +!--mmb !----------------------------------------------------------------------- !---p-conde 5.4 (2007) -----called from main----- !---called from pmain to calculate rainout and washout of tracers @@ -738,6 +779,9 @@ subroutine WASHOUT( LPAR, NTRACE, DTSCAV, QTTJFL, QM, & real, intent(inout) :: QTTJFL(LPAR,NTRACE) logical, intent(in) :: TCKAQB(NTRACE) logical, intent(in) :: TCNION(NTRACE) +!++mmb + real, intent(in) :: RETEFF(NTRACE) +!--mmb !----------------------------------------------------------------------- ! local variables @@ -1120,7 +1164,10 @@ subroutine WASHOUT( LPAR, NTRACE, DTSCAV, QTTJFL, QM, & RRAIN = RPRECIP*GAREA !kg/s local call DISGAS( CLWX, CFXX(L), TCMASS(N), HSTAR(L,N), & TEM(L),POFL(L),QM(L), & - QTT(L)*CFXX(L),QTDISCF ) +!++mmb +! QTT(L)*CFXX(L),QTDISCF ) + QTT(L)*CFXX(L),QTDISCF, is_hno3, RETEFF(N) ) +!--mmb call RAINGAS( RRAIN, DTSCAV, CLWX, CFXX(L), & QM(L), QTT(L), QTDISCF, QTRAIN ) WRK = QTRAIN/CFXX(L) @@ -1148,7 +1195,10 @@ subroutine WASHOUT( LPAR, NTRACE, DTSCAV, QTTJFL, QM, & QTCXA = QTT(L)*FCXA call DISGAS( CLWX*(FCXA/CFXX(L)), FCXA, TCMASS(N), & HSTAR(L,N), TEM(L), POFL(L), & - QM(L), QTCXA, QTDISRIME ) +!++mmb +! QM(L), QTCXA, QTDISRIME ) + QM(L), QTCXA, QTDISRIME, is_hno3, RETEFF(N) ) +!--mmb QTDISSTAR = (QTDISRIME*QTCXA)/(QTDISRIME + QTCXA) QTRIMECXA = QTCXA* & (one - exp((-COLEFFSNOW/(DCA*1.e-3))* & @@ -1214,7 +1264,10 @@ subroutine WASHOUT( LPAR, NTRACE, DTSCAV, QTTJFL, QM, & RRAIN = (RPRECIP*GAREA) !kg/s local call DISGAS( CLWX, CFXX(L), TCMASS(N), HSTAR(L,N), & TEM(L), POFL(L), QM(L), & - QTT(L)*CFXX(L), QTDISCF ) +!++mmb +! QTT(L)*CFXX(L), QTDISCF ) + QTT(L)*CFXX(L), QTDISCF, is_hno3, RETEFF(N) ) +!--mmb call RAINGAS( RRAIN, DTSCAV, CLWX, CFXX(L), & QM(L), QTT(L), QTDISCF, QTRAIN ) WRK = QTRAIN/CFXX(L) @@ -1231,7 +1284,10 @@ subroutine WASHOUT( LPAR, NTRACE, DTSCAV, QTTJFL, QM, & QTCXA = QTT(L)*FCXA call DISGAS( CLWX*(FCXA/CFXX(L)), FCXA, TCMASS(N), & HSTAR(L,N), TEM(L), POFL(L), & - QM(L), QTCXA, QTDISRIME ) +!++mmb +! QM(L), QTCXA, QTDISRIME ) + QM(L), QTCXA, QTDISRIME, is_hno3, RETEFF(N) ) +!--mmb QTDISSTAR = (QTDISRIME*QTCXA)/(QTDISRIME + QTCXA) QTRIMECXA = QTCXA* & (one - exp(-0.24*COLEFFRAIN* & @@ -1373,7 +1429,10 @@ subroutine WASHOUT( LPAR, NTRACE, DTSCAV, QTTJFL, QM, & !----------------------------------------------------------------------- call DISGAS( (MASSLOSS/QM(L)), FCXA, TCMASS(N), & HSTAR(L,N), TEM(L), POFL(L), & - QM(L), QTT(L), QTEVAPCXA ) +!++mmb +! QM(L), QTT(L), QTEVAPCXA ) + QM(L), QTT(L), QTEVAPCXA, is_hno3, RETEFF(N) ) +!--mmb QTEVAPCXA = min( QTTOPCA,QTEVAPCXA ) else QTEVAPCXA = zero @@ -1389,7 +1448,10 @@ subroutine WASHOUT( LPAR, NTRACE, DTSCAV, QTTJFL, QM, & if( QTT(L) > zero ) then call DISGAS( CLWX*(FCXA/CFXX(L)), FCXA, TCMASS(N), & HSTAR(L,N), TEM(L), POFL(L), & - QM(L), QTCXA, QTDISCXA ) +!++mmb +! QM(L), QTCXA, QTDISCXA ) + QM(L), QTCXA, QTDISCXA, is_hno3, RETEFF(N) ) +!--mmb if( QTCXA > QTDISCXA ) then QTWASHCXA = (QTCXA - QTDISCXA)*(one - exp( -0.24*COLEFFAER*((RCXA)**0.75)*DTSCAV )) !local else @@ -1628,7 +1690,10 @@ end subroutine WASHOUT subroutine DISGAS( CLWX, CFX, MOLMASS, HSTAR, & TM, PR, QM, & - QT, QTDIS ) +!++mmb +! QT, QTDIS ) + QT, QTDIS, is_hno3, RETEFF ) +!--mmb !----------------------------------------------------------------------- ! dummy arguments @@ -1641,11 +1706,21 @@ subroutine DISGAS( CLWX, CFX, MOLMASS, HSTAR, & real, intent(in) :: QM !air mass in box (kg) real, intent(in) :: QT !tracer in box (kg) real, intent(out) :: QTDIS !tracer dissolved in aqueous phase + +!++mmb + logical, intent(in) :: is_hno3 + real, intent(in) :: RETEFF !Ice retention parameter +!--mmb !----------------------------------------------------------------------- ! local variables !----------------------------------------------------------------------- - real, parameter :: RETEFF = 0.5 + +!++mmb +! real, parameter :: RETEFF = 0.5 +! real, parameter :: RETEFF = 1.0 +!--mmb + real :: MUEMP !----------------------------------------------------------------------- @@ -1660,7 +1735,10 @@ subroutine DISGAS( CLWX, CFX, MOLMASS, HSTAR, & !----------------------------------------------------------------------- if( TM >= TICE ) then QTDIS = (HSTAR*(QT/(QM*CFX))*0.029*(PR/1.0e3))*(CLWX*QM) - elseif( TM <= TMIX ) then +!++mmb +! elseif( TM <= TMIX ) then + elseif( TM <= TMIX .and. is_hno3 ) then +!--mmb MUEMP = exp( -14.2252 + TM*(1.55704e-1 - 7.1929e-4*TM) ) QTDIS = MUEMP*(MOLMASS/18.)*(CLWX*QM) else diff --git a/wrfv2_fire/chem/module_optical_averaging.F b/wrfv2_fire/chem/module_optical_averaging.F index e8ff7332..fb55f4df 100644 --- a/wrfv2_fire/chem/module_optical_averaging.F +++ b/wrfv2_fire/chem/module_optical_averaging.F @@ -208,9 +208,12 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & real fv complex aa, bb character*150 msg + integer :: uoc_flag ! flag for UoC dust emissions ! save :: sizeaer,extaer,waer,gaer,tauaer,bscoef ! save :: l2,l3,l4,l5,l6,l7 !---------------------------------------------------------------------------------- + uoc_flag = 0 + if (config_flags%dust_opt .eq. 4) uoc_flag = 1 ! ! write( msg, '(a, 6i4)' ) & ! 'jdf ', ids, ide, jds, jde, kds, kde @@ -224,7 +227,6 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & chem_select: SELECT CASE(config_flags%chem_opt) ! CASE (RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & - RACM_SOA_VBS_KPP, & RACM_ESRLSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP, & CBMZSORG, CBMZSORG_AQ, & @@ -238,6 +240,17 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) +!!! TUCCELLA + CASE (RACM_SOA_VBS_KPP, RACM_SOA_VBS_AQCHEM_KPP) + call optical_prep_modal_soa_vbs(nbin_o, chem, alt, & +! h2oai, h2oaj, refindx, radius_wet, number_bin, & +! radius_core, refindx_core, refindx_shell, & + h2oai, h2oaj, radius_core,radius_wet, number_bin, & + swrefindx,swrefindx_core, swrefindx_shell, & + lwrefindx,lwrefindx_core, lwrefindx_shell, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) CASE (CB05_SORG_VBS_AQ_KPP) call optical_prep_modal_vbs(nbin_o, chem, alt, & ! h2oai, h2oaj, refindx, radius_wet, number_bin, & @@ -284,6 +297,7 @@ subroutine optical_averaging(id,curr_secs,dtstep,config_flags, & radius_core,radius_wet, number_bin, & swrefindx,swrefindx_core, swrefindx_shell, & lwrefindx,lwrefindx_core, lwrefindx_shell, & + uoc_flag, & ! mklose ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -1667,17 +1681,25 @@ subroutine optical_prep_modal(nbin_o, chem, alt, & end subroutine optical_prep_modal +!!!! TUCCELLA !---------------------------------------------------------------------------------- -! This subroutine computes volume-averaged refractive index and wet radius needed -! by the mie calculations. Aerosol number is also passed into the mie calculations + +! 03/07/2014 added by Paolo Tuccella +! It is a modification of optical_prep_modal subroutine for +! RACM_SOA_VBS_KPP aerosol model + +! This subroutine computes volume-averaged refractive index and wet radius +! needed +! by the mie calculations. Aerosol number is also passed into the mie +! calculations ! in terms of other units. ! - subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & + subroutine optical_prep_modal_soa_vbs(nbin_o, chem, alt, & ! h2oai, h2oaj, refindx, radius_wet, number_bin, & ! radius_core, refindx_core, refindx_shell, & - h2oai, h2oaj, radius_core,radius_wet, number_bin, & - swrefindx, swrefindx_core, swrefindx_shell, & - lwrefindx, lwrefindx_core, lwrefindx_shell, & + h2oai, h2oaj, radius_core,radius_wet, number_bin, & + swrefindx, swrefindx_core, swrefindx_shell, & + lwrefindx, lwrefindx_core, lwrefindx_shell, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -1686,7 +1708,8 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & ! USE module_state_description USE module_model_constants USE module_state_description, only: param_first_scalar - USE module_data_sorgam_vbs +! USE module_data_sorgam + USE module_data_soa_vbs ! INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte, nbin_o INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme @@ -1697,12 +1720,12 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(IN ) :: alt, h2oai, h2oaj REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & - INTENT(OUT ) :: & + INTENT(OUT ) :: & radius_wet, number_bin, radius_core ! COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & ! INTENT(OUT ) :: & ! refindx, refindx_core, refindx_shell - COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nswbands), & +COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nswbands), & INTENT(OUT ) :: swrefindx, swrefindx_core, swrefindx_shell COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nlwbands), & INTENT(OUT ) :: lwrefindx, lwrefindx_core, lwrefindx_shell @@ -1711,50 +1734,59 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & ! integer i, j, k, l, isize, itype, iphase integer p1st - complex ref_index_lvcite , ref_index_nh4hso4, & - ref_index_nh4msa , ref_index_nh4no3 , ref_index_nh4cl , & - ref_index_nano3 , ref_index_na2so4, & - ref_index_na3hso4, ref_index_nahso4 , ref_index_namsa, & - ref_index_caso4 , ref_index_camsa2 , ref_index_cano3, & - ref_index_cacl2 , ref_index_caco3 , ref_index_h2so4, & - ref_index_hhso4 , ref_index_hno3 , ref_index_hcl, & - ref_index_msa , ref_index_bc, & - ref_index_oin , ref_index_aro1 , ref_index_aro2, & - ref_index_alk1 , ref_index_ole1 , ref_index_api1, & - ref_index_api2 , ref_index_lim1 , ref_index_lim2, & + complex ref_index_lvcite , ref_index_nh4hso4 , & + ref_index_nh4msa , ref_index_nh4no3 , ref_index_nh4cl , & + ref_index_nano3 , ref_index_na2so4 , & + ref_index_na3hso4 , ref_index_nahso4 , ref_index_namsa , & + ref_index_caso4 , ref_index_camsa2 , ref_index_cano3 , & + ref_index_cacl2 , ref_index_caco3 , ref_index_h2so4 , & + ref_index_hhso4 , ref_index_hno3 , ref_index_hcl , & + ref_index_msa , ref_index_bc , & +! ref_index_oin , ref_index_aro1 , ref_index_aro2 , & +! ref_index_alk1 , ref_index_ole1 , ref_index_api1 , & + ref_index_oin , ref_index_soa1 , ref_index_soa2 , & + ref_index_soa3 , ref_index_soa4 , & +! ref_index_api1 , & +! ref_index_api2 , ref_index_lim1 , ref_index_lim2 , & ri_dum , ri_ave_a - COMPLEX, DIMENSION(nswbands) :: & ! now only 5 aerosols have wave-dependent refr + COMPLEX, DIMENSION(nswbands) :: & ! now only 5 aerosols have wave-dependent refr swref_index_oc , swref_index_dust , swref_index_nh4so4, swref_index_nacl,swref_index_h2o - COMPLEX, DIMENSION(nlwbands) :: & ! now only 5 aerosols have wave-dependent refr + COMPLEX, DIMENSION(nlwbands) :: & ! now only 5 aerosols have wave-dependent refr lwref_index_oc , lwref_index_dust , lwref_index_nh4so4, lwref_index_nacl,lwref_index_h2o real dens_so4 , dens_no3 , dens_cl , dens_msa , dens_co3 , & dens_nh4 , dens_na , dens_ca , dens_oin , dens_oc , & - dens_bc , dens_aro1 , dens_aro2 , dens_alk1 , dens_ole1, & - dens_api1 , dens_api2 , dens_lim1 , dens_lim2 , dens_h2o , & - dens_dust +! dens_bc , dens_aro1 , dens_aro2 , dens_alk1 , dens_ole1, & +! dens_bc , dens_soa1 , dens_soa2 , dens_soa3 , dens_soa4, & +! dens_api1 , dens_api2 , dens_lim1 , dens_lim2 , dens_h2o , & + dens_bc , dens_h2o , dens_dust real mass_so4 , mass_no3 , mass_cl , mass_msa , mass_co3 , & mass_nh4 , mass_na , mass_ca , mass_oin , mass_oc , & - mass_bc , mass_aro1 , mass_aro2 , mass_alk1 , mass_ole1, & - mass_api1 , mass_api2 , mass_lim1 , mass_lim2 , mass_h2o, & - mass_dust - real mass_so4i , mass_no3i , mass_cli , mass_msai , mass_co3i, & - mass_nh4i , mass_nai , mass_cai , mass_oini , mass_oci , & - mass_bci , mass_aro1i, mass_aro2i, mass_alk1i, mass_ole1i, & - mass_ba1i , mass_ba2i, mass_ba3i , mass_ba4i , mass_pai, & + mass_bc , & +! mass_aro1 , mass_aro2 , mass_alk1 , mass_ole1, & +! mass_api1 , mass_api2 , mass_lim1 , mass_lim2 , mass_h2o , & + mass_h2o , mass_dust + real mass_so4i , mass_no3i , mass_cli , mass_msai , mass_co3i , & + mass_nh4i , mass_nai , mass_cai , mass_oini , mass_oci , & +! mass_bci , mass_aro1i, mass_aro2i, mass_alk1i, mass_ole1i , & +! mass_ba1i , mass_ba2i, mass_ba3i , mass_ba4i , mass_pai , & + mass_bci , mass_asoa1i, mass_asoa2i, mass_asoa3i, mass_asoa4i , & + mass_bsoa1i , mass_bsoa2i, mass_bsoa3i , mass_bsoa4i , mass_pai, & mass_h2oi , mass_dusti real mass_so4j , mass_no3j , mass_clj , mass_msaj , mass_co3j, & mass_nh4j , mass_naj , mass_caj , mass_oinj , mass_ocj , & - mass_bcj , mass_aro1j, mass_aro2j, mass_alk1j, mass_ole1j, & - mass_ba1j , mass_ba2j, mass_ba3j , mass_ba4j , mass_paj, & +! mass_bcj , mass_aro1j, mass_aro2j, mass_alk1j, mass_ole1j, & +! mass_ba1j , mass_ba2j, mass_ba3j , mass_ba4j , mass_paj, & + mass_bcj , mass_asoa1j, mass_asoa2j, mass_asoa3j, mass_asoa4j , & + mass_bsoa1j , mass_bsoa2j, mass_bsoa3j , mass_bsoa4j , mass_paj, & mass_h2oj , mass_dustj real mass_antha, mass_seas, mass_soil real num_ai, num_aj, num_ac, vol_ai, vol_aj, vol_ac real vol_so4 , vol_no3 , vol_cl , vol_msa , vol_co3 , & vol_nh4 , vol_na , vol_ca , vol_oin , vol_oc , & - vol_bc , vol_aro1 , vol_aro2 , vol_alk1 , vol_ole1 , & - vol_api1 , vol_api2 , vol_lim1 , vol_lim2 , vol_h2o , & - vol_dust +! vol_bc , vol_aro1 , vol_aro2 , vol_alk1 , vol_ole1 , & +! vol_api1 , vol_api2 , vol_lim1 , vol_lim2 , vol_h2o , & + vol_bc , vol_h2o , vol_dust real conv1a, conv1b real mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell, & dp_dry_a , dp_wet_a , num_a , dp_bc_a @@ -1766,9 +1798,10 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & real, dimension(1:nbin_o) :: xnum_secti,xnum_sectj,xnum_sectc real, dimension(1:nbin_o) :: xmas_secti,xmas_sectj,xmas_sectc real, dimension(1:nbin_o) :: xdia_um, xdia_cm + ! ! real sginin,sginia,sginic from module_data_sorgam.F -! +! ! Mass from modal distribution is divided into individual sections before ! being passed back into the Mie routine. ! * currently use the same size bins as 8 default MOSAIC size bins @@ -1803,17 +1836,17 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & ! do ns = 1, nswbands swref_index_nh4so4(ns) = cmplx(refrsw_sulf(ns),refisw_sulf(ns)) - swref_index_oc(ns) = cmplx(refrsw_oc(ns),refisw_oc(ns)) - swref_index_dust(ns) = cmplx(refrsw_dust(ns),refisw_dust(ns)) - swref_index_nacl(ns) = cmplx(refrsw_seas(ns),refisw_seas(ns)) - swref_index_h2o(ns) = cmplx(refrwsw(ns),refiwsw(ns)) + swref_index_oc(ns) = cmplx(refrsw_oc(ns),refisw_oc(ns)) + swref_index_dust(ns) = cmplx(refrsw_dust(ns),refisw_dust(ns)) + swref_index_nacl(ns) = cmplx(refrsw_seas(ns),refisw_seas(ns)) + swref_index_h2o(ns) = cmplx(refrwsw(ns),refiwsw(ns)) enddo do ns = 1, nlwbands lwref_index_nh4so4(ns) = cmplx(refrlw_sulf(ns),refilw_sulf(ns)) - lwref_index_oc(ns) = cmplx(refrlw_oc(ns),refilw_oc(ns)) - lwref_index_dust(ns) = cmplx(refrlw_dust(ns),refilw_dust(ns)) - lwref_index_nacl(ns) = cmplx(refrlw_seas(ns),refilw_seas(ns)) - lwref_index_h2o(ns) = cmplx(refrwlw(ns),refiwlw(ns)) + lwref_index_oc(ns) = cmplx(refrlw_oc(ns),refilw_oc(ns)) + lwref_index_dust(ns) = cmplx(refrlw_dust(ns),refilw_dust(ns)) + lwref_index_nacl(ns) = cmplx(refrlw_seas(ns),refilw_seas(ns)) + lwref_index_h2o(ns) = cmplx(refrwlw(ns),refiwlw(ns)) enddo ! ref_index_nh4so4 = cmplx(1.52,0.) @@ -1845,17 +1878,23 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & ! and Tech., 40:27-67. ! ref_index_bc = cmplx(1.82,0.74) old value ref_index_bc = cmplx(1.85,0.71) - ref_index_oin = cmplx(1.55,0.006) ! JCB, Feb. 20, 2008: "other inorganics" -! ref_index_dust = cmplx(1.55,0.003) ! czhao, this refractive index should be wavelength depedent - ref_index_aro1 = cmplx(1.45,0.) - ref_index_aro2 = cmplx(1.45,0.) - ref_index_alk1 = cmplx(1.45,0.) - ref_index_ole1 = cmplx(1.45,0.) - ref_index_api1 = cmplx(1.45,0.) - ref_index_api2 = cmplx(1.45,0.) - ref_index_lim1 = cmplx(1.45,0.) - ref_index_lim2 = cmplx(1.45,0.) -! ref_index_h2o = cmplx(1.33,0.) + ref_index_oin = cmplx(1.55,0.006) ! JCB, Feb. 20, 2008: "other inorganics" +! ref_index_dust = cmplx(1.55,0.003) ! czhao, this refractive index +! should be wavelength depedent +! ref_index_aro1 = cmplx(1.45,0.) +! ref_index_aro2 = cmplx(1.45,0.) +! ref_index_alk1 = cmplx(1.45,0.) +! ref_index_ole1 = cmplx(1.45,0.) + ref_index_soa1 = cmplx(1.45,0.) + ref_index_soa2 = cmplx(1.45,0.) + ref_index_soa3 = cmplx(1.45,0.) + ref_index_soa4 = cmplx(1.45,0.) +! ref_index_api1 = cmplx(1.45,0.) +! ref_index_api2 = cmplx(1.45,0.) +! ref_index_lim1 = cmplx(1.45,0.) +! ref_index_lim2 = cmplx(1.45,0.) +! ref_index_h2o = cmplx(1.33,0.) + ! ! densities in g/cc ! @@ -1865,24 +1904,25 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & dens_msa = 1.8 ! used dens_co3 = 2.6 ! used dens_nh4 = 1.8 ! used - dens_na = 2.2 ! used + dens_na = 2.2 ! used dens_ca = 2.6 ! used dens_oin = 2.6 ! used dens_dust = 2.6 ! used - dens_oc = 1.0 ! used + !dens_oc = 1.0 ! used + dens_oc = 1.6 ! used ! JCB, Feb. 20, 2008: the density of BC is updated to reflect values ! published by Bond and Bergstrom, Light absorption by carboneceous ! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67. ! dens_bc = 1.7 ! used, old value dens_bc = 1.8 ! midpoint of Bond and Bergstrom value - dens_aro1 = 1.0 - dens_aro2 = 1.0 - dens_alk1 = 1.0 - dens_ole1 = 1.0 - dens_api1 = 1.0 - dens_api2 = 1.0 - dens_lim1 = 1.0 - dens_lim2 = 1.0 +! dens_aro1 = 1.0 +! dens_aro2 = 1.0 +! dens_alk1 = 1.0 +! dens_ole1 = 1.0 +! dens_api1 = 1.0 +! dens_api2 = 1.0 +! dens_lim1 = 1.0 +! dens_lim2 = 1.0 dens_h2o = 1.0 ! p1st = param_first_scalar @@ -1905,6 +1945,7 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & ! itype=1 iphase=1 + do j = jts, jte do k = kts, kte do i = its, ite @@ -1918,22 +1959,30 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & mass_oinj = 0.0 mass_dusti = 0.0 mass_dustj = 0.0 - mass_aro1i = 0.0 - mass_aro1j = 0.0 - mass_aro2i = 0.0 - mass_aro2j = 0.0 - mass_alk1i = 0.0 - mass_alk1j = 0.0 - mass_ole1i = 0.0 - mass_ole1j = 0.0 - mass_ba1i = 0.0 - mass_ba1j = 0.0 - mass_ba2i = 0.0 - mass_ba2j = 0.0 - mass_ba3i = 0.0 - mass_ba3j = 0.0 - mass_ba4i = 0.0 - mass_ba4j = 0.0 +! mass_aro1i = 0.0 +! mass_aro1j = 0.0 +! mass_aro2i = 0.0 +! mass_aro2j = 0.0 +! mass_alk1i = 0.0 +! mass_alk1j = 0.0 +! mass_ole1i = 0.0 +! mass_ole1j = 0.0 + mass_asoa1i= 0.0 + mass_asoa1j= 0.0 + mass_asoa2i= 0.0 + mass_asoa2j= 0.0 + mass_asoa3i= 0.0 + mass_asoa3j= 0.0 + mass_asoa4i= 0.0 + mass_asoa4j= 0.0 + mass_bsoa1i = 0.0 + mass_bsoa1j = 0.0 + mass_bsoa2i = 0.0 + mass_bsoa2j = 0.0 + mass_bsoa3i = 0.0 + mass_bsoa3j = 0.0 + mass_bsoa4i = 0.0 + mass_bsoa4j = 0.0 mass_pai = 0.0 mass_paj = 0.0 mass_oci = 0.0 @@ -1984,22 +2033,38 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & if (l .ge. p1st) mass_oinj= chem(i,k,j,l)*conv1a !jdfcz l=lptr_dust_aer(isize,itype,iphase) !jdfcz if (l .ge. p1st) mass_dustj= chem(i,k,j,l)*conv1a +! l=lptr_orgaro1_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_aro1j= chem(i,k,j,l)*conv1a +! l=lptr_orgaro2_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_aro2j= chem(i,k,j,l)*conv1a +! l=lptr_orgalk_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_alk1j= chem(i,k,j,l)*conv1a +! l=lptr_orgole_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_ole1j= chem(i,k,j,l)*conv1a +! l=lptr_orgba1_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_ba1j= chem(i,k,j,l)*conv1a +! l=lptr_orgba2_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_ba2j= chem(i,k,j,l)*conv1a +! l=lptr_orgba3_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_ba3j= chem(i,k,j,l)*conv1a +! l=lptr_orgba4_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_ba4j= chem(i,k,j,l)*conv1a l=lptr_asoa1_aer(isize,itype,iphase) - if (l .ge. p1st) mass_aro1j= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_asoa1j= chem(i,k,j,l)*conv1a l=lptr_asoa2_aer(isize,itype,iphase) - if (l .ge. p1st) mass_aro2j= chem(i,k,j,l)*conv1a +if (l .ge. p1st) mass_asoa2j= chem(i,k,j,l)*conv1a l=lptr_asoa3_aer(isize,itype,iphase) - if (l .ge. p1st) mass_alk1j= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_asoa3j= chem(i,k,j,l)*conv1a l=lptr_asoa4_aer(isize,itype,iphase) - if (l .ge. p1st) mass_ole1j= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_asoa4j= chem(i,k,j,l)*conv1a l=lptr_bsoa1_aer(isize,itype,iphase) - if (l .ge. p1st) mass_ba1j= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_bsoa1j= chem(i,k,j,l)*conv1a l=lptr_bsoa2_aer(isize,itype,iphase) - if (l .ge. p1st) mass_ba2j= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_bsoa2j= chem(i,k,j,l)*conv1a l=lptr_bsoa3_aer(isize,itype,iphase) - if (l .ge. p1st) mass_ba3j= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_bsoa3j= chem(i,k,j,l)*conv1a l=lptr_bsoa4_aer(isize,itype,iphase) - if (l .ge. p1st) mass_ba4j= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_bsoa4j= chem(i,k,j,l)*conv1a l=lptr_orgpa_aer(isize,itype,iphase) if (l .ge. p1st) mass_paj= chem(i,k,j,l)*conv1a l=lptr_ec_aer(isize,itype,iphase) @@ -2011,11 +2076,11 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & l=numptr_aer(isize,itype,iphase) if (l .ge. p1st) num_aj= chem(i,k,j,l)*conv1b mass_h2oj= h2oaj(i,k,j) * 1.0e-12 - mass_ocj=mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ & - mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j+mass_paj + mass_ocj=mass_asoa1j+mass_asoa2j+mass_asoa3j+mass_asoa4j+ & + mass_bsoa1j+mass_bsoa2j+mass_bsoa3j+mass_bsoa4j+mass_paj ! Aitken mode... -! isize = 1 ; itype = 2 ! before march-2008 ordering +! isize = 1 ; itype = 1 ! before march-2008 ordering isize = 1 ; itype = 1 ! after march-2008 ordering l=lptr_so4_aer(isize,itype,iphase) if (l .ge. p1st) mass_so4i= chem(i,k,j,l)*conv1a @@ -2027,22 +2092,38 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & if (l .ge. p1st) mass_oini= chem(i,k,j,l)*conv1a !jdfcz l=lptr_dust_aer(isize,itype,iphase) !jdfcz if (l .ge. p1st) mass_dusti= chem(i,k,j,l)*conv1a +! l=lptr_orgaro1_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_aro1i= chem(i,k,j,l)*conv1a +! l=lptr_orgaro2_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_aro2i= chem(i,k,j,l)*conv1a +! l=lptr_orgalk_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_alk1i= chem(i,k,j,l)*conv1a +! l=lptr_orgole_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_ole1i= chem(i,k,j,l)*conv1a +! l=lptr_orgba1_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_ba1i= chem(i,k,j,l)*conv1a +! l=lptr_orgba2_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_ba2i= chem(i,k,j,l)*conv1a +! l=lptr_orgba3_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_ba3i= chem(i,k,j,l)*conv1a +! l=lptr_orgba4_aer(isize,itype,iphase) +! if (l .ge. p1st) mass_ba4i= chem(i,k,j,l)*conv1a l=lptr_asoa1_aer(isize,itype,iphase) - if (l .ge. p1st) mass_aro1i= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_asoa1i= chem(i,k,j,l)*conv1a l=lptr_asoa2_aer(isize,itype,iphase) - if (l .ge. p1st) mass_aro2i= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_asoa2i= chem(i,k,j,l)*conv1a l=lptr_asoa3_aer(isize,itype,iphase) - if (l .ge. p1st) mass_alk1i= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_asoa3i= chem(i,k,j,l)*conv1a l=lptr_asoa4_aer(isize,itype,iphase) - if (l .ge. p1st) mass_ole1i= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_asoa4i= chem(i,k,j,l)*conv1a l=lptr_bsoa1_aer(isize,itype,iphase) - if (l .ge. p1st) mass_ba1i= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_bsoa1i= chem(i,k,j,l)*conv1a l=lptr_bsoa2_aer(isize,itype,iphase) - if (l .ge. p1st) mass_ba2i= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_bsoa2i= chem(i,k,j,l)*conv1a l=lptr_bsoa3_aer(isize,itype,iphase) - if (l .ge. p1st) mass_ba3i= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_bsoa3i= chem(i,k,j,l)*conv1a l=lptr_bsoa4_aer(isize,itype,iphase) - if (l .ge. p1st) mass_ba4i= chem(i,k,j,l)*conv1a + if (l .ge. p1st) mass_bsoa4i= chem(i,k,j,l)*conv1a l=lptr_orgpa_aer(isize,itype,iphase) if (l .ge. p1st) mass_pai= chem(i,k,j,l)*conv1a l=lptr_ec_aer(isize,itype,iphase) @@ -2054,8 +2135,8 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & l=numptr_aer(isize,itype,iphase) if (l .ge. p1st) num_ai= chem(i,k,j,l)*conv1b mass_h2oi= h2oai(i,k,j) * 1.0e-12 - mass_oci=mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ & - mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i+mass_pai + mass_oci=mass_asoa1i+mass_asoa2i+mass_asoa3i+mass_asoa4i+ & + mass_bsoa1i+mass_bsoa2i+mass_bsoa3i+mass_bsoa4i+mass_pai ! Coarse mode... ! isize = 1 ; itype = 3 ! before march-2008 ordering @@ -2069,38 +2150,40 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & l=numptr_aer(isize,itype,iphase) if (l .ge. p1st) num_ac= chem(i,k,j,l)*conv1b - vol_ai = (mass_so4i/dens_so4)+(mass_no3i/dens_no3)+ & - (mass_nh4i/dens_nh4)+(mass_oini/dens_oin)+ & - (mass_aro1i/dens_oc)+(mass_alk1i/dens_oc)+ & - (mass_ole1i/dens_oc)+(mass_ba1i/dens_oc)+ & - (mass_ba2i/dens_oc)+(mass_ba3i/dens_oc)+ & - (mass_ba4i/dens_oc)+(mass_pai/dens_oc)+ & - (mass_aro2i/dens_oc)+(mass_bci/dens_bc)+ & - (mass_nai/dens_na)+(mass_cli/dens_cl) + + vol_ai = (mass_so4i/dens_so4) + (mass_no3i/dens_no3) + & + (mass_nh4i/dens_nh4) + (mass_oini/dens_oin) + & + (mass_asoa1i + mass_asoa2i + & + mass_asoa3i + mass_asoa4i + & + mass_bsoa1i + mass_bsoa2i + & + mass_bsoa3i + mass_bsoa4i + & + mass_pai)/dens_oc + (mass_bci/dens_bc) + & + (mass_nai/dens_na) + (mass_cli/dens_cl) !jdfcz (mass_nai/dens_na)+(mass_cli/dens_cl) + & !jdfcz (mass_dusti/dens_dust) - vol_aj = (mass_so4j/dens_so4)+(mass_no3j/dens_no3)+ & - (mass_nh4j/dens_nh4)+(mass_oinj/dens_oin)+ & - (mass_aro1j/dens_oc)+(mass_alk1j/dens_oc)+ & - (mass_ole1j/dens_oc)+(mass_ba1j/dens_oc)+ & - (mass_ba2j/dens_oc)+(mass_ba3j/dens_oc)+ & - (mass_ba4j/dens_oc)+(mass_paj/dens_oc)+ & - (mass_aro2j/dens_oc)+(mass_bcj/dens_bc)+ & - (mass_naj/dens_na)+(mass_clj/dens_cl) -!jdfcz (mass_naj/dens_na)+(mass_clj/dens_cl) + & + + vol_aj = (mass_so4j/dens_so4) + (mass_no3j/dens_no3) + & + (mass_nh4j/dens_nh4) + (mass_oinj/dens_oin) + & + (mass_asoa1j + mass_asoa2j + & + mass_asoa3j + mass_asoa4j + & + mass_bsoa1j + mass_bsoa2j + & + mass_bsoa3j + mass_bsoa4j + & + mass_paj)/dens_oc + (mass_bcj/dens_bc) + & + (mass_naj/dens_na) + (mass_clj/dens_cl) +!jdfcz (mass_naj/dens_na)+(mass_clj/dens_cl) + & !jdfcz (mass_dustj/dens_dust) vol_ac = (mass_antha/dens_oin)+ & (mass_seas*(22.9897/58.4428)/dens_na)+ & (mass_seas*(35.4270/58.4428)/dens_cl)+ & (mass_soil/dens_dust) - ! ! Now divide mass into sections which is done by sect02: ! * xmas_secti is for aiken mode ! * xmas_sectj is for accumulation mode ! * xmas_sectc is for coarse mode ! * sect02 expects input in um -! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins +! * pass in generic mass of 1.0 just to get a percentage distribution of mass +! among bins ! ss1=alog(sginin) ss2=exp(ss1*ss1*36.0/8.0) @@ -2128,12 +2211,15 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & mass_nh4 = mass_nh4i*xmas_secti(isize) + mass_nh4j*xmas_sectj(isize) mass_oin = mass_oini*xmas_secti(isize) + mass_oinj*xmas_sectj(isize) + & mass_antha*xmas_sectc(isize) -!jdfcz mass_dust= mass_dusti*xmas_secti(isize) + mass_dustj*xmas_sectj(isize) + & +!jdfcz mass_dust= mass_dusti*xmas_secti(isize) + mass_dustj*xmas_sectj(isize) +!+ & !jdfcz mass_soil*xmas_sectc(isize) - mass_oc = (mass_pai+mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ & - mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i)*xmas_secti(isize) + & - (mass_paj+mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ & - mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j)*xmas_sectj(isize) + !mass_oc = (mass_pai+mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ & + ! mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i)*xmas_secti(isize) + ! + & + ! (mass_paj+mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ & + ! mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j)*xmas_sectj(isize) + mass_oc = mass_oci*xmas_secti(isize) + mass_ocj*xmas_sectj(isize) mass_bc = mass_bci*xmas_secti(isize) + mass_bcj*xmas_sectj(isize) mass_na = mass_nai*xmas_secti(isize) + mass_naj*xmas_sectj(isize)+ & mass_seas*xmas_sectc(isize)*(22.9897/58.4428) @@ -2173,12 +2259,13 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & vol_oc + vol_bc + vol_na + vol_cl vol_wet_a = vol_dry_a + vol_h2o vol_shell = vol_wet_a - vol_bc - !num_a = vol_wet_a / (0.52359877*xdia_cm(isize)*xdia_cm(isize)*xdia_cm(isize)) - !czhao + !num_a = vol_wet_a / + !(0.52359877*xdia_cm(isize)*xdia_cm(isize)*xdia_cm(isize)) + !czhao num_a = num_ai*xnum_secti(isize)+num_aj*xnum_sectj(isize)+num_ac*xnum_sectc(isize) - !shortwave + !shortwave do ns=1,nswbands ri_dum = (0.0,0.0) ri_dum = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) + & @@ -2189,7 +2276,8 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & (swref_index_dust(ns) * mass_oin / dens_dust) + & (swref_index_oc(ns) * mass_oc / dens_oc) + & (ref_index_bc * mass_bc / dens_bc) + & - (swref_index_nacl(ns) * mass_na / dens_na) + & + +(swref_index_nacl(ns) * mass_na / dens_na) + & (swref_index_nacl(ns) * mass_cl / dens_cl) + & (swref_index_h2o(ns) * mass_h2o / dens_h2o) ! @@ -2226,7 +2314,7 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & swrefindx_core(i,k,j,isize,ns) = ref_index_bc swrefindx_shell(i,k,j,isize,ns) = ref_index_oin elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then - swrefindx(i,k,j,isize,ns) = (1.5,0.0) +swrefindx(i,k,j,isize,ns) = (1.5,0.0) radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 number_bin(i,k,j,isize) =num_a radius_core(i,k,j,isize) =0.0 @@ -2242,7 +2330,8 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & endif enddo ! ns shortwave - !longwave + + !longwave do ns=1,nlwbands ri_dum = (0.0,0.0) ri_dum = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) + & @@ -2262,7 +2351,7 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & ! IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then dp_dry_a = xdia_cm(isize) - dp_wet_a = xdia_cm(isize) +dp_wet_a = xdia_cm(isize) dp_bc_a = xdia_cm(isize) ri_ave_a = 0.0 ri_dum = 0.0 @@ -2315,13 +2404,19 @@ subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & return - end subroutine optical_prep_modal_vbs +END subroutine optical_prep_modal_soa_vbs -!------------------------------------------------------------------ - subroutine optical_prep_mam(nbin_o, chem, alt, & - radius_core,radius_wet, number_bin, & - swrefindx, swrefindx_core, swrefindx_shell, & - lwrefindx, lwrefindx_core, lwrefindx_shell, & +!---------------------------------------------------------------------------------- +! This subroutine computes volume-averaged refractive index and wet radius needed +! by the mie calculations. Aerosol number is also passed into the mie calculations +! in terms of other units. +! + subroutine optical_prep_modal_vbs(nbin_o, chem, alt, & +! h2oai, h2oaj, refindx, radius_wet, number_bin, & +! radius_core, refindx_core, refindx_shell, & + h2oai, h2oaj, radius_core,radius_wet, number_bin, & + swrefindx, swrefindx_core, swrefindx_shell, & + lwrefindx, lwrefindx_core, lwrefindx_shell, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -2330,7 +2425,7 @@ subroutine optical_prep_mam(nbin_o, chem, alt, & ! USE module_state_description USE module_model_constants USE module_state_description, only: param_first_scalar - USE module_data_cam_mam_asect + USE module_data_sorgam_vbs ! INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte, nbin_o INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme @@ -2339,7 +2434,7 @@ subroutine optical_prep_mam(nbin_o, chem, alt, & REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & INTENT(IN ) :: chem REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & - INTENT(IN ) :: alt + INTENT(IN ) :: alt, h2oai, h2oaj REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & INTENT(OUT ) :: & radius_wet, number_bin, radius_core @@ -2363,26 +2458,42 @@ subroutine optical_prep_mam(nbin_o, chem, alt, & ref_index_cacl2 , ref_index_caco3 , ref_index_h2so4, & ref_index_hhso4 , ref_index_hno3 , ref_index_hcl, & ref_index_msa , ref_index_bc, & - ref_index_oin , & + ref_index_oin , ref_index_aro1 , ref_index_aro2, & + ref_index_alk1 , ref_index_ole1 , ref_index_api1, & + ref_index_api2 , ref_index_lim1 , ref_index_lim2, & ri_dum , ri_ave_a - COMPLEX, DIMENSION(nswbands) :: & ! now only 5 aerosols have wave-dependent refr + COMPLEX, DIMENSION(nswbands) :: & ! now only 5 aerosols have wave-dependent refr swref_index_oc , swref_index_dust , swref_index_nh4so4, swref_index_nacl,swref_index_h2o - COMPLEX, DIMENSION(nlwbands) :: & ! now only 5 aerosols have wave-dependent refr + COMPLEX, DIMENSION(nlwbands) :: & ! now only 5 aerosols have wave-dependent refr lwref_index_oc , lwref_index_dust , lwref_index_nh4so4, lwref_index_nacl,lwref_index_h2o - real dens_so4 , dens_ncl , dens_wtr , dens_pom , dens_soa , & - dens_bc , dens_dst - real mass_so4 , mass_ncl , mass_wtr , mass_pom , mass_soa , & - mass_bc , mass_dst - real vol_so4 , vol_ncl , vol_wtr , vol_pom , vol_soa , & - vol_bc , vol_dst - real mass_so4_a1 , mass_so4_a2 , mass_so4_a3, & - mass_ncl_a1 , mass_ncl_a2 , mass_ncl_a3, & - mass_wtr_a1 , mass_wtr_a2 , mass_wtr_a3, & - mass_soa_a1 , mass_soa_a2 , mass_pom_a1, & - mass_bc_a1 , mass_dst_a1 , mass_dst_a3, & - num_a1 , num_a2 , num_a3, & - vol_a1 , vol_a2 , vol_a3 + real dens_so4 , dens_no3 , dens_cl , dens_msa , dens_co3 , & + dens_nh4 , dens_na , dens_ca , dens_oin , dens_oc , & + dens_bc , dens_aro1 , dens_aro2 , dens_alk1 , dens_ole1, & + dens_api1 , dens_api2 , dens_lim1 , dens_lim2 , dens_h2o , & + dens_dust + real mass_so4 , mass_no3 , mass_cl , mass_msa , mass_co3 , & + mass_nh4 , mass_na , mass_ca , mass_oin , mass_oc , & + mass_bc , mass_aro1 , mass_aro2 , mass_alk1 , mass_ole1, & + mass_api1 , mass_api2 , mass_lim1 , mass_lim2 , mass_h2o, & + mass_dust + real mass_so4i , mass_no3i , mass_cli , mass_msai , mass_co3i, & + mass_nh4i , mass_nai , mass_cai , mass_oini , mass_oci , & + mass_bci , mass_aro1i, mass_aro2i, mass_alk1i, mass_ole1i, & + mass_ba1i , mass_ba2i, mass_ba3i , mass_ba4i , mass_pai, & + mass_h2oi , mass_dusti + real mass_so4j , mass_no3j , mass_clj , mass_msaj , mass_co3j, & + mass_nh4j , mass_naj , mass_caj , mass_oinj , mass_ocj , & + mass_bcj , mass_aro1j, mass_aro2j, mass_alk1j, mass_ole1j, & + mass_ba1j , mass_ba2j, mass_ba3j , mass_ba4j , mass_paj, & + mass_h2oj , mass_dustj + real mass_antha, mass_seas, mass_soil + real num_ai, num_aj, num_ac, vol_ai, vol_aj, vol_ac + real vol_so4 , vol_no3 , vol_cl , vol_msa , vol_co3 , & + vol_nh4 , vol_na , vol_ca , vol_oin , vol_oc , & + vol_bc , vol_aro1 , vol_aro2 , vol_alk1 , vol_ole1 , & + vol_api1 , vol_api2 , vol_lim1 , vol_lim2 , vol_h2o , & + vol_dust real conv1a, conv1b real mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell, & dp_dry_a , dp_wet_a , num_a , dp_bc_a @@ -2396,7 +2507,7 @@ subroutine optical_prep_mam(nbin_o, chem, alt, & real, dimension(1:nbin_o) :: xdia_um, xdia_cm ! ! real sginin,sginia,sginic from module_data_sorgam.F -! +! ! Mass from modal distribution is divided into individual sections before ! being passed back into the Mie routine. ! * currently use the same size bins as 8 default MOSAIC size bins @@ -2473,26 +2584,654 @@ subroutine optical_prep_mam(nbin_o, chem, alt, & ! and Tech., 40:27-67. ! ref_index_bc = cmplx(1.82,0.74) old value ref_index_bc = cmplx(1.85,0.71) - ref_index_oin = cmplx(1.55,0.006) ! JCB, Feb. 20, 2008: "other inorganics" + ref_index_oin = cmplx(1.55,0.006) ! JCB, Feb. 20, 2008: "other inorganics" ! ref_index_dust = cmplx(1.55,0.003) ! czhao, this refractive index should be wavelength depedent + ref_index_aro1 = cmplx(1.45,0.) + ref_index_aro2 = cmplx(1.45,0.) + ref_index_alk1 = cmplx(1.45,0.) + ref_index_ole1 = cmplx(1.45,0.) + ref_index_api1 = cmplx(1.45,0.) + ref_index_api2 = cmplx(1.45,0.) + ref_index_lim1 = cmplx(1.45,0.) + ref_index_lim2 = cmplx(1.45,0.) ! ref_index_h2o = cmplx(1.33,0.) ! ! densities in g/cc ! dens_so4 = 1.8 ! used - dens_ncl = 2.2 ! used - dens_dst = 2.6 ! used - dens_pom = 1.0 ! used - dens_soa = 1.0 ! used - dens_wtr = 1.0 -! JCB, Feb. 20, 2008: the density of BC is updated to reflect values -! published by Bond and Bergstrom, Light absorption by carboneceous -! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67. -! dens_bc = 1.7 ! used, old value - dens_bc = 1.8 ! midpoint of Bond and Bergstrom value -! - p1st = param_first_scalar -! + dens_no3 = 1.8 ! used + dens_cl = 2.2 ! used + dens_msa = 1.8 ! used + dens_co3 = 2.6 ! used + dens_nh4 = 1.8 ! used + dens_na = 2.2 ! used + dens_ca = 2.6 ! used + dens_oin = 2.6 ! used + dens_dust = 2.6 ! used + dens_oc = 1.0 ! used +! JCB, Feb. 20, 2008: the density of BC is updated to reflect values +! published by Bond and Bergstrom, Light absorption by carboneceous +! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67. +! dens_bc = 1.7 ! used, old value + dens_bc = 1.8 ! midpoint of Bond and Bergstrom value + dens_aro1 = 1.0 + dens_aro2 = 1.0 + dens_alk1 = 1.0 + dens_ole1 = 1.0 + dens_api1 = 1.0 + dens_api2 = 1.0 + dens_lim1 = 1.0 + dens_lim2 = 1.0 + dens_h2o = 1.0 +! + p1st = param_first_scalar +! + swrefindx=0.0 + lwrefindx=0.0 + radius_wet=0.0 + number_bin=0.0 + radius_core=0.0 + swrefindx_core=0.0 + swrefindx_shell=0.0 + lwrefindx_core=0.0 + lwrefindx_shell=0.0 +! +! units: +! * mass - g/cc(air) +! * number - #/cc(air) +! * volume - cc(air)/cc(air) +! * diameter - cm +! + itype=1 + iphase=1 + do j = jts, jte + do k = kts, kte + do i = its, ite + mass_so4i = 0.0 + mass_so4j = 0.0 + mass_no3i = 0.0 + mass_no3j = 0.0 + mass_nh4i = 0.0 + mass_nh4j = 0.0 + mass_oini = 0.0 + mass_oinj = 0.0 + mass_dusti = 0.0 + mass_dustj = 0.0 + mass_aro1i = 0.0 + mass_aro1j = 0.0 + mass_aro2i = 0.0 + mass_aro2j = 0.0 + mass_alk1i = 0.0 + mass_alk1j = 0.0 + mass_ole1i = 0.0 + mass_ole1j = 0.0 + mass_ba1i = 0.0 + mass_ba1j = 0.0 + mass_ba2i = 0.0 + mass_ba2j = 0.0 + mass_ba3i = 0.0 + mass_ba3j = 0.0 + mass_ba4i = 0.0 + mass_ba4j = 0.0 + mass_pai = 0.0 + mass_paj = 0.0 + mass_oci = 0.0 + mass_ocj = 0.0 + mass_bci = 0.0 + mass_bcj = 0.0 + mass_cai = 0.0 + mass_caj = 0.0 + mass_co3i = 0.0 + mass_co3j = 0.0 + mass_nai = 0.0 + mass_naj = 0.0 + mass_cli = 0.0 + mass_clj = 0.0 + mass_msai = 0.0 + mass_msaj = 0.0 + mass_nai = 0.0 + mass_naj = 0.0 + mass_cli = 0.0 + mass_clj = 0.0 + mass_h2oi = 0.0 + mass_h2oj = 0.0 + mass_antha = 0.0 + mass_seas = 0.0 + mass_soil = 0.0 + vol_aj = 0.0 + vol_ai = 0.0 + vol_ac = 0.0 + num_aj = 0.0 + num_ai = 0.0 + num_ac = 0.0 + +! convert ug / kg dry air to g / cc air + conv1a = (1.0/alt(i,k,j)) * 1.0e-12 +! convert # / kg dry air to # / cc air + conv1b = (1.0/alt(i,k,j)) * 1.0e-6 + +! Accumulation mode... +! isize = 1 ; itype = 1 ! before march-2008 ordering + isize = 2 ; itype = 1 ! after march-2008 ordering + l=lptr_so4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_so4j= chem(i,k,j,l)*conv1a + l=lptr_no3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_no3j= chem(i,k,j,l)*conv1a + l=lptr_nh4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_nh4j= chem(i,k,j,l)*conv1a + l=lptr_p25_aer(isize,itype,iphase) + if (l .ge. p1st) mass_oinj= chem(i,k,j,l)*conv1a +!jdfcz l=lptr_dust_aer(isize,itype,iphase) +!jdfcz if (l .ge. p1st) mass_dustj= chem(i,k,j,l)*conv1a + l=lptr_asoa1_aer(isize,itype,iphase) + if (l .ge. p1st) mass_aro1j= chem(i,k,j,l)*conv1a + l=lptr_asoa2_aer(isize,itype,iphase) + if (l .ge. p1st) mass_aro2j= chem(i,k,j,l)*conv1a + l=lptr_asoa3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_alk1j= chem(i,k,j,l)*conv1a + l=lptr_asoa4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ole1j= chem(i,k,j,l)*conv1a + l=lptr_bsoa1_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba1j= chem(i,k,j,l)*conv1a + l=lptr_bsoa2_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba2j= chem(i,k,j,l)*conv1a + l=lptr_bsoa3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba3j= chem(i,k,j,l)*conv1a + l=lptr_bsoa4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba4j= chem(i,k,j,l)*conv1a + l=lptr_orgpa_aer(isize,itype,iphase) + if (l .ge. p1st) mass_paj= chem(i,k,j,l)*conv1a + l=lptr_ec_aer(isize,itype,iphase) + if (l .ge. p1st) mass_bcj= chem(i,k,j,l)*conv1a + l=lptr_na_aer(isize,itype,iphase) + if (l .ge. p1st) mass_naj= chem(i,k,j,l)*conv1a + l=lptr_cl_aer(isize,itype,iphase) + if (l .ge. p1st) mass_clj= chem(i,k,j,l)*conv1a + l=numptr_aer(isize,itype,iphase) + if (l .ge. p1st) num_aj= chem(i,k,j,l)*conv1b + mass_h2oj= h2oaj(i,k,j) * 1.0e-12 + mass_ocj=mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ & + mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j+mass_paj + +! Aitken mode... +! isize = 1 ; itype = 2 ! before march-2008 ordering + isize = 1 ; itype = 1 ! after march-2008 ordering + l=lptr_so4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_so4i= chem(i,k,j,l)*conv1a + l=lptr_no3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_no3i= chem(i,k,j,l)*conv1a + l=lptr_nh4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_nh4i= chem(i,k,j,l)*conv1a + l=lptr_p25_aer(isize,itype,iphase) + if (l .ge. p1st) mass_oini= chem(i,k,j,l)*conv1a +!jdfcz l=lptr_dust_aer(isize,itype,iphase) +!jdfcz if (l .ge. p1st) mass_dusti= chem(i,k,j,l)*conv1a + l=lptr_asoa1_aer(isize,itype,iphase) + if (l .ge. p1st) mass_aro1i= chem(i,k,j,l)*conv1a + l=lptr_asoa2_aer(isize,itype,iphase) + if (l .ge. p1st) mass_aro2i= chem(i,k,j,l)*conv1a + l=lptr_asoa3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_alk1i= chem(i,k,j,l)*conv1a + l=lptr_asoa4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ole1i= chem(i,k,j,l)*conv1a + l=lptr_bsoa1_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba1i= chem(i,k,j,l)*conv1a + l=lptr_bsoa2_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba2i= chem(i,k,j,l)*conv1a + l=lptr_bsoa3_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba3i= chem(i,k,j,l)*conv1a + l=lptr_bsoa4_aer(isize,itype,iphase) + if (l .ge. p1st) mass_ba4i= chem(i,k,j,l)*conv1a + l=lptr_orgpa_aer(isize,itype,iphase) + if (l .ge. p1st) mass_pai= chem(i,k,j,l)*conv1a + l=lptr_ec_aer(isize,itype,iphase) + if (l .ge. p1st) mass_bci= chem(i,k,j,l)*conv1a + l=lptr_na_aer(isize,itype,iphase) + if (l .ge. p1st) mass_nai= chem(i,k,j,l)*conv1a + l=lptr_cl_aer(isize,itype,iphase) + if (l .ge. p1st) mass_cli= chem(i,k,j,l)*conv1a + l=numptr_aer(isize,itype,iphase) + if (l .ge. p1st) num_ai= chem(i,k,j,l)*conv1b + mass_h2oi= h2oai(i,k,j) * 1.0e-12 + mass_oci=mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ & + mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i+mass_pai + +! Coarse mode... +! isize = 1 ; itype = 3 ! before march-2008 ordering + isize = 1 ; itype = 2 ! after march-2008 ordering + l=lptr_anth_aer(isize,itype,iphase) + if (l .ge. p1st) mass_antha= chem(i,k,j,l)*conv1a + l=lptr_seas_aer(isize,itype,iphase) + if (l .ge. p1st) mass_seas= chem(i,k,j,l)*conv1a + l=lptr_soil_aer(isize,itype,iphase) + if (l .ge. p1st) mass_soil= chem(i,k,j,l)*conv1a + l=numptr_aer(isize,itype,iphase) + if (l .ge. p1st) num_ac= chem(i,k,j,l)*conv1b + + vol_ai = (mass_so4i/dens_so4)+(mass_no3i/dens_no3)+ & + (mass_nh4i/dens_nh4)+(mass_oini/dens_oin)+ & + (mass_aro1i/dens_oc)+(mass_alk1i/dens_oc)+ & + (mass_ole1i/dens_oc)+(mass_ba1i/dens_oc)+ & + (mass_ba2i/dens_oc)+(mass_ba3i/dens_oc)+ & + (mass_ba4i/dens_oc)+(mass_pai/dens_oc)+ & + (mass_aro2i/dens_oc)+(mass_bci/dens_bc)+ & + (mass_nai/dens_na)+(mass_cli/dens_cl) +!jdfcz (mass_nai/dens_na)+(mass_cli/dens_cl) + & +!jdfcz (mass_dusti/dens_dust) + vol_aj = (mass_so4j/dens_so4)+(mass_no3j/dens_no3)+ & + (mass_nh4j/dens_nh4)+(mass_oinj/dens_oin)+ & + (mass_aro1j/dens_oc)+(mass_alk1j/dens_oc)+ & + (mass_ole1j/dens_oc)+(mass_ba1j/dens_oc)+ & + (mass_ba2j/dens_oc)+(mass_ba3j/dens_oc)+ & + (mass_ba4j/dens_oc)+(mass_paj/dens_oc)+ & + (mass_aro2j/dens_oc)+(mass_bcj/dens_bc)+ & + (mass_naj/dens_na)+(mass_clj/dens_cl) +!jdfcz (mass_naj/dens_na)+(mass_clj/dens_cl) + & +!jdfcz (mass_dustj/dens_dust) + vol_ac = (mass_antha/dens_oin)+ & + (mass_seas*(22.9897/58.4428)/dens_na)+ & + (mass_seas*(35.4270/58.4428)/dens_cl)+ & + (mass_soil/dens_dust) + +! +! Now divide mass into sections which is done by sect02: +! * xmas_secti is for aiken mode +! * xmas_sectj is for accumulation mode +! * xmas_sectc is for coarse mode +! * sect02 expects input in um +! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins +! + ss1=alog(sginin) + ss2=exp(ss1*ss1*36.0/8.0) + ss3=(sixpi*vol_ai/(num_ai*ss2))**0.3333333 + dgnum_um=amax1(dgmin,ss3)*1.0e+04 + call sect02(dgnum_um,sginin,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & + xnum_secti,xmas_secti) + ss1=alog(sginia) + ss2=exp(ss1*ss1*36.0/8.0) + ss3=(sixpi*vol_aj/(num_aj*ss2))**0.3333333 + dgnum_um=amax1(dgmin,ss3)*1.0e+04 + call sect02(dgnum_um,sginia,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & + xnum_sectj,xmas_sectj) + ss1=alog(sginic) + ss2=exp(ss1*ss1*36.0/8.0) + ss3=(sixpi*vol_ac/(num_ac*ss2))**0.3333333 + dgnum_um=amax1(dgmin,ss3)*1.0e+04 + call sect02(dgnum_um,sginic,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, & + xnum_sectc,xmas_sectc) + + do isize = 1, nbin_o + xdia_cm(isize)=xdia_um(isize)*1.0e-04 + mass_so4 = mass_so4i*xmas_secti(isize) + mass_so4j*xmas_sectj(isize) + mass_no3 = mass_no3i*xmas_secti(isize) + mass_no3j*xmas_sectj(isize) + mass_nh4 = mass_nh4i*xmas_secti(isize) + mass_nh4j*xmas_sectj(isize) + mass_oin = mass_oini*xmas_secti(isize) + mass_oinj*xmas_sectj(isize) + & + mass_antha*xmas_sectc(isize) +!jdfcz mass_dust= mass_dusti*xmas_secti(isize) + mass_dustj*xmas_sectj(isize) + & +!jdfcz mass_soil*xmas_sectc(isize) + mass_oc = (mass_pai+mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ & + mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i)*xmas_secti(isize) + & + (mass_paj+mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ & + mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j)*xmas_sectj(isize) + mass_bc = mass_bci*xmas_secti(isize) + mass_bcj*xmas_sectj(isize) + mass_na = mass_nai*xmas_secti(isize) + mass_naj*xmas_sectj(isize)+ & + mass_seas*xmas_sectc(isize)*(22.9897/58.4428) + mass_cl = mass_cli*xmas_secti(isize) + mass_clj*xmas_sectj(isize)+ & + mass_seas*xmas_sectc(isize)*(35.4270/58.4428) + mass_h2o = mass_h2oi*xmas_secti(isize) + mass_h2oj*xmas_sectj(isize) +! mass_h2o = 0.0 ! testing purposes only + vol_so4 = mass_so4 / dens_so4 + vol_no3 = mass_no3 / dens_no3 + vol_nh4 = mass_nh4 / dens_nh4 + vol_oin = mass_oin / dens_oin +!jdfcz vol_dust = mass_dust / dens_dust + vol_oc = mass_oc / dens_oc + vol_bc = mass_bc / dens_bc + vol_na = mass_na / dens_na + vol_cl = mass_cl / dens_cl + vol_h2o = mass_h2o / dens_h2o +!!$ if(i.eq.50.and.j.eq.40.and.k.eq.1) then +!!$ print*,'jdf print bin',isize +!!$ print*,'so4',mass_so4,vol_so4 +!!$ print*,'no3',mass_no3,vol_no3 +!!$ print*,'nh4',mass_nh4,vol_nh4 +!!$ print*,'oin',mass_oin,vol_oin +!!$!jdfcz print*,'dust',mass_dust,vol_dust +!!$ print*,'oc ',mass_oc,vol_oc +!!$ print*,'bc ',mass_bc,vol_bc +!!$ print*,'na ',mass_na,vol_na +!!$ print*,'cl ',mass_cl,vol_cl +!!$ print*,'h2o',mass_h2o,vol_h2o +!!$ endif + mass_dry_a = mass_so4 + mass_no3 + mass_nh4 + mass_oin + & +!jdfcz mass_oc + mass_bc + mass_na + mass_cl + mass_dust + mass_oc + mass_bc + mass_na + mass_cl + mass_wet_a = mass_dry_a + mass_h2o + vol_dry_a = vol_so4 + vol_no3 + vol_nh4 + vol_oin + & +!jdfcz vol_oc + vol_bc + vol_na + vol_cl + vol_dust + vol_oc + vol_bc + vol_na + vol_cl + vol_wet_a = vol_dry_a + vol_h2o + vol_shell = vol_wet_a - vol_bc + !num_a = vol_wet_a / (0.52359877*xdia_cm(isize)*xdia_cm(isize)*xdia_cm(isize)) + !czhao + num_a = num_ai*xnum_secti(isize)+num_aj*xnum_sectj(isize)+num_ac*xnum_sectc(isize) + + + !shortwave + do ns=1,nswbands + ri_dum = (0.0,0.0) + ri_dum = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) + & + (ref_index_nh4no3 * mass_no3 / dens_no3) + & + (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & +!jdf (ref_index_oin * mass_oin / dens_oin) + & +!jdfcz (swref_index_dust(ns) * mass_dust / dens_dust) + & + (swref_index_dust(ns) * mass_oin / dens_dust) + & + (swref_index_oc(ns) * mass_oc / dens_oc) + & + (ref_index_bc * mass_bc / dens_bc) + & + (swref_index_nacl(ns) * mass_na / dens_na) + & + (swref_index_nacl(ns) * mass_cl / dens_cl) + & + (swref_index_h2o(ns) * mass_h2o / dens_h2o) +! +! for some reason MADE/SORGAM occasionally produces zero aerosols so +! need to add a check here to avoid divide by zero +! + IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then + dp_dry_a = xdia_cm(isize) + dp_wet_a = xdia_cm(isize) + dp_bc_a = xdia_cm(isize) + ri_ave_a = 0.0 + ri_dum = 0.0 + else + dp_dry_a = (1.90985*vol_dry_a/num_a)**0.3333333 + dp_wet_a = (1.90985*vol_wet_a/num_a)**0.3333333 + dp_bc_a = (1.90985*vol_bc/num_a)**0.3333333 + ri_ave_a = ri_dum/vol_wet_a + ri_dum = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) + & + (ref_index_nh4no3 * mass_no3 / dens_no3) + & + (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & +!jdf (ref_index_oin * mass_oin / dens_oin) + & +!jdfcz (swref_index_dust(ns) * mass_dust / dens_dust) + & + (swref_index_dust(ns) * mass_oin / dens_dust) + & + (swref_index_oc(ns) * mass_oc / dens_oc) + & + (swref_index_nacl(ns) * mass_na / dens_na) + & + (swref_index_nacl(ns) * mass_cl / dens_cl) + & + (swref_index_h2o(ns) * mass_h2o / dens_h2o) + endif + if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then + swrefindx(i,k,j,isize,ns) = (1.5,0.0) + radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =0.0 + swrefindx_core(i,k,j,isize,ns) = ref_index_bc + swrefindx_shell(i,k,j,isize,ns) = ref_index_oin + elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then + swrefindx(i,k,j,isize,ns) = (1.5,0.0) + radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =0.0 + swrefindx_core(i,k,j,isize,ns) = ref_index_bc + swrefindx_shell(i,k,j,isize,ns) = ref_index_oin + else + swrefindx(i,k,j,isize,ns) =ri_ave_a + radius_wet(i,k,j,isize) =dp_wet_a/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =dp_bc_a/2.0 + swrefindx_core(i,k,j,isize,ns) =ref_index_bc + swrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell + endif + enddo ! ns shortwave + + !longwave + do ns=1,nlwbands + ri_dum = (0.0,0.0) + ri_dum = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) + & + (ref_index_nh4no3 * mass_no3 / dens_no3) + & + (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & +!jdf (ref_index_oin * mass_oin / dens_oin) + & +!jdfcz (lwref_index_dust(ns) * mass_dust / dens_dust) + & + (lwref_index_dust(ns) * mass_oin / dens_dust) + & + (lwref_index_oc(ns) * mass_oc / dens_oc) + & + (ref_index_bc * mass_bc / dens_bc) + & + (lwref_index_nacl(ns) * mass_na / dens_na) + & + (lwref_index_nacl(ns) * mass_cl / dens_cl) + & + (lwref_index_h2o(ns) * mass_h2o / dens_h2o) +! +! for some reason MADE/SORGAM occasionally produces zero aerosols so +! need to add a check here to avoid divide by zero +! + IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then + dp_dry_a = xdia_cm(isize) + dp_wet_a = xdia_cm(isize) + dp_bc_a = xdia_cm(isize) + ri_ave_a = 0.0 + ri_dum = 0.0 + else + dp_dry_a = (1.90985*vol_dry_a/num_a)**0.3333333 + dp_wet_a = (1.90985*vol_wet_a/num_a)**0.3333333 + dp_bc_a = (1.90985*vol_bc/num_a)**0.3333333 + ri_ave_a = ri_dum/vol_wet_a + ri_dum = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) + & + (ref_index_nh4no3 * mass_no3 / dens_no3) + & + (ref_index_nh4no3 * mass_nh4 / dens_nh4) + & +!jdf (ref_index_oin * mass_oin / dens_oin) + & +!jdfcz (lwref_index_dust(ns) * mass_dust / dens_dust) + & + (lwref_index_dust(ns) * mass_oin / dens_dust) + & + (lwref_index_oc(ns) * mass_oc / dens_oc) + & + (lwref_index_nacl(ns) * mass_na / dens_na) + & + (lwref_index_nacl(ns) * mass_cl / dens_cl) + & + (lwref_index_h2o(ns) * mass_h2o / dens_h2o) + endif + if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then + lwrefindx(i,k,j,isize,ns) = (1.5,0.0) + radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =0.0 + lwrefindx_core(i,k,j,isize,ns) = ref_index_bc + lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin + elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then + lwrefindx(i,k,j,isize,ns) = (1.5,0.0) + radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =0.0 + lwrefindx_core(i,k,j,isize,ns) = ref_index_bc + lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin + else + lwrefindx(i,k,j,isize,ns) =ri_ave_a + radius_wet(i,k,j,isize) =dp_wet_a/2.0 + number_bin(i,k,j,isize) =num_a + radius_core(i,k,j,isize) =dp_bc_a/2.0 + lwrefindx_core(i,k,j,isize,ns) =ref_index_bc + lwrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell + endif + enddo ! ns longwave + +! refr=real(refindx(i,k,j,isize)) + + enddo !isize + enddo !i + enddo !j + enddo !k + + return + + end subroutine optical_prep_modal_vbs + +!------------------------------------------------------------------ + subroutine optical_prep_mam(nbin_o, chem, alt, & + radius_core,radius_wet, number_bin, & + swrefindx, swrefindx_core, swrefindx_shell, & + lwrefindx, lwrefindx_core, lwrefindx_shell, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! + USE module_configure +! USE module_state_description + USE module_model_constants + USE module_state_description, only: param_first_scalar + USE module_data_cam_mam_asect +! + INTEGER, INTENT(IN ) :: its,ite, jts,jte, kts,kte, nbin_o + INTEGER, INTENT(IN ) :: ims,ime, jms,jme, kms,kme + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: alt + REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & + INTENT(OUT ) :: & + radius_wet, number_bin, radius_core +! COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o), & +! INTENT(OUT ) :: & +! refindx, refindx_core, refindx_shell + COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nswbands), & + INTENT(OUT ) :: swrefindx, swrefindx_core, swrefindx_shell + COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nlwbands), & + INTENT(OUT ) :: lwrefindx, lwrefindx_core, lwrefindx_shell +! +! local variables +! + integer i, j, k, l, isize, itype, iphase + integer p1st + complex ref_index_lvcite , ref_index_nh4hso4, & + ref_index_nh4msa , ref_index_nh4no3 , ref_index_nh4cl , & + ref_index_nano3 , ref_index_na2so4, & + ref_index_na3hso4, ref_index_nahso4 , ref_index_namsa, & + ref_index_caso4 , ref_index_camsa2 , ref_index_cano3, & + ref_index_cacl2 , ref_index_caco3 , ref_index_h2so4, & + ref_index_hhso4 , ref_index_hno3 , ref_index_hcl, & + ref_index_msa , ref_index_bc, & + ref_index_oin , & + ri_dum , ri_ave_a + COMPLEX, DIMENSION(nswbands) :: & ! now only 5 aerosols have wave-dependent refr + swref_index_oc , swref_index_dust , swref_index_nh4so4, swref_index_nacl,swref_index_h2o + COMPLEX, DIMENSION(nlwbands) :: & ! now only 5 aerosols have wave-dependent refr + lwref_index_oc , lwref_index_dust , lwref_index_nh4so4, lwref_index_nacl,lwref_index_h2o + + real dens_so4 , dens_ncl , dens_wtr , dens_pom , dens_soa , & + dens_bc , dens_dst + real mass_so4 , mass_ncl , mass_wtr , mass_pom , mass_soa , & + mass_bc , mass_dst + real vol_so4 , vol_ncl , vol_wtr , vol_pom , vol_soa , & + vol_bc , vol_dst + real mass_so4_a1 , mass_so4_a2 , mass_so4_a3, & + mass_ncl_a1 , mass_ncl_a2 , mass_ncl_a3, & + mass_wtr_a1 , mass_wtr_a2 , mass_wtr_a3, & + mass_soa_a1 , mass_soa_a2 , mass_pom_a1, & + mass_bc_a1 , mass_dst_a1 , mass_dst_a3, & + num_a1 , num_a2 , num_a3, & + vol_a1 , vol_a2 , vol_a3 + real conv1a, conv1b + real mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell, & + dp_dry_a , dp_wet_a , num_a , dp_bc_a + real ifac, jfac, cfac + real refr + integer ns + real dgnum_um,drydens,duma,dlo_um,dhi_um,dgmin,sixpi,ss1,ss2,ss3,dtemp + integer iflag + real, dimension(1:nbin_o) :: xnum_secti,xnum_sectj,xnum_sectc + real, dimension(1:nbin_o) :: xmas_secti,xmas_sectj,xmas_sectc + real, dimension(1:nbin_o) :: xdia_um, xdia_cm +! +! real sginin,sginia,sginic from module_data_sorgam.F +! +! Mass from modal distribution is divided into individual sections before +! being passed back into the Mie routine. +! * currently use the same size bins as 8 default MOSAIC size bins +! * dlo_um and dhi_um define the lower and upper bounds of individual sections +! used to compute optical properties +! * sigmas for 3 modes taken from module_sorgan_data.F +! * these parameters are needed by sect02 that is called later +! * sginin=1.7, sginia=2.0, sginic=2.5 +! + sixpi=6.0/3.14159265359 + dlo_um=0.0390625 + dhi_um=10.0 + drydens=1.8 + iflag=2 + duma=1.0 + dgmin=1.0e-07 ! in (cm) + dtemp=dlo_um + do isize=1,nbin_o + xdia_um(isize)=(dtemp+dtemp*2.0)/2.0 + dtemp=dtemp*2.0 + enddo +! +! Define refractive indicies +! * assume na and cl are the same as nacl +! * assume so4, no3, and nh4 are the same as nh4no3 +! * assume ca and co3 are the same as caco3 +! * assume msa is just msa +! Further work: +! * to be more precise, need to compute electrolytes to apportion +! so4, no3, nh4, na, cl, msa, ca, co3 among various componds +! as was done previously in module_mosaic_therm.F +! + do ns = 1, nswbands + swref_index_nh4so4(ns) = cmplx(refrsw_sulf(ns),refisw_sulf(ns)) + swref_index_oc(ns) = cmplx(refrsw_oc(ns),refisw_oc(ns)) + swref_index_dust(ns) = cmplx(refrsw_dust(ns),refisw_dust(ns)) + swref_index_nacl(ns) = cmplx(refrsw_seas(ns),refisw_seas(ns)) + swref_index_h2o(ns) = cmplx(refrwsw(ns),refiwsw(ns)) + enddo + do ns = 1, nlwbands + lwref_index_nh4so4(ns) = cmplx(refrlw_sulf(ns),refilw_sulf(ns)) + lwref_index_oc(ns) = cmplx(refrlw_oc(ns),refilw_oc(ns)) + lwref_index_dust(ns) = cmplx(refrlw_dust(ns),refilw_dust(ns)) + lwref_index_nacl(ns) = cmplx(refrlw_seas(ns),refilw_seas(ns)) + lwref_index_h2o(ns) = cmplx(refrwlw(ns),refiwlw(ns)) + enddo + +! ref_index_nh4so4 = cmplx(1.52,0.) + ref_index_lvcite = cmplx(1.50,0.) + ref_index_nh4hso4= cmplx(1.47,0.) + ref_index_nh4msa = cmplx(1.50,0.) ! assumed + ref_index_nh4no3 = cmplx(1.50,0.) + ref_index_nh4cl = cmplx(1.50,0.) +! ref_index_nacl = cmplx(1.45,0.) + ref_index_nano3 = cmplx(1.50,0.) + ref_index_na2so4 = cmplx(1.50,0.) + ref_index_na3hso4= cmplx(1.50,0.) + ref_index_nahso4 = cmplx(1.50,0.) + ref_index_namsa = cmplx(1.50,0.) ! assumed + ref_index_caso4 = cmplx(1.56,0.006) + ref_index_camsa2 = cmplx(1.56,0.006) ! assumed + ref_index_cano3 = cmplx(1.56,0.006) + ref_index_cacl2 = cmplx(1.52,0.006) + ref_index_caco3 = cmplx(1.68,0.006) + ref_index_h2so4 = cmplx(1.43,0.) + ref_index_hhso4 = cmplx(1.43,0.) + ref_index_hno3 = cmplx(1.50,0.) + ref_index_hcl = cmplx(1.50,0.) + ref_index_msa = cmplx(1.43,0.) ! assumed +! ref_index_oc = cmplx(1.45,0.) ! JCB, Feb. 20, 2008: no complex part? +! JCB, Feb. 20, 2008: set the refractive index of BC equal to the +! midpoint of ranges given in Bond and Bergstrom, Light absorption by +! carboneceous particles: an investigative review 2006, Aerosol Sci. +! and Tech., 40:27-67. +! ref_index_bc = cmplx(1.82,0.74) old value + ref_index_bc = cmplx(1.85,0.71) + ref_index_oin = cmplx(1.55,0.006) ! JCB, Feb. 20, 2008: "other inorganics" +! ref_index_dust = cmplx(1.55,0.003) ! czhao, this refractive index should be wavelength depedent +! ref_index_h2o = cmplx(1.33,0.) +! +! densities in g/cc +! + dens_so4 = 1.8 ! used + dens_ncl = 2.2 ! used + dens_dst = 2.6 ! used + dens_pom = 1.0 ! used + dens_soa = 1.0 ! used + dens_wtr = 1.0 +! JCB, Feb. 20, 2008: the density of BC is updated to reflect values +! published by Bond and Bergstrom, Light absorption by carboneceous +! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67. +! dens_bc = 1.7 ! used, old value + dens_bc = 1.8 ! midpoint of Bond and Bergstrom value +! + p1st = param_first_scalar +! swrefindx=0.0 lwrefindx=0.0 radius_wet=0.0 @@ -2799,6 +3538,7 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & radius_core,radius_wet, number_bin, & swrefindx,swrefindx_core, swrefindx_shell, & lwrefindx,lwrefindx_core, lwrefindx_shell, & + uoc, & ! mklose ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -2906,6 +3646,11 @@ subroutine optical_prep_gocart(nbin_o, chem, alt,relhum, & integer istop integer, save :: kcall data kcall / 0 / + integer :: uoc + + if (uoc == 1) then ! mklose + den_dust(1) = 2650. ! change dust density in first bin for UoC dust emission schemes + endif ! ! real sginin,sginia,sginic from module_data_sorgam.F diff --git a/wrfv2_fire/chem/module_prep_wetscav_sorgam.F b/wrfv2_fire/chem/module_prep_wetscav_sorgam.F new file mode 100644 index 00000000..ea070396 --- /dev/null +++ b/wrfv2_fire/chem/module_prep_wetscav_sorgam.F @@ -0,0 +1,1100 @@ +MODULE module_prep_wetscav_sorgam + +USE module_state_description +USE module_configure +USE module_mosaic_wetscav,only: initwet,wetscav + +IMPLICIT NONE + +#define cw_species_are_in_registry + +CONTAINS + +SUBROUTINE aerosols_sorgam_init_aercld_ptrs( & + num_chem, is_aerosol, config_flags ) +! +! initialize pointers used by aerosol-cloud-interaction routines +! + USE module_data_sorgam +! USE module_configure,only: grid_config_rec_type +! USE module_mosaic_wetscav,only: initwet + + implicit none + INTEGER, INTENT(IN) :: num_chem + LOGICAL, INTENT(OUT) :: is_aerosol(num_chem) + TYPE (grid_config_rec_type) , INTENT (in) :: config_flags + + + integer iphase, isize, itype, l, ll, n, p1st + REAL dp_meanvol_tmp + + + nphase_aer = 1 + if(p_so4cwj.ge. param_first_scalar) then + nphase_aer = 2 + endif + ai_phase=-999888777 + cw_phase=-999888777 + ci_phase=-999888777 + cr_phase=-999888777 + cs_phase=-999888777 + cg_phase=-999888777 + if(nphase_aer>=1)ai_phase=1 + if(nphase_aer>=2)cw_phase=2 + if(nphase_aer>=3)cr_phase=3 + if(nphase_aer>=4)ci_phase=4 + if(nphase_aer>=5)cw_phase=5 + if(nphase_aer>=6)cg_phase=6 + +! aitken and accum mode have same set of species +! so are treated as isize=1,2 of itype=1 +! coarse mode has different set of species +! so is treated as isize=1 of itype=2 + ntype_aer = 2 + nsize_aer(1)=2 + nsize_aer(2)=1 + + msectional = 0 + maerosolincw = 0 +#if defined ( cw_species_are_in_registry ) + maerosolincw = 1 +#endif + name_mastercomp_aer( 1) = 'sulfate' + dens_mastercomp_aer( 1) = dens_so4_aer + mw_mastercomp_aer( 1) = mw_so4_aer + hygro_mastercomp_aer(1) = hygro_so4_aer + + name_mastercomp_aer( 2) = 'nitrate' + dens_mastercomp_aer( 2) = dens_no3_aer + mw_mastercomp_aer( 2) = mw_no3_aer + hygro_mastercomp_aer(2) = hygro_no3_aer + + name_mastercomp_aer( 3) = 'ammonium' + dens_mastercomp_aer( 3) = dens_nh4_aer + mw_mastercomp_aer( 3) = mw_nh4_aer + hygro_mastercomp_aer(3) = hygro_nh4_aer + + name_mastercomp_aer( 4) = 'orgaro1' + dens_mastercomp_aer( 4) = dens_oc_aer + mw_mastercomp_aer( 4) = mw_oc_aer + hygro_mastercomp_aer(4) = hygro_oc_aer + + name_mastercomp_aer( 5) = 'orgaro2' + dens_mastercomp_aer( 5) = dens_oc_aer + mw_mastercomp_aer( 5) = mw_oc_aer + hygro_mastercomp_aer(5) = hygro_oc_aer + + name_mastercomp_aer( 6) = 'orgalk' + dens_mastercomp_aer( 6) = dens_oc_aer + mw_mastercomp_aer( 6) = mw_oc_aer + hygro_mastercomp_aer(6) = hygro_oc_aer + + name_mastercomp_aer( 7) = 'orgole' + dens_mastercomp_aer( 7) = dens_oc_aer + mw_mastercomp_aer( 7) = mw_oc_aer + hygro_mastercomp_aer(7) = hygro_oc_aer + + name_mastercomp_aer( 8) = 'orgba1' + dens_mastercomp_aer( 8) = dens_oc_aer + mw_mastercomp_aer( 8) = mw_oc_aer + hygro_mastercomp_aer(8) = hygro_oc_aer + + name_mastercomp_aer( 9) = 'orgba2' + dens_mastercomp_aer( 9) = dens_oc_aer + mw_mastercomp_aer( 9) = mw_oc_aer + hygro_mastercomp_aer(9) = hygro_oc_aer + + name_mastercomp_aer( 10) = 'orgba3' + dens_mastercomp_aer( 10) = dens_oc_aer + mw_mastercomp_aer( 10) = mw_oc_aer + hygro_mastercomp_aer(10) = hygro_oc_aer + + name_mastercomp_aer( 11) = 'orgba4' + dens_mastercomp_aer( 11) = dens_oc_aer + mw_mastercomp_aer( 11) = mw_oc_aer + hygro_mastercomp_aer(11) = hygro_oc_aer + + name_mastercomp_aer( 12) = 'orgpa' + dens_mastercomp_aer( 12) = dens_oc_aer + mw_mastercomp_aer( 12) = mw_oc_aer + hygro_mastercomp_aer(12) = hygro_oc_aer + + name_mastercomp_aer( 13) = 'ec' + dens_mastercomp_aer( 13) = dens_ec_aer + mw_mastercomp_aer( 13) = mw_ec_aer + hygro_mastercomp_aer(13) = hygro_ec_aer + name_mastercomp_aer( 14) = 'p25' + dens_mastercomp_aer( 14) = dens_oin_aer + mw_mastercomp_aer( 14) = mw_oin_aer + hygro_mastercomp_aer(14) = hygro_oin_aer + + name_mastercomp_aer( 15) = 'anth' + dens_mastercomp_aer( 15) = dens_oin_aer + mw_mastercomp_aer( 15) = mw_oin_aer + hygro_mastercomp_aer(15) = hygro_oin_aer + + name_mastercomp_aer( 16) = 'seas' + dens_mastercomp_aer( 16) = dens_seas_aer + mw_mastercomp_aer( 16) = mw_seas_aer + hygro_mastercomp_aer(16) = hygro_seas_aer + + name_mastercomp_aer( 17) = 'soil' + dens_mastercomp_aer( 17) = dens_dust_aer + mw_mastercomp_aer( 17) = mw_dust_aer + hygro_mastercomp_aer(17) = hygro_dust_aer + + name_mastercomp_aer(18) = 'sodium' + dens_mastercomp_aer(18) = dens_na_aer + mw_mastercomp_aer( 18) = mw_na_aer + hygro_mastercomp_aer(18) = hygro_na_aer + + name_mastercomp_aer(19) = 'chloride' + dens_mastercomp_aer(19) = dens_cl_aer + mw_mastercomp_aer( 19) = mw_cl_aer + hygro_mastercomp_aer(19) = hygro_cl_aer + + lptr_so4_aer( :,:,:) = 1 + lptr_nh4_aer( :,:,:) = 1 + lptr_no3_aer( :,:,:) = 1 + lptr_na_aer( :,:,:) = 1 + lptr_cl_aer( :,:,:) = 1 + lptr_orgaro1_aer(:,:,:) = 1 + lptr_orgaro2_aer(:,:,:) = 1 + lptr_orgalk_aer( :,:,:) = 1 + lptr_orgole_aer( :,:,:) = 1 + lptr_orgba1_aer( :,:,:) = 1 + lptr_orgba2_aer( :,:,:) = 1 + lptr_orgba3_aer( :,:,:) = 1 + lptr_orgba4_aer( :,:,:) = 1 + lptr_orgpa_aer( :,:,:) = 1 + lptr_ec_aer( :,:,:) = 1 + lptr_p25_aer( :,:,:) = 1 + lptr_anth_aer( :,:,:) = 1 + lptr_seas_aer( :,:,:) = 1 + lptr_soil_aer( :,:,:) = 1 + numptr_aer( :,:,:) = 1 + + do_cloudchem_aer(:,:) = .false. + +! Aitken mode + itype = 1 + isize = 1 + ncomp_aer(itype) = 16 + numptr_aer( isize,itype,ai_phase) = p_nu0 + lptr_so4_aer( isize,itype,ai_phase) = p_so4ai + lptr_nh4_aer( isize,itype,ai_phase) = p_nh4ai + lptr_no3_aer( isize,itype,ai_phase) = p_no3ai + lptr_na_aer( isize,itype,ai_phase) = p_naai + lptr_cl_aer( isize,itype,ai_phase) = p_clai + lptr_orgaro1_aer(isize,itype,ai_phase) = p_orgaro1i + lptr_orgaro2_aer(isize,itype,ai_phase) = p_orgaro2i + lptr_orgalk_aer( isize,itype,ai_phase) = p_orgalk1i + lptr_orgole_aer( isize,itype,ai_phase) = p_orgole1i + lptr_orgba1_aer( isize,itype,ai_phase) = p_orgba1i + lptr_orgba2_aer( isize,itype,ai_phase) = p_orgba2i + lptr_orgba3_aer( isize,itype,ai_phase) = p_orgba3i + lptr_orgba4_aer( isize,itype,ai_phase) = p_orgba4i + lptr_orgpa_aer( isize,itype,ai_phase) = p_orgpai + lptr_ec_aer( isize,itype,ai_phase) = p_eci + lptr_p25_aer( isize,itype,ai_phase) = p_p25i +! aerosol in cloud water + if(cw_phase.gt.0)then + numptr_aer( isize,itype,cw_phase) = p_nu0cw + lptr_so4_aer( isize,itype,cw_phase) = p_so4cwi + lptr_nh4_aer( isize,itype,cw_phase) = p_nh4cwi + lptr_no3_aer( isize,itype,cw_phase) = p_no3cwi + lptr_na_aer( isize,itype,ai_phase) = p_nacwi + lptr_cl_aer( isize,itype,ai_phase) = p_clcwi + lptr_orgaro1_aer(isize,itype,cw_phase) = p_orgaro1cwi + lptr_orgaro2_aer(isize,itype,cw_phase) = p_orgaro2cwi + lptr_orgalk_aer( isize,itype,cw_phase) = p_orgalk1cwi + lptr_orgole_aer( isize,itype,cw_phase) = p_orgole1cwi + lptr_orgba1_aer( isize,itype,cw_phase) = p_orgba1cwi + lptr_orgba2_aer( isize,itype,cw_phase) = p_orgba2cwi + lptr_orgba3_aer( isize,itype,cw_phase) = p_orgba3cwi + lptr_orgba4_aer( isize,itype,cw_phase) = p_orgba4cwi + lptr_orgpa_aer( isize,itype,cw_phase) = p_orgpacwi + lptr_ec_aer( isize,itype,cw_phase) = p_eccwi + lptr_p25_aer( isize,itype,cw_phase) = p_p25cwi + do_cloudchem_aer(isize,itype) = .true. + endif + +! Accumulation mode + itype = 1 + isize = 2 + ncomp_aer(itype) = 16 + numptr_aer( isize,itype,ai_phase) = p_ac0 + lptr_so4_aer( isize,itype,ai_phase) = p_so4aj + lptr_nh4_aer( isize,itype,ai_phase) = p_nh4aj + lptr_no3_aer( isize,itype,ai_phase) = p_no3aj + lptr_na_aer( isize,itype,ai_phase) = p_naaj + lptr_cl_aer( isize,itype,ai_phase) = p_claj + lptr_orgaro1_aer(isize,itype,ai_phase) = p_orgaro1j + lptr_orgaro2_aer(isize,itype,ai_phase) = p_orgaro2j + lptr_orgalk_aer( isize,itype,ai_phase) = p_orgalk1j + lptr_orgole_aer( isize,itype,ai_phase) = p_orgole1j + lptr_orgba1_aer( isize,itype,ai_phase) = p_orgba1j + lptr_orgba2_aer( isize,itype,ai_phase) = p_orgba2j + lptr_orgba3_aer( isize,itype,ai_phase) = p_orgba3j + lptr_orgba4_aer( isize,itype,ai_phase) = p_orgba4j + lptr_orgpa_aer( isize,itype,ai_phase) = p_orgpaj + lptr_ec_aer( isize,itype,ai_phase) = p_ecj + lptr_p25_aer( isize,itype,ai_phase) = p_p25j +! aerosol in cloud water + if(cw_phase.gt.0)then + numptr_aer( isize,itype,cw_phase) = p_ac0cw + lptr_so4_aer( isize,itype,cw_phase) = p_so4cwj + lptr_nh4_aer( isize,itype,cw_phase) = p_nh4cwj + lptr_no3_aer( isize,itype,cw_phase) = p_no3cwj + lptr_na_aer( isize,itype,ai_phase) = p_nacwj + lptr_cl_aer( isize,itype,ai_phase) = p_clcwj + lptr_orgaro1_aer(isize,itype,cw_phase) = p_orgaro1cwj + lptr_orgaro2_aer(isize,itype,cw_phase) = p_orgaro2cwj + lptr_orgalk_aer( isize,itype,cw_phase) = p_orgalk1cwj + lptr_orgole_aer( isize,itype,cw_phase) = p_orgole1cwj + lptr_orgba1_aer( isize,itype,cw_phase) = p_orgba1cwj + lptr_orgba2_aer( isize,itype,cw_phase) = p_orgba2cwj + lptr_orgba3_aer( isize,itype,cw_phase) = p_orgba3cwj + lptr_orgba4_aer( isize,itype,cw_phase) = p_orgba4cwj + lptr_orgpa_aer( isize,itype,cw_phase) = p_orgpacwj + lptr_ec_aer( isize,itype,cw_phase) = p_eccwj + lptr_p25_aer( isize,itype,cw_phase) = p_p25cwj + do_cloudchem_aer(isize,itype) = .true. + endif + +! coarse mode + itype = 2 + isize = 1 + ncomp_aer(itype) = 3 + numptr_aer( isize,itype,ai_phase) = p_corn + lptr_anth_aer( isize,itype,ai_phase) = p_antha + lptr_seas_aer( isize,itype,ai_phase) = p_seas + lptr_soil_aer( isize,itype,ai_phase) = p_soila +! aerosol in cloud water + if(cw_phase.gt.0)then + numptr_aer( isize,itype,cw_phase) = p_corncw + lptr_anth_aer( isize,itype,cw_phase) = p_anthcw + lptr_seas_aer( isize,itype,cw_phase) = p_seascw + lptr_soil_aer( isize,itype,cw_phase) = p_soilcw + +! no cloudchem for coarse mode because it has no so4/nh4/no3 species + do_cloudchem_aer(isize,itype) = .false. + endif + + massptr_aer(:,:,:,:) = -999888777 + mastercompptr_aer(:,:) = -999888777 + + p1st = param_first_scalar + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + ll = 0 + if (lptr_so4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_so4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 1 + end if + if (lptr_no3_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_no3_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 2 + end if + if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_nh4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 3 + end if + if (lptr_orgaro1_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgaro1_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 4 + end if + if (lptr_orgaro2_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgaro2_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 5 + end if + if (lptr_orgalk_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgalk_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 6 + end if + if (lptr_orgole_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgole_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 7 + end if + if (lptr_orgba1_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgba1_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 8 + end if + if (lptr_orgba2_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgba2_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 9 + end if + if (lptr_orgba3_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgba3_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 10 + end if + if (lptr_orgba4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgba4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 11 + end if + if (lptr_orgpa_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgpa_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 12 + end if + if (lptr_ec_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_ec_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 13 + end if + if (lptr_p25_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_p25_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 14 + end if + if (lptr_anth_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_anth_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 15 + end if + if (lptr_seas_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_seas_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 16 + end if + if (lptr_soil_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_soil_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 17 + end if + if (lptr_na_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_na_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 18 + end if + if (lptr_cl_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_cl_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 19 + endif + ncomp_aer_nontracer(itype) = ll + + ncomp_aer(itype) = ll + + mprognum_aer(n,itype,iphase) = 0 + if (numptr_aer(n,itype,iphase) .ge. p1st) then + mprognum_aer(n,itype,iphase) = 1 + end if + + end do ! size + end do ! type + end do ! phase + + waterptr_aer(:,:) = 0 + + do itype=1,ntype_aer + do ll=1,ncomp_aer(itype) + dens_aer(ll,itype) = dens_mastercomp_aer(mastercompptr_aer(ll,itype)) + mw_aer(ll,itype) = mw_mastercomp_aer(mastercompptr_aer(ll,itype)) + hygro_aer(ll,itype) = hygro_mastercomp_aer(mastercompptr_aer(ll,itype)) + name_aer(ll,itype) = name_mastercomp_aer(mastercompptr_aer(ll,itype)) + end do + end do + + is_aerosol(:) = .false. + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + do ll = 1, ncomp_aer(itype) + is_aerosol(massptr_aer(ll,n,itype,iphase))=.true. + end do + is_aerosol(numptr_aer(n,itype,iphase))=.true. + end do ! size + end do ! type + end do ! phase + +! for sectional +! the dhi/dlo_sect are the upper/lower bounds for +! mean-volume diameter for a section/bin +! for modal +! they should be set to reasonable upper/lower +! bounds for mean-volume diameters of each modes +! they are primarily used to put reasonable bounds +! on number (in relation to mass/volume) +! the dcen_sect are used by initwet for the impaction scavenging +! lookup tables, and should represent a "base" mean-volume diameter +! dp_meanvol_tmp (below) is the made-sorgam default initial value +! for mean-volume diameter (in cm) +! terminology: (pi/6) * (mean-volume diameter)**3 == +! (volume mixing ratio of section/mode)/(number mixing ratio) +! + dhi_sect(:,:) = 0.0 + dlo_sect(:,:) = 0.0 + + itype = 1 + isize = 1 + sigmag_aer(isize,itype) = sginin ! aitken + dp_meanvol_tmp = 1.0e2*dginin*exp(1.5*l2sginin) ! aitken + dcen_sect(isize,itype) = dp_meanvol_tmp + dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 + dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 + + itype = 1 + isize = 2 + sigmag_aer(isize,itype) = sginia ! accum + dp_meanvol_tmp = 1.0e2*dginia*exp(1.5*l2sginia) ! accum + dcen_sect(isize,itype) = dp_meanvol_tmp + dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 + dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 + + itype = 2 + isize = 1 + sigmag_aer(isize,itype) = sginic ! coarse + dp_meanvol_tmp = 1.0e2*dginic*exp(1.5*l2sginic) ! coarse + dcen_sect(isize,itype) = dp_meanvol_tmp + dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 + dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + volumcen_sect(isize,itype) = (pirs/6.0)*(dcen_sect(isize,itype)**3) + volumlo_sect(isize,itype) = (pirs/6.0)*(dlo_sect(isize,itype)**3) + volumhi_sect(isize,itype) = (pirs/6.0)*(dhi_sect(isize,itype)**3) + end do + end do + + +! do initialization of the impaction/interception scavenging +! lookup tables + call initwet( & + ntype_aer, nsize_aer, ncomp_aer, & + massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, & + dcen_sect, sigmag_aer, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, & + nimptblgrow_maxd, dlndg_nimptblgrow ) + +END SUBROUTINE aerosols_sorgam_init_aercld_ptrs + +SUBROUTINE aerosols_soa_vbs_init_aercld_ptrs( & + num_chem, is_aerosol, config_flags ) +! +! initialize pointers used by aerosol-cloud-interaction routines +! + USE module_data_soa_vbs +! USE module_configure,only: grid_config_rec_type +! USE module_mosaic_wetscav,only: initwet + + implicit none + INTEGER, INTENT(IN) :: num_chem + LOGICAL, INTENT(OUT) :: is_aerosol(num_chem) + TYPE (grid_config_rec_type) , INTENT (in) :: config_flags + + + integer iphase, isize, itype, l, ll, n, p1st + REAL dp_meanvol_tmp + + nphase_aer = 1 + if(p_so4cwj.ge. param_first_scalar) then + nphase_aer = 2 + endif + ai_phase=-999888777 + cw_phase=-999888777 + ci_phase=-999888777 + cr_phase=-999888777 + cs_phase=-999888777 + cg_phase=-999888777 + if(nphase_aer>=1)ai_phase=1 + if(nphase_aer>=2)cw_phase=2 + if(nphase_aer>=3)cr_phase=3 + if(nphase_aer>=4)ci_phase=4 + if(nphase_aer>=5)cw_phase=5 + if(nphase_aer>=6)cg_phase=6 + +! aitken and accum mode have same set of species +! so are treated as isize=1,2 of itype=1 +! coarse mode has different set of species +! so is treated as isize=1 of itype=2 + ntype_aer = 2 + nsize_aer(1)=2 + nsize_aer(2)=1 + + msectional = 0 + maerosolincw = 0 +#if defined ( cw_species_are_in_registry ) + maerosolincw = 1 +#endif + name_mastercomp_aer( 1) = 'sulfate' + dens_mastercomp_aer( 1) = dens_so4_aer + mw_mastercomp_aer( 1) = mw_so4_aer + hygro_mastercomp_aer(1) = hygro_so4_aer + + name_mastercomp_aer( 2) = 'nitrate' + dens_mastercomp_aer( 2) = dens_no3_aer + mw_mastercomp_aer( 2) = mw_no3_aer + hygro_mastercomp_aer(2) = hygro_no3_aer + + name_mastercomp_aer( 3) = 'ammonium' + dens_mastercomp_aer( 3) = dens_nh4_aer + mw_mastercomp_aer( 3) = mw_nh4_aer + hygro_mastercomp_aer(3) = hygro_nh4_aer + + name_mastercomp_aer( 4) = 'asoa1' + dens_mastercomp_aer( 4) = dens_oc_aer + mw_mastercomp_aer( 4) = mw_oc_aer + hygro_mastercomp_aer(4) = hygro_oc_aer + + name_mastercomp_aer( 5) = 'asoa2' + dens_mastercomp_aer( 5) = dens_oc_aer + mw_mastercomp_aer( 5) = mw_oc_aer + hygro_mastercomp_aer(5) = hygro_oc_aer + + name_mastercomp_aer( 6) = 'asoa3' + dens_mastercomp_aer( 6) = dens_oc_aer + mw_mastercomp_aer( 6) = mw_oc_aer + hygro_mastercomp_aer(6) = hygro_oc_aer + + name_mastercomp_aer( 7) = 'asoa4' + dens_mastercomp_aer( 7) = dens_oc_aer + mw_mastercomp_aer( 7) = mw_oc_aer + hygro_mastercomp_aer(7) = hygro_oc_aer + + name_mastercomp_aer( 8) = 'bsoa1' + dens_mastercomp_aer( 8) = dens_oc_aer + mw_mastercomp_aer( 8) = mw_oc_aer + hygro_mastercomp_aer(8) = hygro_oc_aer + + name_mastercomp_aer( 9) = 'bsoa2' + dens_mastercomp_aer( 9) = dens_oc_aer + mw_mastercomp_aer( 9) = mw_oc_aer + hygro_mastercomp_aer(9) = hygro_oc_aer + + name_mastercomp_aer( 10) = 'bsoa3' + dens_mastercomp_aer( 10) = dens_oc_aer + mw_mastercomp_aer( 10) = mw_oc_aer + hygro_mastercomp_aer(10) = hygro_oc_aer + + name_mastercomp_aer( 11) = 'bsoa4' + dens_mastercomp_aer( 11) = dens_oc_aer + mw_mastercomp_aer( 11) = mw_oc_aer + hygro_mastercomp_aer(11) = hygro_oc_aer + + name_mastercomp_aer( 12) = 'orgpa' + dens_mastercomp_aer( 12) = dens_oc_aer + mw_mastercomp_aer( 12) = mw_oc_aer + hygro_mastercomp_aer(12) = hygro_oc_aer + + name_mastercomp_aer( 13) = 'ec' + dens_mastercomp_aer( 13) = dens_ec_aer + mw_mastercomp_aer( 13) = mw_ec_aer + hygro_mastercomp_aer(13) = hygro_ec_aer + + name_mastercomp_aer( 14) = 'p25' + dens_mastercomp_aer( 14) = dens_oin_aer + mw_mastercomp_aer( 14) = mw_oin_aer + hygro_mastercomp_aer(14) = hygro_oin_aer + + name_mastercomp_aer( 15) = 'anth' + dens_mastercomp_aer( 15) = dens_oin_aer + mw_mastercomp_aer( 15) = mw_oin_aer + hygro_mastercomp_aer(15) = hygro_oin_aer + + name_mastercomp_aer( 16) = 'seas' + dens_mastercomp_aer( 16) = dens_seas_aer + mw_mastercomp_aer( 16) = mw_seas_aer + hygro_mastercomp_aer(16) = hygro_seas_aer + + name_mastercomp_aer( 17) = 'soil' + dens_mastercomp_aer( 17) = dens_dust_aer + mw_mastercomp_aer( 17) = mw_dust_aer + hygro_mastercomp_aer(17) = hygro_dust_aer + + name_mastercomp_aer(18) = 'sodium' + dens_mastercomp_aer(18) = dens_na_aer + mw_mastercomp_aer( 18) = mw_na_aer + hygro_mastercomp_aer(18) = hygro_na_aer + + name_mastercomp_aer(19) = 'chloride' + dens_mastercomp_aer(19) = dens_cl_aer + mw_mastercomp_aer( 19) = mw_cl_aer + hygro_mastercomp_aer(19) = hygro_cl_aer + + lptr_so4_aer( :,:,:) = 1 + lptr_nh4_aer( :,:,:) = 1 + lptr_no3_aer( :,:,:) = 1 + lptr_na_aer( :,:,:) = 1 + lptr_cl_aer( :,:,:) = 1 + lptr_asoa1_aer(:,:,:) = 1 + lptr_asoa2_aer(:,:,:) = 1 + lptr_asoa3_aer( :,:,:) = 1 + lptr_asoa4_aer( :,:,:) = 1 + lptr_bsoa1_aer( :,:,:) = 1 + lptr_bsoa2_aer( :,:,:) = 1 + lptr_bsoa3_aer( :,:,:) = 1 + lptr_bsoa4_aer( :,:,:) = 1 + lptr_orgpa_aer( :,:,:) = 1 + lptr_ec_aer( :,:,:) = 1 + lptr_p25_aer( :,:,:) = 1 + lptr_anth_aer( :,:,:) = 1 + lptr_seas_aer( :,:,:) = 1 + lptr_soil_aer( :,:,:) = 1 + numptr_aer( :,:,:) = 1 + + do_cloudchem_aer(:,:) = .false. + +! Aitken mode + itype = 1 + isize = 1 + ncomp_aer(itype) = 16 + numptr_aer( isize,itype,ai_phase) = p_nu0 + lptr_so4_aer( isize,itype,ai_phase) = p_so4ai + lptr_nh4_aer( isize,itype,ai_phase) = p_nh4ai + lptr_no3_aer( isize,itype,ai_phase) = p_no3ai + lptr_na_aer( isize,itype,ai_phase) = p_naai + lptr_cl_aer( isize,itype,ai_phase) = p_clai + lptr_asoa1_aer( isize,itype,ai_phase) = p_asoa1i + lptr_asoa2_aer( isize,itype,ai_phase) = p_asoa2i + lptr_asoa3_aer( isize,itype,ai_phase) = p_asoa3i + lptr_asoa4_aer( isize,itype,ai_phase) = p_asoa4i + lptr_bsoa1_aer( isize,itype,ai_phase) = p_bsoa1i + lptr_bsoa2_aer( isize,itype,ai_phase) = p_bsoa2i + lptr_bsoa3_aer( isize,itype,ai_phase) = p_bsoa3i + lptr_bsoa4_aer( isize,itype,ai_phase) = p_bsoa4i + lptr_orgpa_aer( isize,itype,ai_phase) = p_orgpai + lptr_ec_aer( isize,itype,ai_phase) = p_eci + lptr_p25_aer( isize,itype,ai_phase) = p_p25i +! aerosol in cloud water + if(cw_phase.gt.0)then + numptr_aer( isize,itype,cw_phase) = p_nu0cw + lptr_so4_aer( isize,itype,cw_phase) = p_so4cwi + lptr_nh4_aer( isize,itype,cw_phase) = p_nh4cwi + lptr_no3_aer( isize,itype,cw_phase) = p_no3cwi + lptr_na_aer( isize,itype,ai_phase) = p_nacwi + lptr_cl_aer( isize,itype,ai_phase) = p_clcwi + lptr_asoa1_aer( isize,itype,cw_phase) = p_asoa1cwi + lptr_asoa2_aer( isize,itype,cw_phase) = p_asoa2cwi + lptr_asoa3_aer( isize,itype,cw_phase) = p_asoa3cwi + lptr_asoa4_aer( isize,itype,cw_phase) = p_asoa4cwi + lptr_bsoa1_aer( isize,itype,cw_phase) = p_bsoa1cwi + lptr_bsoa2_aer( isize,itype,cw_phase) = p_bsoa2cwi + lptr_bsoa3_aer( isize,itype,cw_phase) = p_bsoa3cwi + lptr_bsoa4_aer( isize,itype,cw_phase) = p_bsoa4cwi + lptr_orgpa_aer( isize,itype,cw_phase) = p_orgpacwi + lptr_ec_aer( isize,itype,cw_phase) = p_eccwi + lptr_p25_aer( isize,itype,cw_phase) = p_p25cwi + do_cloudchem_aer(isize,itype) = .true. + endif + +! Accumulation mode + itype = 1 + isize = 2 + ncomp_aer(itype) = 16 + numptr_aer( isize,itype,ai_phase) = p_ac0 + lptr_so4_aer( isize,itype,ai_phase) = p_so4aj + lptr_nh4_aer( isize,itype,ai_phase) = p_nh4aj + lptr_no3_aer( isize,itype,ai_phase) = p_no3aj + lptr_na_aer( isize,itype,ai_phase) = p_naaj + lptr_cl_aer( isize,itype,ai_phase) = p_claj + lptr_asoa1_aer( isize,itype,ai_phase) = p_asoa1j + lptr_asoa2_aer( isize,itype,ai_phase) = p_asoa2j + lptr_asoa3_aer( isize,itype,ai_phase) = p_asoa3j + lptr_asoa4_aer( isize,itype,ai_phase) = p_asoa4j + lptr_bsoa1_aer( isize,itype,ai_phase) = p_bsoa1j + lptr_bsoa2_aer( isize,itype,ai_phase) = p_bsoa2j + lptr_bsoa3_aer( isize,itype,ai_phase) = p_bsoa3j + lptr_bsoa4_aer( isize,itype,ai_phase) = p_bsoa4j + lptr_orgpa_aer( isize,itype,ai_phase) = p_orgpaj + lptr_ec_aer( isize,itype,ai_phase) = p_ecj + lptr_p25_aer( isize,itype,ai_phase) = p_p25j +! aerosol in cloud water + if(cw_phase.gt.0)then + numptr_aer( isize,itype,cw_phase) = p_ac0cw + lptr_so4_aer( isize,itype,cw_phase) = p_so4cwj + lptr_nh4_aer( isize,itype,cw_phase) = p_nh4cwj + lptr_no3_aer( isize,itype,cw_phase) = p_no3cwj + lptr_na_aer( isize,itype,ai_phase) = p_nacwj + lptr_cl_aer( isize,itype,ai_phase) = p_clcwj + lptr_asoa1_aer( isize,itype,cw_phase) = p_asoa1cwj + lptr_asoa2_aer( isize,itype,cw_phase) = p_asoa2cwj + lptr_asoa3_aer( isize,itype,cw_phase) = p_asoa3cwj + lptr_asoa4_aer( isize,itype,cw_phase) = p_asoa4cwj + lptr_bsoa1_aer( isize,itype,cw_phase) = p_bsoa1cwj + lptr_bsoa2_aer( isize,itype,cw_phase) = p_bsoa2cwj + lptr_bsoa3_aer( isize,itype,cw_phase) = p_bsoa3cwj + lptr_bsoa4_aer( isize,itype,cw_phase) = p_bsoa4cwj + lptr_orgpa_aer( isize,itype,cw_phase) = p_orgpacwj + lptr_ec_aer( isize,itype,cw_phase) = p_eccwj + lptr_p25_aer( isize,itype,cw_phase) = p_p25cwj + do_cloudchem_aer(isize,itype) = .true. + endif + +! coarse mode + itype = 2 + isize = 1 + ncomp_aer(itype) = 3 + numptr_aer( isize,itype,ai_phase) = p_corn + lptr_anth_aer( isize,itype,ai_phase) = p_antha + lptr_seas_aer( isize,itype,ai_phase) = p_seas + lptr_soil_aer( isize,itype,ai_phase) = p_soila +! aerosol in cloud water + if(cw_phase.gt.0)then + numptr_aer( isize,itype,cw_phase) = p_corncw + lptr_anth_aer( isize,itype,cw_phase) = p_anthcw + lptr_seas_aer( isize,itype,cw_phase) = p_seascw + lptr_soil_aer( isize,itype,cw_phase) = p_soilcw +! no cloudchem for coarse mode because it has no so4/nh4/no3 species + do_cloudchem_aer(isize,itype) = .false. + endif + + massptr_aer(:,:,:,:) = -999888777 + mastercompptr_aer(:,:) = -999888777 + + p1st = param_first_scalar + + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + ll = 0 + if (lptr_so4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_so4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 1 + end if + if (lptr_no3_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_no3_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 2 + end if + if (lptr_nh4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_nh4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 3 + end if + if (lptr_asoa1_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_asoa1_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 4 + end if + if (lptr_asoa2_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_asoa2_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 5 + end if + if (lptr_asoa3_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_asoa3_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 6 + end if + if (lptr_asoa4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_asoa4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 7 + end if + if (lptr_bsoa1_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_bsoa1_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 8 + end if + if (lptr_bsoa2_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_bsoa2_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 9 + end if + if (lptr_bsoa3_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_bsoa3_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 10 + end if + if (lptr_bsoa4_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_bsoa4_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 11 + end if + if (lptr_orgpa_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_orgpa_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 12 + end if + if (lptr_ec_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_ec_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 13 + end if + if (lptr_p25_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_p25_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 14 + end if + if (lptr_anth_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_anth_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 15 + end if + if (lptr_seas_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_seas_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 16 + end if + if (lptr_soil_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_soil_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 17 + end if + if (lptr_na_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_na_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 18 + end if + if (lptr_cl_aer(n,itype,iphase) .ge. p1st) then + ll = ll + 1 + massptr_aer(ll,n,itype,iphase) = lptr_cl_aer(n,itype,iphase) + mastercompptr_aer(ll,itype) = 19 + endif + ncomp_aer_nontracer(itype) = ll + + ncomp_aer(itype) = ll + + mprognum_aer(n,itype,iphase) = 0 + if (numptr_aer(n,itype,iphase) .ge. p1st) then + mprognum_aer(n,itype,iphase) = 1 + end if + + end do ! size + end do ! type + end do ! phase + + waterptr_aer(:,:) = 0 + + do itype=1,ntype_aer + do ll=1,ncomp_aer(itype) + dens_aer(ll,itype) = dens_mastercomp_aer(mastercompptr_aer(ll,itype)) + mw_aer(ll,itype) = mw_mastercomp_aer(mastercompptr_aer(ll,itype)) + hygro_aer(ll,itype) = hygro_mastercomp_aer(mastercompptr_aer(ll,itype)) + name_aer(ll,itype) = name_mastercomp_aer(mastercompptr_aer(ll,itype)) + end do + end do + + is_aerosol(:) = .false. + do iphase=1,nphase_aer + do itype=1,ntype_aer + do n = 1, nsize_aer(itype) + do ll = 1, ncomp_aer(itype) + is_aerosol(massptr_aer(ll,n,itype,iphase))=.true. + end do + is_aerosol(numptr_aer(n,itype,iphase))=.true. + end do ! size + end do ! type + end do ! phase + +! for sectional +! the dhi/dlo_sect are the upper/lower bounds for +! mean-volume diameter for a section/bin +! for modal +! they should be set to reasonable upper/lower +! bounds for mean-volume diameters of each modes +! they are primarily used to put reasonable bounds +! on number (in relation to mass/volume) +! the dcen_sect are used by initwet for the impaction scavenging +! lookup tables, and should represent a "base" mean-volume diameter +! dp_meanvol_tmp (below) is the made-sorgam default initial value +! for mean-volume diameter (in cm) +! terminology: (pi/6) * (mean-volume diameter)**3 == +! (volume mixing ratio of section/mode)/(number mixing ratio) +! + dhi_sect(:,:) = 0.0 + dlo_sect(:,:) = 0.0 + + itype = 1 + isize = 1 + sigmag_aer(isize,itype) = sginin ! aitken + dp_meanvol_tmp = 1.0e2*dginin*exp(1.5*l2sginin) ! aitken + dcen_sect(isize,itype) = dp_meanvol_tmp + dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 + dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 + + itype = 1 + isize = 2 + sigmag_aer(isize,itype) = sginia ! accum + dp_meanvol_tmp = 1.0e2*dginia*exp(1.5*l2sginia) ! accum + dcen_sect(isize,itype) = dp_meanvol_tmp + dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 + dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 + + itype = 2 + isize = 1 + sigmag_aer(isize,itype) = sginic ! coarse + dp_meanvol_tmp = 1.0e2*dginic*exp(1.5*l2sginic) ! coarse + dcen_sect(isize,itype) = dp_meanvol_tmp + dhi_sect(isize,itype) = dp_meanvol_tmp*4.0 + dlo_sect(isize,itype) = dp_meanvol_tmp/4.0 + + do itype = 1, ntype_aer + do isize = 1, nsize_aer(itype) + volumcen_sect(isize,itype) = (pirs/6.0)*(dcen_sect(isize,itype)**3) + volumlo_sect(isize,itype) = (pirs/6.0)*(dlo_sect(isize,itype)**3) + volumhi_sect(isize,itype) = (pirs/6.0)*(dhi_sect(isize,itype)**3) + end do + end do + +! do initialization of the impaction/interception scavenging +! lookup tables + call initwet( & + ntype_aer, nsize_aer, ncomp_aer, & + massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, & + dcen_sect, sigmag_aer, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, & + nimptblgrow_maxd, dlndg_nimptblgrow ) + + END SUBROUTINE aerosols_soa_vbs_init_aercld_ptrs + !=========================================================================== + subroutine wetscav_sorgam_driver (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg,qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! wet removal by grid-resolved precipitation +! scavenging of cloud-phase aerosols and gases by collection, freezing, ... +! scavenging of interstitial-phase aerosols by impaction +! scavenging of gas-phase gases by mass transfer and reaction + +!---------------------------------------------------------------------- + !USE module_configure + !USE module_state_description + USE module_data_sorgam + !USE module_mosaic_wetscav,only: wetscav + +!---------------------------------------------------------------------- + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + id, ktau, ktauc, numgas_aqfrac + REAL, INTENT(IN ) :: dtstep,dtstepc +! +! all advected chemical species +! + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! fraction of gas species in cloud water + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), & + INTENT(IN ) :: gas_aqfrac + +! +! +! input from meteorology + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t_phy, & + p_phy, & + t8w,p8w, & + qlsink,precr,preci,precs,precg, & + rho_phy,cldfra + REAL, DIMENSION( ims:ime, jms:jme, num_chem ), & + INTENT(OUT ) :: qsrflx ! column change due to scavening + + call wetscav (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg,qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ntype_aer, nsize_aer, ncomp_aer, & + massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, & + volumcen_sect, volumlo_sect, volumhi_sect, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd,dlndg_nimptblgrow, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + end subroutine wetscav_sorgam_driver + + subroutine wetscav_soa_vbs_driver (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg,qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + +! wet removal by grid-resolved precipitation +! scavenging of cloud-phase aerosols and gases by collection, freezing, ... +! scavenging of interstitial-phase aerosols by impaction +! scavenging of gas-phase gases by mass transfer and reaction + +!---------------------------------------------------------------------- + !USE module_configure + !USE module_state_description + USE module_data_soa_vbs + !USE module_mosaic_wetscav,only: wetscav + +!---------------------------------------------------------------------- + IMPLICIT NONE + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + id, ktau, ktauc, numgas_aqfrac + REAL, INTENT(IN ) :: dtstep,dtstepc + +! all advected chemical species +REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + +! fraction of gas species in cloud water + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, numgas_aqfrac ), & + INTENT(IN ) :: gas_aqfrac + +! +! +! input from meteorology + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + alt, & + t_phy, & + p_phy, & + t8w,p8w, & + qlsink,precr,preci,precs,precg, & + rho_phy,cldfra + REAL, DIMENSION( ims:ime, jms:jme, num_chem ), & + INTENT(OUT ) :: qsrflx ! column change due to scavening + + call wetscav (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg,qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ntype_aer, nsize_aer, ncomp_aer, & + massptr_aer, dens_aer, numptr_aer, & + maxd_acomp, maxd_asize,maxd_atype, maxd_aphase, ai_phase, cw_phase, & + volumcen_sect, volumlo_sect, volumhi_sect, & + waterptr_aer, dens_water_aer, & + scavimptblvol, scavimptblnum, nimptblgrow_mind, nimptblgrow_maxd,dlndg_nimptblgrow, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + end subroutine wetscav_soa_vbs_driver + +END MODULE module_prep_wetscav_sorgam diff --git a/wrfv2_fire/chem/module_qf03.F b/wrfv2_fire/chem/module_qf03.F index e4d14c98..729f3a1c 100644 --- a/wrfv2_fire/chem/module_qf03.F +++ b/wrfv2_fire/chem/module_qf03.F @@ -1,573 +1,530 @@ -MODULE qf03 -! -! Y. Shao, 29 Jan 2004 -! -! JY Kang, 01 Dec 2008 -! Modify the code for WRF_chem -! -! M. Klose, 2010-2013 Modifications -!----------------------------------------------------------------------------------- -! Calculate sediment flux for multi-particle size soils as a weighted average of Q(d) -! dust emission F(d) for covered and moisture soil -! -! Options for dust calculation: -! 1 Shao (2001) -! 2 Shao (2004) -! 3 Shao (2011): simplification of 2; added on 26 Sep 2009 -! -!-------------------------------------------------------------------------------------- -! -! input: -! n: number of particle size ranges. -! dm: median diameter of each particle size. [m] -! m_fract: Weight fraction of each particle range. Sum m_fract = 1 -! ustar: Friciton velocity. [m/s] -! cf: fraction area covered by roughness elements -! w: surface soil moisture contains [m^3/m^3] -! c: Owen's coefficient -! -! output: -! ustart: Mean threshold velocity of each particle range. -! q: Sand flux from each size range. -! ffq: Weighted sand flux from each size range. -! qtotal: Total sand flux (weighted average). -! f: Weighted dust flux ejected by single sand size range for given d_d. -! fff: Weighted dust flux ejected by all sand size range from each dust size range. -! ftotal: Total dust flux (weighted average). -!-------------------------------------------------------------------------------------- -! - - CONTAINS - - subroutine qf03_driver ( nmx, idst, g, rho, dt, & - ustar, w, cf_in, ust_min, imod, dz_lowest, & - soilc, tot_soilc, domsoilc, & - tc, bems, rough_cor_in, smois_cor_in, wr, & - d0, dd, psd_m, dpsd_m, ppsd_m, psd_f, dpsd_f, ppsd_f, imax, stype) - - INTEGER, INTENT(IN ) :: nmx, imod, idst - REAL, INTENT(IN ) :: g, dt, rho, dz_lowest, ustar - REAL(8), INTENT(IN ) :: w, cf_in - REAL(8), INTENT(OUT ) :: ust_min, rough_cor_in, smois_cor_in - REAL , INTENT(INOUT), DIMENSION(nmx) :: tc, bems - REAL , INTENT(IN), DIMENSION(12) :: wr - -!kang [2009/01/07] soil class type - REAL, INTENT(IN ) :: tot_soilc - REAL, DIMENSION(16), INTENT(IN) :: soilc - INTEGER, INTENT(IN ) :: domsoilc - - integer :: imax, stype - real(8), dimension(0:imax), intent(in) :: d0 - real(8), dimension(imax), intent(in) :: dd - real(8), dimension(imax,stype), intent(in) :: psd_m, dpsd_m, ppsd_m - real(8), dimension(imax,stype), intent(in) :: psd_f, dpsd_f, ppsd_f - -!local variables -! particle-size distributions - real(8), dimension(imax) :: psdm, dpsdm, ppsdm ! minimally dispersed - real(8), dimension(imax) :: psdf, dpsdf, ppsdf ! fully dispersed - real(8), dimension(imax) :: psds, dpsds, ppsds ! sediment - character(4) :: s_type - - - real(8) :: smois_correc - integer :: i, j, n, kk, ij, index - real(8) :: total, qtotal, ftotal, cf - real(8) :: ftotalb, ftotalp -! - real(8), parameter :: calpha = 5.d0, cbeta = 1.37d0 -! -! - real(8), dimension(imax) :: beta_d, beta_s ! beta1 and beta2 used by Shao et al. (1996) dust emission - real(8), dimension(imax) :: ustart, q, ffq, fff - real(8), dimension(imax,imax) :: f -! - real(8), dimension(imax,imax) :: fb - real(8), dimension(imax,imax) :: fp - real(8), dimension(imax) :: fffb, fffp -! - real(8), parameter :: c_lambda=0.35 - real(8) :: h, lambda - real(8) :: ghl, fc - real(8) :: phl - real(8) :: cys, u0, al0, sx, ppr, rhos, smass, omega, rys - real(8) :: ddm, a1, a2, a3, a3b, a3p - real(8) :: zeta, sigma_m ! u*sqrt(rhos/p), bombardment coefficient -! - real(8) :: ustart0_out, qwhite_out, f_mb_out, f_hlys_out, pmass_out, vhlys_out - - real :: xx1,xx2,xx3,xx4 - - character*2 mod - character*6 ss_type - character*80 infile - character*80 surf_file - integer :: nmax - - integer, parameter :: nbins=4 - integer, parameter :: nkk=50 - real(8) :: sigma - real, dimension(nbins) :: dbin, fbin, cell_fbin - integer, dimension(nbins) :: ibin - data dbin/2.5,5.,10.,20./ !size cut diameter (um) - real(8) :: rhop - real :: cell_ftotal - integer :: isl, cc -!******************************************************************************************* -! -! initialization - cell_ftotal = 0. - do n = 1, nbins - cell_fbin(n) = 0. - enddo -! - DO cc = 1, 12 ! soil category - if (soilc(cc).eq.0.) then - go to 103 - endif - if (cc.eq.1.or.cc.eq.2) then - s_type = 'sand' - psdm(:)=psd_m(:,1) - psdf(:)=psd_f(:,1) - dpsdm(:)=dpsd_m(:,1) - dpsdf(:)=dpsd_f(:,1) - ppsdm(:)=ppsd_m(:,1) - ppsdf(:)=ppsd_f(:,1) - elseif (cc.eq.3.or.cc.eq.4..or.cc.eq.6.or.cc.eq.8.or.cc.eq.9) then - s_type = 'loam' - psdm(:)=psd_m(:,3) - psdf(:)=psd_f(:,3) - dpsdm(:)=dpsd_m(:,3) - dpsdf(:)=dpsd_f(:,3) - ppsdm(:)=ppsd_m(:,3) - ppsdf(:)=ppsd_f(:,3) - elseif (cc.eq.7) then - s_type = 'sloa' - psdm(:)=psd_m(:,2) - psdf(:)=psd_f(:,2) - dpsdm(:)=dpsd_m(:,2) - dpsdf(:)=dpsd_f(:,2) - ppsdm(:)=ppsd_m(:,2) - ppsdf(:)=ppsd_f(:,2) - elseif (cc.eq.5.or.cc.eq.10.or.cc.eq.11.or.cc.eq.12) then - s_type = 'clay' - psdm(:)=psd_m(:,4) - psdf(:)=psd_f(:,4) - dpsdm(:)=dpsd_m(:,4) - dpsdf(:)=dpsd_f(:,4) - ppsdm(:)=ppsd_m(:,4) - ppsdf(:)=ppsd_f(:,4) - else - go to 103 - endif -! -! - rhop = 2560.d0 ! particle density [kg/m3] - rhos = 1000.d0 ! bulk density of soil [kg/m3] ??? - phl = 30000. ! plastic pressure [N/m2] - cys = 0.00001 ! cys : parameter - - sigma = rhop/rho ! particle-air density ratio - cf = cf_in/100. ! vegetation cover - -! -!------------------- -! frontal area index -!------------------- - lambda = - c_lambda*dlog( 1.d0 - cf ) - call r_c(lambda, rough_cor_in) - -! Matching WRF_soil class with Shao's class for moisture correction of Fecan (cc:WRF_soil class, isl:Shao's class) -! cc -! 1:sand, 2:loamy sand, 3:sandy loam, 4:silt loam, 5:silt, 6:loam, 7:sandy clay loam, -! 8:silty clay loam, 9:clay loam, 10:sandy clay, 11:silty clay, 12:clay -! isl -! 1:sand, 2:loamy sand, 3:sandy loam, 4:loam, 5:silt loam, 6: silt, 7:sandy clay loam, -! 8:clay loam, 9:silty clay loam, 10:sandy clay, 11:silty clay, 12:clay - if (cc.eq.1.or.cc.eq.2.or.cc.eq.3.or.cc.eq.7.or.cc.eq.10.or. & - & cc.eq.11.or.cc.eq.12) then - isl = cc - elseif (cc.eq.4) then - isl = 5 - elseif (cc.eq.5) then - isl = 6 - elseif (cc.eq.6) then - isl = 4 - elseif (cc.eq.8) then - isl = 9 - elseif (cc.eq.9) then - isl = 8 - endif - - call h_c(w, wr(cc), isl, smois_correc) -!---------------------------------------------- -! for each particle size group, estimate ustart -!---------------------------------------------- -! - ust_min = 999.0 - do i = 1, imax - call ustart0(dd(i), sigma, g, rho, ustart0_out) - ustart(i) = ustart0_out - ustart(i) = rough_cor_in*smois_correc*ustart(i) - ust_min = dmin1(ust_min, ustart(i)) - call qwhite(ustart(i), ustar, rho, g, qwhite_out) - q(i) = qwhite_out - q(i) = (1.d0-cf)*q(i) - enddo - if (cc.eq.domsoilc) then - smois_cor_in = smois_correc - endif -! -! - IF ( ustar .le. ust_min ) THEN ! no erosion goto 102 - q = 0.d0 - ffq = 0.d0 - qtotal = 0.d0 - fff = 0.d0 - ftotal = 0.d0 - fbin = 0.d0 - goto 102 - ELSE - ghl = dexp( -(ustar - ust_min)**3.d0 ) - dpsds = ghl*dpsdm + (1.-ghl)*dpsdf - psds = ghl*psdm + (1.-ghl)*psdf - ppsds = ghl*ppsdm + (1.-ghl)*ppsdf -! - ffq = q*dpsds - qtotal = sum(ffq) - -!-------------- -! dust emission -!-------------- -! -! size bin - do n=1,nbins - ibin(n)=0 - do i=imax,1,-1 - if(d0(i).ge.dbin(n)) ibin(n)=i - enddo - if(ibin(n).eq.0) stop 'wrong dust classes' - enddo -! -! -! -!-------------------------------- -! Shao (2001) dust emission model -!-------------------------------- - IF (imod .eq. 1) THEN - do i = idst+1, imax - ddm = dd(i)*1.d-6 - call pmass(rhop, ddm, pmass_out) ! mass of saltating particles - smass = pmass_out - u0 = 10*ustar - al0 = 13.d0*3.14159d0/180.d0 - call vhlys(phl, 2, smass, al0, u0, ddm, vhlys_out) - omega = vhlys_out ![m3] -! - do j = 1, idst - rys = psdm(j)/psdf(j) - a1 = cys*( (1.-ghl) + ghl*rys ) - a2 = ffq(i)*g/ustar**2/smass - - if ( dpsdf(j) .lt. dpsdm(j) ) then - a3 = dpsdf(j)*rhos*omega - else - a3 = dpsdf(j)*rhos*omega + (dpsdf(j)-dpsdm(j))*smass - endif - f(i,j) = a1*a2*a3 ![kg/m2/s] - enddo - enddo -! - ftotal = 0.0 - do j = 1, idst - fff(j) = 0. - do i = idst+1, imax - fff(j) = fff(j) + f(i,j) - enddo - fff(j) = (1-cf)*fff(j) - ftotal = ftotal + fff(j) - enddo -! - do n=1,nbins - j0=1 - if(n.gt.1) j0=ibin(n-1)+1 - fbin(n)=0 - do j=j0,ibin(n) - fbin(n)=fbin(n)+fff(j) - enddo - enddo -! -!-------------------------------- -! Shao (2004) dust emission model -!-------------------------------- - ELSEIF (imod .eq. 2) THEN - zeta = ustar*dsqrt( rhos/phl ) - sigma_m = 12.d0*zeta*zeta*(1.d0+14.d0*zeta) -! - do i = idst+1, imax - do j = 1, idst - rys = psdm(j)/psdf(j) - a1 = cys*dpsdf(j)*( (1.-ghl) + ghl*rys ) - a2 = (1.+sigma_m) - a3 = ffq(i)*g/ustar**2 - f(i,j) = a1*a2*a3 - enddo - enddo -! - ftotal = 0.0 - do j = 1, idst - fff(j) = 0. - do i = idst+1, imax - fff(j) = fff(j) + f(i,j) - enddo - fff(j) = (1-cf)*fff(j) - ftotal = ftotal + fff(j) - enddo -! - do n=1,nbins - j0=1 - if(n.gt.1) j0=ibin(n-1)+1 - fbin(n)=0 - do j=j0,ibin(n) - fbin(n)=fbin(n)+fff(j) - enddo - enddo -! -! -!-------------------------------------------------------------------------- -! Shao (2011) minimal version, ghl = 1, Q independent of sand particle size -! -! See Eq. (34) in -! Shao, Y., M. Ishizuka, M. Mikami, J. Leys (2011): Parameterization of size- -! resolved dust emission and validation with measurements, JGR, 116, D08203, -! doi: 10.1029/2010JD014527 -!-------------------------------------------------------------------------- - ELSEIF (imod .eq. 3) THEN - zeta = ustar*dsqrt( rhos/phl ) - sigma_m = 12.d0*zeta*zeta*(1.d0+14.d0*zeta) -! - ftotal = 0.0 -! - do j = 1, idst - a1 = cys*dpsdm(j) - a2 = (1.+sigma_m) - a3 = qtotal*g/ustar**2 - fff(j) = a1*a2*a3 - fff(j) = (1-cf)*fff(j) - ftotal = ftotal + fff(j) - enddo -! - do n=1,nbins - j0=1 - if(n.gt.1) j0=ibin(n-1)+1 - fbin(n)=0 - do j=j0,ibin(n) - fbin(n)=fbin(n)+fff(j) - enddo - enddo -! - ENDIF ! dust scheme - ENDIF ! ust < ust_t -! -! -! -102 continue - - do n = 1, nbins - cell_fbin(n) = cell_fbin(n) + (soilc(cc)/tot_soilc)*fbin(n) - enddo - cell_ftotal = cell_ftotal + ftotal*soilc(cc)/tot_soilc - -103 continue - - ENDDO ! cc, soil category - - - do n = 1, nbins -! fbin : [kg/m2/s], dz_lowest : [m], rho : [kg/m3], dt : [s] -> tc : [kg/kg-dryair] - tc(n) = tc(n) + cell_fbin(n)/dz_lowest/rho*dt ![kg/kg-dryair] - bems(n) = cell_fbin(n) ![kg/m2/s] - enddo - tc(5) = tc(5) + cell_ftotal/dz_lowest/rho*dt ![kg/kg-dryair] - bems(5) = cell_ftotal ![kg/m2/s] - - END subroutine qf03_driver - - -!***************************************************************************** - subroutine ustart0(dum, sigma, g, rho, ustart0_out) -! -! Y. Shao, 13 June 2000 -! -! Calculate ustar0(d) using Shao and Lu (2000) for uncovered -! dry surface -! -! dum: particle diameter [um] -! ustar0: threshold friction velocity [m/s] -! - real, intent(in) :: g, rho - real(8), intent(in) :: dum, sigma - real(8), intent(out) :: ustart0_out - real(8) :: dm - real(8), parameter :: gamma = 1.65d-4 ! a constant - real(8), parameter :: f = 0.0123 - - dm = dum*1d-6 - - ustart0_out = f*(sigma*g*dm + gamma/(rho*dm) ) - ustart0_out = dsqrt( ustart0_out ) -! end function - end subroutine ustart0 -!***************************************************************************** - subroutine qwhite(ust, ustar, rho, g, qwhite_out) -! -! Yaping Shao 17-07-99! -! -! White (1979) Sand Flux Equation -! Q = c*rho*u_*^3 over g (1 - u_*t over u_*)(1 + u_*t^2/u_*^2) -! qwhite: Streamwise Sand Flux; [kg m-1 s-1] -! c : 2.6 -! ust : threhold friction velocity [m/s] -! ustar : friction velocity [m/s] -! - real(8) :: c - real, intent(in) :: ustar, rho, g - real(8), intent(in) :: ust - real(8), intent(out) :: qwhite_out - real(8) :: a, b - c = 0.5d0 - a = rho/g -! IF (ustar.lt.ust) THEN -! qwhite = 0.d0 -! ELSE -! b = ust/ustar -! qwhite = c*a*ustar**3.*(1.-b)*(1.+b*b) -! ENDIF - IF (ustar.lt.ust) THEN - qwhite_out = 0.d0 - ELSE - b = ust/ustar - qwhite_out = c*a*ustar**3.*(1.-b)*(1.+b*b) - ENDIF - - END subroutine qwhite -!***************************************************************************** - subroutine vhlys(p, k, xm, alpha, u, d, vhlys_out) -! -! Volume removal according to Lu and Shao (1999), Equation (8) -! alpha: impact angle [^o] -! u : impact velocity [m/s] -! p : plastic pressure [N/m^2] -! xm : particle mass [kg] -! d : particle diameter [m] -! -! - REAL(8),intent(in) :: alpha, xm, u, d, p - REAL(8) :: beta - REAL(8), PARAMETER :: pi=3.1415927d0 - REAL(8) :: t1, t2, t3 - INTEGER,intent(in) :: k - real(8),intent(out) :: vhlys_out - - beta = dsqrt( p*k*d/xm ) - t1 = u*u/(beta*beta)*( dsin(2.d0*alpha) - 4.d0*dsin(alpha)*dsin(alpha) ) - t2 = u*dsin(alpha)/beta - t3 = 7.5d0*pi*t2**3.d0/d - vhlys_out = d*( t1 + t3 ) - - END subroutine vhlys -!***************************************************************************** -! A routine for correction of ust for soil moisture content -! -! w : volumetric soil moisture -! isl: soil texture type, ranging from 1 to 12 -! -! Author: Yaping Shao, 5/05/2001 -! Reference: Fecan et al. (1999), Ann. Geophysicae,17,149-157 -! -! Data based on Shao and Jung, 2000, unpublished manuscript -! Data invented for sand, loamy sand, sandy loam, loam, clay loam, and clay -! isl=1, 2, 3, 4, 8, 12 -!---------------------------------------------------------------------- - subroutine h_c (w, wr, isl, h) - - real(8) :: a(12), b(12) - real(8), intent(in) :: w - real(8), intent(out) :: h - real, intent(in) :: wr - integer, intent(in) :: isl - character*100 :: msg ! error message string - -! NOTE: There might be an inconsistency between soil moisture parameters used in this module and -! the ones used in the WRF land-surface model. For Noah, RUC, and Noah MP LSM, the inconsistency has -! been checked and the values provided in SOILPARM.TBL are used for consistency purpose. For all -! other LSM options, the parameters obtained from Shao are used and the inconsistency might still -! occur. This might lead to unrealistic fluxes. - - data a /21.19, 33.03, 44.87, 17.79, 20.81, 23.83, 26.84, 29.86, 27.51, 25.17, 22.82, 20.47/ - data b / 0.68, 0.71, 0.85, 0.61, 0.66, 0.71, 0.75, 0.80, 0.75, 0.70, 0.64, 0.59/ - - if ( w.lt.0. ) then - write(msg, *) 'soil moisture correction (h_c): w = ', w, ' < 0' - call wrf_error_fatal(msg) -! stop - endif - - if ( w.le.wr ) then - h = 1.0 - else - h = sqrt( 1 + a(isl)*( w-wr )**b(isl) ) - endif - - END subroutine h_c - -!***************************************************************************** - subroutine pmass(rhop, d, pmass_out) -! -! Particle Mass -! rhop: particle density [kg m^-3] -! d : particle size [m] -! - REAL(8), PARAMETER :: pi=3.1415927d0 - REAL(8),intent(in) :: rhop, d - real(8),intent(out) :: pmass_out - - pmass_out = (pi*rhop*d**3.d0)/6.d0 - - END subroutine pmass - -!***************************************************************************** - subroutine r_c (x,r) -! -! Y. Shao 17-07-92 -! CORRECTION FUNCTION FOR UST(D) BASED ON Raupach et al. (1992) -! x = frontal area index -! -! R_C = (1 - sig m x)^{1/2} (1 + m beta x)^{1/2} -! Note I deife R_C = u_{*tR}/u_{*tS} -! While Raupach et al. defined -! R_C = u_{*tS}/u_{*tR} and their R function is -! R_C = (1 - sig m x)^{-1/2} (1 + m beta x)^{-1/2} -! -! sig : basal to frontal area; about 1 -! m : parameter less than 1; about 0.5 -! beta : a ratio of drag coef.; about 90. -! - real(8) :: xc - real(8), intent(in) :: x - real(8), intent(out) :: r - real(8), parameter :: sig=1., m=0.5, beta=90. -! - xc = 1./(sig*m) - IF (x.ge.xc) THEN - r = 999. ! Full covered surface - ELSE - r = dsqrt(1.-sig*m*x)*dsqrt(1.+m*beta*x) - ENDIF -! - END subroutine r_c - - - -END MODULE qf03 +MODULE qf03 +! +! Y. Shao, 29 Jan 2004 +! +! JY Kang, 01 Dec 2008 +! Modify the code for WRF_chem +! +! M. Klose, 2010-2015 Modifications +!----------------------------------------------------------------------------------- +! Calculate sediment flux for multi-particle size soils as a weighted average of Q(d) +! dust emission F(d) for covered and moisture soil +! +! Options for dust calculation: +! 1 Shao (2001) +! 2 Shao (2004) +! 3 Shao (2011): simplification of 2; added on 26 Sep 2009 +! +!-------------------------------------------------------------------------------------- +! +! input: +! n: number of particle size ranges. +! dm: median diameter of each particle size. [m] +! m_fract: Weight fraction of each particle range. Sum m_fract = 1 +! ustar: Friciton velocity. [m/s] +! cf: fraction area covered by roughness elements/vegetation cover +! w: surface soil moisture content [m^3/m^3] +! wr: air-dry soil moisture [m^3/m^3] from SOILPARM.TBL +! c: Owen's coefficient +! +! output: +! ustart: Mean threshold velocity of each particle range. +! q: Sand flux from each size range. +! ffq: Weighted sand flux from each size range. +! qtotal: Total sand flux (weighted average). +! f: Weighted dust flux ejected by single sand size range for given d_d. +! fff: Weighted dust flux ejected by all sand size range from each dust size range. +! ftotal: Total dust flux (weighted average). +!-------------------------------------------------------------------------------------- +! + + CONTAINS + + subroutine qf03_driver ( nmx, idst, g, rhop, rho, dt, & + ustar, w, cf, ust_min, imod, dz_lowest, & + soilc, tot_soilc, domsoilc, & + tc, bems, rough_cor_in, smois_cor_in, wr, & + d0, dd, psd_m, dpsd_m, ppsd_m, psd_f, dpsd_f, ppsd_f, imax, stype) + + INTEGER, INTENT(IN ) :: nmx, imod, idst + REAL , INTENT(IN ) :: g, dt, rho, dz_lowest, ustar + REAL(8), INTENT(IN ) :: w + REAL(8), INTENT(INOUT) :: cf + REAL(8), INTENT( OUT) :: ust_min, rough_cor_in, smois_cor_in + REAL , INTENT(INOUT), DIMENSION(nmx) :: tc + REAL , INTENT( OUT), DIMENSION(nmx) :: bems + REAL , INTENT(IN ), DIMENSION(12) :: wr + +!kang [2009/01/07] soil class type + REAL, INTENT(IN ) :: tot_soilc + REAL, DIMENSION(16), INTENT(IN) :: soilc + INTEGER, INTENT(IN ) :: domsoilc + + integer :: imax, stype + real(8), dimension(0:imax), intent(in) :: d0 + real(8), dimension(imax), intent(in) :: dd + real(8), dimension(imax,stype), intent(in) :: psd_m, dpsd_m, ppsd_m + real(8), dimension(imax,stype), intent(in) :: psd_f, dpsd_f, ppsd_f + +!local variables +! particle-size distributions + real(8), dimension(imax) :: psdm, dpsdm, ppsdm ! minimally dispersed + real(8), dimension(imax) :: psdf, dpsdf, ppsdf ! fully dispersed + real(8), dimension(imax) :: psds, dpsds, ppsds ! sediment + + real(8) :: smois_correc + integer :: i, j, n, kk, ij, ffile + real(8) :: total, qtotal, ftotal + real(8) :: ftotalb, ftotalp +! + real(8), dimension(imax) :: beta_d, beta_s ! beta1 and beta2 used by Shao et al. (1996) dust emission + real(8), dimension(imax) :: ustart, q, ffq, fff + real(8), dimension(imax,imax) :: f +! + real(8), parameter :: c_lambda=0.35 + real(8) :: h, lambda + real(8) :: ghl, fc + real(8) :: phl + real(8) :: cys, u0, al0, rhos, smass, omega, rys + real(8) :: ddm, a1, a2, a3 + real(8) :: zeta, sigma_m ! u*sqrt(rhos/p), bombardment coefficient +! + real(8) :: ustart0_out, qwhite_out, f_mb_out, f_hlys_out, pmass_out, vhlys_out +! + integer, parameter :: nbins = 5 + real(8) :: sigma + real, dimension(nbins) :: dbin, fbin, cell_fbin + integer, dimension(nbins) :: ibin + data dbin/2.,3.6,6.,12.,20./ !size cut diameter (um) consistent with GOCART model + real(8), intent(in) :: rhop + real :: cell_ftotal + integer :: isl, cc + character :: msg, soil +!******************************************************************************************* +! +! initialization + cell_ftotal = 0. + do n = 1, nbins + cell_fbin(n) = 0. + enddo +! + DO cc = 1, 12 ! soil category + if (soilc(cc).eq.0.) then + go to 103 + endif +! + psdm(:)=psd_m(:,cc) + psdf(:)=psd_f(:,cc) + dpsdm(:)=dpsd_m(:,cc) + dpsdf(:)=dpsd_f(:,cc) + ppsdm(:)=ppsd_m(:,cc) + ppsdf(:)=ppsd_f(:,cc) + +! default settings: + rhos = 1000.d0 ! bulk density of soil [kg/m3] + phl = 30000. ! plastic pressure [N/m2] + cys = 0.00001 ! cys : parameter + + sigma = rhop/rho ! particle-air density ratio + +! +!------------------- +! frontal area index +!------------------- + if (cf .gt. 0.95) then + write(6,*) 'cover fraction too large, reset' + cf = 0.95 + endif! as larger values lead to large lambda, which is problematic in Raupach scheme + + lambda = - c_lambda*dlog( 1.d0 - cf ) + call r_c(lambda, rough_cor_in) + +! Matching WRF_soil class with Shao's class for moisture correction of Fecan (cc:WRF_soil class, isl:Shao's class) +! cc +! 1:sand, 2:loamy sand, 3:sandy loam, 4:silt loam, 5:silt, 6:loam, 7:sandy clay loam, +! 8:silty clay loam, 9:clay loam, 10:sandy clay, 11:silty clay, 12:clay +! isl +! 1:sand, 2:loamy sand, 3:sandy loam, 4:loam, 5:silt loam, 6: silt, 7:sandy clay loam, +! 8:clay loam, 9:silty clay loam, 10:sandy clay, 11:silty clay, 12:clay + if (cc.eq.1.or.cc.eq.2.or.cc.eq.3.or.cc.eq.7.or.cc.eq.10.or. & + & cc.eq.11.or.cc.eq.12) then + isl = cc + elseif (cc.eq.4) then + isl = 5 + elseif (cc.eq.5) then + isl = 6 + elseif (cc.eq.6) then + isl = 4 + elseif (cc.eq.8) then + isl = 9 + elseif (cc.eq.9) then + isl = 8 + endif + + call h_c(w, wr(cc), isl, smois_correc) +!---------------------------------------------- +! for each particle size group, estimate ustart +!---------------------------------------------- +! + ust_min = 999.0 + do i = 1, imax + call ustart0(dd(i), sigma, g, rho, ustart0_out) + ustart(i) = ustart0_out + ustart(i) = rough_cor_in*smois_correc*ustart(i) + ust_min = dmin1(ust_min, ustart(i)) + call qwhite(ustart(i), ustar, rho, g, qwhite_out) + q(i) = qwhite_out + q(i) = (1.d0-cf)*q(i) + enddo + if (cc.eq.domsoilc) then + smois_cor_in = smois_correc + endif +! +! + IF ( ustar .le. ust_min ) THEN ! no erosion goto 102 + q = 0.d0 + ffq = 0.d0 + qtotal = 0.d0 + fff = 0.d0 + ftotal = 0.d0 + fbin = 0.d0 + goto 102 + ELSE + ghl = dexp( -(ustar - ust_min)**3.d0 ) + dpsds = ghl*dpsdm + (1.-ghl)*dpsdf + psds = ghl*psdm + (1.-ghl)*psdf + ppsds = ghl*ppsdm + (1.-ghl)*ppsdf +! + ffq = q*dpsds + qtotal = sum(ffq) + +!-------------- +! dust emission +!-------------- +! +! size bin + do n=1,nbins + ibin(n)=0 + do i=imax,1,-1 + if(d0(i).ge.dbin(n)) ibin(n)=i + enddo + if(ibin(n).eq.0) stop 'wrong dust classes' + enddo +! +! +! +!-------------------------------- +! Shao (2001) dust emission model +!-------------------------------- + IF (imod .eq. 1) THEN + do i = idst+1, imax + ddm = dd(i)*1.d-6 + call pmass(rhop, ddm, pmass_out) ! mass of saltating particles + smass = pmass_out + u0 = 10*ustar + al0 = 13.d0*3.14159d0/180.d0 + call vhlys(phl, 2, smass, al0, u0, ddm, vhlys_out) + omega = vhlys_out ![m3] +! + do j = 1, idst + rys = psdm(j)/psdf(j) + if (rys.gt.1.) then + rys = 1. + endif + a1 = cys*( (1.-ghl) + ghl*rys ) + a2 = ffq(i)*g/ustar**2/smass + + if ( dpsdf(j) .lt. dpsdm(j) ) then + a3 = dpsdf(j)*rhos*omega + else + a3 = dpsdf(j)*rhos*omega + (dpsdf(j)-dpsdm(j))*smass + endif + f(i,j) = a1*a2*a3 ![kg/m2/s] + enddo + enddo +! + ftotal = 0.0 + do j = 1, idst + fff(j) = 0. + do i = idst+1, imax + fff(j) = fff(j) + f(i,j) + enddo + fff(j) = (1.d0-cf)*fff(j) + ftotal = ftotal + fff(j) + enddo +! + do n=1,nbins + j0=1 + if(n.gt.1) j0=ibin(n-1)+1 + fbin(n)=0 + do j=j0,ibin(n) + fbin(n)=fbin(n)+fff(j) + enddo + enddo +! +!-------------------------------- +! Shao (2004) dust emission model +!-------------------------------- + ELSEIF (imod .eq. 2) THEN + zeta = ustar*dsqrt( rhos/phl ) + sigma_m = 12.d0*zeta*zeta*(1.d0+14.d0*zeta) +! + do i = idst+1, imax + do j = 1, idst + rys = psdm(j)/psdf(j) + if (rys .gt.1.) then + rys = 1. + endif + a1 = cys*dpsdf(j)*( (1.-ghl) + ghl*rys ) + a2 = (1.+sigma_m) + a3 = ffq(i)*g/ustar**2 + f(i,j) = a1*a2*a3 + enddo + enddo +! + ftotal = 0.0 + do j = 1, idst + fff(j) = 0. + do i = idst+1, imax + fff(j) = fff(j) + f(i,j) + enddo + fff(j) = (1.d0-cf)*fff(j) + ftotal = ftotal + fff(j) + enddo +! + do n=1,nbins + j0=1 + if(n.gt.1) j0=ibin(n-1)+1 + fbin(n)=0 + do j=j0,ibin(n) + fbin(n)=fbin(n)+fff(j) + enddo + enddo +! +! +!-------------------------------------------------------------------------- +! Shao (2011) minimal version, ghl = 1, Q independent of sand particle size +! +! See Eq. (34) in +! Shao, Y., M. Ishizuka, M. Mikami, J. Leys (2011): Parameterization of size- +! resolved dust emission and validation with measurements, JGR, 116, D08203, +! doi: 10.1029/2010JD014527 +!-------------------------------------------------------------------------- + ELSEIF (imod .eq. 3) THEN + zeta = ustar*dsqrt( rhos/phl ) + sigma_m = 12.d0*zeta*zeta*(1.d0+14.d0*zeta) +! + ftotal = 0.0 +! + do j = 1, idst + a1 = cys*dpsdm(j) + a2 = (1.+sigma_m) + a3 = qtotal*g/ustar**2 + fff(j) = a1*a2*a3 + fff(j) = (1.d0-cf)*fff(j) + ftotal = ftotal + fff(j) + enddo +! + do n=1,nbins + j0=1 + if(n.gt.1) j0=ibin(n-1)+1 + fbin(n)=0 + do j=j0,ibin(n) + fbin(n)=fbin(n)+fff(j) + enddo + enddo +! + ENDIF ! dust scheme + ENDIF ! ust < ust_t +! +! +! +102 continue + + do n = 1, nbins + cell_fbin(n) = cell_fbin(n) + (soilc(cc)/tot_soilc)*fbin(n) + enddo + +103 continue + + ENDDO ! cc, soil category + + do n = 1, nbins +! fbin : [kg/m2/s], dz_lowest : [m], rho : [kg/m3], dt : [s] -> tc : [kg/kg-dryair] + tc(n) = tc(n) + cell_fbin(n)/dz_lowest/rho*dt ![kg/kg-dryair] + bems(n) = cell_fbin(n) ![kg/m2/s] + enddo + + + END subroutine qf03_driver + + +!***************************************************************************** + subroutine ustart0(dum, sigma, g, rho, ustart0_out) +! +! Y. Shao, 13 June 2000 +! +! Calculate ustar0(d) using Shao and Lu (2000) for uncovered +! dry surface +! +! dum: particle diameter [um] +! ustar0: threshold friction velocity [m/s] +! + real, intent(in) :: g, rho + real(8), intent(in) :: dum, sigma + real(8), intent(out) :: ustart0_out + real(8) :: dm + real(8), parameter :: gamma = 1.65d-4 ! a constant + real(8), parameter :: f = 0.0123 + + dm = dum*1d-6 + + ustart0_out = f*(sigma*g*dm + gamma/(rho*dm) ) + ustart0_out = dsqrt( ustart0_out ) +! end function + end subroutine ustart0 +!***************************************************************************** + subroutine qwhite(ust, ustar, rho, g, qwhite_out) +! +! Yaping Shao 17-07-99! +! +! White (1979) Sand Flux Equation +! Q = c*rho*u_*^3 over g (1 - u_*t over u_*)(1 + u_*t^2/u_*^2) +! qwhite: Streamwise Sand Flux; [kg m-1 s-1] +! c : 2.6 +! ust : threhold friction velocity [m/s] +! ustar : friction velocity [m/s] +! + real(8) :: c + real, intent(in) :: ustar, rho, g + real(8), intent(in) :: ust + real(8), intent(out) :: qwhite_out + real(8) :: a, b +! default setting: + c = 2.3d0 + a = rho/g + + IF (ustar.lt.ust) THEN + qwhite_out = 0.d0 + ELSE + b = ust/ustar + qwhite_out = c*a*ustar**3.*(1.-b)*(1.+b*b) + ENDIF + + END subroutine qwhite +!***************************************************************************** + subroutine vhlys(p, k, xm, alpha, u, d, vhlys_out) +! +! Volume removal according to Lu and Shao (1999), Equation (8) +! alpha: impact angle [^o] +! u : impact velocity [m/s] +! p : plastic pressure [N/m^2] +! xm : particle mass [kg] +! d : particle diameter [m] +! +! + REAL(8),intent(in) :: alpha, xm, u, d, p + REAL(8) :: beta + REAL(8), PARAMETER :: pi=3.1415927d0 + REAL(8) :: t1, t2, t3 + INTEGER,intent(in) :: k + real(8),intent(out) :: vhlys_out + + beta = dsqrt( p*k*d/xm ) + t1 = u*u/(beta*beta)*( dsin(2.d0*alpha) - 4.d0*dsin(alpha)*dsin(alpha) ) + t2 = u*dsin(alpha)/beta + t3 = 7.5d0*pi*t2**3.d0/d + vhlys_out = d*( t1 + t3 ) + + END subroutine vhlys +!***************************************************************************** +! A routine for correction of ust for soil moisture content +! +! w : volumetric soil moisture +! isl: soil texture type, ranging from 1 to 12 +! +! Author: Yaping Shao, 5/05/2001 +! Reference: Fecan et al. (1999), Ann. Geophysicae,17,149-157 +! +! Data based on Shao and Jung, 2000, unpublished manuscript +! Data invented for sand, loamy sand, sandy loam, loam, clay loam, and clay +! Soil classes: +! 1 sand, 2 loamy sand, 3 sandy loam, 4 loam, 5 silty loam, 6 silt, 7 sandy clay loam, 8 clay loam, +! 9 silty clay loam, 10 sandy clay, 11 silty clay, 12 clay +!---------------------------------------------------------------------- + subroutine h_c (w, wr, isl, h) + + real(8) :: a(12), b(12)!, thr(12) + real(8), intent(in) :: w + real(8), intent(out) :: h + real, intent(in) :: wr + integer, intent(in) :: isl + character*100 :: msg ! error message string + +! data thr/0.001, 0.003, 0.037, 0.049, 0.061, 0.072, 0.084, 0.095, 0.110, 0.126, 0.141, 0.156/ + data a /21.19, 33.03, 44.87, 17.79, 20.81, 23.83, 26.84, 29.86, 27.51, 25.17, 22.82, 20.47/ + data b / 0.68, 0.71, 0.85, 0.61, 0.66, 0.71, 0.75, 0.80, 0.75, 0.70, 0.64, 0.59/ + + if ( w.lt.0. ) then + write(msg, *) 'soil moisture correction (h_c): w = ', w, ' < 0' + call wrf_error_fatal(msg) +! stop + endif + + if ( w.le.wr ) then + h = 1.0 + else + h = sqrt( 1 + a(isl)*( w-wr )**b(isl) ) + endif + + END subroutine h_c + +!***************************************************************************** + subroutine pmass(rhop, d, pmass_out) +! +! Particle Mass +! rhop: particle density [kg m^-3] +! d : particle size [m] +! + REAL(8), PARAMETER :: pi=3.1415927d0 + REAL(8),intent(in) :: rhop, d + real(8),intent(out) :: pmass_out + + pmass_out = (pi*rhop*d**3.d0)/6.d0 + + END subroutine pmass + +!***************************************************************************** + subroutine r_c (x,r) +! +! Y. Shao 17-07-92 +! CORRECTION FUNCTION FOR UST(D) BASED ON Raupach et al. (1992) +! x = frontal area index +! +! R_C = (1 - sig m x)^{1/2} (1 + m beta x)^{1/2} +! Note I deife R_C = u_{*tR}/u_{*tS} +! While Raupach et al. defined +! R_C = u_{*tS}/u_{*tR} and their R function is +! R_C = (1 - sig m x)^{-1/2} (1 + m beta x)^{-1/2} +! +! sig : basal to frontal area; about 1 +! m : parameter less than 1; about 0.5 +! beta : a ratio of drag coef.; about 90. ; changed to 200 (recommendation by Y. Shao based on data by Gillies et al.) +! + real(8) :: xc + real(8), intent(in) :: x + real(8), intent(out) :: r + real(8), parameter :: sig=1., m=0.5, beta=200. +! + xc = 1./(sig*m) + IF (x.ge.xc) THEN + r = 999. ! Full covered surface + ELSE + r = dsqrt(1.-sig*m*x)*dsqrt(1.+m*beta*x) + ENDIF +! + END subroutine r_c + + + +END MODULE qf03 diff --git a/wrfv2_fire/chem/module_soilpsd.F b/wrfv2_fire/chem/module_soilpsd.F index d3e1bed5..f36f6870 100644 --- a/wrfv2_fire/chem/module_soilpsd.F +++ b/wrfv2_fire/chem/module_soilpsd.F @@ -1,64 +1,151 @@ MODULE module_soilpsd +! Soil particle-size distributions, based on data collected by G.H. McTainsh (g.mctainsh@griffith.edu.au) and collegues, +! Griffith University, Australia. The data has been processed by Harry Butler (harry.butler@usq.edu.au), +! University of Southern Queensland, Australia, and Martina Klose (mklose@uni-koeln.de), University of Cologne, Germany. integer, parameter :: mmax=4 - real(8), dimension(3, mmax) :: csandm ! Coefs for sand minimally dispersed - data csandm /0., 0., 0., & - & 0.0329, 4.3733, 0.8590, & - & 0.9671, 5.7689, 0.2526, & - & 0., 0., 0. / + real(8), dimension(3, mmax) :: csandm ! Coefs for minimally dispersed, Simpson Desert, sand + data csandm / 0.0287, 3.6153, 0.2775, & + & 0.2811, 4.9918, 0.3023, & + & 0.0516, 3.9315, 0.1417, & + & 0.6387, 4.7173, 0.2432 / ! - real(8), dimension(3, mmax) :: cloamm ! Coefs for loam minimally dispersed - data cloamm /0.1114, 4.3565, 0.4257, & - & 0.4554, 5.1674, 0.3824, & - & 0.4331, 5.4092, 1.0000, & - & 0., 0., 0. / + real(8), dimension(3, mmax) :: closam ! Coefs for minimally dispersed, Eulo, loamy sand (orig sandy loam) + data closam / 0.5000, 6.0674, 0.4039, & + & 0.1997, 4.3282, 0.3998, & + & 0.2191, 5.2793, 0.3488, & + & 0.0812, 6.6426, 0.2216 / ! - real(8), dimension(3, mmax) :: csloam ! Coefs for sandy clay loam minimally dispersed, very dusty - data csloam /0.0722, 2.2675, 1.0000, & - & 0.6266, 4.9654, 0.3496, & - & 0.3012, 5.5819, 0.5893, & - & 0., 0., 0. / + real(8), dimension(3, mmax) :: csalom ! Coefs for minimally dispersed, Tambo, sandy loam + data csalom / 0.0240, 6.6566, 0.1000, & + & 0.0536, 6.0663, 0.1227, & + & 0.3184, 5.1840, 0.7462, & + & 0.6039, 6.0685, 0.4063 / +! + real(8), dimension(3, mmax) :: csilom ! Coefs for minimally dispersed, Thargominda, silt loam (orig loam) + data csilom / 0.0278, 5.2068, 0.1921, & + & 0.5000, 4.3275, 0.4544, & + & 0.3054, 3.5848, 1.0721, & + & 0.1669, 4.1432, 0.1877 / +! + real(8), dimension(3, mmax) :: csiltm ! Coefs for minimally dispersed, not available, use same as for silt loam + data csiltm / 0.0278, 5.2068, 0.1921, & + & 0.5000, 4.3275, 0.4544, & + & 0.3054, 3.5848, 1.0721, & + & 0.1669, 4.1432, 0.1877 / +! + real(8), dimension(3, mmax) :: cloamm ! Coefs for minimally dispersed, Wellington, loam + data cloamm / 0.0695, 6.9010, 0.1000, & + & 0.1047, 6.6666, 0.1614, & + & 0.5000, 5.5720, 0.7295, & + & 0.3258, 6.3005, 0.3549 / ! - real(8), dimension(3, mmax) :: cclaym ! Coefs for clay minimally dispersed - data cclaym /0.3902, 3.5542, 1.0000, & - & 0.2813, 4.2239, 0.2507, & - & 0.3286, 5.1638, 0.4632, & - & 0., 0., 0. / + real(8), dimension(3, mmax) :: csclom ! Coefs for minimally dispersed, Yandama, sandy clay loam (orig clay loam) + data csclom / 0.4999, 5.1720, 0.3064, & + & 0.2490, 4.6158, 0.2783, & + & 0.0139, 4.9110, 0.1000, & + & 0.2372, 5.0185, 0.9259 / +! + real(8), dimension(3, mmax) :: csiclm ! Coefs for minimally dispersed, Yandama (McDonald et al., 1990), silty clay loam, not normalized + data csiclm / 1.2597, 4.7986, 0.3751, & + & 0.8107, 5.2549, 0.3047, & + & 0.4482, 5.1246, 1.2550, & + & 0., 0., 0. / +! + real(8), dimension(3, mmax) :: ccloam ! Coefs for minimally dispersed, Manilla, clay loam + data ccloam / 0.1842, 6.3110, 0.2071, & + & 0.4243, 6.0792, 0.4049, & + & 0.3273, 5.5946, 0.7726, & + & 0.0642, 6.5793, 0.1000 / ! - real(8), dimension(3, mmax) :: csandf ! Coefs for sand fully dispersed - data csandf /0., 0., 0., & - & 0.0338, 0.6931, 1.0000, & - & 0.9662, 5.6300, 0.2542, & - & 0., 0., 0. / + real(8), dimension(3, mmax) :: csaclm ! Coefs for minimally dispersed, Thargomindah (McDonald et al., 1990), sandy clay, not normalized + data csaclm / 0.3124, 4.1426, 0.1717, & + & 0.9564, 3.9501, 1.7750, & + & 1.0340, 4.3088, 0.4340, & + & 0., 0., 0. / +! + real(8), dimension(3, mmax) :: csilcm ! Coefs for minimally dispersed, Cooper Floodplain - Windorah, silty clay (orig light clay) + data csilcm / 0.2709, 4.9160, 0.1971, & + & 0.0631, 4.5807, 0.1635, & + & 0.1350, 3.8960, 0.8092, & + & 0.5310, 4.5301, 0.4887 / +! + real(8), dimension(3, mmax) :: cclaym ! Coefs for minimally dispersed, Walgett, clay + data cclaym / 0.2408, 4.5855, 0.6331, & + & 0.0594, 3.3126, 1.1665, & + & 0.0273, 5.3894, 0.1000, & + & 0.6725, 5.3148, 0.3924 / ! - real(8), dimension(3, mmax) :: cloamf ! Coefs for loam fully dispersed - data cloamf /0.5844, 4.6079, 0.6141, & - & 0.3304, 5.2050, 0.2897, & - & 0.0522, 7.0553, 1.0000, & - & 0.0330, 0.6931, 1.0000 / + real(8), dimension(3, mmax) :: csandf ! Coefs for fully dispersed, Simpson Desert, sand + data csandf / 0.0231, 3.6724, 0.2341, & + & 0.0362, 3.9598, 0.1257, & + & 0.2628, 4.9933, 0.2986, & + & 0.6779, 4.7374, 0.2498 / ! - real(8), dimension(3, mmax) :: csloaf ! Coefs for sandy clay loam fully dispersed - data csloaf /0.2344, 1.8079, 0.6141, & - & 0.3634, 4.2050, 0.2897, & - & 0.4022, 5.6553, 1.0000, & - & 0., 0., 0. / + real(8), dimension(3, mmax) :: closaf ! Coefs for fully dispersed, Eulo, loamy sand (orig sandy loam) + data closaf / 0.1354, 5.5976, 0.4288, & + & 0.1073, 2.3499, 1.0898, & + & 0.1692, 4.0550, 0.2113, & + & 0.5880, 4.1982, 0.7748 / ! - real(8), dimension(3, mmax) :: cclayf ! Coefs for clay fully dispersed - data cclayf /0.0872, 0.6931, 1.0000, & - & 0.4464, 3.9323, 0.9181, & - & 0.4665, 5.4486, 0.3916, & - & 0., 0., 0. / -! - real(8), dimension(3, mmax) :: cjadef ! Coefs for fully dispersed, JADE site, loam sand - data cjadef /0.228, 5.42, 0.350, & - & 0.277, 4.86, 0.595, & - & 0.295, 3.08, 1.050, & - & 0.200, 1.30, 1.400 / -! - real(8), dimension(3, mmax) :: cjadem ! Coefs for minimally dispersed, JADE site, loam sand - data cjadem /0.35, 5.40, 0.345, & - & 0.32, 4.63, 0.490, & - & 0.23, 4.10, 0.650, & - & 0.10, 2.75, 0.950 / + real(8), dimension(3, mmax) :: csalof ! Coefs for fully dispersed, Tambo, sandy loam + data csalof / 0.0115, 5.3900, 0.1141, & + & 0.3043, 4.6980, 1.0132, & + & 0.0840, 6.6115, 0.1339, & + & 0.6002, 6.0494, 0.3178 / +! + real(8), dimension(3, mmax) :: csilof ! Coefs for fully dispersed, Thargominda, silt loam (orig loam) + data csilof / 0.1816, 3.1175, 1.0169, & + & 0.4454, 4.3491, 0.6154, & + & 0.0568, 4.1250, 0.1000, & + & 0.3162, 4.1594, 0.3017 / + ! + real(8), dimension(3, mmax) :: csiltf ! Coefs for fully dispersed, not available, use same as for silt loam + data csiltf / 0.1816, 3.1175, 1.0169, & + & 0.4454, 4.3491, 0.6154, & + & 0.0568, 4.1250, 0.1000, & + & 0.3162, 4.1594, 0.3017 / +! + real(8), dimension(3, mmax) :: cloamf ! Coefs for fully dispersed, Wellington, loam + data cloamf / 0.0378, 5.0205, 0.5601, & + & 0.0511, 0.5580, 0.3886, & + & 0.4003, 1.7677, 0.6877, & + & 0.5108, 2.9973, 0.5489 / ! + real(8), dimension(3, mmax) :: csclof ! Coefs for fully dispersed, Yandama, sandy clay loam (orig clay loam) + data csclof / 0.1364, 3.3869, 1.3277, & + & 0.0642, 6.1715, 0.3463, & + & 0.0767, 4.4147, 0.2243, & + & 0.7227, 4.9219, 0.4983 / +! + real(8), dimension(3, mmax) :: csiclf ! Coefs for fully dispersed, Yandama (McDonald et al., 1990), silty clay loam, not normalized + data csiclf / 0.5844, 4.6079, 0.6141, & + & 0.3304, 5.2050, 0.2897, & + & 0.0522, 7.0553, 1.0000, & + & 0.0330, 0.6931, 1.0000 / +! + real(8), dimension(3, mmax) :: ccloaf ! Coefs for fully dispersed, Manilla, clay loam + data ccloaf / 0.3988, 2.0568, 0.9444, & + & 0.5000, 3.5758, 0.6679, & + & 0.0145, 4.4626, 0.1000, & + & 0.0867, 5.0406, 0.4590 / +! + real(8), dimension(3, mmax) :: csaclf ! Coefs for fully dispersed, Thargomindah (McDonald et al., 1990), sandy clay, not normalized + data csaclf / 1.1285, 4.2288, 0.4296, & + & 0.7275, 3.8558, 1.2898, & + & 0.2438, 4.1222, 0.1379, & + & 0., 0., 0. / +! + real(8), dimension(3, mmax) :: csilcf ! Coefs for fully dispersed, Cooper Floodplain - Windorah, silt clay (orig light clay) + data csilcf / 0.3927, 3.6159, 0.5702, & + & 0.1160, 1.3131, 0.2704, & + & 0.4588, 2.3768, 0.6913, & + & 0.0325, 1.0150, 0.1154 / +! + real(8), dimension(3, mmax) :: cclayf ! Coefs for fully dispersed, Walgett, clay + data cclayf / 0.5000, 3.0166, 0.7156, & + & 0.1124, 0.6297, 0.4159, & + & 0.3698, 1.5791, 0.6059, & + & 0.0178, 3.8284, 0.1509 / +! END MODULE module_soilpsd diff --git a/wrfv2_fire/chem/module_sorgam_aqchem.F b/wrfv2_fire/chem/module_sorgam_aqchem.F index 004e2e6a..4622842d 100644 --- a/wrfv2_fire/chem/module_sorgam_aqchem.F +++ b/wrfv2_fire/chem/module_sorgam_aqchem.F @@ -169,9 +169,10 @@ subroutine sorgam_aqchem_driver( & p_mepx, & p_pacd, & CB05_SORG_AQ_KPP - - use module_data_sorgam, only: cw_phase, nphase_aer - + +!!! TUCCELLA + !use module_data_sorgam, only: cw_phase, nphase_aer + implicit none ! @@ -249,6 +250,9 @@ subroutine sorgam_aqchem_driver( & real :: alfa2 ! Scavenging coeffficient for Aitken aerosol surface area real :: alfa3 ! Scavenging coeffficient for Aitken aerosol mass + !!!! TUCCELLA + ! For cw phase + integer :: cw_phase, nphase_aer ! ! Other local variables ! @@ -256,8 +260,17 @@ subroutine sorgam_aqchem_driver( & integer :: it, jt, kt real :: conv_factor - + +!!! TUCCELLA ! Check that cw_phase is active + + !!! Get cw_phase and nphase_aer + IF (config_flags%chem_opt==109) THEN + CALL get_cwphase_soa_vbs(config_flags,cw_phase,nphase_aer) + ELSE + CALL get_cwphase_sorgam(config_flags,cw_phase,nphase_aer) + END IF + if ((cw_phase .le. 0) .or. (cw_phase .gt. nphase_aer)) then write(*,*) '*** module_sorgam_aqchem - cw_phase not active' return @@ -479,5 +492,40 @@ subroutine sorgam_aqchem_driver( & enddo end subroutine sorgam_aqchem_driver - + +!!! TUCCELLA + subroutine get_cwphase_sorgam(config_flags,cw,nphase) + + use module_data_sorgam, only: cw_phase, nphase_aer + use module_configure, only: grid_config_rec_type + + implicit none + + ! Configuration and control parameters: + type(grid_config_rec_type), intent(in) :: config_flags + ! Out paramaeters for cw_phase + integer, intent(out) :: cw,nphase + + cw = cw_phase + nphase = nphase_aer + + end subroutine get_cwphase_sorgam + + + subroutine get_cwphase_soa_vbs(config_flags,cw,nphase) + + use module_data_soa_vbs, only: cw_phase, nphase_aer + use module_configure, only: grid_config_rec_type + + implicit none + + ! Configuration and control parameters: + type(grid_config_rec_type), intent(in) :: config_flags + ! Out paramaeters for cw_phase + integer, intent(out) :: cw,nphase + + cw = cw_phase + nphase = nphase_aer + + end subroutine get_cwphase_soa_vbs end module module_sorgam_aqchem diff --git a/wrfv2_fire/chem/module_uoc_dust.F b/wrfv2_fire/chem/module_uoc_dust.F index 18f4c967..5bf11371 100644 --- a/wrfv2_fire/chem/module_uoc_dust.F +++ b/wrfv2_fire/chem/module_uoc_dust.F @@ -1,333 +1,357 @@ -MODULE uoc_dust -!---------------------------------------------------------------------------- -! Dust emission module developed at the University of Cologne, Germany. -! Dust emission schemes and framework developed by Y Shao (yshao@uni-koeln.de) -! Implementation into WRF and modifications by JY Kang (jy.kang@kiaps.org), -! M Klose (mklose@uni-koeln.de), and CL Wu (wuchenglai@mail.iap.ac.cn). -! -! For references and available schemes, see module_qf03.F -! Martina Klose, 29 May 2013 -!---------------------------------------------------------------------------- - USE module_data_gocart_dust - USE qf03 - USE module_soilpsd - USE module_sf_noahlsm, ONLY:DRYSMC - USE NOAHMP_PARAMETERS, ONLY: DRYSMC_nmp => SMCDRY - USE module_sf_ruclsm, ONLY:DRYSMC_ruc => DRYSMC - - CONTAINS - subroutine uoc_dust_driver(ktau,dt,config_flags, & - chem,rho_phy,dz8w,smois,ust, & - isltyp,vegfra,g,emis_dust, & - ust_t_min, imod, rough_cor, smois_cor, & - soil_top_cat, erod, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) - USE module_configure - USE module_state_description - USE module_model_constants, ONLY: mwdry - IMPLICIT NONE - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - INTEGER, INTENT(IN ) :: ktau, imod, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte - INTEGER, DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: isltyp - REAL, DIMENSION(ims:ime,1:config_flags%num_soil_cat,jms:jme) , & - INTENT(IN ) :: soil_top_cat - REAL, DIMENSION( ims:ime , jms:jme, 3 ) , & - INTENT(IN ) :: erod - -! ust_t_min is calculated value from qf03 - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(INOUT) :: ust_t_min, & - rough_cor, & - smois_cor - REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & - INTENT(INOUT ) :: chem - REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL, & - INTENT(INOUT ) :: emis_dust - REAL, DIMENSION( ims:ime, config_flags%num_soil_layers, jms:jme ) , & - INTENT(INOUT) :: smois - REAL, DIMENSION( ims:ime , jms:jme ) , & - INTENT(IN ) :: ust, & - vegfra - REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & - INTENT(IN ) :: dz8w, & - rho_phy - - REAL, INTENT(IN ) :: dt,g -! -! local variables -! - integer, parameter :: imax=100 ! No. of particle size intervals for psd - integer, parameter :: jmax=4 ! No. of log-normal distributions for constructing psd - integer, parameter :: stype=4 ! No. of soil texture classes - real(8), dimension(0:imax) :: d0 - real(8), dimension(imax) :: dd - real(8), dimension(imax) :: psdm, dpsdm, ppsdm - real(8), dimension(imax) :: psdf, dpsdf, ppsdf - real(8), dimension(imax,stype) :: psd_m, dpsd_m, ppsd_m - real(8), dimension(imax,stype) :: psd_f, dpsd_f, ppsd_f - real(8), parameter :: dcut=20.d0 ! dust cutoff particle size - - integer :: nmx,i,j,k,p,idst - real :: ust_grid, airden, dz_lowest - real, DIMENSION (5) :: tc,bems - real*8 :: gwet, cf - real*8 conver,converi - real*8 ust_min, rough_cor_in, smois_cor_in - real, dimension(16) :: soilc - real tot_soilc - integer domsoilc - integer cc - character*1 :: tmp - real, dimension(12) :: thr - data thr/0.001, 0.003, 0.037, 0.061, 0.072, 0.049, 0.084, 0.110, 0.095, 0.126, 0.141, 0.156/ -! Shao's air-dry soil moisture [m3/m3] in WRF order - -!*************************************************************************** -! initialization - - conver=1.e-9 - converi=1.e9 - - nmx=5 !size bin - k=kts !in the bottom layer - -! calculate soil-psd once for all 4 types -! initialize - psd_m(:,:) = 0. - psd_f(:,:) = 0. - dpsd_m(:,:) = 0. - dpsd_f(:,:) = 0. - ppsd_m(:,:) = 0. - ppsd_f(:,:) = 0. - - do p = 1, 4 - if (p.eq.1) then ! sand - call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csandm, jmax) - call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csandf, jmax) - psd_m(:,1) = psdm(:) - psd_f(:,1) = psdf(:) - dpsd_m(:,1) = dpsdm(:) - dpsd_f(:,1) = dpsdf(:) - ppsd_m(:,1) = ppsdm(:) - ppsd_f(:,1) = ppsdf(:) - elseif (p.eq.2) then ! sandy clay loam - call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csloam, jmax) - call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csloaf, jmax) - psd_m(:,2) = psdm(:) - psd_f(:,2) = psdf(:) - dpsd_m(:,2) = dpsdm(:) - dpsd_f(:,2) = dpsdf(:) - ppsd_m(:,2) = ppsdm(:) - ppsd_f(:,2) = ppsdf(:) - elseif (p.eq.3) then ! loam - call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, cloamm, jmax) - call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, cloamf, jmax) - psd_m(:,3) = psdm(:) - psd_f(:,3) = psdf(:) - dpsd_m(:,3) = dpsdm(:) - dpsd_f(:,3) = dpsdf(:) - ppsd_m(:,3) = ppsdm(:) - ppsd_f(:,3) = ppsdf(:) - else ! clay - call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, cclaym, jmax) - call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, cclayf, jmax) - psd_m(:,4) = psdm(:) - psd_f(:,4) = psdf(:) - dpsd_m(:,4) = dpsdm(:) - dpsd_f(:,4) = dpsdf(:) - ppsd_m(:,4) = ppsdm(:) - ppsd_f(:,4) = ppsdf(:) - endif - enddo -! -! Before calculating dust emission, some parameters should be set. - j = 0 -1 j = j+1 - if ( dd(j) .le. dcut ) then - idst = j - goto 1 - endif -! - do j=jts,jte - do i=its,ite - -! do dust over dust source area only - if (sum(erod(i,j,:)).gt.0.) then !use fraction of erodible surface area as dust source indicator - tc(1)=chem(i,kts,j,p_dust_1)*conver ![kg/kg-dryair] - tc(2)=chem(i,kts,j,p_dust_2)*conver - tc(3)=chem(i,kts,j,p_dust_3)*conver - tc(4)=chem(i,kts,j,p_dust_4)*conver - tc(5)=chem(i,kts,j,p_dust_5)*conver - - ust_grid=ust(i,j) ! u* for one grid - -! delta z for the lowest layer is needed for unit conversion - dz_lowest = dz8w(i,1,j) - -! for soil moisture using volumetric soil moisture (smois) - gwet=smois(i,1,j) - airden=rho_phy(i,kts,j) ![kg/m3] - cf=vegfra(i,j) ! in [%] - -! initialization - tot_soilc=0. - do cc = 1, 12 - soilc(cc) = 0. - enddo - -! print*, texture(i,j) - do cc = 1, 12 - soilc(cc) = soil_top_cat(i,cc,j) - tot_soilc = tot_soilc + soilc(cc) - enddo - -! domsoilc = texture(i,j) - domsoilc = isltyp(i,j) - if ( config_flags%sf_surface_physics .eq. 3 ) then - DRYSMC = DRYSMC_ruc ! RUC - elseif ( config_flags%sf_surface_physics .eq. 4 ) then - DRYSMC = DRYSMC_nmp ! Noah MP - elseif ( config_flags%sf_surface_physics .eq. 1 .or. & - & config_flags%sf_surface_physics .eq. 5 .or. & - & config_flags%sf_surface_physics .eq. 7 .or. & - & config_flags%sf_surface_physics .eq. 8 .or. & - & config_flags%sf_surface_physics .eq. 0) then - DRYSMC(1:12) = thr - CALL wrf_message('UoC dust: DRYSMC reset for dust emission') - endif -!------------------------------------------------------------------------ - - call qf03_driver( nmx, idst, g, airden, dt, & - ust_grid, gwet, cf, ust_min, imod, dz_lowest, & - soilc, tot_soilc, domsoilc, & - tc, bems, rough_cor_in, smois_cor_in, DRYSMC(1:12), & - d0, dd, psd_m, dpsd_m, ppsd_m, psd_f, dpsd_f, ppsd_f, imax, stype) - - chem(i,kts,j,p_dust_1)=tc(1)*converi ![ug/kg-dryair] - chem(i,kts,j,p_dust_2)=tc(2)*converi - chem(i,kts,j,p_dust_3)=tc(3)*converi - chem(i,kts,j,p_dust_4)=tc(4)*converi - chem(i,kts,j,p_dust_5)=tc(5)*converi -! for output diagnostics - emis_dust(i,1,j,p_edust1)=bems(1)*converi - emis_dust(i,1,j,p_edust2)=bems(2)*converi - emis_dust(i,1,j,p_edust3)=bems(3)*converi - emis_dust(i,1,j,p_edust4)=bems(4)*converi - emis_dust(i,1,j,p_edust5)=bems(5)*converi ![kg/m2/s] -> [ug/m2/s] - else ! no dust source - emis_dust(i,1,j,p_edust1)=0. - emis_dust(i,1,j,p_edust2)=0. - emis_dust(i,1,j,p_edust3)=0. - emis_dust(i,1,j,p_edust4)=0. - emis_dust(i,1,j,p_edust5)=0. - ust_min = -9999.d0 - rough_cor_in = 1.d0 - smois_cor_in = 1.d0 - endif !dsource/erod - - ust_t_min(i,j) = ust_min - rough_cor(i,j) = rough_cor_in - smois_cor(i,j) = smois_cor_in - enddo ! i loop - enddo ! j loop -! - -end subroutine UoC_dust_driver - -!***************************************************************************** - subroutine psd_create(d, dm, psd, dpsd, ppsd, imax, cmtrix, jmax) -! -!---------------------------------------------------------------------------- -! Yaping Shao, 13 June 2000 -! -! - Generate particle size distribution density function -! (both minimally-dispersed and fully-dispersed as the -! sum of four log-normal distributions. -! -! d(0,imax): output, particle size at 0, 1, 2, ..., imax points [um] -! dm(imax): output, particle size at middle of 0-1, 1-2, etc [um] -! psd(imax): output, particle size distribution density at dm [um^-1] -! dpsd(imax): output, Delta P for sections 0-1, 1-2, etc. [ ] -! ppsd(imax): output, P for sections 0-1, 1-2, etc. [ ] -! imax: input, length dm, psd, dpsdm, ppsd, etc. -! cmtrix: jmaxx coefficient matrix -! e.g. -! w1 = cmtrix(1, 1): weight for first log-normal distribution -! dln1 = cmtrix(2, 1): mean log-particle size of first log-normal distribution -! sig1 = cmtrix(3, 1): sigma of log-particle size for first log-normal distribution -! etc. -! careful with the dimension of dln and sig -!---------------------------------------------------------------------------- -! - integer :: i, j, imax, jmax - real(8), dimension(3, jmax) :: cmtrix - real(8) :: d(0:imax), dm(imax) - real(8) :: psd(imax), dpsd(imax), ppsd(imax) ! for p(d), Delta P(d) and P(d) - real(8) :: p, pp, w, dln, sig - real(8) :: cn - real(8), parameter :: eps=1.d-7 - real(8), parameter :: dref=1000.d0 - real(8) :: fu, fd, phi -! - cn = 1.d0/dsqrt(2.d0*3.14159d0) -! -! initialise psd, dpsd, ppsd -! - psd = 0.d0 - dpsd = 0.d0 - ppsd = 0.d0 -! -! Estimate d using phi scale. phi varies between from 9 to -1 -! with increment 0.1. Reference particle size d0 = 1000 um -! - fu = 10.d0 - fd = -1.d0 - do i = 0, imax - phi = fu - i*(fu-fd)/imax - d(i) = dref/2.d0**phi - enddo -! - do i = 1, imax - dm(i) = dexp( (dlog(d(i))+dlog(d(i-1)) )/2.d0 ) - - pp = 0.d0 - do j = 1, jmax - w = cmtrix(1, j) - dln = cmtrix(2, j) - sig = cmtrix(3, j) - if ( (w.gt.eps) .and. (sig.ne.0.) ) then - p = w*cn/sig*dexp( -(dlog(dm(i))-dln)**2/(2*sig**2) ) - else - p=0.d0 - endif - pp = pp + p - enddo -! - dpsd(i) = pp*( dlog(d(i)) - dlog(d(i-1)) ) ! Delta P over i - if (i.eq.1) then - ppsd(i) = 0.d0 + dpsd(i) ! P(d), with P(0) = 0 - else - ppsd(i) = ppsd(i-1) + dpsd(i) - endif - psd(i) = pp/dm(i) ! p(d), particle size distribution density - - enddo -! -! Renormalisation, in case ppsd(imax) is not 1 -! - dpsd = dpsd/ppsd(imax) - psd = psd/ppsd(imax) - ppsd = ppsd/ppsd(imax) - -! - end subroutine -!***************************************************************************** - -END MODULE uoc_dust +MODULE uoc_dust +!---------------------------------------------------------------------------- +! Dust emission module developed at the University of Cologne, Germany. +! Dust emission schemes and framework developed by Y Shao (yshao@uni-koeln.de) +! Implementation into WRF and modifications by JY Kang (jy.kang@kiaps.org), +! CL Wu (wuchenglai@mail.iap.ac.cn), and M Klose (mklose@uni-koeln.de). +! +! For references and available schemes, see module_qf03.F +! Martina Klose, 29 May 2013 +! +!---------------------------------------------------------------------------- + USE module_data_gocart_dust + USE qf03 + USE module_soilpsd + USE module_sf_noahlsm, ONLY:DRYSMC + USE NOAHMP_TABLES, ONLY: DRYSMC_nmp => SMCDRY_TABLE + USE module_sf_ruclsm, ONLY:DRYSMC_ruc => DRYSMC + + CONTAINS + subroutine uoc_dust_driver(ktau,dt,config_flags, & + chem,rho_phy,dz8w,smois,ust, & + isltyp,vegfra,g,emis_dust, & + ust_t_min, imod, rough_cor, smois_cor, & + soil_top_cat, erod, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + USE module_configure + USE module_state_description + USE module_model_constants, ONLY: mwdry + IMPLICIT NONE + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + INTEGER, INTENT(IN ) :: ktau, imod, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: isltyp + + REAL, DIMENSION(ims:ime,1:config_flags%num_soil_cat,jms:jme) , & + INTENT(IN ) :: soil_top_cat + + REAL, DIMENSION( ims:ime , jms:jme, 3 ) , & + INTENT(IN ) :: erod + +! ust_t_min is calculated value from qf03 + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: ust_t_min, & + rough_cor, & + smois_cor + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT ) :: chem + REAL, DIMENSION( ims:ime, 1, jms:jme,num_emis_dust),OPTIONAL, & + INTENT(INOUT ) :: emis_dust + REAL, DIMENSION( ims:ime, config_flags%num_soil_layers, jms:jme ) , & + INTENT(INOUT) :: smois + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: ust, & + vegfra + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN ) :: dz8w, & + rho_phy + + REAL, INTENT(IN ) :: dt,g +! +! local variables +! + integer, parameter :: imax=100 ! No. of particle size intervals for psd + integer, parameter :: jmax=4 ! No. of log-normal distributions for constructing psd + integer, parameter :: stype=12 ! No. of soil texture classes + real(8), dimension(0:imax) :: d0 + real(8), dimension(imax) :: dd + real(8), dimension(imax) :: psdm, dpsdm, ppsdm + real(8), dimension(imax) :: psdf, dpsdf, ppsdf + real(8), dimension(imax,stype) :: psd_m, dpsd_m, ppsd_m + real(8), dimension(imax,stype) :: psd_f, dpsd_f, ppsd_f + real(8), parameter :: dcut=20.d0 ! dust cutoff particle size + real(8), parameter :: rhop = 2650.d0 ! particle density [kg/m3] + + + integer :: i,j,k,p,idst + integer, parameter :: nmx = 5 ! No. of dust bins + real :: ust_grid, airden, dz_lowest, smc + real, dimension(nmx):: tc, bems + real(8) :: gwet, cf + real(8) :: conver,converi + real(8) :: ust_min, rough_cor_in, smois_cor_in + real, dimension(16) :: soilc + real :: tot_soilc + integer :: domsoilc + integer :: cc +! + real(8) :: ustart0_out, lambda, sigma + real(8), dimension(imax) :: ustart + real, dimension(12) :: thr + data thr/0.001, 0.003, 0.037, 0.061, 0.072, 0.049, 0.084, 0.110, 0.095, 0.126, 0.141, 0.156/ + +! character*4, dimension(12):: s_type +! data s_type /'sand', 'losa', 'salo', 'silo', 'silt', 'loam', 'sclo', 'sicl', 'cloa', & +! & 'sacl', 'silc', 'clay'/ +! saturation soil moisture from SOILPARM.TBL +!*************************************************************************** +! initialization + + conver=1.e-9 + converi=1.e9 + + k=kts !in the bottom layer + +! calculate soil-psd once for all 12 types +! initialize + psd_m(:,:) = 0. + psd_f(:,:) = 0. + dpsd_m(:,:) = 0. + dpsd_f(:,:) = 0. + ppsd_m(:,:) = 0. + ppsd_f(:,:) = 0. + + do p = 1, stype +! write(6,*) p + if (p.eq.1) then ! sand + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csandm, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csandf, jmax) + elseif (p.eq.2) then ! loamy sand + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, closam, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, closaf, jmax) + elseif (p.eq.3) then ! sandy loam + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csalom, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csalof, jmax) + elseif (p.eq.4) then ! silt loam + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csilom, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csilof, jmax) + elseif (p.eq.5) then ! silt + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csiltm, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csiltf, jmax) + elseif (p.eq.6) then ! loam + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, cloamm, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, cloamf, jmax) + elseif (p.eq.7) then ! sandy clay loam + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csclom, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csclof, jmax) + elseif (p.eq.8) then ! silty clay loam + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csiclm, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csiclf, jmax) + elseif (p.eq.9) then ! clay loam + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, ccloam, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, ccloaf, jmax) + elseif (p.eq.10) then ! sandy clay + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csaclm, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csaclf, jmax) + elseif (p.eq.11) then ! silty clay + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, csilcm, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, csilcf, jmax) + elseif (p.eq.12) then ! clay + call psd_create(d0, dd, psdm, dpsdm, ppsdm, imax, cclaym, jmax) + call psd_create(d0, dd, psdf, dpsdf, ppsdf, imax, cclayf, jmax) + endif + psd_m(:,p) = psdm(:) + psd_f(:,p) = psdf(:) + dpsd_m(:,p) = dpsdm(:) + dpsd_f(:,p) = dpsdf(:) + ppsd_m(:,p) = ppsdm(:) + ppsd_f(:,p) = ppsdf(:) + enddo +! stop +! +! Before calculating dust emission, some parameters should be set. + j = 0 +1 j = j+1 + if ( dd(j) .le. dcut ) then + idst = j + goto 1 + endif +! + do j=jts,jte + do i=its,ite + +! do dust over dust source area only + if (sum(erod(i,j,:)).gt.0.) then !use fraction of erodible surface area as dust source indicator + tc(1)=chem(i,kts,j,p_dust_1)*conver ![kg/kg-dryair] + tc(2)=chem(i,kts,j,p_dust_2)*conver + tc(3)=chem(i,kts,j,p_dust_3)*conver + tc(4)=chem(i,kts,j,p_dust_4)*conver + tc(5)=chem(i,kts,j,p_dust_5)*conver + + ust_grid=ust(i,j) ! u* for one grid + +! delta z for the lowest layer is needed for unit conversion + dz_lowest = dz8w(i,1,j) + +! for soil moisture using volumetric soil moisture (smois) + if (smois(i,1,j).gt.1.) then + smois(i,1,j) = 1. + CALL wrf_message('UoC CTDE WARNING: vol. soil moisture > 1, reset') + endif + + gwet=smois(i,1,j) + airden=rho_phy(i,kts,j) ![kg/m3] + cf=vegfra(i,j) ! in [%] + cf = cf/100.d0 ! fraction + +! initialization + tot_soilc=0. + soilc = 0. + + do cc = 1, 12 + soilc(cc) = soil_top_cat(i,cc,j) + tot_soilc = tot_soilc + soilc(cc) + enddo +! + domsoilc = isltyp(i,j) + if ( config_flags%sf_surface_physics .eq. 3 ) then + DRYSMC = DRYSMC_ruc + elseif ( config_flags%sf_surface_physics .eq. 4 ) then + DRYSMC = DRYSMC_nmp + elseif ( config_flags%sf_surface_physics .eq. 1 .or. & + & config_flags%sf_surface_physics .eq. 5 .or. & + & config_flags%sf_surface_physics .eq. 7 .or. & + & config_flags%sf_surface_physics .eq. 8 .or. & + & config_flags%sf_surface_physics .eq. 0) then + DRYSMC(1:12) = thr + CALL wrf_message('UoC dust: DRYSMC reset for dust emission') + endif +!------------------------------------------------------------------------ + call qf03_driver( nmx, idst, g, rhop, airden, dt, & + ust_grid, gwet, cf, ust_min, imod, dz_lowest, & + soilc, tot_soilc, domsoilc, & + tc, bems, rough_cor_in, smois_cor_in, DRYSMC(1:12), & + d0, dd, psd_m, dpsd_m, ppsd_m, psd_f, dpsd_f, ppsd_f, imax, stype) + +! + chem(i,kts,j,p_dust_1)=tc(1)*converi ![ug/kg-dryair] + chem(i,kts,j,p_dust_2)=tc(2)*converi + chem(i,kts,j,p_dust_3)=tc(3)*converi + chem(i,kts,j,p_dust_4)=tc(4)*converi + chem(i,kts,j,p_dust_5)=tc(5)*converi +! for output diagnostics + emis_dust(i,1,j,p_edust1)=bems(1)*converi + emis_dust(i,1,j,p_edust2)=bems(2)*converi + emis_dust(i,1,j,p_edust3)=bems(3)*converi + emis_dust(i,1,j,p_edust4)=bems(4)*converi + emis_dust(i,1,j,p_edust5)=bems(5)*converi ![kg/m2/s] -> [ug/m2/s] + + else ! no dust source + emis_dust(i,1,j,p_edust1)=0. + emis_dust(i,1,j,p_edust2)=0. + emis_dust(i,1,j,p_edust3)=0. + emis_dust(i,1,j,p_edust4)=0. + emis_dust(i,1,j,p_edust5)=0. +! if (imod .ne. 4) then + ust_min = -9999.d0 + rough_cor_in = 1.d0 + smois_cor_in = 1.d0 +! endif + endif !dsource/erod + + ust_t_min(i,j) = ust_min + rough_cor(i,j) = rough_cor_in + smois_cor(i,j) = smois_cor_in + enddo ! i loop + enddo ! j loop +! + +end subroutine UoC_dust_driver + + +!***************************************************************************** + subroutine psd_create(d, dm, psd, dpsd, ppsd, imax, cmtrix, jmax) +! +!---------------------------------------------------------------------------- +! Yaping Shao, 13 June 2000 +! +! - Generate particle size distribution density function +! (both minimally-dispersed and fully-dispersed as the +! sum of four log-normal distributions. +! +! d(0,imax): output, particle size at 0, 1, 2, ..., imax points [um] +! dm(imax): output, particle size at middle of 0-1, 1-2, etc [um] +! psd(imax): output, particle size distribution density at dm [um^-1] +! dpsd(imax): output, Delta P for sections 0-1, 1-2, etc. [ ] +! ppsd(imax): output, P for sections 0-1, 1-2, etc. [ ] +! imax: input, length dm, psd, dpsdm, ppsd, etc. +! cmtrix: jmaxx coefficient matrix +! e.g. +! w1 = cmtrix(1, 1): weight for first log-normal distribution +! dln1 = cmtrix(2, 1): mean log-particle size of first log-normal distribution +! sig1 = cmtrix(3, 1): sigma of log-particle size for first log-normal distribution +! etc. +! careful with the dimension of dln and sig +!---------------------------------------------------------------------------- +! + integer :: i, j, imax, jmax + real(8), dimension(3, jmax) :: cmtrix + real(8) :: d(0:imax), dm(imax) + real(8) :: psd(imax), dpsd(imax), ppsd(imax) ! for p(d), Delta P(d) and P(d) + real(8) :: p, pp, w, dln, sig + real(8) :: cn + real(8), parameter :: eps=1.d-7 + real(8), parameter :: dref=1000.d0 + real(8) :: fu, fd, phi +! + cn = 1.d0/dsqrt(2.d0*3.14159d0) +! +! initialise psd, dpsd, ppsd +! + psd = 0.d0 + dpsd = 0.d0 + ppsd = 0.d0 +! +! Estimate d using phi scale. phi varies between from 9 to -1 +! with increment 0.1. Reference particle size d0 = 1000 um +! + fu = 10.d0 + fd = -1.d0 + do i = 0, imax + phi = fu - i*(fu-fd)/imax + d(i) = dref/2.d0**phi + enddo +! + do i = 1, imax + dm(i) = (d(i)-d(i-1))/dlog(d(i)/d(i-1)) ! d = delta(d) / delta(log d), because del (log d) = (del d) / d ! mklose [17122014] + + pp = 0.d0 + do j = 1, jmax + w = cmtrix(1, j) + dln = cmtrix(2, j) + sig = cmtrix(3, j) + if ( (w.gt.eps) .and. (sig.ne.0.) ) then + p = w*cn/sig*dexp( -(dlog(dm(i))-dln)**2/(2*sig**2) ) + else + p=0.d0 + endif + pp = pp + p + enddo +! + dpsd(i) = pp*( dlog(d(i)) - dlog(d(i-1)) ) ! Delta P over i + if (i.eq.1) then + ppsd(i) = 0.d0 + dpsd(i) ! P(d), with P(0) = 0 + else + ppsd(i) = ppsd(i-1) + dpsd(i) + endif + psd(i) = pp/dm(i) ! p(d), particle size distribution density + + enddo +! +! Normalize in case ppsd(imax) is not 1 +! + dpsd = dpsd/ppsd(imax) + psd = psd/ppsd(imax) + ppsd = ppsd/ppsd(imax) + +! + end subroutine +!***************************************************************************** + +END MODULE uoc_dust diff --git a/wrfv2_fire/chem/module_uoc_dustwd.F b/wrfv2_fire/chem/module_uoc_dustwd.F new file mode 100755 index 00000000..f9598a27 --- /dev/null +++ b/wrfv2_fire/chem/module_uoc_dustwd.F @@ -0,0 +1,1228 @@ +MODULE module_uoc_dustwd + + +!---------------------------------------------------------------------------- +! Dust wet deposition module of the University of Cologne, Germany. +! Dust wet deposition scheme developed by E Jung (2004, PhD Thesis). +! Implementation into WRF and modifications by C Frick, 2014 (claudia.frick@uni-koeln.de) +! 2014-2015, updates and modifications, Martina Klose (mklose@uni-koeln.de) +!---------------------------------------------------------------------------- + +USE module_state_description ! num_chem, p_qr, ... +USE module_model_constants ! rhowater in kg/m3 +USE physconst ! rair, ... +USE module_data_gocart_dust + + CONTAINS + +subroutine uoc_dustwd_driver(precr,chem,p_phy,t_phy, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + dtstepc, & + dustwd_1, dustwd_2, & + dustwd_3, dustwd_4, & + dustwd_5, & + wetdep_1, wetdep_2, & + wetdep_3, wetdep_4, & + wetdep_5, & + dustwdload_1, dustwdload_2, & + dustwdload_3, dustwdload_4, & + dustwdload_5, & + alt, dz8w, epsilc ) + +IMPLICIT NONE + + INTEGER :: debug_level + CHARACTER*(100) :: text + +real :: dustold ! help variable + +integer :: d, i, j, k, l ! loop + +integer, parameter :: nbins=5 ! number of dust bins +integer, parameter :: nbinsa=5 ! number of dust bins +integer :: bins(nbinsa) ! dust bin numbers in chem +! real, dimension(nbins) :: dbin ! max. dimension of dust in the bin +! data dbin/2.5,5.,10.,20./ ! size cut diameter (um) - from qf03 +real, dimension(nbins) :: dbinm ! mean dimension of dust (um) in the bin +real, dimension(nbins) :: dbinmm ! mean dimension of dust (m) in the bin +! data dbinm/1.25,3.75,7.5,15./ ! mean size cut diameter (um) + +real :: conver9, converi9 ! transformation ug/kg-dryair to kg/kg-dryair and vice versa +real :: conver6, converi6 ! transformation um to m and vice versa + +real :: wt ! terminal fall velocity of dust in the bin (m/s) + +real :: rmin, rmax ! minimum/maximum raindrop diameter (m) + +integer, parameter :: nrbins=30 ! number of raindrop bins +real, dimension(nrbins) :: raind ! raindrop diameter in the middle of the raindrop bin (m) +real, dimension(nrbins+1) :: rend ! raindrop diameter at the end of the raindrop bin (m) +real, dimension(nrbins) :: dsd_rn ! raindrop size distribution +real, dimension(nrbins) :: vt ! raindrop terminal fall velocity (m/s) +real :: z ! help parameter for the determination of the rain bins + +real :: visca ! (dynamic) viscosity of air (g/cm s) +real :: tw, viscw ! temperature of water (C) and (dynamic) viscosity of water (g/cm s) + +real :: colece ! collection efficiency + +real :: scrate, scavn ! scavanging rate (1/s) +real :: delR, delv, rnflx, carea ! help parameter for the determination of the scavanging rate +real :: tair, pair ! current air temperature and pressure +real :: rhoair ! dry air density (kg/m3) - rhoair=pa/(Ra*Ta) + +INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde, & ! domain grid + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + +REAL, INTENT(IN) :: dtstepc, & ! time step (s) + epsilc + +REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(IN) :: precr +! precr - rain precipitation rate at all levels (kg/m2 s) + +REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(INOUT) :: chem +! chem(i,k,j,p_dust_?) - dust mixing ratio for bin np_dust_? (ug/kg-dryair) + +REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: p_phy, t_phy +! pressure (Pa) and temperature (K) + +real, dimension( ims:ime, kms:kme, jms:jme ) :: rnrate +! precipitation rate (mm/h) - rnrate=precr/3600 using rhowater (1l = 1kg) + +REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) :: & +dustwd_1, dustwd_2, dustwd_3, dustwd_4, dustwd_5 +! loss in dust mixing ratio due to wet deposition (ug/kg-dryair) (current time step) + +REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ) :: wdbins +! loss in dust mixing ratio due to wet deposition - help variable (ug/kg-dryair) + +REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: & +dustwdload_1, dustwdload_2, dustwdload_3, dustwdload_4, dustwdload_5 +! loss in dustload due to wet deposition (ug/m2) (current time step) + +REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: & +wetdep_1, wetdep_2, wetdep_3, wetdep_4, wetdep_5 +! loss in dust mixing ratio due to wet deposition in one coulmn for all size bins (ug/m2/s) + +REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: alt, dz8w +! altitude = 1/rhoair (kg/m3) & vertical grid-spacing delta-z / dz between full levels (m) + +den_dust(:) = 2650. + +dbinm(:) = 2.0d0*reff_dust(:) + +CALL get_wrf_debug_level(debug_level) + +rmin = 100.*1.e-6 +rmax = 5800.*1.e-6 ! minimum/maximum raindrop diameter (m) + + conver6 = 1.e-6 ! transformation um to m + converi6 = 1.e6 ! transformation m to um + + conver9 = 1.e-9 ! transformation ug/kg-dryair to kg/kg-dryair + converi9 = 1.e9 ! transformation kg/kg-dryair to ug/kg-dryair + +bins(1)=p_dust_1 ! dust bin number in chem +bins(2)=p_dust_2 ! dust bin number in chem +bins(3)=p_dust_3 ! dust bin number in chem +bins(4)=p_dust_4 ! dust bin number in chem +bins(5)=p_dust_5 ! dust bin number in chem + +dustwd_1(its:ite,kts:kte,jts:jte) = 0. +dustwd_2(its:ite,kts:kte,jts:jte) = 0. +dustwd_3(its:ite,kts:kte,jts:jte) = 0. +dustwd_4(its:ite,kts:kte,jts:jte) = 0. +dustwd_5(its:ite,kts:kte,jts:jte) = 0. +wetdep_1(its:ite,jts:jte) = 0. +wetdep_2(its:ite,jts:jte) = 0. +wetdep_3(its:ite,jts:jte) = 0. +wetdep_4(its:ite,jts:jte) = 0. +wetdep_5(its:ite,jts:jte) = 0. +dustwdload_1(its:ite,jts:jte) = 0. +dustwdload_2(its:ite,jts:jte) = 0. +dustwdload_3(its:ite,jts:jte) = 0. +dustwdload_4(its:ite,jts:jte) = 0. +dustwdload_5(its:ite,jts:jte) = 0. + +wdbins(its:ite,kts:kte,jts:jte,1)=dustwd_1(its:ite,kts:kte,jts:jte) ! dust dust loss in dust bin 1 +wdbins(its:ite,kts:kte,jts:jte,2)=dustwd_2(its:ite,kts:kte,jts:jte) ! dust dust loss in dust bin 2 +wdbins(its:ite,kts:kte,jts:jte,3)=dustwd_3(its:ite,kts:kte,jts:jte) ! dust dust loss in dust bin 3 +wdbins(its:ite,kts:kte,jts:jte,4)=dustwd_4(its:ite,kts:kte,jts:jte) ! dust dust loss in dust bin 4 +wdbins(its:ite,kts:kte,jts:jte,5)=dustwd_5(its:ite,kts:kte,jts:jte) ! dust dust loss in dust bin 5 + +rnrate = precr*3600. ! precipitation rate (mm/h) - rnrate=precr*3600 using rhowater + +dbinmm = dbinm*conver6 ! mean dimension of dust (m) in the bin + +tw=0 ! water temperature (C) +call dviscw(tw,viscw) ! determine water (dynamic) viscosity viscw + +! raindrop classes +do l = 1,nrbins+1 + z = alog10(rmin*converi6)+(alog10(rmax*converi6)-alog10(rmin*converi6))*real(l-1)/real(nrbins) + rend(l) = real(int(10.**z))*conver6 +enddo +do l = 1,nrbins + z = (alog10(rend(l)*converi6)+alog10(rend(l+1)*converi6))*0.5 + raind(l) = real(int(10.**z))*conver6 +enddo +! bin 1 bin 2 bin nrbin +! |--------------|------------!-------------!--------------| +! rend(1) rend(2) rend(3) rend(nrbin+1) +! raind(1) raind(2) raind(nrbin) + + +do j = jts, jte + do k = kts, kte + do i = its, ite + if ( precr(i,k,j).gt.0.) then ! precipitation exists + + call dsd_rain(rnrate(i,k,j),raind,nrbins,dsd_rn,3) ! 3 = Gamma Distribution + + tair=t_phy(i,k,j) + pair=p_phy(i,k,j) + rhoair = pair/(rair*tair) ! dry air density (kg/m3) - rhoair=pa/(Ra*Ta) + + call dvisca(tair,visca) + + do l = 1,nrbins + call fallv(raind(l),tair,pair,rhoair,visca,vt(l)) + enddo + + do d=1,nbins ! d = dust bins // dust classes + + if ( chem(i,k,j,bins(d)).gt.0.) then ! dust exists + + call w_t(wt,dbinmm(d),den_dust(d),rhoair) + + scrate=0. + scavn=0. + do l = 1,nrbins + ! calculate collection efficiency for each dust bin (already in this loop) by each rain bin (already in this loop) + call coleff(dbinmm(d),raind(l),den_dust(d),pair,tair,wt,vt(l),rhoair,visca,viscw,colece) + ! calculate scavanging rate + delR = (rend(l+1)-rend(l))*1.e2 ! cm + delv = (vt(l)-wt)*1.e2 ! cm/s + delv = amax1(delv,0.) + rnflx = dsd_rn(l)*delv + carea = pi*0.25*(raind(l)*1.e2+dbinmm(d)*1.e2)**2. + scavn = scavn+carea*colece*rnflx*delR + enddo + scrate = scavn + + dustold = chem(i,k,j,bins(d)) + chem(i,k,j,bins(d))=chem(i,k,j,bins(d))-max(0.,chem(i,k,j,bins(d))*scrate*dtstepc) + chem(i,k,j,bins(d))=max(chem(i,k,j,bins(d)),epsilc) + wdbins(i,k,j,d)=max(epsilc,dustold-chem(i,k,j,bins(d))) + + endif + enddo + +! mklose: fifths size bin is used now, hence the following is not needed: +! dustold = chem(i,k,j,bins(5)) +! chem(i,k,j,bins(5))=chem(i,k,j,bins(1))+chem(i,k,j,bins(2))+chem(i,k,j,bins(3))+chem(i,k,j,bins(4)) +! chem(i,k,j,bins(5))=max(chem(i,k,j,bins(5)),epsilc) +! wdbins(i,k,j,5)=max(epsilc,dustold-chem(i,k,j,bins(5))) + + endif + + enddo + enddo +enddo + +do j=jts,jte + do i=its,ite + do k=kts,kte + dustwdload_1(i,j)= max(epsilc,dustwdload_1(i,j) + wdbins(i,k,j,1)/alt(i,k,j) * dz8w(i,k,j)) + dustwdload_2(i,j)= max(epsilc,dustwdload_2(i,j) + wdbins(i,k,j,2)/alt(i,k,j) * dz8w(i,k,j)) + dustwdload_3(i,j)= max(epsilc,dustwdload_3(i,j) + wdbins(i,k,j,3)/alt(i,k,j) * dz8w(i,k,j)) + dustwdload_4(i,j)= max(epsilc,dustwdload_4(i,j) + wdbins(i,k,j,4)/alt(i,k,j) * dz8w(i,k,j)) + dustwdload_5(i,j)= max(epsilc,dustwdload_5(i,j) + wdbins(i,k,j,5)/alt(i,k,j) * dz8w(i,k,j)) + dustwd_1(i,k,j)=max(epsilc,wdbins(i,k,j,1)) + dustwd_2(i,k,j)=max(epsilc,wdbins(i,k,j,2)) + dustwd_3(i,k,j)=max(epsilc,wdbins(i,k,j,3)) + dustwd_4(i,k,j)=max(epsilc,wdbins(i,k,j,4)) + dustwd_5(i,k,j)=max(epsilc,wdbins(i,k,j,5)) + enddo + wetdep_1(i,j)= max(epsilc,wdbins(i,kts,j,1)/alt(i,kts,j) * dz8w(i,kts,j) / dtstepc) + wetdep_2(i,j)= max(epsilc,wdbins(i,kts,j,2)/alt(i,kts,j) * dz8w(i,kts,j) / dtstepc) + wetdep_3(i,j)= max(epsilc,wdbins(i,kts,j,3)/alt(i,kts,j) * dz8w(i,kts,j) / dtstepc) + wetdep_4(i,j)= max(epsilc,wdbins(i,kts,j,4)/alt(i,kts,j) * dz8w(i,kts,j) / dtstepc) + wetdep_5(i,j)= max(epsilc,wdbins(i,kts,j,5)/alt(i,kts,j) * dz8w(i,kts,j) / dtstepc) + enddo +enddo + + +end subroutine uoc_dustwd_driver + + +!======================================================================= +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +! - further updates M. Klose + + subroutine coleff(d,rain,prho,p,t,pv,rv,arho,visca,viscw,ecolec) + +! the program to calculate collection efficiency +! it is based on Slinn's empirical equation(1983) +! and theoretical collision efficiencies by +! Mason(1971), Klett and Davis (1973) and Beard and Ochs (1984) + +! input +! ===== + real, intent (in) :: d ! particle diameter in m + real, intent (in) :: rain ! raindrio diameter in m + real(8), intent (in) :: prho ! particle density in kg/m3 + real, intent (in) :: p ! atmosphere pressure in Pa + real, intent (in) :: t ! atmospheric temperature in K + real, intent (in) :: pv ! dust fall velocity in m/s + real, intent (in) :: rv ! rain fall velocity in m/s + real, intent (in) :: arho ! rair density in kg/m3 + real, intent (in) :: visca, viscw + +! output +! ====== + real, intent (out) :: ecolec + +! local variables +! =============== + real :: beta + real :: rmin + real(8) :: E_im,E_in,E_br + real :: dd, raind, rhop, pr, ta, vp, vs, rhoa + + CHARACTER*(100) :: text + integer :: debug_level + + data rhow/1/ ! raindrop density g/cm^3 + + CALL get_wrf_debug_level(debug_level) + + dd = d*1.e6 ! m to um + raind = rain*1.e6 ! m to um + rhop = prho*1.e-3 ! kg/m3 to g/cm3 + pr = p*1.e-2 ! Pa to mb or hPa + ta = t-273.15 ! K to C + vp = pv*1.e2 ! m/s to cm/s + vs = rv*1.e2 ! m/s to cm/s + rhoa = arho*1.e-3 ! kg/m3 to g/cm3 + + !======================================================================= + ecol=0 + + if(dd.le.2) then + call eslinn(raind,dd,pr,ta,rhop,vp,vs,rhoa,visca,viscw,ecol) + elseif(dd.gt.2 .and. dd.le.40) then + call eimpact(rhop,dd,raind,ecol) + elseif(dd.gt.40) then + ecol=0 + endif + + ecolec=ecol + +! return + end subroutine coleff +!**************************************************************** + + +!**************************************************************** +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +! - further updates M. Klose + +! xlambda is set fix instead of calculated - cfrick + + subroutine eslinn(dr,dp,pair,tair,rhop,vp,vs,rhoa,visca,viscw,eslin) + +! input +! ===== + real, intent (in) :: dp ! particle diameter in um + real, intent (in) :: dr ! raindrio diameter in um + real, intent (in) :: rhop ! particle density in g/cm3 + real, intent (in) :: pair ! atmosphere pressure in hPa + real, intent (in) :: tair ! atmospheric temperature in C + real, intent (in) :: vp ! dust fall velocity in cm/s + real, intent (in) :: vs ! rain fall velocity in cm/s + real, intent (in) :: rhoa ! rair density in g/cm3 + real, intent (in) :: visca, viscw + +! output +! ====== + real, intent (out) :: eslin + + real :: pi + + CHARACTER*(100) :: text + integer :: debug_level + + real :: gnarf, ren + + E_br=0 + E_in=0 + E_im=0 + + drc=dr*1.e-4 ! rain diameter in cm + dpc=dp*1.e-4 ! particle diameter in cm + + pr=pair + ta=tair + + pi=acos(-1.0) + xk=1.381e-16 ! Boltzmann constant (g cm2/s2)/K +! xd=3.75e-8 +! prs=pr*1.e+3 +! xlambda=xk*(ta+273.15)/(pi*sqrt(2.0)*prs*xd*xd) + + omg=viscw/visca + ren=0.5*drc*vs*rhoa/visca ! reynolds number + sstar=(1.2+alog(1+ren)/12)/(1+alog(1+ren)) ! S* + + xlambda=0.0651*1.e-4 ! mean free path of air in cm + cc=1+(2*xlambda/dpc)*(1.257+0.4*exp(-1.1*dpc/(2*xlambda))) ! Cunningham's correction for small particles + + tau=dpc**2*rhop*cc/(18*visca) + stn=2*tau*(vs-vp)/drc ! Stokes number + diff=(xk*(ta+273.15)*cc)/(3*pi*visca*dpc) + scn=visca/(diff*rhoa) ! Schmidt number + phi=dpc/drc + pen=ren*scn ! peclet number + +! Brownian diffusion + + E_br=4*(1+0.4*sqrt(ren)*scn**(1.0/3.0)+0.16*sqrt(ren)*sqrt(scn))/pen + +! Interception + + E_in=4*phi*(1/omg+(1+2*sqrt(ren))*phi) + +! Impaction + + if(stn.ge.sstar) then + E_im=((stn-sstar)/(stn-sstar+2.0/3.0))**1.5 + endif + + eslin=E_br+E_in + +! return + end subroutine eslinn +!======================================================================= + +!******************************************************************************* +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +! - further updates M. Klose + +subroutine eimpact(rhop,dp,raind,e_im) + + USE module_data_uoc_wd ! mklose [17122014]: renamed from we_ematrix + + integer, parameter :: lp=17, lr=17 + +! include 'we_ematrix.dat' + +! input +! ===== + real, intent (in) :: dp ! particle diameter in um + real, intent (in) :: raind ! raindrio diameter in um + real, intent (in) :: rhop ! particle density in g/cm3 + +! output +! ====== + real, intent (out) :: e_im + + real :: ee(lr) + real :: u(lr+1) + real :: enew(lr+1) + real :: e_r(lp) + real :: e_c(lp) + real :: f(lp) + real :: v(lp+1) + real :: dnew(lp+1) + + CHARACTER*(100) :: text + integer :: debug_level + + CALL get_wrf_debug_level(debug_level) + +! rr, rp : radiuse of raindrop, dust particle in um +! edata : dataset of composite collection efficiency +!=============================================================================== + + if(raind.lt.100 .or. raind.gt.6000) then + text = 'raindrop diameter out of range' + text=trim(trim(text)//" - ERROR - UoC dust wet deposition") + call wrf_debug (debug_level,text) + endif + if(dp.lt.2 .or. dp.gt.40) then + text = 'particle diameter out of range' + text=trim(trim(text)//" - ERROR - UoC dust wet deposition") + call wrf_debug (debug_level,text) + endif + +! radius of raindrop, dust particle + + rr=raind*0.5 + rp=dp*0.5 + + do i=1,lp +! calculate e_r(1:lp) corresponding to dustr(1:lp) for rr + + jj=0 + do j=1,lr + ee(j)=edatawd(i,j) + if(rr.ge.rainwd(j)) jj=j + enddo + if(jj.eq.0) then + text = 'error in raindrop radius' + text=trim(trim(text)//" - ERROR - UoC dust wet deposition") + call wrf_debug (debug_level,text) + endif + if(rr.gt.rainwd(jj)) then + lrp1=lr+1 + do l=1,jj + u(l)=rainwd(l) + enddo + u(jj+1)=rr + do l=jj+1,lr + u(l+1)=rainwd(l) + enddo + call intrpl(lr,log(rainwd),ee,lrp1,log(u),enew) + e_r(i)=enew(jj+1) + elseif(rr.eq.rainwd(jj)) then + e_r(i)=ee(jj) + endif + enddo + +! interpolate e_d for rp from e_r + + rmax=sqrt(1/rhop) + + do i=1,lp + if(dustwd(i).le.1) then + f(i)=1 + elseif(dustwd(i).gt.1 .and. dustwd(i).lt.3.98) then + f(i)=(1-rmax)*(dustwd(i)-3.98)**2/(1-3.98)**2+rmax + elseif(dustwd(i).ge.3.98) then + f(i)=rmax + endif + enddo + + do i=1,lp + e_c(i)=e_r(i)*f(i) + enddo + + ii=0 + e_d=0 + do i=1,lp + if(rp.ge.dustwd(i)) ii=i + enddo + if(ii.eq.0) then + text = 'wrong particle radius' + text=trim(trim(text)//" - ERROR - UoC dust wet deposition") + call wrf_debug (debug_level,text) + endif + if(rp.gt.dustwd(ii)) then + do l=1,ii + v(l)=dustwd(l) + enddo + v(ii+1)=rp + do l=ii+1,lp + v(l+1)=dustwd(l) + enddo + lpp1=lp+1 + call intrpl(lp,dustwd,e_c,lpp1,v,dnew) + e_d=dnew(ii+1) + elseif(rp.eq.dustwd(ii)) then + e_d=e_c(ii) + endif + + e_im=e_d + +! return + end subroutine eimpact +!======================================================================= + +!*********************************************************************** +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +! - further updates M. Klose + + subroutine dvisca(tair,dvisc) + +! tair : air temperature in K +! visca : dynamic viscosity of air in g/cm/s + + integer, parameter :: l=9, n=1 + + real, dimension(l) :: ta, visca + real, dimension(l) :: x, y + real, dimension(n) :: u, v + + data ta/-173,-73,0,20,25,27,127,227,327/ + data visca/0.71e-4,1.33e-4,1.72e-4,1.797e-4,1.818e-4, & + & 1.86e-4,2.31e-4,2.71e-4,3.08e-4/ + +! values from crc handbook of chemistry and physics + + do i = 1,l + x(i)=ta(i)+273 + y(i)=visca(i) + enddo + + u(1)=tair + + call intrpl(l,x,y,n,u,v) + + dvisc=v(1) + +! return + end subroutine dvisca +! +!************************************************************ + +!************************************************************ +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +! - further updates M. Klose + + subroutine dviscw(twt,dvisc) + + integer, parameter :: l=11, n=1 + + real, dimension(l) :: tw, viscw + real, dimension(l) :: x, y + real, dimension(l) :: u, v + + data tw/0,10,20,30,40,50,60,70,80,90,100/ + data viscw/1.7930e-2,1.3070e-2,1.002e-2,0.7977e-2,0.6532e-2, & + & 0.5470e-2,0.4665e-2,0.404e-2,0.3544e-2,0.3145e-2, & + & 0.2818e-2/ + +! tw : water temperature in degree C + +! dynamic viscosity of water in g/cm/s +! values from crc handbook of chemistry and physics +! properties of water in the range 0 - 100c + + do i = 1,l + x(i)=tw(i)+273.15 + y(i)=viscw(i) + enddo + + u(1)=twt+273.15 + + call intrpl(l,x,y,n,u,v) + + dvisc=v(1) + +! return + end subroutine dviscw + +!******************************************************************************* + +!************************************************************ +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +! - further updates by M. Klose, 2015 + +subroutine intrpl(l,x,y,n,u,v) +!************************************************************ +! algorithm appeared in comm. acm, vol. 15, no. 10, +! p. 914. +! +! interpolation of a single-valued function +! this subroutine interpolates, from values of the function +! given as ordinates of input data points in an x-y plane +! and for a given set of x values (abscissas), the values of +! a single-valued function y = y(x). +! the input parameters are +! l = number of input data points +! (must be 2 or greater) +! x = array of dimension l storing the x values +! (abscissas) of input data points +! (in ascending order) +! y = array of dimension l storing the y values +! (ordinates) of input data points +! n = number of points at which interpolation of the +! y value (ordinate) is desired +! (must be 1 or greater) +! u = array of dimension n storing the x values +! (abscissas) of desired points +! the output parameter is +! v = array of dimension n where the interpolated y +! values (ordinates) are to be displayed +! declaration statements + integer, intent(in) :: l, n + real, dimension(l) :: x, y + real, dimension(n) :: u, v + equivalence (p0,x3),(q0,y3),(q1,t3) + real :: m1,m2,m3,m4,m5 + equivalence (uk,dx),(imn,x2,a1,m1),(imx,x5,a5,m5), & + & (j,sw,sa),(y2,w2,w4,q2),(y5,w3,q3) + real :: a1, a2, a3, a4, a5 + integer :: debug_level + CALL get_wrf_debug_level(debug_level) +! preliminary processing + + 10 l0=l + lm1=l0-1 + lm2=lm1-1 + lp1=l0+1 + n0=n + if(lm2.lt.0) go to 90 + if(n0.le.0) go to 91 + do 11 i=2,l0 + if(x(i-1)-x(i)) 11,95,96 + 11 continue + ipv=0 +! main do-loop + do 80 k=1,n0 + uk=u(k) +! routine to locate the desired point + 20 if(lm2.eq.0) go to 27 + if(uk.ge.x(l0)) go to 26 + if(uk.lt.x(1)) go to 25 + imn=2 + imx=l0 + 21 i=(imn+imx)/2 + if(uk.ge.x(i)) go to 23 + 22 imx=i + go to 24 + 23 imn=i+1 + 24 if(imx.gt.imn) go to 21 + i=imx + go to 30 + 25 i=1 + go to 30 + 26 i=lp1 + go to 30 + 27 i=2 +! check if i = ipv + 30 if(i.eq.ipv) go to 70 + ipv=i +! routines to pick up necessary x and y values and +! to estimate them if necessary + 40 j=i + if(j.eq.1) j=2 + if(j.eq.lp1) j=l0 + x3=x(j-1) + y3=y(j-1) + x4=x(j) + y4=y(j) + a3=x4-x3 + m3=(y4-y3)/a3 + if(lm2.eq.0) go to 43 + if(j.eq.2) go to 41 + x2=x(j-2) + y2=y(j-2) + a2=x3-x2 + m2=(y3-y2)/a2 + if(j.eq.l0) go to 42 + 41 x5=x(j+1) + y5=y(j+1) + a4=x5-x4 + m4=(y5-y4)/a4 + if(j.eq.2) m2=m3+m3-m4 + go to 45 + 42 m4=m3+m3-m2 + go to 45 + 43 m2=m3 + m4=m3 + 45 if(j.le.3) go to 46 + a1=x2-x(j-3) + m1=(y2-y(j-3))/a1 + go to 47 + 46 m1=m2+m2-m3 + 47 if(j.ge.lm1) go to 48 + a5=x(j+2)-x5 + m5=(y(j+2)-y5)/a5 + go to 50 + 48 m5=m4+m4-m3 +! numerical differentiation + 50 if(i.eq.lp1) go to 52 + w2=abs(m4-m3) + w3=abs(m2-m1) + sw=w2+w3 + if(sw.ne.0.0) go to 51 + w2=0.5 + w3=0.5 + sw=1.0 + 51 t3=(w2*m2+w3*m3)/sw + if(i.eq.1) go to 54 + 52 w3=abs(m5-m4) + w4=abs(m3-m2) + sw=w3+w4 + if(sw.ne.0.0) go to 53 + w3=0.5 + w4=0.5 + sw=1.0 + 53 t4=(w3*m3+w4*m4)/sw + if(i.ne.lp1) go to 60 + t3=t4 + sa=a2+a3 + t4=0.5*(m4+m5-a2*(a2-a3)*(m2-m3)/(sa*sa)) + x3=x4 + y3=y4 + a3=a2 + m3=m4 + go to 60 + 54 t4=t3 + sa=a3+a4 + t3=0.5*(m1+m2-a4*(a3-a4)*(m3-m4)/(sa*sa)) + x3=x3-a4 + y3=y3-m2*a4 + a3=a4 + m3=m2 +! determination of the coefficients + 60 q2=(2.0*(m3-t3)+m3-t4)/a3 + q3=(-m3-m3+t3+t4)/(a3*a3) +! computation of the polynomial + 70 dx=uk-p0 + 80 v(k)=q0+dx*(q1+dx*(q2+dx*q3)) + return +! error exit + 90 call wrf_debug (debug_level,'error 90 in subroutine intrpl - ERROR - UoC dust wet deposition') !write (6,2090) + go to 99 + 91 call wrf_debug (debug_level,'error 91 in subroutine intrpl - ERROR - UoC dust wet deposition') !write (6,2091) + go to 99 + 95 call wrf_debug (debug_level,'error 95 in subroutine intrpl - ERROR - UoC dust wet deposition') !write (6,2095) + go to 97 + 96 call wrf_debug (debug_level,'error 96 in subroutine intrpl - ERROR - UoC dust wet deposition') !write (6,2096) + 97 call wrf_debug (debug_level,'error 97 in subroutine intrpl - ERROR - UoC dust wet depositionk') !write (6,2097) i,x(i) + 99 call wrf_debug (debug_level,'error 98 in subroutine intrpl - ERROR - UoC dust wet deposition') !write (6,2099) l0,n0 + return +! format statements +! 2090 format(1x/22h *** l = 1 or less./) +! 2091 format(1x/22h *** n = 0 or less./) +! 2095 format(1x/27h *** identical x values./) +! 2096 format(1x/33h *** x values out of sequence./) +! 2097 format(6h i =,i7,10x,6hx(i) =,e12.3) +! 2099 format(6h l =,i7,10x,3hn =,i7/& +! & 36h error detected in routine intrpl) + end subroutine intrpl +!************************************************************ + +!======================================================================= +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +! - further updates M. Klose + + subroutine fallv(d,t,p,rhoair,visc,vt) +!======================================================================= +! the program to calculate the termincal velocity of raindrop +! this is based on Beard (1976) +! +! input +! ta : temperature in K +! dropd : raindrop diameter in m +! +! output +! vt : terminal velocity in m/s +!======================================================================= + +real :: gg, pr0, t0, visc0, rhow, rhoa, dp, dl, cl, csc, vt, ta, dropd, pr +real :: a0, a1, a2, a3, a4, a5, a6 +real :: b0, b1, b2, b3, b4, b5 +real :: c1, c2, dan, x, vy, rey, c3, bon, phn, rhoair, p, t, d + + CHARACTER*(100) :: text + integer :: debug_level + CALL get_wrf_debug_level(debug_level) + +! compute surface tension +! sig : the surface tension in mN/m + + dropd = d*1.e6 ! m to um + ta = t-273.15 ! K to C + pr = p*1.e-2 ! Pa to hPa (mb) + + call sfctens(ta,sig) + + gg=980 ! cm/s^2 + pr0=1013.25 ! mb + t0=293.15 ! K + visc0=1.818e-4 ! g/cm/sec + rhow=1 ! g/cm^3 + + rhoa = rhoair*1.e-3 ! kg/m3 to g/cm3 + +! compute the terminal velocity + + vt=0 + + dp=dropd + dl=dropd*1.e-4 ! diameter in cm + + c1=(rhow-rhoa)*gg/(18*visc) + cl=6.62e-6*(visc/visc0)*(pr0/pr)*sqrt((ta+273.15)/t0) !cm + csc=1+2.51*cl/dl + + if(dp.lt.19.) then + + vt=c1*csc*dl**2 + vt=vt*1.e-2 ! cm/s to m/s + + elseif(dp.ge.19. .and. dp.lt.1070.) then + + a0=-0.318657e+1 + a1=+0.992696 + a2=-0.153193e-2 + a3=-0.987059e-3 + a4=-0.578878e-3 + a5=+0.855176e-4 + a6=-0.327815e-5 + + c2=4*rhoa*(rhow-rhoa)*gg/(3*visc*visc) + dan=c2*dl**3 + x=alog(dan) + vy=a0+a1*x+a2*x**2+a3*x**3+a4*x**4+a5*x**5+a6*x**6 + rey=csc*exp(vy) + vt=visc*rey/(rhoa*dl) + vt=vt*1.e-2 ! cm/s to m/s + + elseif(dp.ge.1070. .and. dp.le.7000.) then + + b0=-0.500015e+1 + b1=+0.523778e+1 + b2=-0.204914e+1 + b3=+0.475294 + b4=-0.542819e-1 + b5=+0.238449e-2 + + c3=4*(rhow-rhoa)*gg/(3*sig) + bon=c3*dl*dl ! Bond Number + phn=sig**3*rhoa**2/(visc**4*gg*(rhow-rhoa)) ! Physical Property Number + + y=alog(bon*phn**(1.0/6.0)) + vy=b0+b1*y+b2*y**2+b3*y**3+b4*y**4+b5*y**5 + rey=phn**(1.0/6.0)*exp(vy) + vt=visc*rey/(rhoa*dl) + vt=vt*1.e-2 ! cm/s to m/s + + endif + +! return + end subroutine fallv +!======================================================================= + +!======================================================================= +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +! - further updates, M. Klose + + subroutine sfctens(temp,sig) + +! temp : temperature in K +! sig : surface tension in mN/m or dyne/cm + integer, parameter :: n=14 + real, dimension(n) :: t, sfctn + data t/0,5,10,15,18,20,25,30,40,50,60,70,80,100/ + data sfctn/75.6,74.9,74.22,73.49,73.05,72.75,71.97,71.18,69.56, & + & 67.91,66.18,64.4,62.6,58.9/ + + real :: ta + + kk = 1 + xsfc = 0 + ta=max(temp-273.15,0.0) + + do i = 1, 14 + if(i.lt.14) then + if(ta.ge.t(i) .and. ta.lt.t(i+1)) then + kk=i + goto 1 + endif + else + if(ta.ge.t(i)) then + kk=14 + goto 1 + endif + endif + enddo + +1 continue + + if(kk.lt.14) then + sig = sfctn(kk)+ & + & (sfctn(kk+1)-sfctn(kk))*(ta-t(kk))/(t(kk+1)-t(kk)) + else + sig = sfctn(kk)+ & + & (sfctn(kk)-sfctn(kk-1))*(ta-t(kk))/(t(kk)-t(kk-1)) + endif + +! return + end subroutine sfctens +!*********************************************************************** + +!*********************************************************************** +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +! - further updates M. Klose + + subroutine dsd_rain(rnrate,raind,nrbin,dsd_rn,ldsd) + +! input + real, intent(in) :: raind(nrbin), rnrate ! in m and mm/h + integer, intent(in) :: ldsd, nrbin +! local + real :: dsd_mp(nrbin) + real :: dsd_ss(nrbin) + real :: dsd_wt(nrbin) + real :: dsd_fl(nrbin) + real :: ng + real :: nt + real :: pi, dr, wc, d0, dcm, const, dumm +! output + real, intent(out) :: dsd_rn(nrbin) +!....................................................................... + + d0=0 + do nk=1,nrbin + + dr=raind(nk)*1.e3 ! m to mm + + if(ldsd.eq.1) then +! +! Marshall-Palmer(1948) + dsd_mp(nk)=8.e3*exp(-4.1*dr*rnrate**(-0.21)) ! 1/m^3/mm + dsd_mp(nk)=dsd_mp(nk)*1.e-5 ! 1/cm^3/cm + dsd_rn(nk)=dsd_mp(nk) +! + elseif(ldsd.eq.2) then + +! Sekhon and Srivastava + dsd_ss(nk)=0.07*rnrate**0.37*exp(-3.8*dr/rnrate**0.14) ! cm^(-3) cm^(-1) + dsd_rn(nk)=dsd_ss(nk) +! + elseif(ldsd.eq.3) then + +! Willis-Tattelman(1989) + wc=0.062*rnrate**0.913 ! water content in g/m^3 + d0=0.1571*wc**0.1681 ! median volume diameter in cm + ng=512.85*wc*1.e-6/d0**4*d0**(-2.16) + dcm=dr*0.1 ! diameter in cm + dsd_wt(nk)=ng*dcm**2.16*exp(-5.5880*dcm/d0) ! #/cm^3/cm + dsd_rn(nk)=dsd_wt(nk) + + elseif(ldsd.eq.4) then + +! Feingold-Levin(1986) + pi=acos(-1.0) + const=sqrt(2*pi)*alog(1.43) + nt=172*rnrate**0.22 ! 1/m^3 + dg=0.72*rnrate**0.21 + dumm=0.5*alog(dr/dg)**2/alog(1.43)**2 + dsd_fl(nk)=nt/const/dr*exp(-dumm) ! 1/m^3/mm + dsd_fl(nk)=dsd_fl(nk)*1.e-5 ! 1/cm^3/cm + dsd_rn(nk)=dsd_fl(nk) + + endif +! + enddo + + return + end subroutine dsd_rain + +!*********************************************************************** + + +!*********************************************************************** +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +! - further updates M. Klose + +subroutine w_p(d,rho,wt) + +! Yaping Shao 28-07-92 + +! Calculate Terminal velocity for spherical grain +! wt : terminal velocity [m/s] +! d : particle diameter [m] +! rho : particle density [kg/m3] +! Require CDSPH +! Parameter specifications + +IMPLICIT NONE ! cfrick + + REAL, INTENT(OUT) :: wt + REAL :: lambda + REAL :: rden, err, test, x, xl, xh + REAL :: f, fm, fl, fh + INTEGER :: i, isign + real, intent(in) :: rho, d + real :: cc + + REAL, PARAMETER :: visc=1.5E-05 + INTEGER :: debug_level + + CHARACTER*(100) :: text + +! VARIABLE X IS WT, FUNCTION F IS: CD(RE)*WT**2 - 4*D*G*RDEN/3 + + + CALL get_wrf_debug_level(debug_level) + + rden=rho ! particle density + lambda=0.0651*1.e-6 ! mean free path of air + cc=1+(2*lambda/d)*(1.257+0.4*exp(-1.1*d/(2*lambda))) ! Cunningham's correction for small particles + + err=1E-6 + xl=1E-12 + xh=1E3 + + wt = xl + fl = CDSPH(wt*d/visc)*wt**2/cc - 4.0*d*g*rden/3.0 + + wt = xh + fh = CDSPH(wt*d/visc)*wt**2/cc - 4.0*d*g*rden/3.0 + + IF (fh*fl.GT.0) call wrf_debug (debug_level,'w_t: F(XL), F(XH) HAVE SAME SIGN - ERROR - UoC dust wet deposition') + IF (fh-fl.EQ.0) call wrf_debug (debug_level,'w_t: F(XL) = F(XH) - ERROR - UoC dust wet deposition') + + isign=1 + IF (fh.LT.fl) isign=-1 + + fh=isign*fh + fl=isign*fl + + DO 1 i=1,100 + x=(xl+xh)/2 + wt = x + f = CDSPH(wt*d/visc)*wt**2/cc - 4.0*d*g*rden/3.0 + fm=isign*f + IF (fm.GT.fh.OR.fm.LT.fl) call wrf_debug (debug_level,'w_t: F(X) NON-MONOTONIC - ERROR - UoC dust wet deposition') + IF (fm.GT.0) xh=x + IF (fm.LT.0) xl=x + IF (fm.EQ.0) then + return + ENDIF + test=ABS(xh-xl)/ABS(x) + IF (test.LT.ABS(err)) then + return + ENDIF +1 CONTINUE + call wrf_debug (debug_level,'w_t: NO SOLUTION IN 100 LOOPS - ERROR - UoC dust wet deposition') + +END subroutine w_p +!*************************************************************** + + +!*********************************************************************** +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +! - further updates M. Klose + +SUBROUTINE w_t (wt, dmm, rhop, rhoa) + +! Yaping Shao 28-07-92 + +! Calculate Terminal velocity for spherical grain +! wt : terminal velocity [m/s] +! dmm: particle diameter in [m] +! rhop: particle density [kg/m3] +! rhoa: air density [kg/m3] +! Require CDSPH +! Parameter specifications + +! include Cunningham's correction - Claudia Frick 24-04-2014 + + REAL(8), INTENT(IN) :: rhop + REAL, INTENT(IN) :: rhoa + + REAL :: wt, dmm + REAL :: RDEN, D, ERR, TEST, X, XL, XH + REAL :: F, FM, FL, FH + REAL, PARAMETER :: VISC=1.5E-05 + INTEGER :: I, ISIGN + + CHARACTER*(100) :: text + REAL :: lambda + real :: cc + + +! VARIABLE X IS WT, FUNCTION F IS: CD(RE)*WT**2 - 4*D*G*RDEN/3 + + D = dmm + RDEN=rhop/rhoa ! = sigma + lambda=0.0651*1.e-6 ! mean free path of air + cc=1+(2*lambda/D)*(1.257+0.4*exp(-1.1*D/(2*lambda))) ! Cunningham's correction for small particles + + ERR=1E-6 + XL=1E-12 + XH=1E3 + WT = XL + FL = CDSPH(WT*D/VISC)*WT**2/cc - 4.0*D*G*RDEN/3.0 + WT = XH + FH = CDSPH(WT*D/VISC)*WT**2/cc - 4.0*D*G*RDEN/3.0 + IF (FH*FL.GT.0) call wrf_debug (debug_level,'w_t: F(XL), F(XH) HAVE SAME SIGN - ERROR - UoC dust wet deposition') + IF (FH-FL.EQ.0) call wrf_debug (debug_level,'w_t: F(XL) = F(XH) - ERROR - UoC dust wet deposition') + ISIGN=1 + IF (FH.LT.FL) ISIGN=-1 + FH=ISIGN*FH + FL=ISIGN*FL + DO 1 I=1,100 + X=(XL+XH)/2 + WT = X + F = CDSPH(WT*D/VISC)*WT**2/cc - 4.0*D*G*RDEN/3.0 + FM=ISIGN*F + IF (FM.GT.FH.OR.FM.LT.FL) call wrf_debug (debug_level,'w_t: F(X) NON-MONOTONIC - ERROR - UoC dust wet deposition') + IF (FM.GT.0) XH=X + IF (FM.LT.0) XL=X + IF (FM.EQ.0) then + return + ENDIF + TEST=ABS(XH-XL)/ABS(X) + IF (TEST.LT.ABS(ERR)) then + return + ENDIF +1 CONTINUE + call wrf_debug (debug_level,'w_t: NO SOLUTION IN 100 LOOPS - ERROR - UoC dust wet deposition') + +END subroutine w_t +!*************************************************************** + + +!--------------------------------------------------------------- +! CEMSYS5 - smaller modifications by cfrick for WRF implementation +real FUNCTION CDSPH(RE) + +! MRR, 30-SEP-87 +! ADAPTED 10-OCT-89 (NO ISTOKE, NO CRASH FOR RE>50000) +! CALCULATES DRAG COEFFICIENT CD FOR A SPHERE, AS A FUNCTION OF +! REYNOLDS NUMBER RE, WHERE: +! DRAG FORCE = (RHO * PI * D**2 * U**2) / 8 +! RE = U * D / VISCOSITY +! (D = SPHERE DIAMETER, U = VELOCITY, RHO = FLUID DENSITY) +! ALGORITHM FROM MORSI AND ALEXANDER (1972, JFM 55, 193-208), CHECKED +! AGAINST THEIR TABLE FOR CD(SPHERE). +! FOR RE > 50000, SET CDSPH = 0.48802, THE VALUE AT RE=50000=5*10**4. +! THIS IS OK TO RE=3*10**5 (APPROX), BEYOND WHICH DRAG CRISIS OCCURS +! AND SETS CDSPH TO ABOUT 0.1. + +IMPLICIT NONE ! cfrick + +real :: RE + +IF (RE.LE.0) THEN + WRITE(6,*) RE + STOP 'CDSPH: RE.LE.0' +ELSE IF (RE.LE.0.1) THEN + CDSPH = 24/RE +ELSE IF (RE.LE.1) THEN + CDSPH = 22.73/RE + 0.0903/RE**2 + 3.69 +ELSE IF (RE.LE.10) THEN + CDSPH = 29.1667/RE - 3.8889/RE**2 + 1.222 +ELSE IF (RE.LE.100) THEN + CDSPH = 46.5/RE - 116.67/RE**2 + 0.6167 +ELSE IF (RE.LE.1000) THEN + CDSPH = 98.33/RE - 2778/RE**2 + 0.3644 +ELSE IF (RE.LE.5000) THEN + CDSPH = 148.62/RE - 47500/RE**2 + 0.357 +ELSE IF (RE.LE.10000) THEN + CDSPH = -490.546/RE + 578700/RE**2 + 0.46 +ELSE IF (RE.LE.50000) THEN + CDSPH = -1662.5/RE + 5416700/RE**2 + 0.5191 +ELSE + CDSPH = 0.48802 +END IF + +END FUNCTION CDSPH +!-------------------------------------------------------------------- + + +END MODULE module_uoc_dustwd diff --git a/wrfv2_fire/chem/module_wetscav_driver.F b/wrfv2_fire/chem/module_wetscav_driver.F index 1fe8027f..0dd2ba13 100644 --- a/wrfv2_fire/chem/module_wetscav_driver.F +++ b/wrfv2_fire/chem/module_wetscav_driver.F @@ -63,10 +63,16 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & USE modal_aero_data, only: ntot_amode ! For cam_mam_wetscav variables USE module_mozcart_wetscav, only: wetscav_mozcart USE module_mosaic_wetscav, only: wetscav_cbmz_mosaic, wetscav_mozart_mosaic - USE module_aerosols_sorgam, only: wetscav_sorgam_driver +!!! TUCCELLA (BUG, the line below is commented now) + !USE module_aerosols_sorgam, only: wetscav_sorgam_driver USE module_aerosols_sorgam_vbs, only: wetscav_sorgam_vbs_driver USE module_cam_mam_wetscav, only: wetscav_cam_mam_driver USE module_cam_support, only: pcnst =>pcnst_runtime +!!! TUCCELLA (BUG, the line below is commented now) + !USE module_aerosols_soa_vbs, only: wetscav_soa_vbs_driver +!!! TUCCELLA (BUG, the drivers for wet scavenging of SORGAM and VBS now are in +! module_prep_wetscav_sorgam.F) + USE module_prep_wetscav_sorgam, only: wetscav_sorgam_driver, wetscav_soa_vbs_driver USE module_data_mosaic_asect, only: mw_so4_aer, mw_no3_aer, mw_nh4_aer, & mw_smpa_aer, mw_smpbb_aer, mw_oc_aer, & mw_glysoa_r1_aer, mw_glysoa_r2_aer, & @@ -309,6 +315,28 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & enddo enddo +!!! TUCCELLA + CASE ( RACM_SOA_VBS_AQCHEM_KPP ) + CALL wrf_debug(15,'wetscav_driver calling soa_vbs_wetscav_driver' ) + call wetscav_soa_vbs_driver (id,ktau,dtstep,ktauc,config_flags, & + dtstepc,alt,t_phy,p8w,t8w,p_phy,chem,rho_phy,cldfra, & + qlsink,precr,preci,precs,precg, qsrflx, & + gas_aqfrac, numgas_aqfrac, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +! not clear if the following is necessary or appropriate + tmp_minval = 1.0e7 + do jj=jts,jte + do kk=kts,kte + do ii=its,ite + if (chem(ii,kk,jj,p_nu0) .lt. tmp_minval) then + chem(ii,kk,jj,p_nu0) = tmp_minval + endif + enddo + enddo + enddo + CASE (CB05_SORG_VBS_AQ_KPP ) CALL wrf_debug(15,'wetscav_driver calling sorgam_wetscav_driver' ) call wetscav_sorgam_vbs_driver (id,ktau,dtstep,ktauc,config_flags, & diff --git a/wrfv2_fire/compile b/wrfv2_fire/compile index 83bee14e..75e18935 100755 --- a/wrfv2_fire/compile +++ b/wrfv2_fire/compile @@ -47,11 +47,22 @@ foreach a ( $argv ) if ( "$a" != "-d" ) then set arglist = ( $arglist $a ) endif - if ( "$a" == "all_wrfvar" ) then + if ( "$a" == "all_wrfvar" || "$a" == "gen_be" ) then grep "DA_CORE=1" configure.wrf > /dev/null if ( ! $status ) then - # If configuration file has DA_CORE=1 hardwired, ok to set WRF_DA_CORE to 1 - setenv WRF_DA_CORE 1 + # If configuration file has DA_CORE=1, set WRF_DA_CORE to 1 + setenv WRF_DA_CORE 1 + else + # If the user ran the configure script without the "wrfda" option, "./compile all_wrfvar" + # will fail in non-obvious ways, and some executables will be created incorrectly. + # Let's just quit right away to avoid the hassle. + echo "" + echo "To build WRFDA, you must run the 'configure' script with the 'wrfda' option:" + echo " ./configure wrfda" + echo "" + echo "Exiting..." + echo "" + exit 1 endif endif if ( "$a" == "nmm_real" ) then @@ -255,8 +266,6 @@ else /bin/cat Registry/Registry.CONVERT >> Registry/Registry endif else if ( $WRF_DA_CORE == 1 ) then - setenv BUFR 1 - setenv CRTM 1 if ( ! -f Registry/Registry ) then set overwrite=1 else @@ -276,12 +285,22 @@ else echo '## WARNING: this file is autogenerated from Registry/Registry.wrfvar Registry/Registry.EM_COMMON.var. Changes may be lost' > Registry/Registry /bin/cat Registry/Registry.wrfvar >> Registry/Registry endif + + set wrfpluspath = ( `grep "^WRFPLUSPATH" configure.wrf | cut -d"=" -f2-` ) + if ( $wrfpluspath == "" ) then + setenv WRFPLUS_INC " " + else + setenv WRFPLUS_DIR $wrfpluspath + setenv WRFPLUS_INC "-I${wrfpluspath}/dyn_em -I${wrfpluspath}/main -I${wrfpluspath}/frame -I${wrfpluspath}/share" + endif + + setenv BUFR 1 + setenv CRTM 1 if ( $?CRTM ) then if ( ! $?BUFR ) then echo " " echo "BUFR library will be compiled for radiance data ingest." echo " " - setenv BUFR 1 endif setenv CRTM_CPP "-DCRTM" setenv CRTM_LIB "-L../external/crtm_2.1.3/libsrc -lCRTM" @@ -305,10 +324,12 @@ else setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov11.1.0_coef_io -lrttov11.1.0_emis_atlas -lrttov11.1.0_main" else if ( -e ${RTTOV}/lib/librttov11.2.0_main.a ) then setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov11.2.0_coef_io -lrttov11.2.0_emis_atlas -lrttov11.2.0_main" + else if ( -e ${RTTOV}/lib/librttov11_main.a ) then + setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov11_coef_io -lrttov11_emis_atlas -lrttov11_main" else echo "Can not find a compatible RTTOV library! Please ensure that your RTTOV build was successful," echo "your 'RTTOV' environment variable is set correctly, and you are using a supported version of RTTOV." - echo "Currently supported versions are 11.1 and 11.2" + echo "Currently supported versions are 11.1, 11.2, and 11.3" exit 1 endif setenv RTTOV_SRC "-I${RTTOV}/include -I${RTTOV}/mod" @@ -317,6 +338,14 @@ else setenv RTTOV_LIB " " setenv RTTOV_SRC " " endif + set hdf5path = ( `grep "^HDF5PATH" configure.wrf | cut -d"=" -f2-` ) + if ( $hdf5path == "" ) then + setenv HDF5_INC "" + unsetenv HDF5 + else + setenv HDF5_INC "-I${hdf5path}/include" + setenv HDF5 1 + endif if ( $?CLOUD_CV ) then setenv CLOUD_CV_CPP "-DCLOUD_CV" else diff --git a/wrfv2_fire/configure b/wrfv2_fire/configure index 6411ed24..5aaaaa39 100755 --- a/wrfv2_fire/configure +++ b/wrfv2_fire/configure @@ -287,10 +287,16 @@ fi USENETCDFF="" # see below if [ -n "$NETCDF" ] ; then echo "Will use NETCDF in dir: $NETCDF" -# for 3.6.2 and greater there might be a second library, libnetcdff.a . Check for this and use -# if available +# Oh UNIDATA, why make it so hard ... if [ -f "$NETCDF/lib/libnetcdff.a" -o -f "$NETCDF/lib/libnetcdff.so" ] ; then USENETCDFF="-lnetcdff" + else + USENETCDFF=" " + fi + if [ -f "$NETCDF/lib/libnetcdf.a" -o -f "$NETCDF/lib/libnetcdf.so" ] ; then + USENETCDF="-lnetcdf" + else + USENETCDF=" " fi else echo "Will configure for use without NetCDF" @@ -383,18 +389,18 @@ if [ -n "$PNETCDF" ] ; then # echo "Will configure for use without NetCDF" fi +if [ -n "$HDF5" ] ; then + echo "Will use HDF5 in dir: $HDF5" +else + echo "HDF5 not set in environment. Will configure WRF for use without." +fi + if [ -n "$PHDF5" ] ; then echo "Will use PHDF5 in dir: $PHDF5" else echo "PHDF5 not set in environment. Will configure WRF for use without." fi -if [ "$wrf_core" = "DA_CORE" ]; then - if [ -n "$WRFPLUS_DIR" ] ; then - unset WRFPLUS_DIR - fi -fi - if [ "$wrf_core" = "4D_DA_CORE" ]; then if [ -n "$WRFPLUS_DIR" ] ; then echo "Will use WRFPLUS in dir: $WRFPLUS_DIR" @@ -402,6 +408,11 @@ if [ "$wrf_core" = "4D_DA_CORE" ]; then echo "WRFPLUS_DIR not set in environment. Please compile WRFPLUS and set WRFPLUS_DIR." exit fi +else + if [ -n "$WRFPLUS_DIR" ] ; then + echo 'Unsetting "$WRFPLUS_DIR" environment variable. Use "configure 4dvar" to configure for 4dvar compilation.' + unset WRFPLUS_DIR + fi fi # Users who are cross-compiling can set environment variable # $WRF_OS to override the value normally obtained from `uname`. @@ -584,8 +595,9 @@ if test -n "$PERL" ; then srch=`grep -i "^#ARCH.*$os" arch/configure_new.defaults | grep -i "$mach"` if [ -n "$srch" ] ; then $PERL arch/Config_new.pl -dmparallel=$COMMLIB -ompparallel=$OMP -perl=$PERL \ - -netcdf=$NETCDF -pnetcdf=$PNETCDF -phdf5=$PHDF5 -os=$os -mach=$mach -ldflags=$ldflags \ - -compileflags=$compileflags -opt_level=$opt_level -USENETCDFF=$USENETCDFF -time=$FORTRAN_COMPILER_TIMER \ + -netcdf=$NETCDF -pnetcdf=$PNETCDF -hdf5=$HDF5 -phdf5=$PHDF5 -os=$os -mach=$mach -ldflags=$ldflags \ + -compileflags=$compileflags -opt_level=$opt_level -USENETCDFF=$USENETCDFF -USENETCDF=$USENETCDF \ + -time=$FORTRAN_COMPILER_TIMER \ -wrf_core=$wrf_core -gpfs=$GPFS_PATH -curl=$CURL_PATH -dep_lib_path="$DEP_LIB_PATH" if test ! -f configure.wrf ; then echo "configure.wrf not created! Exiting configure script..." diff --git a/wrfv2_fire/dyn_em/couple_or_uncouple_em.F b/wrfv2_fire/dyn_em/couple_or_uncouple_em.F index 556034c7..4af40a07 100644 --- a/wrfv2_fire/dyn_em/couple_or_uncouple_em.F +++ b/wrfv2_fire/dyn_em/couple_or_uncouple_em.F @@ -33,7 +33,7 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & TYPE(domain) , TARGET :: grid ! Definitions of dummy arguments to solve -#include +#include "dummy_new_decl.inc" ! WRF state bcs TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags @@ -54,6 +54,7 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & REAL, DIMENSION(grid%sm31:grid%em31,grid%sm33:grid%em33) :: mut_2, muut_2, muvt_2, muwt_2 ! De-reference dimension information stored in the grid data structure. + IF ( .NOT. grid%active_this_task ) RETURN CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & diff --git a/wrfv2_fire/dyn_em/depend.dyn_em b/wrfv2_fire/dyn_em/depend.dyn_em index 907bf708..03833ef9 100644 --- a/wrfv2_fire/dyn_em/depend.dyn_em +++ b/wrfv2_fire/dyn_em/depend.dyn_em @@ -244,6 +244,7 @@ start_em.o: module_bc_em.o \ ../share/module_date_time.o \ ../phys/module_physics_init.o \ ../phys/module_diag_pld.o \ + ../phys/module_diag_zld.o \ ../phys/module_fr_fire_driver_wrf.o \ $(CF) diff --git a/wrfv2_fire/dyn_em/interp_domain_em.F b/wrfv2_fire/dyn_em/interp_domain_em.F index 5df50966..1c97931a 100644 --- a/wrfv2_fire/dyn_em/interp_domain_em.F +++ b/wrfv2_fire/dyn_em/interp_domain_em.F @@ -21,7 +21,7 @@ SUBROUTINE interp_domain_em_part1 ( grid, ngrid, config_flags & USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type TYPE(domain), POINTER :: grid , ngrid -#include +#include "dummy_new_decl.inc" INTEGER nlev INTEGER i,j,pig,pjg,cm,cn,nig,njg,k diff --git a/wrfv2_fire/dyn_em/module_advect_em.F b/wrfv2_fire/dyn_em/module_advect_em.F index 03c4ee64..1399447e 100644 --- a/wrfv2_fire/dyn_em/module_advect_em.F +++ b/wrfv2_fire/dyn_em/module_advect_em.F @@ -1,5 +1,6 @@ !WRF:MODEL_LAYER:DYNAMICS ! +#if ( ! defined(ADVECT_KERNEL) ) MODULE module_advect_em USE module_bc @@ -5937,6 +5938,71 @@ SUBROUTINE advect_w ( w, w_old, tendency, & END SUBROUTINE advect_w !---------------------------------------------------------------- +#else +! cpp -traditional -C -P -DADVECT_KERNEL module_advect_em.F > advection_kernel.f90 +! ifort, pgfortran, gfortran advection_kernel.f90 +! a.out + +MODULE advection_kernel + + TYPE grid_config_rec_type + INTEGER :: h_sca_adv_order = 5 + INTEGER :: v_sca_adv_order = 3 + + LOGICAL :: periodic_x = .false. + LOGICAL :: periodic_y = .false. + + LOGICAL :: symmetric_xs = .false. + LOGICAL :: symmetric_xe = .false. + LOGICAL :: symmetric_ys = .false. + LOGICAL :: symmetric_ye = .false. + + LOGICAL :: open_xs = .false. + LOGICAL :: open_xe = .false. + LOGICAL :: open_ys = .false. + LOGICAL :: open_ye = .false. + + LOGICAL :: specified = .true. + LOGICAL :: nested = .false. + LOGICAL :: polar = .false. + END TYPE grid_config_rec_type + + CHARACTER (LEN=256) :: wrf_err_message + +CONTAINS + +!---------------------------------------------------------------- + +SUBROUTINE wrf_error_fatal ( message ) + IMPLICIT NONE + CHARACTER(LEN=*) , INTENT(IN) :: message + PRINT *,'advect_scalar_pd: FATAL MESSAGE = ',TRIM(message) + STOP 12345 +END SUBROUTINE wrf_error_fatal + +!---------------------------------------------------------------- + +SUBROUTINE init ( config_flags ) + IMPLICIT NONE + TYPE (grid_config_rec_type) :: config_flags + config_flags%h_sca_adv_order = 5 + config_flags%v_sca_adv_order = 3 + config_flags%periodic_x = .false. + config_flags%periodic_y = .false. + config_flags%symmetric_xs = .false. + config_flags%symmetric_xe = .false. + config_flags%symmetric_ys = .false. + config_flags%symmetric_ye = .false. + config_flags%open_xs = .false. + config_flags%open_xe = .false. + config_flags%open_ys = .false. + config_flags%open_ye = .false. + config_flags%specified = .true. + config_flags%nested = .false. +END SUBROUTINE init + +!---------------------------------------------------------------- +#endif SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & h_tendency, z_tendency, & @@ -7716,6 +7782,195 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & END IF END SUBROUTINE advect_scalar_pd +#if ( defined(ADVECT_KERNEL) ) + +!---------------------------------------------------------------- + +END MODULE advection_kernel + +!================================================================ +!================================================================ + +PROGRAM feeder + + USE advection_kernel + + IMPLICIT NONE + + INTEGER , PARAMETER :: MAX_SCALARS = 15 + + TYPE(grid_config_rec_type) :: config_flags + + LOGICAL :: tenddec = .TRUE. + + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( :,:,:,: ) , ALLOCATABLE :: field, & + field_old + REAL , DIMENSION( :,:,: ) , ALLOCATABLE :: ru, & + rv, & + rom + + REAL , DIMENSION( :,: ), ALLOCATABLE :: mut, mub, mu_old + + REAL , DIMENSION( :,:,: ), ALLOCATABLE :: tendency + + REAL , DIMENSION( :,:,: ), ALLOCATABLE :: h_tendency, z_tendency + + REAL , DIMENSION( :,: ), ALLOCATABLE :: msfux, & + msfuy, & + msfvx, & + msfvy, & + msftx, & + msfty + + REAL , DIMENSION( : ), ALLOCATABLE :: fzm, & + fzp, & + rdzw, znw + + REAL :: rdx, & + rdy, & + dt + + INTEGER :: time_step, im + + INTEGER :: i, j, k, loop + + PRINT *,'Init dimensions' + + ids = 1; ide = 90; jds = 1; jde = 90; kds = 1; kde = 50 + ims = -5; ime = 55; jms = -5; jme = 55; kms = -5; kme = 55 + its = 1; ite = 50; jts = 1; jte = 50; kts = 1; kte = 50 + + + PRINT *,'ALLOCATE two 4d fields' + PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1)*MAX_SCALARS + ALLOCATE ( field(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) ) + ALLOCATE ( field_old(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) ) + + PRINT *,'ALLOCATE three 3d fields U, V, W' + PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1) + ALLOCATE ( ru(ims:ime , kms:kme , jms:jme ) ) + ALLOCATE ( rv(ims:ime , kms:kme , jms:jme ) ) + ALLOCATE ( rom(ims:ime , kms:kme , jms:jme ) ) + + PRINT *,'ALLOCATE three 2d MU fields' + PRINT *,(ime-ims+1)*(jme-jms+1) + ALLOCATE ( mut( ims:ime , jms:jme ) ) + ALLOCATE ( mub( ims:ime , jms:jme ) ) + ALLOCATE ( mu_old( ims:ime , jms:jme ) ) + + PRINT *,'ALLOCATE three 3d tendency' + PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1) + ALLOCATE ( tendency( ims:ime , kms:kme , jms:jme ) ) + ALLOCATE ( h_tendency( ims:ime , kms:kme , jms:jme ) ) + ALLOCATE ( z_tendency( ims:ime , kms:kme , jms:jme ) ) + + PRINT *,'ALLOCATE six 2d map factors' + PRINT *,(ime-ims+1)*(jme-jms+1) + ALLOCATE ( msfux( ims:ime , jms:jme ) ) + ALLOCATE ( msfuy( ims:ime , jms:jme ) ) + ALLOCATE ( msfvx( ims:ime , jms:jme ) ) + ALLOCATE ( msfvy( ims:ime , jms:jme ) ) + ALLOCATE ( msftx( ims:ime , jms:jme ) ) + ALLOCATE ( msfty( ims:ime , jms:jme ) ) + + PRINT *,'ALLOCATE 1d arrays' + ALLOCATE ( fzm( kms:kme ) ) + ALLOCATE ( fzp( kms:kme ) ) + ALLOCATE ( rdzw( kms:kme ) ) + ALLOCATE ( znw( kms:kme ) ) + + PRINT *,'CALL init' + CALL init ( config_flags) + + PRINT *,'RANDOM two 3d fields' + CALL RANDOM_NUMBER ( field ) + CALL RANDOM_NUMBER ( field_old ) + field = field - 0.5 + field_old = field_old - 0.5 + + PRINT *,'RANDOM three 3d tendencies' + CALL RANDOM_NUMBER ( tendency ) + CALL RANDOM_NUMBER ( h_tendency ) + CALL RANDOM_NUMBER ( z_tendency ) + tendency = tendency - 0.5 + h_tendency = h_tendency - 0.5 + z_tendency = z_tendency - 0.5 + + PRINT *,'RANDOM three 2d MU' + mub = 95000 + mut = 100000 + CALL RANDOM_NUMBER ( mu_old ) + mu_old = 100000 - mu_old*100 + + PRINT *,'RANDOM three 3d couple momentum' + CALL RANDOM_NUMBER ( ru ) + CALL RANDOM_NUMBER ( rv ) + CALL RANDOM_NUMBER ( rom ) + DO j = jts, jte + DO k = kts, kte + DO i = its, ite + ru(i,k,j) = ru(i,k,j) * mut(i,j) + rv(i,k,j) = rv(i,k,j) * mut(i,j) + rom(i,k,j) = rom(i,k,j) * mut(i,j) + END DO + END DO + END DO + + time_step = -1 + + msfux = 1 + msfuy = 1 + msfvx = 1 + msfvy = 1 + msftx = 1 + msfty = 1 + + rdx = 1/10000. + rdy = 1/10000. + + DO k = kts, kte + znw(k) = 1 - (real(k)-kts)/(real(kte)-kts) + END DO + + DO k = kts, kte-1 + rdzw(k) = 1./(znw(k)-znw(k+1)) + END DO + + CALL RANDOM_NUMBER ( fzm ) + fzp = 1. - fzm + + ! Loop over advection enough times to get some meaningful timings. + + DO loop = 1 , 100 + + ! A representative number of times to call the advection in a time period. + + PRINT *,'LOOP over scalars' + DO im = 1 , MAX_SCALARS + PRINT *,'CALL advect for loop = ',im,', of ',MAX_SCALARS,' loops' + CALL advect_scalar_pd ( field(ims,kms,jms,im), & + field_old(ims,kms,jms,im), & + tendency(ims,kms,jms), & + h_tendency(ims,kms,jms), & + z_tendency(ims,kms,jms), & + ru, rv, rom, mut, mub, mu_old, & + time_step, config_flags, tenddec, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, fzm, fzp, & + rdx, rdy, rdzw,dt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + + END DO + END DO + +END PROGRAM feeder +#else !---------------------------------------------------------------- @@ -12406,3 +12661,4 @@ END SUBROUTINE advect_weno_w END MODULE module_advect_em +#endif diff --git a/wrfv2_fire/dyn_em/module_bc_em.F b/wrfv2_fire/dyn_em/module_bc_em.F index 97dde121..1cbf7453 100644 --- a/wrfv2_fire/dyn_em/module_bc_em.F +++ b/wrfv2_fire/dyn_em/module_bc_em.F @@ -1413,6 +1413,8 @@ SUBROUTINE theta_and_thetam_lbc_only ( & REAL :: moist_old_bdy_tend_xs , moist_old_bdy_tend_xe REAL :: moist_old_bdy_tend_ys , moist_old_bdy_tend_ye + INTEGER :: i_min, i_max, j_min, j_max + ! IF ( theta_to_thetam ) THEN ! Convert dry potential temperature to theta_m ! Defined as: theta_m = ( theta + T0 ) * ( 1. + (R_v/R_d) Qv ) - T0 @@ -1442,6 +1444,22 @@ SUBROUTINE theta_and_thetam_lbc_only ( & ! passed in, this will either be dry potential temperature or moist potential ! temperature. + ! The i_min, i_max for the south and north boundaries depends on if we are doing + ! serial, OpenMP, or MPI. For OpenMP, we do not want any overlap between tiles that + ! are on the same task (either OpenMP only, or OpenMP+MPI). + + IF ( its .EQ. ips ) THEN + i_min = ips-4 + ELSE + i_min = its + END IF + + IF ( ite .EQ. ipe ) THEN + i_max = ipe+4 + ELSE + i_max = ite + END IF + ! South and north lateral boundaries. This is the i-extent of its through ite, but j only ! goes to within spec_bdy_width of the top and bottom (north and south) boundaries. @@ -1451,7 +1469,9 @@ SUBROUTINE theta_and_thetam_lbc_only ( & DO jj = MAX(jts,1) , MIN(jte,jde-1,spec_bdy_width) j = jj DO k = kts , kte-1 - DO i = MAX(1,its-4) , MIN(ite+4,ide-1) +! DO i = MAX(1,its-4) , MIN(ite+4,ide-1) +! DO i = MAX(1,its,ips-4) , MIN(ite,ipe+4,ide-1) + DO i = MAX(1,i_min) , MIN(i_max,ide-1) mu_old_bdy_ys = mu_bdy_ys(i,1,j) + mub(i,jj) t_old_bdy_ys = ( t_bdy_ys(i,k,j) ) / mu_old_bdy_ys moist_old_bdy_ys = ( moist_bdy_ys(i,k,j) ) / mu_old_bdy_ys @@ -1479,7 +1499,9 @@ SUBROUTINE theta_and_thetam_lbc_only ( & DO jj = MIN(jde-1,jte) , MAX(jde-spec_bdy_width,jts) , -1 j = jde-jj DO k = kts , kte-1 - DO i = MAX(1,its-4) , MIN(ite+4,ide-1) +! DO i = MAX(1,its-4) , MIN(ite+4,ide-1) +! DO i = MAX(1,its,ips-4) , MIN(ite,ipe+4,ide-1) + DO i = MAX(1,i_min) , MIN(i_max,ide-1) mu_old_bdy_ye = mu_bdy_ye(i,1,j) + mub(i,jj) t_old_bdy_ye = ( t_bdy_ye(i,k,j) ) / mu_old_bdy_ye moist_old_bdy_ye = ( moist_bdy_ye(i,k,j) ) / mu_old_bdy_ye @@ -1501,6 +1523,22 @@ SUBROUTINE theta_and_thetam_lbc_only ( & END DO END DO + ! The j_min, j_max for the west and east boundaries depends on if we are doing + ! serial, OpenMP, or MPI. For OpenMP, we do not want any overlap between tiles that + ! are on the same task (either OpenMP only, or OpenMP+MPI). + + IF ( jts .EQ. jps ) THEN + j_min = jps-4 + ELSE + j_min = jts + END IF + + IF ( jte .EQ. jpe ) THEN + j_max = jpe+4 + ELSE + j_max = jte + END IF + ! West and east lateral boundaries. This is the j-extent of jts through jte, but i only ! goes to within spec_bdy_width of the left and right (west and east) boundaries. @@ -1510,7 +1548,9 @@ SUBROUTINE theta_and_thetam_lbc_only ( & DO ii = MAX(its,1) , MIN(ite,ide-1,spec_bdy_width) i = ii DO k = kts , kte-1 - DO j = MAX(1,jts-4) , MIN(jte+4,jde-1) +! DO j = MAX(1,jts-4) , MIN(jte+4,jde-1) +! DO j = MAX(1,jts,jps-4) , MIN(jte,jpe+4,jde-1) + DO j = MAX(1,j_min) , MIN(j_max,jde-1) mu_old_bdy_xs = mu_bdy_xs(j,1,i) + mub(ii,j) t_old_bdy_xs = ( t_bdy_xs(j,k,i) ) / mu_old_bdy_xs moist_old_bdy_xs = ( moist_bdy_xs(j,k,i) ) / mu_old_bdy_xs @@ -1538,7 +1578,9 @@ SUBROUTINE theta_and_thetam_lbc_only ( & DO ii = MIN(ide-1,ite) , MAX(ide-spec_bdy_width,its) , -1 i = ide-ii DO k = kts , kte-1 - DO j = MAX(1,jts-4) , MIN(jte+4,jde-1) +! DO j = MAX(1,jts-4) , MIN(jte+4,jde-1) +! DO j = MAX(1,jts,jps-4) , MIN(jte,jpe+4,jde-1) + DO j = MAX(1,j_min) , MIN(j_max,jde-1) mu_old_bdy_xe = mu_bdy_xe(j,1,i) + mub(ii,j) t_old_bdy_xe = ( t_bdy_xe(j,k,i) ) / mu_old_bdy_xe moist_old_bdy_xe = ( moist_bdy_xe(j,k,i) ) / mu_old_bdy_xe diff --git a/wrfv2_fire/dyn_em/module_big_step_utilities_em.F b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F index e117a54d..ef87db4c 100644 --- a/wrfv2_fire/dyn_em/module_big_step_utilities_em.F +++ b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F @@ -2137,7 +2137,8 @@ END SUBROUTINE rhs_ph SUBROUTINE horizontal_pressure_gradient( ru_tend,rv_tend, & ph,alt,p,pb,al,php,cqu,cqv, & muu,muv,mu,fnm,fnp,rdnw, & - cf1,cf2,cf3,rdx,rdy,msfux,msfuy,& + cf1,cf2,cf3,cfn,cfn1, & + rdx,rdy,msfux,msfuy,& msfvx,msfvy,msftx,msfty, & config_flags, non_hydrostatic, & top_lid, & @@ -2180,7 +2181,7 @@ SUBROUTINE horizontal_pressure_gradient( ru_tend,rv_tend, & REAL, DIMENSION( kms:kme ), INTENT(IN ) :: rdnw, fnm, fnp - REAL, INTENT(IN ) :: rdx, rdy, cf1, cf2, cf3 + REAL, INTENT(IN ) :: rdx, rdy, cf1, cf2, cf3, cfn, cfn1 INTEGER :: i,j,k, itf, jtf, ktf, i_start, j_start REAL, DIMENSION( ims:ime, kms:kme ) :: dpn @@ -2239,9 +2240,8 @@ SUBROUTINE horizontal_pressure_gradient( ru_tend,rv_tend, & ENDDO IF (top_lid) THEN DO i = i_start, itf - dpn(i,kde) = .5*( cf1*(p(i,kde-1,j-1)+p(i,kde-1,j)) & - +cf2*(p(i,kde-2,j-1)+p(i,kde-2,j)) & - +cf3*(p(i,kde-3,j-1)+p(i,kde-3,j)) ) + dpn(i,kde) = .5*( cfn *(p(i,kde-1,j-1)+p(i,kde-1,j)) & + +cfn1*(p(i,kde-2,j-1)+p(i,kde-2,j)) ) ENDDO ENDIF @@ -2279,7 +2279,7 @@ SUBROUTINE horizontal_pressure_gradient( ru_tend,rv_tend, & (ph (i,k+1,j)-ph (i,k+1,j-1) + ph(i,k,j)-ph(i,k,j-1)) & +(alt(i,k ,j)+alt(i,k ,j-1))*(p (i,k,j)-p (i,k,j-1)) & +(al (i,k ,j)+al (i,k ,j-1))*(pb(i,k,j)-pb(i,k,j-1)) ) - rv_tend(i,k,j) = rv_tend(i,k,j)-cqv(i,k,j)*dpy + rv_tend(i,k,j) = rv_tend(i,k,j)-dpy END DO END DO @@ -2315,9 +2315,8 @@ SUBROUTINE horizontal_pressure_gradient( ru_tend,rv_tend, & ENDDO IF (top_lid) THEN DO i = i_start, itf - dpn(i,kde) = .5*( cf1*(p(i-1,kde-1,j)+p(i,kde-1,j)) & - +cf2*(p(i-1,kde-2,j)+p(i,kde-2,j)) & - +cf3*(p(i-1,kde-3,j)+p(i,kde-3,j)) ) + dpn(i,kde) = .5*( cfn *(p(i-1,kde-1,j)+p(i,kde-1,j)) & + +cfn1*(p(i-1,kde-2,j)+p(i,kde-2,j)) ) ENDDO ENDIF @@ -2355,7 +2354,7 @@ SUBROUTINE horizontal_pressure_gradient( ru_tend,rv_tend, & (ph (i,k+1,j)-ph (i-1,k+1,j) + ph(i,k,j)-ph(i-1,k,j)) & +(alt(i,k ,j)+alt(i-1,k ,j))*(p (i,k,j)-p (i-1,k,j)) & +(al (i,k ,j)+al (i-1,k ,j))*(pb(i,k,j)-pb(i-1,k,j)) ) - ru_tend(i,k,j) = ru_tend(i,k,j)-cqu(i,k,j)*dpx + ru_tend(i,k,j) = ru_tend(i,k,j)-dpx END DO END DO @@ -6253,6 +6252,40 @@ END SUBROUTINE sixth_order_diffusion !============================================================================== +SUBROUTINE initialize_moist_old ( moist_old , moist , & + ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + its, ite, jts, jte, kts, kte ) + + ! For the theta_m option, the moist_old variable is uninitialized + ! at the beginning of EACH of the RK steps. So, just set the + ! starting value of moist_old as the final value of moist from the + ! previous time step. Here "moist" is only the P_Qv index. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde , & + ims, ime, jms, jme, kms, kme , & + its, ite, jts, jte, kts, kte + REAL , INTENT(IN ) , DIMENSION(ims:ime,kms:kme,jms:jme) :: moist + REAL , INTENT( OUT) , DIMENSION(ims:ime,kms:kme,jms:jme) :: moist_old + + ! Local variables + + INTEGER :: i , j , k + + DO j = jts , MIN(jte,jde-1) + DO k = kts , kte-1 + DO i = its , MIN(ite,ide-1) + moist_old(i,k,j) = moist(i,k,j) + END DO + END DO + END DO + +END SUBROUTINE initialize_moist_old + +!============================================================================== + SUBROUTINE theta_to_thetam ( t_1 , moist_old , & t_tendf , moist_tend , & t_2 , moist , & @@ -6280,18 +6313,6 @@ SUBROUTINE theta_to_thetam ( t_1 , moist_old , & INTEGER :: i , j , k - ! First time step, there is no OLD moisture. - - IF ( ( itimestep .EQ. 1 ) .AND. ( rk_step .EQ. 1 ) ) THEN - DO j = jts , MIN(jte,jde-1) - DO k = kts , kte-1 - DO i = its , MIN(ite,ide-1) - moist_old(i,k,j) = moist(i,k,j) - END DO - END DO - END DO - END IF - ! First RK loop, this info is from the physics packages. It is modified immediately after the ! call to the physics schemes, and the remains constant for the remainder of the RK loops. @@ -6311,8 +6332,8 @@ SUBROUTINE theta_to_thetam ( t_1 , moist_old , & DO j = jts , MIN(jte,jde-1) DO k = kts , kte-1 DO i = its , MIN(ite,ide-1) - t_1(i,k,j) = t_1(i,k,j) * (1. + (R_v/R_d) * moist_old(i,k,j)) + T0*(R_v/R_d)*moist_old(i,k,j) - t_2(i,k,j) = t_2(i,k,j) * (1. + (R_v/R_d) * moist(i,k,j)) + T0*(R_v/R_d)*moist(i,k,j) + t_1(i,k,j) = ( t_1(i,k,j) + T0 ) * (1. + (R_v/R_d) * moist_old(i,k,j)) - T0 + t_2(i,k,j) = ( t_2(i,k,j) + T0 ) * (1. + (R_v/R_d) * moist(i,k,j)) - T0 END DO END DO END DO diff --git a/wrfv2_fire/dyn_em/module_diffusion_em.F b/wrfv2_fire/dyn_em/module_diffusion_em.F index f2850acc..0f58472f 100644 --- a/wrfv2_fire/dyn_em/module_diffusion_em.F +++ b/wrfv2_fire/dyn_em/module_diffusion_em.F @@ -4845,7 +4845,7 @@ SUBROUTINE cal_titau_23_32( config_flags, titau, defor, & END DO END DO - IF ( config_flags%sfs_opt .EQ. 1 ) THEN ! USE NBA MODEL SFS STRESSES + IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES DO j = j_start, j_end DO k = kts+1, ktf diff --git a/wrfv2_fire/dyn_em/module_em.F b/wrfv2_fire/dyn_em/module_em.F index c3d7a890..9383c663 100644 --- a/wrfv2_fire/dyn_em/module_em.F +++ b/wrfv2_fire/dyn_em/module_em.F @@ -519,10 +519,11 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CALL horizontal_pressure_gradient( ru_tend,rv_tend, & + CALL horizontal_pressure_gradient( ru_tend,rv_tend, & ph,alt,p,pb,al,php,cqu,cqv, & muu,muv,mu,fnm,fnp,rdnw, & - cf1,cf2,cf3,rdx,rdy,msfux,msfuy,& + cf1,cf2,cf3,cfn,cfn1, & + rdx,rdy,msfux,msfuy, & msfvx,msfvy,msftx,msfty, & config_flags, non_hydrostatic, & top_lid, & diff --git a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F index 4e13b087..dd9b7c0f 100644 --- a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F +++ b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F @@ -19,7 +19,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & , ph_tendf, mu_tendf & , tke_tend & , adapt_step_flag , curr_secs & - , psim , psih , wspd , gz1oz0 , br , chklowq & + , psim , psih , wspd , gz1oz0 , chklowq & , cu_act_flag , hol , th_phy & , pi_phy , p_phy , t_phy & , dz8w , p8w , t8w & @@ -88,7 +88,6 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: psih REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: wspd REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: gz1oz0 - REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: br REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: chklowq LOGICAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: cu_act_flag REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: hol @@ -298,6 +297,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,aer_asy_opt=config_flags%aer_asy_opt,aer_asy_val=config_flags%aer_asy_val & & ,aod5502d=grid%aod5502d,angexp2d=grid%angexp2d,aerssa2d=grid%aerssa2d & & ,aerasy2d=grid%aerasy2d,aod5503d=grid%aod5503d & + & ,taod5502d=grid%taod5502d,taod5503d=grid%taod5503d & ! Trude !Optional solar variables & ,DECLINX=grid%declin ,SOLCONX=grid%solcon ,COSZEN=grid%coszen ,HRANG=grid%hrang & & , CEN_LAT=grid%cen_lat & @@ -310,6 +310,13 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,CAM_ABS_FREQ_S=grid%cam_abs_freq_s & & ,XTIME=grid%xtime & ,CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag & +!BSINGH - For WRFCuP scheme + & ,CU_PHYSICS=config_flags%cu_physics & !CuP, wig 5-Oct-2006 + & ,SHALLOWCU_FORCED_RA=config_flags%shallowcu_forced_ra & !CuP, wig + & ,CUBOT=grid%cubot, CUTOP=grid%cutop & !CuP, wig 9-Oct-2006 + & ,CLDFRA_CUP=grid%cldfra_cup & !CuP, wig 1-Oct-2006 + & ,SHALL=grid%shall & !CuP, wig 4-Feb-2008 +!BSINGH - ENDS ! indexes & ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & & ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & @@ -331,6 +338,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & , LRADIUS=grid%LRADIUS,IRADIUS=grid%IRADIUS & !BSINGH(01/22/2014) & , CLDFRA_DP=grid%cldfra_dp & ! ckay for subgrid cloud & , CLDFRA_SH=grid%cldfra_sh & + & , icloud_bl=config_flags%icloud_bl & !JOE: subgrid BL clouds + & , qc_bl=grid%qc_bl,cldfra_bl=grid%cldfra_bl & !JOE: subgrid bl clouds & , re_cloud=grid%re_cloud, re_ice=grid%re_ice, re_snow=grid%re_snow & ! G. Thompson & , has_reqc=grid%has_reqc, has_reqi=grid%has_reqi, has_reqs=grid%has_reqs & ! G. Thompson & , PB=grid%pb & @@ -342,6 +351,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & , QS=moist(ims,kms,jms,P_QS), F_QS=F_QS & & , QG=moist(ims,kms,jms,P_QG), F_QG=F_QG & & , QNDROP=scalar(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP & + & ,QNIFA=scalar(ims,kms,jms,P_QNIFA),F_QNIFA=F_QNIFA & !Trude + & ,QNWFA=scalar(ims,kms,jms,P_QNWFA),F_QNWFA=F_QNWFA & !Trude & ,ACSWUPT=grid%acswupt ,ACSWUPTC=grid%acswuptc & & ,ACSWDNT=grid%acswdnt ,ACSWDNTC=grid%acswdntc & & ,ACSWUPB=grid%acswupb ,ACSWUPBC=grid%acswupbc & @@ -390,7 +401,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,slope_rad=config_flags%slope_rad,topo_shading=config_flags%topo_shading & & ,shadowmask=grid%shadowmask,ht=grid%ht,dx=grid%dx,dy=grid%dy & & ,diffuse_frac=grid%diffuse_frac & - & ,IS_CAMMGMP_USED = grid%is_CAMMGMP_used ) + & ,IS_CAMMGMP_USED = grid%is_CAMMGMP_used & + & ,MP_PHYSICS=CONFIG_FLAGS%MP_PHYSICS ) BENCH_END(rad_driver_tim) @@ -437,7 +449,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,ACSNOM=grid%acsnom ,ACSNOW=grid%acsnow ,AKHS=grid%akhs & & ,AKMS=grid%akms ,ALBBCK=grid%albbck ,ALBEDO=grid%albedo & & ,EMBCK=grid%embck & - & ,BR=br ,CANWAT=grid%canwat ,CHKLOWQ=chklowq & + & ,BR=grid%br ,CANWAT=grid%canwat ,CHKLOWQ=chklowq & & ,CT=grid%ct ,DT=grid%dt ,DX=grid%dx & & ,DZ8W=dz8w ,DZS=grid%dzs ,FLHC=grid%flhc & & ,FM=grid%fm ,FHH=grid%fh & @@ -468,6 +480,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,RA_LW_PHYSICS=config_flags%ra_lw_physics ,RHO=grid%rho & & ,RMOL=grid%rmol ,SFCEVP=grid%sfcevp ,SFCEXC=grid%sfcexc & & ,SFCRUNOFF=grid%sfcrunoff & + & ,opt_thcnd=config_flags%opt_thcnd & & ,SF_SFCLAY_PHYSICS=config_flags%sf_sfclay_physics & & ,SF_SURFACE_PHYSICS=config_flags%sf_surface_physics ,SH2O=grid%sh2o & & ,SHDMAX=grid%shdmax ,SHDMIN=grid%shdmin ,SMOIS=grid%smois & @@ -505,6 +518,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,TML=grid%tml, T0ML=grid%t0ml, HML=grid%hml, H0ML=grid%h0ml & & ,HUML=grid%huml, HVML=grid%hvml, F=grid%f & & ,TMOML=grid%TMOML,ISWATER=iswater & + & ,OML_RELAXATION_TIME=grid%OML_RELAXATION_TIME & & ,lakedepth2d=grid%lakedepth2d, savedtke12d=grid%savedtke12d & & ,snowdp2d=grid%snowdp2d, h2osno2d=grid%h2osno2d & !lake & ,snl2d=grid%snl2d, t_grnd2d=grid%t_grnd2d & @@ -702,6 +716,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,iopt_inf=config_flags%opt_inf, iopt_rad=config_flags%opt_rad & & ,iopt_alb=config_flags%opt_alb, iopt_snf=config_flags%opt_snf & & ,iopt_tbot=config_flags%opt_tbot, iopt_stc=config_flags%opt_stc & + & ,iopt_gla=config_flags%opt_gla, iopt_rsf=config_flags%opt_rsf & & , isnowxy=grid%isnowxy , tvxy=grid%tvxy , tgxy=grid%tgxy & & ,canicexy=grid%canicexy ,canliqxy=grid%canliqxy, eahxy=grid%eahxy & & , tahxy=grid%tahxy , cmxy=grid%cmxy , chxy=grid%chxy & @@ -711,6 +726,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & , zsnsoxy=grid%zsnsoxy , snicexy=grid%snicexy , snliqxy=grid%snliqxy & & ,lfmassxy=grid%lfmassxy ,rtmassxy=grid%rtmassxy,stmassxy=grid%stmassxy & & , woodxy=grid%woodxy ,stblcpxy=grid%stblcpxy,fastcpxy=grid%fastcpxy & + & , grainxy=grid%grainxy , gddxy=grid%gddxy & & , xsaixy=grid%xsaixy , taussxy=grid%taussxy & & , t2mvxy=grid%t2mvxy , t2mbxy=grid%t2mbxy & & , q2mvxy=grid%q2mvxy , q2mbxy=grid%q2mbxy & @@ -782,7 +798,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,ch=grid%ch,tsq=grid%tsq,qsq=grid%qsq,cov=grid%cov & !MYNN - MP & ,Sh3d=grid%sh3d,EL_PBL=grid%el_pbl & !JOE- MYNN cloudpdf & ,bl_mynn_cloudpdf=config_flags%bl_mynn_cloudpdf & !JOE- MYNN cloudpdf - & ,fgdp=grid%fgdp,dfgdp=grid%dfgdp,vdfg=grid%vdfg & !Katata - fogdes + & ,icloud_bl=config_flags%icloud_bl & !JOE- subgrid cloud + & ,qc_bl=grid%qc_bl,cldfra_bl=grid%cldfra_bl & !JOE- subgrid cloud + & ,fgdp=grid%fgdp,dfgdp=grid%dfgdp,vdfg=grid%vdfg & !Katata - fogdes & ,grav_settling=config_flags%grav_settling & !Katata - fogdes & ,OM_TMP=grid%om_tmp, OM_S=grid%om_s, OM_U=grid%om_u, OM_V=grid%om_v & !cyl:3DPWP & ,OM_DEPTH=grid%om_depth, OM_ML=grid%OM_ML, OM_LON=grid%om_lon & !cyl:3DPWP @@ -803,14 +821,17 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,GRDFLX_mosaic=grid%GRDFLX_mosaic,SNOTIME_mosaic=grid%SNOTIME_mosaic & !danli mosaic & ,TR_URB2D_mosaic=grid%TR_URB2D_mosaic,TB_URB2D_mosaic=grid%TB_URB2D_mosaic & !danli mosaic & ,TG_URB2D_mosaic=grid%TG_URB2D_mosaic,TC_URB2D_mosaic=grid%TC_URB2D_mosaic & !danli mosaic - & ,QC_URB2D_mosaic=grid%QC_URB2D_mosaic,UC_URB2D_mosaic=grid%UC_URB2D_mosaic & !danli mosaic + & ,QC_URB2D_mosaic=grid%QC_URB2D_mosaic,UC_URB2D_mosaic=grid%UC_URB2D_mosaic & !danli mosaic & ,TRL_URB3D_mosaic=grid%TRL_URB3D_mosaic,TBL_URB3D_mosaic=grid%TBL_URB3D_mosaic & !danli mosaic & ,TGL_URB3D_mosaic=grid%TGL_URB3D_mosaic & !danli mosaic & ,SH_URB2D_mosaic=grid%SH_URB2D_mosaic,LH_URB2D_mosaic=grid%LH_URB2D_mosaic & !danli mosaic & ,G_URB2D_mosaic=grid%G_URB2D_mosaic,RN_URB2D_mosaic=grid%RN_URB2D_mosaic & !danli mosaic & ,TS_URB2D_mosaic=grid%TS_URB2D_mosaic & !danli mosaic - & ,TS_RUL2D_mosaic=grid%TS_RUL2D_mosaic & !danli mosaic - & ,ZOL=grid%ZOL ) + & ,TS_RUL2D_mosaic=grid%TS_RUL2D_mosaic & !danli mosaic + & ,ZOL=grid%ZOL & + & ,SDA_HFX=grid%SDA_HFX, SDA_QFX=grid%SDA_QFX,HFX_BOTH=grid%HFX_BOTH & !fasdas + & ,QFX_BOTH=grid%QFX_BOTH,QNORM=grid%QNORM,fasdas=config_flags%fasdas & !fasdas + & ) #ifdef WRF_HYDRO if(HYDRO_dt .gt. 1 ) call wrf_drv_HYDRO(HYDRO_dt, grid, & @@ -831,7 +852,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,WINDFARM_OPT=config_flags%windfarm_opt,power=grid%power & & ,BLDT=grid%bldt, CURR_SECS=curr_secs, ADAPT_STEP_FLAG=adapt_step_flag & & ,BLDTACTTIME=grid%bldtacttime & - & ,BR=br ,CHKLOWQ=chklowq ,CT=grid%ct & + & ,BR=grid%br ,CHKLOWQ=chklowq ,CT=grid%ct & & ,DT=grid%dt ,DX=grid%dx ,DY=grid%dy & & ,DZ8W=dz8w & & ,EXCH_H=grid%exch_h ,EXCH_M=grid%exch_m & @@ -851,7 +872,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,TSK=grid%tsk ,T_PHY=grid%t_phy ,UST=grid%ust & & ,U10=grid%u10 ,UZ0=grid%uz0 ,U_FRAME=grid%u_frame ,U_PHY=grid%u_phy & & ,V10=grid%v10 ,VZ0=grid%vz0 ,V_FRAME=grid%v_frame ,V_PHY=grid%v_phy & - & ,UOCE=grid%uoce ,VOCE=grid%voce & + & ,W=grid%w_2 ,UOCE=grid%uoce ,VOCE=grid%voce & ,T2=grid%t2 & & ,WARM_RAIN=grid%warm_rain ,WSPD=wspd & & ,XICE=grid%xice ,XLAND=grid%xland ,Z=grid%z & @@ -916,6 +937,18 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,QSHEAR=grid%qSHEAR,QBUOY=grid%qBUOY,QDISS=grid%qDISS & & ,bl_mynn_tkebudget=config_flags%bl_mynn_tkebudget & & ,bl_mynn_cloudpdf=config_flags%bl_mynn_cloudpdf & + & ,bl_mynn_mixlength=config_flags%bl_mynn_mixlength & + & , icloud_bl=config_flags%icloud_bl & !JOE: subgrid cloud + & , qc_bl=grid%qc_bl,cldfra_bl=grid%cldfra_bl & !JOE: subgrid cloud + & ,bl_mynn_edmf=config_flags%bl_mynn_edmf & !JOE- MYNN edmf + & ,bl_mynn_edmf_mom=config_flags%bl_mynn_edmf_mom & !JOE- MYNN edmf + & ,bl_mynn_edmf_tke=config_flags%bl_mynn_edmf_tke & !JOE- MYNN edmf + & ,bl_mynn_edmf_part=config_flags%bl_mynn_edmf_part & !JOE- MYNN edmf + & ,bl_mynn_cloudmix=config_flags%bl_mynn_cloudmix & !JOE- MYNN cloud mixing + & ,bl_mynn_mixqt=config_flags%bl_mynn_mixqt & !JOE- MYNN tendency method + & ,edmf_a=grid%edmf_a,edmf_w=grid%edmf_w & + & ,edmf_thl=grid%edmf_thl,edmf_qt=grid%edmf_qt & + & ,edmf_ent=grid%edmf_ent,edmf_qc=grid%edmf_qc & !JOE- MYNN edmf & ,rmol=grid%rmol, ch=grid%ch & & ,qcg=grid%qcg, grav_settling=config_flags%grav_settling & ! & ,K_m=grid%K_m, K_h=grid%K_h, K_q=grid%K_q & @@ -961,8 +994,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,CHEM=chem,VD=grid%dep_vel & & ,NCHEM=num_chem,kdvel=config_flags%kdepvel & & ,ndvel=config_flags%ndepvel & - & ,NUM_VERT_MIX=grid%num_vert_mix & + & ,NUM_VERT_MIX=grid%num_vert_mix & #endif + & ,QNORM=grid%QNORM, fasdas=config_flags%fasdas & !fasdas & ) BENCH_END(pbl_driver_tim) @@ -1017,6 +1051,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,NCA=grid%nca & & ,CLDFRA_DP=grid%cldfra_dp ,CLDFRA_SH=grid%cldfra_sh,W_UP=grid%w_up & ! ckay for subgrid cloud & ,QC_CU=grid%QC_CU ,QI_CU=grid%QI_CU & + & ,UDR_KF=grid%udr_kf,DDR_KF=grid%ddr_kf & ! kf_edrates + & ,UER_KF=grid%uer_kf,DER_KF=grid%der_kf,TIMEC_KF=grid%timec_kf & + & ,KF_EDRATES=config_flags%kf_edrates & & ,HTOP=grid%cutop ,HBOT=grid%cubot ,KPBL=grid%kpbl & & ,Z=grid%z ,Z_AT_W=grid%z_at_w ,MAVAIL=grid%mavail ,PBLH=grid%pblh & & ,DZ8W=dz8w ,P8W=grid%p_hyd_w, PSFC=grid%psfc, TSK=grid%tsk & @@ -1040,7 +1077,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,TPERT2D=grid%tpert2d & & ,GSW=grid%gsw,cugd_avedx=config_flags%cugd_avedx & !BSINGH - For WRFCuP scheme - & ,AKPBL=grid%akpbl,BR=br, REGIME=grid%regime, T2=grid%t2, Q2=grid%q2 & !CuP, wig 3-Aug-2006 + & ,AKPBL=grid%akpbl,BR=grid%br, REGIME=grid%regime, T2=grid%t2, Q2=grid%q2 & !CuP, wig 3-Aug-2006 & ,SLOPESFC=grid%slopeSfc, SLOPEEZ=grid%slopeEZ & !CuP, wig 7-Aug-2006 & ,SIGMASFC=grid%sigmaSfc, SIGMAEZ=grid%sigmaEZ & !CuP, wig 7-Aug-2006 & ,CUPFLAG=grid%cupflag & !CuP, wig 9-Oct-2006 @@ -1349,6 +1386,14 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & RUNDGDTEN=grid%rundgdten,RVNDGDTEN=grid%rvndgdten, & RTHNDGDTEN=grid%rthndgdten,RPHNDGDTEN=grid%rphndgdten, & RQVNDGDTEN=grid%rqvndgdten,RMUNDGDTEN=grid%rmundgdten, & +! +! FASDAS +! + SDA_HFX=grid%SDA_HFX, SDA_QFX=grid%SDA_QFX, & + HFX_FDDA=grid%HFX_FDDA, & +! +! END FASDAS +! u_ndg_old=fdda3d(ims,kms,jms,P_u_ndg_old), & v_ndg_old=fdda3d(ims,kms,jms,P_v_ndg_old), & t_ndg_old=fdda3d(ims,kms,jms,P_t_ndg_old), & diff --git a/wrfv2_fire/dyn_em/module_first_rk_step_part2.F b/wrfv2_fire/dyn_em/module_first_rk_step_part2.F index 8f6bc7b7..8f012328 100644 --- a/wrfv2_fire/dyn_em/module_first_rk_step_part2.F +++ b/wrfv2_fire/dyn_em/module_first_rk_step_part2.F @@ -18,7 +18,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & , ph_tendf, mu_tendf & , tke_tend & , adapt_step_flag , curr_secs & - , psim , psih , wspd , gz1oz0 , br , chklowq & + , psim , psih , wspd , gz1oz0 , chklowq & , cu_act_flag , hol , th_phy & , pi_phy , p_phy , t_phy & , dz8w , p8w , t8w & @@ -92,7 +92,6 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: psih REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: wspd REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: gz1oz0 - REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: br REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: chklowq LOGICAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: cu_act_flag REAL ,DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: hol diff --git a/wrfv2_fire/dyn_em/module_initialize_b_wave.F b/wrfv2_fire/dyn_em/module_initialize_b_wave.F index a141ba63..a4804b41 100644 --- a/wrfv2_fire/dyn_em/module_initialize_b_wave.F +++ b/wrfv2_fire/dyn_em/module_initialize_b_wave.F @@ -46,7 +46,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) @@ -56,7 +56,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -64,7 +64,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -406,7 +406,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) @@ -459,7 +459,7 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_convrad.F b/wrfv2_fire/dyn_em/module_initialize_convrad.F index 1ee67639..5eb7bf03 100644 --- a/wrfv2_fire/dyn_em/module_initialize_convrad.F +++ b/wrfv2_fire/dyn_em/module_initialize_convrad.F @@ -57,7 +57,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) END SUBROUTINE init_domain @@ -66,7 +66,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -74,7 +74,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -106,7 +106,7 @@ SUBROUTINE init_domain_rk ( grid & character (len=256) :: mminlu2 #ifdef DM_PARALLEL -# include +# include "data_calls.inc" #endif @@ -443,7 +443,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) @@ -483,7 +483,7 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_fire.F b/wrfv2_fire/dyn_em/module_initialize_fire.F index bf6ca6be..d4387656 100644 --- a/wrfv2_fire/dyn_em/module_initialize_fire.F +++ b/wrfv2_fire/dyn_em/module_initialize_fire.F @@ -55,7 +55,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) @@ -65,7 +65,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -73,7 +73,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -730,7 +730,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) @@ -791,7 +791,7 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_grav2d_x.F b/wrfv2_fire/dyn_em/module_initialize_grav2d_x.F index 8f1f7139..48e29779 100644 --- a/wrfv2_fire/dyn_em/module_initialize_grav2d_x.F +++ b/wrfv2_fire/dyn_em/module_initialize_grav2d_x.F @@ -53,7 +53,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) @@ -63,7 +63,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -71,7 +71,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -108,7 +108,7 @@ SUBROUTINE init_domain_rk ( grid & REAL :: xa1, xal1,pii,hm1 ! data for intercomparison setup from dale #ifdef DM_PARALLEL -# include +# include "data_calls.inc" #endif @@ -398,7 +398,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) @@ -466,7 +466,7 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_heldsuarez.F b/wrfv2_fire/dyn_em/module_initialize_heldsuarez.F index 6c2c3647..8ed6a47d 100644 --- a/wrfv2_fire/dyn_em/module_initialize_heldsuarez.F +++ b/wrfv2_fire/dyn_em/module_initialize_heldsuarez.F @@ -45,7 +45,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) @@ -55,7 +55,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -63,7 +63,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -391,7 +391,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = kts+1,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_hill2d_x.F b/wrfv2_fire/dyn_em/module_initialize_hill2d_x.F index a2edf6c5..d8fcfb46 100644 --- a/wrfv2_fire/dyn_em/module_initialize_hill2d_x.F +++ b/wrfv2_fire/dyn_em/module_initialize_hill2d_x.F @@ -57,7 +57,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) @@ -67,7 +67,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -75,7 +75,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -397,7 +397,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_les.F b/wrfv2_fire/dyn_em/module_initialize_les.F index 4fcc04fd..217d7da9 100644 --- a/wrfv2_fire/dyn_em/module_initialize_les.F +++ b/wrfv2_fire/dyn_em/module_initialize_les.F @@ -53,7 +53,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) @@ -63,7 +63,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -71,7 +71,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -111,8 +111,13 @@ SUBROUTINE init_domain_rk ( grid & ! For LES, add randx real :: randx + +!DJW added for specifying different eta levels for each domain + INTEGER :: ks, ke, id + LOGICAL :: vnest !DJW T if using vertical nesting, otherwise F + #ifdef DM_PARALLEL -# include +# include "data_calls.inc" #endif @@ -229,16 +234,76 @@ SUBROUTINE init_domain_rk ( grid & ! set up the grid + !DJW Added code for specifying multiple domains' eta_levels. + !First check to make sure that we've not specified more + !eta_levels than the dimensionality of eta_levels can handle! This + !issue will most likely cause a break sometime before we real this + !check, however it doesn't hurt to include it. To increase max_eta, + !go to frame/module_driver_constants.F. + vnest = .FALSE. + DO id=1,model_config_rec%max_dom + IF (model_config_rec%vert_refine_method(id) .NE. 0) THEN + vnest = .TRUE. + ENDIF + ENDDO + + IF (model_config_rec%eta_levels(1) .EQ. -1) THEN !we do not have eta_levels from namelist + !DJW start of original code to set eta levels IF (stretch_grid) THEN ! exponential stretch for eta (nearly constant dz) + CALL wrf_debug(0, "module_initialize_les: eta_levels is not specified in the namelist, setting levels with stretched spacing in eta.") DO k=1, kde grid%znw(k) = (exp(-(k-1)/float(kde-1)/z_scale) - exp(-1./z_scale))/ & (1.-exp(-1./z_scale)) ENDDO ELSE + CALL wrf_debug(0,"module_initialize_les: eta_levels is not specified in the namelist, setting levels with constant spacing in eta.") DO k=1, kde grid%znw(k) = 1. - float(k-1)/float(kde-1) ENDDO ENDIF + ELSE !we have specified eta levels from the namelist + CALL wrf_debug(0,"module_initialize_les: vertical nesting is enabled, using eta_levels specified in namelist.input") + ks = 0 + DO id=1,grid%id + ks = ks+model_config_rec%e_vert(id) + ENDDO + IF (ks .GT. max_eta) THEN + CALL wrf_error_fatal("too many vertical levels, increase max_eta in frame/module_driver_constants.F") + ENDIF + !Now set the eta_levels to what we specified in the namelist. We've + !packed all the domains' eta_levels into a 'vector' and now we need + !to pull only the section of the vector associated with our domain + !of interest, which is between indicies ks and ke. + IF (grid%id .EQ. 1) THEN + ks = 1 + ke = model_config_rec%e_vert(1) + ELSE + id = 1 + ks = 1 + ke = 0 + DO WHILE (grid%id .GT. id) + id = id+1 + ks = ks+model_config_rec%e_vert(id-1) + ke = ks+model_config_rec%e_vert(id) + ENDDO + ENDIF + DO k=1,kde + grid%znw(k) = model_config_rec%eta_levels(ks+k-1) + ENDDO + !Check the value of the first and last eta level for our domain, + !then check that the vector of eta levels is only decreasing + IF (grid%znw(1) .NE. 1.0) THEN + CALL wrf_error_fatal("error with specified eta_levels, first level is not 1.0") + ENDIF + IF (grid%znw(kde) .NE. 0.0) THEN + CALL wrf_error_fatal("error with specified eta_levels, last level is not 0.0") + ENDIF + DO k=2,kde + IF (grid%znw(k) .GT. grid%znw(k-1)) THEN + CALL wrf_error_fatal("eta_levels are not uniformly decreasing from 1.0 to 0.0") + ENDIF + ENDDO + ENDIF DO k=1, kde-1 grid%dnw(k) = grid%znw(k+1) - grid%znw(k) @@ -436,8 +501,8 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & - (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - & + grid%dnw(k-1)*((grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) grid%ph_2(i,k,j) = grid%ph_1(i,k,j) @@ -501,7 +566,7 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F b/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F index a2a8081c..d8c2913c 100644 --- a/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F +++ b/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F @@ -53,7 +53,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) @@ -63,7 +63,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -71,7 +71,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -426,7 +426,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) @@ -481,7 +481,7 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_real.F b/wrfv2_fire/dyn_em/module_initialize_real.F index 4e8ec5cb..18813521 100644 --- a/wrfv2_fire/dyn_em/module_initialize_real.F +++ b/wrfv2_fire/dyn_em/module_initialize_real.F @@ -157,9 +157,9 @@ SUBROUTINE init_domain_rk ( grid & REAL :: t_start , t_end REAL , ALLOCATABLE , DIMENSION(:,:) :: clat_glob - ! multiple specified sets of eta_levels + ! added for multiple specified sets of eta_levels with vertical grid nesting INTEGER :: ks, ke, id - LOGICAL :: vnest ! T if using vertical nesting, otherwise F + LOGICAL :: vnest !T if using vertical nesting with vet_refine_method=2, otherwise F INTEGER :: j_save @@ -176,9 +176,37 @@ SUBROUTINE init_domain_rk ( grid & ipsy, ipey, jpsy, jpey, kpsy, kpey ) its = ips ; ite = ipe ; jts = jps ; jte = jpe ; kts = kps ; kte = kpe - CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + ! Would the user prefer to forego the use of the level of max winds, or the + ! tropopause level data? This is an option the user may select. While the + ! additional data is able to provide good information (such as a better + ! resolution of the jet, a better kink for the tropopause), there are + ! horizontal gradients that are introduced. Near a boundary, these gradients + ! would be permanent (due to their inclusion in the LBC file). To turn "off" + ! the use of the max wind/trop data, set the flags for those levels to zero. + + flag_pmaxw = 0 + flag_pmaxwnn = 0 + flag_ptrop = 0 + flag_ptropnn = 0 + IF ( ( config_flags%use_maxw_level .EQ. 0 ) .AND. & + ( ( flag_tmaxw .EQ. 1 ) .OR. ( flag_umaxw .EQ. 1 ) .OR. ( flag_vmaxw .EQ. 1 ) .OR. ( flag_hgtmaxw .EQ. 1 ) ) ) THEN + flag_tmaxw = 0 + flag_umaxw = 0 + flag_vmaxw = 0 + flag_hgtmaxw = 0 + CALL wrf_debug ( 0 , 'Turning off use of MAX WIND level data in vertical interpolation' ) + END IF + IF ( ( config_flags%use_trop_level .EQ. 0 ) .AND. & + ( ( flag_ttrop .EQ. 1 ) .OR. ( flag_utrop .EQ. 1 ) .OR. ( flag_vtrop .EQ. 1 ) .OR. ( flag_hgttrop .EQ. 1 ) ) ) THEN + flag_ttrop = 0 + flag_utrop = 0 + flag_vtrop = 0 + flag_hgttrop = 0 + CALL wrf_debug ( 0 , 'Turning off use of TROPOPAUSE level data in vertical interpolation' ) + END IF + ! Lake Mask and depth assignment CALL nl_get_iswater ( grid%id , grid%iswater ) @@ -611,7 +639,7 @@ SUBROUTINE init_domain_rk ( grid & CALL wrf_error_fatal ( 'If the polar boundary condition is used, then fft_filter_lat must be set in namelist.input' ) END IF - IF ( config_flags%map_proj .EQ. PROJ_CASSINI ) THEN + IF ( ( config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( config_flags%polar ) ) THEN #if 1 dclat = 90./REAL(jde-jds) !(0.5 * 180/ny) DO j = jts, MIN(jte,jde-1) @@ -771,6 +799,9 @@ SUBROUTINE init_domain_rk ( grid & its, ite, jts, jte, 1,1 ) #endif #endif + ELSE IF ( ( config_flags%map_proj .NE. PROJ_CASSINI ) .AND. ( config_flags%polar ) ) THEN + WRITE ( a_message,* ) 'A global domain (polar = true) requires the Cassini projection' + CALL wrf_error_fatal ( a_message ) END IF ! If we have any input low-res surface pressure, we store it. @@ -1366,22 +1397,25 @@ SUBROUTINE init_domain_rk ( grid & ! Compute the eta levels if not defined already. IF ( grid%znw(1) .NE. 1.0 ) THEN + !DJW Check if any of the domains are going to use vertical + !nesting with vert_refine_method=2. If so, set vnest as true. vnest = .FALSE. DO id=1,model_config_rec%max_dom - IF (model_config_rec%vert_refine_method(id) .NE. 0) THEN + IF (model_config_rec%vert_refine_method(id) .EQ. 2) THEN vnest = .TRUE. ENDIF ENDDO - IF (vnest) THEN - - !Added code for specifying multiple domains' eta_levels. + !DJW If there are eta_levels defined in the namelist and at + !least one domain is using vertical nesting, then we need to read in + !the eta_levels. + IF ((model_config_rec%eta_levels(1) .NE. -1.0) .AND. (vnest)) THEN + !DJW Added code for specifying multiple domains' eta_levels. !First check to make sure that we've not specified more !eta_levels than the dimensionality of eta_levels can handle! This - !issue will most likely cause a break sometime before we real this + !issue will most likely cause a break sometime before this !check, however it doesn't hurt to include it. To increase max_eta, !go to frame/module_driver_constants.F. - - CALL wrf_debug ( 0, "using vertical nesting, reading in eta_levels specified in namelist.input" ) + CALL wrf_debug (0, "module_initialize_real: using vert_refine_method=2, reading in eta_levels from namelist.input") ks = 0 DO id=1,grid%id ks = ks+model_config_rec%e_vert(id) @@ -1410,22 +1444,51 @@ SUBROUTINE init_domain_rk ( grid & !Check the value of the first and last eta level for our domain, !then check that the vector of eta levels is only decreasing IF (eta_levels(1) .NE. 1.0) THEN - CALL wrf_error_fatal("error with specified eta_levels, first level is not 1.0") + CALL wrf_error_fatal("--- ERROR: the first specified eta_level is not 1.0") ENDIF IF (eta_levels(kde) .NE. 0.0) THEN - CALL wrf_error_fatal("error with specified eta_levels, last level is not 0.0") + CALL wrf_error_fatal("--- ERROR: the last specified eta_level is not 0.0") ENDIF DO k=2,kde IF (eta_levels(k) .GT. eta_levels(k-1)) THEN - CALL wrf_error_fatal("eta_levels are not uniformly decreasing from 1.0 to 0.0") + CALL wrf_error_fatal("--- ERROR: specified eta_levels are not uniformly decreasing from 1.0 to 0.0") ENDIF ENDDO - DO k=1,kde - write(a_message,'(A,I3,A,F5.3)') "eta_levels(",k,")=",eta_levels(k) - CALL wrf_message ( a_message ) + !DJW End of added code for specifying eta_levels + ELSE !We're not using vertical nesting with eta_levels defined for every domain + !DJW Check if we're doing vertical nesting with integer refinement. + vnest = .FALSE. + DO id=1,model_config_rec%max_dom + IF (model_config_rec%vert_refine_method(id) .EQ. 1) THEN + vnest = .TRUE. + ENDIF ENDDO - ELSE !We're not using vertical nesting + !DJW If we're doing vertical nesting using integer refinement and + !we've got eta_levels specified in the namelist then make sure they are + !for the parent domain and nothing else. + IF ((vnest) .AND. (model_config_rec%eta_levels(kde+1) .NE. -1.0)) THEN + write(wrf_err_message,'(A)') "--- ERROR: too many eta_levels defined in namelist.input." + CALL wrf_error_fatal( wrf_err_message ) + !DJW Check the value of the first and last eta level for our + !domain, then check that the vector of eta levels is only decreasing + ELSEIF ((vnest) .AND. (model_config_rec%eta_levels(1) .NE. -1.0)) THEN + CALL wrf_debug(0, "module_initialize_real: using vert_refine_method=1, reading in eta_levels for d01 from namelist.input") eta_levels(1:kde) = model_config_rec%eta_levels(1:kde) + IF (eta_levels(1) .NE. 1.0) THEN + CALL wrf_error_fatal("--- ERROR: the first specified eta_level is not 1.0") + ENDIF + IF (eta_levels(kde) .NE. 0.0) THEN + CALL wrf_error_fatal("--- ERROR: the last specified eta_level is not 0.0") + ENDIF + DO k=2,kde + IF (eta_levels(k) .GT. eta_levels(k-1)) THEN + CALL wrf_error_fatal("--- ERROR: specified eta_levels are not uniformly decreasing from 1.0 to 0.0") + ENDIF + ENDDO + ELSE + !DJW original code to set eta_levels + eta_levels(1:kde) = model_config_rec%eta_levels(1:kde) + ENDIF ENDIF max_dz = model_config_rec%max_dz @@ -1500,6 +1563,7 @@ SUBROUTINE init_domain_rk ( grid & CALL vert_interp ( grid%ght_gc , grid%pd_gc , grid%ph0 , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & flag_hgtmaxw , flag_hgttrop , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1554,6 +1618,7 @@ SUBROUTINE init_domain_rk ( grid & CALL vert_interp ( grid%rh_gc , grid%pd_gc , grid%u_1 , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1590,6 +1655,7 @@ SUBROUTINE init_domain_rk ( grid & interp_type = 2 CALL vert_interp ( grid%t_gc , grid%pd_gc , grid%t_2 , grid%pb , & grid%tmaxw , grid%ttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & flag_tmaxw , flag_ttrop , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1607,6 +1673,7 @@ SUBROUTINE init_domain_rk ( grid & interp_type = 1 CALL vert_interp ( grid%p_gc , grid%pd_gc , grid%p , grid%pb , & grid%pmaxw , grid%ptrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & flag_pmaxw , flag_ptrop , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1670,6 +1737,7 @@ SUBROUTINE init_domain_rk ( grid & IF ( im .EQ. P_QR ) THEN CALL vert_interp ( grid%qr_gc , grid%pd_gc , moist(:,:,:,P_QR) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1699,6 +1767,7 @@ SUBROUTINE init_domain_rk ( grid & END IF CALL vert_interp ( grid%qc_gc , grid%pd_gc , moist(:,:,:,P_QC) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1728,6 +1797,7 @@ SUBROUTINE init_domain_rk ( grid & END IF CALL vert_interp ( grid%qi_gc , grid%pd_gc , moist(:,:,:,P_QI) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1747,6 +1817,7 @@ SUBROUTINE init_domain_rk ( grid & IF ( im .EQ. P_QS ) THEN CALL vert_interp ( grid%qs_gc , grid%pd_gc , moist(:,:,:,P_QS) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1766,6 +1837,7 @@ SUBROUTINE init_domain_rk ( grid & IF ( im .EQ. P_QG ) THEN CALL vert_interp ( grid%qg_gc , grid%pd_gc , moist(:,:,:,P_QG) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1785,6 +1857,7 @@ SUBROUTINE init_domain_rk ( grid & IF ( im .EQ. P_QH ) THEN CALL vert_interp ( grid%qh_gc , grid%pd_gc , moist(:,:,:,P_QH) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1804,6 +1877,7 @@ SUBROUTINE init_domain_rk ( grid & IF ( im .EQ. P_QNI ) THEN CALL vert_interp ( grid%qni_gc , grid%pd_gc , scalar(:,:,:,P_QNI) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1823,6 +1897,7 @@ SUBROUTINE init_domain_rk ( grid & IF ( im .EQ. P_QNR ) THEN CALL vert_interp ( grid%qnr_gc , grid%pd_gc , scalar(:,:,:,P_QNR) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1848,6 +1923,7 @@ SUBROUTINE init_domain_rk ( grid & !HRRR - aerosol input from WPS CALL vert_interp ( grid%qnwfa_gc , grid%pd_gc , scalar(:,:,:,P_QNWFA) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1862,6 +1938,7 @@ SUBROUTINE init_domain_rk ( grid & else CALL vert_interp ( grid%QNWFA_now , grid%pd_gc , scalar(:,:,:,P_QNWFA) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1897,6 +1974,7 @@ SUBROUTINE init_domain_rk ( grid & ! HRRR - aerosol input from WPS CALL vert_interp ( grid%qnifa_gc , grid%pd_gc , scalar(:,:,:,P_QNIFA) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1911,6 +1989,7 @@ SUBROUTINE init_domain_rk ( grid & else CALL vert_interp ( grid%QNIFA_now , grid%pd_gc , scalar(:,:,:,P_QNIFA) , grid%pb , & grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & 0 , 0 , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1969,6 +2048,7 @@ SUBROUTINE init_domain_rk ( grid & CALL vert_interp ( grid%u_gc , grid%pd_gc , grid%u_2 , grid%pb , & grid%umaxw , grid%utrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & flag_umaxw , flag_utrop , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -1982,6 +2062,7 @@ SUBROUTINE init_domain_rk ( grid & CALL vert_interp ( grid%v_gc , grid%pd_gc , grid%v_2 , grid%pb , & grid%vmaxw , grid%vtrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & flag_vmaxw , flag_vtrop , & config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & config_flags%maxw_above_this_level , & @@ -2055,6 +2136,16 @@ SUBROUTINE init_domain_rk ( grid & grid%landusef(i,grid%islake,j) = 0. END DO END DO + IF ( config_flags%surface_input_source .EQ. 3 ) THEN + DO j=jts,MIN(jde-1,jte) + DO i=its,MIN(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + IF ( grid%lu_index(i,j) .EQ. grid%islake ) THEN + grid%lu_index(i,j) = grid%iswater + END IF + END DO + END DO + END IF END IF @@ -3286,17 +3377,210 @@ SUBROUTINE init_domain_rk ( grid & ! Compute pressure similarly to how computed within model, with final Qv. - DO j = jts, min(jde-1,jte) - DO k=kts,kte-1 - DO i = its, min(ide,ite) - qvf = 1.+rvovrd*moist(i,k,j,P_QV) - grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/ & - (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv & - -grid%pb(i,k,j) - grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + ! Do a re-balance or not? 0 = NOPE + + IF ( ( config_flags%rebalance .EQ. 0 ) .OR. & + ( ( config_flags%rebalance .EQ. 2 ) .AND. ( config_flags%vert_refine_method .NE. 2 ) ) ) THEN + + DO j = jts, min(jde-1,jte) + DO k=kts,kte-1 + DO i = its, min(ide,ite) + qvf = 1.+rvovrd*moist(i,k,j,P_QV) + grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/ & + (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv & + -grid%pb(i,k,j) + grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + ENDDO + ENDDO + ENDDO + + ELSE ! rebalance + + lev500 = 0 + DO j = jts, min(jde-1,jte) + DO i = its, min(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + + dpmu = 10001. + loop_count = 0 + + DO WHILE ( ( ABS(dpmu) .GT. 10. ) .AND. & + ( loop_count .LT. 5 ) ) + + loop_count = loop_count + 1 + + ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum + ! equation) down from the top to get the pressure perturbation. First get the pressure + ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. + + k = kte-1 + + qtot=0. + DO im = PARAM_FIRST_SCALAR, num_3d_m + qtot = qtot + moist(i,k,j,im) + ENDDO + qvf2 = 1./(1.+qtot) + qvf1 = qtot*qvf2 + + grid%p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf& + *(((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) + grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + + ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two + ! inverse density fields (total and perturbation). + + DO k=kte-2,1,-1 + qtot=0. + DO im = PARAM_FIRST_SCALAR, num_3d_m + qtot = qtot + 0.5*(moist(i,k,j,im)+moist(i,k+1,j,im)) + ENDDO + qvf2 = 1./(1.+qtot) + qvf1 = qtot*qvf2 + grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_2(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* & + (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) + grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + END DO + +#if 1 + ! This is the hydrostatic equation used in the model after the small timesteps. In + ! the model, grid%al (inverse density) is computed from the geopotential. + + IF (grid%hypsometric_opt == 1) THEN + + DO k = 2,kte + grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - & + grid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,k-1,j) & + + grid%mu_2(i,j)*grid%alb(i,k-1,j) ) + grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j) + END DO + + ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure. + ! Note that al*p approximates Rd*T and dLOG(p) does z. + ! Here T varies mostly linear with z, the first-order integration produces better result. + + ELSE IF (grid%hypsometric_opt == 2) THEN + + grid%ph_2(i,1,j) = grid%phb(i,1,j) + DO k = 2,kte + pfu = grid%mu0(i,j)*grid%znw(k) + grid%p_top + pfd = grid%mu0(i,j)*grid%znw(k-1) + grid%p_top + phm = grid%mu0(i,j)*grid%znu(k-1) + grid%p_top + grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu) + END DO + + DO k = 1,kte + grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j) + END DO + END IF +#else + ! Get the perturbation geopotential from the 3d height array from WPS. + + DO k = 2,kte + grid%ph_2(i,k,j) = grid%ph0(i,k,j)*g - grid%phb(i,k,j) + END DO +#endif + + ! Recompute density, simlar to what the model does. + + IF (grid%hypsometric_opt == 1) THEN + DO k=kts,kte-1 + grid%al(i,k,j)=-1./(grid%mub(i,j)+grid%mu_2(i,j))*(grid%alb(i,k,j)*grid%mu_2(i,j) & + +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j))) + ENDDO + ELSE IF (grid%hypsometric_opt == 2) THEN + DO k=kts,kte-1 + pfu = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k+1)+grid%p_top + pfd = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k) +grid%p_top + phm = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k) +grid%p_top + grid%al(i,k,j) = (grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)) & + /phm/LOG(pfd/pfu)-grid%alb(i,k,j) + ENDDO + END IF + + ! Compute pressure similarly to how computed within model. + + DO k=kts,kte-1 + qvf = 1.+rvovrd*moist(i,k,j,P_QV) + grid%p(i,k,j)=p1000mb*( (r_d*(t0+grid%t_2(i,k,j))*qvf)/ & + (p1000mb*(grid%al(i,k,j)+grid%alb(i,k,j))) )**cpovcv & + -grid%pb(i,k,j) + grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + grid%alt(i,k,j) = grid%al(i,k,j) + grid%alb(i,k,j) + ENDDO + + ! Adjust the column pressure so that the computed 500 mb height is close to the + ! input value (of course, not when we are doing hybrid input). + + IF ( ( flag_metgrid .EQ. 1 ) .AND. ( i .EQ. i_valid ) .AND. ( j .EQ. j_valid ) ) THEN + DO k = 1 , num_metgrid_levels + IF ( ABS ( grid%p_gc(i,k,j) - 50000. ) .LT. 1. ) THEN + lev500 = k + EXIT + END IF + END DO + END IF + + ! We only do the adjustment of height if we have the input data on pressure + ! surfaces, and folks have asked to do this option. + + IF ( ( flag_metgrid .EQ. 1 ) .AND. & + ( flag_ptheta .EQ. 0 ) .AND. & + ( config_flags%adjust_heights ) .AND. & + ( lev500 .NE. 0 ) ) THEN + + DO k = 2 , kte-1 + + ! Get the pressures on the full eta levels (grid%php is defined above as + ! the full-lev base pressure, an easy array to use for 3d space). + + pl = grid%php(i,k ,j) + & + ( grid%p(i,k-1 ,j) * ( grid%znw(k ) - grid%znu(k ) ) + & + grid%p(i,k ,j) * ( grid%znu(k-1 ) - grid%znw(k ) ) ) / & + ( grid%znu(k-1 ) - grid%znu(k ) ) + pu = grid%php(i,k+1,j) + & + ( grid%p(i,k-1+1,j) * ( grid%znw(k +1) - grid%znu(k+1) ) + & + grid%p(i,k +1,j) * ( grid%znu(k-1+1) - grid%znw(k+1) ) ) / & + ( grid%znu(k-1+1) - grid%znu(k+1) ) + + ! If these pressure levels trap 500 mb, use them to interpolate + ! to the 500 mb level of the computed height. + + IF ( ( pl .GE. 50000. ) .AND. ( pu .LT. 50000. ) ) THEN + zl = ( grid%ph_2(i,k ,j) + grid%phb(i,k ,j) ) / g + zu = ( grid%ph_2(i,k+1,j) + grid%phb(i,k+1,j) ) / g + + z500 = ( zl * ( LOG(50000.) - LOG(pu ) ) + & + zu * ( LOG(pl ) - LOG(50000.) ) ) / & + ( LOG(pl) - LOG(pu) ) + + ! Compute the difference of the 500 mb heights (computed minus input), and + ! then the change in grid%mu_2. The grid%php is still full-levels, base pressure. + + dz500 = z500 - grid%ght_gc(i,lev500,j) + tvsfc = ((grid%t_2(i,1,j)+t0)*((grid%p(i,1,j)+grid%php(i,1,j))/p1000mb)**(r_d/cp)) * & + (1.+0.6*moist(i,1,j,P_QV)) + dpmu = ( grid%php(i,1,j) + grid%p(i,1,j) ) * EXP ( g * dz500 / ( r_d * tvsfc ) ) + dpmu = dpmu - ( grid%php(i,1,j) + grid%p(i,1,j) ) + grid%mu_2(i,j) = grid%mu_2(i,j) - dpmu + EXIT + END IF + + END DO + ELSE + dpmu = 0. + END IF + + END DO + ENDDO ENDDO - ENDDO + END IF ! rebalance ! If this is data from the SI, then we probably do not have the original ! surface data laying around. Note that these are all the lowest levels @@ -3956,15 +4240,19 @@ program vint real , dimension(1:ij,kgen,1:ij) :: fo , po real , dimension(1:ij,1:keta,1:ij) :: fn_calc , fn_interp , pn + real , dimension(1:ij,1:ij) :: not_required_2d_1, not_required_2d_2, & + not_required_2d_3, not_required_2d_4, & + not_required_2d_5, not_required_2d_6 integer, parameter :: interp_type = 1 ! 2 + integer, parameter :: extrap_type = 2 ! 1 ! integer, parameter :: lagrange_order = 2 ! 1 integer :: lagrange_order logical, parameter :: lowest_lev_from_sfc = .FALSE. ! .TRUE. - logical, parameter :: use_levels_below_ground = .FALSE. ! .TRUE. - logical, parameter :: use_surface = .FALSE. ! .TRUE. + logical, parameter :: use_levels_below_ground = .TRUE. ! .FALSE. ! .TRUE. + logical, parameter :: use_surface = .TRUE. ! .FALSE. ! .TRUE. real , parameter :: zap_close_levels = 500. ! 100. - integer, parameter :: force_sfc_in_vinterp = 0 ! 6 + integer, parameter :: force_sfc_in_vinterp = 6 ! 0 ! 6 integer :: k @@ -3979,7 +4267,7 @@ program vint print *,'UNIT TEST FOR VERTICAL INTERPOLATION' print *,'------------------------------------' print *,' ' - do lagrange_order = 1 , 2 + do lagrange_order = 1 , 9 , 8 print *,' ' print *,'------------------------------------' print *,'Lagrange Order = ',lagrange_order @@ -4003,8 +4291,12 @@ program vint print *,' ' call vert_interp ( fo , po , fn_interp , pn , & + not_required_2d_1, not_required_2d_2, & + not_required_2d_3, not_required_2d_4, & + not_required_2d_5, not_required_2d_6, & + 0 , 0, 5000., 5000., 30000., & generic , 'T' , & - interp_type , lagrange_order , & + interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & zap_close_levels , force_sfc_in_vinterp , & ids , ide , jds , jde , kds , kde , & @@ -4023,26 +4315,6 @@ program vint k,pn(2,k,2),fn_calc(2,k,2),fn_interp(2,k,2),fn_calc(2,k,2)-fn_interp(2,k,2) end do - call vert_interp_old ( fo , po , fn_interp , pn , & - generic , 'T' , & - interp_type , lagrange_order , & - lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & - ids , ide , jds , jde , kds , kde , & - ims , ime , jms , jme , kms , kme , & - its , ite , jts , jte , kts , kte ) - - print *,'Linear Interpolator' - print *,'------------------------------------' - print *,' ' - print *,'Level Pressure Field Field Field' - print *,' (Pa) Calc Interp Diff' - print *,'------------------------------------' - print *,' ' - do k = kts , kte-1 - write (*,fmt='(i2,2x,f12.3,1x,3(g15.7))' ) & - k,pn(2,k,2),fn_calc(2,k,2),fn_interp(2,k,2),fn_calc(2,k,2)-fn_interp(2,k,2) - end do end do end program vint @@ -4150,12 +4422,20 @@ subroutine fillitup ( fo , po , fn , pn , & end subroutine fillitup +function skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) + logical :: skip_middle_points_t + integer :: ids , ide , jds , jde , i , j , em_width + logical :: hold_ups + skip_middle_points_t = .false. +end function skip_middle_points_t + #endif !--------------------------------------------------------------------- SUBROUTINE vert_interp ( fo , po , fnew , pnu , & fo_maxw , fo_trop , po_maxw , po_trop , & + po_maxwnn , po_tropnn , & flag_maxw , flag_trop , & maxw_horiz_pres_diff , trop_horiz_pres_diff , & maxw_above_this_level , & @@ -4187,6 +4467,7 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & REAL , DIMENSION(ims:ime,generic,jms:jme) , INTENT(IN) :: fo , po REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: fo_maxw , fo_trop , po_maxw , po_trop + REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: po_maxwnn , po_tropnn REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: pnu REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: fnew @@ -4215,6 +4496,16 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & LOGICAL :: any_valid_points INTEGER :: i_valid , j_valid LOGICAL :: flip_data_required +#ifdef VERT_UNIT + LOGICAL, EXTERNAL :: skip_middle_points_t + INTEGER :: em_width + LOGICAL :: hold_ups +#endif + + ! Vertical interpolation of the extra levels from metgrid: max wind and tropopause + + LOGICAL :: ok_data + INTEGER :: ii, jj zap_close_extra_levels = 500 @@ -4323,10 +4614,10 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & END IF END DO ELSE IF ( ( var_type .EQ. 'W' ) .OR. ( var_type .EQ. 'Z' ) ) THEN - istart = MAX(ids ,its-1) - iend = MIN(ide-1,ite+1) - jstart = MAX(jds ,jts-1) - jend = MIN(jde-1,jte+1) + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = MIN(jde-1,jte) kstart = kts kend = kte DO j = jstart,jend @@ -4350,10 +4641,10 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & END DO END DO ELSE IF ( ( var_type .EQ. 'T' ) .OR. ( var_type .EQ. 'Q' ) ) THEN - istart = MAX(ids ,its-1) - iend = MIN(ide-1,ite+1) - jstart = MAX(jds ,jts-1) - jend = MIN(jde-1,jte+1) + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = MIN(jde-1,jte) kstart = kts kend = kte-1 DO j = jstart,jend @@ -4377,10 +4668,10 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & END DO END DO ELSE - istart = MAX(ids ,its-1) - iend = MIN(ide-1,ite+1) - jstart = MAX(jds ,jts-1) - jend = MIN(jde-1,jte+1) + istart = its + iend = MIN(ide-1,ite) + jstart = jts + jend = MIN(jde-1,jte) kstart = kts kend = kte-1 DO j = jstart,jend @@ -4719,56 +5010,78 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & ! If we have additional levels (for example, some arrays have a "level of max winds" ! or a "level of the tropopause"), we insert them here. - IF ( ( flag_maxw .EQ. 1 ) .AND. ( porig_maxw(i,j) .LE. maxw_above_this_level ) .AND. & - ( ( ( ABS(porig_maxw(MIN(i+1, ide ),j )-porig_maxw(MAX(i-1,ids),j )) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'U' ) ) .OR. & - ( ( ABS(porig_maxw(i ,MIN(j+1, jde-1))-porig_maxw(i ,MAX(j-1,jds))) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'U' ) ) .OR. & - ( ( ABS(porig_maxw(MIN(i+1, ide-1),j )-porig_maxw(MAX(i-1,ids),j )) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'V' ) ) .OR. & - ( ( ABS(porig_maxw(i ,MIN(j+1, jde ))-porig_maxw(i ,MAX(j-1,jds))) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'V' ) ) .OR. & - ( ( ABS(porig_maxw(MIN(i+1, ide-1),j )-porig_maxw(MAX(i-1,ids),j )) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'T' ) ) .OR. & - ( ( ABS(porig_maxw(i ,MIN(j+1, jde-1))-porig_maxw(i ,MAX(j-1,jds))) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'T' ) ) .OR. & - ( ( ABS(porig_maxw(MIN(i+1, ide-1),j )-porig_maxw(MAX(i-1,ids),j )) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'Z' ) ) .OR. & - ( ( ABS(porig_maxw(i ,MIN(j+1, jde-1))-porig_maxw(i ,MAX(j-1,jds))) .LT. 2*maxw_horiz_pres_diff ) .AND. ( var_type .EQ. 'Z' ) ) ) ) THEN - insert_maxw : DO ko = kinterp_start , kinterp_end-1 - IF ( ( ( ( ordered_porig(ko)-porig_maxw(i,j) ) * ( ordered_porig(ko+1)-porig_maxw(i,j) ) ) .LT. 0 ) .AND. & - ( ( ABS(ordered_porig(ko )-porig_maxw(i,j)) .GT. zap_close_extra_levels ) .AND. & - ( ABS(ordered_porig(ko+1)-porig_maxw(i,j)) .GT. zap_close_extra_levels ) ) ) THEN - DO kcount = kinterp_end , ko+1 , -1 - ordered_porig(kcount+1) = ordered_porig(kcount) - ordered_forig(kcount+1) = ordered_forig(kcount) - END DO - ordered_porig(ko+1) = porig_maxw(i,j) - ordered_forig(ko+1) = fo_maxw(i,j) - kinterp_end = kinterp_end + 1 - EXIT insert_maxw - END IF - END DO insert_maxw - END IF - - IF ( ( flag_trop .EQ. 1 ) .AND. & - ( ( ( ABS(porig_trop(MIN(i+1, ide ),j )-porig_trop(MAX(i-1,ids),j )) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'U' ) ) .OR. & - ( ( ABS(porig_trop(i ,MIN(j+1, jde-1))-porig_trop(i ,MAX(j-1,jds))) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'U' ) ) .OR. & - ( ( ABS(porig_trop(MIN(i+1, ide-1),j )-porig_trop(MAX(i-1,ids),j )) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'V' ) ) .OR. & - ( ( ABS(porig_trop(i ,MIN(j+1, jde ))-porig_trop(i ,MAX(j-1,jds))) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'V' ) ) .OR. & - ( ( ABS(porig_trop(MIN(i+1, ide-1),j )-porig_trop(MAX(i-1,ids),j )) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'T' ) ) .OR. & - ( ( ABS(porig_trop(i ,MIN(j+1, jde-1))-porig_trop(i ,MAX(j-1,jds))) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'T' ) ) .OR. & - ( ( ABS(porig_trop(MIN(i+1, ide-1),j )-porig_trop(MAX(i-1,ids),j )) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'Z' ) ) .OR. & - ( ( ABS(porig_trop(i ,MIN(j+1, jde-1))-porig_trop(i ,MAX(j-1,jds))) .LT. 2*trop_horiz_pres_diff ) .AND. ( var_type .EQ. 'Z' ) ) ) ) THEN - insert_trop : DO ko = kinterp_start , kinterp_end-1 - IF ( ( ( ( ordered_porig(ko)-porig_trop(i,j) ) * ( ordered_porig(ko+1)-porig_trop(i,j) ) ) .LT. 0 ) .AND. & - ( ( ABS(ordered_porig(ko )-porig_trop(i,j)) .GT. zap_close_extra_levels ) .AND. & - ( ABS(ordered_porig(ko+1)-porig_trop(i,j)) .GT. zap_close_extra_levels ) ) ) THEN - DO kcount = kinterp_end , ko+1 , -1 - ordered_porig(kcount+1) = ordered_porig(kcount) - ordered_forig(kcount+1) = ordered_forig(kcount) - END DO - ordered_porig(ko+1) = porig_trop(i,j) - ordered_forig(ko+1) = fo_trop(i,j) - kinterp_end = kinterp_end + 1 - EXIT insert_trop - END IF - END DO insert_trop + IF ( ( flag_maxw .EQ. 1 ) .AND. ( porig_maxw(i,j) .LE. maxw_above_this_level ) ) then + ok_data = .TRUE. + DO jj = -2, 2 + DO ii = -2, 2 + ok_data = ok_data .AND. & + ( ABS(po_maxwnn(MAX(MIN(i+ii,iend+2,ide-1),istart-2,ids),MAX(MIN(j+jj,jend+2,jde-1),jstart-2,jds))-porig_maxw(i,j)) & + .LT. maxw_horiz_pres_diff ) + END DO + END DO + IF ( ok_data) THEN + insert_maxw : DO ko = kinterp_start , kinterp_end-1 + IF ( ( ( ordered_porig(ko)-porig_maxw(i,j) ) * ( ordered_porig(ko+1)-porig_maxw(i,j) ) ) .LT. 0 ) THEN + IF ( ( ABS(ordered_porig(ko )-porig_maxw(i,j)) .GT. zap_close_extra_levels ) .AND. & + ( ABS(ordered_porig(ko+1)-porig_maxw(i,j)) .GT. zap_close_extra_levels ) ) THEN + DO kcount = kinterp_end , ko+1 , -1 + ordered_porig(kcount+1) = ordered_porig(kcount) + ordered_forig(kcount+1) = ordered_forig(kcount) + END DO + ordered_porig(ko+1) = porig_maxw(i,j) + ordered_forig(ko+1) = fo_maxw(i,j) + kinterp_end = kinterp_end + 1 + EXIT insert_maxw + ELSE IF ( ABS(ordered_porig(ko )-porig_maxw(i,j)) .LE. zap_close_extra_levels ) THEN + ordered_porig(ko) = porig_maxw(i,j) + ordered_forig(ko) = fo_maxw(i,j) + EXIT insert_maxw + ELSE IF ( ABS(ordered_porig(ko+1)-porig_maxw(i,j)) .LE. zap_close_extra_levels ) THEN + ordered_porig(ko+1) = porig_maxw(i,j) + ordered_forig(ko+1) = fo_maxw(i,j) + EXIT insert_maxw + END IF + END IF + END DO insert_maxw + END IF END IF + IF ( flag_trop .EQ. 1 ) THEN + ok_data = .TRUE. + DO jj = -2, 2 + DO ii = -2, 2 + ok_data = ok_data .AND. & + ( ABS(po_tropnn(MAX(MIN(i+ii,iend+2,ide-1),istart-2,ids),MAX(MIN(j+jj,jend+2,jde-1),jstart-2,jds))-porig_trop(i,j)) & + .LT. trop_horiz_pres_diff ) + END DO + END DO + IF ( ok_data) THEN + insert_trop : DO ko = kinterp_start , kinterp_end-1 + IF ( ( ( ordered_porig(ko)-porig_trop(i,j) ) * ( ordered_porig(ko+1)-porig_trop(i,j) ) ) .LT. 0 ) THEN + IF ( ( ABS(ordered_porig(ko )-porig_trop(i,j)) .GT. zap_close_extra_levels ) .AND. & + ( ABS(ordered_porig(ko+1)-porig_trop(i,j)) .GT. zap_close_extra_levels ) ) THEN + DO kcount = kinterp_end , ko+1 , -1 + ordered_porig(kcount+1) = ordered_porig(kcount) + ordered_forig(kcount+1) = ordered_forig(kcount) + END DO + ordered_porig(ko+1) = porig_trop(i,j) + ordered_forig(ko+1) = fo_trop(i,j) + kinterp_end = kinterp_end + 1 + EXIT insert_trop + ELSE IF ( ABS(ordered_porig(ko )-porig_trop(i,j)) .LE. zap_close_extra_levels ) THEN + ordered_porig(ko) = porig_trop(i,j) + ordered_forig(ko) = fo_trop(i,j) + EXIT insert_trop + ELSE IF ( ABS(ordered_porig(ko+1)-porig_trop(i,j)) .LE. zap_close_extra_levels ) THEN + ordered_porig(ko+1) = porig_trop(i,j) + ordered_forig(ko+1) = fo_trop(i,j) + EXIT insert_trop + END IF + END IF + END DO insert_trop + END IF + END IF + ! The polynomials are either in pressure or LOG(pressure). IF ( interp_type .EQ. 1 ) THEN @@ -4805,401 +5118,6 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & END SUBROUTINE vert_interp -!--------------------------------------------------------------------- - - SUBROUTINE vert_interp_old ( forig , po , fnew , pnu , & - generic , var_type , & - interp_type , lagrange_order , extrap_type , & - lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & - ids , ide , jds , jde , kds , kde , & - ims , ime , jms , jme , kms , kme , & - its , ite , jts , jte , kts , kte ) - - ! Vertically interpolate the new field. The original field on the original - ! pressure levels is provided, and the new pressure surfaces to interpolate to. - - IMPLICIT NONE - - INTEGER , INTENT(IN) :: interp_type , lagrange_order , extrap_type - LOGICAL , INTENT(IN) :: lowest_lev_from_sfc , use_levels_below_ground , use_surface - REAL , INTENT(IN) :: zap_close_levels - INTEGER , INTENT(IN) :: force_sfc_in_vinterp - INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & - ims , ime , jms , jme , kms , kme , & - its , ite , jts , jte , kts , kte - INTEGER , INTENT(IN) :: generic - - CHARACTER (LEN=1) :: var_type - - REAL , DIMENSION(ims:ime,generic,jms:jme) , INTENT(IN) :: forig , po - REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(IN) :: pnu - REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: fnew - - REAL , DIMENSION(ims:ime,generic,jms:jme) :: porig - REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: pnew - - ! Local vars - - INTEGER :: i , j , k , ko , kn , k1 , k2 , ko_1 , ko_2 - INTEGER :: istart , iend , jstart , jend , kstart , kend - INTEGER , DIMENSION(ims:ime,kms:kme ) :: k_above , k_below - INTEGER , DIMENSION(ims:ime ) :: ks - INTEGER , DIMENSION(ims:ime ) :: ko_above_sfc - - LOGICAL :: any_below_ground - - REAL :: p1 , p2 , pn -integer vert_extrap -vert_extrap = 0 - - ! Horiontal loop bounds for different variable types. - - IF ( var_type .EQ. 'U' ) THEN - istart = its - iend = ite - jstart = jts - jend = MIN(jde-1,jte) - kstart = kts - kend = kte-1 - DO j = jstart,jend - DO k = 1,generic - DO i = MAX(ids+1,its) , MIN(ide-1,ite) - porig(i,k,j) = ( po(i,k,j) + po(i-1,k,j) ) * 0.5 - END DO - END DO - IF ( ids .EQ. its ) THEN - DO k = 1,generic - porig(its,k,j) = po(its,k,j) - END DO - END IF - IF ( ide .EQ. ite ) THEN - DO k = 1,generic - porig(ite,k,j) = po(ite-1,k,j) - END DO - END IF - - DO k = kstart,kend - DO i = MAX(ids+1,its) , MIN(ide-1,ite) - pnew(i,k,j) = ( pnu(i,k,j) + pnu(i-1,k,j) ) * 0.5 - END DO - END DO - IF ( ids .EQ. its ) THEN - DO k = kstart,kend - pnew(its,k,j) = pnu(its,k,j) - END DO - END IF - IF ( ide .EQ. ite ) THEN - DO k = kstart,kend - pnew(ite,k,j) = pnu(ite-1,k,j) - END DO - END IF - END DO - ELSE IF ( var_type .EQ. 'V' ) THEN - istart = its - iend = MIN(ide-1,ite) - jstart = jts - jend = jte - kstart = kts - kend = kte-1 - DO i = istart,iend - DO k = 1,generic - DO j = MAX(jds+1,jts) , MIN(jde-1,jte) - porig(i,k,j) = ( po(i,k,j) + po(i,k,j-1) ) * 0.5 - END DO - END DO - IF ( jds .EQ. jts ) THEN - DO k = 1,generic - porig(i,k,jts) = po(i,k,jts) - END DO - END IF - IF ( jde .EQ. jte ) THEN - DO k = 1,generic - porig(i,k,jte) = po(i,k,jte-1) - END DO - END IF - - DO k = kstart,kend - DO j = MAX(jds+1,jts) , MIN(jde-1,jte) - pnew(i,k,j) = ( pnu(i,k,j) + pnu(i,k,j-1) ) * 0.5 - END DO - END DO - IF ( jds .EQ. jts ) THEN - DO k = kstart,kend - pnew(i,k,jts) = pnu(i,k,jts) - END DO - END IF - IF ( jde .EQ. jte ) THEN - DO k = kstart,kend - pnew(i,k,jte) = pnu(i,k,jte-1) - END DO - END IF - END DO - ELSE IF ( ( var_type .EQ. 'W' ) .OR. ( var_type .EQ. 'Z' ) ) THEN - istart = its - iend = MIN(ide-1,ite) - jstart = jts - jend = MIN(jde-1,jte) - kstart = kts - kend = kte - DO j = jstart,jend - DO k = 1,generic - DO i = istart,iend - porig(i,k,j) = po(i,k,j) - END DO - END DO - - DO k = kstart,kend - DO i = istart,iend - pnew(i,k,j) = pnu(i,k,j) - END DO - END DO - END DO - ELSE IF ( ( var_type .EQ. 'T' ) .OR. ( var_type .EQ. 'Q' ) ) THEN - istart = its - iend = MIN(ide-1,ite) - jstart = jts - jend = MIN(jde-1,jte) - kstart = kts - kend = kte-1 - DO j = jstart,jend - DO k = 1,generic - DO i = istart,iend - porig(i,k,j) = po(i,k,j) - END DO - END DO - - DO k = kstart,kend - DO i = istart,iend - pnew(i,k,j) = pnu(i,k,j) - END DO - END DO - END DO - ELSE - istart = its - iend = MIN(ide-1,ite) - jstart = jts - jend = MIN(jde-1,jte) - kstart = kts - kend = kte-1 - DO j = jstart,jend - DO k = 1,generic - DO i = istart,iend - porig(i,k,j) = po(i,k,j) - END DO - END DO - - DO k = kstart,kend - DO i = istart,iend - pnew(i,k,j) = pnu(i,k,j) - END DO - END DO - END DO - END IF - - DO j = jstart , jend - - ! Skip all of the levels below ground in the original data based upon the surface pressure. - ! The ko_above_sfc is the index in the pressure array that is above the surface. If there - ! are no levels underground, this is index = 2. The remaining levels are eligible for use - ! in the vertical interpolation. - - DO i = istart , iend - ko_above_sfc(i) = -1 - END DO - DO ko = kstart+1 , kend - DO i = istart , iend - IF ( ko_above_sfc(i) .EQ. -1 ) THEN - IF ( porig(i,1,j) .GT. porig(i,ko,j) ) THEN - ko_above_sfc(i) = ko - END IF - END IF - END DO - END DO - - ! Initialize interpolation location. These are the levels in the original pressure - ! data that are physically below and above the targeted new pressure level. - - DO kn = kts , kte - DO i = its , ite - k_above(i,kn) = -1 - k_below(i,kn) = -2 - END DO - END DO - - ! Starting location is no lower than previous found location. This is for O(n logn) - ! and not O(n^2), where n is the number of vertical levels to search. - - DO i = its , ite - ks(i) = 1 - END DO - - ! Find trapping layer for interpolation. The kn index runs through all of the "new" - ! levels of data. - - DO kn = kstart , kend - - DO i = istart , iend - - ! For each "new" level (kn), we search to find the trapping levels in the "orig" - ! data. Most of the time, the "new" levels are the eta surfaces, and the "orig" - ! levels are the input pressure levels. - - found_trap_above : DO ko = ks(i) , generic-1 - - ! Because we can have levels in the interpolation that are not valid, - ! let's toss out any candidate orig pressure values that are below ground - ! based on the surface pressure. If the level =1, then this IS the surface - ! level, so we HAVE to keep that one, but maybe not the ones above. If the - ! level (ks) is NOT=1, then we have to just CYCLE our loop to find a legit - ! below-pressure value. If we are not below ground, then we choose two - ! neighboring levels to test whether they surround the new pressure level. - - ! The input trapping levels that we are trying is the surface and the first valid - ! level above the surface. - - IF ( ( ko .LT. ko_above_sfc(i) ) .AND. ( ko .EQ. 1 ) ) THEN - ko_1 = ko - ko_2 = ko_above_sfc(i) - - ! The "below" level is underground, cycle until we get to a valid pressure - ! above ground. - - ELSE IF ( ( ko .LT. ko_above_sfc(i) ) .AND. ( ko .NE. 1 ) ) THEN - CYCLE found_trap_above - - ! The "below" level is above the surface, so we are in the clear to test these - ! two levels out. - - ELSE - ko_1 = ko - ko_2 = ko+1 - - END IF - - ! The test of the candidate levels: "below" has to have a larger pressure, and - ! "above" has to have a smaller pressure. - - ! OK, we found the correct two surrounding levels. The locations are saved for use in the - ! interpolation. - - IF ( ( porig(i,ko_1,j) .GE. pnew(i,kn,j) ) .AND. & - ( porig(i,ko_2,j) .LT. pnew(i,kn,j) ) ) THEN - k_above(i,kn) = ko_2 - k_below(i,kn) = ko_1 - ks(i) = ko_1 - EXIT found_trap_above - - ! What do we do is we need to extrapolate the data underground? This happens when the - ! lowest pressure that we have is physically "above" the new target pressure. Our - ! actions depend on the type of variable we are interpolating. - - ELSE IF ( porig(i,1,j) .LT. pnew(i,kn,j) ) THEN - - ! For horizontal winds and moisture, we keep a constant value under ground. - - IF ( ( var_type .EQ. 'U' ) .OR. & - ( var_type .EQ. 'V' ) .OR. & - ( var_type .EQ. 'Q' ) ) THEN - k_above(i,kn) = 1 - ks(i) = 1 - - ! For temperature and height, we extrapolate the data. Hopefully, we are not - ! extrapolating too far. For pressure level input, the eta levels are always - ! contained within the surface to p_top levels, so no extrapolation is ever - ! required. - - ELSE IF ( ( var_type .EQ. 'Z' ) .OR. & - ( var_type .EQ. 'T' ) ) THEN - k_above(i,kn) = ko_above_sfc(i) - k_below(i,kn) = 1 - ks(i) = 1 - - ! Just a catch all right now. - - ELSE - k_above(i,kn) = 1 - ks(i) = 1 - END IF - - EXIT found_trap_above - - ! The other extrapolation that might be required is when we are going above the - ! top level of the input data. Usually this means we chose a P_PTOP value that - ! was inappropriate, and we should stop and let someone fix this mess. - - ELSE IF ( porig(i,generic,j) .GT. pnew(i,kn,j) ) THEN - print *,'data is too high, try a lower p_top' - print *,'pnew=',pnew(i,kn,j) - print *,'porig=',porig(i,:,j) - CALL wrf_error_fatal ('requested p_top is higher than input data, lower p_top') - - END IF - END DO found_trap_above - END DO - END DO - - ! Linear vertical interpolation. - - DO kn = kstart , kend - DO i = istart , iend - IF ( k_above(i,kn) .EQ. 1 ) THEN - fnew(i,kn,j) = forig(i,1,j) - ELSE - k2 = MAX ( k_above(i,kn) , 2) - k1 = MAX ( k_below(i,kn) , 1) - IF ( k1 .EQ. k2 ) THEN - CALL wrf_error_fatal ( 'identical values in the interp, bad for divisions' ) - END IF - IF ( interp_type .EQ. 1 ) THEN - p1 = porig(i,k1,j) - p2 = porig(i,k2,j) - pn = pnew(i,kn,j) - ELSE IF ( interp_type .EQ. 2 ) THEN - p1 = ALOG(porig(i,k1,j)) - p2 = ALOG(porig(i,k2,j)) - pn = ALOG(pnew(i,kn,j)) - END IF - IF ( ( p1-pn) * (p2-pn) > 0. ) THEN -! CALL wrf_error_fatal ( 'both trapping pressures are on the same side of the new pressure' ) -! CALL wrf_debug ( 0 , 'both trapping pressures are on the same side of the new pressure' ) -vert_extrap = vert_extrap + 1 - END IF - fnew(i,kn,j) = ( forig(i,k1,j) * ( p2 - pn ) + & - forig(i,k2,j) * ( pn - p1 ) ) / & - ( p2 - p1 ) - END IF - END DO - END DO - - search_below_ground : DO kn = kstart , kend - any_below_ground = .FALSE. - DO i = istart , iend - IF ( k_above(i,kn) .EQ. 1 ) THEN - fnew(i,kn,j) = forig(i,1,j) - any_below_ground = .TRUE. - END IF - END DO - IF ( .NOT. any_below_ground ) THEN - EXIT search_below_ground - END IF - END DO search_below_ground - - ! There may have been a request to have the surface data from the input field - ! to be assigned as to the lowest eta level. This assumes thin layers (usually - ! the isobaric original field has the surface from 2-m T and RH, and 10-m U and V). - - DO i = istart , iend - IF ( lowest_lev_from_sfc ) THEN - fnew(i,1,j) = forig(i,ko_above_sfc(i),j) - END IF - END DO - - END DO -print *,'VERT EXTRAP = ', vert_extrap - - END SUBROUTINE vert_interp_old - !--------------------------------------------------------------------- SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n , extrap_type , & @@ -5245,7 +5163,11 @@ SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n REAL :: temp_1 , temp_2 , temp_3 , temp_y REAL :: depth_of_extrap_in_p , avg_of_extrap_p , temp_extrap_starting_point , dhdp , dh , dt +#ifdef VERT_UNIT + REAL , PARAMETER :: RovCp = 0.287 +#else REAL , PARAMETER :: RovCp = rcp +#endif REAL , PARAMETER :: CRC_const1 = 11880.516 ! m REAL , PARAMETER :: CRC_const2 = 0.1902632 ! REAL , PARAMETER :: CRC_const3 = 0.0065 ! K/km @@ -5361,7 +5283,7 @@ SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n ! and shift the range one index, then get an average. IF ( n .EQ. 9 ) THEN - CALL cubic_spline (all_dim, all_x, all_y, P2) + CALL cubic_spline (all_dim-1, all_x, all_y, P2) ! ! Find the value of function f(x) ! @@ -5439,23 +5361,18 @@ SUBROUTINE cubic_spline (N, XI, FI, P2) ! INTEGER :: I INTEGER, INTENT (IN) :: N - REAL, INTENT (IN), DIMENSION (N):: XI, FI - REAL, INTENT (OUT), DIMENSION (N):: P2 + REAL, INTENT (IN), DIMENSION (N+1):: XI, FI + REAL, INTENT (OUT), DIMENSION (N+1):: P2 REAL, DIMENSION (N):: G, H REAL, DIMENSION (N-1):: D, B, C ! ! Assign the intervals and function differences ! - DO I = 1, N-1 + DO I = 1, N H(I) = XI(I+1) - XI(I) G(I) = FI(I+1) - FI(I) END DO ! -! The top vertical derivative is zero -! - H(N) = H(N-1) - G(N) = 0 -! ! Evaluate the coefficient matrix elements DO I = 1, N-1 D(I) = 2*(H(I+1)+H(I)) @@ -5467,6 +5384,7 @@ SUBROUTINE cubic_spline (N, XI, FI, P2) ! CALL TRIDIAGONAL_LINEAR_EQ (N-1, D, C, C, B, G) P2(1) = 0 + P2(N+1) = 0 DO I = 2, N P2(I) = G(I-1) END DO diff --git a/wrfv2_fire/dyn_em/module_initialize_scm_xy.F b/wrfv2_fire/dyn_em/module_initialize_scm_xy.F index b449786f..7d746a51 100644 --- a/wrfv2_fire/dyn_em/module_initialize_scm_xy.F +++ b/wrfv2_fire/dyn_em/module_initialize_scm_xy.F @@ -57,7 +57,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) END SUBROUTINE init_domain @@ -66,7 +66,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) @@ -76,7 +76,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -125,7 +125,7 @@ SUBROUTINE init_domain_rk ( grid & #ifdef DM_PARALLEL -# include +# include "data_calls.inc" #endif @@ -475,7 +475,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F b/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F index 92ee5af6..63fb805b 100644 --- a/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F +++ b/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F @@ -57,7 +57,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) END SUBROUTINE init_domain @@ -66,7 +66,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -74,7 +74,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -106,7 +106,7 @@ SUBROUTINE init_domain_rk ( grid & character (len=256) :: mminlu2 #ifdef DM_PARALLEL -# include +# include "data_calls.inc" #endif @@ -446,7 +446,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) @@ -503,7 +503,7 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_squall2d_x.F b/wrfv2_fire/dyn_em/module_initialize_squall2d_x.F index 64ba3c22..6f1500e0 100644 --- a/wrfv2_fire/dyn_em/module_initialize_squall2d_x.F +++ b/wrfv2_fire/dyn_em/module_initialize_squall2d_x.F @@ -56,7 +56,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) END SUBROUTINE init_domain @@ -65,7 +65,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -73,7 +73,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -375,7 +375,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) @@ -428,7 +428,7 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_squall2d_y.F b/wrfv2_fire/dyn_em/module_initialize_squall2d_y.F index d061b7b2..44954eac 100644 --- a/wrfv2_fire/dyn_em/module_initialize_squall2d_y.F +++ b/wrfv2_fire/dyn_em/module_initialize_squall2d_y.F @@ -53,7 +53,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) END SUBROUTINE init_domain @@ -62,7 +62,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -70,7 +70,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -372,7 +372,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) @@ -425,7 +425,7 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F b/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F index 0b8f8d1b..9e62f642 100644 --- a/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F +++ b/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F @@ -57,7 +57,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include +#include "actual_new_args.inc" ! ) END SUBROUTINE init_domain @@ -66,7 +66,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include +# include "dummy_new_args.inc" ! ) IMPLICIT NONE @@ -74,7 +74,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -114,7 +114,7 @@ SUBROUTINE init_domain_rk ( grid & character (len=256) :: mminlu2 #ifdef DM_PARALLEL -# include +# include "data_calls.inc" #endif @@ -469,7 +469,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) @@ -752,7 +752,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) @@ -913,7 +913,7 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) diff --git a/wrfv2_fire/dyn_em/module_sfs_nba.F b/wrfv2_fire/dyn_em/module_sfs_nba.F index 00bee6dc..18e5d915 100644 --- a/wrfv2_fire/dyn_em/module_sfs_nba.F +++ b/wrfv2_fire/dyn_em/module_sfs_nba.F @@ -71,7 +71,7 @@ SUBROUTINE calc_mij_constants( ) cs = ( ( 8.0*( 1.0+cb ) )/( 27.0*pi**2 ) )**0.5 c1 = ( ( 960.0**0.5 )*cb )/( 7.0*( 1.0+cb )*sk ) - c2 = c1 + c2 = -c1 ce = ( ( 8.0*pi/27.0 )**( 1.0/3.0 ) )*cs**( 4.0/3.0 ) c3 = ( ( 27.0/( 8.0*pi ) )**( 1.0/3.0 ) )*cs**( 2.0/3.0 ) diff --git a/wrfv2_fire/dyn_em/module_stoch.F b/wrfv2_fire/dyn_em/module_stoch.F index 3a88664a..50b87123 100644 --- a/wrfv2_fire/dyn_em/module_stoch.F +++ b/wrfv2_fire/dyn_em/module_stoch.F @@ -1221,17 +1221,18 @@ SUBROUTINE rand_seed (config_flags, iseed1, iseedarr, kms, kme) INTEGER, DIMENSION (kms:kme), INTENT(OUT) :: iseedarr ! Local - integer*8 :: fctime + integer*8 :: fctime, one_big integer :: i fctime = config_flags%start_year * ( config_flags%start_month*100+config_flags%start_day) + config_flags%start_hour + one_big = 1 iseedarr=0.0 do i = kms,kme-3,4 iseedarr(i )= iseed1+config_flags%nens*1000000 - iseedarr(i+1)= mod(fctime+iseed1*1000000,19211) - iseedarr(i+2)= mod(fctime+iseed1*1000000,71209) - iseedarr(i+3)= mod(fctime+iseed1*1000000,11279) + iseedarr(i+1)= mod(fctime+iseed1*1000000,19211*one_big) + iseedarr(i+2)= mod(fctime+iseed1*1000000,71209*one_big) + iseedarr(i+3)= mod(fctime+iseed1*1000000,11279*one_big) enddo end SUBROUTINE rand_seed diff --git a/wrfv2_fire/dyn_em/nest_init_utils.F b/wrfv2_fire/dyn_em/nest_init_utils.F index 9025aee0..774b630a 100644 --- a/wrfv2_fire/dyn_em/nest_init_utils.F +++ b/wrfv2_fire/dyn_em/nest_init_utils.F @@ -119,13 +119,13 @@ END SUBROUTINE init_domain_constants_em !--------------------------------------------------------------------------------------------------- -SUBROUTINE init_domain_vert_nesting ( parent, nest) +SUBROUTINE init_domain_vert_nesting ( parent, nest, use_baseparam_fr_nml ) !KAL this is a driver to initialize the vertical coordinates for the nest when vertical nesting is used USE module_domain IMPLICIT NONE TYPE(domain), POINTER :: parent, nest - + LOGICAL :: use_baseparam_fr_nml !local REAL, DIMENSION(parent%e_vert) :: znw_c @@ -138,11 +138,12 @@ SUBROUTINE vert_cor_vertical_nesting_integer(nest,znw_c,k_dim_c) real , dimension(k_dim_c), INTENT(IN) :: znw_c END SUBROUTINE vert_cor_vertical_nesting_integer - SUBROUTINE vert_cor_vertical_nesting_arbitrary(nest,znw_c,kde_c) + SUBROUTINE vert_cor_vertical_nesting_arbitrary(nest,znw_c,kde_c,use_baseparam_fr_nml) USE module_domain TYPE(domain), POINTER :: nest INTEGER, INTENT(IN ) :: kde_c REAL, DIMENSION(kde_c), INTENT(IN ) :: znw_c + LOGICAL, INTENT(IN ) :: use_baseparam_fr_nml END SUBROUTINE vert_cor_vertical_nesting_arbitrary END INTERFACE @@ -157,7 +158,7 @@ END SUBROUTINE vert_cor_vertical_nesting_arbitrary if (nest%vert_refine_method .EQ. 1) then !if you are in this subroutine there is vertical nesting- (i.e. nest%e_vert /= parent%e_vert to enter this subroutine) CALL vert_cor_vertical_nesting_integer(nest,znw_c,parent%e_vert) elseif (nest%vert_refine_method .EQ. 2) then - CALL vert_cor_vertical_nesting_arbitrary(nest,znw_c,parent%e_vert) + CALL vert_cor_vertical_nesting_arbitrary(nest,znw_c,parent%e_vert,use_baseparam_fr_nml) endif END SUBROUTINE init_domain_vert_nesting @@ -229,18 +230,50 @@ END SUBROUTINE vert_cor_vertical_nesting_integer !----------------------------------------------------------------------------------------- -SUBROUTINE vert_cor_vertical_nesting_arbitrary(nest,znw_c,kde_c) +SUBROUTINE vert_cor_vertical_nesting_arbitrary(nest,znw_c,kde_c,use_baseparam_fr_nml) USE module_domain + USE module_model_constants IMPLICIT NONE TYPE(domain), POINTER :: nest INTEGER, INTENT(IN ) :: kde_c REAL, DIMENSION(kde_c), INTENT(IN ) :: znw_c + LOGICAL, INTENT(IN ) :: use_baseparam_fr_nml INTEGER :: k, kde_n, ks, id REAL :: cof1, cof2 + REAL :: max_dz = 1000 + REAL :: p00, t00, a, tiso, a_strat, p_strat + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + REAL, DIMENSION(max_eta) :: eta_levels + + IF ( use_baseparam_fr_nml ) then + CALL nl_get_base_pres ( 1 , p00 ) + CALL nl_get_base_temp ( 1 , t00 ) + CALL nl_get_base_lapse ( 1 , a ) + CALL nl_get_iso_temp ( 1 , tiso ) + CALL nl_get_base_lapse_strat ( 1 , a_strat ) + CALL nl_get_base_pres_strat ( 1 , p_strat ) + IF ((t00 .LT. 100.0) .OR. (p00 .LT. 10000.0)) THEN + WRITE(wrf_err_message,*) '--- ERROR: bad base state for T00 or P00 in namelist.input file' + CALL wrf_error_fatal(TRIM(wrf_err_message)) + END IF + ELSE + p00 = nest%p00 + t00 = nest%t00 + a = nest%tlp + tiso = nest%tiso + a_strat = nest%tlp_strat + p_strat = nest%p_strat + IF ((t00 .LT. 100.0) .OR. (p00 .LT. 10000.0)) THEN + WRITE(wrf_err_message,*) '--- ERROR: did not find base state parameters in nest. Add use_baseparam_fr_nml = .true. in &dynamics and rerun' + CALL wrf_error_fatal(TRIM(wrf_err_message)) + ENDIF + ENDIF kde_n = nest%e_vert - !DJW 140627 Added code for specifying multiple domains' eta_levels + !DJW Added code for specifying multiple domains' eta_levels IF (nest%id .NE. 1) THEN id = 1 ks = 1 @@ -249,24 +282,70 @@ SUBROUTINE vert_cor_vertical_nesting_arbitrary(nest,znw_c,kde_c) ks = ks+model_config_rec%e_vert(id-1) ENDDO ENDIF + IF ((nest%this_is_an_ideal_run) .AND. (model_config_rec%eta_levels(1) .EQ. -1.0)) THEN + !DJW If we're running an ideal case and do not have levels set in the + !namelist then we set znw using constant spacing in eta + DO k=1,kde_n + CALL wrf_debug(0, "nest_init_utils: eta_levels are not specified in the namelist, setting levels with constant spacing in eta.") + nest%znw(k) = 1.0-(k-1)/FLOAT((kde_n-1)) + ENDDO + ELSEIF (.NOT.(nest%this_is_an_ideal_run) .AND. (model_config_rec%eta_levels(1) .EQ. -1.0)) THEN + write(*,'(A,I2,A)') "--- WARNING: eta_levels are not specified in the namelist for grid_id=",nest%grid_id,", using WRF's default levels." + CALL get_ijk_from_grid( nest, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + write(*,'(A,F10.3)') "--- USING: nest%p_top = ",nest%p_top + write(*,'(A,F10.3)') "--- USING: g = ",g + write(*,'(A,F10.3)') "--- USING: cvpm = ",cvpm + write(*,'(A,F10.3)') "--- USING: r_d = ",r_d + write(*,'(A,F10.3)') "--- USING: cp = ",cp + write(*,'(A,F10.3)') "--- USING: p1000mb = ",p1000mb + write(*,'(A,F10.3)') "--- USING: t0 = ",t0 + write(*,'(A,F10.3)') "--- USING: p00 = ",p00 + write(*,'(A,F10.3)') "--- USING: t00 = ",t00 + write(*,'(A,F10.3)') "--- USING: a = ",a + write(*,'(A,F10.3)') "--- USING: tiso = ",tiso + write(*,'(A,F10.3)') "--- USING: a_strat = ",a_strat + write(*,'(A,F10.3)') "--- USING: p_strat = ",p_strat + CALL compute_eta ( nest%znw, & + eta_levels, max_eta, max_dz, & + nest%p_top, g, p00, cvpm, a, r_d, cp, & + t00, p1000mb, t0, tiso, p_strat, a_strat, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ELSE + !DJW If we're in here then we are suppose to read in eta_levels + !from the namelist. We do so and then check to make sure they make sense DO k=1,kde_n nest%znw(k) = model_config_rec%eta_levels(ks+k-1) - write(*,'(A,I3,A,F5.3)') "DJW[nest_init_utils]: nest%znw(",k,") = ",nest%znw(k) + write(*,'(A,I3,A,F6.3)') "nest%znw(",k,") = ",nest%znw(k) ENDDO !Check the value of the first and last eta level for our domain, !then check that the vector of eta levels is only decreasing IF (nest%znw(1) .NE. 1.0) THEN - CALL wrf_error_fatal("error with specified eta_levels, first level is not 1.0") + write(wrf_err_message,'(A,I2,A)') "--- ERROR: first eta_level for grid_id=",nest%grid_id," is not 1.0. Check namelist." + CALL wrf_error_fatal( wrf_err_message ) ENDIF + write(*,'(A,F10.3)') "--- USING: g = ",g + write(*,'(A,F10.3)') "--- USING: cvpm = ",cvpm + write(*,'(A,F10.3)') "--- USING: r_d = ",r_d + write(*,'(A,F10.3)') "--- USING: cp = ",cp + write(*,'(A,F10.3)') "--- USING: p1000mb = ",p1000mb + write(*,'(A,F10.3)') "--- USING: t0 = ",t0 IF (nest%znw(kde_n) .NE. 0.0) THEN - CALL wrf_error_fatal("error with specified eta_levels, last level is not 0.0") + write(wrf_err_message,'(A,I2,A)') "--- ERROR: last eta_level for grid_id=",nest%grid_id," is not 0.0. Check namelist." + CALL wrf_error_fatal( wrf_err_message ) ENDIF DO k=2,kde_n IF (nest%znw(k) .GT. nest%znw(k-1)) THEN - CALL wrf_error_fatal("eta_levels are not uniformly decreasing from 1.0 to 0.0") + write(wrf_err_message,'(A,I2,A)') "--- ERROR: eta_level for grid_id=",nest%grid_id," are not monotonically decreasing. Check namelist." + CALL wrf_error_fatal( wrf_err_message ) ENDIF ENDDO - !DJW 140627 End of added code for specifying eta_levels + ENDIF + !DJW End of added code for specifying eta_levels DO k=1,kde_n-1 nest%dnw(k) = nest%znw(k+1)-nest%znw(k) @@ -293,6 +372,287 @@ SUBROUTINE vert_cor_vertical_nesting_arbitrary(nest,znw_c,kde_c) END SUBROUTINE vert_cor_vertical_nesting_arbitrary +SUBROUTINE compute_eta ( znw , & + eta_levels , max_eta , max_dz , & + p_top_def , g_def , p00_def , & + cvpm_def , a_def , r_d_def , cp_def , & + t00_def , p1000mb_def , t0_def , & + tiso_def , p_strat_def , a_strat_def , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ! Compute eta levels, either using given values from the namelist (hardly + ! a computation, yep, I know), or assuming a constant dz above the PBL, + ! knowing p_top and the number of eta levels. + + IMPLICIT NONE + + INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte + REAL , INTENT(IN) :: max_dz + REAL , INTENT(IN) :: p_top_def , g_def , p00_def , cvpm_def , & + a_def , r_d_def , cp_def , t00_def , & + p1000mb_def , t0_def , tiso_def , & + p_strat_def , a_strat_def + INTEGER , INTENT(IN) :: max_eta + REAL , DIMENSION (max_eta) :: eta_levels + + REAL , DIMENSION (kts:kte) , INTENT(OUT) :: znw + + ! Local vars + + INTEGER :: k , kk + REAL(KIND=8) :: mub , t_init , p_surf , pb, ztop, ztop_pbl , dz , temp + REAL(KIND=8) , DIMENSION(kts:kte) :: dnw + REAL(KIND=8) :: p_top , g , p00 , cvpm , & + a , r_d , cp , t00 , & + p1000mb , t0 , tiso , & + p_strat , a_strat + + INTEGER , PARAMETER :: prac_levels = 59 + INTEGER :: loop , loop1 + REAL(KIND=8) , DIMENSION(prac_levels) :: znw_prac , znu_prac , dnw_prac + REAL(KIND=8) , DIMENSION(MAX(prac_levels,kde)) :: alb , phb + REAL(KIND=8) :: alb_max, t_init_max, pb_max, phb_max + + CHARACTER(LEN=256) :: message + + ! Compute top of the atmosphere with some silly levels. We just want to + ! integrate to get a reasonable value for ztop. We use the planned + ! PBL-esque + ! levels, and then just coarse resolution above that. We know p_top, + ! and we + ! have the base state vars. + + p_top = p_top_def + g = g_def + p00 = p00_def + cvpm = cvpm_def + a = a_def + r_d = r_d_def + cp = cp_def + t00 = t00_def + p1000mb = p1000mb_def + t0 = t0_def + tiso = tiso_def + p_strat = p_strat_def + a_strat = a_strat_def + + p_surf = p00 + + znw_prac = (/ 1.0000_8 , 0.9930_8 , 0.9830_8 , 0.9700_8 , 0.9540_8 , 0.9340_8 , 0.9090_8 , 0.8800_8 , & + 0.8500_8 , 0.8000_8 , 0.7500_8 , 0.7000_8 , 0.6500_8 , 0.6000_8 , 0.5500_8 , 0.5000_8 , & + 0.4500_8 , 0.4000_8 , 0.3500_8 , 0.3000_8 , 0.2500_8 , 0.2000_8 , 0.1500_8 , 0.1000_8 , & + 0.0800_8 , 0.0600_8 , 0.0400_8 , 0.0200_8 , & + 0.0150_8 , 0.0100_8 , 0.0090_8 , 0.0080_8 , 0.0070_8 , 0.0060_8 , 0.0050_8 , 0.0040_8 , & + 0.0035_8 , 0.0030_8 , & + 0.0028_8 , 0.0026_8 , 0.0024_8 , 0.0022_8 , 0.0020_8 , & + 0.0018_8 , 0.0016_8 , 0.0014_8 , 0.0012_8 , 0.0010_8 , & + 0.0009_8 , 0.0008_8 , 0.0007_8 , 0.0006_8 , 0.0005_8 , 0.0004_8 , 0.0003_8 , & + 0.0002_8 , 0.0001_8 , 0.00005_8, 0.0000_8 /) + + DO k = 1 , prac_levels - 1 + znu_prac(k) = ( znw_prac(k) + znw_prac(k+1) ) * 0.5_8 + dnw_prac(k) = znw_prac(k+1) - znw_prac(k) + END DO + + DO k = 1, prac_levels-1 + pb = znu_prac(k)*(p_surf - p_top) + p_top + temp = MAX ( tiso, t00 + A*LOG(pb/p00) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat*LOG(pb/p_strat) + END IF + t_init = temp*(p00/pb)**(r_d/cp) - t0 + alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm + END DO + + ! Base state mu is defined as base state surface pressure minus p_top + + mub = p_surf - p_top + + ! Integrate base geopotential, starting at terrain elevation. + + phb(1) = 0._8 + DO k = 2,prac_levels + phb(k) = phb(k-1) - dnw_prac(k-1)*mub*alb(k-1) + END DO + + ! So, now we know the model top in meters. Get the average depth above the PBL + ! of each of the remaining levels. We are going for a constant delta z thickness. + + ztop = phb(prac_levels) / g + ztop_pbl = phb(8 ) / g + dz = ( ztop - ztop_pbl ) / REAL ( kde - 8 ) + + IF ( dz .GE. max_dz ) THEN + WRITE (message,FMT='("With a requested ",F7.1," Pa model top, the model lid will be about ",F7.1," m.")') p_top, ztop + CALL wrf_message ( message ) + WRITE (message,FMT='("With ",I3," levels above the PBL, the level thickness will be about ",F6.1," m.")') kde-8, dz + CALL wrf_message ( message ) + WRITE (message,FMT='("Thicknesses greater than ",F7.1," m are not recommended.")') max_dz + CALL wrf_message ( message ) + CALL wrf_error_fatal ( 'Add more levels to namelist.input for e_vert' ) + END IF + + ! Standard levels near the surface so no one gets in trouble. + + DO k = 1 , 8 + eta_levels(k) = znw_prac(k) + END DO + + ! Using d phb(k)/ d eta(k) = -mub * alb(k), eqn 2.9 + ! Skamarock et al, NCAR TN 468. Use full levels, so + ! use twice the thickness. + + DO k = 8, kte-1-2 + + find_prac : DO kk = 1 , prac_levels + IF (znw_prac(kk) .LT. eta_levels(k) ) THEN + EXIT find_prac + END IF + end do find_prac + + pb = 0.5*(eta_levels(k)+znw_prac(kk)) * (p_surf - p_top) + p_top + + temp = MAX ( tiso, t00 + A*LOG(pb/p00) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( pb/p_strat ) + END IF +! temp = t00 + A*LOG(pb/p00) + t_init = temp*(p00/pb)**(r_d/cp) - t0 + alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm + eta_levels(k+1) = eta_levels(k) - dz*g / ( mub*alb(k) ) + pb = 0.5*(eta_levels(k)+eta_levels(k+1)) * (p_surf - p_top) + p_top + + temp = MAX ( tiso, t00 + A*LOG(pb/p00) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( pb/p_strat ) + END IF +! temp = t00 + A*LOG(pb/p00) + t_init = temp*(p00/pb)**(r_d/cp) - t0 + alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm + eta_levels(k+1) = eta_levels(k) - dz*g / ( mub*alb(k) ) + pb = 0.5*(eta_levels(k)+eta_levels(k+1)) * (p_surf - p_top) + p_top + + phb(k+1) = phb(k) - (eta_levels(k+1)-eta_levels(k)) * mub*alb(k) + END DO + + alb_max = alb(kte-1-2) + t_init_max = t_init + pb_max = pb + phb_max = phb(kte-1) + + DO k = 1 , kte-1-2 + znw(k) = eta_levels(k) + END DO + znw(kte-2) = 0.000 + + ! There is some iteration. We want the top level, ztop, to be + ! consistent with the delta z, and we want the half level values + ! to be consistent with the eta levels. The inner loop to 10 gets + ! the eta levels very accurately, but has a residual at the top, due + ! to dz changing. We reset dz five times, and then things seem OK. + + DO loop1 = 1 , 5 + DO loop = 1 , 10 + DO k = 8, kte-1-2-1 + pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top + temp = MAX ( tiso, t00 + A*LOG(pb/p00) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( pb/p_strat ) + END IF + t_init = temp*(p00/pb)**(r_d/cp) - t0 + alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm + znw(k+1) = znw(k) - dz*g / ( mub*alb(k) ) + END DO + pb = pb_max + t_init = t_init_max + alb(kte-1-2) = alb_max + znw(kte-2) = znw(kte-1-2) - dz*g / ( mub*alb(kte-1-2) ) + IF ( ( loop1 .EQ. 5 ) .AND. ( loop .EQ. 10 ) ) THEN + print *,'Converged znw(kte) should be about 0.0 = ',znw(kte-2) + END IF + znw(kte-2) = 0.000 + END DO + + ! Here is where we check the eta levels values we just computed. + + DO k = 1, kde-1-2 + pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top + temp = MAX ( tiso, t00 + A*LOG(pb/p00) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( pb/p_strat ) + END IF + t_init = temp*(p00/pb)**(r_d/cp) - t0 + alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm + END DO + + phb(1) = 0. + DO k = 2,kde-2 + phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1) + END DO + + ! Reset the model top and the dz, and iterate. + + ztop = phb(kde-2)/g + ztop_pbl = phb(8)/g + dz = ( ztop - ztop_pbl ) / REAL ( (kde-2) - 8 ) + END DO + + IF ( dz .GT. max_dz ) THEN + print *,'z (m) = ',phb(1)/g + do k = 2 ,kte-2 + print *,'z (m) and dz (m) = ',phb(k)/g,(phb(k)-phb(k-1))/g + end do + print *,'dz (m) above fixed eta levels = ',dz + print *,'namelist max_dz (m) = ',max_dz + print *,'namelist p_top (Pa) = ',p_top + CALL wrf_debug ( 0, 'You need one of three things:' ) + CALL wrf_debug ( 0, '1) More eta levels to reduce the dz: e_vert' ) + CALL wrf_debug ( 0, '2) A lower p_top so your total height is reduced: p_top_requested') + CALL wrf_debug ( 0, '3) Increase the maximum allowable eta thickness: max_dz') + CALL wrf_debug ( 0, 'All are namelist options') + CALL wrf_error_fatal ( 'dz above fixed eta levels is too large') + END IF + + ! Add those 2 levels back into the middle, just above the 8 levels + ! that semi define a boundary layer. After we open up the levels, + ! then we just linearly interpolate in znw. So now levels 1-8 are + ! specified as the fixed boundary layer levels given in this routine. + ! The top levels, 12 through kte are those computed. The middle + ! levels 9, 10, and 11 are equi-spaced in znw, and are each 1/2 the + ! the znw thickness of levels 11 through 12. + + DO k = kte-2 , 9 , -1 + znw(k+2) = znw(k) + END DO + + znw( 9) = 0.75 * znw( 8) + 0.25 * znw(12) + znw(10) = 0.50 * znw( 8) + 0.50 * znw(12) + znw(11) = 0.25 * znw( 8) + 0.75 * znw(12) + + DO k = 8, kte-1 + pb = (znw(k)+znw(k+1))*0.5 * (p_surf - p_top) + p_top + temp = MAX ( tiso, t00 + A*LOG(pb/p00) ) + IF ( pb .LT. p_strat ) THEN + temp = tiso + A_strat * LOG ( pb/p_strat ) + END IF + t_init = temp*(p00/pb)**(r_d/cp) - t0 + alb(k) = (r_d/p1000mb)*(t_init+t0)*(pb/p1000mb)**cvpm + phb(k) = phb(k-1) - (znw(k)-znw(k-1)) * mub*alb(k-1) + END DO + phb(kte) = phb(kte-1) - (znw(kte)-znw(kte-1)) * mub*alb(kte-1) + + k=1 + WRITE (*,FMT='("Full level index = ",I4," Height = ",F7.1," m")') k,phb(1)/g + do k = 2 ,kte + WRITE (*,FMT='("Full level index = ",I4," Height = ",F7.1," m Thickness = ",F6.1," m")') k,phb(k)/g,(phb(k)-phb(k-1))/g + end do + +END SUBROUTINE compute_eta + !----------------------------------------------------------------------------------------- SUBROUTINE blend_terrain ( ter_interpolated , ter_input , & @@ -579,7 +939,7 @@ SUBROUTINE update_after_feedback_em ( grid & TYPE(domain) , TARGET :: grid ! Definitions of dummy arguments -#include +#include "dummy_new_decl.inc" INTEGER :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & diff --git a/wrfv2_fire/dyn_em/shift_domain_em.F b/wrfv2_fire/dyn_em/shift_domain_em.F index e9e825bd..eeb209cf 100644 --- a/wrfv2_fire/dyn_em/shift_domain_em.F +++ b/wrfv2_fire/dyn_em/shift_domain_em.F @@ -1,6 +1,6 @@ SUBROUTINE shift_domain_em ( grid , disp_x, disp_y & ! -# include +# include "dummy_new_args.inc" ! ) USE module_state_description @@ -32,7 +32,7 @@ SUBROUTINE shift_domain_em ( grid , disp_x, disp_y & ! need to split this routine to avoid clobbering certain widely used compilers SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y & ! -# include +# include "dummy_new_args.inc" ! ) USE module_state_description @@ -43,12 +43,12 @@ SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y & TYPE(domain) , POINTER :: grid ! Definitions of dummy arguments to solve -#include +#include "dummy_new_decl.inc" END SUBROUTINE shift_domain_em2 END INTERFACE ! Definitions of dummy arguments to solve -#include +#include "dummy_new_decl.inc" #ifdef MOVE_NESTS @@ -74,13 +74,13 @@ END SUBROUTINE shift_domain_em2 ! shift the nest domain in x do ii = 1,abs(disp_x) -#include +#include "SHIFT_HALO.inc" #include "../frame/loop_based_x_shift_code.h" enddo CALL shift_domain_em2 ( grid , disp_x, disp_y & ! -# include +# include "dummy_new_args.inc" ! ) @@ -90,7 +90,7 @@ END SUBROUTINE shift_domain_em SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y & ! -# include +# include "dummy_new_args.inc" ! ) USE module_state_description @@ -119,7 +119,7 @@ SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y & TYPE( fieldlist ), POINTER :: p ! Definitions of dummy arguments to solve -#include +#include "dummy_new_decl.inc" #ifdef MOVE_NESTS @@ -135,7 +135,7 @@ SUBROUTINE shift_domain_em2 ( grid , disp_x, disp_y & ! shift the nest domain in y do ii = 1,abs(disp_y) -#include +#include "SHIFT_HALO.inc" #include "../frame/loop_based_y_shift_code.h" enddo diff --git a/wrfv2_fire/dyn_em/solve_em.F b/wrfv2_fire/dyn_em/solve_em.F index 98963f2f..4f650275 100644 --- a/wrfv2_fire/dyn_em/solve_em.F +++ b/wrfv2_fire/dyn_em/solve_em.F @@ -132,7 +132,7 @@ SUBROUTINE solve_em ( grid , config_flags & ! storage for tendencies and decoupled state (generated from Registry) -#include +#include "i1_decl.inc" ! Previous time level of tracer arrays now defined as i1 variables; ! the state 4d arrays now redefined as 1-time level arrays in Registry. ! Benefit: save memory in nested runs, since only 1 domain is active at a @@ -177,7 +177,7 @@ SUBROUTINE solve_em ( grid , config_flags & TYPE(WRFU_TimeInterval) :: dtInterval, intervaltime,restartinterval ! Define benchmarking timers if -DBENCH is compiled -#include +#include "bench_solve_em_def.h" !---------------------- ! Executable statements @@ -215,7 +215,7 @@ SUBROUTINE solve_em ( grid , config_flags & ! ! Initialize timers if compiled with -DBENCH -#include +#include "bench_solve_em_init.h" ! set runge-kutta solver (2nd or 3rd order) @@ -298,6 +298,7 @@ SUBROUTINE solve_em ( grid , config_flags & endif grid%itimestep = grid%itimestep + 1 + grid%dtbc = grid%dtbc + grid%dt IF( coupler_on ) CALL cpl_store_input( grid, config_flags ) @@ -433,9 +434,47 @@ SUBROUTINE solve_em ( grid , config_flags & k_start, k_end ) ENDIF + + ! If the user has requested to optionally select the moist theta (use_theta_m==1) + ! switch, the first setting of the "old" value of theta_m uses the "old" + ! value of Qv. The moist_old variable does not exist until after the advection + ! towards the end of the RK loop. For the first time in the RK loop, we need + ! a reasonable value for moist_old. + + IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN + CALL initialize_moist_old ( moist_old(:,:,:,P_Qv), & + moist(:,:,:,P_Qv) , & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end ) + END IF ENDDO !$OMP END PARALLEL DO + ! Now that we might have initialized the moist_old values for P_Qv, fill + ! out some halos, etc. + IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) +# include "HALO_EM_MOIST_OLD_E_7.inc" +# include "PERIOD_BDY_EM_MOIST_OLD.inc" +#endif + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + DO ij = 1 , grid%num_tiles + im = P_Qv + CALL set_physical_bc3d( moist_old(ims,kms,jms,im), 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start , k_end ) + END DO + !$OMP END PARALLEL DO + END IF + !********************************************************************** ! ! LET US BEGIN....... @@ -696,7 +735,7 @@ SUBROUTINE solve_em ( grid , config_flags & , config_flags%use_adaptive_time_step & , curr_secs & , psim , psih , wspd , gz1oz0 & - , br , chklowq & + , chklowq & , cu_act_flag , hol , th_phy & , pi_phy , p_phy , grid%t_phy & , dz8w , p8w , t8w & @@ -730,7 +769,7 @@ SUBROUTINE solve_em ( grid , config_flags & , tke_tend & , adapt_step_flag , curr_secs & , psim , psih , wspd , gz1oz0 & - , br , chklowq & + , chklowq & , cu_act_flag , hol , th_phy & , pi_phy , p_phy , grid%t_phy & , dz8w , p8w , t8w & @@ -764,7 +803,7 @@ SUBROUTINE solve_em ( grid , config_flags & #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) # include "HALO_EM_THETAM.inc" # include "PERIOD_EM_THETAM.inc" -#else +#endif its=ips ; ite = ipe jts=jps ; jte = jpe CALL set_physical_bc3d( grid%h_diabatic, 'p', config_flags, & @@ -785,7 +824,6 @@ SUBROUTINE solve_em ( grid , config_flags & ips, ipe, jps, jpe, kps, kpe, & its, ite, jts, jte, & k_start , k_end ) -#endif END IF ! @@ -2846,6 +2884,7 @@ SUBROUTINE solve_em ( grid , config_flags & !************************************************************************************************************************ ! LES_fix: convert theta_m back to theta, point 2 ! 28 January 2015 + IF ( ( config_flags%use_theta_m .EQ. 1 ) .AND. (P_Qv .GE. PARAM_FIRST_SCALAR) ) THEN CALL thetam_to_theta ( grid%t_1 , moist_old(ims,kms,jms,P_qv) , & grid%t_2 , moist(ims,kms,jms,P_qv) , & @@ -2853,9 +2892,23 @@ SUBROUTINE solve_em ( grid , config_flags & ims, ime, jms, jme, kms, kme , & ips, ipe, jps, jpe, kps, kpe ) # ifdef DM_PARALLEL -# include "HALO_EM_THETAM.inc" -# include "PERIOD_EM_THETAM.inc" +# include "HALO_EM_THETAM.inc" +# include "PERIOD_EM_THETAM.inc" #endif + its=ips ; ite = ipe + jts=jps ; jte = jpe + CALL set_physical_bc3d( grid%t_1, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, & + k_start , k_end ) + CALL set_physical_bc3d( grid%t_2, 'p', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, & + k_start , k_end ) END IF ! end theta_m fix point 2 @@ -3700,7 +3753,8 @@ SUBROUTINE solve_em ( grid , config_flags & #if 0 BENCH_START(microswap_2) ! for load balancing; communication to redistribute the points - IF ( config_flags%mp_physics .EQ. ETAMPNEW ) THEN + IF ( config_flags%mp_physics .EQ. ETAMPNEW .OR. & + & config_flags%mp_physics .EQ. FER_MP_HIRES) THEN #include "SWAP_ETAMP_NEW.inc" ELSE IF ( config_flags%mp_physics .EQ. WSM3SCHEME ) THEN #include "SWAP_WSM3.inc" @@ -4410,7 +4464,6 @@ SUBROUTINE solve_em ( grid , config_flags & END DO tile_bc_loop_3 !$OMP END PARALLEL DO - grid%dtbc = grid%dtbc + grid%dt ENDIF ! reset surface w for consistency @@ -4550,7 +4603,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF ( grid%id .EQ. 1 ) grid%just_read_boundary = Is_alarm_tstep(grid%domain_clock, grid%alarms(BOUNDARY_ALARM)) ! Finish timers if compiled with -DBENCH. -#include +#include "bench_solve_em_end.h" RETURN diff --git a/wrfv2_fire/dyn_em/start_em.F b/wrfv2_fire/dyn_em/start_em.F index 69973f97..3d4a579d 100644 --- a/wrfv2_fire/dyn_em/start_em.F +++ b/wrfv2_fire/dyn_em/start_em.F @@ -35,6 +35,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & USE module_aerosols_soa_vbs, only: sum_pm_soa_vbs #endif USE module_diag_pld, ONLY : pld + USE module_diag_zld, ONLY : zld !!debug !USE module_compute_geop @@ -117,6 +118,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & !..Need to fill special height var for setting up initial condition. G. Thompson REAL, ALLOCATABLE, DIMENSION(:,:,:) :: z_at_q +! CCN for MP=18 initializatio + REAL :: ccn_max_val + CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -646,9 +650,8 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ENDDO ENDDO ENDDO - ELSE -! with nests, grid%t_init generally needs recomputations (since it is not interpolated) - IF ( .NOT. grid%this_is_an_ideal_run ) THEN + ELSE ! there is more than 1 domain + IF ( .NOT. grid%this_is_an_ideal_run ) THEN ! this is a real run DO j = jts,min(jte,jde-1) DO k = kts,kte-1 DO i = its, min(ite,ide-1) @@ -660,33 +663,82 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ENDIF grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0 grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm + ENDIF + ENDDO + ENDDO + ENDDO + + IF ( ( config_flags%rebalance .EQ. 1 ) .OR. & + ( ( config_flags%rebalance .EQ. 2 ) .AND. ( config_flags%vert_refine_method .EQ. 2 ) ) ) THEN + ! Integrate base geopotential, starting at terrain elevation. This assures that + ! the base state is in exact hydrostatic balance with respect to the model equations. + ! This field is on full levels. + DO j = jts,min(jte,jde-1) + DO i = its, min(ite,ide-1) + grid%phb(i,1,j) = grid%ht(i,j) * g + IF ( config_flags%hypsometric_opt .EQ. 1 ) THEN + DO k = 2,kte + grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j) + END DO + ELSE IF ( config_flags%hypsometric_opt .EQ. 2 ) THEN + DO k = 2,kte + pfu = grid%mub(i,j)*grid%znw(k) + grid%p_top + pfd = grid%mub(i,j)*grid%znw(k-1) + grid%p_top + phm = grid%mub(i,j)*grid%znu(k-1) + grid%p_top + grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu) + END DO ENDIF - ENDDO - ENDDO - ENDDO + ENDDO + ENDDO + END IF + ELSE - DO j = jts,min(jte,jde-1) - DO k = kts,kte-1 - DO i = its, min(ite,ide-1) - IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN - grid%pb(i,k,j) = grid%znu(k)*grid%mub(i,j)+grid%p_top - grid%alb(i,k,j) = -grid%rdnw(k)*(grid%phb(i,k+1,j)-grid%phb(i,k,j))/grid%mub(i,j) - grid%t_init(i,k,j) = grid%alb(i,k,j)*(p1000mb/r_d)/((grid%pb(i,k,j)/p1000mb)**cvpm) - t0 - ENDIF - ENDDO - ENDDO - ENDDO - END IF - ENDIF + IF ( config_flags%ideal_init_method .EQ. 1 ) THEN + DO j = jts,min(jte,jde-1) + DO k = kts,kte-1 + DO i = its, min(ite,ide-1) + IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN + grid%pb(i,k,j) = grid%znu(k)*grid%mub(i,j)+grid%p_top + grid%alb(i,k,j) = -grid%rdnw(k)*(grid%phb(i,k+1,j)-grid%phb(i,k,j))/grid%mub(i,j) + grid%t_init(i,k,j) = grid%alb(i,k,j)*(p1000mb/r_d)/((grid%pb(i,k,j)/p1000mb)**cvpm) - t0 + ENDIF + ENDDO + ENDDO + ENDDO + ELSE IF ( config_flags%ideal_init_method .EQ. 2 ) THEN + DO j = jts,min(jte,jde-1) + DO k = kts,kte-1 + DO i = its, min(ite,ide-1) + IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN + grid%pb(i,k,j) = grid%znu(k)*grid%mub(i,j)+grid%p_top + grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm + ENDIF + ENDDO + ENDDO + ENDDO + ! Integrate base geopotential, starting at terrain elevation. This assures that + ! the base state is in exact hydrostatic balance with respect to the model equations. + ! This field is on full levels. + DO j = jts,min(jte,jde-1) + DO i = its, min(ite,ide-1) + grid%phb(i,1,j) = grid%ht(i,j) * g + DO k = 2,kte + grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j) + END DO + ENDDO + ENDDO + END IF ! end if initialization for ideal, use method 1 or 2 + END IF ! end if this is a real or ideal run + END IF ! end if there is more than 1 domain + +!------base state is finished, perturbation values are recalculated below----- -! Use equations from calc_p_rho_phi to derive p and al from ph: linear in log p -!----------------------------------------------------------------------------- -!tgs - rebalance if the model is cycled but does not run DFI -! For HRRR application -! Rebalance recomputes 1/rho, p, ph_2, ph0, p_hyd + ! For the HRRR application, we want to go through this rebalancing. They + ! have a clunky way of testig on this, but it is operational, so no need to + ! cause them troubles. - IF ( ( grid%dfi_opt .EQ. DFI_NODFI ) .and. config_flags%cycling ) then - call rebalance_driver_cycl (grid ) + IF ( ( grid%dfi_opt .EQ. DFI_NODFI ) .and. ( config_flags%cycling ) ) THEN + call rebalance_driver_cycl (grid ) DO j = jts,min(jte,jde-1) DO k = kts,kte @@ -696,9 +748,29 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ENDDO ENDDO -! ENDIF + ! Everyone else runs thorugh here. NOTE that we might also want to call the + ! rebalancing ourselves for different set ups. It does not impact HRRR, so + ! it is an easy decision. + ELSE -!------------------------------------------------------------------------------ + + ! We request rebalancing for vertical grid nesting, or when the user asks for rebalancing. + ! Rebalance recomputes 1/rho, p, ph_2, ph0, p_hyd + + IF ( ( config_flags%rebalance .EQ. 1 ) .OR. & + ( ( config_flags%rebalance .EQ. 2 ) .AND. ( config_flags%vert_refine_method .EQ. 2 ) ) ) THEN + call rebalance_driver_cycl (grid ) + + DO j = jts,min(jte,jde-1) + DO k = kts,kte + DO i = its, min(ite,ide-1) + grid%ph_1(i,k,j)=grid%ph_2(i,k,j) + ENDDO + ENDDO + ENDDO + END IF + + ! Use equations from calc_p_rho_phi to derive p and al from ph: linear in log p IF ( config_flags%hypsometric_opt .EQ. 1 ) THEN DO j=jts,min(jte,jde-1) @@ -721,7 +793,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ENDDO ENDDO ENDDO - END IF + END IF ! which hypsometric option DO j=jts,min(jte,jde-1) DO k=kts,kte-1 DO i=its,min(ite,ide-1) @@ -734,8 +806,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ENDDO ENDDO ENDDO - ENDIF ! rebalance -!------------------------------------------------------------------------------------- + ENDIF ! Various rebalancing options IF ( .NOT. grid%this_is_an_ideal_run ) THEN DO j=jts,min(jte,jde-1) @@ -759,7 +830,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ENDDO END IF - ENDIF + ENDIF ! first trip for this domain DO j=jts,min(jte,jde-1) DO k = kts,kte @@ -815,15 +886,19 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ! Calculate any variables that were not set if (grid%starting_time_step == -1) then - grid%starting_time_step = NINT(6 * MIN(grid%dx,grid%dy) / 1000) + grid%starting_time_step = NINT(4 * MIN(grid%dx,grid%dy) / 1000) endif + grid%time_step = grid%starting_time_step + config_flags%time_step = grid%starting_time_step + model_config_rec%time_step = grid%starting_time_step + if (grid%max_time_step == -1) then - grid%max_time_step = 3*grid%starting_time_step + grid%max_time_step = NINT(8 * MIN(grid%dx,grid%dy) / 1000) endif if (grid%min_time_step == -1) then - grid%min_time_step = 0.5*grid%starting_time_step + grid%min_time_step = NINT(3 * MIN(grid%dx,grid%dy) / 1000) endif ! Set a starting timestep. @@ -855,7 +930,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & END IF - END IF + END IF ! adaptive computations ! End of adaptive time step modifications !----------------------------------------------------------------------------- @@ -881,13 +956,13 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & endif #endif - DO ij = 1, grid%num_tiles - !tgs do not need physics initialization for backward DFI integration IF ( ( grid%dfi_opt .EQ. DFI_NODFI ) .or. & ( ( grid%dfi_stage .NE. DFI_BCK ) .and. & ( grid%dfi_stage .NE. DFI_STARTBCK ) ) ) THEN !tgs, mods by tah + DO ij = 1, grid%num_tiles + CALL phy_init ( grid%id , config_flags, grid%DT, grid%RESTART, grid%znw, grid%znu, & grid%p_top, grid%tsk, grid%RADT,grid%BLDT,grid%CUDT, MPDT, & grid%rucuten, grid%rvcuten, grid%rthcuten, & @@ -957,6 +1032,8 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%m_ps_1,grid%m_ps_2,grid%m_hybi,aerosolc_1,aerosolc_2,& ! Optional grid%rundgdten,grid%rvndgdten,grid%rthndgdten, & ! Optional grid%rphndgdten,grid%rqvndgdten,grid%rmundgdten, & ! Optional + grid%SDA_HFX, grid%SDA_QFX, grid%QNORM, grid%HFX_BOTH,grid%QFX_BOTH, & ! fasdas + grid%HFX_FDDA, & ! fasdas grid%FGDT,grid%stepfg, & ! Optional grid%cugd_tten,grid%cugd_ttens,grid%cugd_qvten, & ! Optional grid%cugd_qvtens,grid%cugd_qcten, & ! Optional @@ -966,6 +1043,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & grid%CHXY, grid%FWETXY, grid%SNEQVOXY, grid%ALBOLDXY, grid%QSNOWXY, & ! Optional Noah-MP grid%WSLAKEXY, grid%ZWTXY, grid%WAXY, grid%WTXY, grid%LFMASSXY, grid%RTMASSXY, & ! Optional Noah-MP grid%STMASSXY, grid%WOODXY, grid%STBLCPXY, grid%FASTCPXY, & ! Optional Noah-MP + grid%GRAINXY, grid%GDDXY, & ! Optional Noah-MP grid%XSAIXY,grid%LAI, & ! Optional Noah-MP grid%T2MVXY, grid%T2MBXY, grid%CHSTARXY, & ! Optional Noah-MP grid%SMOISEQ ,grid%SMCWTDXY ,grid%RECHXY, grid%DEEPRECHXY, grid%AREAXY, & ! Optional Noah-MP @@ -1068,7 +1146,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & config_flags%nssl_cnoh, config_flags%nssl_cnohl, & config_flags%nssl_cnor, config_flags%nssl_cnos, & config_flags%nssl_rho_qh, config_flags%nssl_rho_qhl, & - config_flags%nssl_rho_qs & + config_flags%nssl_rho_qs, & + config_flags%nssl_ipelec, & + config_flags%nssl_isaund & ,grid%RQCNCUTEN, grid%RQINCUTEN,grid%rliq & !mchen add for cammpmg ,grid%cldfra_dp,grid%cldfra_sh & ! ckay for subgrid cloud ,grid%te_temf,grid%cf3d_temf,grid%wm_temf & ! WA @@ -1092,9 +1172,8 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ,grid%TS_URB2D_mosaic & ! danli mosaic ,grid%TS_RUL2D_mosaic & ! danli mosaic ) - ENDIF !tgs - - ENDDO + ENDDO ! loop of tiles for phy_init + ENDIF ! no phy_init for the backwards part of the DFI CALL wrf_debug ( 100 , 'start_domain_em: After call to phy_init' ) @@ -1150,7 +1229,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & call wrf_debug(100,'start_em: after calling lightning_init') - END IF + END IF ! restart #if 0 #include "CYCLE_TEST.inc" @@ -1532,6 +1611,31 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ENDIF +! Some initializations for the simple ccn field. + + IF ( f_qnn ) THEN + IF ( config_flags%mp_physics == wdm5scheme .or. config_flags%mp_physics == wdm6scheme ) THEN + ! NO OP + ELSE IF ( config_flags%mp_physics == nssl_2momccn ) THEN + grid%ccn_conc = config_flags%nssl_cccn/1.225 + ELSE + ! NO OP + END IF + ccn_max_val = MAXVAL(scalar(its:MIN(ite,ide-1),kts:kte-1,jts:MIN(jte,jde-1),p_qnn)) +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + ccn_max_val = wrf_dm_max_real ( ccn_max_val ) +#endif + IF ( ccn_max_val < 1.0 ) THEN ! initialization of ccn not already done + DO j=jts,MIN(jte,jde-1) + DO k=kts,kte + DO i=its,MIN(ite,ide-1) + scalar(i,k,j,p_qnn) = grid%ccn_conc + END DO + END DO + END DO + END IF + END IF + IF (num_scalar > 0) THEN ! use of (:,:,:,loop) not efficient on DEC, but (ims,kms,jms,loop) not portable to SGI/Cray @@ -1796,6 +1900,54 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte ) ENDIF + IF (config_flags%z_lev_diags == Z_DIAGS ) THEN + CALL wrf_debug ( 200 , ' ZLD: height level and AGL diags' ) + CALL zld ( & + ! Input data for computing + U=grid%u_2 & + ,V=grid%v_2 & + ,W=grid%w_2 & + ,t=grid%t_2 & + ,qv=moist(:,:,:,P_QV) & + ,zp=grid%ph_2 & + ,zb=grid%phb & + ,pp=grid%p & + ,pb=grid%pb & + ,p=grid%p_hyd & + ,pw=grid%p_hyd_w & + ! Map factors, coriolis for diags + ,msfux=grid%msfux & + ,msfuy=grid%msfuy & + ,msfvx=grid%msfvx & + ,msfvy=grid%msfvy & + ,msftx=grid%msftx & + ,msfty=grid%msfty & + ,f=grid%f & + ,e=grid%e & + ,ht=grid%ht & + ! Namelist info + ,use_tot_or_hyd_p=config_flags%use_tot_or_hyd_p & + ,extrap_below_grnd=config_flags%extrap_below_grnd & + ,missing=config_flags%z_lev_missing & + ! The diagnostics, mostly output variables + ,num_z_levels=config_flags%num_z_levels & + ,max_z_levels=max_zlevs & + ,z_levels=model_config_rec%z_levels & + ,z_zl = grid%z_zl & + ,u_zl = grid%u_zl & + ,v_zl = grid%v_zl & + ,t_zl = grid%t_zl & + ,rh_zl = grid%rh_zl & + ,ght_zl= grid%ght_zl & + ,s_zl = grid%s_zl & + ,td_zl = grid%td_zl & + ,q_zl = grid%q_zl & + ! Dimension arguments + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte ) + ENDIF + ! FIRE if(config_flags%ifire.eq.2)then @@ -1944,7 +2096,8 @@ SUBROUTINE rebalance_cycl ( grid & DO j = jts, MIN(jte,jde-1) DO i = its, MIN(ite,ide-1) - IF (n_moist >= PARAM_FIRST_SCALAR ) THEN + IF (n_moist >= PARAM_FIRST_SCALAR ) THEN + ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum ! equation) down from the top to get the pressure perturbation. First get the pressure ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. diff --git a/wrfv2_fire/dyn_exp/module_initialize_exp.F b/wrfv2_fire/dyn_exp/module_initialize_exp.F index 8796d39d..7723f001 100644 --- a/wrfv2_fire/dyn_exp/module_initialize_exp.F +++ b/wrfv2_fire/dyn_exp/module_initialize_exp.F @@ -24,7 +24,7 @@ MODULE module_initialize SUBROUTINE init_domain_exp ( grid & ! -# include +# include "exp_dummy_args.inc" ! ) IMPLICIT NONE @@ -32,7 +32,7 @@ SUBROUTINE init_domain_exp ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include +# include "exp_dummy_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -44,7 +44,7 @@ SUBROUTINE init_domain_exp ( grid & i, j, k #define COPY_IN -#include +#include "exp_scalar_derefs.inc" SELECT CASE ( model_data_order ) CASE ( DATA_ORDER_ZXY ) @@ -105,7 +105,7 @@ SUBROUTINE init_domain_exp ( grid & ENDDO #define COPY_OUT -#include +#include "exp_scalar_derefs.inc" RETURN @@ -142,7 +142,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_exp( grid & ! -#include +#include "actual_args.inc" ! ) diff --git a/wrfv2_fire/dyn_exp/solve_exp.F b/wrfv2_fire/dyn_exp/solve_exp.F index 7e1625da..85347d53 100644 --- a/wrfv2_fire/dyn_exp/solve_exp.F +++ b/wrfv2_fire/dyn_exp/solve_exp.F @@ -30,7 +30,7 @@ SUBROUTINE solve_exp ( grid & TYPE(domain) , TARGET :: grid ! Definitions of dummy arguments to solve -#include +#include "exp_dummy_decl.inc" ! WRF state bcs TYPE (grid_config_rec_type) :: config_flags @@ -50,7 +50,7 @@ SUBROUTINE solve_exp ( grid & INTEGER :: idum1, idum2 ! storage for tendencies and decoupled state (generated from Registry) -#include +#include "exp_i1_decl.inc" #ifdef DEREF_KLUDGE ! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm @@ -61,10 +61,10 @@ SUBROUTINE solve_exp ( grid & #include "deref_kludge.h" #define COPY_IN -#include +#include "exp_scalar_derefs.inc" #ifdef DM_PARALLEL # define REGISTER_I1 -# include +# include "exp_data_calls.inc" #endif CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) @@ -146,7 +146,7 @@ SUBROUTINE solve_exp ( grid & !$OMP END PARALLEL DO #define COPY_OUT -#include +#include "exp_scalar_derefs.inc" RETURN diff --git a/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F b/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F index f25843c1..e4f143a3 100644 --- a/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F +++ b/wrfv2_fire/dyn_nmm/NMM_NEST_UTILS1.F @@ -6,12 +6,14 @@ !=========================================================================== SUBROUTINE med_nest_egrid_configure ( parent , nest ) + USE module_dm USE module_domain USE module_configure USE module_timing IMPLICIT NONE TYPE(domain) , POINTER :: parent , nest + TYPE(domain), POINTER :: grid REAL, PARAMETER :: ERAD=6371200. REAL, PARAMETER :: DTR=0.01745329 REAL, PARAMETER :: DTAD=1.0 @@ -20,6 +22,10 @@ SUBROUTINE med_nest_egrid_configure ( parent , nest ) INTEGER :: IMS,IME,JMS,JME,KMS,KME INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE CHARACTER(LEN=255) :: message + CHARACTER (LEN=256) :: char_junk + + INTEGER :: comzilla + !---------------------------------------------------------------------------- ! PURPOSE: @@ -90,6 +96,10 @@ SUBROUTINE med_nest_egrid_configure ( parent , nest ) nest%dx = parent%dx/nest%parent_grid_ratio nest%dy = parent%dy/nest%parent_grid_ratio + write(message,*)" - nest%id = ",nest%id + CALL wrf_message(trim(message)) + write(message,*)" - parent%id = ",nest%id + CALL wrf_message(trim(message)) write(message,*)" - i_parent_start = ",nest%i_parent_start CALL wrf_message(trim(message)) write(message,*)" - j_parent_start = ",nest%j_parent_start @@ -115,6 +125,7 @@ SUBROUTINE med_nest_egrid_configure ( parent , nest ) CALL nl_get_cen_lat (parent%id, parent%cen_lat) ! cen_lat of parent set to nested domain CALL nl_get_cen_lon (parent%id, parent%cen_lon) ! cen_lon of parent set to nested domain + IF ( parent%active_this_task .AND. nest%active_this_task ) THEN nest%cen_lat=parent%cen_lat nest%cen_lon=parent%cen_lon ! @@ -129,14 +140,14 @@ SUBROUTINE med_nest_egrid_configure ( parent , nest ) ! soil configuration -#ifdef HWRF +#if ( HWRF == 1 ) !zhang if ( .not.nest%analysis ) then #endif nest%sldpth = parent%sldpth nest%dzsoil = parent%dzsoil nest%rtdpth = parent%rtdpth -#ifdef HWRF +#if ( HWRF == 1 ) endif #endif @@ -179,7 +190,7 @@ SUBROUTINE med_nest_egrid_configure ( parent , nest ) CALL nl_get_truelat1 (parent%id, parent%truelat1 ) CALL nl_get_truelat2 (parent%id, parent%truelat2 ) -#ifdef HWRF +#if ( HWRF == 1 ) ! bao : to make the restart output identical at the restart initial time for stand_lon CALL nl_get_stand_lon (parent%id, parent%stand_lon ) #endif @@ -202,6 +213,122 @@ SUBROUTINE med_nest_egrid_configure ( parent , nest ) CALL nl_set_map_proj(nest%id, nest%map_proj) CALL nl_set_iswater(nest%id, nest%iswater) + CALL nl_get_mminlu ( 1, char_junk ) + IF ( nest%id .GT. 1 ) THEN + CALL nl_set_mminlu ( nest%id, char_junk ) + ENDIF + + ENDIF +!!!!!!!!!!!!! +! handle case where task computes parent or nest but not both (case of both is handled above) + IF ( parent%active_this_task .OR. nest%active_this_task ) THEN + IF ( parent%active_this_task ) THEN + comzilla = mpi_comm_to_kid( which_kid( nest%id ) , parent%id ) +!debug write(0,*)__FILE__,__LINE__,'Patt: mpi_comm_to_kid ',comzilla,which_kid( nest%id ) ,nest%id, parent%id + grid => parent + ELSE + comzilla = mpi_comm_to_mom( nest%id ) +!debug write(0,*)__FILE__,__LINE__,'Natt: mpi_comm_to_mom ',comzilla,nest%id + grid => nest + ENDIF + +#define BCAST_RARRAY(X) BYTE_BCAST( X, size(X)*RWORDSIZE, comzilla ) +! soil configuration +#if ( HWRF == 1 ) +!zhang + if ( .not.nest%analysis ) then +#endif + CALL BCAST_RARRAY( grid%sldpth ) ! nest%sldpth = parent%sldpth + CALL BCAST_RARRAY( grid%dzsoil ) ! nest%dzsoil = parent%dzsoil + CALL BCAST_RARRAY( grid%rtdpth ) ! nest%rtdpth = parent%rtdpth +#if ( HWRF == 1 ) + endif +#endif + + IF ( parent%active_this_task ) THEN + CALL nl_get_mminlu ( 1, char_junk ) + ENDIF + CALL wrf_dm_bcast_string_comm( char_junk, LEN(char_junk),comzilla) ! nest%mminlu = trim(parent%mminlu) + IF ( nest%active_this_task .AND. nest%id .GT. 1 ) THEN + CALL nl_set_mminlu ( nest%id, char_junk ) + ENDIF + +! numerical set up + + CALL BYTE_BCAST( grid%cen_lat, RWORDSIZE, comzilla ) ! + CALL BYTE_BCAST( grid%cen_lon, RWORDSIZE, comzilla ) ! + CALL nl_set_cen_lat ( nest%id , nest%cen_lat) ! for output purpose + CALL nl_set_cen_lon ( nest%id , nest%cen_lon) ! for output purpose + ! "For output purposes" is not entirely true, because + ! the central lat (parent) is needed in the call to EARTH_LATLON + ! but it is derived (read from the input) so if this task isn't active + ! on the parent, it won't know it, so set it here. + ! Other way to have done this would have been to pass the nested cen_lat/lon + ! into EARTH_LATLON instead of the parent's. Flipped a coin. + IF ( .NOT. parent%active_this_task ) THEN + CALL nl_set_cen_lat ( parent%id , nest%cen_lat) ! for output purpose + CALL nl_set_cen_lon ( parent%id , nest%cen_lon) ! for output purpose + ENDIF + + IF ( nest%active_this_task ) THEN + write(message,*)" - nest%cen_lat = ",nest%cen_lat + CALL wrf_message(trim(message)) + write(message,*)" - nest%cen_lon = ",nest%cen_lon + CALL wrf_message(trim(message)) + ENDIF + + CALL BYTE_BCAST( grid%truelat1, RWORDSIZE, comzilla ) ! + CALL BYTE_BCAST( grid%truelat2, RWORDSIZE, comzilla ) ! + CALL nl_set_truelat1(nest%id, nest%truelat1) + CALL nl_set_truelat2(nest%id, nest%truelat2) + + CALL BYTE_BCAST( grid%stand_lon, RWORDSIZE, comzilla ) ! + CALL nl_set_stand_lon(nest%id, nest%stand_lon) + + CALL BYTE_BCAST( grid%map_proj, IWORDSIZE, comzilla ) ! + CALL BYTE_BCAST( grid%iswater, IWORDSIZE, comzilla ) ! + CALL nl_set_map_proj(nest%id, nest%map_proj) + CALL nl_set_iswater(nest%id, nest%iswater) + + CALL BCAST_RARRAY( grid%deta ) ! nest%deta = parent%deta + CALL BCAST_RARRAY( grid%aeta ) ! nest%aeta = parent%aeta + CALL BCAST_RARRAY( grid%etax ) ! nest%etax = parent%etax + CALL BCAST_RARRAY( grid%dfl ) ! nest%dfl = parent%dfl + CALL BCAST_RARRAY( grid%deta1 ) ! nest%deta1 = parent%deta1 + CALL BCAST_RARRAY( grid%aeta1 ) ! nest%aeta1 = parent%aeta1 + CALL BCAST_RARRAY( grid%eta1 ) ! nest%eta1 = parent%eta1 + CALL BCAST_RARRAY( grid%deta2 ) ! nest%deta2 = parent%deta2 + CALL BCAST_RARRAY( grid%aeta2 ) ! nest%aeta2 = parent%aeta2 + CALL BCAST_RARRAY( grid%eta2 ) ! nest%eta2 = parent%eta2 + CALL BYTE_BCAST( grid%pdtop, RWORDSIZE, comzilla ) ! nest%pdtop = parent%pdtop + CALL BYTE_BCAST( grid%pt, RWORDSIZE, comzilla ) ! nest%pt = parent%pt + CALL BYTE_BCAST( grid%dfrlg, RWORDSIZE, comzilla ) ! nest%dfrlg = parent%dfrlg + CALL BYTE_BCAST( grid%num_soil_layers, IWORDSIZE, comzilla ) ! nest%num_soil_layers = parent%num_soil_layers + CALL BYTE_BCAST( grid%num_moves, IWORDSIZE, comzilla ) ! nest%num_moves = parent%num_moves + +! Unfortunately, some of the single value constants in used in module_initialize have +! to be defiend here instead of the usual spot in med_initialize_nest_nmm. There +! appears to be a problem in Registry and related code in this area. +! +! state logical upstrm - dyn_nmm - - - + + ENDIF + + IF ( nest%active_this_task ) THEN + + nest%dlmd = nest%dx + nest%dphd = nest%dy + nest%dy_nmm = erad*(nest%dphd*dtr) + nest%cpgfv = -nest%dt/(48.*nest%dy_nmm) + nest%en = nest%dt/( 4.*nest%dy_nmm)*dtad + nest%ent = nest%dt/(16.*nest%dy_nmm)*dtad + nest%f4d = -.5*nest%dt*dtad + nest%f4q = -nest%dt*dtad + nest%ef4t = .5*nest%dt/cp + + ENDIF + + ! physics and other configurations ! CALL nl_get_iswater (parent%id, nest%iswater) ! iswater is just based on parents ! CALL nl_get_bl_surface_physics (nest%id, nest%bl_surface_physics ) @@ -211,12 +338,14 @@ SUBROUTINE med_nest_egrid_configure ( parent , nest ) END SUBROUTINE med_nest_egrid_configure SUBROUTINE med_construct_egrid_weights ( parent , nest ) + USE module_dm USE module_domain USE module_configure USE module_timing IMPLICIT NONE TYPE(domain) , POINTER :: parent , nest + TYPE(domain), POINTER :: grid LOGICAL, EXTERNAL :: wrf_dm_on_monitor INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE INTEGER :: IMS,IME,JMS,JME,KMS,KME @@ -227,6 +356,7 @@ SUBROUTINE med_construct_egrid_weights ( parent , nest ) REAL :: SW_LATD,SW_LOND REAL :: ADDSUM1,ADDSUM2 REAL :: xr,zr,xc + INTEGER :: comzilla !----------------------------------------------------------------------------------------------------------- ! PURPOSE: ! - Initialize lat-lons and determine weights @@ -235,6 +365,16 @@ SUBROUTINE med_construct_egrid_weights ( parent , nest ) ! First obtain central latitude and longitude for the parent domain + IF ( parent%active_this_task .OR. nest%active_this_task ) THEN + IF ( parent%active_this_task ) THEN + comzilla = mpi_comm_to_kid( which_kid( nest%id ) , parent%id ) + grid => parent + ELSE + comzilla = mpi_comm_to_mom( nest%id ) + grid => nest + ENDIF + ENDIF + CALL nl_get_cen_lat (parent%ID, parent_CLAT) CALL nl_get_cen_lon (parent%ID, parent_CLON) @@ -268,12 +408,15 @@ SUBROUTINE med_construct_egrid_weights ( parent , nest ) ! Now compute Geodetic lat/lon (Positive East) of parent grid in degrees + IF ( parent%active_this_task ) THEN + CALL EARTH_LATLON ( parent%HLAT,parent%HLON,parent%VLAT,parent%VLON, & !output parent_DLMD,parent_DPHD,parent_WBD,parent_SBD, & !inputs parent_CLAT,parent_CLON, & IDS,IDE,JDS,JDE,KDS,KDE, & IMS,IME,JMS,JME,KMS,KME, & ITS,ITE,JTS,JTE,KTS,KTE ) + ENDIF ! Nested grid configuration, including, western and southern boundary @@ -308,6 +451,7 @@ SUBROUTINE med_construct_egrid_weights ( parent , nest ) ! as the parent grid ! + IF ( nest%active_this_task ) THEN CALL EARTH_LATLON ( nest%HLAT,nest%HLON,nest%VLAT,nest%VLON, & ! output nest_DLMD,nest_DPHD,nest_WBD,nest_SBD, & ! nest inputs parent_CLAT,parent_CLON, & ! parent central lat/lon @@ -391,11 +535,126 @@ SUBROUTINE med_construct_egrid_weights ( parent , nest ) IDS,IDE,JDS,JDE,KDS,KDE, & ! IMS,IME,JMS,JME,KMS,KME, & ! nested grid configuration ITS,ITE,JTS,JTE,KTS,KTE ) + ENDIF !------------------------------------------------------------------------------------------ END SUBROUTINE med_construct_egrid_weights +SUBROUTINE med_set_egrid_locs ( parent , nest ) + USE module_domain + USE module_configure + USE module_timing + + IMPLICIT NONE + TYPE(domain) :: parent , nest + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE + INTEGER :: IMS,IME,JMS,JME,KMS,KME + INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE + INTEGER :: I,J,II,JJ,NII,NJJ + REAL :: parent_CLAT,parent_CLON,parent_WBD,parent_SBD,parent_DLMD,parent_DPHD + REAL :: nest_WBD,nest_SBD,nest_DLMD,nest_DPHD + REAL :: SW_LATD,SW_LOND + REAL :: ADDSUM1,ADDSUM2 + REAL :: xr,zr,xc +character*255 :: message +!----------------------------------------------------------------------------------------------------------- +! PURPOSE: +! - Initialize lat-lons and determine weights +! +!---------------------------------------------------------------------------------------------------------- + +! First obtain central latitude and longitude for the parent domain + + CALL nl_get_cen_lat (parent%ID, parent_CLAT) + CALL nl_get_cen_lon (parent%ID, parent_CLON) + +! Parent grid configuration, including, western and southern boundary + + IDS = parent%sd31 + IDE = parent%ed31 + JDS = parent%sd32 + JDE = parent%ed32 + KDS = parent%sd33 + KDE = parent%ed33 + + IMS = parent%sm31 + IME = parent%em31 + JMS = parent%sm32 + JME = parent%em32 + KMS = parent%sm33 + KME = parent%em33 + + ITS = parent%sp31 + ITE = parent%ep31 + JTS = parent%sp32 + JTE = parent%ep32 + KTS = parent%sp33 + KTE = parent%ep33 +! + parent_DLMD = parent%dx ! DLMD: dlamda in degrees + parent_DPHD = parent%dy ! DPHD: dphi in degrees + parent_WBD = parent%wbd0 + parent_SBD = parent%sbd0 + +! Now compute Geodetic lat/lon (Positive East) of parent grid in degrees + + IF ( parent%active_this_task ) THEN + + CALL EARTH_LATLON ( parent%HLAT,parent%HLON,parent%VLAT,parent%VLON, & !output + parent_DLMD,parent_DPHD,parent_WBD,parent_SBD, & !inputs + parent_CLAT,parent_CLON, & + IDS,IDE,JDS,JDE,KDS,KDE, & + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) + ENDIF + + if(nest%id == parent%id) return ! nothing more to do; same data structure + +! Nested grid configuration, including, western and southern boundary + + IDS = nest%sd31 + IDE = nest%ed31 + JDS = nest%sd32 + JDE = nest%ed32 + KDS = nest%sd33 + KDE = nest%ed33 + + IMS = nest%sm31 + IME = nest%em31 + JMS = nest%sm32 + JME = nest%em32 + KMS = nest%sm33 + KME = nest%em33 + + ITS = nest%sp31 + ITE = nest%ep31 + JTS = nest%sp32 + JTE = nest%ep32 + KTS = nest%sp33 + KTE = nest%ep33 +! + nest_DLMD = nest%dx + nest_DPHD = nest%dy + nest_WBD = nest%wbd0 + nest_SBD = nest%sbd0 + +! +! Now compute Geodetic lat/lon (Positive East) of nest in degrees, with the same central lat-lon +! as the parent grid +! + + IF ( nest%active_this_task ) THEN + + CALL EARTH_LATLON ( nest%HLAT,nest%HLON,nest%VLAT,nest%VLON, & ! output + nest_DLMD,nest_DPHD,nest_WBD,nest_SBD, & ! nest inputs + parent_CLAT,parent_CLON, & ! parent central lat/lon + IDS,IDE,JDS,JDE,KDS,KDE, & ! nested domain dimension + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) + ENDIF + end SUBROUTINE med_set_egrid_locs !====================================================================================== ! ! compute earth lat-lons for parent and the nest before interpolations @@ -2607,7 +2866,7 @@ SUBROUTINE SPLINE1(I,J,JTBX,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) II=9999 !67 !35 !50 !4 JJ=9999 !31 !73 !115 !192 -#if defined(EXPENSIVE_HWRF_DEBUG_STUFF) +#if ( HWRF == 1 ) IF(I.eq.II.and.J.eq.JJ)THEN WRITE(message,*)'DEBUG in SPLINE1:HSO= ',xnew(1:nold) CALL wrf_debug(1,trim(message)) @@ -2692,7 +2951,7 @@ SUBROUTINE SPLINE1(I,J,JTBX,NOLD,XOLD,YOLD,Y2,NNEW,XNEW,YNEW,P,Q) ! debug -#if defined(EXPENSIVE_HWRF_DEBUG_STUFF) +#if ( HWRF == 1 ) if(i.eq.ii.and.j.eq.jj)then write(message,*) 'DEBUG:: k1,xnew(k1),ynew(k1): ', k1,xnew(k1),ynew(k1) CALL wrf_debug(1,trim(message)) @@ -2848,6 +3107,8 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) end if ! Monitor process stores high-resolution topography: + IF ( nest%active_this_task ) THEN + CALL push_communicators_for_domain(nest%id) #ifdef DM_PARALLEL monitor_only: IF ( wrf_dm_on_monitor() ) THEN #endif @@ -2855,8 +3116,8 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) call MASTER(IDS,IDE,JDS,JDE) #ifdef DM_PARALLEL ELSE - call wrf_debug(1,'NEST_TERRAIN SLAVE PROCESS') - call SLAVE(IDS,IDE,JDS,JDE) + call wrf_debug(1,'NEST_TERRAIN CLIENT PROCESS') + call CLIENT(IDS,IDE,JDS,JDE) ENDIF monitor_only #endif @@ -2886,6 +3147,8 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) ENDDO write(message,'("Nest d",I0," nest_terrain")') nest%id + CALL pop_communicators_for_domain + ENDIF call END_TIMING(trim(message)) #ifdef IDEAL_NMM_TC @@ -2894,7 +3157,7 @@ SUBROUTINE NEST_TERRAIN ( nest, config_flags ) CONTAINS #ifdef DM_PARALLEL - SUBROUTINE SLAVE(IDS,IDE,JDS,JDE) + SUBROUTINE CLIENT(IDS,IDE,JDS,JDE) IMPLICIT NONE integer, intent(in) :: IDS,IDE,JDS,JDE REAL, DIMENSION(1,1) :: avc_nest,lnd_nest @@ -2911,7 +3174,7 @@ SUBROUTINE SLAVE(IDS,IDE,JDS,JDE) call wrf_debug(1,'back from wrf_global_to_patch_real in nest_terrain') - END SUBROUTINE SLAVE + END SUBROUTINE CLIENT #endif SUBROUTINE MASTER(IDS,IDE,JDS,JDE) IMPLICIT NONE @@ -2986,6 +3249,8 @@ SUBROUTINE med_init_domain_constants_nmm ( parent, nest) !, config_flags) USE module_domain USE module_configure USE module_timing + USE module_dm, ONLY : intercomm_active + IMPLICIT NONE TYPE(domain) , POINTER :: parent, nest, grid ! @@ -2993,7 +3258,7 @@ SUBROUTINE med_init_domain_constants_nmm ( parent, nest) !, config_flags) INTERFACE SUBROUTINE med_initialize_nest_nmm ( grid & ! -# include +# include "dummy_new_args.inc" ! ) USE module_domain @@ -3001,7 +3266,7 @@ SUBROUTINE med_initialize_nest_nmm ( grid & USE module_timing IMPLICIT NONE TYPE(domain) , POINTER :: grid -#include +#include "dummy_new_decl.inc" END SUBROUTINE med_initialize_nest_nmm END INTERFACE @@ -3014,17 +3279,19 @@ END SUBROUTINE med_initialize_nest_nmm grid => nest - CALL med_initialize_nest_nmm( grid & + IF ( intercomm_active( grid%id ) ) THEN + CALL med_initialize_nest_nmm( grid & ! -# include +# include "actual_new_args.inc" ! ) + ENDIF END SUBROUTINE med_init_domain_constants_nmm SUBROUTINE med_initialize_nest_nmm( grid & ! -# include +# include "dummy_new_args.inc" ! ) @@ -3091,12 +3358,12 @@ SUBROUTINE med_initialize_nest_nmm( grid & CHARACTER(LEN=255) :: message ! Definitions of dummy arguments to solve -#include +#include "dummy_new_decl.inc" !#define COPY_IN -!#include +!#include "scalar_derefs.inc" #ifdef DM_PARALLEL -# include +# include "data_calls.inc" #endif CALL get_ijk_from_grid ( grid , & @@ -3122,6 +3389,7 @@ SUBROUTINE med_initialize_nest_nmm( grid & WRITE(message,*)'IDS,IDE ON DOMAIN',grid%id,'==',ids,ide CALL wrf_message(trim(message)) ! +IF ( grid%active_this_task ) THEN ALLOCATE(KHL2(JTS:NNYP),KVL2(JTS:NNYP),KHH2(JTS:NNYP),KVH2(JTS:NNYP)) ALLOCATE(DXJ(JTS:NNYP),WPDARJ(JTS:NNYP),CPGFUJ(JTS:NNYP),CURVJ(JTS:NNYP)) ALLOCATE(FCPJ(JTS:NNYP),FDIVJ(JTS:NNYP),FADJ(JTS:NNYP)) @@ -3137,7 +3405,7 @@ SUBROUTINE med_initialize_nest_nmm( grid & ! to find where sea ice is. That's why alogirthm here is slightly different than the ! one used in module_initalize_real.f -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing: added to AVOID THIS COMPUTATION IF THE NEST IS STARTED USING ANALYSIS FILE IF(.not. grid%analysis)THEN #endif @@ -3171,45 +3439,6 @@ SUBROUTINE med_initialize_nest_nmm( grid & ENDDO ENDDO -#if 0 - DO J = JTS, MIN(JTE,JDE-1) - DO I = ITS, MIN(ITE,IDE-1) - IF(grid%sm(I,J).GT.0.9) THEN ! OVER WATER SURFACE -! - IF (XICE(I,J) .gt. 0)THEN ! XICE: SI INPUT ON PARENT, INTERPOLATED ONTO NEST - grid%si(I,J)=1.0 ! INITIALIZE SI BASED ON XICE FROM INTERPOLATED INPUT - ENDIF -! - grid%epsr(I,J)= 0.97 ! VALID OVER SEA SURFACE - grid%embck(I,J)= 0.97 ! VALID OVER SEA SURFACE - grid%gffc(I,J)= 0. - grid%albedo(I,J)=.06 - grid%albase(I,J)=.06 -! - IF(grid%si (I,J) .GT. 0.)THEN ! VALID OVER SEA-ICE - grid%sm(I,J)=0. - grid%si(I,J)=0. ! - grid%sice(I,J)=1. - grid%gffc(I,J)=0. ! just leave zero as irrelevant - grid%albedo(I,J)=.60 ! DEFINE grid%albedo - grid%albase(I,J)=.60 - ENDIF -! - ELSE ! OVER LAND SURFACE -! - grid%si(I,J)=5.0*grid%weasd(I,J)/1000. ! SNOW WATER EQ (mm) OBTAINED FROM PARENT (grid%si) IS INTERPOLATED - grid%epsr(I,J)=1.0 ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN - grid%embck(I,J)=1.0 ! EMISSIVITY DEFINED OVER LAND IN THE NESTED DOMAIN - grid%gffc(I,J)=0.0 ! just leave zero as irrelevant - grid%sice(I,J)=0. ! SEA ICE - grid%sno(I,J)=grid%si(I,J)*.20 ! LAND-SNOW COVER -! - ENDIF -! - ENDDO - ENDDO -#endif - ! This may just be a fix and may need some Registry related changes, later on DO J = JTS, MIN(JTE,JDE-1) @@ -3281,7 +3510,7 @@ SUBROUTINE med_initialize_nest_nmm( grid & #endif ENDIF ! -#if defined(HWRF) +#if ( HWRF == 1 ) ! HWRF should not perform the check below because the nmm_tsk is ! update with the correct skin temperature every timestep (on both ! land and sea points). @@ -3316,7 +3545,7 @@ SUBROUTINE med_initialize_nest_nmm( grid & grid%sldpth(3)=0.6 grid%sldpth(4)=1.0 -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing: added to AVOID THIS COMPUTATION IF THE NEST IS STARTED USING ANALYSIS FILE ENDIF ! <------ for analysis set to false #endif @@ -3650,6 +3879,7 @@ SUBROUTINE med_initialize_nest_nmm( grid & DEALLOCATE(HDACJ,DDMPUJ,DDMPVJ) DEALLOCATE(KHLA,KHHA) DEALLOCATE(KVLA,KVHA) +ENDIF END SUBROUTINE med_initialize_nest_nmm diff --git a/wrfv2_fire/dyn_nmm/depend.dyn_nmm b/wrfv2_fire/dyn_nmm/depend.dyn_nmm index 15ad8511..e6bccee7 100644 --- a/wrfv2_fire/dyn_nmm/depend.dyn_nmm +++ b/wrfv2_fire/dyn_nmm/depend.dyn_nmm @@ -29,8 +29,9 @@ NMM_NEST_UTILS1.o: module_TERRAIN.o module_SMOOTH_TERRAIN.o \ module_STATS_FOR_MOVE.o: ../frame/module_dm.o ../frame/module_domain.o \ ../frame/module_configure.o module_membrane_mslp.o module_tracker.o -start_domain_nmm.o: module_HIFREQ.o ../share/module_random.o module_STATS_FOR_MOVE.o \ - module_tornado_genesis.o module_swath.o ../frame/module_clear_halos.o +#start_domain_nmm.o: module_HIFREQ.o ../share/module_random.o module_STATS_FOR_MOVE.o \ +# module_tornado_genesis.o module_swath.o ../frame/module_clear_halos.o \ +# ../phys/module_physics_init.o module_ADVECTION.o: ../share/module_MPP.o module_INDX.o @@ -72,6 +73,9 @@ module_initialize_tropical_cyclone.o: ../share/module_model_constants.o start_domain_nmm.o: module_ADVECTION.o module_BNDRY_COND.o module_CTLBLK.o \ module_DIFFUSION_NMM.o module_GWD.o module_NONHY_DYNAM.o \ module_IGWAVE_ADJUST.o \ - module_HIFREQ.o ../share/module_random.o + module_HIFREQ.o ../share/module_random.o \ + ../phys/module_physics_init.o \ + module_STATS_FOR_MOVE.o \ + module_tornado_genesis.o module_swath.o ../frame/module_clear_halos.o # DO NOT DELETE diff --git a/wrfv2_fire/dyn_nmm/module_DIFFUSION_NMM.F b/wrfv2_fire/dyn_nmm/module_DIFFUSION_NMM.F index 85a5f6b3..14904f68 100644 --- a/wrfv2_fire/dyn_nmm/module_DIFFUSION_NMM.F +++ b/wrfv2_fire/dyn_nmm/module_DIFFUSION_NMM.F @@ -27,7 +27,7 @@ MODULE MODULE_DIFFUSION_NMM !*********************************************************************** SUBROUTINE HDIFF(NTSD,DT,FIS,DY,HDAC,HDACV & & ,HBM2,DETA1,SIGMA & -#ifdef HWRF +#if ( HWRF == 1 ) & ,T,Q,U,V,Q2,Z,W,SM,SICE,h_diff & #else & ,T,Q,U,V,Q2,Z,W,SM,SICE & @@ -103,7 +103,7 @@ SUBROUTINE HDIFF(NTSD,DT,FIS,DY,HDAC,HDACV & INTEGER,INTENT(IN) :: NTSD ! REAL,INTENT(IN) :: DT,DY -#ifdef HWRF +#if ( HWRF == 1 ) REAL,INTENT(IN) :: H_DIFF #endif ! @@ -148,7 +148,7 @@ SUBROUTINE HDIFF(NTSD,DT,FIS,DY,HDAC,HDACV & !*********************************************************************** !----------------------------------------------------------------------- ! -#ifdef HWRF +#if ( HWRF == 1 ) SLOPHC=SLOPHT*SQRT(2.)*0.5*9. #else SLOPHC=config_flags%slophc @@ -367,7 +367,7 @@ SUBROUTINE HDIFF(NTSD,DT,FIS,DY,HDAC,HDACV & T (I,J,K)=T (I,J,K)+TDIF (I,J) Q (I,J,K)=Q (I,J,K)+QDIF (I,J) ! -#ifdef HWRF +#if ( HWRF == 1 ) U(I,J,K)=U(I,J,K)+UDIF(I,J)*h_diff V(I,J,K)=V(I,J,K)+VDIF(I,J)*h_diff #else @@ -449,7 +449,7 @@ SUBROUTINE HDIFF(NTSD,DT,FIS,DY,HDAC,HDACV & ! DO J=MYJS2,MYJE2 DO I=MYIS1,MYIE1 -#ifdef HWRF +#if ( HWRF == 1 ) U(I,J,K)=U(I,J,K)-(UNE(I,J)-UNE(I+IVW(J),J-1) & & +USE(I,J)-USE(I+IVW(J),J+1))*HDACV(I,J)*h_diff V(I,J,K)=V(I,J,K)-(VNE(I,J)-VNE(I+IVW(J),J-1) & diff --git a/wrfv2_fire/dyn_nmm/module_HIFREQ.F b/wrfv2_fire/dyn_nmm/module_HIFREQ.F index 7f534d45..876810b0 100644 --- a/wrfv2_fire/dyn_nmm/module_HIFREQ.F +++ b/wrfv2_fire/dyn_nmm/module_HIFREQ.F @@ -1,6 +1,6 @@ module module_HIFREQ -#ifdef HWRF +#if ( HWRF == 1 ) ! This module implements the high-frequency output requested by the ! National Hurricane Center in 2010. The hifreq_write routine will ! write a file that contains max. 10m wind, min. MSLP, their locations, @@ -134,8 +134,11 @@ SUBROUTINE HIFREQ_WRITE (LUN,NTSD,DT,HLAT,HLON & !$$$ !********************************************************************** ! +#ifdef DM_PARALLEL + use mpi ! , only: MPI_MAXLOC, MPI_Allreduce, MPI_Bcast, MPI_2REAL, MPI_REAL + USE MODULE_DM, only : wrf_dm_minloc_real, wrf_dm_maxloc_real, mytask, local_communicator +#endif USE MODULE_NEST_UTIL, only : MSLP_DIAG - USE MODULE_DM, only : wrf_dm_minloc_real, wrf_dm_maxloc_real IMPLICIT NONE ! @@ -158,7 +161,8 @@ SUBROUTINE HIFREQ_WRITE (LUN,NTSD,DT,HLAT,HLON & REAL :: MINGBL_MSLP, MAXGBL_WIND, ZDUM, PREF REAL :: CLAT,CLON,PLAT,PLON,WLAT,WLON, WREF, HAVE_CEN INTEGER :: IWIND,JWIND, IMSLP,JMSLP - INTEGER :: ICEN,JCEN,I,J,ITF,JTF + INTEGER :: ICEN,JCEN,I,J,ITF,JTF,ierr,grank,myrank + REAL :: comm(6),reduced(6),bcast(4) !---------------------------------------------------------------------- @@ -207,10 +211,56 @@ SUBROUTINE HIFREQ_WRITE (LUN,NTSD,DT,HLAT,HLON & CLON=HLON(ICEN,JCEN) end if +#ifdef DM_PARALLEL ! Get grid-wide extrema: - call WRF_DM_MAXLOC_REAL(have_cen,clat,clon,zdum,icen,jcen) - call WRF_DM_MINLOC_REAL(mingbl_mslp,plat,plon,zdum,imslp,jmslp) - call WRF_DM_MAXLOC_REAL(maxgbl_wind,wlat,wlon,zdum,iwind,jwind) + call MPI_Comm_rank(local_communicator,myrank,ierr) + comm(1)=have_cen + comm(2)=myrank + comm(3)=-mingbl_mslp + comm(4)=myrank + comm(5)=maxgbl_wind + comm(6)=myrank + call MPI_Allreduce(comm,reduced,3,MPI_2REAL,MPI_MAXLOC,local_communicator,ierr) + + have_cen=reduced(1) + grank=reduced(2) + if(myrank==grank) then + bcast=(/ clat,clon,real(icen),real(jcen) /) + endif + call MPI_Bcast(bcast,4,MPI_REAL,grank,local_communicator,ierr) + if(myrank/=grank) then + clat=bcast(1) + clon=bcast(2) + icen=bcast(3) + jcen=bcast(4) + endif + + mingbl_mslp=-reduced(3) + grank=reduced(4) + if(myrank==grank) then + bcast=(/ plat,plon,real(imslp),real(jmslp) /) + endif + call MPI_Bcast(bcast,4,MPI_REAL,grank,local_communicator,ierr) + if(myrank/=grank) then + plat=bcast(1) + plon=bcast(2) + imslp=bcast(3) + jmslp=bcast(4) + endif + + maxgbl_wind=reduced(5) + grank=reduced(6) + if(myrank==grank) then + bcast=(/ wlat,wlon,real(iwind),real(jwind) /) + endif + call MPI_Bcast(bcast,4,MPI_REAL,grank,local_communicator,ierr) + if(myrank/=grank) then + wlat=bcast(1) + wlon=bcast(2) + iwind=bcast(3) + jwind=bcast(4) + endif +#endif ! Monitor process writes out values. if(wrf_dm_on_monitor()) then diff --git a/wrfv2_fire/dyn_nmm/module_IGWAVE_ADJUST.F b/wrfv2_fire/dyn_nmm/module_IGWAVE_ADJUST.F index e8497c0e..64fa56cd 100644 --- a/wrfv2_fire/dyn_nmm/module_IGWAVE_ADJUST.F +++ b/wrfv2_fire/dyn_nmm/module_IGWAVE_ADJUST.F @@ -870,7 +870,7 @@ SUBROUTINE PDTE( & ! #ifdef DM_PARALLEL ! IPS=ITS;IPE=ITE;JPS=JTS;JPE=JTE;KPS=KTS;KPE=KTE -# include +# include "HALO_NMM_E.inc" #endif !----------------------------------------------------------------------- ! diff --git a/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F b/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F index 017babae..ea455e3a 100644 --- a/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F +++ b/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F @@ -46,8 +46,8 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN & & ,CFRACL,CFRACM,CFRACH,SIGT4 & & ,ACFRST,NCFRST,ACFRCV,NCFRCV & & ,CUPPT,VEGFRC,SNOW,HTOP,HBOT & - & ,Z,SICE,NUM_AEROSOLC,NUM_OZMIXM & - & ,GRID,CONFIG_FLAGS & + & ,Z,SICE,NUM_AEROSOLC,NUM_OZMIXM,OZMIXM,PIN & + & ,LEVSIZ,GRID,CONFIG_FLAGS & & ,RTHRATEN & & ,re_cloud,re_ice,re_snow & ! G. Thompson & ,has_reqc,has_reqi,has_reqs & ! G. Thompson @@ -101,7 +101,8 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN & & ,ITS,ITE,JTS,JTE,KTS,KTE & & ,IHRST,JULDAY,JULYR & & ,N_MOIST,NPHS,NRADL,NRADS,NTSD & - & ,NUM_AEROSOLC,NUM_OZMIXM + & ,NUM_AEROSOLC,NUM_OZMIXM,LEVSIZ + REAL, INTENT(IN) :: OZMIXM(ims:ime,LEVSIZ,jms:jme,num_ozmixm), PIN(LEVSIZ) ! INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: NCFRCV,NCFRST ! @@ -213,6 +214,8 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN & LOGICAL :: WARM_RAIN LOGICAL :: IS_CAMMGMP_USED=.FALSE. + REAL :: DXKM, DYKM + ! !----------------------------------------------------------------------- !*********************************************************************** @@ -233,6 +236,9 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN & !----------------------------------------------------------------------- ! CAPA=R_D/CP + + DXKM=grid%dlmd*0.01745329*6371200. ! numbers from module_initialize_real.F + DYKM=grid%dy_nmm ! !----------------------------------------------------------------------- ! @@ -243,8 +249,6 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN & ! PDSL(I,J)=PD(I,J)*RES(I,J) P8W(I,KTE+1,J)=PT - XLAT(I,J)=GLAT(I,J)/DEGRAD - XLON(I,J)=GLON(I,J)/DEGRAD XLAND(I,J)=SM(I,J)+1. PSFC=PD(I,J)+PDTOP+PT REXNSFC(I,J)=(PSFC*1.E-5)**CAPA @@ -374,6 +378,8 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN & & ,ITIMESTEP=NTSD,DT=DT & & ,ICLOUD_CU=config_flags%ICLOUD_CU & & ,QC_CU=GRID%QC_CU,QI_CU=GRID%QI_CU & + & ,DX=DXKM,DY=DYKM & + & ,DXKM=dxkm & ! WRF-Solar variables ,swint_opt=config_flags%swint_opt & & ,SWDDIR=grid%swddir,SWDDNI=grid%swddni,SWDDIF=grid%swddif & ! jararias @@ -392,7 +398,7 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN & & ,RTHRATEN=RTHRATEN & & ,CEN_LAT=grid%cen_lat & & ,GLW=TOTLWDN,GSW=SWNETDN,SWDOWN=TOTSWDN & - & ,XLAT=XLAT,XLONG=XLON,ALBEDO=ALBEDO,EMISS=EPSR & + & ,XLAT=grid%HLAT,XLONG=grid%HLON,ALBEDO=ALBEDO,EMISS=EPSR & & ,XICE=SICE,XLAND=XLAND,Z=Z,TSK=TSFC & & ,N_AEROSOLC=NUM_AEROSOLC,PAERLEV=GRID%PAERLEV & & ,ID=grid%id & @@ -400,7 +406,8 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN & & ,CAM_ABS_DIM2=GRID%CAM_ABS_DIM2 & & ,CAM_ABS_FREQ_S=GRID%CAM_ABS_FREQ_S & & ,ALEVSIZ=grid%alevsiz,no_src_types=grid%no_src_types & - & ,LEVSIZ=GRID%LEVSIZ,N_OZMIXM=NUM_OZMIXM & + & ,LEVSIZ=LEVSIZ,N_OZMIXM=NUM_OZMIXM & + & ,OZMIXM=OZMIXM,PIN=PIN & & ,HTOP=HTOP,HBOT=HBOT,CUPPT=CUPPTR & & ,HTOPR=HTOPR,HBOTR=HBOTR & & ,VEGFRA=VEGFRC,SNOW=SNOW & @@ -462,7 +469,7 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN & & ,ACFRCV=ACFRCV,NCFRCV=NCFRCV & & ,F_ICE_PHY=F_ICE,F_RAIN_PHY=F_RAIN & & ,LWCF=LWCF,SWCF=SWCF & - & ,O3INPUT=config_flags%O3INPUT,AER_OPT=config_flags%AER_OPT & + & ,O3INPUT=config_flags%O3INPUT,AER_OPT=config_flags%AER_OPT,O3RAD=grid%o3rad & & ,SF_SURFACE_PHYSICS=CONFIG_FLAGS%SF_SURFACE_PHYSICS & & ,QV=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV & & ,QC=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC & @@ -471,7 +478,9 @@ SUBROUTINE RADIATION(NTSD,DT,JULDAY,JULYR,XTIME,JULIAN & & ,QS=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS & & ,QG=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG & & ,IS_CAMMGMP_USED=IS_CAMMGMP_USED & - & ,EXPLICIT_CONVECTION=config_flags%cu_physics==0) + & ,EXPLICIT_CONVECTION=config_flags%cu_physics==0 & + & ,CU_PHYSICS=config_flags%cu_physics & + & ,MP_PHYSICS=CONFIG_FLAGS%MP_PHYSICS) ! @@ -747,6 +756,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & & ,DISHEAT,DKU3D,DKT3D & & ,HPBL2D, EVAP2D, HEAT2D,RC2D & !Kwon S&P & ,SFCHEADRT,INFXSRT,SOLDRAIN & !Hydrology, no-op right now + & ,cd_out,ch_out & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,IPS,IPE,JPS,JPE,KPS,KPE & @@ -882,6 +892,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & ,SOILTB,TWBS ! + REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: cd_out,ch_out REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: taux, tauy REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(IN) :: PINT ! @@ -932,6 +943,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & !----------------------------------------------------------------------- INTEGER :: I,I_M,IDUMMY,IEND,ISFFLX,ISTAT,ISTR,J,K,KOUNT_ALL & & ,LENGTH_ROW,LLIJ,LLYR,N,SST_UPDATE,SF_URBAN_PHYSICS,NUM_URBAN_LAYERS + INTEGER :: FASDAS ! INTEGER,DIMENSION(IMS:IME,JMS:JME) :: KPBL,LOWLYR ! @@ -1010,6 +1022,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & ALLOCATE(MOIST_TRANS(IMS:IME,KMS:KME,JMS:JME,N_MOIST),STAT=ISTAT) ! SF_URBAN_PHYSICS=CONFIG_FLAGS%SF_URBAN_PHYSICS + FASDAS=0 if ( config_flags%bl_pbl_physics == BOULACSCHEME ) then call wrf_error_fatal("Cannot use BOULAC PBL with NMM") @@ -1366,7 +1379,16 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & & ,NUM_SOIL_LAYERS=NSOIL,P8W=P8W & & ,PBLH=PBLH,PI_PHY=PI_PHY,PSHLTR=PSHLTR,PSIH=PSIH & & ,PSIM=PSIM,P_PHY=P_PHY,Q10=Q10,Q2=Q2X,QFX=QWBS,TAUX=TAUX,TAUY=TAUY,QSFC=QS & - & ,QSHLTR=QSHLTR,QZ0=QZ0,RAINCV=RAIN & + & ,QSHLTR=QSHLTR,QZ0=QZ0 & + & ,ICOEF_SF=CONFIG_FLAGS%ICOEF_SF & + & ,LCURR_SF=CONFIG_FLAGS%LCURR_SF &!for gfdl-sf drag +#if (HWRF==1) + & ,pert_Cd=config_flags%pert_Cd & + & ,ens_random_seed=config_flags%ens_random_seed & + & ,ens_Cdamp=config_flags%ens_Cdamp & +#endif + & ,cd_out=grid%cd_out,ch_out=grid%ch_out & + & ,RAINCV=RAIN & & ,RHO=RR,SFCEVP=SFCEVPX,SFCEXC=SFCEXC,SFCRUNOFF=SSROFF & & ,SMOIS=SMC,SMSTAV=SMSTAV,SMSTOT=SMSTOT,SNOALB=MXSNAL & & ,SNOW=SNOW,SNOWC=SNOWC,SNOWH=SNOWH,STEPBL=NPHS & @@ -1382,7 +1404,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & & ,ALBSI=albsi,ICEDEPTH=icedepth,SNOWSI=snowsi & & ,ISICE=GRID%LANDUSE_ISICE,ISWATER=GRID%ISWATER & & ,XLAND=XLAND,Z=Z,ZNT=Z0 & -#ifdef HWRF +#if ( HWRF == 1 ) & ,MZNT=MZ0 & #endif & ,ZS=SLDPTH,CT=CT,TKE_PBL=TKE,SFENTH=SFENTH & !KWON @@ -1438,6 +1460,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & & ,RDLAI2D=config_flags%rdlai2d & & ,usemonalb=config_flags%usemonalb & & ,NOAHRES=grid%noahres & + & ,opt_thcnd=config_flags%opt_thcnd & ! for Noah UA changes & ,ua_phys=config_flags%ua_phys,flx4=grid%flx4,fvb=grid%fvb & & ,fbur=grid%fbur,fgsn=grid%fgsn & @@ -1451,6 +1474,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & & ,iopt_inf=config_flags%opt_inf, iopt_rad=config_flags%opt_rad & & ,iopt_alb=config_flags%opt_alb, iopt_snf=config_flags%opt_snf & & ,iopt_tbot=config_flags%opt_tbot, iopt_stc=config_flags%opt_stc & + & ,iopt_gla=config_flags%opt_gla, iopt_rsf=config_flags%opt_rsf & & , isnowxy=grid%isnowxy , tvxy=grid%tvxy , tgxy=grid%tgxy & & ,canicexy=grid%canicexy ,canliqxy=grid%canliqxy, eahxy=grid%eahxy & & , tahxy=grid%tahxy , cmxy=grid%cmxy , chxy=grid%chxy & @@ -1460,6 +1484,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & & , zsnsoxy=grid%zsnsoxy , snicexy=grid%snicexy , snliqxy=grid%snliqxy & & ,lfmassxy=grid%lfmassxy ,rtmassxy=grid%rtmassxy,stmassxy=grid%stmassxy & & , woodxy=grid%woodxy ,stblcpxy=grid%stblcpxy,fastcpxy=grid%fastcpxy & + & , grainxy=grid%grainxy , gddxy=grid%gddxy & & , xsaixy=grid%xsaixy , taussxy=grid%taussxy & & , t2mvxy=grid%t2mvxy , t2mbxy=grid%t2mbxy & & , q2mvxy=grid%q2mvxy , q2mbxy=grid%q2mbxy & @@ -1479,7 +1504,8 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & & , chv2xy=grid%chv2xy , chb2xy=grid%chb2xy , chstarxy=grid%chstarxy & & , smoiseq=grid%smoiseq, smcwtdxy=grid%smcwtdxy, rechxy=grid%rechxy & & , deeprechxy=grid%deeprechxy & - & ,coszen=grid%czen,xlat_urb2d=grid%xlat & + & ,coszen=grid%czen,xlat_urb2d=grid%hlat & + ! mosaic tiling for Noah & ,sf_surface_mosaic=config_flags%sf_surface_mosaic, mosaic_cat=config_flags%mosaic_cat & ! lake module @@ -1491,7 +1517,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & & ,tkdry3d=grid%tkdry3d,tksatu3d=grid%tksatu3d, LakeModel=grid%sf_lake_physics, lake_min_elev=grid%lake_min_elev & ! end lake module & ,maxpatch=1,inest=1,history_interval=config_flags%history_interval & !clm - + & ,fasdas=fasdas & ) ! !----------------------------------------------------------------------- @@ -1530,7 +1556,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & ! ETAMP_Regional=.FALSE. IF (CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW .OR. & - & CONFIG_FLAGS%MP_PHYSICS==ETAMP_HR) ETAMP_Regional=.TRUE. + & CONFIG_FLAGS%MP_PHYSICS==FER_MP_HIRES) ETAMP_Regional=.TRUE. ! IF(ETAMP_Regional) THEN !-- Logical FQ_I and index PQ_I are set to values associated with snow @@ -1557,7 +1583,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & !BSF & ,RQRBLTEN=RQRBLTEN,RQSBLTEN=RQSBLTEN & !BSF !BSF & ,RQGBLTEN=RQGBLTEN & !BSF & ,TSK=TSFC,XLAND=XLAND,ZNT=Z0 & -#ifdef HWRF +#if ( HWRF == 1 ) & ,MZNT=MZ0 & #endif & ,HT=SFCZ & !KWON @@ -1605,6 +1631,9 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & & ,DKU3D=DKU3D,DKT3D=DKT3D #if HWRF==1 & ,coef_ric_l=coef_ric_l,coef_ric_s=coef_ric_s & !Kwon for Ric + & ,pert_pbl=config_flags%pert_pbl & + & ,ens_random_seed=config_flags%ens_random_seed & + & ,ens_pblamp=config_flags%ens_pblamp & #endif & ,QV_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QV),F_QV=F_QV & & ,QC_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QC),F_QC=F_QC & @@ -1615,6 +1644,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & & ,HOL=HOL,sf_sfclay_physics=CONFIG_FLAGS%SF_SFCLAY_PHYSICS & & ,IS_CAMMGMP_USED=IS_CAMMGMP_USED & & ,wstar=wstar_ysu,delta=delta_ysu & + & ,fasdas=fasdas & & ,sf_urban_physics=CONFIG_FLAGS%SF_URBAN_PHYSICS) ! !*** NOTE THAT THE EXCHANGE COEFFICIENTS FOR HEAT EXCH_H COMING OUT OF @@ -1679,7 +1709,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & ENDDO ENDIF ! -#ifdef HWRF +#if ( HWRF == 1 ) if(size(grid%windsq_swath)>1) then do j=max(jts,jds),min(jte,jde-1) do i=max(its,ids),min(ite,ide-1) @@ -1799,7 +1829,7 @@ SUBROUTINE TURBL(NTSD,DT,NPHS,RESTRT & !125 FORMAT(1X,'grid%id module_PHYSICS.F : gwd_opt ',I2,2X,I2) -#ifdef HWRF +#if ( HWRF == 1 ) IF (grid%gwd_opt .eq. 2 .AND. grid%id.eq.1) THEN !Kwon's doing for parent only now #else IF (grid%gwd_opt .eq. 2) THEN @@ -2213,7 +2243,9 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: LPBL ! REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: HPBL2D,EVAP2D,HEAT2D !Kwon S&P -!` + + REAL,DIMENSION(IMS:IME,JMS:JME) :: SHALL +! REAL,INTENT(IN) :: DT,GPS,PDTOP,PT ! REAL,INTENT(INOUT) :: ACUTIM,AVCNVC @@ -2648,6 +2680,11 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & & ,DZ8W=DZ,P8W=P8W,FORCET=TTEN,FORCEQ=QTEN & & ,CLDEFI=CLDEFI,LOWLYR=LOWLYR,XLAND=XLAND & & ,CU_ACT_FLAG=CU_ACT_FLAG,WARM_RAIN=WARM_RAIN & +! kf_edrates + & ,UDR_KF=grid%udr_kf,DDR_KF=grid%ddr_kf & + & ,UER_KF=grid%uer_kf,DER_KF=grid%der_kf & + & ,TIMEC_KF=grid%timec_kf & + & ,KF_EDRATES=config_flags%kf_edrates & !Biswas & ,HFX=HFX,QFX=QFX,PBLH=PBLH & & ,ZNU=ZNU & @@ -2671,7 +2708,13 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & #if (NMM_CORE==1) & ,RUCUTEN=DUCUDT, RVCUTEN=DVCUDT, MOMMIX=MOMMIX & ,store_rand=store_rand & +#if (HWRF==1) + & ,pert_sas=config_flags%pert_sas & + & ,ens_random_seed=config_flags%ens_random_seed & + & ,ens_sasamp=config_flags%ens_sasamp & +#endif #endif + & ,SHALL=grid%shall & & ,HPBL2D=HPBL2D,EVAP2D=EVAP2D,HEAT2D=HEAT2D & !Kwon S&P & ,pgcon=config_flags%sas_pgcon & & ,sas_mass_flux=config_flags%sas_mass_flux & @@ -2706,7 +2749,7 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & endif N_TIMSTPS_OUTPUT=NINT(60.*CF_HI/DT) - MNTO=MOD(NTSD,N_TIMSTPS_OUTPUT) + MNTO=MOD(NTSD,max(1,N_TIMSTPS_OUTPUT)) ! IF(MNTO>0.AND.MNTO<=NCNVC)THEN DO J=MYJS2,MYJE2 @@ -2729,7 +2772,7 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & have_tg_tp = .false. have_swath = .false. have_tg_tp = (size(grid%tg_total_precip)>1) -#ifdef HWRF +#if ( HWRF == 1 ) have_swath = ( size(grid%precip_swath)>1 ) #endif !$omp parallel do & @@ -2750,7 +2793,7 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & if(have_tg_tp) then grid%tg_total_precip(i,j) = grid%tg_total_precip(i,j) + PCPCOL endif -#ifdef HWRF +#if ( HWRF == 1 ) if(have_swath) then if(grid%interesting(i,j)/=0) & grid%precip_swath(i,j) = grid%precip_swath(i,j) + PCPCOL @@ -2800,7 +2843,7 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL & ! ETAMP_Regional=.FALSE. IF (CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW .OR. & - & CONFIG_FLAGS%MP_PHYSICS==ETAMP_HR) ETAMP_Regional=.TRUE. + & CONFIG_FLAGS%MP_PHYSICS==FER_MP_HIRES) ETAMP_Regional=.TRUE. ! !$omp parallel do & !$omp& private(dqdt,dtdt,i,iendx,j,k,tchange) @@ -2998,7 +3041,7 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & !*** TRANSPOSE THE MOIST ARRAY (IJK) FOR THE PHYSICS (IKJ). !----------------------------------------------------------------------- ! - DO N=1,N_MOIST + DO N=2,N_MOIST !$omp parallel do & !$omp& private(i,j,k) DO K=KMS,KME @@ -3024,11 +3067,11 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & ! QT_PRESENT=.FALSE. IF (CONFIG_FLAGS%MP_PHYSICS==ETAMPNEW .OR. & - & CONFIG_FLAGS%MP_PHYSICS==ETAMP_HR .OR. & + & CONFIG_FLAGS%MP_PHYSICS==FER_MP_HIRES .OR. & & CONFIG_FLAGS%MP_PHYSICS==ETAMP_HWRF) QT_PRESENT=.TRUE. ! micro_check1: IF(.NOT.QT_PRESENT) THEN - DO N=1,N_SCALAR + DO N=2,N_SCALAR !$omp parallel do & !$omp& private(i,j,k) DO K=KMS,KME @@ -3128,8 +3171,18 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & & ,QI_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QI),F_QI=F_QI & & ,QS_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QS),F_QS=F_QS & & ,QG_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QG),F_QG=F_QG & - & ,QNI_CURR=SCALAR_TRANS(IMS,KMS,JMS,P_QNI),F_QNI=F_QNI & - & ,QNR_CURR=SCALAR_TRANS(IMS,KMS,JMS,P_QNR),F_QNR=F_QNR & + & ,QH_CURR=MOIST_TRANS(IMS,KMS,JMS,P_QH),F_QH=F_QH & + & , QNN_CURR=SCALAR_TRANS(ims,kms,jms,P_QNN), F_QNN=F_QNN & + & , QNDROP_CURR=SCALAR_TRANS(ims,kms,jms,P_QNDROP), F_QNDROP=F_QNDROP & + & , QNI_CURR=SCALAR_TRANS(ims,kms,jms,P_QNI), F_QNI=F_QNI & + & , QNC_CURR=SCALAR_TRANS(ims,kms,jms,P_QNC), F_QNC=F_QNC & + & , QNR_CURR=SCALAR_TRANS(ims,kms,jms,P_QNR), F_QNR=F_QNR & + & , QNS_CURR=SCALAR_TRANS(ims,kms,jms,P_QNS), F_QNS=F_QNS & + & , QNG_CURR=SCALAR_TRANS(ims,kms,jms,P_QNG), F_QNG=F_QNG & + & , QNH_CURR=SCALAR_TRANS(ims,kms,jms,P_QNH), F_QNH=F_QNH & ! for milbrandt2mom and nssl_2mom + & , QVOLG_CURR=SCALAR_TRANS(ims,kms,jms,P_QVOLG), F_QVOLG=F_QVOLG & ! for nssl_2mom + & , QVOLH_CURR=SCALAR_TRANS(ims,kms,jms,P_QVOLH), F_QVOLH=F_QVOLH & ! for nssl_2mom + & ,QRIMEF_CURR=SCALAR_TRANS(IMS,KMS,JMS,P_QRIMEF),F_QRIMEF=F_QRIMEF & & ,QT_CURR=CWM_PHY,F_QT=QT_PRESENT & & ,MP_RESTART_STATE=MP_RESTART_STATE & & ,TBPVS_STATE=TBPVS_STATE & @@ -3197,7 +3250,7 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & !*** OUT ABOVE SINCE IT IS ONLY A LOCAL ARRAY FOR NOW. !----------------------------------------------------------------------- ! -#ifdef HWRF +#if ( HWRF == 1 ) have_swath = ( size(grid%precip_swath)>1 ) #endif have_tg_tp = (size(grid%tg_total_precip)>1) @@ -3213,7 +3266,7 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & if(have_tg_tp) then grid%tg_total_precip(i,j) = grid%tg_total_precip(i,j) + PCPCOL endif -#ifdef HWRF +#if ( HWRF == 1 ) if(have_swath) then if(grid%interesting(i,j)/=0) & grid%precip_swath(i,j) = grid%precip_swath(i,j) + PCPCOL @@ -3226,7 +3279,7 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & !*** REFILL THE MOIST ARRAY. !----------------------------------------------------------------------- ! - DO N=1,N_MOIST + DO N=2,N_MOIST !$omp parallel do & !$omp& private(i,j,k) DO J=JMS,JME @@ -3241,7 +3294,7 @@ SUBROUTINE GSMDRIVE(NTSD,DT,NPHS,N_MOIST & !----------------------------------------------------------------------- ! micro_check2: IF (.NOT.QT_PRESENT) THEN - DO N=1,N_SCALAR + DO N=2,N_SCALAR !$omp parallel do & !$omp& private(i,j,k) DO J=JMS,JME diff --git a/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F b/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F index f9ac2c1a..a4c098dd 100644 --- a/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F +++ b/wrfv2_fire/dyn_nmm/module_STATS_FOR_MOVE.F @@ -24,7 +24,7 @@ SUBROUTINE VORTTRAK_INIT(grid,config_flags,init, & ITS,ITE,JTS,JTE,KTS,KTE) USE MODULE_CONFIGURE, ONLY : grid_config_rec_type USE MODULE_DOMAIN, ONLY : domain -#ifdef HWRF +#if ( HWRF == 1 ) USE module_tracker, only: ncep_tracker_init #endif IMPLICIT NONE @@ -43,7 +43,7 @@ SUBROUTINE VORTTRAK_INIT(grid,config_flags,init, & integer :: xshift ! for handling grid staggering integer :: i,j -#ifdef HWRF +#if ( HWRF == 1 ) vortex_tracker=grid%vortex_tracker if(vortex_tracker<1 .or. vortex_tracker>7) then 31 format('Domain ',I0,' has invalid value ',I0,' for vortex_tracker: it must be an integer from 1-7') @@ -154,7 +154,7 @@ SUBROUTINE VORTTRAK_INIT(grid,config_flags,init, & endif distsq #endif -#ifdef HWRF +#if ( HWRF == 1 ) if(init .and. (vortex_tracker==6 .or. vortex_tracker==7) ) then call ncep_tracker_init(grid) endif @@ -162,7 +162,7 @@ SUBROUTINE VORTTRAK_INIT(grid,config_flags,init, & END SUBROUTINE VORTTRAK_INIT -#ifdef HWRF +#if ( HWRF == 1 ) !---------------------------------------------------------------------- ! SUBROUTINE UPDATE_PDYN_MSLP(grid,config_flags, & @@ -278,14 +278,14 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, & ! Mar 2013 - sam added options 5 & 6 ! Sep 2013 - sam added option 7 ! Feb 2014 - sam added hooks for area of interest -#ifdef HWRF +#if ( HWRF == 1 ) USE module_tracker, only: ncep_tracker_center #endif USE MODULE_CONFIGURE, ONLY : grid_config_rec_type USE MODULE_DOMAIN, ONLY : domain,get_ijk_from_grid use module_membrane_mslp #ifdef DM_PARALLEL -# ifdef HWRF +# if ( HWRF == 1 ) USE MODULE_COMM_DM, ONLY : HALO_NMM_VT4_NOISE_sub, HALO_NMM_VT4_MSLP_sub USE MODULE_DM, ONLY: ntasks_x, ntasks_y, mytask, ntasks, local_communicator # endif @@ -305,8 +305,8 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, & ! KEEP NEST MOTION IN SINK WITH PHYSICS TIME STEPS #if ( NMM_NEST == 1 ) -#ifdef HWRF - MOVEFREQ=grid%movemin*grid%nphs +#if ( HWRF == 1 ) + MOVEFREQ=grid%ntrack*grid%nphs vortex_tracker=grid%vortex_tracker #else MOVEFREQ=grid%nphs @@ -314,7 +314,7 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, & #endif skip_nest_motion=.false. IF(MOD(grid%NTSD+1,MOVEFREQ)/=0 .or. grid%id==1)THEN -#ifdef HWRF +#if ( HWRF == 1 ) IF(grid%MOVED .and. grid%id/=1) then grid%NTIME0=grid%NTSD !FOR UPDATING NTIM0 ENDIF @@ -323,7 +323,7 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, & skip_nest_motion=.true. ENDIF -#ifdef HWRF +#if ( HWRF == 1 ) if(skip_nest_motion .and. ( grid%pdyn_smooth_age/=0 .or. size(grid%pdyn_smooth)<=1)) then ! Pdyn_smooth is up to date and it is not yet time to move the ! nest, so we can return now. @@ -357,15 +357,15 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, & ! PDYN causes noise in the presence of strong vorticity variations, ! so it is not used by HWRF for nest tracking. CALL STATS_FOR_MOVE_123 (grid%XLOC_2,grid%YLOC_2 & -#ifdef HWRF +#if ( HWRF == 1 ) ,grid%MSLP & #else ,grid%PDYN & #endif ,grid%sm & -#ifdef HWRF +#if ( HWRF == 1 ) ,GRID%RESTART,grid%NTIME0 & - ,GRID%MOVED,grid%MVNEST,grid%ntsd,GRID%NPHS,GRID%MOVEMIN & + ,GRID%MOVED,grid%MVNEST,grid%ntsd,GRID%NPHS,GRID%NTRACK & #else ,GRID%MOVED,grid%MVNEST,grid%ntsd,GRID%NPHS & #endif @@ -374,7 +374,7 @@ SUBROUTINE STATS_FOR_MOVE(grid,config_flags, & ,IMS,IME,JMS,JME,KMS,KME & ,ITS,ITE,JTS,JTE,KTS,KTE) RETURN -#ifdef HWRF +#if ( HWRF == 1 ) elseif(vortex_tracker==6 .or. vortex_tracker==7) then ! Tracker #6 and #7: do whatever the inline NCEP Tracker says call ncep_tracker_center(grid) @@ -485,7 +485,7 @@ SUBROUTINE vt4_noise_iter(NOISY, & ITS,ITE,JTS,JTE,KTS,KTE integer :: i,j,iadd -#ifdef HWRF +#if ( HWRF == 1 ) do j = max(jds+1,jts), min(jte,jde-2) iadd=mod(j,2)-1 do i = max(ids+1,its), min(ite,ide-2) @@ -535,7 +535,7 @@ SUBROUTINE vt4_noise_detect(MSLP,NOISY,PMAX,PMIN,DPDR, & nprint=10 #endif -#ifdef HWRF +#if ( HWRF == 1 ) dy2=dy_nmm*dy_nmm*4 dp2max=dpdr*dpdr @@ -609,7 +609,7 @@ SUBROUTINE vt4_noise_detect(MSLP,NOISY,PMAX,PMIN,DPDR, & #endif END SUBROUTINE vt4_noise_detect -#ifdef HWRF +#if ( HWRF == 1 ) SUBROUTINE vt5_move(PDYN,distsq,searchrad,xloc,yloc,gridid,cx,cy,mvnest, & IDS,IDE,JDS,JDE,KDS,KDE, & IMS,IME,JMS,JME,KMS,KME, & @@ -1129,7 +1129,7 @@ END SUBROUTINE STATS_MAKE_MSLP !---------------------------------------------------------------------- ! SUBROUTINE STATS_FOR_MOVE_123 (XLOC,YLOC,PRES,SM & -#ifdef HWRF +#if ( HWRF == 1 ) ,RESTART,NTIME0 & ! zhang's doing ,MOVED,MVNEST,NTSD,NPHS,CFREQ & ! CFREQ*DT*NPHS=540s #else @@ -1181,7 +1181,7 @@ SUBROUTINE STATS_FOR_MOVE_123 (XLOC,YLOC,PRES,SM & INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & ,IMS,IME,JMS,JME,KMS,KME & ,ITS,ITE,JTS,JTE,KTS,KTE & -#ifdef HWRF +#if ( HWRF == 1 ) ,NTSD,NPHS,CFREQ #else ,NTSD,NPHS @@ -1196,7 +1196,7 @@ SUBROUTINE STATS_FOR_MOVE_123 (XLOC,YLOC,PRES,SM & ! LOCAL character*256 :: message -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing INTEGER,INTENT(INOUT) :: NTIME0 LOGICAL,INTENT(IN) :: RESTART @@ -1341,7 +1341,7 @@ SUBROUTINE STATS_FOR_MOVE_123 (XLOC,YLOC,PRES,SM & XDIFF=ABS(XLOC - IDE/2) YDIFF=ABS(YLOC - JDE/2) -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing IF((.NOT.RESTART .AND. NTSD==0) .OR. MOVED)NTIME0=NTSD #else diff --git a/wrfv2_fire/dyn_nmm/module_TERRAIN.F b/wrfv2_fire/dyn_nmm/module_TERRAIN.F index afe61909..b92f306f 100644 --- a/wrfv2_fire/dyn_nmm/module_TERRAIN.F +++ b/wrfv2_fire/dyn_nmm/module_TERRAIN.F @@ -75,7 +75,7 @@ subroutine read_terrain(tr,input_type,io_form) type(nmm_terrain), pointer :: tr integer, intent(in) :: io_form, input_type - integer, parameter :: IO_BIN=1, IO_NET=2 + integer, parameter :: IO_BIN=1, IO_NET=2, IO_PNC=11 CHARACTER(LEN=6) :: nestpath character(len=128) :: input_fname integer :: comm_1,comm_2, handle,istatus @@ -141,7 +141,8 @@ subroutine read_terrain(tr,input_type,io_form) if (io_form == IO_BIN) write(input_fname,"(A,I2.2,A)") "geo_nmm_nest.l",level,".int" #endif #ifdef NETCDF - if (io_form == IO_NET) write(input_fname,"(A,I2.2,A)") "geo_nmm_nest.l",level,".nc" + if (io_form == IO_PNC) call wrf_message("WARNING: module_TERRAIN.F: pNetCDF specified, but using serial NetCDF to read geo_nmm_nest file") + if (io_form == IO_NET .OR. io_form == IO_PNC) write(input_fname,"(A,I2.2,A)") "geo_nmm_nest.l",level,".nc" #endif comm_1 = 1 @@ -152,10 +153,10 @@ subroutine read_terrain(tr,input_type,io_form) call ext_int_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus) #endif #ifdef NETCDF - if (io_form == IO_NET) & + if (io_form == IO_NET .OR. io_form == IO_PNC ) & call ext_ncd_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus) #endif - if (istatus /= 0) CALL wrf_error_fatal('NEST_TERRAIN error after ext_XXX_open_for_read '//trim(input_fname)) +!idealized KWON if (istatus /= 0) CALL wrf_error_fatal('NEST_TERRAIN error after ext_XXX_open_for_read '//trim(input_fname)) read_loop: do n=1,24 @@ -169,7 +170,7 @@ subroutine read_terrain(tr,input_type,io_form) call ext_int_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus) #endif #ifdef NETCDF - if (io_form == IO_NET) & + if (io_form == IO_NET .OR. io_form == IO_PNC ) & call ext_ncd_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus) #endif @@ -185,7 +186,7 @@ subroutine read_terrain(tr,input_type,io_form) end if #endif #ifdef NETCDF - if (io_form == IO_NET) then + if (io_form == IO_NET .OR. io_form == IO_PNC ) then call ext_ncd_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, wrftype, & 1, 1, 0, memorder, stagger, & dimnames, domain_start, domain_end, domain_start, domain_end, & @@ -249,7 +250,7 @@ subroutine read_terrain(tr,input_type,io_form) end if #endif #ifdef NETCDF - if (io_form == IO_NET) then + if (io_form == IO_NET .OR. io_form == IO_PNC ) then call ext_ncd_ioclose(handle, istatus) end if #endif diff --git a/wrfv2_fire/dyn_nmm/module_initialize_real.F b/wrfv2_fire/dyn_nmm/module_initialize_real.F index 8400876e..b7da97f3 100644 --- a/wrfv2_fire/dyn_nmm/module_initialize_real.F +++ b/wrfv2_fire/dyn_nmm/module_initialize_real.F @@ -49,7 +49,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_nmm (grid & ! -#include +#include "actual_new_args.inc" ! ) @@ -59,7 +59,7 @@ END SUBROUTINE init_domain !--------------------------------------------------------------------- SUBROUTINE init_domain_nmm ( grid & ! -# include +# include "dummy_new_args.inc" ! ) @@ -71,7 +71,7 @@ SUBROUTINE init_domain_nmm ( grid & ! TYPE (domain), POINTER :: grid TYPE (domain) :: grid -# include +# include "dummy_new_decl.inc" TYPE (grid_config_rec_type) :: config_flags @@ -167,7 +167,7 @@ SUBROUTINE init_domain_nmm ( grid & REAL, PARAMETER:: DTR=0.01745329 REAL, PARAMETER:: W_NMM=0.08 -#if defined(HWRF) +#if ( HWRF == 1 ) REAL, PARAMETER:: DDFC=1.0 #else REAL, PARAMETER:: DDFC=8.0 @@ -192,7 +192,7 @@ SUBROUTINE init_domain_nmm ( grid & REAL, PARAMETER:: TG0=258.16 REAL, PARAMETER:: TGA=30.0 integer :: numzero,numexamined -#ifdef HWRF +#if ( HWRF == 1 ) !============================================================================ ! gopal's doing for ocean coupling !============================================================================ @@ -210,9 +210,9 @@ SUBROUTINE init_domain_nmm ( grid & if (ALLOCATED(TG_ALT)) DEALLOCATE(TG_ALT) !#define COPY_IN -!#include +!#include "scalar_derefs.inc" #ifdef DM_PARALLEL -# include +# include "data_calls.inc" #endif SELECT CASE ( model_data_order ) @@ -416,7 +416,7 @@ SUBROUTINE init_domain_nmm ( grid & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) -#if defined(HWRF) +#if ( HWRF == 1 ) if(.not. grid%use_prep_hybrid) then #endif @@ -445,7 +445,7 @@ SUBROUTINE init_domain_nmm ( grid & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) -#if defined(HWRF) +#if ( HWRF == 1 ) endif #endif @@ -495,7 +495,7 @@ SUBROUTINE init_domain_nmm ( grid & if (grid%tsk_gc(I,J) .gt. 0.) then grid%nmm_tsk(I,J)=grid%tsk_gc(I,J) else -#if defined(HWRF) +#if ( HWRF == 1 ) if(grid%use_prep_hybrid) then if(grid%t(I,J,1)<100) then write(*,*) 'NO VALID SURFACE TEMPERATURE: I,J,TSK_GC(I,J),T(I,J,1) = ', & @@ -506,7 +506,7 @@ SUBROUTINE init_domain_nmm ( grid & else #endif grid%nmm_tsk(I,J)=grid%t_gc(I,J,1) ! stopgap measure -#if defined(HWRF) +#if ( HWRF == 1 ) endif #endif endif @@ -528,7 +528,7 @@ SUBROUTINE init_domain_nmm ( grid & if (internal_time_loop .eq. 1) then if (eta_levels(1) .ne. 1.0) then -#if defined(HWRF) +#if ( HWRF == 1 ) if(grid%use_prep_hybrid) then call wrf_error_fatal('PREP_HYBRID ERROR: eta_levels is not specified, but use_prep_hybrid=.true.') end if @@ -612,7 +612,7 @@ SUBROUTINE init_domain_nmm ( grid & enddo write(message,*) 'TOTAL NEAR-ZERO FIS POINTS: ',numzero,' OF ',numexamined call wrf_debug(10,message) -#if defined(HWRF) +#if ( HWRF == 1 ) interp_notph: if(.not. grid%use_prep_hybrid) then #endif if (.NOT. allocated(PDVP)) allocate(PDVP(IMS:IME,JMS:JME)) @@ -772,7 +772,7 @@ SUBROUTINE init_domain_nmm ( grid & IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP) IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP2) -#if defined(HWRF) +#if ( HWRF == 1 ) else ! we are using prep_hybrid ! Compute surface pressure: grid%psfc_out=grid%pdtop+grid%pd @@ -836,12 +836,12 @@ SUBROUTINE init_domain_nmm ( grid & endif -#if defined(HWRF) +#if ( HWRF == 1 ) if(.not.grid%use_prep_hybrid) then #endif ! new deallocs DEALLOCATE(p3d_out,p3dv_out,p3dv_in) -#if defined(HWRF) +#if ( HWRF == 1 ) end if #endif @@ -1036,7 +1036,7 @@ SUBROUTINE init_domain_nmm ( grid & &, ITS,ITE,JTS,JTE,1,1 ) IF (WRF_DM_ON_MONITOR()) THEN -#if defined(HWRF) +#if ( HWRF == 1 ) ! SM_G is still needed for the high-res grid #else DEALLOCATE(SM_G) @@ -2018,7 +2018,7 @@ SUBROUTINE init_domain_nmm ( grid & write(message,*)'STUFF MOVED TO REGISTRY:',grid%IDTAD, & & grid%NSOIL,grid%NRADL,grid%NRADS,grid%NPHS,grid%NCNVC,grid%sigma CALL wrf_message( TRIM(message) ) -#ifdef HWRF +#if ( HWRF == 1 ) !========================================================================================= ! gopal's doing for ocean coupling. Produce a high resolution grid for the entire domain !========================================================================================= @@ -2032,24 +2032,18 @@ SUBROUTINE init_domain_nmm ( grid & NWBD= WBD ! + (ILOC -1)*2.*grid%dlmd + MOD(JLOC+1,2)*grid%dlmd NSBD= SBD ! + (JLOC -1)*grid%dphd + grid%sbd0=sbd + grid%wbd0=wbd - - -#ifdef HWRF +#if ( HWRF == 1 ) CALL EARTH_LATLON ( grid%HLAT,grid%HLON,grid%VLAT,grid%VLON, & !output grid%DLMD,grid%DPHD,WBD,SBD, & !inputs tph0d,tlm0d, & IDS,IDE,JDS,JDE,KDS,KDE, & IMS,IME,JMS,JME,KMS,KME, & ITS,ITE,JTS,JTE,KTS,KTE ) -#if defined(DM_PARALLEL) - master65: if(wrf_dm_on_monitor()) then -#endif call make_coupler_fort65(grid,NDLMD,NDPHD,NWBD,NSBD,& NIDE,NJDE,IDE-1,JDE-1,tph0d,tlm0d) -#if defined(DM_PARALLEL) - endif master65 -#endif #endif endif !Kwon's doing @@ -2059,7 +2053,7 @@ SUBROUTINE init_domain_nmm ( grid & #endif !#define COPY_OUT -!#include +!#include "scalar_derefs.inc" RETURN END SUBROUTINE init_domain_nmm @@ -2094,20 +2088,62 @@ real function greatarc(lat1,lon1,lat2,lon2) cos(rlat1)*cos(rlat2)*sin((rlon1-rlon2)/2)**2))) end function greatarc +#if ( HWRF == 1 ) SUBROUTINE make_coupler_fort65(grid,& NDLMD,NDPHD,NWBD,NSBD,& - NIDE,NJDE,PIDE,PJDE,tph0d,tlm0d) + NIDE,NJDE,PIFE,PJFE,tph0d,tlm0d) + use mpi + use module_dm,only: local_communicator implicit none type(domain), intent(in) :: grid REAL, DIMENSION(:,:), ALLOCATABLE :: NHLAT,NHLON,NVLAT,NVLON,HRES_SM,& HBWGT1, HBWGT2, HBWGT3, HBWGT4 INTEGER, DIMENSION(:,:), ALLOCATABLE :: IIH, JJH, HNEAR_I,HNEAR_J,CENFLAG REAL, INTENT(IN) :: NDLMD,NDPHD,NWBD,NSBD,tph0d,tlm0d - INTEGER, INTENT(IN) :: NIDE,NJDE,PIDE,PJDE + INTEGER, INTENT(IN) :: NIDE,NJDE,PIFE,PJFE INTEGER :: ci,cj, ni,nj, bad character(len=255) :: message - INTEGER :: count, bigcount, noncount + INTEGER :: count, bigcount, noncount, ierr REAL :: dlon, mindist,maxdist,dist,maxweight + real, dimension(:,:,:), allocatable :: bigsm,bighlat,bighlon + integer :: & + pids, pide, pjds, pjde, pkds, pkde, & + pims, pime, pjms, pjme, pkms, pkme, & + pits, pite, pjts, pjte, pkts, pkte + logical, external :: wrf_dm_on_monitor + + CALL get_ijk_from_grid ( grid , & + pids, pide, pjds, pjde, pkds, pkde, & + pims, pime, pjms, pjme, pkms, pkme, & + pits, pite, pjts, pjte, pkts, pkte) + + if(pife/=pide-1 .or. pjfe/=pjde-1) then + 38 format('Caller sent wrong dimensions: ',I0,'x',I0, & + ' instead of ',I0,'x',I0) + write(message,38) pife,pjfe,pide-1,pjde-1 + call wrf_error_fatal(message) + endif + if(wrf_dm_on_monitor()) then + allocate(bigsm(pids:pide,pjds:pjde,1), & + bighlat(pids:pide,pjds:pjde,1), & + bighlon(pids:pide,pjds:pjde,1)) + else + allocate(bigsm(1,1,1),bighlat(1,1,1),bighlon(1,1,1)) + endif + + call wrf_patch_to_global_real(& + grid%sm,bigsm,grid%domdesc,'xy','xy',& + pids, pide, pjds, pjde, 1, 1, & + pims, pime, pjms, pjme, 1, 1, & + pits, pite, pjts, pjte, 1, 1) + + if(.not.wrf_dm_on_monitor()) then + call MPI_Barrier(local_communicator,ierr) + deallocate(bigsm,bighlat,bighlon) + return + else + call wrf_debug(100,'Working on fort.65 stuff.') + endif allocate(NHLAT(nide,njde),NHLON(nide,njde),NVLAT(nide,njde)) allocate(NVLON(nide,njde),HRES_SM(nide,njde)) @@ -2152,18 +2188,18 @@ SUBROUTINE make_coupler_fort65(grid,& do ni=1,nide ci=HNEAR_I(ni,nj) cj=HNEAR_J(ni,nj) - if(ci<1 .or. ci>pide .or. cj<1 .or. cj>pjde) then + if(ci<1 .or. ci>pife .or. cj<1 .or. cj>pjfe) then 33 format('ERROR: Invalid HNEAR nest ',I0,',',I0,' parent ',& I0,',',I0,' outside parent bounds ',I0,',',I0) - write(message,33) ni,nj,ci,cj,pide,pjde + write(message,33) ni,nj,ci,cj,pife,pjfe call wrf_message(trim(message)) bad=bad+1 endif - HRES_SM(ni,nj)=grid%SM(ci,cj) + HRES_SM(ni,nj)=bigSM(ci,cj,1) maxweight=max(HBWGT1(ni,nj),HBWGT2(ni,nj),HBWGT3(ni,nj),HBWGT4(ni,nj)) if(maxweight>0.9999 .and. maxweight<1.03) then cenflag(ni,nj)=1 - dist=greatarc(grid%HLAT(ci,cj),grid%HLON(ci,cj),& + dist=greatarc(bigHLAT(ci,cj,1),bigHLON(ci,cj,1),& NHLAT(ni,nj),NHLON(ni,nj)) if(dist>100) then bigcount=bigcount+1 @@ -2200,19 +2236,24 @@ SUBROUTINE make_coupler_fort65(grid,& call wrf_error_fatal(message) endif + open(file='fort.65',unit=65,form='UNFORMATTED') WRITE(65)NHLAT(1:NIDE,1:NJDE) WRITE(65)NHLON(1:NIDE,1:NJDE) WRITE(65)NVLAT(1:NIDE,1:NJDE) WRITE(65)NVLON(1:NIDE,1:NJDE) WRITE(65)HRES_SM(1:NIDE,1:NJDE) + close(65) !WRITE(65)HNEAR_I(1:NIDE,1:NJDE) !WRITE(65)HNEAR_J(1:NIDE,1:NJDE) !WRITE(65)CENFLAG(1:NIDE,1:NJDE) deallocate(NHLAT,NHLON,NVLAT,NVLON,HRES_SM,IIH,JJH) deallocate(HBWGT1,HBWGT2,HBWGT3,HBWGT4,HNEAR_I,HNEAR_J) + deallocate(bigsm,bighlat,bighlon) + call MPI_Barrier(local_communicator,ierr) END SUBROUTINE make_coupler_fort65 +#endif !------------------------------------------------------ diff --git a/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F b/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F index 1ad665b0..8097cb3b 100644 --- a/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F +++ b/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F @@ -49,7 +49,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_nmm (grid & ! -#include +#include "actual_new_args.inc" ! ) @@ -59,7 +59,7 @@ END SUBROUTINE init_domain !--------------------------------------------------------------------- SUBROUTINE init_domain_nmm ( grid & ! -# include +# include "dummy_new_args.inc" ! ) @@ -71,7 +71,7 @@ SUBROUTINE init_domain_nmm ( grid & ! TYPE (domain), POINTER :: grid TYPE (domain) :: grid -# include +# include "dummy_new_decl.inc" real ,DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,1:grid%num_metgrid_levels) :: ght_out @@ -176,7 +176,7 @@ SUBROUTINE init_domain_nmm ( grid & REAL, PARAMETER:: DTR=0.01745329 REAL, PARAMETER:: W_NMM=0.08 -#if defined(HWRF) +#if ( HWRF == 1 ) REAL, PARAMETER:: DDFC=1.0 #else REAL, PARAMETER:: DDFC=8.0 @@ -201,7 +201,7 @@ SUBROUTINE init_domain_nmm ( grid & REAL, PARAMETER:: TG0=258.16 REAL, PARAMETER:: TGA=30.0 integer :: numzero,numexamined -#ifdef HWRF +#if ( HWRF == 1 ) !============================================================================ ! gopal's doing for ocean coupling !============================================================================ @@ -222,9 +222,9 @@ SUBROUTINE init_domain_nmm ( grid & if (ALLOCATED(TG_ALT)) DEALLOCATE(TG_ALT) !#define COPY_IN -!#include +!#include "scalar_derefs.inc" #ifdef DM_PARALLEL -# include +# include "data_calls.inc" #endif SELECT CASE ( model_data_order ) @@ -463,7 +463,7 @@ SUBROUTINE init_domain_nmm ( grid & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) -#if defined(HWRF) +#if ( HWRF == 1 ) if(.not. grid%use_prep_hybrid) then #endif @@ -492,7 +492,7 @@ SUBROUTINE init_domain_nmm ( grid & &, IMS,IME,JMS,JME,KMS,KME & &, ITS,ITE,JTS,JTE,KTS,KTE ) -#if defined(HWRF) +#if ( HWRF == 1 ) endif #endif @@ -542,7 +542,7 @@ SUBROUTINE init_domain_nmm ( grid & if (grid%tsk_gc(I,J) .gt. 0.) then grid%nmm_tsk(I,J)=grid%tsk_gc(I,J) else -#if defined(HWRF) +#if ( HWRF == 1 ) if(grid%use_prep_hybrid) then if(grid%t(I,J,1)<100) then write(message,*) 'NO VALID SURFACE TEMPERATURE: I,J,TSK_GC(I,J),T(I,J,1) = ', & @@ -554,7 +554,7 @@ SUBROUTINE init_domain_nmm ( grid & else #endif grid%nmm_tsk(I,J)=grid%t_gc(I,J,1) ! stopgap measure -#if defined(HWRF) +#if ( HWRF == 1 ) endif #endif endif @@ -576,7 +576,7 @@ SUBROUTINE init_domain_nmm ( grid & if (internal_time_loop .eq. 1) then if (eta_levels(1) .ne. 1.0) then -#if defined(HWRF) +#if ( HWRF == 1 ) if(grid%use_prep_hybrid) then call wrf_error_fatal('PREP_HYBRID ERROR: eta_levels is not specified, but use_prep_hybrid=.true.') end if @@ -660,7 +660,7 @@ SUBROUTINE init_domain_nmm ( grid & enddo write(message,*) 'TOTAL NEAR-ZERO FIS POINTS: ',numzero,' OF ',numexamined call wrf_debug(10,message) -#if defined(HWRF) +#if ( HWRF == 1 ) interp_notph: if(.not. grid%use_prep_hybrid) then #endif if (.NOT. allocated(PDVP)) allocate(PDVP(IMS:IME,JMS:JME)) @@ -820,7 +820,7 @@ SUBROUTINE init_domain_nmm ( grid & IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP) IF (ALLOCATED(QTMP)) DEALLOCATE(QTMP2) -#if defined(HWRF) +#if ( HWRF == 1 ) else ! we are using prep_hybrid ! Compute surface pressure: grid%psfc_out=grid%pdtop+grid%pd @@ -884,12 +884,12 @@ SUBROUTINE init_domain_nmm ( grid & endif -#if defined(HWRF) +#if ( HWRF == 1 ) if(.not.grid%use_prep_hybrid) then #endif ! new deallocs DEALLOCATE(p3d_out,p3dv_out,p3dv_in) -#if defined(HWRF) +#if ( HWRF == 1 ) end if #endif @@ -1084,7 +1084,7 @@ SUBROUTINE init_domain_nmm ( grid & &, ITS,ITE,JTS,JTE,1,1 ) IF (WRF_DM_ON_MONITOR()) THEN -#if defined(HWRF) +#if ( HWRF == 1 ) ! SM_G is still needed for the high-res grid #else DEALLOCATE(SM_G) @@ -2075,7 +2075,7 @@ SUBROUTINE init_domain_nmm ( grid & write(message,*)'STUFF MOVED TO REGISTRY:',grid%IDTAD, & & grid%NSOIL,grid%NRADL,grid%NRADS,grid%NPHS,grid%NCNVC,grid%sigma CALL wrf_message( TRIM(message) ) -#ifdef HWRF +#if ( HWRF == 1 ) !========================================================================================= ! gopal's doing for ocean coupling. Produce a high resolution grid for the entire domain !========================================================================================= @@ -2169,7 +2169,7 @@ SUBROUTINE init_domain_nmm ( grid & #endif !#define COPY_OUT -!#include +!#include "scalar_derefs.inc" RETURN END SUBROUTINE init_domain_nmm @@ -5706,6 +5706,10 @@ subroutine posn(xx,forc,err,nnt,lq,lp) do 20 i=2,lp-1 do 20 j=2,lq-1 20 tem(j,i)=wk(j,i) +! + !Gopal's doing on June 17th, 2015. The line below was erroneously removed from the code. + if(anorm.gt.err) goto 2 + write(6,*) nt,anorm,err ! do i=1,lp do j=1,lq @@ -6045,7 +6049,7 @@ end subroutine interps -#ifdef HWRF +#if ( HWRF == 1 ) ! compute earth lat-lons for before interpolations. This is gopal's doing for ocean coupling !============================================================================================ diff --git a/wrfv2_fire/dyn_nmm/module_membrane_mslp.F b/wrfv2_fire/dyn_nmm/module_membrane_mslp.F index 0d627295..a04e175e 100644 --- a/wrfv2_fire/dyn_nmm/module_membrane_mslp.F +++ b/wrfv2_fire/dyn_nmm/module_membrane_mslp.F @@ -2,7 +2,7 @@ module module_membrane_mslp implicit none private -#ifdef HWRF +#if ( HWRF == 1 ) public :: make_membrane_mslp @@ -104,7 +104,7 @@ subroutine membrane_mslp_impl(grid, & #ifdef DM_PARALLEL USE MODULE_COMM_DM, ONLY : HALO_NMM_MEMBRANE_INTERP_sub USE MODULE_DM, ONLY: ntasks_x, ntasks_y, mytask, ntasks, local_communicator - use module_dm, only: wrf_dm_minval_real + use module_dm, only: wrf_dm_minval_real, wrf_dm_maxval_integer #endif implicit none @@ -122,7 +122,7 @@ subroutine membrane_mslp_impl(grid, & logical :: ground_mask(ips:ipe,jps:jpe,npres) integer :: ground_level(ips:ipe,jps:jpe) - integer :: ipres,i,j,mpres,imin,jmin,k + integer :: ipres,i,j,mpres,imin,jmin,k,need_to_relax,imax,jmax real :: pmin character*255 :: message @@ -188,19 +188,32 @@ subroutine membrane_mslp_impl(grid, & grid%relaxmask=.true. ! Now loop over all vertical levels and relax them: - do ipres=1,npres - ! Store Tv in relaxwork: - do j=jps,min(jde-1,jpe) - do i=ips,min(ide-1,ipe) - grid%relaxwork(i,j)=presTv(i,j,ipres) - enddo - enddo - + do ipres=npres,1,-1 ! In the inner regions (all but outermost row & col) set the ! relaxmask to the ground_mask: + need_to_relax=0 do j=max(jps,jds+1),min(jde-2,jpe) do i=max(ips,ids+1),min(ide-2,ipe) grid%relaxmask(i,j)=ground_mask(i,j,ipres) + if(grid%relaxmask(i,j)) need_to_relax=1 + enddo + enddo + + ! If we do not need to relax any points, we are done. +#ifdef DM_PARALLEL + call wrf_dm_maxval_integer(need_to_relax,imax,jmax) +#endif + if(need_to_relax==0) then + 38 format('end mslp relax loop at ',I0) + write(message,38) ipres + call wrf_debug(1,message) + exit + endif + + ! Store Tv in relaxwork: + do j=jps,min(jde-1,jpe) + do i=ips,min(ide-1,ipe) + grid%relaxwork(i,j)=presTv(i,j,ipres) enddo enddo diff --git a/wrfv2_fire/dyn_nmm/module_swath.F b/wrfv2_fire/dyn_nmm/module_swath.F index 8e5943b2..7431f2fd 100644 --- a/wrfv2_fire/dyn_nmm/module_swath.F +++ b/wrfv2_fire/dyn_nmm/module_swath.F @@ -1,5 +1,5 @@ module module_swath -#ifdef HWRF +#if ( HWRF == 1 ) #ifdef DM_PARALLEL use module_dm, only: wrf_dm_sum_integer, local_communicator, & diff --git a/wrfv2_fire/dyn_nmm/module_tracker.F b/wrfv2_fire/dyn_nmm/module_tracker.F index bd85f726..be405538 100644 --- a/wrfv2_fire/dyn_nmm/module_tracker.F +++ b/wrfv2_fire/dyn_nmm/module_tracker.F @@ -1,7 +1,7 @@ module module_tracker implicit none private -#ifdef HWRF +#if ( HWRF == 1 ) public :: ncep_tracker_center, ncep_tracker_init, update_tracker_post_move real, parameter :: invE=0.36787944117 ! 1/e @@ -494,7 +494,7 @@ subroutine get_first_ges(grid, & #endif ! Rotated east and north motion in gridpoints per second, on the combined H+V grid: - tracker_dt=grid%dt*grid%nphs*grid%movemin + tracker_dt=grid%dt*grid%nphs*grid%ntrack dxeast = motion_grideast * tracker_dt / fixdx dynorth = motion_gridnorth * tracker_dt / grid%dy_nmm @@ -567,7 +567,7 @@ subroutine get_first_ges(grid, & !print *,'line guess: n=',n if(n>1) then - ntsd_plus_1 = grid%ntsd + grid%movemin*grid%nphs + ntsd_plus_1 = grid%ntsd + grid%ntrack*grid%nphs mx=(xtsum-(xsum*tsum)/real(n))/(ttsum-(tsum*tsum)/real(n)) my=(ytsum-(ysum*tsum)/real(n))/(ttsum-(tsum*tsum)/real(n)) bx=(xsum-mx*tsum)/real(n) diff --git a/wrfv2_fire/dyn_nmm/shift_domain_nmm.F b/wrfv2_fire/dyn_nmm/shift_domain_nmm.F index e7929bac..a0435ec7 100644 --- a/wrfv2_fire/dyn_nmm/shift_domain_nmm.F +++ b/wrfv2_fire/dyn_nmm/shift_domain_nmm.F @@ -1,6 +1,6 @@ SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y & ! -# include +# include "dummy_new_args.inc" ! ) USE module_domain @@ -28,13 +28,12 @@ SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y & CHARACTER(LEN=255) :: message ! Definitions of dummy arguments to solve -#include +#include "dummy_new_decl.inc" -!#define COPY_IN -!#include +IF ( grid%active_this_task ) THEN #ifdef DM_PARALLEL -# include +# include "data_calls.inc" #endif CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) @@ -169,18 +168,19 @@ SUBROUTINE shift_domain_nmm ( grid , disp_x, disp_y & #ifdef DM_PARALLEL ! shift the nest domain in x do ii = 1,abs(disp_x) -#include <../inc/SHIFT_HALO_X_HALO.inc> -#include <../frame/loop_based_x_shift_code.h> +#include "../inc/SHIFT_HALO_X_HALO.inc" +#include "../frame/loop_based_x_shift_code.h" enddo ! shift the nest domain in y do ii = 1,abs(disp_y) -#include <../inc/SHIFT_HALO_Y_HALO.inc> -#include <../frame/loop_based_y_shift_code.h> +#include "../inc/SHIFT_HALO_Y_HALO.inc" +#include "../frame/loop_based_y_shift_code.h" enddo #endif -!#define COPY_OUT -!#include +ENDIF + + RETURN END SUBROUTINE shift_domain_nmm diff --git a/wrfv2_fire/dyn_nmm/solve_nmm.F b/wrfv2_fire/dyn_nmm/solve_nmm.F index b028e75c..e7f42ab9 100644 --- a/wrfv2_fire/dyn_nmm/solve_nmm.F +++ b/wrfv2_fire/dyn_nmm/solve_nmm.F @@ -1,3 +1,4 @@ +#define HRD_MULTIPLE_STORMS !----------------------------------------------------------------------- ! !NCEP_MESO:MEDIATION_LAYER:SOLVER @@ -27,7 +28,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ,NTASKS_Y USE MODULE_COMM_DM #endif -#ifdef HWRF +#if ( HWRF == 1 ) USE MODULE_SWATH, ONLY : UPDATE_INTEREST USE MODULE_HIFREQ, ONLY: HIFREQ_WRITE, HIFREQ_OPEN #endif @@ -72,7 +73,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! JM, 20050819 ! !---------------------------- -#include +#include "dummy_new_decl.inc" !---------------------------- ! !*** STRUCTURE THAT CONTAINS RUN-TIME CONFIGURATION (NAMELIST) DATA FOR DOMAIN @@ -93,7 +94,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & LOGICAL :: advect_q2 INTEGER :: I,ICLTEND,IDF,IRTN,J,JC,JDF,K,KDF,LB,N_MOIST & & ,NTSD_current,L -#ifdef HWRF +#if ( HWRF == 1 ) #ifdef HRD_MULTIPLE_STORMS !XUEJIN's doing INTEGER, PARAMETER :: max_simulation_domains=11 !The max number of domains in the HWRF simulation. Currently hard-coded to 5 storms. This should eventually be replaced with CONFIG_FLAGS%MAX_DOM. @@ -103,6 +104,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !zhang's doing INTEGER,SAVE :: NTSD_restart1,NTSD_restart2,NTSD_restart3 #endif + LOGICAL :: multi_storm, no_ocean #endif #ifdef NMM_FIND_LOAD_IMBALANCE integer, save :: cpu @@ -113,7 +115,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! INTEGER :: MPI_COMM_COMP,MYPE,MYPROC,NPES INTEGER :: MYPROC,imid,jmid INTEGER :: KVH,NTSD_rad,RC - INTEGER :: NUM_OZMIXM,NUM_AEROSOLC + INTEGER :: NUM_AEROSOLC ! REAL :: DT_INV,FICE,FRAIN,GPS,QI,QR,QW,WC,WP ! @@ -146,7 +148,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & &, radiation_tim,rdtemp_tim,turbl_tim,cltend_tim & &, cucnvc_tim,gsmdrive_tim,hdiff_tim,bocoh_tim & &, pfdht_tim,ddamp_tim,bocov_tim,uv_htov_tim,sum_tim & -#ifdef HWRF +#if ( HWRF == 1 ) &, sst_tim,flux_tim,hifreq_tim & #endif &, diag_tim,adjppt_tim,tornado_tim @@ -194,7 +196,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! !----------------------------------------------------------------------- !#define COPY_IN -!#include +!#include "scalar_derefs.inc" !----------------------------------------------------------------------- ! ! TRICK PROBLEMATIC COMPILERS INTO NOT PERFORMING COPY-IN/COPY-OUT BY ADDING @@ -232,7 +234,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! IF(NTSD_current==0)THEN IF(GRID%RESTART.AND.GRID%TSTART>0.)THEN -#ifdef HWRF +#if ( HWRF == 1 ) #ifdef HRD_MULTIPLE_STORMS !XUEJIN's doing do kid1=1,max_simulation_domains @@ -250,7 +252,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ELSE IHRST=GRID%GMT grid%nstart_hour=IHRST -#ifdef HWRF +#if ( HWRF == 1 ) #ifdef HRD_MULTIPLE_STORMS !XUEJIN's doing NTSD_restart1=0 @@ -265,7 +267,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & #endif ENDIF ENDIF -#ifdef HWRF +#if ( HWRF == 1 ) #ifdef HRD_MULTIPLE_STORMS !XUEJIN's doing do kid1=1,max_simulation_domains @@ -299,8 +301,8 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !----------------------------------------------------------------------- ! !!!!! IF(WRF_DM_ON_MONITOR() )THEN - WRITE(MESSAGE,125)grid%ntsd,grid%ntsd*GRID%DT/3600. - 125 FORMAT(' SOLVE_NMM: TIMESTEP IS ',I5,' TIME IS ',F7.3,' HOURS') + WRITE(MESSAGE,125)grid%id,grid%ntsd,grid%ntsd*GRID%DT/3600. + 125 FORMAT(' SOLVE_NMM: ',I3,' TIMESTEP IS ',I5,' TIME IS ',F7.3,' HOURS') CALL WRF_MESSAGE(TRIM(MESSAGE)) !!!! ENDIF ! @@ -339,7 +341,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ETAMP_PHYSICS=.FALSE. ! IF (CONFIG_FLAGS%MP_PHYSICS == ETAMPNEW .OR. & - & CONFIG_FLAGS%MP_PHYSICS == ETAMP_HR .OR. & + & CONFIG_FLAGS%MP_PHYSICS == FER_MP_HIRES .OR. & & CONFIG_FLAGS%MP_PHYSICS == ETAMP_HWRF ) THEN ! ETAMP_PHYSICS=.TRUE. @@ -464,7 +466,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & adjppt_tim=0. diag_tim=0. tornado_tim=0. -#ifdef HWRF +#if ( HWRF == 1 ) sst_tim=0. flux_tim=0. hifreq_tim=0. @@ -626,7 +628,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !----------------------------------------------------------------------- !*** UPDATE AREA OF INTEREST !----------------------------------------------------------------------- -#ifdef HWRF +#if ( HWRF == 1 ) if(size(grid%precip_swath)>1 .and. grid%update_interest) then call update_interest(grid,config_flags) grid%update_interest=.false. @@ -654,7 +656,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,ITS,ITE,JTS,JTE,KTS,KTE) !----------------------------------------------------------------------- ! -!!#ifdef HWRF +!!#if ( HWRF == 1 ) !!!zhang !! IF(NTSD_current==0)THEN !!#else @@ -709,16 +711,16 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! !----------------------------------------------------------------------- ! -#ifdef DM_PARALLEL -# include "HALO_NMM_A.inc" -#endif +!!#ifdef DM_PARALLEL +!!# include "HALO_NMM_A.inc" +!!#endif ! !----------------------------------------------------------------------- -#ifdef DM_PARALLEL - IF (.NOT.ETAMP_PHYSICS) THEN -# include "HALO_NMM_A_3.inc" - ENDIF -#endif +!!#ifdef DM_PARALLEL +!! IF (.NOT.ETAMP_PHYSICS) THEN +!!# include "HALO_NMM_A_3.inc" +!! ENDIF +!!#endif !----------------------------------------------------------------------- !*** FIRST STEP INITIALIZATION OF PASSIVE SUBSTANCE VARIABLES !----------------------------------------------------------------------- @@ -764,7 +766,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! exch_tim_max=exch_tim_max+et_max !----------------------------------------------------------------------- ! -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing if(GRID%RESTART) then FIRST=.FALSE. @@ -782,23 +784,26 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & 2000 CONTINUE !----------------------------------------------------------------------- !----------------------------------------------------------------------- -#ifdef HWRF -#ifdef HRD_MULTIPLE_STORMS - write(message,*)' No Ocean Coupling Run' - call wrf_message(trim(message)) -#else +#if ( HWRF == 1 ) + CALL nl_get_multi_storm(1,multi_storm) + CALL nl_get_no_ocean(1,no_ocean) + IF ( .NOT. multi_storm .OR. no_ocean) THEN + write(message,*)' No Ocean Coupling Run' + call wrf_debug(1,trim(message)) ! Coupling insertion:-> - btimx=now_time() - call ATM_TSTEP_INIT(NTSD_current,grid%NPHS,GRID%ID,grid%NPHS*grid%dt, & - ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme, & - kds,kde,kts,kte,kms,kme, & - grid%HLON,grid%HLAT,grid%VLON,grid%VLAT,grid%sm, & - grid%i_parent_start,grid%j_parent_start, & - grid%guessdtc,grid%dtc) - sst_tim=sst_tim+now_time()-btimx + ELSE + btimx=now_time() + call ATM_TSTEP_INIT(NTSD_current,grid%NPHS,GRID%ID,grid%NPHS*grid%dt, & + ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme, & + kds,kde,kts,kte,kms,kme, & + grid%HLON,grid%HLAT,grid%VLON,grid%VLAT,grid%sm, & + grid%i_parent_start,grid%j_parent_start, & + grid%guessdtc,grid%dtc) + sst_tim=sst_tim+now_time()-btimx + ENDIF !<-:coupling insertion ! -#endif + #endif !----------------------------------------------------------------------- !*** PRESSURE TENDENCY, SIGMA DOT, VERTICAL PART OF OMEGA-ALPHA @@ -809,9 +814,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & #endif btimx=now_time() !----------------- -#ifdef DM_PARALLEL -# include "HALO_NMM_D.inc" -#endif +!!#ifdef DM_PARALLEL +!!# include "HALO_NMM_D.inc" +!!#endif !----------------- exch_tim=exch_tim+now_time()-btimx #ifdef NMM_FIND_LOAD_IMBALANCE @@ -909,9 +914,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & call blockf(loadimbal_tim,'after adve') #endif btimx=now_time() -#ifdef DM_PARALLEL -# include "HALO_NMM_I.inc" -#endif +!!#ifdef DM_PARALLEL +!!# include "HALO_NMM_I.inc" +!!#endif exch_tim=exch_tim+now_time()-btimx #ifdef NMM_FIND_LOAD_IMBALANCE call blockf(loadimbal_tim,'after halo I') @@ -1048,44 +1053,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !*** CONFIGURATIONS WHERE IT MAY BE USED OUTSIDE OF THE PHYSICS. ! IF(.NOT.OPERATIONAL_PHYSICS)THEN - DO K=KTS,KTE - DO J=MYJS,MYJE - DO I=MYIS,MYIE - MOIST(I,J,K,P_QV)=grid%q(I,J,K)/(1.-grid%q(I,J,K)) - WC = grid%cwm(I,J,K) - QI = 0. - QR = 0. - QW = 0. - FICE=grid%f_ice(I,K,J) - FRAIN=grid%f_rain(I,K,J) -! - IF(FICE>=1.)THEN - QI=WC - ELSEIF(FICE<=0.)THEN - QW=WC - ELSE - QI=FICE*WC - QW=WC-QI - ENDIF -! - IF(QW>0..AND.FRAIN>0.)THEN - IF(FRAIN>=1.)THEN - QR=QW - QW=0. - ELSE - QR=FRAIN*QW - QW=QW-QR - ENDIF - ENDIF -! - MOIST(I,J,K,P_QC)=QW - MOIST(I,J,K,P_QR)=QR - MOIST(I,J,K,P_QI)=0. - MOIST(I,J,K,P_QS)=QI - MOIST(I,J,K,P_QG)=0. - ENDDO - ENDDO - ENDDO + call ETAMP_TO_MOIST() ENDIF ! had2_tim=had2_tim+now_time()-btimx @@ -1377,52 +1345,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !*** CONFIGURATIONS WHERE IT MAY BE USED OUTSIDE OF THE PHYSICS. ! IF(.NOT.OPERATIONAL_PHYSICS)THEN - DO K=KTS,KTE - DO J=MYJS,MYJE - DO I=MYIS,MYIE - MOIST(I,J,K,P_QV)=grid%q(I,J,K)/(1.-grid%q(I,J,K)) - WC = grid%cwm(I,J,K) - QI = 0. - QR = 0. - QW = 0. - FICE=grid%f_ice(I,K,J) - FRAIN=grid%f_rain(I,K,J) -! - IF(FICE>=1.)THEN - QI=WC - ELSEIF(FICE<=0.)THEN - QW=WC - ELSE - QI=FICE*WC - QW=WC-QI - ENDIF -! - IF(QW>0..AND.FRAIN>0.)THEN - IF(FRAIN>=1.)THEN - QR=QW - QW=0. - ELSE - QR=FRAIN*QW - QW=QW-QR - ENDIF - ENDIF -! - MOIST(I,J,K,P_QC)=QW - MOIST(I,J,K,P_QR)=QR - - IF (ETAMP_PHYSICS) THEN -#ifdef HWRF - MOIST(I,J,K,P_QI)=QI - MOIST(I,J,K,P_QS)=0. -#else - MOIST(I,J,K,P_QI)=0. - MOIST(I,J,K,P_QS)=QI -#endif - endif - MOIST(I,J,K,P_QG)=0. - ENDDO - ENDDO - ENDDO + call ETAMP_TO_MOIST() ENDIF ! !----------------------------------------------------------------------- @@ -1507,7 +1430,6 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !*** When allocating CAM radiation 4d arrays (ozmixm, aerosolc), !*** the following two scalars are not needed. ! - NUM_OZMIXM=1 NUM_AEROSOLC=1 ! IF(grid%ntsd<=0)THEN @@ -1520,7 +1442,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & NTSD_rad=grid%ntsd+1 ENDIF ! -#ifdef HWRF +#if ( HWRF == 1 ) !emc_2010_bugfix_h50 ! remove this - not needed for V3.2 ! call nl_get_start_hour(1,IHRST) @@ -1556,7 +1478,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,grid%cfracl,grid%cfracm,grid%cfrach,grid%sigt4 & & ,grid%acfrst,grid%ncfrst,grid%acfrcv,grid%ncfrcv & & ,grid%cuppt,grid%vegfrc,grid%sno,grid%htop,grid%hbot & - & ,grid%z,grid%sice,NUM_AEROSOLC,NUM_OZMIXM & + & ,grid%z,grid%sice,NUM_AEROSOLC,NUM_OZMIXM & + & ,OZMIXM,grid%PIN,grid%LEVSIZ & + & ,GRID,CONFIG_FLAGS & & ,RTHRATEN & & ,grid%re_cloud,grid%re_ice,grid%re_snow & ! G. Thompson @@ -1627,21 +1551,23 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & rdtemp_tim=rdtemp_tim+now_time()-btimx ! ! -#ifdef HWRF +#if ( HWRF == 1 ) ! !------------------------------------------------------------------------------------- !*** GET SSTs FROM DMITRY's COUPLER ON TO THE PARENT AND NESTED GRID !------------------------------------------------------------------------------------- -#ifdef HRD_MULTIPLE_STORMS - write(message,*)' No Ocean Coupling Run' - call wrf_message(trim(message)) -#else + CALL nl_get_multi_storm(1,multi_storm) + CALL nl_get_no_ocean(1,no_ocean) + IF ( .NOT. multi_storm .OR. no_ocean ) THEN + write(message,*)' No Ocean Coupling Run' + call wrf_debug(1,trim(message)) + ELSE ! Coupling insertion:-> btimx=now_time() CALL ATM_GETSST(grid%sst,grid%sm) sst_tim=sst_tim+now_time()-btimx !<-:Coupling insertion -#endif + ENDIF #endif !---------------------------------------------------------------------- !*** TURBULENT PROCESSES @@ -1708,6 +1634,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & & ,GRID%DISHEAT,GRID%DKU3D,GRID%DKT3D & & ,GRID%HPBL2D, GRID%EVAP2D, GRID%HEAT2D,GRID%RC2D & !S&P Kwon & ,GRID%SFCHEADRT,GRID%INFXSRT,GRID%SOLDRAIN & !Hydrology, no-op right now + & ,grid%cd_out,grid%ch_out & & ,IDS,IDF,JDS,JDF,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,IPS,IPE,JPS,JPE,KPS,KPE & @@ -1718,9 +1645,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! *** NOTE *** ! turbl_tim=turbl_tim+now_time()-btimx -#ifdef HWRF - - +#if ( HWRF == 1 ) !------------------------------------------------------------------------------ !*** ATMOSPHERIC MODEL OUTPUTS FROM PARENT AND NESTED GRID FOR DMITRYs COUPLER !------------------------------------------------------------------------------ @@ -1738,25 +1663,25 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! ! - -#ifdef HRD_MULTIPLE_STORMS - write(message,*)' No Ocean Coupling Run' - call wrf_message(trim(message)) -#else + CALL nl_get_multi_storm(1,multi_storm) + CALL nl_get_no_ocean(1,no_ocean) + IF ( .NOT. multi_storm .OR. no_ocean ) THEN + write(message,*)' No Ocean Coupling Run' + call wrf_debug(1,trim(message)) + ELSE ! Coupling insertion:-> - btimx=now_time() - call ATM_DOFLUXES(grid%twbs,grid%qwbs,grid%rlwin,grid%rswin,grid%radot,grid%rswout, & - grid%taux,grid%tauy,grid%pint,grid%prec,grid%u10,grid%v10) - flux_tim=flux_tim+now_time()-btimx + btimx=now_time() + call ATM_DOFLUXES(grid%twbs,grid%qwbs,grid%rlwin,grid%rswin,grid%radot,grid%rswout, & + grid%taux,grid%tauy,grid%pint,grid%prec,grid%u10,grid%v10) + flux_tim=flux_tim+now_time()-btimx !<-:Coupling insertion ! - IF(GRID%ID .EQ. 1 .AND. MOD(grid%ntsd,grid%NPHS)==0)THEN - btimx=now_time() - flux_tim=flux_tim+now_time()-btimx + IF(GRID%ID .EQ. 1 .AND. MOD(grid%ntsd,grid%NPHS)==0)THEN + btimx=now_time() + flux_tim=flux_tim+now_time()-btimx + ENDIF ENDIF - -#endif #endif ! #ifdef NMM_FIND_LOAD_IMBALANCE @@ -1944,7 +1869,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & #if (NMM_CORE==1) -!#ifdef HWRF +!#if ( HWRF == 1 ) !------------------------------------------------------------------------------------- ! This is gopal's doing for HWRFSAS @@ -2107,7 +2032,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! CALL HDIFF(grid%ntsd,GRID%DT,grid%fis,grid%dy_nmm,grid%hdac,grid%hdacv & & ,grid%hbm2,grid%deta1,GRID%SIGMA & -#ifdef HWRF +#if ( HWRF == 1 ) & ,grid%t,grid%q,grid%u,grid%v,grid%q2,grid%z,grid%w,grid%sm,grid%sice,grid%h_diff & #else & ,grid%t,grid%q,grid%u,grid%v,grid%q2,grid%z,grid%w,grid%sm,grid%sice & @@ -2341,9 +2266,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & #endif btimx=now_time() !----------------- -#ifdef DM_PARALLEL -# include "HALO_NMM_A.inc" -#endif +!!#ifdef DM_PARALLEL +!!# include "HALO_NMM_A.inc" +!!#endif !----------------- exch_tim=exch_tim+now_time()-btimx #ifdef NMM_FIND_LOAD_IMBALANCE @@ -2460,7 +2385,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & cucnvc_tim + gsmdrive_tim + hdiff_tim + bocoh_tim + & pfdht_tim + ddamp_tim + bocov_tim + uv_htov_tim + diag_tim + & tornado_tim -#ifdef HWRF +#if ( HWRF == 1 ) sum_tim = sum_tim + sst_tim + flux_tim + hifreq_tim #endif #if defined(NMM_FIND_LOAD_IMBALANCE) @@ -2523,7 +2448,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & call wrf_message(trim(message)) write(message,17)' tornado_tim=',tornado_tim,' pct=',tornado_tim/sum_tim*100. call wrf_message(trim(message)) -#ifdef HWRF +#if ( HWRF == 1 ) write(message,17)' sst_tim=',sst_tim,' pct=',sst_tim/sum_tim*100. call wrf_message(trim(message)) write(message,17)' flux_tim=',flux_tim,' pct=',flux_tim/sum_tim*100. @@ -2580,7 +2505,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & diag_tim=diag_tim+now_time()-btimx ENDIF #endif -#ifdef HWRF +#if ( HWRF == 1 ) hwrfx_mlsp: if(grid%vortex_tracker /= 1) then btimx=now_time() @@ -2602,29 +2527,31 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & #endif !#define COPY_OUT -!#include -#ifdef HWRF +!#include "scalar_derefs.inc" +#if ( HWRF == 1 ) !----------------------------------------------------------------------- !*** ACCUMULATED ATMOSPHERIC MODEL FLUXES FOR DMITRYs COUPLER !----------------------------------------------------------------------- ! ! ! -#ifdef HRD_MULTIPLE_STORMS - write(message,*)' No Ocean Coupling Run' - call wrf_message(trim(message)) -#else + CALL nl_get_multi_storm(1,multi_storm) + CALL nl_get_no_ocean(1,no_ocean) + IF ( .NOT. multi_storm .OR. no_ocean ) THEN + write(message,*)' No Ocean Coupling Run' + call wrf_debug(1,trim(message)) + ELSE ! Coupling insertion:-> - btimx=now_time() - call ATM_SENDFLUXES - flux_tim=flux_tim+now_time()-btimx + btimx=now_time() + call ATM_SENDFLUXES + flux_tim=flux_tim+now_time()-btimx !<-:Coupling insertion ! ! Kwon's doing to check heat flux ! ! IF(grid%id==2)WRITE(0,*)'AFTER ATM_SENDFLUX grid%qwbs grid%twbs AT 10 10 ',grid%ntsd,grid%qwbs(10,10),grid%twbs(10,10) ! -#endif + ENDIF #endif !-------------------------------------------------------------------------------------------------------------- @@ -2634,14 +2561,14 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & ! !-------------------------------------------------------------------------------------------------------------- ! - IF(mod(grid%NTSD,grid%ntornado)==0) then + IF(grid%ntornado>0 .and. mod(grid%NTSD,grid%ntornado)==0) then btimx=now_time() CALL CALC_TORNADO_GENESIS(GRID,CONFIG_FLAGS) tornado_tim=tornado_tim+now_time()-btimx ENDIF -#ifdef HWRF - IF(mod(grid%NTSD,grid%ntornado)==0) then +#if ( HWRF == 1 ) + IF(grid%ntornado==0 .or. mod(grid%NTSD,grid%ntornado)==0) then have_best: if(size(grid%best_mslp)>1) then have_membrane: if(size(grid%membrane_mslp)>1) then call CALC_BEST_MSLP(grid%best_mslp,grid%mslp, & @@ -2685,6 +2612,63 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS & !********************************************************************** !********************************************************************** !---------------------------------------------------------------------- + CONTAINS + + SUBROUTINE ETAMP_TO_MOIST() + implicit none + INTEGER :: I,J,K + REAL :: QI,QR,QW,WC,FICE,FRAIN + if(size(grid%f_ice,1)*size(grid%f_ice,2) <= 1) then + return + endif + DO K=KTS,KTE + DO J=MYJS,MYJE + DO I=MYIS,MYIE + MOIST(I,J,K,P_QV)=grid%q(I,J,K)/(1.-grid%q(I,J,K)) + WC = grid%cwm(I,J,K) + QI = 0. + QR = 0. + QW = 0. + FICE=grid%f_ice(I,K,J) + FRAIN=grid%f_rain(I,K,J) +! + IF(FICE>=1.)THEN + QI=WC + ELSEIF(FICE<=0.)THEN + QW=WC + ELSE + QI=FICE*WC + QW=WC-QI + ENDIF +! + IF(QW>0..AND.FRAIN>0.)THEN + IF(FRAIN>=1.)THEN + QR=QW + QW=0. + ELSE + QR=FRAIN*QW + QW=QW-QR + ENDIF + ENDIF +! + MOIST(I,J,K,P_QC)=QW + MOIST(I,J,K,P_QR)=QR + + IF (ETAMP_PHYSICS) THEN +#if ( HWRF == 1 ) + MOIST(I,J,K,P_QI)=QI + MOIST(I,J,K,P_QS)=0. +#else + MOIST(I,J,K,P_QI)=0. + MOIST(I,J,K,P_QS)=QI +#endif + endif + MOIST(I,J,K,P_QG)=0. + ENDDO + ENDDO + ENDDO + END SUBROUTINE ETAMP_TO_MOIST + END SUBROUTINE SOLVE_NMM !---------------------------------------------------------------------- !********************************************************************** diff --git a/wrfv2_fire/dyn_nmm/start_domain_nmm.F b/wrfv2_fire/dyn_nmm/start_domain_nmm.F index 05929613..ef56625a 100644 --- a/wrfv2_fire/dyn_nmm/start_domain_nmm.F +++ b/wrfv2_fire/dyn_nmm/start_domain_nmm.F @@ -3,7 +3,7 @@ !#define NO_UPSTREAM_ADVECTION !---------------------------------------------------------------------- ! -#ifdef HWRF +#if ( HWRF == 1 ) SUBROUTINE GUESS_COUPLING_TIMESTEP(gridid,DTC) USE module_configure implicit none @@ -13,10 +13,10 @@ SUBROUTINE GUESS_COUPLING_TIMESTEP(gridid,DTC) character*255 :: message real :: dt - integer :: nphs,movemin + integer :: nphs,ntrack if(model_config_rec%max_dom>=2) then ! Normally, in an HWRF simulation, domain 2 has - ! dt*nphs*movemin = coupling timestep + ! dt*nphs*ntrack = coupling timestep ! So if there is a domain 2, we'll use that to ! guess the coupling timestep. if(gridid==1) then @@ -25,7 +25,7 @@ SUBROUTINE GUESS_COUPLING_TIMESTEP(gridid,DTC) ! 2 still has its dt set to the internal WRF default of 2. ! To get domain 2's correct dt, we get domain 1's dt and ! divide by 3 - call wrf_message('Guessing coupling timestep from d01''s dt/3 and d02''s nphs and movemin...') + call wrf_message('Guessing coupling timestep from d01''s dt/3 and d02''s nphs and ntrack...') call model_to_grid_config_rec(1,model_config_rec,config_flags) dt=config_flags%dt/3 call model_to_grid_config_rec(2,model_config_rec,config_flags) @@ -42,11 +42,11 @@ SUBROUTINE GUESS_COUPLING_TIMESTEP(gridid,DTC) dt=config_flags%dt endif nphs=config_flags%nphs - movemin=config_flags%movemin + ntrack=config_flags%ntrack - dtc = dt*nphs*movemin -388 format("dtc=dt*nphs*movemin = ",F0.3,"=",F0.3,"*",I0,"*",I0) - write(message,388) dtc,dt,nphs,movemin + dtc = dt*nphs*ntrack +388 format("dtc=dt*nphs*ntrack = ",F0.3,"=",F0.3,"*",I0,"*",I0) + write(message,388) dtc,dt,nphs,ntrack call wrf_message(message) END SUBROUTINE GUESS_COUPLING_TIMESTEP #endif @@ -57,18 +57,18 @@ END SUBROUTINE GUESS_COUPLING_TIMESTEP ! SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! -#include +#include "dummy_new_args.inc" ! & ) !---------------------------------------------------------------------- ! -#ifdef HWRF +#if ( HWRF == 1 ) USE MODULE_CLEAR_HALOS, only: clear_ij_halos USE MODULE_STATS_FOR_MOVE, only: vorttrak_init USE MODULE_SWATH, only: init_swath #endif USE MODULE_TIMING -#ifdef HWRF +#if ( HWRF == 1 ) USE MODULE_HIFREQ, only : hifreq_open #endif USE MODULE_DOMAIN @@ -107,13 +107,19 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & IMPLICIT NONE ! !---------------------------------------------------------------------- + INTERFACE + SUBROUTINE med_set_egrid_locs ( parent , nest ) + use module_domain_type, only: domain + type(domain) :: parent,nest + END SUBROUTINE med_set_egrid_locs + END INTERFACE !*** !*** Arguments !*** TYPE(DOMAIN),INTENT(INOUT) :: GRID LOGICAL , INTENT(IN) :: allowed_to_read ! -#include +#include "dummy_new_decl.inc" ! TYPE(GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS ! @@ -164,12 +170,12 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & !!! REAL :: BLDT,CWML,EXNSFC,G_INV,PLYR,PSFC,ROG,SFCZ,THSIJ,TL REAL :: CWML,EXNSFC,G_INV,PLYR,PSURF,ROG,SFCZ,THSIJ,TL,ZOQING REAL :: TEND, TEMPDX,TEMPDY -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing REAL :: TSTART !zhang's doing ends #endif -#ifdef HWRF +#if ( HWRF == 1 ) ! gopal's doing for the moving nest (MSLP computation) !----------------------------------------------------------------------------------------------------- REAL, PARAMETER :: LAPSR=6.5E-3, GI=1./G,D608=0.608 @@ -218,7 +224,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & #endif LOGICAL :: E_BDY,N_BDY,S_BDY,W_BDY,WARM_RAIN,ADV_MOIST_COND LOGICAL :: START_OF_SIMULATION - LOGICAL :: LRESTART + LOGICAL :: LRESTART, nestmove LOGICAL :: ETAMP_Regional, ICE1_indx, ICE2_indx LOGICAL :: IS_CAMMGMP_USED=.FALSE. @@ -231,7 +237,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & integer :: i_t=096,j_t=195,n_t=11 integer :: i_u=49,j_u=475,n_u=07 integer :: i_v=49,j_v=475,n_v=07 - integer :: num_ozmixm, num_aerosolc + integer :: num_aerosolc real :: cen_lat,cen_lon,dtphs ! GWD integer :: num_urban_layers,num_urban_hi !Rogers GMT @@ -240,7 +246,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & INTEGER :: interval_seconds, restart_interval -#ifdef HWRF +#if ( HWRF == 1 ) REAL :: xshift,xfar,yfar,dfar,close2edge REAL :: fedge,fmid,fdiff #endif @@ -259,7 +265,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! !---------------------------------------------------------------------- !#define COPY_IN -!#include +!#include "scalar_derefs.inc" !---------------------------------------------------------------------- !********************************************************************** !---------------------------------------------------------------------- @@ -267,7 +273,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & call start_timing -#ifdef HWRF +#if ( HWRF == 1 ) call clear_ij_halos(grid,config_flags%halo_debug) if(grid%id==3) then grid%force_sst=1 @@ -288,7 +294,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & KTS=KPS KTE=KPE -#ifdef HWRF +#if ( HWRF == 1 ) call guess_coupling_timestep(grid%id,grid%guessdtc) grid%dtc=0 #endif @@ -298,8 +304,9 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! RESTRT=config_flags%restart ANAL=config_flags%analysis + nestmove=RESTRT .and. .not. allowed_to_read -#ifdef HWRF +#if ( HWRF == 1 ) ! Sam's doing for hour 0 & 6 nest movement safeguards grid%nomove_freq_hr=config_flags%nomove_freq #endif @@ -538,45 +545,45 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! my_neb(8)=my_nw ! deallocate(itemp) -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include +# include "HALO_NMM_INIT_1.inc" +# include "HALO_NMM_INIT_2.inc" +# include "HALO_NMM_INIT_3.inc" +# include "HALO_NMM_INIT_4.inc" +# include "HALO_NMM_INIT_5.inc" +# include "HALO_NMM_INIT_6.inc" +# include "HALO_NMM_INIT_7.inc" +# include "HALO_NMM_INIT_8.inc" +# include "HALO_NMM_INIT_9.inc" +# include "HALO_NMM_INIT_10.inc" +# include "HALO_NMM_INIT_11.inc" +# include "HALO_NMM_INIT_12.inc" +# include "HALO_NMM_INIT_13.inc" +# include "HALO_NMM_INIT_14.inc" +# include "HALO_NMM_INIT_15.inc" +# include "HALO_NMM_INIT_16.inc" +# include "HALO_NMM_INIT_17.inc" +# include "HALO_NMM_INIT_18.inc" +# include "HALO_NMM_INIT_19.inc" +# include "HALO_NMM_INIT_20.inc" +# include "HALO_NMM_INIT_21.inc" +# include "HALO_NMM_INIT_22.inc" +# include "HALO_NMM_INIT_23.inc" +# include "HALO_NMM_INIT_24.inc" +# include "HALO_NMM_INIT_25.inc" +# include "HALO_NMM_INIT_26.inc" +# include "HALO_NMM_INIT_27.inc" +# include "HALO_NMM_INIT_28.inc" +# include "HALO_NMM_INIT_29.inc" +# include "HALO_NMM_INIT_30.inc" +# include "HALO_NMM_INIT_31.inc" +# include "HALO_NMM_INIT_32.inc" +# include "HALO_NMM_INIT_33.inc" +# include "HALO_NMM_INIT_34.inc" +# include "HALO_NMM_INIT_35.inc" +# include "HALO_NMM_INIT_36.inc" +# include "HALO_NMM_INIT_37.inc" +# include "HALO_NMM_INIT_38.inc" +# include "HALO_NMM_INIT_39.inc" #endif ! if((allowed_to_read .and. .not. restrt) .or. anal) then @@ -646,7 +653,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & endif randif endif ! Begin HWRF update for high-frequency output -#ifdef HWRF +#if ( HWRF == 1 ) if(allowed_to_read .and. config_flags%high_freq) then if(grid%id==config_flags%high_dom) then ! Open HTCF LUN: @@ -688,7 +695,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & endif ! End Sam Trahan's doing for Tornado Genesis (SPC) products -#ifdef HWRF +#if ( HWRF == 1 ) ! Begin Sam Trahan's doing for vortex tracker initialization IF ( program_name(1:8) .NE. "REAL_NMM" ) THEN call VORTTRAK_INIT(grid,config_flags, & @@ -704,7 +711,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ENDIF ! End Sam Trahan's doing for vortex tracker initialization #endif -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing IF((.NOT.RESTRT .AND. .NOT.ANAL) .OR. .NOT.allowed_to_read)THEN !end of zhang's doing @@ -760,7 +767,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & APEM1=(1.E5/PM1)**CAPA IF(grid%nmm_tsk(I,J)>=200.)THEN ! have a specific skin temp, use it -#ifdef HWRF +#if ( HWRF == 1 ) grid%ths(I,J)=grid%nmm_tsk(I,J)*(1.+P608*grid%q(I,J,KTS+1))*APEM1 TSFCK=grid%nmm_tsk(I,J)*(1.+P608*grid%q(I,J,KTS+1)) #else @@ -769,7 +776,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & #endif ELSE ! use lowest layer as a proxy -#ifdef HWRF +#if ( HWRF == 1 ) grid%ths(I,J)=grid%t(I,J,KTS)*(1.+P608*grid%q(I,J,KTS+1))*APEM1 TSFCK=grid%t(I,J,KTS)*(1.+P608*grid%q(I,J,KTS+1)) #else @@ -868,6 +875,16 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ENDDO ENDDO ENDIF + if(allowed_to_read .and. (anal .or. .not. restrt)) then + call wrf_debug(1,'Initialize DKU3D and DKT3D to 0.') + do j=jfs,jfe + do i=ifs,ife + grid%dku3d(i,j,:) = 0 + grid%dkt3d(i,j,:) = 0 + enddo + enddo + endif + !*** !*** INITIALIZE TURBULENT KINETIC ENERGY (TKE) TO A SMALL !*** VALUE (EPSQ2) ABOVE GROUND. SET TKE TO ZERO IN THE @@ -884,7 +901,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & DO K=KPS,KPE-1 DO J=JFS,JFE DO I=IFS,IFE -#ifdef HWRF +#if ( HWRF == 1 ) grid%q2(I,J,K)=0. #else grid%q2(I,J,K)=grid%hbm2(I,J)*EPSQ2 @@ -896,7 +913,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & DO J=JFS,JFE DO I=IFS,IFE grid%q2(I,J,LM) = 0. -#ifdef HWRF +#if ( HWRF == 1 ) grid%q2(I,J,KTE-2)= 0. grid%q2(I,J,KTE-1)= 0. #else @@ -959,7 +976,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & TSPH=3600./GRID%DT ! needed? grid%nphs0=GRID%NPHS -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing tstart = grid%TSTART !zhang's doing ends @@ -997,7 +1014,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & grid%nrdsw = INT(grid%TRDSW *TSPH+0.5) grid%nrdlw = INT(grid%TRDLW *TSPH+0.5) grid%nsrfc = INT(grid%TSRFC *TSPH+0.5) -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's dong for analysis option: grid%NCNVC0 = grid%NCNVC grid%NPHS0 = grid%NPHS @@ -1327,7 +1344,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & !*** !*** SET ZERO-VALUE FOR SOME OUTPUT DIAGNOSTIC ARRAYS !*** -#ifdef HWRF +#if ( HWRF == 1 ) !zhang'sdoing IF(NSTART.EQ.0)THEN IF(NSTART.EQ.0 .or. .not.allowed_to_read )THEN !zhang's doing ends @@ -1478,7 +1495,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & !*** !*** TRY A SIMPLE LINEAR INTERP TO GET 2/10 M VALUES !*** -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing IF(.NOT.RESTRT .OR. .NOT.allowed_to_read) then grid%PDSL(I,J)=grid%PD(I,J)*grid%RES(I,J) @@ -1507,7 +1524,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & FAC2=0. ENDIF ! -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing IF(.NOT.RESTRT .OR. .NOT.allowed_to_read)THEN !end of zhang's doing @@ -1516,7 +1533,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & #endif grid%th10(I,J)=FAC2*grid%ths(I,J)+FAC1*THLM grid%q10(I,J)=FAC2*grid%qsh(I,J)+FAC1*QLM -#ifdef HWRF +#if ( HWRF == 1 ) IF(grid%sm(I,J).LT.0.5)THEN grid%u10(I,J)=ULM*(log(10./grid%z0(I,J))/log(DZLM/grid%z0(I,J))) ! this is all Qingfu's doing grid%v10(I,J)=VLM*(log(10./grid%z0(I,J))/log(DZLM/grid%z0(I,J))) @@ -1559,7 +1576,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & FAC2=0.2 ENDIF -#ifdef HWRF +#if ( HWRF == 1 ) grid%tshltr(I,J)=0.2*grid%ths(I,J)+0.8*THLM grid%qshltr(I,J)=0.2*grid%qsh(I,J)+0.8*QLM #else @@ -1585,7 +1602,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & !*** INITIALIZE TAU-1 VALUES FOR ADAMS-BASHFORTH !---------------------------------------------------------------------- ! -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing IF(.NOT.RESTRT .OR. .NOT.allowed_to_read)THEN !zhang's doing #else @@ -1611,14 +1628,20 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & IF((.NOT.RESTRT.OR.NEST).AND. allowed_to_read)THEN ! This is gopal's inclusion for moving nest DO K=KPS,KPE DO J=JFS,JFE - DO I=IFS,IFE - grid%dwdt(I,J,K)=1. - ENDDO + if(.not. grid%keepnh .or. .not. nestmove & + .or. j<7 .or. j+6>jfe) then + DO I=IFS,IFE + grid%dwdt(I,J,K)=1. + ENDDO + else + grid%dwdt(1:3,j,k)=1. + grid%dwdt(ife-2:ife,j,k)=1. + endif ENDDO ENDDO ENDIF !*** -#ifdef HWRF +#if ( HWRF == 1 ) IF(.NOT.RESTRT .OR. .NOT.allowed_to_read) THEN !zhang's doing #endif IF(GRID%SIGMA==1)THEN @@ -1634,7 +1657,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ENDDO ENDDO ENDIF -#ifdef HWRF +#if ( HWRF == 1 ) ENDIF !zhang's doing #endif ! @@ -1647,27 +1670,50 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & CALL wrf_debug( 0, TRIM(wrf_err_message) ) WRITE( wrf_err_message, * )' grid%pdtop=',grid%pdtop,' grid%pt=',grid%pt CALL wrf_debug( 0, TRIM(wrf_err_message) ) -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing IF(.NOT.RESTRT.OR.NEST .OR. .NOT.allowed_to_read)THEN !end of zhang's doing #else IF(.NOT.RESTRT.OR.NEST)THEN #endif - DO K=KPS,KPE - DO J=JFS,JFE - DO I=IFS,IFE - grid%pint(I,J,K)=grid%eta1(K)*grid%pdtop+grid%eta2(K)*grid%pdsl(I,J)+grid%pt - grid%z(I,J,K)=grid%pint(I,J,K) - grid%w(I,J,K)=0. #ifdef IDEAL_NMM_TC + do k=kps,kpe + do j=jfs,jfe + do i=ifs,ife grid%f(I,J)=0.5*GRID%DT*3.15656e-5 ! IDEAL CASE 0.5*DT*f (and not f!) + enddo + enddo + enddo #endif - ENDDO + if(nestmove) then + if(.not.grid%keepnh) then + call wrf_message('Discarding non-hydrostatic state at nest move. Set keepnh=T to retain the state.') + else + call wrf_message('Retaining non-hydrostatic state at nest move except at nest boundaries.') + endif + endif + + DO K=KPS,KPE + DO J=JFS,JFE + if(.not.nestmove .or. .not. grid%keepnh .or. j<7 .or. j+6>=jfe) then + DO I=IFS,IFE + grid%pint(I,J,K)=grid%eta1(K)*grid%pdtop+grid%eta2(K)*grid%pdsl(I,J)+grid%pt + grid%z(I,J,K)=grid%pint(I,J,K) + grid%w(I,J,K)=0. + ENDDO + else + grid%pint(1:3,J,K)=grid%eta1(K)*grid%pdtop+grid%eta2(K)*grid%pdsl(I,J)+grid%pt + grid%z(1:3,J,K)=grid%pint(I,J,K) + grid%w(1:3,J,K)=0. + grid%pint(ife-2:ife,J,K)=grid%eta1(K)*grid%pdtop+grid%eta2(K)*grid%pdsl(I,J)+grid%pt + grid%z(ife-2:ife,J,K)=grid%pint(I,J,K) + grid%w(ife-2:ife,J,K)=0. + endif ENDDO ENDDO ENDIF -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing IF(.NOT.RESTRT.OR.NEST .OR. .NOT.allowed_to_read)THEN #endif @@ -1680,11 +1726,11 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ENDDO ENDDO ENDDO -#ifdef HWRF +#if ( HWRF == 1 ) ENDIF !zhang #endif -#ifdef HWRF +#if ( HWRF == 1 ) hwrfx_mslp: if(grid%vortex_tracker /= 1) then DO J=JFS,JFE DO I=IFS,IFE @@ -1897,7 +1943,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & DO I=MYIS,MYIE SFCZ=grid%fis(I,J)*G_INV ZINT(I,KTS,J)=SFCZ -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing IF(.NOT.RESTRT .OR. .NOT.allowed_to_read) then grid%PDSL(I,J)=grid%PD(I,J)*grid%RES(I,J) @@ -1953,7 +1999,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! !----------------------------------------------------------------------- -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing if(.NOT.RESTRT .OR. .NOT.allowed_to_read)grid%LU_INDEX=grid%IVGTYP !end of zhang's doing @@ -1992,7 +2038,6 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ENDIF ! ! when allocating CAM radiation 4d arrays (ozmixm, aerosolc) these are not needed - num_ozmixm=1 num_aerosolc=1 ! Set GMT, JULDAY, and JULYR outside of phy_init because it is no longer @@ -2004,20 +2049,12 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & CALL domain_setgmtetc( GRID, START_OF_SIMULATION ) if(restrt) then -#ifdef HWRF -!zhang - CALL nl_get_julyr (grid%id, grid%julyr) - CALL nl_get_julday (grid%id, grid%julday) - CALL nl_get_gmt (grid%id, grid%gmt) -!zhang end -#else CALL domain_clock_get( grid, current_time=currentTime ) CALL WRFU_TimeGet( currentTime, YY=grid%julyr, dayOfYear=grid%julday, & H=hr, M=mn, S=sec, MS=ms, rc=rc) grid%gmt=hr+real(mn)/60.+real(sec)/3600.+real(ms)/(1000*3600) WRITE( wrf_err_message , * ) 'DEBUG start_domain_nmm(): gmt = ',grid%gmt CALL wrf_debug( 150, TRIM(wrf_err_message) ) -#endif endif ! Several arguments are RCONFIG entries in Registry.NMM. Registry no longer @@ -2040,6 +2077,14 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ENDIF END IF + if(allowed_to_read) then + call wrf_debug(1,'Set E grid locations for PHY_INIT.') + if(grid%id==1) then + call med_set_egrid_locs(grid,grid) + else + call med_set_egrid_locs(grid%parents(1)%ptr,grid) + endif + end if CALL PHY_INIT(GRID%ID,CONFIG_FLAGS,GRID%DT,LRESTART,SFULL,SMID & & ,grid%pt,TSFC,GRID%RADT,GRID%BLDT,GRID%CUDT,GRID%GSMDT & & ,grid%DUCUDT, grid%DVCUDT & @@ -2055,7 +2100,8 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & & ,grid%w0avg, RAINNC, RAINC, grid%raincv, RAINNCV & & ,SNOWNC, SNOWNCV, GRAUPELNC, GRAUPELNCV & & ,z_at_q, grid%qnwfa2d & - & ,scalar_trans(ims,kms,jms,1),num_scalar & +! & ,scalar_trans(ims,kms,jms,1),num_scalar & + & ,scalar_trans,num_scalar & & ,grid%re_cloud, grid%re_ice, grid%re_snow & ! G. Thompson & ,grid%has_reqc,grid%has_reqi,grid%has_reqs & ! G. Thompson & ,NCA,GRID%SWRAD_SCAT & @@ -2066,7 +2112,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & & ,GRID%LANDUSE_ISICE, GRID%LANDUSE_LUCATS & & ,GRID%LANDUSE_LUSEAS, GRID%LANDUSE_ISN & & ,GRID%LU_STATE & - & ,grid%xlat,grid%xlong,grid%glat,grid%glon& + & ,grid%hlat,grid%hlon,grid%glat,grid%glon& & ,grid%albedo,grid%albbck & & ,GRID%GMT,GRID%JULYR,GRID%JULDAY & & ,GRID%LEVSIZ, NUM_OZMIXM, NUM_AEROSOLC, GRID%PAERLEV & @@ -2101,6 +2147,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & & WSLAKEXY=grid%WSLAKEXY, ZWTXY=grid%ZWTXY, WAXY=grid%WAXY, & ! Optional Noah-MP & WTXY=grid%WTXY, LFMASSXY=grid%LFMASSXY, RTMASSXY=grid%RTMASSXY, & ! Optional Noah-MP & STMASSXY=grid%STMASSXY, WOODXY=grid%WOODXY, & ! Optional Noah-MP + & GRAINXY=grid%GRAINXY, GDDXY=grid%GDDXY, & ! Optional Noah-MP & STBLCPXY=grid%STBLCPXY, FASTCPXY=grid%FASTCPXY, & ! Optional Noah-MP & XSAIXY=grid%XSAIXY,LAI=grid%LAI, & ! Optional Noah-MP & T2MVXY=grid%T2MVXY, T2MBXY=grid%T2MBXY, CHSTARXY=grid%CHSTARXY, & ! Optional Noah-MP @@ -2115,10 +2162,19 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & & lakedepth_default=config_flags%lakedepth_default, lake_min_elev=config_flags%lake_min_elev, lake_depth=grid%lake_depth, & !lake & lake_depth_flag=grid%LAKE_DEPTH_FLAG, use_lakedepth=grid%use_lakedepth, & !lake & sf_surface_mosaic=config_flags%sf_surface_mosaic, mosaic_cat=config_flags%mosaic_cat, nlcat=1, & ! Noah tiling - & MAXPATCH=1,ccn_conc=config_flags%ccn_conc & ! CLM + & nssl_cccn=config_flags%nssl_cccn, & + & nssl_alphah=config_flags%nssl_alphah, nssl_alphahl=config_flags%nssl_alphahl, & + & nssl_cnoh=config_flags%nssl_cnoh, nssl_cnohl=config_flags%nssl_cnohl, & + & nssl_cnor=config_flags%nssl_cnor, nssl_cnos=config_flags%nssl_cnos, & + & nssl_rho_qh=config_flags%nssl_rho_qh, nssl_rho_qhl=config_flags%nssl_rho_qhl, & + & nssl_rho_qs=config_flags%nssl_rho_qs, & + & nssl_ipelec=config_flags%nssl_ipelec, & + & nssl_isaund=config_flags%nssl_isaund, & + & MAXPATCH=1,ccn_conc=config_flags%ccn_conc, & ! CLM + & pin=grid%pin,ozmixm=grid%ozmixm & & ) -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing grid%julyr_rst=grid%julyr_rst grid%julday_rst=grid%julday_rst @@ -2162,7 +2218,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & !----------------------------------------------------------------------- ! -#ifdef HWRF +#if ( HWRF == 1 ) IF(NSTART.EQ.0 .or. .not.allowed_to_read )THEN #else IF(NSTART==0)THEN @@ -2187,7 +2243,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ! ! !mp replace F*_PHY with values defined in module_initialize_real.F? -#ifdef HWRF +#if ( HWRF == 1 ) IF (.NOT. RESTRT .and. ALLOWED_TO_READ) THEN !zhang moist = 0.0 if(size(grid%f_ice)>1) grid%f_ice = grid%f_ice_phy @@ -2233,7 +2289,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & IF( .not. ( (maxval(grid%f_ice(ips:ipe,:,jps:jpe)) & +maxval(grid%f_rain(ips:ipe,:,jps:jpe))) .gt. EPSQ) ) THEN ETAMP_Regional=.FALSE. !-- Regional NAM or HRW (Ferrier) microphysics - if (model_config_rec%mp_physics(grid%id).EQ.ETAMP_HR .OR. & + if (model_config_rec%mp_physics(grid%id).EQ.FER_MP_HIRES .OR. & & model_config_rec%mp_physics(grid%id).EQ.ETAMPNEW ) & & ETAMP_Regional=.TRUE. CALL wrf_message(' computing grid%f_ice') @@ -2338,7 +2394,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ENDIF ENDIF -#ifdef HWRF +#if ( HWRF == 1 ) if(.NOT. RESTRT .OR. .NOT.allowed_to_read) then !zhang's doing !zhang's doing #else @@ -2351,6 +2407,21 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & ENDDO ENDDO ENDIF + + +! +! translate scalar_trans(i,k,j,n) back to scalar(i,j,k,n) + DO N=1,NUM_SCALAR +!$omp parallel do & +!$omp& private(i,j,k) + DO K=KMS,KME + DO J=JMS,JME + DO I=IMS,IME + SCALAR(I,J,K,N)=SCALAR_TRANS(I,K,J,N) + ENDDO + ENDDO + ENDDO + ENDDO ! DEALLOCATE(SFULL) DEALLOCATE(SMID) @@ -2404,6 +2475,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & DEALLOCATE(CLDFRA_TRANS) DEALLOCATE(CLDFRA_OLD) DEALLOCATE(Z_AT_Q) + DEALLOCATE(SCALAR_TRANS) #if 0 DEALLOCATE(w0avg) #endif @@ -2418,49 +2490,49 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read & !---------------------------------------------------------------------- #ifdef DM_PARALLEL -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include -# include +# include "HALO_NMM_INIT_1.inc" +# include "HALO_NMM_INIT_2.inc" +# include "HALO_NMM_INIT_3.inc" +# include "HALO_NMM_INIT_4.inc" +# include "HALO_NMM_INIT_5.inc" +# include "HALO_NMM_INIT_6.inc" +# include "HALO_NMM_INIT_7.inc" +# include "HALO_NMM_INIT_8.inc" +# include "HALO_NMM_INIT_9.inc" +# include "HALO_NMM_INIT_10.inc" +# include "HALO_NMM_INIT_11.inc" +# include "HALO_NMM_INIT_12.inc" +# include "HALO_NMM_INIT_13.inc" +# include "HALO_NMM_INIT_14.inc" +# include "HALO_NMM_INIT_15.inc" +# include "HALO_NMM_INIT_15B.inc" +# include "HALO_NMM_INIT_16.inc" +# include "HALO_NMM_INIT_17.inc" +# include "HALO_NMM_INIT_18.inc" +# include "HALO_NMM_INIT_19.inc" +# include "HALO_NMM_INIT_20.inc" +# include "HALO_NMM_INIT_21.inc" +# include "HALO_NMM_INIT_22.inc" +# include "HALO_NMM_INIT_23.inc" +# include "HALO_NMM_INIT_24.inc" +# include "HALO_NMM_INIT_25.inc" +# include "HALO_NMM_INIT_26.inc" +# include "HALO_NMM_INIT_27.inc" +# include "HALO_NMM_INIT_28.inc" +# include "HALO_NMM_INIT_29.inc" +# include "HALO_NMM_INIT_30.inc" +# include "HALO_NMM_INIT_31.inc" +# include "HALO_NMM_INIT_32.inc" +# include "HALO_NMM_INIT_33.inc" +# include "HALO_NMM_INIT_34.inc" +# include "HALO_NMM_INIT_35.inc" +# include "HALO_NMM_INIT_36.inc" +# include "HALO_NMM_INIT_37.inc" +# include "HALO_NMM_INIT_38.inc" +# include "HALO_NMM_INIT_39.inc" #endif !#define COPY_OUT -!#include +!#include "scalar_derefs.inc" write(message,*) "Timing for start_domain on d",grid%id call end_timing(message) diff --git a/wrfv2_fire/external/RSL_LITE/c_code.c b/wrfv2_fire/external/RSL_LITE/c_code.c index bdd93f49..6cee6674 100755 --- a/wrfv2_fire/external/RSL_LITE/c_code.c +++ b/wrfv2_fire/external/RSL_LITE/c_code.c @@ -15,6 +15,9 @@ #ifdef _WIN32 #include #endif +#ifdef NCEP_DEBUG_MULTIDIR +// # include +#endif #define STANDARD_ERROR 2 @@ -27,7 +30,7 @@ #define F_PACK -RSL_LITE_ERROR_DUP1 ( int *me ) +void RSL_LITE_ERROR_DUP1 ( int *me ) { int newfd,rc ; char filename[256] ; @@ -223,6 +226,25 @@ BYTE_BCAST ( char * buf, int * size, int * Fcomm ) #endif } +BYTE_BCAST_FROM_ROOT ( char * buf, int * size, int *root , int * Fcomm ) +{ +#ifndef STUBMPI + MPI_Comm *comm, dummy_comm ; + + comm = &dummy_comm ; + *comm = MPI_Comm_f2c( *Fcomm ) ; +# ifdef crayx1 + if (*size % sizeof(int) == 0) { + MPI_Bcast ( buf, *size/sizeof(int), MPI_INT, *root, *comm ) ; + } else { + MPI_Bcast ( buf, *size, MPI_BYTE, *root, *comm ) ; + } +# else + MPI_Bcast ( buf, *size, MPI_BYTE, *root, *comm ) ; +# endif +#endif +} + static int yp_curs, ym_curs, xp_curs, xm_curs ; static int yp_curs_recv, ym_curs_recv, xp_curs_recv, xm_curs_recv ; diff --git a/wrfv2_fire/external/RSL_LITE/gen_comms.c b/wrfv2_fire/external/RSL_LITE/gen_comms.c index 18ed6f97..34a14d84 100644 --- a/wrfv2_fire/external/RSL_LITE/gen_comms.c +++ b/wrfv2_fire/external/RSL_LITE/gen_comms.c @@ -109,8 +109,9 @@ if ( q->mark == 0 ) { } strcat(moredims,",") ; -fprintf(fp," %s, INTENT(INOUT) :: %s ( grid%%sm31:grid%%em31,grid%%sm32:grid%%em32,grid%%sm33:grid%%em33%snum_%s)\n", - q->type->name , varref , moredims, q->name ) ; + dimspec=dimension_with_ranges( "grid%","",-1,tmp3,q,"","" ) ; +fprintf(fp," %s, INTENT(INOUT) :: %s ( %s %snum_%s)\n", + q->type->name , varref , dimspec, moredims, q->name ) ; } } else @@ -185,9 +186,11 @@ int print_decl( FILE * fp , node_t *p, char * communicator, int print_body( FILE * fp, char * commname ) { fprintf(fp," \n") ; + fprintf(fp,"CALL push_communicators_for_domain( grid%%id )\n") ; fprintf(fp,"#ifdef DM_PARALLEL\n") ; fprintf(fp,"#include \"%s_inline.inc\"\n",commname) ; fprintf(fp,"#endif\n") ; + fprintf(fp,"CALL pop_communicators_for_domain\n") ; fprintf(fp," \n") ; fprintf(fp," END SUBROUTINE %s_sub\n",commname) ; return 0; /* SamT: bug fix: return a value */ @@ -578,7 +581,7 @@ gen_packs_halo ( FILE *fp , node_t *p, char *shw, int xy /* 0=y,1=x */ , int pu node_t * q ; node_t * dimd ; char fname[NAMELEN] ; - char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG] ; + char tmp[NAMELEN_LONG], tmp2[NAMELEN_LONG], tmp3[NAMELEN_LONG], tmp4[NAMELEN_LONG] ; char commuse[NAMELEN] ; int maxstenwidth, stenwidth ; char * t1, * t2 , *wordsize ; @@ -625,11 +628,14 @@ gen_packs_halo ( FILE *fp , node_t *p, char *shw, int xy /* 0=y,1=x */ , int pu { node_t *member ; zdex = get_index_for_coord( q , COORD_Z ) ; - if ( zdex >=1 && zdex <= 3 ) + dimd = get_dimnode_for_coord( q , COORD_Z ) ; + if ( zdex >=1 && zdex <= 3 && dimd != NULL ) { int d ; char * colon ; char moredims[80], tx[80], temp[10], r[80] ; + char sd[256], ed[256] , sm[256], em[256] , sp[256], ep[256] ; + set_mem_order( q->members, memord , 3 ) ; fprintf(fp,"DO itrace = PARAM_FIRST_SCALAR, num_%s\n",q->name ) ; strcpy(moredims,"") ; @@ -646,23 +652,42 @@ fprintf(fp," DO idim%d = %s_sdim%d,%s_edim%d\n",d-2,q->name,d-2,q->name,d-2 ) ; strcat(moredims,",") ; xdex = get_index_for_coord( q , COORD_X ) ; ydex = get_index_for_coord( q , COORD_Y ) ; + if ( dimd->len_defined_how == DOMAIN_STANDARD ) { + strcpy(sd,"kds") ; strcpy(ed,"kde" ) ; + strcpy(sm,"kms") ; strcpy(em,"kme" ) ; + strcpy(sp,"kps") ; strcpy(ep,"kpe" ) ; + } else if ( dimd->len_defined_how == NAMELIST ) { + if ( !strcmp(dimd->assoc_nl_var_s,"1") ) { + strcpy(sd,"1") ; + sprintf(ed,"config_flags%%%s",dimd->assoc_nl_var_e) ; + } else { + sprintf(sd,"config_flags%%%s",dimd->assoc_nl_var_s) ; + sprintf(ed,"config_flags%%%s",dimd->assoc_nl_var_e) ; + } + strcpy(sm,sd) ; strcpy(em,ed ) ; + strcpy(sp,sd) ; strcpy(ep,ed ) ; + } else if ( dimd->len_defined_how == CONSTANT ) { + sprintf(sd,"%d",dimd->coord_start) ; sprintf(ed,"%d",dimd->coord_end) ; + strcpy(sm,sd) ; strcpy(em,ed ) ; + strcpy(sp,sd) ; strcpy(ep,ed ) ; + } fprintf(fp," IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; -fprintf(fp," CALL %s ( %s,&\n%s ( grid%%sm31,grid%%sm32,grid%%sm33%sitrace),%s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", - packname, commname, varref , moredims, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ; +fprintf(fp," CALL %s ( %s,&\n%s ( %s%sitrace),%s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", + packname, commname, varref , index_with_firstelem("","grid%",-1,tmp4,q,""),moredims, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ; fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ; if ( !strcmp( packname, "RSL_LITE_PACK_SWAP" ) || !strcmp( packname, "RSL_LITE_PACK_CYCLE" ) ) { fprintf(fp,"thisdomain_max_halo_width, &\n") ; } -if ( q->subgrid == 0 ) { -fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ; -fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ; -fprintf(fp,"ips, ipe, jps, jpe, kps, kpe )\n") ; -} else { -fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, kds, kde, &\n") ; -fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,kms,kme,&\n") ; -fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,kps,kpe)\n") ; -} + if ( q->subgrid == 0 ) { +fprintf(fp,"ids, ide, jds, jde, %s, %s, &\n",sd,ed) ; +fprintf(fp,"ims, ime, jms, jme, %s, %s, &\n",sm,em) ; +fprintf(fp,"ips, ipe, jps, jpe, %s, %s )\n",sp,ep) ; + } else { +fprintf(fp,"ids, ide*grid%%sr_x, jds, jde*grid%%sr_y, %s, %s, &\n",sd,ed) ; +fprintf(fp,"(ims-1)*grid%%sr_x+1,ime*grid%%sr_x,(jms-1)*grid%%sr_y+1,jme*grid%%sr_y,%s,%s,&\n",sm,em) ; +fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%sr_y,%s,%s)\n",sp,ep) ; + } fprintf(fp," ENDIF\n") ; for ( d = 3 ; d < q->ndims ; d++ ) { fprintf(fp," ENDDO ! idim%d \n",d-2 ) ; @@ -685,14 +710,13 @@ fprintf(fp,"ENDDO\n") ; ydex = get_index_for_coord( q , COORD_Y ) ; zdex = get_index_for_coord( q , COORD_Z ) ; fprintf(fp,"IF ( SIZE(%s,%d)*SIZE(%s,%d) .GT. 1 ) THEN\n",varref,xdex+1,varref,ydex+1 ) ; + fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", + packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ; + fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ; if ( dimd != NULL ) { char s[256], e[256] ; - if ( dimd->len_defined_how == DOMAIN_STANDARD ) { - fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", - packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ; - fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ; if ( q->subgrid == 0 ) { fprintf(fp,"ids, ide, jds, jde, kds, kde, &\n") ; fprintf(fp,"ims, ime, jms, jme, kms, kme, &\n") ; @@ -712,9 +736,6 @@ fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%s sprintf(s,"config_flags%%%s",dimd->assoc_nl_var_s) ; sprintf(e,"config_flags%%%s",dimd->assoc_nl_var_e) ; } - fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", - packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ; - fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ; if ( q->subgrid == 0 ) { fprintf(fp,"ids, ide, jds, jde, %s, %s, &\n",s,e) ; fprintf(fp,"ims, ime, jms, jme, %s, %s, &\n",s,e) ; @@ -727,9 +748,6 @@ fprintf(fp,"(ips-1)*grid%%sr_x+1,ipe*grid%%sr_x,(jps-1)*grid%%sr_y+1,jpe*grid%%s } else if ( dimd->len_defined_how == CONSTANT ) { - fprintf(fp,"CALL %s ( %s,&\n %s, %s,&\nrsl_sendbeg_m, rsl_sendw_m, rsl_sendbeg_p, rsl_sendw_p, &\nrsl_recvbeg_m, rsl_recvw_m, rsl_recvbeg_p, rsl_recvw_p, &\n%s, %d, %d, DATA_ORDER_%s, %d, &\n", - packname, commname, varref, shw, wordsize, xy, pu, memord, xy?(q->stag_x?1:0):(q->stag_y?1:0) ) ; - fprintf(fp,"mytask, ntasks, ntasks_x, ntasks_y, &\n") ; if ( q->subgrid == 0 ) { fprintf(fp,"ids, ide, jds, jde, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ; fprintf(fp,"ims, ime, jms, jme, %d, %d, &\n",dimd->coord_start,dimd->coord_end) ; @@ -1993,6 +2011,7 @@ gen_nest_pack ( char * dirname ) int down_path[] = { INTERP_DOWN , FORCE_DOWN , INTERP_UP } ; int ipath ; char ** fnp ; char * fn ; + char * parent ; char * shw_str ; char fname[NAMELEN] ; node_t *node, *p, *dim ; @@ -2028,6 +2047,8 @@ gen_nest_pack ( char * dirname ) #else count_fields ( node , &d2 , &d3 , fourd_names, down_path[ipath] ,0,0) ; #endif + parent= "" ; + if ( !strcmp(fn,"nest_feedbackup_pack.inc") ) parent="parent_" ; if ( d2 + d3 > 0 ) { if ( down_path[ipath] == INTERP_UP ) @@ -2049,13 +2070,18 @@ gen_nest_pack ( char * dirname ) d3_mp,fourd_names_mp,d2_mp); #endif - fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE &\n",info_name ) ; +/* fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE &\n",info_name ) ; */ + fprintf(fp,"CALL %s( msize*RWORDSIZE &\n",info_name ) ; fprintf(fp," ,cips,cipe,cjps,cjpe &\n") ; if (sw) fprintf(fp," ,iids,iide,ijds,ijde &\n") ; fprintf(fp," ,nids,nide,njds,njde &\n") ; if (sw) fprintf(fp," ,pgr , sw &\n") ; - fprintf(fp," ,ntasks_x,ntasks_y &\n") ; - fprintf(fp," ,thisdomain_max_halo_width &\n") ; + fprintf(fp," ,nest_task_offsets(ngrid%%id) &\n") ; + fprintf(fp," ,nest_pes_x(%sgrid%%id) &\n",parent) ; + fprintf(fp," ,nest_pes_y(%sgrid%%id) &\n",parent) ; + fprintf(fp," ,nest_pes_x(intermediate_grid%%id) &\n") ; + fprintf(fp," ,nest_pes_y(intermediate_grid%%id) &\n") ; + fprintf(fp," ,thisdomain_max_halo_width &\n") ; fprintf(fp," ,icoord,jcoord &\n") ; fprintf(fp," ,idim_cd,jdim_cd &\n") ; fprintf(fp," ,pig,pjg,retval )\n") ; @@ -2064,13 +2090,18 @@ if (sw) fprintf(fp," ,pgr , sw gen_nest_packunpack ( fp , Domain.fields, PACKIT, down_path[ipath] ) ; - fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE &\n",info_name ) ; +/* fprintf(fp,"CALL %s( local_communicator, msize*RWORDSIZE &\n",info_name ) ; */ + fprintf(fp,"CALL %s( msize*RWORDSIZE &\n",info_name ) ; fprintf(fp," ,cips,cipe,cjps,cjpe &\n") ; if (sw) fprintf(fp," ,iids,iide,ijds,ijde &\n") ; fprintf(fp," ,nids,nide,njds,njde &\n") ; if (sw) fprintf(fp," ,pgr , sw &\n") ; - fprintf(fp," ,ntasks_x,ntasks_y &\n") ; - fprintf(fp," ,thisdomain_max_halo_width &\n") ; + fprintf(fp," ,nest_task_offsets(ngrid%%id) &\n") ; + fprintf(fp," ,nest_pes_x(%sgrid%%id) &\n",parent) ; + fprintf(fp," ,nest_pes_y(%sgrid%%id) &\n",parent) ; + fprintf(fp," ,nest_pes_x(intermediate_grid%%id) &\n") ; + fprintf(fp," ,nest_pes_y(intermediate_grid%%id) &\n") ; + fprintf(fp," ,thisdomain_max_halo_width &\n") ; fprintf(fp," ,icoord,jcoord &\n") ; fprintf(fp," ,idim_cd,jdim_cd &\n") ; fprintf(fp," ,pig,pjg,retval )\n") ; @@ -2182,7 +2213,7 @@ gen_nest_packunpack ( FILE *fp , node_t * node , int dir, int down_path ) } p = p1 ; - if ( nest_mask & down_path ) + if ( nest_mask & down_path && ! ( down_path==INTERP_UP && p->no_feedback ) ) { if(p->mp_var) { fprintf(fp,"if(interp_mp .eqv. .true.) then\n"); diff --git a/wrfv2_fire/external/RSL_LITE/module_dm.F b/wrfv2_fire/external/RSL_LITE/module_dm.F index 8a6e1879..da95415a 100644 --- a/wrfv2_fire/external/RSL_LITE/module_dm.F +++ b/wrfv2_fire/external/RSL_LITE/module_dm.F @@ -17,6 +17,11 @@ MODULE module_dm #endif IMPLICIT NONE +#ifndef STUBMPI + INCLUDE 'mpif.h' +#else + INTEGER, PARAMETER :: MPI_UNDEFINED = -1 +#endif #if ( NMM_CORE == 1 ) || ( WRF_CHEM == 1 ) INTEGER, PARAMETER :: max_halo_width = 6 @@ -27,10 +32,55 @@ MODULE module_dm INTEGER :: ips_save, ipe_save, jps_save, jpe_save, itrace INTEGER :: lats_to_mic, minx, miny + INTEGER :: communicator_stack_cursor = 0 + INTEGER :: current_id = 1 + INTEGER, DIMENSION(max_domains) :: ntasks_stack, ntasks_y_stack & + , ntasks_x_stack, mytask_stack & + , mytask_x_stack, mytask_y_stack & + , id_stack + INTEGER, DIMENSION(max_domains) :: ntasks_store, ntasks_y_store & + , ntasks_x_store, mytask_store & + , mytask_x_store, mytask_y_store INTEGER ntasks, ntasks_y, ntasks_x, mytask, mytask_x, mytask_y - INTEGER local_communicator, local_communicator_periodic, local_iocommunicator - INTEGER local_communicator_x, local_communicator_y ! subcommunicators for rows and cols of mesh + + INTEGER, DIMENSION(max_domains) :: local_communicator_stack, local_communicator_periodic_stack & + ,local_iocommunicator_stack & + ,local_communicator_x_stack, local_communicator_y_stack + INTEGER, DIMENSION(max_domains) :: local_communicator_store, local_communicator_periodic_store & + ,local_iocommunicator_store & + ,local_communicator_x_store, local_communicator_y_store + + INTEGER :: mpi_comm_allcompute = MPI_UNDEFINED + INTEGER :: local_communicator = MPI_UNDEFINED + INTEGER :: local_communicator_periodic = MPI_UNDEFINED + INTEGER :: local_iocommunicator = MPI_UNDEFINED + INTEGER :: local_communicator_x = MPI_UNDEFINED + INTEGER :: local_communicator_y = MPI_UNDEFINED ! subcommunicators for rows and cols of mesh + INTEGER :: local_quilt_comm = MPI_UNDEFINED ! added 20151212 jm LOGICAL :: dm_debug_flag = .FALSE. +! for parallel nesting, 201408, jm + INTEGER intercomm_to_mom( max_domains ), intercomm_to_kid( max_nests, max_domains ) + INTEGER mpi_comm_to_mom( max_domains ), mpi_comm_to_kid( max_nests, max_domains ) + INTEGER which_kid(max_domains), nkids(max_domains) + INTEGER nest_task_offsets(max_domains) + LOGICAL intercomm_active( max_domains ) + LOGICAL domain_active_this_task( max_domains ) +! see comments below (search for "Communicator definition") + INTEGER tasks_per_split + INTEGER comm_start(max_domains) ! set in dm_task_split +! INTEGER comm_pes (max_domains) ! either this may be set in dm_task_split +! INTEGER comm_pes_x(max_domains) ! or these may be set in dm_task_split +! INTEGER comm_pes_y(max_domains) ! " " may be set in dm_task_split +! INTEGER comm_domain(max_domains) ! set in dm_task_split + INTEGER nest_pes_x(max_domains) ! set in dm_task_split + INTEGER nest_pes_y(max_domains) ! set in dm_task_split + INTEGER comms_i_am_in (max_domains) ! list of local communicators this task is a member of + INTEGER loc_comm(max_domains) + LOGICAL poll_servers + INTEGER nio_tasks_per_group(max_domains), nio_groups, num_io_tasks + NAMELIST /dm_task_split/ tasks_per_split, comm_start, nest_pes_x, nest_pes_y + NAMELIST /namelist_quilt/ nio_tasks_per_group, nio_groups, poll_servers + #if (DA_CORE == 1) integer :: c_ipsy, c_ipey, c_kpsy, c_kpey, c_kpsx, c_kpex, c_ipex, c_ipsx, c_jpex, c_jpsx, c_jpey, c_jpsy @@ -56,7 +106,6 @@ MODULE module_dm CONTAINS - SUBROUTINE MPASPECT( P, MINM, MINN, PROCMIN_M, PROCMIN_N ) IMPLICIT NONE INTEGER P, M, N, MINI, MINM, MINN, PROCMIN_M, PROCMIN_N @@ -73,9 +122,9 @@ SUBROUTINE MPASPECT( P, MINM, MINN, PROCMIN_M, PROCMIN_N ) MINI = ABS(M-N) MINM = M MINN = N - ENDIF - ENDIF - ENDDO + END IF + END IF + END DO IF ( MINM .LT. PROCMIN_M .OR. MINN .LT. PROCMIN_N ) THEN WRITE( wrf_err_message , * )'MPASPECT: UNABLE TO GENERATE PROCESSOR MESH. STOPPING.' CALL wrf_message ( TRIM ( wrf_err_message ) ) @@ -90,7 +139,7 @@ SUBROUTINE MPASPECT( P, MINM, MINN, PROCMIN_M, PROCMIN_N ) WRITE( wrf_err_message , * )' MINN ', MINN CALL wrf_message ( TRIM ( wrf_err_message ) ) CALL wrf_error_fatal ( 'module_dm: mpaspect' ) - ENDIF + END IF RETURN END SUBROUTINE MPASPECT @@ -112,12 +161,12 @@ SUBROUTINE compute_mesh( ntasks , ntasks_x, ntasks_y ) ! if only ntasks_y is specified then make it 1-d decomp in j ELSE IF ( ntasks_x .EQ. -1 .AND. ntasks_y .GT. 0 ) THEN ntasks_x = ntasks / ntasks_y - ENDIF + END IF ! make sure user knows what they're doing IF ( ntasks_x * ntasks_y .NE. ntasks ) THEN WRITE( wrf_err_message , * )'WRF_DM_INITIALIZE (RSL_LITE): nproc_x * nproc_y in namelist ne ',ntasks CALL wrf_error_fatal ( wrf_err_message ) - ENDIF + END IF #ifndef NMM_CORE ELSE IF ( lats_to_mic .GT. 0 ) THEN ntasks_x = ntasks / 2 @@ -127,85 +176,43 @@ SUBROUTINE compute_mesh( ntasks , ntasks_x, ntasks_y ) 'WRF_DM_INITIALIZE (lats_to_mic > 0) nproc_x (',ntasks_x,')* nproc_y (',ntasks_y,& ') in namelist ne ',ntasks CALL wrf_error_fatal ( wrf_err_message ) - ENDIF + END IF #endif ELSE ! When neither is specified, work out mesh with MPASPECT ! Pass nproc_ln and nproc_nt so that number of procs in ! i-dim (nproc_ln) is equal or lesser. CALL mpaspect ( ntasks, ntasks_x, ntasks_y, 1, 1 ) - ENDIF + END IF + ntasks_store(1) = ntasks + ntasks_x_store(1) = ntasks_x + ntasks_y_store(1) = ntasks_y END SUBROUTINE compute_mesh SUBROUTINE wrf_dm_initialize IMPLICIT NONE #ifndef STUBMPI INCLUDE 'mpif.h' - INTEGER :: local_comm, local_comm2, new_local_comm, group, newgroup, p, p1, ierr + INTEGER :: local_comm_per, local_comm_x, local_comm_y, local_comm2, new_local_comm, group, newgroup, p, p1, ierr,itmp INTEGER, ALLOCATABLE, DIMENSION(:) :: ranks INTEGER comdup INTEGER, DIMENSION(2) :: dims, coords LOGICAL, DIMENSION(2) :: isperiodic LOGICAL :: reorder_mesh - CALL wrf_get_dm_communicator ( local_comm ) - CALL mpi_comm_size( local_comm, ntasks, ierr ) - CALL nl_get_reorder_mesh( 1, reorder_mesh ) - CALL compute_mesh( ntasks, ntasks_x, ntasks_y ) - WRITE( wrf_err_message , * )'Ntasks in X ',ntasks_x,', ntasks in Y ',ntasks_y - CALL wrf_message( wrf_err_message ) + CALL instate_communicators_for_domain(1) - CALL mpi_comm_rank( local_comm, mytask, ierr ) -! extra code to reorder the communicator 20051212jm - IF ( reorder_mesh ) THEN - ALLOCATE (ranks(ntasks)) - CALL mpi_comm_dup ( local_comm , local_comm2, ierr ) - CALL mpi_comm_group ( local_comm2, group, ierr ) - DO p1=1,ntasks - p = p1 - 1 - ranks(p1) = mod( p , ntasks_x ) * ntasks_y + p / ntasks_x - ENDDO - CALL mpi_group_incl( group, ntasks, ranks, newgroup, ierr ) - DEALLOCATE (ranks) - CALL mpi_comm_create( local_comm2, newgroup, new_local_comm , ierr ) - ELSE - new_local_comm = local_comm - ENDIF -! end extra code to reorder the communicator 20051212jm - dims(1) = ntasks_y ! rows - dims(2) = ntasks_x ! columns - isperiodic(1) = .false. - isperiodic(2) = .false. - CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_communicator, ierr ) - dims(1) = ntasks_y ! rows - dims(2) = ntasks_x ! columns + CALL wrf_get_dm_communicator ( new_local_comm ) + dims(1) = nest_pes_y(1) ! rows + dims(2) = nest_pes_x(1) ! columns isperiodic(1) = .true. isperiodic(2) = .true. - CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_communicator_periodic, ierr ) -! debug - CALL mpi_comm_rank( local_communicator_periodic, mytask, ierr ) - CALL mpi_cart_coords( local_communicator_periodic, mytask, 2, coords, ierr ) -! write(0,*)'periodic coords ',mytask, coords - - CALL mpi_comm_rank( local_communicator, mytask, ierr ) - CALL mpi_cart_coords( local_communicator, mytask, 2, coords, ierr ) -! write(0,*)'non periodic coords ',mytask, coords - mytask_x = coords(2) ! col task (x) - mytask_y = coords(1) ! row task (y) - CALL nl_set_nproc_x ( 1, ntasks_x ) - CALL nl_set_nproc_y ( 1, ntasks_y ) + CALL mpi_cart_create( new_local_comm, 2, dims, isperiodic, .false., local_comm_per, ierr ) + local_communicator_periodic_store(1) = local_comm_per +! set all the domains' periodic communicators to this one <- kludge, 20151223, splitting domains won't work for period bc's + local_communicator_periodic_store = local_comm_per + local_communicator_periodic = local_comm_per -! 20061228 set up subcommunicators for processors in X, Y coords of mesh -! note that local_comm_x has all the processors in a row (X=0:nproc_x-1); -! in other words, local_comm_x has all the processes with the same rank in Y - CALL MPI_Comm_dup( new_local_comm, comdup, ierr ) - IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_dup fails in 20061228 mod') - CALL MPI_Comm_split(comdup,mytask_y,mytask,local_communicator_x,ierr) - IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_split fails for x in 20061228 mod') - CALL MPI_Comm_split(comdup,mytask_x,mytask,local_communicator_y,ierr) - IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_split fails for y in 20061228 mod') -! end 20061228 - CALL wrf_set_dm_communicator ( local_communicator ) #else ntasks = 1 ntasks_x = 1 @@ -213,8 +220,15 @@ SUBROUTINE wrf_dm_initialize mytask = 0 mytask_x = 0 mytask_y = 0 + nest_pes_x = 1 + nest_pes_y = 1 + intercomm_active = .TRUE. + domain_active_this_task = .TRUE. #endif - + CALL nl_set_nproc_x ( 1, ntasks_x ) + CALL nl_set_nproc_y ( 1, ntasks_y ) + WRITE( wrf_err_message , * )'Ntasks in X ',ntasks_x,', ntasks in Y ',ntasks_y + CALL wrf_message( wrf_err_message ) RETURN END SUBROUTINE wrf_dm_initialize @@ -226,7 +240,7 @@ SUBROUTINE get_dm_max_halo_width( id, width ) width = max_halo_width ELSE width = max_halo_width + 3 - ENDIF + END IF RETURN END SUBROUTINE get_dm_max_halo_width @@ -242,7 +256,7 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & sp3y , ep3y , sm3y , em3y , & bdx , bdy ) -#if ( defined(SGIALTIX) && (! defined(MOVE_NESTS) ) ) || ( defined(FUJITSU_FX10) && (! defined(MOVE_NESTS) ) ) +#if ( ( defined(SGIALTIX) || defined(FUJITSU_FX10) || defined(KEEP_INT_AROUND) ) && (! defined(MOVE_NESTS) ) ) USE module_domain, ONLY : domain, head_grid, find_grid_by_id, alloc_space_field #else USE module_domain, ONLY : domain, head_grid, find_grid_by_id @@ -310,7 +324,7 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & ELSE minx = 1 ! normal miny = 1 ! normal - ENDIF + END IF @@ -339,7 +353,7 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & CALL get_dm_max_halo_width( id , thisdomain_max_halo_width ) IF ( id .GT. 1 ) THEN CALL get_dm_max_halo_width( parent%id , parent_max_halo_width ) - ENDIF + END IF CALL compute_memory_dims_rsl_lite ( id, thisdomain_max_halo_width, 0 , bdx, bdy, & ids, ide, jds, jde, kds, kde, & @@ -359,7 +373,7 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & CALL nl_get_parent_grid_ratio( id, parent_grid_ratio ) if ( mod(ime,parent_grid_ratio) .NE. 0 ) ime = ime + parent_grid_ratio - mod(ime,parent_grid_ratio) if ( mod(jme,parent_grid_ratio) .NE. 0 ) jme = jme + parent_grid_ratio - mod(jme,parent_grid_ratio) - ENDIF + END IF SELECT CASE ( model_data_order ) CASE ( DATA_ORDER_ZXY ) @@ -437,7 +451,7 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & CALL wrf_message( TRIM(wrf_err_message) ) WRITE(wrf_err_message,*)'*************************************' CALL wrf_message( TRIM(wrf_err_message) ) - ENDIF + END IF IF ( id .GT. 1 ) THEN @@ -502,28 +516,30 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & ierr = 0 DO i = c_ids, c_ide ni = ( i - i_parent_start ) * parent_grid_ratio + 1 + 1 ; - CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, & +!jm CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, & + CALL task_for_point ( ni, nj, ids, ide, jds, jde, nest_pes_x(id), nest_pes_y(id),Px,Py, & minx, miny, ierr ) IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (a)') IF ( Px .EQ. mytask_x ) THEN c_ipe = i IF ( c_ips .EQ. -1 ) c_ips = i - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF IF (c_ips .EQ. -1 ) THEN c_ipe = -1 c_ips = 0 - ENDIF + END IF c_jps = -1 ni = ( c_ids - i_parent_start ) * parent_grid_ratio + 1 + 1 ; ierr = 0 DO j = c_jds, c_jde nj = ( j - j_parent_start ) * parent_grid_ratio + 1 + 1 ; - CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, & +! CALL task_for_point ( ni, nj, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, & + CALL task_for_point ( ni, nj, ids, ide, jds, jde, nest_pes_x(id), nest_pes_y(id), Px, Py, & minx, miny, ierr ) IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (b)') @@ -531,15 +547,15 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & IF ( Py .EQ. mytask_y ) THEN c_jpe = j IF ( c_jps .EQ. -1 ) c_jps = j - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF IF (c_jps .EQ. -1 ) THEN c_jpe = -1 c_jps = 0 - ENDIF + END IF #if (DA_CORE == 1) IF (c_ipe .EQ. -1 .or. c_jpe .EQ. -1) THEN @@ -547,54 +563,56 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & c_ips = 0 c_jpe = -1 c_jps = 0 - ENDIF + END IF c_kpsx = -1 nj = ( c_jds - j_parent_start ) * parent_grid_ratio + 1 + 1 ; ierr = 0 DO k = c_kds, c_kde - CALL task_for_point ( k, nj, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, & +! CALL task_for_point ( k, nj, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, & + CALL task_for_point ( k, nj, kds, kde, jds, jde, nest_pes_x(id), nest_pes_y(id), Px, Py, & 1, 1, ierr ) IF ( Px .EQ. mytask_x ) THEN c_kpex = k IF ( c_kpsx .EQ. -1 ) c_kpsx = k - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF IF (c_kpsx .EQ. -1 ) THEN c_kpex = -1 c_kpsx = 0 - ENDIF + END IF c_jpsx = -1 k = c_kds ; ierr = 0 DO j = c_jds, c_jde nj = ( j - j_parent_start ) * parent_grid_ratio + 1 + 1 ; - CALL task_for_point ( k, nj, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, & +! CALL task_for_point ( k, nj, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, & + CALL task_for_point ( k, nj, kds, kde, jds, jde, nest_pes_x(id), nest_pes_y(id), Px, Py, & 1, 1, ierr ) IF ( Py .EQ. mytask_y ) THEN c_jpex = j IF ( c_jpsx .EQ. -1 ) c_jpsx = j - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF IF (c_jpsx .EQ. -1 ) THEN c_jpex = -1 c_jpsx = 0 - ENDIF + END IF IF (c_ipex .EQ. -1 .or. c_jpex .EQ. -1) THEN c_ipex = -1 c_ipsx = 0 c_jpex = -1 c_jpsx = 0 - ENDIF + END IF c_kpsy = c_kpsx ! same as above c_kpey = c_kpex ! same as above @@ -604,20 +622,21 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & ierr = 0 DO i = c_ids, c_ide ni = ( i - i_parent_start ) * parent_grid_ratio + 1 + 1 ; - CALL task_for_point ( ni, k, ids, ide, kds, kde, ntasks_y, ntasks_x, Py, Px, & +! CALL task_for_point ( ni, k, ids, ide, kds, kde, ntasks_y, ntasks_x, Py, Px, & + CALL task_for_point ( ni, k, ids, ide, kds, kde, nest_pes_y(id), nest_pes_x(id), Py, Px, & 1, 1, ierr ) ! x and y for proc mesh reversed IF ( Py .EQ. mytask_y ) THEN c_ipey = i IF ( c_ipsy .EQ. -1 ) c_ipsy = i - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF IF (c_ipsy .EQ. -1 ) THEN c_ipey = -1 c_ipsy = 0 - ENDIF + END IF #endif @@ -628,19 +647,20 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & #if (DA_CORE == 1) c_ipsy = c_ipsy - shw #endif - ENDIF - IF ( mytask_x .EQ. ntasks_x-1 ) THEN + END IF +! IF ( mytask_x .EQ. ntasks_x-1 ) THEN + IF ( mytask_x .EQ. nest_pes_x(id)-1 ) THEN c_ipe = c_ipe + shw #if (DA_CORE == 1) c_ipey = c_ipey + shw #endif - ENDIF + END IF c_ims = max( c_ips - max(shw,thisdomain_max_halo_width), c_ids - bdx ) - 1 c_ime = min( c_ipe + max(shw,thisdomain_max_halo_width), c_ide + bdx ) + 1 ELSE c_ims = 0 c_ime = 0 - ENDIF + END IF ! handle j dims @@ -651,20 +671,21 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & #if (DA_CORE == 1) c_jpsx = c_jpsx - shw #endif - ENDIF - IF ( mytask_y .EQ. ntasks_y-1 ) THEN + END IF +! IF ( mytask_y .EQ. ntasks_y-1 ) THEN + IF ( mytask_y .EQ. nest_pes_y(id)-1 ) THEN c_jpe = c_jpe + shw #if (DA_CORE == 1) c_jpex = c_jpex + shw #endif - ENDIF + END IF c_jms = max( c_jps - max(shw,thisdomain_max_halo_width), c_jds - bdx ) - 1 c_jme = min( c_jpe + max(shw,thisdomain_max_halo_width), c_jde + bdx ) + 1 ! handle k dims ELSE c_jms = 0 c_jme = 0 - ENDIF + END IF c_kps = 1 c_kpe = c_kde c_kms = 1 @@ -683,11 +704,11 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & IF ( c_kpsx .EQ. 0 .AND. c_kpex .EQ. -1 ) THEN c_kmsx = 0 c_kmex = 0 - ENDIF + END IF IF ( c_kpsy .EQ. 0 .AND. c_kpey .EQ. -1 ) THEN c_kmsy = 0 c_kmey = 0 - ENDIF + END IF c_imsx = c_ids c_imex = c_ide c_ipsx = c_imsx @@ -699,7 +720,7 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & ELSE c_imsy = c_ipsy c_imey = c_ipey - ENDIF + END IF c_jmsx = c_jpsx c_jmex = c_jpex @@ -712,7 +733,7 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & ELSE c_jpsy = c_jmsy c_jpey = c_jmey - ENDIF + END IF c_sm1x = c_imsx c_em1x = c_imex @@ -798,7 +819,7 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & NULLIFY( intermediate_grid%sibling ) DO i = 1, max_nests NULLIFY( intermediate_grid%nests(i)%ptr ) - ENDDO + END DO NULLIFY (intermediate_grid%next) NULLIFY (intermediate_grid%same_level) NULLIFY (intermediate_grid%i_start) @@ -811,6 +832,9 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & intermediate_grid%num_parents = 1 intermediate_grid%max_tiles = 0 intermediate_grid%num_tiles_spec = 0 +#if ( EM_CORE == 1 && DA_CORE != 1 ) + intermediate_grid%active_this_task = .true. +#endif CALL find_grid_by_id ( id, head_grid, nest_grid ) nest_grid%intermediate_grid => intermediate_grid ! nest grid now has a pointer to this baby @@ -871,9 +895,10 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & intermediate_grid%ep33y = c_ep3y #endif -#if ( defined(SGIALTIX) && (! defined(MOVE_NESTS) ) ) || ( defined(FUJITSU_FX10) && (! defined(MOVE_NESTS) ) ) +#if ( ( defined(SGIALTIX) || defined(FUJITSU_FX10) || defined(KEEP_INT_AROUND) ) && (! defined(MOVE_NESTS) ) ) ! allocate space for the intermediate domain - CALL alloc_space_field ( intermediate_grid, intermediate_grid%id , 1, 2 , .TRUE., & ! use same id as nest +! CALL alloc_space_field ( intermediate_grid, intermediate_grid%id , 1, 2 , .TRUE., intercomm_active( intermediate_grid%id ), & ! use same id as nest + CALL alloc_space_field ( intermediate_grid, intermediate_grid%id , 1, 2 , .TRUE., nest_grid%active_this_task, & ! use same id as nest c_sd1, c_ed1, c_sd2, c_ed2, c_sd3, c_ed3, & c_sm1, c_em1, c_sm2, c_em2, c_sm3, c_em3, & c_sp1, c_ep1, c_sp2, c_ep2, c_sp3, c_ep3, & @@ -906,7 +931,7 @@ SUBROUTINE patch_domain_rsl_lite( id , parent, parent_id, & intermediate_grid%dx = parent%dx intermediate_grid%dy = parent%dy intermediate_grid%dt = parent%dt - ENDIF + END IF RETURN END SUBROUTINE patch_domain_rsl_lite @@ -943,42 +968,45 @@ SUBROUTINE compute_memory_dims_rsl_lite ( & j = jds ierr = 0 DO i = ids, ide - CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, & +! CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, & + CALL task_for_point ( i, j, ids, ide, jds, jde, nest_pes_x(id), nest_pes_y(id), Px, Py, & minx, miny, ierr ) IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (c)') IF ( Px .EQ. mytask_x ) THEN ipe = i IF ( ips .EQ. -1 ) ips = i - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF ! handle setting the memory dimensions where there are no X elements assigned to this proc IF (ips .EQ. -1 ) THEN ipe = -1 ips = 0 - ENDIF + END IF + jps = -1 i = ids ierr = 0 DO j = jds, jde - CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, & +! CALL task_for_point ( i, j, ids, ide, jds, jde, ntasks_x, ntasks_y, Px, Py, & + CALL task_for_point ( i, j, ids, ide, jds, jde, nest_pes_x(id), nest_pes_y(id), Px, Py, & minx, miny, ierr ) IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (d)') IF ( Py .EQ. mytask_y ) THEN jpe = j IF ( jps .EQ. -1 ) jps = j - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF ! handle setting the memory dimensions where there are no Y elements assigned to this proc IF (jps .EQ. -1 ) THEN jpe = -1 jps = 0 - ENDIF + END IF !begin: wig; 12-Mar-2008 ! This appears redundant with the conditionals above, but we get cases with only @@ -989,7 +1017,7 @@ SUBROUTINE compute_memory_dims_rsl_lite ( & ips = 0 jpe = -1 jps = 0 - ENDIF + END IF !end: wig; 12-Mar-2008 ! @@ -1035,55 +1063,57 @@ SUBROUTINE compute_memory_dims_rsl_lite ( & j = jds ; ierr = 0 DO k = kds, kde - CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, & +! CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, & + CALL task_for_point ( k, j, kds, kde, jds, jde, nest_pes_x(id), nest_pes_y(id), Px, Py, & minx, miny, ierr ) IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (e)') IF ( Px .EQ. mytask_x ) THEN kpex = k IF ( kpsx .EQ. -1 ) kpsx = k - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF ! handle case where no levels are assigned to this process ! no iterations. Do same for I and J. Need to handle memory alloc below. IF (kpsx .EQ. -1 ) THEN kpex = -1 kpsx = 0 - ENDIF + END IF jpsx = -1 k = kds ; ierr = 0 DO j = jds, jde - CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, & +! CALL task_for_point ( k, j, kds, kde, jds, jde, ntasks_x, ntasks_y, Px, Py, & + CALL task_for_point ( k, j, kds, kde, jds, jde, nest_pes_x(id), nest_pes_y(id), Px, Py, & minx, miny, ierr ) IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (f)') IF ( Py .EQ. mytask_y ) THEN jpex = j IF ( jpsx .EQ. -1 ) jpsx = j - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF IF (jpsx .EQ. -1 ) THEN jpex = -1 jpsx = 0 - ENDIF + END IF !begin: wig; 12-Mar-2008 ! This appears redundant with the conditionals above, but we get cases with only ! one of the directions being set to "missing" when turning off extra processors. ! This may break the handling of setting only one of nproc_x or nproc_y via the namelist. - IF (ipex .EQ. -1 .or. jpex .EQ. -1) THEN + IF (jpex .EQ. -1) THEN ipex = -1 ipsx = 0 jpex = -1 jpsx = 0 - ENDIF + END IF !end: wig; 12-Mar-2008 ! XzYx decomposition (note, x grid dim is decomposed over Y processor dim) @@ -1095,21 +1125,22 @@ SUBROUTINE compute_memory_dims_rsl_lite ( & k = kds ; ierr = 0 DO i = ids, ide - CALL task_for_point ( i, k, ids, ide, kds, kde, ntasks_y, ntasks_x, Py, Px, & +! CALL task_for_point ( i, k, ids, ide, kds, kde, ntasks_y, ntasks_x, Py, Px, & + CALL task_for_point ( i, k, ids, ide, kds, kde, nest_pes_y(id), nest_pes_x(id), Py, Px, & miny, minx, ierr ) IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (g)') IF ( Py .EQ. mytask_y ) THEN ipey = i IF ( ipsy .EQ. -1 ) ipsy = i - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF IF (ipsy .EQ. -1 ) THEN ipey = -1 ipsy = 0 - ENDIF + END IF #else @@ -1120,32 +1151,36 @@ SUBROUTINE compute_memory_dims_rsl_lite ( & j = jds ierr = 0 DO i = ids, ide-1 - CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, & +!jm CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, & + CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, nest_pes_x(id), nest_pes_y(id), Px, Py, & minx, miny, ierr ) IF ( Px .EQ. mytask_x ) THEN ipe = i - IF ( Px .EQ. ntasks_x-1 ) ipe = ipe + 1 +! IF ( Px .EQ. ntasks_x-1 ) ipe = ipe + 1 + IF ( Px .EQ. nest_pes_x(id)-1 ) ipe = ipe + 1 IF ( ips .EQ. -1 ) ips = i - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF jps = -1 i = ids ; ierr = 0 DO j = jds, jde-1 - CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, & +!jm CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, ntasks_x, ntasks_y, Px, Py, & + CALL task_for_point ( i, j, ids, ide-1, jds, jde-1, nest_pes_x(id), nest_pes_y(id), Px, Py, & minx, miny, ierr ) IF ( Py .EQ. mytask_y ) THEN jpe = j - IF ( Py .EQ. ntasks_y-1 ) jpe = jpe + 1 +! IF ( Py .EQ. ntasks_y-1 ) jpe = jpe + 1 + IF ( Py .EQ. nest_pes_y(id)-1 ) jpe = jpe + 1 IF ( jps .EQ. -1 ) jps = j - ENDIF - ENDDO + END IF + END DO IF ( ierr .NE. 0 ) THEN CALL tfp_message(__FILE__,__LINE__) - ENDIF + END IF #endif ! extend the patch dimensions out shw along edges of domain @@ -1153,20 +1188,22 @@ SUBROUTINE compute_memory_dims_rsl_lite ( & IF ( mytask_x .EQ. 0 ) THEN ips = ips - shw ipsy = ipsy - shw - ENDIF - IF ( mytask_x .EQ. ntasks_x-1 ) THEN + END IF +! IF ( mytask_x .EQ. ntasks_x-1 ) THEN + IF ( mytask_x .EQ. nest_pes_x(id)-1 ) THEN ipe = ipe + shw ipey = ipey + shw - ENDIF + END IF IF ( mytask_y .EQ. 0 ) THEN jps = jps - shw jpsx = jpsx - shw - ENDIF - IF ( mytask_y .EQ. ntasks_y-1 ) THEN + END IF +! IF ( mytask_y .EQ. ntasks_y-1 ) THEN + IF ( mytask_y .EQ. nest_pes_y(id)-1 ) THEN jpe = jpe + shw jpex = jpex + shw - ENDIF - ENDIF !wig; 11-Mar-2008 + END IF + END IF !wig; 11-Mar-2008 kps = 1 kpe = kde-kds+1 @@ -1182,11 +1219,11 @@ SUBROUTINE compute_memory_dims_rsl_lite ( & IF ( kpsx .EQ. 0 .AND. kpex .EQ. -1 ) THEN kmsx = 0 kmex = 0 - ENDIF + END IF IF ( kpsy .EQ. 0 .AND. kpey .EQ. -1 ) THEN kmsy = 0 kmey = 0 - ENDIF + END IF IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN ims = 0 @@ -1199,7 +1236,7 @@ SUBROUTINE compute_memory_dims_rsl_lite ( & ims = ips-CHUNK ime = ime + (CHUNK-mod(ime-ims+1,CHUNK)) #endif - ENDIF + END IF imsx = ids imex = ide ipsx = imsx @@ -1211,7 +1248,7 @@ SUBROUTINE compute_memory_dims_rsl_lite ( & ELSE imsy = ipsy imey = ipey - ENDIF + END IF IF ( (jps .EQ. 0 .AND. jpe .EQ. -1) .OR. (ips .EQ. 0 .AND. ipe .EQ. -1) ) THEN jms = 0 @@ -1219,7 +1256,7 @@ SUBROUTINE compute_memory_dims_rsl_lite ( & ELSE jms = max( jps - max(shw,maxhalowidth), jds - bdy ) - 1 jme = min( jpe + max(shw,maxhalowidth), jde + bdy ) + 1 - ENDIF + END IF jmsx = jpsx jmex = jpex jmsy = jds @@ -1228,10 +1265,12 @@ SUBROUTINE compute_memory_dims_rsl_lite ( & IF ( jpsx .EQ. 0 .AND. jpex .EQ. -1 ) THEN jmsx = 0 jmex = 0 + jpsy = 0 + jpey = -1 ELSE jpsy = jmsy jpey = jmey - ENDIF + END IF END SUBROUTINE compute_memory_dims_rsl_lite @@ -1250,7 +1289,7 @@ INTEGER function getrealmpitype() getrealmpitype = MPI_DOUBLE_PRECISION ELSE CALL wrf_error_fatal ( 'RWORDSIZE or DWORDSIZE does not match any MPI type' ) - ENDIF + END IF #else ! required dummy initialization for function that is never called getrealmpitype = 1 @@ -1263,8 +1302,9 @@ REAL FUNCTION wrf_dm_max_real ( inval ) #ifndef STUBMPI INCLUDE 'mpif.h' REAL inval, retval - INTEGER ierr - CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MAX, local_communicator, ierr ) + INTEGER comm,ierr + CALL wrf_get_dm_communicator(comm) + CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MAX, comm, ierr ) wrf_dm_max_real = retval #else REAL inval @@ -1277,8 +1317,9 @@ REAL FUNCTION wrf_dm_min_real ( inval ) #ifndef STUBMPI INCLUDE 'mpif.h' REAL inval, retval - INTEGER ierr - CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MIN, local_communicator, ierr ) + INTEGER comm,ierr + CALL wrf_get_dm_communicator(comm) + CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_MIN, comm, ierr ) wrf_dm_min_real = retval #else REAL inval @@ -1293,8 +1334,9 @@ SUBROUTINE wrf_dm_min_reals ( inval, retval, n ) REAL retval(*) #ifndef STUBMPI INCLUDE 'mpif.h' - INTEGER ierr - CALL mpi_allreduce ( inval, retval , n, getrealmpitype(), MPI_MIN, local_communicator, ierr ) + INTEGER comm,ierr + CALL wrf_get_dm_communicator(comm) + CALL mpi_allreduce ( inval, retval , n, getrealmpitype(), MPI_MIN, comm, ierr ) #else retval(1:n) = inval(1:n) #endif @@ -1307,8 +1349,9 @@ FUNCTION wrf_dm_sum_real8 ( inval ) #ifndef STUBMPI INCLUDE 'mpif.h' REAL*8 inval, retval, wrf_dm_sum_real8 - INTEGER ierr - CALL mpi_allreduce ( inval, retval , 1, MPI_REAL8, MPI_SUM, local_communicator, ierr ) + INTEGER comm,ierr + CALL wrf_get_dm_communicator(comm) + CALL mpi_allreduce ( inval, retval , 1, MPI_REAL8, MPI_SUM, comm, ierr ) wrf_dm_sum_real8 = retval #else REAL*8 wrf_dm_sum_real8,inval @@ -1321,8 +1364,9 @@ REAL FUNCTION wrf_dm_sum_real ( inval ) #ifndef STUBMPI INCLUDE 'mpif.h' REAL inval, retval - INTEGER ierr - CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_SUM, local_communicator, ierr ) + INTEGER comm,ierr + CALL wrf_get_dm_communicator(comm) + CALL mpi_allreduce ( inval, retval , 1, getrealmpitype(), MPI_SUM, comm, ierr ) wrf_dm_sum_real = retval #else REAL inval @@ -1336,8 +1380,9 @@ SUBROUTINE wrf_dm_sum_reals (inval, retval) REAL, INTENT(OUT) :: retval(:) #ifndef STUBMPI INCLUDE 'mpif.h' - INTEGER ierr - CALL mpi_allreduce ( inval, retval, SIZE(inval), getrealmpitype(), MPI_SUM, local_communicator, ierr ) + INTEGER comm,ierr + CALL wrf_get_dm_communicator(comm) + CALL mpi_allreduce ( inval, retval, SIZE(inval), getrealmpitype(), MPI_SUM, comm, ierr ) #else retval = inval #endif @@ -1348,8 +1393,9 @@ INTEGER FUNCTION wrf_dm_sum_integer ( inval ) #ifndef STUBMPI INCLUDE 'mpif.h' INTEGER inval, retval - INTEGER ierr - CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_SUM, local_communicator, ierr ) + INTEGER comm,ierr + CALL wrf_get_dm_communicator(comm) + CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_SUM, comm, ierr ) wrf_dm_sum_integer = retval #else INTEGER inval @@ -1363,82 +1409,67 @@ SUBROUTINE wrf_dm_sum_integers (inval, retval) INTEGER, INTENT(OUT) :: retval(:) #ifndef STUBMPI INCLUDE 'mpif.h' - INTEGER ierr - CALL mpi_allreduce ( inval, retval, SIZE(inval), MPI_INTEGER, MPI_SUM, local_communicator, ierr ) + INTEGER comm,ierr + CALL wrf_get_dm_communicator(comm) + CALL mpi_allreduce ( inval, retval, SIZE(inval), MPI_INTEGER, MPI_SUM, comm, ierr ) #else retval = inval #endif END SUBROUTINE wrf_dm_sum_integers -#ifdef HWRF +#if ( HWRF == 1 ) SUBROUTINE wrf_dm_minloc_real ( val, lat, lon, z, idex, jdex ) - IMPLICIT NONE #ifndef STUBMPI - INCLUDE 'mpif.h' + use mpi + IMPLICIT NONE REAL val, lat, lon, z - INTEGER idex, jdex, ierr - INTEGER dex(2) - REAL vll(4) - INTEGER dex_all (2,ntasks) - REAL vll_all(4,ntasks) - INTEGER i - - vll= (/ val, lat, lon, z /) - - dex(1) = idex ; dex(2) = jdex - CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr ) - CALL mpi_allgather ( vll, 4, getrealmpitype(), vll_all , 4, getrealmpitype(), local_communicator, ierr ) - val = vll_all(1,1) ; lat = vll_all(2,1) - lon = vll_all(3,1) ; z = vll_all(4,1) - idex = dex_all(1,1) ; jdex = dex_all(2,1) - DO i = 2, ntasks - IF ( vll_all(1,i) .LT. val ) THEN - val = vll_all(1,i) - lat = vll_all(2,i) - lon = vll_all(3,i) - z = vll_all(4,i) - idex = dex_all(1,i) - jdex = dex_all(2,i) - ENDIF - ENDDO + INTEGER idex, jdex, ierr, mrank, comm + REAL inreduce(2), outreduce(2), bcast(5) + + inreduce=(/ val, real(mytask) /) + CALL wrf_get_dm_communicator(comm) + call MPI_Allreduce(inreduce,outreduce,1,MPI_2REAL,MPI_MINLOC,& + comm,ierr) + val=outreduce(1) + mrank=outreduce(2) + bcast=(/ lat,lon,z,real(idex),real(jdex) /) + call MPI_Bcast(bcast,5,MPI_REAL,mrank,comm,ierr) + lat=bcast(1) + lon=bcast(2) + z=bcast(3) + idex=bcast(4) + jdex=bcast(5) #else + IMPLICIT NONE REAL val,lat,lon,z - INTEGER idex, jdex, ierr + INTEGER idex, jdex #endif END SUBROUTINE wrf_dm_minloc_real SUBROUTINE wrf_dm_maxloc_real ( val, lat, lon, z, idex, jdex ) - IMPLICIT NONE #ifndef STUBMPI - INCLUDE 'mpif.h' + use mpi + IMPLICIT NONE REAL val, lat, lon, z - INTEGER idex, jdex, ierr - INTEGER dex(2) - REAL vll(4) - INTEGER dex_all (2,ntasks) - REAL vll_all(4,ntasks) - INTEGER i - - vll= (/ val, lat, lon, z /) - - dex(1) = idex ; dex(2) = jdex - CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr ) - CALL mpi_allgather ( vll, 4, getrealmpitype(), vll_all , 4, getrealmpitype(), local_communicator, ierr ) - val = vll_all(1,1) ; lat = vll_all(2,1) - lon = vll_all(3,1) ; z = vll_all(4,1) - idex = dex_all(1,1) ; jdex = dex_all(2,1) - DO i = 2, ntasks - IF ( vll_all(1,i) .GT. val ) THEN - val = vll_all(1,i) - lat = vll_all(2,i) - lon = vll_all(3,i) - z = vll_all(4,i) - idex = dex_all(1,i) - jdex = dex_all(2,i) - ENDIF - ENDDO + INTEGER idex, jdex, ierr, mrank, comm + REAL inreduce(2), outreduce(2), bcast(5) + + inreduce=(/ val, real(mytask) /) + CALL wrf_get_dm_communicator(comm) + call MPI_Allreduce(inreduce,outreduce,1,MPI_2REAL,MPI_MAXLOC,& + comm,ierr) + val=outreduce(1) + mrank=outreduce(2) + bcast=(/ lat,lon,z,real(idex),real(jdex) /) + call MPI_Bcast(bcast,5,MPI_REAL,mrank,comm,ierr) + lat=bcast(1) + lon=bcast(2) + z=bcast(3) + idex=bcast(4) + jdex=bcast(5) #else + IMPLICIT NONE REAL val,lat,lon,z - INTEGER idex, jdex, ierr + INTEGER idex, jdex #endif END SUBROUTINE wrf_dm_maxloc_real #endif @@ -1448,8 +1479,9 @@ INTEGER FUNCTION wrf_dm_bxor_integer ( inval ) #ifndef STUBMPI INCLUDE 'mpif.h' INTEGER inval, retval - INTEGER ierr - CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_BXOR, local_communicator, ierr ) + INTEGER comm, ierr + CALL wrf_get_dm_communicator(comm) + CALL mpi_allreduce ( inval, retval , 1, MPI_INTEGER, MPI_BXOR, comm, ierr ) wrf_dm_bxor_integer = retval #else INTEGER inval @@ -1458,201 +1490,262 @@ INTEGER FUNCTION wrf_dm_bxor_integer ( inval ) END FUNCTION wrf_dm_bxor_integer SUBROUTINE wrf_dm_maxval_real ( val, idex, jdex ) +# ifndef STUBMPI + use mpi IMPLICIT NONE -#ifndef STUBMPI - INCLUDE 'mpif.h' - REAL val, val_all( ntasks ) + REAL val + INTEGER :: idex, jdex, i, comm + INTEGER :: bcast(2),mrank + REAL :: inreduce(2),outreduce(2) + + inreduce=(/ val, real(mytask) /) + bcast=(/ idex,jdex /) + CALL wrf_get_dm_communicator(comm) + call MPI_Allreduce(inreduce,outreduce,1,MPI_2REAL,& + MPI_MAXLOC,comm,i) + mrank=outreduce(2) + val=outreduce(1) + call MPI_Bcast(bcast,2,MPI_REAL,mrank,comm,i) + idex=bcast(1) + jdex=bcast(2) +# else + IMPLICIT NONE + REAL val INTEGER idex, jdex, ierr - INTEGER dex(2) - INTEGER dex_all (2,ntasks) - INTEGER i +# endif + END SUBROUTINE wrf_dm_maxval_real - dex(1) = idex ; dex(2) = jdex - CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr ) - CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), local_communicator, ierr ) - val = val_all(1) - idex = dex_all(1,1) ; jdex = dex_all(2,1) - DO i = 2, ntasks - IF ( val_all(i) .GT. val ) THEN - val = val_all(i) - idex = dex_all(1,i) - jdex = dex_all(2,i) - ENDIF - ENDDO -#else + SUBROUTINE wrf_dm_minval_real ( val, idex, jdex ) +# ifndef STUBMPI + use mpi + IMPLICIT NONE REAL val - INTEGER idex, jdex, ierr -#endif - END SUBROUTINE wrf_dm_maxval_real + INTEGER :: idex, jdex, i, comm + INTEGER :: bcast(2),mrank + REAL :: inreduce(2),outreduce(2) + + inreduce=(/ val, real(mytask) /) + bcast=(/ idex,jdex /) + CALL wrf_get_dm_communicator(comm) + call MPI_Allreduce(inreduce,outreduce,1,MPI_2REAL,& + MPI_MINLOC,comm,i) + mrank=outreduce(2) + val=outreduce(1) + call MPI_Bcast(bcast,2,MPI_REAL,mrank,comm,i) + idex=bcast(1) + jdex=bcast(2) +# else + IMPLICIT NONE + REAL val + INTEGER idex, jdex +# endif + END SUBROUTINE wrf_dm_minval_real #ifndef PROMOTE_FLOAT SUBROUTINE wrf_dm_maxval_doubleprecision ( val, idex, jdex ) - IMPLICIT NONE # ifndef STUBMPI - INCLUDE 'mpif.h' - DOUBLE PRECISION val, val_all( ntasks ) + use mpi + IMPLICIT NONE + DOUBLE PRECISION val + INTEGER :: idex, jdex, i, comm + INTEGER :: bcast(2),mrank + DOUBLE PRECISION :: inreduce(2),outreduce(2) + + inreduce=(/ val, dble(mytask) /) + bcast=(/ idex,jdex /) + CALL wrf_get_dm_communicator(comm) + call MPI_Allreduce(inreduce,outreduce,1,MPI_2DOUBLE_PRECISION,& + MPI_MAXLOC,comm,i) + mrank=outreduce(2) + val=outreduce(1) + call MPI_Bcast(bcast,2,MPI_DOUBLE_PRECISION,mrank,comm,i) + idex=bcast(1) + jdex=bcast(2) +# else + IMPLICIT NONE + DOUBLE PRECISION val INTEGER idex, jdex, ierr - INTEGER dex(2) - INTEGER dex_all (2,ntasks) - INTEGER i +# endif + END SUBROUTINE wrf_dm_maxval_doubleprecision - dex(1) = idex ; dex(2) = jdex - CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr ) - CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, local_communicator, ierr ) - val = val_all(1) - idex = dex_all(1,1) ; jdex = dex_all(2,1) - DO i = 2, ntasks - IF ( val_all(i) .GT. val ) THEN - val = val_all(i) - idex = dex_all(1,i) - jdex = dex_all(2,i) - ENDIF - ENDDO + SUBROUTINE wrf_dm_minval_doubleprecision ( val, idex, jdex ) +# ifndef STUBMPI + use mpi + IMPLICIT NONE + DOUBLE PRECISION val + INTEGER :: idex, jdex, i, comm + INTEGER :: bcast(2),mrank + DOUBLE PRECISION :: inreduce(2),outreduce(2) + + inreduce=(/ val, dble(mytask) /) + bcast=(/ idex,jdex /) + CALL wrf_get_dm_communicator(comm) + call MPI_Allreduce(inreduce,outreduce,1,MPI_2DOUBLE_PRECISION,& + MPI_MINLOC,comm,i) + mrank=outreduce(2) + val=outreduce(1) + call MPI_Bcast(bcast,2,MPI_DOUBLE_PRECISION,mrank,comm,i) + idex=bcast(1) + jdex=bcast(2) # else + IMPLICIT NONE DOUBLE PRECISION val INTEGER idex, jdex, ierr # endif - END SUBROUTINE wrf_dm_maxval_doubleprecision + END SUBROUTINE wrf_dm_minval_doubleprecision #endif SUBROUTINE wrf_dm_maxval_integer ( val, idex, jdex ) +# ifndef STUBMPI + use mpi IMPLICIT NONE -#ifndef STUBMPI - INCLUDE 'mpif.h' - INTEGER val, val_all( ntasks ) - INTEGER idex, jdex, ierr - INTEGER dex(2) - INTEGER dex_all (2,ntasks) - INTEGER i - - dex(1) = idex ; dex(2) = jdex - CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, local_communicator, ierr ) - CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, local_communicator, ierr ) - val = val_all(1) - idex = dex_all(1,1) ; jdex = dex_all(2,1) - DO i = 2, ntasks - IF ( val_all(i) .GT. val ) THEN - val = val_all(i) - idex = dex_all(1,i) - jdex = dex_all(2,i) - ENDIF - ENDDO -#else INTEGER val - INTEGER idex, jdex -#endif - END SUBROUTINE wrf_dm_maxval_integer - -! For HWRF some additional computation is required. This is gopal's doing - - SUBROUTINE wrf_dm_minval_real ( val, idex, jdex ) + INTEGER :: idex, jdex, i, comm + INTEGER :: bcast(2),mrank + INTEGER :: inreduce(2),outreduce(2) + + inreduce=(/ val, mytask /) + bcast=(/ idex,jdex /) + CALL wrf_get_dm_communicator(comm) + call MPI_Allreduce(inreduce,outreduce,1,MPI_2INTEGER,& + MPI_MAXLOC,comm,i) + mrank=outreduce(2) + val=outreduce(1) + call MPI_Bcast(bcast,2,MPI_INTEGER,mrank,comm,i) + idex=bcast(1) + jdex=bcast(2) +# else IMPLICIT NONE - REAL val, val_all( ntasks ) + INTEGER val INTEGER idex, jdex, ierr - INTEGER dex(2) - INTEGER dex_all (2,ntasks) -! -! Collective operation. Each processor calls passing a local value and its index; on return -! all processors are passed back the maximum of all values passed and its index. -! -! - INTEGER i, comm -#ifndef STUBMPI - INCLUDE 'mpif.h' - - CALL wrf_get_dm_communicator ( comm ) - dex(1) = idex ; dex(2) = jdex - CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr ) - CALL mpi_allgather ( val, 1, MPI_REAL, val_all , 1, MPI_REAL, comm, ierr ) - val = val_all(1) - idex = dex_all(1,1) ; jdex = dex_all(2,1) - DO i = 2, ntasks - IF ( val_all(i) .LT. val ) THEN - val = val_all(i) - idex = dex_all(1,i) - jdex = dex_all(2,i) - ENDIF - ENDDO -#endif - END SUBROUTINE wrf_dm_minval_real +# endif + END SUBROUTINE wrf_dm_maxval_integer -#ifndef PROMOTE_FLOAT - SUBROUTINE wrf_dm_minval_doubleprecision ( val, idex, jdex ) + SUBROUTINE wrf_dm_minval_integer ( val, idex, jdex ) +# ifndef STUBMPI + use mpi IMPLICIT NONE - DOUBLE PRECISION val, val_all( ntasks ) + INTEGER val + INTEGER :: idex, jdex, i, comm + INTEGER :: bcast(2),mrank + INTEGER :: inreduce(2),outreduce(2) + + inreduce=(/ val, mytask /) + bcast=(/ idex,jdex /) + CALL wrf_get_dm_communicator(comm) + call MPI_Allreduce(inreduce,outreduce,1,MPI_2INTEGER,& + MPI_MINLOC,comm,i) + mrank=outreduce(2) + val=outreduce(1) + call MPI_Bcast(bcast,2,MPI_INTEGER,mrank,comm,i) + idex=bcast(1) + jdex=bcast(2) +# else + IMPLICIT NONE + INTEGER val INTEGER idex, jdex, ierr - INTEGER dex(2) - INTEGER dex_all (2,ntasks) -! -! Collective operation. Each processor calls passing a local value and its index; on return -! all processors are passed back the maximum of all values passed and its index. -! -! - INTEGER i, comm -#ifndef STUBMPI - INCLUDE 'mpif.h' - - CALL wrf_get_dm_communicator ( comm ) - dex(1) = idex ; dex(2) = jdex - CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr ) - CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr ) - val = val_all(1) - idex = dex_all(1,1) ; jdex = dex_all(2,1) - DO i = 2, ntasks - IF ( val_all(i) .LT. val ) THEN - val = val_all(i) - idex = dex_all(1,i) - jdex = dex_all(2,i) - ENDIF - ENDDO -#endif - END SUBROUTINE wrf_dm_minval_doubleprecision -#endif +# endif + END SUBROUTINE wrf_dm_minval_integer - SUBROUTINE wrf_dm_minval_integer ( val, idex, jdex ) + SUBROUTINE hwrf_coupler_init +#if ( HWRF == 1 ) +# ifndef STUBMPI IMPLICIT NONE - INTEGER val, val_all( ntasks ) - INTEGER idex, jdex, ierr - INTEGER dex(2) - INTEGER dex_all (2,ntasks) -! -! Collective operation. Each processor calls passing a local value and its index; on return -! all processors are passed back the maximum of all values passed and its index. -! -! - INTEGER i, comm -#ifndef STUBMPI INCLUDE 'mpif.h' - - CALL wrf_get_dm_communicator ( comm ) - dex(1) = idex ; dex(2) = jdex - CALL mpi_allgather ( dex, 2, MPI_INTEGER, dex_all , 2, MPI_INTEGER, comm, ierr ) - CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr ) - val = val_all(1) - idex = dex_all(1,1) ; jdex = dex_all(2,1) - DO i = 2, ntasks - IF ( val_all(i) .LT. val ) THEN - val = val_all(i) - idex = dex_all(1,i) - jdex = dex_all(2,i) - ENDIF - ENDDO + LOGICAL mpi_inited + INTEGER mpi_comm_here,ierr + CALL MPI_INITIALIZED( mpi_inited, ierr ) + IF ( .NOT. mpi_inited ) THEN + IF ( coupler_on ) THEN + CALL cpl_init( mpi_comm_here ) + ELSE + CALL mpi_init ( ierr ) + mpi_comm_here = MPI_COMM_WORLD + END IF + CALL atm_cmp_start( mpi_comm_here ) + CALL wrf_set_dm_communicator( mpi_comm_here ) + CALL wrf_termio_dup( mpi_comm_here ) + END IF + RETURN +# endif #endif - END SUBROUTINE wrf_dm_minval_integer ! End of gopal's doing + END SUBROUTINE hwrf_coupler_init SUBROUTINE split_communicator #ifndef STUBMPI IMPLICIT NONE INCLUDE 'mpif.h' LOGICAL mpi_inited - INTEGER mpi_comm_here, mpi_comm_local, comdup, mytask, ntasks, ierr, io_status +! INTEGER mpi_comm_here, mpi_comm_local, comdup, comdup2, origmytask, mytask, ntasks, ierr, io_status + INTEGER mpi_comm_here, mpi_comm_local, comdup, comdup2, origmytask, ierr, io_status + INTEGER mpi_comm_me_and_mom + INTEGER coords(3) + INTEGER mytask_local,ntasks_local,num_compute_tasks # if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT) INTEGER thread_support_provided, thread_support_requested -#endif - INTEGER i, j - INTEGER, ALLOCATABLE :: icolor(:) - INTEGER tasks_per_split - NAMELIST /namelist_split/ tasks_per_split +# endif + INTEGER i, j, k, x, y, n_x, n_y + INTEGER iii + INTEGER, ALLOCATABLE :: icolor(:),icolor2(:),idomain(:) + INTEGER comm_id +! +! Communicator definition Domains +! +! 6 pe Example Comm PEs (1) +! COMM_WORLD 0 1 2 3 4 5 / \ +! 1 0 1 2 3 4 5 (2) (3) +! 2 0 1 | +! 3 0 1 2 3 (4) +! 4 0 1 +! +! Notes: 1. No requirement that any communicator be all tasks +! 2. A task may be a member of an arbitrary number +! of local communicators (But you may not want to do this) +! +! +! Namelist Split Settings (for 3 comms, 4 domains) +! Revised namelist semantics -- no need for binding nests to separately defined communicators +! +! (domain_id) 1 2 3 4 +! parent_id - 1 1 2 +! comm_start 0 0 2 0 +! nest_pes_x 2 1 2 1 +! nest_pes_y 3 2 2 2 +! +!! superceded +!! Namelist Split Settings (for 3 comms, 4 domains) +!! (comm_id) 1 2 3 ... +!! comm_start 0 0 2 +!! comm_pes_x 2 1 2 +!! comm_pes_y 3 2 2 +!! +!! Domain definitions +!! (domain_id) 1 2 3 4 +!! parent_id - 1 1 2 +!! comm_domain 1 2 3 2 +!! * nest_pes_x 2 1 2 1 +!! * nest_pes_y 3 2 2 2 +!! +!! [* nest_pes_x is comm_pes_x(comm_domain(domain_id))] +! + + INTEGER dims(3) +! for parallel nesting, 201408, jm + INTEGER :: id + INTEGER :: intercomm + INTEGER :: domain_id,par_id,nest_id,kid_id + INTEGER :: mytask_me_and_mom, ntasks_me_and_mom, remote_leader + LOGICAL :: inthisone + LOGICAL :: mytask_is_nest, mytask_is_par,isperiodic(3) +! for new quilting + LOGICAL :: quilting_is_turned_off + +!!!!! needed to sneak-peek the registry to get parent_id +! define as temporaries +#include "namelist_defines.inc" + +! Statements that specify the namelists +#include "namelist_statements.inc" CALL MPI_INITIALIZED( mpi_inited, ierr ) IF ( .NOT. mpi_inited ) THEN @@ -1661,7 +1754,7 @@ SUBROUTINE split_communicator CALL mpi_init_thread ( thread_support_requested, thread_support_provided, ierr ) IF ( thread_support_provided .lt. thread_support_requested ) THEN CALL WRF_ERROR_FATAL( "failed to initialize MPI thread support") - ENDIF + END IF mpi_comm_here = MPI_COMM_WORLD # else #if ( DA_CORE != 1 ) @@ -1672,50 +1765,356 @@ SUBROUTINE split_communicator CALL mpi_init ( ierr ) mpi_comm_here = MPI_COMM_WORLD #if ( DA_CORE != 1 ) - ENDIF + END IF #endif # endif -#ifdef HWRF - CALL atm_cmp_start( mpi_comm_here ) ! atmospheric side of HWRF coupler will split MPI_COMM_WORLD and return communicator as argument +#if ( HWRF == 1 ) +!!!!! jm 20150807 note that for HWRF, this will not be called here because of the call to hwrf_coupler_init (defined above) in init_modules +!!!! CALL atm_cmp_start( mpi_comm_here ) ! atmospheric side of HWRF coupler will split MPI_COMM_WORLD and return communicator as argument #endif CALL wrf_set_dm_communicator( mpi_comm_here ) - ENDIF + CALL wrf_termio_dup( mpi_comm_here ) + END IF +! this should have been reset by init_module_wrf_quilt to be just the compute tasks CALL wrf_get_dm_communicator( mpi_comm_here ) - CALL wrf_termio_dup( mpi_comm_here ) - CALL MPI_Comm_rank ( mpi_comm_here, mytask, ierr ) ; - CALL mpi_comm_size ( mpi_comm_here, ntasks, ierr ) ; + CALL MPI_Comm_rank ( mpi_comm_here, mytask_local, ierr ) ; + CALL MPI_Comm_size ( mpi_comm_here, ntasks_local, ierr ) ; + mpi_comm_allcompute = mpi_comm_here - IF ( mytask .EQ. 0 ) THEN + IF ( mytask_local .EQ. 0 ) THEN + max_dom = 1 OPEN ( unit=27, file="namelist.input", form="formatted", status="old" ) - tasks_per_split = ntasks - READ ( 27 , NML = namelist_split, IOSTAT=io_status ) + READ ( UNIT = 27 , NML = domains , IOSTAT=io_status ) + REWIND(27) + nio_groups = 1 + nio_tasks_per_group = 0 + poll_servers = .false. + READ ( 27 , NML = namelist_quilt, IOSTAT=io_status ) + CLOSE(27) + END IF + CALL mpi_bcast( nio_tasks_per_group , max_domains , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nio_groups , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( max_dom, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( parent_id, max_domains , MPI_INTEGER , 0 , mpi_comm_here, ierr ) +#if ( HWRF == 1 ) +! check to make sure that if nio_tasks_per_group is non-zero for any domain it has to be non-zero for all of them + i = MAXVAL(nio_tasks_per_group(1:max_dom)) + IF ( i .GT. 0 .AND. nio_groups .GT. 0 ) THEN + DO id = 1, max_dom + IF ( nio_tasks_per_group(id) .LE. 0 ) THEN + CALL wrf_error_fatal( & +'If nio_tasks_per_group in namelist.input is non-zero for any domain, every active domain must have a non-zero value in nio_tasks_per_group') + END IF + END DO + END IF + + num_io_tasks = 0 + DO id = 1, max_dom + num_io_tasks = num_io_tasks + nio_tasks_per_group(id)*nio_groups + END DO +#else + CALL quilting_disabled( quilting_is_turned_off ) + IF ( quilting_is_turned_off ) THEN + num_io_tasks = 0 + nio_tasks_per_group = 0 + nio_groups = 1 + ELSE + num_io_tasks = nio_tasks_per_group(1)*nio_groups + END IF +#endif + CALL nl_set_max_dom(1,max_dom) ! quilting wants to see this too + + IF ( mytask_local .EQ. 0 ) THEN + OPEN ( unit=27, file="namelist.input", form="formatted", status="old" ) +! get a sneak peek an nproc_x and nproc_y + nproc_x = -1 + nproc_y = -1 + READ ( 27 , NML = domains, IOSTAT=io_status ) + CLOSE ( 27 ) + OPEN ( unit=27, file="namelist.input", form="formatted", status="old" ) + tasks_per_split = ntasks_local +! we need to sneak-peek the parent_id namelist setting, ,which is in the "domains" section +! of the namelist. That namelist is registry generated, so the registry-generated information +! is #included above. + nest_pes_x = 0 ! dimensions of communicator in X and y + nest_pes_y = 0 + IF ( nproc_x .EQ. -1 .OR. nproc_y .EQ. -1 ) THEN +#if ( HWRF == 1 ) + CALL compute_mesh( ntasks_local, n_x, n_y ) +#else + CALL compute_mesh( ntasks_local-num_io_tasks, n_x, n_y ) +#endif + ELSE + n_x = nproc_x + n_y = nproc_y + END IF + comm_start = 0 ! make it so everyone will use same communicator if the dm_task_split namelist is not specified or is empty + nest_pes_x(1:max_dom) = n_x + nest_pes_y(1:max_dom) = n_y + READ ( 27 , NML = dm_task_split, IOSTAT=io_status ) CLOSE ( 27 ) - ENDIF + END IF CALL mpi_bcast( io_status, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) IF ( io_status .NE. 0 ) THEN - RETURN ! just ignore and return - ENDIF +! or if dm_task_split was read but was emptly, do nothing: dm_task_split not specified, everyone uses same communicator (see above) + END IF CALL mpi_bcast( tasks_per_split, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) - IF ( tasks_per_split .GT. ntasks .OR. tasks_per_split .LE. 0 ) RETURN - IF ( mod( ntasks, tasks_per_split ) .NE. 0 ) THEN - CALL wrf_message( 'WARNING: tasks_per_split does not evenly divide ntasks. Some tasks will be wasted.' ) - ENDIF - - ALLOCATE( icolor(ntasks) ) - j = 0 - DO WHILE ( j .LT. ntasks / tasks_per_split ) - DO i = 1, tasks_per_split - icolor( i + j * tasks_per_split ) = j - ENDDO - j = j + 1 - ENDDO - - CALL MPI_Comm_dup(mpi_comm_here,comdup,ierr) - CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_local,ierr) - CALL wrf_set_dm_communicator( mpi_comm_local ) - - DEALLOCATE( icolor ) + CALL mpi_bcast( nproc_x, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nproc_y, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( comm_start, max_domains , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nest_pes_x, max_domains , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nest_pes_y, max_domains , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + + nkids = 1 + which_kid = 0 + DO i = 2, max_dom + IF ( 1 .le. parent_id(i) .AND. parent_id(i) .LE. max_domains ) THEN + which_kid(i) = nkids(parent_id(i)) + nkids(parent_id(i)) = nkids(parent_id(i)) + 1 + ELSE + WRITE(wrf_err_message,*)'invalid parent id for domain ',i + CALL wrf_error_fatal(TRIM(wrf_err_message)) + END IF + END DO + + num_compute_tasks = -99 + DO nest_id = 1,max_dom + IF ( nest_id .EQ. 1 ) THEN + nest_task_offsets(nest_id) = comm_start(nest_id) + ELSE + IF ( comm_start(nest_id) .LT. comm_start(parent_id(nest_id)) ) THEN + WRITE(wrf_err_message,& + "('nest domain ',i3,'comm_start (',i3,') lt parent ',i3,' comm_start (',i3,')')") & + nest_id,comm_start,parent_id(nest_id),comm_start(parent_id(nest_id)) + CALL wrf_error_fatal(TRIM(wrf_err_message)) + ELSE IF ( comm_start(nest_id) .LT. & + comm_start(parent_id(nest_id)) & + +nest_pes_x(parent_id(nest_id))*nest_pes_y(parent_id(nest_id))) THEN + nest_task_offsets(nest_id) = comm_start(nest_id)-comm_start(parent_id(nest_id)) + ELSE + nest_task_offsets(nest_id) = nest_pes_x(parent_id(nest_id))*nest_pes_y(parent_id(nest_id)) + END IF + END IF + IF ((comm_start(nest_id)+nest_pes_x(nest_id)*nest_pes_y(nest_id)) .GT. num_compute_tasks ) THEN + num_compute_tasks = (comm_start(nest_id)+nest_pes_x(nest_id)*nest_pes_y(nest_id)) + END IF + END DO + + IF ( .TRUE. ) THEN +!jm Additional code here to set up communicator for this domain and tables +!jm mapping individual domain task IDs to the original local communicator +!jm that is unsplit over nest domains. from now on what we are calling +!jm local_communicator will be the communicator that is used by the local +!jm nests. The communicator that spans all the nests will be renamed to +!jm intercomm_communicator. +!jm Design note: exploring the idea of using MPI intercommunicators. They +!jm only work in pairs so we'd have a lot of intercommunicators to set up +!jm and keep around. We'd also have to have additional communicator arguments +!jm to all the nesting routines in and around the RSL nesting parts. + CALL MPI_Comm_rank ( mpi_comm_here, mytask_local, ierr ) ; + CALL MPI_Comm_rank ( mpi_comm_here, origmytask, ierr ) ; + CALL mpi_comm_size ( mpi_comm_here, ntasks_local, ierr ) ; + ALLOCATE( icolor(ntasks_local) ) + ALLOCATE( icolor2(ntasks_local) ) + ALLOCATE( idomain(ntasks_local) ) + k = 0 +! split off the separate local communicators + +! construct list of local communicators my task is in + comms_i_am_in = MPI_UNDEFINED + DO i = 1, max_dom + inthisone = .FALSE. + icolor = 0 + DO j = comm_start(i), comm_start(i)+nest_pes_x(i)*nest_pes_y(i)-1 + IF ( j+1 .GT. ntasks_local ) THEN + WRITE(wrf_err_message,*)"check comm_start, nest_pes_x, nest_pes_y settings in namelist for comm ",i + CALL wrf_error_fatal(wrf_err_message) + END IF + icolor(j+1) = 1 + END DO + IF ( icolor(mytask_local+1) .EQ. 1 ) inthisone = .TRUE. + CALL MPI_Comm_dup(mpi_comm_here,comdup,ierr) + CALL MPI_Comm_split(comdup,icolor(mytask_local+1),mytask_local,mpi_comm_local,ierr) + IF ( inthisone ) THEN + dims(1) = nest_pes_y(i) ! rows + dims(2) = nest_pes_x(i) ! columns + isperiodic(1) = .false. + isperiodic(2) = .false. + CALL mpi_cart_create( mpi_comm_local, 2, dims, isperiodic, .false., comms_i_am_in(i), ierr ) + END IF + END DO + +! assign domains to communicators + local_communicator = MPI_UNDEFINED +#if ( HWRF != 1 ) + CALL wrf_set_dm_quilt_comm( mpi_comm_here ) ! used by module_io_quilt_old.F +#endif + DO i = 1, max_dom + local_communicator_store(i) = comms_i_am_in(i) + domain_active_this_task(i) = ( local_communicator_store(i) .NE. MPI_UNDEFINED ) + IF ( local_communicator_store(i) .NE. MPI_UNDEFINED ) THEN + CALL MPI_Comm_size( local_communicator_store(i), ntasks_store(i), ierr ) + CALL MPI_Comm_rank( local_communicator_store(i), mytask_store(i), ierr ) + CALL mpi_cart_coords( local_communicator_store(i), mytask_store(i), 2, coords, ierr ) + IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_cart_coords fails ') + mytask_y_store(i) = coords(1) ! col task (1) + mytask_x_store(i) = coords(2) ! col task (x) + CALL MPI_Comm_dup( local_communicator_store(i), comdup2, ierr ) + IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_dup fails ') + + CALL MPI_Comm_split(comdup2,mytask_y_store(i),mytask_store(i),local_communicator_x_store(i),ierr) + IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_split fails for y ') + + CALL MPI_Comm_split(comdup2,mytask_x_store(i),mytask_store(i),local_communicator_y_store(i),ierr) + IF ( ierr .NE. 0 ) CALL wrf_error_fatal('MPI_Comm_split fails for x ') + + CALL MPI_Comm_size( local_communicator_x_store(i), ntasks_x_store(i), ierr ) + CALL MPI_Comm_rank( local_communicator_x_store(i), mytask_x_store(i), ierr ) + CALL MPI_Comm_size( local_communicator_y_store(i), ntasks_y_store(i), ierr ) + CALL MPI_Comm_rank( local_communicator_y_store(i), mytask_y_store(i), ierr ) + END IF + END DO + + intercomm_active = .FALSE. + ! iterate over parent-nest pairs + ! split off a new communicator from the big one that includes the tasks from the parent and nest communicators + ! starting with the parent tasks followed by the nest tasks + ! if a task is in both (ie. the communicators overlap) set the offset at the start of the first nest task + ! in this way, we will handle cases where the parent and nest are decomposed over the same set of tasks + ! (in that case, the offset would be the first task of the parent-nest communicator and that communicator) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ntasks_local = num_compute_tasks + DO nest_id = 2, max_dom + par_id = parent_id(nest_id) + icolor2 = 0 + DO j = 1,ntasks_local !iterate over all the tasks in the "big" communicator + IF ( local_communicator_store( par_id ) .NE. MPI_UNDEFINED .OR. local_communicator_store( nest_id ) .NE. MPI_UNDEFINED ) icolor2(j)=1 + END DO + ! set mpi_comm_me_and_mom to be a communicator that has my parents tasks and mine + icolor2 = 0 + mytask_is_nest = .FALSE. + mytask_is_par = .FALSE. + DO j = 1,ntasks_local + + IF ( comm_start(nest_id) .LE. j-1 .AND. j-1 .LT. comm_start(nest_id) + nest_pes_x(nest_id)*nest_pes_y(nest_id) ) THEN + icolor2(j)=1 + if ( j-1 .EQ. mytask_local ) mytask_is_nest=.TRUE. + END IF + IF ( comm_start(par_id ) .LE. j-1 .AND. j-1 .LT. comm_start(par_id ) + nest_pes_x(par_id )*nest_pes_y(par_id ) ) THEN + icolor2(j)=1 + if ( j-1 .EQ. mytask_local ) mytask_is_par=.TRUE. + END IF + END DO + + i = icolor2(mytask_local+1) + CALL MPI_Comm_dup(mpi_comm_here,comdup,ierr) + CALL MPI_Comm_split(comdup,i,origmytask,mpi_comm_me_and_mom,ierr) + + IF ( mytask_is_nest ) THEN + intercomm_active(nest_id) = .TRUE. + mpi_comm_to_mom(nest_id) = mpi_comm_me_and_mom + END IF + IF ( mytask_is_par ) THEN + intercomm_active(par_id) = .TRUE. + mpi_comm_to_kid(which_kid(nest_id),par_id) = mpi_comm_me_and_mom + END IF + END DO + DEALLOCATE( icolor ) + DEALLOCATE( icolor2 ) + DEALLOCATE( idomain ) + + ELSE IF ( ( tasks_per_split .LE. ntasks_local .AND. tasks_per_split .LE. 0 ) ) THEN + domain_active_this_task(1) = .TRUE. + IF ( mod( ntasks_local, tasks_per_split ) .NE. 0 ) THEN + CALL wrf_message( 'WARNING: tasks_per_split does not evenly divide ntasks. Some tasks will be wasted.' ) + END IF + + ALLOCATE( icolor(ntasks_local) ) + j = 0 + DO WHILE ( j .LT. ntasks_local / tasks_per_split ) + DO i = 1, tasks_per_split + icolor( i + j * tasks_per_split ) = j + END DO + j = j + 1 + END DO + + CALL MPI_Comm_dup(mpi_comm_here,comdup,ierr) + CALL MPI_Comm_split(comdup,icolor(mytask_local+1),mytask_local,mpi_comm_local,ierr) + CALL wrf_set_dm_communicator( mpi_comm_local ) + CALL store_communicators_for_domain(1) + DEALLOCATE( icolor ) + ELSE + domain_active_this_task(1) = .TRUE. + mpi_comm_local = mpi_comm_here + CALL wrf_set_dm_communicator( mpi_comm_local ) + CALL store_communicators_for_domain(1) + END IF + + CALL instate_communicators_for_domain(1) + +#else +! for serial (non-MPI) builds + IMPLICIT NONE +# if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT) + INTEGER thread_support_provided, thread_support_requested +# endif + INTEGER i, j, k, x, y, n_x, n_y + INTEGER iii + INTEGER dims(3) +! for parallel nesting, 201408, jm + INTEGER :: id + INTEGER :: io_status + INTEGER :: domain_id,par_id,nest_id,kid_id + +!!!!! needed to sneak-peek the registry to get parent_id +! define as temporaries +#include "namelist_defines.inc" + +! Statements that specify the namelists +#include "namelist_statements.inc" + + max_dom = 1 + OPEN ( unit=27, file="namelist.input", form="formatted", status="old" ) + READ ( UNIT = 27 , NML = domains , IOSTAT=io_status ) + CLOSE(27) + + nkids = 1 + which_kid = 0 + DO i = 2, max_dom + IF ( 1 .le. parent_id(i) .AND. parent_id(i) .LE. max_domains ) THEN + which_kid(i) = nkids(parent_id(i)) + nkids(parent_id(i)) = nkids(parent_id(i)) + 1 + ELSE + WRITE(wrf_err_message,*)'invalid parent id for domain ',i + CALL wrf_error_fatal(TRIM(wrf_err_message)) + END IF + END DO + + intercomm_active = .TRUE. + domain_active_this_task = .TRUE. + ntasks_stack = 1 + ntasks_y_stack = 1 + ntasks_x_stack = 1 + mytask_stack = 0 + mytask_x_stack = 0 + mytask_y_stack = 0 + ntasks_store = 1 + ntasks_y_store = 1 + ntasks_x_store = 1 + mytask_store = 0 + mytask_x_store = 0 + mytask_y_store = 0 + ntasks = 1 + ntasks_y = 1 + ntasks_x = 1 + mytask = 0 + mytask_x = 0 + mytask_y = 0 + nest_pes_x = 1 + nest_pes_y = 1 + CALL instate_communicators_for_domain(1) #endif END SUBROUTINE split_communicator @@ -1735,9 +2134,8 @@ SUBROUTINE init_module_dm CALL mpi_init ( ierr ) mpi_comm_here = MPI_COMM_WORLD CALL wrf_set_dm_communicator ( mpi_comm_here ) - ENDIF + END IF CALL wrf_get_dm_communicator( mpi_comm_local ) - CALL wrf_termio_dup( mpi_comm_local ) #endif END SUBROUTINE init_module_dm @@ -1805,8 +2203,8 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, & SFP_BUFFER(NLOCAL_DOT) = ERRF(7,N) ! SURFACE PRESSURE QRK_BUFFER(NLOCAL_DOT) = ERRF(9,N) ! RKO N_BUFFER(NLOCAL_DOT) = N - ENDIF - ENDDO + END IF + END DO CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, & ICOUNT,1,MPI_INTEGER, & MPI_COMM_COMP,IERR) @@ -1815,7 +2213,7 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, & IDISPLACEMENT(1) = 0 DO I = 2, NPROCS IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1) - ENDDO + END DO CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER, & IFULL_BUFFER, ICOUNT, IDISPLACEMENT, & MPI_INTEGER, MPI_COMM_COMP, IERR) @@ -1825,21 +2223,21 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, & MPI_REAL, MPI_COMM_COMP, IERR) DO N = 1, NSTA ERRF(1,IFULL_BUFFER(N)) = FULL_BUFFER(N) - ENDDO + END DO ! SURF PRESS AT U-POINTS CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL, & FULL_BUFFER, ICOUNT, IDISPLACEMENT, & MPI_REAL, MPI_COMM_COMP, IERR) DO N = 1, NSTA ERRF(7,IFULL_BUFFER(N)) = FULL_BUFFER(N) - ENDDO + END DO ! RKO CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_DOT, MPI_REAL, & FULL_BUFFER, ICOUNT, IDISPLACEMENT, & MPI_REAL, MPI_COMM_COMP, IERR) DO N = 1, NSTA ERRF(9,IFULL_BUFFER(N)) = FULL_BUFFER(N) - ENDDO + END DO ! DO THE V FIELD NLOCAL_DOT = 0 @@ -1849,8 +2247,8 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, & UVT_BUFFER(NLOCAL_DOT) = ERRF(2,N) ! V WIND COMPONENT SFP_BUFFER(NLOCAL_DOT) = ERRF(8,N) ! SURFACE PRESSURE N_BUFFER(NLOCAL_DOT) = N - ENDIF - ENDDO + END IF + END DO CALL MPI_ALLGATHER(NLOCAL_DOT,1,MPI_INTEGER, & ICOUNT,1,MPI_INTEGER, & MPI_COMM_COMP,IERR) @@ -1859,7 +2257,7 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, & IDISPLACEMENT(1) = 0 DO I = 2, NPROCS IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1) - ENDDO + END DO CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_DOT, MPI_INTEGER, & IFULL_BUFFER, ICOUNT, IDISPLACEMENT, & MPI_INTEGER, MPI_COMM_COMP, IERR) @@ -1869,14 +2267,14 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, & MPI_REAL, MPI_COMM_COMP, IERR) DO N = 1, NSTA ERRF(2,IFULL_BUFFER(N)) = FULL_BUFFER(N) - ENDDO + END DO ! SURF PRESS AT V-POINTS CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_DOT, MPI_REAL, & FULL_BUFFER, ICOUNT, IDISPLACEMENT, & MPI_REAL, MPI_COMM_COMP, IERR) DO N = 1, NSTA ERRF(8,IFULL_BUFFER(N)) = FULL_BUFFER(N) - ENDDO + END DO ! DO THE CROSS FIELDS, T AND Q NLOCAL_CRS = 0 @@ -1889,15 +2287,15 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, & SFP_BUFFER(NLOCAL_CRS) = ERRF(6,N) ! SURFACE PRESSURE QATOB_BUFFER(NLOCAL_CRS) = ERRF(10,N) ! Model Mixing ratio itself (NOT ERROR) N_BUFFER(NLOCAL_CRS) = N - ENDIF - ENDDO + END IF + END DO CALL MPI_ALLGATHER(NLOCAL_CRS,1,MPI_INTEGER, & ICOUNT,1,MPI_INTEGER, & MPI_COMM_COMP,IERR) IDISPLACEMENT(1) = 0 DO I = 2, NPROCS IDISPLACEMENT(I) = IDISPLACEMENT(I-1) + ICOUNT(I-1) - ENDDO + END DO CALL MPI_ALLGATHERV( N_BUFFER, NLOCAL_CRS, MPI_INTEGER, & IFULL_BUFFER, ICOUNT, IDISPLACEMENT, & MPI_INTEGER, MPI_COMM_COMP, IERR) @@ -1908,28 +2306,28 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, & DO N = 1, NSTA ERRF(3,IFULL_BUFFER(N)) = FULL_BUFFER(N) - ENDDO + END DO ! Q CALL MPI_ALLGATHERV( QRK_BUFFER, NLOCAL_CRS, MPI_REAL, & FULL_BUFFER, ICOUNT, IDISPLACEMENT, & MPI_REAL, MPI_COMM_COMP, IERR) DO N = 1, NSTA ERRF(4,IFULL_BUFFER(N)) = FULL_BUFFER(N) - ENDDO + END DO ! KPBL CALL MPI_ALLGATHERV( PBL_BUFFER, NLOCAL_CRS, MPI_REAL, & FULL_BUFFER, ICOUNT, IDISPLACEMENT, & MPI_REAL, MPI_COMM_COMP, IERR) DO N = 1, NSTA ERRF(5,IFULL_BUFFER(N)) = FULL_BUFFER(N) - ENDDO + END DO ! SURF PRESS AT MASS POINTS CALL MPI_ALLGATHERV( SFP_BUFFER, NLOCAL_CRS, MPI_REAL, & FULL_BUFFER, ICOUNT, IDISPLACEMENT, & MPI_REAL, MPI_COMM_COMP, IERR) DO N = 1, NSTA ERRF(6,IFULL_BUFFER(N)) = FULL_BUFFER(N) - ENDDO + END DO ! Water vapor mixing ratio at the mass points (NOT THE ERROR) CALL MPI_ALLGATHERV( QATOB_BUFFER, NLOCAL_CRS, MPI_REAL, & @@ -1937,7 +2335,7 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf, & MPI_REAL, MPI_COMM_COMP, IERR) DO N = 1, NSTA ERRF(10,IFULL_BUFFER(N)) = FULL_BUFFER(N) - ENDDO + END DO #endif END SUBROUTINE get_full_obs_vector @@ -1967,8 +2365,8 @@ SUBROUTINE wrf_dm_maxtile_real ( val , tile) IF ( val_all(i) .GT. val ) THEN tile = i val = val_all(i) - ENDIF - ENDDO + END IF + END DO #endif END SUBROUTINE wrf_dm_maxtile_real @@ -1996,8 +2394,8 @@ SUBROUTINE wrf_dm_mintile_real ( val , tile) IF ( val_all(i) .LT. val ) THEN tile = i val = val_all(i) - ENDIF - ENDDO + END IF + END DO #endif END SUBROUTINE wrf_dm_mintile_real @@ -2025,8 +2423,8 @@ SUBROUTINE wrf_dm_mintile_double ( val , tile) IF ( val_all(i) .LT. val ) THEN tile = i val = val_all(i) - ENDIF - ENDDO + END IF + END DO #endif END SUBROUTINE wrf_dm_mintile_double @@ -2058,7 +2456,7 @@ SUBROUTINE wrf_get_hostname ( str ) CALL rsl_lite_get_hostname( tmp, 512, n, cs ) DO i = 1, n str(i:i) = tmp(i) - ENDDO + END DO RETURN END SUBROUTINE wrf_get_hostname @@ -2073,6 +2471,81 @@ END SUBROUTINE wrf_get_hostid END MODULE module_dm + + SUBROUTINE push_communicators_for_domain( id ) + USE module_dm + INTEGER, INTENT(IN) :: id ! if specified also does an instate for grid id + IF ( communicator_stack_cursor .GE. max_domains ) CALL wrf_error_fatal("push_communicators_for_domain would excede stacksize") + communicator_stack_cursor = communicator_stack_cursor + 1 + + id_stack(communicator_stack_cursor) = current_id + local_communicator_stack( communicator_stack_cursor ) = local_communicator + local_communicator_periodic_stack( communicator_stack_cursor ) = local_communicator_periodic + local_iocommunicator_stack( communicator_stack_cursor ) = local_iocommunicator + local_communicator_x_stack( communicator_stack_cursor ) = local_communicator_x + local_communicator_y_stack( communicator_stack_cursor ) = local_communicator_y + ntasks_stack( communicator_stack_cursor ) = ntasks + ntasks_y_stack( communicator_stack_cursor ) = ntasks_y + ntasks_x_stack( communicator_stack_cursor ) = ntasks_x + mytask_stack( communicator_stack_cursor ) = mytask + mytask_x_stack( communicator_stack_cursor ) = mytask_x + mytask_y_stack( communicator_stack_cursor ) = mytask_y + + CALL instate_communicators_for_domain( id ) + END SUBROUTINE push_communicators_for_domain + SUBROUTINE pop_communicators_for_domain + USE module_dm + IMPLICIT NONE + IF ( communicator_stack_cursor .LT. 1 ) CALL wrf_error_fatal("pop_communicators_for_domain on empty stack") + current_id = id_stack(communicator_stack_cursor) + local_communicator = local_communicator_stack( communicator_stack_cursor ) + local_communicator_periodic = local_communicator_periodic_stack( communicator_stack_cursor ) + local_iocommunicator = local_iocommunicator_stack( communicator_stack_cursor ) + local_communicator_x = local_communicator_x_stack( communicator_stack_cursor ) + local_communicator_y = local_communicator_y_stack( communicator_stack_cursor ) + ntasks = ntasks_stack( communicator_stack_cursor ) + ntasks_y = ntasks_y_stack( communicator_stack_cursor ) + ntasks_x = ntasks_x_stack( communicator_stack_cursor ) + mytask = mytask_stack( communicator_stack_cursor ) + mytask_x = mytask_x_stack( communicator_stack_cursor ) + mytask_y = mytask_y_stack( communicator_stack_cursor ) + communicator_stack_cursor = communicator_stack_cursor - 1 + END SUBROUTINE pop_communicators_for_domain + SUBROUTINE instate_communicators_for_domain( id ) + USE module_dm + IMPLICIT NONE + INTEGER, INTENT(IN) :: id + INTEGER ierr + current_id = id + local_communicator = local_communicator_store( id ) + local_communicator_periodic = local_communicator_periodic_store( id ) + local_iocommunicator = local_iocommunicator_store( id ) + local_communicator_x = local_communicator_x_store( id ) + local_communicator_y = local_communicator_y_store( id ) + ntasks = ntasks_store( id ) + mytask = mytask_store( id ) + ntasks_x = ntasks_x_store( id ) + ntasks_y = ntasks_y_store( id ) + mytask_x = mytask_x_store( id ) + mytask_y = mytask_y_store( id ) + END SUBROUTINE instate_communicators_for_domain + SUBROUTINE store_communicators_for_domain( id ) + USE module_dm + IMPLICIT NONE + INTEGER, INTENT(IN) :: id + local_communicator_store( id ) = local_communicator + local_communicator_periodic_store( id ) = local_communicator_periodic + local_iocommunicator_store( id ) = local_iocommunicator + local_communicator_x_store( id ) = local_communicator_x + local_communicator_y_store( id ) = local_communicator_y + ntasks_store( id ) = ntasks + ntasks_x_store( id ) = ntasks_x + ntasks_y_store( id ) = ntasks_y + mytask_store( id ) = mytask + mytask_x_store( id ) = mytask_x + mytask_y_store( id ) = mytask_y + END SUBROUTINE store_communicators_for_domain + !========================================================================= ! wrf_dm_patch_domain has to be outside the module because it is called ! by a routine in module_domain but depends on module domain @@ -2089,7 +2562,7 @@ SUBROUTINE wrf_dm_patch_domain ( id , domdesc , parent_id , parent_domdesc , & sp3y , ep3y , sm3y , em3y , & bdx , bdy ) USE module_domain, ONLY : domain, head_grid, find_grid_by_id - USE module_dm, ONLY : patch_domain_rsl_lite + USE module_dm, ONLY : patch_domain_rsl_lite !, push_communicators_for_domain, pop_communicators_for_domain IMPLICIT NONE INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy @@ -2113,6 +2586,8 @@ SUBROUTINE wrf_dm_patch_domain ( id , domdesc , parent_id , parent_domdesc , & grid_ptr => head_grid CALL find_grid_by_id( parent_id , grid_ptr , parent ) + CALL push_communicators_for_domain(id) + CALL patch_domain_rsl_lite ( id , parent, parent_id , & sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & sd2 , ed2 , sp2 , ep2 , sm2 , em2 , & @@ -2125,6 +2600,8 @@ SUBROUTINE wrf_dm_patch_domain ( id , domdesc , parent_id , parent_domdesc , & sp3y , ep3y , sm3y , em3y , & bdx , bdy ) + CALL pop_communicators_for_domain + RETURN END SUBROUTINE wrf_dm_patch_domain @@ -2214,17 +2691,48 @@ SUBROUTINE wrf_dm_bcast_string( BUF, N1 ) IF (n .GT. 0 ) then DO i = 1, n ibuf(I) = ichar(buf(I:I)) - ENDDO + END DO CALL wrf_dm_bcast_integer( ibuf, n ) buf = '' DO i = 1, n buf(i:i) = char(ibuf(i)) - ENDDO - ENDIF + END DO + END IF #endif RETURN END SUBROUTINE wrf_dm_bcast_string +SUBROUTINE wrf_dm_bcast_string_comm( BUF, N1, COMM ) + IMPLICIT NONE + INTEGER n1 + INTEGER COMM +! +! Collective operation. Given a string and a size in characters on task zero, broadcast and return that buffer on all tasks. +! +! + CHARACTER*(*) buf +#ifndef STUBMPI + INTEGER ibuf(256),i,n + CHARACTER*256 tstr + n = n1 + ! Root task is required to have the correct value of N1, other tasks + ! might not have the correct value. + CALL BYTE_BCAST( n, IWORDSIZE, COMM ) + IF (n .GT. 256) n = 256 + IF (n .GT. 0 ) then + DO i = 1, n + ibuf(I) = ichar(buf(I:I)) + END DO + CALL BYTE_BCAST( ibuf, N*IWORDSIZE, COMM ) + buf = '' + DO i = 1, n + buf(i:i) = char(ibuf(i)) + END DO + END IF +#endif + RETURN +END SUBROUTINE wrf_dm_bcast_string_comm + SUBROUTINE wrf_dm_bcast_integer( BUF, N1 ) IMPLICIT NONE INTEGER n1 @@ -2303,8 +2811,8 @@ SUBROUTINE write_68( grid, v , s , & DO j = jds, jde DO i = ids, ide WRITE(68,*) globbuf(i,1,j) - ENDDO - ENDDO + END DO + END DO endif RETURN @@ -2349,8 +2857,12 @@ LOGICAL FUNCTION wrf_dm_on_monitor() INCLUDE 'mpif.h' INTEGER tsk, ierr, mpi_comm_local CALL wrf_get_dm_communicator( mpi_comm_local ) - CALL mpi_comm_rank ( mpi_comm_local, tsk , ierr ) - wrf_dm_on_monitor = tsk .EQ. 0 + IF ( mpi_comm_local .NE. MPI_UNDEFINED ) THEN + CALL mpi_comm_rank ( mpi_comm_local, tsk , ierr ) + wrf_dm_on_monitor = tsk .EQ. 0 + ELSE + wrf_dm_on_monitor = .FALSE. + END IF #else wrf_dm_on_monitor = .TRUE. #endif @@ -2374,7 +2886,8 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & shw , xy , ds, de_in, ps, pe, nds,nde, & sendbeg_m, sendw_m, sendbeg_p, sendw_p, & recvbeg_m, recvw_m, recvbeg_p, recvw_p ) - USE module_dm, ONLY : ntasks_x, ntasks_y, mytask_x, mytask_y, minx, miny + USE module_dm, ONLY : ntasks_x, ntasks_y, mytask_x, mytask_y, minx, miny, & + nest_pes_x, nest_pes_y IMPLICIT NONE INTEGER, INTENT(IN) :: id,shw,xy,ds,de_in,ps,pe,nds,nde LOGICAL, INTENT(IN) :: is_intermediate ! treated differently, coarse but with same decomp as nest @@ -2396,8 +2909,8 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & #else de = de_in #endif - ntx = ntasks_x - nty = ntasks_y + ntx = nest_pes_x(id) + nty = nest_pes_y(id) IF ( xy .EQ. 1 ) THEN ! X/I axis nt = ntasks_x me = mytask_x @@ -2405,7 +2918,7 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & IF ( is_intermediate ) THEN CALL nl_get_i_parent_start(id,parent_start) CALL nl_get_parent_grid_ratio(id,parent_grid_ratio) - ENDIF + END IF ELSE nt = ntasks_y me = mytask_y @@ -2413,8 +2926,8 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & IF ( is_intermediate ) THEN CALL nl_get_j_parent_start(id,parent_start) CALL nl_get_parent_grid_ratio(id,parent_grid_ratio) - ENDIF - ENDIF + END IF + END IF iter = iter + 1 #if (DA_CORE == 0) @@ -2428,17 +2941,17 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & DO k = lb,ps+shw-1 went = .TRUE. IF ( xy .eq. 1 ) THEN - IF ( is_intermediate ) THEN - kn = ( k - parent_start ) * parent_grid_ratio + 1 + 1 ; + IF ( is_intermediate ) THEN + kn = ( k - parent_start ) * parent_grid_ratio + 1 + 1 ; CALL task_for_point (kn,1,nds,nde,1,dum,ntx,nty,Px,Py,minx,miny,ierr) ! modified to treat x and y separately IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (h)') - ELSE + ELSE CALL task_for_point (k,1,ds,de,1,dum,ntx,nty,Px,Py,minx,miny,ierr) ! modified to treat x and y separately IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (i)') - ENDIF - IF ( Px .NE. me+(iter-1) ) THEN - exit - ENDIF + END IF + IF ( Px .NE. me+(iter-1) ) THEN + exit + END IF ELSE IF ( is_intermediate ) THEN kn = ( k - parent_start ) * parent_grid_ratio + 1 + 1 ; @@ -2447,15 +2960,15 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & ELSE CALL task_for_point (1,k,1,dum,ds,de,ntx,nty,Px,Py,minx,miny,ierr) ! modified to treat x and y separately IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (i)') - ENDIF + END IF IF ( Py .NE. me+(iter-1) ) THEN exit - ENDIF - ENDIF + END IF + END IF minus_send_start = minus_send_start+1 sendw_m = sendw_m + 1 - ENDDO - ENDIF + END DO + END IF ! recv from minus recvw_m = 0 recvbeg_m = 1 @@ -2472,10 +2985,10 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & ELSE CALL task_for_point (k,1,ds,de,1,dum,ntx,nty,Px,Py,minx,miny,ierr) ! modified to treat x and y separately IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (k)') - ENDIF + END IF IF ( Px .NE. me-iter ) THEN exit - ENDIF + END IF ELSE IF ( is_intermediate ) THEN kn = ( k - parent_start ) * parent_grid_ratio + 1 + 1 ; @@ -2484,15 +2997,15 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & ELSE CALL task_for_point (1,k,1,dum,ds,de,ntx,nty,Px,Py,minx,miny,ierr) ! modified to treat x and y separately IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (k)') - ENDIF + END IF IF ( Py .NE. me-iter ) THEN exit - ENDIF - ENDIF + END IF + END IF minus_recv_start = minus_recv_start-1 recvw_m = recvw_m + 1 - ENDDO - ENDIF + END DO + END IF ! send to plus sendw_p = 0 @@ -2510,10 +3023,10 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & ELSE CALL task_for_point (k,1,ds,de,1,dum,ntx,nty,Px,Py,minx,miny,ierr) ! modified to treat x and y separately IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (m)') - ENDIF + END IF IF ( Px .NE. me-(iter-1) ) THEN exit - ENDIF + END IF ELSE IF ( is_intermediate ) THEN kn = ( k - parent_start ) * parent_grid_ratio + 1 + 1 ; @@ -2522,15 +3035,15 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & ELSE CALL task_for_point (1,k,1,dum,ds,de,ntx,nty,Px,Py,minx,miny,ierr) ! modified to treat x and y separately IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (m)') - ENDIF + END IF IF ( Py .NE. me-(iter-1) ) THEN exit - ENDIF - ENDIF + END IF + END IF plus_send_start = plus_send_start - 1 sendw_p = sendw_p + 1 - ENDDO - ENDIF + END DO + END IF ! recv from plus recvw_p = 0 recvbeg_p = 1 @@ -2549,10 +3062,10 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & CALL task_for_point (k,1,ds,de,1,dum,ntx,nty,Px,Py,minx,miny,ierr) ! modified to treat x and y separately IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (o)') - ENDIF + END IF IF ( Px .NE. me+iter ) THEN exit - ENDIF + END IF ELSE IF ( is_intermediate ) THEN kn = ( k - parent_start ) * parent_grid_ratio + 1 + 1 ; @@ -2561,15 +3074,15 @@ LOGICAL FUNCTION rsl_comm_iter ( id , is_intermediate, & ELSE CALL task_for_point (1,k,1,dum,ds,de,ntx,nty,Px,Py,minx,miny,ierr) ! modified to treat x and y separately IF ( ierr .NE. 0 ) CALL wrf_error_fatal('error code returned by task_for_point in module_dm.F (o)') - ENDIF + END IF IF ( Py .NE. me+iter ) THEN exit - ENDIF - ENDIF + END IF + END IF plus_recv_start = plus_recv_start + 1 recvw_p = recvw_p + 1 - ENDDO - ENDIF + END DO + END IF #else if ( iter .eq. 1 ) then went = .true. @@ -2602,6 +3115,20 @@ INTEGER FUNCTION wrf_dm_monitor_rank() RETURN END FUNCTION wrf_dm_monitor_rank +! return the global communicator if id <= 0 + SUBROUTINE wrf_get_dm_communicator_for_id ( id, communicator ) + USE module_dm , ONLY : local_communicator_store, mpi_comm_allcompute + IMPLICIT NONE + INTEGER , INTENT(IN) :: id + INTEGER , INTENT(OUT) :: communicator + IF ( id .le. 0 ) THEN + communicator = mpi_comm_allcompute + ELSE + communicator = local_communicator_store(id) + END IF + RETURN + END SUBROUTINE wrf_get_dm_communicator_for_id + SUBROUTINE wrf_get_dm_communicator ( communicator ) USE module_dm , ONLY : local_communicator IMPLICIT NONE @@ -2666,6 +3193,23 @@ SUBROUTINE wrf_get_dm_ntasks_y ( retval ) RETURN END SUBROUTINE wrf_get_dm_ntasks_y +! added 20151212 + SUBROUTINE wrf_set_dm_quilt_comm ( communicator ) + USE module_dm , ONLY : local_quilt_comm + IMPLICIT NONE + INTEGER , INTENT(IN) :: communicator + local_quilt_comm = communicator + RETURN + END SUBROUTINE wrf_set_dm_quilt_comm + + SUBROUTINE wrf_get_dm_quilt_comm ( communicator ) + USE module_dm , ONLY : local_quilt_comm + IMPLICIT NONE + INTEGER , INTENT(OUT) :: communicator + communicator = local_quilt_comm + RETURN + END SUBROUTINE wrf_get_dm_quilt_comm + !!!!!!!!!!!!!!!!!!!!!!! PATCH TO GLOBAL !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -2836,7 +3380,7 @@ SUBROUTINE wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,typ ALLOCATE ( tmpbuf ( (DE1-DS1+1)*(DE2-DS2+1)*(DE3-DS3+1)/RWORDSIZE*typesize+32 ), STAT=ierr ) ELSE ALLOCATE ( tmpbuf ( 1 ), STAT=ierr ) - ENDIF + END IF IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating tmpbuf in wrf_patch_to_global_generic') Patch(1,1) = ps1 ; Patch(1,2) = pe1 ! use patch dims @@ -2844,22 +3388,22 @@ SUBROUTINE wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,typ Patch(3,1) = ps3 ; Patch(3,2) = pe3 IF ( typesize .EQ. RWORDSIZE ) THEN - CALL just_patch_r ( buf , locbuf , size(locbuf), & + CALL just_patch_r ( buf , locbuf , size(locbuf)*RWORDSIZE/typesize, & PS1, PE1, PS2, PE2, PS3, PE3 , & MS1, ME1, MS2, ME2, MS3, ME3 ) ELSE IF ( typesize .EQ. IWORDSIZE ) THEN - CALL just_patch_i ( buf , locbuf , size(locbuf), & + CALL just_patch_i ( buf , locbuf , size(locbuf)*RWORDSIZE/typesize, & PS1, PE1, PS2, PE2, PS3, PE3 , & MS1, ME1, MS2, ME2, MS3, ME3 ) ELSE IF ( typesize .EQ. DWORDSIZE ) THEN - CALL just_patch_d ( buf , locbuf , size(locbuf), & + CALL just_patch_d ( buf , locbuf , size(locbuf)*RWORDSIZE/typesize, & PS1, PE1, PS2, PE2, PS3, PE3 , & MS1, ME1, MS2, ME2, MS3, ME3 ) ELSE IF ( typesize .EQ. LWORDSIZE ) THEN - CALL just_patch_l ( buf , locbuf , size(locbuf), & + CALL just_patch_l ( buf , locbuf , size(locbuf)*RWORDSIZE/typesize, & PS1, PE1, PS2, PE2, PS3, PE3 , & MS1, ME1, MS2, ME2, MS3, ME3 ) - ENDIF + END IF ! defined in external/io_quilt CALL collect_on_comm0 ( local_communicator , IWORDSIZE , & @@ -2874,33 +3418,33 @@ SUBROUTINE wrf_patch_to_global_generic (buf,globbuf,domdesc,stagger,ordering,typ IF ( wrf_at_debug_level(500) ) THEN CALL start_timing - ENDIF + END IF IF ( ndim .GE. 2 .AND. wrf_dm_on_monitor() ) THEN IF ( typesize .EQ. RWORDSIZE ) THEN - CALL patch_2_outbuf_r ( tmpbuf FRSTELEM , globbuf , & - DS1, DE1, DS2, DE2, DS3, DE3 , & - GPATCH ) - ELSE IF ( typesize .EQ. IWORDSIZE ) THEN - CALL patch_2_outbuf_i ( tmpbuf FRSTELEM , globbuf , & - DS1, DE1, DS2, DE2, DS3, DE3 , & - GPATCH ) - ELSE IF ( typesize .EQ. DWORDSIZE ) THEN - CALL patch_2_outbuf_d ( tmpbuf FRSTELEM , globbuf , & - DS1, DE1, DS2, DE2, DS3, DE3 , & - GPATCH ) - ELSE IF ( typesize .EQ. LWORDSIZE ) THEN - CALL patch_2_outbuf_l ( tmpbuf FRSTELEM , globbuf , & - DS1, DE1, DS2, DE2, DS3, DE3 , & - GPATCH ) - ENDIF - - ENDIF + CALL patch_2_outbuf_r ( tmpbuf FRSTELEM , globbuf , & + DS1, DE1, DS2, DE2, DS3, DE3 , & + GPATCH ) + ELSE IF ( typesize .EQ. IWORDSIZE ) THEN + CALL patch_2_outbuf_i ( tmpbuf FRSTELEM , globbuf , & + DS1, DE1, DS2, DE2, DS3, DE3 , & + GPATCH ) + ELSE IF ( typesize .EQ. DWORDSIZE ) THEN + CALL patch_2_outbuf_d ( tmpbuf FRSTELEM , globbuf , & + DS1, DE1, DS2, DE2, DS3, DE3 , & + GPATCH ) + ELSE IF ( typesize .EQ. LWORDSIZE ) THEN + CALL patch_2_outbuf_l ( tmpbuf FRSTELEM , globbuf , & + DS1, DE1, DS2, DE2, DS3, DE3 , & + GPATCH ) + END IF + + END IF IF ( wrf_at_debug_level(500) ) THEN CALL end_timing('wrf_patch_to_global_generic') - ENDIF + END IF DEALLOCATE( tmpbuf ) #endif RETURN @@ -2923,9 +3467,9 @@ SUBROUTINE just_patch_i ( inbuf , outbuf, noutbuf, & DO i = PS1, PE1 outbuf( icurs ) = inbuf( i, j, k ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO RETURN END SUBROUTINE just_patch_i @@ -2946,9 +3490,9 @@ SUBROUTINE just_patch_r ( inbuf , outbuf, noutbuf, & DO i = PS1, PE1 outbuf( icurs ) = inbuf( i, j, k ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO RETURN END SUBROUTINE just_patch_r @@ -2969,9 +3513,9 @@ SUBROUTINE just_patch_d ( inbuf , outbuf, noutbuf, & DO i = PS1, PE1 outbuf( icurs ) = inbuf( i, j, k ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO RETURN END SUBROUTINE just_patch_d @@ -2992,9 +3536,9 @@ SUBROUTINE just_patch_l ( inbuf , outbuf, noutbuf, & DO i = PS1, PE1 outbuf( icurs ) = inbuf( i, j, k ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO RETURN END SUBROUTINE just_patch_l @@ -3016,10 +3560,10 @@ SUBROUTINE patch_2_outbuf_r( inbuf, outbuf, & DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n ) outbuf( i, j, k ) = inbuf( icurs ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO + END DO RETURN END SUBROUTINE patch_2_outbuf_r @@ -3041,10 +3585,10 @@ SUBROUTINE patch_2_outbuf_i( inbuf, outbuf, & DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n ) outbuf( i, j, k ) = inbuf( icurs ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO + END DO RETURN END SUBROUTINE patch_2_outbuf_i @@ -3065,10 +3609,10 @@ SUBROUTINE patch_2_outbuf_d( inbuf, outbuf, & DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n ) outbuf( i, j, k ) = inbuf( icurs ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO + END DO RETURN END SUBROUTINE patch_2_outbuf_d @@ -3089,10 +3633,10 @@ SUBROUTINE patch_2_outbuf_l( inbuf, outbuf, & DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n ) outbuf( i, j, k ) = inbuf( icurs ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO + END DO RETURN END SUBROUTINE patch_2_outbuf_l @@ -3247,7 +3791,7 @@ SUBROUTINE wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,typ ALLOCATE ( tmpbuf ( (DE1-DS1+1)*(DE2-DS2+1)*(DE3-DS3+1)/RWORDSIZE*typesize+32 ), STAT=ierr ) ELSE ALLOCATE ( tmpbuf ( 1 ), STAT=ierr ) - ENDIF + END IF IF ( ierr .ne. 0 ) CALL wrf_error_fatal ('allocating tmpbuf in wrf_global_to_patch_generic') Patch(1,1) = ps1 ; Patch(1,2) = pe1 ! use patch dims @@ -3278,8 +3822,8 @@ SUBROUTINE wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,typ CALL outbuf_2_patch_l ( globbuf , tmpbuf FRSTELEM , & DS1, DE1, DS2, DE2, DS3, DE3 , & GPATCH ) - ENDIF - ENDIF + END IF + END IF CALL dist_on_comm0 ( local_communicator , typesize , & tmpbuf FRSTELEM , (de1-ds1+1)*(de2-ds2+1)*(de3-ds3+1) , & @@ -3302,7 +3846,7 @@ SUBROUTINE wrf_global_to_patch_generic (globbuf,buf,domdesc,stagger,ordering,typ CALL all_sub_l ( locbuf , buf , & PS1, PE1, PS2, PE2, PS3, PE3 , & MS1, ME1, MS2, ME2, MS3, ME3 ) - ENDIF + END IF DEALLOCATE ( tmpbuf ) @@ -3326,9 +3870,9 @@ SUBROUTINE all_sub_i ( inbuf , outbuf, & DO i = PS1, PE1 outbuf( i, j, k ) = inbuf ( icurs ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO RETURN END SUBROUTINE all_sub_i @@ -3348,9 +3892,9 @@ SUBROUTINE all_sub_r ( inbuf , outbuf, & DO i = PS1, PE1 outbuf( i, j, k ) = inbuf ( icurs ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO RETURN END SUBROUTINE all_sub_r @@ -3371,9 +3915,9 @@ SUBROUTINE all_sub_d ( inbuf , outbuf, & DO i = PS1, PE1 outbuf( i, j, k ) = inbuf ( icurs ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO RETURN END SUBROUTINE all_sub_d @@ -3393,9 +3937,9 @@ SUBROUTINE all_sub_l ( inbuf , outbuf, & DO i = PS1, PE1 outbuf( i, j, k ) = inbuf ( icurs ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO RETURN END SUBROUTINE all_sub_l @@ -3419,10 +3963,10 @@ SUBROUTINE outbuf_2_patch_r( inbuf, outbuf, & DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n ) outbuf( icurs ) = inbuf( i,j,k ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO + END DO RETURN END SUBROUTINE outbuf_2_patch_r @@ -3443,10 +3987,10 @@ SUBROUTINE outbuf_2_patch_i( inbuf, outbuf, & DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n ) outbuf( icurs ) = inbuf( i,j,k ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO + END DO RETURN END SUBROUTINE outbuf_2_patch_i @@ -3467,10 +4011,10 @@ SUBROUTINE outbuf_2_patch_d( inbuf, outbuf, & DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n ) outbuf( icurs ) = inbuf( i,j,k ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO + END DO RETURN END SUBROUTINE outbuf_2_patch_d @@ -3491,14 +4035,18 @@ SUBROUTINE outbuf_2_patch_l( inbuf, outbuf, & DO i = GPATCH( 1,1,n ), GPATCH( 1,2,n ) outbuf( icurs ) = inbuf( i,j,k ) icurs = icurs + 1 - ENDDO - ENDDO - ENDDO - ENDDO + END DO + END DO + END DO + END DO RETURN END SUBROUTINE outbuf_2_patch_l + SUBROUTINE wrf_dm_nestexchange_init + CALL rsl_lite_nesting_reset + END SUBROUTINE wrf_dm_nestexchange_init + !------------------------------------------------------------------ @@ -3514,14 +4062,17 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags & USE module_state_description USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type - USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, local_communicator, mytask + USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, local_communicator, mytask, & + nest_pes_x, nest_pes_y ! , & + !push_communicators_for_domain,pop_communicators_for_domain USE module_comm_nesting_dm, ONLY : halo_force_down_sub + USE module_model_constants IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid TYPE(domain), POINTER :: pgrid !KAL added for vertical nesting -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -3544,6 +4095,9 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags & REAL, DIMENSION(pgrid%s_vert:pgrid%e_vert+1) :: alt_u_c REAL, DIMENSION(ngrid%s_vert:ngrid%e_vert) :: alt_w_n REAL, DIMENSION(ngrid%s_vert:ngrid%e_vert+1) :: alt_u_n + + REAL, DIMENSION(:,:,:), ALLOCATABLE :: p, al + REAL :: pfu, pfd, phm, temp, qvf, qvf1, qvf2 !KAL change this for vertical nesting ! force_domain_em_part1 packs up the interpolation onto the coarse (vertical) grid @@ -3553,8 +4107,8 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe ) - - !KAL this is the original WRF code + + !KAL this is the original WRF code !CALL get_ijk_from_grid ( grid , & ! cids, cide, cjds, cjde, ckds, ckde, & ! cims, cime, cjms, cjme, ckms, ckme, & @@ -3571,12 +4125,12 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags & if (ngrid%vert_refine_method .NE. 0) then !KAL calculating the vertical coordinate for parent and nest grid (code from ndown) - ! assume that the parent and nest have the same p_top value (as in ndown) + ! assume that the parent and nest have the same p_top value (as in ndown) !KAL ckde is equal to e_vert of the coarse grid. There are e_vert-1 u points. The coarse 1D grid here is e_vert+1, ! so it is the e_vert-1 points from the coarse grid, plus a surface point plus a top point. Extrapolation coefficients ! are used to get the surface and top points to fill out the pro_u_c 1D array of u values from the coarse grid. - + hsca_m = 6.7 !KAL scale height of the atmosphere p_top_m = ngrid%p_top p_surf_m = 1.e5 @@ -3611,19 +4165,187 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe ) - + CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) -if (ngrid%vert_refine_method .NE. 0) then + ! Vertical refinement is turned on. + + IF (ngrid%vert_refine_method .NE. 0) THEN -!KAL added this code (the include file) for the vertical nesting #include "nest_forcedown_interp_vert.inc" -endif - + IF ( ngrid%this_is_an_ideal_run ) THEN + IF ( SIZE( grid%t_init, 1 ) * SIZE( grid%t_init, 3 ) .GT. 1 ) THEN + CALL vert_interp_vert_nesting( grid%t_init, & !CD field + ids, ide, kds, kde, jds, jde, & !CD dims + ims, ime, kms, kme, jms, jme, & !CD dims + ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & !CD dims + pgrid%s_vert, pgrid%e_vert, & !vertical dimension of the parent grid + pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & !coarse grid extrapolation constants + alt_u_c, alt_u_n ) !coordinates for parent and nest + END IF ! Check t_init is a fully allocated 3d array. + END IF ! only for ideal runs + + + ! Rebalance the grid on the intermediate grid. The intermediate grid has the horizontal + ! resolution of the parent grid, but at this point has been interpolated in the vertical + ! to the resolution of the nest. The base state (phb, pb, etc) from the parent grid is + ! unpacked onto the intermediate grid every time this subroutine is called. We need the + ! base state of the nest, so it is recalculated here. + + ! Additionally, we do not need to vertically interpolate the entire intermediate grid + ! above, just the points that contribute to the boundary forcing. + + ! Base state potential temperature and inverse density (alpha = 1/rho) from + ! the half eta levels and the base-profile surface pressure. Compute 1/rho + ! from equation of state. The potential temperature is a perturbation from t0. + + ! Uncouple the variables moist and t_2 that are used to calculate ph_2 + + DO j = jps,jpe + DO i = ips,ipe + DO k=kps,kpe-1 + grid%t_2(i,k,j) = grid%t_2(i,k,j)/(grid%mub(i,j) + grid%mu_2(i,j)) + moist(i,k,j,P_QV) = moist(i,k,j,P_QV)/(grid%mub(i,j) + grid%mu_2(i,j)) + END DO + END DO + END DO + + DO j = jps, jpe + DO i = ips,ipe + + DO k = 1, kpe-1 + grid%pb(i,k,j) = ngrid%znu(k)*grid%mub(i,j)+ngrid%p_top + + ! If this is a real run, recalc t_init. + + IF ( .NOT. ngrid%this_is_an_ideal_run ) THEN + temp = MAX ( ngrid%tiso, ngrid%t00 + ngrid%tlp*LOG(grid%pb(i,k,j)/ngrid%p00) ) + IF ( grid%pb(i,k,j) .LT. ngrid%p_strat ) THEN + temp = ngrid%tiso + ngrid%tlp_strat * LOG ( grid%pb(i,k,j)/ngrid%p_strat ) + END IF + grid%t_init(i,k,j) = temp*(ngrid%p00/grid%pb(i,k,j))**(r_d/cp) - t0 + END IF + grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm + END DO + + ! Integrate base geopotential, starting at terrain elevation. This assures that + ! the base state is in exact hydrostatic balance with respect to the model equations. + ! This field is on full levels. + + grid%phb(i,1,j) = grid%ht(i,j) * g + IF (grid%hypsometric_opt == 1) THEN + DO k = 2,kpe + grid%phb(i,k,j) = grid%phb(i,k-1,j) - ngrid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j) + END DO + ELSE IF (grid%hypsometric_opt == 2) THEN + DO k = 2,kpe + pfu = grid%mub(i,j)*ngrid%znw(k) + ngrid%p_top + pfd = grid%mub(i,j)*ngrid%znw(k-1) + ngrid%p_top + phm = grid%mub(i,j)*ngrid%znu(k-1) + ngrid%p_top + grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu) + END DO + ELSE + CALL wrf_error_fatal( 'module_dm: hypsometric_opt should be 1 or 2' ) + END IF ! which hypsometric option + END DO ! i loop + END DO ! j loop + + ! Perturbation fields + + ALLOCATE( p (ips:ipe, kps:kpe, jps:jpe) ) + ALLOCATE( al(ips:ipe, kps:kpe, jps:jpe) ) + + DO j = jps, jpe + DO i = ips, ipe + + ! Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum + ! equation) down from the top to get the pressure perturbation. First get the pressure + ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. + + k = kpe-1 + + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + + p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/ngrid%rdnw(k)/qvf2 + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + al(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* & + (((p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%alb(i,k,j) + + ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two + ! inverse density fields (total and perturbation). + + DO k=kpe-2,1,-1 + qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + qvf2 = 1./(1.+qvf1) + qvf1 = qvf1*qvf2 + p(i,k,j) = p(i,k+1,j) - (grid%mu_2(i,j) + qvf1*grid%mub(i,j))/qvf2/ngrid%rdn(k+1) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + al(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* & + (((p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%alb(i,k,j) + END DO + + ! This is the hydrostatic equation used in the model after the small timesteps. In + ! the model, grid%al (inverse density) is computed from the geopotential. + + IF (grid%hypsometric_opt == 1) THEN + DO k = 2,kpe + grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - & + ngrid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*al(i,k-1,j) & + + grid%mu_2(i,j)*grid%alb(i,k-1,j) ) + END DO + + ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure. + ! Note that al*p approximates Rd*T and dLOG(p) does z. + ! Here T varies mostly linear with z, the first-order integration produces better result. + + ELSE IF (grid%hypsometric_opt == 2) THEN + + grid%ph_2(i,1,j) = grid%phb(i,1,j) + DO k = 2,kpe + pfu = ( grid%mub(i,j)+grid%mu_2(i,j))*ngrid%znw(k) + ngrid%p_top + pfd = ( grid%mub(i,j)+grid%mu_2(i,j))*ngrid%znw(k-1) + ngrid%p_top + phm = ( grid%mub(i,j)+grid%mu_2(i,j))*ngrid%znu(k-1) + ngrid%p_top + grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + (grid%alb(i,k-1,j)+al(i,k-1,j))*phm*LOG(pfd/pfu) + END DO + + DO k = 1,kpe + grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j) + END DO + + END IF + + END DO ! i loop + END DO ! j loop + + DEALLOCATE(p) + DEALLOCATE(al) + + ! Couple the variables moist and t_2, and the newly calculated ph_2 + DO j = jps, jpe + DO i = ips,ipe + DO k=kps,kpe + grid%ph_2(i,k,j) = grid%ph_2(i,k,j)*(grid%mub(i,j) + grid%mu_2(i,j)) + END DO + END DO + END DO + DO j = jps, jpe + DO i = ips,ipe + DO k=kps,kpe-1 + grid%t_2(i,k,j) = grid%t_2(i,k,j)*(grid%mub(i,j) + grid%mu_2(i,j)) + moist(i,k,j,P_QV) = moist(i,k,j,P_QV)*(grid%mub(i,j) + grid%mu_2(i,j)) + END DO + END DO + END DO + + + END IF + #include "HALO_FORCE_DOWN.inc" @@ -3644,6 +4366,8 @@ SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, & + nest_task_offsets, nest_pes_x, nest_pes_y, which_kid, & + intercomm_active, mpi_comm_to_kid, mpi_comm_to_mom, & mytask, get_dm_max_halo_width USE module_timing IMPLICIT NONE @@ -3651,7 +4375,7 @@ SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k INTEGER iparstrt,jparstrt,sw @@ -3672,6 +4396,7 @@ SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr INTEGER thisdomain_max_halo_width INTEGER local_comm, myproc, nproc + INTEGER ioffset, ierr CALL wrf_get_dm_communicator ( local_comm ) CALL wrf_get_myproc( myproc ) @@ -3704,9 +4429,28 @@ SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags ! get max_halo_width for parent. It may be smaller if it is moad CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width ) + IF ( grid%active_this_task ) THEN #include "nest_interpdown_pack.inc" + END IF + + ! determine which communicator and offset to use + IF ( intercomm_active( grid%id ) ) THEN ! I am parent + local_comm = mpi_comm_to_kid( which_kid(ngrid%id), grid%id ) + ioffset = nest_task_offsets(ngrid%id) + ELSE IF ( intercomm_active( ngrid%id ) ) THEN ! I am nest + local_comm = mpi_comm_to_mom( ngrid%id ) + ioffset = nest_task_offsets(ngrid%id) + END IF - CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm ) + IF ( grid%active_this_task .OR. ngrid%active_this_task ) THEN +#ifndef STUBMPI + CALL mpi_comm_rank(local_comm,myproc,ierr) + CALL mpi_comm_size(local_comm,nproc,ierr) +#endif + CALL rsl_lite_bcast_msgs( myproc, nest_pes_x(grid%id)*nest_pes_y(grid%id), & + nest_pes_x(ngrid%id)*nest_pes_y(ngrid%id), & + ioffset, local_comm ) + END IF RETURN END SUBROUTINE interp_domain_em_part1 @@ -3722,14 +4466,15 @@ SUBROUTINE interp_domain_em_part2 ( grid, ngrid, pgrid, config_flags & USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, & - mytask, get_dm_max_halo_width + mytask, get_dm_max_halo_width, which_kid + ! push_communicators_for_domain,pop_communicators_for_domain USE module_comm_nesting_dm, ONLY : halo_interp_down_sub IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid TYPE(domain), POINTER :: pgrid !KAL added for vertical nesting -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -3786,12 +4531,12 @@ SUBROUTINE interp_domain_em_part2 ( grid, ngrid, pgrid, config_flags & if (ngrid%vert_refine_method .NE. 0) then !KAL calculating the vertical coordinate for parent and nest grid (code from ndown) - ! assume that the parent and nest have the same p_top value (as in ndown) + ! assume that the parent and nest have the same p_top value (as in ndown) !KAL ckde is equal to e_vert of the coarse grid. There are e_vert-1 u points. The coarse 1D grid here is e_vert+1, ! so it is the e_vert-1 points from the coarse grid, plus a surface point plus a top point. Extrapolation coefficients ! are used to get the surface and top points to fill out the pro_u_c 1D array of u values from the coarse grid. - + hsca_m = 6.7 !KAL scale height of the atmosphere p_top_m = ngrid%p_top p_surf_m = 1.e5 @@ -3841,52 +4586,55 @@ SUBROUTINE interp_domain_em_part2 ( grid, ngrid, pgrid, config_flags & !KAL finish off the 1-D variables (t_base, u_base, v_base, qv_base, and z_base) (move this out of here if alt_u_c and alt_u_n are calculated elsewhere) - CALL vert_interp_vert_nesting_1d ( & - ngrid%t_base, & ! CD field - ids, ide, kds, kde, jds, jde, & ! CD dims - ims, ime, kms, kme, jms, jme, & ! CD dims - ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims - pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid - pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants - alt_u_c, alt_u_n) ! coordinates for parent and nest - CALL vert_interp_vert_nesting_1d ( & - ngrid%u_base, & ! CD field - ids, ide, kds, kde, jds, jde, & ! CD dims - ims, ime, kms, kme, jms, jme, & ! CD dims - ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims - pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid - pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants - alt_u_c, alt_u_n) ! coordinates for parent and nest - CALL vert_interp_vert_nesting_1d ( & - ngrid%v_base, & ! CD field - ids, ide, kds, kde, jds, jde, & ! CD dims - ims, ime, kms, kme, jms, jme, & ! CD dims - ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims - pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid - pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants - alt_u_c, alt_u_n) ! coordinates for parent and nest - CALL vert_interp_vert_nesting_1d ( & - ngrid%qv_base, & ! CD field - ids, ide, kds, kde, jds, jde, & ! CD dims - ims, ime, kms, kme, jms, jme, & ! CD dims - ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims - pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid - pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants - alt_u_c, alt_u_n) ! coordinates for parent and nest - CALL vert_interp_vert_nesting_1d ( & - ngrid%z_base, & ! CD field - ids, ide, kds, kde, jds, jde, & ! CD dims - ims, ime, kms, kme, jms, jme, & ! CD dims - ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims - pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid - pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants - alt_u_c, alt_u_n) ! coordinates for parent and nest + CALL vert_interp_vert_nesting_1d ( & + ngrid%t_base, & ! CD field + ids, ide, kds, kde, jds, jde, & ! CD dims + ims, ime, kms, kme, jms, jme, & ! CD dims + ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims + pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid + pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) ! coordinates for parent and nest + CALL vert_interp_vert_nesting_1d ( & + ngrid%u_base, & ! CD field + ids, ide, kds, kde, jds, jde, & ! CD dims + ims, ime, kms, kme, jms, jme, & ! CD dims + ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims + pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid + pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) ! coordinates for parent and nest + CALL vert_interp_vert_nesting_1d ( & + ngrid%v_base, & ! CD field + ids, ide, kds, kde, jds, jde, & ! CD dims + ims, ime, kms, kme, jms, jme, & ! CD dims + ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims + pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid + pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) ! coordinates for parent and nest + CALL vert_interp_vert_nesting_1d ( & + ngrid%qv_base, & ! CD field + ids, ide, kds, kde, jds, jde, & ! CD dims + ims, ime, kms, kme, jms, jme, & ! CD dims + ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims + pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid + pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) ! coordinates for parent and nest + CALL vert_interp_vert_nesting_1d ( & + ngrid%z_base, & ! CD field + ids, ide, kds, kde, jds, jde, & ! CD dims + ims, ime, kms, kme, jms, jme, & ! CD dims + ips, ipe, kps, MIN( (kde-1), kpe ), jps, jpe, & ! CD dims + pgrid%s_vert, pgrid%e_vert, & ! vertical dimension of the parent grid + pgrid%cf1, pgrid%cf2, pgrid%cf3, pgrid%cfn, pgrid%cfn1, & ! coarse grid extrapolation constants + alt_u_c, alt_u_n) ! coordinates for parent and nest endif - + + CALL push_communicators_for_domain( grid%id ) #include "HALO_INTERP_DOWN.inc" + CALL pop_communicators_for_domain + # include "nest_interpdown_interp.inc" RETURN @@ -3904,14 +4652,16 @@ SUBROUTINE interp_domain_em_small_part1 ( grid, intermediate_grid, ngrid, config USE module_configure, ONLY : grid_config_rec_type USE module_comm_dm, ONLY: halo_em_horiz_interp_sub USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, & - mytask, get_dm_max_halo_width + mytask, get_dm_max_halo_width, & + nest_task_offsets, mpi_comm_to_kid, mpi_comm_to_mom, & + which_kid, nest_pes_x, nest_pes_y, intercomm_active USE module_timing IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k INTEGER iparstrt,jparstrt,sw @@ -3936,6 +4686,7 @@ SUBROUTINE interp_domain_em_small_part1 ( grid, intermediate_grid, ngrid, config INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr INTEGER thisdomain_max_halo_width INTEGER local_comm, myproc, nproc + INTEGER ioffset CALL wrf_get_dm_communicator ( local_comm ) CALL wrf_get_myproc( myproc ) @@ -3999,59 +4750,59 @@ SUBROUTINE interp_domain_em_small_part1 ( grid, intermediate_grid, ngrid, config !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, ph_2') DO k = ckds,ckde xv(k)= grid%ph_2(pig,k,pjg) - ENDDO + END DO CALL rsl_lite_to_child_msg(((ckde)-(ckds)+1)*RWORDSIZE,xv) - ENDIF + END IF IF ( SIZE(grid%t_2) .GT. 1 ) THEN !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, t_2') DO k = ckds,(ckde-1) xv(k)= grid%t_2(pig,k,pjg) - ENDDO + END DO CALL rsl_lite_to_child_msg((((ckde-1))-(ckds)+1)*RWORDSIZE,xv) - ENDIF + END IF IF ( SIZE(grid%ht) .GT. 1 ) THEN !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, ht') xv(1)= grid%ht(pig,pjg) CALL rsl_lite_to_child_msg(RWORDSIZE,xv) - ENDIF + END IF IF ( SIZE(grid%t_max_p) .GT. 1 ) THEN !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, t_max_p') xv(1)= grid%t_max_p(pig,pjg) CALL rsl_lite_to_child_msg(RWORDSIZE,xv) - ENDIF + END IF IF ( SIZE(grid%ght_max_p) .GT. 1 ) THEN !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, ght_max_p') xv(1)= grid%ght_max_p(pig,pjg) CALL rsl_lite_to_child_msg(RWORDSIZE,xv) - ENDIF + END IF IF ( SIZE(grid%max_p) .GT. 1 ) THEN !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, max_p') xv(1)= grid%max_p(pig,pjg) CALL rsl_lite_to_child_msg(RWORDSIZE,xv) - ENDIF + END IF IF ( SIZE(grid%t_min_p) .GT. 1 ) THEN !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, t_min_p') xv(1)= grid%t_min_p(pig,pjg) CALL rsl_lite_to_child_msg(RWORDSIZE,xv) - ENDIF + END IF IF ( SIZE(grid%ght_min_p) .GT. 1 ) THEN !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, ght_min_p') xv(1)= grid%ght_min_p(pig,pjg) CALL rsl_lite_to_child_msg(RWORDSIZE,xv) - ENDIF + END IF IF ( SIZE(grid%min_p) .GT. 1 ) THEN !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, min_p') xv(1)= grid%min_p(pig,pjg) CALL rsl_lite_to_child_msg(RWORDSIZE,xv) - ENDIF + END IF !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, calling rsl_lite_to_child_info') CALL rsl_lite_to_child_info( local_communicator, msize*RWORDSIZE & @@ -4065,10 +4816,21 @@ SUBROUTINE interp_domain_em_small_part1 ( grid, intermediate_grid, ngrid, config ,idim_cd,jdim_cd & ,pig,pjg,retval ) !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, back from rsl_lite_to_child_info') - ENDDO + END DO + + ! determine which communicator and offset to use + IF ( intercomm_active( grid%id ) ) THEN ! I am parent + local_comm = mpi_comm_to_kid( which_kid(ngrid%id), grid%id ) + ioffset = nest_task_offsets(ngrid%id) + ELSE IF ( intercomm_active( ngrid%id ) ) THEN ! I am nest + local_comm = mpi_comm_to_mom( ngrid%id ) + ioffset = nest_task_offsets(ngrid%id) + END IF !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, calling rsl_lite_bcast') - CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm ) + CALL rsl_lite_bcast_msgs( myproc, nest_pes_x(grid%id)*nest_pes_y(grid%id), & + nest_pes_x(ngrid%id)*nest_pes_y(ngrid%id), & + ioffset, local_comm ) !call wrf_debug(0,'/external/RSL_LITE/module_dm.F, back from rsl_lite_bcast') RETURN @@ -4091,7 +4853,7 @@ SUBROUTINE interp_domain_em_small_part2 ( grid, ngrid, config_flags & ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -4133,54 +4895,54 @@ SUBROUTINE interp_domain_em_small_part2 ( grid, ngrid, config_flags & CALL rsl_lite_from_parent_msg(((ckde)-(ckds)+1)*RWORDSIZE,xv) DO k = ckds,ckde grid%ph_2(pig,k,pjg) = xv(k) - ENDDO - ENDIF + END DO + END IF IF ( SIZE(grid%t_2) .GT. 1 ) THEN CALL rsl_lite_from_parent_msg((((ckde-1))-(ckds)+1)*RWORDSIZE,xv) DO k = ckds,(ckde-1) grid%t_2(pig,k,pjg) = xv(k) - ENDDO - ENDIF + END DO + END IF IF ( SIZE(grid%ht) .GT. 1 ) THEN CALL rsl_lite_from_parent_msg(RWORDSIZE,xv) grid%ht(pig,pjg) = xv(1) - ENDIF + END IF IF ( SIZE(grid%t_max_p) .GT. 1 ) THEN CALL rsl_lite_from_parent_msg(RWORDSIZE,xv) grid%t_max_p(pig,pjg) = xv(1) - ENDIF + END IF IF ( SIZE(grid%ght_max_p) .GT. 1 ) THEN CALL rsl_lite_from_parent_msg(RWORDSIZE,xv) grid%ght_max_p(pig,pjg) = xv(1) - ENDIF + END IF IF ( SIZE(grid%max_p) .GT. 1 ) THEN CALL rsl_lite_from_parent_msg(RWORDSIZE,xv) grid%max_p(pig,pjg) = xv(1) - ENDIF + END IF IF ( SIZE(grid%t_min_p) .GT. 1 ) THEN CALL rsl_lite_from_parent_msg(RWORDSIZE,xv) grid%t_min_p(pig,pjg) = xv(1) - ENDIF + END IF IF ( SIZE(grid%ght_min_p) .GT. 1 ) THEN CALL rsl_lite_from_parent_msg(RWORDSIZE,xv) grid%ght_min_p(pig,pjg) = xv(1) - ENDIF + END IF IF ( SIZE(grid%min_p) .GT. 1 ) THEN CALL rsl_lite_from_parent_msg(RWORDSIZE,xv) grid%min_p(pig,pjg) = xv(1) - ENDIF + END IF CALL rsl_lite_from_parent_info(pig,pjg,retval) - ENDDO + END DO CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & @@ -4244,7 +5006,8 @@ SUBROUTINE feedback_nest_prep ( grid, config_flags & USE module_state_description USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type - USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask + USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask !, & + !push_communicators_for_domain, pop_communicators_for_domain USE module_comm_nesting_dm, ONLY : halo_interp_up_sub IMPLICIT NONE ! @@ -4252,7 +5015,7 @@ SUBROUTINE feedback_nest_prep ( grid, config_flags & TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of ! soil temp, moisture, etc., has vertical dim ! of soil categories -#include +#include "dummy_new_decl.inc" INTEGER :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4268,10 +5031,16 @@ SUBROUTINE feedback_nest_prep ( grid, config_flags & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) + IF ( grid%active_this_task ) THEN + CALL push_communicators_for_domain( grid%id ) + #ifdef DM_PARALLEL #include "HALO_INTERP_UP.inc" #endif + CALL pop_communicators_for_domain + END IF + END SUBROUTINE feedback_nest_prep !------------------------------------------------------------------ @@ -4285,13 +5054,14 @@ SUBROUTINE feedback_domain_em_part1 ( grid, ngrid, config_flags & USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save + ipe_save, jpe_save, ips_save, jps_save, & + nest_pes_x, nest_pes_y IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE(domain), POINTER :: xgrid @@ -4324,7 +5094,7 @@ SUBROUTINE feedback_nest_prep ( grid, config_flags & ! TYPE (grid_config_rec_type) :: config_flags TYPE(domain), TARGET :: grid -#include +#include "dummy_new_decl.inc" END SUBROUTINE feedback_nest_prep END INTERFACE ! @@ -4393,7 +5163,12 @@ SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_fl USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type, model_config_rec USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width, & + nest_pes_x, nest_pes_y, & + intercomm_active, nest_task_offsets, & + mpi_comm_to_mom, mpi_comm_to_kid, which_kid !, & + !push_communicators_for_domain, pop_communicators_for_domain + USE module_comm_nesting_dm, ONLY : halo_interp_up_sub USE module_utility IMPLICIT NONE @@ -4402,8 +5177,9 @@ SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_fl TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid + TYPE(domain), POINTER :: parent_grid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -4414,6 +5190,9 @@ SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_fl INTEGER :: nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nips, nipe, njps, njpe, nkps, nkpe + INTEGER :: xids, xide, xjds, xjde, xkds, xkde, & + xims, xime, xjms, xjme, xkms, xkme, & + xips, xipe, xjps, xjpe, xkps, xkpe INTEGER :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe @@ -4421,7 +5200,7 @@ SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_fl INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7 INTEGER icoord, jcoord, idim_cd, jdim_cd - INTEGER local_comm, myproc, nproc + INTEGER local_comm, myproc, nproc, ioffset INTEGER iparstrt, jparstrt, sw, thisdomain_max_halo_width REAL nest_influence @@ -4458,8 +5237,22 @@ SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_fl nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nips, nipe, njps, njpe, nkps, nkpe ) + CALL get_ijk_from_grid ( ngrid , & + xids, xide, xjds, xjde, xkds, xkde, & + xims, xime, xjms, xjme, xkms, xkme, & + xips, xipe, xjps, xjpe, xkps, xkpe ) + + ips_save = ngrid%i_parent_start ! used in feedback_domain_em_part2 below + jps_save = ngrid%j_parent_start + ipe_save = ngrid%i_parent_start + (xide-xids+1) / ngrid%parent_grid_ratio - 1 + jpe_save = ngrid%j_parent_start + (xjde-xjds+1) / ngrid%parent_grid_ratio - 1 + + + +IF ( ngrid%active_this_task ) THEN !cyl add this for trajectory + CALL push_communicators_for_domain( ngrid%id ) do tjk = 1,config_flags%num_traj if (ngrid%traj_long(tjk) .eq. -9999.0) then @@ -4493,13 +5286,41 @@ SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_fl CALL get_dm_max_halo_width ( grid%id , thisdomain_max_halo_width ) + parent_grid => grid + grid => ngrid #include "nest_feedbackup_pack.inc" + grid => parent_grid + CALL pop_communicators_for_domain + +END IF + +! CALL wrf_get_dm_communicator ( local_comm ) +! CALL wrf_get_myproc( myproc ) +! CALL wrf_get_nproc( nproc ) + + ! determine which communicator and offset to use + IF ( intercomm_active( grid%id ) ) THEN ! I am parent + local_comm = mpi_comm_to_kid( which_kid(ngrid%id), grid%id ) + ioffset = nest_task_offsets(ngrid%id) + ELSE IF ( intercomm_active( ngrid%id ) ) THEN ! I am nest + local_comm = mpi_comm_to_mom( ngrid%id ) + ioffset = nest_task_offsets(ngrid%id) + END IF - CALL wrf_get_dm_communicator ( local_comm ) - CALL wrf_get_myproc( myproc ) - CALL wrf_get_nproc( nproc ) + IF ( grid%active_this_task .OR. ngrid%active_this_task ) THEN +#ifndef STUBMPI + CALL mpi_comm_rank(local_comm,myproc,ierr) + CALL mpi_comm_size(local_comm,nproc,ierr) +#endif +!call tracebackqq() + CALL rsl_lite_merge_msgs( myproc, nest_pes_x(grid%id)*nest_pes_y(grid%id), & + nest_pes_x(ngrid%id)*nest_pes_y(ngrid%id), & + ioffset, local_comm ) + END IF + +IF ( grid%active_this_task ) THEN + CALL push_communicators_for_domain( grid%id ) - CALL rsl_lite_merge_msgs( myproc, nproc, local_comm ) #define NEST_INFLUENCE(A,B) A = B #include "nest_feedbackup_unpack.inc" @@ -4523,6 +5344,9 @@ SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid, ngrid , config_fl #include "nest_feedbackup_smooth.inc" + CALL pop_communicators_for_domain +END IF + RETURN END SUBROUTINE feedback_domain_em_part2 #endif @@ -4544,13 +5368,16 @@ SUBROUTINE before_interp_halos_nmm(grid,config_flags & USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width, & + nest_pes_x, nest_pes_y !, & + !push_communicators_for_domain, pop_communicators_for_domain USE module_comm_dm, ONLY : HALO_NMM_WEIGHTS_sub + IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE (grid_config_rec_type) :: config_flags -#include +#include "dummy_new_decl.inc" INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE, & IMS,IME,JMS,JME,KMS,KME, & IPS,IPE,JPS,JPE,KPS,KPE @@ -4564,7 +5391,6 @@ SUBROUTINE before_interp_halos_nmm(grid,config_flags & #include "deref_kludge.h" !#define COPY_IN -!#include ! FIXME: Don't initialize these to -1; it is a waste. ! Initialization is only for debugging purposes. @@ -4576,7 +5402,10 @@ SUBROUTINE before_interp_halos_nmm(grid,config_flags & & ,IMS,IME,JMS,JME,KMS,KME & & ,IPS,IPE,JPS,JPE,KPS,KPE ) + CALL push_communicators_for_domain(grid%id) #include "HALO_NMM_WEIGHTS.inc" + CALL pop_communicators_for_domain + END SUBROUTINE before_interp_halos_nmm SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags & @@ -4588,14 +5417,21 @@ SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flag USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width, & + nest_pes_x, nest_pes_y + USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, local_communicator, mytask, & + nest_pes_x, nest_pes_y, & + intercomm_active, nest_task_offsets, & + mpi_comm_to_mom, mpi_comm_to_kid, which_kid !, & + !push_communicators_for_domain,pop_communicators_for_domain + USE module_timing IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k INTEGER iparstrt,jparstrt,sw @@ -4614,7 +5450,7 @@ SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flag INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7 LOGICAL feedback_flag, feedback_flag_v INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr - INTEGER local_comm, myproc, nproc + INTEGER local_comm, ioffset, myproc, nproc, ierr INTEGER thisdomain_max_halo_width LOGICAL interp_mp @@ -4624,9 +5460,6 @@ SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flag CALL wrf_get_myproc( myproc ) CALL wrf_get_nproc( nproc ) -!#define COPY_IN -!#include - CALL get_ijk_from_grid ( grid , & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & @@ -4651,13 +5484,33 @@ SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flag nlev = ckde - ckds + 1 + ! get max_halo_width for parent. It may be smaller if it is moad CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width ) + + IF ( grid%active_this_task ) THEN #include "nest_interpdown_pack.inc" + END IF - CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm ) + ! determine which communicator and offset to use + IF ( intercomm_active( grid%id ) ) THEN ! I am parent + local_comm = mpi_comm_to_kid( which_kid(ngrid%id), grid%id ) + ioffset = nest_task_offsets(ngrid%id) + ELSE IF ( intercomm_active( ngrid%id ) ) THEN ! I am nest + local_comm = mpi_comm_to_mom( ngrid%id ) + ioffset = nest_task_offsets(ngrid%id) + END IF + + IF ( grid%active_this_task .OR. ngrid%active_this_task ) THEN +#ifndef STUBMPI + CALL mpi_comm_rank(local_comm,myproc,ierr) + CALL mpi_comm_size(local_comm,nproc,ierr) +#endif +!CALL tracebackqq() + CALL rsl_lite_bcast_msgs( myproc, nest_pes_x(grid%id)*nest_pes_y(grid%id), & + nest_pes_x(ngrid%id)*nest_pes_y(ngrid%id), & + ioffset, local_comm ) + END IF -!#define COPY_OUT -!#include RETURN END SUBROUTINE interp_domain_nmm_part1 @@ -4672,13 +5525,15 @@ SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags & USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width , & + nest_task_offsets + !push_communicators_for_domain,pop_communicators_for_domain, & USE module_comm_nesting_dm, ONLY : halo_interp_down_sub IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -4699,58 +5554,61 @@ SUBROUTINE interp_domain_nmm_part2 ( grid, ngrid, config_flags & INTEGER ierr integer, parameter :: EConst=0, ECopy=1, EExtrap=2 ! MUST match module_interp_nmm -!#ifdef DEREF_KLUDGE -!! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm -! INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 -! INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x -! INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y -!#endif LOGICAL interp_mp #include "deref_kludge.h" + +! interp_mp is set unconditionally in alloc_and_configure_domain (module_domain.F), +! regardless of active_this_task interp_mp=grid%interp_mp .or. ngrid%interp_mp -!#define COPY_IN -!#include - CALL get_ijk_from_grid ( grid , & - cids, cide, cjds, cjde, ckds, ckde, & - cims, cime, cjms, cjme, ckms, ckme, & - cips, cipe, cjps, cjpe, ckps, ckpe ) - CALL get_ijk_from_grid ( ngrid , & - nids, nide, njds, njde, nkds, nkde, & - nims, nime, njms, njme, nkms, nkme, & - nips, nipe, njps, njpe, nkps, nkpe ) + IF ( ngrid%active_this_task ) THEN + + CALL get_ijk_from_grid ( grid , & + cids, cide, cjds, cjde, ckds, ckde, & + cims, cime, cjms, cjme, ckms, ckme, & + cips, cipe, cjps, cjpe, ckps, ckpe ) + CALL get_ijk_from_grid ( ngrid , & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nips, nipe, njps, njpe, nkps, nkpe ) - nlev = ckde - ckds + 1 + + nlev = ckde - ckds + 1 #include "nest_interpdown_unpack.inc" - CALL get_ijk_from_grid ( grid , & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe ) + CALL get_ijk_from_grid ( grid , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe ) + CALL push_communicators_for_domain( grid%id ) #include "HALO_INTERP_DOWN.inc" ! Generate interpolation information and interpolate Q, T and ! possibly PD while we're at it: - call store_interp_info(ngrid,grid) - call ext_c2n_fulldom(ngrid%IIH,ngrid%JJH,ngrid%HBWGT1, & - ngrid%HBWGT2,ngrid%HBWGT3,ngrid%HBWGT4, & - ngrid%deta1,ngrid%deta2,ngrid%eta1, & - ngrid%eta2,ngrid%pt,ngrid%pdtop, & - grid%pint,grid%t,grid%pd,grid%q, & - cims, cime, cjms, cjme, ckms, ckme, & - ngrid%pint,ngrid%t,ngrid%pd,ngrid%q,& - ngrid%iinfo,ngrid%winfo,ngrid%imask_nostag, & - nids, nide, njds, njde, nkds, nkde, & - nims, nime, njms, njme, nkms, nkme, & - nips, nipe, njps, njpe, nkps, nkpe) +! Grid is set to ngrid%intermediate_grid in the call from med_interp_domain +! (share/mediation_interp_domain.F) so if one is active_this_task, so is the other + call store_interp_info(ngrid,grid) + call ext_c2n_fulldom(ngrid%IIH,ngrid%JJH,ngrid%HBWGT1, & + ngrid%HBWGT2,ngrid%HBWGT3,ngrid%HBWGT4, & + ngrid%deta1,ngrid%deta2,ngrid%eta1, & + ngrid%eta2,ngrid%pt,ngrid%pdtop, & + grid%pint,grid%t,grid%pd,grid%q, & + cims, cime, cjms, cjme, ckms, ckme, & + ngrid%pint,ngrid%t,ngrid%pd,ngrid%q,& + ngrid%iinfo,ngrid%winfo,ngrid%imask_nostag, & + nids, nide, njds, njde, nkds, nkde, & + nims, nime, njms, njme, nkms, nkme, & + nips, nipe, njps, njpe, nkps, nkpe) #include "nest_interpdown_interp.inc" -!#define COPY_OUT -!#include + + CALL pop_communicators_for_domain + + END IF RETURN END SUBROUTINE interp_domain_nmm_part2 @@ -4766,14 +5624,19 @@ SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width, & + nest_pes_x, nest_pes_y, & + intercomm_active, nest_task_offsets, & + mpi_comm_to_mom, mpi_comm_to_kid, which_kid !, & + !push_communicators_for_domain,pop_communicators_for_domain + USE module_timing IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k INTEGER iparstrt,jparstrt,sw @@ -4792,18 +5655,16 @@ SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags INTEGER idim1,idim2,idim3,idim4,idim5,idim6,idim7 LOGICAL feedback_flag, feedback_flag_v INTEGER icoord, jcoord, idim_cd, jdim_cd, pgr - INTEGER local_comm, myproc, nproc + INTEGER local_comm, ioffset, myproc, nproc, ierr INTEGER thisdomain_max_halo_width LOGICAL interp_mp + interp_mp=grid%interp_mp .or. ngrid%interp_mp CALL wrf_get_dm_communicator ( local_comm ) CALL wrf_get_myproc( myproc ) CALL wrf_get_nproc( nproc ) -!#define COPY_IN -!#include - CALL get_ijk_from_grid ( grid , & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & @@ -4829,12 +5690,30 @@ SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags nlev = ckde - ckds + 1 CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width ) + + IF ( grid%active_this_task ) THEN #include "nest_forcedown_pack.inc" + END IF - CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm ) + ! determine which communicator and offset to use + IF ( intercomm_active( grid%id ) ) THEN ! I am parent + local_comm = mpi_comm_to_kid( which_kid(ngrid%id), grid%id ) + ioffset = nest_task_offsets(ngrid%id) + ELSE IF ( intercomm_active( ngrid%id ) ) THEN ! I am nest + local_comm = mpi_comm_to_mom( ngrid%id ) + ioffset = nest_task_offsets(ngrid%id) + END IF + + IF ( grid%active_this_task .OR. ngrid%active_this_task ) THEN +#ifndef STUBMPI + CALL mpi_comm_rank(local_comm,myproc,ierr) + CALL mpi_comm_size(local_comm,nproc,ierr) +#endif + CALL rsl_lite_bcast_msgs( myproc, nest_pes_x(grid%id)*nest_pes_y(grid%id), & + nest_pes_x(ngrid%id)*nest_pes_y(ngrid%id), & + ioffset, local_comm ) + END IF -!#define COPY_OUT -!#include RETURN END SUBROUTINE force_domain_nmm_part1 @@ -4849,19 +5728,22 @@ SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags & USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width, & + nest_pes_x, nest_pes_y !, & + !push_communicators_for_domain,pop_communicators_for_domain + #if (NMM_NEST == 1) USE module_comm_nesting_dm, ONLY : halo_force_down_sub use module_comm_dm, only: HALO_NMM_INTERP_INFO_sub -#ifdef HWRF +# if ( HWRF == 1 ) use module_comm_dm, only: HALO_NMM_FORCE_DOWN_SST_sub -#endif +# endif #endif IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid,cgrid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -4880,23 +5762,13 @@ SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags & REAL dummy_xs, dummy_xe, dummy_ys, dummy_ye LOGICAL feedback_flag, feedback_flag_v -integer myproc - LOGICAL interp_mp integer, parameter :: EConst=0, ECopy=1, EExtrap=2 ! MUST match module_interp_nmm -!#ifdef DEREF_KLUDGE -!! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm -! INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 -! INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x -! INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y -!#endif #include "deref_kludge.h" interp_mp=grid%interp_mp .or. ngrid%interp_mp -!#define COPY_IN -!#include - +IF ( ngrid%active_this_task ) THEN CALL get_ijk_from_grid ( grid , & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & @@ -4906,6 +5778,11 @@ SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags & nims, nime, njms, njme, nkms, nkme, & nips, nipe, njps, njpe, nkps, nkpe ) +!jm as far as I can tell, grid is ngrid%intermediate_domain, so they +!jm should both have the same id, both be active_this_task (if one is) +!jm and use the same communicator. But just to be safe, some extra +!jm pushes and pops of domain communicators littered here. + cgrid=>grid nlev = ckde - ckds + 1 @@ -4916,15 +5793,20 @@ SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) -#ifdef HWRF - IF(ngrid%force_sst(1) == 1) then -#include "HALO_NMM_FORCE_DOWN_SST.inc" - ENDIF + CALL push_communicators_for_domain( grid%id ) + +#if ( HWRF == 1 ) + IF(ngrid%force_sst(1) == 1) then +# include "HALO_NMM_FORCE_DOWN_SST.inc" + END IF #endif #include "HALO_FORCE_DOWN.inc" + CALL pop_communicators_for_domain call store_interp_info(ngrid,grid) + + call ext_c2b_fulldom(ngrid%IIH,ngrid%JJH,ngrid%HBWGT1, & ngrid%HBWGT2,ngrid%HBWGT3,ngrid%HBWGT4, & ngrid%deta1,ngrid%deta2,ngrid%eta1, & @@ -4947,14 +5829,16 @@ SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags & ! Need a halo for interpolation information due to how V grid ! interpolation works: -grid=>ngrid + grid=>ngrid CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) + CALL push_communicators_for_domain( grid%id ) #include "HALO_NMM_INTERP_INFO.inc" + CALL pop_communicators_for_domain -grid=>cgrid + grid=>cgrid CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4962,10 +5846,11 @@ SUBROUTINE force_domain_nmm_part2 ( grid, ngrid, config_flags & ! code here to interpolate the data into the nested domain + CALL push_communicators_for_domain( grid%id ) #include "nest_forcedown_interp.inc" + CALL pop_communicators_for_domain -!#define COPY_OUT -!#include +END IF RETURN END SUBROUTINE force_domain_nmm_part2 @@ -4990,7 +5875,9 @@ SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags & USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width, & + nest_pes_x, nest_pes_y + !push_communicators_for_domain, pop_communicators_for_domain, & USE module_comm_dm, ONLY : HALO_NMM_WEIGHTS_sub USE module_comm_nesting_dm, ONLY : HALO_INTERP_UP_sub @@ -5000,7 +5887,7 @@ SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags & TYPE (grid_config_rec_type) :: config_flags ! configureation flags, has vertical dim of ! soil temp, moisture, etc., has vertical dim ! of soil categories -#include +#include "dummy_new_decl.inc" INTEGER :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -5012,29 +5899,20 @@ SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags & LOGICAL :: interp_mp interp_mp=.true. -!#ifdef DEREF_KLUDGE -!! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm -! INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 -! INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x -! INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y -!#endif #include "deref_kludge.h" -!#define COPY_IN -!#include - CALL get_ijk_from_grid ( grid , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) - + IF ( grid%active_this_task ) THEN + CALL push_communicators_for_domain( grid%id ) #ifdef DM_PARALLEL #include "HALO_INTERP_UP.inc" #include "HALO_NMM_WEIGHTS.inc" #endif - -!#define COPY_OUT -!#include + CALL pop_communicators_for_domain + END IF END SUBROUTINE feedback_nest_prep_nmm @@ -5061,7 +5939,7 @@ SUBROUTINE force_intermediate_nmm ( grid, ngrid, config_flags & TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: cgrid TYPE(domain), POINTER :: ngrid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -5094,7 +5972,6 @@ SUBROUTINE force_intermediate_nmm ( grid, ngrid, config_flags & interp_mp=grid%interp_mp .or. ngrid%interp_mp !#define COPY_IN -!#include CALL get_ijk_from_grid ( grid , & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & @@ -5130,12 +6007,13 @@ SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags & USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width, & + nest_pes_x, nest_pes_y IMPLICIT NONE ! TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: ngrid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize, i_parent_start, j_parent_start INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE(domain), POINTER :: xgrid @@ -5155,12 +6033,6 @@ SUBROUTINE feedback_domain_nmm_part1 ( grid, ngrid, config_flags & integer, parameter :: EConst=0, ECopy=1, EExtrap=2 ! MUST match module_interp_nmm LOGICAL interp_mp -!#ifdef DEREF_KLUDGE -!! see http://www.mmm.ucar.edu/wrf/WG2/topics/deref_kludge.htm -! INTEGER :: sm31 , em31 , sm32 , em32 , sm33 , em33 -! INTEGER :: sm31x, em31x, sm32x, em32x, sm33x, em33x -! INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y -!#endif INTERFACE SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags & @@ -5174,12 +6046,10 @@ SUBROUTINE feedback_nest_prep_nmm ( grid, config_flags & ! TYPE (grid_config_rec_type) :: config_flags TYPE(domain), TARGET :: grid -#include +#include "dummy_new_decl.inc" END SUBROUTINE feedback_nest_prep_nmm END INTERFACE ! -!#define COPY_IN -!#include interp_mp=grid%interp_mp .or. ngrid%interp_mp CALL wrf_get_dm_communicator ( local_comm ) @@ -5254,8 +6124,6 @@ END SUBROUTINE feedback_nest_prep_nmm ! "interp" ngrid onto intermediate grid #include "nest_feedbackup_interp.inc" -!#define COPY_OUT -!#include RETURN END SUBROUTINE feedback_domain_nmm_part1 @@ -5269,9 +6137,14 @@ SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_f USE module_state_description USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type - USE module_dm, ONLY : get_dm_max_halo_width, ips_save, ipe_save, & + USE module_dm, ONLY : get_dm_max_halo_width, ips_save, ipe_save, & jps_save, jpe_save, ntasks, mytask, ntasks_x, ntasks_y, & - local_communicator, itrace + local_communicator, itrace, & + nest_pes_x, nest_pes_y, & + intercomm_active, nest_task_offsets, & + mpi_comm_to_mom, mpi_comm_to_kid, which_kid ! , & + ! push_communicators_for_domain, pop_communicators_for_domain + USE module_comm_nesting_dm, ONLY : halo_interp_up_sub USE module_utility IMPLICIT NONE @@ -5280,8 +6153,9 @@ SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_f TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid + TYPE(domain), POINTER :: parent_grid -#include +#include "dummy_new_decl.inc" INTEGER nlev, msize INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k TYPE (grid_config_rec_type) :: config_flags @@ -5292,6 +6166,9 @@ SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_f INTEGER :: nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nips, nipe, njps, njpe, nkps, nkpe + INTEGER :: xids, xide, xjds, xjde, xkds, xkde, & + xims, xime, xjms, xjme, xkms, xkme, & + xips, xipe, xjps, xjpe, xkps, xkpe INTEGER :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe @@ -5304,7 +6181,7 @@ SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_f INTEGER thisdomain_max_halo_width character*256 :: timestr - integer ierr + integer ioffset, ierr REAL nest_influence LOGICAL feedback_flag, feedback_flag_v @@ -5312,8 +6189,6 @@ SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_f LOGICAL, EXTERNAL :: cd_feedback_mask_v LOGICAL interp_mp -!#define COPY_IN -!#include ! On entry to this routine, ! "grid" refers to the parent domain @@ -5344,10 +6219,22 @@ SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_f nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nips, nipe, njps, njpe, nkps, nkpe ) + CALL get_ijk_from_grid ( ngrid , & + xids, xide, xjds, xjde, xkds, xkde, & + xims, xime, xjms, xjme, xkms, xkme, & + xips, xipe, xjps, xjpe, xkps, xkpe ) + + ips_save = ngrid%i_parent_start + jps_save = ngrid%j_parent_start + ipe_save = ngrid%i_parent_start + (xide-xids) / ngrid%parent_grid_ratio - 1 + jpe_save = ngrid%j_parent_start + (xjde-xjds) / ngrid%parent_grid_ratio - 1 + nide = nide - 1 !dusan njde = njde - 1 !dusan +IF ( ngrid%active_this_task ) THEN + CALL push_communicators_for_domain( ngrid%id ) CALL nl_get_i_parent_start ( intermediate_grid%id, iparstrt ) CALL nl_get_j_parent_start ( intermediate_grid%id, jparstrt ) CALL nl_get_shw ( intermediate_grid%id, sw ) @@ -5359,13 +6246,38 @@ SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_f nlev = ckde - ckds + 1 CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width ) + parent_grid => grid + grid => ngrid #include "nest_feedbackup_pack.inc" + grid => parent_grid + CALL pop_communicators_for_domain +END IF + +! CALL wrf_get_dm_communicator ( local_comm ) +! CALL wrf_get_myproc( myproc ) +! CALL wrf_get_nproc( nproc ) + + ! determine which communicator and offset to use + IF ( intercomm_active( grid%id ) ) THEN ! I am parent + local_comm = mpi_comm_to_kid( which_kid(ngrid%id), grid%id ) + ioffset = nest_task_offsets(ngrid%id) + ELSE IF ( intercomm_active( ngrid%id ) ) THEN ! I am nest + local_comm = mpi_comm_to_mom( ngrid%id ) + ioffset = nest_task_offsets(ngrid%id) + END IF - CALL wrf_get_dm_communicator ( local_comm ) - CALL wrf_get_myproc( myproc ) - CALL wrf_get_nproc( nproc ) + IF ( grid%active_this_task .OR. ngrid%active_this_task ) THEN +#ifndef STUBMPI + CALL mpi_comm_rank(local_comm,myproc,ierr) + CALL mpi_comm_size(local_comm,nproc,ierr) +#endif + CALL rsl_lite_merge_msgs( myproc, nest_pes_x(grid%id)*nest_pes_y(grid%id), & + nest_pes_x(ngrid%id)*nest_pes_y(ngrid%id), & + ioffset, local_comm ) + END IF - CALL rsl_lite_merge_msgs( myproc, nproc, local_comm ) +IF ( grid%active_this_task ) THEN + CALL push_communicators_for_domain( grid%id ) #include "nest_feedbackup_unpack.inc" @@ -5381,17 +6293,23 @@ SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid, ngrid , config_f ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) + before_smooth_halo: if(config_flags%smooth_option/=0) then #include "HALO_INTERP_UP.inc" + endif before_smooth_halo CALL get_ijk_from_grid ( grid , & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe ) + smoother: if(config_flags%smooth_option/=0) then #include "nest_feedbackup_smooth.inc" + endif smoother + + CALL pop_communicators_for_domain +END IF + -!#define COPY_OUT -!#include RETURN END SUBROUTINE feedback_domain_nmm_part2 @@ -5609,7 +6527,7 @@ SUBROUTINE wrf_dm_gatherv ( v, elemsize , km_s, km_e, wordsz ) CALL wrf_dm_gatherv_double(v, elemsize , km_s, km_e) ELSE CALL wrf_dm_gatherv_single(v, elemsize , km_s, km_e) - ENDIF + END IF END SUBROUTINE wrf_dm_gatherv SUBROUTINE wrf_dm_gatherv_double ( v, elemsize , km_s, km_e ) @@ -5637,7 +6555,7 @@ SUBROUTINE wrf_dm_gatherv_double ( v, elemsize , km_s, km_e ) # else DO i = 1,elemsize*(km_e-km_s+1) v_local(i) = v(i+elemsize*km_s-1) - ENDDO + END DO CALL mpi_allgatherv( v_local, & # endif (km_e-km_s+1)*elemsize, & @@ -5679,7 +6597,7 @@ SUBROUTINE wrf_dm_gatherv_single ( v, elemsize , km_s, km_e ) # else DO i = 1,elemsize*(km_e-km_s+1) v_local(i) = v(i+elemsize*km_s-1) - ENDDO + END DO CALL mpi_allgatherv( v_local, & # endif (km_e-km_s+1)*elemsize, & diff --git a/wrfv2_fire/external/RSL_LITE/rsl_bcast.c b/wrfv2_fire/external/RSL_LITE/rsl_bcast.c index a7ac7e3d..55b8acc6 100755 --- a/wrfv2_fire/external/RSL_LITE/rsl_bcast.c +++ b/wrfv2_fire/external/RSL_LITE/rsl_bcast.c @@ -55,6 +55,8 @@ ***************************************************************************/ +#define MAX(a,b) (((a)>(b))?a:b) + #define MOD_9707 #ifndef MS_SUA @@ -107,14 +109,18 @@ static int s_idim_nst ; static int s_jdim_nst ; static int s_irax_n ; static int s_irax_m ; -static int s_ntasks_x ; -static int s_ntasks_y ; +static int s_ntasks_nest_x ; +static int s_ntasks_nest_y ; +static int s_ntasks_par_x ; +static int s_ntasks_par_y ; static rsl_list_t **Plist ; +static int Plist_length = 0 ; static int Psize[RSL_MAXPROC] ; static char *s_parent_msgs ; static int s_parent_msgs_curs ; static int s_remaining ; /* number of bytes left in a parent message before the next point descriptor */ +static int alltasks, offset ; /* add a field to a message outgoing for the specified child domain cell */ /* relies on rsl_ready_bcast having been called already */ @@ -130,13 +136,41 @@ static rsl_list_t *Pptr ; static int s_putmsg = 0 ; #endif +// NOTES for PARALLELNESTING +// This routine is building a list of destination processes to send to on a communicator that . +// It needs the minor number of tasks on the nest's MPI mesh (just pass that in) +// Otherwise it doesn't need a communicator + +RSL_LITE_NESTING_RESET ( + ) +{ + int j ; + + for ( j = 0 ; j < RSL_MAXPROC ; j++ ) { + Ssizes[j] = 0 ; + Sdisplacements[j] = 0 ; + Rsizes[j] = 0 ; + Rdisplacements[j] = 0 ; + } + Rdisplacements[RSL_MAXPROC] = 0 ; + if ( Plist != NULL ) { + for ( j = 0 ; j < Plist_length ; j++ ) { + destroy_list ( &(Plist[j]), NULL ) ; + } + RSL_FREE( Plist ) ; + Plist = NULL ; + } +} + /* parent->nest */ -RSL_LITE_TO_CHILD_INFO ( Fcomm, msize_p, +void RSL_LITE_TO_CHILD_INFO ( msize_p, /* number of tasks in minor dim of nest's mesh */ cips_p, cipe_p, cjps_p, cjpe_p, /* patch dims of SOURCE DOMAIN */ iids_p, iide_p, ijds_p, ijde_p, /* domain dims of INTERMEDIATE DOMAIN */ nids_p, nide_p, njds_p, njde_p, /* domain dims of CHILD DOMAIN */ pgr_p, shw_p , /* nest ratio and stencil half width */ - ntasks_x_p , ntasks_y_p , /* proc counts in x and y */ + offset_p, /* first task of the nest in me_and_mom communicator */ + ntasks_par_x_p , ntasks_par_y_p , /* proc counts in x and y */ + ntasks_nest_x_p , ntasks_nest_y_p , /* proc counts in x and y */ min_subdomain , /* minimum width allowed for a subdomain in a dim ON PARENT */ icoord_p, jcoord_p, idim_cd_p, jdim_cd_p, @@ -144,12 +178,13 @@ RSL_LITE_TO_CHILD_INFO ( Fcomm, msize_p, retval_p ) int_p - Fcomm /* Fortran version of MPI communicator */ - ,cips_p, cipe_p, cjps_p, cjpe_p /* (i) c.d. patch dims */ - ,iids_p, iide_p, ijds_p, ijde_p /* (i) n.n. global dims */ + cips_p, cipe_p, cjps_p, cjpe_p /* (i) c.d. patch dims */ + ,iids_p, iide_p, ijds_p, ijde_p /* (i) n.n. global dims -- in WRF this will be intermediate domain */ ,nids_p, nide_p, njds_p, njde_p /* (i) n.n. global dims */ ,pgr_p /* nesting ratio */ - ,ntasks_x_p , ntasks_y_p /* proc counts in x and y */ + ,offset_p /* first task of the nest in me_and_mom communicator */ + ,ntasks_nest_x_p , ntasks_nest_y_p /* proc counts in x and y */ + ,ntasks_par_x_p , ntasks_par_y_p /* proc counts in x and y */ ,min_subdomain ,icoord_p /* i coordinate of nest in cd */ ,jcoord_p /* j coordinate of nest in cd */ @@ -168,20 +203,31 @@ RSL_LITE_TO_CHILD_INFO ( Fcomm, msize_p, int i, j, ni, nj ; int coords[2] ; int ierr ; -#ifndef STUBMPI - MPI_Comm *comm, dummy_comm ; - comm = &dummy_comm ; - *comm = MPI_Comm_f2c( *Fcomm ) ; + if ( Plist == NULL ) { + s_ntasks_par_x = *ntasks_par_x_p ; + s_ntasks_par_y = *ntasks_par_y_p ; + s_ntasks_nest_x = *ntasks_nest_x_p ; + s_ntasks_nest_y = *ntasks_nest_y_p ; + offset = *offset_p ; + alltasks = MAX( s_ntasks_nest_x*s_ntasks_nest_y + offset, s_ntasks_par_x*s_ntasks_par_y ) ; + +#if 0 +fprintf(stderr,"s_ntasks_par_x %d\n",s_ntasks_par_x) ; +fprintf(stderr,"s_ntasks_par_y %d\n",s_ntasks_par_y) ; +fprintf(stderr,"s_ntasks_nest_x %d\n",s_ntasks_nest_x) ; +fprintf(stderr,"s_ntasks_nest_y %d\n",s_ntasks_nest_y) ; +fprintf(stderr,"%s %d offset %d\n",__FILE__,__LINE__,offset) ; +fprintf(stderr,"%s %d alltasks %d\n",__FILE__,__LINE__,alltasks) ; +fprintf(stderr,"%s %d a %d b %d\n",__FILE__,__LINE__,s_ntasks_nest_x*s_ntasks_nest_y+offset,s_ntasks_par_x*s_ntasks_par_y) ; #endif - if ( Plist == NULL ) { - s_ntasks_x = *ntasks_x_p ; - s_ntasks_y = *ntasks_y_p ; /* construct Plist */ Sendbufsize = 0 ; - Plist = RSL_MALLOC( rsl_list_t * , s_ntasks_x * s_ntasks_y ) ; /* big enough for nest points */ - for ( j = 0 ; j < s_ntasks_x * s_ntasks_y ; j++ ) { + Plist = RSL_MALLOC( rsl_list_t * , alltasks ) ; /* big enough for nest points */ + Plist_length = alltasks ; + /* big enough for the mom and me communicator, which includes tasks for the parent and the nest */ + for ( j = 0 ; j < alltasks ; j++ ) { Plist[j] = NULL ; Sdisplacements[j] = 0 ; Ssizes[j] = 0 ; @@ -196,10 +242,15 @@ RSL_LITE_TO_CHILD_INFO ( Fcomm, msize_p, nj = ( j - (*jcoord_p + *shw_p) ) * *pgr_p + 1 + 1 ; #ifndef STUBMPI - TASK_FOR_POINT ( &ni, &nj, nids_p, nide_p, njds_p, njde_p, &s_ntasks_x, &s_ntasks_y, &Px, &Py, + TASK_FOR_POINT ( &ni, &nj, nids_p, nide_p, njds_p, njde_p, &s_ntasks_nest_x, &s_ntasks_nest_y, &Px, &Py, min_subdomain, min_subdomain, &ierr ) ; - coords[1] = Px ; coords[0] = Py ; - MPI_Cart_rank( *comm, coords, &P ) ; + P = Px + Py * *ntasks_nest_x_p + offset ; +// coords[1] = Px ; coords[0] = Py ; +// MPI_Cart_rank( *comm, coords, &P ) ; +// PARALLELNESTING +// adjust P so that is the rank in the intercomm_to_kid communicator for this parent/nest pair +//fprintf(stderr,"after tfp ni %d nj %d Px %d Py %d P %d ntx %d nty %d\n",ni,nj,Px,Py,P,*ntasks_nest_x_p,*ntasks_nest_y_p) ; + #else P = 0 ; #endif @@ -235,8 +286,8 @@ RSL_LITE_TO_CHILD_INFO ( Fcomm, msize_p, while ( Pptr == NULL ) { Pcurs++ ; - while ( Pcurs < s_ntasks_x * s_ntasks_y && Plist[Pcurs] == NULL ) Pcurs++ ; - if ( Pcurs < s_ntasks_x * s_ntasks_y ) { + while ( Pcurs < alltasks && Plist[Pcurs] == NULL ) Pcurs++ ; + if ( Pcurs < alltasks ) { Sdisplacements[Pcurs] = Sendbufcurs ; Ssizes[Pcurs] = 0 ; Pptr = Plist[Pcurs] ; @@ -262,20 +313,23 @@ RSL_LITE_TO_CHILD_INFO ( Fcomm, msize_p, /********************************************/ /* nest->parent */ -RSL_LITE_TO_PARENT_INFO ( Fcomm, msize_p, +void RSL_LITE_TO_PARENT_INFO ( msize_p, nips_p, nipe_p, njps_p, njpe_p, /* patch dims of SOURCE DOMAIN (CHILD) */ cids_p, cide_p, cjds_p, cjde_p, /* domain dims of TARGET DOMAIN (PARENT) */ - ntasks_x_p , ntasks_y_p , /* proc counts in x and y */ + offset_p, + ntasks_par_x_p , ntasks_par_y_p , /* proc counts in x and y */ + ntasks_nest_x_p , ntasks_nest_y_p , /* proc counts in x and y */ min_subdomain , icoord_p, jcoord_p, idim_cd_p, jdim_cd_p, ig_p, jg_p, retval_p ) int_p - Fcomm /* Fortran version of MPI communicator */ - ,nips_p, nipe_p, njps_p, njpe_p /* (i) n.d. patch dims */ + nips_p, nipe_p, njps_p, njpe_p /* (i) n.d. patch dims */ ,cids_p, cide_p, cjds_p, cjde_p /* (i) n.n. global dims */ - ,ntasks_x_p , ntasks_y_p /* proc counts in x and y */ + ,offset_p + ,ntasks_nest_x_p , ntasks_nest_y_p /* proc counts in x and y */ + ,ntasks_par_x_p , ntasks_par_y_p /* proc counts in x and y */ ,min_subdomain ,icoord_p /* i coordinate of nest in cd */ ,jcoord_p /* j coordinate of nest in cd */ @@ -292,20 +346,20 @@ RSL_LITE_TO_PARENT_INFO ( Fcomm, msize_p, int i, j ; int coords[2] ; int ierr ; -#ifndef STUBMPI - MPI_Comm *comm, dummy_comm ; - - comm = &dummy_comm ; - *comm = MPI_Comm_f2c( *Fcomm ) ; -#endif if ( Plist == NULL ) { - s_ntasks_x = *ntasks_x_p ; - s_ntasks_y = *ntasks_y_p ; + s_ntasks_nest_x = *ntasks_nest_x_p ; + s_ntasks_nest_y = *ntasks_nest_y_p ; + s_ntasks_par_x = *ntasks_par_x_p ; + s_ntasks_par_y = *ntasks_par_y_p ; + offset = *offset_p ; + alltasks = MAX( s_ntasks_nest_x*s_ntasks_nest_y + offset, s_ntasks_par_x*s_ntasks_par_y ) ; + /* construct Plist */ Sendbufsize = 0 ; - Plist = RSL_MALLOC( rsl_list_t * , s_ntasks_x * s_ntasks_y ) ; - for ( j = 0 ; j < s_ntasks_x * s_ntasks_y ; j++ ) { + Plist = RSL_MALLOC( rsl_list_t * , alltasks ) ; + Plist_length = alltasks ; + for ( j = 0 ; j < alltasks ; j++ ) { Plist[j] = NULL ; Sdisplacements[j] = 0 ; Ssizes[j] = 0 ; @@ -317,10 +371,9 @@ RSL_LITE_TO_PARENT_INFO ( Fcomm, msize_p, { if ( ( *jcoord_p <= j && j <= *jcoord_p+*jdim_cd_p-1 ) && ( *icoord_p <= i && i <= *icoord_p+*idim_cd_p-1 ) ) { #ifndef STUBMPI - TASK_FOR_POINT ( &i, &j, cids_p, cide_p, cjds_p, cjde_p, &s_ntasks_x, &s_ntasks_y, &Px, &Py, + TASK_FOR_POINT ( &i, &j, cids_p, cide_p, cjds_p, cjde_p, &s_ntasks_par_x, &s_ntasks_par_y, &Px, &Py, min_subdomain, min_subdomain, &ierr ) ; - coords[1] = Px ; coords[0] = Py ; - MPI_Cart_rank( *comm, coords, &P ) ; + P = Px + Py * *ntasks_par_x_p ; // we are computing parent task numbers, so no offset #else P = 0 ; #endif @@ -355,8 +408,8 @@ RSL_LITE_TO_PARENT_INFO ( Fcomm, msize_p, while ( Pptr == NULL ) { Pcurs++ ; - while ( Pcurs < s_ntasks_x * s_ntasks_y && Plist[Pcurs] == NULL ) Pcurs++ ; - if ( Pcurs < s_ntasks_x * s_ntasks_y ) { + while ( Pcurs < alltasks && Plist[Pcurs] == NULL ) Pcurs++ ; + if ( Pcurs < alltasks ) { Sdisplacements[Pcurs] = Sendbufcurs ; Ssizes[Pcurs] = 0 ; Pptr = Plist[Pcurs] ; @@ -425,7 +478,7 @@ rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) nbuf = *nbuf_p ; if ( Sendbufcurs + nbuf >= Sendbufsize ) { - sprintf(mess,"RSL_LITE_TO_CHILD_MSG: Sendbufcurs + nbuf (%d) would exceed Sendbufsize (%d)\n", + sprintf(mess,"rsl_lite_to_peerpoint_msg: Sendbufcurs + nbuf (%d) would exceed Sendbufsize (%d)\n", Sendbufcurs + nbuf , Sendbufsize ) ; RSL_TEST_ERR(1,mess) ; } @@ -450,9 +503,16 @@ rsl_lite_to_peerpoint_msg ( nbuf_p, buf ) /********************************************/ +// PARALLELNESTING NOTES +// what communicator should be passed and what are mytask and ntasks? +// I think it should be the mom_and_me communicator and the mytask and ntasks from +// that communicator +// +// nest if it's parent->nest and the parent if it's nest->parent (we'll see) + /* parent->nest */ -RSL_LITE_BCAST_MSGS ( mytask_p, ntasks_p, Fcomm ) - int_p mytask_p, ntasks_p, Fcomm ; +RSL_LITE_BCAST_MSGS ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ) + int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ; /* offset is the id of the first task in the nest set */ { #ifndef STUBMPI MPI_Comm comm ; @@ -461,12 +521,12 @@ RSL_LITE_BCAST_MSGS ( mytask_p, ntasks_p, Fcomm ) #else int comm ; #endif - rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm ) ; + rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, 0 ) ; } /* nest->parent */ -RSL_LITE_MERGE_MSGS ( mytask_p, ntasks_p, Fcomm ) - int_p mytask_p, ntasks_p, Fcomm ; +RSL_LITE_MERGE_MSGS ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ) + int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, Fcomm ; /* offset is the id of the first task in the nest set */ { #ifndef STUBMPI MPI_Comm comm ; @@ -475,12 +535,13 @@ RSL_LITE_MERGE_MSGS ( mytask_p, ntasks_p, Fcomm ) #else int comm ; #endif - rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm ) ; + rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, 1 ) ; } /* common code */ -rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm ) - int_p mytask_p, ntasks_p ; +rsl_lite_allgather_msgs ( mytask_p, ntasks_par_p, ntasks_nest_p, offset_p, comm, dir ) + int_p mytask_p, ntasks_par_p, ntasks_nest_p, offset_p ; + int dir ; /* 0 = parent to nest, otherwist nest to parent */ #ifndef STUBMPI MPI_Comm comm ; #else @@ -493,43 +554,44 @@ rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm ) bcast_point_desc_t pdesc ; int curs ; int msglen, mdest, mtag ; - int ntasks, mytask ; + int ntasks_par, ntasks_nest, ntasks, mytask ; + int mytask_on_comm ; int ii, i, j ; int ig, jg ; - int *Psize_all ; int *sp, *bp ; int rc ; #ifndef STUBMPI - ntasks = *ntasks_p ; + ntasks_par = *ntasks_par_p ; + ntasks_nest = *ntasks_nest_p ; mytask = *mytask_p ; + MPI_Comm_rank( comm, &mytask_on_comm ) ; #else ntasks = 1 ; mytask = 0 ; + mytask_on_comm = 0 ; #endif - RSL_TEST_ERR( Plist == NULL, - "RSL_BCAST_MSGS: rsl_to_child_info not called first" ) ; + if ( ( mytask_on_comm < ntasks_par && dir == 0 ) /* parent in parent->child */ + || ( mytask_on_comm >= *offset_p && + mytask_on_comm < *offset_p + ntasks_nest && dir == 1 )) { /* child in child->parent */ + RSL_TEST_ERR( Plist == NULL, + "rsl_lite_allgather_msgs: rsl_to_child_info or rsl_to_parent_info not called first" ) ; + } - RSL_TEST_ERR( ntasks == RSL_MAXPROC , - "RSL_BCAST_MSGS: raise the compile time value of MAXPROC" ) ; - - Psize_all = RSL_MALLOC( int, ntasks * ntasks ) ; +#ifndef STUBMPI + ntasks = MAX(ntasks_par,ntasks_nest+*offset_p) ; +#endif + RSL_TEST_ERR( ntasks >= RSL_MAXPROC , + "rsl_lite_allgather_msgs: raise the compile time value of MAXPROC" ) ; + #ifndef STUBMPI - MPI_Allgather( Ssizes, ntasks, MPI_INT , Psize_all, ntasks, MPI_INT, comm ) ; + MPI_Alltoall(Ssizes,1,MPI_INT, Rsizes,1,MPI_INT,comm); #else - Psize_all[0] = Ssizes[0] ; + Rsizes[0] = Ssizes[0]; #endif - for ( j = 0 ; j < ntasks ; j++ ) - Rsizes[j] = 0 ; - - for ( j = 0 ; j < ntasks ; j++ ) - { - Rsizes[j] += Psize_all[ INDEX_2( j , mytask , ntasks ) ] ; - } - for ( Rbufsize = 0, P = 0, Rdisplacements[0] = 0 ; P < ntasks ; P++ ) { Rdisplacements[P+1] = Rsizes[P] + Rdisplacements[P] ; @@ -557,14 +619,15 @@ rsl_lite_allgather_msgs ( mytask_p, ntasks_p, comm ) r = (int *)&(Recvbuf[Rbufsize + 2 * sizeof(int)]) ; *r = RSL_INVALID ; - RSL_FREE( Sendbuf ) ; - RSL_FREE( Psize_all ) ; - - for ( j = 0 ; j < *ntasks_p ; j++ ) { - destroy_list ( &(Plist[j]), NULL ) ; + if ( Sendbuf != NULL ) RSL_FREE( Sendbuf ) ; + if ( Plist != NULL ) { + for ( j = 0 ; j < Plist_length ; j++ ) { + destroy_list ( &(Plist[j]), NULL ) ; + } + RSL_FREE( Plist ) ; + Plist = NULL ; + Plist_length = 0 ; } - RSL_FREE( Plist ) ; - Plist = NULL ; } @@ -610,8 +673,7 @@ rsl_lite_from_peerpoint_info ( ig_p, jg_p, retval_p ) *retval_p = 0 ; RSL_FREE( Recvbuf ) ; } - - return ; + } /********************************************/ diff --git a/wrfv2_fire/external/RSL_LITE/rsl_lite.h b/wrfv2_fire/external/RSL_LITE/rsl_lite.h index 17f519ed..5cf63df2 100644 --- a/wrfv2_fire/external/RSL_LITE/rsl_lite.h +++ b/wrfv2_fire/external/RSL_LITE/rsl_lite.h @@ -2,6 +2,7 @@ # ifdef NOUNDERSCORE # define RSL_LITE_ERROR_DUP1 rsl_error_dup1 # define BYTE_BCAST byte_bcast +# define BYTE_BCAST_FROM_ROOT byte_bcast_from_root # define RSL_LITE_INIT_EXCH rsl_lite_init_exch # define RSL_LITE_EXCH_Y rsl_lite_exch_y # define RSL_LITE_EXCH_X rsl_lite_exch_x @@ -35,10 +36,12 @@ # define F_UNPACK_LINT f_unpack_lint # define F_UNPACK_INT f_unpack_int # define RSL_LITE_GET_HOSTNAME rsl_lite_get_hostname +# define RSL_LITE_NESTING_RESET rsl_lite_nesting_reset # else # ifdef F2CSTYLE # define RSL_LITE_ERROR_DUP1 rsl_error_dup1__ # define BYTE_BCAST byte_bcast__ +# define BYTE_BCAST_FROM_ROOT byte_bcast_from_root__ # define RSL_LITE_INIT_EXCH rsl_lite_init_exch__ # define RSL_LITE_EXCH_Y rsl_lite_exch_y__ # define RSL_LITE_EXCH_X rsl_lite_exch_x__ @@ -72,9 +75,11 @@ # define F_UNPACK_LINT f_unpack_lint__ # define F_UNPACK_INT f_unpack_int__ # define RSL_LITE_GET_HOSTNAME rsl_lite_get_hostname__ +# define RSL_LITE_NESTING_RESET rsl_lite_nesting_reset__ # else # define RSL_LITE_ERROR_DUP1 rsl_error_dup1_ # define BYTE_BCAST byte_bcast_ +# define BYTE_BCAST_FROM_ROOT byte_bcast_from_root_ # define RSL_LITE_INIT_EXCH rsl_lite_init_exch_ # define RSL_LITE_EXCH_Y rsl_lite_exch_y_ # define RSL_LITE_EXCH_X rsl_lite_exch_x_ @@ -108,6 +113,7 @@ # define F_UNPACK_LINT f_unpack_lint_ # define F_UNPACK_INT f_unpack_int_ # define RSL_LITE_GET_HOSTNAME rsl_lite_get_hostname_ +# define RSL_LITE_NESTING_RESET rsl_lite_nesting_reset_ # endif # endif #endif diff --git a/wrfv2_fire/external/RSL_LITE/rsl_malloc.c b/wrfv2_fire/external/RSL_LITE/rsl_malloc.c index 80acb037..4a4cdd10 100755 --- a/wrfv2_fire/external/RSL_LITE/rsl_malloc.c +++ b/wrfv2_fire/external/RSL_LITE/rsl_malloc.c @@ -240,7 +240,7 @@ RSL_FATAL(2) ; return(retval) ; } -rsl_free( p ) +void rsl_free( p ) char **p ; { if ( *p == zero_length_storage ) return ; /* fix from ANU */ diff --git a/wrfv2_fire/external/RSL_LITE/tfp_tester.F b/wrfv2_fire/external/RSL_LITE/tfp_tester.F index 6921f24f..2a9e3f78 100755 --- a/wrfv2_fire/external/RSL_LITE/tfp_tester.F +++ b/wrfv2_fire/external/RSL_LITE/tfp_tester.F @@ -21,7 +21,7 @@ MODULE module_driver_constants INTEGER , PARAMETER :: DATA_ORDER_XY = DATA_ORDER_XYZ INTEGER , PARAMETER :: DATA_ORDER_YX = DATA_ORDER_YXZ -!#include +!#include "model_data_order.inc" ! 1. Following are constants for use in defining maximal values for array ! definitions. diff --git a/wrfv2_fire/external/atm_ocn/mpi_more.F b/wrfv2_fire/external/atm_ocn/mpi_more.F index c57cfc94..f42559b2 100644 --- a/wrfv2_fire/external/atm_ocn/mpi_more.F +++ b/wrfv2_fire/external/atm_ocn/mpi_more.F @@ -21,6 +21,24 @@ SUBROUTINE GLOB_ABORT(ie,s,rc) #endif RETURN END + +#ifdef PRETEND_WRF_FOR_DMITRY +! For Dmitry's sake for testing this code outside of WRF, these are +! implementations of the WRF_MESSAGE and WRF_ERROR_FATAL functions. + + subroutine WRF_MESSAGE(s) + character(*) :: s + print *,trim(s) + end subroutine WRF_MESSAGE + + subroutine WRF_ERROR_FATAL(s) + include 'mpif.h' + character(*) :: s + print *,trim(s) + write(0,*) trim(s) + CALL MPI_ABORT(MPI_COMM_WORLD,rc,ierr) + end subroutine WRF_ERROR_FATAL +#endif ! !*********************************************************************** ! diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc b/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc index 2cdb33ef..78af4050 100644 --- a/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc +++ b/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc @@ -28,7 +28,7 @@ by both C++ and F90 compilers. !EOP #endif -#include +#include "ESMF_Macros.inc" #define SECONDS_PER_DAY 86400_ESMF_KIND_I8 #define SECONDS_PER_HOUR 3600_ESMF_KIND_I8 diff --git a/wrfv2_fire/external/io_grib1/grib1_util/read_grib.c b/wrfv2_fire/external/io_grib1/grib1_util/read_grib.c index a98c1273..79757d38 100644 --- a/wrfv2_fire/external/io_grib1/grib1_util/read_grib.c +++ b/wrfv2_fire/external/io_grib1/grib1_util/read_grib.c @@ -44,11 +44,7 @@ #include #include #include -#ifdef MACOS -#include "/usr/include/time.h" -#else #include -#endif #include "cfortran.h" #include "gribfuncs.h" #include "gribsize.incl" diff --git a/wrfv2_fire/external/io_int/makefile b/wrfv2_fire/external/io_int/makefile index 22516948..a8b346f1 100644 --- a/wrfv2_fire/external/io_int/makefile +++ b/wrfv2_fire/external/io_int/makefile @@ -36,7 +36,7 @@ io_int_idx_tags.h: ../../inc/intio_tags.h awk '{print "#define", toupper($$4), $$6}' < ../../inc/intio_tags.h > $@ io_int_idx.o: io_int_idx.c io_int_idx.h io_int_idx_tags.h - $(CC) -o $@ -c -w $*.c + $(CC) -o $@ -c $(CFLAGS_LOCAL) $*.c module_io_int_idx.o: module_io_int_idx.f $(FC) $(FCFLAGS) -o $@ -c $*.f diff --git a/wrfv2_fire/external/io_netcdf/wrf_io.F90 b/wrfv2_fire/external/io_netcdf/wrf_io.F90 index 5ee038f8..df8af0a7 100644 --- a/wrfv2_fire/external/io_netcdf/wrf_io.F90 +++ b/wrfv2_fire/external/io_netcdf/wrf_io.F90 @@ -41,7 +41,7 @@ module wrf_data integer , parameter :: WrfDataHandleMax = 99 integer , parameter :: MaxDims = 2000 ! = NF_MAX_VARS #if(WRF_CHEM == 1) - integer , parameter :: MaxVars = 8000 + integer , parameter :: MaxVars = 10000 #else integer , parameter :: MaxVars = 3000 #endif diff --git a/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 b/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 index 175d6a04..8292c556 100644 --- a/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 +++ b/wrfv2_fire/external/io_pnetcdf/wrf_io.F90 @@ -1250,9 +1250,11 @@ SUBROUTINE ext_pnc_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHand CALL mpi_info_set(info,"romio_ds_read","disable", ierr) ; write(0,*)'mpi_info_set read returns ',ierr # endif - write(newFileName, fmt="(2a)") FileName, ".nc" + +! Remove the dash/underscore change to filenames for pnetcdf... + write(newFileName, fmt="(a)") TRIM(ADJUSTL(FileName)) do i = 1, len_trim(newFileName) - if(newFileName(i:i) == '-') newFileName(i:i) = '_' +! if(newFileName(i:i) == '-') newFileName(i:i) = '_' if(newFileName(i:i) == ':') newFileName(i:i) = '_' enddo stat = NFMPI_CREATE(Comm, newFileName, IOR(NF_CLOBBER, NF_64BIT_OFFSET), info, DH%NCID) diff --git a/wrfv2_fire/frame/Makefile b/wrfv2_fire/frame/Makefile index 4eb0a7b8..9db8303d 100644 --- a/wrfv2_fire/frame/Makefile +++ b/wrfv2_fire/frame/Makefile @@ -181,6 +181,8 @@ clean: module_state_description.F : ../Registry/$(REGISTRY) ( cd .. ; tools/registry $(ARCHFLAGS) $(ENVCOMPDEFS) -DNEW_BDYS Registry/$(REGISTRY) ) ; +module_io_quilt.o : module_io_quilt.F module_io_quilt_new.F module_io_quilt_old.F + md_calls.inc : md_calls.m4 if [ "$(M4)" = NA ] ; then \ /bin/cp ../arch/md_calls.inc . ; \ diff --git a/wrfv2_fire/frame/module_alloc_space.h b/wrfv2_fire/frame/module_alloc_space.h index 16ba6d48..249466ed 100644 --- a/wrfv2_fire/frame/module_alloc_space.h +++ b/wrfv2_fire/frame/module_alloc_space.h @@ -1,4 +1,4 @@ - SUBROUTINE ROUTINENAME ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , & + SUBROUTINE ROUTINENAME ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -35,7 +35,7 @@ ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated ! false otherwise (all allocated, modulo tl above) - LOGICAL , INTENT(IN) :: inter_domain_in + LOGICAL , INTENT(IN) :: inter_domain_in, okay_to_alloc_in INTEGER(KIND=8) , INTENT(INOUT) :: num_bytes_allocated @@ -45,7 +45,7 @@ REAL initial_data_value CHARACTER (LEN=256) message INTEGER tl - LOGICAL inter_domain + LOGICAL inter_domain, okay_to_alloc INTEGER setinitval INTEGER sr_x, sr_y @@ -131,6 +131,7 @@ tl = tl_in inter_domain = inter_domain_in + okay_to_alloc = okay_to_alloc_in #if ( RWORDSIZE == 8 ) initial_data_value = 0. diff --git a/wrfv2_fire/frame/module_clear_halos.F b/wrfv2_fire/frame/module_clear_halos.F index 6adc9530..88de325e 100644 --- a/wrfv2_fire/frame/module_clear_halos.F +++ b/wrfv2_fire/frame/module_clear_halos.F @@ -42,7 +42,11 @@ subroutine clear_ij_halos(grid,how,full_domain) ips, ipe, jps, jpe, kps, kpe logical :: fulldom real :: badR, badR_N,badR_NE,badR_NW,badR_S,badR_SW,badR_SE,badR_E,badR_W +#if (RWORDSIZE==4) double precision :: badD, badD_N,badD_NE,badD_NW,badD_S,badD_SW,badD_SE,badD_E,badD_W +#else + real :: badD, badD_N,badD_NE,badD_NW,badD_S,badD_SW,badD_SE,badD_E,badD_W +#endif integer :: badI, badI_N,badI_NE,badI_NW,badI_S,badI_SW,badI_SE,badI_E,badI_W select case(how) diff --git a/wrfv2_fire/frame/module_configure.F b/wrfv2_fire/frame/module_configure.F index 872bd590..912077e8 100644 --- a/wrfv2_fire/frame/module_configure.F +++ b/wrfv2_fire/frame/module_configure.F @@ -5,12 +5,12 @@ MODULE module_scalar_tables USE module_driver_constants USE module_state_description USE module_domain_type, ONLY : streamrec -#include +#include "scalar_tables.inc" CONTAINS SUBROUTINE init_module_scalar_tables INTEGER i , j DO j = 1, max_domains -#include +#include "scalar_tables_init.inc" END DO END SUBROUTINE init_module_scalar_tables END MODULE module_scalar_tables @@ -28,16 +28,16 @@ MODULE module_configure ! integer, first_item_in_struct and the last is an integer last_item_in_struct ! this provides a way of converting this to a buffer for passing to and from ! the driver. -#include +#include "namelist_defines.inc" END TYPE model_config_rec_type TYPE grid_config_rec_type -#include +#include "namelist_defines2.inc" END TYPE grid_config_rec_type TYPE(model_config_rec_type) :: model_config_rec -!#include +!#include "scalar_tables.inc" ! special entries (put here but not enshrined in Registry for one reason or other) @@ -102,10 +102,10 @@ SUBROUTINE initial_config ! define as temporaries -#include +#include "namelist_defines.inc" ! Statements that specify the namelists -#include +#include "namelist_statements.inc" OPEN ( UNIT = nml_read_unit , & FILE = "namelist.input" , & @@ -138,7 +138,7 @@ SUBROUTINE initial_config #endif ! Statements that set the namelist vars to default vals -# include +# include "namelist_defaults.inc" #if (DA_CORE == 1) ! Override the default values, because we can not assigned a arrary with different values in registry. @@ -151,7 +151,7 @@ SUBROUTINE initial_config #endif ! Statements that read the namelist are in this file -# include +# include "config_reads.inc" ! 2004/04/28 JM (with consensus by the group of developers) ! This is needed to ensure that nesting will work, since @@ -173,7 +173,7 @@ SUBROUTINE initial_config #define SOURCE_RECORD #define DEST_RECORD model_config_rec % #define SOURCE_REC_DEX -#include +#include "config_assigns.inc" CLOSE ( UNIT = nml_read_unit , IOSTAT = io_status ) @@ -311,7 +311,7 @@ SUBROUTINE model_to_grid_config_rec ( id_id , model_config_rec , grid_config_rec #define SOURCE_RECORD model_config_rec % #define SOURCE_REC_DEX (id_id) #define DEST_RECORD grid_config_rec % -#include +#include "config_assigns.inc" END SUBROUTINE model_to_grid_config_rec @@ -324,20 +324,58 @@ FUNCTION in_use_for_config ( id, vname ) RESULT ( in_use ) uses = 0 in_use = .TRUE. - IF ( vname(1:1) .GE. 'x' ) THEN -# include - ELSE IF ( vname(1:1) .GE. 't' ) THEN -# include - ELSE IF ( vname(1:1) .GE. 'o' ) THEN -# include - ELSE IF ( vname(1:1) .GE. 'l' ) THEN -# include - ELSE IF ( vname(1:1) .GE. 'g' ) THEN -# include - ELSE IF ( vname(1:1) .GE. 'd' ) THEN -# include - ELSE -# include + IF ( vname(1:1) .EQ. 'a' ) THEN +# include "in_use_for_config_a.inc" + ELSE IF ( vname(1:1) .EQ. 'b' ) THEN +# include "in_use_for_config_b.inc" + ELSE IF ( vname(1:1) .EQ. 'c' ) THEN +# include "in_use_for_config_c.inc" + ELSE IF ( vname(1:1) .EQ. 'd' ) THEN +# include "in_use_for_config_d.inc" + ELSE IF ( vname(1:1) .EQ. 'e' ) THEN +# include "in_use_for_config_e.inc" + ELSE IF ( vname(1:1) .EQ. 'f' ) THEN +# include "in_use_for_config_f.inc" + ELSE IF ( vname(1:1) .EQ. 'g' ) THEN +# include "in_use_for_config_g.inc" + ELSE IF ( vname(1:1) .EQ. 'h' ) THEN +# include "in_use_for_config_h.inc" + ELSE IF ( vname(1:1) .EQ. 'i' ) THEN +# include "in_use_for_config_i.inc" + ELSE IF ( vname(1:1) .EQ. 'j' ) THEN +# include "in_use_for_config_j.inc" + ELSE IF ( vname(1:1) .EQ. 'k' ) THEN +# include "in_use_for_config_k.inc" + ELSE IF ( vname(1:1) .EQ. 'l' ) THEN +# include "in_use_for_config_l.inc" + ELSE IF ( vname(1:1) .EQ. 'm' ) THEN +# include "in_use_for_config_m.inc" + ELSE IF ( vname(1:1) .EQ. 'n' ) THEN +# include "in_use_for_config_n.inc" + ELSE IF ( vname(1:1) .EQ. 'o' ) THEN +# include "in_use_for_config_o.inc" + ELSE IF ( vname(1:1) .EQ. 'p' ) THEN +# include "in_use_for_config_p.inc" + ELSE IF ( vname(1:1) .EQ. 'q' ) THEN +# include "in_use_for_config_q.inc" + ELSE IF ( vname(1:1) .EQ. 'r' ) THEN +# include "in_use_for_config_r.inc" + ELSE IF ( vname(1:1) .EQ. 's' ) THEN +# include "in_use_for_config_s.inc" + ELSE IF ( vname(1:1) .EQ. 't' ) THEN +# include "in_use_for_config_t.inc" + ELSE IF ( vname(1:1) .EQ. 'u' ) THEN +# include "in_use_for_config_u.inc" + ELSE IF ( vname(1:1) .EQ. 'v' ) THEN +# include "in_use_for_config_v.inc" + ELSE IF ( vname(1:1) .EQ. 'w' ) THEN +# include "in_use_for_config_w.inc" + ELSE IF ( vname(1:1) .EQ. 'x' ) THEN +# include "in_use_for_config_x.inc" + ELSE IF ( vname(1:1) .EQ. 'y' ) THEN +# include "in_use_for_config_y.inc" + ELSE IF ( vname(1:1) .EQ. 'z' ) THEN +# include "in_use_for_config_z.inc" ENDIF RETURN @@ -368,8 +406,8 @@ SUBROUTINE wrf_alt_nml_obsolete (nml_read_unit, nml_name) CHARACTER*(*), INTENT(IN) :: nml_name INTEGER :: nml_error -#include -#include +#include "namelist_defines.inc" +#include "namelist_statements.inc" ! These are the variables that have been removed logical , DIMENSION(max_domains) :: pd_moist, pd_chem, pd_tke, pd_scalar @@ -543,8 +581,8 @@ SUBROUTINE set_scalar_indices_from_config ( idomain , dummy2, dummy1 ) ! ! -#include -#include +#include "scalar_indices.inc" +#include "scalar_indices_init.inc" RETURN END SUBROUTINE set_scalar_indices_from_config diff --git a/wrfv2_fire/frame/module_dm_stubs.F b/wrfv2_fire/frame/module_dm_stubs.F index 7ea51c2d..0a2a37da 100644 --- a/wrfv2_fire/frame/module_dm_stubs.F +++ b/wrfv2_fire/frame/module_dm_stubs.F @@ -1,9 +1,14 @@ !WRF:PACKAGE:NODM ! MODULE module_dm + USE module_driver_constants + + LOGICAL intercomm_active( max_domains ), domain_active_this_task( max_domains ) CONTAINS SUBROUTINE init_module_dm + intercomm_active = .TRUE. + domain_active_this_task = .TRUE. END SUBROUTINE init_module_dm REAL FUNCTION wrf_dm_max_real ( inval ) @@ -354,4 +359,23 @@ SUBROUTINE wrf_global_to_patch_LOGICAL (globbuf,buf,domdesc,ndim,& RETURN END SUBROUTINE wrf_global_to_patch_LOGICAL +#if ( HWRF == 1 ) + SUBROUTINE hwrf_coupler_init + END SUBROUTINE hwrf_coupler_init +#endif + + SUBROUTINE push_communicators_for_domain( id ) + IMPLICIT NONE + INTEGER, OPTIONAL, INTENT(IN) :: id ! if specified also does an instate for grid id + END SUBROUTINE push_communicators_for_domain + SUBROUTINE pop_communicators_for_domain + END SUBROUTINE pop_communicators_for_domain + SUBROUTINE instate_communicators_for_domain( id ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: id + END SUBROUTINE instate_communicators_for_domain + SUBROUTINE store_communicators_for_domain( id ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: id + END SUBROUTINE store_communicators_for_domain diff --git a/wrfv2_fire/frame/module_domain.F b/wrfv2_fire/frame/module_domain.F index fb3786c2..5302e1b6 100644 --- a/wrfv2_fire/frame/module_domain.F +++ b/wrfv2_fire/frame/module_domain.F @@ -517,7 +517,7 @@ SUBROUTINE wrf_patch_domain( id , domdesc , parent, parent_id , parent_domdesc , RETURN END SUBROUTINE wrf_patch_domain ! - SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid ) + SUBROUTINE alloc_and_configure_domain ( domain_id , active_this_task, grid , parent, kid ) ! ! This subroutine is used to allocate a domain data structure of @@ -563,10 +563,11 @@ SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid ) ! Input data. - INTEGER , INTENT(IN) :: domain_id - TYPE( domain ) , POINTER :: grid - TYPE( domain ) , POINTER :: parent - INTEGER , INTENT(IN) :: kid ! which kid of parent am I? + INTEGER , INTENT(IN) :: domain_id + LOGICAL , OPTIONAL, INTENT(IN) :: active_this_task ! false if domain is being handled by other MPI tasks + TYPE( domain ) , POINTER :: grid + TYPE( domain ) , POINTER :: parent + INTEGER , INTENT(IN) :: kid ! which kid of parent am I? ! Local data. INTEGER :: sd1 , ed1 , sp1 , ep1 , sm1 , em1 @@ -586,7 +587,13 @@ SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid ) INTEGER :: parent_id , parent_domdesc , new_domdesc INTEGER :: bdyzone_x , bdyzone_y INTEGER :: nx, ny + LOGICAL :: active +! + active = .TRUE. + IF ( PRESENT( active_this_task ) ) THEN + active = active_this_task + ENDIF ! This next step uses information that is listed in the registry as namelist_derived ! to properly size the domain and the patches; this in turn is stored in the new_grid @@ -724,8 +731,17 @@ SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid ) parent%nests(kid)%ptr => new_grid new_grid%child_of_parent(1) = kid ! note assumption that nest can have only 1 parent parent%num_nests = parent%num_nests + 1 +#if ( NMM_CORE == 1 ) +!jm 20150810, this replaces the compile-time logic associated with the CPP constant HRD_MULTIPLE_STORMS +! used in solve_nmm of the HWRF version to decide whether or not to call the coupler. If there is more than +! one nest to a parent then that implies there are multiple storms, so we turn off the coupling. + IF ( parent%num_nests .GT. 1 ) THEN + CALL nl_set_multi_storm(1,.FALSE.) + ENDIF +#endif END IF new_grid%id = domain_id ! this needs to be assigned prior to calling wrf_patch_domain + new_grid%active_this_task = active CALL wrf_patch_domain( domain_id , new_domdesc , parent, parent_id, parent_domdesc , & @@ -758,7 +774,10 @@ SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid ) new_grid%last_step_updated = -1 #endif - CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. , & +! IF (active) THEN + ! only allocate state if this set of tasks actually computes that domain, jm 20140822 + new_grid%active_this_task = active + CALL alloc_space_field ( new_grid, domain_id , 3 , 3 , .FALSE. , active, & sd1, ed1, sd2, ed2, sd3, ed3, & sm1, em1, sm2, em2, sm3, em3, & sp1, ep1, sp2, ep2, sp3, ep3, & @@ -767,6 +786,10 @@ SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid ) sm1x, em1x, sm2x, em2x, sm3x, em3x, & ! x-xpose sm1y, em1y, sm2y, em2y, sm3y, em3y & ! y-xpose ) +! ELSE +! WRITE (wrf_err_message,*)"Not allocating storage for domain ",domain_id," on this set of tasks" +! CALL wrf_message(TRIM(wrf_err_message)) +! ENDIF #if MOVE_NESTS !set these here, after alloc_space_field, which initializes vc_i, vc_j to zero new_grid%xi = -1.0 @@ -913,43 +936,54 @@ SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid ) ! properly assigned to the new_grid record grid => new_grid - +!debug write(0,*)__FILE__,__LINE__,'grid%mvnest ',grid%mvnest + +!debug write(0,*)__FILE__,__LINE__,'grid%mvnest ',grid%mvnest + IF ( grid%active_this_task ) THEN ! Allocate storage for time series metadata - ALLOCATE( grid%lattsloc( grid%max_ts_locs ) ) - ALLOCATE( grid%lontsloc( grid%max_ts_locs ) ) - ALLOCATE( grid%nametsloc( grid%max_ts_locs ) ) - ALLOCATE( grid%desctsloc( grid%max_ts_locs ) ) - ALLOCATE( grid%itsloc( grid%max_ts_locs ) ) - ALLOCATE( grid%jtsloc( grid%max_ts_locs ) ) - ALLOCATE( grid%id_tsloc( grid%max_ts_locs ) ) - ALLOCATE( grid%ts_filename( grid%max_ts_locs ) ) - grid%ntsloc = 0 - grid%ntsloc_domain = 0 + ALLOCATE( grid%lattsloc( grid%max_ts_locs ) ) + ALLOCATE( grid%lontsloc( grid%max_ts_locs ) ) + ALLOCATE( grid%nametsloc( grid%max_ts_locs ) ) + ALLOCATE( grid%desctsloc( grid%max_ts_locs ) ) + ALLOCATE( grid%itsloc( grid%max_ts_locs ) ) + ALLOCATE( grid%jtsloc( grid%max_ts_locs ) ) + ALLOCATE( grid%id_tsloc( grid%max_ts_locs ) ) + ALLOCATE( grid%ts_filename( grid%max_ts_locs ) ) + grid%ntsloc = 0 + grid%ntsloc_domain = 0 #if (EM_CORE == 1) ! Allocate storage for track metadata - ALLOCATE( grid%track_time_in( grid%track_loc_in ) ) - ALLOCATE( grid%track_lat_in( grid%track_loc_in ) ) - ALLOCATE( grid%track_lon_in( grid%track_loc_in ) ) - - ALLOCATE( grid%track_time_domain( grid%track_loc_in ) ) - ALLOCATE( grid%track_lat_domain( grid%track_loc_in ) ) - ALLOCATE( grid%track_lon_domain( grid%track_loc_in ) ) - ALLOCATE( grid%track_i( grid%track_loc_in ) ) - ALLOCATE( grid%track_j( grid%track_loc_in ) ) + ALLOCATE( grid%track_time_in( grid%track_loc_in ) ) + ALLOCATE( grid%track_lat_in( grid%track_loc_in ) ) + ALLOCATE( grid%track_lon_in( grid%track_loc_in ) ) + + ALLOCATE( grid%track_time_domain( grid%track_loc_in ) ) + ALLOCATE( grid%track_lat_domain( grid%track_loc_in ) ) + ALLOCATE( grid%track_lon_domain( grid%track_loc_in ) ) + ALLOCATE( grid%track_i( grid%track_loc_in ) ) + ALLOCATE( grid%track_j( grid%track_loc_in ) ) grid%track_loc = 0 grid%track_loc_domain = 0 grid%track_have_calculated = .FALSE. grid%track_have_input = .FALSE. #endif + ELSE + WRITE (wrf_err_message,*)"Not allocating time series storage for domain ",domain_id," on this set of tasks" + CALL wrf_message(TRIM(wrf_err_message)) + ENDIF +!debug write(0,*)__FILE__,__LINE__,'grid%mvnest ',grid%mvnest #ifdef DM_PARALLEL - CALL wrf_get_dm_communicator ( grid%communicator ) + CALL wrf_get_dm_communicator_for_id( grid%id, grid%communicator ) CALL wrf_dm_define_comms( grid ) #endif #if ( NMM_CORE==1 ) - grid%interp_mp = .not. ( size(grid%f_ice)>1 .or. size(grid%f_rain)>1 .or. size(grid%f_rimef)>1 ) +! grid%interp_mp = .not. ( size(grid%f_ice)>1 .or. size(grid%f_rain)>1 .or. size(grid%f_rimef)>1 ) + grid%interp_mp = .not. (in_use_for_config(grid%id,'f_ice') .or.& + in_use_for_config(grid%id,'f_rain') .or. & + in_use_for_config(grid%id,'f_rimef') ) #else grid%interp_mp = .true. #endif @@ -1251,7 +1285,7 @@ END SUBROUTINE warn_me_or_set_mask ! below this top-level of data allocation and management (in the solve routine ! and below). - SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , & + SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1294,7 +1328,7 @@ SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated ! false otherwise (all allocated, modulo tl above) - LOGICAL , INTENT(IN) :: inter_domain_in + LOGICAL , INTENT(IN) :: inter_domain_in, okay_to_alloc_in ! Local INTEGER(KIND=8) num_bytes_allocated @@ -1308,17 +1342,13 @@ SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain IF ( grid%id .EQ. 1 ) & CALL wrf_message ( 'DYNAMICS OPTION: nmm dyncore' ) #endif -#if (COAMPS_CORE == 1) - IF ( grid%id .EQ. 1 ) & - CALL wrf_message ( 'DYNAMICS OPTION: coamps dyncore' ) -#endif CALL set_scalar_indices_from_config( id , idum1 , idum2 ) num_bytes_allocated = 0 ! now separate modules to reduce the size of module_domain that the compiler sees - CALL alloc_space_field_core_0 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , & + CALL alloc_space_field_core_0 ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1326,7 +1356,7 @@ SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, & sm31x, em31x, sm32x, em32x, sm33x, em33x, & sm31y, em31y, sm32y, em32y, sm33y, em33y ) - CALL alloc_space_field_core_1 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , & + CALL alloc_space_field_core_1 ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1334,7 +1364,7 @@ SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, & sm31x, em31x, sm32x, em32x, sm33x, em33x, & sm31y, em31y, sm32y, em32y, sm33y, em33y ) - CALL alloc_space_field_core_2 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , & + CALL alloc_space_field_core_2 ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1342,7 +1372,7 @@ SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, & sm31x, em31x, sm32x, em32x, sm33x, em33x, & sm31y, em31y, sm32y, em32y, sm33y, em33y ) - CALL alloc_space_field_core_3 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , & + CALL alloc_space_field_core_3 ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1350,7 +1380,7 @@ SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, & sm31x, em31x, sm32x, em32x, sm33x, em33x, & sm31y, em31y, sm32y, em32y, sm33y, em33y ) - CALL alloc_space_field_core_4 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , & + CALL alloc_space_field_core_4 ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1358,7 +1388,7 @@ SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, & sm31x, em31x, sm32x, em32x, sm33x, em33x, & sm31y, em31y, sm32y, em32y, sm33y, em33y ) - CALL alloc_space_field_core_5 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , & + CALL alloc_space_field_core_5 ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1366,7 +1396,7 @@ SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, & sm31x, em31x, sm32x, em32x, sm33x, em33x, & sm31y, em31y, sm32y, em32y, sm33y, em33y ) - CALL alloc_space_field_core_6 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , & + CALL alloc_space_field_core_6 ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1374,7 +1404,7 @@ SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, & sm31x, em31x, sm32x, em32x, sm33x, em33x, & sm31y, em31y, sm32y, em32y, sm33y, em33y ) - CALL alloc_space_field_core_7 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , & + CALL alloc_space_field_core_7 ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1382,7 +1412,7 @@ SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, & sm31x, em31x, sm32x, em32x, sm33x, em33x, & sm31y, em31y, sm32y, em32y, sm33y, em33y ) - CALL alloc_space_field_core_8 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , & + CALL alloc_space_field_core_8 ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1390,7 +1420,7 @@ SUBROUTINE alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, & sm31x, em31x, sm32x, em32x, sm33x, em33x, & sm31y, em31y, sm32y, em32y, sm33y, em33y ) - CALL alloc_space_field_core_9 ( grid, id, setinitval_in , tl_in , inter_domain_in , num_bytes_allocated , & + CALL alloc_space_field_core_9 ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, num_bytes_allocated , & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1444,7 +1474,7 @@ END SUBROUTINE alloc_space_field ! If they were already allocated with the requested dimensions, then ! ensure_space_field does nothing. - SUBROUTINE ensure_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , & + SUBROUTINE ensure_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1476,7 +1506,7 @@ SUBROUTINE ensure_space_field ( grid, id, setinitval_in , tl_in , inter_domai ! true if the allocation is for an intermediate domain (for nesting); only certain fields allocated ! false otherwise (all allocated, modulo tl above) - LOGICAL , INTENT(IN) :: inter_domain_in + LOGICAL , INTENT(IN) :: inter_domain_in, okay_to_alloc_in LOGICAL :: size_changed size_changed= .not. ( & @@ -1502,7 +1532,7 @@ SUBROUTINE ensure_space_field ( grid, id, setinitval_in , tl_in , inter_domai end if if(grid%allocated) & call dealloc_space_field( grid ) - call alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , & + call alloc_space_field ( grid, id, setinitval_in , tl_in , inter_domain_in , okay_to_alloc_in, & sd31, ed31, sd32, ed32, sd33, ed33, & sm31 , em31 , sm32 , em32 , sm33 , em33 , & sp31 , ep31 , sp32 , ep32 , sp33 , ep33 , & @@ -1710,7 +1740,7 @@ SUBROUTINE dealloc_space_field ( grid ) INTEGER :: ierr -# include +# include "deallocs.inc" END SUBROUTINE dealloc_space_field diff --git a/wrfv2_fire/frame/module_domain_type.F b/wrfv2_fire/frame/module_domain_type.F index d924516c..bafe99d4 100644 --- a/wrfv2_fire/frame/module_domain_type.F +++ b/wrfv2_fire/frame/module_domain_type.F @@ -114,7 +114,7 @@ MODULE module_domain_type END TYPE fieldlist -#include +#include "state_subtypes.inc" TYPE domain @@ -122,7 +122,7 @@ MODULE module_domain_type TYPE ( fieldlist ), POINTER :: tail_statevars ! SEE THE INCLUDE FILE FOR DEFINITIONS OF STATE FIELDS WITHIN THE DOMAIN DATA STRUCTURE -#include +#include "state_struct.inc" INTEGER :: comms( max_comms ), shift_x, shift_y @@ -150,6 +150,7 @@ MODULE module_domain_type INTEGER :: num_parents, num_nests, num_siblings INTEGER , DIMENSION( max_parents ) :: child_of_parent INTEGER , DIMENSION( max_nests ) :: active + LOGICAL :: active_this_task INTEGER , DIMENSION(MAX_STREAMS) :: nframes ! frames per outfile for history ! 1 is main history diff --git a/wrfv2_fire/frame/module_driver_constants.F b/wrfv2_fire/frame/module_driver_constants.F index 19653987..4011aa43 100644 --- a/wrfv2_fire/frame/module_driver_constants.F +++ b/wrfv2_fire/frame/module_driver_constants.F @@ -18,7 +18,7 @@ MODULE module_driver_constants INTEGER , PARAMETER :: DATA_ORDER_YX = DATA_ORDER_YXZ -#include +#include "model_data_order.inc" ! 1. Following are constants for use in defining maximal values for array ! definitions. @@ -62,6 +62,10 @@ MODULE module_driver_constants INTEGER , PARAMETER :: max_plevs = 100 + ! The maximum number of height levels to interpolate to, for diagnostics + + INTEGER , PARAMETER :: max_zlevs = 100 + ! The maximum number of trackchem INTEGER , PARAMETER :: max_trackchem = 100 diff --git a/wrfv2_fire/frame/module_integrate.F b/wrfv2_fire/frame/module_integrate.F index 4d2a5466..e34482a0 100644 --- a/wrfv2_fire/frame/module_integrate.F +++ b/wrfv2_fire/frame/module_integrate.F @@ -16,6 +16,14 @@ RECURSIVE SUBROUTINE integrate ( grid ) USE module_timing USE module_utility USE module_cpl, ONLY : coupler_on, cpl_snd, cpl_defdomain +#ifdef DM_PARALLEL +! better if this did not need to be used here. Problem is that the definition of +! domain_active_this_task comes from module_dm, and the routine it's being passed to (alloc_and_configure_domain) +! is defined in module_domain, which uses module_dm. If that weren't the case, we could have the +! alloc_and_configure_domain routine get this form the module_dm module itself, but as it stands there +! would be a circular use association. jm 20140828 + USE module_dm, ONLY: domain_active_this_task !, push_communicators_for_domain, pop_communicators_for_domain +#endif IMPLICIT NONE @@ -156,6 +164,8 @@ RECURSIVE SUBROUTINE integrate ( grid ) LOGICAL , EXTERNAL :: wrf_dm_on_monitor INTEGER :: idum1 , idum2 , ierr , open_status LOGICAL :: should_do_last_io + LOGICAL :: may_have_moved + ! interface INTERFACE @@ -217,6 +227,11 @@ SUBROUTINE med_nest_move ( parent , grid ) USE module_configure TYPE (domain), POINTER :: grid , parent END SUBROUTINE med_nest_move + SUBROUTINE reconcile_nest_positions_over_tasks ( grid ) + USE module_domain + USE module_configure + TYPE (domain), POINTER :: grid + END SUBROUTINE reconcile_nest_positions_over_tasks #endif ! mediation-supplied routine that gives mediation layer opportunity to @@ -270,6 +285,7 @@ SUBROUTINE dfi_accumulate( grid ) ! This allows us to reference the current grid from anywhere beneath ! this point for debugging purposes. CALL set_current_grid_ptr( grid ) + CALL push_communicators_for_domain( grid%id ) IF ( .NOT. domain_clockisstoptime( grid ) ) THEN CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) @@ -277,7 +293,9 @@ SUBROUTINE dfi_accumulate( grid ) CALL domain_clockprint ( 150, grid, 'DEBUG: top of integrate(),' ) DO WHILE ( .NOT. domain_clockisstopsubtime(grid) ) IF ( wrf_dm_on_monitor() ) THEN +IF ( grid%active_this_task ) THEN CALL start_timing +END IF END IF CALL med_setup_step ( grid , config_flags ) a_nest_was_opened = .false. @@ -288,29 +306,45 @@ SUBROUTINE dfi_accumulate( grid ) a_nest_was_opened = .true. CALL med_pre_nest_initial ( grid , nestid , config_flags ) CALL alloc_and_configure_domain ( domain_id = nestid , & +! better if this were not ifdef'd here, try moving into module_dm? see comment above. jm 20140828 +#ifdef DM_PARALLEL + active_this_task = domain_active_this_task( nestid ), & +#endif grid = new_nest , & parent = grid , & kid = kid ) CALL Setup_Timekeeping (new_nest) CALL med_nest_initial ( grid , new_nest , config_flags ) +IF ( grid%active_this_task ) THEN IF ( grid%dfi_stage == DFI_STARTFWD ) THEN CALL wrf_dfi_startfwd_init(new_nest) ENDIF IF (coupler_on) CALL cpl_defdomain( new_nest ) +ENDIF ! active_this_task END DO IF ( a_nest_was_opened ) THEN CALL set_overlaps ( grid ) ! find overlapping and set pointers END IF +IF ( grid%active_this_task ) THEN ! Accumulation calculation for DFI - CALL dfi_accumulate ( grid ) + CALL dfi_accumulate ( grid ) + + CALL med_before_solve_io ( grid , config_flags ) +ENDIF ! active_this_task - CALL med_before_solve_io ( grid , config_flags ) grid_ptr => grid DO WHILE ( ASSOCIATED( grid_ptr ) ) - CALL set_current_grid_ptr( grid_ptr ) - CALL wrf_debug( 100 , 'module_integrate: calling solve interface ' ) - CALL solve_interface ( grid_ptr ) +#if ( NMM_CORE == 1 ) + grid_ptr%mvnest = .FALSE. +#endif +IF ( grid_ptr%active_this_task ) THEN + CALL set_current_grid_ptr( grid_ptr ) + CALL wrf_debug( 100 , 'module_integrate: calling solve interface ' ) + + CALL solve_interface ( grid_ptr ) + +ENDIF CALL domain_clockadvance ( grid_ptr ) CALL wrf_debug( 100 , 'module_integrate: back from solve interface ' ) ! print lots of time-related information for testing @@ -320,7 +354,10 @@ SUBROUTINE dfi_accumulate( grid ) END DO CALL set_current_grid_ptr( grid ) CALL med_calc_model_time ( grid , config_flags ) - CALL med_after_solve_io ( grid , config_flags ) +IF ( grid%active_this_task ) THEN + CALL med_after_solve_io ( grid , config_flags ) +ENDIF + grid_ptr => grid DO WHILE ( ASSOCIATED( grid_ptr ) ) DO kid = 1, max_nests @@ -334,8 +371,23 @@ SUBROUTINE dfi_accumulate( grid ) domain_get_current_time(grid) - domain_get_time_step(grid) grid_ptr%nests(kid)%ptr%stop_subtime = & domain_get_current_time(grid) - CALL integrate ( grid_ptr%nests(kid)%ptr ) - CALL wrf_debug( 100 , 'module_integrate: back from recursive call to integrate ' ) + ENDIF + ENDDO + + DO kid = 1, max_nests + IF ( ASSOCIATED( grid_ptr%nests(kid)%ptr ) ) THEN + CALL set_current_grid_ptr( grid_ptr%nests(kid)%ptr ) + WRITE(message,*)grid%id,' module_integrate: recursive call to integrate ' + CALL wrf_debug( 100 , message ) + CALL integrate ( grid_ptr%nests(kid)%ptr ) + WRITE(message,*)grid%id,' module_integrate: back from recursive call to integrate ' + CALL wrf_debug( 100 , message ) + ENDIF + ENDDO + may_have_moved = .FALSE. + DO kid = 1, max_nests + IF ( ASSOCIATED( grid_ptr%nests(kid)%ptr ) ) THEN + CALL set_current_grid_ptr( grid_ptr%nests(kid)%ptr ) IF ( .NOT. ( domain_clockisstoptime(head_grid ) .OR. & domain_clockisstoptime(grid ) .OR. & domain_clockisstoptime(grid_ptr%nests(kid)%ptr) ) ) THEN @@ -346,16 +398,24 @@ SUBROUTINE dfi_accumulate( grid ) #ifdef MOVE_NESTS IF ( .NOT. domain_clockisstoptime( head_grid ) ) THEN CALL med_nest_move ( grid_ptr , grid_ptr%nests(kid)%ptr ) + may_have_moved = .TRUE. ENDIF #endif END IF END DO +#ifdef MOVE_NESTS + IF ( may_have_moved ) THEN + CALL reconcile_nest_positions_over_tasks( grid_ptr ) + CALL model_to_grid_config_rec ( grid_ptr%id , model_config_rec , config_flags ) + ENDIF +#endif IF (coupler_on) CALL cpl_snd( grid_ptr ) grid_ptr => grid_ptr%sibling END DO CALL set_current_grid_ptr( grid ) ! Report on the timing for a single time step. IF ( wrf_dm_on_monitor() ) THEN +IF ( grid%active_this_task ) THEN CALL domain_clock_get ( grid, current_timestr=message2 ) #if (EM_CORE == 1) if (config_flags%use_adaptive_time_step) then @@ -367,17 +427,21 @@ SUBROUTINE dfi_accumulate( grid ) WRITE ( message , FMT = '("main: time ",A," on domain ",I3)' ) TRIM(message2), grid%id #endif CALL end_timing ( TRIM(message) ) - END IF +ENDIF ! active_this_task + ENDIF CALL med_endup_step ( grid , config_flags ) END DO +IF ( grid%active_this_task ) THEN ! Accumulation calculation for DFI CALL dfi_accumulate ( grid ) +ENDIF ! active_this_task + ! Avoid double writes on nests if this is not really the last time; ! Do check for write if the parent domain is ending. IF ( grid%id .EQ. 1 ) THEN ! head_grid - CALL med_last_solve_io ( grid , config_flags ) + IF ( grid%active_this_task ) CALL med_last_solve_io ( grid , config_flags ) ELSE ! zip up the tree and see if any ancestor is at its stop time should_do_last_io = domain_clockisstoptime( head_grid ) @@ -391,11 +455,12 @@ SUBROUTINE dfi_accumulate( grid ) IF ( should_do_last_io ) THEN grid_ptr => grid CALL med_nest_feedback ( grid_ptr%parents(1)%ptr, grid , config_flags ) - CALL med_last_solve_io ( grid , config_flags ) + IF ( grid%active_this_task ) CALL med_last_solve_io ( grid , config_flags ) ENDIF ENDIF ENDIF END IF + CALL pop_communicators_for_domain END SUBROUTINE integrate diff --git a/wrfv2_fire/frame/module_intermediate_nmm.F b/wrfv2_fire/frame/module_intermediate_nmm.F index 06426421..93394deb 100644 --- a/wrfv2_fire/frame/module_intermediate_nmm.F +++ b/wrfv2_fire/frame/module_intermediate_nmm.F @@ -24,7 +24,13 @@ SUBROUTINE parent_to_inter_part1 ( grid, intermediate_grid, ngrid, config_flags USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width, & + nest_pes_x, nest_pes_y, & + intercomm_active, nest_task_offsets, & + mpi_comm_to_mom, mpi_comm_to_kid, which_kid!, & + !push_communicators_for_domain,pop_communicators_for_domain + + USE module_timing IMPLICIT NONE @@ -32,7 +38,7 @@ SUBROUTINE parent_to_inter_part1 ( grid, intermediate_grid, ngrid, config_flags TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid INTEGER nlev, msize - INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k + INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k,ioffset,ierr INTEGER iparstrt,jparstrt,sw TYPE (grid_config_rec_type) :: config_flags REAL xv(500) @@ -52,13 +58,10 @@ SUBROUTINE parent_to_inter_part1 ( grid, intermediate_grid, ngrid, config_flags INTEGER local_comm, myproc, nproc INTEGER thisdomain_max_halo_width - CALL wrf_get_dm_communicator ( local_comm ) +! CALL wrf_get_dm_communicator ( local_comm ) CALL wrf_get_myproc( myproc ) CALL wrf_get_nproc( nproc ) - - - CALL get_ijk_from_grid ( grid , & cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & @@ -84,19 +87,25 @@ SUBROUTINE parent_to_inter_part1 ( grid, intermediate_grid, ngrid, config_flags nlev = ckde - ckds + 1 CALL get_dm_max_halo_width ( ngrid%id , thisdomain_max_halo_width ) + CALL wrf_dm_nestexchange_init - msize = 5 - CALL rsl_lite_to_child_info( local_communicator, msize*4 & + IF ( grid%active_this_task ) THEN + msize = 5 + CALL rsl_lite_to_child_info( msize*4 & ,cips,cipe,cjps,cjpe & ,iids,iide,ijds,ijde & ,nids,nide,njds,njde & ,pgr , sw & - ,ntasks_x,ntasks_y & - ,thisdomain_max_halo_width & + ,nest_task_offsets(ngrid%id) & + ,nest_pes_x(grid%id) & + ,nest_pes_y(grid%id) & + ,nest_pes_x(intermediate_grid%id) & + ,nest_pes_y(intermediate_grid%id) & + ,thisdomain_max_halo_width & ,icoord,jcoord & ,idim_cd,jdim_cd & ,pig,pjg,retval ) - DO while ( retval .eq. 1 ) + DO while ( retval .eq. 1 ) IF ( SIZE(grid%hres_fis) .GT. 1 ) THEN ! okay for intermediate_grid too. see comment in gen_comms.c xv(1)=grid%hres_fis(pig,pjg) CALL rsl_lite_to_child_msg(4,xv) @@ -113,29 +122,52 @@ SUBROUTINE parent_to_inter_part1 ( grid, intermediate_grid, ngrid, config_flags xv(1)=grid%fis(pig,pjg) CALL rsl_lite_to_child_msg(4,xv) ENDIF - CALL rsl_lite_to_child_info( local_communicator, msize*4 & + CALL rsl_lite_to_child_info( msize*4 & ,cips,cipe,cjps,cjpe & ,iids,iide,ijds,ijde & ,nids,nide,njds,njde & ,pgr , sw & - ,ntasks_x,ntasks_y & - ,thisdomain_max_halo_width & + ,nest_task_offsets(ngrid%id) & + ,nest_pes_x(grid%id) & + ,nest_pes_y(grid%id) & + ,nest_pes_x(intermediate_grid%id) & + ,nest_pes_y(intermediate_grid%id) & + ,thisdomain_max_halo_width & ,icoord,jcoord & ,idim_cd,jdim_cd & ,pig,pjg,retval ) - ENDDO - - CALL rsl_lite_bcast_msgs( myproc, nproc, local_comm ) + ENDDO + ENDIF ! grid%active_this_task + + IF ( intercomm_active( grid%id ) ) THEN ! I am parent + local_comm = mpi_comm_to_kid( which_kid(ngrid%id), grid%id ) + ioffset = nest_task_offsets(ngrid%id) + ELSE IF ( intercomm_active( ngrid%id ) ) THEN ! I am nest + local_comm = mpi_comm_to_mom( ngrid%id ) + ioffset = nest_task_offsets(ngrid%id) + ENDIF + + IF ( grid%active_this_task .OR. ngrid%active_this_task ) THEN +#if defined(DM_PARALLEL) && !defined(STUBMPI) + CALL mpi_comm_rank(local_comm,myproc,ierr) + CALL mpi_comm_size(local_comm,nproc,ierr) +#endif + CALL rsl_lite_bcast_msgs( myproc, nest_pes_x(grid%id)*nest_pes_y(grid%id), & + nest_pes_x(ngrid%id)*nest_pes_y(ngrid%id), & + ioffset, local_comm ) + ENDIF RETURN END SUBROUTINE parent_to_inter_part1 - SUBROUTINE parent_to_inter_part2 ( grid, config_flags ) + SUBROUTINE parent_to_inter_part2 ( grid, ngrid, config_flags ) USE module_state_description USE module_domain, ONLY : domain, get_ijk_from_grid USE module_configure, ONLY : grid_config_rec_type USE module_dm, ONLY : ntasks, ntasks_x, ntasks_y, itrace, local_communicator, mytask, & - ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width + ipe_save, jpe_save, ips_save, jps_save, get_dm_max_halo_width!, & + !push_communicators_for_domain,pop_communicators_for_domain + USE module_comm_dm, ONLY : HALO_NMM_INT_UP_sub IMPLICIT NONE @@ -167,7 +199,7 @@ SUBROUTINE parent_to_inter_part2 ( grid, config_flags ) cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe ) - cgrid=>grid +IF ( ngrid%active_this_task ) THEN nlev = ckde - ckds + 1 !write(0,*) 'IN parent_to_inter_part2' CALL rsl_lite_from_parent_info(pig,pjg,retval) @@ -196,6 +228,8 @@ SUBROUTINE parent_to_inter_part2 ( grid, config_flags ) CALL rsl_lite_from_parent_info(pig,pjg,retval) !write(0,*) 'back with retval=',retval ENDDO + + !write(0,*) 'out of loop' CALL get_ijk_from_grid ( grid , & @@ -203,10 +237,12 @@ SUBROUTINE parent_to_inter_part2 ( grid, config_flags ) ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) - !write(0,*) 'call HALO_NMM_INT_UP.inc' + CALL push_communicators_for_domain( grid%id ) #include "HALO_NMM_INT_UP.inc" - !write(0,*) 'back from HALO_NMM_INT_UP.inc' + CALL pop_communicators_for_domain +ENDIF + CALL wrf_dm_nestexchange_init RETURN END SUBROUTINE parent_to_inter_part2 #endif diff --git a/wrfv2_fire/frame/module_io.F b/wrfv2_fire/frame/module_io.F index 3c740740..040de254 100644 --- a/wrfv2_fire/frame/module_io.F +++ b/wrfv2_fire/frame/module_io.F @@ -193,7 +193,9 @@ SUBROUTINE wrf_ioexit( Status ) CALL ext_pio_ioexit ( ierr(12) ) #endif - IF ( use_output_servers() ) CALL wrf_quilt_ioexit( ierr(11) ) + IF ( use_output_servers() ) THEN + CALL wrf_quilt_ioexit( ierr(11) ) + ENDIF minerr = MINVAL(ierr) maxerr = MAXVAL(ierr) IF ( minerr < 0 ) THEN @@ -234,9 +236,9 @@ SUBROUTINE wrf_open_for_write_begin( FileName , grid, SysDepInfo, & INTEGER, EXTERNAL :: use_package LOGICAL, EXTERNAL :: wrf_dm_on_monitor, multi_files LOGICAL, EXTERNAL :: use_output_servers_for - CHARACTER*128 :: LocFilename ! for appending the process ID if necessary + CHARACTER*512 :: LocFilename ! for appending the process ID if necessary INTEGER :: myproc - CHARACTER*128 :: mess + CHARACTER*512 :: mess CHARACTER*1028 :: tstr, t1 INTEGER :: i,j INTEGER :: Comm_compute , Comm_io @@ -419,10 +421,10 @@ SUBROUTINE wrf_open_for_write_begin( FileName , grid, SysDepInfo, & ELSE ! use_output_servers_for(io_form) IF ( io_form .GT. 0 ) THEN IF ( ncd_nofill ) THEN - CALL wrf_quilt_open_for_write_begin ( FileName , Comm_compute, Comm_io, TRIM(SysDepInfo) // ",NOFILL=.TRUE.", & + CALL wrf_quilt_open_for_write_begin ( FileName , grid%id, Comm_compute, Comm_io, TRIM(SysDepInfo) // ",NOFILL=.TRUE.", & Hndl , io_form, Status ) ELSE - CALL wrf_quilt_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, & + CALL wrf_quilt_open_for_write_begin ( FileName , grid%id, Comm_compute, Comm_io, SysDepInfo, & Hndl , io_form, Status ) ENDIF ENDIF @@ -2624,7 +2626,7 @@ SUBROUTINE get_value_from_pairs ( varname , str , retval ) CHARACTER*(*) :: str CHARACTER*(*) :: retval - CHARACTER (128) varstr, tstr + CHARACTER (256) varstr, tstr INTEGER i,j,n,varstrn LOGICAL nobreak, nobreakouter diff --git a/wrfv2_fire/frame/module_io_quilt.F b/wrfv2_fire/frame/module_io_quilt.F index fa29ffa3..b7cc6525 100644 --- a/wrfv2_fire/frame/module_io_quilt.F +++ b/wrfv2_fire/frame/module_io_quilt.F @@ -1,5173 +1,8 @@ !WRF:DRIVER_LAYER:IO ! -#define DEBUG_LVL 50 -!#define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k ) ; write(0,*) __LINE__ -#define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k ) - -! Workaround for bug in the IBM MPI implementation. Look near the -! bottom of this file for an explanation. -#ifdef IBM_REDUCE_BUG_WORKAROUND -#define mpi_x_reduce(sb,rb,c,dt,op,r,com,ierr) reduce_add_integer(sb,rb,c,r,com) -#else -#define mpi_x_reduce(sb,rb,c,dt,op,r,com,ierr) MPI_Reduce(sb,rb,c,dt,op,r,com,ierr) -#endif - -MODULE module_wrf_quilt -! -!
-! This module contains WRF-specific I/O quilt routines called by both 
-! client (compute) and server (I/O quilt) tasks.  I/O quilt servers are 
-! a run-time optimization that allow I/O operations, executed on the I/O 
-! quilt server tasks, to be overlapped with useful computation, executed on 
-! the compute tasks.  Since I/O operations are often quite slow compared to 
-! computation, this performance optimization can increase parallel 
-! efficiency.  
-!
-! Currently, one group of I/O servers can be specified at run-time.  Namelist 
-! variable "nio_tasks_per_group" is used to specify the number of I/O server 
-! tasks in this group.  In most cases, parallel efficiency is optimized when 
-! the minimum number of I/O server tasks are used.  If memory needed to cache 
-! I/O operations fits on a single processor, then set nio_tasks_per_group=1.  
-! If not, increase the number of I/O server tasks until I/O operations fit in 
-! memory.  In the future, multiple groups of I/O server tasks will be 
-! supported.  The number of groups will be specified by namelist variable 
-! "nio_groups".  For now, nio_groups must be set to 1.  Currently, I/O servers 
-! only support overlap of output operations with computation.  Also, only I/O 
-! packages that do no support native parallel I/O may be used with I/O server 
-! tasks.  This excludes PHDF5 and MCEL.  
-!
-! In this module, the I/O quilt server tasks call package-dependent 
-! WRF-specific I/O interfaces to perform I/O operations requested by the 
-! client (compute) tasks.  All of these calls occur inside subroutine 
-! quilt().  
-! 
-! The client (compute) tasks call package-independent WRF-specific "quilt I/O" 
-! interfaces that send requests to the I/O quilt servers.  All of these calls 
-! are made from module_io.F.  
-!
-! These routines have the same names and (roughly) the same arguments as those 
-! specified in the WRF I/O API except that:
-! - "Quilt I/O" routines defined in this file and called by routines in 
-!   module_io.F have the "wrf_quilt_" prefix.
-! - Package-dependent routines called from routines in this file are defined 
-!   in the external I/O packages and have the "ext_" prefix.
-!
-! Both client (compute) and server tasks call routine init_module_wrf_quilt() 
-! which then calls setup_quilt_servers() determine which tasks are compute 
-! tasks and which are server tasks.  Before the end of init_module_wrf_quilt() 
-! server tasks call routine quilt() and remain there for the rest of the model 
-! run.  Compute tasks return from init_module_wrf_quilt() to perform model 
-! computations.  
-!
-! See http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the latest
-! version of the WRF I/O API.  This document includes detailed descriptions
-! of subroutines and their arguments that are not duplicated here.
-!
-! - USE module_internal_header_util - USE module_timing -#if ( DA_CORE != 1 ) - USE module_cpl, ONLY : coupler_on, cpl_set_dm_communicator, cpl_finalize -#endif - - INTEGER, PARAMETER :: int_num_handles = 99 - INTEGER, PARAMETER :: max_servers = int_num_handles+1 ! why +1? - LOGICAL, DIMENSION(0:int_num_handles) :: okay_to_write, int_handle_in_use, okay_to_commit - INTEGER, DIMENSION(0:int_num_handles) :: int_num_bytes_to_write, io_form - REAL, POINTER,SAVE :: int_local_output_buffer(:) - INTEGER, SAVE :: int_local_output_cursor - LOGICAL :: quilting_enabled - LOGICAL :: disable_quilt = .FALSE. - INTEGER :: prev_server_for_handle = -1 - INTEGER :: server_for_handle(int_num_handles) - INTEGER :: reduced(2), reduced_dummy(2) - LOGICAL, EXTERNAL :: wrf_dm_on_monitor - - INTEGER :: mpi_comm_avail,availrank - LOGICAL :: in_avail=.false., poll_servers=.false. - - INTEGER nio_groups -#ifdef DM_PARALLEL - INTEGER :: mpi_comm_local - LOGICAL :: compute_node - LOGICAL :: compute_group_master(max_servers) - INTEGER :: mpi_comm_io_groups(max_servers) - INTEGER :: nio_tasks_in_group - INTEGER :: nio_tasks_per_group - INTEGER :: ncompute_tasks - INTEGER :: ntasks - INTEGER :: mytask - - INTEGER, PARAMETER :: onebyte = 1 - INTEGER comm_io_servers, iserver, hdrbufsize, obufsize - INTEGER, DIMENSION(4096) :: hdrbuf - INTEGER, DIMENSION(int_num_handles) :: handle -#endif - -#ifdef IBM_REDUCE_BUG_WORKAROUND -! Workaround for bug in the IBM MPI implementation. Look near the -! bottom of this file for an explanation. - interface reduce_add_integer - module procedure reduce_add_int_arr - module procedure reduce_add_int_scl - end interface -#endif - - CONTAINS - -#if defined(DM_PARALLEL) && !defined( STUBMPI ) - INTEGER FUNCTION get_server_id ( dhandle ) -! -! Logic in the client side to know which io server -! group to send to. If the unit corresponds to a file that's -! already been opened, then we have no choice but to send the -! data to that group again, regardless of whether there are -! other server-groups. If it's a new file, we can chose a new -! server group. I.e. opening a file locks it onto a server -! group. Closing the file unlocks it. -! - IMPLICIT NONE - INTEGER, INTENT(IN) :: dhandle - IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN - IF ( server_for_handle ( dhandle ) .GE. 1 ) THEN - get_server_id = server_for_handle ( dhandle ) - ELSE - IF(poll_servers) THEN - ! Poll server group masters to find an inactive I/O server group: - call wrf_quilt_find_server(server_for_handle(dhandle)) - ELSE - ! Server polling is disabled, so cycle through servers: - prev_server_for_handle = mod ( prev_server_for_handle + 1 , nio_groups ) - server_for_handle( dhandle ) = prev_server_for_handle+1 - ENDIF - get_server_id=server_for_handle(dhandle) - ENDIF - ELSE - CALL wrf_message('module_io_quilt: get_server_id bad dhandle' ) - ENDIF - END FUNCTION get_server_id -#endif - - SUBROUTINE set_server_id ( dhandle, value ) - IMPLICIT NONE - INTEGER, INTENT(IN) :: dhandle, value - IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN - server_for_handle(dhandle) = value - ELSE - CALL wrf_message('module_io_quilt: set_server_id bad dhandle' ) - ENDIF - END SUBROUTINE set_server_id - - LOGICAL FUNCTION get_poll_servers() - implicit none - get_poll_servers=poll_servers - end FUNCTION get_poll_servers - -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - SUBROUTINE int_get_fresh_handle( retval ) -! -! Find an unused "client file handle" and return it in retval. -! The "client file handle" is used to remember how a file was opened -! so clients do not need to ask the I/O quilt servers for this information. -! It is also used as a file identifier in communications with the I/O -! server task. -! -! Note that client tasks know nothing about package-specific handles. -! Only the I/O quilt servers know about them. -! - INTEGER i, retval - retval = -1 - DO i = 1, int_num_handles - IF ( .NOT. int_handle_in_use(i) ) THEN - retval = i - GOTO 33 - ENDIF - ENDDO -33 CONTINUE - IF ( retval < 0 ) THEN - CALL wrf_error_fatal("frame/module_io_quilt.F: int_get_fresh_handle() can not") - ENDIF - int_handle_in_use(i) = .TRUE. - NULLIFY ( int_local_output_buffer ) - END SUBROUTINE int_get_fresh_handle - - SUBROUTINE setup_quilt_servers ( nio_tasks_per_group, & - mytask, & - ntasks, & - n_groups_arg, & - nio, & - mpi_comm_wrld, & - mpi_comm_local, & - mpi_comm_io_groups) -! -! Both client (compute) and server tasks call this routine to -! determine which tasks are compute tasks and which are I/O server tasks. -! -! Module variables MPI_COMM_LOCAL and MPI_COMM_IO_GROUPS(:) are set up to -! contain MPI communicators as follows: -! -! MPI_COMM_LOCAL is the Communicator for the local groups of tasks. For the -! compute tasks it is the group of compute tasks; for a server group it the -! communicator of tasks in the server group. -! -! Elements of MPI_COMM_IO_GROUPS are communicators that each contain one or -! more compute tasks and a single I/O server assigned to those compute tasks. -! The I/O server tasks is always the last task in these communicators. -! On a compute task, which has a single associate in each of the server -! groups, MPI_COMM_IO_GROUPS is treated as an array; each element corresponds -! to a different server group. -! On a server task only the first element of MPI_COMM_IO_GROUPS is used -! because each server task is part of only one io_group. -! -! I/O server tasks in each I/O server group are divided among compute tasks as -! evenly as possible. -! -! When multiple I/O server groups are used, each must have the same number of -! tasks. When the total number of extra I/O tasks does not divide evenly by -! the number of io server groups requested, the remainder tasks are not used -! (wasted). -! -! For example, communicator membership for 18 tasks with nio_groups=2 and -! nio_tasks_per_group=3 is shown below: -! -!
-! Membership for MPI_COMM_LOCAL communicators:
-!   COMPUTE TASKS:          0   1   2   3   4   5   6   7   8   9  10  11
-!   1ST I/O SERVER GROUP:  12  13  14
-!   2ND I/O SERVER GROUP:  15  16  17
-!
-! Membership for MPI_COMM_IO_GROUPS(1):  
-!   COMPUTE TASKS 0, 3, 6, 9:   0   3   6   9  12
-!   COMPUTE TASKS 1, 4, 7,10:   1   4   7  10  13
-!   COMPUTE TASKS 2, 5, 8,11:   2   5   8  11  14
-!   I/O SERVER TASK       12:   0   3   6   9  12
-!   I/O SERVER TASK       13:   1   4   7  10  13
-!   I/O SERVER TASK       14:   2   5   8  11  14
-!   I/O SERVER TASK       15:   0   3   6   9  15
-!   I/O SERVER TASK       16:   1   4   7  10  16
-!   I/O SERVER TASK       17:   2   5   8  11  17
-!
-! Membership for MPI_COMM_IO_GROUPS(2):  
-!   COMPUTE TASKS 0, 3, 6, 9:   0   3   6   9  15
-!   COMPUTE TASKS 1, 4, 7,10:   1   4   7  10  16
-!   COMPUTE TASKS 2, 5, 8,11:   2   5   8  11  17
-!   I/O SERVER TASK       12:  ** not used **
-!   I/O SERVER TASK       13:  ** not used **
-!   I/O SERVER TASK       14:  ** not used **
-!   I/O SERVER TASK       15:  ** not used **
-!   I/O SERVER TASK       16:  ** not used **
-!   I/O SERVER TASK       17:  ** not used **
-!
-! - USE module_configure -#ifdef DM_PARALLEL - USE module_dm, ONLY : compute_mesh -#endif - IMPLICIT NONE - INCLUDE 'mpif.h' - INTEGER, INTENT(IN) :: nio_tasks_per_group, mytask, ntasks, & - n_groups_arg, mpi_comm_wrld - INTEGER, INTENT(OUT) :: mpi_comm_local, nio - INTEGER, DIMENSION(100), INTENT(OUT) :: mpi_comm_io_groups -! Local - INTEGER :: i, j, ii, comdup, ierr, niotasks, n_groups, iisize - INTEGER, DIMENSION(ntasks) :: icolor - CHARACTER*128 mess - INTEGER :: io_form_setting - INTEGER :: me - INTEGER :: k, m, nprocx, nprocy - LOGICAL :: reorder_mesh - -!check the namelist and make sure there are no output forms specified -!that cannot be quilted - CALL nl_get_io_form_history(1, io_form_setting) ; call sokay( 'history', io_form_setting ) - CALL nl_get_io_form_restart(1, io_form_setting) ; call sokay( 'restart', io_form_setting ) - CALL nl_get_io_form_auxhist1(1, io_form_setting) ; call sokay( 'auxhist1', io_form_setting ) - CALL nl_get_io_form_auxhist2(1, io_form_setting) ; call sokay( 'auxhist2', io_form_setting ) - CALL nl_get_io_form_auxhist3(1, io_form_setting) ; call sokay( 'auxhist3', io_form_setting ) - CALL nl_get_io_form_auxhist4(1, io_form_setting) ; call sokay( 'auxhist4', io_form_setting ) - CALL nl_get_io_form_auxhist5(1, io_form_setting) ; call sokay( 'auxhist5', io_form_setting ) - CALL nl_get_io_form_auxhist6(1, io_form_setting) ; call sokay( 'auxhist6', io_form_setting ) - CALL nl_get_io_form_auxhist7(1, io_form_setting) ; call sokay( 'auxhist7', io_form_setting ) - CALL nl_get_io_form_auxhist8(1, io_form_setting) ; call sokay( 'auxhist8', io_form_setting ) - CALL nl_get_io_form_auxhist9(1, io_form_setting) ; call sokay( 'auxhist9', io_form_setting ) - CALL nl_get_io_form_auxhist10(1, io_form_setting) ; call sokay( 'auxhist10', io_form_setting ) - CALL nl_get_io_form_auxhist11(1, io_form_setting) ; call sokay( 'auxhist11', io_form_setting ) - - n_groups = n_groups_arg - IF ( n_groups .LT. 1 ) n_groups = 1 - - compute_node = .TRUE. - -! -! nio is number of io tasks per group. If there arent enough tasks to satisfy -! the requirement that there be at least as many compute tasks as io tasks in -! each group, then just print a warning and dump out of quilting -! - - nio = nio_tasks_per_group - ncompute_tasks = ntasks - (nio * n_groups) - IF ( ncompute_tasks .LT. nio ) THEN - WRITE(mess,'("Not enough tasks to have ",I3," groups of ",I3," I/O tasks. No quilting.")')n_groups,nio - nio = 0 - ncompute_tasks = ntasks - ELSE - WRITE(mess,'("Quilting with ",I3," groups of ",I3," I/O tasks.")')n_groups,nio - ENDIF - CALL wrf_message(mess) - - IF ( nio .LT. 0 ) THEN - nio = 0 - ENDIF - IF ( nio .EQ. 0 ) THEN - quilting_enabled = .FALSE. - mpi_comm_local = mpi_comm_wrld - mpi_comm_io_groups = mpi_comm_wrld - RETURN - ENDIF - quilting_enabled = .TRUE. - -! First construct the local communicators -! prepare to split the communicator by designating compute-only tasks - DO i = 1, ncompute_tasks - icolor(i) = 0 - ENDDO - ii = 1 -! and designating the groups of i/o tasks - DO i = ncompute_tasks+1, ntasks, nio - DO j = i, i+nio-1 - icolor(j) = ii - ENDDO - ii = ii+1 - ENDDO - CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr) - CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_local,ierr) - -! Now construct the communicators for the io_groups - CALL nl_get_reorder_mesh(1,reorder_mesh) - IF ( reorder_mesh ) THEN - reorder_mesh = .FALSE. - CALL nl_set_reorder_mesh(1,reorder_mesh) - CALL wrf_message('Warning: reorder_mesh does not work with quilting. Disabled reorder_mesh.') - ENDIF - ! assign the compute tasks to the i/o tasks in full rows - CALL compute_mesh( ncompute_tasks, nprocx, nprocy ) - - nio = min(nio,nprocy) - m = mod(nprocy,nio) ! divide up remainder, 1 row per, until gone - ii = 1 - DO j = 1, nio, 1 - DO k = 1,nprocy/nio+min(m,1) - DO i = 1, nprocx - icolor(ii) = j - 1 - ii = ii + 1 - ENDDO - ENDDO - m = max(m-1,0) - ENDDO - -! ... and add the io servers as the last task in each group - DO j = 1, n_groups - ! TBH: each I/O group will contain only one I/O server - DO i = ncompute_tasks+1,ntasks - icolor(i) = MPI_UNDEFINED - ENDDO - ii = 0 - DO i = ncompute_tasks+(j-1)*nio+1,ncompute_tasks+j*nio - icolor(i) = ii - ii = ii+1 - ENDDO - CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr) - CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask, & - mpi_comm_io_groups(j),ierr) - ENDDO - -#ifdef PNETCDF_QUILT - if(poll_servers) then - poll_servers=.false. - call wrf_message('Warning: server polling does not work with pnetcdf_quilt. Disabled poll_servers.') - else -#endif - if(nio_groups==1) then - poll_servers=.false. - call wrf_message('Server polling is useless with one io group. Disabled poll_servers.') - endif -#ifdef PNETCDF_QUILT - endif -#endif - - if(poll_servers) then - ! If server polling is enabled, we need to create mpi_comm_avail, - ! which contains the monitor process, and the I/O server master process - ! for each I/O server group. This will be used in the routines - ! wrf_quilt_find_server and wrf_quilt_server_ready to find inactive - ! I/O servers for new data handles in get_server_id. - - ! The "in_avail" is set to true iff I am in the mpi_comm_avail. - - call mpi_comm_rank(mpi_comm_wrld,me,ierr) - - icolor=MPI_UNDEFINED - in_avail=.false. - - if(wrf_dm_on_monitor()) then - in_avail=.true. ! monitor process is in mpi_comm_avail - endif - icolor(1)=1 - - do j=1,n_groups - i=ncompute_tasks+j*nio-1 - if(me+1==i) then - in_avail=.true. ! I/O server masters are in mpi_comm_avail - endif - icolor(i)=1 - enddo - - CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr) - CALL MPI_Comm_split(comdup,icolor(me+1),me, & - mpi_comm_avail,ierr) - - availrank=MPI_UNDEFINED - if(in_avail) then - call mpi_comm_rank(mpi_comm_avail,availrank,ierr) - endif - - endif - - compute_group_master = .FALSE. - compute_node = .FALSE. - - DO j = 1, n_groups - - IF ( mytask .LT. ncompute_tasks .OR. & ! I am a compute task - (ncompute_tasks+(j-1)*nio .LE. mytask .AND. mytask .LT. ncompute_tasks+j*nio) & ! I am the I/O server for this group - ) THEN - - CALL MPI_Comm_Size( mpi_comm_io_groups(j) , iisize, ierr ) - ! Get the rank of this compute task in the compute+io - ! communicator to which it belongs - CALL MPI_Comm_Rank( mpi_comm_io_groups(j) , me , ierr ) - - ! If I am an I/O server for this group then make that group's - ! communicator the first element in the mpi_comm_io_groups array - ! (I will ignore all of the other elements). - IF (ncompute_tasks+(j-1)*nio .LE. mytask .AND. mytask .LT. ncompute_tasks+j*nio) THEN - mpi_comm_io_groups(1) = mpi_comm_io_groups(j) - ELSE - compute_node = .TRUE. - ! If I am a compute task, check whether I am the member of my - ! group that will communicate things that should be sent just - ! once (e.g. commands) to the IO server of my group. - compute_group_master(j) = (me .EQ. 0) - -! IF( compute_group_master(j) ) WRITE(*,*) mytask,': ARPDBG : I will talk to IO server in group ',j - ENDIF - ENDIF - ENDDO - - END SUBROUTINE setup_quilt_servers - - SUBROUTINE sokay ( stream, io_form ) - USE module_state_description - CHARACTER*(*) stream - CHARACTER*256 mess - INTEGER io_form - - SELECT CASE (io_form) -#ifdef NETCDF - CASE ( IO_NETCDF ) - RETURN -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - RETURN -#endif -#ifdef YYY - CASE ( IO_YYY ) - RETURN -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - RETURN -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - RETURN -#endif - CASE (0) - RETURN - CASE DEFAULT - WRITE(mess,*)' An output format has been specified that is incompatible with quilting: io_form: ',io_form,' ',TRIM(stream) - CALL wrf_error_fatal(mess) - END SELECT - END SUBROUTINE sokay - - SUBROUTINE quilt -! -! I/O server tasks call this routine and remain in it for the rest of the -! model run. I/O servers receive I/O requests from compute tasks and -! perform requested I/O operations by calling package-dependent WRF-specific -! I/O interfaces. Requests are sent in the form of "data headers". Each -! request has a unique "header" message associated with it. For requests that -! contain large amounts of data, the data is appended to the header. See -! file module_internal_header_util.F for detailed descriptions of all -! headers. -! -! We wish to be able to link to different packages depending on whether -! the I/O is restart, initial, history, or boundary. -! - USE module_state_description - USE module_quilt_outbuf_ops - USE module_configure, only : grid_config_rec_type, model_config_rec, model_to_grid_config_rec - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "intio_tags.h" -#include "wrf_io_flags.h" - TYPE (grid_config_rec_type) :: config_flags - INTEGER itag, ninbuf, ntasks_io_group, ntasks_local_group, mytask_local, ierr - INTEGER istat - INTEGER mytask_io_group - INTEGER :: nout_set = 0 - INTEGER :: obufsize, bigbufsize, chunksize, sz - REAL, DIMENSION(1) :: dummy - INTEGER, ALLOCATABLE, DIMENSION(:) :: obuf, bigbuf - REAL, ALLOCATABLE, DIMENSION(:) :: RDATA - INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA - CHARACTER (LEN=512) :: CDATA - CHARACTER (LEN=80) :: fname - INTEGER icurs, hdrbufsize, itypesize, ftypesize, rtypesize, Status, fstat, io_form_arg - INTEGER :: DataHandle, FieldType, Comm, IOComm, DomainDesc, code, Count - INTEGER, DIMENSION(3) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd - INTEGER :: dummybuf(1) - INTEGER :: num_noops, num_commit_messages, num_field_training_msgs, hdr_tag - CHARACTER (len=256) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess - INTEGER, EXTERNAL :: use_package - LOGICAL :: stored_write_record, retval - INTEGER iii, jjj, vid, CC, DD, dom_id - LOGICAL :: call_server_ready - -logical okay_to_w -character*120 sysline - - dom_id = 1 ! always a valid assumption for domain id for this netcdf setting - CALL model_to_grid_config_rec ( dom_id , model_config_rec , config_flags ) - -! If we've been built with PNETCDF_QUILT defined then we use parallel I/O -! within the group of I/O servers rather than gathering the data onto the -! root I/O server. Unfortunately, this approach means that we can no-longer -! select different I/O layers for use with quilting at run time. ARPDBG. -! This code is sufficiently different that it is kept in the separate -! quilt_pnc() routine. -#ifdef PNETCDF_QUILT - CALL quilt_pnc() - RETURN -#endif - -! Call ext_pkg_ioinit() routines to initialize I/O packages. - SysDepInfo = " " -#ifdef NETCDF - if ( config_flags%use_netcdf_classic ) SysDepInfo="use_netcdf_classic" - CALL ext_ncd_ioinit( SysDepInfo, ierr ) - SysDepInfo = " " -#endif -#ifdef INTIO - CALL ext_int_ioinit( SysDepInfo, ierr ) -#endif -#ifdef XXX - CALL ext_xxx_ioinit( SysDepInfo, ierr) -#endif -#ifdef YYY - CALL ext_yyy_ioinit( SysDepInfo, ierr) -#endif -#ifdef ZZZ - CALL ext_zzz_ioinit( SysDepInfo, ierr) -#endif -#ifdef GRIB1 - CALL ext_gr1_ioinit( SysDepInfo, ierr) -#endif -#ifdef GRIB2 - CALL ext_gr2_ioinit( SysDepInfo, ierr) -#endif - - call_server_ready = .true. ! = true when the server is ready for a new file - - okay_to_commit = .false. - stored_write_record = .false. - ninbuf = 0 - ! get info. about the I/O server group that this I/O server task - ! belongs to - ! Last task in this I/O server group is the I/O server "root" - ! The I/O server "root" actually writes data to disk - ! TBH: WARNING: This is also implicit in the call to collect_on_comm(). - CALL mpi_x_comm_size( mpi_comm_io_groups(1), ntasks_io_group, ierr ) - CALL MPI_COMM_RANK( mpi_comm_io_groups(1), mytask_io_group, ierr ) - CALL mpi_x_comm_size( mpi_comm_local, ntasks_local_group, ierr ) - CALL MPI_COMM_RANK( mpi_comm_local, mytask_local, ierr ) - - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - IF ( itypesize <= 0 ) THEN - CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid") - ENDIF - -! Work out whether this i/o server processor has one fewer associated compute proc than -! the most any processor has. Can happen when number of i/o tasks does not evenly divide -! the number of compute tasks. This is needed to keep the i/o tasks sychronized on the -! same message when they start commmunicating to stitch together an output. -! -! Compute processes associated with this task: - CC = ntasks_io_group - 1 -! Number of compute tasks per I/O task (less remainder) - DD = ncompute_tasks / ntasks_local_group -! -! If CC-DD is 1 on servrs with the maximum number of compute clients, -! 0 on servrs with one less than maximum - - -! infinite loop until shutdown message received -! This is the main request-handling loop. I/O quilt servers stay in this loop -! until the model run ends. -okay_to_w = .false. - DO WHILE (.TRUE.) ! { - -! -! Each I/O server receives requests from its compute tasks. Each request -! is contained in a data header (see module_internal_header_util.F for -! detailed descriptions of data headers). -! Each request is sent in two phases. First, sizes of all messages that -! will be sent from the compute tasks to this I/O server are summed on the -! I/O server via MPI_reduce(). The I/O server then allocates buffer "obuf" -! and receives concatenated messages from the compute tasks in it via the -! call to collect_on_comm(). Note that "sizes" are generally expressed in -! *bytes* in this code so conversion to "count" (number of Fortran words) is -! required for Fortran indexing and MPI calls. -! - - if(poll_servers .and. call_server_ready) then - call_server_ready=.false. - ! Send a message to the monitor telling it we're ready - ! for a new data handle. - call wrf_quilt_server_ready() - endif - - ! wait for info from compute tasks in the I/O group that we're ready to rock - ! obufsize will contain number of *bytes* -!CALL start_timing() - ! first element of reduced is obufsize, second is DataHandle - ! if needed (currently needed only for ioclose). - reduced_dummy = 0 - CALL mpi_x_reduce( reduced_dummy, reduced, 2, MPI_INTEGER, MPI_SUM, mytask_io_group, mpi_comm_io_groups(1), ierr ) - obufsize = reduced(1) -!CALL end_timing("MPI_Reduce at top of forever loop") -!JMDEBUGwrite(0,*)'obufsize = ',obufsize -! Negative obufsize will trigger I/O server exit. - IF ( obufsize .LT. 0 ) THEN - IF ( obufsize .EQ. -100 ) THEN ! magic number -#ifdef NETCDF - CALL ext_ncd_ioexit( Status ) -#endif -#ifdef INTIO - CALL ext_int_ioexit( Status ) -#endif -#ifdef XXX - CALL ext_xxx_ioexit( Status ) -#endif -#ifdef YYY - CALL ext_yyy_ioexit( Status ) -#endif -#ifdef ZZZ - CALL ext_zzz_ioexit( Status ) -#endif -#ifdef GRIB1 - CALL ext_gr1_ioexit( Status ) -#endif -#ifdef GRIB2 - CALL ext_gr2_ioexit( Status ) -#endif - CALL wrf_message ( 'I/O QUILT SERVERS DONE' ) -#if ( DA_CORE != 1 ) - IF (coupler_on) THEN - CALL cpl_finalize() - ELSE -#endif - CALL mpi_finalize(ierr) -#if ( DA_CORE != 1 ) - END IF -#endif - STOP - ELSE - WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.' - CALL wrf_error_fatal(mess) - ENDIF - ENDIF - -! CALL start_timing() -! Obufsize of zero signals a close - -! Allocate buffer obuf to be big enough for the data the compute tasks -! will send. Note: obuf is size in *bytes* so we need to pare this -! down, since the buffer is INTEGER. - IF ( obufsize .GT. 0 ) THEN - ALLOCATE( obuf( (obufsize+1)/itypesize ) ) - -! let's roll; get the data from the compute procs and put in obuf - CALL collect_on_comm_debug(__FILE__,__LINE__, mpi_comm_io_groups(1), & - onebyte, & - dummy, 0, & - obuf, obufsize ) -! CALL end_timing( "quilt on server: collecting data from compute procs" ) - ELSE - ! Necessarily, the compute processes send the ioclose signal, - ! if there is one, after the iosync, which means they - ! will stall on the ioclose message waiting for the quilt - ! processes if we handle the way other messages are collected, - ! using collect_on_comm. This avoids this, but we need - ! a special signal (obufsize zero) and the DataHandle - ! to be closed. That handle is send as the second - ! word of the io_close message received by the MPI_Reduce above. - ! Then a header representing the ioclose message is constructed - ! here and handled below as if it were received from the - ! compute processes. The clients (compute processes) must be - ! careful to send this correctly (one compule process sends the actual - ! handle and everone else sends a zero, so the result sums to - ! the value of the handle). - ! - ALLOCATE( obuf( 4096 ) ) - ! DataHandle is provided as second element of reduced - CALL int_gen_handle_header( obuf, obufsize, itypesize, & - reduced(2) , int_ioclose ) - - if(poll_servers) then - ! Once we're done closing, we need to tell the master - ! process that we're ready for more data. - call_server_ready=.true. - endif - ENDIF - -!write(0,*)'calling init_store_piece_of_field' -! Now all messages received from the compute clients are stored in -! obuf. Scan through obuf and extract headers and field data and store in -! internal buffers. The scan is done twice, first to determine sizes of -! internal buffers required for storage of headers and fields and second to -! actually store the headers and fields. This bit of code does not do the -! "quilting" (assembly of patches into full domains). For each field, it -! simply concatenates all received patches for the field into a separate -! internal buffer (i.e. one buffer per field). Quilting is done later by -! routine store_patch_in_outbuf(). - CALL init_store_piece_of_field - CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr ) -!write(0,*)'mpi_type_size returns ', itypesize -! Scan obuf the first time to calculate the size of the buffer required for -! each field. Calls to add_to_bufsize_for_field() accumulate sizes. - vid = 0 - icurs = itypesize - num_noops = 0 - num_commit_messages = 0 - num_field_training_msgs = 0 - DO WHILE ( icurs .lt. obufsize ) ! { - hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) - SELECT CASE ( hdr_tag ) - CASE ( int_field ) - CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & - DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & - DomainDesc , MemoryOrder , Stagger , DimNames , & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd ) - chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & - (PatchEnd(3)-PatchStart(3)+1)*ftypesize - - IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks - IF ( num_field_training_msgs .EQ. 0 ) THEN - call add_to_bufsize_for_field( VarName, hdrbufsize ) -!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - ENDIF - num_field_training_msgs = num_field_training_msgs + 1 - ELSE - call add_to_bufsize_for_field( VarName, hdrbufsize ) -!write(0,*) 'X-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - ENDIF - icurs = icurs + hdrbufsize - -!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - - ! If this is a real write (i.e. not a training write), accumulate - ! buffersize for this field. - IF ( DomainDesc .NE. 333933 ) THEN ! magic number -!write(0,*) 'X-1a', chunksize, TRIM(VarName) - call add_to_bufsize_for_field( VarName, chunksize ) - icurs = icurs + chunksize - ENDIF - CASE ( int_open_for_write_commit ) ! only one per group of tasks - hdrbufsize = obuf(icurs/itypesize) - IF (num_commit_messages.EQ.0) THEN - call add_to_bufsize_for_field( 'COMMIT', hdrbufsize ) - ENDIF - num_commit_messages = num_commit_messages + 1 - icurs = icurs + hdrbufsize - CASE DEFAULT - hdrbufsize = obuf(icurs/itypesize) - -! This logic and the logic in the loop below is used to determine whether -! to send a noop records sent by the compute processes to allow to go -! through. The purpose is to make sure that the communications between this -! server and the other servers in this quilt group stay synchronized in -! the collection loop below, even when the servers are serving different -! numbers of clients. Here are some conditions: -! -! 1. The number of compute clients served will not differ by more than 1 -! 2. The servers with +1 number of compute clients begin with task 0 -! of mpi_comm_local, the commicator shared by this group of servers -! -! 3. For each collective field or metadata output from the compute tasks, -! there will be one record sent to the associated i/o server task. The -! i/o server task collects these records and stores them contiguously -! in a buffer (obuf) using collect_on_comm above. Thus, obuf on this -! server task will contain one record from each associated compute -! task, in order. -! -! 4. In the case of replicated output from the compute tasks -! (e.g. put_dom_ti records and control records like -! open_for_write_commit type records), compute task 0 is the only -! one that sends the record. The other compute tasks send noop -! records. Thus, obuf on server task zero will contain the output -! record from task 0 followed by noop records from the rest of the -! compute tasks associated with task 0. Obuf on the other server -! tasks will contain nothing but noop records. -! -! 5. The logic below will not allow any noop records from server task 0. -! It allows only one noop record from each of the other server tasks -! in the i/o group. This way, for replicated output, when the records -! are collected on one server task below, using collect_on_comm on -! mpi_comm_local, each task will provide exactly one record for each -! call to collect_on_comm: 1 bona fide output record from server task -! 0 and noops from the rest. - - IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) & - .OR.hdr_tag.NE.int_noop) THEN - write(VarName,'(I5.5)')vid -!write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - call add_to_bufsize_for_field( VarName, hdrbufsize ) - vid = vid+1 - ENDIF - IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 - icurs = icurs + hdrbufsize - END SELECT - ENDDO ! } -! Store the headers and field data in internal buffers. The first call to -! store_piece_of_field() allocates internal buffers using sizes computed by -! calls to add_to_bufsize_for_field(). - vid = 0 - icurs = itypesize - num_noops = 0 - num_commit_messages = 0 - num_field_training_msgs = 0 - DO WHILE ( icurs .lt. obufsize ) !{ -!write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize - hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) - SELECT CASE ( hdr_tag ) - CASE ( int_field ) - CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & - DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & - DomainDesc , MemoryOrder , Stagger , DimNames , & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd ) - chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & - (PatchEnd(3)-PatchStart(3)+1)*ftypesize - - IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks - IF ( num_field_training_msgs .EQ. 0 ) THEN - call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) -!write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - ENDIF - num_field_training_msgs = num_field_training_msgs + 1 - ELSE - call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) -!write(0,*) 'A-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - ENDIF - icurs = icurs + hdrbufsize - ! If this is a real write (i.e. not a training write), store - ! this piece of this field. - IF ( DomainDesc .NE. 333933 ) THEN ! magic number -!write(0,*) 'A-1a', chunksize, TRIM(VarName),PatchStart(1:3),PatchEnd(1:3) - call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize ) - icurs = icurs + chunksize - ENDIF - CASE ( int_open_for_write_commit ) ! only one per group of tasks - hdrbufsize = obuf(icurs/itypesize) - IF (num_commit_messages.EQ.0) THEN - call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize ) - ENDIF - num_commit_messages = num_commit_messages + 1 - icurs = icurs + hdrbufsize - CASE DEFAULT - hdrbufsize = obuf(icurs/itypesize) - IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) & - .OR.hdr_tag.NE.int_noop) THEN - write(VarName,'(I5.5)')vid -!write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) - vid = vid+1 - ENDIF - IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 - icurs = icurs + hdrbufsize - END SELECT - ENDDO !} - -! Now, for each field, retrieve headers and patches (data) from the internal -! buffers and collect them all on the I/O quilt server "root" task. - CALL init_retrieve_pieces_of_field -! Retrieve header and all patches for the first field from the internal -! buffers. - CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) -! Sum sizes of all headers and patches (data) for this field from all I/O -! servers in this I/O server group onto the I/O server "root". - CALL mpi_x_reduce( sz, bigbufsize, 1, MPI_INTEGER, MPI_SUM, ntasks_local_group-1, mpi_comm_local, ierr ) -!write(0,*)'seed: sz ',sz,' bigbufsize ',bigbufsize,' VarName ', TRIM(VarName),' retval ',retval - -! Loop until there are no more fields to retrieve from the internal buffers. - DO WHILE ( retval ) !{ -#if 0 -#else - -! I/O server "root" allocates space to collect headers and fields from all -! other servers in this I/O server group. - IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN - ALLOCATE( bigbuf( (bigbufsize+1)/itypesize ) ) - else - ALLOCATE( bigbuf(1) ) - ENDIF - -! Collect buffers and fields from all I/O servers in this I/O server group -! onto the I/O server "root" - CALL collect_on_comm_debug2(__FILE__,__LINE__,Trim(VarName), & - get_hdr_tag(obuf),sz,get_hdr_rec_size(obuf), & - mpi_comm_local, & - onebyte, & - obuf, sz, & - bigbuf, bigbufsize ) -! The I/O server "root" now handles collected requests from all compute -! tasks served by this I/O server group (i.e. all compute tasks). - IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN -!jjj = 4 -!do iii = 1, ntasks_local_group -! write(0,*)'i,j,tag,size ', iii, jjj, get_hdr_tag(bigbuf(jjj/4)),get_hdr_rec_size(bigbuf(jjj/4)) -! jjj = jjj + get_hdr_rec_size(bigbuf(jjj/4)) -!enddo - - icurs = itypesize ! icurs is a byte counter, but buffer is integer - - stored_write_record = .false. - -! The I/O server "root" loops over the collected requests. - DO WHILE ( icurs .lt. bigbufsize ) !{ - CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr ) - -!write(0,*)'B tag,size ',icurs,get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) -! The I/O server "root" gets the request out of the next header and -! handles it by, in most cases, calling the appropriate external I/O package -! interface. - SELECT CASE ( get_hdr_tag( bigbuf(icurs/itypesize) ) ) -! The I/O server "root" handles the "noop" (do nothing) request. This is -! actually quite easy. "Noop" requests exist to help avoid race conditions. -! In some cases, only one compute task will everything about a request so -! other compute tasks send "noop" requests. - CASE ( int_noop ) - CALL int_get_noop_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize ) - icurs = icurs + hdrbufsize - -! The I/O server "root" handles the "put_dom_td_real" request. - CASE ( int_dom_td_real ) - CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) - ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c - CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & - DataHandle, DateStr, Element, RData, Count, code ) - icurs = icurs + hdrbufsize - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - DEALLOCATE( RData ) -! The I/O server "root" handles the "put_dom_ti_real" request. - CASE ( int_dom_ti_real ) -!write(0,*)' int_dom_ti_real ' - CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) - ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c - CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & - DataHandle, Element, RData, Count, code ) - icurs = icurs + hdrbufsize - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) -!write(0,*)'ext_ncd_put_dom_ti_real ',handle(DataHandle),TRIM(Element),RData,Status -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - DEALLOCATE( RData ) - -! The I/O server "root" handles the "put_dom_td_integer" request. - CASE ( int_dom_td_integer ) -!write(0,*)' int_dom_td_integer ' - CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) - ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c - CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & - DataHandle, DateStr, Element, IData, Count, code ) - icurs = icurs + hdrbufsize - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - DEALLOCATE( IData ) - -! The I/O server "root" handles the "put_dom_ti_integer" request. - CASE ( int_dom_ti_integer ) -!write(0,*)' int_dom_ti_integer ' - - CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) - ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c - CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & - DataHandle, Element, IData, Count, code ) - icurs = icurs + hdrbufsize - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) -!write(0,*)'ext_ncd_put_dom_ti_integer ',handle(DataHandle),TRIM(Element),IData,Status -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) -#endif - - CASE DEFAULT - Status = 0 - END SELECT - - DEALLOCATE( IData) - -! The I/O server "root" handles the "set_time" request. - CASE ( int_set_time ) -!write(0,*)' int_set_time ' - CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle, Element, VarName, CData, code ) - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_set_time ( handle(DataHandle), TRIM(CData), Status) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - icurs = icurs + hdrbufsize - -! The I/O server "root" handles the "put_dom_ti_char" request. - CASE ( int_dom_ti_char ) -!write(0,*)' before int_get_ti_header_char ' - CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle, Element, VarName, CData, code ) -!write(0,*)' after int_get_ti_header_char ',VarName - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - icurs = icurs + hdrbufsize - -! The I/O server "root" handles the "put_var_ti_char" request. - CASE ( int_var_ti_char ) -!write(0,*)' int_var_ti_char ' - CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle, Element, VarName, CData, code ) - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - icurs = icurs + hdrbufsize - - CASE ( int_ioexit ) -! ioexit is now handled by sending negative message length to server - CALL wrf_error_fatal( & - "quilt: should have handled int_ioexit already") -! The I/O server "root" handles the "ioclose" request. - CASE ( int_ioclose ) - CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle , code ) - icurs = icurs + hdrbufsize - - IF ( DataHandle .GE. 1 ) THEN -!JMDEBUGwrite(0,*)'closing DataHandle ',DataHandle,' io_form ',io_form(DataHandle) - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_ncd_ioclose(handle(DataHandle),Status) - ENDIF -#endif -#ifdef PNETCDF - CASE ( IO_PNETCDF ) - CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_pnc_ioclose(handle(DataHandle),Status) - ENDIF -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_int_ioclose(handle(DataHandle),Status) - ENDIF -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_yyy_ioclose(handle(DataHandle),Status) - ENDIF -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_gr1_ioclose(handle(DataHandle),Status) - ENDIF -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_gr2_ioclose(handle(DataHandle),Status) - ENDIF -#endif - CASE DEFAULT - Status = 0 - END SELECT - ENDIF - -! If desired, outputs a ready flag after quilting subroutine closes the data handle for history (wrfout) file. - - IF (fname(1:6) .EQ. 'wrfout' .AND. config_flags%output_ready_flag ) THEN - OPEN (unit=99,file='wrfoutReady' // fname(7:30), status='unknown', access='sequential') - CLOSE (99) - ENDIF - -! The I/O server "root" handles the "open_for_write_begin" request. - CASE ( int_open_for_write_begin ) - - CALL int_get_ofwb_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & - FileName,SysDepInfo,io_form_arg,DataHandle ) - -!write(0,*)' int_open_for_write_begin itypesize ',itypesize,' itypesize ',itypesize -!write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize -!JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle -!write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo) - icurs = icurs + hdrbufsize -!write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) - - io_form(DataHandle) = io_form_arg - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) -!write(0,*)'ext_ncd_open_for_write_begin ',Trim(FileName),DataHandle,handle(DataHandle),Status -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - okay_to_write(DataHandle) = .false. - -! The I/O server "root" handles the "open_for_write_commit" request. -! In this case, the "okay_to_commit" is simply set to .true. so "write_field" -! requests will initiate writes to disk. Actual commit will be done after -! all requests in this batch have been handled. - CASE ( int_open_for_write_commit ) - - CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle , code ) - icurs = icurs + hdrbufsize - okay_to_commit(DataHandle) = .true. - -! The I/O server "root" handles the "write_field" (int_field) request. -! If okay_to_write(DataHandle) is .true. then the patch in the -! header (bigbuf) is written to a globally-sized internal output buffer via -! the call to store_patch_in_outbuf(). Note that this is where the actual -! "quilting" (reassembly of patches onto a full-size domain) is done. If -! okay_to_write(DataHandle) is .false. then external I/O package interfaces -! are called to write metadata for I/O formats that support native metadata. -! -! NOTE that the I/O server "root" will only see write_field (int_field) -! requests AFTER an "iosync" request. - CASE ( int_field ) - CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) - CALL int_get_write_field_header ( bigbuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & - DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & - DomainDesc , MemoryOrder , Stagger , DimNames , & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd ) -!write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle) - icurs = icurs + hdrbufsize - - IF ( okay_to_write(DataHandle) ) THEN - -! WRITE(0,*)'>>> ',TRIM(DateStr), ' ', TRIM(VarName), ' ', TRIM(MemoryOrder), ' ', & -! (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)*(PatchEnd(3)-PatchStart(3)+1) - - IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN - ! Note that the WRF_DOUBLE branch of this IF statement must come first since - ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds. - IF ( FieldType .EQ. WRF_DOUBLE) THEN -! this branch has not been tested TBH: 20050406 - CALL mpi_type_size( MPI_DOUBLE_PRECISION, ftypesize, ierr ) - ELSE - CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) - ENDIF - stored_write_record = .true. - CALL store_patch_in_outbuf ( bigbuf(icurs/itypesize), dummybuf, TRIM(DateStr), TRIM(VarName) , & - FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd ) - - ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN - CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) - stored_write_record = .true. - CALL store_patch_in_outbuf ( dummybuf, bigbuf(icurs/itypesize), TRIM(DateStr), TRIM(VarName) , & - FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd ) - ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN - ftypesize = LWORDSIZE - ENDIF - icurs = icurs + (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & - (PatchEnd(3)-PatchStart(3)+1)*ftypesize - ELSE - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_write_field ( handle(DataHandle) , TRIM(DateStr) , & - TRIM(VarName) , dummy , FieldType , Comm , IOComm, & - DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & - DomainStart , DomainEnd , & - DomainStart , DomainEnd , & - DomainStart , DomainEnd , & - Status ) -#endif -#if 0 -! since this is training and the grib output doesn't need training, disable this branch. -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_YYY_write_field ( handle(DataHandle) , TRIM(DateStr) , & - TRIM(VarName) , dummy , FieldType , Comm , IOComm, & - DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & - DomainStart , DomainEnd , & - DomainStart , DomainEnd , & - DomainStart , DomainEnd , & - Status ) -#endif -#endif - CASE DEFAULT - Status = 0 - END SELECT - ENDIF - CASE ( int_iosync ) - CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle , code ) - icurs = icurs + hdrbufsize - CASE DEFAULT - WRITE(mess,*)'quilt: bad tag: ',get_hdr_tag( bigbuf(icurs/itypesize) ),' icurs ',icurs/itypesize - CALL wrf_error_fatal( mess ) - END SELECT - - ENDDO !} -! Now, the I/O server "root" has finshed handling all commands from the latest -! call to retrieve_pieces_of_field(). - - IF (stored_write_record) THEN -! If any fields have been stored in a globally-sized internal output buffer -! (via a call to store_patch_in_outbuf()) then call write_outbuf() to write -! them to disk now. -! NOTE that the I/O server "root" will only have called -! store_patch_in_outbuf() when handling write_field (int_field) -! commands which only arrive AFTER an "iosync" command. -! CALL start_timing - CALL write_outbuf ( handle(DataHandle), use_package(io_form(DataHandle))) -! CALL end_timing( "quilt: call to write_outbuf" ) - ENDIF - -! If one or more "open_for_write_commit" commands were encountered from the -! latest call to retrieve_pieces_of_field() then call the package-specific -! routine to do the commit. - IF (okay_to_commit(DataHandle)) THEN - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_ncd_open_for_write_commit(handle(DataHandle),Status) - okay_to_write(DataHandle) = .true. - ENDIF -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_int_open_for_write_commit(handle(DataHandle),Status) - okay_to_write(DataHandle) = .true. - ENDIF -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_yyy_open_for_write_commit(handle(DataHandle),Status) - okay_to_write(DataHandle) = .true. - ENDIF -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_gr1_open_for_write_commit(handle(DataHandle),Status) - okay_to_write(DataHandle) = .true. - ENDIF -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_gr2_open_for_write_commit(handle(DataHandle),Status) - okay_to_write(DataHandle) = .true. - ENDIF -#endif - - CASE DEFAULT - Status = 0 - END SELECT - - okay_to_commit(DataHandle) = .false. - ENDIF - DEALLOCATE( bigbuf ) - ENDIF -#endif - if(allocated(bigbuf)) deallocate(bigbuf) -! Retrieve header and all patches for the next field from the internal -! buffers. - CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) -! Sum sizes of all headers and patches (data) for this field from all I/O -! servers in this I/O server group onto the I/O server "root". - CALL mpi_x_reduce( sz, bigbufsize, 1, MPI_INTEGER,MPI_SUM, ntasks_local_group-1,mpi_comm_local, ierr ) -! Then, return to the top of the loop to collect headers and data from all -! I/O servers in this I/O server group onto the I/O server "root" and handle -! the next batch of commands. - END DO !} - - DEALLOCATE( obuf ) - - ! flush output files if needed - IF (stored_write_record) THEN -! CALL start_timing() - SELECT CASE ( use_package(io_form) ) -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_iosync( handle(DataHandle), Status ) -#endif -#ifdef XXX - CASE ( IO_XXX ) - CALL ext_xxx_iosync( handle(DataHandle), Status ) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_iosync( handle(DataHandle), Status ) -#endif -#ifdef ZZZ - CASE ( IO_ZZZ ) - CALL ext_zzz_iosync( handle(DataHandle), Status ) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_iosync( handle(DataHandle), Status ) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_iosync( handle(DataHandle), Status ) -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_iosync( handle(DataHandle), Status ) -#endif - CASE DEFAULT - Status = 0 - END SELECT -!CALL end_timing( "quilt: flush" ) - ENDIF - - END DO ! } - - END SUBROUTINE quilt - - SUBROUTINE quilt_pnc -! -! Same as quilt() routine except that _all_ of the IO servers that call it -! actually write data to disk using pNetCDF. This version is only used when -! the code is compiled with PNETCDF_QUILT defined. -! - USE module_state_description - USE module_quilt_outbuf_ops - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "intio_tags.h" -#include "wrf_io_flags.h" - INTEGER itag, ninbuf, ntasks_io_group, ntasks_local_group, mytask_local, ierr - INTEGER istat - INTEGER mytask_io_group - INTEGER :: nout_set = 0 - INTEGER :: obufsize, bigbufsize, chunksize, sz - REAL, DIMENSION(1) :: dummy - INTEGER, ALLOCATABLE, DIMENSION(:) :: obuf, bigbuf - REAL, ALLOCATABLE, DIMENSION(:) :: RDATA - INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA - CHARACTER (LEN=512) :: CDATA - CHARACTER (LEN=80) :: fname - INTEGER icurs, hdrbufsize, itypesize, ftypesize, rtypesize, Status, fstat, io_form_arg - INTEGER :: DataHandle, FieldType, Comm, IOComm, DomainDesc, code, Count - INTEGER, DIMENSION(3) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd - INTEGER :: dummybuf(1) - INTEGER :: num_noops, num_commit_messages, num_field_training_msgs, hdr_tag - CHARACTER (len=256) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess - INTEGER, EXTERNAL :: use_package - LOGICAL :: stored_write_record, retval, written_record - INTEGER iii, jjj, vid, CC, DD - -! logical okay_to_w -! character*120 sysline - -! Call ext_pkg_ioinit() routines to initialize I/O packages. - SysDepInfo = " " -#ifdef NETCDF - CALL ext_ncd_ioinit( SysDepInfo, ierr) -#endif -#ifdef PNETCDF_QUILT - CALL ext_pnc_ioinit( SysDepInfo, ierr) -#endif -#ifdef INTIO - CALL ext_int_ioinit( SysDepInfo, ierr ) -#endif -#ifdef XXX - CALL ext_xxx_ioinit( SysDepInfo, ierr) -#endif -#ifdef YYY - CALL ext_yyy_ioinit( SysDepInfo, ierr) -#endif -#ifdef ZZZ - CALL ext_zzz_ioinit( SysDepInfo, ierr) -#endif -#ifdef GRIB1 - CALL ext_gr1_ioinit( SysDepInfo, ierr) -#endif -#ifdef GRIB2 - CALL ext_gr2_ioinit( SysDepInfo, ierr) -#endif - - okay_to_commit = .false. - stored_write_record = .false. - ninbuf = 0 - ! get info. about the I/O server group that this I/O server task - ! belongs to - CALL mpi_x_comm_size( mpi_comm_io_groups(1), ntasks_io_group, ierr ) - CALL MPI_COMM_RANK( mpi_comm_io_groups(1), mytask_io_group, ierr ) - CALL mpi_x_comm_size( mpi_comm_local, ntasks_local_group, ierr ) - CALL MPI_COMM_RANK( mpi_comm_local, mytask_local, ierr ) - - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - IF ( itypesize <= 0 ) THEN - CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid") - ENDIF - -! Work out whether this i/o server processor has one fewer associated compute proc than -! the most any processor has. Can happen when number of i/o tasks does not evenly divide -! the number of compute tasks. This is needed to keep the i/o tasks sychronized on the -! same message when they start commmunicating to stitch together an output. -! -! Compute processes associated with this task: - CC = ntasks_io_group - 1 -! Number of compute tasks per I/O task (less remainder) - DD = ncompute_tasks / ntasks_local_group -! -! If CC-DD is 1 on servrs with the maximum number of compute clients, -! 0 on servrs with one less than maximum - - -! infinite loop until shutdown message received -! This is the main request-handling loop. I/O quilt servers stay in this loop -! until the model run ends. -!okay_to_w = .false. - DO WHILE (.TRUE.) ! { - -! -! Each I/O server receives requests from its compute tasks. Each request -! is contained in a data header (see module_internal_header_util.F for -! detailed descriptions of data headers). -! Each request is sent in two phases. First, sizes of all messages that -! will be sent from the compute tasks to this I/O server are summed on the -! I/O server via MPI_reduce(). The I/O server then allocates buffer "obuf" -! and receives concatenated messages from the compute tasks in it via the -! call to collect_on_comm(). Note that "sizes" are generally expressed in -! *bytes* in this code so conversion to "count" (number of Fortran words) is -! required for Fortran indexing and MPI calls. -! - ! wait for info from compute tasks in the I/O group that we're ready to rock - ! obufsize will contain number of *bytes* -!CALL start_timing - ! first element of reduced is obufsize, second is DataHandle - ! if needed (currently needed only for ioclose). - reduced_dummy = 0 - CALL mpi_x_reduce( reduced_dummy, reduced, 2, MPI_INTEGER, MPI_SUM, mytask_io_group, mpi_comm_io_groups(1), ierr ) - obufsize = reduced(1) -!CALL end_timing("MPI_Reduce at top of forever loop") -!JMDEBUGwrite(0,*)'obufsize = ',obufsize -! Negative obufsize will trigger I/O server exit. - IF ( obufsize .LT. 0 ) THEN - IF ( obufsize .EQ. -100 ) THEN ! magic number -#ifdef NETCDF - CALL ext_ncd_ioexit( Status ) -#endif -#ifdef PNETCDF_QUILT - CALL ext_pnc_ioexit( Status ) -#endif -#ifdef INTIO - CALL ext_int_ioexit( Status ) -#endif -#ifdef XXX - CALL ext_xxx_ioexit( Status ) -#endif -#ifdef YYY - CALL ext_yyy_ioexit( Status ) -#endif -#ifdef ZZZ - CALL ext_zzz_ioexit( Status ) -#endif -#ifdef GRIB1 - CALL ext_gr1_ioexit( Status ) -#endif -#ifdef GRIB2 - CALL ext_gr2_ioexit( Status ) -#endif - CALL wrf_message ( 'I/O QUILT SERVERS DONE' ) - CALL mpi_finalize(ierr) - STOP - ELSE - WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.' - CALL wrf_error_fatal(mess) - ENDIF - ENDIF - -! CALL start_timing -! Obufsize of zero signals a close - -! Allocate buffer obuf to be big enough for the data the compute tasks -! will send. Note: obuf is size in *bytes* so we need to pare this -! down, since the buffer is INTEGER. - IF ( obufsize .GT. 0 ) THEN - ALLOCATE( obuf( (obufsize+1)/itypesize ) ) - -! let's roll; get the data from the compute procs and put in obuf - CALL collect_on_comm_debug(__FILE__,__LINE__, mpi_comm_io_groups(1), & - onebyte, & - dummy, 0, & - obuf, obufsize ) -! CALL end_timing( "quilt on server: collecting data from compute procs" ) - ELSE - ! Necessarily, the compute processes send the ioclose signal, - ! if there is one, after the iosync, which means they - ! will stall on the ioclose message waiting for the quilt - ! processes if we handle the way other messages are collected, - ! using collect_on_comm. This avoids this, but we need - ! a special signal (obufsize zero) and the DataHandle - ! to be closed. That handle is send as the second - ! word of the io_close message received by the MPI_Reduce above. - ! Then a header representing the ioclose message is constructed - ! here and handled below as if it were received from the - ! compute processes. The clients (compute processes) must be - ! careful to send this correctly (one compule process sends the actual - ! handle and everone else sends a zero, so the result sums to - ! the value of the handle). - ! - ALLOCATE( obuf( 4096 ) ) - ! DataHandle is provided as second element of reduced - CALL int_gen_handle_header( obuf, obufsize, itypesize, & - reduced(2) , int_ioclose ) - ENDIF - -!write(0,*)'calling init_store_piece_of_field' -! Now all messages received from the compute clients are stored in -! obuf. Scan through obuf and extract headers and field data and store in -! internal buffers. The scan is done twice, first to determine sizes of -! internal buffers required for storage of headers and fields and second to -! actually store the headers and fields. This bit of code does not do any -! "quilting" (assembly of patches into full domains). For each field, it -! simply writes all received patches for the field to disk. -! ARPDBG we can vastly reduce the number of writes to disk by stitching -! any contiguous patches together first. Has implications for synchronisation -! of pNetCDF calls though. - CALL init_store_piece_of_field - CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr ) -!write(0,*)'mpi_type_size returns ', itypesize -! Scan obuf the first time to calculate the size of the buffer required for -! each field. Calls to add_to_bufsize_for_field() accumulate sizes. - vid = 0 - icurs = itypesize - num_noops = 0 - num_commit_messages = 0 - num_field_training_msgs = 0 - DO WHILE ( icurs .lt. obufsize ) ! { - hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) - SELECT CASE ( hdr_tag ) - CASE ( int_field ) - CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & - DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & - DomainDesc , MemoryOrder , Stagger , DimNames , & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd ) - chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & - (PatchEnd(3)-PatchStart(3)+1)*ftypesize - - IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks - IF ( num_field_training_msgs .EQ. 0 ) THEN - call add_to_bufsize_for_field( VarName, hdrbufsize ) -!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - ENDIF - num_field_training_msgs = num_field_training_msgs + 1 - ELSE - call add_to_bufsize_for_field( VarName, hdrbufsize ) -!write(0,*) 'X-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - ENDIF - icurs = icurs + hdrbufsize - -!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - - ! If this is a real write (i.e. not a training write), accumulate - ! buffersize for this field. - IF ( DomainDesc .NE. 333933 ) THEN ! magic number -!write(0,*) 'X-1a', chunksize, TRIM(VarName) - call add_to_bufsize_for_field( VarName, chunksize ) - icurs = icurs + chunksize - ENDIF - CASE ( int_open_for_write_commit ) ! only one per group of tasks - hdrbufsize = obuf(icurs/itypesize) - IF (num_commit_messages.EQ.0) THEN - call add_to_bufsize_for_field( 'COMMIT', hdrbufsize ) - ENDIF - num_commit_messages = num_commit_messages + 1 - icurs = icurs + hdrbufsize - CASE DEFAULT - hdrbufsize = obuf(icurs/itypesize) - -! This logic and the logic in the loop below is used to determine whether -! to send a noop records sent by the compute processes to allow to go -! through. The purpose is to make sure that the communications between this -! server and the other servers in this quilt group stay synchronized in -! the collection loop below, even when the servers are serving different -! numbers of clients. Here are some conditions: -! -! 1. The number of compute clients served will not differ by more than 1 -! 2. The servers with +1 number of compute clients begin with task 0 -! of mpi_comm_local, the commicator shared by this group of servers -! -! 3. For each collective field or metadata output from the compute tasks, -! there will be one record sent to the associated i/o server task. The -! i/o server task collects these records and stores them contiguously -! in a buffer (obuf) using collect_on_comm above. Thus, obuf on this -! server task will contain one record from each associated compute -! task, in order. -! ! -! 4. In the case of replicated output from the compute tasks -! (e.g. put_dom_ti records and control records like -! open_for_write_commit type records), only compute tasks for which -! (compute_group_master == .TRUE) send the record. The other compute -! tasks send noop records. This is done so that each server task -! receives exactly one record plus noops from the other compute tasks. -! -! 5. Logic below does not allow any noop records through since each IO -! server task now receives a valid record (from the 'compute-group master' -! when doing replicated output - IF (hdr_tag.NE.int_noop) THEN - write(VarName,'(I5.5)')vid -!write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - call add_to_bufsize_for_field( VarName, hdrbufsize ) - vid = vid+1 - ENDIF - IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 - icurs = icurs + hdrbufsize - - END SELECT - ENDDO ! } -! Store the headers and field data in internal buffers. The first call to -! store_piece_of_field() allocates internal buffers using sizes computed by -! calls to add_to_bufsize_for_field(). - vid = 0 - icurs = itypesize - num_noops = 0 - num_commit_messages = 0 - num_field_training_msgs = 0 - DO WHILE ( icurs .lt. obufsize ) !{ -!write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize - hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) - SELECT CASE ( hdr_tag ) - CASE ( int_field ) - CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & - DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & - DomainDesc , MemoryOrder , Stagger , DimNames , & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd ) - chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & - (PatchEnd(3)-PatchStart(3)+1)*ftypesize - - IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks - IF ( num_field_training_msgs .EQ. 0 ) THEN - call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) -!write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - ENDIF - num_field_training_msgs = num_field_training_msgs + 1 - ELSE - call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) -!write(0,*) 'A-2a', icurs, hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - ENDIF - icurs = icurs + hdrbufsize - ! If this is a real write (i.e. not a training write), store - ! this piece of this field. - IF ( DomainDesc .NE. 333933 ) THEN ! magic number - call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize ) - icurs = icurs + chunksize -!write(0,*) 'A-1a',TRIM(VarName),' icurs ',icurs,PatchStart(1:3),PatchEnd(1:3) - ENDIF - CASE ( int_open_for_write_commit ) ! only one per group of tasks - hdrbufsize = obuf(icurs/itypesize) - IF (num_commit_messages.EQ.0) THEN - call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize ) - ENDIF - num_commit_messages = num_commit_messages + 1 - icurs = icurs + hdrbufsize - CASE DEFAULT - hdrbufsize = obuf(icurs/itypesize) - IF (hdr_tag.NE.int_noop) THEN - - write(VarName,'(I5.5)')vid -!write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) - call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) - vid = vid+1 - ENDIF - IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 - icurs = icurs + hdrbufsize - END SELECT - ENDDO !} while(icurs < obufsize) - -! Now, for each field, retrieve headers and patches (data) from the internal -! buffers - CALL init_retrieve_pieces_of_field -! Retrieve header and all patches for the first field from the internal -! buffers. - CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) - written_record = .false. - -! Loop until there are no more fields to retrieve from the internal buffers. - DO WHILE ( retval ) !{ - -! This I/O server now handles the collected requests from the compute -! tasks it serves - - icurs = itypesize ! icurs is a byte counter, but buffer is integer - - stored_write_record = .false. - -! ALL I/O servers in this group loop over the collected requests they have -! received. - DO WHILE ( icurs .lt. sz)! bigbufsize ) !{ - -! The I/O server gets the request out of the next header and -! handles it by, in most cases, calling the appropriate external I/O package -! interface. -!write(0,*)__FILE__,__LINE__,'get_hdr_tag ',icurs,sz,get_hdr_tag( obuf(icurs/itypesize) ) - SELECT CASE ( get_hdr_tag( obuf(icurs/itypesize) ) ) -! The I/O server handles the "noop" (do nothing) request. This is -! actually quite easy. "Noop" requests exist to help avoid race conditions. - CASE ( int_noop ) - CALL int_get_noop_header( obuf(icurs/itypesize), & - hdrbufsize, itypesize ) - icurs = icurs + hdrbufsize - -! The I/O server "root" handles the "put_dom_td_real" request. - CASE ( int_dom_td_real ) - CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) - ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c - CALL int_get_td_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & - DataHandle, DateStr, Element, RData, Count, code ) - icurs = icurs + hdrbufsize - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef PNETCDF_QUILT - CASE (IO_PNETCDF ) - CALL ext_pnc_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) -#endif -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - DEALLOCATE( RData ) -! Every I/O server handles the "put_dom_ti_real" request. - CASE ( int_dom_ti_real ) - - CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) - ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c - CALL int_get_ti_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & - DataHandle, Element, RData, Count, code ) - icurs = icurs + hdrbufsize - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef PNETCDF_QUILT - CASE (IO_PNETCDF ) - CALL ext_pnc_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) -#endif -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - DEALLOCATE( RData ) - -! Every I/O server handles the "put_dom_td_integer" request. - CASE ( int_dom_td_integer ) - - CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) - ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c - CALL int_get_td_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & - DataHandle, DateStr, Element, IData, Count, code ) - icurs = icurs + hdrbufsize - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef PNETCDF_QUILT - CASE (IO_PNETCDF ) - CALL ext_pnc_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) -#endif -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - DEALLOCATE( IData ) - -! Every I/O server handles the "put_dom_ti_integer" request. - CASE ( int_dom_ti_integer ) - - CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) - ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c - CALL int_get_ti_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & - DataHandle, Element, IData, Count, code ) - icurs = icurs + hdrbufsize - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef PNETCDF_QUILT - CASE (IO_PNETCDF ) - CALL ext_pnc_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) -#endif -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) -#endif - - CASE DEFAULT - Status = 0 - END SELECT - - DEALLOCATE( IData) - -! Every I/O server handles the "set_time" request. - CASE ( int_set_time ) - - CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle, Element, VarName, CData, code ) - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_set_time ( handle(DataHandle), TRIM(CData), Status) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - icurs = icurs + hdrbufsize - -! Every I/O server handles the "put_dom_ti_char" request. - CASE ( int_dom_ti_char ) - - CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle, Element, VarName, CData, code ) - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef PNETCDF_QUILT - CASE (IO_PNETCDF ) - CALL ext_pnc_put_dom_ti_char ( handle(DataHandle), TRIM(Element), Trim(CData), Status) -#endif -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - icurs = icurs + hdrbufsize - -! Every I/O server handles the "put_var_ti_char" request. - CASE ( int_var_ti_char ) - - CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle, Element, VarName, CData, code ) - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef PNETCDF_QUILT - CASE (IO_PNETCDF ) - CALL ext_pnc_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status ) -#endif -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - icurs = icurs + hdrbufsize - - CASE ( int_ioexit ) -! ioexit is now handled by sending negative message length to server - CALL wrf_error_fatal( & - "quilt: should have handled int_ioexit already") -! Every I/O server handles the "ioclose" request. - CASE ( int_ioclose ) - CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle , code ) - icurs = icurs + hdrbufsize - - IF ( DataHandle .GE. 1 ) THEN - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef PNETCDF_QUILT - CASE ( IO_PNETCDF ) - CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_pnc_ioclose(handle(DataHandle),Status) - ENDIF -#endif -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_ncd_ioclose(handle(DataHandle),Status) - ENDIF -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_int_ioclose(handle(DataHandle),Status) - ENDIF -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_yyy_ioclose(handle(DataHandle),Status) - ENDIF -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_gr1_ioclose(handle(DataHandle),Status) - ENDIF -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_gr2_ioclose(handle(DataHandle),Status) - ENDIF -#endif - CASE DEFAULT - Status = 0 - END SELECT - ENDIF - -! Every I/O server handles the "open_for_write_begin" request. - CASE ( int_open_for_write_begin ) - - CALL int_get_ofwb_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & - FileName,SysDepInfo,io_form_arg,DataHandle ) - -!write(0,*)' int_open_for_write_begin itypesize ',itypesize,' itypesize ',itypesize -!write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize -!JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle -!write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo) - icurs = icurs + hdrbufsize -!write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) - - io_form(DataHandle) = io_form_arg - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef PNETCDF_QUILT - CASE (IO_PNETCDF ) - CALL ext_pnc_open_for_write_begin(FileName,mpi_comm_local,mpi_comm_local,SysDepInfo,handle(DataHandle),Status ) -#endif -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) -!write(0,*)'ext_ncd_open_for_write_begin ',Trim(FileName),DataHandle,handle(DataHandle),Status -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) -#endif - CASE DEFAULT - Status = 0 - END SELECT - - okay_to_write(DataHandle) = .false. - -! Every I/O server handles the "open_for_write_commit" request. -! In this case, the "okay_to_commit" is simply set to .true. so "write_field" -! (int_field) requests will initiate writes to disk. Actual commit will be done after -! all requests in this batch have been handled. - CASE ( int_open_for_write_commit ) - - CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle , code ) - icurs = icurs + hdrbufsize - okay_to_commit(DataHandle) = .true. - -! Every I/O server handles the "write_field" (int_field) request. -! If okay_to_write(DataHandle) is .true. then the patch in the -! header (bigbuf) is written to disk using pNetCDF. Note that this is where the actual -! "quilting" (reassembly of patches onto a full-size domain) is done. If -! okay_to_write(DataHandle) is .false. then external I/O package interfaces -! are called to write metadata for I/O formats that support native metadata. -! -! NOTE that the I/O servers will only see write_field (int_field) -! requests AFTER an "iosync" request. - CASE ( int_field ) - CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) - CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & - DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & - DomainDesc , MemoryOrder , Stagger , DimNames , & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd ) -!write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle) - icurs = icurs + hdrbufsize - - IF ( okay_to_write(DataHandle) ) THEN - -!!$ WRITE(0,FMT="('>>> ',(A),1x,(A),1x,A2,I6,1x,3('[',I3,',',I3,'] '))") & -!!$ TRIM(DateStr), TRIM(VarName), TRIM(MemoryOrder), & -!!$ (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)*(PatchEnd(3)-PatchStart(3)+1), & -!!$PatchStart(1),PatchEnd(1),PatchStart(2),PatchEnd(2),PatchStart(3),PatchEnd(3) -!!$ WRITE(0,FMT="('>>> ',(A),1x,(A),1x,I6,1x,3('[',I3,',',I3,'] '))") & -!!$ TRIM(DateStr), TRIM(VarName), DomainDesc, & -!!$ DomainStart(1),DomainEnd(1),DomainStart(2),DomainEnd(2),DomainStart(3),DomainEnd(3) - - IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN - ! Note that the WRF_DOUBLE branch of this IF statement must come first since - ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds. - IF ( FieldType .EQ. WRF_DOUBLE) THEN -! this branch has not been tested TBH: 20050406 - CALL mpi_type_size( MPI_DOUBLE_PRECISION, ftypesize, ierr ) - ELSE - CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) - ENDIF - -#ifdef PNETCDF_QUILT -! WRITE(mess,FMT="('>>> ',(A),1x,(A),1x,I6,1x,3('[',I3,',',I3,'] '))") & -! TRIM(DateStr), TRIM(VarName), DomainDesc, & -! DomainStart(1),DomainEnd(1), & -! DomainStart(2),DomainEnd(2),DomainStart(3),DomainEnd(3) -! CALL wrf_message(mess) - - CALL store_patch_in_outbuf_pnc(obuf(icurs/itypesize), & - dummybuf, TRIM(DateStr), & - TRIM(VarName) , & - FieldType, & - TRIM(MemoryOrder), & - TRIM(Stagger), & - DimNames, & - DomainStart , DomainEnd ,& - MemoryStart , MemoryEnd ,& - PatchStart , PatchEnd, & - ntasks_io_group-1 ) - stored_write_record = .true. - -!!$ IF(VarName .eq. "PSFC")THEN -!!$ CALL dump_real_array_c(obuf(icurs/itypesize), DomainStart,& -!!$ DomainEnd, PatchStart, PatchEnd, & -!!$ mytask_local, DomainDesc) -!!$ ENDIF - -#endif - ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN - CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) -#ifdef PNETCDF_QUILT - CALL store_patch_in_outbuf_pnc ( dummybuf, & - obuf(icurs/itypesize) , & - TRIM(DateStr) , & - TRIM(VarName) , & - FieldType, & - TRIM(MemoryOrder) , & - TRIM(Stagger), DimNames, & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd , & - ntasks_io_group-1 ) - stored_write_record = .true. -#endif - ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN - ftypesize = LWORDSIZE - ENDIF - - icurs = icurs + (PatchEnd(1)-PatchStart(1)+1)* & - (PatchEnd(2)-PatchStart(2)+1)* & - (PatchEnd(3)-PatchStart(3)+1)*ftypesize - - ELSE ! Write metadata only (or do 'training'?) - - SELECT CASE (use_package(io_form(DataHandle))) - -#ifdef PNETCDF_QUILT - CASE ( IO_PNETCDF ) - CALL ext_pnc_write_field ( handle(DataHandle) , TRIM(DateStr), & - TRIM(VarName) , dummy , FieldType , mpi_comm_local , mpi_comm_local, & - DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger), DimNames , & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd, & - Status ) -#endif -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_write_field ( handle(DataHandle) , TRIM(DateStr) , & - TRIM(VarName) , dummy , FieldType , Comm , IOComm, & - DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & - DomainStart , DomainEnd , & - DomainStart , DomainEnd , & - DomainStart , DomainEnd , & - Status ) -#endif -#if 0 -! since this is training and the grib output doesn't need training, disable this branch. -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_YYY_write_field ( handle(DataHandle) , TRIM(DateStr) , & - TRIM(VarName) , dummy , FieldType , Comm , IOComm, & - DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & - DomainStart , DomainEnd , & - DomainStart , DomainEnd , & - DomainStart , DomainEnd , & - Status ) -#endif -#endif - CASE DEFAULT - Status = 0 - END SELECT - ENDIF - CASE ( int_iosync ) - CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & - DataHandle , code ) - icurs = icurs + hdrbufsize - CASE DEFAULT - WRITE(mess,*)'quilt: bad tag: ', & - get_hdr_tag( obuf(icurs/itypesize) ),' icurs ',& - icurs/itypesize - CALL wrf_error_fatal( mess ) - END SELECT - - ENDDO !} -! Now, we have finshed handling all commands from the latest -! call to retrieve_pieces_of_field(). - - IF (stored_write_record) THEN -! If any field patches have been stored in internal output buffers -! (via a call to store_patch_in_outbuf_pnc()) then call write_outbuf_pnc() -! to write them to disk now. -! NOTE that the I/O server will only have called -! store_patch_in_outbuf() when handling write_field (int_field) -! commands which only arrive AFTER an "iosync" command. -! CALL start_timing -#ifdef PNETCDF_QUILT - CALL write_outbuf_pnc( handle(DataHandle), & - use_package(io_form(DataHandle)), & - mpi_comm_local, mytask_local, & - ntasks_local_group) -#endif -! CALL end_timing( "quilt_pnc: call to write_outbuf_pnc" ) - stored_write_record = .false. - written_record = .true. - ENDIF - -! If one or more "open_for_write_commit" commands were encountered from the -! latest call to retrieve_pieces_of_field() then call the package-specific -! routine to do the commit. - IF (okay_to_commit(DataHandle)) THEN - - SELECT CASE (use_package(io_form(DataHandle))) -#ifdef PNETCDF_QUILT - CASE ( IO_PNETCDF ) - CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_pnc_open_for_write_commit(handle(DataHandle),Status) - okay_to_write(DataHandle) = .true. - ENDIF -#endif -#ifdef NETCDF - CASE ( IO_NETCDF ) - CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_ncd_open_for_write_commit(handle(DataHandle),Status) - okay_to_write(DataHandle) = .true. - ENDIF -#endif -#ifdef INTIO - CASE ( IO_INTIO ) - CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_int_open_for_write_commit(handle(DataHandle),Status) - okay_to_write(DataHandle) = .true. - ENDIF -#endif -#ifdef YYY - CASE ( IO_YYY ) - CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_yyy_open_for_write_commit(handle(DataHandle),Status) - okay_to_write(DataHandle) = .true. - ENDIF -#endif -#ifdef GRIB1 - CASE ( IO_GRIB1 ) - CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_gr1_open_for_write_commit(handle(DataHandle),Status) - okay_to_write(DataHandle) = .true. - ENDIF -#endif -#ifdef GRIB2 - CASE ( IO_GRIB2 ) - CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) - IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN - CALL ext_gr2_open_for_write_commit(handle(DataHandle),Status) - okay_to_write(DataHandle) = .true. - ENDIF -#endif - - CASE DEFAULT - Status = 0 - END SELECT - - okay_to_commit(DataHandle) = .false. - ENDIF -!!endif - -! Retrieve header and all patches for the next field from the internal -! buffers. - CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) - END DO !} - - DEALLOCATE( obuf ) - - ! flush output files if needed - IF (written_record) THEN -!CALL start_timing - SELECT CASE ( use_package(io_form) ) -#ifdef PNETCDF_QUILT - CASE ( IO_PNETCDF ) - CALL ext_pnc_iosync( handle(DataHandle), Status ) -#endif - CASE DEFAULT - Status = 0 - END SELECT - written_record = .false. -!CALL end_timing( "quilt_pnc: flush" ) - ENDIF - - END DO ! } - - END SUBROUTINE quilt_pnc - -! end of #endif of DM_PARALLEL -#endif - - SUBROUTINE init_module_wrf_quilt - USE module_wrf_error, only: init_module_wrf_error -! -! Both client (compute) and server tasks call this routine to initialize the -! module. Routine setup_quilt_servers() is called from this routine to -! determine which tasks are compute tasks and which are server tasks. Server -! tasks then call routine quilt() and remain there for the rest of the model -! run. Compute tasks return from init_module_wrf_quilt() to perform model -! computations. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INCLUDE 'mpif.h' - INTEGER i - NAMELIST /namelist_quilt/ nio_tasks_per_group, nio_groups, poll_servers - INTEGER ntasks, mytask, ierr, io_status -# if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT) - INTEGER thread_support_provided, thread_support_requested -#endif - INTEGER mpi_comm_here, temp_poll - LOGICAL mpi_inited - LOGICAL esmf_coupling - -!TODO: Change this to run-time switch -#ifdef ESMFIO - esmf_coupling = .TRUE. -#else - esmf_coupling = .FALSE. -#endif - - quilting_enabled = .FALSE. - IF ( disable_quilt ) RETURN - - DO i = 1,int_num_handles - okay_to_write(i) = .FALSE. - int_handle_in_use(i) = .FALSE. - server_for_handle(i) = 0 - int_num_bytes_to_write(i) = 0 - ENDDO - - CALL MPI_INITIALIZED( mpi_inited, ierr ) - IF ( .NOT. mpi_inited ) THEN -# if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT) - thread_support_requested = MPI_THREAD_FUNNELED - CALL mpi_init_thread ( thread_support_requested, thread_support_provided, ierr ) - IF ( thread_support_provided .lt. thread_support_requested ) THEN - CALL WRF_ERROR_FATAL( "failed to initialize MPI thread support") - ENDIF -# else - CALL mpi_init ( ierr ) -# endif - CALL wrf_set_dm_communicator( MPI_COMM_WORLD ) - CALL wrf_termio_dup - ENDIF - CALL wrf_get_dm_communicator( mpi_comm_here ) - - CALL MPI_Comm_rank ( mpi_comm_here, mytask, ierr ) ; - CALL mpi_x_comm_size( mpi_comm_here, ntasks, ierr ) ; - - IF ( mytask .EQ. 0 ) THEN - OPEN ( unit=27, file="namelist.input", form="formatted", status="old" ) - nio_groups = 1 - nio_tasks_per_group = 0 - poll_servers = .false. - READ ( 27 , NML = namelist_quilt, IOSTAT=io_status ) - IF (io_status .NE. 0) THEN - CALL wrf_error_fatal( "ERROR reading namelist namelist_quilt" ) - ENDIF - CLOSE ( 27 ) - IF ( esmf_coupling ) THEN - IF ( nio_tasks_per_group > 0 ) THEN - CALL wrf_error_fatal("frame/module_io_quilt.F: cannot use "// & - "ESMF coupling with quilt tasks") ; - ENDIF - ENDIF - if(poll_servers) then - temp_poll=1 - else - temp_poll=0 - endif - ENDIF - - CALL mpi_bcast( nio_tasks_per_group , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) - CALL mpi_bcast( nio_groups , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) - CALL mpi_bcast( temp_poll , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) - - poll_servers = (temp_poll == 1) - - CALL setup_quilt_servers( nio_tasks_per_group, & - mytask, & - ntasks, & - nio_groups, & - nio_tasks_in_group, & - mpi_comm_here, & - mpi_comm_local, & - mpi_comm_io_groups) - - call init_module_wrf_error(on_io_server=.true.) - - ! provide the communicator for the integration tasks to RSL - IF ( compute_node ) THEN - CALL wrf_set_dm_communicator( mpi_comm_local ) -#if ( DA_CORE != 1 ) - IF (coupler_on) CALL cpl_set_dm_communicator( mpi_comm_local ) -#endif -#ifdef HWRF - call ATM_SET_COMM(mpi_comm_local) -#endif - ELSE -#ifdef HWRF - call ATM_LEAVE_COUPLING() -#endif -#if ( DA_CORE != 1 ) - IF (coupler_on) CALL cpl_set_dm_communicator( MPI_COMM_NULL ) -#endif - CALL quilt ! will not return on io server tasks - ENDIF -#endif - RETURN - END SUBROUTINE init_module_wrf_quilt - - -#ifdef IBM_REDUCE_BUG_WORKAROUND - - ! These three subroutines re-implement MPI_Reduce on MPI_INTEGER - ! with OP=MPI_ADD. - - ! This is a workaround for a bug in the IBM MPI implementation. - ! Some MPI processes will get stuck in MPI_Reduce and not - ! return until the PREVIOUS I/O server group finishes writing. - - ! This workaround replaces the MPI_Reduce call with many - ! MPI_Send and MPI_Recv calls that perform the sum on the - ! root of the communicator. - - ! There are two reduce routines: one for a sum of scalars - ! and one for a sum of arrays. The get_reduce_tag generates - ! MPI tags for the communication. - - integer function get_reduce_tag(root,comm) - implicit none - include 'mpif.h' - integer, intent(in) :: comm,root - integer :: i,j, tag, here - integer :: ierr,me,size - - integer, pointer :: nexttags(:) - integer, target :: dummy(1) - character(255) :: message - integer(kind=4) :: comm4,hashed - - integer, parameter :: hashsize = 113 ! should be prime, >max_servers+1 - integer, parameter :: tagloop = 100000 ! number of tags reserved per communicator - integer, parameter :: origin = 1031102 ! lowest tag number we'll use - integer, save :: nexttag=origin ! next tag to use for a new communicator - integer, save :: comms(hashsize)=-1, firsttag(hashsize)=0, curtag(hashsize)=0 - - ! If integers are not four bytes, this implementation will still - ! work, but it may be inefficient (O(N) lookup instead of O(1)). - ! To fix that, an eight byte hash function would be needed, but - ! integers are four bytes in WRF, so that is not a problem right - ! now. - - comm4=comm - call int_hash(comm4,hashed) - hashed=mod(abs(hashed),hashsize)+1 - if(hashed<0) call wrf_error_fatal('hashed<0') - - do i=0,hashsize-1 - j=1+mod(i+hashed-1,hashsize) - - if(firsttag(j)/=0 .and. comms(j)==comm) then - ! Found the communicator - if(curtag(j)-firsttag(j) >= tagloop) then - ! Hit the max tag number so we need to reset. - ! To make sure >tagloop reduces don't happen - ! before someone finishes an old reduce, we - ! have an MPI_Barrier here. - !call wrf_message('Hit tagloop limit so calling mpi_barrier in get_reduce_tag...') - call mpi_barrier(comm,ierr) - if(ierr/=0) call wrf_error_fatal('cannot call mpi_barrier') - !call wrf_message(' ...back from mpi_barrier in get_reduce_tag.') - - curtag(j)=firsttag(j) - endif - - tag=curtag(j) - curtag(j)=tag+1 - get_reduce_tag=tag - return - endif - enddo - - - ! ==================== HANDLE NEW COMMUNICATORS ==================== - - !write(message,'("Found a new communicator ",I0," in get_reduce_tag, so making a tag range for it")') comm - - ! If we get here, the communicator is new to us, so we need - ! to add it to the hash and give it a new tag. - - ! First, figure out where we'll put the tag in the hashtable - here=-1 - do i=0,hashsize-1 - j=1+mod(i+hashed-1,hashsize) - - if(firsttag(j)==0) then - here=j - exit - endif - enddo - if(here==-1) call wrf_error_fatal('no room in hashtable; increase hashsize in get_reduce_tag (should be >max_servers+1)') - - ! Now, find out the new tag's number. To do this, we need to - ! get the next tag number that is not used by any ranks. - - call mpi_comm_rank(comm,me,ierr) - if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank') - - call mpi_comm_size(comm,size,ierr) - if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size') - - if(me==root) then - allocate(nexttags(size)) - else - nexttags=>dummy - endif - - call mpi_gather(nexttag,1,MPI_INTEGER,nexttags,1,MPI_INTEGER,root,comm,ierr) - if(ierr/=0) call wrf_error_fatal('cannot call mpi_gather') - - if(me==root) then - nexttag=max(nexttag,maxval(nexttags)) - deallocate(nexttags) - endif - call mpi_bcast(nexttag,1,MPI_INTEGER,root,comm,ierr) - - comms(here)=comm - firsttag(here)=nexttag - curtag(here)=nexttag - get_reduce_tag=nexttag - - !write(message,'("Stored comm ",I0," with tag ",I0,"=",I0," in hash element ",I0)') & - ! comms(here),firsttag(here),curtag(here),here - !call wrf_message(message) - - nexttag=nexttag+tagloop - - end function get_reduce_tag - subroutine reduce_add_int_scl(send,recv,count,root,comm) - implicit none - include 'mpif.h' - integer, intent(in) :: count,root,comm - integer, intent(inout) :: recv - integer, intent(in) :: send - integer :: me, size, ierr, you, temp, tag - character*255 :: message - if(root<0) call wrf_error_fatal('root is less than 0') - - tag=get_reduce_tag(root,comm) - - !write(message,'("Send/recv to tag ",I0)') tag - !call wrf_message(message) - - call mpi_comm_rank(comm,me,ierr) - if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank') - - call mpi_comm_size(comm,size,ierr) - if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size') - - if(root>=size) call wrf_error_fatal('root is beyond highest communicator rank') - - if(me==root) then - recv=send - do you=0,size-2 - call mpi_recv(temp,1,MPI_INTEGER,MPI_ANY_SOURCE,tag,comm,MPI_STATUS_IGNORE,ierr) - if(ierr/=0) call wrf_error_fatal('error calling mpi_recv') - recv=recv+temp - enddo - else - call mpi_send(send,1,MPI_INTEGER,root,tag,comm,ierr) - if(ierr/=0) call wrf_error_fatal('error calling mpi_send') - endif - end subroutine reduce_add_int_scl - subroutine reduce_add_int_arr(sendbuf,recvbuf,count,root,comm) - implicit none - include 'mpif.h' - integer, intent(in) :: count,root,comm - integer, intent(in) :: sendbuf(count) - integer, intent(inout) :: recvbuf(count) - integer :: me, size, ierr, you, tempbuf(count), tag - character*255 :: message - - if(root<0) call wrf_error_fatal('root is less than 0') - - tag=get_reduce_tag(root,comm) - - !write(message,'("Send/recv to tag ",I0)') tag - !call wrf_message(message) - - call mpi_comm_rank(comm,me,ierr) - if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank') - - call mpi_comm_size(comm,size,ierr) - if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size') - - if(root>=size) call wrf_error_fatal('root is beyond highest communicator rank') - - if(me==root) then - recvbuf=sendbuf - do you=0,size-2 - call mpi_recv(tempbuf,count,MPI_INTEGER,MPI_ANY_SOURCE,tag,comm,MPI_STATUS_IGNORE,ierr) - if(ierr/=0) call wrf_error_fatal('error calling mpi_recv') - recvbuf=recvbuf+tempbuf - enddo - else - call mpi_send(sendbuf,count,MPI_INTEGER,root,tag,comm,ierr) - if(ierr/=0) call wrf_error_fatal('error calling mpi_send') - endif - end subroutine reduce_add_int_arr -#endif - - -END MODULE module_wrf_quilt - -! -! Remaining routines in this file are defined outside of the module -! either to defeat arg/param type checking or to avoid an explicit use -! dependence. -! - -SUBROUTINE disable_quilting -! -! Call this in programs that you never want to be quilting (e.g. real) -! Must call before call to init_module_wrf_quilt(). -! - USE module_wrf_quilt - disable_quilt = .TRUE. - RETURN -END SUBROUTINE disable_quilting - -LOGICAL FUNCTION use_output_servers_for(ioform) -! -! Returns .TRUE. if I/O quilt servers are in-use for write operations -! AND the output servers can handle the given I/O form. If the I/O -! form is 0, then the io form is not considered and the result is the -! same as calling use_output_servers. -! This routine is called only by client (compute) tasks. -! - USE module_wrf_quilt - integer, intent(in) :: ioform - use_output_servers_for = quilting_enabled - use_output_servers_for = ( use_output_servers_for .and. ioform<100 ) - RETURN -END FUNCTION use_output_servers_for - -LOGICAL FUNCTION use_output_servers() -! -! Returns .TRUE. if I/O quilt servers are in-use for write operations. -! This routine is called only by client (compute) tasks. -! - USE module_wrf_quilt - use_output_servers = quilting_enabled - RETURN -END FUNCTION use_output_servers - -LOGICAL FUNCTION use_input_servers() -! -! Returns .TRUE. if I/O quilt servers are in-use for read operations. -! This routine is called only by client (compute) tasks. -! - USE module_wrf_quilt - use_input_servers = .FALSE. - RETURN -END FUNCTION use_input_servers - -SUBROUTINE wrf_quilt_open_for_write_begin( FileName , Comm_compute, Comm_io, SysDepInfo, & - DataHandle , io_form_arg, Status ) -! -! Instruct the I/O quilt servers to begin data definition ("training") phase -! for writing to WRF dataset FileName. io_form_arg indicates file format. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_wrf_quilt - USE module_state_description, ONLY: IO_PNETCDF - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "intio_tags.h" - CHARACTER *(*), INTENT(IN) :: FileName - INTEGER , INTENT(IN) :: Comm_compute , Comm_io - CHARACTER *(*), INTENT(IN) :: SysDepInfo - INTEGER , INTENT(OUT) :: DataHandle - INTEGER , INTENT(IN) :: io_form_arg - INTEGER , INTENT(OUT) :: Status -! Local - CHARACTER*132 :: locFileName, locSysDepInfo - INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group - REAL dummy - INTEGER, EXTERNAL :: use_package - - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_begin' ) - CALL int_get_fresh_handle(i) - okay_to_write(i) = .false. - DataHandle = i - - locFileName = FileName - locSysDepInfo = SysDepInfo - - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - - SELECT CASE(use_package(io_form_arg)) - -#ifdef PNETCDF_QUILT - CASE(IO_PNETCDF) - IF(compute_group_master(1)) THEN - CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, & - locFileName,locSysDepInfo,io_form_arg,& - DataHandle ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - END IF -#endif - CASE DEFAULT - - IF ( wrf_dm_on_monitor() ) THEN - CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, & - locFileName,locSysDepInfo,io_form_arg,DataHandle ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF - - END SELECT - - iserver = get_server_id ( DataHandle ) -!JMDEBUGwrite(0,*)'wrf_quilt_open_for_write_begin iserver = ', iserver - CALL get_mpi_comm_io_groups( comm_io_group , iserver ) -!JMDEBUGwrite(0,*)'wrf_quilt_open_for_write_begin comm_io_group = ', comm_io_group - - CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) -!JMDEBUGwrite(0,*)'mpi_x_comm_size tasks_in_group ',tasks_in_group, ierr - -!!JMTIMING CALL start_timing - ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) - reduced = 0 - reduced(1) = hdrbufsize -#ifdef PNETCDF_QUILT - IF ( compute_group_master(1) ) reduced(2) = i -#else - IF ( wrf_dm_on_monitor() ) reduced(2) = i -#endif - CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) -!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_begin") - - ! send data to the i/o processor - CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & - onebyte, & - hdrbuf, hdrbufsize , & - dummy, 0 ) - - Status = 0 - - -#endif - RETURN -END SUBROUTINE wrf_quilt_open_for_write_begin - -SUBROUTINE wrf_quilt_open_for_write_commit( DataHandle , Status ) -! -! Instruct the I/O quilt servers to switch an internal flag to enable output -! for the dataset referenced by DataHandle. The call to -! wrf_quilt_open_for_write_commit() must be paired with a call to -! wrf_quilt_open_for_write_begin(). -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_wrf_quilt - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "intio_tags.h" - INTEGER , INTENT(IN ) :: DataHandle - INTEGER , INTENT(OUT) :: Status - INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group - REAL dummy - - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_commit' ) - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN - IF ( int_handle_in_use( DataHandle ) ) THEN - okay_to_write( DataHandle ) = .true. - ENDIF - ENDIF - - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - -#ifdef PNETCDF_QUILT -!ARP Only want one command to be received by each IO server when using -!ARP parallel IO - IF(compute_group_master(1)) THEN - CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle, int_open_for_write_commit ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - END IF -#else - - IF ( wrf_dm_on_monitor() ) THEN - CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle, int_open_for_write_commit ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#endif - - iserver = get_server_id ( DataHandle ) - CALL get_mpi_comm_io_groups( comm_io_group , iserver ) - - CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) - -!!JMTIMING CALL start_timing - ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) - reduced = 0 - reduced(1) = hdrbufsize -#ifdef PNETCDF_QUILT - IF ( compute_group_master(1) ) reduced(2) = DataHandle -#else - IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle -#endif - CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) -!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_commit") - - ! send data to the i/o processor - CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & - onebyte, & - hdrbuf, hdrbufsize , & - dummy, 0 ) - - Status = 0 - -#endif - RETURN -END SUBROUTINE wrf_quilt_open_for_write_commit - -SUBROUTINE wrf_quilt_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & - DataHandle , Status ) -! -! Instruct the I/O quilt servers to open WRF dataset FileName for reading. -! This routine is called only by client (compute) tasks. -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - CHARACTER *(*), INTENT(IN) :: FileName - INTEGER , INTENT(IN) :: Comm_compute , Comm_io - CHARACTER *(*), INTENT(IN) :: SysDepInfo - INTEGER , INTENT(OUT) :: DataHandle - INTEGER , INTENT(OUT) :: Status - - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_read' ) - DataHandle = -1 - Status = -1 - CALL wrf_error_fatal ( "frame/module_io_quilt.F: wrf_quilt_open_for_read not yet supported" ) -#endif - RETURN -END SUBROUTINE wrf_quilt_open_for_read - -SUBROUTINE wrf_quilt_inquire_opened ( DataHandle, FileName , FileStatus, Status ) -! -! Inquire if the dataset referenced by DataHandle is open. -! Does not require communication with I/O servers. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_wrf_quilt - IMPLICIT NONE -#include "wrf_io_flags.h" - INTEGER , INTENT(IN) :: DataHandle - CHARACTER *(*), INTENT(IN) :: FileName - INTEGER , INTENT(OUT) :: FileStatus - INTEGER , INTENT(OUT) :: Status - - Status = 0 - - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_opened' ) - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN - IF ( int_handle_in_use( DataHandle ) ) THEN - IF ( okay_to_write( DataHandle ) ) THEN - FileStatus = WRF_FILE_OPENED_FOR_WRITE - ENDIF - ENDIF - ENDIF - Status = 0 - -#endif - RETURN -END SUBROUTINE wrf_quilt_inquire_opened - -SUBROUTINE wrf_quilt_inquire_filename ( DataHandle, FileName , FileStatus, Status ) -! -! Return the Filename and FileStatus associated with DataHandle. -! Does not require communication with I/O servers. -! -! Note that the current implementation does not actually return FileName. -! Currenlty, WRF does not use this returned value. Fixing this would simply -! require saving the file names on the client tasks in an array similar to -! okay_to_write(). -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_wrf_quilt - IMPLICIT NONE -#include "wrf_io_flags.h" - INTEGER , INTENT(IN) :: DataHandle - CHARACTER *(*), INTENT(OUT) :: FileName - INTEGER , INTENT(OUT) :: FileStatus - INTEGER , INTENT(OUT) :: Status - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_filename' ) - Status = 0 - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN - IF ( int_handle_in_use( DataHandle ) ) THEN - IF ( okay_to_write( DataHandle ) ) THEN - FileStatus = WRF_FILE_OPENED_FOR_WRITE - ELSE - FileStatus = WRF_FILE_OPENED_NOT_COMMITTED - ENDIF - ELSE - FileStatus = WRF_FILE_NOT_OPENED - ENDIF - Status = 0 - FileName = "bogusfornow" - ELSE - Status = -1 - ENDIF -#endif - RETURN -END SUBROUTINE wrf_quilt_inquire_filename - -SUBROUTINE wrf_quilt_iosync ( DataHandle, Status ) -! -! Instruct the I/O quilt servers to synchronize the disk copy of a dataset -! with memory buffers. -! -! After the "iosync" header (request) is sent to the I/O quilt server, -! the compute tasks will then send the entire contents (headers and data) of -! int_local_output_buffer to their I/O quilt server. This communication is -! done in subroutine send_to_io_quilt_servers(). After the I/O quilt servers -! receive this data, they will write all accumulated fields to disk. -! -! Significant time may be required for the I/O quilt servers to organize -! fields and write them to disk. Therefore, the "iosync" request should be -! sent only when the compute tasks are ready to run for a while without -! needing to communicate with the servers. Otherwise, the compute tasks -! will end up waiting for the servers to finish writing to disk, thus wasting -! any performance benefits of having servers at all. -! -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && ! defined (STUBMPI) - USE module_wrf_quilt - IMPLICIT NONE - include "mpif.h" - INTEGER , INTENT(IN) :: DataHandle - INTEGER , INTENT(OUT) :: Status - - INTEGER locsize , itypesize - INTEGER ierr, tasks_in_group, comm_io_group, dummy, i - - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_iosync' ) - -! CALL start_timing - IF ( associated ( int_local_output_buffer ) ) THEN - - iserver = get_server_id ( DataHandle ) - CALL get_mpi_comm_io_groups( comm_io_group , iserver ) - - CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) - - locsize = int_num_bytes_to_write(DataHandle) - -! CALL start_timing - ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) - reduced = 0 - reduced(1) = locsize -#ifdef PNETCDF_QUILT -! ARP Only want one command per IOServer if doing parallel IO - IF ( compute_group_master(1) ) reduced(2) = DataHandle -#else - IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle -#endif - CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) -! CALL end_timing("MPI_Reduce in wrf_quilt_iosync") - - ! send data to the i/o processor -#ifdef DEREF_KLUDGE - CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & - onebyte, & - int_local_output_buffer(1), locsize , & - dummy, 0 ) -#else - CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & - onebyte, & - int_local_output_buffer, locsize , & - dummy, 0 ) -#endif - - - int_local_output_cursor = 1 -! int_num_bytes_to_write(DataHandle) = 0 - DEALLOCATE ( int_local_output_buffer ) - NULLIFY ( int_local_output_buffer ) - ELSE - CALL wrf_message ("frame/module_io_quilt.F: wrf_quilt_iosync: no buffer allocated") - ENDIF -! CALL end_timing("wrf_quilt_iosync") - Status = 0 -#endif - RETURN -END SUBROUTINE wrf_quilt_iosync - -SUBROUTINE wrf_quilt_ioclose ( DataHandle, Status ) -! -! Instruct the I/O quilt servers to close the dataset referenced by -! DataHandle. -! This routine also clears the client file handle and, if needed, deallocates -! int_local_output_buffer. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && ! defined( STUBMPI) - USE module_wrf_quilt - USE module_timing - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "intio_tags.h" - INTEGER , INTENT(IN) :: DataHandle - INTEGER , INTENT(OUT) :: Status - INTEGER i, itypesize, tasks_in_group, comm_io_group, ierr - REAL dummy - -!!JMTIMING CALL start_timing - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioclose' ) - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - -! If we're using pnetcdf then each IO server will need to receive the -! handle just once as there is -! no longer a reduce over the IO servers to get it. -#ifdef PNETCDF_QUILT - IF ( compute_group_master(1) )THEN - CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle, int_ioclose ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#else - IF ( wrf_dm_on_monitor() ) THEN - CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle , int_ioclose ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#endif - - iserver = get_server_id ( DataHandle ) - CALL get_mpi_comm_io_groups( comm_io_group , iserver ) - - CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) - -!!JMTIMING CALL start_timing - ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) - reduced = 0 -#ifdef PNETCDF_QUILT -! If we're using pnetcdf then each IO server will need the handle as there is -! no longer a reduce over the IO servers to get it. - IF ( compute_group_master(1) ) reduced(2) = DataHandle -#else - IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle -#endif - CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) -!!JMTIMING CALL end_timing("MPI_Reduce in ioclose") - -#if 0 - ! send data to the i/o processor -!!JMTIMING CALL start_timing - CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & - onebyte, & - hdrbuf, hdrbufsize , & - dummy, 0 ) -!!JMTIMING CALL end_timing("collect_on_comm in io_close") -#endif - - int_handle_in_use(DataHandle) = .false. - CALL set_server_id( DataHandle, 0 ) - okay_to_write(DataHandle) = .false. - okay_to_commit(DataHandle) = .false. - int_local_output_cursor = 1 - int_num_bytes_to_write(DataHandle) = 0 - IF ( associated ( int_local_output_buffer ) ) THEN - DEALLOCATE ( int_local_output_buffer ) - NULLIFY ( int_local_output_buffer ) - ENDIF - - Status = 0 -!!JMTIMING CALL end_timing( "wrf_quilt_ioclose" ) - -#endif - RETURN -END SUBROUTINE wrf_quilt_ioclose - -SUBROUTINE wrf_quilt_ioexit( Status ) -! -! Instruct the I/O quilt servers to shut down the WRF I/O system. -! Do not call any wrf_quilt_*() routines after this routine has been called. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && ! defined (STUBMPI ) - USE module_wrf_quilt - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "intio_tags.h" - INTEGER , INTENT(OUT) :: Status - INTEGER :: DataHandle, actual_iserver - INTEGER i, itypesize, tasks_in_group, comm_io_group, me, ierr - REAL dummy - - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioexit' ) - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - -!ARPDBG - potential bug. Have no access to what type of IO is being used for -! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. -#ifdef PNETCDF_QUILT -!ARP Send the ioexit message just once to each IOServer when using parallel IO - IF( compute_group_master(1) ) THEN - CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle, int_ioexit ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - END IF -#else - - IF ( wrf_dm_on_monitor() ) THEN - CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & - DataHandle , int_ioexit ) ! Handle is dummy - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#endif - - DO iserver = 1, nio_groups - if(poll_servers) then - ! We're using server polling mode, so we must call - ! *_find_server to receive the mpi_ssend sent by the servers, - ! otherwise WRF will hang at the mpi_x_reduce below. - - call wrf_quilt_find_server(actual_iserver) - - ! The actual_iserver is now set to the next available I/O server. - ! That may not be the same as iserver, but that's okay as long - ! as we run through this loop exactly nio_groups times. - else - ! Not using server polling, so just access servers in numeric order. - actual_iserver=iserver - endif - - CALL get_mpi_comm_io_groups( comm_io_group , actual_iserver ) - - CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) - CALL mpi_comm_rank( comm_io_group , me , ierr ) - -! BY SENDING A NEGATIVE SIZE WE GET THE SERVERS TO SHUT DOWN - hdrbufsize = -100 - reduced = 0 - IF ( me .eq. 0 ) reduced(1) = hdrbufsize - CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) - - ENDDO - Status = 0 - -#endif - RETURN -END SUBROUTINE wrf_quilt_ioexit - -SUBROUTINE wrf_quilt_get_next_time ( DataHandle, DateStr, Status ) -! -! Instruct the I/O quilt servers to return the next time stamp. -! This is not yet supported. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && ! defined (STUBMPI) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) :: DateStr - INTEGER :: Status -#endif - RETURN -END SUBROUTINE wrf_quilt_get_next_time - -SUBROUTINE wrf_quilt_get_previous_time ( DataHandle, DateStr, Status ) -! -! Instruct the I/O quilt servers to return the previous time stamp. -! This is not yet supported. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && ! defined (STUBMPI) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) :: DateStr - INTEGER :: Status -#endif - RETURN -END SUBROUTINE wrf_quilt_get_previous_time - -SUBROUTINE wrf_quilt_set_time ( DataHandle, Data, Status ) -! -! Instruct the I/O quilt servers to set the time stamp in the dataset -! referenced by DataHandle. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_wrf_quilt - USE module_state_description, ONLY: IO_PNETCDF - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "intio_tags.h" - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Data - INTEGER :: Status - INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group - REAL dummy - INTEGER :: Count - INTEGER, EXTERNAL :: use_package -! - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_set_time' ) - - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN - IF ( int_handle_in_use( DataHandle ) ) THEN - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - Count = 0 ! there is no count for character strings - -!ARPDBG - potential bug. Have no access to what type of IO is being used for -! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. -#ifdef PNETCDF_QUILT - IF(compute_group_master(1) )THEN -! Only want to send one time header to each IO server as -! can't tell that's what they are on the IO servers themselves - therefore use -! the compute_group_master process. - CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, "TIMESTAMP", "", Data, int_set_time ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - END IF -#else - IF ( wrf_dm_on_monitor() ) THEN - CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, "TIMESTAMP", "", Data, int_set_time ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#endif - - iserver = get_server_id ( DataHandle ) - CALL get_mpi_comm_io_groups( comm_io_group , iserver ) - CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) - - ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) - reduced = 0 - reduced(1) = hdrbufsize -#ifdef PNETCDF_QUILT - IF ( compute_group_master(1) ) reduced(2) = DataHandle -#else - IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle -#endif - CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) - ! send data to the i/o processor - CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & - onebyte, & - hdrbuf, hdrbufsize , & - dummy, 0 ) - ENDIF - ENDIF - -#endif -RETURN -END SUBROUTINE wrf_quilt_set_time - -SUBROUTINE wrf_quilt_get_next_var ( DataHandle, VarName, Status ) -! -! When reading, instruct the I/O quilt servers to return the name of the next -! variable in the current time frame. -! This is not yet supported. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) :: VarName - INTEGER :: Status -#endif - RETURN -END SUBROUTINE wrf_quilt_get_next_var - -SUBROUTINE wrf_quilt_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! independent domain metadata named "Element" -! from the open dataset described by DataHandle. -! Metadata of type real are -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. - -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - REAL, INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Outcount - INTEGER :: Status - CALL wrf_message('wrf_quilt_get_dom_ti_real not supported yet') -#endif -RETURN -END SUBROUTINE wrf_quilt_get_dom_ti_real - -SUBROUTINE wrf_quilt_put_dom_ti_real ( DataHandle,Element, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time independent -! domain metadata named "Element" -! to the open dataset described by DataHandle. -! Metadata of type real are -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_wrf_quilt - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "intio_tags.h" - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - REAL , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -!Local - CHARACTER*132 :: locElement - INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group - REAL dummy -! -!!JMTIMING CALL start_timing - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_real' ) - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - locElement = Element - - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN - IF ( int_handle_in_use( DataHandle ) ) THEN - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - CALL MPI_TYPE_SIZE( MPI_REAL, typesize, ierr ) - -#ifdef PNETCDF_QUILT - IF ( compute_group_master(1) ) THEN - CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & - DataHandle, locElement, Data, Count, int_dom_ti_real ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#else - IF ( wrf_dm_on_monitor() ) THEN - CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & - DataHandle, locElement, Data, Count, int_dom_ti_real ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#endif - - iserver = get_server_id ( DataHandle ) - CALL get_mpi_comm_io_groups( comm_io_group , iserver ) - CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) - -!!JMTIMING CALL start_timing - ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) - reduced = 0 - reduced(1) = hdrbufsize -#ifdef PNETCDF_QUILT - IF( compute_group_master(1) ) reduced(2) = DataHandle -#else - IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle -#endif - CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) -!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_real") - ! send data to the i/o processor - CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & - onebyte, & - hdrbuf, hdrbufsize , & - dummy, 0 ) - ENDIF - ENDIF - - Status = 0 -!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_real") -#endif -RETURN -END SUBROUTINE wrf_quilt_put_dom_ti_real - -SUBROUTINE wrf_quilt_get_dom_ti_double ( DataHandle,Element, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! independent domain metadata named "Element" -! from the open dataset described by DataHandle. -! Metadata of type double are -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - real*8 :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status - CALL wrf_error_fatal('wrf_quilt_get_dom_ti_double not supported yet') -#endif -RETURN -END SUBROUTINE wrf_quilt_get_dom_ti_double - -SUBROUTINE wrf_quilt_put_dom_ti_double ( DataHandle,Element, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time independent -! domain metadata named "Element" -! to the open dataset described by DataHandle. -! Metadata of type double are -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - REAL*8 , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status - CALL wrf_error_fatal('wrf_quilt_put_dom_ti_double not supported yet') -#endif -RETURN -END SUBROUTINE wrf_quilt_put_dom_ti_double - -SUBROUTINE wrf_quilt_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! independent domain metadata named "Element" -! from the open dataset described by DataHandle. -! Metadata of type integer are -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - integer :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status - CALL wrf_message('wrf_quilt_get_dom_ti_integer not supported yet') -#endif -RETURN -END SUBROUTINE wrf_quilt_get_dom_ti_integer - -SUBROUTINE wrf_quilt_put_dom_ti_integer ( DataHandle,Element, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time independent -! domain metadata named "Element" -! to the open dataset described by DataHandle. -! Metadata of type integer are -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_wrf_quilt - USE module_state_description, ONLY: IO_PNETCDF - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "intio_tags.h" - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - INTEGER , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -! Local - CHARACTER*132 :: locElement - INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group - REAL dummy - INTEGER, EXTERNAL :: use_package -! - -!!JMTIMING CALL start_timing - locElement = Element - - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_integer' ) - - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN - IF ( int_handle_in_use( DataHandle ) ) THEN - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - CALL MPI_TYPE_SIZE( MPI_INTEGER, typesize, ierr ) - -!ARPDBG - potential bug. Have no access to what type of IO is being used for -! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. -#ifdef PNETCDF_QUILT - IF ( compute_group_master(1) )THEN - CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & - DataHandle, locElement, Data, Count, & - int_dom_ti_integer ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#else - IF ( wrf_dm_on_monitor() ) THEN - CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & - DataHandle, locElement, Data, Count, & - int_dom_ti_integer ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#endif - - iserver = get_server_id ( DataHandle ) - CALL get_mpi_comm_io_groups( comm_io_group , iserver ) - CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) - -!!JMTIMING CALL start_timing - ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) - reduced = 0 - reduced(1) = hdrbufsize -#ifdef PNETCDF_QUILT - IF ( compute_group_master(1) ) reduced(2) = DataHandle -#else - IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle -#endif - CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) - -!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_integer") - ! send data to the i/o processor - CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & - onebyte, & - hdrbuf, hdrbufsize , & - dummy, 0 ) - ENDIF - ENDIF - CALL wrf_debug ( DEBUG_LVL, 'returning from wrf_quilt_put_dom_ti_integer' ) -!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_integer" ) - -#endif -RETURN -END SUBROUTINE wrf_quilt_put_dom_ti_integer - -SUBROUTINE wrf_quilt_get_dom_ti_logical ( DataHandle,Element, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! independent domain metadata named "Element" -! from the open dataset described by DataHandle. -! Metadata of type logical are -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - logical :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -! CALL wrf_message('wrf_quilt_get_dom_ti_logical not supported yet') -#endif -RETURN -END SUBROUTINE wrf_quilt_get_dom_ti_logical - -SUBROUTINE wrf_quilt_put_dom_ti_logical ( DataHandle,Element, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time independent -! domain metadata named "Element" -! to the open dataset described by DataHandle. -! Metadata of type logical are -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - logical , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -! Local - INTEGER i - INTEGER one_or_zero(Count) - - DO i = 1, Count - IF ( Data(i) ) THEN - one_or_zero(i) = 1 - ELSE - one_or_zero(i) = 0 - ENDIF - ENDDO - - CALL wrf_quilt_put_dom_ti_integer ( DataHandle,Element, one_or_zero, Count, Status ) -#endif -RETURN -END SUBROUTINE wrf_quilt_put_dom_ti_logical - -SUBROUTINE wrf_quilt_get_dom_ti_char ( DataHandle,Element, Data, Status ) -! -! Instruct the I/O quilt servers to attempt to read time independent -! domain metadata named "Element" -! from the open dataset described by DataHandle. -! Metadata of type char are -! stored in string Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) :: Data - INTEGER :: Status - CALL wrf_message('wrf_quilt_get_dom_ti_char not supported yet') -#endif -RETURN -END SUBROUTINE wrf_quilt_get_dom_ti_char - -SUBROUTINE wrf_quilt_put_dom_ti_char ( DataHandle, Element, Data, Status ) -! -! Instruct the I/O quilt servers to write time independent -! domain metadata named "Element" -! to the open dataset described by DataHandle. -! Metadata of type char are -! copied from string Data. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_wrf_quilt - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "intio_tags.h" - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: Data - INTEGER :: Status - INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group, me - REAL dummy -! -!!JMTIMING CALL start_timing - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_char' ) - - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN - IF ( int_handle_in_use( DataHandle ) ) THEN - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - -!ARPDBG - potential bug. Have no access to what type of IO is being used for -! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. -#ifdef PNETCDF_QUILT - IF(compute_group_master(1))THEN - CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, Element, "", Data, & - int_dom_ti_char ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - END IF -#else - IF ( wrf_dm_on_monitor() ) THEN - CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, Element, "", Data, int_dom_ti_char ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#endif - - iserver = get_server_id ( DataHandle ) -! write(0,*)'wrf_quilt_put_dom_ti_char ',iserver - CALL get_mpi_comm_io_groups( comm_io_group , iserver ) - CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) - ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here) -!!JMTIMING! CALL start_timing -!write(0,*)'calling MPI_Barrier' -! CALL MPI_Barrier( mpi_comm_local, ierr ) -!write(0,*)'back from MPI_Barrier' -!!JMTIMING! CALL end_timing("MPI_Barrier in wrf_quilt_put_dom_ti_char") - -!!JMTIMING CALL start_timing - ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) - reduced_dummy = 0 - reduced = 0 - reduced(1) = hdrbufsize -#ifdef PNETCDF_QUILT - IF(compute_group_master(1)) reduced(2) = DataHandle -#else - IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle -#endif -!call mpi_comm_rank( comm_io_group , me, ierr ) - - CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) - -!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_char") - ! send data to the i/o processor -!!JMTIMING CALL start_timing - - CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & - onebyte, & - hdrbuf, hdrbufsize , & - dummy, 0 ) -!!JMTIMING CALL end_timing("collect_on_comm in wrf_quilt_put_dom_ti_char") - ENDIF - ENDIF -!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char") - -#endif -RETURN -END SUBROUTINE wrf_quilt_put_dom_ti_char - -SUBROUTINE wrf_quilt_get_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! dependent domain metadata named "Element" valid at time DateStr -! from the open dataset described by DataHandle. -! Metadata of type real are -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - real :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_dom_td_real - -SUBROUTINE wrf_quilt_put_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time dependent -! domain metadata named "Element" valid at time DateStr -! to the open dataset described by DataHandle. -! Metadata of type real are -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - real , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_put_dom_td_real - -SUBROUTINE wrf_quilt_get_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! dependent domain metadata named "Element" valid at time DateStr -! from the open dataset described by DataHandle. -! Metadata of type double are -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - real*8 :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif - CALL wrf_error_fatal('wrf_quilt_get_dom_td_double not supported yet') -RETURN -END SUBROUTINE wrf_quilt_get_dom_td_double - -SUBROUTINE wrf_quilt_put_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time dependent -! domain metadata named "Element" valid at time DateStr -! to the open dataset described by DataHandle. -! Metadata of type double are -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - real*8 , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif - CALL wrf_error_fatal('wrf_quilt_put_dom_td_double not supported yet') -RETURN -END SUBROUTINE wrf_quilt_put_dom_td_double - -SUBROUTINE wrf_quilt_get_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! dependent domain metadata named "Element" valid at time DateStr -! from the open dataset described by DataHandle. -! Metadata of type integer are -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - integer :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_dom_td_integer - -SUBROUTINE wrf_quilt_put_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time dependent -! domain metadata named "Element" valid at time DateStr -! to the open dataset described by DataHandle. -! Metadata of type integer are -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - integer , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_put_dom_td_integer - -SUBROUTINE wrf_quilt_get_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! dependent domain metadata named "Element" valid at time DateStr -! from the open dataset described by DataHandle. -! Metadata of type logical are -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - logical :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_dom_td_logical - -SUBROUTINE wrf_quilt_put_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time dependent -! domain metadata named "Element" valid at time DateStr -! to the open dataset described by DataHandle. -! Metadata of type logical are -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - logical , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_put_dom_td_logical - -SUBROUTINE wrf_quilt_get_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) -! -! Instruct the I/O quilt servers to attempt to read time dependent -! domain metadata named "Element" valid at time DateStr -! from the open dataset described by DataHandle. -! Metadata of type char are -! stored in string Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) :: Data - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_dom_td_char - -SUBROUTINE wrf_quilt_put_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) -! -! Instruct $he I/O quilt servers to write time dependent -! domain metadata named "Element" valid at time DateStr -! to the open dataset described by DataHandle. -! Metadata of type char are -! copied from string Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: Data - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_put_dom_td_char - -SUBROUTINE wrf_quilt_get_var_ti_real ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! independent attribute "Element" of variable "Varname" -! from the open dataset described by DataHandle. -! Attribute of type real is -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: VarName - real :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_var_ti_real - -SUBROUTINE wrf_quilt_put_var_ti_real ( DataHandle,Element, Varname, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time independent -! attribute "Element" of variable "Varname" -! to the open dataset described by DataHandle. -! Attribute of type real is -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: VarName - real , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_put_var_ti_real - -SUBROUTINE wrf_quilt_get_var_ti_double ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! independent attribute "Element" of variable "Varname" -! from the open dataset described by DataHandle. -! Attribute of type double is -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: VarName - real*8 :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif - CALL wrf_error_fatal('wrf_quilt_get_var_ti_double not supported yet') -RETURN -END SUBROUTINE wrf_quilt_get_var_ti_double - -SUBROUTINE wrf_quilt_put_var_ti_double ( DataHandle,Element, Varname, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time independent -! attribute "Element" of variable "Varname" -! to the open dataset described by DataHandle. -! Attribute of type double is -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: VarName - real*8 , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif - CALL wrf_error_fatal('wrf_quilt_put_var_ti_double not supported yet') -RETURN -END SUBROUTINE wrf_quilt_put_var_ti_double - -SUBROUTINE wrf_quilt_get_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! independent attribute "Element" of variable "Varname" -! from the open dataset described by DataHandle. -! Attribute of type integer is -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: VarName - integer :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_var_ti_integer - -SUBROUTINE wrf_quilt_put_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time independent -! attribute "Element" of variable "Varname" -! to the open dataset described by DataHandle. -! Attribute of type integer is -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: VarName - integer , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_put_var_ti_integer - -SUBROUTINE wrf_quilt_get_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! independent attribute "Element" of variable "Varname" -! from the open dataset described by DataHandle. -! Attribute of type logical is -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: VarName - logical :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_var_ti_logical - -SUBROUTINE wrf_quilt_put_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time independent -! attribute "Element" of variable "Varname" -! to the open dataset described by DataHandle. -! Attribute of type logical is -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: VarName - logical , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_put_var_ti_logical - -SUBROUTINE wrf_quilt_get_var_ti_char ( DataHandle,Element, Varname, Data, Status ) -! -! Instruct the I/O quilt servers to attempt to read time independent -! attribute "Element" of variable "Varname" -! from the open dataset described by DataHandle. -! Attribute of type char is -! stored in string Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: VarName - CHARACTER*(*) :: Data - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_var_ti_char - -SUBROUTINE wrf_quilt_put_var_ti_char ( DataHandle,Element, Varname, Data, Status ) -! -! Instruct the I/O quilt servers to write time independent -! attribute "Element" of variable "Varname" -! to the open dataset described by DataHandle. -! Attribute of type char is -! copied from string Data. -! This routine is called only by client (compute) tasks. -! - -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_wrf_quilt - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "intio_tags.h" - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: VarName - CHARACTER*(*) , INTENT(IN) :: Data - INTEGER :: Status - INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group - REAL dummy -! - -!!JMTIMING CALL start_timing - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_var_ti_char' ) - - IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN - IF ( int_handle_in_use( DataHandle ) ) THEN - CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) - -#ifdef PNETCDF_QUILT - IF ( compute_group_master(1) ) THEN - CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, TRIM(Element), & - TRIM(VarName), TRIM(Data), int_var_ti_char ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#else - IF ( wrf_dm_on_monitor() ) THEN - CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & - DataHandle, TRIM(Element), & - TRIM(VarName), TRIM(Data), int_var_ti_char ) - ELSE - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#endif - - iserver = get_server_id ( DataHandle ) - CALL get_mpi_comm_io_groups( comm_io_group , iserver ) - CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) - -!!JMTIMING CALL start_timing - ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) - reduced = 0 - reduced(1) = hdrbufsize -#ifdef PNETCDF_QUILT - IF ( compute_group_master(1) ) reduced(2) = DataHandle -#else - IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle -#endif - CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) -!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_var_ti_char") - ! send data to the i/o processor - CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & - onebyte, & - hdrbuf, hdrbufsize , & - dummy, 0 ) - ENDIF - ENDIF -!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char" ) - -#endif -RETURN -END SUBROUTINE wrf_quilt_put_var_ti_char - -SUBROUTINE wrf_quilt_get_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! dependent attribute "Element" of variable "Varname" valid at time DateStr -! from the open dataset described by DataHandle. -! Attribute of type real is -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: VarName - real :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_var_td_real - -SUBROUTINE wrf_quilt_put_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time dependent -! attribute "Element" of variable "Varname" valid at time DateStr -! to the open dataset described by DataHandle. -! Attribute of type real is -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: VarName - real , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_put_var_td_real - -SUBROUTINE wrf_quilt_get_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! dependent attribute "Element" of variable "Varname" valid at time DateStr -! from the open dataset described by DataHandle. -! Attribute of type double is -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: VarName - real*8 :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif - CALL wrf_error_fatal('wrf_quilt_get_var_td_double not supported yet') -RETURN -END SUBROUTINE wrf_quilt_get_var_td_double - -SUBROUTINE wrf_quilt_put_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time dependent -! attribute "Element" of variable "Varname" valid at time DateStr -! to the open dataset described by DataHandle. -! Attribute of type double is -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: VarName - real*8 , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif - CALL wrf_error_fatal('wrf_quilt_put_var_td_double not supported yet') -RETURN -END SUBROUTINE wrf_quilt_put_var_td_double - -SUBROUTINE wrf_quilt_get_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount,Status) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! dependent attribute "Element" of variable "Varname" valid at time DateStr -! from the open dataset described by DataHandle. -! Attribute of type integer is -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: VarName - integer :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_var_td_integer - -SUBROUTINE wrf_quilt_put_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time dependent -! attribute "Element" of variable "Varname" valid at time DateStr -! to the open dataset described by DataHandle. -! Attribute of type integer is -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: VarName - integer , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_put_var_td_integer - -SUBROUTINE wrf_quilt_get_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) -! -! Instruct the I/O quilt servers to attempt to read Count words of time -! dependent attribute "Element" of variable "Varname" valid at time DateStr -! from the open dataset described by DataHandle. -! Attribute of type logical is -! stored in array Data. -! Actual number of words read is returned in OutCount. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: VarName - logical :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: OutCount - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_var_td_logical - -SUBROUTINE wrf_quilt_put_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) -! -! Instruct the I/O quilt servers to write Count words of time dependent -! attribute "Element" of variable "Varname" valid at time DateStr -! to the open dataset described by DataHandle. -! Attribute of type logical is -! copied from array Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: VarName - logical , INTENT(IN) :: Data(*) - INTEGER , INTENT(IN) :: Count - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_put_var_td_logical - -SUBROUTINE wrf_quilt_get_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status ) -! -! Instruct the I/O quilt servers to attempt to read time dependent -! attribute "Element" of variable "Varname" valid at time DateStr -! from the open dataset described by DataHandle. -! Attribute of type char is -! stored in string Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: VarName - CHARACTER*(*) :: Data - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_var_td_char - -SUBROUTINE wrf_quilt_put_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status ) -! -! Instruct the I/O quilt servers to write time dependent -! attribute "Element" of variable "Varname" valid at time DateStr -! to the open dataset described by DataHandle. -! Attribute of type char is -! copied from string Data. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: Element - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: VarName - CHARACTER*(*) , INTENT(IN) :: Data - INTEGER :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_put_var_td_char - -SUBROUTINE wrf_quilt_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & - DomainDesc , MemoryOrder , Stagger , DimNames , & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd , & - Status ) -! -! Instruct the I/O quilt servers to read the variable named VarName from the -! dataset pointed to by DataHandle. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(INOUT) :: DateStr - CHARACTER*(*) , INTENT(INOUT) :: VarName - INTEGER , INTENT(INOUT) :: Field(*) - integer ,intent(in) :: FieldType - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(in) :: Stagger - character*(*) , dimension (*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - Status = 0 -#endif -RETURN -END SUBROUTINE wrf_quilt_read_field - -SUBROUTINE wrf_quilt_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & - DomainDesc , MemoryOrder , Stagger , DimNames , & - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd , & - Status ) -! -! Prepare instructions for the I/O quilt servers to write the variable named -! VarName to the dataset pointed to by DataHandle. -! -! During a "training" write this routine accumulates number and sizes of -! messages that will be sent to the I/O server associated with this compute -! (client) task. -! -! During a "real" write, this routine begins by allocating -! int_local_output_buffer if it has not already been allocated. Sizes -! accumulated during "training" are used to determine how big -! int_local_output_buffer must be. This routine then stores "int_field" -! headers and associated field data in int_local_output_buffer. The contents -! of int_local_output_buffer are actually sent to the I/O quilt server in -! routine wrf_quilt_iosync(). This scheme allows output of multiple variables -! to be aggregated into a single "iosync" operation. -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_state_description - USE module_wrf_quilt - IMPLICIT NONE - INCLUDE 'mpif.h' -#include "wrf_io_flags.h" - INTEGER , INTENT(IN) :: DataHandle - CHARACTER*(*) , INTENT(IN) :: DateStr - CHARACTER*(*) , INTENT(IN) :: VarName -! INTEGER , INTENT(IN) :: Field(*) - integer ,intent(in) :: FieldType - integer ,intent(inout) :: Comm - integer ,intent(inout) :: IOComm - integer ,intent(in) :: DomainDesc - character*(*) ,intent(in) :: MemoryOrder - character*(*) ,intent(in) :: Stagger - character*(*) , dimension (*) ,intent(in) :: DimNames - integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd - integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd - integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd - integer ,intent(out) :: Status - - integer ii,jj,kk,myrank - - REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), & - MemoryStart(2):MemoryEnd(2), & - MemoryStart(3):MemoryEnd(3) ) :: Field - INTEGER locsize , typesize, itypesize - INTEGER ierr, tasks_in_group, comm_io_group, dummy, i - INTEGER, EXTERNAL :: use_package - -!!ARPTIMING CALL start_timing - CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_write_field' ) - - IF ( .NOT. (DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles) ) THEN - CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: invalid data handle" ) - ENDIF - IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN - CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: DataHandle not opened" ) - ENDIF - - locsize = (PatchEnd(1)-PatchStart(1)+1)* & - (PatchEnd(2)-PatchStart(2)+1)* & - (PatchEnd(3)-PatchStart(3)+1) - - CALL mpi_type_size( MPI_INTEGER, itypesize, ierr ) - ! Note that the WRF_DOUBLE branch of this IF statement must come first since - ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds. - IF ( FieldType .EQ. WRF_DOUBLE ) THEN - CALL mpi_type_size( MPI_DOUBLE_PRECISION, typesize, ierr ) - ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN - CALL mpi_type_size( MPI_REAL, typesize, ierr ) - ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN - CALL mpi_type_size( MPI_INTEGER, typesize, ierr ) - ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN - CALL mpi_type_size( MPI_LOGICAL, typesize, ierr ) - ENDIF - - IF ( .NOT. okay_to_write( DataHandle ) ) THEN - - ! This is a "training" write. - ! it is not okay to actually write; what we do here is just "bookkeep": count up - ! the number and size of messages that we will output to io server associated with - ! this task - - CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, typesize, & - DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & - 333933 , MemoryOrder , Stagger , DimNames , & ! 333933 means training; magic number - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd ) - - int_num_bytes_to_write(DataHandle) = int_num_bytes_to_write(DataHandle) + locsize * typesize + hdrbufsize - - ! Send the hdr for the write in case the interface is calling the I/O API in "learn" mode - - iserver = get_server_id ( DataHandle ) -!JMDEBUGwrite(0,*)'wrf_quilt_write_field (dryrun) ',iserver - CALL get_mpi_comm_io_groups( comm_io_group , iserver ) - ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here) - - CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) - -#if 0 - IF ( .NOT. wrf_dm_on_monitor() ) THEN ! only one task in compute grid sends this message; send noops on others - CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) - ENDIF -#endif - - -!!ARPTIMING CALL start_timing - ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) - reduced = 0 - reduced(1) = hdrbufsize -#ifdef PNETCDF_QUILT - IF ( compute_group_master(1) ) reduced(2) = DataHandle -#else - IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle -#endif - CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) -!!ARPTIMING CALL end_timing("MPI_Reduce in wrf_quilt_write_field dryrun") - ! send data to the i/o processor - - CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & - onebyte, & - hdrbuf, hdrbufsize , & - dummy, 0 ) - - ELSE - - IF ( .NOT. associated( int_local_output_buffer ) ) THEN - ALLOCATE ( int_local_output_buffer( (int_num_bytes_to_write( DataHandle )+1)/itypesize ), Stat=ierr ) - IF(ierr /= 0)THEN - CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: allocate of int_local_output_buffer failed" ) - END IF - int_local_output_cursor = 1 - ENDIF - iserver = get_server_id ( DataHandle ) -!JMDEBUGwrite(0,*)'wrf_quilt_write_field (writing) ',iserver - - ! This is NOT a "training" write. It is OK to write now. - CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, typesize, & - DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & - 0 , MemoryOrder , Stagger , DimNames , & ! non-333933 means okay to write; magic number - DomainStart , DomainEnd , & - MemoryStart , MemoryEnd , & - PatchStart , PatchEnd ) - - ! Pack header into int_local_output_buffer. It will be sent to the - ! I/O servers during the next "iosync" operation. -#ifdef DEREF_KLUDGE - CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer(1), int_local_output_cursor ) +#if ( HWRF == 1 ) +# include "module_io_quilt_new.F" #else - CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer, int_local_output_cursor ) -#endif - - ! Pack field data into int_local_output_buffer. It will be sent to the - ! I/O servers during the next "iosync" operation. -#ifdef DEREF_KLUDGE - CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), & - locsize * typesize , int_local_output_buffer(1), int_local_output_cursor ) -#else - CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), & - locsize * typesize , int_local_output_buffer, int_local_output_cursor ) -#endif - - ENDIF - Status = 0 -!!ARPTIMING CALL end_timing("wrf_quilt_write_field") - -#endif - RETURN -END SUBROUTINE wrf_quilt_write_field - -SUBROUTINE wrf_quilt_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , & - DomainStart , DomainEnd , Status ) -! -! This routine applies only to a dataset that is open for read. It instructs -! the I/O quilt servers to return information about variable VarName. -! This routine is called only by client (compute) tasks. -! -! This is not yet supported. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - IMPLICIT NONE - integer ,intent(in) :: DataHandle - character*(*) ,intent(in) :: VarName - integer :: NDim - character*(*) :: MemoryOrder - character*(*) :: Stagger - integer ,dimension(*) :: DomainStart, DomainEnd - integer :: Status -#endif -RETURN -END SUBROUTINE wrf_quilt_get_var_info - -subroutine wrf_quilt_find_server(iserver) - - ! This routine is called by the compute processes when they need an - ! I/O server to write out a new file. Upon return, this routine will - ! set iserver to the next available I/O server group. - - ! A mpi_recv to all of mpi_comm_avail is used to implement this, and - ! that recv will not return until an I/O server group calls - ! wrf_quilt_server_ready to signal that it is ready for a new file. - -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - use module_wrf_quilt, only : in_avail, mpi_comm_avail, mpi_comm_local - - implicit none - INCLUDE 'mpif.h' - integer, intent(inout) :: iserver - integer :: ierr - character(255) :: message - - call wrf_message('Polling I/O servers...') - - if(in_avail) then - call mpi_recv(iserver,1,MPI_INTEGER,MPI_ANY_SOURCE,0,mpi_comm_avail,MPI_STATUS_IGNORE,ierr) - if(ierr/=0) then - call wrf_error_fatal('mpi_recv failed in wrf_quilt_find_server') - endif - endif - - call mpi_bcast(iserver,1,MPI_INTEGER,0,mpi_comm_local,ierr) - if(ierr/=0) then - call wrf_error_fatal('mpi_bcast failed in wrf_quilt_find_server') - endif - - write(message,'("I/O server ",I0," is ready for operations.")') iserver - call wrf_message(message) - -#endif - -end subroutine wrf_quilt_find_server -subroutine wrf_quilt_server_ready() - - ! This routine is called by the I/O server group's master process once the - ! I/O server group is done writing its current file, and is waiting for - ! a new one. This information is passed to the monitor process by a - ! blocking send from the I/O server master process to the monitor. - - ! All processes in an I/O group must call this routine, and this routine - ! will not return (in any process) until the monitor process signals - ! that it wants the I/O server group to write a file. That signal is - ! sent in a call to wrf_quilt_find_server on the compute processes. - -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - use module_wrf_quilt, only : mpi_comm_local, in_avail, availrank, mpi_comm_avail - - implicit none - INCLUDE 'mpif.h' - integer :: ierr - character*255 :: message - - write(message,*) 'Entering wrf_quilt_server_ready.' - call wrf_debug(1,message) - - call mpi_barrier(mpi_comm_local,ierr) - if(ierr/=0) then - call wrf_error_fatal('mpi_barrier failed in wrf_quilt_server_ready') - endif - - if(in_avail) then - write(message,'("mpi_ssend ioserver=",I0," in wrf_quilt_server_ready")') availrank - call wrf_debug(1,message) - call mpi_ssend(availrank,1,MPI_INTEGER,0,0,mpi_comm_avail,ierr) - if(ierr/=0) then - call wrf_error_fatal('mpi_ssend failed in wrf_quilt_server_ready') - endif - endif - - call mpi_barrier(mpi_comm_local,ierr) - if(ierr/=0) then - call wrf_error_fatal('mpi_barrier failed in wrf_quilt_server_ready') - endif - - write(message,*) 'Leaving wrf_quilt_server_ready.' - call wrf_debug(1,message) -#endif - -end subroutine wrf_quilt_server_ready - -SUBROUTINE get_mpi_comm_io_groups( retval, isrvr ) -! -! This routine returns the compute+io communicator to which this -! compute task belongs for I/O server group "isrvr". -! This routine is called only by client (compute) tasks. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_wrf_quilt - IMPLICIT NONE - INTEGER, INTENT(IN ) :: isrvr - INTEGER, INTENT(OUT) :: retval - retval = mpi_comm_io_groups(isrvr) -#endif - RETURN -END SUBROUTINE get_mpi_comm_io_groups - -SUBROUTINE get_nio_tasks_in_group( retval ) -! -! This routine returns the number of I/O server tasks in each -! I/O server group. It can be called by both clients and -! servers. -! -#if defined( DM_PARALLEL ) && !defined( STUBMPI ) - USE module_wrf_quilt - IMPLICIT NONE - INTEGER, INTENT(OUT) :: retval - retval = nio_tasks_in_group +# include "module_io_quilt_old.F" #endif - RETURN -END SUBROUTINE get_nio_tasks_in_group - -SUBROUTINE collect_on_comm_debug(file,line, comm_io_group, & - sze, & - hdrbuf, hdrbufsize , & - outbuf, outbufsize ) - IMPLICIT NONE - CHARACTER*(*) file - INTEGER line - INTEGER comm_io_group - INTEGER sze - INTEGER hdrbuf(*), outbuf(*) - INTEGER hdrbufsize, outbufsize - - !write(0,*)'collect_on_comm_debug ',trim(file),line,sze,hdrbufsize,outbufsize - CALL collect_on_comm( comm_io_group, & - sze, & - hdrbuf, hdrbufsize , & - outbuf, outbufsize ) - !write(0,*)trim(file),line,'returning' - RETURN -END - - -SUBROUTINE collect_on_comm_debug2(file,line,var,tag,sz,hdr_rec_size, & - comm_io_group, & - sze, & - hdrbuf, hdrbufsize , & - outbuf, outbufsize ) - IMPLICIT NONE - CHARACTER*(*) file,var - INTEGER line,tag,sz,hdr_rec_size - INTEGER comm_io_group - INTEGER sze - INTEGER hdrbuf(*), outbuf(*) - INTEGER hdrbufsize, outbufsize -! write(0,*)'collect_on_comm_debug2 ',trim(file),line,trim(var),tag,sz,hdr_rec_size,sze,hdrbufsize,outbufsize - CALL collect_on_comm( comm_io_group, & - sze, & - hdrbuf, hdrbufsize , & - outbuf, outbufsize ) -! write(0,*)'collect_on_comm_debug2 ',trim(file),line,'returning for ',trim(var) - RETURN -END diff --git a/wrfv2_fire/frame/module_io_quilt_new.F b/wrfv2_fire/frame/module_io_quilt_new.F new file mode 100644 index 00000000..481b1573 --- /dev/null +++ b/wrfv2_fire/frame/module_io_quilt_new.F @@ -0,0 +1,5335 @@ +!WRF:DRIVER_LAYER:IO +! +#define DEBUG_LVL 50 +#define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k ) + +! Workaround for bug in the IBM MPI implementation. Look near the +! bottom of this file for an explanation. +#ifdef IBM_REDUCE_BUG_WORKAROUND +#define mpi_x_reduce(sb,rb,c,dt,op,r,com,ierr) reduce_add_integer(sb,rb,c,r,com) +#else +#define mpi_x_reduce(sb,rb,c,dt,op,r,com,ierr) MPI_Reduce(sb,rb,c,dt,op,r,com,ierr) +#endif + +MODULE module_wrf_quilt +! +!
+! This module contains WRF-specific I/O quilt routines called by both 
+! client (compute) and server (I/O quilt) tasks.  I/O quilt servers are 
+! a run-time optimization that allow I/O operations, executed on the I/O 
+! quilt server tasks, to be overlapped with useful computation, executed on 
+! the compute tasks.  Since I/O operations are often quite slow compared to 
+! computation, this performance optimization can increase parallel 
+! efficiency.  
+!
+! Currently, one group of I/O servers can be specified at run-time.  Namelist 
+! variable "nio_tasks_per_group" is used to specify the number of I/O server 
+! tasks in this group.  In most cases, parallel efficiency is optimized when 
+! the minimum number of I/O server tasks are used.  If memory needed to cache 
+! I/O operations fits on a single processor, then set nio_tasks_per_group=1.  
+! If not, increase the number of I/O server tasks until I/O operations fit in 
+! memory.  In the future, multiple groups of I/O server tasks will be 
+! supported.  The number of groups will be specified by namelist variable 
+! "nio_groups".  For now, nio_groups must be set to 1.  Currently, I/O servers 
+! only support overlap of output operations with computation.  Also, only I/O 
+! packages that do no support native parallel I/O may be used with I/O server 
+! tasks.  This excludes PHDF5 and MCEL.  
+!
+! In this module, the I/O quilt server tasks call package-dependent 
+! WRF-specific I/O interfaces to perform I/O operations requested by the 
+! client (compute) tasks.  All of these calls occur inside subroutine 
+! quilt().  
+! 
+! The client (compute) tasks call package-independent WRF-specific "quilt I/O" 
+! interfaces that send requests to the I/O quilt servers.  All of these calls 
+! are made from module_io.F.  
+!
+! These routines have the same names and (roughly) the same arguments as those 
+! specified in the WRF I/O API except that:
+! - "Quilt I/O" routines defined in this file and called by routines in 
+!   module_io.F have the "wrf_quilt_" prefix.
+! - Package-dependent routines called from routines in this file are defined 
+!   in the external I/O packages and have the "ext_" prefix.
+!
+! Both client (compute) and server tasks call routine init_module_wrf_quilt() 
+! which then calls setup_quilt_servers() determine which tasks are compute 
+! tasks and which are server tasks.  Before the end of init_module_wrf_quilt() 
+! server tasks call routine quilt() and remain there for the rest of the model 
+! run.  Compute tasks return from init_module_wrf_quilt() to perform model 
+! computations.  
+!
+! See http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the latest
+! version of the WRF I/O API.  This document includes detailed descriptions
+! of subroutines and their arguments that are not duplicated here.
+!
+! + USE module_internal_header_util + USE module_timing + USE module_driver_constants !, ONLY : max_domains + USE module_dm, ONLY : current_id +#if ( DA_CORE != 1 ) + USE module_cpl, ONLY : coupler_on, cpl_set_dm_communicator, cpl_finalize +#endif + + INTEGER, PARAMETER :: int_num_handles = 99 + INTEGER, PARAMETER :: max_servers = int_num_handles+1 ! why +1? + LOGICAL, DIMENSION(0:int_num_handles) :: okay_to_write, int_handle_in_use, okay_to_commit + INTEGER, DIMENSION(0:int_num_handles) :: int_num_bytes_to_write, io_form + INTEGER, DIMENSION(0:int_num_handles) :: which_grid_is_handle + INTEGER, DIMENSION(0:int_num_handles) :: prev_server_for_handle + REAL, POINTER,SAVE :: int_local_output_buffer(:) + INTEGER, SAVE :: int_local_output_cursor + LOGICAL :: quilting_enabled + LOGICAL :: disable_quilt = .FALSE. + INTEGER :: server_for_handle(int_num_handles,max_domains) + INTEGER :: reduced(2), reduced_dummy(2) + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + INTEGER :: mpi_comm_avail(max_domains),availrank(max_domains) + LOGICAL :: in_avail=.false., poll_servers=.false. + + INTEGER, ALLOCATABLE :: role_for_task(:) + INTEGER nio_groups +#ifdef DM_PARALLEL + INTEGER :: mpi_comm_local, mpi_comm_local_io_server_tmp + LOGICAL :: compute_group_master(max_servers,max_domains) + INTEGER :: mpi_comm_io_groups(max_servers,max_domains) + INTEGER :: nio_tasks_per_group(max_domains) + INTEGER :: ntasks + INTEGER :: mytask + + INTEGER, PARAMETER :: onebyte = 1 + INTEGER comm_io_servers, iserver, hdrbufsize, obufsize + INTEGER, DIMENSION(4096) :: hdrbuf + INTEGER, DIMENSION(int_num_handles) :: handle +#endif + +#ifdef IBM_REDUCE_BUG_WORKAROUND +! Workaround for bug in the IBM MPI implementation. Look near the +! bottom of this file for an explanation. + interface reduce_add_integer + module procedure reduce_add_int_arr + module procedure reduce_add_int_scl + end interface +#endif + + CONTAINS + +#if defined(DM_PARALLEL) && !defined( STUBMPI ) + INTEGER FUNCTION get_server_id ( dhandle ) +! +! Logic in the client side to know which io server +! group to send to. If the unit corresponds to a file that's +! already been opened, then we have no choice but to send the +! data to that group again, regardless of whether there are +! other server-groups. If it's a new file, we can chose a new +! server group. I.e. opening a file locks it onto a server +! group. Closing the file unlocks it. +! + IMPLICIT NONE + INTEGER, INTENT(IN) :: dhandle +! local + INTEGER :: id + + IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN + id = which_grid_is_handle(dhandle) + IF ( id .LT. 1 .OR. id .GT. max_domains ) THEN + CALL wrf_error_fatal("module_io_quilt: get_server_id, bad grid id stored with handle") + ENDIF + IF ( server_for_handle ( dhandle, id ) .GE. 1 ) THEN + get_server_id = server_for_handle ( dhandle, id ) + ELSE + IF(poll_servers) THEN + ! Poll server group masters to find an inactive I/O server group: + call wrf_quilt_find_server(server_for_handle(dhandle, id)) + ELSE + ! Server polling is disabled, so cycle through servers: + prev_server_for_handle(id) = mod ( prev_server_for_handle(id) + 1 , nio_groups ) + server_for_handle( dhandle, id ) = prev_server_for_handle(id)+1 + ENDIF + get_server_id=server_for_handle(dhandle, id) + ENDIF + ELSE + CALL wrf_message('module_io_quilt: get_server_id bad dhandle' ) + ENDIF + END FUNCTION get_server_id +#endif + + SUBROUTINE set_server_id ( dhandle, value ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: dhandle, value + INTEGER id + IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN + id = which_grid_is_handle(dhandle) + IF ( id .GE. 1 .AND. ID .LE. max_domains ) THEN + server_for_handle(dhandle,id) = value + ELSE + CALL wrf_message('module_io_quilt: set_server_id bad grid id stored with handle' ) + ENDIF + ELSE + CALL wrf_message('module_io_quilt: set_server_id bad dhandle' ) + ENDIF + END SUBROUTINE set_server_id + + LOGICAL FUNCTION get_poll_servers() + implicit none + get_poll_servers=poll_servers + end FUNCTION get_poll_servers + +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + SUBROUTINE int_get_fresh_handle( retval ) +! +! Find an unused "client file handle" and return it in retval. +! The "client file handle" is used to remember how a file was opened +! so clients do not need to ask the I/O quilt servers for this information. +! It is also used as a file identifier in communications with the I/O +! server task. +! +! Note that client tasks know nothing about package-specific handles. +! Only the I/O quilt servers know about them. +! + INTEGER, INTENT(OUT) :: retval + INTEGER i + retval = -1 + DO i = 1, int_num_handles + IF ( .NOT. int_handle_in_use(i) ) THEN + retval = i + GOTO 33 + ENDIF + ENDDO +33 CONTINUE + IF ( retval < 0 ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: int_get_fresh_handle() can not") + ENDIF + int_handle_in_use(i) = .TRUE. + NULLIFY ( int_local_output_buffer ) + END SUBROUTINE int_get_fresh_handle + + SUBROUTINE setup_quilt_servers ( id, nio_tasks_per_group, & + role_for_task, & + num_io_tasks, & + ncompute_tasks, & + mytask, & + ntasks, & + n_groups_arg, & + mpi_comm_wrld, & + mpi_comm_local, & + mpi_comm_io_groups, & + compute_node ) +! +! Both client (compute) and server tasks call this routine to +! determine which tasks are compute tasks and which are I/O server tasks. +! +! Module variables MPI_COMM_LOCAL and MPI_COMM_IO_GROUPS(:) are set up to +! contain MPI communicators as follows: +! +! MPI_COMM_LOCAL is the Communicator for the local groups of tasks. For the +! compute tasks it is the group of compute tasks; for a server group it the +! communicator of tasks in the server group. +! +! Elements of MPI_COMM_IO_GROUPS are communicators that each contain one or +! more compute tasks and a single I/O server assigned to those compute tasks. +! The I/O server tasks is always the last task in these communicators. +! On a compute task, which has a single associate in each of the server +! groups, MPI_COMM_IO_GROUPS is treated as an array; each element corresponds +! to a different server group. +! On a server task only the first element of MPI_COMM_IO_GROUPS is used +! because each server task is part of only one io_group. +! +! I/O server tasks in each I/O server group are divided among compute tasks as +! evenly as possible. +! +! When multiple I/O server groups are used, each must have the same number of +! tasks. When the total number of extra I/O tasks does not divide evenly by +! the number of io server groups requested, the remainder tasks are not used +! (wasted). +! +! For example, communicator membership for 18 tasks with nio_groups=2 and +! nio_tasks_per_group=3 is shown below: +! +!
+! Membership for MPI_COMM_LOCAL communicators:
+!   COMPUTE TASKS:          0   1   2   3   4   5   6   7   8   9  10  11
+!   1ST I/O SERVER GROUP:  12  13  14
+!   2ND I/O SERVER GROUP:  15  16  17
+!
+! Membership for MPI_COMM_IO_GROUPS(1):  
+!   COMPUTE TASKS 0, 3, 6, 9:   0   3   6   9  12
+!   COMPUTE TASKS 1, 4, 7,10:   1   4   7  10  13
+!   COMPUTE TASKS 2, 5, 8,11:   2   5   8  11  14
+!   I/O SERVER TASK       12:   0   3   6   9  12
+!   I/O SERVER TASK       13:   1   4   7  10  13
+!   I/O SERVER TASK       14:   2   5   8  11  14
+!   I/O SERVER TASK       15:   0   3   6   9  15
+!   I/O SERVER TASK       16:   1   4   7  10  16
+!   I/O SERVER TASK       17:   2   5   8  11  17
+!
+! Membership for MPI_COMM_IO_GROUPS(2):  
+!   COMPUTE TASKS 0, 3, 6, 9:   0   3   6   9  15
+!   COMPUTE TASKS 1, 4, 7,10:   1   4   7  10  16
+!   COMPUTE TASKS 2, 5, 8,11:   2   5   8  11  17
+!   I/O SERVER TASK       12:  ** not used **
+!   I/O SERVER TASK       13:  ** not used **
+!   I/O SERVER TASK       14:  ** not used **
+!   I/O SERVER TASK       15:  ** not used **
+!   I/O SERVER TASK       16:  ** not used **
+!   I/O SERVER TASK       17:  ** not used **
+!
+! + USE module_configure +#ifdef DM_PARALLEL + USE module_dm, ONLY : compute_mesh,nest_pes_x,nest_pes_y,domain_active_this_task,& + tasks_per_split,comm_start,dm_task_split +#endif + IMPLICIT NONE + INCLUDE 'mpif.h' + INTEGER, INTENT(IN) :: id, nio_tasks_per_group(:), mytask, ntasks, & + n_groups_arg, mpi_comm_wrld + INTEGER, INTENT(IN) :: role_for_task(:) + INTEGER, INTENT(IN) :: ncompute_tasks, num_io_tasks + INTEGER, INTENT(OUT) :: mpi_comm_local + INTEGER, DIMENSION(100,max_domains), INTENT(OUT) :: mpi_comm_io_groups + LOGICAL, INTENT(OUT) :: compute_node +! Local + INTEGER :: i, j, ii, comdup, ierr, niotasks, n_groups, iisize, itask, nio + INTEGER, DIMENSION(ntasks) :: icolor + CHARACTER*128 mess + INTEGER :: io_form_setting + INTEGER :: me + INTEGER :: k, m, nprocx, nprocy, found, found_io + LOGICAL :: reorder_mesh + CHARACTER*256 message + +#if 0 +! with the changes to quilting and the movement of some init calls around +! this no longer works because the namelist hasn't been read and distributed yet. +! need to move this somewhere where it will work again, maybe into check-a-mundo? +! +!check the namelist and make sure there are no output forms specified +!that cannot be quilted + CALL nl_get_io_form_history(1, io_form_setting) ; call sokay( 'history', io_form_setting ) + CALL nl_get_io_form_restart(1, io_form_setting) ; call sokay( 'restart', io_form_setting ) + CALL nl_get_io_form_auxhist1(1, io_form_setting) ; call sokay( 'auxhist1', io_form_setting ) + CALL nl_get_io_form_auxhist2(1, io_form_setting) ; call sokay( 'auxhist2', io_form_setting ) + CALL nl_get_io_form_auxhist3(1, io_form_setting) ; call sokay( 'auxhist3', io_form_setting ) + CALL nl_get_io_form_auxhist4(1, io_form_setting) ; call sokay( 'auxhist4', io_form_setting ) + CALL nl_get_io_form_auxhist5(1, io_form_setting) ; call sokay( 'auxhist5', io_form_setting ) + CALL nl_get_io_form_auxhist6(1, io_form_setting) ; call sokay( 'auxhist6', io_form_setting ) + CALL nl_get_io_form_auxhist7(1, io_form_setting) ; call sokay( 'auxhist7', io_form_setting ) + CALL nl_get_io_form_auxhist8(1, io_form_setting) ; call sokay( 'auxhist8', io_form_setting ) + CALL nl_get_io_form_auxhist9(1, io_form_setting) ; call sokay( 'auxhist9', io_form_setting ) + CALL nl_get_io_form_auxhist10(1, io_form_setting) ; call sokay( 'auxhist10', io_form_setting ) + CALL nl_get_io_form_auxhist11(1, io_form_setting) ; call sokay( 'auxhist11', io_form_setting ) +#endif + + n_groups = n_groups_arg + IF ( n_groups .LT. 1 ) n_groups = 1 + +! compute_node = .TRUE. + +! +! nio is number of io tasks per group. If there arent enough tasks to satisfy +! the requirement that there be at least as many compute tasks as io tasks in +! each group, then just print a warning and dump out of quilting +! + + nio = nio_tasks_per_group(id) + IF ( nio .LT. 0 ) THEN + nio = 0 + ENDIF + IF ( nio .EQ. 0 ) THEN + quilting_enabled = .FALSE. + compute_node = .TRUE. + mpi_comm_local = mpi_comm_wrld + mpi_comm_io_groups(:,id) = mpi_comm_wrld + RETURN + ENDIF + found = comm_start(id) + found_io = -99 + DO i=1,ntasks + IF ( role_for_task(i) .EQ. id ) THEN + found_io = i-1 ! found_io is the first io task for this domain, used below + exit + ENDIF + ENDDO + IF ( found_io .eq. -99 ) THEN + CALL wrf_error_fatal('setup_quilt_servers: found_io not found, should not happen (but there it is)') + ENDIF + + quilting_enabled = .TRUE. + + icolor = -99 ! not an I/O task + ii = 0 + DO i = 1, ntasks + IF ( role_for_task( i ) .EQ. id ) THEN + icolor(i) = ii / nio + ii = ii + 1 + ENDIF + ENDDO + CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr) + CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_local,ierr) + IF ( icolor(mytask+1) .NE. -99 ) THEN + mpi_comm_local_io_server_tmp = mpi_comm_local + ENDIF + +! At this point, mpi_comm_local will be the local communicator for the server group associated with this domain +! the mpi_comm_local on the other tasks is a throwaway + +! Now construct the communicators for the io_groups + nprocx = nest_pes_x(id) + nprocy = nest_pes_y(id) + + IF ( nio .GT. nprocy*nprocx ) THEN + CALL wrf_error_fatal( 'more io tasks than compute tasks specified' ) + ENDIF + + m = mod(nprocy*nprocx,nio) ! divide up remainder, 1 row per, until gone + ii = 0 + j = 1 + do while ( j .le. nprocx*nprocy ) + do i = 0, (nprocx*nprocy)/nio+min(m,1)-1 + icolor(j+comm_start(id)) = ii + j = j + 1 + enddo + ii = ii + 1 + m = max(m-1,0) + enddo + +! ... and add the io servers as the last task in each group + DO j = 1, n_groups + DO i = found_io+1,ntasks + icolor(i) = -99 + ENDDO + ii = 0 + DO i = found_io+(j-1)*nio+1,found_io+j*nio + icolor(i) = ii + ii = ii+1 + ENDDO + CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr) + CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask, & + mpi_comm_io_groups(j,id),ierr) + ENDDO + +#ifdef PNETCDF_QUILT + if(poll_servers) then + poll_servers=.false. + call wrf_message('Warning: server polling does not work with pnetcdf_quilt. Disabled poll_servers.') + else +#endif + if(n_groups==1) then + poll_servers=.false. + call wrf_message('Server polling is useless with one io group. Disabled poll_servers.') + endif +#ifdef PNETCDF_QUILT + endif +#endif + + + if(poll_servers) then + ! If server polling is enabled, we need to create mpi_comm_avail, + ! which contains the monitor process, and the I/O server master process + ! for each I/O server group. This will be used in the routines + ! wrf_quilt_find_server and wrf_quilt_server_ready to find inactive + ! I/O servers for new data handles in get_server_id. + + ! The "in_avail" is set to true iff I am in the mpi_comm_avail. + + call mpi_comm_rank(mpi_comm_wrld,me,ierr) + + icolor=-99 + in_avail=.false. + + IF ( found .eq. me ) THEN ! found is the first task id for this domain, used below too + in_avail=.true. + ENDIF + icolor(1)=1 + + nio = nio_tasks_per_group(id) + do j=1,n_groups + i=ncompute_tasks+j*nio-1 + if(me+1==i) then + in_avail=.true. ! I/O server masters are in mpi_comm_avail + endif + icolor(i)=1 + enddo + + CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr) + CALL MPI_Comm_split(comdup,icolor(me+1),me, & + mpi_comm_avail(id),ierr) + + availrank=MPI_UNDEFINED + IF(in_avail) THEN + call mpi_comm_rank(mpi_comm_avail(id),availrank(id),ierr) + ENDIF + IF ( role_for_task(me+1) .GT. 1000 ) THEN ! one of the server tasks + mpi_comm_avail(1) = mpi_comm_avail(id) + availrank(1) = availrank(id) + ENDIF + + endif + +!jm compute_group_master = .FALSE. +!jm compute_node = .FALSE. + + DO j = 1, n_groups + + IF ((found .LE. mytask .AND. mytask .LT. found +ncompute_tasks ).OR. & ! I am a compute task + (found_io+(j-1)*nio .LE. mytask .AND. mytask .LT. found_io+j*nio) & ! I am the I/O server for this group + ) THEN + + CALL MPI_Comm_Size( mpi_comm_io_groups(j,id) , iisize, ierr ) + ! Get the rank of this compute task in the compute+io + ! communicator to which it belongs + CALL MPI_Comm_Rank( mpi_comm_io_groups(j,id) , me , ierr ) + + ! If I am an I/O server for this group then make that group's + ! communicator the first element in the mpi_comm_io_groups array + ! (I will ignore all of the other elements). + + IF ( (found .LE. mytask .AND. mytask .LT. ncompute_tasks ) ) THEN + compute_node = .TRUE. + ! If I am a compute task, check whether I am the member of my + ! group that will communicate things that should be sent just + ! once (e.g. commands) to the IO server of my group. + compute_group_master(j,id) = (me .EQ. 0) + ELSE + IF (found_io+(j-1)*nio .LE. mytask .AND. mytask .LT. found_io+j*nio) THEN + mpi_comm_io_groups(1,1) = mpi_comm_io_groups(j,id) + ENDIF + ENDIF + ENDIF + + ENDDO + + END SUBROUTINE setup_quilt_servers + + SUBROUTINE sokay ( stream, io_form ) + USE module_state_description + CHARACTER*(*) stream + CHARACTER*256 mess + INTEGER io_form + + SELECT CASE (io_form) +#ifdef NETCDF + CASE ( IO_NETCDF ) + RETURN +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + RETURN +#endif +#ifdef YYY + CASE ( IO_YYY ) + RETURN +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + RETURN +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + RETURN +#endif + CASE (0) + RETURN + CASE DEFAULT + WRITE(mess,*)' An output format has been specified that is incompatible with quilting: io_form: ',io_form,' ',TRIM(stream) + CALL wrf_error_fatal(mess) + END SELECT + END SUBROUTINE sokay + + SUBROUTINE quilt +! +! I/O server tasks call this routine and remain in it for the rest of the +! model run. I/O servers receive I/O requests from compute tasks and +! perform requested I/O operations by calling package-dependent WRF-specific +! I/O interfaces. Requests are sent in the form of "data headers". Each +! request has a unique "header" message associated with it. For requests that +! contain large amounts of data, the data is appended to the header. See +! file module_internal_header_util.F for detailed descriptions of all +! headers. +! +! We wish to be able to link to different packages depending on whether +! the I/O is restart, initial, history, or boundary. +! + USE module_state_description + USE module_quilt_outbuf_ops + USE module_configure, only : grid_config_rec_type, model_config_rec, model_to_grid_config_rec + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" +#include "wrf_io_flags.h" + TYPE (grid_config_rec_type) :: config_flags + INTEGER itag, ninbuf, ntasks_io_group, ntasks_local_group, mytask_local, ierr + INTEGER istat + INTEGER mytask_io_group + INTEGER :: nout_set = 0 + INTEGER :: obufsize, bigbufsize, chunksize, sz + REAL, DIMENSION(1) :: dummy + INTEGER, ALLOCATABLE, DIMENSION(:) :: obuf, bigbuf + REAL, ALLOCATABLE, DIMENSION(:) :: RDATA + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA + CHARACTER (LEN=512) :: CDATA + CHARACTER (LEN=80) :: fname + INTEGER icurs, hdrbufsize, itypesize, ftypesize, rtypesize, Status, fstat, io_form_arg + INTEGER :: DataHandle, FieldType, Comm, IOComm, DomainDesc, code, Count + INTEGER, DIMENSION(3) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd + INTEGER :: dummybuf(1) + INTEGER :: num_noops, num_commit_messages, num_field_training_msgs, hdr_tag + CHARACTER (len=256) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess + INTEGER, EXTERNAL :: use_package + LOGICAL :: stored_write_record, retval + INTEGER iii, jjj, vid, dom_id + LOGICAL :: call_server_ready + +logical okay_to_w +character*120 sysline + + dom_id = 1 ! always a valid assumption for domain id for this netcdf setting + CALL model_to_grid_config_rec ( dom_id , model_config_rec , config_flags ) + +! If we've been built with PNETCDF_QUILT defined then we use parallel I/O +! within the group of I/O servers rather than gathering the data onto the +! root I/O server. Unfortunately, this approach means that we can no-longer +! select different I/O layers for use with quilting at run time. ARPDBG. +! This code is sufficiently different that it is kept in the separate +! quilt_pnc() routine. +#ifdef PNETCDF_QUILT + CALL quilt_pnc() + RETURN +#endif + +! Call ext_pkg_ioinit() routines to initialize I/O packages. + SysDepInfo = " " +#ifdef NETCDF + if ( config_flags%use_netcdf_classic ) SysDepInfo="use_netcdf_classic" + CALL ext_ncd_ioinit( SysDepInfo, ierr ) + SysDepInfo = " " +#endif +#ifdef INTIO + CALL ext_int_ioinit( SysDepInfo, ierr ) +#endif +#ifdef XXX + CALL ext_xxx_ioinit( SysDepInfo, ierr) +#endif +#ifdef YYY + CALL ext_yyy_ioinit( SysDepInfo, ierr) +#endif +#ifdef ZZZ + CALL ext_zzz_ioinit( SysDepInfo, ierr) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioinit( SysDepInfo, ierr) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioinit( SysDepInfo, ierr) +#endif + + call_server_ready = .true. ! = true when the server is ready for a new file + + okay_to_commit = .false. + stored_write_record = .false. + ninbuf = 0 + ! get info. about the I/O server group that this I/O server task + ! belongs to + ! Last task in this I/O server group is the I/O server "root" + ! The I/O server "root" actually writes data to disk + ! TBH: WARNING: This is also implicit in the call to collect_on_comm(). + CALL mpi_x_comm_size( mpi_comm_io_groups(1,1), ntasks_io_group, ierr ) + CALL MPI_COMM_RANK( mpi_comm_io_groups(1,1), mytask_io_group, ierr ) + CALL mpi_x_comm_size( mpi_comm_local, ntasks_local_group, ierr ) + CALL MPI_COMM_RANK( mpi_comm_local, mytask_local, ierr ) + + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + IF ( itypesize <= 0 ) THEN + CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid") + ENDIF + +! Work out whether this i/o server processor has one fewer associated compute proc than +! the most any processor has. Can happen when number of i/o tasks does not evenly divide +! the number of compute tasks. This is needed to keep the i/o tasks sychronized on the +! same message when they start commmunicating to stitch together an output. +! + +! infinite loop until shutdown message received +! This is the main request-handling loop. I/O quilt servers stay in this loop +! until the model run ends. + okay_to_w = .FALSE. + + DO WHILE (.TRUE.) ! { + +! +! Each I/O server receives requests from its compute tasks. Each request +! is contained in a data header (see module_internal_header_util.F for +! detailed descriptions of data headers). +! Each request is sent in two phases. First, sizes of all messages that +! will be sent from the compute tasks to this I/O server are summed on the +! I/O server via MPI_reduce(). The I/O server then allocates buffer "obuf" +! and receives concatenated messages from the compute tasks in it via the +! call to collect_on_comm(). Note that "sizes" are generally expressed in +! *bytes* in this code so conversion to "count" (number of Fortran words) is +! required for Fortran indexing and MPI calls. +! + + if(poll_servers .and. call_server_ready) then + call_server_ready=.false. + ! Send a message to the monitor telling it we're ready + ! for a new data handle. + call wrf_quilt_server_ready() + endif + + ! wait for info from compute tasks in the I/O group that we're ready to rock + ! obufsize will contain number of *bytes* +!CALL start_timing() + ! first element of reduced is obufsize, second is DataHandle + ! if needed (currently needed only for ioclose). + reduced_dummy = 0 + +!write(0,*)'before mpi_x_reduce on quilt server ' + CALL mpi_x_reduce( reduced_dummy, reduced, 2, MPI_INTEGER, MPI_SUM, mytask_io_group, mpi_comm_io_groups(1,1), ierr ) + obufsize = reduced(1) +!CALL end_timing("MPI_Reduce at top of forever loop") +!JMDEBUGwrite(0,*)'obufsize = ',obufsize +! Negative obufsize will trigger I/O server exit. +!write(0,*)'after mpi_x_reduce on quilt server ',obufsize + IF ( obufsize .LT. 0 ) THEN + IF ( obufsize .EQ. -100 ) THEN ! magic number +#ifdef NETCDF + CALL ext_ncd_ioexit( Status ) +#endif +#ifdef INTIO + CALL ext_int_ioexit( Status ) +#endif +#ifdef XXX + CALL ext_xxx_ioexit( Status ) +#endif +#ifdef YYY + CALL ext_yyy_ioexit( Status ) +#endif +#ifdef ZZZ + CALL ext_zzz_ioexit( Status ) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioexit( Status ) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioexit( Status ) +#endif + CALL wrf_message ( 'I/O QUILT SERVERS DONE' ) +#if ( DA_CORE != 1 ) + IF (coupler_on) THEN + CALL cpl_finalize() + ELSE +#endif + CALL mpi_finalize(ierr) +#if ( DA_CORE != 1 ) + END IF +#endif + STOP + ELSE + WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.' + CALL wrf_error_fatal(mess) + ENDIF + ENDIF + +! CALL start_timing() +! Obufsize of zero signals a close + +! Allocate buffer obuf to be big enough for the data the compute tasks +! will send. Note: obuf is size in *bytes* so we need to pare this +! down, since the buffer is INTEGER. + IF ( obufsize .GT. 0 ) THEN + ALLOCATE( obuf( (obufsize+1)/itypesize ) ) + +! let's roll; get the data from the compute procs and put in obuf + CALL collect_on_comm_debug(__FILE__,__LINE__, mpi_comm_io_groups(1,1), & + onebyte, & + dummy, 0, & + obuf, obufsize ) +! CALL end_timing( "quilt on server: collecting data from compute procs" ) + ELSE + ! Necessarily, the compute processes send the ioclose signal, + ! if there is one, after the iosync, which means they + ! will stall on the ioclose message waiting for the quilt + ! processes if we handle the way other messages are collected, + ! using collect_on_comm. This avoids this, but we need + ! a special signal (obufsize zero) and the DataHandle + ! to be closed. That handle is send as the second + ! word of the io_close message received by the MPI_Reduce above. + ! Then a header representing the ioclose message is constructed + ! here and handled below as if it were received from the + ! compute processes. The clients (compute processes) must be + ! careful to send this correctly (one compule process sends the actual + ! handle and everone else sends a zero, so the result sums to + ! the value of the handle). + ! + ALLOCATE( obuf( 4096 ) ) + ! DataHandle is provided as second element of reduced + CALL int_gen_handle_header( obuf, obufsize, itypesize, & + reduced(2) , int_ioclose ) + + if(poll_servers) then + ! Once we're done closing, we need to tell the master + ! process that we're ready for more data. + call_server_ready=.true. + endif + ENDIF + +!write(0,*)'calling init_store_piece_of_field' +! Now all messages received from the compute clients are stored in +! obuf. Scan through obuf and extract headers and field data and store in +! internal buffers. The scan is done twice, first to determine sizes of +! internal buffers required for storage of headers and fields and second to +! actually store the headers and fields. This bit of code does not do the +! "quilting" (assembly of patches into full domains). For each field, it +! simply concatenates all received patches for the field into a separate +! internal buffer (i.e. one buffer per field). Quilting is done later by +! routine store_patch_in_outbuf(). + CALL init_store_piece_of_field + CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr ) +!write(0,*)'mpi_type_size returns ', itypesize +! Scan obuf the first time to calculate the size of the buffer required for +! each field. Calls to add_to_bufsize_for_field() accumulate sizes. + vid = 0 + icurs = itypesize + num_noops = 0 + num_commit_messages = 0 + num_field_training_msgs = 0 + DO WHILE ( icurs .lt. obufsize ) ! { + hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) + SELECT CASE ( hdr_tag ) + CASE ( int_field ) + CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + + IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks + IF ( num_field_training_msgs .EQ. 0 ) THEN + call add_to_bufsize_for_field( VarName, hdrbufsize ) +!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + num_field_training_msgs = num_field_training_msgs + 1 + ELSE + call add_to_bufsize_for_field( VarName, hdrbufsize ) +!write(0,*) 'X-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + icurs = icurs + hdrbufsize + +!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + + ! If this is a real write (i.e. not a training write), accumulate + ! buffersize for this field. + IF ( DomainDesc .NE. 333933 ) THEN ! magic number +!write(0,*) 'X-1a', chunksize, TRIM(VarName) + call add_to_bufsize_for_field( VarName, chunksize ) + icurs = icurs + chunksize + ENDIF + CASE ( int_open_for_write_commit ) ! only one per group of tasks + hdrbufsize = obuf(icurs/itypesize) + IF (num_commit_messages.EQ.0) THEN + call add_to_bufsize_for_field( 'COMMIT', hdrbufsize ) + ENDIF + num_commit_messages = num_commit_messages + 1 + icurs = icurs + hdrbufsize + CASE DEFAULT + hdrbufsize = obuf(icurs/itypesize) + +! This logic and the logic in the loop below is used to determine whether +! to send a noop records sent by the compute processes to allow to go +! through. The purpose is to make sure that the communications between this +! server and the other servers in this quilt group stay synchronized in +! the collection loop below, even when the servers are serving different +! numbers of clients. Here are some conditions: +! +! 1. The number of compute clients served will not differ by more than 1 +! 2. The servers with +1 number of compute clients begin with task 0 +! of mpi_comm_local, the commicator shared by this group of servers +! +! 3. For each collective field or metadata output from the compute tasks, +! there will be one record sent to the associated i/o server task. The +! i/o server task collects these records and stores them contiguously +! in a buffer (obuf) using collect_on_comm above. Thus, obuf on this +! server task will contain one record from each associated compute +! task, in order. +! +! 4. In the case of replicated output from the compute tasks +! (e.g. put_dom_ti records and control records like +! open_for_write_commit type records), compute task 0 is the only +! one that sends the record. The other compute tasks send noop +! records. Thus, obuf on server task zero will contain the output +! record from task 0 followed by noop records from the rest of the +! compute tasks associated with task 0. Obuf on the other server +! tasks will contain nothing but noop records. +! +! 5. The logic below will not allow any noop records from server task 0. +! It allows only one noop record from each of the other server tasks +! in the i/o group. This way, for replicated output, when the records +! are collected on one server task below, using collect_on_comm on +! mpi_comm_local, each task will provide exactly one record for each +! call to collect_on_comm: 1 bona fide output record from server task +! 0 and noops from the rest. + + IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) & + .OR.hdr_tag.NE.int_noop) THEN + write(VarName,'(I5.5)')vid +!write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + call add_to_bufsize_for_field( VarName, hdrbufsize ) + vid = vid+1 + ENDIF + IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + icurs = icurs + hdrbufsize + END SELECT + ENDDO ! } +! Store the headers and field data in internal buffers. The first call to +! store_piece_of_field() allocates internal buffers using sizes computed by +! calls to add_to_bufsize_for_field(). + vid = 0 + icurs = itypesize + num_noops = 0 + num_commit_messages = 0 + num_field_training_msgs = 0 + DO WHILE ( icurs .lt. obufsize ) !{ +!write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize + hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) + SELECT CASE ( hdr_tag ) + CASE ( int_field ) + CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + + IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks + IF ( num_field_training_msgs .EQ. 0 ) THEN + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) +!write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + num_field_training_msgs = num_field_training_msgs + 1 + ELSE + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) +!write(0,*) 'A-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + icurs = icurs + hdrbufsize + ! If this is a real write (i.e. not a training write), store + ! this piece of this field. + IF ( DomainDesc .NE. 333933 ) THEN ! magic number +!write(0,*) 'A-1a', chunksize, TRIM(VarName),PatchStart(1:3),PatchEnd(1:3) + call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize ) + icurs = icurs + chunksize + ENDIF + CASE ( int_open_for_write_commit ) ! only one per group of tasks + hdrbufsize = obuf(icurs/itypesize) + IF (num_commit_messages.EQ.0) THEN + call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize ) + ENDIF + num_commit_messages = num_commit_messages + 1 + icurs = icurs + hdrbufsize + CASE DEFAULT + hdrbufsize = obuf(icurs/itypesize) + IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) & + .OR.hdr_tag.NE.int_noop) THEN + write(VarName,'(I5.5)')vid +!write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) + vid = vid+1 + ENDIF + IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + icurs = icurs + hdrbufsize + END SELECT + ENDDO !} + +! Now, for each field, retrieve headers and patches (data) from the internal +! buffers and collect them all on the I/O quilt server "root" task. + CALL init_retrieve_pieces_of_field +! Retrieve header and all patches for the first field from the internal +! buffers. + CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) +! Sum sizes of all headers and patches (data) for this field from all I/O +! servers in this I/O server group onto the I/O server "root". + CALL mpi_x_reduce( sz, bigbufsize, 1, MPI_INTEGER, MPI_SUM, ntasks_local_group-1, mpi_comm_local, ierr ) +!write(0,*)'seed: sz ',sz,' bigbufsize ',bigbufsize,' VarName ', TRIM(VarName),' retval ',retval + +! Loop until there are no more fields to retrieve from the internal buffers. + DO WHILE ( retval ) !{ +#if 0 +#else + +! I/O server "root" allocates space to collect headers and fields from all +! other servers in this I/O server group. + IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN + ALLOCATE( bigbuf( (bigbufsize+1)/itypesize ) ) + else + ALLOCATE( bigbuf(1) ) + ENDIF + +! Collect buffers and fields from all I/O servers in this I/O server group +! onto the I/O server "root" + CALL collect_on_comm_debug2(__FILE__,__LINE__,Trim(VarName), & + get_hdr_tag(obuf),sz,get_hdr_rec_size(obuf), & + mpi_comm_local, & + onebyte, & + obuf, sz, & + bigbuf, bigbufsize ) +! The I/O server "root" now handles collected requests from all compute +! tasks served by this I/O server group (i.e. all compute tasks). + IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN +!jjj = 4 +!do iii = 1, ntasks_local_group +! write(0,*)'i,j,tag,size ', iii, jjj, get_hdr_tag(bigbuf(jjj/4)),get_hdr_rec_size(bigbuf(jjj/4)) +! jjj = jjj + get_hdr_rec_size(bigbuf(jjj/4)) +!enddo + + icurs = itypesize ! icurs is a byte counter, but buffer is integer + + stored_write_record = .false. + +! The I/O server "root" loops over the collected requests. + DO WHILE ( icurs .lt. bigbufsize ) !{ + CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr ) + +!write(0,*)'B tag,size ',icurs,get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) +! The I/O server "root" gets the request out of the next header and +! handles it by, in most cases, calling the appropriate external I/O package +! interface. + SELECT CASE ( get_hdr_tag( bigbuf(icurs/itypesize) ) ) +! The I/O server "root" handles the "noop" (do nothing) request. This is +! actually quite easy. "Noop" requests exist to help avoid race conditions. +! In some cases, only one compute task will everything about a request so +! other compute tasks send "noop" requests. + CASE ( int_noop ) + CALL int_get_noop_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize ) + icurs = icurs + hdrbufsize + +! The I/O server "root" handles the "put_dom_td_real" request. + CASE ( int_dom_td_real ) + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, DateStr, Element, RData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( RData ) +! The I/O server "root" handles the "put_dom_ti_real" request. + CASE ( int_dom_ti_real ) + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, Element, RData, Count, code ) +!write(0,*)' int_dom_ti_real ',trim(element),count + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +!write(0,*)'ext_ncd_put_dom_ti_real ',handle(DataHandle),TRIM(Element),RData,Status +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( RData ) + +! The I/O server "root" handles the "put_dom_td_integer" request. + CASE ( int_dom_td_integer ) + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, DateStr, Element, IData, Count, code ) +!write(0,*)' int_dom_td_integer ',trim(element) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( IData ) + +! The I/O server "root" handles the "put_dom_ti_integer" request. + CASE ( int_dom_ti_integer ) + + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, Element, IData, Count, code ) +!write(0,*)' int_dom_ti_integer ',trim(element) + icurs = icurs + hdrbufsize + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +!!write(0,*)'ext_ncd_put_dom_ti_integer ',handle(DataHandle),TRIM(Element),IData,Status +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif + + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( IData) + +! The I/O server "root" handles the "set_time" request. + CASE ( int_set_time ) + CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) +!write(0,*)' int_set_time ',trim(element) + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_set_time ( handle(DataHandle), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + +! The I/O server "root" handles the "put_dom_ti_char" request. + CASE ( int_dom_ti_char ) + CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) +!write(0,*)' after int_get_ti_header_char ',trim(VarName),trim(element) + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + +! The I/O server "root" handles the "put_var_ti_char" request. + CASE ( int_var_ti_char ) + CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) +!write(0,*)' int_var_ti_char ',trim(varname),trim(element) + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + + CASE ( int_ioexit ) +! ioexit is now handled by sending negative message length to server + CALL wrf_error_fatal( & + "quilt: should have handled int_ioexit already") +! The I/O server "root" handles the "ioclose" request. + CASE ( int_ioclose ) + CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + + IF ( DataHandle .GE. 1 ) THEN +!JMDEBUGwrite(0,*)'closing DataHandle ',DataHandle,' io_form ',io_form(DataHandle) + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_ncd_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_pnc_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_int_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_yyy_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr1_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr2_ioclose(handle(DataHandle),Status) + ENDIF +#endif + CASE DEFAULT + Status = 0 + END SELECT + ENDIF + +! If desired, outputs a ready flag after quilting subroutine closes the data handle for history (wrfout) file. + + IF (fname(1:6) .EQ. 'wrfout' .AND. config_flags%output_ready_flag ) THEN + OPEN (unit=99,file='wrfoutReady' // fname(7:30), status='unknown', access='sequential') + CLOSE (99) + ENDIF + +! The I/O server "root" handles the "open_for_write_begin" request. + CASE ( int_open_for_write_begin ) + + CALL int_get_ofwb_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + FileName,SysDepInfo,io_form_arg,DataHandle ) + +!write(0,*)' int_open_for_write_begin itypesize ',itypesize,' itypesize ',itypesize +!write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize +!write(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle +!write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo) + icurs = icurs + hdrbufsize +!write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) + + io_form(DataHandle) = io_form_arg +!write(0,*)'io_form(DataHandle) ',io_form(DataHandle) + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +!write(0,*)'ext_ncd_open_for_write_begin ',Trim(FileName),DataHandle,handle(DataHandle),Status +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + okay_to_write(DataHandle) = .false. + +! The I/O server "root" handles the "open_for_write_commit" request. +! In this case, the "okay_to_commit" is simply set to .true. so "write_field" +! requests will initiate writes to disk. Actual commit will be done after +! all requests in this batch have been handled. + CASE ( int_open_for_write_commit ) + + CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + okay_to_commit(DataHandle) = .true. + +! The I/O server "root" handles the "write_field" (int_field) request. +! If okay_to_write(DataHandle) is .true. then the patch in the +! header (bigbuf) is written to a globally-sized internal output buffer via +! the call to store_patch_in_outbuf(). Note that this is where the actual +! "quilting" (reassembly of patches onto a full-size domain) is done. If +! okay_to_write(DataHandle) is .false. then external I/O package interfaces +! are called to write metadata for I/O formats that support native metadata. +! +! NOTE that the I/O server "root" will only see write_field (int_field) +! requests AFTER an "iosync" request. + CASE ( int_field ) + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + CALL int_get_write_field_header ( bigbuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) +!write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle) + icurs = icurs + hdrbufsize + + IF ( okay_to_write(DataHandle) ) THEN + +! WRITE(0,*)'>>> ',TRIM(DateStr), ' ', TRIM(VarName), ' ', TRIM(MemoryOrder), ' ', & +! (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)*(PatchEnd(3)-PatchStart(3)+1) + + IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN + ! Note that the WRF_DOUBLE branch of this IF statement must come first since + ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds. + IF ( FieldType .EQ. WRF_DOUBLE) THEN +! this branch has not been tested TBH: 20050406 + CALL mpi_type_size( MPI_DOUBLE_PRECISION, ftypesize, ierr ) + ELSE + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ENDIF + stored_write_record = .true. + CALL store_patch_in_outbuf ( bigbuf(icurs/itypesize), dummybuf, TRIM(DateStr), TRIM(VarName) , & + FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + stored_write_record = .true. + CALL store_patch_in_outbuf ( dummybuf, bigbuf(icurs/itypesize), TRIM(DateStr), TRIM(VarName) , & + FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + ftypesize = LWORDSIZE + ENDIF + icurs = icurs + (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + ELSE + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_write_field ( handle(DataHandle) , TRIM(DateStr) , & + TRIM(VarName) , dummy , FieldType , Comm , IOComm, & + DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ENDIF + CASE ( int_iosync ) + CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + CASE DEFAULT + WRITE(mess,*)' quilt: int_field: bad tag: ',get_hdr_tag( bigbuf(icurs/itypesize) ),' icurs ',icurs/itypesize + CALL wrf_error_fatal( mess ) + END SELECT + + ENDDO !} +! Now, the I/O server "root" has finshed handling all commands from the latest +! call to retrieve_pieces_of_field(). + + IF (stored_write_record) THEN +! If any fields have been stored in a globally-sized internal output buffer +! (via a call to store_patch_in_outbuf()) then call write_outbuf() to write +! them to disk now. +! NOTE that the I/O server "root" will only have called +! store_patch_in_outbuf() when handling write_field (int_field) +! commands which only arrive AFTER an "iosync" command. +! CALL start_timing + CALL write_outbuf ( handle(DataHandle), use_package(io_form(DataHandle))) +! CALL end_timing( "quilt: call to write_outbuf" ) + ENDIF + +! If one or more "open_for_write_commit" commands were encountered from the +! latest call to retrieve_pieces_of_field() then call the package-specific +! routine to do the commit. + IF (okay_to_commit(DataHandle)) THEN + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_ncd_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_int_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_yyy_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr1_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr2_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif + + CASE DEFAULT + Status = 0 + END SELECT + + okay_to_commit(DataHandle) = .false. + ENDIF + DEALLOCATE( bigbuf ) + ENDIF +#endif + if(allocated(bigbuf)) deallocate(bigbuf) +! Retrieve header and all patches for the next field from the internal +! buffers. + CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) +! Sum sizes of all headers and patches (data) for this field from all I/O +! servers in this I/O server group onto the I/O server "root". + CALL mpi_x_reduce( sz, bigbufsize, 1, MPI_INTEGER,MPI_SUM, ntasks_local_group-1,mpi_comm_local, ierr ) +! Then, return to the top of the loop to collect headers and data from all +! I/O servers in this I/O server group onto the I/O server "root" and handle +! the next batch of commands. + END DO !} + + DEALLOCATE( obuf ) + + ! flush output files if needed + IF (stored_write_record) THEN +! CALL start_timing() + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_iosync( handle(DataHandle), Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_iosync( handle(DataHandle), Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_iosync( handle(DataHandle), Status ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_iosync( handle(DataHandle), Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_iosync( handle(DataHandle), Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_iosync( handle(DataHandle), Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_iosync( handle(DataHandle), Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT +!CALL end_timing( "quilt: flush" ) + ENDIF + + END DO ! } + + END SUBROUTINE quilt + + SUBROUTINE quilt_pnc +! +! Same as quilt() routine except that _all_ of the IO servers that call it +! actually write data to disk using pNetCDF. This version is only used when +! the code is compiled with PNETCDF_QUILT defined. +! + USE module_state_description + USE module_quilt_outbuf_ops + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" +#include "wrf_io_flags.h" + INTEGER itag, ninbuf, ntasks_io_group, ntasks_local_group, mytask_local, ierr + INTEGER istat + INTEGER mytask_io_group + INTEGER :: nout_set = 0 + INTEGER :: obufsize, bigbufsize, chunksize, sz + REAL, DIMENSION(1) :: dummy + INTEGER, ALLOCATABLE, DIMENSION(:) :: obuf, bigbuf + REAL, ALLOCATABLE, DIMENSION(:) :: RDATA + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA + CHARACTER (LEN=512) :: CDATA + CHARACTER (LEN=80) :: fname + INTEGER icurs, hdrbufsize, itypesize, ftypesize, rtypesize, Status, fstat, io_form_arg + INTEGER :: DataHandle, FieldType, Comm, IOComm, DomainDesc, code, Count + INTEGER, DIMENSION(3) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd + INTEGER :: dummybuf(1) + INTEGER :: num_noops, num_commit_messages, num_field_training_msgs, hdr_tag + CHARACTER (len=256) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess + INTEGER, EXTERNAL :: use_package + LOGICAL :: stored_write_record, retval, written_record + INTEGER iii, jjj, vid + +! logical okay_to_w +! character*120 sysline + +! Call ext_pkg_ioinit() routines to initialize I/O packages. + SysDepInfo = " " +#ifdef NETCDF + CALL ext_ncd_ioinit( SysDepInfo, ierr) +#endif +#ifdef PNETCDF_QUILT + CALL ext_pnc_ioinit( SysDepInfo, ierr) +#endif +#ifdef INTIO + CALL ext_int_ioinit( SysDepInfo, ierr ) +#endif +#ifdef XXX + CALL ext_xxx_ioinit( SysDepInfo, ierr) +#endif +#ifdef YYY + CALL ext_yyy_ioinit( SysDepInfo, ierr) +#endif +#ifdef ZZZ + CALL ext_zzz_ioinit( SysDepInfo, ierr) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioinit( SysDepInfo, ierr) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioinit( SysDepInfo, ierr) +#endif + + okay_to_commit = .false. + stored_write_record = .false. + ninbuf = 0 + ! get info. about the I/O server group that this I/O server task + ! belongs to + CALL mpi_x_comm_size( mpi_comm_io_groups(1,1), ntasks_io_group, ierr ) + CALL MPI_COMM_RANK( mpi_comm_io_groups(1,1), mytask_io_group, ierr ) + CALL mpi_x_comm_size( mpi_comm_local, ntasks_local_group, ierr ) + CALL MPI_COMM_RANK( mpi_comm_local, mytask_local, ierr ) + + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + IF ( itypesize <= 0 ) THEN + CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid") + ENDIF + +! Work out whether this i/o server processor has one fewer associated compute proc than +! the most any processor has. Can happen when number of i/o tasks does not evenly divide +! the number of compute tasks. This is needed to keep the i/o tasks sychronized on the +! same message when they start commmunicating to stitch together an output. +! + +! infinite loop until shutdown message received +! This is the main request-handling loop. I/O quilt servers stay in this loop +! until the model run ends. +!okay_to_w = .false. + DO WHILE (.TRUE.) ! { + +! +! Each I/O server receives requests from its compute tasks. Each request +! is contained in a data header (see module_internal_header_util.F for +! detailed descriptions of data headers). +! Each request is sent in two phases. First, sizes of all messages that +! will be sent from the compute tasks to this I/O server are summed on the +! I/O server via MPI_reduce(). The I/O server then allocates buffer "obuf" +! and receives concatenated messages from the compute tasks in it via the +! call to collect_on_comm(). Note that "sizes" are generally expressed in +! *bytes* in this code so conversion to "count" (number of Fortran words) is +! required for Fortran indexing and MPI calls. +! + ! wait for info from compute tasks in the I/O group that we're ready to rock + ! obufsize will contain number of *bytes* +!CALL start_timing + ! first element of reduced is obufsize, second is DataHandle + ! if needed (currently needed only for ioclose). + reduced_dummy = 0 + CALL mpi_x_reduce( reduced_dummy, reduced, 2, MPI_INTEGER, MPI_SUM, mytask_io_group, mpi_comm_io_groups(1,1), ierr ) + obufsize = reduced(1) +!CALL end_timing("MPI_Reduce at top of forever loop") +!JMDEBUGwrite(0,*)'obufsize = ',obufsize +! Negative obufsize will trigger I/O server exit. + IF ( obufsize .LT. 0 ) THEN + IF ( obufsize .EQ. -100 ) THEN ! magic number +#ifdef NETCDF + CALL ext_ncd_ioexit( Status ) +#endif +#ifdef PNETCDF_QUILT + CALL ext_pnc_ioexit( Status ) +#endif +#ifdef INTIO + CALL ext_int_ioexit( Status ) +#endif +#ifdef XXX + CALL ext_xxx_ioexit( Status ) +#endif +#ifdef YYY + CALL ext_yyy_ioexit( Status ) +#endif +#ifdef ZZZ + CALL ext_zzz_ioexit( Status ) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioexit( Status ) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioexit( Status ) +#endif + CALL wrf_message ( 'I/O QUILT SERVERS DONE' ) +#if ( DA_CORE != 1 ) + IF (coupler_on) THEN + CALL cpl_finalize() + ELSE +#endif + CALL mpi_finalize(ierr) +#if ( DA_CORE != 1 ) + END IF +#endif + STOP + ELSE + WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.' + CALL wrf_error_fatal(mess) + ENDIF + ENDIF + +! CALL start_timing +! Obufsize of zero signals a close + +! Allocate buffer obuf to be big enough for the data the compute tasks +! will send. Note: obuf is size in *bytes* so we need to pare this +! down, since the buffer is INTEGER. + IF ( obufsize .GT. 0 ) THEN + ALLOCATE( obuf( (obufsize+1)/itypesize ) ) + +! let's roll; get the data from the compute procs and put in obuf + CALL collect_on_comm_debug(__FILE__,__LINE__, mpi_comm_io_groups(1,1), & + onebyte, & + dummy, 0, & + obuf, obufsize ) +! CALL end_timing( "quilt on server: collecting data from compute procs" ) + ELSE + ! Necessarily, the compute processes send the ioclose signal, + ! if there is one, after the iosync, which means they + ! will stall on the ioclose message waiting for the quilt + ! processes if we handle the way other messages are collected, + ! using collect_on_comm. This avoids this, but we need + ! a special signal (obufsize zero) and the DataHandle + ! to be closed. That handle is send as the second + ! word of the io_close message received by the MPI_Reduce above. + ! Then a header representing the ioclose message is constructed + ! here and handled below as if it were received from the + ! compute processes. The clients (compute processes) must be + ! careful to send this correctly (one compule process sends the actual + ! handle and everone else sends a zero, so the result sums to + ! the value of the handle). + ! + ALLOCATE( obuf( 4096 ) ) + ! DataHandle is provided as second element of reduced + CALL int_gen_handle_header( obuf, obufsize, itypesize, & + reduced(2) , int_ioclose ) + ENDIF + +!write(0,*)'calling init_store_piece_of_field' +! Now all messages received from the compute clients are stored in +! obuf. Scan through obuf and extract headers and field data and store in +! internal buffers. The scan is done twice, first to determine sizes of +! internal buffers required for storage of headers and fields and second to +! actually store the headers and fields. This bit of code does not do any +! "quilting" (assembly of patches into full domains). For each field, it +! simply writes all received patches for the field to disk. +! ARPDBG we can vastly reduce the number of writes to disk by stitching +! any contiguous patches together first. Has implications for synchronisation +! of pNetCDF calls though. + CALL init_store_piece_of_field + CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr ) +!write(0,*)'mpi_type_size returns ', itypesize +! Scan obuf the first time to calculate the size of the buffer required for +! each field. Calls to add_to_bufsize_for_field() accumulate sizes. + vid = 0 + icurs = itypesize + num_noops = 0 + num_commit_messages = 0 + num_field_training_msgs = 0 + DO WHILE ( icurs .lt. obufsize ) ! { + hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) + SELECT CASE ( hdr_tag ) + CASE ( int_field ) + CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + + IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks + IF ( num_field_training_msgs .EQ. 0 ) THEN + call add_to_bufsize_for_field( VarName, hdrbufsize ) +!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + num_field_training_msgs = num_field_training_msgs + 1 + ELSE + call add_to_bufsize_for_field( VarName, hdrbufsize ) +!write(0,*) 'X-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + icurs = icurs + hdrbufsize + +!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + + ! If this is a real write (i.e. not a training write), accumulate + ! buffersize for this field. + IF ( DomainDesc .NE. 333933 ) THEN ! magic number +!write(0,*) 'X-1a', chunksize, TRIM(VarName) + call add_to_bufsize_for_field( VarName, chunksize ) + icurs = icurs + chunksize + ENDIF + CASE ( int_open_for_write_commit ) ! only one per group of tasks + hdrbufsize = obuf(icurs/itypesize) + IF (num_commit_messages.EQ.0) THEN + call add_to_bufsize_for_field( 'COMMIT', hdrbufsize ) + ENDIF + num_commit_messages = num_commit_messages + 1 + icurs = icurs + hdrbufsize + CASE DEFAULT + hdrbufsize = obuf(icurs/itypesize) + +! This logic and the logic in the loop below is used to determine whether +! to send a noop records sent by the compute processes to allow to go +! through. The purpose is to make sure that the communications between this +! server and the other servers in this quilt group stay synchronized in +! the collection loop below, even when the servers are serving different +! numbers of clients. Here are some conditions: +! +! 1. The number of compute clients served will not differ by more than 1 +! 2. The servers with +1 number of compute clients begin with task 0 +! of mpi_comm_local, the commicator shared by this group of servers +! +! 3. For each collective field or metadata output from the compute tasks, +! there will be one record sent to the associated i/o server task. The +! i/o server task collects these records and stores them contiguously +! in a buffer (obuf) using collect_on_comm above. Thus, obuf on this +! server task will contain one record from each associated compute +! task, in order. +! ! +! 4. In the case of replicated output from the compute tasks +! (e.g. put_dom_ti records and control records like +! open_for_write_commit type records), only compute tasks for which +! (compute_group_master == .TRUE) send the record. The other compute +! tasks send noop records. This is done so that each server task +! receives exactly one record plus noops from the other compute tasks. +! +! 5. Logic below does not allow any noop records through since each IO +! server task now receives a valid record (from the 'compute-group master' +! when doing replicated output + IF (hdr_tag.NE.int_noop) THEN + write(VarName,'(I5.5)')vid +!write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + call add_to_bufsize_for_field( VarName, hdrbufsize ) + vid = vid+1 + ENDIF + IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + icurs = icurs + hdrbufsize + + END SELECT + ENDDO ! } +! Store the headers and field data in internal buffers. The first call to +! store_piece_of_field() allocates internal buffers using sizes computed by +! calls to add_to_bufsize_for_field(). + vid = 0 + icurs = itypesize + num_noops = 0 + num_commit_messages = 0 + num_field_training_msgs = 0 + DO WHILE ( icurs .lt. obufsize ) !{ +!write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize + hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) + SELECT CASE ( hdr_tag ) + CASE ( int_field ) + CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + + IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks + IF ( num_field_training_msgs .EQ. 0 ) THEN + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) +!write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + num_field_training_msgs = num_field_training_msgs + 1 + ELSE + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) +!write(0,*) 'A-2a', icurs, hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + icurs = icurs + hdrbufsize + ! If this is a real write (i.e. not a training write), store + ! this piece of this field. + IF ( DomainDesc .NE. 333933 ) THEN ! magic number + call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize ) + icurs = icurs + chunksize +!write(0,*) 'A-1a',TRIM(VarName),' icurs ',icurs,PatchStart(1:3),PatchEnd(1:3) + ENDIF + CASE ( int_open_for_write_commit ) ! only one per group of tasks + hdrbufsize = obuf(icurs/itypesize) + IF (num_commit_messages.EQ.0) THEN + call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize ) + ENDIF + num_commit_messages = num_commit_messages + 1 + icurs = icurs + hdrbufsize + CASE DEFAULT + hdrbufsize = obuf(icurs/itypesize) + IF (hdr_tag.NE.int_noop) THEN + + write(VarName,'(I5.5)')vid +!write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) + vid = vid+1 + ENDIF + IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + icurs = icurs + hdrbufsize + END SELECT + ENDDO !} while(icurs < obufsize) + +! Now, for each field, retrieve headers and patches (data) from the internal +! buffers + CALL init_retrieve_pieces_of_field +! Retrieve header and all patches for the first field from the internal +! buffers. + CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) + written_record = .false. + +! Loop until there are no more fields to retrieve from the internal buffers. + DO WHILE ( retval ) !{ + +! This I/O server now handles the collected requests from the compute +! tasks it serves + + icurs = itypesize ! icurs is a byte counter, but buffer is integer + + stored_write_record = .false. + +! ALL I/O servers in this group loop over the collected requests they have +! received. + DO WHILE ( icurs .lt. sz)! bigbufsize ) !{ + +! The I/O server gets the request out of the next header and +! handles it by, in most cases, calling the appropriate external I/O package +! interface. + SELECT CASE ( get_hdr_tag( obuf(icurs/itypesize) ) ) +! The I/O server handles the "noop" (do nothing) request. This is +! actually quite easy. "Noop" requests exist to help avoid race conditions. + CASE ( int_noop ) + CALL int_get_noop_header( obuf(icurs/itypesize), & + hdrbufsize, itypesize ) + icurs = icurs + hdrbufsize + +! The I/O server "root" handles the "put_dom_td_real" request. + CASE ( int_dom_td_real ) + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_td_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, DateStr, Element, RData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( RData ) +! Every I/O server handles the "put_dom_ti_real" request. + CASE ( int_dom_ti_real ) + + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_ti_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, Element, RData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( RData ) + +! Every I/O server handles the "put_dom_td_integer" request. + CASE ( int_dom_td_integer ) + + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_td_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, DateStr, Element, IData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( IData ) + +! Every I/O server handles the "put_dom_ti_integer" request. + CASE ( int_dom_ti_integer ) + + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_ti_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, Element, IData, Count, code ) + icurs = icurs + hdrbufsize + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif + + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( IData) + +! Every I/O server handles the "set_time" request. + CASE ( int_set_time ) + + CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_set_time ( handle(DataHandle), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + +! Every I/O server handles the "put_dom_ti_char" request. + CASE ( int_dom_ti_char ) + + CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_dom_ti_char ( handle(DataHandle), TRIM(Element), Trim(CData), Status) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + +! Every I/O server handles the "put_var_ti_char" request. + CASE ( int_var_ti_char ) + + CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + + CASE ( int_ioexit ) +! ioexit is now handled by sending negative message length to server + CALL wrf_error_fatal( & + "quilt: should have handled int_ioexit already") +! Every I/O server handles the "ioclose" request. + CASE ( int_ioclose ) + CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + + IF ( DataHandle .GE. 1 ) THEN + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE ( IO_PNETCDF ) + CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_pnc_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_ncd_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_int_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_yyy_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr1_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr2_ioclose(handle(DataHandle),Status) + ENDIF +#endif + CASE DEFAULT + Status = 0 + END SELECT + ENDIF + +! Every I/O server handles the "open_for_write_begin" request. + CASE ( int_open_for_write_begin ) + + CALL int_get_ofwb_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & + FileName,SysDepInfo,io_form_arg,DataHandle ) + +!write(0,*)' int_open_for_write_begin itypesize ',itypesize,' itypesize ',itypesize +!write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize +!JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle +!write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo) + icurs = icurs + hdrbufsize +!write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) + + io_form(DataHandle) = io_form_arg + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_open_for_write_begin(FileName,mpi_comm_local,mpi_comm_local,SysDepInfo,handle(DataHandle),Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +!write(0,*)'ext_ncd_open_for_write_begin ',Trim(FileName),DataHandle,handle(DataHandle),Status +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + okay_to_write(DataHandle) = .false. + +! Every I/O server handles the "open_for_write_commit" request. +! In this case, the "okay_to_commit" is simply set to .true. so "write_field" +! (int_field) requests will initiate writes to disk. Actual commit will be done after +! all requests in this batch have been handled. + CASE ( int_open_for_write_commit ) + + CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + okay_to_commit(DataHandle) = .true. + +! Every I/O server handles the "write_field" (int_field) request. +! If okay_to_write(DataHandle) is .true. then the patch in the +! header (bigbuf) is written to disk using pNetCDF. Note that this is where the actual +! "quilting" (reassembly of patches onto a full-size domain) is done. If +! okay_to_write(DataHandle) is .false. then external I/O package interfaces +! are called to write metadata for I/O formats that support native metadata. +! +! NOTE that the I/O servers will only see write_field (int_field) +! requests AFTER an "iosync" request. + CASE ( int_field ) + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) +!write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle) + icurs = icurs + hdrbufsize + + IF ( okay_to_write(DataHandle) ) THEN + +!!$ WRITE(0,FMT="('>>> ',(A),1x,(A),1x,A2,I6,1x,3('[',I3,',',I3,'] '))") & +!!$ TRIM(DateStr), TRIM(VarName), TRIM(MemoryOrder), & +!!$ (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)*(PatchEnd(3)-PatchStart(3)+1), & +!!$PatchStart(1),PatchEnd(1),PatchStart(2),PatchEnd(2),PatchStart(3),PatchEnd(3) +!!$ WRITE(0,FMT="('>>> ',(A),1x,(A),1x,I6,1x,3('[',I3,',',I3,'] '))") & +!!$ TRIM(DateStr), TRIM(VarName), DomainDesc, & +!!$ DomainStart(1),DomainEnd(1),DomainStart(2),DomainEnd(2),DomainStart(3),DomainEnd(3) + + IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN + ! Note that the WRF_DOUBLE branch of this IF statement must come first since + ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds. + IF ( FieldType .EQ. WRF_DOUBLE) THEN +! this branch has not been tested TBH: 20050406 + CALL mpi_type_size( MPI_DOUBLE_PRECISION, ftypesize, ierr ) + ELSE + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ENDIF + +#ifdef PNETCDF_QUILT +! WRITE(mess,FMT="('>>> ',(A),1x,(A),1x,I6,1x,3('[',I3,',',I3,'] '))") & +! TRIM(DateStr), TRIM(VarName), DomainDesc, & +! DomainStart(1),DomainEnd(1), & +! DomainStart(2),DomainEnd(2),DomainStart(3),DomainEnd(3) +! CALL wrf_message(mess) + + CALL store_patch_in_outbuf_pnc(obuf(icurs/itypesize), & + dummybuf, TRIM(DateStr), & + TRIM(VarName) , & + FieldType, & + TRIM(MemoryOrder), & + TRIM(Stagger), & + DimNames, & + DomainStart , DomainEnd ,& + MemoryStart , MemoryEnd ,& + PatchStart , PatchEnd, & + ntasks_io_group-1 ) + stored_write_record = .true. + +!!$ IF(VarName .eq. "PSFC")THEN +!!$ CALL dump_real_array_c(obuf(icurs/itypesize), DomainStart,& +!!$ DomainEnd, PatchStart, PatchEnd, & +!!$ mytask_local, DomainDesc) +!!$ ENDIF + +#endif + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) +#ifdef PNETCDF_QUILT + CALL store_patch_in_outbuf_pnc ( dummybuf, & + obuf(icurs/itypesize) , & + TRIM(DateStr) , & + TRIM(VarName) , & + FieldType, & + TRIM(MemoryOrder) , & + TRIM(Stagger), DimNames, & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + ntasks_io_group-1 ) + stored_write_record = .true. +#endif + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + ftypesize = LWORDSIZE + ENDIF + + icurs = icurs + (PatchEnd(1)-PatchStart(1)+1)* & + (PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + + ELSE ! Write metadata only (or do 'training'?) + + SELECT CASE (use_package(io_form(DataHandle))) + +#ifdef PNETCDF_QUILT + CASE ( IO_PNETCDF ) + CALL ext_pnc_write_field ( handle(DataHandle) , TRIM(DateStr), & + TRIM(VarName) , dummy , FieldType , mpi_comm_local , mpi_comm_local, & + DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger), DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd, & + Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_write_field ( handle(DataHandle) , TRIM(DateStr) , & + TRIM(VarName) , dummy , FieldType , Comm , IOComm, & + DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + ENDIF + CASE ( int_iosync ) + CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + CASE DEFAULT + WRITE(mess,*)__LINE__,' quilt: io_sync: bad tag: ', & + get_hdr_tag( obuf(icurs/itypesize) ),' icurs ',& + icurs/itypesize + CALL wrf_error_fatal( mess ) + END SELECT + + ENDDO !} +! Now, we have finshed handling all commands from the latest +! call to retrieve_pieces_of_field(). + + IF (stored_write_record) THEN +! If any field patches have been stored in internal output buffers +! (via a call to store_patch_in_outbuf_pnc()) then call write_outbuf_pnc() +! to write them to disk now. +! NOTE that the I/O server will only have called +! store_patch_in_outbuf() when handling write_field (int_field) +! commands which only arrive AFTER an "iosync" command. +! CALL start_timing +#ifdef PNETCDF_QUILT + CALL write_outbuf_pnc( handle(DataHandle), & + use_package(io_form(DataHandle)), & + mpi_comm_local, mytask_local, & + ntasks_local_group) +#endif +! CALL end_timing( "quilt_pnc: call to write_outbuf_pnc" ) + stored_write_record = .false. + written_record = .true. + ENDIF + +! If one or more "open_for_write_commit" commands were encountered from the +! latest call to retrieve_pieces_of_field() then call the package-specific +! routine to do the commit. + IF (okay_to_commit(DataHandle)) THEN + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE ( IO_PNETCDF ) + CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_pnc_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_ncd_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_int_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_yyy_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr1_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr2_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif + + CASE DEFAULT + Status = 0 + END SELECT + + okay_to_commit(DataHandle) = .false. + ENDIF +!!endif + +! Retrieve header and all patches for the next field from the internal +! buffers. + CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) + END DO !} + + DEALLOCATE( obuf ) + + ! flush output files if needed + IF (written_record) THEN +!CALL start_timing + SELECT CASE ( use_package(io_form) ) +#ifdef PNETCDF_QUILT + CASE ( IO_PNETCDF ) + CALL ext_pnc_iosync( handle(DataHandle), Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + written_record = .false. +!CALL end_timing( "quilt_pnc: flush" ) + ENDIF + + END DO ! } + + END SUBROUTINE quilt_pnc + +! end of #endif of DM_PARALLEL +#endif + + SUBROUTINE init_module_wrf_quilt + USE module_wrf_error, only: init_module_wrf_error + USE module_driver_constants + USE module_dm, ONLY : compute_mesh,nest_pes_x, nest_pes_y, domain_active_this_task +! +! Both client (compute) and server tasks call this routine to initialize the +! module. Routine setup_quilt_servers() is called from this routine to +! determine which tasks are compute tasks and which are server tasks. Server +! tasks then call routine quilt() and remain there for the rest of the model +! run. Compute tasks return from init_module_wrf_quilt() to perform model +! computations. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_dm, ONLY : compute_mesh,nest_pes_x,nest_pes_y,domain_active_this_task,& + tasks_per_split,comm_start,dm_task_split + IMPLICIT NONE + INCLUDE 'mpif.h' + INTEGER i,j + NAMELIST /namelist_quilt/ nio_tasks_per_group, nio_groups, poll_servers + INTEGER ntasks, mytask, ierr, io_status, id, itask +# if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT) + INTEGER thread_support_provided, thread_support_requested +#endif + INTEGER num_io_tasks, ncompute_tasks + INTEGER n_x, n_y + INTEGER mpi_comm_here, temp_poll, comdup + INTEGER, ALLOCATABLE :: icolor(:) + LOGICAL mpi_inited + LOGICAL compute_node + LOGICAL esmf_coupling + CHARACTER*256 message + +!!!!! needed to sneak-peek the namelist to get parent_id +! define as temporaries +#include "namelist_defines.inc" + +! Statements that specify the namelists +#include "namelist_statements.inc" + +!TODO: Change this to run-time switch +#ifdef ESMFIO + esmf_coupling = .TRUE. +#else + esmf_coupling = .FALSE. +#endif + quilting_enabled = .FALSE. + IF ( disable_quilt ) RETURN + + DO i = 1,int_num_handles + okay_to_write(i) = .FALSE. + int_handle_in_use(i) = .FALSE. + which_grid_is_handle(i) = -1 + prev_server_for_handle(i) = -1 + int_num_bytes_to_write(i) = 0 + ENDDO + DO j = 1, max_domains + DO i = 1,int_num_handles + server_for_handle(i,j) = 0 + ENDDO + ENDDO + + CALL MPI_INITIALIZED( mpi_inited, ierr ) + IF ( .NOT. mpi_inited ) THEN +# if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT) + thread_support_requested = MPI_THREAD_FUNNELED + CALL mpi_init_thread ( thread_support_requested, thread_support_provided, ierr ) + IF ( thread_support_provided .lt. thread_support_requested ) THEN + CALL WRF_ERROR_FATAL( "failed to initialize MPI thread support") + ENDIF +# else + CALL mpi_init ( ierr ) +# endif + CALL wrf_set_dm_communicator( MPI_COMM_WORLD ) + CALL wrf_termio_dup(MPI_COMM_WORLD) + ENDIF + CALL wrf_get_dm_communicator( mpi_comm_here ) ! get global communicator + + CALL MPI_Comm_rank ( mpi_comm_here, mytask, ierr ) ; + CALL MPI_Comm_size ( mpi_comm_here, ntasks, ierr ) ; + + IF ( mytask .EQ. 0 ) THEN + OPEN ( unit=27, file="namelist.input", form="formatted", status="old" ) + tasks_per_split = ntasks +! comm_domain = -1 ! by default, domain is always on communicator 1 +! comm_domain(1) = 1 ! by default, domain is always on communicator 1 + READ ( UNIT = 27 , NML = domains , IOSTAT=io_status ) + REWIND(27) + nio_groups = 1 + nio_tasks_per_group = 0 + poll_servers = .false. + READ ( 27 , NML = namelist_quilt, IOSTAT=io_status ) + IF (io_status .NE. 0) THEN + CALL wrf_error_fatal( "ERROR reading namelist namelist_quilt" ) + ENDIF + REWIND(27) + nproc_x = -1 + nproc_y = -1 + READ ( UNIT = 27 , NML = domains , IOSTAT=io_status ) + IF (io_status .NE. 0) THEN + CALL wrf_error_fatal( "ERROR reading namelist domains" ) + ENDIF + CLOSE ( 27 ) + IF ( esmf_coupling ) THEN + IF ( any ( nio_tasks_per_group > 0 ) ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: cannot use "// & + "ESMF coupling with quilt tasks") ; + ENDIF + ENDIF + if(poll_servers) then + temp_poll=1 + else + temp_poll=0 + endif + ENDIF + CALL mpi_bcast( parent_id, max_domains , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( max_dom, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL nl_set_max_dom(1,max_dom) + CALL mpi_bcast( nio_tasks_per_group , max_domains , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nio_groups , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( temp_poll , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nproc_x , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nproc_y , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + +! check to make sure that if nio_tasks_per_group is non-zero for any domain it has to be non-zero for all of them + i = MAXVAL(nio_tasks_per_group(1:max_dom)) + IF ( i .GT. 0 .AND. nio_groups .GT. 0 ) THEN + DO id = 1, max_dom + IF ( nio_tasks_per_group(id) .LE. 0 ) THEN + CALL wrf_error_fatal( & +'If nio_tasks_per_group in namelist.input is non-zero for any domain, every active domain must have a non-zero value in nio_tasks_per_group') + ENDIF + ENDDO + ENDIF + + num_io_tasks = 0 + DO id = 1, max_dom + num_io_tasks = num_io_tasks + nio_tasks_per_group(id)*nio_groups + ENDDO + IF ( ntasks-num_io_tasks .LE. 0 ) THEN + WRITE(message,*)'Initing quilting: not enough compute tasks left over after allocating ',num_io_tasks,' i/o servers' + CALL wrf_error_fatal( TRIM(message) ) + ENDIF + IF ( mytask .EQ. 0 ) THEN + OPEN ( unit=27, file="namelist.input", form="formatted", status="old" ) + comm_start = -1 ! use this to find how many communicators have actually been defined + nest_pes_x = 0 ! dimensions of communicator in X and y + nest_pes_y = 0 + IF ( nproc_x .NE. -1 .AND. nproc_y .NE. -1 ) THEN + n_x=nproc_x + n_y=nproc_y + ELSE + CALL compute_mesh( ntasks-num_io_tasks, n_x, n_y ) + ENDIF + comm_start = 0 ! make it so everyone will use same communicator if the dm_task_split namelist is not specified or is empty + nest_pes_x(1:max_dom) = n_x + nest_pes_y(1:max_dom) = n_y + READ ( 27 , NML = dm_task_split, IOSTAT=io_status ) +! we need to sneak-peek the parent_id namelist setting, ,which is in the "domains" section +! of the namelist. That namelist is registry generated, so the registry-generated information +! is #included above. + CLOSE ( 27 ) + ENDIF +!debug write(0,*)'before mpi_bcast' + CALL mpi_bcast( io_status, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) +!debug write(0,*)'after mpi_bcast',io_status + IF ( io_status .NE. 0 ) THEN + ENDIF + CALL mpi_bcast( tasks_per_split, 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( comm_start, max_domains , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nest_pes_x, max_domains , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nest_pes_y, max_domains , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + + CALL MPI_Comm_rank ( mpi_comm_here, mytask, ierr ) ; + CALL mpi_x_comm_size( mpi_comm_here, ntasks, ierr ) ; + + +!!!!! end of needed to sneak-peek the namelist + +! set up the arrays associating quilt tasks to domains and check to make sure it will work +! role_for_task( maxprocs ) = 0 if compute, otherwise id of grid for which's it's a server + ALLOCATE(role_for_task(ntasks)) + ! count up the number of I/O tasks needed, each domain has its own set + ncompute_tasks = 0 + DO id = 1, max_dom + IF ( ncompute_tasks < comm_start(id)+nest_pes_x(id)*nest_pes_y(id) ) THEN + ncompute_tasks = comm_start(id)+nest_pes_x(id)*nest_pes_y(id) + ENDIF + ENDDO + num_io_tasks = 0 + DO id = 1, max_dom + num_io_tasks = num_io_tasks + nio_tasks_per_group(id)*nio_groups + ENDDO +!jm IF ( ncompute_tasks + num_io_tasks .NE. ntasks ) THEN +!jm WRITE(message,"('ncompute_tasks(',i9,')+num_io_tasks(',i9,') .NE. ntasks(',i9,')')")ncompute_tasks,num_io_tasks,ntasks + IF ( ncompute_tasks + num_io_tasks .GT. ntasks ) THEN + WRITE(message,"('ncompute_tasks(',i9,')+num_io_tasks(',i9,') .GT. ntasks(',i9,')')")ncompute_tasks,num_io_tasks,ntasks + CALL wrf_error_fatal(TRIM(message)) + ENDIF + DO itask = 1, ncompute_tasks + role_for_task(itask) = 0 + ENDDO + itask = ncompute_tasks + 1 + DO id = 1, max_dom + DO i = 1, nio_tasks_per_group(id)*nio_groups + role_for_task(itask) = id ! mark as a server + itask = itask + 1 + ENDDO + ENDDO + ntasks = itask - 1 +! end set up of role_for_task array + + poll_servers = (temp_poll == 1) + + compute_group_master = .FALSE. + compute_node = .FALSE. + +DO id = 1, max_dom + +! when this returns, mpi_comm_local will be set for server tasks +! and compute tasks but these may be reset by split communicator +! mpi_comm_io_groups will be set for the grid id +! ntasks will be the number of tasks described in role_for_task +! mpi_comm_here will be passed in as all the tasks described in role_for_task + + CALL setup_quilt_servers( id, nio_tasks_per_group, & + role_for_task, & ! this is the "color" array used to split coms + num_io_tasks, & + ncompute_tasks, & + mytask, & + ntasks, & + nio_groups, & + mpi_comm_here, & + mpi_comm_local, & ! only important on i/o servers + mpi_comm_io_groups, & + compute_node ) + +ENDDO + + call init_module_wrf_error(on_io_server=.true.) + + CALL MPI_Comm_dup( mpi_comm_here, comdup, ierr ) + ! throw away the I/O server tasks; mpi_comm_local will now be only all the compute tasks for all domains + CALL MPI_Comm_split(comdup,role_for_task(mytask+1),mytask,mpi_comm_local, ierr ) + + + CALL wrf_set_dm_communicator( mpi_comm_local ) ! split_communicators will see this +! compute node should be true for any compute node and false for every server node + IF ( compute_node ) THEN +#if ( DA_CORE != 1 ) + IF (coupler_on) CALL cpl_set_dm_communicator( mpi_comm_local ) +#endif +#if ( HWRF == 1 ) + call ATM_SET_COMM(mpi_comm_local) +#endif + ELSE +#if ( HWRF == 1 ) + call ATM_LEAVE_COUPLING() +#endif +#if ( DA_CORE != 1 ) + IF (coupler_on) CALL cpl_set_dm_communicator( MPI_COMM_NULL ) +#endif + mpi_comm_local = mpi_comm_local_io_server_tmp + CALL quilt ! will not return on io server tasks + ENDIF +#endif + + RETURN + END SUBROUTINE init_module_wrf_quilt + + +#ifdef IBM_REDUCE_BUG_WORKAROUND + + ! These three subroutines re-implement MPI_Reduce on MPI_INTEGER + ! with OP=MPI_ADD. + + ! This is a workaround for a bug in the IBM MPI implementation. + ! Some MPI processes will get stuck in MPI_Reduce and not + ! return until the PREVIOUS I/O server group finishes writing. + + ! This workaround replaces the MPI_Reduce call with many + ! MPI_Send and MPI_Recv calls that perform the sum on the + ! root of the communicator. + + ! There are two reduce routines: one for a sum of scalars + ! and one for a sum of arrays. The get_reduce_tag generates + ! MPI tags for the communication. + + integer function get_reduce_tag(root,comm) + implicit none + include 'mpif.h' + integer, intent(in) :: comm,root + integer :: i,j, tag, here + integer :: ierr,me,size + + integer, pointer :: nexttags(:) + integer, target :: dummy(1) + character(255) :: message + integer(kind=4) :: comm4,hashed + + integer, parameter :: hashsize = 113 ! should be prime, >max_servers+1 + integer, parameter :: tagloop = 100000 ! number of tags reserved per communicator + integer, parameter :: origin = 1031102 ! lowest tag number we'll use + integer, save :: nexttag=origin ! next tag to use for a new communicator + integer, save :: comms(hashsize)=-1, firsttag(hashsize)=0, curtag(hashsize)=0 + + ! If integers are not four bytes, this implementation will still + ! work, but it may be inefficient (O(N) lookup instead of O(1)). + ! To fix that, an eight byte hash function would be needed, but + ! integers are four bytes in WRF, so that is not a problem right + ! now. + + comm4=comm + call int_hash(comm4,hashed) + hashed=mod(abs(hashed),hashsize)+1 + if(hashed<0) call wrf_error_fatal('hashed<0') + + do i=0,hashsize-1 + j=1+mod(i+hashed-1,hashsize) + + if(firsttag(j)/=0 .and. comms(j)==comm) then + ! Found the communicator + if(curtag(j)-firsttag(j) >= tagloop) then + ! Hit the max tag number so we need to reset. + ! To make sure >tagloop reduces don't happen + ! before someone finishes an old reduce, we + ! have an MPI_Barrier here. + !call wrf_message('Hit tagloop limit so calling mpi_barrier in get_reduce_tag...') + call mpi_barrier(comm,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_barrier') + !call wrf_message(' ...back from mpi_barrier in get_reduce_tag.') + + curtag(j)=firsttag(j) + endif + + tag=curtag(j) + curtag(j)=tag+1 + get_reduce_tag=tag + return + endif + enddo + + + ! ==================== HANDLE NEW COMMUNICATORS ==================== + + !write(message,'("Found a new communicator ",I0," in get_reduce_tag, so making a tag range for it")') comm + + ! If we get here, the communicator is new to us, so we need + ! to add it to the hash and give it a new tag. + + ! First, figure out where we'll put the tag in the hashtable + here=-1 + do i=0,hashsize-1 + j=1+mod(i+hashed-1,hashsize) + + if(firsttag(j)==0) then + here=j + exit + endif + enddo + if(here==-1) call wrf_error_fatal('no room in hashtable; increase hashsize in get_reduce_tag (should be >max_servers+1)') + + ! Now, find out the new tag's number. To do this, we need to + ! get the next tag number that is not used by any ranks. + + call mpi_comm_rank(comm,me,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank') + + call mpi_comm_size(comm,size,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size') + + if(me==root) then + allocate(nexttags(size)) + else + nexttags=>dummy + endif + + call mpi_gather(nexttag,1,MPI_INTEGER,nexttags,1,MPI_INTEGER,root,comm,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_gather') + + if(me==root) then + nexttag=max(nexttag,maxval(nexttags)) + deallocate(nexttags) + endif + call mpi_bcast(nexttag,1,MPI_INTEGER,root,comm,ierr) + + comms(here)=comm + firsttag(here)=nexttag + curtag(here)=nexttag + get_reduce_tag=nexttag + + !write(message,'("Stored comm ",I0," with tag ",I0,"=",I0," in hash element ",I0)') & + ! comms(here),firsttag(here),curtag(here),here + !call wrf_message(message) + + nexttag=nexttag+tagloop + + end function get_reduce_tag + subroutine reduce_add_int_scl(send,recv,count,root,comm) + implicit none + include 'mpif.h' + integer, intent(in) :: count,root,comm + integer, intent(inout) :: recv + integer, intent(in) :: send + integer :: me, size, ierr, you, temp, tag + character*255 :: message + if(root<0) call wrf_error_fatal('root is less than 0') + + tag=get_reduce_tag(root,comm) + + !write(message,'("Send/recv to tag ",I0)') tag + !call wrf_message(message) + + call mpi_comm_rank(comm,me,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank') + + call mpi_comm_size(comm,size,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size') + + if(root>=size) call wrf_error_fatal('root is beyond highest communicator rank') + + if(me==root) then + recv=send + do you=0,size-2 + call mpi_recv(temp,1,MPI_INTEGER,MPI_ANY_SOURCE,tag,comm,MPI_STATUS_IGNORE,ierr) + if(ierr/=0) call wrf_error_fatal('error calling mpi_recv') + recv=recv+temp + enddo + else + call mpi_send(send,1,MPI_INTEGER,root,tag,comm,ierr) + if(ierr/=0) call wrf_error_fatal('error calling mpi_send') + endif + end subroutine reduce_add_int_scl + subroutine reduce_add_int_arr(sendbuf,recvbuf,count,root,comm) + implicit none + include 'mpif.h' + integer, intent(in) :: count,root,comm + integer, intent(in) :: sendbuf(count) + integer, intent(inout) :: recvbuf(count) + integer :: me, size, ierr, you, tempbuf(count), tag + character*255 :: message + + if(root<0) call wrf_error_fatal('root is less than 0') + + tag=get_reduce_tag(root,comm) + + !write(message,'("Send/recv to tag ",I0)') tag + !call wrf_message(message) + + call mpi_comm_rank(comm,me,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank') + + call mpi_comm_size(comm,size,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size') + + if(root>=size) call wrf_error_fatal('root is beyond highest communicator rank') + + if(me==root) then + recvbuf=sendbuf + do you=0,size-2 + call mpi_recv(tempbuf,count,MPI_INTEGER,MPI_ANY_SOURCE,tag,comm,MPI_STATUS_IGNORE,ierr) + if(ierr/=0) call wrf_error_fatal('error calling mpi_recv') + recvbuf=recvbuf+tempbuf + enddo + else + call mpi_send(sendbuf,count,MPI_INTEGER,root,tag,comm,ierr) + if(ierr/=0) call wrf_error_fatal('error calling mpi_send') + endif + end subroutine reduce_add_int_arr +#endif + + +END MODULE module_wrf_quilt + +! +! Remaining routines in this file are defined outside of the module +! either to defeat arg/param type checking or to avoid an explicit use +! dependence. +! + +SUBROUTINE disable_quilting +! +! Call this in programs that you never want to be quilting (e.g. real) +! Must call before call to init_module_wrf_quilt(). +! + USE module_wrf_quilt + disable_quilt = .TRUE. + RETURN +END SUBROUTINE disable_quilting + +LOGICAL FUNCTION use_output_servers_for(ioform) +! +! Returns .TRUE. if I/O quilt servers are in-use for write operations +! AND the output servers can handle the given I/O form. If the I/O +! form is 0, then the io form is not considered and the result is the +! same as calling use_output_servers. +! This routine is called only by client (compute) tasks. +! + USE module_wrf_quilt + integer, intent(in) :: ioform + use_output_servers_for = quilting_enabled + use_output_servers_for = ( use_output_servers_for .and. ioform<100 ) + RETURN +END FUNCTION use_output_servers_for + +LOGICAL FUNCTION use_output_servers() +! +! Returns .TRUE. if I/O quilt servers are in-use for write operations. +! This routine is called only by client (compute) tasks. +! + USE module_wrf_quilt + use_output_servers = quilting_enabled + RETURN +END FUNCTION use_output_servers + +LOGICAL FUNCTION use_input_servers() +! +! Returns .TRUE. if I/O quilt servers are in-use for read operations. +! This routine is called only by client (compute) tasks. +! + USE module_wrf_quilt + use_input_servers = .FALSE. + RETURN +END FUNCTION use_input_servers + +SUBROUTINE wrf_quilt_open_for_write_begin( FileName , gridid, Comm_compute, Comm_io, SysDepInfo, & + DataHandle , io_form_arg, Status ) +! +! Instruct the I/O quilt servers to begin data definition ("training") phase +! for writing to WRF dataset FileName. io_form_arg indicates file format. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + USE module_state_description, ONLY: IO_PNETCDF + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(IN) :: gridid + INTEGER , INTENT(IN) :: Comm_compute , Comm_io + CHARACTER *(*), INTENT(IN) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(IN) :: io_form_arg + INTEGER , INTENT(OUT) :: Status +! Local + CHARACTER*132 :: locFileName, locSysDepInfo + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy + INTEGER, EXTERNAL :: use_package + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_begin' ) + CALL int_get_fresh_handle(i) + okay_to_write(i) = .false. + DataHandle = i + + locFileName = FileName + locSysDepInfo = SysDepInfo + + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + + SELECT CASE(use_package(io_form_arg)) + +#ifdef PNETCDF_QUILT + CASE(IO_PNETCDF) + IF(compute_group_master(1,current_id)) THEN + CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, & + locFileName,locSysDepInfo,io_form_arg,& + DataHandle ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + END IF +#endif + CASE DEFAULT + + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, & + locFileName,locSysDepInfo,io_form_arg,DataHandle ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF + + END SELECT + + which_grid_is_handle(DataHandle) = gridid + iserver = get_server_id ( DataHandle ) +!write(0,*)'wrf_quilt_open_for_write_begin DataHandle = ', DataHandle +!write(0,*)'wrf_quilt_open_for_write_begin filename = ', Trim(filename) +!write(0,*)'wrf_quilt_open_for_write_begin sysdepinfo = ', Trim(sysdepinfo) +!write(0,*)'wrf_quilt_open_for_write_begin iserver = ', iserver + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) +!write(0,*)'wrf_quilt_open_for_write_begin comm_io_group = ', comm_io_group + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) +!write(0,*)'mpi_x_comm_size tasks_in_group ',tasks_in_group, ierr + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1,current_id) ) reduced(2) = i +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = i +#endif +!write(0,*)'calling mpi_x_reduce in wrf_quilt_open_for_write_begin ' + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_begin") + + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + + Status = 0 + + +#endif + RETURN +END SUBROUTINE wrf_quilt_open_for_write_begin + +SUBROUTINE wrf_quilt_open_for_write_commit( DataHandle , Status ) +! +! Instruct the I/O quilt servers to switch an internal flag to enable output +! for the dataset referenced by DataHandle. The call to +! wrf_quilt_open_for_write_commit() must be paired with a call to +! wrf_quilt_open_for_write_begin(). +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN ) :: DataHandle + INTEGER , INTENT(OUT) :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_commit' ) + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + okay_to_write( DataHandle ) = .true. + ENDIF + ENDIF + + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + +#ifdef PNETCDF_QUILT +!ARP Only want one command to be received by each IO server when using +!ARP parallel IO + IF(compute_group_master(1,current_id)) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle, int_open_for_write_commit ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + END IF +#else + + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle, int_open_for_write_commit ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1,current_id) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_commit") + + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + + Status = 0 + +#endif + RETURN +END SUBROUTINE wrf_quilt_open_for_write_commit + +SUBROUTINE wrf_quilt_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & + DataHandle , Status ) +! +! Instruct the I/O quilt servers to open WRF dataset FileName for reading. +! This routine is called only by client (compute) tasks. +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(IN) :: Comm_compute , Comm_io + CHARACTER *(*), INTENT(IN) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: Status + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_read' ) + DataHandle = -1 + Status = -1 + CALL wrf_error_fatal ( "frame/module_io_quilt.F: wrf_quilt_open_for_read not yet supported" ) +#endif + RETURN +END SUBROUTINE wrf_quilt_open_for_read + +SUBROUTINE wrf_quilt_inquire_opened ( DataHandle, FileName , FileStatus, Status ) +! +! Inquire if the dataset referenced by DataHandle is open. +! Does not require communication with I/O servers. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE +#include "wrf_io_flags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(OUT) :: FileStatus + INTEGER , INTENT(OUT) :: Status + + Status = 0 + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_opened' ) + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + IF ( okay_to_write( DataHandle ) ) THEN + FileStatus = WRF_FILE_OPENED_FOR_WRITE + ENDIF + ENDIF + ENDIF + Status = 0 + +#endif + RETURN +END SUBROUTINE wrf_quilt_inquire_opened + +SUBROUTINE wrf_quilt_inquire_filename ( DataHandle, FileName , FileStatus, Status ) +! +! Return the Filename and FileStatus associated with DataHandle. +! Does not require communication with I/O servers. +! +! Note that the current implementation does not actually return FileName. +! Currenlty, WRF does not use this returned value. Fixing this would simply +! require saving the file names on the client tasks in an array similar to +! okay_to_write(). +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE +#include "wrf_io_flags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER *(*), INTENT(OUT) :: FileName + INTEGER , INTENT(OUT) :: FileStatus + INTEGER , INTENT(OUT) :: Status + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_filename' ) + Status = 0 + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + IF ( okay_to_write( DataHandle ) ) THEN + FileStatus = WRF_FILE_OPENED_FOR_WRITE + ELSE + FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + ENDIF + ELSE + FileStatus = WRF_FILE_NOT_OPENED + ENDIF + Status = 0 + FileName = "bogusfornow" + ELSE + Status = -1 + ENDIF +#endif + RETURN +END SUBROUTINE wrf_quilt_inquire_filename + +SUBROUTINE wrf_quilt_iosync ( DataHandle, Status ) +! +! Instruct the I/O quilt servers to synchronize the disk copy of a dataset +! with memory buffers. +! +! After the "iosync" header (request) is sent to the I/O quilt server, +! the compute tasks will then send the entire contents (headers and data) of +! int_local_output_buffer to their I/O quilt server. This communication is +! done in subroutine send_to_io_quilt_servers(). After the I/O quilt servers +! receive this data, they will write all accumulated fields to disk. +! +! Significant time may be required for the I/O quilt servers to organize +! fields and write them to disk. Therefore, the "iosync" request should be +! sent only when the compute tasks are ready to run for a while without +! needing to communicate with the servers. Otherwise, the compute tasks +! will end up waiting for the servers to finish writing to disk, thus wasting +! any performance benefits of having servers at all. +! +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI) + USE module_wrf_quilt + IMPLICIT NONE + include "mpif.h" + INTEGER , INTENT(IN) :: DataHandle + INTEGER , INTENT(OUT) :: Status + + INTEGER locsize , itypesize + INTEGER ierr, tasks_in_group, comm_io_group, dummy, i, rank + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_iosync' ) + +! CALL start_timing + IF ( associated ( int_local_output_buffer ) ) THEN + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + + locsize = int_num_bytes_to_write(DataHandle) + +! CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = locsize +#ifdef PNETCDF_QUILT +! ARP Only want one command per IOServer if doing parallel IO + IF ( compute_group_master(1,current_id) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +! CALL end_timing("MPI_Reduce in wrf_quilt_iosync") + + ! send data to the i/o processor +#ifdef DEREF_KLUDGE + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + int_local_output_buffer(1), locsize , & + dummy, 0 ) +#else + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + int_local_output_buffer, locsize , & + dummy, 0 ) +#endif + + int_local_output_cursor = 1 +! int_num_bytes_to_write(DataHandle) = 0 + DEALLOCATE ( int_local_output_buffer ) + NULLIFY ( int_local_output_buffer ) + ELSE + CALL wrf_message ("frame/module_io_quilt.F: wrf_quilt_iosync: no buffer allocated") + ENDIF +! CALL end_timing("wrf_quilt_iosync") + Status = 0 +#endif + RETURN +END SUBROUTINE wrf_quilt_iosync + +SUBROUTINE wrf_quilt_ioclose ( DataHandle, Status ) +! +! Instruct the I/O quilt servers to close the dataset referenced by +! DataHandle. +! This routine also clears the client file handle and, if needed, deallocates +! int_local_output_buffer. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined( STUBMPI) + USE module_wrf_quilt + USE module_timing + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + INTEGER , INTENT(OUT) :: Status + INTEGER i, itypesize, tasks_in_group, comm_io_group, ierr + REAL dummy + +!!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioclose' ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + +! If we're using pnetcdf then each IO server will need to receive the +! handle just once as there is +! no longer a reduce over the IO servers to get it. +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1,current_id) )THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle, int_ioclose ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle , int_ioclose ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 +#ifdef PNETCDF_QUILT +! If we're using pnetcdf then each IO server will need the handle as there is +! no longer a reduce over the IO servers to get it. + IF ( compute_group_master(1,current_id) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!JMTIMING CALL end_timing("MPI_Reduce in ioclose") + +#if 0 + ! send data to the i/o processor +!!JMTIMING CALL start_timing + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) +!!JMTIMING CALL end_timing("collect_on_comm in io_close") +#endif + + int_handle_in_use(DataHandle) = .false. + CALL set_server_id( DataHandle, 0 ) + okay_to_write(DataHandle) = .false. + okay_to_commit(DataHandle) = .false. + int_local_output_cursor = 1 + int_num_bytes_to_write(DataHandle) = 0 + IF ( associated ( int_local_output_buffer ) ) THEN + DEALLOCATE ( int_local_output_buffer ) + NULLIFY ( int_local_output_buffer ) + ENDIF + + Status = 0 +!!JMTIMING CALL end_timing( "wrf_quilt_ioclose" ) + +#endif + RETURN +END SUBROUTINE wrf_quilt_ioclose + +SUBROUTINE wrf_quilt_ioexit( Status ) +! +! Instruct the I/O quilt servers to shut down the WRF I/O system. +! Do not call any wrf_quilt_*() routines after this routine has been called. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(OUT) :: Status + INTEGER :: DataHandle, actual_iserver + INTEGER i, itypesize, tasks_in_group, comm_io_group, me, ierr + REAL dummy + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioexit' ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + +!ARPDBG - potential bug. Have no access to what type of IO is being used for +! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. +#ifdef PNETCDF_QUILT +!ARP Send the ioexit message just once to each IOServer when using parallel IO + IF( compute_group_master(1,current_id) ) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle, int_ioexit ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + END IF +#else + + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle , int_ioexit ) ! Handle is dummy + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + DO iserver = 1, nio_groups + if(poll_servers) then + ! We're using server polling mode, so we must call + ! *_find_server to receive the mpi_ssend sent by the servers, + ! otherwise WRF will hang at the mpi_x_reduce below. + + call wrf_quilt_find_server(actual_iserver) + + ! The actual_iserver is now set to the next available I/O server. + ! That may not be the same as iserver, but that's okay as long + ! as we run through this loop exactly nio_groups times. + else + ! Not using server polling, so just access servers in numeric order. + actual_iserver=iserver + endif + + CALL get_mpi_comm_io_groups( comm_io_group , actual_iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + CALL mpi_comm_rank( comm_io_group , me , ierr ) + +! BY SENDING A NEGATIVE SIZE WE GET THE SERVERS TO SHUT DOWN + hdrbufsize = -100 + reduced = 0 + IF ( me .eq. 0 ) reduced(1) = hdrbufsize + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) + + ENDDO + Status = 0 + +#endif + RETURN +END SUBROUTINE wrf_quilt_ioexit + +SUBROUTINE wrf_quilt_get_next_time ( DataHandle, DateStr, Status ) +! +! Instruct the I/O quilt servers to return the next time stamp. +! This is not yet supported. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + INTEGER :: Status +#endif + RETURN +END SUBROUTINE wrf_quilt_get_next_time + +SUBROUTINE wrf_quilt_get_previous_time ( DataHandle, DateStr, Status ) +! +! Instruct the I/O quilt servers to return the previous time stamp. +! This is not yet supported. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + INTEGER :: Status +#endif + RETURN +END SUBROUTINE wrf_quilt_get_previous_time + +SUBROUTINE wrf_quilt_set_time ( DataHandle, Data, Status ) +! +! Instruct the I/O quilt servers to set the time stamp in the dataset +! referenced by DataHandle. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + USE module_state_description, ONLY: IO_PNETCDF + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy + INTEGER :: Count + INTEGER, EXTERNAL :: use_package +! + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_set_time' ) + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + Count = 0 ! there is no count for character strings + +!ARPDBG - potential bug. Have no access to what type of IO is being used for +! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. +#ifdef PNETCDF_QUILT + IF(compute_group_master(1,current_id) )THEN +! Only want to send one time header to each IO server as +! can't tell that's what they are on the IO servers themselves - therefore use +! the compute_group_master process. + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, "TIMESTAMP", "", Data, int_set_time ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + END IF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, "TIMESTAMP", "", Data, int_set_time ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1,current_id) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF + +#endif +RETURN +END SUBROUTINE wrf_quilt_set_time + +SUBROUTINE wrf_quilt_get_next_var ( DataHandle, VarName, Status ) +! +! When reading, instruct the I/O quilt servers to return the name of the next +! variable in the current time frame. +! This is not yet supported. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: VarName + INTEGER :: Status +#endif + RETURN +END SUBROUTINE wrf_quilt_get_next_var + +SUBROUTINE wrf_quilt_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type real are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. + +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + REAL, INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Outcount + INTEGER :: Status + CALL wrf_message('wrf_quilt_get_dom_ti_real not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_real + +SUBROUTINE wrf_quilt_put_dom_ti_real ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type real are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + REAL , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +!Local + CHARACTER*132 :: locElement + INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy +! +!!JMTIMING CALL start_timing +!write(0,*)__FILE__,__LINE__,trim(element),count + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_real' ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + locElement = Element + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + CALL MPI_TYPE_SIZE( MPI_REAL, typesize, ierr ) + +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1,current_id) ) THEN + CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, locElement, Data, Count, int_dom_ti_real ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, locElement, Data, Count, int_dom_ti_real ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF( compute_group_master(1,current_id) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_real") + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF + + Status = 0 +!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_real") +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_real + +SUBROUTINE wrf_quilt_get_dom_ti_double ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type double are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status + CALL wrf_error_fatal('wrf_quilt_get_dom_ti_double not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_double + +SUBROUTINE wrf_quilt_put_dom_ti_double ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type double are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + REAL*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status + CALL wrf_error_fatal('wrf_quilt_put_dom_ti_double not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_double + +SUBROUTINE wrf_quilt_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type integer are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status + CALL wrf_message('wrf_quilt_get_dom_ti_integer not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_integer + +SUBROUTINE wrf_quilt_put_dom_ti_integer ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type integer are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + USE module_state_description, ONLY: IO_PNETCDF + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + INTEGER , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +! Local + CHARACTER*132 :: locElement + INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy + INTEGER, EXTERNAL :: use_package +! + +!!JMTIMING CALL start_timing + locElement = Element + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_integer' ) +!write(0,*)__FILE__,__LINE__,trim(element),count + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, typesize, ierr ) + +!ARPDBG - potential bug. Have no access to what type of IO is being used for +! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1,current_id) )THEN + CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, locElement, Data, Count, & + int_dom_ti_integer ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, locElement, Data, Count, & + int_dom_ti_integer ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1,current_id) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) + +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_integer") + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF + CALL wrf_debug ( DEBUG_LVL, 'returning from wrf_quilt_put_dom_ti_integer' ) +!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_integer" ) + +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_integer + +SUBROUTINE wrf_quilt_get_dom_ti_logical ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type logical are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +! CALL wrf_message('wrf_quilt_get_dom_ti_logical not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_logical + +SUBROUTINE wrf_quilt_put_dom_ti_logical ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type logical are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +! Local + INTEGER i + INTEGER one_or_zero(Count) + + DO i = 1, Count + IF ( Data(i) ) THEN + one_or_zero(i) = 1 + ELSE + one_or_zero(i) = 0 + ENDIF + ENDDO + + CALL wrf_quilt_put_dom_ti_integer ( DataHandle,Element, one_or_zero, Count, Status ) +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_logical + +SUBROUTINE wrf_quilt_get_dom_ti_char ( DataHandle,Element, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time independent +! domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type char are +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) :: Data + INTEGER :: Status + CALL wrf_message('wrf_quilt_get_dom_ti_char not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_char + +SUBROUTINE wrf_quilt_put_dom_ti_char ( DataHandle, Element, Data, Status ) +! +! Instruct the I/O quilt servers to write time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type char are +! copied from string Data. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group, me + REAL dummy +! +!!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_char' ) +!write(0,*)__FILE__,__LINE__,trim(element) + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + +!ARPDBG - potential bug. Have no access to what type of IO is being used for +! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. +#ifdef PNETCDF_QUILT + IF(compute_group_master(1,current_id))THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, Element, "", Data, & + int_dom_ti_char ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + END IF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, Element, "", Data, int_dom_ti_char ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) +! write(0,*)'wrf_quilt_put_dom_ti_char ',iserver + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here) +!!JMTIMING! CALL start_timing +!write(0,*)'calling MPI_Barrier' +! CALL MPI_Barrier( mpi_comm_local, ierr ) +!write(0,*)'back from MPI_Barrier' +!!JMTIMING! CALL end_timing("MPI_Barrier in wrf_quilt_put_dom_ti_char") + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced_dummy = 0 + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF(compute_group_master(1,current_id)) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif +!call mpi_comm_rank( comm_io_group , me, ierr ) + + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) + +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_char") + ! send data to the i/o processor +!!JMTIMING CALL start_timing + + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) +!!JMTIMING CALL end_timing("collect_on_comm in wrf_quilt_put_dom_ti_char") + ENDIF + ENDIF +!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char") + +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_char + +SUBROUTINE wrf_quilt_get_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type real are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_real + +SUBROUTINE wrf_quilt_put_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type real are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_real + +SUBROUTINE wrf_quilt_get_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type double are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_get_dom_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_double + +SUBROUTINE wrf_quilt_put_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type double are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_put_dom_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_double + +SUBROUTINE wrf_quilt_get_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type integer are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_integer + +SUBROUTINE wrf_quilt_put_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type integer are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_integer + +SUBROUTINE wrf_quilt_get_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type logical are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_logical + +SUBROUTINE wrf_quilt_put_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type logical are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_logical + +SUBROUTINE wrf_quilt_get_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time dependent +! domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type char are +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_char + +SUBROUTINE wrf_quilt_put_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) +! +! Instruct $he I/O quilt servers to write time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type char are +! copied from string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_char + +SUBROUTINE wrf_quilt_get_var_ti_real ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type real is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_real + +SUBROUTINE wrf_quilt_put_var_ti_real ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type real is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_real + +SUBROUTINE wrf_quilt_get_var_ti_double ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type double is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_get_var_ti_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_double + +SUBROUTINE wrf_quilt_put_var_ti_double ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type double is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_put_var_ti_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_double + +SUBROUTINE wrf_quilt_get_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type integer is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_integer + +SUBROUTINE wrf_quilt_put_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type integer is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_integer + +SUBROUTINE wrf_quilt_get_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type logical is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_logical + +SUBROUTINE wrf_quilt_put_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type logical is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_logical + +SUBROUTINE wrf_quilt_get_var_ti_char ( DataHandle,Element, Varname, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time independent +! attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type char is +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_char + +SUBROUTINE wrf_quilt_put_var_ti_char ( DataHandle,Element, Varname, Data, Status ) +! +! Instruct the I/O quilt servers to write time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type char is +! copied from string Data. +! This routine is called only by client (compute) tasks. +! + +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy +! + +!!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_var_ti_char' ) +!write(0,*)__FILE__,__LINE__,trim(varname),trim(element) + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1,current_id) ) THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, TRIM(Element), & + TRIM(VarName), TRIM(Data), int_var_ti_char ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, TRIM(Element), & + TRIM(VarName), TRIM(Data), int_var_ti_char ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1,current_id) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_var_ti_char") + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF +!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char" ) + +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_char + +SUBROUTINE wrf_quilt_get_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type real is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_real + +SUBROUTINE wrf_quilt_put_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type real is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_real + +SUBROUTINE wrf_quilt_get_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type double is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_get_var_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_get_var_td_double + +SUBROUTINE wrf_quilt_put_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type double is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_put_var_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_put_var_td_double + +SUBROUTINE wrf_quilt_get_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount,Status) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type integer is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_integer + +SUBROUTINE wrf_quilt_put_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type integer is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_integer + +SUBROUTINE wrf_quilt_get_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type logical is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_logical + +SUBROUTINE wrf_quilt_put_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type logical is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_logical + +SUBROUTINE wrf_quilt_get_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type char is +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_char + +SUBROUTINE wrf_quilt_put_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status ) +! +! Instruct the I/O quilt servers to write time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type char is +! copied from string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_char + +SUBROUTINE wrf_quilt_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +! Instruct the I/O quilt servers to read the variable named VarName from the +! dataset pointed to by DataHandle. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(INOUT) :: DateStr + CHARACTER*(*) , INTENT(INOUT) :: VarName + INTEGER , INTENT(INOUT) :: Field(*) + integer ,intent(in) :: FieldType + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(in) :: Stagger + character*(*) , dimension (*) ,intent(in) :: DimNames + integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd + integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd + integer ,intent(out) :: Status + Status = 0 +#endif +RETURN +END SUBROUTINE wrf_quilt_read_field + +SUBROUTINE wrf_quilt_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +! Prepare instructions for the I/O quilt servers to write the variable named +! VarName to the dataset pointed to by DataHandle. +! +! During a "training" write this routine accumulates number and sizes of +! messages that will be sent to the I/O server associated with this compute +! (client) task. +! +! During a "real" write, this routine begins by allocating +! int_local_output_buffer if it has not already been allocated. Sizes +! accumulated during "training" are used to determine how big +! int_local_output_buffer must be. This routine then stores "int_field" +! headers and associated field data in int_local_output_buffer. The contents +! of int_local_output_buffer are actually sent to the I/O quilt server in +! routine wrf_quilt_iosync(). This scheme allows output of multiple variables +! to be aggregated into a single "iosync" operation. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_state_description + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "wrf_io_flags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName +! INTEGER , INTENT(IN) :: Field(*) + integer ,intent(in) :: FieldType + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(in) :: Stagger + character*(*) , dimension (*) ,intent(in) :: DimNames + integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd + integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd + integer ,intent(out) :: Status + + integer ii,jj,kk,myrank + + REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), & + MemoryStart(2):MemoryEnd(2), & + MemoryStart(3):MemoryEnd(3) ) :: Field + INTEGER locsize , typesize, itypesize + INTEGER ierr, tasks_in_group, comm_io_group, dummy, i + INTEGER, EXTERNAL :: use_package + +!!ARPTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_write_field' ) + + IF ( .NOT. (DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles) ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: invalid data handle" ) + ENDIF + IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: DataHandle not opened" ) + ENDIF + + locsize = (PatchEnd(1)-PatchStart(1)+1)* & + (PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1) + + CALL mpi_type_size( MPI_INTEGER, itypesize, ierr ) + ! Note that the WRF_DOUBLE branch of this IF statement must come first since + ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds. + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + CALL mpi_type_size( MPI_DOUBLE_PRECISION, typesize, ierr ) + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + CALL mpi_type_size( MPI_REAL, typesize, ierr ) + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL mpi_type_size( MPI_INTEGER, typesize, ierr ) + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + CALL mpi_type_size( MPI_LOGICAL, typesize, ierr ) + ENDIF + + IF ( .NOT. okay_to_write( DataHandle ) ) THEN + + ! This is a "training" write. + ! it is not okay to actually write; what we do here is just "bookkeep": count up + ! the number and size of messages that we will output to io server associated with + ! this task + + CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + 333933 , MemoryOrder , Stagger , DimNames , & ! 333933 means training; magic number + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + + int_num_bytes_to_write(DataHandle) = int_num_bytes_to_write(DataHandle) + locsize * typesize + hdrbufsize + + ! Send the hdr for the write in case the interface is calling the I/O API in "learn" mode + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +#if 0 + IF ( .NOT. wrf_dm_on_monitor() ) THEN ! only one task in compute grid sends this message; send noops on others + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + +!!ARPTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1,current_id) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!ARPTIMING CALL end_timing("MPI_Reduce in wrf_quilt_write_field dryrun") + ! send data to the i/o processor + + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + + ELSE + + IF ( .NOT. associated( int_local_output_buffer ) ) THEN + ALLOCATE ( int_local_output_buffer( (int_num_bytes_to_write( DataHandle )+1)/itypesize ), Stat=ierr ) + IF(ierr /= 0)THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: allocate of int_local_output_buffer failed" ) + END IF + int_local_output_cursor = 1 + ENDIF + iserver = get_server_id ( DataHandle ) + + ! This is NOT a "training" write. It is OK to write now. + CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + 0 , MemoryOrder , Stagger , DimNames , & ! non-333933 means okay to write; magic number + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + + ! Pack header into int_local_output_buffer. It will be sent to the + ! I/O servers during the next "iosync" operation. +#ifdef DEREF_KLUDGE + CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer(1), int_local_output_cursor ) +#else + CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer, int_local_output_cursor ) +#endif + + ! Pack field data into int_local_output_buffer. It will be sent to the + ! I/O servers during the next "iosync" operation. +#ifdef DEREF_KLUDGE + CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), & + locsize * typesize , int_local_output_buffer(1), int_local_output_cursor ) +#else + CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), & + locsize * typesize , int_local_output_buffer, int_local_output_cursor ) +#endif + + ENDIF + Status = 0 +!!ARPTIMING CALL end_timing("wrf_quilt_write_field") + +#endif + RETURN +END SUBROUTINE wrf_quilt_write_field + +SUBROUTINE wrf_quilt_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , & + DomainStart , DomainEnd , Status ) +! +! This routine applies only to a dataset that is open for read. It instructs +! the I/O quilt servers to return information about variable VarName. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: VarName + integer :: NDim + character*(*) :: MemoryOrder + character*(*) :: Stagger + integer ,dimension(*) :: DomainStart, DomainEnd + integer :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_info + +subroutine wrf_quilt_find_server(iserver) + + ! This routine is called by the compute processes when they need an + ! I/O server to write out a new file. Upon return, this routine will + ! set iserver to the next available I/O server group. + + ! A mpi_recv to all of mpi_comm_avail is used to implement this, and + ! that recv will not return until an I/O server group calls + ! wrf_quilt_server_ready to signal that it is ready for a new file. + +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + use module_wrf_quilt, only : in_avail, mpi_comm_avail, mpi_comm_local + + implicit none + INCLUDE 'mpif.h' + integer, intent(inout) :: iserver + integer :: ierr + character(255) :: message + + call wrf_message('Polling I/O servers...') + + if(in_avail) then + call mpi_recv(iserver,1,MPI_INTEGER,MPI_ANY_SOURCE,0,mpi_comm_avail,MPI_STATUS_IGNORE,ierr) + if(ierr/=0) then + call wrf_error_fatal('mpi_recv failed in wrf_quilt_find_server') + endif + endif + + call mpi_bcast(iserver,1,MPI_INTEGER,0,mpi_comm_local,ierr) + if(ierr/=0) then + call wrf_error_fatal('mpi_bcast failed in wrf_quilt_find_server') + endif + + write(message,'("I/O server ",I0," is ready for operations.")') iserver + call wrf_message(message) + +#endif + +end subroutine wrf_quilt_find_server +subroutine wrf_quilt_server_ready() + + ! This routine is called by the I/O server group's master process once the + ! I/O server group is done writing its current file, and is waiting for + ! a new one. This information is passed to the monitor process by a + ! blocking send from the I/O server master process to the monitor. + + ! All processes in an I/O group must call this routine, and this routine + ! will not return (in any process) until the monitor process signals + ! that it wants the I/O server group to write a file. That signal is + ! sent in a call to wrf_quilt_find_server on the compute processes. + +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + use module_wrf_quilt, only : mpi_comm_local, in_avail, availrank, mpi_comm_avail + + implicit none + INCLUDE 'mpif.h' + integer :: ierr + character*255 :: message + + write(message,*) 'Entering wrf_quilt_server_ready.' + call wrf_debug(1,message) + + call mpi_barrier(mpi_comm_local,ierr) + if(ierr/=0) then + call wrf_error_fatal('mpi_barrier failed in wrf_quilt_server_ready') + endif + + if(in_avail) then + write(message,'("mpi_ssend ioserver=",I0," in wrf_quilt_server_ready")') availrank + call wrf_debug(1,message) + call mpi_ssend(availrank,1,MPI_INTEGER,0,0,mpi_comm_avail,ierr) + if(ierr/=0) then + call wrf_error_fatal('mpi_ssend failed in wrf_quilt_server_ready') + endif + endif + + call mpi_barrier(mpi_comm_local,ierr) + if(ierr/=0) then + call wrf_error_fatal('mpi_barrier failed in wrf_quilt_server_ready') + endif + + write(message,*) 'Leaving wrf_quilt_server_ready.' + call wrf_debug(1,message) +#endif + +end subroutine wrf_quilt_server_ready + +SUBROUTINE get_mpi_comm_io_groups( retval, isrvr ) +! +! This routine returns the compute+io communicator to which this +! compute task belongs for I/O server group "isrvr". +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + USE module_dm, ONLY : current_id + IMPLICIT NONE + INTEGER, INTENT(IN ) :: isrvr + INTEGER, INTENT(OUT) :: retval + retval = mpi_comm_io_groups(isrvr,current_id) +#endif + RETURN +END SUBROUTINE get_mpi_comm_io_groups + +SUBROUTINE get_nio_tasks_in_group( id, retval ) +! +! This routine returns the number of I/O server tasks in each +! I/O server group. It can be called by both clients and +! servers. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INTEGER, INTENT(IN) :: id + INTEGER, INTENT(OUT) :: retval + retval = nio_tasks_per_group(id) +#endif + RETURN +END SUBROUTINE get_nio_tasks_in_group + +SUBROUTINE collect_on_comm_debug(file,line, comm_io_group, & + sze, & + hdrbuf, hdrbufsize , & + outbuf, outbufsize ) + IMPLICIT NONE + CHARACTER*(*) file + INTEGER line + INTEGER comm_io_group + INTEGER sze + INTEGER hdrbuf(*), outbuf(*) + INTEGER hdrbufsize, outbufsize + + !write(0,*)'collect_on_comm_debug ',trim(file),line,sze,hdrbufsize,outbufsize + CALL collect_on_comm( comm_io_group, & + sze, & + hdrbuf, hdrbufsize , & + outbuf, outbufsize ) + !write(0,*)trim(file),line,'returning' + RETURN +END + + +SUBROUTINE collect_on_comm_debug2(file,line,var,tag,sz,hdr_rec_size, & + comm_io_group, & + sze, & + hdrbuf, hdrbufsize , & + outbuf, outbufsize ) + IMPLICIT NONE + CHARACTER*(*) file,var + INTEGER line,tag,sz,hdr_rec_size + INTEGER comm_io_group + INTEGER sze + INTEGER hdrbuf(*), outbuf(*) + INTEGER hdrbufsize, outbufsize + +! write(0,*)'collect_on_comm_debug2 ',trim(file),line,trim(var),tag,sz,hdr_rec_size,sze,hdrbufsize,outbufsize + CALL collect_on_comm( comm_io_group, & + sze, & + hdrbuf, hdrbufsize , & + outbuf, outbufsize ) +! write(0,*)'collect_on_comm_debug2 ',trim(file),line,'returning for ',trim(var) + RETURN +END diff --git a/wrfv2_fire/frame/module_io_quilt_old.F b/wrfv2_fire/frame/module_io_quilt_old.F new file mode 100644 index 00000000..81d70f03 --- /dev/null +++ b/wrfv2_fire/frame/module_io_quilt_old.F @@ -0,0 +1,5194 @@ +!WRF:DRIVER_LAYER:IO +! +#define DEBUG_LVL 50 +!#define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k ) ; write(0,*) __LINE__ +#define mpi_x_comm_size(i,j,k) Mpi_Comm_Size ( i,j,k ) + +! Workaround for bug in the IBM MPI implementation. Look near the +! bottom of this file for an explanation. +#ifdef IBM_REDUCE_BUG_WORKAROUND +#define mpi_x_reduce(sb,rb,c,dt,op,r,com,ierr) reduce_add_integer(sb,rb,c,r,com) +#else +#define mpi_x_reduce(sb,rb,c,dt,op,r,com,ierr) MPI_Reduce(sb,rb,c,dt,op,r,com,ierr) +!#define mpi_x_reduce(sb,rb,c,dt,op,r,com,ierr) MPI_Reduce(sb,rb,c,dt,op,r,com,ierr) ; write(0,*)__LINE__ +#endif + +MODULE module_wrf_quilt +! +!
+! This module contains WRF-specific I/O quilt routines called by both 
+! client (compute) and server (I/O quilt) tasks.  I/O quilt servers are 
+! a run-time optimization that allow I/O operations, executed on the I/O 
+! quilt server tasks, to be overlapped with useful computation, executed on 
+! the compute tasks.  Since I/O operations are often quite slow compared to 
+! computation, this performance optimization can increase parallel 
+! efficiency.  
+!
+! Currently, one group of I/O servers can be specified at run-time.  Namelist 
+! variable "nio_tasks_per_group" is used to specify the number of I/O server 
+! tasks in this group.  In most cases, parallel efficiency is optimized when 
+! the minimum number of I/O server tasks are used.  If memory needed to cache 
+! I/O operations fits on a single processor, then set nio_tasks_per_group=1.  
+! If not, increase the number of I/O server tasks until I/O operations fit in 
+! memory.  In the future, multiple groups of I/O server tasks will be 
+! supported.  The number of groups will be specified by namelist variable 
+! "nio_groups".  For now, nio_groups must be set to 1.  Currently, I/O servers 
+! only support overlap of output operations with computation.  Also, only I/O 
+! packages that do no support native parallel I/O may be used with I/O server 
+! tasks.  This excludes PHDF5 and MCEL.  
+!
+! In this module, the I/O quilt server tasks call package-dependent 
+! WRF-specific I/O interfaces to perform I/O operations requested by the 
+! client (compute) tasks.  All of these calls occur inside subroutine 
+! quilt().  
+! 
+! The client (compute) tasks call package-independent WRF-specific "quilt I/O" 
+! interfaces that send requests to the I/O quilt servers.  All of these calls 
+! are made from module_io.F.  
+!
+! These routines have the same names and (roughly) the same arguments as those 
+! specified in the WRF I/O API except that:
+! - "Quilt I/O" routines defined in this file and called by routines in 
+!   module_io.F have the "wrf_quilt_" prefix.
+! - Package-dependent routines called from routines in this file are defined 
+!   in the external I/O packages and have the "ext_" prefix.
+!
+! Both client (compute) and server tasks call routine init_module_wrf_quilt() 
+! which then calls setup_quilt_servers() determine which tasks are compute 
+! tasks and which are server tasks.  Before the end of init_module_wrf_quilt() 
+! server tasks call routine quilt() and remain there for the rest of the model 
+! run.  Compute tasks return from init_module_wrf_quilt() to perform model 
+! computations.  
+!
+! See http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the latest
+! version of the WRF I/O API.  This document includes detailed descriptions
+! of subroutines and their arguments that are not duplicated here.
+!
+! + USE module_internal_header_util + USE module_timing +#if ( DA_CORE != 1 ) + USE module_cpl, ONLY : coupler_on, cpl_set_dm_communicator, cpl_finalize +#endif + + INTEGER, PARAMETER :: int_num_handles = 99 + INTEGER, PARAMETER :: max_servers = int_num_handles+1 ! why +1? + LOGICAL, DIMENSION(0:int_num_handles) :: okay_to_write, int_handle_in_use, okay_to_commit + INTEGER, DIMENSION(0:int_num_handles) :: int_num_bytes_to_write, io_form + REAL, POINTER,SAVE :: int_local_output_buffer(:) + INTEGER, SAVE :: int_local_output_cursor + LOGICAL :: quilting_enabled + LOGICAL :: disable_quilt = .FALSE. + INTEGER :: prev_server_for_handle = -1 + INTEGER :: server_for_handle(int_num_handles) + INTEGER :: reduced(2), reduced_dummy(2) + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + + INTEGER :: mpi_comm_avail,availrank + LOGICAL :: in_avail=.false., poll_servers=.false. + + INTEGER nio_groups +#ifdef DM_PARALLEL + INTEGER :: mpi_comm_local + LOGICAL :: compute_node + LOGICAL :: compute_group_master(max_servers) + INTEGER :: mpi_comm_io_groups(max_servers) + INTEGER :: nio_tasks_in_group + INTEGER :: nio_tasks_per_group + INTEGER :: ncompute_tasks + INTEGER :: ntasks + INTEGER :: mytask + + INTEGER, PARAMETER :: onebyte = 1 + INTEGER comm_io_servers, iserver, hdrbufsize, obufsize + INTEGER, DIMENSION(4096) :: hdrbuf + INTEGER, DIMENSION(int_num_handles) :: handle +#endif + +#ifdef IBM_REDUCE_BUG_WORKAROUND +! Workaround for bug in the IBM MPI implementation. Look near the +! bottom of this file for an explanation. + interface reduce_add_integer + module procedure reduce_add_int_arr + module procedure reduce_add_int_scl + end interface +#endif + + CONTAINS + +#if defined(DM_PARALLEL) && !defined( STUBMPI ) + INTEGER FUNCTION get_server_id ( dhandle ) +! +! Logic in the client side to know which io server +! group to send to. If the unit corresponds to a file that's +! already been opened, then we have no choice but to send the +! data to that group again, regardless of whether there are +! other server-groups. If it's a new file, we can chose a new +! server group. I.e. opening a file locks it onto a server +! group. Closing the file unlocks it. +! + IMPLICIT NONE + INTEGER, INTENT(IN) :: dhandle + IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN + IF ( server_for_handle ( dhandle ) .GE. 1 ) THEN + get_server_id = server_for_handle ( dhandle ) + ELSE + IF(poll_servers) THEN + ! Poll server group masters to find an inactive I/O server group: + call wrf_quilt_find_server(server_for_handle(dhandle)) + ELSE + ! Server polling is disabled, so cycle through servers: + prev_server_for_handle = mod ( prev_server_for_handle + 1 , nio_groups ) + server_for_handle( dhandle ) = prev_server_for_handle+1 + ENDIF + get_server_id=server_for_handle(dhandle) + ENDIF + ELSE + CALL wrf_message('module_io_quilt: get_server_id bad dhandle' ) + ENDIF + END FUNCTION get_server_id +#endif + + SUBROUTINE set_server_id ( dhandle, value ) + IMPLICIT NONE + INTEGER, INTENT(IN) :: dhandle, value + IF ( dhandle .GE. 1 .AND. dhandle .LE. int_num_handles ) THEN + server_for_handle(dhandle) = value + ELSE + CALL wrf_message('module_io_quilt: set_server_id bad dhandle' ) + ENDIF + END SUBROUTINE set_server_id + + LOGICAL FUNCTION get_poll_servers() + implicit none + get_poll_servers=poll_servers + end FUNCTION get_poll_servers + +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + SUBROUTINE int_get_fresh_handle( retval ) +! +! Find an unused "client file handle" and return it in retval. +! The "client file handle" is used to remember how a file was opened +! so clients do not need to ask the I/O quilt servers for this information. +! It is also used as a file identifier in communications with the I/O +! server task. +! +! Note that client tasks know nothing about package-specific handles. +! Only the I/O quilt servers know about them. +! + INTEGER i, retval + retval = -1 + DO i = 1, int_num_handles + IF ( .NOT. int_handle_in_use(i) ) THEN + retval = i + GOTO 33 + ENDIF + ENDDO +33 CONTINUE + IF ( retval < 0 ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: int_get_fresh_handle() can not") + ENDIF + int_handle_in_use(i) = .TRUE. + NULLIFY ( int_local_output_buffer ) + END SUBROUTINE int_get_fresh_handle + + SUBROUTINE setup_quilt_servers ( nio_tasks_per_group, & + mytask, & + ntasks, & + nproc_x, & + nproc_y, & + n_groups_arg, & + nio, & + mpi_comm_wrld, & + mpi_comm_local, & + mpi_comm_io_groups) +! +! Both client (compute) and server tasks call this routine to +! determine which tasks are compute tasks and which are I/O server tasks. +! +! Module variables MPI_COMM_LOCAL and MPI_COMM_IO_GROUPS(:) are set up to +! contain MPI communicators as follows: +! +! MPI_COMM_LOCAL is the Communicator for the local groups of tasks. For the +! compute tasks it is the group of compute tasks; for a server group it the +! communicator of tasks in the server group. +! +! Elements of MPI_COMM_IO_GROUPS are communicators that each contain one or +! more compute tasks and a single I/O server assigned to those compute tasks. +! The I/O server tasks is always the last task in these communicators. +! On a compute task, which has a single associate in each of the server +! groups, MPI_COMM_IO_GROUPS is treated as an array; each element corresponds +! to a different server group. +! On a server task only the first element of MPI_COMM_IO_GROUPS is used +! because each server task is part of only one io_group. +! +! I/O server tasks in each I/O server group are divided among compute tasks as +! evenly as possible. +! +! When multiple I/O server groups are used, each must have the same number of +! tasks. When the total number of extra I/O tasks does not divide evenly by +! the number of io server groups requested, the remainder tasks are not used +! (wasted). +! +! For example, communicator membership for 18 tasks with nio_groups=2 and +! nio_tasks_per_group=3 is shown below: +! +!
+! Membership for MPI_COMM_LOCAL communicators:
+!   COMPUTE TASKS:          0   1   2   3   4   5   6   7   8   9  10  11
+!   1ST I/O SERVER GROUP:  12  13  14
+!   2ND I/O SERVER GROUP:  15  16  17
+!
+! Membership for MPI_COMM_IO_GROUPS(1):  
+!   COMPUTE TASKS 0, 3, 6, 9:   0   3   6   9  12
+!   COMPUTE TASKS 1, 4, 7,10:   1   4   7  10  13
+!   COMPUTE TASKS 2, 5, 8,11:   2   5   8  11  14
+!   I/O SERVER TASK       12:   0   3   6   9  12
+!   I/O SERVER TASK       13:   1   4   7  10  13
+!   I/O SERVER TASK       14:   2   5   8  11  14
+!   I/O SERVER TASK       15:   0   3   6   9  15
+!   I/O SERVER TASK       16:   1   4   7  10  16
+!   I/O SERVER TASK       17:   2   5   8  11  17
+!
+! Membership for MPI_COMM_IO_GROUPS(2):  
+!   COMPUTE TASKS 0, 3, 6, 9:   0   3   6   9  15
+!   COMPUTE TASKS 1, 4, 7,10:   1   4   7  10  16
+!   COMPUTE TASKS 2, 5, 8,11:   2   5   8  11  17
+!   I/O SERVER TASK       12:  ** not used **
+!   I/O SERVER TASK       13:  ** not used **
+!   I/O SERVER TASK       14:  ** not used **
+!   I/O SERVER TASK       15:  ** not used **
+!   I/O SERVER TASK       16:  ** not used **
+!   I/O SERVER TASK       17:  ** not used **
+!
+! + USE module_configure +#ifdef DM_PARALLEL + USE module_dm, ONLY : compute_mesh +#endif + IMPLICIT NONE + INCLUDE 'mpif.h' + INTEGER, INTENT(IN) :: nio_tasks_per_group, mytask, ntasks, & + n_groups_arg, mpi_comm_wrld + INTEGER, INTENT(IN) :: nproc_x, nproc_y + INTEGER, INTENT(OUT) :: mpi_comm_local, nio + INTEGER, DIMENSION(100), INTENT(OUT) :: mpi_comm_io_groups +! Local + INTEGER :: i, j, ii, comdup, ierr, niotasks, n_groups, iisize + INTEGER, DIMENSION(ntasks) :: icolor + CHARACTER*128 mess + INTEGER :: io_form_setting + INTEGER :: me + INTEGER :: k, m, nprocx, nprocy + LOGICAL :: reorder_mesh + +!check the namelist and make sure there are no output forms specified +!that cannot be quilted + CALL nl_get_io_form_history(1, io_form_setting) ; call sokay( 'history', io_form_setting ) + CALL nl_get_io_form_restart(1, io_form_setting) ; call sokay( 'restart', io_form_setting ) + CALL nl_get_io_form_auxhist1(1, io_form_setting) ; call sokay( 'auxhist1', io_form_setting ) + CALL nl_get_io_form_auxhist2(1, io_form_setting) ; call sokay( 'auxhist2', io_form_setting ) + CALL nl_get_io_form_auxhist3(1, io_form_setting) ; call sokay( 'auxhist3', io_form_setting ) + CALL nl_get_io_form_auxhist4(1, io_form_setting) ; call sokay( 'auxhist4', io_form_setting ) + CALL nl_get_io_form_auxhist5(1, io_form_setting) ; call sokay( 'auxhist5', io_form_setting ) + CALL nl_get_io_form_auxhist6(1, io_form_setting) ; call sokay( 'auxhist6', io_form_setting ) + CALL nl_get_io_form_auxhist7(1, io_form_setting) ; call sokay( 'auxhist7', io_form_setting ) + CALL nl_get_io_form_auxhist8(1, io_form_setting) ; call sokay( 'auxhist8', io_form_setting ) + CALL nl_get_io_form_auxhist9(1, io_form_setting) ; call sokay( 'auxhist9', io_form_setting ) + CALL nl_get_io_form_auxhist10(1, io_form_setting) ; call sokay( 'auxhist10', io_form_setting ) + CALL nl_get_io_form_auxhist11(1, io_form_setting) ; call sokay( 'auxhist11', io_form_setting ) + + n_groups = n_groups_arg + IF ( n_groups .LT. 1 ) n_groups = 1 + + compute_node = .TRUE. + +! +! nio is number of io tasks per group. If there arent enough tasks to satisfy +! the requirement that there be at least as many compute tasks as io tasks in +! each group, then just print a warning and dump out of quilting +! + + nio = nio_tasks_per_group + ncompute_tasks = ntasks - (nio * n_groups) + IF ( ncompute_tasks .LT. nio ) THEN + WRITE(mess,'("Not enough tasks to have ",I3," groups of ",I3," I/O tasks. No quilting.")')n_groups,nio + nio = 0 + ncompute_tasks = ntasks + ELSE + WRITE(mess,'("Quilting with ",I3," groups of ",I3," I/O tasks.")')n_groups,nio + ENDIF + CALL wrf_message(mess) + + IF ( nio .LT. 0 ) THEN + nio = 0 + ENDIF + IF ( nio .EQ. 0 ) THEN + quilting_enabled = .FALSE. + mpi_comm_local = mpi_comm_wrld + mpi_comm_io_groups = mpi_comm_wrld + RETURN + ENDIF + quilting_enabled = .TRUE. + +! First construct the local communicators +! prepare to split the communicator by designating compute-only tasks + DO i = 1, ncompute_tasks + icolor(i) = 0 + ENDDO + ii = 1 +! and designating the groups of i/o tasks + DO i = ncompute_tasks+1, ntasks, nio + DO j = i, i+nio-1 + icolor(j) = ii + ENDDO + ii = ii+1 + ENDDO + CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr) + CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask,mpi_comm_local,ierr) + +! Now construct the communicators for the io_groups + CALL nl_get_reorder_mesh(1,reorder_mesh) + IF ( reorder_mesh ) THEN + reorder_mesh = .FALSE. + CALL nl_set_reorder_mesh(1,reorder_mesh) + CALL wrf_message('Warning: reorder_mesh does not work with quilting. Disabled reorder_mesh.') + ENDIF + ! assign the compute tasks to the i/o tasks in full rows + IF ( nproc_x .NE. -1 .AND. nproc_y .NE. -1 ) THEN + nprocx=nproc_x + nprocy=nproc_y + ELSE + CALL compute_mesh( ncompute_tasks, nprocx, nprocy ) + ENDIF + + nio = min(nio,nprocy) + m = mod(nprocy,nio) ! divide up remainder, 1 row per, until gone + ii = 1 + DO j = 1, nio, 1 + DO k = 1,nprocy/nio+min(m,1) + DO i = 1, nprocx + icolor(ii) = j - 1 + ii = ii + 1 + ENDDO + ENDDO + m = max(m-1,0) + ENDDO + +! ... and add the io servers as the last task in each group + DO j = 1, n_groups + ! TBH: each I/O group will contain only one I/O server + DO i = ncompute_tasks+1,ntasks + icolor(i) = MPI_UNDEFINED + ENDDO + ii = 0 + DO i = ncompute_tasks+(j-1)*nio+1,ncompute_tasks+j*nio + icolor(i) = ii + ii = ii+1 + ENDDO + CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr) + CALL MPI_Comm_split(comdup,icolor(mytask+1),mytask, & + mpi_comm_io_groups(j),ierr) + ENDDO + +#ifdef PNETCDF_QUILT + if(poll_servers) then + poll_servers=.false. + call wrf_message('Warning: server polling does not work with pnetcdf_quilt. Disabled poll_servers.') + else +#endif + if(nio_groups==1) then + poll_servers=.false. + call wrf_message('Server polling is does not work with one io group. Disabled poll_servers.') + endif +#ifdef PNETCDF_QUILT + endif +#endif + + if(poll_servers) then + ! If server polling is enabled, we need to create mpi_comm_avail, + ! which contains the monitor process, and the I/O server master process + ! for each I/O server group. This will be used in the routines + ! wrf_quilt_find_server and wrf_quilt_server_ready to find inactive + ! I/O servers for new data handles in get_server_id. + + ! The "in_avail" is set to true iff I am in the mpi_comm_avail. + + call mpi_comm_rank(mpi_comm_wrld,me,ierr) + + icolor=MPI_UNDEFINED + in_avail=.false. + + if(wrf_dm_on_monitor()) then + in_avail=.true. ! monitor process is in mpi_comm_avail + endif + icolor(1)=1 + + do j=1,n_groups + i=ncompute_tasks+j*nio-1 + if(me+1==i) then + in_avail=.true. ! I/O server masters are in mpi_comm_avail + endif + icolor(i)=1 + enddo + + CALL MPI_Comm_dup(mpi_comm_wrld,comdup,ierr) + CALL MPI_Comm_split(comdup,icolor(me+1),me, & + mpi_comm_avail,ierr) + + availrank=MPI_UNDEFINED + if(in_avail) then + call mpi_comm_rank(mpi_comm_avail,availrank,ierr) + endif + + endif + + compute_group_master = .FALSE. + compute_node = .FALSE. + + DO j = 1, n_groups + + IF ( mytask .LT. ncompute_tasks .OR. & ! I am a compute task + (ncompute_tasks+(j-1)*nio .LE. mytask .AND. mytask .LT. ncompute_tasks+j*nio) & ! I am the I/O server for this group + ) THEN + + CALL MPI_Comm_Size( mpi_comm_io_groups(j) , iisize, ierr ) + ! Get the rank of this compute task in the compute+io + ! communicator to which it belongs + CALL MPI_Comm_Rank( mpi_comm_io_groups(j) , me , ierr ) + + ! If I am an I/O server for this group then make that group's + ! communicator the first element in the mpi_comm_io_groups array + ! (I will ignore all of the other elements). + IF (ncompute_tasks+(j-1)*nio .LE. mytask .AND. mytask .LT. ncompute_tasks+j*nio) THEN + mpi_comm_io_groups(1) = mpi_comm_io_groups(j) + ELSE + compute_node = .TRUE. + ! If I am a compute task, check whether I am the member of my + ! group that will communicate things that should be sent just + ! once (e.g. commands) to the IO server of my group. + compute_group_master(j) = (me .EQ. 0) + +! IF( compute_group_master(j) ) WRITE(*,*) mytask,': ARPDBG : I will talk to IO server in group ',j + ENDIF + ENDIF + ENDDO + + END SUBROUTINE setup_quilt_servers + + SUBROUTINE sokay ( stream, io_form ) + USE module_state_description + CHARACTER*(*) stream + CHARACTER*256 mess + INTEGER io_form + + SELECT CASE (io_form) +#ifdef NETCDF + CASE ( IO_NETCDF ) + RETURN +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + RETURN +#endif +#ifdef YYY + CASE ( IO_YYY ) + RETURN +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + RETURN +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + RETURN +#endif + CASE (0) + RETURN + CASE DEFAULT + WRITE(mess,*)' An output format has been specified that is incompatible with quilting: io_form: ',io_form,' ',TRIM(stream) + CALL wrf_error_fatal(mess) + END SELECT + END SUBROUTINE sokay + + SUBROUTINE quilt +! +! I/O server tasks call this routine and remain in it for the rest of the +! model run. I/O servers receive I/O requests from compute tasks and +! perform requested I/O operations by calling package-dependent WRF-specific +! I/O interfaces. Requests are sent in the form of "data headers". Each +! request has a unique "header" message associated with it. For requests that +! contain large amounts of data, the data is appended to the header. See +! file module_internal_header_util.F for detailed descriptions of all +! headers. +! +! We wish to be able to link to different packages depending on whether +! the I/O is restart, initial, history, or boundary. +! + USE module_state_description + USE module_quilt_outbuf_ops + USE module_configure, only : grid_config_rec_type, model_config_rec, model_to_grid_config_rec + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" +#include "wrf_io_flags.h" + TYPE (grid_config_rec_type) :: config_flags + INTEGER itag, ninbuf, ntasks_io_group, ntasks_local_group, mytask_local, ierr + INTEGER istat + INTEGER mytask_io_group + INTEGER :: nout_set = 0 + INTEGER :: obufsize, bigbufsize, chunksize, sz + REAL, DIMENSION(1) :: dummy + INTEGER, ALLOCATABLE, DIMENSION(:) :: obuf, bigbuf + REAL, ALLOCATABLE, DIMENSION(:) :: RDATA + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA + CHARACTER (LEN=512) :: CDATA + CHARACTER (LEN=80) :: fname + INTEGER icurs, hdrbufsize, itypesize, ftypesize, rtypesize, Status, fstat, io_form_arg + INTEGER :: DataHandle, FieldType, Comm, IOComm, DomainDesc, code, Count + INTEGER, DIMENSION(3) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd + INTEGER :: dummybuf(1) + INTEGER :: num_noops, num_commit_messages, num_field_training_msgs, hdr_tag + CHARACTER (len=256) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess + INTEGER, EXTERNAL :: use_package + LOGICAL :: stored_write_record, retval + INTEGER iii, jjj, vid, CC, DD, dom_id + LOGICAL :: call_server_ready + +logical okay_to_w +character*120 sysline + + dom_id = 1 ! always a valid assumption for domain id for this netcdf setting + CALL model_to_grid_config_rec ( dom_id , model_config_rec , config_flags ) + +! If we've been built with PNETCDF_QUILT defined then we use parallel I/O +! within the group of I/O servers rather than gathering the data onto the +! root I/O server. Unfortunately, this approach means that we can no-longer +! select different I/O layers for use with quilting at run time. ARPDBG. +! This code is sufficiently different that it is kept in the separate +! quilt_pnc() routine. +#ifdef PNETCDF_QUILT + CALL quilt_pnc() + RETURN +#endif + +! Call ext_pkg_ioinit() routines to initialize I/O packages. + SysDepInfo = " " +#ifdef NETCDF + if ( config_flags%use_netcdf_classic ) SysDepInfo="use_netcdf_classic" + CALL ext_ncd_ioinit( SysDepInfo, ierr ) + SysDepInfo = " " +#endif +#ifdef INTIO + CALL ext_int_ioinit( SysDepInfo, ierr ) +#endif +#ifdef XXX + CALL ext_xxx_ioinit( SysDepInfo, ierr) +#endif +#ifdef YYY + CALL ext_yyy_ioinit( SysDepInfo, ierr) +#endif +#ifdef ZZZ + CALL ext_zzz_ioinit( SysDepInfo, ierr) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioinit( SysDepInfo, ierr) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioinit( SysDepInfo, ierr) +#endif + + call_server_ready = .true. ! = true when the server is ready for a new file + + okay_to_commit = .false. + stored_write_record = .false. + ninbuf = 0 + ! get info. about the I/O server group that this I/O server task + ! belongs to + ! Last task in this I/O server group is the I/O server "root" + ! The I/O server "root" actually writes data to disk + ! TBH: WARNING: This is also implicit in the call to collect_on_comm(). + CALL mpi_x_comm_size( mpi_comm_io_groups(1), ntasks_io_group, ierr ) + CALL MPI_COMM_RANK( mpi_comm_io_groups(1), mytask_io_group, ierr ) + CALL mpi_x_comm_size( mpi_comm_local, ntasks_local_group, ierr ) + CALL MPI_COMM_RANK( mpi_comm_local, mytask_local, ierr ) + + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + IF ( itypesize <= 0 ) THEN + CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid") + ENDIF + +! Work out whether this i/o server processor has one fewer associated compute proc than +! the most any processor has. Can happen when number of i/o tasks does not evenly divide +! the number of compute tasks. This is needed to keep the i/o tasks sychronized on the +! same message when they start commmunicating to stitch together an output. +! +! Compute processes associated with this task: + CC = ntasks_io_group - 1 +! Number of compute tasks per I/O task (less remainder) + DD = ncompute_tasks / ntasks_local_group +! +! If CC-DD is 1 on servrs with the maximum number of compute clients, +! 0 on servrs with one less than maximum + + +! infinite loop until shutdown message received +! This is the main request-handling loop. I/O quilt servers stay in this loop +! until the model run ends. +okay_to_w = .false. + DO WHILE (.TRUE.) ! { + +! +! Each I/O server receives requests from its compute tasks. Each request +! is contained in a data header (see module_internal_header_util.F for +! detailed descriptions of data headers). +! Each request is sent in two phases. First, sizes of all messages that +! will be sent from the compute tasks to this I/O server are summed on the +! I/O server via MPI_reduce(). The I/O server then allocates buffer "obuf" +! and receives concatenated messages from the compute tasks in it via the +! call to collect_on_comm(). Note that "sizes" are generally expressed in +! *bytes* in this code so conversion to "count" (number of Fortran words) is +! required for Fortran indexing and MPI calls. +! + + if(poll_servers .and. call_server_ready) then + call_server_ready=.false. + ! Send a message to the monitor telling it we're ready + ! for a new data handle. + call wrf_quilt_server_ready() + endif + + ! wait for info from compute tasks in the I/O group that we're ready to rock + ! obufsize will contain number of *bytes* +!CALL start_timing() + ! first element of reduced is obufsize, second is DataHandle + ! if needed (currently needed only for ioclose). + reduced_dummy = 0 + CALL mpi_x_reduce( reduced_dummy, reduced, 2, MPI_INTEGER, MPI_SUM, mytask_io_group, mpi_comm_io_groups(1), ierr ) + obufsize = reduced(1) +!CALL end_timing("MPI_Reduce at top of forever loop") +!JMDEBUGwrite(0,*)'obufsize = ',obufsize +! Negative obufsize will trigger I/O server exit. + IF ( obufsize .LT. 0 ) THEN + IF ( obufsize .EQ. -100 ) THEN ! magic number +#ifdef NETCDF + CALL ext_ncd_ioexit( Status ) +#endif +#ifdef INTIO + CALL ext_int_ioexit( Status ) +#endif +#ifdef XXX + CALL ext_xxx_ioexit( Status ) +#endif +#ifdef YYY + CALL ext_yyy_ioexit( Status ) +#endif +#ifdef ZZZ + CALL ext_zzz_ioexit( Status ) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioexit( Status ) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioexit( Status ) +#endif + CALL wrf_message ( 'I/O QUILT SERVERS DONE' ) +#if ( DA_CORE != 1 ) + IF (coupler_on) THEN + CALL cpl_finalize() + ELSE +#endif + CALL mpi_finalize(ierr) +#if ( DA_CORE != 1 ) + END IF +#endif + STOP + ELSE + WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.' + CALL wrf_error_fatal(mess) + ENDIF + ENDIF + +! CALL start_timing() +! Obufsize of zero signals a close + +! Allocate buffer obuf to be big enough for the data the compute tasks +! will send. Note: obuf is size in *bytes* so we need to pare this +! down, since the buffer is INTEGER. + IF ( obufsize .GT. 0 ) THEN + ALLOCATE( obuf( (obufsize+1)/itypesize ) ) + +! let's roll; get the data from the compute procs and put in obuf + CALL collect_on_comm_debug(__FILE__,__LINE__, mpi_comm_io_groups(1), & + onebyte, & + dummy, 0, & + obuf, obufsize ) +! CALL end_timing( "quilt on server: collecting data from compute procs" ) + ELSE + ! Necessarily, the compute processes send the ioclose signal, + ! if there is one, after the iosync, which means they + ! will stall on the ioclose message waiting for the quilt + ! processes if we handle the way other messages are collected, + ! using collect_on_comm. This avoids this, but we need + ! a special signal (obufsize zero) and the DataHandle + ! to be closed. That handle is send as the second + ! word of the io_close message received by the MPI_Reduce above. + ! Then a header representing the ioclose message is constructed + ! here and handled below as if it were received from the + ! compute processes. The clients (compute processes) must be + ! careful to send this correctly (one compule process sends the actual + ! handle and everone else sends a zero, so the result sums to + ! the value of the handle). + ! + ALLOCATE( obuf( 4096 ) ) + ! DataHandle is provided as second element of reduced + CALL int_gen_handle_header( obuf, obufsize, itypesize, & + reduced(2) , int_ioclose ) + + if(poll_servers) then + ! Once we're done closing, we need to tell the master + ! process that we're ready for more data. + call_server_ready=.true. + endif + ENDIF + +!write(0,*)'calling init_store_piece_of_field' +! Now all messages received from the compute clients are stored in +! obuf. Scan through obuf and extract headers and field data and store in +! internal buffers. The scan is done twice, first to determine sizes of +! internal buffers required for storage of headers and fields and second to +! actually store the headers and fields. This bit of code does not do the +! "quilting" (assembly of patches into full domains). For each field, it +! simply concatenates all received patches for the field into a separate +! internal buffer (i.e. one buffer per field). Quilting is done later by +! routine store_patch_in_outbuf(). + CALL init_store_piece_of_field + CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr ) +!write(0,*)'mpi_type_size returns ', itypesize +! Scan obuf the first time to calculate the size of the buffer required for +! each field. Calls to add_to_bufsize_for_field() accumulate sizes. + vid = 0 + icurs = itypesize + num_noops = 0 + num_commit_messages = 0 + num_field_training_msgs = 0 + DO WHILE ( icurs .lt. obufsize ) ! { + hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) + SELECT CASE ( hdr_tag ) + CASE ( int_field ) + CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + + IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks + IF ( num_field_training_msgs .EQ. 0 ) THEN + call add_to_bufsize_for_field( VarName, hdrbufsize ) +!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + num_field_training_msgs = num_field_training_msgs + 1 + ELSE + call add_to_bufsize_for_field( VarName, hdrbufsize ) +!write(0,*) 'X-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + icurs = icurs + hdrbufsize + +!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + + ! If this is a real write (i.e. not a training write), accumulate + ! buffersize for this field. + IF ( DomainDesc .NE. 333933 ) THEN ! magic number +!write(0,*) 'X-1a', chunksize, TRIM(VarName) + call add_to_bufsize_for_field( VarName, chunksize ) + icurs = icurs + chunksize + ENDIF + CASE ( int_open_for_write_commit ) ! only one per group of tasks + hdrbufsize = obuf(icurs/itypesize) + IF (num_commit_messages.EQ.0) THEN + call add_to_bufsize_for_field( 'COMMIT', hdrbufsize ) + ENDIF + num_commit_messages = num_commit_messages + 1 + icurs = icurs + hdrbufsize + CASE DEFAULT + hdrbufsize = obuf(icurs/itypesize) + +! This logic and the logic in the loop below is used to determine whether +! to send a noop records sent by the compute processes to allow to go +! through. The purpose is to make sure that the communications between this +! server and the other servers in this quilt group stay synchronized in +! the collection loop below, even when the servers are serving different +! numbers of clients. Here are some conditions: +! +! 1. The number of compute clients served will not differ by more than 1 +! 2. The servers with +1 number of compute clients begin with task 0 +! of mpi_comm_local, the commicator shared by this group of servers +! +! 3. For each collective field or metadata output from the compute tasks, +! there will be one record sent to the associated i/o server task. The +! i/o server task collects these records and stores them contiguously +! in a buffer (obuf) using collect_on_comm above. Thus, obuf on this +! server task will contain one record from each associated compute +! task, in order. +! +! 4. In the case of replicated output from the compute tasks +! (e.g. put_dom_ti records and control records like +! open_for_write_commit type records), compute task 0 is the only +! one that sends the record. The other compute tasks send noop +! records. Thus, obuf on server task zero will contain the output +! record from task 0 followed by noop records from the rest of the +! compute tasks associated with task 0. Obuf on the other server +! tasks will contain nothing but noop records. +! +! 5. The logic below will not allow any noop records from server task 0. +! It allows only one noop record from each of the other server tasks +! in the i/o group. This way, for replicated output, when the records +! are collected on one server task below, using collect_on_comm on +! mpi_comm_local, each task will provide exactly one record for each +! call to collect_on_comm: 1 bona fide output record from server task +! 0 and noops from the rest. + + IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) & + .OR.hdr_tag.NE.int_noop) THEN + write(VarName,'(I5.5)')vid +!write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + call add_to_bufsize_for_field( VarName, hdrbufsize ) + vid = vid+1 + ENDIF + IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + icurs = icurs + hdrbufsize + END SELECT + ENDDO ! } +! Store the headers and field data in internal buffers. The first call to +! store_piece_of_field() allocates internal buffers using sizes computed by +! calls to add_to_bufsize_for_field(). + vid = 0 + icurs = itypesize + num_noops = 0 + num_commit_messages = 0 + num_field_training_msgs = 0 + DO WHILE ( icurs .lt. obufsize ) !{ +!write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize + hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) + SELECT CASE ( hdr_tag ) + CASE ( int_field ) + CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + + IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks + IF ( num_field_training_msgs .EQ. 0 ) THEN + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) +!write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + num_field_training_msgs = num_field_training_msgs + 1 + ELSE + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) +!write(0,*) 'A-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + icurs = icurs + hdrbufsize + ! If this is a real write (i.e. not a training write), store + ! this piece of this field. + IF ( DomainDesc .NE. 333933 ) THEN ! magic number +!write(0,*) 'A-1a', chunksize, TRIM(VarName),PatchStart(1:3),PatchEnd(1:3) + call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize ) + icurs = icurs + chunksize + ENDIF + CASE ( int_open_for_write_commit ) ! only one per group of tasks + hdrbufsize = obuf(icurs/itypesize) + IF (num_commit_messages.EQ.0) THEN + call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize ) + ENDIF + num_commit_messages = num_commit_messages + 1 + icurs = icurs + hdrbufsize + CASE DEFAULT + hdrbufsize = obuf(icurs/itypesize) + IF ((hdr_tag.EQ.int_noop.AND.mytask_local.NE.0.AND.num_noops.LE.0) & + .OR.hdr_tag.NE.int_noop) THEN + write(VarName,'(I5.5)')vid +!write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) + vid = vid+1 + ENDIF + IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + icurs = icurs + hdrbufsize + END SELECT + ENDDO !} + +! Now, for each field, retrieve headers and patches (data) from the internal +! buffers and collect them all on the I/O quilt server "root" task. + CALL init_retrieve_pieces_of_field +! Retrieve header and all patches for the first field from the internal +! buffers. + CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) +! Sum sizes of all headers and patches (data) for this field from all I/O +! servers in this I/O server group onto the I/O server "root". + CALL mpi_x_reduce( sz, bigbufsize, 1, MPI_INTEGER, MPI_SUM, ntasks_local_group-1, mpi_comm_local, ierr ) +!write(0,*)'seed: sz ',sz,' bigbufsize ',bigbufsize,' VarName ', TRIM(VarName),' retval ',retval + +! Loop until there are no more fields to retrieve from the internal buffers. + DO WHILE ( retval ) !{ +#if 0 +#else + +! I/O server "root" allocates space to collect headers and fields from all +! other servers in this I/O server group. + IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN + ALLOCATE( bigbuf( (bigbufsize+1)/itypesize ) ) + else + ALLOCATE( bigbuf(1) ) + ENDIF + +! Collect buffers and fields from all I/O servers in this I/O server group +! onto the I/O server "root" + CALL collect_on_comm_debug2(__FILE__,__LINE__,Trim(VarName), & + get_hdr_tag(obuf),sz,get_hdr_rec_size(obuf), & + mpi_comm_local, & + onebyte, & + obuf, sz, & + bigbuf, bigbufsize ) +! The I/O server "root" now handles collected requests from all compute +! tasks served by this I/O server group (i.e. all compute tasks). + IF ( mytask_local .EQ. ntasks_local_group-1 ) THEN +!jjj = 4 +!do iii = 1, ntasks_local_group +! write(0,*)'i,j,tag,size ', iii, jjj, get_hdr_tag(bigbuf(jjj/4)),get_hdr_rec_size(bigbuf(jjj/4)) +! jjj = jjj + get_hdr_rec_size(bigbuf(jjj/4)) +!enddo + + icurs = itypesize ! icurs is a byte counter, but buffer is integer + + stored_write_record = .false. + +! The I/O server "root" loops over the collected requests. + DO WHILE ( icurs .lt. bigbufsize ) !{ + CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr ) + +!write(0,*)'B tag,size ',icurs,get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) +! The I/O server "root" gets the request out of the next header and +! handles it by, in most cases, calling the appropriate external I/O package +! interface. + SELECT CASE ( get_hdr_tag( bigbuf(icurs/itypesize) ) ) +! The I/O server "root" handles the "noop" (do nothing) request. This is +! actually quite easy. "Noop" requests exist to help avoid race conditions. +! In some cases, only one compute task will everything about a request so +! other compute tasks send "noop" requests. + CASE ( int_noop ) + CALL int_get_noop_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize ) + icurs = icurs + hdrbufsize + +! The I/O server "root" handles the "put_dom_td_real" request. + CASE ( int_dom_td_real ) + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, DateStr, Element, RData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( RData ) +! The I/O server "root" handles the "put_dom_ti_real" request. + CASE ( int_dom_ti_real ) +!write(0,*)' int_dom_ti_real ' + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ALLOCATE( RData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, Element, RData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +!write(0,*)'ext_ncd_put_dom_ti_real ',handle(DataHandle),TRIM(Element),RData,Status +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( RData ) + +! The I/O server "root" handles the "put_dom_td_integer" request. + CASE ( int_dom_td_integer ) +!write(0,*)' int_dom_td_integer ' + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_td_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, DateStr, Element, IData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( IData ) + +! The I/O server "root" handles the "put_dom_ti_integer" request. + CASE ( int_dom_ti_integer ) +!write(0,*)' int_dom_ti_integer ' + + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + ALLOCATE( IData( bigbuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_ti_header( bigbuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, Element, IData, Count, code ) + icurs = icurs + hdrbufsize + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +!write(0,*)'ext_ncd_put_dom_ti_integer ',handle(DataHandle),TRIM(Element),IData,Status +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif + + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( IData) + +! The I/O server "root" handles the "set_time" request. + CASE ( int_set_time ) +!write(0,*)' int_set_time ' + CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_set_time ( handle(DataHandle), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + +! The I/O server "root" handles the "put_dom_ti_char" request. + CASE ( int_dom_ti_char ) +!write(0,*)' before int_get_ti_header_char ' + CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) +!write(0,*)' after int_get_ti_header_char ',VarName + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + +! The I/O server "root" handles the "put_var_ti_char" request. + CASE ( int_var_ti_char ) +!write(0,*)' int_var_ti_char ' + CALL int_get_ti_header_char( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + + CASE ( int_ioexit ) +! ioexit is now handled by sending negative message length to server + CALL wrf_error_fatal( & + "quilt: should have handled int_ioexit already") +! The I/O server "root" handles the "ioclose" request. + CASE ( int_ioclose ) + CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + + IF ( DataHandle .GE. 1 ) THEN + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_ncd_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef PNETCDF + CASE ( IO_PNETCDF ) + CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_pnc_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_int_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_yyy_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr1_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr2_ioclose(handle(DataHandle),Status) + ENDIF +#endif + CASE DEFAULT + Status = 0 + END SELECT + ENDIF + +! If desired, outputs a ready flag after quilting subroutine closes the data handle for history (wrfout) file. + + IF (fname(1:6) .EQ. 'wrfout' .AND. config_flags%output_ready_flag ) THEN + OPEN (unit=99,file='wrfoutReady' // fname(7:30), status='unknown', access='sequential') + CLOSE (99) + ENDIF + +! The I/O server "root" handles the "open_for_write_begin" request. + CASE ( int_open_for_write_begin ) + + CALL int_get_ofwb_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + FileName,SysDepInfo,io_form_arg,DataHandle ) + +!write(0,*)' int_open_for_write_begin itypesize ',itypesize,' itypesize ',itypesize +!write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize +!JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle +!write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo) + icurs = icurs + hdrbufsize +!write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) + + io_form(DataHandle) = io_form_arg + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +!write(0,*)'ext_ncd_open_for_write_begin ',Trim(FileName),DataHandle,handle(DataHandle),Status +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + okay_to_write(DataHandle) = .false. + +! The I/O server "root" handles the "open_for_write_commit" request. +! In this case, the "okay_to_commit" is simply set to .true. so "write_field" +! requests will initiate writes to disk. Actual commit will be done after +! all requests in this batch have been handled. + CASE ( int_open_for_write_commit ) + + CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + okay_to_commit(DataHandle) = .true. + +! The I/O server "root" handles the "write_field" (int_field) request. +! If okay_to_write(DataHandle) is .true. then the patch in the +! header (bigbuf) is written to a globally-sized internal output buffer via +! the call to store_patch_in_outbuf(). Note that this is where the actual +! "quilting" (reassembly of patches onto a full-size domain) is done. If +! okay_to_write(DataHandle) is .false. then external I/O package interfaces +! are called to write metadata for I/O formats that support native metadata. +! +! NOTE that the I/O server "root" will only see write_field (int_field) +! requests AFTER an "iosync" request. + CASE ( int_field ) + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + CALL int_get_write_field_header ( bigbuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) +!write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle) + icurs = icurs + hdrbufsize + + IF ( okay_to_write(DataHandle) ) THEN + +! WRITE(0,*)'>>> ',TRIM(DateStr), ' ', TRIM(VarName), ' ', TRIM(MemoryOrder), ' ', & +! (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)*(PatchEnd(3)-PatchStart(3)+1) + + IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN + ! Note that the WRF_DOUBLE branch of this IF statement must come first since + ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds. + IF ( FieldType .EQ. WRF_DOUBLE) THEN +! this branch has not been tested TBH: 20050406 + CALL mpi_type_size( MPI_DOUBLE_PRECISION, ftypesize, ierr ) + ELSE + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ENDIF + stored_write_record = .true. + CALL store_patch_in_outbuf ( bigbuf(icurs/itypesize), dummybuf, TRIM(DateStr), TRIM(VarName) , & + FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + stored_write_record = .true. + CALL store_patch_in_outbuf ( dummybuf, bigbuf(icurs/itypesize), TRIM(DateStr), TRIM(VarName) , & + FieldType, TRIM(MemoryOrder), TRIM(Stagger), DimNames, & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + ftypesize = LWORDSIZE + ENDIF + icurs = icurs + (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + ELSE + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_write_field ( handle(DataHandle) , TRIM(DateStr) , & + TRIM(VarName) , dummy , FieldType , Comm , IOComm, & + DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + Status ) +#endif +#if 0 +! since this is training and the grib output doesn't need training, disable this branch. +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_YYY_write_field ( handle(DataHandle) , TRIM(DateStr) , & + TRIM(VarName) , dummy , FieldType , Comm , IOComm, & + DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + Status ) +#endif +#endif + CASE DEFAULT + Status = 0 + END SELECT + ENDIF + CASE ( int_iosync ) + CALL int_get_handle_header( bigbuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + CASE DEFAULT + WRITE(mess,*)'quilt: bad tag: ',get_hdr_tag( bigbuf(icurs/itypesize) ),' icurs ',icurs/itypesize + CALL wrf_error_fatal( mess ) + END SELECT + + ENDDO !} +! Now, the I/O server "root" has finshed handling all commands from the latest +! call to retrieve_pieces_of_field(). + + IF (stored_write_record) THEN +! If any fields have been stored in a globally-sized internal output buffer +! (via a call to store_patch_in_outbuf()) then call write_outbuf() to write +! them to disk now. +! NOTE that the I/O server "root" will only have called +! store_patch_in_outbuf() when handling write_field (int_field) +! commands which only arrive AFTER an "iosync" command. +! CALL start_timing + CALL write_outbuf ( handle(DataHandle), use_package(io_form(DataHandle))) +! CALL end_timing( "quilt: call to write_outbuf" ) + ENDIF + +! If one or more "open_for_write_commit" commands were encountered from the +! latest call to retrieve_pieces_of_field() then call the package-specific +! routine to do the commit. + IF (okay_to_commit(DataHandle)) THEN + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_ncd_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_int_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_yyy_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr1_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr2_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif + + CASE DEFAULT + Status = 0 + END SELECT + + okay_to_commit(DataHandle) = .false. + ENDIF + DEALLOCATE( bigbuf ) + ENDIF +#endif + if(allocated(bigbuf)) deallocate(bigbuf) +! Retrieve header and all patches for the next field from the internal +! buffers. + CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) +! Sum sizes of all headers and patches (data) for this field from all I/O +! servers in this I/O server group onto the I/O server "root". + CALL mpi_x_reduce( sz, bigbufsize, 1, MPI_INTEGER,MPI_SUM, ntasks_local_group-1,mpi_comm_local, ierr ) +! Then, return to the top of the loop to collect headers and data from all +! I/O servers in this I/O server group onto the I/O server "root" and handle +! the next batch of commands. + END DO !} + + DEALLOCATE( obuf ) + + ! flush output files if needed + IF (stored_write_record) THEN +! CALL start_timing() + SELECT CASE ( use_package(io_form) ) +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_iosync( handle(DataHandle), Status ) +#endif +#ifdef XXX + CASE ( IO_XXX ) + CALL ext_xxx_iosync( handle(DataHandle), Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_iosync( handle(DataHandle), Status ) +#endif +#ifdef ZZZ + CASE ( IO_ZZZ ) + CALL ext_zzz_iosync( handle(DataHandle), Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_iosync( handle(DataHandle), Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_iosync( handle(DataHandle), Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_iosync( handle(DataHandle), Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT +!CALL end_timing( "quilt: flush" ) + ENDIF + + END DO ! } + + END SUBROUTINE quilt + + SUBROUTINE quilt_pnc +! +! Same as quilt() routine except that _all_ of the IO servers that call it +! actually write data to disk using pNetCDF. This version is only used when +! the code is compiled with PNETCDF_QUILT defined. +! + USE module_state_description + USE module_quilt_outbuf_ops + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" +#include "wrf_io_flags.h" + INTEGER itag, ninbuf, ntasks_io_group, ntasks_local_group, mytask_local, ierr + INTEGER istat + INTEGER mytask_io_group + INTEGER :: nout_set = 0 + INTEGER :: obufsize, bigbufsize, chunksize, sz + REAL, DIMENSION(1) :: dummy + INTEGER, ALLOCATABLE, DIMENSION(:) :: obuf, bigbuf + REAL, ALLOCATABLE, DIMENSION(:) :: RDATA + INTEGER, ALLOCATABLE, DIMENSION(:) :: IDATA + CHARACTER (LEN=512) :: CDATA + CHARACTER (LEN=80) :: fname + INTEGER icurs, hdrbufsize, itypesize, ftypesize, rtypesize, Status, fstat, io_form_arg + INTEGER :: DataHandle, FieldType, Comm, IOComm, DomainDesc, code, Count + INTEGER, DIMENSION(3) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd + INTEGER :: dummybuf(1) + INTEGER :: num_noops, num_commit_messages, num_field_training_msgs, hdr_tag + CHARACTER (len=256) :: DateStr , Element, VarName, MemoryOrder , Stagger , DimNames(3), FileName, SysDepInfo, mess + INTEGER, EXTERNAL :: use_package + LOGICAL :: stored_write_record, retval, written_record + INTEGER iii, jjj, vid, CC, DD + +! logical okay_to_w +! character*120 sysline + +! Call ext_pkg_ioinit() routines to initialize I/O packages. + SysDepInfo = " " +#ifdef NETCDF + CALL ext_ncd_ioinit( SysDepInfo, ierr) +#endif +#ifdef PNETCDF_QUILT + CALL ext_pnc_ioinit( SysDepInfo, ierr) +#endif +#ifdef INTIO + CALL ext_int_ioinit( SysDepInfo, ierr ) +#endif +#ifdef XXX + CALL ext_xxx_ioinit( SysDepInfo, ierr) +#endif +#ifdef YYY + CALL ext_yyy_ioinit( SysDepInfo, ierr) +#endif +#ifdef ZZZ + CALL ext_zzz_ioinit( SysDepInfo, ierr) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioinit( SysDepInfo, ierr) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioinit( SysDepInfo, ierr) +#endif + + okay_to_commit = .false. + stored_write_record = .false. + ninbuf = 0 + ! get info. about the I/O server group that this I/O server task + ! belongs to + CALL mpi_x_comm_size( mpi_comm_io_groups(1), ntasks_io_group, ierr ) + CALL MPI_COMM_RANK( mpi_comm_io_groups(1), mytask_io_group, ierr ) + CALL mpi_x_comm_size( mpi_comm_local, ntasks_local_group, ierr ) + CALL MPI_COMM_RANK( mpi_comm_local, mytask_local, ierr ) + + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + IF ( itypesize <= 0 ) THEN + CALL wrf_error_fatal("external/RSL/module_dm.F: quilt: type size <= 0 invalid") + ENDIF + +! Work out whether this i/o server processor has one fewer associated compute proc than +! the most any processor has. Can happen when number of i/o tasks does not evenly divide +! the number of compute tasks. This is needed to keep the i/o tasks sychronized on the +! same message when they start commmunicating to stitch together an output. +! +! Compute processes associated with this task: + CC = ntasks_io_group - 1 +! Number of compute tasks per I/O task (less remainder) + DD = ncompute_tasks / ntasks_local_group +! +! If CC-DD is 1 on servrs with the maximum number of compute clients, +! 0 on servrs with one less than maximum + + +! infinite loop until shutdown message received +! This is the main request-handling loop. I/O quilt servers stay in this loop +! until the model run ends. +!okay_to_w = .false. + DO WHILE (.TRUE.) ! { + +! +! Each I/O server receives requests from its compute tasks. Each request +! is contained in a data header (see module_internal_header_util.F for +! detailed descriptions of data headers). +! Each request is sent in two phases. First, sizes of all messages that +! will be sent from the compute tasks to this I/O server are summed on the +! I/O server via MPI_reduce(). The I/O server then allocates buffer "obuf" +! and receives concatenated messages from the compute tasks in it via the +! call to collect_on_comm(). Note that "sizes" are generally expressed in +! *bytes* in this code so conversion to "count" (number of Fortran words) is +! required for Fortran indexing and MPI calls. +! + ! wait for info from compute tasks in the I/O group that we're ready to rock + ! obufsize will contain number of *bytes* +!CALL start_timing + ! first element of reduced is obufsize, second is DataHandle + ! if needed (currently needed only for ioclose). + reduced_dummy = 0 + CALL mpi_x_reduce( reduced_dummy, reduced, 2, MPI_INTEGER, MPI_SUM, mytask_io_group, mpi_comm_io_groups(1), ierr ) + obufsize = reduced(1) +!CALL end_timing("MPI_Reduce at top of forever loop") +!JMDEBUGwrite(0,*)'obufsize = ',obufsize +! Negative obufsize will trigger I/O server exit. + IF ( obufsize .LT. 0 ) THEN + IF ( obufsize .EQ. -100 ) THEN ! magic number +#ifdef NETCDF + CALL ext_ncd_ioexit( Status ) +#endif +#ifdef PNETCDF_QUILT + CALL ext_pnc_ioexit( Status ) +#endif +#ifdef INTIO + CALL ext_int_ioexit( Status ) +#endif +#ifdef XXX + CALL ext_xxx_ioexit( Status ) +#endif +#ifdef YYY + CALL ext_yyy_ioexit( Status ) +#endif +#ifdef ZZZ + CALL ext_zzz_ioexit( Status ) +#endif +#ifdef GRIB1 + CALL ext_gr1_ioexit( Status ) +#endif +#ifdef GRIB2 + CALL ext_gr2_ioexit( Status ) +#endif + CALL wrf_message ( 'I/O QUILT SERVERS DONE' ) + CALL mpi_finalize(ierr) + STOP + ELSE + WRITE(mess,*)'Possible 32-bit overflow on output server. Try larger nio_tasks_per_group in namelist.' + CALL wrf_error_fatal(mess) + ENDIF + ENDIF + +! CALL start_timing +! Obufsize of zero signals a close + +! Allocate buffer obuf to be big enough for the data the compute tasks +! will send. Note: obuf is size in *bytes* so we need to pare this +! down, since the buffer is INTEGER. + IF ( obufsize .GT. 0 ) THEN + ALLOCATE( obuf( (obufsize+1)/itypesize ) ) + +! let's roll; get the data from the compute procs and put in obuf + CALL collect_on_comm_debug(__FILE__,__LINE__, mpi_comm_io_groups(1), & + onebyte, & + dummy, 0, & + obuf, obufsize ) +! CALL end_timing( "quilt on server: collecting data from compute procs" ) + ELSE + ! Necessarily, the compute processes send the ioclose signal, + ! if there is one, after the iosync, which means they + ! will stall on the ioclose message waiting for the quilt + ! processes if we handle the way other messages are collected, + ! using collect_on_comm. This avoids this, but we need + ! a special signal (obufsize zero) and the DataHandle + ! to be closed. That handle is send as the second + ! word of the io_close message received by the MPI_Reduce above. + ! Then a header representing the ioclose message is constructed + ! here and handled below as if it were received from the + ! compute processes. The clients (compute processes) must be + ! careful to send this correctly (one compule process sends the actual + ! handle and everone else sends a zero, so the result sums to + ! the value of the handle). + ! + ALLOCATE( obuf( 4096 ) ) + ! DataHandle is provided as second element of reduced + CALL int_gen_handle_header( obuf, obufsize, itypesize, & + reduced(2) , int_ioclose ) + ENDIF + +!write(0,*)'calling init_store_piece_of_field' +! Now all messages received from the compute clients are stored in +! obuf. Scan through obuf and extract headers and field data and store in +! internal buffers. The scan is done twice, first to determine sizes of +! internal buffers required for storage of headers and fields and second to +! actually store the headers and fields. This bit of code does not do any +! "quilting" (assembly of patches into full domains). For each field, it +! simply writes all received patches for the field to disk. +! ARPDBG we can vastly reduce the number of writes to disk by stitching +! any contiguous patches together first. Has implications for synchronisation +! of pNetCDF calls though. + CALL init_store_piece_of_field + CALL mpi_type_size ( MPI_INTEGER , itypesize , ierr ) +!write(0,*)'mpi_type_size returns ', itypesize +! Scan obuf the first time to calculate the size of the buffer required for +! each field. Calls to add_to_bufsize_for_field() accumulate sizes. + vid = 0 + icurs = itypesize + num_noops = 0 + num_commit_messages = 0 + num_field_training_msgs = 0 + DO WHILE ( icurs .lt. obufsize ) ! { + hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) + SELECT CASE ( hdr_tag ) + CASE ( int_field ) + CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + + IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks + IF ( num_field_training_msgs .EQ. 0 ) THEN + call add_to_bufsize_for_field( VarName, hdrbufsize ) +!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + num_field_training_msgs = num_field_training_msgs + 1 + ELSE + call add_to_bufsize_for_field( VarName, hdrbufsize ) +!write(0,*) 'X-2a', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + icurs = icurs + hdrbufsize + +!write(0,*) 'X-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + + ! If this is a real write (i.e. not a training write), accumulate + ! buffersize for this field. + IF ( DomainDesc .NE. 333933 ) THEN ! magic number +!write(0,*) 'X-1a', chunksize, TRIM(VarName) + call add_to_bufsize_for_field( VarName, chunksize ) + icurs = icurs + chunksize + ENDIF + CASE ( int_open_for_write_commit ) ! only one per group of tasks + hdrbufsize = obuf(icurs/itypesize) + IF (num_commit_messages.EQ.0) THEN + call add_to_bufsize_for_field( 'COMMIT', hdrbufsize ) + ENDIF + num_commit_messages = num_commit_messages + 1 + icurs = icurs + hdrbufsize + CASE DEFAULT + hdrbufsize = obuf(icurs/itypesize) + +! This logic and the logic in the loop below is used to determine whether +! to send a noop records sent by the compute processes to allow to go +! through. The purpose is to make sure that the communications between this +! server and the other servers in this quilt group stay synchronized in +! the collection loop below, even when the servers are serving different +! numbers of clients. Here are some conditions: +! +! 1. The number of compute clients served will not differ by more than 1 +! 2. The servers with +1 number of compute clients begin with task 0 +! of mpi_comm_local, the commicator shared by this group of servers +! +! 3. For each collective field or metadata output from the compute tasks, +! there will be one record sent to the associated i/o server task. The +! i/o server task collects these records and stores them contiguously +! in a buffer (obuf) using collect_on_comm above. Thus, obuf on this +! server task will contain one record from each associated compute +! task, in order. +! ! +! 4. In the case of replicated output from the compute tasks +! (e.g. put_dom_ti records and control records like +! open_for_write_commit type records), only compute tasks for which +! (compute_group_master == .TRUE) send the record. The other compute +! tasks send noop records. This is done so that each server task +! receives exactly one record plus noops from the other compute tasks. +! +! 5. Logic below does not allow any noop records through since each IO +! server task now receives a valid record (from the 'compute-group master' +! when doing replicated output + IF (hdr_tag.NE.int_noop) THEN + write(VarName,'(I5.5)')vid +!write(0,*) 'X-2', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + call add_to_bufsize_for_field( VarName, hdrbufsize ) + vid = vid+1 + ENDIF + IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + icurs = icurs + hdrbufsize + + END SELECT + ENDDO ! } +! Store the headers and field data in internal buffers. The first call to +! store_piece_of_field() allocates internal buffers using sizes computed by +! calls to add_to_bufsize_for_field(). + vid = 0 + icurs = itypesize + num_noops = 0 + num_commit_messages = 0 + num_field_training_msgs = 0 + DO WHILE ( icurs .lt. obufsize ) !{ +!write(0,*) 'A icurs ', icurs, ' obufsize ', obufsize + hdr_tag = get_hdr_tag( obuf ( icurs / itypesize ) ) + SELECT CASE ( hdr_tag ) + CASE ( int_field ) + CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + chunksize = (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + + IF ( DomainDesc .EQ. 333933 ) THEN ! Training write, only one per group of tasks + IF ( num_field_training_msgs .EQ. 0 ) THEN + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) +!write(0,*) 'A-1', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + num_field_training_msgs = num_field_training_msgs + 1 + ELSE + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) +!write(0,*) 'A-2a', icurs, hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + ENDIF + icurs = icurs + hdrbufsize + ! If this is a real write (i.e. not a training write), store + ! this piece of this field. + IF ( DomainDesc .NE. 333933 ) THEN ! magic number + call store_piece_of_field( obuf(icurs/itypesize), VarName, chunksize ) + icurs = icurs + chunksize +!write(0,*) 'A-1a',TRIM(VarName),' icurs ',icurs,PatchStart(1:3),PatchEnd(1:3) + ENDIF + CASE ( int_open_for_write_commit ) ! only one per group of tasks + hdrbufsize = obuf(icurs/itypesize) + IF (num_commit_messages.EQ.0) THEN + call store_piece_of_field( obuf(icurs/itypesize), 'COMMIT', hdrbufsize ) + ENDIF + num_commit_messages = num_commit_messages + 1 + icurs = icurs + hdrbufsize + CASE DEFAULT + hdrbufsize = obuf(icurs/itypesize) + IF (hdr_tag.NE.int_noop) THEN + + write(VarName,'(I5.5)')vid +!write(0,*) 'A-2b', hdrbufsize, get_hdr_tag( obuf ( icurs / itypesize ) ) , get_hdr_rec_size( obuf ( icurs / itypesize ) ), TRIM(VarName) + call store_piece_of_field( obuf(icurs/itypesize), VarName, hdrbufsize ) + vid = vid+1 + ENDIF + IF ( hdr_tag .EQ. int_noop ) num_noops = num_noops + 1 + icurs = icurs + hdrbufsize + END SELECT + ENDDO !} while(icurs < obufsize) + +! Now, for each field, retrieve headers and patches (data) from the internal +! buffers + CALL init_retrieve_pieces_of_field +! Retrieve header and all patches for the first field from the internal +! buffers. + CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) + written_record = .false. + +! Loop until there are no more fields to retrieve from the internal buffers. + DO WHILE ( retval ) !{ + +! This I/O server now handles the collected requests from the compute +! tasks it serves + + icurs = itypesize ! icurs is a byte counter, but buffer is integer + + stored_write_record = .false. + +! ALL I/O servers in this group loop over the collected requests they have +! received. + DO WHILE ( icurs .lt. sz)! bigbufsize ) !{ + +! The I/O server gets the request out of the next header and +! handles it by, in most cases, calling the appropriate external I/O package +! interface. +!write(0,*)__FILE__,__LINE__,'get_hdr_tag ',icurs,sz,get_hdr_tag( obuf(icurs/itypesize) ) + SELECT CASE ( get_hdr_tag( obuf(icurs/itypesize) ) ) +! The I/O server handles the "noop" (do nothing) request. This is +! actually quite easy. "Noop" requests exist to help avoid race conditions. + CASE ( int_noop ) + CALL int_get_noop_header( obuf(icurs/itypesize), & + hdrbufsize, itypesize ) + icurs = icurs + hdrbufsize + +! The I/O server "root" handles the "put_dom_td_real" request. + CASE ( int_dom_td_real ) + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_td_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, DateStr, Element, RData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_td_real( handle(DataHandle),TRIM(Element),TRIM(DateStr),RData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( RData ) +! Every I/O server handles the "put_dom_ti_real" request. + CASE ( int_dom_ti_real ) + + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ALLOCATE( RData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_ti_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, Element, RData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_real( handle(DataHandle),TRIM(Element), RData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( RData ) + +! Every I/O server handles the "put_dom_td_integer" request. + CASE ( int_dom_td_integer ) + + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_td_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, DateStr, Element, IData, Count, code ) + icurs = icurs + hdrbufsize + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_td_integer( handle(DataHandle),TRIM(Element), Trim(DateStr), IData, Count, Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( IData ) + +! Every I/O server handles the "put_dom_ti_integer" request. + CASE ( int_dom_ti_integer ) + + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + ALLOCATE( IData( obuf(icurs/itypesize + 4 ) ) ) ! 5 is the count of data items for this record ; defined in collect_on_comm.c + CALL int_get_ti_header( obuf(icurs/itypesize:), hdrbufsize, itypesize, ftypesize, & + DataHandle, Element, IData, Count, code ) + icurs = icurs + hdrbufsize + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_integer( handle(DataHandle),TRIM(Element), IData, Count, Status ) +#endif + + CASE DEFAULT + Status = 0 + END SELECT + + DEALLOCATE( IData) + +! Every I/O server handles the "set_time" request. + CASE ( int_set_time ) + + CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_set_time ( handle(DataHandle), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + +! Every I/O server handles the "put_dom_ti_char" request. + CASE ( int_dom_ti_char ) + + CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_dom_ti_char ( handle(DataHandle), TRIM(Element), Trim(CData), Status) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_dom_ti_char ( handle(DataHandle), TRIM(Element), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + +! Every I/O server handles the "put_var_ti_char" request. + CASE ( int_var_ti_char ) + + CALL int_get_ti_header_char( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle, Element, VarName, CData, code ) + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_put_var_ti_char ( handle(DataHandle), TRIM(Element), TRIM(VarName), TRIM(CData), Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + icurs = icurs + hdrbufsize + + CASE ( int_ioexit ) +! ioexit is now handled by sending negative message length to server + CALL wrf_error_fatal( & + "quilt: should have handled int_ioexit already") +! Every I/O server handles the "ioclose" request. + CASE ( int_ioclose ) + CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + + IF ( DataHandle .GE. 1 ) THEN + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE ( IO_PNETCDF ) + CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_pnc_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_ncd_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_int_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_yyy_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr1_ioclose(handle(DataHandle),Status) + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_FOR_WRITE .OR. fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr2_ioclose(handle(DataHandle),Status) + ENDIF +#endif + CASE DEFAULT + Status = 0 + END SELECT + ENDIF + +! Every I/O server handles the "open_for_write_begin" request. + CASE ( int_open_for_write_begin ) + + CALL int_get_ofwb_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & + FileName,SysDepInfo,io_form_arg,DataHandle ) + +!write(0,*)' int_open_for_write_begin itypesize ',itypesize,' itypesize ',itypesize +!write(0,*)' int_open_for_write_begin icurs ', icurs, hdrbufsize +!JMDEBUGwrite(0,*)' int_open_for_write_begin FileName ',TRIM(FileName) , ' DataHandle ', DataHandle +!write(0,*)' int_open_for_write_begin SysDepInfo ',TRIM(SysDepInfo) + icurs = icurs + hdrbufsize +!write(0,*)' int_open_for_write_begin new icurs,tag,size ', icurs, get_hdr_tag( bigbuf(icurs/itypesize) ),get_hdr_rec_size( bigbuf(icurs/itypesize) ) + + io_form(DataHandle) = io_form_arg + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE (IO_PNETCDF ) + CALL ext_pnc_open_for_write_begin(FileName,mpi_comm_local,mpi_comm_local,SysDepInfo,handle(DataHandle),Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +!write(0,*)'ext_ncd_open_for_write_begin ',Trim(FileName),DataHandle,handle(DataHandle),Status +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,handle(DataHandle),Status) +#endif + CASE DEFAULT + Status = 0 + END SELECT + + okay_to_write(DataHandle) = .false. + +! Every I/O server handles the "open_for_write_commit" request. +! In this case, the "okay_to_commit" is simply set to .true. so "write_field" +! (int_field) requests will initiate writes to disk. Actual commit will be done after +! all requests in this batch have been handled. + CASE ( int_open_for_write_commit ) + + CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + okay_to_commit(DataHandle) = .true. + +! Every I/O server handles the "write_field" (int_field) request. +! If okay_to_write(DataHandle) is .true. then the patch in the +! header (bigbuf) is written to disk using pNetCDF. Note that this is where the actual +! "quilting" (reassembly of patches onto a full-size domain) is done. If +! okay_to_write(DataHandle) is .false. then external I/O package interfaces +! are called to write metadata for I/O formats that support native metadata. +! +! NOTE that the I/O servers will only see write_field (int_field) +! requests AFTER an "iosync" request. + CASE ( int_field ) + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) + CALL int_get_write_field_header ( obuf(icurs/itypesize), hdrbufsize, itypesize, ftypesize, & + DataHandle , DateStr , VarName , Dummy , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) +!write(0,*)' int_field ',TRIM(VarName),DataHandle,okay_to_write(DataHandle) + icurs = icurs + hdrbufsize + + IF ( okay_to_write(DataHandle) ) THEN + +!!$ WRITE(0,FMT="('>>> ',(A),1x,(A),1x,A2,I6,1x,3('[',I3,',',I3,'] '))") & +!!$ TRIM(DateStr), TRIM(VarName), TRIM(MemoryOrder), & +!!$ (PatchEnd(1)-PatchStart(1)+1)*(PatchEnd(2)-PatchStart(2)+1)*(PatchEnd(3)-PatchStart(3)+1), & +!!$PatchStart(1),PatchEnd(1),PatchStart(2),PatchEnd(2),PatchStart(3),PatchEnd(3) +!!$ WRITE(0,FMT="('>>> ',(A),1x,(A),1x,I6,1x,3('[',I3,',',I3,'] '))") & +!!$ TRIM(DateStr), TRIM(VarName), DomainDesc, & +!!$ DomainStart(1),DomainEnd(1),DomainStart(2),DomainEnd(2),DomainStart(3),DomainEnd(3) + + IF ( FieldType .EQ. WRF_FLOAT .OR. FieldType .EQ. WRF_DOUBLE) THEN + ! Note that the WRF_DOUBLE branch of this IF statement must come first since + ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds. + IF ( FieldType .EQ. WRF_DOUBLE) THEN +! this branch has not been tested TBH: 20050406 + CALL mpi_type_size( MPI_DOUBLE_PRECISION, ftypesize, ierr ) + ELSE + CALL mpi_type_size( MPI_REAL, ftypesize, ierr ) + ENDIF + +#ifdef PNETCDF_QUILT +! WRITE(mess,FMT="('>>> ',(A),1x,(A),1x,I6,1x,3('[',I3,',',I3,'] '))") & +! TRIM(DateStr), TRIM(VarName), DomainDesc, & +! DomainStart(1),DomainEnd(1), & +! DomainStart(2),DomainEnd(2),DomainStart(3),DomainEnd(3) +! CALL wrf_message(mess) + + CALL store_patch_in_outbuf_pnc(obuf(icurs/itypesize), & + dummybuf, TRIM(DateStr), & + TRIM(VarName) , & + FieldType, & + TRIM(MemoryOrder), & + TRIM(Stagger), & + DimNames, & + DomainStart , DomainEnd ,& + MemoryStart , MemoryEnd ,& + PatchStart , PatchEnd, & + ntasks_io_group-1 ) + stored_write_record = .true. + +!!$ IF(VarName .eq. "PSFC")THEN +!!$ CALL dump_real_array_c(obuf(icurs/itypesize), DomainStart,& +!!$ DomainEnd, PatchStart, PatchEnd, & +!!$ mytask_local, DomainDesc) +!!$ ENDIF + +#endif + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL mpi_type_size( MPI_INTEGER, ftypesize, ierr ) +#ifdef PNETCDF_QUILT + CALL store_patch_in_outbuf_pnc ( dummybuf, & + obuf(icurs/itypesize) , & + TRIM(DateStr) , & + TRIM(VarName) , & + FieldType, & + TRIM(MemoryOrder) , & + TRIM(Stagger), DimNames, & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + ntasks_io_group-1 ) + stored_write_record = .true. +#endif + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + ftypesize = LWORDSIZE + ENDIF + + icurs = icurs + (PatchEnd(1)-PatchStart(1)+1)* & + (PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1)*ftypesize + + ELSE ! Write metadata only (or do 'training'?) + + SELECT CASE (use_package(io_form(DataHandle))) + +#ifdef PNETCDF_QUILT + CASE ( IO_PNETCDF ) + CALL ext_pnc_write_field ( handle(DataHandle) , TRIM(DateStr), & + TRIM(VarName) , dummy , FieldType , mpi_comm_local , mpi_comm_local, & + DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger), DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd, & + Status ) +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_write_field ( handle(DataHandle) , TRIM(DateStr) , & + TRIM(VarName) , dummy , FieldType , Comm , IOComm, & + DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + Status ) +#endif +#if 0 +! since this is training and the grib output doesn't need training, disable this branch. +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_YYY_write_field ( handle(DataHandle) , TRIM(DateStr) , & + TRIM(VarName) , dummy , FieldType , Comm , IOComm, & + DomainDesc , TRIM(MemoryOrder) , TRIM(Stagger) , DimNames , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + DomainStart , DomainEnd , & + Status ) +#endif +#endif + CASE DEFAULT + Status = 0 + END SELECT + ENDIF + CASE ( int_iosync ) + CALL int_get_handle_header( obuf(icurs/itypesize), hdrbufsize, itypesize, & + DataHandle , code ) + icurs = icurs + hdrbufsize + CASE DEFAULT + WRITE(mess,*)'quilt: bad tag: ', & + get_hdr_tag( obuf(icurs/itypesize) ),' icurs ',& + icurs/itypesize + CALL wrf_error_fatal( mess ) + END SELECT + + ENDDO !} +! Now, we have finshed handling all commands from the latest +! call to retrieve_pieces_of_field(). + + IF (stored_write_record) THEN +! If any field patches have been stored in internal output buffers +! (via a call to store_patch_in_outbuf_pnc()) then call write_outbuf_pnc() +! to write them to disk now. +! NOTE that the I/O server will only have called +! store_patch_in_outbuf() when handling write_field (int_field) +! commands which only arrive AFTER an "iosync" command. +! CALL start_timing +#ifdef PNETCDF_QUILT + CALL write_outbuf_pnc( handle(DataHandle), & + use_package(io_form(DataHandle)), & + mpi_comm_local, mytask_local, & + ntasks_local_group) +#endif +! CALL end_timing( "quilt_pnc: call to write_outbuf_pnc" ) + stored_write_record = .false. + written_record = .true. + ENDIF + +! If one or more "open_for_write_commit" commands were encountered from the +! latest call to retrieve_pieces_of_field() then call the package-specific +! routine to do the commit. + IF (okay_to_commit(DataHandle)) THEN + + SELECT CASE (use_package(io_form(DataHandle))) +#ifdef PNETCDF_QUILT + CASE ( IO_PNETCDF ) + CALL ext_pnc_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_pnc_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef NETCDF + CASE ( IO_NETCDF ) + CALL ext_ncd_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_ncd_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef INTIO + CASE ( IO_INTIO ) + CALL ext_int_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_int_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef YYY + CASE ( IO_YYY ) + CALL ext_yyy_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_yyy_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef GRIB1 + CASE ( IO_GRIB1 ) + CALL ext_gr1_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr1_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif +#ifdef GRIB2 + CASE ( IO_GRIB2 ) + CALL ext_gr2_inquire_filename( handle(DataHandle), fname, fstat, Status ) + IF ( fstat .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) THEN + CALL ext_gr2_open_for_write_commit(handle(DataHandle),Status) + okay_to_write(DataHandle) = .true. + ENDIF +#endif + + CASE DEFAULT + Status = 0 + END SELECT + + okay_to_commit(DataHandle) = .false. + ENDIF +!!endif + +! Retrieve header and all patches for the next field from the internal +! buffers. + CALL retrieve_pieces_of_field ( obuf , VarName, obufsize, sz, retval ) + END DO !} + + DEALLOCATE( obuf ) + + ! flush output files if needed + IF (written_record) THEN +!CALL start_timing + SELECT CASE ( use_package(io_form) ) +#ifdef PNETCDF_QUILT + CASE ( IO_PNETCDF ) + CALL ext_pnc_iosync( handle(DataHandle), Status ) +#endif + CASE DEFAULT + Status = 0 + END SELECT + written_record = .false. +!CALL end_timing( "quilt_pnc: flush" ) + ENDIF + + END DO ! } + + END SUBROUTINE quilt_pnc + +! end of #endif of DM_PARALLEL +#endif + + SUBROUTINE init_module_wrf_quilt + USE module_wrf_error, only: init_module_wrf_error + USE module_driver_constants +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_dm, only: mpi_comm_allcompute +#endif +! +! Both client (compute) and server tasks call this routine to initialize the +! module. Routine setup_quilt_servers() is called from this routine to +! determine which tasks are compute tasks and which are server tasks. Server +! tasks then call routine quilt() and remain there for the rest of the model +! run. Compute tasks return from init_module_wrf_quilt() to perform model +! computations. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INCLUDE 'mpif.h' + INTEGER i + NAMELIST /namelist_quilt/ nio_tasks_per_group, nio_groups, poll_servers + INTEGER ntasks, mytask, ierr, io_status +# if defined(_OPENMP) && defined(MPI2_THREAD_SUPPORT) + INTEGER thread_support_provided, thread_support_requested +# endif + INTEGER mpi_comm_here, temp_poll + LOGICAL mpi_inited + LOGICAL esmf_coupling + +!!!!! needed to sneak-peek the namelist to get parent_id +! define as temporaries +# include "namelist_defines.inc" + +! Statements that specify the namelists +# include "namelist_statements.inc" +!TODO: Change this to run-time switch +# ifdef ESMFIO + esmf_coupling = .TRUE. +# else + esmf_coupling = .FALSE. +# endif + + quilting_enabled = .FALSE. + IF ( disable_quilt ) RETURN + + DO i = 1,int_num_handles + okay_to_write(i) = .FALSE. + int_handle_in_use(i) = .FALSE. + server_for_handle(i) = 0 + int_num_bytes_to_write(i) = 0 + ENDDO + + CALL MPI_INITIALIZED( mpi_inited, ierr ) + IF ( .NOT. mpi_inited ) THEN + CALL WRF_ERROR_FATAL( "module_io_quilt_old.F : MPI not init'd" ) + ENDIF + CALL wrf_get_dm_quilt_comm( mpi_comm_here ) ! jm 20151212 + + CALL MPI_Comm_rank( mpi_comm_here, mytask, ierr ) ; + CALL mpi_x_comm_size( mpi_comm_here, ntasks, ierr ) ; + + IF ( mytask .EQ. 0 ) THEN + OPEN ( unit=27, file="namelist.input", form="formatted", status="old" ) + nio_groups = 1 + nio_tasks_per_group = 0 + poll_servers = .false. + READ ( 27 , NML = namelist_quilt, IOSTAT=io_status ) + IF (io_status .NE. 0) THEN + CALL wrf_error_fatal( "ERROR reading namelist namelist_quilt" ) + ENDIF + REWIND(27) + nproc_x = -1 + nproc_y = -1 + READ ( UNIT = 27 , NML = domains , IOSTAT=io_status ) + IF (io_status .NE. 0) THEN + CALL wrf_error_fatal( "ERROR reading namelist domains" ) + ENDIF + CLOSE ( 27 ) + IF ( esmf_coupling ) THEN + IF ( nio_tasks_per_group > 0 ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: cannot use "// & + "ESMF coupling with quilt tasks") ; + ENDIF + ENDIF + if(poll_servers) then + temp_poll=1 + else + temp_poll=0 + endif + ENDIF + + CALL mpi_bcast( nio_tasks_per_group , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nio_groups , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( temp_poll , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nproc_x , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + CALL mpi_bcast( nproc_y , 1 , MPI_INTEGER , 0 , mpi_comm_here, ierr ) + + poll_servers = (temp_poll == 1) + + CALL setup_quilt_servers( nio_tasks_per_group, & + mytask, & + ntasks, & + nproc_x, & + nproc_y, & + nio_groups, & + nio_tasks_in_group, & + mpi_comm_here, & + mpi_comm_local, & + mpi_comm_io_groups) + + call init_module_wrf_error(on_io_server=.true.) + + ! provide the communicator for the integration tasks to RSL + IF ( compute_node ) THEN +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + mpi_comm_allcompute = mpi_comm_local +#endif + CALL wrf_set_dm_communicator( mpi_comm_local ) +# if ( DA_CORE != 1 ) + IF (coupler_on) CALL cpl_set_dm_communicator( mpi_comm_local ) +# endif + ELSE +# if ( DA_CORE != 1 ) + IF (coupler_on) CALL cpl_set_dm_communicator( MPI_COMM_NULL ) +# endif + CALL quilt ! will not return on io server tasks + ENDIF +#endif + RETURN + END SUBROUTINE init_module_wrf_quilt + + +#ifdef IBM_REDUCE_BUG_WORKAROUND + + ! These three subroutines re-implement MPI_Reduce on MPI_INTEGER + ! with OP=MPI_ADD. + + ! This is a workaround for a bug in the IBM MPI implementation. + ! Some MPI processes will get stuck in MPI_Reduce and not + ! return until the PREVIOUS I/O server group finishes writing. + + ! This workaround replaces the MPI_Reduce call with many + ! MPI_Send and MPI_Recv calls that perform the sum on the + ! root of the communicator. + + ! There are two reduce routines: one for a sum of scalars + ! and one for a sum of arrays. The get_reduce_tag generates + ! MPI tags for the communication. + + integer function get_reduce_tag(root,comm) + implicit none + include 'mpif.h' + integer, intent(in) :: comm,root + integer :: i,j, tag, here + integer :: ierr,me,size + + integer, pointer :: nexttags(:) + integer, target :: dummy(1) + character(255) :: message + integer(kind=4) :: comm4,hashed + + integer, parameter :: hashsize = 113 ! should be prime, >max_servers+1 + integer, parameter :: tagloop = 100000 ! number of tags reserved per communicator + integer, parameter :: origin = 1031102 ! lowest tag number we'll use + integer, save :: nexttag=origin ! next tag to use for a new communicator + integer, save :: comms(hashsize)=-1, firsttag(hashsize)=0, curtag(hashsize)=0 + + ! If integers are not four bytes, this implementation will still + ! work, but it may be inefficient (O(N) lookup instead of O(1)). + ! To fix that, an eight byte hash function would be needed, but + ! integers are four bytes in WRF, so that is not a problem right + ! now. + + comm4=comm + call int_hash(comm4,hashed) + hashed=mod(abs(hashed),hashsize)+1 + if(hashed<0) call wrf_error_fatal('hashed<0') + + do i=0,hashsize-1 + j=1+mod(i+hashed-1,hashsize) + + if(firsttag(j)/=0 .and. comms(j)==comm) then + ! Found the communicator + if(curtag(j)-firsttag(j) >= tagloop) then + ! Hit the max tag number so we need to reset. + ! To make sure >tagloop reduces don't happen + ! before someone finishes an old reduce, we + ! have an MPI_Barrier here. + !call wrf_message('Hit tagloop limit so calling mpi_barrier in get_reduce_tag...') + call mpi_barrier(comm,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_barrier') + !call wrf_message(' ...back from mpi_barrier in get_reduce_tag.') + + curtag(j)=firsttag(j) + endif + + tag=curtag(j) + curtag(j)=tag+1 + get_reduce_tag=tag + return + endif + enddo + + + ! ==================== HANDLE NEW COMMUNICATORS ==================== + + !write(message,'("Found a new communicator ",I0," in get_reduce_tag, so making a tag range for it")') comm + + ! If we get here, the communicator is new to us, so we need + ! to add it to the hash and give it a new tag. + + ! First, figure out where we'll put the tag in the hashtable + here=-1 + do i=0,hashsize-1 + j=1+mod(i+hashed-1,hashsize) + + if(firsttag(j)==0) then + here=j + exit + endif + enddo + if(here==-1) call wrf_error_fatal('no room in hashtable; increase hashsize in get_reduce_tag (should be >max_servers+1)') + + ! Now, find out the new tag's number. To do this, we need to + ! get the next tag number that is not used by any ranks. + + call mpi_comm_rank(comm,me,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank') + + call mpi_comm_size(comm,size,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size') + + if(me==root) then + allocate(nexttags(size)) + else + nexttags=>dummy + endif + + call mpi_gather(nexttag,1,MPI_INTEGER,nexttags,1,MPI_INTEGER,root,comm,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_gather') + + if(me==root) then + nexttag=max(nexttag,maxval(nexttags)) + deallocate(nexttags) + endif + call mpi_bcast(nexttag,1,MPI_INTEGER,root,comm,ierr) + + comms(here)=comm + firsttag(here)=nexttag + curtag(here)=nexttag + get_reduce_tag=nexttag + + !write(message,'("Stored comm ",I0," with tag ",I0,"=",I0," in hash element ",I0)') & + ! comms(here),firsttag(here),curtag(here),here + !call wrf_message(message) + + nexttag=nexttag+tagloop + + end function get_reduce_tag + subroutine reduce_add_int_scl(send,recv,count,root,comm) + implicit none + include 'mpif.h' + integer, intent(in) :: count,root,comm + integer, intent(inout) :: recv + integer, intent(in) :: send + integer :: me, size, ierr, you, temp, tag + character*255 :: message + if(root<0) call wrf_error_fatal('root is less than 0') + + tag=get_reduce_tag(root,comm) + + !write(message,'("Send/recv to tag ",I0)') tag + !call wrf_message(message) + + call mpi_comm_rank(comm,me,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank') + + call mpi_comm_size(comm,size,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size') + + if(root>=size) call wrf_error_fatal('root is beyond highest communicator rank') + + if(me==root) then + recv=send + do you=0,size-2 + call mpi_recv(temp,1,MPI_INTEGER,MPI_ANY_SOURCE,tag,comm,MPI_STATUS_IGNORE,ierr) + if(ierr/=0) call wrf_error_fatal('error calling mpi_recv') + recv=recv+temp + enddo + else + call mpi_send(send,1,MPI_INTEGER,root,tag,comm,ierr) + if(ierr/=0) call wrf_error_fatal('error calling mpi_send') + endif + end subroutine reduce_add_int_scl + subroutine reduce_add_int_arr(sendbuf,recvbuf,count,root,comm) + implicit none + include 'mpif.h' + integer, intent(in) :: count,root,comm + integer, intent(in) :: sendbuf(count) + integer, intent(inout) :: recvbuf(count) + integer :: me, size, ierr, you, tempbuf(count), tag + character*255 :: message + + if(root<0) call wrf_error_fatal('root is less than 0') + + tag=get_reduce_tag(root,comm) + + !write(message,'("Send/recv to tag ",I0)') tag + !call wrf_message(message) + + call mpi_comm_rank(comm,me,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_rank') + + call mpi_comm_size(comm,size,ierr) + if(ierr/=0) call wrf_error_fatal('cannot call mpi_comm_size') + + if(root>=size) call wrf_error_fatal('root is beyond highest communicator rank') + + if(me==root) then + recvbuf=sendbuf + do you=0,size-2 + call mpi_recv(tempbuf,count,MPI_INTEGER,MPI_ANY_SOURCE,tag,comm,MPI_STATUS_IGNORE,ierr) + if(ierr/=0) call wrf_error_fatal('error calling mpi_recv') + recvbuf=recvbuf+tempbuf + enddo + else + call mpi_send(sendbuf,count,MPI_INTEGER,root,tag,comm,ierr) + if(ierr/=0) call wrf_error_fatal('error calling mpi_send') + endif + end subroutine reduce_add_int_arr +#endif + + +END MODULE module_wrf_quilt + +! +! Remaining routines in this file are defined outside of the module +! either to defeat arg/param type checking or to avoid an explicit use +! dependence. +! + +SUBROUTINE disable_quilting +! +! Call this in programs that you never want to be quilting (e.g. real) +! Must call before call to init_module_wrf_quilt(). +! + USE module_wrf_quilt + disable_quilt = .TRUE. + RETURN +END SUBROUTINE disable_quilting + +SUBROUTINE quilting_disabled( reslt ) +! +! Call this in programs that you never want to be quilting (e.g. real) +! Must call before call to init_module_wrf_quilt(). +! + USE module_wrf_quilt + LOGICAL, INTENT(OUT) :: reslt + reslt = disable_quilt +write(0,*)__FILE__,__LINE__,disable_quilt + RETURN +END SUBROUTINE quilting_disabled + +LOGICAL FUNCTION use_output_servers_for(ioform) +! +! Returns .TRUE. if I/O quilt servers are in-use for write operations +! AND the output servers can handle the given I/O form. If the I/O +! form is 0, then the io form is not considered and the result is the +! same as calling use_output_servers. +! This routine is called only by client (compute) tasks. +! + USE module_wrf_quilt + integer, intent(in) :: ioform + use_output_servers_for = quilting_enabled + use_output_servers_for = ( use_output_servers_for .and. ioform<100 ) + RETURN +END FUNCTION use_output_servers_for + +LOGICAL FUNCTION use_output_servers() +! +! Returns .TRUE. if I/O quilt servers are in-use for write operations. +! This routine is called only by client (compute) tasks. +! + USE module_wrf_quilt + use_output_servers = quilting_enabled + RETURN +END FUNCTION use_output_servers + +LOGICAL FUNCTION use_input_servers() +! +! Returns .TRUE. if I/O quilt servers are in-use for read operations. +! This routine is called only by client (compute) tasks. +! + USE module_wrf_quilt + use_input_servers = .FALSE. + RETURN +END FUNCTION use_input_servers + +SUBROUTINE wrf_quilt_open_for_write_begin( FileName , gridid, Comm_compute, Comm_io, SysDepInfo, & + DataHandle , io_form_arg, Status ) +! +! Instruct the I/O quilt servers to begin data definition ("training") phase +! for writing to WRF dataset FileName. io_form_arg indicates file format. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + USE module_state_description, ONLY: IO_PNETCDF + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(IN) :: gridid + INTEGER , INTENT(IN) :: Comm_compute , Comm_io + CHARACTER *(*), INTENT(IN) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(IN) :: io_form_arg + INTEGER , INTENT(OUT) :: Status +! Local + CHARACTER*132 :: locFileName, locSysDepInfo + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy + INTEGER, EXTERNAL :: use_package + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_begin' ) + CALL int_get_fresh_handle(i) + okay_to_write(i) = .false. + DataHandle = i + + locFileName = FileName + locSysDepInfo = SysDepInfo + + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + + SELECT CASE(use_package(io_form_arg)) + +#ifdef PNETCDF_QUILT + CASE(IO_PNETCDF) + IF(compute_group_master(1)) THEN + CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, & + locFileName,locSysDepInfo,io_form_arg,& + DataHandle ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + END IF +#endif + CASE DEFAULT + + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ofwb_header( hdrbuf, hdrbufsize, itypesize, & + locFileName,locSysDepInfo,io_form_arg,DataHandle ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF + + END SELECT + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1) ) reduced(2) = i +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = i +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_begin") + + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + + Status = 0 + + +#endif + RETURN +END SUBROUTINE wrf_quilt_open_for_write_begin + +SUBROUTINE wrf_quilt_open_for_write_commit( DataHandle , Status ) +! +! Instruct the I/O quilt servers to switch an internal flag to enable output +! for the dataset referenced by DataHandle. The call to +! wrf_quilt_open_for_write_commit() must be paired with a call to +! wrf_quilt_open_for_write_begin(). +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN ) :: DataHandle + INTEGER , INTENT(OUT) :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_write_commit' ) + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + okay_to_write( DataHandle ) = .true. + ENDIF + ENDIF + + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + +#ifdef PNETCDF_QUILT +!ARP Only want one command to be received by each IO server when using +!ARP parallel IO + IF(compute_group_master(1)) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle, int_open_for_write_commit ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + END IF +#else + + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle, int_open_for_write_commit ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_open_for_write_commit") + + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + + Status = 0 + +#endif + RETURN +END SUBROUTINE wrf_quilt_open_for_write_commit + +SUBROUTINE wrf_quilt_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, & + DataHandle , Status ) +! +! Instruct the I/O quilt servers to open WRF dataset FileName for reading. +! This routine is called only by client (compute) tasks. +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(IN) :: Comm_compute , Comm_io + CHARACTER *(*), INTENT(IN) :: SysDepInfo + INTEGER , INTENT(OUT) :: DataHandle + INTEGER , INTENT(OUT) :: Status + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_open_for_read' ) + DataHandle = -1 + Status = -1 + CALL wrf_error_fatal ( "frame/module_io_quilt.F: wrf_quilt_open_for_read not yet supported" ) +#endif + RETURN +END SUBROUTINE wrf_quilt_open_for_read + +SUBROUTINE wrf_quilt_inquire_opened ( DataHandle, FileName , FileStatus, Status ) +! +! Inquire if the dataset referenced by DataHandle is open. +! Does not require communication with I/O servers. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE +#include "wrf_io_flags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER *(*), INTENT(IN) :: FileName + INTEGER , INTENT(OUT) :: FileStatus + INTEGER , INTENT(OUT) :: Status + + Status = 0 + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_opened' ) + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + IF ( okay_to_write( DataHandle ) ) THEN + FileStatus = WRF_FILE_OPENED_FOR_WRITE + ENDIF + ENDIF + ENDIF + Status = 0 + +#endif + RETURN +END SUBROUTINE wrf_quilt_inquire_opened + +SUBROUTINE wrf_quilt_inquire_filename ( DataHandle, FileName , FileStatus, Status ) +! +! Return the Filename and FileStatus associated with DataHandle. +! Does not require communication with I/O servers. +! +! Note that the current implementation does not actually return FileName. +! Currenlty, WRF does not use this returned value. Fixing this would simply +! require saving the file names on the client tasks in an array similar to +! okay_to_write(). +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE +#include "wrf_io_flags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER *(*), INTENT(OUT) :: FileName + INTEGER , INTENT(OUT) :: FileStatus + INTEGER , INTENT(OUT) :: Status + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_inquire_filename' ) + Status = 0 + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + IF ( okay_to_write( DataHandle ) ) THEN + FileStatus = WRF_FILE_OPENED_FOR_WRITE + ELSE + FileStatus = WRF_FILE_OPENED_NOT_COMMITTED + ENDIF + ELSE + FileStatus = WRF_FILE_NOT_OPENED + ENDIF + Status = 0 + FileName = "bogusfornow" + ELSE + Status = -1 + ENDIF +#endif + RETURN +END SUBROUTINE wrf_quilt_inquire_filename + +SUBROUTINE wrf_quilt_iosync ( DataHandle, Status ) +! +! Instruct the I/O quilt servers to synchronize the disk copy of a dataset +! with memory buffers. +! +! After the "iosync" header (request) is sent to the I/O quilt server, +! the compute tasks will then send the entire contents (headers and data) of +! int_local_output_buffer to their I/O quilt server. This communication is +! done in subroutine send_to_io_quilt_servers(). After the I/O quilt servers +! receive this data, they will write all accumulated fields to disk. +! +! Significant time may be required for the I/O quilt servers to organize +! fields and write them to disk. Therefore, the "iosync" request should be +! sent only when the compute tasks are ready to run for a while without +! needing to communicate with the servers. Otherwise, the compute tasks +! will end up waiting for the servers to finish writing to disk, thus wasting +! any performance benefits of having servers at all. +! +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI) + USE module_wrf_quilt + IMPLICIT NONE + include "mpif.h" + INTEGER , INTENT(IN) :: DataHandle + INTEGER , INTENT(OUT) :: Status + + INTEGER locsize , itypesize + INTEGER ierr, tasks_in_group, comm_io_group, dummy, i + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_iosync' ) + +! CALL start_timing + IF ( associated ( int_local_output_buffer ) ) THEN + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + + locsize = int_num_bytes_to_write(DataHandle) + +! CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = locsize +#ifdef PNETCDF_QUILT +! ARP Only want one command per IOServer if doing parallel IO + IF ( compute_group_master(1) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +! CALL end_timing("MPI_Reduce in wrf_quilt_iosync") + + ! send data to the i/o processor +#ifdef DEREF_KLUDGE + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + int_local_output_buffer(1), locsize , & + dummy, 0 ) +#else + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + int_local_output_buffer, locsize , & + dummy, 0 ) +#endif + + + int_local_output_cursor = 1 +! int_num_bytes_to_write(DataHandle) = 0 + DEALLOCATE ( int_local_output_buffer ) + NULLIFY ( int_local_output_buffer ) + ELSE + CALL wrf_message ("frame/module_io_quilt.F: wrf_quilt_iosync: no buffer allocated") + ENDIF +! CALL end_timing("wrf_quilt_iosync") + Status = 0 +#endif + RETURN +END SUBROUTINE wrf_quilt_iosync + +SUBROUTINE wrf_quilt_ioclose ( DataHandle, Status ) +! +! Instruct the I/O quilt servers to close the dataset referenced by +! DataHandle. +! This routine also clears the client file handle and, if needed, deallocates +! int_local_output_buffer. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined( STUBMPI) + USE module_wrf_quilt + USE module_timing + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + INTEGER , INTENT(OUT) :: Status + INTEGER i, itypesize, tasks_in_group, comm_io_group, ierr + REAL dummy + +!!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioclose' ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + +! If we're using pnetcdf then each IO server will need to receive the +! handle just once as there is +! no longer a reduce over the IO servers to get it. +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1) )THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle, int_ioclose ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle , int_ioclose ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 +#ifdef PNETCDF_QUILT +! If we're using pnetcdf then each IO server will need the handle as there is +! no longer a reduce over the IO servers to get it. + IF ( compute_group_master(1) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!JMTIMING CALL end_timing("MPI_Reduce in ioclose") + +#if 0 + ! send data to the i/o processor +!!JMTIMING CALL start_timing + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) +!!JMTIMING CALL end_timing("collect_on_comm in io_close") +#endif + + int_handle_in_use(DataHandle) = .false. + CALL set_server_id( DataHandle, 0 ) + okay_to_write(DataHandle) = .false. + okay_to_commit(DataHandle) = .false. + int_local_output_cursor = 1 + int_num_bytes_to_write(DataHandle) = 0 + IF ( associated ( int_local_output_buffer ) ) THEN + DEALLOCATE ( int_local_output_buffer ) + NULLIFY ( int_local_output_buffer ) + ENDIF + + Status = 0 +!!JMTIMING CALL end_timing( "wrf_quilt_ioclose" ) + +#endif + RETURN +END SUBROUTINE wrf_quilt_ioclose + +SUBROUTINE wrf_quilt_ioexit( Status ) +! +! Instruct the I/O quilt servers to shut down the WRF I/O system. +! Do not call any wrf_quilt_*() routines after this routine has been called. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(OUT) :: Status + INTEGER :: DataHandle, actual_iserver + INTEGER i, itypesize, tasks_in_group, comm_io_group, me, ierr + REAL dummy + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_ioexit' ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + +!ARPDBG - potential bug. Have no access to what type of IO is being used for +! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. +#ifdef PNETCDF_QUILT +!ARP Send the ioexit message just once to each IOServer when using parallel IO + IF( compute_group_master(1) ) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle, int_ioexit ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + END IF +#else + + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_handle_header( hdrbuf, hdrbufsize, itypesize, & + DataHandle , int_ioexit ) ! Handle is dummy + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + DO iserver = 1, nio_groups + if(poll_servers) then + ! We're using server polling mode, so we must call + ! *_find_server to receive the mpi_ssend sent by the servers, + ! otherwise WRF will hang at the mpi_x_reduce below. + + call wrf_quilt_find_server(actual_iserver) + + ! The actual_iserver is now set to the next available I/O server. + ! That may not be the same as iserver, but that's okay as long + ! as we run through this loop exactly nio_groups times. + else + ! Not using server polling, so just access servers in numeric order. + actual_iserver=iserver + endif + CALL get_mpi_comm_io_groups( comm_io_group , actual_iserver ) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + CALL mpi_comm_rank( comm_io_group , me , ierr ) + +! BY SENDING A NEGATIVE SIZE WE GET THE SERVERS TO SHUT DOWN + hdrbufsize = -100 + reduced = 0 + IF ( me .eq. 0 ) reduced(1) = hdrbufsize + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) + + ENDDO + Status = 0 + +#endif + RETURN +END SUBROUTINE wrf_quilt_ioexit + +SUBROUTINE wrf_quilt_get_next_time ( DataHandle, DateStr, Status ) +! +! Instruct the I/O quilt servers to return the next time stamp. +! This is not yet supported. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + INTEGER :: Status +#endif + RETURN +END SUBROUTINE wrf_quilt_get_next_time + +SUBROUTINE wrf_quilt_get_previous_time ( DataHandle, DateStr, Status ) +! +! Instruct the I/O quilt servers to return the previous time stamp. +! This is not yet supported. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && ! defined (STUBMPI) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: DateStr + INTEGER :: Status +#endif + RETURN +END SUBROUTINE wrf_quilt_get_previous_time + +SUBROUTINE wrf_quilt_set_time ( DataHandle, Data, Status ) +! +! Instruct the I/O quilt servers to set the time stamp in the dataset +! referenced by DataHandle. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + USE module_state_description, ONLY: IO_PNETCDF + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy + INTEGER :: Count + INTEGER, EXTERNAL :: use_package +! + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_set_time' ) + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + Count = 0 ! there is no count for character strings + +!ARPDBG - potential bug. Have no access to what type of IO is being used for +! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. +#ifdef PNETCDF_QUILT + IF(compute_group_master(1) )THEN +! Only want to send one time header to each IO server as +! can't tell that's what they are on the IO servers themselves - therefore use +! the compute_group_master process. + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, "TIMESTAMP", "", Data, int_set_time ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + END IF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, "TIMESTAMP", "", Data, int_set_time ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF + +#endif +RETURN +END SUBROUTINE wrf_quilt_set_time + +SUBROUTINE wrf_quilt_get_next_var ( DataHandle, VarName, Status ) +! +! When reading, instruct the I/O quilt servers to return the name of the next +! variable in the current time frame. +! This is not yet supported. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) :: VarName + INTEGER :: Status +#endif + RETURN +END SUBROUTINE wrf_quilt_get_next_var + +SUBROUTINE wrf_quilt_get_dom_ti_real ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type real are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. + +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + REAL, INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Outcount + INTEGER :: Status + CALL wrf_message('wrf_quilt_get_dom_ti_real not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_real + +SUBROUTINE wrf_quilt_put_dom_ti_real ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type real are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + REAL , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +!Local + CHARACTER*132 :: locElement + INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy +! +!!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_real' ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + locElement = Element + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + CALL MPI_TYPE_SIZE( MPI_REAL, typesize, ierr ) + +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1) ) THEN + CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, locElement, Data, Count, int_dom_ti_real ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, locElement, Data, Count, int_dom_ti_real ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF( compute_group_master(1) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_real") + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF + + Status = 0 +!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_real") +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_real + +SUBROUTINE wrf_quilt_get_dom_ti_double ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type double are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status + CALL wrf_error_fatal('wrf_quilt_get_dom_ti_double not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_double + +SUBROUTINE wrf_quilt_put_dom_ti_double ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type double are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + REAL*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status + CALL wrf_error_fatal('wrf_quilt_put_dom_ti_double not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_double + +SUBROUTINE wrf_quilt_get_dom_ti_integer ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type integer are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status + CALL wrf_message('wrf_quilt_get_dom_ti_integer not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_integer + +SUBROUTINE wrf_quilt_put_dom_ti_integer ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type integer are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + USE module_state_description, ONLY: IO_PNETCDF + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + INTEGER , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +! Local + CHARACTER*132 :: locElement + INTEGER i, typesize, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy + INTEGER, EXTERNAL :: use_package +! + +!!JMTIMING CALL start_timing + locElement = Element + + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_integer' ) + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + CALL MPI_TYPE_SIZE( MPI_INTEGER, typesize, ierr ) + +!ARPDBG - potential bug. Have no access to what type of IO is being used for +! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1) )THEN + CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, locElement, Data, Count, & + int_dom_ti_integer ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle, locElement, Data, Count, & + int_dom_ti_integer ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) + +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_integer") + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF + CALL wrf_debug ( DEBUG_LVL, 'returning from wrf_quilt_put_dom_ti_integer' ) +!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_integer" ) + +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_integer + +SUBROUTINE wrf_quilt_get_dom_ti_logical ( DataHandle,Element, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type logical are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +! CALL wrf_message('wrf_quilt_get_dom_ti_logical not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_logical + +SUBROUTINE wrf_quilt_put_dom_ti_logical ( DataHandle,Element, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type logical are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +! Local + INTEGER i + INTEGER one_or_zero(Count) + + DO i = 1, Count + IF ( Data(i) ) THEN + one_or_zero(i) = 1 + ELSE + one_or_zero(i) = 0 + ENDIF + ENDDO + + CALL wrf_quilt_put_dom_ti_integer ( DataHandle,Element, one_or_zero, Count, Status ) +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_logical + +SUBROUTINE wrf_quilt_get_dom_ti_char ( DataHandle,Element, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time independent +! domain metadata named "Element" +! from the open dataset described by DataHandle. +! Metadata of type char are +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) :: Data + INTEGER :: Status + CALL wrf_message('wrf_quilt_get_dom_ti_char not supported yet') +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_ti_char + +SUBROUTINE wrf_quilt_put_dom_ti_char ( DataHandle, Element, Data, Status ) +! +! Instruct the I/O quilt servers to write time independent +! domain metadata named "Element" +! to the open dataset described by DataHandle. +! Metadata of type char are +! copied from string Data. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group, me + REAL dummy +! +!!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_dom_ti_char' ) + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + +!ARPDBG - potential bug. Have no access to what type of IO is being used for +! this data so if PNETCDF_QUILT is defined then we assume that's what's being used. +#ifdef PNETCDF_QUILT + IF(compute_group_master(1))THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, Element, "", Data, & + int_dom_ti_char ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + END IF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, Element, "", Data, int_dom_ti_char ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) +! write(0,*)'wrf_quilt_put_dom_ti_char ',iserver + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here) +!!JMTIMING! CALL start_timing +!write(0,*)'calling MPI_Barrier' +! CALL MPI_Barrier( mpi_comm_local, ierr ) +!write(0,*)'back from MPI_Barrier' +!!JMTIMING! CALL end_timing("MPI_Barrier in wrf_quilt_put_dom_ti_char") + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced_dummy = 0 + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF(compute_group_master(1)) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif +!call mpi_comm_rank( comm_io_group , me, ierr ) + + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) + +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_dom_ti_char") + ! send data to the i/o processor +!!JMTIMING CALL start_timing + + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) +!!JMTIMING CALL end_timing("collect_on_comm in wrf_quilt_put_dom_ti_char") + ENDIF + ENDIF +!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char") + +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_ti_char + +SUBROUTINE wrf_quilt_get_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type real are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_real + +SUBROUTINE wrf_quilt_put_dom_td_real ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type real are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_real + +SUBROUTINE wrf_quilt_get_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type double are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_get_dom_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_double + +SUBROUTINE wrf_quilt_put_dom_td_double ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type double are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_put_dom_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_double + +SUBROUTINE wrf_quilt_get_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type integer are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_integer + +SUBROUTINE wrf_quilt_put_dom_td_integer ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type integer are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_integer + +SUBROUTINE wrf_quilt_get_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type logical are +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_logical + +SUBROUTINE wrf_quilt_put_dom_td_logical ( DataHandle,Element, DateStr, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type logical are +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_logical + +SUBROUTINE wrf_quilt_get_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time dependent +! domain metadata named "Element" valid at time DateStr +! from the open dataset described by DataHandle. +! Metadata of type char are +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_dom_td_char + +SUBROUTINE wrf_quilt_put_dom_td_char ( DataHandle,Element, DateStr, Data, Status ) +! +! Instruct $he I/O quilt servers to write time dependent +! domain metadata named "Element" valid at time DateStr +! to the open dataset described by DataHandle. +! Metadata of type char are +! copied from string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_dom_td_char + +SUBROUTINE wrf_quilt_get_var_ti_real ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type real is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_real + +SUBROUTINE wrf_quilt_put_var_ti_real ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type real is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_real + +SUBROUTINE wrf_quilt_get_var_ti_double ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type double is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_get_var_ti_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_double + +SUBROUTINE wrf_quilt_put_var_ti_double ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type double is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_put_var_ti_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_double + +SUBROUTINE wrf_quilt_get_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type integer is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_integer + +SUBROUTINE wrf_quilt_put_var_ti_integer ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type integer is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_integer + +SUBROUTINE wrf_quilt_get_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! independent attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type logical is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_logical + +SUBROUTINE wrf_quilt_put_var_ti_logical ( DataHandle,Element, Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type logical is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_logical + +SUBROUTINE wrf_quilt_get_var_ti_char ( DataHandle,Element, Varname, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time independent +! attribute "Element" of variable "Varname" +! from the open dataset described by DataHandle. +! Attribute of type char is +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_ti_char + +SUBROUTINE wrf_quilt_put_var_ti_char ( DataHandle,Element, Varname, Data, Status ) +! +! Instruct the I/O quilt servers to write time independent +! attribute "Element" of variable "Varname" +! to the open dataset described by DataHandle. +! Attribute of type char is +! copied from string Data. +! This routine is called only by client (compute) tasks. +! + +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "intio_tags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status + INTEGER i, itypesize, tasks_in_group, ierr, comm_io_group + REAL dummy +! + +!!JMTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_put_var_ti_char' ) + + IF ( DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles ) THEN + IF ( int_handle_in_use( DataHandle ) ) THEN + CALL MPI_TYPE_SIZE( MPI_INTEGER, itypesize, ierr ) + +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1) ) THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, TRIM(Element), & + TRIM(VarName), TRIM(Data), int_var_ti_char ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#else + IF ( wrf_dm_on_monitor() ) THEN + CALL int_gen_ti_header_char( hdrbuf, hdrbufsize, itypesize, & + DataHandle, TRIM(Element), & + TRIM(VarName), TRIM(Data), int_var_ti_char ) + ELSE + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + iserver = get_server_id ( DataHandle ) + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +!!JMTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!JMTIMING CALL end_timing("MPI_Reduce in wrf_quilt_put_var_ti_char") + ! send data to the i/o processor + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + ENDIF + ENDIF +!!JMTIMING CALL end_timing("wrf_quilt_put_dom_ti_char" ) + +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_ti_char + +SUBROUTINE wrf_quilt_get_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type real is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_real + +SUBROUTINE wrf_quilt_put_var_td_real ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type real is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_real + +SUBROUTINE wrf_quilt_get_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type double is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_get_var_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_get_var_td_double + +SUBROUTINE wrf_quilt_put_var_td_double ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type double is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + real*8 , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif + CALL wrf_error_fatal('wrf_quilt_put_var_td_double not supported yet') +RETURN +END SUBROUTINE wrf_quilt_put_var_td_double + +SUBROUTINE wrf_quilt_get_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount,Status) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type integer is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + integer :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_integer + +SUBROUTINE wrf_quilt_put_var_td_integer ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type integer is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + integer , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_integer + +SUBROUTINE wrf_quilt_get_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Outcount, Status ) +! +! Instruct the I/O quilt servers to attempt to read Count words of time +! dependent attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type logical is +! stored in array Data. +! Actual number of words read is returned in OutCount. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + logical :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: OutCount + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_logical + +SUBROUTINE wrf_quilt_put_var_td_logical ( DataHandle,Element, DateStr,Varname, Data, Count, Status ) +! +! Instruct the I/O quilt servers to write Count words of time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type logical is +! copied from array Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + logical , INTENT(IN) :: Data(*) + INTEGER , INTENT(IN) :: Count + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_logical + +SUBROUTINE wrf_quilt_get_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status ) +! +! Instruct the I/O quilt servers to attempt to read time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! from the open dataset described by DataHandle. +! Attribute of type char is +! stored in string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_td_char + +SUBROUTINE wrf_quilt_put_var_td_char ( DataHandle,Element, DateStr,Varname, Data, Status ) +! +! Instruct the I/O quilt servers to write time dependent +! attribute "Element" of variable "Varname" valid at time DateStr +! to the open dataset described by DataHandle. +! Attribute of type char is +! copied from string Data. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: Element + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName + CHARACTER*(*) , INTENT(IN) :: Data + INTEGER :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_put_var_td_char + +SUBROUTINE wrf_quilt_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +! Instruct the I/O quilt servers to read the variable named VarName from the +! dataset pointed to by DataHandle. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(INOUT) :: DateStr + CHARACTER*(*) , INTENT(INOUT) :: VarName + INTEGER , INTENT(INOUT) :: Field(*) + integer ,intent(in) :: FieldType + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(in) :: Stagger + character*(*) , dimension (*) ,intent(in) :: DimNames + integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd + integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd + integer ,intent(out) :: Status + Status = 0 +#endif +RETURN +END SUBROUTINE wrf_quilt_read_field + +SUBROUTINE wrf_quilt_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + DomainDesc , MemoryOrder , Stagger , DimNames , & + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd , & + Status ) +! +! Prepare instructions for the I/O quilt servers to write the variable named +! VarName to the dataset pointed to by DataHandle. +! +! During a "training" write this routine accumulates number and sizes of +! messages that will be sent to the I/O server associated with this compute +! (client) task. +! +! During a "real" write, this routine begins by allocating +! int_local_output_buffer if it has not already been allocated. Sizes +! accumulated during "training" are used to determine how big +! int_local_output_buffer must be. This routine then stores "int_field" +! headers and associated field data in int_local_output_buffer. The contents +! of int_local_output_buffer are actually sent to the I/O quilt server in +! routine wrf_quilt_iosync(). This scheme allows output of multiple variables +! to be aggregated into a single "iosync" operation. +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_state_description + USE module_wrf_quilt + IMPLICIT NONE + INCLUDE 'mpif.h' +#include "wrf_io_flags.h" + INTEGER , INTENT(IN) :: DataHandle + CHARACTER*(*) , INTENT(IN) :: DateStr + CHARACTER*(*) , INTENT(IN) :: VarName +! INTEGER , INTENT(IN) :: Field(*) + integer ,intent(in) :: FieldType + integer ,intent(inout) :: Comm + integer ,intent(inout) :: IOComm + integer ,intent(in) :: DomainDesc + character*(*) ,intent(in) :: MemoryOrder + character*(*) ,intent(in) :: Stagger + character*(*) , dimension (*) ,intent(in) :: DimNames + integer ,dimension(*) ,intent(in) :: DomainStart, DomainEnd + integer ,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd + integer ,dimension(*) ,intent(in) :: PatchStart, PatchEnd + integer ,intent(out) :: Status + + integer ii,jj,kk,myrank + + REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), & + MemoryStart(2):MemoryEnd(2), & + MemoryStart(3):MemoryEnd(3) ) :: Field + INTEGER locsize , typesize, itypesize + INTEGER ierr, tasks_in_group, comm_io_group, dummy, i + INTEGER, EXTERNAL :: use_package + +!!ARPTIMING CALL start_timing + CALL wrf_debug ( DEBUG_LVL, 'in wrf_quilt_write_field' ) + + IF ( .NOT. (DataHandle .GE. 1 .AND. DataHandle .LE. int_num_handles) ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: invalid data handle" ) + ENDIF + IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: DataHandle not opened" ) + ENDIF + + locsize = (PatchEnd(1)-PatchStart(1)+1)* & + (PatchEnd(2)-PatchStart(2)+1)* & + (PatchEnd(3)-PatchStart(3)+1) + + CALL mpi_type_size( MPI_INTEGER, itypesize, ierr ) + ! Note that the WRF_DOUBLE branch of this IF statement must come first since + ! WRF_FLOAT is set equal to WRF_DOUBLE during autopromotion builds. + IF ( FieldType .EQ. WRF_DOUBLE ) THEN + CALL mpi_type_size( MPI_DOUBLE_PRECISION, typesize, ierr ) + ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN + CALL mpi_type_size( MPI_REAL, typesize, ierr ) + ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN + CALL mpi_type_size( MPI_INTEGER, typesize, ierr ) + ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN + CALL mpi_type_size( MPI_LOGICAL, typesize, ierr ) + ENDIF + + IF ( .NOT. okay_to_write( DataHandle ) ) THEN + + ! This is a "training" write. + ! it is not okay to actually write; what we do here is just "bookkeep": count up + ! the number and size of messages that we will output to io server associated with + ! this task + + CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + 333933 , MemoryOrder , Stagger , DimNames , & ! 333933 means training; magic number + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + + int_num_bytes_to_write(DataHandle) = int_num_bytes_to_write(DataHandle) + locsize * typesize + hdrbufsize + + ! Send the hdr for the write in case the interface is calling the I/O API in "learn" mode + + iserver = get_server_id ( DataHandle ) +!JMDEBUGwrite(0,*)'wrf_quilt_write_field (dryrun) ',iserver + CALL get_mpi_comm_io_groups( comm_io_group , iserver ) + ! send the size of my local buffer to the i/o task (obufsize doesnt mean anything here) + + CALL mpi_x_comm_size( comm_io_group , tasks_in_group , ierr ) + +#if 0 + IF ( .NOT. wrf_dm_on_monitor() ) THEN ! only one task in compute grid sends this message; send noops on others + CALL int_gen_noop_header( hdrbuf, hdrbufsize, itypesize ) + ENDIF +#endif + + +!!ARPTIMING CALL start_timing + ! send the size of my local buffer to the i/o task (reduced_dummy doesnt mean anything on client side) + reduced = 0 + reduced(1) = hdrbufsize +#ifdef PNETCDF_QUILT + IF ( compute_group_master(1) ) reduced(2) = DataHandle +#else + IF ( wrf_dm_on_monitor() ) reduced(2) = DataHandle +#endif + CALL mpi_x_reduce( reduced, reduced_dummy, 2, MPI_INTEGER, MPI_SUM, tasks_in_group-1, comm_io_group, ierr ) +!!ARPTIMING CALL end_timing("MPI_Reduce in wrf_quilt_write_field dryrun") + ! send data to the i/o processor + + CALL collect_on_comm_debug(__FILE__,__LINE__, comm_io_group, & + onebyte, & + hdrbuf, hdrbufsize , & + dummy, 0 ) + + ELSE + + IF ( .NOT. associated( int_local_output_buffer ) ) THEN + ALLOCATE ( int_local_output_buffer( (int_num_bytes_to_write( DataHandle )+1)/itypesize ), Stat=ierr ) + IF(ierr /= 0)THEN + CALL wrf_error_fatal("frame/module_io_quilt.F: wrf_quilt_write_field: allocate of int_local_output_buffer failed" ) + END IF + int_local_output_cursor = 1 + ENDIF + iserver = get_server_id ( DataHandle ) +!JMDEBUGwrite(0,*)'wrf_quilt_write_field (writing) ',iserver + + ! This is NOT a "training" write. It is OK to write now. + CALL int_gen_write_field_header ( hdrbuf, hdrbufsize, itypesize, typesize, & + DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, & + 0 , MemoryOrder , Stagger , DimNames , & ! non-333933 means okay to write; magic number + DomainStart , DomainEnd , & + MemoryStart , MemoryEnd , & + PatchStart , PatchEnd ) + + ! Pack header into int_local_output_buffer. It will be sent to the + ! I/O servers during the next "iosync" operation. +#ifdef DEREF_KLUDGE + CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer(1), int_local_output_cursor ) +#else + CALL int_pack_data ( hdrbuf , hdrbufsize , int_local_output_buffer, int_local_output_cursor ) +#endif + + ! Pack field data into int_local_output_buffer. It will be sent to the + ! I/O servers during the next "iosync" operation. +#ifdef DEREF_KLUDGE + CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), & + locsize * typesize , int_local_output_buffer(1), int_local_output_cursor ) +#else + CALL int_pack_data ( Field(PatchStart(1):PatchEnd(1),PatchStart(2):PatchEnd(2),PatchStart(3):PatchEnd(3) ), & + locsize * typesize , int_local_output_buffer, int_local_output_cursor ) +#endif + + ENDIF + Status = 0 +!!ARPTIMING CALL end_timing("wrf_quilt_write_field") + +#endif + RETURN +END SUBROUTINE wrf_quilt_write_field + +SUBROUTINE wrf_quilt_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , & + DomainStart , DomainEnd , Status ) +! +! This routine applies only to a dataset that is open for read. It instructs +! the I/O quilt servers to return information about variable VarName. +! This routine is called only by client (compute) tasks. +! +! This is not yet supported. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + IMPLICIT NONE + integer ,intent(in) :: DataHandle + character*(*) ,intent(in) :: VarName + integer :: NDim + character*(*) :: MemoryOrder + character*(*) :: Stagger + integer ,dimension(*) :: DomainStart, DomainEnd + integer :: Status +#endif +RETURN +END SUBROUTINE wrf_quilt_get_var_info + +subroutine wrf_quilt_find_server(iserver) + + ! This routine is called by the compute processes when they need an + ! I/O server to write out a new file. Upon return, this routine will + ! set iserver to the next available I/O server group. + + ! A mpi_recv to all of mpi_comm_avail is used to implement this, and + ! that recv will not return until an I/O server group calls + ! wrf_quilt_server_ready to signal that it is ready for a new file. + +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + use module_wrf_quilt, only : in_avail, mpi_comm_avail, mpi_comm_local + + implicit none + INCLUDE 'mpif.h' + integer, intent(inout) :: iserver + integer :: ierr + character(255) :: message + + call wrf_message('Polling I/O servers...') + + if(in_avail) then + call mpi_recv(iserver,1,MPI_INTEGER,MPI_ANY_SOURCE,0,mpi_comm_avail,MPI_STATUS_IGNORE,ierr) + if(ierr/=0) then + call wrf_error_fatal('mpi_recv failed in wrf_quilt_find_server') + endif + endif + + call mpi_bcast(iserver,1,MPI_INTEGER,0,mpi_comm_local,ierr) + if(ierr/=0) then + call wrf_error_fatal('mpi_bcast failed in wrf_quilt_find_server') + endif + + write(message,'("I/O server ",I0," is ready for operations.")') iserver + call wrf_message(message) + +#endif + +end subroutine wrf_quilt_find_server +subroutine wrf_quilt_server_ready() + + ! This routine is called by the I/O server group's master process once the + ! I/O server group is done writing its current file, and is waiting for + ! a new one. This information is passed to the monitor process by a + ! blocking send from the I/O server master process to the monitor. + + ! All processes in an I/O group must call this routine, and this routine + ! will not return (in any process) until the monitor process signals + ! that it wants the I/O server group to write a file. That signal is + ! sent in a call to wrf_quilt_find_server on the compute processes. + +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + use module_wrf_quilt, only : mpi_comm_local, in_avail, availrank, mpi_comm_avail + + implicit none + INCLUDE 'mpif.h' + integer :: ierr + character*255 :: message + + write(message,*) 'Entering wrf_quilt_server_ready.' + call wrf_debug(1,message) + + call mpi_barrier(mpi_comm_local,ierr) + if(ierr/=0) then + call wrf_error_fatal('mpi_barrier failed in wrf_quilt_server_ready') + endif + + if(in_avail) then + write(message,'("mpi_ssend ioserver=",I0," in wrf_quilt_server_ready")') availrank + call wrf_debug(1,message) + call mpi_ssend(availrank,1,MPI_INTEGER,0,0,mpi_comm_avail,ierr) + if(ierr/=0) then + call wrf_error_fatal('mpi_ssend failed in wrf_quilt_server_ready') + endif + endif + + call mpi_barrier(mpi_comm_local,ierr) + if(ierr/=0) then + call wrf_error_fatal('mpi_barrier failed in wrf_quilt_server_ready') + endif + + write(message,*) 'Leaving wrf_quilt_server_ready.' + call wrf_debug(1,message) +#endif + +end subroutine wrf_quilt_server_ready + +SUBROUTINE get_mpi_comm_io_groups( retval, isrvr ) +! +! This routine returns the compute+io communicator to which this +! compute task belongs for I/O server group "isrvr". +! This routine is called only by client (compute) tasks. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INTEGER, INTENT(IN ) :: isrvr + INTEGER, INTENT(OUT) :: retval + retval = mpi_comm_io_groups(isrvr) +#endif + RETURN +END SUBROUTINE get_mpi_comm_io_groups + +SUBROUTINE get_nio_tasks_in_group( retval ) +! +! This routine returns the number of I/O server tasks in each +! I/O server group. It can be called by both clients and +! servers. +! +#if defined( DM_PARALLEL ) && !defined( STUBMPI ) + USE module_wrf_quilt + IMPLICIT NONE + INTEGER, INTENT(OUT) :: retval + retval = nio_tasks_in_group +#endif + RETURN +END SUBROUTINE get_nio_tasks_in_group + +SUBROUTINE collect_on_comm_debug(file,line, comm_io_group, & + sze, & + hdrbuf, hdrbufsize , & + outbuf, outbufsize ) + IMPLICIT NONE + CHARACTER*(*) file + INTEGER line + INTEGER comm_io_group + INTEGER sze + INTEGER hdrbuf(*), outbuf(*) + INTEGER hdrbufsize, outbufsize + + CALL collect_on_comm( comm_io_group, & + sze, & + hdrbuf, hdrbufsize , & + outbuf, outbufsize ) + RETURN +END + + +SUBROUTINE collect_on_comm_debug2(file,line,var,tag,sz,hdr_rec_size, & + comm_io_group, & + sze, & + hdrbuf, hdrbufsize , & + outbuf, outbufsize ) + IMPLICIT NONE + CHARACTER*(*) file,var + INTEGER line,tag,sz,hdr_rec_size + INTEGER comm_io_group + INTEGER sze + INTEGER hdrbuf(*), outbuf(*) + INTEGER hdrbufsize, outbufsize + + CALL collect_on_comm( comm_io_group, & + sze, & + hdrbuf, hdrbufsize , & + outbuf, outbufsize ) + RETURN +END diff --git a/wrfv2_fire/frame/module_wrf_error.F b/wrfv2_fire/frame/module_wrf_error.F index ff5fe666..be71ce7a 100644 --- a/wrfv2_fire/frame/module_wrf_error.F +++ b/wrfv2_fire/frame/module_wrf_error.F @@ -40,7 +40,7 @@ MODULE module_wrf_error ! Defaults: Non-MPI configurations and HWRF turn OFF stderr. ! MPI configurations other than HWRF turn ON stderr. -#if defined( DM_PARALLEL ) && ! defined( STUBMPI ) && !defined(HWRF) +#if defined( DM_PARALLEL ) && ! defined( STUBMPI ) && !(HWRF == 1) integer :: stderrlog=1 ! 1/T = send to write(0,...) if buffered=0 #else integer :: stderrlog=0! 1/T = send to write(0,...) if buffered=0 @@ -81,31 +81,31 @@ SUBROUTINE init_module_wrf_error(on_io_server) #if defined(DM_PARALLEL) LOGICAL, EXTERNAL :: wrf_dm_on_monitor #endif - LOGICAL :: compute_slaves_silent + LOGICAL :: compute_tasks_silent LOGICAL :: io_servers_silent INTEGER :: buffer_size,iostat,stderr_logging - namelist /logging/ buffer_size,compute_slaves_silent, & + namelist /logging/ buffer_size,compute_tasks_silent, & io_servers_silent,stderr_logging ! MAKE SURE THE NAMELIST DEFAULTS MATCH THE DEFAULT VALUES ! AT THE MODULE LEVEL ! Default: original behavior. No buffering, all ranks talk - compute_slaves_silent=.false. + compute_tasks_silent=.false. io_servers_silent=.false. buffer_size=0 ! MPI configurations default to stderr logging, except for HWRF. ! Non-MPI does not log to stderr. (Note that fatal errors always ! are sent to both stdout and stderr regardless of config.) -#if defined( DM_PARALLEL ) && ! defined( STUBMPI ) && !defined(HWRF) +#if defined( DM_PARALLEL ) && ! defined( STUBMPI ) && !(HWRF == 1) stderr_logging=1 #else stderr_logging=0 #endif 500 format(A) ! Open namelist.input using the same unit used by module_io_wrf - ! since we know nobody will screw up that unit: + ! since we know nobody else will use that unit: OPEN(unit=27, file="namelist.input", form="formatted", status="old") READ(27,nml=logging,iostat=iostat) if(iostat /= 0) then @@ -158,7 +158,7 @@ SUBROUTINE init_module_wrf_error(on_io_server) return endif endif - if(compute_slaves_silent) then + if(compute_tasks_silent) then if(wrf_dm_on_monitor()) then silence=0 else @@ -305,6 +305,9 @@ SUBROUTINE wrf_error_fatal3( file_str, line, str ) CALL esmf_finalize(endflag=ESMF_END_ABORT) #endif +#ifdef TRACEBACKQQ + CALL tracebackqq +#endif CALL wrf_abort END SUBROUTINE wrf_error_fatal3 diff --git a/wrfv2_fire/hydro/.svn/all-wcprops b/wrfv2_fire/hydro/.svn/all-wcprops deleted file mode 100644 index dc82d41c..00000000 --- a/wrfv2_fire/hydro/.svn/all-wcprops +++ /dev/null @@ -1,17 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 52 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro -END -configure -K 25 -svn:wc:ra_dav:version-url -V 62 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/configure -END -wrf_hydro_config -K 25 -svn:wc:ra_dav:version-url -V 69 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/wrf_hydro_config -END diff --git a/wrfv2_fire/hydro/.svn/entries b/wrfv2_fire/hydro/.svn/entries deleted file mode 100644 index 7bfa1a21..00000000 --- a/wrfv2_fire/hydro/.svn/entries +++ /dev/null @@ -1,117 +0,0 @@ -10 - -dir -9105 -https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro -https://kkeene@svn-wrf-model.cgd.ucar.edu - - - -2015-02-13T18:35:30.360105Z -8075 -weiyu@ucar.edu - - - - - - - - - - - - - - -b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d - -HYDRO_drv -dir - -configure -file - - - - -2016-02-11T20:37:50.236264Z -3f7003464a22be1e14d86f1ef73867eb -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu -has-props - - - - - - - - - - - - - - - - - - - - -3506 - -Data_Rec -dir - -Run -dir - -arc -dir - -Routing -dir - -wrf_hydro_config -file - - - - -2016-02-11T20:37:50.234759Z -cdded48ac3d16f3ab131ea7500240998 -2013-02-22T21:30:52.969349Z -6386 -weiyu@ucar.edu -has-props - - - - - - - - - - - - - - - - - - - - -948 - -MPP -dir - -CPL -dir - diff --git a/wrfv2_fire/hydro/.svn/prop-base/configure.svn-base b/wrfv2_fire/hydro/.svn/prop-base/configure.svn-base deleted file mode 100644 index 869ac71c..00000000 --- a/wrfv2_fire/hydro/.svn/prop-base/configure.svn-base +++ /dev/null @@ -1,5 +0,0 @@ -K 14 -svn:executable -V 1 -* -END diff --git a/wrfv2_fire/hydro/.svn/prop-base/wrf_hydro_config.svn-base b/wrfv2_fire/hydro/.svn/prop-base/wrf_hydro_config.svn-base deleted file mode 100644 index 869ac71c..00000000 --- a/wrfv2_fire/hydro/.svn/prop-base/wrf_hydro_config.svn-base +++ /dev/null @@ -1,5 +0,0 @@ -K 14 -svn:executable -V 1 -* -END diff --git a/wrfv2_fire/hydro/.svn/text-base/configure.svn-base b/wrfv2_fire/hydro/.svn/text-base/configure.svn-base deleted file mode 100644 index 5848f116..00000000 --- a/wrfv2_fire/hydro/.svn/text-base/configure.svn-base +++ /dev/null @@ -1,107 +0,0 @@ -#!/usr/bin/perl - - if(! defined($ENV{NETCDF_INC})){ - if(defined($ENV{NETCDF})) { - $tt = `echo "NETCDF_INC = \${NETCDF}/include" > macros.tmp` ; - } else { - print"Error: environment variable NETCDF_INC not defined. \n"; - exit(0); - } - } - - ${NETCDF_LIB} = $ENV{NETCDF_LIB}; - if(! defined($ENV{NETCDF_LIB})){ - if(defined($ENV{NETCDF})) { - $tt = `echo "NETCDF_LIB = \${NETCDF}/lib" >> macros.tmp` ; - ${NETCDF_LIB} = $ENV{NETCDF}."/lib"; - } else { - print"Error: environment variable NETCDF_LIB not defined. \n"; - exit(0); - } - } - - if(! -e "${NETCDF_LIB}/libnetcdff.a"){ - $tt = `echo "NETCDFLIB = -L${NETCDF_LIB} -lnetcdf" >> macros.tmp `; - } - - if(-e macros) {system (rm -f macros);} -# if(-e Makefile) {system "rm -f Makefile" ;} - -# system("cp arc/Makefile ."); - - if($#ARGV == 0) { - $response = shift(@ARGV) ; - print("Configure hydro: $response \n"); - }else { - print "Please select from following supported options. \n\n"; - - print " 1. Linux PGI compiler sequential \n"; - print " 2. Linux PGI compiler dmpar \n"; - print " 3. IBM AIX compiler sequential, xlf90_r\n"; - print " 4. IBM AIX compiler dmpar \n"; - print " 5. Linux gfort compiler sequential \n"; - print " 6. Linux gfort compiler dmpar \n"; - print " 7. Linux ifort compiler sequential \n"; - print " 8. Linux ifort compiler dmpar \n"; - print " 0. exit only \n"; - - printf "\nEnter selection [%d-%d] : ",1,5 ; - - $response = ; - chop($response); - } - - use Switch; - switch ($response) { - case 1 { - # sequential linux - system "cp arc/macros.seq.linux macros"; - system "cp arc/Makefile.seq Makefile.comm"; - } - - case 2 { - # mpp linux - system "cp arc/macros.mpp.linux macros"; - system "cp arc/Makefile.mpp Makefile.comm"; - } - - case 3 { - # sequential IBM AIX - system "cp arc/macros.seq.IBM.xlf90_r macros"; - system "cp arc/Makefile.seq Makefile.comm"; - } - - case 4 { - # mpp IBM AIX - system "cp arc/macros.mpp.IBM.xlf90_r macros"; - system "cp arc/Makefile.mpp Makefile.comm"; - } - - case 5 { - # GFORTRAN only - system "cp arc/macros.seq.gfort macros"; - system "cp arc/Makefile.seq Makefile.comm"; - } - - case 6 { - # GFORTRAN dmpar only - system "cp arc/macros.mpp.gfort macros"; - system "cp arc/Makefile.mpp Makefile.comm"; - } - case 7 { - # ifort sequential - system "cp arc/macros.seq.ifort macros"; - system "cp arc/Makefile.seq Makefile.comm"; - } - case 8 { - # ifort dmpar only - system "cp arc/macros.mpp.ifort macros"; - system "cp arc/Makefile.mpp Makefile.comm"; - } - - else {print "no selection $response\n"; last} - } - if(! (-e lib)) {mkdir lib;} - if(! (-e mod)) {mkdir mod;} - if(-e "macros.tmp") { system("cat macros macros.tmp > macros.a; rm -f macros.tmp; mv macros.a macros");} - if((-d "LandModel") ) {system "cat macros LandModel/user_build_options.bak > LandModel/user_build_options";} diff --git a/wrfv2_fire/hydro/.svn/text-base/wrf_hydro_config.svn-base b/wrfv2_fire/hydro/.svn/text-base/wrf_hydro_config.svn-base deleted file mode 100644 index 47548324..00000000 --- a/wrfv2_fire/hydro/.svn/text-base/wrf_hydro_config.svn-base +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/perl -#input argument: Compiler/System sequential/parallel -#This is called by WRF configuration only. -if($#ARGV ne 1) { - print("Error: No such configuration for Hydro \n"); - exit(1); -} - $x = lc(shift(@ARGV)); - $paropt = lc(shift(@ARGV)); - - print("Configure option for Hydro : $x $paropt \n"); - if($x =~ "pgi") { - if($paropt eq 'serial') { system("./configure 1");} - else {system("./configure 2");} - } - if($x =~ "aix") { - if($paropt eq 'serial') { system("./configure 3");} - else {system("./configure 4");} - } - if($x =~ "gfortran") { - if($paropt eq 'serial') { system("./configure 5");} - else {system("./configure 6");} - } - if($x =~ "ifort") { - if($paropt eq 'serial') { system("./configure 7");} - else {system("./configure 8");} - } - diff --git a/wrfv2_fire/hydro/CPL/.svn/all-wcprops b/wrfv2_fire/hydro/CPL/.svn/all-wcprops deleted file mode 100644 index 17be25a2..00000000 --- a/wrfv2_fire/hydro/CPL/.svn/all-wcprops +++ /dev/null @@ -1,5 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 56 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL -END diff --git a/wrfv2_fire/hydro/CPL/.svn/entries b/wrfv2_fire/hydro/CPL/.svn/entries deleted file mode 100644 index b6a09ea6..00000000 --- a/wrfv2_fire/hydro/CPL/.svn/entries +++ /dev/null @@ -1,31 +0,0 @@ -10 - -dir -9105 -https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/CPL -https://kkeene@svn-wrf-model.cgd.ucar.edu - - - -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - -b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d - -WRF_cpl -dir - diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/all-wcprops b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/all-wcprops deleted file mode 100644 index 781d2007..00000000 --- a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/all-wcprops +++ /dev/null @@ -1,29 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 64 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl -END -wrf_drv_HYDRO.F -K 25 -svn:wc:ra_dav:version-url -V 80 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F -END -Makefile.cpl -K 25 -svn:wc:ra_dav:version-url -V 77 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl/Makefile.cpl -END -module_wrf_HYDRO.F -K 25 -svn:wc:ra_dav:version-url -V 83 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F -END -Makefile -K 25 -svn:wc:ra_dav:version-url -V 73 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl/Makefile -END diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/entries b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/entries deleted file mode 100644 index 44158a6c..00000000 --- a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/entries +++ /dev/null @@ -1,164 +0,0 @@ -10 - -dir -9105 -https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/CPL/WRF_cpl -https://kkeene@svn-wrf-model.cgd.ucar.edu - - - -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - -b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d - -wrf_drv_HYDRO.F -file - - - - -2016-02-11T20:37:50.172606Z -6e1e076f2e8b1e1efb225f08dde43a2b -2012-12-07T20:01:45.900797Z -6094 -gill - - - - - - - - - - - - - - - - - - - - - -909 - -Makefile.cpl -file - - - - -2016-02-11T20:37:50.169433Z -ae2c681e0c2a0970fc2beb3d446630b5 -2013-11-15T19:40:36.446206Z -6964 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -132 - -module_wrf_HYDRO.F -file - - - - -2016-02-11T20:37:50.170735Z -bf29748e6330d3d497a4ca9714d98296 -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -10480 - -Makefile -file - - - - -2016-02-11T20:37:50.171667Z -ea417729522d5ddb60fafaacd56dda2b -2013-11-15T19:40:36.446206Z -6964 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -673 - diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.cpl.svn-base b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.cpl.svn-base deleted file mode 100644 index 64550bdb..00000000 --- a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.cpl.svn-base +++ /dev/null @@ -1,9 +0,0 @@ -# Makefile - -all: - (cd ../../; make -f Makefile.comm BASIC) - (make) - -clean: - (make clean) - (cd ../../; make -f Makefile.comm clean) diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.svn-base b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.svn-base deleted file mode 100644 index a37fbe0d..00000000 --- a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/Makefile.svn-base +++ /dev/null @@ -1,34 +0,0 @@ -# Makefile -# -.SUFFIXES: -.SUFFIXES: .o .F - - - -include ../../macros - -MODFLAG = -I./ -I ../../MPP -I ../../mod - -WRF_ROOT = ../../.. -OBJS = \ - module_wrf_HYDRO.o \ - wrf_drv_HYDRO.o -all: $(OBJS) - -.F.o: - @echo "" - $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f - $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I$(WRF_ROOT)/frame -I$(WRF_ROOT)/main -I$(WRF_ROOT)/external/esmf_time_f90 $(*).f - $(RMD) $(*).f - @echo "" - ar -r ../../lib/libHYDRO.a $(@) - -# -# Dependencies: -# -module_wrf_HYDRO.o: ../../Data_Rec/module_RT_data.o ../../Data_Rec/module_namelist.o ../../HYDRO_drv/module_HYDRO_drv.o - -wrf_drv_HYDRO.o: module_wrf_HYDRO.o - -clean: - rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/module_wrf_HYDRO.F.svn-base b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/module_wrf_HYDRO.F.svn-base deleted file mode 100644 index 700ca2a1..00000000 --- a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/module_wrf_HYDRO.F.svn-base +++ /dev/null @@ -1,341 +0,0 @@ -module module_WRF_HYDRO - -#ifdef MPP_LAND - use module_mpp_land, only: global_nx, global_ny, decompose_data_real, & - write_io_real, my_id, mpp_land_bcast_real1, IO_id, & - mpp_land_bcast_real, mpp_land_bcast_int1 -#endif - use module_HYDRO_drv, only: HYDRO_ini, HYDRO_exe - - use module_rt_data, only: rt_domain - use module_CPL_LAND, only: CPL_LAND_INIT, cpl_outdate - use module_namelist, only: nlst_rt - USE module_domain, ONLY : domain, domain_clock_get - !yw USE module_configure, only : config_flags - USE module_configure, only: model_config_rec - - - implicit none - - !yw added for check soil moisture and soiltype - integer :: checkSOIL_flag - -! -! added to consider the adaptive time step from WRF model. - real :: dtrt0 - integer :: mm0 - - - - -CONTAINS - -!wrf_cpl_HYDRO will not call the off-line lsm - subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) - - implicit none - TYPE ( domain ), INTENT(INOUT) :: grid - integer its, ite, jts, jte, ij - real :: HYDRO_dt - - - integer k, ix,jx, mm, nn - - integer :: did - - integer ntime - - integer :: i,j - - -!output flux and state variable - - did = 1 - ix = ite - its + 1 - jx = jte - jts + 1 - - if(HYDRO_dt .le. 0) then - write(6,*) "Warning: HYDRO_dt <= 0 from land input. set it to be 1 seconds." - HYDRO_dt = 1 - endif - - ntime = 1 - - - nlst_rt(did)%dt = HYDRO_dt - - - if(.not. RT_DOMAIN(did)%initialized) then - - - !yw nlst_rt(did)%nsoil = config_flags%num_soil_layers - !nlst_rt(did)%nsoil = model_config_rec%num_metgrid_soil_levels - nlst_rt(did)%nsoil = grid%num_soil_layers - - -#ifdef MPP_LAND - call mpp_land_bcast_int1 (nlst_rt(did)%nsoil) -#endif - allocate(nlst_rt(did)%zsoil8(nlst_rt(did)%nsoil)) - if(grid%zs(1) < 0) then - nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = grid%zs(1:nlst_rt(did)%nsoil) - else - nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = -1*grid%zs(1:nlst_rt(did)%nsoil) - endif - - CALL domain_clock_get( grid, current_timestr=cpl_outdate) - nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19) - nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19) - - - call CPL_LAND_INIT(its,ite,jts,jte) - -#ifdef HYDRO_D - write(6,*) "sf_surface_physics is ", grid%sf_surface_physics -#endif - - if(grid%sf_surface_physics .eq. 5) then - ! clm4 - call HYDRO_ini(ntime,did=did,ix0=1,jx0=1) - else - call HYDRO_ini(ntime,did,ix0=ix,jx0=jx,vegtyp=grid%IVGTYP(its:ite,jts:jte),soltyp=grid%isltyp(its:ite,jts:jte)) - endif - - - - if(nlst_rt(did)%sys_cpl .ne. 2) then - write(6,*) "Error: sys_cpl should be 2." - call hydro_stop() - endif - - - nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19) - nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19) - - nlst_rt(did)%dt = HYDRO_dt - if(nlst_rt(did)%dtrt .lt. HYDRO_dt) then - nlst_rt(did)%dtrt = HYDRO_dt - mm0 = 1 - else - mm = HYDRO_dt/nlst_rt(did)%dtrt - if(mm*nlst_rt(did)%dtrt .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm - mm0 = mm - endif - - dtrt0 = nlst_rt(did)%dtrt - endif - - if((mm0*nlst_rt(did)%dtrt) .ne. HYDRO_dt) then ! WRF model time step changed. - if(dtrt0 .lt. HYDRO_dt) then - nlst_rt(did)%dtrt = HYDRO_dt - mm0 = 1 - else - mm = HYDRO_dt/dtrt0 - if(mm*dtrt0 .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm - mm0 = mm - endif - endif - -#ifdef HYDRO_D - write(6,*) "mm, nlst_rt(did)%dt = ",mm, nlst_rt(did)%dt -#endif - - if(nlst_rt(did)%SUBRTSWCRT .eq.0 & - .and. nlst_rt(did)%OVRTSWCRT .eq. 0 .and. nlst_rt(did)%GWBASESWCRT .eq. 0) return - - nn = nlst_rt(did)%nsoil - - ! get the data from WRF - - - if((.not. RT_DOMAIN(did)%initialized) .and. (nlst_rt(did)%rst_typ .eq. 1) ) then -#ifdef HYDRO_D - write(6,*) "restart initial data from offline file" -#endif - else - do k = 1, nlst_rt(did)%nsoil - RT_DOMAIN(did)%STC(:,:,k) = grid%TSLB(its:ite,k,jts:jte) - RT_DOMAIN(did)%smc(:,:,k) = grid%smois(its:ite,k,jts:jte) - RT_DOMAIN(did)%sh2ox(:,:,k) = grid%sh2o(its:ite,k,jts:jte) - end do - rt_domain(did)%infxsrt = grid%infxsrt(its:ite,jts:jte) - rt_domain(did)%soldrain = grid%soldrain(its:ite,jts:jte) - endif - - -!yw if(checkSOIL_flag .ne. 99) then -!yw call checkSoil(did) -!yw checkSOIL_flag = 99 -!yw endif - - call HYDRO_exe(did) - - -! add for update the WRF state variable. - do k = 1, nlst_rt(did)%nsoil - ! grid%TSLB(its:ite,k,jts:jte) = RT_DOMAIN(did)%STC(:,:,k) - grid%smois(its:ite,k,jts:jte) = RT_DOMAIN(did)%smc(:,:,k) - grid%sh2o(its:ite,k,jts:jte) = RT_DOMAIN(did)%sh2ox(:,:,k) - end do - -! update WRF variable after running routing model. - grid%sfcheadrt(its:ite,jts:jte) = rt_domain(did)%sfcheadrt - -!yw not sure for the following -! grid%xice(its:ite,jts:jte) = rt_domain(did)%sice - - RT_DOMAIN(did)%initialized = .true. - end subroutine wrf_cpl_HYDRO - - - - - -!program drive rtland -! This subroutine will be used if the 4-layer Noah lsm is not used. - subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) -! input: z1,v1,kk1,z,ix,jx,kk -! output: vout -! interpolate based on soil layer: z1 and z -! z : soil layer of output variable. -! z1: array of soil layers of input variable. - implicit none - integer:: i,j,k - integer:: kk1, ix,jx,kk, vegtyp(ix,jx) - real :: z1(kk1), z(kk), v1(ix,kk1,jx),vout(ix,jx,kk) - - - do j = 1, jx - do i = 1, ix - do k = 1, kk - call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) - end do - end do - end do - end subroutine wrf2lsm - -! This subroutine will be used if the 4-layer Noah lsm is not used. - subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) -! input: z1,v1,kk1,z,ix,jx,kk -! output: vout -! interpolate based on soil layer: z1 and z -! z : soil layer of output variable. -! z1: array of soil layers of input variable. - implicit none - integer:: i,j,k - integer:: kk1, ix,jx,kk, vegtyp(ix,jx) - real :: z1(kk1), z(kk), v1(ix,jx,kk1),vout(ix,kk,jx) - - - do j = 1, jx - do i = 1, ix - do k = 1, kk - call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) - end do - end do - end do - end subroutine lsm2wrf - - subroutine interpLayer(inZ,inV,inK,outZ,outV) - implicit none - integer:: k, k1, k2 - integer :: inK - real:: inV(inK),inZ(inK) - real:: outV, outZ, w1, w2 - - if(outZ .le. inZ(1)) then - w1 = (inZ(2)-outZ)/(inZ(2)-inZ(1)) - w2 = (inZ(1)-outZ)/(inZ(2)-inZ(1)) - outV = inV(1)*w1-inV(2)*w2 - return - elseif(outZ .ge. inZ(inK)) then - w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) - w2 = (outZ-inZ(inK)) /(inZ(inK)-inZ(inK-1)) - outV = inV(inK)*w1 -inV(inK-1)* w2 - return - else - do k = 2, inK - if((inZ(k) .ge. outZ).and.(inZ(k-1) .le. outZ) ) then - k1 = k-1 - k2 = k - w1 = (outZ-inZ(k1))/(inZ(k2)-inZ(k1)) - w2 = (inZ(k2)-outZ)/(inZ(k2)-inZ(k1)) - outV = inV(k2)*w1 + inV(k1)*w2 - return - end if - end do - endif - end subroutine interpLayer - - subroutine lsm_wrf_input(did,vegtyp,soltyp,ix,jx) - implicit none - integer did, leng - parameter(leng=100) - integer :: i,j, nn, ix,jx - integer, dimension(ix,jx) :: soltyp, vegtyp - real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc - - - where(soltyp == 14) VEGTYP = 16 - where(VEGTYP == 16 ) soltyp = 14 - - RT_DOMAIN(did)%VEGTYP = vegtyp - -! input OV_ROUGH from OVROUGH.TBL -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - - open(71,file="HYDRO.TBL", form="formatted") -!read OV_ROUGH first - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) - end do -!read parameter for LKSAT - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) - end do - close(71) - -#ifdef MPP_LAND - endif - call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) - call mpp_land_bcast_real(leng,xdum1) - call mpp_land_bcast_real(leng,MAXSMC) - call mpp_land_bcast_real(leng,refsmc) - call mpp_land_bcast_real(leng,wltsmc) -#endif - - rt_domain(did)%lksat = 0.0 - do j = 1, RT_DOMAIN(did)%jx - do i = 1, RT_DOMAIN(did)%ix - rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 - IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN ! urban - rt_domain(did)%SMCMAX1(i,j) = 0.45 - rt_domain(did)%SMCREF1(i,j) = 0.42 - rt_domain(did)%SMCWLT1(i,j) = 0.40 - else - rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) - rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) - rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) - ENDIF - end do - end do - - - end subroutine lsm_wrf_input - - subroutine checkSoil(did) - implicit none - integer :: did - where(rt_domain(did)%smc(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16 - where(rt_domain(did)%sh2ox(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16 - where(rt_domain(did)%smc(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16 - where(rt_domain(did)%sh2ox(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16 - end subroutine checkSoil - -end module module_wrf_HYDRO diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/wrf_drv_HYDRO.F.svn-base b/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/wrf_drv_HYDRO.F.svn-base deleted file mode 100644 index 70939c26..00000000 --- a/wrfv2_fire/hydro/CPL/WRF_cpl/.svn/text-base/wrf_drv_HYDRO.F.svn-base +++ /dev/null @@ -1,31 +0,0 @@ -!2345678 - subroutine wrf_drv_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) - use module_wrf_HYDRO, only: wrf_cpl_HYDRO - USE module_domain, ONLY : domain - implicit none - integer:: its,ite,jts,jte - real :: HYDRO_dt - TYPE ( domain ), INTENT(INOUT) :: grid -! return - - if(grid%num_nests .lt. 1) then - - call wrf_cpl_HYDRO(HYDRO_dt, grid,its,ite,jts,jte) - - endif - end subroutine wrf_drv_HYDRO - - - subroutine wrf_drv_HYDRO_ini(grid,its,ite,jts,jte) - use module_wrf_HYDRO, only: wrf_cpl_HYDRO - USE module_domain, ONLY : domain - implicit none - integer:: its,ite,jts,jte - TYPE ( domain ), INTENT(INOUT) :: grid - - if(grid%num_nests .lt. 1) then -! call wrf_cpl_HYDRO_ini(grid,its,ite,jts,jte) - endif - - end subroutine wrf_drv_HYDRO_ini - diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile deleted file mode 100644 index a37fbe0d..00000000 --- a/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile +++ /dev/null @@ -1,34 +0,0 @@ -# Makefile -# -.SUFFIXES: -.SUFFIXES: .o .F - - - -include ../../macros - -MODFLAG = -I./ -I ../../MPP -I ../../mod - -WRF_ROOT = ../../.. -OBJS = \ - module_wrf_HYDRO.o \ - wrf_drv_HYDRO.o -all: $(OBJS) - -.F.o: - @echo "" - $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f - $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I$(WRF_ROOT)/frame -I$(WRF_ROOT)/main -I$(WRF_ROOT)/external/esmf_time_f90 $(*).f - $(RMD) $(*).f - @echo "" - ar -r ../../lib/libHYDRO.a $(@) - -# -# Dependencies: -# -module_wrf_HYDRO.o: ../../Data_Rec/module_RT_data.o ../../Data_Rec/module_namelist.o ../../HYDRO_drv/module_HYDRO_drv.o - -wrf_drv_HYDRO.o: module_wrf_HYDRO.o - -clean: - rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl deleted file mode 100644 index 64550bdb..00000000 --- a/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl +++ /dev/null @@ -1,9 +0,0 @@ -# Makefile - -all: - (cd ../../; make -f Makefile.comm BASIC) - (make) - -clean: - (make clean) - (cd ../../; make -f Makefile.comm clean) diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F deleted file mode 100644 index 700ca2a1..00000000 --- a/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F +++ /dev/null @@ -1,341 +0,0 @@ -module module_WRF_HYDRO - -#ifdef MPP_LAND - use module_mpp_land, only: global_nx, global_ny, decompose_data_real, & - write_io_real, my_id, mpp_land_bcast_real1, IO_id, & - mpp_land_bcast_real, mpp_land_bcast_int1 -#endif - use module_HYDRO_drv, only: HYDRO_ini, HYDRO_exe - - use module_rt_data, only: rt_domain - use module_CPL_LAND, only: CPL_LAND_INIT, cpl_outdate - use module_namelist, only: nlst_rt - USE module_domain, ONLY : domain, domain_clock_get - !yw USE module_configure, only : config_flags - USE module_configure, only: model_config_rec - - - implicit none - - !yw added for check soil moisture and soiltype - integer :: checkSOIL_flag - -! -! added to consider the adaptive time step from WRF model. - real :: dtrt0 - integer :: mm0 - - - - -CONTAINS - -!wrf_cpl_HYDRO will not call the off-line lsm - subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) - - implicit none - TYPE ( domain ), INTENT(INOUT) :: grid - integer its, ite, jts, jte, ij - real :: HYDRO_dt - - - integer k, ix,jx, mm, nn - - integer :: did - - integer ntime - - integer :: i,j - - -!output flux and state variable - - did = 1 - ix = ite - its + 1 - jx = jte - jts + 1 - - if(HYDRO_dt .le. 0) then - write(6,*) "Warning: HYDRO_dt <= 0 from land input. set it to be 1 seconds." - HYDRO_dt = 1 - endif - - ntime = 1 - - - nlst_rt(did)%dt = HYDRO_dt - - - if(.not. RT_DOMAIN(did)%initialized) then - - - !yw nlst_rt(did)%nsoil = config_flags%num_soil_layers - !nlst_rt(did)%nsoil = model_config_rec%num_metgrid_soil_levels - nlst_rt(did)%nsoil = grid%num_soil_layers - - -#ifdef MPP_LAND - call mpp_land_bcast_int1 (nlst_rt(did)%nsoil) -#endif - allocate(nlst_rt(did)%zsoil8(nlst_rt(did)%nsoil)) - if(grid%zs(1) < 0) then - nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = grid%zs(1:nlst_rt(did)%nsoil) - else - nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = -1*grid%zs(1:nlst_rt(did)%nsoil) - endif - - CALL domain_clock_get( grid, current_timestr=cpl_outdate) - nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19) - nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19) - - - call CPL_LAND_INIT(its,ite,jts,jte) - -#ifdef HYDRO_D - write(6,*) "sf_surface_physics is ", grid%sf_surface_physics -#endif - - if(grid%sf_surface_physics .eq. 5) then - ! clm4 - call HYDRO_ini(ntime,did=did,ix0=1,jx0=1) - else - call HYDRO_ini(ntime,did,ix0=ix,jx0=jx,vegtyp=grid%IVGTYP(its:ite,jts:jte),soltyp=grid%isltyp(its:ite,jts:jte)) - endif - - - - if(nlst_rt(did)%sys_cpl .ne. 2) then - write(6,*) "Error: sys_cpl should be 2." - call hydro_stop() - endif - - - nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19) - nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19) - - nlst_rt(did)%dt = HYDRO_dt - if(nlst_rt(did)%dtrt .lt. HYDRO_dt) then - nlst_rt(did)%dtrt = HYDRO_dt - mm0 = 1 - else - mm = HYDRO_dt/nlst_rt(did)%dtrt - if(mm*nlst_rt(did)%dtrt .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm - mm0 = mm - endif - - dtrt0 = nlst_rt(did)%dtrt - endif - - if((mm0*nlst_rt(did)%dtrt) .ne. HYDRO_dt) then ! WRF model time step changed. - if(dtrt0 .lt. HYDRO_dt) then - nlst_rt(did)%dtrt = HYDRO_dt - mm0 = 1 - else - mm = HYDRO_dt/dtrt0 - if(mm*dtrt0 .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm - mm0 = mm - endif - endif - -#ifdef HYDRO_D - write(6,*) "mm, nlst_rt(did)%dt = ",mm, nlst_rt(did)%dt -#endif - - if(nlst_rt(did)%SUBRTSWCRT .eq.0 & - .and. nlst_rt(did)%OVRTSWCRT .eq. 0 .and. nlst_rt(did)%GWBASESWCRT .eq. 0) return - - nn = nlst_rt(did)%nsoil - - ! get the data from WRF - - - if((.not. RT_DOMAIN(did)%initialized) .and. (nlst_rt(did)%rst_typ .eq. 1) ) then -#ifdef HYDRO_D - write(6,*) "restart initial data from offline file" -#endif - else - do k = 1, nlst_rt(did)%nsoil - RT_DOMAIN(did)%STC(:,:,k) = grid%TSLB(its:ite,k,jts:jte) - RT_DOMAIN(did)%smc(:,:,k) = grid%smois(its:ite,k,jts:jte) - RT_DOMAIN(did)%sh2ox(:,:,k) = grid%sh2o(its:ite,k,jts:jte) - end do - rt_domain(did)%infxsrt = grid%infxsrt(its:ite,jts:jte) - rt_domain(did)%soldrain = grid%soldrain(its:ite,jts:jte) - endif - - -!yw if(checkSOIL_flag .ne. 99) then -!yw call checkSoil(did) -!yw checkSOIL_flag = 99 -!yw endif - - call HYDRO_exe(did) - - -! add for update the WRF state variable. - do k = 1, nlst_rt(did)%nsoil - ! grid%TSLB(its:ite,k,jts:jte) = RT_DOMAIN(did)%STC(:,:,k) - grid%smois(its:ite,k,jts:jte) = RT_DOMAIN(did)%smc(:,:,k) - grid%sh2o(its:ite,k,jts:jte) = RT_DOMAIN(did)%sh2ox(:,:,k) - end do - -! update WRF variable after running routing model. - grid%sfcheadrt(its:ite,jts:jte) = rt_domain(did)%sfcheadrt - -!yw not sure for the following -! grid%xice(its:ite,jts:jte) = rt_domain(did)%sice - - RT_DOMAIN(did)%initialized = .true. - end subroutine wrf_cpl_HYDRO - - - - - -!program drive rtland -! This subroutine will be used if the 4-layer Noah lsm is not used. - subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) -! input: z1,v1,kk1,z,ix,jx,kk -! output: vout -! interpolate based on soil layer: z1 and z -! z : soil layer of output variable. -! z1: array of soil layers of input variable. - implicit none - integer:: i,j,k - integer:: kk1, ix,jx,kk, vegtyp(ix,jx) - real :: z1(kk1), z(kk), v1(ix,kk1,jx),vout(ix,jx,kk) - - - do j = 1, jx - do i = 1, ix - do k = 1, kk - call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) - end do - end do - end do - end subroutine wrf2lsm - -! This subroutine will be used if the 4-layer Noah lsm is not used. - subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp) -! input: z1,v1,kk1,z,ix,jx,kk -! output: vout -! interpolate based on soil layer: z1 and z -! z : soil layer of output variable. -! z1: array of soil layers of input variable. - implicit none - integer:: i,j,k - integer:: kk1, ix,jx,kk, vegtyp(ix,jx) - real :: z1(kk1), z(kk), v1(ix,jx,kk1),vout(ix,kk,jx) - - - do j = 1, jx - do i = 1, ix - do k = 1, kk - call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) - end do - end do - end do - end subroutine lsm2wrf - - subroutine interpLayer(inZ,inV,inK,outZ,outV) - implicit none - integer:: k, k1, k2 - integer :: inK - real:: inV(inK),inZ(inK) - real:: outV, outZ, w1, w2 - - if(outZ .le. inZ(1)) then - w1 = (inZ(2)-outZ)/(inZ(2)-inZ(1)) - w2 = (inZ(1)-outZ)/(inZ(2)-inZ(1)) - outV = inV(1)*w1-inV(2)*w2 - return - elseif(outZ .ge. inZ(inK)) then - w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) - w2 = (outZ-inZ(inK)) /(inZ(inK)-inZ(inK-1)) - outV = inV(inK)*w1 -inV(inK-1)* w2 - return - else - do k = 2, inK - if((inZ(k) .ge. outZ).and.(inZ(k-1) .le. outZ) ) then - k1 = k-1 - k2 = k - w1 = (outZ-inZ(k1))/(inZ(k2)-inZ(k1)) - w2 = (inZ(k2)-outZ)/(inZ(k2)-inZ(k1)) - outV = inV(k2)*w1 + inV(k1)*w2 - return - end if - end do - endif - end subroutine interpLayer - - subroutine lsm_wrf_input(did,vegtyp,soltyp,ix,jx) - implicit none - integer did, leng - parameter(leng=100) - integer :: i,j, nn, ix,jx - integer, dimension(ix,jx) :: soltyp, vegtyp - real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc - - - where(soltyp == 14) VEGTYP = 16 - where(VEGTYP == 16 ) soltyp = 14 - - RT_DOMAIN(did)%VEGTYP = vegtyp - -! input OV_ROUGH from OVROUGH.TBL -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - - open(71,file="HYDRO.TBL", form="formatted") -!read OV_ROUGH first - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) - end do -!read parameter for LKSAT - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) - end do - close(71) - -#ifdef MPP_LAND - endif - call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) - call mpp_land_bcast_real(leng,xdum1) - call mpp_land_bcast_real(leng,MAXSMC) - call mpp_land_bcast_real(leng,refsmc) - call mpp_land_bcast_real(leng,wltsmc) -#endif - - rt_domain(did)%lksat = 0.0 - do j = 1, RT_DOMAIN(did)%jx - do i = 1, RT_DOMAIN(did)%ix - rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 - IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN ! urban - rt_domain(did)%SMCMAX1(i,j) = 0.45 - rt_domain(did)%SMCREF1(i,j) = 0.42 - rt_domain(did)%SMCWLT1(i,j) = 0.40 - else - rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) - rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) - rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) - ENDIF - end do - end do - - - end subroutine lsm_wrf_input - - subroutine checkSoil(did) - implicit none - integer :: did - where(rt_domain(did)%smc(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16 - where(rt_domain(did)%sh2ox(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16 - where(rt_domain(did)%smc(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16 - where(rt_domain(did)%sh2ox(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16 - end subroutine checkSoil - -end module module_wrf_HYDRO diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F b/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F deleted file mode 100644 index 70939c26..00000000 --- a/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F +++ /dev/null @@ -1,31 +0,0 @@ -!2345678 - subroutine wrf_drv_HYDRO(HYDRO_dt,grid,its,ite,jts,jte) - use module_wrf_HYDRO, only: wrf_cpl_HYDRO - USE module_domain, ONLY : domain - implicit none - integer:: its,ite,jts,jte - real :: HYDRO_dt - TYPE ( domain ), INTENT(INOUT) :: grid -! return - - if(grid%num_nests .lt. 1) then - - call wrf_cpl_HYDRO(HYDRO_dt, grid,its,ite,jts,jte) - - endif - end subroutine wrf_drv_HYDRO - - - subroutine wrf_drv_HYDRO_ini(grid,its,ite,jts,jte) - use module_wrf_HYDRO, only: wrf_cpl_HYDRO - USE module_domain, ONLY : domain - implicit none - integer:: its,ite,jts,jte - TYPE ( domain ), INTENT(INOUT) :: grid - - if(grid%num_nests .lt. 1) then -! call wrf_cpl_HYDRO_ini(grid,its,ite,jts,jte) - endif - - end subroutine wrf_drv_HYDRO_ini - diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/all-wcprops b/wrfv2_fire/hydro/Data_Rec/.svn/all-wcprops deleted file mode 100644 index c89eceae..00000000 --- a/wrfv2_fire/hydro/Data_Rec/.svn/all-wcprops +++ /dev/null @@ -1,47 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 61 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec -END -rt_include.inc -K 25 -svn:wc:ra_dav:version-url -V 76 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/rt_include.inc -END -module_GW_baseflow_data.F -K 25 -svn:wc:ra_dav:version-url -V 87 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/module_GW_baseflow_data.F -END -namelist.inc -K 25 -svn:wc:ra_dav:version-url -V 74 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/namelist.inc -END -module_namelist.F -K 25 -svn:wc:ra_dav:version-url -V 79 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/module_namelist.F -END -module_RT_data.F -K 25 -svn:wc:ra_dav:version-url -V 78 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/module_RT_data.F -END -gw_field_include.inc -K 25 -svn:wc:ra_dav:version-url -V 82 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/gw_field_include.inc -END -Makefile -K 25 -svn:wc:ra_dav:version-url -V 70 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec/Makefile -END diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/entries b/wrfv2_fire/hydro/Data_Rec/.svn/entries deleted file mode 100644 index d0ea24bc..00000000 --- a/wrfv2_fire/hydro/Data_Rec/.svn/entries +++ /dev/null @@ -1,266 +0,0 @@ -10 - -dir -9105 -https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/Data_Rec -https://kkeene@svn-wrf-model.cgd.ucar.edu - - - -2014-12-12T18:07:14.337132Z -7861 -weiyu@ucar.edu - - - - - - - - - - - - - - -b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d - -rt_include.inc -file - - - - -2016-02-11T20:37:50.204451Z -087b67574a7caabe012a182d53d7270d -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -9622 - -module_GW_baseflow_data.F -file - - - - -2016-02-11T20:37:50.205460Z -db442816e357cf353326bceafc35ce7b -2012-12-07T20:01:45.900797Z -6094 -gill - - - - - - - - - - - - - - - - - - - - - -213 - -namelist.inc -file - - - - -2016-02-11T20:37:50.206409Z -03b4ff65d943316bc221efa52fe15135 -2014-12-12T18:07:14.337132Z -7861 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -1447 - -module_namelist.F -file - - - - -2016-02-11T20:37:50.207508Z -d31143270f44e10a00de79054d0f66cf -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -6421 - -module_RT_data.F -file - - - - -2016-02-11T20:37:50.208511Z -114f65d6653c6fd42aae69007ff9f955 -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -250 - -gw_field_include.inc -file - - - - -2016-02-11T20:37:50.209358Z -d134109b5ab189ab9ca998823dc6c577 -2012-12-07T20:01:45.900797Z -6094 -gill - - - - - - - - - - - - - - - - - - - - - -817 - -Makefile -file - - - - -2016-02-11T20:37:50.203321Z -85c9c22506fa9f10e82cc612f727766c -2012-12-07T20:01:45.900797Z -6094 -gill - - - - - - - - - - - - - - - - - - - - - -413 - diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/Makefile.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/Makefile.svn-base deleted file mode 100644 index 398ba2fe..00000000 --- a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/Makefile.svn-base +++ /dev/null @@ -1,28 +0,0 @@ -# Makefile -# -.SUFFIXES: -.SUFFIXES: .o .F - -include ../macros - -OBJS = \ - module_namelist.o \ - module_RT_data.o \ - module_GW_baseflow_data.o - -all: $(OBJS) - -.F.o: - @echo "" - $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f - $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I../mod $(*).f - $(RMD) $(*).f - @echo "" - ar -r ../lib/libHYDRO.a $(@) - cp *.mod ../mod - -# Dependencies: -# - -clean: - rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/gw_field_include.inc.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/gw_field_include.inc.svn-base deleted file mode 100644 index 99c79886..00000000 --- a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/gw_field_include.inc.svn-base +++ /dev/null @@ -1,26 +0,0 @@ - - type gw_field - integer :: ix, jx - integer :: allo_status = -99 - - real :: dx, dt - - integer, allocatable, dimension(:,:) :: ltype ! land-sfc type - real, allocatable, dimension(:,:) :: & - elev, & ! elev/bathymetry of sfc rel to sl (m) - bot, & ! elev. aquifer bottom rel to sl (m) - hycond, & ! hydraulic conductivity (m/s per m/m) - poros, & ! porosity (m3/m3) - compres, & ! compressibility (1/Pa) - ho ! head at start of timestep (m) - - real, allocatable, dimension(:,:) :: & - h, & ! head, after ghmcompute (m) - convgw ! convergence due to gw flow (m/s) - - real :: ebot, eocn - integer ::istep = 0 - - - end type gw_field - diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_GW_baseflow_data.F.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_GW_baseflow_data.F.svn-base deleted file mode 100644 index 4b171683..00000000 --- a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_GW_baseflow_data.F.svn-base +++ /dev/null @@ -1,9 +0,0 @@ -Module module_GW_baseflow_data - IMPLICIT NONE - INTEGER, PARAMETER :: max_domain=5 - -#include "gw_field_include.inc" - type (gw_field) :: gw2d(max_domain) - save gw2d - -end module module_GW_baseflow_data diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_RT_data.F.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_RT_data.F.svn-base deleted file mode 100644 index 2fd80414..00000000 --- a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_RT_data.F.svn-base +++ /dev/null @@ -1,10 +0,0 @@ -Module module_RT_data - IMPLICIT NONE - INTEGER, PARAMETER :: max_domain=5 - -! define Routing data -#include "rt_include.inc" - TYPE ( RT_FIELD ), DIMENSION (max_domain) :: RT_DOMAIN - save RT_DOMAIN - integer :: cur_did -end module module_RT_data diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_namelist.F.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_namelist.F.svn-base deleted file mode 100644 index 936b7ba6..00000000 --- a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/module_namelist.F.svn-base +++ /dev/null @@ -1,203 +0,0 @@ -Module module_namelist - -#ifdef MPP_LAND - USE module_mpp_land -#endif - - IMPLICIT NONE - INTEGER, PARAMETER :: max_domain=5 - -#include "namelist.inc" - TYPE(namelist_rt_field) , dimension(max_domain) :: nlst_rt - save nlst_rt - -CONTAINS - - subroutine read_rt_nlst(nlst) - implicit none - - TYPE(namelist_rt_field) nlst - - integer ierr - integer:: RT_OPTION, CHANRTSWCRT, channel_option, & - SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, & - GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & - sys_cpl, rst_typ - real:: DTRT,dxrt - character(len=256) :: route_topo_f="" - character(len=256) :: route_chan_f="" - character(len=256) :: route_link_f="" - character(len=256) :: route_lake_f="" - character(len=256) :: route_direction_f="" - character(len=256) :: route_order_f="" - character(len=256) :: gwbasmskfil ="" - character(len=256) :: gwstrmfil ="" - character(len=256) :: geo_finegrid_flnm ="" - integer :: SOLVEG_INITSWC - real out_dt, rst_dt - character(len=256) :: RESTART_FILE = "" - logical :: history_output - integer :: split_output_count, order_to_write - integer :: igrid - character(len=256) :: geo_static_flnm = "" - integer :: DEEPGWSPIN - - integer :: HIRES_OUT - integer :: i - -!!! add the following two dummy variables - integer :: NSOIL - real :: ZSOIL8(8) - - namelist /HYDRO_nlist/ NSOIL, ZSOIL8,& - RESTART_FILE,HISTORY_OUTPUT,SPLIT_OUTPUT_COUNT,IGRID,& - geo_static_flnm, & - out_dt, rst_dt, & - HIRES_OUT, & - DEEPGWSPIN, SOLVEG_INITSWC, & - RT_OPTION, CHANRTSWCRT, channel_option, & - SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, dtrt,dxrt,& - GWBASESWCRT,route_topo_f,route_chan_f,route_link_f,route_lake_f, & - route_direction_f,route_order_f,gwbasmskfil, geo_finegrid_flnm,& - gwstrmfil,GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, sys_cpl, & - order_to_write , rst_typ -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - open(30, file="hydro.namelist", form="FORMATTED") - read(30, HYDRO_nlist, iostat=ierr) - close(30) -#ifdef MPP_LAND - endif -#endif - - -#ifdef MPP_LAND -! call mpp_land_bcast_real1(DT) - call mpp_land_bcast_int1(SPLIT_OUTPUT_COUNT) - call mpp_land_bcast_int1(IGRID) - call mpp_land_bcast_real1(out_dt) - call mpp_land_bcast_real1(rst_dt) - call mpp_land_bcast_int1(HIRES_OUT) - call mpp_land_bcast_int1(DEEPGWSPIN) - call mpp_land_bcast_int1(SOLVEG_INITSWC) -#endif - - -#ifdef MPP_LAND - call mpp_land_bcast_int1(nlst%NSOIL) - do i = 1, nlst%NSOIL - call mpp_land_bcast_real1(nlst%ZSOIL8(i)) - end do -#ifdef HYDRO_D - write(6,*) "nlst%NSOIL = ", nlst%NSOIL - write(6,*) "nlst%ZSOIL8 = ",nlst%ZSOIL8 -#endif -#endif - -! nlst%DT = DT - nlst%RESTART_FILE = RESTART_FILE - nlst%HISTORY_OUTPUT = HISTORY_OUTPUT - nlst%SPLIT_OUTPUT_COUNT = SPLIT_OUTPUT_COUNT - nlst%IGRID = IGRID - nlst%geo_static_flnm = geo_static_flnm - nlst%out_dt = out_dt - nlst%rst_dt = rst_dt - nlst%HIRES_OUT = HIRES_OUT - nlst%DEEPGWSPIN = DEEPGWSPIN - nlst%SOLVEG_INITSWC = SOLVEG_INITSWC - - write(nlst%hgrid,'(I1)') igrid - - - if(RESTART_FILE .eq. "") rst_typ = 0 - -#ifdef MPP_LAND - !bcast namelist variable. - call mpp_land_bcast_int1(rt_option) - call mpp_land_bcast_int1(CHANRTSWCRT) - call mpp_land_bcast_int1(channel_option) - call mpp_land_bcast_int1(SUBRTSWCRT) - call mpp_land_bcast_int1(OVRTSWCRT) - call mpp_land_bcast_int1(AGGFACTRT) - call mpp_land_bcast_real1(DTRT) - call mpp_land_bcast_real1(DXRT) - call mpp_land_bcast_int1(GWBASESWCRT) - call mpp_land_bcast_int1(GW_RESTART) - call mpp_land_bcast_int1(RSTRT_SWC ) - call mpp_land_bcast_int1(TERADJ_SOLAR) - call mpp_land_bcast_int1(sys_cpl) - call mpp_land_bcast_int1(rst_typ) - call mpp_land_bcast_int1(order_to_write) -#endif - nlst%RT_OPTION = RT_OPTION - nlst%CHANRTSWCRT = CHANRTSWCRT - nlst%GW_RESTART = GW_RESTART - nlst%RSTRT_SWC = RSTRT_SWC - nlst%channel_option = channel_option - nlst%DTRT = DTRT - nlst%DTCT = DTRT - nlst%SUBRTSWCRT = SUBRTSWCRT - nlst%OVRTSWCRT = OVRTSWCRT - nlst%dxrt0 = dxrt - nlst%AGGFACTRT = AGGFACTRT - nlst%GWBASESWCRT = GWBASESWCRT - nlst%TERADJ_SOLAR = TERADJ_SOLAR - nlst%sys_cpl = sys_cpl - nlst%rst_typ = rst_typ - nlst%order_to_write = order_to_write -! files - nlst%route_topo_f = route_topo_f - nlst%route_chan_f = route_chan_f - nlst%route_link_f = route_link_f - nlst%route_lake_f =route_lake_f - nlst%route_direction_f = route_direction_f - nlst%route_order_f = route_order_f - nlst%gwbasmskfil = gwbasmskfil - nlst%gwstrmfil = gwstrmfil - nlst%geo_finegrid_flnm = geo_finegrid_flnm - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif -#ifdef HYDRO_D - write(6,*) "output of the namelist file " - - write(6,*) " nlst%RT_OPTION ", RT_OPTION - write(6,*) " nlst%CHANRTSWCRT ", CHANRTSWCRT - write(6,*) " nlst%GW_RESTART ", GW_RESTART - write(6,*) " nlst%RSTRT_SWC ", RSTRT_SWC - write(6,*) " nlst%channel_option ", channel_option - write(6,*) " nlst%DTRT ", DTRT - write(6,*) " nlst%SUBRTSWCRT ", SUBRTSWCRT - write(6,*) " nlst%OVRTSWCRT ", OVRTSWCRT - write(6,*) " nlst%dxrt0 ", dxrt - write(6,*) " nlst%AGGFACTRT ", AGGFACTRT - write(6,*) " nlst%GWBASESWCRT ", GWBASESWCRT - write(6,*) " nlst%TERADJ_SOLAR ", TERADJ_SOLAR - write(6,*) " nlst%sys_cpl ", sys_cpl - write(6,*) " nlst%rst_typ ", rst_typ - write(6,*) " nlst%order_to_write ", order_to_write - write(6,*) " nlst%route_topo_f ", route_topo_f - write(6,*) " nlst%route_chan_f ", route_chan_f - write(6,*) " nlst%route_link_f ", route_link_f - write(6,*) " nlst%route_lake_f ",route_lake_f - write(6,*) " nlst%route_direction_f ", route_direction_f - write(6,*) " nlst%route_order_f ", route_order_f - write(6,*) " nlst%gwbasmskfil ", gwbasmskfil - write(6,*) " nlst%gwstrmfil ", gwstrmfil - write(6,*) " nlst%geo_finegrid_flnm ", geo_finegrid_flnm -#endif -#ifdef MPP_LAND - endif -#endif - -#ifdef MPP_LAND - !bcast other variable. - call mpp_land_bcast_real1(nlst%dt) -#endif - return - end subroutine read_rt_nlst - - -end module module_namelist diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/namelist.inc.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/namelist.inc.svn-base deleted file mode 100644 index 79a5ab7d..00000000 --- a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/namelist.inc.svn-base +++ /dev/null @@ -1,39 +0,0 @@ - TYPE namelist_rt_field - - integer :: nsoil, SOLVEG_INITSWC - real,allocatable,dimension(:) :: ZSOIL8 - real out_dt, rst_dt, dt - integer :: START_YEAR, START_MONTH, START_DAY, START_HOUR, START_MIN - character(len=256) :: restart_file = "" - logical :: history_output - integer :: split_output_count - integer :: igrid - character(len=256) :: geo_static_flnm = "" - integer :: DEEPGWSPIN - integer :: HIRES_OUT, order_to_write, rst_typ - -! additional character - character :: hgrid - character(len=19) :: olddate="123456" - character(len=19) :: startdate="123456" - character(len=19) :: sincedate="123456" - - - - integer:: RT_OPTION, CHANRTSWCRT, channel_option, & - SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, & - GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & - sys_cpl - real:: DTRT,dxrt0, DTCT - character(len=256) :: route_topo_f="" - character(len=256) :: route_chan_f="" - character(len=256) :: route_link_f="" - character(len=256) :: route_lake_f="" - character(len=256) :: route_direction_f="" - character(len=256) :: route_order_f="" - character(len=256) :: gwbasmskfil ="" - character(len=256) :: gwstrmfil ="" - character(len=256) :: geo_finegrid_flnm ="" - - END TYPE namelist_rt_field - diff --git a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/rt_include.inc.svn-base b/wrfv2_fire/hydro/Data_Rec/.svn/text-base/rt_include.inc.svn-base deleted file mode 100644 index 1557bc00..00000000 --- a/wrfv2_fire/hydro/Data_Rec/.svn/text-base/rt_include.inc.svn-base +++ /dev/null @@ -1,178 +0,0 @@ - TYPE RT_FIELD - INTEGER :: IX, JX - logical initialized - REAL :: DX,GRDAREART,SUBFLORT,WATAVAILRT,QSUBDRYRT - REAL :: SFHEAD1RT,INFXS1RT,QSTRMVOLTRT,QBDRYTRT,SFHEADRT,ETPND1,INFXSRTOT - REAL :: LAKE_INFLOTRT,accsuminfxs,diffsuminfxs,RETDEPFRAC - REAL :: VERTKSAT,l3temp,l4temp,l3moist,l4moist,RNOF1TOT,RNOF2TOT,RNOF3TOT - INTEGER :: IXRT,JXRT,vegct - INTEGER :: AGGFACYRT, AGGFACXRT, KRTel_option, FORC_TYP - INTEGER :: SATLYRCHKRT,DT_FRACRT - INTEGER :: LAKE_CT, STRM_CT - REAL :: RETDEP_CHAN ! Channel retention depth - INTEGER :: NLINKS !maximum number of unique links in channel - INTEGER :: GNLINKS !maximum number of unique links in channel for parallel computation - INTEGER :: NLAKES !number of lakes - INTEGER :: MAXORDER !maximum stream order - integer :: timestep_flag ! 1 cold start run else continue run - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!DJG VARIABLES FOR ROUTING - INTEGER, allocatable, DIMENSION(:,:) :: CH_NETRT !-- keeps track of the 0-1 channel network - INTEGER, allocatable, DIMENSION(:,:) :: CH_NETLNK, GCH_NETLNK !-- assigns a unique value to each channel gridpoint, called links - REAL, allocatable, DIMENSION(:,:) :: LATVAL,LONVAL !-- lat lon - REAL, allocatable, DIMENSION(:,:) :: TERRAIN - REAL, allocatable, DIMENSION(:) :: CHLAT,CHLON ! channel lat and lon - ! INTEGER, allocatable, DIMENSION(:,:) :: LAKE_MSKRT, BASIN_MSK,LAK_1K - INTEGER, allocatable, DIMENSION(:,:) :: LAKE_MSKRT, LAK_1K - INTEGER, allocatable, DIMENSION(:,:) :: g_LAK_1K - ! REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT, QSUBBDRYTRT - REAL :: QSUBBDRYTRT - REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT - REAL, allocatable, DIMENSION(:,:,:) :: SO8RT - INTEGER, allocatable, DIMENSION(:,:,:) :: SO8RT_D, SO8LD_D - REAL, allocatable, DIMENSION(:,:) :: SO8LD_Vmax - REAL Vmax - REAL, allocatable, DIMENSION(:,:) :: SFCHEADRT,INFXSRT,LKSAT,LKSATRT - REAL, allocatable, DIMENSION(:,:) :: SFCHEADSUBRT,INFXSUBRT,LKSATFAC - REAL, allocatable, DIMENSION(:,:) :: QSUBRT,ZWATTABLRT,QSUBBDRYRT,SOLDEPRT - REAL, allocatable, DIMENSION(:,:) :: SUB_RESID - REAL, allocatable, DIMENSION(:,:) :: q_sfcflx_x,q_sfcflx_y - INTEGER, allocatable, DIMENSION(:) :: map_l2g, map_g2l - -! temp arrary cwatavail - real, allocatable, DIMENSION(:,:,:) :: SMCREFRT -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!DJG VARIABLES FOR GW/Baseflow - INTEGER :: numbasns - INTEGER, allocatable, DIMENSION(:,:) :: GWSUBBASMSK !GW basin mask grid - REAL, allocatable, DIMENSION(:,:) :: qinflowbase !strm inflow/baseflow from GW - REAL, allocatable, DIMENSION(:,:) :: SOLDRAIN !time-step drainage - INTEGER, allocatable, DIMENSION(:,:) :: gw_strm_msk !GW basin mask grid - REAL, allocatable, DIMENSION(:) :: z_gwsubbas !depth in GW bucket - REAL, allocatable, DIMENSION(:) :: qin_gwsubbas !flow to GW bucket - REAL, allocatable, DIMENSION(:) :: qout_gwsubbas!flow from GW bucket - REAL, allocatable, DIMENSION(:) :: gwbas_pix_ct !ct of strm pixels in - REAL, allocatable, DIMENSION(:) :: basns_area !basin area - REAL, allocatable, DIMENSION(:) :: node_area !nodes area - - REAL, allocatable, DIMENSION(:) :: z_q_bas_parm !GW bucket disch params - INTEGER, allocatable, DIMENSION(:) :: ct2_bas !ct of lnd pixels in basn - REAL, allocatable, DIMENSION(:) :: bas_pcp !sub-basin avg'd pcp - INTEGER :: bas,bas_id - CHARACTER(len=19) :: header - CHARACTER(len=1) :: jnk - REAL, allocatable, DIMENSION(:) :: gw_buck_coeff,gw_buck_exp,z_max !GW bucket parameters -!DJG Switch for Deep Sat GW Init: - INTEGER :: DEEPGWSPIN !Switch to setup deep GW spinp - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!DJG,DNY VARIABLES FOR CHANNEL ROUTING -!-- channel params - INTEGER, allocatable, DIMENSION(:) :: LINK !channel link - INTEGER, allocatable, DIMENSION(:) :: TO_NODE !link's to node - INTEGER, allocatable, DIMENSION(:) :: FROM_NODE !link's from node - INTEGER, allocatable, DIMENSION(:) :: ORDER !link's order - INTEGER, allocatable, DIMENSION(:) :: STRMFRXSTPTS !frxst point flag - INTEGER, allocatable, DIMENSION(:) :: TYPEL !type of link Muskingum: 0 strm 1 lake - !-- Diffusion: 0 edge or pour; 1 interior; 2 lake - INTEGER, allocatable, DIMENSION(:) :: TYPEN !type of link 0 strm 1 lake - REAL, allocatable, DIMENSION(:) :: QLAKEI !lake inflow in difussion scheme - REAL, allocatable, DIMENSION(:) :: QLAKEO !lake outflow in difussion scheme - INTEGER, allocatable, DIMENSION(:) :: LAKENODE !which nodes flow into which lakes - REAL, allocatable, DIMENSION(:) :: CVOL ! channel volume - INTEGER, allocatable, DIMENSION(:,:) :: pnode !parent nodes : start from 2 - integer :: maxv_p ! array size for second column of the pnode - - - REAL, allocatable, DIMENSION(:) :: MUSK, MUSX !muskingum params - REAL, allocatable, DIMENSION(:) :: CHANLEN !link length - REAL, allocatable, DIMENSION(:) :: MannN !mannings N - REAL, allocatable, DIMENSION(:) :: So !link slope - REAL, allocatable, DIMENSION(:) :: ChSSlp, Bw !trapezoid link params - REAL, allocatable, DIMENSION(:,:) :: QLINK !flow in link - REAL, allocatable, DIMENSION(:) :: HLINK !head in link - REAL, allocatable, DIMENSION(:) :: ZELEV !elevation of nodes for channel - INTEGER, allocatable, DIMENSION(:) :: CHANXI,CHANYJ !map chan to fine grid - REAL, DIMENSION(50) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann !Channel parms from table - - REAL, allocatable, DIMENSION(:) :: RESHT !reservoir height -!-- lake params - REAL, allocatable, DIMENSION(:) :: HRZAREA !horizontal extent of lake, km^2 - REAL, allocatable, DIMENSION(:) :: WEIRL !overtop weir length (m) - REAL, allocatable, DIMENSION(:) :: ORIFICEC !coefficient of orifice - REAL, allocatable, DIMENSION(:) :: ORIFICEA !orifice opening area (m^2) - REAL, allocatable, DIMENSION(:) :: ORIFICEE !orifice elevation (m) - REAL, allocatable, DIMENSION(:) :: LATLAKE, LONLAKE,ELEVLAKE ! lake info -#ifdef MPP_LAND - INTEGER, allocatable, DIMENSION(:) :: lake_index,nlinks_index - INTEGER, allocatable, DIMENSION(:,:) :: Link_location - integer mpp_nlinks, yw_mpp_nlinks -#endif - - REAL, allocatable, DIMENSION(:,:) :: OVROUGHRTFAC,RETDEPRTFAC - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!DJG VARIABLES FOR AGGREGATION/DISAGGREGATION - REAL, allocatable, DIMENSION(:,:,:) :: SMCRT,SMCMAXRT,SMCWLTRT,SH2OWGT,SICE - REAL, allocatable, DIMENSION(:,:) :: INFXSAGGRT - REAL, allocatable, DIMENSION(:,:) :: DHRT,QSTRMVOLRT,QBDRYRT,LAKE_INFLORT - REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_TS,LAKE_INFLORT_TS - REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_DUM,LAKE_INFLORT_DUM - REAL, allocatable, DIMENSION(:,:) :: INFXSWGT, ywtmp - REAL, allocatable, DIMENSION(:) :: SMCAGGRT,STCAGGRT,SH2OAGGRT - REAL :: INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT - REAL, allocatable, DIMENSION(:,:,:) :: dist ! 8 direction of distance -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!DJG VARIABLES FOR ONLINE MASS BALANCE CALCULATION - REAL(KIND=8) :: DCMC,DSWE,DACRAIN,DSFCEVP,DCANEVP,DEDIR,DETT,DEPND,DESNO,DSFCRNFF - REAL(KIND=8) :: DSMCTOT,RESID,SUMEVP,DUG1RNFF,DUG2RNFF,SMCTOT1,SMCTOT2,DETP - REAL(KIND=8) :: suminfxsrt,suminfxs1,suminfxs2,dprcp_ts - REAL(KIND=8) :: CHAN_IN1,CHAN_IN2,LAKE_IN1,LAKE_IN2,zzz, CHAN_STOR,CHAN_OUT - REAL(KIND=8) :: CHAN_INV,LAKE_INV !-channel and lake inflow in volume - REAL(KIND=8) :: DQBDRY - REAL :: QSTRMVOLTRT1,LAKE_INFLOTRT1,QBDRYTOT1,LSMVOL - REAL(KIND=8), allocatable, DIMENSION(:) :: DSMC,SMCRTCHK - REAL(KIND=8), allocatable, DIMENSION(:,:) :: CMC_INIT,SWE_INIT -! REAL(KIND=8), allocatable, DIMENSION(:,:,:) :: SMC_INIT - REAL(KIND=8) :: SMC_INIT,SMC_FINAL,resid2,resid1 - REAL(KIND=8) :: chcksm1,chcksm2,CMC1,CMC2,prcp_in,ETATOT,dsmctot_av - - integer :: g_ixrt,g_jxrt,flag - integer :: allo_status = -99 - integer iywtmp - - -!-- lake params - REAL, allocatable, DIMENSION(:) :: LAKEMAXH !maximum depth (m) - REAL, allocatable, DIMENSION(:) :: WEIRC !coeff of overtop weir - - - - -!DJG Modified namelist for routing and agg. variables - real Z_tmp - - !!! define land surface grid variables - REAL, allocatable, DIMENSION(:,:,:) :: SMC,STC,SH2OX - REAL, allocatable, DIMENSION(:,:) :: SMCMAX1,SMCWLT1,SMCREF1 - INTEGER, allocatable, DIMENSION(:,:) :: VEGTYP - REAL, allocatable, DIMENSION(:) :: SLDPTH - -!!! define constant/parameter - real :: ov_rough(50), ZSOIL(100) -! out_counts: couput counts for current run. -! his_out_counts: used for channel routing output and special for restart. -! his_out_counts = previous run + out_counts - integer :: out_counts, rst_counts, his_out_counts - - REAL, allocatable, DIMENSION(:,:) :: lat_lsm, lon_lsm - REAL, allocatable, DIMENSION(:,:,:) :: dist_lsm - - END TYPE RT_FIELD diff --git a/wrfv2_fire/hydro/Data_Rec/Makefile b/wrfv2_fire/hydro/Data_Rec/Makefile deleted file mode 100644 index 398ba2fe..00000000 --- a/wrfv2_fire/hydro/Data_Rec/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -# Makefile -# -.SUFFIXES: -.SUFFIXES: .o .F - -include ../macros - -OBJS = \ - module_namelist.o \ - module_RT_data.o \ - module_GW_baseflow_data.o - -all: $(OBJS) - -.F.o: - @echo "" - $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f - $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I../mod $(*).f - $(RMD) $(*).f - @echo "" - ar -r ../lib/libHYDRO.a $(@) - cp *.mod ../mod - -# Dependencies: -# - -clean: - rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc b/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc deleted file mode 100644 index 99c79886..00000000 --- a/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc +++ /dev/null @@ -1,26 +0,0 @@ - - type gw_field - integer :: ix, jx - integer :: allo_status = -99 - - real :: dx, dt - - integer, allocatable, dimension(:,:) :: ltype ! land-sfc type - real, allocatable, dimension(:,:) :: & - elev, & ! elev/bathymetry of sfc rel to sl (m) - bot, & ! elev. aquifer bottom rel to sl (m) - hycond, & ! hydraulic conductivity (m/s per m/m) - poros, & ! porosity (m3/m3) - compres, & ! compressibility (1/Pa) - ho ! head at start of timestep (m) - - real, allocatable, dimension(:,:) :: & - h, & ! head, after ghmcompute (m) - convgw ! convergence due to gw flow (m/s) - - real :: ebot, eocn - integer ::istep = 0 - - - end type gw_field - diff --git a/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F b/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F deleted file mode 100644 index 4b171683..00000000 --- a/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F +++ /dev/null @@ -1,9 +0,0 @@ -Module module_GW_baseflow_data - IMPLICIT NONE - INTEGER, PARAMETER :: max_domain=5 - -#include "gw_field_include.inc" - type (gw_field) :: gw2d(max_domain) - save gw2d - -end module module_GW_baseflow_data diff --git a/wrfv2_fire/hydro/Data_Rec/module_RT_data.F b/wrfv2_fire/hydro/Data_Rec/module_RT_data.F deleted file mode 100644 index 2fd80414..00000000 --- a/wrfv2_fire/hydro/Data_Rec/module_RT_data.F +++ /dev/null @@ -1,10 +0,0 @@ -Module module_RT_data - IMPLICIT NONE - INTEGER, PARAMETER :: max_domain=5 - -! define Routing data -#include "rt_include.inc" - TYPE ( RT_FIELD ), DIMENSION (max_domain) :: RT_DOMAIN - save RT_DOMAIN - integer :: cur_did -end module module_RT_data diff --git a/wrfv2_fire/hydro/Data_Rec/module_namelist.F b/wrfv2_fire/hydro/Data_Rec/module_namelist.F deleted file mode 100644 index 936b7ba6..00000000 --- a/wrfv2_fire/hydro/Data_Rec/module_namelist.F +++ /dev/null @@ -1,203 +0,0 @@ -Module module_namelist - -#ifdef MPP_LAND - USE module_mpp_land -#endif - - IMPLICIT NONE - INTEGER, PARAMETER :: max_domain=5 - -#include "namelist.inc" - TYPE(namelist_rt_field) , dimension(max_domain) :: nlst_rt - save nlst_rt - -CONTAINS - - subroutine read_rt_nlst(nlst) - implicit none - - TYPE(namelist_rt_field) nlst - - integer ierr - integer:: RT_OPTION, CHANRTSWCRT, channel_option, & - SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, & - GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & - sys_cpl, rst_typ - real:: DTRT,dxrt - character(len=256) :: route_topo_f="" - character(len=256) :: route_chan_f="" - character(len=256) :: route_link_f="" - character(len=256) :: route_lake_f="" - character(len=256) :: route_direction_f="" - character(len=256) :: route_order_f="" - character(len=256) :: gwbasmskfil ="" - character(len=256) :: gwstrmfil ="" - character(len=256) :: geo_finegrid_flnm ="" - integer :: SOLVEG_INITSWC - real out_dt, rst_dt - character(len=256) :: RESTART_FILE = "" - logical :: history_output - integer :: split_output_count, order_to_write - integer :: igrid - character(len=256) :: geo_static_flnm = "" - integer :: DEEPGWSPIN - - integer :: HIRES_OUT - integer :: i - -!!! add the following two dummy variables - integer :: NSOIL - real :: ZSOIL8(8) - - namelist /HYDRO_nlist/ NSOIL, ZSOIL8,& - RESTART_FILE,HISTORY_OUTPUT,SPLIT_OUTPUT_COUNT,IGRID,& - geo_static_flnm, & - out_dt, rst_dt, & - HIRES_OUT, & - DEEPGWSPIN, SOLVEG_INITSWC, & - RT_OPTION, CHANRTSWCRT, channel_option, & - SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, dtrt,dxrt,& - GWBASESWCRT,route_topo_f,route_chan_f,route_link_f,route_lake_f, & - route_direction_f,route_order_f,gwbasmskfil, geo_finegrid_flnm,& - gwstrmfil,GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, sys_cpl, & - order_to_write , rst_typ -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - open(30, file="hydro.namelist", form="FORMATTED") - read(30, HYDRO_nlist, iostat=ierr) - close(30) -#ifdef MPP_LAND - endif -#endif - - -#ifdef MPP_LAND -! call mpp_land_bcast_real1(DT) - call mpp_land_bcast_int1(SPLIT_OUTPUT_COUNT) - call mpp_land_bcast_int1(IGRID) - call mpp_land_bcast_real1(out_dt) - call mpp_land_bcast_real1(rst_dt) - call mpp_land_bcast_int1(HIRES_OUT) - call mpp_land_bcast_int1(DEEPGWSPIN) - call mpp_land_bcast_int1(SOLVEG_INITSWC) -#endif - - -#ifdef MPP_LAND - call mpp_land_bcast_int1(nlst%NSOIL) - do i = 1, nlst%NSOIL - call mpp_land_bcast_real1(nlst%ZSOIL8(i)) - end do -#ifdef HYDRO_D - write(6,*) "nlst%NSOIL = ", nlst%NSOIL - write(6,*) "nlst%ZSOIL8 = ",nlst%ZSOIL8 -#endif -#endif - -! nlst%DT = DT - nlst%RESTART_FILE = RESTART_FILE - nlst%HISTORY_OUTPUT = HISTORY_OUTPUT - nlst%SPLIT_OUTPUT_COUNT = SPLIT_OUTPUT_COUNT - nlst%IGRID = IGRID - nlst%geo_static_flnm = geo_static_flnm - nlst%out_dt = out_dt - nlst%rst_dt = rst_dt - nlst%HIRES_OUT = HIRES_OUT - nlst%DEEPGWSPIN = DEEPGWSPIN - nlst%SOLVEG_INITSWC = SOLVEG_INITSWC - - write(nlst%hgrid,'(I1)') igrid - - - if(RESTART_FILE .eq. "") rst_typ = 0 - -#ifdef MPP_LAND - !bcast namelist variable. - call mpp_land_bcast_int1(rt_option) - call mpp_land_bcast_int1(CHANRTSWCRT) - call mpp_land_bcast_int1(channel_option) - call mpp_land_bcast_int1(SUBRTSWCRT) - call mpp_land_bcast_int1(OVRTSWCRT) - call mpp_land_bcast_int1(AGGFACTRT) - call mpp_land_bcast_real1(DTRT) - call mpp_land_bcast_real1(DXRT) - call mpp_land_bcast_int1(GWBASESWCRT) - call mpp_land_bcast_int1(GW_RESTART) - call mpp_land_bcast_int1(RSTRT_SWC ) - call mpp_land_bcast_int1(TERADJ_SOLAR) - call mpp_land_bcast_int1(sys_cpl) - call mpp_land_bcast_int1(rst_typ) - call mpp_land_bcast_int1(order_to_write) -#endif - nlst%RT_OPTION = RT_OPTION - nlst%CHANRTSWCRT = CHANRTSWCRT - nlst%GW_RESTART = GW_RESTART - nlst%RSTRT_SWC = RSTRT_SWC - nlst%channel_option = channel_option - nlst%DTRT = DTRT - nlst%DTCT = DTRT - nlst%SUBRTSWCRT = SUBRTSWCRT - nlst%OVRTSWCRT = OVRTSWCRT - nlst%dxrt0 = dxrt - nlst%AGGFACTRT = AGGFACTRT - nlst%GWBASESWCRT = GWBASESWCRT - nlst%TERADJ_SOLAR = TERADJ_SOLAR - nlst%sys_cpl = sys_cpl - nlst%rst_typ = rst_typ - nlst%order_to_write = order_to_write -! files - nlst%route_topo_f = route_topo_f - nlst%route_chan_f = route_chan_f - nlst%route_link_f = route_link_f - nlst%route_lake_f =route_lake_f - nlst%route_direction_f = route_direction_f - nlst%route_order_f = route_order_f - nlst%gwbasmskfil = gwbasmskfil - nlst%gwstrmfil = gwstrmfil - nlst%geo_finegrid_flnm = geo_finegrid_flnm - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif -#ifdef HYDRO_D - write(6,*) "output of the namelist file " - - write(6,*) " nlst%RT_OPTION ", RT_OPTION - write(6,*) " nlst%CHANRTSWCRT ", CHANRTSWCRT - write(6,*) " nlst%GW_RESTART ", GW_RESTART - write(6,*) " nlst%RSTRT_SWC ", RSTRT_SWC - write(6,*) " nlst%channel_option ", channel_option - write(6,*) " nlst%DTRT ", DTRT - write(6,*) " nlst%SUBRTSWCRT ", SUBRTSWCRT - write(6,*) " nlst%OVRTSWCRT ", OVRTSWCRT - write(6,*) " nlst%dxrt0 ", dxrt - write(6,*) " nlst%AGGFACTRT ", AGGFACTRT - write(6,*) " nlst%GWBASESWCRT ", GWBASESWCRT - write(6,*) " nlst%TERADJ_SOLAR ", TERADJ_SOLAR - write(6,*) " nlst%sys_cpl ", sys_cpl - write(6,*) " nlst%rst_typ ", rst_typ - write(6,*) " nlst%order_to_write ", order_to_write - write(6,*) " nlst%route_topo_f ", route_topo_f - write(6,*) " nlst%route_chan_f ", route_chan_f - write(6,*) " nlst%route_link_f ", route_link_f - write(6,*) " nlst%route_lake_f ",route_lake_f - write(6,*) " nlst%route_direction_f ", route_direction_f - write(6,*) " nlst%route_order_f ", route_order_f - write(6,*) " nlst%gwbasmskfil ", gwbasmskfil - write(6,*) " nlst%gwstrmfil ", gwstrmfil - write(6,*) " nlst%geo_finegrid_flnm ", geo_finegrid_flnm -#endif -#ifdef MPP_LAND - endif -#endif - -#ifdef MPP_LAND - !bcast other variable. - call mpp_land_bcast_real1(nlst%dt) -#endif - return - end subroutine read_rt_nlst - - -end module module_namelist diff --git a/wrfv2_fire/hydro/Data_Rec/namelist.inc b/wrfv2_fire/hydro/Data_Rec/namelist.inc deleted file mode 100644 index 79a5ab7d..00000000 --- a/wrfv2_fire/hydro/Data_Rec/namelist.inc +++ /dev/null @@ -1,39 +0,0 @@ - TYPE namelist_rt_field - - integer :: nsoil, SOLVEG_INITSWC - real,allocatable,dimension(:) :: ZSOIL8 - real out_dt, rst_dt, dt - integer :: START_YEAR, START_MONTH, START_DAY, START_HOUR, START_MIN - character(len=256) :: restart_file = "" - logical :: history_output - integer :: split_output_count - integer :: igrid - character(len=256) :: geo_static_flnm = "" - integer :: DEEPGWSPIN - integer :: HIRES_OUT, order_to_write, rst_typ - -! additional character - character :: hgrid - character(len=19) :: olddate="123456" - character(len=19) :: startdate="123456" - character(len=19) :: sincedate="123456" - - - - integer:: RT_OPTION, CHANRTSWCRT, channel_option, & - SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, & - GWBASESWCRT, GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, & - sys_cpl - real:: DTRT,dxrt0, DTCT - character(len=256) :: route_topo_f="" - character(len=256) :: route_chan_f="" - character(len=256) :: route_link_f="" - character(len=256) :: route_lake_f="" - character(len=256) :: route_direction_f="" - character(len=256) :: route_order_f="" - character(len=256) :: gwbasmskfil ="" - character(len=256) :: gwstrmfil ="" - character(len=256) :: geo_finegrid_flnm ="" - - END TYPE namelist_rt_field - diff --git a/wrfv2_fire/hydro/Data_Rec/rt_include.inc b/wrfv2_fire/hydro/Data_Rec/rt_include.inc deleted file mode 100644 index 1557bc00..00000000 --- a/wrfv2_fire/hydro/Data_Rec/rt_include.inc +++ /dev/null @@ -1,178 +0,0 @@ - TYPE RT_FIELD - INTEGER :: IX, JX - logical initialized - REAL :: DX,GRDAREART,SUBFLORT,WATAVAILRT,QSUBDRYRT - REAL :: SFHEAD1RT,INFXS1RT,QSTRMVOLTRT,QBDRYTRT,SFHEADRT,ETPND1,INFXSRTOT - REAL :: LAKE_INFLOTRT,accsuminfxs,diffsuminfxs,RETDEPFRAC - REAL :: VERTKSAT,l3temp,l4temp,l3moist,l4moist,RNOF1TOT,RNOF2TOT,RNOF3TOT - INTEGER :: IXRT,JXRT,vegct - INTEGER :: AGGFACYRT, AGGFACXRT, KRTel_option, FORC_TYP - INTEGER :: SATLYRCHKRT,DT_FRACRT - INTEGER :: LAKE_CT, STRM_CT - REAL :: RETDEP_CHAN ! Channel retention depth - INTEGER :: NLINKS !maximum number of unique links in channel - INTEGER :: GNLINKS !maximum number of unique links in channel for parallel computation - INTEGER :: NLAKES !number of lakes - INTEGER :: MAXORDER !maximum stream order - integer :: timestep_flag ! 1 cold start run else continue run - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!DJG VARIABLES FOR ROUTING - INTEGER, allocatable, DIMENSION(:,:) :: CH_NETRT !-- keeps track of the 0-1 channel network - INTEGER, allocatable, DIMENSION(:,:) :: CH_NETLNK, GCH_NETLNK !-- assigns a unique value to each channel gridpoint, called links - REAL, allocatable, DIMENSION(:,:) :: LATVAL,LONVAL !-- lat lon - REAL, allocatable, DIMENSION(:,:) :: TERRAIN - REAL, allocatable, DIMENSION(:) :: CHLAT,CHLON ! channel lat and lon - ! INTEGER, allocatable, DIMENSION(:,:) :: LAKE_MSKRT, BASIN_MSK,LAK_1K - INTEGER, allocatable, DIMENSION(:,:) :: LAKE_MSKRT, LAK_1K - INTEGER, allocatable, DIMENSION(:,:) :: g_LAK_1K - ! REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT, QSUBBDRYTRT - REAL :: QSUBBDRYTRT - REAL, allocatable, DIMENSION(:,:) :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT - REAL, allocatable, DIMENSION(:,:,:) :: SO8RT - INTEGER, allocatable, DIMENSION(:,:,:) :: SO8RT_D, SO8LD_D - REAL, allocatable, DIMENSION(:,:) :: SO8LD_Vmax - REAL Vmax - REAL, allocatable, DIMENSION(:,:) :: SFCHEADRT,INFXSRT,LKSAT,LKSATRT - REAL, allocatable, DIMENSION(:,:) :: SFCHEADSUBRT,INFXSUBRT,LKSATFAC - REAL, allocatable, DIMENSION(:,:) :: QSUBRT,ZWATTABLRT,QSUBBDRYRT,SOLDEPRT - REAL, allocatable, DIMENSION(:,:) :: SUB_RESID - REAL, allocatable, DIMENSION(:,:) :: q_sfcflx_x,q_sfcflx_y - INTEGER, allocatable, DIMENSION(:) :: map_l2g, map_g2l - -! temp arrary cwatavail - real, allocatable, DIMENSION(:,:,:) :: SMCREFRT -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!DJG VARIABLES FOR GW/Baseflow - INTEGER :: numbasns - INTEGER, allocatable, DIMENSION(:,:) :: GWSUBBASMSK !GW basin mask grid - REAL, allocatable, DIMENSION(:,:) :: qinflowbase !strm inflow/baseflow from GW - REAL, allocatable, DIMENSION(:,:) :: SOLDRAIN !time-step drainage - INTEGER, allocatable, DIMENSION(:,:) :: gw_strm_msk !GW basin mask grid - REAL, allocatable, DIMENSION(:) :: z_gwsubbas !depth in GW bucket - REAL, allocatable, DIMENSION(:) :: qin_gwsubbas !flow to GW bucket - REAL, allocatable, DIMENSION(:) :: qout_gwsubbas!flow from GW bucket - REAL, allocatable, DIMENSION(:) :: gwbas_pix_ct !ct of strm pixels in - REAL, allocatable, DIMENSION(:) :: basns_area !basin area - REAL, allocatable, DIMENSION(:) :: node_area !nodes area - - REAL, allocatable, DIMENSION(:) :: z_q_bas_parm !GW bucket disch params - INTEGER, allocatable, DIMENSION(:) :: ct2_bas !ct of lnd pixels in basn - REAL, allocatable, DIMENSION(:) :: bas_pcp !sub-basin avg'd pcp - INTEGER :: bas,bas_id - CHARACTER(len=19) :: header - CHARACTER(len=1) :: jnk - REAL, allocatable, DIMENSION(:) :: gw_buck_coeff,gw_buck_exp,z_max !GW bucket parameters -!DJG Switch for Deep Sat GW Init: - INTEGER :: DEEPGWSPIN !Switch to setup deep GW spinp - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!DJG,DNY VARIABLES FOR CHANNEL ROUTING -!-- channel params - INTEGER, allocatable, DIMENSION(:) :: LINK !channel link - INTEGER, allocatable, DIMENSION(:) :: TO_NODE !link's to node - INTEGER, allocatable, DIMENSION(:) :: FROM_NODE !link's from node - INTEGER, allocatable, DIMENSION(:) :: ORDER !link's order - INTEGER, allocatable, DIMENSION(:) :: STRMFRXSTPTS !frxst point flag - INTEGER, allocatable, DIMENSION(:) :: TYPEL !type of link Muskingum: 0 strm 1 lake - !-- Diffusion: 0 edge or pour; 1 interior; 2 lake - INTEGER, allocatable, DIMENSION(:) :: TYPEN !type of link 0 strm 1 lake - REAL, allocatable, DIMENSION(:) :: QLAKEI !lake inflow in difussion scheme - REAL, allocatable, DIMENSION(:) :: QLAKEO !lake outflow in difussion scheme - INTEGER, allocatable, DIMENSION(:) :: LAKENODE !which nodes flow into which lakes - REAL, allocatable, DIMENSION(:) :: CVOL ! channel volume - INTEGER, allocatable, DIMENSION(:,:) :: pnode !parent nodes : start from 2 - integer :: maxv_p ! array size for second column of the pnode - - - REAL, allocatable, DIMENSION(:) :: MUSK, MUSX !muskingum params - REAL, allocatable, DIMENSION(:) :: CHANLEN !link length - REAL, allocatable, DIMENSION(:) :: MannN !mannings N - REAL, allocatable, DIMENSION(:) :: So !link slope - REAL, allocatable, DIMENSION(:) :: ChSSlp, Bw !trapezoid link params - REAL, allocatable, DIMENSION(:,:) :: QLINK !flow in link - REAL, allocatable, DIMENSION(:) :: HLINK !head in link - REAL, allocatable, DIMENSION(:) :: ZELEV !elevation of nodes for channel - INTEGER, allocatable, DIMENSION(:) :: CHANXI,CHANYJ !map chan to fine grid - REAL, DIMENSION(50) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann !Channel parms from table - - REAL, allocatable, DIMENSION(:) :: RESHT !reservoir height -!-- lake params - REAL, allocatable, DIMENSION(:) :: HRZAREA !horizontal extent of lake, km^2 - REAL, allocatable, DIMENSION(:) :: WEIRL !overtop weir length (m) - REAL, allocatable, DIMENSION(:) :: ORIFICEC !coefficient of orifice - REAL, allocatable, DIMENSION(:) :: ORIFICEA !orifice opening area (m^2) - REAL, allocatable, DIMENSION(:) :: ORIFICEE !orifice elevation (m) - REAL, allocatable, DIMENSION(:) :: LATLAKE, LONLAKE,ELEVLAKE ! lake info -#ifdef MPP_LAND - INTEGER, allocatable, DIMENSION(:) :: lake_index,nlinks_index - INTEGER, allocatable, DIMENSION(:,:) :: Link_location - integer mpp_nlinks, yw_mpp_nlinks -#endif - - REAL, allocatable, DIMENSION(:,:) :: OVROUGHRTFAC,RETDEPRTFAC - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!DJG VARIABLES FOR AGGREGATION/DISAGGREGATION - REAL, allocatable, DIMENSION(:,:,:) :: SMCRT,SMCMAXRT,SMCWLTRT,SH2OWGT,SICE - REAL, allocatable, DIMENSION(:,:) :: INFXSAGGRT - REAL, allocatable, DIMENSION(:,:) :: DHRT,QSTRMVOLRT,QBDRYRT,LAKE_INFLORT - REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_TS,LAKE_INFLORT_TS - REAL, allocatable, DIMENSION(:,:) :: QSTRMVOLRT_DUM,LAKE_INFLORT_DUM - REAL, allocatable, DIMENSION(:,:) :: INFXSWGT, ywtmp - REAL, allocatable, DIMENSION(:) :: SMCAGGRT,STCAGGRT,SH2OAGGRT - REAL :: INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT - REAL, allocatable, DIMENSION(:,:,:) :: dist ! 8 direction of distance -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!DJG VARIABLES FOR ONLINE MASS BALANCE CALCULATION - REAL(KIND=8) :: DCMC,DSWE,DACRAIN,DSFCEVP,DCANEVP,DEDIR,DETT,DEPND,DESNO,DSFCRNFF - REAL(KIND=8) :: DSMCTOT,RESID,SUMEVP,DUG1RNFF,DUG2RNFF,SMCTOT1,SMCTOT2,DETP - REAL(KIND=8) :: suminfxsrt,suminfxs1,suminfxs2,dprcp_ts - REAL(KIND=8) :: CHAN_IN1,CHAN_IN2,LAKE_IN1,LAKE_IN2,zzz, CHAN_STOR,CHAN_OUT - REAL(KIND=8) :: CHAN_INV,LAKE_INV !-channel and lake inflow in volume - REAL(KIND=8) :: DQBDRY - REAL :: QSTRMVOLTRT1,LAKE_INFLOTRT1,QBDRYTOT1,LSMVOL - REAL(KIND=8), allocatable, DIMENSION(:) :: DSMC,SMCRTCHK - REAL(KIND=8), allocatable, DIMENSION(:,:) :: CMC_INIT,SWE_INIT -! REAL(KIND=8), allocatable, DIMENSION(:,:,:) :: SMC_INIT - REAL(KIND=8) :: SMC_INIT,SMC_FINAL,resid2,resid1 - REAL(KIND=8) :: chcksm1,chcksm2,CMC1,CMC2,prcp_in,ETATOT,dsmctot_av - - integer :: g_ixrt,g_jxrt,flag - integer :: allo_status = -99 - integer iywtmp - - -!-- lake params - REAL, allocatable, DIMENSION(:) :: LAKEMAXH !maximum depth (m) - REAL, allocatable, DIMENSION(:) :: WEIRC !coeff of overtop weir - - - - -!DJG Modified namelist for routing and agg. variables - real Z_tmp - - !!! define land surface grid variables - REAL, allocatable, DIMENSION(:,:,:) :: SMC,STC,SH2OX - REAL, allocatable, DIMENSION(:,:) :: SMCMAX1,SMCWLT1,SMCREF1 - INTEGER, allocatable, DIMENSION(:,:) :: VEGTYP - REAL, allocatable, DIMENSION(:) :: SLDPTH - -!!! define constant/parameter - real :: ov_rough(50), ZSOIL(100) -! out_counts: couput counts for current run. -! his_out_counts: used for channel routing output and special for restart. -! his_out_counts = previous run + out_counts - integer :: out_counts, rst_counts, his_out_counts - - REAL, allocatable, DIMENSION(:,:) :: lat_lsm, lon_lsm - REAL, allocatable, DIMENSION(:,:,:) :: dist_lsm - - END TYPE RT_FIELD diff --git a/wrfv2_fire/hydro/HYDRO_drv/.svn/all-wcprops b/wrfv2_fire/hydro/HYDRO_drv/.svn/all-wcprops deleted file mode 100644 index c5438960..00000000 --- a/wrfv2_fire/hydro/HYDRO_drv/.svn/all-wcprops +++ /dev/null @@ -1,17 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 62 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/HYDRO_drv -END -module_HYDRO_drv.F -K 25 -svn:wc:ra_dav:version-url -V 81 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/HYDRO_drv/module_HYDRO_drv.F -END -Makefile -K 25 -svn:wc:ra_dav:version-url -V 71 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/HYDRO_drv/Makefile -END diff --git a/wrfv2_fire/hydro/HYDRO_drv/.svn/entries b/wrfv2_fire/hydro/HYDRO_drv/.svn/entries deleted file mode 100644 index 560b987c..00000000 --- a/wrfv2_fire/hydro/HYDRO_drv/.svn/entries +++ /dev/null @@ -1,96 +0,0 @@ -10 - -dir -9105 -https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/HYDRO_drv -https://kkeene@svn-wrf-model.cgd.ucar.edu - - - -2015-01-23T18:49:15.035273Z -8003 -gill - - - - - - - - - - - - - - -b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d - -module_HYDRO_drv.F -file - - - - -2016-02-11T20:37:50.184698Z -71edf2c3486d61b615893a754d5d2bf1 -2015-01-23T18:49:15.035273Z -8003 -gill - - - - - - - - - - - - - - - - - - - - - -34924 - -Makefile -file - - - - -2016-02-11T20:37:50.186021Z -d3bd1628a3ed59ae7049226ed358da85 -2012-12-07T20:01:45.900797Z -6094 -gill - - - - - - - - - - - - - - - - - - - - - -609 - diff --git a/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/Makefile.svn-base b/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/Makefile.svn-base deleted file mode 100644 index 9a04d9e6..00000000 --- a/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/Makefile.svn-base +++ /dev/null @@ -1,28 +0,0 @@ -# Makefile -# -.SUFFIXES: -.SUFFIXES: .o .F - -include ../macros - -OBJS = \ - module_HYDRO_drv.o -all: $(OBJS) - -.F.o: - @echo "" - $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f - $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I../mod $(*).f - $(RMD) $(*).f - @echo "" - ar -r ../lib/libHYDRO.a $(@) - cp *.mod ../mod - -# -# Dependencies: -# -module_HYDRO_drv.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o ../Data_Rec/module_GW_baseflow_data.o \ - ../Routing/module_GW_baseflow.o ../Routing/module_HYDRO_utils.o ../Routing/module_HYDRO_io.o ../Routing/module_RT.o - -clean: - rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/module_HYDRO_drv.F.svn-base b/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/module_HYDRO_drv.F.svn-base deleted file mode 100644 index cc0de91f..00000000 --- a/wrfv2_fire/hydro/HYDRO_drv/.svn/text-base/module_HYDRO_drv.F.svn-base +++ /dev/null @@ -1,1071 +0,0 @@ -module module_HYDRO_drv -#ifdef MPP_LAND - use module_HYDRO_io, only: mpp_output_rt, mpp_output_chrt, mpp_output_lakes, mpp_output_chrtgrd - USE module_mpp_land -#else - use module_HYDRO_io, only: output_rt, output_chrt, output_lakes -#endif - use module_HYDRO_io, only: output_gw, restart_out_nc, restart_in_nc, & - get_file_dimension ,get2d_lsm_real, get2d_lsm_vegtyp, get2d_lsm_soltyp, & - output_lsm - use module_rt_data, only: rt_domain - use module_GW_baseflow_data, only: gw2d - use module_GW_baseflow, only:simp_gw_buck, gwstep, gw2d_allocate, gw2d_ini - use module_channel_routing, only: drive_channel - use module_namelist, only: nlst_rt, read_rt_nlst - use module_routing, only: getChanDim, landrt_ini - use module_HYDRO_utils -! use module_namelist - use module_lsm_forcing, only: geth_newdate - - implicit none - - contains - subroutine HYDRO_rst_out(did) - implicit none - integer:: rst_out - integer did, outflag - character(len=19) out_date - rst_out = -99 -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - if(nlst_rt(did)%dt .gt. nlst_rt(did)%rst_dt*60) then - call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%rst_counts)) - else - call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%rst_dt*60*rt_domain(did)%rst_counts)) - endif - if ( (nlst_rt(did)%rst_dt .gt. 0) .and. (out_date(1:19) == nlst_rt(did)%olddate(1:19)) ) then - rst_out = 99 - rt_domain(did)%rst_counts = rt_domain(did)%rst_counts + 1 - endif -! restart every month automatically. - if ( (nlst_rt(did)%olddate(9:10) == "01") .and. (nlst_rt(did)%olddate(12:13) == "00") .and. & - (nlst_rt(did)%olddate(15:16) == "00").and. (nlst_rt(did)%olddate(18:19) == "00") .and. & - (nlst_rt(did)%rst_dt .le. 0) ) rst_out = 99 - -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(rst_out) -#endif - if(rst_out .gt. 0) & - call RESTART_OUT_nc(trim("HYDRO_RST."//nlst_rt(did)%olddate(1:16) & - //"_DOMAIN"//trim(nlst_rt(did)%hgrid)), did) - -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif -#ifdef HYDRO_D - write(6,*) "restartFile =", "RESTART."//nlst_rt(did)%olddate(1:16) & - //"_DOMAIN"//trim(nlst_rt(did)%hgrid) -#endif -#ifdef MPP_LAND - endif -#endif - - - end subroutine HYDRO_rst_out - - subroutine HYDRO_out(did) - implicit none - integer did, outflag, rtflag - character(len=19) out_date - integer :: Kt, ounit - -! real, dimension(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx):: soilmx_tmp, & -! runoff1x_tmp, runoff2x_tmp, runoff3x_tmp,etax_tmp, & -! EDIRX_tmp,ECX_tmp,ETTX_tmp,RCX_tmp,HX_tmp,acrain_tmp, & -! ACSNOM_tmp, esnow2d_tmp, drip2d_tmp,dewfall_tmp, fpar_tmp, & -! qfx_tmp, prcp_out_tmp, etpndx_tmp - - outflag = -99 - -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - if(nlst_rt(did)%olddate(1:19) .eq. nlst_rt(did)%startdate(1:19) .and. rt_domain(did)%his_out_counts .eq. 0) then -#ifdef HYDRO_D - write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19), rt_domain(did)%his_out_counts -#endif - outflag = 99 - else - if(nlst_rt(did)%dt .gt. nlst_rt(did)%out_dt*60) then - call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%out_counts)) - else - call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%out_dt*60*rt_domain(did)%out_counts)) - endif - if ( out_date(1:19) == nlst_rt(did)%olddate(1:19) ) then -#ifdef HYDRO_D - write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19) -#endif - outflag = 99 - endif - endif -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(outflag) -#endif - - call HYDRO_rst_out(did) - - if (outflag .lt. 0) return - - rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1 - rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1 - - if(nlst_rt(did)%out_dt*60 .gt. nlst_rt(did)%DT) then - kt = rt_domain(did)%his_out_counts*nlst_rt(did)%out_dt*60/nlst_rt(did)%DT - else - kt = rt_domain(did)%his_out_counts - endif - - -! jump the ouput for the initial time when it has restart file from routing. - rtflag = -99 -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - if ( (trim(nlst_rt(did)%restart_file) /= "") .and. ( nlst_rt(did)%startdate(1:19) == nlst_rt(did)%olddate(1:19) ) ) then - print*, "yyyywww restart_file = ", trim(nlst_rt(did)%restart_file) - rtflag = 1 - endif -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(rtflag) -#endif - - -!yw keep the initial time otuput for debug - if(rtflag == 1) return ! jump the initial time output for routing restart - - - - call output_lsm(trim(nlst_rt(did)%olddate(1:4)//nlst_rt(did)%olddate(6:7)//nlst_rt(did)%olddate(9:10) & - //nlst_rt(did)%olddate(12:13)//nlst_rt(did)%olddate(15:16)// & - ".LSMOUT_DOMAIN"//trim(nlst_rt(did)%hgrid)), & - did) - - - - if(nlst_rt(did)%SUBRTSWCRT .gt. 0 & - .or. nlst_rt(did)%OVRTSWCRT .gt. 0 & - .or. nlst_rt(did)%GWBASESWCRT .gt. 0 ) then - if (nlst_rt(did)%HIRES_OUT.ge.1) then - - -! goto 9991 - -#ifdef MPP_LAND - call mpp_output_rt(rt_domain(did)%g_ixrt, rt_domain(did)%g_jxrt, & -#else - call output_rt( & -#endif - nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & - RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & - nlst_rt(did)%nsoil, & -! nlst_rt(did)%startdate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,& - nlst_rt(did)%sincedate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,& - RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SMCRT,& - RT_DOMAIN(did)%SUB_RESID, & - RT_DOMAIN(did)%q_sfcflx_x,RT_DOMAIN(did)%q_sfcflx_y,& - RT_DOMAIN(did)%soxrt,RT_DOMAIN(did)%soyrt,& - RT_DOMAIN(did)%QSTRMVOLRT,RT_DOMAIN(did)%SFCHEADSUBRT, & - nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT,& - RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL,& - RT_DOMAIN(did)%LONVAL,RT_DOMAIN(did)%dist,nlst_rt(did)%HIRES_OUT,& - RT_DOMAIN(did)%QBDRYRT ) - -! 9991 continue - - end if - - - if(nlst_rt(did)%GWBASESWCRT .eq. 3) then - - call output_gw( & - nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & - RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & - nlst_rt(did)%nsoil, & -! nlst_rt(did)%startdate, nlst_rt(did)%olddate, & - nlst_rt(did)%sincedate, nlst_rt(did)%olddate, & - gw2d(did)%h, RT_DOMAIN(did)%SMCRT, & - gw2d(did)%convgw, RT_DOMAIN(did)%SFCHEADSUBRT, & - nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT, & - RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL, & - RT_DOMAIN(did)%LONVAL,rt_domain(did)%dist, & - nlst_rt(did)%HIRES_OUT) - - endif -! BF end gw2d output section - -#ifdef HYDRO_D - write(6,*) "before call output_chrt" -#endif - - if (nlst_rt(did)%CHANRTSWCRT.eq.1.or.nlst_rt(did)%CHANRTSWCRT.eq.2) then - -#ifdef MPP_LAND - call mpp_output_chrt(rt_domain(did)%gnlinks,rt_domain(did)%map_l2g, & -#else - call output_chrt( & -#endif - nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & - RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, & -! nlst_rt(did)%startdate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& - nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& - RT_DOMAIN(did)%CHLAT, & - RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & - RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & - RT_DOMAIN(did)%STRMFRXSTPTS,nlst_rt(did)%order_to_write) - -#ifdef MPP_LAND -! call mpp_output_chrtgrd(nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & -! RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt, RT_DOMAIN(did)%NLINKS, & -! RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%ORDER, & -! nlst_rt(did)%startdate, nlst_rt(did)%olddate, & -! RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm, & -! RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & -! RT_DOMAIN(did)%g_ixrt,RT_DOMAIN(did)%g_jxrt ) -#endif - - if (RT_DOMAIN(did)%NLAKES.gt.0) & -#ifdef MPP_LAND - call mpp_output_lakes( RT_DOMAIN(did)%lake_index, & -#else - call output_lakes( & -#endif - nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & - RT_DOMAIN(did)%NLAKES, & -! trim(nlst_rt(did)%startdate), trim(nlst_rt(did)%olddate), & - trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), & - RT_DOMAIN(did)%LATLAKE,RT_DOMAIN(did)%LONLAKE, & - RT_DOMAIN(did)%ELEVLAKE,RT_DOMAIN(did)%QLAKEI, & - RT_DOMAIN(did)%QLAKEO, & - RT_DOMAIN(did)%RESHT,nlst_rt(did)%DT,Kt) - endif -#ifdef HYDRO_D - write(6,*) "end calling output functions" -#endif - - endif ! end of routing switch - - - end subroutine HYDRO_out - - - subroutine HYDRO_rst_in(did) - integer :: did - integer:: flag - - - - flag = -1 -#ifdef MPP_LAND - if(my_id.eq.IO_id) then -#endif - if (trim(nlst_rt(did)%restart_file) /= "") then - flag = 99 - rt_domain(did)%timestep_flag = 99 ! continue run - endif -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(flag) -#endif - - nlst_rt(did)%sincedate = nlst_rt(did)%startdate - - if (flag.eq.99) then - -#ifdef MPP_LAND - if(my_id.eq.IO_id) then -#endif -#ifdef HYDRO_D - write(6,*) "*** read restart data: ",trim(nlst_rt(did)%restart_file) -#endif -#ifdef MPP_LAND - endif -#endif - call RESTART_IN_nc(trim(nlst_rt(did)%restart_file), did) - -!yw if (trim(nlst_rt(did)%restart_file) /= "") then -!yw nlst_rt(did)%restart_file = "" -!yw endif - - endif - end subroutine HYDRO_rst_in - - subroutine HYDRO_time_adv(did) - implicit none - character(len = 19) :: newdate - integer did - -#ifdef MPP_LAND - if(IO_id.eq.my_id) then -#endif - call geth_newdate(newdate, nlst_rt(did)%olddate, nint( nlst_rt(did)%dt)) - nlst_rt(did)%olddate = newdate -#ifdef HYDRO_D - write(6,*) "current time is ",newdate -#endif -#ifdef MPP_LAND - endif -#endif - end subroutine HYDRO_time_adv - - subroutine HYDRO_exe(did) - - - implicit none - integer:: did - integer:: rst_out - - - call HYDRO_out(did) - - -! running land surface model -! cpl: 0--offline run; -! 1-- coupling with WRF but running offline lsm; -! 2-- coupling with WRF but do not run offline lsm -! 3-- coupling with LIS and do not run offline lsm -! 4: coupling with CLM -! if(nlst_rt(did)%SYS_CPL .eq. 0 .or. nlst_rt(did)%SYS_CPL .eq. 1 )then -! call drive_noahLSF(did,kt) -! else -! ! does not run the NOAH LASF model, only read the parameter -! call read_land_par(did,lsm(did)%ix,lsm(did)%jx) -! endif - - - - - - if (nlst_rt(did)%GWBASESWCRT .ne. 0 & - .or. nlst_rt(did)%SUBRTSWCRT .NE.0 & - .or. nlst_rt(did)%OVRTSWCRT .NE. 0 ) THEN - - - RT_DOMAIN(did)%QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT - RT_DOMAIN(did)%LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT - - - - ! step 1) disaggregate specific fields from LSM to Hydro grid - call disaggregateDomain_drv(did) - - ! step 2) - call SubsurfaceRouting_drv(did) - - ! step 3) todo split - call OverlandRouting_drv(did) - - RT_DOMAIN(did)%QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-RT_DOMAIN(did)%QSTRMVOLRT_DUM - RT_DOMAIN(did)%LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-RT_DOMAIN(did)%LAKE_INFLORT_DUM - - - ! step 4) baseflow or groundwater physics - call driveGwBaseflow(did) - - ! step 5) river channel physics - call driveChannelRouting(did) - - ! step 6) aggregate specific fields from Hydro to LSM grid - call aggregateDomain(did) - - - end if - - - ! advance to next time step - call HYDRO_time_adv(did) - - ! output for history - call HYDRO_out(did) - - -! write(90 + my_id,*) "finish calling hydro_exe" -! flush(90+my_id) -! call mpp_land_sync() - - - - RT_DOMAIN(did)%SOLDRAIN = 0 - RT_DOMAIN(did)%QSUBRT = 0 - - - - end subroutine HYDRO_exe - - - -!---------------------------------------------------- - subroutine driveGwBaseflow(did) - - implicit none - integer, intent(in) :: did - - integer :: i - -!------------------------------------------------------------------ -!DJG Begin GW/Baseflow Routines -!------------------------------------------------------------------- - - IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN ! Switch to activate/specify GW/Baseflow - -! IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow - - If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then ! Call simple bucket baseflow scheme - -#ifdef HYDRO_D - write(6,*) "*****yw******start simp_gw_buck " -#endif - - call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& - RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%basns_area,& - RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & - RT_DOMAIN(did)%SOLDRAIN, & - RT_DOMAIN(did)%z_gwsubbas,& - RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& - RT_DOMAIN(did)%qinflowbase,& - RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & - RT_DOMAIN(did)%dist,nlst_rt(did)%DT,& - RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & - RT_DOMAIN(did)%z_max,& - nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT) - - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - - open (unit=51,file='GW_inflow.txt',form='formatted',& - status='unknown',position='append') - open (unit=52,file='GW_outflow.txt',form='formatted',& - status='unknown',position='append') - open (unit=53,file='GW_zlev.txt',form='formatted',& - status='unknown',position='append') - do i=1,RT_DOMAIN(did)%numbasns - write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i) -951 FORMAT(I3,1X,A19,1X,F11.3) - write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i) - write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i) - end do - close(51) - close(52) - close(53) -#ifdef MPP_LAND - endif -#endif - -#ifdef HYDRO_D - write(6,*) "*****yw******end simp_gw_buck " -#endif - -!!!For parameter setup runs output the percolation for each basin, -!!!otherwise comment out this output... - else if (nlst_rt(did)%GWBASESWCRT .eq. 3) then - -#ifdef HYDRO_D - write(6,*) "*****bf******start 2d_gw_model " -#endif - - call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & - gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & - gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & - gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & - gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & - gw2d(did)%istep) - - -! bftodo head postprocessing block -! GW-SOIL-CHANNEL interaction section - gw2d(did)%ho = gw2d(did)%h - -#ifdef HYDRO_D - write(6,*) "*****bf******end 2d_gw_model " -#endif - - End if - - END IF !DJG (End if for RTE SWC activation) -!------------------------------------------------------------------ -!DJG End GW/Baseflow Routines -!------------------------------------------------------------------- - - - end subroutine driveGwBaseflow - - - - -!------------------------------------------- - subroutine driveChannelRouting(did) - - implicit none - integer, intent(in) :: did - -!------------------------------------------------------------------- -!------------------------------------------------------------------- -!DJG,DNY Begin Channel and Lake Routing Routines -!------------------------------------------------------------------- - IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN - - call drive_CHANNEL(RT_DOMAIN(did)%latval,RT_DOMAIN(did)%lonval, & - RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & - nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, & - RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS,& - RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& - RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& - RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT, & - RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTCT,nlst_rt(did)%DTRT,& - RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & - RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& - RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & - RT_DOMAIN(did)%Bw,& - RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,& - RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, & - RT_DOMAIN(did)%ORIFICEA, & - RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & - RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& - RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, & - RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & - RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, & - RT_DOMAIN(did)%RETDEP_CHAN & - , RT_DOMAIN(did)%node_area & -#ifdef MPP_LAND - ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& - RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & - RT_DOMAIN(did)%yw_mpp_nlinks & -#endif - ) - endif - -#ifdef HYDRO_D - write(6,*) "*****yw******end drive_CHANNEL " -#endif - - end subroutine driveChannelRouting - - - -!------------------------------------------------ - subroutine aggregateDomain(did) - - implicit none - integer, intent(in) :: did - - integer :: i, j, krt, ixxrt, jyyrt, & - AGGFACYRT, AGGFACXRT -#ifdef HYDRO_D - print *, "Beginning Aggregation..." -#endif - - - do J=1,RT_DOMAIN(did)%JX - do I=1,RT_DOMAIN(did)%IX - - RT_DOMAIN(did)%SFCHEADAGGRT = 0. -!DJG Subgrid weighting edit... - RT_DOMAIN(did)%LSMVOL=0. - do KRT=1,nlst_rt(did)%NSOIL -! SMCAGGRT(KRT) = 0. - RT_DOMAIN(did)%SH2OAGGRT(KRT) = 0. - end do - - - do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1 - do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1 - - - IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT - JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT -#ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 -#else -!yw ???? -! IXXRT=IXXRT+1 -! JYYRT=JYYRT+1 -#endif - -!State Variables - RT_DOMAIN(did)%SFCHEADAGGRT = RT_DOMAIN(did)%SFCHEADAGGRT & - + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) -!DJG Subgrid weighting edit... - RT_DOMAIN(did)%LSMVOL = RT_DOMAIN(did)%LSMVOL & - + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) & - * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9) - - do KRT=1,nlst_rt(did)%NSOIL -!DJG SMCAGGRT(KRT)=SMCAGGRT(KRT)+SMCRT(IXXRT,JYYRT,KRT) - RT_DOMAIN(did)%SH2OAGGRT(KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & - + RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) - end do - - end do - end do - - - - RT_DOMAIN(did)%SFCHEADRT(I,J) = RT_DOMAIN(did)%SFCHEADAGGRT & - / (nlst_rt(did)%AGGFACTRT**2) - - do KRT=1,nlst_rt(did)%NSOIL -!DJG SMC(I,J,KRT)=SMCAGGRT(KRT)/(AGGFACTRT**2) - RT_DOMAIN(did)%SH2OX(I,J,KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & - / (nlst_rt(did)%AGGFACTRT**2) - end do - - - -!DJG Calculate subgrid weighting array... - - do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1 - do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1 - IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT - JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT -#ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 -#else -!yw ??? -! IXXRT=IXXRT+1 -! JYYRT=JYYRT+1 -#endif - if (RT_DOMAIN(did)%LSMVOL.gt.0.) then - RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & - = RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) & - * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9) & - / RT_DOMAIN(did)%LSMVOL - else - RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & - = 1./FLOAT(nlst_rt(did)%AGGFACTRT**2) - end if - - do KRT=1,nlst_rt(did)%NSOIL - -!!!yw added for debug - if(RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .lt. 0) then - print*, "Error negative SMCRT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) - endif - if(RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) .lt. 0) then - print *, "Error negative SH2OWGT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) - endif - -!end - IF (RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .GT. & - RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT)) THEN -#ifdef HYDRO_D - print *, "SMCMAX exceeded upon aggregation...", & - RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT), & - RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT) - call hydro_stop("aggregateDomain") -#endif - END IF - IF(RT_DOMAIN(did)%SH2OX(I,J,KRT).LE.0.) THEN -#ifdef HYDRO_D - print *, "Erroneous value of SH2O...", & - RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT - print *, "Error negative SH2OX", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) - call hydro_stop("aggregateDomain") -#endif - END IF - RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) & - = RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) & - / RT_DOMAIN(did)%SH2OX(I,J,KRT) -!?yw - RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = max(1.0E-30, RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT)) - end do - - end do - end do - - end do - end do - - -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(RT_DOMAIN(did)%INFXSWGT, & - RT_DOMAIN(did)%IXRT, & - RT_DOMAIN(did)%JXRT, 99) - - do i = 1, nlst_rt(did)%NSOIL - call MPP_LAND_COM_REAL(RT_DOMAIN(did)%SH2OWGT(:,:,i), & - RT_DOMAIN(did)%IXRT, & - RT_DOMAIN(did)%JXRT, 99) - end do -#endif - -!DJG Update SMC with SICE (unchanged) and new value of SH2O from routing... - RT_DOMAIN(did)%SMC = RT_DOMAIN(did)%SH2OX + RT_DOMAIN(did)%SICE -#ifdef HYDRO_D - print *, "Finished Aggregation..." -#endif - - - end subroutine aggregateDomain - - - - subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) - implicit none - integer ntime, did - integer rst_out, ix,jx -! integer, OPTIONAL:: ix0,jx0 - integer:: ix0,jx0 - integer, dimension(ix0,jx0),OPTIONAL :: vegtyp, soltyp - - - -#ifdef MPP_LAND - call MPP_LAND_INIT() -#endif - - -! read the namelist -! the lsm namelist will be read by rtland sequentially again. - call read_rt_nlst(nlst_rt(did) ) - - - IF (nlst_rt(did)%GWBASESWCRT .eq. 0 & - .and. nlst_rt(did)%SUBRTSWCRT .eq.0 & - .and. nlst_rt(did)%OVRTSWCRT .eq. 0 ) return - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! get the dimension - call get_file_dimension(trim(nlst_rt(did)%geo_static_flnm), ix,jx) - - -#ifdef MPP_LAND - - if (nlst_rt(did)%sys_cpl .eq. 1 .or. nlst_rt(did)%sys_cpl .eq. 4) then -!sys_cpl: 1-- coupling with HRLDAS but running offline lsm; -! 2-- coupling with WRF but do not run offline lsm -! 3-- coupling with LIS and do not run offline lsm -! 4: coupling with CLM - -! create 2 dimensiaon logical mapping of the CPUs for coupling with CLM or HRLDAS. - call log_map2d() - - global_nx = ix ! get from land model - global_ny = jx ! get from land model - - call mpp_land_bcast_int1(global_nx) - call mpp_land_bcast_int1(global_ny) - -!!! temp set global_nx to ix - rt_domain(did)%ix = global_nx - rt_domain(did)%jx = global_ny - -! over write the ix and jx - call MPP_LAND_PAR_INI(1,rt_domain(did)%ix,rt_domain(did)%jx,& - nlst_rt(did)%AGGFACTRT) - else -! coupled with WRF, LIS - numprocs = node_info(1,1) - - call wrf_LAND_set_INIT(node_info,numprocs,nlst_rt(did)%AGGFACTRT) - - - rt_domain(did)%ix = local_nx - rt_domain(did)%jx = local_ny - endif - - - - rt_domain(did)%g_IXRT=global_rt_nx - rt_domain(did)%g_JXRT=global_rt_ny - rt_domain(did)%ixrt = local_rt_nx - rt_domain(did)%jxrt = local_rt_ny - -#ifdef HYDRO_D - write(6,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" - write(6,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt - write(6,*) "rt_domain(did)%ix, rt_domain(did)%jx " - write(6,*) rt_domain(did)%ix, rt_domain(did)%jx - write(6,*) "global_nx, global_ny, local_nx, local_ny" - write(6,*) global_nx, global_ny, local_nx, local_ny -#endif -#else -! sequential - rt_domain(did)%ix = ix - rt_domain(did)%jx = jx - rt_domain(did)%ixrt = ix*nlst_rt(did)%AGGFACTRT - rt_domain(did)%jxrt = jx*nlst_rt(did)%AGGFACTRT -#endif - - -! allocate rt arrays - - - call getChanDim(did) - - -#ifdef HYDRO_D - write(6,*) "finish getChanDim " -#endif - - if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then - call gw2d_allocate(did,& - rt_domain(did)%ixrt,& - rt_domain(did)%jxrt,& - nlst_rt(did)%nsoil) -#ifdef HYDRO_D - write(6,*) "finish gw2d_allocate" -#endif - endif - -! calculate the distance between grids for routing. -! decompose the land parameter/data - - -! ix0= rt_domain(did)%ix -! jx0= rt_domain(did)%jx - if(present(vegtyp)) then - call lsm_input(did,ix0=ix0,jx0=jx0,vegtyp0=vegtyp,soltyp0=soltyp) - else - call lsm_input(did,ix0=ix0,jx0=jx0) - endif - - -#ifdef HYDRO_D - write(6,*) "finish decomposion" -#endif - - - call get_dist_lsm(did) - call get_dist_lrt(did) - - -! rt model initilization - call LandRT_ini(did) - -#ifdef HYDRO_D - write(6,*) "finish LandRT_ini" -#endif - - - if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then - - call gw2d_ini(did,& - nlst_rt(did)%dt,& - nlst_rt(did)%dxrt0) -#ifdef HYDRO_D - write(6,*) "finish gw2d_ini" -#endif - endif -#ifdef HYDRO_D - write(6,*) "finish LandRT_ini" -#endif - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - IF (nlst_rt(did)%TERADJ_SOLAR.EQ.1 .and. nlst_rt(did)%CHANRTSWCRT.NE.2) THEN ! Perform ter rain adjustment of incoming solar -#ifdef MPP_LAND - call MPP_seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& - rt_domain(did)%TERRAIN, rt_domain(did)%dist_lsm,& - rt_domain(did)%ix,rt_domain(did)%jx,global_nx,global_ny) -#else - call seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& - rt_domain(did)%TERRAIN,rt_domain(did)%dist_lsm,& - rt_domain(did)%ix,rt_domain(did)%jx) -#endif - endif - - - IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2 .or. nlst_rt(did)%GWBASESWCRT .gt. 0) then - call get_basn_area(did) - endif - - IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2 ) then -! call get_basn_area(did) - call get_node_area(did) - endif - - -! if (trim(nlst_rt(did)%restart_file) == "") then -! output at the initial time -! call HYDRO_out(did) -! return -! endif - -! restart the file - - ! jummp the initial time output -! rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1 -! rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1 - - call HYDRO_rst_in(did) - - -! call HYDRO_out(did) - - - end subroutine HYDRO_ini - - subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) - implicit none - integer did, leng - parameter(leng=100) - integer :: i,j, nn - integer, allocatable, dimension(:,:) :: soltyp - real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc - - integer :: ix0,jx0 - integer, dimension(ix0,jx0),OPTIONAL :: vegtyp0, soltyp0 - -#ifdef HYDRO_D - write(6,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx -#endif - - allocate(soltyp(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) ) - - soltyp = 0 - call get2d_lsm_soltyp(soltyp,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) - - - call get2d_lsm_real("HGT",RT_DOMAIN(did)%TERRAIN,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) - - call get2d_lsm_real("XLAT",RT_DOMAIN(did)%lat_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) - call get2d_lsm_real("XLONG",RT_DOMAIN(did)%lon_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) - call get2d_lsm_vegtyp(RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) - - - - if(nlst_rt(did)%sys_cpl .eq. 2 ) then - ! coupling with WRF - if(present(soltyp0) ) then - where(soltyp0 == 14) VEGTYP0 = 16 - where(VEGTYP0 == 16 ) soltyp0 = 14 - soltyp = soltyp0 - RT_DOMAIN(did)%VEGTYP = VEGTYP0 - endif - endif - - where(soltyp == 14) RT_DOMAIN(did)%VEGTYP = 16 - where(RT_DOMAIN(did)%VEGTYP == 16 ) soltyp = 14 - -! LKSAT, -! temporary set - RT_DOMAIN(did)%SMCRTCHK = 0 - RT_DOMAIN(did)%SMCAGGRT = 0 - RT_DOMAIN(did)%STCAGGRT = 0 - RT_DOMAIN(did)%SH2OAGGRT = 0 - - - RT_DOMAIN(did)%zsoil(1:nlst_rt(did)%nsoil) = nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) - - RT_DOMAIN(did)%sldpth(1) = abs( RT_DOMAIN(did)%zsoil(1) ) - do i = 2, nlst_rt(did)%nsoil - RT_DOMAIN(did)%sldpth(i) = RT_DOMAIN(did)%zsoil(i-1)-RT_DOMAIN(did)%zsoil(i) - enddo - RT_DOMAIN(did)%SOLDEPRT = -1.0*RT_DOMAIN(did)%ZSOIL(nlst_rt(did)%NSOIL) - -! input OV_ROUGH from OVROUGH.TBL -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - - open(71,file="HYDRO.TBL", form="formatted") -!read OV_ROUGH first - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) - end do -!read parameter for LKSAT - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) - end do - close(71) - -#ifdef MPP_LAND - endif - call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) - call mpp_land_bcast_real(leng,xdum1) - call mpp_land_bcast_real(leng,MAXSMC) - call mpp_land_bcast_real(leng,refsmc) - call mpp_land_bcast_real(leng,wltsmc) -#endif - - rt_domain(did)%lksat = 0.0 - do j = 1, RT_DOMAIN(did)%jx - do i = 1, RT_DOMAIN(did)%ix - !yw rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 - rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) - IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN ! urban - rt_domain(did)%SMCMAX1(i,j) = 0.45 - rt_domain(did)%SMCREF1(i,j) = 0.42 - rt_domain(did)%SMCWLT1(i,j) = 0.40 - else - rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) - rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) - rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) - ENDIF - end do - end do - - deallocate(soltyp) - - - end subroutine lsm_input - - -end module module_HYDRO_drv - -! stop the job due to the fatal error. - subroutine HYDRO_stop(msg) -#ifdef MPP_LAND - use module_mpp_land -#endif - character(len=*) :: msg - integer :: ierr -#ifdef HYDRO_D - write(6,*) "The job is stoped due to the fatal error. ", trim(msg) - flush(6) -#endif -#ifdef MPP_LAND -#ifndef HYDRO_D - print*, "---" - print*, "ERROR! Program stopped. Recompile with environment variable HYDRO_D set to 1 for enhanced debug information." - print*, "" -#endif - -! call mpp_land_sync() -! write(my_id+90,*) msg -! flush(my_id+90) - - call mpp_land_abort() - call MPI_finalize(ierr) -#else - stop "Fatal Error" -#endif - - return - end subroutine HYDRO_stop - - -! stop the job due to the fatal error. - subroutine HYDRO_finish() -#ifdef MPP_LAND - USE module_mpp_land -#endif - integer :: ierr - - print*, "The model finished successfully......." -#ifdef MPP_LAND -! call mpp_land_abort() - flush(6) - call mpp_land_sync() - call MPI_finalize(ierr) - stop -#else - stop -#endif - - return - end subroutine HYDRO_finish diff --git a/wrfv2_fire/hydro/HYDRO_drv/Makefile b/wrfv2_fire/hydro/HYDRO_drv/Makefile deleted file mode 100644 index 9a04d9e6..00000000 --- a/wrfv2_fire/hydro/HYDRO_drv/Makefile +++ /dev/null @@ -1,28 +0,0 @@ -# Makefile -# -.SUFFIXES: -.SUFFIXES: .o .F - -include ../macros - -OBJS = \ - module_HYDRO_drv.o -all: $(OBJS) - -.F.o: - @echo "" - $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f - $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I../mod $(*).f - $(RMD) $(*).f - @echo "" - ar -r ../lib/libHYDRO.a $(@) - cp *.mod ../mod - -# -# Dependencies: -# -module_HYDRO_drv.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o ../Data_Rec/module_GW_baseflow_data.o \ - ../Routing/module_GW_baseflow.o ../Routing/module_HYDRO_utils.o ../Routing/module_HYDRO_io.o ../Routing/module_RT.o - -clean: - rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F b/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F deleted file mode 100644 index cc0de91f..00000000 --- a/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F +++ /dev/null @@ -1,1071 +0,0 @@ -module module_HYDRO_drv -#ifdef MPP_LAND - use module_HYDRO_io, only: mpp_output_rt, mpp_output_chrt, mpp_output_lakes, mpp_output_chrtgrd - USE module_mpp_land -#else - use module_HYDRO_io, only: output_rt, output_chrt, output_lakes -#endif - use module_HYDRO_io, only: output_gw, restart_out_nc, restart_in_nc, & - get_file_dimension ,get2d_lsm_real, get2d_lsm_vegtyp, get2d_lsm_soltyp, & - output_lsm - use module_rt_data, only: rt_domain - use module_GW_baseflow_data, only: gw2d - use module_GW_baseflow, only:simp_gw_buck, gwstep, gw2d_allocate, gw2d_ini - use module_channel_routing, only: drive_channel - use module_namelist, only: nlst_rt, read_rt_nlst - use module_routing, only: getChanDim, landrt_ini - use module_HYDRO_utils -! use module_namelist - use module_lsm_forcing, only: geth_newdate - - implicit none - - contains - subroutine HYDRO_rst_out(did) - implicit none - integer:: rst_out - integer did, outflag - character(len=19) out_date - rst_out = -99 -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - if(nlst_rt(did)%dt .gt. nlst_rt(did)%rst_dt*60) then - call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%rst_counts)) - else - call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%rst_dt*60*rt_domain(did)%rst_counts)) - endif - if ( (nlst_rt(did)%rst_dt .gt. 0) .and. (out_date(1:19) == nlst_rt(did)%olddate(1:19)) ) then - rst_out = 99 - rt_domain(did)%rst_counts = rt_domain(did)%rst_counts + 1 - endif -! restart every month automatically. - if ( (nlst_rt(did)%olddate(9:10) == "01") .and. (nlst_rt(did)%olddate(12:13) == "00") .and. & - (nlst_rt(did)%olddate(15:16) == "00").and. (nlst_rt(did)%olddate(18:19) == "00") .and. & - (nlst_rt(did)%rst_dt .le. 0) ) rst_out = 99 - -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(rst_out) -#endif - if(rst_out .gt. 0) & - call RESTART_OUT_nc(trim("HYDRO_RST."//nlst_rt(did)%olddate(1:16) & - //"_DOMAIN"//trim(nlst_rt(did)%hgrid)), did) - -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif -#ifdef HYDRO_D - write(6,*) "restartFile =", "RESTART."//nlst_rt(did)%olddate(1:16) & - //"_DOMAIN"//trim(nlst_rt(did)%hgrid) -#endif -#ifdef MPP_LAND - endif -#endif - - - end subroutine HYDRO_rst_out - - subroutine HYDRO_out(did) - implicit none - integer did, outflag, rtflag - character(len=19) out_date - integer :: Kt, ounit - -! real, dimension(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx):: soilmx_tmp, & -! runoff1x_tmp, runoff2x_tmp, runoff3x_tmp,etax_tmp, & -! EDIRX_tmp,ECX_tmp,ETTX_tmp,RCX_tmp,HX_tmp,acrain_tmp, & -! ACSNOM_tmp, esnow2d_tmp, drip2d_tmp,dewfall_tmp, fpar_tmp, & -! qfx_tmp, prcp_out_tmp, etpndx_tmp - - outflag = -99 - -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - if(nlst_rt(did)%olddate(1:19) .eq. nlst_rt(did)%startdate(1:19) .and. rt_domain(did)%his_out_counts .eq. 0) then -#ifdef HYDRO_D - write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19), rt_domain(did)%his_out_counts -#endif - outflag = 99 - else - if(nlst_rt(did)%dt .gt. nlst_rt(did)%out_dt*60) then - call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%out_counts)) - else - call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%out_dt*60*rt_domain(did)%out_counts)) - endif - if ( out_date(1:19) == nlst_rt(did)%olddate(1:19) ) then -#ifdef HYDRO_D - write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19) -#endif - outflag = 99 - endif - endif -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(outflag) -#endif - - call HYDRO_rst_out(did) - - if (outflag .lt. 0) return - - rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1 - rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1 - - if(nlst_rt(did)%out_dt*60 .gt. nlst_rt(did)%DT) then - kt = rt_domain(did)%his_out_counts*nlst_rt(did)%out_dt*60/nlst_rt(did)%DT - else - kt = rt_domain(did)%his_out_counts - endif - - -! jump the ouput for the initial time when it has restart file from routing. - rtflag = -99 -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - if ( (trim(nlst_rt(did)%restart_file) /= "") .and. ( nlst_rt(did)%startdate(1:19) == nlst_rt(did)%olddate(1:19) ) ) then - print*, "yyyywww restart_file = ", trim(nlst_rt(did)%restart_file) - rtflag = 1 - endif -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(rtflag) -#endif - - -!yw keep the initial time otuput for debug - if(rtflag == 1) return ! jump the initial time output for routing restart - - - - call output_lsm(trim(nlst_rt(did)%olddate(1:4)//nlst_rt(did)%olddate(6:7)//nlst_rt(did)%olddate(9:10) & - //nlst_rt(did)%olddate(12:13)//nlst_rt(did)%olddate(15:16)// & - ".LSMOUT_DOMAIN"//trim(nlst_rt(did)%hgrid)), & - did) - - - - if(nlst_rt(did)%SUBRTSWCRT .gt. 0 & - .or. nlst_rt(did)%OVRTSWCRT .gt. 0 & - .or. nlst_rt(did)%GWBASESWCRT .gt. 0 ) then - if (nlst_rt(did)%HIRES_OUT.ge.1) then - - -! goto 9991 - -#ifdef MPP_LAND - call mpp_output_rt(rt_domain(did)%g_ixrt, rt_domain(did)%g_jxrt, & -#else - call output_rt( & -#endif - nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & - RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & - nlst_rt(did)%nsoil, & -! nlst_rt(did)%startdate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,& - nlst_rt(did)%sincedate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,& - RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SMCRT,& - RT_DOMAIN(did)%SUB_RESID, & - RT_DOMAIN(did)%q_sfcflx_x,RT_DOMAIN(did)%q_sfcflx_y,& - RT_DOMAIN(did)%soxrt,RT_DOMAIN(did)%soyrt,& - RT_DOMAIN(did)%QSTRMVOLRT,RT_DOMAIN(did)%SFCHEADSUBRT, & - nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT,& - RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL,& - RT_DOMAIN(did)%LONVAL,RT_DOMAIN(did)%dist,nlst_rt(did)%HIRES_OUT,& - RT_DOMAIN(did)%QBDRYRT ) - -! 9991 continue - - end if - - - if(nlst_rt(did)%GWBASESWCRT .eq. 3) then - - call output_gw( & - nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & - RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, & - nlst_rt(did)%nsoil, & -! nlst_rt(did)%startdate, nlst_rt(did)%olddate, & - nlst_rt(did)%sincedate, nlst_rt(did)%olddate, & - gw2d(did)%h, RT_DOMAIN(did)%SMCRT, & - gw2d(did)%convgw, RT_DOMAIN(did)%SFCHEADSUBRT, & - nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT, & - RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL, & - RT_DOMAIN(did)%LONVAL,rt_domain(did)%dist, & - nlst_rt(did)%HIRES_OUT) - - endif -! BF end gw2d output section - -#ifdef HYDRO_D - write(6,*) "before call output_chrt" -#endif - - if (nlst_rt(did)%CHANRTSWCRT.eq.1.or.nlst_rt(did)%CHANRTSWCRT.eq.2) then - -#ifdef MPP_LAND - call mpp_output_chrt(rt_domain(did)%gnlinks,rt_domain(did)%map_l2g, & -#else - call output_chrt( & -#endif - nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & - RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, & -! nlst_rt(did)%startdate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& - nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,& - RT_DOMAIN(did)%CHLAT, & - RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV, & - RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt, & - RT_DOMAIN(did)%STRMFRXSTPTS,nlst_rt(did)%order_to_write) - -#ifdef MPP_LAND -! call mpp_output_chrtgrd(nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & -! RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt, RT_DOMAIN(did)%NLINKS, & -! RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%ORDER, & -! nlst_rt(did)%startdate, nlst_rt(did)%olddate, & -! RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm, & -! RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & -! RT_DOMAIN(did)%g_ixrt,RT_DOMAIN(did)%g_jxrt ) -#endif - - if (RT_DOMAIN(did)%NLAKES.gt.0) & -#ifdef MPP_LAND - call mpp_output_lakes( RT_DOMAIN(did)%lake_index, & -#else - call output_lakes( & -#endif - nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, & - RT_DOMAIN(did)%NLAKES, & -! trim(nlst_rt(did)%startdate), trim(nlst_rt(did)%olddate), & - trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), & - RT_DOMAIN(did)%LATLAKE,RT_DOMAIN(did)%LONLAKE, & - RT_DOMAIN(did)%ELEVLAKE,RT_DOMAIN(did)%QLAKEI, & - RT_DOMAIN(did)%QLAKEO, & - RT_DOMAIN(did)%RESHT,nlst_rt(did)%DT,Kt) - endif -#ifdef HYDRO_D - write(6,*) "end calling output functions" -#endif - - endif ! end of routing switch - - - end subroutine HYDRO_out - - - subroutine HYDRO_rst_in(did) - integer :: did - integer:: flag - - - - flag = -1 -#ifdef MPP_LAND - if(my_id.eq.IO_id) then -#endif - if (trim(nlst_rt(did)%restart_file) /= "") then - flag = 99 - rt_domain(did)%timestep_flag = 99 ! continue run - endif -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(flag) -#endif - - nlst_rt(did)%sincedate = nlst_rt(did)%startdate - - if (flag.eq.99) then - -#ifdef MPP_LAND - if(my_id.eq.IO_id) then -#endif -#ifdef HYDRO_D - write(6,*) "*** read restart data: ",trim(nlst_rt(did)%restart_file) -#endif -#ifdef MPP_LAND - endif -#endif - call RESTART_IN_nc(trim(nlst_rt(did)%restart_file), did) - -!yw if (trim(nlst_rt(did)%restart_file) /= "") then -!yw nlst_rt(did)%restart_file = "" -!yw endif - - endif - end subroutine HYDRO_rst_in - - subroutine HYDRO_time_adv(did) - implicit none - character(len = 19) :: newdate - integer did - -#ifdef MPP_LAND - if(IO_id.eq.my_id) then -#endif - call geth_newdate(newdate, nlst_rt(did)%olddate, nint( nlst_rt(did)%dt)) - nlst_rt(did)%olddate = newdate -#ifdef HYDRO_D - write(6,*) "current time is ",newdate -#endif -#ifdef MPP_LAND - endif -#endif - end subroutine HYDRO_time_adv - - subroutine HYDRO_exe(did) - - - implicit none - integer:: did - integer:: rst_out - - - call HYDRO_out(did) - - -! running land surface model -! cpl: 0--offline run; -! 1-- coupling with WRF but running offline lsm; -! 2-- coupling with WRF but do not run offline lsm -! 3-- coupling with LIS and do not run offline lsm -! 4: coupling with CLM -! if(nlst_rt(did)%SYS_CPL .eq. 0 .or. nlst_rt(did)%SYS_CPL .eq. 1 )then -! call drive_noahLSF(did,kt) -! else -! ! does not run the NOAH LASF model, only read the parameter -! call read_land_par(did,lsm(did)%ix,lsm(did)%jx) -! endif - - - - - - if (nlst_rt(did)%GWBASESWCRT .ne. 0 & - .or. nlst_rt(did)%SUBRTSWCRT .NE.0 & - .or. nlst_rt(did)%OVRTSWCRT .NE. 0 ) THEN - - - RT_DOMAIN(did)%QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT - RT_DOMAIN(did)%LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT - - - - ! step 1) disaggregate specific fields from LSM to Hydro grid - call disaggregateDomain_drv(did) - - ! step 2) - call SubsurfaceRouting_drv(did) - - ! step 3) todo split - call OverlandRouting_drv(did) - - RT_DOMAIN(did)%QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-RT_DOMAIN(did)%QSTRMVOLRT_DUM - RT_DOMAIN(did)%LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-RT_DOMAIN(did)%LAKE_INFLORT_DUM - - - ! step 4) baseflow or groundwater physics - call driveGwBaseflow(did) - - ! step 5) river channel physics - call driveChannelRouting(did) - - ! step 6) aggregate specific fields from Hydro to LSM grid - call aggregateDomain(did) - - - end if - - - ! advance to next time step - call HYDRO_time_adv(did) - - ! output for history - call HYDRO_out(did) - - -! write(90 + my_id,*) "finish calling hydro_exe" -! flush(90+my_id) -! call mpp_land_sync() - - - - RT_DOMAIN(did)%SOLDRAIN = 0 - RT_DOMAIN(did)%QSUBRT = 0 - - - - end subroutine HYDRO_exe - - - -!---------------------------------------------------- - subroutine driveGwBaseflow(did) - - implicit none - integer, intent(in) :: did - - integer :: i - -!------------------------------------------------------------------ -!DJG Begin GW/Baseflow Routines -!------------------------------------------------------------------- - - IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN ! Switch to activate/specify GW/Baseflow - -! IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow - - If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then ! Call simple bucket baseflow scheme - -#ifdef HYDRO_D - write(6,*) "*****yw******start simp_gw_buck " -#endif - - call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& - RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%basns_area,& - RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & - RT_DOMAIN(did)%SOLDRAIN, & - RT_DOMAIN(did)%z_gwsubbas,& - RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& - RT_DOMAIN(did)%qinflowbase,& - RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & - RT_DOMAIN(did)%dist,nlst_rt(did)%DT,& - RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & - RT_DOMAIN(did)%z_max,& - nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT) - - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - - open (unit=51,file='GW_inflow.txt',form='formatted',& - status='unknown',position='append') - open (unit=52,file='GW_outflow.txt',form='formatted',& - status='unknown',position='append') - open (unit=53,file='GW_zlev.txt',form='formatted',& - status='unknown',position='append') - do i=1,RT_DOMAIN(did)%numbasns - write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i) -951 FORMAT(I3,1X,A19,1X,F11.3) - write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i) - write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i) - end do - close(51) - close(52) - close(53) -#ifdef MPP_LAND - endif -#endif - -#ifdef HYDRO_D - write(6,*) "*****yw******end simp_gw_buck " -#endif - -!!!For parameter setup runs output the percolation for each basin, -!!!otherwise comment out this output... - else if (nlst_rt(did)%GWBASESWCRT .eq. 3) then - -#ifdef HYDRO_D - write(6,*) "*****bf******start 2d_gw_model " -#endif - - call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & - gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & - gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & - gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & - gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & - gw2d(did)%istep) - - -! bftodo head postprocessing block -! GW-SOIL-CHANNEL interaction section - gw2d(did)%ho = gw2d(did)%h - -#ifdef HYDRO_D - write(6,*) "*****bf******end 2d_gw_model " -#endif - - End if - - END IF !DJG (End if for RTE SWC activation) -!------------------------------------------------------------------ -!DJG End GW/Baseflow Routines -!------------------------------------------------------------------- - - - end subroutine driveGwBaseflow - - - - -!------------------------------------------- - subroutine driveChannelRouting(did) - - implicit none - integer, intent(in) :: did - -!------------------------------------------------------------------- -!------------------------------------------------------------------- -!DJG,DNY Begin Channel and Lake Routing Routines -!------------------------------------------------------------------- - IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN - - call drive_CHANNEL(RT_DOMAIN(did)%latval,RT_DOMAIN(did)%lonval, & - RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & - nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, & - RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS,& - RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& - RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& - RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT, & - RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTCT,nlst_rt(did)%DTRT,& - RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & - RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& - RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & - RT_DOMAIN(did)%Bw,& - RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,& - RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, & - RT_DOMAIN(did)%ORIFICEA, & - RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & - RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& - RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, & - RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & - RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, & - RT_DOMAIN(did)%RETDEP_CHAN & - , RT_DOMAIN(did)%node_area & -#ifdef MPP_LAND - ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& - RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & - RT_DOMAIN(did)%yw_mpp_nlinks & -#endif - ) - endif - -#ifdef HYDRO_D - write(6,*) "*****yw******end drive_CHANNEL " -#endif - - end subroutine driveChannelRouting - - - -!------------------------------------------------ - subroutine aggregateDomain(did) - - implicit none - integer, intent(in) :: did - - integer :: i, j, krt, ixxrt, jyyrt, & - AGGFACYRT, AGGFACXRT -#ifdef HYDRO_D - print *, "Beginning Aggregation..." -#endif - - - do J=1,RT_DOMAIN(did)%JX - do I=1,RT_DOMAIN(did)%IX - - RT_DOMAIN(did)%SFCHEADAGGRT = 0. -!DJG Subgrid weighting edit... - RT_DOMAIN(did)%LSMVOL=0. - do KRT=1,nlst_rt(did)%NSOIL -! SMCAGGRT(KRT) = 0. - RT_DOMAIN(did)%SH2OAGGRT(KRT) = 0. - end do - - - do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1 - do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1 - - - IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT - JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT -#ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 -#else -!yw ???? -! IXXRT=IXXRT+1 -! JYYRT=JYYRT+1 -#endif - -!State Variables - RT_DOMAIN(did)%SFCHEADAGGRT = RT_DOMAIN(did)%SFCHEADAGGRT & - + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) -!DJG Subgrid weighting edit... - RT_DOMAIN(did)%LSMVOL = RT_DOMAIN(did)%LSMVOL & - + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) & - * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9) - - do KRT=1,nlst_rt(did)%NSOIL -!DJG SMCAGGRT(KRT)=SMCAGGRT(KRT)+SMCRT(IXXRT,JYYRT,KRT) - RT_DOMAIN(did)%SH2OAGGRT(KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & - + RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) - end do - - end do - end do - - - - RT_DOMAIN(did)%SFCHEADRT(I,J) = RT_DOMAIN(did)%SFCHEADAGGRT & - / (nlst_rt(did)%AGGFACTRT**2) - - do KRT=1,nlst_rt(did)%NSOIL -!DJG SMC(I,J,KRT)=SMCAGGRT(KRT)/(AGGFACTRT**2) - RT_DOMAIN(did)%SH2OX(I,J,KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) & - / (nlst_rt(did)%AGGFACTRT**2) - end do - - - -!DJG Calculate subgrid weighting array... - - do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1 - do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1 - IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT - JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT -#ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 -#else -!yw ??? -! IXXRT=IXXRT+1 -! JYYRT=JYYRT+1 -#endif - if (RT_DOMAIN(did)%LSMVOL.gt.0.) then - RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & - = RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) & - * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9) & - / RT_DOMAIN(did)%LSMVOL - else - RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) & - = 1./FLOAT(nlst_rt(did)%AGGFACTRT**2) - end if - - do KRT=1,nlst_rt(did)%NSOIL - -!!!yw added for debug - if(RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .lt. 0) then - print*, "Error negative SMCRT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) - endif - if(RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) .lt. 0) then - print *, "Error negative SH2OWGT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) - endif - -!end - IF (RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .GT. & - RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT)) THEN -#ifdef HYDRO_D - print *, "SMCMAX exceeded upon aggregation...", & - RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT), & - RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT) - call hydro_stop("aggregateDomain") -#endif - END IF - IF(RT_DOMAIN(did)%SH2OX(I,J,KRT).LE.0.) THEN -#ifdef HYDRO_D - print *, "Erroneous value of SH2O...", & - RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT - print *, "Error negative SH2OX", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT) - call hydro_stop("aggregateDomain") -#endif - END IF - RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) & - = RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) & - / RT_DOMAIN(did)%SH2OX(I,J,KRT) -!?yw - RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = max(1.0E-30, RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT)) - end do - - end do - end do - - end do - end do - - -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(RT_DOMAIN(did)%INFXSWGT, & - RT_DOMAIN(did)%IXRT, & - RT_DOMAIN(did)%JXRT, 99) - - do i = 1, nlst_rt(did)%NSOIL - call MPP_LAND_COM_REAL(RT_DOMAIN(did)%SH2OWGT(:,:,i), & - RT_DOMAIN(did)%IXRT, & - RT_DOMAIN(did)%JXRT, 99) - end do -#endif - -!DJG Update SMC with SICE (unchanged) and new value of SH2O from routing... - RT_DOMAIN(did)%SMC = RT_DOMAIN(did)%SH2OX + RT_DOMAIN(did)%SICE -#ifdef HYDRO_D - print *, "Finished Aggregation..." -#endif - - - end subroutine aggregateDomain - - - - subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp) - implicit none - integer ntime, did - integer rst_out, ix,jx -! integer, OPTIONAL:: ix0,jx0 - integer:: ix0,jx0 - integer, dimension(ix0,jx0),OPTIONAL :: vegtyp, soltyp - - - -#ifdef MPP_LAND - call MPP_LAND_INIT() -#endif - - -! read the namelist -! the lsm namelist will be read by rtland sequentially again. - call read_rt_nlst(nlst_rt(did) ) - - - IF (nlst_rt(did)%GWBASESWCRT .eq. 0 & - .and. nlst_rt(did)%SUBRTSWCRT .eq.0 & - .and. nlst_rt(did)%OVRTSWCRT .eq. 0 ) return - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! get the dimension - call get_file_dimension(trim(nlst_rt(did)%geo_static_flnm), ix,jx) - - -#ifdef MPP_LAND - - if (nlst_rt(did)%sys_cpl .eq. 1 .or. nlst_rt(did)%sys_cpl .eq. 4) then -!sys_cpl: 1-- coupling with HRLDAS but running offline lsm; -! 2-- coupling with WRF but do not run offline lsm -! 3-- coupling with LIS and do not run offline lsm -! 4: coupling with CLM - -! create 2 dimensiaon logical mapping of the CPUs for coupling with CLM or HRLDAS. - call log_map2d() - - global_nx = ix ! get from land model - global_ny = jx ! get from land model - - call mpp_land_bcast_int1(global_nx) - call mpp_land_bcast_int1(global_ny) - -!!! temp set global_nx to ix - rt_domain(did)%ix = global_nx - rt_domain(did)%jx = global_ny - -! over write the ix and jx - call MPP_LAND_PAR_INI(1,rt_domain(did)%ix,rt_domain(did)%jx,& - nlst_rt(did)%AGGFACTRT) - else -! coupled with WRF, LIS - numprocs = node_info(1,1) - - call wrf_LAND_set_INIT(node_info,numprocs,nlst_rt(did)%AGGFACTRT) - - - rt_domain(did)%ix = local_nx - rt_domain(did)%jx = local_ny - endif - - - - rt_domain(did)%g_IXRT=global_rt_nx - rt_domain(did)%g_JXRT=global_rt_ny - rt_domain(did)%ixrt = local_rt_nx - rt_domain(did)%jxrt = local_rt_ny - -#ifdef HYDRO_D - write(6,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt" - write(6,*) rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt - write(6,*) "rt_domain(did)%ix, rt_domain(did)%jx " - write(6,*) rt_domain(did)%ix, rt_domain(did)%jx - write(6,*) "global_nx, global_ny, local_nx, local_ny" - write(6,*) global_nx, global_ny, local_nx, local_ny -#endif -#else -! sequential - rt_domain(did)%ix = ix - rt_domain(did)%jx = jx - rt_domain(did)%ixrt = ix*nlst_rt(did)%AGGFACTRT - rt_domain(did)%jxrt = jx*nlst_rt(did)%AGGFACTRT -#endif - - -! allocate rt arrays - - - call getChanDim(did) - - -#ifdef HYDRO_D - write(6,*) "finish getChanDim " -#endif - - if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then - call gw2d_allocate(did,& - rt_domain(did)%ixrt,& - rt_domain(did)%jxrt,& - nlst_rt(did)%nsoil) -#ifdef HYDRO_D - write(6,*) "finish gw2d_allocate" -#endif - endif - -! calculate the distance between grids for routing. -! decompose the land parameter/data - - -! ix0= rt_domain(did)%ix -! jx0= rt_domain(did)%jx - if(present(vegtyp)) then - call lsm_input(did,ix0=ix0,jx0=jx0,vegtyp0=vegtyp,soltyp0=soltyp) - else - call lsm_input(did,ix0=ix0,jx0=jx0) - endif - - -#ifdef HYDRO_D - write(6,*) "finish decomposion" -#endif - - - call get_dist_lsm(did) - call get_dist_lrt(did) - - -! rt model initilization - call LandRT_ini(did) - -#ifdef HYDRO_D - write(6,*) "finish LandRT_ini" -#endif - - - if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then - - call gw2d_ini(did,& - nlst_rt(did)%dt,& - nlst_rt(did)%dxrt0) -#ifdef HYDRO_D - write(6,*) "finish gw2d_ini" -#endif - endif -#ifdef HYDRO_D - write(6,*) "finish LandRT_ini" -#endif - - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - - IF (nlst_rt(did)%TERADJ_SOLAR.EQ.1 .and. nlst_rt(did)%CHANRTSWCRT.NE.2) THEN ! Perform ter rain adjustment of incoming solar -#ifdef MPP_LAND - call MPP_seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& - rt_domain(did)%TERRAIN, rt_domain(did)%dist_lsm,& - rt_domain(did)%ix,rt_domain(did)%jx,global_nx,global_ny) -#else - call seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,& - rt_domain(did)%TERRAIN,rt_domain(did)%dist_lsm,& - rt_domain(did)%ix,rt_domain(did)%jx) -#endif - endif - - - IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2 .or. nlst_rt(did)%GWBASESWCRT .gt. 0) then - call get_basn_area(did) - endif - - IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2 ) then -! call get_basn_area(did) - call get_node_area(did) - endif - - -! if (trim(nlst_rt(did)%restart_file) == "") then -! output at the initial time -! call HYDRO_out(did) -! return -! endif - -! restart the file - - ! jummp the initial time output -! rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1 -! rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1 - - call HYDRO_rst_in(did) - - -! call HYDRO_out(did) - - - end subroutine HYDRO_ini - - subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0) - implicit none - integer did, leng - parameter(leng=100) - integer :: i,j, nn - integer, allocatable, dimension(:,:) :: soltyp - real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc - - integer :: ix0,jx0 - integer, dimension(ix0,jx0),OPTIONAL :: vegtyp0, soltyp0 - -#ifdef HYDRO_D - write(6,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx -#endif - - allocate(soltyp(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) ) - - soltyp = 0 - call get2d_lsm_soltyp(soltyp,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) - - - call get2d_lsm_real("HGT",RT_DOMAIN(did)%TERRAIN,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) - - call get2d_lsm_real("XLAT",RT_DOMAIN(did)%lat_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) - call get2d_lsm_real("XLONG",RT_DOMAIN(did)%lon_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) - call get2d_lsm_vegtyp(RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm)) - - - - if(nlst_rt(did)%sys_cpl .eq. 2 ) then - ! coupling with WRF - if(present(soltyp0) ) then - where(soltyp0 == 14) VEGTYP0 = 16 - where(VEGTYP0 == 16 ) soltyp0 = 14 - soltyp = soltyp0 - RT_DOMAIN(did)%VEGTYP = VEGTYP0 - endif - endif - - where(soltyp == 14) RT_DOMAIN(did)%VEGTYP = 16 - where(RT_DOMAIN(did)%VEGTYP == 16 ) soltyp = 14 - -! LKSAT, -! temporary set - RT_DOMAIN(did)%SMCRTCHK = 0 - RT_DOMAIN(did)%SMCAGGRT = 0 - RT_DOMAIN(did)%STCAGGRT = 0 - RT_DOMAIN(did)%SH2OAGGRT = 0 - - - RT_DOMAIN(did)%zsoil(1:nlst_rt(did)%nsoil) = nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) - - RT_DOMAIN(did)%sldpth(1) = abs( RT_DOMAIN(did)%zsoil(1) ) - do i = 2, nlst_rt(did)%nsoil - RT_DOMAIN(did)%sldpth(i) = RT_DOMAIN(did)%zsoil(i-1)-RT_DOMAIN(did)%zsoil(i) - enddo - RT_DOMAIN(did)%SOLDEPRT = -1.0*RT_DOMAIN(did)%ZSOIL(nlst_rt(did)%NSOIL) - -! input OV_ROUGH from OVROUGH.TBL -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - - open(71,file="HYDRO.TBL", form="formatted") -!read OV_ROUGH first - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) RT_DOMAIN(did)%OV_ROUGH(i) - end do -!read parameter for LKSAT - read(71,*) nn - read(71,*) - do i = 1, nn - read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i) - end do - close(71) - -#ifdef MPP_LAND - endif - call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH) - call mpp_land_bcast_real(leng,xdum1) - call mpp_land_bcast_real(leng,MAXSMC) - call mpp_land_bcast_real(leng,refsmc) - call mpp_land_bcast_real(leng,wltsmc) -#endif - - rt_domain(did)%lksat = 0.0 - do j = 1, RT_DOMAIN(did)%jx - do i = 1, RT_DOMAIN(did)%ix - !yw rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0 - rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) - IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN ! urban - rt_domain(did)%SMCMAX1(i,j) = 0.45 - rt_domain(did)%SMCREF1(i,j) = 0.42 - rt_domain(did)%SMCWLT1(i,j) = 0.40 - else - rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J)) - rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J)) - rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J)) - ENDIF - end do - end do - - deallocate(soltyp) - - - end subroutine lsm_input - - -end module module_HYDRO_drv - -! stop the job due to the fatal error. - subroutine HYDRO_stop(msg) -#ifdef MPP_LAND - use module_mpp_land -#endif - character(len=*) :: msg - integer :: ierr -#ifdef HYDRO_D - write(6,*) "The job is stoped due to the fatal error. ", trim(msg) - flush(6) -#endif -#ifdef MPP_LAND -#ifndef HYDRO_D - print*, "---" - print*, "ERROR! Program stopped. Recompile with environment variable HYDRO_D set to 1 for enhanced debug information." - print*, "" -#endif - -! call mpp_land_sync() -! write(my_id+90,*) msg -! flush(my_id+90) - - call mpp_land_abort() - call MPI_finalize(ierr) -#else - stop "Fatal Error" -#endif - - return - end subroutine HYDRO_stop - - -! stop the job due to the fatal error. - subroutine HYDRO_finish() -#ifdef MPP_LAND - USE module_mpp_land -#endif - integer :: ierr - - print*, "The model finished successfully......." -#ifdef MPP_LAND -! call mpp_land_abort() - flush(6) - call mpp_land_sync() - call MPI_finalize(ierr) - stop -#else - stop -#endif - - return - end subroutine HYDRO_finish diff --git a/wrfv2_fire/hydro/MPP/.svn/all-wcprops b/wrfv2_fire/hydro/MPP/.svn/all-wcprops deleted file mode 100644 index b62c0e7b..00000000 --- a/wrfv2_fire/hydro/MPP/.svn/all-wcprops +++ /dev/null @@ -1,23 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 56 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/MPP -END -CPL_WRF.F -K 25 -svn:wc:ra_dav:version-url -V 66 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/MPP/CPL_WRF.F -END -Makefile -K 25 -svn:wc:ra_dav:version-url -V 65 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/MPP/Makefile -END -mpp_land.F -K 25 -svn:wc:ra_dav:version-url -V 67 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/MPP/mpp_land.F -END diff --git a/wrfv2_fire/hydro/MPP/.svn/entries b/wrfv2_fire/hydro/MPP/.svn/entries deleted file mode 100644 index 8cffcbf8..00000000 --- a/wrfv2_fire/hydro/MPP/.svn/entries +++ /dev/null @@ -1,130 +0,0 @@ -10 - -dir -9105 -https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/MPP -https://kkeene@svn-wrf-model.cgd.ucar.edu - - - -2015-01-23T18:49:15.035273Z -8003 -gill - - - - - - - - - - - - - - -b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d - -CPL_WRF.F -file - - - - -2016-02-11T20:37:50.152130Z -7185bcd723e0f65d8c6f376749eef4c5 -2013-11-15T19:40:36.446206Z -6964 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -4481 - -Makefile -file - - - - -2016-02-11T20:37:50.149954Z -80b086e907e5a44f1bc069d50007290a -2012-12-07T20:01:45.900797Z -6094 -gill - - - - - - - - - - - - - - - - - - - - - -529 - -mpp_land.F -file - - - - -2016-02-11T20:37:50.151125Z -69e53e4ef44c840d3da76d9faec33837 -2015-01-23T18:49:15.035273Z -8003 -gill - - - - - - - - - - - - - - - - - - - - - -62275 - diff --git a/wrfv2_fire/hydro/MPP/.svn/text-base/CPL_WRF.F.svn-base b/wrfv2_fire/hydro/MPP/.svn/text-base/CPL_WRF.F.svn-base deleted file mode 100644 index 45876b9b..00000000 --- a/wrfv2_fire/hydro/MPP/.svn/text-base/CPL_WRF.F.svn-base +++ /dev/null @@ -1,159 +0,0 @@ -! This is used as a coupler with the WRF model. -MODULE MODULE_CPL_LAND - - - IMPLICIT NONE - - integer my_global_id - - integer total_pe_num - integer global_ix,global_jx - - integer,allocatable,dimension(:,:) :: node_info - - logical initialized, cpl_land, time_step_read_rstart, & - time_step_write_rstart, time_step_output - character(len=19) cpl_outdate, cpl_rstdate - - - - contains - - subroutine CPL_LAND_INIT(istart,iend,jstart,jend) - implicit none - include "mpif.h" - integer ierr - logical mpi_inited - integer istart,iend,jstart,jend - - CALL mpi_initialized( mpi_inited, ierr ) - if ( .NOT. mpi_inited ) then - call mpi_init(ierr) - endif - - call MPI_COMM_RANK( MPI_COMM_WORLD, my_global_id, ierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, total_pe_num, ierr ) - - allocate(node_info(9,total_pe_num)) - - node_info = -99 - -! send node info to node 0 - node_info(1,my_global_id+1) = total_pe_num - node_info(6,my_global_id+1) = istart - node_info(7,my_global_id+1) = iend - node_info(8,my_global_id+1) = jstart - node_info(9,my_global_id+1) = jend - - - call send_info() - call find_left() - call find_right() - call find_up() - call find_down() - - call send_info() - - initialized = .false. ! land model need to be initialized. - return - END subroutine CPL_LAND_INIT - - subroutine send_info() - implicit none - include "mpif.h" - integer,allocatable,dimension(:,:) :: tmp_info - integer ierr, i,size, tag - integer mpp_status(MPI_STATUS_SIZE) - tag = 9 - size = 9 - - if(my_global_id .eq. 0) then - do i = 1, total_pe_num-1 - call mpi_recv(node_info(:,i+1),size,MPI_INTEGER, & - i,tag,MPI_COMM_WORLD,mpp_status,ierr) - enddo - else - call mpi_send(node_info(:,my_global_id+1),size, & - MPI_INTEGER,0,tag,MPI_COMM_WORLD,ierr) - endif - - call MPI_barrier( MPI_COMM_WORLD ,ierr) - - size = 9 * total_pe_num - call mpi_bcast(node_info,size,MPI_INTEGER, & - 0,MPI_COMM_WORLD,ierr) - - call MPI_barrier( MPI_COMM_WORLD ,ierr) - - return - end subroutine send_info - - subroutine find_left() - implicit none - integer i - - node_info(2,my_global_id+1) = -1 - - do i = 1, total_pe_num - if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. & - (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. & - ((node_info(7,i)+1).eq.node_info(6,my_global_id+1)) ) then - node_info(2,my_global_id+1) = i - 1 - return - endif - end do - return - end subroutine find_left - - subroutine find_right() - implicit none - integer i - - node_info(3,my_global_id+1) = -1 - - do i = 1, total_pe_num - if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. & - (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. & - ((node_info(6,i)-1).eq.node_info(7,my_global_id+1)) ) then - node_info(3,my_global_id+1) = i - 1 - return - endif - end do - return - end subroutine find_right - - subroutine find_up() - implicit none - integer i - - node_info(4,my_global_id+1) = -1 - - do i = 1, total_pe_num - if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. & - (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. & - ((node_info(8,i)-1).eq.node_info(9,my_global_id+1)) ) then - node_info(4,my_global_id+1) = i - 1 - return - endif - end do - return - end subroutine find_up - - subroutine find_down() - implicit none - integer i - - node_info(5,my_global_id+1) = -1 - - do i = 1, total_pe_num - if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. & - (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. & - ((node_info(9,i)+1).eq.node_info(8,my_global_id+1)) ) then - node_info(5,my_global_id+1) = i - 1 - return - endif - end do - return - end subroutine find_down - -END MODULE MODULE_CPL_LAND diff --git a/wrfv2_fire/hydro/MPP/.svn/text-base/Makefile.svn-base b/wrfv2_fire/hydro/MPP/.svn/text-base/Makefile.svn-base deleted file mode 100644 index abc0b055..00000000 --- a/wrfv2_fire/hydro/MPP/.svn/text-base/Makefile.svn-base +++ /dev/null @@ -1,26 +0,0 @@ -# Makefile -# -.SUFFIXES: -.SUFFIXES: .o .F - -include ../macros - -OBJS = CPL_WRF.o mpp_land.o - -all: $(OBJS) -mpp_land.o: mpp_land.F - @echo "" - $(RMD) $(*).o $(*).mod $(*).stb *~ - $(COMPILER90) $(F90FLAGS) -c $(*).F - ar -r ../lib/libHYDRO.a $(@) - -CPL_WRF.o: CPL_WRF.F - @echo "" - $(RMD) $(*).o $(*).mod $(*).stb *~ *.f - $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f - $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f - - $(COMPILER90) $(F90FLAGS) -c $(*).F - ar -r ../lib/libHYDRO.a $(@) -clean: - $(RMD) *.o *.mod *.stb *~ diff --git a/wrfv2_fire/hydro/MPP/.svn/text-base/mpp_land.F.svn-base b/wrfv2_fire/hydro/MPP/.svn/text-base/mpp_land.F.svn-base deleted file mode 100644 index e3935c3c..00000000 --- a/wrfv2_fire/hydro/MPP/.svn/text-base/mpp_land.F.svn-base +++ /dev/null @@ -1,1876 +0,0 @@ -!#### This is a module for parallel Land model. -MODULE MODULE_MPP_LAND - - use MODULE_CPL_LAND - - IMPLICIT NONE - include "mpif.h" - integer, public :: left_id,right_id,up_id,down_id,my_id - integer, public :: left_right_np,up_down_np ! define total process in two dimensions. - integer, public :: left_right_p ,up_down_p ! the position of the current process in the logical topography. - integer, public :: IO_id ! the number for IO. (Last processor for IO) - integer, public :: global_nx, global_ny, local_nx,local_ny - integer, public :: global_rt_nx, global_rt_ny - integer, public :: local_rt_nx,local_rt_ny,rt_AGGFACTRT - integer, public :: numprocs ! total process, get by mpi initialization. - integer :: local_startx, local_starty - - integer mpp_status(MPI_STATUS_SIZE) - - integer overlap_n - integer, allocatable, DIMENSION(:), public :: local_nx_size,local_ny_size - integer, allocatable, DIMENSION(:), public :: local_rt_nx_size,local_rt_ny_size - integer, allocatable, DIMENSION(:), public :: startx,starty - integer, allocatable, DIMENSION(:), public :: mpp_nlinks - - interface check_land - module procedure check_landreal1 - module procedure check_landreal1d - module procedure check_landreal2d - module procedure check_landreal3d - end interface - interface write_io_land - module procedure write_io_real3d - end interface - interface mpp_land_bcast - module procedure mpp_land_bcast_real2 - module procedure mpp_land_bcast_real_1d - module procedure mpp_land_bcast_real1 - module procedure mpp_land_bcast_char1d - module procedure mpp_land_bcast_char1 - module procedure mpp_land_bcast_int1 - module procedure mpp_land_bcast_int1d - module procedure mpp_land_bcast_int2d - module procedure mpp_land_bcast_logical - end interface - - contains - - subroutine LOG_MAP2d() - implicit none - integer :: ierr - call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) - - call getNX_NY(numprocs, left_right_np,up_down_np) - if(my_id.eq.IO_id) then -#ifdef HYDRO_D - write(6,*) "" - write(6,*) "total process:",numprocs - write(6,*) "left_right_np =", left_right_np,& - "up_down_np=",up_down_np -#endif - end if - -! ### get the row and column of the current process in the logical topography. -! ### left --> right, 0 -->left_right_np -1 -! ### up --> down, 0 --> up_down_np -1 - left_right_p = mod(my_id , left_right_np) - up_down_p = my_id / left_right_np - -! ### get the neighbors. -1 means no neighbor. - down_id = my_id - left_right_np - up_id = my_id + left_right_np - if( up_down_p .eq. 0) down_id = -1 - if( up_down_p .eq. (up_down_np-1) ) up_id = -1 - - left_id = my_id - 1 - right_id = my_id + 1 - if( left_right_p .eq. 0) left_id = -1 - if( left_right_p .eq. (left_right_np-1) ) right_id =-1 - -! ### the IO node is the last processor. -!yw IO_id = numprocs - 1 - IO_id = 0 - -! print the information for debug. - - call mpp_land_sync() - - return - end subroutine log_map2d -!old subroutine MPP_LAND_INIT(flag, ew_numprocs, sn_numprocs) - subroutine MPP_LAND_INIT() -! ### initialize the land model logically based on the two D method. -! ### Call this function directly if it is nested with WRF. - implicit none - integer :: ierr - integer :: ew_numprocs, sn_numprocs ! input the processors in x and y direction. - logical mpi_inited - -! left_right_np = ew_numprocs -! up_down_np = sn_numprocs - - CALL mpi_initialized( mpi_inited, ierr ) - if ( .NOT. mpi_inited ) then - call MPI_INIT( ierr ) ! stand alone land model. - else - call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) - return - endif -! create 2d logical mapping of the CPU. - call log_map2d() - - return - end subroutine MPP_LAND_INIT - - - subroutine MPP_LAND_PAR_INI(over_lap,in_global_nx,in_global_ny,AGGFACTRT) - integer in_global_nx,in_global_ny, AGGFACTRT - integer :: over_lap ! the overlaped grid number. (default is 1) - integer :: i - - global_nx = in_global_nx - global_ny = in_global_ny - rt_AGGFACTRT = AGGFACTRT - global_rt_nx = in_global_nx*AGGFACTRT - global_rt_ny = in_global_ny *AGGFACTRT - !overlap_n = 1 -!ywold local_nx = global_nx / left_right_np -!ywold if(left_right_p .eq. (left_right_np-1) ) then -!ywold local_nx = global_nx & -!ywold -int(global_nx/left_right_np)*(left_right_np-1) -!ywold end if -!ywold local_ny = global_ny / up_down_np -!ywold if( up_down_p .eq. (up_down_np-1) ) then -!ywold local_ny = global_ny & -!ywold -int(global_ny/up_down_np)*(up_down_np -1) -!ywold end if - - local_nx = int(global_nx / left_right_np) - !if(global_nx .ne. (local_nx*left_right_np) ) then - if(mod(global_nx, left_right_np) .ne. 0) then - do i = 1, mod(global_nx, left_right_np) - if(left_right_p .eq. i ) then - local_nx = local_nx + 1 - end if - end do - end if - - local_ny = int(global_ny / up_down_np) - !if(global_ny .ne. (local_ny * up_down_np) ) then - if(mod(global_ny,up_down_np) .ne. 0 ) then - do i = 1, mod(global_ny,up_down_np) - if( up_down_p .eq. i) then - local_ny = local_ny + 1 - end if - end do - end if - - local_rt_nx=local_nx*AGGFACTRT+2 - local_rt_ny=local_ny*AGGFACTRT+2 - if(left_id.lt.0) local_rt_nx = local_rt_nx -1 - if(right_id.lt.0) local_rt_nx = local_rt_nx -1 - if(up_id.lt.0) local_rt_ny = local_rt_ny -1 - if(down_id.lt.0) local_rt_ny = local_rt_ny -1 - - call get_local_size(local_nx, local_ny,local_rt_nx,local_rt_ny) - call calculate_start_p() - - in_global_nx = local_nx - in_global_ny = local_ny -#ifdef HYDRO_D - write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_nx - write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_ny - write(6,*) "my_id=",my_id,"global_nx=",global_nx - write(6,*) "my_id=",my_id,"global_nx=",global_ny -#endif - return - end subroutine MPP_LAND_PAR_INI - - subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) -! ### Communicate message on left right direction. - integer NX,NY - real in_out_data(nx,ny),data_r(2,ny) - integer count,size,tag, ierr - integer flag ! 99 replace the boundary, else get the sum. - - if(flag .eq. 99) then ! replace the data - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = ny - call mpi_send(in_out_data(nx-1,:),size,MPI_REAL, & - right_id,tag,MPI_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = ny - call mpi_recv(in_out_data(1,:),size,MPI_REAL, & - left_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = ny - tag = 21 - call mpi_send(in_out_data(2,:),size,MPI_REAL, & - left_id,tag,MPI_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = ny - call mpi_recv(in_out_data(nx,:),size,MPI_REAL,& - right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - - else ! get the sum - - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = 2*ny - call mpi_send(in_out_data(nx-1:nx,:),size,MPI_REAL, & - right_id,tag,MPI_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = 2*ny - call mpi_recv(data_r,size,MPI_REAL,left_id,tag, & - MPI_COMM_WORLD,mpp_status,ierr) - in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) - in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = 2*ny - tag = 21 - call mpi_send(in_out_data(1:2,:),size,MPI_REAL, & - left_id,tag,MPI_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = 2*ny - call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_REAL,& - right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - endif ! end if black for flag. - - return - end subroutine MPP_LAND_LR_COM - - subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) -! ### Communicate message on left right direction. - integer NX,NY - real*8 in_out_data(nx,ny),data_r(2,ny) - integer count,size,tag, ierr - integer flag ! 99 replace the boundary, else get the sum. - - if(flag .eq. 99) then ! replace the data - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = ny - call mpi_send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION, & - right_id,tag,MPI_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = ny - call mpi_recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION, & - left_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = ny - tag = 21 - call mpi_send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION, & - left_id,tag,MPI_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = ny - call mpi_recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,& - right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - - else ! get the sum - - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = 2*ny - call mpi_send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION, & - right_id,tag,MPI_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = 2*ny - call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, & - MPI_COMM_WORLD,mpp_status,ierr) - in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) - in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = 2*ny - tag = 21 - call mpi_send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION, & - left_id,tag,MPI_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = 2*ny - call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,& - right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - endif ! end if black for flag. - - return - end subroutine MPP_LAND_LR_COM8 - - - subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) - integer local_nx, local_ny, rt_nx,rt_ny - integer i,status,ierr, tag - integer tmp_nx,tmp_ny -! ### if it is IO node, get the local_size of the x and y direction -! ### for all other tasks. - integer s_r(2) - -! if(my_id .eq. IO_id) then - allocate(local_nx_size(numprocs),stat = status) - allocate(local_ny_size(numprocs),stat = status) - allocate(local_rt_nx_size(numprocs),stat = status) - allocate(local_rt_ny_size(numprocs),stat = status) -! end if - - call mpp_land_sync() - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 1 - call mpi_recv(s_r,2,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - local_nx_size(i+1) = s_r(1) - local_ny_size(i+1) = s_r(2) - else - local_nx_size(i+1) = local_nx - local_ny_size(i+1) = local_ny - end if - end do - else - tag = 1 - s_r(1) = local_nx - s_r(2) = local_ny - call mpi_send(s_r,2,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 2 - call mpi_recv(s_r,2,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - local_rt_nx_size(i+1) = s_r(1) - local_rt_ny_size(i+1) = s_r(2) - else - local_rt_nx_size(i+1) = rt_nx - local_rt_ny_size(i+1) = rt_ny - end if - end do - else - tag = 2 - s_r(1) = rt_nx - s_r(2) = rt_ny - call mpi_send(s_r,2,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - call mpp_land_sync() - return - end subroutine get_local_size - - - subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) -! ### Communicate message on up down direction. - integer NX,NY - real in_out_data(nx,ny),data_r(nx,2) - integer count,size,tag, status, ierr - integer flag ! 99 replace the boundary , else get the sum of the boundary - - - if(flag .eq. 99) then ! replace the boundary data. - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx - call mpi_send(in_out_data(:,ny-1),size,MPI_REAL, & - up_id,tag,MPI_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx - call mpi_recv(in_out_data(:,1),size,MPI_REAL, & - down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx - call mpi_send(in_out_data(:,2),size,MPI_REAL, & - down_id,tag,MPI_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx - call mpi_recv(in_out_data(:,ny),size,MPI_REAL, & - up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - - else ! flag = 1 - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx*2 - call mpi_send(in_out_data(:,ny-1:ny),size,MPI_REAL, & - up_id,tag,MPI_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx*2 - call mpi_recv(data_r,size,MPI_REAL, & - down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) - in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx*2 - call mpi_send(in_out_data(:,1:2),size,MPI_REAL, & - down_id,tag,MPI_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx * 2 - call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_REAL, & - up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - endif ! end of block flag - return - end subroutine MPP_LAND_UB_COM - - subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) -! ### Communicate message on up down direction. - integer NX,NY - real*8 in_out_data(nx,ny),data_r(nx,2) - integer count,size,tag, status, ierr - integer flag ! 99 replace the boundary , else get the sum of the boundary - - - if(flag .eq. 99) then ! replace the boundary data. - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx - call mpi_send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION, & - up_id,tag,MPI_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx - call mpi_recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, & - down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx - call mpi_send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION, & - down_id,tag,MPI_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx - call mpi_recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, & - up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - - else ! flag = 1 - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx*2 - call mpi_send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & - up_id,tag,MPI_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx*2 - call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION, & - down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) - in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx*2 - call mpi_send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION, & - down_id,tag,MPI_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx * 2 - call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & - up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - endif ! end of block flag - return - end subroutine MPP_LAND_UB_COM8 - - subroutine calculate_start_p() -! calculate startx and starty - integer :: i,status, ierr, tag - integer :: r_s(2) - integer :: t_nx, t_ny - - allocate(starty(numprocs),stat = ierr) - allocate(startx(numprocs),stat = ierr) - - local_startx = int(global_nx/left_right_np) * left_right_p+1 - local_starty = int(global_ny/up_down_np) * up_down_p+1 - -!ywold - t_nx = 0 - do i = 1, mod(global_nx,left_right_np) - if(left_right_p .gt. i ) then - t_nx = t_nx + 1 - end if - end do - local_startx = local_startx + t_nx - - t_ny = 0 - do i = 1, mod(global_ny,up_down_np) - if( up_down_p .gt. i) then - t_ny = t_ny + 1 - end if - end do - local_starty = local_starty + t_ny - - - if(left_id .lt. 0) local_startx = 1 - if(down_id .lt. 0) local_starty = 1 - - - if(my_id .eq. IO_id) then - startx(my_id+1) = local_startx - starty(my_id+1) = local_starty - end if - - r_s(1) = local_startx - r_s(2) = local_starty - call mpp_land_sync() - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ! block receive from other node. - if(i.ne.my_id) then - tag = 1 - call mpi_recv(r_s,2,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - startx(i+1) = r_s(1) - starty(i+1) = r_s(2) - end if - end do - else - tag = 1 - call mpi_send(r_s,2,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - - call mpp_land_sync() - - return - end subroutine calculate_start_p - - subroutine decompose_data_real3d (in_buff,out_buff,klevel) - implicit none - integer:: klevel, k - real in_buff(global_nx,1:klevel,global_ny),out_buff(local_nx,1:klevel,local_ny) - do k = 1, klevel - call decompose_data_real(in_buff(:,k,:),out_buff(:,k,:)) - end do - end subroutine decompose_data_real3d - - - subroutine decompose_data_real (in_buff,out_buff) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - real in_buff(global_nx,global_ny),out_buff(local_nx,local_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = local_nx_size(i+1)*local_ny_size(i+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL, i,tag,MPI_COMM_WORLD,ierr) - end if - end do - else - size = local_nx*local_ny - call mpi_recv(out_buff,size,MPI_REAL,IO_id, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_data_real - - subroutine decompose_data_int (in_buff,out_buff) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - integer in_buff(global_nx,global_ny),out_buff(local_nx,local_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = local_nx_size(i+1)*local_ny_size(i+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER, i,tag,MPI_COMM_WORLD,ierr) - end if - end do - else - size = local_nx*local_ny - call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_data_int - - subroutine write_IO_int(in_buff,out_buff) -! the IO node will receive the data from the rest process. - integer in_buff(1:local_nx,1:local_ny), & - out_buff(global_nx,global_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_nx*local_ny - tag = 2 - call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_nx_size(i+1)*local_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_int - - subroutine write_IO_real3d(in_buff,out_buff,klevel) - implicit none -! the IO node will receive the data from the rest process. - integer klevel, k - real in_buff(1:local_nx,1:klevel,1:local_ny), & - out_buff(global_nx,1:klevel,global_ny) - do k = 1, klevel - call write_IO_real(in_buff(:,k,:),out_buff(:,k,:)) - end do - end subroutine write_IO_real3d - - subroutine write_IO_real(in_buff,out_buff) -! the IO node will receive the data from the rest process. - real in_buff(1:local_nx,1:local_ny), & - out_buff(global_nx,global_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_nx*local_ny - tag = 2 - call mpi_send(in_buff,size,MPI_REAL, IO_id, & - tag,MPI_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_nx_size(i+1)*local_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL,i,tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_real - - subroutine write_IO_RT_real(in_buff,out_buff) -! the IO node will receive the data from the rest process. - real in_buff(1:local_rt_nx,1:local_rt_ny), & - out_buff(global_rt_nx,global_rt_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_rt_nx*local_rt_ny - tag = 2 - call mpi_send(in_buff,size,MPI_REAL, IO_id, & - tag,MPI_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL,i,tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_RT_real - - - subroutine write_IO_RT_int (in_buff,out_buff) -! the IO node will receive the data from the rest process. - integer :: in_buff(1:local_rt_nx,1:local_rt_ny), & - out_buff(global_rt_nx,global_rt_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_rt_nx*local_rt_ny - tag = 2 - call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_RT_int - - subroutine mpp_land_sync() - integer ierr - call MPI_barrier( MPI_COMM_WORLD ,ierr) - return - end subroutine mpp_land_sync - -! subroutine mpp_land_sync() -! integer tag, i, status, ierr,size -! integer buff(2) -! -! size =2 -! buff = 3 -! if(my_id .ne. IO_id) then -! tag = 2 -! call mpi_send(buff,size,MPI_INTEGER, IO_id, & -! tag,MPI_COMM_WORLD,ierr) -! else -! do i = 0, numprocs - 1 -! tag = 2 -! if(i .ne. IO_id) then -! call mpi_recv(buff,size,& -! MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr) -! end if -! end do -! end if - -! return -! end subroutine mpp_land_sync - - - subroutine mpp_land_bcast_int(size,inout) - integer size - integer inout(size) - integer ierr - call mpi_bcast(inout,size,MPI_INTEGER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int - - subroutine mpp_land_bcast_int1d(inout) - integer len - integer inout(:) - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_INTEGER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int1d - - subroutine mpp_land_bcast_int1(inout) - integer inout - integer ierr - call mpi_bcast(inout,1,MPI_INTEGER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int1 - - subroutine mpp_land_bcast_logical(inout) - logical :: inout - integer ierr - call mpi_bcast(inout,1,MPI_LOGICAL, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_logical - - subroutine mpp_land_bcast_real1(inout) - real inout - integer ierr - call mpi_bcast(inout,1,MPI_REAL, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real1 - - subroutine mpp_land_bcast_real_1d(inout) - integer len - real inout(:) - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_real, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real_1d - - subroutine mpp_land_bcast_real(size,inout) - integer size - real inout(size) - integer ierr - call mpi_bcast(inout,size,MPI_real, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real - - subroutine mpp_land_bcast_int2d(inout) - integer length1, k,length2 - integer inout(:,:) - integer ierr - length1 = size(inout,1) - length2 = size(inout,2) - do k = 1, length2 - call mpi_bcast(inout(:,k),length1,MPI_INTEGER, & - IO_id,MPI_COMM_WORLD,ierr) - end do - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int2d - - subroutine mpp_land_bcast_real2(inout) - integer length1, k,length2 - real inout(:,:) - integer ierr - length1 = size(inout,1) - length2 = size(inout,2) - do k = 1, length2 - call mpi_bcast(inout(:,k),length1,MPI_real, & - IO_id,MPI_COMM_WORLD,ierr) - end do - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real2 - - subroutine mpp_land_bcast_rd(size,inout) - integer size - real*8 inout(size) - integer ierr - call mpi_bcast(inout,size,MPI_REAL8, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_rd - - subroutine mpp_land_bcast_char(size,inout) - integer size - character inout(*) - integer ierr - call mpi_bcast(inout,size,MPI_CHARACTER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_char - - subroutine mpp_land_bcast_char1d(inout) - integer len - character inout(:) - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_CHARACTER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_char1d - - subroutine mpp_land_bcast_char1(inout) - integer len - character(len=*) inout - integer ierr - len = LEN_TRIM(inout) - call mpi_bcast(inout,len,MPI_CHARACTER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_char1 - - - subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag) -! ### Communicate message on left right and up bottom directions. - integer NX,NY - integer flag != 99 test only for land model. (replace the boundary). - != 1 get the sum of the boundary value. - real in_out_data(nx,ny) - - call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) - call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) - - return - end subroutine MPP_LAND_COM_REAL - - subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag) -! ### Communicate message on left right and up bottom directions. - integer NX,NY - integer flag != 99 test only for land model. (replace the boundary). - != 1 get the sum of the boundary value. - real*8 in_out_data(nx,ny) - - call MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) - call MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) - - return - end subroutine MPP_LAND_COM_REAL8 - - subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag) -! ### Communicate message on left right and up bottom directions. - integer NX,NY - integer flag != 99 test only for land model. (replace the boundary). - != 1 get the sum of the boundary value. - integer data(nx,ny) - real in_out_data(nx,ny) - - in_out_data = data + 0.0 - call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) - call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) - data = in_out_data + 0 - - return - end subroutine MPP_LAND_COM_INTEGER - - subroutine read_restart_3(unit,nz,out) - integer unit,nz,i - real buf3(global_nx,global_ny,nz),& - out(local_nx,local_ny,3) - if(my_id.eq.IO_id) read(unit) buf3 - do i = 1,nz - call decompose_data_real (buf3(:,:,i),out(:,:,i)) - end do - return - end subroutine read_restart_3 - - subroutine read_restart_2(unit,out) - integer unit,ierr2 - real buf2(global_nx,global_ny),& - out(local_nx,local_ny) - - if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 - call mpp_land_bcast_int1(ierr2) - if(ierr2 .ne. 0) return - - call decompose_data_real (buf2,out) - return - end subroutine read_restart_2 - - subroutine read_restart_rt_2(unit,out) - integer unit,ierr2 - real buf2(global_rt_nx,global_rt_ny),& - out(local_rt_nx,local_rt_ny) - - if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 - call mpp_land_bcast_int1(ierr2) - if(ierr2.ne.0) return - - call decompose_RT_real(buf2,out, & - global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) - return - end subroutine read_restart_rt_2 - - subroutine read_restart_rt_3(unit,nz,out) - integer unit,nz,i,ierr2 - real buf3(global_rt_nx,global_rt_ny,nz),& - out(local_rt_nx,local_rt_ny,3) - - if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf3 - call mpp_land_bcast_int1(ierr2) - if(ierr2.ne.0) return - - do i = 1,nz - call decompose_RT_real (buf3(:,:,i),out(:,:,i),& - global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) - end do - return - end subroutine read_restart_rt_3 - - subroutine write_restart_3(unit,nz,in) - integer unit,nz,i - real buf3(global_nx,global_ny,nz),& - in(local_nx,local_ny,nz) - do i = 1,nz - call write_IO_real(in(:,:,i),buf3(:,:,i)) - end do - if(my_id.eq.IO_id) write(unit) buf3 - return - end subroutine write_restart_3 - - subroutine write_restart_2(unit,in) - integer unit - real buf2(global_nx,global_ny),& - in(local_nx,local_ny) - call write_IO_real(in,buf2) - if(my_id.eq.IO_id) write(unit) buf2 - return - end subroutine write_restart_2 - - subroutine write_restart_rt_2(unit,in) - integer unit - real buf2(global_rt_nx,global_rt_ny), & - in(local_rt_nx,local_rt_ny) - call write_IO_RT_real(in,buf2) - if(my_id.eq.IO_id) write(unit) buf2 - return - end subroutine write_restart_rt_2 - - subroutine write_restart_rt_3(unit,nz,in) - integer unit,nz,i - real buf3(global_rt_nx,global_rt_ny,nz),& - in(local_rt_nx,local_rt_ny,nz) - do i = 1,nz - call write_IO_RT_real(in(:,:,i),buf3(:,:,i)) - end do - if(my_id.eq.IO_id) write(unit) buf3 - return - end subroutine write_restart_rt_3 - - subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - integer g_nx,g_ny,nx,ny - real in_buff(g_nx,g_ny),out_buff(nx,ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL, i,tag,MPI_COMM_WORLD,ierr) - end if - end do - else - size = nx*ny - call mpi_recv(out_buff,size,MPI_REAL,IO_id, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_RT_real - - subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - integer g_nx,g_ny,nx,ny - integer in_buff(g_nx,g_ny),out_buff(nx,ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - call mpp_land_sync() - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER, i,tag,MPI_COMM_WORLD,ierr) - end if - end do - else - size = nx*ny - call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_RT_int - - subroutine getNX_NY(nprocs, nx,ny) - ! calculate the nx and ny based on the total nprocs. - integer nprocs, nx, ny - integer i,j, max - max = nprocs - do j = 1, nprocs - if( mod(nprocs,j) .eq. 0 ) then - i = nprocs/j - if( abs(i-j) .lt. max) then - max = abs(i-j) - nx = i - ny = j - end if - end if - end do - return - end subroutine getNX_NY - - subroutine pack_global_22(in, & - out,k) - integer ix,jx,k,i - real out(global_nx,global_ny,k) - real in(local_nx,local_ny,k) - do i = 1, k - call write_IO_real(in(:,:,i),out(:,:,i)) - enddo - return - end subroutine pack_global_22 - - - subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT) - implicit none - integer total_pe - integer info(9,total_pe),AGGFACTRT - integer :: ierr, status - integer i - - call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) - - if(numprocs .ne. total_pe) then - write(6,*) "Error: numprocs .ne. total_pe ",numprocs, total_pe - call mpp_land_abort() - endif - - -! ### get the neighbors. -1 means no neighbor. - left_id = info(2,my_id+1) - right_id = info(3,my_id+1) - up_id = info(4,my_id+1) - down_id = info(5,my_id+1) - IO_id = 0 - - allocate(local_nx_size(numprocs),stat = status) - allocate(local_ny_size(numprocs),stat = status) - allocate(local_rt_nx_size(numprocs),stat = status) - allocate(local_rt_ny_size(numprocs),stat = status) - allocate(starty(numprocs),stat = ierr) - allocate(startx(numprocs),stat = ierr) - - i = my_id + 1 - local_nx = info(7,i) - info(6,i) + 1 - local_ny = info(9,i) - info(8,i) + 1 - - global_nx = 0 - global_ny = 0 - do i = 1, numprocs - global_nx = max(global_nx,info(7,i)) - global_ny = max(global_ny,info(9,i)) - enddo - - local_rt_nx = local_nx*AGGFACTRT+2 - local_rt_ny = local_ny*AGGFACTRT+2 - if(left_id.lt.0) local_rt_nx = local_rt_nx -1 - if(right_id.lt.0) local_rt_nx = local_rt_nx -1 - if(up_id.lt.0) local_rt_ny = local_rt_ny -1 - if(down_id.lt.0) local_rt_ny = local_rt_ny -1 - - global_rt_nx = global_nx*AGGFACTRT - global_rt_ny = global_ny*AGGFACTRT - rt_AGGFACTRT = AGGFACTRT - - do i =1,numprocs - local_nx_size(i) = info(7,i) - info(6,i) + 1 - local_ny_size(i) = info(9,i) - info(8,i) + 1 - startx(i) = info(6,i) - starty(i) = info(8,i) - - local_rt_nx_size(i) = (info(7,i) - info(6,i) + 1)*AGGFACTRT+2 - local_rt_ny_size(i) = (info(9,i) - info(8,i) + 1 )*AGGFACTRT+2 - if(info(2,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 - if(info(3,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 - if(info(4,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 - if(info(5,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 - enddo - return - end subroutine wrf_LAND_set_INIT - - subroutine getMy_global_id() - integer ierr - call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) - return - end subroutine getMy_global_id - - subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag) - ! communicate the data for channel routine. - implicit none - integer ix,jy,size - integer Link_location(ix,jy) - integer i,j, flag - real Link_V(size), tmp_inout(ix,jy) - - tmp_inout = -999 - - if(size .eq. 0) then - tmp_inout = -999 - else - - ! map the Link_V data to tmp_inout(ix,jy) - do i = 1,ix - if(Link_location(i,1) .gt. 0) & - tmp_inout(i,1) = Link_V(Link_location(i,1)) - if(Link_location(i,2) .gt. 0) & - tmp_inout(i,2) = Link_V(Link_location(i,2)) - if(Link_location(i,jy-1) .gt. 0) & - tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) - if(Link_location(i,jy) .gt. 0) & - tmp_inout(i,jy) = Link_V(Link_location(i,jy)) - enddo - do j = 1,jy - if(Link_location(1,j) .gt. 0) & - tmp_inout(1,j) = Link_V(Link_location(1,j)) - if(Link_location(2,j) .gt. 0) & - tmp_inout(2,j) = Link_V(Link_location(2,j)) - if(Link_location(ix-1,j) .gt. 0) & - tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) - if(Link_location(ix,j) .gt. 0) & - tmp_inout(ix,j) = Link_V(Link_location(ix,j)) - enddo - endif - -! commu nicate tmp_inout - call MPP_LAND_COM_REAL(tmp_inout, ix,jy,flag) - -!map the data back to Link_V - if(size .eq. 0) return - do j = 1,jy - if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & - Link_V(Link_location(1,j)) = tmp_inout(1,j) - if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & - Link_V(Link_location(2,j)) = tmp_inout(2,j) - if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & - Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) - if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& - Link_V(Link_location(ix,j)) = tmp_inout(ix,j) - enddo - do i = 1,ix - if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& - Link_V(Link_location(i,1)) = tmp_inout(i,1) - if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& - Link_V(Link_location(i,2)) = tmp_inout(i,2) - if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & - Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) - if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & - Link_V(Link_location(i,jy)) = tmp_inout(i,jy) - enddo - end subroutine MPP_CHANNEL_COM_REAL - - subroutine MPP_CHANNEL_COM_INT(Link_location,ix,jy,Link_V,size,flag) - ! communicate the data for channel routine. - implicit none - integer ix,jy,size - integer Link_location(ix,jy) - integer i,j, flag - integer Link_V(size), tmp_inout(ix,jy) - - if(size .eq. 0) then - tmp_inout = -999 - else - - ! map the Link_V data to tmp_inout(ix,jy) - do i = 1,ix - if(Link_location(i,1) .gt. 0) & - tmp_inout(i,1) = Link_V(Link_location(i,1)) - if(Link_location(i,2) .gt. 0) & - tmp_inout(i,2) = Link_V(Link_location(i,2)) - if(Link_location(i,jy-1) .gt. 0) & - tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) - if(Link_location(i,jy) .gt. 0) & - tmp_inout(i,jy) = Link_V(Link_location(i,jy)) - enddo - do j = 1,jy - if(Link_location(1,j) .gt. 0) & - tmp_inout(1,j) = Link_V(Link_location(1,j)) - if(Link_location(2,j) .gt. 0) & - tmp_inout(2,j) = Link_V(Link_location(2,j)) - if(Link_location(ix-1,j) .gt. 0) & - tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) - if(Link_location(ix,j) .gt. 0) & - tmp_inout(ix,j) = Link_V(Link_location(ix,j)) - enddo - endif - -! commu nicate tmp_inout - call MPP_LAND_COM_INTEGER(tmp_inout, ix,jy,flag) - -!map the data back to Link_V - if(size .eq. 0) return - do j = 1,jy - if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & - Link_V(Link_location(1,j)) = tmp_inout(1,j) - if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & - Link_V(Link_location(2,j)) = tmp_inout(2,j) - if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & - Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) - if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& - Link_V(Link_location(ix,j)) = tmp_inout(ix,j) - enddo - do i = 1,ix - if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& - Link_V(Link_location(i,1)) = tmp_inout(i,1) - if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& - Link_V(Link_location(i,2)) = tmp_inout(i,2) - if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & - Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) - if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & - Link_V(Link_location(i,jy)) = tmp_inout(i,jy) - enddo - end subroutine MPP_CHANNEL_COM_INT - subroutine print_2(unit,in,fm) - integer unit - character(len=*) fm - real buf2(global_nx,global_ny),& - in(local_nx,local_ny) - call write_IO_real(in,buf2) - if(my_id.eq.IO_id) write(unit,*) buf2 - return - end subroutine print_2 - - subroutine print_rt_2(unit,in) - integer unit - real buf2(global_nx,global_ny),& - in(local_nx,local_ny) - call write_IO_real(in,buf2) - if(my_id.eq.IO_id) write(unit,*) buf2 - return - end subroutine print_rt_2 - - subroutine mpp_land_max_int1(v) - implicit none - integer v, r1, max - integer i, ierr, tag - if(my_id .eq. IO_id) then - max = v - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 101 - call mpi_recv(r1,1,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - if(max <= r1) max = r1 - end if - end do - else - tag = 101 - call mpi_send(v,1,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - call mpp_land_bcast_int1(max) - v = max - return - end subroutine mpp_land_max_int1 - - subroutine mpp_land_max_real1(v) - implicit none - real v, r1, max - integer i, ierr, tag - if(my_id .eq. IO_id) then - max = v - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 101 - call mpi_recv(r1,1,MPI_REAL,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - if(max <= r1) max = r1 - end if - end do - else - tag = 101 - call mpi_send(v,1,MPI_REAL, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - call mpp_land_bcast_real1(max) - v = max - return - end subroutine mpp_land_max_real1 - - subroutine mpp_same_int1(v) - implicit none - integer v,r1 - integer i, ierr, tag - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 109 - call mpi_recv(r1,1,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - if(v .ne. r1) v = -99 - end if - end do - else - tag = 109 - call mpi_send(v,1,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - call mpp_land_bcast_int1(v) - end subroutine mpp_same_int1 - - - - subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v) - implicit none - integer gnlinks,nlinks, map_l2g(nlinks),tmp_map(gnlinks) - real recv(nlinks), v(nlinks) - real g_v(gnlinks), tmp_v(gnlinks) - integer i, ierr, tag, k - integer length, node, message_len - - if(nlinks .le. 0) then - tmp_map = -999 - else - tmp_map(1:nlinks) = map_l2g(1:nlinks) - endif - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - message_len = mpp_nlinks(i+1) - if(i .ne. my_id) then - !block receive from other node. - - tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - tag = 119 - - call mpi_recv(tmp_v(1:message_len),message_len,MPI_REAL,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - - do k = 1,message_len - node = tmp_map(k) - if(node .gt. 0) then - g_v(node) = tmp_v(k) - else - write(6,*) "Maping infor k=",k," node=", node - endif - enddo - else - do k = 1,nlinks - node = map_l2g(k) - if(node .gt. 0) then - g_v(node) = v(k) - else - write(6,*) "local Maping infor k=",k," node=",node - endif - enddo - end if - - end do - else - tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - tag = 119 - call mpi_send(v,nlinks,MPI_REAL,IO_id, & - tag,MPI_COMM_WORLD,ierr) - - end if - end subroutine write_chanel_real - - subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v) - implicit none - integer gnlinks,nlinks, map_l2g(nlinks),tmp_map(gnlinks) - integer :: recv(nlinks), v(nlinks) - integer :: g_v(gnlinks), tmp_v(gnlinks) - integer i, ierr, tag, k - integer length, node, message_len - - if(nlinks .le. 0) then - tmp_map = -999 - else - tmp_map(1:nlinks) = map_l2g(1:nlinks) - endif - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - message_len = mpp_nlinks(i+1) - if(i .ne. my_id) then - !block receive from other node. - - tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - tag = 119 - - call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - - do k = 1,message_len - if(tmp_map(k) .gt. 0) then - node = tmp_map(k) - g_v(node) = tmp_v(k) - else - write(6,*) "Maping infor k=",k," node=",tmp_v(k) - endif - enddo - else - do k = 1,nlinks - if(map_l2g(k) .gt. 0) then - node = map_l2g(k) - g_v(node) = v(k) - else - write(6,*) "Maping infor k=",k," node=",map_l2g(k) - endif - enddo - end if - - end do - else - tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - tag = 119 - call mpi_send(v,nlinks,MPI_INTEGER,IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - end subroutine write_chanel_int - - - - subroutine write_lake_real(v,nodelist_in,nlakes) - implicit none - real recv(nlakes), v(nlakes) - integer nodelist(nlakes), nlakes, nodelist_in(nlakes) - integer i, ierr, tag, k - integer length, node - - nodelist = nodelist_in - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 129 - call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - tag = 139 - call mpi_recv(recv(:),nlakes,MPI_REAL,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - - do k = 1,nlakes - if(nodelist(k) .gt. -99) then - node = nodelist(k) - v(node) = recv(node) - endif - enddo - end if - - end do - else - tag = 129 - call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - tag = 139 - call mpi_send(v,nlakes,MPI_REAL,IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - end subroutine write_lake_real - - subroutine read_rst_crt_r(unit,out,size) - implicit none - integer unit, size, ierr,ierr2 - real out(size),out1(size) - if(my_id.eq.IO_id) then - read(unit,IOSTAT=ierr2,end=99) out1 - if(ierr2.eq.0) out=out1 - endif -99 continue - call mpp_land_bcast_int1(ierr2) - if(ierr2 .ne. 0) return - call mpi_bcast(out,size,MPI_REAL, & - IO_id,MPI_COMM_WORLD,ierr) - return - end subroutine read_rst_crt_r - - subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks) - integer :: unit,gnlinks,nlinks,map_l2g(nlinks) - real cd(nlinks) - real g_cd (gnlinks) - call write_chanel_real(cd,map_l2g,gnlinks,nlinks, g_cd) - write(unit) g_cd - return - end subroutine write_rst_crt_r - - subroutine sum_real8(vin,nsize) - implicit none - integer nsize,i,j,tag,ierr - real*8, dimension(nsize):: vin,recv - real, dimension(nsize):: v - tag = 319 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_DOUBLE_PRECISION,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - vin(:) = vin(:) + recv(:) - endif - end do - v = vin - else - call mpi_send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id, & - tag,MPI_COMM_WORLD,ierr) - endif - call mpp_land_bcast_real(nsize,v) - vin = v - return - end subroutine sum_real8 - -! subroutine get_globalDim(ix,g_ix) -! implicit none -! integer ix,g_ix, ierr -! include "mpif.h" -! -! if ( my_id .eq. IO_id ) then -! g_ix = ix -! call mpi_reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, & -! MPI_SUM, 0, MPI_COMM_WORLD, ierr ) -! else -! call mpi_reduce( ix, 0, 4, MPI_INTEGER, & -! MPI_SUM, 0, MPI_COMM_WORLD, ierr ) -! endif -! call mpp_land_bcast_int1(g_ix) -! -! return -! -! end subroutine get_globalDim - - subroutine gather_1d_real_tmp(vl,s_in,e_in,vg,sg) - integer sg, s,e, size, s_in, e_in - integer index_s(2) - integer tag, ierr,i -! s: start index, e: end index - real vl(e_in-s_in+1), vg(sg) - s = s_in - e = e_in - - if(my_id .eq. IO_id) then - vg(s:e) = vl - end if - - index_s(1) = s - index_s(2) = e - size = e - s + 1 - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 202 - call mpi_recv(index_s,2,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - - tag = 203 - e = index_s(2) - s = index_s(1) - size = e - s + 1 - call mpi_recv(vg(s:e),size,MPI_REAL, & - i,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - end do - else - tag = 202 - call mpi_send(index_s,2,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - - tag = 203 - call mpi_send(vl,size,MPI_REAL,IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - - return - end subroutine gather_1d_real_tmp - - subroutine sum_double(inout) - implicit none - real*8:: inout, send - integer :: ierr - send = inout - !yw CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,ierr) - CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr) - end subroutine sum_double - - subroutine mpp_chrt_nlinks_collect(nlinks) - ! collect the nlinks - implicit none - integer :: nlinks - integer :: i, ierr, status, tag - allocate(mpp_nlinks(numprocs),stat = status) - tag = 138 - mpp_nlinks = 0 - if(my_id .eq. IO_id) then - do i = 0,numprocs -1 - if(i .ne. my_id) then - call mpi_recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - else - mpp_nlinks(i+1) = 0 - end if - end do - else - call mpi_send(nlinks,1,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - endif - - - end subroutine mpp_chrt_nlinks_collect - - subroutine getLocalXY(ix,jx,startx,starty,endx,endy) -!!! this is for NoahMP only - implicit none - integer:: ix,jx,startx,starty,endx,endy - startx = local_startx - starty = local_starty - endx = startx + ix -1 - endy = starty + jx -1 - end subroutine getLocalXY - - subroutine check_landreal1(unit, inVar) - implicit none - integer :: unit - real :: inVar - if(my_id .eq. IO_id) then - write(unit,*) inVar - flush(unit) - endif - end subroutine check_landreal1 - - subroutine check_landreal1d(unit, inVar) - implicit none - integer :: unit - real :: inVar(:) - if(my_id .eq. IO_id) then - write(unit,*) inVar - flush(unit) - endif - end subroutine check_landreal1d - subroutine check_landreal2d(unit, inVar) - implicit none - integer :: unit - real :: inVar(:,:) - real :: g_var(global_nx,global_ny) - call write_io_real(inVar,g_var) - if(my_id .eq. IO_id) then - write(unit,*) g_var - flush(unit) - endif - end subroutine check_landreal2d - - subroutine check_landreal3d(unit, inVar) - implicit none - integer :: unit, k, klevel - real :: inVar(:,:,:) - real :: g_var(global_nx,global_ny) - klevel = size(inVar,2) - do k = 1, klevel - call write_io_real(inVar(:,k,:),g_var) - if(my_id .eq. IO_id) then - write(unit,*) g_var - flush(unit) - endif - end do - end subroutine check_landreal3d - -END MODULE MODULE_MPP_LAND - - subroutine mpp_land_abort() - implicit none - include "mpif.h" - integer ierr - CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) - end ! mpp_land_abort - - subroutine mpp_land_sync() - implicit none - include "mpif.h" - integer ierr - call MPI_barrier( MPI_COMM_WORLD ,ierr) - if(ierr .ne. 0) call mpp_land_abort() - return - end ! mpp_land_sync - - - - diff --git a/wrfv2_fire/hydro/MPP/CPL_WRF.F b/wrfv2_fire/hydro/MPP/CPL_WRF.F deleted file mode 100644 index 45876b9b..00000000 --- a/wrfv2_fire/hydro/MPP/CPL_WRF.F +++ /dev/null @@ -1,159 +0,0 @@ -! This is used as a coupler with the WRF model. -MODULE MODULE_CPL_LAND - - - IMPLICIT NONE - - integer my_global_id - - integer total_pe_num - integer global_ix,global_jx - - integer,allocatable,dimension(:,:) :: node_info - - logical initialized, cpl_land, time_step_read_rstart, & - time_step_write_rstart, time_step_output - character(len=19) cpl_outdate, cpl_rstdate - - - - contains - - subroutine CPL_LAND_INIT(istart,iend,jstart,jend) - implicit none - include "mpif.h" - integer ierr - logical mpi_inited - integer istart,iend,jstart,jend - - CALL mpi_initialized( mpi_inited, ierr ) - if ( .NOT. mpi_inited ) then - call mpi_init(ierr) - endif - - call MPI_COMM_RANK( MPI_COMM_WORLD, my_global_id, ierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, total_pe_num, ierr ) - - allocate(node_info(9,total_pe_num)) - - node_info = -99 - -! send node info to node 0 - node_info(1,my_global_id+1) = total_pe_num - node_info(6,my_global_id+1) = istart - node_info(7,my_global_id+1) = iend - node_info(8,my_global_id+1) = jstart - node_info(9,my_global_id+1) = jend - - - call send_info() - call find_left() - call find_right() - call find_up() - call find_down() - - call send_info() - - initialized = .false. ! land model need to be initialized. - return - END subroutine CPL_LAND_INIT - - subroutine send_info() - implicit none - include "mpif.h" - integer,allocatable,dimension(:,:) :: tmp_info - integer ierr, i,size, tag - integer mpp_status(MPI_STATUS_SIZE) - tag = 9 - size = 9 - - if(my_global_id .eq. 0) then - do i = 1, total_pe_num-1 - call mpi_recv(node_info(:,i+1),size,MPI_INTEGER, & - i,tag,MPI_COMM_WORLD,mpp_status,ierr) - enddo - else - call mpi_send(node_info(:,my_global_id+1),size, & - MPI_INTEGER,0,tag,MPI_COMM_WORLD,ierr) - endif - - call MPI_barrier( MPI_COMM_WORLD ,ierr) - - size = 9 * total_pe_num - call mpi_bcast(node_info,size,MPI_INTEGER, & - 0,MPI_COMM_WORLD,ierr) - - call MPI_barrier( MPI_COMM_WORLD ,ierr) - - return - end subroutine send_info - - subroutine find_left() - implicit none - integer i - - node_info(2,my_global_id+1) = -1 - - do i = 1, total_pe_num - if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. & - (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. & - ((node_info(7,i)+1).eq.node_info(6,my_global_id+1)) ) then - node_info(2,my_global_id+1) = i - 1 - return - endif - end do - return - end subroutine find_left - - subroutine find_right() - implicit none - integer i - - node_info(3,my_global_id+1) = -1 - - do i = 1, total_pe_num - if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. & - (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. & - ((node_info(6,i)-1).eq.node_info(7,my_global_id+1)) ) then - node_info(3,my_global_id+1) = i - 1 - return - endif - end do - return - end subroutine find_right - - subroutine find_up() - implicit none - integer i - - node_info(4,my_global_id+1) = -1 - - do i = 1, total_pe_num - if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. & - (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. & - ((node_info(8,i)-1).eq.node_info(9,my_global_id+1)) ) then - node_info(4,my_global_id+1) = i - 1 - return - endif - end do - return - end subroutine find_up - - subroutine find_down() - implicit none - integer i - - node_info(5,my_global_id+1) = -1 - - do i = 1, total_pe_num - if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. & - (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. & - ((node_info(9,i)+1).eq.node_info(8,my_global_id+1)) ) then - node_info(5,my_global_id+1) = i - 1 - return - endif - end do - return - end subroutine find_down - -END MODULE MODULE_CPL_LAND diff --git a/wrfv2_fire/hydro/MPP/Makefile b/wrfv2_fire/hydro/MPP/Makefile deleted file mode 100644 index abc0b055..00000000 --- a/wrfv2_fire/hydro/MPP/Makefile +++ /dev/null @@ -1,26 +0,0 @@ -# Makefile -# -.SUFFIXES: -.SUFFIXES: .o .F - -include ../macros - -OBJS = CPL_WRF.o mpp_land.o - -all: $(OBJS) -mpp_land.o: mpp_land.F - @echo "" - $(RMD) $(*).o $(*).mod $(*).stb *~ - $(COMPILER90) $(F90FLAGS) -c $(*).F - ar -r ../lib/libHYDRO.a $(@) - -CPL_WRF.o: CPL_WRF.F - @echo "" - $(RMD) $(*).o $(*).mod $(*).stb *~ *.f - $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f - $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f - - $(COMPILER90) $(F90FLAGS) -c $(*).F - ar -r ../lib/libHYDRO.a $(@) -clean: - $(RMD) *.o *.mod *.stb *~ diff --git a/wrfv2_fire/hydro/MPP/mpp_land.F b/wrfv2_fire/hydro/MPP/mpp_land.F deleted file mode 100644 index e3935c3c..00000000 --- a/wrfv2_fire/hydro/MPP/mpp_land.F +++ /dev/null @@ -1,1876 +0,0 @@ -!#### This is a module for parallel Land model. -MODULE MODULE_MPP_LAND - - use MODULE_CPL_LAND - - IMPLICIT NONE - include "mpif.h" - integer, public :: left_id,right_id,up_id,down_id,my_id - integer, public :: left_right_np,up_down_np ! define total process in two dimensions. - integer, public :: left_right_p ,up_down_p ! the position of the current process in the logical topography. - integer, public :: IO_id ! the number for IO. (Last processor for IO) - integer, public :: global_nx, global_ny, local_nx,local_ny - integer, public :: global_rt_nx, global_rt_ny - integer, public :: local_rt_nx,local_rt_ny,rt_AGGFACTRT - integer, public :: numprocs ! total process, get by mpi initialization. - integer :: local_startx, local_starty - - integer mpp_status(MPI_STATUS_SIZE) - - integer overlap_n - integer, allocatable, DIMENSION(:), public :: local_nx_size,local_ny_size - integer, allocatable, DIMENSION(:), public :: local_rt_nx_size,local_rt_ny_size - integer, allocatable, DIMENSION(:), public :: startx,starty - integer, allocatable, DIMENSION(:), public :: mpp_nlinks - - interface check_land - module procedure check_landreal1 - module procedure check_landreal1d - module procedure check_landreal2d - module procedure check_landreal3d - end interface - interface write_io_land - module procedure write_io_real3d - end interface - interface mpp_land_bcast - module procedure mpp_land_bcast_real2 - module procedure mpp_land_bcast_real_1d - module procedure mpp_land_bcast_real1 - module procedure mpp_land_bcast_char1d - module procedure mpp_land_bcast_char1 - module procedure mpp_land_bcast_int1 - module procedure mpp_land_bcast_int1d - module procedure mpp_land_bcast_int2d - module procedure mpp_land_bcast_logical - end interface - - contains - - subroutine LOG_MAP2d() - implicit none - integer :: ierr - call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) - - call getNX_NY(numprocs, left_right_np,up_down_np) - if(my_id.eq.IO_id) then -#ifdef HYDRO_D - write(6,*) "" - write(6,*) "total process:",numprocs - write(6,*) "left_right_np =", left_right_np,& - "up_down_np=",up_down_np -#endif - end if - -! ### get the row and column of the current process in the logical topography. -! ### left --> right, 0 -->left_right_np -1 -! ### up --> down, 0 --> up_down_np -1 - left_right_p = mod(my_id , left_right_np) - up_down_p = my_id / left_right_np - -! ### get the neighbors. -1 means no neighbor. - down_id = my_id - left_right_np - up_id = my_id + left_right_np - if( up_down_p .eq. 0) down_id = -1 - if( up_down_p .eq. (up_down_np-1) ) up_id = -1 - - left_id = my_id - 1 - right_id = my_id + 1 - if( left_right_p .eq. 0) left_id = -1 - if( left_right_p .eq. (left_right_np-1) ) right_id =-1 - -! ### the IO node is the last processor. -!yw IO_id = numprocs - 1 - IO_id = 0 - -! print the information for debug. - - call mpp_land_sync() - - return - end subroutine log_map2d -!old subroutine MPP_LAND_INIT(flag, ew_numprocs, sn_numprocs) - subroutine MPP_LAND_INIT() -! ### initialize the land model logically based on the two D method. -! ### Call this function directly if it is nested with WRF. - implicit none - integer :: ierr - integer :: ew_numprocs, sn_numprocs ! input the processors in x and y direction. - logical mpi_inited - -! left_right_np = ew_numprocs -! up_down_np = sn_numprocs - - CALL mpi_initialized( mpi_inited, ierr ) - if ( .NOT. mpi_inited ) then - call MPI_INIT( ierr ) ! stand alone land model. - else - call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) - return - endif -! create 2d logical mapping of the CPU. - call log_map2d() - - return - end subroutine MPP_LAND_INIT - - - subroutine MPP_LAND_PAR_INI(over_lap,in_global_nx,in_global_ny,AGGFACTRT) - integer in_global_nx,in_global_ny, AGGFACTRT - integer :: over_lap ! the overlaped grid number. (default is 1) - integer :: i - - global_nx = in_global_nx - global_ny = in_global_ny - rt_AGGFACTRT = AGGFACTRT - global_rt_nx = in_global_nx*AGGFACTRT - global_rt_ny = in_global_ny *AGGFACTRT - !overlap_n = 1 -!ywold local_nx = global_nx / left_right_np -!ywold if(left_right_p .eq. (left_right_np-1) ) then -!ywold local_nx = global_nx & -!ywold -int(global_nx/left_right_np)*(left_right_np-1) -!ywold end if -!ywold local_ny = global_ny / up_down_np -!ywold if( up_down_p .eq. (up_down_np-1) ) then -!ywold local_ny = global_ny & -!ywold -int(global_ny/up_down_np)*(up_down_np -1) -!ywold end if - - local_nx = int(global_nx / left_right_np) - !if(global_nx .ne. (local_nx*left_right_np) ) then - if(mod(global_nx, left_right_np) .ne. 0) then - do i = 1, mod(global_nx, left_right_np) - if(left_right_p .eq. i ) then - local_nx = local_nx + 1 - end if - end do - end if - - local_ny = int(global_ny / up_down_np) - !if(global_ny .ne. (local_ny * up_down_np) ) then - if(mod(global_ny,up_down_np) .ne. 0 ) then - do i = 1, mod(global_ny,up_down_np) - if( up_down_p .eq. i) then - local_ny = local_ny + 1 - end if - end do - end if - - local_rt_nx=local_nx*AGGFACTRT+2 - local_rt_ny=local_ny*AGGFACTRT+2 - if(left_id.lt.0) local_rt_nx = local_rt_nx -1 - if(right_id.lt.0) local_rt_nx = local_rt_nx -1 - if(up_id.lt.0) local_rt_ny = local_rt_ny -1 - if(down_id.lt.0) local_rt_ny = local_rt_ny -1 - - call get_local_size(local_nx, local_ny,local_rt_nx,local_rt_ny) - call calculate_start_p() - - in_global_nx = local_nx - in_global_ny = local_ny -#ifdef HYDRO_D - write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_nx - write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_ny - write(6,*) "my_id=",my_id,"global_nx=",global_nx - write(6,*) "my_id=",my_id,"global_nx=",global_ny -#endif - return - end subroutine MPP_LAND_PAR_INI - - subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag) -! ### Communicate message on left right direction. - integer NX,NY - real in_out_data(nx,ny),data_r(2,ny) - integer count,size,tag, ierr - integer flag ! 99 replace the boundary, else get the sum. - - if(flag .eq. 99) then ! replace the data - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = ny - call mpi_send(in_out_data(nx-1,:),size,MPI_REAL, & - right_id,tag,MPI_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = ny - call mpi_recv(in_out_data(1,:),size,MPI_REAL, & - left_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = ny - tag = 21 - call mpi_send(in_out_data(2,:),size,MPI_REAL, & - left_id,tag,MPI_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = ny - call mpi_recv(in_out_data(nx,:),size,MPI_REAL,& - right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - - else ! get the sum - - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = 2*ny - call mpi_send(in_out_data(nx-1:nx,:),size,MPI_REAL, & - right_id,tag,MPI_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = 2*ny - call mpi_recv(data_r,size,MPI_REAL,left_id,tag, & - MPI_COMM_WORLD,mpp_status,ierr) - in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) - in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = 2*ny - tag = 21 - call mpi_send(in_out_data(1:2,:),size,MPI_REAL, & - left_id,tag,MPI_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = 2*ny - call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_REAL,& - right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - endif ! end if black for flag. - - return - end subroutine MPP_LAND_LR_COM - - subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) -! ### Communicate message on left right direction. - integer NX,NY - real*8 in_out_data(nx,ny),data_r(2,ny) - integer count,size,tag, ierr - integer flag ! 99 replace the boundary, else get the sum. - - if(flag .eq. 99) then ! replace the data - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = ny - call mpi_send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION, & - right_id,tag,MPI_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = ny - call mpi_recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION, & - left_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = ny - tag = 21 - call mpi_send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION, & - left_id,tag,MPI_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = ny - call mpi_recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,& - right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - - else ! get the sum - - if(right_id .ge. 0) then ! ### send to right first. - tag = 11 - size = 2*ny - call mpi_send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION, & - right_id,tag,MPI_COMM_WORLD,ierr) - end if - if(left_id .ge. 0) then ! receive from left - tag = 11 - size = 2*ny - call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, & - MPI_COMM_WORLD,mpp_status,ierr) - in_out_data(1,:) = in_out_data(1,:) + data_r(1,:) - in_out_data(2,:) = in_out_data(2,:) + data_r(2,:) - endif - - if(left_id .ge. 0 ) then ! ### send to left second. - size = 2*ny - tag = 21 - call mpi_send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION, & - left_id,tag,MPI_COMM_WORLD,ierr) - endif - if(right_id .ge. 0) then ! receive from right - tag = 21 - size = 2*ny - call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,& - right_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - endif ! end if black for flag. - - return - end subroutine MPP_LAND_LR_COM8 - - - subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny) - integer local_nx, local_ny, rt_nx,rt_ny - integer i,status,ierr, tag - integer tmp_nx,tmp_ny -! ### if it is IO node, get the local_size of the x and y direction -! ### for all other tasks. - integer s_r(2) - -! if(my_id .eq. IO_id) then - allocate(local_nx_size(numprocs),stat = status) - allocate(local_ny_size(numprocs),stat = status) - allocate(local_rt_nx_size(numprocs),stat = status) - allocate(local_rt_ny_size(numprocs),stat = status) -! end if - - call mpp_land_sync() - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 1 - call mpi_recv(s_r,2,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - local_nx_size(i+1) = s_r(1) - local_ny_size(i+1) = s_r(2) - else - local_nx_size(i+1) = local_nx - local_ny_size(i+1) = local_ny - end if - end do - else - tag = 1 - s_r(1) = local_nx - s_r(2) = local_ny - call mpi_send(s_r,2,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 2 - call mpi_recv(s_r,2,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - local_rt_nx_size(i+1) = s_r(1) - local_rt_ny_size(i+1) = s_r(2) - else - local_rt_nx_size(i+1) = rt_nx - local_rt_ny_size(i+1) = rt_ny - end if - end do - else - tag = 2 - s_r(1) = rt_nx - s_r(2) = rt_ny - call mpi_send(s_r,2,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - call mpp_land_sync() - return - end subroutine get_local_size - - - subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag) -! ### Communicate message on up down direction. - integer NX,NY - real in_out_data(nx,ny),data_r(nx,2) - integer count,size,tag, status, ierr - integer flag ! 99 replace the boundary , else get the sum of the boundary - - - if(flag .eq. 99) then ! replace the boundary data. - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx - call mpi_send(in_out_data(:,ny-1),size,MPI_REAL, & - up_id,tag,MPI_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx - call mpi_recv(in_out_data(:,1),size,MPI_REAL, & - down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx - call mpi_send(in_out_data(:,2),size,MPI_REAL, & - down_id,tag,MPI_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx - call mpi_recv(in_out_data(:,ny),size,MPI_REAL, & - up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - - else ! flag = 1 - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx*2 - call mpi_send(in_out_data(:,ny-1:ny),size,MPI_REAL, & - up_id,tag,MPI_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx*2 - call mpi_recv(data_r,size,MPI_REAL, & - down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) - in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx*2 - call mpi_send(in_out_data(:,1:2),size,MPI_REAL, & - down_id,tag,MPI_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx * 2 - call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_REAL, & - up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - endif ! end of block flag - return - end subroutine MPP_LAND_UB_COM - - subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) -! ### Communicate message on up down direction. - integer NX,NY - real*8 in_out_data(nx,ny),data_r(nx,2) - integer count,size,tag, status, ierr - integer flag ! 99 replace the boundary , else get the sum of the boundary - - - if(flag .eq. 99) then ! replace the boundary data. - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx - call mpi_send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION, & - up_id,tag,MPI_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx - call mpi_recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, & - down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx - call mpi_send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION, & - down_id,tag,MPI_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx - call mpi_recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, & - up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - - else ! flag = 1 - - if(up_id .ge. 0 ) then ! ### send to up first. - tag = 31 - size = nx*2 - call mpi_send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & - up_id,tag,MPI_COMM_WORLD,ierr) - endif - if(down_id .ge. 0 ) then ! receive from down - tag = 31 - size = nx*2 - call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION, & - down_id,tag,MPI_COMM_WORLD, mpp_status,ierr) - in_out_data(:,1) = in_out_data(:,1) + data_r(:,1) - in_out_data(:,2) = in_out_data(:,2) + data_r(:,2) - endif - - if(down_id .ge. 0 ) then ! send down. - tag = 41 - size = nx*2 - call mpi_send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION, & - down_id,tag,MPI_COMM_WORLD,ierr) - endif - if(up_id .ge. 0 ) then ! receive from upper - tag = 41 - size = nx * 2 - call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, & - up_id,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - endif ! end of block flag - return - end subroutine MPP_LAND_UB_COM8 - - subroutine calculate_start_p() -! calculate startx and starty - integer :: i,status, ierr, tag - integer :: r_s(2) - integer :: t_nx, t_ny - - allocate(starty(numprocs),stat = ierr) - allocate(startx(numprocs),stat = ierr) - - local_startx = int(global_nx/left_right_np) * left_right_p+1 - local_starty = int(global_ny/up_down_np) * up_down_p+1 - -!ywold - t_nx = 0 - do i = 1, mod(global_nx,left_right_np) - if(left_right_p .gt. i ) then - t_nx = t_nx + 1 - end if - end do - local_startx = local_startx + t_nx - - t_ny = 0 - do i = 1, mod(global_ny,up_down_np) - if( up_down_p .gt. i) then - t_ny = t_ny + 1 - end if - end do - local_starty = local_starty + t_ny - - - if(left_id .lt. 0) local_startx = 1 - if(down_id .lt. 0) local_starty = 1 - - - if(my_id .eq. IO_id) then - startx(my_id+1) = local_startx - starty(my_id+1) = local_starty - end if - - r_s(1) = local_startx - r_s(2) = local_starty - call mpp_land_sync() - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ! block receive from other node. - if(i.ne.my_id) then - tag = 1 - call mpi_recv(r_s,2,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - startx(i+1) = r_s(1) - starty(i+1) = r_s(2) - end if - end do - else - tag = 1 - call mpi_send(r_s,2,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - - call mpp_land_sync() - - return - end subroutine calculate_start_p - - subroutine decompose_data_real3d (in_buff,out_buff,klevel) - implicit none - integer:: klevel, k - real in_buff(global_nx,1:klevel,global_ny),out_buff(local_nx,1:klevel,local_ny) - do k = 1, klevel - call decompose_data_real(in_buff(:,k,:),out_buff(:,k,:)) - end do - end subroutine decompose_data_real3d - - - subroutine decompose_data_real (in_buff,out_buff) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - real in_buff(global_nx,global_ny),out_buff(local_nx,local_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = local_nx_size(i+1)*local_ny_size(i+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL, i,tag,MPI_COMM_WORLD,ierr) - end if - end do - else - size = local_nx*local_ny - call mpi_recv(out_buff,size,MPI_REAL,IO_id, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_data_real - - subroutine decompose_data_int (in_buff,out_buff) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - integer in_buff(global_nx,global_ny),out_buff(local_nx,local_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = local_nx_size(i+1)*local_ny_size(i+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER, i,tag,MPI_COMM_WORLD,ierr) - end if - end do - else - size = local_nx*local_ny - call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_data_int - - subroutine write_IO_int(in_buff,out_buff) -! the IO node will receive the data from the rest process. - integer in_buff(1:local_nx,1:local_ny), & - out_buff(global_nx,global_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_nx*local_ny - tag = 2 - call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_nx_size(i+1)*local_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_int - - subroutine write_IO_real3d(in_buff,out_buff,klevel) - implicit none -! the IO node will receive the data from the rest process. - integer klevel, k - real in_buff(1:local_nx,1:klevel,1:local_ny), & - out_buff(global_nx,1:klevel,global_ny) - do k = 1, klevel - call write_IO_real(in_buff(:,k,:),out_buff(:,k,:)) - end do - end subroutine write_IO_real3d - - subroutine write_IO_real(in_buff,out_buff) -! the IO node will receive the data from the rest process. - real in_buff(1:local_nx,1:local_ny), & - out_buff(global_nx,global_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_nx*local_ny - tag = 2 - call mpi_send(in_buff,size,MPI_REAL, IO_id, & - tag,MPI_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1) - iend = startx(i+1)+local_nx_size(i+1) -1 - jbegin = starty(i+1) - jend = starty(i+1)+local_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_nx_size(i+1)*local_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL,i,tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_real - - subroutine write_IO_RT_real(in_buff,out_buff) -! the IO node will receive the data from the rest process. - real in_buff(1:local_rt_nx,1:local_rt_ny), & - out_buff(global_rt_nx,global_rt_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_rt_nx*local_rt_ny - tag = 2 - call mpi_send(in_buff,size,MPI_REAL, IO_id, & - tag,MPI_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL,i,tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_RT_real - - - subroutine write_IO_RT_int (in_buff,out_buff) -! the IO node will receive the data from the rest process. - integer :: in_buff(1:local_rt_nx,1:local_rt_ny), & - out_buff(global_rt_nx,global_rt_ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - if(my_id .ne. IO_id) then - size = local_rt_nx*local_rt_ny - tag = 2 - call mpi_send(in_buff,size,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - else - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - if(i .eq. IO_id) then - out_buff(ibegin:iend,jbegin:jend) = in_buff - else - size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1) - tag = 2 - call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - end do - end if - return - end subroutine write_IO_RT_int - - subroutine mpp_land_sync() - integer ierr - call MPI_barrier( MPI_COMM_WORLD ,ierr) - return - end subroutine mpp_land_sync - -! subroutine mpp_land_sync() -! integer tag, i, status, ierr,size -! integer buff(2) -! -! size =2 -! buff = 3 -! if(my_id .ne. IO_id) then -! tag = 2 -! call mpi_send(buff,size,MPI_INTEGER, IO_id, & -! tag,MPI_COMM_WORLD,ierr) -! else -! do i = 0, numprocs - 1 -! tag = 2 -! if(i .ne. IO_id) then -! call mpi_recv(buff,size,& -! MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr) -! end if -! end do -! end if - -! return -! end subroutine mpp_land_sync - - - subroutine mpp_land_bcast_int(size,inout) - integer size - integer inout(size) - integer ierr - call mpi_bcast(inout,size,MPI_INTEGER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int - - subroutine mpp_land_bcast_int1d(inout) - integer len - integer inout(:) - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_INTEGER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int1d - - subroutine mpp_land_bcast_int1(inout) - integer inout - integer ierr - call mpi_bcast(inout,1,MPI_INTEGER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int1 - - subroutine mpp_land_bcast_logical(inout) - logical :: inout - integer ierr - call mpi_bcast(inout,1,MPI_LOGICAL, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_logical - - subroutine mpp_land_bcast_real1(inout) - real inout - integer ierr - call mpi_bcast(inout,1,MPI_REAL, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real1 - - subroutine mpp_land_bcast_real_1d(inout) - integer len - real inout(:) - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_real, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real_1d - - subroutine mpp_land_bcast_real(size,inout) - integer size - real inout(size) - integer ierr - call mpi_bcast(inout,size,MPI_real, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real - - subroutine mpp_land_bcast_int2d(inout) - integer length1, k,length2 - integer inout(:,:) - integer ierr - length1 = size(inout,1) - length2 = size(inout,2) - do k = 1, length2 - call mpi_bcast(inout(:,k),length1,MPI_INTEGER, & - IO_id,MPI_COMM_WORLD,ierr) - end do - call mpp_land_sync() - return - end subroutine mpp_land_bcast_int2d - - subroutine mpp_land_bcast_real2(inout) - integer length1, k,length2 - real inout(:,:) - integer ierr - length1 = size(inout,1) - length2 = size(inout,2) - do k = 1, length2 - call mpi_bcast(inout(:,k),length1,MPI_real, & - IO_id,MPI_COMM_WORLD,ierr) - end do - call mpp_land_sync() - return - end subroutine mpp_land_bcast_real2 - - subroutine mpp_land_bcast_rd(size,inout) - integer size - real*8 inout(size) - integer ierr - call mpi_bcast(inout,size,MPI_REAL8, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_rd - - subroutine mpp_land_bcast_char(size,inout) - integer size - character inout(*) - integer ierr - call mpi_bcast(inout,size,MPI_CHARACTER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_char - - subroutine mpp_land_bcast_char1d(inout) - integer len - character inout(:) - integer ierr - len = size(inout,1) - call mpi_bcast(inout,len,MPI_CHARACTER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_char1d - - subroutine mpp_land_bcast_char1(inout) - integer len - character(len=*) inout - integer ierr - len = LEN_TRIM(inout) - call mpi_bcast(inout,len,MPI_CHARACTER, & - IO_id,MPI_COMM_WORLD,ierr) - call mpp_land_sync() - return - end subroutine mpp_land_bcast_char1 - - - subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag) -! ### Communicate message on left right and up bottom directions. - integer NX,NY - integer flag != 99 test only for land model. (replace the boundary). - != 1 get the sum of the boundary value. - real in_out_data(nx,ny) - - call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) - call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) - - return - end subroutine MPP_LAND_COM_REAL - - subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag) -! ### Communicate message on left right and up bottom directions. - integer NX,NY - integer flag != 99 test only for land model. (replace the boundary). - != 1 get the sum of the boundary value. - real*8 in_out_data(nx,ny) - - call MPP_LAND_LR_COM8(in_out_data,NX,NY,flag) - call MPP_LAND_UB_COM8(in_out_data,NX,NY,flag) - - return - end subroutine MPP_LAND_COM_REAL8 - - subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag) -! ### Communicate message on left right and up bottom directions. - integer NX,NY - integer flag != 99 test only for land model. (replace the boundary). - != 1 get the sum of the boundary value. - integer data(nx,ny) - real in_out_data(nx,ny) - - in_out_data = data + 0.0 - call MPP_LAND_LR_COM(in_out_data,NX,NY,flag) - call MPP_LAND_UB_COM(in_out_data,NX,NY,flag) - data = in_out_data + 0 - - return - end subroutine MPP_LAND_COM_INTEGER - - subroutine read_restart_3(unit,nz,out) - integer unit,nz,i - real buf3(global_nx,global_ny,nz),& - out(local_nx,local_ny,3) - if(my_id.eq.IO_id) read(unit) buf3 - do i = 1,nz - call decompose_data_real (buf3(:,:,i),out(:,:,i)) - end do - return - end subroutine read_restart_3 - - subroutine read_restart_2(unit,out) - integer unit,ierr2 - real buf2(global_nx,global_ny),& - out(local_nx,local_ny) - - if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 - call mpp_land_bcast_int1(ierr2) - if(ierr2 .ne. 0) return - - call decompose_data_real (buf2,out) - return - end subroutine read_restart_2 - - subroutine read_restart_rt_2(unit,out) - integer unit,ierr2 - real buf2(global_rt_nx,global_rt_ny),& - out(local_rt_nx,local_rt_ny) - - if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2 - call mpp_land_bcast_int1(ierr2) - if(ierr2.ne.0) return - - call decompose_RT_real(buf2,out, & - global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) - return - end subroutine read_restart_rt_2 - - subroutine read_restart_rt_3(unit,nz,out) - integer unit,nz,i,ierr2 - real buf3(global_rt_nx,global_rt_ny,nz),& - out(local_rt_nx,local_rt_ny,3) - - if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf3 - call mpp_land_bcast_int1(ierr2) - if(ierr2.ne.0) return - - do i = 1,nz - call decompose_RT_real (buf3(:,:,i),out(:,:,i),& - global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny) - end do - return - end subroutine read_restart_rt_3 - - subroutine write_restart_3(unit,nz,in) - integer unit,nz,i - real buf3(global_nx,global_ny,nz),& - in(local_nx,local_ny,nz) - do i = 1,nz - call write_IO_real(in(:,:,i),buf3(:,:,i)) - end do - if(my_id.eq.IO_id) write(unit) buf3 - return - end subroutine write_restart_3 - - subroutine write_restart_2(unit,in) - integer unit - real buf2(global_nx,global_ny),& - in(local_nx,local_ny) - call write_IO_real(in,buf2) - if(my_id.eq.IO_id) write(unit) buf2 - return - end subroutine write_restart_2 - - subroutine write_restart_rt_2(unit,in) - integer unit - real buf2(global_rt_nx,global_rt_ny), & - in(local_rt_nx,local_rt_ny) - call write_IO_RT_real(in,buf2) - if(my_id.eq.IO_id) write(unit) buf2 - return - end subroutine write_restart_rt_2 - - subroutine write_restart_rt_3(unit,nz,in) - integer unit,nz,i - real buf3(global_rt_nx,global_rt_ny,nz),& - in(local_rt_nx,local_rt_ny,nz) - do i = 1,nz - call write_IO_RT_real(in(:,:,i),buf3(:,:,i)) - end do - if(my_id.eq.IO_id) write(unit) buf3 - return - end subroutine write_restart_rt_3 - - subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - integer g_nx,g_ny,nx,ny - real in_buff(g_nx,g_ny),out_buff(nx,ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_REAL, i,tag,MPI_COMM_WORLD,ierr) - end if - end do - else - size = nx*ny - call mpi_recv(out_buff,size,MPI_REAL,IO_id, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_RT_real - - subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny) -! usage: all of the cpu call this subroutine. -! the IO node will distribute the data to rest of the node. - integer g_nx,g_ny,nx,ny - integer in_buff(g_nx,g_ny),out_buff(nx,ny) - integer tag, i, status, ierr,size - integer ibegin,iend,jbegin,jend - - tag = 2 - call mpp_land_sync() - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(ibegin.gt.1) ibegin=ibegin - 1 - iend = ibegin + local_rt_nx_size(i+1) -1 - jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) - if(jbegin.gt.1) jbegin=jbegin - 1 - jend = jbegin + local_rt_ny_size(i+1) -1 - - if(my_id .eq. i) then - out_buff=in_buff(ibegin:iend,jbegin:jend) - else - ! send data to the rest process. - size = (iend-ibegin+1)*(jend-jbegin+1) - call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,& - MPI_INTEGER, i,tag,MPI_COMM_WORLD,ierr) - end if - end do - else - size = nx*ny - call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - end if - return - end subroutine decompose_RT_int - - subroutine getNX_NY(nprocs, nx,ny) - ! calculate the nx and ny based on the total nprocs. - integer nprocs, nx, ny - integer i,j, max - max = nprocs - do j = 1, nprocs - if( mod(nprocs,j) .eq. 0 ) then - i = nprocs/j - if( abs(i-j) .lt. max) then - max = abs(i-j) - nx = i - ny = j - end if - end if - end do - return - end subroutine getNX_NY - - subroutine pack_global_22(in, & - out,k) - integer ix,jx,k,i - real out(global_nx,global_ny,k) - real in(local_nx,local_ny,k) - do i = 1, k - call write_IO_real(in(:,:,i),out(:,:,i)) - enddo - return - end subroutine pack_global_22 - - - subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT) - implicit none - integer total_pe - integer info(9,total_pe),AGGFACTRT - integer :: ierr, status - integer i - - call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) - call MPI_COMM_SIZE( MPI_COMM_WORLD, numprocs, ierr ) - - if(numprocs .ne. total_pe) then - write(6,*) "Error: numprocs .ne. total_pe ",numprocs, total_pe - call mpp_land_abort() - endif - - -! ### get the neighbors. -1 means no neighbor. - left_id = info(2,my_id+1) - right_id = info(3,my_id+1) - up_id = info(4,my_id+1) - down_id = info(5,my_id+1) - IO_id = 0 - - allocate(local_nx_size(numprocs),stat = status) - allocate(local_ny_size(numprocs),stat = status) - allocate(local_rt_nx_size(numprocs),stat = status) - allocate(local_rt_ny_size(numprocs),stat = status) - allocate(starty(numprocs),stat = ierr) - allocate(startx(numprocs),stat = ierr) - - i = my_id + 1 - local_nx = info(7,i) - info(6,i) + 1 - local_ny = info(9,i) - info(8,i) + 1 - - global_nx = 0 - global_ny = 0 - do i = 1, numprocs - global_nx = max(global_nx,info(7,i)) - global_ny = max(global_ny,info(9,i)) - enddo - - local_rt_nx = local_nx*AGGFACTRT+2 - local_rt_ny = local_ny*AGGFACTRT+2 - if(left_id.lt.0) local_rt_nx = local_rt_nx -1 - if(right_id.lt.0) local_rt_nx = local_rt_nx -1 - if(up_id.lt.0) local_rt_ny = local_rt_ny -1 - if(down_id.lt.0) local_rt_ny = local_rt_ny -1 - - global_rt_nx = global_nx*AGGFACTRT - global_rt_ny = global_ny*AGGFACTRT - rt_AGGFACTRT = AGGFACTRT - - do i =1,numprocs - local_nx_size(i) = info(7,i) - info(6,i) + 1 - local_ny_size(i) = info(9,i) - info(8,i) + 1 - startx(i) = info(6,i) - starty(i) = info(8,i) - - local_rt_nx_size(i) = (info(7,i) - info(6,i) + 1)*AGGFACTRT+2 - local_rt_ny_size(i) = (info(9,i) - info(8,i) + 1 )*AGGFACTRT+2 - if(info(2,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 - if(info(3,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1 - if(info(4,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 - if(info(5,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1 - enddo - return - end subroutine wrf_LAND_set_INIT - - subroutine getMy_global_id() - integer ierr - call MPI_COMM_RANK( MPI_COMM_WORLD, my_id, ierr ) - return - end subroutine getMy_global_id - - subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag) - ! communicate the data for channel routine. - implicit none - integer ix,jy,size - integer Link_location(ix,jy) - integer i,j, flag - real Link_V(size), tmp_inout(ix,jy) - - tmp_inout = -999 - - if(size .eq. 0) then - tmp_inout = -999 - else - - ! map the Link_V data to tmp_inout(ix,jy) - do i = 1,ix - if(Link_location(i,1) .gt. 0) & - tmp_inout(i,1) = Link_V(Link_location(i,1)) - if(Link_location(i,2) .gt. 0) & - tmp_inout(i,2) = Link_V(Link_location(i,2)) - if(Link_location(i,jy-1) .gt. 0) & - tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) - if(Link_location(i,jy) .gt. 0) & - tmp_inout(i,jy) = Link_V(Link_location(i,jy)) - enddo - do j = 1,jy - if(Link_location(1,j) .gt. 0) & - tmp_inout(1,j) = Link_V(Link_location(1,j)) - if(Link_location(2,j) .gt. 0) & - tmp_inout(2,j) = Link_V(Link_location(2,j)) - if(Link_location(ix-1,j) .gt. 0) & - tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) - if(Link_location(ix,j) .gt. 0) & - tmp_inout(ix,j) = Link_V(Link_location(ix,j)) - enddo - endif - -! commu nicate tmp_inout - call MPP_LAND_COM_REAL(tmp_inout, ix,jy,flag) - -!map the data back to Link_V - if(size .eq. 0) return - do j = 1,jy - if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & - Link_V(Link_location(1,j)) = tmp_inout(1,j) - if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & - Link_V(Link_location(2,j)) = tmp_inout(2,j) - if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & - Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) - if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& - Link_V(Link_location(ix,j)) = tmp_inout(ix,j) - enddo - do i = 1,ix - if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& - Link_V(Link_location(i,1)) = tmp_inout(i,1) - if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& - Link_V(Link_location(i,2)) = tmp_inout(i,2) - if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & - Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) - if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & - Link_V(Link_location(i,jy)) = tmp_inout(i,jy) - enddo - end subroutine MPP_CHANNEL_COM_REAL - - subroutine MPP_CHANNEL_COM_INT(Link_location,ix,jy,Link_V,size,flag) - ! communicate the data for channel routine. - implicit none - integer ix,jy,size - integer Link_location(ix,jy) - integer i,j, flag - integer Link_V(size), tmp_inout(ix,jy) - - if(size .eq. 0) then - tmp_inout = -999 - else - - ! map the Link_V data to tmp_inout(ix,jy) - do i = 1,ix - if(Link_location(i,1) .gt. 0) & - tmp_inout(i,1) = Link_V(Link_location(i,1)) - if(Link_location(i,2) .gt. 0) & - tmp_inout(i,2) = Link_V(Link_location(i,2)) - if(Link_location(i,jy-1) .gt. 0) & - tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1)) - if(Link_location(i,jy) .gt. 0) & - tmp_inout(i,jy) = Link_V(Link_location(i,jy)) - enddo - do j = 1,jy - if(Link_location(1,j) .gt. 0) & - tmp_inout(1,j) = Link_V(Link_location(1,j)) - if(Link_location(2,j) .gt. 0) & - tmp_inout(2,j) = Link_V(Link_location(2,j)) - if(Link_location(ix-1,j) .gt. 0) & - tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j)) - if(Link_location(ix,j) .gt. 0) & - tmp_inout(ix,j) = Link_V(Link_location(ix,j)) - enddo - endif - -! commu nicate tmp_inout - call MPP_LAND_COM_INTEGER(tmp_inout, ix,jy,flag) - -!map the data back to Link_V - if(size .eq. 0) return - do j = 1,jy - if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) & - Link_V(Link_location(1,j)) = tmp_inout(1,j) - if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) & - Link_V(Link_location(2,j)) = tmp_inout(2,j) - if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) & - Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j) - if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )& - Link_V(Link_location(ix,j)) = tmp_inout(ix,j) - enddo - do i = 1,ix - if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )& - Link_V(Link_location(i,1)) = tmp_inout(i,1) - if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )& - Link_V(Link_location(i,2)) = tmp_inout(i,2) - if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) & - Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1) - if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) & - Link_V(Link_location(i,jy)) = tmp_inout(i,jy) - enddo - end subroutine MPP_CHANNEL_COM_INT - subroutine print_2(unit,in,fm) - integer unit - character(len=*) fm - real buf2(global_nx,global_ny),& - in(local_nx,local_ny) - call write_IO_real(in,buf2) - if(my_id.eq.IO_id) write(unit,*) buf2 - return - end subroutine print_2 - - subroutine print_rt_2(unit,in) - integer unit - real buf2(global_nx,global_ny),& - in(local_nx,local_ny) - call write_IO_real(in,buf2) - if(my_id.eq.IO_id) write(unit,*) buf2 - return - end subroutine print_rt_2 - - subroutine mpp_land_max_int1(v) - implicit none - integer v, r1, max - integer i, ierr, tag - if(my_id .eq. IO_id) then - max = v - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 101 - call mpi_recv(r1,1,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - if(max <= r1) max = r1 - end if - end do - else - tag = 101 - call mpi_send(v,1,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - call mpp_land_bcast_int1(max) - v = max - return - end subroutine mpp_land_max_int1 - - subroutine mpp_land_max_real1(v) - implicit none - real v, r1, max - integer i, ierr, tag - if(my_id .eq. IO_id) then - max = v - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 101 - call mpi_recv(r1,1,MPI_REAL,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - if(max <= r1) max = r1 - end if - end do - else - tag = 101 - call mpi_send(v,1,MPI_REAL, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - call mpp_land_bcast_real1(max) - v = max - return - end subroutine mpp_land_max_real1 - - subroutine mpp_same_int1(v) - implicit none - integer v,r1 - integer i, ierr, tag - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 109 - call mpi_recv(r1,1,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - if(v .ne. r1) v = -99 - end if - end do - else - tag = 109 - call mpi_send(v,1,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - call mpp_land_bcast_int1(v) - end subroutine mpp_same_int1 - - - - subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v) - implicit none - integer gnlinks,nlinks, map_l2g(nlinks),tmp_map(gnlinks) - real recv(nlinks), v(nlinks) - real g_v(gnlinks), tmp_v(gnlinks) - integer i, ierr, tag, k - integer length, node, message_len - - if(nlinks .le. 0) then - tmp_map = -999 - else - tmp_map(1:nlinks) = map_l2g(1:nlinks) - endif - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - message_len = mpp_nlinks(i+1) - if(i .ne. my_id) then - !block receive from other node. - - tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - tag = 119 - - call mpi_recv(tmp_v(1:message_len),message_len,MPI_REAL,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - - do k = 1,message_len - node = tmp_map(k) - if(node .gt. 0) then - g_v(node) = tmp_v(k) - else - write(6,*) "Maping infor k=",k," node=", node - endif - enddo - else - do k = 1,nlinks - node = map_l2g(k) - if(node .gt. 0) then - g_v(node) = v(k) - else - write(6,*) "local Maping infor k=",k," node=",node - endif - enddo - end if - - end do - else - tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - tag = 119 - call mpi_send(v,nlinks,MPI_REAL,IO_id, & - tag,MPI_COMM_WORLD,ierr) - - end if - end subroutine write_chanel_real - - subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v) - implicit none - integer gnlinks,nlinks, map_l2g(nlinks),tmp_map(gnlinks) - integer :: recv(nlinks), v(nlinks) - integer :: g_v(gnlinks), tmp_v(gnlinks) - integer i, ierr, tag, k - integer length, node, message_len - - if(nlinks .le. 0) then - tmp_map = -999 - else - tmp_map(1:nlinks) = map_l2g(1:nlinks) - endif - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - message_len = mpp_nlinks(i+1) - if(i .ne. my_id) then - !block receive from other node. - - tag = 109 - call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - tag = 119 - - call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - - do k = 1,message_len - if(tmp_map(k) .gt. 0) then - node = tmp_map(k) - g_v(node) = tmp_v(k) - else - write(6,*) "Maping infor k=",k," node=",tmp_v(k) - endif - enddo - else - do k = 1,nlinks - if(map_l2g(k) .gt. 0) then - node = map_l2g(k) - g_v(node) = v(k) - else - write(6,*) "Maping infor k=",k," node=",map_l2g(k) - endif - enddo - end if - - end do - else - tag = 109 - call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - tag = 119 - call mpi_send(v,nlinks,MPI_INTEGER,IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - end subroutine write_chanel_int - - - - subroutine write_lake_real(v,nodelist_in,nlakes) - implicit none - real recv(nlakes), v(nlakes) - integer nodelist(nlakes), nlakes, nodelist_in(nlakes) - integer i, ierr, tag, k - integer length, node - - nodelist = nodelist_in - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 129 - call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - tag = 139 - call mpi_recv(recv(:),nlakes,MPI_REAL,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - - do k = 1,nlakes - if(nodelist(k) .gt. -99) then - node = nodelist(k) - v(node) = recv(node) - endif - enddo - end if - - end do - else - tag = 129 - call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - tag = 139 - call mpi_send(v,nlakes,MPI_REAL,IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - end subroutine write_lake_real - - subroutine read_rst_crt_r(unit,out,size) - implicit none - integer unit, size, ierr,ierr2 - real out(size),out1(size) - if(my_id.eq.IO_id) then - read(unit,IOSTAT=ierr2,end=99) out1 - if(ierr2.eq.0) out=out1 - endif -99 continue - call mpp_land_bcast_int1(ierr2) - if(ierr2 .ne. 0) return - call mpi_bcast(out,size,MPI_REAL, & - IO_id,MPI_COMM_WORLD,ierr) - return - end subroutine read_rst_crt_r - - subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks) - integer :: unit,gnlinks,nlinks,map_l2g(nlinks) - real cd(nlinks) - real g_cd (gnlinks) - call write_chanel_real(cd,map_l2g,gnlinks,nlinks, g_cd) - write(unit) g_cd - return - end subroutine write_rst_crt_r - - subroutine sum_real8(vin,nsize) - implicit none - integer nsize,i,j,tag,ierr - real*8, dimension(nsize):: vin,recv - real, dimension(nsize):: v - tag = 319 - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - call mpi_recv(recv,nsize,MPI_DOUBLE_PRECISION,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - vin(:) = vin(:) + recv(:) - endif - end do - v = vin - else - call mpi_send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id, & - tag,MPI_COMM_WORLD,ierr) - endif - call mpp_land_bcast_real(nsize,v) - vin = v - return - end subroutine sum_real8 - -! subroutine get_globalDim(ix,g_ix) -! implicit none -! integer ix,g_ix, ierr -! include "mpif.h" -! -! if ( my_id .eq. IO_id ) then -! g_ix = ix -! call mpi_reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, & -! MPI_SUM, 0, MPI_COMM_WORLD, ierr ) -! else -! call mpi_reduce( ix, 0, 4, MPI_INTEGER, & -! MPI_SUM, 0, MPI_COMM_WORLD, ierr ) -! endif -! call mpp_land_bcast_int1(g_ix) -! -! return -! -! end subroutine get_globalDim - - subroutine gather_1d_real_tmp(vl,s_in,e_in,vg,sg) - integer sg, s,e, size, s_in, e_in - integer index_s(2) - integer tag, ierr,i -! s: start index, e: end index - real vl(e_in-s_in+1), vg(sg) - s = s_in - e = e_in - - if(my_id .eq. IO_id) then - vg(s:e) = vl - end if - - index_s(1) = s - index_s(2) = e - size = e - s + 1 - - if(my_id .eq. IO_id) then - do i = 0, numprocs - 1 - if(i .ne. my_id) then - !block receive from other node. - tag = 202 - call mpi_recv(index_s,2,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - - tag = 203 - e = index_s(2) - s = index_s(1) - size = e - s + 1 - call mpi_recv(vg(s:e),size,MPI_REAL, & - i,tag,MPI_COMM_WORLD,mpp_status,ierr) - endif - end do - else - tag = 202 - call mpi_send(index_s,2,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - - tag = 203 - call mpi_send(vl,size,MPI_REAL,IO_id, & - tag,MPI_COMM_WORLD,ierr) - end if - - return - end subroutine gather_1d_real_tmp - - subroutine sum_double(inout) - implicit none - real*8:: inout, send - integer :: ierr - send = inout - !yw CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE,MPI_SUM,MPI_COMM_WORLD,ierr) - CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr) - end subroutine sum_double - - subroutine mpp_chrt_nlinks_collect(nlinks) - ! collect the nlinks - implicit none - integer :: nlinks - integer :: i, ierr, status, tag - allocate(mpp_nlinks(numprocs),stat = status) - tag = 138 - mpp_nlinks = 0 - if(my_id .eq. IO_id) then - do i = 0,numprocs -1 - if(i .ne. my_id) then - call mpi_recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, & - tag,MPI_COMM_WORLD,mpp_status,ierr) - else - mpp_nlinks(i+1) = 0 - end if - end do - else - call mpi_send(nlinks,1,MPI_INTEGER, IO_id, & - tag,MPI_COMM_WORLD,ierr) - endif - - - end subroutine mpp_chrt_nlinks_collect - - subroutine getLocalXY(ix,jx,startx,starty,endx,endy) -!!! this is for NoahMP only - implicit none - integer:: ix,jx,startx,starty,endx,endy - startx = local_startx - starty = local_starty - endx = startx + ix -1 - endy = starty + jx -1 - end subroutine getLocalXY - - subroutine check_landreal1(unit, inVar) - implicit none - integer :: unit - real :: inVar - if(my_id .eq. IO_id) then - write(unit,*) inVar - flush(unit) - endif - end subroutine check_landreal1 - - subroutine check_landreal1d(unit, inVar) - implicit none - integer :: unit - real :: inVar(:) - if(my_id .eq. IO_id) then - write(unit,*) inVar - flush(unit) - endif - end subroutine check_landreal1d - subroutine check_landreal2d(unit, inVar) - implicit none - integer :: unit - real :: inVar(:,:) - real :: g_var(global_nx,global_ny) - call write_io_real(inVar,g_var) - if(my_id .eq. IO_id) then - write(unit,*) g_var - flush(unit) - endif - end subroutine check_landreal2d - - subroutine check_landreal3d(unit, inVar) - implicit none - integer :: unit, k, klevel - real :: inVar(:,:,:) - real :: g_var(global_nx,global_ny) - klevel = size(inVar,2) - do k = 1, klevel - call write_io_real(inVar(:,k,:),g_var) - if(my_id .eq. IO_id) then - write(unit,*) g_var - flush(unit) - endif - end do - end subroutine check_landreal3d - -END MODULE MODULE_MPP_LAND - - subroutine mpp_land_abort() - implicit none - include "mpif.h" - integer ierr - CALL MPI_ABORT(MPI_COMM_WORLD,1,IERR) - end ! mpp_land_abort - - subroutine mpp_land_sync() - implicit none - include "mpif.h" - integer ierr - call MPI_barrier( MPI_COMM_WORLD ,ierr) - if(ierr .ne. 0) call mpp_land_abort() - return - end ! mpp_land_sync - - - - diff --git a/wrfv2_fire/hydro/Routing/.svn/all-wcprops b/wrfv2_fire/hydro/Routing/.svn/all-wcprops deleted file mode 100644 index 5d4775d6..00000000 --- a/wrfv2_fire/hydro/Routing/.svn/all-wcprops +++ /dev/null @@ -1,71 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 60 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing -END -module_noah_chan_param_init_rt.F -K 25 -svn:wc:ra_dav:version-url -V 93 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_noah_chan_param_init_rt.F -END -rtFunction.F -K 25 -svn:wc:ra_dav:version-url -V 73 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/rtFunction.F -END -Noah_distr_routing.F -K 25 -svn:wc:ra_dav:version-url -V 81 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/Noah_distr_routing.F -END -module_HYDRO_io.F -K 25 -svn:wc:ra_dav:version-url -V 78 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_HYDRO_io.F -END -module_date_utilities_rt.F -K 25 -svn:wc:ra_dav:version-url -V 87 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_date_utilities_rt.F -END -module_GW_baseflow.F -K 25 -svn:wc:ra_dav:version-url -V 81 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_GW_baseflow.F -END -module_channel_routing.F -K 25 -svn:wc:ra_dav:version-url -V 85 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_channel_routing.F -END -module_lsm_forcing.F -K 25 -svn:wc:ra_dav:version-url -V 81 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_lsm_forcing.F -END -Makefile -K 25 -svn:wc:ra_dav:version-url -V 69 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/Makefile -END -module_HYDRO_utils.F -K 25 -svn:wc:ra_dav:version-url -V 81 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_HYDRO_utils.F -END -module_RT.F -K 25 -svn:wc:ra_dav:version-url -V 72 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Routing/module_RT.F -END diff --git a/wrfv2_fire/hydro/Routing/.svn/entries b/wrfv2_fire/hydro/Routing/.svn/entries deleted file mode 100644 index 44b84ff4..00000000 --- a/wrfv2_fire/hydro/Routing/.svn/entries +++ /dev/null @@ -1,402 +0,0 @@ -10 - -dir -9105 -https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/Routing -https://kkeene@svn-wrf-model.cgd.ucar.edu - - - -2015-02-13T18:35:30.360105Z -8075 -weiyu@ucar.edu - - - - - - - - - - - - - - -b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d - -module_noah_chan_param_init_rt.F -file - - - - -2016-02-11T20:37:50.134995Z -630a8feec10d204ea5c17538384988ce -2012-12-07T20:01:45.900797Z -6094 -gill - - - - - - - - - - - - - - - - - - - - - -2719 - -rtFunction.F -file - - - - -2016-02-11T20:37:50.136223Z -66aee92dbadc919da2a278cb6ee6c042 -2013-11-15T19:40:36.446206Z -6964 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -9159 - -Noah_distr_routing.F -file - - - - -2016-02-11T20:37:50.121621Z -ba290baa52dd512dc283c734b1964a7a -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -92153 - -module_HYDRO_io.F -file - - - - -2016-02-11T20:37:50.123186Z -06e5f14906bc1e53f9ae140d0bc3de70 -2015-01-23T18:49:15.035273Z -8003 -gill - - - - - - - - - - - - - - - - - - - - - -241116 - -module_date_utilities_rt.F -file - - - - -2016-02-11T20:37:50.124370Z -49972d35cce17498d1fd4aab9ca6f2dc -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -27903 - -module_GW_baseflow.F -file - - - - -2016-02-11T20:37:50.125453Z -f9022bc6362d306dc881189824307266 -2015-02-13T18:35:30.360105Z -8075 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -26501 - -module_channel_routing.F -file - - - - -2016-02-11T20:37:50.126617Z -02dd8389957051a283142233447cfd58 -2015-01-23T18:49:15.035273Z -8003 -gill - - - - - - - - - - - - - - - - - - - - - -50277 - -module_lsm_forcing.F -file - - - - -2016-02-11T20:37:50.127855Z -ebb3f6b8637055122118f29e2163947b -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -75184 - -Makefile -file - - - - -2016-02-11T20:37:50.131541Z -7524715cf5a742825473c375346ca604 -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -1240 - -module_HYDRO_utils.F -file - - - - -2016-02-11T20:37:50.132710Z -f2ef7f1a0cbceeac8680821c0f6ca117 -2013-03-22T17:14:06.234507Z -6523 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -13813 - -module_RT.F -file - - - - -2016-02-11T20:37:50.133907Z -f6efcd969c8b00048ef85e58db1e6124 -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -40331 - diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/Makefile.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/Makefile.svn-base deleted file mode 100644 index ce785bc1..00000000 --- a/wrfv2_fire/hydro/Routing/.svn/text-base/Makefile.svn-base +++ /dev/null @@ -1,53 +0,0 @@ -# Makefile -# -.SUFFIXES: -.SUFFIXES: .o .F - -include ../macros - -OBJS = \ - module_HYDRO_utils.o \ - module_noah_chan_param_init_rt.o \ - module_GW_baseflow.o \ - module_HYDRO_io.o \ - module_RT.o Noah_distr_routing.o \ - module_channel_routing.o \ - module_lsm_forcing.o - -all: $(OBJS) - -#module_RT.o: module_RT.F -# @echo "" -# $(CPP) $(CPPFLAGS) $(*).F > $(*).f -# $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f -# $(RMD) $(*).f -# @echo "" -# cp *.mod ../mod - -.F.o: - @echo "" - $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f - $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f - $(RMD) $(*).f - @echo "" - ar -r ../lib/libHYDRO.a $(@) - cp *.mod ../mod - -# -# Dependencies: -# -module_GW_baseflow.o: ../Data_Rec/module_GW_baseflow_data.o - -module_HYDRO_io.o: module_HYDRO_utils.o ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o - -module_HYDRO_utils.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o - -module_lsm_forcing.o: module_HYDRO_io.o - -module_RT.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o ../Data_Rec/module_GW_baseflow_data.o \ - module_GW_baseflow.o module_HYDRO_utils.o module_HYDRO_io.o\ - module_noah_chan_param_init_rt.o ../Data_Rec/module_GW_baseflow_data.o - - -clean: - rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/Noah_distr_routing.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/Noah_distr_routing.F.svn-base deleted file mode 100644 index 0f856caf..00000000 --- a/wrfv2_fire/hydro/Routing/.svn/text-base/Noah_distr_routing.F.svn-base +++ /dev/null @@ -1,2768 +0,0 @@ -!DJG ------------------------------------------------ -!DJG SUBROUTINE RT_PARM -!DJG ------------------------------------------------ - - SUBROUTINE RT_PARM(IX,JY,IXRT,JXRT,VEGTYP,RETDP,OVRGH, & - AGGFACTR) -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id,& - up_id,mpp_land_com_real,MPP_LAND_UB_COM, & - MPP_LAND_LR_COM,mpp_land_com_integer -#endif - - IMPLICIT NONE - -!DJG -------- DECLARATIONS ----------------------- - - INTEGER, INTENT(IN) :: IX,JY,IXRT,JXRT,AGGFACTR - - INTEGER, INTENT(IN), DIMENSION(IX,JY) :: VEGTYP - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: RETDP - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: OVRGH - - -!DJG Local Variables - - INTEGER :: I,J,IXXRT,JYYRT - INTEGER :: AGGFACYRT,AGGFACXRT - - -!DJG Assign RETDP and OVRGH based on VEGTYP... - - do J=1,JY - do I=1,IX - - do AGGFACYRT=AGGFACTR-1,0,-1 - do AGGFACXRT=AGGFACTR-1,0,-1 - - IXXRT=I*AGGFACTR-AGGFACXRT - JYYRT=J*AGGFACTR-AGGFACYRT -#ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 -#else -!yw ???? -! IXXRT=IXXRT+1 -! JYYRT=JYYRT+1 -#endif - - -!DJG Urban, rock, playa, snow/ice... - IF (VEGTYP(I,J).EQ.1.OR.VEGTYP(I,J).EQ.26.OR. & - VEGTYP(I,J).EQ.26.OR.VEGTYP(I,J).EQ.24) THEN - RETDP(IXXRT,JYYRT)=1.3 - OVRGH(IXXRT,JYYRT)=0.1 -!DJG Wetlands and water bodies... - ELSE IF (VEGTYP(I,J).EQ.17.OR.VEGTYP(I,J).EQ.18.OR. & - VEGTYP(I,J).EQ.19.OR.VEGTYP(I,J).EQ.16) THEN - RETDP(IXXRT,JYYRT)=10.0 - OVRGH(IXXRT,JYYRT)=0.2 -!DJG All other natural covers... - ELSE - RETDP(IXXRT,JYYRT)=5.0 - OVRGH(IXXRT,JYYRT)=0.2 - END IF - - end do - end do - - end do - end do -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(RETDP,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(OVRGH,IXRT,JXRT,99) -#endif - -!DJG ---------------------------------------------------------------- - END SUBROUTINE RT_PARM -!DJG ---------------------------------------------------------------- - - - - - -!DJG ------------------------------------------------ -!DJG SUBROUTINE SUBSFC_RTNG -!DJG ------------------------------------------------ - - SUBROUTINE SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT, & - SOYRT,LATKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT, & - NSOIL,SMCRT,INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT, & - SMCWLTRT,SO8RT,SO8RT_D, rt_option,SLDPTH,junk4,CWATAVAIL, & - SATLYRCHK) - -! use module_mpp_land, only: write_restart_rt_3, write_restart_rt_2, & -! my_id -#ifdef MPP_LAND - use module_mpp_land, only: MPP_LAND_COM_REAL -#endif - IMPLICIT NONE - -!DJG -------- DECLARATIONS ------------------------ - - INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL - - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT,junk4 - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOYRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: LATKSATRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOLDEPRT - - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ZWATTABLRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: CWATAVAIL - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: SATLYRCHK - - - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBRT - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBBDRYRT - - REAL, INTENT(IN) :: dist(ixrt,jxrt,9) - REAL, INTENT(IN) :: DT - REAL, INTENT(IN), DIMENSION(NSOIL) :: ZSOIL - REAL, INTENT(IN), DIMENSION(NSOIL) :: SLDPTH - REAL, INTENT(INOUT) :: QSUBBDRYTRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: INFXSUBRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT - - REAL, DIMENSION(IXRT,JXRT) :: ywtmp -!DJG Local Variables - - INTEGER :: I,J,KK -!djg INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK - - REAL :: GRDAREA - REAL :: SUBFLO - REAL :: WATAVAIL - - INTEGER :: SO8RT_D(IXRT,JXRT,3) - REAL :: SO8RT(IXRT,JXRT,8) - integer :: rt_option, index - - INTEGER :: DT_STEPS !-- number of timestep in routing - REAL :: SUBDT !-- subsurface routing timestep - INTEGER :: KRT !-- routing counter - REAL, DIMENSION(IXRT,JXRT,NSOIL) :: SMCTMP !--temp store of SMC - REAL, DIMENSION(IXRT,JXRT) :: ZWATTABLRTTMP ! temp store of ZWAT - REAL, DIMENSION(IXRT,JXRT) :: INFXSUBRTTMP ! temp store of infilx -!djg REAL, DIMENSION(IXRT,JXRT) :: CWATAVAIL ! temp specif. of wat avial - - - -!DJG Debug Variables... - REAL :: qsubchk,qsubbdrytmp - REAL :: junk1,junk2,junk3,junk5,junk6,junk7 - INTEGER, PARAMETER :: double=8 - REAL (KIND=double) :: smctot1a,smctot2a - INTEGER :: kx,count - - -!DJG ----------------------------------------------------------------- -!DJG SUBSURFACE ROUTING LOOP -!DJG - SUBSURFACE ROUTING RUN ON NOAH TIMESTEP -!DJG - SUBSURFACE ROUITNG ONLY PERFORMED ON SATURATED LAYERS -!DJG ----------------------------------------------------------------- - - !yw GRDAREA=DXRT*DXRT - ! GRDAREA=dist(i,j,9) - - -!DJG debug subsfc... - subflo = 0.0 - -!DJG Set up mass balance checks... -! CWATAVAIL = 0. !-- initialize subsurface watavail - SUBDT = DT !-- initialize the routing timestep to DT - - -!!!! Find saturated layer depth... -! Loop through domain to determine sat. layers and assign wat tbl depth... -! and water available for subsfc routing (CWATAVAIL)... -! -! CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & -! SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, & -! CWATAVAIL,SLDPTH) - - - -!DJG debug variable... - - -!DJG Courant check temp variable setup... - ZWATTABLRTTMP = ZWATTABLRT !-- temporary storage of water table level - - - - -!!!! Call subsurface routing subroutine... -#ifdef HYDRO_D - print *, "calling subsurface routing subroutine...Opt. ",rt_option -#endif - - - if(rt_option .eq. 1) then - CALL ROUTE_SUBSURFACE1(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & - LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT, & - SO8RT,SO8RT_D,CWATAVAIL,SUBDT) - else - CALL ROUTE_SUBSURFACE2(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & - LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT, & - CWATAVAIL,SUBDT) - end if - -#ifdef HYDRO_D - write(6,*) "finish calling ROUTE_SUBSURFACE ", rt_option -#endif - - -!!!! Update soil moisture fields with subsurface flow... - -!!!! Loop through subsurface routing domain... - DO I=1,IXRT - DO J=1,JXRT - -!!DJG Check for courant condition violation...put limit on qsub -!!DJG QSUB HAS units of m^3/s SUBFLO has units of m - - - IF (CWATAVAIL(i,j).le.ABS(qsubrt(i,j))/dist(i,j,9)*SUBDT) THEN - QSUBRT(i,j) = -1.0*CWATAVAIL(i,j) - SUBFLO = QSUBRT(i,j) !Units of qsubrt converted via CWATAVAIL - ELSE - SUBFLO=QSUBRT(I,J)/dist(i,j,9)*SUBDT !Convert qsubrt from m^3/s to m - END IF - - WATAVAIL=0. !Initialize to 0. for every cell... - - -!!DJG Begin loop through soil profile to adjust soil water content -!!DJG based on subsfc flow (SUBFLO)... - - IF (SUBFLO.GT.0) THEN ! Increase soil moist for +SUBFLO (Inflow) - -! Loop through soil layers from bottom to top - DO KK=NSOIL,1,-1 - - -! Check for saturated layers - IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK)) THEN - IF (SMCRT(I,J,KK).GT.SMCMAXRT(I,J,KK)) THEN -#ifdef HYDRO_D - print *, "Subsfc acct. SMCMAX exceeded...", & - SMCRT(I,J,KK), SMCMAXRT(I,J,KK),KK,i,j - call hydro_stop("SUBSFC_RTNG") -#endif - ELSE - END IF - ELSE - WATAVAIL = (SMCMAXRT(I,J,KK)-SMCRT(I,J,KK))*SLDPTH(KK) - IF (WATAVAIL.GE.SUBFLO) THEN - SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK) - SUBFLO = 0. - ELSE - SUBFLO = SUBFLO - WATAVAIL - SMCRT(I,J,KK) = SMCMAXRT(I,J,KK) - END IF - END IF - - IF (SUBFLO.EQ.0.) EXIT -! IF (SUBFLO.EQ.0.) goto 669 - - END DO ! END DO FOR SOIL LAYERS - -669 continue - -! If all layers sat. add remaining subflo to infilt. excess... - IF (KK.eq.0.AND.SUBFLO.gt.0.) then - INFXSUBRT(I,J) = INFXSUBRT(I,J) + SUBFLO*1000. !Units = mm - SUBFLO=0. - END IF - -!DJG Error trap... - if (subflo.ne.0.) then -#ifdef HYDRO_D - print *, "Subflo (+) not expired...:",subflo,i,j,kk,SMCRT(i,j,1), & - SMCRT(i,j,2),SMCRT(i,j,3),SMCRT(i,j,4),SMCRT(i,j,5), & - SMCRT(i,j,6),SMCRT(i,j,7),SMCRT(i,j,8),"SMCMAX",SMCMAXRT(i,j,1) -#endif - end if - - - ELSE IF (SUBFLO.LT.0) THEN ! Decrease soil moist for -SUBFLO (Drainage) - - -!DJG loop from satlyr back down and subtract out subflo as necess... -! now set to SMCREF, 8/24/07 -!DJG and then using unsat cond as opposed to Ksat... - - DO KK=SATLYRCHK(I,J),NSOIL - WATAVAIL = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK) - IF (WATAVAIL.GE.ABS(SUBFLO)) THEN -!?yw mod IF (WATAVAIL.GE.(ABS(SUBFLO)+0.000001) ) THEN - SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK) - SUBFLO=0. - ELSE ! Since subflo is small on a time-step following is unlikely... - SMCRT(I,J,KK)=SMCREFRT(I,J,KK) - SUBFLO=SUBFLO+WATAVAIL - END IF - IF (SUBFLO.EQ.0.) EXIT -! IF (SUBFLO.EQ.0.) goto 668 - - END DO ! END DO FOR SOIL LAYERS -668 continue - - -!DJG Error trap... - if(abs(subflo) .le. 1.E-7 ) subflo = 0.0 !truncate residual to 1E-7 prec. - - if (subflo.ne.0.) then -#ifdef HYDRO_D - print *, "Subflo (-) not expired:",i,j,subflo,CWATAVAIL(i,j) - print *, "zwatabl = ", ZWATTABLRT(I,J) - print *, "QSUBRT(I,J)=",QSUBRT(I,J) - print *, "WATAVAIL = ",WATAVAIL, "kk=",kk - print * -#endif - end if - - - - END IF ! end if for +/- SUBFLO soil moisture accounting... - - - - - END DO ! END DO X dim - END DO ! END DO Y dim -!!!! End loop through subsurface routing domain... - -#ifdef MPP_LAND - do i = 1, NSOIL - call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99) - end DO -#endif - - - -!DJG ---------------------------------------------------------------- - END SUBROUTINE SUBSFC_RTNG -!DJG ---------------------------------------------------------------- - - -!DJG ------------------------------------------------------------------------ -!DJG SUBSURFACE FINDZWAT -!DJG ------------------------------------------------------------------------ - SUBROUTINE FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & - SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT,CWATAVAIL,& - SLDPTH) - - IMPLICIT NONE - -!DJG -------- DECLARATIONS ------------------------ - - INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT - REAL, INTENT(IN), DIMENSION(NSOIL) :: ZSOIL - REAL, INTENT(IN), DIMENSION(NSOIL) :: SLDPTH - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: ZWATTABLRT - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: CWATAVAIL - INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SATLYRCHK - -!DJG Local Variables - INTEGER :: KK,i,j - - -!!!! Find saturated layer depth... -! Loop through domain to determine sat. layers and assign wat tbl depth... - - - SATLYRCHK = 0 !set flag for sat. layers - CWATAVAIL = 0. !set wat avail for subsfc rtng = 0. - - DO J=1,JXRT - DO I=1,IXRT - -! Loop through soil layers from bottom to top - DO KK=NSOIL,1,-1 - -! Check for saturated layers -! Add additional logical check to ensure water is 'available' for routing, -! (i.e. not 'frozen' or otherwise immobile) -! IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK).AND.SMCMAXRT(I,J,KK) & -! .GT.SMCWLTRT(I,J,KK)) THEN - IF ( (SMCRT(I,J,KK).GE.SMCREFRT(I,J,KK)).AND.(SMCREFRT(I,J,KK) & - .GT.SMCWLTRT(I,J,KK)) ) THEN -! Add additional check to ensure saturation from bottom up only...8/8/05 - IF((SATLYRCHK(I,J).EQ.KK+1) .OR. (KK.EQ.NSOIL) ) SATLYRCHK(I,J) = KK - END IF - - END DO - - -! Designate ZWATTABLRT based on highest sat. layer and -! Define amount of water avail for subsfc routing on each gridcell (CWATAVAIL) -! note: using a 'field capacity' value of SMCREF as lower limit... - - IF (SATLYRCHK(I,J).ne.0) then - IF (SATLYRCHK(I,J).ne.1) then ! soil column is partially sat. - ZWATTABLRT(I,J) = -ZSOIL(SATLYRCHK(I,J)-1) - DO KK=SATLYRCHK(I,J),NSOIL -!old CWATAVAIL(I,J) = (SMCRT(I,J,SATLYRCHK(I,J))-& -!old SMCREFRT(I,J,SATLYRCHK(I,J))) * & -!old (ZSOIL(SATLYRCHK(I,J)-1)-ZSOIL(NSOIL)) - CWATAVAIL(I,J) = CWATAVAIL(I,J)+(SMCRT(I,J,KK)- & - SMCREFRT(I,J,KK))*SLDPTH(KK) - END DO - - - ELSE ! soil column is fully saturated to sfc. - ZWATTABLRT(I,J) = 0. - DO KK=SATLYRCHK(I,J),NSOIL - CWATAVAIL(I,J) = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK) - END DO - END IF - ELSE ! no saturated layers... - ZWATTABLRT(I,J) = -ZSOIL(NSOIL) - SATLYRCHK(I,J) = NSOIL + 1 - END IF - - - END DO - END DO - - -!DJG ---------------------------------------------------------------- - END SUBROUTINE FINDZWAT -!DJG ---------------------------------------------------------------- - - -!DJG ---------------------------------------------------------------- -!DJG ---------------------------------------------------------------- -!DJG SUBROUTINE ROUTE_SUBSURFACE2 -!DJG ---------------------------------------------------------------- - - SUBROUTINE ROUTE_SUBSURFACE2( & - dist,z,qsub,sox,soy, & - latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,CWATAVAIL, & - SUBDT) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Subroutine to route subsurface flow through the watershed -!DJG ---------------------------------------------------------------- -! -! Called from: main.f (Noah_router_driver) -! -! Returns: qsub=DQSUB which in turn becomes SUBFLO in head calc. -! -! Created: D. Gochis 3/27/03 -! Adaptded from Wigmosta, 1994 -! -! Modified: D. Gochis 1/05/04 -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id,& - up_id,mpp_land_com_real,MPP_LAND_UB_COM, & - MPP_LAND_LR_COM,mpp_land_com_integer -#endif - - IMPLICIT NONE - - -!! Declare Passed variables - - INTEGER, INTENT(IN) :: XX,YY - -!! Declare passed arrays - - REAL, INTENT(IN), DIMENSION(XX,YY) :: z - REAL, INTENT(IN), DIMENSION(XX,YY) :: sox - REAL, INTENT(IN), DIMENSION(XX,YY) :: soy - REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat - REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL - REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep - REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY - REAL, INTENT(INOUT) :: QSUBDRYT - REAL, INTENT(IN) :: SUBDT - real, intent(in), dimension(xx,yy,9) :: dist - -!!! Declare Local Variables - - REAL :: dzdx,dzdy,beta,gamma - REAL :: qqsub,hh,ksat, gsize - - INTEGER :: i,j -!!! Initialize variables - REAL, PARAMETER :: nexp=1.0 ! local power law exponent - qsub = 0. ! initialize flux = 0. !DJG 5 May 2014 - -!yw soldep = 2. - - -! Begin Subsurface routing - -!!! Loop to route water in x-direction - do j=1,YY - do i=1,XX -! check for boundary grid point? - if (i.eq.XX) GOTO 998 - gsize = dist(i,j,3) - - dzdx= (z(i,j) - z(i+1,j))/gsize - beta=sox(i,j) + dzdx + 1E-30 - if (abs(beta) .lt. 1E-20) beta=1E-20 - if (beta.lt.0) then -!yw hh=(1-(z(i+1,j)/soldep(i,j)))**nexp - hh=(1-(z(i+1,j)/soldep(i+1,j)))**nexp -! Change later to use mean Ksat of two cells - ksat=latksat(i+1,j) - else - hh=(1-(z(i,j)/soldep(i,j)))**nexp - ksat=latksat(i,j) - end if - - if (hh .lt. 0.) then -#ifdef HYDRO_D - print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), & - soldep(i,j),nexp - call hydro_stop("ROUTE_SUBSURFACE2") -#endif - end if - -!Err. tan slope gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) - gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) -!DJG lacks tan(beta) of original Wigmosta version gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta - - qqsub = gamma * hh - qsub(i,j) = qsub(i,j) + qqsub - qsub(i+1,j) = qsub(i+1,j) - qqsub - -! Boundary adjustments -#ifdef MPP_LAND - if ((i.eq.1).AND.(beta.lt.0.).and.(left_id.lt.0)) then -#else - if ((i.eq.1).AND.(beta.lt.0.)) then -#endif - qsub(i,j) = qsub(i,j) - qqsub - QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub - QSUBDRYT = QSUBDRYT - qqsub -#ifdef MPP_LAND - else if ((i.eq.(xx-1)).AND.(beta.gt.0.) & - .and.(right_id.lt.0) ) then -#else - else if ((i.eq.(xx-1)).AND.(beta.gt.0.)) then -#endif - qsub(i+1,j) = qsub(i+1,j) + qqsub - QSUBDRY(i+1,j) = QSUBDRY(i+1,j) + qqsub - QSUBDRYT = QSUBDRYT + qqsub - end if - -998 continue - -!! End loop to route sfc water in x-direction - end do - end do - -#ifdef MPP_LAND - call MPP_LAND_LR_COM(qsub,XX,YY,99) - call MPP_LAND_LR_COM(QSUBDRY,XX,YY,99) -#endif - - -!!! Loop to route water in y-direction - do j=1,YY - do i=1,XX -! check for boundary grid point? - if (j.eq.YY) GOTO 999 - gsize = dist(i,j,1) - - dzdy= (z(i,j) - z(i,j+1))/gsize - beta=soy(i,j) + dzdy + 1E-30 - if (abs(beta) .lt. 1E-20) beta=1E-20 - if (beta.lt.0) then -!yw hh=(1-(z(i,j+1)/soldep(i,j)))**nexp - hh=(1-(z(i,j+1)/soldep(i,j+1)))**nexp - ksat=latksat(i,j+1) - else - hh=(1-(z(i,j)/soldep(i,j)))**nexp - ksat=latksat(i,j) - end if - - if (hh .lt. 0.) GOTO 999 - -!Err. tan slope gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) - gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta - - qqsub = gamma * hh - qsub(i,j) = qsub(i,j) + qqsub - qsub(i,j+1) = qsub(i,j+1) - qqsub - -! Boundary adjustments - -#ifdef MPP_LAND - if ((j.eq.1).AND.(beta.lt.0.).and.(down_id.lt.0)) then -#else - if ((j.eq.1).AND.(beta.lt.0.)) then -#endif - qsub(i,j) = qsub(i,j) - qqsub - QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub - QSUBDRYT = QSUBDRYT - qqsub -#ifdef MPP_LAND - else if ((j.eq.(yy-1)).AND.(beta.gt.0.) & - .and. (up_id.lt.0) ) then -#else - else if ((j.eq.(yy-1)).AND.(beta.gt.0.)) then -#endif - qsub(i,j+1) = qsub(i,j+1) + qqsub - QSUBDRY(i,j+1) = QSUBDRY(i,j+1) + qqsub - QSUBDRYT = QSUBDRYT + qqsub - end if - -999 continue - -!! End loop to route sfc water in y-direction - end do - end do - -#ifdef MPP_LAND - call MPP_LAND_UB_COM(qsub,XX,YY,99) - call MPP_LAND_UB_COM(QSUBDRY,XX,YY,99) -#endif - - return -!DJG------------------------------------------------------------ - end subroutine ROUTE_SUBSURFACE2 -!DJG------------------------------------------------------------ - - - -!DJG ------------------------------------------------ -!DJG SUBROUTINE OV_RTNG -!DJG ------------------------------------------------ - - SUBROUTINE OV_RTNG(DT,DTRT,IXRT,JXRT,INFXSUBRT, & - SFCHEADSUBRT,DHRT,CH_NETRT,RETDEPRT,OVROUGHRT, & - QSTRMVOLRT,QBDRYRT,QSTRMVOLTRT,QBDRYTRT,SOXRT, & - SOYRT,dist,LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT, & - SO8RT,SO8RT_D,rt_option,q_sfcflx_x,q_sfcflx_y) - -!yyww -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id, & - up_id,mpp_land_com_real, my_id, & - mpp_land_sync -#endif - - IMPLICIT NONE - -!DJG --------DECLARATIONS---------------------------- - - INTEGER, INTENT(IN) :: IXRT,JXRT - REAL, INTENT(IN) :: DT,DTRT - - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: INFXSUBRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOYRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: RETDEPRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: OVROUGHRT - - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SFCHEADSUBRT - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: DHRT - - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_INFLORT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QBDRYRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: q_sfcflx_x,q_sfcflx_y - REAL, INTENT(INOUT) :: QSTRMVOLTRT,QBDRYTRT,LAKE_INFLOTRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8) :: SO8RT - -!DJG Local Variables - - INTEGER :: KRT,I,J,ct - - REAL, DIMENSION(IXRT,JXRT) :: INFXS_FRAC - REAL :: DT_FRAC,SUM_INFXS,sum_head - INTEGER SO8RT_D(IXRT,JXRT,3), rt_option - - - - -!DJG ---------------------------------------------------------------------- -! DJG BEGIN 1-D or 2-D OVERLAND FLOW ROUTING LOOP -!DJG --------------------------------------------------------------------- -!DJG Loop over 'routing time step' -!DJG Compute the number of time steps based on NOAH DT and routing DTRT - - DT_FRAC=INT(DT/DTRT) - -#ifdef HYDRO_D - write(6,*) "OV_RTNG DT_FRAC, DT, DTRT",DT_FRAC, DT, DTRT - write(6,*) "IXRT, JXRT = ",ixrt,jxrt -#endif - -!DJG NOTE: Applying all infiltration excess water at once then routing -!DJG Pre-existing SFHEAD gets combined with Precip. in the -!DJG calculation of INFXS1 during subroutine SRT.f. -!DJG debug - - -!DJG Assign all infiltration excess to surface head... - SFCHEADSUBRT=INFXSUBRT - -!DJG Divide infiltration excess over all routing time-steps -! INFXS_FRAC=INFXSUBRT/(DT/DTRT) - -!DJG Set flux accumulation fields to 0. before each loop... - q_sfcflx_x = 0. - q_sfcflx_y = 0. - ct =0 - - -!DJG Execute routing time-step loop... - - - DO KRT=1,DT_FRAC - - DO J=1,JXRT - DO I=1,IXRT - -!DJG Removed 4_29_05, sfhead now updated in route_overland subroutine... -! SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J) -!! SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J)+INFXS_FRAC(I,J) -! DHRT(I,J)=0. - -!DJG ERROR Check... - - IF (SFCHEADSUBRT(I,J).lt.0.) THEN -#ifdef HYDRO_D - print *, "ywcheck 2 ERROR!!!: Neg. Surface Head Value at (i,j):", & - i,j,SFCHEADSUBRT(I,J) - print *, "RETDEPRT(I,J) = ",RETDEPRT(I,J), "KRT=",KRT - print *, "INFXSUBRT(i,j)=",INFXSUBRT(i,j) - print *, "jxrt=",jxrt," ixrt=",ixrt -#endif - END IF - -!DJG Remove surface water from channel cells -!DJG Channel inflo cells specified as nonzeros from CH_NET -!DJG 9/16/04 Channel Extractions Removed until stream model implemented... - - - - IF (CH_NETRT(I,J).ne.-9999) THEN - ct = ct +1 - -!DJG Temporary test to up the retention depth of channel grid cells to 'soak' -!more water into valleys....set retdep = retdep*100 (=5 mm) - -! RETDEPRT(I,J) = RETDEPRT(I,J) * 100.0 !DJG TEMP HARDWIRE!!!! -! RETDEPRT(I,J) = 10.0 !DJG TEMP HARDWIRE!!!! - - IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN -!! QINFLO(CH_NET(I,J)=QINFLO(CH_NET(I,J)+SFCHEAD(I,J) - RETDEPRT(I,J) - QSTRMVOLTRT = QSTRMVOLTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J)) - QSTRMVOLRT(I,J) = QSTRMVOLRT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J) - SFCHEADSUBRT(I,J) = RETDEPRT(I,J) - END IF - END IF - -!DJG Lake inflow withdrawl from surface head...(4/29/05) - - - IF (LAKE_MSKRT(I,J).gt.0) THEN - IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN - LAKE_INFLOTRT = LAKE_INFLOTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J)) - LAKE_INFLORT(I,J) = LAKE_INFLORT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J) - SFCHEADSUBRT(I,J) = RETDEPRT(I,J) - - END IF - END IF - - - - END DO - END DO - -! call MPP_LAND_COM_REAL(QSTRMVOLRT,IXRT,JXRT,99) -!DJG---------------------------------------------------------------------- -!DJG CALL OVERLAND FLOW ROUTING SUBROUTINE -!DJG---------------------------------------------------------------------- - -!DJG Debug... - - - if(rt_option .eq. 1) then - CALL ROUTE_OVERLAND1(DTRT,dist,SFCHEADSUBRT,DHRT,SOXRT, & - SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT, & - SO8RT,SO8RT_D,q_sfcflx_x,q_sfcflx_y) - else - CALL ROUTE_OVERLAND2(DTRT,dist,SFCHEADSUBRT,DHRT,SOXRT, & - SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT, & - q_sfcflx_x,q_sfcflx_y) - end if - - END DO ! END routing time steps - -#ifdef HYDRO_D - print *, "End of OV_routing call..." -#endif - -!---------------------------------------------------------------------- -! END OVERLAND FLOW ROUTING LOOP -! CHANNEL ROUTING TO FOLLOW -!---------------------------------------------------------------------- - -!DJG ---------------------------------------------------------------- - END SUBROUTINE OV_RTNG -!DJG ---------------------------------------------------------------- - -!DJG SUBROUTINE ROUTE_OVERLAND1 -!DJG ---------------------------------------------------------------- - - SUBROUTINE ROUTE_OVERLAND1(dt, & - & gsize,h,qsfc,sox,soy, & - & retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT,SO8RT,SO8RT_D, & - & q_sfcflx_x,q_sfcflx_y) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Subroutine to route excess rainfall over the watershed -! using a 2d diffusion routing scheme. -! -! Called from: main.f -! -! Will try to formulate this to be called from NOAH -! -! Returns: qsfc=DQOV which in turn becomes DH in head calc. -! -! Created: Adaptded from CASC2D source code -! NOTE: dh from original code has been replaced by qsfc -! dhh replaced by qqsfc -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id, & - up_id,mpp_land_com_real, my_id, mpp_land_com_real8,& - mpp_land_sync -#endif - - IMPLICIT NONE - - -!! Declare Passed variables - - INTEGER, INTENT(IN) :: XX,YY - REAL, INTENT(IN) :: dt, gsize(xx,yy,9) - -!! Declare passed arrays - - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h - REAL, INTENT(IN), DIMENSION(XX,YY) :: qsfc - REAL, INTENT(IN), DIMENSION(XX,YY) :: sox - REAL, INTENT(IN), DIMENSION(XX,YY) :: soy - REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep - REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x, q_sfcflx_y - REAL, INTENT(INOUT) :: QBDRYT - REAL, INTENT(IN), DIMENSION(XX,YY,8) :: SO8RT - REAL*8, DIMENSION(XX,YY) :: QBDRY_tmp, DH - REAL*8, DIMENSION(XX,YY) :: DH_tmp - -!!! Declare Local Variables - - REAL :: dhdx,dhdy,alfax,alfay - REAL :: hh53,qqsfc,hh,dt_new,hmax - REAL :: sfx,sfy - REAL :: tmp_adjust - - INTEGER :: i,j - REAL IXX8,IYY8 - INTEGER IXX0,JYY0,index, SO8RT_D(XX,YY,3) - REAL tmp_gsize,hsum - -!!! Initialize variables - - - -!!! Begin Routing of Excess Rainfall over the Watershed - - DH=0. - DH_tmp=0. - QBDRY_tmp =0. - -!!! Loop to route water - do j=2,YY-1 - do i=2,XX-1 - if (h(I,J).GT.retent_dep(I,J)) then - IXX0 = SO8RT_D(i,j,1) - JYY0 = SO8RT_D(i,j,2) - index = SO8RT_D(i,j,3) - tmp_gsize = 1.0/gsize(i,j,index) - sfx = so8RT(i,j,index)-(h(IXX0,JYY0)-h(i,j))*0.001*tmp_gsize - hmax = h(i,j)*0.001 !Specify max head for mass flux limit... - if(sfx .lt. 1E-20) then - call GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,so8rt,gsize(i,j,:),sfx,XX,YY) - end if - if(IXX0 > 0) then ! do the rest if the lowest grid can be found. - if(sfx .lt. 1E-20) then -#ifdef HYDRO_D - print*, "Message: sfx reset to 1E-20. sfx =",sfx - print*, "i,j,index,IXX0,JYY0",i,j,index,IXX0,JYY0 - print*, "so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index) ", & - so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index) -#endif - sfx = 1E-20 - end if - alfax = sqrt(sfx) / dist_rough(i,j) - hh=(h(i,j)-retent_dep(i,j)) * 0.001 - hh53=hh**(5./3.) - -! Calculate q-flux... - qqsfc = alfax*hh53*dt * tmp_gsize - -!Courant check (simple mass limit on overland flow)... - if (qqsfc.ge.(hmax*dt*tmp_gsize)) qqsfc = hmax*dt*tmp_gsize - -! Accumulate directional fluxes on routing subgrid... - if (IXX0.gt.i) then - q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc * & - (1.0 - 0.5 * (ABS(j-JYY0))) - else if (IXX0.lt.i) then - q_sfcflx_x(I,J) = q_sfcflx_x(I,J) - 1.0 * & - qqsfc * (1.0 - 0.5 * (ABS(j-JYY0))) - else - q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + 0. - end if - if (JYY0.gt.j) then - q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc * & - (1.0 - 0.5 * (ABS(i-IXX0))) - elseif (JYY0.lt.j) then - q_sfcflx_y(I,J) = q_sfcflx_y(I,J) - 1.0 * & - qqsfc * (1.0 - 0.5 * (ABS(i-IXX0))) - else - q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + 0. - end if - - -!DJG put adjustment in for (h) due to qqsfc - -!yw changed as following: - tmp_adjust=qqsfc*1000 - if((h(i,j) - tmp_adjust) <0 ) then -#ifdef HYDRO_D - print*, "Error Warning: surface head is negative: ",i,j,ixx0,jyy0, & - h(i,j) - tmp_adjust -#endif - tmp_adjust = h(i,j) - end if - DH(i,j) = DH(i,j)-tmp_adjust - DH_tmp(ixx0,jyy0) = DH_tmp(ixx0,jyy0) + tmp_adjust - !yw end change - - !DG Boundary adjustments here - !DG Constant Flux Condition -#ifdef MPP_LAND - if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. & - ((ixx0.eq.1) .and.(left_id .lt. 0)) .or. & - ((jyy0.eq.1) .and.(down_id .lt. 0)) .or. & - ((JYY0.eq.YY).and.(up_id .lt. 0)) ) then - QBDRY_tmp(IXX0,JYY0)=QBDRY_tmp(IXX0,JYY0) - qqsfc*1000. -#else - if ((ixx0.eq.XX).or.(ixx0.eq.1).or.(jyy0.eq.1) & - .or.(JYY0.eq.YY )) then - QBDRY(IXX0,JYY0)=QBDRY(IXX0,JYY0) - qqsfc*1000. -#endif - QBDRYT=QBDRYT - qqsfc - DH_tmp(IXX0,JYY0)= DH_tmp(IXX0,JYY0)-tmp_adjust - end if - end if -!! End loop to route sfc water - end if - end do - end do - -#ifdef MPP_LAND -! use double precision to solve the underflow problem. - call MPP_LAND_COM_REAL8(DH_tmp,XX,YY,1) - call MPP_LAND_COM_REAL8(QBDRY_tmp,XX,YY,1) -#endif - QBDRY = QBDRY + QBDRY_tmp - DH = DH+DH_tmp - -#ifdef MPP_LAND - call MPP_LAND_COM_REAL8(DH,XX,YY,99) - call MPP_LAND_COM_REAL(QBDRY,XX,YY,99) -#endif - - H = H + DH - - return - -!DJG ---------------------------------------------------------------------- - end subroutine ROUTE_OVERLAND1 - - -!DJG ---------------------------------------------------------------- - SUBROUTINE GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,sox,tmp_gsize,max,XX,YY) - implicit none - INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY - INTEGER, INTENT(IN) :: I,J - - REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY,8),tmp_gsize(9) - REAL max - IXX0 = -1 - max = 0 - if (h(I,J).LE.retent_dep(I,J)) return - - IXX8 = I - JYY8 = J+1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY) - - IXX8 = I+1 - JYY8 = J+1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY) - - IXX8 = I+1 - JYY8 = J - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY) - - IXX8 = I+1 - JYY8 = J-1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY) - - IXX8 = I - JYY8 = J-1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY) - - IXX8 = I-1 - JYY8 = J-1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY) - - IXX8 = I-1 - JYY8 = J - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY) - - IXX8 = I-1 - JYY8 = J+1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY) - RETURN - END SUBROUTINE GETMAX8DIR - - SUBROUTINE GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox & - ,IXX0,JYY0,max,tmp_gsize,XX,YY) - implicit none - integer,INTENT(INOUT) ::IXX0,JYY0 - INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY - REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY) - REAL, INTENT(INOUT) ::max - real, INTENT(IN) :: tmp_gsize - real :: sfx - - sfx = sox(i,j)-(h(IXX8,JYY8)-h(i,j))*0.001/tmp_gsize - if(sfx .le. 0 ) return - if(max < sfx ) then - IXX0 = IXX8 - JYY0 = JYY8 - max = sfx - end if - - END SUBROUTINE GET8DIR -!DJG ---------------------------------------------------------------- -!DJG SUBROUTINE ROUTE_SUBSURFACE1 -!DJG ---------------------------------------------------------------- - - SUBROUTINE ROUTE_SUBSURFACE1( & - dist,z,qsub,sox,soy, & - latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,SO8RT,SO8RT_D, & - CWATAVAIL,SUBDT) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Subroutine to route subsurface flow through the watershed -! -! Called from: main.f (Noah_router_driver) -! -! Returns: qsub=DQSUB which in turn becomes SUBFLO in head calc. -! -! Created: D. Gochis 3/27/03 -! Adaptded from Wigmosta, 1994 -! -! Modified: D. Gochis 1/05/04 -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id,& - up_id,mpp_land_com_real8,my_id,mpp_land_com_real -#endif - - IMPLICIT NONE - - -!! Declare Passed variables - - INTEGER, INTENT(IN) :: XX,YY - -!! Declare passed arrays - - REAL, INTENT(IN), DIMENSION(XX,YY) :: z - REAL, INTENT(IN), DIMENSION(XX,YY) :: sox - REAL, INTENT(IN), DIMENSION(XX,YY) :: soy - REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat - REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL - REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep - REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY - REAL, INTENT(INOUT) :: QSUBDRYT - REAL*8, DIMENSION(XX,YY) :: qsub_tmp,QSUBDRY_tmp -!yw INTEGER, INTENT(OUT) :: flag - REAL, INTENT(IN) :: dist(xx,yy,9),SUBDT - -!!! Declare Local Variables - - REAL :: dzdx,dzdy,beta,gamma - REAL :: qqsub,hh,ksat - - REAL :: SO8RT(XX,YY,8) - INTEGER :: SO8RT_D(XX,YY,3), rt_option - - -!!! Initialize variables - - REAL, PARAMETER :: nexp=1.0 ! local power law exponent - integer IXX0,JYY0,index,i,j - real tmp_gsize - -! temporary set it to be 2. Should be passed in. -!yw soldep = 2. -! Begin Subsurface routing - - - -!!! Loop to route water in x-direction - qsub_tmp = 0. - QSUBDRY_tmp = 0. - -#ifdef HYDRO_D - write(6,*) "call subsurface routing xx= , yy =", yy, xx -#endif - - do j=2,YY-1 - do i=2,XX-1 - - - if(i.ge.2.AND.i.le.XX-1.AND.j.ge.2.AND.j.le.YY-1) then !if grdcl chk -! check for boundary grid point? - IXX0 = SO8RT_D(i,j,1) - JYY0 = SO8RT_D(i,j,2) - - index = SO8RT_D(i,j,3) - - if(dist(i,j,index) .le. 0) then -#ifdef HYDRO_D - write(6,*) "Error: dist(i,j,index) is <= zero " - call hydro_stop("ROUTE_SUBSURFACE1") -#endif - endif - if(soldep(i,j) .eq. 0) then -#ifdef HYDRO_D - write(6,*) "Error: soldep is = zero " - call hydro_stop("ROUTE_SUBSURFACE1") -#endif - endif - - tmp_gsize = 1.0/dist(i,j,index) - - - dzdx= (z(i,j) - z(IXX0,JYY0) )* tmp_gsize - beta=so8RT(i,j,index) + dzdx - - if(beta .lt. 1E-20 ) then !if-then for direction... - call GETSUB8(IXX0,JYY0,I,J,Z,so8rt,dist(i,j,:),beta,XX,YY) - end if - if(beta .gt. 0) then !if-then for flux calc - if(beta .lt. 1E-20 ) then -#ifdef HYDRO_D - print*, "Message: beta need to be reset to 1E-20. beta = ",beta -#endif - beta = 1E-20 - end if - -! do the rest if the lowest grid can be found. - hh=(1-(z(i,j)/soldep(i,j)))**nexp - ksat=latksat(i,j) - - if (hh .lt. 0.) then -#ifdef HYDRO_D - print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), & - soldep(i,j) - call hydro_stop("ROUTE_SUBSURFACE1") -#endif - end if - -!err. tan slope gamma=-1.0*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) - gamma=-1.0*((dist(i,j,index)*ksat*soldep(i,j))/nexp)*beta - qqsub = gamma * hh - - qsub(i,j) = qsub(i,j) + qqsub - qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) - qqsub - -!!DJG Error Checks... - if(qqsub .gt. 0) then -#ifdef HYDRO_D - print*, "Error: qqsub should be negative, qqsub =",qqsub,& - "gamma=",gamma,"hh=",hh,"beta=",beta,"dzdx=",dzdx,& - "so8RT=",so8RT(i,j,index),"latksat=",ksat, & - "tan(beta)=",tan(beta),i,j,z(i,j),z(IXX0,JYY0) - print*, "ixx0=",ixx0, "jyy0=",jyy0 - print*, "soldep =", soldep(i,j), "nexp=",nexp - call hydro_stop("ROUTE_SUBSURFACE1") -#endif - end if - - - - -! Boundary adjustments -#ifdef MPP_LAND - if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. & - ((ixx0.eq.1) .and.(left_id .lt. 0)) .or. & - ((jyy0.eq.1) .and.(down_id .lt. 0)) .or. & - ((JYY0.eq.YY).and.(up_id .lt. 0)) ) then -#else - if ((ixx0.eq.1).or.(ixx0.eq.xx).or.(jyy0.eq.1).or.(jyy0.eq.yy)) then -#endif - qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) + qqsub - QSUBDRY_tmp(ixx0,jyy0) = QSUBDRY_tmp(ixx0,jyy0) + qqsub - - QSUBDRYT = QSUBDRYT + qqsub - end if - -998 continue - -!! End loop to route sfc water in x-direction - end if !endif for flux calc - - endif !! Endif for gridcell check... - - - end do !endif for i-dim -!CRNT debug if(flag.eq.-99) exit !exit loop for courant violation... - end do !endif for j-dim - -#ifdef MPP_LAND - - call MPP_LAND_COM_REAL8(qsub_tmp,XX,YY,1) - call MPP_LAND_COM_REAL8(QSUBDRY_tmp,XX,YY,1) -#endif - qsub = qsub + qsub_tmp - QSUBDRY= QSUBDRY + QSUBDRY_tmp - - - do j=2,YY-1 - do i=2,XX-1 - if(dist(i,j,9) .le. 0) then -#ifdef HYDRO_D - write(6,*) "Error: dist(i,j,9) is <= zero " - call hydro_stop("ROUTE_SUBSURFACE1") -#endif - endif - if(CWATAVAIL(i,j).lt.ABS(qsub(i,j))/dist(i,j,9)*SUBDT) THEN - qsub(i,j) = -1.0*CWATAVAIL(i,j) - end if - end do - end do -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(qsub,XX,YY,99) - call MPP_LAND_COM_REAL(QSUBDRY,XX,YY,99) -#endif - - - return -!DJG------------------------------------------------------------ - end subroutine ROUTE_SUBSURFACE1 -!DJG------------------------------------------------------------ - -!DJG------------------------------------------------------------ - - - SUBROUTINE GETSUB8(IXX0,JYY0,I,J,Z,sox,tmp_gsize,max,XX,YY) - implicit none - INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY - INTEGER, INTENT(IN) :: I,J - - REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY,8),tmp_gsize(9) - REAL max - max = -1 - - IXX8 = I - JYY8 = J+1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY) - - IXX8 = I+1 - JYY8 = J+1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY) - - IXX8 = I+1 - JYY8 = J - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY) - - IXX8 = I+1 - JYY8 = J-1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY) - - IXX8 = I - JYY8 = J-1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY) - - IXX8 = I-1 - JYY8 = J-1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY) - - IXX8 = I-1 - JYY8 = J - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY) - - IXX8 = I-1 - JYY8 = J+1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY) - RETURN - END SUBROUTINE GETSUB8 - - SUBROUTINE GETSUB8DIR(IXX8,JYY8,I,J,Z,sox,IXX0,JYY0,max,tmp_gsize,XX,YY) - implicit none - integer,INTENT(INOUT) ::IXX0,JYY0 - INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY - REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY) - REAL, INTENT(INOUT) ::max - real, INTENT(IN) :: tmp_gsize - real :: beta , dzdx - - dzdx= (z(i,j) - z(IXX0,JYY0) )/tmp_gsize - beta=sox(i,j) + dzdx - if(max < beta ) then - IXX0 = IXX8 - JYY0 = JYY8 - max = beta - end if - - END SUBROUTINE GETSUB8DIR -!DJG ---------------------------------------------------------------------- - -!DJG SUBROUTINE ROUTE_OVERLAND2 -!DJG ---------------------------------------------------------------- - - SUBROUTINE ROUTE_OVERLAND2 (dt, & - & dist,h,qsfc,sox,soy, & - & retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT, & - & q_sfcflx_x,q_sfcflx_y) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Subroutine to route excess rainfall over the watershed -! using a 2d diffusion routing scheme. -! -! Called from: main.f -! -! Will try to formulate this to be called from NOAH -! -! Returns: qsfc=DQOV which in turn becomes DH in head calc. -! -! Created: Adaptded from CASC2D source code -! NOTE: dh from original code has been replaced by qsfc -! dhh replaced by qqsfc -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id,& - up_id,mpp_land_com_real,MPP_LAND_UB_COM, & - MPP_LAND_LR_COM,mpp_land_com_integer -#endif - - IMPLICIT NONE - - -!! Declare Passed variables - - real :: gsize - INTEGER, INTENT(IN) :: XX,YY - REAL, INTENT(IN) :: dt , dist(XX,YY,9) - -!! Declare passed arrays - - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: qsfc - REAL, INTENT(IN), DIMENSION(XX,YY) :: sox - REAL, INTENT(IN), DIMENSION(XX,YY) :: soy - REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep - REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x,q_sfcflx_y - REAL, INTENT(INOUT) :: QBDRYT - REAL :: DH(XX,YY) - -!!! Declare Local Variables - - REAL :: dhdx,dhdy,alfax,alfay - REAL :: hh53,qqsfc,hh,dt_new - REAL :: sfx,sfy - REAL :: tmp_adjust - - INTEGER :: i,j - -!!! Initialize variables - - - - -!!! Begin Routing of Excess Rainfall over the Watershed - - - DH = 0 -!!! Loop to route water in x-direction - do j=1,YY - do i=1,XX - - -! check for boundary gridpoint? - if (i.eq.XX) GOTO 998 - gsize = dist(i,j,3) - - -! check for detention storage? - if (h(i,j).lt.retent_dep(i,j).AND. & - h(i+1,j).lt.retent_dep(i+1,j)) GOTO 998 - - dhdx = (h(i+1,j)/1000. - h(i,j)/1000.) / gsize ! gisze-(m),h-(mm) - - sfx = (sox(i,j)-dhdx+1E-30) - if (abs(sfx).lt.1E-20) sfx=1E-20 - alfax = ((abs(sfx))**0.5)/dist_rough(i,j) - if (sfx.lt.0.) then - hh=(h(i+1,j)-retent_dep(i+1,j))/1000. - else - hh=(h(i,j)-retent_dep(i,j))/1000. - end if - - if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 998 - if (hh.lt.0.) then - GOTO 998 - end if - - hh53=hh**(5./3.) - - -! Calculate q-flux... (units (m)) - qqsfc = (sfx/abs(sfx))*alfax*hh53*dt/gsize - q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc - -!DJG put adjustment in for (h) due to qqsfc - -!yw changed as following: - tmp_adjust=qqsfc*1000 - if(tmp_adjust .le. 0 ) GOTO 998 - if((h(i,j) - tmp_adjust) <0 ) then -#ifdef HYDRO_D - print*, "Error Warning: surface head is negative: ",i,j -#endif - tmp_adjust = h(i,j) - end if - if((h(i+1,j) + tmp_adjust) <0) then -#ifdef HYDRO_D - print*, "Error Warning: surface head is negative: ",i+1,j -#endif - tmp_adjust = -1*h(i+1,j) - end if - Dh(i,j) = Dh(i,j)-tmp_adjust - Dh(i+1,j) = Dh(i+1,j) + tmp_adjust -!yw end change - - - -!DG Boundary adjustments here -!DG Constant Flux Condition -#ifdef MPP_LAND - if ((i.eq.1).AND.(sfx.lt.0).and. & - (left_id .lt. 0) ) then -#else - if ((i.eq.1).AND.(sfx.lt.0)) then -#endif - Dh(i,j) = Dh(i,j) + qqsfc*1000. - QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000. - QBDRYT=QBDRYT + qqsfc*1000. -#ifdef MPP_LAND - else if ( (i.eq.(XX-1)).AND.(sfx.gt.0) & - .and. (right_id .lt. 0) ) then -#else - else if ((i.eq.(XX-1)).AND.(sfx.gt.0)) then -#endif - tmp_adjust = qqsfc*1000. - if(h(i+1,j).lt.tmp_adjust) tmp_adjust = h(i+1,j) - Dh(i+1,j) = Dh(i+1,j) - tmp_adjust -!DJG Re-assign h(i+1) = 0.0 when <0.0 (from rounding/truncation error) - QBDRY(I+1,J)=QBDRY(I+1,J) - tmp_adjust - QBDRYT=QBDRYT - tmp_adjust - end if - - -998 continue - -!! End loop to route sfc water in x-direction - end do - end do - - H = H + DH -#ifdef MPP_LAND - call MPP_LAND_LR_COM(H,XX,YY,99) - call MPP_LAND_LR_COM(QBDRY,XX,YY,99) -#endif - - - DH = 0 -!!!! Loop to route water in y-direction - do j=1,YY - do i=1,XX - -!! check for boundary grid point? - if (j.eq.YY) GOTO 999 - gsize = dist(i,j,1) - - -!! check for detention storage? - if (h(i,j).lt.retent_dep(i,j).AND. & - h(i,j+1).lt.retent_dep(i,j+1)) GOTO 999 - - dhdy = (h(i,j+1)/1000. - h(i,j)/1000.) / gsize - - sfy = (soy(i,j)-dhdy+1E-30) - if (abs(sfy).lt.1E-20) sfy=1E-20 - alfay = ((abs(sfy))**0.5)/dist_rough(i,j) - if (sfy.lt.0.) then - hh=(h(i,j+1)-retent_dep(i,j+1))/1000. - else - hh=(h(i,j)-retent_dep(i,j))/1000. - end if - - if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 999 - if (hh.lt.0.) then - GOTO 999 - end if - - hh53=hh**(5./3.) - -! Calculate q-flux... - qqsfc = (sfy/abs(sfy))*alfay*hh53*dt / gsize - q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc - - -!DJG put adjustment in for (h) due to qqsfc -!yw h(i,j) = h(i,j)-qqsfc*1000. -!yw h(i,j+1) = h(i,j+1) + qqsfc*1000. -!yw changed as following: - tmp_adjust=qqsfc*1000 - if(tmp_adjust .le. 0 ) GOTO 999 - - if((h(i,j) - tmp_adjust) <0 ) then -#ifdef HYDRO_D - print*, "Error Warning: surface head is negative: ",i,j -#endif - tmp_adjust = h(i,j) - end if - if((h(i,j+1) + tmp_adjust) <0) then -#ifdef HYDRO_D - print*, "Error Warning: surface head is negative: ",i,j+1 -#endif - tmp_adjust = -1*h(i,j+1) - end if - Dh(i,j) = Dh(i,j)-tmp_adjust - Dh(i,j+1) = Dh(i,j+1) + tmp_adjust -!yw end change - -! qsfc(i,j) = qsfc(i,j)-qqsfc -! qsfc(i,j+1) = qsfc(i,j+1) + qqsfc -!!DG Boundary adjustments here -!!DG Constant Flux Condition -#ifdef MPP_LAND - if ((j.eq.1).AND.(sfy.lt.0) & - .and. (down_id .lt. 0) ) then -#else - if ((j.eq.1).AND.(sfy.lt.0)) then -#endif - Dh(i,j) = Dh(i,j) + qqsfc*1000. - QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000. - QBDRYT=QBDRYT + qqsfc*1000. -#ifdef MPP_LAND - else if ((j.eq.(YY-1)).AND.(sfy.gt.0) & - .and. (up_id .lt. 0) ) then -#else - else if ((j.eq.(YY-1)).AND.(sfy.gt.0)) then -#endif - tmp_adjust = qqsfc*1000. - if(h(i,j+1).lt.tmp_adjust) tmp_adjust = h(i,j+1) - Dh(i,j+1) = Dh(i,j+1) - tmp_adjust -!DJG Re-assign h(j+1) = 0.0 when <0.0 (from rounding/truncation error) - QBDRY(I,J+1)=QBDRY(I,J+1) - tmp_adjust - QBDRYT=QBDRYT - tmp_adjust - end if - -999 continue - -!!!! End loop to route sfc water in y-direction - end do - end do - - H = H +DH -#ifdef MPP_LAND - call MPP_LAND_UB_COM(H,XX,YY,99) - call MPP_LAND_UB_COM(QBDRY,XX,YY,99) -#endif - return - -!DJG ---------------------------------------------------------------------- - end subroutine ROUTE_OVERLAND2 - - -!DJG ---------------------------------------------------------------------- - - -!DJG----------------------------------------------------------------------- -!DJG SUBROUTINE TER_ADJ_SOL - Terrain adjustment of incoming solar radiation -!DJG----------------------------------------------------------------------- - SUBROUTINE TER_ADJ_SOL(IX,JX,SO8LD_D,TSLP,SHORT,XLAT,XLONG,olddate,DT) - -#ifdef MPP_LAND - use module_mpp_land, only: my_id, io_id, & - mpp_land_bcast_int1 -#endif - implicit none - integer,INTENT(IN) :: IX,JX - INTEGER,INTENT(in), DIMENSION(IX,JX,3) :: SO8LD_D - real,INTENT(IN), DIMENSION(IX,JX) :: XLAT,XLONG - real,INTENT(IN) :: DT - real,INTENT(INOUT), DIMENSION(IX,JX) :: SHORT - character(len=19) :: olddate - -! Local Variables... - real, dimension(IX,JX) ::TSLP,TAZI - real, dimension(IX,JX) ::SOLDN - real :: SOLDEC,DGRD,ITIME2,HRANGLE - real :: BINSH,SOLZANG,SOLAZI,INCADJ - real :: TAZIR,TSLPR,LATR,LONR,SOLDNADJ - integer :: JULDAY0,HHTIME0,MMTIME0,YYYY0,MM0,DD0 - integer :: JULDAY,HHTIME,MMTIME,YYYY,MM,DD - integer :: I,J - - -!---------------------------------------------------------------------- -! SPECIFY PARAMETERS and VARIABLES -!---------------------------------------------------------------------- - - JULDAY = 0 - SOLDN = SHORT - DGRD = 3.14159/180. - -! Set up time variables... -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - read(olddate(1:4),"(I4)") YYYY0 ! real-time year (GMT) - read(olddate(6:7),"(I2.2)") MM0 ! real-time month (GMT) - read(olddate(9:10),"(I2.2)") DD0 ! real-time day (GMT) - read(olddate(12:13),"(I2.2)") HHTIME0 ! real-time hour (GMT) - read(olddate(15:16),"(I2.2)") MMTIME0 ! real-time minutes (GMT) -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(YYYY0) - call mpp_land_bcast_int1(MM0) - call mpp_land_bcast_int1(DD0) - call mpp_land_bcast_int1(HHTIME0) - call mpp_land_bcast_int1(MMTIME0) -#endif - - -! Set up terrain variables...(returns TSLP&TAZI in radians) - call SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) - -!---------------------------------------------------------------------- -! BEGIN LOOP THROUGH GRID -!---------------------------------------------------------------------- - DO J=1,JX - DO I=1,IX - YYYY = YYYY0 - MM = MM0 - DD = DD0 - HHTIME = HHTIME0 - MMTIME = MMTIME0 - call GMT2LOCAL(1,1,XLONG(i,j),YYYY,MM,DD,HHTIME,MMTIME,DT) - call JULDAY_CALC(YYYY,MM,DD,JULDAY) - -! Convert to radians... - LATR = XLAT(I,J) !send solsub local lat in deg - LONR = XLONG(I,J) !send solsub local lon in deg - TSLPR = TSLP(I,J)/DGRD !send solsub local slp in deg - TAZIR = TAZI(I,J)/DGRD !send solsub local azim in deg - -!Call SOLSUB to return terrain adjusted incoming solar radiation... -! SOLSUB taken from Whiteman and Allwine, 1986, Environ. Software. - - call SOLSUB(LONR,LATR,TAZIR,TSLPR,SOLDN(I,J),YYYY,MM, & - DD,HHTIME,MMTIME,SOLDNADJ,SOLZANG,SOLAZI,INCADJ) - - SOLDN(I,J)=SOLDNADJ - - ENDDO - ENDDO - - SHORT = SOLDN - - return - end SUBROUTINE TER_ADJ_SOL -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE TER_ADJ_SOL -!DJG----------------------------------------------------------------------- - - -!DJG----------------------------------------------------------------------- -!DJG SUBROUTINE GMT2LOCAL -!DJG----------------------------------------------------------------------- - subroutine GMT2LOCAL(IX,JX,XLONG,YY,MM,DD,HH,MIN,DT) - - implicit none - -!!! Declare Passed Args. - - INTEGER, INTENT(INOUT) :: yy,mm,dd,hh,min - INTEGER, INTENT(IN) :: IX,JX - REAL,INTENT(IN), DIMENSION(IX,JX) :: XLONG - REAL,INTENT(IN) :: DT - -!!! Declare local variables - - integer :: i,j,minflag,hhflag,ddflag,mmflag,yyflag - integer :: adj_min,lst_adj_min,lst_adj_hh,adj_hh - real, dimension(IX,JX) :: TDIFF - real :: tmp - integer :: yyinit,mminit,ddinit,hhinit,mininit - -!!! Initialize flags - hhflag=0 - ddflag=0 - mmflag=0 - yyflag=0 - -!!! Set up constants... - yyinit = yy - mminit = mm - ddinit = dd - hhinit = hh - mininit = min - - -! Loop through data... - do j=1,JX - do i=1,IX - -! Reset yy,mm,dd... - yy = yyinit - mm = mminit - dd = ddinit - hh = hhinit - min = mininit - -!!! Set up adjustments... -! - assumes +E , -W longitude and 0.06667 hr/deg (=24/360) - TDIFF(I,J) = XLONG(I,J)*0.06667 ! time offset in hr - tmp = TDIFF(I,J) - lst_adj_hh = INT(tmp) - lst_adj_min = NINT(MOD(int(tmp),1)*60.) + int(DT/2./60.) ! w/ 1/2 timestep adjustment... - -!!! Process Minutes... - adj_min = min+lst_adj_min - if (adj_min.lt.0) then - min=60+adj_min - lst_adj_hh = lst_adj_hh - 1 - else if (adj_min.ge.0.AND.adj_min.lt.60) then - min=adj_min - else if (adj_min.ge.60) then - min=adj_min-60 - lst_adj_hh = lst_adj_hh + 1 - end if - -!!! Process Hours - adj_hh = hh+lst_adj_hh - if (adj_hh.lt.0) then - hh = 24+adj_hh - ddflag=1 - else if (adj_hh.ge.0.AND.adj_hh.lt.24) then - hh=adj_hh - else if (adj_hh.ge.24) then - hh=adj_hh-24 - ddflag = 2 - end if - - - -!!! Process Days, Months, Years -! Subtract a day - if (ddflag.eq.1) then - if (dd.gt.1) then - dd=dd-1 - else - if (mm.eq.1) then - mm=12 - yy=yy-1 - else - mm=mm-1 - end if - if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & - (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & - (mm.eq.12)) then - dd=31 - else - -!!! Adjustment for leap years!!! - if(mm.eq.2) then - if(MOD(yy,4).eq.0) then - dd=29 - else - dd=28 - end if - end if - if(mm.ne.2) dd=30 - end if - end if - end if - -! Add a day - if (ddflag.eq.2) then - if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & - (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & - (mm.eq.12)) then - if (dd.eq.31) then - dd=1 - if (mm.eq.12) then - mm=1 - yy=yy+1 - else - mm=mm+1 - end if - else - dd=dd+1 - end if - -!!! Adjustment for leap years!!! - else if (mm.eq.2) then - if(MOD(yy,4).eq.0) then - if (dd.eq.29) then - dd=1 - mm=3 - else - dd=dd+1 - end if - else - if (dd.eq.28) then - dd=1 - mm=3 - else - dd=dd+1 - end if - end if - else - if (dd.eq.30) then - dd=1 - mm=mm+1 - else - dd=dd+1 - end if - end if - - end if - - end do !i-loop - end do !j-loop - - return - end subroutine - -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE GMT2LOCAL -!DJG----------------------------------------------------------------------- - - - -!DJG----------------------------------------------------------------------- -!DJG SUBROUTINE JULDAY_CALC -!DJG----------------------------------------------------------------------- - subroutine JULDAY_CALC(YYYY,MM,DD,JULDAY) - - implicit none - integer,intent(in) :: YYYY,MM,DD - integer,intent(out) :: JULDAY - - integer :: resid - integer julm(13) - DATA JULM/0, 31, 59, 90, 120, 151, 181, 212, 243, 273, & - 304, 334, 365 / - - integer LPjulm(13) - DATA LPJULM/0, 31, 60, 91, 121, 152, 182, 213, 244, 274, & - 305, 335, 366 / - - resid = MOD(YYYY,4) !Set up leap year check... - - if (resid.ne.0) then !If not a leap year.... - JULDAY = JULM(MM) + DD - else !If a leap year... - JULDAY = LPJULM(MM) + DD - end if - - RETURN - END subroutine JULDAY_CALC -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE JULDAY -!DJG----------------------------------------------------------------------- - -!DJG----------------------------------------------------------------------- -!DJG SUBROUTINE SLOPE_ASPECT -!DJG----------------------------------------------------------------------- - subroutine SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) - - implicit none - integer, INTENT(IN) :: IX,JX -! real,INTENT(in),DIMENSION(IX,JX) :: TSLP !terrain slope (m/m) - real,INTENT(OUT),DIMENSION(IX,JX) :: TAZI !terrain aspect (deg) - - INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D - real :: DGRD - integer :: i,j - -! TSLP = 0. !Initialize as flat - TAZI = 0. !Initialize as north facing - -! Find steepest descent slope and direction... - do j=1,JX - do i=1,IX -! TSLP(I,J) = TANH(Vmax(i,j)) ! calculate slope in radians... - -! Convert steepest slope and aspect to radians... - IF (SO8LD_D(i,j,3).eq.1) then - TAZI(I,J) = 0.0 - ELSEIF (SO8LD_D(i,j,3).eq.2) then - TAZI(I,J) = 45.0 - ELSEIF (SO8LD_D(i,j,3).eq.3) then - TAZI(I,J) = 90.0 - ELSEIF (SO8LD_D(i,j,3).eq.4) then - TAZI(I,J) = 135.0 - ELSEIF (SO8LD_D(i,j,3).eq.5) then - TAZI(I,J) = 180.0 - ELSEIF (SO8LD_D(i,j,3).eq.6) then - TAZI(I,J) = 225.0 - ELSEIF (SO8LD_D(i,j,3).eq.7) then - TAZI(I,J) = 270.0 - ELSEIF (SO8LD_D(i,j,3).eq.8) then - TAZI(I,J) = 315.0 - END IF - - DGRD = 3.141593/180. - TAZI(I,J) = TAZI(I,J)*DGRD ! convert azimuth to radians... - - END DO - END DO - - RETURN - END subroutine SLOPE_ASPECT -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE SLOPE_ASPECT -!DJG----------------------------------------------------------------------- - -!DJG---------------------------------------------------------------- -!DJG SUBROUTINE SOLSUB -!DJG---------------------------------------------------------------- - SUBROUTINE SOLSUB(LONG,LAT,AZ,IN,SC,YY,MO,IDA,IHR,MM,OUT1, & - OUT2,OUT3,INCADJ) - - -! Notes.... - - implicit none - logical :: daily, first - integer :: yy,mo,ida,ihr,mm,d - integer,dimension(12) :: nday - real :: lat,long,longcor,longsun,in,inslo - real :: az,sc,out1,out2,out3,cosbeta,dzero,eccent,pi,calint - real :: rtod,decmax,omega,onehr,omd,omdzero,rdvecsq,sdec - real :: declin,cdec,arg,declon,sr,stdmrdn,b,em,timnoon,azslo - real :: slat,clat,caz,saz,sinc,cinc,hinc,h,cosz,extra,extslo - real :: t1,z,cosa,a,cosbeta_flat,INCADJ - integer :: HHTIME,MMTIME,i,ik - real, dimension(4) :: ACOF,BCOF - -! Constants - daily=.FALSE. - ACOF(1) = 0.00839 - ACOF(2) = -0.05391 - ACOF(3) = -0.00154 - ACOF(4) = -0.0022 - BCOF(1) = -0.12193 - BCOF(2) = -0.15699 - BCOF(3) = -0.00657 - BCOF(4) = -0.00370 - DZERO = 80. - ECCENT = 0.0167 - PI = 3.14159 - CALINT = 1. - RTOD = PI / 180. - DECMAX=(23.+26./60.)*RTOD - OMEGA=2*PI/365. - ONEHR=15.*RTOD - -! Calculate Julian Day... - D = 0 - call JULDAY_CALC(YY,MO,IDA,D) - -! Ratio of radius vectors squared... - OMD=OMEGA*D - OMDZERO=OMEGA*DZERO -! RDVECSQ=1./(1.-ECCENT*COS(OMD))**2 - RDVECSQ = 1. ! no adjustment for orbital changes when coupled to HRLDAS... - -! Declination of sun... - LONGSUN=OMEGA*(D-Dzero)+2.*ECCENT*(SIN(OMD)-SIN(OMDZERO)) - DECLIN=ASIN(SIN(DECMAX)*SIN(LONGSUN)) - SDEC=SIN(DECLIN) - CDEC=COS(DECLIN) - -! Check for Polar Day/night... - ARG=((PI/2.)-ABS(DECLIN))/RTOD - IF(ABS(LAT).GT.ARG) THEN - IF((LAT.GT.0..AND.DECLIN.LT.0) .OR. & - (LAT.LT.0..AND.DECLON.GT.0.)) THEN - OUT1 = 0. - OUT2 = 0. - OUT3 = 0. - RETURN - ENDIF - SR=-1.*PI - ELSE - -! Calculate sunrise hour angle... - SR=-1.*ABS(ACOS(-1.*TAN(LAT*RTOD)*TAN(DECLIN))) - END IF - -! Find standard meridian for site - STDMRDN=NINT(LONG/15.)*15. - LONGCOR=(LONG-STDMRDN)/15. - -! Compute time correction from equation of time... - B=2.*PI*(D-.4)/365 - EM=0. - DO I=1,4 - EM=EM+(BCOF(I)*SIN(I*B)+ACOF(I)*COS(I*B)) - END DO - -! Compute time of solar noon... - TIMNOON=12.-EM-LONGCOR - -! Set up a few more terms... - AZSLO=AZ*RTOD - INSLO=IN*RTOD - SLAT=SIN(LAT*RTOD) - CLAT=COS(LAT*RTOD) - CAZ=COS(AZSLO) - SAZ=SIN(AZSLO) - SINC=SIN(INSLO) - CINC=COS(INSLO) - -! Begin solar radiation calculations...daily first, else instantaneous... - IF (DAILY) THEN ! compute daily integrated values...(Not used in HRLDAS!) - IHR=0 - MM=0 - HINC=CALINT*ONEHR/60. - IK=(2.*ABS(SR)/HINC)+2. - FIRST=.TRUE. - OUT1=0. - DO I=1,IK - H=SR+HINC*FLOAT(I-1) - COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) - COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & - SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & - SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) - EXTRA=SC*RDVECSQ*COSZ - IF(EXTRA.LE.0.) EXTRA=0. - EXTSLO=SC*RDVECSQ*COSBETA - IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. - IF(FIRST .AND. EXTSLO.GT.0.) THEN - OUT2=(H-HINC)/ONEHR+TIMNOON - FIRST = .FALSE. - END IF - IF(.NOT.FIRST .AND. EXTSLO.LE.0.) OUT3=H/ONEHR+TIMNOON - OUT1=EXTSLO+OUT1 - END DO - OUT1=OUT1*CALINT*60./1000000. - - ELSE ! Compute instantaneous values...(Is used in HRLDAS!) - - T1=FLOAT(IHR)+FLOAT(MM)/60. - H=ONEHR*(T1-TIMNOON) - COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) - -! Assuming HRLDAS forcing already accounts for season, time of day etc, -! subtract out the component of adjustment that would occur for -! a flat surface, this should leave only the sloped component remaining - - COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & - SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & - SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) - - COSBETA_FLAT=CDEC*CLAT*COS(H)+SDEC*SLAT - - INCADJ = COSBETA+(1-COSBETA_FLAT) - - EXTRA=SC*RDVECSQ*COSZ - IF(EXTRA.LE.0.) EXTRA=0. - EXTSLO=SC*RDVECSQ*INCADJ -! IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. !remove check for HRLDAS. - OUT1=EXTSLO - Z=ACOS(COSZ) - COSA=(SLAT*COSZ-SDEC)/(CLAT*SIN(Z)) - IF(COSA.LT.-1.) COSA=-1. - IF(COSA.GT.1.) COSA=1. - A=ABS(ACOS(COSA)) - IF(H.LT.0.) A=-A - OUT2=Z/RTOD - OUT3=A/RTOD+180 - - END IF ! End if for daily vs instantaneous values... - -!DJG----------------------------------------------------------------------- - RETURN - END SUBROUTINE SOLSUB -!DJG----------------------------------------------------------------------- - - subroutine seq_land_SO8(SO8LD_D,Vmax,TERR,dx,ix,jx) - implicit none - integer :: ix,jx,i,j - REAL, DIMENSION(IX,JX,8) :: SO8LD - INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D - real,DIMENSION(IX,JX) :: TERR - real :: dx(ix,jx,9),Vmax(ix,jx) - SO8LD_D = -1 - do j = 2, jx -1 - do i = 2, ix -1 - SO8LD(i,j,1) = (TERR(i,j)-TERR(i,j+1))/dx(i,j,1) - SO8LD_D(i,j,1) = i - SO8LD_D(i,j,2) = j + 1 - SO8LD_D(i,j,3) = 1 - Vmax(i,j) = SO8LD(i,j,1) - - SO8LD(i,j,2) = (TERR(i,j)-TERR(i+1,j+1))/DX(i,j,2) - if(SO8LD(i,j,2) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i + 1 - SO8LD_D(i,j,2) = j + 1 - SO8LD_D(i,j,3) = 2 - Vmax(i,j) = SO8LD(i,j,2) - end if - SO8LD(i,j,3) = (TERR(i,j)-TERR(i+1,j))/DX(i,j,3) - if(SO8LD(i,j,3) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i + 1 - SO8LD_D(i,j,2) = j - SO8LD_D(i,j,3) = 3 - Vmax(i,j) = SO8LD(i,j,3) - end if - SO8LD(i,j,4) = (TERR(i,j)-TERR(i+1,j-1))/DX(i,j,4) - if(SO8LD(i,j,4) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i + 1 - SO8LD_D(i,j,2) = j - 1 - SO8LD_D(i,j,3) = 4 - Vmax(i,j) = SO8LD(i,j,4) - end if - SO8LD(i,j,5) = (TERR(i,j)-TERR(i,j-1))/DX(i,j,5) - if(SO8LD(i,j,5) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - SO8LD_D(i,j,2) = j - 1 - SO8LD_D(i,j,3) = 5 - Vmax(i,j) = SO8LD(i,j,5) - end if - SO8LD(i,j,6) = (TERR(i,j)-TERR(i-1,j-1))/DX(i,j,6) - if(SO8LD(i,j,6) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - 1 - SO8LD_D(i,j,2) = j - 1 - SO8LD_D(i,j,3) = 6 - Vmax(i,j) = SO8LD(i,j,6) - end if - SO8LD(i,j,7) = (TERR(i,j)-TERR(i-1,j))/DX(i,j,7) - if(SO8LD(i,j,7) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - 1 - SO8LD_D(i,j,2) = j - SO8LD_D(i,j,3) = 7 - Vmax(i,j) = SO8LD(i,j,7) - end if - SO8LD(i,j,8) = (TERR(i,j)-TERR(i-1,j+1))/DX(i,j,8) - if(SO8LD(i,j,8) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - 1 - SO8LD_D(i,j,2) = j + 1 - SO8LD_D(i,j,3) = 8 - Vmax(i,j) = SO8LD(i,j,8) - end if - enddo - enddo - Vmax = TANH(Vmax) - return - end subroutine seq_land_SO8 - -#ifdef MPP_LAND - subroutine MPP_seq_land_SO8(SO8LD_D,Vmax,TERRAIN,dx,ix,jx,& - global_nx,global_ny) - - use module_mpp_land, only: my_id, io_id, & - write_io_real,decompose_data_int,decompose_data_real - - implicit none - integer,intent(in) :: ix,jx,global_nx,global_ny - INTEGER, intent(inout),DIMENSION(IX,JX,3) :: SO8LD_D -! real,intent(in), DIMENSION(IX,JX) :: TERRAIN - real,DIMENSION(IX,JX) :: TERRAIN - real,intent(out),dimension(ix,jx) :: Vmax - real,intent(in) :: dx(ix,jx,9) - real :: g_dx(ix,jx,9) - - real,DIMENSION(global_nx,global_ny) :: g_TERRAIN - real,DIMENSION(global_nx,global_ny) :: g_Vmax - integer,DIMENSION(global_nx,global_ny,3) :: g_SO8LD_D - integer :: k - - g_SO8LD_D = 0 - g_Vmax = 0 - - do k = 1, 9 - call write_IO_real(dx(:,:,k),g_dx(:,:,k)) - end do - - call write_IO_real(TERRAIN,g_TERRAIN) - if(my_id .eq. IO_id) then - call seq_land_SO8(g_SO8LD_D,g_Vmax,g_TERRAIN,g_dx,global_nx,global_ny) - endif - call decompose_data_int(g_SO8LD_D(:,:,3),SO8LD_D(:,:,3)) - call decompose_data_real(g_Vmax,Vmax) - return - end subroutine MPP_seq_land_SO8 - -#endif - - - - subroutine disaggregateDomain_drv(did) - use module_RT_data, only: rt_domain - use module_namelist, only: nlst_rt - integer :: did - call disaggregateDomain( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,& - RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT,nlst_rt(did)%AGGFACTRT,RT_DOMAIN(did)%SICE, & - RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%SH2OX,RT_DOMAIN(did)%INFXSRT, & - rt_domain(did)%dist_lsm(:,:,9),RT_DOMAIN(did)%SMCMAX1,RT_DOMAIN(did)%SMCREF1, & - RT_DOMAIN(did)%SMCWLT1,RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%LKSAT,RT_DOMAIN(did)%dist, & - RT_DOMAIN(did)%INFXSWGT, RT_DOMAIN(did)%OVROUGHRTFAC,RT_DOMAIN(did)%LKSATFAC, & - RT_DOMAIN(did)%CH_NETRT,RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%SMCREFRT, & - RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%SMCMAXRT, RT_DOMAIN(did)%SMCWLTRT, & - RT_DOMAIN(did)%SMCRT, & - RT_DOMAIN(did)%OVROUGHRT, RT_DOMAIN(did)%LAKE_MSKRT, & - RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%OV_ROUGH,RT_DOMAIN(did)%SLDPTH ) - - end subroutine disaggregateDomain_drv - - subroutine disaggregateDomain(IX,JX,NSOIL,IXRT,JXRT,AGGFACTRT, & - SICE, SMC,SH2OX, INFXSRT, area_lsm, SMCMAX1,SMCREF1, & - SMCWLT1, VEGTYP, LKSAT, dist,INFXSWGT,OVROUGHRTFAC, & - LKSATFAC, CH_NETRT,SH2OWGT,SMCREFRT, INFXSUBRT,SMCMAXRT, & - SMCWLTRT,SMCRT, OVROUGHRT, LAKE_MSKRT, LKSATRT,OV_ROUGH, & - SLDPTH & - ) -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id, & - up_id,mpp_land_com_real, my_id, & - mpp_land_sync,mpp_land_com_integer,mpp_land_max_int1, & - sum_double -#endif - implicit none - integer,INTENT(IN) :: IX,JX,NSOIL,IXRT,JXRT,AGGFACTRT - real,INTENT(OUT),DIMENSION(IX,JX,NSOIL)::SICE - real,INTENT(IN),DIMENSION(IX,JX,NSOIL)::SMC,SH2OX - real,INTENT(IN),DIMENSION(IX,JX)::INFXSRT, area_lsm, SMCMAX1,SMCREF1, & - SMCWLT1, LKSAT - integer,INTENT(IN),DIMENSION(IX,JX) ::VEGTYP - - real,INTENT(IN),DIMENSION(IXRT,JXRT,9)::dist - real,INTENT(IN),DIMENSION(IXRT,JXRT)::INFXSWGT,OVROUGHRTFAC, & - LKSATFAC - integer,INTENT(IN), DIMENSION(IXRT,JXRT) ::CH_NETRT - real,INTENT(IN),DIMENSION(IXRT,JXRT,NSOIL)::SH2OWGT - real,INTENT(OUT),DIMENSION(IXRT,JXRT,NSOIL)::SMCREFRT, SMCMAXRT, & - SMCWLTRT,SMCRT - real,INTENT(OUT),DIMENSION(IXRT,JXRT)::INFXSUBRT - real,INTENT(INOUT),DIMENSION(IXRT,JXRT)::OVROUGHRT, LKSATRT - integer,INTENT(INOUT), DIMENSION(IXRT,JXRT) ::LAKE_MSKRT - - - real,INTENT(IN), DIMENSION(NSOIL) :: SLDPTH - REAL OV_ROUGH(*) - - - - integer :: i, j, AGGFACYRT, AGGFACXRT, IXXRT, JYYRT,KRT, KF - REAL :: LSMVOL,SMCEXCS, WATHOLDCAP -!------------------------------------- - - - - SICE=SMC-SH2OX - SMCREFRT = 0 - -!DJG First, Disaggregate a few key fields for routing... -!DJG Debug... -#ifdef HYDRO_D - print *, "Beginning Disaggregation..." -#endif - -!DJG Mass balance check for disagg... - - -!DJG Weighting alg. alteration...(prescribe wghts if time = 1) - - - do J=1,JX - do I=1,IX - -!DJG Weighting alg. alteration... - LSMVOL=INFXSRT(I,J)*area_lsm(I,J) - - - do AGGFACYRT=AGGFACTRT-1,0,-1 - do AGGFACXRT=AGGFACTRT-1,0,-1 - - IXXRT=I*AGGFACTRT-AGGFACXRT - JYYRT=J*AGGFACTRT-AGGFACYRT -#ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 -#else -!yw ???? -! IXXRT=IXXRT+1 -! JYYRT=JYYRT+1 -#endif - - -!DJG Implement subgrid weighting routine... - INFXSUBRT(IXXRT,JYYRT)=LSMVOL* & - INFXSWGT(IXXRT,JYYRT)/dist(IXXRT,JYYRT,9) - - - do KRT=1,NSOIL !Do for soil profile loop - IF(SICE(I,J,KRT).gt.0) then !...adjust for soil ice -!DJG Adjust SMCMAX for SICE when subsfc routing...make 3d variable - SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J)-SICE(I,J,KRT) - SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J)-SICE(I,J,KRT) - WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) - IF (SICE(I,J,KRT).le.WATHOLDCAP) then - SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - else - if(SICE(I,J,KRT).lt.SMCMAX1(I,J)) & - SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - & - (SICE(I,J,KRT)-WATHOLDCAP) - if(SICE(I,J,KRT).ge.SMCMAX1(I,J)) SMCWLTRT(IXXRT,JYYRT,KRT) = 0. - end if - ELSE - SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J) - SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J) - WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) - SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - END IF !endif adjust for soil ice... - - -!Now Adjust soil moisture -!DJG Use SH2O instead of SMC for 'liquid' water... - IF(SMCMAXRT(IXXRT,JYYRT,KRT).GT.0) THEN !Check for smcmax data (=0 over water) - SMCRT(IXXRT,JYYRT,KRT)=SH2OX(I,J,KRT)*SH2OWGT(IXXRT,JYYRT,KRT) -!old SMCRT(IXXRT,JYYRT,KRT)=SMC(I,J,KRT) - ELSE - SMCRT(IXXRT,JYYRT,KRT) = 0.001 !will be skipped w/ landmask - SMCMAXRT(IXXRT,JYYRT,KRT) = 0.001 - END IF -!DJG Check/Adjust so that subgrid cells do not exceed saturation... - IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN - SMCEXCS = (SMCRT(IXXRT,JYYRT,KRT) - SMCMAXRT(IXXRT,JYYRT,KRT)) & - * SLDPTH(KRT)*1000. !Excess soil water in units of (mm) - SMCRT(IXXRT,JYYRT,KRT) = SMCMAXRT(IXXRT,JYYRT,KRT) - DO KF = KRT-1,1, -1 !loop back upward to redistribute excess water from disagg. - SMCRT(IXXRT,JYYRT,KF) = SMCRT(IXXRT,JYYRT,KF) + SMCEXCS/(SLDPTH(KF)*1000.) - IF (SMCRT(IXXRT,JYYRT,KF).GT.SMCMAXRT(IXXRT,JYYRT,KF)) THEN !Recheck new lyr sat. - SMCEXCS = (SMCRT(IXXRT,JYYRT,KF) - SMCMAXRT(IXXRT,JYYRT,KF)) & - * SLDPTH(KF)*1000. !Excess soil water in units of (mm) - SMCRT(IXXRT,JYYRT,KF) = SMCMAXRT(IXXRT,JYYRT,KF) - ELSE ! Excess soil water expired - SMCEXCS = 0. - EXIT - END IF - END DO - IF (SMCEXCS.GT.0) THEN !If not expired by sfc then add to Infil. Excess - INFXSUBRT(IXXRT,JYYRT) = INFXSUBRT(IXXRT,JYYRT) + SMCEXCS - SMCEXCS = 0. - END IF - END IF !End if for soil moisture saturation excess - - - end do !End do for soil profile loop - - - - do KRT=1,NSOIL !debug loop - - IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN -#ifdef HYDRO_D - print *, "Err. SMCMAX exceeded upon disaggregation3...", ixxrt,jyyrt,krt,& - SMCRT(IXXRT,JYYRT,KRT),SMCMAXRT(IXXRT,JYYRT,KRT) - call hydro_stop("disaggregateDomain") -#endif - ELSE IF (SMCRT(IXXRT,JYYRT,KRT).LE.0.) THEN -#ifdef HYDRO_D - print *, "Err. SMCRT fully depleted upon disaggregation...", ixxrt,jyyrt,krt,& - SMCRT(IXXRT,JYYRT,KRT),SH2OWGT(IXXRT,JYYRT,KRT),SH2OX(I,J,KRT) - - print*, "SMC=", SMC(i,j,KRT), "SICE =", sice(i,j,KRT) - print *, "VEGTYP = ", VEGTYP(I,J) - print *, "i,j,krt, nsoil",i,j,krt,nsoil - call hydro_stop("disaggregateDomain SMCRT depleted") -#endif - END IF - end do !debug loop - - - -!DJG map ov roughness as function of land use provided in VEGPARM.TBL... -! --- added extra check for VEGTYP for 'masked-out' locations... -! --- out of basin locations (VEGTYP=0) have OVROUGH hardwired to 0.1 - IF (VEGTYP(I,J).LE.0) then - OVROUGHRT(IXXRT,JYYRT) = 0.1 !COWS mask test - ELSE - OVROUGHRT(IXXRT,JYYRT)=OV_ROUGH(VEGTYP(I,J))*OVROUGHRTFAC(IXXRT,JYYRT) ! Distributed calibration...1/17/2012 - END IF - - - -!DJG 6.12.08 Map lateral hydraulic conductivity and apply distributed scaling -! --- factor that will be read in from hires terrain file -! LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) - LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) * LKSATFAC(IXXRT,JYYRT) * & !Apply scaling factor... -! ...and scale from max to 0 when SMC decreases from SMCMAX to SMCREF... -!!DJG error found from KIT,improper scaling ((SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL)) / & - (max(0.,(SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL))) / & - (SMCMAXRT(IXXRT,JYYRT,NSOIL)-SMCREFRT(IXXRT,JYYRT,NSOIL)) ) - - - -!DJG set up lake mask... -!--- modify to make lake mask large here, but not one of the routed lakes!!! -!-- IF (VEGTYP(I,J).eq.16) then - IF (VEGTYP(I,J).eq.16 .and. & - CH_NETRT(IXXRT,JYYRT).le.0) then - !--LAKE_MSKRT(IXXRT,JYYRT) = 1 -!yw LAKE_MSKRT(IXXRT,JYYRT) = 9999 - LAKE_MSKRT(IXXRT,JYYRT) = -9999 - end if - - end do - end do - - end do - end do - - - - -#ifdef HYDRO_D - print *, "After Disaggregation..." -#endif - -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(INFXSUBRT,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(LKSATRT,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(OVROUGHRT,IXRT,JXRT,99) - call MPP_LAND_COM_INTEGER(LAKE_MSKRT,IXRT,JXRT,99) - do i = 1, NSOIL - call MPP_LAND_COM_REAL(SMCMAXRT(:,:,i),IXRT,JXRT,99) - call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99) - call MPP_LAND_COM_REAL(SMCWLTRT(:,:,i),IXRT,JXRT,99) - end DO -#endif - - end subroutine disaggregateDomain - - subroutine SubsurfaceRouting_drv(did) - - use module_RT_data, only: rt_domain - use module_namelist, only: nlst_rt - implicit none - integer :: did - IF (nlst_rt(did)%SUBRTSWCRT.EQ.1) THEN - call subsurfaceRouting (RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt , nlst_rt(did)%nsoil, & - RT_DOMAIN(did)%SMCRT,RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCREFRT,& - RT_DOMAIN(did)%SMCWLTRT, RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SLDPTH, & - nlst_rt(did)%DT,RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SOXRT, & - RT_DOMAIN(did)%SOYRT,RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%SOLDEPRT, & - RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%QSUBBDRYTRT, RT_DOMAIN(did)%QSUBBDRYRT,& - RT_DOMAIN(did)%QSUBRT ,nlst_rt(did)%rt_option, RT_DOMAIN(did)%dist, & - RT_DOMAIN(did)%sub_resid,RT_DOMAIN(did)%SO8RT_D, RT_DOMAIN(did)%SO8RT) - endif - end subroutine SubsurfaceRouting_drv - - subroutine subsurfaceRouting (ixrt, jxrt , nsoil, & - SMCRT,SMCMAXRT,SMCREFRT,SMCWLTRT, & - ZSOIL, SLDPTH, & - DT,ZWATTABLRT,SOXRT,SOYRT,LKSATRT,& - SOLDEPRT,INFXSUBRT,QSUBBDRYTRT, QSUBBDRYRT,& - QSUBRT ,rt_option, dist,sub_resid,SO8RT_D, SO8RT) -#ifdef MPP_LAND - use module_mpp_land, only: mpp_land_com_real, mpp_land_com_integer -#endif - implicit none - integer, INTENT(IN) :: ixrt, jxrt , nsoil, rt_option - REAL, INTENT(IN) :: DT - real,INTENT(IN), DIMENSION(NSOIL) :: ZSOIL, SLDPTH - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT,SOYRT,LKSATRT, SOLDEPRT , sub_resid - real,INTENT(INOUT), DIMENSION(IXRT,JXRT)::INFXSUBRT - real,INTENT(INOUT) :: QSUBBDRYTRT - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBBDRYRT, QSUBRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT, SMCWLTRT, SMCMAXRT,SMCREFRT - - - INTEGER :: SO8RT_D(IXRT,JXRT,3) - REAL :: SO8RT(IXRT,JXRT,8) - REAL, INTENT(IN) :: dist(ixrt,jxrt,9) -! -----local array ---------- - REAL, DIMENSION(IXRT,JXRT) :: ZWATTABLRT - REAL, DIMENSION(IXRT,JXRT) :: CWATAVAIL - INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK - - - - - CWATAVAIL = 0. - CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & - SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, & - CWATAVAIL,SLDPTH) -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(ZWATTABLRT,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(CWATAVAIL,IXRT,JXRT,99) - call MPP_LAND_COM_INTEGER(SATLYRCHK,IXRT,JXRT,99) -#endif - - -!DJG Second, Call subsurface routing routine... -#ifdef HYDRO_D - print *, "Beginning SUB_routing..." - print *, "Routing method is ",rt_option, " direction." -#endif - -!!!! Find saturated layer depth... -! Loop through domain to determine sat. layers and assign wat tbl depth... -! and water available for subsfc routing (CWATAVAIL)... -! This subroutine returns: ZWATTABLRT, CWATAVAIL and SATLYRCHK - - - CALL SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & - LKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT,NSOIL,SMCRT, & - INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT,SMCWLTRT,SO8RT, & - SO8RT_D, rt_option,SLDPTH,SUB_RESID,CWATAVAIL,SATLYRCHK) - -#ifdef HYDRO_D - print *, "SUBROUTE routing called and returned..." -#endif - - end subroutine subsurfaceRouting - - - subroutine OverlandRouting_drv(did) - use module_RT_data, only: rt_domain - use module_namelist, only: nlst_rt - implicit none - integer :: did - if(nlst_rt(did)%OVRTSWCRT .eq. 1) then - call OverlandRouting (nlst_rt(did)%DT, nlst_rt(did)%DTRT, nlst_rt(did)%rt_option, & - rt_domain(did)%ixrt, rt_domain(did)%jxrt,rt_domain(did)%LAKE_MSKRT, & - rt_domain(did)%INFXSUBRT, rt_domain(did)%RETDEPRT,rt_domain(did)%OVROUGHRT, & - rt_domain(did)%SOXRT, rt_domain(did)%SOYRT, rt_domain(did)%SFCHEADSUBRT, & - rt_domain(did)%DHRT, rt_domain(did)%CH_NETRT, rt_domain(did)%QSTRMVOLRT, & - rt_domain(did)%LAKE_INFLORT,rt_domain(did)%QBDRYRT, & - rt_domain(did)%QSTRMVOLTRT,rt_domain(did)%QBDRYTRT, rt_domain(did)%LAKE_INFLOTRT,& - rt_domain(did)%q_sfcflx_x,rt_domain(did)%q_sfcflx_y, & - rt_domain(did)%dist, rt_domain(did)%SO8RT, rt_domain(did)%SO8RT_D , & - rt_domain(did)%SMCTOT2,rt_domain(did)%suminfxs1,rt_domain(did)%suminfxsrt, & - rt_domain(did)%smctot1,rt_domain(did)%dsmctot ) - endif - end subroutine OverlandRouting_drv - - - - subroutine OverlandRouting (DT, DTRT, rt_option, ixrt, jxrt,LAKE_MSKRT, & - INFXSUBRT, RETDEPRT,OVROUGHRT,SOXRT, SOYRT, SFCHEADSUBRT,DHRT, & - CH_NETRT, QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, & - QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y, & - dist, SO8RT, SO8RT_D, & - SMCTOT2,suminfxs1,suminfxsrt,smctot1,dsmctot ) -#ifdef MPP_LAND - use module_mpp_land, only: mpp_land_max_int1, sum_double -#endif - implicit none - - REAL, INTENT(IN) :: DT, DTRT - integer, INTENT(IN) :: ixrt, jxrt, rt_option - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: INFXSUBRT, & - RETDEPRT,OVROUGHRT,SOXRT, SOYRT - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SFCHEADSUBRT,DHRT - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, & - QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y - - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8) :: SO8RT - INTEGER SO8RT_D(IXRT,JXRT,3) - - integer :: i,j - - - INTEGER, PARAMETER :: double1=8 - real (KIND=double1) :: smctot2,smctot1,dsmctot - real (KIND=double1) :: suminfxsrt,suminfxs1 -! local variable - real (KIND=double1) :: chan_in1,chan_in2 - real (KIND=double1) :: lake_in1,lake_in2 - real (KIND=double1) :: qbdry1,qbdry2 - integer :: sfcrt_flag - - - -!DJG Third, Call Overland Flow Routing Routine... -#ifdef HYDRO_D - print *, "Beginning OV_routing..." - print *, "Routing method is ",rt_option, " direction." -#endif - -!DJG debug...OV Routing... - suminfxs1=0. - chan_in1=0. - lake_in1=0. - qbdry1=0. - do i=1,IXRT - do j=1,JXRT - suminfxs1=suminfxs1+INFXSUBRT(I,J)/float(IXRT*JXRT) - chan_in1=chan_in1+QSTRMVOLRT(I,J)/float(IXRT*JXRT) - lake_in1=lake_in1+LAKE_INFLORT(I,J)/float(IXRT*JXRT) - qbdry1=qbdry1+QBDRYRT(I,J)/float(IXRT*JXRT) - end do - end do - -#ifdef MPP_LAND -! not tested - CALL sum_double(suminfxs1) - CALL sum_double(chan_in1) - CALL sum_double(lake_in1) - CALL sum_double(qbdry1) -#endif - - -!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(set sfcrt_flag) -!DJG.7.20.2007 - this check will skip ov rtng when no flow is present... - - sfcrt_flag = 0 - - do j=1,jxrt - do i=1,ixrt - if(INFXSUBRT(i,j).gt.RETDEPRT(i,j)) then - sfcrt_flag = 1 - exit - end if - end do - if(sfcrt_flag.eq.1) exit - end do - -#ifdef MPP_LAND - call mpp_land_max_int1(sfcrt_flag) -#endif -!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(IF) - - if (sfcrt_flag.eq.1) then !If/then for sfc_rt check... -#ifdef HYDRO_D - write(6,*) "calling OV_RTNG " -#endif - CALL OV_RTNG(DT,DTRT,IXRT,JXRT,INFXSUBRT,SFCHEADSUBRT,DHRT, & - CH_NETRT,RETDEPRT,OVROUGHRT,QSTRMVOLRT,QBDRYRT, & - QSTRMVOLTRT,QBDRYTRT,SOXRT,SOYRT,dist, & - LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT,SO8RT,SO8RT_D,rt_option,& - q_sfcflx_x,q_sfcflx_y) - else -#ifdef HYDRO_D - print *, "No water to route overland..." -#endif - end if !Endif for sfc_rt check... - -!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(ENDIF) - -#ifdef HYDRO_D - print *, "OV routing called and returned..." -#endif - -!DJG Debug...OV Routing... - suminfxsrt=0. - chan_in2=0. - lake_in2=0. - qbdry2=0. - do i=1,IXRT - do j=1,JXRT - suminfxsrt=suminfxsrt+SFCHEADSUBRT(I,J)/float(IXRT*JXRT) - chan_in2=chan_in2+QSTRMVOLRT(I,J)/float(IXRT*JXRT) - lake_in2=lake_in2+LAKE_INFLORT(I,J)/float(IXRT*JXRT) - qbdry2=qbdry2+QBDRYRT(I,J)/float(IXRT*JXRT) - end do - end do -#ifdef MPP_LAND -! not tested - CALL sum_double(suminfxsrt) - CALL sum_double(chan_in2) - CALL sum_double(lake_in2) - CALL sum_double(qbdry2) -#endif - -#ifdef HYDRO_D - print *, "OV Routing Mass Bal: " - print *, "Infil. Excess/Sfc Head: ", suminfxsrt-suminfxs1, & - suminfxsrt,suminfxs1 - print *, "chan_in = ",chan_in2-chan_in1 - print *, "lake_in = ",lake_in2-lake_in1 - print *, "Qbdry = ",qbdry2-qbdry1 - print *, "Residual : ", suminfxs1-suminfxsrt-(chan_in2-chan_in1) & - -(lake_in2-lake_in1)-(qbdry2-qbdry1) -#endif - - - end subroutine OverlandRouting - - - subroutine time_seconds(i3) - integer time_array(8) - real*8 i3 - call date_and_time(values=time_array) - i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + & - time_array(7) + 0.001 * time_array(8) - return - end subroutine time_seconds - diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/module_GW_baseflow.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/module_GW_baseflow.F.svn-base deleted file mode 100644 index 7b72ff1e..00000000 --- a/wrfv2_fire/hydro/Routing/.svn/text-base/module_GW_baseflow.F.svn-base +++ /dev/null @@ -1,856 +0,0 @@ -module module_GW_baseflow - -#ifdef MPP_LAND - use module_mpp_land -#endif - implicit none - -#include "gw_field_include.inc" -#include "rt_include.inc" -!yw #include "namelist.inc" -contains - -!------------------------------------------------------------------------------ -!DJG Simple GW Bucket Model -!------------------------------------------------------------------------------ - - subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,basns_area,& - gwsubbasmsk, runoff1x, runoff2x, z_gwsubbas_tmp, qin_gwsubbas,& - qout_gwsubbas,qinflowbase,gw_strm_msk,gwbas_pix_ct,dist,DT,& - C,ex,z_mx,GWBASESWCRT,OVRTSWCRT) - implicit none - -!!!Declarations... - integer, intent(in) :: ix,jx,ixrt,jxrt - integer, intent(in) :: numbasns - integer, intent(in), dimension(ix,jx) :: gwsubbasmsk - real, intent(in), dimension(ix,jx) :: runoff2x - real, intent(in), dimension(ix,jx) :: runoff1x - real, intent(in) :: basns_area(numbasns),dist(ixrt,jxrt,9),DT - real, intent(in),dimension(numbasns) :: C,ex,z_mx - real, intent(out),dimension(numbasns) :: qout_gwsubbas - real, intent(out),dimension(numbasns) :: qin_gwsubbas - real*8 :: z_gwsubbas(numbasns) - real :: qout_max, qout_spill, z_gw_spill - real, intent(inout),dimension(numbasns) :: z_gwsubbas_tmp - real, intent(out),dimension(ixrt,jxrt) :: qinflowbase - integer, intent(in),dimension(ixrt,jxrt) :: gw_strm_msk - integer, intent(in) :: GWBASESWCRT - integer, intent(in) :: OVRTSWCRT - - - real*8, dimension(numbasns) :: sum_perc8,ct_bas8 - real, dimension(numbasns) :: sum_perc - real, dimension(numbasns) :: net_perc - - real, dimension(numbasns) :: ct_bas - real, dimension(numbasns) :: gwbas_pix_ct - integer :: i,j,bas - character(len=19) :: header - character(len=1) :: jnk - - -!!!Initialize variables... - ct_bas8 = 0 - sum_perc8 = 0. - net_perc = 0. - qout_gwsubbas = 0. - qin_gwsubbas = 0. - z_gwsubbas = z_gwsubbas_tmp - - - -!!!Calculate aggregated percolation from deep runoff into GW basins... - do i=1,ix - do j=1,jx - do bas=1,numbasns - if(gwsubbasmsk(i,j).eq.bas) then - if(OVRTSWCRT.ne.0) then - sum_perc8(bas) = sum_perc8(bas)+runoff2x(i,j) !Add only drainage to bucket...runoff2x in (mm) - else - sum_perc8(bas) = sum_perc8(bas)+runoff1x(i,j)+runoff2x(i,j) !Add sfc water & drainage to bucket...runoff1x and runoff2x in (mm) - end if - ct_bas8(bas) = ct_bas8(bas) + 1 - end if - end do - end do - end do - -#ifdef MPP_LAND - call sum_real8(sum_perc8,numbasns) - call sum_real8(ct_bas8,numbasns) -#endif - sum_perc = sum_perc8 - ct_bas = ct_bas8 - - - - -!!!Loop through GW basins to adjust for inflow/outflow - - DO bas=1,numbasns ! Loop for GW bucket calcs... -! #ifdef MPP_LAND -! if(ct_bas(bas) .gt. 0) then -! #endif - - net_perc(bas) = sum_perc(bas) / ct_bas(bas) !units (mm) -!DJG...old change to cms qin_gwsubbas(bas) = net_perc(bas)/1000. * ct_bas(bas) * basns_area(bas) !units (m^3) - qin_gwsubbas(bas) = net_perc(bas)/1000.* & - ct_bas(bas)*basns_area(bas)/DT !units (m^3/s) - - -!Adjust level of GW depth...(conceptual GW bucket units (mm)) -!DJG...old change to cms inflow... z_gwsubbas(bas) = z_gwsubbas(bas) + net_perc(bas) / 1000.0 ! (m) - -!DJG...debug write (6,*) "DJG...before",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas) - - z_gwsubbas(bas) = z_gwsubbas(bas) + qin_gwsubbas(bas)*DT/( & - ct_bas(bas)*basns_area(bas))*1000. ! units (mm) - - - - - -!Calculate baseflow as a function of GW bucket depth... - - if(GWBASESWCRT.eq.1) then !active exponential bucket... if/then for bucket model discharge type... - -!DJG...Estimation of bucket 'overflow' (qout_spill) if/when bucket gets filled... - qout_spill = 0. - z_gw_spill = 0. - if (z_gwsubbas(bas).gt.z_mx(bas)) then !If/then for bucket overflow case... - z_gw_spill = z_gwsubbas(bas) - z_mx(bas) - z_gwsubbas(bas) = z_mx(bas) - write (6,*) "Bucket spilling...", bas, z_gwsubbas(bas), z_mx(bas), z_gw_spill - else - z_gw_spill = 0. - end if ! End if for bucket overflow case... - - qout_spill = z_gw_spill/1000.*(ct_bas(bas)*basns_area(bas))/DT !amount spilled from bucket overflow...units (cms) - - -!DJG...Maximum estimation of bucket outlfow that is limited by total quantity in bucket... - qout_max = z_gwsubbas(bas)/1000.*(ct_bas(bas)*basns_area(bas))/DT ! Estimate max bucket disharge limit to total volume in bucket...(m^3/s) - - -! Assume exponential relation between z/zmax and Q... -!DJG...old...creates non-asymptotic flow... qout_gwsubbas(bas) = C(bas)*EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas)) !Exp.model. q_out (m^3/s) -!DJG force asymptote to zero to prevent 'overdraft'... -!DJG debug hardwire test... qout_gwsubbas(bas) = 1*(EXP(7.0*10./100.)-1) !Exp.model. q_out (m^3/s) - qout_gwsubbas(bas) = C(bas)*(EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas))-1) !Exp.model. q_out (m^3/s) - -!DJG...Calculation of max bucket outlfow that is limited by total quantity in bucket... - qout_gwsubbas(bas) = MIN(qout_max,qout_gwsubbas(bas)) ! Limit bucket discharge to max. bucket limit - - write (6,*) "DJG-exp bucket...during",C(bas),ex(bas),z_gwsubbas(bas),qin_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max, qout_spill - - - - elseif (GWBASESWCRT.eq.2) then !Pass through/steady-state bucket - -! Assuming a steady-state (inflow=outflow) model... -!DJG convert input and output units to cms... qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3) - qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3/s) - -!DJG...debug write (6,*) "DJG-pass through...during",C(bas),ex(bas),qin_gwsubbas(bas), z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max - - end if ! End if for bucket model discharge type.... - - - - -!Adjust level of GW depth... -!DJG bug adjust output to be mm and correct area bug... z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT & -!DJG bug adjust output to be mm and correct area bug... / (ct_bas(bas)*basns_area(bas)) !units(m) - - z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT/( & - ct_bas(bas)*basns_area(bas))*1000. ! units (mm) - -!DJG...Combine calculated bucket discharge and amount spilled from bucket... - qout_gwsubbas(bas) = qout_gwsubbas(bas) + qout_spill ! units (cms) - - - write (6,*) "DJG...after",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_spill - write (6,*) "DJG...after...calc",bas,ct_bas(bas),ct_bas(bas)*basns_area(bas),basns_area(bas),DT - - - - -! #ifdef MPP_LAND -! endif -! #endif - END DO ! End loop for GW bucket calcs... - - z_gwsubbas_tmp = z_gwsubbas - - -!!!Distribute basin integrated baseflow to stream pixels as stream 'inflow'... - - qinflowbase = 0. - - - do i=1,ixrt - do j=1,jxrt -!!! -simple uniform disaggregation (8.31.06) - if (gw_strm_msk(i,j).gt.0) then - - qinflowbase(i,j) = qout_gwsubbas(gw_strm_msk(i,j))*1000.*DT/ & - gwbas_pix_ct(gw_strm_msk(i,j))/dist(i,j,9) ! units (mm) that gets passed into chan routing as stream inflow - - end if - end do - end do - - -!!! - weighted redistribution...(need to pass accum weights (slope) in...) -! NOT FINISHED just BASIC framework... -! do bas=1,numbasns -! do k=1,gwbas_pix_ct(bas) -! qinflowbase(i,j) = k*slope -! end do -! end do - - z_gwsubbas = z_gwsubbas_tmp - - return - -!------------------------------------------------------------------------------ - End subroutine simp_gw_buck -!------------------------------------------------------------------------------ - - - - -#ifdef MPP_LAND - subroutine pix_ct_1(in_gw_strm_msk,ixrt,jxrt,gwbas_pix_ct,numbasns) - USE module_mpp_land - implicit none - integer :: i,j,ixrt,jxrt,numbasns, bas - integer,dimension(ixrt,jxrt) :: in_gw_strm_msk - integer,dimension(global_rt_nx,global_rt_ny) :: gw_strm_msk - real,dimension(numbasns) :: gwbas_pix_ct - - gw_strm_msk = 0 - call write_IO_rt_int(in_gw_strm_msk, gw_strm_msk) - - if(my_id .eq. IO_id) then - gwbas_pix_ct = 0. - do bas = 1,numbasns - do i=1,global_rt_nx - do j=1,global_rt_ny - if(gw_strm_msk(i,j) .eq. bas) then - gwbas_pix_ct(gw_strm_msk(i,j)) = gwbas_pix_ct(gw_strm_msk(i,j)) & - + 1.0 - endif - end do - end do - end do - end if - call mpp_land_bcast_real(numbasns,gwbas_pix_ct) - - return - end subroutine pix_ct_1 -#endif - - -!------------------------------------------------------------------------------ -! Benjamin Fersch 2d groundwater model -!------------------------------------------------------------------------------ - subroutine gw2d_ini(did,dt,dx) - use module_GW_baseflow_data, only: gw2d - implicit none - integer did - real dt,dx - - gw2d(did)%dx=dx - gw2d(did)%dt=dt - ! bftodo: develop proper landtype mask - - gw2d(did)%compres=0. ! currently not implemented - - return - end subroutine gw2d_ini - - subroutine gw2d_allocate(did, ix, jx, nsoil) - use module_GW_baseflow_data, only: gw2d - implicit none - integer ix, jx, nsoil - integer istatus, did - - if(gw2d(did)%allo_status .eq. 1) return - gw2d(did)%allo_status = 1 - - gw2d(did)%ix = ix - gw2d(did)%jx = jx - - - allocate(gw2d(did)%ltype (ix,jx)) - allocate(gw2d(did)%elev (ix,jx)) - allocate(gw2d(did)%bot (ix,jx)) - allocate(gw2d(did)%hycond (ix,jx)) - allocate(gw2d(did)%poros (ix,jx)) - allocate(gw2d(did)%compres(ix,jx)) - allocate(gw2d(did)%ho (ix,jx)) - allocate(gw2d(did)%h (ix,jx)) - allocate(gw2d(did)%convgw (ix,jx)) -! allocate(gw2d(did)% (ix,jx)) - - end subroutine gw2d_allocate - - - subroutine gwstep(ix, jx, dx, & - ltype, elev, bot, & - hycond, poros, compres, & - ho, h, convgw, & - ebot, eocn, & - dt, istep) -! #else -! dx, istep, dt, & !supplied -! ims,ime,jms,jme,its,ite,jts,jte, & !supplied -! ids,ide,jds,jde,ifs,ife,jfs,jfe) !supplied -! #endif - -! New (volug): calling routines use change in head, convgw = d(h-ho)/dt. - -! Steps ground-water hydrology (head) through one timestep. -! Modified from Prickett and Lonnquist (1971), basic one-layer aquifer -! simulation program, with mods by Zhongbo Yu(1997). -! Solves S.dh/dt = d/dx(T.dh/dx) + d/dy(T.dh/dy) + "external sources" -! for a single layer, where h is head, S is storage coeff and T is -! transmissivity. 3-D arrays in main program (hycond,poros,h,bot) -! are 2-D here, since only a single (uppermost) layer is solved. -! Uses an iterative time-implicit ADI method. - -! use module_hms_constants - - - - integer, intent(in) :: ix, jx - - integer, intent(in), dimension(ix,jx) :: ltype ! land-sfc type (supp) - real, intent(in), dimension(ix,jx) :: & - elev, & ! elev/bathymetry of sfc rel to sl (m) (supp) - bot, & ! elev. aquifer bottom rel to sl (m) (supp) - hycond, & ! hydraulic conductivity (m/s per m/m) (supp) - poros, & ! porosity (m3/m3) (supp) - compres, & ! compressibility (1/Pa) (supp) - ho ! head at start of timestep (m) (supp) - - real, intent(inout), dimension(ix,jx) :: & - h, & ! head, after ghmcompute (m) (ret) - convgw ! convergence due to gw flow (m/s) (ret) - - real, intent(inout) :: ebot, eocn - - - - integer :: istep !, dt - real, intent(in) :: dt, dx - -! #endif -! eocn = mean spurious sink for h_ocn = sealev fix (m/s)(ret) -! This equals the total ground-water flow across -! land->ocean boundaries. -! ebot = mean spurious source for "bot" fix (m/s) (returned) -! time = elapsed time from start of run (sec) -! dt = timestep length (sec) -! istep = timestep counter - -! Local arrays: - - real, dimension(ix,jx) :: sf2 ! storage coefficient (m3 of h2o / bulk m3) - real, dimension(ix,jx,2) :: t ! transmissivity (m2/s)..1 for N-S,..2 for E-W - real, dimension(0:ix+jx) :: b,g ! work arrays - - - real, parameter :: botinc = 0.01 ! re-wetting increment to fix h < bot -! parameter (botinc = 0. ) ! re-wetting increment to fix h < bot - ! (m); else no flow into dry cells - real, parameter :: delskip = 0.005 ! av.|dhead| value for iter.skip out(m) - integer, parameter :: itermax = 10 ! maximum number of iterations - integer, parameter :: itermin = 3 ! minimum number of iterations - real, parameter :: sealev = -1. ! sea-level elevation (m) - - -! die müssen noch sortiert, geprüft und aufgeräumt werden - integer :: & - iter, & - j, & - i, & - jp, & - ip, & - ii, & - n, & - jj, & - ierr, & - ier - -! real :: su, sc, shp, bb, aa, cc, w, zz, tareal, dtoa, dtot - real :: & - dy, & - e, & - su, & - sc, & - shp, & - bb, & - dd, & - aa, & - cc, & - w, & - ha, & - delcur, & - dtot, & - dtoa, & - darea, & - tareal, & - zz - -#ifdef MPP_LAND - real mpiDelcur - integer mpiSize -#endif - - dy = dx - darea = dx*dy - - - call scopy (ix*jx, ho, 1, h, 1) - -! Top of iterative loop for ADI solution - - iter = 0 -!~~~~~~~~~~~~~ - 80 continue -!~~~~~~~~~~~~~ - iter = iter+1 - -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(h, ix, jx, 99) -#endif - - e = 0. ! absolute changes in head (for iteration control) -! eocn = 0. ! accumulated fixes for h = 0 over ocean (diag) -! ebot = 0. ! accumulated fixes for h < bot (diagnostic) - -! Set storage coefficient (sf2) - -! #ifdef HMSWRF -! - tareal = 0. -! -! do j=jfs,jfe -! do i=ifs,ife -! -! -! #else - do j=1,jx - do i=1,ix - if(ltype(i,j) .ge. 1) tareal = tareal + darea - -! #endif -! unconfined water table (h < e): V = poros*(h-b) -! dV/dh = poros -! saturated to surface (h >= e) : V = poros*(e-b) + (h-e) -! dV/dh = 1 -! (compressibility is ignored) -! -! su = poros(i,j)*(1.-theta(i,j)) ! old (pre-volug) - su = poros(i,j) ! new (volug) - sc = 1. - - if (ho(i,j).le.elev(i,j) .and. h(i,j).le.elev(i,j)) then - sf2(i,j) = su - else if (ho(i,j).ge.elev(i,j) .and. h(i,j).ge.elev(i,j)) then - sf2(i,j) = sc - else if (ho(i,j).le.elev(i,j) .and. h(i,j).ge.elev(i,j)) then - shp = sf2(i,j) * (h(i,j) - ho(i,j)) - sf2(i,j) = shp * sc / (shp - (su-sc)*(elev(i,j)-ho(i,j))) - else if (ho(i,j).ge.elev(i,j) .and. h(i,j).le.elev(i,j)) then - shp = sf2(i,j) * (ho(i,j) - h(i,j)) - sf2(i,j) = shp * su / (shp + (su-sc)*(ho(i,j)-elev(i,j))) - endif - - enddo - enddo - -#ifdef MPP_LAND - ! communicate storage coefficient - call MPP_LAND_COM_REAL(sf2, ix, jx, 99) - -#endif - - -!========================== -! Column calculations -!========================== - -! Set transmissivities. Use min(h,elev)-bot instead of h-bot, -! since if h > elev, thickness of groundwater flow is just -! elev-bot. - -! #ifdef HMSWRF -! -! do j=jfs,jfe -! jp = min (j+1,jfe) -! do i=ifs,ife -! ip = min (i+1,ife) -! -! #else - - do j=1,jx - jp = min (j+1,jx) - do i=1,ix - ip = min (i+1,ix) - -! #endif - t(i,j,2) = sqrt( abs( & - hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j)) & - *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j)) & - ) ) & -! #ifdef HMSWRF - * (0.5*(dy+dy)) & ! in WRF the dx and dy are usually equal - / (0.5*(dx+dx)) -! #else -! * (0.5*(dy(i,j)+dy(ip,j))) & -! / (0.5*(dx(i,j)+dx(ip,j))) -! #endif - - t(i,j,1) = sqrt( abs( & - hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j )) & - *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp)) & - ) ) & -! #ifdef HMSWRF - * (0.5*(dx+dx)) & - / (0.5*(dy+dy)) -! #else -! * (0.5*(dx(i,j)+dx(i,jp))) & -! / (0.5*(dy(i,j)+dy(i,jp))) -! #endif - enddo - enddo - -#ifdef MPP_LAND - ! communicate transmissivities in x and y direction - call MPP_LAND_COM_REAL(t(:,:,1), ix, jx, 99) - call MPP_LAND_COM_REAL(t(:,:,2), ix, jx, 99) -#endif - b = 0. - g = 0. - -!------------------- - do 190 ii=1,ix -!------------------- - i=ii - if (mod(istep+iter,2).eq.1) i=ix-i+1 - -! calculate b and g arrays - -!>>>>>>>>>>>>>>>>>>>> - do 170 j=1,jx -!>>>>>>>>>>>>>>>>>>>> -! bb = (sf2(i,j)/dt) * darea(i,j) -! dd = ( ho(i,j)*sf2(i,j)/dt ) * darea(i,j) - bb = (sf2(i,j)/dt) * darea - dd = ( ho(i,j)*sf2(i,j)/dt ) * darea - aa = 0.0 - cc = 0.0 - - if (j-1) 90,100,90 - 90 aa = -t(i,j-1,1) - bb = bb + t(i,j-1,1) - - 100 if (j-jx) 110,120,110 - 110 cc = -t(i,j,1) - bb = bb + t(i,j,1) - - 120 if (i-1) 130,140,130 - 130 bb = bb + t(i-1,j,2) - dd = dd + h(i-1,j)*t(i-1,j,2) - - 140 if (i-ix) 150,160,150 - 150 bb = bb + t(i,j,2) - dd = dd + h(i+1,j)*t(i,j,2) - - 160 w = bb - aa*b(j-1) - b(j) = cc/w - g(j) = (dd-aa*g(j-1))/w -!>>>>>>>>>>>>>>> - 170 continue -!>>>>>>>>>>>>>>> - -! re-estimate heads - - e = e + abs(h(i,jx)-g(jx)) - h(i,jx) = g(jx) - n = jx-1 - 180 if (n.eq.0) goto 185 - ha = g(n) - b(n)*h(i,n+1) - e = e + abs(ha-h(i,n)) - h(i,n) = ha - n = n-1 - goto 180 - 185 continue - -!------------- - 190 continue -!------------- - -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(h, ix, jx, 99) -#endif - - -!======================= -! Row calculations -!======================= - -! set transmissivities (same as above) - - do j=1,jx - jp = min (j+1,jx) - do i=1,ix - ip = min (i+1,ix) - t(i,j,2) = sqrt( abs( & - hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j)) & - *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j)) & - ) ) & -! * (0.5*(dy(i,j)+dy(ip,j))) & -! / (0.5*(dx(i,j)+dx(ip,j))) - * (0.5*(dy+dy)) & - / (0.5*(dx+dx)) - - t(i,j,1) = sqrt( abs( & - hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j )) & - *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp)) & - ) ) & - * (0.5*(dx+dx)) & - / (0.5*(dy+dy)) - enddo - enddo - -#ifdef MPP_LAND - ! communicate transmissivities in x and y direction - call MPP_LAND_COM_REAL(t(:,:,1), ix, jx, 99) - call MPP_LAND_COM_REAL(t(:,:,2), ix, jx, 99) -#endif - b = 0. - g = 0. - -!------------------- - do 300 jj=1,jx -!------------------- - j=jj - if (mod(istep+iter,2).eq.1) j = jx-j+1 - -! calculate b and g arrays - -!>>>>>>>>>>>>>>>>>>>> - do 280 i=1,ix -!>>>>>>>>>>>>>>>>>>>> -! bb = (sf2(i,j)/dt) * darea(i,j) -! dd = ( ho(i,j)*sf2(i,j)/dt ) * darea(i,j) - bb = (sf2(i,j)/dt) * darea - dd = ( ho(i,j)*sf2(i,j)/dt ) * darea - aa = 0.0 - cc = 0.0 - - if (j-1) 200,210,200 - 200 bb = bb + t(i,j-1,1) - dd = dd + h(i,j-1)*t(i,j-1,1) - - 210 if (j-jx) 220,230,220 - 220 dd = dd + h(i,j+1)*t(i,j,1) - bb = bb + t(i,j,1) - - 230 if (i-1) 240,250,240 - 240 bb = bb + t(i-1,j,2) - aa = -t(i-1,j,2) - - 250 if (i-ix) 260,270,260 - 260 bb = bb + t(i,j,2) - cc = -t(i,j,2) - - 270 w = bb - aa*b(i-1) - b(i) = cc/w - g(i) = (dd-aa*g(i-1))/w -!>>>>>>>>>>>>>>> - 280 continue -!>>>>>>>>>>>>>>> - -! re-estimate heads - - e = e + abs(h(ix,j)-g(ix)) - h(ix,j) = g(ix) - n = ix-1 - 290 if (n.eq.0) goto 295 - ha = g(n)-b(n)*h(n+1,j) - e = e + abs(h(n,j)-ha) - h(n,j) = ha - n = n-1 - goto 290 - 295 continue - -!------------- - 300 continue -!------------- - -! fix head < bottom of aquifer -! #endif -! -! #ifdef HMSWRF -! -! do j=jfs,jfe -! do i=ifs,ife -! -! #else - do j=1,jx - do i=1,ix -! #endif - if (ltype(i,j).eq.1 .and. h(i,j).le.bot(i,j)+botinc) then - -! #ifndef HMSWRF - e = e + bot(i,j) + botinc - h(i,j) -! ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea(i,j) - ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea -! #endif - - h(i,j) = bot(i,j) + botinc - endif - enddo - enddo -! maintain head = sea level for ocean (only for adjacent ocean, -! rest has hycond=0) - -! #ifdef HMSWRF -! -! do j=jfs,jfe -! do i=its,ife -! -! #else - do j=1,jx - do i=1,ix -! #endif - if (ltype(i,j).eq.2) then -! #ifndef HMSWRF - eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea -! eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea(i,j) -! #endif - h(i,j) = sealev - endif - enddo - enddo - -! Loop back for next ADI iteration - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! #ifdef HMSWRF -! delcur = e/(xdim*ydim) -! #else - delcur = e/(ix*jx) -! #endif - -#ifdef MPP_LAND - -call mpi_reduce(delcur, mpiDelcur, 1, MPI_REAL, MPI_SUM, 0, MPI_COMM_WORLD, ierr) -call MPI_COMM_SIZE( MPI_COMM_WORLD, mpiSize, ierr ) - -mpiDelcur = mpiDelcur/mpiSize - -call mpi_bcast(delcur, 1, mpi_real, 0, MPI_COMM_WORLD, ierr) - -#endif - - if ( (delcur.gt.delskip*dt/86400. .and. iter.lt.itermax) & - .or. iter.lt.itermin ) then - goto 80 - else - endif - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -! Compute convergence rate due to ground water flow (returned) - -! #ifdef HMSWRF -! -! do j=jfs,jfe -! do i=ifs,ife -! -! #else - do j=1,jx - do i=1,ix -! #endif - if (ltype(i,j).eq.1) then - convgw(i,j) = sf2(i,j) * (h(i,j)-ho(i,j)) / dt - else - convgw(i,j) = 0. - endif - enddo - enddo - -! Diagnostic water conservation check for this timestep - - dtot = 0. ! total change in water storage (m3) - dtoa = 0. - -! #ifdef HMSWRF -! -! do j=jts,jte -! do i=its,ite -! -! #else - do j=1,jx - do i=1,ix -! #endif - if (ltype(i,j).eq.1) then -! #ifdef HMSWRF - dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea - dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea -! #else -! dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea(i,j) -! dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea(i,j) -! #endif - endif - enddo - enddo - - dtot = (dtot/tareal)/dt ! convert to m/s, rel to land area - dtoa = (dtoa/tareal)/dt - eocn = (eocn/tareal)/dt - ebot = (ebot/tareal)/dt - - zz = 1.e3 * 86400. ! convert printout to mm/day -#ifdef HYDRO_D - write (*,900) & - dtot*zz, dtoa*zz, -eocn*zz, ebot*zz, & - (dtot-(-eocn+ebot))*zz -#endif - 900 format & - (3x,' dh/dt |dh/dt| ocnflx botfix',& - ' ',' ghmerror' & -! /3x,4f9.4,2(9x),e14.4) - /3x,5(e14.4)) - - return - end subroutine gwstep - - - SUBROUTINE SCOPY (NT, ARR, INCA, BRR, INCB) -! -! Copies array ARR to BRR, incrementing by INCA and INCB -! respectively, up to a total length of NT words of ARR. -! (Same as Cray SCOPY.) -! - real, DIMENSION(*) :: ARR, BRR - integer :: ia, nt, inca, incb, ib -! - IB = 1 - DO 10 IA=1,NT,INCA - BRR(IB) = ARR(IA) - IB = IB + INCB - 10 CONTINUE -! - RETURN - END SUBROUTINE SCOPY - -end module module_GW_baseflow diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/module_HYDRO_io.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/module_HYDRO_io.F.svn-base deleted file mode 100644 index 54fbdf93..00000000 --- a/wrfv2_fire/hydro/Routing/.svn/text-base/module_HYDRO_io.F.svn-base +++ /dev/null @@ -1,6340 +0,0 @@ -module module_HYDRO_io -#ifdef MPP_LAND - use module_mpp_land -#endif - use module_HYDRO_utils, only: get_dist_ll - use module_namelist, only: nlst_rt - use module_RT_data, only: rt_domain - - implicit none -#include - - contains - integer function get2d_real(var_name,out_buff,ix,jx,fileName) - implicit none - integer :: ivar, iret,varid,ncid,ix,jx - real out_buff(ix,jx) - character(len=*), intent(in) :: var_name - character(len=*), intent(in) :: fileName - get2d_real = -1 - - iret = nf_open(trim(fileName), NF_NOWRITE, ncid) - if (iret .ne. 0) then -#ifdef HYDRO_D - print*,"failed to open the netcdf file: ",trim(fileName) -#endif - out_buff = -9999. - return - endif - ivar = nf_inq_varid(ncid,trim(var_name), varid) - if(ivar .ne. 0) then - ivar = nf_inq_varid(ncid,trim(var_name//"_M"), varid) - if(ivar .ne. 0) then -#ifdef HYDRO_D - write(6,*) "Read Variable Error file: ",trim(fileName) - write(6,*) "Read Error: could not find ",trim(var_name) -#endif - return - endif - end if - iret = nf_get_var_real(ncid, varid, out_buff) - iret = nf_close(ncid) - get2d_real = ivar - end function get2d_real - - subroutine get2d_lsm_real(var_name,out_buff,ix,jx,fileName) - implicit none - integer ix,jx, status - character (len=*),intent(in) :: var_name, fileName - real,dimension(ix,jx):: out_buff -#ifdef MPP_LAND - real,allocatable, dimension(:,:) :: buff_g - -#ifdef HYDRO_D - write(6,*) "start to read variable ", var_name -#endif - allocate(buff_g (global_nx,global_ny) ) - - if(my_id .eq. IO_id) then - status = get2d_real(var_name,buff_g,global_nx,global_ny,fileName) - end if - call decompose_data_real(buff_g,out_buff) - deallocate(buff_g) -#else - status = get2d_real(var_name,out_buff,ix,jx,fileName) -#endif -#ifdef HYDRO_D - write(6,*) "finish reading variable ", var_name -#endif - end subroutine get2d_lsm_real - - subroutine get2d_lsm_vegtyp(out_buff,ix,jx,fileName) - implicit none - integer ix,jx, status,land_cat, iret, dimid,ncid - character (len=*),intent(in) :: fileName - character (len=256) units - integer,dimension(ix,jx):: out_buff - real, dimension(ix,jx) :: xdum -#ifdef MPP_LAND - real,allocatable, dimension(:,:) :: buff_g - - allocate(buff_g (global_nx,global_ny) ) - - if(my_id .eq. IO_id) then -#endif - ! Open the NetCDF file. - iret = nf_open(fileName, NF_NOWRITE, ncid) - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_static file: ''", A, "''")') & - trim(fileName) - call hydro_stop("get2d_lsm_vegtyp") -#endif - endif - - iret = nf_inq_dimid(ncid, "land_cat", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: land_cat" - call hydro_stop("get2d_lsm_vegtyp") -#endif - endif - - iret = nf_inq_dimlen(ncid, dimid, land_cat) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: land_cat" - call hydro_stop("get2d_lsm_vegtyp") -#endif - endif - -#ifdef MPP_LAND - call get_landuse_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat) - iret = nf_close(ncid) - end if - - call decompose_data_real(buff_g,xdum) - deallocate(buff_g) -#else - call get_landuse_netcdf(ncid, xdum, units, ix, jx, land_cat) - iret = nf_close(ncid) -#endif - out_buff = nint(xdum) - end subroutine get2d_lsm_vegtyp - - subroutine get_file_dimension(fileName, ix,jx) - implicit none - character(len=*) fileName - integer ncid , iret, ix,jx, dimid -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - iret = nf_open(fileName, NF_NOWRITE, ncid) - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_static file: ''", A, "''")') & - trim(fileName) - call hydro_stop("get_file_dimension") -#endif - endif - - iret = nf_inq_dimid(ncid, "west_east", dimid) - - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: west_east" - call hydro_stop("get_file_dimension") -#endif - endif - - iret = nf_inq_dimlen(ncid, dimid, ix) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: west_east" - call hydro_stop("get_file_dimension") -#endif - endif - - iret = nf_inq_dimid(ncid, "south_north", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: south_north" - call hydro_stop("get_file_dimension") -#endif - endif - - iret = nf_inq_dimlen(ncid, dimid, jx) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: south_north" - call hydro_stop("get_file_dimension") -#endif - endif - iret = nf_close(ncid) -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(ix) - call mpp_land_bcast_int1(jx) -#endif - - end subroutine get_file_dimension - - subroutine get2d_lsm_soltyp(out_buff,ix,jx,fileName) - implicit none - integer ix,jx, status,land_cat, iret, dimid,ncid - character (len=*),intent(in) :: fileName - character (len=256) units - integer,dimension(ix,jx):: out_buff - real, dimension(ix,jx) :: xdum -#ifdef MPP_LAND - real,allocatable, dimension(:,:) :: buff_g - - allocate(buff_g (global_nx,global_ny) ) - - if(my_id .eq. IO_id) then -#endif - ! Open the NetCDF file. - iret = nf_open(fileName, NF_NOWRITE, ncid) - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_static file: ''", A, "''")') & - trim(fileName) - call hydro_stop("get2d_lsm_soltyp") -#endif - endif - - iret = nf_inq_dimid(ncid, "soil_cat", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: soil_cat" - call hydro_stop("get2d_lsm_soltyp") -#endif - endif - - iret = nf_inq_dimlen(ncid, dimid, land_cat) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: soil_cat" - call hydro_stop("get2d_lsm_soltyp") -#endif - endif - -#ifdef MPP_LAND - call get_soilcat_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat) - iret = nf_close(ncid) - end if - - call decompose_data_real(buff_g,xdum) - deallocate(buff_g) -#else - call get_soilcat_netcdf(ncid, xdum, units, ix, jx, land_cat) - iret = nf_close(ncid) -#endif - out_buff = nint(xdum) - end subroutine get2d_lsm_soltyp - - - - - - - subroutine get_landuse_netcdf(ncid, array, units, idim, jdim, ldim) - implicit none -#include - integer, intent(in) :: ncid - integer, intent(in) :: idim, jdim, ldim - real, dimension(idim,jdim), intent(out) :: array - character(len=256), intent(out) :: units - integer :: iret, varid - real, dimension(idim,jdim,ldim) :: xtmp - integer, dimension(1) :: mp - integer :: i, j, l - character(len=24), parameter :: name = "LANDUSEF" - - units = "" - - iret = nf_inq_varid(ncid, trim(name), varid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_landuse_netcdf: nf_inq_varid" - call hydro_stop("get_landuse_netcdf") -#endif - endif - - iret = nf_get_var_real(ncid, varid, xtmp) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_landuse_netcdf: nf_get_var_real" - call hydro_stop("get_landuse_netcdf") -#endif - endif - - do i = 1, idim - do j = 1, jdim - mp = maxloc(xtmp(i,j,:)) - array(i,j) = mp(1) - do l = 1,ldim - if(xtmp(i,j,l).lt.0) array(i,j) = -9999.0 - enddo - enddo - enddo - - end subroutine get_landuse_netcdf - - - subroutine get_soilcat_netcdf(ncid, array, units, idim, jdim, ldim) - implicit none -#include - - integer, intent(in) :: ncid - integer, intent(in) :: idim, jdim, ldim - real, dimension(idim,jdim), intent(out) :: array - character(len=256), intent(out) :: units - integer :: iret, varid - real, dimension(idim,jdim,ldim) :: xtmp - integer, dimension(1) :: mp - integer :: i, j - character(len=24), parameter :: name = "SOILCTOP" - - units = "" - - iret = nf_inq_varid(ncid, trim(name), varid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_soilcat_netcdf: nf_inq_varid" - call hydro_stop("get_soilcat_netcdf") -#endif - endif - - iret = nf_get_var_real(ncid, varid, xtmp) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_soilcat_netcdf: nf_get_var_real" - call hydro_stop("get_soilcat_netcdf") -#endif - endif - - do i = 1, idim - do j = 1, jdim - mp = maxloc(xtmp(i,j,:)) - array(i,j) = mp(1) - enddo - enddo - - where (array == 14) array = 1 ! DJG remove all 'water' soils... - - end subroutine get_soilcat_netcdf - - -subroutine get_greenfrac_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) - implicit none -#include - integer, intent(in) :: ncid,mm,dd - integer, intent(in) :: idim, jdim, ldim - real, dimension(idim,jdim) :: array - real, dimension(idim,jdim) :: array2 - real, dimension(idim,jdim) :: diff - real, dimension(idim,jdim), intent(out) :: array3 - character(len=256), intent(out) :: units - integer :: iret, varid - real, dimension(idim,jdim,ldim) :: xtmp - integer, dimension(1) :: mp - integer :: i, j, mm2,daytot - real :: ddfrac - character(len=24), parameter :: name = "GREENFRAC" - - units = "fraction" - - iret = nf_inq_varid(ncid, trim(name), varid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_greenfrac_netcdf: nf_inq_varid" - call hydro_stop("get_greenfrac_netcdf") -#endif - endif - - iret = nf_get_var_real(ncid, varid, xtmp) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_greenfrac_netcdf: nf_get_var_real" - call hydro_stop("get_greenfrac_netcdf") -#endif - endif - - - if (mm.lt.12) then - mm2 = mm+1 - else - mm2 = 1 - end if - -!DJG_DES Set up dates for daily interpolation... - if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then - daytot = 31 - else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then - daytot = 30 - else if (mm.eq.2) then - daytot = 28 - end if - ddfrac = float(dd)/float(daytot) - if (ddfrac.gt.1.0) ddfrac = 1.0 ! Assumes Feb. 29th change is same as Feb 28th - -#ifdef HYDRO_D - print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac -#endif - - do i = 1, idim - do j = 1, jdim - array(i,j) = xtmp(i,j,mm) !GREENFRAC in geogrid in units of fraction from month 1 - array2(i,j) = xtmp(i,j,mm2) !GREENFRAC in geogrid in units of fraction from month 1 - diff(i,j) = array2(i,j) - array(i,j) - array3(i,j) = array(i,j) + ddfrac * diff(i,j) - enddo - enddo - -end subroutine get_greenfrac_netcdf - - - -subroutine get_albedo12m_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) - implicit none -#include - integer, intent(in) :: ncid,mm,dd - integer, intent(in) :: idim, jdim, ldim - real, dimension(idim,jdim) :: array - real, dimension(idim,jdim) :: array2 - real, dimension(idim,jdim) :: diff - real, dimension(idim,jdim), intent(out) :: array3 - character(len=256), intent(out) :: units - integer :: iret, varid - real, dimension(idim,jdim,ldim) :: xtmp - integer, dimension(1) :: mp - integer :: i, j, mm2,daytot - real :: ddfrac - character(len=24), parameter :: name = "ALBEDO12M" - - - units = "fraction" - - iret = nf_inq_varid(ncid, trim(name), varid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_albedo12m_netcdf: nf_inq_varid" - call hydro_stop("get_albedo12m_netcdf") -#endif - endif - - iret = nf_get_var_real(ncid, varid, xtmp) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_albedo12m_netcdf: nf_get_var_real" - call hydro_stop("get_albedo12m_netcdf") -#endif - endif - - if (mm.lt.12) then - mm2 = mm+1 - else - mm2 = 1 - end if - -!DJG_DES Set up dates for daily interpolation... - if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then - daytot = 31 - else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then - daytot = 30 - else if (mm.eq.2) then - daytot = 28 - end if - ddfrac = float(dd)/float(daytot) - if (ddfrac.gt.1.0) ddfrac = 1.0 ! Assumes Feb. 29th change is same as Feb 28th - -#ifdef HYDRO_D - print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac -#endif - - do i = 1, idim - do j = 1, jdim - array(i,j) = xtmp(i,j,mm) / 100.0 !Convert ALBEDO12M from % to fraction...month 1 - array2(i,j) = xtmp(i,j,mm2) / 100.0 !Convert ALBEDO12M from % to fraction... month 2 - diff(i,j) = array2(i,j) - array(i,j) - array3(i,j) = array(i,j) + ddfrac * diff(i,j) - enddo - enddo - -end subroutine get_albedo12m_netcdf - - - - subroutine get_2d_netcdf(name, ncid, array, units, idim, jdim, & - fatal_if_error, ierr) - implicit none -#include - character(len=*), intent(in) :: name - integer, intent(in) :: ncid - integer, intent(in) :: idim, jdim - real, dimension(idim,jdim), intent(out) :: array - character(len=256), intent(out) :: units - integer :: iret, varid - ! .TRUE._IF_ERROR: an input code value: - ! .TRUE. if an error in reading the data should stop the program. - ! Otherwise the, IERR error flag is set, but the program continues. - logical, intent(in) :: fatal_if_error - integer, intent(out) :: ierr - - units = "" - - iret = nf_inq_varid(ncid, name, varid) - - if (iret /= 0) then - if (fatal_IF_ERROR) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf: nf_inq_varid" - call hydro_stop("get_2d_netcdf") -#endif - else - ierr = iret - return - endif - endif - - - iret = nf_get_var_real(ncid, varid, array) - if (iret /= 0) then - if (fatal_IF_ERROR) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf: nf_get_var_real" - call hydro_stop("get_2d_netcdf") -#endif - else - ierr = iret - return - endif - endif - - ierr = 0; - end subroutine get_2d_netcdf - - subroutine get_2d_netcdf_cows(var_name,ncid,var, & - ix,jx,tlevel,fatal_if_error,ierr) -#include - character(len=*), intent(in) :: var_name - integer,intent(in) :: ncid,ix,jx,tlevel - real, intent(out):: var(ix,jx) - logical, intent(in) :: fatal_if_error - integer ierr, iret - integer varid - integer start(4),count(4) - data count /1,1,1,1/ - data start /1,1,1,1/ - count(1) = ix - count(2) = jx - start(4) = tlevel - iret = nf_inq_varid(ncid, var_name, varid) - - if (iret /= 0) then - if (fatal_IF_ERROR) then -#ifdef HYDRO_D - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid" - call hydro_stop("get_2d_netcdf_cows") -#endif - else - ierr = iret - return - endif - endif - iret = nf_get_vara_real(ncid, varid, start,count,var) - - return - end subroutine get_2d_netcdf_cows - -!--------------------------------------------------------- -!DJG Subroutinesfor inputting routing fields... -!DNY first reads the files to get the size of the -!DNY LINKS arrays -!DJG - Currently only hi-res topo is read -!DJG - At a future time, use this routine to input -!DJG subgrid land-use classification or routing -!DJG parameters 'overland roughness' and 'retention -!DJG depth' -! -!DJG,DNY - Update this subroutine to read in channel and lake -! parameters if activated 11.20.2005 -!--------------------------------------------------------- - - SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, & - route_direction_f, route_lake_f, NLINKS, NLAKES, & - CH_NETLNK, channel_option, geo_finegrid_flnm) - - implicit none -#include - INTEGER :: I,J,channel_option,iret,jj - INTEGER, INTENT(INOUT) :: NLINKS, NLAKES - INTEGER, INTENT(IN) :: IXRT,JXRT - INTEGER :: CHNID,cnt - INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction - INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - REAL, DIMENSION(IXRT,JXRT) :: LAT, LON - -!!Dummy read in grids for inverted y-axis - - - CHARACTER(len=*) :: route_chan_f, route_link_f,route_direction_f,route_lake_f - CHARACTER(len=256) :: InputLine - CHARACTER(len=256) :: geo_finegrid_flnm - CHARACTER(len=256) :: var_name -! external get2d_real -! integer :: get2d_real - - NLINKS = 0 - NLAKES = 0 - CH_NETRT = -9999 - CH_NETLNK = -9999 - - - cnt = 0 -#ifdef HYDRO_D - print *, "Channel Option in Routedim is ", channel_option -#endif - - IF(channel_option.eq.3) then !get maxnodes and links from grid - - var_name = "CHANNELGRID" - call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - - var_name = "FLOWDIRECTION" - call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - - var_name = "LAKEGRID" - call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - - - var_name = "LATITUDE" - call readRT2d_real(var_name,LAT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - var_name = "LONGITUDE" - call readRT2d_real(var_name,LON,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - -! temp fix for buggy Arc export... - do j=1,jxrt - do i=1,ixrt - if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 - end do - end do - -!DJG inv do j=jxrt,1,-1 - do j=1,jxrt - do i = 1, ixrt - if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then - NLINKS = NLINKS + 1 - endif - end do - end do -#ifdef HYDRO_D - print *, "NLINKS IS ", NLINKS -#endif - - -!DJG inv DO j = JXRT,1,-1 !rows - DO j = 1,JXRT !rows - DO i = 1 ,IXRT !colsumns - If (CH_NETRT(i, j) .ge. 0) then !get its direction - If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT).AND.(CH_NETRT(i,j+1) .ge.0) ) then !North - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1) .ge.0)) then !North East - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT).AND.(CH_NETRT(i+1,j) .ge. 0)) then !East - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & - .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i+1,j-1).ge.0)) then !south east - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0)) then !due south - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & - .AND. (j - 1 .NE. 0).AND. (CH_NETRT(i-1,j-1).ge.0) ) then !south west - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0)) then !West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0)) then !North West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else -#ifdef HYDRO_D - write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j -135 FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4) -#endif - if (DIRECTION(i,j) .eq. 0) then -#ifdef HYDRO_D - print *, "Direction i,j ",i,j," of point ", cnt, "is invalid" -#endif - endif - - End If - End If !CH_NETRT check for this node - END DO - END DO -#ifdef HYDRO_D - print *, "found type 0 nodes", cnt -#endif - -!Find out if the boundaries are on an edge or flow into a lake -!DJG inv DO j = JXRT,1,-1 - DO j = 1,JXRT - DO i = 1 ,IXRT - If (CH_NETRT(i, j) .ge. 0) then !get its direction - - If ( ((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) & !-- 64's can only flow north - .OR. ((DIRECTION(i, j) .EQ. 64).and. (j1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) & !-- 4's can only flow due south - .OR. ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west - .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge - .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE. 0)) & !-- 16's can only flow due west - .OR. ((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north - .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge - .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j - INTEGER, INTENT(IN) :: IXRT,JXRT - INTEGER :: CHANRTSWCRT, NLINKS, NLAKES - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION - INTEGER, DIMENSION(IXRT,JXRT) :: GSTRMFRXSTPTS - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT - INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - INTEGER, DIMENSION(IXRT,JXRT) :: GORDER !-- gridded stream orderk - INTEGER, DIMENSION(IXRT,JXRT) :: Link_Location !-- gridded stream orderk - INTEGER :: I,J,channel_option - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LATVAL, LONVAL - CHARACTER(len=28) :: dir -!Dummy inverted grids from arc - - -!----DJG,DNY New variables for channel and lake routing - CHARACTER(len=155) :: header - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: FROM_NODE - REAL, INTENT(OUT), DIMENSION(NLINKS) :: ZELEV - REAL, INTENT(OUT), DIMENSION(NLINKS) :: CHLAT,CHLON - - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: TYPEL - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: TO_NODE,ORDER - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: STRMFRXSTPTS - - INTEGER, INTENT(OUT) :: MAXORDER - REAL, INTENT(OUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum - REAL, INTENT(OUT), DIMENSION(NLINKS,2) :: QLINK !channel flow - REAL, INTENT(OUT), DIMENSION(NLINKS) :: CHANLEN !channel length - REAL, INTENT(OUT), DIMENSION(NLINKS) :: MannN, So !mannings N - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: LAKENODE ! identifies which nodes pour into which lakes - REAL, INTENT(IN) :: dist(ixrt,jxrt,9) - - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK - REAL, DIMENSION(IXRT,JXRT) :: ChSSlpG,BwG,MannNG !channel properties on Grid - - -!-- store the location x,y location of the channel element - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ - -!--reservoir/lake attributes - REAL, INTENT(OUT), DIMENSION(NLAKES) :: HRZAREA - REAL, INTENT(OUT), DIMENSION(NLAKES) :: LAKEMAXH - REAL, INTENT(OUT), DIMENSION(NLAKES) :: WEIRC - REAL, INTENT(OUT), DIMENSION(NLAKES) :: WEIRL - REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEC - REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEA - REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEE - REAL, INTENT(OUT), DIMENSION(NLAKES) :: LATLAKE,LONLAKE,ELEVLAKE - REAL, INTENT(OUT), DIMENSION(NLINKS) :: ChSSlp, Bw - - CHARACTER(len=256) :: route_link_f - CHARACTER(len=256) :: route_lake_f - CHARACTER(len=256) :: route_direction_f - CHARACTER(len=256) :: route_order_f - CHARACTER(len=256) :: geo_finegrid_flnm - CHARACTER(len=256) :: var_name - - INTEGER :: tmp, cnt, ncid, iret, jj,ct - real :: gc,n - -!--------------------------------------------------------- -! End Declarations -!--------------------------------------------------------- - MAXORDER = -9999 -!initialize GSTRM - GSTRMFRXSTPTS = -9999 - -!yw initialize the array. - to_node = MAXORDER - from_node = MAXORDER - -#ifdef HYDRO_D - print *, "reading routing initialization files..." - print *, "route direction", route_direction_f - print *, "route order", route_order_f - print *, "route linke",route_link_f - print *, "route lake",route_lake_f - - BwG = 0.0 - ChSSlpG = 0.0 - MannNG = 0.0 - TYPEL = 0 - MannN = 0.0 - Bw = 0.0 - ChSSlp = 0.0 - -#endif - -!DJG Edited code here to retrieve data from hires netcdf file.... - - IF((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then - - var_name = "LATITUDE" - call readRT2d_real(var_name,LATVAL,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - var_name = "LONGITUDE" - call readRT2d_real(var_name,LONVAL,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - - END IF - - - IF(CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2) then -!DJG change filename to LAKEPARM.TBL open(unit=79,file=trim(route_link_f), & - open(unit=79,file='LAKEPARM.TBL', & - form='formatted',status='old') - END IF - - - var_name = "LAKEGRID" - call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - var_name = "FLOWDIRECTION" - call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - var_name = "STREAMORDER" - call readRT2d_int(var_name,GORDER,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - var_name = "frxst_pts" - call readRT2d_int(var_name,GSTRMFRXSTPTS,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - -!--1/13/2011 real hi res sfc calibrtion parameters (...) -! var_name = "LAKEGRID" -! call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) -! var_name = "LAKEGRID" -! call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) - - -!-- real hi res channel properties (not yet implemented...) -! var_name = "MANNINGS" -! iret = get2d_real(var_name,MannNG,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) -! var_name = "SIDE_SLOPE" -! iret = get2d_real(var_name,ChSSlpG,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) -! var_name = "BOTTOM_WIDTH" -! iret = get2d_real(var_name,BwG,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) - - -!!!Flip y-dimension of highres grids from exported Arc files... - - - - - -! temp fix for buggy Arc export... - do j=1,jxrt - do i=1,ixrt - if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 - end do - end do - - cnt =0 - if ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option .ne. 3) then ! not routing on grid, read from file - read(79,*) header - do i=1,NLINKS - read (79,*) tmp, FROM_NODE(i), TO_NODE(i), TYPEL(i),& - ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), & - MannN(i), So(i), ChSSlp(i), Bw(i), HRZAREA(i),& - LAKEMAXH(i), WEIRC(i), WEIRL(i), ORIFICEC(i), & - ORIFICEA(i),ORIFICEE(i) - - !-- hardwire QLINK - QLINK(i,1) = 1.0 - QLINK(i,2) = QLINK(i,1) - - if (So(i).lt.0.005) So(i) = 0.005 !-- impose a minimum slope requireement - - if (ORDER(i) .gt. MAXORDER) then - MAXORDER = ORDER(i) - endif - - end do - - elseif ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then !-- handle setting up topology on the grid for diffusion scheme - - read(79,*) header !-- read the lake file -#ifdef HYDRO_D - write(*,*) "reading lake file ", header - write(6,*) "error check read file ",route_link_f -#endif - - - if (NLAKES.gt.0) then !read in only if there are lakes - do i=1, NLAKES - read (79,*) tmp, HRZAREA(i),LAKEMAXH(i), & - WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),& - LATLAKE(i), LONLAKE(i),ELEVLAKE(i) -#ifdef HYDRO_D - write (*,*) tmp, HRZAREA(i),LAKEMAXH(i), LATLAKE(i), LONLAKE(i),ELEVLAKE(i),NLAKES -#endif - enddo - end if !end if for NLAKES >0 check - - cnt = 0 - -!yw add temperary to initialize the following two variables. - -!yw debug -! write(6,*) "ixrt =",ixrt, "jxrt=",jxrt -! write(18) CH_NETRT -! write(19) DIRECTION -! write(20) GORDER -! write(21) GSTRMFRXSTPTS -! write(22) ELRT -!ywend debug - - BwG = 0.0 - ChSSlpG = 0.0 - -!DJG inv DO j = JXRT,1,-1 !rows - DO j = 1,JXRT !rows - DO i = 1 ,IXRT !colsumns - If (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order - If ((DIRECTION(i, j) .EQ. 64) .AND. (j + 1 .LE. JXRT) .AND. & - (CH_NETRT(i,j+1).ge.0) ) then !North - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i, j + 1) - CHANLEN(cnt) = dist(i,j,1) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1).ge.0) ) then !North East - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1) - CHANLEN(cnt) = dist(i,j,2) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT) & - .AND. (CH_NETRT(i+1,j).ge.0) ) then !East - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j) - CHANLEN(cnt) = dist(i,j,3) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & - .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i+1,j-1).ge.0) ) then !south east - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1) - CHANLEN(cnt) = dist(i,j,4) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0) ) then !due south - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i, j - 1) - CHANLEN(cnt) = dist(i,j,5) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & - .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i-1,j-1).ge.0)) then !south west - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i,j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1) - CHANLEN(cnt) = dist(i,j,6) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0) ) then !West - cnt = cnt + 1 - FROM_NODE(cnt) = CH_NETLNK(i, j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j) - CHANLEN(cnt) = dist(i,j,7) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0) ) then !North West - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1) - CHANLEN(cnt) = dist(i,j,8) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else -#ifdef HYDRO_D - print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east -#endif - End If - - End If !CH_NETRT check for this node - - END DO - END DO - -#ifdef HYDRO_D - print *, "after exiting the channel, this many nodes", cnt - write(*,*) " " -#endif - -!Find out if the boundaries are on an edge -!DJG inv DO j = JXRT,1,-1 - DO j = 1,JXRT - DO i = 1 ,IXRT - If (CH_NETRT(i, j) .ge. 0) then !get its direction - If (((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) .OR. & !-- 64's can only flow north - ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(j+1 .GT. JXRT) then !-- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i,j+1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i,j+1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,1) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - else if ( ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .GT. IXRT)) & !-- 128's can flow out of the North or East edge - .OR. ((DIRECTION(i, j) .EQ. 128) .AND. (j + 1 .GT. JXRT)) & ! this is due north edge - .OR. ((DIRECTION(i, j) .EQ. 128) .AND. (i1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if((i+1 .GT. IXRT) .OR. (j-1 .EQ. 0)) then !an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i+1,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,4) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - else if (((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) .OR. & !-- 4's can only flow due south - ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(j-1 .EQ. 0) then !- an edge - TYPEL(cnt) =1 - elseif(LAKE_MSKRT(i,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,5) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west - .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge - .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if( (i-1 .EQ. 0) .OR. (j-1 .EQ. 0) ) then !- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i-1,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,6) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - else if (((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE.0) ) & !16's can only flow due west - .OR.((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(i-1 .EQ. 0) then !-- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i-1,j).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i-1,j) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,7) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north - .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge - .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j - - integer, intent(in) :: IX,JX,IXRT,JXRT,AGGFACTRT - integer, intent(in), dimension(IXRT,JXRT) :: ch_netrt - integer, intent(out) :: numbasns - integer, intent(out), dimension(IX,JX) :: GWSUBBASMSK - integer, intent(out), dimension(IXRT,JXRT) :: gw_strm_msk - character(len=256) :: gwbasmskfil - integer :: i,j,aggfacxrt,aggfacyrt,ixxrt,jyyrt - - numbasns = 0 - gw_strm_msk = -9999 - -!Open files... - open(unit=91,file=trim(gwbasmskfil), & - form='formatted',status='old') - -!Read in sub-basin mask... - do j=jx,1,-1 - read (91,*) (GWSUBBASMSK(i,j),i=1,ix) - end do - close(91) - - -!Loop through to count number of basins and assign basin indices to chan grid - do J=1,JX - do I=1,IX - -!Determine max number of basins...(assumes basins are numbered -! sequentially from 1 to max number of basins...) - if (GWSUBBASMSK(i,j).gt.numbasns) then - numbasns = GWSUBBASMSK(i,j) ! get count of basins... - end if - -!Assign gw basin index values to channel grid... - do AGGFACYRT=AGGFACTRT-1,0,-1 - do AGGFACXRT=AGGFACTRT-1,0,-1 - - IXXRT=I*AGGFACTRT-AGGFACXRT - JYYRT=J*AGGFACTRT-AGGFACYRT - IF(ch_netrt(IXXRT,JYYRT).ge.0) then !If channel grid cell - gw_strm_msk(IXXRT,JYYRT) = GWSUBBASMSK(i,j) ! assign coarse grid basn indx to chan grid - END IF - - end do !AGGFACXRT - end do !AGGFACYRT - - end do !I-ix - end do !J-jx - -#ifdef HYDRO_D - write(6,*) "numbasns = ", numbasns -#endif - - return - -!DJG ----------------------------------------------------- - END SUBROUTINE READ_SIMP_GW -!DJG ----------------------------------------------------- - - ! BF read the static input fields needed for the 2D GW scheme - subroutine readGW2d(ix, jx, hc, ihead, botelv, por, ltype) - implicit none -#include - integer, intent(in) :: ix, jx - integer, dimension(ix,jx), intent(inout):: ltype - real, dimension(ix,jx), intent(inout) :: hc, ihead, botelv, por - -#ifdef MPP_LAND - integer, dimension(:,:), allocatable :: gLtype - real, dimension(:,:), allocatable :: gHC, gIHEAD, gBOTELV, gPOR -#endif - integer :: i -!, get2d_real - -#ifdef MPP_LAND - allocate(gHC(global_rt_nx, global_rt_ny)) - allocate(gIHEAD(global_rt_nx, global_rt_ny)) - allocate(gBOTELV(global_rt_nx, global_rt_ny)) - allocate(gPOR(global_rt_nx, global_rt_ny)) - allocate(gLtype(global_rt_nx, global_rt_ny)) - - if(my_id .eq. IO_id) then -#ifdef HYDRO_D - print*, "2D GW-Scheme selected, retrieving files from gwhires.nc ..." -#endif -#endif - - - ! hydraulic conductivity - i = get2d_real("HC", & -#ifdef MPP_LAND - gHC, global_nx, global_ny, & -#else - hc, ix, jx, & -#endif - trim("./gwhires.nc")) - - ! initial head - i = get2d_real("IHEAD", & -#ifdef MPP_LAND - gIHEAD, global_nx, global_ny, & -#else - ihead, ix, jx, & -#endif - trim("./gwhires.nc")) - - ! aquifer bottom elevation - i = get2d_real("BOTELV", & -#ifdef MPP_LAND - gBOTELV, global_nx, global_ny, & -#else - botelv, ix, jx, & -#endif - trim("./gwhires.nc")) - - ! aquifer porosity - i = get2d_real("POR", & -#ifdef MPP_LAND - gPOR, global_nx, global_ny, & -#else - por, ix, jx, & -#endif - trim("./gwhires.nc")) - -! bftodo: develop proper landtype mask - -#ifdef MPP_LAND - gLtype=1 - gLtype(1,:) = 2 - gLtype(:,1) = 2 - gLtype(global_rt_nx,:) = 2 - gLtype(:,global_rt_ny) = 2 -#else - ltype=1 - ltype(1,:) =2 - ltype(:,1) =2 - ltype(ix,:)=2 - ltype(:,jx)=2 -#endif - -#ifdef MPP_LAND - endif - call decompose_rt_int (gLtype, ltype, global_rt_nx, global_rt_ny, ix, jx) - call decompose_rt_real(gHC,hc,global_rt_nx, global_rt_ny, ix, jx) - call decompose_rt_real(gIHEAD,ihead,global_rt_nx, global_rt_ny, ix, jx) - call decompose_rt_real(gBOTELV,botelv,global_rt_nx, global_rt_ny, ix, jx) - call decompose_rt_real(gPOR,por,global_rt_nx, global_rt_ny, ix, jx) - deallocate(gHC, gIHEAD, gBOTELV, gPOR) -#endif - !bftodo: make filename accessible in namelist - return - end subroutine readGW2d - !BF - - - - - subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & - startdate, date, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID, & - q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, & - geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,HIRES_OUT, & - QBDRYRT) - -!output the routing variables over routing grid. - implicit none -#include - - integer, intent(in) :: igrid - integer, intent(in) :: split_output_count - integer, intent(in) :: ixrt,jxrt - real, intent(in) :: dt - real, intent(in) :: dist(ixrt,jxrt,9) - integer, intent(in) :: nsoil - integer, intent(in) :: HIRES_OUT - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - character(len=*), intent(in) :: geo_finegrid_flnm - real, dimension(nsoil), intent(in) :: sldpth - real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable - real*8, allocatable, DIMENSION(:) :: xcoord_d, xcoord - real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord - - integer, save :: ncid,ncstatic - integer, save :: output_count - real, dimension(nsoil) :: asldpth - - integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n - integer :: iret, dimid_soil, i,j,ii,jj - character(len=256) :: output_flnm - character(len=19) :: date19 - character(len=32) :: convention - character(len=34) :: sec_since_date - - character(len=30) :: soilm - - real :: long_cm,lat_po,fe,fn, chan_in - real, dimension(2) :: sp - - real, dimension(ixrt,jxrt) :: xdum,QSUBRT,ZWATTABLRT,SUB_RESID - real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y - real, dimension(ixrt,jxrt) :: QSTRMVOLRT - real, dimension(ixrt,jxrt) :: SFCHEADSUBRT - real, dimension(ixrt,jxrt) :: soxrt,soyrt - real, dimension(ixrt,jxrt) :: LATVAL,LONVAL, QBDRYRT - real, dimension(ixrt,jxrt,nsoil) :: SMCRT - - integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag - sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' - seconds_since = int(dt)*output_count - - decimation = 1 !-- decimation factor - ixrtd = int(ixrt/decimation) - jxrtd = int(jxrt/decimation) - allocate(xdumd(ixrtd,jxrtd)) - allocate(xcoord_d(ixrtd)) - allocate(ycoord_d(jxrtd)) - allocate(xcoord(ixrtd)) - allocate(ycoord(jxrtd)) - ii = 0 - jj = 0 - -!DJG Dump timeseries for channel inflow accum. for calibration...(8/28/09) - chan_in = 0.0 - do j=1,jxrt - do i=1,ixrt - chan_in=chan_in+QSTRMVOLRT(I,J)/1000.0*(dist(i,j,9)) !(units m^3) - enddo - enddo - open (unit=46,file='qstrmvolrt_accum.txt',form='formatted',& - status='unknown',position='append') - write (46,713) chan_in -713 FORMAT (F20.7) - close (46) -! return -!DJG end dump of channel inflow for calibration.... - - if (hires_out.eq.1) return ! return if hires flag eq 1, if =2 output full grid - - if (output_count == 0) then - - !-- Open the finemesh static files to obtain projection information -#ifdef HYDRO_D - write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) -#endif - iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic) - - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & - trim(geo_finegrid_flnm) - write(*,*) "HIRES_OUTPUT will not be georeferenced..." -#endif - - hires_flag = 0 - else - hires_flag = 1 - endif - - if(hires_flag.eq.1) then !if/then hires_georef - ! Get Latitude (X) - iret = NF_INQ_VARID(ncstatic,'x',varid) - if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord) - ! Get Longitude (Y) - iret = NF_INQ_VARID(ncstatic,'y',varid) - if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord) - else - xcoord_d = 0. - ycoord_d = 0. - end if !endif hires_georef - - do j=jxrt,1,-1*decimation - jj = jj+1 - if (jj<= jxrtd) then - ycoord_d(jj) = ycoord(j) - endif - enddo - -!yw do i = 1,ixrt,decimation -!yw ii = ii + 1 -!yw if (ii <= ixrtd) then -!yw xcoord_d(ii) = xcoord(i) - xcoord_d = xcoord -!yw endif -!yw enddo - - - if(hires_flag.eq.1) then !if/then hires_georef - ! Get projection information from finegrid netcdf file - iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) - if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file - end if !endif hires_georef - iret = nf_close(ncstatic) - -!-- create the fine grid routing file - write(output_flnm, '(A12,".RTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid -#ifdef HYDRO_D - print*, 'output_flnm = "'//trim(output_flnm)//'"' -#endif -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) -#endif -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("output_rt") - endif -#endif - - iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times) - iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx) - iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil) !-- 3-d soils - -!--- define variables -! !- time definition, timeObs - iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) - - !- x-coordinate in cartesian system - iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') - iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') - iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - - !- y-coordinate in cartesian ssystem - iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') - iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') - iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - - !- LATITUDE - iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE') - iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE') - iret = nf_put_att_text(ncid,varid,'units',5,'deg North') - - !- LONGITUDE - iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE') - iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE') - iret = nf_put_att_text(ncid,varid,'units',5,'deg east') - - !-- z-level is soil - iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid) - iret = nf_put_att_text(ncid,varid,'units',2,'cm') - iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer') - - iret = nf_def_var(ncid, "SOIL_M", NF_FLOAT, 4, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',7,'m^3/m^3') - iret = nf_put_att_text(ncid,varid,'description',16,'moisture content') - iret = nf_put_att_text(ncid,varid,'long_name',26,soilm) -! iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"ESNOW2D",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - -! iret = nf_def_var(ncid,"QSUBRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) -! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') -! iret = nf_put_att_text(ncid,varid,'long_name',15,'subsurface flow') -! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') -! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') -! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"ZWATTABLRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',1,'m') - iret = nf_put_att_text(ncid,varid,'long_name',17,'water table depth') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"Q_SFCFLX_X",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) -! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') -! iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux x') -! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') -! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') -! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"Q_SFCFLX_Y",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) -! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') -! iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux y') -! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') -! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') -! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"QSTRMVOLRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',2,'mm') - iret = nf_put_att_text(ncid,varid,'long_name',14,'channel inflow') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"SFCHEADSUBRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',2,'mm') - iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"SOXRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) -! iret = nf_put_att_text(ncid,varid,'units',1,'1') -! iret = nf_put_att_text(ncid,varid,'long_name',7,'slope x') -! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') -! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') -! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"SOYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) -! iret = nf_put_att_text(ncid,varid,'units',1,'1') -! iret = nf_put_att_text(ncid,varid,'long_name',7,'slope 7') -! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') -! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') -! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"SUB_RESID",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - - iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',2,'mm') - iret = nf_put_att_text(ncid,varid,'long_name',70, & - 'accumulated value of the boundary flux, + into domain, - out of domain') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -!-- place projection information - if(hires_flag.eq.1) then !if/then hires_georef - iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid) - iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm) - iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po) - iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe) - iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn) - iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp) - end if !endif hires_georef - -! iret = nf_def_var(ncid,"Date", NF_CHAR, 2, (/dimid_datelen,dimid_times/), varid) - - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(startdate)) = startdate - convention(1:32) = "CF-1.0" - iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19) - iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation) - - iret = nf_enddef(ncid) - -!!-- write latitude and longitude locations -! xdumd = LATVAL - iret = nf_inq_varid(ncid,"x", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array - -! xdumd = LONVAL - iret = nf_inq_varid(ncid,"y", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array - - xdumd = LATVAL - iret = nf_inq_varid(ncid,"LATITUDE", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - - xdumd = LONVAL - iret = nf_inq_varid(ncid,"LONGITUDE", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - - -#ifdef HYDRO_D - write (*,*) "TEST....",LONVAL (1,1),(1,2) - write (*,*) "TEST....",LATVAL (1,1),(1,2) -#endif - - - - - do n = 1,nsoil - if(n == 1) then - asldpth(n) = -sldpth(n) - else - asldpth(n) = asldpth(n-1) - sldpth(n) - endif - enddo - - iret = nf_inq_varid(ncid,"depth", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth) -!yw iret = nf_close(ncstatic) - - endif - - output_count = output_count + 1 - -!!-- time - iret = nf_inq_varid(ncid,"time", varid) - iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since) - -!-- 3-d soils - do n = 1, nsoil -!DJG inv jj = int(jxrt/decimation) - jj = 1 - ii = 0 -!DJG inv do j = jxrt,1,-decimation - do j = 1,jxrt,decimation - do i = 1,ixrt,decimation - ii = ii + 1 - if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then - xdumd(ii,jj) = smcrt(i,j,n) - endif - enddo - ii = 0 -!DJG inv jj = jj -1 - jj = jj + 1 - enddo -! where (vegtyp(:,:) == 16) xdum = -1.E33 - iret = nf_inq_varid(ncid, "SOIL_M", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/), xdumd) - enddo !-n soils - - -!! where (vegtyp(:,:) == 16) xdum = -1.E33 -! jj = int(jxrt/decimation) -! ii = 0 -!! do j = jxrt,1,-decimation -! do j = 1,jxrt,decimation -! do i = 1,ixrt,decimation -! ii = ii + 1 -! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then -! xdumd(ii,jj) = QSUBRT(i,j) -! endif -! enddo -! ii = 0 -! jj = jj - 1 -! enddo -! iret = nf_inq_varid(ncid, "QSUBRT", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -! xdum = ZWATTABLRT -! where (vegtyp(:,:) == 16) xdum = -1.E33 -!DJG inv jj = int(jxrt/decimation) - jj = 1 - ii = 0 -!DJG inv do j = jxrt,1,-decimation - do j = 1,jxrt,decimation - do i = 1,ixrt,decimation - ii = ii + 1 - if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then - xdumd(ii,jj) = ZWATTABLRT(i,j) - endif - enddo - ii = 0 -!DJG inv jj = jj - 1 - jj = jj + 1 - enddo - iret = nf_inq_varid(ncid, "ZWATTABLRT", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - - -!! xdum = Q_SFCFLX_X -!!! where (vegtyp(:,:) == 16) xdum = -1.E33 -! jj = int(jxrt/decimation) -! ii = 0 -!! do j = jxrt,1,-decimation -! do j = 1,jxrt,decimation -! do i = 1,ixrt,decimation -! ii = ii + 1 -! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then -! xdumd(ii,jj) = Q_SFCFLX_X(i,j) -! endif -! enddo -! ii = 0 -! jj = jj - 1 -! enddo -! iret = nf_inq_varid(ncid, "Q_SFCFLX_X", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) -!! -!! xdum = Q_SFCFLX_Y -!!! where (vegtyp(:,:) == 16) xdum = -1.E33 -! jj = int(jxrt/decimation) -! ii = 0 -!! do j = jxrt,1,-decimation -! do j = 1,jxrt,decimation -! do i = 1,ixrt,decimation -! ii = ii + 1 -! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then -! xdumd(ii,jj) = Q_SFCFLX_Y(i,j) -! endif -! enddo -! ii = 0 -! jj = jj - 1 -! enddo -! iret = nf_inq_varid(ncid, "Q_SFCFLX_Y", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -! for compareing between sequential and parallel to initialized xdumd - xdumd = 0.0 - jj = 1 - ii = 0 - do j = 1,jxrt,decimation - do i = 1,ixrt,decimation - ii = ii + 1 - if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then - xdumd(ii,jj) = QBDRYRT(i,j) - endif - enddo - ii = 0 - jj = jj + 1 - enddo - iret = nf_inq_varid(ncid, "QBDRYRT", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - - - xdumd = 0.0 -! xdum = QSTRMVOLRT -!! where (vegtyp(:,:) == 16) xdum = -1.E33 -!DJG inv jj = int(jxrt/decimation) - jj = 1 - ii = 0 -!DJG inv do j = jxrt,1,-decimation - do j = 1,jxrt,decimation - do i = 1,ixrt,decimation - ii = ii + 1 - if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then - xdumd(ii,jj) = QSTRMVOLRT(i,j) - endif - enddo - ii = 0 -!DJG inv jj = jj - 1 - jj = jj + 1 - enddo - iret = nf_inq_varid(ncid, "QSTRMVOLRT", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -! xdum = SFCHEADSUBRT -! where (vegtyp(:,:) == 16) xdum = -1.E33 -!DJG inv jj = int(jxrt/decimation) - jj = 1 - ii = 0 -!DJG inv do j = jxrt,1,-decimation - do j = 1,jxrt,decimation - do i = 1,ixrt,decimation - ii = ii + 1 - if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then - xdumd(ii,jj) = SFCHEADSUBRT(i,j) - endif - enddo - ii = 0 -!DJG inv jj = jj - 1 - jj = jj + 1 - enddo - iret = nf_inq_varid(ncid, "SFCHEADSUBRT", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - - -! iret = nf_inq_varid(ncid, "SOXRT", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -!!! where (vegtyp(:,:) == 16) xdum = -1.E33 -! iret = nf_inq_varid(ncid, "SOYRT", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) -! -!! xdum = SUB_RESID -!!! where (vegtyp(:,:) == 16) xdum = -1.E33 -!! iret = nf_inq_varid(ncid, "SUB_RESID", varid) -!! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) -! -!!time in seconds since startdate - - iret = nf_redef(ncid) - date19(1:len_trim(date)) = date - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) - - iret = nf_enddef(ncid) - iret = nf_sync(ncid) - if (output_count == split_output_count) then - output_count = 0 - iret = nf_close(ncid) - endif - - deallocate(xdumd) - deallocate(xcoord_d) - deallocate(xcoord) - deallocate(ycoord_d) - deallocate(ycoord) - -#ifdef HYDRO_D - write(6,*) "end of output_rt" -#endif - - end subroutine output_rt - -!BF output section for gw2d model -!bftodo: clean up an customize for GW usage - subroutine output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, & - startdate, date, HEAD, SMCRT, convgw, SFCHEADSUBRT, & - geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,HIRES_OUT) - -#ifdef MPP_LAND - USE module_mpp_land -#endif -!output the routing variables over routing grid. - implicit none -#include - - integer, intent(in) :: igrid - integer, intent(in) :: split_output_count - integer, intent(in) :: ixrt,jxrt - real, intent(in) :: dt - real, intent(in) :: dist(ixrt,jxrt,9) - integer, intent(in) :: nsoil - integer, intent(in) :: HIRES_OUT - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - character(len=*), intent(in) :: geo_finegrid_flnm - real, dimension(nsoil), intent(in) :: sldpth - real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable - real*8, allocatable, DIMENSION(:) :: xcoord_d, xcoord - real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord - - integer, save :: ncid,ncstatic - integer, save :: output_count - real, dimension(nsoil) :: asldpth - - integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n - integer :: iret, dimid_soil, i,j,ii,jj - character(len=256) :: output_flnm - character(len=19) :: date19 - character(len=32) :: convention - character(len=34) :: sec_since_date - - character(len=30) :: soilm - - real :: long_cm,lat_po,fe,fn, chan_in - real, dimension(2) :: sp - - real, dimension(ixrt,jxrt) :: head, convgw - real, dimension(ixrt,jxrt) :: SFCHEADSUBRT - real, dimension(ixrt,jxrt) :: latval,lonval - real, dimension(ixrt,jxrt,nsoil) :: SMCRT - - integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag - -#ifdef MPP_LAND - real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gSFCHEADSUBRT - real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval - real, dimension(global_rt_nx,global_rt_ny,nsoil) :: gSMCRT -#endif - -#ifdef MPP_LAND - call write_IO_rt_real(latval,gLatval) - call write_IO_rt_real(lonval,gLonval) - call write_IO_rt_real(SFCHEADSUBRT,gSFCHEADSUBRT) - call write_IO_rt_real(head,gHead) - call write_IO_rt_real(convgw,gConvgw) - - do i = 1, NSOIL - call write_IO_rt_real(SMCRT(:,:,i),gSMCRT(:,:,i)) - end do - - if(my_id.eq.IO_id) then - - -#endif - sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' - seconds_since = int(dt)*output_count - - decimation = 1 !-- decimation factor -#ifdef MPP_LAND - ixrtd = int(global_rt_nx/decimation) - jxrtd = int(global_rt_ny/decimation) -#else - ixrtd = int(ixrt/decimation) - jxrtd = int(jxrt/decimation) -#endif - allocate(xdumd(ixrtd,jxrtd)) - allocate(xcoord_d(ixrtd)) - allocate(ycoord_d(jxrtd)) - allocate(xcoord(ixrtd)) - allocate(ycoord(jxrtd)) - ii = 0 - jj = 0 - - if (hires_out.eq.1) return ! return if hires flag eq 1, if =2 output full grid - - if (output_count == 0) then - - !-- Open the finemesh static files to obtain projection information -#ifdef HYDRO_D - write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) - -#endif - iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic) - - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & - trim(geo_finegrid_flnm) - write(*,*) "HIRES_OUTPUT will not be georeferenced..." -#endif - hires_flag = 0 - else - hires_flag = 1 - endif - - if(hires_flag.eq.1) then !if/then hires_georef - ! Get Latitude (X) - iret = NF_INQ_VARID(ncstatic,'x',varid) - if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord) - ! Get Longitude (Y) - iret = NF_INQ_VARID(ncstatic,'y',varid) - if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord) - else - xcoord_d = 0. - ycoord_d = 0. - end if !endif hires_georef - - do j=jxrt,1,-1*decimation - jj = jj+1 - if (jj<= jxrtd) then - ycoord_d(jj) = ycoord(j) - endif - enddo - -!yw do i = 1,ixrt,decimation -!yw ii = ii + 1 -!yw if (ii <= ixrtd) then -!yw xcoord_d(ii) = xcoord(i) - xcoord_d = xcoord -!yw endif -!yw enddo - - - if(hires_flag.eq.1) then !if/then hires_georef - ! Get projection information from finegrid netcdf file - iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) - if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file - end if !endif hires_georef - iret = nf_close(ncstatic) - -!-- create the fine grid routing file - write(output_flnm, '(A12,".GW_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid -#ifdef HYDRO_D - print*, 'output_flnm = "'//trim(output_flnm)//'"' -#endif - - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) -#endif - -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("output_rt") - endif -#endif - - iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times) - iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx) - iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil) !-- 3-d soils - -!--- define variables - !- time definition, timeObs - iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) - - !- x-coordinate in cartesian system - iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') - iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') - iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - - !- y-coordinate in cartesian ssystem - iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') - iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') - iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - - !- LATITUDE - iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE') - iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE') - iret = nf_put_att_text(ncid,varid,'units',5,'deg North') - - !- LONGITUDE - iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE') - iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE') - iret = nf_put_att_text(ncid,varid,'units',5,'deg east') - - !-- z-level is soil - iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid) - iret = nf_put_att_text(ncid,varid,'units',2,'cm') - iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer') - - iret = nf_def_var(ncid, "SOIL_M", NF_FLOAT, 4, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',6,'kg m-2') - iret = nf_put_att_text(ncid,varid,'description',16,'moisture content') - iret = nf_put_att_text(ncid,varid,'long_name',26,soilm) -! iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"HEAD",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',1,'m') - iret = nf_put_att_text(ncid,varid,'long_name',17,'groundwater head') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"CONVGW",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',2,'mm') - iret = nf_put_att_text(ncid,varid,'long_name',12,'channel flux') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"Platzhalter",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',2,'mm') - iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -!-- place projection information - if(hires_flag.eq.1) then !if/then hires_georef - iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid) - iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm) - iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po) - iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe) - iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn) - iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp) - end if !endif hires_georef - -! iret = nf_def_var(ncid,"Date", NF_CHAR, 2, (/dimid_datelen,dimid_times/), varid) - - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(startdate)) = startdate - convention(1:32) = "CF-1.0" - iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19) - iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation) - - iret = nf_enddef(ncid) - -!!-- write latitude and longitude locations -! xdumd = LATVAL - iret = nf_inq_varid(ncid,"x", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array - -! xdumd = LONVAL - iret = nf_inq_varid(ncid,"y", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array - -#ifdef MPP_LAND - xdumd = gLATVAL -#else - xdumd = LATVAL -#endif - iret = nf_inq_varid(ncid,"LATITUDE", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - -#ifdef MPP_LAND - xdumd = gLONVAL -#else - xdumd = LONVAL -#endif - iret = nf_inq_varid(ncid,"LONGITUDE", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - - do n = 1,nsoil - if(n == 1) then - asldpth(n) = -sldpth(n) - else - asldpth(n) = asldpth(n-1) - sldpth(n) - endif - enddo - - iret = nf_inq_varid(ncid,"depth", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth) -!yw iret = nf_close(ncstatic) - - endif - - output_count = output_count + 1 - -!!-- time - iret = nf_inq_varid(ncid,"time", varid) - iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since) - -!-- 3-d soils - do n = 1, nsoil -#ifdef MPP_LAND - xdumd = gSMCRT(:,:,n) -#else - xdumd = SMCRT(:,:,n) -#endif -! !DJG inv jj = int(jxrt/decimation) -! jj = 1 -! ii = 0 -! !DJG inv do j = jxrt,1,-decimation -! do j = 1,jxrt,decimation -! do i = 1,ixrt,decimation -! ii = ii + 1 -! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then -! xdumd(ii,jj) = smcrt(i,j,n) -! endif -! enddo -! ii = 0 -! !DJG inv jj = jj -1 -! jj = jj + 1 -! enddo -! where (vegtyp(:,:) == 16) xdum = -1.E33 - iret = nf_inq_varid(ncid, "SOIL_M", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/), xdumd) - enddo !-n soils - -#ifdef MPP_LAND - xdumd = gHead -#else - xdumd = head -#endif - - iret = nf_inq_varid(ncid, "HEAD", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -#ifdef MPP_LAND - xdumd = gConvgw -#else - xdumd = convgw -#endif - iret = nf_inq_varid(ncid, "CONVGW", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -!!time in seconds since startdate - - iret = nf_redef(ncid) - date19(1:len_trim(date)) = date - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) - - iret = nf_enddef(ncid) - iret = nf_sync(ncid) - if (output_count == split_output_count) then - output_count = 0 - iret = nf_close(ncid) - endif - - deallocate(xdumd) - deallocate(xcoord_d) - deallocate(xcoord) - deallocate(ycoord_d) - deallocate(ycoord) - -#ifdef HYDRO_D - write(6,*) "end of output_ge" -#endif -#ifdef MPP_LAND - endif -#endif - - end subroutine output_gw - -!-- output the channel route in an IDV 'station' compatible format - subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER, & - startdate,date,chlon, chlat, hlink,zelev,qlink,dtrt,K, & - STRMFRXSTPTS,order_to_write) - - implicit none -#include -!!output the routing variables over just channel - integer, intent(in) :: igrid,K - integer, intent(in) :: split_output_count - integer, intent(in) :: NLINKS - real, dimension(NLINKS), intent(in) :: chlon,chlat - real, dimension(NLINKS), intent(in) :: hlink,zelev - integer, dimension(NLINKS), intent(in) :: ORDER - integer, dimension(NLINKS), intent(inout) :: STRMFRXSTPTS - - real, intent(in) :: dtrt - real, dimension(NLINKS,2), intent(in) :: qlink - - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - - real, allocatable, DIMENSION(:) :: chanlat,chanlon - real, allocatable, DIMENSION(:) :: chanlatO,chanlonO - - real, allocatable, DIMENSION(:) :: elevation - real, allocatable, DIMENSION(:) :: elevationO - - integer, allocatable, DIMENSION(:) :: station_id - integer, allocatable, DIMENSION(:) :: station_idO - - integer, allocatable, DIMENSION(:) :: rec_num_of_station - integer, allocatable, DIMENSION(:) :: rec_num_of_stationO - - integer, allocatable, DIMENSION(:) :: lOrder !- local stream order - integer, allocatable, DIMENSION(:) :: lOrderO !- local stream order - - integer, save :: output_count - integer, save :: ncid,ncid2 - - integer :: stationdim, dimdata, varid, charid, n - integer :: obsdim, dimdataO, charidO - - integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output - integer :: start_posO, prev_posO - - integer :: previous_pos !-- used for the station model - character(len=256) :: output_flnm,output_flnm2 - character(len=19) :: date19,date19start - character(len=34) :: sec_since_date - integer :: seconds_since,nstations,cnt,ObsStation,nobs - character(len=32) :: convention - character(len=11),allocatable, DIMENSION(:) :: stname - character(len=11),allocatable, DIMENSION(:) :: stnameO - - !--- all this for writing the station id string - INTEGER TDIMS, TXLEN - PARAMETER (TDIMS=2) ! number of TX dimensions - PARAMETER (TXLEN = 11) ! length of example string - INTEGER TIMEID ! record dimension id - INTEGER TXID ! variable ID - INTEGER TXDIMS(TDIMS) ! variable shape - INTEGER TSTART(TDIMS), TCOUNT(TDIMS) - - !-- observation point ids - INTEGER OTDIMS, OTXLEN - PARAMETER (OTDIMS=2) ! number of TX dimensions - PARAMETER (OTXLEN = 11) ! length of example string - INTEGER OTIMEID ! record dimension id - INTEGER OTXID ! variable ID - INTEGER OTXDIMS(OTDIMS) ! variable shape - INTEGER OTSTART(OTDIMS), OTCOUNT(OTDIMS) - -#ifdef HYDRO_D - write(6,*) "yyww dtrt =", dtrt , "k =", k -#endif - - seconds_since = int(dtrt)*K - -! order_to_write = 2 !-- 1 all; 6 feweest - - nstations = 0 ! total number of channel points to display - nobs = 0 ! number of observation points - -!-- output only the higher oder streamflows and only observation points - do i=1,NLINKS - if(ORDER(i) .ge. order_to_write) then - nstations = nstations + 1 - endif - if(STRMFRXSTPTS(i) .ne. -9999) then - nobs = nobs + 1 - endif - enddo - - if (nobs .eq. 0) then ! let's at least make one obs point - nobs = 1 - STRMFRXSTPTS(1) = 1 - endif - - allocate(chanlat(nstations)) - allocate(chanlon(nstations)) - allocate(elevation(nstations)) - allocate(station_id(nstations)) - allocate(lOrder(nstations)) - allocate(rec_num_of_station(nstations)) - allocate(stname(nstations)) - - allocate(chanlatO(nobs)) - allocate(chanlonO(nobs)) - allocate(elevationO(nobs)) - allocate(station_idO(nobs)) - allocate(lOrderO(nobs)) - allocate(rec_num_of_stationO(nobs)) - allocate(stnameO(nobs)) - - if(output_count == 0) then -!-- have moved sec_since_date from above here.. - sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & - //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' - - date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & - //startdate(12:13)//':'//startdate(15:16)//':00' - - nstations = 0 - nobs = 0 - - write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid - write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid - -#ifdef HYDRO_D - print*, 'output_flnm = "'//trim(output_flnm)//'"' -#endif - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) -#endif -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create points" - call hydro_stop("output_chrt") - endif -#endif - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm2), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid2) -#else - iret = nf_create(trim(output_flnm2), NF_CLOBBER, ncid2) -#endif -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create observation" - call hydro_stop("output_chrt") - endif -#endif - - do i=1,NLINKS - if(ORDER(i) .ge. order_to_write) then - nstations = nstations + 1 - chanlat(nstations) = chlat(i) - chanlon(nstations) = chlon(i) - elevation(nstations) = zelev(i) - lOrder(nstations) = ORDER(i) - station_id(nstations) = i - if(STRMFRXSTPTS(nstations) .eq. -9999) then - ObsStation = 0 - else - ObsStation = 1 - endif - write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation - endif - enddo - - - do i=1,NLINKS - if(STRMFRXSTPTS(i) .ne. -9999) then - nobs = nobs + 1 - chanlatO(nobs) = chlat(i) - chanlonO(nobs) = chlon(i) - elevationO(nobs) = zelev(i) - lOrderO(nobs) = ORDER(i) - station_idO(nobs) = i - write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs) -#ifdef HYDRO_D -! print *,"stationobservation name", stnameO(nobs) -#endif - endif - enddo - - iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata) !--for linked list approach - - - iret = nf_def_dim(ncid, "station", nstations, stationdim) - - - - iret = nf_def_dim(ncid2, "recNum", NF_UNLIMITED, dimdataO) !--for linked list approach - iret = nf_def_dim(ncid2, "station", nobs, obsdim) - - - !- station location definition all, lat - iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid) -#ifdef HYDRO_D - write(6,*) "iret 2.1, ", iret, stationdim -#endif - iret = nf_put_att_text(ncid,varid,'long_name',16,'Station latitude') -#ifdef HYDRO_D - write(6,*) "iret 2.2", iret -#endif - iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north') -#ifdef HYDRO_D - write(6,*) "iret 2.3", iret -#endif - - - !- station location definition obs, lat - iret = nf_def_var(ncid2,"latitude",NF_FLOAT, 1, (/obsdim/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation latitude') - iret = nf_put_att_text(ncid2,varid,'units',13,'degrees_north') - - - !- station location definition, long - iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',17,'Station longitude') - iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east') - - - !- station location definition, obs long - iret = nf_def_var(ncid2,"longitude",NF_FLOAT, 1, (/obsdim/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',21,'Observation longitude') - iret = nf_put_att_text(ncid2,varid,'units',12,'degrees_east') - - -! !-- elevation is ZELEV - iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',16,'Station altitude') - iret = nf_put_att_text(ncid,varid,'units',6,'meters') - - -! !-- elevation is obs ZELEV - iret = nf_def_var(ncid2,"altitude",NF_FLOAT, 1, (/obsdim/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation altitude') - iret = nf_put_att_text(ncid2,varid,'units',6,'meters') - - -! !-- gage observation -! iret = nf_def_var(ncid,"gages",NF_FLOAT, 1, (/stationdim/), varid) -! iret = nf_put_att_text(ncid,varid,'long_name',20,'Stream Gage Location') -! iret = nf_put_att_text(ncid,varid,'units',4,'none') - -!-- parent index - iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',36,'index of the station for this record') - - iret = nf_def_var(ncid2,"parent_index",NF_INT,1,(/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',36,'index of the station for this record') - - !-- prevChild - iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',57,'record number of the previous record for the same station') -!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - - iret = nf_def_var(ncid2,"prevChild",NF_INT,1,(/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',57,'record number of the previous record for the same station') -!ywtmp iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1) - - !-- lastChild - iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',30,'latest report for this station') -!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - - iret = nf_def_var(ncid2,"lastChild",NF_INT,1,(/obsdim/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',30,'latest report for this station') -!ywtmp iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1) - -! !- flow definition, var - iret = nf_def_var(ncid, "streamflow", NF_FLOAT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') - iret = nf_put_att_text(ncid,varid,'long_name',10,'River Flow') - - iret = nf_def_var(ncid2, "streamflow", NF_FLOAT, 1, (/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec') - iret = nf_put_att_text(ncid2,varid,'long_name',10,'River Flow') - -! !- flow definition, var -! iret = nf_def_var(ncid, "pos_streamflow", NF_FLOAT, 1, (/dimdata/), varid) -! iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') -! iret = nf_put_att_text(ncid,varid,'long_name',14,'abs streamflow') - -! !- head definition, var - iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',5,'meter') - iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage') - - iret = nf_def_var(ncid2, "head", NF_FLOAT, 1, (/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'units',5,'meter') - iret = nf_put_att_text(ncid2,varid,'long_name',11,'River Stage') - - -! !- order definition, var - iret = nf_def_var(ncid, "order", NF_INT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',21,'Strahler Stream Order') - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - - iret = nf_def_var(ncid2, "order", NF_INT, 1, (/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',21,'Strahler Stream Order') - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - - - !-- station id - ! define character-position dimension for strings of max length 11 - iret = NF_DEF_DIM(ncid, "id_len", 11, charid) - TXDIMS(1) = charid ! define char-string variable and position dimension first - TXDIMS(2) = stationdim - iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid) - iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id') - - iret = NF_DEF_DIM(ncid2, "id_len", 11, charidO) - OTXDIMS(1) = charidO ! define char-string variable and position dimension first - OTXDIMS(2) = obsdim - iret = nf_def_var(ncid2,"station_id",NF_CHAR, OTDIMS, OTXDIMS, varid) - iret = nf_put_att_text(ncid2,varid,'long_name',14,'Observation id') - - -! !- time definition, timeObs - iret = nf_def_var(ncid,"time_observation",NF_INT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) - iret = nf_put_att_text(ncid,varid,'long_name',19,'time of observation') - - iret = nf_def_var(ncid2,"time_observation",NF_INT, 1, (/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'units',34,sec_since_date) - iret = nf_put_att_text(ncid2,varid,'long_name',19,'time of observation') - - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) - iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention) - - convention(1:32) = "Unidata Observation Dataset v1.0" - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) - iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19start) - iret = nf_put_att_text(ncid, NF_GLOBAL, "stationDimension",7, "station") - iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_put_att_int(ncid, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write) - - iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention) - iret = nf_put_att_text(ncid2, NF_GLOBAL, "cdm_datatype",7, "Station") - iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_max",4, "90.0") - iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") - iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_max",5, "180.0") - iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") - iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_start",19, date19start) - iret = nf_put_att_text(ncid2, NF_GLOBAL, "stationDimension",7, "station") - iret = nf_put_att_real(ncid2, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_put_att_int(ncid2, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write) - - iret = nf_enddef(ncid) - iret = nf_enddef(ncid2) - - !-- write latitudes - iret = nf_inq_varid(ncid,"latitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlat) - - iret = nf_inq_varid(ncid2,"latitude", varid) - iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlatO) - - !-- write longitudes - iret = nf_inq_varid(ncid,"longitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlon) - - iret = nf_inq_varid(ncid2,"longitude", varid) - iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlonO) - - !-- write elevations - iret = nf_inq_varid(ncid,"altitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), elevation) - - iret = nf_inq_varid(ncid2,"altitude", varid) - iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), elevationO) - - !-- write gage location -! iret = nf_inq_varid(ncid,"gages", varid) -! iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), STRMFRXSTPTS) - - !-- write number_of_stations, OPTIONAL - !! iret = nf_inq_varid(ncid,"number_stations", varid) - !! iret = nf_put_var_int(ncid, varid, nstations) - - !-- write station id's - do i=1,nstations - TSTART(1) = 1 - TSTART(2) = i - TCOUNT(1) = TXLEN - TCOUNT(2) = 1 - iret = nf_inq_varid(ncid,"station_id", varid) - iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i)) - enddo - - !-- write observation id's - do i=1, nobs - OTSTART(1) = 1 - OTSTART(2) = i - OTCOUNT(1) = OTXLEN - OTCOUNT(2) = 1 - iret = nf_inq_varid(ncid2,"station_id", varid) - iret = nf_put_vara_text(ncid2, varid, OTSTART, OTCOUNT, stnameO(i)) - enddo - - endif - - output_count = output_count + 1 - - open (unit=999,file='frxst_pts_out.txt',status='unknown',position='append') - - cnt=0 - do i=1,NLINKS - - if(ORDER(i) .ge. order_to_write) then - start_pos = (cnt+1)+(nstations*(output_count-1)) - - !!--time in seconds since startdate - iret = nf_inq_varid(ncid,"time_observation", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since) - - iret = nf_inq_varid(ncid,"streamflow", varid) - iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlink(i,1)) - -! iret = nf_inq_varid(ncid,"pos_streamflow", varid) -! iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), abs(qlink(i,1))) - - iret = nf_inq_varid(ncid,"head", varid) - iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), hlink(i)) - - iret = nf_inq_varid(ncid,"order", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), ORDER(i)) - - !-- station index.. will repeat for every timesstep - iret = nf_inq_varid(ncid,"parent_index", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt) - - !--record number of previous record for same station -!obsolete format prev_pos = cnt+(nstations*(output_count-1)) - prev_pos = cnt+(nobs*(output_count-2)) - if(output_count.ne.1) then !-- only write next set of records - iret = nf_inq_varid(ncid,"prevChild", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos) - endif - - cnt=cnt+1 !--indices are 0 based - rec_num_of_station(cnt) = start_pos-1 !-- save position for last child, 0-based!! - - - endif - enddo -! close(999) - - !-- output only observation points - cnt=0 - do i=1,NLINKS - - if(STRMFRXSTPTS(i) .ne. -9999) then - start_posO = (cnt+1)+(nobs * (output_count-1)) -!Write frxst_pts to text file... -!yw write(999,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & - write(999,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), & - qlink(i,1), qlink(i,1)*35.315,hlink(i) -!yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) -!yw 117 FORMAT(I8,1X,A10,1X,A8,1x,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) - 117 FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) - - !!--time in seconds since startdate - iret = nf_inq_varid(ncid2,"time_observation", varid) - iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), seconds_since) - - iret = nf_inq_varid(ncid2,"streamflow", varid) - iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1)) - - iret = nf_inq_varid(ncid2,"head", varid) - iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i)) - - iret = nf_inq_varid(ncid,"order", varid) - iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i)) - - !-- station index.. will repeat for every timesstep - iret = nf_inq_varid(ncid2,"parent_index", varid) - iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt) - - !--record number of previous record for same station -!obsolete format prev_posO = cnt+(nobs*(output_count-1)) - prev_posO = cnt+(nobs*(output_count-2)) - if(output_count.ne.1) then !-- only write next set of records - iret = nf_inq_varid(ncid2,"prevChild", varid) - iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) - -!IF block to add -1 to last element of prevChild array to designate end of list... -! if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then -! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1) -! else -! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) -! endif - - - endif - - cnt=cnt+1 !--indices are 0 based - rec_num_of_stationO(cnt) = start_posO - 1 !-- save position for last child, 0-based!! - - - endif - - enddo - close(999) - - - !-- lastChild variable gives the record number of the most recent report for the station - iret = nf_inq_varid(ncid,"lastChild", varid) - iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), rec_num_of_station) - - !-- lastChild variable gives the record number of the most recent report for the station - iret = nf_inq_varid(ncid2,"lastChild", varid) - iret = nf_put_vara_int(ncid2, varid, (/1/), (/nobs/), rec_num_of_stationO) - - iret = nf_redef(ncid) - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(date)) = date - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) - - iret = nf_redef(ncid2) - iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_end", 19, date19) - - iret = nf_enddef(ncid) - iret = nf_sync(ncid) - - iret = nf_enddef(ncid2) - iret = nf_sync(ncid2) - - if (output_count == split_output_count) then - output_count = 0 - iret = nf_close(ncid) - iret = nf_close(ncid2) - endif - - deallocate(chanlat) - deallocate(chanlon) - deallocate(elevation) - deallocate(station_id) - deallocate(lOrder) - deallocate(rec_num_of_station) - deallocate(stname) - - deallocate(chanlatO) - deallocate(chanlonO) - deallocate(elevationO) - deallocate(station_idO) - deallocate(lOrderO) - deallocate(rec_num_of_stationO) - deallocate(stnameO) -#ifdef HYDRO_D - print *, "Exited Subroutine output_chrt" -#endif - close(16) - -20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3) - -end subroutine output_chrt - -#ifdef MPP_LAND -!-- output the channel route in an IDV 'station' compatible format - subroutine mpp_output_chrt(gnlinks,map_l2g,igrid, & - split_output_count, NLINKS, ORDER, & - startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt, & - K,STRMFRXSTPTS,order_to_write) - - USE module_mpp_land - -!!output the routing variables over just channel - integer, intent(in) :: igrid,K - integer, intent(in) :: split_output_count - integer, intent(in) :: NLINKS - real, dimension(NLINKS), intent(in) :: chlon,chlat - real, dimension(NLINKS), intent(in) :: hlink,zelev - - integer, dimension(NLINKS), intent(in) :: ORDER - integer, dimension(NLINKS), intent(inout) :: STRMFRXSTPTS - - real, intent(in) :: dtrt - real, dimension(NLINKS,2), intent(in) :: qlink - - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - - integer :: gnlinks, map_l2g(nlinks), order_to_write - real, dimension(gNLINKS) :: g_chlon,g_chlat, g_hlink,g_zelev - real, dimension(gNLINKS,2) :: g_qlink - integer , dimension(gNLINKS) :: g_order,g_STRMFRXSTPTS - - - call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) - call write_chanel_int(STRMFRXSTPTS,map_l2g,gnlinks,nlinks,g_STRMFRXSTPTS) - call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon) - call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat) - call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink) - call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev) - call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) - call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) - - if(my_id .eq. IO_id) then - call output_chrt(igrid, split_output_count, GNLINKS, g_ORDER, & - startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt,K,& - g_STRMFRXSTPTS,order_to_write) - end if - -end subroutine mpp_output_chrt - -!--------- lake netcdf output ----------------------------------------- -!-- output the ilake info an IDV 'station' compatible format ----------- - subroutine mpp_output_lakes(lake_index,igrid, split_output_count, NLAKES, & - startdate, date, latlake, lonlake, elevlake, & - qlakei,qlakeo, resht,dtrt,K) - - USE module_mpp_land - -!!output the routing variables over just channel - integer, intent(in) :: igrid, K - integer, intent(in) :: split_output_count - integer, intent(in) :: NLAKES - real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht - real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake - real, intent(in) :: dtrt - - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - integer lake_index(nlakes) - - call write_lake_real(latlake,lake_index,nlakes) - call write_lake_real(lonlake,lake_index,nlakes) - call write_lake_real(elevlake,lake_index,nlakes) - call write_lake_real(resht,lake_index,nlakes) - call write_lake_real(qlakei,lake_index,nlakes) - call write_lake_real(qlakeo,lake_index,nlakes) - if(my_id.eq. IO_id) then - call output_lakes(igrid, split_output_count, NLAKES, & - startdate, date, latlake, lonlake, elevlake, & - qlakei,qlakeo, resht,dtrt,K) - end if - return - end subroutine mpp_output_lakes - -#endif - -!----------------------------------- lake netcdf output -!-- output the ilake info an IDV 'station' compatible format - subroutine output_lakes(igrid, split_output_count, NLAKES, & - startdate, date, latlake, lonlake, elevlake, & - qlakei,qlakeo, resht,dtrt,K) - -!!output the routing variables over just channel - integer, intent(in) :: igrid, K - integer, intent(in) :: split_output_count - integer, intent(in) :: NLAKES - real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht - real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake - real, intent(in) :: dtrt - - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - - integer, allocatable, DIMENSION(:) :: station_id - integer, allocatable, DIMENSION(:) :: rec_num_of_lake - - integer, save :: output_count - integer, save :: ncid - - integer :: stationdim, dimdata, varid, charid, n - integer :: iret,i, start_pos, prev_pos !-- - integer :: previous_pos !-- used for the station model - character(len=256) :: output_flnm - character(len=19) :: date19, date19start - character(len=34) :: sec_since_date - integer :: seconds_since,cnt - character(len=32) :: convention - character(len=6),allocatable, DIMENSION(:) :: stname - - !--- all this for writing the station id string - INTEGER TDIMS, TXLEN - PARAMETER (TDIMS=2) ! number of TX dimensions - PARAMETER (TXLEN = 6) ! length of example string - INTEGER TIMEID ! record dimension id - INTEGER TXID ! variable ID - INTEGER TXDIMS(TDIMS) ! variable shape - INTEGER TSTART(TDIMS), TCOUNT(TDIMS) - -! sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' -! seconds_since = int(dtrt)*output_count - seconds_since = int(dtrt)*K - - allocate(station_id(NLAKES)) - allocate(rec_num_of_lake(NLAKES)) - allocate(stname(NLAKES)) - - if (output_count == 0) then - -!-- have moved sec_since_date from above here.. - sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & - //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' - - date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & - //startdate(12:13)//':'//startdate(15:16)//':00' - - write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid -#ifdef HYDRO_D - print*, 'output_flnm = "'//trim(output_flnm)//'"' -#endif - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) -#endif - -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("output_lakes") - endif -#endif - - do i=1,NLAKES - station_id(i) = i - write(stname(i),'(I6)') i - enddo - - iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata) !--for linked list approach - iret = nf_def_dim(ncid, "station", nlakes, stationdim) - - !- station location definition, lat - iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake latitude') - iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north') - - !- station location definition, long - iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake longitude') - iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east') - -! !-- lake's phyical elevation - iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake altitude') - iret = nf_put_att_text(ncid,varid,'units',6,'meters') - - !-- parent index - iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',33,'index of the lake for this record') - - !-- prevChild - iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',54,'record number of the previous record for the same lake') -!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - - !-- lastChild - iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',27,'latest report for this lake') -!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - -! !- water surface elevation - iret = nf_def_var(ncid, "elevation", NF_FLOAT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',6,'meters') - iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake Elevation') - -! !- inflow to lake - iret = nf_def_var(ncid, "inflow", NF_FLOAT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') - -! !- outflow to lake - iret = nf_def_var(ncid, "outflow", NF_FLOAT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') - - !-- station id - ! define character-position dimension for strings of max length 6 - iret = NF_DEF_DIM(ncid, "id_len", 6, charid) - TXDIMS(1) = charid ! define char-string variable and position dimension first - TXDIMS(2) = stationdim - iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid) - iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id') - -! !- time definition, timeObs - iret = nf_def_var(ncid,"time_observation",NF_INT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) - iret = nf_put_att_text(ncid,varid,'long_name',19,'time of observation') - -! date19(1:19) = "0000-00-00_00:00:00" -! date19(1:len_trim(startdate)) = startdate -! iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) -! - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(startdate)) = startdate - convention(1:32) = "Unidata Observation Dataset v1.0" - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) - iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19start) - iret = nf_put_att_text(ncid, NF_GLOBAL, "stationDimension",7, "station") -!! iret = nf_put_att_text(ncid, NF_GLOBAL, "observationDimension",6, "recNum") -!! iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coordinate",16,"time_observation") - iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_enddef(ncid) - - !-- write latitudes - iret = nf_inq_varid(ncid,"latitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LATLAKE) - - !-- write longitudes - iret = nf_inq_varid(ncid,"longitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LONLAKE) - - !-- write physical height of lake - iret = nf_inq_varid(ncid,"altitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), elevlake) - - !-- write station id's - do i=1,nlakes - TSTART(1) = 1 - TSTART(2) = i - TCOUNT(1) = TXLEN - TCOUNT(2) = 1 - iret = nf_inq_varid(ncid,"station_id", varid) - iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i)) - enddo - - endif - - output_count = output_count + 1 - - cnt=0 - do i=1,NLAKES - - start_pos = (cnt+1)+(nlakes*(output_count-1)) - - !!--time in seconds since startdate - iret = nf_inq_varid(ncid,"time_observation", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since) - - iret = nf_inq_varid(ncid,"elevation", varid) - iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), resht(i)) - - iret = nf_inq_varid(ncid,"inflow", varid) - iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakei(i)) - - iret = nf_inq_varid(ncid,"outflow", varid) - iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakeo(i)) - - !-- station index.. will repeat for every timesstep - iret = nf_inq_varid(ncid,"parent_index", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt) - - !--record number of previous record for same station - prev_pos = cnt+(nlakes*(output_count-1)) - if(output_count.ne.1) then !-- only write next set of records - iret = nf_inq_varid(ncid,"prevChild", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos) - endif - - cnt=cnt+1 !--indices are 0 based - rec_num_of_lake(cnt) = start_pos-1 !-- save position for last child, 0-based!! - - enddo - - !-- lastChild variable gives the record number of the most recent report for the station - iret = nf_inq_varid(ncid,"lastChild", varid) - iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake) - - !-- number of children reported for this station, OPTIONAL - !-- iret = nf_inq_varid(ncid,"numChildren", varid) - !-- iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake) - - iret = nf_redef(ncid) - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(date)) = date - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) - iret = nf_enddef(ncid) - - iret = nf_sync(ncid) - if (output_count == split_output_count) then - output_count = 0 - iret = nf_close(ncid) - endif - - deallocate(station_id) - deallocate(rec_num_of_lake) - deallocate(stname) -#ifdef HYDRO_D - print *, "Exited Subroutine output_lakes" -#endif - close(16) - - end subroutine output_lakes -!----------------------------------- lake netcdf output - -#ifdef MPP_LAND - -!-- output the channel route in an IDV 'grid' compatible format - subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & - NLINKS,CH_NETRT_in, CH_NETLNK_in, ORDER, startdate, date, & - qlink, dt, geo_finegrid_flnm, gnlinks,map_l2g,g_ixrt,g_jxrt ) - - USE module_mpp_land - - implicit none -#include - integer g_ixrt,g_jxrt - integer, intent(in) :: igrid - integer, intent(in) :: split_output_count - integer, intent(in) :: NLINKS,ixrt,jxrt - real, intent(in) :: dt - real, dimension(NLINKS,2), intent(in) :: qlink - integer, dimension(g_IXRT,g_JXRT) :: CH_NETRT,CH_NETLNK - integer, dimension(IXRT,JXRT), intent(in) :: CH_NETRT_in,CH_NETLNK_in - integer, dimension(NLINKS), intent(in) :: ORDER !--currently not used here, see finegrid.f - character(len=*), intent(in) :: geo_finegrid_flnm - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - integer:: gnlinks , map_l2g(nlinks) - - integer,dimension(gnlinks) :: g_order - real, dimension(gNLINKS,2) :: g_qlink - - call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) - call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) - call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) - - call write_IO_rt_int(CH_NETRT_in, CH_NETRT) - call write_IO_rt_int(CH_NETLNK_in, CH_NETLNK) - - if(my_id.eq.IO_id) then - call output_chrtgrd(igrid, split_output_count, g_ixrt,g_jxrt, & - GNLINKS,CH_NETRT, CH_NETLNK, g_ORDER, startdate, date, & - g_qlink, dt, geo_finegrid_flnm) - endif - - return - end subroutine mpp_output_chrtgrd -#endif - -!-- output the channel route in an IDV 'grid' compatible format - subroutine output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & - NLINKS,CH_NETRT, CH_NETLNK, ORDER, startdate, date, & - qlink, dt, geo_finegrid_flnm) - - integer, intent(in) :: igrid - integer, intent(in) :: split_output_count - integer, intent(in) :: NLINKS,ixrt,jxrt - real, intent(in) :: dt - real, dimension(NLINKS,2), intent(in) :: qlink - integer, dimension(IXRT,JXRT), intent(in) :: CH_NETRT,CH_NETLNK - integer, dimension(NLINKS), intent(in) :: ORDER !--currently not used here, see finegrid.f - character(len=*), intent(in) :: geo_finegrid_flnm - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - character(len=32) :: convention - integer,save :: output_count - integer, save :: ncid,ncstatic - real, dimension(IXRT,JXRT) :: tmpflow - real, dimension(IXRT) :: xcoord - real, dimension(JXRT) :: ycoord - real :: long_cm,lat_po,fe,fn - real, dimension(2) :: sp - - integer :: varid, n - integer :: jxlatdim,ixlondim,timedim !-- dimension ids - - integer :: iret,i,j - character(len=256) :: output_flnm - character(len=19) :: date19 - character(len=34) :: sec_since_date - - - integer :: seconds_since - - - - - tmpflow = -9E15 - - - write(output_flnm, '(A12,".CHRTOUT_GRID",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid -#ifdef HYDRO_D - print*, 'output_flnm = "'//trim(output_flnm)//'"' -#endif - - -!--- define dimension -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) -#endif - -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("output_chrtgrd") - endif -#endif - - - iret = nf_def_dim(ncid, "time", NF_UNLIMITED, timedim) - iret = nf_def_dim(ncid, "x", ixrt, ixlondim) - iret = nf_def_dim(ncid, "y", jxrt, jxlatdim) - -!--- define variables -! !- time definition, timeObs - iret = nf_def_var(ncid,"time",NF_INT, 1, (/timedim/), varid) - - !- x-coordinate in cartesian system -!yw iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/ixlondim/), varid) -!yw iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') -!yw iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') -!yw iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - - !- y-coordinate in cartesian ssystem -!yw iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/jxlatdim/), varid) -!yw iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') -!yw iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') -!yw iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - -! !- flow definition, var - iret = nf_def_var(ncid,"flow",NF_REAL, 3, (/ixlondim,jxlatdim,timedim/), varid) - iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') - iret = nf_put_att_text(ncid,varid,'long_name',15,'water flow rate') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - -!-- place prjection information - - - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(startdate)) = startdate - convention(1:32) = "CF-1.0" - iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19) - - iret = nf_enddef(ncid) - -!!-- write latitude and longitude locations - -!DJG inv do j=jxrt,1,-1 - do j=1,jxrt - do i=1,ixrt - if(CH_NETRT(i,j).GE.0) then - tmpflow(i,j) = qlink(CH_NETLNK(i,j),1) - else - tmpflow(i,j) = -9E15 - endif - enddo - enddo - -!!time in seconds since startdate - - iret = nf_inq_varid(ncid,"flow", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ixrt,jxrt,1/),tmpflow) - - iret = nf_close(ncid) - - - - end subroutine output_chrtgrd - - - -#ifdef MPP_LAND - subroutine mpp_output_rt(ixrt, jxrt,igrid, split_output_count, & - ixrt_in, jxrt_in,nsoil, startdate, olddate, & - QSUBRT_in,ZWATTABLRT_in,SMCRT_in,SUB_RESID_in, & - q_sfcflx_x_in,q_sfcflx_y_in,soxrt_in,soyrt_in, & - QSTRMVOLRT_in,SFCHEADSUBRT_in, & - geo_finegrid_flnm,dt,sldpth,LATVAL_in,LONVAL_in,dist,HIRES_OUT, & - QBDRYRT_in) - -!output the routing variables over routing grid. - USE module_mpp_land - - implicit none -#include - - integer, intent(in) :: igrid - integer, intent(in) :: split_output_count - -! ixrt and jxrt are global. ixrt_in and jxrt_in are local array index. - integer, intent(in) :: ixrt,jxrt,ixrt_in,jxrt_in - real, intent(in) :: dt - real, intent(in) :: dist(ixrt_in,jxrt_in,9) - integer, intent(in) :: nsoil - integer, intent(in) :: HIRES_OUT - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: olddate - character(len=*), intent(in) :: geo_finegrid_flnm - real, dimension(nsoil), intent(in) :: sldpth - - real, dimension(ixrt_in,jxrt_in) :: QSUBRT_in,ZWATTABLRT_in,SUB_RESID_in - real, dimension(ixrt_in,jxrt_in) :: q_sfcflx_x_in,q_sfcflx_y_in - real, dimension(ixrt_in,jxrt_in) :: QSTRMVOLRT_in - real, dimension(ixrt_in,jxrt_in) :: SFCHEADSUBRT_in, QBDRYRT_in - real, dimension(ixrt_in,jxrt_in) :: soxrt_in,soyrt_in - real, dimension(ixrt_in,jxrt_in,nsoil) :: SMCRT_in - real, dimension(ixrt_in,jxrt_in) :: LATVAL_in,LONVAL_in - - real, dimension(ixrt,jxrt) :: QSUBRT,ZWATTABLRT,SUB_RESID - real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y - real, dimension(ixrt,jxrt) :: QSTRMVOLRT, QBDRYRT - real, dimension(ixrt,jxrt) :: SFCHEADSUBRT - real, dimension(ixrt,jxrt) :: soxrt,soyrt - real, dimension(ixrt,jxrt,nsoil) :: SMCRT - real, dimension(ixrt,jxrt,9) :: dist_g - real, dimension(ixrt,jxrt) :: LATVAL,LONVAL - integer i - - -#ifdef HYDRO_D - write(6,*) "mpp_output_RT output file: ",trim(geo_finegrid_flnm) -#endif - - call write_IO_rt_real(LATVAL_in,LATVAL) - call write_IO_rt_real(LONVAL_in,LONVAL) - call write_IO_rt_real(QSUBRT_in,QSUBRT) - - - call write_IO_rt_real(ZWATTABLRT_in,ZWATTABLRT) - - - call write_IO_rt_real(SUB_RESID_in,SUB_RESID) - - - call write_IO_rt_real(QSTRMVOLRT_in,QSTRMVOLRT) - - - - call write_IO_rt_real(SFCHEADSUBRT_in,SFCHEADSUBRT) - call write_IO_rt_real(soxrt_in,soxrt) - - call write_IO_rt_real(QBDRYRT_in,QBDRYRT) - - - - call write_IO_rt_real(soyrt_in,soyrt) - call write_IO_rt_real(q_sfcflx_x_in,q_sfcflx_x) - call write_IO_rt_real(q_sfcflx_y_in,q_sfcflx_y) - - - - - do i = 1, NSOIL - call write_IO_rt_real(SMCRT_in(:,:,i),SMCRT(:,:,i)) - end do - do i = 1, 9 - call write_IO_rt_real(dist(:,:,i),dist_g(:,:,i)) - end do - -! yyywwww ! temp test -! if(my_id.eq. IO_id ) write(14,*) dist(:,:,9) -! if(my_id.eq. IO_id ) write(12,*) dist_g(:,:,9) - - - - - if(my_id.eq.IO_id) then - call output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & - startdate, olddate, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID, & - q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, & - geo_finegrid_flnm,DT,SLDPTH,latval,lonval,dist_g,HIRES_OUT, & - QBDRYRT) - end if - -#ifdef HYDRO_D - write(6,*) "return from mpp_output_RT" -#endif - end subroutine mpp_output_rt - -#endif - - subroutine read_chan_forcing( & - indir,olddate,startdate,hgrid,& - ixrt,jxrt,QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT) -! This subrouting is going to read channel forcing for -! channel only simulations (ie when CHANRTSWCRT = 2) - - implicit none -#include - ! in variable - character(len=*) :: olddate,hgrid,indir,startdate - character(len=256) :: filename - integer :: ixrt,jxrt - real,dimension(ixrt,jxrt):: QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT - ! tmp variable - character(len=256) :: inflnm, product - integer :: i,j,mmflag - character(len=256) :: units - integer :: ierr - integer :: ncid - - -!DJG Create filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".RTOUT_DOMAIN"//hgrid -#ifdef HYDRO_D - print *, "Channel forcing file...",inflnm -#endif - - -!DJG Open NetCDF file... - ierr = nf_open(inflnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_chan Problem opening netcdf file: ''", A, "''")') trim(inflnm) - call hydro_stop("read_chan_forcing") -#endif - endif - -!DJG read data... - call get_2d_netcdf("QSTRMVOLRT", ncid, QSTRMVOLRT_ACC, units, ixrt, jxrt, .TRUE., ierr) -!DJG TBC call get_2d_netcdf("T2D", ncid, t, units, ixrt, jxrt, .TRUE., ierr) -!DJG TBC call get_2d_netcdf("T2D", ncid, t, units, ixrt, jxrt, .TRUE., ierr) - - ierr = nf_close(ncid) - - end subroutine read_chan_forcing - - - - - subroutine get2d_int(var_name,out_buff,ix,jx,fileName) - implicit none -#include - integer :: iret,varid,ncid,ix,jx - integer out_buff(ix,jx) - character(len=*), intent(in) :: var_name - character(len=*), intent(in) :: fileName - iret = nf_open(trim(fileName), NF_NOWRITE, ncid) - if (iret .ne. 0) then -#ifdef HYDRO_D - print*,"aaa failed to open the netcdf file: ",trim(fileName) - call hydro_stop("get2d_int") -#endif - endif - iret = nf_inq_varid(ncid,trim(var_name), varid) - if(iret .ne. 0) then -#ifdef HYDRO_D - print*,"failed to read the variabe: ",trim(var_name) - print*,"failed to read the netcdf file: ",trim(fileName) -#endif - endif - iret = nf_get_var_int(ncid, varid, out_buff) - iret = nf_close(ncid) - return - end subroutine get2d_int - -#ifdef MPP_LAND - SUBROUTINE MPP_READ_ROUTEDIM(did,g_IXRT,g_JXRT, GCH_NETLNK,GNLINKS,IXRT,JXRT, & - route_chan_f,route_link_f, & - route_direction_f, route_lake_f,NLINKS, NLAKES, & - CH_NETLNK, channel_option, geo_finegrid_flnm) - - - USE module_mpp_land - - implicit none -#include - INTEGER :: channel_option, did - INTEGER :: g_IXRT,g_JXRT - INTEGER, INTENT(INOUT) :: NLINKS, NLAKES, GNLINKS - INTEGER, INTENT(IN) :: IXRT,JXRT - INTEGER :: CHNID,cnt - INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: GCH_NETLNK !- each node gets unique id based on global domain - INTEGER, DIMENSION(g_IXRT,g_JXRT) :: g_CH_NETLNK ! temp array - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction - INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - REAL, DIMENSION(IXRT,JXRT) :: LAT, LON - integer:: i,j - - CHARACTER(len=256) :: route_chan_f, route_link_f,route_direction_f,route_lake_f - CHARACTER(len=256) :: geo_finegrid_flnm -! CHARACTER(len=*) :: geo_finegrid_flnm - -! integer, allocatable, dimension(:) :: tmp_int - integer :: ywcount - - if(my_id .eq. IO_id) then - CALL READ_ROUTEDIM(g_IXRT, g_JXRT, route_chan_f, route_link_f, & - route_direction_f, route_lake_f, GNLINKS, NLAKES, & - g_CH_NETLNK, channel_option,geo_finegrid_flnm) - endif - - - call mpp_land_bcast_int1(NLAKES) - call mpp_land_bcast_int1(GNLINKS) - - - call decompose_RT_int(g_CH_NETLNK,GCH_NETLNK,g_IXRT,g_JXRT,ixrt,jxrt) - ywcount = 0 - CH_NETLNK = -9999 - do j = 1, jxrt - do i = 1, ixrt - if(GCH_NETLNK(i,j) .gt. 0) then - ywcount = ywcount + 1 - CH_NETLNK(i,j) = ywcount - endif - end do - end do - NLINKS = ywcount - - allocate(rt_domain(did)%map_l2g(NLINKS)) - - rt_domain(did)%map_l2g = -1 - do j = 1, jxrt - do i = 1, ixrt - if(CH_NETLNK(i,j) .gt. 0) then - rt_domain(did)%map_l2g(CH_NETLNK(i,j)) = GCH_NETLNK(i,j) - endif - end do - end do - - call mpp_chrt_nlinks_collect(NLINKS) - return - end SUBROUTINE MPP_READ_ROUTEDIM - - SUBROUTINE MPP_READ_ROUTING(IXRT,JXRT,ELRT, & - CH_NETRT,LKSATFAC,route_topo_f, & - route_chan_f, geo_finegrid_flnm,g_IXRT,g_JXRT, & - OVROUGHRTFAC,RETDEPRTFAC) - - implicit none -#include - INTEGER, INTENT(IN) :: IXRT,JXRT,g_IXRT,g_JXRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC,RETDEPRTFAC - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT - - REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_ELRT - INTEGER,DIMENSION(g_IXRT,g_JXRT) :: g1_CH_NETRT - REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_LKSATFAC - REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_OVROUGHRTFAC - REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_RETDEPRTFAC - - CHARACTER(len=256) :: route_topo_f,route_chan_f,geo_finegrid_flnm - - if(my_id .eq. IO_id) then - CALL READ_ROUTING_seq(g_IXRT,g_JXRT,g1_ELRT,g1_CH_NETRT,g1_LKSATFAC,& - route_topo_f, route_chan_f,geo_finegrid_flnm,g1_OVROUGHRTFAC,& - g1_RETDEPRTFAC) - endif - - call decompose_RT_real(g1_ELRT,ELRT,g_IXRT,g_JXRT,IXRT,JXRT) - call decompose_RT_int(g1_CH_NETRT,CH_NETRT,g_IXRT,g_JXRT,IXRT,JXRT) - call decompose_RT_real(g1_LKSATFAC,LKSATFAC,g_IXRT,g_JXRT,IXRT,JXRT) - call decompose_RT_real(g1_RETDEPRTFAC,RETDEPRTFAC,g_IXRT,g_JXRT,IXRT,JXRT) - call decompose_RT_real(g1_OVROUGHRTFAC,OVROUGHRTFAC,g_IXRT,g_JXRT,IXRT,JXRT) - - return - end SUBROUTINE MPP_READ_ROUTING - - - subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& - global_nX, global_ny,nsoil,out_SMC,out_SH2OX) - implicit none -#include - - integer, intent(in) :: ix,global_nx,global_ny - integer, intent(in) :: jx,nsoil - real, dimension(ix,jx), intent(in) :: in_smcmax - real, dimension(ix,jx,nsoil), intent(out) :: out_smc,out_sh2ox - - real,dimension(global_nX, global_ny,nsoil):: g_smc, g_sh2ox - real,dimension(global_nX, global_ny):: g_smcmax - integer :: i,j,k - - - call write_IO_real(in_smcmax,g_smcmax) ! get global grid of smcmax - - write (*,*) "In deep GW...", nsoil - -!loop to overwrite soils to saturation... - do i=1,global_nx - do j=1,global_ny - g_smc(i,j,1:NSOIL) = g_smcmax(i,j) - g_sh2ox(i,j,1:NSOIL) = g_smcmax(i,j) - end do - end do - -!decompose global grid to parallel tiles... - do k=1,nsoil - call decompose_data_real(g_smc(:,:,k),out_smc(:,:,k)) - call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k)) - end do - - return - end subroutine MPP_DEEPGW_HRLDAS - -#endif - - SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & - route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC) - - -#include - INTEGER, INTENT(IN) :: IXRT,JXRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT -!Dummy inverted grids - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC - - INTEGER :: I,J, iret, jj - CHARACTER(len=256) :: var_name - CHARACTER(len=256) :: route_topo_f - CHARACTER(len=256) :: route_chan_f - CHARACTER(len=256) :: geo_finegrid_flnm - - var_name = "TOPOGRAPHY" - - call readRT2d_real(var_name,ELRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - -!!!DY to be fixed ... 6/27/08 -! var_name = "BED_ELEVATION" -! iret = get2d_real(var_name,ELRT,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) - - var_name = "CHANNELGRID" - call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - - var_name = "LKSATFAC" - LKSATFAC = -9999.9 - call readRT2d_real(var_name,LKSATFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - - where (LKSATFAC == -9999.9) LKSATFAC = 1000.0 !specify LKSAFAC if no term avail... - - -!1.12.2012...Read in routing calibration factors... - var_name = "RETDEPRTFAC" - call readRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists - - var_name = "OVROUGHRTFAC" - call readRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists - - -#ifdef HYDRO_D - write(6,*) "finish READ_ROUTING_seq" -#endif - - return - -!DJG ----------------------------------------------------- - END SUBROUTINE READ_ROUTING_seq -!DJG _____________________________ - subroutine output_lsm(outFile,did) - - - implicit none - - integer did - - character(len=*) outFile - - integer :: ncid,irt, dimid_ix, dimid_jx, & - dimid_ixrt, dimid_jxrt, varid, & - dimid_links, dimid_basns, dimid_soil - integer :: iret - - - -#ifdef MPP_LAND - if(IO_id.eq.my_id) & -#endif - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(outFile), NF_CLOBBER, ncid) -#endif - -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("output_lsm") - endif -#endif - - -#ifdef MPP_LAND - if(IO_id.eq.my_id) then -#endif -#ifdef HYDRO_D - write(6,*) "output file ", outFile -#endif -! define dimension for variables - iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil) !-- 3-d soils - -#ifdef MPP_LAND - iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx) -#else - iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx) -#endif - -!define variables - iret = nf_def_var(ncid,"stc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - iret = nf_def_var(ncid,"smc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - iret = nf_def_var(ncid,"sh2ox",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - - iret = nf_enddef(ncid) - -#ifdef MPP_LAND - endif -#endif - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SFCHEADRT,"sfcheadrt" ) - - -#ifdef MPP_LAND - if(IO_id.eq.my_id) then -#endif - - iret = nf_close(ncid) -#ifdef HYDRO_D - write(6,*) "finish writing outFile : ", outFile -#endif - -#ifdef MPP_LAND - endif -#endif - - return - end subroutine output_lsm - - - subroutine RESTART_OUT_nc(outFile,did) - - - implicit none - - integer did - - character(len=*) outFile - - integer :: ncid,irt, dimid_ix, dimid_jx, & - dimid_ixrt, dimid_jxrt, varid, & - dimid_links, dimid_basns, dimid_soil, dimid_lakes - integer :: iret - - -#ifdef MPP_LAND - if(IO_id.eq.my_id) & -#endif - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(outFile), NF_CLOBBER, ncid) -#endif - - -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("RESTART_OUT_nc") - endif -#endif - -#ifdef MPP_LAND - if(IO_id.eq.my_id) then -#endif -! define dimension for variables - iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil) !-- 3-d soils - -#ifdef MPP_LAND - iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx) - iret = nf_def_dim(ncid, "ixrt", global_rt_nx , dimid_ixrt) !-- make a decimated grid - iret = nf_def_dim(ncid, "iyrt", global_rt_ny, dimid_jxrt) -#else - iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx) - iret = nf_def_dim(ncid, "ixrt", rt_domain(did)%ixrt , dimid_ixrt) !-- make a decimated grid - iret = nf_def_dim(ncid, "iyrt", rt_domain(did)%jxrt, dimid_jxrt) -#endif - - iret = nf_def_dim(ncid, "links", rt_domain(did)%gnlinks, dimid_links) - if(rt_domain(did)%nlakes .gt. 0) then - iret = nf_def_dim(ncid, "lakes", rt_domain(did)%nlakes, dimid_lakes) - endif - iret = nf_def_dim(ncid, "basns", rt_domain(did)%numbasns, dimid_basns) - -!define variables - iret = nf_def_var(ncid,"stc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - iret = nf_def_var(ncid,"smc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - iret = nf_def_var(ncid,"sh2ox",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - - iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"soldrain",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - - if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then - iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - iret = nf_def_var(ncid,"infxswgt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - iret = nf_def_var(ncid,"SFCHEADSUBRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - iret = nf_def_var(ncid,"sh2owgt",NF_FLOAT,3,(/dimid_ixrt,dimid_jxrt,dimid_soil/),varid) - iret = nf_def_var(ncid,"qstrmvolrt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - iret = nf_def_var(ncid,"RETDEPRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - - - - - - - if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then - iret = nf_def_var(ncid,"hlink",NF_FLOAT,1,(/dimid_links/),varid) - iret = nf_def_var(ncid,"qlink1",NF_FLOAT,1,(/dimid_links/),varid) - iret = nf_def_var(ncid,"qlink2",NF_FLOAT,1,(/dimid_links/),varid) - iret = nf_def_var(ncid,"cvol",NF_FLOAT,1,(/dimid_links/),varid) - if(rt_domain(did)%nlakes .gt. 0) then - iret = nf_def_var(ncid,"resht",NF_FLOAT,1,(/dimid_lakes/),varid) - iret = nf_def_var(ncid,"qlakeo",NF_FLOAT,1,(/dimid_lakes/),varid) - endif - iret = nf_def_var(ncid,"lake_inflort",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - end if - if(nlst_rt(did)%GWBASESWCRT.EQ.1) then - iret = nf_def_var(ncid,"z_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) -!yw test bucket model -! iret = nf_def_var(ncid,"gwbas_pix_ct",NF_FLOAT,1,(/dimid_basns/),varid) -! iret = nf_def_var(ncid,"gw_buck_exp",NF_FLOAT,1,(/dimid_basns/),varid) -! iret = nf_def_var(ncid,"z_max",NF_FLOAT,1,(/dimid_basns/),varid) -! iret = nf_def_var(ncid,"gw_buck_coeff",NF_FLOAT,1,(/dimid_basns/),varid) -! iret = nf_def_var(ncid,"qin_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) -! iret = nf_def_var(ncid,"qinflowbase",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) -! iret = nf_def_var(ncid,"qout_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) - end if - end if - -! put global attribute - iret = nf_put_att_int(ncid,NF_GLOBAL,"his_out_counts",NF_INT, 1,rt_domain(did)%his_out_counts) - iret = nf_put_att_text(ncid,NF_GLOBAL,"Restart_Time",19,nlst_rt(did)%olddate(1:19)) - iret = nf_put_att_text(ncid,NF_GLOBAL,"Since_Date",19,nlst_rt(did)%sincedate(1:19)) - iret = nf_put_att_real(ncid,NF_GLOBAL,"DTCT",NF_REAL, 1,nlst_rt(did)%DTCT) - iret = nf_enddef(ncid) - -#ifdef MPP_LAND - endif -#endif - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") - - - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt" ) - - - if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT, "QBDRYRT" ) - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT, "infxswgt" ) - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT, "SFCHEADSUBRT" ) - call w_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT, "sh2owgt" ) - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT, "qstrmvolrt" ) - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT, "RETDEPRT" ) - -!yw test - - -!yw test - - - if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then - call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%HLINK,"hlink" & -#ifdef MPP_LAND - ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & -#endif - ) - - call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,1),"qlink1" & -#ifdef MPP_LAND - ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & -#endif - ) - - - call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,2),"qlink2" & -#ifdef MPP_LAND - ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & -#endif - ) - - - call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%cvol,"cvol" & -#ifdef MPP_LAND - ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & -#endif - ) - -! call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%resht,"resht" & -!#ifdef MPP_LAND -! ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & -!#endif -! ) - - call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%resht,"resht" & -#ifdef MPP_LAND - ,rt_domain(did)%lake_index & -#endif - ) - - call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakeo,"qlakeo" & -#ifdef MPP_LAND - ,rt_domain(did)%lake_index & -#endif - ) - - - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort") - - end if - - if(nlst_rt(did)%GWBASESWCRT.EQ.1) then - call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,"z_gwsubbas" ) -!yw test bucket model -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gwbas_pix_ct,"gwbas_pix_ct" ) -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_exp,"gw_buck_exp" ) -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_max,"z_max" ) -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_coeff,"gw_buck_coeff" ) -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,"qin_gwsubbas" ) -! call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%qinflowbase,"qinflowbase") -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,"qout_gwsubbas" ) - end if - end if - -#ifdef MPP_LAND - if(IO_id.eq.my_id) & -#endif - iret = nf_close(ncid) - - return - end subroutine RESTART_OUT_nc - - subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName) - implicit none - integer:: ncid,ix,jx,varid , iret - character(len=*) varName - real, dimension(ix,jx):: inVar -#ifdef MPP_LAND - real, dimension(global_rt_nx, global_rt_ny):: varTmp - call write_IO_rt_real(inVar,varTmp) - if(my_id .eq. IO_id) then - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_rt_nx,global_rt_ny/),varTmp) - endif -#else - iret = nf_inq_varid(ncid,varName, varid) - if(iret .eq. 0) then - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),inVar) - else - write(6,*) "Error : variable not defined in rst file before write: ", varName - endif -#endif - - return - end subroutine w_rst_rt_nc2 - - subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName) - implicit none - integer:: ncid,ix,jx,varid , iret, nsoil - character(len=*) varName - real,dimension(ix,jx,nsoil):: inVar -#ifdef MPP_LAND - integer k - real varTmp(global_rt_nx,global_rt_ny,nsoil) - do k = 1, nsoil - call write_IO_rt_real(inVar(:,:,k),varTmp(:,:,k)) - end do - if(my_id .eq. IO_id) then - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/global_rt_nx,global_rt_ny,nsoil/),varTmp) - endif -#else - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ix,jx,nsoil/),inVar) -#endif - return - end subroutine w_rst_rt_nc3 - - subroutine w_rst_nc2(ncid,ix,jx,inVar,varName) - implicit none - integer:: ncid,ix,jx,varid , iret - character(len=*) varName - real inVar(ix,jx) - -#ifdef MPP_LAND - real varTmp(global_nx,global_ny) - call write_IO_real(inVar,varTmp) - if(my_id .eq. IO_id) then - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_nx,global_ny/),varTmp) - endif -#else - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),invar) -#endif - - return - end subroutine w_rst_nc2 - - subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName) - implicit none - integer:: ncid,ix,jx,varid , iret, nsoil - character(len=*) varName - real inVar(ix,jx,nsoil) - integer k -#ifdef MPP_LAND - real varTmp(global_nx,global_ny,nsoil) - do k = 1, nsoil - call write_IO_real(inVar(:,:,k),varTmp(:,:,k)) - end do - if(my_id .eq. IO_id) then - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/global_nx,global_ny,nsoil/),varTmp) - endif -#else - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ix,jx,nsoil/),inVar) -#endif - return - end subroutine w_rst_nc3 - - subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName & -#ifdef MPP_LAND - ,nodelist & -#endif - ) - implicit none - integer:: ncid,n,varid , iret - character(len=*) varName - real inVar(n) -#ifdef MPP_LAND - integer:: nodelist(n) - if(n .eq. 0) return - - call write_lake_real(inVar,nodelist,n) - if(my_id .eq. IO_id) then -#endif - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) -#ifdef MPP_LAND - endif -#endif - return - end subroutine w_rst_crt_nc1_lake - - subroutine w_rst_crt_nc1(ncid,n,inVar,varName & -#ifdef MPP_LAND - ,map_l2g, gnlinks& -#endif - ) - implicit none - integer:: ncid,n,varid , iret - character(len=*) varName - real inVar(n) -#ifdef MPP_LAND - integer:: gnlinks, map_l2g(n) - real g_var(gnlinks) - call write_chanel_real(inVar,map_l2g,gnlinks,n,g_var) - if(my_id .eq. IO_id) then - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/gnlinks/),g_var) -#else - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) -#endif -#ifdef MPP_LAND - endif -#endif - return - end subroutine w_rst_crt_nc1 - - subroutine w_rst_crt_nc1g(ncid,n,inVar,varName) - implicit none - integer:: ncid,n,varid , iret - character(len=*) varName - real inVar(n) -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) -#ifdef MPP_LAND - endif -#endif - return - end subroutine w_rst_crt_nc1g - - subroutine RESTART_IN_NC(inFile,did) - - - implicit none - character(len=*) inFile - integer :: ierr, iret,ncid, did - - integer :: i, j - - -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif -!open a netcdf file - iret = nf_open(trim(inFile), NF_NOWRITE, ncid) -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening file: ''", A, "''")') & - trim(inFile) - call hydro_stop("RESTART_IN_NC") -#endif - endif - -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - iret = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'his_out_counts', rt_domain(did)%his_out_counts) - iret = NF_GET_ATT_REAL(ncid, NF_GLOBAL, 'DTCT', nlst_rt(did)%DTCT) - iret = nf_get_att_text(ncid,NF_GLOBAL,"Since_Date",nlst_rt(did)%sincedate(1:19)) - if(iret /= 0) nlst_rt(did)%sincedate = nlst_rt(did)%startdate - if(nlst_rt(did)%DTCT .gt. 0) then - nlst_rt(did)%DTCT = min(nlst_rt(did)%DTCT, nlst_rt(did)%DTRT) - else - nlst_rt(did)%DTCT = nlst_rt(did)%DTRT - endif -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(rt_domain(did)%out_counts) - call mpp_land_bcast_real1(nlst_rt(did)%DTCT) -#endif - -#ifdef HYDRO_D - write(6,*) "nlst_rt(did)%nsoil=",nlst_rt(did)%nsoil -#endif - - if(nlst_rt(did)%rst_typ .eq. 1 ) then - call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") - call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") - call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt") - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt") - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain") - endif - - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1") - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1") - - - if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT,"infxswgt") - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT,"SFCHEADSUBRT") - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT,"QBDRYRT") - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT,"qstrmvolrt") - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT,"RETDEPRT") - call read_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT,"sh2owgt") - - - if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then - call read_rst_crt_stream_nc(ncid,rt_domain(did)%HLINK,rt_domain(did)%NLINKS,"hlink",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) - call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,1),rt_domain(did)%NLINKS,"qlink1",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) - call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,2),rt_domain(did)%NLINKS,"qlink2",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) - call read_rst_crt_stream_nc(ncid,rt_domain(did)%CVOL,rt_domain(did)%NLINKS,"cvol",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) - if(rt_domain(did)%NLAKES .gt. 0) then - call read_rst_crt_nc(ncid,rt_domain(did)%RESHT,rt_domain(did)%NLAKES,"resht") - call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEO,rt_domain(did)%NLAKES,"qlakeo") - endif - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort") - - end if - - if(nlst_rt(did)%GWBASESWCRT.EQ.1.AND.nlst_rt(did)%GW_RESTART.NE.0 .and. rt_domain(did)%numbasns .gt. 0) then - call read_rst_crt_nc(ncid,rt_domain(did)%z_gwsubbas,rt_domain(did)%numbasns,"z_gwsubbas") - end if - end if - - if(nlst_rt(did)%rstrt_swc.eq.1) then !Switch for rest of restart accum vars... -#ifdef HYDRO_D - print *, "1 Resetting RESTART Accumulation Variables to 0...",nlst_rt(did)%rstrt_swc -#endif - rt_domain(did)%INFXSRT=0. - rt_domain(did)%LAKE_INFLORT=0. - rt_domain(did)%QSTRMVOLRT=0. - end if - - -#ifdef MPP_LAND - if(my_id .eq. IO_id) & -#endif - iret = nf_close(ncid) -#ifdef HYDRO_D - write(6,*) "end of RESTART_IN" - flush(6) -#endif - - !call check_channel(81,rt_domain(did)%QLINK(:,1),1,rt_domain(did)%NLINKS) - !call check_channel(83,rt_domain(did)%QLINK(:,2),1,rt_domain(did)%NLINKS) - !call check_channel(84,rt_domain(did)%HLINK,1,rt_domain(did)%NLINKS) - !call check_channel(85,rt_domain(did)%CVOL,1,rt_domain(did)%NLINKS) - !call hydro_stop("666666666666") - - return - end subroutine RESTART_IN_nc - - subroutine read_rst_nc3(ncid,ix,jx,NSOIL,var,varStr) - implicit none - integer :: ix,jx,nsoil, ireg, ncid, varid, iret - real,dimension(ix,jx,nsoil) :: var - character(len=*) :: varStr -#ifdef MPP_LAND - real,dimension(global_nx,global_ny,nsoil) :: xtmp - integer i - - if(my_id .eq. IO_id) & -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) & - iret = nf_get_var_real(ncid, varid, xtmp) - - do i = 1, nsoil - call decompose_data_real(xtmp(:,:,i), var(:,:,i)) - end do -#else - iret = nf_get_var_real(ncid, varid, var) -#endif - - return - end subroutine read_rst_nc3 - - subroutine read_rst_nc2(ncid,ix,jx,var,varStr) - implicit none - integer :: ix,jx,ireg, ncid, varid, iret - real,dimension(ix,jx) :: var - character(len=*) :: varStr -#ifdef MPP_LAND - real,dimension(global_nx,global_ny) :: xtmp - if(my_id .eq. IO_id) & -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) - -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) & - iret = nf_get_var_real(ncid, varid, xtmp) - - call decompose_data_real(xtmp, var) -#else - var = 0.0 - iret = nf_get_var_real(ncid, varid, var) -#endif - return - end subroutine read_rst_nc2 - - subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr) - implicit none - integer :: ix,jx,nsoil, ireg, ncid, varid, iret - real,dimension(ix,jx,nsoil) :: var - character(len=*) :: varStr -#ifdef MPP_LAND - real,dimension(global_rt_nx,global_rt_ny,nsoil) :: xtmp - integer i - if(my_id .eq. IO_id) & -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - iret = nf_get_var_real(ncid, varid, xtmp) - do i = 1, nsoil - call decompose_RT_real(xtmp(:,:,i),var(:,:,i),global_rt_nx,global_rt_ny,ix,jx) - end do -#else - iret = nf_get_var_real(ncid, varid, var) -#endif - return - end subroutine read_rst_rt_nc3 - - subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr) - implicit none - integer :: ix,jx,ireg, ncid, varid, iret - real,dimension(ix,jx) :: var - character(len=*) :: varStr -#ifdef MPP_LAND - real,dimension(global_rt_nx,global_rt_ny) :: xtmp -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) & - iret = nf_get_var_real(ncid, varid, xtmp) - call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx) -#else - iret = nf_get_var_real(ncid, varid, var) -#endif - return - end subroutine read_rst_rt_nc2 - - subroutine read_rt_nc2(ncid,ix,jx,var,varStr) - implicit none - integer :: ix,jx, ncid, varid, iret - real,dimension(ix,jx) :: var - character(len=*) :: varStr - -#ifdef MPP_LAND - real,dimension(global_rt_nx,global_rt_ny) :: xtmp - xtmp = 0.0 -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) then - iret = nf_get_var_real(ncid, varid, xtmp) - endif - call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx) -#else - iret = nf_get_var_real(ncid, varid, var) -#endif - return - end subroutine read_rt_nc2 - - subroutine read_rst_crt_nc(ncid,var,n,varStr) - implicit none - integer :: ireg, ncid, varid, n, iret - real,dimension(n) :: var - character(len=*) :: varStr - - if( n .le. 0) return -#ifdef MPP_LAND - if(my_id .eq. IO_id) & -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - iret = nf_get_var_real(ncid, varid, var) -#ifdef MPP_LAND - endif - call mpp_land_bcast_real(n,var) -#endif - return - end subroutine read_rst_crt_nc - - subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g) - implicit none - integer :: ncid, varid, n, iret, gnlinks - integer, intent(in), dimension(:) :: map_l2g - character(len=*) :: varStr - integer :: l, g - real,intent(out) , dimension(:) :: var_out -#ifdef MPP_LAND - real,dimension(gnlinks) :: var -#else - real,dimension(n) :: var -#endif - - -#ifdef MPP_LAND - if(my_id .eq. IO_id) & -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - var = 0.0 - iret = nf_get_var_real(ncid, varid, var) -#ifdef MPP_LAND - endif - call mpp_land_bcast_real(gnlinks,var) - - if(n .le. 0) return - var_out = 0 - - do l = 1, n - g = map_l2g(l) - var_out(l) = var(g) - end do -#else - var_out = var -#endif - return - end subroutine read_rst_crt_stream_nc - - subroutine hrldas_out() - end subroutine hrldas_out - - SUBROUTINE READ_ROUTING_old(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & - route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC) - - -#include - INTEGER, INTENT(IN) :: IXRT,JXRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT -!Dummy inverted grids - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC - - INTEGER :: I,J, iret, jj - CHARACTER(len=256) :: var_name - CHARACTER(len=256) :: route_topo_f - CHARACTER(len=256) :: route_chan_f - CHARACTER(len=256) :: geo_finegrid_flnm - - var_name = "TOPOGRAPHY" - call readRT2d_real(var_name,ELRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - -!!!DY to be fixed ... 6/27/08 -! var_name = "BED_ELEVATION" -! iret = get2d_real(var_name,ELRT,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) - - var_name = "CHANNELGRID" - call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - - var_name = "LKSATFAC" - LKSATFAC = -9999.9 - call readRT2d_real(var_name,LKSATFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - - where (LKSATFAC == -9999.9) LKSATFAC = 1000.0 !specify LKSAFAC if no term avail... - - -!1.12.2012...Read in routing calibration factors... - var_name = "RETDEPRTFAC" - call readRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists - - var_name = "OVROUGHRTFAC" - call readRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists - - -#ifdef HYDRO_D - write(6,*) "finish READ_ROUTING_old" -#endif - - return - -!DJG ----------------------------------------------------- - END SUBROUTINE READ_ROUTING_old -!DJG _____________________________ - - -#ifdef MPP_LAND - - SUBROUTINE MPP_READ_CHROUTING(did,IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & - FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, & - NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, & - HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & - ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, & - route_link_f, & - route_lake_f, route_direction_f, route_order_f, & - CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, & - CHANXI, CHANYJ, CHLAT, CHLON, & - channel_option,LATVAL,LONVAL, & - STRMFRXSTPTS,geo_finegrid_flnm,Link_Location) - use module_mpp_land, only: my_id, io_id -#include - INTEGER, INTENT(IN) :: IXRT,JXRT, did - INTEGER :: CHANRTSWCRT, NLINKS, NLAKES - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION - INTEGER, DIMENSION(IXRT,JXRT) :: GSTRMFRXSTPTS - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - INTEGER, DIMENSION(IXRT,JXRT) :: GORDER !-- gridded stream orderk - INTEGER, DIMENSION(IXRT,JXRT) :: Link_Location !-- gridded stream orderk - INTEGER :: I,J,channel_option - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LATVAL, LONVAL - CHARACTER(len=28) :: dir -!Dummy inverted grids from arc - - -!----DJG,DNY New variables for channel and lake routing - CHARACTER(len=155) :: header - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: FROM_NODE - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ZELEV - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHLAT,CHLON - - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TYPEL - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TO_NODE,ORDER - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: STRMFRXSTPTS - - INTEGER, INTENT(INOUT) :: MAXORDER - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum - REAL, INTENT(INOUT), DIMENSION(NLINKS,2) :: QLINK !channel flow - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHANLEN !channel length - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MannN, So !mannings N - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: LAKENODE ! identifies which nodes pour into which lakes - REAL, INTENT(IN) :: dist(ixrt,jxrt,9) - - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK - REAL, DIMENSION(IXRT,JXRT) :: ChSSlpG,BwG,MannNG !channel properties on Grid - - -!-- store the location x,y location of the channel element - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ - -!--reservoir/lake attributes - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: HRZAREA - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: LAKEMAXH - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: WEIRC - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: WEIRL - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEC - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEA - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEE - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: LATLAKE,LONLAKE,ELEVLAKE - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ChSSlp, Bw - - CHARACTER(len=256) :: route_link_f - CHARACTER(len=256) :: route_lake_f - CHARACTER(len=256) :: route_direction_f - CHARACTER(len=256) :: route_order_f - CHARACTER(len=256) :: geo_finegrid_flnm - CHARACTER(len=256) :: var_name - - INTEGER :: tmp, cnt, ncid, iret, jj,ct - real :: gc,n - -!--------------------------------------------------------- -! End Declarations -!--------------------------------------------------------- - MAXORDER = -9999 -!initialize GSTRM - GSTRMFRXSTPTS = -9999 - -!yw initialize the array. - to_node = MAXORDER - from_node = MAXORDER - Link_location = MAXORDER - -#ifdef HYDRO_D - print *, "reading routing initialization files..." - print *, "route direction", route_direction_f - print *, "route order", route_order_f - print *, "route linke",route_link_f - print *, "route lake",route_lake_f -#endif - -!DJG Edited code here to retrieve data from hires netcdf file.... - - IF((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then - - var_name = "LATITUDE" -#ifdef MPP_LAND - call mpp_readRT2d_real (did, & -#else - call readRT2d_real ( & -#endif - var_name,LATVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) - - - var_name = "LONGITUDE" -#ifdef MPP_LAND - call mpp_readRT2d_real(did, & -#else - call readRT2d_real( & -#endif - var_name,LONVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) - - END IF - - - IF(CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2) then -!DJG change filename to LAKEPARM.TBL open(unit=79,file=trim(route_link_f), & -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - open(unit=79,file='LAKEPARM.TBL', & - form='formatted',status='old') -#ifdef MPP_LAND - endif -#endif - END IF - - - var_name = "LAKEGRID" -#ifdef MPP_LAND - call mpp_readRT2d_int(did,& -#else - call readRT2d_int(& -#endif - var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm)) - - var_name = "FLOWDIRECTION" -#ifdef MPP_LAND - call mpp_readRT2d_int(did, & -#else - call readRT2d_int(& -#endif - var_name,DIRECTION,ixrt,jxrt,trim(geo_finegrid_flnm)) - - var_name = "STREAMORDER" -#ifdef MPP_LAND - call mpp_readRT2d_int(did,& -#else - call readRT2d_int(& -#endif - var_name,GORDER,ixrt,jxrt,trim(geo_finegrid_flnm)) - - - var_name = "frxst_pts" -#ifdef MPP_LAND - call mpp_readRT2d_int(did,& -#else - call readRT2d_int(& -#endif - var_name,GSTRMFRXSTPTS,ixrt,jxrt,trim(geo_finegrid_flnm)) - -!!!Flip y-dimension of highres grids from exported Arc files... - - - ct = 0 - -#ifdef HYDRO_D - print *, "Number of frxst pts: ",ct -#endif - - -! temp fix for buggy Arc export... - do j=1,jxrt - do i=1,ixrt - if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 - end do - end do - - cnt =0 - if ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option .ne. 3) then ! not routing on grid, read from file - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - read(79,*) header -#ifdef MPP_LAND - endif -#endif - call hydro_stop("Possible Error for this code") - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - do i=1,NLINKS - read (79,*) tmp, FROM_NODE(i), TO_NODE(i), TYPEL(i),& - ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), & - MannN(i), So(i), ChSSlp(i), Bw(i), HRZAREA(i),& - LAKEMAXH(i), WEIRC(i), WEIRL(i), ORIFICEC(i), & - ORIFICEA(i),ORIFICEE(i) - - !-- hardwire QLINK - QLINK(i,1) = 1.0 - QLINK(i,2) = QLINK(i,1) - - if (So(i).lt.0.005) So(i) = 0.005 !-- impose a minimum slope requireement - - if (ORDER(i) .gt. MAXORDER) then - MAXORDER = ORDER(i) - endif - - end do -#ifdef MPP_LAND - endif - call mpp_land_bcast_int(NLINKS,FROM_NODE) - call mpp_land_bcast_int(NLINKS,TO_NODE) - call mpp_land_bcast_int(NLINKS,TYPEL ) - call mpp_land_bcast_int(NLINKS,ORDER ) - call mpp_land_bcast_real(NLINKS,QLINK ) - call mpp_land_bcast_real(NLINKS,MUSK ) - call mpp_land_bcast_real(NLINKS,MUSX ) - call mpp_land_bcast_real(NLINKS,CHANLEN) - call mpp_land_bcast_real(NLINKS,MannN ) - call mpp_land_bcast_real(NLINKS,So ) - call mpp_land_bcast_real(NLINKS,ChSSlp ) - call mpp_land_bcast_real(NLINKS,Bw ) - call mpp_land_bcast_real(NLINKS,HRZAREA) - call mpp_land_bcast_real(NLINKS,LAKEMAXH) - call mpp_land_bcast_real(NLINKS,WEIRC ) - call mpp_land_bcast_real(NLINKS,WEIRL ) - call mpp_land_bcast_real(NLINKS,ORIFICEC) - call mpp_land_bcast_real(NLINKS,ORIFICEA) - call mpp_land_bcast_real(NLINKS,ORIFICEE) - call mpp_land_bcast_int1(MAXORDER) - -#endif - - elseif ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then !-- handle setting up topology on the grid for diffusion scheme - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - read(79,*) header !-- read the lake file -#ifdef HYDRO_D - write(*,*) "output message: reading lake file ", header - write(6,*) "output message: error check read file ",route_link_f -#endif -#ifdef MPP_LAND - endif -#endif - - - if (NLAKES.gt.0) then !read in only if there are lakes - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - - do i=1, NLAKES - read (79,*) tmp, HRZAREA(i),LAKEMAXH(i), & - WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),& - LATLAKE(i), LONLAKE(i),ELEVLAKE(i) -#ifdef HYDRO_D - write (*,*) tmp, HRZAREA(i),LAKEMAXH(i), LATLAKE(i), LONLAKE(i),ELEVLAKE(i),NLAKES -#endif - enddo - -#ifdef MPP_LAND - endif - call mpp_land_bcast_real(NLAKES,HRZAREA) - call mpp_land_bcast_real(NLAKES,LAKEMAXH) - call mpp_land_bcast_real(NLAKES,WEIRC ) - call mpp_land_bcast_real(NLAKES,WEIRL ) - call mpp_land_bcast_real(NLAKES,ORIFICEC) - call mpp_land_bcast_real(NLAKES,ORIFICEA) - call mpp_land_bcast_real(NLAKES,ORIFICEE) - call mpp_land_bcast_real(NLAKES,LATLAKE ) - call mpp_land_bcast_real(NLAKES,LONLAKE ) - call mpp_land_bcast_real(NLAKES,ELEVLAKE) -#endif - - end if !end if for NLAKES >0 check - - cnt = 0 - - - BwG = 0.0 - ChSSlpG = 0.0 - MannNG = 0.0 - TYPEL = 0 - MannN = 0.0 - Bw = 0.0 - ChSSlp = 0.0 - -!DJG inv DO j = JXRT,1,-1 !rows - DO j = 1,JXRT !rows - DO i = 1 ,IXRT !colsumns - If (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order - If ((DIRECTION(i, j) .EQ. 64) .AND. (j + 1 .LE. JXRT) .AND. & - (CH_NETRT(i,j+1).ge.0) ) then !North - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i, j + 1) - CHANLEN(cnt) = dist(i,j,1) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1).ge.0) ) then !North East - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1) - CHANLEN(cnt) = dist(i,j,2) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT) & - .AND. (CH_NETRT(i+1,j).ge.0) ) then !East - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j) - CHANLEN(cnt) = dist(i,j,3) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & - .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i+1,j-1).ge.0) ) then !south east - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1) - CHANLEN(cnt) = dist(i,j,4) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0) ) then !due south - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i, j - 1) - CHANLEN(cnt) = dist(i,j,5) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & - .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i-1,j-1).ge.0)) then !south west - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i,j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1) - CHANLEN(cnt) = dist(i,j,6) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0) ) then !West - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j) - CHANLEN(cnt) = dist(i,j,7) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0) ) then !North West - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1) - CHANLEN(cnt) = dist(i,j,8) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else -#ifdef HYDRO_D - print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east -#endif - End If - - End If !CH_NETRT check for this node - - END DO - END DO - -#ifdef HYDRO_D - print *, "after exiting the channel, this many nodes", cnt - write(*,*) " " -#endif - -!Find out if the boundaries are on an edge -!DJG inv DO j = JXRT,1,-1 - DO j = 1,JXRT - DO i = 1 ,IXRT - If (CH_NETRT(i, j) .ge. 0) then !get its direction - -!#ifdef MPP_LAND -! If (((DIRECTION(i, j).EQ. 64) .AND. ((j + 1 .GT. JXRT) .and. (up_id < 0)) ) .OR. & !-- 64's can only flow north -! ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North -!#else - If (((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) .OR. & !-- 64's can only flow north - ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North -!#endif - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(j+1 .GT. JXRT) then !-- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i,j+1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i,j+1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,1) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - -!#ifdef MPP_LAND -! else if ( ((DIRECTION(i, j) .EQ. 128) .AND. ((i + 1 .GT. IXRT) .and. (right_id < 0)) ) & !-- 128's can flow out of the North or East edge -! .OR. ((DIRECTION(i, j) .EQ. 128) .AND. ((j + 1 .GT. JXRT) .and. (up_id < 0)) ) & ! this is due north edge -! .OR. ((DIRECTION(i, j) .EQ. 128) .AND. (i1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if((i+1 .GT. IXRT) .OR. (j-1 .EQ. 0)) then !an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i+1,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,4) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - -!#ifdef MPP_LAND -! else if (((DIRECTION(i, j) .EQ. 4) .AND. ((j - 1 .EQ. 0) .and. (down_id <0)) ) .OR. & !-- 4's can only flow due south -! ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south -!#else - else if (((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) .OR. & !-- 4's can only flow due south - ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south -!#endif - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(j-1 .EQ. 0) then !- an edge - TYPEL(cnt) =1 - elseif(LAKE_MSKRT(i,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,5) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - -!#ifdef MPP_LAND -! else if ( ((DIRECTION(i, j) .EQ. 8) .AND. ((i - 1 .LE. 0).and.(left_id <0))) & !-- 8's can flow south or west -! .OR. ((DIRECTION(i, j) .EQ. 8) .AND.( (j - 1 .EQ. 0) .and. (down_id <0)) ) & !-- this is the south edge -! .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west -!#else - else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west - .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge - .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west -!#endif - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if( (i-1 .EQ. 0) .OR. (j-1 .EQ. 0) ) then !- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i-1,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,6) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif -!#ifdef MPP_LAND -! else if (((DIRECTION(i, j) .EQ. 16) .AND. ((i - 1 .LE.0) .and. (left_id <0)) ) & !16's can only flow due west -!#else - else if (((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE.0) ) & !16's can only flow due west -!#endif - .OR.((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(i-1 .EQ. 0) then !-- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i-1,j).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i-1,j) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,7) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - -!#ifdef MPP_LAND -! else if ( ((DIRECTION(i, j) .EQ. 32) .AND. ((i - 1 .LE. 0) .and. (left_id <0)) ) & !-- 32's can flow either west or north -! .OR. ((DIRECTION(i, j) .EQ. 32) .AND. ((j + 1 .GT. JXRT) .and. (up_id <0)) ) & !-- this is the north edge -!#else - else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north - .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge -!#endif - .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j - INTEGER :: I,J,channel_option,iret,jj, did - INTEGER, INTENT(OUT) :: NLINKS - INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id - - INTEGER, INTENT(IN) :: IXRT,JXRT - INTEGER :: CHNID,cnt - INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction - INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - REAL, DIMENSION(IXRT,JXRT) :: LAT, LON - -!!Dummy read in grids for inverted y-axis - - - CHARACTER(len=*) :: route_chan_f, route_link_f,route_direction_f,route_lake_f - CHARACTER(len=256) :: InputLine - CHARACTER(len=256) :: geo_finegrid_flnm - CHARACTER(len=256) :: var_name -! external get2d_real -! integer :: get2d_real - - NLINKS = 0 - CH_NETRT = -9999 - CH_NETLNK = -9999 - - - cnt = 0 -#ifdef HYDRO_D - print *, "Channel Option in Routedim is ", channel_option -#endif - - IF(channel_option.eq.3) then !get maxnodes and links from grid - - var_name = "CHANNELGRID" -#ifdef MPP_LAND - call mpp_readRT2d_int(did,& -#else - call readRT2d_int(& -#endif - var_name,CH_NETRT,ixrt,jxrt, trim(geo_finegrid_flnm)) - - - var_name = "FLOWDIRECTION" -#ifdef MPP_LAND - call mpp_readRT2d_int(did, & -#else - call readRT2d_int( & -#endif - var_name,DIRECTION,ixrt,jxrt, trim(geo_finegrid_flnm)) - - var_name = "LAKEGRID" -#ifdef MPP_LAND - call mpp_readRT2d_int(did, & -#else - call readRT2d_int( & -#endif - var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm)) - - - var_name = "LATITUDE" -#ifdef MPP_LAND - call mpp_readRT2d_real(did, & -#else - call readRT2d_real( & -#endif - var_name,LAT,ixrt,jxrt,trim(geo_finegrid_flnm)) - - - var_name = "LONGITUDE" -#ifdef MPP_LAND - call mpp_readRT2d_real(did, & -#else - call readRT2d_real( & -#endif - var_name,LON,ixrt,jxrt,trim(geo_finegrid_flnm)) - -! temp fix for buggy Arc export... - do j=1,jxrt - do i=1,ixrt - if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 - end do - end do - -!DJG inv do j=jxrt,1,-1 - do j=1,jxrt - do i = 1, ixrt - if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then - NLINKS = NLINKS + 1 - endif - end do - end do -#ifdef HYDRO_D - print *, "NLINKS IS ", NLINKS -#endif - - -!DJG inv DO j = JXRT,1,-1 !rows - DO j = 1,JXRT !rows - DO i = 1 ,IXRT !colsumns - If (CH_NETRT(i, j) .ge. 0) then !get its direction - If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT).AND.(CH_NETRT(i,j+1) .ge.0) ) then !North - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1) .ge.0)) then !North East - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT).AND.(CH_NETRT(i+1,j) .ge. 0)) then !East - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & - .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i+1,j-1).ge.0)) then !south east - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0)) then !due south - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & - .AND. (j - 1 .NE. 0).AND. (CH_NETRT(i-1,j-1).ge.0) ) then !south west - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0)) then !West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0)) then !North West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else -#ifdef HYDRO_D - write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j -135 FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4) -#endif - if (DIRECTION(i,j) .eq. 0) then -#ifdef HYDRO_D - print *, "Direction i,j ",i,j," of point ", cnt, "is invalid" -#endif - endif - - End If - End If !CH_NETRT check for this node - END DO - END DO -#ifdef HYDRO_D - print *, "found type 0 nodes", cnt -#endif - -!Find out if the boundaries are on an edge or flow into a lake -!DJG inv DO j = JXRT,1,-1 - DO j = 1,JXRT - DO i = 1 ,IXRT - If (CH_NETRT(i, j) .ge. 0) then !get its direction - - If ( ((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) & !-- 64's can only flow north - .OR. ((DIRECTION(i, j) .EQ. 64).and. (j1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) & !-- 4's can only flow due south - .OR. ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west - .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge - .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE. 0)) & !-- 16's can only flow due west - .OR. ((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north - .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge - .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. jchannel coefficients" - print *, "nod, n, Cs, Bw", nod, n, Cs, Bw - call hydro_stop("in DIFFUSION") -#endif - endif - -! Sf = ((z1+h1)-(z2+h2))/dx !-- compute the friction slope - !if(z1 .eq. z2) then - ! Sf = ((z1-(z2-0.01))+(h1-h2))/dx !-- compute the friction slope - !else -! Sf = ((z1-z2)+(h1-h2))/dx !-- compute the friction slope - !endif - -!modifieed by Wei Yu for false geography data - if(abs(z1-z2) .gt. 1.0E5) then -#ifdef HYDRO_D - print*, "Warning: huge slope rest to 0 for channel grid.", z1,z2 -#endif - Sf = ((h1-h2))/dx !-- compute the friction slope - else - Sf = ((z1-z2)+(h1-h2))/dx !-- compute the friction slope - endif -!end modfication - - sgn = SGNf(Sf) !-- establish sign - - w = 0.5*(sgn + 1.) !-- compute upstream or downstream weighting - - z = 1/Cs !--channel side distance (m) - R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z**2)) !-- Hyd Radius - AREA = (Bw+z*h1)*h1 !-- Flow area - Ku = (1/n)*(R**(2./3.))*AREA !-- convenyance - - R = ((Bw+z*h2)*h2)/(Bw+2*h2*sqrt(1+z**2)) !-- Hyd Radius - AREA = (Bw+z*h2)*h2 !-- Flow area - Kd = (1/n)*(R**(2./3.))*AREA !-- convenyance - - Kf = (1-w)*Kd + w*Ku !-- conveyance - DIFFUSION = Kf * sqrt(abs(Sf))*sgn - - -100 format('z1,z2,h1,h2,kf,Dif, Sf, sgn ',f8.3,2x,f8.3,2x,f8.4,2x,f8.4,2x,f8.3,2x,f8.3,2x,f8.3,2x,f8.0) - - END FUNCTION DIFFUSION -! ---------------------------------------------------------------- - -! ------------------------------------------------ -! FUNCTION MUSKINGUM CUNGE -! ------------------------------------------------ - REAL FUNCTION MUSKINGCUNGE(index,qup, quc, qdp, ql,& - dt,So,dx,n,Cs,Bw) - IMPLICIT NONE - -!--local variables - REAL :: C1, C2, C3, C4 - REAL :: Km !K travel time in hrs in reach - REAL :: X !weighting factors 0<=X<=0.5 - REAL :: dt !routing period in seconds - REAL :: qup !flow upstream previous timestep - REAL :: quc !flow upstream current timestep - REAL :: qdp !flow downstream previous timestep - REAL :: ql !lateral inflow through reach (m^3/sec) - REAL :: Ck ! wave celerity (m/s) - REAL :: qp ! peak flow - -!-- channel geometry and characteristics - REAL :: Bw ! bottom width (meters) - REAL :: Cs ! Channel side slope slope - REAL :: So ! Channel bottom slope - REAL :: dx ! channel lngth (m) - REAL :: n ! mannings coefficient - REAL :: Tw ! top width at peak flow - REAL :: AREA ! Cross sectional area m^2 - REAL :: Z ! trapezoid distance (m) - REAL :: R ! Hydraulic radius - REAL :: WP ! wetted perimmeter - REAL :: h ! depth of flow - REAL :: Qj ! intermediate flow estimate - REAL :: D,D1 ! diffusion coeff - REAL :: dtr ! required timestep, minutes - REAL :: error,shapefn, sh1, sh2, sh3 - REAL :: hp !courant, previous height - INTEGER :: maxiter !maximum number of iterations - -!-- local variables.. needed if channel is sub-divded - REAL :: c,b - REAL :: dxlocal - INTEGER :: i,index !-- channel segment counter - INTEGER :: ChnSegments !-- number of channel sub-sections - - c = 0.2407 !-- coefficnets for finding dx/Ckdt - b = 1.16065 - - z = 1/Cs !channel side distance (m) - h = sqrt(quc+ql)*0.1 !-- assume a initial depth (m) - qp = quc + ql - - if (n.le.0.or.So.le.0.or.z.le.0.or.Bw.le.0) then -#ifdef HYDRO_D - print*, "error in channel coefficients -> Muskingum cunge" - call hydro_stop("in MUSKINGCUNGE") -#endif - end if - - error = 1.0 - maxiter = 0 - - if (quc .gt.0) then !--top of link must have some water in it - do while (error .gt. 0.01 .and. maxiter < 100) !-- first estimate depth at top of channel - maxiter = maxiter + 1 - !---trapezoidal channel shape function - shapefn = SHAPE(Bw,z,h) - Qj = FLOW(n,So,Bw,h,z) - h = h - (1-quc/Qj)/(shapefn) - error = abs((Qj - quc)/quc) - end do - endif - - maxiter = 0 -!------- approximate flow and depth at the bottom of the channel - if (ql .eq.0 .and. quc .eq. 0) then !-- no water to route - Qj=0.0 - else - error = 1.0 !--reset the error - Tw = Bw + 2*z*h !--top width of the channel inflow - Ck = (sqrt(So)/n)*(5/3)*h**0.667 !-- pg 287 Chow, Mdt, Mays - X = 0.5-(qp/(2*Tw*So*Ck*dx)) - if (X.le.0) then -#ifdef HYDRO_D - print *, "Muskingum weighting factor is less than 0" -#endif - endif - - if ( dx/(Ck*dt) .le. c*LOG(X)+b) then !-- Bedient and Huber pg. 296 - ChnSegments = 1 - dxlocal = dx - else - dxlocal = fnDX(qp,Tw,So, Ck,dx,dt) !-- find appropriate channel length - X = 0.5-(qp/(2*Tw*So*Ck*dxlocal)) - if(FRACTION(dx/dxlocal) .le. 0.5) then !-- round up - ChnSegments = NINT(dx/dxlocal) + 1 - else - ChnSegments = NINT(dx/dxlocal) - endif - dxlocal = dx/ChnSegments !-- compute segment length, which will - endif - - do i = 1, ChnSegments - error = 1.0 !--reset the error - - do while (error .gt. 0.01 .and. maxiter < 500) - - if (qp.gt.2*(2*Tw*So*Ck*dxlocal)) then -#ifdef HYDRO_D - print *, "ERROR IN Musking Cunge,X <0 ", X - print *, "X,Qp,Tw,So,Ck,Dxlocal",X,Qp,Tw,So,Ck,Dxlocal -#endif - endif - - Km = dxlocal/Ck !-- minutes,Muskingum Param - D = (Km*(1 - X) + dt/2) !-- minutes - C1 = (Km*X + dt/2)/D - C2 = (dt/2 - Km*X)/D - C3 = (Km*(1-X)-dt/2)/D - C4 = (ql/ChnSegments*dt)/D !-- lateral inflow is along each channel sub-section - - MUSKINGCUNGE = (C1*qup)+(C2*quc)+(C3*qdp)+C4 !-- pg 295 Bedient huber assume flows from previous - !--previous values same in each segment,a good assumption? - if (MUSKINGCUNGE .lt. 0) then !-- only outflow -#ifdef HYDRO_D - print *, "ERROR: musking cunge is negative" - print *, "D, C1+C2+C3,C4, MsCng",D,C1+C2+C3,C4,Muskingcunge - print *, "qup, quc, qdp, ql",qup,quc,qdp,ql,i,ChnSegments -#endif - Qj = 0.0 - error = 0.001 - else -!---trapezoidal channel shape function - shapefn = SHAPE(Bw,z,h) - Qj = FLOW(n,So,Bw,h,z) - h = h - (1-MUSKINGCUNGE/Qj)/(shapefn) - error = abs((Qj - MUSKINGCUNGE)/MUSKINGCUNGE) - if (h<0.00001) error=0.001 !--very small flow depths to route - Tw = Bw+2*z*h - hp=h - maxiter = maxiter + 1 - endif - enddo !-- while error condtion number of - if (ChnSegments .gt.1) then - quc = MUSKINGCUNGE !-- update condition for next channel length upstream - endif - enddo !-- number of channel segment loops - endif - - MUSKINGCUNGE = Qj - - if(index .eq. 1 .or. index .eq. 2 .or. index .eq. 6) then -#ifdef HYDRO_D - write(*,13) index, ql,quc,qup,Qj,qdp -#endif - endif - -10 format('Tw,h,Z, latflow,usf',f3.1,2x,f8.4,2x,f4.1,2x,f5.4,2x,f5.4) -11 format('h, Qj, Musking, error',f8.4,2x,f8.4,2x,f8.4,2x,f8.4) -12 format('X, Km, Ck, dtcrv',f8.2,2x,f8.1,2x,f8.1,2x,f6.4) -13 format('ql,quc,qup,qdc,qdp',i2,2x,f8.2,2x,f8.2,2x,f8.2,2x,f8.2,2x,f8.2) - -! ---------------------------------------------------------------- - END FUNCTION MUSKINGCUNGE -! ---------------------------------------------------------------- - -! ------------------------------------------------ -! FUNCTION KINEMATIC -! ------------------------------------------------ - REAL FUNCTION KINEMATIC() - - IMPLICIT NONE - -! -------- DECLARATIONS ----------------------- - -! REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: OVRGH - - KINEMATIC = 1 -!---------------------------------------------------------------- - END FUNCTION KINEMATIC -!---------------------------------------------------------------- - - -! ------------------------------------------------ -! SUBROUTINE drive_CHANNEL -! ------------------------------------------------ - Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & - QSUBRT, LAKEINFLORT, QSTRMVOLRT, TO_NODE, FROM_NODE, & - TYPEL, ORDER, MAXORDER, NLINKS, CH_NETLNK, CH_NETRT, & - LAKE_MSKRT, DT, DTCT,DTRT, MUSK, MUSX, QLINK, & - HLINK, ELRT, CHANLEN, MannN, So, ChSSlp, Bw, & - RESHT, HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & - ORIFICEE, ZELEV, CVOL, NLAKES, QLAKEI, QLAKEO, LAKENODE, & - dist, QINFLOWBASE, CHANXI, CHANYJ, channel_option, RETDEP_CHAN & - ,node_area & -#ifdef MPP_LAND - ,lake_index,link_location,mpp_nlinks,nlinks_index,yw_mpp_nlinks & -#endif - ) - - IMPLICIT NONE - -! -------- DECLARATIONS ------------------------ - - INTEGER, INTENT(IN) :: IXRT,JXRT,channel_option - INTEGER, INTENT(IN) :: NLINKS,NLAKES - integer, INTENT(INOUT) :: KT ! flag of cold start (1) or continue run. - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QSUBRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKEINFLORT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QINFLOWBASE - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT - - real , dimension(ixrt,jxrt):: latval,lonval - - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - INTEGER, INTENT(IN), DIMENSION(NLINKS) :: ORDER, TYPEL !--link - INTEGER, INTENT(IN), DIMENSION(NLINKS) :: TO_NODE, FROM_NODE - INTEGER, INTENT(IN), DIMENSION(NLINKS) :: CHANXI, CHANYJ - REAL, INTENT(IN), DIMENSION(NLINKS) :: ZELEV !--elevation of nodes - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CVOL - REAL, INTENT(IN), DIMENSION(NLINKS) :: MUSK, MUSX - REAL, INTENT(IN), DIMENSION(NLINKS) :: CHANLEN - REAL, INTENT(IN), DIMENSION(NLINKS) :: So, MannN - REAL, INTENT(IN), DIMENSION(NLINKS) :: ChSSlp,Bw !--properties of nodes or links - REAL :: Km, X - REAL , INTENT(INOUT), DIMENSION(NLINKS,2) :: QLINK - REAL , INTENT(INOUT), DIMENSION(NLINKS) :: HLINK - REAL, INTENT(IN) :: DT !-- model timestep - REAL, INTENT(IN) :: DTRT !-- routing timestep - REAL, INTENT(INOUT):: DTCT - REAL :: dist(ixrt,jxrt,9) - REAL :: RETDEP_CHAN - INTEGER, INTENT(IN) :: MAXORDER, SUBRTSWCRT - REAL , INTENT(IN), DIMENSION(NLINKS) :: node_area - - !-- lake params - REAL, INTENT(IN), DIMENSION(NLAKES) :: HRZAREA !-- horizontal area (km^2) - REAL, INTENT(IN), DIMENSION(NLAKES) :: LAKEMAXH !-- maximum lake depth (m^2) - REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRC !-- weir coefficient - REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRL !-- weir length (m) - REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEC !-- orrifice coefficient - REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEA !-- orrifice area (m^2) - REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEE !-- orrifce elevation (m) - - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: RESHT !-- reservoir height (m) - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEI !-- lake inflow (cms) - REAL, DIMENSION(NLAKES) :: QLAKEIP !-- lake inflow previous timestep (cms) - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEO !-- outflow from lake used in diffusion scheme - INTEGER, INTENT(IN), DIMENSION(NLINKS) :: LAKENODE !-- outflow from lake used in diffusion scheme - REAL, DIMENSION(NLINKS) :: QLateral !--lateral flux - REAL, DIMENSION(NLINKS) :: QSUM !--mass bal of node - REAL, DIMENSION(NLAKES) :: QLLAKE !-- lateral inflow to lake in diffusion scheme - -!-- Local Variables - INTEGER :: i,j,k,m,kk,KRT,node - INTEGER :: DT_STEPS !-- number of timestep in routing - REAL :: qu,qd !--upstream, downstream flow - REAL :: bo !--critical depth, bnd outflow just for testing - - REAL, DIMENSION(NLINKS,2) :: QLINKPREV !-- temporarily store qlink value - REAL ,DIMENSION(NLINKS) :: HLINKTMP,CVOLTMP !-- temporarily store head values and volume values - REAL ,DIMENSION(NLINKS) :: CD !-- critical depth - real, DIMENSION(IXRT,JXRT) :: tmp - real, dimension(nlinks) :: tmp2 - -#ifdef MPP_LAND - integer lake_index(nlakes) - integer nlinks_index(nlinks) - integer mpp_nlinks, iyw, yw_mpp_nlinks - integer link_location(ixrt,jxrt) - real ywtmp(ixrt,jxrt) -#endif - integer flag - - integer :: kk2 ! tmp - - QLAKEIP = 0 - QLINKPREV = 0 - HLINKTMP = 0 - CVOLTMP = 0 - CD = 0 - - node = 1 - - - QLateral = 0 - QSUM = 0 - QLLAKE = 0 - - - IF(channel_option .ne. 3) then !--muskingum methods ROUTE ON DT timestep, not DTRT!! -#ifdef MPP_LAND -#ifdef HYDRO_D - write(6,*) "Error: not parallelized" - call hydro_stop("in drive_CHANNEL") -#endif -#endif - DT_STEPS = 1 - - DO KRT=1,DT_STEPS !-- route over routing timestep - - do k = 1, NLINKS - QLateral(k)=0 !--initial lateral flux to 0 for this reach - do i = 1, IXRT - do j = 1, JXRT - !--------river grid points - !!!! IS THIS CORREECT BECAUSE CH_NETRT IS JUST A 0,1????? - if ( (CH_NETRT(i,j) .eq. k) .and. (LAKE_MSKRT(i,j) .eq. -9999)) then - !--------river grid points - !-- convert total volume into flow rate across reach (m3/sec) - !-- QSUBRT and QSTRMVOLRT are mm for the DT interval, so - !-- you need to divided by the timestep fraction and - !-- multiply by DXRT^2 1m/1000mmm/DT - QLateral(k) = QLateral(k) + ((QSUBRT(i,j)+QSTRMVOLRT(i,j))/DT_STEPS & - *dist(i,j,9)/1000/DT) + QINFLOWBASE(i,j) - elseif ( (LAKE_MSKRT(i,j) .eq. k)) then !-lake grid - !-- convert total volume into flow rate across reach (m3/sec) - QLateral(k) = QLateral(k) + (LAKEINFLORT(i,j)/DT_STEPS & - *dist(i,j,9)/1000/DT) + QINFLOWBASE(i,j) - endif - end do - end do - end do - -!---------- route order 1 reaches which have no upstream inflow - do k=1, NLINKS - if (ORDER(k) .eq. 1) then !-- first order stream has no headflow - - if (KT .eq. 1) then !-- initial slug of water in unpstream cells - qd = QLINK(k,1) - KT = KT + 1 - else - qd = QLINK(k,2) !-- downstream outflow, previous timestep - QLINK(k,1) = 0 - endif - - if(TYPEL(k) .eq. 1) then !-- level pool route of reservoir - !CALL LEVELPOOL(1,0.0, 0.0, qd, QLINK(k,2), QLateral(k), & - ! DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), & - ! WEIRC(k), WEIRL(k), ORIFICEE(i), ORIFICEC(k), ORIFICEA(k) ) - elseif (channel_option .eq. 1) then - Km = MUSK(k) - X = MUSX(k) - QLINK(k,2) = MUSKING(QLINK(k,1), QLateral(k), qd, DT, Km, X) !--current outflow - elseif (channel_option .eq. 2) then !-- upstream is assumed constant initial condition - QLINK(k,2) = MUSKINGCUNGE(k,QLINK(k,1),QLINK(k,1), qd, & - QLateral(k), DT, So(k), CHANLEN(k), & - MannN(k), ChSSLP(k), Bw(k)) - - else -#ifdef HYDRO_D - print *, "No channel option selected" - call hydro_stop("drive_CHANNEL") -#endif - endif - endif - end do - - !---------- route other reaches, with upstream inflow - do kk = 2, MAXORDER - do k = 1, NLINKS - qu = 0 - if (ORDER(k) .eq. kk) then !--do the orders sequentially - qd = QLINK(k,2) !--downstream flow previous timestep - - do m = 1, NLINKS - if (TO_NODE(m) .eq. FROM_NODE(k)) then - qu = qu + QLINK(m,2) !--upstream previous timestep - endif - end do ! do m - - - if(TYPEL(k) .eq. 1) then !--link is a reservoir - ! CALL LEVELPOOL(1,QLINK(k,1), qu, qd, QLINK(k,2), & - ! QLateral(k), DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), & - ! WEIRC(k), WEIRL(k),ORIFICEE(k), ORIFICEC(k), ORIFICEA(k)) - elseif (channel_option .eq. 1) then !muskingum routing - Km = MUSK(k) - X = MUSX(k) - QLINK(k,2) = MUSKING(QLINK(k,1),qu,qd,DT,Km,X) - elseif (channel_option .eq. 2) then ! muskingum cunge - QLINK(k,2) = MUSKINGCUNGE(k,QLINK(k,1), qu, qd, & - QLateral(k), DT, So(k), CHANLEN(k), & - MannN(k), ChSSlp(k), Bw(k) ) - else -#ifdef HYDRO_D - print *, " no channel option selected" - call hydro_stop("drive_CHANNEL") -#endif - endif - QLINK(k,1) = qu !save inflow to reach at current timestep - !to be used as inflow from previous timestep - !on next iteration - endif !--order == kk - end do !--k links - end do !--kk order - -#ifdef HYDRO_D - print *, "END OF ALL REACHES...",KRT,DT_STEPS -#endif - - END DO !-- krt timestep for muksingumcunge routing - -!yw begin - elseif(channel_option .eq. 3) then !--- route using the diffusion scheme on nodes not links - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINK,NLINKS,99) - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOL,NLINKS,99) -#endif - - KRT = 0 !-- initialize the time counter - - DTCT = min(DTCT*2.0,DTRT) -!yw DTCT = DTRT !-- initialize the routing timestep to the timestep in namelist (s) - - HLINKTMP = HLINK !-- temporary storage of the water elevations (m) - CVOLTMP = CVOL !-- temporary storage of the volume of water in channel (m^3) - QLAKEIP = QLAKEI !-- temporary lake inflow from previous timestep (cms) - -! call check_channel(77,HLINKTMP,1,nlinks) -! call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,ZELEV,NLINKS,99) -! call check_channel(78,ZELEV,1,nlinks) - - -crnt: DO !-- loop on the courant condition - QSUM = 0 !-- initialize the total flow out of each cell to zero - QLAKEI = 0 !-- set the lake inflow as zero - QLLAKE = 0 !-- initialize each lake's lateral inflow to zero - DT_STEPS=INT(DT/DTCT) !-- fix the timestep - QLateral = 0. - - -!-- vectorize -!--------------------- -#ifdef MPP_LAND - DO iyw = 1,yw_MPP_NLINKS - i = nlinks_index(iyw) -#else - DO i = 1,NLINKS -#endif - - if(node_area(i) .eq. 0) then - write(6,*) "Error: node_area(i) is zero. i=", i - call hydro_stop("drive_CHANNEL") - endif - - if((CH_NETRT(CHANXI(i), CHANYJ(i) ) .eq. 0) .and. & - (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .lt.0) ) then !--a reg. node - QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) = & -! await subsfc exchg ((QSUBRT(CHANXI(i),CHANYJ(i))+QSTRMVOLRT(CHANXI(i),CHANYJ(i))+& - ((QSTRMVOLRT(CHANXI(i),CHANYJ(i))+& - QINFLOWBASE(CHANXI(i),CHANYJ(i))) & - /DT_STEPS*node_area(i)/1000/DTCT) - if(Qlateral(CH_NETLNK(CHANXI(i),CHANYJ(i))).lt.0.) then -#ifdef HYDRO_D - print*, "i, CHANXI(i),CHANYJ(i) = ", i, CHANXI(i),CHANYJ(i) - print *, "NEGATIVE Lat inflow...",QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))), & - QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)), & - QINFLOWBASE(CHANXI(i),CHANYJ(i)) - call hydro_stop("drive_CHANNEL") -#endif - end if - elseif(LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .gt. 0 .and. & - (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .ne. -9999)) then !--a lake node - QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) = & - QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) + & - (LAKEINFLORT(CHANXI(i),CHANYJ(i))+ & - QINFLOWBASE(CHANXI(i),CHANYJ(i)) & - /DT_STEPS*node_area(i)/1000/DTCT) - elseif(CH_NETRT(CHANXI(i),CHANYJ(i)) .gt. 0) then !pour out of lake - QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) = & - QLAKEO(CH_NETRT(CHANXI(i),CHANYJ(i))) !-- previous timestep - endif - ENDDO - - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLateral,NLINKS,99) - if(NLAKES .gt. 0) then - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT ,ixrt,jxrt,QLLAKE,NLAKES,99) - endif -#endif - -! call check_channel(79,QLINK(:,1),1,nlinks) - - - !-- compute conveyances, with known depths (just assign to QLINK(,1) - !--QLINK(,2) will not be used), QLINK is the flow across the node face - !-- units should be m3/second.. consistent with QL (lateral flow) - -#ifdef MPP_LAND - DO iyw = 1,yw_MPP_NLINKS - i = nlinks_index(iyw) -#else - DO i = 1,NLINKS -#endif - if (TYPEL(i) .eq. 0 .AND. HLINKTMP(FROM_NODE(i)) .gt. RETDEP_CHAN) then - if(from_node(i) .ne. to_node(i) .and. (to_node(i) .gt. 0) .and.(from_node(i) .gt. 0) ) & ! added by Wei Yu - QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & - HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & - CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) - else !-- we are just computing critical depth for outflow points - QLINK(i,1) =0. - endif - ENDDO - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99) -#endif -! call check_lake(80,QLLAKE,lake_index,nlakes) -! call check_channel(81,QLINK(:,1),1,nlinks) -! call check_channel(82,HLINKTMP,1,nlinks) -! call check_channel(89,HLINKTMP,1,nlinks) -! call check_channel(83,CHANLEN,1,nlinks) -! call check_channel(84,MannN,1,nlinks) -! call check_channel(85,Bw,1,nlinks) -! call check_channel(86,ChSSlp,1,nlinks) -! call check_channel(87,TYPEL*1.0,1,nlinks) - - - !-- compute total flow across face, into node -#ifdef MPP_LAND - DO iyw = 1,yw_mpp_nlinks - i = nlinks_index(iyw) -#else - DO i = 1,NLINKS !-- inflow to node across each face -#endif - if(TYPEL(i) .eq. 0) then !-- only regular nodes have to attribute - QSUM(TO_NODE(i)) = QSUM(TO_NODE(i)) + QLINK(i,1) - endif - END DO - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,0) -#endif - -! call check_channel(79,TYPEL*1.0,1,nlinks) - -! call check_channel(80,QLINK(:,1),1,nlinks) - -! call check_channel(89,qsum,1,nlinks) - - - -#ifdef MPP_LAND - DO iyw = 1,yw_mpp_nlinks - i = nlinks_index(iyw) -#else - DO i = 1,NLINKS !-- outflow from node across each face -#endif - QSUM(FROM_NODE(i)) = QSUM(FROM_NODE(i)) - QLINK(i,1) - END DO -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,99) -#endif -! call check_channel(89,qsum,1,nlinks) - - - flag = 99 - - -#ifdef MPP_LAND - DO iyw = 1,yw_MPP_NLINKS - i = nlinks_index(iyw) -#else - DO i = 1, NLINKS !--- compute volume and depth at each node -#endif - - if( TYPEL(i).eq.0 .and. CVOLTMP(i) .ge. 0.001 .and.(CVOLTMP(i)-QSUM(i)*DTCT)/CVOLTMP(i) .le. -0.01 ) then - flag = -99 -#ifdef HYDRO_D - write(6,*) "******* start diag ***************" - write(6,*) "Unstable at node ",i, "i=",CHANXI(i),"j=",CHANYJ(i) - write(6,*) "Unstatble at node ",i, "lat=",latval(CHANXI(i),CHANYJ(i)), "lon=",lonval(CHANXI(i),CHANYJ(i)) - write(6,*) "TYPEL, CVOLTMP, QSUM, QSUM*DTCT",TYPEL(i), CVOLTMP(i), QSUM(i), QSUM(i)*DTCT - write(6,*) "qsubrt, qstrmvolrt,qlink",QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)),qlink(i,1),qlink(i,2) -! write(6,*) "current nodes, z, h", ZELEV(FROM_NODE(i)),HLINKTMP(FROM_NODE(i)) -! if(TO_NODE(i) .gt. 0) then -! write(6,*) "to nodes, z, h", ZELEV(TO_NODE(i)), HLINKTMP(TO_NODE(i)) -! else -! write(6,*) "no to nodes " -! endif - write(6,*) "CHANLEN(i), MannN(i), Bw(i), ChSSlp(i) ", CHANLEN(i), MannN(i), Bw(i), ChSSlp(i) - write(6,*) "*******end of diag ***************" -#endif - - goto 999 - endif - enddo - -999 continue -#ifdef MPP_LAND - call mpp_same_int1(flag) -#endif - - - if(flag < 0 .and. DTCT >0.1) then - - ! call smoth121(HLINK,nlinks,maxv_p,pnode,to_node) - - if(DTCT .gt. 0.001) then !-- timestep in seconds - DTCT = max(DTCT/2 ,0.1) !-- 1/2 timestep - KRT = 0 !-- restart counter - HLINKTMP = HLINK !-- set head and vol to start value of timestep - CVOLTMP = CVOL - CYCLE crnt !-- start cycle over with smaller timestep - else -#ifdef HYDRO_D - write(6,*) "Error ..... with small DTCT",DTCT - call hydro_stop("drive_CHANNEL") -#endif - DTCT = 0.1 - HLINKTMP = HLINK !-- set head and volume to start values of timestep - CVOLTMP = CVOL - goto 998 - end if - endif - -998 continue - - -#ifdef MPP_LAND - DO iyw = 1,yw_MPP_NLINKS - i = nlinks_index(iyw) -#else - DO i = 1, NLINKS !--- compute volume and depth at each node -#endif - - if(TYPEL(i) .eq. 0) then !-- regular channel grid point, compute volume - CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) )* DTCT - if(CVOLTMP(i) .lt. 0) then -#ifdef HYDRO_D - print *, "warning! channel volume less than 0:i,CVOL,QSUM,QLat", & - i, CVOLTMP(i),QSUM(i),QLateral(i),HLINK(i) -#endif - CVOLTMP(i) =0 - endif - - elseif(TYPEL(i) .eq. 1) then !-- pour point, critical depth downstream - - if (QSUM(i)+QLateral(i) .lt. 0) then - else - -!DJG remove to have const. flux b.c.... CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) - CD(i) = HLINKTMP(i) !This is a temp hardwire for flow depth for the pour point... - endif - - ! change in volume is inflow, lateral flow, and outflow - !yw DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*DXRT),HLINKTMP(i), & - CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & - DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & - CD(i),CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT - elseif (TYPEL(i) .eq. 2) then !--- into a reservoir, assume critical depth - if (QSUM(i)+QLateral(i) .lt. 0) then -#ifdef HYDRO_D - print *, i, 'CrtDpth Qsum+QLat into lake< 0',QSUM(i), QLateral(i) -#endif - else -!DJG remove to have const. flux b.c.... CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) - CD(i) = HLINKTMP(i) !This is a temp hardwire for flow depth for the pour point... - endif - - !-- compute volume in reach (m^3) - CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & - DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & - CD(i) ,CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT - !-- compute flow rate into lake from all contributing nodes (cms) - QLAKEI(LAKENODE(i)) = QLAKEI(LAKENODE(i)) + QLINK(FROM_NODE(i),1) - - else -#ifdef HYDRO_D - print *, "this node does not have a type.. error TYPEL =", TYPEL(i) - call hydro_stop("drive_CHANNEL") -#endif - endif - - if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow - HLINKTMP(i) = HEAD(i, CVOLTMP(i)/CHANLEN(i),Bw(i),1/ChSSlp(i)) !--updated depth - else - HLINKTMP(i) = CD(i) !!! CRITICALDEPTH(i,QSUM(i)+QLateral(i), Bw(i), 1./ChSSlp(i)) !--critical depth is head - endif - - END DO !--- done processing all the links - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOLTMP,NLINKS,99) - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CD,NLINKS,99) - if(NLAKES .gt. 0) then - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) - endif - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINKTMP,NLINKS,99) -#endif -! call check_channel(83,CVOLTMP,1,nlinks) -! call check_channel(84,CD,1,nlinks) -! call check_channel(85,HLINKTMP,1,nlinks) -! call check_lake(86,QLAKEI,lake_index,nlakes) - -! call hydro_stop("88888888") - - - - - do i = 1, NLAKES !-- mass balances of lakes -#ifdef MPP_LAND - if(lake_index(i) .gt. 0) then -#endif - CALL LEVELPOOL(i,QLAKEIP(i), QLAKEI(i), QLAKEO(i), QLLAKE(i), & - DTCT, RESHT(i), HRZAREA(i), LAKEMAXH(i), WEIRC(i), & - WEIRL(i), ORIFICEE(i), ORIFICEC(i), ORIFICEA(i)) - QLAKEIP(i) = QLAKEI(i) !-- store total lake inflow for this timestep -#ifdef MPP_LAND - endif -#endif - enddo -#ifdef MPP_LAND - if(NLAKES .gt. 0) then - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT ,ixrt,jxrt,QLLAKE,NLAKES,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,RESHT,NLAKES,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEO,NLAKES,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEIP,NLAKES,99) - endif -#endif - - -#ifdef MPP_LAND - DO iyw = 1,yw_MPP_NLINKS - i = nlinks_index(iyw) -#else - DO i = 1, NLINKS !--- compute volume and depth at each node -#endif - if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow - QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & - HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & - CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) - endif - enddo - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99) -#endif - - KRT = KRT + 1 !-- iterate on the timestep - IF(KRT .eq. DT_STEPS) EXIT crnt !-- up to the maximum time in interval - - END DO crnt !--- DTCT timestep of DT_STEPS - - HLINK = HLINKTMP !-- update head based on final solution in timestep - CVOL = CVOLTMP !-- update volume - else !-- no channel option apparently selected -#ifdef HYDRO_D - print *, "no channel option selected" - call hydro_stop("drive_CHANNEL") -#endif - endif - -#ifdef HYDRO_D - write(6,*) "finished call drive_CHANNEL" -#endif - - if (KT .eq. 1) KT = KT + 1 - - - END SUBROUTINE drive_CHANNEL -! ---------------------------------------------------------------- - -!--================== utility functions - REAL FUNCTION SHAPE(Bw,z,h) - REAL :: Bw, z, h - REAL :: sh1, sh2, sh3 - !---trapezoidal channel shape function - sh1 = (Bw+2*z*h)*(5*Bw + 6*h*sqrt(1+z**2)) - sh2 = 4*z*h**2*sqrt(1+z**2) - sh3 = (3*h*(Bw+z*h)*(Bw+2*h*sqrt(1+z**2))) - if (sh3 .eq. 0) then - SHAPE = 0 - else - SHAPE = (sh1+sh2)/sh3 - endif - END FUNCTION SHAPE - - REAL FUNCTION FLOW(n,So,Bw,h,z) - REAL :: n,So, Bw, z, h - REAL :: WP, AREA - WP = Bw + 2*h*sqrt(1+h**2) !-- wetted perimeter - AREA = (Bw+z*h)*h !-- Flow area - if (WP .le.0) then -#ifdef HYDRO_D - print *, "Wetter perimeter is zero, will get divide by zero error" - call hydro_stop("in SHAPE") -#endif - else - FLOW = (1/n)*sqrt(So)*(AREA**(5./3.)/(WP**(2./3.))) - endif - END FUNCTION FLOW - -!-======================================= - REAL FUNCTION AREAf(AREA,Bw,h,z) - REAL :: AREA, Bw, z, h - AREAf = (Bw+z*h)*h-AREA !-- Flow area - END FUNCTION AREAf - -!-====critical depth function ========== - REAL FUNCTION CDf(Q,Bw,h,z) - REAL :: Q, Bw, z, h - if(h .le. 0) then -#ifdef HYDRO_D - print *, "head is zero, will get division by zero error" - call hydro_stop("in AREAf") -#endif - else - CDf = (Q/((Bw+z*h)*h))/(sqrt(9.81*(((Bw+z*h)*h)/(Bw+2*z*h))))-1 !--critical depth function - endif - END FUNCTION CDf - -!=======find flow depth in channel with bisection Chapra pg. 131 - REAL FUNCTION HEAD(index,AREA,Bw,z) !-- find the water elevation given wetted area, - !--bottom widith and side channel.. index was for debuggin - REAL :: Bw,z,AREA,test - REAL :: hl, hu, hr, hrold - REAL :: fl, fr,error !-- function evaluation - INTEGER :: maxiter,index - - error = 1.0 - maxiter = 0 - hl = 0.00001 !-- minimum depth is small - hu = 30. !-- assume maximum depth is 30 meters - - if (AREA .lt. 0.00001) then - hr = 0. - else - do while ((AREAf(AREA,BW,hl,z)*AREAf(AREA,BW,hu,z)).gt.0 .and. maxiter .lt. 100) - !-- allows for larger , smaller heads - if(AREA .lt. 1.) then - hl=hl/2 - else - hu = hu * 2 - endif - maxiter = maxiter + 1 - - end do - - maxiter =0 - hr = 0 - fl = AREAf(AREA,Bw,hl,z) - do while (error .gt. 0.0001 .and. maxiter < 1000) - hrold = hr - hr = (hl+hu)/2 - fr = AREAf(AREA,Bw,hr,z) - maxiter = maxiter + 1 - if (hr .ne. 0) then - error = abs((hr - hrold)/hr) - endif - test = fl * fr - if (test.lt.0) then - hu = hr - elseif (test.gt.0) then - hl=hr - fl = fr - else - error = 0.0 - endif - end do - endif - HEAD = hr - -22 format("i,hl,hu,Area",i5,2x,f12.8,2x,f6.3,2x,f6.3,2x,f6.3,2x,f9.1,2x,i5) - - END FUNCTION HEAD -!================================= - REAL FUNCTION MANNING(h1,n,Bw,Cs) - - REAL :: Bw,h1,Cs,n - REAL :: z, AREA,R,Kd - - z=1/Cs - R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z**2)) !-- Hyd Radius - AREA = (Bw+z*h1)*h1 !-- Flow area - Kd = (1/n)*(R**(2./3.))*AREA !-- convenyance -#ifdef HYDRO_D - print *,"head, kd", h1,Kd -#endif - MANNING = Kd - - END FUNCTION MANNING - -!=======find flow depth in channel with bisection Chapra pg. 131 - REAL FUNCTION CRITICALDEPTH(lnk,Q,Bw,z) !-- find the critical depth - REAL :: Bw,z,Q,test - REAL :: hl, hu, hr, hrold - REAL :: fl, fr,error !-- function evaluation - INTEGER :: maxiter - INTEGER :: lnk - - error = 1.0 - maxiter = 0 - hl = 1e-5 !-- minimum depth is 0.00001 meters -! hu = 35. !-- assume maximum critical depth 25 m - hu = 100. !-- assume maximum critical depth 25 m - - if(CDf(Q,BW,hl,z)*CDf(Q,BW,hu,z) .gt. 0) then - if(Q .gt. 0.001) then -#ifdef HYDRO_D - print *, "interval won't work to find CD of lnk ", lnk - print *, "Q, hl, hu", Q, hl, hu - print *, "cd lwr, upr", CDf(Q,BW,hl,z), CDf(Q,BW,hu,z) - ! call hydro_stop("in CRITICALDEPTH") - CRITICALDEPTH = -9999 - return -#endif - else - Q = 0.0 - endif - endif - - hr = 0. - fl = CDf(Q,Bw,hl,z) - - if (Q .eq. 0.) then - hr = 0. - else - do while (error .gt. 0.0001 .and. maxiter < 1000) - hrold = hr - hr = (hl+hu)/2 - fr = CDf(Q,Bw,hr,z) - maxiter = maxiter + 1 - if (hr .ne. 0) then - error = abs((hr - hrold)/hr) - endif - test = fl * fr - if (test.lt.0) then - hu = hr - elseif (test.gt.0) then - hl=hr - fl = fr - else - error = 0.0 - endif - - end do - endif - - CRITICALDEPTH = hr - - END FUNCTION CRITICALDEPTH -!================================================ - REAL FUNCTION SGNf(val) !-- function to return the sign of a number - REAL:: val - - if (val .lt. 0) then - SGNf= -1. - elseif (val.gt.0) then - SGNf= 1. - else - SGNf= 0. - endif - - END FUNCTION SGNf -!================================================ - - REAL FUNCTION fnDX(qp,Tw,So,Ck,dx,dt) !-- find channel sub-length for MK method - REAL :: qp,Tw,So,Ck,dx, dt,test - REAL :: dxl, dxu, dxr, dxrold - REAL :: fl, fr, error - REAL :: X - INTEGER :: maxiter - - error = 1.0 - maxiter =0 - dxl = dx*0.9 !-- how to choose dxl??? - dxu = dx - dxr=0 - - do while (fnDXCDT(qp,Tw,So,Ck,dxl,dt)*fnDXCDT(qp,Tw,So,Ck,dxu,dt) .gt. 0 & - .and. dxl .gt. 10) !-- don't let dxl get too small - dxl = dxl/1.1 - end do - - - fl = fnDXCDT(qp,Tw,So,Ck,dxl,dt) - do while (error .gt. 0.0001 .and. maxiter < 1000) - dxrold = dxr - dxr = (dxl+dxu)/2 - fr = fnDXCDT(qp,Tw,So,Ck,dxr,dt) - maxiter = maxiter + 1 - if (dxr .ne. 0) then - error = abs((dxr - dxrold)/dxr) - endif - test = fl * fr - if (test.lt.0) then - dxu = dxr - elseif (test.gt.0) then - dxl=dxr - fl = fr - else - error = 0.0 - endif - end do - FnDX = dxr - - END FUNCTION fnDX -!================================================ - REAL FUNCTION fnDXCDT(qp,Tw,So,Ck,dx,dt) !-- function to help find sub-length for MK method - REAL :: qp,Tw,So,Ck,dx,dt,X - REAL :: c,b !-- coefficients on dx/cdt log approximation function - - c = 0.2407 - b = 1.16065 - X = 0.5-(qp/(2*Tw*So*Ck*dx)) - if (X .le.0) then - fnDXCDT = -1 !0.115 - else - fnDXCDT = (dx/(Ck*dt)) - (c*LOG(X)+b) !-- this function needs to converge to 0 - endif - END FUNCTION fnDXCDT -! ---------------------------------------------------------------------- - - subroutine check_lake(unit,cd,lake_index,nlakes) - use module_RT_data, only: rt_domain - implicit none - integer :: unit,nlakes,i,lake_index(nlakes) - real cd(nlakes) -#ifdef MPP_LAND - call write_lake_real(cd,lake_index,nlakes) -#endif - write(unit,*) cd - flush(unit) - return - end subroutine check_lake - - subroutine check_channel(unit,cd,did,nlinks) - use module_RT_data, only: rt_domain -#ifdef MPP_LAND - USE module_mpp_land -#endif - implicit none - integer :: unit,nlinks,i, did - real cd(nlinks) -#ifdef MPP_LAND - real g_cd(rt_domain(did)%gnlinks) - call write_chanel_real(cd,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,nlinks,g_cd) - if(my_id .eq. IO_id) then - write(unit,*) "rt_domain(did)%gnlinks = ",rt_domain(did)%gnlinks - write(unit,*) g_cd - endif -#else - write(unit,*) cd -#endif - flush(unit) - close(unit) - return - end subroutine check_channel - subroutine smoth121(var,nlinks,maxv_p,from_node,to_node) - implicit none - integer,intent(in) :: nlinks, maxv_p - integer, intent(in), dimension(nlinks):: to_node - integer, intent(in), dimension(nlinks):: from_node(nlinks,maxv_p) - real, intent(inout), dimension(nlinks) :: var - real, dimension(nlinks) :: vartmp - integer :: i,j , k, from,to - integer :: plen - vartmp = 0 - do i = 1, nlinks - to = to_node(i) - plen = from_node(i,1) - if(plen .gt. 1) then - do k = 1, plen-1 - from = from_node(i,k+1) - if(to .gt. 0) then - vartmp(i) = vartmp(i)+0.25*(var(from)+2.*var(i)+var(to)) - else - vartmp(i) = vartmp(i)+(2.*var(i)+var(from))/3.0 - endif - end do - vartmp(i) = vartmp(i) /(plen-1) - else - if(to .gt. 0) then - vartmp(i) = vartmp(i)+(2.*var(i)+var(to)/3.0) - else - vartmp(i) = var(i) - endif - endif - end do - var = vartmp - return - end subroutine smoth121 -END MODULE module_channel_routing diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/module_date_utilities_rt.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/module_date_utilities_rt.F.svn-base deleted file mode 100644 index 4ec65dd9..00000000 --- a/wrfv2_fire/hydro/Routing/.svn/text-base/module_date_utilities_rt.F.svn-base +++ /dev/null @@ -1,1040 +0,0 @@ -module Module_Date_utilities_rt -contains - subroutine geth_newdate (ndate, odate, idt) - implicit none - - ! From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and - ! delta-time, compute the new date. - - ! on entry - odate - the old hdate. - ! idt - the change in time - - ! on exit - ndate - the new hdate. - - integer, intent(in) :: idt - character (len=*), intent(out) :: ndate - character (len=*), intent(in) :: odate - - ! Local Variables - - ! yrold - indicates the year associated with "odate" - ! moold - indicates the month associated with "odate" - ! dyold - indicates the day associated with "odate" - ! hrold - indicates the hour associated with "odate" - ! miold - indicates the minute associated with "odate" - ! scold - indicates the second associated with "odate" - - ! yrnew - indicates the year associated with "ndate" - ! monew - indicates the month associated with "ndate" - ! dynew - indicates the day associated with "ndate" - ! hrnew - indicates the hour associated with "ndate" - ! minew - indicates the minute associated with "ndate" - ! scnew - indicates the second associated with "ndate" - - ! mday - a list assigning the number of days in each month - - ! i - loop counter - ! nday - the integer number of days represented by "idt" - ! nhour - the integer number of hours in "idt" after taking out - ! all the whole days - ! nmin - the integer number of minutes in "idt" after taking out - ! all the whole days and whole hours. - ! nsec - the integer number of minutes in "idt" after taking out - ! all the whole days, whole hours, and whole minutes. - - integer :: newlen, oldlen - integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew - integer :: yrold, moold, dyold, hrold, miold, scold, frold - integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc - logical :: opass - character (len=10) :: hfrc - character (len=1) :: sp - logical :: punct - integer :: yrstart, yrend, mostart, moend, dystart, dyend - integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart - integer :: units - integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) - - ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...." - if (odate(5:5) == "-") then - punct = .TRUE. - else - punct = .FALSE. - endif - - ! Break down old hdate into parts - - hrold = 0 - miold = 0 - scold = 0 - frold = 0 - oldlen = LEN(odate) - if (punct) then - yrstart = 1 - yrend = 4 - mostart = 6 - moend = 7 - dystart = 9 - dyend = 10 - hrstart = 12 - hrend = 13 - mistart = 15 - miend = 16 - scstart = 18 - scend = 19 - frstart = 21 - select case (oldlen) - case (10) - ! Days - units = 1 - case (13) - ! Hours - units = 2 - case (16) - ! Minutes - units = 3 - case (19) - ! Seconds - units = 4 - case (21) - ! Tenths - units = 5 - case (22) - ! Hundredths - units = 6 - case (23) - ! Thousandths - units = 7 - case (24) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - call hydro_stop("geth_newdate") -#endif - end select - - if (oldlen.ge.11) then - sp = odate(11:11) - else - sp = ' ' - end if - - else - - yrstart = 1 - yrend = 4 - mostart = 5 - moend = 6 - dystart = 7 - dyend = 8 - hrstart = 9 - hrend = 10 - mistart = 11 - miend = 12 - scstart = 13 - scend = 14 - frstart = 15 - - select case (oldlen) - case (8) - ! Days - units = 1 - case (10) - ! Hours - units = 2 - case (12) - ! Minutes - units = 3 - case (14) - ! Seconds - units = 4 - case (15) - ! Tenths - units = 5 - case (16) - ! Hundredths - units = 6 - case (17) - ! Thousandths - units = 7 - case (18) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - call hydro_stop("geth_newdate") -#endif - end select - endif - - ! Use internal READ statements to convert the CHARACTER string - ! date into INTEGER components. - - read(odate(yrstart:yrend), '(i4)') yrold - read(odate(mostart:moend), '(i2)') moold - read(odate(dystart:dyend), '(i2)') dyold - if (units.ge.2) then - read(odate(hrstart:hrend),'(i2)') hrold - if (units.ge.3) then - read(odate(mistart:miend),'(i2)') miold - if (units.ge.4) then - read(odate(scstart:scend),'(i2)') scold - if (units.ge.5) then - read(odate(frstart:oldlen),*) frold - end if - end if - end if - end if - - ! Set the number of days in February for that year. - - mday(2) = nfeb(yrold) - - ! Check that ODATE makes sense. - - opass = .TRUE. - - ! Check that the month of ODATE makes sense. - - if ((moold.gt.12).or.(moold.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold -#endif - opass = .FALSE. - end if - - ! Check that the day of ODATE makes sense. - - if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold -#endif - opass = .FALSE. - end if - - ! Check that the hour of ODATE makes sense. - - if ((hrold.gt.23).or.(hrold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold -#endif - opass = .FALSE. - end if - - ! Check that the minute of ODATE makes sense. - - if ((miold.gt.59).or.(miold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold -#endif - opass = .FALSE. - end if - - ! Check that the second of ODATE makes sense. - - if ((scold.gt.59).or.(scold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold -#endif - opass = .FALSE. - end if - - ! Check that the fractional part of ODATE makes sense. - - - if (.not.opass) then -#ifdef HYDRO_D - write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen - stop -#endif - end if - - ! Date Checks are completed. Continue. - - - ! Compute the number of days, hours, minutes, and seconds in idt - - if (units.ge.5) then !idt should be in fractions of seconds - ifrc = oldlen-(frstart)+1 - ifrc = 10**ifrc - nday = abs(idt)/(86400*ifrc) - nhour = mod(abs(idt),86400*ifrc)/(3600*ifrc) - nmin = mod(abs(idt),3600*ifrc)/(60*ifrc) - nsec = mod(abs(idt),60*ifrc)/(ifrc) - nfrac = mod(abs(idt), ifrc) - else if (units.eq.4) then !idt should be in seconds - ifrc = 1 - nday = abs(idt)/86400 ! integer number of days in delta-time - nhour = mod(abs(idt),86400)/3600 - nmin = mod(abs(idt),3600)/60 - nsec = mod(abs(idt),60) - nfrac = 0 - else if (units.eq.3) then !idt should be in minutes - ifrc = 1 - nday = abs(idt)/1440 ! integer number of days in delta-time - nhour = mod(abs(idt),1440)/60 - nmin = mod(abs(idt),60) - nsec = 0 - nfrac = 0 - else if (units.eq.2) then !idt should be in hours - ifrc = 1 - nday = abs(idt)/24 ! integer number of days in delta-time - nhour = mod(abs(idt),24) - nmin = 0 - nsec = 0 - nfrac = 0 - else if (units.eq.1) then !idt should be in days - ifrc = 1 - nday = abs(idt) ! integer number of days in delta-time - nhour = 0 - nmin = 0 - nsec = 0 - nfrac = 0 - else -#ifdef HYDRO_D - write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & - oldlen - write(*,*) '#'//odate(1:oldlen)//'#' - call hydro_stop("geth_newdate") -#endif - end if - - if (idt.ge.0) then - - frnew = frold + nfrac - if (frnew.ge.ifrc) then - frnew = frnew - ifrc - nsec = nsec + 1 - end if - - scnew = scold + nsec - if (scnew .ge. 60) then - scnew = scnew - 60 - nmin = nmin + 1 - end if - - minew = miold + nmin - if (minew .ge. 60) then - minew = minew - 60 - nhour = nhour + 1 - end if - - hrnew = hrold + nhour - if (hrnew .ge. 24) then - hrnew = hrnew - 24 - nday = nday + 1 - end if - - dynew = dyold - monew = moold - yrnew = yrold - do i = 1, nday - dynew = dynew + 1 - if (dynew.gt.mday(monew)) then - dynew = dynew - mday(monew) - monew = monew + 1 - if (monew .gt. 12) then - monew = 1 - yrnew = yrnew + 1 - ! If the year changes, recompute the number of days in February - mday(2) = nfeb(yrnew) - end if - end if - end do - - else if (idt.lt.0) then - - frnew = frold - nfrac - if (frnew .lt. 0) then - frnew = frnew + ifrc - nsec = nsec + 1 - end if - - scnew = scold - nsec - if (scnew .lt. 00) then - scnew = scnew + 60 - nmin = nmin + 1 - end if - - minew = miold - nmin - if (minew .lt. 00) then - minew = minew + 60 - nhour = nhour + 1 - end if - - hrnew = hrold - nhour - if (hrnew .lt. 00) then - hrnew = hrnew + 24 - nday = nday + 1 - end if - - dynew = dyold - monew = moold - yrnew = yrold - do i = 1, nday - dynew = dynew - 1 - if (dynew.eq.0) then - monew = monew - 1 - if (monew.eq.0) then - monew = 12 - yrnew = yrnew - 1 - ! If the year changes, recompute the number of days in February - mday(2) = nfeb(yrnew) - end if - dynew = mday(monew) - end if - end do - end if - - ! Now construct the new mdate - - newlen = LEN(ndate) - - if (punct) then - - if (newlen.gt.frstart) then - write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew - write(hfrc,'(i10)') frnew+1000000000 - ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) - - else if (newlen.eq.scend) then - write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew -19 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2) - - else if (newlen.eq.miend) then - write(ndate,16) yrnew, monew, dynew, hrnew, minew -16 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2) - - else if (newlen.eq.hrend) then - write(ndate,13) yrnew, monew, dynew, hrnew -13 format(i4,'-',i2.2,'-',i2.2,'_',i2.2) - - else if (newlen.eq.dyend) then - write(ndate,10) yrnew, monew, dynew -10 format(i4,'-',i2.2,'-',i2.2) - - end if - - else - - if (newlen.gt.frstart) then - write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew - write(hfrc,'(i10)') frnew+1000000000 - ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) - - else if (newlen.eq.scend) then - write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew -119 format(i4,i2.2,i2.2,i2.2,i2.2,i2.2) - - else if (newlen.eq.miend) then - write(ndate,116) yrnew, monew, dynew, hrnew, minew -116 format(i4,i2.2,i2.2,i2.2,i2.2) - - else if (newlen.eq.hrend) then - write(ndate,113) yrnew, monew, dynew, hrnew -113 format(i4,i2.2,i2.2,i2.2) - - else if (newlen.eq.dyend) then - write(ndate,110) yrnew, monew, dynew -110 format(i4,i2.2,i2.2) - - end if - - endif - - if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp - - end subroutine geth_newdate - - subroutine geth_idts (newdate, olddate, idt) - - implicit none - - ! From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'), - ! compute the time difference. - - ! on entry - newdate - the new hdate. - ! olddate - the old hdate. - - ! on exit - idt - the change in time. - ! Units depend on length of date strings. - - character (len=*) , intent(in) :: newdate, olddate - integer , intent(out) :: idt - - - ! Local Variables - - ! yrnew - indicates the year associated with "ndate" - ! yrold - indicates the year associated with "odate" - ! monew - indicates the month associated with "ndate" - ! moold - indicates the month associated with "odate" - ! dynew - indicates the day associated with "ndate" - ! dyold - indicates the day associated with "odate" - ! hrnew - indicates the hour associated with "ndate" - ! hrold - indicates the hour associated with "odate" - ! minew - indicates the minute associated with "ndate" - ! miold - indicates the minute associated with "odate" - ! scnew - indicates the second associated with "ndate" - ! scold - indicates the second associated with "odate" - ! i - loop counter - ! mday - a list assigning the number of days in each month - - ! ndate, odate: local values of newdate and olddate - character(len=24) :: ndate, odate - - integer :: oldlen, newlen - integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew - integer :: yrold, moold, dyold, hrold, miold, scold, frold - integer :: i, newdys, olddys - logical :: npass, opass - integer :: timesign - integer :: ifrc - integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) - logical :: punct - integer :: yrstart, yrend, mostart, moend, dystart, dyend - integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart - integer :: units - - oldlen = len(olddate) - newlen = len(newdate) - if (newlen.ne.oldlen) then -#ifdef HYDRO_D - write(*,'("GETH_IDTS: NEWLEN /= OLDLEN: ", A, 3x, A)') newdate(1:newlen), olddate(1:oldlen) - call hydro_stop("geth_newdate") -#endif - endif - - if (olddate.gt.newdate) then - timesign = -1 - - ifrc = oldlen - oldlen = newlen - newlen = ifrc - - ndate = olddate - odate = newdate - else - timesign = 1 - ndate = newdate - odate = olddate - end if - - ! Break down old hdate into parts - - ! Determine if olddate is punctuated or not - if (odate(5:5) == "-") then - punct = .TRUE. - if (ndate(5:5) /= "-") then -#ifdef HYDRO_D - write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') & - ndate(1:newlen), odate(1:oldlen) - call hydro_stop("geth_idts") -#endif - endif - else - punct = .FALSE. - if (ndate(5:5) == "-") then -#ifdef HYDRO_D - write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') & - ndate(1:newlen), odate(1:oldlen) - call hydro_stop("geth_idts") -#endif - endif - endif - - if (punct) then - yrstart = 1 - yrend = 4 - mostart = 6 - moend = 7 - dystart = 9 - dyend = 10 - hrstart = 12 - hrend = 13 - mistart = 15 - miend = 16 - scstart = 18 - scend = 19 - frstart = 21 - select case (oldlen) - case (10) - ! Days - units = 1 - case (13) - ! Hours - units = 2 - case (16) - ! Minutes - units = 3 - case (19) - ! Seconds - units = 4 - case (21) - ! Tenths - units = 5 - case (22) - ! Hundredths - units = 6 - case (23) - ! Thousandths - units = 7 - case (24) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_idts: odd length: #'//trim(odate)//'#' - call hydro_stop("geth_idts") -#endif - end select - else - - yrstart = 1 - yrend = 4 - mostart = 5 - moend = 6 - dystart = 7 - dyend = 8 - hrstart = 9 - hrend = 10 - mistart = 11 - miend = 12 - scstart = 13 - scend = 14 - frstart = 15 - - select case (oldlen) - case (8) - ! Days - units = 1 - case (10) - ! Hours - units = 2 - case (12) - ! Minutes - units = 3 - case (14) - ! Seconds - units = 4 - case (15) - ! Tenths - units = 5 - case (16) - ! Hundredths - units = 6 - case (17) - ! Thousandths - units = 7 - case (18) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_idts: odd length: #'//trim(odate)//'#' - call hydro_stop("geth_idts") -#endif - end select - endif - - - hrold = 0 - miold = 0 - scold = 0 - frold = 0 - - read(odate(yrstart:yrend), '(i4)') yrold - read(odate(mostart:moend), '(i2)') moold - read(odate(dystart:dyend), '(i2)') dyold - if (units.ge.2) then - read(odate(hrstart:hrend),'(i2)') hrold - if (units.ge.3) then - read(odate(mistart:miend),'(i2)') miold - if (units.ge.4) then - read(odate(scstart:scend),'(i2)') scold - if (units.ge.5) then - read(odate(frstart:oldlen),*) frold - end if - end if - end if - end if - - ! Break down new hdate into parts - - hrnew = 0 - minew = 0 - scnew = 0 - frnew = 0 - - read(ndate(yrstart:yrend), '(i4)') yrnew - read(ndate(mostart:moend), '(i2)') monew - read(ndate(dystart:dyend), '(i2)') dynew - if (units.ge.2) then - read(ndate(hrstart:hrend),'(i2)') hrnew - if (units.ge.3) then - read(ndate(mistart:miend),'(i2)') minew - if (units.ge.4) then - read(ndate(scstart:scend),'(i2)') scnew - if (units.ge.5) then - read(ndate(frstart:newlen),*) frnew - end if - end if - end if - end if - - ! Check that the dates make sense. - - npass = .true. - opass = .true. - - ! Check that the month of NDATE makes sense. - - if ((monew.gt.12).or.(monew.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_IDTS: Month of NDATE = ', monew -#endif - npass = .false. - end if - - ! Check that the month of ODATE makes sense. - - if ((moold.gt.12).or.(moold.lt.1)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Month of ODATE = ', moold -#endif - opass = .false. - end if - - ! Check that the day of NDATE makes sense. - - if (monew.ne.2) then - ! ...... For all months but February - if ((dynew.gt.mday(monew)).or.(dynew.lt.1)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Day of NDATE = ', dynew -#endif - npass = .false. - end if - else if (monew.eq.2) then - ! ...... For February - if ((dynew > nfeb(yrnew)).or.(dynew < 1)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Day of NDATE = ', dynew -#endif - npass = .false. - end if - endif - - ! Check that the day of ODATE makes sense. - - if (moold.ne.2) then - ! ...... For all months but February - if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Day of ODATE = ', dyold -#endif - opass = .false. - end if - else if (moold.eq.2) then - ! ....... For February - if ((dyold > nfeb(yrold)).or.(dyold < 1)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Day of ODATE = ', dyold -#endif - opass = .false. - end if - end if - - ! Check that the hour of NDATE makes sense. - - if ((hrnew.gt.23).or.(hrnew.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Hour of NDATE = ', hrnew -#endif - npass = .false. - end if - - ! Check that the hour of ODATE makes sense. - - if ((hrold.gt.23).or.(hrold.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Hour of ODATE = ', hrold -#endif - opass = .false. - end if - - ! Check that the minute of NDATE makes sense. - - if ((minew.gt.59).or.(minew.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Minute of NDATE = ', minew -#endif - npass = .false. - end if - - ! Check that the minute of ODATE makes sense. - - if ((miold.gt.59).or.(miold.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Minute of ODATE = ', miold -#endif - opass = .false. - end if - - ! Check that the second of NDATE makes sense. - - if ((scnew.gt.59).or.(scnew.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: SECOND of NDATE = ', scnew -#endif - npass = .false. - end if - - ! Check that the second of ODATE makes sense. - - if ((scold.gt.59).or.(scold.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Second of ODATE = ', scold -#endif - opass = .false. - end if - - if (.not. npass) then -#ifdef HYDRO_D - print*, 'Screwy NDATE: ', ndate(1:newlen) - call hydro_stop("geth_idts") -#endif - end if - - if (.not. opass) then -#ifdef HYDRO_D - print*, 'Screwy ODATE: ', odate(1:oldlen) - call hydro_stop("geth_idts") -#endif - end if - - ! Date Checks are completed. Continue. - - ! Compute number of days from 1 January ODATE, 00:00:00 until ndate - ! Compute number of hours from 1 January ODATE, 00:00:00 until ndate - ! Compute number of minutes from 1 January ODATE, 00:00:00 until ndate - - newdys = 0 - do i = yrold, yrnew - 1 - newdys = newdys + 337 + nfeb(i) - end do - - if (monew .gt. 1) then - mday(2) = nfeb(yrnew) - do i = 1, monew - 1 - newdys = newdys + mday(i) - end do - mday(2) = 28 - end if - - newdys = newdys + dynew - 1 - - ! Compute number of hours from 1 January ODATE, 00:00:00 until odate - ! Compute number of minutes from 1 January ODATE, 00:00:00 until odate - - olddys = 0 - - if (moold .gt. 1) then - mday(2) = nfeb(yrold) - do i = 1, moold - 1 - olddys = olddys + mday(i) - end do - mday(2) = 28 - end if - - olddys = olddys + dyold -1 - - ! Determine the time difference - - idt = (newdys - olddys) - if (units.ge.2) then - idt = idt*24 + (hrnew - hrold) - if (units.ge.3) then - idt = idt*60 + (minew - miold) - if (units.ge.4) then - idt = idt*60 + (scnew - scold) - if (units.ge.5) then - ifrc = oldlen-(frstart-1) - ifrc = 10**ifrc - idt = idt * ifrc + (frnew-frold) - endif - endif - endif - endif - - if (timesign .eq. -1) then - idt = idt * timesign - end if - - end subroutine geth_idts - - - integer function nfeb(year) - ! - ! Compute the number of days in February for the given year. - ! - implicit none - integer, intent(in) :: year ! Four-digit year - - nfeb = 28 ! By default, February has 28 days ... - if (mod(year,4).eq.0) then - nfeb = 29 ! But every four years, it has 29 days ... - if (mod(year,100).eq.0) then - nfeb = 28 ! Except every 100 years, when it has 28 days ... - if (mod(year,400).eq.0) then - nfeb = 29 ! Except every 400 years, when it has 29 days ... - if (mod(year,3600).eq.0) then - nfeb = 28 ! Except every 3600 years, when it has 28 days. - endif - endif - endif - endif - end function nfeb - - integer function nmdays(hdate) - ! - ! Compute the number of days in the month of given date hdate. - ! - implicit none - character(len=*), intent(in) :: hdate - - integer :: year, month - integer, dimension(12), parameter :: ndays = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) - - read(hdate(1:7), '(I4,1x,I2)') year, month - - if (month == 2) then - nmdays = nfeb(year) - else - nmdays = ndays(month) - endif - end function nmdays - - function monthabbr_to_mm(mon) result(mm) - implicit none - - character(len=3), intent(in) :: mon - - integer :: mm - - if (mon == "Jan") then - mm = 1 - elseif (mon == "Feb") then - mm = 2 - elseif (mon == "Mar") then - mm = 3 - elseif (mon == "Apr") then - mm = 4 - elseif (mon == "May") then - mm = 5 - elseif (mon == "Jun") then - mm = 6 - elseif (mon == "Jul") then - mm = 7 - elseif (mon == "Aug") then - mm = 8 - elseif (mon == "Sep") then - mm = 9 - elseif (mon == "Oct") then - mm = 10 - elseif (mon == "Nov") then - mm = 11 - elseif (mon == "Dec") then - mm = 12 - else -#ifdef HYDRO_D - write(*, '("Function monthabbr_to_mm: mon = <",A,">")') mon - print*, "Function monthabbr_to_mm: Unrecognized mon" - call hydro_stop("monthabbr_to_mm") -#endif - endif - end function monthabbr_to_mm - - subroutine swap_date_format(indate, outdate) - implicit none - character(len=*), intent(in) :: indate - character(len=*), intent(out) :: outdate - integer :: inlen - - inlen = len(indate) - if (indate(5:5) == "-") then - select case (inlen) - case (10) - ! YYYY-MM-DD - outdate = indate(1:4)//indate(6:7)//indate(9:10) - case (13) - ! YYYY-MM-DD_HH - outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13) - case (16) - ! YYYY-MM-DD_HH:mm - outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16) - case (19) - ! YYYY-MM-DD_HH:mm:ss - outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//& - indate(18:19) - case (21,22,23,24) - ! YYYY-MM-DD_HH:mm:ss.f[f[f[f]]] - outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//& - indate(18:19)//indate(21:inlen) - case default -#ifdef HYDRO_D - write(*,'("Unrecognized length: <", A,">")') indate - call hydro_stop("swap_date_format") -#endif - end select - else - select case (inlen) - case (8) - ! YYYYMMDD - outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8) - case (10) - ! YYYYMMDDHH - outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& - indate(9:10) - case (12) - ! YYYYMMDDHHmm - outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& - indate(9:10)//":"//indate(11:12) - case (14) - ! YYYYMMDDHHmmss - outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& - indate(9:10)//":"//indate(11:12)//":"//indate(13:14) - case (15,16,17,18) - ! YYYYMMDDHHmmssf[f[f[f]]] - outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& - indate(9:10)//":"//indate(11:12)//":"//indate(13:14)//"."//indate(15:inlen) - case default -#ifdef HYDRO_D - write(*,'("Unrecognized length: <", A,">")') indate - call hydro_stop("swap_date_format") -#endif - end select - endif - - end subroutine swap_date_format - - character(len=3) function mm_to_monthabbr(ii) result(mon) - implicit none - integer, intent(in) :: ii - character(len=3), parameter, dimension(12) :: month = (/ & - "Jan", "Feb", "Mar", "Apr", "May", "Jun", & - "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" /) - if (ii > 0 .and. ii < 13 ) then - mon = month(ii) - else -#ifdef HYDRO_D - print*, "mm_to_monthabbr" - call hydro_stop("mm_to_monthabbr") -#endif - endif - end function mm_to_monthabbr - -end module Module_Date_utilities_rt diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/module_lsm_forcing.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/module_lsm_forcing.F.svn-base deleted file mode 100644 index f60b0493..00000000 --- a/wrfv2_fire/hydro/Routing/.svn/text-base/module_lsm_forcing.F.svn-base +++ /dev/null @@ -1,2276 +0,0 @@ -module module_lsm_forcing - -#ifdef MPP_LAND - use module_mpp_land -#endif - use module_HYDRO_io, only: get_2d_netcdf, get_soilcat_netcdf, get2d_int - -implicit none -#include - integer :: i_forcing -character(len=19) out_date - -interface read_hydro_forcing -#ifdef MPP_LAND - module procedure read_hydro_forcing_mpp -#else - module procedure read_hydro_forcing_seq -#endif -end interface - -Contains - - subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) - - implicit none - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - character(len=*), intent(in) :: target_date - real, dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc, lai,fpar - integer tlevel - - character(len=256) :: units - integer :: ierr - integer :: ncid - - tlevel = 1 - - pcp = 0 - pcpc = 0 - - ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) -#endif - call hydro_stop("READFORC_WRF") - endif - - call get_2d_netcdf_ruc("T2", ncid, t, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("Q2", ncid, q, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("U10", ncid, u, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("V10", ncid, v, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("PSFC", ncid, p, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("GLW", ncid, lw, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("SWDOWN", ncid, sw, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("VEGFRA", ncid, fpar, ix, jx,tlevel, .true., ierr) - if(ierr == 0) then - if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar/100. - endif - call get_2d_netcdf_ruc("LAI", ncid, lai, ix, jx,tlevel, .true., ierr) - - ierr = nf_close(ncid) - - -!DJG Add the convective and non-convective rain components (note: conv. comp=0 -!for cloud resolving runs...) -!DJG Note that for WRF these are accumulated values to be adjusted to rates in -!driver... - - pcp=pcp+pcpc ! assumes pcpc=0 for resolved convection... - - end subroutine READFORC_WRF - - subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) - ! Simply return the dimensions of the grid. - implicit none - character(len=*), intent(in) :: geo_static_flnm - integer, intent(out) :: ix, jx, land_cat, soil_cat ! dimensions - - integer :: iret, ncid, dimid - - ! Open the NetCDF file. - iret = nf_open(geo_static_flnm, NF_NOWRITE, ncid) - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_static file: ''", A, "''")') & - trim(geo_static_flnm) -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimid(ncid, "west_east", dimid) - - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: west_east" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimlen(ncid, dimid, ix) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: west_east" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimid(ncid, "south_north", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: south_north" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimlen(ncid, dimid, jx) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: south_north" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimid(ncid, "land_cat", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: land_cat" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimlen(ncid, dimid, land_cat) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: land_cat" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimid(ncid, "soil_cat", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: soil_cat" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimlen(ncid, dimid, soil_cat) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: soil_cat" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_close(ncid) - - end subroutine read_hrldas_hdrinfo - - - - subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp, & - terrain,latitude,longitude,SOLVEG_INITSWC) - implicit none - character(len=*), intent(in) :: geo_static_flnm - integer, intent(in) :: ix, jx, land_cat, soil_cat,SOLVEG_INITSWC - integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp - real, dimension(ix,jx), intent(out) :: terrain, latitude, longitude - - character(len=256) :: units - integer :: ierr,i,j,jj - integer :: ncid,varid - real, dimension(ix,jx) :: xdum - integer, dimension(ix,jx) :: vegtyp_inv, soiltyp_inv,xdum_int - integer flag ! flag = 1 from wrfsi, flag =2 from WPS. - CHARACTER(len=256) :: var_name - - - ! Open the NetCDF file. - ierr = nf_open(geo_static_flnm, NF_NOWRITE, ncid) - - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_static file: ''", A, "''")') trim(geo_static_flnm) -#endif - call hydro_stop("readland_hrldas") - endif - - flag = -99 - ierr = nf_inq_varid(ncid,"XLAT", varid) - flag = 1 - if(ierr .ne. 0) then - ierr = nf_inq_varid(ncid,"XLAT_M", varid) - if(ierr .ne. 0) then -#ifdef HYDRO_D - write(6,*) "XLAT not found from wrfstatic file. " -#endif - call hydro_stop("readland_hrldas") - endif - flag = 2 - endif - - ! Get Latitude (lat) - if(flag .eq. 1) then - call get_2d_netcdf("XLAT", ncid, latitude, units, ix, jx, .TRUE., ierr) - else - call get_2d_netcdf("XLAT_M", ncid, latitude, units, ix, jx, .TRUE., ierr) - endif - - ! Get Longitude (lon) - if(flag .eq. 1) then - call get_2d_netcdf("XLONG", ncid, longitude, units, ix, jx, .TRUE., ierr) - else - call get_2d_netcdf("XLONG_M", ncid, longitude, units, ix, jx, .TRUE., ierr) - endif - - ! Get Terrain (avg) - if(flag .eq. 1) then - call get_2d_netcdf("HGT", ncid, terrain, units, ix, jx, .TRUE., ierr) - else - call get_2d_netcdf("HGT_M", ncid, terrain, units, ix, jx, .TRUE., ierr) - endif - - - if (SOLVEG_INITSWC.eq.0) then -! ! Get Dominant Land Use categories (use) -! call get_landuse_netcdf(ncid, xdum , units, ix, jx, land_cat) -! vegtyp = nint(xdum) - - var_name = "LU_INDEX" - call get2d_int(var_name,xdum_int,ix,jx,& - trim(geo_static_flnm)) - vegtyp = xdum_int - - ! Get Dominant Soil Type categories in the top layer (stl) - call get_soilcat_netcdf(ncid, xdum , units, ix, jx, soil_cat) - soltyp = nint(xdum) - - else if (SOLVEG_INITSWC.eq.1) then - var_name = "VEGTYP" - call get2d_int(var_name,VEGTYP_inv,ix,jx,& - trim(geo_static_flnm)) - - var_name = "SOILTYP" - call get2d_int(var_name,SOILTYP_inv,ix,jx,& - trim(geo_static_flnm)) - do i=1,ix - jj=jx - do j=1,jx - VEGTYP(i,j)=VEGTYP_inv(i,jj) - SOLTYP(i,j)=SOILTYP_inv(i,jj) - jj=jx-j - end do - end do - - endif - - - - ! Close the NetCDF file - ierr = nf_close(ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: READLAND_HRLDAS: NF_CLOSE" -#endif - call hydro_stop("readland_hrldas") - endif - - ! Make sure vegtyp and soltyp are consistent when it comes to water points, - ! by setting soil category to water when vegetation category is water, and - ! vice-versa. - where (vegtyp == 16) soltyp = 14 - where (soltyp == 14) vegtyp = 16 - -!DJG test for deep gw function... -! where (soltyp <> 14) soltyp = 1 - - end subroutine readland_hrldas - - - subroutine get_2d_netcdf_ruc(var_name,ncid,var, & - ix,jx,tlevel,fatal_if_error,ierr) - character(len=*), intent(in) :: var_name - integer,intent(in) :: ncid,ix,jx,tlevel - real, intent(out):: var(ix,jx) - logical, intent(in) :: fatal_if_error - integer dims(4), dim_len(4) - integer ierr,iret - integer varid - integer start(4),count(4) - data count /1,1,1,1/ - data start /1,1,1,1/ - count(1) = ix - count(2) = jx - start(4) = tlevel - iret = nf_inq_varid(ncid, var_name, varid) - - if (iret /= 0) then - if (fatal_IF_ERROR) then -#ifdef HYDRO_D - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf_inq_varid ", trim(var_name) -#endif - call hydro_stop("get_2d_netcdf_ruc") - else - ierr = iret - return - endif - endif - - iret = nf_get_vara_real(ncid, varid, start,count,var) - - return - end subroutine get_2d_netcdf_ruc - - - subroutine get_2d_netcdf_cows(var_name,ncid,var, & - ix,jx,tlevel,fatal_if_error,ierr) - character(len=*), intent(in) :: var_name - integer,intent(in) :: ncid,ix,jx,tlevel - real, intent(out):: var(ix,jx) - logical, intent(in) :: fatal_if_error - integer ierr, iret - integer varid - integer start(4),count(4) - data count /1,1,1,1/ - data start /1,1,1,1/ - count(1) = ix - count(2) = jx - start(4) = tlevel - iret = nf_inq_varid(ncid, var_name, varid) - - if (iret /= 0) then - if (fatal_IF_ERROR) then -#ifdef HYDRO_D - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid" -#endif - call hydro_stop("get_2d_netcdf_cows") - else - ierr = iret - return - endif - endif - iret = nf_get_vara_real(ncid, varid, start,count,var) - - return - end subroutine get_2d_netcdf_cows - - - - - - subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, & - smc, stc, sh2o, cmc, t1, weasd, snodep) - implicit none - character(len=*), intent(in) :: netcdf_flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - integer, intent(in) :: nsoil - character(len=*), intent(in) :: target_date - real, dimension(ix,jx,nsoil), intent(out) :: smc - real, dimension(ix,jx,nsoil), intent(out) :: stc - real, dimension(ix,jx,nsoil), intent(out) :: sh2o - real, dimension(ix,jx), intent(out) :: cmc - real, dimension(ix,jx), intent(out) :: t1 - real, dimension(ix,jx), intent(out) :: weasd - real, dimension(ix,jx), intent(out) :: snodep - - character(len=256) :: units - character(len=8) :: name - integer :: ix_read, jx_read,i,j - - integer :: ierr, ncid, ierr_snodep - integer :: idx - - logical :: found_canwat, found_skintemp, found_weasd, found_stemp, found_smois - - ! Open the NetCDF file. - ierr = nf_open(netcdf_flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READINIT Problem opening netcdf file: ''", A, "''")') & - trim(netcdf_flnm) -#endif - call hydro_stop("readinit_hrldas") - endif - - call get_2d_netcdf("CANWAT", ncid, cmc, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SKINTEMP", ncid, t1, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("WEASD", ncid, weasd, units, ix, jx, .TRUE., ierr) - - if (trim(units) == "m") then - ! No conversion necessary - else if (trim(units) == "mm") then - ! convert WEASD from mm to m - weasd = weasd * 1.E-3 - else -#ifdef HYDRO_D - print*, 'units = "'//trim(units)//'"' - print*, "Unrecognized units on WEASD" -#endif - call hydro_stop("readinit_hrldas") - endif - - call get_2d_netcdf("SNODEP", ncid, snodep, units, ix, jx, .FALSE., ierr_snodep) - call get_2d_netcdf("STEMP_1", ncid, stc(:,:,1), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("STEMP_2", ncid, stc(:,:,2), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("STEMP_3", ncid, stc(:,:,3), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("STEMP_4", ncid, stc(:,:,4), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SMOIS_1", ncid, smc(:,:,1), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SMOIS_2", ncid, smc(:,:,2), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SMOIS_3", ncid, smc(:,:,3), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SMOIS_4", ncid, smc(:,:,4), units, ix, jx, .TRUE., ierr) - - - if (ierr_snodep /= 0) then - ! Quick assumption regarding snow depth. - snodep = weasd * 10. - endif - - -!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... - do i=1,ix - do j=1,jx - if (WEASD(i,j).lt.0.) WEASD(i,j)=0.0 !set lower bound to correct bi-lin interp err... - if (snodep(i,j).lt.0.) snodep(i,j)=0.0 !set lower bound to correct bi-lin interp err... - end do - end do - - - sh2o = smc - - ierr = nf_close(ncid) - end subroutine readinit_hrldas - - - - - subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - character(len=*), intent(in) :: target_date - real, dimension(ix,jx), intent(out) :: t - real, dimension(ix,jx), intent(out) :: q - real, dimension(ix,jx), intent(out) :: u - real, dimension(ix,jx), intent(out) :: v - real, dimension(ix,jx), intent(out) :: p - real, dimension(ix,jx), intent(out) :: lw - real, dimension(ix,jx), intent(out) :: sw - real, dimension(ix,jx), intent(out) :: pcp - real, dimension(ix,jx), intent(inout) :: lai - real, dimension(ix,jx), intent(inout) :: fpar - - character(len=256) :: units - integer :: ierr - integer :: ncid - - ! Open the NetCDF file. - ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) -#endif - call hydro_stop("READFORC_HRLDAS") - endif - - call get_2d_netcdf("T2D", ncid, t, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("Q2D", ncid, q, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("U2D", ncid, u, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("V2D", ncid, v, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("PSFC", ncid, p, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("LWDOWN", ncid, lw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SWDOWN", ncid, sw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("RAINRATE",ncid, pcp, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("VEGFRA", ncid, fpar, units, ix, jx, .FALSE., ierr) - if (ierr == 0) then - if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000) fpar = fpar * 1.E-2 - endif - call get_2d_netcdf("LAI", ncid, lai, units, ix, jx, .FALSE., ierr) - - ierr = nf_close(ncid) - - end subroutine READFORC_HRLDAS - - - - subroutine READFORC_DMIP(flnm,ix,jx,var) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - real, dimension(ix,jx), intent(out) :: var - character(len=13) :: head - integer :: ncols, nrows, cellsize - real :: xllc, yllc, no_data - integer :: i,j - character(len=256) ::junk - - open (77,file=trim(flnm),form="formatted",status="old") - -! read(77,732) head,ncols -! read(77,732) head,nrows -!732 FORMAT(A13,I4) -! read(77,733) head,xllc -! read(77,733) head,yllc -!733 FORMAT(A13,F16.9) -! read(77,732) head,cellsize -! read(77,732) head,no_data - - read(77,*) junk - read(77,*) junk - read(77,*) junk - read(77,*) junk - read(77,*) junk - read(77,*) junk - - do j=jx,1,-1 - read(77,*) (var(I,J),I=1,ix) - end do - close(77) - - end subroutine READFORC_DMIP - - - - subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - integer, intent(out) :: ierr_flg - integer :: it,jew,zsn - real, dimension(ix,jx), intent(out) :: pcp - - character(len=256) :: units - integer :: ierr,i,j,i2,j2,varid - integer :: ncid,mmflag - real, dimension(ix,jx) :: temp - - mmflag = 0 ! flag for units spec. (0=mm, 1=mm/s) - - -!open NetCDF file... - ierr_flg = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr_flg /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_MDV Problem opening netcdf file: ''",A,"''")') & - trim(flnm) -#endif - return - end if - - ierr = nf_inq_varid(ncid, "precip", varid) - if(ierr /= 0) ierr_flg = ierr - if (ierr /= 0) then - ierr = nf_inq_varid(ncid, "precip_rate", varid) !recheck variable name... - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & - trim(flnm) -#endif - end if - ierr_flg = ierr - mmflag = 1 - end if - ierr = nf_get_var_real(ncid, varid, pcp) - ierr = nf_close(ncid) - - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm) -#endif - end if - - end subroutine READFORC_MDV - - - - subroutine READFORC_NAMPCP(flnm,ix,jx,pcp,k,product) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - integer, intent(in) :: k - character(len=*), intent(in) :: product - integer :: it,jew,zsn - parameter(it = 496,jew = 449, zsn = 499) ! domain 1 -! parameter(it = 496,jew = 74, zsn = 109) ! domain 2 - real, dimension(it,jew,zsn) :: buf - real, dimension(ix,jx), intent(out) :: pcp - - character(len=256) :: units - integer :: ierr,i,j,i2,j2,varid - integer :: ncid - real, dimension(ix,jx) :: temp - -! varname = trim(product) - -!open NetCDF file... - if (k.eq.1.) then - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_NAMPCP1 Problem opening netcdf file: ''",A, "''")') & - trim(flnm) -#endif - call hydro_stop("READFORC_NAMPCP") - end if - - ierr = nf_inq_varid(ncid, trim(product), varid) - ierr = nf_get_var_real(ncid, varid, buf) - ierr = nf_close(ncid) - - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_NAMPCP2 Problem reading netcdf file: ''", A,"''")') & - trim(flnm) -#endif - call hydro_stop("READFORC_NAMPCP") - end if - endif -#ifdef HYDRO_D - print *, "Data read in...",it,ix,jx,k -#endif - -! Extract single time slice from dataset... - - do i=1,ix - do j=1,jx - pcp(i,j) = buf(k,i,j) - end do - end do - -! call get_2d_netcdf_ruc("trmm",ncid, pcp, jx, ix,k, .true., ierr) - - end subroutine READFORC_NAMPCP - - - - - subroutine READFORC_COWS(flnm,ix,jx,target_date, t,q,u,p,lw,sw,pcp,tlevel) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - character(len=*), intent(in) :: target_date - real, dimension(ix,jx), intent(out) :: t - real, dimension(ix,jx), intent(out) :: q - real, dimension(ix,jx), intent(out) :: u - real, dimension(ix,jx) :: v - real, dimension(ix,jx), intent(out) :: p - real, dimension(ix,jx), intent(out) :: lw - real, dimension(ix,jx), intent(out) :: sw - real, dimension(ix,jx), intent(out) :: pcp - integer tlevel - - character(len=256) :: units - integer :: ierr - integer :: ncid - - ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_COWS Problem opening netcdf file: ''", A, "''")') trim(flnm) -#endif - call hydro_stop("READFORC_COWS") - endif - - call get_2d_netcdf_cows("TA2", ncid, t, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("QV2", ncid, q, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("WSPD10", ncid, u, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("PRES", ncid, p, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("GLW", ncid, lw, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("RSD", ncid, sw, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("RAIN", ncid, pcp, ix, jx,tlevel, .TRUE., ierr) -!yw call get_2d_netcdf_cows("V2D", ncid, v, ix, jx,tlevel, .TRUE., ierr) - - ierr = nf_close(ncid) - - end subroutine READFORC_COWS - - - - - subroutine READFORC_RUC(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) - - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - character(len=*), intent(in) :: target_date - real, dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc - integer tlevel - - character(len=256) :: units - integer :: ierr - integer :: ncid - - tlevel = 1 - - ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_RUC Problem opening netcdf file: ''", A, "''")') trim(flnm) -#endif - call hydro_stop("READFORC_RUC") - endif - - call get_2d_netcdf_ruc("T2", ncid, t, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("Q2", ncid, q, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("U10", ncid, u, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("V10", ncid, v, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("PSFC", ncid, p, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("GLW", ncid, lw, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("SWDOWN", ncid, sw, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) - - ierr = nf_close(ncid) - - -!DJG Add the convective and non-convective rain components (note: conv. comp=0 -!for cloud resolving runs...) -!DJG Note that for RUC these are accumulated values to be adjusted to rates in -!driver... - - pcp=pcp+pcpc ! assumes pcpc=0 for resolved convection... - - end subroutine READFORC_RUC - - - - - subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - real, dimension(ix,jx), intent(out) :: weasd - real, dimension(ix,jx), intent(out) :: snodep - real, dimension(ix,jx) :: tmp - - character(len=256) :: units - integer :: ierr - integer :: ncid,i,j - - ! Open the NetCDF file. - - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm) -#endif - call hydro_stop("READSNOW_FORC") - endif - - call get_2d_netcdf("WEASD", ncid, tmp, units, ix, jx, .FALSE., ierr) - if (ierr /= 0) then - call get_2d_netcdf("SNOW", ncid, tmp, units, ix, jx, .FALSE., ierr) - if (ierr == 0) then - units = "mm" - print *, "read WEASD from wrfoutput ...... " - weasd = tmp * 1.E-3 - endif - else - weasd = tmp - if (trim(units) == "m") then - ! No conversion necessary - else if (trim(units) == "mm") then - ! convert WEASD from mm to m - weasd = weasd * 1.E-3 - endif - endif - - if (ierr /= 0) then -#ifdef HYDRO_D - print *, "!!!!! NO WEASD present in input file...initialize to 0." -#endif - endif - - - call get_2d_netcdf("SNODEP", ncid, tmp, units, ix, jx, .FALSE., ierr) - if (ierr /= 0) then - ! Quick assumption regarding snow depth. - call get_2d_netcdf("SNOWH", ncid, tmp, units, ix, jx, .FALSE., ierr) - if(ierr .eq. 0) then - print *, "read snow depth from wrfoutput ... " - snodep = tmp - endif - else - snodep = tmp - endif - - if (ierr /= 0) then - ! Quick assumption regarding snow depth. -!yw snodep = weasd * 10. - where(snodep .lt. weasd) snodep = weasd*10 !set lower bound to correct bi-lin interp err... - endif - -!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... - where(snodep .lt. 0) snodep = 0 - where(weasd .lt. 0) weasd = 0 - -!yw do i=1,ix -!yw do j=1,jx -!yw if (WEASD(i,j).lt.0.) WEASD(i,j)=0.0 !set lower bound to correct bi-lin interp err... -!yw if (snodep(i,j).lt.0.) snodep(i,j)=0.0 !set lower bound to correct bi-lin interp err... -!yw end do -!yw end do - - ierr = nf_close(ncid) - - end subroutine READSNOW_FORC - - subroutine get2d_hrldas(inflnm,ix,jx,nsoil,smc,stc,sh2ox,cmc,t1,weasd,snodep) - implicit none - integer :: iret,varid,ncid,ix,jx,nsoil,ierr - real,dimension(ix,jx):: weasd,snodep,cmc,t1 - real,dimension(ix,jx,nsoil):: smc,stc,sh2ox - character(len=*), intent(in) :: inflnm - character(len=256):: units - iret = nf_open(trim(inflnm), NF_NOWRITE, ncid) - if(iret .ne. 0 )then -#ifdef HYDRO_D - write(6,*) "Error: failed to open file :",trim(inflnm) -#endif - call hydro_stop("get2d_hrldas") - endif - - call get2d_hrldas_real("CMC", ncid, cmc, ix, jx) - call get2d_hrldas_real("TSKIN", ncid, t1, ix, jx) - call get2d_hrldas_real("SWE", ncid, weasd, ix, jx) - call get2d_hrldas_real("SNODEP", ncid, snodep, ix, jx) - - call get2d_hrldas_real("SOIL_T_1", ncid, stc(:,:,1), ix, jx) - call get2d_hrldas_real("SOIL_T_2", ncid, stc(:,:,2), ix, jx) - call get2d_hrldas_real("SOIL_T_3", ncid, stc(:,:,3), ix, jx) - call get2d_hrldas_real("SOIL_T_4", ncid, stc(:,:,4), ix, jx) - call get2d_hrldas_real("SOIL_T_5", ncid, stc(:,:,5), ix, jx) - call get2d_hrldas_real("SOIL_T_6", ncid, stc(:,:,6), ix, jx) - call get2d_hrldas_real("SOIL_T_7", ncid, stc(:,:,7), ix, jx) - call get2d_hrldas_real("SOIL_T_8", ncid, stc(:,:,8), ix, jx) - - call get2d_hrldas_real("SOIL_M_1", ncid, SMC(:,:,1), ix, jx) - call get2d_hrldas_real("SOIL_M_2", ncid, SMC(:,:,2), ix, jx) - call get2d_hrldas_real("SOIL_M_3", ncid, SMC(:,:,3), ix, jx) - call get2d_hrldas_real("SOIL_M_4", ncid, SMC(:,:,4), ix, jx) - call get2d_hrldas_real("SOIL_M_5", ncid, SMC(:,:,5), ix, jx) - call get2d_hrldas_real("SOIL_M_6", ncid, SMC(:,:,6), ix, jx) - call get2d_hrldas_real("SOIL_M_7", ncid, SMC(:,:,7), ix, jx) - call get2d_hrldas_real("SOIL_M_8", ncid, SMC(:,:,8), ix, jx) - - call get2d_hrldas_real("SOIL_W_1", ncid, SH2OX(:,:,1), ix, jx) - call get2d_hrldas_real("SOIL_W_2", ncid, SH2OX(:,:,2), ix, jx) - call get2d_hrldas_real("SOIL_W_3", ncid, SH2OX(:,:,3), ix, jx) - call get2d_hrldas_real("SOIL_W_4", ncid, SH2OX(:,:,4), ix, jx) - call get2d_hrldas_real("SOIL_W_5", ncid, SH2OX(:,:,5), ix, jx) - call get2d_hrldas_real("SOIL_W_6", ncid, SH2OX(:,:,6), ix, jx) - call get2d_hrldas_real("SOIL_W_7", ncid, SH2OX(:,:,7), ix, jx) - call get2d_hrldas_real("SOIL_W_8", ncid, SH2OX(:,:,8), ix, jx) - - iret = nf_close(ncid) - return - end subroutine get2d_hrldas - - subroutine get2d_hrldas_real(var_name,ncid,out_buff,ix,jx) - implicit none - integer ::iret,varid,ncid,ix,jx - real out_buff(ix,jx) - character(len=*), intent(in) :: var_name - iret = nf_inq_varid(ncid,trim(var_name), varid) - iret = nf_get_var_real(ncid, varid, out_buff) - return - end subroutine get2d_hrldas_real - - subroutine read_stage4(flnm,IX,JX,pcp) - integer IX,JX,ierr,ncid,i,j - real pcp(IX,JX),buf(ix,jx) - character(len=*), intent(in) :: flnm - character(len=256) :: units - - ierr = nf_open(flnm, NF_NOWRITE, ncid) - - if(ierr .ne. 0) then - call hydro_stop("read_stage4") - endif - - call get_2d_netcdf("RAINRATE",ncid, buf, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) - do j = 1, jx - do i = 1, ix - if(buf(i,j) .lt. 0) then - buf(i,j) = pcp(i,j) - end if - end do - end do - pcp = buf - return - END subroutine read_stage4 - - - - - subroutine read_hydro_forcing_seq( & - indir,olddate,hgrid, & - ix,jx,forc_typ,snow_assim, & - T2,q2x,u,v,pres,xlong,short,prcp1,& - lai,fpar,snodep,dt,k,prcp_old) -! This subrouting is going to read different forcing. - implicit none - ! in variable - character(len=*) :: olddate,hgrid,indir - character(len=256) :: filename - integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop - real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& - prcpnew,weasd,snodep,prcp0,prcp2,prcp_old - real :: dt, wrf_dt - ! tmp variable - character(len=256) :: inflnm, inflnm2, product - integer :: i,j,mmflag,ierr_flg - real,dimension(ix,jx):: lai,fpar - character(len=4) nwxst_t - logical :: fexist - - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - ".LDASIN_DOMAIN"//hgrid - -!!!DJG... Call READFORC_(variable) Subroutine for forcing data... -!!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!) - if(FORC_TYP.eq.1) then -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - ".LDASIN_DOMAIN"//hgrid - - inquire (file=trim(inflnm), exist=fexist) - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no forcing data found", inflnm -#endif - call hydro_stop("read_hydro_forcing_seq") - endif - - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) - end if - - - - -!!!DJG HRLDAS Forcing with minute format filename (NOTE: precip must be in mm/s!!!) - if(FORC_TYP.eq.2) then -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".LDASIN_DOMAIN"//hgrid - inquire (file=trim(inflnm), exist=fexist) - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no forcing data found", inflnm -#endif - call hydro_stop("read_hydro_forcing_seq") - endif - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) - end if - - - - - -!!!DJG WRF Output File Direct Ingest Forcing... - if(FORC_TYP.eq.3) then -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - "wrfout_d0"//hgrid//"_"//& - olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//& - "_"//olddate(12:13)//":00:00" - - inquire (file=trim(inflnm), exist=fexist) - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no forcing data found", inflnm -#endif - call hydro_stop("read_hydro_forcing_seq") - endif - - do i_forcing = 1, int(24*3600/dt) - wrf_dt = i_forcing*dt - call geth_newdate(out_date,olddate,nint(wrf_dt)) - inflnm2 = trim(indir)//"/"//& - "wrfout_d0"//hgrid//"_"//& - out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& - "_"//out_date(12:13)//":00:00" - inquire (file=trim(inflnm2), exist=fexist) - if (fexist ) goto 991 - end do -991 continue - -#ifdef HYDRO_D - if(.not. fexist) then - write(6,*) "Error: could not find file ",trim(inflnm2) - call hydro_stop("read_hydro_forcing_seq") - endif - print*, "read WRF forcing data: ", trim(inflnm) - print*, "read WRF forcing data: ", trim(inflnm2) -#endif - CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCPnew,lai,fpar) - CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,prcp0,lai,fpar) - PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) - - end if - - - - - -!!!DJG CONSTant, idealized forcing... - if(FORC_TYP.eq.4) then -! Impose a fixed diurnal cycle... -! assumes model timestep is 1 hr -! assumes K=1 is 12z (Ks or ~ sunrise) -! First Precip... -! IF (K.GE.1 .and. K.LE.2) THEN - IF (K.EQ.1) THEN - PRCP1 =25.4/3600.0 !units mm/s (Simulates 1"/hr for first time step...) -! PRCP1 =0./3600.0 !units mm/s (Simulates 1"/hr for first time step...) - ELSEIF (K.GT.1) THEN -! PRCP1 =0./3600.0 !units mm/s -! ELSE - PRCP1 = 0. - END IF -! PRCP1 = 0. -! PRCP1 =10./3600.0 !units mm/s -! Other Met. Vars... - T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - Q2X = 0.01 - U = 1.0 - V = 1.0 - PRES = 100000.0 - XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - end if - - - - - -!!!DJG Idealized Met. w/ Specified Precip. Forcing Data...(Note: input precip units here are in 'mm/hr') -! This option uses hard-wired met forcing EXCEPT precipitation which is read in -! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' -! - if(FORC_TYP.eq.5) then -! Standard Met. Vars... - T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - Q2X = 0.01 - U = 1.0 - V = 1.0 - PRES = 100000.0 - XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - -!Get specified precip.... -!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! -! product = "trmm" -! inflnm = trim(indir)//"/"//"sat_domain1.nc" -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".PRECIP_FORCING.nc" - inquire (file=trim(inflnm), exist=fexist) - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no specified precipitation data found", inflnm -#endif - call hydro_stop("read_hydro_forcing_seq") - endif - - PRCP1 = 0. - PRCP_old = PRCP1 - -#ifdef HYDRO_D - print *, "Opening supplemental precipitation forcing file...",inflnm -#endif - CALL READFORC_MDV(inflnm,IX,JX, & - PRCP2,mmflag,ierr_flg) - -!If radar or spec. data is ok use if not, skip to original NARR data... - IF (ierr_flg.eq.0) then ! use spec. precip -!Convert units if necessary - IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... - PRCP1=PRCP2/DT !convert from mm to mm/s -#ifdef HYDRO_D - print*, "Supplemental pcp is accumulated pcp/dt. " -#endif - else - PRCP1=PRCP2 !assumes PRCP2 is in mm/s -#ifdef HYDRO_D - print*, "Supplemental pcp is rate. " -#endif - END IF ! Endif mmflag - ELSE ! either stop or default to original forcing data... -#ifdef HYDRO_D - print *,"Current RADAR precip data not found !!! Using previous available file..." -#endif - PRCP1 = PRCP_old - END IF ! Endif ierr_flg - -! Loop through data to screen for plausible values - do i=1,ix - do j=1,jx - if (PRCP1(i,j).lt.0.) PRCP1(i,j)= PRCP_old(i,j) - if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889 !set max pcp intens = 500 mm/h - end do - end do - - end if - - - - - -!!!DJG HRLDAS Forcing with hourly format filename with specified precipitation forcing... -! This option uses HRLDAS-formatted met forcing EXCEPT precipitation which is read in -! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' - - if(FORC_TYP.eq.6) then - -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - ".LDASIN_DOMAIN"//hgrid - - inquire (file=trim(inflnm), exist=fexist) - - if ( .not. fexist ) then - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".LDASIN_DOMAIN"//hgrid - inquire (file=trim(inflnm), exist=fexist) - endif - - - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no ATM forcing data found at this time", inflnm -#endif - else -#ifdef HYDRO_D - print*, "reading forcing data at this time", inflnm -#endif - - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) - PRCP_old = PRCP1 ! This assigns new precip to last precip as a fallback for missing data... - endif - - -!Get specified precip.... -!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".PRECIP_FORCING.nc" - inquire (file=trim(inflnm), exist=fexist) -#ifdef HYDRO_D - if(fexist) then - print*, "using specified pcp forcing: ",trim(inflnm) - else - print*, "no specified pcp forcing: ",trim(inflnm) - endif -#endif - if ( .not. fexist ) then - prcp1 = PRCP_old ! for missing pcp data use analysis/model input - else - CALL READFORC_MDV(inflnm,IX,JX, & - PRCP2,mmflag,ierr_flg) -!If radar or spec. data is ok use if not, skip to original NARR data... - if(ierr_flg .ne. 0) then -#ifdef HYDRO_D - print*, "Warning: pcp reading problem: ", trim(inflnm) -#endif - PRCP1=PRCP_old - else - PRCP1=PRCP2 !assumes PRCP2 is in mm/s - IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... - PRCP1=PRCP2/DT !convert from mm to mm/s - END IF ! Endif mmflag -#ifdef HYDRO_D - print*, "replace pcp successfully! ",trim(inflnm) -#endif - endif - endif - - -! Loop through data to screen for plausible values - where(PRCP1 .lt. 0) PRCP1=PRCP_old - where(PRCP1 .gt. 10 ) PRCP1= PRCP_old - do i=1,ix - do j=1,jx - if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0 - if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889 !set max pcp intens = 500 mm/h - end do - end do -! write(80,*) prcp1 -! call hydro_stop("9999") - - end if - - -!!!! FORC_TYP 7: uses WRF forcing data plus additional pcp forcing. - - if(FORC_TYP.eq.7) then - -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - "wrfout_d0"//hgrid//"_"//& - olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//& - "_"//olddate(12:13)//":00:00" - - inquire (file=trim(inflnm), exist=fexist) - - - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no forcing data found", inflnm -#endif - else - do i_forcing = 1, int(24*3600/dt) - wrf_dt = i_forcing*dt - call geth_newdate(out_date,olddate,nint(wrf_dt)) - inflnm2 = trim(indir)//"/"//& - "wrfout_d0"//hgrid//"_"//& - out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& - "_"//out_date(12:13)//":00:00" - inquire (file=trim(inflnm2), exist=fexist) - if (fexist ) goto 992 - end do -992 continue - -#ifdef HYDRO_D - print*, "read WRF forcing data: ", trim(inflnm) - print*, "read WRF forcing data: ", trim(inflnm2) -#endif - CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCPnew,lai,fpar) - CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,prcp0,lai,fpar) - PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) - PRCP_old = PRCP1 - endif - -!Get specified precip.... -!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".PRECIP_FORCING.nc" - inquire (file=trim(inflnm), exist=fexist) -#ifdef HYDRO_D - if(fexist) then - print*, "using specified pcp forcing: ",trim(inflnm) - else - print*, "no specified pcp forcing: ",trim(inflnm) - endif -#endif - if ( .not. fexist ) then - prcp1 = PRCP_old ! for missing pcp data use analysis/model input - else - CALL READFORC_MDV(inflnm,IX,JX, & - PRCP2,mmflag,ierr_flg) -!If radar or spec. data is ok use if not, skip to original NARR data... - if(ierr_flg .ne. 0) then -#ifdef HYDRO_D - print*, "Warning: pcp reading problem: ", trim(inflnm) -#endif - PRCP1=PRCP_old - else - PRCP1=PRCP2 !assumes PRCP2 is in mm/s - IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... - write(6,*) "using supplemental pcp time interval ", DT - PRCP1=PRCP2/DT !convert from mm to mm/s - else - write(6,*) "using supplemental pcp rates " - END IF ! Endif mmflag -#ifdef HYDRO_D - print*, "replace pcp successfully! ",trim(inflnm) -#endif - endif - endif - - -! Loop through data to screen for plausible values - where(PRCP1 .lt. 0) PRCP1=PRCP_old - where(PRCP1 .gt. 10 ) PRCP1= PRCP_old ! set maximum to be 500 mm/h - where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h - end if - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!The other forcing data types below here are obsolete and left for reference... -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!!!DJG HRLDAS Single Input with Multiple Input Times File Forcing... -! if(FORC_TYP.eq.6) then -!!Create forcing data filename... -! if (len_trim(range) == 0) then -! inflnm = trim(indir)//"/"//& -! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& -! olddate(15:16)//".LDASIN_DOMAIN"//hgrid//"_multiple" -!! "MET_LIS_CRO_2D_SANTEE_LU_1KM."//& -!! ".156hrfcst.radar" -! else -! endif -! CALL READFORC_HRLDAS_mult(inflnm,IX,JX,OLDDATE,T2,Q2X,U, & -! PRES,XLONG,SHORT,PRCP1,K) -! -!! IF (K.GT.0.AND.K.LT.10) THEN -!! PRCP1 = 10.0/3600.0 ! units mm/s -!! PRCP1 = 0.254/3600.0 -!! ELSE -!! PRCP1 = 0. -!! END IF -! endif - - - -!!!!!DJG NARR Met. w/ NARR Precip. Forcing Data... -!! Assumes standard 3-hrly NARR data has been resampled to NDHMS grid... -!! Assumes one 3hrly time-step per forcing data file -!! Input precip units here are in 'mm' accumulated over 3 hrs... -! if(FORC_TYP.eq.7) then !NARR Met. w/ NARR Precip. -!!!Create forcing data filename... -! if (len_trim(range) == 0) then -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid -! else -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) -! endif -! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & -! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) -! PRCP1=PRCP1/(3.0*3600.0) ! convert from 3hr accum to mm/s which is what NDHMS expects -! end if !NARR Met. w/ NARR Precip. - - - - - - -!!!!DJG NARR Met. w/ Specified Precip. Forcing Data... -! if(FORC_TYP.eq.8) then !NARR Met. w/ Specified Precip. -! -!!Check to make sure if Noah time step is 3 hrs as is NARR... -! -! PRCP_old = PRCP1 -! -! if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then !if/then 3 hr check -!!!Create forcing data filename... -! if (len_trim(range) == 0) then -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid -!! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& -!! ".48hrfcst.ncf" -! else -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) -! endif -! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & -! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) -!! PRCP1=PRCP1/(3.0*3600.0) !NARR 3hrly precip product in mm -! PRCP1=PRCP1 !NAM model data in mm/s -! end if !3 hr check -! -! -!!Get spec. precip.... -!! NAM Remote sensing... -!!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! -!! product = "trmm" -!! inflnm = trim(indir)//"/"//"sat_domain1.nc" -!!! inflnm = trim(indir)//"/"//"sat_domain2.nc" -!! PRCP1 = 0. -!! CALL READFORC_NAMPCP(inflnm,IX,JX, & -!! PRCP2,K,product) -!! ierr_flg = 0 -!! mmflag = 0 -!!!Convert pcp grid to units of mm/s... -!! PRCP1=PRCP1/(3.0*3600.0) !3hrly precip product -! -!!Read from filelist (NAME HE...,others)... -!! if (K.eq.1) then -!! open(unit=93,file="filelist.txt",form="formatted",status="old") -!! end if -!! read (93,*) filename -!! inflnm = trim(indir)//"/"//trim(filename) -!! -!! -!!Front Range MDV Radar... -! -!! inflnm = "/ptmp/weiyu/rt_2008/radar_obs/"//& -!! inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//& -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -!! olddate(15:16)//"_radar.nc" -!! olddate(15:16)//"_chill.nc" -! -!! inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/Big_Thomp_04/"//& -!! inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//& -!! inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//& -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -!! olddate(15:16)//"00_Pcp60min.nc" -!! olddate(15:16)//"00_Pcp30min.nc" -!! olddate(15:16)//"00_30min.nc" -! olddate(15:16)//"00_Pcp5min.nc" -!! olddate(15:16)//"_chill.nc" -! -!! inflnm = "/d2/hydrolab/HRLDAS/forcing/COWS/"//& -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& -!! olddate(15:16)//"00_Pcp5min.nc" -!! olddate(15:16)//"00_5.nc" -! -!! inflnm = "" ! use this for NAM frxst runs with 30 min time-step -!! -! -! -!! if (K.le.6) then ! use for 30min nowcast... -!! if (K.eq.1) then -!! open(unit=94,file="start_file.txt",form="formatted",status="replace") -!!! inflnm2 = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//& -!! inflnm2 = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/"//& -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& -!! olddate(15:16)//"00_" -!! close(94) -!! nwxst_t = "5"! calc minutes from timestep and convert to char... -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! if (K.eq.2) then -!! nwxst_t = "10" ! calc minutes from timestep and convert to char... -!! open(unit=94,file="start_file.txt",form="formatted",status="old") -!! read (94,*) inflnm2 -!! close(94) -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! if (K.eq.3) then -!! nwxst_t = "15" ! calc minutes from timestep and convert to char... -!! open(unit=94,file="start_file.txt",form="formatted",status="old") -!! read (94,*) inflnm -!! close(94) -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! if (K.eq.4) then -!! nwxst_t = "20" ! calc minutes from timestep and convert to char... -!! open(unit=94,file="start_file.txt",form="formatted",status="old") -!! read (94,*) inflnm -!! close(94) -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! if (K.eq.5) then -!! nwxst_t = "25" ! calc minutes from timestep and convert to char... -!! open(unit=94,file="start_file.txt",form="formatted",status="old") -!! read (94,*) inflnm -!! close(94) -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! if (K.eq.6) then -!! nwxst_t = "30" ! calc minutes from timestep and convert to char... -!! open(unit=94,file="start_file.txt",form="formatted",status="old") -!! read (94,*) inflnm -!! close(94) -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! else -!! inflnm = "" ! use this for NAM frxst runs with 30 min time-step -!! end if -! -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& -!! olddate(15:16)//"00_Pcp30minMerge.nc" -! -! CALL READFORC_MDV(inflnm,IX,JX, & -! PRCP2,mmflag,ierr_flg) -! -!!If radar or spec. data is ok use if not, skip to original NARR data... -! IF (ierr_flg.eq.0) then ! use spec. precip -! PRCP1=PRCP2 !assumes PRCP2 is in mm/s -!!Convert units if necessary -! IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... -! PRCP1=PRCP2/DT !convert from mm to mm/s -! END IF ! Endif mmflag -! ELSE ! either stop or default to original forcing data... -! PRCP1 = PRCP_old -! END IF ! Endif ierr_flg -! -!! Loop through data to screen for plausible values -! do i=1,ix -! do j=1,jx -! if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0 -! if (PRCP1(i,j).gt.0.0555) PRCP1(i,j)=0.0555 !set max pcp intens = 200 mm/h -!! PRCP1(i,j) = 0. -!! PRCP1(i,j) = 0.02 !override w/ const. precip for gw testing only... -! end do -! end do -! -!! if (K.eq.1) then ! quick dump for site specific precip... -! open(unit=94,file="Christman_accumpcp.txt",form="formatted",status="new") -! end if -! -! -! end if !NARR Met. w/ Specified Precip. - - - - - -!!!!DJG NLDAS Met. w/ NLDAS Precip. Forcing Data... -!! Assumes standard hrly NLDAS data has been resampled to NDHMS grid... -!! Assumes one 1-hrly time-step per forcing data file -!! Input precip units here are in 'mm' accumulated over 1 hr... -! if(FORC_TYP.eq.9) then !NLDAS Met. w/ NLDAS Precip. -!!!Create forcing data filename... -! if (len_trim(range) == 0) then -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -!!Use this for minute forcing... olddate(15:16)//".LDASIN_DOMAIN"//hgrid -! ".LDASIN_DOMAIN"//hgrid -! else -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) -! endif -! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & -! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) -! PRCP1=PRCP1/(1.0*3600.0) ! convert hourly NLDAS hourly accum pcp to mm/s which is what NDHMS expects -! end if !NLDAS Met. w/ NLDAS Precip. - - - - - -!!!!DJG NARR Met. w/ DMIP Precip. & Temp. Forcing Data... -! if(FORC_TYP.eq.10) then ! If/Then for DMIP forcing data... -!!Check to make sure if Noah time step is 3 hrs as is NARR... -! -! if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then !if/then 3 hr check -!!!Create forcing data filename... -! if (len_trim(range) == 0) then -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid -!! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& -!! ".48hrfcst.ncf" -! else -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) -! endif -! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & -! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) -! PRCP1=PRCP1/(3.0*3600.0) ! convert to mm/s which is what HRLDAS expects -! end if !3 hr check -! -!!Get DMIP Precip... -!! inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/PRECIP_HRAP/precip_finished"//"/"//& -! inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/PRECIP_HRAP"//"/"//& -! "proj.xmrg"//& -! olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//& -! "z.asc" -! PRCP1 = 0. -! CALL READFORC_DMIP(inflnm,IX,JX,PRCP1) -! PRCP1 = PRCP1 / 100.0 ! Convert from native hundreths of mm to mm -!! IF (K.LT.34) THEN -!! PRCP1 = 5.0/3600.0 ! units mm/s -!!! ELSE -!!! PRCP1 = 0. -!! END IF -! -!!Get DMIP Temp... -!! inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/TEMP_HRAP/tair_finished"//"/"//& -! inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/TEMP_HRAP"//"/"//& -! "proj.tair"//& -! olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//& -! "z.asc" -! CALL READFORC_DMIP(inflnm,IX,JX,T2) -! T2 = (5./9.)*(T2-32.0) + 273.15 !Convert from deg F to deg K -! -! end if !End if for DMIP forcing data... -! -! -! -!! : add reading forcing precipitation data -!! ywinflnm = "/ptmp/weiyu/hrldas/v2/st4"//"/"//& -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -!! ".LDASIN_DOMAIN2" -!! call read_stage4(ywinflnm,IX,JX,PRCP1) -!!end yw -! -! -!!!!DJG Check for snow data assimilation... - - if (SNOW_ASSIM .eq. 1) then - -! Every 24 hours, update the snow field from analyses. - if(forc_typ .ne. 3 .or. forc_typ .ne. 6) then - if ( OLDDATE(12:13) == "00") then - CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP) - endif - else - CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP) - endif - - end if - - - end subroutine read_hydro_forcing_seq - - -#ifdef MPP_LAND - subroutine mpp_readland_hrldas(geo_static_flnm,& - ix,jx,land_cat,soil_cat,& - vegtyp,soltyp,terrain,latitude,longitude,& - global_nx,global_ny,SOLVEG_INITSWC) - implicit none - character(len=*), intent(in) :: geo_static_flnm - integer, intent(in) :: ix, jx, land_cat, soil_cat, & - global_nx,global_ny,SOLVEG_INITSWC - integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp - real, dimension(ix,jx), intent(out) :: terrain, latitude, longitude - real, dimension(global_nx,global_ny) ::g_terrain, g_latitude, g_longitude - integer, dimension(global_nx,global_ny) :: g_vegtyp, g_soltyp - - character(len=256) :: units - integer :: ierr - integer :: ncid,varid - real, dimension(ix,jx) :: xdum - integer flag ! flag = 1 from wrfsi, flag =2 from WPS. - if(my_id.eq.IO_id) then - CALL READLAND_HRLDAS(geo_static_flnm,global_nx, & - global_ny,LAND_CAT,SOIL_CAT, & - g_VEGTYP,g_SOLTYP,g_TERRAIN,g_LATITUDE,g_LONGITUDE, SOLVEG_INITSWC) - end if - ! distribute the data to computation node. - call mpp_land_bcast_int1(LAND_CAT) - call mpp_land_bcast_int1(SOIL_CAT) - call decompose_data_int(g_VEGTYP,VEGTYP) - call decompose_data_int(g_SOLTYP,SOLTYP) - call decompose_data_real(g_TERRAIN,TERRAIN) - call decompose_data_real(g_LATITUDE,LATITUDE) - call decompose_data_real(g_LONGITUDE,LONGITUDE) - return - end subroutine mpp_readland_hrldas - - - subroutine MPP_READSNOW_FORC(flnm,ix,jx,OLDDATE,weasd,snodep,& - global_nX, global_ny) - implicit none - - character(len=*), intent(in) :: flnm,OLDDATE - integer, intent(in) :: ix, global_nx,global_ny - integer, intent(in) :: jx - real, dimension(ix,jx), intent(out) :: weasd - real, dimension(ix,jx), intent(out) :: snodep - - real,dimension(global_nX, global_ny):: g_weasd, g_snodep - - character(len=256) :: units - integer :: ierr - integer :: ncid,i,j - - if(my_id .eq. IO_id) then - CALL READSNOW_FORC(trim(flnm),global_nX, global_ny,g_WEASD,g_SNODEP) - endif - call decompose_data_real(g_WEASD,WEASD) - call decompose_data_real(g_SNODEP,SNODEP) - - return - end subroutine MPP_READSNOW_FORC - - subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& - global_nX, global_ny,nsoil,out_SMC,out_SH2OX) - implicit none - - integer, intent(in) :: ix,global_nx,global_ny - integer, intent(in) :: jx,nsoil - real, dimension(ix,jx), intent(in) :: in_smcmax - real, dimension(ix,jx,nsoil), intent(out) :: out_smc,out_sh2ox - - real,dimension(global_nX, global_ny,nsoil):: g_smc, g_sh2ox - real,dimension(global_nX, global_ny):: g_smcmax - integer :: i,j,k - - - call write_IO_real(in_smcmax,g_smcmax) ! get global grid of smcmax - -#ifdef HYDRO_D - write (*,*) "In deep GW...", nsoil -#endif - -!loop to overwrite soils to saturation... - do i=1,global_nx - do j=1,global_ny - g_smc(i,j,1:NSOIL) = g_smcmax(i,j) - g_sh2ox(i,j,1:NSOIL) = g_smcmax(i,j) - end do - end do - -!decompose global grid to parallel tiles... - do k=1,nsoil - call decompose_data_real(g_smc(:,:,k),out_smc(:,:,k)) - call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k)) - end do - - return - end subroutine MPP_DEEPGW_HRLDAS - - - subroutine read_hydro_forcing_mpp( & - indir,olddate,hgrid, & - ix,jx,forc_typ,snow_assim, & - T2,q2x,u,v,pres,xlong,short,prcp1,& - lai,fpar,snodep,dt,k,prcp_old) -! This subrouting is going to read different forcing. - - - implicit none - ! in variable - character(len=*) :: olddate,hgrid,indir - character(len=256) :: filename - integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop - real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& - prcpnew,lai,fpar,snodep,prcp_old - real :: dt - ! tmp variable - character(len=256) :: inflnm, product - integer :: i,j,mmflag - real,dimension(global_nx,global_ny):: g_T2,g_Q2X,g_U,g_V,g_XLONG, & - g_SHORT,g_PRCP1,g_PRES,g_lai,g_snodep,g_prcp_old, g_fpar - integer flag - - - - call write_io_real(T2,g_T2) - call write_io_real(Q2X,g_Q2X) - call write_io_real(U,g_U) - call write_io_real(V,g_V) - call write_io_real(XLONG,g_XLONG) - call write_io_real(SHORT,g_SHORT) - call write_io_real(PRCP1,g_PRCP1) - call write_io_real(PRES,g_PRES) - call write_io_real(prcp_old,g_PRCP_old) - - call write_io_real(lai,g_lai) - call write_io_real(fpar,g_fpar) - call write_io_real(snodep,g_snodep) - - - - if(my_id .eq. IO_id) then - call read_hydro_forcing_seq( & - indir,olddate,hgrid,& - global_nx,global_ny,forc_typ,snow_assim, & - g_T2,g_q2x,g_u,g_v,g_pres,g_xlong,g_short,g_prcp1,& - g_lai,g_fpar,g_snodep,dt,k,g_prcp_old) -#ifdef HYDRO_D - write(6,*) "finish read forcing,olddate ",olddate -#endif - end if - - call decompose_data_real(g_T2,T2) - call decompose_data_real(g_Q2X,Q2X) - call decompose_data_real(g_U,U) - call decompose_data_real(g_V,V) - call decompose_data_real(g_XLONG,XLONG) - call decompose_data_real(g_SHORT,SHORT) - call decompose_data_real(g_PRCP1,PRCP1) - call decompose_data_real(g_prcp_old,prcp_old) - call decompose_data_real(g_PRES,PRES) - - call decompose_data_real(g_lai,lai) - call decompose_data_real(g_fpar,fpar) - call decompose_data_real(g_snodep,snodep) - - return - end subroutine read_hydro_forcing_mpp -#endif - - integer function nfeb_yw(year) - ! - ! Compute the number of days in February for the given year. - ! - implicit none - integer, intent(in) :: year ! Four-digit year - - nfeb_yw = 28 ! By default, February has 28 days ... - if (mod(year,4).eq.0) then - nfeb_yw = 29 ! But every four years, it has 29 days ... - if (mod(year,100).eq.0) then - nfeb_yw = 28 ! Except every 100 years, when it has 28 days ... - if (mod(year,400).eq.0) then - nfeb_yw = 29 ! Except every 400 years, when it has 29 days ... - if (mod(year,3600).eq.0) then - nfeb_yw = 28 ! Except every 3600 years, when it has 28 days. - endif - endif - endif - endif - end function nfeb_yw - - subroutine geth_newdate (ndate, odate, idt) - implicit none - - ! From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and - ! delta-time, compute the new date. - - ! on entry - odate - the old hdate. - ! idt - the change in time - - ! on exit - ndate - the new hdate. - - integer, intent(in) :: idt - character (len=*), intent(out) :: ndate - character (len=*), intent(in) :: odate - - ! Local Variables - - ! yrold - indicates the year associated with "odate" - ! moold - indicates the month associated with "odate" - ! dyold - indicates the day associated with "odate" - ! hrold - indicates the hour associated with "odate" - ! miold - indicates the minute associated with "odate" - ! scold - indicates the second associated with "odate" - - ! yrnew - indicates the year associated with "ndate" - ! monew - indicates the month associated with "ndate" - ! dynew - indicates the day associated with "ndate" - ! hrnew - indicates the hour associated with "ndate" - ! minew - indicates the minute associated with "ndate" - ! scnew - indicates the second associated with "ndate" - - ! mday - a list assigning the number of days in each month - - ! i - loop counter - ! nday - the integer number of days represented by "idt" - ! nhour - the integer number of hours in "idt" after taking out - ! all the whole days - ! nmin - the integer number of minutes in "idt" after taking out - ! all the whole days and whole hours. - ! nsec - the integer number of minutes in "idt" after taking out - ! all the whole days, whole hours, and whole minutes. - - integer :: newlen, oldlen - integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew - integer :: yrold, moold, dyold, hrold, miold, scold, frold - integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc - logical :: opass - character (len=10) :: hfrc - character (len=1) :: sp - logical :: punct - integer :: yrstart, yrend, mostart, moend, dystart, dyend - integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart - integer :: units - integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) -!yw integer nfeb_yw - - ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...." - if (odate(5:5) == "-") then - punct = .TRUE. - else - punct = .FALSE. - endif - - ! Break down old hdate into parts - - hrold = 0 - miold = 0 - scold = 0 - frold = 0 - oldlen = LEN(odate) - if (punct) then - yrstart = 1 - yrend = 4 - mostart = 6 - moend = 7 - dystart = 9 - dyend = 10 - hrstart = 12 - hrend = 13 - mistart = 15 - miend = 16 - scstart = 18 - scend = 19 - frstart = 21 - select case (oldlen) - case (10) - ! Days - units = 1 - case (13) - ! Hours - units = 2 - case (16) - ! Minutes - units = 3 - case (19) - ! Seconds - units = 4 - case (21) - ! Tenths - units = 5 - case (22) - ! Hundredths - units = 6 - case (23) - ! Thousandths - units = 7 - case (24) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - call hydro_stop("in geth_newdate") -#endif - end select - - if (oldlen.ge.11) then - sp = odate(11:11) - else - sp = ' ' - end if - - else - - yrstart = 1 - yrend = 4 - mostart = 5 - moend = 6 - dystart = 7 - dyend = 8 - hrstart = 9 - hrend = 10 - mistart = 11 - miend = 12 - scstart = 13 - scend = 14 - frstart = 15 - - select case (oldlen) - case (8) - ! Days - units = 1 - case (10) - ! Hours - units = 2 - case (12) - ! Minutes - units = 3 - case (14) - ! Seconds - units = 4 - case (15) - ! Tenths - units = 5 - case (16) - ! Hundredths - units = 6 - case (17) - ! Thousandths - units = 7 - case (18) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - call hydro_stop("in geth_newdate") -#endif - end select - endif - - ! Use internal READ statements to convert the CHARACTER string - ! date into INTEGER components. - - read(odate(yrstart:yrend), '(i4)') yrold - read(odate(mostart:moend), '(i2)') moold - read(odate(dystart:dyend), '(i2)') dyold - if (units.ge.2) then - read(odate(hrstart:hrend),'(i2)') hrold - if (units.ge.3) then - read(odate(mistart:miend),'(i2)') miold - if (units.ge.4) then - read(odate(scstart:scend),'(i2)') scold - if (units.ge.5) then - read(odate(frstart:oldlen),*) frold - end if - end if - end if - end if - - ! Set the number of days in February for that year. - - mday(2) = nfeb_yw(yrold) - - ! Check that ODATE makes sense. - - opass = .TRUE. - - ! Check that the month of ODATE makes sense. - - if ((moold.gt.12).or.(moold.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold -#endif - opass = .FALSE. - end if - - ! Check that the day of ODATE makes sense. - - if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold -#endif - opass = .FALSE. - end if - - ! Check that the hour of ODATE makes sense. - - if ((hrold.gt.23).or.(hrold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold -#endif - opass = .FALSE. - end if - - ! Check that the minute of ODATE makes sense. - - if ((miold.gt.59).or.(miold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold -#endif - opass = .FALSE. - end if - - ! Check that the second of ODATE makes sense. - - if ((scold.gt.59).or.(scold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold -#endif - opass = .FALSE. - end if - - ! Check that the fractional part of ODATE makes sense. - if (.not.opass) then -#ifdef HYDRO_D - write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen - call hydro_stop("in geth_newdate") -#endif - end if - - ! Date Checks are completed. Continue. - - - ! Compute the number of days, hours, minutes, and seconds in idt - - if (units.ge.5) then !idt should be in fractions of seconds - ifrc = oldlen-(frstart)+1 - ifrc = 10**ifrc - nday = abs(idt)/(86400*ifrc) - nhour = mod(abs(idt),86400*ifrc)/(3600*ifrc) - nmin = mod(abs(idt),3600*ifrc)/(60*ifrc) - nsec = mod(abs(idt),60*ifrc)/(ifrc) - nfrac = mod(abs(idt), ifrc) - else if (units.eq.4) then !idt should be in seconds - ifrc = 1 - nday = abs(idt)/86400 ! integer number of days in delta-time - nhour = mod(abs(idt),86400)/3600 - nmin = mod(abs(idt),3600)/60 - nsec = mod(abs(idt),60) - nfrac = 0 - else if (units.eq.3) then !idt should be in minutes - ifrc = 1 - nday = abs(idt)/1440 ! integer number of days in delta-time - nhour = mod(abs(idt),1440)/60 - nmin = mod(abs(idt),60) - nsec = 0 - nfrac = 0 - else if (units.eq.2) then !idt should be in hours - ifrc = 1 - nday = abs(idt)/24 ! integer number of days in delta-time - nhour = mod(abs(idt),24) - nmin = 0 - nsec = 0 - nfrac = 0 - else if (units.eq.1) then !idt should be in days - ifrc = 1 - nday = abs(idt) ! integer number of days in delta-time - nhour = 0 - nmin = 0 - nsec = 0 - nfrac = 0 - else -#ifdef HYDRO_D - write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & - oldlen - write(*,*) '#'//odate(1:oldlen)//'#' - call hydro_stop("in geth_newdate") -#endif - end if - - if (idt.ge.0) then - - frnew = frold + nfrac - if (frnew.ge.ifrc) then - frnew = frnew - ifrc - nsec = nsec + 1 - end if - - scnew = scold + nsec - if (scnew .ge. 60) then - scnew = scnew - 60 - nmin = nmin + 1 - end if - - minew = miold + nmin - if (minew .ge. 60) then - minew = minew - 60 - nhour = nhour + 1 - end if - - hrnew = hrold + nhour - if (hrnew .ge. 24) then - hrnew = hrnew - 24 - nday = nday + 1 - end if - - dynew = dyold - monew = moold - yrnew = yrold - do i = 1, nday - dynew = dynew + 1 - if (dynew.gt.mday(monew)) then - dynew = dynew - mday(monew) - monew = monew + 1 - if (monew .gt. 12) then - monew = 1 - yrnew = yrnew + 1 - ! If the year changes, recompute the number of days in February - mday(2) = nfeb_yw(yrnew) - end if - end if - end do - - else if (idt.lt.0) then - - frnew = frold - nfrac - if (frnew .lt. 0) then - frnew = frnew + ifrc - nsec = nsec + 1 - end if - - scnew = scold - nsec - if (scnew .lt. 00) then - scnew = scnew + 60 - nmin = nmin + 1 - end if - - minew = miold - nmin - if (minew .lt. 00) then - minew = minew + 60 - nhour = nhour + 1 - end if - - hrnew = hrold - nhour - if (hrnew .lt. 00) then - hrnew = hrnew + 24 - nday = nday + 1 - end if - - dynew = dyold - monew = moold - yrnew = yrold - do i = 1, nday - dynew = dynew - 1 - if (dynew.eq.0) then - monew = monew - 1 - if (monew.eq.0) then - monew = 12 - yrnew = yrnew - 1 - ! If the year changes, recompute the number of days in February - mday(2) = nfeb_yw(yrnew) - end if - dynew = mday(monew) - end if - end do - end if - - ! Now construct the new mdate - - newlen = LEN(ndate) - - if (punct) then - - if (newlen.gt.frstart) then - write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew - write(hfrc,'(i10)') frnew+1000000000 - ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) - - else if (newlen.eq.scend) then - write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew -19 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2) - - else if (newlen.eq.miend) then - write(ndate,16) yrnew, monew, dynew, hrnew, minew -16 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2) - - else if (newlen.eq.hrend) then - write(ndate,13) yrnew, monew, dynew, hrnew -13 format(i4,'-',i2.2,'-',i2.2,'_',i2.2) - - else if (newlen.eq.dyend) then - write(ndate,10) yrnew, monew, dynew -10 format(i4,'-',i2.2,'-',i2.2) - - end if - - else - - if (newlen.gt.frstart) then - write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew - write(hfrc,'(i10)') frnew+1000000000 - ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) - - else if (newlen.eq.scend) then - write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew -119 format(i4,i2.2,i2.2,i2.2,i2.2,i2.2) - - else if (newlen.eq.miend) then - write(ndate,116) yrnew, monew, dynew, hrnew, minew -116 format(i4,i2.2,i2.2,i2.2,i2.2) - - else if (newlen.eq.hrend) then - write(ndate,113) yrnew, monew, dynew, hrnew -113 format(i4,i2.2,i2.2,i2.2) - - else if (newlen.eq.dyend) then - write(ndate,110) yrnew, monew, dynew -110 format(i4,i2.2,i2.2) - - end if - - endif - - if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp - - end subroutine geth_newdate -end module module_lsm_forcing diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/module_noah_chan_param_init_rt.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/module_noah_chan_param_init_rt.F.svn-base deleted file mode 100644 index ba40b76b..00000000 --- a/wrfv2_fire/hydro/Routing/.svn/text-base/module_noah_chan_param_init_rt.F.svn-base +++ /dev/null @@ -1,87 +0,0 @@ -MODULE module_noah_chan_param_init_rt - - -CONTAINS -! -!----------------------------------------------------------------- - SUBROUTINE CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann) -!----------------------------------------------------------------- - - IMPLICIT NONE - - integer :: IINDEX, CHANCATS - integer :: ORDER - integer, PARAMETER :: NCHANTYPES=50 - real,dimension(NCHANTYPES) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann - character(LEN=11) :: DATATYPE - -!-----SPECIFY CHANNEL RELATED CHARACTERISTICS : -! ORDER: Strahler Stream Order -! BOTWID: Channel Bottom Width (meters) -! HLINK_INIT: Initial depth of flow in channel (meters) -! CHAN_SS: Channel side slope (assuming trapezoidal channel geom) -! CHMann: Channel Manning's N roughness coefficient - - -!-----READ IN CHANNEL PROPERTIES FROM CHANPARM.TBL : - OPEN(19, FILE='CHANPARM.TBL',FORM='FORMATTED',STATUS='OLD') - READ (19,*) - READ (19,2000,END=2002) DATATYPE -#ifdef HYDRO_D - PRINT *, DATATYPE -#endif - READ (19,*)CHANCATS,IINDEX -2000 FORMAT (A11) - -!-----Read in Channel Parameters as functions of stream order... - - IF(DATATYPE.EQ.'StreamOrder')THEN -#ifdef HYDRO_D - PRINT *, 'CHANNEL DATA SOURCE TYPE = ',DATATYPE,' FOUND', & - CHANCATS,' CATEGORIES' -#endif - DO ORDER=1,CHANCATS - READ (19,*)IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER), & - & CHMann(ORDER) - PRINT *, IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER), & - & CHMann(ORDER) - ENDDO - ENDIF - - -!-----Read in Channel Parameters as functions of ???other method??? (TBC)... - - -2002 CONTINUE - - CLOSE (19) - END SUBROUTINE CHAN_PARM_INIT - - - -#ifdef MPP_LAND - SUBROUTINE mpp_CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann) - use module_mpp_land, only: my_id, IO_id,mpp_land_bcast_int1, & - mpp_land_bcast_real,mpp_land_bcast_int,mpp_land_bcast_real1 - implicit none - integer :: IINDEX, CHANCATS - integer :: ORDER - integer, PARAMETER :: NCHANTYPES=50 - real,dimension(NCHANTYPES) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann - character(LEN=11) :: DATATYPE - - if(my_id.eq.io_id) then - call CHAN_PARM_INIT(BOTWID,HLINK_INIT,CHAN_SS,CHMann) - end if - call mpp_land_bcast_real(NCHANTYPES,BOTWID) - call mpp_land_bcast_real(NCHANTYPES,HLINK_INIT) - call mpp_land_bcast_real(NCHANTYPES,CHAN_SS) - call mpp_land_bcast_real(NCHANTYPES,CHMann) - return - END SUBROUTINE mpp_CHAN_PARM_INIT -#endif -!----------------------------------------------------------------- -!----------------------------------------------------------------- - - -END MODULE module_Noah_chan_param_init_rt diff --git a/wrfv2_fire/hydro/Routing/.svn/text-base/rtFunction.F.svn-base b/wrfv2_fire/hydro/Routing/.svn/text-base/rtFunction.F.svn-base deleted file mode 100644 index 9334307f..00000000 --- a/wrfv2_fire/hydro/Routing/.svn/text-base/rtFunction.F.svn-base +++ /dev/null @@ -1,222 +0,0 @@ - subroutine exeRouting (did) - use module_RT_data, only: rt_domain - use module_GW_baseflow_data, only: gw2d - use module_GW_baseflow, only: simp_gw_buck, gwstep - use module_channel_routing, only: drive_channel - use module_namelist, only: nlst_rt - -#ifdef MPP_LAND - use module_mpp_land -#endif - - - implicit none - integer did, i - real, dimension(RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT):: & - QSTRMVOLRT_DUM,LAKE_INFLORT_DUM, & - QSTRMVOLRT_TS, LAKE_INFLORT_TS - - real :: dx - integer ii,jj,kk - - - IF (nlst_rt(did)%SUBRTSWCRT.EQ.1 .or. nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) THEN - - QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT - LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT - -#ifdef HYDRO_D - write(6,*) "*****yw******start drive_RT " -#endif - - - -! write(6,*) "yyww RT_DOMAIN(did)%SH2OX(15,1,7)= ", RT_DOMAIN(did)%SH2OX(15,1,7) - - call drive_RT( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,& - RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & - RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%STC,RT_DOMAIN(did)%SH2OX, & - RT_DOMAIN(did)%INFXSRT,RT_DOMAIN(did)%SFCHEADRT,RT_DOMAIN(did)%SMCMAX1,& - RT_DOMAIN(did)%SMCREF1,RT_DOMAIN(did)%LKSAT, & - RT_DOMAIN(did)%SMCWLT1, RT_DOMAIN(did)%SMCRTCHK,RT_DOMAIN(did)%DSMC,& - RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SMCAGGRT,& - RT_DOMAIN(did)%STCAGGRT,RT_DOMAIN(did)%SH2OAGGRT, & - RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%SOLDEPRT,& - RT_DOMAIN(did)%INFXSAGGRT,RT_DOMAIN(did)%DHRT,RT_DOMAIN(did)%QSTRMVOLRT, & - RT_DOMAIN(did)%QBDRYRT,RT_DOMAIN(did)%LAKE_INFLORT,& - RT_DOMAIN(did)%SFCHEADSUBRT,RT_DOMAIN(did)%INFXSWGT,& - RT_DOMAIN(did)%LKSATRT, & - RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%OVROUGHRT,& - RT_DOMAIN(did)%QSUBRT,RT_DOMAIN(did)%ZWATTABLRT, & - RT_DOMAIN(did)%QSUBBDRYRT, & - RT_DOMAIN(did)%RETDEPRT,RT_DOMAIN(did)%SOXRT,RT_DOMAIN(did)%SOYRT,& - RT_DOMAIN(did)%SUB_RESID,RT_DOMAIN(did)%SMCRT,& - RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCWLTRT, & - RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%LAKE_MSKRT,& - RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%dist, & - RT_DOMAIN(did)%LSMVOL,RT_DOMAIN(did)%DSMCTOT, & - RT_DOMAIN(did)%SMCTOT1,& - RT_DOMAIN(did)%SMCTOT2,RT_DOMAIN(did)%suminfxs1, & - RT_DOMAIN(did)%suminfxsrt,RT_DOMAIN(did)%SO8RT, & - RT_DOMAIN(did)%SO8RT_D,nlst_rt(did)%AGGFACTRT, & - nlst_rt(did)%SUBRTSWCRT,nlst_rt(did)%OVRTSWCRT, & - RT_DOMAIN(did)%LAKE_CT, RT_DOMAIN(did)%STRM_CT, & - nlst_rt(did)%RT_OPTION,RT_DOMAIN(did)%OV_ROUGH, & - RT_DOMAIN(did)%INFXSAGG1RT,RT_DOMAIN(did)%SFCHEADAGG1RT,& - RT_DOMAIN(did)%SFCHEADAGGRT,& - nlst_rt(did)%DTRT, & - nlst_rt(did)%DT,RT_DOMAIN(did)%LAKE_INFLOTRT,& - RT_DOMAIN(did)%QBDRYTRT,RT_DOMAIN(did)%QSUBBDRYTRT,& - RT_DOMAIN(did)%QSTRMVOLTRT,RT_DOMAIN(did)%q_sfcflx_x,& - RT_DOMAIN(did)%q_sfcflx_y,RT_DOMAIN(did)%LKSATFAC,& - RT_DOMAIN(did)%OVROUGHRTFAC,rt_domain(did)%dist_lsm(:,:,9) ) - - QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-QSTRMVOLRT_DUM - LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-LAKE_INFLORT_DUM - -#ifdef HYDRO_D - write(6,*) "*****yw******end drive_RT " -#endif - end if - - - -!------------------------------------------------------------------ -!DJG Begin GW/Baseflow Routines -!------------------------------------------------------------------- - - IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN ! Switch to activate/specify GW/Baseflow - -! IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow - - If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then ! Call simple bucket baseflow scheme - -#ifdef HYDRO_D - write(6,*) "*****yw******start simp_gw_buck " -#endif - - call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& - RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%basns_area,& - RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & - RT_DOMAIN(did)%SOLDRAIN, & - RT_DOMAIN(did)%z_gwsubbas,& - RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& - RT_DOMAIN(did)%qinflowbase,& - RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & - RT_DOMAIN(did)%dist,nlst_rt(did)%DT,& - RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & - RT_DOMAIN(did)%z_max,& - nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT) - - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - - open (unit=51,file='GW_inflow.txt',form='formatted',& - status='unknown',position='append') - open (unit=52,file='GW_outflow.txt',form='formatted',& - status='unknown',position='append') - open (unit=53,file='GW_zlev.txt',form='formatted',& - status='unknown',position='append') - do i=1,RT_DOMAIN(did)%numbasns - write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i) -951 FORMAT(I3,1X,A19,1X,F11.3) - write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i) - write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i) - end do - close(51) - close(52) - close(53) -#ifdef MPP_LAND - endif -#endif - -#ifdef HYDRO_D - write(6,*) "*****yw******end simp_gw_buck " -#endif - -!!!For parameter setup runs output the percolation for each basin, -!!!otherwise comment out this output... - else if (nlst_rt(did)%GWBASESWCRT .eq. 3) then - -#ifdef HYDRO_D - write(6,*) "*****bf******start 2d_gw_model " -#endif - - DX = abs(nlst_rt(did)%DXRT0 * nlst_rt(did)%AGGFACTRT) - - call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & - gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & - gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & - gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & - gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & - gw2d(did)%istep) - - -! bftodo head postprocessing block -! GW-SOIL-CHANNEL interaction section - gw2d(did)%ho = gw2d(did)%h - -#ifdef HYDRO_D - write(6,*) "*****bf******end 2d_gw_model " -#endif - - End if - - END IF !DJG (End if for RTE SWC activation) -!------------------------------------------------------------------ -!DJG End GW/Baseflow Routines -!------------------------------------------------------------------- - -!------------------------------------------------------------------- -!------------------------------------------------------------------- -!DJG,DNY Begin Channel and Lake Routing Routines -!------------------------------------------------------------------- - IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN - - call drive_CHANNEL(RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & - nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, & - LAKE_INFLORT_TS, QSTRMVOLRT_TS,& - RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& - RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& - RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT, & - RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTRT, & - RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & - RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& - RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & - RT_DOMAIN(did)%Bw,& - RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,& - RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, & - RT_DOMAIN(did)%ORIFICEA, & - RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & - RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& - RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, & - RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & - RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, & - RT_DOMAIN(did)%RETDEP_CHAN & - , RT_DOMAIN(did)%node_area & -#ifdef MPP_LAND - ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& - RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & - RT_DOMAIN(did)%yw_mpp_nlinks & -#endif - ) - endif - -#ifdef HYDRO_D - write(6,*) "*****yw******end drive_CHANNEL " -#endif - - end subroutine exeRouting - - subroutine time_seconds(i3) - integer time_array(8) - real*8 i3 - call date_and_time(values=time_array) - i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + & - time_array(7) + 0.001 * time_array(8) - return - end subroutine time_seconds - - diff --git a/wrfv2_fire/hydro/Routing/Makefile b/wrfv2_fire/hydro/Routing/Makefile deleted file mode 100644 index ce785bc1..00000000 --- a/wrfv2_fire/hydro/Routing/Makefile +++ /dev/null @@ -1,53 +0,0 @@ -# Makefile -# -.SUFFIXES: -.SUFFIXES: .o .F - -include ../macros - -OBJS = \ - module_HYDRO_utils.o \ - module_noah_chan_param_init_rt.o \ - module_GW_baseflow.o \ - module_HYDRO_io.o \ - module_RT.o Noah_distr_routing.o \ - module_channel_routing.o \ - module_lsm_forcing.o - -all: $(OBJS) - -#module_RT.o: module_RT.F -# @echo "" -# $(CPP) $(CPPFLAGS) $(*).F > $(*).f -# $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f -# $(RMD) $(*).f -# @echo "" -# cp *.mod ../mod - -.F.o: - @echo "" - $(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f - $(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f - $(RMD) $(*).f - @echo "" - ar -r ../lib/libHYDRO.a $(@) - cp *.mod ../mod - -# -# Dependencies: -# -module_GW_baseflow.o: ../Data_Rec/module_GW_baseflow_data.o - -module_HYDRO_io.o: module_HYDRO_utils.o ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o - -module_HYDRO_utils.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o - -module_lsm_forcing.o: module_HYDRO_io.o - -module_RT.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o ../Data_Rec/module_GW_baseflow_data.o \ - module_GW_baseflow.o module_HYDRO_utils.o module_HYDRO_io.o\ - module_noah_chan_param_init_rt.o ../Data_Rec/module_GW_baseflow_data.o - - -clean: - rm -f *.o *.mod *.stb *~ *.f diff --git a/wrfv2_fire/hydro/Routing/Noah_distr_routing.F b/wrfv2_fire/hydro/Routing/Noah_distr_routing.F deleted file mode 100644 index 0f856caf..00000000 --- a/wrfv2_fire/hydro/Routing/Noah_distr_routing.F +++ /dev/null @@ -1,2768 +0,0 @@ -!DJG ------------------------------------------------ -!DJG SUBROUTINE RT_PARM -!DJG ------------------------------------------------ - - SUBROUTINE RT_PARM(IX,JY,IXRT,JXRT,VEGTYP,RETDP,OVRGH, & - AGGFACTR) -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id,& - up_id,mpp_land_com_real,MPP_LAND_UB_COM, & - MPP_LAND_LR_COM,mpp_land_com_integer -#endif - - IMPLICIT NONE - -!DJG -------- DECLARATIONS ----------------------- - - INTEGER, INTENT(IN) :: IX,JY,IXRT,JXRT,AGGFACTR - - INTEGER, INTENT(IN), DIMENSION(IX,JY) :: VEGTYP - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: RETDP - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: OVRGH - - -!DJG Local Variables - - INTEGER :: I,J,IXXRT,JYYRT - INTEGER :: AGGFACYRT,AGGFACXRT - - -!DJG Assign RETDP and OVRGH based on VEGTYP... - - do J=1,JY - do I=1,IX - - do AGGFACYRT=AGGFACTR-1,0,-1 - do AGGFACXRT=AGGFACTR-1,0,-1 - - IXXRT=I*AGGFACTR-AGGFACXRT - JYYRT=J*AGGFACTR-AGGFACYRT -#ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 -#else -!yw ???? -! IXXRT=IXXRT+1 -! JYYRT=JYYRT+1 -#endif - - -!DJG Urban, rock, playa, snow/ice... - IF (VEGTYP(I,J).EQ.1.OR.VEGTYP(I,J).EQ.26.OR. & - VEGTYP(I,J).EQ.26.OR.VEGTYP(I,J).EQ.24) THEN - RETDP(IXXRT,JYYRT)=1.3 - OVRGH(IXXRT,JYYRT)=0.1 -!DJG Wetlands and water bodies... - ELSE IF (VEGTYP(I,J).EQ.17.OR.VEGTYP(I,J).EQ.18.OR. & - VEGTYP(I,J).EQ.19.OR.VEGTYP(I,J).EQ.16) THEN - RETDP(IXXRT,JYYRT)=10.0 - OVRGH(IXXRT,JYYRT)=0.2 -!DJG All other natural covers... - ELSE - RETDP(IXXRT,JYYRT)=5.0 - OVRGH(IXXRT,JYYRT)=0.2 - END IF - - end do - end do - - end do - end do -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(RETDP,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(OVRGH,IXRT,JXRT,99) -#endif - -!DJG ---------------------------------------------------------------- - END SUBROUTINE RT_PARM -!DJG ---------------------------------------------------------------- - - - - - -!DJG ------------------------------------------------ -!DJG SUBROUTINE SUBSFC_RTNG -!DJG ------------------------------------------------ - - SUBROUTINE SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT, & - SOYRT,LATKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT, & - NSOIL,SMCRT,INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT, & - SMCWLTRT,SO8RT,SO8RT_D, rt_option,SLDPTH,junk4,CWATAVAIL, & - SATLYRCHK) - -! use module_mpp_land, only: write_restart_rt_3, write_restart_rt_2, & -! my_id -#ifdef MPP_LAND - use module_mpp_land, only: MPP_LAND_COM_REAL -#endif - IMPLICIT NONE - -!DJG -------- DECLARATIONS ------------------------ - - INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL - - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT,junk4 - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOYRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: LATKSATRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOLDEPRT - - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ZWATTABLRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: CWATAVAIL - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: SATLYRCHK - - - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBRT - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBBDRYRT - - REAL, INTENT(IN) :: dist(ixrt,jxrt,9) - REAL, INTENT(IN) :: DT - REAL, INTENT(IN), DIMENSION(NSOIL) :: ZSOIL - REAL, INTENT(IN), DIMENSION(NSOIL) :: SLDPTH - REAL, INTENT(INOUT) :: QSUBBDRYTRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: INFXSUBRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT - - REAL, DIMENSION(IXRT,JXRT) :: ywtmp -!DJG Local Variables - - INTEGER :: I,J,KK -!djg INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK - - REAL :: GRDAREA - REAL :: SUBFLO - REAL :: WATAVAIL - - INTEGER :: SO8RT_D(IXRT,JXRT,3) - REAL :: SO8RT(IXRT,JXRT,8) - integer :: rt_option, index - - INTEGER :: DT_STEPS !-- number of timestep in routing - REAL :: SUBDT !-- subsurface routing timestep - INTEGER :: KRT !-- routing counter - REAL, DIMENSION(IXRT,JXRT,NSOIL) :: SMCTMP !--temp store of SMC - REAL, DIMENSION(IXRT,JXRT) :: ZWATTABLRTTMP ! temp store of ZWAT - REAL, DIMENSION(IXRT,JXRT) :: INFXSUBRTTMP ! temp store of infilx -!djg REAL, DIMENSION(IXRT,JXRT) :: CWATAVAIL ! temp specif. of wat avial - - - -!DJG Debug Variables... - REAL :: qsubchk,qsubbdrytmp - REAL :: junk1,junk2,junk3,junk5,junk6,junk7 - INTEGER, PARAMETER :: double=8 - REAL (KIND=double) :: smctot1a,smctot2a - INTEGER :: kx,count - - -!DJG ----------------------------------------------------------------- -!DJG SUBSURFACE ROUTING LOOP -!DJG - SUBSURFACE ROUTING RUN ON NOAH TIMESTEP -!DJG - SUBSURFACE ROUITNG ONLY PERFORMED ON SATURATED LAYERS -!DJG ----------------------------------------------------------------- - - !yw GRDAREA=DXRT*DXRT - ! GRDAREA=dist(i,j,9) - - -!DJG debug subsfc... - subflo = 0.0 - -!DJG Set up mass balance checks... -! CWATAVAIL = 0. !-- initialize subsurface watavail - SUBDT = DT !-- initialize the routing timestep to DT - - -!!!! Find saturated layer depth... -! Loop through domain to determine sat. layers and assign wat tbl depth... -! and water available for subsfc routing (CWATAVAIL)... -! -! CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & -! SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, & -! CWATAVAIL,SLDPTH) - - - -!DJG debug variable... - - -!DJG Courant check temp variable setup... - ZWATTABLRTTMP = ZWATTABLRT !-- temporary storage of water table level - - - - -!!!! Call subsurface routing subroutine... -#ifdef HYDRO_D - print *, "calling subsurface routing subroutine...Opt. ",rt_option -#endif - - - if(rt_option .eq. 1) then - CALL ROUTE_SUBSURFACE1(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & - LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT, & - SO8RT,SO8RT_D,CWATAVAIL,SUBDT) - else - CALL ROUTE_SUBSURFACE2(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & - LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT, & - CWATAVAIL,SUBDT) - end if - -#ifdef HYDRO_D - write(6,*) "finish calling ROUTE_SUBSURFACE ", rt_option -#endif - - -!!!! Update soil moisture fields with subsurface flow... - -!!!! Loop through subsurface routing domain... - DO I=1,IXRT - DO J=1,JXRT - -!!DJG Check for courant condition violation...put limit on qsub -!!DJG QSUB HAS units of m^3/s SUBFLO has units of m - - - IF (CWATAVAIL(i,j).le.ABS(qsubrt(i,j))/dist(i,j,9)*SUBDT) THEN - QSUBRT(i,j) = -1.0*CWATAVAIL(i,j) - SUBFLO = QSUBRT(i,j) !Units of qsubrt converted via CWATAVAIL - ELSE - SUBFLO=QSUBRT(I,J)/dist(i,j,9)*SUBDT !Convert qsubrt from m^3/s to m - END IF - - WATAVAIL=0. !Initialize to 0. for every cell... - - -!!DJG Begin loop through soil profile to adjust soil water content -!!DJG based on subsfc flow (SUBFLO)... - - IF (SUBFLO.GT.0) THEN ! Increase soil moist for +SUBFLO (Inflow) - -! Loop through soil layers from bottom to top - DO KK=NSOIL,1,-1 - - -! Check for saturated layers - IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK)) THEN - IF (SMCRT(I,J,KK).GT.SMCMAXRT(I,J,KK)) THEN -#ifdef HYDRO_D - print *, "Subsfc acct. SMCMAX exceeded...", & - SMCRT(I,J,KK), SMCMAXRT(I,J,KK),KK,i,j - call hydro_stop("SUBSFC_RTNG") -#endif - ELSE - END IF - ELSE - WATAVAIL = (SMCMAXRT(I,J,KK)-SMCRT(I,J,KK))*SLDPTH(KK) - IF (WATAVAIL.GE.SUBFLO) THEN - SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK) - SUBFLO = 0. - ELSE - SUBFLO = SUBFLO - WATAVAIL - SMCRT(I,J,KK) = SMCMAXRT(I,J,KK) - END IF - END IF - - IF (SUBFLO.EQ.0.) EXIT -! IF (SUBFLO.EQ.0.) goto 669 - - END DO ! END DO FOR SOIL LAYERS - -669 continue - -! If all layers sat. add remaining subflo to infilt. excess... - IF (KK.eq.0.AND.SUBFLO.gt.0.) then - INFXSUBRT(I,J) = INFXSUBRT(I,J) + SUBFLO*1000. !Units = mm - SUBFLO=0. - END IF - -!DJG Error trap... - if (subflo.ne.0.) then -#ifdef HYDRO_D - print *, "Subflo (+) not expired...:",subflo,i,j,kk,SMCRT(i,j,1), & - SMCRT(i,j,2),SMCRT(i,j,3),SMCRT(i,j,4),SMCRT(i,j,5), & - SMCRT(i,j,6),SMCRT(i,j,7),SMCRT(i,j,8),"SMCMAX",SMCMAXRT(i,j,1) -#endif - end if - - - ELSE IF (SUBFLO.LT.0) THEN ! Decrease soil moist for -SUBFLO (Drainage) - - -!DJG loop from satlyr back down and subtract out subflo as necess... -! now set to SMCREF, 8/24/07 -!DJG and then using unsat cond as opposed to Ksat... - - DO KK=SATLYRCHK(I,J),NSOIL - WATAVAIL = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK) - IF (WATAVAIL.GE.ABS(SUBFLO)) THEN -!?yw mod IF (WATAVAIL.GE.(ABS(SUBFLO)+0.000001) ) THEN - SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK) - SUBFLO=0. - ELSE ! Since subflo is small on a time-step following is unlikely... - SMCRT(I,J,KK)=SMCREFRT(I,J,KK) - SUBFLO=SUBFLO+WATAVAIL - END IF - IF (SUBFLO.EQ.0.) EXIT -! IF (SUBFLO.EQ.0.) goto 668 - - END DO ! END DO FOR SOIL LAYERS -668 continue - - -!DJG Error trap... - if(abs(subflo) .le. 1.E-7 ) subflo = 0.0 !truncate residual to 1E-7 prec. - - if (subflo.ne.0.) then -#ifdef HYDRO_D - print *, "Subflo (-) not expired:",i,j,subflo,CWATAVAIL(i,j) - print *, "zwatabl = ", ZWATTABLRT(I,J) - print *, "QSUBRT(I,J)=",QSUBRT(I,J) - print *, "WATAVAIL = ",WATAVAIL, "kk=",kk - print * -#endif - end if - - - - END IF ! end if for +/- SUBFLO soil moisture accounting... - - - - - END DO ! END DO X dim - END DO ! END DO Y dim -!!!! End loop through subsurface routing domain... - -#ifdef MPP_LAND - do i = 1, NSOIL - call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99) - end DO -#endif - - - -!DJG ---------------------------------------------------------------- - END SUBROUTINE SUBSFC_RTNG -!DJG ---------------------------------------------------------------- - - -!DJG ------------------------------------------------------------------------ -!DJG SUBSURFACE FINDZWAT -!DJG ------------------------------------------------------------------------ - SUBROUTINE FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & - SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT,CWATAVAIL,& - SLDPTH) - - IMPLICIT NONE - -!DJG -------- DECLARATIONS ------------------------ - - INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT - REAL, INTENT(IN), DIMENSION(NSOIL) :: ZSOIL - REAL, INTENT(IN), DIMENSION(NSOIL) :: SLDPTH - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: ZWATTABLRT - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: CWATAVAIL - INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SATLYRCHK - -!DJG Local Variables - INTEGER :: KK,i,j - - -!!!! Find saturated layer depth... -! Loop through domain to determine sat. layers and assign wat tbl depth... - - - SATLYRCHK = 0 !set flag for sat. layers - CWATAVAIL = 0. !set wat avail for subsfc rtng = 0. - - DO J=1,JXRT - DO I=1,IXRT - -! Loop through soil layers from bottom to top - DO KK=NSOIL,1,-1 - -! Check for saturated layers -! Add additional logical check to ensure water is 'available' for routing, -! (i.e. not 'frozen' or otherwise immobile) -! IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK).AND.SMCMAXRT(I,J,KK) & -! .GT.SMCWLTRT(I,J,KK)) THEN - IF ( (SMCRT(I,J,KK).GE.SMCREFRT(I,J,KK)).AND.(SMCREFRT(I,J,KK) & - .GT.SMCWLTRT(I,J,KK)) ) THEN -! Add additional check to ensure saturation from bottom up only...8/8/05 - IF((SATLYRCHK(I,J).EQ.KK+1) .OR. (KK.EQ.NSOIL) ) SATLYRCHK(I,J) = KK - END IF - - END DO - - -! Designate ZWATTABLRT based on highest sat. layer and -! Define amount of water avail for subsfc routing on each gridcell (CWATAVAIL) -! note: using a 'field capacity' value of SMCREF as lower limit... - - IF (SATLYRCHK(I,J).ne.0) then - IF (SATLYRCHK(I,J).ne.1) then ! soil column is partially sat. - ZWATTABLRT(I,J) = -ZSOIL(SATLYRCHK(I,J)-1) - DO KK=SATLYRCHK(I,J),NSOIL -!old CWATAVAIL(I,J) = (SMCRT(I,J,SATLYRCHK(I,J))-& -!old SMCREFRT(I,J,SATLYRCHK(I,J))) * & -!old (ZSOIL(SATLYRCHK(I,J)-1)-ZSOIL(NSOIL)) - CWATAVAIL(I,J) = CWATAVAIL(I,J)+(SMCRT(I,J,KK)- & - SMCREFRT(I,J,KK))*SLDPTH(KK) - END DO - - - ELSE ! soil column is fully saturated to sfc. - ZWATTABLRT(I,J) = 0. - DO KK=SATLYRCHK(I,J),NSOIL - CWATAVAIL(I,J) = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK) - END DO - END IF - ELSE ! no saturated layers... - ZWATTABLRT(I,J) = -ZSOIL(NSOIL) - SATLYRCHK(I,J) = NSOIL + 1 - END IF - - - END DO - END DO - - -!DJG ---------------------------------------------------------------- - END SUBROUTINE FINDZWAT -!DJG ---------------------------------------------------------------- - - -!DJG ---------------------------------------------------------------- -!DJG ---------------------------------------------------------------- -!DJG SUBROUTINE ROUTE_SUBSURFACE2 -!DJG ---------------------------------------------------------------- - - SUBROUTINE ROUTE_SUBSURFACE2( & - dist,z,qsub,sox,soy, & - latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,CWATAVAIL, & - SUBDT) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Subroutine to route subsurface flow through the watershed -!DJG ---------------------------------------------------------------- -! -! Called from: main.f (Noah_router_driver) -! -! Returns: qsub=DQSUB which in turn becomes SUBFLO in head calc. -! -! Created: D. Gochis 3/27/03 -! Adaptded from Wigmosta, 1994 -! -! Modified: D. Gochis 1/05/04 -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id,& - up_id,mpp_land_com_real,MPP_LAND_UB_COM, & - MPP_LAND_LR_COM,mpp_land_com_integer -#endif - - IMPLICIT NONE - - -!! Declare Passed variables - - INTEGER, INTENT(IN) :: XX,YY - -!! Declare passed arrays - - REAL, INTENT(IN), DIMENSION(XX,YY) :: z - REAL, INTENT(IN), DIMENSION(XX,YY) :: sox - REAL, INTENT(IN), DIMENSION(XX,YY) :: soy - REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat - REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL - REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep - REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY - REAL, INTENT(INOUT) :: QSUBDRYT - REAL, INTENT(IN) :: SUBDT - real, intent(in), dimension(xx,yy,9) :: dist - -!!! Declare Local Variables - - REAL :: dzdx,dzdy,beta,gamma - REAL :: qqsub,hh,ksat, gsize - - INTEGER :: i,j -!!! Initialize variables - REAL, PARAMETER :: nexp=1.0 ! local power law exponent - qsub = 0. ! initialize flux = 0. !DJG 5 May 2014 - -!yw soldep = 2. - - -! Begin Subsurface routing - -!!! Loop to route water in x-direction - do j=1,YY - do i=1,XX -! check for boundary grid point? - if (i.eq.XX) GOTO 998 - gsize = dist(i,j,3) - - dzdx= (z(i,j) - z(i+1,j))/gsize - beta=sox(i,j) + dzdx + 1E-30 - if (abs(beta) .lt. 1E-20) beta=1E-20 - if (beta.lt.0) then -!yw hh=(1-(z(i+1,j)/soldep(i,j)))**nexp - hh=(1-(z(i+1,j)/soldep(i+1,j)))**nexp -! Change later to use mean Ksat of two cells - ksat=latksat(i+1,j) - else - hh=(1-(z(i,j)/soldep(i,j)))**nexp - ksat=latksat(i,j) - end if - - if (hh .lt. 0.) then -#ifdef HYDRO_D - print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), & - soldep(i,j),nexp - call hydro_stop("ROUTE_SUBSURFACE2") -#endif - end if - -!Err. tan slope gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) - gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) -!DJG lacks tan(beta) of original Wigmosta version gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta - - qqsub = gamma * hh - qsub(i,j) = qsub(i,j) + qqsub - qsub(i+1,j) = qsub(i+1,j) - qqsub - -! Boundary adjustments -#ifdef MPP_LAND - if ((i.eq.1).AND.(beta.lt.0.).and.(left_id.lt.0)) then -#else - if ((i.eq.1).AND.(beta.lt.0.)) then -#endif - qsub(i,j) = qsub(i,j) - qqsub - QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub - QSUBDRYT = QSUBDRYT - qqsub -#ifdef MPP_LAND - else if ((i.eq.(xx-1)).AND.(beta.gt.0.) & - .and.(right_id.lt.0) ) then -#else - else if ((i.eq.(xx-1)).AND.(beta.gt.0.)) then -#endif - qsub(i+1,j) = qsub(i+1,j) + qqsub - QSUBDRY(i+1,j) = QSUBDRY(i+1,j) + qqsub - QSUBDRYT = QSUBDRYT + qqsub - end if - -998 continue - -!! End loop to route sfc water in x-direction - end do - end do - -#ifdef MPP_LAND - call MPP_LAND_LR_COM(qsub,XX,YY,99) - call MPP_LAND_LR_COM(QSUBDRY,XX,YY,99) -#endif - - -!!! Loop to route water in y-direction - do j=1,YY - do i=1,XX -! check for boundary grid point? - if (j.eq.YY) GOTO 999 - gsize = dist(i,j,1) - - dzdy= (z(i,j) - z(i,j+1))/gsize - beta=soy(i,j) + dzdy + 1E-30 - if (abs(beta) .lt. 1E-20) beta=1E-20 - if (beta.lt.0) then -!yw hh=(1-(z(i,j+1)/soldep(i,j)))**nexp - hh=(1-(z(i,j+1)/soldep(i,j+1)))**nexp - ksat=latksat(i,j+1) - else - hh=(1-(z(i,j)/soldep(i,j)))**nexp - ksat=latksat(i,j) - end if - - if (hh .lt. 0.) GOTO 999 - -!Err. tan slope gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) - gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta - - qqsub = gamma * hh - qsub(i,j) = qsub(i,j) + qqsub - qsub(i,j+1) = qsub(i,j+1) - qqsub - -! Boundary adjustments - -#ifdef MPP_LAND - if ((j.eq.1).AND.(beta.lt.0.).and.(down_id.lt.0)) then -#else - if ((j.eq.1).AND.(beta.lt.0.)) then -#endif - qsub(i,j) = qsub(i,j) - qqsub - QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub - QSUBDRYT = QSUBDRYT - qqsub -#ifdef MPP_LAND - else if ((j.eq.(yy-1)).AND.(beta.gt.0.) & - .and. (up_id.lt.0) ) then -#else - else if ((j.eq.(yy-1)).AND.(beta.gt.0.)) then -#endif - qsub(i,j+1) = qsub(i,j+1) + qqsub - QSUBDRY(i,j+1) = QSUBDRY(i,j+1) + qqsub - QSUBDRYT = QSUBDRYT + qqsub - end if - -999 continue - -!! End loop to route sfc water in y-direction - end do - end do - -#ifdef MPP_LAND - call MPP_LAND_UB_COM(qsub,XX,YY,99) - call MPP_LAND_UB_COM(QSUBDRY,XX,YY,99) -#endif - - return -!DJG------------------------------------------------------------ - end subroutine ROUTE_SUBSURFACE2 -!DJG------------------------------------------------------------ - - - -!DJG ------------------------------------------------ -!DJG SUBROUTINE OV_RTNG -!DJG ------------------------------------------------ - - SUBROUTINE OV_RTNG(DT,DTRT,IXRT,JXRT,INFXSUBRT, & - SFCHEADSUBRT,DHRT,CH_NETRT,RETDEPRT,OVROUGHRT, & - QSTRMVOLRT,QBDRYRT,QSTRMVOLTRT,QBDRYTRT,SOXRT, & - SOYRT,dist,LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT, & - SO8RT,SO8RT_D,rt_option,q_sfcflx_x,q_sfcflx_y) - -!yyww -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id, & - up_id,mpp_land_com_real, my_id, & - mpp_land_sync -#endif - - IMPLICIT NONE - -!DJG --------DECLARATIONS---------------------------- - - INTEGER, INTENT(IN) :: IXRT,JXRT - REAL, INTENT(IN) :: DT,DTRT - - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: INFXSUBRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOYRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: RETDEPRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: OVROUGHRT - - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SFCHEADSUBRT - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: DHRT - - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_INFLORT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QBDRYRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: q_sfcflx_x,q_sfcflx_y - REAL, INTENT(INOUT) :: QSTRMVOLTRT,QBDRYTRT,LAKE_INFLOTRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8) :: SO8RT - -!DJG Local Variables - - INTEGER :: KRT,I,J,ct - - REAL, DIMENSION(IXRT,JXRT) :: INFXS_FRAC - REAL :: DT_FRAC,SUM_INFXS,sum_head - INTEGER SO8RT_D(IXRT,JXRT,3), rt_option - - - - -!DJG ---------------------------------------------------------------------- -! DJG BEGIN 1-D or 2-D OVERLAND FLOW ROUTING LOOP -!DJG --------------------------------------------------------------------- -!DJG Loop over 'routing time step' -!DJG Compute the number of time steps based on NOAH DT and routing DTRT - - DT_FRAC=INT(DT/DTRT) - -#ifdef HYDRO_D - write(6,*) "OV_RTNG DT_FRAC, DT, DTRT",DT_FRAC, DT, DTRT - write(6,*) "IXRT, JXRT = ",ixrt,jxrt -#endif - -!DJG NOTE: Applying all infiltration excess water at once then routing -!DJG Pre-existing SFHEAD gets combined with Precip. in the -!DJG calculation of INFXS1 during subroutine SRT.f. -!DJG debug - - -!DJG Assign all infiltration excess to surface head... - SFCHEADSUBRT=INFXSUBRT - -!DJG Divide infiltration excess over all routing time-steps -! INFXS_FRAC=INFXSUBRT/(DT/DTRT) - -!DJG Set flux accumulation fields to 0. before each loop... - q_sfcflx_x = 0. - q_sfcflx_y = 0. - ct =0 - - -!DJG Execute routing time-step loop... - - - DO KRT=1,DT_FRAC - - DO J=1,JXRT - DO I=1,IXRT - -!DJG Removed 4_29_05, sfhead now updated in route_overland subroutine... -! SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J) -!! SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J)+INFXS_FRAC(I,J) -! DHRT(I,J)=0. - -!DJG ERROR Check... - - IF (SFCHEADSUBRT(I,J).lt.0.) THEN -#ifdef HYDRO_D - print *, "ywcheck 2 ERROR!!!: Neg. Surface Head Value at (i,j):", & - i,j,SFCHEADSUBRT(I,J) - print *, "RETDEPRT(I,J) = ",RETDEPRT(I,J), "KRT=",KRT - print *, "INFXSUBRT(i,j)=",INFXSUBRT(i,j) - print *, "jxrt=",jxrt," ixrt=",ixrt -#endif - END IF - -!DJG Remove surface water from channel cells -!DJG Channel inflo cells specified as nonzeros from CH_NET -!DJG 9/16/04 Channel Extractions Removed until stream model implemented... - - - - IF (CH_NETRT(I,J).ne.-9999) THEN - ct = ct +1 - -!DJG Temporary test to up the retention depth of channel grid cells to 'soak' -!more water into valleys....set retdep = retdep*100 (=5 mm) - -! RETDEPRT(I,J) = RETDEPRT(I,J) * 100.0 !DJG TEMP HARDWIRE!!!! -! RETDEPRT(I,J) = 10.0 !DJG TEMP HARDWIRE!!!! - - IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN -!! QINFLO(CH_NET(I,J)=QINFLO(CH_NET(I,J)+SFCHEAD(I,J) - RETDEPRT(I,J) - QSTRMVOLTRT = QSTRMVOLTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J)) - QSTRMVOLRT(I,J) = QSTRMVOLRT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J) - SFCHEADSUBRT(I,J) = RETDEPRT(I,J) - END IF - END IF - -!DJG Lake inflow withdrawl from surface head...(4/29/05) - - - IF (LAKE_MSKRT(I,J).gt.0) THEN - IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN - LAKE_INFLOTRT = LAKE_INFLOTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J)) - LAKE_INFLORT(I,J) = LAKE_INFLORT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J) - SFCHEADSUBRT(I,J) = RETDEPRT(I,J) - - END IF - END IF - - - - END DO - END DO - -! call MPP_LAND_COM_REAL(QSTRMVOLRT,IXRT,JXRT,99) -!DJG---------------------------------------------------------------------- -!DJG CALL OVERLAND FLOW ROUTING SUBROUTINE -!DJG---------------------------------------------------------------------- - -!DJG Debug... - - - if(rt_option .eq. 1) then - CALL ROUTE_OVERLAND1(DTRT,dist,SFCHEADSUBRT,DHRT,SOXRT, & - SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT, & - SO8RT,SO8RT_D,q_sfcflx_x,q_sfcflx_y) - else - CALL ROUTE_OVERLAND2(DTRT,dist,SFCHEADSUBRT,DHRT,SOXRT, & - SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT, & - q_sfcflx_x,q_sfcflx_y) - end if - - END DO ! END routing time steps - -#ifdef HYDRO_D - print *, "End of OV_routing call..." -#endif - -!---------------------------------------------------------------------- -! END OVERLAND FLOW ROUTING LOOP -! CHANNEL ROUTING TO FOLLOW -!---------------------------------------------------------------------- - -!DJG ---------------------------------------------------------------- - END SUBROUTINE OV_RTNG -!DJG ---------------------------------------------------------------- - -!DJG SUBROUTINE ROUTE_OVERLAND1 -!DJG ---------------------------------------------------------------- - - SUBROUTINE ROUTE_OVERLAND1(dt, & - & gsize,h,qsfc,sox,soy, & - & retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT,SO8RT,SO8RT_D, & - & q_sfcflx_x,q_sfcflx_y) -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Subroutine to route excess rainfall over the watershed -! using a 2d diffusion routing scheme. -! -! Called from: main.f -! -! Will try to formulate this to be called from NOAH -! -! Returns: qsfc=DQOV which in turn becomes DH in head calc. -! -! Created: Adaptded from CASC2D source code -! NOTE: dh from original code has been replaced by qsfc -! dhh replaced by qqsfc -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id, & - up_id,mpp_land_com_real, my_id, mpp_land_com_real8,& - mpp_land_sync -#endif - - IMPLICIT NONE - - -!! Declare Passed variables - - INTEGER, INTENT(IN) :: XX,YY - REAL, INTENT(IN) :: dt, gsize(xx,yy,9) - -!! Declare passed arrays - - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h - REAL, INTENT(IN), DIMENSION(XX,YY) :: qsfc - REAL, INTENT(IN), DIMENSION(XX,YY) :: sox - REAL, INTENT(IN), DIMENSION(XX,YY) :: soy - REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep - REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x, q_sfcflx_y - REAL, INTENT(INOUT) :: QBDRYT - REAL, INTENT(IN), DIMENSION(XX,YY,8) :: SO8RT - REAL*8, DIMENSION(XX,YY) :: QBDRY_tmp, DH - REAL*8, DIMENSION(XX,YY) :: DH_tmp - -!!! Declare Local Variables - - REAL :: dhdx,dhdy,alfax,alfay - REAL :: hh53,qqsfc,hh,dt_new,hmax - REAL :: sfx,sfy - REAL :: tmp_adjust - - INTEGER :: i,j - REAL IXX8,IYY8 - INTEGER IXX0,JYY0,index, SO8RT_D(XX,YY,3) - REAL tmp_gsize,hsum - -!!! Initialize variables - - - -!!! Begin Routing of Excess Rainfall over the Watershed - - DH=0. - DH_tmp=0. - QBDRY_tmp =0. - -!!! Loop to route water - do j=2,YY-1 - do i=2,XX-1 - if (h(I,J).GT.retent_dep(I,J)) then - IXX0 = SO8RT_D(i,j,1) - JYY0 = SO8RT_D(i,j,2) - index = SO8RT_D(i,j,3) - tmp_gsize = 1.0/gsize(i,j,index) - sfx = so8RT(i,j,index)-(h(IXX0,JYY0)-h(i,j))*0.001*tmp_gsize - hmax = h(i,j)*0.001 !Specify max head for mass flux limit... - if(sfx .lt. 1E-20) then - call GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,so8rt,gsize(i,j,:),sfx,XX,YY) - end if - if(IXX0 > 0) then ! do the rest if the lowest grid can be found. - if(sfx .lt. 1E-20) then -#ifdef HYDRO_D - print*, "Message: sfx reset to 1E-20. sfx =",sfx - print*, "i,j,index,IXX0,JYY0",i,j,index,IXX0,JYY0 - print*, "so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index) ", & - so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index) -#endif - sfx = 1E-20 - end if - alfax = sqrt(sfx) / dist_rough(i,j) - hh=(h(i,j)-retent_dep(i,j)) * 0.001 - hh53=hh**(5./3.) - -! Calculate q-flux... - qqsfc = alfax*hh53*dt * tmp_gsize - -!Courant check (simple mass limit on overland flow)... - if (qqsfc.ge.(hmax*dt*tmp_gsize)) qqsfc = hmax*dt*tmp_gsize - -! Accumulate directional fluxes on routing subgrid... - if (IXX0.gt.i) then - q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc * & - (1.0 - 0.5 * (ABS(j-JYY0))) - else if (IXX0.lt.i) then - q_sfcflx_x(I,J) = q_sfcflx_x(I,J) - 1.0 * & - qqsfc * (1.0 - 0.5 * (ABS(j-JYY0))) - else - q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + 0. - end if - if (JYY0.gt.j) then - q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc * & - (1.0 - 0.5 * (ABS(i-IXX0))) - elseif (JYY0.lt.j) then - q_sfcflx_y(I,J) = q_sfcflx_y(I,J) - 1.0 * & - qqsfc * (1.0 - 0.5 * (ABS(i-IXX0))) - else - q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + 0. - end if - - -!DJG put adjustment in for (h) due to qqsfc - -!yw changed as following: - tmp_adjust=qqsfc*1000 - if((h(i,j) - tmp_adjust) <0 ) then -#ifdef HYDRO_D - print*, "Error Warning: surface head is negative: ",i,j,ixx0,jyy0, & - h(i,j) - tmp_adjust -#endif - tmp_adjust = h(i,j) - end if - DH(i,j) = DH(i,j)-tmp_adjust - DH_tmp(ixx0,jyy0) = DH_tmp(ixx0,jyy0) + tmp_adjust - !yw end change - - !DG Boundary adjustments here - !DG Constant Flux Condition -#ifdef MPP_LAND - if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. & - ((ixx0.eq.1) .and.(left_id .lt. 0)) .or. & - ((jyy0.eq.1) .and.(down_id .lt. 0)) .or. & - ((JYY0.eq.YY).and.(up_id .lt. 0)) ) then - QBDRY_tmp(IXX0,JYY0)=QBDRY_tmp(IXX0,JYY0) - qqsfc*1000. -#else - if ((ixx0.eq.XX).or.(ixx0.eq.1).or.(jyy0.eq.1) & - .or.(JYY0.eq.YY )) then - QBDRY(IXX0,JYY0)=QBDRY(IXX0,JYY0) - qqsfc*1000. -#endif - QBDRYT=QBDRYT - qqsfc - DH_tmp(IXX0,JYY0)= DH_tmp(IXX0,JYY0)-tmp_adjust - end if - end if -!! End loop to route sfc water - end if - end do - end do - -#ifdef MPP_LAND -! use double precision to solve the underflow problem. - call MPP_LAND_COM_REAL8(DH_tmp,XX,YY,1) - call MPP_LAND_COM_REAL8(QBDRY_tmp,XX,YY,1) -#endif - QBDRY = QBDRY + QBDRY_tmp - DH = DH+DH_tmp - -#ifdef MPP_LAND - call MPP_LAND_COM_REAL8(DH,XX,YY,99) - call MPP_LAND_COM_REAL(QBDRY,XX,YY,99) -#endif - - H = H + DH - - return - -!DJG ---------------------------------------------------------------------- - end subroutine ROUTE_OVERLAND1 - - -!DJG ---------------------------------------------------------------- - SUBROUTINE GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,sox,tmp_gsize,max,XX,YY) - implicit none - INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY - INTEGER, INTENT(IN) :: I,J - - REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY,8),tmp_gsize(9) - REAL max - IXX0 = -1 - max = 0 - if (h(I,J).LE.retent_dep(I,J)) return - - IXX8 = I - JYY8 = J+1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY) - - IXX8 = I+1 - JYY8 = J+1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY) - - IXX8 = I+1 - JYY8 = J - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY) - - IXX8 = I+1 - JYY8 = J-1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY) - - IXX8 = I - JYY8 = J-1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY) - - IXX8 = I-1 - JYY8 = J-1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY) - - IXX8 = I-1 - JYY8 = J - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY) - - IXX8 = I-1 - JYY8 = J+1 - call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY) - RETURN - END SUBROUTINE GETMAX8DIR - - SUBROUTINE GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox & - ,IXX0,JYY0,max,tmp_gsize,XX,YY) - implicit none - integer,INTENT(INOUT) ::IXX0,JYY0 - INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY - REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY) - REAL, INTENT(INOUT) ::max - real, INTENT(IN) :: tmp_gsize - real :: sfx - - sfx = sox(i,j)-(h(IXX8,JYY8)-h(i,j))*0.001/tmp_gsize - if(sfx .le. 0 ) return - if(max < sfx ) then - IXX0 = IXX8 - JYY0 = JYY8 - max = sfx - end if - - END SUBROUTINE GET8DIR -!DJG ---------------------------------------------------------------- -!DJG SUBROUTINE ROUTE_SUBSURFACE1 -!DJG ---------------------------------------------------------------- - - SUBROUTINE ROUTE_SUBSURFACE1( & - dist,z,qsub,sox,soy, & - latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,SO8RT,SO8RT_D, & - CWATAVAIL,SUBDT) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Subroutine to route subsurface flow through the watershed -! -! Called from: main.f (Noah_router_driver) -! -! Returns: qsub=DQSUB which in turn becomes SUBFLO in head calc. -! -! Created: D. Gochis 3/27/03 -! Adaptded from Wigmosta, 1994 -! -! Modified: D. Gochis 1/05/04 -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id,& - up_id,mpp_land_com_real8,my_id,mpp_land_com_real -#endif - - IMPLICIT NONE - - -!! Declare Passed variables - - INTEGER, INTENT(IN) :: XX,YY - -!! Declare passed arrays - - REAL, INTENT(IN), DIMENSION(XX,YY) :: z - REAL, INTENT(IN), DIMENSION(XX,YY) :: sox - REAL, INTENT(IN), DIMENSION(XX,YY) :: soy - REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat - REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL - REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep - REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY - REAL, INTENT(INOUT) :: QSUBDRYT - REAL*8, DIMENSION(XX,YY) :: qsub_tmp,QSUBDRY_tmp -!yw INTEGER, INTENT(OUT) :: flag - REAL, INTENT(IN) :: dist(xx,yy,9),SUBDT - -!!! Declare Local Variables - - REAL :: dzdx,dzdy,beta,gamma - REAL :: qqsub,hh,ksat - - REAL :: SO8RT(XX,YY,8) - INTEGER :: SO8RT_D(XX,YY,3), rt_option - - -!!! Initialize variables - - REAL, PARAMETER :: nexp=1.0 ! local power law exponent - integer IXX0,JYY0,index,i,j - real tmp_gsize - -! temporary set it to be 2. Should be passed in. -!yw soldep = 2. -! Begin Subsurface routing - - - -!!! Loop to route water in x-direction - qsub_tmp = 0. - QSUBDRY_tmp = 0. - -#ifdef HYDRO_D - write(6,*) "call subsurface routing xx= , yy =", yy, xx -#endif - - do j=2,YY-1 - do i=2,XX-1 - - - if(i.ge.2.AND.i.le.XX-1.AND.j.ge.2.AND.j.le.YY-1) then !if grdcl chk -! check for boundary grid point? - IXX0 = SO8RT_D(i,j,1) - JYY0 = SO8RT_D(i,j,2) - - index = SO8RT_D(i,j,3) - - if(dist(i,j,index) .le. 0) then -#ifdef HYDRO_D - write(6,*) "Error: dist(i,j,index) is <= zero " - call hydro_stop("ROUTE_SUBSURFACE1") -#endif - endif - if(soldep(i,j) .eq. 0) then -#ifdef HYDRO_D - write(6,*) "Error: soldep is = zero " - call hydro_stop("ROUTE_SUBSURFACE1") -#endif - endif - - tmp_gsize = 1.0/dist(i,j,index) - - - dzdx= (z(i,j) - z(IXX0,JYY0) )* tmp_gsize - beta=so8RT(i,j,index) + dzdx - - if(beta .lt. 1E-20 ) then !if-then for direction... - call GETSUB8(IXX0,JYY0,I,J,Z,so8rt,dist(i,j,:),beta,XX,YY) - end if - if(beta .gt. 0) then !if-then for flux calc - if(beta .lt. 1E-20 ) then -#ifdef HYDRO_D - print*, "Message: beta need to be reset to 1E-20. beta = ",beta -#endif - beta = 1E-20 - end if - -! do the rest if the lowest grid can be found. - hh=(1-(z(i,j)/soldep(i,j)))**nexp - ksat=latksat(i,j) - - if (hh .lt. 0.) then -#ifdef HYDRO_D - print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), & - soldep(i,j) - call hydro_stop("ROUTE_SUBSURFACE1") -#endif - end if - -!err. tan slope gamma=-1.0*((gsize*ksat*soldep(i,j))/nexp)*tan(beta) - gamma=-1.0*((dist(i,j,index)*ksat*soldep(i,j))/nexp)*beta - qqsub = gamma * hh - - qsub(i,j) = qsub(i,j) + qqsub - qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) - qqsub - -!!DJG Error Checks... - if(qqsub .gt. 0) then -#ifdef HYDRO_D - print*, "Error: qqsub should be negative, qqsub =",qqsub,& - "gamma=",gamma,"hh=",hh,"beta=",beta,"dzdx=",dzdx,& - "so8RT=",so8RT(i,j,index),"latksat=",ksat, & - "tan(beta)=",tan(beta),i,j,z(i,j),z(IXX0,JYY0) - print*, "ixx0=",ixx0, "jyy0=",jyy0 - print*, "soldep =", soldep(i,j), "nexp=",nexp - call hydro_stop("ROUTE_SUBSURFACE1") -#endif - end if - - - - -! Boundary adjustments -#ifdef MPP_LAND - if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. & - ((ixx0.eq.1) .and.(left_id .lt. 0)) .or. & - ((jyy0.eq.1) .and.(down_id .lt. 0)) .or. & - ((JYY0.eq.YY).and.(up_id .lt. 0)) ) then -#else - if ((ixx0.eq.1).or.(ixx0.eq.xx).or.(jyy0.eq.1).or.(jyy0.eq.yy)) then -#endif - qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) + qqsub - QSUBDRY_tmp(ixx0,jyy0) = QSUBDRY_tmp(ixx0,jyy0) + qqsub - - QSUBDRYT = QSUBDRYT + qqsub - end if - -998 continue - -!! End loop to route sfc water in x-direction - end if !endif for flux calc - - endif !! Endif for gridcell check... - - - end do !endif for i-dim -!CRNT debug if(flag.eq.-99) exit !exit loop for courant violation... - end do !endif for j-dim - -#ifdef MPP_LAND - - call MPP_LAND_COM_REAL8(qsub_tmp,XX,YY,1) - call MPP_LAND_COM_REAL8(QSUBDRY_tmp,XX,YY,1) -#endif - qsub = qsub + qsub_tmp - QSUBDRY= QSUBDRY + QSUBDRY_tmp - - - do j=2,YY-1 - do i=2,XX-1 - if(dist(i,j,9) .le. 0) then -#ifdef HYDRO_D - write(6,*) "Error: dist(i,j,9) is <= zero " - call hydro_stop("ROUTE_SUBSURFACE1") -#endif - endif - if(CWATAVAIL(i,j).lt.ABS(qsub(i,j))/dist(i,j,9)*SUBDT) THEN - qsub(i,j) = -1.0*CWATAVAIL(i,j) - end if - end do - end do -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(qsub,XX,YY,99) - call MPP_LAND_COM_REAL(QSUBDRY,XX,YY,99) -#endif - - - return -!DJG------------------------------------------------------------ - end subroutine ROUTE_SUBSURFACE1 -!DJG------------------------------------------------------------ - -!DJG------------------------------------------------------------ - - - SUBROUTINE GETSUB8(IXX0,JYY0,I,J,Z,sox,tmp_gsize,max,XX,YY) - implicit none - INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY - INTEGER, INTENT(IN) :: I,J - - REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY,8),tmp_gsize(9) - REAL max - max = -1 - - IXX8 = I - JYY8 = J+1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY) - - IXX8 = I+1 - JYY8 = J+1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY) - - IXX8 = I+1 - JYY8 = J - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY) - - IXX8 = I+1 - JYY8 = J-1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY) - - IXX8 = I - JYY8 = J-1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY) - - IXX8 = I-1 - JYY8 = J-1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY) - - IXX8 = I-1 - JYY8 = J - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY) - - IXX8 = I-1 - JYY8 = J+1 - call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY) - RETURN - END SUBROUTINE GETSUB8 - - SUBROUTINE GETSUB8DIR(IXX8,JYY8,I,J,Z,sox,IXX0,JYY0,max,tmp_gsize,XX,YY) - implicit none - integer,INTENT(INOUT) ::IXX0,JYY0 - INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY - REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY) - REAL, INTENT(INOUT) ::max - real, INTENT(IN) :: tmp_gsize - real :: beta , dzdx - - dzdx= (z(i,j) - z(IXX0,JYY0) )/tmp_gsize - beta=sox(i,j) + dzdx - if(max < beta ) then - IXX0 = IXX8 - JYY0 = JYY8 - max = beta - end if - - END SUBROUTINE GETSUB8DIR -!DJG ---------------------------------------------------------------------- - -!DJG SUBROUTINE ROUTE_OVERLAND2 -!DJG ---------------------------------------------------------------- - - SUBROUTINE ROUTE_OVERLAND2 (dt, & - & dist,h,qsfc,sox,soy, & - & retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT, & - & q_sfcflx_x,q_sfcflx_y) - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Subroutine to route excess rainfall over the watershed -! using a 2d diffusion routing scheme. -! -! Called from: main.f -! -! Will try to formulate this to be called from NOAH -! -! Returns: qsfc=DQOV which in turn becomes DH in head calc. -! -! Created: Adaptded from CASC2D source code -! NOTE: dh from original code has been replaced by qsfc -! dhh replaced by qqsfc -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id,& - up_id,mpp_land_com_real,MPP_LAND_UB_COM, & - MPP_LAND_LR_COM,mpp_land_com_integer -#endif - - IMPLICIT NONE - - -!! Declare Passed variables - - real :: gsize - INTEGER, INTENT(IN) :: XX,YY - REAL, INTENT(IN) :: dt , dist(XX,YY,9) - -!! Declare passed arrays - - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: qsfc - REAL, INTENT(IN), DIMENSION(XX,YY) :: sox - REAL, INTENT(IN), DIMENSION(XX,YY) :: soy - REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep - REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY - REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x,q_sfcflx_y - REAL, INTENT(INOUT) :: QBDRYT - REAL :: DH(XX,YY) - -!!! Declare Local Variables - - REAL :: dhdx,dhdy,alfax,alfay - REAL :: hh53,qqsfc,hh,dt_new - REAL :: sfx,sfy - REAL :: tmp_adjust - - INTEGER :: i,j - -!!! Initialize variables - - - - -!!! Begin Routing of Excess Rainfall over the Watershed - - - DH = 0 -!!! Loop to route water in x-direction - do j=1,YY - do i=1,XX - - -! check for boundary gridpoint? - if (i.eq.XX) GOTO 998 - gsize = dist(i,j,3) - - -! check for detention storage? - if (h(i,j).lt.retent_dep(i,j).AND. & - h(i+1,j).lt.retent_dep(i+1,j)) GOTO 998 - - dhdx = (h(i+1,j)/1000. - h(i,j)/1000.) / gsize ! gisze-(m),h-(mm) - - sfx = (sox(i,j)-dhdx+1E-30) - if (abs(sfx).lt.1E-20) sfx=1E-20 - alfax = ((abs(sfx))**0.5)/dist_rough(i,j) - if (sfx.lt.0.) then - hh=(h(i+1,j)-retent_dep(i+1,j))/1000. - else - hh=(h(i,j)-retent_dep(i,j))/1000. - end if - - if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 998 - if (hh.lt.0.) then - GOTO 998 - end if - - hh53=hh**(5./3.) - - -! Calculate q-flux... (units (m)) - qqsfc = (sfx/abs(sfx))*alfax*hh53*dt/gsize - q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc - -!DJG put adjustment in for (h) due to qqsfc - -!yw changed as following: - tmp_adjust=qqsfc*1000 - if(tmp_adjust .le. 0 ) GOTO 998 - if((h(i,j) - tmp_adjust) <0 ) then -#ifdef HYDRO_D - print*, "Error Warning: surface head is negative: ",i,j -#endif - tmp_adjust = h(i,j) - end if - if((h(i+1,j) + tmp_adjust) <0) then -#ifdef HYDRO_D - print*, "Error Warning: surface head is negative: ",i+1,j -#endif - tmp_adjust = -1*h(i+1,j) - end if - Dh(i,j) = Dh(i,j)-tmp_adjust - Dh(i+1,j) = Dh(i+1,j) + tmp_adjust -!yw end change - - - -!DG Boundary adjustments here -!DG Constant Flux Condition -#ifdef MPP_LAND - if ((i.eq.1).AND.(sfx.lt.0).and. & - (left_id .lt. 0) ) then -#else - if ((i.eq.1).AND.(sfx.lt.0)) then -#endif - Dh(i,j) = Dh(i,j) + qqsfc*1000. - QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000. - QBDRYT=QBDRYT + qqsfc*1000. -#ifdef MPP_LAND - else if ( (i.eq.(XX-1)).AND.(sfx.gt.0) & - .and. (right_id .lt. 0) ) then -#else - else if ((i.eq.(XX-1)).AND.(sfx.gt.0)) then -#endif - tmp_adjust = qqsfc*1000. - if(h(i+1,j).lt.tmp_adjust) tmp_adjust = h(i+1,j) - Dh(i+1,j) = Dh(i+1,j) - tmp_adjust -!DJG Re-assign h(i+1) = 0.0 when <0.0 (from rounding/truncation error) - QBDRY(I+1,J)=QBDRY(I+1,J) - tmp_adjust - QBDRYT=QBDRYT - tmp_adjust - end if - - -998 continue - -!! End loop to route sfc water in x-direction - end do - end do - - H = H + DH -#ifdef MPP_LAND - call MPP_LAND_LR_COM(H,XX,YY,99) - call MPP_LAND_LR_COM(QBDRY,XX,YY,99) -#endif - - - DH = 0 -!!!! Loop to route water in y-direction - do j=1,YY - do i=1,XX - -!! check for boundary grid point? - if (j.eq.YY) GOTO 999 - gsize = dist(i,j,1) - - -!! check for detention storage? - if (h(i,j).lt.retent_dep(i,j).AND. & - h(i,j+1).lt.retent_dep(i,j+1)) GOTO 999 - - dhdy = (h(i,j+1)/1000. - h(i,j)/1000.) / gsize - - sfy = (soy(i,j)-dhdy+1E-30) - if (abs(sfy).lt.1E-20) sfy=1E-20 - alfay = ((abs(sfy))**0.5)/dist_rough(i,j) - if (sfy.lt.0.) then - hh=(h(i,j+1)-retent_dep(i,j+1))/1000. - else - hh=(h(i,j)-retent_dep(i,j))/1000. - end if - - if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 999 - if (hh.lt.0.) then - GOTO 999 - end if - - hh53=hh**(5./3.) - -! Calculate q-flux... - qqsfc = (sfy/abs(sfy))*alfay*hh53*dt / gsize - q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc - - -!DJG put adjustment in for (h) due to qqsfc -!yw h(i,j) = h(i,j)-qqsfc*1000. -!yw h(i,j+1) = h(i,j+1) + qqsfc*1000. -!yw changed as following: - tmp_adjust=qqsfc*1000 - if(tmp_adjust .le. 0 ) GOTO 999 - - if((h(i,j) - tmp_adjust) <0 ) then -#ifdef HYDRO_D - print*, "Error Warning: surface head is negative: ",i,j -#endif - tmp_adjust = h(i,j) - end if - if((h(i,j+1) + tmp_adjust) <0) then -#ifdef HYDRO_D - print*, "Error Warning: surface head is negative: ",i,j+1 -#endif - tmp_adjust = -1*h(i,j+1) - end if - Dh(i,j) = Dh(i,j)-tmp_adjust - Dh(i,j+1) = Dh(i,j+1) + tmp_adjust -!yw end change - -! qsfc(i,j) = qsfc(i,j)-qqsfc -! qsfc(i,j+1) = qsfc(i,j+1) + qqsfc -!!DG Boundary adjustments here -!!DG Constant Flux Condition -#ifdef MPP_LAND - if ((j.eq.1).AND.(sfy.lt.0) & - .and. (down_id .lt. 0) ) then -#else - if ((j.eq.1).AND.(sfy.lt.0)) then -#endif - Dh(i,j) = Dh(i,j) + qqsfc*1000. - QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000. - QBDRYT=QBDRYT + qqsfc*1000. -#ifdef MPP_LAND - else if ((j.eq.(YY-1)).AND.(sfy.gt.0) & - .and. (up_id .lt. 0) ) then -#else - else if ((j.eq.(YY-1)).AND.(sfy.gt.0)) then -#endif - tmp_adjust = qqsfc*1000. - if(h(i,j+1).lt.tmp_adjust) tmp_adjust = h(i,j+1) - Dh(i,j+1) = Dh(i,j+1) - tmp_adjust -!DJG Re-assign h(j+1) = 0.0 when <0.0 (from rounding/truncation error) - QBDRY(I,J+1)=QBDRY(I,J+1) - tmp_adjust - QBDRYT=QBDRYT - tmp_adjust - end if - -999 continue - -!!!! End loop to route sfc water in y-direction - end do - end do - - H = H +DH -#ifdef MPP_LAND - call MPP_LAND_UB_COM(H,XX,YY,99) - call MPP_LAND_UB_COM(QBDRY,XX,YY,99) -#endif - return - -!DJG ---------------------------------------------------------------------- - end subroutine ROUTE_OVERLAND2 - - -!DJG ---------------------------------------------------------------------- - - -!DJG----------------------------------------------------------------------- -!DJG SUBROUTINE TER_ADJ_SOL - Terrain adjustment of incoming solar radiation -!DJG----------------------------------------------------------------------- - SUBROUTINE TER_ADJ_SOL(IX,JX,SO8LD_D,TSLP,SHORT,XLAT,XLONG,olddate,DT) - -#ifdef MPP_LAND - use module_mpp_land, only: my_id, io_id, & - mpp_land_bcast_int1 -#endif - implicit none - integer,INTENT(IN) :: IX,JX - INTEGER,INTENT(in), DIMENSION(IX,JX,3) :: SO8LD_D - real,INTENT(IN), DIMENSION(IX,JX) :: XLAT,XLONG - real,INTENT(IN) :: DT - real,INTENT(INOUT), DIMENSION(IX,JX) :: SHORT - character(len=19) :: olddate - -! Local Variables... - real, dimension(IX,JX) ::TSLP,TAZI - real, dimension(IX,JX) ::SOLDN - real :: SOLDEC,DGRD,ITIME2,HRANGLE - real :: BINSH,SOLZANG,SOLAZI,INCADJ - real :: TAZIR,TSLPR,LATR,LONR,SOLDNADJ - integer :: JULDAY0,HHTIME0,MMTIME0,YYYY0,MM0,DD0 - integer :: JULDAY,HHTIME,MMTIME,YYYY,MM,DD - integer :: I,J - - -!---------------------------------------------------------------------- -! SPECIFY PARAMETERS and VARIABLES -!---------------------------------------------------------------------- - - JULDAY = 0 - SOLDN = SHORT - DGRD = 3.14159/180. - -! Set up time variables... -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - read(olddate(1:4),"(I4)") YYYY0 ! real-time year (GMT) - read(olddate(6:7),"(I2.2)") MM0 ! real-time month (GMT) - read(olddate(9:10),"(I2.2)") DD0 ! real-time day (GMT) - read(olddate(12:13),"(I2.2)") HHTIME0 ! real-time hour (GMT) - read(olddate(15:16),"(I2.2)") MMTIME0 ! real-time minutes (GMT) -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(YYYY0) - call mpp_land_bcast_int1(MM0) - call mpp_land_bcast_int1(DD0) - call mpp_land_bcast_int1(HHTIME0) - call mpp_land_bcast_int1(MMTIME0) -#endif - - -! Set up terrain variables...(returns TSLP&TAZI in radians) - call SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) - -!---------------------------------------------------------------------- -! BEGIN LOOP THROUGH GRID -!---------------------------------------------------------------------- - DO J=1,JX - DO I=1,IX - YYYY = YYYY0 - MM = MM0 - DD = DD0 - HHTIME = HHTIME0 - MMTIME = MMTIME0 - call GMT2LOCAL(1,1,XLONG(i,j),YYYY,MM,DD,HHTIME,MMTIME,DT) - call JULDAY_CALC(YYYY,MM,DD,JULDAY) - -! Convert to radians... - LATR = XLAT(I,J) !send solsub local lat in deg - LONR = XLONG(I,J) !send solsub local lon in deg - TSLPR = TSLP(I,J)/DGRD !send solsub local slp in deg - TAZIR = TAZI(I,J)/DGRD !send solsub local azim in deg - -!Call SOLSUB to return terrain adjusted incoming solar radiation... -! SOLSUB taken from Whiteman and Allwine, 1986, Environ. Software. - - call SOLSUB(LONR,LATR,TAZIR,TSLPR,SOLDN(I,J),YYYY,MM, & - DD,HHTIME,MMTIME,SOLDNADJ,SOLZANG,SOLAZI,INCADJ) - - SOLDN(I,J)=SOLDNADJ - - ENDDO - ENDDO - - SHORT = SOLDN - - return - end SUBROUTINE TER_ADJ_SOL -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE TER_ADJ_SOL -!DJG----------------------------------------------------------------------- - - -!DJG----------------------------------------------------------------------- -!DJG SUBROUTINE GMT2LOCAL -!DJG----------------------------------------------------------------------- - subroutine GMT2LOCAL(IX,JX,XLONG,YY,MM,DD,HH,MIN,DT) - - implicit none - -!!! Declare Passed Args. - - INTEGER, INTENT(INOUT) :: yy,mm,dd,hh,min - INTEGER, INTENT(IN) :: IX,JX - REAL,INTENT(IN), DIMENSION(IX,JX) :: XLONG - REAL,INTENT(IN) :: DT - -!!! Declare local variables - - integer :: i,j,minflag,hhflag,ddflag,mmflag,yyflag - integer :: adj_min,lst_adj_min,lst_adj_hh,adj_hh - real, dimension(IX,JX) :: TDIFF - real :: tmp - integer :: yyinit,mminit,ddinit,hhinit,mininit - -!!! Initialize flags - hhflag=0 - ddflag=0 - mmflag=0 - yyflag=0 - -!!! Set up constants... - yyinit = yy - mminit = mm - ddinit = dd - hhinit = hh - mininit = min - - -! Loop through data... - do j=1,JX - do i=1,IX - -! Reset yy,mm,dd... - yy = yyinit - mm = mminit - dd = ddinit - hh = hhinit - min = mininit - -!!! Set up adjustments... -! - assumes +E , -W longitude and 0.06667 hr/deg (=24/360) - TDIFF(I,J) = XLONG(I,J)*0.06667 ! time offset in hr - tmp = TDIFF(I,J) - lst_adj_hh = INT(tmp) - lst_adj_min = NINT(MOD(int(tmp),1)*60.) + int(DT/2./60.) ! w/ 1/2 timestep adjustment... - -!!! Process Minutes... - adj_min = min+lst_adj_min - if (adj_min.lt.0) then - min=60+adj_min - lst_adj_hh = lst_adj_hh - 1 - else if (adj_min.ge.0.AND.adj_min.lt.60) then - min=adj_min - else if (adj_min.ge.60) then - min=adj_min-60 - lst_adj_hh = lst_adj_hh + 1 - end if - -!!! Process Hours - adj_hh = hh+lst_adj_hh - if (adj_hh.lt.0) then - hh = 24+adj_hh - ddflag=1 - else if (adj_hh.ge.0.AND.adj_hh.lt.24) then - hh=adj_hh - else if (adj_hh.ge.24) then - hh=adj_hh-24 - ddflag = 2 - end if - - - -!!! Process Days, Months, Years -! Subtract a day - if (ddflag.eq.1) then - if (dd.gt.1) then - dd=dd-1 - else - if (mm.eq.1) then - mm=12 - yy=yy-1 - else - mm=mm-1 - end if - if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & - (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & - (mm.eq.12)) then - dd=31 - else - -!!! Adjustment for leap years!!! - if(mm.eq.2) then - if(MOD(yy,4).eq.0) then - dd=29 - else - dd=28 - end if - end if - if(mm.ne.2) dd=30 - end if - end if - end if - -! Add a day - if (ddflag.eq.2) then - if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. & - (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. & - (mm.eq.12)) then - if (dd.eq.31) then - dd=1 - if (mm.eq.12) then - mm=1 - yy=yy+1 - else - mm=mm+1 - end if - else - dd=dd+1 - end if - -!!! Adjustment for leap years!!! - else if (mm.eq.2) then - if(MOD(yy,4).eq.0) then - if (dd.eq.29) then - dd=1 - mm=3 - else - dd=dd+1 - end if - else - if (dd.eq.28) then - dd=1 - mm=3 - else - dd=dd+1 - end if - end if - else - if (dd.eq.30) then - dd=1 - mm=mm+1 - else - dd=dd+1 - end if - end if - - end if - - end do !i-loop - end do !j-loop - - return - end subroutine - -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE GMT2LOCAL -!DJG----------------------------------------------------------------------- - - - -!DJG----------------------------------------------------------------------- -!DJG SUBROUTINE JULDAY_CALC -!DJG----------------------------------------------------------------------- - subroutine JULDAY_CALC(YYYY,MM,DD,JULDAY) - - implicit none - integer,intent(in) :: YYYY,MM,DD - integer,intent(out) :: JULDAY - - integer :: resid - integer julm(13) - DATA JULM/0, 31, 59, 90, 120, 151, 181, 212, 243, 273, & - 304, 334, 365 / - - integer LPjulm(13) - DATA LPJULM/0, 31, 60, 91, 121, 152, 182, 213, 244, 274, & - 305, 335, 366 / - - resid = MOD(YYYY,4) !Set up leap year check... - - if (resid.ne.0) then !If not a leap year.... - JULDAY = JULM(MM) + DD - else !If a leap year... - JULDAY = LPJULM(MM) + DD - end if - - RETURN - END subroutine JULDAY_CALC -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE JULDAY -!DJG----------------------------------------------------------------------- - -!DJG----------------------------------------------------------------------- -!DJG SUBROUTINE SLOPE_ASPECT -!DJG----------------------------------------------------------------------- - subroutine SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI) - - implicit none - integer, INTENT(IN) :: IX,JX -! real,INTENT(in),DIMENSION(IX,JX) :: TSLP !terrain slope (m/m) - real,INTENT(OUT),DIMENSION(IX,JX) :: TAZI !terrain aspect (deg) - - INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D - real :: DGRD - integer :: i,j - -! TSLP = 0. !Initialize as flat - TAZI = 0. !Initialize as north facing - -! Find steepest descent slope and direction... - do j=1,JX - do i=1,IX -! TSLP(I,J) = TANH(Vmax(i,j)) ! calculate slope in radians... - -! Convert steepest slope and aspect to radians... - IF (SO8LD_D(i,j,3).eq.1) then - TAZI(I,J) = 0.0 - ELSEIF (SO8LD_D(i,j,3).eq.2) then - TAZI(I,J) = 45.0 - ELSEIF (SO8LD_D(i,j,3).eq.3) then - TAZI(I,J) = 90.0 - ELSEIF (SO8LD_D(i,j,3).eq.4) then - TAZI(I,J) = 135.0 - ELSEIF (SO8LD_D(i,j,3).eq.5) then - TAZI(I,J) = 180.0 - ELSEIF (SO8LD_D(i,j,3).eq.6) then - TAZI(I,J) = 225.0 - ELSEIF (SO8LD_D(i,j,3).eq.7) then - TAZI(I,J) = 270.0 - ELSEIF (SO8LD_D(i,j,3).eq.8) then - TAZI(I,J) = 315.0 - END IF - - DGRD = 3.141593/180. - TAZI(I,J) = TAZI(I,J)*DGRD ! convert azimuth to radians... - - END DO - END DO - - RETURN - END subroutine SLOPE_ASPECT -!DJG----------------------------------------------------------------------- -!DJG END SUBROUTINE SLOPE_ASPECT -!DJG----------------------------------------------------------------------- - -!DJG---------------------------------------------------------------- -!DJG SUBROUTINE SOLSUB -!DJG---------------------------------------------------------------- - SUBROUTINE SOLSUB(LONG,LAT,AZ,IN,SC,YY,MO,IDA,IHR,MM,OUT1, & - OUT2,OUT3,INCADJ) - - -! Notes.... - - implicit none - logical :: daily, first - integer :: yy,mo,ida,ihr,mm,d - integer,dimension(12) :: nday - real :: lat,long,longcor,longsun,in,inslo - real :: az,sc,out1,out2,out3,cosbeta,dzero,eccent,pi,calint - real :: rtod,decmax,omega,onehr,omd,omdzero,rdvecsq,sdec - real :: declin,cdec,arg,declon,sr,stdmrdn,b,em,timnoon,azslo - real :: slat,clat,caz,saz,sinc,cinc,hinc,h,cosz,extra,extslo - real :: t1,z,cosa,a,cosbeta_flat,INCADJ - integer :: HHTIME,MMTIME,i,ik - real, dimension(4) :: ACOF,BCOF - -! Constants - daily=.FALSE. - ACOF(1) = 0.00839 - ACOF(2) = -0.05391 - ACOF(3) = -0.00154 - ACOF(4) = -0.0022 - BCOF(1) = -0.12193 - BCOF(2) = -0.15699 - BCOF(3) = -0.00657 - BCOF(4) = -0.00370 - DZERO = 80. - ECCENT = 0.0167 - PI = 3.14159 - CALINT = 1. - RTOD = PI / 180. - DECMAX=(23.+26./60.)*RTOD - OMEGA=2*PI/365. - ONEHR=15.*RTOD - -! Calculate Julian Day... - D = 0 - call JULDAY_CALC(YY,MO,IDA,D) - -! Ratio of radius vectors squared... - OMD=OMEGA*D - OMDZERO=OMEGA*DZERO -! RDVECSQ=1./(1.-ECCENT*COS(OMD))**2 - RDVECSQ = 1. ! no adjustment for orbital changes when coupled to HRLDAS... - -! Declination of sun... - LONGSUN=OMEGA*(D-Dzero)+2.*ECCENT*(SIN(OMD)-SIN(OMDZERO)) - DECLIN=ASIN(SIN(DECMAX)*SIN(LONGSUN)) - SDEC=SIN(DECLIN) - CDEC=COS(DECLIN) - -! Check for Polar Day/night... - ARG=((PI/2.)-ABS(DECLIN))/RTOD - IF(ABS(LAT).GT.ARG) THEN - IF((LAT.GT.0..AND.DECLIN.LT.0) .OR. & - (LAT.LT.0..AND.DECLON.GT.0.)) THEN - OUT1 = 0. - OUT2 = 0. - OUT3 = 0. - RETURN - ENDIF - SR=-1.*PI - ELSE - -! Calculate sunrise hour angle... - SR=-1.*ABS(ACOS(-1.*TAN(LAT*RTOD)*TAN(DECLIN))) - END IF - -! Find standard meridian for site - STDMRDN=NINT(LONG/15.)*15. - LONGCOR=(LONG-STDMRDN)/15. - -! Compute time correction from equation of time... - B=2.*PI*(D-.4)/365 - EM=0. - DO I=1,4 - EM=EM+(BCOF(I)*SIN(I*B)+ACOF(I)*COS(I*B)) - END DO - -! Compute time of solar noon... - TIMNOON=12.-EM-LONGCOR - -! Set up a few more terms... - AZSLO=AZ*RTOD - INSLO=IN*RTOD - SLAT=SIN(LAT*RTOD) - CLAT=COS(LAT*RTOD) - CAZ=COS(AZSLO) - SAZ=SIN(AZSLO) - SINC=SIN(INSLO) - CINC=COS(INSLO) - -! Begin solar radiation calculations...daily first, else instantaneous... - IF (DAILY) THEN ! compute daily integrated values...(Not used in HRLDAS!) - IHR=0 - MM=0 - HINC=CALINT*ONEHR/60. - IK=(2.*ABS(SR)/HINC)+2. - FIRST=.TRUE. - OUT1=0. - DO I=1,IK - H=SR+HINC*FLOAT(I-1) - COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) - COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & - SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & - SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) - EXTRA=SC*RDVECSQ*COSZ - IF(EXTRA.LE.0.) EXTRA=0. - EXTSLO=SC*RDVECSQ*COSBETA - IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. - IF(FIRST .AND. EXTSLO.GT.0.) THEN - OUT2=(H-HINC)/ONEHR+TIMNOON - FIRST = .FALSE. - END IF - IF(.NOT.FIRST .AND. EXTSLO.LE.0.) OUT3=H/ONEHR+TIMNOON - OUT1=EXTSLO+OUT1 - END DO - OUT1=OUT1*CALINT*60./1000000. - - ELSE ! Compute instantaneous values...(Is used in HRLDAS!) - - T1=FLOAT(IHR)+FLOAT(MM)/60. - H=ONEHR*(T1-TIMNOON) - COSZ=SLAT*SDEC+CLAT*CDEC*COS(H) - -! Assuming HRLDAS forcing already accounts for season, time of day etc, -! subtract out the component of adjustment that would occur for -! a flat surface, this should leave only the sloped component remaining - - COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- & - SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ & - SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC) - - COSBETA_FLAT=CDEC*CLAT*COS(H)+SDEC*SLAT - - INCADJ = COSBETA+(1-COSBETA_FLAT) - - EXTRA=SC*RDVECSQ*COSZ - IF(EXTRA.LE.0.) EXTRA=0. - EXTSLO=SC*RDVECSQ*INCADJ -! IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0. !remove check for HRLDAS. - OUT1=EXTSLO - Z=ACOS(COSZ) - COSA=(SLAT*COSZ-SDEC)/(CLAT*SIN(Z)) - IF(COSA.LT.-1.) COSA=-1. - IF(COSA.GT.1.) COSA=1. - A=ABS(ACOS(COSA)) - IF(H.LT.0.) A=-A - OUT2=Z/RTOD - OUT3=A/RTOD+180 - - END IF ! End if for daily vs instantaneous values... - -!DJG----------------------------------------------------------------------- - RETURN - END SUBROUTINE SOLSUB -!DJG----------------------------------------------------------------------- - - subroutine seq_land_SO8(SO8LD_D,Vmax,TERR,dx,ix,jx) - implicit none - integer :: ix,jx,i,j - REAL, DIMENSION(IX,JX,8) :: SO8LD - INTEGER, DIMENSION(IX,JX,3) :: SO8LD_D - real,DIMENSION(IX,JX) :: TERR - real :: dx(ix,jx,9),Vmax(ix,jx) - SO8LD_D = -1 - do j = 2, jx -1 - do i = 2, ix -1 - SO8LD(i,j,1) = (TERR(i,j)-TERR(i,j+1))/dx(i,j,1) - SO8LD_D(i,j,1) = i - SO8LD_D(i,j,2) = j + 1 - SO8LD_D(i,j,3) = 1 - Vmax(i,j) = SO8LD(i,j,1) - - SO8LD(i,j,2) = (TERR(i,j)-TERR(i+1,j+1))/DX(i,j,2) - if(SO8LD(i,j,2) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i + 1 - SO8LD_D(i,j,2) = j + 1 - SO8LD_D(i,j,3) = 2 - Vmax(i,j) = SO8LD(i,j,2) - end if - SO8LD(i,j,3) = (TERR(i,j)-TERR(i+1,j))/DX(i,j,3) - if(SO8LD(i,j,3) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i + 1 - SO8LD_D(i,j,2) = j - SO8LD_D(i,j,3) = 3 - Vmax(i,j) = SO8LD(i,j,3) - end if - SO8LD(i,j,4) = (TERR(i,j)-TERR(i+1,j-1))/DX(i,j,4) - if(SO8LD(i,j,4) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i + 1 - SO8LD_D(i,j,2) = j - 1 - SO8LD_D(i,j,3) = 4 - Vmax(i,j) = SO8LD(i,j,4) - end if - SO8LD(i,j,5) = (TERR(i,j)-TERR(i,j-1))/DX(i,j,5) - if(SO8LD(i,j,5) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - SO8LD_D(i,j,2) = j - 1 - SO8LD_D(i,j,3) = 5 - Vmax(i,j) = SO8LD(i,j,5) - end if - SO8LD(i,j,6) = (TERR(i,j)-TERR(i-1,j-1))/DX(i,j,6) - if(SO8LD(i,j,6) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - 1 - SO8LD_D(i,j,2) = j - 1 - SO8LD_D(i,j,3) = 6 - Vmax(i,j) = SO8LD(i,j,6) - end if - SO8LD(i,j,7) = (TERR(i,j)-TERR(i-1,j))/DX(i,j,7) - if(SO8LD(i,j,7) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - 1 - SO8LD_D(i,j,2) = j - SO8LD_D(i,j,3) = 7 - Vmax(i,j) = SO8LD(i,j,7) - end if - SO8LD(i,j,8) = (TERR(i,j)-TERR(i-1,j+1))/DX(i,j,8) - if(SO8LD(i,j,8) .gt. Vmax(i,j) ) then - SO8LD_D(i,j,1) = i - 1 - SO8LD_D(i,j,2) = j + 1 - SO8LD_D(i,j,3) = 8 - Vmax(i,j) = SO8LD(i,j,8) - end if - enddo - enddo - Vmax = TANH(Vmax) - return - end subroutine seq_land_SO8 - -#ifdef MPP_LAND - subroutine MPP_seq_land_SO8(SO8LD_D,Vmax,TERRAIN,dx,ix,jx,& - global_nx,global_ny) - - use module_mpp_land, only: my_id, io_id, & - write_io_real,decompose_data_int,decompose_data_real - - implicit none - integer,intent(in) :: ix,jx,global_nx,global_ny - INTEGER, intent(inout),DIMENSION(IX,JX,3) :: SO8LD_D -! real,intent(in), DIMENSION(IX,JX) :: TERRAIN - real,DIMENSION(IX,JX) :: TERRAIN - real,intent(out),dimension(ix,jx) :: Vmax - real,intent(in) :: dx(ix,jx,9) - real :: g_dx(ix,jx,9) - - real,DIMENSION(global_nx,global_ny) :: g_TERRAIN - real,DIMENSION(global_nx,global_ny) :: g_Vmax - integer,DIMENSION(global_nx,global_ny,3) :: g_SO8LD_D - integer :: k - - g_SO8LD_D = 0 - g_Vmax = 0 - - do k = 1, 9 - call write_IO_real(dx(:,:,k),g_dx(:,:,k)) - end do - - call write_IO_real(TERRAIN,g_TERRAIN) - if(my_id .eq. IO_id) then - call seq_land_SO8(g_SO8LD_D,g_Vmax,g_TERRAIN,g_dx,global_nx,global_ny) - endif - call decompose_data_int(g_SO8LD_D(:,:,3),SO8LD_D(:,:,3)) - call decompose_data_real(g_Vmax,Vmax) - return - end subroutine MPP_seq_land_SO8 - -#endif - - - - subroutine disaggregateDomain_drv(did) - use module_RT_data, only: rt_domain - use module_namelist, only: nlst_rt - integer :: did - call disaggregateDomain( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,& - RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT,nlst_rt(did)%AGGFACTRT,RT_DOMAIN(did)%SICE, & - RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%SH2OX,RT_DOMAIN(did)%INFXSRT, & - rt_domain(did)%dist_lsm(:,:,9),RT_DOMAIN(did)%SMCMAX1,RT_DOMAIN(did)%SMCREF1, & - RT_DOMAIN(did)%SMCWLT1,RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%LKSAT,RT_DOMAIN(did)%dist, & - RT_DOMAIN(did)%INFXSWGT, RT_DOMAIN(did)%OVROUGHRTFAC,RT_DOMAIN(did)%LKSATFAC, & - RT_DOMAIN(did)%CH_NETRT,RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%SMCREFRT, & - RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%SMCMAXRT, RT_DOMAIN(did)%SMCWLTRT, & - RT_DOMAIN(did)%SMCRT, & - RT_DOMAIN(did)%OVROUGHRT, RT_DOMAIN(did)%LAKE_MSKRT, & - RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%OV_ROUGH,RT_DOMAIN(did)%SLDPTH ) - - end subroutine disaggregateDomain_drv - - subroutine disaggregateDomain(IX,JX,NSOIL,IXRT,JXRT,AGGFACTRT, & - SICE, SMC,SH2OX, INFXSRT, area_lsm, SMCMAX1,SMCREF1, & - SMCWLT1, VEGTYP, LKSAT, dist,INFXSWGT,OVROUGHRTFAC, & - LKSATFAC, CH_NETRT,SH2OWGT,SMCREFRT, INFXSUBRT,SMCMAXRT, & - SMCWLTRT,SMCRT, OVROUGHRT, LAKE_MSKRT, LKSATRT,OV_ROUGH, & - SLDPTH & - ) -#ifdef MPP_LAND - use module_mpp_land, only: left_id,down_id,right_id, & - up_id,mpp_land_com_real, my_id, & - mpp_land_sync,mpp_land_com_integer,mpp_land_max_int1, & - sum_double -#endif - implicit none - integer,INTENT(IN) :: IX,JX,NSOIL,IXRT,JXRT,AGGFACTRT - real,INTENT(OUT),DIMENSION(IX,JX,NSOIL)::SICE - real,INTENT(IN),DIMENSION(IX,JX,NSOIL)::SMC,SH2OX - real,INTENT(IN),DIMENSION(IX,JX)::INFXSRT, area_lsm, SMCMAX1,SMCREF1, & - SMCWLT1, LKSAT - integer,INTENT(IN),DIMENSION(IX,JX) ::VEGTYP - - real,INTENT(IN),DIMENSION(IXRT,JXRT,9)::dist - real,INTENT(IN),DIMENSION(IXRT,JXRT)::INFXSWGT,OVROUGHRTFAC, & - LKSATFAC - integer,INTENT(IN), DIMENSION(IXRT,JXRT) ::CH_NETRT - real,INTENT(IN),DIMENSION(IXRT,JXRT,NSOIL)::SH2OWGT - real,INTENT(OUT),DIMENSION(IXRT,JXRT,NSOIL)::SMCREFRT, SMCMAXRT, & - SMCWLTRT,SMCRT - real,INTENT(OUT),DIMENSION(IXRT,JXRT)::INFXSUBRT - real,INTENT(INOUT),DIMENSION(IXRT,JXRT)::OVROUGHRT, LKSATRT - integer,INTENT(INOUT), DIMENSION(IXRT,JXRT) ::LAKE_MSKRT - - - real,INTENT(IN), DIMENSION(NSOIL) :: SLDPTH - REAL OV_ROUGH(*) - - - - integer :: i, j, AGGFACYRT, AGGFACXRT, IXXRT, JYYRT,KRT, KF - REAL :: LSMVOL,SMCEXCS, WATHOLDCAP -!------------------------------------- - - - - SICE=SMC-SH2OX - SMCREFRT = 0 - -!DJG First, Disaggregate a few key fields for routing... -!DJG Debug... -#ifdef HYDRO_D - print *, "Beginning Disaggregation..." -#endif - -!DJG Mass balance check for disagg... - - -!DJG Weighting alg. alteration...(prescribe wghts if time = 1) - - - do J=1,JX - do I=1,IX - -!DJG Weighting alg. alteration... - LSMVOL=INFXSRT(I,J)*area_lsm(I,J) - - - do AGGFACYRT=AGGFACTRT-1,0,-1 - do AGGFACXRT=AGGFACTRT-1,0,-1 - - IXXRT=I*AGGFACTRT-AGGFACXRT - JYYRT=J*AGGFACTRT-AGGFACYRT -#ifdef MPP_LAND - if(left_id.ge.0) IXXRT=IXXRT+1 - if(down_id.ge.0) JYYRT=JYYRT+1 -#else -!yw ???? -! IXXRT=IXXRT+1 -! JYYRT=JYYRT+1 -#endif - - -!DJG Implement subgrid weighting routine... - INFXSUBRT(IXXRT,JYYRT)=LSMVOL* & - INFXSWGT(IXXRT,JYYRT)/dist(IXXRT,JYYRT,9) - - - do KRT=1,NSOIL !Do for soil profile loop - IF(SICE(I,J,KRT).gt.0) then !...adjust for soil ice -!DJG Adjust SMCMAX for SICE when subsfc routing...make 3d variable - SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J)-SICE(I,J,KRT) - SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J)-SICE(I,J,KRT) - WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) - IF (SICE(I,J,KRT).le.WATHOLDCAP) then - SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - else - if(SICE(I,J,KRT).lt.SMCMAX1(I,J)) & - SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - & - (SICE(I,J,KRT)-WATHOLDCAP) - if(SICE(I,J,KRT).ge.SMCMAX1(I,J)) SMCWLTRT(IXXRT,JYYRT,KRT) = 0. - end if - ELSE - SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J) - SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J) - WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J) - SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - END IF !endif adjust for soil ice... - - -!Now Adjust soil moisture -!DJG Use SH2O instead of SMC for 'liquid' water... - IF(SMCMAXRT(IXXRT,JYYRT,KRT).GT.0) THEN !Check for smcmax data (=0 over water) - SMCRT(IXXRT,JYYRT,KRT)=SH2OX(I,J,KRT)*SH2OWGT(IXXRT,JYYRT,KRT) -!old SMCRT(IXXRT,JYYRT,KRT)=SMC(I,J,KRT) - ELSE - SMCRT(IXXRT,JYYRT,KRT) = 0.001 !will be skipped w/ landmask - SMCMAXRT(IXXRT,JYYRT,KRT) = 0.001 - END IF -!DJG Check/Adjust so that subgrid cells do not exceed saturation... - IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN - SMCEXCS = (SMCRT(IXXRT,JYYRT,KRT) - SMCMAXRT(IXXRT,JYYRT,KRT)) & - * SLDPTH(KRT)*1000. !Excess soil water in units of (mm) - SMCRT(IXXRT,JYYRT,KRT) = SMCMAXRT(IXXRT,JYYRT,KRT) - DO KF = KRT-1,1, -1 !loop back upward to redistribute excess water from disagg. - SMCRT(IXXRT,JYYRT,KF) = SMCRT(IXXRT,JYYRT,KF) + SMCEXCS/(SLDPTH(KF)*1000.) - IF (SMCRT(IXXRT,JYYRT,KF).GT.SMCMAXRT(IXXRT,JYYRT,KF)) THEN !Recheck new lyr sat. - SMCEXCS = (SMCRT(IXXRT,JYYRT,KF) - SMCMAXRT(IXXRT,JYYRT,KF)) & - * SLDPTH(KF)*1000. !Excess soil water in units of (mm) - SMCRT(IXXRT,JYYRT,KF) = SMCMAXRT(IXXRT,JYYRT,KF) - ELSE ! Excess soil water expired - SMCEXCS = 0. - EXIT - END IF - END DO - IF (SMCEXCS.GT.0) THEN !If not expired by sfc then add to Infil. Excess - INFXSUBRT(IXXRT,JYYRT) = INFXSUBRT(IXXRT,JYYRT) + SMCEXCS - SMCEXCS = 0. - END IF - END IF !End if for soil moisture saturation excess - - - end do !End do for soil profile loop - - - - do KRT=1,NSOIL !debug loop - - IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN -#ifdef HYDRO_D - print *, "Err. SMCMAX exceeded upon disaggregation3...", ixxrt,jyyrt,krt,& - SMCRT(IXXRT,JYYRT,KRT),SMCMAXRT(IXXRT,JYYRT,KRT) - call hydro_stop("disaggregateDomain") -#endif - ELSE IF (SMCRT(IXXRT,JYYRT,KRT).LE.0.) THEN -#ifdef HYDRO_D - print *, "Err. SMCRT fully depleted upon disaggregation...", ixxrt,jyyrt,krt,& - SMCRT(IXXRT,JYYRT,KRT),SH2OWGT(IXXRT,JYYRT,KRT),SH2OX(I,J,KRT) - - print*, "SMC=", SMC(i,j,KRT), "SICE =", sice(i,j,KRT) - print *, "VEGTYP = ", VEGTYP(I,J) - print *, "i,j,krt, nsoil",i,j,krt,nsoil - call hydro_stop("disaggregateDomain SMCRT depleted") -#endif - END IF - end do !debug loop - - - -!DJG map ov roughness as function of land use provided in VEGPARM.TBL... -! --- added extra check for VEGTYP for 'masked-out' locations... -! --- out of basin locations (VEGTYP=0) have OVROUGH hardwired to 0.1 - IF (VEGTYP(I,J).LE.0) then - OVROUGHRT(IXXRT,JYYRT) = 0.1 !COWS mask test - ELSE - OVROUGHRT(IXXRT,JYYRT)=OV_ROUGH(VEGTYP(I,J))*OVROUGHRTFAC(IXXRT,JYYRT) ! Distributed calibration...1/17/2012 - END IF - - - -!DJG 6.12.08 Map lateral hydraulic conductivity and apply distributed scaling -! --- factor that will be read in from hires terrain file -! LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) - LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) * LKSATFAC(IXXRT,JYYRT) * & !Apply scaling factor... -! ...and scale from max to 0 when SMC decreases from SMCMAX to SMCREF... -!!DJG error found from KIT,improper scaling ((SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL)) / & - (max(0.,(SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL))) / & - (SMCMAXRT(IXXRT,JYYRT,NSOIL)-SMCREFRT(IXXRT,JYYRT,NSOIL)) ) - - - -!DJG set up lake mask... -!--- modify to make lake mask large here, but not one of the routed lakes!!! -!-- IF (VEGTYP(I,J).eq.16) then - IF (VEGTYP(I,J).eq.16 .and. & - CH_NETRT(IXXRT,JYYRT).le.0) then - !--LAKE_MSKRT(IXXRT,JYYRT) = 1 -!yw LAKE_MSKRT(IXXRT,JYYRT) = 9999 - LAKE_MSKRT(IXXRT,JYYRT) = -9999 - end if - - end do - end do - - end do - end do - - - - -#ifdef HYDRO_D - print *, "After Disaggregation..." -#endif - -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(INFXSUBRT,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(LKSATRT,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(OVROUGHRT,IXRT,JXRT,99) - call MPP_LAND_COM_INTEGER(LAKE_MSKRT,IXRT,JXRT,99) - do i = 1, NSOIL - call MPP_LAND_COM_REAL(SMCMAXRT(:,:,i),IXRT,JXRT,99) - call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99) - call MPP_LAND_COM_REAL(SMCWLTRT(:,:,i),IXRT,JXRT,99) - end DO -#endif - - end subroutine disaggregateDomain - - subroutine SubsurfaceRouting_drv(did) - - use module_RT_data, only: rt_domain - use module_namelist, only: nlst_rt - implicit none - integer :: did - IF (nlst_rt(did)%SUBRTSWCRT.EQ.1) THEN - call subsurfaceRouting (RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt , nlst_rt(did)%nsoil, & - RT_DOMAIN(did)%SMCRT,RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCREFRT,& - RT_DOMAIN(did)%SMCWLTRT, RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SLDPTH, & - nlst_rt(did)%DT,RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SOXRT, & - RT_DOMAIN(did)%SOYRT,RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%SOLDEPRT, & - RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%QSUBBDRYTRT, RT_DOMAIN(did)%QSUBBDRYRT,& - RT_DOMAIN(did)%QSUBRT ,nlst_rt(did)%rt_option, RT_DOMAIN(did)%dist, & - RT_DOMAIN(did)%sub_resid,RT_DOMAIN(did)%SO8RT_D, RT_DOMAIN(did)%SO8RT) - endif - end subroutine SubsurfaceRouting_drv - - subroutine subsurfaceRouting (ixrt, jxrt , nsoil, & - SMCRT,SMCMAXRT,SMCREFRT,SMCWLTRT, & - ZSOIL, SLDPTH, & - DT,ZWATTABLRT,SOXRT,SOYRT,LKSATRT,& - SOLDEPRT,INFXSUBRT,QSUBBDRYTRT, QSUBBDRYRT,& - QSUBRT ,rt_option, dist,sub_resid,SO8RT_D, SO8RT) -#ifdef MPP_LAND - use module_mpp_land, only: mpp_land_com_real, mpp_land_com_integer -#endif - implicit none - integer, INTENT(IN) :: ixrt, jxrt , nsoil, rt_option - REAL, INTENT(IN) :: DT - real,INTENT(IN), DIMENSION(NSOIL) :: ZSOIL, SLDPTH - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: SOXRT,SOYRT,LKSATRT, SOLDEPRT , sub_resid - real,INTENT(INOUT), DIMENSION(IXRT,JXRT)::INFXSUBRT - real,INTENT(INOUT) :: QSUBBDRYTRT - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: QSUBBDRYRT, QSUBRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT, SMCWLTRT, SMCMAXRT,SMCREFRT - - - INTEGER :: SO8RT_D(IXRT,JXRT,3) - REAL :: SO8RT(IXRT,JXRT,8) - REAL, INTENT(IN) :: dist(ixrt,jxrt,9) -! -----local array ---------- - REAL, DIMENSION(IXRT,JXRT) :: ZWATTABLRT - REAL, DIMENSION(IXRT,JXRT) :: CWATAVAIL - INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK - - - - - CWATAVAIL = 0. - CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, & - SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, & - CWATAVAIL,SLDPTH) -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(ZWATTABLRT,IXRT,JXRT,99) - call MPP_LAND_COM_REAL(CWATAVAIL,IXRT,JXRT,99) - call MPP_LAND_COM_INTEGER(SATLYRCHK,IXRT,JXRT,99) -#endif - - -!DJG Second, Call subsurface routing routine... -#ifdef HYDRO_D - print *, "Beginning SUB_routing..." - print *, "Routing method is ",rt_option, " direction." -#endif - -!!!! Find saturated layer depth... -! Loop through domain to determine sat. layers and assign wat tbl depth... -! and water available for subsfc routing (CWATAVAIL)... -! This subroutine returns: ZWATTABLRT, CWATAVAIL and SATLYRCHK - - - CALL SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT, & - LKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT,NSOIL,SMCRT, & - INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT,SMCWLTRT,SO8RT, & - SO8RT_D, rt_option,SLDPTH,SUB_RESID,CWATAVAIL,SATLYRCHK) - -#ifdef HYDRO_D - print *, "SUBROUTE routing called and returned..." -#endif - - end subroutine subsurfaceRouting - - - subroutine OverlandRouting_drv(did) - use module_RT_data, only: rt_domain - use module_namelist, only: nlst_rt - implicit none - integer :: did - if(nlst_rt(did)%OVRTSWCRT .eq. 1) then - call OverlandRouting (nlst_rt(did)%DT, nlst_rt(did)%DTRT, nlst_rt(did)%rt_option, & - rt_domain(did)%ixrt, rt_domain(did)%jxrt,rt_domain(did)%LAKE_MSKRT, & - rt_domain(did)%INFXSUBRT, rt_domain(did)%RETDEPRT,rt_domain(did)%OVROUGHRT, & - rt_domain(did)%SOXRT, rt_domain(did)%SOYRT, rt_domain(did)%SFCHEADSUBRT, & - rt_domain(did)%DHRT, rt_domain(did)%CH_NETRT, rt_domain(did)%QSTRMVOLRT, & - rt_domain(did)%LAKE_INFLORT,rt_domain(did)%QBDRYRT, & - rt_domain(did)%QSTRMVOLTRT,rt_domain(did)%QBDRYTRT, rt_domain(did)%LAKE_INFLOTRT,& - rt_domain(did)%q_sfcflx_x,rt_domain(did)%q_sfcflx_y, & - rt_domain(did)%dist, rt_domain(did)%SO8RT, rt_domain(did)%SO8RT_D , & - rt_domain(did)%SMCTOT2,rt_domain(did)%suminfxs1,rt_domain(did)%suminfxsrt, & - rt_domain(did)%smctot1,rt_domain(did)%dsmctot ) - endif - end subroutine OverlandRouting_drv - - - - subroutine OverlandRouting (DT, DTRT, rt_option, ixrt, jxrt,LAKE_MSKRT, & - INFXSUBRT, RETDEPRT,OVROUGHRT,SOXRT, SOYRT, SFCHEADSUBRT,DHRT, & - CH_NETRT, QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, & - QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y, & - dist, SO8RT, SO8RT_D, & - SMCTOT2,suminfxs1,suminfxsrt,smctot1,dsmctot ) -#ifdef MPP_LAND - use module_mpp_land, only: mpp_land_max_int1, sum_double -#endif - implicit none - - REAL, INTENT(IN) :: DT, DTRT - integer, INTENT(IN) :: ixrt, jxrt, rt_option - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: INFXSUBRT, & - RETDEPRT,OVROUGHRT,SOXRT, SOYRT - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SFCHEADSUBRT,DHRT - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, & - QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y - - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist - REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8) :: SO8RT - INTEGER SO8RT_D(IXRT,JXRT,3) - - integer :: i,j - - - INTEGER, PARAMETER :: double1=8 - real (KIND=double1) :: smctot2,smctot1,dsmctot - real (KIND=double1) :: suminfxsrt,suminfxs1 -! local variable - real (KIND=double1) :: chan_in1,chan_in2 - real (KIND=double1) :: lake_in1,lake_in2 - real (KIND=double1) :: qbdry1,qbdry2 - integer :: sfcrt_flag - - - -!DJG Third, Call Overland Flow Routing Routine... -#ifdef HYDRO_D - print *, "Beginning OV_routing..." - print *, "Routing method is ",rt_option, " direction." -#endif - -!DJG debug...OV Routing... - suminfxs1=0. - chan_in1=0. - lake_in1=0. - qbdry1=0. - do i=1,IXRT - do j=1,JXRT - suminfxs1=suminfxs1+INFXSUBRT(I,J)/float(IXRT*JXRT) - chan_in1=chan_in1+QSTRMVOLRT(I,J)/float(IXRT*JXRT) - lake_in1=lake_in1+LAKE_INFLORT(I,J)/float(IXRT*JXRT) - qbdry1=qbdry1+QBDRYRT(I,J)/float(IXRT*JXRT) - end do - end do - -#ifdef MPP_LAND -! not tested - CALL sum_double(suminfxs1) - CALL sum_double(chan_in1) - CALL sum_double(lake_in1) - CALL sum_double(qbdry1) -#endif - - -!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(set sfcrt_flag) -!DJG.7.20.2007 - this check will skip ov rtng when no flow is present... - - sfcrt_flag = 0 - - do j=1,jxrt - do i=1,ixrt - if(INFXSUBRT(i,j).gt.RETDEPRT(i,j)) then - sfcrt_flag = 1 - exit - end if - end do - if(sfcrt_flag.eq.1) exit - end do - -#ifdef MPP_LAND - call mpp_land_max_int1(sfcrt_flag) -#endif -!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(IF) - - if (sfcrt_flag.eq.1) then !If/then for sfc_rt check... -#ifdef HYDRO_D - write(6,*) "calling OV_RTNG " -#endif - CALL OV_RTNG(DT,DTRT,IXRT,JXRT,INFXSUBRT,SFCHEADSUBRT,DHRT, & - CH_NETRT,RETDEPRT,OVROUGHRT,QSTRMVOLRT,QBDRYRT, & - QSTRMVOLTRT,QBDRYTRT,SOXRT,SOYRT,dist, & - LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT,SO8RT,SO8RT_D,rt_option,& - q_sfcflx_x,q_sfcflx_y) - else -#ifdef HYDRO_D - print *, "No water to route overland..." -#endif - end if !Endif for sfc_rt check... - -!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(ENDIF) - -#ifdef HYDRO_D - print *, "OV routing called and returned..." -#endif - -!DJG Debug...OV Routing... - suminfxsrt=0. - chan_in2=0. - lake_in2=0. - qbdry2=0. - do i=1,IXRT - do j=1,JXRT - suminfxsrt=suminfxsrt+SFCHEADSUBRT(I,J)/float(IXRT*JXRT) - chan_in2=chan_in2+QSTRMVOLRT(I,J)/float(IXRT*JXRT) - lake_in2=lake_in2+LAKE_INFLORT(I,J)/float(IXRT*JXRT) - qbdry2=qbdry2+QBDRYRT(I,J)/float(IXRT*JXRT) - end do - end do -#ifdef MPP_LAND -! not tested - CALL sum_double(suminfxsrt) - CALL sum_double(chan_in2) - CALL sum_double(lake_in2) - CALL sum_double(qbdry2) -#endif - -#ifdef HYDRO_D - print *, "OV Routing Mass Bal: " - print *, "Infil. Excess/Sfc Head: ", suminfxsrt-suminfxs1, & - suminfxsrt,suminfxs1 - print *, "chan_in = ",chan_in2-chan_in1 - print *, "lake_in = ",lake_in2-lake_in1 - print *, "Qbdry = ",qbdry2-qbdry1 - print *, "Residual : ", suminfxs1-suminfxsrt-(chan_in2-chan_in1) & - -(lake_in2-lake_in1)-(qbdry2-qbdry1) -#endif - - - end subroutine OverlandRouting - - - subroutine time_seconds(i3) - integer time_array(8) - real*8 i3 - call date_and_time(values=time_array) - i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + & - time_array(7) + 0.001 * time_array(8) - return - end subroutine time_seconds - diff --git a/wrfv2_fire/hydro/Routing/module_GW_baseflow.F b/wrfv2_fire/hydro/Routing/module_GW_baseflow.F deleted file mode 100644 index 7b72ff1e..00000000 --- a/wrfv2_fire/hydro/Routing/module_GW_baseflow.F +++ /dev/null @@ -1,856 +0,0 @@ -module module_GW_baseflow - -#ifdef MPP_LAND - use module_mpp_land -#endif - implicit none - -#include "gw_field_include.inc" -#include "rt_include.inc" -!yw #include "namelist.inc" -contains - -!------------------------------------------------------------------------------ -!DJG Simple GW Bucket Model -!------------------------------------------------------------------------------ - - subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,basns_area,& - gwsubbasmsk, runoff1x, runoff2x, z_gwsubbas_tmp, qin_gwsubbas,& - qout_gwsubbas,qinflowbase,gw_strm_msk,gwbas_pix_ct,dist,DT,& - C,ex,z_mx,GWBASESWCRT,OVRTSWCRT) - implicit none - -!!!Declarations... - integer, intent(in) :: ix,jx,ixrt,jxrt - integer, intent(in) :: numbasns - integer, intent(in), dimension(ix,jx) :: gwsubbasmsk - real, intent(in), dimension(ix,jx) :: runoff2x - real, intent(in), dimension(ix,jx) :: runoff1x - real, intent(in) :: basns_area(numbasns),dist(ixrt,jxrt,9),DT - real, intent(in),dimension(numbasns) :: C,ex,z_mx - real, intent(out),dimension(numbasns) :: qout_gwsubbas - real, intent(out),dimension(numbasns) :: qin_gwsubbas - real*8 :: z_gwsubbas(numbasns) - real :: qout_max, qout_spill, z_gw_spill - real, intent(inout),dimension(numbasns) :: z_gwsubbas_tmp - real, intent(out),dimension(ixrt,jxrt) :: qinflowbase - integer, intent(in),dimension(ixrt,jxrt) :: gw_strm_msk - integer, intent(in) :: GWBASESWCRT - integer, intent(in) :: OVRTSWCRT - - - real*8, dimension(numbasns) :: sum_perc8,ct_bas8 - real, dimension(numbasns) :: sum_perc - real, dimension(numbasns) :: net_perc - - real, dimension(numbasns) :: ct_bas - real, dimension(numbasns) :: gwbas_pix_ct - integer :: i,j,bas - character(len=19) :: header - character(len=1) :: jnk - - -!!!Initialize variables... - ct_bas8 = 0 - sum_perc8 = 0. - net_perc = 0. - qout_gwsubbas = 0. - qin_gwsubbas = 0. - z_gwsubbas = z_gwsubbas_tmp - - - -!!!Calculate aggregated percolation from deep runoff into GW basins... - do i=1,ix - do j=1,jx - do bas=1,numbasns - if(gwsubbasmsk(i,j).eq.bas) then - if(OVRTSWCRT.ne.0) then - sum_perc8(bas) = sum_perc8(bas)+runoff2x(i,j) !Add only drainage to bucket...runoff2x in (mm) - else - sum_perc8(bas) = sum_perc8(bas)+runoff1x(i,j)+runoff2x(i,j) !Add sfc water & drainage to bucket...runoff1x and runoff2x in (mm) - end if - ct_bas8(bas) = ct_bas8(bas) + 1 - end if - end do - end do - end do - -#ifdef MPP_LAND - call sum_real8(sum_perc8,numbasns) - call sum_real8(ct_bas8,numbasns) -#endif - sum_perc = sum_perc8 - ct_bas = ct_bas8 - - - - -!!!Loop through GW basins to adjust for inflow/outflow - - DO bas=1,numbasns ! Loop for GW bucket calcs... -! #ifdef MPP_LAND -! if(ct_bas(bas) .gt. 0) then -! #endif - - net_perc(bas) = sum_perc(bas) / ct_bas(bas) !units (mm) -!DJG...old change to cms qin_gwsubbas(bas) = net_perc(bas)/1000. * ct_bas(bas) * basns_area(bas) !units (m^3) - qin_gwsubbas(bas) = net_perc(bas)/1000.* & - ct_bas(bas)*basns_area(bas)/DT !units (m^3/s) - - -!Adjust level of GW depth...(conceptual GW bucket units (mm)) -!DJG...old change to cms inflow... z_gwsubbas(bas) = z_gwsubbas(bas) + net_perc(bas) / 1000.0 ! (m) - -!DJG...debug write (6,*) "DJG...before",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas) - - z_gwsubbas(bas) = z_gwsubbas(bas) + qin_gwsubbas(bas)*DT/( & - ct_bas(bas)*basns_area(bas))*1000. ! units (mm) - - - - - -!Calculate baseflow as a function of GW bucket depth... - - if(GWBASESWCRT.eq.1) then !active exponential bucket... if/then for bucket model discharge type... - -!DJG...Estimation of bucket 'overflow' (qout_spill) if/when bucket gets filled... - qout_spill = 0. - z_gw_spill = 0. - if (z_gwsubbas(bas).gt.z_mx(bas)) then !If/then for bucket overflow case... - z_gw_spill = z_gwsubbas(bas) - z_mx(bas) - z_gwsubbas(bas) = z_mx(bas) - write (6,*) "Bucket spilling...", bas, z_gwsubbas(bas), z_mx(bas), z_gw_spill - else - z_gw_spill = 0. - end if ! End if for bucket overflow case... - - qout_spill = z_gw_spill/1000.*(ct_bas(bas)*basns_area(bas))/DT !amount spilled from bucket overflow...units (cms) - - -!DJG...Maximum estimation of bucket outlfow that is limited by total quantity in bucket... - qout_max = z_gwsubbas(bas)/1000.*(ct_bas(bas)*basns_area(bas))/DT ! Estimate max bucket disharge limit to total volume in bucket...(m^3/s) - - -! Assume exponential relation between z/zmax and Q... -!DJG...old...creates non-asymptotic flow... qout_gwsubbas(bas) = C(bas)*EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas)) !Exp.model. q_out (m^3/s) -!DJG force asymptote to zero to prevent 'overdraft'... -!DJG debug hardwire test... qout_gwsubbas(bas) = 1*(EXP(7.0*10./100.)-1) !Exp.model. q_out (m^3/s) - qout_gwsubbas(bas) = C(bas)*(EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas))-1) !Exp.model. q_out (m^3/s) - -!DJG...Calculation of max bucket outlfow that is limited by total quantity in bucket... - qout_gwsubbas(bas) = MIN(qout_max,qout_gwsubbas(bas)) ! Limit bucket discharge to max. bucket limit - - write (6,*) "DJG-exp bucket...during",C(bas),ex(bas),z_gwsubbas(bas),qin_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max, qout_spill - - - - elseif (GWBASESWCRT.eq.2) then !Pass through/steady-state bucket - -! Assuming a steady-state (inflow=outflow) model... -!DJG convert input and output units to cms... qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3) - qout_gwsubbas(bas) = qin_gwsubbas(bas) !steady-state model...(m^3/s) - -!DJG...debug write (6,*) "DJG-pass through...during",C(bas),ex(bas),qin_gwsubbas(bas), z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max - - end if ! End if for bucket model discharge type.... - - - - -!Adjust level of GW depth... -!DJG bug adjust output to be mm and correct area bug... z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT & -!DJG bug adjust output to be mm and correct area bug... / (ct_bas(bas)*basns_area(bas)) !units(m) - - z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT/( & - ct_bas(bas)*basns_area(bas))*1000. ! units (mm) - -!DJG...Combine calculated bucket discharge and amount spilled from bucket... - qout_gwsubbas(bas) = qout_gwsubbas(bas) + qout_spill ! units (cms) - - - write (6,*) "DJG...after",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_spill - write (6,*) "DJG...after...calc",bas,ct_bas(bas),ct_bas(bas)*basns_area(bas),basns_area(bas),DT - - - - -! #ifdef MPP_LAND -! endif -! #endif - END DO ! End loop for GW bucket calcs... - - z_gwsubbas_tmp = z_gwsubbas - - -!!!Distribute basin integrated baseflow to stream pixels as stream 'inflow'... - - qinflowbase = 0. - - - do i=1,ixrt - do j=1,jxrt -!!! -simple uniform disaggregation (8.31.06) - if (gw_strm_msk(i,j).gt.0) then - - qinflowbase(i,j) = qout_gwsubbas(gw_strm_msk(i,j))*1000.*DT/ & - gwbas_pix_ct(gw_strm_msk(i,j))/dist(i,j,9) ! units (mm) that gets passed into chan routing as stream inflow - - end if - end do - end do - - -!!! - weighted redistribution...(need to pass accum weights (slope) in...) -! NOT FINISHED just BASIC framework... -! do bas=1,numbasns -! do k=1,gwbas_pix_ct(bas) -! qinflowbase(i,j) = k*slope -! end do -! end do - - z_gwsubbas = z_gwsubbas_tmp - - return - -!------------------------------------------------------------------------------ - End subroutine simp_gw_buck -!------------------------------------------------------------------------------ - - - - -#ifdef MPP_LAND - subroutine pix_ct_1(in_gw_strm_msk,ixrt,jxrt,gwbas_pix_ct,numbasns) - USE module_mpp_land - implicit none - integer :: i,j,ixrt,jxrt,numbasns, bas - integer,dimension(ixrt,jxrt) :: in_gw_strm_msk - integer,dimension(global_rt_nx,global_rt_ny) :: gw_strm_msk - real,dimension(numbasns) :: gwbas_pix_ct - - gw_strm_msk = 0 - call write_IO_rt_int(in_gw_strm_msk, gw_strm_msk) - - if(my_id .eq. IO_id) then - gwbas_pix_ct = 0. - do bas = 1,numbasns - do i=1,global_rt_nx - do j=1,global_rt_ny - if(gw_strm_msk(i,j) .eq. bas) then - gwbas_pix_ct(gw_strm_msk(i,j)) = gwbas_pix_ct(gw_strm_msk(i,j)) & - + 1.0 - endif - end do - end do - end do - end if - call mpp_land_bcast_real(numbasns,gwbas_pix_ct) - - return - end subroutine pix_ct_1 -#endif - - -!------------------------------------------------------------------------------ -! Benjamin Fersch 2d groundwater model -!------------------------------------------------------------------------------ - subroutine gw2d_ini(did,dt,dx) - use module_GW_baseflow_data, only: gw2d - implicit none - integer did - real dt,dx - - gw2d(did)%dx=dx - gw2d(did)%dt=dt - ! bftodo: develop proper landtype mask - - gw2d(did)%compres=0. ! currently not implemented - - return - end subroutine gw2d_ini - - subroutine gw2d_allocate(did, ix, jx, nsoil) - use module_GW_baseflow_data, only: gw2d - implicit none - integer ix, jx, nsoil - integer istatus, did - - if(gw2d(did)%allo_status .eq. 1) return - gw2d(did)%allo_status = 1 - - gw2d(did)%ix = ix - gw2d(did)%jx = jx - - - allocate(gw2d(did)%ltype (ix,jx)) - allocate(gw2d(did)%elev (ix,jx)) - allocate(gw2d(did)%bot (ix,jx)) - allocate(gw2d(did)%hycond (ix,jx)) - allocate(gw2d(did)%poros (ix,jx)) - allocate(gw2d(did)%compres(ix,jx)) - allocate(gw2d(did)%ho (ix,jx)) - allocate(gw2d(did)%h (ix,jx)) - allocate(gw2d(did)%convgw (ix,jx)) -! allocate(gw2d(did)% (ix,jx)) - - end subroutine gw2d_allocate - - - subroutine gwstep(ix, jx, dx, & - ltype, elev, bot, & - hycond, poros, compres, & - ho, h, convgw, & - ebot, eocn, & - dt, istep) -! #else -! dx, istep, dt, & !supplied -! ims,ime,jms,jme,its,ite,jts,jte, & !supplied -! ids,ide,jds,jde,ifs,ife,jfs,jfe) !supplied -! #endif - -! New (volug): calling routines use change in head, convgw = d(h-ho)/dt. - -! Steps ground-water hydrology (head) through one timestep. -! Modified from Prickett and Lonnquist (1971), basic one-layer aquifer -! simulation program, with mods by Zhongbo Yu(1997). -! Solves S.dh/dt = d/dx(T.dh/dx) + d/dy(T.dh/dy) + "external sources" -! for a single layer, where h is head, S is storage coeff and T is -! transmissivity. 3-D arrays in main program (hycond,poros,h,bot) -! are 2-D here, since only a single (uppermost) layer is solved. -! Uses an iterative time-implicit ADI method. - -! use module_hms_constants - - - - integer, intent(in) :: ix, jx - - integer, intent(in), dimension(ix,jx) :: ltype ! land-sfc type (supp) - real, intent(in), dimension(ix,jx) :: & - elev, & ! elev/bathymetry of sfc rel to sl (m) (supp) - bot, & ! elev. aquifer bottom rel to sl (m) (supp) - hycond, & ! hydraulic conductivity (m/s per m/m) (supp) - poros, & ! porosity (m3/m3) (supp) - compres, & ! compressibility (1/Pa) (supp) - ho ! head at start of timestep (m) (supp) - - real, intent(inout), dimension(ix,jx) :: & - h, & ! head, after ghmcompute (m) (ret) - convgw ! convergence due to gw flow (m/s) (ret) - - real, intent(inout) :: ebot, eocn - - - - integer :: istep !, dt - real, intent(in) :: dt, dx - -! #endif -! eocn = mean spurious sink for h_ocn = sealev fix (m/s)(ret) -! This equals the total ground-water flow across -! land->ocean boundaries. -! ebot = mean spurious source for "bot" fix (m/s) (returned) -! time = elapsed time from start of run (sec) -! dt = timestep length (sec) -! istep = timestep counter - -! Local arrays: - - real, dimension(ix,jx) :: sf2 ! storage coefficient (m3 of h2o / bulk m3) - real, dimension(ix,jx,2) :: t ! transmissivity (m2/s)..1 for N-S,..2 for E-W - real, dimension(0:ix+jx) :: b,g ! work arrays - - - real, parameter :: botinc = 0.01 ! re-wetting increment to fix h < bot -! parameter (botinc = 0. ) ! re-wetting increment to fix h < bot - ! (m); else no flow into dry cells - real, parameter :: delskip = 0.005 ! av.|dhead| value for iter.skip out(m) - integer, parameter :: itermax = 10 ! maximum number of iterations - integer, parameter :: itermin = 3 ! minimum number of iterations - real, parameter :: sealev = -1. ! sea-level elevation (m) - - -! die müssen noch sortiert, geprüft und aufgeräumt werden - integer :: & - iter, & - j, & - i, & - jp, & - ip, & - ii, & - n, & - jj, & - ierr, & - ier - -! real :: su, sc, shp, bb, aa, cc, w, zz, tareal, dtoa, dtot - real :: & - dy, & - e, & - su, & - sc, & - shp, & - bb, & - dd, & - aa, & - cc, & - w, & - ha, & - delcur, & - dtot, & - dtoa, & - darea, & - tareal, & - zz - -#ifdef MPP_LAND - real mpiDelcur - integer mpiSize -#endif - - dy = dx - darea = dx*dy - - - call scopy (ix*jx, ho, 1, h, 1) - -! Top of iterative loop for ADI solution - - iter = 0 -!~~~~~~~~~~~~~ - 80 continue -!~~~~~~~~~~~~~ - iter = iter+1 - -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(h, ix, jx, 99) -#endif - - e = 0. ! absolute changes in head (for iteration control) -! eocn = 0. ! accumulated fixes for h = 0 over ocean (diag) -! ebot = 0. ! accumulated fixes for h < bot (diagnostic) - -! Set storage coefficient (sf2) - -! #ifdef HMSWRF -! - tareal = 0. -! -! do j=jfs,jfe -! do i=ifs,ife -! -! -! #else - do j=1,jx - do i=1,ix - if(ltype(i,j) .ge. 1) tareal = tareal + darea - -! #endif -! unconfined water table (h < e): V = poros*(h-b) -! dV/dh = poros -! saturated to surface (h >= e) : V = poros*(e-b) + (h-e) -! dV/dh = 1 -! (compressibility is ignored) -! -! su = poros(i,j)*(1.-theta(i,j)) ! old (pre-volug) - su = poros(i,j) ! new (volug) - sc = 1. - - if (ho(i,j).le.elev(i,j) .and. h(i,j).le.elev(i,j)) then - sf2(i,j) = su - else if (ho(i,j).ge.elev(i,j) .and. h(i,j).ge.elev(i,j)) then - sf2(i,j) = sc - else if (ho(i,j).le.elev(i,j) .and. h(i,j).ge.elev(i,j)) then - shp = sf2(i,j) * (h(i,j) - ho(i,j)) - sf2(i,j) = shp * sc / (shp - (su-sc)*(elev(i,j)-ho(i,j))) - else if (ho(i,j).ge.elev(i,j) .and. h(i,j).le.elev(i,j)) then - shp = sf2(i,j) * (ho(i,j) - h(i,j)) - sf2(i,j) = shp * su / (shp + (su-sc)*(ho(i,j)-elev(i,j))) - endif - - enddo - enddo - -#ifdef MPP_LAND - ! communicate storage coefficient - call MPP_LAND_COM_REAL(sf2, ix, jx, 99) - -#endif - - -!========================== -! Column calculations -!========================== - -! Set transmissivities. Use min(h,elev)-bot instead of h-bot, -! since if h > elev, thickness of groundwater flow is just -! elev-bot. - -! #ifdef HMSWRF -! -! do j=jfs,jfe -! jp = min (j+1,jfe) -! do i=ifs,ife -! ip = min (i+1,ife) -! -! #else - - do j=1,jx - jp = min (j+1,jx) - do i=1,ix - ip = min (i+1,ix) - -! #endif - t(i,j,2) = sqrt( abs( & - hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j)) & - *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j)) & - ) ) & -! #ifdef HMSWRF - * (0.5*(dy+dy)) & ! in WRF the dx and dy are usually equal - / (0.5*(dx+dx)) -! #else -! * (0.5*(dy(i,j)+dy(ip,j))) & -! / (0.5*(dx(i,j)+dx(ip,j))) -! #endif - - t(i,j,1) = sqrt( abs( & - hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j )) & - *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp)) & - ) ) & -! #ifdef HMSWRF - * (0.5*(dx+dx)) & - / (0.5*(dy+dy)) -! #else -! * (0.5*(dx(i,j)+dx(i,jp))) & -! / (0.5*(dy(i,j)+dy(i,jp))) -! #endif - enddo - enddo - -#ifdef MPP_LAND - ! communicate transmissivities in x and y direction - call MPP_LAND_COM_REAL(t(:,:,1), ix, jx, 99) - call MPP_LAND_COM_REAL(t(:,:,2), ix, jx, 99) -#endif - b = 0. - g = 0. - -!------------------- - do 190 ii=1,ix -!------------------- - i=ii - if (mod(istep+iter,2).eq.1) i=ix-i+1 - -! calculate b and g arrays - -!>>>>>>>>>>>>>>>>>>>> - do 170 j=1,jx -!>>>>>>>>>>>>>>>>>>>> -! bb = (sf2(i,j)/dt) * darea(i,j) -! dd = ( ho(i,j)*sf2(i,j)/dt ) * darea(i,j) - bb = (sf2(i,j)/dt) * darea - dd = ( ho(i,j)*sf2(i,j)/dt ) * darea - aa = 0.0 - cc = 0.0 - - if (j-1) 90,100,90 - 90 aa = -t(i,j-1,1) - bb = bb + t(i,j-1,1) - - 100 if (j-jx) 110,120,110 - 110 cc = -t(i,j,1) - bb = bb + t(i,j,1) - - 120 if (i-1) 130,140,130 - 130 bb = bb + t(i-1,j,2) - dd = dd + h(i-1,j)*t(i-1,j,2) - - 140 if (i-ix) 150,160,150 - 150 bb = bb + t(i,j,2) - dd = dd + h(i+1,j)*t(i,j,2) - - 160 w = bb - aa*b(j-1) - b(j) = cc/w - g(j) = (dd-aa*g(j-1))/w -!>>>>>>>>>>>>>>> - 170 continue -!>>>>>>>>>>>>>>> - -! re-estimate heads - - e = e + abs(h(i,jx)-g(jx)) - h(i,jx) = g(jx) - n = jx-1 - 180 if (n.eq.0) goto 185 - ha = g(n) - b(n)*h(i,n+1) - e = e + abs(ha-h(i,n)) - h(i,n) = ha - n = n-1 - goto 180 - 185 continue - -!------------- - 190 continue -!------------- - -#ifdef MPP_LAND - call MPP_LAND_COM_REAL(h, ix, jx, 99) -#endif - - -!======================= -! Row calculations -!======================= - -! set transmissivities (same as above) - - do j=1,jx - jp = min (j+1,jx) - do i=1,ix - ip = min (i+1,ix) - t(i,j,2) = sqrt( abs( & - hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j)) & - *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j)) & - ) ) & -! * (0.5*(dy(i,j)+dy(ip,j))) & -! / (0.5*(dx(i,j)+dx(ip,j))) - * (0.5*(dy+dy)) & - / (0.5*(dx+dx)) - - t(i,j,1) = sqrt( abs( & - hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j )) & - *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp)) & - ) ) & - * (0.5*(dx+dx)) & - / (0.5*(dy+dy)) - enddo - enddo - -#ifdef MPP_LAND - ! communicate transmissivities in x and y direction - call MPP_LAND_COM_REAL(t(:,:,1), ix, jx, 99) - call MPP_LAND_COM_REAL(t(:,:,2), ix, jx, 99) -#endif - b = 0. - g = 0. - -!------------------- - do 300 jj=1,jx -!------------------- - j=jj - if (mod(istep+iter,2).eq.1) j = jx-j+1 - -! calculate b and g arrays - -!>>>>>>>>>>>>>>>>>>>> - do 280 i=1,ix -!>>>>>>>>>>>>>>>>>>>> -! bb = (sf2(i,j)/dt) * darea(i,j) -! dd = ( ho(i,j)*sf2(i,j)/dt ) * darea(i,j) - bb = (sf2(i,j)/dt) * darea - dd = ( ho(i,j)*sf2(i,j)/dt ) * darea - aa = 0.0 - cc = 0.0 - - if (j-1) 200,210,200 - 200 bb = bb + t(i,j-1,1) - dd = dd + h(i,j-1)*t(i,j-1,1) - - 210 if (j-jx) 220,230,220 - 220 dd = dd + h(i,j+1)*t(i,j,1) - bb = bb + t(i,j,1) - - 230 if (i-1) 240,250,240 - 240 bb = bb + t(i-1,j,2) - aa = -t(i-1,j,2) - - 250 if (i-ix) 260,270,260 - 260 bb = bb + t(i,j,2) - cc = -t(i,j,2) - - 270 w = bb - aa*b(i-1) - b(i) = cc/w - g(i) = (dd-aa*g(i-1))/w -!>>>>>>>>>>>>>>> - 280 continue -!>>>>>>>>>>>>>>> - -! re-estimate heads - - e = e + abs(h(ix,j)-g(ix)) - h(ix,j) = g(ix) - n = ix-1 - 290 if (n.eq.0) goto 295 - ha = g(n)-b(n)*h(n+1,j) - e = e + abs(h(n,j)-ha) - h(n,j) = ha - n = n-1 - goto 290 - 295 continue - -!------------- - 300 continue -!------------- - -! fix head < bottom of aquifer -! #endif -! -! #ifdef HMSWRF -! -! do j=jfs,jfe -! do i=ifs,ife -! -! #else - do j=1,jx - do i=1,ix -! #endif - if (ltype(i,j).eq.1 .and. h(i,j).le.bot(i,j)+botinc) then - -! #ifndef HMSWRF - e = e + bot(i,j) + botinc - h(i,j) -! ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea(i,j) - ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea -! #endif - - h(i,j) = bot(i,j) + botinc - endif - enddo - enddo -! maintain head = sea level for ocean (only for adjacent ocean, -! rest has hycond=0) - -! #ifdef HMSWRF -! -! do j=jfs,jfe -! do i=its,ife -! -! #else - do j=1,jx - do i=1,ix -! #endif - if (ltype(i,j).eq.2) then -! #ifndef HMSWRF - eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea -! eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea(i,j) -! #endif - h(i,j) = sealev - endif - enddo - enddo - -! Loop back for next ADI iteration - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -! #ifdef HMSWRF -! delcur = e/(xdim*ydim) -! #else - delcur = e/(ix*jx) -! #endif - -#ifdef MPP_LAND - -call mpi_reduce(delcur, mpiDelcur, 1, MPI_REAL, MPI_SUM, 0, MPI_COMM_WORLD, ierr) -call MPI_COMM_SIZE( MPI_COMM_WORLD, mpiSize, ierr ) - -mpiDelcur = mpiDelcur/mpiSize - -call mpi_bcast(delcur, 1, mpi_real, 0, MPI_COMM_WORLD, ierr) - -#endif - - if ( (delcur.gt.delskip*dt/86400. .and. iter.lt.itermax) & - .or. iter.lt.itermin ) then - goto 80 - else - endif - - -!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -! Compute convergence rate due to ground water flow (returned) - -! #ifdef HMSWRF -! -! do j=jfs,jfe -! do i=ifs,ife -! -! #else - do j=1,jx - do i=1,ix -! #endif - if (ltype(i,j).eq.1) then - convgw(i,j) = sf2(i,j) * (h(i,j)-ho(i,j)) / dt - else - convgw(i,j) = 0. - endif - enddo - enddo - -! Diagnostic water conservation check for this timestep - - dtot = 0. ! total change in water storage (m3) - dtoa = 0. - -! #ifdef HMSWRF -! -! do j=jts,jte -! do i=its,ite -! -! #else - do j=1,jx - do i=1,ix -! #endif - if (ltype(i,j).eq.1) then -! #ifdef HMSWRF - dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea - dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea -! #else -! dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea(i,j) -! dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea(i,j) -! #endif - endif - enddo - enddo - - dtot = (dtot/tareal)/dt ! convert to m/s, rel to land area - dtoa = (dtoa/tareal)/dt - eocn = (eocn/tareal)/dt - ebot = (ebot/tareal)/dt - - zz = 1.e3 * 86400. ! convert printout to mm/day -#ifdef HYDRO_D - write (*,900) & - dtot*zz, dtoa*zz, -eocn*zz, ebot*zz, & - (dtot-(-eocn+ebot))*zz -#endif - 900 format & - (3x,' dh/dt |dh/dt| ocnflx botfix',& - ' ',' ghmerror' & -! /3x,4f9.4,2(9x),e14.4) - /3x,5(e14.4)) - - return - end subroutine gwstep - - - SUBROUTINE SCOPY (NT, ARR, INCA, BRR, INCB) -! -! Copies array ARR to BRR, incrementing by INCA and INCB -! respectively, up to a total length of NT words of ARR. -! (Same as Cray SCOPY.) -! - real, DIMENSION(*) :: ARR, BRR - integer :: ia, nt, inca, incb, ib -! - IB = 1 - DO 10 IA=1,NT,INCA - BRR(IB) = ARR(IA) - IB = IB + INCB - 10 CONTINUE -! - RETURN - END SUBROUTINE SCOPY - -end module module_GW_baseflow diff --git a/wrfv2_fire/hydro/Routing/module_HYDRO_io.F b/wrfv2_fire/hydro/Routing/module_HYDRO_io.F deleted file mode 100644 index 54fbdf93..00000000 --- a/wrfv2_fire/hydro/Routing/module_HYDRO_io.F +++ /dev/null @@ -1,6340 +0,0 @@ -module module_HYDRO_io -#ifdef MPP_LAND - use module_mpp_land -#endif - use module_HYDRO_utils, only: get_dist_ll - use module_namelist, only: nlst_rt - use module_RT_data, only: rt_domain - - implicit none -#include - - contains - integer function get2d_real(var_name,out_buff,ix,jx,fileName) - implicit none - integer :: ivar, iret,varid,ncid,ix,jx - real out_buff(ix,jx) - character(len=*), intent(in) :: var_name - character(len=*), intent(in) :: fileName - get2d_real = -1 - - iret = nf_open(trim(fileName), NF_NOWRITE, ncid) - if (iret .ne. 0) then -#ifdef HYDRO_D - print*,"failed to open the netcdf file: ",trim(fileName) -#endif - out_buff = -9999. - return - endif - ivar = nf_inq_varid(ncid,trim(var_name), varid) - if(ivar .ne. 0) then - ivar = nf_inq_varid(ncid,trim(var_name//"_M"), varid) - if(ivar .ne. 0) then -#ifdef HYDRO_D - write(6,*) "Read Variable Error file: ",trim(fileName) - write(6,*) "Read Error: could not find ",trim(var_name) -#endif - return - endif - end if - iret = nf_get_var_real(ncid, varid, out_buff) - iret = nf_close(ncid) - get2d_real = ivar - end function get2d_real - - subroutine get2d_lsm_real(var_name,out_buff,ix,jx,fileName) - implicit none - integer ix,jx, status - character (len=*),intent(in) :: var_name, fileName - real,dimension(ix,jx):: out_buff -#ifdef MPP_LAND - real,allocatable, dimension(:,:) :: buff_g - -#ifdef HYDRO_D - write(6,*) "start to read variable ", var_name -#endif - allocate(buff_g (global_nx,global_ny) ) - - if(my_id .eq. IO_id) then - status = get2d_real(var_name,buff_g,global_nx,global_ny,fileName) - end if - call decompose_data_real(buff_g,out_buff) - deallocate(buff_g) -#else - status = get2d_real(var_name,out_buff,ix,jx,fileName) -#endif -#ifdef HYDRO_D - write(6,*) "finish reading variable ", var_name -#endif - end subroutine get2d_lsm_real - - subroutine get2d_lsm_vegtyp(out_buff,ix,jx,fileName) - implicit none - integer ix,jx, status,land_cat, iret, dimid,ncid - character (len=*),intent(in) :: fileName - character (len=256) units - integer,dimension(ix,jx):: out_buff - real, dimension(ix,jx) :: xdum -#ifdef MPP_LAND - real,allocatable, dimension(:,:) :: buff_g - - allocate(buff_g (global_nx,global_ny) ) - - if(my_id .eq. IO_id) then -#endif - ! Open the NetCDF file. - iret = nf_open(fileName, NF_NOWRITE, ncid) - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_static file: ''", A, "''")') & - trim(fileName) - call hydro_stop("get2d_lsm_vegtyp") -#endif - endif - - iret = nf_inq_dimid(ncid, "land_cat", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: land_cat" - call hydro_stop("get2d_lsm_vegtyp") -#endif - endif - - iret = nf_inq_dimlen(ncid, dimid, land_cat) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: land_cat" - call hydro_stop("get2d_lsm_vegtyp") -#endif - endif - -#ifdef MPP_LAND - call get_landuse_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat) - iret = nf_close(ncid) - end if - - call decompose_data_real(buff_g,xdum) - deallocate(buff_g) -#else - call get_landuse_netcdf(ncid, xdum, units, ix, jx, land_cat) - iret = nf_close(ncid) -#endif - out_buff = nint(xdum) - end subroutine get2d_lsm_vegtyp - - subroutine get_file_dimension(fileName, ix,jx) - implicit none - character(len=*) fileName - integer ncid , iret, ix,jx, dimid -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - iret = nf_open(fileName, NF_NOWRITE, ncid) - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_static file: ''", A, "''")') & - trim(fileName) - call hydro_stop("get_file_dimension") -#endif - endif - - iret = nf_inq_dimid(ncid, "west_east", dimid) - - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: west_east" - call hydro_stop("get_file_dimension") -#endif - endif - - iret = nf_inq_dimlen(ncid, dimid, ix) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: west_east" - call hydro_stop("get_file_dimension") -#endif - endif - - iret = nf_inq_dimid(ncid, "south_north", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: south_north" - call hydro_stop("get_file_dimension") -#endif - endif - - iret = nf_inq_dimlen(ncid, dimid, jx) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: south_north" - call hydro_stop("get_file_dimension") -#endif - endif - iret = nf_close(ncid) -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(ix) - call mpp_land_bcast_int1(jx) -#endif - - end subroutine get_file_dimension - - subroutine get2d_lsm_soltyp(out_buff,ix,jx,fileName) - implicit none - integer ix,jx, status,land_cat, iret, dimid,ncid - character (len=*),intent(in) :: fileName - character (len=256) units - integer,dimension(ix,jx):: out_buff - real, dimension(ix,jx) :: xdum -#ifdef MPP_LAND - real,allocatable, dimension(:,:) :: buff_g - - allocate(buff_g (global_nx,global_ny) ) - - if(my_id .eq. IO_id) then -#endif - ! Open the NetCDF file. - iret = nf_open(fileName, NF_NOWRITE, ncid) - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_static file: ''", A, "''")') & - trim(fileName) - call hydro_stop("get2d_lsm_soltyp") -#endif - endif - - iret = nf_inq_dimid(ncid, "soil_cat", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: soil_cat" - call hydro_stop("get2d_lsm_soltyp") -#endif - endif - - iret = nf_inq_dimlen(ncid, dimid, land_cat) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: soil_cat" - call hydro_stop("get2d_lsm_soltyp") -#endif - endif - -#ifdef MPP_LAND - call get_soilcat_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat) - iret = nf_close(ncid) - end if - - call decompose_data_real(buff_g,xdum) - deallocate(buff_g) -#else - call get_soilcat_netcdf(ncid, xdum, units, ix, jx, land_cat) - iret = nf_close(ncid) -#endif - out_buff = nint(xdum) - end subroutine get2d_lsm_soltyp - - - - - - - subroutine get_landuse_netcdf(ncid, array, units, idim, jdim, ldim) - implicit none -#include - integer, intent(in) :: ncid - integer, intent(in) :: idim, jdim, ldim - real, dimension(idim,jdim), intent(out) :: array - character(len=256), intent(out) :: units - integer :: iret, varid - real, dimension(idim,jdim,ldim) :: xtmp - integer, dimension(1) :: mp - integer :: i, j, l - character(len=24), parameter :: name = "LANDUSEF" - - units = "" - - iret = nf_inq_varid(ncid, trim(name), varid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_landuse_netcdf: nf_inq_varid" - call hydro_stop("get_landuse_netcdf") -#endif - endif - - iret = nf_get_var_real(ncid, varid, xtmp) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_landuse_netcdf: nf_get_var_real" - call hydro_stop("get_landuse_netcdf") -#endif - endif - - do i = 1, idim - do j = 1, jdim - mp = maxloc(xtmp(i,j,:)) - array(i,j) = mp(1) - do l = 1,ldim - if(xtmp(i,j,l).lt.0) array(i,j) = -9999.0 - enddo - enddo - enddo - - end subroutine get_landuse_netcdf - - - subroutine get_soilcat_netcdf(ncid, array, units, idim, jdim, ldim) - implicit none -#include - - integer, intent(in) :: ncid - integer, intent(in) :: idim, jdim, ldim - real, dimension(idim,jdim), intent(out) :: array - character(len=256), intent(out) :: units - integer :: iret, varid - real, dimension(idim,jdim,ldim) :: xtmp - integer, dimension(1) :: mp - integer :: i, j - character(len=24), parameter :: name = "SOILCTOP" - - units = "" - - iret = nf_inq_varid(ncid, trim(name), varid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_soilcat_netcdf: nf_inq_varid" - call hydro_stop("get_soilcat_netcdf") -#endif - endif - - iret = nf_get_var_real(ncid, varid, xtmp) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_soilcat_netcdf: nf_get_var_real" - call hydro_stop("get_soilcat_netcdf") -#endif - endif - - do i = 1, idim - do j = 1, jdim - mp = maxloc(xtmp(i,j,:)) - array(i,j) = mp(1) - enddo - enddo - - where (array == 14) array = 1 ! DJG remove all 'water' soils... - - end subroutine get_soilcat_netcdf - - -subroutine get_greenfrac_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) - implicit none -#include - integer, intent(in) :: ncid,mm,dd - integer, intent(in) :: idim, jdim, ldim - real, dimension(idim,jdim) :: array - real, dimension(idim,jdim) :: array2 - real, dimension(idim,jdim) :: diff - real, dimension(idim,jdim), intent(out) :: array3 - character(len=256), intent(out) :: units - integer :: iret, varid - real, dimension(idim,jdim,ldim) :: xtmp - integer, dimension(1) :: mp - integer :: i, j, mm2,daytot - real :: ddfrac - character(len=24), parameter :: name = "GREENFRAC" - - units = "fraction" - - iret = nf_inq_varid(ncid, trim(name), varid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_greenfrac_netcdf: nf_inq_varid" - call hydro_stop("get_greenfrac_netcdf") -#endif - endif - - iret = nf_get_var_real(ncid, varid, xtmp) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_greenfrac_netcdf: nf_get_var_real" - call hydro_stop("get_greenfrac_netcdf") -#endif - endif - - - if (mm.lt.12) then - mm2 = mm+1 - else - mm2 = 1 - end if - -!DJG_DES Set up dates for daily interpolation... - if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then - daytot = 31 - else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then - daytot = 30 - else if (mm.eq.2) then - daytot = 28 - end if - ddfrac = float(dd)/float(daytot) - if (ddfrac.gt.1.0) ddfrac = 1.0 ! Assumes Feb. 29th change is same as Feb 28th - -#ifdef HYDRO_D - print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac -#endif - - do i = 1, idim - do j = 1, jdim - array(i,j) = xtmp(i,j,mm) !GREENFRAC in geogrid in units of fraction from month 1 - array2(i,j) = xtmp(i,j,mm2) !GREENFRAC in geogrid in units of fraction from month 1 - diff(i,j) = array2(i,j) - array(i,j) - array3(i,j) = array(i,j) + ddfrac * diff(i,j) - enddo - enddo - -end subroutine get_greenfrac_netcdf - - - -subroutine get_albedo12m_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd) - implicit none -#include - integer, intent(in) :: ncid,mm,dd - integer, intent(in) :: idim, jdim, ldim - real, dimension(idim,jdim) :: array - real, dimension(idim,jdim) :: array2 - real, dimension(idim,jdim) :: diff - real, dimension(idim,jdim), intent(out) :: array3 - character(len=256), intent(out) :: units - integer :: iret, varid - real, dimension(idim,jdim,ldim) :: xtmp - integer, dimension(1) :: mp - integer :: i, j, mm2,daytot - real :: ddfrac - character(len=24), parameter :: name = "ALBEDO12M" - - - units = "fraction" - - iret = nf_inq_varid(ncid, trim(name), varid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_albedo12m_netcdf: nf_inq_varid" - call hydro_stop("get_albedo12m_netcdf") -#endif - endif - - iret = nf_get_var_real(ncid, varid, xtmp) - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_albedo12m_netcdf: nf_get_var_real" - call hydro_stop("get_albedo12m_netcdf") -#endif - endif - - if (mm.lt.12) then - mm2 = mm+1 - else - mm2 = 1 - end if - -!DJG_DES Set up dates for daily interpolation... - if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then - daytot = 31 - else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then - daytot = 30 - else if (mm.eq.2) then - daytot = 28 - end if - ddfrac = float(dd)/float(daytot) - if (ddfrac.gt.1.0) ddfrac = 1.0 ! Assumes Feb. 29th change is same as Feb 28th - -#ifdef HYDRO_D - print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac -#endif - - do i = 1, idim - do j = 1, jdim - array(i,j) = xtmp(i,j,mm) / 100.0 !Convert ALBEDO12M from % to fraction...month 1 - array2(i,j) = xtmp(i,j,mm2) / 100.0 !Convert ALBEDO12M from % to fraction... month 2 - diff(i,j) = array2(i,j) - array(i,j) - array3(i,j) = array(i,j) + ddfrac * diff(i,j) - enddo - enddo - -end subroutine get_albedo12m_netcdf - - - - subroutine get_2d_netcdf(name, ncid, array, units, idim, jdim, & - fatal_if_error, ierr) - implicit none -#include - character(len=*), intent(in) :: name - integer, intent(in) :: ncid - integer, intent(in) :: idim, jdim - real, dimension(idim,jdim), intent(out) :: array - character(len=256), intent(out) :: units - integer :: iret, varid - ! .TRUE._IF_ERROR: an input code value: - ! .TRUE. if an error in reading the data should stop the program. - ! Otherwise the, IERR error flag is set, but the program continues. - logical, intent(in) :: fatal_if_error - integer, intent(out) :: ierr - - units = "" - - iret = nf_inq_varid(ncid, name, varid) - - if (iret /= 0) then - if (fatal_IF_ERROR) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf: nf_inq_varid" - call hydro_stop("get_2d_netcdf") -#endif - else - ierr = iret - return - endif - endif - - - iret = nf_get_var_real(ncid, varid, array) - if (iret /= 0) then - if (fatal_IF_ERROR) then -#ifdef HYDRO_D - print*, 'name = "', trim(name)//'"' - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf: nf_get_var_real" - call hydro_stop("get_2d_netcdf") -#endif - else - ierr = iret - return - endif - endif - - ierr = 0; - end subroutine get_2d_netcdf - - subroutine get_2d_netcdf_cows(var_name,ncid,var, & - ix,jx,tlevel,fatal_if_error,ierr) -#include - character(len=*), intent(in) :: var_name - integer,intent(in) :: ncid,ix,jx,tlevel - real, intent(out):: var(ix,jx) - logical, intent(in) :: fatal_if_error - integer ierr, iret - integer varid - integer start(4),count(4) - data count /1,1,1,1/ - data start /1,1,1,1/ - count(1) = ix - count(2) = jx - start(4) = tlevel - iret = nf_inq_varid(ncid, var_name, varid) - - if (iret /= 0) then - if (fatal_IF_ERROR) then -#ifdef HYDRO_D - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid" - call hydro_stop("get_2d_netcdf_cows") -#endif - else - ierr = iret - return - endif - endif - iret = nf_get_vara_real(ncid, varid, start,count,var) - - return - end subroutine get_2d_netcdf_cows - -!--------------------------------------------------------- -!DJG Subroutinesfor inputting routing fields... -!DNY first reads the files to get the size of the -!DNY LINKS arrays -!DJG - Currently only hi-res topo is read -!DJG - At a future time, use this routine to input -!DJG subgrid land-use classification or routing -!DJG parameters 'overland roughness' and 'retention -!DJG depth' -! -!DJG,DNY - Update this subroutine to read in channel and lake -! parameters if activated 11.20.2005 -!--------------------------------------------------------- - - SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, & - route_direction_f, route_lake_f, NLINKS, NLAKES, & - CH_NETLNK, channel_option, geo_finegrid_flnm) - - implicit none -#include - INTEGER :: I,J,channel_option,iret,jj - INTEGER, INTENT(INOUT) :: NLINKS, NLAKES - INTEGER, INTENT(IN) :: IXRT,JXRT - INTEGER :: CHNID,cnt - INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction - INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - REAL, DIMENSION(IXRT,JXRT) :: LAT, LON - -!!Dummy read in grids for inverted y-axis - - - CHARACTER(len=*) :: route_chan_f, route_link_f,route_direction_f,route_lake_f - CHARACTER(len=256) :: InputLine - CHARACTER(len=256) :: geo_finegrid_flnm - CHARACTER(len=256) :: var_name -! external get2d_real -! integer :: get2d_real - - NLINKS = 0 - NLAKES = 0 - CH_NETRT = -9999 - CH_NETLNK = -9999 - - - cnt = 0 -#ifdef HYDRO_D - print *, "Channel Option in Routedim is ", channel_option -#endif - - IF(channel_option.eq.3) then !get maxnodes and links from grid - - var_name = "CHANNELGRID" - call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - - var_name = "FLOWDIRECTION" - call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - - var_name = "LAKEGRID" - call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - - - var_name = "LATITUDE" - call readRT2d_real(var_name,LAT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - var_name = "LONGITUDE" - call readRT2d_real(var_name,LON,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - -! temp fix for buggy Arc export... - do j=1,jxrt - do i=1,ixrt - if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 - end do - end do - -!DJG inv do j=jxrt,1,-1 - do j=1,jxrt - do i = 1, ixrt - if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then - NLINKS = NLINKS + 1 - endif - end do - end do -#ifdef HYDRO_D - print *, "NLINKS IS ", NLINKS -#endif - - -!DJG inv DO j = JXRT,1,-1 !rows - DO j = 1,JXRT !rows - DO i = 1 ,IXRT !colsumns - If (CH_NETRT(i, j) .ge. 0) then !get its direction - If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT).AND.(CH_NETRT(i,j+1) .ge.0) ) then !North - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1) .ge.0)) then !North East - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT).AND.(CH_NETRT(i+1,j) .ge. 0)) then !East - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & - .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i+1,j-1).ge.0)) then !south east - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0)) then !due south - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & - .AND. (j - 1 .NE. 0).AND. (CH_NETRT(i-1,j-1).ge.0) ) then !south west - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0)) then !West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0)) then !North West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else -#ifdef HYDRO_D - write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j -135 FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4) -#endif - if (DIRECTION(i,j) .eq. 0) then -#ifdef HYDRO_D - print *, "Direction i,j ",i,j," of point ", cnt, "is invalid" -#endif - endif - - End If - End If !CH_NETRT check for this node - END DO - END DO -#ifdef HYDRO_D - print *, "found type 0 nodes", cnt -#endif - -!Find out if the boundaries are on an edge or flow into a lake -!DJG inv DO j = JXRT,1,-1 - DO j = 1,JXRT - DO i = 1 ,IXRT - If (CH_NETRT(i, j) .ge. 0) then !get its direction - - If ( ((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) & !-- 64's can only flow north - .OR. ((DIRECTION(i, j) .EQ. 64).and. (j1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) & !-- 4's can only flow due south - .OR. ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west - .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge - .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE. 0)) & !-- 16's can only flow due west - .OR. ((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north - .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge - .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j - INTEGER, INTENT(IN) :: IXRT,JXRT - INTEGER :: CHANRTSWCRT, NLINKS, NLAKES - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION - INTEGER, DIMENSION(IXRT,JXRT) :: GSTRMFRXSTPTS - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT - INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - INTEGER, DIMENSION(IXRT,JXRT) :: GORDER !-- gridded stream orderk - INTEGER, DIMENSION(IXRT,JXRT) :: Link_Location !-- gridded stream orderk - INTEGER :: I,J,channel_option - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LATVAL, LONVAL - CHARACTER(len=28) :: dir -!Dummy inverted grids from arc - - -!----DJG,DNY New variables for channel and lake routing - CHARACTER(len=155) :: header - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: FROM_NODE - REAL, INTENT(OUT), DIMENSION(NLINKS) :: ZELEV - REAL, INTENT(OUT), DIMENSION(NLINKS) :: CHLAT,CHLON - - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: TYPEL - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: TO_NODE,ORDER - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: STRMFRXSTPTS - - INTEGER, INTENT(OUT) :: MAXORDER - REAL, INTENT(OUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum - REAL, INTENT(OUT), DIMENSION(NLINKS,2) :: QLINK !channel flow - REAL, INTENT(OUT), DIMENSION(NLINKS) :: CHANLEN !channel length - REAL, INTENT(OUT), DIMENSION(NLINKS) :: MannN, So !mannings N - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: LAKENODE ! identifies which nodes pour into which lakes - REAL, INTENT(IN) :: dist(ixrt,jxrt,9) - - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK - REAL, DIMENSION(IXRT,JXRT) :: ChSSlpG,BwG,MannNG !channel properties on Grid - - -!-- store the location x,y location of the channel element - INTEGER, INTENT(OUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ - -!--reservoir/lake attributes - REAL, INTENT(OUT), DIMENSION(NLAKES) :: HRZAREA - REAL, INTENT(OUT), DIMENSION(NLAKES) :: LAKEMAXH - REAL, INTENT(OUT), DIMENSION(NLAKES) :: WEIRC - REAL, INTENT(OUT), DIMENSION(NLAKES) :: WEIRL - REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEC - REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEA - REAL, INTENT(OUT), DIMENSION(NLAKES) :: ORIFICEE - REAL, INTENT(OUT), DIMENSION(NLAKES) :: LATLAKE,LONLAKE,ELEVLAKE - REAL, INTENT(OUT), DIMENSION(NLINKS) :: ChSSlp, Bw - - CHARACTER(len=256) :: route_link_f - CHARACTER(len=256) :: route_lake_f - CHARACTER(len=256) :: route_direction_f - CHARACTER(len=256) :: route_order_f - CHARACTER(len=256) :: geo_finegrid_flnm - CHARACTER(len=256) :: var_name - - INTEGER :: tmp, cnt, ncid, iret, jj,ct - real :: gc,n - -!--------------------------------------------------------- -! End Declarations -!--------------------------------------------------------- - MAXORDER = -9999 -!initialize GSTRM - GSTRMFRXSTPTS = -9999 - -!yw initialize the array. - to_node = MAXORDER - from_node = MAXORDER - -#ifdef HYDRO_D - print *, "reading routing initialization files..." - print *, "route direction", route_direction_f - print *, "route order", route_order_f - print *, "route linke",route_link_f - print *, "route lake",route_lake_f - - BwG = 0.0 - ChSSlpG = 0.0 - MannNG = 0.0 - TYPEL = 0 - MannN = 0.0 - Bw = 0.0 - ChSSlp = 0.0 - -#endif - -!DJG Edited code here to retrieve data from hires netcdf file.... - - IF((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then - - var_name = "LATITUDE" - call readRT2d_real(var_name,LATVAL,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - var_name = "LONGITUDE" - call readRT2d_real(var_name,LONVAL,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - - END IF - - - IF(CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2) then -!DJG change filename to LAKEPARM.TBL open(unit=79,file=trim(route_link_f), & - open(unit=79,file='LAKEPARM.TBL', & - form='formatted',status='old') - END IF - - - var_name = "LAKEGRID" - call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - var_name = "FLOWDIRECTION" - call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - var_name = "STREAMORDER" - call readRT2d_int(var_name,GORDER,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - var_name = "frxst_pts" - call readRT2d_int(var_name,GSTRMFRXSTPTS,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - -!--1/13/2011 real hi res sfc calibrtion parameters (...) -! var_name = "LAKEGRID" -! call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) -! var_name = "LAKEGRID" -! call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) - - -!-- real hi res channel properties (not yet implemented...) -! var_name = "MANNINGS" -! iret = get2d_real(var_name,MannNG,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) -! var_name = "SIDE_SLOPE" -! iret = get2d_real(var_name,ChSSlpG,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) -! var_name = "BOTTOM_WIDTH" -! iret = get2d_real(var_name,BwG,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) - - -!!!Flip y-dimension of highres grids from exported Arc files... - - - - - -! temp fix for buggy Arc export... - do j=1,jxrt - do i=1,ixrt - if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 - end do - end do - - cnt =0 - if ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option .ne. 3) then ! not routing on grid, read from file - read(79,*) header - do i=1,NLINKS - read (79,*) tmp, FROM_NODE(i), TO_NODE(i), TYPEL(i),& - ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), & - MannN(i), So(i), ChSSlp(i), Bw(i), HRZAREA(i),& - LAKEMAXH(i), WEIRC(i), WEIRL(i), ORIFICEC(i), & - ORIFICEA(i),ORIFICEE(i) - - !-- hardwire QLINK - QLINK(i,1) = 1.0 - QLINK(i,2) = QLINK(i,1) - - if (So(i).lt.0.005) So(i) = 0.005 !-- impose a minimum slope requireement - - if (ORDER(i) .gt. MAXORDER) then - MAXORDER = ORDER(i) - endif - - end do - - elseif ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then !-- handle setting up topology on the grid for diffusion scheme - - read(79,*) header !-- read the lake file -#ifdef HYDRO_D - write(*,*) "reading lake file ", header - write(6,*) "error check read file ",route_link_f -#endif - - - if (NLAKES.gt.0) then !read in only if there are lakes - do i=1, NLAKES - read (79,*) tmp, HRZAREA(i),LAKEMAXH(i), & - WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),& - LATLAKE(i), LONLAKE(i),ELEVLAKE(i) -#ifdef HYDRO_D - write (*,*) tmp, HRZAREA(i),LAKEMAXH(i), LATLAKE(i), LONLAKE(i),ELEVLAKE(i),NLAKES -#endif - enddo - end if !end if for NLAKES >0 check - - cnt = 0 - -!yw add temperary to initialize the following two variables. - -!yw debug -! write(6,*) "ixrt =",ixrt, "jxrt=",jxrt -! write(18) CH_NETRT -! write(19) DIRECTION -! write(20) GORDER -! write(21) GSTRMFRXSTPTS -! write(22) ELRT -!ywend debug - - BwG = 0.0 - ChSSlpG = 0.0 - -!DJG inv DO j = JXRT,1,-1 !rows - DO j = 1,JXRT !rows - DO i = 1 ,IXRT !colsumns - If (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order - If ((DIRECTION(i, j) .EQ. 64) .AND. (j + 1 .LE. JXRT) .AND. & - (CH_NETRT(i,j+1).ge.0) ) then !North - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i, j + 1) - CHANLEN(cnt) = dist(i,j,1) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1).ge.0) ) then !North East - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1) - CHANLEN(cnt) = dist(i,j,2) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT) & - .AND. (CH_NETRT(i+1,j).ge.0) ) then !East - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j) - CHANLEN(cnt) = dist(i,j,3) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & - .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i+1,j-1).ge.0) ) then !south east - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1) - CHANLEN(cnt) = dist(i,j,4) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0) ) then !due south - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i, j - 1) - CHANLEN(cnt) = dist(i,j,5) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & - .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i-1,j-1).ge.0)) then !south west - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i,j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1) - CHANLEN(cnt) = dist(i,j,6) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0) ) then !West - cnt = cnt + 1 - FROM_NODE(cnt) = CH_NETLNK(i, j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j) - CHANLEN(cnt) = dist(i,j,7) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0) ) then !North West - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1) - CHANLEN(cnt) = dist(i,j,8) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else -#ifdef HYDRO_D - print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east -#endif - End If - - End If !CH_NETRT check for this node - - END DO - END DO - -#ifdef HYDRO_D - print *, "after exiting the channel, this many nodes", cnt - write(*,*) " " -#endif - -!Find out if the boundaries are on an edge -!DJG inv DO j = JXRT,1,-1 - DO j = 1,JXRT - DO i = 1 ,IXRT - If (CH_NETRT(i, j) .ge. 0) then !get its direction - If (((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) .OR. & !-- 64's can only flow north - ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(j+1 .GT. JXRT) then !-- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i,j+1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i,j+1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,1) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - else if ( ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .GT. IXRT)) & !-- 128's can flow out of the North or East edge - .OR. ((DIRECTION(i, j) .EQ. 128) .AND. (j + 1 .GT. JXRT)) & ! this is due north edge - .OR. ((DIRECTION(i, j) .EQ. 128) .AND. (i1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if((i+1 .GT. IXRT) .OR. (j-1 .EQ. 0)) then !an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i+1,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,4) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - else if (((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) .OR. & !-- 4's can only flow due south - ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(j-1 .EQ. 0) then !- an edge - TYPEL(cnt) =1 - elseif(LAKE_MSKRT(i,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,5) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west - .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge - .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if( (i-1 .EQ. 0) .OR. (j-1 .EQ. 0) ) then !- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i-1,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,6) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - else if (((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE.0) ) & !16's can only flow due west - .OR.((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West - cnt = cnt + 1 - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(i-1 .EQ. 0) then !-- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i-1,j).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i-1,j) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,7) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north - .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge - .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j - - integer, intent(in) :: IX,JX,IXRT,JXRT,AGGFACTRT - integer, intent(in), dimension(IXRT,JXRT) :: ch_netrt - integer, intent(out) :: numbasns - integer, intent(out), dimension(IX,JX) :: GWSUBBASMSK - integer, intent(out), dimension(IXRT,JXRT) :: gw_strm_msk - character(len=256) :: gwbasmskfil - integer :: i,j,aggfacxrt,aggfacyrt,ixxrt,jyyrt - - numbasns = 0 - gw_strm_msk = -9999 - -!Open files... - open(unit=91,file=trim(gwbasmskfil), & - form='formatted',status='old') - -!Read in sub-basin mask... - do j=jx,1,-1 - read (91,*) (GWSUBBASMSK(i,j),i=1,ix) - end do - close(91) - - -!Loop through to count number of basins and assign basin indices to chan grid - do J=1,JX - do I=1,IX - -!Determine max number of basins...(assumes basins are numbered -! sequentially from 1 to max number of basins...) - if (GWSUBBASMSK(i,j).gt.numbasns) then - numbasns = GWSUBBASMSK(i,j) ! get count of basins... - end if - -!Assign gw basin index values to channel grid... - do AGGFACYRT=AGGFACTRT-1,0,-1 - do AGGFACXRT=AGGFACTRT-1,0,-1 - - IXXRT=I*AGGFACTRT-AGGFACXRT - JYYRT=J*AGGFACTRT-AGGFACYRT - IF(ch_netrt(IXXRT,JYYRT).ge.0) then !If channel grid cell - gw_strm_msk(IXXRT,JYYRT) = GWSUBBASMSK(i,j) ! assign coarse grid basn indx to chan grid - END IF - - end do !AGGFACXRT - end do !AGGFACYRT - - end do !I-ix - end do !J-jx - -#ifdef HYDRO_D - write(6,*) "numbasns = ", numbasns -#endif - - return - -!DJG ----------------------------------------------------- - END SUBROUTINE READ_SIMP_GW -!DJG ----------------------------------------------------- - - ! BF read the static input fields needed for the 2D GW scheme - subroutine readGW2d(ix, jx, hc, ihead, botelv, por, ltype) - implicit none -#include - integer, intent(in) :: ix, jx - integer, dimension(ix,jx), intent(inout):: ltype - real, dimension(ix,jx), intent(inout) :: hc, ihead, botelv, por - -#ifdef MPP_LAND - integer, dimension(:,:), allocatable :: gLtype - real, dimension(:,:), allocatable :: gHC, gIHEAD, gBOTELV, gPOR -#endif - integer :: i -!, get2d_real - -#ifdef MPP_LAND - allocate(gHC(global_rt_nx, global_rt_ny)) - allocate(gIHEAD(global_rt_nx, global_rt_ny)) - allocate(gBOTELV(global_rt_nx, global_rt_ny)) - allocate(gPOR(global_rt_nx, global_rt_ny)) - allocate(gLtype(global_rt_nx, global_rt_ny)) - - if(my_id .eq. IO_id) then -#ifdef HYDRO_D - print*, "2D GW-Scheme selected, retrieving files from gwhires.nc ..." -#endif -#endif - - - ! hydraulic conductivity - i = get2d_real("HC", & -#ifdef MPP_LAND - gHC, global_nx, global_ny, & -#else - hc, ix, jx, & -#endif - trim("./gwhires.nc")) - - ! initial head - i = get2d_real("IHEAD", & -#ifdef MPP_LAND - gIHEAD, global_nx, global_ny, & -#else - ihead, ix, jx, & -#endif - trim("./gwhires.nc")) - - ! aquifer bottom elevation - i = get2d_real("BOTELV", & -#ifdef MPP_LAND - gBOTELV, global_nx, global_ny, & -#else - botelv, ix, jx, & -#endif - trim("./gwhires.nc")) - - ! aquifer porosity - i = get2d_real("POR", & -#ifdef MPP_LAND - gPOR, global_nx, global_ny, & -#else - por, ix, jx, & -#endif - trim("./gwhires.nc")) - -! bftodo: develop proper landtype mask - -#ifdef MPP_LAND - gLtype=1 - gLtype(1,:) = 2 - gLtype(:,1) = 2 - gLtype(global_rt_nx,:) = 2 - gLtype(:,global_rt_ny) = 2 -#else - ltype=1 - ltype(1,:) =2 - ltype(:,1) =2 - ltype(ix,:)=2 - ltype(:,jx)=2 -#endif - -#ifdef MPP_LAND - endif - call decompose_rt_int (gLtype, ltype, global_rt_nx, global_rt_ny, ix, jx) - call decompose_rt_real(gHC,hc,global_rt_nx, global_rt_ny, ix, jx) - call decompose_rt_real(gIHEAD,ihead,global_rt_nx, global_rt_ny, ix, jx) - call decompose_rt_real(gBOTELV,botelv,global_rt_nx, global_rt_ny, ix, jx) - call decompose_rt_real(gPOR,por,global_rt_nx, global_rt_ny, ix, jx) - deallocate(gHC, gIHEAD, gBOTELV, gPOR) -#endif - !bftodo: make filename accessible in namelist - return - end subroutine readGW2d - !BF - - - - - subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & - startdate, date, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID, & - q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, & - geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,HIRES_OUT, & - QBDRYRT) - -!output the routing variables over routing grid. - implicit none -#include - - integer, intent(in) :: igrid - integer, intent(in) :: split_output_count - integer, intent(in) :: ixrt,jxrt - real, intent(in) :: dt - real, intent(in) :: dist(ixrt,jxrt,9) - integer, intent(in) :: nsoil - integer, intent(in) :: HIRES_OUT - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - character(len=*), intent(in) :: geo_finegrid_flnm - real, dimension(nsoil), intent(in) :: sldpth - real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable - real*8, allocatable, DIMENSION(:) :: xcoord_d, xcoord - real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord - - integer, save :: ncid,ncstatic - integer, save :: output_count - real, dimension(nsoil) :: asldpth - - integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n - integer :: iret, dimid_soil, i,j,ii,jj - character(len=256) :: output_flnm - character(len=19) :: date19 - character(len=32) :: convention - character(len=34) :: sec_since_date - - character(len=30) :: soilm - - real :: long_cm,lat_po,fe,fn, chan_in - real, dimension(2) :: sp - - real, dimension(ixrt,jxrt) :: xdum,QSUBRT,ZWATTABLRT,SUB_RESID - real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y - real, dimension(ixrt,jxrt) :: QSTRMVOLRT - real, dimension(ixrt,jxrt) :: SFCHEADSUBRT - real, dimension(ixrt,jxrt) :: soxrt,soyrt - real, dimension(ixrt,jxrt) :: LATVAL,LONVAL, QBDRYRT - real, dimension(ixrt,jxrt,nsoil) :: SMCRT - - integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag - sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' - seconds_since = int(dt)*output_count - - decimation = 1 !-- decimation factor - ixrtd = int(ixrt/decimation) - jxrtd = int(jxrt/decimation) - allocate(xdumd(ixrtd,jxrtd)) - allocate(xcoord_d(ixrtd)) - allocate(ycoord_d(jxrtd)) - allocate(xcoord(ixrtd)) - allocate(ycoord(jxrtd)) - ii = 0 - jj = 0 - -!DJG Dump timeseries for channel inflow accum. for calibration...(8/28/09) - chan_in = 0.0 - do j=1,jxrt - do i=1,ixrt - chan_in=chan_in+QSTRMVOLRT(I,J)/1000.0*(dist(i,j,9)) !(units m^3) - enddo - enddo - open (unit=46,file='qstrmvolrt_accum.txt',form='formatted',& - status='unknown',position='append') - write (46,713) chan_in -713 FORMAT (F20.7) - close (46) -! return -!DJG end dump of channel inflow for calibration.... - - if (hires_out.eq.1) return ! return if hires flag eq 1, if =2 output full grid - - if (output_count == 0) then - - !-- Open the finemesh static files to obtain projection information -#ifdef HYDRO_D - write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) -#endif - iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic) - - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & - trim(geo_finegrid_flnm) - write(*,*) "HIRES_OUTPUT will not be georeferenced..." -#endif - - hires_flag = 0 - else - hires_flag = 1 - endif - - if(hires_flag.eq.1) then !if/then hires_georef - ! Get Latitude (X) - iret = NF_INQ_VARID(ncstatic,'x',varid) - if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord) - ! Get Longitude (Y) - iret = NF_INQ_VARID(ncstatic,'y',varid) - if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord) - else - xcoord_d = 0. - ycoord_d = 0. - end if !endif hires_georef - - do j=jxrt,1,-1*decimation - jj = jj+1 - if (jj<= jxrtd) then - ycoord_d(jj) = ycoord(j) - endif - enddo - -!yw do i = 1,ixrt,decimation -!yw ii = ii + 1 -!yw if (ii <= ixrtd) then -!yw xcoord_d(ii) = xcoord(i) - xcoord_d = xcoord -!yw endif -!yw enddo - - - if(hires_flag.eq.1) then !if/then hires_georef - ! Get projection information from finegrid netcdf file - iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) - if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file - end if !endif hires_georef - iret = nf_close(ncstatic) - -!-- create the fine grid routing file - write(output_flnm, '(A12,".RTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid -#ifdef HYDRO_D - print*, 'output_flnm = "'//trim(output_flnm)//'"' -#endif -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) -#endif -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("output_rt") - endif -#endif - - iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times) - iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx) - iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil) !-- 3-d soils - -!--- define variables -! !- time definition, timeObs - iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) - - !- x-coordinate in cartesian system - iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') - iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') - iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - - !- y-coordinate in cartesian ssystem - iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') - iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') - iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - - !- LATITUDE - iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE') - iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE') - iret = nf_put_att_text(ncid,varid,'units',5,'deg North') - - !- LONGITUDE - iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE') - iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE') - iret = nf_put_att_text(ncid,varid,'units',5,'deg east') - - !-- z-level is soil - iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid) - iret = nf_put_att_text(ncid,varid,'units',2,'cm') - iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer') - - iret = nf_def_var(ncid, "SOIL_M", NF_FLOAT, 4, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',7,'m^3/m^3') - iret = nf_put_att_text(ncid,varid,'description',16,'moisture content') - iret = nf_put_att_text(ncid,varid,'long_name',26,soilm) -! iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"ESNOW2D",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - -! iret = nf_def_var(ncid,"QSUBRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) -! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') -! iret = nf_put_att_text(ncid,varid,'long_name',15,'subsurface flow') -! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') -! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') -! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"ZWATTABLRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',1,'m') - iret = nf_put_att_text(ncid,varid,'long_name',17,'water table depth') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"Q_SFCFLX_X",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) -! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') -! iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux x') -! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') -! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') -! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"Q_SFCFLX_Y",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) -! iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') -! iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux y') -! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') -! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') -! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"QSTRMVOLRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',2,'mm') - iret = nf_put_att_text(ncid,varid,'long_name',14,'channel inflow') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"SFCHEADSUBRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',2,'mm') - iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"SOXRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) -! iret = nf_put_att_text(ncid,varid,'units',1,'1') -! iret = nf_put_att_text(ncid,varid,'long_name',7,'slope x') -! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') -! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') -! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"SOYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) -! iret = nf_put_att_text(ncid,varid,'units',1,'1') -! iret = nf_put_att_text(ncid,varid,'long_name',7,'slope 7') -! iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') -! iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') -! iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -! iret = nf_def_var(ncid,"SUB_RESID",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - - iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',2,'mm') - iret = nf_put_att_text(ncid,varid,'long_name',70, & - 'accumulated value of the boundary flux, + into domain, - out of domain') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -!-- place projection information - if(hires_flag.eq.1) then !if/then hires_georef - iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid) - iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm) - iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po) - iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe) - iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn) - iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp) - end if !endif hires_georef - -! iret = nf_def_var(ncid,"Date", NF_CHAR, 2, (/dimid_datelen,dimid_times/), varid) - - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(startdate)) = startdate - convention(1:32) = "CF-1.0" - iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19) - iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation) - - iret = nf_enddef(ncid) - -!!-- write latitude and longitude locations -! xdumd = LATVAL - iret = nf_inq_varid(ncid,"x", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array - -! xdumd = LONVAL - iret = nf_inq_varid(ncid,"y", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array - - xdumd = LATVAL - iret = nf_inq_varid(ncid,"LATITUDE", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - - xdumd = LONVAL - iret = nf_inq_varid(ncid,"LONGITUDE", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - - -#ifdef HYDRO_D - write (*,*) "TEST....",LONVAL (1,1),(1,2) - write (*,*) "TEST....",LATVAL (1,1),(1,2) -#endif - - - - - do n = 1,nsoil - if(n == 1) then - asldpth(n) = -sldpth(n) - else - asldpth(n) = asldpth(n-1) - sldpth(n) - endif - enddo - - iret = nf_inq_varid(ncid,"depth", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth) -!yw iret = nf_close(ncstatic) - - endif - - output_count = output_count + 1 - -!!-- time - iret = nf_inq_varid(ncid,"time", varid) - iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since) - -!-- 3-d soils - do n = 1, nsoil -!DJG inv jj = int(jxrt/decimation) - jj = 1 - ii = 0 -!DJG inv do j = jxrt,1,-decimation - do j = 1,jxrt,decimation - do i = 1,ixrt,decimation - ii = ii + 1 - if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then - xdumd(ii,jj) = smcrt(i,j,n) - endif - enddo - ii = 0 -!DJG inv jj = jj -1 - jj = jj + 1 - enddo -! where (vegtyp(:,:) == 16) xdum = -1.E33 - iret = nf_inq_varid(ncid, "SOIL_M", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/), xdumd) - enddo !-n soils - - -!! where (vegtyp(:,:) == 16) xdum = -1.E33 -! jj = int(jxrt/decimation) -! ii = 0 -!! do j = jxrt,1,-decimation -! do j = 1,jxrt,decimation -! do i = 1,ixrt,decimation -! ii = ii + 1 -! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then -! xdumd(ii,jj) = QSUBRT(i,j) -! endif -! enddo -! ii = 0 -! jj = jj - 1 -! enddo -! iret = nf_inq_varid(ncid, "QSUBRT", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -! xdum = ZWATTABLRT -! where (vegtyp(:,:) == 16) xdum = -1.E33 -!DJG inv jj = int(jxrt/decimation) - jj = 1 - ii = 0 -!DJG inv do j = jxrt,1,-decimation - do j = 1,jxrt,decimation - do i = 1,ixrt,decimation - ii = ii + 1 - if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then - xdumd(ii,jj) = ZWATTABLRT(i,j) - endif - enddo - ii = 0 -!DJG inv jj = jj - 1 - jj = jj + 1 - enddo - iret = nf_inq_varid(ncid, "ZWATTABLRT", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - - -!! xdum = Q_SFCFLX_X -!!! where (vegtyp(:,:) == 16) xdum = -1.E33 -! jj = int(jxrt/decimation) -! ii = 0 -!! do j = jxrt,1,-decimation -! do j = 1,jxrt,decimation -! do i = 1,ixrt,decimation -! ii = ii + 1 -! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then -! xdumd(ii,jj) = Q_SFCFLX_X(i,j) -! endif -! enddo -! ii = 0 -! jj = jj - 1 -! enddo -! iret = nf_inq_varid(ncid, "Q_SFCFLX_X", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) -!! -!! xdum = Q_SFCFLX_Y -!!! where (vegtyp(:,:) == 16) xdum = -1.E33 -! jj = int(jxrt/decimation) -! ii = 0 -!! do j = jxrt,1,-decimation -! do j = 1,jxrt,decimation -! do i = 1,ixrt,decimation -! ii = ii + 1 -! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then -! xdumd(ii,jj) = Q_SFCFLX_Y(i,j) -! endif -! enddo -! ii = 0 -! jj = jj - 1 -! enddo -! iret = nf_inq_varid(ncid, "Q_SFCFLX_Y", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -! for compareing between sequential and parallel to initialized xdumd - xdumd = 0.0 - jj = 1 - ii = 0 - do j = 1,jxrt,decimation - do i = 1,ixrt,decimation - ii = ii + 1 - if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then - xdumd(ii,jj) = QBDRYRT(i,j) - endif - enddo - ii = 0 - jj = jj + 1 - enddo - iret = nf_inq_varid(ncid, "QBDRYRT", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - - - xdumd = 0.0 -! xdum = QSTRMVOLRT -!! where (vegtyp(:,:) == 16) xdum = -1.E33 -!DJG inv jj = int(jxrt/decimation) - jj = 1 - ii = 0 -!DJG inv do j = jxrt,1,-decimation - do j = 1,jxrt,decimation - do i = 1,ixrt,decimation - ii = ii + 1 - if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then - xdumd(ii,jj) = QSTRMVOLRT(i,j) - endif - enddo - ii = 0 -!DJG inv jj = jj - 1 - jj = jj + 1 - enddo - iret = nf_inq_varid(ncid, "QSTRMVOLRT", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -! xdum = SFCHEADSUBRT -! where (vegtyp(:,:) == 16) xdum = -1.E33 -!DJG inv jj = int(jxrt/decimation) - jj = 1 - ii = 0 -!DJG inv do j = jxrt,1,-decimation - do j = 1,jxrt,decimation - do i = 1,ixrt,decimation - ii = ii + 1 - if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then - xdumd(ii,jj) = SFCHEADSUBRT(i,j) - endif - enddo - ii = 0 -!DJG inv jj = jj - 1 - jj = jj + 1 - enddo - iret = nf_inq_varid(ncid, "SFCHEADSUBRT", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - - -! iret = nf_inq_varid(ncid, "SOXRT", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -!!! where (vegtyp(:,:) == 16) xdum = -1.E33 -! iret = nf_inq_varid(ncid, "SOYRT", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) -! -!! xdum = SUB_RESID -!!! where (vegtyp(:,:) == 16) xdum = -1.E33 -!! iret = nf_inq_varid(ncid, "SUB_RESID", varid) -!! iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) -! -!!time in seconds since startdate - - iret = nf_redef(ncid) - date19(1:len_trim(date)) = date - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) - - iret = nf_enddef(ncid) - iret = nf_sync(ncid) - if (output_count == split_output_count) then - output_count = 0 - iret = nf_close(ncid) - endif - - deallocate(xdumd) - deallocate(xcoord_d) - deallocate(xcoord) - deallocate(ycoord_d) - deallocate(ycoord) - -#ifdef HYDRO_D - write(6,*) "end of output_rt" -#endif - - end subroutine output_rt - -!BF output section for gw2d model -!bftodo: clean up an customize for GW usage - subroutine output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, & - startdate, date, HEAD, SMCRT, convgw, SFCHEADSUBRT, & - geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,HIRES_OUT) - -#ifdef MPP_LAND - USE module_mpp_land -#endif -!output the routing variables over routing grid. - implicit none -#include - - integer, intent(in) :: igrid - integer, intent(in) :: split_output_count - integer, intent(in) :: ixrt,jxrt - real, intent(in) :: dt - real, intent(in) :: dist(ixrt,jxrt,9) - integer, intent(in) :: nsoil - integer, intent(in) :: HIRES_OUT - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - character(len=*), intent(in) :: geo_finegrid_flnm - real, dimension(nsoil), intent(in) :: sldpth - real, allocatable, DIMENSION(:,:) :: xdumd !-- decimated variable - real*8, allocatable, DIMENSION(:) :: xcoord_d, xcoord - real*8, allocatable, DIMENSION(:) :: ycoord_d, ycoord - - integer, save :: ncid,ncstatic - integer, save :: output_count - real, dimension(nsoil) :: asldpth - - integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n - integer :: iret, dimid_soil, i,j,ii,jj - character(len=256) :: output_flnm - character(len=19) :: date19 - character(len=32) :: convention - character(len=34) :: sec_since_date - - character(len=30) :: soilm - - real :: long_cm,lat_po,fe,fn, chan_in - real, dimension(2) :: sp - - real, dimension(ixrt,jxrt) :: head, convgw - real, dimension(ixrt,jxrt) :: SFCHEADSUBRT - real, dimension(ixrt,jxrt) :: latval,lonval - real, dimension(ixrt,jxrt,nsoil) :: SMCRT - - integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag - -#ifdef MPP_LAND - real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gSFCHEADSUBRT - real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval - real, dimension(global_rt_nx,global_rt_ny,nsoil) :: gSMCRT -#endif - -#ifdef MPP_LAND - call write_IO_rt_real(latval,gLatval) - call write_IO_rt_real(lonval,gLonval) - call write_IO_rt_real(SFCHEADSUBRT,gSFCHEADSUBRT) - call write_IO_rt_real(head,gHead) - call write_IO_rt_real(convgw,gConvgw) - - do i = 1, NSOIL - call write_IO_rt_real(SMCRT(:,:,i),gSMCRT(:,:,i)) - end do - - if(my_id.eq.IO_id) then - - -#endif - sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' - seconds_since = int(dt)*output_count - - decimation = 1 !-- decimation factor -#ifdef MPP_LAND - ixrtd = int(global_rt_nx/decimation) - jxrtd = int(global_rt_ny/decimation) -#else - ixrtd = int(ixrt/decimation) - jxrtd = int(jxrt/decimation) -#endif - allocate(xdumd(ixrtd,jxrtd)) - allocate(xcoord_d(ixrtd)) - allocate(ycoord_d(jxrtd)) - allocate(xcoord(ixrtd)) - allocate(ycoord(jxrtd)) - ii = 0 - jj = 0 - - if (hires_out.eq.1) return ! return if hires flag eq 1, if =2 output full grid - - if (output_count == 0) then - - !-- Open the finemesh static files to obtain projection information -#ifdef HYDRO_D - write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm) - -#endif - iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic) - - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_finegrid file: ''", A, "''")') & - trim(geo_finegrid_flnm) - write(*,*) "HIRES_OUTPUT will not be georeferenced..." -#endif - hires_flag = 0 - else - hires_flag = 1 - endif - - if(hires_flag.eq.1) then !if/then hires_georef - ! Get Latitude (X) - iret = NF_INQ_VARID(ncstatic,'x',varid) - if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord) - ! Get Longitude (Y) - iret = NF_INQ_VARID(ncstatic,'y',varid) - if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord) - else - xcoord_d = 0. - ycoord_d = 0. - end if !endif hires_georef - - do j=jxrt,1,-1*decimation - jj = jj+1 - if (jj<= jxrtd) then - ycoord_d(jj) = ycoord(j) - endif - enddo - -!yw do i = 1,ixrt,decimation -!yw ii = ii + 1 -!yw if (ii <= ixrtd) then -!yw xcoord_d(ii) = xcoord(i) - xcoord_d = xcoord -!yw endif -!yw enddo - - - if(hires_flag.eq.1) then !if/then hires_georef - ! Get projection information from finegrid netcdf file - iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid) - if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn) !-- read it from the static file - iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp) !-- read it from the static file - end if !endif hires_georef - iret = nf_close(ncstatic) - -!-- create the fine grid routing file - write(output_flnm, '(A12,".GW_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid -#ifdef HYDRO_D - print*, 'output_flnm = "'//trim(output_flnm)//'"' -#endif - - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) -#endif - -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("output_rt") - endif -#endif - - iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times) - iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx) - iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil) !-- 3-d soils - -!--- define variables - !- time definition, timeObs - iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) - - !- x-coordinate in cartesian system - iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') - iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') - iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - - !- y-coordinate in cartesian ssystem - iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') - iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') - iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - - !- LATITUDE - iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE') - iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE') - iret = nf_put_att_text(ncid,varid,'units',5,'deg North') - - !- LONGITUDE - iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE') - iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE') - iret = nf_put_att_text(ncid,varid,'units',5,'deg east') - - !-- z-level is soil - iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid) - iret = nf_put_att_text(ncid,varid,'units',2,'cm') - iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer') - - iret = nf_def_var(ncid, "SOIL_M", NF_FLOAT, 4, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',6,'kg m-2') - iret = nf_put_att_text(ncid,varid,'description',16,'moisture content') - iret = nf_put_att_text(ncid,varid,'long_name',26,soilm) -! iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"HEAD",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',1,'m') - iret = nf_put_att_text(ncid,varid,'long_name',17,'groundwater head') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"CONVGW",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',2,'mm') - iret = nf_put_att_text(ncid,varid,'long_name',12,'channel flux') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - iret = nf_def_var(ncid,"Platzhalter",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid) - iret = nf_put_att_text(ncid,varid,'units',2,'mm') - iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - -!-- place projection information - if(hires_flag.eq.1) then !if/then hires_georef - iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid) - iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm) - iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po) - iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe) - iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn) - iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp) - end if !endif hires_georef - -! iret = nf_def_var(ncid,"Date", NF_CHAR, 2, (/dimid_datelen,dimid_times/), varid) - - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(startdate)) = startdate - convention(1:32) = "CF-1.0" - iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19) - iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation) - - iret = nf_enddef(ncid) - -!!-- write latitude and longitude locations -! xdumd = LATVAL - iret = nf_inq_varid(ncid,"x", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array - -! xdumd = LONVAL - iret = nf_inq_varid(ncid,"y", varid) -! iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array - -#ifdef MPP_LAND - xdumd = gLATVAL -#else - xdumd = LATVAL -#endif - iret = nf_inq_varid(ncid,"LATITUDE", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - -#ifdef MPP_LAND - xdumd = gLONVAL -#else - xdumd = LONVAL -#endif - iret = nf_inq_varid(ncid,"LONGITUDE", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd) - - do n = 1,nsoil - if(n == 1) then - asldpth(n) = -sldpth(n) - else - asldpth(n) = asldpth(n-1) - sldpth(n) - endif - enddo - - iret = nf_inq_varid(ncid,"depth", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth) -!yw iret = nf_close(ncstatic) - - endif - - output_count = output_count + 1 - -!!-- time - iret = nf_inq_varid(ncid,"time", varid) - iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since) - -!-- 3-d soils - do n = 1, nsoil -#ifdef MPP_LAND - xdumd = gSMCRT(:,:,n) -#else - xdumd = SMCRT(:,:,n) -#endif -! !DJG inv jj = int(jxrt/decimation) -! jj = 1 -! ii = 0 -! !DJG inv do j = jxrt,1,-decimation -! do j = 1,jxrt,decimation -! do i = 1,ixrt,decimation -! ii = ii + 1 -! if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then -! xdumd(ii,jj) = smcrt(i,j,n) -! endif -! enddo -! ii = 0 -! !DJG inv jj = jj -1 -! jj = jj + 1 -! enddo -! where (vegtyp(:,:) == 16) xdum = -1.E33 - iret = nf_inq_varid(ncid, "SOIL_M", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/), xdumd) - enddo !-n soils - -#ifdef MPP_LAND - xdumd = gHead -#else - xdumd = head -#endif - - iret = nf_inq_varid(ncid, "HEAD", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -#ifdef MPP_LAND - xdumd = gConvgw -#else - xdumd = convgw -#endif - iret = nf_inq_varid(ncid, "CONVGW", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd) - -!!time in seconds since startdate - - iret = nf_redef(ncid) - date19(1:len_trim(date)) = date - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) - - iret = nf_enddef(ncid) - iret = nf_sync(ncid) - if (output_count == split_output_count) then - output_count = 0 - iret = nf_close(ncid) - endif - - deallocate(xdumd) - deallocate(xcoord_d) - deallocate(xcoord) - deallocate(ycoord_d) - deallocate(ycoord) - -#ifdef HYDRO_D - write(6,*) "end of output_ge" -#endif -#ifdef MPP_LAND - endif -#endif - - end subroutine output_gw - -!-- output the channel route in an IDV 'station' compatible format - subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER, & - startdate,date,chlon, chlat, hlink,zelev,qlink,dtrt,K, & - STRMFRXSTPTS,order_to_write) - - implicit none -#include -!!output the routing variables over just channel - integer, intent(in) :: igrid,K - integer, intent(in) :: split_output_count - integer, intent(in) :: NLINKS - real, dimension(NLINKS), intent(in) :: chlon,chlat - real, dimension(NLINKS), intent(in) :: hlink,zelev - integer, dimension(NLINKS), intent(in) :: ORDER - integer, dimension(NLINKS), intent(inout) :: STRMFRXSTPTS - - real, intent(in) :: dtrt - real, dimension(NLINKS,2), intent(in) :: qlink - - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - - real, allocatable, DIMENSION(:) :: chanlat,chanlon - real, allocatable, DIMENSION(:) :: chanlatO,chanlonO - - real, allocatable, DIMENSION(:) :: elevation - real, allocatable, DIMENSION(:) :: elevationO - - integer, allocatable, DIMENSION(:) :: station_id - integer, allocatable, DIMENSION(:) :: station_idO - - integer, allocatable, DIMENSION(:) :: rec_num_of_station - integer, allocatable, DIMENSION(:) :: rec_num_of_stationO - - integer, allocatable, DIMENSION(:) :: lOrder !- local stream order - integer, allocatable, DIMENSION(:) :: lOrderO !- local stream order - - integer, save :: output_count - integer, save :: ncid,ncid2 - - integer :: stationdim, dimdata, varid, charid, n - integer :: obsdim, dimdataO, charidO - - integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output - integer :: start_posO, prev_posO - - integer :: previous_pos !-- used for the station model - character(len=256) :: output_flnm,output_flnm2 - character(len=19) :: date19,date19start - character(len=34) :: sec_since_date - integer :: seconds_since,nstations,cnt,ObsStation,nobs - character(len=32) :: convention - character(len=11),allocatable, DIMENSION(:) :: stname - character(len=11),allocatable, DIMENSION(:) :: stnameO - - !--- all this for writing the station id string - INTEGER TDIMS, TXLEN - PARAMETER (TDIMS=2) ! number of TX dimensions - PARAMETER (TXLEN = 11) ! length of example string - INTEGER TIMEID ! record dimension id - INTEGER TXID ! variable ID - INTEGER TXDIMS(TDIMS) ! variable shape - INTEGER TSTART(TDIMS), TCOUNT(TDIMS) - - !-- observation point ids - INTEGER OTDIMS, OTXLEN - PARAMETER (OTDIMS=2) ! number of TX dimensions - PARAMETER (OTXLEN = 11) ! length of example string - INTEGER OTIMEID ! record dimension id - INTEGER OTXID ! variable ID - INTEGER OTXDIMS(OTDIMS) ! variable shape - INTEGER OTSTART(OTDIMS), OTCOUNT(OTDIMS) - -#ifdef HYDRO_D - write(6,*) "yyww dtrt =", dtrt , "k =", k -#endif - - seconds_since = int(dtrt)*K - -! order_to_write = 2 !-- 1 all; 6 feweest - - nstations = 0 ! total number of channel points to display - nobs = 0 ! number of observation points - -!-- output only the higher oder streamflows and only observation points - do i=1,NLINKS - if(ORDER(i) .ge. order_to_write) then - nstations = nstations + 1 - endif - if(STRMFRXSTPTS(i) .ne. -9999) then - nobs = nobs + 1 - endif - enddo - - if (nobs .eq. 0) then ! let's at least make one obs point - nobs = 1 - STRMFRXSTPTS(1) = 1 - endif - - allocate(chanlat(nstations)) - allocate(chanlon(nstations)) - allocate(elevation(nstations)) - allocate(station_id(nstations)) - allocate(lOrder(nstations)) - allocate(rec_num_of_station(nstations)) - allocate(stname(nstations)) - - allocate(chanlatO(nobs)) - allocate(chanlonO(nobs)) - allocate(elevationO(nobs)) - allocate(station_idO(nobs)) - allocate(lOrderO(nobs)) - allocate(rec_num_of_stationO(nobs)) - allocate(stnameO(nobs)) - - if(output_count == 0) then -!-- have moved sec_since_date from above here.. - sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & - //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' - - date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & - //startdate(12:13)//':'//startdate(15:16)//':00' - - nstations = 0 - nobs = 0 - - write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid - write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid - -#ifdef HYDRO_D - print*, 'output_flnm = "'//trim(output_flnm)//'"' -#endif - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) -#endif -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create points" - call hydro_stop("output_chrt") - endif -#endif - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm2), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid2) -#else - iret = nf_create(trim(output_flnm2), NF_CLOBBER, ncid2) -#endif -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create observation" - call hydro_stop("output_chrt") - endif -#endif - - do i=1,NLINKS - if(ORDER(i) .ge. order_to_write) then - nstations = nstations + 1 - chanlat(nstations) = chlat(i) - chanlon(nstations) = chlon(i) - elevation(nstations) = zelev(i) - lOrder(nstations) = ORDER(i) - station_id(nstations) = i - if(STRMFRXSTPTS(nstations) .eq. -9999) then - ObsStation = 0 - else - ObsStation = 1 - endif - write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation - endif - enddo - - - do i=1,NLINKS - if(STRMFRXSTPTS(i) .ne. -9999) then - nobs = nobs + 1 - chanlatO(nobs) = chlat(i) - chanlonO(nobs) = chlon(i) - elevationO(nobs) = zelev(i) - lOrderO(nobs) = ORDER(i) - station_idO(nobs) = i - write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs) -#ifdef HYDRO_D -! print *,"stationobservation name", stnameO(nobs) -#endif - endif - enddo - - iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata) !--for linked list approach - - - iret = nf_def_dim(ncid, "station", nstations, stationdim) - - - - iret = nf_def_dim(ncid2, "recNum", NF_UNLIMITED, dimdataO) !--for linked list approach - iret = nf_def_dim(ncid2, "station", nobs, obsdim) - - - !- station location definition all, lat - iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid) -#ifdef HYDRO_D - write(6,*) "iret 2.1, ", iret, stationdim -#endif - iret = nf_put_att_text(ncid,varid,'long_name',16,'Station latitude') -#ifdef HYDRO_D - write(6,*) "iret 2.2", iret -#endif - iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north') -#ifdef HYDRO_D - write(6,*) "iret 2.3", iret -#endif - - - !- station location definition obs, lat - iret = nf_def_var(ncid2,"latitude",NF_FLOAT, 1, (/obsdim/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation latitude') - iret = nf_put_att_text(ncid2,varid,'units',13,'degrees_north') - - - !- station location definition, long - iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',17,'Station longitude') - iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east') - - - !- station location definition, obs long - iret = nf_def_var(ncid2,"longitude",NF_FLOAT, 1, (/obsdim/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',21,'Observation longitude') - iret = nf_put_att_text(ncid2,varid,'units',12,'degrees_east') - - -! !-- elevation is ZELEV - iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',16,'Station altitude') - iret = nf_put_att_text(ncid,varid,'units',6,'meters') - - -! !-- elevation is obs ZELEV - iret = nf_def_var(ncid2,"altitude",NF_FLOAT, 1, (/obsdim/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation altitude') - iret = nf_put_att_text(ncid2,varid,'units',6,'meters') - - -! !-- gage observation -! iret = nf_def_var(ncid,"gages",NF_FLOAT, 1, (/stationdim/), varid) -! iret = nf_put_att_text(ncid,varid,'long_name',20,'Stream Gage Location') -! iret = nf_put_att_text(ncid,varid,'units',4,'none') - -!-- parent index - iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',36,'index of the station for this record') - - iret = nf_def_var(ncid2,"parent_index",NF_INT,1,(/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',36,'index of the station for this record') - - !-- prevChild - iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',57,'record number of the previous record for the same station') -!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - - iret = nf_def_var(ncid2,"prevChild",NF_INT,1,(/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',57,'record number of the previous record for the same station') -!ywtmp iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1) - - !-- lastChild - iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',30,'latest report for this station') -!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - - iret = nf_def_var(ncid2,"lastChild",NF_INT,1,(/obsdim/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',30,'latest report for this station') -!ywtmp iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1) - -! !- flow definition, var - iret = nf_def_var(ncid, "streamflow", NF_FLOAT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') - iret = nf_put_att_text(ncid,varid,'long_name',10,'River Flow') - - iret = nf_def_var(ncid2, "streamflow", NF_FLOAT, 1, (/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec') - iret = nf_put_att_text(ncid2,varid,'long_name',10,'River Flow') - -! !- flow definition, var -! iret = nf_def_var(ncid, "pos_streamflow", NF_FLOAT, 1, (/dimdata/), varid) -! iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') -! iret = nf_put_att_text(ncid,varid,'long_name',14,'abs streamflow') - -! !- head definition, var - iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',5,'meter') - iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage') - - iret = nf_def_var(ncid2, "head", NF_FLOAT, 1, (/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'units',5,'meter') - iret = nf_put_att_text(ncid2,varid,'long_name',11,'River Stage') - - -! !- order definition, var - iret = nf_def_var(ncid, "order", NF_INT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',21,'Strahler Stream Order') - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - - iret = nf_def_var(ncid2, "order", NF_INT, 1, (/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'long_name',21,'Strahler Stream Order') - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - - - !-- station id - ! define character-position dimension for strings of max length 11 - iret = NF_DEF_DIM(ncid, "id_len", 11, charid) - TXDIMS(1) = charid ! define char-string variable and position dimension first - TXDIMS(2) = stationdim - iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid) - iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id') - - iret = NF_DEF_DIM(ncid2, "id_len", 11, charidO) - OTXDIMS(1) = charidO ! define char-string variable and position dimension first - OTXDIMS(2) = obsdim - iret = nf_def_var(ncid2,"station_id",NF_CHAR, OTDIMS, OTXDIMS, varid) - iret = nf_put_att_text(ncid2,varid,'long_name',14,'Observation id') - - -! !- time definition, timeObs - iret = nf_def_var(ncid,"time_observation",NF_INT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) - iret = nf_put_att_text(ncid,varid,'long_name',19,'time of observation') - - iret = nf_def_var(ncid2,"time_observation",NF_INT, 1, (/dimdataO/), varid) - iret = nf_put_att_text(ncid2,varid,'units',34,sec_since_date) - iret = nf_put_att_text(ncid2,varid,'long_name',19,'time of observation') - - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) - iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention) - - convention(1:32) = "Unidata Observation Dataset v1.0" - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) - iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19start) - iret = nf_put_att_text(ncid, NF_GLOBAL, "stationDimension",7, "station") - iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_put_att_int(ncid, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write) - - iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention) - iret = nf_put_att_text(ncid2, NF_GLOBAL, "cdm_datatype",7, "Station") - iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_max",4, "90.0") - iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") - iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_max",5, "180.0") - iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") - iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_start",19, date19start) - iret = nf_put_att_text(ncid2, NF_GLOBAL, "stationDimension",7, "station") - iret = nf_put_att_real(ncid2, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_put_att_int(ncid2, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write) - - iret = nf_enddef(ncid) - iret = nf_enddef(ncid2) - - !-- write latitudes - iret = nf_inq_varid(ncid,"latitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlat) - - iret = nf_inq_varid(ncid2,"latitude", varid) - iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlatO) - - !-- write longitudes - iret = nf_inq_varid(ncid,"longitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlon) - - iret = nf_inq_varid(ncid2,"longitude", varid) - iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlonO) - - !-- write elevations - iret = nf_inq_varid(ncid,"altitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), elevation) - - iret = nf_inq_varid(ncid2,"altitude", varid) - iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), elevationO) - - !-- write gage location -! iret = nf_inq_varid(ncid,"gages", varid) -! iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), STRMFRXSTPTS) - - !-- write number_of_stations, OPTIONAL - !! iret = nf_inq_varid(ncid,"number_stations", varid) - !! iret = nf_put_var_int(ncid, varid, nstations) - - !-- write station id's - do i=1,nstations - TSTART(1) = 1 - TSTART(2) = i - TCOUNT(1) = TXLEN - TCOUNT(2) = 1 - iret = nf_inq_varid(ncid,"station_id", varid) - iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i)) - enddo - - !-- write observation id's - do i=1, nobs - OTSTART(1) = 1 - OTSTART(2) = i - OTCOUNT(1) = OTXLEN - OTCOUNT(2) = 1 - iret = nf_inq_varid(ncid2,"station_id", varid) - iret = nf_put_vara_text(ncid2, varid, OTSTART, OTCOUNT, stnameO(i)) - enddo - - endif - - output_count = output_count + 1 - - open (unit=999,file='frxst_pts_out.txt',status='unknown',position='append') - - cnt=0 - do i=1,NLINKS - - if(ORDER(i) .ge. order_to_write) then - start_pos = (cnt+1)+(nstations*(output_count-1)) - - !!--time in seconds since startdate - iret = nf_inq_varid(ncid,"time_observation", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since) - - iret = nf_inq_varid(ncid,"streamflow", varid) - iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlink(i,1)) - -! iret = nf_inq_varid(ncid,"pos_streamflow", varid) -! iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), abs(qlink(i,1))) - - iret = nf_inq_varid(ncid,"head", varid) - iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), hlink(i)) - - iret = nf_inq_varid(ncid,"order", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), ORDER(i)) - - !-- station index.. will repeat for every timesstep - iret = nf_inq_varid(ncid,"parent_index", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt) - - !--record number of previous record for same station -!obsolete format prev_pos = cnt+(nstations*(output_count-1)) - prev_pos = cnt+(nobs*(output_count-2)) - if(output_count.ne.1) then !-- only write next set of records - iret = nf_inq_varid(ncid,"prevChild", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos) - endif - - cnt=cnt+1 !--indices are 0 based - rec_num_of_station(cnt) = start_pos-1 !-- save position for last child, 0-based!! - - - endif - enddo -! close(999) - - !-- output only observation points - cnt=0 - do i=1,NLINKS - - if(STRMFRXSTPTS(i) .ne. -9999) then - start_posO = (cnt+1)+(nobs * (output_count-1)) -!Write frxst_pts to text file... -!yw write(999,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), & - write(999,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), & - qlink(i,1), qlink(i,1)*35.315,hlink(i) -!yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) -!yw 117 FORMAT(I8,1X,A10,1X,A8,1x,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3) - 117 FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3) - - !!--time in seconds since startdate - iret = nf_inq_varid(ncid2,"time_observation", varid) - iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), seconds_since) - - iret = nf_inq_varid(ncid2,"streamflow", varid) - iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1)) - - iret = nf_inq_varid(ncid2,"head", varid) - iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i)) - - iret = nf_inq_varid(ncid,"order", varid) - iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i)) - - !-- station index.. will repeat for every timesstep - iret = nf_inq_varid(ncid2,"parent_index", varid) - iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt) - - !--record number of previous record for same station -!obsolete format prev_posO = cnt+(nobs*(output_count-1)) - prev_posO = cnt+(nobs*(output_count-2)) - if(output_count.ne.1) then !-- only write next set of records - iret = nf_inq_varid(ncid2,"prevChild", varid) - iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) - -!IF block to add -1 to last element of prevChild array to designate end of list... -! if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then -! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1) -! else -! iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO) -! endif - - - endif - - cnt=cnt+1 !--indices are 0 based - rec_num_of_stationO(cnt) = start_posO - 1 !-- save position for last child, 0-based!! - - - endif - - enddo - close(999) - - - !-- lastChild variable gives the record number of the most recent report for the station - iret = nf_inq_varid(ncid,"lastChild", varid) - iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), rec_num_of_station) - - !-- lastChild variable gives the record number of the most recent report for the station - iret = nf_inq_varid(ncid2,"lastChild", varid) - iret = nf_put_vara_int(ncid2, varid, (/1/), (/nobs/), rec_num_of_stationO) - - iret = nf_redef(ncid) - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(date)) = date - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) - - iret = nf_redef(ncid2) - iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_end", 19, date19) - - iret = nf_enddef(ncid) - iret = nf_sync(ncid) - - iret = nf_enddef(ncid2) - iret = nf_sync(ncid2) - - if (output_count == split_output_count) then - output_count = 0 - iret = nf_close(ncid) - iret = nf_close(ncid2) - endif - - deallocate(chanlat) - deallocate(chanlon) - deallocate(elevation) - deallocate(station_id) - deallocate(lOrder) - deallocate(rec_num_of_station) - deallocate(stname) - - deallocate(chanlatO) - deallocate(chanlonO) - deallocate(elevationO) - deallocate(station_idO) - deallocate(lOrderO) - deallocate(rec_num_of_stationO) - deallocate(stnameO) -#ifdef HYDRO_D - print *, "Exited Subroutine output_chrt" -#endif - close(16) - -20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3) - -end subroutine output_chrt - -#ifdef MPP_LAND -!-- output the channel route in an IDV 'station' compatible format - subroutine mpp_output_chrt(gnlinks,map_l2g,igrid, & - split_output_count, NLINKS, ORDER, & - startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt, & - K,STRMFRXSTPTS,order_to_write) - - USE module_mpp_land - -!!output the routing variables over just channel - integer, intent(in) :: igrid,K - integer, intent(in) :: split_output_count - integer, intent(in) :: NLINKS - real, dimension(NLINKS), intent(in) :: chlon,chlat - real, dimension(NLINKS), intent(in) :: hlink,zelev - - integer, dimension(NLINKS), intent(in) :: ORDER - integer, dimension(NLINKS), intent(inout) :: STRMFRXSTPTS - - real, intent(in) :: dtrt - real, dimension(NLINKS,2), intent(in) :: qlink - - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - - integer :: gnlinks, map_l2g(nlinks), order_to_write - real, dimension(gNLINKS) :: g_chlon,g_chlat, g_hlink,g_zelev - real, dimension(gNLINKS,2) :: g_qlink - integer , dimension(gNLINKS) :: g_order,g_STRMFRXSTPTS - - - call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) - call write_chanel_int(STRMFRXSTPTS,map_l2g,gnlinks,nlinks,g_STRMFRXSTPTS) - call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon) - call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat) - call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink) - call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev) - call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) - call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) - - if(my_id .eq. IO_id) then - call output_chrt(igrid, split_output_count, GNLINKS, g_ORDER, & - startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt,K,& - g_STRMFRXSTPTS,order_to_write) - end if - -end subroutine mpp_output_chrt - -!--------- lake netcdf output ----------------------------------------- -!-- output the ilake info an IDV 'station' compatible format ----------- - subroutine mpp_output_lakes(lake_index,igrid, split_output_count, NLAKES, & - startdate, date, latlake, lonlake, elevlake, & - qlakei,qlakeo, resht,dtrt,K) - - USE module_mpp_land - -!!output the routing variables over just channel - integer, intent(in) :: igrid, K - integer, intent(in) :: split_output_count - integer, intent(in) :: NLAKES - real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht - real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake - real, intent(in) :: dtrt - - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - integer lake_index(nlakes) - - call write_lake_real(latlake,lake_index,nlakes) - call write_lake_real(lonlake,lake_index,nlakes) - call write_lake_real(elevlake,lake_index,nlakes) - call write_lake_real(resht,lake_index,nlakes) - call write_lake_real(qlakei,lake_index,nlakes) - call write_lake_real(qlakeo,lake_index,nlakes) - if(my_id.eq. IO_id) then - call output_lakes(igrid, split_output_count, NLAKES, & - startdate, date, latlake, lonlake, elevlake, & - qlakei,qlakeo, resht,dtrt,K) - end if - return - end subroutine mpp_output_lakes - -#endif - -!----------------------------------- lake netcdf output -!-- output the ilake info an IDV 'station' compatible format - subroutine output_lakes(igrid, split_output_count, NLAKES, & - startdate, date, latlake, lonlake, elevlake, & - qlakei,qlakeo, resht,dtrt,K) - -!!output the routing variables over just channel - integer, intent(in) :: igrid, K - integer, intent(in) :: split_output_count - integer, intent(in) :: NLAKES - real, dimension(NLAKES), intent(in) :: latlake,lonlake,elevlake,resht - real, dimension(NLAKES), intent(in) :: qlakei,qlakeo !-- inflow and outflow of lake - real, intent(in) :: dtrt - - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - - integer, allocatable, DIMENSION(:) :: station_id - integer, allocatable, DIMENSION(:) :: rec_num_of_lake - - integer, save :: output_count - integer, save :: ncid - - integer :: stationdim, dimdata, varid, charid, n - integer :: iret,i, start_pos, prev_pos !-- - integer :: previous_pos !-- used for the station model - character(len=256) :: output_flnm - character(len=19) :: date19, date19start - character(len=34) :: sec_since_date - integer :: seconds_since,cnt - character(len=32) :: convention - character(len=6),allocatable, DIMENSION(:) :: stname - - !--- all this for writing the station id string - INTEGER TDIMS, TXLEN - PARAMETER (TDIMS=2) ! number of TX dimensions - PARAMETER (TXLEN = 6) ! length of example string - INTEGER TIMEID ! record dimension id - INTEGER TXID ! variable ID - INTEGER TXDIMS(TDIMS) ! variable shape - INTEGER TSTART(TDIMS), TCOUNT(TDIMS) - -! sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC' -! seconds_since = int(dtrt)*output_count - seconds_since = int(dtrt)*K - - allocate(station_id(NLAKES)) - allocate(rec_num_of_lake(NLAKES)) - allocate(stname(NLAKES)) - - if (output_count == 0) then - -!-- have moved sec_since_date from above here.. - sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) & - //' '//startdate(12:13)//':'//startdate(15:16)//' UTC' - - date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' & - //startdate(12:13)//':'//startdate(15:16)//':00' - - write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid -#ifdef HYDRO_D - print*, 'output_flnm = "'//trim(output_flnm)//'"' -#endif - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) -#endif - -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("output_lakes") - endif -#endif - - do i=1,NLAKES - station_id(i) = i - write(stname(i),'(I6)') i - enddo - - iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata) !--for linked list approach - iret = nf_def_dim(ncid, "station", nlakes, stationdim) - - !- station location definition, lat - iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake latitude') - iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north') - - !- station location definition, long - iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake longitude') - iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east') - -! !-- lake's phyical elevation - iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake altitude') - iret = nf_put_att_text(ncid,varid,'units',6,'meters') - - !-- parent index - iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',33,'index of the lake for this record') - - !-- prevChild - iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',54,'record number of the previous record for the same lake') -!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - - !-- lastChild - iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid) - iret = nf_put_att_text(ncid,varid,'long_name',27,'latest report for this lake') -!ywtmp iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1) - iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1) - -! !- water surface elevation - iret = nf_def_var(ncid, "elevation", NF_FLOAT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',6,'meters') - iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake Elevation') - -! !- inflow to lake - iret = nf_def_var(ncid, "inflow", NF_FLOAT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') - -! !- outflow to lake - iret = nf_def_var(ncid, "outflow", NF_FLOAT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec') - - !-- station id - ! define character-position dimension for strings of max length 6 - iret = NF_DEF_DIM(ncid, "id_len", 6, charid) - TXDIMS(1) = charid ! define char-string variable and position dimension first - TXDIMS(2) = stationdim - iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid) - iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id') - -! !- time definition, timeObs - iret = nf_def_var(ncid,"time_observation",NF_INT, 1, (/dimdata/), varid) - iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date) - iret = nf_put_att_text(ncid,varid,'long_name',19,'time of observation') - -! date19(1:19) = "0000-00-00_00:00:00" -! date19(1:len_trim(startdate)) = startdate -! iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) -! - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(startdate)) = startdate - convention(1:32) = "Unidata Observation Dataset v1.0" - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention) - iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0") - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19start) - iret = nf_put_att_text(ncid, NF_GLOBAL, "stationDimension",7, "station") -!! iret = nf_put_att_text(ncid, NF_GLOBAL, "observationDimension",6, "recNum") -!! iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coordinate",16,"time_observation") - iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_enddef(ncid) - - !-- write latitudes - iret = nf_inq_varid(ncid,"latitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LATLAKE) - - !-- write longitudes - iret = nf_inq_varid(ncid,"longitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LONLAKE) - - !-- write physical height of lake - iret = nf_inq_varid(ncid,"altitude", varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), elevlake) - - !-- write station id's - do i=1,nlakes - TSTART(1) = 1 - TSTART(2) = i - TCOUNT(1) = TXLEN - TCOUNT(2) = 1 - iret = nf_inq_varid(ncid,"station_id", varid) - iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i)) - enddo - - endif - - output_count = output_count + 1 - - cnt=0 - do i=1,NLAKES - - start_pos = (cnt+1)+(nlakes*(output_count-1)) - - !!--time in seconds since startdate - iret = nf_inq_varid(ncid,"time_observation", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since) - - iret = nf_inq_varid(ncid,"elevation", varid) - iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), resht(i)) - - iret = nf_inq_varid(ncid,"inflow", varid) - iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakei(i)) - - iret = nf_inq_varid(ncid,"outflow", varid) - iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakeo(i)) - - !-- station index.. will repeat for every timesstep - iret = nf_inq_varid(ncid,"parent_index", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt) - - !--record number of previous record for same station - prev_pos = cnt+(nlakes*(output_count-1)) - if(output_count.ne.1) then !-- only write next set of records - iret = nf_inq_varid(ncid,"prevChild", varid) - iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos) - endif - - cnt=cnt+1 !--indices are 0 based - rec_num_of_lake(cnt) = start_pos-1 !-- save position for last child, 0-based!! - - enddo - - !-- lastChild variable gives the record number of the most recent report for the station - iret = nf_inq_varid(ncid,"lastChild", varid) - iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake) - - !-- number of children reported for this station, OPTIONAL - !-- iret = nf_inq_varid(ncid,"numChildren", varid) - !-- iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake) - - iret = nf_redef(ncid) - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(date)) = date - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19) - iret = nf_enddef(ncid) - - iret = nf_sync(ncid) - if (output_count == split_output_count) then - output_count = 0 - iret = nf_close(ncid) - endif - - deallocate(station_id) - deallocate(rec_num_of_lake) - deallocate(stname) -#ifdef HYDRO_D - print *, "Exited Subroutine output_lakes" -#endif - close(16) - - end subroutine output_lakes -!----------------------------------- lake netcdf output - -#ifdef MPP_LAND - -!-- output the channel route in an IDV 'grid' compatible format - subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & - NLINKS,CH_NETRT_in, CH_NETLNK_in, ORDER, startdate, date, & - qlink, dt, geo_finegrid_flnm, gnlinks,map_l2g,g_ixrt,g_jxrt ) - - USE module_mpp_land - - implicit none -#include - integer g_ixrt,g_jxrt - integer, intent(in) :: igrid - integer, intent(in) :: split_output_count - integer, intent(in) :: NLINKS,ixrt,jxrt - real, intent(in) :: dt - real, dimension(NLINKS,2), intent(in) :: qlink - integer, dimension(g_IXRT,g_JXRT) :: CH_NETRT,CH_NETLNK - integer, dimension(IXRT,JXRT), intent(in) :: CH_NETRT_in,CH_NETLNK_in - integer, dimension(NLINKS), intent(in) :: ORDER !--currently not used here, see finegrid.f - character(len=*), intent(in) :: geo_finegrid_flnm - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - integer:: gnlinks , map_l2g(nlinks) - - integer,dimension(gnlinks) :: g_order - real, dimension(gNLINKS,2) :: g_qlink - - call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1)) - call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2)) - call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order) - - call write_IO_rt_int(CH_NETRT_in, CH_NETRT) - call write_IO_rt_int(CH_NETLNK_in, CH_NETLNK) - - if(my_id.eq.IO_id) then - call output_chrtgrd(igrid, split_output_count, g_ixrt,g_jxrt, & - GNLINKS,CH_NETRT, CH_NETLNK, g_ORDER, startdate, date, & - g_qlink, dt, geo_finegrid_flnm) - endif - - return - end subroutine mpp_output_chrtgrd -#endif - -!-- output the channel route in an IDV 'grid' compatible format - subroutine output_chrtgrd(igrid, split_output_count, ixrt,jxrt, & - NLINKS,CH_NETRT, CH_NETLNK, ORDER, startdate, date, & - qlink, dt, geo_finegrid_flnm) - - integer, intent(in) :: igrid - integer, intent(in) :: split_output_count - integer, intent(in) :: NLINKS,ixrt,jxrt - real, intent(in) :: dt - real, dimension(NLINKS,2), intent(in) :: qlink - integer, dimension(IXRT,JXRT), intent(in) :: CH_NETRT,CH_NETLNK - integer, dimension(NLINKS), intent(in) :: ORDER !--currently not used here, see finegrid.f - character(len=*), intent(in) :: geo_finegrid_flnm - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: date - character(len=32) :: convention - integer,save :: output_count - integer, save :: ncid,ncstatic - real, dimension(IXRT,JXRT) :: tmpflow - real, dimension(IXRT) :: xcoord - real, dimension(JXRT) :: ycoord - real :: long_cm,lat_po,fe,fn - real, dimension(2) :: sp - - integer :: varid, n - integer :: jxlatdim,ixlondim,timedim !-- dimension ids - - integer :: iret,i,j - character(len=256) :: output_flnm - character(len=19) :: date19 - character(len=34) :: sec_since_date - - - integer :: seconds_since - - - - - tmpflow = -9E15 - - - write(output_flnm, '(A12,".CHRTOUT_GRID",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid -#ifdef HYDRO_D - print*, 'output_flnm = "'//trim(output_flnm)//'"' -#endif - - -!--- define dimension -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid) -#endif - -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("output_chrtgrd") - endif -#endif - - - iret = nf_def_dim(ncid, "time", NF_UNLIMITED, timedim) - iret = nf_def_dim(ncid, "x", ixrt, ixlondim) - iret = nf_def_dim(ncid, "y", jxrt, jxlatdim) - -!--- define variables -! !- time definition, timeObs - iret = nf_def_var(ncid,"time",NF_INT, 1, (/timedim/), varid) - - !- x-coordinate in cartesian system -!yw iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/ixlondim/), varid) -!yw iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection') -!yw iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate') -!yw iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - - !- y-coordinate in cartesian ssystem -!yw iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/jxlatdim/), varid) -!yw iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection') -!yw iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate') -!yw iret = nf_put_att_text(ncid,varid,'units',5,'Meter') - -! !- flow definition, var - iret = nf_def_var(ncid,"flow",NF_REAL, 3, (/ixlondim,jxlatdim,timedim/), varid) - iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1') - iret = nf_put_att_text(ncid,varid,'long_name',15,'water flow rate') - iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y') - iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic') - iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15) - - -!-- place prjection information - - - date19(1:19) = "0000-00-00_00:00:00" - date19(1:len_trim(startdate)) = startdate - convention(1:32) = "CF-1.0" - iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15) - iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention) - iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19) - - iret = nf_enddef(ncid) - -!!-- write latitude and longitude locations - -!DJG inv do j=jxrt,1,-1 - do j=1,jxrt - do i=1,ixrt - if(CH_NETRT(i,j).GE.0) then - tmpflow(i,j) = qlink(CH_NETLNK(i,j),1) - else - tmpflow(i,j) = -9E15 - endif - enddo - enddo - -!!time in seconds since startdate - - iret = nf_inq_varid(ncid,"flow", varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ixrt,jxrt,1/),tmpflow) - - iret = nf_close(ncid) - - - - end subroutine output_chrtgrd - - - -#ifdef MPP_LAND - subroutine mpp_output_rt(ixrt, jxrt,igrid, split_output_count, & - ixrt_in, jxrt_in,nsoil, startdate, olddate, & - QSUBRT_in,ZWATTABLRT_in,SMCRT_in,SUB_RESID_in, & - q_sfcflx_x_in,q_sfcflx_y_in,soxrt_in,soyrt_in, & - QSTRMVOLRT_in,SFCHEADSUBRT_in, & - geo_finegrid_flnm,dt,sldpth,LATVAL_in,LONVAL_in,dist,HIRES_OUT, & - QBDRYRT_in) - -!output the routing variables over routing grid. - USE module_mpp_land - - implicit none -#include - - integer, intent(in) :: igrid - integer, intent(in) :: split_output_count - -! ixrt and jxrt are global. ixrt_in and jxrt_in are local array index. - integer, intent(in) :: ixrt,jxrt,ixrt_in,jxrt_in - real, intent(in) :: dt - real, intent(in) :: dist(ixrt_in,jxrt_in,9) - integer, intent(in) :: nsoil - integer, intent(in) :: HIRES_OUT - character(len=*), intent(in) :: startdate - character(len=*), intent(in) :: olddate - character(len=*), intent(in) :: geo_finegrid_flnm - real, dimension(nsoil), intent(in) :: sldpth - - real, dimension(ixrt_in,jxrt_in) :: QSUBRT_in,ZWATTABLRT_in,SUB_RESID_in - real, dimension(ixrt_in,jxrt_in) :: q_sfcflx_x_in,q_sfcflx_y_in - real, dimension(ixrt_in,jxrt_in) :: QSTRMVOLRT_in - real, dimension(ixrt_in,jxrt_in) :: SFCHEADSUBRT_in, QBDRYRT_in - real, dimension(ixrt_in,jxrt_in) :: soxrt_in,soyrt_in - real, dimension(ixrt_in,jxrt_in,nsoil) :: SMCRT_in - real, dimension(ixrt_in,jxrt_in) :: LATVAL_in,LONVAL_in - - real, dimension(ixrt,jxrt) :: QSUBRT,ZWATTABLRT,SUB_RESID - real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y - real, dimension(ixrt,jxrt) :: QSTRMVOLRT, QBDRYRT - real, dimension(ixrt,jxrt) :: SFCHEADSUBRT - real, dimension(ixrt,jxrt) :: soxrt,soyrt - real, dimension(ixrt,jxrt,nsoil) :: SMCRT - real, dimension(ixrt,jxrt,9) :: dist_g - real, dimension(ixrt,jxrt) :: LATVAL,LONVAL - integer i - - -#ifdef HYDRO_D - write(6,*) "mpp_output_RT output file: ",trim(geo_finegrid_flnm) -#endif - - call write_IO_rt_real(LATVAL_in,LATVAL) - call write_IO_rt_real(LONVAL_in,LONVAL) - call write_IO_rt_real(QSUBRT_in,QSUBRT) - - - call write_IO_rt_real(ZWATTABLRT_in,ZWATTABLRT) - - - call write_IO_rt_real(SUB_RESID_in,SUB_RESID) - - - call write_IO_rt_real(QSTRMVOLRT_in,QSTRMVOLRT) - - - - call write_IO_rt_real(SFCHEADSUBRT_in,SFCHEADSUBRT) - call write_IO_rt_real(soxrt_in,soxrt) - - call write_IO_rt_real(QBDRYRT_in,QBDRYRT) - - - - call write_IO_rt_real(soyrt_in,soyrt) - call write_IO_rt_real(q_sfcflx_x_in,q_sfcflx_x) - call write_IO_rt_real(q_sfcflx_y_in,q_sfcflx_y) - - - - - do i = 1, NSOIL - call write_IO_rt_real(SMCRT_in(:,:,i),SMCRT(:,:,i)) - end do - do i = 1, 9 - call write_IO_rt_real(dist(:,:,i),dist_g(:,:,i)) - end do - -! yyywwww ! temp test -! if(my_id.eq. IO_id ) write(14,*) dist(:,:,9) -! if(my_id.eq. IO_id ) write(12,*) dist_g(:,:,9) - - - - - if(my_id.eq.IO_id) then - call output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, & - startdate, olddate, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID, & - q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, & - geo_finegrid_flnm,DT,SLDPTH,latval,lonval,dist_g,HIRES_OUT, & - QBDRYRT) - end if - -#ifdef HYDRO_D - write(6,*) "return from mpp_output_RT" -#endif - end subroutine mpp_output_rt - -#endif - - subroutine read_chan_forcing( & - indir,olddate,startdate,hgrid,& - ixrt,jxrt,QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT) -! This subrouting is going to read channel forcing for -! channel only simulations (ie when CHANRTSWCRT = 2) - - implicit none -#include - ! in variable - character(len=*) :: olddate,hgrid,indir,startdate - character(len=256) :: filename - integer :: ixrt,jxrt - real,dimension(ixrt,jxrt):: QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT - ! tmp variable - character(len=256) :: inflnm, product - integer :: i,j,mmflag - character(len=256) :: units - integer :: ierr - integer :: ncid - - -!DJG Create filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".RTOUT_DOMAIN"//hgrid -#ifdef HYDRO_D - print *, "Channel forcing file...",inflnm -#endif - - -!DJG Open NetCDF file... - ierr = nf_open(inflnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_chan Problem opening netcdf file: ''", A, "''")') trim(inflnm) - call hydro_stop("read_chan_forcing") -#endif - endif - -!DJG read data... - call get_2d_netcdf("QSTRMVOLRT", ncid, QSTRMVOLRT_ACC, units, ixrt, jxrt, .TRUE., ierr) -!DJG TBC call get_2d_netcdf("T2D", ncid, t, units, ixrt, jxrt, .TRUE., ierr) -!DJG TBC call get_2d_netcdf("T2D", ncid, t, units, ixrt, jxrt, .TRUE., ierr) - - ierr = nf_close(ncid) - - end subroutine read_chan_forcing - - - - - subroutine get2d_int(var_name,out_buff,ix,jx,fileName) - implicit none -#include - integer :: iret,varid,ncid,ix,jx - integer out_buff(ix,jx) - character(len=*), intent(in) :: var_name - character(len=*), intent(in) :: fileName - iret = nf_open(trim(fileName), NF_NOWRITE, ncid) - if (iret .ne. 0) then -#ifdef HYDRO_D - print*,"aaa failed to open the netcdf file: ",trim(fileName) - call hydro_stop("get2d_int") -#endif - endif - iret = nf_inq_varid(ncid,trim(var_name), varid) - if(iret .ne. 0) then -#ifdef HYDRO_D - print*,"failed to read the variabe: ",trim(var_name) - print*,"failed to read the netcdf file: ",trim(fileName) -#endif - endif - iret = nf_get_var_int(ncid, varid, out_buff) - iret = nf_close(ncid) - return - end subroutine get2d_int - -#ifdef MPP_LAND - SUBROUTINE MPP_READ_ROUTEDIM(did,g_IXRT,g_JXRT, GCH_NETLNK,GNLINKS,IXRT,JXRT, & - route_chan_f,route_link_f, & - route_direction_f, route_lake_f,NLINKS, NLAKES, & - CH_NETLNK, channel_option, geo_finegrid_flnm) - - - USE module_mpp_land - - implicit none -#include - INTEGER :: channel_option, did - INTEGER :: g_IXRT,g_JXRT - INTEGER, INTENT(INOUT) :: NLINKS, NLAKES, GNLINKS - INTEGER, INTENT(IN) :: IXRT,JXRT - INTEGER :: CHNID,cnt - INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: GCH_NETLNK !- each node gets unique id based on global domain - INTEGER, DIMENSION(g_IXRT,g_JXRT) :: g_CH_NETLNK ! temp array - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction - INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - REAL, DIMENSION(IXRT,JXRT) :: LAT, LON - integer:: i,j - - CHARACTER(len=256) :: route_chan_f, route_link_f,route_direction_f,route_lake_f - CHARACTER(len=256) :: geo_finegrid_flnm -! CHARACTER(len=*) :: geo_finegrid_flnm - -! integer, allocatable, dimension(:) :: tmp_int - integer :: ywcount - - if(my_id .eq. IO_id) then - CALL READ_ROUTEDIM(g_IXRT, g_JXRT, route_chan_f, route_link_f, & - route_direction_f, route_lake_f, GNLINKS, NLAKES, & - g_CH_NETLNK, channel_option,geo_finegrid_flnm) - endif - - - call mpp_land_bcast_int1(NLAKES) - call mpp_land_bcast_int1(GNLINKS) - - - call decompose_RT_int(g_CH_NETLNK,GCH_NETLNK,g_IXRT,g_JXRT,ixrt,jxrt) - ywcount = 0 - CH_NETLNK = -9999 - do j = 1, jxrt - do i = 1, ixrt - if(GCH_NETLNK(i,j) .gt. 0) then - ywcount = ywcount + 1 - CH_NETLNK(i,j) = ywcount - endif - end do - end do - NLINKS = ywcount - - allocate(rt_domain(did)%map_l2g(NLINKS)) - - rt_domain(did)%map_l2g = -1 - do j = 1, jxrt - do i = 1, ixrt - if(CH_NETLNK(i,j) .gt. 0) then - rt_domain(did)%map_l2g(CH_NETLNK(i,j)) = GCH_NETLNK(i,j) - endif - end do - end do - - call mpp_chrt_nlinks_collect(NLINKS) - return - end SUBROUTINE MPP_READ_ROUTEDIM - - SUBROUTINE MPP_READ_ROUTING(IXRT,JXRT,ELRT, & - CH_NETRT,LKSATFAC,route_topo_f, & - route_chan_f, geo_finegrid_flnm,g_IXRT,g_JXRT, & - OVROUGHRTFAC,RETDEPRTFAC) - - implicit none -#include - INTEGER, INTENT(IN) :: IXRT,JXRT,g_IXRT,g_JXRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC,RETDEPRTFAC - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT - - REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_ELRT - INTEGER,DIMENSION(g_IXRT,g_JXRT) :: g1_CH_NETRT - REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_LKSATFAC - REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_OVROUGHRTFAC - REAL, DIMENSION(g_IXRT,g_JXRT) :: g1_RETDEPRTFAC - - CHARACTER(len=256) :: route_topo_f,route_chan_f,geo_finegrid_flnm - - if(my_id .eq. IO_id) then - CALL READ_ROUTING_seq(g_IXRT,g_JXRT,g1_ELRT,g1_CH_NETRT,g1_LKSATFAC,& - route_topo_f, route_chan_f,geo_finegrid_flnm,g1_OVROUGHRTFAC,& - g1_RETDEPRTFAC) - endif - - call decompose_RT_real(g1_ELRT,ELRT,g_IXRT,g_JXRT,IXRT,JXRT) - call decompose_RT_int(g1_CH_NETRT,CH_NETRT,g_IXRT,g_JXRT,IXRT,JXRT) - call decompose_RT_real(g1_LKSATFAC,LKSATFAC,g_IXRT,g_JXRT,IXRT,JXRT) - call decompose_RT_real(g1_RETDEPRTFAC,RETDEPRTFAC,g_IXRT,g_JXRT,IXRT,JXRT) - call decompose_RT_real(g1_OVROUGHRTFAC,OVROUGHRTFAC,g_IXRT,g_JXRT,IXRT,JXRT) - - return - end SUBROUTINE MPP_READ_ROUTING - - - subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& - global_nX, global_ny,nsoil,out_SMC,out_SH2OX) - implicit none -#include - - integer, intent(in) :: ix,global_nx,global_ny - integer, intent(in) :: jx,nsoil - real, dimension(ix,jx), intent(in) :: in_smcmax - real, dimension(ix,jx,nsoil), intent(out) :: out_smc,out_sh2ox - - real,dimension(global_nX, global_ny,nsoil):: g_smc, g_sh2ox - real,dimension(global_nX, global_ny):: g_smcmax - integer :: i,j,k - - - call write_IO_real(in_smcmax,g_smcmax) ! get global grid of smcmax - - write (*,*) "In deep GW...", nsoil - -!loop to overwrite soils to saturation... - do i=1,global_nx - do j=1,global_ny - g_smc(i,j,1:NSOIL) = g_smcmax(i,j) - g_sh2ox(i,j,1:NSOIL) = g_smcmax(i,j) - end do - end do - -!decompose global grid to parallel tiles... - do k=1,nsoil - call decompose_data_real(g_smc(:,:,k),out_smc(:,:,k)) - call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k)) - end do - - return - end subroutine MPP_DEEPGW_HRLDAS - -#endif - - SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & - route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC) - - -#include - INTEGER, INTENT(IN) :: IXRT,JXRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT -!Dummy inverted grids - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC - - INTEGER :: I,J, iret, jj - CHARACTER(len=256) :: var_name - CHARACTER(len=256) :: route_topo_f - CHARACTER(len=256) :: route_chan_f - CHARACTER(len=256) :: geo_finegrid_flnm - - var_name = "TOPOGRAPHY" - - call readRT2d_real(var_name,ELRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - -!!!DY to be fixed ... 6/27/08 -! var_name = "BED_ELEVATION" -! iret = get2d_real(var_name,ELRT,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) - - var_name = "CHANNELGRID" - call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - - var_name = "LKSATFAC" - LKSATFAC = -9999.9 - call readRT2d_real(var_name,LKSATFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - - where (LKSATFAC == -9999.9) LKSATFAC = 1000.0 !specify LKSAFAC if no term avail... - - -!1.12.2012...Read in routing calibration factors... - var_name = "RETDEPRTFAC" - call readRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists - - var_name = "OVROUGHRTFAC" - call readRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists - - -#ifdef HYDRO_D - write(6,*) "finish READ_ROUTING_seq" -#endif - - return - -!DJG ----------------------------------------------------- - END SUBROUTINE READ_ROUTING_seq -!DJG _____________________________ - subroutine output_lsm(outFile,did) - - - implicit none - - integer did - - character(len=*) outFile - - integer :: ncid,irt, dimid_ix, dimid_jx, & - dimid_ixrt, dimid_jxrt, varid, & - dimid_links, dimid_basns, dimid_soil - integer :: iret - - - -#ifdef MPP_LAND - if(IO_id.eq.my_id) & -#endif - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(outFile), NF_CLOBBER, ncid) -#endif - -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("output_lsm") - endif -#endif - - -#ifdef MPP_LAND - if(IO_id.eq.my_id) then -#endif -#ifdef HYDRO_D - write(6,*) "output file ", outFile -#endif -! define dimension for variables - iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil) !-- 3-d soils - -#ifdef MPP_LAND - iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx) -#else - iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx) -#endif - -!define variables - iret = nf_def_var(ncid,"stc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - iret = nf_def_var(ncid,"smc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - iret = nf_def_var(ncid,"sh2ox",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - - iret = nf_enddef(ncid) - -#ifdef MPP_LAND - endif -#endif - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SFCHEADRT,"sfcheadrt" ) - - -#ifdef MPP_LAND - if(IO_id.eq.my_id) then -#endif - - iret = nf_close(ncid) -#ifdef HYDRO_D - write(6,*) "finish writing outFile : ", outFile -#endif - -#ifdef MPP_LAND - endif -#endif - - return - end subroutine output_lsm - - - subroutine RESTART_OUT_nc(outFile,did) - - - implicit none - - integer did - - character(len=*) outFile - - integer :: ncid,irt, dimid_ix, dimid_jx, & - dimid_ixrt, dimid_jxrt, varid, & - dimid_links, dimid_basns, dimid_soil, dimid_lakes - integer :: iret - - -#ifdef MPP_LAND - if(IO_id.eq.my_id) & -#endif - -#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT - iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid) -#else - iret = nf_create(trim(outFile), NF_CLOBBER, ncid) -#endif - - -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - -#ifdef HYDRO_D - if (iret /= 0) then - print*, "Problem nf_create" - call hydro_stop("RESTART_OUT_nc") - endif -#endif - -#ifdef MPP_LAND - if(IO_id.eq.my_id) then -#endif -! define dimension for variables - iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil) !-- 3-d soils - -#ifdef MPP_LAND - iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx) - iret = nf_def_dim(ncid, "ixrt", global_rt_nx , dimid_ixrt) !-- make a decimated grid - iret = nf_def_dim(ncid, "iyrt", global_rt_ny, dimid_jxrt) -#else - iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix) !-- make a decimated grid - iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx) - iret = nf_def_dim(ncid, "ixrt", rt_domain(did)%ixrt , dimid_ixrt) !-- make a decimated grid - iret = nf_def_dim(ncid, "iyrt", rt_domain(did)%jxrt, dimid_jxrt) -#endif - - iret = nf_def_dim(ncid, "links", rt_domain(did)%gnlinks, dimid_links) - if(rt_domain(did)%nlakes .gt. 0) then - iret = nf_def_dim(ncid, "lakes", rt_domain(did)%nlakes, dimid_lakes) - endif - iret = nf_def_dim(ncid, "basns", rt_domain(did)%numbasns, dimid_basns) - -!define variables - iret = nf_def_var(ncid,"stc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - iret = nf_def_var(ncid,"smc",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - iret = nf_def_var(ncid,"sh2ox",NF_FLOAT,3,(/dimid_ix,dimid_jx,dimid_soil/),varid) - - iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"soldrain",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid) - - if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then - iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - iret = nf_def_var(ncid,"infxswgt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - iret = nf_def_var(ncid,"SFCHEADSUBRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - iret = nf_def_var(ncid,"sh2owgt",NF_FLOAT,3,(/dimid_ixrt,dimid_jxrt,dimid_soil/),varid) - iret = nf_def_var(ncid,"qstrmvolrt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - iret = nf_def_var(ncid,"RETDEPRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - - - - - - - if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then - iret = nf_def_var(ncid,"hlink",NF_FLOAT,1,(/dimid_links/),varid) - iret = nf_def_var(ncid,"qlink1",NF_FLOAT,1,(/dimid_links/),varid) - iret = nf_def_var(ncid,"qlink2",NF_FLOAT,1,(/dimid_links/),varid) - iret = nf_def_var(ncid,"cvol",NF_FLOAT,1,(/dimid_links/),varid) - if(rt_domain(did)%nlakes .gt. 0) then - iret = nf_def_var(ncid,"resht",NF_FLOAT,1,(/dimid_lakes/),varid) - iret = nf_def_var(ncid,"qlakeo",NF_FLOAT,1,(/dimid_lakes/),varid) - endif - iret = nf_def_var(ncid,"lake_inflort",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) - end if - if(nlst_rt(did)%GWBASESWCRT.EQ.1) then - iret = nf_def_var(ncid,"z_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) -!yw test bucket model -! iret = nf_def_var(ncid,"gwbas_pix_ct",NF_FLOAT,1,(/dimid_basns/),varid) -! iret = nf_def_var(ncid,"gw_buck_exp",NF_FLOAT,1,(/dimid_basns/),varid) -! iret = nf_def_var(ncid,"z_max",NF_FLOAT,1,(/dimid_basns/),varid) -! iret = nf_def_var(ncid,"gw_buck_coeff",NF_FLOAT,1,(/dimid_basns/),varid) -! iret = nf_def_var(ncid,"qin_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) -! iret = nf_def_var(ncid,"qinflowbase",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid) -! iret = nf_def_var(ncid,"qout_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid) - end if - end if - -! put global attribute - iret = nf_put_att_int(ncid,NF_GLOBAL,"his_out_counts",NF_INT, 1,rt_domain(did)%his_out_counts) - iret = nf_put_att_text(ncid,NF_GLOBAL,"Restart_Time",19,nlst_rt(did)%olddate(1:19)) - iret = nf_put_att_text(ncid,NF_GLOBAL,"Since_Date",19,nlst_rt(did)%sincedate(1:19)) - iret = nf_put_att_real(ncid,NF_GLOBAL,"DTCT",NF_REAL, 1,nlst_rt(did)%DTCT) - iret = nf_enddef(ncid) - -#ifdef MPP_LAND - endif -#endif - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") - call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") - - - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain" ) - call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt" ) - - - if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT, "QBDRYRT" ) - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT, "infxswgt" ) - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT, "SFCHEADSUBRT" ) - call w_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT, "sh2owgt" ) - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT, "qstrmvolrt" ) - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT, "RETDEPRT" ) - -!yw test - - -!yw test - - - if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then - call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%HLINK,"hlink" & -#ifdef MPP_LAND - ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & -#endif - ) - - call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,1),"qlink1" & -#ifdef MPP_LAND - ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & -#endif - ) - - - call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,2),"qlink2" & -#ifdef MPP_LAND - ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & -#endif - ) - - - call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%cvol,"cvol" & -#ifdef MPP_LAND - ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & -#endif - ) - -! call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%resht,"resht" & -!#ifdef MPP_LAND -! ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks & -!#endif -! ) - - call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%resht,"resht" & -#ifdef MPP_LAND - ,rt_domain(did)%lake_index & -#endif - ) - - call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakeo,"qlakeo" & -#ifdef MPP_LAND - ,rt_domain(did)%lake_index & -#endif - ) - - - call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort") - - end if - - if(nlst_rt(did)%GWBASESWCRT.EQ.1) then - call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,"z_gwsubbas" ) -!yw test bucket model -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gwbas_pix_ct,"gwbas_pix_ct" ) -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_exp,"gw_buck_exp" ) -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_max,"z_max" ) -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_coeff,"gw_buck_coeff" ) -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,"qin_gwsubbas" ) -! call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%qinflowbase,"qinflowbase") -! call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,"qout_gwsubbas" ) - end if - end if - -#ifdef MPP_LAND - if(IO_id.eq.my_id) & -#endif - iret = nf_close(ncid) - - return - end subroutine RESTART_OUT_nc - - subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName) - implicit none - integer:: ncid,ix,jx,varid , iret - character(len=*) varName - real, dimension(ix,jx):: inVar -#ifdef MPP_LAND - real, dimension(global_rt_nx, global_rt_ny):: varTmp - call write_IO_rt_real(inVar,varTmp) - if(my_id .eq. IO_id) then - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_rt_nx,global_rt_ny/),varTmp) - endif -#else - iret = nf_inq_varid(ncid,varName, varid) - if(iret .eq. 0) then - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),inVar) - else - write(6,*) "Error : variable not defined in rst file before write: ", varName - endif -#endif - - return - end subroutine w_rst_rt_nc2 - - subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName) - implicit none - integer:: ncid,ix,jx,varid , iret, nsoil - character(len=*) varName - real,dimension(ix,jx,nsoil):: inVar -#ifdef MPP_LAND - integer k - real varTmp(global_rt_nx,global_rt_ny,nsoil) - do k = 1, nsoil - call write_IO_rt_real(inVar(:,:,k),varTmp(:,:,k)) - end do - if(my_id .eq. IO_id) then - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/global_rt_nx,global_rt_ny,nsoil/),varTmp) - endif -#else - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ix,jx,nsoil/),inVar) -#endif - return - end subroutine w_rst_rt_nc3 - - subroutine w_rst_nc2(ncid,ix,jx,inVar,varName) - implicit none - integer:: ncid,ix,jx,varid , iret - character(len=*) varName - real inVar(ix,jx) - -#ifdef MPP_LAND - real varTmp(global_nx,global_ny) - call write_IO_real(inVar,varTmp) - if(my_id .eq. IO_id) then - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_nx,global_ny/),varTmp) - endif -#else - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),invar) -#endif - - return - end subroutine w_rst_nc2 - - subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName) - implicit none - integer:: ncid,ix,jx,varid , iret, nsoil - character(len=*) varName - real inVar(ix,jx,nsoil) - integer k -#ifdef MPP_LAND - real varTmp(global_nx,global_ny,nsoil) - do k = 1, nsoil - call write_IO_real(inVar(:,:,k),varTmp(:,:,k)) - end do - if(my_id .eq. IO_id) then - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/global_nx,global_ny,nsoil/),varTmp) - endif -#else - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ix,jx,nsoil/),inVar) -#endif - return - end subroutine w_rst_nc3 - - subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName & -#ifdef MPP_LAND - ,nodelist & -#endif - ) - implicit none - integer:: ncid,n,varid , iret - character(len=*) varName - real inVar(n) -#ifdef MPP_LAND - integer:: nodelist(n) - if(n .eq. 0) return - - call write_lake_real(inVar,nodelist,n) - if(my_id .eq. IO_id) then -#endif - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) -#ifdef MPP_LAND - endif -#endif - return - end subroutine w_rst_crt_nc1_lake - - subroutine w_rst_crt_nc1(ncid,n,inVar,varName & -#ifdef MPP_LAND - ,map_l2g, gnlinks& -#endif - ) - implicit none - integer:: ncid,n,varid , iret - character(len=*) varName - real inVar(n) -#ifdef MPP_LAND - integer:: gnlinks, map_l2g(n) - real g_var(gnlinks) - call write_chanel_real(inVar,map_l2g,gnlinks,n,g_var) - if(my_id .eq. IO_id) then - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/gnlinks/),g_var) -#else - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) -#endif -#ifdef MPP_LAND - endif -#endif - return - end subroutine w_rst_crt_nc1 - - subroutine w_rst_crt_nc1g(ncid,n,inVar,varName) - implicit none - integer:: ncid,n,varid , iret - character(len=*) varName - real inVar(n) -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - iret = nf_inq_varid(ncid,varName, varid) - iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar) -#ifdef MPP_LAND - endif -#endif - return - end subroutine w_rst_crt_nc1g - - subroutine RESTART_IN_NC(inFile,did) - - - implicit none - character(len=*) inFile - integer :: ierr, iret,ncid, did - - integer :: i, j - - -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif -!open a netcdf file - iret = nf_open(trim(inFile), NF_NOWRITE, ncid) -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening file: ''", A, "''")') & - trim(inFile) - call hydro_stop("RESTART_IN_NC") -#endif - endif - -#ifdef MPP_LAND - if(IO_id .eq. my_id) then -#endif - iret = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'his_out_counts', rt_domain(did)%his_out_counts) - iret = NF_GET_ATT_REAL(ncid, NF_GLOBAL, 'DTCT', nlst_rt(did)%DTCT) - iret = nf_get_att_text(ncid,NF_GLOBAL,"Since_Date",nlst_rt(did)%sincedate(1:19)) - if(iret /= 0) nlst_rt(did)%sincedate = nlst_rt(did)%startdate - if(nlst_rt(did)%DTCT .gt. 0) then - nlst_rt(did)%DTCT = min(nlst_rt(did)%DTCT, nlst_rt(did)%DTRT) - else - nlst_rt(did)%DTCT = nlst_rt(did)%DTRT - endif -#ifdef MPP_LAND - endif - call mpp_land_bcast_int1(rt_domain(did)%out_counts) - call mpp_land_bcast_real1(nlst_rt(did)%DTCT) -#endif - -#ifdef HYDRO_D - write(6,*) "nlst_rt(did)%nsoil=",nlst_rt(did)%nsoil -#endif - - if(nlst_rt(did)%rst_typ .eq. 1 ) then - call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc") - call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc") - call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox") - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt") - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt") - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain") - endif - - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1") - call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1") - - - if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT,"infxswgt") - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT,"SFCHEADSUBRT") - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT,"QBDRYRT") - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT,"qstrmvolrt") - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT,"RETDEPRT") - call read_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT,"sh2owgt") - - - if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then - call read_rst_crt_stream_nc(ncid,rt_domain(did)%HLINK,rt_domain(did)%NLINKS,"hlink",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) - call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,1),rt_domain(did)%NLINKS,"qlink1",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) - call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,2),rt_domain(did)%NLINKS,"qlink2",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) - call read_rst_crt_stream_nc(ncid,rt_domain(did)%CVOL,rt_domain(did)%NLINKS,"cvol",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g) - if(rt_domain(did)%NLAKES .gt. 0) then - call read_rst_crt_nc(ncid,rt_domain(did)%RESHT,rt_domain(did)%NLAKES,"resht") - call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEO,rt_domain(did)%NLAKES,"qlakeo") - endif - call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort") - - end if - - if(nlst_rt(did)%GWBASESWCRT.EQ.1.AND.nlst_rt(did)%GW_RESTART.NE.0 .and. rt_domain(did)%numbasns .gt. 0) then - call read_rst_crt_nc(ncid,rt_domain(did)%z_gwsubbas,rt_domain(did)%numbasns,"z_gwsubbas") - end if - end if - - if(nlst_rt(did)%rstrt_swc.eq.1) then !Switch for rest of restart accum vars... -#ifdef HYDRO_D - print *, "1 Resetting RESTART Accumulation Variables to 0...",nlst_rt(did)%rstrt_swc -#endif - rt_domain(did)%INFXSRT=0. - rt_domain(did)%LAKE_INFLORT=0. - rt_domain(did)%QSTRMVOLRT=0. - end if - - -#ifdef MPP_LAND - if(my_id .eq. IO_id) & -#endif - iret = nf_close(ncid) -#ifdef HYDRO_D - write(6,*) "end of RESTART_IN" - flush(6) -#endif - - !call check_channel(81,rt_domain(did)%QLINK(:,1),1,rt_domain(did)%NLINKS) - !call check_channel(83,rt_domain(did)%QLINK(:,2),1,rt_domain(did)%NLINKS) - !call check_channel(84,rt_domain(did)%HLINK,1,rt_domain(did)%NLINKS) - !call check_channel(85,rt_domain(did)%CVOL,1,rt_domain(did)%NLINKS) - !call hydro_stop("666666666666") - - return - end subroutine RESTART_IN_nc - - subroutine read_rst_nc3(ncid,ix,jx,NSOIL,var,varStr) - implicit none - integer :: ix,jx,nsoil, ireg, ncid, varid, iret - real,dimension(ix,jx,nsoil) :: var - character(len=*) :: varStr -#ifdef MPP_LAND - real,dimension(global_nx,global_ny,nsoil) :: xtmp - integer i - - if(my_id .eq. IO_id) & -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) & - iret = nf_get_var_real(ncid, varid, xtmp) - - do i = 1, nsoil - call decompose_data_real(xtmp(:,:,i), var(:,:,i)) - end do -#else - iret = nf_get_var_real(ncid, varid, var) -#endif - - return - end subroutine read_rst_nc3 - - subroutine read_rst_nc2(ncid,ix,jx,var,varStr) - implicit none - integer :: ix,jx,ireg, ncid, varid, iret - real,dimension(ix,jx) :: var - character(len=*) :: varStr -#ifdef MPP_LAND - real,dimension(global_nx,global_ny) :: xtmp - if(my_id .eq. IO_id) & -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) - -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) & - iret = nf_get_var_real(ncid, varid, xtmp) - - call decompose_data_real(xtmp, var) -#else - var = 0.0 - iret = nf_get_var_real(ncid, varid, var) -#endif - return - end subroutine read_rst_nc2 - - subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr) - implicit none - integer :: ix,jx,nsoil, ireg, ncid, varid, iret - real,dimension(ix,jx,nsoil) :: var - character(len=*) :: varStr -#ifdef MPP_LAND - real,dimension(global_rt_nx,global_rt_ny,nsoil) :: xtmp - integer i - if(my_id .eq. IO_id) & -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - iret = nf_get_var_real(ncid, varid, xtmp) - do i = 1, nsoil - call decompose_RT_real(xtmp(:,:,i),var(:,:,i),global_rt_nx,global_rt_ny,ix,jx) - end do -#else - iret = nf_get_var_real(ncid, varid, var) -#endif - return - end subroutine read_rst_rt_nc3 - - subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr) - implicit none - integer :: ix,jx,ireg, ncid, varid, iret - real,dimension(ix,jx) :: var - character(len=*) :: varStr -#ifdef MPP_LAND - real,dimension(global_rt_nx,global_rt_ny) :: xtmp -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) & - iret = nf_get_var_real(ncid, varid, xtmp) - call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx) -#else - iret = nf_get_var_real(ncid, varid, var) -#endif - return - end subroutine read_rst_rt_nc2 - - subroutine read_rt_nc2(ncid,ix,jx,var,varStr) - implicit none - integer :: ix,jx, ncid, varid, iret - real,dimension(ix,jx) :: var - character(len=*) :: varStr - -#ifdef MPP_LAND - real,dimension(global_rt_nx,global_rt_ny) :: xtmp - xtmp = 0.0 -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) then - iret = nf_get_var_real(ncid, varid, xtmp) - endif - call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx) -#else - iret = nf_get_var_real(ncid, varid, var) -#endif - return - end subroutine read_rt_nc2 - - subroutine read_rst_crt_nc(ncid,var,n,varStr) - implicit none - integer :: ireg, ncid, varid, n, iret - real,dimension(n) :: var - character(len=*) :: varStr - - if( n .le. 0) return -#ifdef MPP_LAND - if(my_id .eq. IO_id) & -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - iret = nf_get_var_real(ncid, varid, var) -#ifdef MPP_LAND - endif - call mpp_land_bcast_real(n,var) -#endif - return - end subroutine read_rst_crt_nc - - subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g) - implicit none - integer :: ncid, varid, n, iret, gnlinks - integer, intent(in), dimension(:) :: map_l2g - character(len=*) :: varStr - integer :: l, g - real,intent(out) , dimension(:) :: var_out -#ifdef MPP_LAND - real,dimension(gnlinks) :: var -#else - real,dimension(n) :: var -#endif - - -#ifdef MPP_LAND - if(my_id .eq. IO_id) & -#endif - iret = nf_inq_varid(ncid, trim(varStr), varid) -#ifdef MPP_LAND - call mpp_land_bcast_int1(iret) -#endif - if (iret /= 0) then -#ifdef HYDRO_D - print*, 'variable not found: name = "', trim(varStr)//'"' -#endif - return - endif -#ifdef HYDRO_D - print*, "read restart variable ", varStr -#endif -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - var = 0.0 - iret = nf_get_var_real(ncid, varid, var) -#ifdef MPP_LAND - endif - call mpp_land_bcast_real(gnlinks,var) - - if(n .le. 0) return - var_out = 0 - - do l = 1, n - g = map_l2g(l) - var_out(l) = var(g) - end do -#else - var_out = var -#endif - return - end subroutine read_rst_crt_stream_nc - - subroutine hrldas_out() - end subroutine hrldas_out - - SUBROUTINE READ_ROUTING_old(IXRT,JXRT,ELRT,CH_NETRT,LKSATFAC,route_topo_f, & - route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC) - - -#include - INTEGER, INTENT(IN) :: IXRT,JXRT - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT -!Dummy inverted grids - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC - REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC - - INTEGER :: I,J, iret, jj - CHARACTER(len=256) :: var_name - CHARACTER(len=256) :: route_topo_f - CHARACTER(len=256) :: route_chan_f - CHARACTER(len=256) :: geo_finegrid_flnm - - var_name = "TOPOGRAPHY" - call readRT2d_real(var_name,ELRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - -!!!DY to be fixed ... 6/27/08 -! var_name = "BED_ELEVATION" -! iret = get2d_real(var_name,ELRT,ixrt,jxrt,& -! trim(geo_finegrid_flnm)) - - var_name = "CHANNELGRID" - call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - - var_name = "LKSATFAC" - LKSATFAC = -9999.9 - call readRT2d_real(var_name,LKSATFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) -#ifdef HYDRO_D - write(6,*) "read ",var_name -#endif - - where (LKSATFAC == -9999.9) LKSATFAC = 1000.0 !specify LKSAFAC if no term avail... - - -!1.12.2012...Read in routing calibration factors... - var_name = "RETDEPRTFAC" - call readRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists - - var_name = "OVROUGHRTFAC" - call readRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,& - trim(geo_finegrid_flnm)) - where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists - - -#ifdef HYDRO_D - write(6,*) "finish READ_ROUTING_old" -#endif - - return - -!DJG ----------------------------------------------------- - END SUBROUTINE READ_ROUTING_old -!DJG _____________________________ - - -#ifdef MPP_LAND - - SUBROUTINE MPP_READ_CHROUTING(did,IXRT,JXRT,ELRT,CH_NETRT, LAKE_MSKRT, & - FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, & - NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, & - HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & - ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, & - route_link_f, & - route_lake_f, route_direction_f, route_order_f, & - CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, & - CHANXI, CHANYJ, CHLAT, CHLON, & - channel_option,LATVAL,LONVAL, & - STRMFRXSTPTS,geo_finegrid_flnm,Link_Location) - use module_mpp_land, only: my_id, io_id -#include - INTEGER, INTENT(IN) :: IXRT,JXRT, did - INTEGER :: CHANRTSWCRT, NLINKS, NLAKES - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION - INTEGER, DIMENSION(IXRT,JXRT) :: GSTRMFRXSTPTS - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT - INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - INTEGER, DIMENSION(IXRT,JXRT) :: GORDER !-- gridded stream orderk - INTEGER, DIMENSION(IXRT,JXRT) :: Link_Location !-- gridded stream orderk - INTEGER :: I,J,channel_option - REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LATVAL, LONVAL - CHARACTER(len=28) :: dir -!Dummy inverted grids from arc - - -!----DJG,DNY New variables for channel and lake routing - CHARACTER(len=155) :: header - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: FROM_NODE - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ZELEV - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHLAT,CHLON - - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TYPEL - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: TO_NODE,ORDER - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: STRMFRXSTPTS - - INTEGER, INTENT(INOUT) :: MAXORDER - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MUSK, MUSX !muskingum - REAL, INTENT(INOUT), DIMENSION(NLINKS,2) :: QLINK !channel flow - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CHANLEN !channel length - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: MannN, So !mannings N - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: LAKENODE ! identifies which nodes pour into which lakes - REAL, INTENT(IN) :: dist(ixrt,jxrt,9) - - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK - REAL, DIMENSION(IXRT,JXRT) :: ChSSlpG,BwG,MannNG !channel properties on Grid - - -!-- store the location x,y location of the channel element - INTEGER, INTENT(INOUT), DIMENSION(NLINKS) :: CHANXI, CHANYJ - -!--reservoir/lake attributes - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: HRZAREA - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: LAKEMAXH - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: WEIRC - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: WEIRL - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEC - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEA - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: ORIFICEE - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: LATLAKE,LONLAKE,ELEVLAKE - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: ChSSlp, Bw - - CHARACTER(len=256) :: route_link_f - CHARACTER(len=256) :: route_lake_f - CHARACTER(len=256) :: route_direction_f - CHARACTER(len=256) :: route_order_f - CHARACTER(len=256) :: geo_finegrid_flnm - CHARACTER(len=256) :: var_name - - INTEGER :: tmp, cnt, ncid, iret, jj,ct - real :: gc,n - -!--------------------------------------------------------- -! End Declarations -!--------------------------------------------------------- - MAXORDER = -9999 -!initialize GSTRM - GSTRMFRXSTPTS = -9999 - -!yw initialize the array. - to_node = MAXORDER - from_node = MAXORDER - Link_location = MAXORDER - -#ifdef HYDRO_D - print *, "reading routing initialization files..." - print *, "route direction", route_direction_f - print *, "route order", route_order_f - print *, "route linke",route_link_f - print *, "route lake",route_lake_f -#endif - -!DJG Edited code here to retrieve data from hires netcdf file.... - - IF((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then - - var_name = "LATITUDE" -#ifdef MPP_LAND - call mpp_readRT2d_real (did, & -#else - call readRT2d_real ( & -#endif - var_name,LATVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) - - - var_name = "LONGITUDE" -#ifdef MPP_LAND - call mpp_readRT2d_real(did, & -#else - call readRT2d_real( & -#endif - var_name,LONVAL,ixrt,jxrt,trim(geo_finegrid_flnm)) - - END IF - - - IF(CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2) then -!DJG change filename to LAKEPARM.TBL open(unit=79,file=trim(route_link_f), & -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - open(unit=79,file='LAKEPARM.TBL', & - form='formatted',status='old') -#ifdef MPP_LAND - endif -#endif - END IF - - - var_name = "LAKEGRID" -#ifdef MPP_LAND - call mpp_readRT2d_int(did,& -#else - call readRT2d_int(& -#endif - var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm)) - - var_name = "FLOWDIRECTION" -#ifdef MPP_LAND - call mpp_readRT2d_int(did, & -#else - call readRT2d_int(& -#endif - var_name,DIRECTION,ixrt,jxrt,trim(geo_finegrid_flnm)) - - var_name = "STREAMORDER" -#ifdef MPP_LAND - call mpp_readRT2d_int(did,& -#else - call readRT2d_int(& -#endif - var_name,GORDER,ixrt,jxrt,trim(geo_finegrid_flnm)) - - - var_name = "frxst_pts" -#ifdef MPP_LAND - call mpp_readRT2d_int(did,& -#else - call readRT2d_int(& -#endif - var_name,GSTRMFRXSTPTS,ixrt,jxrt,trim(geo_finegrid_flnm)) - -!!!Flip y-dimension of highres grids from exported Arc files... - - - ct = 0 - -#ifdef HYDRO_D - print *, "Number of frxst pts: ",ct -#endif - - -! temp fix for buggy Arc export... - do j=1,jxrt - do i=1,ixrt - if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 - end do - end do - - cnt =0 - if ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option .ne. 3) then ! not routing on grid, read from file - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - read(79,*) header -#ifdef MPP_LAND - endif -#endif - call hydro_stop("Possible Error for this code") - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - do i=1,NLINKS - read (79,*) tmp, FROM_NODE(i), TO_NODE(i), TYPEL(i),& - ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), & - MannN(i), So(i), ChSSlp(i), Bw(i), HRZAREA(i),& - LAKEMAXH(i), WEIRC(i), WEIRL(i), ORIFICEC(i), & - ORIFICEA(i),ORIFICEE(i) - - !-- hardwire QLINK - QLINK(i,1) = 1.0 - QLINK(i,2) = QLINK(i,1) - - if (So(i).lt.0.005) So(i) = 0.005 !-- impose a minimum slope requireement - - if (ORDER(i) .gt. MAXORDER) then - MAXORDER = ORDER(i) - endif - - end do -#ifdef MPP_LAND - endif - call mpp_land_bcast_int(NLINKS,FROM_NODE) - call mpp_land_bcast_int(NLINKS,TO_NODE) - call mpp_land_bcast_int(NLINKS,TYPEL ) - call mpp_land_bcast_int(NLINKS,ORDER ) - call mpp_land_bcast_real(NLINKS,QLINK ) - call mpp_land_bcast_real(NLINKS,MUSK ) - call mpp_land_bcast_real(NLINKS,MUSX ) - call mpp_land_bcast_real(NLINKS,CHANLEN) - call mpp_land_bcast_real(NLINKS,MannN ) - call mpp_land_bcast_real(NLINKS,So ) - call mpp_land_bcast_real(NLINKS,ChSSlp ) - call mpp_land_bcast_real(NLINKS,Bw ) - call mpp_land_bcast_real(NLINKS,HRZAREA) - call mpp_land_bcast_real(NLINKS,LAKEMAXH) - call mpp_land_bcast_real(NLINKS,WEIRC ) - call mpp_land_bcast_real(NLINKS,WEIRL ) - call mpp_land_bcast_real(NLINKS,ORIFICEC) - call mpp_land_bcast_real(NLINKS,ORIFICEA) - call mpp_land_bcast_real(NLINKS,ORIFICEE) - call mpp_land_bcast_int1(MAXORDER) - -#endif - - elseif ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option.eq.3) then !-- handle setting up topology on the grid for diffusion scheme - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - read(79,*) header !-- read the lake file -#ifdef HYDRO_D - write(*,*) "output message: reading lake file ", header - write(6,*) "output message: error check read file ",route_link_f -#endif -#ifdef MPP_LAND - endif -#endif - - - if (NLAKES.gt.0) then !read in only if there are lakes - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - - do i=1, NLAKES - read (79,*) tmp, HRZAREA(i),LAKEMAXH(i), & - WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),& - LATLAKE(i), LONLAKE(i),ELEVLAKE(i) -#ifdef HYDRO_D - write (*,*) tmp, HRZAREA(i),LAKEMAXH(i), LATLAKE(i), LONLAKE(i),ELEVLAKE(i),NLAKES -#endif - enddo - -#ifdef MPP_LAND - endif - call mpp_land_bcast_real(NLAKES,HRZAREA) - call mpp_land_bcast_real(NLAKES,LAKEMAXH) - call mpp_land_bcast_real(NLAKES,WEIRC ) - call mpp_land_bcast_real(NLAKES,WEIRL ) - call mpp_land_bcast_real(NLAKES,ORIFICEC) - call mpp_land_bcast_real(NLAKES,ORIFICEA) - call mpp_land_bcast_real(NLAKES,ORIFICEE) - call mpp_land_bcast_real(NLAKES,LATLAKE ) - call mpp_land_bcast_real(NLAKES,LONLAKE ) - call mpp_land_bcast_real(NLAKES,ELEVLAKE) -#endif - - end if !end if for NLAKES >0 check - - cnt = 0 - - - BwG = 0.0 - ChSSlpG = 0.0 - MannNG = 0.0 - TYPEL = 0 - MannN = 0.0 - Bw = 0.0 - ChSSlp = 0.0 - -!DJG inv DO j = JXRT,1,-1 !rows - DO j = 1,JXRT !rows - DO i = 1 ,IXRT !colsumns - If (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order - If ((DIRECTION(i, j) .EQ. 64) .AND. (j + 1 .LE. JXRT) .AND. & - (CH_NETRT(i,j+1).ge.0) ) then !North - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i, j + 1) - CHANLEN(cnt) = dist(i,j,1) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1).ge.0) ) then !North East - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1) - CHANLEN(cnt) = dist(i,j,2) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT) & - .AND. (CH_NETRT(i+1,j).ge.0) ) then !East - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j) - CHANLEN(cnt) = dist(i,j,3) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & - .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i+1,j-1).ge.0) ) then !south east - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1) - CHANLEN(cnt) = dist(i,j,4) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0) ) then !due south - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i, j - 1) - CHANLEN(cnt) = dist(i,j,5) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & - .AND. (j - 1 .NE. 0) .AND. (CH_NETRT(i-1,j-1).ge.0)) then !south west - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i,j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1) - CHANLEN(cnt) = dist(i,j,6) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0) ) then !West - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j) - CHANLEN(cnt) = dist(i,j,7) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0) ) then !North West - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - FROM_NODE(cnt) = CH_NETLNK(i, j) - TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1) - CHANLEN(cnt) = dist(i,j,8) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt - else -#ifdef HYDRO_D - print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east -#endif - End If - - End If !CH_NETRT check for this node - - END DO - END DO - -#ifdef HYDRO_D - print *, "after exiting the channel, this many nodes", cnt - write(*,*) " " -#endif - -!Find out if the boundaries are on an edge -!DJG inv DO j = JXRT,1,-1 - DO j = 1,JXRT - DO i = 1 ,IXRT - If (CH_NETRT(i, j) .ge. 0) then !get its direction - -!#ifdef MPP_LAND -! If (((DIRECTION(i, j).EQ. 64) .AND. ((j + 1 .GT. JXRT) .and. (up_id < 0)) ) .OR. & !-- 64's can only flow north -! ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North -!#else - If (((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) .OR. & !-- 64's can only flow north - ((DIRECTION(i, j) .EQ. 64) .and. (j < jxrt) .AND. (CH_NETRT(i,j+1) .lt. 0))) then !North -!#endif - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(j+1 .GT. JXRT) then !-- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i,j+1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i,j+1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,1) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - -!#ifdef MPP_LAND -! else if ( ((DIRECTION(i, j) .EQ. 128) .AND. ((i + 1 .GT. IXRT) .and. (right_id < 0)) ) & !-- 128's can flow out of the North or East edge -! .OR. ((DIRECTION(i, j) .EQ. 128) .AND. ((j + 1 .GT. JXRT) .and. (up_id < 0)) ) & ! this is due north edge -! .OR. ((DIRECTION(i, j) .EQ. 128) .AND. (i1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if((i+1 .GT. IXRT) .OR. (j-1 .EQ. 0)) then !an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i+1,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,4) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - -!#ifdef MPP_LAND -! else if (((DIRECTION(i, j) .EQ. 4) .AND. ((j - 1 .EQ. 0) .and. (down_id <0)) ) .OR. & !-- 4's can only flow due south -! ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south -!#else - else if (((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) .OR. & !-- 4's can only flow due south - ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south -!#endif - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(j-1 .EQ. 0) then !- an edge - TYPEL(cnt) =1 - elseif(LAKE_MSKRT(i,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,5) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - -!#ifdef MPP_LAND -! else if ( ((DIRECTION(i, j) .EQ. 8) .AND. ((i - 1 .LE. 0).and.(left_id <0))) & !-- 8's can flow south or west -! .OR. ((DIRECTION(i, j) .EQ. 8) .AND.( (j - 1 .EQ. 0) .and. (down_id <0)) ) & !-- this is the south edge -! .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west -!#else - else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west - .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge - .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west -!#endif - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if( (i-1 .EQ. 0) .OR. (j-1 .EQ. 0) ) then !- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i-1,j-1).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,6) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif -!#ifdef MPP_LAND -! else if (((DIRECTION(i, j) .EQ. 16) .AND. ((i - 1 .LE.0) .and. (left_id <0)) ) & !16's can only flow due west -!#else - else if (((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE.0) ) & !16's can only flow due west -!#endif - .OR.((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West - !yw cnt = cnt + 1 - cnt = CH_NETLNK(i,j) - ORDER(cnt) = GORDER(i,j) - STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j) - ZELEV(cnt) = ELRT(i,j) - MannN(cnt) = MannNG(i,j) - ChSSlp(cnt) = ChSSlpG(i,j) - Bw(cnt) = BwG(i,j) - CHLAT(cnt) = LATVAL(i,j) - CHLON(cnt) = LONVAL(i,j) - if(i-1 .EQ. 0) then !-- an edge - TYPEL(cnt) = 1 - elseif(LAKE_MSKRT(i-1,j).gt.0) then - TYPEL(cnt) = 2 - LAKENODE(cnt) = LAKE_MSKRT(i-1,j) - else - TYPEL(cnt) = 1 - endif - FROM_NODE(cnt) = CH_NETLNK(i, j) - CHANLEN(cnt) = dist(i,j,7) - CHANXI(cnt) = i - CHANYJ(cnt) = j - Link_Location(i,j) = cnt -#ifdef HYDRO_D - print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt -#endif - -!#ifdef MPP_LAND -! else if ( ((DIRECTION(i, j) .EQ. 32) .AND. ((i - 1 .LE. 0) .and. (left_id <0)) ) & !-- 32's can flow either west or north -! .OR. ((DIRECTION(i, j) .EQ. 32) .AND. ((j + 1 .GT. JXRT) .and. (up_id <0)) ) & !-- this is the north edge -!#else - else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north - .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge -!#endif - .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. j - INTEGER :: I,J,channel_option,iret,jj, did - INTEGER, INTENT(OUT) :: NLINKS - INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK !- each node gets unique id - - INTEGER, INTENT(IN) :: IXRT,JXRT - INTEGER :: CHNID,cnt - INTEGER, DIMENSION(IXRT,JXRT) :: CH_NETRT !- binary channel mask - INTEGER, DIMENSION(IXRT,JXRT) :: DIRECTION !- flow direction - INTEGER, DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - REAL, DIMENSION(IXRT,JXRT) :: LAT, LON - -!!Dummy read in grids for inverted y-axis - - - CHARACTER(len=*) :: route_chan_f, route_link_f,route_direction_f,route_lake_f - CHARACTER(len=256) :: InputLine - CHARACTER(len=256) :: geo_finegrid_flnm - CHARACTER(len=256) :: var_name -! external get2d_real -! integer :: get2d_real - - NLINKS = 0 - CH_NETRT = -9999 - CH_NETLNK = -9999 - - - cnt = 0 -#ifdef HYDRO_D - print *, "Channel Option in Routedim is ", channel_option -#endif - - IF(channel_option.eq.3) then !get maxnodes and links from grid - - var_name = "CHANNELGRID" -#ifdef MPP_LAND - call mpp_readRT2d_int(did,& -#else - call readRT2d_int(& -#endif - var_name,CH_NETRT,ixrt,jxrt, trim(geo_finegrid_flnm)) - - - var_name = "FLOWDIRECTION" -#ifdef MPP_LAND - call mpp_readRT2d_int(did, & -#else - call readRT2d_int( & -#endif - var_name,DIRECTION,ixrt,jxrt, trim(geo_finegrid_flnm)) - - var_name = "LAKEGRID" -#ifdef MPP_LAND - call mpp_readRT2d_int(did, & -#else - call readRT2d_int( & -#endif - var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm)) - - - var_name = "LATITUDE" -#ifdef MPP_LAND - call mpp_readRT2d_real(did, & -#else - call readRT2d_real( & -#endif - var_name,LAT,ixrt,jxrt,trim(geo_finegrid_flnm)) - - - var_name = "LONGITUDE" -#ifdef MPP_LAND - call mpp_readRT2d_real(did, & -#else - call readRT2d_real( & -#endif - var_name,LON,ixrt,jxrt,trim(geo_finegrid_flnm)) - -! temp fix for buggy Arc export... - do j=1,jxrt - do i=1,ixrt - if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128 - end do - end do - -!DJG inv do j=jxrt,1,-1 - do j=1,jxrt - do i = 1, ixrt - if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then - NLINKS = NLINKS + 1 - endif - end do - end do -#ifdef HYDRO_D - print *, "NLINKS IS ", NLINKS -#endif - - -!DJG inv DO j = JXRT,1,-1 !rows - DO j = 1,JXRT !rows - DO i = 1 ,IXRT !colsumns - If (CH_NETRT(i, j) .ge. 0) then !get its direction - If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT).AND.(CH_NETRT(i,j+1) .ge.0) ) then !North - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i+1,j+1) .ge.0)) then !North East - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT).AND.(CH_NETRT(i+1,j) .ge. 0)) then !East - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) & - .AND. (j - 1 .NE. 0).AND.(CH_NETRT(i+1,j-1).ge.0)) then !south east - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0).AND.(CH_NETRT(i,j-1).ge.0)) then !due south - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) & - .AND. (j - 1 .NE. 0).AND. (CH_NETRT(i-1,j-1).ge.0) ) then !south west - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0).AND.(CH_NETRT(i-1,j).ge.0)) then !West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) & - .AND. (j + 1 .LE. JXRT) .AND. (CH_NETRT(i-1,j+1).ge.0)) then !North West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt - else -#ifdef HYDRO_D - write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j -135 FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4) -#endif - if (DIRECTION(i,j) .eq. 0) then -#ifdef HYDRO_D - print *, "Direction i,j ",i,j," of point ", cnt, "is invalid" -#endif - endif - - End If - End If !CH_NETRT check for this node - END DO - END DO -#ifdef HYDRO_D - print *, "found type 0 nodes", cnt -#endif - -!Find out if the boundaries are on an edge or flow into a lake -!DJG inv DO j = JXRT,1,-1 - DO j = 1,JXRT - DO i = 1 ,IXRT - If (CH_NETRT(i, j) .ge. 0) then !get its direction - - If ( ((DIRECTION(i, j).EQ. 64) .AND. (j + 1 .GT. JXRT)) & !-- 64's can only flow north - .OR. ((DIRECTION(i, j) .EQ. 64).and. (j1) .AND.(CH_NETRT(i + 1, j - 1) .lt.0))) then !south east - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .EQ. 0)) & !-- 4's can only flow due south - .OR. ((DIRECTION(i, j) .EQ. 4) .and. (j>1) .AND.(CH_NETRT(i, j - 1) .lt. 0))) then !due south - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .LE. 0)) & !-- 8's can flow south or west - .OR. ((DIRECTION(i, j) .EQ. 8) .AND. (j - 1 .EQ. 0)) & !-- this is the south edge - .OR. ((DIRECTION(i, j).EQ.8).and. (i>1 .and. j>1) .AND.(CH_NETRT(i - 1, j - 1).lt.0))) then !south west - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .LE. 0)) & !-- 16's can only flow due west - .OR. ((DIRECTION(i, j).EQ.16) .and. (i>1) .AND.(CH_NETRT(i - 1, j).lt.0))) then !West - cnt = cnt + 1 - CH_NETLNK(i,j) = cnt -#ifdef HYDRO_D - print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j -#endif - else if ( ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .LE. 0)) & !-- 32's can flow either west or north - .OR. ((DIRECTION(i, j) .EQ. 32) .AND. (j + 1 .GT. JXRT)) & !-- this is the north edge - .OR. ((DIRECTION(i, j).EQ.32) .and. (i>1 .and. jchannel coefficients" - print *, "nod, n, Cs, Bw", nod, n, Cs, Bw - call hydro_stop("in DIFFUSION") -#endif - endif - -! Sf = ((z1+h1)-(z2+h2))/dx !-- compute the friction slope - !if(z1 .eq. z2) then - ! Sf = ((z1-(z2-0.01))+(h1-h2))/dx !-- compute the friction slope - !else -! Sf = ((z1-z2)+(h1-h2))/dx !-- compute the friction slope - !endif - -!modifieed by Wei Yu for false geography data - if(abs(z1-z2) .gt. 1.0E5) then -#ifdef HYDRO_D - print*, "Warning: huge slope rest to 0 for channel grid.", z1,z2 -#endif - Sf = ((h1-h2))/dx !-- compute the friction slope - else - Sf = ((z1-z2)+(h1-h2))/dx !-- compute the friction slope - endif -!end modfication - - sgn = SGNf(Sf) !-- establish sign - - w = 0.5*(sgn + 1.) !-- compute upstream or downstream weighting - - z = 1/Cs !--channel side distance (m) - R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z**2)) !-- Hyd Radius - AREA = (Bw+z*h1)*h1 !-- Flow area - Ku = (1/n)*(R**(2./3.))*AREA !-- convenyance - - R = ((Bw+z*h2)*h2)/(Bw+2*h2*sqrt(1+z**2)) !-- Hyd Radius - AREA = (Bw+z*h2)*h2 !-- Flow area - Kd = (1/n)*(R**(2./3.))*AREA !-- convenyance - - Kf = (1-w)*Kd + w*Ku !-- conveyance - DIFFUSION = Kf * sqrt(abs(Sf))*sgn - - -100 format('z1,z2,h1,h2,kf,Dif, Sf, sgn ',f8.3,2x,f8.3,2x,f8.4,2x,f8.4,2x,f8.3,2x,f8.3,2x,f8.3,2x,f8.0) - - END FUNCTION DIFFUSION -! ---------------------------------------------------------------- - -! ------------------------------------------------ -! FUNCTION MUSKINGUM CUNGE -! ------------------------------------------------ - REAL FUNCTION MUSKINGCUNGE(index,qup, quc, qdp, ql,& - dt,So,dx,n,Cs,Bw) - IMPLICIT NONE - -!--local variables - REAL :: C1, C2, C3, C4 - REAL :: Km !K travel time in hrs in reach - REAL :: X !weighting factors 0<=X<=0.5 - REAL :: dt !routing period in seconds - REAL :: qup !flow upstream previous timestep - REAL :: quc !flow upstream current timestep - REAL :: qdp !flow downstream previous timestep - REAL :: ql !lateral inflow through reach (m^3/sec) - REAL :: Ck ! wave celerity (m/s) - REAL :: qp ! peak flow - -!-- channel geometry and characteristics - REAL :: Bw ! bottom width (meters) - REAL :: Cs ! Channel side slope slope - REAL :: So ! Channel bottom slope - REAL :: dx ! channel lngth (m) - REAL :: n ! mannings coefficient - REAL :: Tw ! top width at peak flow - REAL :: AREA ! Cross sectional area m^2 - REAL :: Z ! trapezoid distance (m) - REAL :: R ! Hydraulic radius - REAL :: WP ! wetted perimmeter - REAL :: h ! depth of flow - REAL :: Qj ! intermediate flow estimate - REAL :: D,D1 ! diffusion coeff - REAL :: dtr ! required timestep, minutes - REAL :: error,shapefn, sh1, sh2, sh3 - REAL :: hp !courant, previous height - INTEGER :: maxiter !maximum number of iterations - -!-- local variables.. needed if channel is sub-divded - REAL :: c,b - REAL :: dxlocal - INTEGER :: i,index !-- channel segment counter - INTEGER :: ChnSegments !-- number of channel sub-sections - - c = 0.2407 !-- coefficnets for finding dx/Ckdt - b = 1.16065 - - z = 1/Cs !channel side distance (m) - h = sqrt(quc+ql)*0.1 !-- assume a initial depth (m) - qp = quc + ql - - if (n.le.0.or.So.le.0.or.z.le.0.or.Bw.le.0) then -#ifdef HYDRO_D - print*, "error in channel coefficients -> Muskingum cunge" - call hydro_stop("in MUSKINGCUNGE") -#endif - end if - - error = 1.0 - maxiter = 0 - - if (quc .gt.0) then !--top of link must have some water in it - do while (error .gt. 0.01 .and. maxiter < 100) !-- first estimate depth at top of channel - maxiter = maxiter + 1 - !---trapezoidal channel shape function - shapefn = SHAPE(Bw,z,h) - Qj = FLOW(n,So,Bw,h,z) - h = h - (1-quc/Qj)/(shapefn) - error = abs((Qj - quc)/quc) - end do - endif - - maxiter = 0 -!------- approximate flow and depth at the bottom of the channel - if (ql .eq.0 .and. quc .eq. 0) then !-- no water to route - Qj=0.0 - else - error = 1.0 !--reset the error - Tw = Bw + 2*z*h !--top width of the channel inflow - Ck = (sqrt(So)/n)*(5/3)*h**0.667 !-- pg 287 Chow, Mdt, Mays - X = 0.5-(qp/(2*Tw*So*Ck*dx)) - if (X.le.0) then -#ifdef HYDRO_D - print *, "Muskingum weighting factor is less than 0" -#endif - endif - - if ( dx/(Ck*dt) .le. c*LOG(X)+b) then !-- Bedient and Huber pg. 296 - ChnSegments = 1 - dxlocal = dx - else - dxlocal = fnDX(qp,Tw,So, Ck,dx,dt) !-- find appropriate channel length - X = 0.5-(qp/(2*Tw*So*Ck*dxlocal)) - if(FRACTION(dx/dxlocal) .le. 0.5) then !-- round up - ChnSegments = NINT(dx/dxlocal) + 1 - else - ChnSegments = NINT(dx/dxlocal) - endif - dxlocal = dx/ChnSegments !-- compute segment length, which will - endif - - do i = 1, ChnSegments - error = 1.0 !--reset the error - - do while (error .gt. 0.01 .and. maxiter < 500) - - if (qp.gt.2*(2*Tw*So*Ck*dxlocal)) then -#ifdef HYDRO_D - print *, "ERROR IN Musking Cunge,X <0 ", X - print *, "X,Qp,Tw,So,Ck,Dxlocal",X,Qp,Tw,So,Ck,Dxlocal -#endif - endif - - Km = dxlocal/Ck !-- minutes,Muskingum Param - D = (Km*(1 - X) + dt/2) !-- minutes - C1 = (Km*X + dt/2)/D - C2 = (dt/2 - Km*X)/D - C3 = (Km*(1-X)-dt/2)/D - C4 = (ql/ChnSegments*dt)/D !-- lateral inflow is along each channel sub-section - - MUSKINGCUNGE = (C1*qup)+(C2*quc)+(C3*qdp)+C4 !-- pg 295 Bedient huber assume flows from previous - !--previous values same in each segment,a good assumption? - if (MUSKINGCUNGE .lt. 0) then !-- only outflow -#ifdef HYDRO_D - print *, "ERROR: musking cunge is negative" - print *, "D, C1+C2+C3,C4, MsCng",D,C1+C2+C3,C4,Muskingcunge - print *, "qup, quc, qdp, ql",qup,quc,qdp,ql,i,ChnSegments -#endif - Qj = 0.0 - error = 0.001 - else -!---trapezoidal channel shape function - shapefn = SHAPE(Bw,z,h) - Qj = FLOW(n,So,Bw,h,z) - h = h - (1-MUSKINGCUNGE/Qj)/(shapefn) - error = abs((Qj - MUSKINGCUNGE)/MUSKINGCUNGE) - if (h<0.00001) error=0.001 !--very small flow depths to route - Tw = Bw+2*z*h - hp=h - maxiter = maxiter + 1 - endif - enddo !-- while error condtion number of - if (ChnSegments .gt.1) then - quc = MUSKINGCUNGE !-- update condition for next channel length upstream - endif - enddo !-- number of channel segment loops - endif - - MUSKINGCUNGE = Qj - - if(index .eq. 1 .or. index .eq. 2 .or. index .eq. 6) then -#ifdef HYDRO_D - write(*,13) index, ql,quc,qup,Qj,qdp -#endif - endif - -10 format('Tw,h,Z, latflow,usf',f3.1,2x,f8.4,2x,f4.1,2x,f5.4,2x,f5.4) -11 format('h, Qj, Musking, error',f8.4,2x,f8.4,2x,f8.4,2x,f8.4) -12 format('X, Km, Ck, dtcrv',f8.2,2x,f8.1,2x,f8.1,2x,f6.4) -13 format('ql,quc,qup,qdc,qdp',i2,2x,f8.2,2x,f8.2,2x,f8.2,2x,f8.2,2x,f8.2) - -! ---------------------------------------------------------------- - END FUNCTION MUSKINGCUNGE -! ---------------------------------------------------------------- - -! ------------------------------------------------ -! FUNCTION KINEMATIC -! ------------------------------------------------ - REAL FUNCTION KINEMATIC() - - IMPLICIT NONE - -! -------- DECLARATIONS ----------------------- - -! REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: OVRGH - - KINEMATIC = 1 -!---------------------------------------------------------------- - END FUNCTION KINEMATIC -!---------------------------------------------------------------- - - -! ------------------------------------------------ -! SUBROUTINE drive_CHANNEL -! ------------------------------------------------ - Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, & - QSUBRT, LAKEINFLORT, QSTRMVOLRT, TO_NODE, FROM_NODE, & - TYPEL, ORDER, MAXORDER, NLINKS, CH_NETLNK, CH_NETRT, & - LAKE_MSKRT, DT, DTCT,DTRT, MUSK, MUSX, QLINK, & - HLINK, ELRT, CHANLEN, MannN, So, ChSSlp, Bw, & - RESHT, HRZAREA, LAKEMAXH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, & - ORIFICEE, ZELEV, CVOL, NLAKES, QLAKEI, QLAKEO, LAKENODE, & - dist, QINFLOWBASE, CHANXI, CHANYJ, channel_option, RETDEP_CHAN & - ,node_area & -#ifdef MPP_LAND - ,lake_index,link_location,mpp_nlinks,nlinks_index,yw_mpp_nlinks & -#endif - ) - - IMPLICIT NONE - -! -------- DECLARATIONS ------------------------ - - INTEGER, INTENT(IN) :: IXRT,JXRT,channel_option - INTEGER, INTENT(IN) :: NLINKS,NLAKES - integer, INTENT(INOUT) :: KT ! flag of cold start (1) or continue run. - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QSUBRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKEINFLORT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: ELRT - REAL, INTENT(IN), DIMENSION(IXRT,JXRT) :: QINFLOWBASE - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT - - real , dimension(ixrt,jxrt):: latval,lonval - - INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT - INTEGER, INTENT(IN), DIMENSION(NLINKS) :: ORDER, TYPEL !--link - INTEGER, INTENT(IN), DIMENSION(NLINKS) :: TO_NODE, FROM_NODE - INTEGER, INTENT(IN), DIMENSION(NLINKS) :: CHANXI, CHANYJ - REAL, INTENT(IN), DIMENSION(NLINKS) :: ZELEV !--elevation of nodes - REAL, INTENT(INOUT), DIMENSION(NLINKS) :: CVOL - REAL, INTENT(IN), DIMENSION(NLINKS) :: MUSK, MUSX - REAL, INTENT(IN), DIMENSION(NLINKS) :: CHANLEN - REAL, INTENT(IN), DIMENSION(NLINKS) :: So, MannN - REAL, INTENT(IN), DIMENSION(NLINKS) :: ChSSlp,Bw !--properties of nodes or links - REAL :: Km, X - REAL , INTENT(INOUT), DIMENSION(NLINKS,2) :: QLINK - REAL , INTENT(INOUT), DIMENSION(NLINKS) :: HLINK - REAL, INTENT(IN) :: DT !-- model timestep - REAL, INTENT(IN) :: DTRT !-- routing timestep - REAL, INTENT(INOUT):: DTCT - REAL :: dist(ixrt,jxrt,9) - REAL :: RETDEP_CHAN - INTEGER, INTENT(IN) :: MAXORDER, SUBRTSWCRT - REAL , INTENT(IN), DIMENSION(NLINKS) :: node_area - - !-- lake params - REAL, INTENT(IN), DIMENSION(NLAKES) :: HRZAREA !-- horizontal area (km^2) - REAL, INTENT(IN), DIMENSION(NLAKES) :: LAKEMAXH !-- maximum lake depth (m^2) - REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRC !-- weir coefficient - REAL, INTENT(IN), DIMENSION(NLAKES) :: WEIRL !-- weir length (m) - REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEC !-- orrifice coefficient - REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEA !-- orrifice area (m^2) - REAL, INTENT(IN), DIMENSION(NLAKES) :: ORIFICEE !-- orrifce elevation (m) - - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: RESHT !-- reservoir height (m) - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEI !-- lake inflow (cms) - REAL, DIMENSION(NLAKES) :: QLAKEIP !-- lake inflow previous timestep (cms) - REAL, INTENT(INOUT), DIMENSION(NLAKES) :: QLAKEO !-- outflow from lake used in diffusion scheme - INTEGER, INTENT(IN), DIMENSION(NLINKS) :: LAKENODE !-- outflow from lake used in diffusion scheme - REAL, DIMENSION(NLINKS) :: QLateral !--lateral flux - REAL, DIMENSION(NLINKS) :: QSUM !--mass bal of node - REAL, DIMENSION(NLAKES) :: QLLAKE !-- lateral inflow to lake in diffusion scheme - -!-- Local Variables - INTEGER :: i,j,k,m,kk,KRT,node - INTEGER :: DT_STEPS !-- number of timestep in routing - REAL :: qu,qd !--upstream, downstream flow - REAL :: bo !--critical depth, bnd outflow just for testing - - REAL, DIMENSION(NLINKS,2) :: QLINKPREV !-- temporarily store qlink value - REAL ,DIMENSION(NLINKS) :: HLINKTMP,CVOLTMP !-- temporarily store head values and volume values - REAL ,DIMENSION(NLINKS) :: CD !-- critical depth - real, DIMENSION(IXRT,JXRT) :: tmp - real, dimension(nlinks) :: tmp2 - -#ifdef MPP_LAND - integer lake_index(nlakes) - integer nlinks_index(nlinks) - integer mpp_nlinks, iyw, yw_mpp_nlinks - integer link_location(ixrt,jxrt) - real ywtmp(ixrt,jxrt) -#endif - integer flag - - integer :: kk2 ! tmp - - QLAKEIP = 0 - QLINKPREV = 0 - HLINKTMP = 0 - CVOLTMP = 0 - CD = 0 - - node = 1 - - - QLateral = 0 - QSUM = 0 - QLLAKE = 0 - - - IF(channel_option .ne. 3) then !--muskingum methods ROUTE ON DT timestep, not DTRT!! -#ifdef MPP_LAND -#ifdef HYDRO_D - write(6,*) "Error: not parallelized" - call hydro_stop("in drive_CHANNEL") -#endif -#endif - DT_STEPS = 1 - - DO KRT=1,DT_STEPS !-- route over routing timestep - - do k = 1, NLINKS - QLateral(k)=0 !--initial lateral flux to 0 for this reach - do i = 1, IXRT - do j = 1, JXRT - !--------river grid points - !!!! IS THIS CORREECT BECAUSE CH_NETRT IS JUST A 0,1????? - if ( (CH_NETRT(i,j) .eq. k) .and. (LAKE_MSKRT(i,j) .eq. -9999)) then - !--------river grid points - !-- convert total volume into flow rate across reach (m3/sec) - !-- QSUBRT and QSTRMVOLRT are mm for the DT interval, so - !-- you need to divided by the timestep fraction and - !-- multiply by DXRT^2 1m/1000mmm/DT - QLateral(k) = QLateral(k) + ((QSUBRT(i,j)+QSTRMVOLRT(i,j))/DT_STEPS & - *dist(i,j,9)/1000/DT) + QINFLOWBASE(i,j) - elseif ( (LAKE_MSKRT(i,j) .eq. k)) then !-lake grid - !-- convert total volume into flow rate across reach (m3/sec) - QLateral(k) = QLateral(k) + (LAKEINFLORT(i,j)/DT_STEPS & - *dist(i,j,9)/1000/DT) + QINFLOWBASE(i,j) - endif - end do - end do - end do - -!---------- route order 1 reaches which have no upstream inflow - do k=1, NLINKS - if (ORDER(k) .eq. 1) then !-- first order stream has no headflow - - if (KT .eq. 1) then !-- initial slug of water in unpstream cells - qd = QLINK(k,1) - KT = KT + 1 - else - qd = QLINK(k,2) !-- downstream outflow, previous timestep - QLINK(k,1) = 0 - endif - - if(TYPEL(k) .eq. 1) then !-- level pool route of reservoir - !CALL LEVELPOOL(1,0.0, 0.0, qd, QLINK(k,2), QLateral(k), & - ! DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), & - ! WEIRC(k), WEIRL(k), ORIFICEE(i), ORIFICEC(k), ORIFICEA(k) ) - elseif (channel_option .eq. 1) then - Km = MUSK(k) - X = MUSX(k) - QLINK(k,2) = MUSKING(QLINK(k,1), QLateral(k), qd, DT, Km, X) !--current outflow - elseif (channel_option .eq. 2) then !-- upstream is assumed constant initial condition - QLINK(k,2) = MUSKINGCUNGE(k,QLINK(k,1),QLINK(k,1), qd, & - QLateral(k), DT, So(k), CHANLEN(k), & - MannN(k), ChSSLP(k), Bw(k)) - - else -#ifdef HYDRO_D - print *, "No channel option selected" - call hydro_stop("drive_CHANNEL") -#endif - endif - endif - end do - - !---------- route other reaches, with upstream inflow - do kk = 2, MAXORDER - do k = 1, NLINKS - qu = 0 - if (ORDER(k) .eq. kk) then !--do the orders sequentially - qd = QLINK(k,2) !--downstream flow previous timestep - - do m = 1, NLINKS - if (TO_NODE(m) .eq. FROM_NODE(k)) then - qu = qu + QLINK(m,2) !--upstream previous timestep - endif - end do ! do m - - - if(TYPEL(k) .eq. 1) then !--link is a reservoir - ! CALL LEVELPOOL(1,QLINK(k,1), qu, qd, QLINK(k,2), & - ! QLateral(k), DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), & - ! WEIRC(k), WEIRL(k),ORIFICEE(k), ORIFICEC(k), ORIFICEA(k)) - elseif (channel_option .eq. 1) then !muskingum routing - Km = MUSK(k) - X = MUSX(k) - QLINK(k,2) = MUSKING(QLINK(k,1),qu,qd,DT,Km,X) - elseif (channel_option .eq. 2) then ! muskingum cunge - QLINK(k,2) = MUSKINGCUNGE(k,QLINK(k,1), qu, qd, & - QLateral(k), DT, So(k), CHANLEN(k), & - MannN(k), ChSSlp(k), Bw(k) ) - else -#ifdef HYDRO_D - print *, " no channel option selected" - call hydro_stop("drive_CHANNEL") -#endif - endif - QLINK(k,1) = qu !save inflow to reach at current timestep - !to be used as inflow from previous timestep - !on next iteration - endif !--order == kk - end do !--k links - end do !--kk order - -#ifdef HYDRO_D - print *, "END OF ALL REACHES...",KRT,DT_STEPS -#endif - - END DO !-- krt timestep for muksingumcunge routing - -!yw begin - elseif(channel_option .eq. 3) then !--- route using the diffusion scheme on nodes not links - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINK,NLINKS,99) - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOL,NLINKS,99) -#endif - - KRT = 0 !-- initialize the time counter - - DTCT = min(DTCT*2.0,DTRT) -!yw DTCT = DTRT !-- initialize the routing timestep to the timestep in namelist (s) - - HLINKTMP = HLINK !-- temporary storage of the water elevations (m) - CVOLTMP = CVOL !-- temporary storage of the volume of water in channel (m^3) - QLAKEIP = QLAKEI !-- temporary lake inflow from previous timestep (cms) - -! call check_channel(77,HLINKTMP,1,nlinks) -! call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,ZELEV,NLINKS,99) -! call check_channel(78,ZELEV,1,nlinks) - - -crnt: DO !-- loop on the courant condition - QSUM = 0 !-- initialize the total flow out of each cell to zero - QLAKEI = 0 !-- set the lake inflow as zero - QLLAKE = 0 !-- initialize each lake's lateral inflow to zero - DT_STEPS=INT(DT/DTCT) !-- fix the timestep - QLateral = 0. - - -!-- vectorize -!--------------------- -#ifdef MPP_LAND - DO iyw = 1,yw_MPP_NLINKS - i = nlinks_index(iyw) -#else - DO i = 1,NLINKS -#endif - - if(node_area(i) .eq. 0) then - write(6,*) "Error: node_area(i) is zero. i=", i - call hydro_stop("drive_CHANNEL") - endif - - if((CH_NETRT(CHANXI(i), CHANYJ(i) ) .eq. 0) .and. & - (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .lt.0) ) then !--a reg. node - QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) = & -! await subsfc exchg ((QSUBRT(CHANXI(i),CHANYJ(i))+QSTRMVOLRT(CHANXI(i),CHANYJ(i))+& - ((QSTRMVOLRT(CHANXI(i),CHANYJ(i))+& - QINFLOWBASE(CHANXI(i),CHANYJ(i))) & - /DT_STEPS*node_area(i)/1000/DTCT) - if(Qlateral(CH_NETLNK(CHANXI(i),CHANYJ(i))).lt.0.) then -#ifdef HYDRO_D - print*, "i, CHANXI(i),CHANYJ(i) = ", i, CHANXI(i),CHANYJ(i) - print *, "NEGATIVE Lat inflow...",QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))), & - QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)), & - QINFLOWBASE(CHANXI(i),CHANYJ(i)) - call hydro_stop("drive_CHANNEL") -#endif - end if - elseif(LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .gt. 0 .and. & - (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .ne. -9999)) then !--a lake node - QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) = & - QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) + & - (LAKEINFLORT(CHANXI(i),CHANYJ(i))+ & - QINFLOWBASE(CHANXI(i),CHANYJ(i)) & - /DT_STEPS*node_area(i)/1000/DTCT) - elseif(CH_NETRT(CHANXI(i),CHANYJ(i)) .gt. 0) then !pour out of lake - QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) = & - QLAKEO(CH_NETRT(CHANXI(i),CHANYJ(i))) !-- previous timestep - endif - ENDDO - - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLateral,NLINKS,99) - if(NLAKES .gt. 0) then - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT ,ixrt,jxrt,QLLAKE,NLAKES,99) - endif -#endif - -! call check_channel(79,QLINK(:,1),1,nlinks) - - - !-- compute conveyances, with known depths (just assign to QLINK(,1) - !--QLINK(,2) will not be used), QLINK is the flow across the node face - !-- units should be m3/second.. consistent with QL (lateral flow) - -#ifdef MPP_LAND - DO iyw = 1,yw_MPP_NLINKS - i = nlinks_index(iyw) -#else - DO i = 1,NLINKS -#endif - if (TYPEL(i) .eq. 0 .AND. HLINKTMP(FROM_NODE(i)) .gt. RETDEP_CHAN) then - if(from_node(i) .ne. to_node(i) .and. (to_node(i) .gt. 0) .and.(from_node(i) .gt. 0) ) & ! added by Wei Yu - QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & - HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & - CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) - else !-- we are just computing critical depth for outflow points - QLINK(i,1) =0. - endif - ENDDO - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99) -#endif -! call check_lake(80,QLLAKE,lake_index,nlakes) -! call check_channel(81,QLINK(:,1),1,nlinks) -! call check_channel(82,HLINKTMP,1,nlinks) -! call check_channel(89,HLINKTMP,1,nlinks) -! call check_channel(83,CHANLEN,1,nlinks) -! call check_channel(84,MannN,1,nlinks) -! call check_channel(85,Bw,1,nlinks) -! call check_channel(86,ChSSlp,1,nlinks) -! call check_channel(87,TYPEL*1.0,1,nlinks) - - - !-- compute total flow across face, into node -#ifdef MPP_LAND - DO iyw = 1,yw_mpp_nlinks - i = nlinks_index(iyw) -#else - DO i = 1,NLINKS !-- inflow to node across each face -#endif - if(TYPEL(i) .eq. 0) then !-- only regular nodes have to attribute - QSUM(TO_NODE(i)) = QSUM(TO_NODE(i)) + QLINK(i,1) - endif - END DO - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,0) -#endif - -! call check_channel(79,TYPEL*1.0,1,nlinks) - -! call check_channel(80,QLINK(:,1),1,nlinks) - -! call check_channel(89,qsum,1,nlinks) - - - -#ifdef MPP_LAND - DO iyw = 1,yw_mpp_nlinks - i = nlinks_index(iyw) -#else - DO i = 1,NLINKS !-- outflow from node across each face -#endif - QSUM(FROM_NODE(i)) = QSUM(FROM_NODE(i)) - QLINK(i,1) - END DO -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,99) -#endif -! call check_channel(89,qsum,1,nlinks) - - - flag = 99 - - -#ifdef MPP_LAND - DO iyw = 1,yw_MPP_NLINKS - i = nlinks_index(iyw) -#else - DO i = 1, NLINKS !--- compute volume and depth at each node -#endif - - if( TYPEL(i).eq.0 .and. CVOLTMP(i) .ge. 0.001 .and.(CVOLTMP(i)-QSUM(i)*DTCT)/CVOLTMP(i) .le. -0.01 ) then - flag = -99 -#ifdef HYDRO_D - write(6,*) "******* start diag ***************" - write(6,*) "Unstable at node ",i, "i=",CHANXI(i),"j=",CHANYJ(i) - write(6,*) "Unstatble at node ",i, "lat=",latval(CHANXI(i),CHANYJ(i)), "lon=",lonval(CHANXI(i),CHANYJ(i)) - write(6,*) "TYPEL, CVOLTMP, QSUM, QSUM*DTCT",TYPEL(i), CVOLTMP(i), QSUM(i), QSUM(i)*DTCT - write(6,*) "qsubrt, qstrmvolrt,qlink",QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)),qlink(i,1),qlink(i,2) -! write(6,*) "current nodes, z, h", ZELEV(FROM_NODE(i)),HLINKTMP(FROM_NODE(i)) -! if(TO_NODE(i) .gt. 0) then -! write(6,*) "to nodes, z, h", ZELEV(TO_NODE(i)), HLINKTMP(TO_NODE(i)) -! else -! write(6,*) "no to nodes " -! endif - write(6,*) "CHANLEN(i), MannN(i), Bw(i), ChSSlp(i) ", CHANLEN(i), MannN(i), Bw(i), ChSSlp(i) - write(6,*) "*******end of diag ***************" -#endif - - goto 999 - endif - enddo - -999 continue -#ifdef MPP_LAND - call mpp_same_int1(flag) -#endif - - - if(flag < 0 .and. DTCT >0.1) then - - ! call smoth121(HLINK,nlinks,maxv_p,pnode,to_node) - - if(DTCT .gt. 0.001) then !-- timestep in seconds - DTCT = max(DTCT/2 ,0.1) !-- 1/2 timestep - KRT = 0 !-- restart counter - HLINKTMP = HLINK !-- set head and vol to start value of timestep - CVOLTMP = CVOL - CYCLE crnt !-- start cycle over with smaller timestep - else -#ifdef HYDRO_D - write(6,*) "Error ..... with small DTCT",DTCT - call hydro_stop("drive_CHANNEL") -#endif - DTCT = 0.1 - HLINKTMP = HLINK !-- set head and volume to start values of timestep - CVOLTMP = CVOL - goto 998 - end if - endif - -998 continue - - -#ifdef MPP_LAND - DO iyw = 1,yw_MPP_NLINKS - i = nlinks_index(iyw) -#else - DO i = 1, NLINKS !--- compute volume and depth at each node -#endif - - if(TYPEL(i) .eq. 0) then !-- regular channel grid point, compute volume - CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) )* DTCT - if(CVOLTMP(i) .lt. 0) then -#ifdef HYDRO_D - print *, "warning! channel volume less than 0:i,CVOL,QSUM,QLat", & - i, CVOLTMP(i),QSUM(i),QLateral(i),HLINK(i) -#endif - CVOLTMP(i) =0 - endif - - elseif(TYPEL(i) .eq. 1) then !-- pour point, critical depth downstream - - if (QSUM(i)+QLateral(i) .lt. 0) then - else - -!DJG remove to have const. flux b.c.... CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) - CD(i) = HLINKTMP(i) !This is a temp hardwire for flow depth for the pour point... - endif - - ! change in volume is inflow, lateral flow, and outflow - !yw DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*DXRT),HLINKTMP(i), & - CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & - DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & - CD(i),CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT - elseif (TYPEL(i) .eq. 2) then !--- into a reservoir, assume critical depth - if (QSUM(i)+QLateral(i) .lt. 0) then -#ifdef HYDRO_D - print *, i, 'CrtDpth Qsum+QLat into lake< 0',QSUM(i), QLateral(i) -#endif - else -!DJG remove to have const. flux b.c.... CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i)) - CD(i) = HLINKTMP(i) !This is a temp hardwire for flow depth for the pour point... - endif - - !-- compute volume in reach (m^3) - CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - & - DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), & - CD(i) ,CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT - !-- compute flow rate into lake from all contributing nodes (cms) - QLAKEI(LAKENODE(i)) = QLAKEI(LAKENODE(i)) + QLINK(FROM_NODE(i),1) - - else -#ifdef HYDRO_D - print *, "this node does not have a type.. error TYPEL =", TYPEL(i) - call hydro_stop("drive_CHANNEL") -#endif - endif - - if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow - HLINKTMP(i) = HEAD(i, CVOLTMP(i)/CHANLEN(i),Bw(i),1/ChSSlp(i)) !--updated depth - else - HLINKTMP(i) = CD(i) !!! CRITICALDEPTH(i,QSUM(i)+QLateral(i), Bw(i), 1./ChSSlp(i)) !--critical depth is head - endif - - END DO !--- done processing all the links - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOLTMP,NLINKS,99) - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CD,NLINKS,99) - if(NLAKES .gt. 0) then - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) - endif - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINKTMP,NLINKS,99) -#endif -! call check_channel(83,CVOLTMP,1,nlinks) -! call check_channel(84,CD,1,nlinks) -! call check_channel(85,HLINKTMP,1,nlinks) -! call check_lake(86,QLAKEI,lake_index,nlakes) - -! call hydro_stop("88888888") - - - - - do i = 1, NLAKES !-- mass balances of lakes -#ifdef MPP_LAND - if(lake_index(i) .gt. 0) then -#endif - CALL LEVELPOOL(i,QLAKEIP(i), QLAKEI(i), QLAKEO(i), QLLAKE(i), & - DTCT, RESHT(i), HRZAREA(i), LAKEMAXH(i), WEIRC(i), & - WEIRL(i), ORIFICEE(i), ORIFICEC(i), ORIFICEA(i)) - QLAKEIP(i) = QLAKEI(i) !-- store total lake inflow for this timestep -#ifdef MPP_LAND - endif -#endif - enddo -#ifdef MPP_LAND - if(NLAKES .gt. 0) then - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT ,ixrt,jxrt,QLLAKE,NLAKES,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,RESHT,NLAKES,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEO,NLAKES,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99) - call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEIP,NLAKES,99) - endif -#endif - - -#ifdef MPP_LAND - DO iyw = 1,yw_MPP_NLINKS - i = nlinks_index(iyw) -#else - DO i = 1, NLINKS !--- compute volume and depth at each node -#endif - if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow - QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), & - HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), & - CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) - endif - enddo - -#ifdef MPP_LAND - call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99) -#endif - - KRT = KRT + 1 !-- iterate on the timestep - IF(KRT .eq. DT_STEPS) EXIT crnt !-- up to the maximum time in interval - - END DO crnt !--- DTCT timestep of DT_STEPS - - HLINK = HLINKTMP !-- update head based on final solution in timestep - CVOL = CVOLTMP !-- update volume - else !-- no channel option apparently selected -#ifdef HYDRO_D - print *, "no channel option selected" - call hydro_stop("drive_CHANNEL") -#endif - endif - -#ifdef HYDRO_D - write(6,*) "finished call drive_CHANNEL" -#endif - - if (KT .eq. 1) KT = KT + 1 - - - END SUBROUTINE drive_CHANNEL -! ---------------------------------------------------------------- - -!--================== utility functions - REAL FUNCTION SHAPE(Bw,z,h) - REAL :: Bw, z, h - REAL :: sh1, sh2, sh3 - !---trapezoidal channel shape function - sh1 = (Bw+2*z*h)*(5*Bw + 6*h*sqrt(1+z**2)) - sh2 = 4*z*h**2*sqrt(1+z**2) - sh3 = (3*h*(Bw+z*h)*(Bw+2*h*sqrt(1+z**2))) - if (sh3 .eq. 0) then - SHAPE = 0 - else - SHAPE = (sh1+sh2)/sh3 - endif - END FUNCTION SHAPE - - REAL FUNCTION FLOW(n,So,Bw,h,z) - REAL :: n,So, Bw, z, h - REAL :: WP, AREA - WP = Bw + 2*h*sqrt(1+h**2) !-- wetted perimeter - AREA = (Bw+z*h)*h !-- Flow area - if (WP .le.0) then -#ifdef HYDRO_D - print *, "Wetter perimeter is zero, will get divide by zero error" - call hydro_stop("in SHAPE") -#endif - else - FLOW = (1/n)*sqrt(So)*(AREA**(5./3.)/(WP**(2./3.))) - endif - END FUNCTION FLOW - -!-======================================= - REAL FUNCTION AREAf(AREA,Bw,h,z) - REAL :: AREA, Bw, z, h - AREAf = (Bw+z*h)*h-AREA !-- Flow area - END FUNCTION AREAf - -!-====critical depth function ========== - REAL FUNCTION CDf(Q,Bw,h,z) - REAL :: Q, Bw, z, h - if(h .le. 0) then -#ifdef HYDRO_D - print *, "head is zero, will get division by zero error" - call hydro_stop("in AREAf") -#endif - else - CDf = (Q/((Bw+z*h)*h))/(sqrt(9.81*(((Bw+z*h)*h)/(Bw+2*z*h))))-1 !--critical depth function - endif - END FUNCTION CDf - -!=======find flow depth in channel with bisection Chapra pg. 131 - REAL FUNCTION HEAD(index,AREA,Bw,z) !-- find the water elevation given wetted area, - !--bottom widith and side channel.. index was for debuggin - REAL :: Bw,z,AREA,test - REAL :: hl, hu, hr, hrold - REAL :: fl, fr,error !-- function evaluation - INTEGER :: maxiter,index - - error = 1.0 - maxiter = 0 - hl = 0.00001 !-- minimum depth is small - hu = 30. !-- assume maximum depth is 30 meters - - if (AREA .lt. 0.00001) then - hr = 0. - else - do while ((AREAf(AREA,BW,hl,z)*AREAf(AREA,BW,hu,z)).gt.0 .and. maxiter .lt. 100) - !-- allows for larger , smaller heads - if(AREA .lt. 1.) then - hl=hl/2 - else - hu = hu * 2 - endif - maxiter = maxiter + 1 - - end do - - maxiter =0 - hr = 0 - fl = AREAf(AREA,Bw,hl,z) - do while (error .gt. 0.0001 .and. maxiter < 1000) - hrold = hr - hr = (hl+hu)/2 - fr = AREAf(AREA,Bw,hr,z) - maxiter = maxiter + 1 - if (hr .ne. 0) then - error = abs((hr - hrold)/hr) - endif - test = fl * fr - if (test.lt.0) then - hu = hr - elseif (test.gt.0) then - hl=hr - fl = fr - else - error = 0.0 - endif - end do - endif - HEAD = hr - -22 format("i,hl,hu,Area",i5,2x,f12.8,2x,f6.3,2x,f6.3,2x,f6.3,2x,f9.1,2x,i5) - - END FUNCTION HEAD -!================================= - REAL FUNCTION MANNING(h1,n,Bw,Cs) - - REAL :: Bw,h1,Cs,n - REAL :: z, AREA,R,Kd - - z=1/Cs - R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z**2)) !-- Hyd Radius - AREA = (Bw+z*h1)*h1 !-- Flow area - Kd = (1/n)*(R**(2./3.))*AREA !-- convenyance -#ifdef HYDRO_D - print *,"head, kd", h1,Kd -#endif - MANNING = Kd - - END FUNCTION MANNING - -!=======find flow depth in channel with bisection Chapra pg. 131 - REAL FUNCTION CRITICALDEPTH(lnk,Q,Bw,z) !-- find the critical depth - REAL :: Bw,z,Q,test - REAL :: hl, hu, hr, hrold - REAL :: fl, fr,error !-- function evaluation - INTEGER :: maxiter - INTEGER :: lnk - - error = 1.0 - maxiter = 0 - hl = 1e-5 !-- minimum depth is 0.00001 meters -! hu = 35. !-- assume maximum critical depth 25 m - hu = 100. !-- assume maximum critical depth 25 m - - if(CDf(Q,BW,hl,z)*CDf(Q,BW,hu,z) .gt. 0) then - if(Q .gt. 0.001) then -#ifdef HYDRO_D - print *, "interval won't work to find CD of lnk ", lnk - print *, "Q, hl, hu", Q, hl, hu - print *, "cd lwr, upr", CDf(Q,BW,hl,z), CDf(Q,BW,hu,z) - ! call hydro_stop("in CRITICALDEPTH") - CRITICALDEPTH = -9999 - return -#endif - else - Q = 0.0 - endif - endif - - hr = 0. - fl = CDf(Q,Bw,hl,z) - - if (Q .eq. 0.) then - hr = 0. - else - do while (error .gt. 0.0001 .and. maxiter < 1000) - hrold = hr - hr = (hl+hu)/2 - fr = CDf(Q,Bw,hr,z) - maxiter = maxiter + 1 - if (hr .ne. 0) then - error = abs((hr - hrold)/hr) - endif - test = fl * fr - if (test.lt.0) then - hu = hr - elseif (test.gt.0) then - hl=hr - fl = fr - else - error = 0.0 - endif - - end do - endif - - CRITICALDEPTH = hr - - END FUNCTION CRITICALDEPTH -!================================================ - REAL FUNCTION SGNf(val) !-- function to return the sign of a number - REAL:: val - - if (val .lt. 0) then - SGNf= -1. - elseif (val.gt.0) then - SGNf= 1. - else - SGNf= 0. - endif - - END FUNCTION SGNf -!================================================ - - REAL FUNCTION fnDX(qp,Tw,So,Ck,dx,dt) !-- find channel sub-length for MK method - REAL :: qp,Tw,So,Ck,dx, dt,test - REAL :: dxl, dxu, dxr, dxrold - REAL :: fl, fr, error - REAL :: X - INTEGER :: maxiter - - error = 1.0 - maxiter =0 - dxl = dx*0.9 !-- how to choose dxl??? - dxu = dx - dxr=0 - - do while (fnDXCDT(qp,Tw,So,Ck,dxl,dt)*fnDXCDT(qp,Tw,So,Ck,dxu,dt) .gt. 0 & - .and. dxl .gt. 10) !-- don't let dxl get too small - dxl = dxl/1.1 - end do - - - fl = fnDXCDT(qp,Tw,So,Ck,dxl,dt) - do while (error .gt. 0.0001 .and. maxiter < 1000) - dxrold = dxr - dxr = (dxl+dxu)/2 - fr = fnDXCDT(qp,Tw,So,Ck,dxr,dt) - maxiter = maxiter + 1 - if (dxr .ne. 0) then - error = abs((dxr - dxrold)/dxr) - endif - test = fl * fr - if (test.lt.0) then - dxu = dxr - elseif (test.gt.0) then - dxl=dxr - fl = fr - else - error = 0.0 - endif - end do - FnDX = dxr - - END FUNCTION fnDX -!================================================ - REAL FUNCTION fnDXCDT(qp,Tw,So,Ck,dx,dt) !-- function to help find sub-length for MK method - REAL :: qp,Tw,So,Ck,dx,dt,X - REAL :: c,b !-- coefficients on dx/cdt log approximation function - - c = 0.2407 - b = 1.16065 - X = 0.5-(qp/(2*Tw*So*Ck*dx)) - if (X .le.0) then - fnDXCDT = -1 !0.115 - else - fnDXCDT = (dx/(Ck*dt)) - (c*LOG(X)+b) !-- this function needs to converge to 0 - endif - END FUNCTION fnDXCDT -! ---------------------------------------------------------------------- - - subroutine check_lake(unit,cd,lake_index,nlakes) - use module_RT_data, only: rt_domain - implicit none - integer :: unit,nlakes,i,lake_index(nlakes) - real cd(nlakes) -#ifdef MPP_LAND - call write_lake_real(cd,lake_index,nlakes) -#endif - write(unit,*) cd - flush(unit) - return - end subroutine check_lake - - subroutine check_channel(unit,cd,did,nlinks) - use module_RT_data, only: rt_domain -#ifdef MPP_LAND - USE module_mpp_land -#endif - implicit none - integer :: unit,nlinks,i, did - real cd(nlinks) -#ifdef MPP_LAND - real g_cd(rt_domain(did)%gnlinks) - call write_chanel_real(cd,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,nlinks,g_cd) - if(my_id .eq. IO_id) then - write(unit,*) "rt_domain(did)%gnlinks = ",rt_domain(did)%gnlinks - write(unit,*) g_cd - endif -#else - write(unit,*) cd -#endif - flush(unit) - close(unit) - return - end subroutine check_channel - subroutine smoth121(var,nlinks,maxv_p,from_node,to_node) - implicit none - integer,intent(in) :: nlinks, maxv_p - integer, intent(in), dimension(nlinks):: to_node - integer, intent(in), dimension(nlinks):: from_node(nlinks,maxv_p) - real, intent(inout), dimension(nlinks) :: var - real, dimension(nlinks) :: vartmp - integer :: i,j , k, from,to - integer :: plen - vartmp = 0 - do i = 1, nlinks - to = to_node(i) - plen = from_node(i,1) - if(plen .gt. 1) then - do k = 1, plen-1 - from = from_node(i,k+1) - if(to .gt. 0) then - vartmp(i) = vartmp(i)+0.25*(var(from)+2.*var(i)+var(to)) - else - vartmp(i) = vartmp(i)+(2.*var(i)+var(from))/3.0 - endif - end do - vartmp(i) = vartmp(i) /(plen-1) - else - if(to .gt. 0) then - vartmp(i) = vartmp(i)+(2.*var(i)+var(to)/3.0) - else - vartmp(i) = var(i) - endif - endif - end do - var = vartmp - return - end subroutine smoth121 -END MODULE module_channel_routing diff --git a/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F b/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F deleted file mode 100644 index 4ec65dd9..00000000 --- a/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F +++ /dev/null @@ -1,1040 +0,0 @@ -module Module_Date_utilities_rt -contains - subroutine geth_newdate (ndate, odate, idt) - implicit none - - ! From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and - ! delta-time, compute the new date. - - ! on entry - odate - the old hdate. - ! idt - the change in time - - ! on exit - ndate - the new hdate. - - integer, intent(in) :: idt - character (len=*), intent(out) :: ndate - character (len=*), intent(in) :: odate - - ! Local Variables - - ! yrold - indicates the year associated with "odate" - ! moold - indicates the month associated with "odate" - ! dyold - indicates the day associated with "odate" - ! hrold - indicates the hour associated with "odate" - ! miold - indicates the minute associated with "odate" - ! scold - indicates the second associated with "odate" - - ! yrnew - indicates the year associated with "ndate" - ! monew - indicates the month associated with "ndate" - ! dynew - indicates the day associated with "ndate" - ! hrnew - indicates the hour associated with "ndate" - ! minew - indicates the minute associated with "ndate" - ! scnew - indicates the second associated with "ndate" - - ! mday - a list assigning the number of days in each month - - ! i - loop counter - ! nday - the integer number of days represented by "idt" - ! nhour - the integer number of hours in "idt" after taking out - ! all the whole days - ! nmin - the integer number of minutes in "idt" after taking out - ! all the whole days and whole hours. - ! nsec - the integer number of minutes in "idt" after taking out - ! all the whole days, whole hours, and whole minutes. - - integer :: newlen, oldlen - integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew - integer :: yrold, moold, dyold, hrold, miold, scold, frold - integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc - logical :: opass - character (len=10) :: hfrc - character (len=1) :: sp - logical :: punct - integer :: yrstart, yrend, mostart, moend, dystart, dyend - integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart - integer :: units - integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) - - ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...." - if (odate(5:5) == "-") then - punct = .TRUE. - else - punct = .FALSE. - endif - - ! Break down old hdate into parts - - hrold = 0 - miold = 0 - scold = 0 - frold = 0 - oldlen = LEN(odate) - if (punct) then - yrstart = 1 - yrend = 4 - mostart = 6 - moend = 7 - dystart = 9 - dyend = 10 - hrstart = 12 - hrend = 13 - mistart = 15 - miend = 16 - scstart = 18 - scend = 19 - frstart = 21 - select case (oldlen) - case (10) - ! Days - units = 1 - case (13) - ! Hours - units = 2 - case (16) - ! Minutes - units = 3 - case (19) - ! Seconds - units = 4 - case (21) - ! Tenths - units = 5 - case (22) - ! Hundredths - units = 6 - case (23) - ! Thousandths - units = 7 - case (24) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - call hydro_stop("geth_newdate") -#endif - end select - - if (oldlen.ge.11) then - sp = odate(11:11) - else - sp = ' ' - end if - - else - - yrstart = 1 - yrend = 4 - mostart = 5 - moend = 6 - dystart = 7 - dyend = 8 - hrstart = 9 - hrend = 10 - mistart = 11 - miend = 12 - scstart = 13 - scend = 14 - frstart = 15 - - select case (oldlen) - case (8) - ! Days - units = 1 - case (10) - ! Hours - units = 2 - case (12) - ! Minutes - units = 3 - case (14) - ! Seconds - units = 4 - case (15) - ! Tenths - units = 5 - case (16) - ! Hundredths - units = 6 - case (17) - ! Thousandths - units = 7 - case (18) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - call hydro_stop("geth_newdate") -#endif - end select - endif - - ! Use internal READ statements to convert the CHARACTER string - ! date into INTEGER components. - - read(odate(yrstart:yrend), '(i4)') yrold - read(odate(mostart:moend), '(i2)') moold - read(odate(dystart:dyend), '(i2)') dyold - if (units.ge.2) then - read(odate(hrstart:hrend),'(i2)') hrold - if (units.ge.3) then - read(odate(mistart:miend),'(i2)') miold - if (units.ge.4) then - read(odate(scstart:scend),'(i2)') scold - if (units.ge.5) then - read(odate(frstart:oldlen),*) frold - end if - end if - end if - end if - - ! Set the number of days in February for that year. - - mday(2) = nfeb(yrold) - - ! Check that ODATE makes sense. - - opass = .TRUE. - - ! Check that the month of ODATE makes sense. - - if ((moold.gt.12).or.(moold.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold -#endif - opass = .FALSE. - end if - - ! Check that the day of ODATE makes sense. - - if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold -#endif - opass = .FALSE. - end if - - ! Check that the hour of ODATE makes sense. - - if ((hrold.gt.23).or.(hrold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold -#endif - opass = .FALSE. - end if - - ! Check that the minute of ODATE makes sense. - - if ((miold.gt.59).or.(miold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold -#endif - opass = .FALSE. - end if - - ! Check that the second of ODATE makes sense. - - if ((scold.gt.59).or.(scold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold -#endif - opass = .FALSE. - end if - - ! Check that the fractional part of ODATE makes sense. - - - if (.not.opass) then -#ifdef HYDRO_D - write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen - stop -#endif - end if - - ! Date Checks are completed. Continue. - - - ! Compute the number of days, hours, minutes, and seconds in idt - - if (units.ge.5) then !idt should be in fractions of seconds - ifrc = oldlen-(frstart)+1 - ifrc = 10**ifrc - nday = abs(idt)/(86400*ifrc) - nhour = mod(abs(idt),86400*ifrc)/(3600*ifrc) - nmin = mod(abs(idt),3600*ifrc)/(60*ifrc) - nsec = mod(abs(idt),60*ifrc)/(ifrc) - nfrac = mod(abs(idt), ifrc) - else if (units.eq.4) then !idt should be in seconds - ifrc = 1 - nday = abs(idt)/86400 ! integer number of days in delta-time - nhour = mod(abs(idt),86400)/3600 - nmin = mod(abs(idt),3600)/60 - nsec = mod(abs(idt),60) - nfrac = 0 - else if (units.eq.3) then !idt should be in minutes - ifrc = 1 - nday = abs(idt)/1440 ! integer number of days in delta-time - nhour = mod(abs(idt),1440)/60 - nmin = mod(abs(idt),60) - nsec = 0 - nfrac = 0 - else if (units.eq.2) then !idt should be in hours - ifrc = 1 - nday = abs(idt)/24 ! integer number of days in delta-time - nhour = mod(abs(idt),24) - nmin = 0 - nsec = 0 - nfrac = 0 - else if (units.eq.1) then !idt should be in days - ifrc = 1 - nday = abs(idt) ! integer number of days in delta-time - nhour = 0 - nmin = 0 - nsec = 0 - nfrac = 0 - else -#ifdef HYDRO_D - write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & - oldlen - write(*,*) '#'//odate(1:oldlen)//'#' - call hydro_stop("geth_newdate") -#endif - end if - - if (idt.ge.0) then - - frnew = frold + nfrac - if (frnew.ge.ifrc) then - frnew = frnew - ifrc - nsec = nsec + 1 - end if - - scnew = scold + nsec - if (scnew .ge. 60) then - scnew = scnew - 60 - nmin = nmin + 1 - end if - - minew = miold + nmin - if (minew .ge. 60) then - minew = minew - 60 - nhour = nhour + 1 - end if - - hrnew = hrold + nhour - if (hrnew .ge. 24) then - hrnew = hrnew - 24 - nday = nday + 1 - end if - - dynew = dyold - monew = moold - yrnew = yrold - do i = 1, nday - dynew = dynew + 1 - if (dynew.gt.mday(monew)) then - dynew = dynew - mday(monew) - monew = monew + 1 - if (monew .gt. 12) then - monew = 1 - yrnew = yrnew + 1 - ! If the year changes, recompute the number of days in February - mday(2) = nfeb(yrnew) - end if - end if - end do - - else if (idt.lt.0) then - - frnew = frold - nfrac - if (frnew .lt. 0) then - frnew = frnew + ifrc - nsec = nsec + 1 - end if - - scnew = scold - nsec - if (scnew .lt. 00) then - scnew = scnew + 60 - nmin = nmin + 1 - end if - - minew = miold - nmin - if (minew .lt. 00) then - minew = minew + 60 - nhour = nhour + 1 - end if - - hrnew = hrold - nhour - if (hrnew .lt. 00) then - hrnew = hrnew + 24 - nday = nday + 1 - end if - - dynew = dyold - monew = moold - yrnew = yrold - do i = 1, nday - dynew = dynew - 1 - if (dynew.eq.0) then - monew = monew - 1 - if (monew.eq.0) then - monew = 12 - yrnew = yrnew - 1 - ! If the year changes, recompute the number of days in February - mday(2) = nfeb(yrnew) - end if - dynew = mday(monew) - end if - end do - end if - - ! Now construct the new mdate - - newlen = LEN(ndate) - - if (punct) then - - if (newlen.gt.frstart) then - write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew - write(hfrc,'(i10)') frnew+1000000000 - ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) - - else if (newlen.eq.scend) then - write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew -19 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2) - - else if (newlen.eq.miend) then - write(ndate,16) yrnew, monew, dynew, hrnew, minew -16 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2) - - else if (newlen.eq.hrend) then - write(ndate,13) yrnew, monew, dynew, hrnew -13 format(i4,'-',i2.2,'-',i2.2,'_',i2.2) - - else if (newlen.eq.dyend) then - write(ndate,10) yrnew, monew, dynew -10 format(i4,'-',i2.2,'-',i2.2) - - end if - - else - - if (newlen.gt.frstart) then - write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew - write(hfrc,'(i10)') frnew+1000000000 - ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) - - else if (newlen.eq.scend) then - write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew -119 format(i4,i2.2,i2.2,i2.2,i2.2,i2.2) - - else if (newlen.eq.miend) then - write(ndate,116) yrnew, monew, dynew, hrnew, minew -116 format(i4,i2.2,i2.2,i2.2,i2.2) - - else if (newlen.eq.hrend) then - write(ndate,113) yrnew, monew, dynew, hrnew -113 format(i4,i2.2,i2.2,i2.2) - - else if (newlen.eq.dyend) then - write(ndate,110) yrnew, monew, dynew -110 format(i4,i2.2,i2.2) - - end if - - endif - - if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp - - end subroutine geth_newdate - - subroutine geth_idts (newdate, olddate, idt) - - implicit none - - ! From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'), - ! compute the time difference. - - ! on entry - newdate - the new hdate. - ! olddate - the old hdate. - - ! on exit - idt - the change in time. - ! Units depend on length of date strings. - - character (len=*) , intent(in) :: newdate, olddate - integer , intent(out) :: idt - - - ! Local Variables - - ! yrnew - indicates the year associated with "ndate" - ! yrold - indicates the year associated with "odate" - ! monew - indicates the month associated with "ndate" - ! moold - indicates the month associated with "odate" - ! dynew - indicates the day associated with "ndate" - ! dyold - indicates the day associated with "odate" - ! hrnew - indicates the hour associated with "ndate" - ! hrold - indicates the hour associated with "odate" - ! minew - indicates the minute associated with "ndate" - ! miold - indicates the minute associated with "odate" - ! scnew - indicates the second associated with "ndate" - ! scold - indicates the second associated with "odate" - ! i - loop counter - ! mday - a list assigning the number of days in each month - - ! ndate, odate: local values of newdate and olddate - character(len=24) :: ndate, odate - - integer :: oldlen, newlen - integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew - integer :: yrold, moold, dyold, hrold, miold, scold, frold - integer :: i, newdys, olddys - logical :: npass, opass - integer :: timesign - integer :: ifrc - integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) - logical :: punct - integer :: yrstart, yrend, mostart, moend, dystart, dyend - integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart - integer :: units - - oldlen = len(olddate) - newlen = len(newdate) - if (newlen.ne.oldlen) then -#ifdef HYDRO_D - write(*,'("GETH_IDTS: NEWLEN /= OLDLEN: ", A, 3x, A)') newdate(1:newlen), olddate(1:oldlen) - call hydro_stop("geth_newdate") -#endif - endif - - if (olddate.gt.newdate) then - timesign = -1 - - ifrc = oldlen - oldlen = newlen - newlen = ifrc - - ndate = olddate - odate = newdate - else - timesign = 1 - ndate = newdate - odate = olddate - end if - - ! Break down old hdate into parts - - ! Determine if olddate is punctuated or not - if (odate(5:5) == "-") then - punct = .TRUE. - if (ndate(5:5) /= "-") then -#ifdef HYDRO_D - write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') & - ndate(1:newlen), odate(1:oldlen) - call hydro_stop("geth_idts") -#endif - endif - else - punct = .FALSE. - if (ndate(5:5) == "-") then -#ifdef HYDRO_D - write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') & - ndate(1:newlen), odate(1:oldlen) - call hydro_stop("geth_idts") -#endif - endif - endif - - if (punct) then - yrstart = 1 - yrend = 4 - mostart = 6 - moend = 7 - dystart = 9 - dyend = 10 - hrstart = 12 - hrend = 13 - mistart = 15 - miend = 16 - scstart = 18 - scend = 19 - frstart = 21 - select case (oldlen) - case (10) - ! Days - units = 1 - case (13) - ! Hours - units = 2 - case (16) - ! Minutes - units = 3 - case (19) - ! Seconds - units = 4 - case (21) - ! Tenths - units = 5 - case (22) - ! Hundredths - units = 6 - case (23) - ! Thousandths - units = 7 - case (24) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_idts: odd length: #'//trim(odate)//'#' - call hydro_stop("geth_idts") -#endif - end select - else - - yrstart = 1 - yrend = 4 - mostart = 5 - moend = 6 - dystart = 7 - dyend = 8 - hrstart = 9 - hrend = 10 - mistart = 11 - miend = 12 - scstart = 13 - scend = 14 - frstart = 15 - - select case (oldlen) - case (8) - ! Days - units = 1 - case (10) - ! Hours - units = 2 - case (12) - ! Minutes - units = 3 - case (14) - ! Seconds - units = 4 - case (15) - ! Tenths - units = 5 - case (16) - ! Hundredths - units = 6 - case (17) - ! Thousandths - units = 7 - case (18) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_idts: odd length: #'//trim(odate)//'#' - call hydro_stop("geth_idts") -#endif - end select - endif - - - hrold = 0 - miold = 0 - scold = 0 - frold = 0 - - read(odate(yrstart:yrend), '(i4)') yrold - read(odate(mostart:moend), '(i2)') moold - read(odate(dystart:dyend), '(i2)') dyold - if (units.ge.2) then - read(odate(hrstart:hrend),'(i2)') hrold - if (units.ge.3) then - read(odate(mistart:miend),'(i2)') miold - if (units.ge.4) then - read(odate(scstart:scend),'(i2)') scold - if (units.ge.5) then - read(odate(frstart:oldlen),*) frold - end if - end if - end if - end if - - ! Break down new hdate into parts - - hrnew = 0 - minew = 0 - scnew = 0 - frnew = 0 - - read(ndate(yrstart:yrend), '(i4)') yrnew - read(ndate(mostart:moend), '(i2)') monew - read(ndate(dystart:dyend), '(i2)') dynew - if (units.ge.2) then - read(ndate(hrstart:hrend),'(i2)') hrnew - if (units.ge.3) then - read(ndate(mistart:miend),'(i2)') minew - if (units.ge.4) then - read(ndate(scstart:scend),'(i2)') scnew - if (units.ge.5) then - read(ndate(frstart:newlen),*) frnew - end if - end if - end if - end if - - ! Check that the dates make sense. - - npass = .true. - opass = .true. - - ! Check that the month of NDATE makes sense. - - if ((monew.gt.12).or.(monew.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_IDTS: Month of NDATE = ', monew -#endif - npass = .false. - end if - - ! Check that the month of ODATE makes sense. - - if ((moold.gt.12).or.(moold.lt.1)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Month of ODATE = ', moold -#endif - opass = .false. - end if - - ! Check that the day of NDATE makes sense. - - if (monew.ne.2) then - ! ...... For all months but February - if ((dynew.gt.mday(monew)).or.(dynew.lt.1)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Day of NDATE = ', dynew -#endif - npass = .false. - end if - else if (monew.eq.2) then - ! ...... For February - if ((dynew > nfeb(yrnew)).or.(dynew < 1)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Day of NDATE = ', dynew -#endif - npass = .false. - end if - endif - - ! Check that the day of ODATE makes sense. - - if (moold.ne.2) then - ! ...... For all months but February - if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Day of ODATE = ', dyold -#endif - opass = .false. - end if - else if (moold.eq.2) then - ! ....... For February - if ((dyold > nfeb(yrold)).or.(dyold < 1)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Day of ODATE = ', dyold -#endif - opass = .false. - end if - end if - - ! Check that the hour of NDATE makes sense. - - if ((hrnew.gt.23).or.(hrnew.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Hour of NDATE = ', hrnew -#endif - npass = .false. - end if - - ! Check that the hour of ODATE makes sense. - - if ((hrold.gt.23).or.(hrold.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Hour of ODATE = ', hrold -#endif - opass = .false. - end if - - ! Check that the minute of NDATE makes sense. - - if ((minew.gt.59).or.(minew.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Minute of NDATE = ', minew -#endif - npass = .false. - end if - - ! Check that the minute of ODATE makes sense. - - if ((miold.gt.59).or.(miold.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Minute of ODATE = ', miold -#endif - opass = .false. - end if - - ! Check that the second of NDATE makes sense. - - if ((scnew.gt.59).or.(scnew.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: SECOND of NDATE = ', scnew -#endif - npass = .false. - end if - - ! Check that the second of ODATE makes sense. - - if ((scold.gt.59).or.(scold.lt.0)) then -#ifdef HYDRO_D - print*, 'GETH_IDTS: Second of ODATE = ', scold -#endif - opass = .false. - end if - - if (.not. npass) then -#ifdef HYDRO_D - print*, 'Screwy NDATE: ', ndate(1:newlen) - call hydro_stop("geth_idts") -#endif - end if - - if (.not. opass) then -#ifdef HYDRO_D - print*, 'Screwy ODATE: ', odate(1:oldlen) - call hydro_stop("geth_idts") -#endif - end if - - ! Date Checks are completed. Continue. - - ! Compute number of days from 1 January ODATE, 00:00:00 until ndate - ! Compute number of hours from 1 January ODATE, 00:00:00 until ndate - ! Compute number of minutes from 1 January ODATE, 00:00:00 until ndate - - newdys = 0 - do i = yrold, yrnew - 1 - newdys = newdys + 337 + nfeb(i) - end do - - if (monew .gt. 1) then - mday(2) = nfeb(yrnew) - do i = 1, monew - 1 - newdys = newdys + mday(i) - end do - mday(2) = 28 - end if - - newdys = newdys + dynew - 1 - - ! Compute number of hours from 1 January ODATE, 00:00:00 until odate - ! Compute number of minutes from 1 January ODATE, 00:00:00 until odate - - olddys = 0 - - if (moold .gt. 1) then - mday(2) = nfeb(yrold) - do i = 1, moold - 1 - olddys = olddys + mday(i) - end do - mday(2) = 28 - end if - - olddys = olddys + dyold -1 - - ! Determine the time difference - - idt = (newdys - olddys) - if (units.ge.2) then - idt = idt*24 + (hrnew - hrold) - if (units.ge.3) then - idt = idt*60 + (minew - miold) - if (units.ge.4) then - idt = idt*60 + (scnew - scold) - if (units.ge.5) then - ifrc = oldlen-(frstart-1) - ifrc = 10**ifrc - idt = idt * ifrc + (frnew-frold) - endif - endif - endif - endif - - if (timesign .eq. -1) then - idt = idt * timesign - end if - - end subroutine geth_idts - - - integer function nfeb(year) - ! - ! Compute the number of days in February for the given year. - ! - implicit none - integer, intent(in) :: year ! Four-digit year - - nfeb = 28 ! By default, February has 28 days ... - if (mod(year,4).eq.0) then - nfeb = 29 ! But every four years, it has 29 days ... - if (mod(year,100).eq.0) then - nfeb = 28 ! Except every 100 years, when it has 28 days ... - if (mod(year,400).eq.0) then - nfeb = 29 ! Except every 400 years, when it has 29 days ... - if (mod(year,3600).eq.0) then - nfeb = 28 ! Except every 3600 years, when it has 28 days. - endif - endif - endif - endif - end function nfeb - - integer function nmdays(hdate) - ! - ! Compute the number of days in the month of given date hdate. - ! - implicit none - character(len=*), intent(in) :: hdate - - integer :: year, month - integer, dimension(12), parameter :: ndays = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /) - - read(hdate(1:7), '(I4,1x,I2)') year, month - - if (month == 2) then - nmdays = nfeb(year) - else - nmdays = ndays(month) - endif - end function nmdays - - function monthabbr_to_mm(mon) result(mm) - implicit none - - character(len=3), intent(in) :: mon - - integer :: mm - - if (mon == "Jan") then - mm = 1 - elseif (mon == "Feb") then - mm = 2 - elseif (mon == "Mar") then - mm = 3 - elseif (mon == "Apr") then - mm = 4 - elseif (mon == "May") then - mm = 5 - elseif (mon == "Jun") then - mm = 6 - elseif (mon == "Jul") then - mm = 7 - elseif (mon == "Aug") then - mm = 8 - elseif (mon == "Sep") then - mm = 9 - elseif (mon == "Oct") then - mm = 10 - elseif (mon == "Nov") then - mm = 11 - elseif (mon == "Dec") then - mm = 12 - else -#ifdef HYDRO_D - write(*, '("Function monthabbr_to_mm: mon = <",A,">")') mon - print*, "Function monthabbr_to_mm: Unrecognized mon" - call hydro_stop("monthabbr_to_mm") -#endif - endif - end function monthabbr_to_mm - - subroutine swap_date_format(indate, outdate) - implicit none - character(len=*), intent(in) :: indate - character(len=*), intent(out) :: outdate - integer :: inlen - - inlen = len(indate) - if (indate(5:5) == "-") then - select case (inlen) - case (10) - ! YYYY-MM-DD - outdate = indate(1:4)//indate(6:7)//indate(9:10) - case (13) - ! YYYY-MM-DD_HH - outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13) - case (16) - ! YYYY-MM-DD_HH:mm - outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16) - case (19) - ! YYYY-MM-DD_HH:mm:ss - outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//& - indate(18:19) - case (21,22,23,24) - ! YYYY-MM-DD_HH:mm:ss.f[f[f[f]]] - outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//& - indate(18:19)//indate(21:inlen) - case default -#ifdef HYDRO_D - write(*,'("Unrecognized length: <", A,">")') indate - call hydro_stop("swap_date_format") -#endif - end select - else - select case (inlen) - case (8) - ! YYYYMMDD - outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8) - case (10) - ! YYYYMMDDHH - outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& - indate(9:10) - case (12) - ! YYYYMMDDHHmm - outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& - indate(9:10)//":"//indate(11:12) - case (14) - ! YYYYMMDDHHmmss - outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& - indate(9:10)//":"//indate(11:12)//":"//indate(13:14) - case (15,16,17,18) - ! YYYYMMDDHHmmssf[f[f[f]]] - outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//& - indate(9:10)//":"//indate(11:12)//":"//indate(13:14)//"."//indate(15:inlen) - case default -#ifdef HYDRO_D - write(*,'("Unrecognized length: <", A,">")') indate - call hydro_stop("swap_date_format") -#endif - end select - endif - - end subroutine swap_date_format - - character(len=3) function mm_to_monthabbr(ii) result(mon) - implicit none - integer, intent(in) :: ii - character(len=3), parameter, dimension(12) :: month = (/ & - "Jan", "Feb", "Mar", "Apr", "May", "Jun", & - "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" /) - if (ii > 0 .and. ii < 13 ) then - mon = month(ii) - else -#ifdef HYDRO_D - print*, "mm_to_monthabbr" - call hydro_stop("mm_to_monthabbr") -#endif - endif - end function mm_to_monthabbr - -end module Module_Date_utilities_rt diff --git a/wrfv2_fire/hydro/Routing/module_lsm_forcing.F b/wrfv2_fire/hydro/Routing/module_lsm_forcing.F deleted file mode 100644 index f60b0493..00000000 --- a/wrfv2_fire/hydro/Routing/module_lsm_forcing.F +++ /dev/null @@ -1,2276 +0,0 @@ -module module_lsm_forcing - -#ifdef MPP_LAND - use module_mpp_land -#endif - use module_HYDRO_io, only: get_2d_netcdf, get_soilcat_netcdf, get2d_int - -implicit none -#include - integer :: i_forcing -character(len=19) out_date - -interface read_hydro_forcing -#ifdef MPP_LAND - module procedure read_hydro_forcing_mpp -#else - module procedure read_hydro_forcing_seq -#endif -end interface - -Contains - - subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar) - - implicit none - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - character(len=*), intent(in) :: target_date - real, dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc, lai,fpar - integer tlevel - - character(len=256) :: units - integer :: ierr - integer :: ncid - - tlevel = 1 - - pcp = 0 - pcpc = 0 - - ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm) -#endif - call hydro_stop("READFORC_WRF") - endif - - call get_2d_netcdf_ruc("T2", ncid, t, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("Q2", ncid, q, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("U10", ncid, u, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("V10", ncid, v, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("PSFC", ncid, p, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("GLW", ncid, lw, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("SWDOWN", ncid, sw, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("VEGFRA", ncid, fpar, ix, jx,tlevel, .true., ierr) - if(ierr == 0) then - if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar/100. - endif - call get_2d_netcdf_ruc("LAI", ncid, lai, ix, jx,tlevel, .true., ierr) - - ierr = nf_close(ncid) - - -!DJG Add the convective and non-convective rain components (note: conv. comp=0 -!for cloud resolving runs...) -!DJG Note that for WRF these are accumulated values to be adjusted to rates in -!driver... - - pcp=pcp+pcpc ! assumes pcpc=0 for resolved convection... - - end subroutine READFORC_WRF - - subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat) - ! Simply return the dimensions of the grid. - implicit none - character(len=*), intent(in) :: geo_static_flnm - integer, intent(out) :: ix, jx, land_cat, soil_cat ! dimensions - - integer :: iret, ncid, dimid - - ! Open the NetCDF file. - iret = nf_open(geo_static_flnm, NF_NOWRITE, ncid) - if (iret /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_static file: ''", A, "''")') & - trim(geo_static_flnm) -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimid(ncid, "west_east", dimid) - - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: west_east" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimlen(ncid, dimid, ix) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: west_east" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimid(ncid, "south_north", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: south_north" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimlen(ncid, dimid, jx) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: south_north" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimid(ncid, "land_cat", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: land_cat" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimlen(ncid, dimid, land_cat) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: land_cat" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimid(ncid, "soil_cat", dimid) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimid: soil_cat" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_inq_dimlen(ncid, dimid, soil_cat) - if (iret /= 0) then -#ifdef HYDRO_D - print*, "nf_inq_dimlen: soil_cat" -#endif - call hydro_stop("read_hrldas_hdrinfo") - endif - - iret = nf_close(ncid) - - end subroutine read_hrldas_hdrinfo - - - - subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp, & - terrain,latitude,longitude,SOLVEG_INITSWC) - implicit none - character(len=*), intent(in) :: geo_static_flnm - integer, intent(in) :: ix, jx, land_cat, soil_cat,SOLVEG_INITSWC - integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp - real, dimension(ix,jx), intent(out) :: terrain, latitude, longitude - - character(len=256) :: units - integer :: ierr,i,j,jj - integer :: ncid,varid - real, dimension(ix,jx) :: xdum - integer, dimension(ix,jx) :: vegtyp_inv, soiltyp_inv,xdum_int - integer flag ! flag = 1 from wrfsi, flag =2 from WPS. - CHARACTER(len=256) :: var_name - - - ! Open the NetCDF file. - ierr = nf_open(geo_static_flnm, NF_NOWRITE, ncid) - - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("Problem opening geo_static file: ''", A, "''")') trim(geo_static_flnm) -#endif - call hydro_stop("readland_hrldas") - endif - - flag = -99 - ierr = nf_inq_varid(ncid,"XLAT", varid) - flag = 1 - if(ierr .ne. 0) then - ierr = nf_inq_varid(ncid,"XLAT_M", varid) - if(ierr .ne. 0) then -#ifdef HYDRO_D - write(6,*) "XLAT not found from wrfstatic file. " -#endif - call hydro_stop("readland_hrldas") - endif - flag = 2 - endif - - ! Get Latitude (lat) - if(flag .eq. 1) then - call get_2d_netcdf("XLAT", ncid, latitude, units, ix, jx, .TRUE., ierr) - else - call get_2d_netcdf("XLAT_M", ncid, latitude, units, ix, jx, .TRUE., ierr) - endif - - ! Get Longitude (lon) - if(flag .eq. 1) then - call get_2d_netcdf("XLONG", ncid, longitude, units, ix, jx, .TRUE., ierr) - else - call get_2d_netcdf("XLONG_M", ncid, longitude, units, ix, jx, .TRUE., ierr) - endif - - ! Get Terrain (avg) - if(flag .eq. 1) then - call get_2d_netcdf("HGT", ncid, terrain, units, ix, jx, .TRUE., ierr) - else - call get_2d_netcdf("HGT_M", ncid, terrain, units, ix, jx, .TRUE., ierr) - endif - - - if (SOLVEG_INITSWC.eq.0) then -! ! Get Dominant Land Use categories (use) -! call get_landuse_netcdf(ncid, xdum , units, ix, jx, land_cat) -! vegtyp = nint(xdum) - - var_name = "LU_INDEX" - call get2d_int(var_name,xdum_int,ix,jx,& - trim(geo_static_flnm)) - vegtyp = xdum_int - - ! Get Dominant Soil Type categories in the top layer (stl) - call get_soilcat_netcdf(ncid, xdum , units, ix, jx, soil_cat) - soltyp = nint(xdum) - - else if (SOLVEG_INITSWC.eq.1) then - var_name = "VEGTYP" - call get2d_int(var_name,VEGTYP_inv,ix,jx,& - trim(geo_static_flnm)) - - var_name = "SOILTYP" - call get2d_int(var_name,SOILTYP_inv,ix,jx,& - trim(geo_static_flnm)) - do i=1,ix - jj=jx - do j=1,jx - VEGTYP(i,j)=VEGTYP_inv(i,jj) - SOLTYP(i,j)=SOILTYP_inv(i,jj) - jj=jx-j - end do - end do - - endif - - - - ! Close the NetCDF file - ierr = nf_close(ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: READLAND_HRLDAS: NF_CLOSE" -#endif - call hydro_stop("readland_hrldas") - endif - - ! Make sure vegtyp and soltyp are consistent when it comes to water points, - ! by setting soil category to water when vegetation category is water, and - ! vice-versa. - where (vegtyp == 16) soltyp = 14 - where (soltyp == 14) vegtyp = 16 - -!DJG test for deep gw function... -! where (soltyp <> 14) soltyp = 1 - - end subroutine readland_hrldas - - - subroutine get_2d_netcdf_ruc(var_name,ncid,var, & - ix,jx,tlevel,fatal_if_error,ierr) - character(len=*), intent(in) :: var_name - integer,intent(in) :: ncid,ix,jx,tlevel - real, intent(out):: var(ix,jx) - logical, intent(in) :: fatal_if_error - integer dims(4), dim_len(4) - integer ierr,iret - integer varid - integer start(4),count(4) - data count /1,1,1,1/ - data start /1,1,1,1/ - count(1) = ix - count(2) = jx - start(4) = tlevel - iret = nf_inq_varid(ncid, var_name, varid) - - if (iret /= 0) then - if (fatal_IF_ERROR) then -#ifdef HYDRO_D - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf_inq_varid ", trim(var_name) -#endif - call hydro_stop("get_2d_netcdf_ruc") - else - ierr = iret - return - endif - endif - - iret = nf_get_vara_real(ncid, varid, start,count,var) - - return - end subroutine get_2d_netcdf_ruc - - - subroutine get_2d_netcdf_cows(var_name,ncid,var, & - ix,jx,tlevel,fatal_if_error,ierr) - character(len=*), intent(in) :: var_name - integer,intent(in) :: ncid,ix,jx,tlevel - real, intent(out):: var(ix,jx) - logical, intent(in) :: fatal_if_error - integer ierr, iret - integer varid - integer start(4),count(4) - data count /1,1,1,1/ - data start /1,1,1,1/ - count(1) = ix - count(2) = jx - start(4) = tlevel - iret = nf_inq_varid(ncid, var_name, varid) - - if (iret /= 0) then - if (fatal_IF_ERROR) then -#ifdef HYDRO_D - print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid" -#endif - call hydro_stop("get_2d_netcdf_cows") - else - ierr = iret - return - endif - endif - iret = nf_get_vara_real(ncid, varid, start,count,var) - - return - end subroutine get_2d_netcdf_cows - - - - - - subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, & - smc, stc, sh2o, cmc, t1, weasd, snodep) - implicit none - character(len=*), intent(in) :: netcdf_flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - integer, intent(in) :: nsoil - character(len=*), intent(in) :: target_date - real, dimension(ix,jx,nsoil), intent(out) :: smc - real, dimension(ix,jx,nsoil), intent(out) :: stc - real, dimension(ix,jx,nsoil), intent(out) :: sh2o - real, dimension(ix,jx), intent(out) :: cmc - real, dimension(ix,jx), intent(out) :: t1 - real, dimension(ix,jx), intent(out) :: weasd - real, dimension(ix,jx), intent(out) :: snodep - - character(len=256) :: units - character(len=8) :: name - integer :: ix_read, jx_read,i,j - - integer :: ierr, ncid, ierr_snodep - integer :: idx - - logical :: found_canwat, found_skintemp, found_weasd, found_stemp, found_smois - - ! Open the NetCDF file. - ierr = nf_open(netcdf_flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READINIT Problem opening netcdf file: ''", A, "''")') & - trim(netcdf_flnm) -#endif - call hydro_stop("readinit_hrldas") - endif - - call get_2d_netcdf("CANWAT", ncid, cmc, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SKINTEMP", ncid, t1, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("WEASD", ncid, weasd, units, ix, jx, .TRUE., ierr) - - if (trim(units) == "m") then - ! No conversion necessary - else if (trim(units) == "mm") then - ! convert WEASD from mm to m - weasd = weasd * 1.E-3 - else -#ifdef HYDRO_D - print*, 'units = "'//trim(units)//'"' - print*, "Unrecognized units on WEASD" -#endif - call hydro_stop("readinit_hrldas") - endif - - call get_2d_netcdf("SNODEP", ncid, snodep, units, ix, jx, .FALSE., ierr_snodep) - call get_2d_netcdf("STEMP_1", ncid, stc(:,:,1), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("STEMP_2", ncid, stc(:,:,2), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("STEMP_3", ncid, stc(:,:,3), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("STEMP_4", ncid, stc(:,:,4), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SMOIS_1", ncid, smc(:,:,1), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SMOIS_2", ncid, smc(:,:,2), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SMOIS_3", ncid, smc(:,:,3), units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SMOIS_4", ncid, smc(:,:,4), units, ix, jx, .TRUE., ierr) - - - if (ierr_snodep /= 0) then - ! Quick assumption regarding snow depth. - snodep = weasd * 10. - endif - - -!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... - do i=1,ix - do j=1,jx - if (WEASD(i,j).lt.0.) WEASD(i,j)=0.0 !set lower bound to correct bi-lin interp err... - if (snodep(i,j).lt.0.) snodep(i,j)=0.0 !set lower bound to correct bi-lin interp err... - end do - end do - - - sh2o = smc - - ierr = nf_close(ncid) - end subroutine readinit_hrldas - - - - - subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - character(len=*), intent(in) :: target_date - real, dimension(ix,jx), intent(out) :: t - real, dimension(ix,jx), intent(out) :: q - real, dimension(ix,jx), intent(out) :: u - real, dimension(ix,jx), intent(out) :: v - real, dimension(ix,jx), intent(out) :: p - real, dimension(ix,jx), intent(out) :: lw - real, dimension(ix,jx), intent(out) :: sw - real, dimension(ix,jx), intent(out) :: pcp - real, dimension(ix,jx), intent(inout) :: lai - real, dimension(ix,jx), intent(inout) :: fpar - - character(len=256) :: units - integer :: ierr - integer :: ncid - - ! Open the NetCDF file. - ierr = nf_open(trim(flnm), NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm) -#endif - call hydro_stop("READFORC_HRLDAS") - endif - - call get_2d_netcdf("T2D", ncid, t, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("Q2D", ncid, q, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("U2D", ncid, u, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("V2D", ncid, v, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("PSFC", ncid, p, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("LWDOWN", ncid, lw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("SWDOWN", ncid, sw, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("RAINRATE",ncid, pcp, units, ix, jx, .TRUE., ierr) - call get_2d_netcdf("VEGFRA", ncid, fpar, units, ix, jx, .FALSE., ierr) - if (ierr == 0) then - if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000) fpar = fpar * 1.E-2 - endif - call get_2d_netcdf("LAI", ncid, lai, units, ix, jx, .FALSE., ierr) - - ierr = nf_close(ncid) - - end subroutine READFORC_HRLDAS - - - - subroutine READFORC_DMIP(flnm,ix,jx,var) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - real, dimension(ix,jx), intent(out) :: var - character(len=13) :: head - integer :: ncols, nrows, cellsize - real :: xllc, yllc, no_data - integer :: i,j - character(len=256) ::junk - - open (77,file=trim(flnm),form="formatted",status="old") - -! read(77,732) head,ncols -! read(77,732) head,nrows -!732 FORMAT(A13,I4) -! read(77,733) head,xllc -! read(77,733) head,yllc -!733 FORMAT(A13,F16.9) -! read(77,732) head,cellsize -! read(77,732) head,no_data - - read(77,*) junk - read(77,*) junk - read(77,*) junk - read(77,*) junk - read(77,*) junk - read(77,*) junk - - do j=jx,1,-1 - read(77,*) (var(I,J),I=1,ix) - end do - close(77) - - end subroutine READFORC_DMIP - - - - subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - integer, intent(out) :: ierr_flg - integer :: it,jew,zsn - real, dimension(ix,jx), intent(out) :: pcp - - character(len=256) :: units - integer :: ierr,i,j,i2,j2,varid - integer :: ncid,mmflag - real, dimension(ix,jx) :: temp - - mmflag = 0 ! flag for units spec. (0=mm, 1=mm/s) - - -!open NetCDF file... - ierr_flg = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr_flg /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_MDV Problem opening netcdf file: ''",A,"''")') & - trim(flnm) -#endif - return - end if - - ierr = nf_inq_varid(ncid, "precip", varid) - if(ierr /= 0) ierr_flg = ierr - if (ierr /= 0) then - ierr = nf_inq_varid(ncid, "precip_rate", varid) !recheck variable name... - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') & - trim(flnm) -#endif - end if - ierr_flg = ierr - mmflag = 1 - end if - ierr = nf_get_var_real(ncid, varid, pcp) - ierr = nf_close(ncid) - - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm) -#endif - end if - - end subroutine READFORC_MDV - - - - subroutine READFORC_NAMPCP(flnm,ix,jx,pcp,k,product) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - integer, intent(in) :: k - character(len=*), intent(in) :: product - integer :: it,jew,zsn - parameter(it = 496,jew = 449, zsn = 499) ! domain 1 -! parameter(it = 496,jew = 74, zsn = 109) ! domain 2 - real, dimension(it,jew,zsn) :: buf - real, dimension(ix,jx), intent(out) :: pcp - - character(len=256) :: units - integer :: ierr,i,j,i2,j2,varid - integer :: ncid - real, dimension(ix,jx) :: temp - -! varname = trim(product) - -!open NetCDF file... - if (k.eq.1.) then - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_NAMPCP1 Problem opening netcdf file: ''",A, "''")') & - trim(flnm) -#endif - call hydro_stop("READFORC_NAMPCP") - end if - - ierr = nf_inq_varid(ncid, trim(product), varid) - ierr = nf_get_var_real(ncid, varid, buf) - ierr = nf_close(ncid) - - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_NAMPCP2 Problem reading netcdf file: ''", A,"''")') & - trim(flnm) -#endif - call hydro_stop("READFORC_NAMPCP") - end if - endif -#ifdef HYDRO_D - print *, "Data read in...",it,ix,jx,k -#endif - -! Extract single time slice from dataset... - - do i=1,ix - do j=1,jx - pcp(i,j) = buf(k,i,j) - end do - end do - -! call get_2d_netcdf_ruc("trmm",ncid, pcp, jx, ix,k, .true., ierr) - - end subroutine READFORC_NAMPCP - - - - - subroutine READFORC_COWS(flnm,ix,jx,target_date, t,q,u,p,lw,sw,pcp,tlevel) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - character(len=*), intent(in) :: target_date - real, dimension(ix,jx), intent(out) :: t - real, dimension(ix,jx), intent(out) :: q - real, dimension(ix,jx), intent(out) :: u - real, dimension(ix,jx) :: v - real, dimension(ix,jx), intent(out) :: p - real, dimension(ix,jx), intent(out) :: lw - real, dimension(ix,jx), intent(out) :: sw - real, dimension(ix,jx), intent(out) :: pcp - integer tlevel - - character(len=256) :: units - integer :: ierr - integer :: ncid - - ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_COWS Problem opening netcdf file: ''", A, "''")') trim(flnm) -#endif - call hydro_stop("READFORC_COWS") - endif - - call get_2d_netcdf_cows("TA2", ncid, t, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("QV2", ncid, q, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("WSPD10", ncid, u, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("PRES", ncid, p, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("GLW", ncid, lw, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("RSD", ncid, sw, ix, jx,tlevel, .TRUE., ierr) - call get_2d_netcdf_cows("RAIN", ncid, pcp, ix, jx,tlevel, .TRUE., ierr) -!yw call get_2d_netcdf_cows("V2D", ncid, v, ix, jx,tlevel, .TRUE., ierr) - - ierr = nf_close(ncid) - - end subroutine READFORC_COWS - - - - - subroutine READFORC_RUC(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp) - - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - character(len=*), intent(in) :: target_date - real, dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc - integer tlevel - - character(len=256) :: units - integer :: ierr - integer :: ncid - - tlevel = 1 - - ! Open the NetCDF file. - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READFORC_RUC Problem opening netcdf file: ''", A, "''")') trim(flnm) -#endif - call hydro_stop("READFORC_RUC") - endif - - call get_2d_netcdf_ruc("T2", ncid, t, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("Q2", ncid, q, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("U10", ncid, u, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("V10", ncid, v, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("PSFC", ncid, p, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("GLW", ncid, lw, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("SWDOWN", ncid, sw, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("RAINC", ncid, pcpc, ix, jx,tlevel, .true., ierr) - call get_2d_netcdf_ruc("RAINNC", ncid, pcp, ix, jx,tlevel, .true., ierr) - - ierr = nf_close(ncid) - - -!DJG Add the convective and non-convective rain components (note: conv. comp=0 -!for cloud resolving runs...) -!DJG Note that for RUC these are accumulated values to be adjusted to rates in -!driver... - - pcp=pcp+pcpc ! assumes pcpc=0 for resolved convection... - - end subroutine READFORC_RUC - - - - - subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep) - implicit none - - character(len=*), intent(in) :: flnm - integer, intent(in) :: ix - integer, intent(in) :: jx - real, dimension(ix,jx), intent(out) :: weasd - real, dimension(ix,jx), intent(out) :: snodep - real, dimension(ix,jx) :: tmp - - character(len=256) :: units - integer :: ierr - integer :: ncid,i,j - - ! Open the NetCDF file. - - ierr = nf_open(flnm, NF_NOWRITE, ncid) - if (ierr /= 0) then -#ifdef HYDRO_D - write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm) -#endif - call hydro_stop("READSNOW_FORC") - endif - - call get_2d_netcdf("WEASD", ncid, tmp, units, ix, jx, .FALSE., ierr) - if (ierr /= 0) then - call get_2d_netcdf("SNOW", ncid, tmp, units, ix, jx, .FALSE., ierr) - if (ierr == 0) then - units = "mm" - print *, "read WEASD from wrfoutput ...... " - weasd = tmp * 1.E-3 - endif - else - weasd = tmp - if (trim(units) == "m") then - ! No conversion necessary - else if (trim(units) == "mm") then - ! convert WEASD from mm to m - weasd = weasd * 1.E-3 - endif - endif - - if (ierr /= 0) then -#ifdef HYDRO_D - print *, "!!!!! NO WEASD present in input file...initialize to 0." -#endif - endif - - - call get_2d_netcdf("SNODEP", ncid, tmp, units, ix, jx, .FALSE., ierr) - if (ierr /= 0) then - ! Quick assumption regarding snow depth. - call get_2d_netcdf("SNOWH", ncid, tmp, units, ix, jx, .FALSE., ierr) - if(ierr .eq. 0) then - print *, "read snow depth from wrfoutput ... " - snodep = tmp - endif - else - snodep = tmp - endif - - if (ierr /= 0) then - ! Quick assumption regarding snow depth. -!yw snodep = weasd * 10. - where(snodep .lt. weasd) snodep = weasd*10 !set lower bound to correct bi-lin interp err... - endif - -!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation... - where(snodep .lt. 0) snodep = 0 - where(weasd .lt. 0) weasd = 0 - -!yw do i=1,ix -!yw do j=1,jx -!yw if (WEASD(i,j).lt.0.) WEASD(i,j)=0.0 !set lower bound to correct bi-lin interp err... -!yw if (snodep(i,j).lt.0.) snodep(i,j)=0.0 !set lower bound to correct bi-lin interp err... -!yw end do -!yw end do - - ierr = nf_close(ncid) - - end subroutine READSNOW_FORC - - subroutine get2d_hrldas(inflnm,ix,jx,nsoil,smc,stc,sh2ox,cmc,t1,weasd,snodep) - implicit none - integer :: iret,varid,ncid,ix,jx,nsoil,ierr - real,dimension(ix,jx):: weasd,snodep,cmc,t1 - real,dimension(ix,jx,nsoil):: smc,stc,sh2ox - character(len=*), intent(in) :: inflnm - character(len=256):: units - iret = nf_open(trim(inflnm), NF_NOWRITE, ncid) - if(iret .ne. 0 )then -#ifdef HYDRO_D - write(6,*) "Error: failed to open file :",trim(inflnm) -#endif - call hydro_stop("get2d_hrldas") - endif - - call get2d_hrldas_real("CMC", ncid, cmc, ix, jx) - call get2d_hrldas_real("TSKIN", ncid, t1, ix, jx) - call get2d_hrldas_real("SWE", ncid, weasd, ix, jx) - call get2d_hrldas_real("SNODEP", ncid, snodep, ix, jx) - - call get2d_hrldas_real("SOIL_T_1", ncid, stc(:,:,1), ix, jx) - call get2d_hrldas_real("SOIL_T_2", ncid, stc(:,:,2), ix, jx) - call get2d_hrldas_real("SOIL_T_3", ncid, stc(:,:,3), ix, jx) - call get2d_hrldas_real("SOIL_T_4", ncid, stc(:,:,4), ix, jx) - call get2d_hrldas_real("SOIL_T_5", ncid, stc(:,:,5), ix, jx) - call get2d_hrldas_real("SOIL_T_6", ncid, stc(:,:,6), ix, jx) - call get2d_hrldas_real("SOIL_T_7", ncid, stc(:,:,7), ix, jx) - call get2d_hrldas_real("SOIL_T_8", ncid, stc(:,:,8), ix, jx) - - call get2d_hrldas_real("SOIL_M_1", ncid, SMC(:,:,1), ix, jx) - call get2d_hrldas_real("SOIL_M_2", ncid, SMC(:,:,2), ix, jx) - call get2d_hrldas_real("SOIL_M_3", ncid, SMC(:,:,3), ix, jx) - call get2d_hrldas_real("SOIL_M_4", ncid, SMC(:,:,4), ix, jx) - call get2d_hrldas_real("SOIL_M_5", ncid, SMC(:,:,5), ix, jx) - call get2d_hrldas_real("SOIL_M_6", ncid, SMC(:,:,6), ix, jx) - call get2d_hrldas_real("SOIL_M_7", ncid, SMC(:,:,7), ix, jx) - call get2d_hrldas_real("SOIL_M_8", ncid, SMC(:,:,8), ix, jx) - - call get2d_hrldas_real("SOIL_W_1", ncid, SH2OX(:,:,1), ix, jx) - call get2d_hrldas_real("SOIL_W_2", ncid, SH2OX(:,:,2), ix, jx) - call get2d_hrldas_real("SOIL_W_3", ncid, SH2OX(:,:,3), ix, jx) - call get2d_hrldas_real("SOIL_W_4", ncid, SH2OX(:,:,4), ix, jx) - call get2d_hrldas_real("SOIL_W_5", ncid, SH2OX(:,:,5), ix, jx) - call get2d_hrldas_real("SOIL_W_6", ncid, SH2OX(:,:,6), ix, jx) - call get2d_hrldas_real("SOIL_W_7", ncid, SH2OX(:,:,7), ix, jx) - call get2d_hrldas_real("SOIL_W_8", ncid, SH2OX(:,:,8), ix, jx) - - iret = nf_close(ncid) - return - end subroutine get2d_hrldas - - subroutine get2d_hrldas_real(var_name,ncid,out_buff,ix,jx) - implicit none - integer ::iret,varid,ncid,ix,jx - real out_buff(ix,jx) - character(len=*), intent(in) :: var_name - iret = nf_inq_varid(ncid,trim(var_name), varid) - iret = nf_get_var_real(ncid, varid, out_buff) - return - end subroutine get2d_hrldas_real - - subroutine read_stage4(flnm,IX,JX,pcp) - integer IX,JX,ierr,ncid,i,j - real pcp(IX,JX),buf(ix,jx) - character(len=*), intent(in) :: flnm - character(len=256) :: units - - ierr = nf_open(flnm, NF_NOWRITE, ncid) - - if(ierr .ne. 0) then - call hydro_stop("read_stage4") - endif - - call get_2d_netcdf("RAINRATE",ncid, buf, units, ix, jx, .TRUE., ierr) - ierr = nf_close(ncid) - do j = 1, jx - do i = 1, ix - if(buf(i,j) .lt. 0) then - buf(i,j) = pcp(i,j) - end if - end do - end do - pcp = buf - return - END subroutine read_stage4 - - - - - subroutine read_hydro_forcing_seq( & - indir,olddate,hgrid, & - ix,jx,forc_typ,snow_assim, & - T2,q2x,u,v,pres,xlong,short,prcp1,& - lai,fpar,snodep,dt,k,prcp_old) -! This subrouting is going to read different forcing. - implicit none - ! in variable - character(len=*) :: olddate,hgrid,indir - character(len=256) :: filename - integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop - real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& - prcpnew,weasd,snodep,prcp0,prcp2,prcp_old - real :: dt, wrf_dt - ! tmp variable - character(len=256) :: inflnm, inflnm2, product - integer :: i,j,mmflag,ierr_flg - real,dimension(ix,jx):: lai,fpar - character(len=4) nwxst_t - logical :: fexist - - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - ".LDASIN_DOMAIN"//hgrid - -!!!DJG... Call READFORC_(variable) Subroutine for forcing data... -!!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!) - if(FORC_TYP.eq.1) then -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - ".LDASIN_DOMAIN"//hgrid - - inquire (file=trim(inflnm), exist=fexist) - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no forcing data found", inflnm -#endif - call hydro_stop("read_hydro_forcing_seq") - endif - - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) - end if - - - - -!!!DJG HRLDAS Forcing with minute format filename (NOTE: precip must be in mm/s!!!) - if(FORC_TYP.eq.2) then -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".LDASIN_DOMAIN"//hgrid - inquire (file=trim(inflnm), exist=fexist) - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no forcing data found", inflnm -#endif - call hydro_stop("read_hydro_forcing_seq") - endif - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) - end if - - - - - -!!!DJG WRF Output File Direct Ingest Forcing... - if(FORC_TYP.eq.3) then -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - "wrfout_d0"//hgrid//"_"//& - olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//& - "_"//olddate(12:13)//":00:00" - - inquire (file=trim(inflnm), exist=fexist) - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no forcing data found", inflnm -#endif - call hydro_stop("read_hydro_forcing_seq") - endif - - do i_forcing = 1, int(24*3600/dt) - wrf_dt = i_forcing*dt - call geth_newdate(out_date,olddate,nint(wrf_dt)) - inflnm2 = trim(indir)//"/"//& - "wrfout_d0"//hgrid//"_"//& - out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& - "_"//out_date(12:13)//":00:00" - inquire (file=trim(inflnm2), exist=fexist) - if (fexist ) goto 991 - end do -991 continue - -#ifdef HYDRO_D - if(.not. fexist) then - write(6,*) "Error: could not find file ",trim(inflnm2) - call hydro_stop("read_hydro_forcing_seq") - endif - print*, "read WRF forcing data: ", trim(inflnm) - print*, "read WRF forcing data: ", trim(inflnm2) -#endif - CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCPnew,lai,fpar) - CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,prcp0,lai,fpar) - PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) - - end if - - - - - -!!!DJG CONSTant, idealized forcing... - if(FORC_TYP.eq.4) then -! Impose a fixed diurnal cycle... -! assumes model timestep is 1 hr -! assumes K=1 is 12z (Ks or ~ sunrise) -! First Precip... -! IF (K.GE.1 .and. K.LE.2) THEN - IF (K.EQ.1) THEN - PRCP1 =25.4/3600.0 !units mm/s (Simulates 1"/hr for first time step...) -! PRCP1 =0./3600.0 !units mm/s (Simulates 1"/hr for first time step...) - ELSEIF (K.GT.1) THEN -! PRCP1 =0./3600.0 !units mm/s -! ELSE - PRCP1 = 0. - END IF -! PRCP1 = 0. -! PRCP1 =10./3600.0 !units mm/s -! Other Met. Vars... - T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - Q2X = 0.01 - U = 1.0 - V = 1.0 - PRES = 100000.0 - XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - end if - - - - - -!!!DJG Idealized Met. w/ Specified Precip. Forcing Data...(Note: input precip units here are in 'mm/hr') -! This option uses hard-wired met forcing EXCEPT precipitation which is read in -! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' -! - if(FORC_TYP.eq.5) then -! Standard Met. Vars... - T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - Q2X = 0.01 - U = 1.0 - V = 1.0 - PRES = 100000.0 - XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0)) - -!Get specified precip.... -!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! -! product = "trmm" -! inflnm = trim(indir)//"/"//"sat_domain1.nc" -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".PRECIP_FORCING.nc" - inquire (file=trim(inflnm), exist=fexist) - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no specified precipitation data found", inflnm -#endif - call hydro_stop("read_hydro_forcing_seq") - endif - - PRCP1 = 0. - PRCP_old = PRCP1 - -#ifdef HYDRO_D - print *, "Opening supplemental precipitation forcing file...",inflnm -#endif - CALL READFORC_MDV(inflnm,IX,JX, & - PRCP2,mmflag,ierr_flg) - -!If radar or spec. data is ok use if not, skip to original NARR data... - IF (ierr_flg.eq.0) then ! use spec. precip -!Convert units if necessary - IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... - PRCP1=PRCP2/DT !convert from mm to mm/s -#ifdef HYDRO_D - print*, "Supplemental pcp is accumulated pcp/dt. " -#endif - else - PRCP1=PRCP2 !assumes PRCP2 is in mm/s -#ifdef HYDRO_D - print*, "Supplemental pcp is rate. " -#endif - END IF ! Endif mmflag - ELSE ! either stop or default to original forcing data... -#ifdef HYDRO_D - print *,"Current RADAR precip data not found !!! Using previous available file..." -#endif - PRCP1 = PRCP_old - END IF ! Endif ierr_flg - -! Loop through data to screen for plausible values - do i=1,ix - do j=1,jx - if (PRCP1(i,j).lt.0.) PRCP1(i,j)= PRCP_old(i,j) - if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889 !set max pcp intens = 500 mm/h - end do - end do - - end if - - - - - -!!!DJG HRLDAS Forcing with hourly format filename with specified precipitation forcing... -! This option uses HRLDAS-formatted met forcing EXCEPT precipitation which is read in -! from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc' - - if(FORC_TYP.eq.6) then - -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - ".LDASIN_DOMAIN"//hgrid - - inquire (file=trim(inflnm), exist=fexist) - - if ( .not. fexist ) then - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".LDASIN_DOMAIN"//hgrid - inquire (file=trim(inflnm), exist=fexist) - endif - - - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no ATM forcing data found at this time", inflnm -#endif - else -#ifdef HYDRO_D - print*, "reading forcing data at this time", inflnm -#endif - - CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCP1,LAI,FPAR) - PRCP_old = PRCP1 ! This assigns new precip to last precip as a fallback for missing data... - endif - - -!Get specified precip.... -!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".PRECIP_FORCING.nc" - inquire (file=trim(inflnm), exist=fexist) -#ifdef HYDRO_D - if(fexist) then - print*, "using specified pcp forcing: ",trim(inflnm) - else - print*, "no specified pcp forcing: ",trim(inflnm) - endif -#endif - if ( .not. fexist ) then - prcp1 = PRCP_old ! for missing pcp data use analysis/model input - else - CALL READFORC_MDV(inflnm,IX,JX, & - PRCP2,mmflag,ierr_flg) -!If radar or spec. data is ok use if not, skip to original NARR data... - if(ierr_flg .ne. 0) then -#ifdef HYDRO_D - print*, "Warning: pcp reading problem: ", trim(inflnm) -#endif - PRCP1=PRCP_old - else - PRCP1=PRCP2 !assumes PRCP2 is in mm/s - IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... - PRCP1=PRCP2/DT !convert from mm to mm/s - END IF ! Endif mmflag -#ifdef HYDRO_D - print*, "replace pcp successfully! ",trim(inflnm) -#endif - endif - endif - - -! Loop through data to screen for plausible values - where(PRCP1 .lt. 0) PRCP1=PRCP_old - where(PRCP1 .gt. 10 ) PRCP1= PRCP_old - do i=1,ix - do j=1,jx - if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0 - if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889 !set max pcp intens = 500 mm/h - end do - end do -! write(80,*) prcp1 -! call hydro_stop("9999") - - end if - - -!!!! FORC_TYP 7: uses WRF forcing data plus additional pcp forcing. - - if(FORC_TYP.eq.7) then - -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - "wrfout_d0"//hgrid//"_"//& - olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//& - "_"//olddate(12:13)//":00:00" - - inquire (file=trim(inflnm), exist=fexist) - - - if ( .not. fexist ) then -#ifdef HYDRO_D - print*, "no forcing data found", inflnm -#endif - else - do i_forcing = 1, int(24*3600/dt) - wrf_dt = i_forcing*dt - call geth_newdate(out_date,olddate,nint(wrf_dt)) - inflnm2 = trim(indir)//"/"//& - "wrfout_d0"//hgrid//"_"//& - out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//& - "_"//out_date(12:13)//":00:00" - inquire (file=trim(inflnm2), exist=fexist) - if (fexist ) goto 992 - end do -992 continue - -#ifdef HYDRO_D - print*, "read WRF forcing data: ", trim(inflnm) - print*, "read WRF forcing data: ", trim(inflnm2) -#endif - CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,PRCPnew,lai,fpar) - CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & - PRES,XLONG,SHORT,prcp0,lai,fpar) - PRCP1=(PRCPnew-prcp0)/wrf_dt !Adjustment to convert accum to rate...(mm/s) - PRCP_old = PRCP1 - endif - -!Get specified precip.... -!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! -!!Create forcing data filename... - inflnm = trim(indir)//"/"//& - olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& - olddate(15:16)//".PRECIP_FORCING.nc" - inquire (file=trim(inflnm), exist=fexist) -#ifdef HYDRO_D - if(fexist) then - print*, "using specified pcp forcing: ",trim(inflnm) - else - print*, "no specified pcp forcing: ",trim(inflnm) - endif -#endif - if ( .not. fexist ) then - prcp1 = PRCP_old ! for missing pcp data use analysis/model input - else - CALL READFORC_MDV(inflnm,IX,JX, & - PRCP2,mmflag,ierr_flg) -!If radar or spec. data is ok use if not, skip to original NARR data... - if(ierr_flg .ne. 0) then -#ifdef HYDRO_D - print*, "Warning: pcp reading problem: ", trim(inflnm) -#endif - PRCP1=PRCP_old - else - PRCP1=PRCP2 !assumes PRCP2 is in mm/s - IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... - write(6,*) "using supplemental pcp time interval ", DT - PRCP1=PRCP2/DT !convert from mm to mm/s - else - write(6,*) "using supplemental pcp rates " - END IF ! Endif mmflag -#ifdef HYDRO_D - print*, "replace pcp successfully! ",trim(inflnm) -#endif - endif - endif - - -! Loop through data to screen for plausible values - where(PRCP1 .lt. 0) PRCP1=PRCP_old - where(PRCP1 .gt. 10 ) PRCP1= PRCP_old ! set maximum to be 500 mm/h - where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h - end if - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!!The other forcing data types below here are obsolete and left for reference... -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -!!!DJG HRLDAS Single Input with Multiple Input Times File Forcing... -! if(FORC_TYP.eq.6) then -!!Create forcing data filename... -! if (len_trim(range) == 0) then -! inflnm = trim(indir)//"/"//& -! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& -! olddate(15:16)//".LDASIN_DOMAIN"//hgrid//"_multiple" -!! "MET_LIS_CRO_2D_SANTEE_LU_1KM."//& -!! ".156hrfcst.radar" -! else -! endif -! CALL READFORC_HRLDAS_mult(inflnm,IX,JX,OLDDATE,T2,Q2X,U, & -! PRES,XLONG,SHORT,PRCP1,K) -! -!! IF (K.GT.0.AND.K.LT.10) THEN -!! PRCP1 = 10.0/3600.0 ! units mm/s -!! PRCP1 = 0.254/3600.0 -!! ELSE -!! PRCP1 = 0. -!! END IF -! endif - - - -!!!!!DJG NARR Met. w/ NARR Precip. Forcing Data... -!! Assumes standard 3-hrly NARR data has been resampled to NDHMS grid... -!! Assumes one 3hrly time-step per forcing data file -!! Input precip units here are in 'mm' accumulated over 3 hrs... -! if(FORC_TYP.eq.7) then !NARR Met. w/ NARR Precip. -!!!Create forcing data filename... -! if (len_trim(range) == 0) then -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid -! else -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) -! endif -! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & -! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) -! PRCP1=PRCP1/(3.0*3600.0) ! convert from 3hr accum to mm/s which is what NDHMS expects -! end if !NARR Met. w/ NARR Precip. - - - - - - -!!!!DJG NARR Met. w/ Specified Precip. Forcing Data... -! if(FORC_TYP.eq.8) then !NARR Met. w/ Specified Precip. -! -!!Check to make sure if Noah time step is 3 hrs as is NARR... -! -! PRCP_old = PRCP1 -! -! if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then !if/then 3 hr check -!!!Create forcing data filename... -! if (len_trim(range) == 0) then -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid -!! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& -!! ".48hrfcst.ncf" -! else -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) -! endif -! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & -! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) -!! PRCP1=PRCP1/(3.0*3600.0) !NARR 3hrly precip product in mm -! PRCP1=PRCP1 !NAM model data in mm/s -! end if !3 hr check -! -! -!!Get spec. precip.... -!! NAM Remote sensing... -!!!!VIP, dimensions of grid are currently hardwired in input subroutine!!! -!! product = "trmm" -!! inflnm = trim(indir)//"/"//"sat_domain1.nc" -!!! inflnm = trim(indir)//"/"//"sat_domain2.nc" -!! PRCP1 = 0. -!! CALL READFORC_NAMPCP(inflnm,IX,JX, & -!! PRCP2,K,product) -!! ierr_flg = 0 -!! mmflag = 0 -!!!Convert pcp grid to units of mm/s... -!! PRCP1=PRCP1/(3.0*3600.0) !3hrly precip product -! -!!Read from filelist (NAME HE...,others)... -!! if (K.eq.1) then -!! open(unit=93,file="filelist.txt",form="formatted",status="old") -!! end if -!! read (93,*) filename -!! inflnm = trim(indir)//"/"//trim(filename) -!! -!! -!!Front Range MDV Radar... -! -!! inflnm = "/ptmp/weiyu/rt_2008/radar_obs/"//& -!! inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//& -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -!! olddate(15:16)//"_radar.nc" -!! olddate(15:16)//"_chill.nc" -! -!! inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/Big_Thomp_04/"//& -!! inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//& -!! inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//& -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -!! olddate(15:16)//"00_Pcp60min.nc" -!! olddate(15:16)//"00_Pcp30min.nc" -!! olddate(15:16)//"00_30min.nc" -! olddate(15:16)//"00_Pcp5min.nc" -!! olddate(15:16)//"_chill.nc" -! -!! inflnm = "/d2/hydrolab/HRLDAS/forcing/COWS/"//& -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& -!! olddate(15:16)//"00_Pcp5min.nc" -!! olddate(15:16)//"00_5.nc" -! -!! inflnm = "" ! use this for NAM frxst runs with 30 min time-step -!! -! -! -!! if (K.le.6) then ! use for 30min nowcast... -!! if (K.eq.1) then -!! open(unit=94,file="start_file.txt",form="formatted",status="replace") -!!! inflnm2 = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//& -!! inflnm2 = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/"//& -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& -!! olddate(15:16)//"00_" -!! close(94) -!! nwxst_t = "5"! calc minutes from timestep and convert to char... -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! if (K.eq.2) then -!! nwxst_t = "10" ! calc minutes from timestep and convert to char... -!! open(unit=94,file="start_file.txt",form="formatted",status="old") -!! read (94,*) inflnm2 -!! close(94) -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! if (K.eq.3) then -!! nwxst_t = "15" ! calc minutes from timestep and convert to char... -!! open(unit=94,file="start_file.txt",form="formatted",status="old") -!! read (94,*) inflnm -!! close(94) -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! if (K.eq.4) then -!! nwxst_t = "20" ! calc minutes from timestep and convert to char... -!! open(unit=94,file="start_file.txt",form="formatted",status="old") -!! read (94,*) inflnm -!! close(94) -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! if (K.eq.5) then -!! nwxst_t = "25" ! calc minutes from timestep and convert to char... -!! open(unit=94,file="start_file.txt",form="formatted",status="old") -!! read (94,*) inflnm -!! close(94) -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! if (K.eq.6) then -!! nwxst_t = "30" ! calc minutes from timestep and convert to char... -!! open(unit=94,file="start_file.txt",form="formatted",status="old") -!! read (94,*) inflnm -!! close(94) -!! inflnm = trim(inflnm2)//trim(nwxst_t)//".nc" -!! end if -!! else -!! inflnm = "" ! use this for NAM frxst runs with 30 min time-step -!! end if -! -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//& -!! olddate(15:16)//"00_Pcp30minMerge.nc" -! -! CALL READFORC_MDV(inflnm,IX,JX, & -! PRCP2,mmflag,ierr_flg) -! -!!If radar or spec. data is ok use if not, skip to original NARR data... -! IF (ierr_flg.eq.0) then ! use spec. precip -! PRCP1=PRCP2 !assumes PRCP2 is in mm/s -!!Convert units if necessary -! IF (mmflag.eq.0) then !Convert pcp grid to units of mm/s... -! PRCP1=PRCP2/DT !convert from mm to mm/s -! END IF ! Endif mmflag -! ELSE ! either stop or default to original forcing data... -! PRCP1 = PRCP_old -! END IF ! Endif ierr_flg -! -!! Loop through data to screen for plausible values -! do i=1,ix -! do j=1,jx -! if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0 -! if (PRCP1(i,j).gt.0.0555) PRCP1(i,j)=0.0555 !set max pcp intens = 200 mm/h -!! PRCP1(i,j) = 0. -!! PRCP1(i,j) = 0.02 !override w/ const. precip for gw testing only... -! end do -! end do -! -!! if (K.eq.1) then ! quick dump for site specific precip... -! open(unit=94,file="Christman_accumpcp.txt",form="formatted",status="new") -! end if -! -! -! end if !NARR Met. w/ Specified Precip. - - - - - -!!!!DJG NLDAS Met. w/ NLDAS Precip. Forcing Data... -!! Assumes standard hrly NLDAS data has been resampled to NDHMS grid... -!! Assumes one 1-hrly time-step per forcing data file -!! Input precip units here are in 'mm' accumulated over 1 hr... -! if(FORC_TYP.eq.9) then !NLDAS Met. w/ NLDAS Precip. -!!!Create forcing data filename... -! if (len_trim(range) == 0) then -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -!!Use this for minute forcing... olddate(15:16)//".LDASIN_DOMAIN"//hgrid -! ".LDASIN_DOMAIN"//hgrid -! else -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) -! endif -! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & -! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) -! PRCP1=PRCP1/(1.0*3600.0) ! convert hourly NLDAS hourly accum pcp to mm/s which is what NDHMS expects -! end if !NLDAS Met. w/ NLDAS Precip. - - - - - -!!!!DJG NARR Met. w/ DMIP Precip. & Temp. Forcing Data... -! if(FORC_TYP.eq.10) then ! If/Then for DMIP forcing data... -!!Check to make sure if Noah time step is 3 hrs as is NARR... -! -! if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then !if/then 3 hr check -!!!Create forcing data filename... -! if (len_trim(range) == 0) then -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid -!! startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//& -!! ".48hrfcst.ncf" -! else -! inflnm = trim(indir)//"/"//& -! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -! ".LDASIN_DOMAIN"//hgrid//"."//trim(range) -! endif -! CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V, & -! PRES,XLONG,SHORT,PRCP1,LAI,FPAR) -! PRCP1=PRCP1/(3.0*3600.0) ! convert to mm/s which is what HRLDAS expects -! end if !3 hr check -! -!!Get DMIP Precip... -!! inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/PRECIP_HRAP/precip_finished"//"/"//& -! inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/PRECIP_HRAP"//"/"//& -! "proj.xmrg"//& -! olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//& -! "z.asc" -! PRCP1 = 0. -! CALL READFORC_DMIP(inflnm,IX,JX,PRCP1) -! PRCP1 = PRCP1 / 100.0 ! Convert from native hundreths of mm to mm -!! IF (K.LT.34) THEN -!! PRCP1 = 5.0/3600.0 ! units mm/s -!!! ELSE -!!! PRCP1 = 0. -!! END IF -! -!!Get DMIP Temp... -!! inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/TEMP_HRAP/tair_finished"//"/"//& -! inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/TEMP_HRAP"//"/"//& -! "proj.tair"//& -! olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//& -! "z.asc" -! CALL READFORC_DMIP(inflnm,IX,JX,T2) -! T2 = (5./9.)*(T2-32.0) + 273.15 !Convert from deg F to deg K -! -! end if !End if for DMIP forcing data... -! -! -! -!! : add reading forcing precipitation data -!! ywinflnm = "/ptmp/weiyu/hrldas/v2/st4"//"/"//& -!! olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//& -!! ".LDASIN_DOMAIN2" -!! call read_stage4(ywinflnm,IX,JX,PRCP1) -!!end yw -! -! -!!!!DJG Check for snow data assimilation... - - if (SNOW_ASSIM .eq. 1) then - -! Every 24 hours, update the snow field from analyses. - if(forc_typ .ne. 3 .or. forc_typ .ne. 6) then - if ( OLDDATE(12:13) == "00") then - CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP) - endif - else - CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP) - endif - - end if - - - end subroutine read_hydro_forcing_seq - - -#ifdef MPP_LAND - subroutine mpp_readland_hrldas(geo_static_flnm,& - ix,jx,land_cat,soil_cat,& - vegtyp,soltyp,terrain,latitude,longitude,& - global_nx,global_ny,SOLVEG_INITSWC) - implicit none - character(len=*), intent(in) :: geo_static_flnm - integer, intent(in) :: ix, jx, land_cat, soil_cat, & - global_nx,global_ny,SOLVEG_INITSWC - integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp - real, dimension(ix,jx), intent(out) :: terrain, latitude, longitude - real, dimension(global_nx,global_ny) ::g_terrain, g_latitude, g_longitude - integer, dimension(global_nx,global_ny) :: g_vegtyp, g_soltyp - - character(len=256) :: units - integer :: ierr - integer :: ncid,varid - real, dimension(ix,jx) :: xdum - integer flag ! flag = 1 from wrfsi, flag =2 from WPS. - if(my_id.eq.IO_id) then - CALL READLAND_HRLDAS(geo_static_flnm,global_nx, & - global_ny,LAND_CAT,SOIL_CAT, & - g_VEGTYP,g_SOLTYP,g_TERRAIN,g_LATITUDE,g_LONGITUDE, SOLVEG_INITSWC) - end if - ! distribute the data to computation node. - call mpp_land_bcast_int1(LAND_CAT) - call mpp_land_bcast_int1(SOIL_CAT) - call decompose_data_int(g_VEGTYP,VEGTYP) - call decompose_data_int(g_SOLTYP,SOLTYP) - call decompose_data_real(g_TERRAIN,TERRAIN) - call decompose_data_real(g_LATITUDE,LATITUDE) - call decompose_data_real(g_LONGITUDE,LONGITUDE) - return - end subroutine mpp_readland_hrldas - - - subroutine MPP_READSNOW_FORC(flnm,ix,jx,OLDDATE,weasd,snodep,& - global_nX, global_ny) - implicit none - - character(len=*), intent(in) :: flnm,OLDDATE - integer, intent(in) :: ix, global_nx,global_ny - integer, intent(in) :: jx - real, dimension(ix,jx), intent(out) :: weasd - real, dimension(ix,jx), intent(out) :: snodep - - real,dimension(global_nX, global_ny):: g_weasd, g_snodep - - character(len=256) :: units - integer :: ierr - integer :: ncid,i,j - - if(my_id .eq. IO_id) then - CALL READSNOW_FORC(trim(flnm),global_nX, global_ny,g_WEASD,g_SNODEP) - endif - call decompose_data_real(g_WEASD,WEASD) - call decompose_data_real(g_SNODEP,SNODEP) - - return - end subroutine MPP_READSNOW_FORC - - subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,& - global_nX, global_ny,nsoil,out_SMC,out_SH2OX) - implicit none - - integer, intent(in) :: ix,global_nx,global_ny - integer, intent(in) :: jx,nsoil - real, dimension(ix,jx), intent(in) :: in_smcmax - real, dimension(ix,jx,nsoil), intent(out) :: out_smc,out_sh2ox - - real,dimension(global_nX, global_ny,nsoil):: g_smc, g_sh2ox - real,dimension(global_nX, global_ny):: g_smcmax - integer :: i,j,k - - - call write_IO_real(in_smcmax,g_smcmax) ! get global grid of smcmax - -#ifdef HYDRO_D - write (*,*) "In deep GW...", nsoil -#endif - -!loop to overwrite soils to saturation... - do i=1,global_nx - do j=1,global_ny - g_smc(i,j,1:NSOIL) = g_smcmax(i,j) - g_sh2ox(i,j,1:NSOIL) = g_smcmax(i,j) - end do - end do - -!decompose global grid to parallel tiles... - do k=1,nsoil - call decompose_data_real(g_smc(:,:,k),out_smc(:,:,k)) - call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k)) - end do - - return - end subroutine MPP_DEEPGW_HRLDAS - - - subroutine read_hydro_forcing_mpp( & - indir,olddate,hgrid, & - ix,jx,forc_typ,snow_assim, & - T2,q2x,u,v,pres,xlong,short,prcp1,& - lai,fpar,snodep,dt,k,prcp_old) -! This subrouting is going to read different forcing. - - - implicit none - ! in variable - character(len=*) :: olddate,hgrid,indir - character(len=256) :: filename - integer :: ix,jx,forc_typ,k,snow_assim ! k is time loop - real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,& - prcpnew,lai,fpar,snodep,prcp_old - real :: dt - ! tmp variable - character(len=256) :: inflnm, product - integer :: i,j,mmflag - real,dimension(global_nx,global_ny):: g_T2,g_Q2X,g_U,g_V,g_XLONG, & - g_SHORT,g_PRCP1,g_PRES,g_lai,g_snodep,g_prcp_old, g_fpar - integer flag - - - - call write_io_real(T2,g_T2) - call write_io_real(Q2X,g_Q2X) - call write_io_real(U,g_U) - call write_io_real(V,g_V) - call write_io_real(XLONG,g_XLONG) - call write_io_real(SHORT,g_SHORT) - call write_io_real(PRCP1,g_PRCP1) - call write_io_real(PRES,g_PRES) - call write_io_real(prcp_old,g_PRCP_old) - - call write_io_real(lai,g_lai) - call write_io_real(fpar,g_fpar) - call write_io_real(snodep,g_snodep) - - - - if(my_id .eq. IO_id) then - call read_hydro_forcing_seq( & - indir,olddate,hgrid,& - global_nx,global_ny,forc_typ,snow_assim, & - g_T2,g_q2x,g_u,g_v,g_pres,g_xlong,g_short,g_prcp1,& - g_lai,g_fpar,g_snodep,dt,k,g_prcp_old) -#ifdef HYDRO_D - write(6,*) "finish read forcing,olddate ",olddate -#endif - end if - - call decompose_data_real(g_T2,T2) - call decompose_data_real(g_Q2X,Q2X) - call decompose_data_real(g_U,U) - call decompose_data_real(g_V,V) - call decompose_data_real(g_XLONG,XLONG) - call decompose_data_real(g_SHORT,SHORT) - call decompose_data_real(g_PRCP1,PRCP1) - call decompose_data_real(g_prcp_old,prcp_old) - call decompose_data_real(g_PRES,PRES) - - call decompose_data_real(g_lai,lai) - call decompose_data_real(g_fpar,fpar) - call decompose_data_real(g_snodep,snodep) - - return - end subroutine read_hydro_forcing_mpp -#endif - - integer function nfeb_yw(year) - ! - ! Compute the number of days in February for the given year. - ! - implicit none - integer, intent(in) :: year ! Four-digit year - - nfeb_yw = 28 ! By default, February has 28 days ... - if (mod(year,4).eq.0) then - nfeb_yw = 29 ! But every four years, it has 29 days ... - if (mod(year,100).eq.0) then - nfeb_yw = 28 ! Except every 100 years, when it has 28 days ... - if (mod(year,400).eq.0) then - nfeb_yw = 29 ! Except every 400 years, when it has 29 days ... - if (mod(year,3600).eq.0) then - nfeb_yw = 28 ! Except every 3600 years, when it has 28 days. - endif - endif - endif - endif - end function nfeb_yw - - subroutine geth_newdate (ndate, odate, idt) - implicit none - - ! From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and - ! delta-time, compute the new date. - - ! on entry - odate - the old hdate. - ! idt - the change in time - - ! on exit - ndate - the new hdate. - - integer, intent(in) :: idt - character (len=*), intent(out) :: ndate - character (len=*), intent(in) :: odate - - ! Local Variables - - ! yrold - indicates the year associated with "odate" - ! moold - indicates the month associated with "odate" - ! dyold - indicates the day associated with "odate" - ! hrold - indicates the hour associated with "odate" - ! miold - indicates the minute associated with "odate" - ! scold - indicates the second associated with "odate" - - ! yrnew - indicates the year associated with "ndate" - ! monew - indicates the month associated with "ndate" - ! dynew - indicates the day associated with "ndate" - ! hrnew - indicates the hour associated with "ndate" - ! minew - indicates the minute associated with "ndate" - ! scnew - indicates the second associated with "ndate" - - ! mday - a list assigning the number of days in each month - - ! i - loop counter - ! nday - the integer number of days represented by "idt" - ! nhour - the integer number of hours in "idt" after taking out - ! all the whole days - ! nmin - the integer number of minutes in "idt" after taking out - ! all the whole days and whole hours. - ! nsec - the integer number of minutes in "idt" after taking out - ! all the whole days, whole hours, and whole minutes. - - integer :: newlen, oldlen - integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew - integer :: yrold, moold, dyold, hrold, miold, scold, frold - integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc - logical :: opass - character (len=10) :: hfrc - character (len=1) :: sp - logical :: punct - integer :: yrstart, yrend, mostart, moend, dystart, dyend - integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart - integer :: units - integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/) -!yw integer nfeb_yw - - ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...." - if (odate(5:5) == "-") then - punct = .TRUE. - else - punct = .FALSE. - endif - - ! Break down old hdate into parts - - hrold = 0 - miold = 0 - scold = 0 - frold = 0 - oldlen = LEN(odate) - if (punct) then - yrstart = 1 - yrend = 4 - mostart = 6 - moend = 7 - dystart = 9 - dyend = 10 - hrstart = 12 - hrend = 13 - mistart = 15 - miend = 16 - scstart = 18 - scend = 19 - frstart = 21 - select case (oldlen) - case (10) - ! Days - units = 1 - case (13) - ! Hours - units = 2 - case (16) - ! Minutes - units = 3 - case (19) - ! Seconds - units = 4 - case (21) - ! Tenths - units = 5 - case (22) - ! Hundredths - units = 6 - case (23) - ! Thousandths - units = 7 - case (24) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - call hydro_stop("in geth_newdate") -#endif - end select - - if (oldlen.ge.11) then - sp = odate(11:11) - else - sp = ' ' - end if - - else - - yrstart = 1 - yrend = 4 - mostart = 5 - moend = 6 - dystart = 7 - dyend = 8 - hrstart = 9 - hrend = 10 - mistart = 11 - miend = 12 - scstart = 13 - scend = 14 - frstart = 15 - - select case (oldlen) - case (8) - ! Days - units = 1 - case (10) - ! Hours - units = 2 - case (12) - ! Minutes - units = 3 - case (14) - ! Seconds - units = 4 - case (15) - ! Tenths - units = 5 - case (16) - ! Hundredths - units = 6 - case (17) - ! Thousandths - units = 7 - case (18) - ! Ten thousandths - units = 8 - case default -#ifdef HYDRO_D - write(*,*) 'ERROR: geth_newdate: odd length: #'//trim(odate)//'#' - call hydro_stop("in geth_newdate") -#endif - end select - endif - - ! Use internal READ statements to convert the CHARACTER string - ! date into INTEGER components. - - read(odate(yrstart:yrend), '(i4)') yrold - read(odate(mostart:moend), '(i2)') moold - read(odate(dystart:dyend), '(i2)') dyold - if (units.ge.2) then - read(odate(hrstart:hrend),'(i2)') hrold - if (units.ge.3) then - read(odate(mistart:miend),'(i2)') miold - if (units.ge.4) then - read(odate(scstart:scend),'(i2)') scold - if (units.ge.5) then - read(odate(frstart:oldlen),*) frold - end if - end if - end if - end if - - ! Set the number of days in February for that year. - - mday(2) = nfeb_yw(yrold) - - ! Check that ODATE makes sense. - - opass = .TRUE. - - ! Check that the month of ODATE makes sense. - - if ((moold.gt.12).or.(moold.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold -#endif - opass = .FALSE. - end if - - ! Check that the day of ODATE makes sense. - - if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold -#endif - opass = .FALSE. - end if - - ! Check that the hour of ODATE makes sense. - - if ((hrold.gt.23).or.(hrold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold -#endif - opass = .FALSE. - end if - - ! Check that the minute of ODATE makes sense. - - if ((miold.gt.59).or.(miold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold -#endif - opass = .FALSE. - end if - - ! Check that the second of ODATE makes sense. - - if ((scold.gt.59).or.(scold.lt.0)) then -#ifdef HYDRO_D - write(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold -#endif - opass = .FALSE. - end if - - ! Check that the fractional part of ODATE makes sense. - if (.not.opass) then -#ifdef HYDRO_D - write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen - call hydro_stop("in geth_newdate") -#endif - end if - - ! Date Checks are completed. Continue. - - - ! Compute the number of days, hours, minutes, and seconds in idt - - if (units.ge.5) then !idt should be in fractions of seconds - ifrc = oldlen-(frstart)+1 - ifrc = 10**ifrc - nday = abs(idt)/(86400*ifrc) - nhour = mod(abs(idt),86400*ifrc)/(3600*ifrc) - nmin = mod(abs(idt),3600*ifrc)/(60*ifrc) - nsec = mod(abs(idt),60*ifrc)/(ifrc) - nfrac = mod(abs(idt), ifrc) - else if (units.eq.4) then !idt should be in seconds - ifrc = 1 - nday = abs(idt)/86400 ! integer number of days in delta-time - nhour = mod(abs(idt),86400)/3600 - nmin = mod(abs(idt),3600)/60 - nsec = mod(abs(idt),60) - nfrac = 0 - else if (units.eq.3) then !idt should be in minutes - ifrc = 1 - nday = abs(idt)/1440 ! integer number of days in delta-time - nhour = mod(abs(idt),1440)/60 - nmin = mod(abs(idt),60) - nsec = 0 - nfrac = 0 - else if (units.eq.2) then !idt should be in hours - ifrc = 1 - nday = abs(idt)/24 ! integer number of days in delta-time - nhour = mod(abs(idt),24) - nmin = 0 - nsec = 0 - nfrac = 0 - else if (units.eq.1) then !idt should be in days - ifrc = 1 - nday = abs(idt) ! integer number of days in delta-time - nhour = 0 - nmin = 0 - nsec = 0 - nfrac = 0 - else -#ifdef HYDRO_D - write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') & - oldlen - write(*,*) '#'//odate(1:oldlen)//'#' - call hydro_stop("in geth_newdate") -#endif - end if - - if (idt.ge.0) then - - frnew = frold + nfrac - if (frnew.ge.ifrc) then - frnew = frnew - ifrc - nsec = nsec + 1 - end if - - scnew = scold + nsec - if (scnew .ge. 60) then - scnew = scnew - 60 - nmin = nmin + 1 - end if - - minew = miold + nmin - if (minew .ge. 60) then - minew = minew - 60 - nhour = nhour + 1 - end if - - hrnew = hrold + nhour - if (hrnew .ge. 24) then - hrnew = hrnew - 24 - nday = nday + 1 - end if - - dynew = dyold - monew = moold - yrnew = yrold - do i = 1, nday - dynew = dynew + 1 - if (dynew.gt.mday(monew)) then - dynew = dynew - mday(monew) - monew = monew + 1 - if (monew .gt. 12) then - monew = 1 - yrnew = yrnew + 1 - ! If the year changes, recompute the number of days in February - mday(2) = nfeb_yw(yrnew) - end if - end if - end do - - else if (idt.lt.0) then - - frnew = frold - nfrac - if (frnew .lt. 0) then - frnew = frnew + ifrc - nsec = nsec + 1 - end if - - scnew = scold - nsec - if (scnew .lt. 00) then - scnew = scnew + 60 - nmin = nmin + 1 - end if - - minew = miold - nmin - if (minew .lt. 00) then - minew = minew + 60 - nhour = nhour + 1 - end if - - hrnew = hrold - nhour - if (hrnew .lt. 00) then - hrnew = hrnew + 24 - nday = nday + 1 - end if - - dynew = dyold - monew = moold - yrnew = yrold - do i = 1, nday - dynew = dynew - 1 - if (dynew.eq.0) then - monew = monew - 1 - if (monew.eq.0) then - monew = 12 - yrnew = yrnew - 1 - ! If the year changes, recompute the number of days in February - mday(2) = nfeb_yw(yrnew) - end if - dynew = mday(monew) - end if - end do - end if - - ! Now construct the new mdate - - newlen = LEN(ndate) - - if (punct) then - - if (newlen.gt.frstart) then - write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew - write(hfrc,'(i10)') frnew+1000000000 - ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) - - else if (newlen.eq.scend) then - write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew -19 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2) - - else if (newlen.eq.miend) then - write(ndate,16) yrnew, monew, dynew, hrnew, minew -16 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2) - - else if (newlen.eq.hrend) then - write(ndate,13) yrnew, monew, dynew, hrnew -13 format(i4,'-',i2.2,'-',i2.2,'_',i2.2) - - else if (newlen.eq.dyend) then - write(ndate,10) yrnew, monew, dynew -10 format(i4,'-',i2.2,'-',i2.2) - - end if - - else - - if (newlen.gt.frstart) then - write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew - write(hfrc,'(i10)') frnew+1000000000 - ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10) - - else if (newlen.eq.scend) then - write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew -119 format(i4,i2.2,i2.2,i2.2,i2.2,i2.2) - - else if (newlen.eq.miend) then - write(ndate,116) yrnew, monew, dynew, hrnew, minew -116 format(i4,i2.2,i2.2,i2.2,i2.2) - - else if (newlen.eq.hrend) then - write(ndate,113) yrnew, monew, dynew, hrnew -113 format(i4,i2.2,i2.2,i2.2) - - else if (newlen.eq.dyend) then - write(ndate,110) yrnew, monew, dynew -110 format(i4,i2.2,i2.2) - - end if - - endif - - if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp - - end subroutine geth_newdate -end module module_lsm_forcing diff --git a/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F b/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F deleted file mode 100644 index ba40b76b..00000000 --- a/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F +++ /dev/null @@ -1,87 +0,0 @@ -MODULE module_noah_chan_param_init_rt - - -CONTAINS -! -!----------------------------------------------------------------- - SUBROUTINE CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann) -!----------------------------------------------------------------- - - IMPLICIT NONE - - integer :: IINDEX, CHANCATS - integer :: ORDER - integer, PARAMETER :: NCHANTYPES=50 - real,dimension(NCHANTYPES) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann - character(LEN=11) :: DATATYPE - -!-----SPECIFY CHANNEL RELATED CHARACTERISTICS : -! ORDER: Strahler Stream Order -! BOTWID: Channel Bottom Width (meters) -! HLINK_INIT: Initial depth of flow in channel (meters) -! CHAN_SS: Channel side slope (assuming trapezoidal channel geom) -! CHMann: Channel Manning's N roughness coefficient - - -!-----READ IN CHANNEL PROPERTIES FROM CHANPARM.TBL : - OPEN(19, FILE='CHANPARM.TBL',FORM='FORMATTED',STATUS='OLD') - READ (19,*) - READ (19,2000,END=2002) DATATYPE -#ifdef HYDRO_D - PRINT *, DATATYPE -#endif - READ (19,*)CHANCATS,IINDEX -2000 FORMAT (A11) - -!-----Read in Channel Parameters as functions of stream order... - - IF(DATATYPE.EQ.'StreamOrder')THEN -#ifdef HYDRO_D - PRINT *, 'CHANNEL DATA SOURCE TYPE = ',DATATYPE,' FOUND', & - CHANCATS,' CATEGORIES' -#endif - DO ORDER=1,CHANCATS - READ (19,*)IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER), & - & CHMann(ORDER) - PRINT *, IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER), & - & CHMann(ORDER) - ENDDO - ENDIF - - -!-----Read in Channel Parameters as functions of ???other method??? (TBC)... - - -2002 CONTINUE - - CLOSE (19) - END SUBROUTINE CHAN_PARM_INIT - - - -#ifdef MPP_LAND - SUBROUTINE mpp_CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann) - use module_mpp_land, only: my_id, IO_id,mpp_land_bcast_int1, & - mpp_land_bcast_real,mpp_land_bcast_int,mpp_land_bcast_real1 - implicit none - integer :: IINDEX, CHANCATS - integer :: ORDER - integer, PARAMETER :: NCHANTYPES=50 - real,dimension(NCHANTYPES) :: BOTWID,HLINK_INIT,CHAN_SS,CHMann - character(LEN=11) :: DATATYPE - - if(my_id.eq.io_id) then - call CHAN_PARM_INIT(BOTWID,HLINK_INIT,CHAN_SS,CHMann) - end if - call mpp_land_bcast_real(NCHANTYPES,BOTWID) - call mpp_land_bcast_real(NCHANTYPES,HLINK_INIT) - call mpp_land_bcast_real(NCHANTYPES,CHAN_SS) - call mpp_land_bcast_real(NCHANTYPES,CHMann) - return - END SUBROUTINE mpp_CHAN_PARM_INIT -#endif -!----------------------------------------------------------------- -!----------------------------------------------------------------- - - -END MODULE module_Noah_chan_param_init_rt diff --git a/wrfv2_fire/hydro/Routing/rtFunction.F b/wrfv2_fire/hydro/Routing/rtFunction.F deleted file mode 100644 index 9334307f..00000000 --- a/wrfv2_fire/hydro/Routing/rtFunction.F +++ /dev/null @@ -1,222 +0,0 @@ - subroutine exeRouting (did) - use module_RT_data, only: rt_domain - use module_GW_baseflow_data, only: gw2d - use module_GW_baseflow, only: simp_gw_buck, gwstep - use module_channel_routing, only: drive_channel - use module_namelist, only: nlst_rt - -#ifdef MPP_LAND - use module_mpp_land -#endif - - - implicit none - integer did, i - real, dimension(RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT):: & - QSTRMVOLRT_DUM,LAKE_INFLORT_DUM, & - QSTRMVOLRT_TS, LAKE_INFLORT_TS - - real :: dx - integer ii,jj,kk - - - IF (nlst_rt(did)%SUBRTSWCRT.EQ.1 .or. nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) THEN - - QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT - LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT - -#ifdef HYDRO_D - write(6,*) "*****yw******start drive_RT " -#endif - - - -! write(6,*) "yyww RT_DOMAIN(did)%SH2OX(15,1,7)= ", RT_DOMAIN(did)%SH2OX(15,1,7) - - call drive_RT( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,& - RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & - RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%STC,RT_DOMAIN(did)%SH2OX, & - RT_DOMAIN(did)%INFXSRT,RT_DOMAIN(did)%SFCHEADRT,RT_DOMAIN(did)%SMCMAX1,& - RT_DOMAIN(did)%SMCREF1,RT_DOMAIN(did)%LKSAT, & - RT_DOMAIN(did)%SMCWLT1, RT_DOMAIN(did)%SMCRTCHK,RT_DOMAIN(did)%DSMC,& - RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SMCAGGRT,& - RT_DOMAIN(did)%STCAGGRT,RT_DOMAIN(did)%SH2OAGGRT, & - RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%SOLDEPRT,& - RT_DOMAIN(did)%INFXSAGGRT,RT_DOMAIN(did)%DHRT,RT_DOMAIN(did)%QSTRMVOLRT, & - RT_DOMAIN(did)%QBDRYRT,RT_DOMAIN(did)%LAKE_INFLORT,& - RT_DOMAIN(did)%SFCHEADSUBRT,RT_DOMAIN(did)%INFXSWGT,& - RT_DOMAIN(did)%LKSATRT, & - RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%OVROUGHRT,& - RT_DOMAIN(did)%QSUBRT,RT_DOMAIN(did)%ZWATTABLRT, & - RT_DOMAIN(did)%QSUBBDRYRT, & - RT_DOMAIN(did)%RETDEPRT,RT_DOMAIN(did)%SOXRT,RT_DOMAIN(did)%SOYRT,& - RT_DOMAIN(did)%SUB_RESID,RT_DOMAIN(did)%SMCRT,& - RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCWLTRT, & - RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%LAKE_MSKRT,& - RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%dist, & - RT_DOMAIN(did)%LSMVOL,RT_DOMAIN(did)%DSMCTOT, & - RT_DOMAIN(did)%SMCTOT1,& - RT_DOMAIN(did)%SMCTOT2,RT_DOMAIN(did)%suminfxs1, & - RT_DOMAIN(did)%suminfxsrt,RT_DOMAIN(did)%SO8RT, & - RT_DOMAIN(did)%SO8RT_D,nlst_rt(did)%AGGFACTRT, & - nlst_rt(did)%SUBRTSWCRT,nlst_rt(did)%OVRTSWCRT, & - RT_DOMAIN(did)%LAKE_CT, RT_DOMAIN(did)%STRM_CT, & - nlst_rt(did)%RT_OPTION,RT_DOMAIN(did)%OV_ROUGH, & - RT_DOMAIN(did)%INFXSAGG1RT,RT_DOMAIN(did)%SFCHEADAGG1RT,& - RT_DOMAIN(did)%SFCHEADAGGRT,& - nlst_rt(did)%DTRT, & - nlst_rt(did)%DT,RT_DOMAIN(did)%LAKE_INFLOTRT,& - RT_DOMAIN(did)%QBDRYTRT,RT_DOMAIN(did)%QSUBBDRYTRT,& - RT_DOMAIN(did)%QSTRMVOLTRT,RT_DOMAIN(did)%q_sfcflx_x,& - RT_DOMAIN(did)%q_sfcflx_y,RT_DOMAIN(did)%LKSATFAC,& - RT_DOMAIN(did)%OVROUGHRTFAC,rt_domain(did)%dist_lsm(:,:,9) ) - - QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-QSTRMVOLRT_DUM - LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-LAKE_INFLORT_DUM - -#ifdef HYDRO_D - write(6,*) "*****yw******end drive_RT " -#endif - end if - - - -!------------------------------------------------------------------ -!DJG Begin GW/Baseflow Routines -!------------------------------------------------------------------- - - IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN ! Switch to activate/specify GW/Baseflow - -! IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN ! Switch to activate/specify GW/Baseflow - - If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then ! Call simple bucket baseflow scheme - -#ifdef HYDRO_D - write(6,*) "*****yw******start simp_gw_buck " -#endif - - call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,& - RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%basns_area,& - RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, & - RT_DOMAIN(did)%SOLDRAIN, & - RT_DOMAIN(did)%z_gwsubbas,& - RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,& - RT_DOMAIN(did)%qinflowbase,& - RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, & - RT_DOMAIN(did)%dist,nlst_rt(did)%DT,& - RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, & - RT_DOMAIN(did)%z_max,& - nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT) - - -#ifdef MPP_LAND - if(my_id .eq. IO_id) then -#endif - - open (unit=51,file='GW_inflow.txt',form='formatted',& - status='unknown',position='append') - open (unit=52,file='GW_outflow.txt',form='formatted',& - status='unknown',position='append') - open (unit=53,file='GW_zlev.txt',form='formatted',& - status='unknown',position='append') - do i=1,RT_DOMAIN(did)%numbasns - write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i) -951 FORMAT(I3,1X,A19,1X,F11.3) - write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i) - write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i) - end do - close(51) - close(52) - close(53) -#ifdef MPP_LAND - endif -#endif - -#ifdef HYDRO_D - write(6,*) "*****yw******end simp_gw_buck " -#endif - -!!!For parameter setup runs output the percolation for each basin, -!!!otherwise comment out this output... - else if (nlst_rt(did)%GWBASESWCRT .eq. 3) then - -#ifdef HYDRO_D - write(6,*) "*****bf******start 2d_gw_model " -#endif - - DX = abs(nlst_rt(did)%DXRT0 * nlst_rt(did)%AGGFACTRT) - - call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, & - gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, & - gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, & - gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, & - gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, & - gw2d(did)%istep) - - -! bftodo head postprocessing block -! GW-SOIL-CHANNEL interaction section - gw2d(did)%ho = gw2d(did)%h - -#ifdef HYDRO_D - write(6,*) "*****bf******end 2d_gw_model " -#endif - - End if - - END IF !DJG (End if for RTE SWC activation) -!------------------------------------------------------------------ -!DJG End GW/Baseflow Routines -!------------------------------------------------------------------- - -!------------------------------------------------------------------- -!------------------------------------------------------------------- -!DJG,DNY Begin Channel and Lake Routing Routines -!------------------------------------------------------------------- - IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN - - call drive_CHANNEL(RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, & - nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, & - LAKE_INFLORT_TS, QSTRMVOLRT_TS,& - RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,& - RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,& - RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT, & - RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTRT, & - RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, & - RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,& - RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, & - RT_DOMAIN(did)%Bw,& - RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,& - RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, & - RT_DOMAIN(did)%ORIFICEA, & - RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, & - RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,& - RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, & - RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, & - RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, & - RT_DOMAIN(did)%RETDEP_CHAN & - , RT_DOMAIN(did)%node_area & -#ifdef MPP_LAND - ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,& - RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, & - RT_DOMAIN(did)%yw_mpp_nlinks & -#endif - ) - endif - -#ifdef HYDRO_D - write(6,*) "*****yw******end drive_CHANNEL " -#endif - - end subroutine exeRouting - - subroutine time_seconds(i3) - integer time_array(8) - real*8 i3 - call date_and_time(values=time_array) - i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + & - time_array(7) + 0.001 * time_array(8) - return - end subroutine time_seconds - - diff --git a/wrfv2_fire/hydro/Run/.svn/all-wcprops b/wrfv2_fire/hydro/Run/.svn/all-wcprops deleted file mode 100644 index 83be28c2..00000000 --- a/wrfv2_fire/hydro/Run/.svn/all-wcprops +++ /dev/null @@ -1,17 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 56 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Run -END -hydro.namelist -K 25 -svn:wc:ra_dav:version-url -V 71 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Run/hydro.namelist -END -HYDRO.TBL -K 25 -svn:wc:ra_dav:version-url -V 66 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/Run/HYDRO.TBL -END diff --git a/wrfv2_fire/hydro/Run/.svn/entries b/wrfv2_fire/hydro/Run/.svn/entries deleted file mode 100644 index 253741b0..00000000 --- a/wrfv2_fire/hydro/Run/.svn/entries +++ /dev/null @@ -1,96 +0,0 @@ -10 - -dir -9105 -https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/Run -https://kkeene@svn-wrf-model.cgd.ucar.edu - - - -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - -b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d - -hydro.namelist -file - - - - -2016-02-11T20:37:50.230193Z -57b60e98bf800551790f4a412231f488 -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -3436 - -HYDRO.TBL -file - - - - -2016-02-11T20:37:50.231253Z -f265ac087359e672e926e2334ca5fc38 -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -2199 - diff --git a/wrfv2_fire/hydro/Run/.svn/text-base/HYDRO.TBL.svn-base b/wrfv2_fire/hydro/Run/.svn/text-base/HYDRO.TBL.svn-base deleted file mode 100644 index 1d691a08..00000000 --- a/wrfv2_fire/hydro/Run/.svn/text-base/HYDRO.TBL.svn-base +++ /dev/null @@ -1,51 +0,0 @@ - 28 USGS for OV_ROUGH - SFC_ROUGH' - 0.025, 'Urban and Built-Up Land' - 0.035, 'Dryland Cropland and Pasture' - 0.035, 'Irrigated Cropland and Pasture' - 0.055, 'Mixed Dryland/Irrigated Cropland and Pasture' - 0.035, 'Cropland/Grassland Mosaic' - 0.068, 'Cropland/Woodland Mosaic' - 0.055, 'Grassland' - 0.055, 'Shrubland' - 0.055, 'Mixed Shrubland/Grassland' - 0.055, 'Savanna' - 0.200, 'Deciduous Broadleaf Forest' - 0.200, 'Deciduous Needleleaf Forest' - 0.200, 'Evergreen Broadleaf Forest' - 0.200, 'Evergreen Needleleaf Forest' - 0.200, 'Mixed Forest' - 0.005, 'Water Bodies' - 0.070, 'Herbaceous Wetland' - 0.070, 'Wooded Wetland' - 0.035, 'Barren or Sparsely Vegetated' - 0.055, 'Herbaceous Tundra' - 0.055, 'Wooded Tundra' - 0.055, 'Mixed Tundra' - 0.055, 'Bare Ground Tundra' - 0.010, 'Snow or Ice' - 0.010, 'Playa' - 0.100, 'Lava' - 0.010, 'White Sand' - 0.005, 'Non-Ocean Water Bodies' -19, for SATDK -SATDK MAXSMC REFSMC WLTSMC QTZ ' -1.07E-6, 0.339, 0.236, 0.010, 0.92, 'SAND' -1.41E-5, 0.421, 0.383, 0.028, 0.82, 'LOAMY SAND' -5.23E-6, 0.434, 0.383, 0.047, 0.60, 'SANDY LOAM' -2.81E-6, 0.476, 0.360, 0.084, 0.25, 'SILT LOAM' -2.81E-6, 0.476, 0.383, 0.084, 0.10, 'SILT' -3.38E-6, 0.439, 0.329, 0.066, 0.40, 'LOAM' -4.45E-6, 0.404, 0.314, 0.067, 0.60, 'SANDY CLAY LOAM' -2.04E-6, 0.464, 0.387, 0.120, 0.10, 'SILTY CLAY LOAM' -2.45E-6, 0.465, 0.382, 0.103, 0.35, 'CLAY LOAM' -7.22E-6, 0.406, 0.338, 0.100, 0.52, 'SANDY CLAY' -1.34E-6, 0.468, 0.404, 0.126, 0.10, 'SILTY CLAY' -9.74E-7, 0.468, 0.412, 0.138, 0.25, 'CLAY' -3.38E-6, 0.439, 0.329, 0.066, 0.05, 'ORGANIC MATERIAL' - 0.0, 1.0, 0.0, 0.0, 0.60, 'WATER' -1.75E-5, 0.20, 0.170, 0.006, 0.07, 'BEDROCK' -1.41E-5, 0.421, 0.283, 0.028, 0.25, 'OTHER(land-ice)' -9.74E-7, 0.468, 0.454, 0.030, 0.60, 'PLAYA' -1.41E-4, 0.200, 0.170, 0.006, 0.52, 'LAVA' -1.07E-6, 0.339, 0.236, 0.01, 0.92, 'WHITE SAND' diff --git a/wrfv2_fire/hydro/Run/.svn/text-base/hydro.namelist.svn-base b/wrfv2_fire/hydro/Run/.svn/text-base/hydro.namelist.svn-base deleted file mode 100644 index f47b80a1..00000000 --- a/wrfv2_fire/hydro/Run/.svn/text-base/hydro.namelist.svn-base +++ /dev/null @@ -1,105 +0,0 @@ -&HYDRO_nlist - -!!!! SYSTEM COUPLING !!!! -!Specify what is being coupled: 1=HRLDAS (offline Noah-LSM), 2=WRF, 3=NASA/LIS, 4=CLM - sys_cpl = 2 - - - -!!!! MODEL INPUT DATA FILES !!! -!Specify land surface model gridded input data file...(e.g.: "geo_em.d03.nc") - GEO_STATIC_FLNM = "DOMAIN/geo_em.d03.nc" - -!Specify the high-resolution routing terrain input data file...(e.g.: "Fulldom_hires_hydrofile.nc" - GEO_FINEGRID_FLNM = "DOMAIN/Fulldom_hires_hydrofile_ohd_new_basns_w_cal_params_full_domain.nc" - -!Specify the name of the restart file if starting from restart...comment out with '!' if not... -! RESTART_FILE = 'HYDRO_RST.2012-07-21_12:00_DOMAIN2' - - - -!!!! MODEL SETUP AND I/O CONTROL !!!! -!Specify the domain or nest number identifier...(integer) - IGRID = 3 - -!Specify the restart file write frequency...(minutes) - !rst_dt = 360 - rst_dt = 30 - -!Specify the output file write frequency...(minutes) - out_dt = 15 ! minutes - -!Specify if output history files are to be written...(.TRUE. or .FALSE.) - HISTORY_OUTPUT = .TRUE. - -!Specify the number of output times to be contained within each output history file...(integer) -! SET = 1 WHEN RUNNING CHANNEL ROUTING ONLY/CALIBRATION SIMS!!! -! SET = 1 WHEN RUNNING COUPLED TO WRF!!! - SPLIT_OUTPUT_COUNT = 1 - -! rst_typ = 1 : overwrite the soil variables from routing restart file. - rst_typ = 0 - -!Restart switch to set restart accumulation variables = 0 (0-no reset, 1-yes reset to 0.0) - RSTRT_SWC = 0 - -!Output high-resolution routing files...0=none, 1=total chan_inflow ASCII time-series, 2=hires grid and chan_inflow... - HIRES_OUT = 2 - -!Specify the minimum stream order to output to netcdf point file...(integer) -!Note: lower value of stream order produces more output. - order_to_write = 1 - - - -!!!! PHYSICS OPTIONS AND RELATED SETTINGS !!!! -!Switch for terrain adjustment of incoming solar radiation: 0=no, 1=yes -!Note: This option is not yet active in Verion 1.0... -! WRF has this capability so be careful not to double apply the correction!!! - TERADJ_SOLAR = 0 - -!Specify the number of soil layers (integer) and the depth of the bottom of each layer (meters)... -! Notes: In Version 1 of WRF-Hydro these must be the same as in the namelist.input file -! Future versions will permit this to be different. - NSOIL=4 - ZSOIL8(1) = -0.10 - ZSOIL8(2) = -0.40 - ZSOIL8(3) = -1.0 - ZSOIL8(4) = -2.0 - -!Specify the grid spacing of the terrain routing grid...(meters) - DXRT = 100 - -!Specify the integer multiple between the land model grid and the terrain routing grid...(integer) - AGGFACTRT = 10 - -!Specify the routing model timestep...(seconds) - DTRT = 2 - -!Switch activate subsurface routing...(0=no, 1=yes) - SUBRTSWCRT = 1 - -!Switch activate surface overland flow routing...(0=no, 1=yes) - OVRTSWCRT = 1 - -!Switch to activate channel routing Routing Option: 1=Seepest Descent (D8) 2=CASC2D - rt_option = 1 - CHANRTSWCRT = 0 - -!Specify channel routing option: 1=Muskingam-reach, 2=Musk.-Cunge-reach, 3=Diff.Wave-gridded - channel_option =3 - -!Specify the reach file for reach-based routing options... - route_link_f = "" - -!Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through) - GWBASESWCRT = 2 - -!Specify baseflow/bucket model initialization...(0=cold start from table, 1=restart file) - GW_RESTART = 0 - -!Groundwater/baseflow mask specified on land surface model grid... -!Note: Only required if baseflow bucket model is active - gwbasmskfil = "DOMAIN/basn_msk1k_frng_ohd.txt" - -/ diff --git a/wrfv2_fire/hydro/Run/HYDRO.TBL b/wrfv2_fire/hydro/Run/HYDRO.TBL deleted file mode 100644 index 1d691a08..00000000 --- a/wrfv2_fire/hydro/Run/HYDRO.TBL +++ /dev/null @@ -1,51 +0,0 @@ - 28 USGS for OV_ROUGH - SFC_ROUGH' - 0.025, 'Urban and Built-Up Land' - 0.035, 'Dryland Cropland and Pasture' - 0.035, 'Irrigated Cropland and Pasture' - 0.055, 'Mixed Dryland/Irrigated Cropland and Pasture' - 0.035, 'Cropland/Grassland Mosaic' - 0.068, 'Cropland/Woodland Mosaic' - 0.055, 'Grassland' - 0.055, 'Shrubland' - 0.055, 'Mixed Shrubland/Grassland' - 0.055, 'Savanna' - 0.200, 'Deciduous Broadleaf Forest' - 0.200, 'Deciduous Needleleaf Forest' - 0.200, 'Evergreen Broadleaf Forest' - 0.200, 'Evergreen Needleleaf Forest' - 0.200, 'Mixed Forest' - 0.005, 'Water Bodies' - 0.070, 'Herbaceous Wetland' - 0.070, 'Wooded Wetland' - 0.035, 'Barren or Sparsely Vegetated' - 0.055, 'Herbaceous Tundra' - 0.055, 'Wooded Tundra' - 0.055, 'Mixed Tundra' - 0.055, 'Bare Ground Tundra' - 0.010, 'Snow or Ice' - 0.010, 'Playa' - 0.100, 'Lava' - 0.010, 'White Sand' - 0.005, 'Non-Ocean Water Bodies' -19, for SATDK -SATDK MAXSMC REFSMC WLTSMC QTZ ' -1.07E-6, 0.339, 0.236, 0.010, 0.92, 'SAND' -1.41E-5, 0.421, 0.383, 0.028, 0.82, 'LOAMY SAND' -5.23E-6, 0.434, 0.383, 0.047, 0.60, 'SANDY LOAM' -2.81E-6, 0.476, 0.360, 0.084, 0.25, 'SILT LOAM' -2.81E-6, 0.476, 0.383, 0.084, 0.10, 'SILT' -3.38E-6, 0.439, 0.329, 0.066, 0.40, 'LOAM' -4.45E-6, 0.404, 0.314, 0.067, 0.60, 'SANDY CLAY LOAM' -2.04E-6, 0.464, 0.387, 0.120, 0.10, 'SILTY CLAY LOAM' -2.45E-6, 0.465, 0.382, 0.103, 0.35, 'CLAY LOAM' -7.22E-6, 0.406, 0.338, 0.100, 0.52, 'SANDY CLAY' -1.34E-6, 0.468, 0.404, 0.126, 0.10, 'SILTY CLAY' -9.74E-7, 0.468, 0.412, 0.138, 0.25, 'CLAY' -3.38E-6, 0.439, 0.329, 0.066, 0.05, 'ORGANIC MATERIAL' - 0.0, 1.0, 0.0, 0.0, 0.60, 'WATER' -1.75E-5, 0.20, 0.170, 0.006, 0.07, 'BEDROCK' -1.41E-5, 0.421, 0.283, 0.028, 0.25, 'OTHER(land-ice)' -9.74E-7, 0.468, 0.454, 0.030, 0.60, 'PLAYA' -1.41E-4, 0.200, 0.170, 0.006, 0.52, 'LAVA' -1.07E-6, 0.339, 0.236, 0.01, 0.92, 'WHITE SAND' diff --git a/wrfv2_fire/hydro/Run/hydro.namelist b/wrfv2_fire/hydro/Run/hydro.namelist deleted file mode 100644 index f47b80a1..00000000 --- a/wrfv2_fire/hydro/Run/hydro.namelist +++ /dev/null @@ -1,105 +0,0 @@ -&HYDRO_nlist - -!!!! SYSTEM COUPLING !!!! -!Specify what is being coupled: 1=HRLDAS (offline Noah-LSM), 2=WRF, 3=NASA/LIS, 4=CLM - sys_cpl = 2 - - - -!!!! MODEL INPUT DATA FILES !!! -!Specify land surface model gridded input data file...(e.g.: "geo_em.d03.nc") - GEO_STATIC_FLNM = "DOMAIN/geo_em.d03.nc" - -!Specify the high-resolution routing terrain input data file...(e.g.: "Fulldom_hires_hydrofile.nc" - GEO_FINEGRID_FLNM = "DOMAIN/Fulldom_hires_hydrofile_ohd_new_basns_w_cal_params_full_domain.nc" - -!Specify the name of the restart file if starting from restart...comment out with '!' if not... -! RESTART_FILE = 'HYDRO_RST.2012-07-21_12:00_DOMAIN2' - - - -!!!! MODEL SETUP AND I/O CONTROL !!!! -!Specify the domain or nest number identifier...(integer) - IGRID = 3 - -!Specify the restart file write frequency...(minutes) - !rst_dt = 360 - rst_dt = 30 - -!Specify the output file write frequency...(minutes) - out_dt = 15 ! minutes - -!Specify if output history files are to be written...(.TRUE. or .FALSE.) - HISTORY_OUTPUT = .TRUE. - -!Specify the number of output times to be contained within each output history file...(integer) -! SET = 1 WHEN RUNNING CHANNEL ROUTING ONLY/CALIBRATION SIMS!!! -! SET = 1 WHEN RUNNING COUPLED TO WRF!!! - SPLIT_OUTPUT_COUNT = 1 - -! rst_typ = 1 : overwrite the soil variables from routing restart file. - rst_typ = 0 - -!Restart switch to set restart accumulation variables = 0 (0-no reset, 1-yes reset to 0.0) - RSTRT_SWC = 0 - -!Output high-resolution routing files...0=none, 1=total chan_inflow ASCII time-series, 2=hires grid and chan_inflow... - HIRES_OUT = 2 - -!Specify the minimum stream order to output to netcdf point file...(integer) -!Note: lower value of stream order produces more output. - order_to_write = 1 - - - -!!!! PHYSICS OPTIONS AND RELATED SETTINGS !!!! -!Switch for terrain adjustment of incoming solar radiation: 0=no, 1=yes -!Note: This option is not yet active in Verion 1.0... -! WRF has this capability so be careful not to double apply the correction!!! - TERADJ_SOLAR = 0 - -!Specify the number of soil layers (integer) and the depth of the bottom of each layer (meters)... -! Notes: In Version 1 of WRF-Hydro these must be the same as in the namelist.input file -! Future versions will permit this to be different. - NSOIL=4 - ZSOIL8(1) = -0.10 - ZSOIL8(2) = -0.40 - ZSOIL8(3) = -1.0 - ZSOIL8(4) = -2.0 - -!Specify the grid spacing of the terrain routing grid...(meters) - DXRT = 100 - -!Specify the integer multiple between the land model grid and the terrain routing grid...(integer) - AGGFACTRT = 10 - -!Specify the routing model timestep...(seconds) - DTRT = 2 - -!Switch activate subsurface routing...(0=no, 1=yes) - SUBRTSWCRT = 1 - -!Switch activate surface overland flow routing...(0=no, 1=yes) - OVRTSWCRT = 1 - -!Switch to activate channel routing Routing Option: 1=Seepest Descent (D8) 2=CASC2D - rt_option = 1 - CHANRTSWCRT = 0 - -!Specify channel routing option: 1=Muskingam-reach, 2=Musk.-Cunge-reach, 3=Diff.Wave-gridded - channel_option =3 - -!Specify the reach file for reach-based routing options... - route_link_f = "" - -!Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through) - GWBASESWCRT = 2 - -!Specify baseflow/bucket model initialization...(0=cold start from table, 1=restart file) - GW_RESTART = 0 - -!Groundwater/baseflow mask specified on land surface model grid... -!Note: Only required if baseflow bucket model is active - gwbasmskfil = "DOMAIN/basn_msk1k_frng_ohd.txt" - -/ diff --git a/wrfv2_fire/hydro/arc/.svn/all-wcprops b/wrfv2_fire/hydro/arc/.svn/all-wcprops deleted file mode 100644 index 701f4568..00000000 --- a/wrfv2_fire/hydro/arc/.svn/all-wcprops +++ /dev/null @@ -1,65 +0,0 @@ -K 25 -svn:wc:ra_dav:version-url -V 56 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc -END -macros.mpp.gfort -K 25 -svn:wc:ra_dav:version-url -V 73 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.mpp.gfort -END -macros.mpp.ifort -K 25 -svn:wc:ra_dav:version-url -V 73 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.mpp.ifort -END -macros.seq.IBM.xlf90_r -K 25 -svn:wc:ra_dav:version-url -V 79 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.seq.IBM.xlf90_r -END -Makefile.seq -K 25 -svn:wc:ra_dav:version-url -V 69 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/Makefile.seq -END -macros.mpp.IBM.xlf90_r -K 25 -svn:wc:ra_dav:version-url -V 79 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.mpp.IBM.xlf90_r -END -Makefile.mpp -K 25 -svn:wc:ra_dav:version-url -V 69 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/Makefile.mpp -END -macros.seq.linux -K 25 -svn:wc:ra_dav:version-url -V 73 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.seq.linux -END -macros.seq.gfort -K 25 -svn:wc:ra_dav:version-url -V 73 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.seq.gfort -END -macros.mpp.linux -K 25 -svn:wc:ra_dav:version-url -V 73 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.mpp.linux -END -macros.seq.ifort -K 25 -svn:wc:ra_dav:version-url -V 73 -/!svn/ver/8351/tags/trunk_20150420_3-7_RELEASE/hydro/arc/macros.seq.ifort -END diff --git a/wrfv2_fire/hydro/arc/.svn/entries b/wrfv2_fire/hydro/arc/.svn/entries deleted file mode 100644 index 5affc035..00000000 --- a/wrfv2_fire/hydro/arc/.svn/entries +++ /dev/null @@ -1,368 +0,0 @@ -10 - -dir -9105 -https://kkeene@svn-wrf-model.cgd.ucar.edu/tags/trunk_20150420_3-7_RELEASE/hydro/arc -https://kkeene@svn-wrf-model.cgd.ucar.edu - - - -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - -b0b5d27b-6f0f-0410-a2a3-cb1e977edc3d - -macros.mpp.gfort -file - - - - -2016-02-11T20:37:49.552475Z -12187f1c1835a25d489f0bcad4f1ee8e -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -838 - -macros.mpp.ifort -file - - - - -2016-02-11T20:37:49.553462Z -6229cf85e23f4eda91a9502670a678df -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -859 - -macros.seq.IBM.xlf90_r -file - - - - -2016-02-11T20:37:49.554415Z -607dbe92225a1bfab2525e3fa7d8cea1 -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -742 - -Makefile.seq -file - - - - -2016-02-11T20:37:49.556507Z -4aa282f0ae08c6c65705d144cec193b1 -2013-11-15T19:40:36.446206Z -6964 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -571 - -macros.mpp.IBM.xlf90_r -file - - - - -2016-02-11T20:37:49.557348Z -9bfc47c368eb915db5e270025d090330 -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -827 - -Makefile.mpp -file - - - - -2016-02-11T20:37:49.559360Z -fa1ab651d6e2cc9a6aceb458ddc975a6 -2013-11-15T19:40:36.446206Z -6964 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -411 - -macros.seq.linux -file - - - - -2016-02-11T20:37:49.560391Z -545de223d8fe266c3a91fc9365039860 -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -797 - -macros.seq.gfort -file - - - - -2016-02-11T20:37:49.549654Z -47acd877f54da658b716de60139e7fcb -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -800 - -macros.mpp.linux -file - - - - -2016-02-11T20:37:49.550613Z -83a02ae424831fbb8e57ea790c35fbed -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -783 - -macros.seq.ifort -file - - - - -2016-02-11T20:37:49.551534Z -0b7e9fe9a50eb39e6232d3a58e427c62 -2014-12-05T18:15:21.639800Z -7824 -weiyu@ucar.edu - - - - - - - - - - - - - - - - - - - - - -876 - diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.mpp.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.mpp.svn-base deleted file mode 100644 index a494e8df..00000000 --- a/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.mpp.svn-base +++ /dev/null @@ -1,17 +0,0 @@ -# Makefile - -all: - (make -f Makefile.comm BASIC) - -BASIC: - (cd MPP ; make -f Makefile) - (cd Data_Rec ; make -f Makefile) - (cd Routing; make -f Makefile) - (cd HYDRO_drv; make -f Makefile) - -clean: - (cd Data_Rec; make -f Makefile clean) - (cd HYDRO_drv; make -f Makefile clean) - (cd MPP; make -f Makefile clean) - (cd Routing; make -f Makefile clean) - (rm -f lib/*.a */*.mod */*.o CPL/*/*.o CPL/*/*.mod) diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.seq.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.seq.svn-base deleted file mode 100644 index 14d8a260..00000000 --- a/wrfv2_fire/hydro/arc/.svn/text-base/Makefile.seq.svn-base +++ /dev/null @@ -1,30 +0,0 @@ -# Makefile - -all: - (make -f Makefile BASIC) - -BASIC: - (cd Data_Rec ; make -f Makefile) - (cd Routing; make -f Makefile) - (cd HYDRO_drv; make -f Makefile) - -LIS: - (make -f Makefile BASIC) - (cd LIS_cpl ; make -f Makefile) - -CLM: - (make -f Makefile BASIC) - (cd CLM_cpl ; make -f Makefile) - -WRF: - (make -f Makefile BASIC) - (cd WRF_cpl ; make -f Makefile) - -HYDRO: - (make -f Makefile BASIC) - -clean: - (cd Data_Rec; make -f Makefile clean) - (cd HYDRO_drv; make -f Makefile clean) - (cd Routing; make -f Makefile clean) - (rm -f lib/*.a */*.mod CPL/*/*.o CPL/*/*.mod) diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.IBM.xlf90_r.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.IBM.xlf90_r.svn-base deleted file mode 100644 index 67b224a7..00000000 --- a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.IBM.xlf90_r.svn-base +++ /dev/null @@ -1,37 +0,0 @@ -.IGNORE: - -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - -RM = rm -f -RMD = rm -f -COMPILER90= mpxlf90_r -F90FLAGS = -O2 -qfree=f90 -c -w -qspill=20000 -qmaxmem=64000 -LDFLAGS = -O2 -qfree=f90 -w -qspill=20000 -qmaxmem=64000 -MODFLAG = -I./ -I ../MPP -I../../MPP -I ../mod -LDFLAGS = -CPP = cpp -LIBS = -CPPFLAGS = -C -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf - diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.gfort.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.gfort.svn-base deleted file mode 100644 index f0ac6898..00000000 --- a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.gfort.svn-base +++ /dev/null @@ -1,33 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - -RMD = rm -f -COMPILER90= mpif90 -F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 -MODFLAG = -I"./" -I"../../MPP" -I"../MPP" -I"../mod" -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -xassembler-with-cpp -traditional -DMPP_LAND -I"../Data_Rec" $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.ifort.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.ifort.svn-base deleted file mode 100644 index c6f6bcf6..00000000 --- a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.ifort.svn-base +++ /dev/null @@ -1,36 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - - -RMD = rm -f -COMPILER90= mpif90 -FORMAT_FREE = -FR -BYTESWAPIO = -convert big_endian -F90FLAGS = -w -c -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO) -MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -traditional -DMPP_LAND -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.linux.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.linux.svn-base deleted file mode 100644 index 025d18de..00000000 --- a/wrfv2_fire/hydro/arc/.svn/text-base/macros.mpp.linux.svn-base +++ /dev/null @@ -1,35 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - -RM = rm -f -RMD = rm -f -COMPILER90= mpif90 -F90FLAGS = -Mfree -c -byteswapio -O2 -Kieee -LDFLAGS = $(F90FLAGS) -MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.IBM.xlf90_r.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.IBM.xlf90_r.svn-base deleted file mode 100644 index fb5c020f..00000000 --- a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.IBM.xlf90_r.svn-base +++ /dev/null @@ -1,36 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - - - -RM = rm -f -RMD = rm -f -COMPILER90= xlf90_r -F90FLAGS = -c -O2 -qfree=f90 -qmaxmem=819200 -MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod -LDFLAGS = -CPP = cpp -C -P -CPPFLAGS = -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.gfort.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.gfort.svn-base deleted file mode 100644 index a03fba3d..00000000 --- a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.gfort.svn-base +++ /dev/null @@ -1,34 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - - -RMD = rm -f -COMPILER90= gfortran -F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 -MODFLAG = -I./ -I../mod -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -xassembler-with-cpp -traditional -I"../Data_Rec" $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.ifort.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.ifort.svn-base deleted file mode 100644 index 60b64161..00000000 --- a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.ifort.svn-base +++ /dev/null @@ -1,36 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - - -RMD = rm -f -COMPILER90= ifort -##F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 -F90FLAGS = -w -c -ftz -align all -fno-alias -fp-model precise -FR -convert big_endian - -MODFLAG = -I./ -I ../mod -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.linux.svn-base b/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.linux.svn-base deleted file mode 100644 index 748bad15..00000000 --- a/wrfv2_fire/hydro/arc/.svn/text-base/macros.seq.linux.svn-base +++ /dev/null @@ -1,36 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - - -RMD = ls -RM = rm -f -COMPILER90= pgf90 -F90FLAGS = -Mfree -Mfptrap -c -byteswapio -Ktrap=fp -O2 -Kieee -LDFLAGS = $(F90FLAGS) -MODFLAG = -I./ -I ../mod -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRF_HYDRO) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/Makefile.mpp b/wrfv2_fire/hydro/arc/Makefile.mpp deleted file mode 100644 index a494e8df..00000000 --- a/wrfv2_fire/hydro/arc/Makefile.mpp +++ /dev/null @@ -1,17 +0,0 @@ -# Makefile - -all: - (make -f Makefile.comm BASIC) - -BASIC: - (cd MPP ; make -f Makefile) - (cd Data_Rec ; make -f Makefile) - (cd Routing; make -f Makefile) - (cd HYDRO_drv; make -f Makefile) - -clean: - (cd Data_Rec; make -f Makefile clean) - (cd HYDRO_drv; make -f Makefile clean) - (cd MPP; make -f Makefile clean) - (cd Routing; make -f Makefile clean) - (rm -f lib/*.a */*.mod */*.o CPL/*/*.o CPL/*/*.mod) diff --git a/wrfv2_fire/hydro/arc/Makefile.seq b/wrfv2_fire/hydro/arc/Makefile.seq deleted file mode 100644 index 14d8a260..00000000 --- a/wrfv2_fire/hydro/arc/Makefile.seq +++ /dev/null @@ -1,30 +0,0 @@ -# Makefile - -all: - (make -f Makefile BASIC) - -BASIC: - (cd Data_Rec ; make -f Makefile) - (cd Routing; make -f Makefile) - (cd HYDRO_drv; make -f Makefile) - -LIS: - (make -f Makefile BASIC) - (cd LIS_cpl ; make -f Makefile) - -CLM: - (make -f Makefile BASIC) - (cd CLM_cpl ; make -f Makefile) - -WRF: - (make -f Makefile BASIC) - (cd WRF_cpl ; make -f Makefile) - -HYDRO: - (make -f Makefile BASIC) - -clean: - (cd Data_Rec; make -f Makefile clean) - (cd HYDRO_drv; make -f Makefile clean) - (cd Routing; make -f Makefile clean) - (rm -f lib/*.a */*.mod CPL/*/*.o CPL/*/*.mod) diff --git a/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r b/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r deleted file mode 100644 index 67b224a7..00000000 --- a/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r +++ /dev/null @@ -1,37 +0,0 @@ -.IGNORE: - -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - -RM = rm -f -RMD = rm -f -COMPILER90= mpxlf90_r -F90FLAGS = -O2 -qfree=f90 -c -w -qspill=20000 -qmaxmem=64000 -LDFLAGS = -O2 -qfree=f90 -w -qspill=20000 -qmaxmem=64000 -MODFLAG = -I./ -I ../MPP -I../../MPP -I ../mod -LDFLAGS = -CPP = cpp -LIBS = -CPPFLAGS = -C -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf - diff --git a/wrfv2_fire/hydro/arc/macros.mpp.gfort b/wrfv2_fire/hydro/arc/macros.mpp.gfort deleted file mode 100644 index f0ac6898..00000000 --- a/wrfv2_fire/hydro/arc/macros.mpp.gfort +++ /dev/null @@ -1,33 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - -RMD = rm -f -COMPILER90= mpif90 -F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 -MODFLAG = -I"./" -I"../../MPP" -I"../MPP" -I"../mod" -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -xassembler-with-cpp -traditional -DMPP_LAND -I"../Data_Rec" $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.mpp.ifort b/wrfv2_fire/hydro/arc/macros.mpp.ifort deleted file mode 100644 index c6f6bcf6..00000000 --- a/wrfv2_fire/hydro/arc/macros.mpp.ifort +++ /dev/null @@ -1,36 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - - -RMD = rm -f -COMPILER90= mpif90 -FORMAT_FREE = -FR -BYTESWAPIO = -convert big_endian -F90FLAGS = -w -c -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO) -MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -traditional -DMPP_LAND -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.mpp.linux b/wrfv2_fire/hydro/arc/macros.mpp.linux deleted file mode 100644 index 025d18de..00000000 --- a/wrfv2_fire/hydro/arc/macros.mpp.linux +++ /dev/null @@ -1,35 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - -RM = rm -f -RMD = rm -f -COMPILER90= mpif90 -F90FLAGS = -Mfree -c -byteswapio -O2 -Kieee -LDFLAGS = $(F90FLAGS) -MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r b/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r deleted file mode 100644 index fb5c020f..00000000 --- a/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r +++ /dev/null @@ -1,36 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - - - -RM = rm -f -RMD = rm -f -COMPILER90= xlf90_r -F90FLAGS = -c -O2 -qfree=f90 -qmaxmem=819200 -MODFLAG = -I./ -I ../../MPP -I ../MPP -I ../mod -LDFLAGS = -CPP = cpp -C -P -CPPFLAGS = -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.seq.gfort b/wrfv2_fire/hydro/arc/macros.seq.gfort deleted file mode 100644 index a03fba3d..00000000 --- a/wrfv2_fire/hydro/arc/macros.seq.gfort +++ /dev/null @@ -1,34 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - - -RMD = rm -f -COMPILER90= gfortran -F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 -MODFLAG = -I./ -I../mod -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -xassembler-with-cpp -traditional -I"../Data_Rec" $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.seq.ifort b/wrfv2_fire/hydro/arc/macros.seq.ifort deleted file mode 100644 index 60b64161..00000000 --- a/wrfv2_fire/hydro/arc/macros.seq.ifort +++ /dev/null @@ -1,36 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - - -RMD = rm -f -COMPILER90= ifort -##F90FLAGS = -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 -F90FLAGS = -w -c -ftz -align all -fno-alias -fp-model precise -FR -convert big_endian - -MODFLAG = -I./ -I ../mod -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/arc/macros.seq.linux b/wrfv2_fire/hydro/arc/macros.seq.linux deleted file mode 100644 index 748bad15..00000000 --- a/wrfv2_fire/hydro/arc/macros.seq.linux +++ /dev/null @@ -1,36 +0,0 @@ -.IGNORE: -ifeq ($(WRF_HYDRO),1) -WRF_HYDRO = -DWRF_HYDRO -else -WRF_HYDRO = -endif - -ifeq ($(WRF_HYDRO_RAPID),1) -WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID -endif - -ifeq ($(HYDRO_D),1) -HYDRO_D = -DHYDRO_D $(WRF_HYDRO) -else -HYDRO_D = $(WRF_HYDRO) -endif - -ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1) -WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT -else -WRFIO_NCD_LARGE_FILE_SUPPORT = -endif - - -RMD = ls -RM = rm -f -COMPILER90= pgf90 -F90FLAGS = -Mfree -Mfptrap -c -byteswapio -Ktrap=fp -O2 -Kieee -LDFLAGS = $(F90FLAGS) -MODFLAG = -I./ -I ../mod -LDFLAGS = -CPP = cpp -CPPFLAGS = -C -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRF_HYDRO) $(WRFIO_NCD_LARGE_FILE_SUPPORT) -LIBS = -NETCDFINC = $(NETCDF_INC) -NETCDFLIB = -L$(NETCDF_LIB) -lnetcdff -lnetcdf diff --git a/wrfv2_fire/hydro/configure b/wrfv2_fire/hydro/configure deleted file mode 100755 index 5848f116..00000000 --- a/wrfv2_fire/hydro/configure +++ /dev/null @@ -1,107 +0,0 @@ -#!/usr/bin/perl - - if(! defined($ENV{NETCDF_INC})){ - if(defined($ENV{NETCDF})) { - $tt = `echo "NETCDF_INC = \${NETCDF}/include" > macros.tmp` ; - } else { - print"Error: environment variable NETCDF_INC not defined. \n"; - exit(0); - } - } - - ${NETCDF_LIB} = $ENV{NETCDF_LIB}; - if(! defined($ENV{NETCDF_LIB})){ - if(defined($ENV{NETCDF})) { - $tt = `echo "NETCDF_LIB = \${NETCDF}/lib" >> macros.tmp` ; - ${NETCDF_LIB} = $ENV{NETCDF}."/lib"; - } else { - print"Error: environment variable NETCDF_LIB not defined. \n"; - exit(0); - } - } - - if(! -e "${NETCDF_LIB}/libnetcdff.a"){ - $tt = `echo "NETCDFLIB = -L${NETCDF_LIB} -lnetcdf" >> macros.tmp `; - } - - if(-e macros) {system (rm -f macros);} -# if(-e Makefile) {system "rm -f Makefile" ;} - -# system("cp arc/Makefile ."); - - if($#ARGV == 0) { - $response = shift(@ARGV) ; - print("Configure hydro: $response \n"); - }else { - print "Please select from following supported options. \n\n"; - - print " 1. Linux PGI compiler sequential \n"; - print " 2. Linux PGI compiler dmpar \n"; - print " 3. IBM AIX compiler sequential, xlf90_r\n"; - print " 4. IBM AIX compiler dmpar \n"; - print " 5. Linux gfort compiler sequential \n"; - print " 6. Linux gfort compiler dmpar \n"; - print " 7. Linux ifort compiler sequential \n"; - print " 8. Linux ifort compiler dmpar \n"; - print " 0. exit only \n"; - - printf "\nEnter selection [%d-%d] : ",1,5 ; - - $response = ; - chop($response); - } - - use Switch; - switch ($response) { - case 1 { - # sequential linux - system "cp arc/macros.seq.linux macros"; - system "cp arc/Makefile.seq Makefile.comm"; - } - - case 2 { - # mpp linux - system "cp arc/macros.mpp.linux macros"; - system "cp arc/Makefile.mpp Makefile.comm"; - } - - case 3 { - # sequential IBM AIX - system "cp arc/macros.seq.IBM.xlf90_r macros"; - system "cp arc/Makefile.seq Makefile.comm"; - } - - case 4 { - # mpp IBM AIX - system "cp arc/macros.mpp.IBM.xlf90_r macros"; - system "cp arc/Makefile.mpp Makefile.comm"; - } - - case 5 { - # GFORTRAN only - system "cp arc/macros.seq.gfort macros"; - system "cp arc/Makefile.seq Makefile.comm"; - } - - case 6 { - # GFORTRAN dmpar only - system "cp arc/macros.mpp.gfort macros"; - system "cp arc/Makefile.mpp Makefile.comm"; - } - case 7 { - # ifort sequential - system "cp arc/macros.seq.ifort macros"; - system "cp arc/Makefile.seq Makefile.comm"; - } - case 8 { - # ifort dmpar only - system "cp arc/macros.mpp.ifort macros"; - system "cp arc/Makefile.mpp Makefile.comm"; - } - - else {print "no selection $response\n"; last} - } - if(! (-e lib)) {mkdir lib;} - if(! (-e mod)) {mkdir mod;} - if(-e "macros.tmp") { system("cat macros macros.tmp > macros.a; rm -f macros.tmp; mv macros.a macros");} - if((-d "LandModel") ) {system "cat macros LandModel/user_build_options.bak > LandModel/user_build_options";} diff --git a/wrfv2_fire/hydro/wrf_hydro_config b/wrfv2_fire/hydro/wrf_hydro_config deleted file mode 100755 index 47548324..00000000 --- a/wrfv2_fire/hydro/wrf_hydro_config +++ /dev/null @@ -1,28 +0,0 @@ -#!/usr/bin/perl -#input argument: Compiler/System sequential/parallel -#This is called by WRF configuration only. -if($#ARGV ne 1) { - print("Error: No such configuration for Hydro \n"); - exit(1); -} - $x = lc(shift(@ARGV)); - $paropt = lc(shift(@ARGV)); - - print("Configure option for Hydro : $x $paropt \n"); - if($x =~ "pgi") { - if($paropt eq 'serial') { system("./configure 1");} - else {system("./configure 2");} - } - if($x =~ "aix") { - if($paropt eq 'serial') { system("./configure 3");} - else {system("./configure 4");} - } - if($x =~ "gfortran") { - if($paropt eq 'serial') { system("./configure 5");} - else {system("./configure 6");} - } - if($x =~ "ifort") { - if($paropt eq 'serial') { system("./configure 7");} - else {system("./configure 8");} - } - diff --git a/wrfv2_fire/inc/version_decl b/wrfv2_fire/inc/version_decl index fa58cdcc..a1412807 100644 --- a/wrfv2_fire/inc/version_decl +++ b/wrfv2_fire/inc/version_decl @@ -1 +1 @@ - CHARACTER (LEN=10) :: release_version = 'V3.7 ' + CHARACTER (LEN=10) :: release_version = 'V3.8 ' diff --git a/wrfv2_fire/main/Makefile b/wrfv2_fire/main/Makefile index 34c9761b..b8074657 100644 --- a/wrfv2_fire/main/Makefile +++ b/wrfv2_fire/main/Makefile @@ -13,35 +13,35 @@ LIBPATHS = include ../configure.wrf $(SOLVER)_wrf : wrf.o ../main/module_wrf_top.o - $(RANLIB) $(LIBWRFLIB) + $(RANLIB) $(RLFLAGS) $(LIBWRFLIB) $(LD) -o wrf.exe $(LDFLAGS) wrf.o ../main/module_wrf_top.o $(LIBWRFLIB) $(LIB) $(SOLVER)_wrf_SST_ESMF : wrf_ESMFMod.o wrf_SST_ESMF.o ../main/module_wrf_top.o - $(RANLIB) $(LIBWRFLIB) + $(RANLIB) $(RLFLAGS) $(LIBWRFLIB) $(LD) -o wrf_SST_ESMF.exe $(LDFLAGS) wrf_SST_ESMF.o wrf_ESMFMod.o ../main/module_wrf_top.o $(LIBWRFLIB) $(LIB) $(SOLVER)_ideal : module_initialize ideal_$(SOLVER).o - $(RANLIB) $(LIBWRFLIB) + $(RANLIB) $(RLFLAGS) $(LIBWRFLIB) $(LD) -o ideal.exe $(LDFLAGS) ideal_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) $(SOLVER)_real : module_initialize ndown_$(SOLVER).o nup_$(SOLVER).o tc_$(SOLVER).o real_$(SOLVER).o - $(RANLIB) $(LIBWRFLIB) + $(RANLIB) $(RLFLAGS) $(LIBWRFLIB) $(LD) -o ndown.exe $(LDFLAGS) ndown_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) #TEMPORARILY REMOVED $(LD) -o nup.exe $(LDFLAGS) nup_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) $(LD) -o tc.exe $(LDFLAGS) tc_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) $(LD) -o real.exe $(LDFLAGS) real_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) convert_em : convert_em.o - $(RANLIB) $(LIBWRFLIB) + $(RANLIB) $(RLFLAGS) $(LIBWRFLIB) $(LD) -o convert_em.exe $(LDFLAGS) convert_em.o $(LIBWRFLIB) $(LIB) convert_nmm : convert_nmm.o - $(RANLIB) $(LIBWRFLIB) + $(RANLIB) $(RLFLAGS) $(LIBWRFLIB) $(FC) -o convert_nmm.exe $(LDFLAGS) convert_nmm.o $(LIBWRFLIB) $(LIB) real_nmm : real_nmm.o ( cd ../dyn_nmm ; $(MAKE) module_initialize_real.o ) - $(RANLIB) $(LIBWRFLIB) + $(RANLIB) $(RLFLAGS) $(LIBWRFLIB) $(FC) -o real_nmm.exe $(LDFLAGS) real_nmm.o $(LIBWRFLIB) $(LIB) module_initialize : ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o @@ -49,7 +49,7 @@ module_initialize : ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o ## prevent real being compiled for OMP -- only for regtesting #$(SOLVER)_real : module_initialize real_$(SOLVER).o -# $(RANLIB) $(LIBWRFLIB) +# $(RANLIB) $(RLFLAGS) $(LIBWRFLIB) # if [ -z "$(OMP)" ] ; then $(FC) -o real.exe $(LDFLAGS) real_$(SOLVER).o ../dyn_$(SOLVER)/module_initialize_$(IDEAL_CASE).o $(LIBWRFLIB) $(LIB) ; fi # ## prevent module_initialize being compiled for OMP --remove after IBM debugging diff --git a/wrfv2_fire/main/depend.common b/wrfv2_fire/main/depend.common index cd8ec584..89edc6c9 100644 --- a/wrfv2_fire/main/depend.common +++ b/wrfv2_fire/main/depend.common @@ -14,7 +14,8 @@ module_dm.o: module_machine.o module_state_description.o module_wrf_error.o \ module_timing.o \ module_comm_nesting_dm.o \ module_configure.o module_comm_dm.o \ - module_cpl.o + module_cpl.o \ + ../share/module_model_constants.o module_timing.o: hires_timer.o clog.o @@ -78,6 +79,7 @@ module_integrate.o: \ module_nesting.o \ module_configure.o \ module_cpl.o \ + module_dm.o \ $(ESMF_MOD_DEPENDENCE) module_intermediate_nmm.o: \ @@ -226,6 +228,7 @@ module_bl_fogdes.o: ../share/module_model_constants.o \ module_sf_gfdl.o : \ module_gfs_machine.o \ + module_sf_exchcoef.o \ module_gfs_funcphys.o \ module_gfs_physcons.o @@ -549,6 +552,7 @@ module_physics_init.o : \ module_mp_wsm5.o \ module_mp_wsm6.o \ module_mp_etanew.o \ + module_mp_fer_hires.o \ module_mp_HWRF.o \ module_fdda_psufddagd.o \ module_fdda_spnudging.o \ @@ -580,7 +584,7 @@ module_microphysics_driver.o: \ module_mp_kessler.o module_mp_sbu_ylin.o module_mp_lin.o \ module_mp_wsm3.o module_mp_wsm5.o \ module_mp_wsm6.o module_mp_etanew.o \ - module_mp_HWRF.o \ + module_mp_fer_hires.o module_mp_HWRF.o \ module_mp_thompson.o \ module_mp_gsfcgce.o \ module_mp_morr_two_moment.o \ @@ -715,6 +719,7 @@ module_diagnostics_driver.o: \ module_diag_misc.o \ module_diag_cl.o \ module_diag_pld.o \ + module_diag_zld.o \ module_diag_afwa.o \ ../frame/module_comm_dm.o \ ../frame/module_state_description.o \ @@ -733,6 +738,9 @@ module_diag_cl.o: \ module_diag_pld.o: \ ../share/module_model_constants.o +module_diag_zld.o: \ + ../share/module_model_constants.o + module_diag_afwa_hail.o: module_diag_afwa.o: \ @@ -928,7 +936,7 @@ dfi.o : ../frame/module_wrf_error.o ../frame/module_configure.o \ module_optional_input.o: module_io_wrf.o module_io_domain.o \ ../frame/module_domain.o ../frame/module_configure.o -mediation_wrfmain.o: ../frame/module_domain.o ../frame/module_configure.o \ +mediation_wrfmain.o: ../frame/module_domain.o ../frame/module_configure.o ../frame/module_dm.o \ ../frame/module_timing.o $(ESMF_MOD_DEPENDENCE) \ module_bc_time_utilities.o module_io_domain.o diff --git a/wrfv2_fire/main/ideal_nmm.F b/wrfv2_fire/main/ideal_nmm.F index 4fb85b32..ad434c24 100644 --- a/wrfv2_fire/main/ideal_nmm.F +++ b/wrfv2_fire/main/ideal_nmm.F @@ -215,7 +215,7 @@ END SUBROUTINE start_domain ! Local INTEGER :: time_step_begin_restart INTEGER :: idsi , ierr , myproc - CHARACTER (LEN=80) :: si_inpname + CHARACTER (LEN=256) :: si_inpname CHARACTER (LEN=132) :: message CHARACTER(LEN=19) :: start_date_char , end_date_char , & @@ -243,7 +243,7 @@ END SUBROUTINE start_domain INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y #endif -#if defined(HWRF) +#if ( HWRF == 1 ) ! Sam Says: ! The *INIT arrays are used to read init data written out by hwrf_prep_hybrid @@ -336,7 +336,7 @@ END SUBROUTINE start_domain write(message,*) 'TRIM(config_flags%auxinput1_inname): ', TRIM(config_flags%auxinput1_inname) CALL wrf_message(message) -#if defined(HWRF) +#if ( HWRF == 1 ) ifph_onlyfirst: if(.not.grid%use_prep_hybrid .or. loop==1) then #endif IF (config_flags%auxinput1_inname(1:10) .eq. 'real_input') THEN @@ -344,10 +344,8 @@ END SUBROUTINE start_domain ENDIF SELECT CASE ( use_package(io_form_auxinput1) ) -#if defined(NETCDF) || defined(PNETCDF) || defined(PIO) +#if defined(NETCDF) CASE ( IO_NETCDF ) - CASE ( IO_PNETCDF ) - CASE ( IO_PIO ) ! Open the wrfinput file. @@ -422,7 +420,7 @@ END SUBROUTINE start_domain CASE DEFAULT CALL wrf_error_fatal('ideal_hwrf: not valid io_form_auxinput1') END SELECT -#if defined(HWRF) +#if ( HWRF == 1 ) endif ifph_onlyfirst #endif @@ -440,7 +438,7 @@ END SUBROUTINE start_domain CALL init_domain ( grid ) -#if defined(HWRF) +#if ( HWRF == 1 ) read_phinit: if(grid%use_prep_hybrid) then #if defined(DM_PARALLEL) if(.not. wrf_dm_on_monitor()) then @@ -698,7 +696,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) USE module_bc IMPLICIT NONE -#if defined(HWRF) +#if ( HWRF == 1 ) external get_wrf_debug_level integer :: debug #endif @@ -739,7 +737,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y #endif -#if defined(HWRF) +#if ( HWRF == 1 ) ! Sam says: ! The *B arrays are used to read boundary data written out by hwrf_prep_hybrid @@ -760,7 +758,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) #include "deref_kludge.h" -#if defined(HWRF) +#if ( HWRF == 1 ) alloc_ph_arrays=.false. call get_wrf_debug_level(debug) #endif @@ -1099,7 +1097,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) !----------------------------------------------------------------------- call wrf_debug(1,'LOOP>1, so start making non-init boundary conditions') -#if defined(HWRF) +#if ( HWRF == 1 ) bdytmp_useph: if(grid%use_prep_hybrid) then call wrf_debug(1,'ALLOCATE PREP_HYBRID BOUNDARY ARRAYS') @@ -1311,7 +1309,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) CALL output_auxinput4 ( id4, grid , config_flags , ierr ) -#if defined( HWRF) +#if ( HWRF == 1 ) endif bdytmp_useph #endif @@ -1335,7 +1333,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) CALL domain_clockadvance( grid ) END IF -#if defined(HWRF) +#if ( HWRF == 1 ) bdytmp_notph: if(.not.grid%use_prep_hybrid) then #endif !----------------------------------------------------------------------- @@ -1465,7 +1463,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) endif END DO ENDIF -#if defined(HWRF) +#if ( HWRF == 1 ) endif bdytmp_notph #endif !----------------------------------------------------------------------- @@ -1673,7 +1671,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) END IF main_loop_test -#if defined(HWRF) +#if ( HWRF == 1 ) if(alloc_ph_arrays) then call wrf_debug(1,'DEALLOCATE PREP_HYBRID BOUNARY ARRAYS') deallocate(TB,QB,CWMB,UB,VB,PDB) diff --git a/wrfv2_fire/main/module_wrf_top.F b/wrfv2_fire/main/module_wrf_top.F index 65cdcf1c..d04e3135 100644 --- a/wrfv2_fire/main/module_wrf_top.F +++ b/wrfv2_fire/main/module_wrf_top.F @@ -21,7 +21,9 @@ MODULE module_wrf_top USE module_nesting #ifdef DM_PARALLEL - USE module_dm, ONLY : wrf_dm_initialize,wrf_get_hostid + USE module_dm, ONLY : wrf_dm_initialize,wrf_get_hostid,domain_active_this_task,mpi_comm_allcompute +#else + USE module_dm, ONLY : domain_active_this_task #endif USE module_cpl, ONLY : coupler_on, cpl_finalize, cpl_defdomain @@ -52,7 +54,7 @@ MODULE module_wrf_top LOGICAL , EXTERNAL :: wrf_dm_on_monitor #endif - CHARACTER (LEN=80) :: rstname + CHARACTER (LEN=256) :: rstname CHARACTER (LEN=80) :: message CHARACTER (LEN=256) , PRIVATE :: a_message @@ -109,11 +111,12 @@ SUBROUTINE wrf_init( no_init1 ) use accel_lib #endif LOGICAL, OPTIONAL, INTENT(IN) :: no_init1 - INTEGER i, myproc, nproc, hostid, loccomm, ierr, buddcounter, mydevice + INTEGER i, myproc, nproc, hostid, loccomm, ierr, buddcounter, mydevice, save_comm INTEGER, ALLOCATABLE :: hostids(:), budds(:) CHARACTER*512 hostname + CHARACTER*512 mminlu_loc #ifdef _ACCEL - integer :: it, nt, in, devnum + INTEGER :: it, nt, in, devnum #endif #if defined(DM_PARALLEL) && !defined(STUBMPI) && ( defined(RUN_ON_GPU) || defined(_ACCEL)) include "mpif.h" @@ -165,6 +168,8 @@ SUBROUTINE wrf_init( no_init1 ) ! #ifdef DM_PARALLEL + CALL wrf_get_dm_communicator( save_comm ) + CALL wrf_set_dm_communicator( mpi_comm_allcompute ) IF ( wrf_dm_on_monitor() ) THEN CALL initial_config ENDIF @@ -172,6 +177,7 @@ SUBROUTINE wrf_init( no_init1 ) CALL wrf_dm_bcast_bytes( configbuf, nbytes ) CALL set_config_as_buffer( configbuf, configbuflen ) CALL wrf_dm_initialize + CALL wrf_set_dm_communicator( save_comm ) #else CALL initial_config #endif @@ -316,6 +322,7 @@ SUBROUTINE wrf_init( no_init1 ) CALL wrf_message ( program_name ) CALL wrf_debug ( 100 , 'wrf: calling alloc_and_configure_domain ' ) CALL alloc_and_configure_domain ( domain_id = 1 , & + active_this_task = domain_active_this_task(1), & grid = head_grid , & parent = null_domain , & kid = -1 ) @@ -328,9 +335,12 @@ SUBROUTINE wrf_init( no_init1 ) CALL init_wrfio #ifdef DM_PARALLEL + CALL wrf_get_dm_communicator( save_comm ) + CALL wrf_set_dm_communicator( mpi_comm_allcompute ) CALL get_config_as_buffer( configbuf, configbuflen, nbytes ) CALL wrf_dm_bcast_bytes( configbuf, nbytes ) CALL set_config_as_buffer( configbuf, configbuflen ) + CALL wrf_set_dm_communicator( save_comm ) #endif ! #if (EM_CORE == 1) @@ -363,6 +373,7 @@ SUBROUTINE wrf_init( no_init1 ) ! ! + IF ( domain_active_this_task(1) ) THEN CALL med_initialdata_input( head_grid , config_flags ) IF ( config_flags%write_restart_at_0h ) THEN @@ -377,11 +388,13 @@ SUBROUTINE wrf_init( no_init1 ) CALL wrf_finalize( ) #endif END IF + ENDIF ! domain_active_this_task ! set default values for subtimes head_grid%start_subtime = domain_get_start_time ( head_grid ) head_grid%stop_subtime = domain_get_stop_time ( head_grid ) + IF ( domain_active_this_task(1) ) THEN ! For EM (but not DA), if this is a DFI run, we can allocate some space. We are ! not allowing anyting tricky for nested DFI. If there are any nested domains, ! they all need to start at the same time. Otherwise, why even do the DFI? If @@ -395,6 +408,7 @@ SUBROUTINE wrf_init( no_init1 ) #endif IF (coupler_on) CALL cpl_defdomain( head_grid ) + ENDIF ! domain_active_this_task END SUBROUTINE wrf_init diff --git a/wrfv2_fire/main/ndown_em.F b/wrfv2_fire/main/ndown_em.F index d2788a30..af87151d 100644 --- a/wrfv2_fire/main/ndown_em.F +++ b/wrfv2_fire/main/ndown_em.F @@ -86,7 +86,7 @@ END SUBROUTINE vertical_interp REAL , DIMENSION(:,:,:) , ALLOCATABLE :: sbdy3dtemp1 , sbdy3dtemp2 REAL , DIMENSION(:,:,:,:) , ALLOCATABLE :: cbdy3dtemp0 REAL , DIMENSION(:,:,:,:) , ALLOCATABLE :: qbdy3dtemp1_coupled, qbdy3dtemp2_coupled - REAL , DIMENSION(:,:,:,:) , ALLOCATABLE :: sbdy3dtemp0 + REAL , DIMENSION(:,:,:,:) , ALLOCATABLE :: sbdy3dtemp1_coupled, sbdy3dtemp2_coupled CHARACTER(LEN=19) :: start_date_char , current_date_char , end_date_char CHARACTER(LEN=19) :: stopTimeStr @@ -121,8 +121,8 @@ END SUBROUTINE vertical_interp #endif INTEGER :: idsi - CHARACTER (LEN=80) :: inpname , outname , bdyname - CHARACTER (LEN=80) :: si_inpname + CHARACTER (LEN=256) :: inpname , outname , bdyname + CHARACTER (LEN=256) :: si_inpname character *19 :: temp19 character *24 :: temp24 , temp24b character(len=24) :: start_date_hold @@ -542,9 +542,10 @@ END SUBROUTINE vert_cor ALLOCATE ( cbdy3dtemp0(ims:ime,kms:kme,jms:jme,1:num_chem) ) ALLOCATE ( cbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) ALLOCATE ( cbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) - ALLOCATE ( sbdy3dtemp0(ims:ime,kms:kme,jms:jme,1:num_scalar) ) ALLOCATE ( sbdy3dtemp1(ims:ime,kms:kme,jms:jme) ) ALLOCATE ( sbdy3dtemp2(ims:ime,kms:kme,jms:jme) ) + ALLOCATE ( sbdy3dtemp1_coupled(ims:ime,kms:kme,jms:jme,1:num_scalar) ) + ALLOCATE ( sbdy3dtemp2_coupled(ims:ime,kms:kme,jms:jme,1:num_scalar) ) END IF @@ -807,6 +808,12 @@ END SUBROUTINE vert_cor ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) qbdy3dtemp1_coupled(:,:,:,nvmoist) = qbdy3dtemp1 END DO + DO nvscalar=PARAM_FIRST_SCALAR, num_scalar + CALL couple ( nested_grid%mu_2 , nested_grid%mub , sbdy3dtemp1 , nested_grid%scalar(ims:ime,kms:kme,jms:jme,nvscalar) , & + 't' , nested_grid%msfty , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + sbdy3dtemp1_coupled(:,:,:,nvscalar) = sbdy3dtemp1 + END DO DO j = jps , jpe DO i = ips , ipe @@ -854,7 +861,7 @@ END SUBROUTINE vert_cor END DO DO nvscalar=PARAM_FIRST_SCALAR, num_scalar - sbdy3dtemp1 = nested_grid%scalar(:,:,:,nvscalar) + sbdy3dtemp1 = sbdy3dtemp1_coupled(:,:,:,nvscalar) CALL stuff_bdy ( sbdy3dtemp1 , nested_grid%scalar_bxs(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & nested_grid%scalar_bxe(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & nested_grid%scalar_bys(ims:ime,kms:kme,1:spec_bdy_width,nvscalar), & @@ -863,7 +870,6 @@ END SUBROUTINE vert_cor ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe ) - sbdy3dtemp0(:,:,:,nvscalar) = sbdy3dtemp1 END DO CALL stuff_bdy ( mbdy2dtemp1 , nested_grid%mu_bxs, nested_grid%mu_bxe, & @@ -916,6 +922,12 @@ END SUBROUTINE vert_cor ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) qbdy3dtemp2_coupled(:,:,:,nvmoist) = qbdy3dtemp2 END DO + DO nvscalar=PARAM_FIRST_SCALAR, num_scalar + CALL couple ( nested_grid%mu_2 , nested_grid%mub , sbdy3dtemp2 , nested_grid%scalar(ims:ime,kms:kme,jms:jme,nvscalar) , & + 't' , nested_grid%msfty , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + sbdy3dtemp2_coupled(:,:,:,nvscalar) = sbdy3dtemp2 + END DO DO j = jps , jpe DO i = ips , ipe @@ -975,19 +987,18 @@ END SUBROUTINE vert_cor END DO DO nvscalar=PARAM_FIRST_SCALAR, num_scalar - sbdy3dtemp1=sbdy3dtemp0(:,:,:,nvscalar) - sbdy3dtemp2=nested_grid%scalar(:,:,:,nvscalar) + sbdy3dtemp1 = sbdy3dtemp1_coupled(:,:,:,nvscalar) + sbdy3dtemp2 = sbdy3dtemp2_coupled(:,:,:,nvscalar) CALL stuff_bdytend ( sbdy3dtemp2 , sbdy3dtemp1 , new_bdy_frq , & - nested_grid%scalar_btxs(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & - nested_grid%scalar_btxe(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & - nested_grid%scalar_btys(ims:ime,kms:kme,1:spec_bdy_width,nvscalar), & - nested_grid%scalar_btye(ims:ime,kms:kme,1:spec_bdy_width,nvscalar), & + nested_grid%scalar_btxs(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & + nested_grid%scalar_btxe(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & + nested_grid%scalar_btys(ims:ime,kms:kme,1:spec_bdy_width,nvscalar), & + nested_grid%scalar_btye(ims:ime,kms:kme,1:spec_bdy_width,nvscalar), & 'T' , & spec_bdy_width, & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe ) - sbdy3dtemp0(:,:,:,nvscalar)=sbdy3dtemp2 END DO CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq , & @@ -1077,6 +1088,7 @@ END SUBROUTINE vert_cor tbdy3dtemp1(i,k,j) = tbdy3dtemp2(i,k,j) pbdy3dtemp1(i,k,j) = pbdy3dtemp2(i,k,j) qbdy3dtemp1_coupled(i,k,j,:) = qbdy3dtemp2_coupled(i,k,j,:) + sbdy3dtemp1_coupled(i,k,j,:) = sbdy3dtemp2_coupled(i,k,j,:) END DO END DO END DO @@ -1132,12 +1144,12 @@ END SUBROUTINE vert_cor END DO DO nvscalar=PARAM_FIRST_SCALAR, num_scalar - sbdy3dtemp1=sbdy3dtemp0(:,:,:,nvscalar) + sbdy3dtemp1 = sbdy3dtemp1_coupled(:,:,:,nvscalar) CALL stuff_bdy ( sbdy3dtemp1 , & - nested_grid%scalar_bxs(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & - nested_grid%scalar_bxe(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & - nested_grid%scalar_bys(ims:ime,kms:kme,1:spec_bdy_width,nvscalar), & - nested_grid%scalar_bye(ims:ime,kms:kme,1:spec_bdy_width,nvscalar), & + nested_grid%scalar_bxs(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & + nested_grid%scalar_bxe(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & + nested_grid%scalar_bys(ims:ime,kms:kme,1:spec_bdy_width,nvscalar), & + nested_grid%scalar_bye(ims:ime,kms:kme,1:spec_bdy_width,nvscalar), & 'T' , spec_bdy_width, & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & @@ -1195,6 +1207,12 @@ END SUBROUTINE vert_cor ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) qbdy3dtemp2_coupled(:,:,:,nvmoist) = qbdy3dtemp2 END DO + DO nvscalar=PARAM_FIRST_SCALAR, num_scalar + CALL couple ( nested_grid%mu_2 , nested_grid%mub , sbdy3dtemp2 , nested_grid%scalar(ims:ime,kms:kme,jms:jme,nvscalar) , & + 't' , nested_grid%msfty , & + ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe ) + sbdy3dtemp2_coupled(:,:,:,nvscalar) = sbdy3dtemp2 + END DO mbdy2dtemp2(:,1,:) = nested_grid%mu_2(:,:) ! During all of the loops after the first loop, we first compute the boundary @@ -1272,8 +1290,8 @@ END SUBROUTINE vert_cor END DO DO nvscalar=PARAM_FIRST_SCALAR, num_scalar - sbdy3dtemp1=sbdy3dtemp0(:,:,:,nvscalar) - sbdy3dtemp2=nested_grid%scalar(:,:,:,nvscalar) + sbdy3dtemp1 = sbdy3dtemp1_coupled(:,:,:,nvscalar) + sbdy3dtemp2 = sbdy3dtemp2_coupled(:,:,:,nvscalar) CALL stuff_bdytend ( sbdy3dtemp2 , sbdy3dtemp1 , new_bdy_frq , & nested_grid%scalar_btxs(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & nested_grid%scalar_btxe(jms:jme,kms:kme,1:spec_bdy_width,nvscalar), & @@ -1284,7 +1302,6 @@ END SUBROUTINE vert_cor ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe ) - sbdy3dtemp0(:,:,:,nvscalar)=cbdy3dtemp2 END DO CALL stuff_bdytend ( mbdy2dtemp2 , mbdy2dtemp1 , new_bdy_frq , & diff --git a/wrfv2_fire/main/nup_em.F b/wrfv2_fire/main/nup_em.F index 17189ee6..c86f48bf 100644 --- a/wrfv2_fire/main/nup_em.F +++ b/wrfv2_fire/main/nup_em.F @@ -171,7 +171,7 @@ END SUBROUTINE nup CHARACTER (LEN=80) :: si_inpname CHARACTER *19 :: temp19 CHARACTER *24 :: temp24 , temp24b - CHARACTER *132 :: fname + CHARACTER *256 :: fname CHARACTER(len=24) :: start_date_hold CHARACTER (LEN=80) :: message diff --git a/wrfv2_fire/main/real_em.F b/wrfv2_fire/main/real_em.F index c8ce23ba..ee4e2a2e 100644 --- a/wrfv2_fire/main/real_em.F +++ b/wrfv2_fire/main/real_em.F @@ -128,6 +128,13 @@ END SUBROUTINE Setup_Timekeeping #else CALL initial_config #endif + + ! There are variables in the Registry that are only required for the real + ! program, fields that come from the WPS package. We define the run-time + ! flag that says to allocate space for these input-from-WPS-only arrays. + + CALL nl_set_use_wps_input ( 1 , REALONLY ) + CALL check_nml_consistency CALL set_physics_rconfigs @@ -136,12 +143,6 @@ END SUBROUTINE Setup_Timekeeping CALL wrf_message ( program_name ) - ! There are variables in the Registry that are only required for the real - ! program, fields that come from the WPS package. We define the run-time - ! flag that says to allocate space for these input-from-WPS-only arrays. - - CALL nl_set_use_wps_input ( 1 , REALONLY ) - ! Allocate the space for the mother of all domains. NULLIFY( null_domain ) @@ -236,9 +237,13 @@ END SUBROUTINE Setup_Timekeeping ok_so_far = .TRUE. + !DJW changed the check below so that instead of always comparing + !to d01 we now compare vertical levels between a grid and its parent. + !If 4 domains were used, this allows for vertical nesting to be enabled between grids 1 & 2 and + !between grids 3 & 4, but allows you to not use vertical grid nesting between grids 2 & 3. DO loop = 2 , model_config_rec%max_dom - IF ( model_config_rec%vert_refine_method(loop) .EQ. 0 ) THEN - IF ( model_config_rec%e_vert(loop) .NE. model_config_rec%e_vert(1) ) THEN + IF (( model_config_rec%vert_refine_method(loop) .EQ. 0 ) .AND. ( model_config_rec%vert_refine_fact .EQ. 1 )) THEN + IF ( model_config_rec%e_vert(loop) .NE. model_config_rec%e_vert(model_config_rec%parent_id(loop)) ) THEN CALL wrf_message ( 'e_vert must be the same for each domain' ) ok_so_far = .FALSE. END IF @@ -324,7 +329,7 @@ END SUBROUTINE start_domain ! Local INTEGER :: time_step_begin_restart INTEGER :: idsi , ierr , myproc - CHARACTER (LEN=80) :: si_inpname + CHARACTER (LEN=256) :: si_inpname CHARACTER (LEN=80) :: message CHARACTER(LEN=19) :: start_date_char , end_date_char , current_date_char , next_date_char @@ -684,7 +689,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) INTEGER :: id1 , interval_seconds , ierr, rc, sst_update, grid_fdda INTEGER , SAVE :: id, id2, id4 - CHARACTER (LEN=80) :: inpname , bdyname + CHARACTER (LEN=256) :: inpname , bdyname CHARACTER(LEN= 4) :: loop_char CHARACTER (LEN=256) :: message character *19 :: temp19 diff --git a/wrfv2_fire/main/real_nmm.F b/wrfv2_fire/main/real_nmm.F index 27f60a80..81f5ae2d 100644 --- a/wrfv2_fire/main/real_nmm.F +++ b/wrfv2_fire/main/real_nmm.F @@ -114,6 +114,8 @@ END SUBROUTINE Setup_Timekeeping #else CALL initial_config #endif + + CALL nl_set_use_wps_input ( 1,1 ) CALL check_nml_consistency CALL set_physics_rconfigs @@ -244,7 +246,7 @@ END SUBROUTINE start_domain INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y #endif -#if defined(HWRF) +#if ( HWRF == 1 ) ! Sam Says: ! The *INIT arrays are used to read init data written out by hwrf_prep_hybrid @@ -336,7 +338,7 @@ END SUBROUTINE start_domain write(message,*) 'TRIM(config_flags%auxinput1_inname): ', TRIM(config_flags%auxinput1_inname) CALL wrf_message(message) -#if defined(HWRF) +#if ( HWRF == 1 ) ifph_onlyfirst: if(.not.grid%use_prep_hybrid .or. loop==1) then #endif IF (config_flags%auxinput1_inname(1:10) .eq. 'real_input') THEN @@ -419,7 +421,7 @@ END SUBROUTINE start_domain CASE DEFAULT CALL wrf_error_fatal('real: not valid io_form_auxinput1') END SELECT -#if defined(HWRF) +#if ( HWRF == 1 ) endif ifph_onlyfirst #endif @@ -437,7 +439,7 @@ END SUBROUTINE start_domain CALL init_domain ( grid ) -#if defined(HWRF) +#if ( HWRF == 1 ) read_phinit: if(grid%use_prep_hybrid) then #if defined(DM_PARALLEL) if(.not. wrf_dm_on_monitor()) then @@ -696,7 +698,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) USE module_bc IMPLICIT NONE -#if defined(HWRF) +#if ( HWRF == 1 ) external get_wrf_debug_level integer :: debug #endif @@ -737,7 +739,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) INTEGER :: sm31y, em31y, sm32y, em32y, sm33y, em33y #endif -#if defined(HWRF) +#if ( HWRF == 1 ) ! Sam says: ! The *B arrays are used to read boundary data written out by hwrf_prep_hybrid @@ -758,7 +760,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) #include "deref_kludge.h" -#if defined(HWRF) +#if ( HWRF == 1 ) alloc_ph_arrays=.false. call get_wrf_debug_level(debug) #endif @@ -1097,7 +1099,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) !----------------------------------------------------------------------- call wrf_debug(1,'LOOP>1, so start making non-init boundary conditions') -#if defined(HWRF) +#if ( HWRF == 1 ) bdytmp_useph: if(grid%use_prep_hybrid) then call wrf_debug(1,'ALLOCATE PREP_HYBRID BOUNDARY ARRAYS') @@ -1310,7 +1312,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) CALL output_auxinput4 ( id4, grid , config_flags , ierr ) -#if defined( HWRF) +#if ( HWRF == 1 ) endif bdytmp_useph #endif @@ -1334,7 +1336,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) CALL domain_clockadvance( grid ) END IF -#if defined(HWRF) +#if ( HWRF == 1 ) bdytmp_notph: if(.not.grid%use_prep_hybrid) then #endif !----------------------------------------------------------------------- @@ -1464,7 +1466,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) endif END DO ENDIF -#if defined(HWRF) +#if ( HWRF == 1 ) endif bdytmp_notph #endif !----------------------------------------------------------------------- @@ -1672,7 +1674,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max ) END IF main_loop_test -#if defined(HWRF) +#if ( HWRF == 1 ) if(alloc_ph_arrays) then call wrf_debug(1,'DEALLOCATE PREP_HYBRID BOUNARY ARRAYS') deallocate(TB,QB,CWMB,UB,VB,PDB) diff --git a/wrfv2_fire/main/tc_em.F b/wrfv2_fire/main/tc_em.F index 622cadf8..0700bcef 100644 --- a/wrfv2_fire/main/tc_em.F +++ b/wrfv2_fire/main/tc_em.F @@ -267,7 +267,7 @@ END SUBROUTINE start_domain ! Declarations for the netcdf routines. INTEGER ::nf_inq ! - CHARACTER (LEN=80) :: si_inpname + CHARACTER (LEN=256) :: si_inpname CHARACTER (LEN=80) :: message CHARACTER(LEN=19) :: start_date_char , end_date_char , current_date_char , next_date_char @@ -536,7 +536,7 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max,current_ INTEGER :: id1 , interval_seconds , ierr, rc, sst_update, grid_fdda INTEGER , SAVE :: id, id2, id4 - CHARACTER (LEN=80) :: tcoutname , bdyname,si_inpname + CHARACTER (LEN=256) :: tcoutname , bdyname,si_inpname CHARACTER(LEN= 4) :: loop_char CHARACTER(LEN=19) :: current_date_char diff --git a/wrfv2_fire/main/wrf_SST_ESMF.F b/wrfv2_fire/main/wrf_SST_ESMF.F index cff9bc36..04c39f5c 100644 --- a/wrfv2_fire/main/wrf_SST_ESMF.F +++ b/wrfv2_fire/main/wrf_SST_ESMF.F @@ -222,8 +222,8 @@ SUBROUTINE read_data( exportState, clock ) ! stuffs the file data into the SST exportState. ! -#include -#include +#include "wrf_status_codes.h" +#include "wrf_io_flags.h" ! Local variables CHARACTER (LEN=19) :: date_string diff --git a/wrfv2_fire/phys/Makefile b/wrfv2_fire/phys/Makefile index 0fa15d83..c56121ef 100644 --- a/wrfv2_fire/phys/Makefile +++ b/wrfv2_fire/phys/Makefile @@ -75,6 +75,7 @@ MODULES = \ module_mp_wsm5.o \ module_mp_wsm6.o \ module_mp_etanew.o \ + module_mp_fer_hires.o \ module_mp_HWRF.o \ module_mp_thompson.o \ module_mp_full_sbm.o \ @@ -106,6 +107,7 @@ MODULES = \ module_sf_sfclay.o \ module_sf_sfclayrev.o \ module_sf_gfs.o \ + module_sf_exchcoef.o \ module_sf_gfdl.o \ module_sf_slab.o \ module_sf_noahdrv.o \ @@ -184,7 +186,8 @@ DIAGNOSTIC_MODULES_EM = \ module_diag_afwa_hail.o \ module_diag_cl.o \ module_diag_misc.o \ - module_diag_pld.o + module_diag_pld.o \ + module_diag_zld.o DIAGNOSTIC_MODULES_NMM = \ module_diag_refl.o diff --git a/wrfv2_fire/phys/module_bl_acm.F b/wrfv2_fire/phys/module_bl_acm.F index 49c13ba0..4c172d59 100755 --- a/wrfv2_fire/phys/module_bl_acm.F +++ b/wrfv2_fire/phys/module_bl_acm.F @@ -22,7 +22,7 @@ SUBROUTINE ACMPBL(XTIME, DTPBL, ZNW, SIGMAH, & PSFC, EP1, G, & ROVCP, RD, CPD, & PBLH, KPBL2D, EXCH_H, REGIME, & - GZ1OZ0, WSPD, PSIM, MUT, & + GZ1OZ0, WSPD, PSIM, MUT, RMOL, & RUBLTEN, RVBLTEN, RTHBLTEN, & RQVBLTEN, RQCBLTEN, RQIBLTEN, & ids,ide, jds,jde, kds,kde, & @@ -48,6 +48,12 @@ SUBROUTINE ACMPBL(XTIME, DTPBL, ZNW, SIGMAH, & ! RG and JP 7/2006 - Finished WRF adaptation ! JP 12/2011 12/2011 - ACM2 modified so it's not dependent on first layer thickness. ! JP 3/2013 - WRFChem version. Mixing of chemical species are added +! JP 12/2014 - Km and Kh updated. New Richardson number stability function. +! Reduces day and night 2-m temperature bias. +! JP 12/2014 - Minimum PBL height bug caused PBLH lower than first level thickness in very stable +! conditions. Fixed so PBLH minimum is layer 1 thickness. +! JP 12/2015 - RMOL updated after initial calculation in the PX-SFCLAY. +! ! !********************************************************************** ! ARGUMENT LIST: @@ -84,6 +90,7 @@ SUBROUTINE ACMPBL(XTIME, DTPBL, ZNW, SIGMAH, & !-- WSPD wind speed at lowest model level (m/s) !-- PSIM similarity stability function for momentum !-- MUT Total Mu : Psfc - Ptop +!-- RMOL inverse (1/MOL) of Monin-Obukhov length (m) (added for v3.8) !-- ids start index for i in domain !-- ide end index for i in domain @@ -138,7 +145,8 @@ SUBROUTINE ACMPBL(XTIME, DTPBL, ZNW, SIGMAH, & HFX, QFX, TSK, & PSFC, WSPD, MUT - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: PBLH, REGIME, UST + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: PBLH, REGIME, & + UST, RMOL REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(INOUT) :: RUBLTEN, RVBLTEN, & @@ -235,7 +243,7 @@ SUBROUTINE ACMPBL(XTIME, DTPBL, ZNW, SIGMAH, & ,hfx=hfx(ims,j),qfx=qfx(ims,j) & ,tg=tsk(ims,j),gz1oz0=gz1oz0(ims,j) & ,wspd=wspd(ims,j) ,klpbl=kpbl2d(ims,j) & - ,mut=mut(ims,j) & + ,mut=mut(ims,j), rmol=rmol(ims,j) & ,ep1=ep1,karman=karman & ,ids=ids,ide=ide, jds=jds,jde=jde, kds=kds,kde=kde & ,ims=ims,ime=ime, jms=jms,jme=jme, kms=kms,kme=kme & @@ -267,7 +275,7 @@ SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah & ,cpd,g,rovcp,rd,rdt,psfcpa,ust & ,pbl,exch_hx,regime,psim & ,hfx,qfx,tg,gz1oz0,wspd ,klpbl & - ,mut & + ,mut, rmol & ,ep1,karman & ,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & @@ -297,7 +305,7 @@ SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah & qitnp real, dimension( ims:ime ), intent(in ) :: psfcpa real, dimension( ims:ime ), intent(in ) :: tg - real, dimension( ims:ime ), intent(inout) :: regime + real, dimension( ims:ime ), intent(inout) :: regime, rmol real, dimension( ims:ime ), intent(in) :: wspd, psim, gz1oz0 real, dimension( ims:ime ), intent(in) :: hfx, qfx real, dimension( ims:ime ), intent(in) :: mut @@ -380,6 +388,7 @@ SUBROUTINE ACM2D(j,XTIME, DTPBL, sigmaf, sigmah & TSTV(I) = SIGN(1.0E-6,TSTV(I)) ENDIF MOL(I) = THV1 * UST(i)**2/(KARMAN*G*TSTV(I)) + RMOL(I) = 1./MOL(I) WST(I) = UST(I) * (PBL(I)/(KARMAN*ABS(MOL(I)))) ** 0.333333 PSTAR(I) = MUT(I)/1000. ! P* in cb ENDDO @@ -794,7 +803,7 @@ SUBROUTINE EDDYX(DTPBL, ZF, ZA, MOL, PBL, UST, & ! FH = (MAX(1.-RI/RC,0.01))**2 ! ENDIF FH=1./(1.+10.*RI+50.*RI**2+5000.*RI**4)+0.0012 !pleim5 - FM= PR*FH + 0.00104 + FM= PR*FH + 0.00104 EDDYZ(I,K) = KZO + SQRT(SS) * FH * SQL EDDYZM(I,K) = KZO + SQRT(SS) * FM * SQL diff --git a/wrfv2_fire/phys/module_bl_camuwpbl_driver.F b/wrfv2_fire/phys/module_bl_camuwpbl_driver.F index 5709184f..bcdbeead 100755 --- a/wrfv2_fire/phys/module_bl_camuwpbl_driver.F +++ b/wrfv2_fire/phys/module_bl_camuwpbl_driver.F @@ -727,9 +727,9 @@ subroutine camuwpbl(dt,u_phy,v_phy,th_phy,rho,qv_curr,hfx,qfx,ustar,p8w & rvblten(i,k,j) = wind_tends(1,kflip,2) rthblten(i,k,j) = stnd(1,kflip)/cpair/exner8(1,kflip) - multFrc = 1._r8/(1._r8 - qv_curr(i,k,j)) + multFrc = 1._r8 + qv_curr(i,k,j) - rqvblten(i,k,j) = cloudtnd(1,kflip,1 ) * multFrc + rqvblten(i,k,j) = cloudtnd(1,kflip,1 ) * multFrc * multFrc rqcblten(i,k,j) = cloudtnd(1,kflip,ixcldliq) * multFrc rqiblten(i,k,j) = cloudtnd(1,kflip,ixcldice) * multFrc !*Important* : ixnumliq is mixed in the dropmixnuc, therefore ixnumliq is NOT mixed here (ONLY if CAMMGMP is used for mp_physics) diff --git a/wrfv2_fire/phys/module_bl_gfs.F b/wrfv2_fire/phys/module_bl_gfs.F index 67836789..0f15a1b9 100755 --- a/wrfv2_fire/phys/module_bl_gfs.F +++ b/wrfv2_fire/phys/module_bl_gfs.F @@ -22,6 +22,7 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D, & VAR_RIC, & !Kwon for variable Ric U10,V10,ZNT,MZNT,rc2d, & !Kwon for variable Ric DKU3D,DKT3D,coef_ric_l,coef_ric_s,xland, & !Kwon for variable Ric + pert_pbl, ens_random_seed, ens_pblamp, & #endif ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -114,6 +115,9 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D, & ZNT !ADDED BY KWON FOR VARIABLE Ric REAL, DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(OUT) :: DKU3D,DKT3D REAL, INTENT(IN) :: VAR_RIC,coef_ric_l,coef_ric_s !ADDED BY KWON + integer,intent(in) :: ens_random_seed + real,intent(in) :: ens_pblamp + logical,intent(in) :: pert_pbl #endif @@ -353,6 +357,7 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D, & DELTIM,DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT, & #if (HWRF==1) VAR_RIC,Ro,DKU,DKT,coef_ric_l,coef_ric_s,xland1, & + pert_pbl, ens_random_seed, ens_pblamp, & #endif RBCR,HGAMQ,ALPHA) @@ -509,6 +514,7 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & & DUSFC,DVSFC,DTSFC,DQSFC,HPBL,HGAMT, & #if (HWRF==1) VAR_RIC,Ro,DKU,DKT,coef_ric_l,coef_ric_s,xland1, & + pert_pbl, ens_random_seed, ens_pblamp, & #endif RBCR,HGAMQ,ALPHA) ! @@ -530,6 +536,9 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & #if (HWRF==1) real :: VAR_RIC,coef_ric_l,coef_ric_s + integer,intent(in) :: ens_random_seed + real,intent(in) :: ens_pblamp + logical,intent(in) :: pert_pbl #endif real(kind=kind_phys) DV(IM,KM), DU(IM,KM), & & TAU(IM,KM), RTG(IM,KM,ntrac), & @@ -605,21 +614,16 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & PARAMETER(IUN=84) #if HWRF==1 real*8 :: ran1 !zhang - integer :: ens_random_seed !zhang - real :: ens_pblamp,rr !zhang - logical :: pert_pbl !zhang + real :: rr logical,save :: pert_pbl_local !zhang integer,save :: ens_random_seed_local !zhang real,save :: ens_pblamp_local !zhang data ens_random_seed_local/0/ !zz print*, 'zhang in pbl===========' if ( ens_random_seed_local .eq. 0 ) then - CALL nl_get_pert_pbl(1,pert_pbl) - CALL nl_get_ens_random_seed(1,ens_random_seed) - CALL nl_get_ens_pblamp(1,ens_pblamp) - pert_pbl_local=pert_pbl - ens_random_seed_local=ens_random_seed - ens_pblamp_local=ens_pblamp + pert_pbl_local=pert_pbl + ens_random_seed_local=ens_random_seed + ens_pblamp_local=ens_pblamp !zz print*, "zhang in pbl= one time ", pert_pbl_local, ens_random_seed_local, ens_pblamp_local endif !zz print*, "zhang in pbl=",pert_pbl_local, ens_random_seed_local, ens_pblamp_local @@ -961,7 +965,7 @@ SUBROUTINE MONINP(IX,IM,KM,ntrac,DV,DU,TAU,RTG, & ! (3) only do this IF KPBL(I) >= kLOC. Otherwise, we are finished, with DKU as if alpha = +1 - if(KPBL(I).ge.kLOC)then + if(KPBL(I).gt.kLOC)then xDKU = DKU(i,kLOC) ! Km at k-level diff --git a/wrfv2_fire/phys/module_bl_mynn.F b/wrfv2_fire/phys/module_bl_mynn.F index 03f6e85c..56fde672 100644 --- a/wrfv2_fire/phys/module_bl_mynn.F +++ b/wrfv2_fire/phys/module_bl_mynn.F @@ -1,3 +1,6 @@ +#define MYNN_DBG_LVL 3000 +!WRF:MODEL_LAYER:PHYSICS +! ! translated from NN f77 to F90 and put into WRF by Mariusz Pagowski ! NOAA/GSD & CIRA/CSU, Feb 2008 ! changes to original code: @@ -10,31 +13,60 @@ ! intent etc) !------------------------------------------------------------------- !Modifications implemented by Joseph Olson NOAA/GSD/AMB - CU/CIRES -!(approved by Mikio Nakanishi or under consideration): +! (approved by Mikio Nakanishi or under consideration or do not +! significantly alter the general behavior of the MYNN as documented.): +! ! 1. Addition of BouLac mixing length in the free atmosphere. ! 2. Changed the turbulent mixing length to be integrated from the ! surface to the top of the BL + a transition layer depth. ! 3. v3.4.1: Option to use Kitamura/Canuto modification which removes -! the critical Richardson number and negative TKE (default). -! 4. v3.4.1: Hybrid PBL height diagnostic, which blends a theta-v-based -! definition in neutral/convective BL and a TKE-based definition -! in stable conditions. -! 5. v3.4.1: TKE budget output option (bl_mynn_tkebudget) -! 6. v3.5.0: TKE advection option (bl_mynn_tkeadvect) -! 7. v3.5.1: Fog deposition related changes. -! -! For changes 1 and 3, see "JOE's mods" below: +! the critical Richardson number and negative TKE (default). +! Hybrid PBL height diagnostic, which blends a theta-v-based +! definition in neutral/convective BL and a TKE-based definition +! in stable conditions. +! TKE budget output option (bl_mynn_tkebudget) +! 4. v3.5.0: TKE advection option (bl_mynn_tkeadvect) +! 5. v3.5.1: Fog deposition related changes. +! 6. v3.6.0: Removed fog deposition from the calculation of tendencies +! Added mixing of qc, qi, qni +! Added output for wstar, delta, TKE_PBL, & KPBL for correct +! coupling to shcu schemes +! 7. v3.8.0: Added subgrid scale cloud output for coupling to radiation +! schemes (activated by setting icloud_bl =1 in phys namelist). +! Added WRF_DEBUG prints (at level 3000) +! Added Tripoli and Cotton (1981) correction. +! Added namelist option bl_mynn_cloudmix to test effect of mixing +! cloud species (default = 1: on). +! Added mass-flux option (bl_mynn_edmf, = 1 for StEM, 2 for TEMF). +! This option is off by default (=0). +! Related (hidden) options: +! bl_mynn_edmf_mom = 1 : activate momentum transport in MF scheme +! bl_mynn_edmf_tke = 1 : activate TKE transport in MF scheme +! bl_mynn_edmf_part= 1 : activate areal partitioning of ED & MF +! Added mixing length option (bl_mynn_mixlength, see notes below) +! Added more sophisticated saturation checks, following Thompson scheme +! Added new cloud PDF option (bl_mynn_cloudpdf = 2) from Chaboureau +! and Bechtold (2002, JAS, with mods) +! Added capability to mix chemical species when env variable +! WRF_CHEM = 1, thanks to Wayne Angevine. +! Added scale-aware mixing length, following Junshi Ito's work +! Ito et al. (2015, BLM). +! +! For changes 1, 3, and 6, see "JOE's mods" below: !------------------------------------------------------------------- MODULE module_bl_mynn USE module_model_constants, only: & &karman, g, p1000mb, & - &cp, r_d, rcp, xlv, xlf,& - &svp1, svp2, svp3, svpt0, ep_1, ep_2 + &cp, r_d, r_v, rcp, xlv, xlf, xls, & + &svp1, svp2, svp3, svpt0, ep_1, ep_2, rvovrd, & + &cpv, cliq, cice USE module_state_description, only: param_first_scalar, & &p_qc, p_qr, p_qi, p_qs, p_qg, p_qnc, p_qni + + USE module_wrf_error !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -46,14 +78,15 @@ MODULE module_bl_mynn REAL, PARAMETER :: xlvcp=xlv/cp, xlscp=(xlv+xlf)/cp, ev=xlv, rd=r_d, & &rk=cp/rd, svp11=svp1*1.e3, p608=ep_1, ep_3=1.-ep_2 - REAL, PARAMETER :: tref=300.0 ! reference temperature (K) + REAL, PARAMETER :: tref=300.0 ! reference temperature (K) + REAL, PARAMETER :: TKmin=253.0 ! for total water conversion, Tripoli and Cotton (1981) REAL, PARAMETER :: tv0=p608*tref, tv1=(1.+p608)*tref, gtr=g/tref ! Closure constants REAL, PARAMETER :: & &vk = karman, & - &pr = 0.74, & - &g1 = 0.229, & ! NN2009 = 0.235 + &pr = 0.74, & + &g1 = 0.235, & ! NN2009 = 0.235 &b1 = 24.0, & &b2 = 15.0, & ! CKmod NN2009 &c2 = 0.729, & ! 0.729, & !0.75, & @@ -75,46 +108,95 @@ MODULE module_bl_mynn &e4c = 12.0*a1*a2*cc2, & &e5c = 6.0*a1*a1 -! Constants for length scale (alps & cns) and TKE diffusion (Sqfac) -! Original (Nakanishi and Niino 2009) (for CKmod=0.): -! REAL, PARAMETER :: qmin=0.0, zmax=1.0, cns=2.7, & -! &alp1=0.23, alp2=1.0, alp3=5.0, alp4=100.0, & -! &alp5=0.40, Sqfac=3.0 -! Modified for Rapid Refresh/HRRR (and for CKmod=1.): - REAL, PARAMETER :: qmin=0.0, zmax=1.0, cns=2.1, & - &alp1=0.23, alp2=0.65, alp3=3.0, alp4=20.0, & - &alp5=1.0, Sqfac=2.0 +! Constants for min tke in elt integration (qmin), max z/L in els (zmax), +! and factor for eddy viscosity for TKE (Kq = Sqfac*Km): + REAL, PARAMETER :: qmin=0.0, zmax=1.0, Sqfac=3.0 +! Note that the following mixing-length constants are now specified in mym_length +! &cns=3.5, alp1=0.23, alp2=0.3, alp3=3.0, alp4=10.0, alp5=0.4 ! Constants for gravitational settling ! REAL, PARAMETER :: gno=1.e6/(1.e8)**(2./3.), gpw=5./3., qcgmin=1.e-8 REAL, PARAMETER :: gno=1.0 !original value seems too agressive: 4.64158883361278196 REAL, PARAMETER :: gpw=5./3., qcgmin=1.e-8, qkemin=1.e-12 -! REAL, PARAMETER :: pblh_ref=1500. ! Constants for cloud PDF (mym_condensation) REAL, PARAMETER :: rr2=0.7071068, rrp=0.3989423 -!JOE's mods +! 'parameters' for Poisson distribution (StEM EDMF scheme) + REAL, PARAMETER :: zero = 0.0, half = 0.5, one = 1.0, two = 2.0 + !Use Canuto/Kitamura mod (remove Ric and negative TKE) (1:yes, 0:no) !For more info, see Canuto et al. (2008 JAS) and Kitamura (Journal of the !Meteorological Society of Japan, Vol. 88, No. 5, pp. 857-864, 2010). !Note that this change required further modification of other parameters - !above (c2, c3, alp2, and Sqfac). If you want to remove this option, set these - !parameters back to NN2009 values (see commented out lines next to the + !above (c2, c3). If you want to remove this option, set c2 and c3 constants + !(above) back to NN2009 values (see commented out lines next to the !parameters above). This only removes the negative TKE problem !but does not necessarily improve performance - neutral impact. REAL, PARAMETER :: CKmod=1. - !Use BouLac mixing length in free atmosphere (1:yes, 0:no) - !This helps remove excessively large mixing in unstable layers aloft. - REAL, PARAMETER :: BLmod=1. + !Use Ito et al. (2015, BLM) scale-aware (0: no, 1: yes). Note that this also has impacts + !on the cloud PDF and mass-flux scheme, using Honnert et al. (2011) similarity function + !for TKE in the upper PBL/cloud layer. + REAL, PARAMETER :: scaleaware=1. + + +! JAYMES- +! Constants used for empirical calculations of saturation +! vapor pressures (in function "esat") and saturation mixing ratios +! (in function "qsat"), reproduced from module_mp_thompson.F, +! v3.6 + REAL, PARAMETER:: J0= .611583699E03 + REAL, PARAMETER:: J1= .444606896E02 + REAL, PARAMETER:: J2= .143177157E01 + REAL, PARAMETER:: J3= .264224321E-1 + REAL, PARAMETER:: J4= .299291081E-3 + REAL, PARAMETER:: J5= .203154182E-5 + REAL, PARAMETER:: J6= .702620698E-8 + REAL, PARAMETER:: J7= .379534310E-11 + REAL, PARAMETER:: J8=-.321582393E-13 + + REAL, PARAMETER:: K0= .609868993E03 + REAL, PARAMETER:: K1= .499320233E02 + REAL, PARAMETER:: K2= .184672631E01 + REAL, PARAMETER:: K3= .402737184E-1 + REAL, PARAMETER:: K4= .565392987E-3 + REAL, PARAMETER:: K5= .521693933E-5 + REAL, PARAMETER:: K6= .307839583E-7 + REAL, PARAMETER:: K7= .105785160E-9 + REAL, PARAMETER:: K8= .161444444E-12 +! end- + +!JOE & JAYMES'S mods +! +! Mixing Length Options +! specifed through namelist: bl_mynn_mixlength +! added: 16 Apr 2015 +! +! 0: Uses original MYNN mixing length formulation (except elt is calculated from +! a 10-km vertical integration). No scale-awareness is applied to the master +! mixing length (el), regardless of "scaleaware" setting. +! +! 1 (*DEFAULT*): Instead of (0), uses BouLac mixing length in free atmosphere. +! This helps remove excessively large mixing in unstable layers aloft. Scale- +! awareness in dx is available via the "scaleaware" setting. As of Apr 2015, +! this mixing length formulation option is used in the ESRL RAP/HRRR configuration. +! +! 2: As in (1), but elb is lengthened using separate cloud mixing length functions +! for statically stable and unstable regimes. This elb adjustment is only +! possible for nonzero cloud fractions, such that cloud-free cells are treated +! as in (1), but BouLac calculation is used more sparingly - when elb > 500 m. +! This is to reduce the computational expense that comes with the BouLac calculation. +! Also, This option is scale-aware in dx if "scaleaware" = 1. (Following Ito et al. 2015). +! +!JOE & JAYMES- end + - !Mix couds (water & ice): (0: no, 1: yes) - REAL, PARAMETER :: Cloudmix=0. -!JOE-end INTEGER :: mynn_level + CHARACTER*128 :: mynn_message + INTEGER, PARAMETER :: kdebug=27 CONTAINS @@ -196,54 +278,50 @@ MODULE module_bl_mynn ! iniflag : <>0; turbulent quantities will be initialized ! = 0; turbulent quantities have been already ! given, i.e., they will not be initialized -! mx, my : Maximum numbers of grid boxes -! in the x and y directions, respectively -! nx, ny, nz : Numbers of the actual grid boxes -! in the x, y and z directions, respectively +! nx, ny, nz : Dimension sizes of the +! x, y and z directions, respectively ! tref : Reference temperature (K) ! dz(nz) : Vertical grid spacings (m) ! # dz(nz)=dz(nz-1) ! zw(nz+1) : Heights of the walls of the grid boxes (m) ! # zw(1)=0.0 and zw(k)=zw(k-1)+dz(k-1) -! h(mx,ny) : G^(1/2) in the terrain-following coordinate +! h(nx,ny) : G^(1/2) in the terrain-following coordinate ! # h=1-zg/zt, where zg is the height of the ! terrain and zt the top of the model domain -! pi0(mx,my,nz) : Exner function at zw*h+zg (J/kg K) +! pi0(nx,my,nz) : Exner function at zw*h+zg (J/kg K) ! defined by c_p*( p_basic/1000hPa )^kappa ! This is usually computed by integrating ! d(pi0)/dz = -h*g/tref. -! rmo(mx,ny) : Inverse of the Obukhov length (m^(-1)) -! flt, flq(mx,ny) : Turbulent fluxes of sensible and latent heat, +! rmo(nx,ny) : Inverse of the Obukhov length (m^(-1)) +! flt, flq(nx,ny) : Turbulent fluxes of sensible and latent heat, ! respectively, e.g., flt=-u_*Theta_* (K m/s) !! flt - liquid water potential temperature surface flux !! flq - total water flux surface flux -! ust(mx,ny) : Friction velocity (m/s) -! pmz(mx,ny) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1)) +! ust(nx,ny) : Friction velocity (m/s) +! pmz(nx,ny) : phi_m-zeta at z1*h+z0, where z1 (=0.5*dz(1)) ! is the first grid point above the surafce, z0 ! the roughness length and zeta=(z1*h+z0)*rmo -! phh(mx,ny) : phi_h at z1*h+z0 -! u, v(mx,my,nz): Components of the horizontal wind (m/s) -! thl(mx,my,nz) : Liquid water potential temperature +! phh(nx,ny) : phi_h at z1*h+z0 +! u, v(nx,nz,ny): Components of the horizontal wind (m/s) +! thl(nx,nz,ny) : Liquid water potential temperature ! (K) -! qw(mx,my,nz) : Total water content Q_w (kg/kg) +! qw(nx,nz,ny) : Total water content Q_w (kg/kg) ! ! Output variables: -! ql(mx,my,nz) : Liquid water content (kg/kg) -! v?(mx,my,nz) : Functions for computing the buoyancy flux -! qke(mx,my,nz) : Twice the turbulent kinetic energy q^2 +! ql(nx,nz,ny) : Liquid water content (kg/kg) +! v?(nx,nz,ny) : Functions for computing the buoyancy flux +! qke(nx,nz,ny) : Twice the turbulent kinetic energy q^2 ! (m^2/s^2) -! tsq(mx,my,nz) : Variance of Theta_l (K^2) -! qsq(mx,my,nz) : Variance of Q_w -! cov(mx,my,nz) : Covariance of Theta_l and Q_w (K) -! el(mx,my,nz) : Master length scale L (m) +! tsq(nx,nz,ny) : Variance of Theta_l (K^2) +! qsq(nx,nz,ny) : Variance of Q_w +! cov(nx,nz,ny) : Covariance of Theta_l and Q_w (K) +! el(nx,nz,ny) : Master length scale L (m) ! defined on the walls of the grid boxes -! bsh : no longer used -! via common : Closure constants ! ! Work arrays: see subroutine mym_level2 -! pd?(mx,my,nz) : Half of the production terms at Level 2 +! pd?(nx,nz,ny) : Half of the production terms at Level 2 ! defined on the walls of the grid boxes -! qkw(mx,my,nz) : q on the walls of the grid boxes (m/s) +! qkw(nx,nz,ny) : q on the walls of the grid boxes (m/s) ! ! # As to dtl, ...gh, see subroutine mym_turbulence. ! @@ -252,22 +330,22 @@ SUBROUTINE mym_initialize ( kts,kte,& & dz, zw, & & u, v, thl, qw, & ! & ust, rmo, pmz, phh, flt, flq,& -!JOE-BouLac/PBLH mod - & zi,theta,& - & sh,& -!JOE-end + & zi, theta, sh,& & ust, rmo, el,& - & Qke, Tsq, Qsq, Cov) + & Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, & + & bl_mynn_mixlength, & + & edmf_a1,edmf_qc1,bl_mynn_edmf) ! !------------------------------------------------------------------- INTEGER, INTENT(IN) :: kts,kte + INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf ! REAL, INTENT(IN) :: ust, rmo, pmz, phh, flt, flq - REAL, INTENT(IN) :: ust, rmo + REAL, INTENT(IN) :: ust, rmo, Psig_bl REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw - + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,cldfra_bl1D,& + edmf_a1,edmf_qc1 REAL, DIMENSION(kts:kte), INTENT(out) :: tsq,qsq,cov REAL, DIMENSION(kts:kte), INTENT(inout) :: el,qke @@ -276,11 +354,8 @@ SUBROUTINE mym_initialize ( kts,kte,& &gm,gh,sm,sh,qkw,vt,vq INTEGER :: k,l,lmax REAL :: phm,vkz,elq,elv,b1l,b2l,pmz=1.,phh=1.,flt=0.,flq=0.,tmpq -!JOE-BouLac and PBLH mod REAL :: zi REAL, DIMENSION(kts:kte) :: theta -!JOE-end - ! ** At first ql, vt and vq are set to zero. ** DO k = kts,kte @@ -328,10 +403,9 @@ SUBROUTINE mym_initialize ( kts,kte,& & qke, & & dtv, & & el, & -!JOE-added for BouLac/PBHL & zi,theta,& -!JOE-end - & qkw) + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_a1,edmf_qc1,bl_mynn_edmf) ! DO k = kts+1,kte elq = el(k)*qkw(k) @@ -396,13 +470,13 @@ END SUBROUTINE mym_initialize ! Input variables: see subroutine mym_initialize ! ! Output variables: -! dtl(mx,my,nz) : Vertical gradient of Theta_l (K/m) -! dqw(mx,my,nz) : Vertical gradient of Q_w -! dtv(mx,my,nz) : Vertical gradient of Theta_V (K/m) -! gm (mx,my,nz) : G_M divided by L^2/q^2 (s^(-2)) -! gh (mx,my,nz) : G_H divided by L^2/q^2 (s^(-2)) -! sm (mx,my,nz) : Stability function for momentum, at Level 2 -! sh (mx,my,nz) : Stability function for heat, at Level 2 +! dtl(nx,nz,ny) : Vertical gradient of Theta_l (K/m) +! dqw(nx,nz,ny) : Vertical gradient of Q_w +! dtv(nx,nz,ny) : Vertical gradient of Theta_V (K/m) +! gm (nx,nz,ny) : G_M divided by L^2/q^2 (s^(-2)) +! gh (nx,nz,ny) : G_H divided by L^2/q^2 (s^(-2)) +! sm (nx,nz,ny) : Stability function for momentum, at Level 2 +! sh (nx,nz,ny) : Stability function for heat, at Level 2 ! ! These are defined on the walls of the grid boxes. ! @@ -458,8 +532,8 @@ SUBROUTINE mym_level2 (kts,kte,& dtz = ( thl(k)-thl(k-1) )/( dzk ) dqz = ( qw(k)-qw(k-1) )/( dzk ) ! - vtt = 1.0 +vt(k)*abk +vt(k-1)*afk - vqq = tv0 +vq(k)*abk +vq(k-1)*afk + vtt = 1.0 +vt(k)*abk +vt(k-1)*afk ! Beta-theta in NN09, Eq. 39 + vqq = tv0 +vq(k)*abk +vq(k-1)*afk ! Beta-q dtq = vtt*dtz +vqq*dqz ! dtl(k) = dtz @@ -516,8 +590,8 @@ END SUBROUTINE mym_level2 ! Output variables: see subroutine mym_initialize ! ! Work arrays: -! elt(mx,ny) : Length scale depending on the PBL depth (m) -! vsc(mx,ny) : Velocity scale q_c (m/s) +! elt(nx,ny) : Length scale depending on the PBL depth (m) +! vsc(nx,ny) : Velocity scale q_c (m/s) ! at first, used for computing elt ! ! NOTE: the mixing lengths are meant to be calculated at the full- @@ -531,24 +605,35 @@ SUBROUTINE mym_length ( kts,kte,& & dtv, & & el, & & zi,theta,& !JOE-BouLac mod - & qkw) + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_a1,edmf_qc1,bl_mynn_edmf) !------------------------------------------------------------------- INTEGER, INTENT(IN) :: kts,kte + INTEGER, INTENT(IN) :: bl_mynn_mixlength,bl_mynn_edmf REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq - REAL, DIMENSION(kts:kte), INTENT(IN) :: qke,vt,vq - + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl + REAL, DIMENSION(kts:kte), INTENT(IN) :: qke,vt,vq,cldfra_bl1D,& + edmf_a1,edmf_qc1 REAL, DIMENSION(kts:kte), INTENT(out) :: qkw, el REAL, DIMENSION(kts:kte), INTENT(in) :: dtv REAL :: elt,vsc -!JOE-added for BouLac ML + REAL, DIMENSION(kts:kte), INTENT(IN) :: theta REAL, DIMENSION(kts:kte) :: qtke,elBLmin,elBLavg,thetaw - REAL :: wt,zi,zi2,h1,h2 + REAL :: wt,wt2,zi,zi2,h1,h2,hs,elBLmin0,elBLavg0 + + ! THE FOLLOWING CONSTANTS ARE IMPORTANT FOR REGULATING THE + ! MIXING LENGTHS: + REAL :: cns, & ! for surface layer (els) in stable conditions + alp1, & ! for turbulent length scale (elt) + alp2, & ! for buoyancy length scale (elb) + alp3, & ! for buoyancy enhancement factor of elb + alp4, & ! for surface layer (els) in unstable conditions + alp5 ! for BouLac mixing length !THE FOLLOWING LIMITS DO NOT DIRECTLY AFFECT THE ACTUAL PBLH. !THEY ONLY IMPOSE LIMITS ON THE CALCULATION OF THE MIXING LENGTH @@ -558,25 +643,48 @@ SUBROUTINE mym_length ( kts,kte,& REAL, PARAMETER :: maxdz = 750. !max (half) transition layer depth !=0.3*2500 m PBLH, so the transition !layer stops growing for PBLHs > 2.5 km. - REAL, PARAMETER :: mindz = 300. !min (half) transition layer depth + REAL, PARAMETER :: mindz = 300. !300 !min (half) transition layer depth !SURFACE LAYER LENGTH SCALE MODS TO REDUCE IMPACT IN UPPER BOUNDARY LAYER REAL, PARAMETER :: ZSLH = 100. ! Max height correlated to surface conditions (m) REAL, PARAMETER :: CSL = 2. ! CSL = constant of proportionality to L O(1) REAL :: z_m -!Joe-end INTEGER :: i,j,k - REAL :: afk,abk,zwk,dzk,qdz,vflx,bv,elb,els,elf + REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,elb,elb_cloud,els,els1,elf, & + & el_stab,el_unstab,el_mf,el_stab_mf,elb_mf + + IF ( bl_mynn_mixlength .EQ. 0 ) THEN + cns = 2.7 + alp1 = 0.23 + alp2 = 1.0 + alp3 = 5.0 + alp4 = 100. + alp5 = 0.4 + ELSEIF ( bl_mynn_mixlength .EQ. 1 ) THEN + cns = 2.3 + alp1 = 0.23 + alp2 = 0.6 + alp3 = 3.0 + alp4 = 20. + alp5 = 0.4 + ELSEIF ( bl_mynn_mixlength .GE. 2 ) THEN + cns = 2.7 + alp1 = 0.23 + alp2 = 0.3 + alp3 = 3.0 + alp4 = 10. + alp5 = 0.4 + ENDIF ! tv0 = 0.61*tref ! gtr = 9.81/tref ! !JOE-added to impose limits on the height integration for elt as well ! as the transition layer depth - IF ( BLmod .EQ. 0. ) THEN - zi2=5000. !originally integrated to model top, not just 5000 m. + IF ( bl_mynn_mixlength .EQ. 0 ) THEN + zi2=10000. !originally integrated to model top, not just 10 km. ELSE zi2=MAX(zi,minzi) ENDIF @@ -593,12 +701,8 @@ SUBROUTINE mym_length ( kts,kte,& afk = dz(k)/( dz(k)+dz(k-1) ) abk = 1.0 -afk qkw(k) = SQRT(MAX(qke(k)*abk+qke(k-1)*afk,1.0e-3)) - -!JOE- BouLac Start qtke(k) = (qkw(k)**2.)/2. ! q -> TKE thetaw(k)= theta(k)*abk + theta(k-1)*afk -!JOE- BouLac End - END DO ! elt = 1.0e-5 @@ -611,7 +715,7 @@ SUBROUTINE mym_length ( kts,kte,& ! k = kts+1 zwk = zw(k) - DO WHILE (zwk .LE. MIN((zi2+h1), 4000.)) !JOE: 20130523 reduce too high diffusivity over mts + DO WHILE (zwk .LE. (zi2+h1)) dzk = 0.5*( dz(k)+dz(k-1) ) qdz = MAX( qkw(k)-qmin, 0.03 )*dzk elt = elt +qdz*zwk @@ -627,62 +731,161 @@ SUBROUTINE mym_length ( kts,kte,& ! ** Strictly, el(i,j,1) is not zero. ** el(kts) = 0.0 ! -!JOE- BouLac Start - IF ( BLmod .GT. 0. ) THEN + IF ( bl_mynn_mixlength .EQ. 1 ) THEN ! COMPUTE BouLac mixing length CALL boulac_length(kts,kte,zw,dz,qtke,thetaw,elBLmin,elBLavg) ENDIF -!JOE- BouLac END DO k = kts+1,kte zwk = zw(k) !full-sigma levels + IF (k .EQ. kts+1) zwk1=zwk + + ! ** Length scale limited by the buoyancy effect ** -! ** Length scale limited by the buoyancy effect ** IF ( dtv(k) .GT. 0.0 ) THEN - bv = SQRT( gtr*dtv(k) ) - elb = alp2*qkw(k) / bv & - & *( 1.0 + alp3/alp2*& - &SQRT( vsc/( bv*elt ) ) ) + bv = SQRT( gtr*dtv(k) ) + + IF ( bl_mynn_mixlength .EQ. 0 ) THEN ! use default elb formulation + elb = alp2*qkw(k) / bv & + & *( 1.0 + alp3/alp2*& + &SQRT( vsc/( bv*elt ) ) ) + elf = alp2 * qkw(k)/bv + + ELSE IF ( bl_mynn_mixlength .EQ. 1 ) THEN ! use default elb + elb = alp2*qkw(k) / bv & ! formulation, + & *( 1.0 + alp3/alp2*& ! except keep + &SQRT( vsc/( bv*elt ) ) ) ! elb bounded by + elb = MIN(elb, zwk) ! zwk + elf = alp2 * qkw(k)/bv + + ELSE IF ( bl_mynn_mixlength .GE. 2 ) THEN ! use new elb formulation + elb_mf = alp2*qkw(k) / bv & + & *( 1.0 + alp3/alp2*& + &SQRT( vsc/( bv*elt ) ) ) + tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(flt,1.0e-4))**(1.0/3.0)), 100.),300.) + !minimize influence of surface heat flux on tau far away from the PBLH. + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + tau_cloud = tau_cloud*(1.-wt) + 100.*wt + elb_cloud = MIN(tau_cloud*SQRT(MIN(qtke(k),16.)), zwk) + elb = MIN(alp2*qkw(k)/bv, zwk) + elf = elb + IF (zwk > zi .AND. elf > 500.) THEN + ! COMPUTE BouLac mixing length + CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0) + elf = alp5*elBLavg0 + ENDIF + elb = elb*(1.-cldfra_bl1D(k)) + elb_cloud*cldfra_bl1D(k) + elf = elf*(1.-cldfra_bl1D(k)) + elb_cloud*cldfra_bl1D(k) + + END IF - elf = alp2 * qkw(k)/bv ELSE - elb = 1.0e10 - elf = elb + + IF ( bl_mynn_mixlength .LE. 1 ) THEN ! use default elb formulation + elb = 1.0e10 + elf = elb + + ELSE IF ( bl_mynn_mixlength .GE. 2 ) THEN + ! use version in development for RAP/HRRR 2016 + ! JAYMES- + ! tau_cloud is an eddy turnover timescale; + ! see Teixeira and Cheinet (2004), Eq. 1, and + ! Cheinet and Teixeira (2003), Eq. 7. The + ! coefficient 0.5 is tuneable. Expression in + ! denominator is identical to vsc (a convective + ! velocity scale), except that elt is relpaced + ! by zi, and zero is replaced by 1.0e-4 to + ! prevent division by zero. + + tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(flt,1.0e-4))**(1.0/3.0)),200.),300.) + !minimize influence of surface heat flux on tau far away from the PBLH. + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + tau_cloud = tau_cloud*(1.-wt) + 100.*wt + elb_cloud = MIN(tau_cloud*SQRT(MIN(qtke(k),20.)), zwk) + elb = elb_cloud + elf = elb_cloud + elb_mf = elb + IF (zwk > zi .AND. elf > 500.) THEN + ! COMPUTE BouLac mixing length for dry conditions in free atmosphere + CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0) + elf = alp5*elBLavg0*(1.-cldfra_bl1D(k)) + elb_cloud*cldfra_bl1D(k) + END IF + elf = elf*(1.-cldfra_bl1D(k)) + elb_cloud*cldfra_bl1D(k) + + END IF END IF -! - z_m = MAX(ZSLH,CSL*zwk*rmo) + + z_m = MAX(0.,zwk - 4.) ! ** Length scale in the surface layer ** IF ( rmo .GT. 0.0 ) THEN - ! IF ( zwk <= z_m ) THEN ! use original cns - els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) - !els = vk*zwk/(1.0+cns*MIN( 0.5*zw(kts+1)*rmo, zmax )) - ! ELSE - ! !blend to neutral values (kz) above z_m - ! els = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + vk*(zwk - z_m) - ! ENDIF + IF ( bl_mynn_mixlength .LE. 1 ) THEN + els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + ELSE + els = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax )) + els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax )) + !els = vk*zwk/(1.0+cns*MIN( zwk1*rmo, zmax )) + !els1 = vk*z_m/(1.0+cns*MIN( zwk1*rmo, zmax )) + ENDIF ELSE - els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + els = vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2 + els1 = vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2 END IF + ! ! ** HARMONC AVERGING OF MIXING LENGTH SCALES: ! el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) ! el(k) = elb/( elb/elt+elb/els+1.0 ) -!JOE- BouLac Start - IF ( BLmod .EQ. 0. ) THEN + + wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 + + IF ( bl_mynn_mixlength .EQ. 0 ) THEN el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - ELSE + + ELSE IF ( bl_mynn_mixlength .EQ. 1 ) THEN !add blending to use BouLac mixing length in free atmos; !defined relative to the PBLH (zi) + transition layer (h1) el(k) = MIN(elb/( elb/elt+elb/els+1.0 ),elf) - wt=.5*TANH((zwk - (zi2+h1))/h2) + .5 el(k) = el(k)*(1.-wt) + alp5*elBLmin(k)*wt - ENDIF -!JOE- BouLac End - !IF (el(k) > 1000.) THEN - ! print*,"SUSPICIOUSLY LARGE Lm:",el(k),k + !JAYMES- el_stab & el_unstab blending begin ( bl_mynn_mixlength opt) + ELSE IF ( bl_mynn_mixlength .GE. 2 ) THEN + hs = MAX(MIN(0.2*zi,200.),50.) ! bounded: 50 m < hs < 200 m + !z_m = MAX(0.,zwk - zwk1) + wt2 = 1.-(MIN(z_m,hs)/hs) + + el_stab = els*wt2 + elb*(1.-wt2) + el_stab_mf = els*wt2 + elb_mf*(1.-wt2) + + el_unstab = els/(1. + (els1/elt)) + + IF (bl_mynn_edmf > 0 .AND. edmf_a1(kts)>0.0) THEN + !Force unstable mixing length to be used in the lower PBL and + !blended unstable-mf length scale in the upper PBL when the mass-flux + !scheme is active. + !wt2=.5*TANH((zwk - (0.5*zi))/(0.25*zi)) + .5 + !el(k) = el_unstab*wt2 + MIN(el_stab_mf,el_unstab)*(1.-wt2) + el(k) = MIN(el_stab_mf,el_unstab) + ELSE + el(k) = MIN(el_stab,el_unstab) + ENDIF + el(k) = el(k)*(1.-wt) + elf*wt + END IF + + IF ( bl_mynn_mixlength .GE. 1 ) THEN ! include scale-awareness, except for original MYNN + el(k) = el(k)*Psig_bl + END IF + + !IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + IF (el(k) > 1000.) THEN + WRITE ( mynn_message , FMT='(A,F7.0,I5,5F7.0)' ) & + ' MYNN; mym_length; LARGE el,k,elb_cloud,elb,elt,elf,tau:'& + , el(k),k,elb_cloud,elb,elt,elf,tau_cloud + CALL wrf_debug ( 0 , mynn_message ) + ENDIF !ENDIF + END DO ! RETURN @@ -690,6 +893,158 @@ SUBROUTINE mym_length ( kts,kte,& END SUBROUTINE mym_length !JOE- BouLac Code Start - + +! ================================================================== + SUBROUTINE boulac_length0(k,kts,kte,zw,dz,qtke,theta,lb1,lb2) +! +! NOTE: This subroutine was taken from the BouLac scheme in WRF-ARW +! and modified for integration into the MYNN PBL scheme. +! WHILE loops were added to reduce the computational expense. +! This subroutine computes the length scales up and down +! and then computes the min, average of the up/down +! length scales, and also considers the distance to the +! surface. +! +! dlu = the distance a parcel can be lifted upwards give a finite +! amount of TKE. +! dld = the distance a parcel can be displaced downwards given a +! finite amount of TKE. +! lb1 = the minimum of the length up and length down +! lb2 = the average of the length up and length down +!------------------------------------------------------------------- + + INTEGER, INTENT(IN) :: k,kts,kte + REAL, DIMENSION(kts:kte), INTENT(IN) :: qtke,dz,theta + REAL, INTENT(OUT) :: lb1,lb2 + REAL, DIMENSION(kts:kte+1), INTENT(IN) :: zw + + !LOCAL VARS + INTEGER :: izz, found + REAL :: dlu,dld + REAL :: dzt, zup, beta, zup_inf, bbb, tl, zdo, zdo_sup, zzz + + + !---------------------------------- + ! FIND DISTANCE UPWARD + !---------------------------------- + zup=0. + dlu=zw(kte+1)-zw(k)-dz(k)/2. + zzz=0. + zup_inf=0. + beta=g/theta(k) !Buoyancy coefficient + + !print*,"FINDING Dup, k=",k," zw=",zw(k) + + if (k .lt. kte) then !cant integrate upwards from highest level + found = 0 + izz=k + DO WHILE (found .EQ. 0) + + if (izz .lt. kte) then + dzt=dz(izz) ! layer depth above + zup=zup-beta*theta(k)*dzt ! initial PE the parcel has at k + !print*," ",k,izz,theta(izz),dz(izz) + zup=zup+beta*(theta(izz+1)+theta(izz))*dzt/2. ! PE gained by lifting a parcel to izz+1 + zzz=zzz+dzt ! depth of layer k to izz+1 + !print*," PE=",zup," TKE=",qtke(k)," z=",zw(izz) + if (qtke(k).lt.zup .and. qtke(k).ge.zup_inf) then + bbb=(theta(izz+1)-theta(izz))/dzt + if (bbb .ne. 0.) then + !fractional distance up into the layer where TKE becomes < PE + tl=(-beta*(theta(izz)-theta(k)) + & + & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2. + & + & 2.*bbb*beta*(qtke(k)-zup_inf))))/bbb/beta + else + if (theta(izz) .ne. theta(k))then + tl=(qtke(k)-zup_inf)/(beta*(theta(izz)-theta(k))) + else + tl=0. + endif + endif + dlu=zzz-dzt+tl + !print*," FOUND Dup:",dlu," z=",zw(izz)," tl=",tl + found =1 + endif + zup_inf=zup + izz=izz+1 + ELSE + found = 1 + ENDIF + + ENDDO + + endif + + !---------------------------------- + ! FIND DISTANCE DOWN + !---------------------------------- + zdo=0. + zdo_sup=0. + dld=zw(k) + zzz=0. + + !print*,"FINDING Ddown, k=",k," zwk=",zw(k) + if (k .gt. kts) then !cant integrate downwards from lowest level + + found = 0 + izz=k + DO WHILE (found .EQ. 0) + + if (izz .gt. kts) then + dzt=dz(izz-1) + zdo=zdo+beta*theta(k)*dzt + !print*," ",k,izz,theta(izz),dz(izz-1) + zdo=zdo-beta*(theta(izz-1)+theta(izz))*dzt/2. + zzz=zzz+dzt + !print*," PE=",zdo," TKE=",qtke(k)," z=",zw(izz) + if (qtke(k).lt.zdo .and. qtke(k).ge.zdo_sup) then + bbb=(theta(izz)-theta(izz-1))/dzt + if (bbb .ne. 0.) then + tl=(beta*(theta(izz)-theta(k))+ & + & sqrt( max(0.,(beta*(theta(izz)-theta(k)))**2. + & + & 2.*bbb*beta*(qtke(k)-zdo_sup))))/bbb/beta + else + if (theta(izz) .ne. theta(k)) then + tl=(qtke(k)-zdo_sup)/(beta*(theta(izz)-theta(k))) + else + tl=0. + endif + endif + dld=zzz-dzt+tl + !print*," FOUND Ddown:",dld," z=",zw(izz)," tl=",tl + found = 1 + endif + zdo_sup=zdo + izz=izz-1 + ELSE + found = 1 + ENDIF + ENDDO + + endif + + !---------------------------------- + ! GET MINIMUM (OR AVERAGE) + !---------------------------------- + !The surface layer length scale can exceed z for large z/L, + !so keep maximum distance down > z. + dld = min(dld,zw(k+1))!not used in PBL anyway, only free atmos + lb1 = min(dlu,dld) !minimum + !JOE-fight floating point errors + dlu=MAX(0.1,MIN(dlu,1000.)) + dld=MAX(0.1,MIN(dld,1000.)) + lb2 = sqrt(dlu*dld) !average - biased towards smallest + !lb2 = 0.5*(dlu+dld) !average + + if (k .eq. kte) then + lb1 = 0. + lb2 = 0. + endif + !print*,"IN MYNN-BouLac",k,lb1 + !print*,"IN MYNN-BouLac",k,dld,dlu + + END SUBROUTINE boulac_length0 + ! ================================================================== SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) ! @@ -831,6 +1186,9 @@ SUBROUTINE boulac_length(kts,kte,zw,dz,qtke,theta,lb1,lb2) !so keep maximum distance down > z. dld(iz) = min(dld(iz),zw(iz+1))!not used in PBL anyway, only free atmos lb1(iz) = min(dlu(iz),dld(iz)) !minimum + !JOE-fight floating point errors + dlu(iz)=MAX(0.1,MIN(dlu(iz),1000.)) + dld(iz)=MAX(0.1,MIN(dld(iz),1000.)) lb2(iz) = sqrt(dlu(iz)*dld(iz)) !average - biased towards smallest !lb2(iz) = 0.5*(dlu(iz)+dld(iz)) !average @@ -861,17 +1219,17 @@ END SUBROUTINE boulac_length ! # ql, vt, vq, qke, tsq, qsq and cov are changed to input variables. ! ! Output variables: see subroutine mym_initialize -! dfm(mx,my,nz) : Diffusivity coefficient for momentum, +! dfm(nx,nz,ny) : Diffusivity coefficient for momentum, ! divided by dz (not dz*h(i,j)) (m/s) -! dfh(mx,my,nz) : Diffusivity coefficient for heat, +! dfh(nx,nz,ny) : Diffusivity coefficient for heat, ! divided by dz (not dz*h(i,j)) (m/s) -! dfq(mx,my,nz) : Diffusivity coefficient for q^2, +! dfq(nx,nz,ny) : Diffusivity coefficient for q^2, ! divided by dz (not dz*h(i,j)) (m/s) -! tcd(mx,my,nz) : Countergradient diffusion term for Theta_l +! tcd(nx,nz,ny) : Countergradient diffusion term for Theta_l ! (K/s) -! qcd(mx,my,nz) : Countergradient diffusion term for Q_w +! qcd(nx,nz,ny) : Countergradient diffusion term for Q_w ! (kg/kg s) -! pd?(mx,my,nz) : Half of the production terms +! pd?(nx,nz,ny) : Half of the production terms ! ! Only tcd and qcd are defined at the center of the grid boxes ! @@ -890,27 +1248,24 @@ SUBROUTINE mym_turbulence ( kts,kte,& & qke, tsq, qsq, cov, & & vt, vq,& & rmo, flt, flq, & -!JOE-BouLac/PBLH test & zi,theta,& & sh,& -!JOE-end & El,& & Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc & -!JOE-TKE BUDGET & ,qWT1D,qSHEAR1D,qBUOY1D,qDISS1D & & ,bl_mynn_tkebudget & -!JOE-end - &) + & ,Psig_bl,Psig_shcu,cldfra_bl1D,bl_mynn_mixlength,& + & edmf_a1,edmf_qc1,bl_mynn_edmf) !------------------------------------------------------------------- ! INTEGER, INTENT(IN) :: kts,kte - INTEGER, INTENT(IN) :: levflag + INTEGER, INTENT(IN) :: levflag,bl_mynn_mixlength,bl_mynn_edmf REAL, DIMENSION(kts:kte), INTENT(in) :: dz REAL, DIMENSION(kts:kte+1), INTENT(in) :: zw - REAL, INTENT(in) :: rmo,flt,flq + REAL, INTENT(in) :: rmo,flt,flq,Psig_bl,Psig_shcu REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,thl,qw,& - &ql,vt,vq,qke,tsq,qsq,cov + &ql,vt,vq,qke,tsq,qsq,cov,cldfra_bl1D,edmf_a1,edmf_qc1 REAL, DIMENSION(kts:kte), INTENT(out) :: dfm,dfh,dfq,& &pdk,pdt,pdq,pdc,tcd,qcd,el @@ -931,12 +1286,13 @@ SUBROUTINE mym_turbulence ( kts,kte,& REAL :: e6c,dzk,afk,abk,vtt,vqq,& &cw25,clow,cupp,gamt,gamq,smd,gamv,elq,elh -!JOE-added for BouLac/PBLH test REAL :: zi REAL, DIMENSION(kts:kte), INTENT(in) :: theta -!JOE-end REAL :: a2den, duz, ri, HLmod !JOE-Canuto/Kitamura mod +!JOE-stability criteria for cw + REAL:: auh,aum,adh,adm,aeh,aem,Req,Rsl,Rsl2 +!JOE-end DOUBLE PRECISION q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel DOUBLE PRECISION q3sq, t3sq, r3sq, c3sq, dlsq, qdiv @@ -967,8 +1323,9 @@ SUBROUTINE mym_turbulence ( kts,kte,& & qke, & & dtv, & & el, & - & zi,theta,& !JOE-hybrid PBLH - & qkw) + & zi,theta,& + & qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength, & + & edmf_a1,edmf_qc1,bl_mynn_edmf) ! DO k = kts+1,kte @@ -995,72 +1352,109 @@ SUBROUTINE mym_turbulence ( kts,kte,& gmel = gm (k)*elsq ghel = gh (k)*elsq ! Modified: Dec/22/2005, up to here -! -!JOE-add prints - IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN - PRINT*,"MYM_TURBULENCE2.0: k=",k," sh=",sh(k) - PRINT*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - PRINT*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - PRINT*," qke=",qke(k)," el=",el(k)," ri=",ri - PRINT*," PBLH=",zi," u=",u(k)," v=",v(k) + + ! Level 2.0 debug prints + IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN + WRITE ( mynn_message , FMT='(A,F8.1,A,I6)' ) & + " MYNN; mym_turbulence2.0; sh=",sh(k)," k=",k + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " qke=",qke(k)," el=",el(k)," ri=",ri + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " PBLH=",zi," u=",u(k)," v=",v(k) + CALL wrf_debug ( 0 , mynn_message ) + ENDIF ENDIF + !JOE-Apply Helfand & Labraga stability check for all Ric -! when CKmod == 1. Suggested by Kitamura. Not applied below. +! when CKmod == 1. (currently not forced below) IF (CKmod .eq. 1) THEN HLmod = q2sq -1. ELSE HLmod = q3sq ENDIF + ! ** Since qkw is set to more than 0.0, q3sq > 0.0. ** + +!JOE-test new stability criteria in level 2.5 (as well as level 3) - little/no impact +! ** Limitation on q, instead of L/q ** + dlsq = elsq + IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) +!JOE-end + IF ( q3sq .LT. q2sq ) THEN -! IF ( HLmod .LT. q2sq ) THEN -!JOE-END + !IF ( HLmod .LT. q2sq ) THEN + !Apply Helfand & Labraga mod qdiv = SQRT( q3sq/q2sq ) !HL89: (1-alfa) sm(k) = sm(k) * qdiv sh(k) = sh(k) * qdiv ! -!JOE-Canuto/Kitamura mod -! e1 = q3sq - e1c*ghel * qdiv**2 -! e2 = q3sq - e2c*ghel * qdiv**2 -! e3 = e1 + e3c*ghel * qdiv**2 -! e4 = e1 - e4c*ghel * qdiv**2 + !JOE-Canuto/Kitamura mod + !e1 = q3sq - e1c*ghel * qdiv**2 + !e2 = q3sq - e2c*ghel * qdiv**2 + !e3 = e1 + e3c*ghel * qdiv**2 + !e4 = e1 - e4c*ghel * qdiv**2 e1 = q3sq - e1c*ghel/a2den * qdiv**2 e2 = q3sq - e2c*ghel/a2den * qdiv**2 e3 = e1 + e3c*ghel/(a2den**2) * qdiv**2 e4 = e1 - e4c*ghel/a2den * qdiv**2 -!JOE-end eden = e2*e4 + e3*e5c*gmel * qdiv**2 eden = MAX( eden, 1.0d-20 ) ELSE -!JOE-Canuto/Kitamura mod -! e1 = q3sq - e1c*ghel -! e2 = q3sq - e2c*ghel -! e3 = e1 + e3c*ghel -! e4 = e1 - e4c*ghel + !JOE-Canuto/Kitamura mod + !e1 = q3sq - e1c*ghel + !e2 = q3sq - e2c*ghel + !e3 = e1 + e3c*ghel + !e4 = e1 - e4c*ghel e1 = q3sq - e1c*ghel/a2den e2 = q3sq - e2c*ghel/a2den e3 = e1 + e3c*ghel/(a2den**2) e4 = e1 - e4c*ghel/a2den -!JOE-end eden = e2*e4 + e3*e5c*gmel eden = MAX( eden, 1.0d-20 ) -! + qdiv = 1.0 sm(k) = q3sq*a1*( e3-3.0*c1*e4 )/eden -!JOE-Canuto/Kitamura mod -! sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden + !JOE-Canuto/Kitamura mod + !sh(k) = q3sq*a2*( e2+3.0*c1*e5c*gmel )/eden sh(k) = q3sq*(a2/a2den)*( e2+3.0*c1*e5c*gmel )/eden -!JOE-end - END IF -! -! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 - IF (sh(k)<0.0 .OR. sm(k)<0.0 .OR. & + END IF !end Helfand & Labraga check + + !JOE-TEST: try forcing some small ED mixing within the MF plume + !IF (bl_mynn_edmf > 0 .AND. edmf_a1(k)>0.01) THEN + ! sh(k) = MAX(sh(k),0.05) + ! sm(k) = MAX(sm(k),0.05) + !ENDIF + + !JOE: Level 2.5 debug prints + ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20 + IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + IF (sh(k)<0.0 .OR. sm(k)<0.0 .OR. & sh(k) > 0.76*b2 .or. (sm(k)**2*gm(k) .gt. .44**2)) THEN - PRINT*,"MYM_TURBULENCE2.5: k=",k," sh=",sh(k) - PRINT*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - PRINT*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - PRINT*," qke=",qke(k)," el=",el(k)," ri=",ri - PRINT*," PBLH=",zi," u=",u(k)," v=",v(k) + WRITE ( mynn_message , FMT='(A,F8.1,A,I6)' ) & + " MYNN; mym_turbulence2.5; sh=",sh(k)," k=",k + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " qke=",qke(k)," el=",el(k)," ri=",ri + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " PBLH=",zi," u=",u(k)," v=",v(k) + CALL wrf_debug ( 0 , mynn_message ) + ENDIF ENDIF ! ** Level 3 : start ** @@ -1071,7 +1465,7 @@ SUBROUTINE mym_turbulence ( kts,kte,& t3sq = MAX( tsq(k)*abk+tsq(k-1)*afk, 0.0 ) r3sq = MAX( qsq(k)*abk+qsq(k-1)*afk, 0.0 ) c3sq = cov(k)*abk+cov(k-1)*afk -! + ! Modified: Dec/22/2005, from here c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) ! @@ -1091,26 +1485,55 @@ SUBROUTINE mym_turbulence ( kts,kte,& IF ( q3sq/dlsq .LT. -gh(k) ) q3sq = -dlsq*gh(k) ! ! ** Limitation on c3sq (0.12 =< cw =< 0.76) ** -!JOE-Canuto/Kitamura mod -! e2 = q3sq - e2c*ghel * qdiv**2 -! e3 = q3sq + e3c*ghel * qdiv**2 -! e4 = q3sq - e4c*ghel * qdiv**2 + !JOE: use Janjic's (2001; p 13-17) methodology (eqs 4.11-414 and 5.7-5.10) + ! to calculate an exact limit for c3sq: + auh = 27.*a1*((a2/a2den)**2)*b2*(g/tref)**2 + aum = 54.*(a1**2)*(a2/a2den)*b2*c1*(g/tref) + adh = 9.*a1*((a2/a2den)**2)*(12.*a1 + 3.*b2)*(g/tref)**2 + adm = 18.*(a1**2)*(a2/a2den)*(b2 - 3.*(a2/a2den))*(g/tref) + + aeh = (9.*a1*((a2/a2den)**2)*b1 +9.*a1*((a2/a2den)**2)* & + (12.*a1 + 3.*b2))*(g/tref) + aem = 3.*a1*(a2/a2den)*b1*(3.*(a2/a2den) + 3.*b2*c1 + & + (18.*a1*c1 - b2)) + & + (18.)*(a1**2)*(a2/a2den)*(b2 - 3.*(a2/a2den)) + + Req = -aeh/aem + Rsl = (auh + aum*Req)/(3.*adh + 3.*adm*Req) + !For now, use default values, since tests showed little/no sensitivity + Rsl = .12 !lower limit + Rsl2= 1.0 - 2.*Rsl !upper limit + !IF (k==2)print*,"Dynamic limit RSL=",Rsl + !IF (Rsl < 0.10 .OR. Rsl > 0.18) THEN + ! wrf_err_message = '--- ERROR: MYNN: Dynamic Cw '// & + ! 'limit exceeds reasonable limits' + ! CALL wrf_message ( wrf_err_message ) + ! WRITE ( mynn_message , FMT='(A,F8.3)' ) & + ! " MYNN: Dynamic Cw limit needs attention=",Rsl + ! CALL wrf_debug ( 0 , mynn_message ) + !ENDIF + + !JOE-Canuto/Kitamura mod + !e2 = q3sq - e2c*ghel * qdiv**2 + !e3 = q3sq + e3c*ghel * qdiv**2 + !e4 = q3sq - e4c*ghel * qdiv**2 e2 = q3sq - e2c*ghel/a2den * qdiv**2 e3 = q3sq + e3c*ghel/(a2den**2) * qdiv**2 e4 = q3sq - e4c*ghel/a2den * qdiv**2 -!JOE-end eden = e2*e4 + e3 *e5c*gmel * qdiv**2 -! -!JOE-Canuto/Kitamura mod -! wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & -! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 ) + + !JOE-Canuto/Kitamura mod + !wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & + ! & *( e2*e4c - e3c*e5c*gmel * qdiv**2 ) wden = cc3*gtr**2 * dlsq**2/elsq * qdiv**2 & & *( e2*e4c/a2den - e3c*e5c*gmel/(a2den**2) * qdiv**2 ) -!JOE-end -! + IF ( wden .NE. 0.0 ) THEN - clow = q3sq*( 0.12-cw25 )*eden/wden - cupp = q3sq*( 0.76-cw25 )*eden/wden + !JOE: test dynamic limits + !clow = q3sq*( 0.12-cw25 )*eden/wden + !cupp = q3sq*( 0.76-cw25 )*eden/wden + clow = q3sq*( Rsl -cw25 )*eden/wden + cupp = q3sq*( Rsl2-cw25 )*eden/wden ! IF ( wden .GT. 0.0 ) THEN c3sq = MIN( MAX( c3sq, c2sq+clow ), c2sq+cupp ) @@ -1122,57 +1545,72 @@ SUBROUTINE mym_turbulence ( kts,kte,& e1 = e2 + e5c*gmel * qdiv**2 eden = MAX( eden, 1.0d-20 ) ! Modified: Dec/22/2005, up to here -! -!JOE-Canuto/Kitamura mod -! e6c = 3.0*a2*cc3*gtr * dlsq/elsq + + !JOE-Canuto/Kitamura mod + !e6c = 3.0*a2*cc3*gtr * dlsq/elsq e6c = 3.0*(a2/a2den)*cc3*gtr * dlsq/elsq -!JOE-end -! -! ** for Gamma_theta ** -!! enum = qdiv*e6c*( t3sq-t2sq ) + + !============================ + ! ** for Gamma_theta ** + !! enum = qdiv*e6c*( t3sq-t2sq ) IF ( t2sq .GE. 0.0 ) THEN enum = MAX( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) ELSE enum = MIN( qdiv*e6c*( t3sq-t2sq ), 0.0d0 ) ENDIF - gamt =-e1 *enum /eden -! -! ** for Gamma_q ** -!! enum = qdiv*e6c*( r3sq-r2sq ) + + !============================ + ! ** for Gamma_q ** + !! enum = qdiv*e6c*( r3sq-r2sq ) IF ( r2sq .GE. 0.0 ) THEN enum = MAX( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) ELSE enum = MIN( qdiv*e6c*( r3sq-r2sq ), 0.0d0 ) ENDIF - gamq =-e1 *enum /eden -! -! ** for Sm' and Sh'd(Theta_V)/dz ** -!! enum = qdiv*e6c*( c3sq-c2sq ) + + !============================ + ! ** for Sm' and Sh'd(Theta_V)/dz ** + !! enum = qdiv*e6c*( c3sq-c2sq ) enum = MAX( qdiv*e6c*( c3sq-c2sq ), 0.0d0) -!JOE-Canuto/Kitamura mod -! smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 + !JOE-Canuto/Kitamura mod + !smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c+e4c)*a1/a2 smd = dlsq*enum*gtr/eden * qdiv**2 * (e3c/(a2den**2) + & & e4c/a2den)*a1/(a2/a2den) -!JOE-end + gamv = e1 *enum*gtr/eden -! sm(k) = sm(k) +smd -! -! ** For elh (see below), qdiv at Level 3 is reset to 1.0. ** + + !============================ + ! ** For elh (see below), qdiv at Level 3 is reset to 1.0. ** qdiv = 1.0 -! ** Level 3 : end ** -! - IF (sh(k)<0.0 .OR. sm(k)<0.0) THEN - PRINT*,"MYM_TURBULENCE3.0: k=",k," sh=",sh(k) - PRINT*," gm=",gm(k)," gh=",gh(k)," sm=",sm(k) - PRINT*," q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq - PRINT*," qke=",qke(k)," el=",el(k)," ri=",ri - PRINT*," PBLH=",zi," u=",u(k)," v=",v(k) + + ! Level 3 debug prints + IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + IF (sh(k)<-0.3 .OR. sm(k)<-0.3 .OR. & + qke(k) < -0.1 .or. ABS(smd) .gt. 2.0) THEN + WRITE ( mynn_message , FMT='(A,F8.1,A,I6)' ) & + " MYNN; mym_turbulence3.0; sh=",sh(k)," k=",k + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " gm=",gm(k)," gh=",gh(k)," sm=",sm(k) + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " q2sq=",q2sq," q3sq=",q3sq," q3/q2=",q3sq/q2sq + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " qke=",qke(k)," el=",el(k)," ri=",ri + CALL wrf_debug ( 0 , mynn_message ) + WRITE ( mynn_message , FMT='(A,F6.1,A,F6.1,A,F6.1)' ) & + " PBLH=",zi," u=",u(k)," v=",v(k) + CALL wrf_debug ( 0 , mynn_message ) + ENDIF ENDIF +! ** Level 3 : end ** + ELSE ! ** At Level 2.5, qdiv is not reset. ** gamt = 0.0 @@ -1182,20 +1620,24 @@ SUBROUTINE mym_turbulence ( kts,kte,& ! elq = el(k)*qkw(k) elh = elq*qdiv -! + + ! Production of TKE (pdk), T-variance (pdt), + ! q-variance (pdq), and covariance (pdc) pdk(k) = elq*( sm(k)*gm(k) & - & +sh(k)*gh(k)+gamv ) + & +sh(k)*gh(k)+gamv ) ! JAYMES TKE pdt(k) = elh*( sh(k)*dtl(k)+gamt )*dtl(k) pdq(k) = elh*( sh(k)*dqw(k)+gamq )*dqw(k) pdc(k) = elh*( sh(k)*dtl(k)+gamt )& &*dqw(k)*0.5 & &+elh*( sh(k)*dqw(k)+gamq )*dtl(k)*0.5 -! + + ! Contergradient terms tcd(k) = elq*gamt qcd(k) = elq*gamq -! - dfm(k) = elq*sm (k) / dzk - dfh(k) = elq*sh (k) / dzk + + ! Eddy Diffusivity/Viscosity divided by dz + dfm(k) = elq*sm(k) / dzk + dfh(k) = elq*sh(k) / dzk ! Modified: Dec/22/2005, from here ! ** In sub.mym_predict, dfq for the TKE and scalar variance ** ! ** are set to 3.0*dfm and 1.0*dfm, respectively. (Sqfac) ** @@ -1277,17 +1719,17 @@ END SUBROUTINE mym_turbulence ! SUBROUTINE mym_predict: ! ! Input variables: see subroutine mym_initialize and turbulence -! qke(mx,my,nz) : qke at (n)th time level +! qke(nx,nz,ny) : qke at (n)th time level ! tsq, ...cov : ditto ! ! Output variables: -! qke(mx,my,nz) : qke at (n+1)th time level +! qke(nx,nz,ny) : qke at (n+1)th time level ! tsq, ...cov : ditto ! ! Work arrays: -! qkw(mx,my,nz) : q at the center of the grid boxes (m/s) -! bp (mx,my,nz) : = 1/2*F, see below -! rp (mx,my,nz) : = P-1/2*F*Q, see below +! qkw(nx,nz,ny) : q at the center of the grid boxes (m/s) +! bp (nx,nz,ny) : = 1/2*F, see below +! rp (nx,nz,ny) : = P-1/2*F*Q, see below ! ! # The equation for a turbulent quantity Q can be expressed as ! dQ/dt + Ah + Av = Dh + Dv + P - F*Q, (1) @@ -1324,38 +1766,45 @@ SUBROUTINE mym_predict (kts,kte,& & ust, flt, flq, pmz, phh, & & el, dfq, & & pdk, pdt, pdq, pdc,& - & qke, tsq, qsq, cov & + & qke, tsq, qsq, cov, & + & s_aw,s_awqke,bl_mynn_edmf_tke & &) !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte + INTEGER, INTENT(IN) :: kts,kte INTEGER, INTENT(IN) :: levflag - REAL, INTENT(IN) :: delt + INTEGER, INTENT(IN) :: bl_mynn_edmf_tke + REAL, INTENT(IN) :: delt REAL, DIMENSION(kts:kte), INTENT(IN) :: dz, dfq,el REAL, DIMENSION(kts:kte), INTENT(INOUT) :: pdk, pdt, pdq, pdc - REAL, INTENT(IN) :: flt, flq, ust, pmz, phh + REAL, INTENT(IN) :: flt, flq, ust, pmz, phh REAL, DIMENSION(kts:kte), INTENT(INOUT) :: qke,tsq, qsq, cov +! WA 8/3/15 + REAL, DIMENSION(kts:kte+1), INTENT(INOUT) :: s_awqke,s_aw INTEGER :: k,nz REAL, DIMENSION(kts:kte) :: qkw, bp, rp, df3q - REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l + REAL :: vkz,pdk1,phm,pdt1,pdq1,pdc1,b1l,b2l,onoff REAL, DIMENSION(kts:kte) :: dtz REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d nz=kte-kts+1 + ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) + IF (bl_mynn_edmf_tke == 0) THEN + onoff=0.0 + ELSE + onoff=1.0 + ENDIF + ! ** Strictly, vkz*h(i,j) -> vk*( 0.5*dz(1)*h(i,j)+z0 ) ** vkz = vk*0.5*dz(kts) ! -! Modified: Dec/22/2005, from here ! ** dfq for the TKE is 3.0*dfm. ** -! CALL coefvu ( dfq, 3.0 ) ! make change here -! Modified: Dec/22/2005, up to here ! DO k = kts,kte !! qke(k) = MAX(qke(k), 0.0) qkw(k) = SQRT( MAX( qke(k), 0.0 ) ) - !df3q(k)=3.*dfq(k) df3q(k)=Sqfac*dfq(k) dtz(k)=delt/dz(k) END DO @@ -1381,9 +1830,9 @@ SUBROUTINE mym_predict (kts,kte,& DO k = kts,kte-1 b1l = b1*0.5*( el(k+1)+el(k) ) bp(k) = 2.*qkw(k) / b1l - rp(k) = pdk(k+1) + pdk(k) + rp(k) = pdk(k+1) + pdk(k) END DO - + !! a(1)=0. !! b(1)=1. !! c(1)=-1. @@ -1391,10 +1840,16 @@ SUBROUTINE mym_predict (kts,kte,& ! Since df3q(kts)=0.0, a(1)=0.0 and b(1)=1.+dtz(k)*df3q(k+1)+bp(k)*delt. DO k=kts,kte-1 - a(k-kts+1)=-dtz(k)*df3q(k) - b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt - c(k-kts+1)=-dtz(k)*df3q(k+1) - d(k-kts+1)=rp(k)*delt + qke(k) +! a(k-kts+1)=-dtz(k)*df3q(k) +! b(k-kts+1)=1.+dtz(k)*(df3q(k)+df3q(k+1))+bp(k)*delt +! c(k-kts+1)=-dtz(k)*df3q(k+1) +! d(k-kts+1)=rp(k)*delt + qke(k) +! WA 8/3/15 add EDMF contribution + a(k-kts+1)=-dtz(k)*df3q(k) + 0.5*dtz(k)*s_aw(k)*onoff + b(k-kts+1)=1. + dtz(k)*(df3q(k)+df3q(k+1)) & + + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + bp(k)*delt + c(k-kts+1)=-dtz(k)*df3q(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(k-kts+1)=rp(k)*delt + qke(k) + dtz(k)*(s_awqke(k)-s_awqke(k+1))*onoff ENDDO !! DO k=kts+1,kte-1 @@ -1584,14 +2039,14 @@ END SUBROUTINE mym_predict ! virtual potential temperature minus tref. ! ! Output variables: see subroutine mym_initialize -! cld(mx,my,nz) : Cloud fraction +! cld(nx,nz,ny) : Cloud fraction ! ! Work arrays: -! qmq(mx,my,nz) : Q_w-Q_{sl}, where Q_{sl} is the saturation +! qmq(nx,nz,ny) : Q_w-Q_{sl}, where Q_{sl} is the saturation ! specific humidity at T=Tl -! alp(mx,my,nz) : Functions in the condensation process -! bet(mx,my,nz) : ditto -! sgm(mx,my,nz) : Combined standard deviation sigma_s +! alp(nx,nz,ny) : Functions in the condensation process +! bet(nx,nz,ny) : ditto +! sgm(nx,nz,ny) : Combined standard deviation sigma_s ! multiplied by 2/alp ! ! # qmq, alp, bet and sgm are allowed to share storage units with @@ -1601,43 +2056,62 @@ END SUBROUTINE mym_predict ! Set these values to those adopted by you. ! !------------------------------------------------------------------- - SUBROUTINE mym_condensation (kts,kte, & - & dz, & - & thl, qw, & - & p,exner, & - & tsq, qsq, cov, & - & Sh, el, bl_mynn_cloudpdf,& !JOE - cloud PDF testing + SUBROUTINE mym_condensation (kts,kte, & + & dx, dz, & + & thl, qw, & + & p,exner, & + & tsq, qsq, cov, & + & Sh, el, bl_mynn_cloudpdf,& !JOE - cloud PDF testing + & qc_bl1D, cldfra_bl1D, & !JOE - subgrid BL clouds + & PBLH1,HFX1, & !JOE - for subgrid BL clouds + & edmf_qc1, & & Vt, Vq) !------------------------------------------------------------------- - INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf + INTEGER, INTENT(IN) :: kts,kte, bl_mynn_cloudpdf + REAL, INTENT(IN) :: dx,PBLH1,HFX1 REAL, DIMENSION(kts:kte), INTENT(IN) :: dz REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, & - &tsq, qsq, cov + &tsq, qsq, cov, edmf_qc1 REAL, DIMENSION(kts:kte), INTENT(OUT) :: vt,vq - REAL, DIMENSION(kts:kte) :: qmq,alp,bet,sgm,ql,cld - + REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,sgm,ql,q1,cld,RH + REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,cldfra_bl1D DOUBLE PRECISION :: t3sq, r3sq, c3sq + +! WA TEST 8/6/15 save incoming qc and cldfra (from EDMF?) + ! REAL, DIMENSION(kts:kte) :: qc_prev,cldfra_prev ! - REAL :: p2a,t,esl,qsl,dqsl,q1,cld0,eq1,qll,& - &q2p,pt,rac,qt + REAL :: p2a,qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,eq1,qll,& + &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,fng,qww,alpha,beta,bb,ls,wt INTEGER :: i,j,k REAL :: erf !JOE: NEW VARIABLES FOR ALTERNATE SIGMA - REAL::dth,dqw,dzk + REAL::dth,dtl,dqw,dzk REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el -! Note: kte needs to be larger than kts, i.e., kte >= kts+1. + !JOE: variables for BL clouds + REAL::zagl,cld9,damp,edown,RHcrit,RHmean,RHsum,RHnum,Hshcu,PBLH2 + REAL, PARAMETER :: Hfac = 3.0 !cloud depth factor for HFX (m^3/W) + REAL, PARAMETER :: HFXmin = 50.0 !min W/m^2 for BL clouds + REAL :: RH_00L, RH_00O, phi_dz + REAL, PARAMETER :: cdz = 2.0 + REAL, PARAMETER :: mdz = 1.5 +! WA TEST 8/6/15 save incoming qc and cldfra (from EDMF?) + ! qc_prev = qc_bl1D + ! cldfra_prev = cldfra_bl1D + + zagl = 0. +! Note: kte needs to be larger than kts, i.e., kte >= kts+1. DO k = kts,kte-1 p2a = exner(k) - t = thl(k)*p2a + t = thl(k)*p2a !x if ( ct .gt. 0.0 ) then ! a = 17.27 @@ -1648,30 +2122,40 @@ SUBROUTINE mym_condensation (kts,kte, & !x end if ! ! ** 3.8 = 0.622*6.11 (hPa) ** + !SATURATED VAPOR PRESSURE - esl=svp11*EXP(svp2*(t-svpt0)/(t-svp3)) + esat = esat_blend(t) !SATURATED SPECIFIC HUMIDITY - qsl=ep_2*esl/(p(k)-ep_3*esl) + qsl=ep_2*esat/(p(k)-ep_3*esat) !dqw/dT: Clausius-Clapeyron dqsl = qsl*ep_2*ev/( rd*t**2 ) - !DEFICIT/EXCESS WATER CONTENT - qmq(k) = qw(k) -qsl + !RH (0 to 1.0) + RH(k)=MAX(MIN(1.0,qw(k)/MAX(1.E-8,qsl)),0.001) alp(k) = 1.0/( 1.0+dqsl*xlvcp ) bet(k) = dqsl*p2a -! - t3sq = MAX( tsq(k), 0.0 ) - r3sq = MAX( qsq(k), 0.0 ) - c3sq = cov(k) - c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) -! - r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq + IF (bl_mynn_cloudpdf == 0) THEN - !ORIGINAL STANDARD DEVIATION: limit e-6 produces ~10% more BL clouds than e-10 + !Sommeria and Deardorff (1977) scheme, as implemented + !in Nakanishi and Niino (2009), Appendix B + t3sq = MAX( tsq(k), 0.0 ) + r3sq = MAX( qsq(k), 0.0 ) + c3sq = cov(k) + c3sq = SIGN( MIN( ABS(c3sq), SQRT(t3sq*r3sq) ), c3sq ) + r3sq = r3sq +bet(k)**2*t3sq -2.0*bet(k)*c3sq + !DEFICIT/EXCESS WATER CONTENT + qmq(k) = qw(k) -qsl + !ORIGINAL STANDARD DEVIATION: limit e-6 produces ~10% more BL clouds + !than e-10 sgm(k) = SQRT( MAX( r3sq, 1.0d-10 )) - ELSE + !NORMALIZED DEPARTURE FROM SATURATION + q1(k) = qmq(k) / sgm(k) + !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 + cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + + ELSE IF (bl_mynn_cloudpdf == 1) THEN !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and - ! Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): + !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7): if (k .eq. kts) then dzk = 0.5*dz(k) else @@ -1679,43 +2163,238 @@ SUBROUTINE mym_condensation (kts,kte, & end if dth = 0.5*(thl(k+1)+thl(k)) - 0.5*(thl(k)+thl(MAX(k-1,kts))) dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) - sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,1.) * & + sgm(k) = SQRT( MAX( (alp(k)**2 * MAX(el(k)**2,0.1) * & b2 * MAX(Sh(k),0.03))/4. * & (dqw/dzk - bet(k)*(dth/dzk ))**2 , 1.0e-10) ) + qmq(k) = qw(k) -qsl + q1(k) = qmq(k) / sgm(k) + cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) ) + + ELSE IF (bl_mynn_cloudpdf >= 2) THEN + !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS + !JAYMES- this added 27 Apr 2015 + xl = xl_blend(t) ! obtain latent heat + + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + + qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio + ! at tl and p + + rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + + cpm = cp + qw(k)*cpv ! CB02, sec. 2, para. 1 + + a(k) = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + + qmq(k) = a(k) * (qw(k) - qsat_tl) ! saturation deficit/excess; + ! the numerator of Q1 + + b(k) = a(k)*rsl ! CB02 variable "b" + + dtl = 0.5*(thl(k+1)*(p(k+1)/p1000mb)**rcp + tlk) & + & - 0.5*(tlk + thl(MAX(k-1,kts))*(p(MAX(k-1,kts))/p1000mb)**rcp) + + dqw = 0.5*(qw(k+1) + qw(k)) - 0.5*(qw(k) + qw(MAX(k-1,kts))) + + if (k .eq. kts) then + dzk = 0.5*dz(k) + else + dzk = 0.5*( dz(k) + dz(k-1) ) + end if + + cdhdz = dtl/dzk + (g/cpm)*(1.+qw(k)) ! expression below Eq. 9 + ! in CB02 + + zagl = zagl + dz(k) + !ls = MIN(MAX(zagl,25.),300.) + ls = MIN(el(k),300.) + ! CB02 use 900 m as a (constant) free-atmosphere length scale. + ! The form above was selected based on HRRR tests. + + sgm(k) = MAX(1.e-10, 0.2*ls*SQRT(MAX(0., & ! Eq. 9 in CB02: + & (a(k)*dqw/dzk)**2 & ! < 1st term in brackets, + & -2*a(k)*b(k)*cdhdz*dqw/dzk & ! < 2nd term, + & +b(k)**2 * cdhdz**2))) ! < 3rd term + ! Per CB02, 0.2 is chosen as a constant. + + q1(k) = qmq(k) / sgm(k) ! Q1, the normalized saturation + + cld(k) = MAX(0., MIN(1., 0.5+0.36*ATAN(1.55*q1(k)))) ! Eq. 7 in CB02 + ENDIF END DO -! + + zagl = 0. + RHsum=0. + RHnum=0. + RHmean=0.1 !initialize with small value for small PBLH cases + damp =0 + PBLH2=MAX(10.,PBLH1) + DO k = kts,kte-1 - !NORMALIZED DEPARTURE FROM SATURATION - q1 = qmq(k) / sgm(k) - !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707 - cld(k) = 0.5*( 1.0+erf( q1*rr2 ) ) -! IF (cld(k) < 0. .OR. cld(k) > 1.) THEN -! PRINT*,"MYM_CONDENSATION, k=",k," cld=",cld(k) -! PRINT*," r3sq=",r3sq," t3sq=",t3sq," c3sq=",c3sq -! ENDIF -! q1=0. -! cld(k)=0. - - !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and - !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 - eq1 = rrp*EXP( -0.5*q1*q1 ) - qll = MAX( cld(k)*q1 + eq1, 0.0 ) - !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) - ql (k) = alp(k)*sgm(k)*qll -! - q2p = xlvcp/exner(k) - !POTENTIAL TEMPERATURE - pt = thl(k) +q2p*ql(k) - !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) - qt = 1.0 +p608*qw(k) -(1.+p608)*ql(k) - rac = alp(k)*( cld(k)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) - - !BUOYANCY FACTORS: wherever vt and vq are used, there is a - !"+1" and "+tv0", respectively, so these are subtracted out here. - !vt is unitless and vq has units of K. - vt (k) = qt-1.0 -rac*bet(k) - vq (k) = p608*pt-tv0 +rac + + IF (edmf_qc1(k) > 1.e-9) THEN + !RETAIN CLDFRA & QC_BL FROM MASS-FLUX SCHEME, but compute vt & vq + q1k = -0.7 + fng = -1.5*q1k + + xl = xl_blend(t) + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*edmf_qc1(k) ! potential temp + bb = b(k)*t/pt ! bb is "b" in BCMT95. Their "b" differs from + ! "b" in CB02 (i.e., b(k) above) by a factor + ! of T/theta. Strictly, b(k) above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qw(k) + alpha = 0.61*pt + p2a = exner(k) + t = thl(k)*p2a + beta = pt*xl/(t*cp) - 1.61*pt + + vt(k) = (1.-cldfra_bl1D(k))*qww + cldfra_bl1D(k)*(qww - beta*bb *(1.+fng)) - 1. + vq(k) = (1.-cldfra_bl1D(k))*alpha + cldfra_bl1D(k)*(alpha + beta*a(k)*(1.+fng)) - tv0 + ! These equations were derived by Jaymes, using BCMT95, Eq. B5, + ! in order to recast the BC02/BCMT95 buoyancy flux in terms of + ! vt and vq (i.e., beta-theta and beta-q in NN09, Eq. B8). + ! The "-1" and "-tv0" terms are included for consistency with + ! the legacy vt and vq formulations (above). + + ELSE + + q1k = q1(k) + zagl = zagl + dz(k) + !COMPUTE MEAN RH IN PBL (NOT PRESSURE WEIGHTED). + IF (zagl < PBLH2 .AND. PBLH2 > 400.) THEN + RHsum=RHsum+RH(k) + RHnum=RHnum+1.0 + RHmean=RHsum/RHnum + ENDIF +! IF (cld(k) < 0. .OR. cld(k) > 1.) THEN +! PRINT*,"MYM_CONDENSATION, k=",k," cld=",cld(k) +! PRINT*," r3sq=",r3sq," t3sq=",t3sq," c3sq=",c3sq +! ENDIF +! q1=0. +! cld(k)=0. + + IF ( bl_mynn_cloudpdf <= 1 ) THEN + + RHcrit = 1. - 0.35*(1.0 - (MAX(250.- MAX(HFX1,HFXmin),0.0)/200.)**2) + if(HFX1 > HFXmin)then + cld9=MIN(MAX(0., (rh(k)-RHcrit)/(1.1-RHcrit)), 1.)**2 + else + cld9=0.0 + endif + + edown=PBLH2*.1 + !Vary BL cloud depth (Hshcu) by mean RH in PBL and HFX + !(somewhat following results from Zhang and Klein (2013, JAS)) + Hshcu=200. + (RHmean+0.5)**1.5*MAX(HFX1,0.)*Hfac + if(zagl < PBLH2-edown)then + damp=MIN(1.0,exp(-ABS(((PBLH2-edown)-zagl)/edown))) + elseif(zagl >= PBLH2-edown .AND. zagl < PBLH2+Hshcu)then + damp=1. + elseif (zagl >= PBLH2+Hshcu)then + damp=MIN(1.0,exp(-ABS((zagl-(PBLH2+Hshcu))/500.))) + endif + ! cldfra_bl1D(k)=cld9*damp + cldfra_bl1D(k)=cld(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value + + !use alternate cloud fraction to estimate qc for use in BL clouds-radiation + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cldfra_bl1D(k)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql (k) = alp(k)*sgm(k)*qll + if(cldfra_bl1D(k)>0.01 .and. ql(k)<1.E-6)ql(k)=1.E-6 + ! qc_bl1D(k)=ql(k)*damp + qc_bl1D(k)=ql(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value + + !now recompute estimated lwc for PBL scheme's use + !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and + !Deardorff (1977, eq 29a). rrp = 1/(sqrt(2*pi)) = 0.3989 + eq1 = rrp*EXP( -0.5*q1k*q1k ) + qll = MAX( cld(k)*q1k + eq1, 0.0 ) + !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED) + ql (k) = alp(k)*sgm(k)*qll + + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*ql(k) ! potential temp + + !qt is a THETA-V CONVERSION FOR TOTAL WATER (i.e., THETA-V = qt*THETA) + qt = 1.0 +p608*qw(k) -(1.+p608)*ql(k) + rac = alp(k)*( cld(k)-qll*eq1 )*( q2p*qt-(1.+p608)*pt ) + + !BUOYANCY FACTORS: wherever vt and vq are used, there is a + !"+1" and "+tv0", respectively, so these are subtracted out here. + !vt is unitless and vq has units of K. + vt(k) = qt-1.0 -rac*bet(k) + vq(k) = p608*pt-tv0 +rac + + ELSE IF ( bl_mynn_cloudpdf == 2 ) THEN + ! JAYMES- this option added 8 May 2015 + ! The cloud water formulations are taken from CB02, Eq. 8. + ! "fng" represents the non-Gaussian contribution to the liquid + ! water flux; these formulations are from Cuijpers and Bechtold + ! (1995), Eq. 7. CB95 also draws from Bechtold et al. 1995, + ! hereafter BCMT95 + IF (q1k < 0.) THEN + ql (k) = sgm(k)*EXP(1.2*q1k-1) + ELSE IF (q1k > 2.) THEN + ql (k) = sgm(k)*q1k + ELSE + ql (k) = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2) + ENDIF + + !buoyancy-flux-related calculations follow + IF (q1k < -2.) THEN + fng = 1.-q1k + ELSE IF (q1k > 0.) THEN + fng = 0. + ELSE + fng = -1.5*q1k + ENDIF + + xl = xl_blend(t) + q2p = xlvcp/exner(k) + pt = thl(k) +q2p*ql(k) ! potential temp + bb = b(k)*t/pt ! bb is "b" in BCMT95. Their "b" differs from + ! "b" in CB02 (i.e., b(k) above) by a factor + ! of T/theta. Strictly, b(k) above is formulated in + ! terms of sat. mixing ratio, but bb in BCMT95 is + ! cast in terms of sat. specific humidity. The + ! conversion is neglected here. + qww = 1.+0.61*qw(k) + alpha = 0.61*pt + p2a = exner(k) + t = thl(k)*p2a + beta = pt*xl/(t*cp) - 1.61*pt + + vt(k) = (1.-cld(k))*qww + cld(k)*(qww - beta*bb *(1.+fng)) - 1. + vq(k) = (1.-cld(k))*alpha + cld(k)*(alpha + beta*a(k)*(1.+fng)) - tv0 + ! These equations were derived by Jaymes, using BCMT95, Eq. B5, + ! in order to recast the BC02/BCMT95 buoyancy flux in terms of + ! vt and vq (i.e., beta-theta and beta-q in NN09, Eq. B8). + ! The "-1" and "-tv0" terms are included for consistency with + ! the legacy vt and vq formulations (above). + + !return a cloud condensate and cloud fraction for icloud_bl option: + cldfra_bl1D(k) = cld(k) + qc_bl1D(k) = ql(k) + + ENDIF !end cloudPDF option + + ENDIF !end MF check + + !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother, + ! add limit to qc_bl and cldfra_bl: + IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6 + IF (CLDFRA_BL1D(k) < 1E-2)THEN + CLDFRA_BL1D(k)=0. + QC_BL1D(k)=0. + ENDIF + END DO ! @@ -1723,32 +2402,41 @@ SUBROUTINE mym_condensation (kts,kte, & ql(kte) = ql(kte-1) vt(kte) = vt(kte-1) vq(kte) = vq(kte-1) + qc_bl1D(kte)=0. + cldfra_bl1D(kte)=0. RETURN END SUBROUTINE mym_condensation ! ================================================================== - SUBROUTINE mynn_tendencies(kts,kte,& - &levflag,grav_settling,& - &delt,& - &dz,& - &u,v,th,qv,qc,qi,qni,& !qnc,& - &p,exner,& - &thl,sqv,sqc,sqi,sqw,& - &ust,flt,flq,flqv,flqc,wspd,qcg,& - &uoce,voce,& - &tsq,qsq,cov,& - &tcd,qcd,& - &dfm,dfh,dfq,& - &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqni&!,Dqnc& - &,vdfg1& !Katata/JOE-fogdes - &,FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC & - &) + SUBROUTINE mynn_tendencies(kts,kte, & + &levflag,grav_settling, & + &delt,dz, & + &u,v,th,tk,qv,qc,qi,qni,qnc, & + &p,exner, & + &thl,sqv,sqc,sqi,sqw, & + &ust,flt,flq,flqv,flqc,wspd,qcg, & + &uoce,voce, & + &tsq,qsq,cov, & + &tcd,qcd, & + &dfm,dfh,dfq, & + &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqni, &!Dqnc, & + &vdfg1, & + &s_aw,s_awthl,s_awqt,s_awqv,s_awqc, & + &s_awu,s_awv, & + &FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC, & + &cldfra_bl1d, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom ) !------------------------------------------------------------------- INTEGER, INTENT(in) :: kts,kte INTEGER, INTENT(in) :: grav_settling,levflag + INTEGER, INTENT(in) :: bl_mynn_cloudmix,bl_mynn_mixqt,& + bl_mynn_edmf,bl_mynn_edmf_mom LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC !! grav_settling = 1 or 2 for gravitational settling of droplets @@ -1759,11 +2447,14 @@ SUBROUTINE mynn_tendencies(kts,kte,& ! flt - surface flux of thl ! flq - surface flux of qw - REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,qv,qc,qi,qni,&!qnc,& - &p,exner,dfm,dfh,dfq,dz,tsq,qsq,cov,tcd,qcd - REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi + REAL,DIMENSION(kts:kte+1), INTENT(in) :: s_aw,s_awthl,s_awqt,& + s_awqv,s_awqc,s_awu,s_awv + REAL, DIMENSION(kts:kte), INTENT(in) :: u,v,th,tk,qv,qc,qi,qni,qnc,& + &p,exner,dfq,dz,tsq,qsq,cov,tcd,qcd,cldfra_bl1d + REAL, DIMENSION(kts:kte), INTENT(inout) :: thl,sqw,sqv,sqc,sqi,& + &dfm,dfh REAL, DIMENSION(kts:kte), INTENT(inout) :: du,dv,dth,dqv,dqc,dqi,& - &dqni!,dqnc + &dqni !,dqnc REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg ! REAL, INTENT(IN) :: delt,ust,flt,flq,qcg,& @@ -1771,72 +2462,96 @@ SUBROUTINE mynn_tendencies(kts,kte,& !local vars - REAL, DIMENSION(kts:kte) :: dtz,vt,vq,qni2!,qnc2 + REAL, DIMENSION(kts:kte) :: dtz,vt,vq,dfhc,dfmc !Kh for clouds (Pr < 2) + REAL, DIMENSION(kts:kte) :: sqv2,sqc2,sqi2,sqw2,qni2 !,qnc2 !AFTER MIXING REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d - REAL :: rhs,gfluxm,gfluxp,dztop - + REAL :: rhs,gfluxm,gfluxp,dztop,maxdfh,mindfh REAL :: grav_settling2,vdfg1 !Katata-fogdes - + REAL :: t,esat,qsl,onoff INTEGER :: k,kk,nz nz=kte-kts+1 dztop=.5*(dz(kte)+dz(kte-1)) + ! REGULATE THE MOMENTUM MIXING FROM THE MASS-FLUX SCHEME (on or off) + IF (bl_mynn_edmf_mom == 0) THEN + onoff=0.0 + ELSE + onoff=1.0 + ENDIF + ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so + ! we only need to zero-out the MF diffusivity term + maxdfh=maxval(dfh(1:15)) + mindfh=maxdfh*0.02 DO k=kts,kte dtz(k)=delt/dz(k) + !dfhc(k)=dfh(k) + !dfmc(k)=dfm(k) + IF (dfm(k) > dfh(k)) THEN + !in stable regime only, limit Prandtl number to < 2 within clouds + IF (qc(k) > 1.e-6 .OR. & + qi(k) > 1.e-6 .OR. & + cldfra_bl1D(k) > 0.05 ) THEN + !dfhc(k)= MAX(dfh(k),dfm(k)*0.5) + dfh(k)= MAX(dfh(k),dfm(k)*0.5) + ENDIF + ENDIF + !add small minimum Km & Kh in MF updrafts for edmf2 + IF(bl_mynn_edmf==2 .AND. k > 1 .AND. s_aw(k)>0.0) THEN + !dfhc(k)=MAX(mindfh,dfhc(k)) + !dfmc(k)=MAX(mindfh,dfmc(k)) + dfh(k)=MAX(mindfh,dfh(k)) + dfm(k)=MAX(mindfh,dfm(k)) + ENDIF ENDDO !!============================================ !! u !!============================================ - + k=kts a(1)=0. - b(1)=1.+dtz(k)*(dfm(k+1)+ust**2/wspd) - c(1)=-dtz(k)*dfm(k+1) -! d(1)=u(k) - d(1)=u(k)+dtz(k)*uoce*ust**2/wspd + b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff + c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1) !! a(1)=0. !! b(1)=1.+dtz(k)*dfm(k+1) !! c(1)=-dtz(k)*dfm(k+1) !! d(1)=u(k)*(1.-ust**2/wspd*dtz(k)) - + DO k=kts+1,kte-1 kk=k-kts+1 - a(kk)=-dtz(k)*dfm(k) - b(kk)=1.+dtz(k)*(dfm(k)+dfm(k+1)) - c(kk)=-dtz(k)*dfm(k+1) - d(kk)=u(k) + a(kk)=-dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff + b(kk)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + c(kk)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(kk)=u(k) + dtz(k)*(s_awu(k)-s_awu(k+1)) ENDDO !! no flux at the top - ! a(nz)=-1. ! b(nz)=1. ! c(nz)=0. ! d(nz)=0. !! specified gradient at the top - ! a(nz)=-1. ! b(nz)=1. ! c(nz)=0. ! d(nz)=gradu_top*dztop !! prescribed value - a(nz)=0 b(nz)=1. c(nz)=0. d(nz)=u(kte) CALL tridiag(nz,a,b,c,d) - + DO k=kts,kte du(k)=(d(k-kts+1)-u(k))/delt ENDDO @@ -1848,10 +2563,10 @@ SUBROUTINE mynn_tendencies(kts,kte,& k=kts a(1)=0. - b(1)=1.+dtz(k)*(dfm(k+1)+ust**2/wspd) - c(1)=-dtz(k)*dfm(k+1) + b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff + c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff ! d(1)=v(k) - d(1)=v(k)+dtz(k)*voce*ust**2/wspd + d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1) !! a(1)=0. !! b(1)=1.+dtz(k)*dfm(k+1) @@ -1860,36 +2575,32 @@ SUBROUTINE mynn_tendencies(kts,kte,& DO k=kts+1,kte-1 kk=k-kts+1 - a(kk)=-dtz(k)*dfm(k) - b(kk)=1.+dtz(k)*(dfm(k)+dfm(k+1)) - c(kk)=-dtz(k)*dfm(k+1) - d(kk)=v(k) + a(kk)=-dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff + b(kk)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff + c(kk)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff + d(kk)=v(k) + dtz(k)*(s_awv(k)-s_awv(k+1)) ENDDO !! no flux at the top - ! a(nz)=-1. ! b(nz)=1. ! c(nz)=0. ! d(nz)=0. - !! specified gradient at the top - ! a(nz)=-1. ! b(nz)=1. ! c(nz)=0. ! d(nz)=gradv_top*dztop !! prescribed value - a(nz)=0 b(nz)=1. c(nz)=0. d(nz)=v(kte) CALL tridiag(nz,a,b,c,d) - + DO k=kts,kte dv(k)=(d(k-kts+1)-v(k))/delt ENDDO @@ -1901,214 +2612,131 @@ SUBROUTINE mynn_tendencies(kts,kte,& k=kts a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - c(1)=-dtz(k)*dfh(k+1) - -!Katata - added -! grav_settling2 = MIN(REAL(grav_settling),1.) -!Katata - end -! -! if qcg not used then assume constant flux in the surface layer -!JOE-remove original code -! IF (qcg < qcgmin) THEN -! IF (sqc(k) > qcgmin) THEN -! gfluxm=grav_settling2*gno*sqc(k)**gpw -! ELSE -! gfluxm=0. -! ENDIF -! ELSE -! gfluxm=grav_settling2*gno*(qcg/(1.+qcg))**gpw -! ENDIF -!and replace with vdfg1 is computed in module_sf_fogdes.F. -! IF (sqc(k) > qcgmin) THEN -! !gfluxm=grav_settling2*gno*sqc(k)**gpw -! gfluxm=grav_settling2*sqc(k)*vdfg1 -! ELSE -! gfluxm=0. -! ENDIF -!JOE-end -! -! IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN -! gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw -! ELSE -! gfluxp=0. -! ENDIF + b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(1)=-dtz(k)*(dfh(k+1) + 0.5*s_aw(k+1)) - rhs= tcd(k) !-xlvcp/exner(k)*& -! ((gfluxp - gfluxm)/dz(k)) + rhs= tcd(k) + + d(1)=thl(k) + dtz(k)*flt + rhs*delt -dtz(1)*s_awthl(kts+1) - d(1)=thl(k) + dtz(k)*flt + rhs*delt - DO k=kts+1,kte-1 kk=k-kts+1 - a(kk)=-dtz(k)*dfh(k) - b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(kk)=-dtz(k)*dfh(k+1) + a(kk)=-dtz(k)*(dfh(k) - 0.5*s_aw(k)) + b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1) + 0.5*(s_aw(k)-s_aw(k+1))) + c(kk)=-dtz(k)*(dfh(k+1) + 0.5*s_aw(k+1)) -! IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN -! gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw -! ELSE -! gfluxp=0. -! ENDIF -! -! IF (.5*(sqc(k-1)+sqc(k)) > qcgmin) THEN -! gfluxm=grav_settling2*gno*(.5*(sqc(k-1)+sqc(k)))**gpw -! ELSE -! gfluxm=0. -! ENDIF + rhs= tcd(k) - rhs= tcd(k) !-xlvcp/exner(k)*& -! &((gfluxp - gfluxm)/dz(k)) - - d(kk)=thl(k) + rhs*delt + d(kk)=thl(k) + rhs*delt + dtz(k)*(s_awthl(k)-s_awthl(k+1)) ENDDO !! no flux at the top - ! a(nz)=-1. ! b(nz)=1. ! c(nz)=0. ! d(nz)=0. - -!! specified gradient at the top +!! specified gradient at the top !assume gradthl_top=gradth_top - ! a(nz)=-1. ! b(nz)=1. ! c(nz)=0. ! d(nz)=gradth_top*dztop !! prescribed value - a(nz)=0. b(nz)=1. c(nz)=0. d(nz)=thl(kte) CALL tridiag(nz,a,b,c,d) - + DO k=kts,kte thl(k)=d(k-kts+1) ENDDO -!!============================================ -!! NO LONGER MIX total water (sqw = sqc + sqv) -!! NOTE: no total water tendency is output -!!============================================ -! -! k=kts -! -! a(1)=0. -! b(1)=1.+dtz(k)*dfh(k+1) -! c(1)=-dtz(k)*dfh(k+1) -! -!JOE: replace orig code with fogdep -! IF (qcg < qcgmin) THEN -! IF (sqc(k) > qcgmin) THEN -! gfluxm=grav_settling2*gno*sqc(k)**gpw -! ELSE -! gfluxm=0. -! ENDIF -! ELSE -! gfluxm=grav_settling2*gno*(qcg/(1.+qcg))**gpw -! ENDIF -!and replace with fogdes code + remove use of qcg: -! IF (sqc(k) > qcgmin) THEN -! !gfluxm=grav_settling2*gno*(.5*(sqc(k)+sqc(k)))**gpw -! gfluxm=grav_settling2*sqc(k)*vdfg1 -! ELSE -! gfluxm=0. -! ENDIF -!JOE-end -! -! IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN -! gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw -! ELSE -! gfluxp=0. -! ENDIF -! -! rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& -! -! d(1)=sqw(k) + dtz(k)*flq + rhs*delt -! -! DO k=kts+1,kte-1 -! kk=k-kts+1 -! a(kk)=-dtz(k)*dfh(k) -! b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) -! c(kk)=-dtz(k)*dfh(k+1) -! -! IF (.5*(sqc(k+1)+sqc(k)) > qcgmin) THEN -! gfluxp=grav_settling2*gno*(.5*(sqc(k+1)+sqc(k)))**gpw -! ELSE -! gfluxp=0. -! ENDIF -! -! IF (.5*(sqc(k-1)+sqc(k)) > qcgmin) THEN -! gfluxm=grav_settling2*gno*(.5*(sqc(k-1)+sqc(k)))**gpw -! ELSE -! gfluxm=0. -! ENDIF -! -! rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& -! -! d(kk)=sqw(k) + rhs*delt -! ENDDO +IF (bl_mynn_mixqt > 0) THEN + !============================================ + ! MIX total water (sqw = sqc + sqv + sqi) + ! NOTE: no total water tendency is output; instead, we must calculate + ! the saturation specific humidity and then + ! subtract out the moisture excess (sqc & sqi) + !============================================ + k=kts -!! no flux at the top + a(1)=0. + b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(1)= -dtz(k)*(dfh(k+1) + 0.5*s_aw(k+1)) + + rhs= qcd(k) !+ (gfluxp - gfluxm)/dz(k)& + + d(1)=sqw(k) + dtz(k)*flq + rhs*delt - dtz(k)*s_awqt(k+1) + + DO k=kts+1,kte-1 + kk=k-kts+1 + a(kk)=-dtz(k)*(dfh(k) - 0.5*s_aw(k)) + b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1) + 0.5*(s_aw(k)-s_aw(k+1))) + c(kk)=-dtz(k)*(dfh(k+1) + 0.5*s_aw(k+1)) + + rhs= qcd(k) + d(kk)=sqw(k) + rhs*delt + dtz(k)*(s_awqt(k)-s_awqt(k+1)) + ENDDO + +!! no flux at the top ! a(nz)=-1. ! b(nz)=1. ! c(nz)=0. ! d(nz)=0. - !! specified gradient at the top !assume gradqw_top=gradqv_top - ! a(nz)=-1. ! b(nz)=1. ! c(nz)=0. ! d(nz)=gradqv_top*dztop - !! prescribed value + a(nz)=0. + b(nz)=1. + c(nz)=0. + d(nz)=sqw(kte) -! a(nz)=0. -! b(nz)=1. -! c(nz)=0. -! d(nz)=sqw(kte) -! -! CALL tridiag(nz,a,b,c,d) -! -! DO k=kts,kte -! sqw(k)=d(k-kts+1) -! ENDDO + CALL tridiag(nz,a,b,c,d) -!!============================================ -!! cloud water ( sqc ) -!!============================================ -IF (Cloudmix > 0.5 .AND. FLAG_QC) THEN + DO k=kts,kte + sqw2(k)=d(k-kts+1) + ENDDO +ELSE + sqw2=sqw +ENDIF + +IF (bl_mynn_mixqt == 0) THEN +!============================================ +! cloud water ( sqc ). If mixing total water (bl_mynn_mixqt > 0), +! then sqc will be backed out of saturation check (below). +!============================================ + IF (bl_mynn_cloudmix > 0 .AND. FLAG_QC) THEN k=kts a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - c(1)=-dtz(k)*dfh(k+1) + b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(1)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) rhs = qcd(k) - d(1)=sqc(k) + dtz(k)*flqc + rhs*delt + d(1)=sqc(k) + dtz(k)*flqc + rhs*delt -dtz(k)*s_awqc(k+1) DO k=kts+1,kte-1 kk=k-kts+1 - a(kk)=-dtz(k)*dfh(k) - b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(kk)=-dtz(k)*dfh(k+1) + a(kk)=-dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(kk)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) rhs = qcd(k) - d(kk)=sqc(k) + rhs*delt + d(kk)=sqc(k) + rhs*delt + dtz(k)*(s_awqc(k)-s_awqc(k+1)) ENDDO -!! prescribed value +! prescribed value a(nz)=0. b(nz)=1. c(nz)=0. @@ -2117,84 +2745,49 @@ SUBROUTINE mynn_tendencies(kts,kte,& CALL tridiag(nz,a,b,c,d) DO k=kts,kte - sqc(k)=d(k-kts+1) + sqc2(k)=d(k-kts+1) ENDDO - + ELSE + !If not mixing clouds, set "updated" array equal to original array + sqc2=sqc + ENDIF ENDIF -!!============================================ -!! cloud water number concentration ( qnc ) -!!============================================ -!IF (Cloudmix > 0.5 .AND. FLAG_QNC) THEN -! -! k=kts -! -! a(1)=0. -! b(1)=1.+dtz(k)*dfh(k+1) -! c(1)=-dtz(k)*dfh(k+1) -! -! rhs =qcd(k) -! d(1)=qnc(k) !+ dtz(k)*flqc + rhs*delt -! -! DO k=kts+1,kte-1 -! kk=k-kts+1 -! a(kk)=-dtz(k)*dfh(k) -! b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) -! c(kk)=-dtz(k)*dfh(k+1) -! -! rhs = qcd(k) -! d(kk)=qnc(k) + rhs*delt -! ENDDO -! -!! prescribed value -! a(nz)=0. -! b(nz)=1. -! c(nz)=0. -! d(nz)=qnc(kte) -! -! CALL tridiag(nz,a,b,c,d) -! -! DO k=kts,kte -! qnc2(k)=d(k-kts+1) -! ENDDO -! -!ELSE -! qnc2=qnc -!ENDIF - -!!============================================ -!! MIX WATER VAPOR ONLY ( sqv ) -!!============================================ +IF (bl_mynn_mixqt == 0) THEN + !============================================ + ! MIX WATER VAPOR ONLY ( sqv ). If mixing total water (bl_mynn_mixqt > 0), + ! then sqv will be backed out of saturation check (below). + !============================================ k=kts a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - c(1)=-dtz(k)*dfh(k+1) - d(1)=sqv(k) + dtz(k)*flqv + qcd(k)*delt + b(1)=1.+dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + c(1)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(1)=sqv(k) + dtz(k)*flqv + qcd(k)*delt - dtz(k)*s_awqv(k+1) !note: using qt, not qv... DO k=kts+1,kte-1 kk=k-kts+1 - a(kk)=-dtz(k)*dfh(k) - b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(kk)=-dtz(k)*dfh(k+1) - d(kk)=sqv(k) + qcd(k)*delt + a(kk)=-dtz(k)*dfh(k) + 0.5*dtz(k)*s_aw(k) + b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1)) + c(kk)=-dtz(k)*dfh(k+1) - 0.5*dtz(k)*s_aw(k+1) + d(kk)=sqv(k) + qcd(k)*delt + dtz(k)*(s_awqv(k)-s_awqv(k+1)) ENDDO -!! no flux at the top -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=0. +! no flux at the top +! a(nz)=-1. +! b(nz)=1. +! c(nz)=0. +! d(nz)=0. -!! specified gradient at the top -!assume gradqw_top=gradqv_top -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=gradqv_top*dztop +! specified gradient at the top +! assume gradqw_top=gradqv_top +! a(nz)=-1. +! b(nz)=1. +! c(nz)=0. +! d(nz)=gradqv_top*dztop -!! prescribed value +! prescribed value a(nz)=0. b(nz)=1. c(nz)=0. @@ -2203,27 +2796,30 @@ SUBROUTINE mynn_tendencies(kts,kte,& CALL tridiag(nz,a,b,c,d) DO k=kts,kte - sqv(k)=d(k-kts+1) + sqv2(k)=d(k-kts+1) ENDDO +ELSE + sqv2=sqv +ENDIF -!!============================================ -!! MIX CLOUD ICE ( sqi ) -!!============================================ -IF (Cloudmix > 0.5 .AND. FLAG_QI) THEN +!============================================ +! MIX CLOUD ICE ( sqi ) +!============================================ +IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN k=kts a(1)=0. b(1)=1.+dtz(k)*dfh(k+1) c(1)=-dtz(k)*dfh(k+1) - d(1)=sqi(k) + qcd(k)*delt !should we have qcd for ice??? + d(1)=sqi(k) !+ qcd(k)*delt !should we have qcd for ice??? DO k=kts+1,kte-1 kk=k-kts+1 a(kk)=-dtz(k)*dfh(k) b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) c(kk)=-dtz(k)*dfh(k+1) - d(kk)=sqi(k) + qcd(k)*delt + d(kk)=sqi(k) !+ qcd(k)*delt ENDDO !! no flux at the top @@ -2234,12 +2830,12 @@ SUBROUTINE mynn_tendencies(kts,kte,& !! specified gradient at the top !assume gradqw_top=gradqv_top -! a(nz)=-1. -! b(nz)=1. -! c(nz)=0. -! d(nz)=gradqv_top*dztop +! a(nz)=-1. +! b(nz)=1. +! c(nz)=0. +! d(nz)=gradqv_top*dztop -!! prescribed value +!! prescribed value a(nz)=0. b(nz)=1. c(nz)=0. @@ -2248,73 +2844,257 @@ SUBROUTINE mynn_tendencies(kts,kte,& CALL tridiag(nz,a,b,c,d) DO k=kts,kte - sqi(k)=d(k-kts+1) + sqi2(k)=d(k-kts+1) ENDDO - +ELSE + sqi2=sqi ENDIF !!============================================ -!! ice water number concentration (qni) +!! cloud ice number concentration (qni) !!============================================ -IF (Cloudmix > 0.5 .AND. FLAG_QNI) THEN +! diasbled this since scalar_pblmix option can be invoked instead +!IF (bl_mynn_cloudmix > 0 .AND. FLAG_QNI) THEN +! +! k=kts +! +! a(1)=0. +! b(1)=1.+dtz(k)*dfh(k+1) +! c(1)=-dtz(k)*dfh(k+1) +! +! rhs = qcd(k) +! +! d(1)=qni(k) !+ dtz(k)*flqc + rhs*delt +! +! DO k=kts+1,kte-1 +! kk=k-kts+1 +! a(kk)=-dtz(k)*dfh(k) +! b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) +! c(kk)=-dtz(k)*dfh(k+1) +! +! rhs = qcd(k) +! d(kk)=qni(k) !+ rhs*delt +! +! ENDDO +! +!! prescribed value +! a(nz)=0. +! b(nz)=1. +! c(nz)=0. +! d(nz)=qni(kte) +! +! CALL tridiag(nz,a,b,c,d) +! +! DO k=kts,kte +! qni2(k)=d(k-kts+1) +! ENDDO +!ELSE + qni2=qni +!ENDIF - k=kts +!!============================================ +!! Compute tendencies and convert to mixing ratios for WRF. +!! Note that the momentum tendencies are calculated above. +!!============================================ - a(1)=0. - b(1)=1.+dtz(k)*dfh(k+1) - c(1)=-dtz(k)*dfh(k+1) + DO k=kts,kte - rhs = qcd(k) + IF (bl_mynn_mixqt > 0) THEN + t = thl(k)*exner(k) + !SATURATED VAPOR PRESSURE + esat=esat_blend(t) + !SATURATED SPECIFIC HUMIDITY + qsl=ep_2*esat/(p(k)-ep_3*esat) + + !IF (qsl >= sqw2(k)) THEN !unsaturated + ! sqv2(k) = MAX(0.0,sqw2(k)) + ! sqi2(k) = MAX(0.0,sqi2(k)) + ! sqc2(k) = MAX(0.0,sqw2(k) - sqv2(k) - sqi2(k)) + !ELSE !saturated + IF (FLAG_QI) THEN + !sqv2(k) = qsl + sqi2(k) = MAX(0., sqi2(k)) + sqc2(k) = MAX(0., sqw2(k) - sqi2(k) - qsl) !updated cloud water + sqv2(k) = MAX(0., sqw2(k) - sqc2(k) - sqi2(k)) !updated water vapor + ELSE + !sqv2(k) = qsl + sqi2(k) = 0.0 + sqc2(k) = MAX(0., sqw2(k) - qsl) !updated cloud water + sqv2(k) = MAX(0., sqw2(k) - sqc2(k)) ! updated water vapor + ENDIF + !ENDIF + ENDIF - d(1)=qni(k) !+ dtz(k)*flqc + rhs*delt + !===================== + ! WATER VAPOR TENDENCY + !===================== + Dqv(k)=(sqv2(k)/(1.-sqv2(k)) - qv(k))/delt + !IF(-Dqv(k) > qv(k)) Dqv(k)=-qv(k) + + !===================== + ! CLOUD WATER TENDENCY + !===================== + !qc fog settling tendency is now computed in module_bl_fogdes.F, so + !sqc should only be changed by eddy diffusion or mass-flux. + !print*,"FLAG_QC:",FLAG_QC + IF (bl_mynn_cloudmix > 0 .AND. FLAG_QC) THEN + Dqc(k)=(sqc2(k)/(1.-sqc2(k)) - qc(k))/delt + IF(Dqc(k)*delt + qc(k) < 0.) THEN + !WRITE ( mynn_message , FMT='(A,5(F8.6,A1),F6.1)' ) & + !' MYNN; neg qc: ',qsl,' ',sqw2(k),' ',sqi2(k),' ',sqc2(k),' ',qc(k),' ',tk(k) + !CALL wrf_debug ( 0 , mynn_message ) + Dqc(k)=-qc(k)/delt + ENDIF + + !REMOVED MIXING OF QNC - PERFORMED IN THE SCALAR_PBLMIX OPTION + !IF (FLAG_QNC) THEN + ! IF(sqc2(k)>1.e-9)qnc2(k)=MAX(qnc2(k),1.e6) + ! Dqnc(k) = (qnc2(k)-qnc(k))/delt + ! IF(Dqnc(k)*delt + qnc(k) < 0.)Dqnc(k)=-qnc(k)/delt + !ELSE + ! Dqnc(k) = 0. + !ENDIF + ELSE + Dqc(k)=0. + !Dqnc(k)=0. + ENDIF - DO k=kts+1,kte-1 - kk=k-kts+1 - a(kk)=-dtz(k)*dfh(k) - b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) - c(kk)=-dtz(k)*dfh(k+1) + !=================== + ! CLOUD ICE TENDENCY + !=================== + IF (bl_mynn_cloudmix > 0 .AND. FLAG_QI) THEN + Dqi(k)=(sqi2(k)/(1.-sqi2(k)) - qi(k))/delt + IF(Dqi(k)*delt + qi(k) < 0.) THEN + !WRITE ( mynn_message , FMT='(A,5(F8.6,A1),F6.1)' ) & + !' MYNN; neg qi; ',qsl,' ',sqw2(k),' ',sqi2(k),' ',sqc2(k),' ',qi(k),' ',tk(k) + !CALL wrf_debug ( 0 , mynn_message ) + Dqi(k)=-qi(k)/delt + ENDIF + + !REMOVED MIXING OF QNI - PERFORMED IN THE SCALAR_PBLMIX OPTION + !SET qni2 = qni above, so all tendencies are zero + IF (FLAG_QNI) THEN + Dqni(k)=(qni2(k)-qni(k))/delt + IF(Dqni(k)*delt + qni(k) < 0.)Dqni(k)=-qni(k)/delt + ELSE + Dqni(k)=0. + ENDIF + ELSE + Dqi(k)=0. + Dqni(k)=0. + ENDIF - rhs = qcd(k) - d(kk)=qni(k) + rhs*delt + !=================== + ! THETA TENDENCY + !=================== + IF (FLAG_QI) THEN + !Dth(k)=(thl(k) + xlvcp/exner(k)*sqc(k) & + ! & + xlscp/exner(k)*sqi(k) & + ! & - th(k))/delt + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy: + Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k) & + & + xlscp/MAX(tk(k),TKmin)*sqi2(k)) & + & - th(k))/delt + ELSE + !Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k)) & + & - th(k))/delt + ENDIF ENDDO -!! prescribed value - a(nz)=0. - b(nz)=1. - c(nz)=0. - d(nz)=qni(kte) + END SUBROUTINE mynn_tendencies - CALL tridiag(nz,a,b,c,d) +! ================================================================== +#if (WRF_CHEM == 1) + SUBROUTINE mynn_mix_chem(kts,kte, & + levflag,grav_settling, & + delt,dz, & + nchem, kdvel, ndvel, num_vert_mix, & + chem1, vd1, & + qni,qnc, & + p,exner, & + thl,sqv,sqc,sqi,sqw, & + ust,flt,flq,flqv,flqc,wspd,qcg, & + uoce,voce, & + tsq,qsq,cov, & + tcd,qcd, & + dfm,dfh,dfq, & + s_awchem, & + bl_mynn_cloudmix) + +!------------------------------------------------------------------- + INTEGER, INTENT(in) :: kts,kte + INTEGER, INTENT(in) :: grav_settling,levflag + INTEGER, INTENT(in) :: bl_mynn_cloudmix + + REAL, DIMENSION(kts:kte), INTENT(IN) :: qni,qnc,& + &p,exner,dfm,dfh,dfq,dz,tsq,qsq,cov,tcd,qcd + REAL, DIMENSION(kts:kte), INTENT(INOUT) :: thl,sqw,sqv,sqc,sqi + REAL, INTENT(IN) :: delt,ust,flt,flq,flqv,flqc,wspd,uoce,voce,qcg + INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix + REAL, DIMENSION( kts:kte, nchem ), INTENT(INOUT) :: chem1 + REAL, DIMENSION( kts:kte+1,nchem), INTENT(IN) :: s_awchem + REAL, DIMENSION( ndvel ), INTENT(INOUT) :: vd1 + +!local vars + + REAL, DIMENSION(kts:kte) :: dtz,vt,vq + REAL, DIMENSION(1:kte-kts+1) :: a,b,c,d + REAL :: rhs,gfluxm,gfluxp,dztop + REAL :: t,esl,qsl + INTEGER :: k,kk,nz + INTEGER :: ic ! Chemical array loop index + REAL, DIMENSION( kts:kte, nchem ) :: chem_new + + nz=kte-kts+1 + + dztop=.5*(dz(kte)+dz(kte-1)) DO k=kts,kte - qni2(k)=d(k-kts+1) + dtz(k)=delt/dz(k) ENDDO -ELSE - qni2=qni -ENDIF -!!============================================ -!! convert to mixing ratios for wrf -!!============================================ -!!NOTE: added number conc tendencies for double moment schemes + !============================================ + ! Patterned after mixing of water vapor in mynn_tendencies. + !============================================ + + DO ic = 1,nchem + k=kts + + a(1)=0. + b(1)=1.+dtz(k)*dfh(k+1) + c(1)=-dtz(k)*dfh(k+1) + ! d(1)=sqv(k) + dtz(k)*flqv + qcd(k)*delt + d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic) + + DO k=kts+1,kte-1 + kk=k-kts+1 + a(kk)=-dtz(k)*dfh(k) + b(kk)=1.+dtz(k)*(dfh(k)+dfh(k+1)) + c(kk)=-dtz(k)*dfh(k+1) + ! d(kk)=chem1(k,ic) + qcd(k)*delt + d(kk)=chem1(k,ic) + rhs*delt + dtz(k)*(s_awchem(k,ic)-s_awchem(k+1,ic)) + ENDDO - DO k=kts,kte - !sqw(k)=d(k-kts+1) - Dqv(k)=(sqv(k)/(1.-sqv(k))-qv(k))/delt - !qc settling tendency is now computed in module_bl_fogdes.F, so - !sqc should only be changed by turbulent mixing. - Dqc(k)=(sqc(k)/(1.-sqc(k))-qc(k))/delt - Dqi(k)=(sqi(k)/(1.-sqi(k))-qi(k))/delt - ! Dqnc(k)=(qnc2(k)-qnc(k))/delt - Dqni(k)=(qni2(k)-qni(k))/delt - Dth(k)=(thl(k) + xlvcp/exner(k)*sqc(k) & - & + xlscp/exner(k)*sqi(k) & - & - th(k))/delt - !Dth(k)=(thl(k)+xlvcp/exner(k)*sqc(k)-th(k))/delt + ! prescribed value at top + a(nz)=0. + b(nz)=1. + c(nz)=0. + d(nz)=chem1(kte,ic) + + CALL tridiag(nz,a,b,c,d) + + DO k=kts,kte + chem_new(k,ic)=d(k-kts+1) + ENDDO ENDDO - END SUBROUTINE mynn_tendencies + END SUBROUTINE mynn_mix_chem +#endif ! ================================================================== SUBROUTINE retrieve_exchange_coeffs(kts,kte,& @@ -2342,7 +3122,7 @@ SUBROUTINE retrieve_exchange_coeffs(kts,kte,& dzk = 0.5 *( dz(k)+dz(k-1) ) K_m(k)=dfm(k)*dzk K_h(k)=dfh(k)*dzk - K_q(k)=dfq(k)*dzk + K_q(k)=Sqfac*dfq(k)*dzk ENDDO END SUBROUTINE retrieve_exchange_coeffs @@ -2384,31 +3164,40 @@ END SUBROUTINE tridiag ! ================================================================== SUBROUTINE mynn_bl_driver(& - &initflag,& - &grav_settling,& - &delt,& - &dz,& - &u,v,th,qv,qc,qi,qni,&! qnc& !JOE: ice & num conc mixing - &p,exner,rho,& - &xland,ts,qsfc,qcg,ps,& - &ust,ch,hfx,qfx,rmol,wspd,& - &uoce,voce,& !ocean current - &vdfg,& !Katata-added for fog dep - &Qke,tke_pbl,& !JOE: add TKE for coupling - &qke_adv,bl_mynn_tkeadvect,& !ACF for QKE advection - &Tsq,Qsq,Cov,& - &Du,Dv,Dth,& - &Dqv,Dqc,Dqi,Dqni,& !Dqnc,& !JOE: ice & nim conc mixing -! &K_m,K_h,K_q& - &K_h,k_m,& - &Pblh,kpbl& !JOE-added kpbl for coupling - &,el_pbl& - &,dqke,qWT,qSHEAR,qBUOY,qDISS & !JOE-TKE BUDGET - &,wstar,delta & !JOE-added for grims - &,bl_mynn_tkebudget & !JOE-TKE BUDGET - &,bl_mynn_cloudpdf,Sh3D & !JOE-cloudPDF testing - ! optional arguments - &,FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC & + &initflag,grav_settling, & + &delt,dz,dx,znt, & + &u,v,w,th,qv,qc,qi,qni,qnc, & + &p,exner,rho,T3D, & + &xland,ts,qsfc,qcg,ps, & + &ust,ch,hfx,qfx,rmol,wspd, & + &uoce,voce, & !ocean current + &vdfg, & !Katata-added for fog dep + &Qke,tke_pbl, & + &qke_adv,bl_mynn_tkeadvect, & !ACF for QKE advection +#if (WRF_CHEM == 1) + chem3d, vd3d, nchem, & ! WA 7/29/15 For WRF-Chem + kdvel, ndvel, num_vert_mix, & +#endif + &Tsq,Qsq,Cov, & + &RUBLTEN,RVBLTEN,RTHBLTEN, & + &RQVBLTEN,RQCBLTEN,RQIBLTEN, & + &RQNIBLTEN, & !RQNCBLTEN, & + &exch_h,exch_m, & + &Pblh,kpbl, & + &el_pbl, & + &dqke,qWT,qSHEAR,qBUOY,qDISS, & !JOE-TKE BUDGET + &wstar,delta, & !JOE-added for grims + &bl_mynn_tkebudget, & !JOE-TKE BUDGET + &bl_mynn_cloudpdf,Sh3D, & !JOE-cloudPDF testing + &bl_mynn_mixlength, & !JAYMES- mixing length options + &icloud_bl,qc_bl,cldfra_bl, & !JOE-subgrid bl clouds + &bl_mynn_edmf, & !JOE- edmf + &bl_mynn_edmf_mom,bl_mynn_edmf_tke, & + &bl_mynn_edmf_part, & !JOE- edmf + &bl_mynn_cloudmix,bl_mynn_mixqt, & !JOE- cloud mixing methods + &edmf_a,edmf_w,edmf_qt, & + &edmf_thl,edmf_ent,edmf_qc, & + &FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC & &,IDS,IDE,JDS,JDE,KDS,KDE & &,IMS,IME,JMS,JME,KMS,KME & &,ITS,ITE,JTS,JTE,KTS,KTE) @@ -2420,7 +3209,15 @@ SUBROUTINE mynn_bl_driver(& INTEGER, INTENT(in) :: grav_settling INTEGER, INTENT(in) :: bl_mynn_tkebudget INTEGER, INTENT(in) :: bl_mynn_cloudpdf + INTEGER, INTENT(in) :: bl_mynn_mixlength + INTEGER, INTENT(in) :: bl_mynn_edmf LOGICAL, INTENT(IN) :: bl_mynn_tkeadvect + INTEGER, INTENT(in) :: bl_mynn_edmf_mom + INTEGER, INTENT(in) :: bl_mynn_edmf_tke + INTEGER, INTENT(in) :: bl_mynn_edmf_part + INTEGER, INTENT(in) :: bl_mynn_cloudmix + INTEGER, INTENT(in) :: bl_mynn_mixqt + INTEGER, INTENT(in) :: icloud_bl LOGICAL, INTENT(IN) :: FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC @@ -2437,16 +3234,13 @@ SUBROUTINE mynn_bl_driver(& ! grav_settling = 1 when gravitational settling accounted for ! grav_settling = 0 when gravitational settling NOT accounted for - REAL, INTENT(in) :: delt + REAL, INTENT(in) :: delt,dx REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(in) :: dz,& - &u,v,th,qv,qc,p,exner,rho + &u,v,w,th,qv,p,exner,rho,T3D REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), OPTIONAL, INTENT(in)::& - &qi,qni! ,qnc + &qc,qi,qni,qnc REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(in) :: xland,ust,& -! &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd,uoce,voce -!Katata-added for extra in-output - &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd,uoce,voce, vdfg -!Katata-end + &ch,rmol,ts,qsfc,qcg,ps,hfx,qfx, wspd,uoce,voce, vdfg,znt REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & &Qke,Tsq,Qsq,Cov, & @@ -2454,42 +3248,71 @@ SUBROUTINE mynn_bl_driver(& &qke_adv !ACF for QKE advection REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & - &Du,Dv,Dth,Dqv,Dqc,Dqi,Dqni!,Dqnc + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,RQCBLTEN,& + &RQIBLTEN,RQNIBLTEN !,RQNCBLTEN REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & - &K_h,K_m + &exch_h,exch_m + + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), OPTIONAL, INTENT(inout) :: & + & edmf_a,edmf_w,edmf_qt,edmf_thl,edmf_ent,edmf_qc REAL, DIMENSION(IMS:IME,JMS:JME), INTENT(inout) :: & &Pblh,wstar,delta !JOE-added for GRIMS + + REAL, DIMENSION(IMS:IME,JMS:JME) :: & + &Psig_bl,Psig_shcu + INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: & &KPBL REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & &el_pbl -!JOE-TKE BUDGET REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(out) :: & &qWT,qSHEAR,qBUOY,qDISS,dqke ! 3D budget arrays are not allocated when bl_mynn_tkebudget == 0. ! 1D (local) budget arrays are used for passing between subroutines. REAL, DIMENSION(KTS:KTE) :: qWT1,qSHEAR1,qBUOY1,qDISS1,dqke1 -!JOE-end + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME) :: K_q,Sh3D + REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: & + &qc_bl,cldfra_bl + REAL, DIMENSION(KTS:KTE) :: qc_bl1D,cldfra_bl1D + +! WA 7/29/15 Mix chemical arrays +#if (WRF_CHEM == 1) + INTEGER, INTENT(IN ) :: nchem, kdvel, ndvel, num_vert_mix + REAL, DIMENSION( ims:ime, kts:kte, jms:jme, nchem ), INTENT(INOUT) :: chem3d + REAL, DIMENSION( ims:ime, kdvel, jms:jme, ndvel ), INTENT(IN) :: vd3d + REAL, DIMENSION( kts:kte, nchem ) :: chem1 + REAL, DIMENSION( kts:kte+1, nchem ) :: s_awchem1 + REAL, DIMENSION( ndvel ) :: vd1 + INTEGER ic +#endif + !local vars INTEGER :: ITF,JTF,KTF, IMD,JMD INTEGER :: i,j,k - REAL, DIMENSION(KTS:KTE) :: thl,sqv,sqc,sqi,sqw,& + REAL, DIMENSION(KTS:KTE) :: thl,tl,sqv,sqc,sqi,sqw,& &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, Vt, Vq - REAL, DIMENSION(KTS:KTE) :: thetav,sh,u1,v1,p1,ex1,dz1,th1,qke1, & - & tsq1,qsq1,cov1,qv1,qi1,qc1,du1,dv1,dth1,dqv1,dqc1,dqi1, & - & k_m1,k_h1,k_q1,qni1,dqni1!,qnc1,dqnc1 + REAL, DIMENSION(KTS:KTE) :: thetav,sh,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,& + & qke1,tsq1,qsq1,cov1,qv1,qi1,qc1,du1,dv1,dth1,dqv1,dqc1,dqi1, & + & k_m1,k_h1,k_q1,qni1,dqni1,qnc1 !,dqnc1 + +!JOE: mass-flux variables + REAL, DIMENSION(KTS:KTE) :: dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf + REAL, DIMENSION(KTS:KTE) :: edmf_a1,edmf_w1,edmf_qt1,edmf_thl1,& + edmf_ent1,edmf_qc1 + REAL,DIMENSION(KTS:KTE+1) :: s_aw1,s_awthl1,s_awqt1,& + s_awqv1,s_awqc1,s_awu1,s_awv1,s_awqke1 REAL, DIMENSION(KTS:KTE+1) :: zw - - REAL :: cpm,sqcg,flt,flq,flqv,flqc,pmz,phh,exnerg,zet,& + REAL :: cpm,sqcg,flt,flq,flqv,flqc,pmz,phh,exnerg,zet,& &afk,abk + !JOE-add GRIMS parameters & variables real,parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 real,parameter :: h1 = 0.33333335, h2 = 0.6666667 @@ -2497,6 +3320,12 @@ SUBROUTINE mynn_bl_driver(& !JOE-end GRIMS INTEGER, SAVE :: levflag + IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + WRITE ( mynn_message , FMT='(A)' ) & + 'in MYNN driver; at beginning' + CALL wrf_debug ( 0 , mynn_message ) + ENDIF + !*** Begin debugging IMD=(IMS+IME)/2 JMD=(JMS+JME)/2 @@ -2508,6 +3337,18 @@ SUBROUTINE mynn_bl_driver(& levflag=mynn_level + IF (bl_mynn_edmf > 0) THEN + ! setup random seed + call init_random_seed + + edmf_a(its:ite,kts:kte,jts:jte)=0. + edmf_w(its:ite,kts:kte,jts:jte)=0. + edmf_qt(its:ite,kts:kte,jts:jte)=0. + edmf_thl(its:ite,kts:kte,jts:jte)=0. + edmf_ent(its:ite,kts:kte,jts:jte)=0. + edmf_qc(its:ite,kts:kte,jts:jte)=0. + ENDIF + IF (initflag > 0) THEN Sh3D(its:ite,kts:kte,jts:jte)=0. @@ -2515,6 +3356,14 @@ SUBROUTINE mynn_bl_driver(& tsq(its:ite,kts:kte,jts:jte)=0. qsq(its:ite,kts:kte,jts:jte)=0. cov(its:ite,kts:kte,jts:jte)=0. + dqc1(kts:kte)=0.0 + dqi1(kts:kte)=0.0 + dqni1(kts:kte)=0.0 + !dqnc1(kts:kte)=0.0 + qc_bl1D(kts:kte)=0.0 + cldfra_bl1D(kts:kte)=0.0 + edmf_a1(kts:kte)=0.0 + edmf_qc1(kts:kte)=0.0 DO j=JTS,JTF DO i=ITS,ITF @@ -2522,19 +3371,29 @@ SUBROUTINE mynn_bl_driver(& dz1(k)=dz(i,k,j) u1(k) = u(i,k,j) v1(k) = v(i,k,j) + w1(k) = w(i,k,j) th1(k)=th(i,k,j) + tk1(k)=T3D(i,k,j) + rho1(k)=rho(i,k,j) sqc(k)=qc(i,k,j)/(1.+qc(i,k,j)) sqv(k)=qv(i,k,j)/(1.+qv(i,k,j)) thetav(k)=th(i,k,j)*(1.+0.61*sqv(k)) IF (PRESENT(qi) .AND. FLAG_QI ) THEN sqi(k)=qi(i,k,j)/(1.+qi(i,k,j)) sqw(k)=sqv(k)+sqc(k)+sqi(k) - thl(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc(k) & - & - xlscp/exner(i,k,j)*sqi(k) + !thl(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc(k) & + ! & - xlscp/exner(i,k,j)*sqi(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) ELSE sqi(k)=0.0 sqw(k)=sqv(k)+sqc(k) - thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) + !thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) ENDIF IF (k==kts) THEN @@ -2543,10 +3402,10 @@ SUBROUTINE mynn_bl_driver(& zw(k)=zw(k-1)+dz(i,k-1,j) ENDIF - k_m(i,k,j)=0. - k_h(i,k,j)=0. - k_q(i,k,j)=0. - qke(i,k,j)=0.1-MIN(zw(k)*0.001, 0.0) + exch_m(i,k,j)=0. + exch_h(i,k,j)=0. + K_q(i,k,j)=0. + qke(i,k,j)=0.1-MIN(zw(k)*0.001, 0.0) !for initial PBLH calc only qke1(k)=qke(i,k,j) el(k)=el_pbl(i,k,j) sh(k)=Sh3D(i,k,j) @@ -2565,16 +3424,25 @@ SUBROUTINE mynn_bl_driver(& ENDDO zw(kte+1)=zw(kte)+dz(i,kte,j) - + CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) + + IF (scaleaware > 0.) THEN + CALL SCALE_AWARE(dx,PBLH(i,j),Psig_bl(i,j),Psig_shcu(i,j)) + ELSE + Psig_bl(i,j)=1.0 + Psig_shcu(i,j)=1.0 + ENDIF - CALL mym_initialize ( kts,kte,& - &dz1, zw, u1, v1, thl, sqv,& - &PBLH(i,j),th1,& !JOE-BouLac mod - &sh,& !JOE-cloudPDF mod - &ust(i,j), rmol(i,j),& - &el, Qke1, Tsq1, Qsq1, Cov1) + CALL mym_initialize ( kts,kte, & + &dz1, zw, u1, v1, thl, sqv, & + &PBLH(i,j), th1, sh, & + &ust(i,j), rmol(i,j), & + &el, Qke1, Tsq1, Qsq1, Cov1, & + &Psig_bl(i,j), cldfra_bl1D, & + &bl_mynn_mixlength, & + &edmf_a1,edmf_qc1,bl_mynn_edmf ) !UPDATE 3D VARIABLES DO k=KTS,KTE !KTF @@ -2584,18 +3452,17 @@ SUBROUTINE mynn_bl_driver(& tsq(i,k,j)=tsq1(k) qsq(i,k,j)=qsq1(k) cov(i,k,j)=cov1(k) -!ACF,JOE- initialize qke_adv array if using advection + !ACF,JOE- initialize qke_adv array if using advection IF (bl_mynn_tkeadvect) THEN qke_adv(i,k,j)=qke1(k) ENDIF -!ACF,JOE-end ENDDO !*** Begin debugging ! k=kdebug ! IF(I==IMD .AND. J==JMD)THEN ! PRINT*,"MYNN DRIVER INIT: k=",1," sh=",sh(k) -! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",k_m(i,k,j) +! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k,j) ! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) ! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",Tsq(i,k,j) ! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) @@ -2607,11 +3474,10 @@ SUBROUTINE mynn_bl_driver(& ENDIF ! end initflag -!ACF copy qke_adv array into qke if using advection + !ACF- copy qke_adv array into qke if using advection IF (bl_mynn_tkeadvect) THEN qke=qke_adv ENDIF -!ACF-end DO j=JTS,JTF DO i=ITS,ITF @@ -2623,36 +3489,50 @@ SUBROUTINE mynn_bl_driver(& dz1(k)= dz(i,k,j) u1(k) = u(i,k,j) v1(k) = v(i,k,j) + w1(k) = w(i,k,j) th1(k)= th(i,k,j) + tk1(k)=T3D(i,k,j) + rho1(k)=rho(i,k,j) qv1(k)= qv(i,k,j) qc1(k)= qc(i,k,j) sqv(k)= qv(i,k,j)/(1.+qv(i,k,j)) sqc(k)= qc(i,k,j)/(1.+qc(i,k,j)) + dqc1(k)=0.0 + dqi1(k)=0.0 + dqni1(k)=0.0 + !dqnc1(k)=0.0 IF(PRESENT(qi) .AND. FLAG_QI)THEN qi1(k)= qi(i,k,j) sqi(k)= qi(i,k,j)/(1.+qi(i,k,j)) sqw(k)= sqv(k)+sqc(k)+sqi(k) - thl(k)= th(i,k,j) - xlvcp/exner(i,k,j)*sqc(k) & - & - xlscp/exner(i,k,j)*sqi(k) - !print*,"MYNN: Flag_qi=",FLAG_QI,qi(i,k,j) + !thl(k)= th(i,k,j) - xlvcp/exner(i,k,j)*sqc(k) & + ! & - xlscp/exner(i,k,j)*sqi(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) & + & - xlscp/MAX(tk1(k),TKmin)*sqi(k)) ELSE qi1(k)=0.0 sqi(k)=0.0 sqw(k)= sqv(k)+sqc(k) - thl(k)= th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) + !thl(k)= th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k) + !Use form from Tripoli and Cotton (1981) with their + !suggested min temperature to improve accuracy. + thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k)) ENDIF + IF (PRESENT(qni) .AND. FLAG_QNI ) THEN qni1(k)=qni(i,k,j) !print*,"MYNN: Flag_qni=",FLAG_QNI,qni(i,k,j) ELSE qni1(k)=0.0 ENDIF - !IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN - ! qnc1(k)=qnc(i,k,j) - ! !print*,"MYNN: Flag_qnc=",FLAG_QNC,qnc(i,k,j) - !ELSE - ! qnc1(k)=0.0 - !ENDIF + IF (PRESENT(qnc) .AND. FLAG_QNC ) THEN + qnc1(k)=qnc(i,k,j) + !print*,"MYNN: Flag_qnc=",FLAG_QNC,qnc(i,k,j) + ELSE + qnc1(k)=0.0 + ENDIF thetav(k)=th(i,k,j)*(1.+0.608*sqv(k)) p1(k) = p(i,k,j) ex1(k)= exner(i,k,j) @@ -2662,6 +3542,30 @@ SUBROUTINE mynn_bl_driver(& tsq1(k)=tsq(i,k,j) qsq1(k)=qsq(i,k,j) cov1(k)=cov(i,k,j) + !edmf + edmf_a1(k)=0.0 + edmf_qc1(k)=0.0 + s_aw1(k)=0. + s_awthl1(k)=0. + s_awqt1(k)=0. + s_awqv1(k)=0. + s_awqc1(k)=0. + s_awu1(k)=0. + s_awv1(k)=0. + s_awqke1(k)=0. + +#if (WRF_CHEM == 1) + ! WA 7/29/15 Set up chemical arrays + DO ic = 1,nchem + chem1(k,ic) = chem3d(i,k,j,ic) + s_awchem1(k,ic)=0. + ENDDO + DO ic = 1,ndvel + IF (k == KTS) THEN + vd1(ic) = vd3d(i,1,j,ic) + ENDIF + ENDDO +#endif IF (k==kts) THEN zw(k)=0. @@ -2670,11 +3574,32 @@ SUBROUTINE mynn_bl_driver(& ENDIF ENDDO - zw(kte+1)=zw(kte)+dz(i,kte,j) - + zw(kte+1)=zw(kte)+dz(i,kte,j) + !EDMF + s_aw1(kte+1)=0. + s_awthl1(kte+1)=0. + s_awqt1(kte+1)=0. + s_awqv1(kte+1)=0. + s_awqc1(kte+1)=0. + s_awu1(kte+1)=0. + s_awv1(kte+1)=0. + s_awqke1(kte+1)=0. +#if (WRF_CHEM == 1) + DO ic = 1,ndvel + s_awchem1(kte+1,ic)=0. + ENDDO +#endif + CALL GET_PBLH(KTS,KTE,PBLH(i,j),thetav,& & Qke1,zw,dz1,xland(i,j),KPBL(i,j)) - + + IF (scaleaware > 0.) THEN + CALL SCALE_AWARE(dx,PBLH(i,j),Psig_bl(i,j),Psig_shcu(i,j)) + ELSE + Psig_bl(i,j)=1.0 + Psig_shcu(i,j)=1.0 + ENDIF + sqcg= 0.0 !JOE, it was: qcg(i,j)/(1.+qcg(i,j)) cpm=cp*(1.+0.84*qv(i,kts,j)) exnerg=(ps(i,j)/p1000mb)**rcp @@ -2686,7 +3611,7 @@ SUBROUTINE mynn_bl_driver(& !flq = qfx(i,j)/ rho(i,kts,j) & ! -ch(i,j)*(sqc(kts) -sqcg ) !----------------------------------------------------- - ! Katata-added - The deposition velocity of cloud (fog) + ! Katata-added - The deposition velocity of cloud (fog) ! water is used instead of CH. flt = hfx(i,j)/( rho(i,kts,j)*cpm ) & & +xlvcp*vdfg(i,j)*(sqc(kts)/exner(i,kts,j)- sqcg/exnerg) @@ -2704,7 +3629,7 @@ SUBROUTINE mynn_bl_driver(& phh = 1.0/SQRT(1.0-cphh_unst*zet) end if -!!!!! estimate wstar & delta for GRIMS shallow-cu + !-- Estimate wstar & delta for GRIMS shallow-cu------- govrth = g/th1(kts) sflux = hfx(i,j)/rho(i,kts,j)/cpm + & qfx(i,j)/rho(i,kts,j)*ep_1*th1(kts) @@ -2715,52 +3640,211 @@ SUBROUTINE mynn_bl_driver(& wm2 = wm3**h2 delb = govrth*d3*pblh(i,j) delta(i,j) = min(d1*pblh(i,j) + d2*wm2/delb, 100.) -!!!!! end GRIMS + !-- End GRIMS----------------------------------------- + + IF (bl_mynn_edmf == 1) THEN + !PRINT*,"Calling StEM Mass-Flux: i= ",i," j=",j + CALL StEM_mf(kts,kte,delt,zw,p1, & + &bl_mynn_edmf_mom, & + &bl_mynn_edmf_tke, & + &u1,v1,w1,th1,thl,thetav,tk1, & + &sqw,sqv,sqc,qke1, & + &ust(i,j),flt,flq,flqv,flqc, & + &PBLH(i,j),DX,xland(i,j), & + ! now outputs - tendencies + ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & + ! outputs - updraft properties + & edmf_a1,edmf_w1,edmf_qt1, & + & edmf_thl1,edmf_ent1,edmf_qc1, & + ! for the solver + & s_aw1,s_awthl1,s_awqt1, & + & s_awqv1,s_awqc1,s_awu1,s_awv1, & + & s_awqke1, & + & qc_bl1D,cldfra_bl1D, & + & FLAG_QI,FLAG_QC, & + & Psig_shcu(i,j) & + ) + + ELSEIF (bl_mynn_edmf == 2) THEN + CALL temf_mf(kts,kte,delt,zw,p1,ex1, & + &u1,v1,w1,th1,thl,thetav, & + &sqw,sqv,sqc,qke1, & + &ust(i,j),flt,flq,flqv,flqc, & + &hfx(i,j),qfx(i,j),ts(i,j), & + &pblh(i,j),rho1,dfh,dx,znt(i,j),ep_2, & + ! outputs - updraft properties + & edmf_a1,edmf_w1,edmf_qt1, & + & edmf_thl1,edmf_ent1,edmf_qc1, & + ! for the solver + & s_aw1,s_awthl1,s_awqt1, & + & s_awqv1,s_awqc1, & + & s_awu1,s_awv1,s_awqke1, & +#if (WRF_CHEM == 1) + & nchem,chem1,s_awchem1, & +#endif + & qc_bl1D,cldfra_bl1D & + &,FLAG_QI,FLAG_QC & + &,Psig_shcu(i,j) & + ) + ENDIF - CALL mym_condensation ( kts,kte,& - &dz1,thl,sqw,p1,ex1, & - &tsq1, qsq1, cov1, & - &Sh,el,bl_mynn_cloudpdf, & !JOE-added for cloud PDF testing (from Kuwano-Yoshida et al. 2010) + + CALL mym_condensation ( kts,kte, & + &dx,dz1,thl,sqw,p1,ex1, & + &tsq1, qsq1, cov1, & + &Sh,el,bl_mynn_cloudpdf, & !JOE-cloud PDF testing (Kuwano-Yoshida et al. 2010) + &qc_bl1D,cldfra_bl1D, & !JOE-subgrid BL clouds + &PBLH(i,j),HFX(i,j), & !JOE-subgrid BL clouds + &edmf_qc1, & &Vt, Vq) CALL mym_turbulence ( kts,kte,levflag, & - &dz1, zw, u1, v1, thl, sqc, sqw, & - &qke1, tsq1, qsq1, cov1, & - &vt, vq,& - &rmol(i,j), flt, flq, & - &PBLH(i,j),th1,& !JOE-BouLac mod - &Sh,& !JOE-cloudPDF mod - &el,& - &Dfm,Dfh,Dfq, & - &Tcd,Qcd,Pdk, & - &Pdt,Pdq,Pdc & - &,qWT1,qSHEAR1,qBUOY1,qDISS1 & !JOE-TKE BUDGET - &,bl_mynn_tkebudget & !JOE-TKE BUDGET - &) - - CALL mym_predict (kts,kte,levflag, & - &delt, dz1, & - &ust(i,j), flt, flq, pmz, phh, & - &el, dfq, pdk, pdt, pdq, pdc, & - &Qke1, Tsq1, Qsq1, Cov1) - - CALL mynn_tendencies(kts,kte,& - &levflag,grav_settling,& - &delt, dz1,& - &u1, v1, th1, qv1, qc1, qi1, qni1,&! qnc1,& + &dz1, zw, u1, v1, thl, sqc, sqw, & + &qke1, tsq1, qsq1, cov1, & + &vt, vq, & + &rmol(i,j), flt, flq, & + &PBLH(i,j),th1, & + &Sh,el, & + &Dfm,Dfh,Dfq, & + &Tcd,Qcd,Pdk, & + &Pdt,Pdq,Pdc, & + &qWT1,qSHEAR1,qBUOY1,qDISS1, & + &bl_mynn_tkebudget, & + &Psig_bl(i,j),Psig_shcu(i,j), & + &cldfra_bl1D,bl_mynn_mixlength, & + &edmf_a1,edmf_qc1,bl_mynn_edmf) + +! IF (bl_mynn_edmf == 1) THEN +! !PRINT*,"Calling StEM Mass-Flux: i= ",i," j=",j +! CALL StEM_mf(kts,kte,delt,zw,p1, & +! &bl_mynn_edmf_mom, & +! &bl_mynn_edmf_tke, & +! &u1,v1,w1,th1,thl,thetav,tk1, & +! &sqw,sqv,sqc,qke1, & +! &ust(i,j),flt,flq,flqv,flqc, & +! &PBLH(i,j),DX,xland(i,j), & +! ! now outputs - tendencies +! ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & +! ! outputs - updraft properties +! & edmf_a1,edmf_w1,edmf_qt1, & +! & edmf_thl1,edmf_ent1,edmf_qc1, & +! ! for the solver +! & s_aw1,s_awthl1,s_awqt1, & +! & s_awqv1,s_awqc1,s_awu1,s_awv1, & +! & s_awqke1, & +! & qc_bl1D,cldfra_bl1D, & +! & FLAG_QI,FLAG_QC, & +! & Psig_shcu(i,j) & +! ) +! +! ELSEIF (bl_mynn_edmf == 2) THEN +! CALL temf_mf(kts,kte,delt,zw,p1,ex1, & +! &u1,v1,w1,th1,thl,thetav, & +! &sqw,sqv,sqc,qke1, & +! &ust(i,j),flt,flq,flqv,flqc, & +! &hfx(i,j),qfx(i,j),ts(i,j), & +! &pblh(i,j),rho1,dfh,dx,znt(i,j),ep_2, & +! ! outputs - updraft properties +! & edmf_a1,edmf_w1,edmf_qt1, & +! & edmf_thl1,edmf_ent1,edmf_qc1, & +! ! for the solver +! & s_aw1,s_awthl1,s_awqt1, & +! & s_awqv1,s_awqc1, & +! & s_awu1,s_awv1,s_awqke1, & +!#if (WRF_CHEM == 1) +! & nchem,chem1,s_awchem1, & +!#endif +! & qc_bl1D,cldfra_bl1D & +! &,FLAG_QI,FLAG_QC & +! &,Psig_shcu(i,j) & +! ) +! ENDIF + +! IF (bl_mynn_edmf > 0) THEN +! !DEBUG +! DO k=kts,kte +! IF (s_aw1(k)<0. .OR. s_aw1(k)>0.5) THEN +! PRINT*,"After Mass-Flux: i= ",i," j=",j," k=",k +! PRINT*," s_aw1=",s_aw1(k)," s_awthl1=",s_awthl1(k)," s_awqt1=",s_awqt1(k) +! PRINT*," s_awu1=",s_awu1(k)," s_awv1=",s_awu1(k) +! ENDIF +! ENDDO +! ENDIF + + IF (bl_mynn_edmf_part > 0 .AND. bl_mynn_edmf > 0) THEN + !Partition the fluxes from each component (ed & mf). + !Assume overlap of 50%: Reduce eddy diffusivities by 50% of the estimated + !area fraction of mass-flux scheme's updraft. + DO k=kts,kte + dfm(k)=dfm(k) * (1. - 0.5*edmf_a1(k)) + dfh(k)=dfh(k) * (1. - 0.5*edmf_a1(k)) + dfq(k)=dfq(k) * (1. - 0.5*edmf_a1(k)) + ENDDO + ENDIF + + CALL mym_predict (kts,kte,levflag, & + &delt, dz1, & + &ust(i,j), flt, flq, pmz, phh, & + &el, dfq, pdk, pdt, pdq, pdc, & + &Qke1, Tsq1, Qsq1, Cov1, & + &s_aw1, s_awqke1, bl_mynn_edmf_tke) + + CALL mynn_tendencies(kts,kte, & + &levflag,grav_settling, & + &delt, dz1, & + &u1, v1, th1, tk1, qv1, qc1, qi1, & + &qni1,qnc1, & &p1, ex1, thl, sqv, sqc, sqi, sqw,& - &ust(i,j),flt,flq,flqv,flqc,wspd(i,j),qcg(i,j),& - &uoce(i,j),voce(i,j),& - &tsq1, qsq1, cov1,& - &tcd, qcd, & - &dfm, dfh, dfq,& - &Du1, Dv1, Dth1, Dqv1, Dqc1, Dqi1, Dqni1& !, Dqnc1& - &,vdfg(i,j)& !JOE/Katata- fog deposition - &,FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC & - &) - - !print*,"MYNN: qi_ten, qni_ten=",Dqi1(4),Dqni1(4) - !print*,"MYNN: qc_ten, qnc_ten=",Dqc1(4),Dqnc1(4) + &ust(i,j),flt,flq,flqv,flqc, & + &wspd(i,j),qcg(i,j), & + &uoce(i,j),voce(i,j), & + &tsq1, qsq1, cov1, & + &tcd, qcd, & + &dfm, dfh, dfq, & + &Du1, Dv1, Dth1, Dqv1, & + &Dqc1, Dqi1, Dqni1, & !Dqnc1, & + &vdfg(i,j), & !JOE/Katata- fog deposition + ! mass flux components + &s_aw1,s_awthl1,s_awqt1, & + &s_awqv1,s_awqc1,s_awu1,s_awv1, & + &FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC,& + &cldfra_bl1d, & + &bl_mynn_cloudmix, & + &bl_mynn_mixqt, & + &bl_mynn_edmf, & + &bl_mynn_edmf_mom) + +#if (WRF_CHEM == 1) + CALL mynn_mix_chem(kts,kte, & + levflag,grav_settling, & + delt, dz1, & + nchem, kdvel, ndvel, num_vert_mix, & + chem1, vd1, & + qni1,qnc1, & + p1, ex1, thl, sqv, sqc, sqi, sqw,& + ust(i,j),flt,flq,flqv,flqc, & + wspd(i,j),qcg(i,j), & + uoce(i,j),voce(i,j), & + tsq1, qsq1, cov1, & + tcd, qcd, & + &dfm, dfh, dfq, & + ! mass flux components + & s_awchem1, & + &bl_mynn_cloudmix) +#endif + +! +! add mass flux tendencies and calculate the new variables. +! Now done implicitly in the mynn_tendencies subroutine +! do k=kts,kte +! du1(k)=du1(k)+du1mf(k) +! dv1(k)=dv1(k)+dv1mf(k) +! dth1(k)=dth1(k)+dth1mf(k) +! dqv1(k)=dqv1(k)+dqv1mf(k) +! that is supposed to be done by bl_fogdes +! dqc1(k)=dqc1(k)+dqc1mf(k) +! enddo + CALL retrieve_exchange_coeffs(kts,kte,& &dfm, dfh, dfq, dz1,& @@ -2768,23 +3852,36 @@ SUBROUTINE mynn_bl_driver(& !UPDATE 3D ARRAYS DO k=KTS,KTF - K_m(i,k,j)=K_m1(k) - K_h(i,k,j)=K_h1(k) + exch_m(i,k,j)=K_m1(k) + exch_h(i,k,j)=K_h1(k) K_q(i,k,j)=K_q1(k) - du(i,k,j)=du1(k) - dv(i,k,j)=dv1(k) - dth(i,k,j)=dth1(k) - dqv(i,k,j)=dqv1(k) - dqc(i,k,j)=dqc1(k) - IF (PRESENT(qi) .AND. FLAG_QI) dqi(i,k,j)=dqi1(k) - !IF (PRESENT(qnc) .AND. FLAG_QNC) dqnc(i,k,j)=dqnc1(k) - IF (PRESENT(qni) .AND. FLAG_QNI) dqni(i,k,j)=dqni1(k) + RUBLTEN(i,k,j)=du1(k) + RVBLTEN(i,k,j)=dv1(k) + RTHBLTEN(i,k,j)=dth1(k) + RQVBLTEN(i,k,j)=dqv1(k) + IF(bl_mynn_cloudmix > 0)THEN + IF (PRESENT(qc) .AND. FLAG_QC) RQCBLTEN(i,k,j)=dqc1(k) + IF (PRESENT(qi) .AND. FLAG_QI) RQIBLTEN(i,k,j)=dqi1(k) + !IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k,j)=dqnc1(k) + IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k,j)=dqni1(k) + ELSE + IF (PRESENT(qc) .AND. FLAG_QC) RQCBLTEN(i,k,j)=0. + IF (PRESENT(qi) .AND. FLAG_QI) RQIBLTEN(i,k,j)=0. + !IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k,j)=0. + IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k,j)=0. + ENDIF + IF(icloud_bl > 0)THEN + !make BL clouds scale aware - may already be done in mym_condensation + qc_bl(i,k,j)=qc_bl1D(k) !*Psig_shcu(i,j) + cldfra_bl(i,k,j)=cldfra_bl1D(k) !*Psig_shcu(i,j) + ENDIF el_pbl(i,k,j)=el(k) qke(i,k,j)=qke1(k) tsq(i,k,j)=tsq1(k) qsq(i,k,j)=qsq1(k) cov(i,k,j)=cov1(k) sh3d(i,k,j)=sh(k) + IF ( bl_mynn_tkebudget == 1) THEN dqke(i,k,j) = (qke1(k)-dqke(i,k,j))*0.5 !qke->tke qWT(i,k,j) = qWT1(k)*delt @@ -2792,32 +3889,56 @@ SUBROUTINE mynn_bl_driver(& qBUOY(i,k,j) = qBUOY1(k)*delt qDISS(i,k,j) = qDISS1(k)*delt ENDIF - !*** Begin debugging -! IF ( sh(k) < 0. .OR. sh(k)> 200. .OR. & -! & qke(i,k,j) < -5. .OR. qke(i,k,j)> 200. .OR. & -! & el_pbl(i,k,j) < 0. .OR. el_pbl(i,k,j)> 2000. .OR. & -! & ABS(vt(k)) > 0.8 .OR. ABS(vq(k)) > 1100. .OR. & -! & k_m(i,k,j) < 0. .OR. k_m(i,k,j)> 2000. .OR. & -! & vdfg(i,j) < 0. .OR. vdfg(i,j)>5. ) THEN -! PRINT*,"SUSPICIOUS VALUES AT: k=",k," sh=",sh(k) -! PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",k_m(i,k,j) -! PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) -! PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",tsq(i,k,j) -! PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) -! PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i,j) -! ENDIF - !*** End debugging + + !update updraft properties + IF (bl_mynn_edmf > 0) THEN + edmf_a(i,k,j)=edmf_a1(k) + edmf_w(i,k,j)=edmf_w1(k) + edmf_qt(i,k,j)=edmf_qt1(k) + edmf_thl(i,k,j)=edmf_thl1(k) + edmf_ent(i,k,j)=edmf_ent1(k) + edmf_qc(i,k,j)=edmf_qc1(k) + !Reapply checks on cldfra_bl and qc_bl to avoid FPEs in radiation driver + ! when these two quantities are multiplied by eachother (they may have changed + ! in the MF scheme: + IF (QC_BL(i,k,j) < 1E-6 .AND. ABS(CLDFRA_BL(i,k,j)) > 0.1)QC_BL(i,k,j)= 1E-6 + IF (CLDFRA_BL(i,k,j) < 1E-2)CLDFRA_BL(i,k,j)= 0. + ENDIF + + !*** Begin debug prints + IF ( wrf_at_debug_level(3000) ) THEN + IF ( sh(k) < 0. .OR. sh(k)> 200. .OR. & + & qke(i,k,j) < -1. .OR. qke(i,k,j)> 200. .OR. & + & el_pbl(i,k,j) < 0. .OR. el_pbl(i,k,j)> 2000. .OR. & + & ABS(vt(k)) > 0.8 .OR. ABS(vq(k)) > 3000. .OR. & + & exch_m(i,k,j) < 0. .OR. exch_m(i,k,j)> 2000. .OR. & + & vdfg(i,j) < 0. .OR. vdfg(i,j)>5. .OR. & + & ABS(HFX(i,j))>1000. .OR. ABS(QFX(i,j))>.001) THEN + PRINT*,"**SUSPICIOUS VALUES AT: k=",k," sh=",sh(k) + PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k,j) + PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j) + PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",tsq(i,k,j) + PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j) + PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i,j) + PRINT*," hfx=",HFX(i,j)," qfx=",QFX(i,j) + ENDIF + IF (icloud_bl > 0) then + IF( cldfra_bl(i,k,j) < 0.0 .OR. cldfra_bl(i,k,j)> 1.)THEN + PRINT*,"CLDFRA_BL=",cldfra_bl(i,k,j)," qc_bl=",QC_BL(i,k,j) + ENDIF + ENDIF + ENDIF + !*** End debug prints ENDDO -!JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.) -! TKE_PBL is defined on interfaces, while QKE is at middle of layer. + + !JOE-add tke_pbl for coupling w/shallow-cu schemes (TKE_PBL = QKE/2.) + ! TKE_PBL is defined on interfaces, while QKE is at middle of layer. tke_pbl(i,kts,j) = 0.5*MAX(qke(i,kts,j),1.0e-10) DO k = kts+1,kte afk = dz1(k)/( dz1(k)+dz1(k-1) ) abk = 1.0 -afk tke_pbl(i,k,j) = 0.5*MAX(qke(i,k,j)*abk+qke(i,k-1,j)*afk,1.0e-3) ENDDO -!JOE-end tke_pbl -!JOE-end addition !*** Begin debugging ! IF(I==IMD .AND. J==JMD)THEN @@ -2843,10 +3964,11 @@ SUBROUTINE mynn_bl_driver(& END SUBROUTINE mynn_bl_driver ! ================================================================== - SUBROUTINE mynn_bl_init_driver(& - &Du,Dv,Dth,Dqv,Dqc,Dqi & - !&,Dqnc,Dqni & + SUBROUTINE mynn_bl_init_driver( & + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + &RQCBLTEN,RQIBLTEN & !,RQNIBLTEN,RQNCBLTEN & &,QKE,TKE_PBL,EXCH_H & +! &,icloud_bl,qc_bl,cldfra_bl & !JOE-subgrid bl clouds &,RESTART,ALLOWED_TO_READ,LEVEL & &,IDS,IDE,JDS,JDE,KDS,KDE & &,IMS,IME,JMS,JME,KMS,KME & @@ -2854,7 +3976,7 @@ SUBROUTINE mynn_bl_init_driver(& !--------------------------------------------------------------- LOGICAL,INTENT(IN) :: ALLOWED_TO_READ,RESTART - INTEGER,INTENT(IN) :: LEVEL + INTEGER,INTENT(IN) :: LEVEL !,icloud_bl INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE, & & IMS,IME,JMS,JME,KMS,KME, & @@ -2862,9 +3984,13 @@ SUBROUTINE mynn_bl_init_driver(& REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & - &Du,Dv,Dth,Dqv,Dqc,Dqi, & !Dqnc,Dqni, + &RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & + &RQCBLTEN,RQIBLTEN,& !RQNIBLTEN,RQNCBLTEN & &QKE,TKE_PBL,EXCH_H +! REAL,DIMENSION(IMS:IME,KMS:KME,JMS:JME),INTENT(INOUT) :: & +! &qc_bl,cldfra_bl + INTEGER :: I,J,K,ITF,JTF,KTF JTF=MIN0(JTE,JDE-1) @@ -2875,17 +4001,19 @@ SUBROUTINE mynn_bl_init_driver(& DO J=JTS,JTF DO K=KTS,KTF DO I=ITS,ITF - Du(i,k,j)=0. - Dv(i,k,j)=0. - Dth(i,k,j)=0. - Dqv(i,k,j)=0. - if( p_qc >= param_first_scalar ) Dqc(i,k,j)=0. - if( p_qi >= param_first_scalar ) Dqi(i,k,j)=0. - !if( p_qnc >= param_first_scalar ) Dqnc(i,k,j)=0. - !if( p_qni >= param_first_scalar ) Dqni(i,k,j)=0. - QKE(i,k,j)=0. + RUBLTEN(i,k,j)=0. + RVBLTEN(i,k,j)=0. + RTHBLTEN(i,k,j)=0. + RQVBLTEN(i,k,j)=0. + if( p_qc >= param_first_scalar ) RQCBLTEN(i,k,j)=0. + if( p_qi >= param_first_scalar ) RQIBLTEN(i,k,j)=0. + !if( p_qnc >= param_first_scalar ) RQNCBLTEN(i,k,j)=0. + !if( p_qni >= param_first_scalar ) RQNIBLTEN(i,k,j)=0. + !QKE(i,k,j)=0. TKE_PBL(i,k,j)=0. EXCH_H(i,k,j)=0. +! if(icloud_bl > 0) qc_bl(i,k,j)=0. +! if(icloud_bl > 0) cldfra_bl(i,k,j)=0. ENDDO ENDDO ENDDO @@ -2924,14 +4052,14 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) !LOCAL VARS REAL :: PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv REAL :: delt_thv !delta theta-v; dependent on land/sea point - REAL, PARAMETER :: sbl_lim = 200. !typical scale of stable BL (m). - REAL, PARAMETER :: sbl_damp = 400. !transition length for blending (m). + REAL, PARAMETER :: sbl_lim = 400. !200. !upper limit of stable BL height (m). + REAL, PARAMETER :: sbl_damp = 800.!400. !transition length for blending (m). INTEGER :: I,J,K,kthv,ktke,kzi,kzi2 !ADD KPBL (kzi) for coupling to some Cu schemes, initialize at k=2 !kzi2 is the TKE-based part of the hybrid KPBL - kzi = 1 - kzi2= 1 + kzi = 2 + kzi2= 2 !FIND MAX TKE AND MIN THETAV IN THE LOWEST 500 M k = kts+1 @@ -2939,7 +4067,7 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) ktke = 1 maxqke = 0. minthv = 9.E9 - DO WHILE (zw1D(k) .LE. 500.) + DO WHILE (zw1D(k) .LE. sbl_lim) qtke =MAX(Qke1D(k),0.) ! maximum QKE IF (maxqke < qtke) then maxqke = qtke @@ -2951,18 +4079,20 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) ENDIF k = k+1 ENDDO + + !Use 5% of tke max (Kosovic and Curry, 2000; JAS) !TKEeps = maxtke/20. = maxqke/40. - TKEeps = maxqke/40. - TKEeps = MAX(TKEeps,0.025) + TKEeps = maxqke/40. + TKEeps = MAX(TKEeps,0.02) !0.010) !0.025) !FIND THETAV-BASED PBLH (BEST FOR DAYTIME). zi=0. k = kthv+1 - IF((landsea-1.5).GE.0)THEN + IF((landsea-1.5).GE.0)THEN ! WATER delt_thv = 0.75 - ELSE - ! LAND + ELSE + ! LAND delt_thv = 1.25 ENDIF @@ -3005,21 +4135,1919 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi) !With TKE advection turned on, the TKE-based PBLH can be very large !in grid points with convective precipitation (> 8 km!), - !so an artificial limit is imposed to not let PBLH_TKE exceed 4km. + !so an artificial limit is imposed to not let PBLH_TKE xceed 4km. !This has no impact on 98-99% of the domain, but is the simplest patch !that adequately addresses these extremely large PBLHs. !PBLH_TKE = MIN(PBLH_TKE,4000.) PBLH_TKE = MIN(PBLH_TKE,zi+500.) + PBLH_TKE = MAX(PBLH_TKE,MAX(zi-500.,10.)) - !BLEND THE TWO PBLH TYPES HERE: wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5 - zi=PBLH_TKE*(1.-wt) + zi*wt + IF (maxqke <= 0.05) THEN + !Cold pool situation - default to theta_v-based def + ELSE + !BLEND THE TWO PBLH TYPES HERE: + zi=PBLH_TKE*(1.-wt) + zi*wt + ENDIF !ADD KPBL (kzi) for coupling to some Cu schemes - kzi = INT(kzi2*(1.-wt) + kzi*wt) + kzi = MAX(INT(kzi2*(1.-wt) + kzi*wt),1) END SUBROUTINE GET_PBLH ! ================================================================== +! Much thanks to Kay Suslj of NASA-JPL for contributing the original version +! of this mass-flux scheme. Considerable changes have been made from it's +! original form. Some additions include: +! 1) scale-aware tapering as dx -> 0 +! 2) transport of TKE (extra namelist option) +! 3) Chaboureau-Bechtold cloud fraction & coupling to radiation (when icloud_bl > 0) +! 4) some extra limits for numerical stability +! This scheme remains under development, so consider it experimental code. +! + SUBROUTINE StEM_mf(kts,kte,dt,zw,p, & + & momentum_opt, & + & tke_opt, & + & u,v,w,th,thl,thv,tk, & + & qt,qv,qc,qke, & + & ust,flt,flq,flqv,flqc, & + & pblh,DX,landsea, & + ! outputs - tendencies + ! &dth,dqv,dqc,du,dv,& + ! outputs - updraft properties + & edmf_a,edmf_w, & + & edmf_qt,edmf_thl, & + & edmf_ent,edmf_qc, & + ! outputs - variables needed for solver + & s_aw,s_awthl,s_awqt, & + & s_awqv,s_awqc, & + & s_awu,s_awv,s_awqke, & + ! in/outputs - subgrid scale clouds + & qc_bl1d,cldfra_bl1d, & + ! inputs - flags for moist arrays + &F_QC,F_QI, & + &Psig_shcu) + + ! inputs: + INTEGER, INTENT(IN) :: KTS,KTE,momentum_opt,tke_opt + REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,THV,P,qke + REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW !height at full-sigma + REAL, INTENT(IN) :: DT,UST,FLT,FLQ,FLQV,FLQC,PBLH,DX,Psig_shcu,landsea + LOGICAL, OPTIONAL :: F_QC,F_QI + + ! outputs - tendencies + ! REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: DTH,DQV,DQC,DU,DV + ! outputs - updraft properties + REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w, & + & edmf_qt,edmf_thl, edmf_ent,edmf_qc + + ! outputs - variables needed for solver + REAL,DIMENSION(KTS:KTE+1) :: s_aw, & !sum ai*wis_awphi + s_awthl, & !sum ai*wi*phii + s_awqt, & + s_awqv, & + s_awqc, & + s_awu, & + s_awv, & + s_awqke + + REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d + + INTEGER, PARAMETER :: NUP=10 + ! local variables + ! updraft properties + REAL,DIMENSION(KTS:KTE+1,1:NUP) :: UPW,UPTHL,UPQT,UPQC,UPQV, & + UPA,UPU,UPV,UPTHV,UPQKE + ! entrainment variables + REAL,DIMENSION(KTS:KTE,1:NUP) :: ENT,ENTf + INTEGER,DIMENSION(KTS:KTE,1:NUP) :: ENTi + ! internal variables + INTEGER :: K,I,k50 + REAL :: fltv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0, & + pwmin,pwmax,wmin,wmax,wlv,wtv,Psig_w,maxw + REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,EntEXP,EntW + + ! w parameters + REAL,PARAMETER :: & + &Wa=2./3., & + &Wb=0.002,& + &Wc=1.5 + + ! Lateral entrainment parameters ( L0=100 and ENT0=0.1) were taken from + ! Suselj et al (2013, jas). Note that Suselj et al (2014,waf) use L0=200 and ENT0=0.2. + REAL,PARAMETER :: & + & L0=100.,& + & ENT0=0.1 + + !JOE: add declaration of ERF + REAL :: ERF + + !JOE: add option to switch cloud fraction calculations: + INTEGER, PARAMETER :: cldfra_opt = 0 ! 0: Chaboureau and Bechtold (2005, JGR) + ! 1: Xu & Randall (1994) + !JOE:add for cldfra + REAL :: xcldfra, UMF_new, dcf, ktop_dcf, kbcon_dcf + ! PARAMETERS FOR RANDALL AND XU (1996) CLOUD FRACTION + REAL, PARAMETER :: coef_p = 0.25, coef_gamm = 0.49, coef_alph = 100. + REAL :: satvp,rhgrid,h2oliq + LOGICAL :: superadiabatic + + ! VARIABLES FOR CHABOUREAU-BECHTOLD + REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,diffqt + + ! WA TEST 11/9/15 for consistent reduction of updraft params + REAL :: csigma,flt2,flq2,fltv2 + +! check the inputs +! print *,'dt',dt +! print *,'dz',dz +! print *,'u',u +! print *,'v',v +! print *,'thl',thl +! print *,'qt',qt +! print *,'ust',ust +! print *,'flt',flt +! print *,'flq',flq +! print *,'pblh',pblh + + UPW=0. + UPTHL=0. + UPTHV=0. + UPQT=0. + UPA=0. + UPU=0. + UPV=0. + UPQC=0. + UPQV=0. + UPQKE=0. + ENT=0. + + !taper off MF scheme when significant resolved-scale motions are present + !This function needs to be asymetric... + k = 1 + maxw = 0.0 + DO WHILE (ZW(k) < pblh + 500.) + maxw = MAX(maxw,ABS(W(k))) + !JOE-find highest k-level below 50m AGL + IF(ZW(k)<=50.)k50=k + k = k+1 + ENDDO + !print*," maxw before manipulation=", maxw + maxw = MAX(0.,maxw - 0.5) ! do nothing for small w, but + Psig_w = MAX(0.0, 1.0 - maxw/0.5) ! linearly taper off for w > 0.5 m/s + Psig_w = MIN(Psig_w, Psig_shcu) + !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu + + flt2 = flt !*0.0 !reserve some for ED or set to zero to remove excess + flq2 = flq !*0.0 !reserve some for ED or set to zero to remove excess + fltv = flt + svp1*flq + fltv2 = flt2 + svp1*flq2 + !PRINT*," fltv=",fltv," zi=",pblh + + !Completely shut off MF scheme for strong resolved-scale vertical velocities. + IF(Psig_w == 0.0 .and. fltv > 0.0) fltv = -1.*fltv + +! if surface buoyancy is positive we do integration otherwise not, and make sure that +! PBLH > twice the height of the surface layer (set at z0 = 50m) +! Also, ensure that it is at least slightly superadiabatic up through 50 m + superadiabatic = .false. + DO k=1,MAX(1,k50-1) + IF (th(k+1)-th(k) < 0.) THEN + superadiabatic = .true. + ELSE + superadiabatic = .false. + exit + ENDIF + ENDDO + + IF ( fltv > 0.002 .AND. PBLH > 100. .AND. superadiabatic) then + !PRINT*," Conditions met to run mass-flux scheme",fltv,pblh + ! get entrainment coefficient + ! get dz/L0 + ENTf(kts:kte,1:Nup)=0.1 + ENTi(kts:kte,1:Nup)=0.1 + do i=1,Nup + do k=kts+1,kte + ENTf(k,i)=(ZW(k)-ZW(k-1))/L0 ! input into Poisson + ENTf(k,i)=MIN(ENTf(k,i),9.9) !JOE: test avoiding FPE + ENTf(k,i)=MAX(ENTf(k,i),0.05) !JOE: test avoiding FPE + enddo + enddo + ! get Poisson P(dz/L0) + call Poisson(1,Nup,kts+1,kte,ENTf,ENTi) + ! entrainent: Ent=Ent0/dz*P(dz/L0) + do i=1,Nup + do k=kts+1,kte + ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k)-ZW(k-1)) !eq (13) in Suselj et al. (2013, jas) + ! WA TEST 11/12/15 Add some small deterministic background entrainment + ENT(k,i) = max(ENT(k,i),0.0002) + ! JOE - increase updraft entrainment near surface + ENT(k,i) = max(ENT(k,i),0.3/ZW(k)) + enddo + enddo + +! print *,'Entrainment:',ENT + + ! set initial conditions for updrafts + z0=50. + pwmin=0.5 + pwmax=2.0 !1.5 ! was 3.0 + + wstar=max(1.E-2,(g/thv(1)*fltv*pblh)**(1./3.)) + qstar=flq2/wstar + thstar=flt2/wstar + + IF((landsea-1.5).GE.0)THEN + csigma = 0.0 ! WATER + ELSE + csigma = 1.34 ! LAND + ENDIF + sigmaW =1.34*wstar*(z0/pblh)**(1./3.)*(1 - 0.8*z0/pblh) + sigmaQT=csigma*qstar*(z0/pblh)**(-1./3.) + sigmaTH=csigma*thstar*(z0/pblh)**(-1./3.) + + wmin=sigmaW*pwmin + wmax=sigmaW*pwmax + + !SPECIFY SURFACE UPDRAFT PROPERTIES + DO I=1,NUP + wlv=wmin+(wmax-wmin)/NUP*(i-1) + wtv=wmin+(wmax-wmin)/NUP*i + + !SURFACE UPDRAFT VERTICAL VELOCITY + UPW(1,I)=0.5*(wlv+wtv) + !IF (UPW(1,I) > 0.5*ZW(2)/dt) UPW(1,I) = 0.5*ZW(2)/dt + + !SURFACE UPDRAFT AREA + !UPA(1,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.5*ERF(wlv/(sqrt(2.)*sigmaW)) + !UPA(1,I)=0.4*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.4*ERF(wlv/(sqrt(2.)*sigmaW)) !19.6 + !UPA(1,I)=0.3*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.3*ERF(wlv/(sqrt(2.)*sigmaW)) !14.6 + !UPA(1,I)=0.25*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.25*ERF(wlv/(sqrt(2.)*sigmaW)) !12.0 + UPA(1,I)=0.2*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.2*ERF(wlv/(sqrt(2.)*sigmaW)) !9.6 + + UPU(1,I)=U(1) + UPV(1,I)=V(1) + UPQC(1,I)=0 + !UPQT(1,I) =QT(1) +0.58*UPW(1,I)*sigmaQT/sigmaW + !UPTHV(1,I)=THV(1)+0.58*UPW(1,I)*sigmaTH/sigmaW + !Alternatively, initialize parcel over lowest 50m + UPQT(1,I) = 0. + UPTHL(1,I)= 0. + k50=1 !for now, keep at lowest model layer... + DO k=1,k50 + UPQT(1,I) = UPQT(1,I) +QT(k) +0.58*UPW(1,I)*sigmaQT/sigmaW !*EXP(-ZW(k)/100.) + UPTHV(1,I)= UPTHV(1,I)+THV(k)+0.58*UPW(1,I)*sigmaTH/sigmaW !*EXP(-ZW(k)/100.) + !UPQT(1,I) = UPQT(1,I) +QT(k) +1.*UPW(1,I)*sigmaQT/sigmaW + !UPTHV(1,I)= UPTHV(1,I)+THV(k)+1.*UPW(1,I)*sigmaTH/sigmaW + ENDDO + UPQT(1,I) = UPQT(1,I)/REAL(k50) + UPTHV(1,I)= UPTHV(1,I)/REAL(k50) + UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I)) + UPQKE(1,I)= QKE(1) + +! !DEBUG +! IF (UPA(1,I)<0. .OR. UPA(1,I)>0.5 .OR. wstar<0. .OR. wstar>4.0 .OR. & +! ABS(thstar)> 5. .OR. sigmaW>1.5) THEN +! PRINT*,"IN Mass-Flux: UPA(1,i)=",UPA(1,i) +! PRINT*," wstar=",wstar," qstar=",qstar +! PRINT*," thstar=",thstar," sigmaW=",sigmaW +! ENDIF + ENDDO + + !QCn = 0. + ! do integration updraft + DO I=1,NUP + QCn = 0. + DO k=KTS+1,KTE + + !JOE - increase background entrainment within clouds + !if(QCn > 1.e-8)ENT(k,i) = max(ENT(k,i),0.0004) + !JOE - use constant ent in dry plumes in the PBL + IF(QCn < 1.e-8 .AND. ZW(k) < pblh) ENT(k,i) = max(0.0009,0.3/ZW(k)) + + EntExp=exp(-ENT(K,I)*(ZW(k)-ZW(k-1))) + + QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp + THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp + Un =U(K) *(1-EntExp)+UPU(K-1,I)*EntExp + Vn =V(K) *(1-EntExp)+UPV(K-1,I)*EntExp + QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp + + ! get thvn,qcn + call condensation_edmf(QTn,THLn,(P(K)+P(K-1))/2.,ZW(k),THVn,QCn) + + B=g*(0.5*(THVn+UPTHV(k-1,I))/THV(k-1) - 1.0) + + EntW=exp(-2.*(Wb+Wc*ENT(K,I))*(ZW(k)-ZW(k-1))) + Wn2=UPW(K-1,I)**2*EntW + (1.-EntW)*0.5*Wa*B/(Wb+Wc*ENT(K,I)) + + Wn2=Wn2*EXP(-MAX(ZW(k)-(pblh+3000.),0.0)/1000.) + IF(ZW(k) >= pblh+4000.)Wn2=0. + + IF (Wn2 > 0.) THEN + UPW(K,I)=sqrt(Wn2) + !IF (UPW(K,I) > 0.5*(ZW(K)-ZW(K-1))/dt) UPW(K,I) = 0.5*(ZW(K)-ZW(K-1))/dt + UPTHV(K,I)=THVn + UPTHL(K,I)=THLn + UPQT(K,I)=QTn + UPQC(K,I)=QCn + UPU(K,I)=Un + UPV(K,I)=Vn + UPQKE(K,I)=QKEn + UPA(K,I)=UPA(K-1,I) + ELSE + exit + END IF + ENDDO + ENDDO + + END IF +! +! get updraft properties, for saving +! + edmf_a =0. + edmf_w =0. + edmf_qt =0. + edmf_thl=0. + edmf_ent=0. + edmf_qc =0. + + ! writing updraft properties in their variable + ! all variables, except Areas are now multipled by the area + ! to confirm with WRF grid setup we do not save the first and the last row + + DO k=KTS,KTE-1 + DO I=1,NUP + edmf_a(K)=edmf_a(K)+UPA(K+1,I) + edmf_w(K)=edmf_w(K)+UPA(K+1,I)*UPW(K+1,I) + edmf_qt(K)=edmf_qt(K)+UPA(K+1,I)*UPQT(K+1,I) + edmf_thl(K)=edmf_thl(K)+UPA(K+1,I)*UPTHL(K+1,I) + edmf_ent(K)=edmf_ent(K)+UPA(K+1,I)*ENT(K+1,I) + edmf_qc(K)=edmf_qc(K)+UPA(K+1,I)*UPQC(K+1,I) + ENDDO + + IF (edmf_a(k)>0.) THEN + edmf_w(k)=edmf_w(k)/edmf_a(k)*Psig_w + edmf_qt(k)=edmf_qt(k)/edmf_a(k)*Psig_w + edmf_thl(k)=edmf_thl(k)/edmf_a(k)*Psig_w + edmf_ent(k)=edmf_ent(k)/edmf_a(k)*Psig_w + edmf_qc(k)=edmf_qc(k)/edmf_a(k)*Psig_w + ENDIF + ENDDO + + ! + ! computing variables needed for implicit solver + ! + s_aw=0. + s_awthl=0. + s_awqt=0. + s_awqv=0. + s_awqc=0. + s_awu=0. + s_awv=0. + s_awqke=0. + + DO k=KTS,KTE+1 + DO I=1,NUP + s_aw(k) = s_aw(K) + UPA(K,I)*UPW(K,I)*Psig_w + s_awthl(k)= s_awthl(K) + UPA(K,i)*UPW(K,I)*UPTHL(K,I)*Psig_w + s_awqt(k) = s_awqt(K) + UPA(K,i)*UPW(K,I)*UPQT(K,I)*Psig_w + s_awqc(k) = s_awqc(K) + UPA(K,i)*UPW(K,I)*UPQC(K,I)*Psig_w + IF (momentum_opt > 0) THEN + s_awu(k) = s_awu(K) + UPA(K,i)*UPW(K,I)*UPU(K,I)*Psig_w + s_awv(k) = s_awv(K) + UPA(K,i)*UPW(K,I)*UPV(K,I)*Psig_w + ENDIF + IF (tke_opt > 0) THEN + s_awqke(k)= s_awqke(K) + UPA(K,i)*UPW(K,I)*UPQKE(K,I)*Psig_w + ENDIF + ENDDO + s_awqv(k) = s_awqt(k) - s_awqc(k) + ENDDO + +!JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined above. +! Here, a shallow-cu component is added (or max is used). + DO K=KTS,KTE +! qc_bl1d(k)=0. +! cldfra_bl1d(k)=0. + + IF (cldfra_opt == 0) THEN + IF(edmf_qc(k)>0.0)THEN + !Chaboureau and Bechtold (2005, JGR) + diffqt=edmf_qt(k)-qt(k) + if(ABS(diffqt) < 1.0E-6)diffqt = 1.0E-6 + !sigq = MAX(edmf_a(k)*(1.-edmf_a(k))*diffqt**2 , 1.0e-8) + sigq = MAX(edmf_a(k)*diffqt**2 , 1.0e-8) + sigq = sqrt(sigq) + + xl = xl_blend(tk(k)) ! obtain blended heat capacity + tlk = thl(k)*(p(k)/p1000mb)**rcp ! recover liquid temp (tl) from thl + qsat_tl = qsat_blend(tlk,p(k)) ! get saturation water vapor mixing ratio + ! at tl and p + rsl = xl*qsat_tl / (r_v*tlk**2) ! slope of C-C curve at t = tl + ! CB02, Eqn. 4 + cpm = cp + qt(k)*cpv ! CB02, sec. 2, para. 1 + a = 1./(1. + xl*rsl/cpm) ! CB02 variable "a" + qmq = a * (qt(k) - qsat_tl) ! saturation deficit/excess; + ! the numerator of Q1 + mf_cf = min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),1.0) + !IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + ! print*,"In MYNN, StEM edmf" + ! print*," CB: qt=",qt(k)," qsat=",qsat_tl," satdef=",qt(k) - qsat_tl + ! print*," CB: sigq=",sigq," qmq=",qmq," tlk=",tlk + ! print*," CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k) + !ENDIF + IF (mf_cf > edmf_a(k)) THEN + cldfra_bl1d(k) = mf_cf + qc_bl1d(k) = edmf_qc(k)*edmf_a(k)/mf_cf + ELSE + cldfra_bl1d(k)=edmf_a(k) !MAX(mf_cf,edmf_a(k)) + qc_bl1d(k) = edmf_qc(k) !MAX(qc_bl1d(k), edmf_qc(k)) + ENDIF + ENDIF + ELSEIF(cldfra_opt == 1) THEN + !Randall and Xu + qc_bl1d(k) = MAX(qc_bl1d(k), edmf_qc(k)) + if(F_qc .and. .not. F_qi)then + satvp = 3.80*exp(17.27*(th(k)-273.)/ & + (th(k)-36.))/(.01*p(k)) + rhgrid = max(.1,MIN( .95, qv(k) /satvp)) + h2oliq=1000.*qc_bl1d(k) + satvp=1000.*satvp + cldfra_bl1d(k)=(1.-exp(-coef_alph*h2oliq/& + ((1.-rhgrid)*satvp)**coef_gamm))*(rhgrid**coef_p) + cldfra_bl1d(k)=max(0.0,MIN(1.,cldfra_bl1d(k))) + elseif(F_qc .and. F_qi)then + satvp = 3.80*exp(17.27*(th(k)-273.)/ & + (th(k)-36.))/(.01*p(k)) + rhgrid = max(.1,MIN( .95, qv(k) /satvp)) + h2oliq=1000.*qc_bl1d(k) + satvp=1000.*satvp + cldfra_bl1d(k)=(1.-exp(-coef_alph*h2oliq/& + ((1.-rhgrid)*satvp)**coef_gamm))*(rhgrid**coef_p) + cldfra_bl1d(k)=max(0.0,MIN(1.,cldfra_bl1d(k))) + endif + ENDIF + ENDDO + + +! +! debugging +! +IF (edmf_w(1) > 4.0) THEN +! surface values + print *,'flq:',flq,' fltv:',fltv + print *,'pblh:',pblh,' wstar:',wstar + print *,'sigmaW=',sigmaW,' sigmaTH=',sigmaTH,' sigmaQT=',sigmaQT +! means +! print *,'u:',u +! print *,'v:',v +! print *,'thl:',thl +! print *,'thv:',thv +! print *,'qt:',qt +! print *,'p:',p + +! updrafts +! DO I=1,NUP +! print *,'up:A',i +! print *,UPA(:,i) +! print *,'up:W',i +! print*,UPW(:,i) +! print *,'up:thv',i +! print *,UPTHV(:,i) +! print *,'up:thl',i +! print *,UPTHL(:,i) +! print *,'up:qt',i +! print *,UPQT(:,i) +! print *,'up:tQC',i +! print *,UPQC(:,i) +! print *,'up:ent',i +! print *,ENT(:,i) +! ENDDO + +! mean updrafts + print *,' edmf_a',edmf_a(1:14) + print *,' edmf_w',edmf_w(1:14) + print *,' edmf_qt:',edmf_qt(1:14) + print *,' edmf_thl:',edmf_thl(1:14) + +ENDIF !END Debugging + +! initialization of deltas +! DO k=kts,kte +! dth(k)=0. +! dqv(k)=0. +! dqc(k)=0. +! du(k)=0. +! dv(k)=0. +! ENDDO + +END SUBROUTINE StEM_MF +!================================================================= +subroutine Poisson(istart,iend,jstart,jend,mu,POI) + + integer, intent(in) :: istart,iend,jstart,jend + real,dimension(istart:iend,jstart:jend),intent(in) :: MU + integer, dimension(istart:iend,jstart:jend), intent(out) :: POI + integer :: i,j + ! + ! do this only once + ! call init_random_seed + + do i=istart,iend + do j=jstart,jend + call random_Poisson(mu(i,j),.true.,POI(i,j)) + enddo + enddo + +end subroutine Poisson +!================================================================= +subroutine init_random_seed() + !JOE: PGI had problem! use iso_fortran_env, only: int64 + !JOE: PGI had problem! use ifport, only: getpid + implicit none + integer, allocatable :: seed(:) + integer :: i, n, un, istat, dt(8), pid + !JOE: PGI had problem! integer(int64) :: t + integer :: t + + call random_seed(size = n) + allocate(seed(n)) + + ! First try if the OS provides a random number generator + !JOE: PGI had problem! open(newunit=un, file="/dev/urandom", access="stream", & + un=191 + open(unit=un, file="/dev/urandom", access="stream", & + form="unformatted", action="read", status="old", iostat=istat) + + if (istat == 0) then + read(un) seed + close(un) + else + ! Fallback to XOR:ing the current time and pid. The PID is + ! useful in case one launches multiple instances of the same + ! program in parallel. + call system_clock(t) + if (t == 0) then + call date_and_time(values=dt) + !t = (dt(1) - 1970) * 365_int64 * 24 * 60 * 60 * 1000 & + ! + dt(2) * 31_int64 * 24 * 60 * 60 * 1000 & + ! + dt(3) * 24_int64 * 60 * 60 * 1000 & + ! + dt(5) * 60 * 60 * 1000 & + ! + dt(6) * 60 * 1000 + dt(7) * 1000 & + ! + dt(8) + t = dt(6) * 60 & ! only return seconds for smaller t + + dt(7) + end if + + !JOE: PGI had problem!pid = getpid() + ! for distributed memory jobs we need to fix this + !pid=1 + pid = 666 + MOD(t,10) !JOE: doesn't work for PG compilers: getpid() + + t = ieor(t, int(pid, kind(t))) + do i = 1, n + seed(i) = lcg(t) + end do + end if + call random_seed(put=seed) + + contains + + ! Pseudo-random number generator (PRNG) + ! This simple PRNG might not be good enough for real work, but is + ! sufficient for seeding a better PRNG. + function lcg(s) + + integer :: lcg + !JOE: PGI had problem! integer(int64) :: s + integer :: s + + if (s == 0) then + !s = 104729 + s = 1047 + else + !s = mod(s, 4294967296_int64) + s = mod(s, 71) + end if + !s = mod(s * 279470273_int64, 4294967291_int64) + s = mod(s * 23, 17) + !lcg = int(mod(s, int(huge(0), int64)), kind(0)) + lcg = int(mod(s, int(s/3.5))) + + end function lcg + + end subroutine init_random_seed + + +subroutine random_Poisson(mu,first,ival) +!********************************************************************** +! Translated to Fortran 90 by Alan Miller from: RANLIB +! +! Library of Fortran Routines for Random Number Generation +! +! Compiled and Written by: +! +! Barry W. Brown +! James Lovato +! +! Department of Biomathematics, Box 237 +! The University of Texas, M.D. Anderson Cancer Center +! 1515 Holcombe Boulevard +! Houston, TX 77030 +! +! Generates a single random deviate from a Poisson distribution with mean mu. +! Scalar Arguments: + REAL, INTENT(IN) :: mu !The mean of the Poisson distribution from which + !a random deviate is to be generated. + LOGICAL, INTENT(IN) :: first + INTEGER :: ival + +! TABLES: COEFFICIENTS A0-A7 FOR STEP F. FACTORIALS FACT +! COEFFICIENTS A(K) - FOR PX = FK*V*V*SUM(A(K)*V**K)-DEL +! SEPARATION OF CASES A AND B +! +! .. Local Scalars .. +!JOE: since many of these scalars conflict with globally declared closure constants (above), +! need to change XX to XX_s +! REAL :: b1, b2, c, c0, c1, c2, c3, del, difmuk, e, fk, fx, fy, g, & +! omega, px, py, t, u, v, x, xx + REAL :: b1_s, b2_s, c, c0, c1_s, c2_s, c3_s, del, difmuk, e, fk, fx, fy, g_s, & + omega, px, py, t, u, v, x, xx + REAL, SAVE :: s, d, p, q, p0 + INTEGER :: j, k, kflag + LOGICAL, SAVE :: full_init + INTEGER, SAVE :: l, m +! .. +! .. Local Arrays .. + REAL, SAVE :: pp(35) +! .. +! .. Data statements .. +!JOE: since many of these scalars conflict with globally declared closure constants (above), +! need to change XX to XX_s +! REAL, PARAMETER :: a0 = -.5, a1 = .3333333, a2 = -.2500068, a3 = .2000118, & + REAL, PARAMETER :: a0 = -.5, a1_s = .3333333, a2_s = -.2500068, a3 = .2000118, & + a4 = -.1661269, a5 = .1421878, a6 = -0.1384794, & + a7 = .1250060 + + REAL, PARAMETER :: fact(10) = (/ 1., 1., 2., 6., 24., 120., 720., 5040., & + 40320., 362880. /) + +!JOE: difmuk,fk,u errors - undefined + difmuk = 0. + fk = 1.0 + u = 0. + +! .. +! .. Executable Statements .. + IF (mu > 10.0) THEN +! C A S E A. (RECALCULATION OF S, D, L IF MU HAS CHANGED) + + IF (first) THEN + s = SQRT(mu) + d = 6.0*mu*mu + +! THE POISSON PROBABILITIES PK EXCEED THE DISCRETE NORMAL +! PROBABILITIES FK WHENEVER K >= M(MU). L=IFIX(MU-1.1484) +! IS AN UPPER BOUND TO M(MU) FOR ALL MU >= 10 . + + l = mu - 1.1484 + full_init = .false. + END IF + +! STEP N. NORMAL SAMPLE - random_normal() FOR STANDARD NORMAL DEVIATE + g_s = mu + s*random_normal() + IF (g_s > 0.0) THEN + ival = g_s + + ! STEP I. IMMEDIATE ACCEPTANCE IF ival IS LARGE ENOUGH + IF (ival>=l) RETURN + + ! STEP S. SQUEEZE ACCEPTANCE - SAMPLE U + fk = ival + difmuk = mu - fk + CALL RANDOM_NUMBER(u) + IF (d*u >= difmuk*difmuk*difmuk) RETURN + END IF + + ! STEP P. PREPARATIONS FOR STEPS Q AND H. + ! (RECALCULATIONS OF PARAMETERS IF NECESSARY) + ! .3989423=(2*PI)**(-.5) .416667E-1=1./24. .1428571=1./7. + ! THE QUANTITIES B1_S, B2_S, C3_S, C2_S, C1_S, C0 ARE FOR THE HERMITE + ! APPROXIMATIONS TO THE DISCRETE NORMAL PROBABILITIES FK. + ! C=.1069/MU GUARANTEES MAJORIZATION BY THE 'HAT'-FUNCTION. + + IF (.NOT. full_init) THEN + omega = .3989423/s + b1_s = .4166667E-1/mu + b2_s = .3*b1_s*b1_s + c3_s = .1428571*b1_s*b2_s + c2_s = b2_s - 15.*c3_s + c1_s = b1_s - 6.*b2_s + 45.*c3_s + c0 = 1. - b1_s + 3.*b2_s - 15.*c3_s + c = .1069/mu + full_init = .true. + END IF + + IF (g_s < 0.0) GO TO 50 + + ! 'SUBROUTINE' F IS CALLED (KFLAG=0 FOR CORRECT RETURN) + + kflag = 0 + GO TO 70 + + ! STEP Q. QUOTIENT ACCEPTANCE (RARE CASE) + + 40 IF (fy-u*fy <= py*EXP(px-fx)) RETURN + + ! STEP E. EXPONENTIAL SAMPLE - random_exponential() FOR STANDARD EXPONENTIAL + ! DEVIATE E AND SAMPLE T FROM THE LAPLACE 'HAT' + ! (IF T <= -.6744 THEN PK < FK FOR ALL MU >= 10.) + + 50 e = random_exponential() + CALL RANDOM_NUMBER(u) + u = u + u - one + t = 1.8 + SIGN(e, u) + IF (t <= (-.6744)) GO TO 50 + ival = mu + s*t + fk = ival + difmuk = mu - fk + + ! 'SUBROUTINE' F IS CALLED (KFLAG=1 FOR CORRECT RETURN) + + kflag = 1 + GO TO 70 + + ! STEP H. HAT ACCEPTANCE (E IS REPEATED ON REJECTION) + + 60 IF (c*ABS(u) > py*EXP(px+e) - fy*EXP(fx+e)) GO TO 50 + RETURN + + ! STEP F. 'SUBROUTINE' F. CALCULATION OF PX, PY, FX, FY. + ! CASE ival < 10 USES FACTORIALS FROM TABLE FACT + + 70 IF (ival>=10) GO TO 80 + px = -mu +!JOE: had error " Subscript #1 of FACT has value -858993459"; shouldn't be < 1. + !py = mu**ival/fact(ival+1) + py = mu**ival/fact(MAX(ival+1,1)) + GO TO 110 + + ! CASE ival >= 10 USES POLYNOMIAL APPROXIMATION + ! A0-A7 FOR ACCURACY WHEN ADVISABLE + ! .8333333E-1=1./12. .3989423=(2*PI)**(-.5) + + 80 del = .8333333E-1/fk + del = del - 4.8*del*del*del + v = difmuk/fk + IF (ABS(v)>0.25) THEN + px = fk*LOG(one + v) - difmuk - del + ELSE + px = fk*v*v* (((((((a7*v+a6)*v+a5)*v+a4)*v+a3)*v+a2_s)*v+a1_s)*v+a0) - del + END IF + py = .3989423/SQRT(fk) + 110 x = (half - difmuk)/s + xx = x*x + fx = -half*xx + fy = omega* (((c3_s*xx + c2_s)*xx + c1_s)*xx + c0) + IF (kflag <= 0) GO TO 40 + GO TO 60 + + !--------------------------------------------------------------------------- + ! C A S E B. mu < 10 + ! START NEW TABLE AND CALCULATE P0 IF NECESSARY + ELSE + + IF (first) THEN + m = MAX(1, INT(mu)) + l = 0 + !print*,"mu=",mu + !print*," mu=",mu," p=",EXP(-mu) + p = EXP(-mu) + q = p + p0 = p + END IF + + ! STEP U. UNIFORM SAMPLE FOR INVERSION METHOD + + DO + CALL RANDOM_NUMBER(u) + ival = 0 + IF (u <= p0) RETURN + + ! STEP T. TABLE COMPARISON UNTIL THE END PP(L) OF THE + ! PP-TABLE OF CUMULATIVE POISSON PROBABILITIES + ! (0.458=PP(9) FOR MU=10) + + IF (l == 0) GO TO 150 + j = 1 + IF (u > 0.458) j = MIN(l, m) + DO k = j, l + IF (u <= pp(k)) GO TO 180 + END DO + IF (l == 35) CYCLE + + ! STEP C. CREATION OF NEW POISSON PROBABILITIES P + ! AND THEIR CUMULATIVES Q=PP(K) + + 150 l = l + 1 + DO k = l, 35 + p = p*mu / k + q = q + p + pp(k) = q + IF (u <= q) GO TO 170 + END DO + l = 35 + END DO + + 170 l = k + 180 ival = k + RETURN + END IF + + RETURN + END subroutine random_Poisson + +!================================================================== + + FUNCTION random_normal() RESULT(fn_val) + + ! Adapted from the following Fortran 77 code + ! ALGORITHM 712, COLLECTED ALGORITHMS FROM ACM. + ! THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, + ! VOL. 18, NO. 4, DECEMBER, 1992, PP. 434-435. + + ! The function random_normal() returns a normally distributed pseudo-random + ! number with zero mean and unit variance. + + ! The algorithm uses the ratio of uniforms method of A.J. Kinderman + ! and J.F. Monahan augmented with quadratic bounding curves. + + REAL :: fn_val + + ! Local variables + REAL :: s = 0.449871, t = -0.386595, a = 0.19600, b = 0.25472, & + r1 = 0.27597, r2 = 0.27846, u, v, x, y, q + + ! Generate P = (u,v) uniform in rectangle enclosing acceptance region + + DO + CALL RANDOM_NUMBER(u) + CALL RANDOM_NUMBER(v) + v = 1.7156 * (v - half) + + ! Evaluate the quadratic form + x = u - s + y = ABS(v) - t + q = x**2 + y*(a*y - b*x) + + ! Accept P if inside inner ellipse + IF (q < r1) EXIT + ! Reject P if outside outer ellipse + IF (q > r2) CYCLE + ! Reject P if outside acceptance region + IF (v**2 < -4.0*LOG(u)*u**2) EXIT + END DO + + ! Return ratio of P's coordinates as the normal deviate + fn_val = v/u + RETURN + + END FUNCTION random_normal + +!=============================================================== + + FUNCTION random_exponential() RESULT(fn_val) + + ! Adapted from Fortran 77 code from the book: + ! Dagpunar, J. 'Principles of random variate generation' + ! Clarendon Press, Oxford, 1988. ISBN 0-19-852202-9 + + ! FUNCTION GENERATES A RANDOM VARIATE IN [0,INFINITY) FROM + ! A NEGATIVE EXPONENTIAL DlSTRIBUTION WlTH DENSITY PROPORTIONAL + ! TO EXP(-random_exponential), USING INVERSION. + + REAL :: fn_val + + ! Local variable + REAL :: r + + DO + CALL RANDOM_NUMBER(r) + IF (r > zero) EXIT + END DO + + fn_val = -LOG(r) + RETURN + + END FUNCTION random_exponential + +!=============================================================== + +subroutine condensation_edmf(QT,THL,P,zagl,THV,QC) +! +! zero or one condensation for edmf: calculates THV and QC +! +real,intent(in) :: QT,THL,P,zagl +real,intent(out):: THV,QC + +integer :: niter,i +real :: diff,exn,t,qs,qcold + +! constants used from module_model_constants.F +! p1000mb +! rcp ... Rd/cp +! xlv ... latent heat for water (2.5e6) +! cp +! rvord .. rv/rd (1.6) + + +! number of iterations + niter=50 +! minimum difference + diff=1.e-4 + + EXN=(P/p1000mb)**rcp + QC=0. + + do i=1,NITER + T=EXN*(THL+xlv/cp*QC) + QS=qsat_blend(T,P) + QCOLD=QC + QC=max(0.5*QC + 0.5*(QT-QS),0.) + if (abs(QC-QCOLD) moist_w +! thup_temfx -> moist_thl +! qtup_temfx -> moist_qt +! qlup_temfx -> moist_qc +! cf3d_temfx -> cldfra_bl1d +! au -> moist_a + + SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d, & + & u,v,w,th,thl,thv,qt,qv,qc,& + & qke,ust,flt,flq,flqv,flqc,& + & hfx,qfx,tsk, & + & pblh,rho,dfh,dx,znt,ep_2, & + ! outputs - updraft properties + & edmf_a,edmf_w,edmf_qt, & + & edmf_thl,edmf_ent,edmf_qc,& +! & dry_a,moist_a, & +! & dry_w,moist_w, & +! & dry_qt,moist_qt, & +! & dry_thl,moist_thl, & +! & dry_ent,moist_ent, & +! & moist_qc, & + ! outputs - variables needed for solver + & s_aw,s_awthl,s_awqt, & + & s_awqv,s_awqc, & + & s_awu,s_awv,s_awqke, & +#if (WRF_CHEM == 1) + & nchem,chem,s_awchem, & +#endif + ! in/outputs - subgrid scale clouds + & qc_bl1d,cldfra_bl1d, & + ! inputs - flags for moist arrays + &F_QC,F_QI,psig) + + ! inputs: + INTEGER, INTENT(IN) :: kts,kte + REAL,DIMENSION(kts:kte), INTENT(IN) :: u,v,w,th,thl,qt,qv,qc,thv,p,pi1d + REAL,DIMENSION(kts:kte), INTENT(IN) :: qke + REAL,DIMENSION(kts:kte+1), INTENT(IN) :: zw !height at full-sigma + REAL,DIMENSION(kts:kte), INTENT(IN) :: rho !density + REAL,DIMENSION(kts:kte), INTENT(IN) :: dfh !diffusivity for heat + REAL, INTENT(IN) :: dt,ust,flt,flq,flqv,flqc,hfx,qfx,tsk,pblh,dx,znt,ep_2,psig + LOGICAL, OPTIONAL :: f_qc,f_qi + + ! outputs - updraft properties + REAL,DIMENSION(kts:kte), INTENT(OUT) :: & + & edmf_a,edmf_w,edmf_qt, & + & edmf_thl,edmf_ent,edmf_qc + + ! outputs - variables needed for solver + REAL,DIMENSION(kts:kte+1) :: s_aw, & !sum ai*wis_awphi + s_awthl, & !sum ai*wi*phii + s_awqt, & + s_awqv, & + s_awqc, & + s_awu, & + s_awv, & + s_awqke +#if (WRF_CHEM == 1) + INTEGER, INTENT(IN) :: nchem + REAL,DIMENSION(kts:kte+1, nchem) :: chem + REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem + INTEGER :: ic +#endif + + REAL,DIMENSION(kts:kte), INTENT(INOUT) :: qc_bl1d,cldfra_bl1d + +! Local variables +! +! EDMF constants + real, parameter :: CM = 0.03 ! Proportionality constant for subcloud MF + real, parameter :: Cdelt = 0.006 ! Prefactor for detrainment rate + real, parameter :: Cw = 0.5 ! Prefactor for surface wUPD + real, parameter :: Cc = 3.0 ! Prefactor for convective length scale + real, parameter :: lasymp = 200.0 ! Asymptotic length scale WA 11/20/09 + real, parameter :: hmax = 4000.0 ! Max hd,hct WA 11/20/09 + integer, parameter :: Nupd = 8 ! Number of updrafts +! + integer :: i, k, kt, nu ! Loop variable + integer:: h0idx + real:: h0 + real:: wstr, ang, wm + real, dimension( Nupd) :: hd,lcl,hct,ht + real:: convection_TKE_surface_src, sfcFTE + real:: sfcTHVF + real:: z0t + integer, dimension( Nupd) :: hdidx,lclidx,hctidx,htidx + integer:: hmax_idx + integer:: tval + real, dimension( kts:kte) :: zm, zt, dzm, dzt + real, dimension( kts:kte) :: thetal, qtot + real, dimension( kts:kte) :: u_temf, v_temf + real, dimension( kts:kte) :: rv, rl, rt + real, dimension( kts:kte) :: chi_poisson, gam + real, dimension( kts:kte) :: dthdz + real, dimension( kts:kte) :: lepsmin + real, dimension( kts:kte) :: thetav + real, dimension( kts:kte) :: dmoist_qtdz + real, dimension( kts:kte) :: B, Bmoist + real, dimension( kts:kte, Nupd) :: epsmf, deltmf, dMdz + real, dimension( kts:kte, Nupd) :: UUPD, VUPD + real, dimension( kts:kte, Nupd) :: thetavUPD, qlUPD, TEUPD + real, dimension( kts:kte, Nupd) :: thetavUPDmoist, wUPD_dry + real, dimension( kts:kte, Nupd) :: dthUPDdz, dwUPDdz + real, dimension( kts:kte, Nupd) :: dwUPDmoistdz + real, dimension( kts:kte, Nupd) :: dUUPDdz, dVUPDdz, dTEUPDdz + real, dimension( kts:kte, Nupd) :: TUPD, rstUPD, rUPD, rlUPD, qstUPD + real, dimension( kts:kte, Nupd) :: MUPD, wUPD, qtUPD, thlUPD, qcUPD + real, dimension( kts:kte, Nupd) :: aUPD, cldfraUPD + real, dimension( kts:kte) :: N2, S, Ri, beta, ftau, fth, ratio + real, dimension( kts:kte) :: TKE, TE2 + real, dimension( kts:kte) :: ustrtilde, linv, leps + real, dimension( kts:kte) :: km, kh + real, dimension( kts:kte) :: Fz, QFK, uwk, vwk + real, dimension( kts:kte) :: km_conv, kh_conv, lconv + real, dimension( kts:kte) :: alpha2, beta2 ! For thetav flux calculation + real, dimension( kts:kte) :: THVF, buoy_src, srcs + real, dimension( kts:kte) :: beta1 ! For saturation humidity calculations + real, dimension( kts:kte) :: MFCth + real Cepsmf ! Prefactor for entrainment rate + real red_fact ! for reducing MF components + real, dimension( kts:kte) :: edmf_u, edmf_v, edmf_qke ! Same format as registry vars, but not passed out + +#if (WRF_CHEM == 1) + real,dimension( kts:kte+1, nchem, Nupd) :: chemUPD, dchemUPDdz + real,dimension( kts:kte+1, nchem) :: edmf_chem +#endif + + ! Used to be TEMF external variables, now local + real, dimension( kts:kte, Nupd) :: & + shf_temfx, qf_temfx, uw_temfx, vw_temfx , & + mf_temfx + real, dimension( Nupd) :: hd_temfx, lcl_temfx, hct_temfx, cfm_temfx + logical is_convective + ! Vars for cloud fraction calculation + real, dimension( kts:kte) :: sigq, qst, satdef + real :: sigq2, rst, cldfra_sum, psig_w, maxw + +!---------------------------------------------------------------------- +! Grid staggering: Matlab version has mass and turbulence levels. +! WRF has full levels (with w) and half levels (u,v,theta,q*). Both +! sets of levels use the same indices (kts:kte). See pbl_driver or +! WRF Physics doc for (a few) details. +! So *mass levels correspond to half levels.* +! WRF full levels are ignored, we define our own turbulence levels +! in order to put the first one below the first half level. +! Another difference is that +! the Matlab version (and the Mauritsen et al. paper) consider the +! first mass level to be at z0 (effectively the surface). WRF considers +! the first half level to be above the effective surface. The first half +! level, at k=1, has nonzero values of u,v for example. Here we convert +! all incoming variables to internal ones with the correct indexing +! in order to make the code consistent with the Matlab version. We +! already had to do this for thetal and qt anyway, so the only additional +! overhead is for u and v. +! I use suffixes m for mass and t for turbulence as in Matlab for things +! like indices. +! Note that zsrf is the terrain height ASL, from Registry variable ht. +! Translations (Matlab to WRF): +! dzt -> calculated below +! dzm -> not supplied, calculated below +! k -> karman +! z0 -> znt +! z0t -> not in WRF, calculated below +! zt -> calculated below +! zm -> zw but NOTE zm(1) is now z0 (znt) and zm(2) is zw(1) +! +! Other notes: +! - I have often used 1 instead of kts below, because the scheme demands +! to know where the surface is. It won't work if kts .NE. 1. + + IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + WRITE ( mynn_message , FMT='(A)' ) & + ' MYNN; in TEMF_MF, beginning' + CALL wrf_debug ( 0 , mynn_message ) + ENDIF + + !JOE-initialize s_aw* variables + s_aw = 0. + s_awthl= 0. + s_awqt = 0. + s_awqv = 0. + s_awqc = 0. + s_awu = 0. + s_awv = 0. + s_awqke= 0. + edmf_a = 0. + edmf_w = 0. + edmf_qt= 0. !qt + edmf_thl=0. !thl + edmf_ent=0. + edmf_qc= 0. !qc + edmf_u=0. + edmf_v=0. + edmf_qke=0. + + z0t = znt + + do k = kts,kte + rv(k) = qv(k) / (1.-qv(k)) ! Water vapor + rl(k) = qc(k) / (1.-qc(k)) ! Liquid water + rt(k) = qt(k) ! Total water (without ice) + thetal(k) = thl(k) + qtot(k) = qt(k) + thetav(k) = thv(k) + end do + + do k = kts,kte + u_temf(k) = u(k) + v_temf(k) = v(k) + end do + + !taper off MF scheme when significant resolved-scale motions are present + !This function needs to be asymetric... + k = 1 + maxw = 0.0 + DO WHILE (ZW(k) < pblh + 500.) + maxw = MAX(maxw,ABS(W(k))) + k = k+1 + ENDDO + maxw = MAX(0.,maxw - 0.5) ! do nothing for small w, but + Psig_w = MAX(0.0, 1.0 - maxw/0.5) ! linearly taper off for w > 0.5 m/s + Psig_w = MIN(Psig_w, Psig) + !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu + + ! Get delta height at half (mass) levels + zm(1) = znt + dzt(1) = zw(2) - zm(1) + ! Get height and delta at turbulence levels + zt(1) = (zw(2) - znt) / 2. + do kt = kts+1,kte + zm(kt) = zw(kt) ! Convert indexing from WRF to TEMF + zt(kt) = (zm(kt) + zw(kt+1)) / 2. + dzm(kt) = zt(kt) - zt(kt-1) + dzt(kt) = zw(kt+1) - zw(kt) + end do + dzm(1) = dzm(2) + + !print *,"In TEMF_MF zw = ", zw + !print *,"zm = ", zm + !print *,"zt = ", zt + !print *,"dzm = ", dzm + !print *,"dzt = ", dzt + + ! Gradients at first level + dthdz(1) = (thetal(2)-thetal(1)) / (zt(1) * log10(zm(2)/z0t)) + + !print *,"In TEMF_MF dthdz(1),thetal(2,1),tsk,zt(1),zm(2),z0t = ", & + ! dthdz(1),thetal(2),thetal(1),tsk,zt(1),zm(2),z0t + + ! Surface thetaV flux from Stull p.147 + sfcTHVF = hfx/(rho(1)*cp) * (1.+0.608*(qv(1)+qc(1))) + 0.608*thetav(1)*qfx + + ! WA use hd_temf to calculate w* instead of finding h0 here???? + ! Watch initialization! + h0idx = 1 + h0 = zm(1) + + lepsmin(kts) = 0. + + ! WA 2/11/13 find index just above hmax for use below + hmax_idx = kte-1 + + do k = kts+1,kte-1 + lepsmin(k) = 0. + + ! Mean gradients + dthdz(k) = (thetal(k+1) - thetal(k)) / dzt(k) + + ! Find h0 (should eventually be interpolated for smoothness) + if (thetav(k) > thetav(1) .AND. h0idx .EQ. 1) then + ! WA 9/28/11 limit h0 as for hd and hct + if (zm(k) < hmax) then + h0idx = k + h0 = zm(k) + else + h0idx = k + h0 = hmax + end if + end if + ! WA 2/11/13 find index just above hmax for use below + if (zm(k) > hmax) then + hmax_idx = min(hmax_idx,k) + end if + end do + + ! Gradients at top level + + dthdz(kte) = dthdz(kte-1) + + if ( hfx > 0.) then + wstr = (g * h0 / thetav(2) * hfx/(rho(1)*cp) ) ** (1./3.) + else + wstr = 0. + end if + + !print *,"In TEMF_MF wstr,hfx,dthdz(1:2),h0 = ", wstr,hfx,dthdz(1),dthdz(2),h0 + IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + WRITE ( mynn_message , FMT='(A,F5.1,F6.1,F5.1,F5.1,F5.1)' ) & + ' MYNN; in TEMF_MF: wstr,hfx,dtdz1,dtdz2,h0:', wstr,hfx,dthdz(1),dthdz(2),h0 + CALL wrf_debug ( 0 , mynn_message ) + ENDIF + + ! Set flag convective or not for use below + is_convective = wstr > 0. .AND. dthdz(1)<0. .AND. dthdz(2)<0. + ! WA 12/16/09 require two levels of negative (unstable) gradient + + !*** Mass flux block starts here *** + ! WA WFIP 11/13/15 allow multiple updrafts, deterministic for now + + if ( is_convective) then + + !print *,"In TEMF_MF is_convective, wstr = ", wstr + IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + WRITE ( mynn_message , FMT='(A)' ) & + ' MYNN; in TEMF_MF: inconvective branch' + CALL wrf_debug ( 0 , mynn_message ) + ENDIF + + Cepsmf = 2. / max(200.,h0) + ! Cepsmf = max(Cepsmf,0.002) + Cepsmf = max(Cepsmf,0.0015) ! WA TEST reduce max entrainment + + do nu = 1,Nupd + do k = kts,kte + ! Calculate lateral entrainment fraction for subcloud layer + ! epsilon and delta are defined on mass grid (half levels) + ! epsmf(k,nu) = Cepsmf * (1+0.2*(floor(nu - Nupd/2.))) ! WA for three updrafts + ! epsmf(k,nu) = Cepsmf * (1+0.05*(floor(nu - Nupd/2.))) ! WA for ten updrafts + !epsmf(k,nu) = Cepsmf * (1+0.0625*(floor(nu - Nupd/2.))) ! WA for eight updrafts + epsmf(k,nu) = Cepsmf * (1+0.03*(floor(nu - Nupd/2.))) ! WA for eight updrafts, less spread + end do + !print *,"In TEMF_MF Cepsmf, epsmf = ", Cepsmf, epsmf(1,:) + !IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + ! WRITE ( mynn_message , FMT='(A,F8.4)' ) & + ! ' MYNN; in TEMF_MF, Cepsmf, epsmf(1:13,nu)=', Cepsmf + ! CALL wrf_debug ( 0 , mynn_message ) + ! print*," epsmf(1:13,nu)=",epsmf(1:13,nu) + !ENDIF + + ! Initialize updraft + thlUPD(1,nu) = thetal(1) + Cw*wstr + qtUPD(1,nu) = qtot(1) + 0.0*qfx/wstr + rUPD(1,nu) = qtUPD(1,nu) / (1. - qtUPD(1,nu)) + wUPD(1,nu) = Cw * wstr + wUPD_dry(1,nu) = Cw * wstr + UUPD(1,nu) = u_temf(1) + VUPD(1,nu) = v_temf(1) + thetavUPD(1,nu) = thlUPD(1,nu) * (1. + 0.608*qtUPD(1,nu)) ! WA Assumes no liquid + thetavUPDmoist(1,nu) = thetavUPD(1,nu) + TEUPD(1,nu) = qke(1) + g / thetav(1) * sfcTHVF + qlUPD(1,nu) = qc(1) ! WA allow environment liquid + TUPD(1,nu) = thlUPD(1,nu) * pi1d(1) + !rstUPD(1,nu) = rsat_temf(p(1),TUPD(1,nu),ep_2) + rstUPD(1,nu) = qsat_blend(TUPD(1,nu),p(1)) ! get saturation water vapor mixing ratio at tl and p + rlUPD(1,nu) = 0. +#if (WRF_CHEM == 1) + do ic = 1,nchem + chemUPD(1,ic,nu) = chem(1,ic) + enddo +#endif + + ! Calculate updraft parameters counting up + do k = 2,kte + ! WA 2/11/13 use hmax index to prevent oddness high up + if ( k < hmax_idx) then + dthUPDdz(k-1,nu) = -epsmf(k,nu) * (thlUPD(k-1,nu) - thetal(k-1)) + thlUPD(k,nu) = thlUPD(k-1,nu) + dthUPDdz(k-1,nu) * dzm(k-1) + dmoist_qtdz(k-1) = -epsmf(k,nu) * (qtUPD(k-1,nu) - qtot(k-1)) + qtUPD(k,nu) = qtUPD(k-1,nu) + dmoist_qtdz(k-1) * dzm(k-1) + thetavUPD(k,nu) = thlUPD(k,nu) * (1. + 0.608*qtUPD(k,nu)) ! WA Assumes no liquid + B(k-1) = g * (thetavUPD(k,nu) - thetav(k)) / thetav(k) + if ( wUPD_dry(k-1,nu) < 1e-15 ) then + wUPD_dry(k,nu) = 0. + else + dwUPDdz(k-1,nu) = -2. *epsmf(k,nu)*wUPD_dry(k-1,nu) + 0.33*B(k-1)/wUPD_dry(k-1,nu) + wUPD_dry(k,nu) = wUPD_dry(k-1,nu) + dwUPDdz(k-1,nu) * dzm(k-1) + end if + dUUPDdz(k-1,nu) = -epsmf(k,nu) * (UUPD(k-1,nu) - u_temf(k-1)) + UUPD(k,nu) = UUPD(k-1,nu) + dUUPDdz(k-1,nu) * dzm(k-1) + dVUPDdz(k-1,nu) = -epsmf(k,nu) * (VUPD(k-1,nu) - v_temf(k-1)) + VUPD(k,nu) = VUPD(k-1,nu) + dVUPDdz(k-1,nu) * dzm(k-1) + dTEUPDdz(k-1,nu) = -epsmf(k,nu) * (TEUPD(k-1,nu) - qke(k-1)) + TEUPD(k,nu) = TEUPD(k-1,nu) + dTEUPDdz(k-1,nu) * dzm(k-1) + ! Alternative updraft velocity based on moist thetav + ! Need thetavUPDmoist, qlUPD + rUPD(k,nu) = qtUPD(k,nu) / (1. - qtUPD(k,nu)) + ! WA Updraft temperature assuming no liquid + TUPD(k,nu) = thlUPD(k,nu) * pi1d(k) + ! Updraft saturation mixing ratio + !rstUPD(k,nu) = rsat_temf(p(k-1),TUPD(k,nu),ep_2) + rstUPD(k,nu) = qsat_blend(TUPD(k,nu),p(k-1)) + ! Correct to actual temperature (Sommeria & Deardorff 1977) + beta1(k) = 0.622 * (xlv/(r_d*TUPD(k,nu))) * (xlv/(cp*TUPD(k,nu))) + rstUPD(k,nu) = rstUPD(k,nu) * (1.0+beta1(k)*rUPD(k,nu)) / (1.0+beta1(k)*rstUPD(k,nu)) + qstUPD(k,nu) = rstUPD(k,nu) / (1. + rstUPD(k,nu)) + if (rUPD(k,nu) > rstUPD(k,nu)) then + rlUPD(k,nu) = rUPD(k,nu) - rstUPD(k,nu) + qlUPD(k,nu) = rlUPD(k,nu) / (1. + rlUPD(k,nu)) + thetavUPDmoist(k,nu) = (thlUPD(k,nu) + ((xlv/cp)*qlUPD(k,nu)/pi1d(k))) * & + (1. + 0.608*qstUPD(k,nu) - qlUPD(k,nu)) + else + rlUPD(k,nu) = 0. + qlUPD(k,nu) = qc(k-1) ! WA 4/6/10 allow environment liquid + thetavUPDmoist(k,nu) = thlUPD(k,nu) * (1. + 0.608*qtUPD(k,nu)) + end if + Bmoist(k-1) = g * (thetavUPDmoist(k,nu) - thetav(k)) / thetav(k) + if ( wUPD(k-1,nu) < 1e-15 ) then + wUPD(k,nu) = 0. + else + dwUPDmoistdz(k-1,nu) = -2. *epsmf(k,nu)*wUPD(k-1,nu) + 0.33*Bmoist(k-1)/wUPD(k-1,nu) + wUPD(k,nu) = wUPD(k-1,nu) + dwUPDmoistdz(k-1,nu) * dzm(k-1) + end if +#if (WRF_CHEM == 1) + do ic = 1,nchem + dchemUPDdz(k-1,ic,nu) = -epsmf(k,nu) * (chemUPD(k-1,ic,nu) - chem(k-1,ic)) + chemUPD(k,ic,nu) = chemUPD(k-1,ic,nu) + dchemUPDdz(k-1,ic,nu) * dzm(k-1) + enddo +#endif + else ! above hmax + thlUPD(k,nu) = thetal(k) + qtUPD(k,nu) = qtot(k) + wUPD_dry(k,nu) = 0. + UUPD(k,nu) = u_temf(k) + VUPD(k,nu) = v_temf(k) + TEUPD(k,nu) = qke(k) + qlUPD(k,nu) = qc(k-1) + wUPD(k,nu) = 0. +#if (WRF_CHEM == 1) + do ic = 1,nchem + chemUPD(k,ic,nu) = chem(k-1,ic) + enddo +#endif + end if + + IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + IF ( ABS(wUPD(k,nu))>10. ) THEN + WRITE ( mynn_message , FMT='(A,2I3)' ) & + ' MYNN, in TEMF_MF, huge w at (nu,k):', nu,k + CALL wrf_debug ( 0 , mynn_message ) + print *," thlUPD(1:k,nu) = ", thlUPD(1:k,nu) + print *," wUPD(1:k,nu) = ", wUPD(1:k,nu) + print *," Bmoist(1:k-1) = ", Bmoist(1:k-1) + print *," epsmf(1:k,nu) = ", epsmf(1:k,nu) + ENDIF + ENDIF + + ENDDO !end-k + + ! Find hd based on wUPD + if (wUPD_dry(1,nu) == 0.) then + hdidx(nu) = 1 + else + hdidx(nu) = kte ! In case wUPD <= 0 not found + do k = 2,kte + if (wUPD_dry(k,nu) <= 0. .OR. zm(k) > hmax) then + hdidx(nu) = k + ! goto 100 ! FORTRAN made me do it! + exit + end if + end do + end if + 100 hd(nu) = zm(hdidx(nu)) + + ! Find LCL, hct, and ht + lclidx(nu) = kte ! In case LCL not found + do k = kts,kte + if ( k < hmax_idx .AND. rUPD(k,nu) > rstUPD(k,nu)) then + lclidx(nu) = k + ! goto 200 + exit + end if + end do + 200 lcl(nu) = zm(lclidx(nu)) + + if (hd(nu) > lcl(nu)) then ! Forced cloud (at least) occurs + ! Find hct based on wUPDmoist + if (wUPD(1,nu) == 0.) then + hctidx(nu) = 1 + else + hctidx(nu) = kte ! In case wUPD <= 0 not found + do k = 2,kte + if (wUPD(k,nu) <= 0. .OR. zm(k) > hmax) then + hctidx(nu) = k + ! goto 300 ! FORTRAN made me do it! + exit + end if + end do + end if + 300 hct(nu) = zm(hctidx(nu)) + if (hctidx(nu) <= hdidx(nu)+1) then ! No active cloud + hct(nu) = hd(nu) + hctidx(nu) = hdidx(nu) + else + end if + else ! No cloud + hct(nu) = hd(nu) + hctidx(nu) = hdidx(nu) + end if + ht(nu) = max(hd(nu),hct(nu)) + htidx(nu) = max(hdidx(nu),hctidx(nu)) + + ! Now truncate updraft at ht with taper + do k = 1,kte + if (zm(k) < 0.9*ht(nu)) then ! Below taper region + tval = 1 + else if (zm(k) >= 0.9*ht(nu) .AND. zm(k) <= 1.0*ht(nu)) then + ! Within taper region + tval = 1. - ((zm(k) - 0.9*ht(nu)) / (1.0*ht(nu) - 0.9*ht(nu))) + else ! Above taper region + tval = 0. + end if + thlUPD(k,nu) = tval * thlUPD(k,nu) + (1-tval)*thetal(k) + thetavUPD(k,nu) = tval * thetavUPD(k,nu) + (1-tval)*thetav(k) + qtUPD(k,nu) = tval * qtUPD(k,nu) + (1-tval) * qtot(k) + if (k > 1) then + qlUPD(k,nu) = tval * qlUPD(k,nu) + (1-tval) * qc(k-1) + end if + UUPD(k,nu) = tval * UUPD(k,nu) + (1-tval) * u_temf(k) + VUPD(k,nu) = tval * VUPD(k,nu) + (1-tval) * v_temf(k) + TEUPD(k,nu) = tval * TEUPD(k,nu) + (1-tval) * qke(k) + if (zm(k) > ht(nu)) then ! WA this is just for cleanliness + wUPD(k,nu) = 0. + dwUPDmoistdz(k,nu) = 0. + wUPD_dry(k,nu) = 0. + dwUPDdz(k,nu) = 0. + end if +#if (WRF_CHEM == 1) + do ic = 1,nchem + chemUPD(k,ic,nu) = tval * chemUPD(k,ic,nu) + (1-tval) * chem(k,ic) + enddo +#endif + end do + + ! Calculate lateral detrainment rate for cloud layer + ! WA 8/5/15 constant detrainment + deltmf(1,nu) = Cepsmf + do k = 2,kte-1 + deltmf(k,nu) = deltmf(k-1,nu) + end do + deltmf(kte,nu) = Cepsmf + + ! Calculate mass flux (defined on turbulence levels) + mf_temfx(1,nu) = CM * wstr / Nupd + ! WA 3/2/16 limit max MF for stability + ! WA reduce the constant for improved numerical stability? + mf_temfx(1,nu) = min(mf_temfx(1,nu),0.2/Nupd) + do kt = 2,kte-1 + dMdz(kt,nu) = (epsmf(kt,nu) - deltmf(kt,nu)) * mf_temfx(kt-1,nu) * dzt(kt) + mf_temfx(kt,nu) = mf_temfx(kt-1,nu) + dMdz(kt,nu) + IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + IF ( mf_temfx(kt,nu)>=0.2/NUPD ) THEN + WRITE ( mynn_message , FMT='(A,2I3)' ) & + ' MYNN, in TEMF_MF, huge MF at (nu,k):', nu,kt + CALL wrf_debug ( 0 , mynn_message ) + print *," mf_temfx(1:kt,nu) = ", mf_temfx(1:kt,nu) + ENDIF + ENDIF + end do + mf_temfx(kte,nu) = 0. + + ! Calculate cloud fraction (on mass levels) + ! WA eventually replace this with the same saturation calculation + ! used in the MYNN code above for consistency. + do k = 2,kte + if (wUPD(k-1,nu) >= 1.0e-15 .AND. wUPD(k,nu) >= 1.0e-15) then + aUPD(k,nu) = ((mf_temfx(k-1,nu)+mf_temfx(k,nu))/2.0) / & + ((wUPD(k-1,nu)+wUPD(k,nu))/2.0) ! WA average before divide, is that best? + else + aUPD(k,nu) = 0.0 + end if + sigq2 = aUPD(k,nu) * (qtUPD(k,nu)-qtot(k)) + if (sigq2 > 0.0) then + sigq(k) = sqrt(sigq2) + else + sigq(k) = 0.0 + end if + !rst = rsat_temf(p(k-1),th(k-1)*pi1d(k-1),ep_2) + rst = qsat_blend(th(k-1)*pi1d(k-1),p(k-1)) + qst(k) = rst / (1. + rst) + satdef(k) = qtot(k) - qst(k) + if (satdef(k) <= 0.0) then + if (sigq(k) > 1.0e-15) then + cldfraUPD(k,nu) = max(0.5 + 0.36 * atan(1.55*(satdef(k)/sigq(k))),0.0) / Nupd + else + cldfraUPD(k,nu) = 0.0 + end if + else + cldfraUPD(k,nu) = 1.0 / Nupd + end if + if (zm(k) < lcl(nu)) then + cldfraUPD(k,nu) = 0.0 + end if + end do + + end do ! loop over nu updrafts + + ! Add updraft areas into edmf_a, etc. + ! Add cloud fractions into cldfra_bl1d + !cldfra_bl1d(1) = 0.0 + cfm_temfx = 0.0 + do k = 2,kte + !cldfra_bl1d(k) = 0.0 + cldfra_sum = 0.0 + edmf_a(k) = 0.0 + edmf_w(k) = 0.0 + edmf_thl(k) = 0.0 + edmf_qt(k) = 0.0 + edmf_qc(k) = 0.0 + edmf_u(k) = 0.0 + edmf_v(k) = 0.0 + edmf_qke(k) = 0.0 + edmf_ent(k) = 0.0 +#if (WRF_CHEM == 1) + do ic = 1,nchem + edmf_chem(k,ic) = 0.0 + enddo +#endif + do nu = 1,Nupd + edmf_a(k) = edmf_a(k) + aUPD(k,nu) + edmf_w(k) = edmf_w(k) + aUPD(k,nu)*wUPD(k,nu) + edmf_thl(k) = edmf_thl(k) + aUPD(k,nu)*thlUPD(k,nu) + ! print *,"k,nu,aUPD,thlUPD,edmf_thl = ", k,nu,aUPD(k,nu),thlUPD(k,nu),edmf_thl(k) + edmf_qt(k) = edmf_qt(k) + aUPD(k,nu)*qtUPD(k,nu) + edmf_qc(k) = edmf_qc(k) + aUPD(k,nu)*qlUPD(k,nu) + edmf_u(k) = edmf_u(k) + aUPD(k,nu)*UUPD(k,nu) + edmf_v(k) = edmf_v(k) + aUPD(k,nu)*VUPD(k,nu) + edmf_qke(k) = edmf_qke(k) + aUPD(k,nu)*TEUPD(k,nu) + edmf_ent(k) = edmf_ent(k) + aUPD(k,nu)*epsmf(k,nu) + !cldfra_bl1d(k) = cldfra_bl1d(k) + cldfraUPD(k,nu) + cldfra_sum = cldfra_sum + cldfraUPD(k,nu) +#if (WRF_CHEM == 1) + do ic = 1,nchem + edmf_chem(k,ic) = edmf_chem(k,ic) + aUPD(k,nu)*chemUPD(k,ic,nu) + enddo +#endif + end do + + IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + ! print *,"In TEMF_MF edmf_w = ", edmf_w(1:10) + ! print *,"In TEMF_MF edmf_a = ", edmf_a(1:10) + ! print *,"In TEMF_MF edmf_thl = ", edmf_thl(1:10) + ! print *,"In TEMF_MF aUPD(2,:) = ", aUPD(2,:) + ! print *,"In TEMF_MF wUPD(2,:) = ", wUPD(2,:) + ! print *,"In TEMF_MF thlUPD(2,:) = ", thlUPD(2,:) + ENDIF + + if (edmf_a(k)>0.) then + edmf_w(k)=edmf_w(k)/edmf_a(k) + edmf_qt(k)=edmf_qt(k)/edmf_a(k) + edmf_thl(k)=edmf_thl(k)/edmf_a(k) + edmf_ent(k)=edmf_ent(k)/edmf_a(k) + edmf_qc(k)=edmf_qc(k)/edmf_a(k) + edmf_u(k)=edmf_u(k)/edmf_a(k) + edmf_v(k)=edmf_v(k)/edmf_a(k) + edmf_qke(k)=edmf_qke(k)/edmf_a(k) +#if (WRF_CHEM == 1) + do ic = 1,nchem + edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k) + enddo +#endif + + if (edmf_qc(k) > 0.0) then + IF (cldfra_sum > edmf_a(k)) THEN + cldfra_bl1d(k) = cldfra_sum + qc_bl1d(k) = edmf_qc(k)*edmf_a(k)/cldfra_sum + ELSE + cldfra_bl1d(k)=edmf_a(k) + qc_bl1d(k) = edmf_qc(k) + ENDIF + endif + endif + + ! Put max value so far into cfm + if (zt(k) <= hmax) then + cfm_temfx = max(cldfra_bl1d(k),cfm_temfx) + end if + end do + + !cldfra_bl1d(kte) = 0.0 + + ! Computing variables needed for solver + + do k=kts,kte ! do these in loop above + s_aw(k) = edmf_a(k)*edmf_w(k)*psig_w + s_awthl(k)= edmf_a(k)*edmf_w(k)*edmf_thl(k)*psig_w + s_awqt(k) = edmf_a(k)*edmf_w(k)*edmf_qt(k)*psig_w + s_awqc(k) = edmf_a(k)*edmf_w(k)*edmf_qc(k)*psig_w + s_awqv(k) = s_awqt(k) - s_awqc(k) + s_awu(k) = edmf_a(k)*edmf_w(k)*edmf_u(k)*psig_w + s_awv(k) = edmf_a(k)*edmf_w(k)*edmf_v(k)*psig_w + s_awqke(k) = edmf_a(k)*edmf_w(k)*edmf_qke(k)*psig_w +#if (WRF_CHEM == 1) + do ic = 1,nchem + s_awchem(k,ic) = edmf_w(k)*edmf_chem(k,ic)*psig_w + enddo +#endif + !now reduce diagnostic output arrays by psig + edmf_w(k)=edmf_w(k)*psig_w + edmf_qt(k)=edmf_qt(k)*psig_w + edmf_thl(k)=edmf_thl(k)*psig_w + edmf_ent(k)=edmf_ent(k)*psig_w + edmf_qc(k)=edmf_qc(k)*psig_w + edmf_u(k)=edmf_u(k)*psig_w + edmf_v(k)=edmf_v(k)*psig_w + edmf_qke(k)=edmf_qke(k)*psig_w + enddo + + ! end if ! is_convective + ! Mass flux block ends here + else + edmf_a = 0. + edmf_w = 0. + edmf_qt = 0. + edmf_thl = 0. + edmf_ent = 0. + edmf_u = 0. + edmf_v = 0. + edmf_qke = 0. + s_aw = 0. + s_awthl= 0. + s_awqt = 0. + s_awqv = 0. + s_awqc = 0. + s_awu = 0. + s_awv = 0. + s_awqke= 0. + edmf_qc(1) = qc(1) + !qc_bl1d(1) = qc(1) + do k = kts+1,kte-1 + edmf_qc(k) = qc(k-1) + !qc_bl1d(k) = qc(k-1) + end do +#if (WRF_CHEM == 1) + do ic = 1,nchem + s_awchem(:,ic) = 0. + enddo +#endif + end if + !edmf_qc(kte) = qc(kte) + !qc_bl1d(kte) = qc(kte) + + !IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN + ! print *,"After TEMF_MF, s_aw = ", s_aw(1:5) + ! print *,"After TEMF_MF, s_awthl = ", s_awthl(1:5) + ! print *,"After TEMF_MF, s_awqt = ", s_awqt(1:5) + ! print *,"After TEMF_MF, s_awqc = ", s_awqc(1:5) + ! print *,"After TEMF_MF, s_awqv = ", s_awqv(1:5) + ! print *,"After TEMF_MF, s_awu = ", s_awu(1:5) + ! print *,"After TEMF_MF, s_awv = ", s_awv(1:5) + ! print *,"After TEMF_MF, s_awqke = ", s_awqke(1:5) + !ENDIF + +END SUBROUTINE temf_mf + +!-------------------------------------------------------------------- +! + real function rsat_temf(p,T,ep2) + +! Calculates the saturation mixing ratio with respect to liquid water +! Arguments are pressure (Pa) and absolute temperature (K) +! Uses the formula from the ARM intercomparison setup. +! Converted from Matlab by WA 7/28/08 + +implicit none +real p, T, ep2 +real temp, x +real, parameter :: c0 = 0.6105851e+3 +real, parameter :: c1 = 0.4440316e+2 +real, parameter :: c2 = 0.1430341e+1 +real, parameter :: c3 = 0.2641412e-1 +real, parameter :: c4 = 0.2995057e-3 +real, parameter :: c5 = 0.2031998e-5 +real, parameter :: c6 = 0.6936113e-8 +real, parameter :: c7 = 0.2564861e-11 +real, parameter :: c8 = -0.3704404e-13 + +temp = T - 273.15 + +x =c0+temp*(c1+temp*(c2+temp*(c3+temp*(c4+temp*(c5+temp*(c6+temp*(c7+temp*c8))))))) +rsat_temf = ep2*x/(p-x) + +return +end function rsat_temf + +!================================================================= END MODULE module_bl_mynn diff --git a/wrfv2_fire/phys/module_bl_shinhong.F b/wrfv2_fire/phys/module_bl_shinhong.F index 651225cd..dc5cd5c5 100644 --- a/wrfv2_fire/phys/module_bl_shinhong.F +++ b/wrfv2_fire/phys/module_bl_shinhong.F @@ -1,118 +1,6 @@ !WRF:model_layer:physics ! module module_bl_shinhong -! - USE MODULE_MODEL_CONSTANTS -! -!----------------------------------------------------------------------- -! - INTEGER :: ITRMX=5 ! ITERATION COUNT FOR MIXING LENGTH COMPUTATION - REAL,PARAMETER :: PI=3.1415926,VKARMAN=0.4 -! -!----------------------------------------------------------------------- -!*** QNSE MODEL CONSTANTS -!----------------------------------------------------------------------- -! - REAL,PARAMETER :: EPSQ2L=0.01 - REAL,PARAMETER :: C0=0.55,CEPS=C0**3,BLCKDR=0.0063,CN=0.75 & - & ,AM1=8.0,AM2=2.3,AM3=35.0,AH1=1.4,AH2=-0.01 & - & ,AH3=1.29,AH4=2.44,AH5=19.8 & - & ,ARIMIN=0.127,BM1=2.88,BM2=16.0,BH1=3.6,BH2=16.0 & - & ,BH3=720.0,EPSKM=1.E-3 - REAL,PARAMETER :: CAPA=R_D/CP - REAL,PARAMETER :: RLIVWV=XLS/XLV,ELOCP=2.72E6/CP - REAL,PARAMETER :: EPS1=1.E-12,EPS2=0. - REAL,PARAMETER :: EPSL=0.32,EPSRU=1.E-7,EPSRS=1.E-7 & - & ,EPSTRB=1.E-24 - REAL,PARAMETER :: EPSA=1.E-8,EPSIT=1.E-4,EPSU2=1.E-4,EPSUST=0.07 - REAL,PARAMETER :: ALPH=0.30,BETA=1./273.,EL0MAX=1000.,EL0MIN=1. & - & ,ELFC=0.23*0.5,GAM1=0.2222222222222222222 & - & ,PRT=1. - REAL,PARAMETER :: A1=0.659888514560862645 & - & ,A2X=0.6574209922667784586 & - & ,B1=11.87799326209552761 & - & ,B2=7.226971804046074028 & - & ,C1=0.000830955950095854396 - REAL,PARAMETER :: A2S=17.2693882,A3S=273.16,A4S=35.86 - REAL,PARAMETER :: ELZ0=0.,ESQ=5.0,EXCM=0.001 & - & ,FHNEU=0.8,GLKBR=10.,GLKBS=30. & - & ,QVISC=2.1E-5,RFC=0.191,RIC=0.505,SMALL=0.35 & - & ,SQPR=0.84,SQSC=0.84,SQVISC=258.2,TVISC=2.1E-5 & - & ,USTC=0.7,USTR=0.225,VISC=1.5E-5 & - & ,WOLD=0.15,WWST=1.2,ZTMAX=1.,ZTFC=1.,ZTMIN=-5. -! - REAL,PARAMETER :: SEAFC=0.98,PQ0SEA=PQ0*SEAFC -! - REAL,PARAMETER :: BTG=BETA*G,CZIV=SMALL*GLKBS & - & ,ESQHF=0.5*5.0,GRRS=GLKBR/GLKBS & - & ,RB1=1./B1,RTVISC=1./TVISC,RVISC=1./VISC & - & ,ZQRZT=SQSC/SQPR -! - REAL,PARAMETER :: ADNH= 9.*A1*A2X*A2X*(12.*A1+3.*B2)*BTG*BTG & - & ,ADNM=18.*A1*A1*A2X*(B2-3.*A2X)*BTG & - & ,ANMH=-9.*A1*A2X*A2X*BTG*BTG & - & ,ANMM=-3.*A1*A2X*(3.*A2X+3.*B2*C1+18.*A1*C1-B2) & - & *BTG & - & ,BDNH= 3.*A2X*(7.*A1+B2)*BTG & - & ,BDNM= 6.*A1*A1 & - & ,BEQH= A2X*B1*BTG+3.*A2X*(7.*A1+B2)*BTG & - & ,BEQM=-A1*B1*(1.-3.*C1)+6.*A1*A1 & - & ,BNMH=-A2X*BTG & - & ,BNMM=A1*(1.-3.*C1) & - & ,BSHH=9.*A1*A2X*A2X*BTG & - & ,BSHM=18.*A1*A1*A2X*C1 & - & ,BSMH=-3.*A1*A2X*(3.*A2X+3.*B2*C1+12.*A1*C1-B2) & - & *BTG & - & ,CESH=A2X & - & ,CESM=A1*(1.-3.*C1) & - & ,CNV=EP_1*G/BTG & - & ,ELFCS=VKARMAN*BTG & - & ,FZQ1=RTVISC*QVISC*ZQRZT & - & ,FZQ2=RTVISC*QVISC*ZQRZT & - & ,FZT1=RVISC *TVISC*SQPR & - & ,FZT2=CZIV*GRRS*TVISC*SQPR & - & ,FZU1=CZIV*VISC & - & ,PIHF=0.5*PI & - & ,RFAC=RIC/(FHNEU*RFC*RFC) & - & ,RQVISC=1./QVISC & - & ,RRIC=1./RIC & - & ,USTFC=0.018/G & - & ,WNEW=1.-WOLD & - & ,WWST2=WWST*WWST -! -!----------------------------------------------------------------------- -!*** FREE TERM IN THE EQUILIBRIUM EQUATION FOR (L/Q)**2 -!----------------------------------------------------------------------- -! - REAL,PARAMETER :: AEQH=9.*A1*A2X*A2X*B1*BTG*BTG & - & +9.*A1*A2X*A2X*(12.*A1+3.*B2)*BTG*BTG & - & ,AEQM=3.*A1*A2X*B1*(3.*A2X+3.*B2*C1+18.*A1*C1-B2)& - & *BTG+18.*A1*A1*A2X*(B2-3.*A2X)*BTG -! -!----------------------------------------------------------------------- -!*** FORBIDDEN TURBULENCE AREA -!----------------------------------------------------------------------- -! - REAL,PARAMETER :: REQU=-AEQH/AEQM & - & ,EPSGH=1.E-9,EPSGM=REQU*EPSGH -! -!----------------------------------------------------------------------- -!*** NEAR ISOTROPY FOR SHEAR TURBULENCE, WW/Q2 LOWER LIMIT -!----------------------------------------------------------------------- -! - REAL,PARAMETER :: UBRYL=(18.*REQU*A1*A1*A2X*B2*C1*BTG & - & +9.*A1*A2X*A2X*B2*BTG*BTG) & - & /(REQU*ADNM+ADNH) & - & ,UBRY=(1.+EPSRS)*UBRYL,UBRY3=3.*UBRY -! - REAL,PARAMETER :: AUBH=27.*A1*A2X*A2X*B2*BTG*BTG-ADNH*UBRY3 & - & ,AUBM=54.*A1*A1*A2X*B2*C1*BTG -ADNM*UBRY3 & - & ,BUBH=(9.*A1*A2X+3.*A2X*B2)*BTG-BDNH*UBRY3 & - & ,BUBM=18.*A1*A1*C1 -BDNM*UBRY3 & - & ,CUBR=1. - UBRY3 & - & ,RCUBR=1./CUBR -! -!----------------------------------------------------------------------- ! contains ! @@ -129,13 +17,13 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & dt,kpbl2d, & exch_h, & u10,v10, & - ctopo,ctopo2, & shinhong_tke_diag,tke_pbl,el_pbl,corf, & dx,dy, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & !optional + ctopo,ctopo2, & wstar,delta, & regime ) !------------------------------------------------------------------------------- @@ -152,7 +40,6 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & !-- p3d 3d pressure (pa) !-- p3di 3d pressure (pa) at interface level !-- pi3d 3d exner function (dimensionless) -!-- rr3d 3d dry air density (kg/m^3) !-- rublten u tendency due to ! pbl parameterization (m/s/s) !-- rvblten v tendency due to @@ -170,10 +57,17 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & !-- rovcp r/cp !-- rd gas constant for dry air (j/kg/k) !-- rovg r/g -!-- dz8w dz between full levels (m) +!-- ep1 constant for virtual temperature (r_v/r_d - 1) +!-- ep2 constant for specific humidity calculation +!-- karman von karman constant !-- xlv latent heat of vaporization (j/kg) !-- rv gas constant for water vapor (j/kg/k) +!-- dz8w dz between full levels (m) !-- psfc pressure at the surface (pa) +!-- znu eta values on half (mass) levels +!-- znw eta values on full (w) levels +!-- mut mass in column (pa) +!-- p_top pressure top of the model (pa) !-- znt roughness length (m) !-- ust u* in similarity theory (m/s) !-- hpbl pbl height (m) @@ -183,14 +77,10 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & !-- hfx upward heat flux at the surface (w/m^2) !-- qfx upward moisture flux at the surface (kg/m^2/s) !-- wspd wind speed at lowest model level (m/s) +!-- br bulk richardson number in surface layer !-- u10 u-wind speed at 10 m (m/s) !-- v10 v-wind speed at 10 m (m/s) -!-- br bulk richardson number in surface layer !-- dt time step (s) -!-- rvovrd r_v divided by r_d (dimensionless) -!-- ep1 constant for virtual temperature (r_v/r_d - 1) -!-- ep2 constant for specific humidity calculation -!-- karman von karman constant !-- ids start index for i in domain !-- ide end index for i in domain !-- jds start index for j in domain @@ -217,13 +107,18 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - integer, intent(in) :: shinhong_tke_diag + integer, intent(in ) :: shinhong_tke_diag ! real, intent(in ) :: dt,cp,g,rovcp,rovg,rd,xlv,rv + real, intent(in ) :: ep1,ep2,karman + real, intent(in ) :: dx,dy ! - real, intent(in ) :: ep1,ep2,karman - real, intent(in ) :: dx,dy + integer, dimension( ims:ime, jms:jme ) , & + intent(out ) :: kpbl2d ! + real, dimension( ims:ime, kms:kme, jms:jme ) , & + intent(in ) :: u3d, & + v3d real, dimension( ims:ime, kms:kme, jms:jme ) , & intent(in ) :: qv3d, & qc3d, & @@ -242,16 +137,11 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & rthblten, & rqvblten, & rqcblten -! real, dimension( ims:ime, kms:kme, jms:jme ) , & intent(inout) :: exch_h -! real, dimension( ims:ime, kms:kme, jms:jme ) , & intent(inout) :: tke_pbl, & el_pbl - real, dimension( ims:ime, jms:jme ) , & - intent(inout) :: u10, & - v10 ! real, dimension( ims:ime, jms:jme ) , & intent(in ) :: xland, & @@ -264,57 +154,49 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & intent(in ) :: & psim, & psih +! + real, dimension( ims:ime, jms:jme ) , & + intent(inout) :: u10, & + v10 real, dimension( ims:ime, jms:jme ) , & intent(inout) :: znt, & ust, & hpbl, & wspd ! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - intent(in ) :: u3d, & - v3d -! - integer, dimension( ims:ime, jms:jme ) , & - intent(out ) :: kpbl2d logical, intent(in) :: flag_qi ! -!optional +! optional +! + real, dimension( ims:ime, kms:kme, jms:jme ) , & + intent(inout), optional :: rqiblten ! real, dimension( ims:ime, jms:jme ) , & - intent(inout), optional :: wstar + intent(inout), optional :: wstar, & + delta real, dimension( ims:ime, jms:jme ) , & - intent(inout), optional :: delta + intent(inout), optional :: regime ! real, dimension( ims:ime, jms:jme ) , & - optional , & - intent(inout) :: regime -! - real, dimension( ims:ime, kms:kme, jms:jme ) , & - optional , & - intent(inout) :: rqiblten + intent(in ), optional :: mut + real, dimension( ims:ime, jms:jme ) , & + intent(in ), optional :: ctopo, & + ctopo2 ! real, dimension( kms:kme ) , & - optional , & - intent(in ) :: znu, & + intent(in ), optional :: znu, & znw ! - real, dimension( ims:ime, jms:jme ) , & - optional , & - intent(in ) :: mut + real, optional, intent(in ) :: p_top ! - real, optional, intent(in ) :: p_top +! local ! - real, dimension( ims:ime, jms:jme ) , & - optional , & - intent(in ) :: ctopo, & - ctopo2 -!local integer :: i,j,k real, dimension( its:ite, kts:kte*ndiff ) :: rqvbl2dt, & qv2d - real, dimension( its:ite, kts:kte ) :: pdh - real, dimension( its:ite, kts:kte+1 ) :: pdhi - real, dimension( its:ite ) :: & + real, dimension( its:ite, kts:kte ) :: pdh + real, dimension( its:ite, kts:kte+1 ) :: pdhi + real, dimension( its:ite ) :: & dusfc, & dvsfc, & dtsfc, & @@ -393,9 +275,9 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d, & enddo ! end subroutine shinhong -! !------------------------------------------------------------------------------- ! +!------------------------------------------------------------------------------- subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & utnp,vtnp,ttnp,qtnp,ndiff, & cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv, & @@ -416,16 +298,20 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & its,ite, jts,jte, kts,kte, & !optional regime ) -!------------------------------------------------------------------------------- -! use module_shinhong_tke, only: mixlen, prodq2, vdifq, epsq2l !------------------------------------------------------------------------------- implicit none !------------------------------------------------------------------------------- ! -! the shinhongpbl (shin and hong 2015) is based on the study of shin -! and hong (2013). the major ingredient of the shinhongpbl is the -! inclusion of scale dependency for vertical transport in convective pbl -! so the shinhongpbl works at gray zone resolution of convective pbl. +! the shinhongpbl (shin and hong 2015) is based on the les study of shin +! and hong (2013). the major ingredients of the shinhongpbl are +! 1) the prescribed nonlocal heat transport profile fit to the les and +! 2) inclusion of explicit scale dependency functions for vertical +! transport in convective pbl. +! so, the shinhongpbl works at the gray zone resolution of convective pbl. +! note that honnert et al. (2011) first suggested explicit scale dependency +! function, and shin and hong (2013) further classified the function by +! stability (u*/w*) in convective pbl and calculated the function for +! nonlocal and local transport separately. ! vertical mixing in the stable boundary layer and free atmosphere follows ! hong (2010) and hong et al. (2006), same as the ysupbl scheme. ! @@ -439,15 +325,16 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! summer 2002 ! ! references: -! ! shin and hong (2015) mon. wea. rev. ! shin and hong (2013) j. atmos. sci. +! honnert, masson, and couvreux (2011) j. atmos. sci. ! hong (2010) quart. j. roy. met. soc ! hong, noh, and dudhia (2006), mon. wea. rev. ! !------------------------------------------------------------------------------- ! - real,parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. + real,parameter :: xkzminm = 0.1,xkzminh = 0.01 + real,parameter :: xkzmax = 1000.,rimin = -100. real,parameter :: rlam = 30.,prmin = 0.25,prmax = 4. real,parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 real,parameter :: afac = 6.8,bfac = 6.8,pfac = 2.0,pfac_q = 2.0 @@ -459,8 +346,13 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & real,parameter :: gamcrt = 3.,gamcrq = 2.e-3 real,parameter :: xka = 2.4e-5 integer,parameter :: imvdif = 1 - real,parameter :: c_1=1.0, gamcre = 0.224 -! tunable parameters +! +! tunable parameters for tke +! + real,parameter :: epsq2l = 0.01,c_1 = 1.0,gamcre = 0.224 +! +! tunable parameters for prescribed nonlocal transport profile +! real,parameter :: mltop = 1.0,sfcfracn1 = 0.075 real,parameter :: nlfrac = 0.7,enlfrac = -0.4 real,parameter :: a11 = 1.0,a12 = -1.15 @@ -472,64 +364,65 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & j,ndiff - integer, intent(in) :: shinhong_tke_diag + integer, intent(in ) :: shinhong_tke_diag ! real, intent(in ) :: dt,rcl,cp,g,rovcp,rovg,rd,xlv,rv + real, intent(in ) :: ep1,ep2,karman + real, intent(in ) :: dx,dy ! - real, intent(in ) :: ep1,ep2,karman + integer, dimension( ims:ime ) , & + intent(out ) :: kpbl1d ! - real, intent(in ) :: dx,dy -! - real, dimension( ims:ime, kms:kme ), & - intent(in) :: dz8w2d, & + real, dimension( ims:ime, kms:kme ) , & + intent(in ) :: dz8w2d, & pi2d -! + real, dimension( ims:ime, kms:kme ) , & + intent(in ) :: ux, & + vx real, dimension( ims:ime, kms:kme ) , & intent(in ) :: tx - real, dimension( its:ite, kts:kte*ndiff ) , & - intent(in ) :: qx ! - real, dimension( ims:ime, kms:kme ) , & - intent(inout) :: utnp, & - vtnp, & - ttnp real, dimension( its:ite, kts:kte*ndiff ) , & - intent(inout) :: qtnp -! + intent(in ) :: qx real, dimension( its:ite, kts:kte+1 ) , & intent(in ) :: p2di -! real, dimension( its:ite, kts:kte ) , & intent(in ) :: p2d ! -! + real, dimension( ims:ime, kms:kme ) , & + intent(inout) :: utnp, & + vtnp, & + ttnp + real, dimension( ims:ime, kms:kme ) , & + intent(inout) :: exch_hx real, dimension( ims:ime, kms:kme ) , & intent(inout) :: tke, & el_pbl + real, dimension( its:ite, kts:kte*ndiff ) , & + intent(inout) :: qtnp ! - real, dimension( ims:ime ) , & - intent(inout) :: ust, & - hpbl, & - znt real, dimension( ims:ime ) , & intent(in ) :: xland, & hfx, & qfx + real, dimension( ims:ime ) , & + intent(in ) :: br, & + psim, & + psih, & + psfcpa + real, dimension( ims:ime ) , & + intent(in ) :: corf ! - real, dimension( ims:ime ), intent(inout) :: wspd - real, dimension( ims:ime ), intent(in ) :: br - real, dimension( ims:ime ), intent(in ) :: corf -! - real, dimension( ims:ime ), intent(in ) :: psim, & - psih -! - real, dimension( ims:ime ), intent(in ) :: psfcpa - integer, dimension( ims:ime ), intent(out ) :: kpbl1d + real, dimension( ims:ime ) , & + intent(inout) :: ust, & + hpbl, & + znt + real, dimension( ims:ime ) , & + intent(inout) :: wspd + real, dimension( ims:ime ) , & + intent(inout) :: u10, & + v10 ! - real, dimension( ims:ime, kms:kme ) , & - intent(in ) :: ux, & - vx - real, dimension( ims:ime ) , & optional , & intent(in ) :: ctopo, & @@ -543,26 +436,33 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! ! local vars ! - real, dimension( its:ite ) :: hol - real, dimension( its:ite, kts:kte+1 ) :: zq + integer :: n,i,k,l,ic,is,nwmass + integer :: klpbl, kqc, kqi + integer :: lmh,lmxl ! + real :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 + real :: ss,ri,qmean,tmean,alpha,chi,zk,rl2,dk,sri + real :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz + real :: utend,vtend,ttend,qtend + real :: dtstep,govrthv + real :: cont, conq, conw, conwrc + real :: delxy,pu1,pth1,pq1 + real :: dex,hgame_c + real :: zfacdx + real :: amf1,amf2,bmf2,amf3,bmf3,amf4,bmf4,sflux0,snlflux0 + real :: mlfrac,ezfrac,sfcfracn + real :: uwst,uwstx,csfac + real :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & + dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & + prfac,prfac2,phim8z +! + integer, dimension( its:ite ) :: kpbl + real, dimension( its:ite ) :: hol real, dimension( its:ite ) :: deltaoh - real, dimension( its:ite, kts:kte ) :: mf, & - zfacmf, & - entfacmf real, dimension( its:ite ) :: rigs, & enlfrac2, & cslen -! - real, dimension( its:ite, kts:kte ) :: & - thx,thvx, & - del, & - dza, & - dzq, & - xkzo, & - za -! - real, dimension( its:ite ) :: & + real, dimension( its:ite ) :: & rhox, & govrth, & zl1,thermal, & @@ -574,8 +474,27 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & dtsfc,dqsfc, & prpbl, & wspd1 + real, dimension( its:ite ) :: & + ust3, & + wstar3, & + hgamu,hgamv, & + wm2, we, & + bfxpbl, & + hfxpbl,qfxpbl, & + ufxpbl,vfxpbl, & + dthvx + real, dimension( its:ite ) :: & + brcr, & + sflux, & + zol1, & + brcr_sbro + real, dimension( its:ite ) :: & + efxpbl, & + hpbl_cbl, & + epshol, & + ct ! - real, dimension( its:ite, kts:kte ) :: xkzm,xkzh, & + real, dimension( its:ite, kts:kte ) :: xkzm,xkzh, & f1,f2, & r1,r2, & ad,au, & @@ -583,86 +502,52 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & al, & xkzq, & zfac -! -!jdf added exch_hx -! - real, dimension( ims:ime, kms:kme ) , & - intent(inout) :: exch_hx -! - real, dimension( ims:ime ) , & - intent(inout) :: u10, & - v10 - real, dimension( its:ite ) :: & - brcr, & - sflux, & - zol1, & - brcr_sbro -! - real, dimension( its:ite, kts:kte, ndiff) :: r3,f3 - integer, dimension( its:ite ) :: kpbl -! - logical, dimension( its:ite ) :: pblflg, & - sfcflg, & - stable - logical, dimension( ndiff ) :: ifvmix -! - integer :: n,i,k,l,ic,is,nwmass - integer :: klpbl, kqc, kqi -! - real :: dt2,rdt,spdk2,fm,fh,hol1,gamfac,vpert,prnum,prnum0 - real :: ss,ri,qmean,tmean,alpha,chi,zk,rl2,dk,sri - real :: brint,dtodsd,dtodsu,rdz,dsdzt,dsdzq,dsdz2,rlamdz - real :: utend,vtend,ttend,qtend - real :: dtstep,govrthv - real :: cont, conq, conw, conwrc - real :: delxy,pu1,pth1,pq1 - real :: zfacdx - real :: amf1,amf2,bmf2,amf3,bmf3,amf4,bmf4,sflux0,snlflux0 - real :: mlfrac,ezfrac,sfcfracn - real :: uwst,uwstx,csfac -! - real, dimension( its:ite, kts:kte ) :: wscalek - real, dimension( its:ite, kts:kte ) :: xkzml,xkzhl, & + real, dimension( its:ite, kts:kte ) :: & + thx,thvx, & + del, & + dza, & + dzq, & + xkzom, & + xkzoh, & + za + real, dimension( its:ite, kts:kte ) :: & + wscalek + real, dimension( its:ite, kts:kte ) :: & + xkzml,xkzhl, & zfacent,entfac - real, dimension( its:ite ) :: ust3, & - wstar3, & - hgamu,hgamv, & - wm2, we, & - bfxpbl, & - hfxpbl,qfxpbl, & - ufxpbl,vfxpbl, & - dthvx - real :: prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx, & - dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr, & - prfac,prfac2,phim8z -! - integer :: lmh,lmxl - real :: dex,hgame_c -! - real, dimension( its:ite, kts:kte ) :: q2x, & + real, dimension( its:ite, kts:kte ) :: & + mf, & + zfacmf, & + entfacmf + real, dimension( its:ite, kts:kte ) :: & + q2x, & hgame2d, & - tflux_e -! - real, dimension( kts+1:kte ) :: s2,gh,rig,el, & - akmk,akhk, & - zfacentk -! - real, dimension( kts:kte+1 ) :: zqk -! - real, dimension( kts:kte*ndiff ) :: qxk + tflux_e, & + qflux_e, & + tvflux_e + real, dimension( its:ite, kts:kte+1 ) :: zq + real, dimension( its:ite, kts:kte, ndiff ) :: r3,f3 ! - real, dimension( kts:kte ) :: uxk,vxk, & + real, dimension( kts:kte ) :: & + uxk,vxk, & txk,thxk,thvxk, & q2xk, & hgame + real, dimension( kts:kte ) :: & + ps1d,pb1d,eps1d,pt1d, & + xkze1d,eflx_l1d,eflx_nl1d, & + ptke1 + real, dimension( kts+1:kte ) :: & + s2,gh,rig,el, & + akmk,akhk, & + mfk,ufxpblk,vfxpblk,qfxpblk + real, dimension( kts:kte+1 ) :: zqk + real, dimension( kts:kte*ndiff ) :: qxk ! - real, dimension( kts:kte ) :: ps1d,pb1d,eps1d,pt1d, & - xkze1d,eflx_l1d,eflx_nl1d -! - real, dimension( its:ite ) :: efxpbl, & - hpbl_cbl, & - epshol, & - ct + logical, dimension( its:ite ) :: pblflg, & + sfcflg, & + stable + logical, dimension( ndiff ) :: ifvmix ! !------------------------------------------------------------------------------- ! @@ -764,6 +649,20 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & hgamv(i) = 0.0 delta(i) = 0.0 enddo +! + do i = its,ite + efxpbl(i) = 0.0 + hpbl_cbl(i) = 0.0 + epshol(i) = 0.0 + ct(i) = 0.0 + enddo +! + do i = its,ite + deltaoh(i) = 0.0 + rigs(i) = 0.0 + enlfrac2(i) = 0.0 + cslen(i) = 0.0 + enddo ! do k = kts,klpbl do i = its,ite @@ -776,45 +675,34 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & zfac(i,k) = 0.0 enddo enddo -! - do i = its,ite - efxpbl(i) = 0.0 - hpbl_cbl(i) = 0.0 - epshol(i) = 0.0 - ct(i) = 0.0 - enddo ! do k = kts,kte do i = its,ite - el_pbl(i,k) = 0.0 - hgame2d(i,k) = 0.0 - tflux_e(i,k) = 0.0 + q2x(i,k) = 2.*tke(i,k) enddo enddo ! do k = kts,kte do i = its,ite - q2x(i,k) = 2.*tke(i,k) + el_pbl(i,k) = 0.0 + hgame2d(i,k) = 0.0 + tflux_e(i,k) = 0.0 + qflux_e(i,k) = 0.0 + tvflux_e(i,k) = 0.0 enddo enddo -! - do i = its,ite - deltaoh(i) = 0.0 - rigs(i) = 0.0 - enlfrac2(i) = 0.0 - cslen(i) = 0.0 - enddo ! do k = kts,kte do i = its,ite - mf(i,k) = 0.0 + mf(i,k) = 0.0 zfacmf(i,k) = 0.0 enddo enddo ! do k = kts,klpbl-1 do i = its,ite - xkzo(i,k) = ckz*dza(i,k+1) + xkzom(i,k) = xkzminm + xkzoh(i,k) = xkzminh enddo enddo ! @@ -1033,15 +921,17 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & endif enddo ! -! grid-size dependency for nonlocal momentum transport +! scale dependency for nonlocal momentum and moisture transport ! delxy=sqrt(dx*dy) ! do i = its,ite pu1=pu(delxy,cslen(i)) + pq1=pq(delxy,cslen(i)) if(pblflg(i)) then hgamu(i) = hgamu(i)*pu1 hgamv(i) = hgamv(i)*pu1 + hgamq(i) = hgamq(i)*pq1 endif enddo ! @@ -1061,11 +951,12 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & dqx = min(qx(i,k+1)-qx(i,k),0.0) we(i) = max(bfxpbl(i)/dthvx(i),-sqrt(wm2(i))) hfxpbl(i) = we(i)*dthx - qfxpbl(i) = we(i)*dqx + pq1=pq(delxy,cslen(i)) + qfxpbl(i) = we(i)*dqx*pq1 ! + pu1=pu(delxy,cslen(i)) dux = ux(i,k+1)-ux(i,k) dvx = vx(i,k+1)-vx(i,k) - pu1=pu(delxy,cslen(i)) if(dux.gt.tmin) then ufxpbl(i) = max(prpbl(i)*we(i)*dux*pu1,-ust(i)*ust(i)) elseif(dux.lt.-tmin) then @@ -1134,12 +1025,12 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) prnum = 1. + (prnum0-1.)*exp(prnumfac) xkzh(i,k) = xkzm(i,k)/prnum + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzq(i,k) = xkzq(i,k)+xkzoh(i,k) xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzm(i,k) = max(xkzm(i,k),xkzo(i,k)) xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzh(i,k) = max(xkzh(i,k),xkzo(i,k)) xkzq(i,k) = min(xkzq(i,k),xkzmax) - xkzq(i,k) = max(xkzq(i,k),xkzo(i,k)) endif enddo enddo @@ -1184,17 +1075,17 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & xkzm(i,k) = xkzh(i,k)*prnum endif ! + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzm(i,k) = max(xkzm(i,k),xkzo(i,k)) xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzh(i,k) = max(xkzh(i,k),xkzo(i,k)) xkzml(i,k) = xkzm(i,k) xkzhl(i,k) = xkzh(i,k) endif enddo enddo ! -! prescribe nonlocal transport below pbl +! prescribe nonlocal heat transport below pbl ! do i = its,ite deltaoh(i) = deltaoh(i)/hpbl(i) @@ -1202,7 +1093,6 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! delxy=sqrt(dx*dy) do i = its,ite -! mlfrac = mltop-deltaoh(i) ezfrac = mltop+deltaoh(i) zfacmf(i,1) = min(max((zq(i,2)/hpbl(i)),zfmin),1.) @@ -1264,8 +1154,8 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) + xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzh(i,k) = max(xkzh(i,k),xkzo(i,k)) f1(i,k+1) = thx(i,k+1)-300. else f1(i,k+1) = thx(i,k+1)-300. @@ -1275,7 +1165,7 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & au(i,k) = -dtodsd*dsdz2 al(i,k) = -dtodsu*dsdz2 ! -! grid-size dependency for local heat transport +! scale dependency for local heat transport ! zfacdx=0.2*hpbl(i)/zq(i,k+1) delxy=sqrt(dx*dy)*max(zfacdx,1.0) @@ -1315,23 +1205,6 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & endif enddo enddo -! - do k = kts,kte - do i = its,ite - if(pblflg(i).and.k.lt.kpbl(i)) then - hgame_c=c_1*0.2*2.5*(g/thvx(i,k))*wstar(i)/(0.25*(q2x(i,k+1)+q2x(i,k))) - hgame_c=min(hgame_c,gamcre) - if(k.eq.kte)then - hgame2d(i,k)=hgame_c*0.5*tflux_e(i,k)*hpbl(i) - hgame2d(i,k)=max(hgame2d(i,k),0.0) - else - hgame2d(i,k)=hgame_c*0.5*(tflux_e(i,k)+tflux_e(i,k+1))*hpbl(i) - hgame2d(i,k)=max(hgame2d(i,k),0.0) - endif - endif - enddo - enddo -! ! ! compute tridiagonal matrix elements for moisture, clouds, and gases ! @@ -1387,8 +1260,8 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) + xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) xkzq(i,k) = min(xkzq(i,k),xkzmax) - xkzq(i,k) = max(xkzq(i,k),xkzo(i,k)) f3(i,k+1,1) = qx(i,k+1) else f3(i,k+1,1) = qx(i,k+1) @@ -1397,6 +1270,16 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & dsdz2 = tem1*rdz au(i,k) = -dtodsd*dsdz2 al(i,k) = -dtodsu*dsdz2 +! +! scale dependency for local moisture transport +! + zfacdx=0.2*hpbl(i)/zq(i,k+1) + delxy=sqrt(dx*dy)*max(zfacdx,1.0) + pq1=pq(delxy,hpbl(i)) + if(pblflg(i).and.k.lt.kpbl(i)) then + au(i,k) = au(i,k)*pq1 + al(i,k) = al(i,k)*pq1 + endif ad(i,k) = ad(i,k)-au(i,k) ad(i,k+1) = 1.-al(i,k) ! exch_hx(i,k+1) = xkzh(i,k) @@ -1441,16 +1324,27 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & qtend = (f3(i,k,1)-qx(i,k))*rdt qtnp(i,k) = qtnp(i,k)+qtend dqsfc(i) = dqsfc(i)+qtend*conq*del(i,k) + if(k.eq.kte) then + qflux_e(i,k) = qtend*dz8w2d(i,k) + else + qflux_e(i,k) = qflux_e(i,k+1) + qtend*dz8w2d(i,k) + endif + tvflux_e(i,k) = tflux_e(i,k) + qflux_e(i,k)*ep1*thx(i,k) enddo enddo ! - delxy=sqrt(dx*dy) -! - do i = its,ite - pq1=pq(delxy,cslen(i)) - do k = kts,kte + do k = kts,kte + do i = its,ite if(pblflg(i).and.k.lt.kpbl(i)) then - qtnp(i,k) = qtnp(i,k)*pq1 + hgame_c=c_1*0.2*2.5*(g/thvx(i,k))*wstar(i)/(0.25*(q2x(i,k+1)+q2x(i,k))) + hgame_c=min(hgame_c,gamcre) + if(k.eq.kte)then + hgame2d(i,k)=hgame_c*0.5*tvflux_e(i,k)*hpbl(i) + hgame2d(i,k)=max(hgame2d(i,k),0.0) + else + hgame2d(i,k)=hgame_c*0.5*(tvflux_e(i,k)+tvflux_e(i,k+1))*hpbl(i) + hgame2d(i,k)=max(hgame2d(i,k),0.0) + endif endif enddo enddo @@ -1508,8 +1402,8 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then xkzm(i,k) = prpbl(i)*xkzh(i,k) xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) + xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzm(i,k) = max(xkzm(i,k),xkzo(i,k)) f1(i,k+1) = ux(i,k+1) f2(i,k+1) = vx(i,k+1) else @@ -1521,7 +1415,7 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & au(i,k) = -dtodsd*dsdz2 al(i,k) = -dtodsu*dsdz2 ! -! grid-size dependency for local momentum transport +! scale dependency for local momentum transport ! zfacdx=0.2*hpbl(i)/zq(i,k+1) delxy=sqrt(dx*dy)*max(zfacdx,1.0) @@ -1561,6 +1455,10 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & dvsfc(i) = dvsfc(i) + vtend*conwrc*del(i,k) enddo enddo +! + do i = its,ite + kpbl1d(i) = kpbl(i) + enddo ! ! paj: ctopo2=1 if topo_wind=0 (default) ! @@ -1569,12 +1467,11 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & v10(i) = ctopo2(i)*v10(i)+(1-ctopo2(i))*vx(i,1) enddo ! - if (shinhong_tke_diag.eq.1) then +!---- calculate sgs tke which is consistent with shinhongpbl algorithm ! -!---- calculate tke consistent with shinhongpbl algorithm + if (shinhong_tke_diag.eq.1) then ! tke_calculation: do i = its,ite -! do k = kts+1,kte s2(k) = 0.0 gh(k) = 0.0 @@ -1582,7 +1479,10 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & el(k) = 0.0 akmk(k) = 0.0 akhk(k) = 0.0 - zfacentk(k) = 0.0 + mfk(k) = 0.0 + ufxpblk(k) = 0.0 + vfxpblk(k) = 0.0 + qfxpblk(k) = 0.0 enddo ! do k = kts,kte @@ -1600,6 +1500,7 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & xkze1d(k) = 0.0 eflx_l1d(k) = 0.0 eflx_nl1d(k) = 0.0 + ptke1(k) = 1.0 enddo ! do k = kts,kte+1 @@ -1619,6 +1520,14 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & q2xk(k) = q2x(i,k) hgame(k) = hgame2d(i,k) enddo +! + do k = kts,kte-1 + if(pblflg(i).and.k.le.kpbl(i)) then + zfacdx = 0.2*hpbl(i)/za(i,k) + delxy = sqrt(dx*dy)*max(zfacdx,1.0) + ptke1(k+1) = ptke(delxy,hpbl(i)) + endif + enddo ! do k = kts,kte+1 zqk(k) = zq(i,k) @@ -1631,7 +1540,10 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & do k = kts+1,kte akmk(k) = xkzm(i,k-1) akhk(k) = xkzh(i,k-1) - zfacentk(k) = zfacent(i,k-1) + mfk(k) = mf(i,k-1)/xkzh(i,k-1) + ufxpblk(k) = ufxpbl(i)*zfacent(i,k-1)/xkzm(i,k-1) + vfxpblk(k) = vfxpbl(i)*zfacent(i,k-1)/xkzm(i,k-1) + qfxpblk(k) = qfxpbl(i)*zfacent(i,k-1)/xkzq(i,k-1) enddo ! if(pblflg(i)) then @@ -1639,6 +1551,8 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & dex = 0.25*(q2xk(k+2)-q2xk(k)) efxpbl(i) = we(i)*dex endif +! + delxy=sqrt(dx*dy) ! !---- find the mixing length ! @@ -1646,8 +1560,9 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ,q2xk,zqk,ust(i),corf(i),epshol(i) & ,s2,gh,rig,el & ,hpbl(i),kpbl(i),lmxl,ct(i) & - ,hgamu(i),hgamv(i),hgamt(i),pblflg(i) & - ,zfacentk,ufxpbl(i),vfxpbl(i),hfxpbl(i) & + ,hgamu(i),hgamv(i),hgamq(i),pblflg(i) & + ,mfk,ufxpblk,vfxpblk,qfxpblk & + ,ep1,karman,cp & ,ids,ide,jds,jde,kds,kde & ,ims,ime,jms,jme,kms,kme & ,its,ite,jts,jte,kts,kte ) @@ -1656,9 +1571,10 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! call prodq2(lmh,dt,ust(i),s2,rig,q2xk,el,zqk,akmk,akhk & ,uxk,vxk,thxk,thvxk & - ,hgamu(i),hgamv(i),hgamt(i) & + ,hgamu(i),hgamv(i),hgamq(i),delxy & ,hpbl(i),pblflg(i),kpbl(i) & - ,zfacentk,ufxpbl(i),vfxpbl(i),hfxpbl(i) & + ,mfk,ufxpblk,vfxpblk,qfxpblk & + ,ep1 & ,ids,ide,jds,jde,kds,kde & ,ims,ime,jms,jme,kms,kme & ,its,ite,jts,jte,kts,kte ) @@ -1667,7 +1583,7 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & !---- carry out the vertical diffusion of turbulent kinetic energy ! call vdifq(lmh,dt,q2xk,el,zqk & - ,akhk & + ,akhk,ptke1 & ,hgame,hpbl(i),pblflg(i),kpbl(i) & ,efxpbl(i) & ,ids,ide,jds,jde,kds,kde & @@ -1685,12 +1601,10 @@ subroutine shinhong2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & enddo tke_calculation endif ! -!---- end of vertical diffusion +!---- end of tke calculation ! - do i = its,ite - kpbl1d(i) = kpbl(i) - enddo ! +!---- end of vertical diffusion ! end subroutine shinhong2d !------------------------------------------------------------------------------- @@ -1852,6 +1766,465 @@ subroutine tridin_ysu(cl,cm,cu,r2,au,f2,its,ite,kts,kte,nt) end subroutine tridin_ysu !------------------------------------------------------------------------------- ! +!------------------------------------------------------------------------------- + subroutine mixlen(lmh,u,v,t,the,q,cwm,q2,z,ustar,corf,epshol, & + s2,gh,ri,el,hpbl,lpbl,lmxl,ct, & + hgamu,hgamv,hgamq,pblflg, & + mf,ufxpbl,vfxpbl,qfxpbl, & + p608,vkarman,cp, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! qnse model constants +!------------------------------------------------------------------------------- + real,parameter :: blckdr=0.0063,cn=0.75 + real,parameter :: eps1=1.e-12,epsl=0.32,epsru=1.e-7,epsrs=1.e-7 + real,parameter :: el0max=1000.,el0min=1.,elfc=0.23*0.5 + real,parameter :: alph=0.30,beta=1./273.,g=9.81,btg=beta*g + real,parameter :: a1=0.659888514560862645,a2x=0.6574209922667784586 + real,parameter :: b1=11.87799326209552761,b2=7.226971804046074028 + real,parameter :: c1=0.000830955950095854396 + real,parameter :: adnh= 9.*a1*a2x*a2x*(12.*a1+3.*b2)*btg*btg + real,parameter :: adnm=18.*a1*a1*a2x*(b2-3.*a2x)*btg + real,parameter :: bdnh= 3.*a2x*(7.*a1+b2)*btg,bdnm= 6.*a1*a1 +!------------------------------------------------------------------------------- +! free term in the equilibrium equation for (l/q)**2 +!------------------------------------------------------------------------------- + real,parameter :: aeqh=9.*a1*a2x*a2x*b1*btg*btg & + +9.*a1*a2x*a2x*(12.*a1+3.*b2)*btg*btg + real,parameter :: aeqm=3.*a1*a2x*b1*(3.*a2x+3.*b2*c1+18.*a1*c1-b2) & + *btg+18.*a1*a1*a2x*(b2-3.*a2x)*btg +!------------------------------------------------------------------------------- +! forbidden turbulence area +!------------------------------------------------------------------------------- + real,parameter :: requ=-aeqh/aeqm + real,parameter :: epsgh=1.e-9,epsgm=requ*epsgh +!------------------------------------------------------------------------------- +! near isotropy for shear turbulence, ww/q2 lower limit +!------------------------------------------------------------------------------- + real,parameter :: ubryl=(18.*requ*a1*a1*a2x*b2*c1*btg & + +9.*a1*a2x*a2x*b2*btg*btg) & + /(requ*adnm+adnh) + real,parameter :: ubry=(1.+epsrs)*ubryl,ubry3=3.*ubry + real,parameter :: aubh=27.*a1*a2x*a2x*b2*btg*btg-adnh*ubry3 + real,parameter :: aubm=54.*a1*a1*a2x*b2*c1*btg -adnm*ubry3 + real,parameter :: bubh=(9.*a1*a2x+3.*a2x*b2)*btg-bdnh*ubry3 + real,parameter :: bubm=18.*a1*a1*c1 -bdnm*ubry3 + real,parameter :: cubr=1.-ubry3,rcubr=1./cubr +!------------------------------------------------------------------------------- +! k profile constants +!------------------------------------------------------------------------------- + real,parameter :: elcbl=0.77 +!------------------------------------------------------------------------------- +! + integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + integer, intent(in ) :: lmh,lmxl,lpbl +! + real, intent(in ) :: p608,vkarman,cp + real, intent(in ) :: hpbl,corf,ustar,hgamu,hgamv,hgamq + real, intent(inout) :: ct,epshol +! + real, dimension( kts:kte ) , & + intent(in ) :: cwm, & + q, & + q2, & + t, & + the, & + u, & + v +! + real, dimension( kts+1:kte ) , & + intent(in ) :: mf, & + ufxpbl, & + vfxpbl, & + qfxpbl +! + real, dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real, dimension( kts+1:kte ) , & + intent(out ) :: el, & + ri, & + gh, & + s2 +! + logical,intent(in) :: pblflg +! +! local vars +! + integer :: k,lpblm + real :: suk,svk,elocp + real :: a,aden,b,bden,aubr,bubr,blmx,el0,eloq2x,ghl,s2l, & + qol2st,qol2un,qdzl,rdz,sq,srel,szq,tem,thm,vkrmz,rlambda, & + rlb,rln,f + real :: ckp + real, dimension( kts:kte ) :: q1, & + en2 + real, dimension( kts+1:kte ) :: dth, & + elm, & + rel +! +!------------------------------------------------------------------------------- +! + elocp=2.72e6/cp + ct=0. +! + do k = kts,kte + q1(k) = 0. + enddo +! + do k = kts+1,kte + dth(k) = the(k)-the(k-1) + enddo +! + do k = kts+2,kte + if(dth(k)>0..and.dth(k-1)<=0.)then + dth(k)=dth(k)+ct + exit + endif + enddo +! +! compute local gradient richardson number +! + do k = kte,kts+1,-1 + rdz=2./(z(k+1)-z(k-1)) + s2l=((u(k)-u(k-1))**2+(v(k)-v(k-1))**2)*rdz*rdz ! s**2 + if(pblflg.and.k.le.lpbl)then + suk=(u(k)-u(k-1))*rdz + svk=(v(k)-v(k-1))*rdz + s2l=(suk-hgamu/hpbl-ufxpbl(k))*suk+(svk-hgamv/hpbl-vfxpbl(k))*svk + endif + s2l=max(s2l,epsgm) + s2(k)=s2l +! + tem=(t(k)+t(k-1))*0.5 + thm=(the(k)+the(k-1))*0.5 + a=thm*p608 + b=(elocp/tem-1.-p608)*thm + ghl=(dth(k)*((q(k)+q(k-1)+cwm(k)+cwm(k-1))*(0.5*p608)+1.) & + +(q(k)-q(k-1)+cwm(k)-cwm(k-1))*a & + +(cwm(k)-cwm(k-1))*b)*rdz ! dtheta/dz + if(pblflg.and.k.le.lpbl)then + ghl=ghl-mf(k)-(hgamq/hpbl+qfxpbl(k))*a + endif + if(abs(ghl)<=epsgh)ghl=epsgh +! + en2(k)=ghl*g/thm ! n**2 + gh(k)=ghl + ri(k)=en2(k)/s2l + enddo +! +! find maximum mixing lengths and the level of the pbl top +! + do k = kte,kts+1,-1 + s2l=s2(k) + ghl=gh(k) + if(ghl>=epsgh)then + if(s2l/ghl<=requ)then + elm(k)=epsl + else + aubr=(aubm*s2l+aubh*ghl)*ghl + bubr= bubm*s2l+bubh*ghl + qol2st=(-0.5*bubr+sqrt(bubr*bubr*0.25-aubr*cubr))*rcubr + eloq2x=1./qol2st + elm(k)=max(sqrt(eloq2x*q2(k)),epsl) + endif + else + aden=(adnm*s2l+adnh*ghl)*ghl + bden= bdnm*s2l+bdnh*ghl + qol2un=-0.5*bden+sqrt(bden*bden*0.25-aden) + eloq2x=1./(qol2un+epsru) ! repsr1/qol2un + elm(k)=max(sqrt(eloq2x*q2(k)),epsl) + endif + enddo +! + do k = lpbl,lmh,-1 + q1(k)=sqrt(q2(k)) + enddo +! + szq=0. + sq =0. + do k = kte,kts+1,-1 + qdzl=(q1(k)+q1(k-1))*(z(k)-z(k-1)) + szq=(z(k)+z(k-1)-z(lmh)-z(lmh))*qdzl+szq + sq=qdzl+sq + enddo +! +! computation of asymptotic l in blackadar formula +! + el0=min(alph*szq*0.5/sq,el0max) + el0=max(el0 ,el0min) +! +! above the pbl top +! + lpblm=min(lpbl+1,kte) + do k = kte,lpblm,-1 + el(k)=(z(k+1)-z(k-1))*elfc + rel(k)=el(k)/elm(k) + enddo +! +! inside the pbl +! + epshol=min(epshol,0.0) + ckp=elcbl*((1.0-8.0*epshol)**(1./3.)) + if(lpbl>lmh)then + do k = lpbl,lmh+1,-1 + vkrmz=(z(k)-z(lmh))*vkarman + if(pblflg) then + vkrmz=ckp*(z(k)-z(lmh))*vkarman + el(k)=vkrmz/(vkrmz/el0+1.) + else + el(k)=vkrmz/(vkrmz/el0+1.) + endif + rel(k)=el(k)/elm(k) + enddo + endif +! + do k = lpbl-1,lmh+2,-1 + srel=min(((rel(k-1)+rel(k+1))*0.5+rel(k))*0.5,rel(k)) + el(k)=max(srel*elm(k),epsl) + enddo +! +! mixing length for the qnse model in stable case +! + f=max(corf,eps1) + rlambda=f/(blckdr*ustar) + do k = kte,kts+1,-1 + if(en2(k)>=0.0)then ! stable case + vkrmz=(z(k)-z(lmh))*vkarman + rlb=rlambda+1./vkrmz + rln=sqrt(2.*en2(k)/q2(k))/cn + el(k)=1./(rlb+rln) + endif + enddo +! + end subroutine mixlen +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine prodq2(lmh,dtturbl,ustar,s2,ri,q2,el,z,akm,akh, & + uxk,vxk,thxk,thvxk, & + hgamu,hgamv,hgamq,delxy, & + hpbl,pblflg,kpbl, & + mf,ufxpbl,vfxpbl,qfxpbl, & + p608, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + real,parameter :: epsq2l = 0.01,c0 = 0.55,ceps = 16.6,g = 9.81 +! + integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + integer, intent(in ) :: lmh,kpbl +! + real, intent(in ) :: p608,dtturbl,ustar + real, intent(in ) :: hgamu,hgamv,hgamq,delxy,hpbl +! + logical, intent(in ) :: pblflg +! + real, dimension( kts:kte ) , & + intent(in ) :: uxk, & + vxk, & + thxk, & + thvxk + real, dimension( kts+1:kte ) , & + intent(in ) :: s2, & + ri, & + akm, & + akh, & + el, & + mf, & + ufxpbl, & + vfxpbl, & + qfxpbl +! + real, dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real, dimension( kts:kte ) , & + intent(inout) :: q2 +! +! local vars +! + integer :: k +! + real :: s2l,q2l,deltaz,akml,akhl,en2,pr,bpr,dis,rc02 + real :: suk,svk,gthvk,govrthvk,pru,prv + real :: thm,disel +! +!------------------------------------------------------------------------------- +! + rc02=2.0/(c0*c0) +! +! start of production/dissipation loop +! + main_integration: do k = kts+1,kte + deltaz=0.5*(z(k+1)-z(k-1)) + s2l=s2(k) + q2l=q2(k) + suk=(uxk(k)-uxk(k-1))/deltaz + svk=(vxk(k)-vxk(k-1))/deltaz + gthvk=(thvxk(k)-thvxk(k-1))/deltaz + govrthvk=g/(0.5*(thvxk(k)+thvxk(k-1))) + akml=akm(k) + akhl=akh(k) + en2=ri(k)*s2l !n**2 + thm=(thxk(k)+thxk(k-1))*0.5 +! +! turbulence production term +! + if(pblflg.and.k.le.kpbl)then + pru=(akml*(suk-hgamu/hpbl-ufxpbl(k)))*suk + prv=(akml*(svk-hgamv/hpbl-vfxpbl(k)))*svk + else + pru=akml*suk*suk + prv=akml*svk*svk + endif + pr=pru+prv +! +! buoyancy production +! + if(pblflg.and.k.le.kpbl)then + bpr=(akhl*(gthvk-mf(k)-(hgamq/hpbl+qfxpbl(k))*p608*thm))*govrthvk + else + bpr=akhl*gthvk*govrthvk + endif +! +! dissipation +! + disel=min(delxy,ceps*el(k)) + dis=(q2l)**1.5/disel +! + q2l=q2l+2.0*(pr-bpr-dis)*dtturbl + q2(k)=amax1(q2l,epsq2l) +! +! end of production/dissipation loop +! + enddo main_integration +! +! lower boundary condition for q2 +! + q2(kts)=amax1(rc02*ustar*ustar,epsq2l) +! + end subroutine prodq2 +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + subroutine vdifq(lmh,dtdif,q2,el,z, & + akhk,ptke1, & + hgame,hpbl,pblflg,kpbl, & + efxpbl, & + ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- +! + real,parameter :: c_k=1.0,esq=5.0 +! + integer, intent(in ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + integer, intent(in ) :: lmh,kpbl +! + real, intent(in ) :: dtdif,hpbl,efxpbl +! + logical, intent(in ) :: pblflg +! + real, dimension( kts:kte ) , & + intent(in ) :: hgame, & + ptke1 + real, dimension( kts+1:kte ) , & + intent(in ) :: el, & + akhk + real, dimension( kts:kte+1 ) , & + intent(in ) :: z +! + real, dimension( kts:kte ) , & + intent(inout) :: q2 +! +! local vars +! + integer :: k +! + real :: aden,akqs,bden,besh,besm,cden,cf,dtozs,ell,eloq2,eloq4 + real :: elqdz,esh,esm,esqhf,ghl,gml,q1l,rden,rdz + real :: zak +! + real, dimension( kts+1:kte ) :: zfacentk + real, dimension( kts+2:kte ) :: akq, & + cm, & + cr, & + dtoz, & + rsq2 +! +!------------------------------------------------------------------------------- +! +! vertical turbulent diffusion +! + esqhf=0.5*esq + do k = kts+1,kte + zak=0.5*(z(k)+z(k-1)) !zak of vdifq = za(k-1) of shinhong2d + zfacentk(k)=(zak/hpbl)**3.0 + enddo +! + do k = kte,kts+2,-1 + dtoz(k)=(dtdif+dtdif)/(z(k+1)-z(k-1)) + akq(k)=c_k*(akhk(k)/(z(k+1)-z(k-1))+akhk(k-1)/(z(k)-z(k-2))) + akq(k)=akq(k)*ptke1(k) + cr(k)=-dtoz(k)*akq(k) + enddo +! + akqs=c_k*akhk(kts+1)/(z(kts+2)-z(kts)) + akqs=akqs*ptke1(kts+1) + cm(kte)=dtoz(kte)*akq(kte)+1. + rsq2(kte)=q2(kte) +! + do k = kte-1,kts+2,-1 + cf=-dtoz(k)*akq(k+1)/cm(k+1) + cm(k)=-cr(k+1)*cf+(akq(k+1)+akq(k))*dtoz(k)+1. + rsq2(k)=-rsq2(k+1)*cf+q2(k) + if(pblflg.and.k.lt.kpbl) then + rsq2(k)=rsq2(k)-dtoz(k)*(2.0*hgame(k)/hpbl)*akq(k+1)*(z(k+1)-z(k)) & + +dtoz(k)*(2.0*hgame(k-1)/hpbl)*akq(k)*(z(k)-z(k-1)) + rsq2(k)=rsq2(k)-dtoz(k)*2.0*efxpbl*zfacentk(k+1) & + +dtoz(k)*2.0*efxpbl*zfacentk(k) + endif + enddo +! + dtozs=(dtdif+dtdif)/(z(kts+2)-z(kts)) + cf=-dtozs*akq(lmh+2)/cm(lmh+2) +! + if(pblflg.and.((lmh+1).lt.kpbl)) then + q2(lmh+1)=(dtozs*akqs*q2(lmh)-rsq2(lmh+2)*cf+q2(lmh+1) & + -dtozs*(2.0*hgame(lmh+1)/hpbl)*akq(lmh+2)*(z(lmh+2)-z(lmh+1)) & + +dtozs*(2.0*hgame(lmh)/hpbl)*akqs*(z(lmh+1)-z(lmh))) + q2(lmh+1)=q2(lmh+1)-dtozs*2.0*efxpbl*zfacentk(lmh+2) & + +dtozs*2.0*efxpbl*zfacentk(lmh+1) + q2(lmh+1)=q2(lmh+1)/((akq(lmh+2)+akqs)*dtozs-cr(lmh+2)*cf+1.) + else + q2(lmh+1)=(dtozs*akqs*q2(lmh)-rsq2(lmh+2)*cf+q2(lmh+1)) & + /((akq(lmh+2)+akqs)*dtozs-cr(lmh+2)*cf+1.) + endif +! + do k = lmh+2,kte + q2(k)=(-cr(k)*q2(k-1)+rsq2(k))/cm(k) + enddo +! + end subroutine vdifq +!------------------------------------------------------------------------------- +! !------------------------------------------------------------------------------- subroutine shinhonginit(rublten,rvblten,rthblten,rqvblten, & rqcblten,rqiblten, & @@ -1866,7 +2239,7 @@ subroutine shinhonginit(rublten,rvblten,rthblten,rqvblten, & !------------------------------------------------------------------------------- ! real,parameter :: epsq2l = 0.01 - logical , intent(in) :: restart, allowed_to_read + logical , intent(in) :: restart, allowed_to_read integer , intent(in) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte @@ -2003,456 +2376,30 @@ function pthl(d,h) return end function !------------------------------------------------------------------------------- -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!---------------------------------------------------------------------- - SUBROUTINE MIXLEN & -!---------------------------------------------------------------------- -! ****************************************************************** -! * * -! * LEVEL 2.5 MIXING LENGTH * -! * * -! ****************************************************************** -! - &(LMH,U,V,T,THE,Q,CWM,Q2,Z,USTAR,CORF,EPSHOL & - &,S2,GH,RI,EL,PBLH,LPBL,LMXL,CT & - &,HGAMU,HGAMV,HGAMT,PBLFLG & - &,ZFACENTK,UFXPBL,VFXPBL,HFXPBL & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) -!---------------------------------------------------------------------- -! - IMPLICIT NONE -! -!---------------------------------------------------------------------- - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE -! - INTEGER,INTENT(IN) :: LMH -! - INTEGER,INTENT(IN) :: LMXL,LPBL -! - REAL,DIMENSION(KTS:KTE),INTENT(IN) :: CWM,Q,Q2,T,THE,U,V -! - REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z -! - REAL,INTENT(IN) :: PBLH -! - REAL,DIMENSION(KTS+1:KTE),INTENT(OUT) :: EL,RI,GH,S2 -! - REAL,INTENT(INOUT) :: CT -! - REAL,INTENT(IN) :: CORF,USTAR - REAL,INTENT(INOUT) :: EPSHOL -! - REAL,DIMENSION(KTS+1:KTE),INTENT(IN) :: ZFACENTK - REAL,INTENT(IN) :: HGAMU,HGAMV,HGAMT,UFXPBL,VFXPBL,HFXPBL - REAL :: SUK,SVK -! - LOGICAL,INTENT(IN) :: PBLFLG -!---------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** - INTEGER :: K,LPBLM -! - REAL :: A,ADEN,B,BDEN,AUBR,BUBR,BLMX,EL0,ELOQ2X,GHL,S2L & - & ,QOL2ST,QOL2UN,QDZL,RDZ,SQ,SREL,SZQ,TEM,THM,VKRMZ,RLAMBDA & - & ,RLB,RLN,F -! - REAL,DIMENSION(KTS:KTE) :: Q1,EN2 -! - REAL,DIMENSION(KTS+1:KTE) :: DTH,ELM,REL - REAL,PARAMETER :: ELCBL=0.77 - REAL :: CKP -!---------------------------------------------------------------------- -!********************************************************************** -!----------------------------------------------------------------------- - DO K=KTS,KTE - Q1(K)=0. - ENDDO -! - DO K=KTS+1,KTE - DTH(K)=THE(K)-THE(K-1) - ENDDO -! - DO K=KTS+2,KTE - IF(DTH(K)>0..AND.DTH(K-1)<=0.)THEN - DTH(K)=DTH(K)+CT - EXIT - ENDIF - ENDDO -! - CT=0. -!---------------------------------------------------------------------- -!*** COMPUTE LOCAL GRADIENT RICHARDSON NUMBER -!---------------------------------------------------------------------- - DO K=KTE,KTS+1,-1 - RDZ=2./(Z(K+1)-Z(K-1)) - S2L=((U(K)-U(K-1))**2+(V(K)-V(K-1))**2)*RDZ*RDZ ! S**2 - IF(PBLFLG.AND.K.LE.LPBL)THEN - SUK=(U(K)-U(K-1))*RDZ - SVK=(V(K)-V(K-1))*RDZ - S2L=(SUK-HGAMU/PBLH)*SUK+(SVK-HGAMV/PBLH)*SVK - ENDIF - S2L=MAX(S2L,EPSGM) - S2(K)=S2L -! - TEM=(T(K)+T(K-1))*0.5 - THM=(THE(K)+THE(K-1))*0.5 -! - A=THM*P608 - B=(ELOCP/TEM-1.-P608)*THM -! - GHL=(DTH(K)*((Q(K)+Q(K-1)+CWM(K)+CWM(K-1))*(0.5*P608)+1.) & - & +(Q(K)-Q(K-1)+CWM(K)-CWM(K-1))*A & - & +(CWM(K)-CWM(K-1))*B)*RDZ ! dTheta/dz - IF(PBLFLG.AND.K.LE.LPBL)THEN - GHL=GHL-HGAMT/PBLH - ENDIF -! - IF(ABS(GHL)<=EPSGH)GHL=EPSGH -! - EN2(K)=GHL*G/THM ! N**2 -! - GH(K)=GHL - RI(K)=EN2(K)/S2L - ENDDO -! -!---------------------------------------------------------------------- -!*** FIND MAXIMUM MIXING LENGTHS AND THE LEVEL OF THE PBL TOP -!---------------------------------------------------------------------- -! - DO K=KTE,KTS+1,-1 - S2L=S2(K) - GHL=GH(K) -! - IF(GHL>=EPSGH)THEN - IF(S2L/GHL<=REQU)THEN - ELM(K)=EPSL - ELSE - AUBR=(AUBM*S2L+AUBH*GHL)*GHL - BUBR= BUBM*S2L+BUBH*GHL - QOL2ST=(-0.5*BUBR+SQRT(BUBR*BUBR*0.25-AUBR*CUBR))*RCUBR - ELOQ2X=1./QOL2ST - ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL) - ENDIF - ELSE - ADEN=(ADNM*S2L+ADNH*GHL)*GHL - BDEN= BDNM*S2L+BDNH*GHL - QOL2UN=-0.5*BDEN+SQRT(BDEN*BDEN*0.25-ADEN) - ELOQ2X=1./(QOL2UN+EPSRU) ! repsr1/qol2un - ELM(K)=MAX(SQRT(ELOQ2X*Q2(K)),EPSL) - ENDIF - ENDDO -! -!---------------------------------------------------------------------- - DO K=LPBL,LMH,-1 - Q1(K)=SQRT(Q2(K)) - ENDDO -!---------------------------------------------------------------------- - SZQ=0. - SQ =0. -! - DO K=KTE,KTS+1,-1 - QDZL=(Q1(K)+Q1(K-1))*(Z(K)-Z(K-1)) - SZQ=(Z(K)+Z(K-1)-Z(LMH)-Z(LMH))*QDZL+SZQ - SQ=QDZL+SQ - ENDDO -! -!---------------------------------------------------------------------- -!*** COMPUTATION OF ASYMPTOTIC L IN BLACKADAR FORMULA -!---------------------------------------------------------------------- -! - EL0=MIN(ALPH*SZQ*0.5/SQ,EL0MAX) - EL0=MAX(EL0 ,EL0MIN) -! -!---------------------------------------------------------------------- -!*** ABOVE THE PBL TOP -!---------------------------------------------------------------------- -! - LPBLM=MIN(LPBL+1,KTE) -! - DO K=KTE,LPBLM,-1 - EL(K)=(Z(K+1)-Z(K-1))*ELFC - REL(K)=EL(K)/ELM(K) - ENDDO -! -!---------------------------------------------------------------------- -!*** INSIDE THE PBL -!---------------------------------------------------------------------- -! - EPSHOL=MIN(EPSHOL,0.0) - CKP=ELCBL*((1.0-8.0*EPSHOL)**(1./3.)) - IF(LPBL>LMH)THEN - DO K=LPBL,LMH+1,-1 - VKRMZ=(Z(K)-Z(LMH))*VKARMAN - IF(PBLFLG) THEN - VKRMZ=CKP*(Z(K)-Z(LMH))*VKARMAN - EL(K)=VKRMZ/(VKRMZ/EL0+1.) - ELSE - EL(K)=VKRMZ/(VKRMZ/EL0+1.) - ENDIF - REL(K)=EL(K)/ELM(K) - ENDDO - ENDIF -! - DO K=LPBL-1,LMH+2,-1 - SREL=MIN(((REL(K-1)+REL(K+1))*0.5+REL(K))*0.5,REL(K)) - EL(K)=MAX(SREL*ELM(K),EPSL) - ENDDO -! -!---------------------------------------------------------------------- -!*** MIXING LENGTH FOR THE QNSE MODEL IN STABLE CASE -!---------------------------------------------------------------------- -! - F=MAX(CORF,EPS1) - RLAMBDA=F/(BLCKDR*USTAR) - DO K=KTE,KTS+1,-1 - IF(EN2(K)>=0.0)THEN ! Stable case - VKRMZ=(Z(K)-Z(LMH))*VKARMAN - RLB=RLAMBDA+1./VKRMZ - RLN=SQRT(2.*EN2(K)/Q2(K))/CN -! EL(K)=MIN(1./(RLB+RLN),ELM(K)) - EL(K)=1./(RLB+RLN) - ENDIF - ENDDO -! -!---------------------------------------------------------------------- - END SUBROUTINE MIXLEN -!---------------------------------------------------------------------- -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!---------------------------------------------------------------------- - SUBROUTINE PRODQ2 & -!---------------------------------------------------------------------- -! ****************************************************************** -! * * -! * LEVEL 2.5 Q2 PRODUCTION/DISSIPATION * -! * * -! ****************************************************************** -! - &(LMH,DTTURBL,USTAR,S2,RI,Q2,EL,Z,AKM,AKH & - &,UXK,VXK,THXK,THVXK & - &,HGAMU,HGAMV,HGAMT & - &,HPBL,PBLFLG,KPBL & - &,ZFACENTK,UFXPBL,VFXPBL,HFXPBL & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) -!---------------------------------------------------------------------- -! - IMPLICIT NONE -! -!---------------------------------------------------------------------- - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE -! - INTEGER,INTENT(IN) :: LMH -! - REAL,INTENT(IN) :: DTTURBL,USTAR -! - REAL,DIMENSION(KTS+1:KTE),INTENT(IN) :: S2,RI,AKM,AKH,EL -! - REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z -! - REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2 -! - REAL,DIMENSION(KTS:KTE),INTENT(IN) :: UXK,VXK,THXK,THVXK - REAL,INTENT(IN) :: HGAMU,HGAMV,HGAMT,HPBL -! - INTEGER,INTENT(IN) :: KPBL - LOGICAL,INTENT(IN) :: PBLFLG -! - REAL,DIMENSION(KTS+1:KTE),INTENT(IN) :: ZFACENTK - REAL,INTENT(IN) :: UFXPBL,VFXPBL,HFXPBL -! -!---------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** - INTEGER :: K -! - REAL :: S2L,Q2L,DELTAZ,AKML,AKHL,EN2,PR,BPR,DIS,RC02 - REAL :: SUK,SVK,GTHVK,GOVRTHVK,PRU,PRV - REAL :: ZFACENTL -! -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- -! - RC02=2.0/(C0*C0) - main_integration: DO K=KTS+1,KTE - DELTAZ=0.5*(Z(K+1)-Z(K-1)) - S2L=S2(K) - Q2L=Q2(K) - SUK=(UXK(K)-UXK(K-1))/DELTAZ - SVK=(VXK(K)-VXK(K-1))/DELTAZ - GTHVK=(THVXK(K)-THVXK(K-1))/DELTAZ - GOVRTHVK=G/(0.5*(THVXK(K)+THVXK(K-1))) - AKML=AKM(K) - AKHL=AKH(K) - ZFACENTL=ZFACENTK(K) - EN2=RI(K)*S2L !N**2 -! -!*** TURBULENCE PRODUCTION TERM -! - IF(PBLFLG.AND.K.LE.KPBL)THEN - PRU=(AKML*(SUK-HGAMU/HPBL))*SUK - PRV=(AKML*(SVK-HGAMV/HPBL))*SVK - PRU=(AKML*(SUK-HGAMU/HPBL)-UFXPBL*ZFACENTL)*SUK - PRV=(AKML*(SVK-HGAMV/HPBL)-VFXPBL*ZFACENTL)*SVK - ELSE - PRU=AKML*SUK*SUK - PRV=AKML*SVK*SVK - ENDIF - PR=PRU+PRV -! -!*** BUOYANCY PRODUCTION -! - IF(PBLFLG.AND.K.LE.KPBL)THEN - BPR=(AKHL*(GTHVK-HGAMT/HPBL))*GOVRTHVK - BPR=(AKHL*(GTHVK-HGAMT/HPBL)-HFXPBL*ZFACENTL)*GOVRTHVK - ELSE - BPR=AKHL*GTHVK*GOVRTHVK - ENDIF -! -!*** DISSIPATION -! - DIS=CEPS*(0.5*Q2L)**1.5/EL(K) -! - Q2L=Q2L+2.0*(PR-BPR-DIS)*DTTURBL - Q2(K)=AMAX1(Q2L,EPSQ2L) -!---------------------------------------------------------------------- -!*** END OF PRODUCTION/DISSIPATION LOOP -!---------------------------------------------------------------------- -! - ENDDO main_integration -! -!---------------------------------------------------------------------- -!*** LOWER BOUNDARY CONDITION FOR Q2 -!---------------------------------------------------------------------- -! - Q2(KTS)=AMAX1(RC02*USTAR*USTAR,EPSQ2L) -!---------------------------------------------------------------------- -! - END SUBROUTINE PRODQ2 -! -!---------------------------------------------------------------------- -!XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX -!---------------------------------------------------------------------- - SUBROUTINE VDIFQ & -! ****************************************************************** -! * * -! * VERTICAL DIFFUSION OF Q2 (TKE) * -! * * -! ****************************************************************** - &(LMH,DTDIF,Q2,EL,Z & - &,AKHK & - &,HGAME,HPBL,PBLFLG,KPBL & - &,EFXPBL & - &,IDS,IDE,JDS,JDE,KDS,KDE & - &,IMS,IME,JMS,JME,KMS,KME & - &,ITS,ITE,JTS,JTE,KTS,KTE) -!---------------------------------------------------------------------- -! - IMPLICIT NONE -! -!---------------------------------------------------------------------- - INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & - & ,IMS,IME,JMS,JME,KMS,KME & - & ,ITS,ITE,JTS,JTE,KTS,KTE -! - INTEGER,INTENT(IN) :: LMH -! - REAL,INTENT(IN) :: DTDIF -! - REAL,DIMENSION(KTS+1:KTE),INTENT(IN) :: EL - REAL,DIMENSION(KTS+1:KTE),INTENT(IN) :: AKHK - REAL,DIMENSION(KTS:KTE+1),INTENT(IN) :: Z -! - REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: Q2 -! - REAL,DIMENSION(KTS:KTE),INTENT(IN) :: HGAME - REAL,INTENT(IN) :: HPBL - INTEGER,INTENT(IN) :: KPBL - LOGICAL,INTENT(IN) :: PBLFLG -! - REAL,INTENT(IN) :: EFXPBL -! -! -!---------------------------------------------------------------------- -!*** -!*** LOCAL VARIABLES -!*** - INTEGER :: K -! - REAL :: ADEN,AKQS,BDEN,BESH,BESM,CDEN,CF,DTOZS,ELL,ELOQ2,ELOQ4 & - & ,ELQDZ,ESH,ESM,ESQHF,GHL,GML,Q1L,RDEN,RDZ - REAL :: ZAK -! - REAL,DIMENSION(KTS+2:KTE) :: AKQ,CM,CR,DTOZ,RSQ2 - REAL,DIMENSION(KTS+1:KTE) :: ZFACENTK -! - REAL,PARAMETER :: C_K=1.0 -!---------------------------------------------------------------------- -!********************************************************************** -!---------------------------------------------------------------------- -!*** -!*** VERTICAL TURBULENT DIFFUSION -!*** -!---------------------------------------------------------------------- - ESQHF=0.5*ESQ - DO K=KTS+1,KTE - ZAK=0.5*(Z(K)+Z(K-1)) !ZAK OF VDIFQ = ZA(K-1) OF SHINHONG2D - ZFACENTK(K)=(ZAK/HPBL)**3.0 - ENDDO -! - DO K=KTE,KTS+2,-1 - DTOZ(K)=(DTDIF+DTDIF)/(Z(K+1)-Z(K-1)) - AKQ(K)=C_K*(AKHK(K)/(Z(K+1)-Z(K-1))+AKHK(K-1)/(Z(K)-Z(K-2))) - CR(K)=-DTOZ(K)*AKQ(K) - ENDDO -! - AKQS=C_K*AKHK(KTS+1)/(Z(KTS+2)-Z(KTS)) - CM(KTE)=DTOZ(KTE)*AKQ(KTE)+1. - RSQ2(KTE)=Q2(KTE) -! - DO K=KTE-1,KTS+2,-1 - CF=-DTOZ(K)*AKQ(K+1)/CM(K+1) - CM(K)=-CR(K+1)*CF+(AKQ(K+1)+AKQ(K))*DTOZ(K)+1. - RSQ2(K)=-RSQ2(K+1)*CF+Q2(K) - IF(PBLFLG.AND.K.LT.KPBL) THEN - RSQ2(K)=RSQ2(K)-DTOZ(K)*(2.0*HGAME(K)/HPBL)*AKQ(K+1)*(Z(K+1)-Z(K)) & - +DTOZ(K)*(2.0*HGAME(K-1)/HPBL)*AKQ(K)*(Z(K)-Z(K-1)) - RSQ2(K)=RSQ2(K)-DTOZ(K)*2.0*EFXPBL*ZFACENTK(K+1) & - +DTOZ(K)*2.0*EFXPBL*ZFACENTK(K) - ENDIF - ENDDO -! - DTOZS=(DTDIF+DTDIF)/(Z(KTS+2)-Z(KTS)) - CF=-DTOZS*AKQ(LMH+2)/CM(LMH+2) -! - IF(PBLFLG.AND.((LMH+1).LT.KPBL)) THEN - Q2(LMH+1)=(DTOZS*AKQS*Q2(LMH)-RSQ2(LMH+2)*CF+Q2(LMH+1) & - -DTOZS*(2.0*HGAME(LMH+1)/HPBL)*AKQ(LMH+2)*(Z(LMH+2)-Z(LMH+1)) & - +DTOZS*(2.0*HGAME(LMH)/HPBL)*AKQS*(Z(LMH+1)-Z(LMH))) - Q2(LMH+1)=Q2(LMH+1)-DTOZS*2.0*EFXPBL*ZFACENTK(LMH+2) & - +DTOZS*2.0*EFXPBL*ZFACENTK(LMH+1) - Q2(LMH+1)=Q2(LMH+1)/((AKQ(LMH+2)+AKQS)*DTOZS-CR(LMH+2)*CF+1.) - ELSE - Q2(LMH+1)=(DTOZS*AKQS*Q2(LMH)-RSQ2(LMH+2)*CF+Q2(LMH+1)) & - & /((AKQ(LMH+2)+AKQS)*DTOZS-CR(LMH+2)*CF+1.) - ENDIF -! - DO K=LMH+2,KTE - Q2(K)=(-CR(K)*Q2(K-1)+RSQ2(K))/CM(K) - ENDDO -!---------------------------------------------------------------------- -! - END SUBROUTINE VDIFQ -! -!---------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- + function ptke(d,h) +!------------------------------------------------------------------------------- + implicit none +!------------------------------------------------------------------------------- + real :: ptke + real,parameter :: pmin = 0.0,pmax = 1.0 + real,parameter :: a1 = 1.000, a2 = 0.070, & + a3 = 1.000, a4 = 0.142, a5 = 0.071 + real,parameter :: b1 = 2.0, b2 = 0.6666667 + real :: d,h,doh,num,den +! + doh=d/h + num=a1*(doh)**b1+a2*(doh)**b2 + den=a3*(doh)**b1+a4*(doh)**b2+a5 + ptke=num/den + ptke=max(ptke,pmin) + ptke=min(ptke,pmax) +! + return + end function +!------------------------------------------------------------------------------- +! +!------------------------------------------------------------------------------- end module module_bl_shinhong !------------------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_bl_ysu.F b/wrfv2_fire/phys/module_bl_ysu.F index 3ad60517..639049ed 100644 --- a/wrfv2_fire/phys/module_bl_ysu.F +++ b/wrfv2_fire/phys/module_bl_ysu.F @@ -355,6 +355,10 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! ==> consider thermal z0 when differs from mechanical z0 ! a bug fix in wscale computation in stable bl, sukanta basu, jun 2012 ! ==> wscale becomes small with height, and less mixing in stable bl +! revision in background diffusion (kzo), jan 2016 +! ==> kzo = 0.1 for momentum and = 0.01 for mass to account for +! internal wave mixing of large et al. (1994), songyou hong, feb 2016 +! ==> alleviate superious excessive mixing when delz is large ! ! references: ! @@ -366,6 +370,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & ! !------------------------------------------------------------------------------- ! + real,parameter :: xkzminm = 0.1,xkzminh = 0.01 real,parameter :: xkzmin = 0.01,xkzmax = 1000.,rimin = -100. real,parameter :: rlam = 30.,prmin = 0.25,prmax = 4. real,parameter :: brcr_ub = 0.0,brcr_sb = 0.25,cori = 1.e-4 @@ -373,7 +378,7 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & real,parameter :: phifac = 8.,sfcfrac = 0.1 real,parameter :: d1 = 0.02, d2 = 0.05, d3 = 0.001 real,parameter :: h1 = 0.33333335, h2 = 0.6666667 - real,parameter :: ckz = 0.001,zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. + real,parameter :: zfmin = 1.e-8,aphi5 = 5.,aphi16 = 16. real,parameter :: tmin=1.e-2 real,parameter :: gamcrt = 3.,gamcrq = 2.e-3 real,parameter :: xka = 2.4e-5 @@ -453,7 +458,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & del, & dza, & dzq, & - xkzo, & + xkzom, & + xkzoh, & za ! real, dimension( its:ite ) :: & @@ -654,7 +660,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & enddo do k = kts,klpbl-1 do i = its,ite - xkzo(i,k) = ckz*dza(i,k+1) + xkzom(i,k) = xkzminm + xkzoh(i,k) = xkzminh enddo enddo ! @@ -1035,12 +1042,12 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & prnum0 = prnum0/(1.+prfac2*karman*sfcfrac) prnum = 1. + (prnum0-1.)*exp(prnumfac) xkzh(i,k) = xkzm(i,k)/prnum + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) + xkzq(i,k) = xkzq(i,k)+xkzoh(i,k) xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzm(i,k) = max(xkzm(i,k),xkzo(i,k)) xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzh(i,k) = max(xkzh(i,k),xkzo(i,k)) xkzq(i,k) = min(xkzq(i,k),xkzmax) - xkzq(i,k) = max(xkzq(i,k),xkzo(i,k)) endif enddo enddo @@ -1085,10 +1092,10 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & xkzm(i,k) = xkzh(i,k)*prnum endif ! + xkzm(i,k) = xkzm(i,k)+xkzom(i,k) + xkzh(i,k) = xkzh(i,k)+xkzoh(i,k) xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzm(i,k) = max(xkzm(i,k),xkzo(i,k)) xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzh(i,k) = max(xkzh(i,k),xkzo(i,k)) xkzml(i,k) = xkzm(i,k) xkzhl(i,k) = xkzh(i,k) endif @@ -1125,8 +1132,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then xkzh(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) xkzh(i,k) = sqrt(xkzh(i,k)*xkzhl(i,k)) + xkzh(i,k) = max(xkzh(i,k),xkzoh(i,k)) xkzh(i,k) = min(xkzh(i,k),xkzmax) - xkzh(i,k) = max(xkzh(i,k),xkzo(i,k)) f1(i,k+1) = thx(i,k+1)-300. else f1(i,k+1) = thx(i,k+1)-300. @@ -1216,8 +1223,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then xkzq(i,k) = -we(i)*dza(i,kpbl(i))*exp(-entfac(i,k)) xkzq(i,k) = sqrt(xkzq(i,k)*xkzhl(i,k)) + xkzq(i,k) = max(xkzq(i,k),xkzoh(i,k)) xkzq(i,k) = min(xkzq(i,k),xkzmax) - xkzq(i,k) = max(xkzq(i,k),xkzo(i,k)) f3(i,k+1,1) = qx(i,k+1) else f3(i,k+1,1) = qx(i,k+1) @@ -1328,8 +1335,8 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d, & elseif(pblflg(i).and.k.ge.kpbl(i).and.entfac(i,k).lt.4.6) then xkzm(i,k) = prpbl(i)*xkzh(i,k) xkzm(i,k) = sqrt(xkzm(i,k)*xkzml(i,k)) + xkzm(i,k) = max(xkzm(i,k),xkzom(i,k)) xkzm(i,k) = min(xkzm(i,k),xkzmax) - xkzm(i,k) = max(xkzm(i,k),xkzo(i,k)) f1(i,k+1) = ux(i,k+1) f2(i,k+1) = vx(i,k+1) else diff --git a/wrfv2_fire/phys/module_cu_camzm_driver.F b/wrfv2_fire/phys/module_cu_camzm_driver.F index 52fad5bc..82b32904 100644 --- a/wrfv2_fire/phys/module_cu_camzm_driver.F +++ b/wrfv2_fire/phys/module_cu_camzm_driver.F @@ -263,7 +263,8 @@ SUBROUTINE camzm_driver( & ntsnprd, & !evap outfld: net snow production in layer (kg/kg/s) pdel8, & !pressure thickness of layer (between interfaces, Pa) pmid8, & !pressure at layer middle (Pa) - ql8, & !cloud liquid water (~units?) + ql8, & !in cloud liquid water (~units?) + ql8prm, & !cloud liquid water (~units?) qi8, & !cloud ice (~units?) t8, & !temperature (K) zm8, & !height above ground at mid-level (m) @@ -426,9 +427,9 @@ SUBROUTINE camzm_driver( & pmid8(1,kflip) = p(i,k,j) qh8(1,kflip,1) = max( qv(i,k,j)/(1.+qv(i,k,j)), 1e-30 ) !values of 0 cause a crash in entropy if( present(qc) ) then - ql8(1,kflip) = qc(i,k,j)/(1.+qv(i,k,j)) !Convert to moist mix ratio + ql8prm(1,kflip) = qc(i,k,j)/(1.+qv(i,k,j)) !Convert to moist mix ratio else - ql8(1,kflip) = 0. + ql8prm(1,kflip) = 0. end if if( present(qi) ) then qi8(1,kflip) = qi(i,k,j)/(1.+qv(i,k,j)) !Used in convtran, ditto for conversion @@ -541,7 +542,7 @@ SUBROUTINE camzm_driver( & !Convert temperature to potential temperature and !specific humidity to water vapor mixing ratio rthcuten(i,k,j) = zmdt(i,k,j)/pi_phy(i,k,j) - rqvcuten(i,k,j) = zmdq(i,k,j)/(1._r8 - zmdq(i,k,j)) + rqvcuten(i,k,j) = zmdq(i,k,j)*(1._r8 + qv(i,k,j))**2 t8(1,kflip) = t8(1,kflip) + zmdt(i,k,j)*cudts !PMA qh8(1,kflip,1) = qh8(1,kflip,1) + zmdq(i,k,j)*cudts !PMA @@ -602,7 +603,7 @@ SUBROUTINE camzm_driver( & rthcuten(i,k,j) = rthcuten(i,k,j) + & evaptzm(i,k,j)/pi_phy(i,k,j) rqvcuten(i,k,j) = rqvcuten(i,k,j) + & - evapqzm(i,k,j)/(1. - qv(i,k,j)) + evapqzm(i,k,j)*(1. + qv(i,k,j))**2 t8(1,kflip) = t8(1,kflip) + evaptzm(i,k,j)*cudts !PMA qh8(1,kflip,1) = qh8(1,kflip,1) + evapqzm(i,k,j)*cudts !PMA @@ -683,7 +684,7 @@ SUBROUTINE camzm_driver( & kflip = kte-k+1 cloud(1,kflip,1) = qh8(1,kflip,1) !We can either use moist mix ratios, as is - cloud(1,kflip,2) = ql8(1,kflip) !done here, or else use dry mix ratios, send + cloud(1,kflip,2) = ql8prm(1,kflip) !done here, or else use dry mix ratios, send cloud(1,kflip,3) = qi8(1,kflip) !in appropriate dpdry values, and return the !approp. response from cnst_get_type_byind end do @@ -728,16 +729,16 @@ SUBROUTINE camzm_driver( & !Convert cloud tendencies from wet to dry mix ratios if( present(rqccuten) ) then - rqccuten(i,k,j) = (cloudtnd(1,kflip,2)+qcten_det(1,kflip))/(1. - qv(i,k,j)) + rqccuten(i,k,j) = (cloudtnd(1,kflip,2)+qcten_det(1,kflip))*(1. + qv(i,k,j)) end if if( present(rqicuten) ) then - rqicuten(i,k,j) = (cloudtnd(1,kflip,3)+qiten_det(1,kflip))/(1. - qv(i,k,j)) + rqicuten(i,k,j) = (cloudtnd(1,kflip,3)+qiten_det(1,kflip))*(1. + qv(i,k,j)) end if if( present(rqcncuten) ) then - rqcncuten(i,k,j) = qcnten_det(1,kflip)/(1. - qv(i,k,j)) !BSINGH - Added the denominator following qiten_det + rqcncuten(i,k,j) = qcnten_det(1,kflip)*(1. + qv(i,k,j)) !BSINGH - Added the denominator following qiten_det end if if( present(rqincuten) ) then - rqincuten(i,k,j) = qinten_det(1,kflip)/(1. - qv(i,k,j)) !BSINGH - Added the denominator following qiten_det + rqincuten(i,k,j) = qinten_det(1,kflip)*(1. + qv(i,k,j)) !BSINGH - Added the denominator following qiten_det end if !Variables required by zm_conv_tend_2 call dp3d(i,k,j) = dp(1,kflip,lchnk) diff --git a/wrfv2_fire/phys/module_cu_kf.F b/wrfv2_fire/phys/module_cu_kf.F index ec4188be..2481a8f6 100644 --- a/wrfv2_fire/phys/module_cu_kf.F +++ b/wrfv2_fire/phys/module_cu_kf.F @@ -25,6 +25,10 @@ SUBROUTINE KFCPS( & ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & ,RQVCUTEN,RQCCUTEN,RQRCUTEN,RQICUTEN,RQSCUTEN & ,RTHCUTEN & +!kf_edrates + ,UDR_KF,DDR_KF & + ,UER_KF,DER_KF & + ,TIMEC_KF,KF_EDRATES & ) !------------------------------------------------------------- IMPLICIT NONE @@ -102,7 +106,19 @@ SUBROUTINE KFCPS( & ,F_QI & ,F_QS +!kf_edrates + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: & + UDR_KF, & + DDR_KF, & + UER_KF, & + DER_KF + + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: & + TIMEC_KF + INTEGER, INTENT(IN) :: KF_EDRATES ! LOCAL VARS @@ -228,6 +244,16 @@ SUBROUTINE KFCPS( & DQSDT(k)=0. DTDT(k)=0. ENDDO +!kf_edrates + IF (KF_EDRATES == 1) THEN + DO k=kts,kte + UDR_KF(I,k,J)=0. + DDR_KF(I,k,J)=0. + UER_KF(I,k,J)=0. + DER_KF(I,k,J)=0. + ENDDO + TIMEC_KF(I,J)=0. + ENDIF RAINCV(I,J)=0. PRATEC(I,J)=0. ! @@ -255,7 +281,11 @@ SUBROUTINE KFCPS( & warm_rain,qi_flag,qs_flag, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, & +!kf_edrates + UDR_KF,DDR_KF, & + UER_KF,DER_KF, & + TIMEC_KF,KF_EDRATES ) IF ( PRESENT( RTHCUTEN ) .AND. PRESENT( RQVCUTEN ) ) THEN DO K=kts,kte @@ -311,7 +341,11 @@ SUBROUTINE KFPARA (I, J, & warm_rain,qi_flag,qs_flag, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & - its,ite, jts,jte, kts,kte ) + its,ite, jts,jte, kts,kte, & +!kf_edrates + UDR_KF,DDR_KF, & + UER_KF,DER_KF, & + TIMEC_KF,KF_EDRATES ) !----------------------------------------------------------- IMPLICIT NONE !----------------------------------------------------------- @@ -351,6 +385,19 @@ SUBROUTINE KFPARA (I, J, & INTENT(INOUT) :: RAINCV, & PRATEC, & NCA + +!kf_edrates + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: UDR_KF, & + DDR_KF, & + UER_KF, & + DER_KF + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: TIMEC_KF + + INTEGER, INTENT(IN) :: KF_EDRATES + ! !...DEFINE LOCAL VARIABLES... ! @@ -1738,6 +1785,18 @@ SUBROUTINE KFPARA (I, J, & ! GOTO 175 265 CONTINUE + +!kf_edrates +!Save up/down entrainment/detrainment rates as 3D variables + IF (KF_EDRATES == 1) THEN + DO NK=1,LTOP + UDR_KF(I,NK,J)=UDR(NK) + DDR_KF(I,NK,J)=DDR(NK) + UER_KF(I,NK,J)=UER(NK) + DER_KF(I,NK,J)=DER(NK) + ENDDO + ENDIF + ! !...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS !...GRID POINT... @@ -1811,6 +1870,13 @@ SUBROUTINE KFPARA (I, J, & QRG(NK)=QRPA(NK) QSG(NK)=QSPA(NK) 295 CONTINUE + +!kf_edrates +!Save convective timescale (TIMEC) as 2D variable + IF (KF_EDRATES == 1) THEN + TIMEC_KF(I,J)=TIMEC + ENDIF + ! WRITE(98,1080)LFS,LDB,LDT,TIMEC,NSTEP,NCOUNT,FABE,AINC ! !...SEND FINAL PARAMETERIZED VALUES TO OUTPUT FILES... diff --git a/wrfv2_fire/phys/module_cu_kfcup.F b/wrfv2_fire/phys/module_cu_kfcup.F index 1cba849c..31b5f7d3 100644 --- a/wrfv2_fire/phys/module_cu_kfcup.F +++ b/wrfv2_fire/phys/module_cu_kfcup.F @@ -3496,7 +3496,7 @@ SUBROUTINE KF_cup_PARA ( GRID_ID, KTAU, & ! rce 11-may-2012 ! !...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS... ! - IF(.NOT. F_QI .and. warm_rain)THEN + IF(warm_rain)THEN CPM=CP*(1.+0.887*QG(K)) TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM @@ -3504,9 +3504,9 @@ SUBROUTINE KF_cup_PARA ( GRID_ID, KTAU, & ! rce 11-may-2012 DQIDT(K)=0. DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC DQSDT(K)=0. - ELSEIF(.NOT. F_QI .and. .not. warm_rain)THEN + ELSEIF(.NOT. F_QS)THEN ! -!...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROME +!...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROMETEORS !...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL ! CPM=CP*(1.+0.887*QG(K)) @@ -3519,22 +3519,22 @@ SUBROUTINE KF_cup_PARA ( GRID_ID, KTAU, & ! rce 11-may-2012 DQIDT(K)=0. DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC DQSDT(K)=0. - ELSEIF(F_QI) THEN + ELSEIF(F_QS) THEN ! -!...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE TENDEN +!...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE TENDENCIES !...OF HYDROMETEORS DIRECTLY... ! DQCDT(K)=(QLG(K)-QL0(K))/TIMEC - DQIDT(K)=(QIG(K)-QI0(K))/TIMEC + DQSDT(K)=(QSG(K)-QS0(K))/TIMEC DQRDT(K)=(QRG(K)-QR0(K))/TIMEC - IF (F_QS) THEN - DQSDT(K)=(QSG(K)-QS0(K))/TIMEC + IF (F_QI) THEN + DQIDT(K)=(QIG(K)-QI0(K))/TIMEC ELSE - DQIDT(K)=DQIDT(K)+(QSG(K)-QS0(K))/TIMEC + DQSDT(K)=DQSDT(K)+(QIG(K)-QI0(K))/TIMEC ENDIF ELSE ! PRINT *,'THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED!' - CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED' ) + CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS MICROPHYSICS CHOICE IS NOT ALLOWED' ) ENDIF DTDT(K)=(TG(K)-T0(K))/TIMEC DQDT(K)=(QG(K)-Q0(K))/TIMEC diff --git a/wrfv2_fire/phys/module_cu_kfeta.F b/wrfv2_fire/phys/module_cu_kfeta.F index 63319f85..59707e29 100644 --- a/wrfv2_fire/phys/module_cu_kfeta.F +++ b/wrfv2_fire/phys/module_cu_kfeta.F @@ -15,7 +15,7 @@ MODULE module_cu_kfeta ! !-------------------------------------------------------------------- ! Lookup table variables: - INTEGER, PARAMETER :: KFNT=250,KFNP=220 + INTEGER, PARAMETER, PRIVATE :: KFNT=250,KFNP=220!wig, 24-Aug-2006: added private to prevent CuP conflicts !BSINGH - For WRFCuP scheme REAL, DIMENSION(KFNT,KFNP),PRIVATE, SAVE :: TTAB,QSTAB REAL, DIMENSION(KFNP),PRIVATE, SAVE :: THE0K REAL, DIMENSION(200),PRIVATE, SAVE :: ALU @@ -38,6 +38,7 @@ SUBROUTINE KF_eta_CPS( & ,EP2,SVP1,SVP2,SVP3,SVPT0 & ,STEPCU,CU_ACT_FLAG,warm_rain,CUTOP,CUBOT & ,QV & + ,shall & !BSINGH - For WRFCuP scheme added "shall" ! optionals ,F_QV ,F_QC ,F_QR ,F_QI ,F_QS & ,RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN & @@ -45,6 +46,10 @@ SUBROUTINE KF_eta_CPS( & !ckay ,cldfra_dp_KF,cldfra_sh_KF & ,qc_KF,qi_KF & +!kf_edrates + ,UDR_KF,DDR_KF & + ,UER_KF,DER_KF & + ,TIMEC_KF,KF_EDRATES & ) ! !------------------------------------------------------------- @@ -95,6 +100,9 @@ SUBROUTINE KF_eta_CPS( & REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: NCA + REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & + INTENT(INOUT) :: SHALL !BSINGH - For WRFCuP scheme + REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(OUT) :: CUBOT, & CUTOP @@ -138,6 +146,20 @@ SUBROUTINE KF_eta_CPS( & qc_KF, & qi_KF +!kf_edrates + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: & + UDR_KF, & + DDR_KF, & + UER_KF, & + DER_KF + + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: & + TIMEC_KF + + INTEGER, INTENT(IN) :: KF_EDRATES + ! LOCAL VARS LOGICAL :: flag_qr, flag_qi, flag_qs @@ -176,6 +198,7 @@ SUBROUTINE KF_eta_CPS( & integer :: ibegh,iendh,jbegh,jendh integer :: istart,iend,jstart,jend INTEGER :: i,j,k,NTST + INTEGER :: ishall !BSINGH - For WRFCuP Scheme REAL :: lastdt = -1.0 REAL :: W0AVGfctr, W0fctr, W0den @@ -401,6 +424,16 @@ SUBROUTINE KF_eta_CPS( & qc_KF(I,k,J)=0. qi_KF(I,k,J)=0. ENDDO +!kf_edrates + IF (KF_EDRATES == 1) THEN + DO k=kts,kte + UDR_KF(I,k,J)=0. + DDR_KF(I,k,J)=0. + UER_KF(I,k,J)=0. + DER_KF(I,k,J)=0. + ENDDO + TIMEC_KF(I,J)=0. + ENDIF RAINCV(I,J)=0. CUTOP(I,J)=KTS CUBOT(I,J)=KTE+1 @@ -435,13 +468,20 @@ SUBROUTINE KF_eta_CPS( & DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & RAINCV,PRATEC,NCA, & flag_QI,flag_QS,warm_rain, & - CUTOP,CUBOT,CUDT, & + CUTOP,CUBOT,ishall,CUDT, & !BSINGH - Added ishall as arg for WRFCuP ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & !ckay cldfra_dp_KF,cldfra_sh_KF, & - qc_KF,qi_KF ) + qc_KF,qi_KF, & +!kf_edrates + UDR_KF,DDR_KF, & + UER_KF,DER_KF, & + TIMEC_KF,KF_EDRATES ) + if(present(shall))shall(i,j) = ishall !,BSINGH - For WRFCuP scheme + + IF(PRESENT(rthcuten).AND.PRESENT(rqvcuten)) THEN DO K=kts,kte RTHCUTEN(I,K,J)=DTDT(K)/pi(I,K,J) @@ -500,13 +540,17 @@ SUBROUTINE KF_eta_PARA (I, J, & DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & RAINCV,PRATEC,NCA, & F_QI,F_QS,warm_rain, & - CUTOP,CUBOT,CUDT, & + CUTOP,CUBOT,ishall,CUDT, & !BSINGH - For WRFCuP scheme ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & !ckay cldfra_dp_KF,cldfra_sh_KF, & - qc_KF,qi_KF ) + qc_KF,qi_KF, & +!kf_edrates + UDR_KF,DDR_KF, & + UER_KF,DER_KF, & + TIMEC_KF,KF_EDRATES ) !----------------------------------------------------------- !***** The KF scheme that is currently used in experimental runs of EMCs !***** Eta model....jsk 8/00 @@ -543,6 +587,7 @@ SUBROUTINE KF_eta_PARA (I, J, & REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 ! + INTEGER, INTENT(INOUT) :: ISHALL REAL, DIMENSION( kts:kte ), INTENT(INOUT) :: & DQDT, & DQIDT, & @@ -560,6 +605,17 @@ SUBROUTINE KF_eta_PARA (I, J, & cldfra_sh_KF, & qc_KF, & qi_KF +!kf_edrates + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: UDR_KF, & + DDR_KF, & + UER_KF, & + DER_KF + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: TIMEC_KF + + INTEGER, INTENT(IN) :: KF_EDRATES REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: RAINCV @@ -647,7 +703,7 @@ SUBROUTINE KF_eta_PARA (I, J, & LTOPM1,LVF,KSTART,KMIN,LFS, & ND,NIC,LDB,LDT,ND1,NDK, & NM,LMAX,NCOUNT,NOITR, & - NSTEP,NTC,NCHM,ISHALL,NSHALL + NSTEP,NTC,NCHM,NSHALL LOGICAL :: IPRNT REAL :: u00,qslcl,rhlcl,dqssdt !jfb CHARACTER*1024 message @@ -779,6 +835,11 @@ SUBROUTINE KF_eta_PARA (I, J, & FBFRC=1. CYCLE usl ELSE + !BSINGH - For WRFCuP scheme + ! wig, 29-Aug-2006: I think this is where no convecion occurs. So, force + ! ishall to a flag value to indicate this for accounting purposes. + ishall = 2 + !BSINGH -ENDS RETURN ENDIF ENDIF @@ -814,6 +875,10 @@ SUBROUTINE KF_eta_PARA (I, J, & END DO ENDIF IF(DPTHMX.LT.DPMIN)THEN + !BSINGH - For WRFCuP scheme + ! wig, 29-Aug-2006: Indicate no convection occurred in ishall. + ishall = 2 + !BSINGH -ENDS RETURN ENDIF KPBL=LC+NLAYRS-1 @@ -880,7 +945,15 @@ SUBROUTINE KF_eta_PARA (I, J, & KLCL = NK IF ( ZLCL.LE.Z0(NK) ) EXIT END DO - IF ( ZLCL.GT.Z0(KL) ) RETURN + IF ( ZLCL.GT.Z0(KL) ) then + !BSINGH - For WRFCuP scheme + !BSINGH - Improvised based on the following reason + !Before every "RETURN" statement assign ishall=2 + ! wig, 29-Aug-2006: Indicate no convection occurred in ishall. + ishall = 2 + !BSINGH -ENDS + RETURN + endif K=KLCL-1 ! calculate DLP using Z instead of log(P) @@ -2115,6 +2188,12 @@ SUBROUTINE KF_eta_PARA (I, J, & IF(FABE.GT.1. .and. ISHALL.EQ.0)THEN ! WRITE(98,*)'UPDRAFT/DOWNDRAFT COUPLET INCREASES CAPE AT THIS ! *GRID POINT; NO CONVECTION ALLOWED!' + !BSINGH - For WRFCuP scheme + !BSINGH - Improvised based on the following reason + !Before every "RETURN" statement assign ishall=2 + ! wig, 29-Aug-2006: Indicate no convection occurred in ishall. + ishall = 2 + !BSINGH -ENDS RETURN ENDIF IF(NCOUNT.NE.1)THEN @@ -2169,6 +2248,13 @@ SUBROUTINE KF_eta_PARA (I, J, & !...IF AINC BECOMES VERY SMALL, EFFECTS OF CONVECTION ! JSK MODS !...WILL BE MINIMAL SO JUST IGNORE IT... ! JSK MODS IF(AINC.LT.0.05)then + !BSINGH - For WRFCuP scheme + !BSINGH - Improvised based on the following reason + !Before every "RETURN" statement assign ishall=2 + ! wig, 29-Aug-2006: Indicate no convection occurred in ishall. + ishall = 2 + !BSINGH -ENDS + RETURN ! JSK MODS ENDIF ! AINC=AMAX1(AINC,0.05) ! JSK MODS @@ -2210,6 +2296,17 @@ SUBROUTINE KF_eta_PARA (I, J, & cldfra_dp_KF(I,NK,J) = amin1(0.6,xcldfra) ENDDO ENDIF + +!kf_edrates +!Save up/down entrainment/detrainment rates as 3D variables + IF (KF_EDRATES == 1) THEN + DO NK=1,LTOP + UDR_KF(I,NK,J)=UDR(NK) + DDR_KF(I,NK,J)=DDR(NK) + UER_KF(I,NK,J)=UER(NK) + DER_KF(I,NK,J)=DER(NK) + ENDDO + ENDIF ! !...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV... ! @@ -2283,6 +2380,12 @@ SUBROUTINE KF_eta_PARA (I, J, & QRG(NK)=QRPA(NK) QSG(NK)=QSPA(NK) ENDDO + +!kf_edrates +!Save convective timescale (TIMEC) as 2D variable + IF (KF_EDRATES == 1) THEN + TIMEC_KF(I,J)=TIMEC + ENDIF ! !...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS !...GRID POINT... @@ -2493,7 +2596,7 @@ SUBROUTINE KF_eta_PARA (I, J, & ! !...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS... ! - IF(.NOT. F_QI .and. warm_rain)THEN + IF(warm_rain)THEN CPM=CP*(1.+0.887*QG(K)) TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM @@ -2501,7 +2604,7 @@ SUBROUTINE KF_eta_PARA (I, J, & DQIDT(K)=0. DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC DQSDT(K)=0. - ELSEIF(.NOT. F_QI .and. .not. warm_rain)THEN + ELSEIF(.NOT. F_QS)THEN ! !...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROMETEORS !...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL @@ -2516,22 +2619,22 @@ SUBROUTINE KF_eta_PARA (I, J, & DQIDT(K)=0. DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC DQSDT(K)=0. - ELSEIF(F_QI) THEN + ELSEIF(F_QS) THEN ! !...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE TENDENCIES !...OF HYDROMETEORS DIRECTLY... ! DQCDT(K)=(QLG(K)-QL0(K))/TIMEC - DQIDT(K)=(QIG(K)-QI0(K))/TIMEC + DQSDT(K)=(QSG(K)-QS0(K))/TIMEC DQRDT(K)=(QRG(K)-QR0(K))/TIMEC - IF (F_QS) THEN - DQSDT(K)=(QSG(K)-QS0(K))/TIMEC + IF (F_QI) THEN + DQIDT(K)=(QIG(K)-QI0(K))/TIMEC ELSE - DQIDT(K)=DQIDT(K)+(QSG(K)-QS0(K))/TIMEC + DQSDT(K)=DQSDT(K)+(QIG(K)-QI0(K))/TIMEC ENDIF ELSE ! PRINT *,'THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED!' - CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED' ) + CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS MICROPHYSICS CHOICE IS NOT ALLOWED' ) ENDIF DTDT(K)=(TG(K)-T0(K))/TIMEC DQDT(K)=(QG(K)-Q0(K))/TIMEC diff --git a/wrfv2_fire/phys/module_cu_mesosas.F b/wrfv2_fire/phys/module_cu_mesosas.F index a18bbbf2..087d5302 100644 --- a/wrfv2_fire/phys/module_cu_mesosas.F +++ b/wrfv2_fire/phys/module_cu_mesosas.F @@ -529,7 +529,7 @@ SUBROUTINE msasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & ktf=min0(kte,kde-1) itf=min0(ite,ide-1) -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing IF(.not.restart .or. .not.allowed_to_read)THEN !end of zhang's doing diff --git a/wrfv2_fire/phys/module_cu_mskf.F b/wrfv2_fire/phys/module_cu_mskf.F index 3593f88c..3216dc91 100644 --- a/wrfv2_fire/phys/module_cu_mskf.F +++ b/wrfv2_fire/phys/module_cu_mskf.F @@ -4,6 +4,7 @@ MODULE module_cu_mskf ! !ckay=Kiran Alapaty, EPA +!CGM = Chris Marciano, NCSU ! !multi-scale KF scheme ! (1) With diagnosed deep and shallow KF cloud fraction using @@ -14,9 +15,6 @@ MODULE module_cu_mskf ! (4) Scale-dependent Fallout Rate ! (5) Scale-dependent Stabilization Capacity ! (6) Elimination of "double counting" when environment is saturated -! (7) Estimation and feeback of updraft vertical velocities back -! to gridscale vertical velocities -! (8) new Trigger function based on Bechtold method -- scale dependent ! ! Alapaty et al., 2012: Introducing subgrid-scale cloud feedbacks to radiation ! for regional meteorological and climate modeling. GRL, V39, I24. @@ -65,6 +63,10 @@ SUBROUTINE MSKF_CPS( & !ckay ,cldfra_dp_KF,cldfra_sh_KF,w_up & ,qc_KF,qi_KF & +!kf_edrates + ,UDR_KF,DDR_KF & + ,UER_KF,DER_KF & + ,TIMEC_KF,KF_EDRATES & ,ZOL,WSTAR,UST,PBLH & !ckay ) ! @@ -159,6 +161,21 @@ SUBROUTINE MSKF_CPS( & qc_KF, & qi_KF, & W + +!kf_edrates + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(INOUT) :: & + UDR_KF, & + DDR_KF, & + UER_KF, & + DER_KF + + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT) :: & + TIMEC_KF + + INTEGER, INTENT(IN) :: KF_EDRATES + !ckay REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT( IN) :: ZOL, & @@ -256,7 +273,7 @@ SUBROUTINE MSKF_CPS( & ! W0AVG(I,K,J) = ( W0AVG(I,K,J) * W0AVGfctr + W0 * W0fctr ) / W0den !ckaywup - w(I,K,J)=w(I,K,J)+w_up(i,K,j) +! w(I,K,J)=w(I,K,J)+w_up(i,K,j) ENDDO ENDDO @@ -440,6 +457,15 @@ SUBROUTINE MSKF_CPS( & qi_KF(I,k,J)=0. w_up(I,k,J)=0. ENDDO + IF (KF_EDRATES == 1) THEN + DO k=kts,kte + UDR_KF(I,k,J)=0. + DDR_KF(I,k,J)=0. + UER_KF(I,k,J)=0. + DER_KF(I,k,J)=0. + ENDDO + TIMEC_KF(I,J)=0. + ENDIF RAINCV(I,J)=0. CUTOP(I,J)=KTS CUBOT(I,J)=KTE+1 @@ -482,6 +508,10 @@ SUBROUTINE MSKF_CPS( & !ckay cldfra_dp_KF,cldfra_sh_KF,w_up, & qc_KF,qi_KF, & +!kf_edrates + UDR_KF,DDR_KF, & + UER_KF,DER_KF, & + TIMEC_KF,KF_EDRATES, & ZOL,WSTAR,UST,PBLH ) IF(PRESENT(rthcuten).AND.PRESENT(rqvcuten)) THEN @@ -549,6 +579,10 @@ SUBROUTINE KF_eta_PARA (I, J, & !ckay cldfra_dp_KF,cldfra_sh_KF,w_up, & qc_KF,qi_KF, & +!kf_edrates + UDR_KF,DDR_KF, & + UER_KF,DER_KF, & + TIMEC_KF,KF_EDRATES, & ZOL,WSTAR,UST,PBLH ) !----------------------------------------------------------- !***** The KF scheme that is currently used in experimental runs of EMCs @@ -609,6 +643,17 @@ SUBROUTINE KF_eta_PARA (I, J, & cldfra_sh_KF, & qc_KF, & qi_KF +!kf_edrates + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), & + INTENT(INOUT) :: UDR_KF, & + DDR_KF, & + UER_KF, & + DER_KF + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: TIMEC_KF + + INTEGER, INTENT(IN) :: KF_EDRATES REAL, DIMENSION( ims:ime , jms:jme ), & INTENT(INOUT) :: RAINCV @@ -741,7 +786,7 @@ SUBROUTINE KF_eta_PARA (I, J, & capeDX = 0.1 ELSE Scale_Fac = 1.0 + (log(25.E3/DX)) - capeDX = 0.1*Scale_Fac + capeDX = 0.1 *SQRT(Scale_Fac) END IF ! !**************************************************************************** @@ -962,7 +1007,7 @@ SUBROUTINE KF_eta_PARA (I, J, & ! ww: this needs to be initialized DTRH = 0. -! Becthold 2001 trigger with my Beta parameter +! Bechtold 2001 trigger with my Beta parameter DTLCL = W0AVG1D(KLCL)/Scale_Fac if(DTLCL.lt.0.0) then tempKay = -1.0 @@ -975,14 +1020,31 @@ SUBROUTINE KF_eta_PARA (I, J, & end if DTLCL = 6.0 * tempKay * DTLCL +! +! old trigger +! Stick with the old trigger for now... CGM July 2015 +! + IF(ZLCL.LT.2.E3)THEN ! Kain (2004) Eq. 2 + WKLCL=0.02*ZLCL/2.E3 + ELSE + WKLCL=0.02 ! units of m/s + ENDIF + WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)*DX/25.E3-WKLCL + IF(WKL.LT.0.0001)THEN + DTLCL=0. + ELSE + DTLCL=4.64*WKL**0.33 ! Kain (2004) Eq. 1 + ENDIF + ! IF(ISHALL.EQ.1)IPRNT=.TRUE. ! IPRNT=.TRUE. ! IF(TLCL+DTLCL.GT.TENV)GOTO 45 - -trigger2: IF(TLCL+DTLCL+DTRH.LT.TENV)THEN + + IF(TLCL+DTLCL.LT.TENV)THEN ! -! Parcel not buoyant, CYCLE back to start of trigger and evaluate next potential USL... +! Parcel not buoyant, CYCLE back to start of trigger and evaluate next potential +! USL... ! CYCLE usl ! @@ -1137,12 +1199,14 @@ SUBROUTINE KF_eta_PARA (I, J, & DZZ=DZA(NK) ENDIF ENTERM=2.*REI*WTW/UPOLD - -!ckay +! +! ckay +! using corrected RATE_kay for Test simulation #2... CGM July 2015 +! IF(DX.GE.24.999E3) then RATE_kay = RATE else - RATE_kay = RATE / Scale_Fac + RATE_kay = RATE / Scale_Fac end if CALL CONDLOAD(QLIQ(NK1),QICE(NK1),WTW,DZZ,BOTERM,ENTERM, & RATE_kay,QNEWLQ,QNEWIC,QLQOUT(NK1),QICOUT(NK1),G) @@ -1325,18 +1389,28 @@ SUBROUTINE KF_eta_PARA (I, J, & qi_KF(I,NK,J)=QICE(NK) END DO -!ckay: if mean env RH with respect to water is over 100% then dont allow KF +!ckay: if mean env RH with respect to water/ice is over 100% then dont allow KF +!ckay: added saturation w.r.to ice june 10, 2015 ! to avoid double counting envRHavg = 0.0 DO NK=K-1,LTOP+1 - envEsat = 6.112*exp(17.67*(T0(NK)-273.16)/(243.5+T0(NK)-273.16)) + if(T0(NK).LE.273.16) then + envEsat = 6.112*exp(21.87*(T0(NK)-273.16)/(T0(NK)-7.66)) + else + envEsat = 6.112*exp(17.67*(T0(NK)-273.16)/(243.5+T0(NK)-273.16)) + end if envEsat = envEsat * 100.0 ! to hPa envQsat = 0.622*envEsat/(P0(NK)-envEsat) envRH = Q0(NK)/envQsat + if(NK.GT.K.and.envRH.LT.0.99) then + envRHavg = 0.0 + goto 2020 + end if envRHavg = envRHavg + envRH END DO !ckay ; get vertically averaged envRHavg envRHavg = envRHavg / float(LTOP-K+1+2) +2020 continue ! !...If cloud top height is less than the specified minimum for deep @@ -1415,7 +1489,7 @@ SUBROUTINE KF_eta_PARA (I, J, & ENDDO ENDIF ENDIF - ENDIF trigger2 + ENDIF ! for trigger END DO usl IF(ISHALL.EQ.1)THEN KSTART=MAX0(KPBL,KLCL) @@ -1624,8 +1698,8 @@ SUBROUTINE KF_eta_PARA (I, J, & TIMEC = TIMEC/((0.03*SCLvel*ABE)**0.3333) !ckay: this dynTau is good for the Deep as well as Shallow Cu clouds - TIMEC = AMAX1(DT, TIMEC) - + TIMEC = AMAX1(TADVEC, TIMEC) + NIC=NINT(TIMEC/DT) TIMEC=FLOAT(NIC)*DT ! @@ -2315,8 +2389,9 @@ SUBROUTINE KF_eta_PARA (I, J, & !ckaywup DMF_new=DMF(NK)/updil FXM_new=FXM(NK)/dxsq - w_up(I,NK,J) = (UMF_new+DMF_new-FXM_new)/denSplume - w_up(I,NK,J) = w_up(I,NK,J)*Drag*DT/TIMEC +! w_up(I,NK,J) = (UMF_new+DMF_new-FXM_new)/denSplume +! w_up(I,NK,J) = w_up(I,NK,J)*Drag*DT/TIMEC + w_up(I,NK,J) = (UMF_new/denSplume)*Drag*DT/TIMEC ENDDO ELSE DO NK=KLCL, LTOP @@ -2329,8 +2404,10 @@ SUBROUTINE KF_eta_PARA (I, J, & !new added downdraft impact DMF_new = DMF(NK)/updil FXM_new = FXM(NK)/dxsq - w_up(I,NK,J) = (UMF_new+DMF_new-FXM_new)/denSplume - w_up(I,NK,J) = w_up(I,NK,J)*Drag*DT/TIMEC +! w_up(I,NK,J) = (UMF_new+DMF_new-FXM_new)/denSplume +! w_up(I,NK,J) = w_up(I,NK,J)*Drag*DT/TIMEC + w_up(I,NK,J) = (UMF_new/denSplume)*Drag*DT/TIMEC + ENDDO ENDIF !ckaywup @@ -2345,6 +2422,18 @@ SUBROUTINE KF_eta_PARA (I, J, & w_up(I,NK,J) = 0.0 end if END DO + +!kf_edrates +!Save up/down entrainment/detrainment rates as 3D variables + IF (KF_EDRATES == 1) THEN + DO NK=1,LTOP + UDR_KF(I,NK,J)=UDR(NK) + DDR_KF(I,NK,J)=DDR(NK) + UER_KF(I,NK,J)=UER(NK) + DER_KF(I,NK,J)=DER(NK) + ENDDO + ENDIF + ! !...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV... ! @@ -2418,6 +2507,13 @@ SUBROUTINE KF_eta_PARA (I, J, & QRG(NK)=QRPA(NK) QSG(NK)=QSPA(NK) ENDDO + +!kf_edrates +!Save convective timescale (TIMEC) as 2D variable + IF (KF_EDRATES == 1) THEN + TIMEC_KF(I,J)=TIMEC + ENDIF + ! !...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS !...GRID POINT... @@ -2601,7 +2697,7 @@ SUBROUTINE KF_eta_PARA (I, J, & IF(TADVEC.LT.TIMEC)NIC=NINT(TADVEC/DT) NCA(I,J) = REAL(NIC)*DT IF(ISHALL.EQ.1)THEN - TIMEC = 2400. +! TIMEC = 2400. NCA(I,J) = CUDT*60. NSHALL = NSHALL+1 ENDIF @@ -2628,7 +2724,7 @@ SUBROUTINE KF_eta_PARA (I, J, & ! !...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS... ! - IF(.NOT. F_QI .and. warm_rain)THEN + IF(warm_rain)THEN CPM=CP*(1.+0.887*QG(K)) TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM @@ -2636,7 +2732,7 @@ SUBROUTINE KF_eta_PARA (I, J, & DQIDT(K)=0. DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC DQSDT(K)=0. - ELSEIF(.NOT. F_QI .and. .not. warm_rain)THEN + ELSEIF(.NOT. F_QS)THEN ! !...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROMETEORS !...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL @@ -2651,24 +2747,23 @@ SUBROUTINE KF_eta_PARA (I, J, & DQIDT(K)=0. DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC DQSDT(K)=0. - ELSEIF(F_QI) THEN + ELSEIF(F_QS) THEN ! !...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE TENDENCIES !...OF HYDROMETEORS DIRECTLY... ! DQCDT(K)=(QLG(K)-QL0(K))/TIMEC - DQIDT(K)=(QIG(K)-QI0(K))/TIMEC + DQSDT(K)=(QSG(K)-QS0(K))/TIMEC DQRDT(K)=(QRG(K)-QR0(K))/TIMEC - IF (F_QS) THEN - DQSDT(K)=(QSG(K)-QS0(K))/TIMEC + IF (F_QI) THEN + DQIDT(K)=(QIG(K)-QI0(K))/TIMEC ELSE - DQIDT(K)=DQIDT(K)+(QSG(K)-QS0(K))/TIMEC + DQSDT(K)=DQSDT(K)+(QIG(K)-QI0(K))/TIMEC ENDIF ELSE ! PRINT *,'THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED!' - CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED' ) + CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS MICROPHYSICS CHOICE IS NOT ALLOWED' ) ENDIF - DTDT(K)=(TG(K)-T0(K))/TIMEC DQDT(K)=(QG(K)-Q0(K))/TIMEC ENDDO diff --git a/wrfv2_fire/phys/module_cu_ntiedtke.F b/wrfv2_fire/phys/module_cu_ntiedtke.F index e109d7d4..f6f59ea2 100644 --- a/wrfv2_fire/phys/module_cu_ntiedtke.F +++ b/wrfv2_fire/phys/module_cu_ntiedtke.F @@ -35,7 +35,7 @@ module module_cu_ntiedtke !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ use module_model_constants, only:rd=>r_d, rv=>r_v, & - & cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, epsl=>epsilon, g + & cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, g implicit none real,private :: rcpd,vtmpc1,tmelt, & @@ -43,7 +43,7 @@ module module_cu_ntiedtke real,private :: r5alvcp,r5alscp,ralvdcp,ralsdcp,ralfdcp,rtwat,rtber,rtice real,private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon - integer,private :: ntrigger,momtrans,p950,p650 + integer,private :: momtrans,p950,p650 parameter( & rcpd=1.0/cpd, & @@ -70,7 +70,7 @@ module module_cu_ntiedtke ! entrdd: average entrainment & detrainment rate for downdrafts ! ------ ! - parameter(entrdd = 3.0e-4) + parameter(entrdd = 2.0e-4) ! ! cmfcmax: maximum massflux value allowed for updrafts etc ! ------- @@ -87,7 +87,7 @@ module module_cu_ntiedtke ! parameter(cmfdeps = 0.30) -! zdnoprc: deep cloud is thicker than this height +! zdnoprc: deep cloud is thicker than this height (Unit:Pa) ! parameter(zdnoprc = 2.0e4) ! ------- @@ -101,7 +101,7 @@ module module_cu_ntiedtke ! parameter(momtrans = 2 ) ! ------- - +! !-------------------- ! switches for deep, mid, shallow convections, downdraft, and momemtum transport ! ------------------ @@ -140,8 +140,8 @@ subroutine cu_ntiedtke( & !-- p8w 3d hydrostatic pressure at full levels (pa) !-- pcps 3d hydrostatic pressure at half levels (pa) !-- pi3d 3d exner function (dimensionless) -!-- qvften 3d total advective moisture tendency (kg kg-1 s-1) -!-- thften 3d total advective temperature tendency (k s-1) +!-- qvften 3d total advective + PBL moisture tendency (kg kg-1 s-1) +!-- thften 3d total advective + PBL + radiative temperature tendency (k s-1) !-- rthcuten theta tendency due to ! cumulus scheme precipitation (k/s) !-- rucuten u wind tendency due to @@ -732,7 +732,7 @@ subroutine cumastrn & real pmflxr(klon,klevp1), pmflxs(klon,klevp1) real zhcbase(klon),& & zmfub(klon), zmfub1(klon),& - & zdqpbl(klon), zdhpbl(klon) + & zdhpbl(klon) real zsfl(klon), zdpmel(klon,klev),& & pcte(klon,klev), zcape(klon),& & zcape1(klon), zcape2(klon),& @@ -1086,6 +1086,17 @@ subroutine cumastrn & end if end do + if ( .not. lmfscv .or. .not. lmfpen ) then + do jl = 1,klon + llo2(jl) = .false. + if ( (.not. lmfscv .and. ktype(jl) == 2) .or. & + (.not. lmfpen .and. ktype(jl) == 1) ) then + llo2(jl) = .true. + ldcum(jl) = .false. + end if + end do + end if + !* 6.7 set downdraft mass fluxes to zero above cloud top !---------------------------------------------------- do jl = 1,klon @@ -1133,7 +1144,7 @@ subroutine cumastrn & call cudtdqn(klon,klev,itopm2,kctop,idtop,ldcum,loddraf, & ztmst,paph,zgeoh,pgeo,pten,ztenh,pqen,zqenh,pqsen, & zlglac,plude,pmfu,pmfd,zmfus,zmfds,zmfuq,zmfdq,zmful, & - zdmfup,zdpmel,ptte,pqte,pcte) + zdmfup,zdmfdp,zdpmel,ptte,pqte,pcte) !---------------------------------------------------------------- !* 9.0 update tendencies for u and u in subroutine cududv !---------------------------------------------------------------- @@ -1272,6 +1283,31 @@ subroutine cumastrn & end do end if + +!---------------------------------------------------------------------- +!* 10. IN CASE THAT EITHER DEEP OR SHALLOW IS SWITCHED OFF +! NEED TO SET SOME VARIABLES A POSTERIORI TO ZERO +! --------------------------------------------------- + if ( .not. lmfscv .or. .not. lmfpen ) then + do jk = 2 , klev + do jl = 1, klon + if ( llo2(jl) .and. jk >= kctop(jl)-1 ) then + ptu(jl,jk) = pten(jl,jk) + pqu(jl,jk) = pqen(jl,jk) + plu(jl,jk) = 0. + pmfude_rate(jl,jk) = 0. + pmfdde_rate(jl,jk) = 0. + end if + end do + end do + do jl = 1, klon + if ( llo2(jl) ) then + kctop(jl) = klev - 1 + kcbot(jl) = klev - 1 + end if + end do + end if + return end subroutine cumastrn @@ -1338,10 +1374,13 @@ subroutine cuinin & do jl=1,klon ptenh(jl,jk)=(max(cpd*pten(jl,jk-1)+pgeo(jl,jk-1), & & cpd*pten(jl,jk)+pgeo(jl,jk))-pgeoh(jl,jk))*rcpd + pqenh(jl,jk) = pqen(jl,jk-1) pqsenh(jl,jk)= pqsen(jl,jk-1) zph(jl)=paph(jl,jk) loflag(jl)=.true. end do + + if ( jk >= klev-1 .or. jk < 2 ) cycle ik=jk icall=0 call cuadjtqn(klon,klev,ik,zph,ptenh,pqsenh,loflag,icall) @@ -1509,7 +1548,6 @@ subroutine cutypen & ldcum(jl)=.false. end do - if(lmfscv) then !----------------------------------------------------------- ! let's do test,and check the shallow convection first ! the first level is klev @@ -1698,9 +1736,6 @@ subroutine cutypen & end do end do - end if ! if activate shallow convection - - if(lmfpen) then !----------------------------------------------------------- ! next, let's check the deep convection ! the first level is klevm1-1 @@ -1794,8 +1829,8 @@ subroutine cutypen & do jl=1,klon if(loflag(jl)) then ! define the fscale - fscale = min(1.,(pqsen(jl,jk)/pqsen(jl,klev))**3) - eta(jl) = 0.8*1.75e-3*fscale + fscale = min(1.,(pqsen(jl,jk)/pqsen(jl,levels))**3) + eta(jl) = 1.75e-3*fscale dz(jl) = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg coef(jl)= 0.5*eta(jl)*dz(jl) dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk) @@ -1925,7 +1960,6 @@ subroutine cutypen & end do ! end all cycles - end if ! end actiavating deep convection return end subroutine cutypen @@ -2289,7 +2323,7 @@ subroutine cuascn & end if end if if ( klab(jl,jk+1) == 2 ) then - if ( zbuo(jl,jk) < 0. .and. klab(jl,jk+1) == 2 ) then + if ( zbuo(jl,jk) < 0. ) then ptenh(jl,jk) = 0.5*(pten(jl,jk)+pten(jl,jk-1)) pqenh(jl,jk) = 0.5*(pqen(jl,jk)+pqen(jl,jk-1)) zbuo(jl,jk) = zbc - ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) @@ -2308,7 +2342,7 @@ subroutine cuascn & end if kup(jl,jk) = (kup(jl,jk+1)*(1.-zdken)+zdkbuo) / & (1.+zdken) - if ( zbuo(jl,jk) < 0. .and. klab(jl,jk+1) == 2 ) then + if ( zbuo(jl,jk) < 0. ) then zkedke = kup(jl,jk)/max(1.e-10,kup(jl,jk+1)) zkedke = max(0.,min(1.,zkedke)) zmfun = sqrt(zkedke)*pmfu(jl,jk+1) @@ -2316,7 +2350,7 @@ subroutine cuascn & plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl) pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl) end if - if ( zbuo(jl,jk) >-0.2 .and. klab(jl,jk+1) == 2 ) then + if ( zbuo(jl,jk) > 0. ) then ikb = kcbot(jl) zoentr(jl) = 1.75e-3*(0.3-(min(1.,pqen(jl,jk-1) / & pqsen(jl,jk-1))-1.))*(pgeoh(jl,jk-1)-pgeoh(jl,jk)) * & @@ -2364,7 +2398,7 @@ subroutine cuascn & zdshrd = 3.e-4 end if ikb=kcbot(jl) - if ( plu(jl,jk) > zdshrd .and.(paph(jl,ikb)-paph(jl,jk))>zdnoprc)then + if ( plu(jl,jk) > zdshrd )then zwu = min(15.0,sqrt(2.*max(0.1,kup(jl,jk+1)))) zprcon = zprcdgw/(0.75*zwu) ! PARAMETERS FOR BERGERON-FINDEISEN PROCESS (T < -5C) @@ -2775,116 +2809,90 @@ subroutine cuddrafn & ! (c) checking for negative buoyancy and ! specifying final t,q,u,v and downward fluxes ! ------------------------------------------------- - do jl=1,klon - zoentr(jl)=0. - zbuoy(jl)=0. - zdmfen(jl)=0. + do jl=1,klon + zdmfen(jl)=0. zdmfde(jl)=0. - enddo + enddo do jk=1,klev do jl=1,klon pmfdde_rate(jl,jk) = 0. end do - end do - - do jk=3,klev - is=0 - do jl=1,klon - zph(jl)=paph(jl,jk) - llo2(jl)=lddraf(jl).and.pmfd(jl,jk-1).lt.0. - if(llo2(jl)) then - is=is+1 - endif - enddo - if(is.eq.0) cycle - - do jl=1,klon - if(llo2(jl)) then - zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg - zdmfen(jl)=zentr - zdmfde(jl)=zentr - endif - enddo - - if(jk.gt.itopde) then - do jl=1,klon - if(llo2(jl)) then - zdmfen(jl)=0. - zdmfde(jl)=pmfd(jl,itopde)* & - & (paph(jl,jk)-paph(jl,jk-1))/ & - & (paph(jl,klev+1)-paph(jl,itopde)) - endif - enddo - endif + end do - if(jk.le.itopde) then - do jl=1,klon - if(llo2(jl)) then - zdz=-(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg - zzentr=zoentr(jl)*zdz*pmfd(jl,jk-1) - zdmfen(jl)=zdmfen(jl)+zzentr - zdmfen(jl)=max(zdmfen(jl),0.3*pmfd(jl,jk-1)) - zdmfen(jl)=max(zdmfen(jl),-0.75*pmfu(jl,jk)- & - & (pmfd(jl,jk-1)-zdmfde(jl))) - zdmfen(jl)=min(zdmfen(jl),0.) - endif - enddo - endif + do jk=3,klev + is=0 + do jl=1,klon + zph(jl)=paph(jl,jk) + llo2(jl)=lddraf(jl).and.pmfd(jl,jk-1).lt.0. + if(llo2(jl)) then + is=is+1 + endif + end do + + if(is.eq.0) cycle + do jl=1,klon + if(llo2(jl)) then + zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg + zdmfen(jl)=zentr + zdmfde(jl)=zentr + end if + end do - do jl=1,klon - if(llo2(jl)) then + if(jk.gt.itopde) then + do jl=1,klon + if(llo2(jl)) then + zdmfen(jl)=0. + zdmfde(jl)=pmfd(jl,itopde)* & + (paph(jl,jk)-paph(jl,jk-1))/ & + (paph(jl,klev+1)-paph(jl,itopde)) + end if + end do + end if + + do jl=1,klon + if(llo2(jl)) then pmfd(jl,jk)=pmfd(jl,jk-1)+zdmfen(jl)-zdmfde(jl) - zseen=(cpd*ptenh(jl,jk-1)+pgeoh(jl,jk-1))*zdmfen(jl) - zqeen=pqenh(jl,jk-1)*zdmfen(jl) - zsdde=(cpd*ptd(jl,jk-1)+pgeoh(jl,jk-1))*zdmfde(jl) - zqdde=pqd(jl,jk-1)*zdmfde(jl) - zmfdsk=pmfds(jl,jk-1)+zseen-zsdde - zmfdqk=pmfdq(jl,jk-1)+zqeen-zqdde - pqd(jl,jk)=zmfdqk*(1./min(-cmfcmin,pmfd(jl,jk))) - ptd(jl,jk)=(zmfdsk*(1./min(-cmfcmin,pmfd(jl,jk)))-& - & pgeoh(jl,jk))*rcpd - ptd(jl,jk)=min(400.,ptd(jl,jk)) - ptd(jl,jk)=max(100.,ptd(jl,jk)) - zcond(jl)=pqd(jl,jk) - endif - enddo - - ik=jk - icall=2 - call cuadjtqn(klon, klev, ik, zph, ptd, pqd, llo2, icall ) - - do jl=1,klon - if(llo2(jl)) then + zseen=(cpd*ptenh(jl,jk-1)+pgeoh(jl,jk-1))*zdmfen(jl) + zqeen=pqenh(jl,jk-1)*zdmfen(jl) + zsdde=(cpd*ptd(jl,jk-1)+pgeoh(jl,jk-1))*zdmfde(jl) + zqdde=pqd(jl,jk-1)*zdmfde(jl) + zmfdsk=pmfds(jl,jk-1)+zseen-zsdde + zmfdqk=pmfdq(jl,jk-1)+zqeen-zqdde + pqd(jl,jk)=zmfdqk*(1./min(-cmfcmin,pmfd(jl,jk))) + ptd(jl,jk)=(zmfdsk*(1./min(-cmfcmin,pmfd(jl,jk)))- & + pgeoh(jl,jk))*rcpd + ptd(jl,jk)=min(400.,ptd(jl,jk)) + ptd(jl,jk)=max(100.,ptd(jl,jk)) + zcond(jl)=pqd(jl,jk) + end if + end do + + ik=jk + icall=2 + call cuadjtqn(klon,klev,ik,zph,ptd,pqd,llo2,icall) + do jl=1,klon + if(llo2(jl)) then zcond(jl)=zcond(jl)-pqd(jl,jk) - zbuo=ptd(jl,jk)*(1.+vtmpc1 *pqd(jl,jk))- & - & ptenh(jl,jk)*(1.+vtmpc1 *pqenh(jl,jk)) - if(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then - zrain=prfl(jl)/pmfu(jl,jk) + zbuo=ptd(jl,jk)*(1.+vtmpc1*pqd(jl,jk))- & + ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk)) + if(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then + zrain=prfl(jl)/pmfu(jl,jk) zbuo=zbuo-ptd(jl,jk)*zrain - endif - if(zbuo.ge.0 .or. prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then - pmfd(jl,jk)=0. - zbuo=0. endif - pmfds(jl,jk)=(cpd*ptd(jl,jk)+pgeoh(jl,jk))*pmfd(jl,jk) - pmfdq(jl,jk)=pqd(jl,jk)*pmfd(jl,jk) - zdmfdp=-pmfd(jl,jk)*zcond(jl) - pdmfdp(jl,jk-1)=zdmfdp - prfl(jl)=prfl(jl)+zdmfdp - -! compute organized entrainment for use at next level - zbuoyz=zbuo/ptenh(jl,jk) - zbuoyz=min(zbuoyz,0.0) - zdz=-(pgeo(jl,jk-1)-pgeo(jl,jk)) - zbuoy(jl)=zbuoy(jl)+zbuoyz*zdz - zoentr(jl)=g*zbuoyz*0.5/(1.+zbuoy(jl)) + if(zbuo.ge.0..or.prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then + pmfd(jl,jk)=0. + end if + pmfds(jl,jk)=(cpd*ptd(jl,jk)+pgeoh(jl,jk))*pmfd(jl,jk) + pmfdq(jl,jk)=pqd(jl,jk)*pmfd(jl,jk) + zdmfdp=-pmfd(jl,jk)*zcond(jl) + pdmfdp(jl,jk-1)=zdmfdp + prfl(jl)=prfl(jl)+zdmfdp pmfdde_rate(jl,jk) = -zdmfde(jl) - endif - enddo + end if + end do - enddo - + end do return end subroutine cuddrafn !--------------------------------------------------------- @@ -3042,7 +3050,7 @@ subroutine cuflxn & pmfuq(jl,jk)=pmfuq(jl,jk)-pmfu(jl,jk)*pqenh(jl,jk) plglac(jl,jk)=pmfu(jl,jk)*plglac(jl,jk) llddraf = lddraf(jl) .and. jk >= kdtop(jl) - if ( llddraf ) then + if ( llddraf .and.jk.ge.kdtop(jl)) then pmfds(jl,jk) = pmfds(jl,jk)-pmfd(jl,jk) * & (cpd*ptenh(jl,jk)+pgeoh(jl,jk)) pmfdq(jl,jk) = pmfdq(jl,jk)-pmfd(jl,jk)*pqenh(jl,jk) @@ -3219,7 +3227,7 @@ end subroutine cuflxn subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & lddraf,ztmst,paph,pgeoh,pgeo,pten,ptenh,pqen, & pqenh,pqsen,plglac,plude,pmfu,pmfd,pmfus,pmfds, & - pmfuq,pmfdq,pmful,pdmfup,pdpmel,ptent,ptenq,pcte) + pmfuq,pmfdq,pmful,pdmfup,pdmfdp,pdpmel,ptent,ptenq,pcte) implicit none integer klon,klev,ktopm2 integer kctop(klon), kdtop(klon) @@ -3234,7 +3242,7 @@ subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & pmfus(klon,klev), pmfds(klon,klev),& pmfuq(klon,klev), pmfdq(klon,klev),& pmful(klon,klev), pdmfup(klon,klev),& - pdpmel(klon,klev) + pdpmel(klon,klev), pdmfdp(klon,klev) real ptent(klon,klev), ptenq(klon,klev) real pcte(klon,klev) @@ -3268,10 +3276,10 @@ subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & zdtdt(jl,jk) = zdp(jl,jk)*rcpd * & (zmfus(jl,jk+1)-zmfus(jl,jk)+zmfds(jl,jk+1) - & zmfds(jl,jk)+alf*plglac(jl,jk)-alf*pdpmel(jl,jk) - & - zalv*(pmful(jl,jk+1)-pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk))) + zalv*(pmful(jl,jk+1)-pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk))) zdqdt(jl,jk) = zdp(jl,jk)*(zmfuq(jl,jk+1) - & zmfuq(jl,jk)+zmfdq(jl,jk+1)-zmfdq(jl,jk)+pmful(jl,jk+1) - & - pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)) + pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk)) end if end do else @@ -3280,9 +3288,9 @@ subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & zalv = foelhm(pten(jl,jk)) zdtdt(jl,jk) = -zdp(jl,jk)*rcpd * & (zmfus(jl,jk)+zmfds(jl,jk)+alf*pdpmel(jl,jk) - & - zalv*(pmful(jl,jk)+pdmfup(jl,jk))) + zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk))) zdqdt(jl,jk) = -zdp(jl,jk)*(zmfuq(jl,jk) + & - zmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk))) + zmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk))) end if end do end if @@ -3295,7 +3303,7 @@ subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, & if ( ldcum(jl) ) then ptent(jl,jk) = ptent(jl,jk) + zdtdt(jl,jk) ptenq(jl,jk) = ptenq(jl,jk) + zdqdt(jl,jk) - pcte(jl,jk) = zdp(jl,jk)*plude(jl,jk) + pcte(jl,jk) = zdp(jl,jk)*plude(jl,jk) end if end do end do diff --git a/wrfv2_fire/phys/module_cu_osas.F b/wrfv2_fire/phys/module_cu_osas.F index 3185c2c1..aebd6915 100755 --- a/wrfv2_fire/phys/module_cu_osas.F +++ b/wrfv2_fire/phys/module_cu_osas.F @@ -425,7 +425,7 @@ SUBROUTINE osasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & ktf=min0(kte,kde-1) itf=min0(ite,ide-1) -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing IF(.not.restart .or. .not.allowed_to_read)THEN !end of zhang's doing diff --git a/wrfv2_fire/phys/module_cu_sas.F b/wrfv2_fire/phys/module_cu_sas.F index 4aa0f333..d92bf2c4 100755 --- a/wrfv2_fire/phys/module_cu_sas.F +++ b/wrfv2_fire/phys/module_cu_sas.F @@ -13,6 +13,7 @@ SUBROUTINE CU_SAS(DT,ITIMESTEP,STEPCU, & P_QC, & MOMMIX, & ! gopal's doing PGCON,sas_mass_flux, & + pert_sas, ens_random_seed, ens_sasamp, & shalconv,shal_pgcon, & HPBL2D,EVAP2D,HEAT2D, & !Kwon for shallow convection P_QI,P_FIRST_SCALAR, & @@ -119,6 +120,9 @@ SUBROUTINE CU_SAS(DT,ITIMESTEP,STEPCU, & REAL, OPTIONAL, INTENT(IN) :: PGCON,sas_mass_flux,shal_pgcon INTEGER, OPTIONAL, INTENT(IN) :: shalconv REAL(kind=kind_phys) :: PGCON_USE,SHAL_PGCON_USE,massf + logical,intent(in) :: pert_sas + integer,intent(in) :: ens_random_seed + real,intent(in) :: ens_sasamp INTEGER :: shalconv_use REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: & RQCCUTEN, & @@ -401,9 +405,10 @@ SUBROUTINE CU_SAS(DT,ITIMESTEP,STEPCU, & ENDDO ENDDO - CALL SASCNVN(IM,IM,KX,JCAP,DELT,DEL,PRSL,PS,PHIL, & + CALL SASCNVN(IM,IM,KX,JCAP,DELT,DEL,PRSL,PS,PHIL, & QL,Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT, & - KTOP,KCNV,SLIMSK,DOT,NCLOUD,PGCON_USE,massf) + KTOP,KCNV,SLIMSK,DOT,NCLOUD,PGCON_USE,massf, & + pert_sas, ens_random_seed, ens_sasamp) ! do i=its,ite RAINCV1(I,J)=RN(I)*1000./STEPCU @@ -526,7 +531,7 @@ SUBROUTINE sasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN, & ktf=min0(kte,kde-1) itf=min0(ite,ide-1) -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing IF(.not.restart .or. .not.allowed_to_read)THEN !end of zhang's doing @@ -2593,7 +2598,8 @@ END SUBROUTINE MSTADBT3 subroutine sascnvn(im,ix,km,jcap,delt,del,prsl,ps,phil,ql, & & q1,t1,u1,v1,rcs,cldwrk,rn,kbot,ktop,kcnv,slimsk, & - & dot,ncloud,pgcon,sas_mass_flux) + & dot,ncloud,pgcon,sas_mass_flux, & + & pert_sas, ens_random_seed, ens_sasamp) ! & dot,ncloud,ud_mf,dd_mf,dt_mf) ! & dot,ncloud,ud_mf,dd_mf,dt_mf,me) ! @@ -2652,6 +2658,9 @@ subroutine sascnvn(im,ix,km,jcap,delt,del,prsl,ps,phil,ql, & & ptem, ptem1 ! real(kind=kind_phys), intent(in) :: pgcon + logical,intent(in) :: pert_sas + integer,intent(in) :: ens_random_seed + real,intent(in) :: ens_sasamp integer kb(im), kbcon(im), kbcon1(im), & & ktcon(im), ktcon1(im), & @@ -2713,25 +2722,17 @@ subroutine sascnvn(im,ix,km,jcap,delt,del,prsl,ps,phil,ql, & real(kind=kind_phys) tf, tcr, tcrf parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf)) #if HWRF==1 - logical :: pert_sas !zhang - integer :: ens_random_seed !zhang real*8 :: gasdev,ran1 !zhang - real :: rr, ens_sasamp !zhang + real :: rr !zhang logical,save :: pert_sas_local !zhang integer,save :: ens_random_seed_local !zhang real,save :: ens_sasamp_local !zhang data ens_random_seed_local/0/ -!zz print*,'zhang in sas=============' if ( ens_random_seed_local .eq. 0 ) then - CALL nl_get_pert_sas(1,pert_sas) - CALL nl_get_ens_random_seed(1,ens_random_seed) - CALL nl_get_ens_sasamp(1,ens_sasamp) - ens_random_seed_local=ens_random_seed - pert_sas_local=pert_sas - ens_sasamp_local=ens_sasamp -!zz print*,"zhang in sas one time", pert_sas_local,ens_random_seed_local,ens_sasamp_local + ens_random_seed_local=ens_random_seed + pert_sas_local=pert_sas + ens_sasamp_local=ens_sasamp endif -!zz print*,"zhang in sas", pert_sas_local,ens_random_seed_local,ens_sasamp_local #endif ! !c----------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_cumulus_driver.F b/wrfv2_fire/phys/module_cumulus_driver.F index 79bf3bd7..cfec8fb6 100644 --- a/wrfv2_fire/phys/module_cumulus_driver.F +++ b/wrfv2_fire/phys/module_cumulus_driver.F @@ -18,6 +18,7 @@ SUBROUTINE cumulus_driver(grid & ,cudtacttime & ,rainc,raincv,pratec,nca & ,cldfra_dp,cldfra_sh,w_up & !ckay for subgrid cloud + ,udr_kf,ddr_kf,uer_kf,der_kf,timec_kf,kf_edrates & !kf_edrates ,QC_CU,QI_CU & ,z,z_at_w,dz8w,mavail,pblh,p8w,psfc,tsk & ,tke_pbl, ust & @@ -27,12 +28,13 @@ SUBROUTINE cumulus_driver(grid & ,hfx,qfx,cldfra,cldfra_mp_all,tpert2d & ,htop,hbot,kpbl,ht & ,ensdim,maxiens,maxens,maxens2,maxens3 & + ,shall & !CuP, wig 18-Sep-2006 #if (EM_CORE == 1) !BSINGH - For WRFCuP Scheme ,akpbl, br,regime,t2,q2 & !CuP, wig 3-Aug-2006 ,slopeSfc, slopeEZ, sigmaSfc, sigmaEZ & !CuP, wig 7-Aug-2006 ,cupflag, cldfra_cup, cldfratend_cup & !CuP, wig 18-Sep-2006 - ,shall, taucloud, tactive & !CuP, wig 18-Sep-2006 + ,taucloud, tactive & !CuP, wig 18-Sep-2006 ,activeFrac & !CuP, lkb 4-May-2010 ,tstar, lnterms, lnint & !CuP, wig 4-Oct-2006 ,numBins, thBinSize, rBinSize & !CUP, lkb 4-Nov-2009 @@ -92,6 +94,8 @@ SUBROUTINE cumulus_driver(grid & ,ktop_deep & ! Optional arguments for SAS scheme ,pgcon,sas_mass_flux & + ,pert_sas,ens_random_seed & + ,ens_sasamp & ,shalconv,shal_pgcon & ,HPBL2D,EVAP2D,HEAT2D & !Kwon for SAS2010 shallow convection ! Optional arguments for NSAS scheme @@ -367,15 +371,21 @@ SUBROUTINE cumulus_driver(grid & LOGICAL, INTENT(IN ) :: is_CAMMGMP_used !BSINGH:01/31/2013: Added for CAMZM REAL, INTENT(IN), OPTIONAL :: pgcon,shal_pgcon,sas_mass_flux + logical,intent(in),optional :: pert_sas + integer,intent(in),optional :: ens_random_seed + real,intent(in),optional :: ens_sasamp INTEGER, INTENT(IN), OPTIONAL :: shalconv INTEGER,DIMENSION( ims:ime, jms:jme ), & INTENT(IN ) :: LOWLYR + + !BSINGH - For WRFCuP scheme + REAL,DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: shall !CuP, wig 18-Sep-2006 #if (EM_CORE == 1) !BSINGH - For WRFCuP scheme REAL,DIMENSION( ims:ime, jms:jme ), & - INTENT(INOUT) :: shall, & !CuP, wig 18-Sep-2006 - taucloud, & !CuP, wig 1-Oct-2006 + INTENT(INOUT) :: taucloud, & !CuP, wig 1-Oct-2006 tactive, & !CuP, wig 1-Oct-2006 activeFrac, & !CuP, lkb 5-May-2010 wCloudBase !CuP, lkb 29-April-2010 @@ -415,6 +425,18 @@ SUBROUTINE cumulus_driver(grid & INTENT(INOUT) :: cldfra_dp & , cldfra_sh +!kf_edrates + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: udr_kf & + , ddr_kf & + , uer_kf & + , der_kf + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT) :: & + timec_kf + + INTEGER, INTENT(IN ) :: kf_edrates + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(INOUT ),OPTIONAL :: w_up @@ -832,6 +854,9 @@ SUBROUTINE cumulus_driver(grid & ,RQICUTEN=rqicuten ,RQSCUTEN=rqscuten & ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr & ,F_QI=f_qi,F_QS=f_qs & + ,UDR_KF=udr_kf,DDR_KF=ddr_kf & !kf_edrates + ,UER_KF=uer_kf,DER_KF=der_kf & + ,TIMEC_KF=timec_kf,KF_EDRATES=kf_edrates & ) CASE (BMJSCHEME) @@ -871,6 +896,7 @@ SUBROUTINE cumulus_driver(grid & ,STEPCU=stepcu & ,CU_ACT_FLAG=cu_act_flag ,WARM_RAIN=warm_rain & ,QV=qv_curr & + ,SHALL=shall & !BSINGH - For WRFCuP scheme added "shall" ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & @@ -884,7 +910,10 @@ SUBROUTINE cumulus_driver(grid & ,F_QI=f_qi,F_QS=f_qs & ,CLDFRA_DP_KF=cldfra_dp & ! ckay for sub-grid cloud ,CLDFRA_SH_KF=cldfra_sh & - ,QC_KF=QC_CU,QI_KF=QI_CU ) + ,QC_KF=QC_CU,QI_KF=QI_CU & + ,UDR_KF=udr_kf,DDR_KF=ddr_kf & !kf_edrates + ,UER_KF=uer_kf,DER_KF=der_kf & + ,TIMEC_KF=timec_kf,KF_EDRATES=kf_edrates ) #if (EM_CORE==1) CASE (MSKFSCHEME) @@ -919,6 +948,9 @@ SUBROUTINE cumulus_driver(grid & ,CLDFRA_SH_KF=cldfra_sh & ,W_UP=w_up & ! ckay ,QC_KF=QC_CU,QI_KF=QI_CU & + ,UDR_KF=udr_kf,DDR_KF=ddr_kf & !kf_edrates + ,UER_KF=uer_kf,DER_KF=der_kf & + ,TIMEC_KF=timec_kf,KF_EDRATES=kf_edrates & ,ZOL=zol,WSTAR=wstar,UST=ust,PBLH=pblh ) !ckay #endif @@ -984,6 +1016,8 @@ SUBROUTINE cumulus_driver(grid & ,P_QC=p_qc & ,MOMMIX=MOMMIX & ,pgcon=pgcon,sas_mass_flux=sas_mass_flux & + ,pert_sas=pert_sas,ens_random_seed=ens_random_seed & + ,ens_sasamp=ens_sasamp & ,shalconv=shalconv,shal_pgcon=shal_pgcon & ,hpbl2d=hpbl2d,evap2d=evap2d,heat2d=heat2d & ,P_QI=p_qi,P_FIRST_SCALAR=param_first_scalar & diff --git a/wrfv2_fire/phys/module_data_gocart_dust.F b/wrfv2_fire/phys/module_data_gocart_dust.F index d12bbc58..4912304e 100644 --- a/wrfv2_fire/phys/module_data_gocart_dust.F +++ b/wrfv2_fire/phys/module_data_gocart_dust.F @@ -1,32 +1,34 @@ -Module module_data_gocart_dust - INTEGER, PARAMETER :: ndust=5,ndcls=3,ndsrc=1,maxstypes=100 - INTEGER, PARAMETER :: ngsalt=9 -! GAC--> -! 20130219 - Drypoint no longer needed. Use NOAA porosity for all schemes to -! allow use of AFWA dust scheme by all LSMs, not just NOAA and RUC. -! real, dimension (maxstypes) :: drypoint -! real, dimension (maxstypes) :: porosity - real, dimension (19), PARAMETER :: porosity=(/0.339, 0.421, 0.434, 0.476, 0.476, 0.439, & - 0.404, 0.464, 0.465, 0.406, 0.468, 0.468, & - 0.439, 1.000, 0.200, 0.421, 0.468, 0.200, & - 0.339/) -! <--GAC - - REAL :: ch_dust(ndust,12) - REAL, PARAMETER :: dyn_visc = 1.5E-5 - real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) - real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) - INTEGER, DIMENSION (5), PARAMETER :: ipoint(5)=(/3,2,2,2,2/) - REAL, DIMENSION (5), PARAMETER :: frac_s(5)=(/0.1,0.25,0.25,0.25,0.25/) - - real*8, DIMENSION (ngsalt), PARAMETER :: reff_salt=(/0.71D-6,1.37D-6,2.63D-6,5.00D-6,9.50D-6,18.1D-6,34.5D-6,65.5D-6,125.D-6/) - real*8, DIMENSION (ngsalt), PARAMETER :: den_salt=(/2500.,2650.,2650.,2650.,2650.,2650.,2650.,2650.,2650./) - INTEGER, DIMENSION (ngsalt), PARAMETER :: spoint=(/1,2,2,2,2,2,3,3,3/) ! 1 Clay, 2 Silt, 3 Sand - real*8, DIMENSION (ngsalt), PARAMETER :: frac_salt=(/1.,0.2,0.2,0.2,0.2,0.2,0.333,0.333,0.333/) - - real*8, DIMENSION (ndust), PARAMETER :: distr_dust=(/1.074D-1,1.012D-1,2.078D-1,4.817D-1,1.019D-1/) -! real*8, DIMENSION (ndust), PARAMETER :: lo_dust=(/0.1D-6,1.0D-6,1.8D-6,3.0D-6,6.0D-6/) -! real*8, DIMENSION (ndust), PARAMETER :: up_dust=(/1.0D-6,1.8D-6,3.0D-6,6.0D-6,10.0D-6/) - -END Module module_data_gocart_dust - +Module module_data_gocart_dust + INTEGER, PARAMETER :: ndust=5,ndcls=3,ndsrc=1,maxstypes=100 + INTEGER, PARAMETER :: ngsalt=9 +! GAC--> +! 20130219 - Drypoint no longer needed. Use NOAA porosity for all schemes to +! allow use of AFWA dust scheme by all LSMs, not just NOAA and RUC. +! real, dimension (maxstypes) :: drypoint +! real, dimension (maxstypes) :: porosity + real, dimension (19), PARAMETER :: porosity=(/0.339, 0.421, 0.434, 0.476, 0.476, 0.439, & + 0.404, 0.464, 0.465, 0.406, 0.468, 0.468, & + 0.439, 1.000, 0.200, 0.421, 0.468, 0.200, & + 0.339/) +! <--GAC + + REAL :: ch_dust(ndust,12) + REAL, PARAMETER :: dyn_visc = 1.5E-5 +! real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) + real*8, DIMENSION (5) :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./) + real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/) + INTEGER, DIMENSION (5), PARAMETER :: ipoint(5)=(/3,2,2,2,2/) + REAL, DIMENSION (5), PARAMETER :: frac_s(5)=(/0.1,0.25,0.25,0.25,0.25/) + + real*8, DIMENSION (ngsalt), PARAMETER :: reff_salt=(/0.71D-6,1.37D-6,2.63D-6,5.00D-6,9.50D-6,18.1D-6,34.5D-6,65.5D-6,125.D-6/) + real*8, DIMENSION (ngsalt), PARAMETER :: den_salt=(/2500.,2650.,2650.,2650.,2650.,2650.,2650.,2650.,2650./) + INTEGER, DIMENSION (ngsalt), PARAMETER :: spoint=(/1,2,2,2,2,2,3,3,3/) ! 1 Clay, 2 Silt, 3 Sand + real*8, DIMENSION (ngsalt), PARAMETER :: frac_salt=(/1.,0.2,0.2,0.2,0.2,0.2,0.333,0.333,0.333/) + + real*8, DIMENSION (ndust), PARAMETER :: distr_dust=(/1.074D-1,1.012D-1,2.078D-1,4.817D-1,1.019D-1/) +! real*8, DIMENSION (ndust), PARAMETER :: lo_dust=(/0.1D-6,1.0D-6,1.8D-6,3.0D-6,6.0D-6/) +! real*8, DIMENSION (ndust), PARAMETER :: up_dust=(/1.0D-6,1.8D-6,3.0D-6,6.0D-6,10.0D-6/) + +END Module module_data_gocart_dust + + diff --git a/wrfv2_fire/phys/module_diag_cl.F b/wrfv2_fire/phys/module_diag_cl.F index 61d7c2d1..a95239a2 100644 --- a/wrfv2_fire/phys/module_diag_cl.F +++ b/wrfv2_fire/phys/module_diag_cl.F @@ -139,9 +139,12 @@ SUBROUTINE clwrf_output_calc( & CHARACTER (LEN=1024) :: message INTEGER, INTENT(INOUT) :: nsteps LOGICAL :: is_restart +! local vars + REAL :: t273 !----------------------------------------------------------------- -! Compute minutes from reference times clwrfH + + t273 = 273. ! Initialize [var] values ! SET START AND END POINTS FOR TILES @@ -154,12 +157,13 @@ SUBROUTINE clwrf_output_calc( & IF ( wrf_dm_on_monitor() ) THEN CALL wrf_debug(0, 'Re-initializing accumulation arrays') ENDIF + nsteps = 1 DO j = j_start(ij), j_end(ij) DO i = i_start(ij), i_end(ij) - t2clmin(i,j)=t2(i,j) - t2clmax(i,j)=t2(i,j) - t2clmean(i,j)=t2(i,j) - t2clstd(i,j)=t2(i,j)*t2(i,j) + t2clmin(i,j)=t2(i,j)-t273 + t2clmax(i,j)=t2(i,j)-t273 + t2clmean(i,j)=t2(i,j)-t273 + t2clstd(i,j)=(t2(i,j)-t273)*(t2(i,j)-t273) q2clmin(i,j)=q2(i,j) q2clmax(i,j)=q2(i,j) q2clmean(i,j)=q2(i,j) @@ -177,25 +181,19 @@ SUBROUTINE clwrf_output_calc( & rainncclmean(i,j)=rainncv(i,j)/dt raincclstd(i,j)=(raincv(i,j)/dt)*(raincv(i,j)/dt) rainncclstd(i,j)=(rainncv(i,j)/dt)*(rainncv(i,j)/dt) - skintempclmin(i,j)=skintemp(i,j) - skintempclmax(i,j)=skintemp(i,j) - skintempclmean(i,j)=skintemp(i,j) - skintempclstd(i,j)=skintemp(i,j)*skintemp(i,j) -! nsteps=0 + skintempclmin(i,j)=skintemp(i,j)-t273 + skintempclmax(i,j)=skintemp(i,j)-t273 + skintempclmean(i,j)=skintemp(i,j)-t273 + skintempclstd(i,j)=(skintemp(i,j)-t273)*(skintemp(i,j)-t273) ENDDO ENDDO - ENDDO + ENDDO ! nsteps=clwrfH*60./dt ELSE xtimep = xtime + dt/60. ! value at end of timestep for time info nsteps=nsteps+1 -! nsteps=clwrfH*60./dt -! DO j = j_start(ij), j_end(ij) -! DO i = i_start(ij), i_end(ij) -! DO j = jps, jpe -! DO i = ips, ipe ! Temperature - CALL varstatistics(t2,xtimep,ime-ims+1,jme-jms+1,t2clmin,t2clmax, & + CALL varstatistics(t2-t273,xtimep,ime-ims+1,jme-jms+1,t2clmin,t2clmax, & tt2clmin,tt2clmax,t2clmean,t2clstd) ! Water vapor mixing ratio CALL varstatistics(q2,xtimep,ime-ims+1,jme-jms+1,q2clmin,q2clmax, & @@ -210,7 +208,7 @@ SUBROUTINE clwrf_output_calc( & CALL varstatisticsMAX(rainncv/dt,xtimep,ime-ims+1,jme-jms+1, & rainncclmax,trainncclmax,rainncclmean,rainncclstd) ! Skin Temperature - CALL varstatistics(skintemp,xtimep,ime-ims+1,jme-jms+1,skintempclmin,& + CALL varstatistics(skintemp-t273,xtimep,ime-ims+1,jme-jms+1,skintempclmin,& skintempclmax,tskintempclmin,tskintempclmax,skintempclmean, & skintempclstd) @@ -221,8 +219,13 @@ SUBROUTINE clwrf_output_calc( & PRINT *,'nsteps=',nsteps,' xtime:', xtime,' clwrfH:',clwrfH t2clmean=t2clmean/nsteps t2clstd=SQRT(t2clstd/nsteps-t2clmean**2.) + t2clmean=t2clmean+t273 + t2clmin=t2clmin+t273 + t2clmax=t2clmax+t273 q2clmean=q2clmean/nsteps - q2clstd=SQRT(q2clstd/nsteps-q2clmean**2.) + q2clstd=q2clstd/nsteps-q2clmean*q2clmean + q2clstd=MAX(q2clstd,0.) + q2clstd=SQRT(q2clstd) u10clmean=u10clmean/nsteps v10clmean=v10clmean/nsteps spduv10clmean=spduv10clmean/nsteps @@ -235,8 +238,12 @@ SUBROUTINE clwrf_output_calc( & raincclstd=SQRT(raincclstd/nsteps-raincclmean**2.) rainncclstd=SQRT(rainncclstd/nsteps-rainncclmean**2.) skintempclmean=skintempclmean/nsteps - skintempclstd=SQRT(skintempclstd/nsteps-skintempclmean**2.) - nsteps = 0 + skintempclstd=skintempclstd/nsteps-skintempclmean*skintempclmean + skintempclstd=MAX(skintempclstd,0.) + skintempclstd=SQRT(skintempclstd) + skintempclmean=skintempclmean+t273 + skintempclmin=skintempclmin+t273 + skintempclmax=skintempclmax+t273 IF ( wrf_dm_on_monitor() ) THEN DO ij = 1 , num_tiles idp = i_start(ij)+(i_end(ij)-i_start(ij))/2 diff --git a/wrfv2_fire/phys/module_diag_misc.F b/wrfv2_fire/phys/module_diag_misc.F index a69144ac..b006c143 100644 --- a/wrfv2_fire/phys/module_diag_misc.F +++ b/wrfv2_fire/phys/module_diag_misc.F @@ -64,7 +64,7 @@ SUBROUTINE diagnostic_output_calc( & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME, & WSM6SCHEME, ETAMPNEW, THOMPSON, THOMPSONAERO, & MORR_TWO_MOMENT, GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, & - NSSL_2MOM, NSSL_2MOMCCN, NSSL_1MOM, NSSL_1MOMLFO, & + NSSL_2MOM, NSSL_2MOMG, NSSL_2MOMCCN, NSSL_1MOM, NSSL_1MOMLFO, & MILBRANDT2MOM , CAMMGMPSCHEME, FAST_KHAIN_LYNN, FULL_KHAIN_LYNN !,MILBRANDT3MOM, NSSL_3MOM IMPLICIT NONE @@ -250,7 +250,8 @@ SUBROUTINE diagnostic_output_calc( & REAL :: depth DOUBLE PRECISION:: hail_max - DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.01d0 ! number conc. of graupel/hail per cubic meter + REAL:: hail_max_sp + DOUBLE PRECISION, PARAMETER:: thresh_conc = 0.001d0 ! number conc. of graupel/hail per cubic meter LOGICAL:: scheme_has_graupel INTEGER, PARAMETER:: ngbins=50 DOUBLE PRECISION, DIMENSION(ngbins+1):: xxDx @@ -882,7 +883,7 @@ SUBROUTINE diagnostic_output_calc( & ! CASE (MILBRANDT3MOM) ! coming in future? - CASE (NSSL_1MOMLFO, NSSL_1MOM, NSSL_2MOM, NSSL_2MOMCCN) + CASE (NSSL_1MOMLFO, NSSL_1MOM, NSSL_2MOM, NSSL_2MOMG, NSSL_2MOMCCN) scheme_has_graupel = .true. xrho_g = nssl_rho_qh @@ -987,10 +988,11 @@ SUBROUTINE diagnostic_output_calc( & WRITE(outstring,*) 'GT-Debug-Hail, ', hail_max*1000. CALL wrf_debug (350, TRIM(outstring)) endif + hail_max_sp = hail_max if (k.eq.kms) then - hail_maxk1(i,j) = MAX(hail_maxk1(i,j), hail_max) + hail_maxk1(i,j) = MAX(hail_maxk1(i,j), hail_max_sp) endif - hail_max2d(i,j) = MAX(hail_max2d(i,j), hail_max) + hail_max2d(i,j) = MAX(hail_max2d(i,j), hail_max_sp) ENDDO ENDDO ENDDO diff --git a/wrfv2_fire/phys/module_diag_zld.F b/wrfv2_fire/phys/module_diag_zld.F new file mode 100644 index 00000000..b39a1cec --- /dev/null +++ b/wrfv2_fire/phys/module_diag_zld.F @@ -0,0 +1,214 @@ +#if (NMM_CORE == 1) +MODULE module_diag_zld +CONTAINS + SUBROUTINE diag_zld_stub + END SUBROUTINE diag_zld_stub +END MODULE module_diag_zld +#else +!WRF:MEDIATION_LAYER:PHYSICS +! + +MODULE module_diag_zld +CONTAINS + + SUBROUTINE zld ( u,v,w,t,qv,zp,zb,pp,pb,p,pw, & + msfux,msfuy,msfvx,msfvy,msftx,msfty, & + f,e,ht, & + use_tot_or_hyd_p,extrap_below_grnd,missing, & + num_z_levels,max_z_levels,z_levels, & + z_zl,u_zl,v_zl,t_zl,rh_zl,ght_zl,s_zl,td_zl, & + q_zl, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_model_constants + + IMPLICIT NONE + + + ! Input variables + + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + REAL , INTENT(IN ) , DIMENSION(ims:ime , jms:jme) :: msfux,msfuy,msfvx,msfvy,msftx,msfty, & + f,e,ht + INTEGER, INTENT(IN ) :: use_tot_or_hyd_p + INTEGER, INTENT(IN ) :: extrap_below_grnd + REAL , INTENT(IN ) :: missing + REAL , INTENT(IN ) , DIMENSION(ims:ime , kms:kme , jms:jme) :: u,v,w,t,qv,zp,zb,pp,pb,p,pw + INTEGER, INTENT(IN ) :: num_z_levels, max_z_levels + REAL , INTENT(IN ) , DIMENSION(max_z_levels) :: z_levels + + ! Output variables + + REAL , INTENT( OUT) , DIMENSION(num_z_levels) :: z_zl + REAL , INTENT( OUT) , DIMENSION(ims:ime , num_z_levels , jms:jme) :: u_zl,v_zl,t_zl,rh_zl,ght_zl,s_zl,td_zl,q_zl + + ! Local variables + + REAL, PARAMETER :: eps = 0.622, t_kelvin = svpt0 , s1 = 243.5, s2 = svp2 , s3 = svp1*10., s4 = 611.0, s5 = 5418.12 + REAL, PARAMETER :: zshul=75., tvshul=290.66 + + INTEGER :: i, j, ke, kz, ke_h, ke_f + REAL :: zu, zd, zm , & + tu, td , & + su, sd , & + uu, ud , & + vu, vd , & + qu, qd , & + eu, ed, em , & + pu, pd, pm , & + du, dd + REAL :: es, qs + REAL :: part, gammas, tvu, tvd + + ! Silly, but transfer the small namelist.input array into the grid structure for output purposes. + + DO kz = 1 , num_z_levels + z_zl(kz) = z_levels(kz) + END DO + + ! Initialize height level data to un-initialized + + DO j = jts , jte + DO kz = 1 , num_z_levels + DO i = its , ite + u_zl (i,kz,j) = missing + v_zl (i,kz,j) = missing + t_zl (i,kz,j) = missing + rh_zl (i,kz,j) = missing + ght_zl(i,kz,j) = missing + s_zl (i,kz,j) = missing + td_zl (i,kz,j) = missing + END DO + END DO + END DO + + ! Loop over each i,j location + + j_loop : DO j = jts , MIN(jte,jde-1) + i_loop : DO i = its , MIN(ite,ide-1) + + ! For each i,j location, loop over the selected + ! pressure levels to find + + ke_h = kts + ke_f = kts + kz_loop : DO kz = 1 , num_z_levels + + ! For this particular i,j and height level, find the + ! eta levels that surround this point on half-levels. + ! Negative heights are a flag to do AGL. + + ke_loop_half : DO ke = ke_h , kte-2 + + zm = ABS(z_zl(kz)) + IF ( z_zl(kz) .LT. 1 ) THEN + zu = ( zp(i,ke+1,j)+zb(i,ke+1,j) + zp(i,ke+2,j)+zb(i,ke+2,j) ) / 2.0 / 9.8 - ht(i,j) + zd = ( zp(i,ke ,j)+zb(i,ke ,j) + zp(i,ke+1,j)+zb(i,ke+1,j) ) / 2.0 / 9.8 - ht(i,j) + ELSE + zu = ( zp(i,ke+1,j)+zb(i,ke+1,j) + zp(i,ke+2,j)+zb(i,ke+2,j) ) / 2.0 / 9.8 + zd = ( zp(i,ke ,j)+zb(i,ke ,j) + zp(i,ke+1,j)+zb(i,ke+1,j) ) / 2.0 / 9.8 + END IF + + IF ( ( zd .LE. zm ) .AND. ( zu .GT. zm ) ) THEN + + pu = pp(i,ke+1,j)+pb(i,ke+1,j) + pd = pp(i,ke ,j)+pb(i,ke ,j) + pm = ( pu * (zm-zd) + pd * (zu-zm) ) / (zu-zd) + + ! Found trapping height: up, middle, down. + ! We are doing first order interpolation. + ! Now we just put in a list of diagnostics for this level. + + ! 1. Temperature (K) + + tu = (t(i,ke+1,j)+t0)*(pu/p1000mb)**rcp + td = (t(i,ke ,j)+t0)*(pd/p1000mb)**rcp + t_zl(i,kz,j) = ( tu * (zm-zd) + td * (zu-zm) ) / (zu-zd) + + ! 2. Speed (m s-1) + + su = 0.5 * SQRT ( ( u(i,ke+1,j)+u(i+1,ke+1,j) )**2 + & + ( v(i,ke+1,j)+v(i,ke+1,j+1) )**2 ) + sd = 0.5 * SQRT ( ( u(i,ke ,j)+u(i+1,ke ,j) )**2 + & + ( v(i,ke ,j)+v(i,ke ,j+1) )**2 ) + s_zl(i,kz,j) = ( su * (zm-zd) + sd * (zu-zm) ) / (zu-zd) + + ! 3. U and V (m s-1) + + uu = 0.5 * ( u(i,ke+1,j)+u(i+1,ke+1,j) ) + ud = 0.5 * ( u(i,ke ,j)+u(i+1,ke ,j) ) + u_zl(i,kz,j) = ( uu * (zm-zd) + ud * (zu-zm) ) / (zu-zd) + + vu = 0.5 * ( v(i,ke+1,j)+v(i,ke+1,j+1) ) + vd = 0.5 * ( v(i,ke ,j)+v(i,ke ,j+1) ) + v_zl(i,kz,j) = ( vu * (zm-zd) + vd * (zu-zm) ) / (zu-zd) + + ! 4. Mixing ratio (kg/kg) + + qu = MAX(qv(i,ke+1,j),0.) + qd = MAX(qv(i,ke ,j),0.) + q_zl(i,kz,j) = ( qu * (zm-zd) + qd * (zu-zm) ) / (zu-zd) + + ! 5. Dewpoint (K) - Use Bolton's approximation + + eu = qu * pu * 0.01 / ( eps + qu ) ! water vapor press (mb) + ed = qd * pd * 0.01 / ( eps + qd ) ! water vapor press (mb) + eu = max(eu, 0.001) + ed = max(ed, 0.001) + + du = t_kelvin + ( s1 / ((s2 / log(eu/s3)) - 1.0) ) + dd = t_kelvin + ( s1 / ((s2 / log(ed/s3)) - 1.0) ) + td_zl(i,kz,j) = ( du * (zm-zd) + dd * (zu-zm) ) / (zu-zd) + + + ! 6. Relative humidity (%) + + es = s4 * exp(s5 * (1.0 / 273.0 - 1.0 / t_zl(i,kz,j))) + qs = eps * es / (pm - es) + rh_zl(i,kz,j) = q_zl(i,kz,j) / qs * 100. + + ke_h = ke + EXIT ke_loop_half + END IF + END DO ke_loop_half + + ke_loop_full : DO ke = ke_f , kte-1 + + zm = ABS(z_zl(kz)) + IF ( z_zl(kz) .LT. 1 ) THEN + zu = ( zp(i,ke+1,j)+zb(i,ke+1,j) ) / 9.8 - ht(i,j) + zd = ( zp(i,ke ,j)+zb(i,ke ,j) ) / 9.8 - ht(i,j) + ELSE + zu = ( zp(i,ke+1,j)+zb(i,ke+1,j) ) / 9.8 + zd = ( zp(i,ke ,j)+zb(i,ke ,j) ) / 9.8 + END IF + + IF ( ( zd .LE. zm ) .AND. & + ( zu .GT. zm) ) THEN + + ! Found trapping height: up, middle, down. + ! We are doing first order interpolation. + + ! Now we just put in a list of diagnostics for this level. + + ! 1. Geopotential height (m) + + ght_zl(i,kz,j) = ( zu * (zm-zd) + zd * (zu-zm) ) / (zu-zd) + + ke_f = ke + EXIT ke_loop_full + END IF + END DO ke_loop_full + + END DO kz_loop + END DO i_loop + END DO j_loop + + END SUBROUTINE zld + +END MODULE module_diag_zld +#endif diff --git a/wrfv2_fire/phys/module_diagnostics_driver.F b/wrfv2_fire/phys/module_diagnostics_driver.F index 59b7c774..8fd04caf 100644 --- a/wrfv2_fire/phys/module_diagnostics_driver.F +++ b/wrfv2_fire/phys/module_diagnostics_driver.F @@ -36,17 +36,16 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & ! Pick up the number of members for each of the 4d arrays - for declaration purposes. USE module_state_description, ONLY: num_moist, num_chem, num_tracer, num_scalar, & + SKIP_PRESS_DIAGS, SKIP_Z_DIAGS, & P_QG, P_QH, P_QV, & P_QNG, P_QH, P_QNH, P_QR, P_QNR, & - SKIP_PRESS_DIAGS, & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME, & WSM6SCHEME, ETAMPNEW, THOMPSON, THOMPSONAERO, & MORR_TWO_MOMENT, GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, & NSSL_2MOM, NSSL_2MOMCCN, NSSL_1MOM, NSSL_1MOMLFO, & MILBRANDT2MOM , CAMMGMPSCHEME, FAST_KHAIN_LYNN, FULL_KHAIN_LYNN !,MILBRANDT3MOM, NSSL_3MOM, MORR_MILB_P3 - USE module_driver_constants, ONLY: max_plevs - + USE module_driver_constants, ONLY: max_plevs, max_zlevs ! From where we preferably are pulling g, Cp, etc. @@ -73,6 +72,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & USE module_diag_misc, ONLY : diagnostic_output_calc USE module_diag_cl, ONLY : clwrf_output_calc USE module_diag_pld, ONLY : pld + USE module_diag_zld, ONLY : zld USE module_diag_afwa, ONLY : afwa_diagnostics_driver @@ -853,6 +853,78 @@ SUBROUTINE diagnostics_driver ( grid, config_flags, & + + ! Height level and AGL diagnostics. + + + ZL_DIAGNOSTICS : IF ( config_flags%z_lev_diags .NE. SKIP_Z_DIAGS ) THEN + + ! Process the diags if this is the correct time step OR + ! if this is an adaptive timestep forecast. + + TIME_TO_DO_ZL_DIAGS : IF ( ( ( MOD(NINT(curr_secs2+grid%dt),NINT(config_flags%z_lev_interval)) .EQ. 0 ) ) .OR. & + ( config_flags%use_adaptive_time_step ) ) THEN + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + DO ij = 1 , grid%num_tiles + + CALL wrf_debug ( 100 , '--> CALL DIAGNOSTICS PACKAGE: HEIGHT LEVEL AND AGL DIAGNOSTICS' ) + + CALL zld ( & + ! Input data for computing + U=grid%u_2 & + ,V=grid%v_2 & + ,W=grid%w_2 & + ,t=grid%t_2 & + ,qv=moist(:,:,:,P_QV) & + ,zp=grid%ph_2 & + ,zb=grid%phb & + ,pp=grid%p & + ,pb=grid%pb & + ,p=grid%p_hyd & + ,pw=grid%p_hyd_w & + ! Map factors, coriolis for diags + ,msfux=grid%msfux & + ,msfuy=grid%msfuy & + ,msfvx=grid%msfvx & + ,msfvy=grid%msfvy & + ,msftx=grid%msftx & + ,msfty=grid%msfty & + ,f=grid%f & + ,e=grid%e & + ,ht=grid%ht & + ! Namelist info + ,use_tot_or_hyd_p=config_flags%use_tot_or_hyd_p & + ,extrap_below_grnd=config_flags%extrap_below_grnd & + ,missing=config_flags%z_lev_missing & + ! The diagnostics, mostly output variables + ,num_z_levels=config_flags%num_z_levels & + ,max_z_levels=max_zlevs & + ,z_levels=model_config_rec%z_levels & + ,z_zl = grid%z_zl & + ,u_zl = grid%u_zl & + ,v_zl = grid%v_zl & + ,t_zl = grid%t_zl & + ,rh_zl = grid%rh_zl & + ,ght_zl= grid%ght_zl & + ,s_zl = grid%s_zl & + ,td_zl = grid%td_zl & + ,q_zl = grid%q_zl & + ! Dimension arguments + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=grid%i_start(ij),ITE=grid%i_end(ij) & + ,JTS=grid%j_start(ij),JTE=grid%j_end(ij) & + ,KTS=k_start,KTE=k_end+1 ) + END DO + !$OMP END PARALLEL DO + END IF TIME_TO_DO_ZL_DIAGS + END IF ZL_DIAGNOSTICS + + + + ! AFWA diagnostic package. AFWA_DIAGS : IF ( config_flags%afwa_diag_opt == 1 ) THEN diff --git a/wrfv2_fire/phys/module_fdda_psufddagd.F b/wrfv2_fire/phys/module_fdda_psufddagd.F index 5a1fd72d..67df3491 100644 --- a/wrfv2_fire/phys/module_fdda_psufddagd.F +++ b/wrfv2_fire/phys/module_fdda_psufddagd.F @@ -1,5 +1,15 @@ !wrf:model_layer:physics ! +!ckay=KIRAN ALAPATY @ US EPA -- November 01, 2015 +! +! Tim Glotfelty@CNSU; AJ Deng@PSU +!modified for use with FASDAS +!Flux Adjusting Surface Data Assimilation System to assimilate +!surface layer and soil layers temperature and moisture using +! surfance reanalsys +!Reference: Alapaty et al., 2008: Development of the flux-adjusting surface +! data assimilation system for mesoscale models. JAMC, 47, 2331-2350 + ! ! MODULE module_fdda_psufddagd @@ -28,6 +38,8 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & u10_ndg_new, v10_ndg_new, t2_ndg_new, th2_ndg_new, q2_ndg_new, & rh_ndg_new, psl_ndg_new, ps_ndg_new, tob_ndg_new, odis_ndg_new, & RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN,& + fasdas, SDA_HFX, SDA_QFX, & ! fasdas + HFX_FDDA,dz8w, & ! fasdas pblh, ht, regime, znt, z, z_at_w, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -109,6 +121,20 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & rvndgdten, & rthndgdten, & rqvndgdten +! +! FASDAS +! + INTEGER, INTENT(IN) :: fasdas + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: SDA_HFX, & + SDA_QFX + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: HFX_FDDA + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN) :: dz8w +! +! END FASDAS +! REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(INOUT) :: rmundgdten @@ -169,21 +195,38 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & INTEGER :: kpbl, dbg_level REAL :: zpbl, zagl, zagl_bot, zagl_top, tfac, actual_end_fdda_min + !BPR BEGIN + REAL :: tfac_sfc, actual_end_fdda_min_sfc + !BPR END REAL, DIMENSION( its:ite, kts:kte, jts:jte, 4 ) :: wpbl ! 1: u, 2: v, 3: t, 4: q REAL, DIMENSION( kts:kte, 4 ) :: wzfac ! 1: u, 2: v, 3: t, 4: q +! TWG 2015 Pseudo Radiative Flux + REAL, DIMENSION( its:ite, kts:kte, jts:jte) :: rho_air +! END TWG 2015 + LOGICAL , EXTERNAL :: wrf_dm_on_monitor CHARACTER (LEN=256) :: message INTEGER :: int4 + int4 = 1 ! 1: temporal interpolation. else: target nudging toward *_ndg_new values actual_end_fdda_min = end_fdda_hour*60.0 + !BPR BEGIN + actual_end_fdda_min_sfc = end_fdda_hour*60.0 + !BPR END IF( if_ramping == 1 .AND. dtramp_min > 0.0 ) & actual_end_fdda_min = end_fdda_hour*60.0 + ABS(dtramp_min) - IF( xtime > actual_end_fdda_min ) THEN -! If xtime is greater than the end time, no need to calculate tendencies. Just set the tnedencies + !BPR BEGIN + actual_end_fdda_min_sfc = end_fdda_hour_sfc*60.0 + ABS(dtramp_min) + !BPR END + !BPR BEGIN + !IF( xtime > actual_end_fdda_min ) THEN + IF( ( xtime > actual_end_fdda_min ) .AND. ( xtime > actual_end_fdda_min_sfc ) ) THEN + !BPR END +! If xtime is greater than the end time, no need to calculate tendencies. Just set the tendencies ! to zero to turn off nudging and return. DO j = jts, jte DO k = kts, kte @@ -289,13 +332,13 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & itf=MIN0(ite,ide-1) ! ! If the user-defined namelist switches (if_no_pbl_nudging_uv, if_no_pbl_nudging_t, -! if_no_pbl_nudging_q swithes) are set to 1, compute the weighting function, wpbl(:,k,:,:), +! if_no_pbl_nudging_q switches) are set to 1, compute the weighting function, wpbl(:,k,:,:), ! based on the PBL depth. wpbl = 1 above the PBL and wpbl = 0 in the PBL. If all -! the switche are set to zero, wpbl = 1 (default value). +! the switches are set to zero, wpbl = 1 (default value). ! wpbl(:,:,:,:) = 1.0 - IF( if_no_pbl_nudging_uv == 1 .OR. grid_sfdda == 1 ) THEN + IF( if_no_pbl_nudging_uv == 1 .OR. grid_sfdda >= 1 ) THEN DO j=jts,jtf DO i=itsu,itf @@ -349,7 +392,7 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & ENDIF - IF( if_no_pbl_nudging_t == 1 .OR. grid_sfdda == 1 ) THEN + IF( if_no_pbl_nudging_t == 1 .OR. grid_sfdda >= 1 ) THEN DO j=jts,jtf DO i=its,itf @@ -378,7 +421,7 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & ENDIF - IF( if_no_pbl_nudging_q == 1 .OR. grid_sfdda == 1 ) THEN + IF( if_no_pbl_nudging_q == 1 .OR. grid_sfdda >= 1 ) THEN DO j=jts,jtf DO i=its,itf @@ -457,7 +500,7 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & ENDIF ! -! If if_ramping and dtramp_min are defined by user, comput a time weighting function, tfac, +! If if_ramping and dtramp_min are defined by user, compute a time weighting function, tfac, ! for analysis nudging so that at the end of the nudging period (which has to be at a ! analysis time) we ramp down the nudging coefficient, based on the use-defined sign of dtramp_min. ! @@ -465,11 +508,21 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & ! end_fdda_hour-ABS(dtramp_min). ! ! When dtramp_min is positive, ramping starts at end_fdda_hour and ends at -! end_fdda_hour+ABS(dtramp_min). In this case, the obs values are extrapolated using -! the obs tendency saved from the previous FDDA wondow. More specifically for extrapolation, +! end_fdda_hour+ABS(dtramp_min). +! BPR BEGIN +! In this case, during the rampdown we nudge towards the most recent past analysis and ignore +! the future analysis (implemented by setting coef = 0.0) +! THE FOLLOWING COMMENT IS NO LONGER APPLICABLE +! In this case, the obs values are extrapolated using +! the obs tendency saved from the previous FDDA window. More specifically for extrapolation, ! coef (see codes below) is recalculated to reflect extrapolation during the ramping period. +! THE PRECEDING COMMENT IS NOT LONGER APPLICABLE +! BPR END ! tfac = 1.0 + !BPR BEGIN + tfac_sfc = 1.0 + !BPR END IF( if_ramping == 1 .AND. ABS(dtramp_min) > 0.0 ) THEN @@ -483,16 +536,48 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & tfac = 1.0 ELSEIF( xtime >= actual_end_fdda_min-ABS(dtramp_min) .AND. xtime <= actual_end_fdda_min )THEN tfac = ( actual_end_fdda_min - xtime ) / ABS(dtramp_min) - IF( dtramp_min > 0.0 ) coef = (xtime-xtime_old+analysis_interval)/(analysis_interval*1.0) + !BPR BEGIN + !The original method assumed that to be here in the code with dtramp_min>0 + !meant that we were after the valid time of *_ndg_new and so used the + !values *_ndg_old and *_ndg_new to extrapolate a current analysis value. + !HOWEVER, in practice once we get to the valid time of *_ndg_new WRF will + !read in the next pair of *_ndg_old and *_ndg_new values, even if we are + !at the beginning of the rampdown period. Since the *_ndg_new values have + !a valid time after the beginning of the rampdown period we do not want + !to use them as we would be using analyses valid after the supposed end + !time of the analysis nudging. + !IF( dtramp_min > 0.0 ) coef = (xtime-xtime_old+analysis_interval)/(analysis_interval*1.0) + !Use only the *_ndg_old values + IF( dtramp_min > 0.0 ) coef = 0.0 + !BPR END ELSE tfac = 0.0 ENDIF + !BPR BEGIN + !Now calculate the same quantities for surface analysis nudging + !Add actual_end_fdda_min_sfc, tfac_sfc + IF( dtramp_min <= 0.0 ) THEN + actual_end_fdda_min_sfc = end_fdda_hour_sfc*60.0 + ELSE + actual_end_fdda_min_sfc = end_fdda_hour_sfc*60.0 + dtramp_min + ENDIF + + IF( xtime < actual_end_fdda_min_sfc-ABS(dtramp_min) )THEN + tfac_sfc = 1.0 + ELSEIF( xtime >= actual_end_fdda_min_sfc-ABS(dtramp_min) .AND. xtime <= actual_end_fdda_min_sfc )THEN + tfac_sfc = ( actual_end_fdda_min_sfc - xtime ) / ABS(dtramp_min) + ELSE + tfac_sfc = 0.0 + ENDIF + !BPR END + ENDIF + ! ! Surface Analysis Nudging ! - IF( grid_sfdda == 1 ) THEN + IF( grid_sfdda >= 1 ) THEN CALL SFDDAGD(itimestep,dx,dt,xtime, id, & analysis_interval_sfc, end_fdda_hour_sfc, guv_sfc, gt_sfc, gq_sfc, & rinblw, & @@ -508,7 +593,18 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, wpbl, wzfac, if_ramping, dtramp_min, & - actual_end_fdda_min, tfac ) +!BPR BEGIN +! actual_end_fdda_min, tfac & + actual_end_fdda_min_sfc, tfac_sfc & +!BPR END +! +! FASDAS +! + ,fasdas, SDA_HFX, SDA_QFX & +! +! END FASDAS +! + ) ENDIF ! ! Compute 3-D nudging tendencies for u, v, t and q @@ -536,17 +632,51 @@ SUBROUTINE fddagd(itimestep,dx,dt,xtime, & DO j=jts,jtf DO k=kts,ktf DO i=its,itf + + val_analysis = t_ndg_old(i,k,j) *( 1.0 - coef ) + t_ndg_new(i,k,j) * coef RTHNDGDTEN(i,k,j) = RTHNDGDTEN(i,k,j) + gt * wpbl(i,k,j,3) * wzfac(k,3) * tfac * & ( val_analysis - th3d(i,k,j) + 300.0 ) +! +!FASDAS +! +!TWG 2015 Pseudo Radiative Flux + + rho_air(i,k,j) = p3d(i,k,j)/(287.0*th3d(i,k,j)) + HFX_FDDA(i,k,j) = rho_air(i,k,j)*1004.0*RTHNDGDTEN(i,k,j)*dz8w(i,k,j) +!TWG 2015 END +! +!END FASDAS +! val_analysis = q_ndg_old(i,k,j) *( 1.0 - coef ) + q_ndg_new(i,k,j) * coef RQVNDGDTEN(i,k,j) = RQVNDGDTEN(i,k,j) + gq * wpbl(i,k,j,4) * wzfac(k,4) * tfac * & ( val_analysis - qv3d(i,k,j) ) + ENDDO ENDDO ENDDO + !BPR BEGIN + !Diagnostic print + IF ( wrf_dm_on_monitor()) THEN + IF( dbg_level .GE. 10 ) THEN + i0 = (ite-its)/2+its + j0 = (jte-jts)/2+jts + k0 = (kte-kts)/2+kts + WRITE(message,'(a,i1,a,f7.2,a,i4,a,i4,a,i4,a,f7.2,a,f4.2,a,f7.2,a,f4.2,a,f4.2 )') & + ' D0',id,' At xtime=',xtime,' FDDA sample pot. temp. analysis (i=',i0,', j=',j0,' k=', & + k0,') = (t_ndg_old=', t_ndg_old(i0,k0,j0),') * ',1.0-coef,' + (t_ndg_new=', & + t_ndg_new(i0,k0,j0),') * ',coef, ' where tfac=',tfac + CALL wrf_message( TRIM(message) ) + WRITE(message,'(a,i1,a,f7.2,a,i4,a,f7.2,a,f7.2)') & + ' D0',id,' xtime_old=',xtime_old,' analysis_interval=',analysis_interval,' actual_end_fdda_min=', & + actual_end_fdda_min,' dtramp_min=',dtramp_min + CALL wrf_message( TRIM(message) ) + END IF + END IF + !BPR END + END SUBROUTINE fddagd !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -565,8 +695,18 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, wpbl, wzfac, if_ramping, dtramp_min, & - actual_end_fdda_min, tfac) - +!BPR BEGIN +! actual_end_fdda_min, tfac & + actual_end_fdda_min_sfc, tfac_sfc & +!BPR END +! +! FASDAS +! + ,fasdas, SDA_HFX, SDA_QFX & +! +! END FASDAS +! + ) !------------------------------------------------------------------- USE module_model_constants @@ -682,10 +822,10 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & REAL :: xtime_old_sfc, xtime_new_sfc, coef, val_analysis, es INTEGER :: kpbl, dbg_level - REAL :: zpbl, zagl, zagl_bot, zagl_top, tfac, actual_end_fdda_min + REAL :: zpbl, zagl, zagl_bot, zagl_top, tfac_sfc, actual_end_fdda_min_sfc REAL, DIMENSION( its:ite, kts:kte, jts:jte, 4 ), & - INTENT(IN) :: wpbl ! 1: u, 2: v, 3: t, 4: q + INTENT(INout) :: wpbl ! 1: u, 2: v, 3: t, 4: q REAL, DIMENSION( kts:kte, 4 ), & INTENT(IN) :: wzfac ! 1: u, 2: v, 3: t, 4: q REAL, DIMENSION( its:ite, jts:jte) :: wndcor_u, wndcor_v @@ -702,7 +842,18 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & CHARACTER (LEN=256) :: message INTEGER :: iwinds, idd, iqsat, int4 - +! +! FASDAS +! + INTEGER, INTENT(IN) :: fasdas + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT( OUT) :: SDA_HFX, & + SDA_QFX + REAL :: stabFac, exf, DiffTN + REAL, DIMENSION( its:ite, kts:kte, jts:jte ) :: wpblfasdas +! +! END FASDAS +! iwinds = 1 ! 1: Scale the surface wind analysis to the lowest model level, ! if the first model half-layer is greater than 10 meters ! and we are in the free convection regime (REGIME=4.0). else: no @@ -734,7 +885,7 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & CALL wrf_message( TRIM(message) ) ENDIF - IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min ) THEN + IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min_sfc ) THEN ! Find the mid point of the tile and print out the sample values i0 = (ite-its)/2+its j0 = (jte-jts)/2+jts @@ -828,7 +979,7 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & IF ( wrf_dm_on_monitor()) THEN IF( xtime-xtime_old_sfc < 0.5*dt/60.0 ) THEN - IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min ) THEN + IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min_sfc ) THEN i0 = (ite-its)/2+its j0 = (jte-jts)/2+jts WRITE(message,'(a,i1,a,2i4,a,f10.4)') & @@ -868,7 +1019,7 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & ENDDO IF ( wrf_dm_on_monitor()) THEN IF( xtime-xtime_old_sfc < 0.5*dt/60.0 ) THEN - IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min ) THEN + IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min_sfc ) THEN i0 = (ite-its)/2+its j0 = (jte-jts)/2+jts WRITE(message,'(a,i1,a,2i4,a,f10.4)') & @@ -897,7 +1048,7 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & IF ( wrf_dm_on_monitor()) THEN IF( xtime-xtime_old_sfc < 0.5*dt/60.0 ) THEN - IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min ) THEN + IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min_sfc ) THEN i0 = (ite-its)/2+its j0 = (jte-jts)/2+jts DO k = kts, kte @@ -965,7 +1116,7 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & IF ( wrf_dm_on_monitor()) THEN IF( xtime-xtime_old_sfc < 0.5*dt/60.0 ) THEN - IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min ) THEN + IF( dbg_level .GE. 10 .AND. xtime <= actual_end_fdda_min_sfc ) THEN i0 = (ite-its)/2+its j0 = (jte-jts)/2+jts WRITE(message,'(a,i1,a,2i4,4(a,f10.4))') & @@ -979,15 +1130,54 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & ENDIF ! -! TFAC for surface analysis nudging +! tfac_sfc for surface analysis nudging ! - IF( xtime >= actual_end_fdda_min-ABS(dtramp_min) .AND. xtime <= actual_end_fdda_min & + IF( xtime >= actual_end_fdda_min_sfc-ABS(dtramp_min) .AND. xtime <= actual_end_fdda_min_sfc & .AND. dtramp_min > 0.0 .AND. if_ramping == 1 ) & - coef = (xtime-xtime_old_sfc+analysis_interval_sfc)/(analysis_interval_sfc*1.0) + + !BPR BEGIN + !The original method assumed that to be here in the code with dtramp_min>0 + !meant that we were after the valid time of *_ndg_new and so used the + !values *_ndg_old and *_ndg_new to extrapolate a current analysis value. + !HOWEVER, in practice once we get to the valid time of *_ndg_new WRF will + !read in the next pair of *_ndg_old and *_ndg_new values, even if we are + !at the beginning of the rampdown period. Since the *_ndg_new values have + !a valid time after the beginning of the rampdown period we do not want + !to use them as we would be using analyses valid after the supposed end + !time of the analysis nudging. + !coef = (xtime-xtime_old_sfc+analysis_interval_sfc)/(analysis_interval_sfc*1.0) + !Use only the *_ndg_old values + coef = 0.0 + !BPR END + ! print*, 'coef =', xtime_old_sfc, xtime, xtime_new_sfc, coef ! ! Compute surface analysis nudging tendencies for u, v, t and q ! +! FASDAS +! + IF( fasdas == 1 ) THEN + + !Edit TWG2015 Add new variable wpblfasdas to avoid altering global wpbl + !field when using the FASDAS option + + wpblfasdas = 1.0 + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + if( k == 1 ) then + wpblfasdas(i, k, j) = 0.0 + else + wpblfasdas(i, k, j) = 1.0 + endif + ENDDO + ENDDO + ENDDO + + ENDIF +! +! END FASDAS +! DO j=jts,jtf DO k=kts,ktf DO i=itsu,itf @@ -999,7 +1189,7 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & ENDIF val_analysis = u10_ndg_old(i,j) *( 1.0 - coef ) + u10_ndg_new(i,j) * coef val_analysis = val_analysis * wndcor_u(i,j) - RUNDGDTEN(i,k,j) = guv_sfc * (1.0-wpbl(i,k,j,1)) * wzfac(k,1) * tfac * blw * & + RUNDGDTEN(i,k,j) = guv_sfc * (1.0-wpbl(i,k,j,1)) * wzfac(k,1) * tfac_sfc * blw * & ( val_analysis - u3d(i,1,j) ) ENDDO ENDDO @@ -1008,6 +1198,7 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & DO j=jtsv,jtf DO k=kts,ktf DO i=its,itf + IF( idd == 1 ) THEN blw = 0.5* (blw_old(i,j-1)+blw_old(i,j)) * ( 1.0 - coef ) & + 0.5* (blw_new(i,j-1)+blw_new(i,j)) * coef @@ -1016,7 +1207,7 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & ENDIF val_analysis = v10_ndg_old(i,j) *( 1.0 - coef ) + v10_ndg_new(i,j) * coef val_analysis = val_analysis * wndcor_v(i,j) - RVNDGDTEN(i,k,j) = guv_sfc * (1.0-wpbl(i,k,j,2)) * wzfac(k,2) * tfac * blw * & + RVNDGDTEN(i,k,j) = guv_sfc * (1.0-wpbl(i,k,j,2)) * wzfac(k,2) * tfac_sfc * blw * & ( val_analysis - v3d(i,1,j) ) ENDDO ENDDO @@ -1030,23 +1221,99 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime, & ELSE blw = 1.0 ENDIF + +!ckay2015 and TWG2015 add stability factor for stable regime, ensure +!consistency between Direct and Indirect nudging, and Convert potential +!temperature tendency to temperature tendency +! +! FASDAS +! + IF( fasdas == 1 ) THEN + if(regime(i,j).le.1.1) then + stabFac = 1.0/3.0 + else + stabFac = 1.0 + end if + val_analysis = th2_ndg_old(i,j) *( 1.0 - coef ) + th2_ndg_new(i,j) * coef - RTHNDGDTEN(i,k,j) = gt_sfc * (1.0-wpbl(i,k,j,3)) * wzfac(k,3) * tfac * blw * & + !BPR BEGIN + !RTHNDGDTEN(i,k,j) = stabFac*gt_sfc * (1.0-wpblfasdas(i,k,j)) * wzfac(k,3) * tfac * blw * & + RTHNDGDTEN(i,k,j) = stabFac*gt_sfc * (1.0-wpblfasdas(i,k,j)) * wzfac(k,3) * tfac_sfc * blw * & + !BPR END ( val_analysis - th3d(i,1,j)) + DiffTN = val_analysis - th3d(i,1,j) + if(k.eq.1) then + exf = (1.0E05/p3d(i,k,j))**(287./1004.) + SDA_HFX(i,j) = RTHNDGDTEN(i,k,j)/exf !TWG 2015 + else + RTHNDGDTEN(i,k,j) = 0.0 + end if + val_analysis = q2_ndg_old(i,j) *( 1.0 - coef ) + q2_ndg_new(i,j) * coef IF( iqsat == 1 .AND. val_analysis > qsat(i,k,j) ) val_analysis = qsat(i,k,j) - RQVNDGDTEN(i,k,j) = gq_sfc * (1.0-wpbl(i,k,j,4)) * wzfac(k,4) * tfac * blw * & + !BPR BEGIN + !RQVNDGDTEN(i,k,j) = stabFac*gq_sfc * (1.0-wpblfasdas(i,k,j)) * wzfac(k,4) * tfac * blw * & + RQVNDGDTEN(i,k,j) = stabFac*gq_sfc * (1.0-wpblfasdas(i,k,j)) * wzfac(k,4) * tfac_sfc * blw * & + !BPR END ( val_analysis - qv3d(i,k,j) ) + if(k.eq.1) then + SDA_QFX = RQVNDGDTEN(i,k,j) + else + RQVNDGDTEN(i,k,j) = 0.0 + end if + + ELSE + + val_analysis = th2_ndg_old(i,j) *( 1.0 - coef ) + th2_ndg_new(i,j) * coef + !BPR BEGIN + !RTHNDGDTEN(i,k,j) = gt_sfc * (1.0-wpbl(i,k,j,3)) * wzfac(k,3) * tfac * blw * & + RTHNDGDTEN(i,k,j) = gt_sfc * (1.0-wpbl(i,k,j,3)) * wzfac(k,3) * tfac_sfc * blw * & + !BPR END + ( val_analysis - th3d(i,1,j)) + + val_analysis = q2_ndg_old(i,j) *( 1.0 - coef ) + q2_ndg_new(i,j) * coef + IF( iqsat == 1 .AND. val_analysis > qsat(i,k,j) ) val_analysis = qsat(i,k,j) + !BPR BEGIN + !RQVNDGDTEN(i,k,j) = gq_sfc * (1.0-wpbl(i,k,j,4)) * wzfac(k,4) * tfac * blw * & + RQVNDGDTEN(i,k,j) = gq_sfc * (1.0-wpbl(i,k,j,4)) * wzfac(k,4) * tfac_sfc * blw * & + !BPR END + ( val_analysis - qv3d(i,k,j) ) + + ENDIF +! +! END FASDAS +! ENDDO ENDDO ENDDO + !BPR BEGIN + !Diagnostic print + IF ( wrf_dm_on_monitor()) THEN + IF( dbg_level .GE. 10 ) THEN + i0 = (ite-its)/2+its + j0 = (jte-jts)/2+jts + WRITE(message,'(a,i1,a,f7.2,a,i4,a,i4,a,f7.2,a,f4.2,a,f7.2,a,f4.2,a,f4.2 )') & + ' D0',id,' At xtime=',xtime,' SFC FDDA sample TH2 analysis (i=',i0,', j=',j0,') = (th2_ndg_old=', & + th2_ndg_old(i0,j0),') * ',1.0-coef,' + (th2_ndg_new=',th2_ndg_new(i0,j0),') * ',coef, & + ' where tfac_sfc=',tfac_sfc + CALL wrf_message( TRIM(message) ) + WRITE(message,'(a,i1,a,f7.2,a,i4,a,f7.2,a,f7.2)') & + ' D0',id,' xtime_old_sfc=',xtime_old_sfc,' analysis_interval_sfc=',analysis_interval_sfc, & + ' actual_end_fdda_min_sfc=', actual_end_fdda_min_sfc,' dtramp_min=',dtramp_min + CALL wrf_message( TRIM(message) ) + END IF + END IF + !BPR END + END SUBROUTINE sfddagd !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SUBROUTINE fddagdinit(id,rundgdten,rvndgdten,rthndgdten,rqvndgdten,rmundgdten,& + SDA_HFX, SDA_QFX, QNORM, HFX_BOTH, QFX_BOTH, fasdas,& !fasdas + HFX_FDDA, & !fasdas run_hours, & if_no_pbl_nudging_uv, if_no_pbl_nudging_t, if_no_pbl_nudging_q, & if_zfac_uv, k_zfac_uv, if_zfac_t, k_zfac_t, if_zfac_q, k_zfac_q, & @@ -1070,6 +1337,19 @@ SUBROUTINE fddagdinit(id,rundgdten,rvndgdten,rthndgdten,rqvndgdten,rmundgdten,& rvndgdten, & rthndgdten, & rqvndgdten +! +! FASDAS +! + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: & + SDA_HFX, & + SDA_QFX, & + QNORM, HFX_BOTH, QFX_BOTH + INTEGER, INTENT(IN ) :: fasdas + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(OUT) :: & + HFX_FDDA +! +! END FASDAS +! INTEGER, INTENT(IN) :: run_hours INTEGER, INTENT(IN) :: if_no_pbl_nudging_uv, if_no_pbl_nudging_t, & if_no_pbl_nudging_q, end_fdda_hour @@ -1163,7 +1443,7 @@ SUBROUTINE fddagdinit(id,rundgdten,rvndgdten,rthndgdten,rqvndgdten,rmundgdten,& CALL wrf_message(TRIM(message)) ENDIF - IF( grid_sfdda ==1 ) THEN + IF( grid_sfdda >=1 ) THEN IF( guv_sfc > 0.0 ) THEN WRITE(message,'(a,i1,a,e12.4)') & 'D0',id,' surface analysis nudging for wind is applied and Guv_sfc= ', guv_sfc @@ -1231,10 +1511,30 @@ SUBROUTINE fddagdinit(id,rundgdten,rvndgdten,rthndgdten,rqvndgdten,rmundgdten,& rvndgdten(i,k,j) = 0. rthndgdten(i,k,j) = 0. rqvndgdten(i,k,j) = 0. +! TWG 2015 Psuedo radiative flux + HFX_FDDA(i,k,j) = 0. +! TWG END if(k.eq.kts) rmundgdten(i,j) = 0. ENDDO ENDDO ENDDO +! +! FASDAS +! + IF( fasdas == 1 ) THEN + DO j = jts,jte + DO i = its,ite + SDA_HFX(I,J) = 0.0 + SDA_QFX(I,J) = 0.0 + QNORM(I,J) = 0.0 + HFX_BOTH(I,J) = 0.0 + QFX_BOTH(I,J) = 0.0 + ENDDO + ENDDO + ENDIF +! +! END FASDAS +! ENDIF END SUBROUTINE fddagdinit diff --git a/wrfv2_fire/phys/module_fddagd_driver.F b/wrfv2_fire/phys/module_fddagd_driver.F index 374b1459..8856cb37 100644 --- a/wrfv2_fire/phys/module_fddagd_driver.F +++ b/wrfv2_fire/phys/module_fddagd_driver.F @@ -9,6 +9,8 @@ SUBROUTINE fddagd_driver(itimestep,dt,xtime, & id, & RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN, & RPHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN, & + SDA_HFX, SDA_QFX, & !fasdas + HFX_FDDA, & !fasdas u_ndg_old,v_ndg_old,t_ndg_old,ph_ndg_old, & q_ndg_old,mu_ndg_old, & u_ndg_new,v_ndg_new,t_ndg_new,ph_ndg_new, & @@ -170,7 +172,17 @@ SUBROUTINE fddagd_driver(itimestep,dt,xtime, & RTHNDGDTEN, & RPHNDGDTEN, & RQVNDGDTEN - +! +! FASDAS +! + REAL, DIMENSION( ims:ime, jms:jme ), & + INTENT(INOUT) :: SDA_HFX, & + SDA_QFX + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: HFX_FDDA +! +! END FASDAS +! REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(INOUT) :: RMUNDGDTEN @@ -337,6 +349,158 @@ SUBROUTINE fddagd_driver(itimestep,dt,xtime, & CASE (PSUFDDAGD) + !BPR BEGIN + !Add error checks to ensure that user does not use analysis nudging + !options that WRF will read in but not fully utilize + !3D Analysis nudging + + !The begin time of analysis nudging must be the model start time + !It appears the WRF code that reads analysis nudging files respects + !the start time settings, but the actual nudging code does not. This + !leads one to nudge towards 0 in all fields (including potential + !temperature [K]) since the nudging code applies analysis nudging but has + !no data to nudge towards + IF( config_flags%gfdda_begin_y /= 0 ) THEN + WRITE( wrf_err_message , * ) 'WRF currently assumes analysis nudging starts at the model ',& + 'start time and so analysis nudging start time cannot be specified via gfdda_begin_y' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%gfdda_begin_d /= 0 ) THEN + WRITE( wrf_err_message , * ) 'WRF currently assumes analysis nudging starts at the model ',& + 'start time and so analysis nudging start time cannot be specified via gfdda_begin_d' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%gfdda_begin_h /= 0 ) THEN + WRITE( wrf_err_message , * ) 'WRF currently assumes analysis nudging starts at the model ',& + 'start time and so analysis nudging start time cannot be specified via gfdda_begin_h' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%gfdda_begin_m /= 0 ) THEN + WRITE( wrf_err_message , * ) 'WRF currently assumes analysis nudging starts at the model ',& + 'start time and so analysis nudging start time cannot be specified via gfdda_begin_m' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%gfdda_begin_s /= 0 ) THEN + WRITE( wrf_err_message , * ) 'WRF currently assumes analysis nudging starts at the model ',& + 'start time and so analysis nudging start time cannot be specified via gfdda_begin_s' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + + + !The end time of analysis nudging relative to the model start must be + !specified in hours + IF( config_flags%gfdda_end_y /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option gfdda_end_y is ignored, use gfdda_end_h instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%gfdda_end_d /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option gfdda_end_d is ignored, use gfdda_end_h instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%gfdda_end_m /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option gfdda_end_m is ignored, use gfdda_end_h instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%gfdda_end_s /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option gfdda_end_s is ignored, use gfdda_end_h instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + + !The interval between analyses must be specified in minutes + IF( config_flags%gfdda_interval_y /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option gfdda_interval_y is ignored, use gfdda_interval_m instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%gfdda_interval_d /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option gfdda_interval_d is ignored, use gfdda_interval_m instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%gfdda_interval_h /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option gfdda_interval_h is ignored, use gfdda_interval_m instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%gfdda_interval_s /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option gfdda_interval_s is ignored, use gfdda_interval_m instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + + !If surface analysis nudging chosen check analogous surface analysis + !nudging namelist options + IF( config_flags%grid_sfdda /= 0 ) THEN + + !The begin time of analysis nudging must be the model start time + !It appears the WRF code that reads analysis nudging files respects + !the start time settings, but the actual nudging code does not. This + !leads one to nudge towards 0 in all fields (including potential + !temperature [K]) since the nudging code applies analysis nudging but has + !no data to nudge towards + IF( config_flags%sgfdda_begin_y /= 0 ) THEN + WRITE( wrf_err_message , * ) 'WRF currently assumes analysis nudging starts at the model ',& + 'start time and so analysis nudging start time cannot be specified via sgfdda_begin_y' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%sgfdda_begin_d /= 0 ) THEN + WRITE( wrf_err_message , * ) 'WRF currently assumes analysis nudging starts at the model ',& + 'start time and so analysis nudging start time cannot be specified via sgfdda_begin_d' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%sgfdda_begin_h /= 0 ) THEN + WRITE( wrf_err_message , * ) 'WRF currently assumes analysis nudging starts at the model ',& + 'start time and so analysis nudging start time cannot be specified via sgfdda_begin_h' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%sgfdda_begin_m /= 0 ) THEN + WRITE( wrf_err_message , * ) 'WRF currently assumes analysis nudging starts at the model ',& + 'start time and so analysis nudging start time cannot be specified via sgfdda_begin_m' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%sgfdda_begin_s /= 0 ) THEN + WRITE( wrf_err_message , * ) 'WRF currently assumes analysis nudging starts at the model ',& + 'start time and so analysis nudging start time cannot be specified via sgfdda_begin_s' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + + + !The end time of analysis nudging relative to the model start must be + !specified in hours + IF( config_flags%sgfdda_end_y /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option sgfdda_end_y is ignored, use sgfdda_end_h instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%sgfdda_end_d /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option sgfdda_end_d is ignored, use sgfdda_end_h instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%sgfdda_end_m /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option sgfdda_end_m is ignored, use sgfdda_end_h instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%sgfdda_end_s /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option sgfdda_end_s is ignored, use sgfdda_end_h instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + + !The interval between analyses must be specified in minutes + IF( config_flags%sgfdda_interval_y /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option sgfdda_interval_y is ignored, use sgfdda_interval_m instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%sgfdda_interval_d /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option sgfdda_interval_d is ignored, use sgfdda_interval_m instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%sgfdda_interval_h /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option sgfdda_interval_h is ignored, use sgfdda_interval_m instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + IF( config_flags%sgfdda_interval_s /= 0 ) THEN + WRITE( wrf_err_message , * ) 'The option sgfdda_interval_s is ignored, use sgfdda_interval_m instead' + CALL wrf_error_fatal ( wrf_err_message ) + ENDIF + + ENDIF !IF surface analysis nudging is anabled + !BPR END + !$OMP PARALLEL DO & !$OMP PRIVATE ( ij, i,j,k ) DO ij = 1 , num_tiles @@ -388,6 +552,14 @@ SUBROUTINE fddagd_driver(itimestep,dt,xtime, & u10_ndg_new, v10_ndg_new, t2_ndg_new, th2_ndg_new, q2_ndg_new, & rh_ndg_new, psl_ndg_new, ps_ndg_new, tob_ndg_new, odis_ndg_new, & RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN,& +! +! FASDAS +! + config_flags%fasdas, SDA_HFX, SDA_QFX, & + HFX_FDDA,dz8w, & +! +! END FASDAS +! pblh, ht, regime, znt, z, z_at_w, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & diff --git a/wrfv2_fire/phys/module_fr_fire_phys.F b/wrfv2_fire/phys/module_fr_fire_phys.F index 458b6761..856536d1 100644 --- a/wrfv2_fire/phys/module_fr_fire_phys.F +++ b/wrfv2_fire/phys/module_fr_fire_phys.F @@ -138,7 +138,9 @@ subroutine init_fuel_cats !*** purpose: initialize fuel tables and variables by constants !*** arguments: none logical, external:: wrf_dm_on_monitor -!$ integer, external:: OMP_GET_THREAD_NUM +#ifdef _OPENMP +!integer, external:: OMP_GET_THREAD_NUM +#endif !*** local integer:: i,j,k,ii,iounit character(len=128):: msg @@ -149,9 +151,11 @@ subroutine init_fuel_cats namelist /fuel_categories/ fuel_name,windrf,fgi,fueldepthm,savr, & fuelmce,fueldens,st,se,weight,fci_d,fct,ichap -!$ if (OMP_GET_THREAD_NUM() .ne. 0)then -!$ call crash('init_fuel_cats: must be called from master thread') -!$ endif +#ifdef _OPENMP +! if (OMP_GET_THREAD_NUM() .ne. 0)then +! call crash('init_fuel_cats: must be called from master thread') +! endif +#endif IF ( wrf_dm_on_monitor() ) THEN ! if we are the master task, read the file diff --git a/wrfv2_fire/phys/module_fr_fire_util.F b/wrfv2_fire/phys/module_fr_fire_util.F index a977e087..322250c4 100644 --- a/wrfv2_fire/phys/module_fr_fire_util.F +++ b/wrfv2_fire/phys/module_fr_fire_util.F @@ -107,15 +107,19 @@ end subroutine message integer function open_text_file(filename,rw) implicit none character(len=*),intent(in):: filename,rw -!$ integer, external:: OMP_GET_THREAD_NUM +#ifdef _OPENMP +!integer, external:: OMP_GET_THREAD_NUM +#endif character(len=128):: msg character(len=1)::act integer::iounit,ierr logical::op -!$ if (OMP_GET_THREAD_NUM() .ne. 0)then -!$ call crash('open_input_text_file: called from parallel loop') -!$ endif +#ifdef _OPENMP +! if (OMP_GET_THREAD_NUM() .ne. 0)then +! call crash('open_input_text_file: called from parallel loop') +! endif +#endif do iounit=19,99 inquire(iounit,opened=op) @@ -1333,8 +1337,10 @@ subroutine print_chsum( id, & real, intent(in),dimension(ims:ime,kms:kme,jms:jme)::a character(len=*)::name -!$ external, logical:: omp_in_parallel -!$ external, integer:: omp_get_thread_num +#ifdef _OPENMP +!external, logical:: omp_in_parallel +!external, integer:: omp_get_thread_num +#endif !*** local integer::lsum @@ -1365,7 +1371,9 @@ subroutine print_chsum( id, & ! get process sum over all threads thread=0 -!$ thread=omp_get_thread_num() +#ifdef _OPENMP +!thread=omp_get_thread_num() +#endif if(thread.eq.0)psum=0 !$OMP BARRIER !$OMP CRITICAL(CHSUM) diff --git a/wrfv2_fire/phys/module_gfs_funcphys.F b/wrfv2_fire/phys/module_gfs_funcphys.F index 6c9f7b18..694d4c54 100755 --- a/wrfv2_fire/phys/module_gfs_funcphys.F +++ b/wrfv2_fire/phys/module_gfs_funcphys.F @@ -270,6 +270,7 @@ module module_gfs_funcphys real(krealfp) c1xrkap,c2xrkap,tbrkap(nxrkap) integer,parameter:: nxtlcl=151,nytlcl=61 real(krealfp) c1xtlcl,c2xtlcl,c1ytlcl,c2ytlcl,tbtlcl(nxtlcl,nytlcl) + logical, private :: initialized=.false. ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ! Public Subprograms public gpvsl,fpvsl,fpvslq,fpvslx @@ -368,6 +369,7 @@ function fpvsl(t) integer jx real(krealfp) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) jx=min(xj,nxpvsl-1._krealfp) fpvsl=tbpvsl(jx)+(xj-jx)*(tbpvsl(jx+1)-tbpvsl(jx)) @@ -412,6 +414,7 @@ function fpvslq(t) integer jx real(krealfp) xj,dxj,fj1,fj2,fj3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xpvsl+c2xpvsl*t,1._krealfp),real(nxpvsl,krealfp)) jx=min(max(nint(xj),2),nxpvsl-1) dxj=xj-jx @@ -466,6 +469,7 @@ function fpvslx(t) real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) real(krealfp) tr ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() tr=con_ttp/t fpvslx=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -502,6 +506,7 @@ subroutine gpvsi integer jx real(krealfp) xmin,xmax,xinc,x,t ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xmin=180.0_krealfp xmax=330.0_krealfp xinc=(xmax-xmin)/(nxpvsi-1) @@ -555,6 +560,7 @@ function fpvsi(t) integer jx real(krealfp) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) jx=min(xj,nxpvsi-1._krealfp) fpvsi=tbpvsi(jx)+(xj-jx)*(tbpvsi(jx+1)-tbpvsi(jx)) @@ -600,6 +606,7 @@ function fpvsiq(t) integer jx real(krealfp) xj,dxj,fj1,fj2,fj3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xpvsi+c2xpvsi*t,1._krealfp),real(nxpvsi,krealfp)) jx=min(max(nint(xj),2),nxpvsi-1) dxj=xj-jx @@ -655,6 +662,7 @@ function fpvsix(t) real(krealfp),parameter:: xponb=-dldt/con_rv+heat/(con_rv*con_ttp) real(krealfp) tr ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() tr=con_ttp/t fpvsix=con_psat*(tr**xpona)*exp(xponb*(1.-tr)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -691,6 +699,7 @@ subroutine gpvs integer jx real(krealfp) xmin,xmax,xinc,x,t ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xmin=180.0_krealfp xmax=330.0_krealfp xinc=(xmax-xmin)/(nxpvs-1) @@ -744,6 +753,7 @@ function fpvs(t) integer jx real(krealfp) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) jx=min(xj,nxpvs-1._krealfp) fpvs=tbpvs(jx)+(xj-jx)*(tbpvs(jx+1)-tbpvs(jx)) @@ -789,6 +799,7 @@ function fpvsq(t) integer jx real(krealfp) xj,dxj,fj1,fj2,fj3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xpvs+c2xpvs*t,1._krealfp),real(nxpvs,krealfp)) jx=min(max(nint(xj),2),nxpvs-1) dxj=xj-jx @@ -855,6 +866,7 @@ function fpvsx(t) real(krealfp),parameter:: xponbi=-dldti/con_rv+heati/(con_rv*con_ttp) real(krealfp) tr,w,pvl,pvi ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() tr=con_ttp/t if(t.ge.tliq) then fpvsx=con_psat*(tr**xponal)*exp(xponbl*(1.-tr)) @@ -955,6 +967,7 @@ function ftdpl(pv) integer jx real(krealfp) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) jx=min(xj,nxtdpl-1._krealfp) ftdpl=tbtdpl(jx)+(xj-jx)*(tbtdpl(jx+1)-tbtdpl(jx)) @@ -1001,6 +1014,7 @@ function ftdplq(pv) integer jx real(krealfp) xj,dxj,fj1,fj2,fj3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xtdpl+c2xtdpl*pv,1._krealfp),real(nxtdpl,krealfp)) jx=min(max(nint(xj),2),nxtdpl-1) dxj=xj-jx @@ -1049,6 +1063,7 @@ function ftdplx(pv) real(krealfp),intent(in):: pv real(krealfp) tg ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() tg=ftdpl(pv) ftdplx=ftdplxg(tg,pv) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1104,6 +1119,7 @@ function ftdplxg(tg,pv) real(krealfp) t,tr,pvt,el,dpvt,terr integer i ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() t=tg do i=1,100 tr=con_ttp/t @@ -1206,6 +1222,7 @@ function ftdpi(pv) integer jx real(krealfp) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) jx=min(xj,nxtdpi-1._krealfp) ftdpi=tbtdpi(jx)+(xj-jx)*(tbtdpi(jx+1)-tbtdpi(jx)) @@ -1253,6 +1270,7 @@ function ftdpiq(pv) integer jx real(krealfp) xj,dxj,fj1,fj2,fj3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xtdpi+c2xtdpi*pv,1._krealfp),real(nxtdpi,krealfp)) jx=min(max(nint(xj),2),nxtdpi-1) dxj=xj-jx @@ -1302,6 +1320,7 @@ function ftdpix(pv) real(krealfp),intent(in):: pv real(krealfp) tg ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() tg=ftdpi(pv) ftdpix=ftdpixg(tg,pv) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1358,6 +1377,7 @@ function ftdpixg(tg,pv) real(krealfp) t,tr,pvt,el,dpvt,terr integer i ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() t=tg do i=1,100 tr=con_ttp/t @@ -1460,6 +1480,7 @@ function ftdp(pv) integer jx real(krealfp) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) jx=min(xj,nxtdp-1._krealfp) ftdp=tbtdp(jx)+(xj-jx)*(tbtdp(jx+1)-tbtdp(jx)) @@ -1507,6 +1528,7 @@ function ftdpq(pv) integer jx real(krealfp) xj,dxj,fj1,fj2,fj3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xtdp+c2xtdp*pv,1._krealfp),real(nxtdp,krealfp)) jx=min(max(nint(xj),2),nxtdp-1) dxj=xj-jx @@ -1556,6 +1578,7 @@ function ftdpx(pv) real(krealfp),intent(in):: pv real(krealfp) tg ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() tg=ftdp(pv) ftdpx=ftdpxg(tg,pv) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -1623,6 +1646,7 @@ function ftdpxg(tg,pv) real(krealfp) t,tr,w,pvtl,pvti,pvt,ell,eli,el,dpvt,terr integer i ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() t=tg do i=1,100 tr=con_ttp/t @@ -1747,6 +1771,7 @@ function fthe(t,pk) integer jx,jy real(krealfp) xj,yj,ftx1,ftx2 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) if(xj.ge.1..and.yj.ge.1.) then @@ -1804,6 +1829,7 @@ function ftheq(t,pk) real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 real(krealfp) ftx1,ftx2,ftx3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(c1xthe+c2xthe*t,real(nxthe,krealfp)) yj=min(c1ythe+c2ythe*pk,real(nythe,krealfp)) if(xj.ge.1..and.yj.ge.1.) then @@ -1874,6 +1900,7 @@ function fthex(t,pk) real(krealfp),intent(in):: t,pk real(krealfp) p,tr,pv,pd,el,expo,expmax ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() p=pk**con_cpor tr=con_ttp/t pv=psatb*(tr**con_xpona)*exp(con_xponb*(1.-tr)) @@ -1990,6 +2017,7 @@ subroutine stma(the,pk,tma,qma) integer jx,jy real(krealfp) xj,yj,ftx1,ftx2,qx1,qx2 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) jx=min(xj,nxma-1._krealfp) @@ -2049,6 +2077,7 @@ subroutine stmaq(the,pk,tma,qma) real(krealfp) ftx1,ftx2,ftx3 real(krealfp) q11,q12,q13,q21,q22,q23,q31,q32,q33,qx1,qx2,qx3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xma+c2xma*the,1._krealfp),real(nxma,krealfp)) yj=min(max(c1yma+c2yma*pk,1._krealfp),real(nyma,krealfp)) jx=min(max(nint(xj),2),nxma-1) @@ -2126,6 +2155,7 @@ subroutine stmax(the,pk,tma,qma) real(krealfp),intent(out):: tma,qma real(krealfp) tg,qg ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() call stma(the,pk,tg,qg) call stmaxg(tg,the,pk,tma,qma) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -2183,6 +2213,7 @@ subroutine stmaxg(tg,the,pk,tma,qma) real(krealfp) t,p,tr,pv,pd,el,expo,thet,dthet,terr integer i ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() t=tg p=pk**con_cpor do i=1,100 @@ -2289,6 +2320,7 @@ function fpkap(p) integer jx real(krealfp) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) jx=min(xj,nxpkap-1._krealfp) fpkap=tbpkap(jx)+(xj-jx)*(tbpkap(jx+1)-tbpkap(jx)) @@ -2336,6 +2368,7 @@ function fpkapq(p) integer jx real(krealfp) xj,dxj,fj1,fj2,fj3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xpkap+c2xpkap*p,1._krealfp),real(nxpkap,krealfp)) jx=min(max(nint(xj),2),nxpkap-1) dxj=xj-jx @@ -2390,6 +2423,7 @@ function fpkapo(p) integer n real(krealfp) pkpa,fnpk,fdpk ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() pkpa=p*1.e-3_krealfp fnpk=cnpk(nnpk) do n=nnpk-1,0,-1 @@ -2434,6 +2468,7 @@ function fpkapx(p) real(krealfp) fpkapx real(krealfp),intent(in):: p ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() fpkapx=(p/1.e5_krealfp)**con_rocp ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function @@ -2468,6 +2503,7 @@ subroutine grkap integer jx real(krealfp) xmin,xmax,xinc,x,p ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xmin=0._krealfp xmax=fpkapx(110000._krealfp) xinc=(xmax-xmin)/(nxrkap-1) @@ -2521,6 +2557,7 @@ function frkap(pkap) integer jx real(krealfp) xj ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) jx=min(xj,nxrkap-1._krealfp) frkap=tbrkap(jx)+(xj-jx)*(tbrkap(jx+1)-tbrkap(jx)) @@ -2567,6 +2604,7 @@ function frkapq(pkap) integer jx real(krealfp) xj,dxj,fj1,fj2,fj3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xrkap+c2xrkap*pkap,1._krealfp),real(nxrkap,krealfp)) jx=min(max(nint(xj),2),nxrkap-1) dxj=xj-jx @@ -2608,6 +2646,7 @@ function frkapx(pkap) real(krealfp) frkapx real(krealfp),intent(in):: pkap ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() frkapx=pkap**(1/con_rocp)*1.e5_krealfp ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function @@ -2702,6 +2741,7 @@ function ftlcl(t,tdpd) integer jx,jy real(krealfp) xj,yj,ftx1,ftx2 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) jx=min(xj,nxtlcl-1._krealfp) @@ -2752,6 +2792,7 @@ function ftlclq(t,tdpd) real(krealfp) ft11,ft12,ft13,ft21,ft22,ft23,ft31,ft32,ft33 real(krealfp) ftx1,ftx2,ftx3 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() xj=min(max(c1xtlcl+c2xtlcl*t,1._krealfp),real(nxtlcl,krealfp)) yj=min(max(c1ytlcl+c2ytlcl*tdpd,1._krealfp),real(nytlcl,krealfp)) jx=min(max(nint(xj),2),nxtlcl-1) @@ -2812,6 +2853,7 @@ function ftlclo(t,tdpd) real(krealfp),parameter:: clcl1= 0.954442e+0,clcl2= 0.967772e-3,& clcl3=-0.710321e-3,clcl4=-0.270742e-5 ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() ftlclo=t-tdpd*(clcl1+clcl2*t+tdpd*(clcl3+clcl4*t)) ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - end function @@ -2866,6 +2908,7 @@ function ftlclx(t,tdpd) real(krealfp) tr,pvdew,tlcl,ta,pvlcl,el,dpvlcl,terr,terrp integer i ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if(.not.initialized) call gfuncphys() tr=con_ttp/(t-tdpd) pvdew=con_psat*(tr**con_xpona)*exp(con_xponb*(1.-tr)) tlcl=t-tdpd @@ -2918,6 +2961,7 @@ subroutine gfuncphys !$$$ implicit none ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + initialized=.true. call gpvsl call gpvsi call gpvs diff --git a/wrfv2_fire/phys/module_microphysics_driver.F b/wrfv2_fire/phys/module_microphysics_driver.F index e7cd8cb6..081d6fec 100644 --- a/wrfv2_fire/phys/module_microphysics_driver.F +++ b/wrfv2_fire/phys/module_microphysics_driver.F @@ -59,7 +59,7 @@ SUBROUTINE microphysics_driver( & ,f_qic_effr,f_qip_effr,f_qid_effr & ,qrcuten, qscuten, qicuten, mu & ,qt_curr,f_qt & - ,mp_restart_state,tbpvs_state,tbpvs0_state & ! for etampnew or etamp_hr + ,mp_restart_state,tbpvs_state,tbpvs0_state & ! for etampnew or fer_mp_hires ,hail,ice2 & ! for mp_gsfcgce ! ,ccntype & ! for mp_milbrandt2mom ,u,v,w,z & @@ -90,22 +90,22 @@ SUBROUTINE microphysics_driver( & ,TH_OLD & ,QV_OLD & ,xlat,xlong,ivgtyp & - + ,qrimef_curr,f_qrimef & ) ! Framework #if(NMM_CORE==1) USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME & - ,WSM6SCHEME, ETAMPNEW, ETAMP_HR, etamp_HWRF,THOMPSON, THOMPSONAERO, MORR_TWO_MOMENT & + ,WSM6SCHEME, ETAMPNEW, FER_MP_HIRES, etamp_HWRF,THOMPSON, THOMPSONAERO, MORR_TWO_MOMENT & ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN, NSSL_2MOMG & - ,NSSL_1MOM,NSSL_1MOMLFO & + ,NSSL_1MOM,NSSL_1MOMLFO, FER_MP_HIRES_ADVECT & ,MILBRANDT2MOM !,MILBRANDT3MOM #else USE module_state_description, ONLY : & KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME & - ,WSM6SCHEME, ETAMPNEW, ETAMP_HR, THOMPSON, THOMPSONAERO, FAST_KHAIN_LYNN, MORR_TWO_MOMENT & + ,WSM6SCHEME, ETAMPNEW, FER_MP_HIRES, THOMPSON, THOMPSONAERO, FAST_KHAIN_LYNN, MORR_TWO_MOMENT & ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN, NSSL_2MOMG & - ,NSSL_1MOM,NSSL_1MOMLFO & ! ,NSSL_3MOM & + ,NSSL_1MOM,NSSL_1MOMLFO, FER_MP_HIRES_ADVECT & ! ,NSSL_3MOM & ,MILBRANDT2MOM , CAMMGMPSCHEME,FULL_KHAIN_LYNN !,MILBRANDT3MOM #endif @@ -133,6 +133,7 @@ SUBROUTINE microphysics_driver( & USE module_mp_wsm5 USE module_mp_wsm6 USE module_mp_etanew + USE module_mp_fer_hires USE module_mp_thompson USE module_mp_full_sbm USE module_mp_fast_sbm @@ -145,9 +146,7 @@ SUBROUTINE microphysics_driver( & USE module_mp_cammgmp_driver, ONLY: CAMMGMP ! CAM5's microphysics driver # endif ! USE module_mp_milbrandt3mom -#if (EM_CORE==1) USE module_mp_nssl_2mom -#endif USE module_mp_HWRF USE module_mixactivate, only: prescribe_aerosol_mixactivate @@ -469,7 +468,7 @@ SUBROUTINE microphysics_driver( & ,kext_ft_qic,kext_ft_qip,kext_ft_qid & ,kext_ft_qs,kext_ft_qg & ,qnwfa_curr,qnifa_curr & ! Added by G. Thompson - ,qvolg_curr,qvolh_curr + ,qvolg_curr,qvolh_curr, qrimef_curr @@ -525,6 +524,7 @@ SUBROUTINE microphysics_driver( & ,f_qic,f_qip,f_qid & ,f_qnic,f_qnip,f_qnid & ,f_qzi,f_qzs,f_qzg,f_qzh,f_qvolg,f_qvolh & + ,f_qrimef & ,f_qnwfa, f_qnifa ! Added by G. Thompson @@ -933,7 +933,7 @@ SUBROUTINE microphysics_driver( & PRESENT (MU) .AND. PRESENT (QSCUTEN).AND. & PRESENT (QRCUTEN) .AND. PRESENT (QICUTEN).AND. & PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & - PRESENT (Z ) .AND.PRESENT ( W ) ) THEN + PRESENT ( W ) ) THEN CALL mp_morr_two_moment( & ITIMESTEP=itimestep, & !* TH=th, & !* @@ -997,7 +997,7 @@ SUBROUTINE microphysics_driver( & PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & - PRESENT (Z ) .AND. PRESENT ( W ) ) THEN + PRESENT ( W ) ) THEN ! PRESENT (ccntype) & CALL mp_milbrandt2mom_driver( & @@ -1052,7 +1052,7 @@ SUBROUTINE microphysics_driver( & ! PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. PRESENT (QZG_CURR) .AND. & ! PRESENT (QH_CURR) .AND. PRESENT (QNH_CURR) .AND. PRESENT (QZH_CURR) .AND. & ! PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & -! PRESENT (Z ) .AND. PRESENT ( W ) ) THEN +! PRESENT ( W ) ) THEN ! CALL mp_milbrandt3mom_driver( & ! ITIMESTEP=itimestep, & !* ! TH=th, & !* @@ -1090,7 +1090,6 @@ SUBROUTINE microphysics_driver( & ! Call wrf_error_fatal( 'arguments not present for calling milbrandt3mom') ! ENDIF -#if (EM_CORE==1) CASE (NSSL_1MOM) CALL wrf_debug(100, 'microphysics_driver: calling nssl1mom') IF (PRESENT (QV_CURR) .AND. & @@ -1101,10 +1100,12 @@ SUBROUTINE microphysics_driver( & PRESENT (QG_CURR) .AND. & PRESENT (QH_CURR) .AND. & PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & +#if (EM_CORE==1) PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & - PRESENT (Z ) .AND. PRESENT ( W ) .AND. & +#endif + PRESENT ( W ) .AND. & PRESENT (QVOLG_CURR) ) THEN @@ -1147,7 +1148,7 @@ SUBROUTINE microphysics_driver( & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & ) ELSE - Call wrf_error_fatal( 'arguments not present for calling nssl_2mom') + Call wrf_error_fatal( 'arguments not present for calling nssl_1mom') ENDIF @@ -1160,9 +1161,11 @@ SUBROUTINE microphysics_driver( & PRESENT (QS_CURR) .AND. & PRESENT (QG_CURR) .AND. & PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & +#if (EM_CORE==1) PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & - PRESENT (Z ) .AND. PRESENT ( W ) ) THEN +#endif + PRESENT ( W ) ) THEN CALL nssl_2mom_driver( & @@ -1194,7 +1197,7 @@ SUBROUTINE microphysics_driver( & ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & ) ELSE - Call wrf_error_fatal( 'arguments not present for calling nssl_2mom') + Call wrf_error_fatal( 'arguments not present for calling nssl_1momlfo') ENDIF CASE (NSSL_2MOM) @@ -1207,10 +1210,12 @@ SUBROUTINE microphysics_driver( & PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. & PRESENT (QH_CURR) .AND. PRESENT (QNH_CURR) .AND. & PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & +#if (EM_CORE==1) PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & - PRESENT (Z ) .AND. PRESENT ( W ) .AND. & +#endif + PRESENT ( W ) .AND. & PRESENT (QVOLG_CURR) .AND. F_QVOLG .AND. & PRESENT (QVOLH_CURR) .AND. F_QVOLH ) THEN @@ -1279,10 +1284,12 @@ SUBROUTINE microphysics_driver( & PRESENT (QS_CURR) .AND. PRESENT (QNS_CURR) .AND. & PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. & PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & +#if (EM_CORE==1) PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & - PRESENT (Z ) .AND. PRESENT ( W ) .AND. & +#endif + PRESENT ( W ) .AND. & PRESENT (QVOLG_CURR) .AND. F_QVOLG ) THEN @@ -1335,7 +1342,7 @@ SUBROUTINE microphysics_driver( & ) ELSE - Call wrf_error_fatal( 'arguments not present for calling nssl_2mom') + Call wrf_error_fatal( 'arguments not present for calling nssl_2momg') ENDIF CASE (NSSL_2MOMCCN) @@ -1348,10 +1355,12 @@ SUBROUTINE microphysics_driver( & PRESENT (QG_CURR) .AND. PRESENT (QNG_CURR) .AND. & PRESENT (QH_CURR) .AND. PRESENT (QNH_CURR) .AND. & PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. & +#if (EM_CORE==1) PRESENT (SNOWNC ) .AND. PRESENT (SNOWNCV) .AND. & PRESENT (HAILNC ) .AND. PRESENT (HAILNCV) .AND. & PRESENT (GRAUPELNC).AND.PRESENT (GRAUPELNCV).AND. & - PRESENT (Z ) .AND. PRESENT ( W ) .AND. & +#endif + PRESENT ( W ) .AND. & PRESENT (QVOLG_CURR) .AND. F_QVOLG .AND. & PRESENT (QVOLH_CURR) .AND. F_QVOLH .AND. & PRESENT( QNN_CURR ) ) THEN @@ -1411,7 +1420,6 @@ SUBROUTINE microphysics_driver( & ELSE Call wrf_error_fatal( 'arguments not present for calling nssl_2momccn') ENDIF -#endif ! CASE (GSFCGCESCHEME) CALL wrf_debug ( 100 , 'microphysics_driver: calling GSFCGCE' ) @@ -1810,6 +1818,71 @@ SUBROUTINE microphysics_driver( & ELSE CALL wrf_error_fatal ( 'arguments not present for calling etampnew' ) ENDIF + CASE (FER_MP_HIRES) !-- Operational Ferrier-Aligo High-Resolution Window(HRW) version + ! (2014/2 version) added by Weiguo Wang on + ! 2014-11-19 + CALL wrf_debug ( 100 , 'microphysics_driver: calling etampnew') + + IF ( PRESENT( qv_curr ) .AND. PRESENT( qt_curr ) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & + PRESENT( mp_restart_state ) .AND. & + PRESENT( tbpvs_state ) .AND. & + PRESENT( tbpvs0_state ) ) THEN + + ! write(0,*)',f_qv,f_qc,f_qr,f_qi,f_qs,f_qg',f_qv,f_qc,f_qr,f_qi,f_qs,f_qg + ! write(0,*)'max qi=',maxval(qi_curr(its:ite,kts:kte,jts:jte)) + ! write(0,*)'max qs=',maxval(qs_curr(its:ite,kts:kte,jts:jte)) + + CALL FER_HIRES( & + ITIMESTEP=itimestep,DT=dt,DX=dx,DY=dy, GID=id & + ,RAINNC=rainnc,RAINNCV=rainncv & + ,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,PI_PHY=pi_phy,TH_PHY=th & + ,QV=qv_curr & + ,QT=qt_curr & + ,LOWLYR=LOWLYR,SR=SR & + ,F_ICE_PHY=F_ICE_PHY,F_RAIN_PHY=F_RAIN_PHY & + ,F_RIMEF_PHY=F_RIMEF_PHY & + ,QC=qc_curr,QR=Qr_curr,QI=Qi_curr & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling fer_hires' ) + ENDIF + + CASE (FER_MP_HIRES_ADVECT) !-- Operational Ferrier-Aligo High-Resolution Window(HRW) version + ! (2014/2 version) added by Weiguo Wang on + ! 2014-11-19 + ! Modified for advection, Sam Trahan, August 2015 + CALL wrf_debug ( 100 , 'microphysics_driver: calling etampnew') + + IF ( PRESENT( qv_curr ) .AND. PRESENT( qi_curr ) .AND. & + PRESENT( qc_curr ) .and. PRESENT(qrimef_curr) .AND. & + PRESENT( RAINNC ) .AND. PRESENT ( RAINNCV ) .AND. & + PRESENT( mp_restart_state ) .AND. & + PRESENT( tbpvs_state ) .AND. & + PRESENT( tbpvs0_state ) ) THEN + + ! write(0,*)',f_qv,f_qc,f_qr,f_qi,f_qs,f_qg',f_qv,f_qc,f_qr,f_qi,f_qs,f_qg + ! write(0,*)'max qi=',maxval(qi_curr(its:ite,kts:kte,jts:jte)) + ! write(0,*)'max qs=',maxval(qs_curr(its:ite,kts:kte,jts:jte)) + + CALL FER_HIRES_ADVECT( & + ITIMESTEP=itimestep,DT=dt,DX=dx,DY=dy, GID=id & + ,RAINNC=rainnc,RAINNCV=rainncv & + ,DZ8W=dz8w,RHO_PHY=rho,P_PHY=p,PI_PHY=pi_phy,TH_PHY=th & + ,QV=qv_curr & + ,LOWLYR=LOWLYR,SR=SR & + ,QC=qc_curr,QR=Qr_curr,QI=Qi_curr,QRIMEF=qrimef_curr & + ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde & + ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme & + ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte & + ) + ELSE + CALL wrf_error_fatal ( 'arguments not present for calling fer_hires' ) + ENDIF + #if(EM_CORE==1) CASE (CAMMGMPSCHEME) CALL wrf_debug ( 100 , 'microphysics_driver: calling CAMMGMPSCHEME') diff --git a/wrfv2_fire/phys/module_mp_HWRF.F b/wrfv2_fire/phys/module_mp_HWRF.F index e26a98a7..3574f5c8 100755 --- a/wrfv2_fire/phys/module_mp_HWRF.F +++ b/wrfv2_fire/phys/module_mp_HWRF.F @@ -172,6 +172,11 @@ SUBROUTINE ETAMP_NEW_HWRF (itimestep,DT,DX,DY,GID,RAINNC,RAINNCV, & !GID REAL, DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC REAL, DIMENSION(its:ite, kts:kte, jts:jte):: t_phy +!jm 20150331 +! see comment below + REAL :: PI, DTPH +!jm 20150331 + INTEGER :: I,J,K,KFLIP ! !----------------------------------------------------------------------- @@ -192,6 +197,23 @@ SUBROUTINE ETAMP_NEW_HWRF (itimestep,DT,DX,DY,GID,RAINNC,RAINNCV, & !GID !HWRF TBPVS(1:NX) =TBPVS_STATE(1:NX) !HWRF TBPVS0(1:NX)=TBPVS0_STATE(1:NX) ! +!jm 20150331 +! Temp fix problem with SAVEd variables CIACW, CIACR, CRACW, and CRAUT that +! are inadvertantly recalculated when the etanewinit_HWRF routine, below, +! is called for other domains. Best solution is to move these to state (put +! in registry) so there will be separate copies for each domain. For now, +! just recompute each time this routine is entered. Will be an innocuous +! race condition (many set with same value) with threading so need to fix. +! Temporary fix is idea of Weiguo Wang. + PI=ACOS(-1.) + DTPH=DT + CALL MY_GROWTH_RATES(DT) + CIACW=DTPH*0.25*PI*0.5*(1.E5)**C1 + CIACR=PI*DTPH + CRACW=DTPH*0.25*PI*1.0 + CRAUT=1.-EXP(-1.E-3*DTPH) +!jm 20150331 + DO j = jts,jte DO k = kts,kte DO i = its,ite diff --git a/wrfv2_fire/phys/module_mp_fast_sbm.F b/wrfv2_fire/phys/module_mp_fast_sbm.F index 677d6e21..cbcd6d30 100644 --- a/wrfv2_fire/phys/module_mp_fast_sbm.F +++ b/wrfv2_fire/phys/module_mp_fast_sbm.F @@ -489,7 +489,7 @@ SUBROUTINE FAST_SBM (w,u,v,th_old, & KRR=0 DO KR=p_ff8i01,p_ff8i33 KRR=KRR+1 - if (xland(i,j).eq.1.and.(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.1))then + if (xland(i,j).lt.1.5)then chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ else chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ @@ -519,7 +519,7 @@ SUBROUTINE FAST_SBM (w,u,v,th_old, & KRR=0 DO kr=p_ff8i01,p_ff8i33 KRR=KRR+1 - if (xland(i,j).eq.1.and.(ivgtyp(i,j).eq.19.or.ivgtyp(i,j).eq.1))then + if (xland(i,j).lt.1.5)then chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ else chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ diff --git a/wrfv2_fire/phys/module_mp_fer_hires.F b/wrfv2_fire/phys/module_mp_fer_hires.F new file mode 100755 index 00000000..7e50ddfa --- /dev/null +++ b/wrfv2_fire/phys/module_mp_fer_hires.F @@ -0,0 +1,3097 @@ +!WRF:MODEL_MP:PHYSICS +! +!-- Updates based on NAM changes in 2011: +! +! (a) Expanded rain lookup tables from 0.45 mm to 1 mm mean diameter. +! (b) Allow cloud ice to fall (fall speeds based on 50 micron mean diameters). +! (c) Cloud water autoconversion to rain follows Liu et al. (JAS, 2006) +! (d) Fix to MY_GROWTH by multiplying estimates by 1.e-3 +! (e) Added integer function GET_INDEXR +! (f) Added warning messages when unusual conditions occur, screened for +! 5 different types of problems, such as (1) condensate in the +! stratosphere, (2) temperature = NaN, (3) water supersaturation at +! <180K, (4) too many iterations (>10) in the condensation function, +! and (5) too many iterations (>10) in the deposition function. +! +!-- Updates based on jan19 2014 changes in the NMMB: +! +! (1) Ice nucleation: Fletcher (1962) replaces Meyers et al. (1992) +! (2) Cloud ice is a simple function of the number concentration from (1), and it +! is no longer a fractional function of the large ice. Thus, the FLARGE & +! FSMALL parameters are no longer used. +! (3) T_ICE_init=-12 deg C provides a slight delay in the initial onset of ice. +! (4) NLImax is a function of rime factor (RF) and temperature. +! a) For RF>10, NLImax=1.e3. Mean ice diameters can exceed the 1 mm maximum +! size in the tables so that NLICE=NLImax=1.e3. +! b) Otherwise, NLImax is 10 L-1 at 0C and increases with colder temperatures +! to 20 L-1 at <=-40C. Also, NLICE can be >NLImax at the maximum ice +! diameter of 1 mm. +! (5) Can turn off ice processes by setting T_ICE & T_ICE_init to be < -100 deg C +! (6) Modified the homogeneous freezing of cloud water when TNLImax. +! (10) Ice deposition does not change the rime factor (RF) when RF>=10 & T>T_ICE. +! (11) Limit GAMMAS to <=1.5 (air resistance impact on ice fall speeds) +! (12) NSImax is maximum # conc of ice crystals. At cold temperature NSImax is +! calculated based on assuming 10% of total ice content is due to cloud ice. +! +MODULE module_mp_fer_hires +!----------------------------------------------------------------------- +!-- The following changes were made on 24 July 2006. +! (1) All known version 2.1 dependencies were removed from the +! operational WRF NMM model code (search for "!HWRF") +! (2) Incorporated code changes from the GFDL model (search for "!GFDL") +!----------------------------------------------------------------------- +! + REAL,PRIVATE,SAVE :: ABFR, CBFR, CIACW, CIACR, C_N0r0, & + & ARAUT, BRAUT, CN0r0, CN0r_DMRmin, CN0r_DMRmax, CRACW, ESW0, & + & RFmax, RQR_DRmin, RQR_DRmax, RR_DRmin, RR_DR1, RR_DR2, & + & RR_DR3, RR_DR4, RR_DR5, RR_DRmax, BETA6, PI_E +! + INTEGER, PRIVATE,PARAMETER :: MY_T1=1, MY_T2=35 + REAL,PRIVATE,DIMENSION(MY_T1:MY_T2),SAVE :: MY_GROWTH +! + REAL, PRIVATE,PARAMETER :: DMImin=.05e-3, DMImax=1.e-3, & + & DelDMI=1.e-6,XMImin=1.e6*DMImin,XMIexp=.0536 + INTEGER, PUBLIC,PARAMETER :: XMImax=1.e6*DMImax, & + & MDImin=XMImin, MDImax=XMImax + REAL, PRIVATE,DIMENSION(MDImin:MDImax) :: & + & ACCRI,VSNOWI,VENTI1,VENTI2 + REAL, PUBLIC,DIMENSION(MDImin:MDImax) :: SDENS !-- For RRTM +! + REAL, PRIVATE,PARAMETER :: DMRmin=.05e-3, DMRmax=1.0e-3, & + & DelDMR=1.e-6, XMRmin=1.e6*DMRmin, XMRmax=1.e6*DMRmax + INTEGER, PUBLIC,PARAMETER :: MDRmin=XMRmin, MDRmax=XMRmax +! + REAL, PRIVATE,DIMENSION(MDRmin:MDRmax):: & + & ACCRR,MASSR,RRATE,VRAIN,VENTR1,VENTR2 +! + INTEGER, PRIVATE,PARAMETER :: Nrime=40 + REAL, DIMENSION(2:9,0:Nrime),PRIVATE,SAVE :: VEL_RF +! + INTEGER,PARAMETER :: NX=7501 + REAL, PARAMETER :: XMIN=180.0,XMAX=330.0 + REAL, DIMENSION(NX),PRIVATE,SAVE :: TBPVS,TBPVS0 + REAL, PRIVATE,SAVE :: C1XPVS0,C2XPVS0,C1XPVS,C2XPVS +! + REAL, PRIVATE,PARAMETER :: & +!--- Physical constants follow: + & CP=1004.6, EPSQ=1.E-12, GRAV=9.806, RHOL=1000., RD=287.04 & + & ,RV=461.5, T0C=273.15, XLS=2.834E6 & +!--- Derived physical constants follow: + & ,EPS=RD/RV, EPS1=RV/RD-1., EPSQ1=1.001*EPSQ & + & ,RCP=1./CP, RCPRV=RCP/RV, RGRAV=1./GRAV, RRHOL=1./RHOL & + & ,XLS1=XLS*RCP, XLS2=XLS*XLS*RCPRV, XLS3=XLS*XLS/RV & +!--- Constants specific to the parameterization follow: +!--- CLIMIT/CLIMIT1 are lower limits for treating accumulated precipitation + & ,CLIMIT=10.*EPSQ, CLIMIT1=-CLIMIT & + & ,C1=1./3. & + & ,DMR1=.1E-3, DMR2=.2E-3, DMR3=.32E-3, DMR4=0.45E-3 & + & ,DMR5=0.67E-3 & + & ,XMR1=1.e6*DMR1, XMR2=1.e6*DMR2, XMR3=1.e6*DMR3 & + & ,XMR4=1.e6*DMR4, XMR5=1.e6*DMR5 + INTEGER, PARAMETER :: MDR1=XMR1, MDR2=XMR2, MDR3=XMR3, MDR4=XMR4 & + & , MDR5=XMR5 + +!-- Debug 20120111 +LOGICAL, SAVE :: WARN1=.TRUE.,WARN2=.TRUE.,WARN3=.TRUE.,WARN5=.TRUE. +REAL, SAVE :: Pwarn=75.E2, QTwarn=1.E-3 +INTEGER, PARAMETER :: MAX_ITERATIONS=10 + +! +! ====================================================================== +!--- Important tunable parameters that are exported to other modules +!GFDL * RHgrd - generic reference to the threshold relative humidity for +!GFDL the onset of condensation +!GFDL (new) * RHgrd_in - "RHgrd" for the inner domain +!GFDL (new) * RHgrd_out - "RHgrd" for the outer domain +!HWRF 6/11/2010 mod - use lower RHgrd_out for p < 850 hPa +! * T_ICE - temperature (C) threshold at which all remaining liquid water +! is glaciated to ice +! * T_ICE_init - maximum temperature (C) at which ice nucleation occurs +! +!-- To turn off ice processes, set T_ICE & T_ICE_init to <= -100. (i.e., -100 C) +! +! * NLImax - maximum number concentrations (m**-3) of large ice (snow/graupel/sleet) +! * NLImin - minimum number concentrations (m**-3) of large ice (snow/graupel/sleet) +! * NSImax - maximum number concentrations (m**-3) of small ice crystals +! * N0r0 - assumed intercept (m**-4) of rain drops if drop diameters are between 0.2 and 0.45 mm +! * N0rmin - minimum intercept (m**-4) for rain drops +! * NCW - number concentrations of cloud droplets (m**-3) +! * PRINT_diag - for extended model diagnostics (code currently commented out) +! ====================================================================== + REAL, PUBLIC,PARAMETER :: & +! & RHgrd=1. & + & RHgrd_in=1. & !GFDL + & ,RHgrd_out=0.975 & !GFDL + & ,P_RHgrd_out=850.E2 & !HWRF 6/11/2010 + & ,T_ICE=-40. & + & ,T_ICEK=T0C+T_ICE & + & ,T_ICE_init=-12. & + & ,NSI_max=250.E3 & + & ,NLImin=1.E3 & + & ,N0r0=8.E6 & + & ,N0rmin=1.E4 & +!!2-09-2012 & ,NCW=60.E6 & !GFDL +!! based on Aligo's email,NCW is changed to 250E6 + & ,NCW=250.E6 !GFDL +!HWRF & ,NCW=100.E6 & + LOGICAL, PARAMETER :: PRINT_diag=.FALSE. !GFDL +!--- Other public variables passed to other routines: + REAL, PUBLIC,DIMENSION(MDImin:MDImax) :: MASSI +! +! + CONTAINS + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + SUBROUTINE FER_HIRES (itimestep,DT,DX,DY,GID,RAINNC,RAINNCV, & !GID + & dz8w,rho_phy,p_phy,pi_phy,th_phy,qv,qt, & !gopal's doing + & LOWLYR,SR, & + & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & + & QC,QR,QI, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte ) +!HWRF SUBROUTINE ETAMP_NEW (itimestep,DT,DX,DY, & +!HWRF & dz8w,rho_phy,p_phy,pi_phy,th_phy,qv,qc, & +!HWRF & LOWLYR,SR, & +!HWRF & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & +!HWRF & mp_restart_state,tbpvs_state,tbpvs0_state, & +!HWRF & RAINNC,RAINNCV, & +!HWRF & ids,ide, jds,jde, kds,kde, & +!HWRF & ims,ime, jms,jme, kms,kme, & +!HWRF & its,ite, jts,jte, kts,kte ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + INTEGER, PARAMETER :: ITLO=-60, ITHI=40 + + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE & + & ,ITIMESTEP,GID ! GID gopal's doing + + REAL, INTENT(IN) :: DT,DX,DY + REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: & + & dz8w,p_phy,pi_phy,rho_phy + REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme):: & + & th_phy,qv,qt,qc,qr,qi + REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme ) :: & + & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY + REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: & + & RAINNC,RAINNCV + REAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme):: SR +! +!HWRF REAL,DIMENSION(*),INTENT(INOUT) :: MP_RESTART_STATE +! +!HWRF REAL,DIMENSION(nx),INTENT(INOUT) :: TBPVS_STATE,TBPVS0_STATE +! + INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR + +!----------------------------------------------------------------------- +! LOCAL VARS +!----------------------------------------------------------------------- + +! NSTATS,QMAX,QTOT are diagnostic vars + + INTEGER,DIMENSION(ITLO:ITHI,4) :: NSTATS + REAL, DIMENSION(ITLO:ITHI,5) :: QMAX + REAL, DIMENSION(ITLO:ITHI,22):: QTOT + +! SOME VARS WILL BE USED FOR DATA ASSIMILATION (DON'T NEED THEM NOW). +! THEY ARE TREATED AS LOCAL VARS, BUT WILL BECOME STATE VARS IN THE +! FUTURE. SO, WE DECLARED THEM AS MEMORY SIZES FOR THE FUTURE USE + +! TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related +! the microphysics scheme. Instead, they will be used by Eta precip +! assimilation. + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: & + & TLATGS_PHY,TRAIN_PHY + REAL, DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC + REAL, DIMENSION(its:ite, kts:kte, jts:jte):: t_phy + + INTEGER :: I,J,K,KFLIP + REAL :: WC +! +!----------------------------------------------------------------------- +!********************************************************************** +!----------------------------------------------------------------------- +! +!HWRF MY_GROWTH(MY_T1:MY_T2)=MP_RESTART_STATE(MY_T1:MY_T2) +!HWRF! +!HWRF C1XPVS0=MP_RESTART_STATE(MY_T2+1) +!HWRF C2XPVS0=MP_RESTART_STATE(MY_T2+2) +!HWRF C1XPVS =MP_RESTART_STATE(MY_T2+3) +!HWRF C2XPVS =MP_RESTART_STATE(MY_T2+4) +!HWRF CIACW =MP_RESTART_STATE(MY_T2+5) +!HWRF CIACR =MP_RESTART_STATE(MY_T2+6) +!HWRF CRACW =MP_RESTART_STATE(MY_T2+7) +!HWRF CRAUT =MP_RESTART_STATE(MY_T2+8) +!HWRF! +!HWRF TBPVS(1:NX) =TBPVS_STATE(1:NX) +!HWRF TBPVS0(1:NX)=TBPVS0_STATE(1:NX) +! +!---------- +!2015-03-30, recalculate some constants which may depend on phy time step + CALL MY_GROWTH_RATES (DT) + +!--- CIACW is used in calculating riming rates +! The assumed effective collection efficiency of cloud water rimed onto +! ice is =0.5 below: +! + CIACW=DT*0.25*PI_E*0.5*(1.E5)**C1 +! +!--- CIACR is used in calculating freezing of rain colliding with large ice +! The assumed collection efficiency is 1.0 +! + CIACR=PI_E*DT +! +!--- CRACW is used in calculating collection of cloud water by rain (an +! assumed collection efficiency of 1.0) +! + CRACW=DT*0.25*PI_E*1.0 +! +!-- See comments in subroutine etanewhr_init starting with variable RDIS= +! + BRAUT=DT*1.1E10*BETA6/NCW + +! write(*,*)'dt=',dt +! write(*,*)'pi_e=',pi_e +! write(*,*)'ciacw=',ciacw +! write(*,*)'ciacr=',ciacr +! write(*,*)'cracw=',cracw +! write(*,*)'araut=',araut +! write(*,*)'braut=',braut +!! END OF adding, 2015-03-30 +!----------- + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j) + qv(i,k,j)=qv(i,k,j)/(1.+qv(i,k,j)) !Convert to specific humidity + ENDDO + ENDDO + ENDDO + +! initial diagnostic variables and data assimilation vars +! (will need to delete this part in the future) + + DO k = 1,4 + DO i = ITLO,ITHI + NSTATS(i,k)=0. + ENDDO + ENDDO + + DO k = 1,5 + DO i = ITLO,ITHI + QMAX(i,k)=0. + ENDDO + ENDDO + + DO k = 1,22 + DO i = ITLO,ITHI + QTOT(i,k)=0. + ENDDO + ENDDO + +! initial data assimilation vars (will need to delete this part in the future) + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + TLATGS_PHY (i,k,j)=0. + TRAIN_PHY (i,k,j)=0. + ENDDO + ENDDO + ENDDO + + DO j = jts,jte + DO i = its,ite + ACPREC(i,j)=0. + APREC (i,j)=0. + PREC (i,j)=0. + SR (i,j)=0. + ENDDO + ENDDO + +!-- 6/11/2010: Update QT, F_ice, F_rain arrays + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + QT(I,K,J)=QC(I,K,J)+QR(I,K,J)+QI(I,K,J) + IF (QI(I,K,J) <= EPSQ) THEN + F_ICE_PHY(I,K,J)=0. + IF (T_PHY(I,K,J) < T_ICEK) F_ICE_PHY(I,K,J)=1. + ELSE + F_ICE_PHY(I,K,J)=MAX( 0., MIN(1., QI(I,K,J)/QT(I,K,J) ) ) + ENDIF + IF (QR(I,K,J) <= EPSQ) THEN + F_RAIN_PHY(I,K,J)=0. + ELSE + F_RAIN_PHY(I,K,J)=QR(I,K,J)/(QR(I,K,J)+QC(I,K,J)) + ENDIF + ENDDO + ENDDO + ENDDO + +!----------------------------------------------------------------------- + + CALL EGCP01DRV(GID,DT,LOWLYR, & + & APREC,PREC,ACPREC,SR,NSTATS,QMAX,QTOT, & + & dz8w,rho_phy,qt,t_phy,qv,F_ICE_PHY,P_PHY, & + & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte ) +!----------------------------------------------------------------------- + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + th_phy(i,k,j) = t_phy(i,k,j)/pi_phy(i,k,j) + qv(i,k,j)=qv(i,k,j)/(1.-qv(i,k,j)) !Convert to mixing ratio + WC=qt(I,K,J) + QI(I,K,J)=0. + QR(I,K,J)=0. + QC(I,K,J)=0. + IF(F_ICE_PHY(I,K,J)>=1.)THEN + QI(I,K,J)=WC + ELSEIF(F_ICE_PHY(I,K,J)<=0.)THEN + QC(I,K,J)=WC + ELSE + QI(I,K,J)=F_ICE_PHY(I,K,J)*WC + QC(I,K,J)=WC-QI(I,K,J) + ENDIF +! + IF(QC(I,K,J)>0..AND.F_RAIN_PHY(I,K,J)>0.)THEN + IF(F_RAIN_PHY(I,K,J).GE.1.)THEN + QR(I,K,J)=QC(I,K,J) + QC(I,K,J)=0. + ELSE + QR(I,K,J)=F_RAIN_PHY(I,K,J)*QC(I,K,J) + QC(I,K,J)=QC(I,K,J)-QR(I,K,J) + ENDIF + endif + ENDDO + ENDDO + ENDDO +! +! update rain (from m to mm) + + DO j=jts,jte + DO i=its,ite + RAINNC(i,j)=APREC(i,j)*1000.+RAINNC(i,j) + RAINNCV(i,j)=APREC(i,j)*1000. + ENDDO + ENDDO +! +!HWRF MP_RESTART_STATE(MY_T1:MY_T2)=MY_GROWTH(MY_T1:MY_T2) +!HWRF MP_RESTART_STATE(MY_T2+1)=C1XPVS0 +!HWRF MP_RESTART_STATE(MY_T2+2)=C2XPVS0 +!HWRF MP_RESTART_STATE(MY_T2+3)=C1XPVS +!HWRF MP_RESTART_STATE(MY_T2+4)=C2XPVS +!HWRF MP_RESTART_STATE(MY_T2+5)=CIACW +!HWRF MP_RESTART_STATE(MY_T2+6)=CIACR +!HWRF MP_RESTART_STATE(MY_T2+7)=CRACW +!HWRF MP_RESTART_STATE(MY_T2+8)=CRAUT +!HWRF! +!HWRF TBPVS_STATE(1:NX) =TBPVS(1:NX) +!HWRF TBPVS0_STATE(1:NX)=TBPVS0(1:NX) + +!----------------------------------------------------------------------- + + END SUBROUTINE FER_HIRES + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +! NOTE: The only differences between FER_HIRES and FER_HIRES_ADVECT +! is that the QT, and F_* are all local variables in the advected +! version, and QRIMEF is only in the advected version. The innards +! are all the same. + SUBROUTINE FER_HIRES_ADVECT (itimestep,DT,DX,DY,GID,RAINNC,RAINNCV, & !GID + & dz8w,rho_phy,p_phy,pi_phy,th_phy,qv, & !gopal's doing + & LOWLYR,SR, & + & QC,QR,QI,QRIMEF, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte ) +!HWRF SUBROUTINE ETAMP_NEW (itimestep,DT,DX,DY, & +!HWRF & dz8w,rho_phy,p_phy,pi_phy,th_phy,qv,qc, & +!HWRF & LOWLYR,SR, & +!HWRF & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, & +!HWRF & mp_restart_state,tbpvs_state,tbpvs0_state, & +!HWRF & RAINNC,RAINNCV, & +!HWRF & ids,ide, jds,jde, kds,kde, & +!HWRF & ims,ime, jms,jme, kms,kme, & +!HWRF & its,ite, jts,jte, kts,kte ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + INTEGER, PARAMETER :: ITLO=-60, ITHI=40 + + INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & + & ,IMS,IME,JMS,JME,KMS,KME & + & ,ITS,ITE,JTS,JTE,KTS,KTE & + & ,ITIMESTEP,GID ! GID gopal's doing + + REAL, INTENT(IN) :: DT,DX,DY + REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: & + & dz8w,p_phy,pi_phy,rho_phy + REAL, INTENT(INOUT), DIMENSION(ims:ime, kms:kme, jms:jme):: & + & th_phy,qv,qc,qr,qi,qrimef + REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: & + & RAINNC,RAINNCV + REAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme):: SR +! +!HWRF REAL,DIMENSION(*),INTENT(INOUT) :: MP_RESTART_STATE +! +!HWRF REAL,DIMENSION(nx),INTENT(INOUT) :: TBPVS_STATE,TBPVS0_STATE +! + INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR + +!----------------------------------------------------------------------- +! LOCAL VARS +!----------------------------------------------------------------------- + + REAL, DIMENSION(ims:ime, kms:kme, jms:jme ) :: & + & F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY, QT +! NSTATS,QMAX,QTOT are diagnostic vars + + INTEGER,DIMENSION(ITLO:ITHI,4) :: NSTATS + REAL, DIMENSION(ITLO:ITHI,5) :: QMAX + REAL, DIMENSION(ITLO:ITHI,22):: QTOT + +! SOME VARS WILL BE USED FOR DATA ASSIMILATION (DON'T NEED THEM NOW). +! THEY ARE TREATED AS LOCAL VARS, BUT WILL BECOME STATE VARS IN THE +! FUTURE. SO, WE DECLARED THEM AS MEMORY SIZES FOR THE FUTURE USE + +! TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related +! the microphysics scheme. Instead, they will be used by Eta precip +! assimilation. + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: & + & TLATGS_PHY,TRAIN_PHY + REAL, DIMENSION(ims:ime,jms:jme):: APREC,PREC,ACPREC + REAL, DIMENSION(its:ite, kts:kte, jts:jte):: t_phy + + INTEGER :: I,J,K,KFLIP + REAL :: WC +! +!----------------------------------------------------------------------- +!********************************************************************** +!----------------------------------------------------------------------- +! +!HWRF MY_GROWTH(MY_T1:MY_T2)=MP_RESTART_STATE(MY_T1:MY_T2) +!HWRF! +!HWRF C1XPVS0=MP_RESTART_STATE(MY_T2+1) +!HWRF C2XPVS0=MP_RESTART_STATE(MY_T2+2) +!HWRF C1XPVS =MP_RESTART_STATE(MY_T2+3) +!HWRF C2XPVS =MP_RESTART_STATE(MY_T2+4) +!HWRF CIACW =MP_RESTART_STATE(MY_T2+5) +!HWRF CIACR =MP_RESTART_STATE(MY_T2+6) +!HWRF CRACW =MP_RESTART_STATE(MY_T2+7) +!HWRF CRAUT =MP_RESTART_STATE(MY_T2+8) +!HWRF! +!HWRF TBPVS(1:NX) =TBPVS_STATE(1:NX) +!HWRF TBPVS0(1:NX)=TBPVS0_STATE(1:NX) +! +!---------- +!2015-03-30, recalculate some constants which may depend on phy time step + CALL MY_GROWTH_RATES (DT) + +!--- CIACW is used in calculating riming rates +! The assumed effective collection efficiency of cloud water rimed onto +! ice is =0.5 below: +! + CIACW=DT*0.25*PI_E*0.5*(1.E5)**C1 +! +!--- CIACR is used in calculating freezing of rain colliding with large ice +! The assumed collection efficiency is 1.0 +! + CIACR=PI_E*DT +! +!--- CRACW is used in calculating collection of cloud water by rain (an +! assumed collection efficiency of 1.0) +! + CRACW=DT*0.25*PI_E*1.0 +! +!-- See comments in subroutine etanewhr_init starting with variable RDIS= +! + BRAUT=DT*1.1E10*BETA6/NCW + +! write(*,*)'dt=',dt +! write(*,*)'pi_e=',pi_e +! write(*,*)'ciacw=',ciacw +! write(*,*)'ciacr=',ciacr +! write(*,*)'cracw=',cracw +! write(*,*)'araut=',araut +! write(*,*)'braut=',braut +!! END OF adding, 2015-03-30 +!----------- + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + t_phy(i,k,j) = th_phy(i,k,j)*pi_phy(i,k,j) + qv(i,k,j)=qv(i,k,j)/(1.+qv(i,k,j)) !Convert to specific humidity + ENDDO + ENDDO + ENDDO + +! initial diagnostic variables and data assimilation vars +! (will need to delete this part in the future) + + DO k = 1,4 + DO i = ITLO,ITHI + NSTATS(i,k)=0. + ENDDO + ENDDO + + DO k = 1,5 + DO i = ITLO,ITHI + QMAX(i,k)=0. + ENDDO + ENDDO + + DO k = 1,22 + DO i = ITLO,ITHI + QTOT(i,k)=0. + ENDDO + ENDDO + +! initial data assimilation vars (will need to delete this part in the future) + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + TLATGS_PHY (i,k,j)=0. + TRAIN_PHY (i,k,j)=0. + ENDDO + ENDDO + ENDDO + + DO j = jts,jte + DO i = its,ite + ACPREC(i,j)=0. + APREC (i,j)=0. + PREC (i,j)=0. + SR (i,j)=0. + ENDDO + ENDDO + +!-- 6/11/2010: Update QT, F_ice, F_rain arrays + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + QT(I,K,J)=QC(I,K,J)+QR(I,K,J)+QI(I,K,J) + IF (QI(I,K,J) <= EPSQ) THEN + F_ICE_PHY(I,K,J)=0. + F_RIMEF_PHY(I,K,J)=1. + IF (T_PHY(I,K,J) < T_ICEK) F_ICE_PHY(I,K,J)=1. + ELSE + F_ICE_PHY(I,K,J)=MAX( 0., MIN(1., QI(I,K,J)/QT(I,K,J) ) ) + F_RIMEF_PHY(I,K,J)=QRIMEF(I,K,J)/QI(I,K,J) + ENDIF + IF (QR(I,K,J) <= EPSQ) THEN + F_RAIN_PHY(I,K,J)=0. + ELSE + F_RAIN_PHY(I,K,J)=QR(I,K,J)/(QR(I,K,J)+QC(I,K,J)) + ENDIF + ENDDO + ENDDO + ENDDO + +!----------------------------------------------------------------------- + + CALL EGCP01DRV(GID,DT,LOWLYR, & + & APREC,PREC,ACPREC,SR,NSTATS,QMAX,QTOT, & + & dz8w,rho_phy,qt,t_phy,qv,F_ICE_PHY,P_PHY, & + & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte ) +!----------------------------------------------------------------------- + + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + th_phy(i,k,j) = t_phy(i,k,j)/pi_phy(i,k,j) + qv(i,k,j)=qv(i,k,j)/(1.-qv(i,k,j)) !Convert to mixing ratio + WC=qt(I,K,J) + QI(I,K,J)=0. + QR(I,K,J)=0. + QC(I,K,J)=0. + IF(F_ICE_PHY(I,K,J)>=1.)THEN + QI(I,K,J)=WC + ELSEIF(F_ICE_PHY(I,K,J)<=0.)THEN + QC(I,K,J)=WC + ELSE + QI(I,K,J)=F_ICE_PHY(I,K,J)*WC + QC(I,K,J)=WC-QI(I,K,J) + ENDIF +! + IF(QC(I,K,J)>0..AND.F_RAIN_PHY(I,K,J)>0.)THEN + IF(F_RAIN_PHY(I,K,J).GE.1.)THEN + QR(I,K,J)=QC(I,K,J) + QC(I,K,J)=0. + ELSE + QR(I,K,J)=F_RAIN_PHY(I,K,J)*QC(I,K,J) + QC(I,K,J)=QC(I,K,J)-QR(I,K,J) + ENDIF + endif + QRIMEF(I,K,J)=QI(I,K,J)*F_RIMEF_PHY(I,K,J) + ENDDO + ENDDO + ENDDO +! +! update rain (from m to mm) + + DO j=jts,jte + DO i=its,ite + RAINNC(i,j)=APREC(i,j)*1000.+RAINNC(i,j) + RAINNCV(i,j)=APREC(i,j)*1000. + ENDDO + ENDDO +! +!HWRF MP_RESTART_STATE(MY_T1:MY_T2)=MY_GROWTH(MY_T1:MY_T2) +!HWRF MP_RESTART_STATE(MY_T2+1)=C1XPVS0 +!HWRF MP_RESTART_STATE(MY_T2+2)=C2XPVS0 +!HWRF MP_RESTART_STATE(MY_T2+3)=C1XPVS +!HWRF MP_RESTART_STATE(MY_T2+4)=C2XPVS +!HWRF MP_RESTART_STATE(MY_T2+5)=CIACW +!HWRF MP_RESTART_STATE(MY_T2+6)=CIACR +!HWRF MP_RESTART_STATE(MY_T2+7)=CRACW +!HWRF MP_RESTART_STATE(MY_T2+8)=CRAUT +!HWRF! +!HWRF TBPVS_STATE(1:NX) =TBPVS(1:NX) +!HWRF TBPVS0_STATE(1:NX)=TBPVS0(1:NX) + +!----------------------------------------------------------------------- + + END SUBROUTINE FER_HIRES_ADVECT + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + + SUBROUTINE EGCP01DRV(GID, & !GID gopal's doing + & DTPH,LOWLYR,APREC,PREC,ACPREC,SR, & + & NSTATS,QMAX,QTOT, & + & dz8w,RHO_PHY,CWM_PHY,T_PHY,Q_PHY,F_ICE_PHY,P_PHY, & + & F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY,TRAIN_PHY, & + & ids,ide, jds,jde, kds,kde, & + & ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte) +!----------------------------------------------------------------------- +! DTPH Physics time step (s) +! CWM_PHY (qt) Mixing ratio of the total condensate. kg/kg +! Q_PHY Mixing ratio of water vapor. kg/kg +! F_RAIN_PHY Fraction of rain. +! F_ICE_PHY Fraction of ice. +! F_RIMEF_PHY Mass ratio of rimed ice (rime factor). +! +!TLATGS_PHY,TRAIN_PHY,APREC,PREC,ACPREC,SR are not directly related the +!micrphysics sechme. Instead, they will be used by Eta precip assimilation. +! +!NSTATS,QMAX,QTOT are used for diagnosis purposes. +! +!----------------------------------------------------------------------- +!--- Variables APREC,PREC,ACPREC,SR are calculated for precip assimilation +! and/or ZHAO's scheme in Eta and are not required by this microphysics +! scheme itself. +!--- NSTATS,QMAX,QTOT are used for diagnosis purposes only. They will be +! printed out when PRINT_diag is true. +! +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +! + INTEGER, PARAMETER :: ITLO=-60, ITHI=40 +! VARIABLES PASSED IN/OUT + INTEGER,INTENT(IN ) :: ids,ide, jds,jde, kds,kde & + & ,ims,ime, jms,jme, kms,kme & + & ,its,ite, jts,jte, kts,kte + INTEGER,INTENT(IN ) :: GID ! grid%id gopal's doing + REAL,INTENT(IN) :: DTPH + INTEGER, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT) :: LOWLYR + INTEGER,DIMENSION(ITLO:ITHI,4),INTENT(INOUT) :: NSTATS + REAL,DIMENSION(ITLO:ITHI,5),INTENT(INOUT) :: QMAX + REAL,DIMENSION(ITLO:ITHI,22),INTENT(INOUT) :: QTOT + REAL,DIMENSION(ims:ime,jms:jme),INTENT(INOUT) :: & + & APREC,PREC,ACPREC,SR + REAL,DIMENSION( its:ite, kts:kte, jts:jte ),INTENT(INOUT) :: t_phy + REAL,DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN) :: & + & dz8w,P_PHY,RHO_PHY + REAL,DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(INOUT) :: & + & CWM_PHY, F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY,TLATGS_PHY & + & ,Q_PHY,TRAIN_PHY +! +!----------------------------------------------------------------------- +!LOCAL VARIABLES +!----------------------------------------------------------------------- +! +!HWRF - Below are directives in the operational code that have been removed, +! where "TEMP_DEX" has been replaced with "I,J,L" and "TEMP_DIMS" has +! been replaced with "its:ite,jts:jte,kts:kte" +!HWRF#define CACHE_FRIENDLY_MP_ETANEW +!HWRF#ifdef CACHE_FRIENDLY_MP_ETANEW +!HWRF# define TEMP_DIMS kts:kte,its:ite,jts:jte +!HWRF# define TEMP_DEX L,I,J +!HWRF#else +!HWRF# define TEMP_DIMS its:ite,jts:jte,kts:kte +!HWRF# define TEMP_DEX I,J,L +!HWRF#endif +!HWRF! + INTEGER :: LSFC,I,J,I_index,J_index,L,K,KFLIP +!HWRF REAL,DIMENSION(TEMP_DIMS) :: CWM,T,Q,TRAIN,TLATGS,P + REAL,DIMENSION(its:ite,jts:jte,kts:kte) :: & + & CWM,T,Q,TRAIN,TLATGS,P + REAL,DIMENSION(kts:kte,its:ite,jts:jte) :: F_ice,F_rain,F_RimeF + INTEGER,DIMENSION(its:ite,jts:jte) :: LMH + REAL :: TC,WC,QI,QR,QW,Fice,Frain,DUM,ASNOW,ARAIN + REAL,DIMENSION(kts:kte) :: P_col,Q_col,T_col,QV_col,WC_col, & + RimeF_col,QI_col,QR_col,QW_col, THICK_col, RHC_col, DPCOL !GFDL + REAL,DIMENSION(2) :: PRECtot,PRECmax +!----------------------------------------------------------------------- +! + DO J=JTS,JTE + DO I=ITS,ITE + LMH(I,J) = KTE-LOWLYR(I,J)+1 + ENDDO + ENDDO + + + DO 98 J=JTS,JTE + DO 98 I=ITS,ITE + DO L=KTS,KTE + KFLIP=KTE+1-L + CWM(I,J,L)=CWM_PHY(I,KFLIP,J) + T(I,J,L)=T_PHY(I,KFLIP,J) + Q(I,J,L)=Q_PHY(I,KFLIP,J) + P(I,J,L)=P_PHY(I,KFLIP,J) + TLATGS(I,J,L)=TLATGS_PHY(I,KFLIP,J) + TRAIN(I,J,L)=TRAIN_PHY(I,KFLIP,J) + F_ice(L,I,J)=F_ice_PHY(I,KFLIP,J) + F_rain(L,I,J)=F_rain_PHY(I,KFLIP,J) + F_RimeF(L,I,J)=F_RimeF_PHY(I,KFLIP,J) + ENDDO +98 CONTINUE + + DO 100 J=JTS,JTE + DO 100 I=ITS,ITE + LSFC=LMH(I,J) ! "L" of surface +! + DO K=KTS,KTE + KFLIP=KTE+1-K + DPCOL(K)=RHO_PHY(I,KFLIP,J)*GRAV*dz8w(I,KFLIP,J) + ENDDO +! + ! + !--- Initialize column data (1D arrays) + ! + IF (CWM(I,J,1) .LE. EPSQ) CWM(I,J,1)=EPSQ + F_ice(1,I,J)=1. + F_rain(1,I,J)=0. + F_RimeF(1,I,J)=1. + DO L=1,LSFC + ! + !--- Pressure (Pa) = (Psfc-Ptop)*(ETA/ETA_sfc)+Ptop + ! + P_col(L)=P(I,J,L) + ! + !--- Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_sfc) + ! + THICK_col(L)=DPCOL(L)*RGRAV + T_col(L)=T(I,J,L) + TC=T_col(L)-T0C + QV_col(L)=max(EPSQ, Q(I,J,L)) + IF (CWM(I,J,L) .LE. EPSQ1) THEN + WC_col(L)=0. + IF (TC .LT. T_ICE) THEN + F_ice(L,I,J)=1. + ELSE + F_ice(L,I,J)=0. + ENDIF + F_rain(L,I,J)=0. + F_RimeF(L,I,J)=1. + ELSE + WC_col(L)=CWM(I,J,L) + +!-- Debug 20120111: TC==TC will fail if NaN +IF (WC_col(L)>QTwarn .AND. P_col(L)1 g/kg condensate in stratosphere; I,J,L,TC,P,QT=', & + I,J,L,TC,.01*P_col(L),1000.*WC_col(L) + QTwarn=MAX(WC_col(L),10.*QTwarn) + Pwarn=MIN(P_col(L),0.5*Pwarn) +ENDIF +!-- TC/=TC will pass if TC is NaN +IF (WARN5 .AND. TC/=TC) THEN + WRITE(0,*) 'WARN5: NaN temperature; I,J,L,P=',I,J,L,.01*P_col(L) + WARN5=.FALSE. +ENDIF + + ENDIF + ! + !--- Determine composition of condensate in terms of + ! cloud water, ice, & rain + ! + WC=WC_col(L) + QI=0. + QR=0. + QW=0. + Fice=F_ice(L,I,J) + Frain=F_rain(L,I,J) + IF (Fice .GE. 1.) THEN + QI=WC + ELSE IF (Fice .LE. 0.) THEN + QW=WC + ELSE + QI=Fice*WC + QW=WC-QI + ENDIF + IF (QW.GT.0. .AND. Frain.GT.0.) THEN + IF (Frain .GE. 1.) THEN + QR=QW + QW=0. + ELSE + QR=Frain*QW + QW=QW-QR + ENDIF + ENDIF + IF (QI .LE. 0.) F_RimeF(L,I,J)=1. + RimeF_col(L)=F_RimeF(L,I,J) + QI_col(L)=QI + QR_col(L)=QR + QW_col(L)=QW +!GFDL => New. Added RHC_col to allow for height- and grid-dependent values for +!GFDL the relative humidity threshold for condensation ("RHgrd") +!6/11/2010 mod - Use lower RHgrd_out threshold for < 850 hPa +!------------------------------------------------------------ + IF(GID .EQ. 1 .AND. P_col(L)0) associated with snow + ! + APREC(I,J)=(ARAIN+ASNOW)*RRHOL ! Accumulated surface precip (depth in m) !<--- Ying + PREC(I,J)=PREC(I,J)+APREC(I,J) + ACPREC(I,J)=ACPREC(I,J)+APREC(I,J) + IF(APREC(I,J) .LT. 1.E-8) THEN + SR(I,J)=0. + ELSE + SR(I,J)=RRHOL*ASNOW/APREC(I,J) + ENDIF +! ! +! !--- Debug statistics +! ! +! IF (PRINT_diag) THEN +! PRECtot(1)=PRECtot(1)+ARAIN +! PRECtot(2)=PRECtot(2)+ASNOW +! PRECmax(1)=MAX(PRECmax(1), ARAIN) +! PRECmax(2)=MAX(PRECmax(2), ASNOW) +! ENDIF + + +!####################################################################### +!####################################################################### +! +100 CONTINUE ! End "I" & "J" loops + DO 101 J=JTS,JTE + DO 101 I=ITS,ITE + DO L=KTS,KTE + KFLIP=KTE+1-L + CWM_PHY(I,KFLIP,J)=CWM(I,J,L) + T_PHY(I,KFLIP,J)=T(I,J,L) + Q_PHY(I,KFLIP,J)=Q(I,J,L) + TLATGS_PHY(I,KFLIP,J)=TLATGS(I,J,L) + TRAIN_PHY(I,KFLIP,J)=TRAIN(I,J,L) + F_ice_PHY(I,KFLIP,J)=F_ice(L,I,J) + F_rain_PHY(I,KFLIP,J)=F_rain(L,I,J) + F_RimeF_PHY(I,KFLIP,J)=F_RimeF(L,I,J) + ENDDO +101 CONTINUE +! + END SUBROUTINE EGCP01DRV +! +! +!############################################################################### +! ***** VERSION OF MICROPHYSICS DESIGNED FOR HIGHER RESOLUTION MESO ETA MODEL +! (1) Represents sedimentation by preserving a portion of the precipitation +! through top-down integration from cloud-top. Modified procedure to +! Zhao and Carr (1997). +! (2) Microphysical equations are modified to be less sensitive to time +! steps by use of Clausius-Clapeyron equation to account for changes in +! saturation mixing ratios in response to latent heating/cooling. +! (3) Prevent spurious temperature oscillations across 0C due to +! microphysics. +! (4) Uses lookup tables for: calculating two different ventilation +! coefficients in condensation and deposition processes; accretion of +! cloud water by precipitation; precipitation mass; precipitation rate +! (and mass-weighted precipitation fall speeds). +! (5) Assumes temperature-dependent variation in mean diameter of large ice +! (Houze et al., 1979; Ryan et al., 1996). +! -> 8/22/01: This relationship has been extended to colder temperatures +! to parameterize smaller large-ice particles down to mean sizes of MDImin, +! which is 50 microns reached at -55.9C. +! (6) Attempts to differentiate growth of large and small ice, mainly for +! improved transition from thin cirrus to thick, precipitating ice +! anvils. +! (7) Top-down integration also attempts to treat mixed-phase processes, +! allowing a mixture of ice and water. Based on numerous observational +! studies, ice growth is based on nucleation at cloud top & +! subsequent growth by vapor deposition and riming as the ice particles +! fall through the cloud. Nucleation rates are a function of temperature. +! (8) Depositional growth of newly nucleated ice is calculated for large time +! steps using Fig. 8 of Miller and Young (JAS, 1979), at 1 deg intervals +! using their ice crystal masses calculated after 600 s of growth in water +! saturated conditions. The growth rates are normalized by time step +! assuming 3D growth with time**1.5 following eq. (6.3) in Young (1993). +! (9) Ice precipitation rates can increase due to increase in response to +! cloud water riming due to (a) increased density & mass of the rimed +! ice, and (b) increased fall speeds of rimed ice. +!############################################################################### +!############################################################################### +! + SUBROUTINE EGCP01COLUMN ( ARAIN, ASNOW, DTPH, I_index, J_index, & + & LSFC, P_col, QI_col, QR_col, QV_col, QW_col, RimeF_col, T_col, & + & THICK_col, WC_col, RHC_col, KTS,KTE,NSTATS,QMAX,QTOT) !GFDL +! +!############################################################################### +!############################################################################### +! +!------------------------------------------------------------------------------- +!----- NOTE: Code is currently set up w/o threading! +!------------------------------------------------------------------------------- +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . +! SUBPROGRAM: Grid-scale microphysical processes - condensation & precipitation +! PRGRMMR: Ferrier ORG: W/NP22 DATE: 08-2001 +! PRGRMMR: Jin (Modification for WRF structure) +!------------------------------------------------------------------------------- +! ABSTRACT: +! * Merges original GSCOND & PRECPD subroutines. +! * Code has been substantially streamlined and restructured. +! * Exchange between water vapor & small cloud condensate is calculated using +! the original Asai (1965, J. Japan) algorithm. See also references to +! Yau and Austin (1979, JAS), Rutledge and Hobbs (1983, JAS), and Tao et al. +! (1989, MWR). This algorithm replaces the Sundqvist et al. (1989, MWR) +! parameterization. +!------------------------------------------------------------------------------- +! +! USAGE: +! * CALL EGCP01COLUMN FROM SUBROUTINE EGCP01DRV +! +! INPUT ARGUMENT LIST: +! DTPH - physics time step (s) +! I_index - I index +! J_index - J index +! LSFC - Eta level of level above surface, ground +! P_col - vertical column of model pressure (Pa) +! QI_col - vertical column of model ice mixing ratio (kg/kg) +! QR_col - vertical column of model rain ratio (kg/kg) +! QV_col - vertical column of model water vapor specific humidity (kg/kg) +! QW_col - vertical column of model cloud water mixing ratio (kg/kg) +! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) +! T_col - vertical column of model temperature (deg K) +! THICK_col - vertical column of model mass thickness (density*height increment) +! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) +! RHC_col - vertical column of threshold relative humidity for onset of condensation (ratio) !GFDL +! +! +! OUTPUT ARGUMENT LIST: +! ARAIN - accumulated rainfall at the surface (kg) +! ASNOW - accumulated snowfall at the surface (kg) +! QV_col - vertical column of model water vapor specific humidity (kg/kg) +! WC_col - vertical column of model mixing ratio of total condensate (kg/kg) +! QW_col - vertical column of model cloud water mixing ratio (kg/kg) +! QI_col - vertical column of model ice mixing ratio (kg/kg) +! QR_col - vertical column of model rain ratio (kg/kg) +! RimeF_col - vertical column of rime factor for ice in model (ratio, defined below) +! T_col - vertical column of model temperature (deg K) +! +! OUTPUT FILES: +! NONE +! +! Subprograms & Functions called: +! * Real Function CONDENSE - cloud water condensation +! * Real Function DEPOSIT - ice deposition (not sublimation) +! +! UNIQUE: NONE +! +! LIBRARY: NONE +! +! COMMON BLOCKS: +! CMICRO_CONS - key constants initialized in GSMCONST +! CMICRO_STATS - accumulated and maximum statistics +! CMY_GROWTH - lookup table for growth of ice crystals in +! water saturated conditions (Miller & Young, 1979) +! IVENT_TABLES - lookup tables for ventilation effects of ice +! IACCR_TABLES - lookup tables for accretion rates of ice +! IMASS_TABLES - lookup tables for mass content of ice +! IRATE_TABLES - lookup tables for precipitation rates of ice +! IRIME_TABLES - lookup tables for increase in fall speed of rimed ice +! RVENT_TABLES - lookup tables for ventilation effects of rain +! RACCR_TABLES - lookup tables for accretion rates of rain +! RMASS_TABLES - lookup tables for mass content of rain +! RVELR_TABLES - lookup tables for fall speeds of rain +! RRATE_TABLES - lookup tables for precipitation rates of rain +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! MACHINE : IBM SP +! +! +!------------------------------------------------------------------------- +!--------------- Arrays & constants in argument list --------------------- +!------------------------------------------------------------------------- +! + IMPLICIT NONE +! + INTEGER,INTENT(IN) :: KTS,KTE,I_index, J_index, LSFC + REAL,INTENT(INOUT) :: ARAIN, ASNOW + REAL,DIMENSION(KTS:KTE),INTENT(INOUT) :: P_col, QI_col,QR_col & + & ,QV_col ,QW_col, RimeF_col, T_col, THICK_col, WC_col, RHC_col !GFDL +! +!------------------------------------------------------------------------- +!-------------- Common blocks for microphysical statistics --------------- +!------------------------------------------------------------------------- +! +!------------------------------------------------------------------------- +!--------- Common blocks for constants initialized in GSMCONST ---------- +! + INTEGER, PARAMETER :: ITLO=-60, ITHI=40 + INTEGER,INTENT(INOUT) :: NSTATS(ITLO:ITHI,4) + REAL,INTENT(INOUT) :: QMAX(ITLO:ITHI,5),QTOT(ITLO:ITHI,22) +! +!------------------------------------------------------------------------- +!--------------- Common blocks for various lookup tables ----------------- +! +!--- Discretized growth rates of small ice crystals after their nucleation +! at 1 C intervals from -1 C to -35 C, based on calculations by Miller +! and Young (1979, JAS) after 600 s of growth. Resultant growth rates +! are multiplied by physics time step in GSMCONST. +! +!------------------------------------------------------------------------- +! +!--- Mean ice-particle diameters varying from 50 microns to 1000 microns +! (1 mm), assuming an exponential size distribution. +! +!---- Meaning of the following arrays: +! - mdiam - mean diameter (m) +! - VENTI1 - integrated quantity associated w/ ventilation effects +! (capacitance only) for calculating vapor deposition onto ice +! - VENTI2 - integrated quantity associated w/ ventilation effects +! (with fall speed) for calculating vapor deposition onto ice +! - ACCRI - integrated quantity associated w/ cloud water collection by ice +! - MASSI - integrated quantity associated w/ ice mass +! - VSNOWI - mass-weighted fall speed of snow (large ice), used to calculate +! precipitation rates +! +! +!------------------------------------------------------------------------- +! +!--- VEL_RF - velocity increase of rimed particles as functions of crude +! particle size categories (at 0.1 mm intervals of mean ice particle +! sizes) and rime factor (different values of Rime Factor of 1.1**N, +! where N=0 to Nrime). +! +!------------------------------------------------------------------------- +! +!--- Mean rain drop diameters varying from 50 microns (0.05 mm) to 1000 microns +! (1.0 mm) assuming an exponential size distribution. +! +!------------------------------------------------------------------------- +!------- Key parameters, local variables, & important comments --------- +!----------------------------------------------------------------------- +! +!--- TOLER => Tolerance or precision for accumulated precipitation +! + REAL, PARAMETER :: TOLER=5.E-7, C2=1./6., RHO0=1.194, Xratio=.025 +! +!--- If BLEND=1: +! precipitation (large) ice amounts are estimated at each level as a +! blend of ice falling from the grid point above and the precip ice +! present at the start of the time step (see TOT_ICE below). +!--- If BLEND=0: +! precipitation (large) ice amounts are estimated to be the precip +! ice present at the start of the time step. +! +!--- Extended to include sedimentation of rain on 2/5/01 +! + REAL, PARAMETER :: BLEND=1. +! +!----------------------------------------------------------------------- +!--- Local variables +!----------------------------------------------------------------------- +! + REAL EMAIRI, N0r, NLICE, NSmICE, NInuclei, RHgrd + LOGICAL :: CLEAR, ICE_logical, DBG_logical, RAIN_logical, & + & LARGE_RF, HAIL + INTEGER :: IDR,INDEX_MY,INDEXR,INDEXR1,INDEXS,IPASS,ITDX,IXRF, & + & IXS,LBEF,L +! + REAL :: ABI,ABW,AIEVP,ARAINnew,ASNOWnew,BLDTRH,BUDGET, & + & CREVP,DELI,DELR,DELT,DELV,DELW,DENOMF, & + & DENOMI,DENOMW,DENOMWI,DIDEP, & + & DIEVP,DIFFUS,DLI,DTPH,DTRHO,DUM,DUM1,DUM2,DUM3, & + & DWV0,DWVI,DWVR,DYNVIS,ESI,ESW,FIR,FLARGE,FLIMASS, & + & FSMALL,FWR,FWS,GAMMAR,GAMMAS, & + & PCOND,PIACR,PIACW,PIACWI,PIACWR,PICND,PIDEP,PIDEP_max, & + & PIEVP,PILOSS,PIMLT,PINT,PP,PRACW,PRAUT,PREVP,PRLOSS, & + & QI,QInew,QLICE,QR,QRnew,QSI,QSIgrd,QSInew,QSW,QSW0, & + & QSWgrd,QSWnew,QT,QTICE,QTnew,QTRAIN,QV,QW,QWnew, & + & RFACTOR,RHO,RIMEF,RIMEF1,RQR,RR,RRHO,SFACTOR, & + & TC,TCC,TFACTOR,THERM_COND,THICK,TK,TK2,TNEW, & + & TOT_ICE,TOT_ICEnew,TOT_RAIN,TOT_RAINnew, & + & VEL_INC,VENTR,VENTIL,VENTIS,VRAIN1,VRAIN2,VRIMEF,VSNOW, & + & WC,WCnew,WSgrd,WS,WSnew,WV,WVnew, & + & XLF,XLF1,XLI,XLV,XLV1,XLV2,XLIMASS,XRF, & + & NLImax,NSImax,QRdum,QSmICE,QLgIce,RQLICE,VCI,VRabove !-- new variables + REAL, SAVE :: Revised_LICE=1.e-3 !-- kg/m**3 +! +!####################################################################### +!########################## Begin Execution ############################ +!####################################################################### +! +! + ARAIN=0. ! Accumulated rainfall into grid box from above (kg/m**2) + ASNOW=0. ! Accumulated snowfall into grid box from above (kg/m**2) + VRabove=0. ! Fall speed of rain into grid box from above (m/s) +! +!----------------------------------------------------------------------- +!------------ Loop from top (L=1) to surface (L=LSFC) ------------------ +!----------------------------------------------------------------------- +! + DO 10 L=1,LSFC +!--- Skip this level and go to the next lower level if no condensate +! and very low specific humidities +! + IF (QV_col(L).LE.EPSQ .AND. WC_col(L).LE.EPSQ) GO TO 10 +! +!----------------------------------------------------------------------- +!------------ Proceed with cloud microphysics calculations ------------- +!----------------------------------------------------------------------- +! + TK=T_col(L) ! Temperature (deg K) + TC=TK-T0C ! Temperature (deg C) + PP=P_col(L) ! Pressure (Pa) + QV=QV_col(L) ! Specific humidity of water vapor (kg/kg) + WV=QV/(1.-QV) ! Water vapor mixing ratio (kg/kg) + WC=WC_col(L) ! Grid-scale mixing ratio of total condensate (water or ice; kg/kg) + RHgrd=RHC_col(L) ! Threshold relative humidity for the onset of condensation +! +!----------------------------------------------------------------------- +!--- Moisture variables below are mixing ratios & not specifc humidities +!----------------------------------------------------------------------- +! + CLEAR=.TRUE. +! +!--- This check is to determine grid-scale saturation when no condensate is present +! + ESW=MIN(1000.*FPVS0(TK),0.99*PP) ! Saturation vapor pressure w/r/t water + QSW=EPS*ESW/(PP-ESW) ! Saturation mixing ratio w/r/t water + WS=QSW ! General saturation mixing ratio (water/ice) + QSI=QSW ! Saturation mixing ratio w/r/t ice + IF (TC .LT. 0.) THEN + ESI=MIN(1000.*FPVS(TK),0.99*PP) ! Saturation vapor pressure w/r/t ice + QSI=EPS*ESI/(PP-ESI) ! Saturation mixing ratio w/r/t water + WS=QSI ! General saturation mixing ratio (water/ice) + ENDIF +! +!--- Effective grid-scale Saturation mixing ratios +! + QSWgrd=RHgrd*QSW + QSIgrd=RHgrd*QSI + WSgrd=RHgrd*WS +! +!--- Check if air is subsaturated and w/o condensate +! + IF (WV.GT.WSgrd .OR. WC.GT.EPSQ) CLEAR=.FALSE. +! +!--- Check if any rain is falling into layer from above +! + IF (ARAIN .GT. CLIMIT) THEN + CLEAR=.FALSE. + ELSE + ARAIN=0. + VRabove=0. + ENDIF +! +!--- Check if any ice is falling into layer from above +! +!--- NOTE that "SNOW" in variable names is synonomous with +! large, precipitation ice particles +! + IF (ASNOW .GT. CLIMIT) THEN + CLEAR=.FALSE. + ELSE + ASNOW=0. + ENDIF +! +!----------------------------------------------------------------------- +!-- Loop to the end if in clear, subsaturated air free of condensate --- +!----------------------------------------------------------------------- +! + IF (CLEAR) GO TO 10 +! +!----------------------------------------------------------------------- +!--------- Initialize RHO, THICK & microphysical processes ------------- +!----------------------------------------------------------------------- +! +! +!--- Virtual temperature, TV=T*(1./EPS-1)*Q, Q is specific humidity; +! (see pp. 63-65 in Fleagle & Businger, 1963) +! + RHO=PP/(RD*TK*(1.+EPS1*QV)) ! Air density (kg/m**3) + RRHO=1./RHO ! Reciprocal of air density + DTRHO=DTPH*RHO ! Time step * air density + BLDTRH=BLEND*DTRHO ! Blend parameter * time step * air density + THICK=THICK_col(L) ! Layer thickness = RHO*DZ = -DP/G = (Psfc-Ptop)*D_ETA/(G*ETA_sfc) +! + ARAINnew=0. ! Updated accumulated rainfall + ASNOWnew=0. ! Updated accumulated snowfall + QI=QI_col(L) ! Ice mixing ratio + QInew=0. ! Updated ice mixing ratio + QR=QR_col(L) ! Rain mixing ratio + QRnew=0. ! Updated rain ratio + QW=QW_col(L) ! Cloud water mixing ratio + QWnew=0. ! Updated cloud water ratio +! + PCOND=0. ! Condensation (>0) or evaporation (<0) of cloud water (kg/kg) + PIDEP=0. ! Deposition (>0) or sublimation (<0) of ice crystals (kg/kg) + PIACW=0. ! Cloud water collection (riming) by precipitation ice (kg/kg; >0) + PIACWI=0. ! Growth of precip ice by riming (kg/kg; >0) + PIACWR=0. ! Shedding of accreted cloud water to form rain (kg/kg; >0) + PIACR=0. ! Freezing of rain onto large ice at supercooled temps (kg/kg; >0) + PICND=0. ! Condensation (>0) onto wet, melting ice (kg/kg) + PIEVP=0. ! Evaporation (<0) from wet, melting ice (kg/kg) + PIMLT=0. ! Melting ice (kg/kg; >0) + PRAUT=0. ! Cloud water autoconversion to rain (kg/kg; >0) + PRACW=0. ! Cloud water collection (accretion) by rain (kg/kg; >0) + PREVP=0. ! Rain evaporation (kg/kg; <0) +! +!--- Double check input hydrometeor mixing ratios +! +! DUM=WC-(QI+QW+QR) +! DUM1=ABS(DUM) +! DUM2=TOLER*MIN(WC, QI+QW+QR) +! IF (DUM1 .GT. DUM2) THEN +! WRITE(6,"(/2(a,i4),a,i2)") '{@ i=',I_index,' j=',J_index, +! & ' L=',L +! WRITE(6,"(4(a12,g11.4,1x))") +! & '{@ TCold=',TC,'P=',.01*PP,'DIFF=',DUM,'WCold=',WC, +! & '{@ QIold=',QI,'QWold=',QW,'QRold=',QR +! ENDIF +! +!*********************************************************************** +!*********** MAIN MICROPHYSICS CALCULATIONS NOW FOLLOW! **************** +!*********************************************************************** +! +!--- Calculate a few variables, which are used more than once below +! +!--- Latent heat of vaporization as a function of temperature from +! Bolton (1980, JAS) +! + XLV=3.148E6-2370*TK ! Latent heat of vaporization (Lv) + XLF=XLS-XLV ! Latent heat of fusion (Lf) + XLV1=XLV*RCP ! Lv/Cp + XLF1=XLF*RCP ! Lf/Cp + TK2=1./(TK*TK) ! 1./TK**2 + XLV2=XLV*XLV*QSW*TK2/RV ! Lv**2*Qsw/(Rv*TK**2) + DENOMW=1.+XLV2*RCP ! Denominator term, Clausius-Clapeyron correction +! +!--- Basic thermodynamic quantities +! * DYNVIS - dynamic viscosity [ kg/(m*s) ] +! * THERM_COND - thermal conductivity [ J/(m*s*K) ] +! * DIFFUS - diffusivity of water vapor [ m**2/s ] +! + TFACTOR=SQRT(TK*TK*TK)/(TK+120.) + DYNVIS=1.496E-6*TFACTOR + THERM_COND=2.116E-3*TFACTOR + DIFFUS=8.794E-5*TK**1.81/PP +! +!--- Air resistance term for the fall speed of ice following the +! basic research by Heymsfield, Kajikawa, others +! + GAMMAS=MIN(1.5, (1.E5/PP)**C1) !-- limited to 1.5x +! +!--- Air resistance for rain fall speed (Beard, 1985, JAS, p.470) +! + GAMMAR=(RHO0/RHO)**.4 +! +!---------------------------------------------------------------------- +!------------- IMPORTANT MICROPHYSICS DECISION TREE ----------------- +!---------------------------------------------------------------------- +! +!--- Determine if conditions supporting ice are present +! + IF (TC.LT.0. .OR. QI.GT.EPSQ .OR. ASNOW.GT.CLIMIT) THEN + ICE_logical=.TRUE. + ELSE + ICE_logical=.FALSE. + QLICE=0. + QTICE=0. + ENDIF + IF (T_ICE <= -100.) THEN + ICE_logical=.FALSE. + QLICE=0. + QTICE=0. + ENDIF +! +!--- Determine if rain is present +! + RAIN_logical=.FALSE. + IF (ARAIN.GT.CLIMIT .OR. QR.GT.EPSQ) RAIN_logical=.TRUE. +! +ice_test: IF (ICE_logical) THEN +! +!--- IMPORTANT: Estimate time-averaged properties. +! +!--- +! * FLARGE - ratio of number of large ice to total (large & small) ice +! * FSMALL - ratio of number of small ice crystals to large ice particles +! -> Small ice particles are assumed to have a mean diameter of 50 microns. +! * QSmICE - estimated mixing ratio for small cloud ice +!--- +! * TOT_ICE - total mass (small & large) ice before microphysics, +! which is the sum of the total mass of large ice in the +! current layer and the input flux of ice from above +! * PILOSS - greatest loss (<0) of total (small & large) ice by +! sublimation, removing all of the ice falling from above +! and the ice within the layer +! * RimeF1 - Rime Factor, which is the mass ratio of total (unrimed & rimed) +! ice mass to the unrimed ice mass (>=1) +! * VrimeF - the velocity increase due to rime factor or melting (ratio, >=1) +! * VSNOW - Fall speed of rimed snow w/ air resistance correction +! * VCI - Fall speed of 50-micron ice crystals w/ air resistance correction +! * EMAIRI - equivalent mass of air associated layer and with fall of snow into layer +! * XLIMASS - used for debugging, associated with calculating large ice mixing ratio +! * FLIMASS - mass fraction of large ice +! * QTICE - time-averaged mixing ratio of total ice +! * QLICE - time-averaged mixing ratio of large ice +! * NLICE - time-averaged number concentration of large ice +! * NSmICE - number concentration of small ice crystals at current level +! * QSmICE - mixing ratio of small ice crystals at current level +!--- +!--- Assumed number fraction of large ice particles to total (large & small) +! ice particles, which is based on a general impression of the literature. +! + NInuclei=0. + NSmICE=0. + QSmICE=0. + IF (TC<0.) THEN +! +!--- Max # conc of small ice crystals based on 10% of total ice content +! or the parameter NSI_max +! + NSImax=MAX(NSI_max, 0.1*RHO*QI/MASSI(MDImin) ) +! +!-- Specify Fletcher, Cooper, Meyers, etc. here for ice nuclei concentrations +! + NInuclei=MIN(0.01*EXP(-0.6*TC), NSImax) !- Fletcher (1962) + IF (QI>EPSQ) THEN + DUM=RRHO*MASSI(MDImin) + NSmICE=MIN(NInuclei, QI/DUM) + QSmICE=NSmICE*DUM + ENDIF ! End IF (QI>EPSQ) + ENDIF ! End IF (TC<0.) + init_ice: IF (QI<=EPSQ .AND. ASNOW<=CLIMIT) THEN + INDEXS=MDImin + TOT_ICE=0. + PILOSS=0. + RimeF1=1. + VrimeF=1. + VEL_INC=GAMMAS + VSNOW=0. + VCI=0. + EMAIRI=THICK + XLIMASS=RimeF1*MASSI(INDEXS) + FLIMASS=1. + QLICE=0. + RQLICE=0. + QTICE=0. + NLICE=0. + ELSE init_ice + ! + !--- For T<0C mean particle size follows Houze et al. (JAS, 1979, p. 160), + ! converted from Fig. 5 plot of LAMDAs. Similar set of relationships + ! also shown in Fig. 8 of Ryan (BAMS, 1996, p. 66). + ! + DUM=XMImax*EXP(XMIexp*TC) + INDEXS=MIN(MDImax, MAX(MDImin, INT(DUM) ) ) + TOT_ICE=THICK*QI+BLEND*ASNOW + PILOSS=-TOT_ICE/THICK + LBEF=MAX(1,L-1) + DUM1=RimeF_col(LBEF) + DUM2=RimeF_col(L) + QLgICE=MAX(0., QI-QSmICE) !-- 1st-guess estimate of large ice + RimeF1=(DUM2*THICK*QLgICE+DUM1*BLEND*ASNOW)/TOT_ICE + VCI=GAMMAS*VSNOWI(MDImin) + vel_rime: IF (RimeF1<=1.) THEN + RimeF1=1. + VrimeF=1. + ELSE vel_rime +!--- Prevent rime factor (RimeF1) from exceeding a maximum value (RFmax) + RimeF1=MIN(RimeF1, RFmax) + IXS=MAX(2, MIN(INDEXS/100, 9)) + XRF=10.492*ALOG(RimeF1) + IXRF=MAX(0, MIN(INT(XRF), Nrime)) + IF (IXRF .GE. Nrime) THEN + VrimeF=VEL_RF(IXS,Nrime) + ELSE + VrimeF=VEL_RF(IXS,IXRF)+(XRF-FLOAT(IXRF))* & + & (VEL_RF(IXS,IXRF+1)-VEL_RF(IXS,IXRF)) + ENDIF + ENDIF vel_rime + VEL_INC=GAMMAS*VrimeF*SQRT(VrimeF) !-- Faster rimed ice fall speeds +! +!-- Specify NLImax depending on presence of high density ice (rime factors >10) +! + IF (RimeF1>10.) THEN + LARGE_RF=.TRUE. !-- Convective precipitation (and sleet) + NLImax=1.E3 + ELSE + LARGE_RF=.FALSE. !-- Non-convective precipitation +!-- NLImax slowly decreases from 10 L-1 at 0C to 5 L-1 at -40C and colder. + DUM=MAX(TC, T_ICE) + NLImax=10.E3*EXP(-0.017*DUM) +! Based on Aligo's email, added on 2012-02-09 +!-- Idea from Greg Thompson to smoothly increase the fall speed of melting snow + IF (TC>0.) THEN + VEL_INC=MAX(VEL_INC, VRabove/VSNOWI(INDEXS) ) + ENDIF + ENDIF + HAIL=.FALSE. + two_pass: DO IPASS=1,2 + VSNOW=VEL_INC*VSNOWI(INDEXS) + EMAIRI=THICK+BLDTRH*VSNOW + QLICE=(THICK*QLgICE+BLEND*ASNOW)/EMAIRI !-- Final estimate of large ice + QTICE=QLICE+QSmICE + FLIMASS=QLICE/QTICE + RQLICE=RHO*QLICE +hail_mode: IF (.NOT. HAIL) THEN + XLIMASS=RimeF1*MASSI(INDEXS) + NLICE=RQLICE/XLIMASS !-- NLICE > NLImax + ELSE hail_mode +!-- Executed only when IPASS=2, RF>10, INDEX=1000, & NLICE=NLImax + XLIMASS=RQLICE/NLICE !-- for debugging only + ENDIF hail_mode + IF (IPASS>=2) THEN + EXIT two_pass + ENDIF + DUM=RRHO*NLImin*MASSI(MDImin) !-- Minimum large ice mixing ratio + IF (QLICE<=DUM) THEN + INDEXS=MDImin + RimeF1=1. + CYCLE two_pass !-- Go to top of DO IPASS with IPASS=2 + ENDIF + IF (NLICE>=NLImin .AND. NLICE<=NLImax) THEN + EXIT two_pass + ENDIF +! +!--- Force NLICE to be between NLImin and NLImax when IPASS=1 +! + NLICE=MAX(NLImin, MIN(NLImax, NLICE) ) + XLI=RQLICE/(NLICE*RimeF1) +new_size: IF (XLI<=MASSI(MDImin) ) THEN + INDEXS=MDImin + ELSE IF (XLI<=MASSI(450) ) THEN new_size + DLI=9.5885E5*XLI**.42066 ! DLI in microns + INDEXS=MIN(MDImax, MAX(MDImin, INT(DLI) ) ) + ELSE IF (XLIRevised_LICE) THEN + WRITE(6,"(5(a12,g11.4,1x))") '{$ RimeF1=',RimeF1, & + & ' RHO*QLICE=',RQLICE,' TC=',TC,' NLICE=',NLICE, & + & ' NLICEold=',DUM2 + Revised_LICE=1.2*RQLICE + ENDIF + ENDIF new_size + ENDDO two_pass + ENDIF init_ice + ENDIF ice_test +! +!---------------------------------------------------------------------- +!--------------- Calculate individual processes ----------------------- +!---------------------------------------------------------------------- +! +!--- Cloud water autoconversion to rain (PRAUT) and collection of cloud +! water by precipitation ice (PIACW) +! + IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) THEN +! +!-- July 2010 version follows Liu & Daum (JAS, 2004) and Liu et al. (JAS, 2006) +! + DUM=BRAUT*RHO*RHO*QW*QW*QW + DUM1=ARAUT*RHO*RHO*QW*QW + PRAUT=MIN(QW, DUM*(1.-EXP(-DUM1*DUM1)) ) + IF (QLICE .GT. EPSQ) THEN + ! + !--- Collection of cloud water by large ice particles ("snow") + ! PIACWI=PIACW for riming, PIACWI=0 for shedding + ! + FWS=MIN(1., CIACW*VEL_INC*NLICE*ACCRI(INDEXS)/PP**C1) + PIACW=FWS*QW + IF (TC .LT. 0.) PIACWI=PIACW ! Large ice riming + ENDIF ! End IF (QLICE .GT. EPSQ) + ENDIF ! End IF (QW.GT.EPSQ .AND. TC.GE.T_ICE) +! +!---------------------------------------------------------------------- +!--- Loop around some of the ice-phase processes if no ice should be present +!---------------------------------------------------------------------- +! + IF (ICE_logical .EQV. .FALSE.) GO TO 20 +! +!--- Now the pretzel logic of calculating ice deposition +! + IF (TC.LT.T_ICE .AND. (WV.GT.QSWgrd .OR. QW.GT.EPSQ)) THEN + ! + !--- Adjust to ice saturation at T More extensive units conversion than can be described here to go from +! eq. (13) in Liu et al. (JAS, 2006) to what's programmed below. Note that +! the units used throughout the paper are in cgs units! +! + ARAUT=1.03e19/(NCW*SQRT(NCW)) + BRAUT=DTPH*1.1E10*BETA6/NCW +! +!--- For calculating snow optical depths by considering bulk density of +! snow based on emails from Q. Fu (6/27-28/01), where optical +! depth (T) = 1.5*SWP/(Reff*DENS), SWP is snow water path, Reff +! is effective radius, and DENS is the bulk density of snow. +! +! SWP (kg/m**2)=(1.E-3 kg/g)*SWPrad, SWPrad in g/m**2 used in radiation +! T = 1.5*1.E3*SWPrad/(Reff*DENS) +! +! See derivation for MASSI(INDEXS), note equal to RHO*QSNOW/NSNOW +! +! SDENS=1.5e3/DENS, DENS=MASSI(INDEXS)/[PI_E*(1.E-6*INDEXS)**3] +! + DO I=MDImin,MDImax + SDENS(I)=PI_E*1.5E-15*FLOAT(I*I*I)/MASSI(I) + ENDDO +! + Thour_print=-DTPH/3600. + + + ENDIF ! Allowed_to_read + + RETURN +! +!----------------------------------------------------------------------- +! +9061 CONTINUE + WRITE( errmess , '(A,I4)' ) & + 'module_mp_hwrf: error opening ETAMPNEW_DATA on unit ' & + &, etampnew_unit1 + CALL wrf_error_fatal(errmess) +! +!----------------------------------------------------------------------- + END SUBROUTINE fer_hires_init +! + SUBROUTINE MY_GROWTH_RATES (DTPH) +! +!--- Below are tabulated values for the predicted mass of ice crystals +! after 600 s of growth in water saturated conditions, based on +! calculations from Miller and Young (JAS, 1979). These values are +! crudely estimated from tabulated curves at 600 s from Fig. 6.9 of +! Young (1993). Values at temperatures colder than -27C were +! assumed to be invariant with temperature. +! +!--- Used to normalize Miller & Young (1979) calculations of ice growth +! over large time steps using their tabulated values at 600 s. +! Assumes 3D growth with time**1.5 following eq. (6.3) in Young (1993). +! + IMPLICIT NONE +! + REAL,INTENT(IN) :: DTPH +! + REAL DT_ICE + REAL,DIMENSION(35) :: MY_600 +!WRF +! +!----------------------------------------------------------------------- + DATA MY_600 / & + & 5.5e-8, 1.4E-7, 2.8E-7, 6.E-7, 3.3E-6, & + & 2.E-6, 9.E-7, 8.8E-7, 8.2E-7, 9.4e-7, & + & 1.2E-6, 1.85E-6, 5.5E-6, 1.5E-5, 1.7E-5, & + & 1.5E-5, 1.E-5, 3.4E-6, 1.85E-6, 1.35E-6, & + & 1.05E-6, 1.E-6, 9.5E-7, 9.0E-7, 9.5E-7, & + & 9.5E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7, & + & 9.E-7, 9.E-7, 9.E-7, 9.E-7, 9.E-7 / ! -31 to -35 deg C +! +!----------------------------------------------------------------------- +! + DT_ICE=(DTPH/600.)**1.5 + MY_GROWTH=DT_ICE*MY_600*1.E-3 !-- 20090714: Convert from g to kg +! +!----------------------------------------------------------------------- +! + END SUBROUTINE MY_GROWTH_RATES +! +!----------------------------------------------------------------------- +!--------- Old GFS saturation vapor pressure lookup tables ----------- +!----------------------------------------------------------------------- +! + SUBROUTINE GPVS +! ****************************************************************** +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . +! SUBPROGRAM: GPVS COMPUTE SATURATION VAPOR PRESSURE TABLE +! AUTHOR: N PHILLIPS W/NP2 DATE: 30 DEC 82 +! +! ABSTRACT: COMPUTE SATURATION VAPOR PRESSURE TABLE AS A FUNCTION OF +! TEMPERATURE FOR THE TABLE LOOKUP FUNCTION FPVS. +! EXACT SATURATION VAPOR PRESSURES ARE CALCULATED IN SUBPROGRAM FPVSX. +! THE CURRENT IMPLEMENTATION COMPUTES A TABLE WITH A LENGTH +! OF 7501 FOR TEMPERATURES RANGING FROM 180.0 TO 330.0 KELVIN. +! +! PROGRAM HISTORY LOG: +! 91-05-07 IREDELL +! 94-12-30 IREDELL EXPAND TABLE +! 96-02-19 HONG ICE EFFECT +! 01-11-29 JIN MODIFIED FOR WRF +! +! USAGE: CALL GPVS +! +! SUBPROGRAMS CALLED: +! (FPVSX) - INLINABLE FUNCTION TO COMPUTE SATURATION VAPOR PRESSURE +! +! COMMON BLOCKS: +! COMPVS - SCALING PARAMETERS AND TABLE FOR FUNCTION FPVS. +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! +!$$$ + IMPLICIT NONE + real :: X,XINC,T + integer :: JX +!---------------------------------------------------------------------- + XINC=(XMAX-XMIN)/(NX-1) + C1XPVS=1.-XMIN/XINC + C2XPVS=1./XINC + C1XPVS0=1.-XMIN/XINC + C2XPVS0=1./XINC +! + DO JX=1,NX + X=XMIN+(JX-1)*XINC + T=X + TBPVS(JX)=FPVSX(T) + TBPVS0(JX)=FPVSX0(T) + ENDDO +! + END SUBROUTINE GPVS +!----------------------------------------------------------------------- +!*********************************************************************** +!----------------------------------------------------------------------- + REAL FUNCTION FPVS(T) +!----------------------------------------------------------------------- +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . +! SUBPROGRAM: FPVS COMPUTE SATURATION VAPOR PRESSURE +! AUTHOR: N PHILLIPS W/NP2 DATE: 30 DEC 82 +! +! ABSTRACT: COMPUTE SATURATION VAPOR PRESSURE FROM THE TEMPERATURE. +! A LINEAR INTERPOLATION IS DONE BETWEEN VALUES IN A LOOKUP TABLE +! COMPUTED IN GPVS. SEE DOCUMENTATION FOR FPVSX FOR DETAILS. +! INPUT VALUES OUTSIDE TABLE RANGE ARE RESET TO TABLE EXTREMA. +! THE INTERPOLATION ACCURACY IS ALMOST 6 DECIMAL PLACES. +! ON THE CRAY, FPVS IS ABOUT 4 TIMES FASTER THAN EXACT CALCULATION. +! THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. +! +! PROGRAM HISTORY LOG: +! 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION +! 94-12-30 IREDELL EXPAND TABLE +! 96-02-19 HONG ICE EFFECT +! 01-11-29 JIN MODIFIED FOR WRF +! +! USAGE: PVS=FPVS(T) +! +! INPUT ARGUMENT LIST: +! T - REAL TEMPERATURE IN KELVIN +! +! OUTPUT ARGUMENT LIST: +! FPVS - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB) +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +!$$$ + IMPLICIT NONE + real,INTENT(IN) :: T + real XJ + integer :: JX +!----------------------------------------------------------------------- + XJ=MIN(MAX(C1XPVS+C2XPVS*T,1.),FLOAT(NX)) + JX=MIN(XJ,NX-1.) + FPVS=TBPVS(JX)+(XJ-JX)*(TBPVS(JX+1)-TBPVS(JX)) +! + END FUNCTION FPVS +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + REAL FUNCTION FPVS0(T) +!----------------------------------------------------------------------- + IMPLICIT NONE + real,INTENT(IN) :: T + real :: XJ1 + integer :: JX1 +!----------------------------------------------------------------------- + XJ1=MIN(MAX(C1XPVS0+C2XPVS0*T,1.),FLOAT(NX)) + JX1=MIN(XJ1,NX-1.) + FPVS0=TBPVS0(JX1)+(XJ1-JX1)*(TBPVS0(JX1+1)-TBPVS0(JX1)) +! + END FUNCTION FPVS0 +!----------------------------------------------------------------------- +!*********************************************************************** +!----------------------------------------------------------------------- + REAL FUNCTION FPVSX(T) +!----------------------------------------------------------------------- +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . +! SUBPROGRAM: FPVSX COMPUTE SATURATION VAPOR PRESSURE +! AUTHOR: N PHILLIPS W/NP2 DATE: 30 DEC 82 +! +! ABSTRACT: EXACTLY COMPUTE SATURATION VAPOR PRESSURE FROM TEMPERATURE. +! THE WATER MODEL ASSUMES A PERFECT GAS, CONSTANT SPECIFIC HEATS +! FOR GAS AND LIQUID, AND NEGLECTS THE VOLUME OF THE LIQUID. +! THE MODEL DOES ACCOUNT FOR THE VARIATION OF THE LATENT HEAT +! OF CONDENSATION WITH TEMPERATURE. THE ICE OPTION IS NOT INCLUDED. +! THE CLAUSIUS-CLAPEYRON EQUATION IS INTEGRATED FROM THE TRIPLE POINT +! TO GET THE FORMULA +! PVS=PSATK*(TR**XA)*EXP(XB*(1.-TR)) +! WHERE TR IS TTP/T AND OTHER VALUES ARE PHYSICAL CONSTANTS +! THIS FUNCTION SHOULD BE EXPANDED INLINE IN THE CALLING ROUTINE. +! +! PROGRAM HISTORY LOG: +! 91-05-07 IREDELL MADE INTO INLINABLE FUNCTION +! 94-12-30 IREDELL EXACT COMPUTATION +! 96-02-19 HONG ICE EFFECT +! 01-11-29 JIN MODIFIED FOR WRF +! +! USAGE: PVS=FPVSX(T) +! REFERENCE: EMANUEL(1994),116-117 +! +! INPUT ARGUMENT LIST: +! T - REAL TEMPERATURE IN KELVIN +! +! OUTPUT ARGUMENT LIST: +! FPVSX - REAL SATURATION VAPOR PRESSURE IN KILOPASCALS (CB) +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +!$$$ + IMPLICIT NONE +!----------------------------------------------------------------------- + real, parameter :: TTP=2.7316E+2,HVAP=2.5000E+6,PSAT=6.1078E+2 & + , CLIQ=4.1855E+3,CVAP= 1.8460E+3 & + , CICE=2.1060E+3,HSUB=2.8340E+6 +! + real, parameter :: PSATK=PSAT*1.E-3 + real, parameter :: DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP) + real, parameter :: DLDTI=CVAP-CICE & + , XAI=-DLDTI/RV,XBI=XAI+HSUB/(RV*TTP) + real T,TR +!----------------------------------------------------------------------- + TR=TTP/T +! + IF(T.GE.TTP)THEN + FPVSX=PSATK*(TR**XA)*EXP(XB*(1.-TR)) + ELSE + FPVSX=PSATK*(TR**XAI)*EXP(XBI*(1.-TR)) + ENDIF +! + END FUNCTION FPVSX +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- + REAL FUNCTION FPVSX0(T) +!----------------------------------------------------------------------- + IMPLICIT NONE + real,parameter :: TTP=2.7316E+2,HVAP=2.5000E+6,PSAT=6.1078E+2 & + , CLIQ=4.1855E+3,CVAP=1.8460E+3 & + , CICE=2.1060E+3,HSUB=2.8340E+6 + real,PARAMETER :: PSATK=PSAT*1.E-3 + real,PARAMETER :: DLDT=CVAP-CLIQ,XA=-DLDT/RV,XB=XA+HVAP/(RV*TTP) + real,PARAMETER :: DLDTI=CVAP-CICE & + , XAI=-DLDT/RV,XBI=XA+HSUB/(RV*TTP) + real :: T,TR +!----------------------------------------------------------------------- + TR=TTP/T + FPVSX0=PSATK*(TR**XA)*EXP(XB*(1.-TR)) +! + END FUNCTION FPVSX0 +! + END MODULE module_mp_fer_hires diff --git a/wrfv2_fire/phys/module_mp_full_sbm.F b/wrfv2_fire/phys/module_mp_full_sbm.F index 344f9c0a..b31dc849 100644 --- a/wrfv2_fire/phys/module_mp_full_sbm.F +++ b/wrfv2_fire/phys/module_mp_full_sbm.F @@ -580,10 +580,10 @@ SUBROUTINE SBM (w,u,v,th_old, & KRR=0 DO KR=p_ff8i01,p_ff8i33 KRR=KRR+1 - if (xland(i,j).eq.1)then - chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ + if (xland(i,j).lt.1.5)then + chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ else - chem_new(I,K,J,KR)=FCCNR_MIX(KRR)*FACTZ + chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ end if ! if (xlat(i,j).ge.10.and.xlat(i,j).le.30.and.zcgs(i,k,j).le.300000)then ! if (zcgs(i,k,j).le.25000)then @@ -612,10 +612,10 @@ SUBROUTINE SBM (w,u,v,th_old, & KRR=0 DO kr=p_ff8i01,p_ff8i33 KRR=KRR+1 - if (xland(i,j).eq.1)then - chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ + if (xland(i,j).lt.1.5)then + chem_new(I,K,J,KR)=FCCNR_CON(KRR)*FACTZ else - chem_new(I,K,J,KR)=FCCNR_MIX(KRR)*FACTZ + chem_new(I,K,J,KR)=FCCNR_MAR(KRR)*FACTZ end if ! if (xlat(i,j).ge.10.and.xlat(i,j).le.30.and.zcgs(i,k,j).le.300000)then ! if (zcgs(i,k,j).le.25000)then diff --git a/wrfv2_fire/phys/module_mp_nssl_2mom.F b/wrfv2_fire/phys/module_mp_nssl_2mom.F index 0c8688bb..e9d25034 100644 --- a/wrfv2_fire/phys/module_mp_nssl_2mom.F +++ b/wrfv2_fire/phys/module_mp_nssl_2mom.F @@ -4,6 +4,8 @@ + + !--------------------------------------------------------------------- ! IMPORTANT: Best results are attained using the new 5th-order WENO advection option (4) for scalars: ! moist_adv_opt = 4, @@ -54,6 +56,28 @@ ! ! Note: Some parameters below apply to unreleased features. ! +! WRF 3.8 updates: +! Fixed issue with reflectivity conservation for graupel melting into rain. Rain number concentrations were too low, +! resulting in excessive reflectivity of a couple dBZ +! Changed default value of iusewetgraupel to 1 (turns off diagnostic meltwater on graupel for reflectivity) +! Apply a 70 m/s fall speed limit for sedimentation +! Changed vapor ice nucleation to Meyers-Ferrier method (original scheme) +! New method for Bigg freezing (ibiggopt=2) +! Reduced snow aggregration efficiency and restricted aggregation to higher temperatures (assuming dendrites and mechanical aggregation) +! Increased maximum graupel-droplet collection efficiency when hail is turned off (nssl_2momg) +! Updates for compatibility with WRF-NMM +! Added calculation of hail number concentration in calcnfromq (creates number concentration from mixing ratio +! when starting from an analysis). And fixed error in graupel intercept +! Bug fix in snow fall speeds +! Further fix in snow reflectivity +! Use diameter of maximum mass rather than mean diamter when checking maximum size +! Helped performance in sedimentation with flag "do_accurate_sedimentation" to control recalculation of fall speeds when +! more than one sub-time step is needed (often happens with large time steps and small dz near the ground): +! = .true. : recalculates fall speed after each substep (more accurate) +! = .false. : (default) reuses fall speeds calculated on the first substep (typical for most schemes), theoretically could cause an occasional glitch, but none seen in practice +! Increased maximum mean droplet radius from 40 to 60 microns, which alleviates spurious number concentration increases at low CCN concentration. +! Removed a duplicate factor from hail reflectivity that was causing a loss of about 6 dBZ (since WRF 3.5). +! !--------------------------------------------------------------------- @@ -65,7 +89,7 @@ MODULE module_mp_nssl_2mom public nssl_2mom_driver public nssl_2mom_init private gamma,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis - private gamma_dp + private gamma_dp, gamxinfdp private delbk, delabk private gammadp @@ -94,7 +118,8 @@ MODULE module_mp_nssl_2mom ! Params for dbz: integer :: iuseferrier = 1 ! =1: use dry graupel only from Ferrier 1994; = 0: Use Smith (wet graupel) integer :: idbzci = 0 - integer :: iusewetgraupel = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + ! new version integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) + integer :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) ! =2 turn on for graupel density less than 300. only integer :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase) integer :: iusewetsnow = 1 ! =1 to turn on diagnosed bright band @@ -131,6 +156,9 @@ MODULE module_mp_nssl_2mom integer, private :: itfall = 0 integer, private :: iscfall = 1 integer, private :: irfall = -1 + logical, private :: do_accurate_sedimentation = .false. ! if true, recalculate fall speeds on sub time steps; (more expensive) + ! if false, reuse fall speeds on multiple steps (can have a noticeable speedup) + ! Mainly is an issue for small dz near the surface. integer, private :: infall = 4 ! 0 -> uses number-wgt for N; NO correction applied (results in excessive size sorting) ! 1 -> uses mass-weighted fallspeed for N ALWAYS ! 2 -> uses number-wgt for N and mass-weighted correction for N (Method II in Mansell, 2010 JAS) @@ -144,6 +172,7 @@ MODULE module_mp_nssl_2mom real , private :: cdhdnmin = 500., cdhdnmax = 800.0 ! defaults for graupel (icdx=4) real , private :: cdhlmin = 0.45, cdhlmax = 0.6 ! defaults for hail (icdx=4) real , private :: cdhldnmin = 500., cdhldnmax = 800.0 ! defaults for hail (icdx=4) + real , private :: vtmaxsed = 70. ! Limit on fall speed (m/s, all moments) for sedimentation calculations. Not applied to fall speeds for microphysical rates integer :: rssflg = 1 ! Rain size-sorting allowed (1, default), or disallowed (0). If 0, sets N and Z-weighted fall speeds to q-weighted value integer :: sssflg = 1 ! As above but for snow @@ -164,6 +193,7 @@ MODULE module_mp_nssl_2mom real , private :: ifrzg = 1.0 ! fraction of frozen drops going to graupel. 1=freeze all rain to graupel, 0=freeze all to hail real , private :: ifrzs = 1.0 ! fraction of small frozen drops going to snow. 1=freeze rain to snow, 0=freeze to cloud ice + real , private :: ffrzs = 0.0 ! fraction of other initiated cloud ice going to snow. 1=freeze rain to snow, 0=freeze to cloud ice integer, private :: irwfrz = 1 ! compute total rain that can freeze (checks heat budget) integer, private :: irimtim = 0 ! future use ! integer, private :: infdo = 1 ! 1 = calculate number-weighted fall speeds @@ -187,7 +217,7 @@ MODULE module_mp_nssl_2mom ! = 1 : cnuc = actual available CCN ! otherwise cnuc = cwccn*(1. - renufrac) + ccnc(1:ngscnt)*renucfrac real , private :: cck = 0.6 ! exponent in Twomey expression - real , private :: ciintmx = 1.0e6 + real , private :: ciintmx = 1.0e6 ! limit on ice concentration from primary nucleation real , private :: cwccn ! , cwmasn,cwmasx real , private :: ccwmx @@ -199,7 +229,7 @@ MODULE module_mp_nssl_2mom ! 0,2, 5.00e-10, 1, 0, 0, 0 : itype1,itype2,cimas0,icfn,ihrn,ibfc,iacr integer, private :: itype1 = 0, itype2 = 2 ! controls Hallett-Mossop process - integer, private :: icenucopt = 3 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott) + integer, private :: icenucopt = 1 ! =1 Meyers/Ferrier primary ice nucleation; =2 Thompson/Cooper, =3 Phillips (Meyers/Demott) integer, private :: icfn = 2 ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version integer, private :: ihrn = 0 ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only) integer, private :: ibfc = 1 ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on) @@ -207,7 +237,7 @@ MODULE module_mp_nssl_2mom ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron) integer, private :: ibfr = 2 ! Flag for Bigg freezing conversion of freezing drops to graupel ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation) - integer, private :: ibiggopt = 1 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) + integer, private :: ibiggopt = 2 ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however) integer, private :: iacrsize = 5 ! assumed min size of drops freezing by capture ! 1: > 500 micron diam ! 2: > 300 micron @@ -253,16 +283,19 @@ MODULE module_mp_nssl_2mom real , private :: eii0hl = 0.2 ,eii1hl = 0.0 ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) ! set eii1hl = 0 to get a constant value of eii0hl real , private :: eri0 = 0.1 ! rain efficiency to collect ice crystals - real , private :: ehs0 = 0.1 ,ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) + real , private :: esi0 = 0.1 ! linear factor in snow-ice collection efficiency + real , private :: ehs0 = 0.1, ehs1 = 0.1 ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! set ehs1 = 0 to get a constant value of ehs0 - real , private :: ess0 = 1.0 ,ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) + real , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0)) ! set ess1 = 0 to get a constant value of ess0 + real , private :: esstem1 = -10. ! lower temperature where snow aggregation turns on + real , private :: esstem2 = -07. ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2 real , private :: ehsfrac = 1.0 ! multiplier for graupel collection efficiency in wet growth real , private :: ehimin = 0.0 ! Minimum collection efficiency (graupel - ice crystal) real , private :: ehimax = 1.0 ! Maximum collection efficiency (graupel - ice crystal) real , private :: ehsmax = 0.5 ! Maximum collection efficiency (graupel - snow) real , private :: ecollmx = 0.5 ! Maximum collision efficiency for graup/hail with ice; used only for charging rates - integer, private :: iglcnvi = 1 ! flag for riming conversion from cloud ice to rimed ice/graupel + integer, private :: iglcnvi = 2 ! flag for riming conversion from cloud ice to rimed ice/graupel integer, private :: iglcnvs = 2 ! flag for conversion from snow to rimed ice/graupel real , private :: rz ! reflectivity conservation factor for graupel/rain @@ -271,6 +304,8 @@ MODULE module_mp_nssl_2mom real , private :: rzhl ! reflectivity conservation factor for hail/rain ! now calculated in icezvd_dr.F from alphahl and rnu + real , private :: rzs ! reflectivity conservation factor for snow(imusnow=3) with rain (imurain=1) + real , private :: alphahacx = 0.0 ! assumed minimum shape parameter for zhacw and zhacr real , private :: fconv = 1.0 ! factor to boost max graupel depletion by riming conversions in 10ICE @@ -288,13 +323,14 @@ MODULE module_mp_nssl_2mom real , private :: dshd = 1.0e-3 ! nominal diameter for drops shed from graupel/hail integer, private :: ihmlt = 2 ! 1=old melting with vmlt; 2=new melting using mean volume diam of graupel/hail - integer, private :: imltshddmr = 0 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail + integer, private :: imltshddmr = 1 ! 0 (default)=mean diameter of drops produced during melting+shedding as before (using mean diameter of graupel/hail ! and max mean diameter of rain) ! 1=new method where mean diameter of rain during melting is adjusted linearly downward ! toward 3 mm for large (> sheddiam) graupel and hail, to take into account shedding of ! smaller drops. sheddiam0 controls the size of graupel/hail above which the assumed ! mean diameter of rain is set to 3 mm ! Only valid for ihmlt = 2 for ZVD(H) but also applies to ZVD(H)M + ! 2 = method that sets the resulting rain size ( vshdgs ) according to the mass-weighted diameter of the ice integer, private :: nsplinter = 0 ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle @@ -334,7 +370,10 @@ MODULE module_mp_nssl_2mom integer, private :: imurain = 1 ! 3 for gamma-volume, 1 for gamma-diameter DSD for rain. integer, private :: imusnow = 3 ! 3 for gamma-volume, 1 for gamma-diameter DSD for snow (=1 NOT IMPLEMENTED!!). - integer :: iturbenhance = 0 ! enhancement of rain self-collection by turbulence + integer, private :: iturbenhance = 0 ! warm-rain collision enhancement + ! 1 = enhance autoconversion only + ! 2 = add rain collection of cloud + ! 3 = add rain self-collection integer, private :: isedonly = 0 ! 1= only do sedimentation and skip other microphysics integer, private :: iferwisventr = 2 ! =1 for Ferrier rwvent, =2 for Wisner rwvent (imurain=1) integer, private :: izwisventr = 2 ! =1 for old Ziegler rwvent, =2 for Wisner-style rwvent (imurain=3) @@ -367,8 +406,12 @@ MODULE module_mp_nssl_2mom ! 3 = switch conversion over to snow for small frozen drops from both integer, private :: ixtaltype = 1 ! =1 column, =2 disk (similar to Takahashi) + + real, private :: takshedsize1 = 0.15 ! diameter (cm) of drop shed from ice with D > 1.9 cm + real, private :: takshedsize2 = 0.3 ! diameter (cm) of drop shed from ice with D < 1.9 cm and D > 0.8 cm real, private :: evapfac = 1.0 ! Multiplier on rain evaporation rate + real, private :: depfac = 1.0 ! Multiplier on graupel/hail deposition/sublimation rate integer, private :: ibinhmlr = 0 ! =1 use incomplete gammas to determine melting from larger and smaller sizes of graupel, and appropriate shed drop sizes ! =2 to test melting by temporary bins @@ -376,16 +419,17 @@ MODULE module_mp_nssl_2mom ! =2 to test melting by temporary bins - + integer, parameter :: icespheres = 0 ! turn ice spheres (frozen droplets) on (1) or off (0). NOT COMPLETE IN WRF/ARPS/CM1 CODE! integer, parameter :: lqmx = 30 integer, parameter :: lt = 1 integer, parameter :: lv = 2 integer, parameter :: lc = 3 integer, parameter :: lr = 4 integer, parameter :: li = 5 - integer, parameter :: ls = 6 - integer, parameter :: lh = 7 - integer :: lhl = 0 + integer, private :: lis = 0 + integer, private :: ls = 6 + integer, private :: lh = 7 + integer, private :: lhl = 0 integer, private :: lccn = 9 ! 0 or 9, other indices adjusted accordingly integer, private :: lccna = 0 @@ -394,6 +438,7 @@ MODULE module_mp_nssl_2mom integer, private :: lnc = 9 integer, private :: lnr = 10 integer, private :: lni = 11 + integer, private :: lnis = 0 integer, private :: lns = 12 integer, private :: lnh = 13 integer, private :: lnhl = 0 @@ -436,6 +481,7 @@ MODULE module_mp_nssl_2mom integer :: lscw = 0 integer :: lscr = 0 integer :: lsci = 0 + integer :: lscis = 0 integer :: lscs = 0 integer :: lsch = 0 integer :: lschl = 0 @@ -495,6 +541,11 @@ MODULE module_mp_nssl_2mom integer :: ipelec = 0 integer :: isaund = 0 logical :: idonic = .false. + integer :: jchgs = 3 ! number of points near boundary where charging is turned off (to keep lightning from getting wonky) + integer :: jchgn = 2 + integer :: ichge = 3 + integer :: ichgw = 2 + real :: charging_border = 4000. ! width of no-charging zone from boundary real, private :: delqnw = -1.0e-10!-1.0e-12 ! real, private :: delqxw = 1.0e-10! 1.0e-12 ! real :: tindmn = 233, tindmx = 298.0 ! min and max temperatures where inductive charging is allowed @@ -507,13 +558,16 @@ MODULE module_mp_nssl_2mom double precision, parameter :: dgam = 0.01, dgami = 100. double precision gmoi(0:ngm0) ! ,gmod(0:ngm1,0:ngm2),gmdi(0:ngm1,0:ngm2) - integer, parameter :: nqiacralpha = 120 ! 15 - integer, parameter :: nqiacrratio = 50 ! 25 - real, parameter :: dqiacralpha = 15./Float(nqiacralpha), dqiacrratio = 25./Float(nqiacrratio) + integer, parameter :: nqiacralpha = 240 !480 ! 240 ! 120 ! 15 + integer, parameter :: nqiacrratio = 100 ! 500 !50 ! 25 + real, parameter :: maxratiolu = 25. + real, parameter :: maxalphalu = 15. + real, parameter :: dqiacralpha = maxalphalu/Float(nqiacralpha), dqiacrratio = maxratiolu/Float(nqiacrratio) real, parameter :: dqiacrratioinv = 1./dqiacrratio, dqiacralphainv = 1./dqiacralpha real :: ciacrratio(0:nqiacrratio,0:nqiacralpha) real :: qiacrratio(0:nqiacrratio,0:nqiacralpha) - double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,8,2) ! last index for graupel (1) or hail (2) + real :: ziacrratio(0:nqiacrratio,0:nqiacralpha) + double precision :: gamxinflu(0:nqiacrratio,0:nqiacralpha,10,2) ! last index for graupel (1) or hail (2) integer, parameter :: ngdnmm = 9 real :: mmgraupvt(ngdnmm,3) ! Milbrandt and Morrison (2013) fall speed coefficients for graupel/hail @@ -527,7 +581,7 @@ MODULE module_mp_nssl_2mom integer ipc(lc:lqmx) integer lvol(lc:lqmx) integer lz(lc:lqmx) - integer lliq(ls:lqmx) + integer lliq(li:lqmx) integer denscale(lc:lqmx) ! flag for density scaling (mixing ratio conversion) integer ido(lc:lqmx) @@ -587,7 +641,7 @@ MODULE module_mp_nssl_2mom real, private :: dhmn = dhmn0, dhmx = -1. real, parameter :: cwradn = 2.5e-6, xcradmn = cwradn ! minimum radius - real, parameter :: cwradx = 40.e-6, xcradmx = cwradx ! maximum radius + real, parameter :: cwradx = 60.e-6, xcradmx = cwradx ! maximum radius real, parameter :: cwc1 = 6.0/(pi*1000.) ! parameter( xvcmn=4.188e-18 ) ! mks min volume = 3 micron radius @@ -619,6 +673,8 @@ MODULE module_mp_nssl_2mom parameter (ec = 1.602e-19) parameter (eci = 1.0/ec) + real :: scwppmx = 20.0e-12 + real :: scippmx = 20.0e-12 ! ! constants ! @@ -657,7 +713,7 @@ MODULE module_mp_nssl_2mom real :: cckm,ccne,ccnefac,cnexp,CCNE0 integer :: na = 9 - + integer :: nxtra = 1 real gf4p5, gf4ds, gf4br real gsnow1, gsnow53, gsnow73 real gfcinu1, gfcinu1p47, gfcinu2p47 @@ -702,12 +758,12 @@ SUBROUTINE nssl_2mom_init( & implicit none integer, intent(in) :: ims,ime, jms,jme, kms,kme - real, intent(in), dimension(20) :: nssl_params + real, intent(in), dimension(20) :: nssl_params + integer, intent(in) :: ipctmp,mixphase,ihvol logical, optional, intent(in) :: idonictmp - double precision :: arg real :: temq integer :: igam @@ -716,13 +772,14 @@ SUBROUTINE nssl_2mom_init( & integer :: isub real :: bxh,bxhl - real :: alp,ratio,x,y + real :: alp,ratio,x,y,y7 ! ! set some global values from namelist input ! + ccn = nssl_params(1) alphah = nssl_params(2) alphahl = nssl_params(3) @@ -739,9 +796,19 @@ SUBROUTINE nssl_2mom_init( & lhab = 8 lhl = 8 + IF ( icespheres >= 1 ) THEN + lhab = lhab + 1 + lis = li + 1 + ls = ls + 1 + lh = lh + 1 + lhl = lhl + 1 + ENDIF IF ( ihvol == -1 ) THEN - lhab = 7 ! turns off hail -- option for single moment, only!! + lhab = lhab - 1 ! turns off hail -- option for single moment, only!! lhl = 0 + ehw0 = 0.75 + iehw = 2 + dfrz = Max( dfrz, 0.5e-3 ) ENDIF ! IF ( ipelec > 0 ) idonic = .true. @@ -764,22 +831,28 @@ SUBROUTINE nssl_2mom_init( & ax(lr) = 1647.81 fx(lr) = 135.477 - IF ( icdx > 0 ) THEN + IF ( icdx == 6 ) THEN + bx(lh) = 0.6 ! Milbrandt and Morrison (2013) for density of 550. + ax(lh) = 157.71 + ELSEIF ( icdx > 0 ) THEN bx(lh) = 0.5 ax(lh) = 75.7149 ELSE - bx(lh) = 0.37 ! 0.6 + bx(lh) = 0.37 ! 0.6 ! Ferrier 1994 ax(lh) = 19.3 ENDIF ! bx(lh) = 0.6 IF ( lhl .gt. 1 ) THEN - IF (icdxhl > 0 ) THEN - bx(lhl) = 0.5 - ax(lhl) = 75.7149 + IF ( icdx == 6 ) THEN + bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750. + ax(lhl) = 179.36 + ELSEIF (icdxhl > 0 ) THEN + bx(lhl) = 0.5 + ax(lhl) = 75.7149 ELSE - ax(lhl) = 206.984 - bx(lhl) = 0.6384 + ax(lhl) = 206.984 ! Ferrier 1994 + bx(lhl) = 0.6384 ENDIF ENDIF @@ -793,6 +866,7 @@ SUBROUTINE nssl_2mom_init( & ! build lookup table to compute the number and mass fractions of rain drops ! (imurain=1) greater than a given diameter. Used for qiacr and ciacr ! Uses incomplete gamma functions + ! The terms with bxh or bxhl will be off if the actual bxh or bxhl is different from the base value (icdx=6 option) bxh = bx(lh) bxhl = bx(Max(lh,lhl)) @@ -806,26 +880,38 @@ SUBROUTINE nssl_2mom_init( & ! write(0,*) 'i, x/y = ',i, x/y ciacrratio(i,j) = x/y + ! graupel (.,.,.,1) gamxinflu(i,j,1,1) = x/y gamxinflu(i,j,2,1) = gamxinf( 2.0+alp, ratio )/y gamxinflu(i,j,3,1) = gamxinf( 2.5+alp+0.5*bxh, ratio )/y - gamxinflu(i,j,5,1) = gamxinf( 5.0+alp, ratio )/y - gamxinflu(i,j,6,1) = gamxinf( 5.5+alp+0.5*bxh, ratio )/y - + gamxinflu(i,j,5,1) = (gamma(5.0+alp) - gamxinf( 5.0+alp, ratio ))/y + gamxinflu(i,j,6,1) = (gamma(5.5+alp+0.5*bxh) - gamxinf( 5.5+alp+0.5*bxh, ratio ))/y + gamxinflu(i,j,9,1) = gamxinf( 1.0+alp, ratio )/y + gamxinflu(i,j,10,1)= gamxinf( 4.0+alp, ratio )/y + + ! hail (.,.,.,2) gamxinflu(i,j,1,2) = gamxinflu(i,j,1,1) gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1) gamxinflu(i,j,3,2) = gamxinf( 2.5+alp+0.5*bxhl, ratio )/y gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1) - gamxinflu(i,j,6,2) = gamxinf( 5.5+alp+0.5*bxhl, ratio )/y + gamxinflu(i,j,6,2) = (gamma(5.5+alp+0.5*bxhl) - gamxinf( 5.5+alp+0.5*bxhl, ratio ))/y + gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1) + gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1) IF ( alp > 1.1 ) THEN - gamxinflu(i,j,7,1) = gamxinf( alp - 1., ratio )/y - gamxinflu(i,j,8,1) = gamxinf( alp - 0.5 + 0.5*bxh, ratio )/y - gamxinflu(i,j,8,2) = gamxinf( alp - 0.5 + 0.5*bxhl, ratio )/y +! gamxinflu(i,j,7,1) = gamxinf( alp - 1., ratio )/y + gamxinflu(i,j,7,1) = (gamma(alp - 1.) - gamxinf( alp - 1., ratio ))/y +! gamxinflu(i,j,8,1) = gamxinf( alp - 0.5 + 0.5*bxh, ratio )/y + gamxinflu(i,j,8,1) = (gamma(alp - 0.5 + 0.5*bxh) - gamxinf( alp - 0.5 + 0.5*bxh, ratio ))/y +! gamxinflu(i,j,8,2) = gamxinf( alp - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,2) = (gamma(alp - 0.5 + 0.5*bxhl) - gamxinf( alp - 0.5 + 0.5*bxhl, ratio ))/y ELSE - gamxinflu(i,j,7,1) = gamxinf( .1, ratio )/y - gamxinflu(i,j,8,1) = gamxinf( 1.1 - 0.5 + 0.5*bxh, ratio )/y - gamxinflu(i,j,8,2) = gamxinf( 1.1 - 0.5 + 0.5*bxhl, ratio )/y +! gamxinflu(i,j,7,1) = gamxinf( .1, ratio )/y + gamxinflu(i,j,7,1) = (gamma(0.1) - gamxinf( 0.1, ratio ) )/y +! gamxinflu(i,j,8,1) = gamxinf( 1.1 - 0.5 + 0.5*bxh, ratio )/y +! gamxinflu(i,j,8,2) = gamxinf( 1.1 - 0.5 + 0.5*bxhl, ratio )/y + gamxinflu(i,j,8,1) = (gamma(1.1 - 0.5 + 0.5*bxh) - gamxinf( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y + gamxinflu(i,j,8,2) = (gamma(1.1 - 0.5 + 0.5*bxhl) - gamxinf( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y ENDIF gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1) @@ -837,6 +923,7 @@ SUBROUTINE nssl_2mom_init( & DO j = 0,nqiacralpha alp = float(j)*dqiacralpha y = gamma(4.+alp) + y7 = gamma(7.+alp) DO i = 1,nqiacrratio ratio = float(i)*dqiacrratio x = gamxinf( 4.+alp, ratio ) @@ -845,6 +932,9 @@ SUBROUTINE nssl_2mom_init( & gamxinflu(i,j,4,1) = x/y gamxinflu(i,j,4,2) = x/y + x = gamxinf( 7.+alp, ratio ) + ziacrratio(i,j) = x/y7 + ENDDO ENDDO qiacrratio(0,:) = 1.0 @@ -857,6 +947,7 @@ SUBROUTINE nssl_2mom_init( & lnc = 0 lnr = 0 lni = 0 + lnis = 0 lns = 0 lnh = 0 lnhl = 0 @@ -909,6 +1000,8 @@ SUBROUTINE nssl_2mom_init( & ltmp = lhlw ENDIF ELSEIF ( ipconc >= 6 ) THEN + write(0,*) 'NSSL microphysics has not been compiled for 3-moment. Sorry.' + STOP lccn = 9 lnc = 10 lnr = 11 @@ -1024,6 +1117,11 @@ SUBROUTINE nssl_2mom_init( & xnu(li) = 0.0 xmu(li) = 1. + IF ( lis >= 1 ) THEN + xnu(lis) = 0.0 + xmu(lis) = 1. + ENDIF + dnu(lc) = 3.*xnu(lc) + 2. ! alphac dmu(lc) = 3.*xmu(lc) @@ -1042,14 +1140,42 @@ SUBROUTINE nssl_2mom_init( & xnu(lh) = (dnu(lh) - 2.)/3. xmu(lh) = dmuh/3. - rz = ((4 + alphah)*(5 + alphah)*(6 + alphah)*(1. + xnu(lr)))/ & + IF ( imurain == 3 ) THEN ! rain is gamma of volume + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ & & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr))) ! IF ( ipconc .lt. 5 ) alphahl = alphah + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + xnu(lr)))/ & + & ((1. + alphahl)*(2. + alphahl)*(3. + alphahl)*(2. + xnu(lr))) + + rzs = 1. ! assume rain and snow are both gamma volume + + ELSE ! rain is gamma of diameter + + rz = ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphah)*(2 + alphah)*(3 + alphah)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + rzhl = ((4. + alphahl)*(5. + alphahl)*(6. + alphahl)*(1. + alphar)*(2. + alphar)*(3. + alphar))/ & + & ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(4. + alphar)*(5. + alphar)*(6. + alphar)) + + + rzs = & + & ((1. + alphar)*(2. + alphar)*(3. + alphar)*(2. + xnu(ls)))/ & + & ((4. + alphar)*(5. + alphar)*(6. + alphar)*(1. + xnu(ls))) + + + ENDIF - rzhl = ((4 + alphahl)*(5 + alphahl)*(6 + alphahl)*(1. + xnu(lr)))/ & - & ((1 + alphahl)*(2 + alphahl)*(3 + alphahl)*(2. + xnu(lr))) + IF ( ipconc <= 5 ) THEN + imltshddmr = Min(1, imltshddmr) + ibinhmlr = 0 + ibinhlmlr = 0 + ENDIF + IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhmlr == 0 ) ) THEN + imltshddmr = Min(1, imltshddmr) + ENDIF ! write(0,*) 'rz,rzhl = ', rz,rzhl @@ -1317,15 +1443,30 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw zrw, zhw, zhl, & qsw, qhw, qhlw, & th, pii, p, w, dn, dz, dtp, itimestep, & - RAINNC,RAINNCV, SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & + RAINNC,RAINNCV, & + dx, dy, & + SNOWNC, SNOWNCV, GRPLNC, GRPLNCV, & SR,HAILNC, HAILNCV, & + tkediss, & re_cloud, re_ice, re_snow, & has_reqc, has_reqi, has_reqs, & - dx, dy, & + rainncw2, rainnci2, & dbz, vzf,compdbz, & rscghis_2d, & scr,scw,sci,scs,sch,schl,sctot,noninduc, & induc,elec,scion,sciona, & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2, & +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail, & ipelectmp, & diagflag, & nssl_progn, & ! wrf-chem @@ -1338,7 +1479,6 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw - implicit none integer :: mytask = 0 @@ -1363,15 +1503,35 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw scr,scw,sci,scs,sch,schl,sciona,sctot,induc,noninduc ! space charge real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: elec ! elecsave = Ez real, dimension(ims:ime, kms:kme, jms:jme,2),optional, intent(inout) :: scion - real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: & - pii,p,w,dz,dn + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: p,w,dz,dn + + real, dimension(ims:ime, kms:kme, jms:jme), intent(in):: pii + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: & + pcc2, pre2, depsubr, & + mnucf2, melr2, ctr2, & + rim1_2, rim2_2,rim3_2, & + nctr2, nnuccd2, nnucf2, & + effc2,effr2,effi2, & + effs2, effg2, & + fc2, fr2,fi2,fs2,fg2, & + fnc2, fnr2,fni2,fns2,fng2 +! qcond,qdep,qfrz,qrauto,qhcnvi,qhcollw,qscollw, & +! ncauto, niinit,nifrz, & +! re_liquid, re_graupel, re_hail, re_icesnow, & +! vtcloud, vtrain, vtsnow, vtgraupel, vthail + real, dimension(ims:ime, jms:jme), intent(inout):: & - RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) + RAINNC,RAINNCV ! accumulated precip (NC) and rate (NCV) + real, dimension(ims:ime, jms:jme), optional, intent(inout):: & + SNOWNC,SNOWNCV,GRPLNC,GRPLNCV,SR ! accumulated precip (NC) and rate (NCV) real, dimension(ims:ime, jms:jme), optional, intent(inout):: & HAILNC,HAILNCV ! accumulated precip (NC) and rate (NCV) REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(INOUT):: & re_cloud, re_ice, re_snow + REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: tkediss INTEGER, INTENT(IN), optional :: has_reqc, has_reqi, has_reqs + real, dimension(ims:ime, jms:jme), intent(out), optional :: & + rainncw2, rainnci2 ! liquid rain, ice, accumulation rates real, optional, intent(in) :: dx,dy real, intent(in):: dtp integer, intent(in):: itimestep !, ccntype @@ -1393,8 +1553,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab ! real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+ - real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d + real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d real, dimension(its:ite, 1, kts:kte, na) :: an + real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d real, dimension(its:ite, 1, na) :: xfall @@ -1416,7 +1577,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw real, parameter :: cnin2a = 12.96 real, parameter :: cnin2b = 0.639 +#if (NMM_CORE == 1) +! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true + logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state +#else logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state +#endif real :: tmp,dv @@ -1424,6 +1590,15 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed double precision :: timevtcalc,timesetvt +#ifdef MPI + +#if defined(MPI) + integer, parameter :: ntot = 50 + double precision mpitotindp(ntot), mpitotoutdp(ntot) + INTEGER :: mpi_error_code = 1 +#endif +#endif + ! ------------------------------------------------------------------- @@ -1466,7 +1641,9 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ! set up CCN array and some other static local values IF ( itimestep == 1 .and. .not. invertccn .and. present( cn ) ) THEN -! IF ( cn((ite+its)/2,(kte+kts)/2,(jte+jts)/2) == 0.0 ) THEN ! initialize ccn if not already done + ! this is not needed for WRF 3.8 and later because it is done in physics_init, + ! but kept for backwards compatibility with earlier versions + IF ( cn((ite+its)/2,(kte+kts)/2,(jte+jts)/2) < 10.0 ) THEN ! initialize ccn if not already done DO jy = jts,jte DO kz = kts,kte DO ix = its,ite @@ -1474,7 +1651,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDDO ENDDO ENDDO -! ENDIF + ENDIF ENDIF IF ( invertccn .and. present( cn ) ) THEN ! hack for WRF to convert activated ccn to unactivated, then don't have to @@ -1509,6 +1686,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw HAILNCV(its:ite,jts:jte) = 0. ENDIF + tke2d(:,:) = 0.0 ! initialize if not used + lnb = Max(lh,lhl)+1 ! lnc ! IF ( lccn > 1 ) lnb = lccn @@ -1540,7 +1719,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw xfall(:,:,:) = 0.0 ! write(0,*) 'N2M: load an, jy,lccn = ',jy,lccn,qccn - + + IF ( present( pcc2 ) .and. makediag ) THEN + axtra(its:ite,1,kts:kte,:) = 0.0 + ENDIF ! copy from 3D array to 2D slab DO kz = kts,kte @@ -1578,6 +1760,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw + t0(ix,1,kz) = th(ix,kz,jy)*pii(ix,kz,jy) ! temperature (Kelvin) t1(ix,1,kz) = 0.0 @@ -1668,13 +1851,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw end if ! ( ssival .gt. 1.0 ) ! - ENDDO - ENDDO + ENDDO ! ix + ENDDO ! kz IF ( wrfchem_flag > 0 ) THEN IF ( PRESENT( rainprod ) ) rainprod2d(its:ite,kts:kte) = 0 IF ( PRESENT( evapprod ) ) evapprod2d(its:ite,kts:kte) = 0 ENDIF + ! transform from number mixing ratios to number conc. @@ -1715,25 +1899,43 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw RAINNCV(ix,jy) = dtp*dn1(ix,1,1)*(xfall(ix,1,lr) + xfall(ix,1,ls)*1000./xdn0(lr) + & & xfall(ix,1,lh)*1000./xdn0(lr) ) ENDIF - SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) - GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) + IF ( present ( rainncw2 ) ) THEN ! rain only + rainncw2(ix,jy) = rainncw2(ix,jy) + dtp*dn1(ix,1,1)*xfall(ix,1,lr) + ENDIF + IF ( present ( rainnci2 ) ) THEN ! ice only + IF ( lhl > 1 ) THEN + rainnci2(ix,jy) =rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) + xfall(ix,1,lhl)*1000./xdn0(lr) ) + ELSE + rainnci2(ix,jy) = rainnci2(ix,jy) + dtp*dn1(ix,1,1)*(xfall(ix,1,ls)*1000./xdn0(lr) + & + & xfall(ix,1,lh)*1000./xdn0(lr) ) + ENDIF + ENDIF + IF ( present( SNOWNCV ) ) SNOWNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,ls)*1000./xdn0(lr) + IF ( present( GRPLNCV ) ) GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lh)*1000./xdn0(lr) RAINNC(ix,jy) = RAINNC(ix,jy) + RAINNCV(ix,jy) - SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) + IF ( present (SNOWNC) .and. present (SNOWNCV) ) SNOWNC(ix,jy) = SNOWNC(ix,jy) + SNOWNCV(ix,jy) IF ( lhl > 1 ) THEN +!#ifdef CM1 +! IF ( .true. ) THEN +!#else IF ( present( HAILNC ) ) THEN +!#endif HAILNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) HAILNC(ix,jy) = HAILNC(ix,jy) + HAILNCV(ix,jy) - ELSE + ELSEIF ( present( GRPLNCV ) ) THEN GRPLNCV(ix,jy) = dtp*dn1(ix,1,1)*xfall(ix,1,lhl)*1000./xdn0(lr) ENDIF ENDIF - GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) + IF ( present( GRPLNCV ) ) GRPLNC(ix,jy) = GRPLNC(ix,jy) + GRPLNCV(ix,jy) + IF ( present( SR ) .and. present (SNOWNCV) .and. present(GRPLNCV) ) THEN IF ( present( HAILNC ) ) THEN SR(ix,jy) = (SNOWNCV(ix,jy)+HAILNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) ELSE SR(ix,jy) = (SNOWNCV(ix,jy)+GRPLNCV(ix,jy))/(RAINNCV(ix,jy)+1.e-12) ENDIF + ENDIF ENDDO ENDIF ! .false. @@ -1750,17 +1952,18 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw & (nx,ny,nz,na,jy & & ,nor,nor & & ,dtp,dz2d & - & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & - & ,an,dn1,t77 & - & ,pn,wn,0 & - & ,t00,t77, & - & ventr,ventc,c1sw,1,ido, & - & xdnmx,xdnmn, & -! & ln,ipc,lvol,lz,lliq, & + & ,t0,t1,t2,t3,t4,t5,t6,t7,t8,t9 & + & ,an,dn1,t77 & + & ,pn,wn,0 & + & ,t00,t77, & + & ventr,ventc,c1sw,1,ido, & + & xdnmx,xdnmn, & +! & ln,ipc,lvol,lz,lliq, & & cdx, & - & xdn0,dbz2d,timevtcalc & - & ,rainprod2d, evapprod2d & - & ,elec2,its,ids,ide,jds,jde & + & xdn0,dbz2d,tke2d, & + & timevtcalc,axtra, makediag & + & ,rainprod2d, evapprod2d & + & ,elec2,its,ids,ide,jds,jde & & ) @@ -1773,17 +1976,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw IF ( .true. ) THEN CALL NUCOND & & (nx,ny,nz,na,jy & - & ,nor,nor & - & ,dtp,dz2d & + & ,nor,nor,dtp,nx & + & ,dz2d & & ,t0,t9 & & ,an,dn1,t77 & & ,pn,wn & + & ,axtra, makediag & & ,ssat,t00,t77,flag_qndrop) ENDIF + ! compute diagnostic S-band reflectivity if needed IF ( present( dbz ) .and. makediag ) THEN ! calc dbz @@ -1839,6 +2044,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw ENDIF ENDIF + + ENDIF ! transform concentrations back to mixing ratios @@ -2008,6 +2215,66 @@ real function GAMXINF(A1,X1) return END function GAMXINF +! ##################################################################### + + double precision function GAMXINFDP(A1,X1) + +! =================================================== +! Purpose: Compute the incomplete gamma function +! from x to infinity +! Input : a --- Parameter ( a < 170 ) +! x --- Argument +! Output: GIM --- Gamma(a,x) t=x,Infinity +! Routine called: GAMMA for computing â(x) +! =================================================== + +! IMPLICIT DOUBLE PRECISION (A-H,O-Z) + implicit none + real :: a1,x1 +! dont declare gamma_dp because it is within the module +! double precision :: gamma_dp + double precision :: xam,dlog,s,r,ga,t0,a,x + integer :: k + double precision :: gin, gim + + a = a1 + x = x1 + XAM=-X+A*DLOG(X) + IF (XAM.GT.700.0.OR.A.GT.170.0) THEN + WRITE(*,*)'a and/or x too large' + STOP + ENDIF + IF (X.EQ.0.0) THEN + GIN=0.0 + GIM = GAMMA_dp(A) + ELSE IF (X.LE.1.0+A) THEN + S=1.0D0/A + R=S + DO 10 K=1,60 + R=R*X/(A+K) + S=S+R + IF (DABS(R/S).LT.1.0D-15) GO TO 15 +10 CONTINUE +15 GIN=DEXP(XAM)*S + ga = GAMMA_DP(A) + GIM=GA-GIN + ELSE IF (X.GT.1.0+A) THEN + T0=0.0D0 + DO 20 K=60,1,-1 + T0=(K-A)/(1.0D0+K/(X+T0)) +20 CONTINUE + GIM=DEXP(XAM)/(X+T0) +! GA = GAMMA_dp(A) +! GIN=GA-GIM + ENDIF + + gamxinfdp = GIM + return + END function GAMXINFDP + + +! ##################################################################### + ! ##################################################################### !**************************** GAML02 *********************** @@ -2585,6 +2852,11 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & vtmax = 0.0 do kz = kzb,kze + + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) vtmax = Max(vtmax,xvt(kz,ix,1,il)*dz2dinv(kz,ix)) vtmax = Max(vtmax,xvt(kz,ix,2,il)*dz2dinv(kz,ix)) @@ -2629,7 +2901,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & DO n = 1,ndfall - IF ( n .ge. 2 ) THEN + IF ( do_accurate_sedimentation .and. n .ge. 2 ) THEN ! ! zero the precip flux arrays (2d) ! @@ -2647,6 +2919,16 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, & & infdo,il) + DO kz = kzb,kze + ! apply limit vtmaxsed (08/20/2015) + xvt(kz,ix,1,il) = Min( vtmaxsed, xvt(kz,ix,1,il) ) + xvt(kz,ix,2,il) = Min( vtmaxsed, xvt(kz,ix,2,il) ) + xvt(kz,ix,3,il) = Min( vtmaxsed, xvt(kz,ix,3,il) ) + ENDDO + + + + ENDIF ! (n .ge. 2) @@ -3224,6 +3506,9 @@ END subroutine calcnfromz1d ! N will be in #/kg, NOT #/m^3, since sedimentation is done next. ! +! +! 10.27.2015: Added hail calculation +! subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) @@ -3245,10 +3530,11 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) integer ix,jy,kz - double precision vr,q,nrx,rd,g1h,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 + double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1 double precision :: zr, zs, zh, dninv - real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4 - real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 900.0 + real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4 + real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0 + real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl) real, parameter :: zhfac = 1./(pi*xdnh*xn0h) real, parameter :: zrfac = 1./(pi*xdnr*xn0r) real, parameter :: zsfac = 1./(pi*xdns*xn0s) @@ -3265,6 +3551,9 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/ & & ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) + + g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/ & + & ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) IF ( imurain == 3 ) THEN g1r = (rnu+2.0)/(rnu+1.0) @@ -3283,7 +3572,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! Cloud droplets IF ( lnc > 1 ) THEN - IF ( an(ix,jy,kz,lnc) <= 0.0 .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN + IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN an(ix,jy,kz,lnc) = qccn ENDIF ENDIF @@ -3291,13 +3580,13 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! rain IF ( lnr > 1 ) THEN - IF ( an(ix,jy,kz,lnr) <= 0.0 .and. an(ix,jy,kz,lr) > qxmin(lr) ) THEN + IF ( an(ix,jy,kz,lnr) <= 0.1*cxmin .and. an(ix,jy,kz,lr) > qxmin(lr) ) THEN q = an(ix,jy,kz,lr) laminv1 = (dn(ix,kz) * q * zrfac)**(0.25) ! inverse of slope - n1 = laminv1*xn0h ! number concentration for inv. exponential single moment input + n1 = laminv1*xn0r ! number concentration for inv. exponential single moment input nrx = n1*g1r/g0 ! number concentration for different shape parameter @@ -3308,7 +3597,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! snow IF ( lns > 1 ) THEN - IF ( an(ix,jy,kz,lns) <= 0.0 .and. an(ix,jy,kz,ls) > qxmin(ls) ) THEN + IF ( an(ix,jy,kz,lns) <= 0.1*cxmin .and. an(ix,jy,kz,ls) > qxmin(ls) ) THEN q = an(ix,jy,kz,ls) @@ -3326,7 +3615,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ! graupel IF ( lnh > 1 ) THEN - IF ( an(ix,jy,kz,lnh) <= 0.0 .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN + IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN IF ( lvh > 1 ) THEN IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh @@ -3345,6 +3634,29 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn) ENDIF ENDIF + + ! hail + + IF ( lnhl > 1 .and. lhl > 1 ) THEN + IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN + IF ( lvhl > 1 ) THEN + IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN + an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl + ENDIF + ENDIF + + q = an(ix,jy,kz,lhl) + + laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25) ! inverse of slope + + n1 = laminv1*xn0hl ! number concentration for inv. exponential single moment input + + nrx = n1*g1hl/g0 ! number concentration for different shape parameter + + an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio + + ENDIF + ENDIF ENDDO ! ix ENDDO ! kz @@ -3662,9 +3974,6 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & implicit none - -! include 'sam.index.ion.h' -! include 'swm.index.zieg.h' integer ngscnt,ngs0,ngs,nz ! integer infall ! whether to calculate number-weighted fall speeds @@ -3739,7 +4048,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & real x,y,tmp,del real aax,bbx,delrho integer :: indxr - real mwt + real mwt, nwt real, parameter :: rho00 = 1.225 integer i real xvbarmax @@ -4432,7 +4741,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.) ELSEIF ( isnowfall == 2 ) THEN ! Ferrier: - vtxbar(mgs,ls,1) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14) + vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1) ENDIF ELSE vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1) @@ -4850,7 +5159,6 @@ END SUBROUTINE setvtz ! ! ############################################################################## -! #include "sam.def.h" ! ! subroutine to calculate fall speeds of hydrometeors ! @@ -4922,9 +5230,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, & real :: xdia(ngs,lc:lhab,3) real :: vx(ngs,li:lhab) real :: alpha(ngs,lc:lhab) -!#ifdef Z3MOM real :: zx(ngs,lr:lhab) -!#endif real xdnmx(lc:lhab), xdnmn(lc:lhab) real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) @@ -5492,7 +5798,9 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & real rhos parameter ( rhos = 0.1 ) - real qxw ! temp value for liquid water on ice mixing ratio + real qxw,qxw1 ! temp value for liquid water on ice mixing ratio + real :: dnsnow + real qh real, parameter :: cwmasn = 5.23e-13 ! minimum mass, defined by radius of 5.0e-6 real, parameter :: cwmasx = 5.25e-10 ! maximum mass, defined by radius of 50.0e-6 @@ -5971,15 +6279,18 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & gtmp(ix,kz) = 0.0 qxw = 0.0 + qxw1 = 0.0 dtmps = 0.0 IF ( an(ix,jy,kz,ls) .ge. qsmin ) THEN !{ IF ( ipconc .ge. 4 ) THEN ! (Ferrier 94) !{ if (lsw .gt. 1) THEN qxw = an(ix,jy,kz,lsw) + qxw1 = 0.0 ELSEIF ( iusewetsnow == 1 .and. temk(ix,jy,kz) .gt. tfr+1. .and. an(ix,jy,kz,ls) > an(ix,jy,kz,lr) & & .and. an(ix,jy,kz,lr) > qsmin) THEN qxw = Min(0.5*an(ix,jy,kz,ls), an(ix,jy,kz,lr)) + qxw1 = qxw ENDIF vr = xvs ! db(ix,jy,kz)*an(ix,jy,kz,lr)/(1000.*an(ix,jy,kz,lnr)) @@ -5990,12 +6301,19 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & IF ( qxw > qsmin ) THEN ! old version ! gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*an(ix,jy,kz,ls) + 0.776*qxw)*an(ix,jy,kz,ls)/ & ! & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 - gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw)/ & + gtmp(ix,kz) = 3.6e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 ELSE ! new form using a mass relationship m = p d^2 (instead of d^3 -- Cox 1988 QJRMS) so that density depends on size - gtmp(ix,kz) = 1.e18* 1.06214**2*(ksq*an(ix,jy,kz,ls) + (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow1* gsnow73/ & - & (an(ix,jy,kz,lns)*(917.)**2* gsnow53**2) + ! p = 0.106214 for m = p v^(2/3) + dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) ) + IF ( .true. .or. dnsnow < 900. ) THEN + gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/ & + & (an(ix,jy,kz,lns)*(917.)**2* gsnow1*(1.0+snu)**(4./3.)) + ELSE ! otherwise small enough to assume ice spheres? + gtmp(ix,kz) = (36./pi**2) * 1.e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ & + & (an(ix,jy,kz,lns)*(snu+1.)*rwdn**2)*db(ix,jy,kz)**2 + ENDIF ENDIF ENDIF @@ -6070,6 +6388,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & chw = db(ix,jy,kz)*an(ix,jy,kz,lh)/(xvh*hwdn) ENDIF + qh = an(ix,jy,kz,lh) + IF ( lhw .gt. 1 ) THEN IF ( iusewetgraupel .eq. 1 ) THEN qxw = an(ix,jy,kz,lhw) @@ -6081,7 +6401,13 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & ELSEIF ( iusewetgraupel .eq. 3 ) THEN IF ( hwdn .lt. 300. .and. temk(ix,jy,kz) > tfr .and. an(ix,jy,kz,lr) > qhmin ) THEN qxw = Min( an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw ENDIF + ELSEIF ( iusewetgraupel == 4 .and. temk(ix,jy,kz) .gt. tfr+0.25 .and. an(ix,jy,kz,lh) > an(ix,jy,kz,lr) & + & .and. an(ix,jy,kz,lr) > qhmin) THEN + qxw = Min(0.5*an(ix,jy,kz,lh), an(ix,jy,kz,lr)) + qh = qh + qxw + ENDIF IF ( lzh .gt. 1 ) THEN @@ -6089,7 +6415,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & g1 = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah)) ! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lh))**2/chw ! ze = 0.224*1.e18*zx*(6./(pi*1000.))**2 - zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lh) + 0.776*qxw)*an(ix,jy,kz,lh)/chw + zx = g1*db(ix,jy,kz)**2*( 0.224*qh + 0.776*qxw)*qh/chw ze =1.e18*zx*(6./(pi*1000.))**2 dtmp(ix,kz) = dtmp(ix,kz) + ze dtmph = ze @@ -6185,7 +6511,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk, & g1 = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl)) zx = g1*db(ix,jy,kz)**2*( 0.224*an(ix,jy,kz,lhl) + 0.776*qxw)*an(ix,jy,kz,lhl)/chl ! zx = g1*(db(ix,jy,kz)*an(ix,jy,kz,lhl))**2/chl - ze = 0.224*1.e18*zx*(6./(pi*1000.))**2 + ze = 1.e18*zx*(6./(pi*1000.))**2 ! 3/28/2016 removed extra factor of 0.224 dtmp(ix,kz) = dtmp(ix,kz) + ze dtmphl = ze @@ -6333,18 +6659,19 @@ END subroutine radardd02 ! SUBROUTINE NUCOND & & (nx,ny,nz,na,jyslab & - & ,nor,norz,dtp & + & ,nor,norz,dtp,nxi & & ,dz3d & & ,t0,t9 & & ,an,dn,p2 & & ,pn,w & + & ,axtra,io_flag & & ,ssfilt,t00,t77,flag_qndrop & & ) implicit none - integer :: nx,ny,nz,na + integer :: nx,ny,nz,na,nxi integer :: nor,norz, jyslab ! ,nht,ngt,igsr real :: dtp ! time step logical :: flag_qndrop @@ -6390,6 +6717,11 @@ SUBROUTINE NUCOND & ! local + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + logical :: io_flag + + real :: dv + ! ! declarations microphysics and for gather/scatter ! @@ -6440,6 +6772,7 @@ SUBROUTINE NUCOND & real chw, g1, rd1 real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp2 ! , sstdy, super + real tmpmx, fw real x,y,del,r,alpr double precision :: vent1,vent2 real g1palp @@ -6464,7 +6797,7 @@ SUBROUTINE NUCOND & integer il real es(ngs) ! ss(ngs), - real eis(ngs) +! real eis(ngs) real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs) real ssfjp1(ngs),ssfjm1(ngs) real ssfip1(ngs),ssfim1(ngs) @@ -6491,7 +6824,7 @@ SUBROUTINE NUCOND & real temgx(ngs),temcgx(ngs) real qvs(ngs),qis(ngs),qss(ngs),pqs(ngs) real felv(ngs),felf(ngs),fels(ngs) - real felvcp(ngs) + real felvcp(ngs),felvpi(ngs) real gamw(ngs),gams(ngs) ! qciavl(ngs), real tsqr(ngs),ssi(ngs),ssw(ngs) real cc3(ngs),cqv1(ngs),cqv2(ngs) @@ -6503,7 +6836,7 @@ SUBROUTINE NUCOND & real fci(ngs),fcw(ngs) real fschm(ngs),fpndl(ngs) - real pres(ngs) + real pres(ngs),pipert(ngs) real pk(ngs) real rho0(ngs),pi0(ngs) real rhovt(ngs) @@ -6535,7 +6868,10 @@ SUBROUTINE NUCOND & real :: frac, hwdn, tmpg - real :: cvm + real :: cvm,cpm,rmm + + real, parameter :: rovcp = rd/cp + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure integer :: kstag @@ -6543,18 +6879,20 @@ SUBROUTINE NUCOND & ! ------------------------------------------------------------------------------- - itile = nx + itile = nxi jtile = ny ktile = nz - ixend = nx + ixend = nxi jyend = ny kzend = nz - nxend = nx + 1 + nxend = nxi + 1 nyend = ny + 1 nzend = nz kzbeg = 1 nzbeg = 1 + f5 = 237.3 * 17.27 * 2.5e6 / cp ! combined constants for rain condensation (Soong and Ogura 73) + jy = 1 kstag = 0 pb(:) = 0.0 @@ -6566,12 +6904,12 @@ SUBROUTINE NUCOND & ! Ziegler nucleation ! - ssfilt(:,:,:) = 0.0 +! ssfilt(:,:,:) = 0.0 ssmx = 0 count = 0 do kz = 1,nz-kstag - do ix = 1,nx + do ix = 1,nxi temp1 = an(ix,jy,kz,lt)*t77(ix,jy,kz) t0(ix,jy,kz) = temp1 @@ -6580,8 +6918,9 @@ SUBROUTINE NUCOND & c1 = t00(ix,jy,kz)*tabqvs(ltemq) - ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values - + IF ( c1 > 0. ) THEN + ssfilt(ix,jy,kz) = 100.*(an(ix,jy,kz,lv)/c1 - 1.0) ! from "new" values + ENDIF ENDDO ENDDO @@ -6600,7 +6939,7 @@ SUBROUTINE NUCOND & nxmpb = 1 nzmpb = 1 - nxz = nx*nz + nxz = nxi*nz numgs = nxz/ngs + 1 @@ -6618,7 +6957,7 @@ SUBROUTINE NUCOND & ! if (ixbeg .le. nxmpb .and. ixend .gt. nxmpb) ixb = nxmpb do kz = kzb,kze - do ix = nxmpb,nx + do ix = nxmpb,nxi pqs(1) = 380.0/(pn(ix,jy,kz) + pb(kz)) theta(1) = an(ix,jy,kz,lt) @@ -6692,12 +7031,14 @@ SUBROUTINE NUCOND & qwvp(mgs) = qx(mgs,lv) - qv0(mgs) pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) rhoinv(mgs) = 1.0/rho0(mgs) rhovt(mgs) = Sqrt(rho00/rho0(mgs)) pi0(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) temg(mgs) = t0(igs(mgs),jy,kgs(mgs)) - pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap +! pk(mgs) = t77(igs(mgs),jy,kgs(mgs)) ! ( pres(mgs) / poo ) ** cap + pk(mgs) = p2(igs(mgs),jy,kgs(mgs)) + pinit(kgs(mgs)) ! t77(igs(mgs),jy,kgs(mgs)) temcg(mgs) = temg(mgs) - tfr qss0(mgs) = (380.0)/(pres(mgs)) pqs(mgs) = (380.0)/(pres(mgs)) @@ -6722,7 +7063,19 @@ SUBROUTINE NUCOND & IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) - felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + IF ( eqtset == 2 ) THEN + + felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm + + ELSE + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + ENDIF + ENDIF temcgx(mgs) = min(temg(mgs),273.15) @@ -6946,8 +7299,9 @@ SUBROUTINE NUCOND & IF ( qx(mgs,lc) .LT. QEVAP ) THEN ! GO TO 63 qwvp(mgs) = qwvp(mgs) + qx(mgs,lc) thetap(mgs) = thetap(mgs) - felv(mgs)*qx(mgs,lc)/(cp*pi0(mgs)) -! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) - (qx(mgs,lc))/dtp*felv(mgs)/(cp*pi0(mgs)) !* & -!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -qx(mgs,lc)/dtp + ENDIF qx(mgs,lc) = 0. cx(mgs,lc) = 0. ELSE @@ -6955,8 +7309,10 @@ SUBROUTINE NUCOND & qx(mgs,lc) = qx(mgs,lc) - QEVAP IF ( qx(mgs,lc) .le. 0. ) cx(mgs,lc) = 0. thetap(mgs) = thetap(mgs) - felv(mgs)*QEVAP/(CP*pi0(mgs)) -! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) - (qevap)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & -!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = -QEVAP/dtp + ENDIF + ENDIF GO TO 631 @@ -7120,6 +7476,8 @@ SUBROUTINE NUCOND & dqr = 0.0 dqi = 0.0 dqs = 0.0 + dqvii = 0.0 + dqvis = 0.0 RK2c: DO WHILE ( dt1 .lt. dtp ) nc = 0 @@ -7135,7 +7493,7 @@ SUBROUTINE NUCOND & ! calculate midpoint values: ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5) IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN - write(0,*) 'STOP in icezvd_dr line 3790 ' + write(0,*) 'STOP in nucond line 1192 ' write(0,*) ' ltemq1m,icond = ',ltemq1m,icond write(0,*) ' dtemp,e1,f1,dqv,dqvr = ', dtemp,e1,f1,dqv,dqvr write(0,*) ' d1,d1r,dtcon,ss1 = ',d1,d1r,dtcon,ss1 @@ -7144,7 +7502,7 @@ SUBROUTINE NUCOND & write(0,*) ' i, j, k = ',igs(mgs),jy,kgs(mgs) write(0,*) ' dtcon1,dtcon2,delta = ',dtcon1,dtcon2,delta write(0,*) ' nc,dtp = ',nc,dtp - write(0,*) ' rwvent,xdia,crw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr) + write(0,*) ' rwvent,xdia,crw,ccw = ', rwvent(mgs),xdia(mgs,lr,1),cx(mgs,lr),cx(mgs,lc) write(0,*) ' fvent,alphar = ',fvent(mgs),alpha(mgs,lr) write(0,*) ' xvr,xmasr,xdnr,cwc1 = ',xv(mgs,lr),xmas(mgs,lr),xdn(mgs,lr),cwc1 ENDIF @@ -7173,7 +7531,7 @@ SUBROUTINE NUCOND & dtemp = -e1*f1*(dqv + dqvr) ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5) IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN - write(0,*) 'STOP in icezvd_dr line 3856 ' + write(0,*) 'STOP in nucond line 1230 ' write(0,*) ' ltemq1m,icond = ',ltemq1m,icond write(0,*) ' dtemp,e1,dqv,dqvr = ', dtemp,e1,dqv,dqvr ENDIF @@ -7203,6 +7561,13 @@ SUBROUTINE NUCOND & dcloud = dqc ! qx(mgs,lv) - qv1 thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr) + ENDIF + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + axtra(igs(mgs),jy,kgs(mgs),2) = axtra(igs(mgs),jy,kgs(mgs),2) + dqr/dtp + ENDIF qwvp(mgs) = qwvp(mgs) - (DCLOUD + dqr) qx(mgs,lc) = qx(mgs,lc) + DCLOUD qx(mgs,lr) = qx(mgs,lr) + dqr @@ -7215,7 +7580,7 @@ SUBROUTINE NUCOND & ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - es(mgs) = 6.1078e2*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) ! @@ -7260,17 +7625,16 @@ SUBROUTINE NUCOND & thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs)) qwvp(mgs) = qwvp(mgs) - DCLOUD qx(mgs,lc) = qx(mgs,lc) + DCLOUD - -! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (DCLOUD)/dtp*felv(mgs)/(cp*pi0(mgs)) ! * & -!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) - + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = DCLOUD/dtp + ENDIF theta(mgs) = thetap(mgs) + theta0(mgs) temg(mgs) = theta(mgs)*pk(mgs) !( pres(mgs) / poo ) ** cap ! temg(mgs) = theta2temp( theta(mgs), pres(mgs) ) ltemq = (temg(mgs)-163.15)/fqsat+1.5 ltemq = Min( nqsat, Max(1,ltemq) ) qvs(mgs) = pqs(mgs)*tabqvs(ltemq) - es(mgs) = 6.1078e2*tabqvs(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) !.... S. TWOMEY (1959) ! Note: get here if there is no previous cloud water and w > 0. @@ -7481,10 +7845,9 @@ SUBROUTINE NUCOND & IF ( qvex .gt. 0.0 ) THEN thetap(mgs) = thetap(mgs) + felvcp(mgs)*qvex/(pi0(mgs)) - -! t9(igs(mgs),jy,kgs(mgs)) = t9(igs(mgs),jy,kgs(mgs)) + (qvex)/dtp*felv(mgs)/(cp*pi0(mgs)) !* & -!! & dx*dy*dz3d(igs(mgs),jy,kgs(mgs)) - + IF ( io_flag .and. nxtra > 1 ) THEN + axtra(igs(mgs),jy,kgs(mgs),1) = axtra(igs(mgs),jy,kgs(mgs),1) + qvex/dtp + ENDIF qwvp(mgs) = qwvp(mgs) - qvex qx(mgs,lc) = qx(mgs,lc) + qvex IF ( .not. flag_qndrop) THEN @@ -7573,6 +7936,10 @@ SUBROUTINE NUCOND & an(igs(mgs),jy,kgs(mgs),lv) = qv0(mgs) + qwvp(mgs) ! tmp3d(igs(mgs),jy,kgs(mgs)) = tmp3d(igs(mgs),jy,kgs(mgs)) + t9(igs(mgs),jy,kgs(mgs)) ! pi0(mgs) ! wvdf(mgs) ! ssf(mgs) ! cn(mgs) ! + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF + if ( ido(lc) .eq. 1 ) then an(igs(mgs),jy,kgs(mgs),lc) = qx(mgs,lc) + & & min( an(igs(mgs),jy,kgs(mgs),lc), 0.0 ) @@ -7603,8 +7970,8 @@ SUBROUTINE NUCOND & 29998 continue - if ( kz .gt. nz-1 .and. ix .ge. nx) then - if ( ix .ge. nx ) then + if ( kz .gt. nz-1 .and. ix .ge. nxi) then + if ( ix .ge. nxi ) then go to 2200 ! exit gather scatter else nzmpb = kz @@ -7613,7 +7980,7 @@ SUBROUTINE NUCOND & nzmpb = kz end if - if ( ix .ge. nx ) then + if ( ix .ge. nxi ) then nxmpb = 1 nzmpb = kz+1 else @@ -7642,7 +8009,7 @@ SUBROUTINE NUCOND & do kz = 1,nz ! do jy = 1,1 - do ix = 1,nx + do ix = 1,nxi zerocx(:) = .false. DO il = lc,lhab @@ -7688,24 +8055,45 @@ SUBROUTINE NUCOND & IF ( lvol(lhl) .gt. 1 ) THEN ! check density IF ( an(ix,jy,kz,lvhl) .gt. 0.0 ) THEN tmp = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/an(ix,jy,kz,lvhl) - ELSE - tmp = 0.5*( xdnmn(lhl) + xdnmx(lhl) ) + ELSE ! in case volume is zero but mass is above threshold (should not happen, of course) + tmp = rho_qhl an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp ENDIF -! DEBUG -! tmp = 850. -! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp -! IF ( an(ix,jy,kz,lhl) .gt. 1.0e-3 ) THEN -! write(iunit,*) 'HAILdr: dn,q,c,v = ',tmp,an(ix,jy,kz,lhl)*1000., -! : an(ix,jy,kz,lnhl), an(ix,jy,kz,lvhl) -! write(iunit,*) 'lvhl = ',lvhl -! ENDIF - + IF ( tmp .lt. xdnmn(lhl) ) THEN + tmp = Max( xdnmn(lhl), tmp ) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF - IF ( tmp .gt. xdnmx(lhl) .or. tmp .lt. xdnmn(lhl) ) THEN - tmp = Min( xdnmx(lhl), Max( xdnmn(lhl) , tmp ) ) + IF ( tmp .gt. xdnmx(lhl) .and. lhlw .le. 0 ) THEN ! no liquid allowed on hail + tmp = Min( xdnmx(lhl), tmp ) an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ELSEIF ( tmp .gt. xdnmx(lhl) .and. lhlw .gt. 1 ) THEN ! allow for liquid on hail + fw = an(ix,jy,kz,lhlw)/an(ix,jy,kz,lhl) +! tmpmx = xdnmx(lhl) + fw*(xdnmx(lr) - xdnmx(lhl)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + + tmpmx = xdnmx(lhl)/( 1. - fw*(1. - xdnmx(lhl)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmpmx + ENDIF + +! IF ( tmp .gt. xdnmx(lhl) .and. an(ix,jy,kz,lhlw) .lt. qxmin(lhl) ) THEN +! tmp = Min( xdnmx(lhl), tmp ) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp +! ENDIF + ENDIF + + IF ( lhlw .gt. 1 ) THEN ! check if basically pure water + IF ( an(ix,jy,kz,lhlw) .gt. 0.98*an(ix,jy,kz,lhl) ) THEN + tmp = xdnmx(lr) + an(ix,jy,kz,lvhl) = dn(ix,jy,kz)*an(ix,jy,kz,lhl)/tmp + ENDIF ENDIF ENDIF @@ -7777,13 +8165,24 @@ SUBROUTINE NUCOND & tmp = Min( xdnmx(lh), tmp ) an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp ELSEIF ( tmp .gt. xdnmx(lh) .and. lhw .gt. 1 ) THEN ! allow for liquid on graupel - IF ( tmp .gt. xdnmx(lh) .and. an(ix,jy,kz,lhw) .lt. qxmin(lh) ) THEN - tmp = Min( xdnmx(lh), tmp ) - an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp - ELSEIF ( tmp .gt. xdnmx(lr) ) THEN - tmp = xdnmn(lr) - an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp + fw = an(ix,jy,kz,lhw)/an(ix,jy,kz,lh) +! tmpmx = xdnmx(lh) + fw*(xdnmx(lr) - xdnmx(lh)) ! maximum possible average density + ! it is not exactly linear, but approx. is close enough for this +! tmpmx = 1./( (1. - fw)/900. + fw/1000. ) is exact max, where 900 is xdnmx + tmpmx = xdnmx(lh)/( 1. - fw*(1. - xdnmx(lh)/xdnmx(lr) )) + + IF ( tmp .gt. tmpmx ) THEN + an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmpmx ENDIF + +! IF ( tmp .gt. xdnmx(lh) .and. an(ix,jy,kz,lhw) .lt. qxmin(lh) ) THEN +! tmp = Min( xdnmx(lh), tmp ) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ELSEIF ( tmp .gt. xdnmx(lr) ) THEN +! tmp = xdnmx(lr) +! an(ix,jy,kz,lvh) = dn(ix,jy,kz)*an(ix,jy,kz,lh)/tmp +! ENDIF + ENDIF IF ( lhw .gt. 1 ) THEN ! check if basically pure water @@ -7904,6 +8303,20 @@ SUBROUTINE NUCOND & ENDIF ENDIF +! +! for qis +! + IF ( lis > 1 ) THEN + IF ( an(ix,jy,kz,lis) .le. frac*qxmin(lis) .or. zerocx(lis) & ! .or. an(ix,jy,kz,lni) .lt. 0.1 + & ) THEN + an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis) + an(ix,jy,kz,lis)= 0.0 + IF ( ipconc .ge. 1 ) THEN + an(ix,jy,kz,lnis) = 0.0 + ENDIF + ENDIF + ENDIF + ! ! for qcw ! @@ -8000,8 +8413,8 @@ subroutine nssl_2mom_gs & & xdnmx,xdnmn, & ! & ln,ipc,lvol,lz,lliq, & & cdx, & - & xdn0,tmp3d & - & ,timevtcalc & + & xdn0,tmp3d,tkediss & + & ,timevtcalc,axtra,io_flag & & ,rainprod2d, evapprod2d & & ,elec,its,ids,ide,jds,jde & & ) @@ -8074,6 +8487,8 @@ subroutine nssl_2mom_gs & integer iwrite real dtp,dx,dy,dz + logical, intent(in) :: io_flag + integer itile,jtile,ktile integer ixbeg,jybeg integer ixend,jyend,kzend,kzbeg @@ -8084,7 +8499,11 @@ subroutine nssl_2mom_gs & real evapprod2d(-nor+1:nx+nor,-norz+ng1:nz+norz) + real tkediss(-nor+1:nx+nor,-norz+ng1:nz+norz) + real axtra(-nor+ng1:nx+nor,-nor+ng1:ny+nor,-norz+ng1:nz+norz,nxtra) + real :: galpharaut + real :: xvbarmax integer jyslab,its,ids,ide,jds,jde ! domain boundaries integer, intent(in) :: iunit !,iunit0 @@ -8108,7 +8527,8 @@ subroutine nssl_2mom_gs & logical, parameter :: usegamxinf = .false. - logical, parameter :: usegamxinf2 = .true. + logical, parameter :: usegamxinf2 = .false. + logical, parameter :: usegamxinf3 = .false. ! real rar ! rime accretion rate as calculated from qxacw @@ -8116,7 +8536,7 @@ subroutine nssl_2mom_gs & real vtmax integer n,ndfall - double precision chgneg,chgpos + double precision chgneg,chgpos,sctot real temgtmp @@ -8222,6 +8642,8 @@ subroutine nssl_2mom_gs & integer ntt parameter (ntt=300) + real dvmgs(ngs) + integer ngscnt,igs(ngs),kgs(ngs) integer kgsp(ngs),kgsm(ngs),kgsm2(ngs) integer ncuse @@ -8255,8 +8677,8 @@ subroutine nssl_2mom_gs & integer ifilt ! =1 to filter ssat, =0 to set ssfilt=ssat parameter ( ifilt = 0 ) real temp1,temp2 ! ,ssold - real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor - real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter, 4 for mass-weighted diameter + real :: mwat, mice, dice, mwshed, fwmax, fw, mwcrit, massfactor, tmpdiam + real, parameter :: shedalp = 3. ! set 3 for maximum mass diameter (same as area-weighted diameter), 4 for mass-weighted diameter real ssmax(ngs) ! maximum SS experienced by a parcel real ssmx real dnnet,dqnet @@ -8282,11 +8704,11 @@ subroutine nssl_2mom_gs & real ex1, ft, rhoinv(ngs) double precision ec0(ngs) - real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4 ! , sstdy, super + real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5 ! , sstdy, super real ratio, delx, dely real dbigg,volt real chgtmp,fac - real x,y,del,r,rtmp,alpr + real x,y,y2,del,r,rtmp,alpr double precision :: vent1,vent2 real g1palp,g4palp real fqt !charge separation as fn of temperature from Dong and Hallett 1992 @@ -8297,7 +8719,7 @@ subroutine nssl_2mom_gs & real, parameter :: vr1mm = 5.23599e-10 ! volume of 1mm diameter sphere (m**3) real, parameter :: vr3mm = 5.23599e-10*(3.0/1.)**3 ! volume of a 3 mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) real, parameter :: vr4p5mm = 5.23599e-10*(4.5/1.)**3 ! volume of 4.5mm diameter sphere (m**3) (Rasmussen et al. 1984b, JAS) - real vmlt,vshd + real vmlt,vshd, vshdgs(ngs,lh:lhab), maxmassfac(lc:lhab) real rhosm parameter ( rhosm = 500. ) integer nc ! condensation step @@ -8313,8 +8735,8 @@ subroutine nssl_2mom_gs & real cn(ngs) double precision xvc, xvr real mwfac - real es(ngs) ! ss(ngs), - real eis(ngs) +! real es(ngs) ! ss(ngs), +! real eis(ngs) real rwmasn,rwmasx @@ -8365,7 +8787,9 @@ subroutine nssl_2mom_gs & real pid4 real cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1 real gf73rds, gf83rds + real gamice73fac, gamsnow73fac real gf43rds, gf53rds + real gamma real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn parameter ( rwradmn = 50.e-6 ) real dh0 @@ -8383,6 +8807,7 @@ subroutine nssl_2mom_gs & real fai(ngs),fav(ngs),fbi(ngs),fbv(ngs) real felv(ngs),fels(ngs),felf(ngs) real felvcp(ngs),felscp(ngs),felfcp(ngs) + real felvpi(ngs),felspi(ngs),felfpi(ngs) real felvs(ngs),felss(ngs) ! ,felfs(ngs) real fwvdf(ngs),ftka(ngs),fthdf(ngs) real fadvisc(ngs),fakvisc(ngs) @@ -8391,7 +8816,10 @@ subroutine nssl_2mom_gs & real fgamw(ngs),fgams(ngs) real fcqv1(ngs),fcqv2(ngs),fcc3(ngs) - real cvm + real cvm,cpm,rmm + + real, parameter :: rovcp = rd/cp + real, parameter :: cpv = 1885.0 ! specific heat of water vapor at constant pressure ! real fcci(ngs), fcip(ngs) ! @@ -8402,9 +8830,10 @@ subroutine nssl_2mom_gs & logical :: wetsfc(ngs),wetsfchl(ngs) logical :: wetgrowth(ngs), wetgrowthhl(ngs) - real qitmp(ngs) + real qitmp(ngs),qistmp(ngs) real rzxh(ngs), rzxhl(ngs), rzxhlh(ngs) + real rzxs(ngs) real axh(ngs),bxh(ngs),axhl(ngs),bxhl(ngs) real vt2ave(ngs) @@ -8433,7 +8862,14 @@ subroutine nssl_2mom_gs & real ventrxn(ngs) real g1shr, alphashr real g1mlr, alphamlr + real massfacshr, massfacmlr + real :: qhgt8mm ! ice mass greater than 8mm + real :: qhgt10mm ! mass greater than 10mm + real :: qhgt20mm ! mass greater than 20mm + real :: fwmhtmp + real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) + real, parameter :: srasheym = 0.1389 ! real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs) integer, parameter :: ndiam = 10 @@ -8457,6 +8893,7 @@ subroutine nssl_2mom_gs & real civent(ngs) + real isvent(ngs) ! real xmascw(ngs) real xdnmx(lc:lhab), xdnmn(lc:lhab) @@ -8470,9 +8907,10 @@ subroutine nssl_2mom_gs & real hwcap(ngs) real hlcap(ngs) real cicap(ngs) + real iscap(ngs) real qvimxd(ngs) - real qimxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) + real qimxd(ngs),qismxd(ngs),qcmxd(ngs),qrmxd(ngs),qsmxd(ngs),qhmxd(ngs),qhlmxd(ngs) real cimxd(ngs),ccmxd(ngs),crmxd(ngs),csmxd(ngs),chmxd(ngs) real cionpmxd(ngs),cionnmxd(ngs) real clionpmxd(ngs),clionnmxd(ngs) @@ -8515,7 +8953,8 @@ subroutine nssl_2mom_gs & real :: chlaci(ngs), chlacs(ngs) real crcnw(ngs) real cidpv(ngs),cisbv(ngs) - real cimlr(ngs) + real cisdpv(ngs),cissbv(ngs) + real cimlr(ngs),cismlr(ngs) real chlsbv(ngs), chldpv(ngs) real chlmlr(ngs), chlmlrr(ngs) @@ -8592,7 +9031,7 @@ subroutine nssl_2mom_gs & ! conversions ! real qrfrz(ngs) ! , qirirhr(ngs) - real zrfrz(ngs), zrfrzf(ngs) + real zrfrz(ngs), zrfrzf(ngs), zrfrzs(ngs) real ziacrf(ngs), zhcnsh(ngs), zhcnih(ngs) real zhacw(ngs), zhacs(ngs), zhaci(ngs) real zhmlr(ngs), zhdsv(ngs), zhsbv(ngs), zhlcnh(ngs), zhshr(ngs) @@ -8611,9 +9050,11 @@ subroutine nssl_2mom_gs & real qrfrzs(ngs), qrfrzf(ngs) real qwfrz(ngs), qwctfz(ngs) real cwfrz(ngs), cwctfz(ngs) - real qwfrzc(ngs), qwctfzc(ngs) + real qwfrzis(ngs), qwctfzis(ngs) ! droplet freezing to ice spheres + real cwfrzis(ngs), cwctfzis(ngs) + real qwfrzc(ngs), qwctfzc(ngs) ! droplet freezing to columns real cwfrzc(ngs), cwctfzc(ngs) - real qwfrzp(ngs), qwctfzp(ngs) + real qwfrzp(ngs), qwctfzp(ngs) ! droplet freezing to plates real cwfrzp(ngs), cwctfzp(ngs) real xcolmn(ngs), xplate(ngs) real ciihr(ngs), qiihr(ngs) @@ -8630,7 +9071,8 @@ subroutine nssl_2mom_gs & real uvel(ngs),vvel(ngs) ! real qidpv(ngs),qisbv(ngs) ! qicnv(ngs),qievv(ngs), - real qimlr(ngs),qidsv(ngs),qidsvp(ngs) ! ,qicev(ngs) + real qimlr(ngs),qidsv(ngs),qisdsv(ngs),qidsvp(ngs) ! ,qicev(ngs) + real qismlr(ngs) ! real qfdpv(ngs),qfsbv(ngs) ! qfcnv(ngs),qfevv(ngs), @@ -8702,7 +9144,7 @@ subroutine nssl_2mom_gs & real :: qhcnhl(ngs), chcnhl(ngs), zhcnhl(ngs), vhcnhl(ngs) ! conversion of low-density hail back to graupel - real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs) + real eiw(ngs),eii(ngs),eiri(ngs),eipir(ngs),eisw(ngs) real erw(ngs),esw(ngs),eglw(ngs),eghw(ngs),efw(ngs) real ehxw(ngs),ehlw(ngs),egmw(ngs),ehw(ngs) real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs) @@ -8758,7 +9200,7 @@ subroutine nssl_2mom_gs & ! real ptotal(ngs) ! , pqtot(ngs) ! - real pqcwi(ngs),pqcii(ngs),pqrwi(ngs) + real pqcwi(ngs),pqcii(ngs),pqrwi(ngs),pqisi(ngs) real pqswi(ngs),pqhwi(ngs),pqwvi(ngs) real pqgli(ngs),pqghi(ngs),pqfwi(ngs) real pqgmi(ngs),pqhli(ngs) ! ,pqhxi(ngs) @@ -8769,7 +9211,7 @@ subroutine nssl_2mom_gs & real pvhli(ngs), pvhld(ngs) real pvswi(ngs), pvswd(ngs) ! - real pqcwd(ngs),pqcid(ngs),pqrwd(ngs) + real pqcwd(ngs),pqcid(ngs),pqrwd(ngs),pqisd(ngs) real pqswd(ngs),pqhwd(ngs),pqwvd(ngs) real pqgld(ngs),pqghd(ngs),pqfwd(ngs) real pqgmd(ngs),pqhld(ngs) ! ,pqhxd(ngs) @@ -8783,6 +9225,7 @@ subroutine nssl_2mom_gs & real pciri(ngs), pcird(ngs) real pccwi(ngs), pccwd(ngs) real pccii(ngs), pccid(ngs) + real pcisi(ngs), pcisd(ngs) real pccin(ngs) real pcrwi(ngs), pcrwd(ngs) real pcswi(ngs), pcswd(ngs) @@ -8806,7 +9249,7 @@ subroutine nssl_2mom_gs & real qss0(ngs) real qsacip(ngs) - real pres(ngs) + real pres(ngs),pipert(ngs) real pk(ngs) real rho0(ngs),pi0(ngs) real rhovt(ngs),sqrtrhovt @@ -8931,20 +9374,23 @@ subroutine nssl_2mom_gs & integer iqgl, iqgm, iqgh, iqrw, iqsw integer itertd, ia + integer :: infdo + real tau, ewtmp integer cntnic_noliq real q_noliqmn, q_noliqmx real scsacimn, scsacimx - double precision :: dtpinv + real :: dtpinv ! arrays for temporary bin space + real :: qhmlrtmp,qhmlrtmp2, chmlrtmp, chmlrtmpd1inf, chlmlrtmp, zhlmlrtmp, zhlmlrrtmp, qvs0,tmpcmlt + real :: term1,term2,term3,term4 real :: qaacw ! combined qsacw-qhacw for WSM6 variation -! inline functions for Newton method ! @@ -9066,6 +9512,9 @@ subroutine nssl_2mom_gs & gf53rds = 0.9027452930 ! gamma(5./3.) gf73rds = 1.190639349 ! gamma(7./3.) gf83rds = 1.504575488 ! gamma(8./3.) + + gamice73fac = (gamma(7./3. + cinu))**3/ (gamma(1. + cinu)**3 * (1. + cinu)**4) + gamsnow73fac = (gamma(7./3. + snu))**3/ (gamma(1. + snu)**3 * (1. + snu)**4) ! ! constants ! @@ -9092,6 +9541,47 @@ subroutine nssl_2mom_gs & tfrcbi = tfr - cbi ! ! +! #ifdef COMMAS +! print*,'ventr,ventc = ',ventr,ventc + +! +! Set up look up tables for supersaturation w.r.t. liq and ice +! +!VD$L SKIP +! do l = 1,nqsat +! temq = 163.15 + (l-1)*fqsat +! tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw)) +! tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi)) +! end do + + mltmass1inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize1)**3) ) ! for drops melting from ice with diameter > 1.9cm + mltmass2inv = 1.0/( 1000.0*(4.0*pi/3.0)*((0.01*0.5*takshedsize2)**3) ) ! for drops melting from ice with 0.9cm < d < 1.9cm + mltmass1cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize1)**3) + mltmass2cgs = 1.0*(4.0*pi/3.0)*((0.5*takshedsize2)**3) + +! real, parameter :: mltdiam1 = 9.0e-3, mltdiam2 = 19.0e-3, mltdiam05 = 4.5e-3 + + IF ( .false. ) THEN + numdiam = 1 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 4.5e-3 + ELSEIF ( .true. ) THEN + numdiam = 2 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 1.5e-3 + mltdiam(2) = 4.5e-3 + ELSE + numdiam = 5 ! must have numdiam < ndiam because numdiam+1 holds values for the interval of mltdiam(numdiam) to mltdiam(ndiam+1) + mltdiam(1) = 0.5e-3 + mltdiam(2) = 1.0e-3 + mltdiam(3) = 2.0e-3 + mltdiam(4) = 4.0e-3 + mltdiam(5) = 6.0e-3 + ENDIF + + + mltdiam(ndiam+1) = mltdiam1 ! 9.0e-3 + mltdiam(ndiam+2) = mltdiam2 ! 19.0e-3 + mltdiam(ndiam+3) = mltdiam3 !100.0e-3 + ! ! cw constants in mks units @@ -9260,6 +9750,7 @@ subroutine nssl_2mom_gs & qwvp(mgs) = an(igs(mgs),jy,kgs(mgs),lv) - qv0(mgs) ! qv0(mgs) is full qv, so qwvp starts as zero! pres(mgs) = pn(igs(mgs),jy,kgs(mgs)) + pb(kgs(mgs)) + pipert(mgs) = p2(igs(mgs),jy,kgs(mgs)) rho0(mgs) = dn(igs(mgs),jy,kgs(mgs)) rhoinv(mgs) = 1.0/rho0(mgs) rhovt(mgs) = Sqrt(rho00/rho0(mgs)) @@ -9275,8 +9766,8 @@ subroutine nssl_2mom_gs & ltemq = Min( nqsat, Max(1,ltemq) ) qvs(mgs) = pqs(mgs)*tabqvs(ltemq) qis(mgs) = pqs(mgs)*tabqis(ltemq) - es(mgs) = 6.1078e2*tabqvs(ltemq) - eis(mgs) = 6.1078e2*tabqis(ltemq) +! es(mgs) = 6.1078e2*tabqvs(ltemq) +! eis(mgs) = 6.1078e2*tabqis(ltemq) cnostmp(mgs) = cno(ls) ! @@ -9357,6 +9848,12 @@ subroutine nssl_2mom_gs & rzxh(:) = rz rzxhl(:) = rzhl ENDIF + + IF ( imurain == 1 .and. imusnow == 3 ) THEN + rzxs(:) = rzs + ELSEIF ( imurain == imusnow ) THEN + rzxs(:) = 1. + ENDIF ! ENDDO IF ( lhl .gt. 1 ) THEN @@ -9546,13 +10043,37 @@ subroutine nssl_2mom_gs & felscp(mgs) = fels(mgs)*cpi felfcp(mgs) = felf(mgs)*cpi ELSE + + ! equations from appendix in Bryan and Morrison (2012, MWR) + ! note that rw is Rv in the paper, and rd is R. + tmp = qx(mgs,li)+qx(mgs,ls)+qx(mgs,lh) IF ( lhl > 1 ) tmp = tmp + qx(mgs,lhl) cvm = cv+cvv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & +cpigb*(tmp) + + IF ( eqtset == 2 ) THEN ! compact form from treating dT/dt = theta*d(pi)/dt + pi*d(theta)dt and then applied to theta assuming constant pi felvcp(mgs) = (felv(mgs)-rw*temg(mgs))/cvm felscp(mgs) = (fels(mgs)-rw*temg(mgs))/cvm felfcp(mgs) = felf(mgs)/cvm + + ELSE + ! equivalent version that applies separate updates of latent heating to theta and pi, when both are returned. + + cpm = cp+cpv*qx(mgs,lv)+cpl*(qx(mgs,lc)+qx(mgs,lr)) & + +cpigb*(tmp) + rmm=rd+rw*qx(mgs,lv) + + felvcp(mgs) = (felv(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felscp(mgs) = (fels(mgs)*cv/(cp) - rw*temg(mgs)*(1.0-rovcp*cpm/rmm))/cvm + felfcp(mgs) = felf(mgs)*cv/(cp*cvm) + + felvpi(mgs) = pi0(mgs)*rovcp*(felv(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felspi(mgs) = pi0(mgs)*rovcp*(fels(mgs)/(temg(mgs)) - rw*cpm/rmm)/cvm + felfpi(mgs) = pi0(mgs)*rovcp*(felf(mgs)/(cvm*temg(mgs))) + + ENDIF + ENDIF ! fgamw(mgs) = felvcp(mgs)/pi0(mgs) @@ -9676,6 +10197,33 @@ subroutine nssl_2mom_gs & end do + IF ( imurain == 3 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 0.0 + alphamlr = -2.0/3.0 + ELSE + alphashr = xnu(lr) + alphamlr = xnu(lr) + ENDIF +! massfacshr = ( (2. + 3.*(1. +alphashr) )/( 3.*(1. + alphashr) ) )**(1./3.) ! this is the diameter factor +! massfacmlr = ( (2. + 3.*(1. +alphamlr) )/( 3.*(1. + alphamlr) ) )**(1./3.) + massfacshr = ( (2. + 3.*(1. +alphashr) )**3/( 3.*(1. + alphashr) ) ) ! this is the mass or volume factor + massfacmlr = ( (2. + 3.*(1. +alphamlr) )**3/( 3.*(1. + alphamlr) ) ) + ELSEIF ( imurain == 1 ) THEN + IF ( lzr > 1 ) THEN + alphashr = 4.0 + alphamlr = 4.0 + ELSE + alphashr = alphar + alphamlr = alphar + ENDIF +! massfacshr = (3.0 + alphashr)*((3.+alphashr)*(2.+alphashr)*(1. + alphashr) )**(-1./3.) ! this is the diameter factor +! massfacmlr = (3.0 + alphamlr)*((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) )**(-1./3.) + massfacshr = (3.0 + alphashr)**3/((3.+alphashr)*(2.+alphashr)*(1. + alphashr) ) ! this is the mass or volume factor + massfacmlr = (3.0 + alphamlr)**3/((3.+alphamlr)*(2.+alphamlr)*(1. + alphamlr) ) + ENDIF + + ! ! set some values for ice nucleation ! @@ -9706,11 +10254,14 @@ subroutine nssl_2mom_gs & ! & itype1a,itype2a,temcg,infdo,alpha) + infdo = 0 + IF ( io_flag .and. nxtra > 1 ) infdo = 1 + call setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, & & xmas,vtxbar,xdn,xvmn,xvmx,xv,cdx, & & ipconc,ndebug,ngs,nz,kgs,fadvisc, & & cwmasn,cwmasx,cwradn,cnina,cimn,cimx, & - & itype1,itype2,temcg,0,alpha,0,axh,bxh,axhl,bxhl) + & itype1,itype2,temcg,infdo,alpha,0,axh,bxh,axhl,bxhl) IF ( lwsm6 .and. ipconc == 0 ) THEN @@ -9797,7 +10348,6 @@ subroutine nssl_2mom_gs & ! if( ndebug .ge. 0 ) THEN !mpi! write(iunit,*) 'Set depletion max/min1' -! flush(iunit) endif do mgs = 1,ngscnt qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))/dtp ! depletion by all vap. dep to ice. @@ -9818,8 +10368,7 @@ subroutine nssl_2mom_gs & end do ! if( ndebug .ge. 0 ) THEN -!mpi! write(iunit,*) 'Set depletion max/min2' -! flush(iunit) +!mpi! write(0,*) 'Set depletion max/min2' endif do mgs = 1,ngscnt @@ -9867,7 +10416,55 @@ subroutine nssl_2mom_gs & -! calculate maximum mass diameters + + ! default factors between mean volume and maximum mass volume + maxmassfac(lc) = ( (2. + 3.*(1. + xnu(lc)) )**3/( 3.*(1. + xnu(lc)) ) ) + maxmassfac(li) = ( (2. + 3.*(1. + xnu(li)) )**3/( 3.*(1. + xnu(li)) ) ) + + IF ( imurain == 3 ) THEN + maxmassfac(lr) = ( (2. + 3.*(1. + xnu(lr)) )**3/( 3.*(1. + xnu(lr)) ) ) + ELSE + maxmassfac(lr) = (3.0 + alphar)**3/ & + & ((3.+alphar)*(2.+alphar)*(1. + alphar) ) + ENDIF + + IF ( imusnow == 3 ) THEN + maxmassfac(ls) = ( (2. + 3.*(1. + alphas) )**3/( 3.*(1. + alphas) ) ) + ELSE + maxmassfac(ls) = (3.0 + alphas)**3/ & + & ((3.+alphas)*(2.+alphas)*(1. + alphas) ) + ENDIF + + maxmassfac(lh) = (3.0 + alphah)**3/ & + & ((3.+alphah)*(2.+alphah)*(1. + alphah) ) + + IF ( lhl > 1 ) THEN + maxmassfac(lhl) = (3.0 + alphahl)**3/ & + & ((3.+alphahl)*(2.+alphahl)*(1. + alphahl) ) + ENDIF + + + + DO mgs = 1,ngscnt + DO il = lh,lhab ! graupel and hail only + + vshdgs(mgs,il) = vshd ! base value + + IF ( qx(mgs,il) > qxmin(il) ) THEN + + tmpdiam = (shedalp+alpha(mgs,il))*xdia(mgs,il,1)*( xdn(mgs,il)/917. )**(1./3.) ! erm added density factor for equiv. solid ice sphere 10.12.2015 + + IF ( tmpdiam > sheddiam0 ) THEN + vshdgs(mgs,il) = 0.523599*(1.5e-3)**3/massfacshr ! 1.5mm drops from very large ice + ELSEIF ( tmpdiam > sheddiam ) THEN ! intermediate size + vshdgs(mgs,il) = 0.523599*(3.0e-3)**3/massfacshr ! 3.0mm drops from medium-large ice + ELSE +! vshdgs(mgs,il) = Min( xvmx(lr), xv(mgs,il)*xdn(mgs,il)*0.001 ) ! size of drop from melted mean ice particle + vshdgs(mgs,il) = Min( xvmx(lr), 6./pi*xdn(mgs,il)*0.001*tmpdiam**3 )/massfacshr ! size of drop from melted mean ice particle + ENDIF + ENDIF + ENDDO + ENDDO ! ! @@ -9899,14 +10496,14 @@ subroutine nssl_2mom_gs & ! eri(mgs) = 0.0 esi(mgs) = 0.0 - ehi(mgs) = 0.0 - ehli(mgs) = 0.0 + ehi(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn + ehli(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn ! ehxi(mgs) = 0.0 ! ers(mgs) = 0.0 ess(mgs) = 0.0 - ehs(mgs) = 0.0 - ehls(mgs) = 0.0 + ehs(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehs*ehsclsn + ehls(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehls*ehlsclsn ehscnv(mgs) = 0.0 ! ehxs(mgs) = 0.0 ! @@ -9991,6 +10588,7 @@ subroutine nssl_2mom_gs & end if if ( temg(mgs) .ge. 273.15 ) eiw(mgs) = 0.0 end if + ! ! ! @@ -10098,14 +10696,15 @@ subroutine nssl_2mom_gs & ! ! if ( qx(mgs,ls).gt.qxmin(ls) ) then if ( temcg(mgs) < 0.0 ) then - IF ( ipconc .lt. 4 .or. temcg(mgs) < -25. ) THEN + + IF ( ipconc .lt. 4 .or. temcg(mgs) < esstem1 ) THEN ess(mgs) = 0.0 ! ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) ! ess(mgs)=min(0.1,ess(mgs)) ELSE - IF ( temcg(mgs) > -25. .and. temcg(mgs) < -20. ) THEN ! only nonzero for T > -25 - ess(mgs) = ess0*Exp(ess1*(-20.) )*(temcg(mgs) + 25.)/5. ! linear ramp up from zero at -25 to value at -20 - ELSEIF ( temcg(mgs) >= -20.0 ) THEN + IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN ! only nonzero for T > -25 + ess(mgs) = ess0*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/5. ! linear ramp up from zero at -25 to value at -20 + ELSEIF ( temcg(mgs) >= esstem2 ) THEN ess(mgs) = ess0*Exp(ess1*Min( temcg(mgs), 0.0 ) ) ENDIF ENDIF @@ -10117,8 +10716,8 @@ subroutine nssl_2mom_gs & IF ( ipconc < 1 .and. lwsm6 ) THEN esi(mgs) = exp(0.7*min(temcg(mgs),0.0)) ELSE - esi(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0)) - esi(mgs)=min(0.1,esi(mgs)) + esi(mgs) = esi0*exp(0.1*min(temcg(mgs),0.0)) + esi(mgs) = Min(0.1,esi(mgs)) ENDIF IF ( ipconc .le. 3 ) THEN esi(mgs) = exp(0.025*min(temcg(mgs),0.0)) ! LFO @@ -10208,7 +10807,7 @@ subroutine nssl_2mom_gs & ! IF ( qx(mgs,ls).gt.qxmin(ls) ) THEN IF ( ipconc .ge. 4 ) THEN - ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) + ehscnv(mgs) = ehs0*exp(ehs1*min(temcg(mgs),0.0)) ! for 2-moment, used as default for ehs and ehls. Otherwise not used for snow->graupel conversion ELSE ehscnv(mgs) = exp(0.09*min(temcg(mgs),0.0)) ENDIF @@ -10222,7 +10821,8 @@ subroutine nssl_2mom_gs & ehsclsn(mgs) = ehs_collsn ENDIF ! ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh) ) ! shut off qhacs as graupel goes to lowest density - ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to lowest density + ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300. ) ! shut off qhacs as graupel goes to low density + ehs(mgs) = Min(ehs(mgs),ehsmax) end if ENDIF ! @@ -10230,7 +10830,7 @@ subroutine nssl_2mom_gs & ehiclsn(mgs) = ehi_collsn ehi(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0)) ehi(mgs) = Min( ehimax, Max( ehi(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 ) ehi(mgs) = 0.0 + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0 end if @@ -10307,6 +10907,7 @@ subroutine nssl_2mom_gs & if ( qx(mgs,lhl).gt.qxmin(lhl) ) then ehlsclsn(mgs) = ehls_collsn ehls(mgs) = ehscnv(mgs) + ehls(mgs) = Min(ehls(mgs),ehsmax) end if ENDIF ! @@ -10314,7 +10915,7 @@ subroutine nssl_2mom_gs & ehliclsn(mgs) = ehli_collsn ehli(mgs)=eii0hl*exp(eii1hl*min(temcg(mgs),0.0)) ehli(mgs) = Min( ehimax, Max( ehli(mgs), ehimin ) ) - if ( temg(mgs) .gt. 273.15 ) ehli(mgs) = 1.0 + if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehli(mgs) = 0.0 end if @@ -10707,7 +11308,8 @@ subroutine nssl_2mom_gs & rimdn(mgs,lh) = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & & *((0.60)*vtxbar(mgs,lh,1)) & & /(temg(mgs)-273.15))**(rimc2) - rimdn(mgs,lh) = Min( Max( hdnmn, rimc3, rimdn(mgs,lh) ), rimc4 ) +! rimdn(mgs,lh) = Min( Max( hdnmn, rimc3, rimdn(mgs,lh) ), rimc4 ) + rimdn(mgs,lh) = Min( Max( rimc3, rimdn(mgs,lh) ), rimc4 ) ELSE rimdn(mgs,lh) = 1000. ENDIF @@ -10716,7 +11318,7 @@ subroutine nssl_2mom_gs & ENDIF - IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .gt. 0 ) THEN + IF ( qx(mgs,lh) .gt. qxmin(lh) .and. ipelec .ge. 1 ) THEN rarx(mgs,lh) = & & qhacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lh,2)*cx(mgs,lh)) ENDIF @@ -10925,7 +11527,7 @@ subroutine nssl_2mom_gs & ENDIF - IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .gt. 0 ) THEN + IF ( qx(mgs,lhl) .gt. qxmin(lhl) .and. ipelec .ge. 1 ) THEN rarx(mgs,lhl) = & & qhlacw(mgs)*1.0e3*rho0(mgs)/((pi/2.0)*xdia(mgs,lhl,2)*cx(mgs,lhl)) ENDIF @@ -10934,6 +11536,7 @@ subroutine nssl_2mom_gs & end do qhlaci(:) = 0.0 + qhlaci0(:) = 0.0 IF ( lhl .gt. 1 ) THEN do mgs = 1,ngscnt IF ( ehli(mgs) .gt. 0.0 ) THEN @@ -10942,17 +11545,19 @@ subroutine nssl_2mom_gs & vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,li,1))**2 + & & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,li,1) ) - qhlaci(mgs) = 0.25*pi*ehli(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & + qhlaci0(mgs) = 0.25*pi*ehliclsn(mgs)*cx(mgs,lhl)*qx(mgs,li)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & dab1lh(mgs,li,lhl)*xdia(mgs,lhl,3)*xdia(mgs,li,3) + & & da1(li)*xdia(mgs,li,3)**2 ) - qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) ) + ! qhlaci(mgs) = Min( qhlaci(mgs), qimxd(mgs) ) + qhlaci(mgs) = Min( ehli(mgs)*qhlaci0(mgs), qimxd(mgs) ) ENDIF ENDIF end do ENDIF ! qhlacs(:) = 0.0 + qhlacs0(:) = 0.0 IF ( lhl .gt. 1 ) THEN do mgs = 1,ngscnt IF ( ehls(mgs) .gt. 0.0) THEN @@ -10961,13 +11566,12 @@ subroutine nssl_2mom_gs & vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,ls,1))**2 + & & 0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,ls,1) ) - qhlacs(mgs) = 0.25*pi*ehli(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & + qhlacs0(mgs) = 0.25*pi*ehlsclsn(mgs)*cx(mgs,lhl)*qx(mgs,ls)*vt* & & ( da0lhl(mgs)*xdia(mgs,lhl,3)**2 + & & dab1lh(mgs,ls,lhl)*xdia(mgs,lhl,3)*xdia(mgs,ls,3) + & & da1(ls)*xdia(mgs,ls,3)**2 ) - qhlacs(mgs) = Min( qhlacs(mgs), qsmxd(mgs) ) - + qhlacs(mgs) = Min( ehls(mgs)*qhlacs0(mgs), qsmxd(mgs) ) ENDIF ENDIF end do @@ -11042,6 +11646,8 @@ subroutine nssl_2mom_gs & qiacw(mgs) = Min( qiacw(mgs), qxmxd(mgs,lc) ) ENDIF end do + + ! ! if (ndebug .gt. 0 ) write(0,*) 'Collection: cloud ice collects xxxx8' @@ -11230,11 +11836,11 @@ subroutine nssl_2mom_gs & ! ! snow aggregation here - if ( ipconc .ge. 4 .or. ipelec .ge. 100 ) then ! + if ( ipconc .ge. 4 ) then ! do mgs = 1,ngscnt csacs(mgs) = 0.0 - IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 .and. xv(mgs,ls) < 0.25*xvmx(ls) ) THEN - csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) + IF ( qx(mgs,ls) > qxmin(ls) .and. ess(mgs) .gt. 0.0 .and. xv(mgs,ls) < 0.25*xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN + csacs(mgs) = rvt*aa2*ess(mgs)*cx(mgs,ls)**2*xv(mgs,ls) *Min(1.,xdn(mgs,ls)/100. ) ! Min func tries to recalibrate for low diagnosed density csacs(mgs) = min(csacs(mgs),csmxd(mgs)) ENDIF end do @@ -11251,6 +11857,7 @@ subroutine nssl_2mom_gs & ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs)) ENDIF end do + end if if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 18' @@ -11733,6 +12340,7 @@ subroutine nssl_2mom_gs & crfrzs(:) = 0.0 crfrzf(:) = 0.0 zrfrz(:) = 0.0 + zrfrzs(:) = 0.0 zrfrzf(:) = 0.0 qwcnr(:) = 0.0 @@ -11758,7 +12366,8 @@ subroutine nssl_2mom_gs & frach = 1.0d0 - IF ( ibiggopt == 2 .and. imurain == 1 ) THEN +! IF ( ibiggopt == 2 .and. imurain == 1 .and. lzr < 1 ) THEN ! lzr check because results are weird for 3-moment + IF ( ibiggopt == 2 .and. imurain == 1 ) THEN ! ! integrate from Bigg diameter (for given supercooling Ts) to infinity volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 ! Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 @@ -11768,7 +12377,7 @@ subroutine nssl_2mom_gs & ! perhaps should also test that W > V_t_dbigg, i.e., that drops the size of dbigg are being lifted and cooled. - ratio = dbigg/xdia(mgs,lr,1) + ratio = Min(maxratiolu, dbigg/xdia(mgs,lr,1) ) i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) ! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))) @@ -11785,7 +12394,7 @@ subroutine nssl_2mom_gs & ! interpolate along alpha; crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)/dtp - + crfrzf(mgs) = crfrz(mgs) ! interpolate along x, i.e., ratio; tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) tmp2 = qiacrratio(i,jp1) + delx*dqiacrratioinv*(qiacrratio(ip1,jp1) - qiacrratio(i,jp1)) @@ -11793,17 +12402,16 @@ subroutine nssl_2mom_gs & ! interpolate along alpha; qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)/dtp + qrfrzf(mgs) = qrfrz(mgs) - - IF ( dbigg < Min(dfrz,dhmn) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! convert some to snow or ice crystals - ! temporarily store qrfrz and crfrz in snow terms - crfrzs(mgs) = qrfrz(mgs) - qrfrzs(mgs) = crfrz(mgs) - - + IF ( dbigg < Max(dfrz,dhmn) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals + ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone! + crfrzs(mgs) = crfrz(mgs) + qrfrzs(mgs) = qrfrz(mgs) + ! recalculate using dhmn for ratio - ratio = Min(dfrz,dhmn)/xdia(mgs,lr,1) + ratio = Min( maxratiolu, Max(dfrz,dhmn)/xdia(mgs,lr,1) ) i = Min(nqiacrratio,Int(ratio*dqiacrratioinv)) ! j = Int(Max(0.0,Min(15.,alpha(mgs,lr)))) @@ -11816,10 +12424,11 @@ subroutine nssl_2mom_gs & ! interpolate along x, i.e., ratio; tmp1 = ciacrratio(i,j) + delx*dqiacrratioinv*(ciacrratio(ip1,j) - ciacrratio(i,j)) tmp2 = ciacrratio(i,jp1) + delx*dqiacrratioinv*(ciacrratio(ip1,jp1) - ciacrratio(i,jp1)) - + + ! interpolate along alpha; - crfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)/dtp + crfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*cx(mgs,lr)/dtp ! interpolate along x, i.e., ratio; tmp1 = qiacrratio(i,j) + delx*dqiacrratioinv*(qiacrratio(ip1,j) - qiacrratio(i,j)) @@ -11827,26 +12436,31 @@ subroutine nssl_2mom_gs & ! interpolate along alpha; - qrfrz(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)/dtp + qrfrzf(mgs) = (tmp1 + dely*dqiacralphainv*(tmp2 - tmp1))*qx(mgs,lr)/dtp ! now subtract off the difference - crfrzs(mgs) = crfrzs(mgs) - crfrz(mgs) - qrfrzs(mgs) = qrfrzs(mgs) - qrfrz(mgs) + crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs) + qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs) ELSE crfrzs(mgs) = 0.0 qrfrzs(mgs) = 0.0 - ENDIF + zrfrzs(mgs) = 0.0 + ENDIF ! } - IF ( (qrfrzs(mgs) + qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN - fac = ( qrfrzs(mgs) + qrfrz(mgs) )*dtp/qx(mgs,lr) + IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN + fac = ( qrfrz(mgs) )*dtp/qx(mgs,lr) qrfrz(mgs) = fac*qrfrz(mgs) qrfrzs(mgs) = fac*qrfrzs(mgs) qrfrzf(mgs) = fac*qrfrzf(mgs) crfrz(mgs) = fac*crfrz(mgs) crfrzs(mgs) = fac*crfrzs(mgs) crfrzf(mgs) = fac*crfrzf(mgs) + IF ( lzr > 1 ) THEN + zrfrz(mgs) = fac*zrfrz(mgs) + zrfrzf(mgs) = fac*zrfrzf(mgs) + ENDIF ENDIF ! IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN ! fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr) @@ -11854,11 +12468,11 @@ subroutine nssl_2mom_gs & ! crfrzs(mgs) = fac*crfrzs(mgs) ! ENDIF - qrfrzf(mgs) = qrfrz(mgs) - crfrzf(mgs) = crfrz(mgs) +! qrfrzf(mgs) = qrfrz(mgs) +! crfrzf(mgs) = crfrz(mgs) - qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs) - crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs) + ! qrfrz(mgs) = qrfrzf(mgs) + qrfrzs(mgs) + ! crfrz(mgs) = crfrzf(mgs) + crfrzs(mgs) ELSE ! ibiggopt == 1 @@ -11907,11 +12521,11 @@ subroutine nssl_2mom_gs & - IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN + IF ( crfrz(mgs) .gt. qxmin(lh) ) THEN !{ ! IF ( xdia(mgs,lr,1) .lt. 200.e-6 ) THEN ! IF ( xv(mgs,lr) .lt. xvmn(lh) ) THEN - IF ( ibiggsnow == 1 .or. ibiggsnow == 3 ) THEN + IF ( (ibiggsnow == 1 .or. ibiggsnow == 3 ) .and. ibiggopt /= 2 ) THEN xvfrz = rho0(mgs)*qrfrz(mgs)/(crfrz(mgs)*900.) ! mean volume of frozen drops; 900. for frozen drop density frach = 0.5 *(1. + Tanh(0.2e12 *( xvfrz - 1.15*xvmn(lh)))) @@ -11925,21 +12539,21 @@ subroutine nssl_2mom_gs & qrfrzs(mgs) = qrfrz(mgs) crfrzs(mgs) = crfrz(mgs) ! *rzxh(mgs) ELSE -! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)/dtp ) ! cxmxd(mgs,lr) ) -! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)/dtp ) ! qxmxd(mgs,lr) ) +! crfrz(mgs) = Min( crfrz(mgs), 0.1*cx(mgs,lr)/dtp ) ! cxmxd(mgs,lr) +! qrfrz(mgs) = Min( qrfrz(mgs), 0.1*qx(mgs,lr)/dtp ) ! qxmxd(mgs,lr) qrfrzf(mgs) = frach*qrfrz(mgs) ! crfrzf(mgs) = Min( qrfrz(mgs)*rho0(mgs)/(xdn(mgs,lh)*vgra), crfrz(mgs) ) IF ( ibfr .le. 1 ) THEN - crfrzf(mgs) = frach*Min(crfrz(mgs), dble(qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs)) ) ! rzxh(mgs)*crfrz(mgs) + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*1.0*vr1mm*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) ELSEIF ( ibfr .eq. 5 ) THEN - crfrzf(mgs) = frach*Min(crfrz(mgs), dble(qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs)) )*rzxh(mgs) !*crfrz(mgs) + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) )*rzxh(mgs) !*crfrz(mgs) ELSEIF ( ibfr .eq. 2 ) THEN - crfrzf(mgs) = frach*Min(crfrz(mgs), dble(qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs)) ) ! rzxh(mgs)*crfrz(mgs) + crfrzf(mgs) = frach*Min(crfrz(mgs), qrfrz(mgs)/(bfnu*vfrz*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) ELSEIF ( ibfr .eq. 6 ) THEN - crfrzf(mgs) = frach*Max(crfrz(mgs), dble(qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs)) ) ! rzxh(mgs)*crfrz(mgs) + crfrzf(mgs) = frach*Max(crfrz(mgs), qrfrz(mgs)/(bfnu*9.*xv(mgs,lr)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) ELSE crfrzf(mgs) = frach*crfrz(mgs) - ENDIF + ENDIF ! crfrzf(mgs) = Min(crfrz(mgs), qrfrz(mgs)/(bfnu*xvmn(lh)*1000.0)*rho0(mgs) ) ! rzxh(mgs)*crfrz(mgs) ! IF ( lz(lr) > 1 .and. lz(lh) > 1 ) THEN ! crfrzf(mgs) = crfrz(mgs) @@ -11950,7 +12564,7 @@ subroutine nssl_2mom_gs & ELSE crfrz(mgs) = 0.0 qrfrz(mgs) = 0.0 - ENDIF + ENDIF !} ENDIF ! ibiggopt @@ -12046,15 +12660,16 @@ subroutine nssl_2mom_gs & end if ENDIF ! - if ( xplate(mgs) .eq. 1 ) then - qwfrzp(mgs) = qwfrz(mgs) - cwfrzp(mgs) = cwfrz(mgs) - end if -! - if ( xcolmn(mgs) .eq. 1 ) then - qwfrzc(mgs) = qwfrz(mgs) - cwfrzc(mgs) = cwfrz(mgs) - end if + if ( xplate(mgs) .eq. 1 ) then + qwfrzp(mgs) = qwfrz(mgs) + cwfrzp(mgs) = cwfrz(mgs) + end if +! + if ( xcolmn(mgs) .eq. 1 ) then + qwfrzc(mgs) = qwfrz(mgs) + cwfrzc(mgs) = cwfrz(mgs) + end if + ! ! qwfrzp(mgs) = 0.0 ! qwfrzc(mgs) = qwfrz(mgs) @@ -12080,7 +12695,6 @@ subroutine nssl_2mom_gs & qwctfzc(mgs) = 0.0 cwctfzp(mgs) = 0.0 qwctfzp(mgs) = 0.0 - IF ( icfn .ge. 1 ) THEN IF ( temg(mgs) .lt. 271.15 .and. qx(mgs,lc) .gt. qxmin(lc)) THEN @@ -12149,6 +12763,7 @@ subroutine nssl_2mom_gs & qwctfzc(mgs) = qwctfz(mgs) cwctfzc(mgs) = cwctfz(mgs) end if + ! ! qwctfzc(mgs) = qwctfz(mgs) ! qwctfzp(mgs) = 0.0 @@ -12313,6 +12928,8 @@ subroutine nssl_2mom_gs & ELSE civent(mgs) = 0.0 ENDIF + + ENDIF ! icond .eq. 1 end do @@ -12611,6 +13228,11 @@ subroutine nssl_2mom_gs & & , 0.0 ) ELSEIF ( ibinhmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + write(0,*) 'ibinhmlr = 1 not available for 2-moment' + STOP + + ELSEIF ( ibinhmlr == 2 ) THEN + ENDIF @@ -12638,6 +13260,9 @@ subroutine nssl_2mom_gs & ELSEIF ( ibinhlmlr == 1 ) THEN ! use incomplete gamma functions to approximate the bin results + + ELSEIF ( ibinhlmlr == -1 ) THEN ! OLD VERSION use incomplete gamma functions to approximate the bin results + ENDIF ! ibinhlmlr @@ -12659,8 +13284,8 @@ subroutine nssl_2mom_gs & ! qimlr(mgs) = max( qimlr(mgs), -qimxd(mgs) ) ! qsmlr(mgs) = max( qsmlr(mgs), -qsmxd(mgs) ) ! erm 5/10/2007 changed to next line: - if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)/dtp ) ) - if ( .not. mixedphase ) qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.5*qx(mgs,lh)/dtp ) ) + if ( .not. mixedphase ) qsmlr(mgs) = max( qsmlr(mgs), Min( -qsmxd(mgs), -0.7*qx(mgs,ls)*dtpinv ) ) + if ( .not. mixedphase ) qhmlr(mgs) = max( qhmlr(mgs), Min( -qhmxd(mgs), -0.5*qx(mgs,lh)*dtpinv ) ) ! qhmlr(mgs) = max( max( qhmlr(mgs), -qhmxd(mgs) ) , -0.5*qx(mgs,lh)/dtp ) !limits to 1/2 qh or max depletion qhmlh(mgs) = 0. @@ -12678,39 +13303,76 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt cimlr(mgs) = (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qimlr(mgs) + IF ( .not. mixedphase ) THEN !{ + IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN +! csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm) + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ELSEIF ( qx(mgs,ls) > qxmin(ls) ) THEN + csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs) + ENDIF - IF ( .not. mixedphase ) THEN - IF ( xdia(mgs,ls,1) .gt. 1.e-6 .and. -qsmlr(mgs) .ge. 0.5*qxmin(ls) .and. ipconc .ge. 4 ) THEN -! csmlr(mgs) = rho0(mgs)*qsmlr(mgs)/(xv(mgs,ls)*rhosm) - csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsmlr(mgs) - ELSE - csmlr(mgs) = (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsmlr(mgs) - ENDIF +! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN +! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail +! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) ) +! ELSE + IF ( ibinhmlr == 0 ) THEN + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) + IF ( imltshddmr == 3 .and. qhmlr(mgs) < -qxmin(lh) ) THEN + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! + ! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam + ! chmlr(mgs) = 0.0 + ! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller + tmp = 1. + alpha(mgs,lh) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami -! IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN -! chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3) ! out of hail -! chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) ) -! ELSE - chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) -! ENDIF + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lh,1) ) + + x = gamxinfdp(2. + alpha(mgs,lh), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lh) + 0.5*bxh(mgs), ratio)/g1palp + hwvent1 = 0.78*x + y*hwventy(mgs) - IF ( chmlr(mgs) < 0.0 ) THEN + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lh)*hwvent1*xdia(mgs,lh,1), 0.0 ) + + chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*(qhmlr(mgs) - qhlmlr1) + + + ENDIF +! IF ( igs(mgs) == 40 ) THEN +! write(0,*) 'is this running? chmlr = ',kgs(mgs), chmlr(mgs) +! ENDIF + ENDIF +! ENDIF + + + + IF ( chmlr(mgs) < 0.0 .and. ibinhmlr < 1) THEN ! { already done if ibinhmlr > 0 + IF ( ibinhmlr == 0 ) THEN IF ( ihmlt .eq. 1 ) THEN chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain ELSEIF ( ihmlt .eq. 2 ) THEN IF ( xv(mgs,lh) .gt. 0.0 .and. chmlr(mgs) .lt. 0.0 ) THEN ! chmlrr(mgs) = Min( chmlr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lh)*xv(mgs,lh)) ) ! into rain ! guess what, this is the same as chmlr: rho0*qhmlr/xmas(lh) --> cx/qx = rho0/xmas - IF(imltshddmr > 0) THEN + IF(imltshddmr == 1) THEN ! DTD: If Dmg < sheddiam, then assume complete melting into ! maximal raindrop. Between sheddiam and sheddiam0 mm, linearly ramp down to a 3 mm shed drop tmp = -rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! Min of Maximum raindrop size/mean hail size tmp2 = -rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter - chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) + + chmlrr(mgs) = tmp*(sheddiam0-xdia(mgs,lh,3))/(sheddiam0-sheddiam)+tmp2*(xdia(mgs,lh,3)-sheddiam)/(sheddiam0-sheddiam) ! old version chmlrr(mgs) = -Max(tmp,Min(tmp2,chmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain ELSE ! Old method chmlrr(mgs) = rho0(mgs)*qhmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lh)*xv(mgs,lh))) ! into rain ENDIF @@ -12720,29 +13382,67 @@ subroutine nssl_2mom_gs & ELSEIF ( ihmlt .eq. 0 ) THEN chmlrr(mgs) = chmlr(mgs) ENDIF + + ELSE ! ibinhmlr < 0? Already have an outer IF test for ibinhmlr < 1 + chmlrr(mgs) = Min( chmlrr(mgs), rho0(mgs)*qhmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF - ENDIF ! chmlr(mgs) < 0.0 + ENDIF ! } ( chmlr(mgs) < 0.0 .and. ibinhmlr < 1) IF ( lhl .gt. 1 .and. lhlw < 1 .and. .not. mixedphase .and. qhlmlr(mgs) < 0.0 ) THEN ! { + IF ( ibinhlmlr == 0 ) THEN ! IF ( xdia(mgs,lhl,1) .gt. 1.e-6 .and. Abs(qhlmlr(mgs)) .ge. qxmin(lhl) ) THEN ! chlmlr(mgs) = rho0(mgs)*qhlmlr(mgs)/(pi*xdn(mgs,lhl)*xdia(mgs,lhl,1)**3) ! out of hail ! chlmlr(mgs) = Max( chlmlr(mgs), -cxmxd(mgs,lhl) ) ! ELSE chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlmlr(mgs) + IF ( imltshddmr == 3 .and. qhlmlr(mgs) < -qxmin(lhl) ) THEN +! IF ( .false. .and. imltshddmr == 3 ) THEN +! tmpdiam = (shedalp+alpha(mgs,lhl))*xdia(mgs,lhl,1) +! +! IF ( tmpdiam > sheddiam ) THEN ! let size get smaller until it reaches sheddiam +! chlmlr(mgs) = 0.0 +! ENDIF + + ! test to remove the part of the melting associated with large ice particles so they get smaller +! + tmp = 1. + alpha(mgs,lhl) + i = Int(dgami*(tmp)) + del = tmp - dgam*i + g1palp = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami + + ratio = Min( maxratiolu, mltdiam1/xdia(mgs,lhl,1) ) + + x = gamxinfdp(2. + alpha(mgs,lhl), ratio)/g1palp + y = gamxinfdp(2.5 + alpha(mgs,lhl) + 0.5*bxhl(mgs), ratio)/g1palp + + hwvent1 = 0.78*x + y*hlventy(mgs) + + qhlmlr1 = min( fmlt1(mgs)*cx(mgs,lhl)*hwvent1*xdia(mgs,lhl,1), 0.0 ) + + chlmlr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*Min(0.0, qhlmlr(mgs) - qhlmlr1) + + ENDIF ! ENDIF + ENDIF + IF ( ibinhlmlr == 0 ) THEN !{ IF ( ihmlt .eq. 1 ) THEN chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vmlt) ) ! into rain ELSEIF ( ihmlt .eq. 2 ) THEN IF ( xv(mgs,lhl) .gt. 0.0 .and. chlmlr(mgs) .lt. 0.0 ) THEN ! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain ! chlmlrr(mgs) = Min( chlmlr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lhl)*xv(mgs,lhl)) ) ! into rain - IF(imltshddmr > 0) THEN + IF(imltshddmr == 1 ) THEN tmp = -rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! Min of Maximum raindrop size/mean hail size tmp2 = -rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vr3mm) ! conc. change for a 3 mm mean drop diameter chlmlrr(mgs) = tmp*(20.e-3-xdia(mgs,lhl,3))/(20.e-3-sheddiam)+tmp2*(xdia(mgs,lhl,3)-sheddiam)/(20.e-3-sheddiam) chlmlrr(mgs) = -Max(tmp,Min(tmp2,chlmlrr(mgs))) + ELSEIF ( imltshddmr == 2 .or. imltshddmr == 3 ) THEN + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain ELSE chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain ENDIF @@ -12752,10 +13452,14 @@ subroutine nssl_2mom_gs & ELSEIF ( ihmlt .eq. 0 ) THEN chlmlrr(mgs) = chlmlr(mgs) ENDIF + + ELSE ! } { ibinhlmlr > 0 + chlmlrr(mgs) = Min( chlmlrr(mgs), rho0(mgs)*qhlmlr(mgs)/(xdn(mgs,lr)*xvmx(lr)) ) ! into rain + ENDIF !} ENDIF ! } - ENDIF ! .not. mixedphase + ENDIF ! }.not. mixedphase ! 10ice versions: ! chmlr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhmlr(mgs) @@ -12809,14 +13513,18 @@ subroutine nssl_2mom_gs & qsdsv(mgs) = 0.0 ENDIF qhdsv(mgs) = & - & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs) + & fvds(mgs)*cx(mgs,lh)*hwvent(mgs)*hwcap(mgs)*depfac - IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs) + IF ( lhl .gt. 1 ) qhldsv(mgs) = fvds(mgs)*cx(mgs,lhl)*hlvent(mgs)*hlcap(mgs)*depfac ! ! end do ! do mgs = 1,ngscnt + qisbv(mgs) = 0.0 + qssbv(mgs) = 0.0 + qidpv(mgs) = 0.0 + qsdpv(mgs) = 0.0 IF ( icond .eq. 1 .or. temg(mgs) .le. tfrh & & .or. (qx(mgs,lr) .le. qxmin(lr) .and. qx(mgs,lc) .le. qxmin(lc)) ) THEN ! qisbv(mgs) = max( min(qidsv(mgs), 0.0), -qimxd(mgs) ) @@ -12844,7 +13552,7 @@ subroutine nssl_2mom_gs & qhlsbv(mgs) = max( min(qhldsv(mgs), 0.0), -qxmxd(mgs,lhl) ) qhldpv(mgs) = Max(qhldsv(mgs), 0.0) ENDIF - + temp1 = qidpv(mgs) + qsdpv(mgs) + qhdpv(mgs) + qhldpv(mgs) IF ( temp1 .gt. qvimxd(mgs) ) THEN @@ -12874,13 +13582,14 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 ) chlsbv(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlsbv(mgs) csdpv(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*qsdpv(mgs) cidpv(mgs) = 0.0 ! (cx(mgs,li)/(qx(mgs,li)+1.e-20))*qidpv(mgs) + cisdpv(mgs) = 0.0 chdpv(mgs) = 0.0 ! (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhdpv(mgs) chldpv(mgs) = 0.0 end do end if ! -! Aggregation of crystals +! Aggregation or size conversion of small crystals to snow ! if (ndebug .gt. 0 ) write(0,*) 'conc 29a' do mgs = 1,ngscnt @@ -12937,13 +13646,13 @@ subroutine nssl_2mom_gs & ELSEIF ( ipconc < 4 ) THEN ! LFO IF ( lwsm6 ) THEN qimax = rhoinv(mgs)*roqimax - qscni(mgs) = Min(0.9d0*qx(mgs,li), Max( 0.d0, (qx(mgs,li) - qimax)*dtpinv ) ) + qscni(mgs) = Min(0.9*qx(mgs,li), Max( 0., (qx(mgs,li) - qimax)*dtpinv ) ) ELSE qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0) qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li)) ENDIF else ! 10-ice version - if ( qx(mgs,li) .gt. qxmin(li) ) then + if ( iscni > 0 .and. qx(mgs,li) .gt. qxmin(li) ) then qscni(mgs) = & & pi*rho0(mgs)*((0.25)/(6.0)) & & *eii(mgs)*(qx(mgs,li)**2)*(xdia(mgs,li,2)) & @@ -12978,6 +13687,8 @@ subroutine nssl_2mom_gs & ! set wet growth and shedding ! do mgs = 1,ngscnt + + IF ( temg(mgs) < tfr ) THEN ! ! qswet(mgs) = ! > ( xdia(mgs,ls,1)*swvent(mgs)*cx(mgs,ls)*fwet1(mgs) @@ -13001,6 +13712,13 @@ subroutine nssl_2mom_gs & & + fwet2(mgs)*(qhlaci(mgs) + qhlacs(mgs)) ) qhlwet(mgs) = max( 0.0, qhlwet(mgs)) ENDIF + + ELSE + + qhwet(mgs) = qhdry(mgs) + qhlwet(mgs) = qhldry(mgs) + + ENDIF ! ! qhlwet(mgs) = qhldry(mgs) @@ -13084,7 +13802,19 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt csshr(mgs) = 0.0 ! (cx(mgs,ls)/(qx(mgs,ls)+1.e-20))*Min(0.0,qsshr(mgs)) - chshr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) + ! why is there a number loss for graupel for shedding? NEED TO CHECK THIS + ! chshr(mgs) = (cx(mgs,lh)/(qx(mgs,lh)+1.e-20))*qhshr(mgs) + ! IF ( temg(mgs) < tfr ) chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding + + chshr(mgs) = 0.0 ! no change to graupel number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chshrr(mgs) = rho0(mgs)*qhshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lh)) ! into rain + + IF ( .false. ) THEN IF ( temg(mgs) < tfr ) THEN chshrr(mgs) = Min( chshr(mgs), rho0(mgs)*qhshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding ELSE @@ -13100,10 +13830,25 @@ subroutine nssl_2mom_gs & ! chlmlrr(mgs) = rho0(mgs)*qhlmlr(mgs)/(Min(xdn(mgs,lr)*xvmx(lr), xdn(mgs,lhl)*xv(mgs,lhl))) ! into rain ENDIF ENDIF + ENDIF + + chlshr(mgs) = 0.0 chlshrr(mgs) = 0.0 IF ( lhl .gt. 1 ) THEN - chlshr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) +! chlshr(mgs) = (cx(mgs,lhl)/(qx(mgs,lhl)+1.e-20))*qhlshr(mgs) + + + chlshr(mgs) = 0.0 ! no change to hail number concentration for wet-growth shedding + + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + ! Base the drop size on the shedding regime + ! 8/26/2015 ERM updated to use shedalp and tmpdiam + ! tmpdiam = (shedalp+alpha(mgs,lh))*xdia(mgs,lh,1) + chlshrr(mgs) = rho0(mgs)*qhlshr(mgs)/(xdn(mgs,lr)*vshdgs(mgs,lhl)) ! into rain + + + IF ( .false. ) THEN IF ( temg(mgs) < tfr ) THEN chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vshd) ) ! maximum of dshd from shedding ! chlshrr(mgs) = Min( chlshr(mgs), rho0(mgs)*qhlshr(mgs)/(xdn0(lr)*vr1mm) ) ! maximum of 1mm drops from shedding @@ -13121,6 +13866,9 @@ subroutine nssl_2mom_gs & ENDIF ENDIF ENDIF + + ENDIF ! ( lhl > 1 ) + end do end if @@ -13211,10 +13959,10 @@ subroutine nssl_2mom_gs & ENDIF IF ( ehs(mgs) .gt. 0.0 ) THEN ! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)/ehs(mgs)) ! effectively sets collection eff to 1 - qhacs(mgs) = qhacs0(mgs) !/ehs(mgs) ! divide out the collection efficiency - chacs(mgs) = chacs0(mgs) !/ehs(mgs) ! divide out the collection efficiency - ehs(mgs) = 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it - ! qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)*ehs(mgs)) ! plug it back in + qhacs(mgs) = Min(qsmxd(mgs),qhacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + chacs(mgs) = Min(csmxd(mgs),chacs0(mgs)) !/ehs(mgs) ! divide out the collection efficiency + ehs(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it + qhacs(mgs) = Min(qsmxd(mgs),qhacs(mgs)) ! plug it back in ENDIF ! be sure to catch particles with wet surfaces but not in wet growth to turn off Hallett-Mossop @@ -13277,11 +14025,20 @@ subroutine nssl_2mom_gs & ENDIF IF ( ehli(mgs) .gt. 0.0 ) THEN - qhlaci(mgs) = Min(qimxd(mgs),qhlaci(mgs)/ehli(mgs)) + qhlaci(mgs) = Min(qimxd(mgs),qhlaci0(mgs)) ! effectively sets collection eff to 1 + chlaci(mgs) = Min(cimxd(mgs),chlaci0(mgs)) ! effectively sets collection eff to 1 ENDIF + +! IF ( ehls(mgs) .gt. 0.0 ) THEN +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs)) +! ENDIF IF ( ehls(mgs) .gt. 0.0 ) THEN - qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)/ehls(mgs)) + qhlacs(mgs) = Min(qsmxd(mgs),qhlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + chlacs(mgs) = Min(csmxd(mgs),chlacs0(mgs)) !/ehls(mgs) ! divide out the collection efficiency + ehls(mgs) = ehsmax ! 1.0 ! min(ehsfrac*ehs(mgs),ehsmax) ! modify it +! qhlacs(mgs) = Min(qsmxd(mgs),qhlacs(mgs)) ! plug it back in ENDIF + ! qhlwet(mgs) = 1.0 @@ -13332,9 +14089,38 @@ subroutine nssl_2mom_gs & vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r ENDIF + ELSEIF ( iglcnvi == 3 ) THEN + + IF ( temg(mgs) .lt. 273.0 .and. qiacw(mgs)*dtp > 2.*qxmin(lh) .and. gamice73fac*xmas(mgs,li) > xdnmn(lh)*xvmn(lh) ) THEN + + + tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & + & *((0.60)*vtxbar(mgs,li,1)) & + & /(temg(mgs)-273.15))**(rimc2) + tmp = Min( Max( rimc3, tmp ), 900.0 ) + + ! Assume that half the volume of the embryo is rime with density 'tmp' + ! m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2 + ! V = 2*m/(rhoi + rhorime) + +! write(0,*) 'rime dens = ',tmp + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp .ge. xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,li) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcni(mgs) = 0.5*qiacw(mgs) + chcni(mgs) = qhcni(mgs)/(gamice73fac*xmas(mgs,li)) + chcnih(mgs) = Min(chcni(mgs), rho0(mgs)*qhcni(mgs)/(r*xvmn(lh)) ) +! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) + vhcni(mgs) = rho0(mgs)*qhcni(mgs)/r + ENDIF + ENDIF + ENDIF ENDIF @@ -13495,6 +14281,7 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 5 ) THEN + ! test attempt at converting graupel to snow when not riming but growing by deposition IF ( temg(mgs) < tfr .and. qx(mgs,lh) .gt. qxmin(lh) .and. qhdpv(mgs) > qxmin(lh)*dtpinv & & .and. qhacw(mgs) < qxmin(lh)*dtpinv ) THEN IF ( xdn(mgs,lh) < 290. ) THEN @@ -13546,7 +14333,8 @@ subroutine nssl_2mom_gs & ELSEIF ( iglcnvs .ge. 2 ) THEN ! treat like ice crystals, i.e., check for rime density (ERM) - IF ( temg(mgs) .lt. 273.0 .and. qsacw(mgs) - qsdpv(mgs) .gt. 0.0 ) THEN + IF ( temg(mgs) .lt. 273.0 .and. ( qsacw(mgs) - qsdpv(mgs) .gt. 0.0 .or. & + ( iglcnvs >= 3 .and. qsacw(mgs) > 2.*qxmin(lh) .and. gamsnow73fac*xmas(mgs,ls) > xdnmn(lh)*xvmn(lh) ) ) ) THEN tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1)) & @@ -13560,7 +14348,8 @@ subroutine nssl_2mom_gs & ! write(0,*) 'rime dens = ',tmp - IF ( tmp .ge. 200.0 .or. iglcnvs >= 3 ) THEN + IF ( iglcnvs == 2 ) THEN + IF ( tmp .ge. 200.0 ) THEN r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) ! r = Max( r, 400. ) qhcns(mgs) = (qsacw(mgs) - qsdpv(mgs)) @@ -13570,6 +14359,22 @@ subroutine nssl_2mom_gs & ! vhcni(mgs) = rho0(mgs)*2.0*qhcni(mgs)/(xdn(mgs,li) + tmp) vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r ENDIF + + ELSEIF ( iglcnvs == 3 ) THEN + + ! convert to particles with the mass of the mass-weighted diameter + ! massofmwr = gamice73fac*xmas(mgs,li) + + IF ( tmp .ge. xdnmn(lh) ) THEN + r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) ) +! r = Max( r, 400. ) + qhcns(mgs) = 0.5*qsacw(mgs) + chcns(mgs) = qhcns(mgs)/(gamsnow73fac*xmas(mgs,ls)) + chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) ) + vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r + ENDIF + + ENDIF ENDIF @@ -13964,11 +14769,12 @@ subroutine nssl_2mom_gs & cicint(mgs) = 0.0 qipipnt(mgs) = 0.0 cipint(mgs) = 0.0 - IF ( icenucopt == 1 ) THEN + ccitmp = 0.0 + IF ( icenucopt == 1 .or. icenucopt == -10 .or. icenucopt == -11 ) THEN if ( ( temg(mgs) .lt. 268.15 .or. & ! : ( imeyers5 .and. temg(mgs) .lt. 273.0) ) .and. & & ( imeyers5 .and. temg(mgs) .lt. 272.0 .and. temgkm2(mgs) .lt. tfr) ) .and. & - & ciintmx .gt. (cx(mgs,li)) & + & ciintmx .gt. (cx(mgs,li)+ccitmp) & ! : .and. cninm(mgs) .gt. 0. & & ) then fiinit(mgs) = (felv(mgs)**2)/(cp*rw) @@ -13995,29 +14801,40 @@ subroutine nssl_2mom_gs & ! ! ciintmx = 1.e9 ! ciintmx = 1.e9 - IF ( lcin > 1 ) THEN - ciint(mgs) = Min(ciint(mgs), ccin(mgs)) - ccin(mgs) = ccin(mgs) - ciint(mgs) - qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) - ELSEIF ( lcina > 1 ) THEN - ciint(mgs) = Max(0.0, Min( ciint(mgs), Min( cnina(mgs), ciintmx ) - cina(mgs) )) - qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + IF ( icenucopt /= -10 ) THEN + + IF ( lcin > 1 ) THEN + ciint(mgs) = Min(ciint(mgs), ccin(mgs)) + ccin(mgs) = ccin(mgs) - ciint(mgs) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ELSEIF ( lcina > 1 ) THEN + ciint(mgs) = Max(0.0, Min( ciint(mgs), Min( cnina(mgs), ciintmx ) - cina(mgs) )) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) - ELSEIF ( ciint(mgs) .gt. (ciintmx - (cx(mgs,li)))) THEN - ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) ) - qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + ELSEIF ( icenucopt == 1 .and. ciint(mgs) .gt. Max(0.0, ciintmx - cx(mgs,li) - ccitmp )*dtpinv ) THEN + ciint(mgs) = Max(0.0, ciintmx - (cx(mgs,li)) )*dtpinv + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ELSEIF ( icenucopt == -11 .and. dtp*ciint(mgs) .gt. ( cnina(mgs) - (cx(mgs,li) - ccitmp))) THEN + ciint(mgs) = Max(0.0, cnina(mgs) - (cx(mgs,li)+ccitmp)*dtpinv ) + qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) + + ENDIF ENDIF + end if endif ELSEIF ( icenucopt == 2 .or. icenucopt == -1 .or. icenucopt == -2 ) THEN - IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 0.999 ) .or. ssi(mgs) > 1.05 ) THEN + IF ( ( temg(mgs) .lt. 268.15 .and. ssw(mgs) > 1.0 ) .or. ssi(mgs) > 1.25 ) THEN IF ( lcin > 1 ) THEN ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) - ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate ELSE - ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) ) + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv ENDIF qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) @@ -14033,9 +14850,11 @@ subroutine nssl_2mom_gs & IF ( temg(mgs) .lt. 268.15 ) THEN IF ( lcin > 1 ) THEN ciint(mgs) = Min(cnina(mgs), ccin(mgs)) + ciint(mgs) = Min( ciint(mgs), Max(0.0, ciintmx - (cx(mgs,li) + ccitmp) ) ) ! do not initiate ice beyond concentration of ciintmx ccin(mgs) = ccin(mgs) - ciint(mgs) + ciint(mgs) = ciint(mgs)*dtpinv ! convert total initiation to a rate ELSE - ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) ) + ciint(mgs) = Max( 0.0, cnina(mgs) - cina(mgs) )*dtpinv ENDIF qiint(mgs) = ciint(mgs)*cmassin/rho0(mgs) ENDIF @@ -14123,6 +14942,8 @@ subroutine nssl_2mom_gs & pccii(:) = 0.0 pccin(:) = 0.0 pccid(:) = 0.0 + pcisi(:) = 0.0 + pcisd(:) = 0.0 pcrwi(:) = 0.0 pcrwd(:) = 0.0 pcswi(:) = 0.0 @@ -14140,16 +14961,14 @@ subroutine nssl_2mom_gs & IF ( warmonly < 0.5 ) THEN do mgs = 1,ngscnt pccii(mgs) = & - & il5(mgs)*cicint(mgs) & -! > +il5(mgs)*cidpv(mgs) -! > +il5(mgs)*(cwacii(mgs)) & + & il5(mgs)*cicint(mgs)*(1. - ffrzs) & & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & - & +cicichr(mgs)) & + & +cicichr(mgs))*(1. - ffrzs) & & +chmul1(mgs) & & +chlmul1(mgs) & & + csplinter(mgs) + csplinter2(mgs) & -! > + nsplinter*(crfrzf(mgs) + crfrz(mgs)) & +csmul(mgs) +! > + nsplinter*(crfrzf(mgs) + crfrz(mgs)) pccid(mgs) = & & il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs) & & -craci(mgs) & @@ -14160,6 +14979,8 @@ subroutine nssl_2mom_gs & & -(1.-il5(mgs))*cimlr(mgs) pccin(mgs) = ciint(mgs) + + end do ELSEIF ( warmonly < 0.8 ) THEN do mgs = 1,ngscnt @@ -14169,9 +14990,9 @@ subroutine nssl_2mom_gs & ! qicicnt(mgs) = 0.0 pccii(mgs) = & - & il5(mgs)*cicint(mgs) & + & il5(mgs)*cicint(mgs)*(1. - ffrzs) & & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & - & +cicichr(mgs)) & + & +cicichr(mgs))*(1. - ffrzs) & & +chmul1(mgs) & & +chlmul1(mgs) & & + csplinter(mgs) + csplinter2(mgs) & @@ -14250,6 +15071,7 @@ subroutine nssl_2mom_gs & cwctfzp(mgs) = frac*cwctfzp(mgs) cwfrzc(mgs) = frac*cwfrzc(mgs) cwctfzc(mgs) = frac*cwctfzc(mgs) + cwctfz(mgs) = frac*cwctfz(mgs) cracw(mgs) = frac*cracw(mgs) csacw(mgs) = frac*csacw(mgs) chacw(mgs) = frac*chacw(mgs) @@ -14279,7 +15101,7 @@ subroutine nssl_2mom_gs & & +(1-il5(mgs))*( & & -chmlrr(mgs)/rzxh(mgs) & & -chlmlrr(mgs)/rzxhl(mgs) & - & -csmlr(mgs) & + & -csmlr(mgs)/rzxs(mgs) & & - cimlr(mgs) ) & & -crshr(mgs) !null at this point when wet snow/graupel included pcrwd(mgs) = & @@ -14359,8 +15181,11 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt pcswi(mgs) = & & il5(mgs)*(cscnis(mgs) + cscnvis(mgs) ) & + & + il5(mgs)*cicint(mgs)*ffrzs & & + ifrzs*crfrzs(mgs) & & + ifrzs*ciacrs(mgs) & + & +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs) & + & +cicichr(mgs))*ffrzs & & + cscnh(mgs) pcswd(mgs) = & ! : cracs(mgs) & @@ -14371,6 +15196,25 @@ subroutine nssl_2mom_gs & & + cssbv(mgs) & & - csacs(mgs) + frac = 0.0 + IF ( imixedphase == 0 ) THEN + IF ( cx(mgs,ls) + dtp*(pcswi(mgs) + pcswd(mgs)) < 0.0 ) THEN + frac = (-cx(mgs,ls) + pcswi(mgs)*dtp)/(pcswd(mgs)*dtp) + + pqswd(mgs) = frac*pqswd(mgs) + + chacs(mgs) = frac*chacs(mgs) + chlacs(mgs) = frac*chlacs(mgs) + chcns(mgs) = frac*chcns(mgs) + csmlr(mgs) = frac*csmlr(mgs) + csshr(mgs) = frac*csshr(mgs) + cssbv(mgs) = frac*cssbv(mgs) + csacs(mgs) = frac*csacs(mgs) + + ENDIF + ENDIF + + pccii(mgs) = pccii(mgs) & & + (1. - ifrzs)*crfrzs(mgs) & & + (1. - ifrzs)*ciacrs(mgs) @@ -14440,7 +15284,7 @@ subroutine nssl_2mom_gs & ! IF ( lhl .gt. 1 ) THEN ! do mgs = 1,ngscnt - pchli(mgs) = & ! (1.0-ifrzg)*(crfrzf(mgs) +il5(mgs)*(ciacrf(mgs) )) & + pchli(mgs) = (1.0-ifrzg)*(crfrzf(mgs) +il5(mgs)*(ciacrf(mgs) )) & & + chlcnh(mgs) *rzxhl(mgs)/rzxh(mgs) pchld(mgs) = & @@ -14509,6 +15353,8 @@ subroutine nssl_2mom_gs & ! IF ( warmonly < 0.5 ) THEN do mgs = 1,ngscnt + +! NOTE: ANY CHANGES HERE ALSO NEED TO GO INTO THE RESUM FARTHER DOWN! pqwvi(mgs) = & & -Min(0.0, qrcev(mgs)) & & -Min(0.0, qhcev(mgs)) & @@ -14518,6 +15364,7 @@ subroutine nssl_2mom_gs & & -qhsbv(mgs) - qhlsbv(mgs) & & -qssbv(mgs) & & -il5(mgs)*qisbv(mgs) + pqwvd(mgs) = & & -Max(0.0, qrcev(mgs)) & & -Max(0.0, qhcev(mgs)) & @@ -14525,7 +15372,8 @@ subroutine nssl_2mom_gs & & -Max(0.0, qscev(mgs)) & & +il5(mgs)*(-qiint(mgs) & & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & - & -il5(mgs)*qidpv(mgs) + & -il5(mgs)*qidpv(mgs) + end do ELSEIF ( warmonly < 0.8 ) THEN @@ -14539,7 +15387,7 @@ subroutine nssl_2mom_gs & & -qhdpv(mgs) - qhldpv(mgs)) & ! & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & & -Max(0.0, qrcev(mgs)) & - & -il5(mgs)*qidpv(mgs) + & -il5(mgs)*qidpv(mgs) end do ELSE @@ -14560,14 +15408,13 @@ subroutine nssl_2mom_gs & IF ( warmonly < 0.5 ) THEN pqcwd(mgs) = & - & il5(mgs)*(-qiacw(mgs)-qwfrzc(mgs)-qwctfzc(mgs)) & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & & -il5(mgs)*(qicichr(mgs)) & - & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) -! > -il5(mgs)*(qwfrzp(mgs)+qwctfzp(mgs)) + & -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs) !& +! & -il5(mgs)*(qwfrzp(mgs)) ELSEIF ( warmonly < 0.8 ) THEN pqcwd(mgs) = & - & il5(mgs)*(-qiacw(mgs)-qwfrzc(mgs)-qwctfzc(mgs)) & -! & il5(mgs)*(-qwfrzc(mgs)-qwctfzc(mgs)) & + & il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs)) & & -il5(mgs)*(qicichr(mgs)) & & -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs) ELSE @@ -14584,13 +15431,16 @@ subroutine nssl_2mom_gs & ! qwfrzp(mgs) = frac*qwfrzp(mgs) ! qwctfzp(mgs) = frac*qwctfzp(mgs) qwfrzc(mgs) = frac*qwfrzc(mgs) + qwfrzis(mgs) = frac*qwfrzis(mgs) + qwfrz(mgs) = frac*qwfrz(mgs) qwctfzc(mgs) = frac*qwctfzc(mgs) + qwctfzis(mgs) = frac*qwctfzis(mgs) + qwctfz(mgs) = frac*qwctfz(mgs) qracw(mgs) = frac*qracw(mgs) qsacw(mgs) = frac*qsacw(mgs) qhacw(mgs) = frac*qhacw(mgs) vhacw(mgs) = frac*vhacw(mgs) qrcnw(mgs) = frac*qrcnw(mgs) - qwfrz(mgs) = frac*qwfrz(mgs) qwfrzp(mgs) = frac*qwfrzp(mgs) IF ( lhl .gt. 1 ) THEN qhlacw(mgs) = frac*qhlacw(mgs) @@ -14610,11 +15460,11 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt pqcii(mgs) = & - & il5(mgs)*qicicnt(mgs) & + & il5(mgs)*qicicnt(mgs)*(1. - ffrzs) & & +il5(mgs)*qidpv(mgs) & - & +il5(mgs)*qiacw(mgs) & ! (qiacwi(mgs)+qwacii(mgs)) & - & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & - & +il5(mgs)*(qicichr(mgs)) & + & +il5(mgs)*qiacw(mgs) & + & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs))*(1. - ffrzs) & + & +il5(mgs)*(qicichr(mgs))*(1. - ffrzs) & & +qsmul(mgs) & & +qhmul1(mgs) + qhlmul1(mgs) & & + qsplinter(mgs) + qsplinter2(mgs) @@ -14631,12 +15481,14 @@ subroutine nssl_2mom_gs & & - qhcni(mgs) end do + ELSEIF ( warmonly < 0.8 ) THEN do mgs = 1,ngscnt pqcii(mgs) = & - & il5(mgs)*qicicnt(mgs) & - & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs)) & + & il5(mgs)*qicicnt(mgs)*(1. - ffrzs) & + & +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs))*(1. - ffrzs) & + & +il5(mgs)*(qicichr(mgs))*(1. - ffrzs) & ! & +il5(mgs)*(qicichr(mgs)) & ! & +qsmul(mgs) & & +qhmul1(mgs) + qhlmul1(mgs) & @@ -14757,7 +15609,8 @@ subroutine nssl_2mom_gs & ! > +il5(mgs)*(-qhsbv(mgs) - qhlsbv(mgs) ) & & -qhsbv(mgs) - qhlsbv(mgs) & & -qssbv(mgs) & - & -il5(mgs)*qisbv(mgs) + & -il5(mgs)*qisbv(mgs) + pqwvd(mgs) = & & -Max(0.0, qrcev(mgs)) & & -Max(0.0, qhcev(mgs)) & @@ -14765,7 +15618,8 @@ subroutine nssl_2mom_gs & & -Max(0.0, qscev(mgs)) & & +il5(mgs)*(-qiint(mgs) & & -qhdpv(mgs) -qsdpv(mgs) - qhldpv(mgs)) & - & -il5(mgs)*qidpv(mgs) + & -il5(mgs)*qidpv(mgs) + ENDIF @@ -14783,7 +15637,9 @@ subroutine nssl_2mom_gs & & il5(mgs)*(qscni(mgs)+qsaci(mgs)+qsdpv(mgs) & & + qscnvi(mgs) & & + ifrzs*(qiacrs(mgs) + qrfrzs(mgs)) & + & + il5(mgs)*( qwfrzc(mgs) + qwctfzc(mgs) + qicichr(mgs) )*ffrzs & & + il2(mgs)*qsacr(mgs)) & + & + il5(mgs)*qicicnt(mgs)*ffrzs & & + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) & & + Max(0.0, qscev(mgs)) & & + qsacw(mgs) + qscnh(mgs) @@ -14797,6 +15653,26 @@ subroutine nssl_2mom_gs & & + Min(0.0, qscev(mgs)) & & -qsmul(mgs) + + IF ( imixedphase == 0 .and. pqswd(mgs) .lt. 0.0 ) THEN + IF ( qx(mgs,ls) + dtp*(pqswi(mgs) + pqswd(mgs)) < 0.0 ) THEN + frac = (-qx(mgs,ls) + pqswi(mgs)*dtp)/(pqswd(mgs)*dtp) + + pqswd(mgs) = frac*pqswd(mgs) + + qracs(mgs) = frac*qracs(mgs) ! only used for single moment at this time + qhacs(mgs) = frac*qhacs(mgs) + qhlacs(mgs) = frac*qhlacs(mgs) + qhcns(mgs) = frac*qhcns(mgs) + qsmlr(mgs) = frac*qsmlr(mgs) + qsshr(mgs) = frac*qsshr(mgs) + qssbv(mgs) = frac*qssbv(mgs) + qsmul(mgs) = frac*qsmul(mgs) + IF ( qscev(mgs) < 0.0 ) qscev(mgs) = frac*qscev(mgs) + + ENDIF + ENDIF + pqcii(mgs) = pqcii(mgs) & & + (1. - ifrzs)*qrfrzs(mgs) & & + (1. - ifrzs)*qiacrs(mgs) @@ -15080,7 +15956,7 @@ subroutine nssl_2mom_gs & do mgs = 1,ngscnt ! ptotal(mgs) = 0. - ptotal(mgs) = ptotal(mgs) & + ptotal(mgs) = ptotal(mgs) & & + pqwvi(mgs) + pqwvd(mgs) & & + pqcwi(mgs) + pqcwd(mgs) & & + pqcii(mgs) + pqcid(mgs) & @@ -15089,16 +15965,21 @@ subroutine nssl_2mom_gs & & + pqhwi(mgs) + pqhwd(mgs) & & + pqhli(mgs) + pqhld(mgs) ! + + + ENDDO + + do mgs = 1,ngscnt - if ( ( (ndebug .ge. 1 ) .and. abs(ptotal(mgs)) .gt. eqtot ) & + if ( ( (ndebug .ge. 0 ) .and. abs(ptotal(mgs)) .gt. eqtot ) & ! if ( ( abs(ptotal(mgs)) .gt. eqtot ) ! : .or. pqswi(mgs)*dtp .gt. 1.e-3 ! : .or. pqhwi(mgs)*dtp .gt. 1.e-3 ! : .or. dtp*(pqrwi(mgs)+pqrwd(mgs)) .gt. 10.0e-3 ! : .or. dtp*(pccii(mgs)+pccid(mgs)) .gt. 1.e7 ! : .or. dtp*(pcipi(mgs)+pcipd(mgs)) .gt. 1.e7 & - & .or. .not. (ptotal(mgs) .lt. 1.0 .and. & - & ptotal(mgs) .gt. -1.0) ) then + & .or. .not. (ptotal(mgs) .lt. 1.0 .and. ptotal(mgs) .gt. -1.0) & ! this line is basically checking for NaNs + & ) then write(iunit,*) 'YIKES! ','ptotal1',mgs,igs(mgs),jgs, & & kgs(mgs),ptotal(mgs) @@ -15120,13 +16001,22 @@ subroutine nssl_2mom_gs & write(iunit,*) 'rain cx,xv : ',cx(mgs,lr),xv(mgs,lr) write(iunit,*) 'temcg = ', temcg(mgs) - write(iunit,*) pqwvi(mgs) ,pqwvd(mgs) - write(iunit,*) pqcwi(mgs) ,pqcwd(mgs) - write(iunit,*) pqcii(mgs) ,pqcid(mgs) - write(iunit,*) pqrwi(mgs) ,pqrwd(mgs) - write(iunit,*) pqswi(mgs) ,pqswd(mgs) - write(iunit,*) pqhwi(mgs) ,pqhwd(mgs) - write(iunit,*) pqhli(mgs) ,pqhld(mgs) + write(iunit,*) 'v ', pqwvi(mgs) ,pqwvd(mgs) + write(iunit,*) 'c ', pqcwi(mgs) ,pqcwd(mgs) + write(iunit,*) 'ci', pqcii(mgs) ,pqcid(mgs) + write(iunit,*) 'r ', pqrwi(mgs) ,pqrwd(mgs) + write(iunit,*) 's ', pqswi(mgs) ,pqswd(mgs) + write(iunit,*) 'h ', pqhwi(mgs) ,pqhwd(mgs) + write(iunit,*) 'hl', pqhli(mgs) ,pqhld(mgs) + tmp = pqwvi(mgs) + pqwvd(mgs) & + & + pqcwi(mgs) + pqcwd(mgs) & + & + pqcii(mgs) + pqcid(mgs) & + & + pqrwi(mgs) + pqrwd(mgs) & + & + pqswi(mgs) + pqswd(mgs) & + & + pqhwi(mgs) + pqhwd(mgs) & + & + pqhli(mgs) + pqhld(mgs) + + write(iunit,*) 'total = ',tmp write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' ! @@ -15158,8 +16048,8 @@ subroutine nssl_2mom_gs & write(iunit,*) il5(mgs)*qicicnt(mgs) write(iunit,*) il5(mgs)*qidpv(mgs) write(iunit,*) il5(mgs)*qiacw(mgs) - write(iunit,*) il5(mgs)*qwfrz(mgs) - write(iunit,*) il5(mgs)*qwctfz(mgs) + write(iunit,*) il5(mgs)*qwfrzc(mgs) + write(iunit,*) il5(mgs)*qwctfzc(mgs) write(iunit,*) il5(mgs)*qicichr(mgs) write(iunit,*) qhmul1(mgs) write(iunit,*) qhlmul1(mgs) @@ -15193,6 +16083,7 @@ subroutine nssl_2mom_gs & write(iunit,*) -il5(mgs)*qiacw(mgs) write(iunit,*) -il5(mgs)*qwfrzc(mgs) write(iunit,*) -il5(mgs)*qwctfzc(mgs) + write(iunit,*) -il5(mgs)*qwctfzis(mgs) ! write(iunit,*) -il5(mgs)*qwfrzp(mgs) ! write(iunit,*) -il5(mgs)*qwctfzp(mgs) write(iunit,*) -il5(mgs)*qiihr(mgs) @@ -15281,6 +16172,12 @@ subroutine nssl_2mom_gs & ! write(iunit,*) qsshrp(mgs) write(iunit,*) il5(mgs)*(qssbv(mgs)) write(iunit,*) 'pqswd = ', pqswd(mgs) + write(iunit,*) -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs) + write(iunit,*) -qhcns(mgs) + write(iunit,*) +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs) !null at this point when wet snow included + write(iunit,*) (qssbv(mgs)) + write(iunit,*) Min(0.0, qscev(mgs)) + write(iunit,*) -qsmul(mgs) ! ! write(iunit,*) @@ -15336,10 +16233,11 @@ subroutine nssl_2mom_gs & write(iunit,*) 'END OF OUTPUT OF SOURCE AND SINK' write(iunit,*) 'PTOTAL',ptotal(mgs) ! - end if + end if ! ptotal out of bounds or NaN ! end do ! + end if ! ( nstep/12*12 .eq. nstep ) ! @@ -15364,6 +16262,7 @@ subroutine nssl_2mom_gs & pmlt(mgs) = & & (1-il5(mgs))* & & (qhmlr(mgs)+qsmlr(mgs)+qhlmlr(mgs)) !+qhmlh(mgs)) + ! NOTE: psub is sum of sublimation and deposition psub(mgs) = & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & @@ -15375,6 +16274,7 @@ subroutine nssl_2mom_gs & & qrcev(mgs) + qhcev(mgs) + qscev(mgs) + qhlcev(mgs) pevap(mgs) = & & Min(0.0,qrcev(mgs)) + Min(0.0,qhcev(mgs)) + Min(0.0,qscev(mgs)) + Min(0.0,qhlcev(mgs)) + ! NOTE: pdep is the deposition part only pdep(mgs) = & & il5(mgs)*( & & + qsdpv(mgs) + qhdpv(mgs) & @@ -15413,6 +16313,11 @@ subroutine nssl_2mom_gs & & +felscp(mgs)*psub(mgs) & & +felvcp(mgs)*pvap(mgs)) thetap(mgs) = thetap(mgs) + dtp*ptem(mgs) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (felfpi(mgs)*pfrz(mgs) & + & +felspi(mgs)*psub(mgs) & + & +felvpi(mgs)*pvap(mgs))*dtp + ENDIF end do @@ -15427,15 +16332,8 @@ subroutine nssl_2mom_gs & & dtp*(pqwvi(mgs)+pqwvd(mgs)) qx(mgs,lc) = qx(mgs,lc) + & & dtp*(pqcwi(mgs)+pqcwd(mgs)) -! IF ( qx(mgs,lr) .gt. 10.0e-3 ) THEN -! write(0,*) 'RAIN1a: ',igs(mgs),kgs(mgs),qx(mgs,lr) -! ENDIF qx(mgs,lr) = qx(mgs,lr) + & & dtp*(pqrwi(mgs)+pqrwd(mgs)) -! IF ( qx(mgs,lr) .gt. 10.0e-3 ) THEN -! write(0,*) 'RAIN1b: ',igs(mgs),kgs(mgs),qx(mgs,lr) -! write(0,*) pqrwi(mgs),pqrwd(mgs) -! ENDIF qx(mgs,li) = qx(mgs,li) + & & dtp*(pqcii(mgs)+pqcid(mgs)) qx(mgs,ls) = qx(mgs,ls) + & @@ -15445,7 +16343,6 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 ) THEN qx(mgs,lhl) = qx(mgs,lhl) + & & dtp*(pqhli(mgs)+pqhld(mgs)) -! IF ( pqhli(mgs) .gt. 1.e-8 ) write(0,*) ' pqhli,qx(lhl) = ',pqhli(mgs),qx(mgs,lhl) ENDIF @@ -15488,7 +16385,8 @@ subroutine nssl_2mom_gs & if ( ipconc .ge. 1 ) then do mgs = 1,ngscnt cx(mgs,li) = cx(mgs,li) + & - & dtp*(pccii(mgs)+pccid(mgs)) + & dtp*(pccii(mgs)+pccid(mgs)) + cina(mgs) = cina(mgs) + pccin(mgs)*dtp IF ( ipconc .ge. 2 ) THEN cx(mgs,lc) = cx(mgs,lc) + & & dtp*(pccwi(mgs)+pccwd(mgs)) @@ -15507,9 +16405,6 @@ subroutine nssl_2mom_gs & IF ( lhl .gt. 1 ) THEN cx(mgs,lhl) = cx(mgs,lhl) + & & dtp*(pchli(mgs)+pchld(mgs)) -! IF ( pchli(mgs) .ne. 0. .or. pchld(mgs) .ne. 0 ) THEN -! write(0,*) 'dr: cx,pchli,pchld = ', cx(mgs,lhl),pchli(mgs),pchld(mgs), igs(mgs),kgs(mgs) -! ENDIF ENDIF ENDIF end do @@ -15568,6 +16463,9 @@ subroutine nssl_2mom_gs & ptem(mgs) = ptem(mgs) + & & (1./pi0(mgs))* & & felfcp(mgs)*(- qitmp(mgs)/dtp) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) - (felfpi(mgs)*qitmp(mgs)) + ENDIF pmlt(mgs) = pmlt(mgs) - qitmp(mgs)/dtp scx(mgs,lc) = scx(mgs,lc) + scx(mgs,li) thetap(mgs) = thetap(mgs) - & @@ -15581,6 +16479,7 @@ subroutine nssl_2mom_gs & qitmp(mgs) = 0.0 end if end do + ! ! @@ -15635,6 +16534,11 @@ subroutine nssl_2mom_gs & ptem(mgs) = ptem(mgs) + & & (1./pi0(mgs))* & & felfcp(mgs)*(qtmp/dtp) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + felfpi(mgs)*qtmp + ENDIF + ! IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qx(mgs,lc)/xdn0(li) IF ( lvol(li) .gt. 1 ) vx(mgs,li) = vx(mgs,li) + rho0(mgs)*qtmp/xdn0(li) @@ -15839,6 +16743,12 @@ subroutine nssl_2mom_gs & & 1./pi0(mgs)* & & (felvcp(mgs)*dqcw(mgs) +felscp(mgs)*dqci(mgs)) + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) & + & +(felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + end if ! dqwv(mgs) .lt. 0. (end of evap/sublim) ! ! condensation/deposition @@ -15902,6 +16812,13 @@ subroutine nssl_2mom_gs & thetap(mgs) = thetap(mgs) + & & (felvcp(mgs)*dqcw(mgs) + felscp(mgs)*dqci(mgs)) & & / (pi0(mgs)) + + IF ( eqtset > 2 ) THEN + pipert(mgs) = pipert(mgs) + (0 & + & +felspi(mgs)*dqci(mgs) & + & +felvpi(mgs)*dqcw(mgs))*dtp + ENDIF + qwvp(mgs) = qwvp(mgs) - ( dqvcnd(mgs) ) qx(mgs,lc) = qx(mgs,lc) + dqcw(mgs) IF ( qitmp(mgs) .gt. qxmin(li) ) THEN @@ -15972,6 +16889,7 @@ subroutine nssl_2mom_gs & ! ! ! end of saturation adjustment + ! ! ! !DIR$ IVDEP @@ -15983,6 +16901,7 @@ subroutine nssl_2mom_gs & ! + if (ndebug .gt. 0 ) write(0,*) 'gs 11' do mgs = 1,ngscnt @@ -15990,6 +16909,10 @@ subroutine nssl_2mom_gs & an(igs(mgs),jy,kgs(mgs),lt) = & & theta0(mgs) + thetap(mgs) an(igs(mgs),jy,kgs(mgs),lv) = qwvp(mgs) + qv0(mgs) ! + + IF ( eqtset > 2 ) THEN + p2(igs(mgs),jy,kgs(mgs)) = pipert(mgs) + ENDIF ! DO il = lc,lhab @@ -16000,6 +16923,10 @@ subroutine nssl_2mom_gs & ENDIF ENDDO + IF ( lcina > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lcina) = cina(mgs) + ENDIF + ! end do @@ -16032,9 +16959,23 @@ subroutine nssl_2mom_gs & ! IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN ! write(0,*) 'dr: xv,cx,qx,xdn,ln = ',xv(mgs,il),cx(mgs,il),qx(mgs,il),xdn(mgs,il),ln(il) ! ENDIF - - IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvmx(il) ) THEN - xv(mgs,il) = Min( xvmx(il), xv(mgs,il) ) + + ! 8/26/2015 erm: apply imaxdiaopt for 2-moment also + IF ( imaxdiaopt == 1 .or. il == lc .or. il == li .or. (il == lr .and. imurain == 3) .or. (il == ls .and. imusnow == 3 ) ) THEN + xvbarmax = xvmx(il) + ELSEIF ( imaxdiaopt == 2 ) THEN ! test against maximum mass diameter + xvbarmax = xvmx(il) /((3. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ELSEIF ( imaxdiaopt == 3 ) THEN ! test against mass-weighted diameter + xvbarmax = xvmx(il) /((4. + alpha(mgs,il))**3/((3. + alpha(mgs,il))*(2. + alpha(mgs,il))*(1. + alpha(mgs,il)))) + ENDIF + + tmp = 1.0 + IF ( il == ls ) THEN + xvbarmax = xvbarmax*Max(1.,100./Min(100.,xdn(mgs,ls))) + ENDIF + + IF ( xv(mgs,il) .lt. xvmn(il) .or. xv(mgs,il) .gt. xvbarmax ) THEN + xv(mgs,il) = Min( xvbarmax, xv(mgs,il) ) xv(mgs,il) = Max( xvmn(il), xv(mgs,il) ) cx(mgs,il) = rho0(mgs)*qx(mgs,il)/(xv(mgs,il)*xdn(mgs,il)) ENDIF @@ -16066,8 +17007,12 @@ subroutine nssl_2mom_gs & IF ( ipconc .ge. 2 ) THEN do mgs = 1,ngscnt + IF ( lss > 1 ) THEN + an(igs(mgs),jy,kgs(mgs),lss) = Max(0.0, ssmax(mgs) ) + ENDIF + IF ( lccn > 1 ) THEN - an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) + an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0, ccnc(mgs) ) ENDIF end do ENDIF diff --git a/wrfv2_fire/phys/module_mp_thompson.F b/wrfv2_fire/phys/module_mp_thompson.F index 4b816fb1..f8c124ea 100644 --- a/wrfv2_fire/phys/module_mp_thompson.F +++ b/wrfv2_fire/phys/module_mp_thompson.F @@ -36,7 +36,7 @@ !.. Remaining values should probably be left alone. !.. !..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805 -!..Last modified: 11 Feb 2015 Aerosol additions to v3.5.1 code 9/2013 +!..Last modified: 09 Nov 2015 Aerosol additions to v3.5.1 code 9/2013 !.. Cloud fraction additions 11/2014 part of pre-v3.7 !+---+-----------------------------------------------------------------+ !wrft:model_layer:physics @@ -1053,7 +1053,7 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & REAL, DIMENSION(kts:kte):: & qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & nr1d, nc1d, nwfa1d, nifa1d, & - t1d, p1d, w1d, dz1d, dBZ + t1d, p1d, w1d, dz1d, rho, dBZ REAL, DIMENSION(kts:kte):: re_qc1d, re_qi1d, re_qs1d #if ( WRF_CHEM == 1 ) REAL, DIMENSION(kts:kte):: & @@ -1167,9 +1167,10 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & nwfa1 = nwfa2d(i,j) else do k = kts, kte - nc1d(k) = Nt_c - nwfa1d(k) = 11.1E6 - nifa1d(k) = naIN1*0.01 + rho(k) = 0.622*p1d(k)/(R*t1d(k)*(qv1d(k)+0.622)) + nc1d(k) = Nt_c/rho(k) + nwfa1d(k) = 11.1E6/rho(k) + nifa1d(k) = naIN1*0.01/rho(k) enddo nwfa1 = 11.1E6 endif @@ -1324,16 +1325,16 @@ SUBROUTINE mp_gt_driver(qv, qc, qr, qi, qs, qg, ni, nr, nc, & IF (has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN do k = kts, kte - re_qc1d(k) = 2.51E-6 - re_qi1d(k) = 10.01E-6 - re_qs1d(k) = 10.01E-6 + re_qc1d(k) = 2.49E-6 + re_qi1d(k) = 4.99E-6 + re_qs1d(k) = 9.99E-6 enddo call calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & re_qc1d, re_qi1d, re_qs1d, kts, kte) do k = kts, kte - re_cloud(i,k,j) = MAX( 2.51E-6, MIN(re_qc1d(k), 50.E-6)) - re_ice(i,k,j) = MAX(10.01E-6, MIN(re_qi1d(k), 125.E-6)) - re_snow(i,k,j) = MAX(10.01E-6, MIN(re_qs1d(k), 999.E-6)) + re_cloud(i,k,j) = MAX(2.49E-6, MIN(re_qc1d(k), 50.E-6)) + re_ice(i,k,j) = MAX(4.99E-6, MIN(re_qi1d(k), 125.E-6)) + re_snow(i,k,j) = MAX(9.99E-6, MIN(re_qs1d(k), 999.E-6)) enddo ENDIF @@ -1640,8 +1641,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi ilami = 1./lami xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 20.E-6) then - lami = cie(2)/20.E-6 + if (xDi.lt. 5.E-6) then + lami = cie(2)/5.E-6 ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i) elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 @@ -2672,8 +2673,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lami = (am_i*cig(2)*oig1*xni/xri)**obmi ilami = 1./lami xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 20.E-6) then - lami = cie(2)/20.E-6 + if (xDi.lt. 5.E-6) then + lami = cie(2)/5.E-6 xni = MIN(499.D3, cig(1)*oig2*xri/am_i*lami**bm_i) niten(k) = (xni-ni1d(k)*rho(k))*odts*orho elseif (xDi.gt. 300.E-6) then @@ -3255,8 +3256,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & t3_vts = Kap0*csg(1)*ils1**cse(1) t4_vts = Kap1*Mrat**mu_s*csg(7)*ils2**cse(7) vts = rhof(k)*av_s * (t1_vts+t2_vts)/(t3_vts+t4_vts) - if (temp(k).gt. T_0) then - vtsk(k) = MAX(vts*vts_boost(k), vtrk(k)) + if (temp(k).gt. (T_0+0.1)) then + vtsk(k) = MAX(vts*vts_boost(k), & + & vts*((vtrk(k)-vts*vts_boost(k))/(temp(k)-T_0))) else vtsk(k) = vts*vts_boost(k) endif @@ -3503,8 +3505,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, & lami = (am_i*cig(2)*oig1*ni1d(k)/qi1d(k))**obmi ilami = 1./lami xDi = (bm_i + mu_i + 1.) * ilami - if (xDi.lt. 20.E-6) then - lami = cie(2)/20.E-6 + if (xDi.lt. 5.E-6) then + lami = cie(2)/5.E-6 elseif (xDi.gt. 300.E-6) then lami = cie(2)/300.E-6 endif @@ -3589,6 +3591,11 @@ subroutine qr_acr_qg CALL wrf_error_fatal("Error opening qr_acr_qg.dat. Aborting because force_read_thompson is .true.") ENDIF ENDIF + ELSE + INQUIRE(63,opened=lopen) + IF (lopen) THEN + CLOSE(63) + ENDIF ENDIF ELSE IF( force_read_thompson ) THEN @@ -3781,6 +3788,11 @@ subroutine qr_acr_qs CALL wrf_error_fatal("Error opening qr_acr_qs.dat. Aborting because force_read_thompson is .true.") ENDIF ENDIF + ELSE + INQUIRE(63,opened=lopen) + IF (lopen) THEN + CLOSE(63) + ENDIF ENDIF ELSE IF( force_read_thompson ) THEN @@ -4055,6 +4067,11 @@ subroutine freezeH2O CALL wrf_error_fatal("Error opening freezeH2O.dat. Aborting because force_read_thompson is .true.") ENDIF ENDIF + ELSE + INQUIRE(63,opened=lopen) + IF (lopen) THEN + CLOSE(63) + ENDIF ENDIF ELSE IF( force_read_thompson ) THEN @@ -5018,7 +5035,7 @@ subroutine calc_effectRad (t1d, p1d, qv1d, qc1d, nc1d, qi1d, ni1d, qs1d, & do k = kts, kte if (ri(k).le.R1 .or. ni(k).le.R2) CYCLE lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi - re_qi1d(k) = MAX(10.01E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) + re_qi1d(k) = MAX(5.01E-6, MIN(SNGL(0.5D0 * DBLE(3.+mu_i)/lami), 125.E-6)) enddo endif diff --git a/wrfv2_fire/phys/module_mp_wdm5.F b/wrfv2_fire/phys/module_mp_wdm5.F index ea0e9b27..4e0c2df0 100644 --- a/wrfv2_fire/phys/module_mp_wdm5.F +++ b/wrfv2_fire/phys/module_mp_wdm5.F @@ -118,6 +118,8 @@ SUBROUTINE wdm5(th, q, qc, qr, qi, qs & ! ==> only diagnostic, but with removal of too large drops ! effective radius of hydrometeors, bae from kiaps, jan 2015 ! ==> consistency in solar insolation of rrtmg radiation +! bug fix in melting terms, bae from kiaps, nov 2015 +! ==> density of air is divided, which has not been ! ! Reference) Lim and Hong (LH, 2010) Mon. Wea. Rev. ! Juang and Hong (JH, 2010) Mon. Wea. Rev. @@ -813,7 +815,8 @@ SUBROUTINE wdm52D(t, q, qci, qrs, ncr, den, p, delz & psmlt(i,k) = (1.414e3*(1.496e-6 * ((t(i,k))*sqrt(t(i,k))) & /((t(i,k))+120.)/(den(i,k)))*(den(i,k)))/xlf & *(t0c-t(i,k))*pi/2.*n0sfac(i,k) & - *(precs1*rslope2(i,k,2)+precs2*work2(i,k)*coeres) + *(precs1*rslope2(i,k,2)+precs2*work2(i,k)*coeres) & + /den(i,k) psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i),-qrs(i,k,2) & /mstep(i)),0.) !------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_mp_wdm6.F b/wrfv2_fire/phys/module_mp_wdm6.F index 47f4552d..1563681e 100644 --- a/wrfv2_fire/phys/module_mp_wdm6.F +++ b/wrfv2_fire/phys/module_mp_wdm6.F @@ -128,6 +128,8 @@ SUBROUTINE wdm6(th, q, qc, qr, qi, qs, qg, & ! ==> switch graupel or hail by changing no, den, fall vel. ! effective radius of hydrometeors, bae from kiaps, jan 2015 ! ==> consistency in solar insolation of rrtmg radiation +! bug fix in melting terms, bae from kiaps, nov 2015 +! ==> density of air is divided, which has not been ! ! Reference) Lim and Hong (LH, 2010) Mon. Wea. Rev. ! Juang and Hong (JH, 2010) Mon. Wea. Rev. @@ -805,7 +807,7 @@ SUBROUTINE wdm62D(t, q, qci, qrs, ncr, den, p, delz & coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & *n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres) + +precs2*work2(i,k)*coeres)/den(i,k) psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i),-qrs(i,k,2) & /mstep(i)),0.) qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) @@ -827,7 +829,8 @@ SUBROUTINE wdm62D(t, q, qci, qrs, ncr, den, p, delz & if(qrs(i,k,3).gt.0.) then coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*(precg1 & - *rslope2(i,k,3) + precg2*work2(i,k)*coeres) + *rslope2(i,k,3) + precg2*work2(i,k)*coeres) & + /den(i,k) pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & -qrs(i,k,3)/mstep(i)),0.) qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) @@ -1307,7 +1310,7 @@ SUBROUTINE wdm62D(t, q, qci, qrs, ncr, den, p, delz & ! (TQS or QR->QG) (T>=T0: enhance melting of snow) !------------------------------------------------------------- acrfac = 30.*rslope3(i,k,1)*rslope2(i,k,1)*rslope(i,k,2) & - + 5.*rslope2(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & + +10.*rslope2(i,k,1)*rslope2(i,k,1)*rslope2(i,k,2) & + 2.*rslope3(i,k,1)*rslope3(i,k,2) psacr(i,k) = pi*pi*ncr(i,k,3)*n0s*n0sfac(i,k)*abs(vt2ave-vt2r) & *(denr/den(i,k))*acrfac @@ -1330,7 +1333,7 @@ SUBROUTINE wdm62D(t, q, qci, qrs, ncr, den, p, delz & !------------------------------------------------------------- if(qrs(i,k,3).gt.qcrmin .and. qrs(i,k,1).gt.qcrmin) then acrfac = 30.*rslope3(i,k,1)*rslope2(i,k,1)*rslope(i,k,3) & - + 5.*rslope2(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & + +10.*rslope2(i,k,1)*rslope2(i,k,1)*rslope2(i,k,3) & + 2.*rslope3(i,k,1)*rslope3(i,k,3) pgacr(i,k) = pi*pi*ncr(i,k,3)*n0g*abs(vt2ave-vt2r)*(denr/den(i,k)) & *acrfac diff --git a/wrfv2_fire/phys/module_mp_wsm5.F b/wrfv2_fire/phys/module_mp_wsm5.F index a598df97..7612ed3c 100644 --- a/wrfv2_fire/phys/module_mp_wsm5.F +++ b/wrfv2_fire/phys/module_mp_wsm5.F @@ -322,6 +322,8 @@ SUBROUTINE wsm52D(t, q & ! ==> only diagnostic, but with removal of too large drops ! effective radius of hydrometeors, bae from kiaps, jan 2015 ! ==> consistency in solar insolation of rrtmg radiation +! bug fix in melting terms, bae from kiaps, nov 2015 +! ==> density of air is divided, which has not been ! ! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. ! Rutledge, Hobbs (RH83, 1983) J. Atmos. Sci. @@ -710,7 +712,7 @@ SUBROUTINE wsm52D(t, q & /((t(i,k))+120.)/(den(i,k)) )*(den(i,k))) & /xlf*(t0c-t(i,k))*pi/2. & *n0sfac(i,k)*(precs1*rslope2(i,k,2)+precs2 & - *work2(i,k)*coeres) + *work2(i,k)*coeres)/den(i,k) psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & -qrs(i,k,2)/mstep(i)),0.) qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) diff --git a/wrfv2_fire/phys/module_mp_wsm6.F b/wrfv2_fire/phys/module_mp_wsm6.F index 6422ee2b..e136f42d 100644 --- a/wrfv2_fire/phys/module_mp_wsm6.F +++ b/wrfv2_fire/phys/module_mp_wsm6.F @@ -293,6 +293,8 @@ SUBROUTINE wsm62D(t, q & ! ==> switch graupel or hail by changing no, den, fall vel. ! effective radius of hydrometeors, bae from kiaps, jan 2015 ! ==> consistency in solar insolation of rrtmg radiation +! bug fix in melting terms, bae from kiaps, nov 2015 +! ==> density of air is divided, which has not been ! ! Reference) Hong, Dudhia, Chen (HDC, 2004) Mon. Wea. Rev. ! Hong and Lim (HL, 2006) J. Korean Meteor. Soc. @@ -702,7 +704,7 @@ SUBROUTINE wsm62D(t, q & coeres = rslope2(i,k,2)*sqrt(rslope(i,k,2)*rslopeb(i,k,2)) psmlt(i,k) = xka(t(i,k),den(i,k))/xlf*(t0c-t(i,k))*pi/2. & *n0sfac(i,k)*(precs1*rslope2(i,k,2) & - +precs2*work2(i,k)*coeres) + +precs2*work2(i,k)*coeres)/den(i,k) psmlt(i,k) = min(max(psmlt(i,k)*dtcld/mstep(i), & -qrs(i,k,2)/mstep(i)),0.) qrs(i,k,2) = qrs(i,k,2) + psmlt(i,k) @@ -717,7 +719,7 @@ SUBROUTINE wsm62D(t, q & coeres = rslope2(i,k,3)*sqrt(rslope(i,k,3)*rslopeb(i,k,3)) pgmlt(i,k) = xka(t(i,k),den(i,k))/xlf & *(t0c-t(i,k))*(precg1*rslope2(i,k,3) & - +precg2*work2(i,k)*coeres) + +precg2*work2(i,k)*coeres)/den(i,k) pgmlt(i,k) = min(max(pgmlt(i,k)*dtcld/mstep(i), & -qrs(i,k,3)/mstep(i)),0.) qrs(i,k,3) = qrs(i,k,3) + pgmlt(i,k) diff --git a/wrfv2_fire/phys/module_pbl_driver.F b/wrfv2_fire/phys/module_pbl_driver.F index 86052ef2..05f53a61 100644 --- a/wrfv2_fire/phys/module_pbl_driver.F +++ b/wrfv2_fire/phys/module_pbl_driver.F @@ -16,7 +16,7 @@ SUBROUTINE pbl_driver( & #endif ,ht & ,ust,pblh,hfx,qfx,grdflx & - ,u_phy,v_phy,th_phy,rho & + ,u_phy,v_phy,w,th_phy,rho & ,p_phy,pi_phy,p8w,t_phy,dz8w,z & ,exch_h,exch_m,akhs,akms & ,thz0,qz0,uz0,vz0,qsfc,f & @@ -43,17 +43,25 @@ SUBROUTINE pbl_driver( & ,tsq,qsq,cov,rmol,ch,qcg,grav_settling & ,dqke,qWT,qSHEAR,qBUOY,qDISS,bl_mynn_tkebudget & ! JOE - MYNN TKE budget ,bl_mynn_cloudpdf & ! JOE - cloud PDF tests + ,bl_mynn_mixlength & ! JAYMES + ,icloud_bl,qc_bl,cldfra_bl & ! JOE-subgrid bl clouds + ,bl_mynn_edmf,bl_mynn_edmf_mom,bl_mynn_edmf_tke & + ,bl_mynn_edmf_part & !JOE- MYNN edmf + ,bl_mynn_cloudmix,bl_mynn_mixqt & !JOE- MYNN cloud methods + ,edmf_a,edmf_w,edmf_thl & !JOE- MYNN edmf + ,edmf_qt,edmf_ent,edmf_qc & !JOE- MYNN edmf ,vdfg & ! Katata- fog deposition #if (NMM_CORE==1) ,DISHEAT & ,HPBL2D, EVAP2D, HEAT2D, RC2D & !Kwon FOR SHAL. CON. -#ifdef HWRF +#if ( HWRF == 1 ) ,VAR_RIC & !Kwon for Variable Ric #endif ,DKU3D,DKT3D & #endif #if (HWRF==1) ,coef_ric_l,coef_ric_s,gfs_alpha & + ,pert_pbl, ens_random_seed, ens_pblamp & #endif ,ids,ide, jds,jde, kds,kde & ,ims,ime, jms,jme, kms,kme & @@ -109,7 +117,15 @@ SUBROUTINE pbl_driver( & #if (WRF_CHEM == 1) ,chem,vd,nchem,kdvel,ndvel,num_vert_mix & #endif - ) +! +! FASDAS +! + ,QNORM, fasdas & +! +! END FASDAS +! + ) + !------------------------------------------------------------------ #if (EM_CORE==1) USE module_state_description, ONLY : & @@ -375,11 +391,11 @@ SUBROUTINE pbl_driver( & REAL, DIMENSION( ims:ime , jms:jme , kms:kme ), & INTENT(OUT) :: DKU3D,DKT3D !Kwon duffusivity #endif -#ifdef HWRF +#if ( HWRF == 1 ) REAL, INTENT(IN) :: VAR_RIC !Kwon for variable Ric - -#endif -#if defined(HWRF) + integer,intent(in) :: ens_random_seed + real,intent(in) :: ens_pblamp + logical,intent(in) :: pert_pbl REAL, INTENT(IN) :: gfs_alpha,coef_ric_l,coef_ric_s #endif @@ -399,6 +415,8 @@ SUBROUTINE pbl_driver( & REAL, DIMENSION( ims:ime, jms:jme ), & INTENT(IN), OPTIONAL :: xlat_u,xlong_u,xlat_v,xlong_v + REAL, DIMENSION( ims:ime, kms:kme ,jms:jme ), & + INTENT(IN), OPTIONAL :: w ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(IN ) :: p_phy, & @@ -411,6 +429,7 @@ SUBROUTINE pbl_driver( & dz8w, & z, & th_phy + !1D variables required for CAMUWPBL scheme REAL , DIMENSION( kms:kme ) , & INTENT(IN ) , OPTIONAL :: fnm, & !Factors for interpolation at "w" grid (interfaces) @@ -502,16 +521,31 @@ SUBROUTINE pbl_driver( & REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & INTENT(INOUT) :: tsq,qsq,cov, & !,k_m,k_h,k_q & qke,Sh3d, & - dqke,qWT,qSHEAR,qBUOY,qDISS + dqke,qWT,qSHEAR,qBUOY,qDISS, & + qc_bl,cldfra_bl + + REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT) :: edmf_a,edmf_w,edmf_thl, & !JOE- MYNN edmf + edmf_qt,edmf_ent,edmf_qc !JOE- MYNN edmf + INTEGER, OPTIONAL, INTENT(IN) :: bl_mynn_tkebudget, & grav_settling, & - bl_mynn_cloudpdf + bl_mynn_cloudpdf, & + bl_mynn_mixlength, & + bl_mynn_edmf, & + bl_mynn_edmf_mom, & + bl_mynn_edmf_tke, & + bl_mynn_edmf_part, & + bl_mynn_cloudmix, & + bl_mynn_mixqt, & + icloud_bl + !ACF-QKE advection start REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & & INTENT(INOUT) :: qke_adv LOGICAL, OPTIONAL, INTENT(IN) :: bl_mynn_tkeadvect !ACF-QKE advection end -! Katata-added - +! Katata-added - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, & & INTENT(INOUT):: vdfg ! Katata-end @@ -524,7 +558,9 @@ SUBROUTINE pbl_driver( & REAL, DIMENSION( ims:ime , jms:jme ), & &OPTIONAL, INTENT(IN) :: & - & qcg, rmol, ch + & qcg, ch + REAL, DIMENSION( ims:ime , jms:jme ), & + &OPTIONAL, INTENT(INOUT) :: rmol @@ -714,7 +750,15 @@ SUBROUTINE pbl_driver( & integer iu_bep,iurb,idiff real seamask,thsk,zzz,unew,vnew,tnew,qnew,umom,vmom REAL :: z0,z1,z2,w1,w2 - +! +! FASDAS +! + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT( OUT) , OPTIONAL :: QNORM + INTEGER, INTENT(IN ) :: fasdas + REAL :: scrp1 +! +! END FASDAS +! !------------------------------------------------------------------ ! !!!!!!!if using BEP set flag_bep to true @@ -1117,6 +1161,25 @@ SUBROUTINE pbl_driver( & ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme & ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte & ) +! +! FASDAS +! + IF( fasdas == 1 ) THEN + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + scrp1 = rqvblten(i,1,j) + scrp1 = scrp1*(2.0*DT)/qv_curr(i,1,j) + scrp1 = scrp1*100.0 + scrp1 = amax1(0.0,scrp1) + scrp1 = amin1(5.0,scrp1) + QNORM(I,J)= scrp1/100.0 + ENDDO + ENDDO + ENDIF +! +! END FASDAS +! + ELSE WRITE ( message , FMT = '(A,7(L1,1X))' ) & 'present: '// & @@ -1267,13 +1330,16 @@ SUBROUTINE pbl_driver( & #if (NMM_CORE==1) ,DISHEAT=DISHEAT & #endif -#if defined(HWRF) +#if ( HWRF == 1 ) ,ALPHA=gfs_alpha & ,HPBL2D=HPBL2D, EVAP2D=EVAP2D, HEAT2D=HEAT2D & !Kwon add FOR SHAL. CON. ,VAR_RIC=VAR_RIC & !Kwon for variable Ric ,U10=U10,V10=V10,ZNT=ZNT,MZNT=MZNT,RC2D=RC2D & !Kwon for variable Ric ,DKU3D=DKU3D,DKT3D=DKT3D & ,coef_ric_l=coef_ric_l,coef_ric_s=coef_ric_s,xland=xland & + ,pert_pbl=pert_pbl & + ,ens_random_seed=ens_random_seed & + ,ens_pblamp=ens_pblamp & #endif ,P_QI=p_qi,P_FIRST_SCALAR=param_first_scalar & ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & @@ -1505,7 +1571,7 @@ SUBROUTINE pbl_driver( & ,UST=UST, HFX=HFX, QFX=QFX, TSK=tsk & ,PSFC=PSFC, EP1=EP_1, G=g, ROVCP=rcp,RD=r_D,CPD=cp & ,PBLH=pblh, KPBL2D=kpbl, EXCH_H=exch_h, REGIME=regime & - ,GZ1OZ0=gz1oz0,WSPD=wspd,PSIM=psim, MUT=mut & + ,GZ1OZ0=gz1oz0,WSPD=wspd,PSIM=psim, MUT=mut, RMOL=rmol & ,RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten & ,RQVBLTEN=rqvblten,RQCBLTEN=rqcblten,RQIBLTEN=rqiblten & ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & @@ -1556,36 +1622,45 @@ SUBROUTINE pbl_driver( & ENDIF CALL mynn_bl_driver(& - &initflag=initflag,& - &grav_settling=grav_settling,& - &delt=dtbl,& - &dz=dz8w,& - &u=u_phy,v=v_phy,th=th_phy,qv=qv_curr,qc=qc_curr,& - &qi=qi_curr,qni=qni_curr,& !qnc=qnc_curr,& - &p=p_phy,exner=pi_phy,rho=rho,& - &xland=xland,ts=tsk,qsfc=qsfc,qcg=qcg,ps=psfc,& - &ust=ust,ch=ch,hfx=hfx,qfx=qfx,rmol=rmol,wspd=wspd,& - &uoce=uoce,voce=voce,& !Ocean currents - &vdfg=vdfg,& !Katata -added - &Qke=qke,TKE_PBL=tke_pbl,& !JOE-for CAMUW shcu - &Sh3d=Sh3d,& -!ACF for QKE advection - &qke_adv=qke_adv,bl_mynn_tkeadvect=bl_mynn_tkeadvect,& -!ACF-end - &Tsq=tsq,Qsq=qsq,Cov=cov,& - &Du=rublten,Dv=rvblten,Dth=rthblten,& - &Dqv=rqvblten,Dqc=rqcblten,Dqi=rqiblten,& - !&Dqnc=rqncblten,& - &Dqni=rqniblten,& - &k_h=exch_h,k_m=exch_m,& - &pblh=pblh,KPBL=KPBL& + &initflag=initflag,grav_settling=grav_settling, & + &delt=dtbl,dz=dz8w,dx=dx,znt=znt, & + &u=u_phy,v=v_phy,w=w,th=th_phy,qv=qv_curr,qc=qc_curr, & + &qi=qi_curr,qni=qni_curr,qnc=qnc_curr, & + &p=p_phy,exner=pi_phy,rho=rho,T3D=t_phy, & + &xland=xland,ts=tsk,qsfc=qsfc,qcg=qcg,ps=psfc, & + &ust=ust,ch=ch,hfx=hfx,qfx=qfx,rmol=rmol,wspd=wspd, & + &uoce=uoce,voce=voce, & !Ocean currents + &vdfg=vdfg, & !Katata -added + &Qke=qke,TKE_PBL=tke_pbl, & + &Sh3d=Sh3d, & + &qke_adv=qke_adv,bl_mynn_tkeadvect=bl_mynn_tkeadvect, & +#if (WRF_CHEM == 1) + &chem3d=chem,vd3d=vd,nchem=nchem,kdvel=kdvel, & ! WA 7/31/15 + &ndvel=ndvel,num_vert_mix=num_vert_mix, & +#endif + &Tsq=tsq,Qsq=qsq,Cov=cov, & + &RUBLTEN=rublten,RVBLTEN=rvblten,RTHBLTEN=rthblten, & + &RQVBLTEN=rqvblten,RQCBLTEN=rqcblten,RQIBLTEN=rqiblten,& + &RQNIBLTEN=rqniblten, & + &EXCH_H=exch_h,EXCH_M=exch_m, & + &pblh=pblh,KPBL=KPBL & &,el_pbl=el_pbl & &,dqke=dqke & &,qWT=qWT,qSHEAR=qSHEAR,qBUOY=qBUOY,qDISS=qDISS & -! for grims shallow convection - &,WSTAR=wstar,DELTA=delta & + &,WSTAR=wstar,DELTA=delta & ! for grims shallow-cu &,bl_mynn_tkebudget=bl_mynn_tkebudget & &,bl_mynn_cloudpdf=bl_mynn_cloudpdf & + &,bl_mynn_mixlength=bl_mynn_mixlength & + &,icloud_bl=icloud_bl,qc_bl=qc_bl & !JOE-subgrid bl clouds + &,cldfra_bl=cldfra_bl & !JOE-subgrid bl clouds + &,bl_mynn_edmf=bl_mynn_edmf & + &,bl_mynn_edmf_mom=bl_mynn_edmf_mom & + &,bl_mynn_edmf_tke=bl_mynn_edmf_tke & + &,bl_mynn_edmf_part=bl_mynn_edmf_part & + &,bl_mynn_cloudmix=bl_mynn_cloudmix & + &,bl_mynn_mixqt=bl_mynn_mixqt & + &,edmf_a=edmf_a,edmf_w=edmf_w,edmf_qt=edmf_qt & + &,edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc & &,FLAG_QI=flag_qi,FLAG_QNI=flag_qni & &,FLAG_QC=flag_qc,FLAG_QNC=flag_qnc & ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde & diff --git a/wrfv2_fire/phys/module_physics_init.F b/wrfv2_fire/phys/module_physics_init.F index 7d1b1c70..2e924584 100644 --- a/wrfv2_fire/phys/module_physics_init.F +++ b/wrfv2_fire/phys/module_physics_init.F @@ -89,6 +89,8 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & m_ps_1,m_ps_2,m_hybi,aerosolc_1,aerosolc_2,& ! Optional RUNDGDTEN,RVNDGDTEN,RTHNDGDTEN, & ! Optional RPHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN, & ! Optional + SDA_HFX, SDA_QFX, QNORM, HFX_BOTH, QFX_BOTH, & ! fasdas + HFX_FDDA, & ! fasdas FGDT,STEPFG, & ! Optional cugd_tten,cugd_ttens,cugd_qvten, & ! Optional cugd_qvtens,cugd_qcten, & ! Optional @@ -98,6 +100,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & CHXY, FWETXY, SNEQVOXY, ALBOLDXY, QSNOWXY, & ! Optional Noah-MP WSLAKEXY, ZWTXY, WAXY, WTXY, LFMASSXY, RTMASSXY, & ! Optional Noah-MP STMASSXY, WOODXY, STBLCPXY, FASTCPXY, & ! Optional Noah-MP + GRAINXY, GDDXY, & ! Optional Noah-MP XSAIXY, LAI, & ! Optional Noah-MP T2MVXY, T2MBXY, CHSTARXY , & ! Optional Noah-MP SMOISEQ ,SMCWTDXY ,RECHXY, DEEPRECHXY, AREAXY, & ! Optional Noah-MP @@ -192,6 +195,9 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & nssl_cnor, nssl_cnos, & nssl_rho_qh, nssl_rho_qhl, & nssl_rho_qs, & +! next 2 flags for Explicit lightning: + nssl_ipelec, & + nssl_isaund, & ! OPTIONAL RQCNCUTEN, RQINCUTEN, & rliq, & !BSINGH:01/31/2013 - Added rliq and is_CAMMGMP_used for CAM5 physics @@ -451,6 +457,8 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: RTMASSXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: STMASSXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: WOODXY + REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: GRAINXY + REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: GDDXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: STBLCPXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: FASTCPXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: XSAIXY @@ -472,6 +480,8 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: RIVERCONDXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: PEXPXY +! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL, INTENT(INOUT ) :: qnn_curr + INTEGER , OPTIONAL, INTENT(OUT) :: STEPWTD REAL , OPTIONAL, INTENT(IN) :: WTDDT @@ -494,6 +504,15 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & INTEGER , OPTIONAL, INTENT(OUT) :: STEPFG REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , OPTIONAL, INTENT(INOUT) :: &!BSINGH(PNNL)- should be declared inout RUNDGDTEN, RVNDGDTEN, RTHNDGDTEN, RPHNDGDTEN, RQVNDGDTEN +! +! FASDAS +! + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT), OPTIONAL :: & + SDA_HFX, SDA_QFX, QNORM, HFX_BOTH, QFX_BOTH +! INTEGER, INTENT(IN ) :: fasdas + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , OPTIONAL, INTENT(INOUT) :: & + HFX_FDDA +! REAL, DIMENSION( ims:ime , jms:jme ) , OPTIONAL, INTENT(INOUT) :: & RMUNDGDTEN @@ -661,12 +680,13 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & TYPE(fdob_type), OPTIONAL, INTENT(INOUT) :: fdob #endif REAL, OPTIONAL, INTENT(IN) :: p00, t00, tlp ! for obs-nudging base-state calcn - REAL, OPTIONAL, INTENT(IN) :: nssl_cccn, nssl_alphah, nssl_alphahl, & + REAL, INTENT(IN) :: nssl_cccn, nssl_alphah, nssl_alphahl, & nssl_cnoh, nssl_cnohl, & nssl_cnor, nssl_cnos, & nssl_rho_qh, nssl_rho_qhl, & nssl_rho_qs + INTEGER, INTENT(IN) :: nssl_ipelec,nssl_isaund ! WA 12/21/09 REAL,OPTIONAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & @@ -758,6 +778,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & has_reqc = 0 has_reqi = 0 has_reqs = 0 + IF ( config_flags%use_mp_re .EQ. 1 ) THEN if ((config_flags%ra_lw_physics .eq. RRTMG_LWSCHEME .or. config_flags%ra_lw_physics .eq. RRTMG_LWSCHEME_FAST) .and. & (config_flags%ra_sw_physics .eq. RRTMG_SWSCHEME .or. config_flags%ra_sw_physics .eq. RRTMG_SWSCHEME_FAST) .and. & (config_flags%mp_physics .eq. THOMPSON .or. & @@ -774,6 +795,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & has_reqi = 1 has_reqs = 1 endif + ENDIF !-- should be from the namelist @@ -804,7 +826,14 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & CALL nl_get_iswater(id,iswater) CALL nl_get_isice(id,isice) CALL nl_get_isurban(id,isurban) - CALL nl_get_mminlu( 1, mminlu_loc ) +!jm CALL nl_get_mminlu( 1, mminlu_loc ) + CALL nl_get_mminlu( id, mminlu_loc ) +#if (NMM_CORE == 1 && HWRF == 1 ) + IF ( trim(mminlu_loc) .eq. "" ) THEN + CALL wrf_message('WARNING: MMINLU NOT SET, USING USGS') + MMINLU_LOC = 'USGS' + ENDIF +#endif CALL wrf_debug(100,'after nl_get_iswater, nl_get_isice, nl_get_mminlu_loc') !-- temporary fix by ww landuse_ISICE = isice @@ -828,7 +857,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & #endif CALL nl_set_icloud_cu ( id , icloud_cu ) - IF(.not.restart)THEN + IF(.not.restart)THEN !{ !-- initialize common variables !BSINGH - When all the CAM parameterizations are not executed in WRF, !rliq can have undefined behaviour @@ -987,7 +1016,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & its, ite, jts, jte, kts, kte ) ENDIF - ENDIF + ENDIF !} !-- convert zfull and zhalf to sigma values for ra_init (Eta CO2 needs these) !-- zfull/zhalf may be either zeta or eta @@ -1089,6 +1118,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & CHXY, FWETXY, SNEQVOXY, ALBOLDXY, QSNOWXY, & WSLAKEXY, ZWTXY, WAXY, WTXY, LFMASSXY, RTMASSXY,& STMASSXY, WOODXY, STBLCPXY, FASTCPXY, & + GRAINXY, GDDXY, & XSAIXY, LAI, & SMOISEQ, SMCWTDXY, RECHXY, DEEPRECHXY, AREAXY, & WTDDT, STEPWTD, QRFSXY ,QSPRINGSXY ,QSLATXY, & @@ -1242,6 +1272,7 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & !CAMMGMP specific variables ixcldliq, ixcldice, ixnumliq, ixnumice, & nssl_cccn, nssl_alphah, nssl_alphahl, & + nssl_ipelec, nssl_isaund, & nssl_cnoh, nssl_cnohl, & nssl_cnor, nssl_cnos, & nssl_rho_qh, nssl_rho_qhl, & @@ -1257,6 +1288,8 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf, & CALL fg_init(STEPFG,FGDT,DT,id,RUNDGDTEN,RVNDGDTEN, & RTHNDGDTEN,RPHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN, & + SDA_HFX, SDA_QFX, QNORM, HFX_BOTH, QFX_BOTH, & ! fasdas + HFX_FDDA, & ! fasdas config_flags,restart, & allowed_to_read , & ids, ide, jds, jde, kds, kde, & @@ -1421,6 +1454,7 @@ SUBROUTINE landuse_init(lu_index, snowc, albedo, albbck, snoalb, mavail, emiss, 'module_physics_init.F: LANDUSE_INIT: open failure for LANDUSE.TBL' CALL wrf_error_fatal ( message ) END IF + REWIND(landuse_unit) ENDIF ! Read info from file LANDUSE.TBL @@ -1458,6 +1492,7 @@ SUBROUTINE landuse_init(lu_index, snowc, albedo, albbck, snoalb, mavail, emiss, ENDIF CALL wrf_dm_bcast_bytes (end_of_file, LWORDSIZE ) IF ( .NOT. end_of_file ) THEN + CALL wrf_dm_bcast_bytes (lucats, IWORDSIZE ) CALL wrf_dm_bcast_string(lutype, 256) CALL wrf_dm_bcast_bytes (lucats, IWORDSIZE ) CALL wrf_dm_bcast_bytes (luseas, IWORDSIZE ) @@ -1756,7 +1791,11 @@ SUBROUTINE ra_init(id,STEPRA,RADT,DT,RTHRATEN,RTHRATENLW, & ! Read in CAM ozone data, and interpolate data to model grid ! Interpolation is done on domain 1 only +#if (EM_CORE==1) IF ( config_flags%o3input .EQ. 2 .AND. id .EQ. 1 ) THEN +#else + IF ( config_flags%o3input .EQ. 2 ) THEN +#endif CALL oznini(ozmixm,pin,levsiz,n_ozmixm,XLAT, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -1990,6 +2029,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & CHXY, FWETXY, SNEQVOXY, ALBOLDXY, QSNOWXY, & WSLAKEXY, ZWTXY, WAXY, WTXY, LFMASSXY, RTMASSXY,& STMASSXY, WOODXY, STBLCPXY, FASTCPXY, & + GRAINXY, GDDXY, & XSAIXY, LAI, & SMOISEQ, SMCWTDXY, RECHXY, DEEPRECHXY, AREAXY, & WTDDT, STEPWTD,QRFSXY ,QSPRINGSXY ,QSLATXY, & @@ -2111,6 +2151,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & USE module_sf_myjsfc USE module_sf_qnsesfc USE module_sf_noahdrv + USE module_sf_noahlsm, only : LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL USE module_sf_noahmpdrv #ifdef WRF_USE_CLM USE module_sf_clm, only : clminit @@ -2263,6 +2304,8 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: RTMASSXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: STMASSXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: WOODXY + REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: GRAINXY + REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: GDDXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: STBLCPXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: FASTCPXY REAL, OPTIONAL, DIMENSION(ims:ime,jms:jme) :: XSAIXY @@ -2644,6 +2687,17 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & #endif CASE (LSMSCHEME) + + IF(TRIM(mminlu) .EQ. 'NLCD40')THEN + CALL wrf_message('Using NLCD40 for Noah, redefine urban categories ') + DO j=jts,jte + DO i=its,ite + IF(IVGTYP(i,j)==23) IVGTYP(i,j) = 24 + IF(IVGTYP(i,j)==25) IVGTYP(i,j) = 24 + ENDDO + ENDDO + ENDIF + CALL LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & SMSTOT, SFCRUNOFF,UDRUNOFF,ACSNOW, & ACSNOM,IVGTYP,ISLTYP,TSLB,SMOIS,SH2O,ZS,DZS, & @@ -2669,6 +2723,9 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & CALL urban_var_init(ISURBAN,TSK,TSLB,TMN,IVGTYP, & !urban ims,ime,jms,jme,kms,kme,num_soil_layers, & !urban ! num_roof_layers,num_wall_layers,num_road_layers, & !urban + LOW_DENSITY_RESIDENTIAL, & + HIGH_DENSITY_RESIDENTIAL, & + HIGH_INTENSITY_INDUSTRIAL, & restart,sf_urban_physics, & !urban XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & !urban TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & !urban @@ -2738,6 +2795,10 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & ! CASE (NOAHMPSCHEME) + IF ( TRIM(mminlu) .EQ. 'NLCD40' ) THEN + CALL wrf_error_fatal ( 'NoahMP does not work with NLCD data. Stop.' ) + ENDIF + CALL NOAHMP_INIT(MMINLU, SNOW,SNOWH,CANWAT,ISLTYP,IVGTYP, & TSLB,SMOIS,SH2O,DZS, FNDSOILW, FNDSNOWH, & TSK,isnowxy ,tvxy ,tgxy ,canicexy ,TMN,XICE, & @@ -2745,6 +2806,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & fwetxy ,sneqvoxy ,alboldxy ,qsnowxy ,wslakexy ,zwtxy ,waxy , & wtxy ,tsnoxy ,zsnsoxy ,snicexy ,snliqxy ,lfmassxy ,rtmassxy , & stmassxy ,woodxy ,stblcpxy ,fastcpxy ,xsaixy ,lai , & + grainxy ,gddxy , & t2mvxy ,t2mbxy ,chstarxy , & num_soil_layers, restart, & allowed_to_read, iopt_run , & @@ -2802,12 +2864,19 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & if(config_flags%ra_sw_physics .eq. 2 .or. config_flags%ra_sw_physics .gt. 4)CALL wrf_error_fatal & ( 'module_physics_init: SSiB only works with rrtm, cam scheme or rrtmg scheme (sw_phys=1,3,4)' ) ! End of Adding radiation scheme 4 (RRTMg) for SSiB, By Zhenxin 2011-06-20 ************** + IF ( TRIM(mminlu) .EQ. 'NLCD40' ) THEN + CALL wrf_error_fatal ( 'SSIB does not work with NLCD data. Stop.' ) + ENDIF !-------------------------------------------------------------- ! CLM Init Coupling CASE (CLMSCHEME) IF ((SF_URBAN_PHYSICS.eq.1).OR.(SF_URBAN_PHYSICS.EQ.2).OR.(SF_URBAN_PHYSICS.EQ.3)) THEN CALL wrf_error_fatal ( 'CLM DOES NOT WORK WITH URBAN SCHEME' ) ENDIF + IF ( TRIM(mminlu) .EQ. 'NLCD40' ) THEN + CALL wrf_error_fatal ( 'CLM does not work with NLCD input. Stop' ) + ENDIF + #ifdef WRF_USE_CLM IF(PRESENT(numc))THEN ! added by Jiming Jin 10/14/2012 ; modified to use MODIS data 3/6/2014 @@ -2906,7 +2975,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & CASE (YSUSCHEME) if(isfc .ne. 1)CALL wrf_error_fatal & - ( 'module_physics_init: use sfclay scheme for this pbl option' ) + ( 'module_physics_init: Use sf_sfclay_physics= 1 or 91 for this pbl option' ) IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal & ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' ) CALL ysuinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & @@ -2919,7 +2988,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & its, ite, jts, jte, kts, kte ) CASE (SHINHONGSCHEME) if(isfc .ne. 1)CALL wrf_error_fatal & - ( 'module_physics_init: use sfclay scheme for this pbl option' ) + ( 'module_physics_init: Use sf_sfclay_physics= 1 or 91 for this pbl option' ) IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal & ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' ) CALL shinhonginit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,& @@ -2932,7 +3001,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & its, ite, jts, jte, kts, kte ) CASE (MRFSCHEME) if(isfc .ne. 1)CALL wrf_error_fatal & - ( 'module_physics_init: use sfclay scheme for this pbl option' ) + ( 'module_physics_init: Use sf_sfclay_physics= 1 or 91 for this pbl option' ) IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal & ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' ) CALL mrfinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & @@ -3103,7 +3172,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN, & CASE (GBMPBLSCHEME) if(isfc .ne. 1)CALL wrf_error_fatal & - ( 'module_physics_init: use sfclay scheme for this pbl option' ) + ( 'module_physics_init: Use sf_sfclay_physics= 1 or 91 for this pbl option' ) CALL gbmpblinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN, & RQCBLTEN,RQIBLTEN,P_QI, & PARAM_FIRST_SCALAR,TKE_PBL, & @@ -3457,17 +3526,6 @@ SUBROUTINE shcu_init(STEPCU,CUDT,DT,RUSHTEN,RVSHTEN,RTHSHTEN, & STEPCU = nint(CUDT*60./DT) STEPCU = max(STEPCU,1) -!-- initialization - - IF(start_of_simulation)THEN - DO j=jts,jtf - DO i=its,itf - RAINC(i,j)=0. - RAINCV(i,j)=0. - ENDDO - ENDDO - ENDIF - !-- independent shallow convection schemes shcu_select: SELECT CASE(config_flags%shcu_physics) @@ -3505,6 +3563,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, !CAMMGMP specific variables ixcldliq, ixcldice, ixnumliq, ixnumice, & nssl_cccn, nssl_alphah, nssl_alphahl, & + nssl_ipelec, nssl_isaund, & nssl_cnoh, nssl_cnohl, & nssl_cnor, nssl_cnos, & nssl_rho_qh, nssl_rho_qhl, & @@ -3519,6 +3578,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, USE module_mp_wsm5 USE module_mp_wsm6 USE module_mp_etanew + USE module_mp_fer_hires #if (NMM_CORE == 1) USE module_mp_HWRF #endif @@ -3530,8 +3590,8 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ! USE module_mp_milbrandt3mom USE module_mp_wdm5 USE module_mp_wdm6 -#if (EM_CORE==1) USE module_mp_nssl_2mom +#if (EM_CORE==1) USE module_mp_cammgmp_driver, ONLY:CAMMGMP_INIT !CAM5's microphysics #endif !------------------------------------------------------------------ @@ -3547,6 +3607,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, nssl_cnor, nssl_cnos, & nssl_rho_qh, nssl_rho_qhl, & nssl_rho_qs + INTEGER, INTENT(IN), OPTIONAL :: nssl_ipelec, nssl_isaund LOGICAL , INTENT(IN) :: start_of_simulation INTEGER , INTENT(IN) :: ixcldliq, ixcldice, ixnumliq, ixnumice ! CAMMGMP specific variables @@ -3570,6 +3631,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ! Local INTEGER :: i, j, itf, jtf REAL, DIMENSION(20) :: nssl_params + INTEGER :: nssl_ipelec_tmp warm_rain = .false. adv_moist_cond = .true. @@ -3587,6 +3649,17 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ENDIF IF ( present( nssl_cccn ) ) THEN + SELECT CASE(config_flags%mp_physics) + CASE (NSSL_2MOM,NSSL_2MOMCCN) + IF ( config_flags%elec_physics > 0 ) THEN + nssl_ipelec_tmp = nssl_ipelec + ELSE + nssl_ipelec_tmp = 0.0 + ENDIF + CASE DEFAULT + nssl_ipelec_tmp = 0.0 + END SELECT + nssl_params(1) = nssl_cccn nssl_params(2) = nssl_alphah nssl_params(3) = nssl_alphahl @@ -3597,6 +3670,9 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, nssl_params(8) = nssl_rho_qh nssl_params(9) = nssl_rho_qhl nssl_params(10) = nssl_rho_qs + nssl_params(11) = nssl_ipelec_tmp + nssl_params(12) = nssl_isaund + ENDIF mp_select: SELECT CASE(config_flags%mp_physics) @@ -3618,6 +3694,13 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) + CASE (FER_MP_HIRES,FER_MP_HIRES_ADVECT) + CALL fer_hires_init (MPDT,DT,DX,DY,LOWLYR,restart, & + allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & + F_ICE_PHY,F_RAIN_PHY,F_RIMEF_PHY) #if(NMM_CORE==1) CASE (etamp_HWRF) CALL etanewinit_HWRF (MPDT,DT,DX,DY,LOWLYR,restart, & @@ -3668,6 +3751,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, IF(start_of_simulation.or.restart)THEN CALL fast_hucminit(dt) END IF +#endif CASE (NSSL_1MOMLFO) CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=0,mixphase=0,ihvol=-1) ! no separate hail CASE (NSSL_1MOM) @@ -3679,8 +3763,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain, CASE (NSSL_2MOMCCN) ccn_conc = nssl_cccn/1.225 ! set this to have correct boundary conditions CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=5,mixphase=0,ihvol=1) -! CASE (NSSL_3MOM) -! CALL nssl_2mom_init(ims,ime, jms,jme, kms,kme,nssl_params,ipctmp=8,mixphase=0,ihvol=1) +#if (EM_CORE==1) CASE (CAMMGMPSCHEME) ! CAM5's microphysics CALL CAMMGMP_INIT(ixcldliq, ixcldice, ixnumliq, ixnumice & ,config_flags%chem_opt & @@ -3699,6 +3782,8 @@ END SUBROUTINE mp_init !========================================================== SUBROUTINE fg_init(STEPFG,FGDT,DT,id,RUNDGDTEN,RVNDGDTEN, & RTHNDGDTEN,RPHNDGDTEN,RQVNDGDTEN,RMUNDGDTEN, & + SDA_HFX, SDA_QFX, QNORM, HFX_BOTH, QFX_BOTH, & ! fasdas + HFX_FDDA, & ! fasdas config_flags,restart, & allowed_to_read , & ids, ide, jds, jde, kds, kde, & @@ -3728,6 +3813,17 @@ SUBROUTINE fg_init(STEPFG,FGDT,DT,id,RUNDGDTEN,RVNDGDTEN, & RTHNDGDTEN, & RPHNDGDTEN, & RQVNDGDTEN +! +! FASDAS +! + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: & + SDA_HFX, & + SDA_QFX, & + QNORM,HFX_BOTH,QFX_BOTH +! INTEGER , INTENT(IN ) :: fasdas + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: & + HFX_FDDA + REAL, DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: RMUNDGDTEN !BSINGH(PNNL)- should be declared inout LOGICAL, INTENT(IN) :: allowed_to_read @@ -3745,6 +3841,8 @@ SUBROUTINE fg_init(STEPFG,FGDT,DT,id,RUNDGDTEN,RVNDGDTEN, & CASE (PSUFDDAGD) CALL fddagdinit(id,rundgdten,rvndgdten,rthndgdten,rqvndgdten,rmundgdten,& + SDA_HFX, SDA_QFX, QNORM, HFX_BOTH, QFX_BOTH, config_flags%fasdas,& ! fasdas + HFX_FDDA, & ! fasdas config_flags%run_hours, & config_flags%if_no_pbl_nudging_uv, & config_flags%if_no_pbl_nudging_t, & diff --git a/wrfv2_fire/phys/module_ra_aerosol.F b/wrfv2_fire/phys/module_ra_aerosol.F index 9d36ca83..f4163c07 100644 --- a/wrfv2_fire/phys/module_ra_aerosol.F +++ b/wrfv2_fire/phys/module_ra_aerosol.F @@ -387,7 +387,7 @@ subroutine calc_aerosol_rrtmg_sw(ht,dz8w,p,t3d,qv3d,aer_type, aer_aod550_val, aer_angexp_val, aer_ssa_val, aer_asy_val, & aod5502d, angexp2d, aerssa2d, aerasy2d, & ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte, & - tauaer, ssaaer, asyaer ) + tauaer, ssaaer, asyaer, aod5503d ) USE module_wrf_error , ONLY : wrf_err_message @@ -417,9 +417,12 @@ subroutine calc_aerosol_rrtmg_sw(ht,dz8w,p,t3d,qv3d,aer_type, real, dimension(ims:ime, jms:jme), optional, intent(inout) :: aod5502d, angexp2d, aerssa2d, aerasy2d real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS), intent(inout) :: tauaer, ssaaer, asyaer + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: aod5503d ! trude + ! local variables real :: angexp_val,aod_rate,x,xy,xx real, dimension(ims:ime, jms:jme, 1:N_BANDS) :: aod550spc + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS) :: aod550spc3d ! trude real, dimension(ims:ime, kms:kme, jms:jme) :: rh ! relative humidity call calc_relative_humidity(p,t3d,qv3d, & @@ -524,10 +527,36 @@ subroutine calc_aerosol_rrtmg_sw(ht,dz8w,p,t3d,qv3d,aer_type, write( wrf_err_message, '("aer_angexp_opt=",I1,": Angstrom exponent calculated from RH and aer_type ",I1)') & aer_angexp_opt,aer_type call wrf_debug(100, wrf_err_message ) - call calc_spectral_aod_rrtmg_sw(ims,ime,jms,jme,kms,kme, & - its,ite,jts,jte,kts,kte, & - rh,aer_type,aod5502d, & - aod550spc ) + call calc_spectral_aod_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type,aod5502d, & + aod550spc, & + aod5503d, aod550spc3d) ! trude + + do j=jts,jte + do i=its,ite + angexp2d(i,j) = 0.0 + enddo + enddo + + if (present(aod5503d)) then + do j=jts,jte + do k=kts,kte + do i=its,ite + xy=0 + xx=0 + do nb=8,N_BANDS-3 ! bands between 0.4 and 1.0 um + ! the slope of a linear regression with intercept=0 is m=E(xy)/E(x^2), where y=m*x + x=log(0.5*(lower_wvl(nb)+upper_wvl(nb))/0.55) + xy=xy+x*log(aod550spc3d(i,k,j,nb)/aod5503d(i,k,j)) + xx=xx+x*x + end do + angexp2d(i,j) = angexp2d(i,j) - (xy/(N_BANDS-3-8+1))/(xx/(N_BANDS-3-8+1)) + enddo + enddo + enddo + else + ! added July, 16th, 2013: angexp2d is in the wrfout when aer_angexp_opt=3. It is the average ! value in the spectral bands between 0.4 and 1. um do j=jts,jte @@ -543,15 +572,31 @@ subroutine calc_aerosol_rrtmg_sw(ht,dz8w,p,t3d,qv3d,aer_type, angexp2d(i,j)=-(xy/(N_BANDS-3-8+1))/(xx/(N_BANDS-3-8+1)) end do end do + endif case default write(wrf_err_message,*) 'Expected aer_angexp_opt=[1,2,3]. Got',aer_angexp_opt call wrf_error_fatal(wrf_err_message) end select aer_angexp_opt_select - ! exponental -vertical- profile - call aod_profiler(ht,dz8w,aod550spc,n_bands,ims,ime,jms,jme,kms,kme, & +!..If 3D AOD (at 550nm) was provided explicitly, then no need to assume a +!.. vertical distribution, just use what was provided. (Trude) + + if (present(aod5503d)) then + do nb=1,N_BANDS + do j=jts,jte + do k=kts,kte + do i=its,ite + tauaer(i,k,j,nb) = aod550spc3d(i,k,j,nb) + enddo + enddo + enddo + enddo + else + ! exponental -vertical- profile + call aod_profiler(ht,dz8w,aod550spc,n_bands,ims,ime,jms,jme,kms,kme, & its,ite,jts,jte,kts,kte,tauaer ) + endif aer_ssa_opt_select: select case(aer_ssa_opt) !case(0) @@ -961,10 +1006,12 @@ subroutine calc_spectral_asy_goddard_sw(ims,ime,jms,jme,kms,kme, & end do end subroutine calc_spectral_asy_goddard_sw -subroutine calc_spectral_aod_rrtmg_sw(ims,ime,jms,jme,kms,kme, & - its,ite,jts,jte,kts,kte, & - rh,aer_type,aod550, & - tauaer ) +subroutine calc_spectral_aod_rrtmg_sw(ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte, & + rh,aer_type,aod550, & + tauaer, & + aod550_3d, tauaer3d) ! trude + implicit none ! constants @@ -981,8 +1028,13 @@ subroutine calc_spectral_aod_rrtmg_sw(ims,ime,jms,jme,kms,kme, & real, dimension(ims:ime, jms:jme), intent(in) :: aod550 ! Total AOD at 550 nm at surface real, dimension(ims:ime, jms:jme, 1:N_BANDS), intent(inout) :: tauaer ! Total spectral aerosol optical depth at surface + ! ++ Trude + real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(in) :: aod550_3d ! 3D AOD at 550 nm + real, dimension(ims:ime, kms:kme, jms:jme, 1:N_BANDS), optional, intent(inout) :: tauaer3d ! + ! -- Trude + ! local variables - integer :: i,j,k,ib,imax,imin,ii,jj + integer :: i,j,k,ib,imax,imin,ii,jj,kk real :: rhs(N_RH),lj real :: raod_lut(N_AER_TYPES,N_BANDS,N_RH) @@ -1043,7 +1095,37 @@ subroutine calc_spectral_aod_rrtmg_sw(ims,ime,jms,jme,kms,kme, & data (raod_lut(3,ib,8),ib=1,N_BANDS) /0.8836,0.8965,0.9073,0.9149,0.9239,0.9365,0.9448,0.9626,0.9841,1.0069, & 1.0415,1.0712,1.1145,0.8741/ - ! this spectral disaggregation is only at surface (k=kts) + +! ++ Trude ; if 3D AOD, disaggreaget at all levels. + if (present(aod550_3d)) then + do j=jts,jte + do i=its,ite + ! common part of the Lagrange's interpolator + ! only depends on the relative humidity value + do kk = kts,kte + ii=1 + do while ( (ii.le.N_RH) .and. (rh(i,kk,j).gt.rhs(ii)) ) + ii=ii+1 + end do + imin=max(1,ii-N_INT_POINTS/2-1) + imax=min(N_RH,ii+N_INT_POINTS/2) + + do ib=1,N_BANDS + tauaer3d(i,kk,j,ib)=0. + do jj=imin,imax + lj=1. + do k=imin,imax + if (k.ne.jj) lj=lj*(rh(i,kk,j)-rhs(k))/(rhs(jj)-rhs(k)) + end do + tauaer3d(i,kk,j,ib)=tauaer3d(i,kk,j,ib)+lj*raod_lut(aer_type,ib,jj)*aod550_3d(i,kk,j) + end do + end do + end do + end do + end do + else +! -- Trude + do j=jts,jte do i=its,ite ! common part of the Lagrange's interpolator @@ -1067,6 +1149,8 @@ subroutine calc_spectral_aod_rrtmg_sw(ims,ime,jms,jme,kms,kme, & end do end do end do + endif + end subroutine calc_spectral_aod_rrtmg_sw subroutine calc_spectral_ssa_rrtmg_sw(ims,ime,jms,jme,kms,kme, & diff --git a/wrfv2_fire/phys/module_ra_cam.F b/wrfv2_fire/phys/module_ra_cam.F index 7aba770b..3bd9b8ca 100644 --- a/wrfv2_fire/phys/module_ra_cam.F +++ b/wrfv2_fire/phys/module_ra_cam.F @@ -1318,7 +1318,7 @@ subroutine aerosol_indirect(ncol,lchnk,pcols,pver,ppcnst,landfrac,pmid,t,qm1,cld ! use constituents, only: ppcnst, cnst_get_ind ! use history, only: outfld -!#include +!#include "comctl.h" integer, intent(in) :: ncol ! number of atmospheric columns integer, intent(in) :: lchnk ! chunk identifier @@ -1538,7 +1538,7 @@ subroutine aer_pth(aer_mass, aer_mpp, ncol, pcols, plev, plevp) ! use ppgrid ! use pmgrid implicit none -!#include +!#include "crdcon.h" ! Parameters ! Input diff --git a/wrfv2_fire/phys/module_ra_cam_support.F b/wrfv2_fire/phys/module_ra_cam_support.F index 501cb85d..a2964830 100644 --- a/wrfv2_fire/phys/module_ra_cam_support.F +++ b/wrfv2_fire/phys/module_ra_cam_support.F @@ -23,7 +23,9 @@ MODULE module_ra_cam_support integer :: idxBCPHI integer :: idxBG integer :: idxVOLC - + real, pointer :: ozmixin_save(:,:,:,:), lat_ozone_save(:), plev_ozone_save(:) + integer :: levsiz_ozone_save=-1 + logical :: have_ozone=.false. integer :: mxaerl ! Maximum level of background aerosol ! indices to sections of array that represent @@ -1973,7 +1975,7 @@ subroutine background(lchnk, ncol, pint, pcols, pverr, pverrp, mmr) !----------------------------------------------------------------------- implicit none !----------------------------------------------------------------------- -!#include +!#include "ptrrgrid.h" !------------------------------Arguments-------------------------------- ! ! Input arguments @@ -3456,6 +3458,10 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & ! It should be replaced by monthly climatology that varies latitudinally and vertically ! +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + use mpi + use module_dm, only: local_communicator +#endif IMPLICIT NONE INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & @@ -3474,20 +3480,32 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & ! Local INTEGER, PARAMETER :: latsiz = 64 INTEGER, PARAMETER :: lonsiz = 1 - INTEGER :: i, j, k, itf, jtf, ktf, m, pin_unit, lat_unit, oz_unit + INTEGER :: i, j, k, itf, jtf, ktf, m, pin_unit, lat_unit, oz_unit, ierr REAL :: interp_pt - CHARACTER*256 :: message + CHARACTER*255 :: message + real, pointer :: ozmixin(:,:,:,:), lat_ozone(:), plev(:) +! REAL, DIMENSION( lonsiz, levsiz, latsiz, num_months ) :: & +! OZMIXIN - REAL, DIMENSION( lonsiz, levsiz, latsiz, num_months ) :: & - OZMIXIN - - REAL, DIMENSION(latsiz) :: lat_ozone + logical, external :: wrf_dm_on_monitor jtf=min0(jte,jde-1) ktf=min0(kte,kde-1) itf=min0(ite,ide-1) - + if_have_ozone: if(.not.have_ozone) then + call wrf_debug(1,'Do not have ozone. Must read it in.') + ! Allocate and set local aliases: + levsiz_ozone_save=levsiz + allocate(plev_ozone_save(levsiz),lat_ozone_save(latsiz)) + allocate(ozmixin_save(lonsiz, levsiz, latsiz, num_months)) + plev=>plev_ozone_save + lat_ozone=>lat_ozone_save + ozmixin=>ozmixin_save +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + if_master: if(wrf_dm_on_monitor()) then + call wrf_debug(1,'Master rank reads ozone.') +#endif !-- read in ozone pressure data WRITE(message,*)'num_months = ',num_months @@ -3496,13 +3514,14 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & pin_unit = 27 OPEN(pin_unit, FILE='ozone_plev.formatted',FORM='FORMATTED',STATUS='OLD') do k = 1,levsiz - READ (pin_unit,*)pin(k) + READ (pin_unit,*)plev(k) end do close(27) do k=1,levsiz - pin(k) = pin(k)*100. + plev(k) = plev(k)*100. end do + pin=plev ! copy to grid array !-- read in ozone lat data @@ -3529,7 +3548,31 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT, & enddo enddo close(29) - +#if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) ) + endif if_master + call wrf_debug(1,"Broadcast ozone to other ranks.") + call MPI_Bcast(ozmixin,size(ozmixin),MPI_REAL,0,local_communicator,ierr) + call MPI_Bcast(pin,size(pin),MPI_REAL,0,local_communicator,ierr) + plev=pin + call MPI_Bcast(lat_ozone,size(lat_ozone),MPI_REAL,0,local_communicator,ierr) +#endif + else ! already read in ozone data + ! Make sure, first: + if(levsiz/=levsiz_ozone_save) then +3081 format('Logic error in caller: levsiz=',I0,' but prior call used ',I0,'.') + write(message,3081) levsiz,levsiz_ozone_save + call wrf_error_fatal(message) + endif + if(.not.(associated(plev_ozone_save) .and. & + associated(lat_ozone_save) .and. & + associated(ozmixin_save))) then + call wrf_error_fatal('Ozone save arrays are not allocated.') + endif + ! Recover the pointers to allocated data: + plev=>plev_ozone_save + lat_ozone=>lat_ozone_save + ozmixin=>ozmixin_save + endif if_have_ozone !-- latitudinally interpolate ozone data (and extend longitudinally) !-- using function lin_interpol2(x, f, y) result(g) diff --git a/wrfv2_fire/phys/module_ra_goddard.F b/wrfv2_fire/phys/module_ra_goddard.F index 7aa50e50..d771ac72 100644 --- a/wrfv2_fire/phys/module_ra_goddard.F +++ b/wrfv2_fire/phys/module_ra_goddard.F @@ -269,10 +269,11 @@ subroutine goddardrad( rthraten, gsf, xlat,xlong & julian ! julian day (1-365) ! jararias, 14/08/2013 ! jararias, 2013/11 - real, dimension( ims:ime, kms:kme, jms:jme, ib_sw ), optional, intent(in) :: & - tauaer3d_sw, & ! 3D aerosol optical depth for SW bands - ssaaer3d_sw, & ! 3D single scattering albedo for SW bands - asyaer3d_sw ! 3D asymmetry factor for SW bands +! real, dimension( ims:ime, kms:kme, jms:jme, ib_sw ), optional, intent(in) :: & +! tauaer3d_sw, & ! 3D aerosol optical depth for SW bands +! ssaaer3d_sw, & ! 3D single scattering albedo for SW bands +! asyaer3d_sw ! 3D asymmetry factor for SW bands + real, dimension(:,:,:,:), pointer :: tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw integer, intent(in) :: aer_opt !------- Local variables ---------------------------------------------- @@ -919,9 +920,10 @@ subroutine goddardrad( rthraten, gsf, xlat,xlong & end do end do + if ( associated (tauaer3d_sw) ) then ! jararias 2013/11 - if ( present (tauaer3d_sw) ) then - if ( aer_opt .eq. 2 ) then +! if ( present (tauaer3d_sw) ) then +! if ( aer_opt .eq. 2 ) then do ib=1,ib_sw do i=its,ite taual_sw(i,kts-1,ib)=0. @@ -935,7 +937,7 @@ subroutine goddardrad( rthraten, gsf, xlat,xlong & end do end do end do - end if +! end if end if ! ! 1-dimension driver of shortwave radiative transfer scheme diff --git a/wrfv2_fire/phys/module_ra_rrtmg_lw.F b/wrfv2_fire/phys/module_ra_rrtmg_lw.F index 5305bb55..85f28d57 100644 --- a/wrfv2_fire/phys/module_ra_rrtmg_lw.F +++ b/wrfv2_fire/phys/module_ra_rrtmg_lw.F @@ -11374,6 +11374,11 @@ MODULE module_ra_rrtmg_lw use module_model_constants, only : cp use module_wrf_error +#if (HWRF == 1) + USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF +#else + USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT +#endif !use module_dm use parrrtm, only : nbndlw, ngptlw @@ -11438,6 +11443,7 @@ SUBROUTINE RRTMG_LWRAD( & !ccc added for time varying gases. yr,julian, & !ccc + mp_physics, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -11457,6 +11463,7 @@ SUBROUTINE RRTMG_LWRAD( & its,ite, jts,jte, kts,kte INTEGER, INTENT(IN ) :: ICLOUD + INTEGER, INTENT(IN ) :: MP_PHYSICS ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & INTENT(IN ) :: dz8w, & @@ -11572,10 +11579,15 @@ SUBROUTINE RRTMG_LWRAD( & QC1D, & QR1D, & QI1D, & + RHO1D, & QS1D, & QG1D, & O31D, & qndrop1d +!BSF: From eq. (5) on p. 2434 in McFarquhar & Heymsfield (1996) + real, parameter :: re_50C=1250.0/9.917, re_40C=1250.0/9.337, & + re_30C=1250.0/9.208, re_20C=1250.0/9.387 + ! Added local arrays for RRTMG integer :: ncol, & @@ -11740,7 +11752,7 @@ SUBROUTINE RRTMG_LWRAD( & INTEGER, PARAMETER :: nproflevs = 60 ! Constant, from the table INTEGER :: L, LL, klev ! Loop indices REAL, DIMENSION( kts:nlayers+1 ) :: varint - REAL :: wght,vark,vark1 + REAL :: wght,vark,vark1,tem1,tem2,tem3 REAL :: PPROF(nproflevs), TPROF(nproflevs) ! Weighted mean pressure and temperature profiles from midlatitude ! summer (MLS),midlatitude winter (MLW), sub-Arctic @@ -11853,6 +11865,7 @@ SUBROUTINE RRTMG_LWRAD( & TTEN1D(K)=0. T1D(K)=T3D(I,K,J) P1D(K)=P3D(I,K,J)/100. + RHO1D(K)=RHO3D(I,K,J) DZ1D(K)=dz8w(I,K,J) ENDDO @@ -11955,6 +11968,24 @@ SUBROUTINE RRTMG_LWRAD( & ENDIF +! For mp option=5 or 85 (new Ferrier- Aligo or fer_hires scheme), QI3D saves all +#if (HWRF == 1) + IF ( mp_physics == FER_MP_HIRES .OR. & + mp_physics == FER_MP_HIRES_ADVECT .OR. & + mp_physics == ETAMP_HWRF ) THEN +#else + IF ( mp_physics == FER_MP_HIRES .OR. & + mp_physics == FER_MP_HIRES_ADVECT) THEN +#endif + DO K=kts,kte + qi1d(k) = qi3d(i,k,j) + qs1d(k) = 0.0 + qc1d(k) = qc3d(i,k,j) + qi1d(k) = max(0.,qi1d(k)) + qc1d(k) = max(0.,qc1d(k)) + ENDDO + ENDIF + ! EMISS0=EMISS(I,J) ! GLW0=0. ! OLR0=0. @@ -12016,19 +12047,38 @@ SUBROUTINE RRTMG_LWRAD( & inflglw = 4 iceflglw = 4 DO K=kts,kte - reice1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6) - if (reice1D(ncol,K).LE.10..AND.cldfra3d(i,k,j).gt.0.) then + reice1D(ncol,K) = MAX(5., re_ice(I,K,J)*1.E6) + if (reice1D(ncol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then idx_rei = int(t3d(i,k,j)-179.) idx_rei = min(max(idx_rei,1),75) corr = t3d(i,k,j) - int(t3d(i,k,j)) reice1D(ncol,K) = retab(idx_rei)*(1.-corr) + & & retab(idx_rei+1)*corr - reice1D(ncol,K) = MAX(reice1D(ncol,K), 10.0) + reice1D(ncol,K) = MAX(reice1D(ncol,K), 5.0) endif ENDDO ELSE DO K=kts,kte +#if (EM_CORE==1) reice1D(ncol,K) = 10.0 +#else + tem2 = 25.0 !- was 10.0 + tem3=1.e3*rho1d(k)*qi1d(k) !- IWC (g m^-3) + if (tem3>thresh) then !- Only when IWC>1.e-9 gm^-3 + tem1=t1d(k)-273.15 + if (tem1 < -50.0) then + tem2 = re_50C*tem3**0.109 + elseif (tem1 < -40.0) then + tem2 = re_40C*tem3**0.08 + elseif (tem1 < -30.0) then + tem2 = re_30C*tem3**0.055 + else + tem2 = re_20C*tem3**0.031 + endif + tem2 = max(25.,tem2) + endif + reice1D(ncol,K) = min(tem2, 135.72) !- 1.0315*reice<= 140 microns +#endif ENDDO ENDIF @@ -12351,7 +12401,12 @@ SUBROUTINE RRTMG_LWRAD( & reliq(ncol,k) = recloud1d(ncol,k) end do endif +#if (EM_CORE==1) if (iceflglw .ge. 4) then +#else + if (iceflglw .ge. 3) then !BSF: was .ge. 4 +#endif + do k = kts, kte reice(ncol,k) = reice1d(ncol,k) end do diff --git a/wrfv2_fire/phys/module_ra_rrtmg_lwf.F b/wrfv2_fire/phys/module_ra_rrtmg_lwf.F index d535d315..d1e9607c 100644 --- a/wrfv2_fire/phys/module_ra_rrtmg_lwf.F +++ b/wrfv2_fire/phys/module_ra_rrtmg_lwf.F @@ -3640,8 +3640,7 @@ subroutine mcica_subcol_lwg(colstart, ncol, nlay, icld, permuteseed, irng, ! Dimensions: (ngptlw,ncol,nlay) real _gpudev, intent(out) :: taucmcl(:,:,:) ! in-cloud optical depth [mcica] ! Dimensions: (ngptlw,ncol,nlay) -! integer , intent(out) :: cloudFlag(:,:) - + #ifndef _ACCEL ! were module data but changed to arguments because not thread-safe real :: pmidd(:, :) @@ -4382,11 +4381,9 @@ _gpuker subroutine cldprmcg(ncol, nlayers, absice3d(index,ib) + fint * & (absice3d(index+1,ib) - (absice3d(index,ib))) abscosno = 0.0 - endif !..Incorporate additional effects due to snow. -!STOPPED HERE if (cswpmcd(iplon,ig,lay).gt.0.0 .and. iceflagd(iplon) .eq. 5) then radsno = resnmcd(iplon,lay) @@ -4414,7 +4411,12 @@ _gpuker subroutine cldprmcg(ncol, nlayers, endif ! Calculation of absorption coefficients due to water clouds. - if (liqflagd(iplon) .eq. 1) then +!jm if (liqflagd(iplon) .eq. 1) then + if (clwpmcd(iplon,ig,lay) .eq. 0.0) then + abscoliq = 0.0 + else if (liqflagd(iplon) .eq. 0) then + abscoliq = absliq0 + else if (liqflagd(iplon) .eq. 1) then radliq = relqmcd(iplon, lay) index = int(radliq - 1.5 ) ! mji - temporary fix to prevent out of range subscripts @@ -5033,9 +5035,6 @@ _gpuker subroutine rtrnmcg(ncol, nlayers, istart, iend, iout radlu = rad0 + reflect * radld radclru = rad0 + reflect * radclrd - - - ! Upward radiative transfer loop. gurad(iplon, igc, 0) = gurad(iplon, igc, 0) + radlu gclrurad(iplon, igc, 0) = gclrurad(iplon, igc, 0) + radclru @@ -5161,12 +5160,75 @@ _gpuker subroutine rtrnadd(ncol, nlay, ngpt, drvf & ! (dmb 2012) This kernel computes the heating rates separately. It is parallelized across the ! columnn and layer dimensions. _gpuker subroutine rtrnheatrates(ncol, nlay & -#include "rrtmg_lw_cpu_args.h" +#ifndef _ACCEL + ,ncol_,nlayers_,nbndlw_,ngptlw_ & + ,taucmcd,pzd,pwvcmd,semissd,planklayd,planklevd,plankbndd,gurad,gdrad,gclrurad,gclrdrad & + ,gdtotuflux_dtd,gdtotuclfl_dtd,idrvd,bpaded,heatfacd,fluxfacd,a0d,a1d,a2d & + ,delwaved,totufluxd,totdfluxd,fnetd,htrd,totuclfld,totdclfld,fnetcd,htrcd,dtotuflux_dtd & + ,dtotuclfl_dtd,dplankbnd_dtd & +#endif ) integer, intent(in), value :: ncol integer, intent(in), value :: nlay -#include "rrtmg_lw_cpu_defs.h" +#ifndef _ACCEL + integer :: ncol_,nlayers_,nbndlw_,ngptlw_ +! changed to arguments for thread safety +# ifndef ncol_ +# define ncol_ CHNK +# endif + integer :: ngsd(nbndlw) + +! Atmosphere + real :: taucmcd(ncol_, ngptlw_, nlayers_+1) + + real , dimension(ncol_, 0:nlayers_+1) :: pzd ! level (interface) pressures (hPa, mb) + ! Dimensions: (ncol,0:nlayers) + real , dimension(ncol_) :: pwvcmd ! precipitable water vapor (cm) + ! Dimensions: (ncol) + real , dimension(ncol_,nbndlw_) :: semissd ! lw surface emissivity + ! Dimensions: (ncol,nbndlw) + real , dimension(ncol_,nlayers_+1,nbndlw_) :: planklayd ! + ! Dimensions: (ncol,nlayers+1,nbndlw) + real , dimension(ncol_,0:nlayers_+1,nbndlw_) :: planklevd ! + ! Dimensions: (ncol,0:nlayers+1,nbndlw) + real, dimension(ncol_,nbndlw_) :: plankbndd ! + ! Dimensions: (ncol,nbndlw) + + real :: gurad(ncol_,ngptlw_,0:nlayers_+1) ! upward longwave flux (w/m2) + real :: gdrad(ncol_,ngptlw_,0:nlayers_+1) ! downward longwave flux (w/m2) + real :: gclrurad(ncol_,ngptlw_,0:nlayers_+1) ! clear sky upward longwave flux (w/m2) + real :: gclrdrad(ncol_,ngptlw_,0:nlayers_+1) ! clear sky downward longwave flux (w/m2) + + real :: gdtotuflux_dtd(ncol_, ngptlw_, 0:nlayers_+1) ! change in upward longwave flux (w/m1/k) + ! with respect to surface temperature + + real :: gdtotuclfl_dtd(ncol_, ngptlw_, 0:nlayers_+1) ! change in clear sky upward longwave flux (w/m2/k) + ! with respect to surface temperature + +! Clouds + integer :: idrvd ! flag for calculation of dF/dt from + ! Planck derivative [0=off, 1=on] + real :: bpaded + real :: heatfacd + real :: fluxfacd + real :: a0d(nbndlw_), a1d(nbndlw_), a2d(nbndlw_) + real :: delwaved(nbndlw_) + real :: totufluxd(ncol_, 0:nlayers_+1) ! upward longwave flux (w/m2) + real :: totdfluxd(ncol_, 0:nlayers_+1) ! downward longwave flux (w/m2) + real :: fnetd(ncol_, 0:nlayers_+1) ! net longwave flux (w/m2) + real :: htrd(ncol_, 0:nlayers_+1) ! longwave heating rate (k/day) + real :: totuclfld(ncol_, 0:nlayers_+1) ! clear sky upward longwave flux (w/m2) + real :: totdclfld(ncol_, 0:nlayers_+1) ! clear sky downward longwave flux (w/m2) + real :: fnetcd(ncol_, 0:nlayers_+1) ! clear sky net longwave flux (w/m2) + real :: htrcd(ncol_, 0:nlayers_+1) ! clear sky longwave heating rate (k/day) + real :: dtotuflux_dtd(ncol_, 0:nlayers_+1) ! change in upward longwave flux (w/m2/k) + ! with respect to surface temperature + real :: dtotuclfl_dtd(ncol_, 0:nlayers_+1) ! change in clear sky upward longwave flux (w/m2/k) + ! with respect to surface temperature + real :: dplankbnd_dtd(ncol_,nbndlw_) +# undef ncol_ +#endif real :: t2 integer :: iplon, ilay @@ -13904,6 +13966,7 @@ module rrtmg_lw_rad_f #endif real :: timings(10) + INTEGER, PARAMETER :: debug_level_lwf=100 !------------------------------------------------------------------ contains @@ -14149,6 +14212,7 @@ subroutine rrtmg_lw( & integer :: numThreads integer,external :: omp_get_thread_num + CHARACTER(LEN=256) :: message ! Cuda device information #ifdef _ACCEL @@ -14208,10 +14272,13 @@ subroutine rrtmg_lw( & cn = CHNK #endif ! - print *, "RRTMG_LWF: Number of columns is ", ncol - print *, "RRTMG_LWF: Number of columns per partition is ", cn + WRITE(message,*)'RRTMG_LWF: Number of columns is ',ncol + call wrf_debug( debug_level_lwf, message) + WRITE(message,*)'RRTMG_LWF: Number of columns per partition is ',cn + call wrf_debug( debug_level_lwf, message) ns = ceiling( real(ncol) / real(cn) ) - print *, "RRTMG_LWF: Number of partitions is ", ns + WRITE(message,*)'RRTMG_LWF: Number of partitions is ',ns + call wrf_debug( debug_level_lwf, message) ! mji - time call cpu_time(t1) @@ -14226,7 +14293,6 @@ subroutine rrtmg_lw( & -!write(0,*)__FILE__,__LINE__,i call rrtmg_lw_part & (ns, ncol, (i-1)*cn + 1, min(cn, ncol - (i-1)*cn), & nlay ,icld ,idrv,& @@ -14238,15 +14304,16 @@ subroutine rrtmg_lw( & tauaer , & uflx ,dflx ,hr ,uflxc ,dflxc, hrc, & duflx_dt,duflxc_dt) -!write(0,*)__FILE__,__LINE__,i,'uflx ',uflx(10,10) -!write(0,*)__FILE__,__LINE__,i,'dflx ',dflx(10,10) end do ! mji - time call cpu_time(t2) - print *, "------------------------------------------------" - print *, "TOTAL RRTMG_LWF RUN TIME IS ", t2-t1 - print *, "------------------------------------------------" + WRITE(message,*)'------------------------------------------------' + call wrf_debug( debug_level_lwf, message) + WRITE(message,*)'TOTAL RRTMG_LWF RUN TIME IS ', t2-t1 + call wrf_debug( debug_level_lwf, message) + WRITE(message,*)'------------------------------------------------' + call wrf_debug( debug_level_lwf, message) end subroutine @@ -14644,7 +14711,6 @@ subroutine rrtmg_lw_part & integer,external :: omp_get_thread_num ! -!write(0,*)__FILE__,__LINE__ #ifndef _ACCEL # undef pncol ncol_ = pncol ; nlayers_ = nlay ; nbndlw_ = nbndlw ; ngptlw_ = ngptlw ! for passing through argument list @@ -14687,10 +14753,8 @@ subroutine rrtmg_lw_part & allocate( ncbandsd(pncol)) allocate( icldlyr(pncol, nlay+1)) -!write(0,*)__FILE__,__LINE__ call allocateGPUcldprmcg(pncol, nlay, ngptlw) call allocateGPUrtrnmcg(pncol, nlay, ngptlw, idrv) -!write(0,*)__FILE__,__LINE__ ngbd = ngb ngsd = ngs @@ -14742,21 +14806,17 @@ subroutine rrtmg_lw_part & nlayers = nlay -!write(0,*)__FILE__,__LINE__ call allocateGPUTaumol( pncol, nlayers, npart) -!write(0,*)__FILE__,__LINE__ #ifdef _ACCEL allocate( fracsd( pncol, nlayers+1, ngptlw )) allocate( taug( pncol, nlayers+1, ngptlw )) #endif -!write(0,*)__FILE__,__LINE__ tbound = tsfc(colstart:(colstart+pncol-1)) pz(:,0:nlay) = plev(colstart:(colstart+pncol-1),0:nlay) tz(:,0:nlay) = tlev(colstart:(colstart+pncol-1),0:nlay) pavel(:,1:nlay) = play(colstart:(colstart+pncol-1),1:nlay) tavel(:,1:nlay) = tlay(colstart:(colstart+pncol-1),1:nlay) -!write(0,*)__FILE__,__LINE__ #ifdef _ACCEL call copyGPUTaumolMol( colstart, pncol, nlayers, h2ovmr, co2vmr, o3vmr, n2ovmr, ch4vmr, & @@ -14785,7 +14845,6 @@ subroutine rrtmg_lw_part & # undef pncol #endif -!write(0,*)__FILE__,__LINE__ permuteseed=150 ! if you change this, change value in module_ra_rrtmg_lw.F call mcica_subcol_lwg(colstart, pncol, nlay, icld, counter, permuteseed, & #ifndef _ACCEL @@ -14793,8 +14852,9 @@ subroutine rrtmg_lw_part & #endif play, cldfracq, ciwpq, & clwpq, cswpq, taucq,ngbd, cldfmcd, ciwpmcd, clwpmcd, cswpmcd, & - taucmcd) -!write(0,*)__FILE__,__LINE__ + taucmcd) + + !jm write(0,*)__FILE__,__LINE__,omp_get_thread_num() ! Generate the stochastic subcolumns of cloud optical properties for the longwave; @@ -14803,15 +14863,12 @@ subroutine rrtmg_lw_part & dimBlock = dim3( 256,2,1) #endif if (icld > 0) then -!write(0,*)__FILE__,__LINE__ call generate_stochastic_cloudsg _gpuchv (pncold, nlayd, icldd, ngbd, & #ifndef _ACCEL pmid,cldfracq,clwpq,ciwpq,cswpq,taucq,permuteseed, & #endif cldfmcd, clwpmcd, ciwpmcd, cswpmcd, taucmcd) -!write(0,*)__FILE__,__LINE__ end if -!write(0,*)__FILE__,__LINE__ !jm write(0,*)__FILE__,__LINE__,omp_get_thread_num() do iplon = 1, pncol @@ -14846,11 +14903,10 @@ subroutine rrtmg_lw_part & ! Move incoming GCM cloud arrays to RRTMG cloud arrays. ! For GCM input, incoming reicmcl is defined based on selected ice parameterization (inflglw) - + endif enddo -!write(0,*)__FILE__,__LINE__ #ifdef _ACCEL deallocate( pmidd, cldfracd) deallocate( clwpd, ciwpd, cswpd, taucd) @@ -14894,9 +14950,7 @@ subroutine rrtmg_lw_part & ! (dmb 2012) Copy the needed data of to the GPU for the SetCoef and Taumol kernels -!write(0,*)__FILE__,__LINE__ call copyGPUTaumol( pavel, wx, coldry, tauaer, pncol, colstart, nlay , npart) -!write(0,*)__FILE__,__LINE__ call copyGPUSetCoef( ) ! (dmb 2012) Copy over additional common arrays @@ -14938,15 +14992,13 @@ subroutine rrtmg_lw_part & ! clwpmcd = 0 ! clwpmcd = clwpmc ! (dmb 2012) Call the cldprmcg kernel -!write(0,*)__FILE__,__LINE__ call cldprmcg _gpuchv (pncol, nlayers, & #ifndef _ACCEL inflag,iceflag,liqflag,ciwpmcd,clwpmcd,cswpmcd,relqmcd,reicmcd,resnmcd, & - absice0,absice1,absice2,absice3,absliq1, & + absice0,absice1,absice2,absice3,absliq1, & #endif - cldfmcd, taucmcd, ngbd, icbd, ncbandsd, icldlyr) + cldfmcd, taucmcd, ngbd, icbd, ncbandsd, icldlyr) -!write(0,*)__FILE__,__LINE__ ! synchronize the GPU with the CPU before taking timing results or passing data back to the CPU #ifdef _ACCEL ierr = cudaThreadSynchronize() @@ -14970,7 +15022,6 @@ subroutine rrtmg_lw_part & ,tavel,tz,tbound,wbroadd,totplnk,totplk16,totplnkderiv,totplk16deriv & #endif ) -!write(0,*)__FILE__,__LINE__ ! (dmb 2012) end if GPU flag @@ -14979,7 +15030,16 @@ subroutine rrtmg_lw_part & ! (dmb 2012) Call the taumolg subroutine. This subroutine calls all of the individal taumol kernels. call taumolg(1, pncol,nlayers, ngbd, taug, fracsd & -# include "taug_cpu_args.h" +!# include "taug_cpu_args.h" +#ifndef _ACCEL + ,ncol__,nlayers__,nbndlw__,ngptlw__ & + ,pavel,wx1,wx2,wx3,wx4,coldry,laytrop,jp,jt,jt1,colh2o,colco2,colo3,coln2o & + ,colco,colch4,colo2,colbrd,indself,indfor,selffac,selffrac,forfac,forfrac & + ,indminor,minorfrac,scaleminor,scaleminorn2,fac00,fac01,fac10,fac11 & + ,rat_h2oco2,rat_h2oco2_1,rat_h2oo3,rat_h2oo3_1,rat_h2on2o,rat_h2on2o_1 & + ,rat_h2och4,rat_h2och4_1,rat_n2oco2,rat_n2oco2_1,rat_o3co2,rat_o3co2_1 & + ,tauaa,nspad,nspbd,oneminusd & +#endif ) ! Call the radiative transfer routine. @@ -14999,7 +15059,13 @@ subroutine rrtmg_lw_part & #endif call rtrnmcg _gpuchv (pncol,nlayers, istart, iend, iout & -#include "rrtmg_lw_cpu_args.h" +#ifndef _ACCEL + ,ncol_,nlayers_,nbndlw_,ngptlw_ & + ,taucmcd,pzd,pwvcmd,semissd,planklayd,planklevd,plankbndd,gurad,gdrad,gclrurad,gclrdrad & + ,gdtotuflux_dtd,gdtotuclfl_dtd,idrvd,bpaded,heatfacd,fluxfacd,a0d,a1d,a2d & + ,delwaved,totufluxd,totdfluxd,fnetd,htrd,totuclfld,totdclfld,fnetcd,htrcd,dtotuflux_dtd & + ,dtotuclfl_dtd,dplankbnd_dtd & +#endif ,ngbd, icldlyr, taug, fracsd, cldfmcd) #ifdef _ACCEL @@ -15022,62 +15088,58 @@ subroutine rrtmg_lw_part & dimBlock = dim3( 256, 1, 1) #endif -!!zap -!do ierr = 1, ngptlw -!write(0,*)'gurad before rtrnadd',gurad(5,ierr,1) -!enddo -!ierr = 0 -!!zap - uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,1:(nlayers+1)) -!write(0,*)__FILE__,__LINE__,i,'uflx ',uflx(10,10) - dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,1:(nlayers+1)) -!write(0,*)__FILE__,__LINE__,i,'dflx ',dflx(10,10) - -!write(0,*)__FILE__,__LINE__ + uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,0:(nlayers)) + dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,0:(nlayers)) ! (dmb 2012) Here we integrate across the g-point fluxes to arrive at total fluxes ! This functionality was factored out of the original rtrnmc routine so that I could ! parallelize across multiple dimensions. -!write(0,*)__FILE__,__LINE__,i,'totufluxd ',totufluxd(10,10) -!write(0,*)__FILE__,__LINE__,i,'totdfluxd ',totdfluxd(10,10) call rtrnadd _gpuchv (pncol, nlayers, ngptlw, idrv & -#include "rrtmg_lw_cpu_args.h" +#ifndef _ACCEL + ,ncol_,nlayers_,nbndlw_,ngptlw_ & + ,taucmcd,pzd,pwvcmd,semissd,planklayd,planklevd,plankbndd,gurad,gdrad,gclrurad,gclrdrad & + ,gdtotuflux_dtd,gdtotuclfl_dtd,idrvd,bpaded,heatfacd,fluxfacd,a0d,a1d,a2d & + ,delwaved,totufluxd,totdfluxd,fnetd,htrd,totuclfld,totdclfld,fnetcd,htrcd,dtotuflux_dtd & + ,dtotuclfl_dtd,dplankbnd_dtd & +#endif ) - uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,1:(nlayers+1)) -!write(0,*)__FILE__,__LINE__,'uflx ',uflx(10,10) - dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,1:(nlayers+1)) -!write(0,*)__FILE__,__LINE__,'dflx ',dflx(10,10) - #ifdef _ACCEL - ierr = cudaThreadSynchronize() + ierr = cudaThreadSynchronize() dimGrid = dim3( (pncol+255)/256,nlayers,1) #endif -!jm write(0,*)__FILE__,__LINE__,omp_get_thread_num() + uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,0:(nlayers)) + dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,0:(nlayers)) + ! (dmb 2012) Calculate the heating rates. call rtrnheatrates _gpuchv (pncol, nlayers & -#include "rrtmg_lw_cpu_args.h" +#ifndef _ACCEL + ,ncol_,nlayers_,nbndlw_,ngptlw_ & + ,taucmcd,pzd,pwvcmd,semissd,planklayd,planklevd,plankbndd,gurad,gdrad,gclrurad,gclrdrad & + ,gdtotuflux_dtd,gdtotuclfl_dtd,idrvd,bpaded,heatfacd,fluxfacd,a0d,a1d,a2d & + ,delwaved,totufluxd,totdfluxd,fnetd,htrd,totuclfld,totdclfld,fnetcd,htrcd,dtotuflux_dtd & + ,dtotuclfl_dtd,dplankbnd_dtd & +#endif ) #ifdef _ACCEL ierr = cudaThreadSynchronize() #endif ! copy the partition data back to the CPU -!write(0,*)__FILE__,__LINE__,i,'totufluxd ',totufluxd(10,10) -!write(0,*)__FILE__,__LINE__,i,'totdfluxd ',totdfluxd(10,10) - uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,1:(nlayers+1)) -!write(0,*)__FILE__,__LINE__,i,'uflx ',uflx(10,10) - dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,1:(nlayers+1)) -!write(0,*)__FILE__,__LINE__,i,'dflx ',dflx(10,10) - uflxc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totuclfld(1:pncol,1:(nlayers+1)) - dflxc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdclfld(1:pncol,1:(nlayers+1)) - hr(colstart:(colstart+pncol-1), 1:(nlayers+1)) = htrd(1:pncol,1:(nlayers+1)) - hrc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = htrcd(1:pncol,1:(nlayers+1)) +#if 0 +!these are redundant with the copies before the call to rtrnheatrates, above + uflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totufluxd(1:pncol,0:(nlayers)) + dflx(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdfluxd(1:pncol,0:(nlayers)) +#endif + uflxc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totuclfld(1:pncol,0:(nlayers)) + dflxc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = totdclfld(1:pncol,0:(nlayers)) + hr(colstart:(colstart+pncol-1), 1:(nlayers+1)) = htrd(1:pncol,0:(nlayers)) + hrc(colstart:(colstart+pncol-1), 1:(nlayers+1)) = htrcd(1:pncol,0:(nlayers)) if (idrv .eq. 1) then - duflx_dt(colstart:(colstart+pncol-1), 1:(nlayers+1)) = dtotuflux_dtd(1:pncol,1:(nlayers+1)) - duflxc_dt(colstart:(colstart+pncol-1), 1:(nlayers+1)) = dtotuclfl_dtd(1:pncol,1:(nlayers+1)) + duflx_dt(colstart:(colstart+pncol-1), 1:(nlayers+1)) = dtotuflux_dtd(1:pncol,0:(nlayers)) + duflxc_dt(colstart:(colstart+pncol-1), 1:(nlayers+1)) = dtotuclfl_dtd(1:pncol,0:(nlayers)) end if @@ -15124,7 +15186,6 @@ subroutine rrtmg_lw_part & # undef fracsd #endif -!write(0,*)__FILE__,__LINE__ end subroutine rrtmg_lw_part end module rrtmg_lw_rad_f @@ -15168,8 +15229,8 @@ MODULE module_ra_rrtmg_lwf ! save retab ! For buffer layer adjustment. Steven Cavallo, Dec 2010. - integer , save :: nlayers - real, PARAMETER :: deltap = 4. ! Pressure interval for buffer layer in mb + INTEGER , SAVE :: nlayers + REAL, PARAMETER :: deltap = 4. ! Pressure interval for buffer layer in mb CONTAINS @@ -15563,7 +15624,6 @@ SUBROUTINE RRTMG_LWRAD_FAST( & ENDIF #endif -!write(0,*)__FILE__,__LINE__ !-----CALCULATE LONG WAVE RADIATION ! @@ -15796,13 +15856,14 @@ SUBROUTINE RRTMG_LWRAD_FAST( & inflglw = 4 iceflglw = 4 DO K=kts,kte - reice1D(icol,K) = MAX(10., re_ice(I,K,J)*1.E6) - if (recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & - & .AND. (XLAND(I,J)-1.5).GT.0.) then !--- Ocean - recloud1D(icol,K) = 10.5 - elseif(recloud1D(icol,K).LE.2.5.AND.cldfra3d(i,k,j).gt.0. & - & .AND. (XLAND(I,J)-1.5).LT.0.) then !--- Land - recloud1D(icol,K) = 7.5 + reice1D(icol,K) = MAX(5., re_ice(I,K,J)*1.E6) + if (reice1D(icol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then + idx_rei = int(t3d(i,k,j)-179.) + idx_rei = min(max(idx_rei,1),75) + corr = t3d(i,k,j) - int(t3d(i,k,j)) + reice1D(icol,K) = retab(idx_rei)*(1.-corr) + & + & retab(idx_rei+1)*corr + reice1D(icol,K) = MAX(reice1D(icol,K), 5.0) endif ENDDO ELSE @@ -16309,10 +16370,7 @@ SUBROUTINE RRTMG_LWRAD_FAST( & ! end do i_loop end do j_loop -!write(0,*)'zap before rrtmg_lw duflx_dt ',duflx_dt -!write(0,*)'zap before rrtmg_lw duflxc_dt ',duflxc_dt -!write(0,*)__FILE__,__LINE__ ! Call RRTMG longwave radiation model for full grid for gpu call rrtmg_lw & (ncol ,nlay ,icld ,idrv , & @@ -16324,9 +16382,6 @@ SUBROUTINE RRTMG_LWRAD_FAST( & tauaer , & uflx ,dflx ,hr ,uflxc ,dflxc, hrc, & duflx_dt,duflxc_dt) -!write(0,*)__FILE__,__LINE__,'h2ovmr ',h2ovmr(10,10) -!write(0,*)__FILE__,__LINE__,'uflx ',uflx(10,10) -!write(0,*)__FILE__,__LINE__,'dflx ',dflx(10,10) ! Output downard surface flux, and outgoing longwave flux and cloud forcing ! at the top of atmosphere (W/m2) diff --git a/wrfv2_fire/phys/module_ra_rrtmg_sw.F b/wrfv2_fire/phys/module_ra_rrtmg_sw.F index 05cdafd9..847e8a8c 100644 --- a/wrfv2_fire/phys/module_ra_rrtmg_sw.F +++ b/wrfv2_fire/phys/module_ra_rrtmg_sw.F @@ -9173,7 +9173,7 @@ subroutine rrtmg_sw & ! input aerosol optical depth at 0.55 microns for each aerosol type (ecaer) ! iaer = 10, input total aerosol optical depth, single scattering albedo ! and asymmetry parameter (tauaer, ssaaer, asmaer) directly - if ( aer_opt .eq. 0 .or. aer_opt .eq. 2 ) then + if ( aer_opt.eq.0 .or. aer_opt.eq.2 .or. aer_opt.eq.3) then iaer = 10 else if ( aer_opt .eq. 1 ) then iaer = 6 @@ -9802,6 +9802,11 @@ MODULE module_ra_rrtmg_sw use module_model_constants, only : cp USE module_wrf_error +#if (HWRF == 1) +USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF +#else +USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT +#endif !USE module_dm use parrrsw, only : nbndsw, ngptsw, naerec @@ -9851,6 +9856,7 @@ SUBROUTINE RRTMG_SWRAD( & !jdfcz progn,prescribe, & progn, & qndrop3d,f_qndrop, & !czhao + mp_physics, & !wang 2014/12 ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -9870,6 +9876,7 @@ SUBROUTINE RRTMG_SWRAD( & its,ite, jts,jte, kts,kte INTEGER, INTENT(IN ) :: ICLOUD + INTEGER, INTENT(IN ) :: MP_PHYSICS ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & INTENT(IN ) :: dz8w, & @@ -9929,10 +9936,7 @@ SUBROUTINE RRTMG_SWRAD( & julian ! julian day (1-366) real, dimension(ims:ime,jms:jme), intent(in) :: & xcoszen ! cosine of the solar zenith angle - real, dimension(ims:ime,kms:kme,jms:jme,nbndsw), optional, & - intent(in) :: tauaer3d_sw, & - ssaaer3d_sw, & - asyaer3d_sw + real, dimension(:,:,:,:), pointer :: tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw ! ------------------------ jararias end snippet ----------------- REAL, INTENT(IN ) :: R,G @@ -10030,11 +10034,16 @@ SUBROUTINE RRTMG_SWRAD( & QC1D, & QR1D, & QI1D, & + RHO1D, & QS1D, & QG1D, & O31D, & qndrop1d +!BSF: From eq. (5) on p. 2434 in McFarquhar & Heymsfield (1996) + real, parameter :: re_50C=1250.0/9.917, re_40C=1250.0/9.337, & + re_30C=1250.0/9.208, re_20C=1250.0/9.387 + ! Added local arrays for RRTMG integer :: ncol, & nlay, & @@ -10172,7 +10181,7 @@ SUBROUTINE RRTMG_SWRAD( & real, dimension(1, 1:kte-kts+1):: recloud1d, & reice1d, & resnow1d - real :: gliqwp, gicewp, gsnowp, gravmks + real :: gliqwp, gicewp, gsnowp, gravmks, tem1,tem2,tem3 ! ! REAL :: TSFC,GLW0,OLR0,EMISS0,FP @@ -10223,6 +10232,7 @@ SUBROUTINE RRTMG_SWRAD( & ! longitude loop i_loop: do i = its,ite + rho1d(kts:kte)=rho3d(i,kts:kte,j) ! BUG FIX (SGT): this was uninitialized ! ! Do shortwave by default, deactivate below if sun below horizon dorrsw = .true. @@ -10373,7 +10383,25 @@ SUBROUTINE RRTMG_SWRAD( & ENDIF ENDIF - +! For mp option=5 or 85 (new Ferrier- Aligo or called fer_hires +! scheme), QI3D saves all frozen water (ice+snow) +#if (HWRF == 1) + IF ( mp_physics == FER_MP_HIRES .OR. & + mp_physics == FER_MP_HIRES_ADVECT .OR. & + mp_physics == ETAMP_HWRF ) THEN +#else + IF ( mp_physics == FER_MP_HIRES .OR. & + mp_physics == FER_MP_HIRES_ADVECT) THEN +#endif + DO K=kts,kte + qi1d(k) = qi3d(i,k,j) + qs1d(k) = 0.0 + qc1d(k) = qc3d(i,k,j) + qi1d(k) = max(0.,qi1d(k)) + qc1d(k) = max(0.,qc1d(k)) + ENDDO + ENDIF +! ! EMISS0=EMISS(I,J) ! GLW0=0. ! OLR0=0. @@ -10415,7 +10443,11 @@ SUBROUTINE RRTMG_SWRAD( & ENDDO ELSE DO K=kts,kte +#if (EM_CORE==1) recloud1D(ncol,K) = 5.0 +#else + recloud1D(ncol,K) = 10.0 ! was 5.0 +#endif ENDDO ENDIF @@ -10423,14 +10455,14 @@ SUBROUTINE RRTMG_SWRAD( & inflgsw = 4 iceflgsw = 4 DO K=kts,kte - reice1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6) - if (reice1D(ncol,K).LE.10..AND.cldfra3d(i,k,j).gt.0.) then + reice1D(ncol,K) = MAX(5., re_ice(I,K,J)*1.E6) + if (reice1D(ncol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then idx_rei = int(t3d(i,k,j)-179.) idx_rei = min(max(idx_rei,1),75) corr = t3d(i,k,j) - int(t3d(i,k,j)) reice1D(ncol,K) = retab(idx_rei)*(1.-corr) + & & retab(idx_rei+1)*corr - reice1D(ncol,K) = MAX(reice1D(ncol,K), 10.0) + reice1D(ncol,K) = MAX(reice1D(ncol,K), 5.0) endif ENDDO ELSE @@ -10447,7 +10479,26 @@ SUBROUTINE RRTMG_SWRAD( & ENDDO ELSE DO K=kts,kte +#if (EM_CORE==1) resnow1D(ncol,K) = 10.0 +#else + tem2 = 25.0 !- was 10.0 + tem3=1.e3*rho1d(k)*qi1d(k) !- IWC (g m^-3) + if (tem3>thresh) then !- Only when IWC>1.e-9 g m^-3 + tem1=t1d(k)-273.15 + if (tem1 < -50.0) then + tem2 = re_50C*tem3**0.109 + elseif (tem1 < -40.0) then + tem2 = re_40C*tem3**0.08 + elseif (tem1 < -30.0) then + tem2 = re_30C*tem3**0.055 + else + tem2 = re_20C*tem3**0.031 + endif + tem2 = max(25.,tem2) + endif + reice1D(ncol,K) = min(tem2, 135.72) !- 1.0315*reice <= 140 microns +#endif ENDDO ENDIF ENDIF @@ -10692,7 +10743,11 @@ SUBROUTINE RRTMG_SWRAD( & reliq(ncol,k) = recloud1d(ncol,k) end do endif +#if (EM_CORE==1) if (iceflgsw .ge. 4) then +#else + if (iceflgsw .ge. 3) then !BSF: was .ge. 4 +#endif do k = kts, kte reice(ncol,k) = reice1d(ncol,k) end do @@ -10820,9 +10875,8 @@ SUBROUTINE RRTMG_SWRAD( & end do end do - if ( present (tauaer3d_sw) ) then + if ( associated (tauaer3d_sw) ) then ! ---- jararias 11/2012 - if ( aer_opt .eq. 2) then do nb=1,nbndsw do k=kts,kte tauaer(ncol,k,nb)=tauaer3d_sw(i,k,j,nb) @@ -10830,7 +10884,6 @@ SUBROUTINE RRTMG_SWRAD( & asmaer(ncol,k,nb)=asyaer3d_sw(i,k,j,nb) end do end do - end if end if #if ( WRF_CHEM == 1 ) @@ -11026,6 +11079,7 @@ SUBROUTINE RRTMG_SWRAD( & swddir(i,j) = 0. ! jararias 2013/08/10 swddni(i,j) = 0. ! jararias 2013/08/10 swddif(i,j) = 0. ! jararias 2013/08/10 + swcf(i,j) = 0. endif ! diff --git a/wrfv2_fire/phys/module_ra_rrtmg_swf.F b/wrfv2_fire/phys/module_ra_rrtmg_swf.F index fa2692d0..24207004 100644 --- a/wrfv2_fire/phys/module_ra_rrtmg_swf.F +++ b/wrfv2_fire/phys/module_ra_rrtmg_swf.F @@ -9913,6 +9913,8 @@ module rrtmg_sw_rad_f public :: rrtmg_sw, earth_sun + INTEGER, PARAMETER :: debug_level_swf=100 + contains subroutine rrtmg_sw & @@ -10078,6 +10080,7 @@ subroutine rrtmg_sw & ! Dimensions: (ncol,nlay+1) jararias, 2013/08/10 integer :: npart, pncol, ns + CHARACTER(LEN=256) :: message ! mji - time real :: t1, t2 @@ -10139,10 +10142,13 @@ subroutine rrtmg_sw & end if - print *, "RRTMG_SWF: Number of columns is ", ncol - print *, "RRTMG_SWF: Number of columns per partition is ", pncol + WRITE(message,*)'RRTMG_SWF: Number of columns is ',ncol + call wrf_debug( debug_level_swf, message) + WRITE(message,*)'RRTMG_SWF: Number of columns per partition is ',pncol + call wrf_debug( debug_level_swf, message) ns = ceiling( real(ncol) / real(pncol) ) - print *, "RRTMG_SWF: Number of partitions is ", ns + WRITE(message,*)'RRTMG_SWF: Number of partitions is ',ns + call wrf_debug( debug_level_swf, message) call cpu_time(t1) @@ -10161,10 +10167,12 @@ subroutine rrtmg_sw & swdkdir , swdkdif & ! jararias, 2013/08/10 ) call cpu_time(t2) - print *, "------------------------------------------------" - print *, "TOTAL RRTMG_SWF RUN TIME IS ", t2-t1 - print *, "------------------------------------------------" - + WRITE(message,*)'------------------------------------------------' + call wrf_debug( debug_level_swf, message) + WRITE(message,*)'TOTAL RRTMG_SWF RUN TIME IS ', t2-t1 + call wrf_debug( debug_level_swf, message) + WRITE(message,*)'------------------------------------------------' + call wrf_debug( debug_level_swf, message) end subroutine rrtmg_sw @@ -11298,10 +11306,7 @@ SUBROUTINE RRTMG_SWRAD_FAST( & julian ! julian day (1-366) real, dimension(ims:ime,jms:jme), optional, intent(in) :: & xcoszen ! cosine of the solar zenith angle - real, dimension(ims:ime,kms:kme,jms:jme,nbndsw), optional, & - intent(in) :: tauaer3d_sw, & - ssaaer3d_sw, & - asyaer3d_sw + real, dimension(:,:,:,:), pointer :: tauaer3d_sw,ssaaer3d_sw,asyaer3d_sw ! ------------------------ jararias end snippet ----------------- @@ -11848,14 +11853,14 @@ SUBROUTINE RRTMG_SWRAD_FAST( & inflgsw = 4 iceflgsw = 4 DO K=kts,kte - reice1D(icol,K) = MAX(10., re_ice(I,K,J)*1.E6) - if (reice1D(icol,K).LE.10..AND.cldfra3d(i,k,j).gt.0.) then + reice1D(icol,K) = MAX(5., re_ice(I,K,J)*1.E6) + if (reice1D(icol,K).LE.5..AND.cldfra3d(i,k,j).gt.0.) then idx_rei = int(t3d(i,k,j)-179.) idx_rei = min(max(idx_rei,1),75) corr = t3d(i,k,j) - int(t3d(i,k,j)) reice1D(icol,K) = retab(idx_rei)*(1.-corr) + & & retab(idx_rei+1)*corr - reice1D(icol,K) = MAX(reice1D(icol,K), 10.0) + reice1D(icol,K) = MAX(reice1D(icol,K), 5.0) endif ENDDO ELSE @@ -12233,9 +12238,8 @@ SUBROUTINE RRTMG_SWRAD_FAST( & end do end do - if ( present (tauaer3d_sw) ) then + if ( associated (tauaer3d_sw) ) then ! ---- jararias 11/2012 - if ( aer_opt .eq. 2) then do nb=1,nbndsw do k=kts,kte tauaer(icol,k,nb)=tauaer3d_sw(i,k,j,nb) @@ -12243,7 +12247,6 @@ SUBROUTINE RRTMG_SWRAD_FAST( & asmaer(icol,k,nb)=asyaer3d_sw(i,k,j,nb) end do end do - end if end if #if ( WRF_CHEM == 1 ) @@ -12344,7 +12347,7 @@ SUBROUTINE RRTMG_SWRAD_FAST( & enddo IF ( PRESENT( aerod ) ) THEN - if ( aer_opt .eq. 0 .or. aer_opt .eq. 2 ) then + if ( aer_opt .eq. 0 .or. aer_opt .eq. 2 .or. aer_opt .eq. 3 ) then iaer = 10 do na = 1, naerec do k = kts, kte+1 diff --git a/wrfv2_fire/phys/module_radiation_driver.F b/wrfv2_fire/phys/module_radiation_driver.F index 1de41833..ee894062 100644 --- a/wrfv2_fire/phys/module_radiation_driver.F +++ b/wrfv2_fire/phys/module_radiation_driver.F @@ -44,6 +44,11 @@ SUBROUTINE radiation_driver ( & ,CAM_ABS_FREQ_S & ,XTIME & ,CURR_SECS, ADAPT_STEP_FLAG & + !BSINGH - For WRFCuP scheme (optional args) + ,cu_physics,shallowcu_forced_ra & !CuP, wig 1-Oct-2006 + ,cubot,cutop,cldfra_cup & !CuP, wig 1-Oct-2006 + ,shall & !CuP, wig 4-Feb-2008 + !BSINGH - ENDS ! indexes ,IDS,IDE, JDS,JDE, KDS,KDE & ,IMS,IME, JMS,JME, KMS,KME & @@ -72,6 +77,8 @@ SUBROUTINE radiation_driver ( & , QS, F_QS & , QG, F_QG & , QNDROP, F_QNDROP & + ,QNIFA,F_QNIFA & ! trude + ,QNWFA,F_QNWFA & ! trude ,ACSWUPT ,ACSWUPTC & ,ACSWDNT ,ACSWDNTC & ,ACSWUPB ,ACSWUPBC & @@ -99,6 +106,7 @@ SUBROUTINE radiation_driver ( & ,ICLOUD_CU & ,AER_RA_FEEDBACK & ,QC_CU , QI_CU & + ,icloud_bl,qc_bl,cldfra_bl & !JOE-subgrid bl clouds ,PM2_5_DRY, PM2_5_WATER & ,PM2_5_DRY_EC & ,TAUAER300, TAUAER400 & ! jcb @@ -134,6 +142,8 @@ SUBROUTINE radiation_driver ( & ,aer_asy_opt, aer_asy_val & ,aod5502d, angexp2d, aerssa2d, aerasy2d & ,aod5503d & + ,taod5502d, taod5503d & ! Trude + ,mp_physics & ) @@ -146,14 +156,12 @@ SUBROUTINE radiation_driver ( & ,SWRADSCHEME, GSFCSWSCHEME & ,GFDLSWSCHEME, CAMLWSCHEME, CAMSWSCHEME & ,HELDSUAREZ & -#ifdef HWRF +#if ( HWRF == 1 ) ,HWRFSWSCHEME, HWRFLWSCHEME & #endif ,goddardlwscheme & ,goddardswscheme & -# if (EM_CORE == 1) - ,CAMMGMPSCHEME & -# endif + ,KFCUPSCHEME & !BSINGH - Added KFCUPSCHEME for WRFCuP scheme ,FLGLWSCHEME, FLGSWSCHEME USE module_model_constants @@ -172,7 +180,7 @@ SUBROUTINE radiation_driver ( & USE module_ra_rrtmg_swf , ONLY : rrtmg_swrad_fast USE module_ra_cam , ONLY : camrad USE module_ra_gfdleta , ONLY : etara -#ifdef HWRF +#if ( HWRF == 1 ) USE module_ra_hwrf #endif USE module_ra_hs , ONLY : hsrad @@ -355,7 +363,7 @@ SUBROUTINE radiation_driver ( & kts,kte, & num_tiles - INTEGER, INTENT(IN) :: lw_physics, sw_physics + INTEGER, INTENT(IN) :: lw_physics, sw_physics, mp_physics INTEGER, INTENT(IN) :: o3input, aer_opt INTEGER, INTENT(IN) :: id integer, intent(in) :: swint_opt @@ -370,6 +378,10 @@ SUBROUTINE radiation_driver ( & REAL, INTENT(IN ) :: cam_abs_freq_s LOGICAL, INTENT(IN ) :: warm_rain + INTEGER, INTENT(IN ) :: cu_physics !CuP, wig 5-Oct-2006 !BSINGH - For WRFCuP scheme + !BSINGH - For WRFCuP scheme + LOGICAL, OPTIONAL, INTENT(IN) :: shallowcu_forced_ra !CuP, wig + !BSINGH -ENDS LOGICAL, INTENT(IN ) :: is_CAMMGMP_used !BSINGH:01/31/2013: Added for CAM5 RRTMG REAL, INTENT(IN ) :: RADT @@ -406,6 +418,14 @@ SUBROUTINE radiation_driver ( & HTOPR, & HBOTR, & CUPPT + !BSINGH - For WRFCuP scheme + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & + INTENT(INOUT) :: & + cutop, & !CuP, wig 1-Oct-2006 + cubot, & !CuP, wig 1-Oct-2006 + shall !CuP, wig 4-Feb-2008 + !BSINGH -ENDS + INTEGER, INTENT(IN ) :: julyr ! @@ -418,6 +438,14 @@ SUBROUTINE radiation_driver ( & t, & t8w, & rho + + !BSINGH - For WRFCuP scheme + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL, & + INTENT(INOUT ) :: cldfra_cup !CuP, wig 1-Oct-2006 + + + !BSINGH -ENDS + ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & INTENT(IN ) :: tauaer300,tauaer400,tauaer600,tauaer999, & ! jcb @@ -425,7 +453,7 @@ SUBROUTINE radiation_driver ( & waer300,waer400,waer600,waer999 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & - INTENT(IN ) :: qc_cu, qi_cu + INTENT(IN ) :: qc_cu, qi_cu, qc_bl REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL , & INTENT(IN ) :: tauaerlw1,tauaerlw2,tauaerlw3,tauaerlw4, & ! czhao @@ -435,6 +463,7 @@ SUBROUTINE radiation_driver ( & INTEGER, INTENT(IN) :: icloud_cu + INTEGER, INTENT(IN ), OPTIONAL :: icloud_bl INTEGER, INTENT(IN ), OPTIONAL :: aer_ra_feedback !jdfcz INTEGER, OPTIONAL, INTENT(IN ) :: progn,prescribe @@ -536,6 +565,9 @@ SUBROUTINE radiation_driver ( & aerasy2d ! gridded aerosol asy from auxinput REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), OPTIONAL, & INTENT(OUT) :: aod5503d ! 3D AOD at 550 nm + + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), OPTIONAL:: taod5503d ! Trude + REAL, DIMENSION(ims:ime,jms:jme), OPTIONAL:: taod5502d ! Trude ! REAL, INTENT(IN ) :: GMT,dt, & julian, xtime @@ -594,7 +626,8 @@ SUBROUTINE radiation_driver ( & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & ! ckay for sub-grid cloud fraction OPTIONAL, & INTENT(INOUT) :: cldfra_dp, & - cldfra_sh + cldfra_sh, & + cldfra_bl !..G. Thompson REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: re_cloud, re_ice, re_snow @@ -623,9 +656,11 @@ SUBROUTINE radiation_driver ( & OPTIONAL, & INTENT(INOUT ) :: & pb & - ,qv,qc,qr,qi,qs,qg,qndrop + ,qv,qc,qr,qi,qs,qg,qndrop, & + qnifa,qnwfa ! Trude - LOGICAL, OPTIONAL :: f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop + LOGICAL, OPTIONAL :: f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop, & + f_qnifa,f_qnwfa ! trude ! REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & OPTIONAL, & @@ -651,28 +686,28 @@ SUBROUTINE radiation_driver ( & REAL :: p_top_dummy ! LOCAL VAR - + INTEGER, DIMENSION( ims:ime, kms:kme, jms:jme ) :: cldfra1_flag REAL, DIMENSION( ims:ime, jms:jme ) :: GLAT,GLON REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: CEMISS REAL, DIMENSION( ims:ime, jms:jme ) :: coszr REAL, DIMENSION( ims:ime, levsiz, jms:jme ) :: ozmixt REAL, DIMENSION( ims:ime, alevsiz, jms:jme, 1:no_src_types ) :: aerodt - REAL :: DECLIN,SOLCON,XXLAT,TLOCTM,XT24, CEN_LAT + REAL :: DECLIN,SOLCON,XXLAT,TLOCTM,XT24, CEN_LAT, cldfra_cup_mod INTEGER :: i,j,k,its,ite,jts,jte,ij INTEGER :: STEPABS - LOGICAL :: gfdl_lw,gfdl_sw + LOGICAL :: gfdl_lw,gfdl_sw, compute_cldfra_cup LOGICAL :: doabsems LOGICAL, EXTERNAL :: wrf_dm_on_monitor INTEGER :: s REAL :: OBECL,SINOB,SXLONG,ARG,DECDEG, & DJUL,RJUL,ECCFAC - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qi_temp,qc_temp + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qc_temp REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qi_save,qc_save REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qs_save - REAL :: gridkm + REAL :: gridkm, Wice,Wh2o REAL :: next_rad_time, DTaccum LOGICAL :: run_param , doing_adapt_dt , decided @@ -692,12 +727,20 @@ SUBROUTINE radiation_driver ( & ! jararias, 2013/08/10 real :: ioh,kt,airmass,kd real, dimension(ims:ime,jms:jme) :: coszen_loc,hrang_loc -! jararias 2013/11 - real, dimension(:,:,:,:), allocatable :: tauaer_sw, ssaaer_sw, asyaer_sw +! jararias 2013/11 but modified on 2016/2/10 +! the following three arrays may be dimensioned by (ims,ime,kms,kme,jms,jme,aerosol_vars) + real, dimension(:,:,:,:), pointer :: tauaer_sw=>null(), ssaaer_sw=>null(), asyaer_sw=>null() + +! Trude AOD variables + INTEGER, PARAMETER:: taer_type = 1 ! rural, urban, maritime, ... + INTEGER, PARAMETER:: taer_aod550_opt = 2 ! input option for AOD at 550 nm + INTEGER, PARAMETER:: taer_angexp_opt = 3 ! input option for aerosol Angstrom exponent + INTEGER, PARAMETER:: taer_ssa_opt = 3 ! input option for aerosol ssa + INTEGER, PARAMETER:: taer_asy_opt = 3 ! input option for aerosol asy -#ifdef HWRF - CHARACTER(len=265) :: wrf_err_message +#if ( HWRF == 1 ) + CHARACTER(len=255) :: wrf_err_message #endif ! This allows radiation schemes (mainly HWRF) to correctly @@ -834,6 +877,8 @@ SUBROUTINE radiation_driver ( & gfdl_lw = .false. gfdl_sw = .false. + flg_lw = .false. + flg_sw = .false. ! Allocate aerosol arrays used by aer_opt = 2 option IF ( PRESENT( AOD5502D ) ) THEN @@ -852,21 +897,47 @@ SUBROUTINE radiation_driver ( & allocate(asyaer_sw(ims:ime, kms:kme, jms:jme, 1:14)) end select swrad_aerosol_select - ELSE - swrad_aerosol_select_stub: select case(sw_physics) + ENDIF + ENDIF - case(GODDARDSWSCHEME) - allocate(tauaer_sw(1, 1, 1, 1)) - allocate(ssaaer_sw(1, 1, 1, 1)) - allocate(asyaer_sw(1, 1, 1, 1)) +! Allocate aerosol arrays used by aer_opt = 3 option, and explicit AOD from QNWFA+QNIFA (Trude) + IF (PRESENT(f_qnwfa) .AND. PRESENT(f_qnifa) .AND. PRESENT(taod5503d) .AND. PRESENT(taod5502d)) THEN + IF (F_QNWFA .AND. aer_opt.eq.3 .AND. & + (sw_physics.eq.RRTMG_SWSCHEME .OR. & + sw_physics.eq.RRTMG_SWSCHEME_FAST)) THEN + CALL wrf_debug (150, 'DEBUG-GT: computing 3D AOD from QNWFA+QNIFA') + + allocate(tauaer_sw(ims:ime, kms:kme, jms:jme, 1:14)) + allocate(ssaaer_sw(ims:ime, kms:kme, jms:jme, 1:14)) + allocate(asyaer_sw(ims:ime, kms:kme, jms:jme, 1:14)) + + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ,i,j,k,its,ite,jts,jte) + DO ij = 1 , num_tiles + its = i_start(ij) + ite = i_end(ij) + jts = j_start(ij) + jte = j_end(ij) - case(RRTMG_SWSCHEME,RRTMG_SWSCHEME_FAST) - allocate(tauaer_sw(1, 1, 1, 1)) - allocate(ssaaer_sw(1, 1, 1, 1)) - allocate(asyaer_sw(1, 1, 1, 1)) + do j=jts,jte + do i=its,ite + taod5502d(i,j) = 0.0 + end do + end do - end select swrad_aerosol_select_stub - ENDIF + call gt_aod (p, DZ8W, t, qv, qnwfa, qnifa, taod5503d, & + ims,ime, jms,jme, kms,kme,its,ite, jts,jte, kts,kte) + + do j=jts,jte + do i=its,ite + do k=kts,kte + taod5502d(i,j) = taod5502d(i,j) + taod5503d(i,k,j) + end do + end do + end do + ENDDO + !$OMP END PARALLEL DO + ENDIF ENDIF !--------------- @@ -966,31 +1037,29 @@ SUBROUTINE radiation_driver ( & ENDDO ENDIF -! temporarily modify hydrometeors (currently only done for GD scheme and WRF-Chem) -! - IF ( PRESENT( qc ) .AND. PRESENT( qc_cu ) .AND. icloud_cu .EQ. 1 ) THEN +! backup the incoming hydrometeors + + IF ( F_QC ) THEN DO j=jts,jte DO k=kts,kte DO i=its,ite - qc_save(i,k,j) = qc(i,k,j) - qc(i,k,j) = qc(i,k,j) + qc_cu(i,k,j) + qc_save(i,k,j) = qc(i,k,j) ENDDO ENDDO ENDDO - ENDIF - IF ( PRESENT( qi ) .AND. PRESENT( qi_cu ) .AND. icloud_cu .EQ. 1 ) THEN + ENDIF + IF ( F_QI ) THEN DO j=jts,jte DO k=kts,kte DO i=its,ite - qi_save(i,k,j) = qi(i,k,j) - qi(i,k,j) = qi(i,k,j) + qi_cu(i,k,j) + qi_save(i,k,j) = qi(i,k,j) ENDDO ENDDO ENDDO - ENDIF + ENDIF ! Fill temporary water variable depending on micro package (tgs 25 Apr 2006) - if(PRESENT(qc) .and. PRESENT(F_QC)) then + if( F_QC ) then DO j=jts,jte DO k=kts,kte DO i=its,ite @@ -1008,7 +1077,7 @@ SUBROUTINE radiation_driver ( & ENDDO endif ! Remove this - to match NAM operational (affects GFDL and HWRF schemes) -! if(PRESENT(qr) .and. PRESENT(F_QR)) then +! if( F_QR ) then ! DO j=jts,jte ! DO k=kts,kte ! DO i=its,ite @@ -1017,6 +1086,27 @@ SUBROUTINE radiation_driver ( & ! ENDDO ! ENDDO ! endif +! +! temporarily modify hydrometeors (this is for GD scheme and WRF-Chem) +! + IF ( F_QC .AND. icloud_cu .EQ. 1 ) THEN + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + qc(i,k,j) = qc(i,k,j) + qc_cu(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + IF ( F_QI .AND. icloud_cu .EQ. 1 ) THEN + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + qi(i,k,j) = qi(i,k,j) + qi_cu(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF ! Choose how to compute cloud fraction (since 3.6) ! Initialize to zero @@ -1030,14 +1120,14 @@ SUBROUTINE radiation_driver ( & IF ( ICLOUD == 1 ) THEN - IF ( PRESENT ( CLDFRA ) .AND. & - PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN + IF ( F_QC .AND. F_QI ) THEN ! Call to cloud fraction routine based on Randall 1994 (Hong Pan 1998) CALL wrf_debug (1, 'CALL cldfra1') CALL cal_cldfra1(CLDFRA,qv,qc,qi,qs, & F_QV,F_QC,F_QI,F_QS,t,p, & F_ICE_PHY,F_RAIN_PHY, & + mp_physics,cldfra1_flag, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -1053,9 +1143,7 @@ SUBROUTINE radiation_driver ( & CLDFRA(i,k,j)=(1.-cldfra_cu(i,k,j))*CLDFRA(i,k,j) ! Update resolved cloud fraction for Cu punch-through CLDFRA(i,k,j)=CLDFRA(i,k,j)+cldfra_cu(i,k,j) ! New total cloud fraction CLDFRA(i,k,j)=AMIN1(1.0,CLDFRA(i,k,j)) - qc_save(i,k,j)=qc(i,k,j) qc(i,k,j) = qc(i,k,j)+qc_cu(i,k,j)*cldfra_cu(i,k,j) - qi_save(i,k,j)=qi(i,k,j) qi(i,k,j) = qi(i,k,j)+qi_cu(i,k,j)*cldfra_cu(i,k,j) ENDDO ENDDO @@ -1063,6 +1151,27 @@ SUBROUTINE radiation_driver ( & ENDIF ENDIF + IF ( PRESENT ( CLDFRA_BL ) .AND. PRESENT ( QC_BL ) ) THEN + IF ( icloud_bl > 0 ) THEN + CALL wrf_debug (1, 'in rad driver; use BL clouds') + DO j = jts,jte + DO i = its,ite + DO k = kts,kte + !Partition the BL clouds into water & ice according to a linear + !approximation of Hobbs et al. (1974). This allows us to only use + !one 3D array for both cloud water & ice. +! Wice = 1. - MIN(1., MAX(0., (t(i,k,j)-254.)/15.)) +! Wh2o = 1. - Wice + CLDFRA(i,k,j)=MAX(CLDFRA(i,k,j),CLDFRA_BL(i,k,j)) + CLDFRA(i,k,j)=MAX(0.0,MIN(1.0,CLDFRA(i,k,j))) + qc(i,k,j)=qc(i,k,j) + QC_BL(i,k,j)*(MIN(1., MAX(0., (t(i,k,j)-254.)/15.)))*CLDFRA_BL(i,k,j) + qi(i,k,j)=qi(i,k,j) + QC_BL(i,k,j)*(1. - MIN(1., MAX(0., (t(i,k,j)-254.)/15.)))*CLDFRA_BL(i,k,j) + ENDDO + ENDDO + ENDDO + ENDIF + ENDIF + IF ( PRESENT (cldfra_mp_all) ) THEN IF (is_CAMMGMP_used) THEN !BSINGH: cloud fraction from CAMMGMP is being used (Mods by Po-Lun) @@ -1083,8 +1192,7 @@ SUBROUTINE radiation_driver ( & ELSE IF ( ICLOUD == 2 ) THEN - IF ( PRESENT ( CLDFRA ) .AND. & - PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN + IF ( F_QC .AND. F_QI ) THEN CALL wrf_debug (1, 'CALL cldfra2') CALL cal_cldfra2(CLDFRA,qc,qi,F_QC,F_QI, & ids,ide, jds,jde, kds,kde, & @@ -1096,19 +1204,9 @@ SUBROUTINE radiation_driver ( & !..New cloud fraction scheme added by G. Thompson (2014Oct31) !+---+-----------------------------------------------------------------+ - ELSEIF (ICLOUD == 3) THEN - IF (PRESENT(CLDFRA) .AND. & - PRESENT(F_QC) .AND. PRESENT ( F_QI ) ) THEN - - DO j = jts,jte - DO k = kts,kte - DO i = its,ite - qc_save(i,k,j) = qc(i,k,j) - qi_save(i,k,j) = qi(i,k,j) - ENDDO - ENDDO - ENDDO - IF (PRESENT(F_QS)) THEN + ELSEIF (ICLOUD == 3) THEN + IF ( F_QC .AND. F_QI ) THEN + IF ( F_QS ) THEN DO j = jts,jte DO k = kts,kte DO i = its,ite @@ -1116,14 +1214,6 @@ SUBROUTINE radiation_driver ( & ENDDO ENDDO ENDDO - ELSE - DO j = jts,jte - DO k = kts,kte - DO i = its,ite - qs_save(i,k,j) = 0.0 - ENDDO - ENDDO - ENDDO ENDIF CALL wrf_debug (150, 'DEBUG: using gthompsn cloud fraction scheme') @@ -1133,6 +1223,8 @@ SUBROUTINE radiation_driver ( & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte) + ELSE + CALL wrf_error_fatal('Can not use icloud = 3 option, missing QC or QI field.') ENDIF END IF @@ -1140,7 +1232,12 @@ SUBROUTINE radiation_driver ( & ! ww: Interpolating climatological ozone and aerosol to model time and levels ! Adapted from camrad code IF ( PRESENT( O3RAD ) ) THEN + call wrf_debug(1,'Have o3rad') +#if (EM_CORE==1) IF ( o3input .EQ. 2 .AND. id .EQ. 1 ) THEN +#else + IF ( o3input .EQ. 2 ) THEN +#endif ! ! Find the current month (adapted from Cavallo) ! CALL cam_time_interp( ozmixm, pin, levsiz, date_str, & ! ids , ide , jds , jde , kds , kde , & @@ -1175,6 +1272,60 @@ SUBROUTINE radiation_driver ( & ENDIF ENDIF + !Modify CLDFRA and QC for kfcupscheme cumulus scheme + if(present(cldfra_cup)) then + !BSINGH - overwrite cldfra with the cloud fraction computed in module_cu_kfcup.F + !Force cloud fraction if cumulus triggered. + if( cu_physics == KFCUPSCHEME ) then + do j = jts,jte + do k = kts,kte + do i = its,ite + + !Find whether to overwrite cldfra or not (ONLY if ICLOUD == 1) + compute_cldfra_cup = .true. + if (icloud == 1 ) then + compute_cldfra_cup = .false. + if(cldfra1_flag(i,k,j) == 1 .and. shall(i,j) .gt. 1) then + CLDFRA(i,k,j)=0. + elseif(cldfra1_flag(i,k,j) == 2 .and. shall(i,j) .gt. 1) then + CLDFRA(i,k,j)=1. + elseif(cldfra1_flag(i,k,j) == 3) then + compute_cldfra_cup = .true. + endif + endif + + + if(compute_cldfra_cup) then + if( (int(shall(i,j)) .le.1) .and. k >= int(cubot(i,j)) .and. k <= int(cutop(i,j)) ) then ! LD Mar232012 + CLDFRA(i,k,j) = cldfra_cup(i,k,j) + else if( shall(i,j) .gt. 1) then !!LD + cldfra_cup(i,k,j) = 0.0 + end if + endif + if( shall(i,j) == 1 .and. k >= cubot(i,j) .and. k <= cutop(i,j) ) then ! 1=Shallow Cu + ! Begin: wig, 4-Feb-2008 + ! + ! Override the cloud condensate values if shallow convection triggered. + ! For shallow convection, use a representative condensate value based on + ! observations from CHAPS (Oklahoma area) and Florida (Blyth et al. 2005) + ! or the predicted value if it is greater. + + cldfra_cup_mod = cldfra_cup(i,k,j)* 1.0e-3*(1+qv(i,k,j))!modified cloud fraction + qc(i,k,j) = max( 1.0e-3*cldfra_cup_mod, qc(i,k,j) )!DE+LB 2012-Feb + + ! Override the cloud fraction values calculated above if shallow + ! convection triggered. For shallow convection, use a representative + ! cloud fraction. In this case, the median value for shallow Cu cases + ! at the ARM SGP site, 36%, Berg et al. 2008, J. Clim. + if( shallowcu_forced_ra )cldfra(i,k,j) = max(0.36, cldfra(i,k,j)) ! Median shallow Cu frac at ARM SGP + endif + ENDDO + ENDDO + ENDDO + end if + endif + + lwrad_select: SELECT CASE(lw_physics) CASE (RRTMSCHEME) @@ -1239,6 +1390,9 @@ SUBROUTINE radiation_driver ( & ,f_qi=f_qi,f_qs=f_qs,f_qg=f_qg & ,erbe_out=erbe_out & !optional ,aer_opt=aer_opt & + ,tauaer3d_sw=tauaer_sw & ! jararias, 2013/11 + ,ssaaer3d_sw=ssaaer_sw & ! jararias, 2013/11 + ,asyaer3d_sw=asyaer_sw & ! jararias, 2012/11 ) CASE (GFDLLWSCHEME) @@ -1281,7 +1435,7 @@ SUBROUTINE radiation_driver ( & CALL wrf_error_fatal('Can not call ETARA (1b). Missing moisture fields.') ENDIF -#ifdef HWRF +#if ( HWRF == 1 ) CASE (HWRFLWSCHEME) CALL wrf_debug (100, 'CALL hwrflw') @@ -1415,8 +1569,8 @@ SUBROUTINE radiation_driver ( & IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme,& ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte,& LWUPFLX=LWUPFLX,LWUPFLXC=LWUPFLXC, & - LWDNFLX=LWDNFLX,LWDNFLXC=LWDNFLXC & - ) + LWDNFLX=LWDNFLX,LWDNFLXC=LWDNFLXC, & + mp_physics=mp_physics ) CASE (RRTMG_LWSCHEME_FAST) CALL wrf_debug (100, 'CALL rrtmg_lw') @@ -1531,7 +1685,7 @@ SUBROUTINE radiation_driver ( & END SELECT lwrad_select - IF (lw_physics .gt. 0 .and. .not.gfdl_lw) THEN + IF (lw_physics .gt. 0 .and. .not.gfdl_lw .and. .not.flg_lw) THEN DO j=jts,jte DO k=kts,kte DO i=its,ite @@ -1595,6 +1749,21 @@ SUBROUTINE radiation_driver ( & ENDIF ENDIF + !..Different treatment for aer_opt=3 using QNWFA+QNIFA aerosol species (Trude) + + IF (PRESENT(f_qnwfa) .AND. PRESENT(f_qnifa)) THEN + IF (F_QNWFA .AND. aer_opt.eq.3 .AND. & + (sw_physics.eq.RRTMG_SWSCHEME .OR. & + sw_physics.eq.RRTMG_SWSCHEME_FAST)) THEN + call wrf_debug(100, 'call calc_aerosol_rrtmg_sw with 3D AOD values') + call calc_aerosol_rrtmg_sw(ht,dz8w,p,t,qv,taer_type,taer_aod550_opt,taer_angexp_opt, & + taer_ssa_opt,taer_asy_opt,aer_aod550_val,aer_angexp_val, & + aer_ssa_val,aer_asy_val,taod5502d,angexp2d,aerssa2d, & + aerasy2d,ims,ime,jms,jme,kms,kme,its,ite,jts,jte,kts,kte, & + tauaer_sw,ssaaer_sw,asyaer_sw, taod5503d) + ENDIF + ENDIF + swrad_select: SELECT CASE(sw_physics) CASE (SWRADSCHEME) @@ -1825,7 +1994,7 @@ SUBROUTINE radiation_driver ( & ssaaer3d_sw=ssaaer_sw, & ! jararias 2013/11 asyaer3d_sw=asyaer_sw, & ! jararias 2013/11 swddir=swddir,swddni=swddni,swddif=swddif, & ! jararias 2013/08/10 - xcoszen=coszen,julian=julian ) ! jararias 2013/08/14 + xcoszen=coszen,julian=julian,mp_physics=mp_physics ) ! jararias 2013/08/14 DO j=jts,jte DO k=kts,kte @@ -1944,7 +2113,7 @@ SUBROUTINE radiation_driver ( & CALL wrf_error_fatal('Can not call ETARA (2b). Missing moisture fields.') ENDIF -#ifdef HWRF +#if ( HWRF == 1 ) CASE (HWRFSWSCHEME) CALL wrf_debug (100, 'CALL hwrfsw') @@ -2004,7 +2173,7 @@ SUBROUTINE radiation_driver ( & ENDIF ENDIF - IF (sw_physics .gt. 0 .and. .not.gfdl_sw) THEN + IF (sw_physics .gt. 0 .and. .not.gfdl_sw .and. .not.flg_sw) THEN DO j=jts,jte DO k=kts,kte DO i=its,ite @@ -2046,32 +2215,24 @@ SUBROUTINE radiation_driver ( & swddni(i,j)=swddir(i,j)/max(coszen(i,j),1e-4) ENDIF ENDDO - ENDDO - ENDIF - IF ( PRESENT( qs ) .AND. ICLOUD.eq.3) THEN - DO j=jts,jte - DO k=kts,kte - DO i=its,ite - qs(i,k,j) = qs_save(i,k,j) - ENDDO - ENDDO - ENDDO - ENDIF + ENDDO + ENDIF IF ( PRESENT( diffuse_frac ) ) THEN DO j=jts,jte DO i=its,ite - if (coszen(i,j).gt.1e-3) then + if (swdown(i,j).gt.0.001) then diffuse_frac(i,j) = swddif(i,j)/swdown(i,j) + diffuse_frac(i,j) = min(diffuse_frac(i,j),1.0) else diffuse_frac(i,j) = 0. endif ENDDO ENDDO - ENDIF + ENDIF - IF ( PRESENT( qc ) .AND. PRESENT( qc_cu ) ) THEN - IF ( icloud_cu .NE. 0 ) THEN + ! Restore qc & qi for any model physics configuration + IF ( F_QC ) THEN DO j=jts,jte DO k=kts,kte DO i=its,ite @@ -2079,10 +2240,8 @@ SUBROUTINE radiation_driver ( & ENDDO ENDDO ENDDO - ENDIF ENDIF - IF ( PRESENT( qi ) .AND. PRESENT( qi_cu ) ) THEN - IF ( icloud_cu .NE. 0 ) THEN + IF ( F_QI ) THEN DO j=jts,jte DO k=kts,kte DO i=its,ite @@ -2090,7 +2249,16 @@ SUBROUTINE radiation_driver ( & ENDDO ENDDO ENDDO - ENDIF + ENDIF + + IF (ICLOUD == 3 .AND. F_QS ) THEN + DO j = jts,jte + DO k = kts,kte + DO i = its,ite + qs(i,k,j) = qs_save(i,k,j) + ENDDO + ENDDO + ENDDO ENDIF ! jararias, aug 2013, updated 2013/11 @@ -2106,9 +2274,9 @@ SUBROUTINE radiation_driver ( & ENDDO !$OMP END PARALLEL DO - IF ( allocated(tauaer_sw) ) deallocate(tauaer_sw) - IF ( allocated(ssaaer_sw) ) deallocate(ssaaer_sw) - IF ( allocated(asyaer_sw) ) deallocate(asyaer_sw) + IF ( associated(tauaer_sw) ) deallocate(tauaer_sw) + IF ( associated(ssaaer_sw) ) deallocate(ssaaer_sw) + IF ( associated(asyaer_sw) ) deallocate(asyaer_sw) ENDIF Radiation_step @@ -2354,7 +2522,6 @@ SUBROUTINE pre_radiation_driver ( grid, config_flags & endif - IF( nested ) THEN !$OMP PARALLEL DO & @@ -2631,6 +2798,7 @@ SUBROUTINE cal_cldfra2(CLDFRA,QC,QI,F_QC,F_QI, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + USE module_state_description, ONLY : KFCUPSCHEME, KFETASCHEME !CuP, wig 5-Oct-2006 !BSINGH - For WRFCuP scheme !--------------------------------------------------------------------- IMPLICIT NONE !--------------------------------------------------------------------- @@ -2645,7 +2813,6 @@ SUBROUTINE cal_cldfra2(CLDFRA,QC,QI,F_QC,F_QI, & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: & QI, & QC - LOGICAL,INTENT(IN) :: F_QC,F_QI REAL thresh @@ -2700,7 +2867,6 @@ SUBROUTINE cal_cldfra2(CLDFRA,QC,QI,F_QC,F_QI, & ENDDO ENDDO ENDIF - END SUBROUTINE cal_cldfra2 !BOP @@ -2713,12 +2879,20 @@ END SUBROUTINE cal_cldfra2 !! (see Hong et al., 1998) !! (modified by Ferrier, Feb '02) ! - SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & + SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & F_QV, F_QC, F_QI, F_QS, t_phy, p_phy, & F_ICE_PHY,F_RAIN_PHY, & + mp_physics, cldfra1_flag, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + USE module_state_description, ONLY : KFCUPSCHEME, KFETASCHEME !wig, CuP 4-Fb-2008 !BSINGH - For WRFCuP scheme + +#if (HWRF == 1) + USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT, ETAMP_HWRF +#else + USE module_state_description, ONLY : FER_MP_HIRES, FER_MP_HIRES_ADVECT +#endif !--------------------------------------------------------------------- IMPLICIT NONE !--------------------------------------------------------------------- @@ -2727,6 +2901,7 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & its,ite, jts,jte, kts,kte ! + INTEGER, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT ) :: cldfra1_flag REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(OUT ) :: & CLDFRA @@ -2746,8 +2921,8 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & INTENT(IN ) :: & F_ICE_PHY, & F_RAIN_PHY - LOGICAL,OPTIONAL,INTENT(IN) :: F_QC,F_QI,F_QV,F_QS + INTEGER :: mp_physics ! REAL thresh INTEGER:: i,j,k @@ -2814,7 +2989,7 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & QVSW = EP_2 * esw / ( p_phy(i,k,j) - esw ) QVSI = EP_2 * esi / ( p_phy(i,k,j) - esi ) - IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) ) THEN + ifouter: IF ( PRESENT(F_QI) .and. PRESENT(F_QC) .and. PRESENT(F_QS) ) THEN ! mji - For MP options 2, 4, 6, 7, 8, etc. (qc = liquid, qi = ice, qs = snow) IF ( F_QI .and. F_QC .and. F_QS) THEN @@ -2862,11 +3037,31 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & weight = F_ICE_PHY(i,k,j) ENDIF ENDIF +!BSF - For HWRF MP option; (qc = liquid, qi = cloud ice+snow) +! IF ( F_QC .and. F_QI .and. .not. F_QS ) THEN +#if (HWRF == 1) + IF ( mp_physics .eq. FER_MP_HIRES .or. & + mp_physics .eq. FER_MP_HIRES_ADVECT .or. & + mp_physics .eq. ETAMP_HWRF) THEN +#else + IF ( mp_physics .eq. FER_MP_HIRES .or. & + mp_physics==fer_mp_hires_advect) THEN +#endif + QIMID = QI(i,k,j) !- total ice (cloud ice + snow) + QWMID = QC(i,k,j) !- cloud water + QCLD=QWMID+QIMID !- cloud water + total ice + IF (QCLD .LT. QCLDMIN) THEN + weight = 0. + ELSE + weight = QIMID/QCLD + if (tc<-40.) weight=1. + ENDIF + ENDIF ELSE CLDFRA(i,k,j)=0. - ENDIF ! IF ( F_QI .and. F_QC .and. F_QS) + ENDIF ifouter ! IF ( F_QI .and. F_QC .and. F_QS) QVS_WEIGHT = (1-weight)*QVSW + weight*QVSI @@ -2874,18 +3069,22 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & ! !--- Determine cloud fraction (modified from original algorithm) ! + cldfra1_flag(i,k,j) = 0 IF (QCLD .LT. QCLDMIN) THEN ! !--- Assume zero cloud fraction if there is no cloud mixing ratio ! CLDFRA(i,k,j)=0. + cldfra1_flag(i,k,j) = 1 ELSEIF(RHUM.GE.RHGRID)THEN ! !--- Assume cloud fraction of unity if near saturation and the cloud ! mixing ratio is at or above the minimum threshold ! CLDFRA(i,k,j)=1. + cldfra1_flag(i,k,j) = 2 ELSE + cldfra1_flag(i,k,j) = 3 ! !--- Adaptation of original algorithm (Randall, 1994; Zhao, 1995) ! modified based on assumed grid-scale saturation at RH=RHgrid. @@ -2900,7 +3099,8 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS, & !! ARG=MAX(ARG, ARGMIN) !! CLDFRA(i,k,j)=(RHUM/RHGRID)*(1.-EXP(ARG)) IF (CLDFRA(i,k,j) .LT. .01) CLDFRA(i,k,j)=0. - ENDIF !--- End IF (QCLD .LT. QCLDMIN) ... + + ENDIF !--- End IF (QCLD .LT. QCLDMIN) ... ENDDO !--- End DO i ENDDO !--- End DO k ENDDO !--- End DO j @@ -3572,8 +3772,8 @@ SUBROUTINE toposhad(xlat,xlong,sina,cosa,xtime,gmt,radfrq,declin, & i2 = i1+1 wgt = ri-i1 dxabs = sqrt((dy*(jj-j))**2+(dx*(ri-i))**2) - if ((jj.ge.jpe+1).or.(i1.le.ips-1).or.(i2.ge.ipe+1)) then - if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1 + if ((jj.ge.jpe+3).or.(i1.le.ips-3).or.(i2.ge.ipe+3)) then +! if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1 goto 120 endif topoelev=atan((wgt*ht_loc(i2,jj)+(1.-wgt)*ht_loc(i1,jj)-ht_loc(i,j))/dxabs) @@ -3590,8 +3790,8 @@ SUBROUTINE toposhad(xlat,xlong,sina,cosa,xtime,gmt,radfrq,declin, & j2 = j1+1 wgt = rj-j1 dxabs = sqrt((dx*(ii-i))**2+(dy*(rj-j))**2) - if ((ii.ge.ipe+1).or.(j1.le.jps-1).or.(j2.ge.jpe+1)) then - if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1 + if ((ii.ge.ipe+3).or.(j1.le.jps-3).or.(j2.ge.jpe+3)) then +! if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1 goto 120 endif topoelev=atan((wgt*ht_loc(ii,j2)+(1.-wgt)*ht_loc(ii,j1)-ht_loc(i,j))/dxabs) @@ -3608,8 +3808,8 @@ SUBROUTINE toposhad(xlat,xlong,sina,cosa,xtime,gmt,radfrq,declin, & i2 = i1+1 wgt = ri-i1 dxabs = sqrt((dy*(jj-j))**2+(dx*(ri-i))**2) - if ((jj.le.jps-1).or.(i1.le.ips-1).or.(i2.ge.ipe+1)) then - if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1 + if ((jj.le.jps-3).or.(i1.le.ips-3).or.(i2.ge.ipe+3)) then +! if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1 goto 120 endif topoelev=atan((wgt*ht_loc(i2,jj)+(1.-wgt)*ht_loc(i1,jj)-ht_loc(i,j))/dxabs) @@ -3626,8 +3826,8 @@ SUBROUTINE toposhad(xlat,xlong,sina,cosa,xtime,gmt,radfrq,declin, & j2 = j1+1 wgt = rj-j1 dxabs = sqrt((dx*(ii-i))**2+(dy*(rj-j))**2) - if ((ii.le.ips-1).or.(j1.le.jps-1).or.(j2.ge.jpe+1)) then - if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1 + if ((ii.le.ips-3).or.(j1.le.jps-3).or.(j2.ge.jpe+3)) then +! if (shadowmask(i,j).eq.0) shadowmask(i,j) = -1 goto 120 endif topoelev=atan((wgt*ht_loc(ii,j2)+(1.-wgt)*ht_loc(ii,j1)-ht_loc(i,j))/dxabs) @@ -3656,6 +3856,12 @@ SUBROUTINE toposhad(xlat,xlong,sina,cosa,xtime,gmt,radfrq,declin, & XXLAT=XLAT(i,j)*DEGRAD CSZA=SIN(XXLAT)*SIN(DECLIN)+COS(XXLAT)*COS(DECLIN)*COS(HRANG) + if (csza.lt.1.e-2) then ! shadow mask does not need to be computed + shadowmask(i,j) = 0 + ht_shad(i,j) = ht_loc(i,j)-0.001 + goto 220 + endif + ! Solar azimuth angle argu=(csza*sin(XXLAT)-sin(DECLIN))/(sin(acos(csza))*cos(XXLAT)) @@ -4257,4 +4463,191 @@ SUBROUTINE aer_p_int(p ,pin, levsiz, aerodt, aerod, no_src, pf, totaod, & return END SUBROUTINE aer_p_int + +!+---+-----------------------------------------------------------------+ + + SUBROUTINE gt_aod(p_phy,DZ8W,t_phy,qvapor, nwfa,nifa, taod5503d, & + & ims,ime, jms,jme, kms,kme, its,ite, jts,jte, kts,kte) + + USE module_mp_thompson, only: RSLF + + IMPLICIT NONE + + INTEGER, INTENT(IN):: ims,ime, jms,jme, kms,kme, & + & its,ite, jts,jte, kts,kte + + REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN) :: & + & t_phy,p_phy, DZ8W, & + & qvapor, nifa, nwfa + REAL,DIMENSION(ims:ime,kms:kme,jms:jme),INTENT(INOUT):: taod5503d + + !..Local variables. + + REAL, DIMENSION(its:ite,kts:kte,jts:jte):: AOD_wfa, AOD_ifa + REAL:: RH, a_RH,b_RH, rh_d,rh_f, rhoa,qvsat, unit_bext1,unit_bext3 + INTEGER :: i, k, j, RH_idx, RH_idx1, RH_idx2, t_idx + INTEGER, PARAMETER:: rind=8 + REAL, DIMENSION(rind), PARAMETER:: rh_arr = & + & (/10., 60., 70., 80., 85., 90., 95., 100./) + REAL, DIMENSION(rind,4,2) :: lookup_tabl ! RH, temp, water-friendly, ice-friendly + + lookup_tabl(1,1,1) = 5.73936E-15 + lookup_tabl(1,1,2) = 2.63577E-12 + lookup_tabl(1,2,1) = 5.73936E-15 + lookup_tabl(1,2,2) = 2.63577E-12 + lookup_tabl(1,3,1) = 5.73936E-15 + lookup_tabl(1,3,2) = 2.63577E-12 + lookup_tabl(1,4,1) = 5.73936E-15 + lookup_tabl(1,4,2) = 2.63577E-12 + + lookup_tabl(2,1,1) = 6.93515E-15 + lookup_tabl(2,1,2) = 2.72095E-12 + lookup_tabl(2,2,1) = 6.93168E-15 + lookup_tabl(2,2,2) = 2.72092E-12 + lookup_tabl(2,3,1) = 6.92570E-15 + lookup_tabl(2,3,2) = 2.72091E-12 + lookup_tabl(2,4,1) = 6.91833E-15 + lookup_tabl(2,4,2) = 2.72087E-12 + + lookup_tabl(3,1,1) = 7.24707E-15 + lookup_tabl(3,1,2) = 2.77219E-12 + lookup_tabl(3,2,1) = 7.23809E-15 + lookup_tabl(3,2,2) = 2.77222E-12 + lookup_tabl(3,3,1) = 7.23108E-15 + lookup_tabl(3,3,2) = 2.77201E-12 + lookup_tabl(3,4,1) = 7.21800E-15 + lookup_tabl(3,4,2) = 2.77111E-12 + + lookup_tabl(4,1,1) = 8.95130E-15 + lookup_tabl(4,1,2) = 2.87263E-12 + lookup_tabl(4,2,1) = 9.01582E-15 + lookup_tabl(4,2,2) = 2.87252E-12 + lookup_tabl(4,3,1) = 9.13216E-15 + lookup_tabl(4,3,2) = 2.87241E-12 + lookup_tabl(4,4,1) = 9.16219E-15 + lookup_tabl(4,4,2) = 2.87211E-12 + + lookup_tabl(5,1,1) = 1.06695E-14 + lookup_tabl(5,1,2) = 2.96752E-12 + lookup_tabl(5,2,1) = 1.06370E-14 + lookup_tabl(5,2,2) = 2.96726E-12 + lookup_tabl(5,3,1) = 1.05999E-14 + lookup_tabl(5,3,2) = 2.96702E-12 + lookup_tabl(5,4,1) = 1.05443E-14 + lookup_tabl(5,4,2) = 2.96603E-12 + + lookup_tabl(6,1,1) = 1.37908E-14 + lookup_tabl(6,1,2) = 3.15081E-12 + lookup_tabl(6,2,1) = 1.37172E-14 + lookup_tabl(6,2,2) = 3.15020E-12 + lookup_tabl(6,3,1) = 1.36362E-14 + lookup_tabl(6,3,2) = 3.14927E-12 + lookup_tabl(6,4,1) = 1.35287E-14 + lookup_tabl(6,4,2) = 3.14817E-12 + + lookup_tabl(7,1,1) = 2.26019E-14 + lookup_tabl(7,1,2) = 3.66798E-12 + lookup_tabl(7,2,1) = 2.24435E-14 + lookup_tabl(7,2,2) = 3.66540E-12 + lookup_tabl(7,3,1) = 2.23254E-14 + lookup_tabl(7,3,2) = 3.66173E-12 + lookup_tabl(7,4,1) = 2.20496E-14 + lookup_tabl(7,4,2) = 3.65796E-12 + + lookup_tabl(8,1,1) = 4.41983E-13 + lookup_tabl(8,1,2) = 7.50091E-11 + lookup_tabl(8,2,1) = 3.93335E-13 + lookup_tabl(8,2,2) = 6.79097E-11 + lookup_tabl(8,3,1) = 3.45569E-13 + lookup_tabl(8,3,2) = 6.07845E-11 + lookup_tabl(8,4,1) = 2.96971E-13 + lookup_tabl(8,4,2) = 5.36085E-11 + + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + AOD_wfa(i,k,j) = 0. + AOD_ifa(i,k,j) = 0. + END DO + END DO + END DO + + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + rhoa = p_phy(i,k,j)/(287.*t_phy(i,k,j)) + t_idx = MAX(1, MIN(nint(10.999-0.0333*t_phy(i,k,j)),4)) + qvsat = rslf(p_phy(i,k,j),t_phy(i,k,j)) + RH = MIN(97., MAX(10.1, qvapor(i,k,j)/qvsat*100.)) + + !..Get the index for the RH array element + + if (RH .lt. 60) then + RH_idx1 = 1 + RH_idx2 = 2 + elseif (RH .ge. 60 .AND. RH.lt.80) then + a_RH = 0.1 + b_RH = -4 + RH_idx = nint(a_RH*RH+b_RH) + rh_d = rh-rh_arr(rh_idx) + if (rh_d .lt. 0) then + RH_idx1 = RH_idx-1 + RH_idx2 = RH_idx + else + RH_idx1 = RH_idx + RH_idx2 = RH_idx+1 + if (RH_idx2.gt.rind) then + RH_idx2 = rind + RH_idx1 = rind-1 + endif + endif + else + a_RH = 0.2 + b_RH = -12. + RH_idx = MIN(rind, nint(a_RH*RH+b_RH)) + rh_d = rh-rh_arr(rh_idx) + if (rh_d .lt. 0) then + RH_idx1 = RH_idx-1 + RH_idx2 = RH_idx + else + RH_idx1 = RH_idx + RH_idx2 = RH_idx+1 + if (RH_idx2.gt.rind) then + RH_idx2 = rind + RH_idx1 = rind-1 + endif + endif + endif + + !..RH fraction to be used + + rh_f = MAX(0., MIN( (rh-rh_arr(rh_idx1)) & + & /(rh_arr(rh_idx2)-rh_arr(rh_idx1)), 1.0)) + + unit_bext1 = lookup_tabl(RH_idx1,t_idx,1) & + & + (lookup_tabl(RH_idx2,t_idx,1) & + & - lookup_tabl(RH_idx1,t_idx,1))*rh_f + unit_bext3 = lookup_tabl(RH_idx1,t_idx,2) & + & + (lookup_tabl(RH_idx2,t_idx,2) & + & - lookup_tabl(RH_idx1,t_idx,2))*rh_f + + AOD_wfa(i,k,j) = unit_bext1*nwfa(i,k,j)*dz8w(i,k,j)*rhoa + AOD_ifa(i,k,j) = unit_bext3*nifa(i,k,j)*dz8w(i,k,j)*rhoa + + END DO + END DO + END DO + + DO j=jts,jte + DO k=kts,kte + DO i=its,ite + taod5503d(i,k,j) = aod_wfa(i,k,j) + aod_ifa(i,k,j) + END DO + END DO + END DO + + END SUBROUTINE gt_aod + +!+---+-----------------------------------------------------------------+ + END MODULE module_radiation_driver diff --git a/wrfv2_fire/phys/module_sf_3dpwp.F b/wrfv2_fire/phys/module_sf_3dpwp.F index 07e04942..82b3f844 100644 --- a/wrfv2_fire/phys/module_sf_3dpwp.F +++ b/wrfv2_fire/phys/module_sf_3dpwp.F @@ -630,11 +630,11 @@ SUBROUTINE PWP(i,j,k,ims, ime, jms, jme, okms,okme,om_tmp,om_s, & if (udrag .lt. 100) ucon = 1./(86400*udrag) call absorb(i,j, ims, ime,jms,jme,okms,okme, beta1,beta2, & absrb, om_depth,GSW,GLW) - ql = -1.*(HFX+STBOLT*om_tmp(1)**4) + ql = -1.*(LH+HFX+STBOLT*om_tmp(1)**4) ! corrected V3.8 qi = GLW+GSW ql = ql+absrb(1)*qi om_tmp(1) = om_tmp(1) + dt*ql/(om_depth(1)*ro*cpw) - om_s(1)=om_s(1)-om_s(1)*QFX*dt/ro/om_depth(1) ! check physical meaning.. ok! + om_s(1)=om_s(1)+om_s(1)*QFX*dt/ro/om_depth(1) ! corrected V3.8 do k = 2, okme dz = om_depth(k)-om_depth(k-1) om_tmp(k) = om_tmp(k) + dt*qi*absrb(k)/(dz*ro*cpw) diff --git a/wrfv2_fire/phys/module_sf_clm.F b/wrfv2_fire/phys/module_sf_clm.F index 17388e46..f9445fbc 100644 --- a/wrfv2_fire/phys/module_sf_clm.F +++ b/wrfv2_fire/phys/module_sf_clm.F @@ -1346,8 +1346,8 @@ subroutine varsur_dealloc end subroutine varsur_dealloc end module clm_varsur -!#include -!#include +!#include "misc.h" +!#include "preproc.h" module clmtype @@ -3915,6 +3915,7 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & USE module_date_time USE module_sf_urban, only: urban + USE module_sf_noahlsm, only: low_density_residential, high_density_residential, high_intensity_industrial USE module_ra_gfdleta, only: cal_mon_day USE module_configure @@ -5120,9 +5121,8 @@ subroutine clmdrv(zgcmxy ,forc_qxy ,ps ,forc_txy ,tsxy & !-------------------------------------- ! Input variables lsm --> urban - - IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN + IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == low_density_residential .or. & + IVGTYP(I,J) == high_density_residential .or. IVGTYP(I,J) == high_intensity_industrial ) THEN ! Call urban forc_sols_buf = swd_buf*0.35 @@ -55393,8 +55393,8 @@ end subroutine CNWoodProducts #endif end module CNWoodProductsMod -!#include -!#include +!#include "misc.h" +!#include "preproc.h" !----------------------------------------------------------------------- !BOP diff --git a/wrfv2_fire/phys/module_sf_exchcoef.F b/wrfv2_fire/phys/module_sf_exchcoef.F new file mode 100755 index 00000000..5b07b59e --- /dev/null +++ b/wrfv2_fire/phys/module_sf_exchcoef.F @@ -0,0 +1,224 @@ +! This MODULE holds the routines that calculate air-sea exchange coefficients + +MODULE module_sf_exchcoef +CONTAINS + + SUBROUTINE znot_m_v1(uref,znotm) + IMPLICIT NONE + +! uref(m/s) : Reference level wind +! znotm(meter): Roughness scale for momentum +! Author : Biju Thomas on 02/07/2014 +! + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znotm + REAL :: bs0, bs1, bs2, bs3, bs4, bs5, bs6 + REAL :: cf0, cf1, cf2, cf3, cf4, cf5, cf6 + + + bs0 = -8.367276172397277e-12 + bs1 = 1.7398510865876079e-09 + bs2 = -1.331896578363359e-07 + bs3 = 4.507055294438727e-06 + bs4 = -6.508676881906914e-05 + bs5 = 0.00044745137674732834 + bs6 = -0.0010745704660847233 + + cf0 = 2.1151080765239772e-13 + cf1 = -3.2260663894433345e-11 + cf2 = -3.329705958751961e-10 + cf3 = 1.7648562021709124e-07 + cf4 = 7.107636825694182e-06 + cf5 = -0.0013914681964973246 + cf6 = 0.0406766967657759 + + + IF ( uref .LE. 5.0 ) THEN + znotm = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2) + ELSEIF (uref .GT. 5.0 .AND. uref .LT. 10.0) THEN + znotm =.00000235*(uref**2 - 25 ) + 3.805129199617346e-05 + ELSEIF ( uref .GE. 10.0 .AND. uref .LT. 60.0) THEN + znotm = bs6 + bs5*uref + bs4*uref**2 + bs3*uref**3 + bs2*uref**4 + & + bs1*uref**5 + bs0*uref**6 + ELSE + znotm = cf6 + cf5*uref + cf4*uref**2 + cf3*uref**3 + cf2*uref**4 + & + cf1*uref**5 + cf0*uref**6 + + END IF + + END SUBROUTINE znot_m_v1 + + SUBROUTINE znot_m_v0(uref,znotm) + IMPLICIT NONE + +! uref(m/s) : Reference level wind +! znotm(meter): Roughness scale for momentum +! Author : Biju Thomas on 02/07/2014 + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znotm + REAL :: yz, y1, y2, y3, y4 + + yz = 0.0001344 + y1 = 3.015e-05 + y2 = 1.517e-06 + y3 = -3.567e-08 + y4 = 2.046e-10 + + IF ( uref .LT. 12.5 ) THEN + znotm = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2) + ELSE IF ( uref .GE. 12.5 .AND. uref .LT. 30.0 ) THEN + znotm = (0.0739793 * uref -0.58)/1000.0 + ELSE + znotm = yz + uref*y1 + uref**2*y2 + uref**3*y3 + uref**4*y4 + END IF + + END SUBROUTINE znot_m_v0 + + + SUBROUTINE znot_t_v1(uref,znott) + IMPLICIT NONE + +! uref(m/s) : Reference level wind +! znott(meter): Roughness scale for temperature/moisture +! Author : Biju Thomas on 02/07/2014 + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znott + REAL :: to0, to1, to2, to3 + REAL :: tr0, tr1, tr2, tr3 + REAL :: tn0, tn1, tn2, tn3, tn4, tn5 + REAL :: ta0, ta1, ta2, ta3, ta4, ta5, ta6 + REAL :: tt0, tt1, tt2, tt3, tt4, tt5, tt6, tt7 + + + tr0 = 6.451939325286488e-08 + tr1 = -7.306388137342143e-07 + tr2 = -1.3709065148333262e-05 + tr3 = 0.00019109962089098182 + + to0 = 1.4379320027061375e-08 + to1 = -2.0674525898850674e-07 + to2 = -6.8950970846611e-06 + to3 = 0.00012199648268521026 + + tn0 = 1.4023940955902878e-10 + tn1 = -1.4752557214976321e-08 + tn2 = 5.90998487691812e-07 + tn3 = -1.0920804077770066e-05 + tn4 = 8.898205876940546e-05 + tn5 = -0.00021123340439418298 + + tt0 = 1.92409564131838e-12 + tt1 = -5.765467086754962e-10 + tt2 = 7.276979099726975e-08 + tt3 = -5.002261599293387e-06 + tt4 = 0.00020220445539973736 + tt5 = -0.0048088230565883 + tt6 = 0.0623468551971189 + tt7 = -0.34019193746967424 + + ta0 = -1.7787470700719361e-10 + ta1 = 4.4691736529848764e-08 + ta2 = -3.0261975348463414e-06 + ta3 = -0.00011680322286017206 + ta4 = 0.024449377821884846 + ta5 = -1.1228628619105638 + ta6 = 17.358026773905973 + + IF ( uref .LE. 7.0 ) THEN + znott = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2) + ELSEIF ( uref .GE. 7.0 .AND. uref .LT. 12.5 ) THEN + znott = tr3 + tr2*uref + tr1*uref**2 + tr0*uref**3 + ELSEIF ( uref .GE. 12.5 .AND. uref .LT. 15.0 ) THEN + znott = to3 + to2*uref + to1*uref**2 + to0*uref**3 + ELSEIF ( uref .GE. 15.0 .AND. uref .LT. 30.0) THEN + znott = tn5 + tn4*uref + tn3*uref**2 + tn2*uref**3 + tn1*uref**4 + & + tn0*uref**5 + ELSEIF ( uref .GE. 30.0 .AND. uref .LT. 60.0) THEN + znott = tt7 + tt6*uref + tt5*uref**2 + tt4*uref**3 + tt3*uref**4 + & + tt2*uref**5 + tt1*uref**6 + tt0*uref**7 + ELSE + znott = ta6 + ta5*uref + ta4*uref**2 + ta3*uref**3 + ta2*uref**4 + & + ta1*uref**5 + ta0*uref**6 + END IF + + END SUBROUTINE znot_t_v1 + + SUBROUTINE znot_t_v0(uref,znott) + IMPLICIT NONE + +! uref(m/s) : Reference level wind +! znott(meter): Roughness scale for temperature/moisture +! Author : Biju Thomas on 02/07/2014 + + REAL, INTENT(IN) :: uref + REAL, INTENT(OUT):: znott + + IF ( uref .LT. 7.0 ) THEN + znott = (0.0185 / 9.8*(7.59e-4*uref**2+2.46e-2*uref)**2) + ELSE + znott = (0.2375*exp(-0.5250*uref) + 0.0025*exp(-0.0211*uref))*0.01 + END IF + + END SUBROUTINE znot_t_v0 + + + SUBROUTINE znot_t_v2(uu,znott) + IMPLICIT NONE + +! uu in MKS +! znott in m +! Biju Thomas on 02/12/2015 +! + + REAL, INTENT(IN) :: uu + REAL, INTENT(OUT):: znott + REAL :: ta0, ta1, ta2, ta3, ta4, ta5, ta6 + REAL :: tb0, tb1, tb2, tb3, tb4, tb5, tb6 + REAL :: tt0, tt1, tt2, tt3, tt4, tt5, tt6 + + ta0 = 2.51715926619e-09 + ta1 = -1.66917514012e-07 + ta2 = 4.57345863551e-06 + ta3 = -6.64883696932e-05 + ta4 = 0.00054390175125 + ta5 = -0.00239645231325 + ta6 = 0.00453024927761 + + + tb0 = -1.72935914649e-14 + tb1 = 2.50587455802e-12 + tb2 = -7.90109676541e-11 + tb3 = -4.40976353607e-09 + tb4 = 3.68968179733e-07 + tb5 = -9.43728336756e-06 + tb6 = 8.90731312383e-05 + + tt0 = 4.68042680888e-14 + tt1 = -1.98125754931e-11 + tt2 = 3.41357133496e-09 + tt3 = -3.05130605309e-07 + tt4 = 1.48243563819e-05 + tt5 = -0.000367207751936 + tt6 = 0.00357204479347 + + IF ( uu .LE. 7.0 ) THEN + znott = (0.0185 / 9.8*(7.59e-4*uu**2+2.46e-2*uu)**2) + ELSEIF ( uu .GE. 7.0 .AND. uu .LT. 15. ) THEN + znott = ta6 + ta5*uu + ta4*uu**2 + ta3*uu**3 + ta2*uu**4 + & + ta1*uu**5 + ta0*uu**6 + ELSEIF ( uu .GE. 15.0 .AND. uu .LT. 60.0) THEN + znott = tb6 + tb5*uu + tb4*uu**2 + tb3*uu**3 + tb2*uu**4 + & + tb1*uu**5 + tb0*uu**6 + ELSE + znott = tt6 + tt5*uu + tt4*uu**2 + tt3*uu**3 + tt2*uu**4 + & + tt1*uu**5 + tt0*uu**6 + END IF + + END SUBROUTINE znot_t_v2 + + +END MODULE module_sf_exchcoef + diff --git a/wrfv2_fire/phys/module_sf_gfdl.F b/wrfv2_fire/phys/module_sf_gfdl.F index ccfcbc8e..23888282 100755 --- a/wrfv2_fire/phys/module_sf_gfdl.F +++ b/wrfv2_fire/phys/module_sf_gfdl.F @@ -16,8 +16,11 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D, & UST,PSIM,PSIH, & XLAND,HFX,QFX,TAUX,TAUY,LH,GSW,GLW,TSK,FLHC,FLQC, & ! gopal's doing for Ocean coupling QGH,QSFC,U10,V10, & + ICOEF_SF, LCURR_SF, & + pert_Cd, ens_random_seed, ens_Cdamp, & GZ1OZ0,WSPD,BR,ISFFLX, & EP1,EP2,KARMAN,NTSFLG,SFENTH, & + Cd_out,Ch_out, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -90,6 +93,11 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & ISFFLX,NUM_SOIL_LAYERS,NTSFLG + INTEGER, INTENT(IN) :: ICOEF_SF + LOGICAL, INTENT(IN) :: LCURR_SF + logical,intent(in) :: pert_Cd + integer,intent(in) :: ens_random_seed + real,intent(in) :: ens_Cdamp REAL, INTENT(IN) :: & CP, & @@ -120,6 +128,8 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D, & TSK, & BR, & CHS, & + Cd_out, & + Ch_out, & CHS2, & CPM, & CQS2, & @@ -144,8 +154,7 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D, & REAL, DIMENSION(ims:ime, jms:jme), INTENT(OUT) :: & U10, & - V10 - + V10 !--------------------------- LOCAL VARS ------------------------------ @@ -262,6 +271,8 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D, & WRITE(message,*)'WITHIN THE GFDL SCHEME, NTSFLG=1 FOR GFDL SLAB 2010 UPGRADS',NTSFLG call wrf_debug(1,message) +!! write(0,*)'icoef_sf,lcurr_sf=',icoef_sf,lcurr_sf + DO J=jts,jte DO i=its,ite @@ -328,6 +339,8 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D, & CALL MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mzoc for momentum Zo KWON pspc,pkmax,wetc,slwdc,tjloc, & + icoef_sf,lcurr_sf, & + pert_Cd, ens_random_seed, ens_Cdamp, & upc,vpc,tpc,rpc,dt,J,wind10,xxfh2,ntsflg,SFENTH, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -415,7 +428,8 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D, & fh2(i) = karman*xxfh2(i) ch(i) = karman*karman/(fm(i) * fh(i)) cm(i) = cdm(i) - + Cd_out(i,j) = cm(i) + Ch_out(i,j) = ch(i) U10(i,j)=U10M(i) V10(i,j)=V10M(i) BR(i,j)=rib(i) @@ -533,6 +547,8 @@ END SUBROUTINE SF_GFDL !------------------------------------------------------------------- SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mzoc KWON pspc,pkmax,wetc,slwdc,tjloc, & + icoef_sf,lcurr_sf, & + pert_Cd, ens_random_seed, ens_Cdamp, & upc,vpc,tpc,rpc,dt,jfix,wind10,xxfh2,ntsflg,sfenth, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -548,6 +564,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mz ! !------------------------------------------------------------------------ + USE module_sf_exchcoef IMPLICIT NONE ! use allocate_mod ! use module_TLDATA , ONLY : tab,table,cp,g,rgas,og @@ -577,6 +594,11 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mz integer,intent(in) :: ims,ime, jms,jme, kms,kme integer,intent(in) :: its,ite, jts,jte, kts,kte integer,intent(in) :: jfix,ntsflg + integer,intent(in) :: icoef_sf + logical,intent(in) :: lcurr_sf + logical,intent(in) :: pert_Cd + integer,intent(in) :: ens_random_seed + real,intent(in) :: ens_Cdamp real, intent (out), dimension (ims :ime ) :: fxh real, intent (out), dimension (ims :ime ) :: fxe @@ -701,7 +723,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mz real :: shfx,sigt4,reflect real :: cor1,cor2,szetho,zal2gh,cons_p000001,cons_7,vis,ustar,restar,rat real :: wndm,ckg - real :: yz,y1,y2,y3,y4,windmks,znott,znotm + real :: windmks,znott,znotm integer:: i,j,ii,iq,nnest,icnt,ngd,ip !----------------------------------------------------------------------- @@ -808,6 +830,23 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mz real,parameter :: og = 1./g character*255 :: message ! +#if HWRF==1 + real*8 :: gasdev,ran1 !zhang + real :: rr !zhang + logical,save :: pert_Cd_local !zhang + integer,save :: ens_random_seed_local !zhang + real,save :: ens_Cdamp_local !zhang + data ens_random_seed_local/0/ + if ( ens_random_seed_local .eq. 0 ) then +! CALL nl_get_pert_Cd(1,pert_Cd) +! CALL nl_get_ens_random_seed(1,ens_random_seed) +! CALL nl_get_ens_Cdamp(1,ens_Cdamp) + ens_random_seed_local=ens_random_seed + pert_Cd_local=pert_Cd + ens_Cdamp_local=ens_Cdamp + endif +#endif + ! character*10 routine ! routine = 'mflux2' ! @@ -820,11 +859,11 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mz ! cor1 = .120 cor2 = 720. - yz= 0.0001344 - y1= 3.015e-05 - y2= 1.517e-06 - y3= -3.567e-08 - y4= 2.046e-10 +! KWON : remove the artificial increase of 10m wind speed over 60kts +! which comes from GFDL hurricane model +! cor1 = 0. +! cor2 = 0. +! do i = its,ite z10(i) = 1000. @@ -852,33 +891,22 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mz else ecof(i) = wetc(i) land(i) = 0.0 - zot (i) = zoc(i) -! now use 2 regime fit for znot thermal windmks=wind(i)*.01 - znott=0.2375*exp(-0.5250*windmks) + 0.0025*exp(-0.0211*windmks) - znott=0.01*znott -! go back to moon et al for below 7m/s - if(windmks.le. 7.) & - znott = (0.0185/9.8*(7.59e-8*wind(i)**2+ & - 2.46e-4*wind(i))**2) -! back to cgs - zot (i) = 100.*znott -! end of kwon correction.... -! in hwrf, thermal znot(zot) is passed as argument zoc -! in hwrf, momentum znot is recalculated internally - zoc(i)=-(0.0185/9.8*(7.59e-8*wind(i)**2+ & - 2.46e-4*wind(i))**2)*100. - if(wind(i).ge.1250.0) & - zoc(i)=-(.000739793 * wind(i) -0.58)/10 - if(wind(i).ge.3000.) then - windmks=wind(i)*.01 -! kwon znotm - znotm = yz +windmks*y1 +windmks**2*y2 +windmks**3*y3 +windmks**4*y4 !powell 2003 -! back to cgs - zoc(i) = 100.*znotm - endif + if ( icoef_sf .EQ. 1) then + call znot_m_v1(windmks,znotm) + call znot_t_v1(windmks,znott) + else if ( icoef_sf .EQ. 0 ) then + call znot_m_v0(windmks,znotm) + call znot_t_v0(windmks,znott) + else + call znot_m_v1(windmks,znotm) + call znot_t_v2(windmks,znott) + endif + zoc(i) = -100.*znotm + zot(i) = -100* znott endif + !------------------------------------------------------------------------ ! where necessary modify zo values over ocean. !------------------------------------------------------------------------ @@ -933,8 +961,8 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mz tab1 (i) = tstar(i) - 153.16 it (i) = IFIX(tab1(i)) tab2 (i) = tab1(i) - FLOAT(it(i)) - t1 (i) = tab(it(i) + 1) - t2 (i) = table(it(i) + 1) + t1 (i) = tab(min(223,max(1,it(i) + 1))) + t2 (i) = table(min(223,max(1,it(i) + 1))) estso(i) = t1(i) + tab2(i)*t2(i) psps1 = (pss(i) - estso(i)) if(psps1 .EQ. 0.0)then @@ -1497,8 +1525,8 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mz tab1 (i) = tsp(i) - 153.16 it (i) = IFIX(tab1(i)) tab2 (i) = tab1(i) - FLOAT(it(i)) - t1 (i) = tab(it(i) + 1) - t2 (i) = table(it(i) + 1) + t1 (i) = tab(min(223,max(1,it(i) + 1))) + t2 (i) = table(min(223,max(1,it(i) + 1))) estsop(i) = t1(i) + tab2(i)*t2(i) psps2 = (pssp(i) - estsop(i)) if(psps2 .EQ. 0.0)then @@ -1583,6 +1611,14 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc, & !mz cdm(i) = 1./(xxfm(i)*xxfm(i)) ! print *, 'i,zot,zoc,cdm,cdm2,tsg,wind', & ! i, zot(i),zoc(i), cdm(i),cdm2(i), tsg(i),wind(i) +#if HWRF==1 +! randomly perturb the Cd + if( pert_Cd_local ) then + rr=2.0*ens_Cdamp_local*ran1(ens_random_seed_local)-ens_Cdamp_local + cdm(i) = cdm(i) *(1.0+rr) + endif +#endif + enddo return diff --git a/wrfv2_fire/phys/module_sf_mynn.F b/wrfv2_fire/phys/module_sf_mynn.F index b5639be4..2fb643f4 100644 --- a/wrfv2_fire/phys/module_sf_mynn.F +++ b/wrfv2_fire/phys/module_sf_mynn.F @@ -1,12 +1,15 @@ +#define MYNN_DBG_LVL 3000 +!WRF:MODEL_LAYER:PHYSICS +! MODULE module_sf_mynn !------------------------------------------------------------------- !Modifications implemented by Joseph Olson NOAA/GSD/AMB - CU/CIRES -!for WRFv3.4 and WRFv3.4.1: +!for WRFv3.4, v3.4.1, v3.5.1, v3.6, and v3.7.1: ! ! BOTH LAND AND WATER: !1) Calculation of stability parameter (z/L) taken from Li et al. (2010 BLM) -! for first iteration of first time step; afterwards, exact calculation. +! for first iteration of first time step; afterwards, exact calculation. !2) Fixed isflux=0 option to turn off scalar fluxes, but keep momentum ! fluxes for idealized studies (credit: Anna Fitch). !3) Kinematic viscosity now varies with temperature @@ -25,16 +28,22 @@ MODULE module_sf_mynn ! ! WATER only: !1) isftcflx option is now available with the following options: -! (default) =0: z0, zt, and zq from COARE3.0 (Fairall et al 2003) -! =1: z0 from Davis et al (2008), zt & zq from COARE3.0 -! =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) -! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE3.0 -! =4: z0 from Zilitinkevich (2001), zt & zq from COARE3.0 +! (default) =0: z0, zt, and zq from the COARE algorithm. Set COARE_OPT (below) to +! 3.0 (Fairall et al. 2003) +! 3.5 (Edson et al 2013; default) +! =1: z0 from Davis et al (2008), zt & zq from COARE 3.0/3.5 +! =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) +! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE 3.0/3.5 +! =4: z0 from Zilitinkevich (2001), zt & zq from COARE 3.0/3.5 ! ! SNOW/ICE only: !1) Added Andreas (2002) snow/ice parameterization for thermal and -! moisture roughness to help reduce the cool/moist bias in the arctic -! region. +! moisture roughness to help reduce the cool/moist bias in the arctic +! region. Also added a z0 mod for snow (Andreas et al. 2005, BLM), which +! +! Misc: +! 2) added a more elaborate diagnostic for u10 & V10 for high vertical resolution +! model configurations. ! !NOTE: This code was primarily tested in combination with the RUC LSM. ! Performance with the Noah (or other) LSM is relatively unknown. @@ -44,7 +53,7 @@ MODULE module_sf_mynn USE module_sf_sfclay, ONLY: sfclayinit USE module_bl_mynn, only: tv0, mym_condensation -! USE module_wrf_error + USE module_wrf_error !------------------------------------------------------------------- IMPLICIT NONE !------------------------------------------------------------------- @@ -53,7 +62,8 @@ MODULE module_sf_mynn REAL, PARAMETER :: wmin=0.1 ! Minimum wind speed REAL, PARAMETER :: VCONVC=1.0 - REAL, PARAMETER :: SNOWZ0=0.012 + REAL, PARAMETER :: SNOWZ0=0.011 + REAL, PARAMETER :: COARE_OPT=3.5 ! 3.0 or 3.5 REAL, DIMENSION(0:1000 ),SAVE :: PSIMTB,PSIHTB @@ -82,6 +92,7 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & KARMAN,itimestep,ch,th3d,pi3d,qc3d,rho3d, & tsq,qsq,cov,sh3d,el_pbl,qcg, & + icloud_bl,qc_bl,cldfra_bl, & !JOE-add output ! z0zt_ratio,BulkRi,wstar,qstar,resist,logres, & !JOE-end @@ -108,7 +119,7 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & !-- PSFCPA surface pressure (Pa) !-- ZNT roughness length (m) !-- UST u* in similarity theory (m/s) -!-- USTM u* in similarity theory (m/s) w* added to WSPD. This is +!-- USTM u* in similarity theory (m/s) w* added to WSPD. This is ! used to couple with TKE scheme but not in MYNN. ! (as of now, USTM = UST in this version) !-- PBLH PBL height from previous time (m) @@ -149,16 +160,16 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & !-- EP2 constant for spec. hum. calc (Rd/Rv = 0.622) (dimensionless) !-- EP3 constant for spec. hum. calc (1 - Rd/Rv = 0.378 ) (dimensionless) !-- KARMAN Von Karman constant -!-- ck enthalpy exchange coeff at 10 meters -!-- cd momentum exchange coeff at 10 meters -!-- cka enthalpy exchange coeff at the lowest model level -!-- cda momentum exchange coeff at the lowest model level -!-- isftcflx =0: z0, zt, and zq from COARE3.0 (Fairall et al 2003) -! (water =1: z0 from Davis et al (2008), zt & zq from COARE3.0 +!-- ck enthalpy exchange coeff at 10 meters +!-- cd momentum exchange coeff at 10 meters +!-- cka enthalpy exchange coeff at the lowest model level +!-- cda momentum exchange coeff at the lowest model level +!-- isftcflx =0: z0, zt, and zq from COARE3.0/3.5 (Fairall et al 2003/Edson et al 2013) +! (water =1: z0 from Davis et al (2008), zt & zq from COARE3.0/3.5 ! only) =2: z0 from Davis et al (2008), zt & zq from Garratt (1992) -! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE3.0 -! =4: z0 from Zilitinkevich (2001), zt & zq from COARE3.0 -!-- iz0tlnd =0: Zilitinkevich (1995) with Czil=0.14, +! =3: z0 from Taylor and Yelland (2004), zt and zq from COARE 3.0/3.5 +! =4: z0 from Zilitinkevich (2001), zt & zq from COARE 3.0/3.5 +!-- iz0tlnd =0: Zilitinkevich (1995) with Czil=0.10, ! (land =1: Czil_new (modified according to Chen & Zhang 2008) ! only) =2: Modified Yang et al (2002, 2008) - generalized for all landuse ! =3: constant zt = z0/7.4 (Garratt 1992) @@ -170,6 +181,9 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & !-- cov = T'q' from PBL scheme !-- tsq = T'T' from PBL scheme !-- qsq = q'q' from PBL scheme +!-- icloud_bl = namelist option for subgrid scale cloud/radiation feedback +!-- qc_bl = subgrid scale (bloundary layer) clouds +!-- cldfra_bl = subgridscale cloud fraction ! !-- ids start index for i in domain !-- ide end index for i in domain @@ -202,7 +216,8 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & !NAMELIST OPTIONS: INTEGER, INTENT(IN) :: ISFFLX INTEGER, OPTIONAL, INTENT(IN) :: ISFTCFLX, IZ0TLND,& - bl_mynn_cloudpdf + bl_mynn_cloudpdf,& + icloud_bl !=================================== ! 3D VARIABLES !=================================== @@ -213,7 +228,10 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & T3D, & QC3D, & U3D,V3D, & - RHO3D,th3d,pi3d,tsq,qsq,cov,sh3d,el_pbl + RHO3D,th3d,pi3d,tsq,qsq,cov,sh3d,el_pbl + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: qc_bl, & + cldfra_bl !=================================== ! 2D VARIABLES !=================================== @@ -223,17 +241,16 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & XLAND, & TSK, & QCG, & - PSFCPA , & + PSFCPA ,& SNOWH + REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT ) :: U10,V10, & TH2,T2,Q2 REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(OUT) :: ck,cka,cd,cda - REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: ustm + INTENT(OUT) :: ck,cka,cd,cda,ustm ! REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: REGIME, & @@ -264,11 +281,19 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & !=================================== REAL, DIMENSION( its:ite ) :: U1D, & V1D, & + U1D2,V1D2, & !level2 winds QV1D, & P1D, & T1D,QC1D, & RHO1D, & - dz8w1d + dz8w1d, & !level 1 height + dz2w1d !level 2 height + + ! VARIABLE FOR PASSING TO MYM_CONDENSATION + REAL, DIMENSION(kts:kts+1 ) :: dummy1,dummy2,dummy3,dummy4, & + dummy5,dummy6,dummy7,dummy8, & + dummy9,dummy10,dummy11, & + dummy12,dummy13 REAL, DIMENSION( its:ite ) :: vt1,vq1 REAL, DIMENSION(kts:kts+1) :: thl, qw, vt, vq @@ -284,8 +309,12 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & DO J=jts,jte DO i=its,ite dz8w1d(I) = dz8w(i,kts,j) + dz2w1d(I) = dz8w(i,kts+1,j) U1D(i) =U3D(i,kts,j) V1D(i) =V3D(i,kts,j) + !2nd model level winds - for diags with high-res grids + U1D2(i) =U3D(i,kts+1,j) + V1D2(i) =V3D(i,kts+1,j) QV1D(i)=QV3D(i,kts,j) QC1D(i)=QC3D(i,kts,j) P1D(i) =P3D(i,kts,j) @@ -304,31 +333,65 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & ENDDO ELSE DO i=its,ite - do k = kts,kts+1 + DO k = kts,kts+1 ql = qc3d(i,k,j)/(1.+qc3d(i,k,j)) qw(k) = qv3d(i,k,j)/(1.+qv3d(i,k,j)) + ql thl(k) = th3d(i,k,j)-xlvcp*ql/pi3d(i,k,j) - end do + dummy1(k)=dz8w(i,k,j) + dummy2(k)=thl(k) + dummy3(k)=qw(k) + dummy4(k)=p3d(i,k,j) + dummy5(k)=pi3d(i,k,j) + dummy6(k)=tsq(i,k,j) + dummy7(k)=qsq(i,k,j) + dummy8(k)=cov(i,k,j) + dummy9(k)=Sh3d(i,k,j) + dummy10(k)=el_pbl(i,k,j) + if(icloud_bl > 0) then + dummy11(k)=qc_bl(i,k,j) + dummy12(k)=cldfra_bl(i,k,j) + else + dummy11(k)=0.0 + dummy12(k)=0.0 + endif + dummy13(k)=0.0 + ENDDO ! NOTE: The last grid number is kts+1 instead of kte. - CALL mym_condensation (kts,kts+1, & - & dz8w(i,kts:kts+1,j), & - & thl(kts:kts+1), qw(kts:kts+1), & - & p3d(i,kts:kts+1,j), & - & pi3d(i,kts:kts+1,j), & - & tsq(i,kts:kts+1,j), & - & qsq(i,kts:kts+1,j), & - & cov(i,kts:kts+1,j), & - & Sh3d(i,kts:kts+1,j), & !JOE - cloud PDF testing - & el_pbl(i,kts:kts+1,j), & !JOE - cloud PDF testing - & bl_mynn_cloudpdf, & !JOE - cloud PDF testing + CALL mym_condensation (kts,kts+1, dx, & + & dummy1,dummy2,dummy3, & + & dummy4,dummy5,dummy6, & + & dummy7,dummy8,dummy9, & + & dummy10,bl_mynn_cloudpdf,& + & dummy11,dummy12, & + & PBLH(i,j),HFX(i,j), & + & dummy13, & & vt(kts:kts+1), vq(kts:kts+1)) + +! ! NOTE: The last grid number is kts+1 instead of kte. +! CALL mym_condensation (kts,kts+1, dx, & +! & dz8w(i,kts:kts+1,j), & +! & thl(kts:kts+1), & +! & qw(kts:kts+1), & +! & p3d(i,kts:kts+1,j), & +! & pi3d(i,kts:kts+1,j), & +! & tsq(i,kts:kts+1,j), & +! & qsq(i,kts:kts+1,j), & +! & cov(i,kts:kts+1,j), & +! & Sh3d(i,kts:kts+1,j), & !JOE - cloud PDF testing +! & el_pbl(i,kts:kts+1,j), & !JOE - cloud PDF testing +! & bl_mynn_cloudpdf, & !JOE - cloud PDF testing +! & qc_bl2D(i,kts:kts+1), & !JOE-subgrid BL clouds +! & cldfra_bl2D(i,kts:kts+1),& !JOE-subgrid BL clouds +! & PBLH(i,j),HFX(i,j), & !JOE-subgrid BL clouds +! & vt(kts:kts+1), vq(kts:kts+1)) vt1(i) = vt(kts) vq1(i) = vq(kts) ENDDO ENDIF CALL SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & + U1D2,V1D2,dz2w1d, & CP,G,ROVCP,R,XLV,PSFCPA(ims,j),CHS(ims,j),CHS2(ims,j),& CQS2(ims,j),CPM(ims,j),PBLH(ims,j), RMOL(ims,j), & ZNT(ims,j),UST(ims,j),MAVAIL(ims,j),ZOL(ims,j), & @@ -339,9 +402,10 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w, & QGH(ims,j),QSFC(ims,j),LH(ims,j), & GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & - ch(ims,j),vt1,vq1,qc1d,qcg(ims,j),itimestep, & + ch(ims,j),vt1,vq1,qc1d,qcg(ims,j), & + itimestep, & !JOE-begin additional output - z0zt_ratio(ims,j),BulkRi(ims,j),wstar(ims,j), & + z0zt_ratio(ims,j),wstar(ims,j), & qstar(ims,j),resist(ims,j),logres(ims,j), & !JOE-end ids,ide, jds,jde, kds,kde, & @@ -358,15 +422,17 @@ END SUBROUTINE SFCLAY_MYNN !------------------------------------------------------------------- SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & + U1D2,V1D2,dz2w1d, & CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM, & PBLH,RMOL,ZNT,UST,MAVAIL,ZOL,MOL,REGIME, & PSIM,PSIH,XLAND,HFX,QFX,TSK, & U10,V10,TH2,T2,Q2,FLHC,FLQC,SNOWH,QGH, & QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2, & - KARMAN,ch,vt1,vq1,qc1d,qcg,itimestep, & + KARMAN,ch,vt1,vq1,qc1d,qcg, & + itimestep, & !JOE-additional output - zratio,BRi,wstar,qstar,resist,logres, & + zratio,wstar,qstar,resist,logres, & !JOE-end ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -408,9 +474,10 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & SNOWH REAL, DIMENSION( its:ite ), INTENT(IN) :: U1D,V1D, & + U1D2,V1D2, & QV1D,P1D, & T1D,QC1d, & - dz8w1d, & + dz8w1d,dz2w1d, & RHO1D, & vt1,vq1 @@ -435,12 +502,10 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & TH2,T2,Q2 REAL, OPTIONAL, DIMENSION( ims:ime ) , & - INTENT(OUT) :: ck,cka,cd,cda - REAL, OPTIONAL, DIMENSION( ims:ime ) , & - INTENT(INOUT) :: ustm + INTENT(OUT) :: ck,cka,cd,cda,ustm !-------------------------------------------- !JOE-additinal output - REAL, DIMENSION( ims:ime ) :: zratio,BRi,wstar,qstar, & + REAL, DIMENSION( ims:ime ) :: zratio,wstar,qstar, & resist,logres !JOE-end !---------------------------------------------------------------- @@ -450,6 +515,7 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & REAL, DIMENSION(its:ite) :: & ZA, & !Height of lowest 1/2 sigma level(m) + ZA2, & !Height of 2nd lowest 1/2 sigma level(m) THV1D, & !Theta-v at lowest 1/2 sigma (K) TH1D, & !Theta at lowest 1/2 sigma (K) TC1D, & !T at lowest 1/2 sigma (Celsius) @@ -471,7 +537,7 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & GZ1OZt !LOG((ZA(I)+z_t(i))/z_t(i)) INTEGER :: N,I,K,L,NZOL,NK,NZOL2,NZOL10, ITER - INTEGER, PARAMETER :: ITMAX=5 + INTEGER, PARAMETER :: ITMAX=1 REAL :: PL,THCON,TVCON,E1 REAL :: DTHVDZ,DTHVM,VCONV,RZOL,RZOL2,RZOL10,ZOL2,ZOL10 @@ -497,10 +563,11 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & QVSH(I)=QV1D(I)/(1.+QV1D(I)) !CONVERT TO SPEC HUM (kg/kg) TVCON=(1.+EP1*QVSH(I)) THV1D(I)=TH1D(I)*TVCON !(K) - TV1D(I)=T1D(I)*TVCON !(K) + TV1D(I)=T1D(I)*TVCON !(K) !RHO1D(I)=PSFCPA(I)/(R*TV1D(I)) !now using value calculated in sfc driver ZA(I)=0.5*dz8w1d(I) !height of first half-sigma level + ZA2(I)=dz8w1d(I) + 0.5*dz2w1d(I) !height of 2nd half-sigma level GOVRTH(I)=G/TH1D(I) ENDDO @@ -576,7 +643,7 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & !JOE-the Wyngaard formula is ~3 times larger than the Beljaars !formula, so switch to Beljaars for water, but use VCONVC = 1.25, - !as in the COARE3.0 bulk parameterizations. + !as in the COARE 3.0/3.5 bulk parameterizations. !IF(-DTHVDZ.GE.0)THEN ! DTHVM=-DTHVDZ !ELSE @@ -603,11 +670,9 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & !-------------------------------------------------------- BR(I)=GOVRTH(I)*ZA(I)*DTHVDZ/(WSPD(I)*WSPD(I)) !SET LIMITS ACCORDING TO Li et al. (2010) Boundary-Layer Meteorol (p.158) - !JOE: defying limits: BR(I)=MAX(BR(I),-2.0) BR(I)=MAX(BR(I),-20.0) BR(I)=MIN(BR(I),2.0) - BRi(I)=BR(I) !new variable for output - BR is not a "state" variable. - + ! IF PREVIOUSLY UNSTABLE, DO NOT LET INTO REGIMES 1 AND 2 (STABLE) !if (itimestep .GT. 1) THEN ! IF(MOL(I).LT.0.)BR(I)=MIN(BR(I),0.0) @@ -647,19 +712,35 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & !-------------------------------------- IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX .EQ. 0 ) THEN - !NAME OF SUBROUTINE IS MISLEADING - ACTUALLY VARIABLE CHARNOCK - !PARAMETER FROM COARE3.0: - CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc) + IF (COARE_OPT .EQ. 3.0) THEN + !COARE 3.0 (MISLEADING SUBROUTINE NAME) + CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ELSE + !COARE 3.5 + CALL edson_etal_2013(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ENDIF ELSEIF ( ISFTCFLX .EQ. 1 .OR. ISFTCFLX .EQ. 2 ) THEN CALL davis_etal_2008(ZNT(i),UST(i)) ELSEIF ( ISFTCFLX .EQ. 3 ) THEN - CALL Taylor_Yelland_2001(ZNT(i),UST(i),WSPD(i)) + CALL Taylor_Yelland_2001(ZNT(i),UST(i),WSPD(i)) ELSEIF ( ISFTCFLX .EQ. 4 ) THEN - CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc) + IF (COARE_OPT .EQ. 3.0) THEN + !COARE 3.0 (MISLEADING SUBROUTINE NAME) + CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ELSE + !COARE 3.5 + CALL edson_etal_2013(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ENDIF ENDIF ELSE - !DEFAULT TO COARE 3.0 - CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc) + !DEFAULT TO COARE 3.0/3.5 + IF (COARE_OPT .EQ. 3.0) THEN + !COARE 3.0 + CALL charnock_1955(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ELSE + !COARE 3.5 + CALL edson_etal_2013(ZNT(i),UST(i),WSPD(i),visc,ZA(I)) + ENDIF ENDIF !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING NEW ZNT @@ -673,20 +754,37 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & !-------------------------------------- IF ( PRESENT(ISFTCFLX) ) THEN IF ( ISFTCFLX .EQ. 0 ) THEN - CALL fairall_2001(z_t(i),z_q(i),restar,UST(i),visc) + IF (COARE_OPT .EQ. 3.0) THEN + CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) + ELSE + !presumably, this will be published soon, but hasn't yet + CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc) + ENDIF ELSEIF ( ISFTCFLX .EQ. 1 ) THEN - CALL fairall_2001(z_t(i),z_q(i),restar,UST(i),visc) + IF (COARE_OPT .EQ. 3.0) THEN + CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) + ELSE + CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc) + ENDIF ELSEIF ( ISFTCFLX .EQ. 2 ) THEN CALL garratt_1992(z_t(i),z_q(i),ZNT(i),restar,XLAND(I)) ELSEIF ( ISFTCFLX .EQ. 3 ) THEN - CALL fairall_2001(z_t(i),z_q(i),restar,UST(i),visc) + IF (COARE_OPT .EQ. 3.0) THEN + CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) + ELSE + CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc) + ENDIF ELSEIF ( ISFTCFLX .EQ. 4 ) THEN CALL zilitinkevich_1995(ZNT(i),z_t(i),z_q(i),restar,& UST(I),KARMAN,XLAND(I),IZ0TLND) ENDIF ELSE - !DEFAULT TO COARE 3.0 - CALL fairall_2001(z_t(i),z_q(i),restar,UST(i),visc) + !DEFAULT TO COARE 3.0/3.5 + IF (COARE_OPT .EQ. 3.0) THEN + CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc) + ELSE + CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc) + ENDIF ENDIF ELSE @@ -703,7 +801,7 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & !CHECK FOR SNOW/ICE POINTS OVER LAND !IF ( ZNT(i) .LE. SNOWZ0 .AND. TSK(I) .LE. 273.15 ) THEN IF ( SNOWH(i) .GE. 0.1) THEN - CALL Andreas_2002(ZNT(i),restar,z_t(i),z_q(i)) + CALL Andreas_2002(ZNT(i),visc,ust(i),z_t(i),z_q(i)) ELSE IF ( PRESENT(IZ0TLND) ) THEN IF ( IZ0TLND .LE. 1 .OR. IZ0TLND .EQ. 4) THEN @@ -770,13 +868,13 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & !COMPUTE z/L !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I)) - IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN +! IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I)) - ELSE - ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I),0.001)**2) - ZOL(I)=MAX(ZOL(I),0.0) - ZOL(I)=MIN(ZOL(I),2.) - ENDIF +! ELSE +! ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I),0.001)**2) +! ZOL(I)=MAX(ZOL(I),0.0) +! ZOL(I)=MIN(ZOL(I),2.) +! ENDIF !COMPUTE PSIM and PSIH IF((XLAND(I)-1.5).GE.0)THEN @@ -964,12 +1062,24 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & !----------------------------------------------------- ! If the lowest model level is close to 10-m, use it ! instead of the flux-based diagnostic formula. - if (ZA(i) .gt. 7.0 .and. ZA(i) .lt. 13.0) then + if (ZA(i) .le. 7.0) then + ! high vertical resolution + if(ZA2(i) .gt. 7.0 .and. ZA2(i) .lt. 13.0) then + !use 2nd model level + U10(I)=U1D2(I) + V10(I)=V1D2(I) + else + U10(I)=U1D(I)*log(10./ZNT(I))/log(ZA(I)/ZNT(I)) + V10(I)=V1D(I)*log(10./ZNT(I))/log(ZA(I)/ZNT(I)) + endif + elseif(ZA(i) .gt. 7.0 .and. ZA(i) .lt. 13.0) then + !moderate vertical resolution U10(I)=U1D(I) V10(I)=V1D(I) - else - U10(I)=U1D(I)*PSIX10/PSIX - V10(I)=V1D(I)*PSIX10/PSIX + else + ! very coarse vertical resolution + U10(I)=U1D(I)*PSIX10/PSIX + V10(I)=V1D(I)*PSIX10/PSIX endif !----------------------------------------------------- @@ -1000,7 +1110,7 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & ITER = ITER+ITMAX ENDIF - !IF (I .eq. 2) THEN + !IF () THEN ! print*,"ITER:",ITER ! write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I)," Tstar:",MOL(I) ! write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I)," DTHV:",THV1D(I)-THVGB(I) @@ -1073,18 +1183,18 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & ! AND MOISTURE (FLQC) !------------------------------------------ FLQC(I)=RHO1D(I)*MAVAIL(I)*UST(I)*KARMAN/PSIQ - - DTTHX=ABS(TH1D(I)-THGB(I)) - IF(DTTHX.GT.1.E-5)THEN - FLHC(I)=CPM(I)*RHO1D(I)*UST(I)*MOL(I)/(TH1D(I)-THGB(I)) - ELSE - FLHC(I)=0. - ENDIF + FLHC(I)=RHO1D(I)*CPM(I)*UST(I)*KARMAN/PSIT + !OLD WAY: + !DTTHX=ABS(TH1D(I)-THGB(I)) + !IF(DTTHX.GT.1.E-5)THEN + ! FLHC(I)=CPM(I)*RHO1D(I)*UST(I)*MOL(I)/(TH1D(I)-THGB(I)) + !ELSE + ! FLHC(I)=0. + !ENDIF !---------------------------------- ! COMPUTE SURFACE MOISTURE FLUX: !---------------------------------- - QFX(I)=FLQC(I)*(QSFCMR(I)-QV1D(I)) !JOE: QFX(I)=MAX(QFX(I),0.) !originally did not allow neg QFX QFX(I)=MAX(QFX(I),-0.02) !allows small neg QFX, like MYJ @@ -1095,12 +1205,12 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & !---------------------------------- IF(XLAND(I)-1.5.GT.0.)THEN !WATER HFX(I)=FLHC(I)*(THGB(I)-TH1D(I)) -! IF ( PRESENT(ISFTCFLX) ) THEN -! IF ( ISFTCFLX.NE.0 ) THEN -! ! AHW: add dissipative heating term (commented out in 3.6.1 -! HFX(I)=HFX(I)+RHO1D(I)*USTM(I)*USTM(I)*WSPDI(I) -! ENDIF -! ENDIF + IF ( PRESENT(ISFTCFLX) ) THEN + IF ( ISFTCFLX.NE.0 ) THEN + ! AHW: add dissipative heating term + HFX(I)=HFX(I)+RHO1D(I)*USTM(I)*USTM(I)*WSPDI(I) + ENDIF + ENDIF ELSEIF(XLAND(I)-1.5.LT.0.)THEN !LAND HFX(I)=FLHC(I)*(THGB(I)-TH1D(I)) HFX(I)=MAX(HFX(I),-250.) @@ -1131,32 +1241,32 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d, & ENDIF !end ISFFLX option -! IF ( wrf_at_debug_level(3000) ) THEN -! IF (HFX(I) > 1200. .OR. HFX(I) < -500. .OR. & -! &LH(I) > 1200. .OR. LH(I) < -500. .OR. & -! &UST(I) < 0.0 .OR. UST(I) > 4.0 .OR. & -! &WSTAR(I)<0.0 .OR. WSTAR(I) > 6.0 .OR. & -! &RHO1D(I)<0.0 .OR. RHO1D(I) > 1.6 .OR. & -! &QSFC(I)*1000. <0.0 .OR. QSFC(I)*1000. >38. .OR. & -! &PBLH(I)>6000.) THEN -! print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& -! ITER-ITMAX," ITERATIONS",I,J -! write(*,1000)"HFX: ",HFX(I)," LH:",LH(I)," CH:",CH(I),& -! " PBLH:",PBLH(I) -! write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I),& -! " Tstar:",MOL(I) -! write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I),& -! " DTHV:",THV1D(I)-THVGB(I) -! write(*,1003)"CPM:",CPM(I)," RHO1D:",RHO1D(I)," L:",& -! ZOL(I)/ZA(I)," DTH:",TH1D(I)-THGB(I) -! write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNT(I)," Zt:",z_t(I),& -! " za:",za(I) -! write(*,1005)"Re:",restar," MAVAIL:",MAVAIL(I)," QSFC(I):",& -! QSFC(I)," QVSH(I):",QVSH(I) -! print*,"PSIX=",PSIX," Z0:",ZNT(I)," T1D(i):",T1D(i) -! write(*,*)"=============================================" -! ENDIF -! ENDIF + IF ( wrf_at_debug_level(3000) ) THEN + IF (HFX(I) > 1200. .OR. HFX(I) < -500. .OR. & + &LH(I) > 1200. .OR. LH(I) < -500. .OR. & + &UST(I) < 0.0 .OR. UST(I) > 4.0 .OR. & + &WSTAR(I)<0.0 .OR. WSTAR(I) > 6.0 .OR. & + &RHO1D(I)<0.0 .OR. RHO1D(I) > 1.6 .OR. & + &QSFC(I)*1000. <0.0 .OR. QSFC(I)*1000. >38. .OR. & + &PBLH(I)>6000.) THEN + print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",& + ITER-ITMAX," ITERATIONS",I,J + write(*,1000)"HFX: ",HFX(I)," LH:",LH(I)," CH:",CH(I),& + " PBLH:",PBLH(I) + write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I),& + " Tstar:",MOL(I) + write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I),& + " DTHV:",THV1D(I)-THVGB(I) + write(*,1003)"CPM:",CPM(I)," RHO1D:",RHO1D(I)," L:",& + ZOL(I)/ZA(I)," DTH:",TH1D(I)-THGB(I) + write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNT(I)," Zt:",z_t(I),& + " za:",za(I) + write(*,1005)"Re:",restar," MAVAIL:",MAVAIL(I)," QSFC(I):",& + QSFC(I)," QVSH(I):",QVSH(I) + print*,"PSIX=",PSIX," Z0:",ZNT(I)," T1D(i):",T1D(i) + write(*,*)"=============================================" + ENDIF + ENDIF ENDDO !end i-loop @@ -1261,6 +1371,7 @@ END SUBROUTINE Pan_etal_1994 !-------------------------------------------------------------- SUBROUTINE davis_etal_2008(Z_0,ustar) + !a.k.a. : Donelan et al. (2004) !This formulation for roughness length was designed to match !the labratory experiments of Donelan et al. (2004). !This is an update version from Davis et al. 2008, which @@ -1314,7 +1425,7 @@ SUBROUTINE Taylor_Yelland_2001(Z_0,ustar,wsp10) END SUBROUTINE Taylor_Yelland_2001 !-------------------------------------------------------------------- - SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc) + SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc,zu) !This version of Charnock's relation employs a varying !Charnock parameter, similar to COARE3.0 [Fairall et al. (2003)]. @@ -1322,23 +1433,54 @@ SUBROUTINE charnock_1955(Z_0,ustar,wsp10,visc) !between 10-m wsp = 10 and 18. IMPLICIT NONE - REAL, INTENT(IN) :: ustar, visc, wsp10 + REAL, INTENT(IN) :: ustar, visc, wsp10, zu REAL, INTENT(OUT) :: Z_0 REAL, PARAMETER :: G=9.81, CZO2=0.011 REAL :: CZC !variable charnock "constant" + REAL :: wsp10m ! logarithmically calculated 10 m + + wsp10m = wsp10*log(10./1e-4)/log(zu/1e-4) + CZC = CZO2 + 0.007*MIN(MAX((wsp10m-10.)/8., 0.), 1.0) - CZC = CZO2 + 0.007*MIN(MAX((wsp10-10.)/8., 0.), 1.0) - Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.1)) + Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.05)) Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) return END SUBROUTINE charnock_1955 +!-------------------------------------------------------------------- + SUBROUTINE edson_etal_2013(Z_0,ustar,wsp10,visc,zu) + + !This version of Charnock's relation employs a varying + !Charnock parameter, taken from COARE 3.5 [Edson et al. (2001, JPO)]. + !The Charnock parameter CZC is varied from about .005 to .028 + !between 10-m wind speeds of 6 and 19 m/s. + + IMPLICIT NONE + REAL, INTENT(IN) :: ustar, visc, wsp10, zu + REAL, INTENT(OUT) :: Z_0 + REAL, PARAMETER :: G=9.81 + REAL, PARAMETER :: m=0.017, b=-0.005 + REAL :: CZC ! variable charnock "constant" + REAL :: wsp10m ! logarithmically calculated 10 m + + wsp10m = wsp10*log(10/1e-4)/log(zu/1e-4) + wsp10m = MIN(19., wsp10m) + CZC = m*wsp10m + b + CZC = MAX(CZC, 0.0) + + Z_0 = CZC*ustar*ustar/G + (0.11*visc/MAX(ustar,0.07)) + Z_0 = MAX( Z_0, 1.27e-7) !These max/mins were suggested by + Z_0 = MIN( Z_0, 2.85e-3) !Davis et al. (2008) + + return + + END SUBROUTINE edson_etal_2013 !-------------------------------------------------------------------- SUBROUTINE garratt_1992(Zt,Zq,Z_0,Ren,landsea) - !This formulation for the thermal and moisture roughness lengths + !This formulation for the thermal and moisture roughness lengths !(Zt and Zq) relates them to Z0 via the roughness Reynolds number (Ren). !This formula comes from Fairall et al. (2003). It is modified from !the original Garratt-Brutsaert model to better fit the COARE/HEXMAX @@ -1369,20 +1511,15 @@ SUBROUTINE garratt_1992(Zt,Zq,Z_0,Ren,landsea) END SUBROUTINE garratt_1992 !-------------------------------------------------------------------- - SUBROUTINE fairall_2001(Zt,Zq,Ren,ustar,visc) + SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc) - !This formulation for thermal and moisture roughness length (Zt and Zq) - !as a function of the roughness Reynolds number (Ren) comes from the + !This formulation for thermal and moisture roughness length (Zt and Zq) + !as a function of the roughness Reynolds number (Ren) comes from the !COARE3.0 formulation, empirically derived from COARE and HEXMAX data ![Fairall et al. (2003)]. Edson et al. (2004; JGR) suspected that this - !relationship overestimated roughness lengths for low Reynolds number - !flows, so a smooth flow relationship, taken from Garrattt (1992, p. 102), - !is used for flows with Ren < 2. - ! - !Note that this formulation should not be used with the Davis et al. - !(2008) formulation for Zo, because that formulation produces much - !smaller u* (Ren), resulting in a large Zt and Zq. It works best with - !the Charnock or the Taylor and Yelland relationships. + !relationship overestimated the scalar roughness lengths for low Reynolds + !number flows, so an optional smooth flow relationship, taken from Garratt + !(1992, p. 102), is available for flows with Ren < 2. ! !This is for use over water only. @@ -1394,27 +1531,50 @@ SUBROUTINE fairall_2001(Zt,Zq,Ren,ustar,visc) Zt = (5.5e-5)*(Ren**(-0.60)) Zq = Zt - !FOR SMOOTH SEAS, USE GARRATT + !FOR SMOOTH SEAS, CAN USE GARRATT !Zq = 0.2*visc/MAX(ustar,0.1) !Zq = 0.3*visc/MAX(ustar,0.1) ELSE - - !FOR ROUGH SEAS, USE FAIRALL + + !FOR ROUGH SEAS, USE COARE Zt = (5.5e-5)*(Ren**(-0.60)) Zq = Zt - + ENDIF Zt = MIN(Zt,1.0e-4) Zt = MAX(Zt,2.0e-9) Zq = MIN(Zt,1.0e-4) - Zq = MAX(Zt,2.0e-9) - + Zq = MAX(Zt,2.0e-9) + + return + + END SUBROUTINE fairall_etal_2003 +!-------------------------------------------------------------------- + SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc) + + !This formulation for thermal and moisture roughness length (Zt and Zq) + !as a function of the roughness Reynolds number (Ren) comes from the + !COARE 3.5/4.0 formulation, empirically derived from COARE and HEXMAX data + ![Fairall et al. (2014? coming soon, not yet published as of July 2014)]. + !This is for use over water only. + + IMPLICIT NONE + REAL, INTENT(IN) :: Ren,ustar,visc + REAL, INTENT(OUT) :: Zt,Zq + + !Zt = (5.5e-5)*(Ren**(-0.60)) + Zt = MIN(1.6E-4, 5.8E-5/(Ren**0.72)) + Zq = Zt + + Zt = MAX(Zt,2.0e-9) + Zq = MAX(Zt,2.0e-9) + return - END SUBROUTINE fairall_2001 + END SUBROUTINE fairall_etal_2014 !-------------------------------------------------------------------- SUBROUTINE Yang_2008(Z_0,Zt,Zq,ustar,tstar,qst,Ren,visc,landsea) @@ -1433,44 +1593,57 @@ SUBROUTINE Yang_2008(Z_0,Zt,Zq,ustar,tstar,qst,Ren,visc,landsea) !to 7.2 (in 2008 paper). Their form typically varies the !ratio Z0/Zt by a few orders of magnitude (1-1E4). ! - !This modified form uses beta = 0.5 and Renc = 350, so zt generally - !varies similarly to the Zilitinkevich form for small/moderate heat - !fluxes but can become ~O(1/2 Zilitinkevich) for very large negative T*. - !Also, the exponent (0.25) on tstar was changed to 1.0, since we found - !Zt was reduced too much for low-moderate positive heat fluxes. + !This modified form uses beta = 1.5 and a variable Renc (function of Z_0), + !so zt generally varies similarly to the Zilitinkevich form (with Czil = 0.1) + !for very small or negative surface heat fluxes but can become close to the + !Zilitinkevich with Czil = 0.2 for very large HFX (large negative T*). + !Also, the exponent (0.25) on tstar was changed to 1.0, since we found + !Zt was reduced too much for low-moderate positive heat fluxes. ! !This should only be used over land! IMPLICIT NONE REAL, INTENT(IN) :: Z_0, Ren, ustar, tstar, qst, visc, landsea - REAL :: ht, tstar2 + REAL :: ht, &! roughness height at critical Reynolds number + tstar2, &! bounded T*, forced to be non-positive + qstar2, &! bounded q*, forced to be non-positive + Z_02, &! bounded Z_0 for variable Renc2 calc + Renc2 ! variable Renc, function of Z_0 REAL, INTENT(OUT) :: Zt,Zq - REAL, PARAMETER :: Renc=350., beta=0.5, e=2.71828183 - - ht = Renc*visc/MAX(ustar,0.01) + REAL, PARAMETER :: Renc=300., & !old constant Renc + beta=1.5, & !important for diurnal variation + m=170., & !slope for Renc2 function + b=691. !y-intercept for Renc2 function + + Z_02 = MIN(Z_0,0.5) + Z_02 = MAX(Z_02,0.04) + Renc2= b + m*log(Z_02) + ht = Renc2*visc/MAX(ustar,0.01) tstar2 = MIN(tstar, 0.0) + qstar2 = MIN(qst,0.0) Zt = ht * EXP(-beta*(ustar**0.5)*(ABS(tstar2)**1.0)) - !Zq = ht * EXP(-beta*(ustar**0.5)*(ABS(qst)**1.0)) - Zq = Zt - - Zt = MIN(Zt, Z_0/2.0) !(e**2.)) !limit from Garratt (1980,1992) - Zq = MIN(Zq, Z_0/2.0) !(e**2.)) !limit from Garratt (1980,1992) + Zq = ht * EXP(-beta*(ustar**0.5)*(ABS(qstar2)**1.0)) + !Zq = Zt + + Zt = MIN(Zt, Z_0/2.0) + Zq = MIN(Zq, Z_0/2.0) return END SUBROUTINE Yang_2008 !-------------------------------------------------------------------- - SUBROUTINE Andreas_2002(Z_0,Ren,Zt,Zq) + SUBROUTINE Andreas_2002(Z_0,bvisc,ustar,Zt,Zq) - !This is taken from Andreas (2002; J. of Hydromet). + ! This is taken from Andreas (2002; J. of Hydromet) and + ! Andreas et al. (2005; BLM). ! - !This should only be used over snow/ice! + ! This should only be used over snow/ice! IMPLICIT NONE - REAL, INTENT(IN) :: Z_0, Ren + REAL, INTENT(IN) :: Z_0, bvisc, ustar REAL, INTENT(OUT) :: Zt, Zq - REAL :: Ren2 + REAL :: Ren2, zntsno REAL, PARAMETER :: bt0_s=1.25, bt0_t=0.149, bt0_r=0.317, & bt1_s=0.0, bt1_t=-0.55, bt1_r=-0.565, & @@ -1479,26 +1652,31 @@ SUBROUTINE Andreas_2002(Z_0,Ren,Zt,Zq) REAL, PARAMETER :: bq0_s=1.61, bq0_t=0.351, bq0_r=0.396, & bq1_s=0.0, bq1_t=-0.628, bq1_r=-0.512, & bq2_s=0.0, bq2_t=0.0, bq2_r=-0.180 - - Ren2 = Ren + + !Calculate zo for snow (Andreas et al. 2005, BLM) + zntsno = 0.135*bvisc/ustar + & + (0.035*(ustar*ustar)/9.8) * & + (5.*exp(-1.*(((ustar - 0.18)/0.1)*((ustar - 0.18)/0.1))) + 1.) + Ren2 = ustar*zntsno/bvisc + ! Make sure that Re is not outside of the range of validity ! for using their equations IF (Ren2 .gt. 1000.) Ren2 = 1000. IF (Ren2 .le. 0.135) then - Zt = Z_0*EXP(bt0_s + bt1_s*LOG(Ren2) + bt2_s*LOG(Ren2)**2) - Zq = Z_0*EXP(bq0_s + bq1_s*LOG(Ren2) + bq2_s*LOG(Ren2)**2) + Zt = zntsno*EXP(bt0_s + bt1_s*LOG(Ren2) + bt2_s*LOG(Ren2)**2) + Zq = zntsno*EXP(bq0_s + bq1_s*LOG(Ren2) + bq2_s*LOG(Ren2)**2) ELSE IF (Ren2 .gt. 0.135 .AND. Ren2 .lt. 2.5) then - Zt = Z_0*EXP(bt0_t + bt1_t*LOG(Ren2) + bt2_t*LOG(Ren2)**2) - Zq = Z_0*EXP(bq0_t + bq1_t*LOG(Ren2) + bq2_t*LOG(Ren2)**2) + Zt = zntsno*EXP(bt0_t + bt1_t*LOG(Ren2) + bt2_t*LOG(Ren2)**2) + Zq = zntsno*EXP(bq0_t + bq1_t*LOG(Ren2) + bq2_t*LOG(Ren2)**2) ELSE - Zt = Z_0*EXP(bt0_r + bt1_r*LOG(Ren2) + bt2_r*LOG(Ren2)**2) - Zq = Z_0*EXP(bq0_r + bq1_r*LOG(Ren2) + bq2_r*LOG(Ren2)**2) + Zt = zntsno*EXP(bt0_r + bt1_r*LOG(Ren2) + bt2_r*LOG(Ren2)**2) + Zq = zntsno*EXP(bq0_r + bq1_r*LOG(Ren2) + bq2_r*LOG(Ren2)**2) ENDIF diff --git a/wrfv2_fire/phys/module_sf_noah_seaice.F b/wrfv2_fire/phys/module_sf_noah_seaice.F index 18b28451..16e725ff 100644 --- a/wrfv2_fire/phys/module_sf_noah_seaice.F +++ b/wrfv2_fire/phys/module_sf_noah_seaice.F @@ -469,7 +469,8 @@ SUBROUTINE SFLX_SEAICE (IILOC, JJLOC, SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SNOWH,ZSOIL,TBOT, & SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI,RIBB, & SEAICE_ALBEDO_OPT) - ETA_KINEMATIC = ESNOW +! ETA_KINEMATIC = ESNOW + ETA_KINEMATIC = ETP IF ( SEAICE_SNOWDEPTH_OPT == 0 ) THEN @@ -953,7 +954,7 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,SNOWNG, & ! ABOVE FREEZING BLOCK ! ---------------------------------------------------------------------- ELSE - T1 = TFREEZ * SNCOVR ** SNOEXP + T12 * (1.0- SNCOVR ** SNOEXP) + T1 = TFREEZ SSOIL = DF1 * (T1- STC (1)) / DTOT ! ---------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_sf_noahdrv.F b/wrfv2_fire/phys/module_sf_noahdrv.F index ef9e0130..9b80b265 100644 --- a/wrfv2_fire/phys/module_sf_noahdrv.F +++ b/wrfv2_fire/phys/module_sf_noahdrv.F @@ -9,7 +9,8 @@ MODULE module_sf_noahdrv & NSLTYPE, SLPCATS, SLOPE_DATA, SBETA_DATA, FXEXP_DATA, CSOIL_DATA, & & SALP_DATA, REFDK_DATA, REFKDT_DATA, FRZK_DATA, ZBOT_DATA, CZIL_DATA, & & SMLOW_DATA, SMHIGH_DATA, LVCOEF_DATA, NSLOPE, & - & FRH2O,ZTOPVTBL,ZBOTVTBL + & FRH2O,ZTOPVTBL,ZBOTVTBL, & + & LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL USE module_sf_urban, only: urban, oasis, IRI_SCHEME USE module_sf_noahlsm_glacial_only, only: sflx_glacial @@ -47,7 +48,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & XICE_THRESHOLD, & RDLAI2D,USEMONALB, & RIB, & !? - NOAHRES, & + NOAHRES,opt_thcnd, & ! Noah UA changes ua_phys,flx4_2d,fvb_2d,fbur_2d,fgsn_2d, & ids,ide, jds,jde, kds,kde, & @@ -91,7 +92,9 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & a_u_bep,a_v_bep,a_t_bep,a_q_bep, & !O multi-layer urban a_e_bep,b_u_bep,b_v_bep, & !O multi-layer urban b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban - dl_u_bep,sf_bep,vl_bep,sfcheadrt,INFXSRT, soldrain ) !O multi-layer urban + dl_u_bep,sf_bep,vl_bep,sfcheadrt,INFXSRT, soldrain & !O multi-layer urban + ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas & !fasdas + ) !O multi-layer urban !---------------------------------------------------------------- IMPLICIT NONE @@ -324,6 +327,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ZNT REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: NOAHRES + INTEGER, INTENT(IN) :: OPT_THCND ! Noah UA changes LOGICAL, INTENT(IN) :: UA_PHYS @@ -629,8 +633,24 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL :: APELM,APES,SFCTH2,PSFC real, intent(in) :: xice_threshold character(len=80) :: message_text - - +! +! FASDAS +! + REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL, & + INTENT(INOUT) :: SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM + INTEGER, INTENT(IN ) :: fasdas +! local vars + REAL :: XSDA_HFX, XSDA_QFX, XQNORM + REAL :: HFX_PHY, QFX_PHY + REAL :: DZQ + REAL :: HCPCT_FASDAS + + HFX_PHY = 0.0 ! initialize + QFX_PHY = 0.0 + XQNORM = 0.0 +! +! END FASDAS +! FLX4 = 0.0 !BSINGH - Initialized to 0.0 FVB = 0.0 !BSINGH - Initialized to 0.0 FBUR = 0.0 !BSINGH - Initialized to 0.0 @@ -772,6 +792,7 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & LH_RURAL(I,J)=LH(I,J) EMISS_RURAL(I,J)=EMISS(I,J) GRDFLX_RURAL(I,J)=GRDFLX(I,J) + ELSE ! Land or sea-ice case @@ -803,7 +824,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & DQSDT2=Q2SATI*6174./(SFCTSNO**2) ENDIF ! for snow cover fraction at 0 C, ground temp will not change, so DQSDT2 effectively zero - IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0.)DQSDT2=DQSDT2*(1.-SNOWC(I,J)) +! V3.8 add condition for SWDOWN to restrict condition to positive forcing (JD) + IF(T1 .GT. 273. .AND. SNOWC(I,J) .GT. 0. .AND. SWDOWN(I,J) .GT. 10.)DQSDT2=DQSDT2*(1.-SNOWC(I,J)) ENDIF ! Land-ice or land points use the usual deep-soil temperature. @@ -855,8 +877,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ! the "NATURAL" category in the VEGPARM.TBL IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN VEGTYP = NATURAL SHDFAC = SHDTBL(NATURAL) ALBEDOK =0.2 ! 0.2 @@ -876,8 +898,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDIF ENDIF ELSE - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN VEGTYP = ISURBAN ENDIF ENDIF @@ -893,8 +915,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & if (tloc.lt.0) tloc=tloc+24 if (tloc==0) tloc=24 CALL cal_mon_day(julian,julyr,jmonth,jday) - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN AOASIS = oasis ! urban oasis effect IF (IRIOPTION ==1) THEN IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm @@ -962,7 +984,21 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ELSEIF (ICE == 0) THEN ! Non-glacial land - +! +! FASDAS +! + IF( fasdas == 1 ) THEN + + DZQ = DZ8W(I,1,J) + XSDA_HFX= SDA_HFX(I,J)*RHO(I,1,J)*CPM(I,J)*DZQ ! W/m^2 + ! TWG2015 Bugfix remove factor of 1000.0 for correct units + XSDA_QFX= SDA_QFX(I,J)*RHO(I,1,J)*DZQ ! Kg/m2/s of water + XQNORM = QNORM(I,J) + + ENDIF +! +! END FASDAS +! CALL SFLX (I,J,FFROZP, ISURBAN, DT,ZLVL,NSOIL,SLDPTH, & !C LOCAL, & !L LUTYPE, SLTYPE, & !CL @@ -986,9 +1022,11 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & RIBB, & SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & sfcheadrt(i,j), & !I - INFXSRT(i,j),ETPND1,AOASIS & !O + INFXSRT(i,j),ETPND1,OPT_THCND,AOASIS & !O + ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas ) + #ifdef WRF_HYDRO soldrain(i,j) = RUNOFF2*DT*1000.0 #endif @@ -1065,6 +1103,22 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & EMISS_RURAL(I,J) = EMISSI ! Noah: activate time-varying roughness length (V3.3 Feb 2011) ZNT(I,J)=Z0K +! +! FASDAS +! +! Update Skin Temperature + IF( fasdas == 1 ) THEN + XSDA_QFX= XSDA_QFX*ELWV*XQNORM + + !TWG2015 Bugfix to multiply Heat Capacity by Soil Depth for correct + !units + + T1 = T1 + (XSDA_HFX-XSDA_QFX)*DT/(HCPCT_FASDAS*DZS(1)) + + END IF +! +! END FASDAS +! TSK(I,J)=T1 TSK_RURAL(I,J)=T1 HFX(I,J)=SHEAT @@ -1136,8 +1190,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & ! Input variables lsm --> urban - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL ) THEN ! Call urban @@ -1571,8 +1625,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK, & G_URB2D(I,J) = 0. RN_URB2D(I,J) = 0. endif -! IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == 31 .or. & -! IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN +! IF( IVGTYP(I,J) == 1 .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & +! IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN ! print*,'ivgtyp, qfx, hfx',ivgtyp(i,j),hfx_rural(i,j),qfx_rural(i,j) ! print*,'ivgtyp,hfx,hfx_urb,hfx_rural',hfx(i,j),hfx_urb(i,j),hfx_rural(i,j) ! print*,'lh,lh_rural',lh(i,j),lh_rural(i,j) @@ -1680,7 +1734,7 @@ SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & DO i = its,itf IF ( ISLTYP( i,j ) .LT. 1 ) THEN errflag = 1 - WRITE(err_message,*)"module_sf_noahlsm.F: lsminit: out of range ISLTYP ",i,j,ISLTYP( i,j ) + WRITE(err_message,*)"module_sf_noahdrv.F: lsminit: out of range ISLTYP ",i,j,ISLTYP( i,j ) CALL wrf_message(err_message) ENDIF IF(.not.RDMAXALB) THEN @@ -1689,8 +1743,13 @@ SUBROUTINE LSMINIT(VEGFRA,SNOW,SNOWC,SNOWH,CANWAT,SMSTAV, & ENDDO ENDDO IF ( errflag .EQ. 1 ) THEN - CALL wrf_error_fatal( "module_sf_noahlsm.F: lsminit: out of range value "// & +#if ( HWRF == 1 ) + CALL wrf_message( "WARNING: message only; was fatal. module_sf_noahdrv.F: lsminit: out of range value "// & + "of ISLTYP. Is this field in the input?" ) +#else + CALL wrf_error_fatal( "module_sf_noahdrv.F: lsminit: out of range value "// & "of ISLTYP. Is this field in the input?" ) +#endif ENDIF ! initialize soil liquid water content SH2O @@ -1787,7 +1846,10 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) INTEGER , PARAMETER :: OPEN_OK = 0 character*128 :: mess , message + character*256 :: a_string logical, external :: wrf_dm_on_monitor + integer , parameter :: loop_max = 10 + integer :: loop_count !-----SPECIFY VEGETATION RELATED CHARACTERISTICS : @@ -1826,8 +1888,9 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) LUMATCH=0 + loop_count = 0 + READ (19,FMT='(A)',END=2002) a_string FIND_LUTYPE : DO WHILE (LUMATCH == 0) - READ (19,*,END=2002) READ (19,*,END=2002)LUTYPE READ (19,*)LUCATS,IINDEX @@ -1836,10 +1899,16 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) CALL wrf_message( mess ) LUMATCH=1 ELSE + loop_count = loop_count+1 call wrf_message ( "Skipping over LUTYPE = " // TRIM ( LUTYPE ) ) - DO LC = 1, LUCATS+14 - read(19,*) - ENDDO + FIND_VEGETATION_PARAMETER_FLAG : DO + READ (19,FMT='(A)', END=2002) a_string + IF ( a_string(1:21) .EQ. 'Vegetation Parameters' ) THEN + EXIT FIND_VEGETATION_PARAMETER_FLAG + ELSE IF ( loop_count .GE. loop_max ) THEN + CALL wrf_error_fatal ( 'Too many loops in VEGPARM.TBL') + ENDIF + ENDDO FIND_VEGETATION_PARAMETER_FLAG ENDIF ENDDO FIND_LUTYPE ! prevent possible array overwrite, Bill Bovermann, IBM, May 6, 2008 @@ -1886,6 +1955,18 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) READ (19,*)BARE READ (19,*) READ (19,*)NATURAL + READ (19,*) + READ (19,*) + READ (19,FMT='(A)') a_string + IF ( a_string(1:21) .EQ. 'Vegetation Parameters' ) THEN + CALL wrf_message ("Expected low and high density residential, and high density industrial information in VEGPARM.TBL") + CALL wrf_error_fatal ("This could be caused by using an older VEGPARM.TBL file with a newer WRF source code.") + ENDIF + READ (19,*)LOW_DENSITY_RESIDENTIAL + READ (19,*) + READ (19,*)HIGH_DENSITY_RESIDENTIAL + READ (19,*) + READ (19,*)HIGH_INTENSITY_INDUSTRIAL ENDIF ! 2002 CONTINUE @@ -1923,6 +2004,9 @@ SUBROUTINE SOIL_VEG_GEN_PARM( MMINLU, MMINSL) CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 ) CALL wrf_dm_bcast_integer ( BARE , 1 ) CALL wrf_dm_bcast_integer ( NATURAL , 1 ) + CALL wrf_dm_bcast_integer ( LOW_DENSITY_RESIDENTIAL , 1 ) + CALL wrf_dm_bcast_integer ( HIGH_DENSITY_RESIDENTIAL , 1 ) + CALL wrf_dm_bcast_integer ( HIGH_INTENSITY_INDUSTRIAL , 1 ) ! !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL @@ -2097,7 +2181,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & XICE_THRESHOLD, & RDLAI2D,USEMONALB, & RIB, & !? - NOAHRES, & + NOAHRES,OPT_THCND, & NLCAT,landusef,landusef2, & ! danli mosaic sf_surface_mosaic,mosaic_cat,mosaic_cat_index, & ! danli mosaic TSK_mosaic,QSFC_mosaic, & ! danli mosaic @@ -2161,7 +2245,10 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & a_u_bep,a_v_bep,a_t_bep,a_q_bep, & !O multi-layer urban a_e_bep,b_u_bep,b_v_bep, & !O multi-layer urban b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban - dl_u_bep,sf_bep,vl_bep,sfcheadrt,INFXSRT, soldrain ) !O multi-layer urban + dl_u_bep,sf_bep,vl_bep & !O multi-layer urban + ,sfcheadrt,INFXSRT, soldrain & !hydro + ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas & !fasdas + ) !---------------------------------------------------------------- IMPLICIT NONE @@ -2395,6 +2482,7 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ZNT REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: NOAHRES + INTEGER, INTENT(IN) :: OPT_THCND ! Noah UA changes LOGICAL, INTENT(IN) :: UA_PHYS @@ -2737,7 +2825,23 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & REAL :: APELM,APES,SFCTH2,PSFC real, intent(in) :: xice_threshold character(len=80) :: message_text - +! +! FASDAS: it doesn't work for mosaic, but we need the variables to call sflx +! + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM + INTEGER, INTENT(IN ) :: fasdas + REAL :: XSDA_HFX, XSDA_QFX, XQNORM + REAL :: HFX_PHY, QFX_PHY + REAL :: DZQ + REAL :: HCPCT_FASDAS + + HFX_PHY = 0.0 ! initialize + QFX_PHY = 0.0 + XQNORM = 0.0 +! +! END FASDAS +! ! MEK MAY 2007 FDTLIW=DT/ROWLIW ! MEK JUL2007 @@ -3038,8 +3142,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ! IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN - ! IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - ! IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + ! IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + ! IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN ! VEGTYP = NATURAL ! SHDFAC = SHDTBL(NATURAL) ! ALBEDOK =0.2 ! 0.2 @@ -3059,8 +3163,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ! ENDIF ! ENDIF ! ELSE - ! IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - ! IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + ! IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + ! IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN ! VEGTYP = ISURBAN ! ENDIF ! ENDIF @@ -3069,8 +3173,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & If ( SF_URBAN_PHYSICS == 0 ) THEN ! ONLY NOAH - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN Noah_call = .TRUE. VEGTYP = ISURBAN ENDIF @@ -3079,8 +3183,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & IF(SF_URBAN_PHYSICS == 1) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN Noah_call = .TRUE. VEGTYP = NATURAL @@ -3106,8 +3210,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & if (tloc==0) tloc=24 CALL cal_mon_day(julian,julyr,jmonth,jday) IF(SF_URBAN_PHYSICS == 1) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN AOASIS = oasis ! urban oasis effect IF (IRIOPTION ==1) THEN IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm @@ -3202,7 +3306,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & RIBB, & SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & sfcheadrt(i,j), & !I - INFXSRT(i,j),ETPND1,AOASIS & !O + INFXSRT(i,j),ETPND1,OPT_THCND,AOASIS & !O + ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas vars ) #ifdef WRF_HYDRO @@ -3350,20 +3455,20 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & !-------------------------------------- ! Input variables lsm --> urban - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL ) THEN ! UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial) ! this need to be changed in the mosaic danli IF(IVGTYP(I,J)==ISURBAN) UTYPE_URB=2 - IF(IVGTYP(I,J)==31) UTYPE_URB=3 - IF(IVGTYP(I,J)==32) UTYPE_URB=2 - IF(IVGTYP(I,J)==33) UTYPE_URB=1 + IF(IVGTYP(I,J)==LOW_DENSITY_RESIDENTIAL) UTYPE_URB=1 + IF(IVGTYP(I,J)==HIGH_DENSITY_RESIDENTIAL) UTYPE_URB=2 + IF(IVGTYP(I,J)==HIGH_INTENSITY_INDUSTRIAL) UTYPE_URB=3 - IF(UTYPE_URB==3) FRC_URB2D(I,J)=0.5 + IF(UTYPE_URB==1) FRC_URB2D(I,J)=0.5 IF(UTYPE_URB==2) FRC_URB2D(I,J)=0.9 - IF(UTYPE_URB==1) FRC_URB2D(I,J)=0.95 + IF(UTYPE_URB==3) FRC_URB2D(I,J)=0.95 TA_URB = SFCTMP ! [K] QA_URB = Q2K ! [kg/kg] @@ -3947,8 +4052,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ! the "NATURAL" category in the VEGPARM.TBL IF(SF_URBAN_PHYSICS == 1.OR. SF_URBAN_PHYSICS==2.OR.SF_URBAN_PHYSICS==3 ) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN VEGTYP = NATURAL SHDFAC = SHDTBL(NATURAL) ALBEDOK =0.2 ! 0.2 @@ -3968,8 +4073,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & ENDIF ENDIF ELSE - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN VEGTYP = ISURBAN ENDIF ENDIF @@ -3986,8 +4091,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & if (tloc==0) tloc=24 CALL cal_mon_day(julian,julyr,jmonth,jday) IF(SF_URBAN_PHYSICS == 1) THEN - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN AOASIS = oasis ! urban oasis effect IF (IRIOPTION ==1) THEN IF (tloc==21 .or. tloc==22) THEN !irrigation on vegetaion in urban area, MAY-SEP, 9-10pm @@ -4077,7 +4182,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & RIBB, & SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & sfcheadrt(i,j), & !I - INFXSRT(i,j),ETPND1,AOASIS & !O + INFXSRT(i,j),ETPND1,OPT_THCND,AOASIS & !O + ,XSDA_QFX, HFX_PHY, QFX_PHY, XQNORM, fasdas, HCPCT_FASDAS & ! fasdas vars ) #ifdef WRF_HYDRO @@ -4222,8 +4328,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK, & !-------------------------------------- ! Input variables lsm --> urban - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN + IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN ! Call urban ! diff --git a/wrfv2_fire/phys/module_sf_noahlsm.F b/wrfv2_fire/phys/module_sf_noahlsm.F index de487051..38bf19ed 100644 --- a/wrfv2_fire/phys/module_sf_noahlsm.F +++ b/wrfv2_fire/phys/module_sf_noahlsm.F @@ -1,6 +1,17 @@ MODULE module_sf_noahlsm USE module_model_constants, only : CP, R_D, XLF, XLV, RHOWATER, STBOLT, KARMAN +!ckay=KIRAN ALAPATY @ US EPA -- November 01, 2015 +! +! Tim Glotfelty@CNSU; AJ Deng@PSU +!modified for use with FASDAS +!Flux Adjusting Surface Data Assimilation System to assimilate +!surface layer and soil layers temperature and moisture using +! surfance reanalsys +!Reference: Alapaty et al., 2008: Development of the flux-adjusting surface +! data assimilation system for mesoscale models. JAMC, 47, 2331-2350 +! + ! REAL, PARAMETER :: CP = 1004.5 REAL, PARAMETER :: RD = 287.04, SIGMA = 5.67E-8, & CPH2O = 4.218E+3,CPICE = 2.106E+3, & @@ -10,6 +21,7 @@ MODULE module_sf_noahlsm ! VEGETATION PARAMETERS INTEGER :: LUCATS , BARE INTEGER :: NATURAL + INTEGER :: LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL integer, PARAMETER :: NLUS=50 CHARACTER(LEN=256) LUTYPE INTEGER, DIMENSION(1:NLUS) :: NROTBL @@ -74,7 +86,10 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C RIBB, & SMCWLT,SMCDRY,SMCREF,SMCMAX,NROOT, & SFHEAD1RT, & !I - INFXS1RT,ETPND1,AOASIS ) !P + INFXS1RT,ETPND1,OPT_THCND,AOASIS & !P + ,XSDA_QFX,HFX_PHY,QFX_PHY,XQNORM & !fasdas + ,fasdas,HCPCT_FASDAS ) !fasdas + ! ---------------------------------------------------------------------- ! SUBROUTINE SFLX - UNIFIED NOAHLSM VERSION 1.0 JULY 2007 ! ---------------------------------------------------------------------- @@ -118,6 +133,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! roughness length) will be defined by three tables ! LLANDUSE (=USGS, using USGS landuse classification) ! LSOIL (=STAS, using FAO/STATSGO soil texture classification) +! OPT_THCND option for how to treat thermal conductivity ! ---------------------------------------------------------------------- ! 3. FORCING DATA (F): ! ---------------------------------------------------------------------- @@ -292,6 +308,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! ---------------------------------------------------------------------- LOGICAL, INTENT(IN) :: RDLAI2D LOGICAL, INTENT(IN) :: USEMONALB + INTEGER, INTENT(IN) :: OPT_THCND REAL, INTENT(INOUT):: SFHEAD1RT,INFXS1RT, ETPND1 @@ -350,7 +367,16 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C PARAMETER (LVH2O = 2.501E+6) PARAMETER (LSUBS = 2.83E+6) PARAMETER (R = 287.04) - +! +! FASDAS +! + INTEGER, INTENT(IN ) :: fasdas + REAL, INTENT(INOUT) :: XSDA_QFX, XQNORM + REAL, INTENT(INOUT) :: HFX_PHY, QFX_PHY + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! ! ---------------------------------------------------------------------- ! INITIALIZATION ! ---------------------------------------------------------------------- @@ -577,7 +603,7 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ! OVERLYING GREEN CANOPY, ADAPTED FROM SECTION 2.1.2 OF ! PETERS-LIDARD ET AL. (1997, JGR, VOL 102(D4)) ! ---------------------------------------------------------------------- - CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1)) + CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1),BEXP, PSISAT, SOILTYP, OPT_THCND) !urban IF ( VEGTYP == ISURBAN ) DF1=3.24 @@ -734,7 +760,8 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C RUNOFF3,EDIR,EC,ET,ETT,NROOT,RTDIS, & QUARTZ,FXEXP,CSOIL, & BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN, & - SFHEAD1RT,INFXS1RT,ETPND1 ) + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,XSDA_QFX,QFX_PHY,XQNORM,fasdas,HCPCT_FASDAS ) !fasdas ETA_KINEMATIC = ETA ELSE CALL SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & @@ -751,7 +778,8 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C ISURBAN, & VEGTYP, & ETPN,FLX4,UA_PHYS, & - SFHEAD1RT,INFXS1RT,ETPND1) + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,QFX_PHY,fasdas,HCPCT_FASDAS ) !fasdas ETA_KINEMATIC = ESNOW + ETNS - 1000.0*DEW END IF @@ -766,7 +794,15 @@ SUBROUTINE SFLX (IILOC,JJLOC,FFROZP,ISURBAN,DT,ZLVL,NSOIL,SLDPTH, & !C SHEAT = - (CH * CP * SFCPRS)/ (R * T2V) * ( TH2- T1 ) IF(UA_PHYS) SHEAT = SHEAT + FLX4 - +! +! FASDAS +! + IF ( fasdas == 1 ) THEN + HFX_PHY = SHEAT + ENDIF +! +! END FASDAS +! ! ---------------------------------------------------------------------- ! CONVERT EVAP TERMS FROM KINEMATIC (KG M-2 S-1) TO ENERGY UNITS (W M-2) ! ---------------------------------------------------------------------- @@ -1538,8 +1574,9 @@ END SUBROUTINE FRH2O ! ---------------------------------------------------------------------- SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & - TBOT,ZBOT,PSISAT,SH2O,DT,BEXP, & - F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN) + TBOT,ZBOT,PSISAT,SH2O,DT,BEXP,SOILTYP,OPT_THCND, & + F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN & + ,HCPCT_FASDAS ) !fasdas ! ---------------------------------------------------------------------- ! SUBROUTINE HRT @@ -1550,7 +1587,8 @@ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & ! ---------------------------------------------------------------------- IMPLICIT NONE LOGICAL :: ITAVG - INTEGER, INTENT(IN) :: NSOIL, VEGTYP + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NSOIL, VEGTYP, SOILTYP INTEGER, INTENT(IN) :: ISURBAN INTEGER :: I, K @@ -1566,6 +1604,13 @@ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & REAL, PARAMETER :: T0 = 273.15, CAIR = 1004.0, CICE = 2.106E6,& CH2O = 4.2E6 +! +! FASDAS +! + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! !urban IF( VEGTYP == ISURBAN ) then @@ -1586,7 +1631,13 @@ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & HCPCT = SH2O (1)* CH2O + (1.0- SMCMAX)* CSOIL_LOC + (SMCMAX - SMC (1))& * CAIR & + ( SMC (1) - SH2O (1) )* CICE - +! +! FASDAS +! + HCPCT_FASDAS = HCPCT +! +! END FASDAS +! ! ---------------------------------------------------------------------- ! CALC THE MATRIX COEFFICIENTS AI, BI, AND CI FOR THE TOP LAYER ! ---------------------------------------------------------------------- @@ -1687,7 +1738,7 @@ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & ! ---------------------------------------------------------------------- ! CALC THE VERTICAL SOIL TEMP GRADIENT THRU THIS LAYER ! ---------------------------------------------------------------------- - CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K)) + CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K),BEXP, PSISAT, SOILTYP, OPT_THCND) !urban IF ( VEGTYP == ISURBAN ) DF1N = 3.24 @@ -1719,7 +1770,7 @@ SUBROUTINE HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1, & ! ---------------------------------------------------------------------- ! CALC THE VERTICAL SOIL TEMP GRADIENT THRU BOTTOM LAYER. ! ---------------------------------------------------------------------- - CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K)) + CALL TDFCND (DF1N,SMC (K),QUARTZ,SMCMAX,SH2O (K),BEXP, PSISAT, SOILTYP, OPT_THCND) !urban @@ -1848,8 +1899,8 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & RUNOFF3,EDIR,EC,ET,ETT,NROOT,RTDIS, & QUARTZ,FXEXP,CSOIL, & BETA,DRIP,DEW,FLX1,FLX3,VEGTYP,ISURBAN, & -!DJG NDHMS/WRF-Hydro edit... - SFHEAD1RT,INFXS1RT,ETPND1) + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,XSDA_QFX,QFX_PHY,XQNORM,fasdas,HCPCT_FASDAS ) !fasdas ! ---------------------------------------------------------------------- ! SUBROUTINE NOPAC @@ -1860,7 +1911,8 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ! ---------------------------------------------------------------------- IMPLICIT NONE - INTEGER, INTENT(IN) :: NROOT,NSOIL,VEGTYP + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NROOT,NSOIL,VEGTYP,SOILTYP INTEGER, INTENT(IN) :: ISURBAN INTEGER :: K @@ -1881,7 +1933,17 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & REAL, DIMENSION(1:NSOIL) :: ET1 REAL :: EC1,EDIR1,ETT1,DF1,ETA1,ETP1,PRCP1,YY, & YYNUM,ZZ1 - +! +! FASDAS +! + REAL :: XSDA_QFX, QFX_PHY, XQNORM + INTEGER :: fasdas + REAL , DIMENSION(1:NSOIL) :: EFT(NSOIL), wetty(1:NSOIL) + REAL :: EFDIR, EFC, EALL_now + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! ! ---------------------------------------------------------------------- ! EXECUTABLE CODE BEGINS HERE: ! CONVERT ETP Fnd PRCP FROM KG M-2 S-1 TO M S-1 AND INITIALIZE DEW. @@ -1892,6 +1954,13 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ! ---------------------------------------------------------------------- ! INITIALIZE EVAP TERMS. ! ---------------------------------------------------------------------- +! +! FASDAS +! + QFX_PHY = 0.0 +! +! END FASDAS +! EDIR = 0. EDIR1 = 0. EC1 = 0. @@ -1899,6 +1968,13 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & DO K = 1,NSOIL ET(K) = 0. ET1(K) = 0. +! +! FASDAS +! + wetty(K) = 1.0 +! +! END FASDAS +! END DO ETT = 0. ETT1 = 0. @@ -1915,6 +1991,45 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & SMCDRY,CFACTR, & EDIR1,EC1,ET1,ETT1,SFCTMP,Q2,NROOT,RTDIS,FXEXP, & SFHEAD1RT,ETPND1 ) +! +! FASDAS +! + IF( fasdas == 1 ) THEN + DO K=1,NSOIL + QFX_PHY = QFX_PHY + ET1(K) ! m/s +! dont add moisture fluxes if soil moisture is = or > smcref + IF(SMC(K).GE.SMCREF.and.XSDA_QFX.gt.0.0) wetty(K)=0.0 + END DO + QFX_PHY = EDIR1+EC1+QFX_PHY ! m/s + EALL_now = QFX_PHY ! m/s + QFX_PHY = QFX_PHY*1000.0 ! Kg/m2/s + + if(EALL_now.ne.0.0) then + EFDIR = (EDIR1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFDIR = EFDIR * wetty(1) + !TWG2015 Bugfix Flip Sign to conform to Net upward Flux + EDIR1 = EDIR1 + EFDIR ! new value + + EFC = (EC1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + !TWG2015 Bugfix Flip Sign to conform to Net upward Flux + EC1 = EC1 + EFC ! new value + + + DO K=1,NSOIL + EFT(K) = (ET1(K)/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFT(K) = EFT(K) * wetty(K) + !TWG2015 Bugfix Flip Sign to conform to Net upward Flux + ET1(K) = ET1(K) + EFT(K) ! new value + END DO + + + END IF ! for non-zero eall_now + ELSE + QFX_PHY = 0.0 + ENDIF +! +! END FASDAS +! CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & SH2O,SLOPE,KDT,FRZFACT, & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & @@ -1941,6 +2056,43 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ! ---------------------------------------------------------------------- PRCP1 = PRCP1+ DEW +! +! FASDAS +! + IF( fasdas == 1 ) THEN + DO K=1,NSOIL + QFX_PHY = QFX_PHY + ET1(K) ! m/s +! dont add moisture fluxes if soil moisture is = or > smcref + IF(SMC(K).GE.SMCREF.and.XSDA_QFX.gt.0.0) wetty(K)=0.0 + END DO + QFX_PHY = EDIR1+EC1+QFX_PHY ! m/s + EALL_now = QFX_PHY ! m/s + QFX_PHY = QFX_PHY*1000.0 ! Kg/m2/s + + IF(EALL_now.ne.0.0) then + EFDIR = (EDIR1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFDIR = EFDIR * wetty(1) + !TWG2015 Bugfix Flip Sign to conform to Net Upward Flux + EDIR1 = EDIR1 + EFDIR ! new value + + EFC = (EC1/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + !TWG2015 Bugfix Flip Sign to conform to Net Upward Flux + EC1 = EC1+ EFC ! new value + + DO K=1,NSOIL + EFT(K) = (ET1(K)/EALL_now)*XSDA_QFX*1.0E-03*XQNORM + EFT(K) = EFT(K) * wetty(K) + !TWG2015 Bugfix Flip Sign to conform to Net Upward Flux + ET1(K) = ET1(K) + EFT(K) ! new value + END DO + + END IF ! for non-zero eall_now + ELSE + QFX_PHY = 0.0 + ENDIF +! +! END FASDAS +! CALL SMFLX (SMC,NSOIL,CMC,DT,PRCP1,ZSOIL, & SH2O,SLOPE,KDT,FRZFACT, & SMCMAX,BEXP,SMCWLT,DKSAT,DWSAT, & @@ -1985,7 +2137,7 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & ! CALL SHFLX TO COMPUTE/UPDATE SOIL HEAT FLUX AND SOIL TEMPS. ! ---------------------------------------------------------------------- - CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1)) + CALL TDFCND (DF1,SMC (1),QUARTZ,SMCMAX,SH2O (1),BEXP, PSISAT, SOILTYP, OPT_THCND) !urban IF ( VEGTYP == ISURBAN ) DF1=3.24 @@ -2011,7 +2163,8 @@ SUBROUTINE NOPAC (ETP,ETA,PRCP,SMC,SMCMAX,SMCWLT, & !urban CALL SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1, & - QUARTZ,CSOIL,VEGTYP,ISURBAN) + QUARTZ,CSOIL,VEGTYP,ISURBAN,SOILTYP,OPT_THCND & + ,HCPCT_FASDAS ) !fasdas ! ---------------------------------------------------------------------- ! SET FLX1 AND FLX3 (SNOPACK PHASE CHANGE HEAT FLUXES) TO ZERO SINCE @@ -2432,7 +2585,8 @@ END SUBROUTINE ROSR12 SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1, & - QUARTZ,CSOIL,VEGTYP,ISURBAN) + QUARTZ,CSOIL,VEGTYP,ISURBAN,SOILTYP,OPT_THCND & + ,HCPCT_FASDAS ) ! fasdas ! ---------------------------------------------------------------------- ! SUBROUTINE SHFLX @@ -2443,7 +2597,8 @@ SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & ! ---------------------------------------------------------------------- IMPLICIT NONE - INTEGER, INTENT(IN) :: NSOIL, VEGTYP, ISURBAN + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NSOIL, VEGTYP, ISURBAN, SOILTYP INTEGER :: I REAL, INTENT(IN) :: BEXP,CSOIL,DF1,DT,F1,PSISAT,QUARTZ, & @@ -2456,15 +2611,23 @@ SUBROUTINE SHFLX (SSOIL,STC,SMC,SMCMAX,NSOIL,T1,DT,YY,ZZ1,ZSOIL, & REAL, DIMENSION(1:NSOIL) :: AI, BI, CI, STCF,RHSTS REAL, PARAMETER :: T0 = 273.15 +! +! FASDAS +! + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! ! ---------------------------------------------------------------------- ! HRT ROUTINE CALCS THE RIGHT HAND SIDE OF THE SOIL TEMP DIF EQN ! ---------------------------------------------------------------------- ! Land case - CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, & - ZBOT,PSISAT,SH2O,DT, & - BEXP,F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN) + CALL HRT (RHSTS,STC,SMC,SMCMAX,NSOIL,ZSOIL,YY,ZZ1,TBOT, & + ZBOT,PSISAT,SH2O,DT,BEXP,SOILTYP,OPT_THCND, & + F1,DF1,QUARTZ,CSOIL,AI,BI,CI,VEGTYP,ISURBAN & + ,HCPCT_FASDAS ) !fasdas CALL HSTEP (STCF,STC,RHSTS,DT,NSOIL,AI,BI,CI) @@ -2839,8 +3002,8 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ISURBAN, & VEGTYP, & ETPN,FLX4,UA_PHYS, & - SFHEAD1RT,INFXS1RT,ETPND1) - + SFHEAD1RT,INFXS1RT,ETPND1,SOILTYP,OPT_THCND & + ,QFX_PHY,fasdas,HCPCT_FASDAS ) !fasdas ! ---------------------------------------------------------------------- ! SUBROUTINE SNOPAC ! ---------------------------------------------------------------------- @@ -2850,7 +3013,8 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & ! ---------------------------------------------------------------------- IMPLICIT NONE - INTEGER, INTENT(IN) :: NROOT, NSOIL,VEGTYP + INTEGER, INTENT(IN) :: OPT_THCND + INTEGER, INTENT(IN) :: NROOT, NSOIL,VEGTYP,SOILTYP INTEGER, INTENT(IN) :: ISURBAN INTEGER :: K ! @@ -2896,6 +3060,15 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & REAL, INTENT(IN) :: ETPN ! UA: adjusted pot. evap. [mm/s] REAL :: ETP1N ! UA: adjusted pot. evap. [m/s] +! +! FASDAS +! + REAL :: QFX_PHY + INTEGER :: fasdas + REAL, INTENT( OUT) :: HCPCT_FASDAS +! +! END FASDAS +! ! ---------------------------------------------------------------------- ! EXECUTABLE CODE BEGINS HERE: ! ---------------------------------------------------------------------- @@ -2980,6 +3153,18 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & DO K = 1,NSOIL ET (K) = ET1 (K)*1000. END DO +! +! FASDAS +! + if( fasdas == 1 ) then + QFX_PHY = EDIR + EC + DO K=1,NSOIL + QFX_PHY = QFX_PHY + ET(K) + END DO + endif +! +! END FASDAS +! ETT = ETT1*1000. ETNS = ETNS1*1000. @@ -3185,7 +3370,8 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT, & T11 = T1 CALL SHFLX (SSOIL1,STC,SMC,SMCMAX,NSOIL,T11,DT,YY,ZZ1,ZSOIL, & TBOT,ZBOT,SMCWLT,PSISAT,SH2O,BEXP,F1,DF1, & - QUARTZ,CSOIL,VEGTYP,ISURBAN) + QUARTZ,CSOIL,VEGTYP,ISURBAN,SOILTYP,OPT_THCND & + ,HCPCT_FASDAS ) !fasdas ! ---------------------------------------------------------------------- ! SNOW DEPTH AND DENSITY ADJUSTMENT BASED ON SNOW COMPACTION. YY IS @@ -3914,7 +4100,7 @@ END SUBROUTINE TBND ! ---------------------------------------------------------------------- - SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) + SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O, BEXP, PSISAT, SOILTYP, OPT_THCND) ! ---------------------------------------------------------------------- ! SUBROUTINE TDFCND @@ -3926,11 +4112,12 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) ! June 2001 CHANGES: FROZEN SOIL CONDITION. ! ---------------------------------------------------------------------- IMPLICIT NONE - REAL, INTENT(IN) :: QZ, SMC, SMCMAX, SH2O + INTEGER, INTENT(IN) :: SOILTYP, OPT_THCND + REAL, INTENT(IN) :: QZ, SMC, SMCMAX, SH2O, BEXP, PSISAT REAL, INTENT(OUT) :: DF REAL :: AKE, GAMMD, THKDRY, THKICE, THKO, & THKQTZ,THKSAT,THKS,THKW,SATRATIO,XU, & - XUNFROZ,AKEI,AKEL + XUNFROZ,AKEI,AKEL,PSIF,PF ! ---------------------------------------------------------------------- ! WE NOW GET QUARTZ AS AN INPUT ARGUMENT (SET IN ROUTINE REDPRM): @@ -3961,6 +4148,9 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) ! AND TEMPERATURES. JOURNAL OF THE ATMOSPHERIC SCIENCES, ! VOL. 55, PP. 1209-1224. ! ---------------------------------------------------------------------- + +IF ( OPT_THCND == 1 .OR. ( OPT_THCND == 2 .AND. (SOILTYP /= 4 .AND. SOILTYP /= 3)) )THEN + ! NEEDS PARAMETERS ! POROSITY(SOIL TYPE): ! POROS = SMCMAX @@ -4016,6 +4206,22 @@ SUBROUTINE TDFCND ( DF, SMC, QZ, SMCMAX, SH2O) DF = AKE * (THKSAT - THKDRY) + THKDRY + + ELSE + +! use the Mccumber and Pielke approach for silt loam (4), sandy loam (3) + + PSIF = PSISAT*100.*(SMCMAX/(SMC))**BEXP +!--- PSIF should be in [CM] to compute PF + PF=log10(abs(PSIF)) +!--- HK is for McCumber thermal conductivity + IF(PF.LE.5.1) THEN + DF=420.*EXP(-(PF+2.7)) + ELSE + DF=.1744 + END IF + + ENDIF ! for OPT_THCND OPTIONS ! ---------------------------------------------------------------------- END SUBROUTINE TDFCND ! ---------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_sf_noahlsm_glacial_only.F b/wrfv2_fire/phys/module_sf_noahlsm_glacial_only.F index 4a7b1a01..15faaf20 100644 --- a/wrfv2_fire/phys/module_sf_noahlsm_glacial_only.F +++ b/wrfv2_fire/phys/module_sf_noahlsm_glacial_only.F @@ -359,7 +359,8 @@ SUBROUTINE SFLX_GLACIAL (IILOC,JJLOC,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH, & & SFCPRS,RCH,RR,SNEQV,SNDENS,SNOWH,ZSOIL,TBOT, & & SNOMLT,DEW,FLX1,FLX2,FLX3,ESNOW,EMISSI,RIBB) - ETA_KINEMATIC = ESNOW +! ETA_KINEMATIC = ESNOW + ETA_KINEMATIC = ETP ! ---------------------------------------------------------------------- ! Effective mixing ratio at grnd level (skin) diff --git a/wrfv2_fire/phys/module_sf_noahmp_glacier.F b/wrfv2_fire/phys/module_sf_noahmp_glacier.F index c1e852d9..347fef9e 100644 --- a/wrfv2_fire/phys/module_sf_noahmp_glacier.F +++ b/wrfv2_fire/phys/module_sf_noahmp_glacier.F @@ -26,56 +26,6 @@ MODULE NOAHMP_GLACIER_GLOBALS REAL, PARAMETER :: DENICE = 917. !density of ice (kg/m3) ! =====================================options for different schemes================================ -! options for dynamic vegetation: -! 1 -> off (use table LAI; use FVEG = SHDFAC from input) -! 2 -> on (together with OPT_CRS = 1) -! 3 -> off (use table LAI; calculate FVEG) -! 4 -> off (use table LAI; use maximum vegetation fraction) - - INTEGER :: DVEG != 2 ! - -! options for canopy stomatal resistance -! 1-> Ball-Berry; 2->Jarvis - - INTEGER :: OPT_CRS != 1 !(must 1 when DVEG = 2) - -! options for soil moisture factor for stomatal resistance -! 1-> Noah (soil moisture) -! 2-> CLM (matric potential) -! 3-> SSiB (matric potential) - - INTEGER :: OPT_BTR != 1 !(suggested 1) - -! options for runoff and groundwater -! 1 -> TOPMODEL with groundwater (Niu et al. 2007 JGR) ; -! 2 -> TOPMODEL with an equilibrium water table (Niu et al. 2005 JGR) ; -! 3 -> original surface and subsurface runoff (free drainage) -! 4 -> BATS surface and subsurface runoff (free drainage) - - INTEGER :: OPT_RUN != 1 !(suggested 1) - -! options for surface layer drag coeff (CH & CM) -! 1->M-O ; 2->original Noah (Chen97); 3->MYJ consistent; 4->YSU consistent. - - INTEGER :: OPT_SFC != 1 !(1 or 2 or 3 or 4) - -! options for supercooled liquid water (or ice fraction) -! 1-> no iteration (Niu and Yang, 2006 JHM); 2: Koren's iteration - - INTEGER :: OPT_FRZ != 1 !(1 or 2) - -! options for frozen soil permeability -! 1 -> linear effects, more permeable (Niu and Yang, 2006, JHM) -! 2 -> nonlinear effects, less permeable (old) - - INTEGER :: OPT_INF != 1 !(suggested 1) - -! options for radiation transfer -! 1 -> modified two-stream (gap = F(solar angle, 3D structure ...)<1-FVEG) -! 2 -> two-stream applied to grid-cell (gap = 0) -! 3 -> two-stream applied to vegetated fraction (gap=1-FVEG) - - INTEGER :: OPT_RAD != 1 !(suggested 1) ! options for ground snow surface albedo ! 1-> BATS; 2 -> CLASS @@ -98,6 +48,11 @@ MODULE NOAHMP_GLACIER_GLOBALS INTEGER :: OPT_STC != 1 !(suggested 1) +! options for glacier treatment +! 1 -> include phase change of ice; 2 -> ice treatment more like original Noah + + INTEGER :: OPT_GLA != 1 !(suggested 1) + ! adjustable parameters for snow processes REAL, PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) @@ -304,13 +259,18 @@ SUBROUTINE NOAHMP_GLACIER (& CALL WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in QVAP ,QDEW ,FICEOLD,ZSOIL , & !in ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ ,STC , & !inout - DZSNSO ,SH2O ,SICE ,PONDING,ZSNSO , & !inout + DZSNSO ,SH2O ,SICE ,PONDING,ZSNSO ,FSH , & !inout RUNSRF ,RUNSUB ,QSNOW ,PONDING1 ,PONDING2,QSNBOT,FPICE & !out #ifdef WRF_HYDRO , sfcheadrt & #endif ) + IF(OPT_GLA == 2) THEN + EDIR = QVAP - QDEW + FGEV = EDIR * LATHEA + END IF + IF(MAXVAL(SICE) < 0.0001) THEN WRITE(message,*) "GLACIER HAS MELTED AT:",ILOC,JLOC," ARE YOU SURE THIS SHOULD BE A GLACIER POINT?" CALL wrf_debug(10,TRIM(message)) @@ -560,7 +520,7 @@ SUBROUTINE ENERGY_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,QSNOW ,RHOAIR , & !i IF (SNOWH > 0.05 .AND. TG > TFRZ) TG = TFRZ END IF -! Energy released or consumed by snow & frozen soil +! Energy released or consumed by snow & ice CALL PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in DZSNSO , & !in @@ -1081,7 +1041,11 @@ SUBROUTINE GLACIER_FLUX (NSOIL ,NSNOW ,EMG ,ISNOW ,DF ,DZSNSO ,Z END IF CSH = RHOAIR*CPAIR/RAHB - CEV = RHOAIR*CPAIR/GAMMA/(RSURF+RAWB) + IF(SNOWH > 0.0 .OR. OPT_GLA == 1) THEN + CEV = RHOAIR*CPAIR/GAMMA/(RSURF+RAWB) + ELSE + CEV = 0.0 ! don't allow any sublimation of glacier in opt_gla=2 + END IF ! surface fluxes and dtg @@ -1120,9 +1084,13 @@ SUBROUTINE GLACIER_FLUX (NSOIL ,NSNOW ,EMG ,ISNOW ,DF ,DZSNSO ,Z ! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes. SICE = SMC - SH2O - IF(OPT_STC == 1) THEN - IF ((MAXVAL(SICE) > 0.0 .OR. SNOWH > 0.0) .AND. TGB > TFRZ) THEN + IF(OPT_STC == 1 .OR. OPT_STC ==3) THEN + IF ((MAXVAL(SICE) > 0.0 .OR. SNOWH > 0.0) .AND. TGB > TFRZ .AND. OPT_GLA == 1) THEN TGB = TFRZ + T = TDC(TGB) ! MB: recalculate ESTG + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + ESTG = ESATI + QSFC = 0.622*(ESTG*RHSUR)/(SFCPRS-0.378*(ESTG*RHSUR)) IRB = CIR * TGB**4 - EMG*LWDN SHB = CSH * (TGB - SFCTMP) EVB = CEV * (ESTG*RHSUR - EAIR ) !ESTG reevaluate ? @@ -1496,7 +1464,7 @@ SUBROUTINE HRT_GLACIER (NSNOW ,NSOIL ,ISNOW ,ZSNSO , & !in IF (K == ISNOW+1) THEN AI(K) = 0.0 CI(K) = - DF(K) * DDZ(K) / DENOM(K) - IF (OPT_STC == 1) THEN + IF (OPT_STC == 1 .OR. OPT_STC == 3) THEN BI(K) = - CI(K) END IF IF (OPT_STC == 2) THEN @@ -1692,12 +1660,106 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & MLIQ(J) = SNLIQ(J) END DO + DO J = ISNOW+1,0 ! all snow layers; do ice later + IMELT(J) = 0 + HM(J) = 0. + XM(J) = 0. + WICE0(J) = MICE(J) + WLIQ0(J) = MLIQ(J) + WMASS0(J) = MICE(J) + MLIQ(J) + ENDDO + + DO J = ISNOW+1,0 + IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN ! melting + IMELT(J) = 1 + ENDIF + IF (MLIQ(J) > 0. .AND. STC(J) < TFRZ) THEN ! freezing + IMELT(J) = 2 + ENDIF + + ENDDO + +! Calculate the energy surplus and loss for melting and freezing + + DO J = ISNOW+1,0 + IF (IMELT(J) > 0) THEN + HM(J) = (STC(J)-TFRZ)/FACT(J) + STC(J) = TFRZ + ENDIF + + IF (IMELT(J) == 1 .AND. HM(J) < 0.) THEN + HM(J) = 0. + IMELT(J) = 0 + ENDIF + IF (IMELT(J) == 2 .AND. HM(J) > 0.) THEN + HM(J) = 0. + IMELT(J) = 0 + ENDIF + XM(J) = HM(J)*DT/HFUS + ENDDO + +! The rate of melting and freezing for snow without a layer, opt_gla==1 treated below + +IF (OPT_GLA == 2) THEN + + IF (ISNOW == 0 .AND. SNEQV > 0. .AND. STC(1) >= TFRZ) THEN + HM(1) = (STC(1)-TFRZ)/FACT(1) ! available heat + STC(1) = TFRZ ! set T to freezing + XM(1) = HM(1)*DT/HFUS ! total snow melt possible + + TEMP1 = SNEQV + SNEQV = MAX(0.,TEMP1-XM(1)) ! snow remaining + PROPOR = SNEQV/TEMP1 ! fraction melted + SNOWH = MAX(0.,PROPOR * SNOWH) ! new snow height + HEATR(1) = HM(1) - HFUS*(TEMP1-SNEQV)/DT ! excess heat + IF (HEATR(1) > 0.) THEN + XM(1) = HEATR(1)*DT/HFUS + STC(1) = STC(1) + FACT(1)*HEATR(1) ! re-heat ice + ELSE + XM(1) = 0. ! heat used up + HM(1) = 0. + ENDIF + QMELT = MAX(0.,(TEMP1-SNEQV))/DT ! melted snow rate + XMF = HFUS*QMELT ! melted snow energy + PONDING = TEMP1-SNEQV ! melt water + ENDIF + +END IF ! OPT_GLA == 2 + +! The rate of melting and freezing for snow + + DO J = ISNOW+1,0 + IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN + + HEATR(J) = 0. + IF (XM(J) > 0.) THEN + MICE(J) = MAX(0., WICE0(J)-XM(J)) + HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT + ELSE IF (XM(J) < 0.) THEN + MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J)) + HEATR(J) = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT + ENDIF + + MLIQ(J) = MAX(0.,WMASS0(J)-MICE(J)) + + IF (ABS(HEATR(J)) > 0.) THEN + STC(J) = STC(J) + FACT(J)*HEATR(J) + IF (MLIQ(J)*MICE(J)>0.) STC(J) = TFRZ + ENDIF + + QMELT = QMELT + MAX(0.,(WICE0(J)-MICE(J)))/DT + + ENDIF + ENDDO + +IF (OPT_GLA == 1) THEN ! operate on the ice layers + DO J = 1, NSOIL ! all soil layers MLIQ(J) = SH2O(J) * DZSNSO(J) * 1000. MICE(J) = (SMC(J) - SH2O(J)) * DZSNSO(J) * 1000. END DO - DO J = ISNOW+1,NSOIL ! all layers + DO J = 1,NSOIL ! all layers IMELT(J) = 0 HM(J) = 0. XM(J) = 0. @@ -1706,7 +1768,7 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & WMASS0(J) = MICE(J) + MLIQ(J) ENDDO - DO J = ISNOW+1,NSOIL + DO J = 1,NSOIL IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN ! melting IMELT(J) = 1 ENDIF @@ -1724,7 +1786,7 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & ! Calculate the energy surplus and loss for melting and freezing - DO J = ISNOW+1,NSOIL + DO J = 1,NSOIL IF (IMELT(J) > 0) THEN HM(J) = (STC(J)-TFRZ)/FACT(J) STC(J) = TFRZ @@ -1763,9 +1825,9 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & PONDING = TEMP1-SNEQV ENDIF -! The rate of melting and freezing for snow and soil +! The rate of melting and freezing for soil - DO J = ISNOW+1,NSOIL + DO J = 1,NSOIL IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN HEATR(J) = 0. @@ -1905,6 +1967,8 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & END IF END DO END IF + +END IF ! OPT_GLA == 1 DO J = ISNOW+1,0 ! snow SNLIQ(J) = MLIQ(J) @@ -1912,10 +1976,14 @@ SUBROUTINE PHASECHANGE_GLACIER (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & END DO DO J = 1, NSOIL ! soil + IF(OPT_GLA == 1) THEN SH2O(J) = MLIQ(J) / (1000. * DZSNSO(J)) SH2O(J) = MAX(0.0,MIN(1.0,SH2O(J))) ! SMC(J) = (MLIQ(J) + MICE(J)) / (1000. * DZSNSO(J)) - SMC(J) = 1.0 + ELSEIF(OPT_GLA == 2) THEN + SH2O(J) = 0.0 ! ice, assume all frozen...forever + END IF + SMC(J) = 1.0 END DO END SUBROUTINE PHASECHANGE_GLACIER @@ -1923,7 +1991,7 @@ END SUBROUTINE PHASECHANGE_GLACIER SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in QVAP ,QDEW ,FICEOLD,ZSOIL , & !in ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ ,STC , & !inout - DZSNSO ,SH2O ,SICE ,PONDING,ZSNSO , & !inout + DZSNSO ,SH2O ,SICE ,PONDING,ZSNSO ,FSH , & !inout RUNSRF ,RUNSUB ,QSNOW ,PONDING1 ,PONDING2,QSNBOT,FPICE & !out #ifdef WRF_HYDRO , sfcheadrt & @@ -1942,8 +2010,8 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in REAL, INTENT(IN) :: DT !main time step (s) REAL, INTENT(IN) :: PRCP !precipitation (mm/s) REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] - REAL, INTENT(IN) :: QVAP !soil surface evaporation rate[mm/s] - REAL, INTENT(IN) :: QDEW !soil surface dew rate[mm/s] + REAL, INTENT(INOUT) :: QVAP !soil surface evaporation rate[mm/s] + REAL, INTENT(INOUT) :: QDEW !soil surface dew rate[mm/s] REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD !ice fraction at last timestep REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) @@ -1959,6 +2027,7 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice content [m3/m3] REAL , INTENT(INOUT) :: PONDING ![mm] REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !layer-bottom depth from snow surf [m] + REAL , INTENT(INOUT) :: FSH !total sensible heat (w/m2) [+ to atm] ! output REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] @@ -2044,36 +2113,16 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in ! sublimation, frost, evaporation, and dew -! QSNSUB = 0. -! IF (SNEQV > 0.) THEN -! QSNSUB = MIN(QVAP, SNEQV/DT) -! ENDIF -! QSEVA = QVAP-QSNSUB - -! QSNFRO = 0. -! IF (SNEQV > 0.) THEN -! QSNFRO = QDEW -! ENDIF -! QSDEW = QDEW - QSNFRO - QSNSUB = QVAP ! send total sublimation/frost to SNOWWATER and deal with it there QSNFRO = QDEW -! print *, 'qvap',qvap,qvap*dt -! print *, 'qsnsub',qsnsub,qsnsub*dt -! print *, 'qseva',qseva,qseva*dt -! print *, 'qsnfro',qsnfro,qsnfro*dt -! print *, 'qdew',qdew,qdew*dt -! print *, 'qsdew',qsdew,qsdew*dt -!print *, 'before snowwater', sneqv,snowh,snice,snliq,sh2o,sice CALL SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in SNOWHIN,QSNOW ,QSNFRO ,QSNSUB ,QRAIN , & !in FICEOLD,ZSOIL , & !in ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout SH2O ,SICE ,STC ,DZSNSO ,ZSNSO , & !inout + FSH , & !inout QSNBOT ,SNOFLOW,PONDING1 ,PONDING2) !out -!print *, 'after snowwater', sneqv,snowh,snice,snliq,sh2o,sice -!print *, 'ponding', PONDING,PONDING1,PONDING2 !PONDING: melting water from snow when there is no layer @@ -2089,20 +2138,29 @@ SUBROUTINE WATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,PRCP ,SFCTMP , & !in RUNSRF = RUNSRF + sfcheadrt/DT !sfcheadrt units (mm) #endif - REPLACE = 0.0 - DO ILEV = 1,NSOIL + IF(OPT_GLA == 1) THEN + REPLACE = 0.0 + DO ILEV = 1,NSOIL REPLACE = REPLACE + DZSNSO(ILEV)*(SICE(ILEV) - SICE_SAVE(ILEV) + SH2O(ILEV) - SH2O_SAVE(ILEV)) - END DO - REPLACE = REPLACE * 1000.0 / DT ! convert to [mm/s] + END DO + REPLACE = REPLACE * 1000.0 / DT ! convert to [mm/s] - SICE = MIN(1.0,SICE_SAVE) + SICE = MIN(1.0,SICE_SAVE) + ELSEIF(OPT_GLA == 2) THEN + SICE = 1.0 + END IF SH2O = 1.0 - SICE -!print *, 'replace', replace ! use RUNSUB as a water balancer, SNOFLOW is snow that disappears, REPLACE is ! water from below that replaces glacier loss - RUNSUB = SNOFLOW + REPLACE + IF(OPT_GLA == 1) THEN + RUNSUB = SNOFLOW + REPLACE + ELSEIF(OPT_GLA == 2) THEN + RUNSUB = SNOFLOW + QVAP = QSNSUB + QDEW = QSNFRO + END IF END SUBROUTINE WATER_GLACIER ! ================================================================================================== @@ -2112,6 +2170,7 @@ SUBROUTINE SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in FICEOLD,ZSOIL , & !in ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout SH2O ,SICE ,STC ,DZSNSO ,ZSNSO , & !inout + FSH , & !inout QSNBOT ,SNOFLOW,PONDING1 ,PONDING2) !out ! ---------------------------------------------------------------------- IMPLICIT NONE @@ -2124,8 +2183,8 @@ SUBROUTINE SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] REAL, INTENT(IN) :: SNOWHIN!snow depth increasing rate (m/s) REAL, INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] - REAL, INTENT(IN) :: QSNFRO !snow surface frost rate[mm/s] - REAL, INTENT(IN) :: QSNSUB !snow surface sublimation rate[mm/s] + REAL, INTENT(INOUT) :: QSNFRO !snow surface frost rate[mm/s] + REAL, INTENT(INOUT) :: QSNSUB !snow surface sublimation rate[mm/s] REAL, INTENT(IN) :: QRAIN !snow surface rain rate[mm/s] REAL, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: FICEOLD!ice fraction at last timestep REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) @@ -2141,6 +2200,7 @@ SUBROUTINE SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !snow/soil layer thickness [m] REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !layer-bottom depth from snow surf [m] + REAL , INTENT(INOUT) :: FSH !total sensible heat (w/m2) [+ to atm] ! output REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] @@ -2189,7 +2249,7 @@ SUBROUTINE SNOWWATER_GLACIER (NSNOW ,NSOIL ,IMELT ,DT ,SFCTMP , & !in QRAIN , & !in ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout SNLIQ ,SH2O ,SICE ,STC , & !inout - PONDING1 ,PONDING2 , & !inout + PONDING1 ,PONDING2 ,FSH , & !inout QSNBOT ) !out !to obtain equilibrium state of snow in glacier region @@ -2749,7 +2809,7 @@ SUBROUTINE SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in QRAIN , & !in ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout SNLIQ ,SH2O ,SICE ,STC , & !inout - PONDING1 ,PONDING2 , & !inout + PONDING1 ,PONDING2 ,FSH , & !inout QSNBOT ) !out ! ---------------------------------------------------------------------- ! Renew the mass of ice lens (SNICE) and liquid (SNLIQ) of the @@ -2762,8 +2822,8 @@ SUBROUTINE SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers[=3] INTEGER, INTENT(IN) :: NSOIL !No. of soil layers[=4] REAL, INTENT(IN) :: DT !time step - REAL, INTENT(IN) :: QSNFRO !snow surface frost rate[mm/s] - REAL, INTENT(IN) :: QSNSUB !snow surface sublimation rate[mm/s] + REAL, INTENT(INOUT) :: QSNFRO !snow surface frost rate[mm/s] + REAL, INTENT(INOUT) :: QSNSUB !snow surface sublimation rate[mm/s] REAL, INTENT(IN) :: QRAIN !snow surface rain rate[mm/s] ! output @@ -2783,6 +2843,7 @@ SUBROUTINE SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] REAL, INTENT(INOUT) :: PONDING1 REAL, INTENT(INOUT) :: PONDING2 + REAL, INTENT(INOUT) :: FSH !total sensible heat (w/m2) [+ to atm] ! local variables: @@ -2799,7 +2860,13 @@ SUBROUTINE SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in !for the case when SNEQV becomes '0' after 'COMBINE' IF(SNEQV == 0.) THEN - SICE(1) = SICE(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.) + IF(OPT_GLA == 1) THEN + SICE(1) = SICE(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.) + ELSEIF(OPT_GLA == 2) THEN + FSH = FSH - (QSNFRO-QSNSUB)*HSUB + QSNFRO = 0.0 + QSNSUB = 0.0 + END IF END IF ! for shallow snow without a layer @@ -2808,10 +2875,16 @@ SUBROUTINE SNOWH2O_GLACIER (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in ! to aviod this problem. IF(ISNOW == 0 .and. SNEQV > 0.) THEN - TEMP = SNEQV - SNEQV = SNEQV - QSNSUB*DT + QSNFRO*DT - PROPOR = SNEQV/TEMP - SNOWH = MAX(0.,PROPOR * SNOWH) + IF(OPT_GLA == 1) THEN + TEMP = SNEQV + SNEQV = SNEQV - QSNSUB*DT + QSNFRO*DT + PROPOR = SNEQV/TEMP + SNOWH = MAX(0.,PROPOR * SNOWH) + ELSEIF(OPT_GLA == 2) THEN + FSH = FSH - (QSNFRO-QSNSUB)*HSUB + QSNFRO = 0.0 + QSNSUB = 0.0 + END IF IF(SNEQV < 0.) THEN SICE(1) = SICE(1) + SNEQV/(DZSNSO(1)*1000.) @@ -2969,41 +3042,24 @@ SUBROUTINE ERROR_GLACIER (ILOC ,JLOC ,SWDOWN ,FSA ,FSR ,FIRA , & END SUBROUTINE ERROR_GLACIER ! ================================================================================================== - SUBROUTINE NOAHMP_OPTIONS_GLACIER(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & - iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) + SUBROUTINE NOAHMP_OPTIONS_GLACIER(iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, iopt_gla ) IMPLICIT NONE - INTEGER, INTENT(IN) :: idveg !dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 - INTEGER, INTENT(IN) :: iopt_crs !canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis) - INTEGER, INTENT(IN) :: iopt_btr !soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB) - INTEGER, INTENT(IN) :: iopt_run !runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS) - INTEGER, INTENT(IN) :: iopt_sfc !surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97) - INTEGER, INTENT(IN) :: iopt_frz !supercooled liquid water (1-> NY06; 2->Koren99) - INTEGER, INTENT(IN) :: iopt_inf !frozen soil permeability (1-> NY06; 2->Koren99) - INTEGER, INTENT(IN) :: iopt_rad !radiation transfer (1->gap=F(3D,cosz); 2->gap=0; 3->gap=1-Fveg) INTEGER, INTENT(IN) :: iopt_alb !snow surface albedo (1->BATS; 2->CLASS) INTEGER, INTENT(IN) :: iopt_snf !rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah) INTEGER, INTENT(IN) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->Noah) - INTEGER, INTENT(IN) :: iopt_stc !snow/soil temperature time scheme (only layer 1) ! 1 -> semi-implicit; 2 -> full implicit (original Noah) + INTEGER, INTENT(IN) :: IOPT_GLA ! glacier option (1->phase change; 2->simple) ! ------------------------------------------------------------------------------------------------- - dveg = idveg - - opt_crs = iopt_crs - opt_btr = iopt_btr - opt_run = iopt_run - opt_sfc = iopt_sfc - opt_frz = iopt_frz - opt_inf = iopt_inf - opt_rad = iopt_rad opt_alb = iopt_alb opt_snf = iopt_snf opt_tbot = iopt_tbot opt_stc = iopt_stc + opt_gla = iopt_gla end subroutine noahmp_options_glacier diff --git a/wrfv2_fire/phys/module_sf_noahmp_groundwater.F b/wrfv2_fire/phys/module_sf_noahmp_groundwater.F index 70fada6f..d7afc5f6 100644 --- a/wrfv2_fire/phys/module_sf_noahmp_groundwater.F +++ b/wrfv2_fire/phys/module_sf_noahmp_groundwater.F @@ -20,7 +20,7 @@ SUBROUTINE WTABLE_mmf_noahmp (NSOIL ,XLAND ,XICE ,XICE_THRESHOLD ,ISI its,ite, jts,jte, kts,kte ) ! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: BEXP, DKSAT, SMCMAX, PSISAT, SMCWLT ! SOIL DEPENDENT + USE NOAHMP_TABLES, ONLY: BEXP_TABLE, DKSAT_TABLE, SMCMAX_TABLE,PSISAT_TABLE, SMCWLT_TABLE ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- @@ -85,6 +85,8 @@ SUBROUTINE WTABLE_mmf_noahmp (NSOIL ,XLAND ,XICE ,XICE_THRESHOLD ,ISI ,WPLUS,WMINUS REAL, DIMENSION( ims:ime, jms:jme ) :: QLAT INTEGER, DIMENSION( ims:ime, jms:jme ) :: LANDMASK !-1 for water (ice or no ice) and glacial areas, 1 for land where the LSM does its soil moisture calculations. + + REAL :: BEXP,DKSAT,PSISAT,SMCMAX,SMCWLT DELTAT = WTDDT * 60. !timestep in seconds for this calculation @@ -133,6 +135,12 @@ SUBROUTINE WTABLE_mmf_noahmp (NSOIL ,XLAND ,XICE ,XICE_THRESHOLD ,ISI DO I=its,ite IF(LANDMASK(I,J).GT.0)THEN + BEXP = BEXP_TABLE (ISLTYP(I,J)) + DKSAT = DKSAT_TABLE (ISLTYP(I,J)) + PSISAT = PSISAT_TABLE (ISLTYP(I,J)) + SMCMAX = SMCMAX_TABLE (ISLTYP(I,J)) + SMCWLT = SMCWLT_TABLE (ISLTYP(I,J)) + IF(IVGTYP(I,J)==ISURBAN)THEN SMCMAX = 0.45 SMCWLT = 0.40 @@ -198,7 +206,7 @@ SUBROUTINE LATERALFLOW (ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA & ,ims,ime,jms,jme,kms,kme & ,its,ite,jts,jte,kts,kte ) ! ---------------------------------------------------------------------- - USE NOAHMP_SOIL_PARAMETERS, ONLY : DKSAT_TABLE + USE NOAHMP_TABLES, ONLY : DKSAT_TABLE ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- diff --git a/wrfv2_fire/phys/module_sf_noahmpdrv.F b/wrfv2_fire/phys/module_sf_noahmpdrv.F index c511525c..5e32d55d 100644 --- a/wrfv2_fire/phys/module_sf_noahmpdrv.F +++ b/wrfv2_fire/phys/module_sf_noahmpdrv.F @@ -1,8 +1,6 @@ MODULE module_sf_noahmpdrv !------------------------------- - USE module_sf_noahmplsm - USE module_sf_noahmp_glacier #if ( WRF_CHEM == 1 ) USE module_data_gocart_dust #endif @@ -17,7 +15,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN XLAND, XICE,XICE_THRES, & ! IN : Vegetation/Soil characteristics IDVEG, IOPT_CRS, IOPT_BTR, IOPT_RUN, IOPT_SFC, IOPT_FRZ, & ! IN : User options IOPT_INF, IOPT_RAD, IOPT_ALB, IOPT_SNF,IOPT_TBOT, IOPT_STC, & ! IN : User options - IZ0TLND, & ! IN : User options + IOPT_GLA, IOPT_RSF, IZ0TLND, & ! IN : User options T3D, QV3D, U_PHY, V_PHY, SWDOWN, GLW, & ! IN : Forcing P8W3D,PRECIP_IN, SR, & ! IN : Forcing TSK, HFX, QFX, LH, GRDFLX, SMSTAV, & ! IN/OUT LSM eqv @@ -30,7 +28,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN QSNOWXY, WSLAKEXY, ZWTXY, WAXY, WTXY, TSNOXY, & ! IN/OUT Noah MP only ZSNSOXY, SNICEXY, SNLIQXY, LFMASSXY, RTMASSXY, STMASSXY, & ! IN/OUT Noah MP only WOODXY, STBLCPXY, FASTCPXY, XLAIXY, XSAIXY, TAUSSXY, & ! IN/OUT Noah MP only - SMOISEQ, SMCWTDXY,DEEPRECHXY, RECHXY, & ! IN/OUT Noah MP only + SMOISEQ, SMCWTDXY,DEEPRECHXY, RECHXY, GRAINXY, GDDXY, & ! IN/OUT Noah MP only T2MVXY, T2MBXY, Q2MVXY, Q2MBXY, & ! OUT Noah MP only TRADXY, NEEXY, GPPXY, NPPXY, FVEGXY, RUNSFXY, & ! OUT Noah MP only RUNSBXY, ECANXY, EDIRXY, ETRANXY, FSAXY, FIRAXY, & ! OUT Noah MP only @@ -39,6 +37,9 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN SHGXY, SHCXY, SHBXY, EVGXY, EVBXY, GHVXY, & ! OUT Noah MP only GHBXY, IRGXY, IRCXY, IRBXY, TRXY, EVCXY, & ! OUT Noah MP only CHLEAFXY, CHUCXY, CHV2XY, CHB2XY, & ! OUT Noah MP only +! BEXP_3D,SMCDRY_3D,SMCWLT_3D,SMCREF_3D,SMCMAX_3D, & ! placeholders to activate 3D soil +! DKSAT_3D,DWSAT_3D,PSISAT_3D,QUARTZ_3D, & +! REFDK_2D,REFKDT_2D, & #ifdef WRF_HYDRO sfcheadrt,INFXSRT,soldrain, & #endif @@ -47,7 +48,10 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN its,ite, jts,jte, kts,kte, & MP_RAINC, MP_RAINNC, MP_SHCV, MP_SNOW, MP_GRAUP, MP_HAIL ) !---------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: TRANSFER_MP_PARAMETERS, CO2, O2, ISICE + USE MODULE_SF_NOAHMPLSM +! USE MODULE_SF_NOAHMPLSM, only: noahmp_options, NOAHMP_SFLX, noahmp_parameters + USE module_sf_noahmp_glacier + USE NOAHMP_TABLES, ONLY: ISICE_TABLE, CO2_TABLE, O2_TABLE !---------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------- @@ -84,6 +88,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN INTEGER, INTENT(IN ) :: IOPT_SNF ! rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah) INTEGER, INTENT(IN ) :: IOPT_TBOT ! lower boundary of soil temperature (1->zero-flux; 2->Noah) INTEGER, INTENT(IN ) :: IOPT_STC ! snow/soil temperature time scheme + INTEGER, INTENT(IN ) :: IOPT_GLA ! glacier option (1->phase change; 2->simple) + INTEGER, INTENT(IN ) :: IOPT_RSF ! surface resistance (1->Sakaguchi/Zeng; 2->Seller; 3->mod Sellers; 4->1+snow) INTEGER, INTENT(IN ) :: IZ0TLND ! option of Chen adjustment of Czil (not used) REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: T3D ! 3D atmospheric temperature valid at mid-levels [K] REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN ) :: QV3D ! 3D water vapor mixing ratio [kg/kg_dry] @@ -105,6 +111,18 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN #ifdef WRF_HYDRO REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: sfcheadrt,INFXSRT,soldrain ! for WRF-Hydro #endif +! placeholders for 3D soil +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: BEXP_3D ! C-H B exponent +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: SMCDRY_3D ! Soil Moisture Limit: Dry +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: SMCWLT_3D ! Soil Moisture Limit: Wilt +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: SMCREF_3D ! Soil Moisture Limit: Reference +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: SMCMAX_3D ! Soil Moisture Limit: Max +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: DKSAT_3D ! Saturated Soil Conductivity +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: DWSAT_3D ! Saturated Soil Diffusivity +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: PSISAT_3D ! Saturated Matric Potential +! REAL, DIMENSION( ims:ime, 1:nsoil, jms:jme ), INTENT(IN) :: QUARTZ_3D ! Soil quartz content +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: REFDK_2D ! Reference Soil Conductivity +! REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN) :: REFKDT_2D ! Soil Infiltration Parameter ! INOUT (with generic LSM equivalent) @@ -159,6 +177,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RTMASSXY ! mass of fine roots [g/m2] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: STMASSXY ! stem mass [g/m2] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: WOODXY ! mass of wood (incl. woody roots) [g/m2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: GRAINXY ! mass of grain XING [g/m2] + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: GDDXY ! growing degree days XING (based on 10C) REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: STBLCPXY ! stable carbon in deep soil [g/m2] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: FASTCPXY ! short-lived carbon, shallow soil [g/m2] REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XLAIXY ! leaf area index @@ -293,6 +313,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN REAL :: RTMASS ! mass of fine roots [g/m2] REAL :: STMASS ! stem mass [g/m2] REAL :: WOOD ! mass of wood (incl. woody roots) [g/m2] + REAL :: GRAIN ! mass of grain XING [g/m2] + REAL :: GDD ! mass of grain XING[g/m2] REAL :: STBLCP ! stable carbon in deep soil [g/m2] REAL :: FASTCP ! short-lived carbon, shallow soil [g/m2] REAL :: PLAI ! leaf area index @@ -388,12 +410,15 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN INTEGER, PARAMETER :: NSNOW = 3 ! number of snow layers fixed to 3 REAL, PARAMETER :: undefined_value = -1.E36 + + type(noahmp_parameters) :: parameters ! ---------------------------------------------------------------------- CALL NOAHMP_OPTIONS(IDVEG ,IOPT_CRS ,IOPT_BTR ,IOPT_RUN ,IOPT_SFC ,IOPT_FRZ , & - IOPT_INF ,IOPT_RAD ,IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC ) + IOPT_INF ,IOPT_RAD ,IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC , & + IOPT_RSF ) IPRINT = .false. ! debug printout @@ -535,6 +560,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN RTMASS = RTMASSXY(I,J) ! root mass STMASS = STMASSXY(I,J) ! stem mass WOOD = WOODXY (I,J) ! mass of wood (incl. woody roots) [g/m2] + GRAIN = GRAINXY (I,J) ! mass of grain XING [g/m2] + GDD = GDDXY (I,J) ! growing degree days XING STBLCP = STBLCPXY(I,J) ! stable carbon pool FASTCP = FASTCPXY(I,J) ! fast carbon pool PLAI = XLAIXY (I,J) ! leaf area index [-] (no snow effects) @@ -555,15 +582,27 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN SOILTYP = 7 ENDIF - CALL TRANSFER_MP_PARAMETERS(VEGTYP,SOILTYP,SLOPETYP,SOILCOLOR) - +! placeholders for 3D soil +! parameters%bexp = BEXP_3D (I,1:NSOIL,J) ! C-H B exponent +! parameters%smcdry = SMCDRY_3D(I,1:NSOIL,J) ! Soil Moisture Limit: Dry +! parameters%smcwlt = SMCWLT_3D(I,1:NSOIL,J) ! Soil Moisture Limit: Wilt +! parameters%smcref = SMCREF_3D(I,1:NSOIL,J) ! Soil Moisture Limit: Reference +! parameters%smcmax = SMCMAX_3D(I,1:NSOIL,J) ! Soil Moisture Limit: Max +! parameters%dksat = DKSAT_3D (I,1:NSOIL,J) ! Saturated Soil Conductivity +! parameters%dwsat = DWSAT_3D (I,1:NSOIL,J) ! Saturated Soil Diffusivity +! parameters%psisat = PSISAT_3D(I,1:NSOIL,J) ! Saturated Matric Potential +! parameters%quartz = QUARTZ_3D(I,1:NSOIL,J) ! Soil quartz content +! parameters%refdk = REFDK_2D (I,J) ! Reference Soil Conductivity +! parameters%refkdt = REFKDT_2D(I,J) ! Soil Infiltration Parameter + + CALL TRANSFER_MP_PARAMETERS(VEGTYP,SOILTYP,SLOPETYP,SOILCOLOR,parameters) ! Initialized local FICEOLD = 0.0 FICEOLD(ISNOW+1:0) = SNICEXY(I,ISNOW+1:0,J) & ! snow ice fraction /(SNICEXY(I,ISNOW+1:0,J)+SNLIQXY(I,ISNOW+1:0,J)) - CO2PP = CO2 * P_ML ! partial pressure co2 [Pa] - O2PP = O2 * P_ML ! partial pressure o2 [Pa] + CO2PP = CO2_TABLE * P_ML ! partial pressure co2 [Pa] + O2PP = O2_TABLE * P_ML ! partial pressure o2 [Pa] FOLN = 1.0 ! for now, set to nitrogen saturation QC = undefined_value ! test dummy value PBLH = undefined_value ! test dummy value ! PBL height @@ -576,10 +615,9 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN IF(VEGTYP == 27) FVEG = 0.0 IF(VEGTYP == 27) PLAI = 0.0 - IF ( VEGTYP == ISICE ) THEN + IF ( VEGTYP == ISICE_TABLE ) THEN ICE = -1 ! Land-ice point - CALL NOAHMP_OPTIONS_GLACIER(IDVEG ,IOPT_CRS ,IOPT_BTR ,IOPT_RUN ,IOPT_SFC ,IOPT_FRZ , & - IOPT_INF ,IOPT_RAD ,IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC ) + CALL NOAHMP_OPTIONS_GLACIER(IOPT_ALB ,IOPT_SNF ,IOPT_TBOT, IOPT_STC, IOPT_GLA ) TBOT = MIN(TBOT,263.15) ! set deep temp to at most -10C CALL NOAHMP_GLACIER( I, J, COSZ, NSNOW, NSOIL, DT, & ! IN : Time/Space/Model-related @@ -613,6 +651,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN RTMASS = undefined_value STMASS = undefined_value WOOD = undefined_value + GRAIN = undefined_value + GDD = undefined_value STBLCP = undefined_value FASTCP = undefined_value PLAI = undefined_value @@ -659,7 +699,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN ELSE ICE=0 ! Neither sea ice or land ice. - CALL NOAHMP_SFLX (& + CALL NOAHMP_SFLX (parameters, & I , J , LAT , YEARLEN , JULIAN , COSZ , & ! IN : Time/Space-related DT , DX , DZ8W1D , NSOIL , ZSOIL , NSNOW , & ! IN : Model configuration FVEG , FVGMAX , VEGTYP , ICE , IST , & ! IN : Vegetation/Soil characteristics @@ -675,6 +715,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN ZWT , WA , WT , WSLAKE , LFMASS , RTMASS , & ! IN/OUT : STMASS , WOOD , STBLCP , FASTCP , PLAI , PSAI , & ! IN/OUT : CM , CH , TAUSS , & ! IN/OUT : + GRAIN , GDD , & ! IN/OUT SMCWTD ,DEEPRECH , RECH , & ! IN/OUT : Z0WRF , & FSA , FSR , FIRA , FSH , SSOIL , FCEV , & ! OUT : @@ -725,7 +766,7 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN SNOW (I,J) = SWE SNOWH (I,J) = SNDPTH CANWAT (I,J) = CANLIQ + CANICE - ACSNOW (I,J) = ACSNOW(I,J) + PRCP * FPICE + ACSNOW (I,J) = ACSNOW(I,J) + PRECIP_IN(I,J) * FPICE ACSNOM (I,J) = ACSNOM(I,J) + QSNBOT*DT + PONDING + PONDING1 + PONDING2 EMISS (I,J) = EMISSI QSFC (I,J) = QSFC1D @@ -755,6 +796,8 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN RTMASSXY (I,J) = RTMASS STMASSXY (I,J) = STMASS WOODXY (I,J) = WOOD + GRAINXY (I,J) = GRAIN !GRAIN XING + GDDXY (I,J) = GDD !XING STBLCPXY (I,J) = STBLCP FASTCPXY (I,J) = FASTCP XLAIXY (I,J) = PLAI @@ -822,6 +865,208 @@ SUBROUTINE noahmplsm(ITIMESTEP, YR, JULIAN, COSZIN, XLATIN, & ! IN END SUBROUTINE noahmplsm !------------------------------------------------------ +SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,parameters) + + USE NOAHMP_TABLES + USE MODULE_SF_NOAHMPLSM + + implicit none + + INTEGER, INTENT(IN) :: VEGTYPE + INTEGER, INTENT(IN) :: SOILTYPE + INTEGER, INTENT(IN) :: SLOPETYPE + INTEGER, INTENT(IN) :: SOILCOLOR + + type (noahmp_parameters), intent(inout) :: parameters + + REAL :: REFDK + REAL :: REFKDT + REAL :: FRZK + REAL :: FRZFACT + + parameters%ISWATER = ISWATER_TABLE + parameters%ISBARREN = ISBARREN_TABLE + parameters%ISICE = ISICE_TABLE + parameters%EBLFOREST = EBLFOREST_TABLE + + parameters%URBAN_FLAG = .FALSE. + IF( VEGTYPE == ISURBAN_TABLE .or. VEGTYPE == LOW_DENSITY_RESIDENTIAL_TABLE .or. & + VEGTYPE == HIGH_DENSITY_RESIDENTIAL_TABLE .or. VEGTYPE == HIGH_INTENSITY_INDUSTRIAL_TABLE ) THEN + parameters%URBAN_FLAG = .TRUE. + ENDIF + +!------------------------------------------------------------------------------------------! +! Transfer veg parameters +!------------------------------------------------------------------------------------------! + + parameters%CH2OP = CH2OP_TABLE(VEGTYPE) !maximum intercepted h2o per unit lai+sai (mm) + parameters%DLEAF = DLEAF_TABLE(VEGTYPE) !characteristic leaf dimension (m) + parameters%Z0MVT = Z0MVT_TABLE(VEGTYPE) !momentum roughness length (m) + parameters%HVT = HVT_TABLE(VEGTYPE) !top of canopy (m) + parameters%HVB = HVB_TABLE(VEGTYPE) !bottom of canopy (m) + parameters%DEN = DEN_TABLE(VEGTYPE) !tree density (no. of trunks per m2) + parameters%RC = RC_TABLE(VEGTYPE) !tree crown radius (m) + parameters%MFSNO = MFSNO_TABLE(VEGTYPE) !snowmelt m parameter () + parameters%SAIM = SAIM_TABLE(VEGTYPE,:) !monthly stem area index, one-sided + parameters%LAIM = LAIM_TABLE(VEGTYPE,:) !monthly leaf area index, one-sided + parameters%SLA = SLA_TABLE(VEGTYPE) !single-side leaf area per Kg [m2/kg] + parameters%DILEFC = DILEFC_TABLE(VEGTYPE) !coeficient for leaf stress death [1/s] + parameters%DILEFW = DILEFW_TABLE(VEGTYPE) !coeficient for leaf stress death [1/s] + parameters%FRAGR = FRAGR_TABLE(VEGTYPE) !fraction of growth respiration !original was 0.3 + parameters%LTOVRC = LTOVRC_TABLE(VEGTYPE) !leaf turnover [1/s] + + parameters%C3PSN = C3PSN_TABLE(VEGTYPE) !photosynthetic pathway: 0. = c4, 1. = c3 + parameters%KC25 = KC25_TABLE(VEGTYPE) !co2 michaelis-menten constant at 25c (pa) + parameters%AKC = AKC_TABLE(VEGTYPE) !q10 for kc25 + parameters%KO25 = KO25_TABLE(VEGTYPE) !o2 michaelis-menten constant at 25c (pa) + parameters%AKO = AKO_TABLE(VEGTYPE) !q10 for ko25 + parameters%VCMX25 = VCMX25_TABLE(VEGTYPE) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + parameters%AVCMX = AVCMX_TABLE(VEGTYPE) !q10 for vcmx25 + parameters%BP = BP_TABLE(VEGTYPE) !minimum leaf conductance (umol/m**2/s) + parameters%MP = MP_TABLE(VEGTYPE) !slope of conductance-to-photosynthesis relationship + parameters%QE25 = QE25_TABLE(VEGTYPE) !quantum efficiency at 25c (umol co2 / umol photon) + parameters%AQE = AQE_TABLE(VEGTYPE) !q10 for qe25 + parameters%RMF25 = RMF25_TABLE(VEGTYPE) !leaf maintenance respiration at 25c (umol co2/m**2/s) + parameters%RMS25 = RMS25_TABLE(VEGTYPE) !stem maintenance respiration at 25c (umol co2/kg bio/s) + parameters%RMR25 = RMR25_TABLE(VEGTYPE) !root maintenance respiration at 25c (umol co2/kg bio/s) + parameters%ARM = ARM_TABLE(VEGTYPE) !q10 for maintenance respiration + parameters%FOLNMX = FOLNMX_TABLE(VEGTYPE) !foliage nitrogen concentration when f(n)=1 (%) + parameters%TMIN = TMIN_TABLE(VEGTYPE) !minimum temperature for photosynthesis (k) + + parameters%XL = XL_TABLE(VEGTYPE) !leaf/stem orientation index + parameters%RHOL = RHOL_TABLE(VEGTYPE,:) !leaf reflectance: 1=vis, 2=nir + parameters%RHOS = RHOS_TABLE(VEGTYPE,:) !stem reflectance: 1=vis, 2=nir + parameters%TAUL = TAUL_TABLE(VEGTYPE,:) !leaf transmittance: 1=vis, 2=nir + parameters%TAUS = TAUS_TABLE(VEGTYPE,:) !stem transmittance: 1=vis, 2=nir + + parameters%MRP = MRP_TABLE(VEGTYPE) !microbial respiration parameter (umol co2 /kg c/ s) + parameters%CWPVT = CWPVT_TABLE(VEGTYPE) !empirical canopy wind parameter + + parameters%WRRAT = WRRAT_TABLE(VEGTYPE) !wood to non-wood ratio + parameters%WDPOOL = WDPOOL_TABLE(VEGTYPE) !wood pool (switch 1 or 0) depending on woody or not [-] + parameters%TDLEF = TDLEF_TABLE(VEGTYPE) !characteristic T for leaf freezing [K] + + parameters%NROOT = NROOT_TABLE(VEGTYPE) !number of soil layers with root present + parameters%RGL = RGL_TABLE(VEGTYPE) !Parameter used in radiation stress function + parameters%RSMIN = RS_TABLE(VEGTYPE) !Minimum stomatal resistance [s m-1] + parameters%HS = HS_TABLE(VEGTYPE) !Parameter used in vapor pressure deficit function + parameters%TOPT = TOPT_TABLE(VEGTYPE) !Optimum transpiration air temperature [K] + parameters%RSMAX = RSMAX_TABLE(VEGTYPE) !Maximal stomatal resistance [s m-1] + +!------------------------------------------------------------------------------------------! +! Transfer rad parameters +!------------------------------------------------------------------------------------------! + + parameters%ALBSAT = ALBSAT_TABLE(SOILCOLOR,:) + parameters%ALBDRY = ALBDRY_TABLE(SOILCOLOR,:) + parameters%ALBICE = ALBICE_TABLE + parameters%ALBLAK = ALBLAK_TABLE + parameters%OMEGAS = OMEGAS_TABLE + parameters%BETADS = BETADS_TABLE + parameters%BETAIS = BETAIS_TABLE + parameters%EG = EG_TABLE + +!------------------------------------------------------------------------------------------! +! Transfer crop parameters +!------------------------------------------------------------------------------------------! + + parameters%PLTDAY = PLTDAY_TABLE(1) ! Planting date + parameters%HSDAY = HSDAY_TABLE(1) ! Harvest date + parameters%PLANTPOP = PLANTPOP_TABLE(1) ! Plant density [per ha] - used? + parameters%IRRI = IRRI_TABLE(1) ! Irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + parameters%GDDTBASE = GDDTBASE_TABLE(1) ! Base temperature for GDD accumulation [C] + parameters%GDDTCUT = GDDTCUT_TABLE(1) ! Upper temperature for GDD accumulation [C] + parameters%GDDS1 = GDDS1_TABLE(1) ! GDD from seeding to emergence + parameters%GDDS2 = GDDS2_TABLE(1) ! GDD from seeding to initial vegetative + parameters%GDDS3 = GDDS3_TABLE(1) ! GDD from seeding to post vegetative + parameters%GDDS4 = GDDS4_TABLE(1) ! GDD from seeding to intial reproductive + parameters%GDDS5 = GDDS5_TABLE(1) ! GDD from seeding to pysical maturity + parameters%C3C4 = C3C4_TABLE(1) ! photosynthetic pathway: 1. = c3 2. = c4 + parameters%AREF = AREF_TABLE(1) ! reference maximum CO2 assimulation rate + parameters%PSNRF = PSNRF_TABLE(1) ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + parameters%I2PAR = I2PAR_TABLE(1) ! Fraction of incoming solar radiation to photosynthetically active radiation + parameters%TASSIM0 = TASSIM0_TABLE(1) ! Minimum temperature for CO2 assimulation [C] + parameters%TASSIM1 = TASSIM1_TABLE(1) ! CO2 assimulation linearly increasing until temperature reaches T1 [C] + parameters%TASSIM2 = TASSIM2_TABLE(1) ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C] + parameters%K = K_TABLE(1) ! light extinction coefficient + parameters%EPSI = EPSI_TABLE(1) ! initial light use efficiency + parameters%Q10MR = Q10MR_TABLE(1) ! q10 for maintainance respiration + parameters%FOLN_MX = FOLN_MX_TABLE(1) ! foliage nitrogen concentration when f(n)=1 (%) + parameters%LEFREEZ = LEFREEZ_TABLE(1) ! characteristic T for leaf freezing [K] + parameters%DILE_FC = DILE_FC_TABLE(1,:) ! coeficient for temperature leaf stress death [1/s] + parameters%DILE_FW = DILE_FW_TABLE(1,:) ! coeficient for water leaf stress death [1/s] + parameters%FRA_GR = FRA_GR_TABLE(1) ! fraction of growth respiration + parameters%LF_OVRC = LF_OVRC_TABLE(1,:) ! fraction of leaf turnover [1/s] + parameters%ST_OVRC = ST_OVRC_TABLE(1,:) ! fraction of stem turnover [1/s] + parameters%RT_OVRC = RT_OVRC_TABLE(1,:) ! fraction of root tunrover [1/s] + parameters%LFMR25 = LFMR25_TABLE(1) ! leaf maintenance respiration at 25C [umol CO2/m**2 /s] + parameters%STMR25 = STMR25_TABLE(1) ! stem maintenance respiration at 25C [umol CO2/kg bio/s] + parameters%RTMR25 = RTMR25_TABLE(1) ! root maintenance respiration at 25C [umol CO2/kg bio/s] + parameters%GRAINMR25 = GRAINMR25_TABLE(1) ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + parameters%LFPT = LFPT_TABLE(1,:) ! fraction of carbohydrate flux to leaf + parameters%STPT = STPT_TABLE(1,:) ! fraction of carbohydrate flux to stem + parameters%RTPT = RTPT_TABLE(1,:) ! fraction of carbohydrate flux to root + parameters%GRAINPT = GRAINPT_TABLE(1,:) ! fraction of carbohydrate flux to grain + parameters%BIO2LAI = BIO2LAI_TABLE(1) ! leaf are per living leaf biomass [m^2/kg] + +!------------------------------------------------------------------------------------------! +! Transfer global parameters +!------------------------------------------------------------------------------------------! + + parameters%CO2 = CO2_TABLE + parameters%O2 = O2_TABLE + parameters%TIMEAN = TIMEAN_TABLE + parameters%FSATMX = FSATMX_TABLE + parameters%Z0SNO = Z0SNO_TABLE + parameters%SSI = SSI_TABLE + parameters%SWEMX = SWEMX_TABLE + parameters%RSURF_SNOW = RSURF_SNOW_TABLE + +! ---------------------------------------------------------------------- +! Transfer soil parameters +! ---------------------------------------------------------------------- + + parameters%BEXP = BEXP_TABLE (SOILTYPE) + parameters%DKSAT = DKSAT_TABLE (SOILTYPE) + parameters%DWSAT = DWSAT_TABLE (SOILTYPE) + parameters%F1 = F1_TABLE (SOILTYPE) + parameters%PSISAT = PSISAT_TABLE (SOILTYPE) + parameters%QUARTZ = QUARTZ_TABLE (SOILTYPE) + parameters%SMCDRY = SMCDRY_TABLE (SOILTYPE) + parameters%SMCMAX = SMCMAX_TABLE (SOILTYPE) + parameters%SMCREF = SMCREF_TABLE (SOILTYPE) + parameters%SMCWLT = SMCWLT_TABLE (SOILTYPE) + parameters%REFDK = REFDK_TABLE + parameters%REFKDT = REFKDT_TABLE + +! ---------------------------------------------------------------------- +! Transfer GENPARM parameters +! ---------------------------------------------------------------------- + parameters%CSOIL = CSOIL_TABLE + parameters%ZBOT = ZBOT_TABLE + parameters%CZIL = CZIL_TABLE + + FRZK = FRZK_TABLE + parameters%KDT = parameters%REFKDT * parameters%DKSAT(1) / parameters%REFDK + parameters%SLOPE = SLOPE_TABLE(SLOPETYPE) + + IF(parameters%URBAN_FLAG)THEN ! Hardcoding some urban parameters for soil + parameters%SMCMAX = 0.45 + parameters%SMCREF = 0.42 + parameters%SMCWLT = 0.40 + parameters%SMCDRY = 0.40 + parameters%CSOIL = 3.E6 + ENDIF + +! adjust FRZK parameter to actual soil type: FRZK * FRZFACT + + IF(SOILTYPE /= 14) then + FRZFACT = (parameters%SMCMAX(1) / parameters%SMCREF(1)) * (0.412 / 0.468) + parameters%FRZX = FRZK * FRZFACT + END IF + + END SUBROUTINE TRANSFER_MP_PARAMETERS + SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & TSLB , SMOIS , SH2O , DZS , FNDSOILW , FNDSNOWH , & TSK, isnowxy , tvxy ,tgxy ,canicexy , TMN, XICE, & @@ -829,6 +1074,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & fwetxy ,sneqvoxy ,alboldxy ,qsnowxy ,wslakexy ,zwtxy ,waxy , & wtxy ,tsnoxy ,zsnsoxy ,snicexy ,snliqxy ,lfmassxy ,rtmassxy , & stmassxy ,woodxy ,stblcpxy ,fastcpxy ,xsaixy ,lai , & + grainxy ,gddxy , & !jref:start t2mvxy ,t2mbxy ,chstarxy, & !jref:end @@ -841,9 +1087,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & wtddt ,stepwtd ,dt ,qrfsxy ,qspringsxy , qslatxy , & ! Optional groundwater fdepthxy ,ht ,riverbedxy ,eqzwt ,rivercondxy ,pexpxy ) ! Optional groundwater - USE NOAHMP_VEG_PARAMETERS - USE NOAHMP_SOIL_PARAMETERS - USE NOAHMP_RAD_PARAMETERS + USE NOAHMP_TABLES IMPLICIT NONE @@ -907,6 +1151,8 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: rtmassxy !mass of fine roots [g/m2] REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: stmassxy !stem mass [g/m2] REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: woodxy !mass of wood (incl. woody roots) [g/m2] + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: grainxy !mass of grain [g/m2] !XING + REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: gddxy !growing degree days !XING REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: stblcpxy !stable carbon in deep soil [g/m2] REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: fastcpxy !short-lived carbon, shallow soil [g/m2] REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: xsaixy !stem area index @@ -952,7 +1198,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & INTEGER :: errflag, i,j,itf,jtf,ns - character(len=80) :: err_message + character(len=240) :: err_message character(len=4) :: MMINSL character(len=*), intent(in) :: MMINLU MMINSL='STAS' @@ -960,6 +1206,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & call read_mp_veg_parameters(trim(MMINLU)) call read_mp_soil_parameters() call read_mp_rad_parameters() + call read_mp_global_parameters() IF( .NOT. restart ) THEN @@ -979,6 +1226,23 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & ENDDO ENDIF + + ! Check if snow/snowh are consistent and cap SWE at 2000mm; + ! the Noah-MP code does it internally but if we don't do it here, problems ensue + DO J = jts,jtf + DO I = its,itf + IF ( SNOW(i,j) > 0. .AND. SNOWH(i,j) == 0. .OR. SNOWH(i,j) > 0. .AND. SNOW(i,j) == 0.) THEN + WRITE(err_message,*)"problem with initial snow fields: snow/snowh>0 while snowh/snow=0 at i,j" & + ,i,j,snow(i,j),snowh(i,j) + CALL wrf_message(err_message) + ENDIF + IF ( SNOW( i,j ) > 2000. ) THEN + SNOWH(I,J) = SNOWH(I,J) * 2000. / SNOW(I,J) ! SNOW in mm and SNOWH in m + SNOW (I,J) = 2000. ! cap SNOW at 2000, maintain density + ENDIF + ENDDO + ENDDO + errflag = 0 DO j = jts,jtf DO i = its,itf @@ -1112,6 +1376,8 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & woodxy (I,J) = 500.0 ! in the table or read from initialization stblcpxy (I,J) = 1000.0 ! fastcpxy (I,J) = 1000.0 ! + grainxy (I,J) = 1E-10 ! add by XING + gddxy (I,J) = 0 ! add by XING END IF @@ -1160,7 +1426,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP , IVGTYP, & STEPWTD = max(STEPWTD,1) CALL groundwater_init ( & - & nsoil, zsoil , dzs ,isltyp, ivgtyp, isurban_TABLE, isice_TABLE ,iswater_TABLE ,wtddt , & + & nsoil, zsoil , dzs ,isltyp, ivgtyp,wtddt , & & fdepthxy, ht, riverbedxy, eqzwt, rivercondxy, pexpxy , areaxy, zwtxy, & & smois,sh2o, smoiseq, smcwtdxy, deeprechxy, rechxy, qslatxy, qrfsxy, qspringsxy, & & ids,ide, jds,jde, kds,kde, & @@ -1282,7 +1548,7 @@ END SUBROUTINE SNOW_INIT ! ================================================================================================== ! ---------------------------------------------------------------------- SUBROUTINE GROUNDWATER_INIT ( & - & NSOIL , ZSOIL , DZS, ISLTYP, IVGTYP, ISURBAN, ISICE ,ISWATER , WTDDT , & + & NSOIL , ZSOIL , DZS, ISLTYP, IVGTYP, WTDDT , & & FDEPTH, TOPO, RIVERBED, EQWTD, RIVERCOND, PEXP , AREA ,WTD , & & SMOIS,SH2O, SMOISEQ, SMCWTDXY, DEEPRECHXY, RECHXY , & & QSLATXY, QRFSXY, QSPRINGSXY, & @@ -1291,7 +1557,8 @@ SUBROUTINE GROUNDWATER_INIT ( & & its,ite, jts,jte, kts,kte ) - USE NOAHMP_SOIL_PARAMETERS, ONLY : BEXP_TABLE,SMCMAX_TABLE,PSISAT_TABLE,SMCWLT_TABLE,DWSAT_TABLE,DKSAT_TABLE + USE NOAHMP_TABLES, ONLY : BEXP_TABLE,SMCMAX_TABLE,PSISAT_TABLE,SMCWLT_TABLE,DWSAT_TABLE,DKSAT_TABLE, & + ISURBAN_TABLE, ISICE_TABLE ,ISWATER_TABLE USE module_sf_noahmp_groundwater, ONLY : LATERALFLOW ! ---------------------------------------------------------------------- @@ -1301,7 +1568,7 @@ SUBROUTINE GROUNDWATER_INIT ( & INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN) :: NSOIL, ISURBAN, ISWATER ,ISICE + INTEGER, INTENT(IN) :: NSOIL REAL, INTENT(IN) :: WTDDT REAL, INTENT(IN), DIMENSION(1:NSOIL) :: ZSOIL,DZS INTEGER, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: ISLTYP, IVGTYP @@ -1336,7 +1603,7 @@ SUBROUTINE GROUNDWATER_INIT ( & DELTAT = WTDDT * 60. !timestep in seconds for this calculation - WHERE(IVGTYP.NE.ISWATER.AND.IVGTYP.NE.ISICE) + WHERE(IVGTYP.NE.ISWATER_TABLE.AND.IVGTYP.NE.ISICE_TABLE) LANDMASK=1 ELSEWHERE LANDMASK=-1 @@ -1377,7 +1644,7 @@ SUBROUTINE GROUNDWATER_INIT ( & BEXP = BEXP_TABLE(ISLTYP(I,J)) SMCMAX = SMCMAX_TABLE(ISLTYP(I,J)) SMCWLT = SMCWLT_TABLE(ISLTYP(I,J)) - IF(IVGTYP(I,J)==ISURBAN)THEN + IF(IVGTYP(I,J)==ISURBAN_TABLE)THEN SMCMAX = 0.45 SMCWLT = 0.40 ENDIF diff --git a/wrfv2_fire/phys/module_sf_noahmplsm.F b/wrfv2_fire/phys/module_sf_noahmplsm.F index 336656a1..e97f257f 100644 --- a/wrfv2_fire/phys/module_sf_noahmplsm.F +++ b/wrfv2_fire/phys/module_sf_noahmplsm.F @@ -1,8959 +1,9684 @@ -module noahmp_globals - - implicit none - -! =====================================options for different schemes================================ -! options for dynamic vegetation: -! 1 -> off (use table LAI; use FVEG = SHDFAC from input) -! 2 -> on (together with OPT_CRS = 1) -! 3 -> off (use table LAI; calculate FVEG) -! 4 -> off (use table LAI; use maximum vegetation fraction) - - INTEGER :: DVEG != 4 ! - -! options for canopy stomatal resistance -! 1-> Ball-Berry; 2->Jarvis - - INTEGER :: OPT_CRS != 1 !(must 1 when DVEG = 2) +MODULE MODULE_SF_NOAHMPLSM -! options for soil moisture factor for stomatal resistance -! 1-> Noah (soil moisture) -! 2-> CLM (matric potential) -! 3-> SSiB (matric potential) + IMPLICIT NONE - INTEGER :: OPT_BTR != 1 !(suggested 1) + public :: noahmp_options + public :: NOAHMP_SFLX -! options for runoff and groundwater -! 1 -> TOPMODEL with groundwater (Niu et al. 2007 JGR) ; -! 2 -> TOPMODEL with an equilibrium water table (Niu et al. 2005 JGR) ; -! 3 -> original surface and subsurface runoff (free drainage) -! 4 -> BATS surface and subsurface runoff (free drainage) -! 5 -> Miguez-Macho&Fan groundwater scheme (Miguez-Macho et al. 2007 JGR, lateral flow: Fan et al. 2007 JGR) + private :: ATM + private :: PHENOLOGY + private :: PRECIP_HEAT + private :: ENERGY + private :: THERMOPROP + private :: CSNOW + private :: TDFCND + private :: RADIATION + private :: ALBEDO + private :: SNOW_AGE + private :: SNOWALB_BATS + private :: SNOWALB_CLASS + private :: GROUNDALB + private :: TWOSTREAM + private :: SURRAD + private :: VEGE_FLUX + private :: SFCDIF1 + private :: SFCDIF2 + private :: STOMATA + private :: CANRES + private :: ESAT + private :: RAGRB + private :: BARE_FLUX + private :: TSNOSOI + private :: HRT + private :: HSTEP + private :: ROSR12 + private :: PHASECHANGE + private :: FRH2O - INTEGER :: OPT_RUN != 1 !(suggested 1) + private :: WATER + private :: CANWATER + private :: SNOWWATER + private :: SNOWFALL + private :: COMBINE + private :: DIVIDE + private :: COMBO + private :: COMPACT + private :: SNOWH2O + private :: SOILWATER + private :: ZWTEQ + private :: INFIL + private :: SRT + private :: WDFCND1 + private :: WDFCND2 + private :: SSTEP + private :: GROUNDWATER + private :: SHALLOWWATERTABLE -! options for surface layer drag coeff (CH & CM) -! 1->M-O ; 2->original Noah (Chen97); 3->MYJ consistent; 4->YSU consistent. + private :: CARBON + private :: CO2FLUX +! private :: BVOCFLUX +! private :: CH4FLUX - INTEGER :: OPT_SFC != 1 !(1 or 2 or 3 or 4) + private :: ERROR -! options for supercooled liquid water (or ice fraction) -! 1-> no iteration (Niu and Yang, 2006 JHM); 2: Koren's iteration +! =====================================options for different schemes================================ +! **recommended + + INTEGER :: DVEG ! options for dynamic vegetation: + ! 1 -> off (use table LAI; use FVEG = SHDFAC from input) + ! 2 -> on (together with OPT_CRS = 1) + ! 3 -> off (use table LAI; calculate FVEG) + ! **4 -> off (use table LAI; use maximum vegetation fraction) + ! **5 -> on (use maximum vegetation fraction) + ! 6 -> on (use FVEG = SHDFAC from input) + ! 7 -> off (use input LAI; use FVEG = SHDFAC from input) + ! 8 -> off (use input LAI; calculate FVEG) + ! 9 -> off (use input LAI; use maximum vegetation fraction) + + INTEGER :: OPT_CRS ! options for canopy stomatal resistance + ! **1 -> Ball-Berry + ! 2 -> Jarvis + + INTEGER :: OPT_BTR ! options for soil moisture factor for stomatal resistance + ! **1 -> Noah (soil moisture) + ! 2 -> CLM (matric potential) + ! 3 -> SSiB (matric potential) + + INTEGER :: OPT_RUN ! options for runoff and groundwater + ! **1 -> TOPMODEL with groundwater (Niu et al. 2007 JGR) ; + ! 2 -> TOPMODEL with an equilibrium water table (Niu et al. 2005 JGR) ; + ! 3 -> original surface and subsurface runoff (free drainage) + ! 4 -> BATS surface and subsurface runoff (free drainage) + ! 5 -> Miguez-Macho&Fan groundwater scheme (Miguez-Macho et al. 2007 JGR; Fan et al. 2007 JGR) + ! (needs further testing for public use) + + INTEGER :: OPT_SFC ! options for surface layer drag coeff (CH & CM) + ! **1 -> M-O + ! **2 -> original Noah (Chen97) + ! **3 -> MYJ consistent; 4->YSU consistent. MB: removed in v3.7 for further testing + + INTEGER :: OPT_FRZ ! options for supercooled liquid water (or ice fraction) + ! **1 -> no iteration (Niu and Yang, 2006 JHM) + ! 2 -> Koren's iteration + + INTEGER :: OPT_INF ! options for frozen soil permeability + ! **1 -> linear effects, more permeable (Niu and Yang, 2006, JHM) + ! 2 -> nonlinear effects, less permeable (old) + + INTEGER :: OPT_RAD ! options for radiation transfer + ! 1 -> modified two-stream (gap = F(solar angle, 3D structure ...)<1-FVEG) + ! 2 -> two-stream applied to grid-cell (gap = 0) + ! **3 -> two-stream applied to vegetated fraction (gap=1-FVEG) + + INTEGER :: OPT_ALB ! options for ground snow surface albedo + ! 1 -> BATS + ! **2 -> CLASS + + INTEGER :: OPT_SNF ! options for partitioning precipitation into rainfall & snowfall + ! **1 -> Jordan (1991) + ! 2 -> BATS: when SFCTMP SFCTMP < TFRZ + ! 4 -> Use WRF microphysics output + + INTEGER :: OPT_TBOT ! options for lower boundary condition of soil temperature + ! 1 -> zero heat flux from bottom (ZBOT and TBOT not used) + ! **2 -> TBOT at ZBOT (8m) read from a file (original Noah) + + INTEGER :: OPT_STC ! options for snow/soil temperature time scheme (only layer 1) + ! **1 -> semi-implicit; flux top boundary condition + ! 2 -> full implicit (original Noah); temperature top boundary condition + ! 3 -> same as 1, but FSNO for TS calculation (generally improves snow; v3.7) + + INTEGER :: OPT_RSF ! options for surface resistent to evaporation/sublimation + ! **1 -> Sakaguchi and Zeng, 2009 + ! 2 -> Sellers (1992) + ! 3 -> adjusted Sellers to decrease RSURF for wet soil + ! 4 -> option 1 for non-snow; rsurf = rsurf_snow for snow (set in MPTABLE); AD v3.8 - INTEGER :: OPT_FRZ != 1 !(1 or 2) +!------------------------------------------------------------------------------------------! +! Physical Constants: ! +!------------------------------------------------------------------------------------------! -! options for frozen soil permeability -! 1 -> linear effects, more permeable (Niu and Yang, 2006, JHM) -! 2 -> nonlinear effects, less permeable (old) + REAL, PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) + REAL, PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) + REAL, PARAMETER :: VKC = 0.40 !von Karman constant + REAL, PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) + REAL, PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) + REAL, PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) + REAL, PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) + REAL, PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) + REAL, PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) + REAL, PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) + REAL, PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) + REAL, PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) + REAL, PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) (not used MB: 20140718) + REAL, PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) + REAL, PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) + REAL, PARAMETER :: DENH2O = 1000. !density of water (kg/m3) + REAL, PARAMETER :: DENICE = 917. !density of ice (kg/m3) - INTEGER :: OPT_INF != 1 !(suggested 1) + INTEGER, PRIVATE, PARAMETER :: MBAND = 2 + INTEGER, PRIVATE, PARAMETER :: NSOIL = 4 + INTEGER, PRIVATE, PARAMETER :: NSTAGE = 8 -! options for radiation transfer -! 1 -> modified two-stream (gap = F(solar angle, 3D structure ...)<1-FVEG) -! 2 -> two-stream applied to grid-cell (gap = 0) -! 3 -> two-stream applied to vegetated fraction (gap=1-FVEG) + TYPE noahmp_parameters ! define a NoahMP parameters type - INTEGER :: OPT_RAD != 1 !(suggested 1) +!------------------------------------------------------------------------------------------! +! From the veg section of MPTABLE.TBL +!------------------------------------------------------------------------------------------! -! options for ground snow surface albedo -! 1-> BATS; 2 -> CLASS + LOGICAL :: URBAN_FLAG + INTEGER :: ISWATER + INTEGER :: ISBARREN + INTEGER :: ISICE + INTEGER :: EBLFOREST + + REAL :: CH2OP !maximum intercepted h2o per unit lai+sai (mm) + REAL :: DLEAF !characteristic leaf dimension (m) + REAL :: Z0MVT !momentum roughness length (m) + REAL :: HVT !top of canopy (m) + REAL :: HVB !bottom of canopy (m) + REAL :: DEN !tree density (no. of trunks per m2) + REAL :: RC !tree crown radius (m) + REAL :: MFSNO !snowmelt m parameter () + REAL :: SAIM(12) !monthly stem area index, one-sided + REAL :: LAIM(12) !monthly leaf area index, one-sided + REAL :: SLA !single-side leaf area per Kg [m2/kg] + REAL :: DILEFC !coeficient for leaf stress death [1/s] + REAL :: DILEFW !coeficient for leaf stress death [1/s] + REAL :: FRAGR !fraction of growth respiration !original was 0.3 + REAL :: LTOVRC !leaf turnover [1/s] + + REAL :: C3PSN !photosynthetic pathway: 0. = c4, 1. = c3 + REAL :: KC25 !co2 michaelis-menten constant at 25c (pa) + REAL :: AKC !q10 for kc25 + REAL :: KO25 !o2 michaelis-menten constant at 25c (pa) + REAL :: AKO !q10 for ko25 + REAL :: VCMX25 !maximum rate of carboxylation at 25c (umol co2/m**2/s) + REAL :: AVCMX !q10 for vcmx25 + REAL :: BP !minimum leaf conductance (umol/m**2/s) + REAL :: MP !slope of conductance-to-photosynthesis relationship + REAL :: QE25 !quantum efficiency at 25c (umol co2 / umol photon) + REAL :: AQE !q10 for qe25 + REAL :: RMF25 !leaf maintenance respiration at 25c (umol co2/m**2/s) + REAL :: RMS25 !stem maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: RMR25 !root maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: ARM !q10 for maintenance respiration + REAL :: FOLNMX !foliage nitrogen concentration when f(n)=1 (%) + REAL :: TMIN !minimum temperature for photosynthesis (k) + + REAL :: XL !leaf/stem orientation index + REAL :: RHOL(MBAND) !leaf reflectance: 1=vis, 2=nir + REAL :: RHOS(MBAND) !stem reflectance: 1=vis, 2=nir + REAL :: TAUL(MBAND) !leaf transmittance: 1=vis, 2=nir + REAL :: TAUS(MBAND) !stem transmittance: 1=vis, 2=nir - INTEGER :: OPT_ALB != 2 !(suggested 2) + REAL :: MRP !microbial respiration parameter (umol co2 /kg c/ s) + REAL :: CWPVT !empirical canopy wind parameter -! options for partitioning precipitation into rainfall & snowfall -! 1 -> Jordan (1991); 2 -> BATS: when SFCTMP SFCTMP zero heat flux from bottom (ZBOT and TBOT not used) -! 2 -> TBOT at ZBOT (8m) read from a file (original Noah) + REAL :: SLAREA + REAL :: EPS(5) - INTEGER :: OPT_TBOT != 2 !(suggested 2) +!------------------------------------------------------------------------------------------! +! From the rad section of MPTABLE.TBL +!------------------------------------------------------------------------------------------! -! options for snow/soil temperature time scheme (only layer 1) -! 1 -> semi-implicit; 2 -> full implicit (original Noah) + REAL :: ALBSAT(MBAND) !saturated soil albedos: 1=vis, 2=nir + REAL :: ALBDRY(MBAND) !dry soil albedos: 1=vis, 2=nir + REAL :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir + REAL :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir + REAL :: OMEGAS(MBAND) !two-stream parameter omega for snow + REAL :: BETADS !two-stream parameter betad for snow + REAL :: BETAIS !two-stream parameter betad for snow + REAL :: EG(2) !emissivity - INTEGER :: OPT_STC != 1 !(suggested 1) -! ================================================================================================== +!------------------------------------------------------------------------------------------! +! From the globals section of MPTABLE.TBL +!------------------------------------------------------------------------------------------! + + REAL :: CO2 !co2 partial pressure + REAL :: O2 !o2 partial pressure + REAL :: TIMEAN !gridcell mean topgraphic index (global mean) + REAL :: FSATMX !maximum surface saturated fraction (global mean) + REAL :: Z0SNO !snow surface roughness length (m) (0.002) + REAL :: SSI !liquid water holding capacity for snowpack (m3/m3) + REAL :: SWEMX !new snow mass to fully cover old snow (mm) + REAL :: RSURF_SNOW !surface resistance for snow(s/m) -! NOTES: things to add or improve -! 1. lake model: explicit representation of lake water storage, sunlight through lake -! with different purity, turbulent mixing of surface laker water, snow on frozen lake, etc. -! 2. shallow snow wihtout a layer: melting energy -! 3. urban model to be added. -! 4. irrigation !------------------------------------------------------------------------------------------! -END MODULE NOAHMP_GLOBALS +! From the crop section of MPTABLE.TBL +!------------------------------------------------------------------------------------------! + + INTEGER :: PLTDAY ! Planting date + INTEGER :: HSDAY ! Harvest date + REAL :: PLANTPOP ! Plant density [per ha] - used? + REAL :: IRRI ! Irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + REAL :: GDDTBASE ! Base temperature for GDD accumulation [C] + REAL :: GDDTCUT ! Upper temperature for GDD accumulation [C] + REAL :: GDDS1 ! GDD from seeding to emergence + REAL :: GDDS2 ! GDD from seeding to initial vegetative + REAL :: GDDS3 ! GDD from seeding to post vegetative + REAL :: GDDS4 ! GDD from seeding to intial reproductive + REAL :: GDDS5 ! GDD from seeding to pysical maturity + INTEGER :: C3C4 ! photosynthetic pathway: 1 = c3 2 = c4 + REAL :: AREF ! reference maximum CO2 assimulation rate + REAL :: PSNRF ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + REAL :: I2PAR ! Fraction of incoming solar radiation to photosynthetically active radiation + REAL :: TASSIM0 ! Minimum temperature for CO2 assimulation [C] + REAL :: TASSIM1 ! CO2 assimulation linearly increasing until temperature reaches T1 [C] + REAL :: TASSIM2 ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C] + REAL :: K ! light extinction coefficient + REAL :: EPSI ! initial light use efficiency + REAL :: Q10MR ! q10 for maintainance respiration + REAL :: FOLN_MX ! foliage nitrogen concentration when f(n)=1 (%) + REAL :: LEFREEZ ! characteristic T for leaf freezing [K] + REAL :: DILE_FC(NSTAGE) ! coeficient for temperature leaf stress death [1/s] + REAL :: DILE_FW(NSTAGE) ! coeficient for water leaf stress death [1/s] + REAL :: FRA_GR ! fraction of growth respiration + REAL :: LF_OVRC(NSTAGE) ! fraction of leaf turnover [1/s] + REAL :: ST_OVRC(NSTAGE) ! fraction of stem turnover [1/s] + REAL :: RT_OVRC(NSTAGE) ! fraction of root tunrover [1/s] + REAL :: LFMR25 ! leaf maintenance respiration at 25C [umol CO2/m**2 /s] + REAL :: STMR25 ! stem maintenance respiration at 25C [umol CO2/kg bio/s] + REAL :: RTMR25 ! root maintenance respiration at 25C [umol CO2/kg bio/s] + REAL :: GRAINMR25 ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + REAL :: LFPT(NSTAGE) ! fraction of carbohydrate flux to leaf + REAL :: STPT(NSTAGE) ! fraction of carbohydrate flux to stem + REAL :: RTPT(NSTAGE) ! fraction of carbohydrate flux to root + REAL :: GRAINPT(NSTAGE) ! fraction of carbohydrate flux to grain + REAL :: BIO2LAI ! leaf are per living leaf biomass [m^2/kg] -! ================================================================================================== +!------------------------------------------------------------------------------------------! +! From the SOILPARM.TBL tables, as functions of soil category. +!------------------------------------------------------------------------------------------! + REAL :: BEXP(NSOIL) !B parameter + REAL :: SMCDRY(NSOIL) !dry soil moisture threshold where direct evap from top + !layer ends (volumetric) (not used MB: 20140718) + REAL :: SMCWLT(NSOIL) !wilting point soil moisture (volumetric) + REAL :: SMCREF(NSOIL) !reference soil moisture (field capacity) (volumetric) + REAL :: SMCMAX(NSOIL) !porosity, saturated value of soil moisture (volumetric) + REAL :: PSISAT(NSOIL) !saturated soil matric potential + REAL :: DKSAT(NSOIL) !saturated soil hydraulic conductivity + REAL :: DWSAT(NSOIL) !saturated soil hydraulic diffusivity + REAL :: QUARTZ(NSOIL) !soil quartz content + REAL :: F1 !soil thermal diffusivity/conductivity coef (not used MB: 20140718) +!------------------------------------------------------------------------------------------! +! From the GENPARM.TBL file +!------------------------------------------------------------------------------------------! + REAL :: SLOPE !slope index (0 - 1) + REAL :: CSOIL !vol. soil heat capacity [j/m3/K] + REAL :: ZBOT !Depth (m) of lower boundary soil temperature + REAL :: CZIL !Calculate roughness length of heat + REAL :: REFDK + REAL :: REFKDT -MODULE NOAHMP_VEG_PARAMETERS + REAL :: KDT !used in compute maximum infiltration rate (in INFIL) + REAL :: FRZX !used in compute maximum infiltration rate (in INFIL) - IMPLICIT NONE + END TYPE noahmp_parameters - INTEGER, PRIVATE, PARAMETER :: MVT = 27 - INTEGER, PRIVATE, PARAMETER :: MBAND = 2 +contains +! +!== begin noahmp_sflx ============================================================================== - INTEGER :: ISURBAN_TABLE - INTEGER :: ISWATER_TABLE - INTEGER :: ISBARREN_TABLE - INTEGER :: ISICE_TABLE - INTEGER :: EBLFOREST_TABLE + SUBROUTINE NOAHMP_SFLX (parameters, & + ILOC , JLOC , LAT , YEARLEN , JULIAN , COSZ , & ! IN : Time/Space-related + DT , DX , DZ8W , NSOIL , ZSOIL , NSNOW , & ! IN : Model configuration + SHDFAC , SHDMAX , VEGTYP , ICE , IST , & ! IN : Vegetation/Soil characteristics + SMCEQ , & ! IN : Vegetation/Soil characteristics + SFCTMP , SFCPRS , PSFC , UU , VV , Q2 , & ! IN : Forcing + QC , SOLDN , LWDN , & ! IN : Forcing + PRCPCONV, PRCPNONC, PRCPSHCV, PRCPSNOW, PRCPGRPL, PRCPHAIL, & ! IN : Forcing + TBOT , CO2AIR , O2AIR , FOLN , FICEOLD , ZLVL , & ! IN : Forcing + ALBOLD , SNEQVO , & ! IN/OUT : + STC , SH2O , SMC , TAH , EAH , FWET , & ! IN/OUT : + CANLIQ , CANICE , TV , TG , QSFC , QSNOW , & ! IN/OUT : + ISNOW , ZSNSO , SNOWH , SNEQV , SNICE , SNLIQ , & ! IN/OUT : + ZWT , WA , WT , WSLAKE , LFMASS , RTMASS , & ! IN/OUT : + STMASS , WOOD , STBLCP , FASTCP , LAI , SAI , & ! IN/OUT : + CM , CH , TAUSS , & ! IN/OUT : + GRAIN , GDD , & ! IN/OUT + SMCWTD ,DEEPRECH , RECH , & ! IN/OUT : + Z0WRF , & + FSA , FSR , FIRA , FSH , SSOIL , FCEV , & ! OUT : + FGEV , FCTR , ECAN , ETRAN , EDIR , TRAD , & ! OUT : + TGB , TGV , T2MV , T2MB , Q2V , Q2B , & ! OUT : + RUNSRF , RUNSUB , APAR , PSN , SAV , SAG , & ! OUT : + FSNO , NEE , GPP , NPP , FVEG , ALBEDO , & ! OUT : + QSNBOT , PONDING , PONDING1, PONDING2, RSSUN , RSSHA , & ! OUT : + BGAP , WGAP , CHV , CHB , EMISSI , & ! OUT : + SHG , SHC , SHB , EVG , EVB , GHV , & ! OUT : + GHB , IRG , IRC , IRB , TR , EVC , & ! OUT : + CHLEAF , CHUC , CHV2 , CHB2 , FPICE , PAHV , & + PAHG , PAHB , PAH & +#ifdef WRF_HYDRO + ,SFCHEADRT & ! IN/OUT : +#endif + ) - REAL :: CH2OP_TABLE(MVT) !maximum intercepted h2o per unit lai+sai (mm) - REAL :: DLEAF_TABLE(MVT) !characteristic leaf dimension (m) - REAL :: Z0MVT_TABLE(MVT) !momentum roughness length (m) - REAL :: HVT_TABLE(MVT) !top of canopy (m) - REAL :: HVB_TABLE(MVT) !bottom of canopy (m) - REAL :: DEN_TABLE(MVT) !tree density (no. of trunks per m2) - REAL :: RC_TABLE(MVT) !tree crown radius (m) - REAL :: MFSNO_TABLE(MVT) !snowmelt curve parameter () - REAL :: SAIM_TABLE(MVT,12) !monthly stem area index, one-sided - REAL :: LAIM_TABLE(MVT,12) !monthly leaf area index, one-sided - REAL :: SLA_TABLE(MVT) !single-side leaf area per Kg [m2/kg] - REAL :: DILEFC_TABLE(MVT) !coeficient for leaf stress death [1/s] - REAL :: DILEFW_TABLE(MVT) !coeficient for leaf stress death [1/s] - REAL :: FRAGR_TABLE(MVT) !fraction of growth respiration !original was 0.3 - REAL :: LTOVRC_TABLE(MVT) !leaf turnover [1/s] +! -------------------------------------------------------------------------------------------------- +! Initial code: Guo-Yue Niu, Oct. 2007 +! -------------------------------------------------------------------------------------------------- + implicit none +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), INTENT(IN) :: parameters - REAL :: C3PSN_TABLE(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 - REAL :: KC25_TABLE(MVT) !co2 michaelis-menten constant at 25c (pa) - REAL :: AKC_TABLE(MVT) !q10 for kc25 - REAL :: KO25_TABLE(MVT) !o2 michaelis-menten constant at 25c (pa) - REAL :: AKO_TABLE(MVT) !q10 for ko25 - REAL :: VCMX25_TABLE(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) - REAL :: AVCMX_TABLE(MVT) !q10 for vcmx25 - REAL :: BP_TABLE(MVT) !minimum leaf conductance (umol/m**2/s) - REAL :: MP_TABLE(MVT) !slope of conductance-to-photosynthesis relationship - REAL :: QE25_TABLE(MVT) !quantum efficiency at 25c (umol co2 / umol photon) - REAL :: AQE_TABLE(MVT) !q10 for qe25 - REAL :: RMF25_TABLE(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) - REAL :: RMS25_TABLE(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) - REAL :: RMR25_TABLE(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) - REAL :: ARM_TABLE(MVT) !q10 for maintenance respiration - REAL :: FOLNMX_TABLE(MVT) !foliage nitrogen concentration when f(n)=1 (%) - REAL :: TMIN_TABLE(MVT) !minimum temperature for photosynthesis (k) + INTEGER , INTENT(IN) :: ICE !ice (ice = 1) + INTEGER , INTENT(IN) :: IST !surface type 1->soil; 2->lake + INTEGER , INTENT(IN) :: VEGTYP !vegetation type + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !no. of soil layers + INTEGER , INTENT(IN) :: ILOC !grid index + INTEGER , INTENT(IN) :: JLOC !grid index + REAL , INTENT(IN) :: DT !time step [sec] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) + REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) lowest model layer + REAL , INTENT(IN) :: SFCTMP !surface air temperature [K] + REAL , INTENT(IN) :: UU !wind speed in eastward dir (m/s) + REAL , INTENT(IN) :: VV !wind speed in northward dir (m/s) + REAL , INTENT(IN) :: SOLDN !downward shortwave radiation (w/m2) + REAL , INTENT(IN) :: LWDN !downward longwave radiation (w/m2) + REAL , INTENT(IN) :: SFCPRS !pressure (pa) + REAL , INTENT(INOUT) :: ZLVL !reference height (m) + REAL , INTENT(IN) :: COSZ !cosine solar zenith angle [0-1] + REAL , INTENT(IN) :: TBOT !bottom condition for soil temp. [K] + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) [1-saturated] + REAL , INTENT(IN) :: SHDFAC !green vegetation fraction [0.0-1.0] + INTEGER , INTENT(IN) :: YEARLEN!Number of days in the particular year. + REAL , INTENT(IN) :: JULIAN !Julian day of year (floating point) + REAL , INTENT(IN) :: LAT !latitude (radians) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD!ice fraction at last timestep + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] + REAL , INTENT(IN) :: PRCPCONV ! convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPNONC ! non-convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSHCV ! shallow convective precip entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSNOW ! snow entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPGRPL ! graupel entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPHAIL ! hail entering land model [mm/s] ! MB/AN : v3.7 - REAL :: XL_TABLE(MVT) !leaf/stem orientation index - REAL :: RHOL_TABLE(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir - REAL :: RHOS_TABLE(MVT,MBAND) !stem reflectance: 1=vis, 2=nir - REAL :: TAUL_TABLE(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir - REAL :: TAUS_TABLE(MVT,MBAND) !stem transmittance: 1=vis, 2=nir +!jref:start; in + REAL , INTENT(IN) :: QC !cloud water mixing ratio + REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer + REAL , INTENT(IN) :: PSFC !pressure at lowest model layer + REAL , INTENT(IN) :: DZ8W !thickness of lowest layer + REAL , INTENT(IN) :: DX + REAL , INTENT(IN) :: SHDMAX !yearly max vegetation fraction +!jref:end - REAL :: MRP_TABLE(MVT) !microbial respiration parameter (umol co2 /kg c/ s) - REAL :: CWPVT_TABLE(MVT) !empirical canopy wind parameter +#ifdef WRF_HYDRO + REAL , INTENT(INOUT) :: sfcheadrt +#endif - REAL :: WRRAT_TABLE(MVT) !wood to non-wood ratio - REAL :: WDPOOL_TABLE(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] - REAL :: TDLEF_TABLE(MVT) !characteristic T for leaf freezing [K] +! input/output : need arbitary intial values + REAL , INTENT(INOUT) :: QSNOW !snowfall [mm/s] + REAL , INTENT(INOUT) :: FWET !wetted or snowed fraction of canopy (-) + REAL , INTENT(INOUT) :: SNEQVO !snow mass at last time step (mm) + REAL , INTENT(INOUT) :: EAH !canopy air vapor pressure (pa) + REAL , INTENT(INOUT) :: TAH !canopy air tmeperature (k) + REAL , INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL , INTENT(INOUT) :: CM !momentum drag coefficient + REAL , INTENT(INOUT) :: CH !sensible heat exchange coefficient + REAL , INTENT(INOUT) :: TAUSS !non-dimensional snow age - REAL :: NROOT_TABLE(MVT) !number of soil layers with root present - REAL :: RGL_TABLE(MVT) !Parameter used in radiation stress function - REAL :: RS_TABLE(MVT) !Minimum stomatal resistance [s m-1] - REAL :: HS_TABLE(MVT) !Parameter used in vapor pressure deficit function - REAL :: TOPT_TABLE(MVT) !Optimum transpiration air temperature [K] - REAL :: RSMAX_TABLE(MVT) !Maximal stomatal resistance [s m-1] - - INTEGER, PRIVATE :: ISURBAN - INTEGER, PRIVATE :: ISWATER - INTEGER, PRIVATE :: ISBARREN - INTEGER, PRIVATE :: ISICE - INTEGER, PRIVATE :: EBLFOREST - - REAL, DIMENSION(MVT), PRIVATE :: SAI_JAN,SAI_FEB,SAI_MAR,SAI_APR,SAI_MAY,SAI_JUN, & - SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC - REAL, DIMENSION(MVT), PRIVATE :: LAI_JAN,LAI_FEB,LAI_MAR,LAI_APR,LAI_MAY,LAI_JUN, & - LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC - REAL, DIMENSION(MVT), PRIVATE :: RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, & - TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR - REAL, DIMENSION(MVT), PRIVATE :: CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, & - AVCMX, AQE, LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , & - BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & - SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 - -CONTAINS - - subroutine read_mp_veg_parameters(DATASET_IDENTIFIER) - implicit none - character(len=*), intent(in) :: DATASET_IDENTIFIER - integer :: ierr - INTEGER :: IK,IM - - integer :: NVEG - character(len=256) :: VEG_DATASET_DESCRIPTION - - NAMELIST / noah_mp_usgs_veg_categories / VEG_DATASET_DESCRIPTION, NVEG - NAMELIST / noah_mp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, EBLFOREST, & - CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & - LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, & - FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & - SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN,SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC, & - LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN,LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC, & - RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR, SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 - - NAMELIST / noah_mp_modis_veg_categories / VEG_DATASET_DESCRIPTION, NVEG - NAMELIST / noah_mp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, EBLFOREST, & - CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & - LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, & - FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & - SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN,SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC, & - LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN,LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC, & - RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR, SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 - - ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. - CH2OP_TABLE = -1.E36 - DLEAF_TABLE = -1.E36 - Z0MVT_TABLE = -1.E36 - HVT_TABLE = -1.E36 - HVB_TABLE = -1.E36 - DEN_TABLE = -1.E36 - RC_TABLE = -1.E36 - MFSNO_TABLE = -1.E36 - RHOL_TABLE = -1.E36 - RHOS_TABLE = -1.E36 - TAUL_TABLE = -1.E36 - TAUS_TABLE = -1.E36 - XL_TABLE = -1.E36 - CWPVT_TABLE = -1.E36 - C3PSN_TABLE = -1.E36 - KC25_TABLE = -1.E36 - AKC_TABLE = -1.E36 - KO25_TABLE = -1.E36 - AKO_TABLE = -1.E36 - AVCMX_TABLE = -1.E36 - AQE_TABLE = -1.E36 - LTOVRC_TABLE = -1.E36 - DILEFC_TABLE = -1.E36 - DILEFW_TABLE = -1.E36 - RMF25_TABLE = -1.E36 - SLA_TABLE = -1.E36 - FRAGR_TABLE = -1.E36 - TMIN_TABLE = -1.E36 - VCMX25_TABLE = -1.E36 - TDLEF_TABLE = -1.E36 - BP_TABLE = -1.E36 - MP_TABLE = -1.E36 - QE25_TABLE = -1.E36 - RMS25_TABLE = -1.E36 - RMR25_TABLE = -1.E36 - ARM_TABLE = -1.E36 - FOLNMX_TABLE = -1.E36 - WDPOOL_TABLE = -1.E36 - WRRAT_TABLE = -1.E36 - MRP_TABLE = -1.E36 - SAIM_TABLE = -1.E36 - LAIM_TABLE = -1.E36 - NROOT_TABLE = -1.E36 - RGL_TABLE = -1.E36 - RS_TABLE = -1.E36 - HS_TABLE = -1.E36 - TOPT_TABLE = -1.E36 - RSMAX_TABLE = -1.E36 - ISURBAN_TABLE = -99999 - ISWATER_TABLE = -99999 - ISBARREN_TABLE = -99999 - ISICE_TABLE = -99999 - EBLFOREST_TABLE = -99999 - - open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) - if (ierr /= 0) then - write(*,'("****** Error ******************************************************")') - write(*,'("Cannot find file MPTABLE.TBL")') - write(*,'("STOP")') - write(*,'("*******************************************************************")') - call wrf_error_fatal("STOP in Noah-MP read_mp_veg_parameters") - endif - - if ( trim(DATASET_IDENTIFIER) == "USGS" ) then - read(15,noah_mp_usgs_veg_categories) - read(15,noah_mp_usgs_parameters) - else if ( trim(DATASET_IDENTIFIER) == "MODIFIED_IGBP_MODIS_NOAH" ) then - read(15,noah_mp_modis_veg_categories) - read(15,noah_mp_modis_parameters) - else - write(*,'("Unrecognized DATASET_IDENTIFIER in subroutine READ_MP_VEG_PARAMETERS")') - write(*,'("DATASET_IDENTIFIER = ''", A, "''")') trim(DATASET_IDENTIFIER) - call wrf_error_fatal("STOP in Noah-MP read_mp_veg_parameters") - endif - close(15) - - ISURBAN_TABLE = ISURBAN - ISWATER_TABLE = ISWATER - ISBARREN_TABLE = ISBARREN - ISICE_TABLE = ISICE - EBLFOREST_TABLE = EBLFOREST - - CH2OP_TABLE(1:NVEG) = CH2OP(1:NVEG) - DLEAF_TABLE(1:NVEG) = DLEAF(1:NVEG) - Z0MVT_TABLE(1:NVEG) = Z0MVT(1:NVEG) - HVT_TABLE(1:NVEG) = HVT(1:NVEG) - HVB_TABLE(1:NVEG) = HVB(1:NVEG) - DEN_TABLE(1:NVEG) = DEN(1:NVEG) - RC_TABLE(1:NVEG) = RC(1:NVEG) - MFSNO_TABLE(1:NVEG) = MFSNO(1:NVEG) - XL_TABLE(1:NVEG) = XL(1:NVEG) - CWPVT_TABLE(1:NVEG) = CWPVT(1:NVEG) - C3PSN_TABLE(1:NVEG) = C3PSN(1:NVEG) - KC25_TABLE(1:NVEG) = KC25(1:NVEG) - AKC_TABLE(1:NVEG) = AKC(1:NVEG) - KO25_TABLE(1:NVEG) = KO25(1:NVEG) - AKO_TABLE(1:NVEG) = AKO(1:NVEG) - AVCMX_TABLE(1:NVEG) = AVCMX(1:NVEG) - AQE_TABLE(1:NVEG) = AQE(1:NVEG) - LTOVRC_TABLE(1:NVEG) = LTOVRC(1:NVEG) - DILEFC_TABLE(1:NVEG) = DILEFC(1:NVEG) - DILEFW_TABLE(1:NVEG) = DILEFW(1:NVEG) - RMF25_TABLE(1:NVEG) = RMF25(1:NVEG) - SLA_TABLE(1:NVEG) = SLA(1:NVEG) - FRAGR_TABLE(1:NVEG) = FRAGR(1:NVEG) - TMIN_TABLE(1:NVEG) = TMIN(1:NVEG) - VCMX25_TABLE(1:NVEG) = VCMX25(1:NVEG) - TDLEF_TABLE(1:NVEG) = TDLEF(1:NVEG) - BP_TABLE(1:NVEG) = BP(1:NVEG) - MP_TABLE(1:NVEG) = MP(1:NVEG) - QE25_TABLE(1:NVEG) = QE25(1:NVEG) - RMS25_TABLE(1:NVEG) = RMS25(1:NVEG) - RMR25_TABLE(1:NVEG) = RMR25(1:NVEG) - ARM_TABLE(1:NVEG) = ARM(1:NVEG) - FOLNMX_TABLE(1:NVEG) = FOLNMX(1:NVEG) - WDPOOL_TABLE(1:NVEG) = WDPOOL(1:NVEG) - WRRAT_TABLE(1:NVEG) = WRRAT(1:NVEG) - MRP_TABLE(1:NVEG) = MRP(1:NVEG) - NROOT_TABLE(1:NVEG) = NROOT(1:NVEG) - RGL_TABLE(1:NVEG) = RGL(1:NVEG) - RS_TABLE(1:NVEG) = RS(1:NVEG) - HS_TABLE(1:NVEG) = HS(1:NVEG) - TOPT_TABLE(1:NVEG) = TOPT(1:NVEG) - RSMAX_TABLE(1:NVEG) = RSMAX(1:NVEG) - - ! Put LAI and SAI into 2d array from monthly lines in table; same for canopy radiation properties - - SAIM_TABLE(1:NVEG, 1) = SAI_JAN(1:NVEG) - SAIM_TABLE(1:NVEG, 2) = SAI_FEB(1:NVEG) - SAIM_TABLE(1:NVEG, 3) = SAI_MAR(1:NVEG) - SAIM_TABLE(1:NVEG, 4) = SAI_APR(1:NVEG) - SAIM_TABLE(1:NVEG, 5) = SAI_MAY(1:NVEG) - SAIM_TABLE(1:NVEG, 6) = SAI_JUN(1:NVEG) - SAIM_TABLE(1:NVEG, 7) = SAI_JUL(1:NVEG) - SAIM_TABLE(1:NVEG, 8) = SAI_AUG(1:NVEG) - SAIM_TABLE(1:NVEG, 9) = SAI_SEP(1:NVEG) - SAIM_TABLE(1:NVEG,10) = SAI_OCT(1:NVEG) - SAIM_TABLE(1:NVEG,11) = SAI_NOV(1:NVEG) - SAIM_TABLE(1:NVEG,12) = SAI_DEC(1:NVEG) - - LAIM_TABLE(1:NVEG, 1) = LAI_JAN(1:NVEG) - LAIM_TABLE(1:NVEG, 2) = LAI_FEB(1:NVEG) - LAIM_TABLE(1:NVEG, 3) = LAI_MAR(1:NVEG) - LAIM_TABLE(1:NVEG, 4) = LAI_APR(1:NVEG) - LAIM_TABLE(1:NVEG, 5) = LAI_MAY(1:NVEG) - LAIM_TABLE(1:NVEG, 6) = LAI_JUN(1:NVEG) - LAIM_TABLE(1:NVEG, 7) = LAI_JUL(1:NVEG) - LAIM_TABLE(1:NVEG, 8) = LAI_AUG(1:NVEG) - LAIM_TABLE(1:NVEG, 9) = LAI_SEP(1:NVEG) - LAIM_TABLE(1:NVEG,10) = LAI_OCT(1:NVEG) - LAIM_TABLE(1:NVEG,11) = LAI_NOV(1:NVEG) - LAIM_TABLE(1:NVEG,12) = LAI_DEC(1:NVEG) - - RHOL_TABLE(1:NVEG,1) = RHOL_VIS(1:NVEG) !leaf reflectance: 1=vis, 2=nir - RHOL_TABLE(1:NVEG,2) = RHOL_NIR(1:NVEG) !leaf reflectance: 1=vis, 2=nir - RHOS_TABLE(1:NVEG,1) = RHOS_VIS(1:NVEG) !stem reflectance: 1=vis, 2=nir - RHOS_TABLE(1:NVEG,2) = RHOS_NIR(1:NVEG) !stem reflectance: 1=vis, 2=nir - TAUL_TABLE(1:NVEG,1) = TAUL_VIS(1:NVEG) !leaf transmittance: 1=vis, 2=nir - TAUL_TABLE(1:NVEG,2) = TAUL_NIR(1:NVEG) !leaf transmittance: 1=vis, 2=nir - TAUS_TABLE(1:NVEG,1) = TAUS_VIS(1:NVEG) !stem transmittance: 1=vis, 2=nir - TAUS_TABLE(1:NVEG,2) = TAUS_NIR(1:NVEG) !stem transmittance: 1=vis, 2=nir - - end subroutine read_mp_veg_parameters - -END MODULE NOAHMP_VEG_PARAMETERS - -! ================================================================================================== - -MODULE NOAHMP_SOIL_PARAMETERS - - IMPLICIT NONE - - INTEGER, PARAMETER :: MAX_SOILTYP = 30 +! prognostic variables + INTEGER , INTENT(INOUT) :: ISNOW !actual no. of snow layers [-] + REAL , INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) + REAL , INTENT(INOUT) :: CANICE !intercepted ice mass (mm) + REAL , INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !layer-bottom depth from snow surf [m] + REAL , INTENT(INOUT) :: SNOWH !snow height [m] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL , INTENT(INOUT) :: TV !vegetation temperature (k) + REAL , INTENT(INOUT) :: TG !ground temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil temperature [k] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !liquid soil moisture [m3/m3] + REAL , INTENT(INOUT) :: ZWT !depth to water table [m] + REAL , INTENT(INOUT) :: WA !water storage in aquifer [mm] + REAL , INTENT(INOUT) :: WT !water in aquifer&saturated soil [mm] + REAL , INTENT(INOUT) :: WSLAKE !lake water storage (can be neg.) (mm) + REAL, INTENT(INOUT) :: SMCWTD !soil water content between bottom of the soil and water table [m3/m3] + REAL, INTENT(INOUT) :: DEEPRECH !recharge to or from the water table when deep [m] + REAL, INTENT(INOUT) :: RECH !recharge to or from the water table when shallow [m] (diagnostic) - INTEGER :: SLCATS +! output + REAL , INTENT(OUT) :: Z0WRF !combined z0 sent to coupled model + REAL , INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL , INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL , INTENT(OUT) :: FIRA !total net LW rad (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FSH !total sensible heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FCEV !canopy evap heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FGEV !ground evap heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FCTR !transpiration heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: SSOIL !ground heat flux (w/m2) [+ to soil] + REAL , INTENT(OUT) :: TRAD !surface radiative temperature (k) + REAL :: TS !surface temperature (k) + REAL , INTENT(OUT) :: ECAN !evaporation of intercepted water (mm/s) + REAL , INTENT(OUT) :: ETRAN !transpiration rate (mm/s) + REAL , INTENT(OUT) :: EDIR !soil surface evaporation rate (mm/s] + REAL , INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL , INTENT(OUT) :: RUNSUB !baseflow (saturation excess) [mm/s] + REAL , INTENT(OUT) :: PSN !total photosynthesis (umol co2/m2/s) [+] + REAL , INTENT(OUT) :: APAR !photosyn active energy by canopy (w/m2) + REAL , INTENT(OUT) :: SAV !solar rad absorbed by veg. (w/m2) + REAL , INTENT(OUT) :: SAG !solar rad absorbed by ground (w/m2) + REAL , INTENT(OUT) :: FSNO !snow cover fraction on the ground (-) + REAL , INTENT(OUT) :: FVEG !green vegetation fraction [0.0-1.0] + REAL , INTENT(OUT) :: ALBEDO !surface albedo [-] + REAL :: ERRWAT !water error [kg m{-2}] + REAL , INTENT(OUT) :: QSNBOT !snowmelt out bottom of pack [mm/s] + REAL , INTENT(OUT) :: PONDING!surface ponding [mm] + REAL , INTENT(OUT) :: PONDING1!surface ponding [mm] + REAL , INTENT(OUT) :: PONDING2!surface ponding [mm] - REAL :: BEXP_TABLE(MAX_SOILTYP) !maximum intercepted h2o per unit lai+sai (mm) - REAL :: SMCDRY_TABLE(MAX_SOILTYP) !characteristic leaf dimension (m) - REAL :: F1_TABLE(MAX_SOILTYP) !momentum roughness length (m) - REAL :: SMCMAX_TABLE(MAX_SOILTYP) !top of canopy (m) - REAL :: SMCREF_TABLE(MAX_SOILTYP) !bottom of canopy (m) - REAL :: PSISAT_TABLE(MAX_SOILTYP) !tree density (no. of trunks per m2) - REAL :: DKSAT_TABLE(MAX_SOILTYP) !tree crown radius (m) - REAL :: DWSAT_TABLE(MAX_SOILTYP) !monthly stem area index, one-sided - REAL :: SMCWLT_TABLE(MAX_SOILTYP) !monthly leaf area index, one-sided - REAL :: QUARTZ_TABLE(MAX_SOILTYP) !single-side leaf area per Kg [m2/kg] +!jref:start; output + REAL , INTENT(OUT) :: T2MV !2-m air temperature over vegetated part [k] + REAL , INTENT(OUT) :: T2MB !2-m air temperature over bare ground part [k] + REAL, INTENT(OUT) :: RSSUN !sunlit leaf stomatal resistance (s/m) + REAL, INTENT(OUT) :: RSSHA !shaded leaf stomatal resistance (s/m) + REAL, INTENT(OUT) :: BGAP + REAL, INTENT(OUT) :: WGAP + REAL, INTENT(OUT) :: TGV + REAL, INTENT(OUT) :: TGB + REAL :: Q1 + REAL, INTENT(OUT) :: EMISSI +!jref:end - REAL :: SLOPE_TABLE(9) !slope factor for soil drainage - - REAL :: CSOIL_TABLE !Soil heat capacity [J m-3 K-1] - REAL :: REFDK_TABLE !Parameter in the surface runoff parameterization - REAL :: REFKDT_TABLE !Parameter in the surface runoff parameterization - REAL :: FRZK_TABLE !Frozen ground parameter - REAL :: ZBOT_TABLE !Depth [m] of lower boundary soil temperature - REAL :: CZIL_TABLE !Parameter used in the calculation of the roughness length for heat +! local + INTEGER :: IZ !do-loop index + INTEGER, DIMENSION(-NSNOW+1:NSOIL) :: IMELT !phase change index [1-melt; 2-freeze] + REAL :: CMC !intercepted water (CANICE+CANLIQ) (mm) + REAL :: TAUX !wind stress: e-w (n/m2) + REAL :: TAUY !wind stress: n-s (n/m2) + REAL :: RHOAIR !density air (kg/m3) +! REAL, DIMENSION( 1: 5) :: VOCFLX !voc fluxes [ug C m-2 h-1] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DZSNSO !snow/soil layer thickness [m] + REAL :: THAIR !potential temperature (k) + REAL :: QAIR !specific humidity (kg/kg) (q2/(1+q2)) + REAL :: EAIR !vapor pressure air (pa) + REAL, DIMENSION( 1: 2) :: SOLAD !incoming direct solar rad (w/m2) + REAL, DIMENSION( 1: 2) :: SOLAI !incoming diffuse solar rad (w/m2) + REAL :: QPRECC !convective precipitation (mm/s) + REAL :: QPRECL !large-scale precipitation (mm/s) + REAL :: IGS !growing season index (0=off, 1=on) + REAL :: ELAI !leaf area index, after burying by snow + REAL :: ESAI !stem area index, after burying by snow + REAL :: BEVAP !soil water evaporation factor (0 - 1) + REAL, DIMENSION( 1:NSOIL) :: BTRANI !Soil water transpiration factor (0 - 1) + REAL :: BTRAN !soil water transpiration factor (0 - 1) + REAL :: QIN !groundwater recharge [mm/s] + REAL :: QDIS !groundwater discharge [mm/s] + REAL, DIMENSION( 1:NSOIL) :: SICE !soil ice content (m3/m3) + REAL, DIMENSION(-NSNOW+1: 0) :: SNICEV !partial volume ice of snow [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0) :: SNLIQV !partial volume liq of snow [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0) :: EPORE !effective porosity [m3/m3] + REAL :: TOTSC !total soil carbon (g/m2) + REAL :: TOTLB !total living carbon (g/m2) + REAL :: T2M !2-meter air temperature (k) + REAL :: QDEW !ground surface dew rate [mm/s] + REAL :: QVAP !ground surface evap. rate [mm/s] + REAL :: LATHEA !latent heat [j/kg] + REAL :: SWDOWN !downward solar [w/m2] + REAL :: QMELT !snowmelt [mm/s] + REAL :: BEG_WB !water storage at begin of a step [mm] + REAL,INTENT(OUT) :: IRC !canopy net LW rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: IRG !ground net LW rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHC !canopy sen. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHG !ground sen. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: EVG !ground evap. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: GHV !ground heat flux [w/m2] [+ to soil] + REAL,INTENT(OUT) :: IRB !net longwave rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHB !sensible heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: EVB !evaporation heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: GHB !ground heat flux [w/m2] [+ to soil] + REAL,INTENT(OUT) :: EVC !canopy evap. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: TR !transpiration heat [w/m2] [+ to atm] + REAL, INTENT(OUT) :: FPICE !snow fraction in precipitation + REAL, INTENT(OUT) :: PAHV !precipitation advected heat - vegetation net (W/m2) + REAL, INTENT(OUT) :: PAHG !precipitation advected heat - under canopy net (W/m2) + REAL, INTENT(OUT) :: PAHB !precipitation advected heat - bare ground net (W/m2) + REAL, INTENT(OUT) :: PAH !precipitation advected heat - total (W/m2) -CONTAINS +!jref:start + REAL :: FSRV + REAL :: FSRG + REAL,INTENT(OUT) :: Q2V + REAL,INTENT(OUT) :: Q2B + REAL :: Q2E + REAL :: QFX + REAL,INTENT(OUT) :: CHV !sensible heat exchange coefficient over vegetated fraction + REAL,INTENT(OUT) :: CHB !sensible heat exchange coefficient over bare-ground + REAL,INTENT(OUT) :: CHLEAF !leaf exchange coefficient + REAL,INTENT(OUT) :: CHUC !under canopy exchange coefficient + REAL,INTENT(OUT) :: CHV2 !sensible heat exchange coefficient over vegetated fraction + REAL,INTENT(OUT) :: CHB2 !sensible heat exchange coefficient over bare-ground +!jref:end - subroutine read_mp_soil_parameters() - IMPLICIT NONE - INTEGER :: IERR - CHARACTER*4 :: SLTYPE - INTEGER :: ITMP, NUM_SLOPE, LC - CHARACTER(len=256) :: message - +! carbon +! inputs + REAL , INTENT(IN) :: CO2AIR !atmospheric co2 concentration (pa) + REAL , INTENT(IN) :: O2AIR !atmospheric o2 concentration (pa) - ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. - BEXP_TABLE = -1.E36 - SMCDRY_TABLE = -1.E36 - F1_TABLE = -1.E36 - SMCMAX_TABLE = -1.E36 - SMCREF_TABLE = -1.E36 - PSISAT_TABLE = -1.E36 - DKSAT_TABLE = -1.E36 - DWSAT_TABLE = -1.E36 - SMCWLT_TABLE = -1.E36 - QUARTZ_TABLE = -1.E36 - SLOPE_TABLE = -1.E36 - CSOIL_TABLE = -1.E36 - REFDK_TABLE = -1.E36 - REFKDT_TABLE = -1.E36 - FRZK_TABLE = -1.E36 - ZBOT_TABLE = -1.E36 - CZIL_TABLE = -1.E36 +! inputs and outputs : prognostic variables + REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] + REAL , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2] + REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] + REAL , INTENT(INOUT) :: WOOD !mass of wood (incl. woody roots) [g/m2] + REAL , INTENT(INOUT) :: STBLCP !stable carbon in deep soil [g/m2] + REAL , INTENT(INOUT) :: FASTCP !short-lived carbon, shallow soil [g/m2] + REAL , INTENT(INOUT) :: LAI !leaf area index [-] + REAL , INTENT(INOUT) :: SAI !stem area index [-] + REAL , INTENT(INOUT) :: GRAIN !grain mass [g/m2] + REAL , INTENT(INOUT) :: GDD !growing degree days -! -!-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL -! - OPEN(19, FILE='SOILPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) - IF(ierr .NE. 0 ) THEN - WRITE(message,FMT='(A)') 'module_sf_noahmpdrv.F: read_mp_soil_parameters: failure opening SOILPARM.TBL' - CALL wrf_error_fatal ( message ) - END IF +! outputs + REAL , INTENT(OUT) :: NEE !net ecosys exchange (g/m2/s CO2) + REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s C] + REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2/s C] + REAL :: AUTORS !net ecosystem respiration (g/m2/s C) + REAL :: HETERS !organic respiration (g/m2/s C) + REAL :: TROOT !root-zone averaged temperature (k) + REAL :: BDFALL !bulk density of new snow (kg/m3) ! MB/AN: v3.7 + REAL :: RAIN !rain rate (mm/s) ! MB/AN: v3.7 + REAL :: SNOW !liquid equivalent snow rate (mm/s) ! MB/AN: v3.7 + REAL :: FP ! MB/AN: v3.7 + REAL :: PRCP ! MB/AN: v3.7 +!more local variables for precip heat MB + REAL :: QINTR !interception rate for rain (mm/s) + REAL :: QDRIPR !drip rate for rain (mm/s) + REAL :: QTHROR !throughfall for rain (mm/s) + REAL :: QINTS !interception (loading) rate for snowfall (mm/s) + REAL :: QDRIPS !drip (unloading) rate for intercepted snow (mm/s) + REAL :: QTHROS !throughfall of snowfall (mm/s) + REAL :: QRAIN !rain at ground srf (mm/s) [+] + REAL :: SNOWHIN !snow depth increasing rate (m/s) + REAL :: LATHEAV !latent heat vap./sublimation (j/kg) + REAL :: LATHEAG !latent heat vap./sublimation (j/kg) + LOGICAL :: FROZEN_GROUND ! used to define latent heat pathway + LOGICAL :: FROZEN_CANOPY ! used to define latent heat pathway + + ! INTENT (OUT) variables need to be assigned a value. These normally get assigned values + ! only if DVEG == 2. + nee = 0.0 + npp = 0.0 + gpp = 0.0 + PAHV = 0. + PAHG = 0. + PAHB = 0. + PAH = 0. - READ (19,*) - READ (19,*) SLTYPE - READ (19,*) SLCATS - WRITE( message , * ) 'SOIL TEXTURE CLASSIFICATION = ', TRIM ( SLTYPE ) , ' FOUND', & - SLCATS,' CATEGORIES' - CALL wrf_message ( message ) +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing - DO LC=1,SLCATS - READ (19,*) ITMP,BEXP_TABLE(LC),SMCDRY_TABLE(LC),F1_TABLE(LC),SMCMAX_TABLE(LC), & - SMCREF_TABLE(LC),PSISAT_TABLE(LC),DKSAT_TABLE(LC), DWSAT_TABLE(LC), & - SMCWLT_TABLE(LC), QUARTZ_TABLE(LC) - ENDDO + CALL ATM (parameters,SFCPRS ,SFCTMP ,Q2 , & + PRCPCONV, PRCPNONC,PRCPSHCV,PRCPSNOW,PRCPGRPL,PRCPHAIL, & + SOLDN ,COSZ ,THAIR ,QAIR , & + EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD ,SOLAI , & + SWDOWN ,BDFALL ,RAIN ,SNOW ,FP ,FPICE , PRCP ) - CLOSE (19) +! snow/soil layer thickness (m) -! -!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL -! - OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) - IF(ierr .NE. 0 ) THEN - WRITE(message,FMT='(A)') 'module_sf_noahlsm.F: read_mp_soil_parameters: failure opening GENPARM.TBL' - CALL wrf_error_fatal ( message ) - END IF + DO IZ = ISNOW+1, NSOIL + IF(IZ == ISNOW+1) THEN + DZSNSO(IZ) = - ZSNSO(IZ) + ELSE + DZSNSO(IZ) = ZSNSO(IZ-1) - ZSNSO(IZ) + END IF + END DO - READ (19,*) - READ (19,*) - READ (19,*) NUM_SLOPE +! root-zone temperature - DO LC=1,NUM_SLOPE - READ (19,*) SLOPE_TABLE(LC) - ENDDO + TROOT = 0. + DO IZ=1,parameters%NROOT + TROOT = TROOT + STC(IZ)*DZSNSO(IZ)/(-ZSOIL(parameters%NROOT)) + ENDDO - READ (19,*) - READ (19,*) - READ (19,*) - READ (19,*) - READ (19,*) - READ (19,*) CSOIL_TABLE - READ (19,*) - READ (19,*) - READ (19,*) - READ (19,*) REFDK_TABLE - READ (19,*) - READ (19,*) REFKDT_TABLE - READ (19,*) - READ (19,*) FRZK_TABLE - READ (19,*) - READ (19,*) ZBOT_TABLE - READ (19,*) - READ (19,*) CZIL_TABLE - READ (19,*) - READ (19,*) - READ (19,*) - READ (19,*) +! total water storage for water balance check + + IF(IST == 1) THEN + BEG_WB = CANLIQ + CANICE + SNEQV + WA + DO IZ = 1,NSOIL + BEG_WB = BEG_WB + SMC(IZ) * DZSNSO(IZ) * 1000. + END DO + END IF - CLOSE (19) +! vegetation phenology - end subroutine read_mp_soil_parameters + CALL PHENOLOGY (parameters,VEGTYP , SNOWH , TV , LAT , YEARLEN , JULIAN , & !in + LAI , SAI , TROOT , ELAI , ESAI ,IGS) -END MODULE NOAHMP_SOIL_PARAMETERS +!input GVF should be consistent with LAI + IF(DVEG == 1 .or. DVEG == 6 .or. DVEG == 7) THEN + FVEG = SHDFAC + IF(FVEG <= 0.05) FVEG = 0.05 + ELSE IF (DVEG == 2 .or. DVEG == 3 .or. DVEG == 8) THEN + FVEG = 1.-EXP(-0.52*(LAI+SAI)) + IF(FVEG <= 0.05) FVEG = 0.05 + ELSE IF (DVEG == 4 .or. DVEG == 5 .or. DVEG == 9 .or. DVEG == 10) THEN + FVEG = SHDMAX + IF(FVEG <= 0.05) FVEG = 0.05 + ELSE + WRITE(*,*) "-------- FATAL CALLED IN SFLX -----------" + CALL wrf_error_fatal("Namelist parameter DVEG unknown") + ENDIF + IF(parameters%urban_flag .OR. VEGTYP == parameters%ISBARREN) FVEG = 0.0 + IF(ELAI+ESAI == 0.0) FVEG = 0.0 -! ================================================================================================== + CALL PRECIP_HEAT(parameters,ILOC ,JLOC ,VEGTYP ,DT ,UU ,VV , & !in + ELAI ,ESAI ,FVEG ,IST , & !in + BDFALL ,RAIN ,SNOW ,FP , & !in + CANLIQ ,CANICE ,TV ,SFCTMP ,TG , & !in + QINTR ,QDRIPR ,QTHROR ,QINTS ,QDRIPS ,QTHROS , & !out + PAHV ,PAHG ,PAHB ,QRAIN ,QSNOW ,SNOWHIN, & !out + FWET ,CMC ) !out -MODULE NOAHMP_RAD_PARAMETERS +! compute energy budget (momentum & energy fluxes and phase changes) - IMPLICIT NONE - - INTEGER, PRIVATE, PARAMETER :: MSC = 8 - INTEGER, PRIVATE, PARAMETER :: MBAND = 2 + CALL ENERGY (parameters,ICE ,VEGTYP ,IST ,NSNOW ,NSOIL , & !in + ISNOW ,DT ,RHOAIR ,SFCPRS ,QAIR , & !in + SFCTMP ,THAIR ,LWDN ,UU ,VV ,ZLVL , & !in + CO2AIR ,O2AIR ,SOLAD ,SOLAI ,COSZ ,IGS , & !in + EAIR ,TBOT ,ZSNSO ,ZSOIL , & !in + ELAI ,ESAI ,FWET ,FOLN , & !in + FVEG ,PAHV ,PAHG ,PAHB , & !in + QSNOW ,DZSNSO ,LAT ,CANLIQ ,CANICE ,iloc, jloc , & !in + Z0WRF , & + IMELT ,SNICEV ,SNLIQV ,EPORE ,T2M ,FSNO , & !out + SAV ,SAG ,QMELT ,FSA ,FSR ,TAUX , & !out + TAUY ,FIRA ,FSH ,FCEV ,FGEV ,FCTR , & !out + TRAD ,PSN ,APAR ,SSOIL ,BTRANI ,BTRAN , & !out + PONDING,TS ,LATHEAV , LATHEAG , frozen_canopy,frozen_ground, & !out + TV ,TG ,STC ,SNOWH ,EAH ,TAH , & !inout + SNEQVO ,SNEQV ,SH2O ,SMC ,SNICE ,SNLIQ , & !inout + ALBOLD ,CM ,CH ,DX ,DZ8W ,Q2 , & !inout + TAUSS , & !inout +!jref:start + QC ,QSFC ,PSFC , & !in + T2MV ,T2MB ,FSRV , & + FSRG ,RSSUN ,RSSHA ,BGAP ,WGAP, TGV,TGB,& + Q1 ,Q2V ,Q2B ,Q2E ,CHV ,CHB , & !out + EMISSI ,PAH , & + SHG,SHC,SHB,EVG,EVB,GHV,GHB,IRG,IRC,IRB,TR,EVC,CHLEAF,CHUC,CHV2,CHB2 ) !out +!jref:end - REAL :: ALBSAT_TABLE(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir - REAL :: ALBDRY_TABLE(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir - REAL :: ALBICE_TABLE(MBAND) !albedo land ice: 1=vis, 2=nir - REAL :: ALBLAK_TABLE(MBAND) !albedo frozen lakes: 1=vis, 2=nir - REAL :: OMEGAS_TABLE(MBAND) !two-stream parameter omega for snow - REAL :: BETADS_TABLE !two-stream parameter betad for snow - REAL :: BETAIS_TABLE !two-stream parameter betad for snow - REAL :: EG_TABLE(2) !emissivity + SICE(:) = MAX(0.0, SMC(:) - SH2O(:)) + SNEQVO = SNEQV - REAL, PRIVATE :: ALBICE(MBAND),ALBLAK(MBAND),OMEGAS(MBAND),BETADS,BETAIS,EG(2) - REAL, PRIVATE :: ALBSAT_VIS(MSC) - REAL, PRIVATE :: ALBSAT_NIR(MSC) - REAL, PRIVATE :: ALBDRY_VIS(MSC) - REAL, PRIVATE :: ALBDRY_NIR(MSC) + QVAP = MAX( FGEV/LATHEAG, 0.) ! positive part of fgev; Barlage change to ground v3.6 + QDEW = ABS( MIN(FGEV/LATHEAG, 0.)) ! negative part of fgev + EDIR = QVAP - QDEW -CONTAINS +! compute water budgets (water storages, ET components, and runoff) + + CALL WATER (parameters,VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in + VV ,FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , & !in + ESAI ,SFCTMP ,QVAP ,QDEW ,ZSOIL ,BTRANI , & !in + FICEOLD,PONDING,TG ,IST ,FVEG ,iloc,jloc , SMCEQ , & !in + BDFALL ,FP ,RAIN ,SNOW , & !in MB/AN: v3.7 + QSNOW ,QRAIN ,SNOWHIN,LATHEAV,LATHEAG,frozen_canopy,frozen_ground, & !in MB + ISNOW ,CANLIQ ,CANICE ,TV ,SNOWH ,SNEQV , & !inout + SNICE ,SNLIQ ,STC ,ZSNSO ,SH2O ,SMC , & !inout + SICE ,ZWT ,WA ,WT ,DZSNSO ,WSLAKE , & !inout + SMCWTD ,DEEPRECH,RECH , & !inout + CMC ,ECAN ,ETRAN ,FWET ,RUNSRF ,RUNSUB , & !out + QIN ,QDIS ,PONDING1 ,PONDING2,& + QSNBOT & +#ifdef WRF_HYDRO + ,sfcheadrt & +#endif + ) !out - subroutine read_mp_rad_parameters() - implicit none - integer :: ierr +! write(*,'(a20,10F15.5)') 'SFLX:RUNOFF=',RUNSRF*DT,RUNSUB*DT,EDIR*DT - NAMELIST / noah_mp_rad_parameters / ALBSAT_VIS,ALBSAT_NIR,ALBDRY_VIS,ALBDRY_NIR,ALBICE,ALBLAK,OMEGAS,BETADS,BETAIS,EG +! compute carbon budgets (carbon storages and co2 & bvoc fluxes) + IF (DVEG == 2 .OR. DVEG == 5 .OR. DVEG == 6) THEN + CALL CARBON (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL , & !in + DZSNSO ,STC ,SMC ,TV ,TG ,PSN , & !in + FOLN ,BTRAN ,APAR ,FVEG ,IGS , & !in + TROOT ,IST ,LAT ,iloc ,jloc , & !in + LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC , & !out + TOTLB ,LAI ,SAI ) !out + END IF - ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. - ALBSAT_TABLE = -1.E36 - ALBDRY_TABLE = -1.E36 - ALBICE_TABLE = -1.E36 - ALBLAK_TABLE = -1.E36 - OMEGAS_TABLE = -1.E36 - BETADS_TABLE = -1.E36 - BETAIS_TABLE = -1.E36 - EG_TABLE = -1.E36 + IF (DVEG == 6) THEN !XING + CALL CARBON_CROP (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL ,JULIAN , & !in + DZSNSO ,STC ,SMC ,TV ,PSN ,FOLN ,BTRAN , & !in + SOLDN ,T2M , & !in + LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP ,GRAIN , & !inout + LAI ,SAI ,GDD , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC ,TOTLB ) !out + END IF + - open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) - if (ierr /= 0) then - write(*,'("****** Error ******************************************************")') - write(*,'("Cannot find file MPTABLE.TBL")') - write(*,'("STOP")') - write(*,'("*******************************************************************")') - call wrf_error_fatal("STOP in Noah-MP read_mp_rad_parameters") - endif +! water and energy balance check - read(15,noah_mp_rad_parameters) - close(15) + CALL ERROR (parameters,SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , & !in + FGEV ,FCTR ,SSOIL ,BEG_WB ,CANLIQ ,CANICE , & !in + SNEQV ,WA ,SMC ,DZSNSO ,PRCP ,ECAN , & !in + ETRAN ,EDIR ,RUNSRF ,RUNSUB ,DT ,NSOIL , & !in + NSNOW ,IST ,ERRWAT ,ILOC , JLOC ,FVEG , & + SAV ,SAG ,FSRV ,FSRG ,ZWT ,PAH , & + PAHV ,PAHG ,PAHB ) !in ( Except ERRWAT, which is out ) - ALBSAT_TABLE(:,1) = ALBSAT_VIS ! saturated soil albedos: 1=vis, 2=nir - ALBSAT_TABLE(:,2) = ALBSAT_NIR ! saturated soil albedos: 1=vis, 2=nir - ALBDRY_TABLE(:,1) = ALBDRY_VIS ! dry soil albedos: 1=vis, 2=nir - ALBDRY_TABLE(:,2) = ALBDRY_NIR ! dry soil albedos: 1=vis, 2=nir - ALBICE_TABLE = ALBICE - ALBLAK_TABLE = ALBLAK - OMEGAS_TABLE = OMEGAS - BETADS_TABLE = BETADS - BETAIS_TABLE = BETAIS - EG_TABLE = EG +! urban - jref + QFX = ETRAN + ECAN + EDIR + IF ( parameters%urban_flag ) THEN + QSFC = (QFX/RHOAIR*CH) + QAIR + Q2B = QSFC + END IF - end subroutine read_mp_rad_parameters + IF(SNOWH <= 1.E-6 .OR. SNEQV <= 1.E-3) THEN + SNOWH = 0.0 + SNEQV = 0.0 + END IF -END MODULE NOAHMP_RAD_PARAMETERS + IF(SWDOWN.NE.0.) THEN + ALBEDO = FSR / SWDOWN + ELSE + ALBEDO = -999.9 + END IF + -! ================================================================================================== + END SUBROUTINE NOAHMP_SFLX -MODULE NOAHMP_PARAMETERS +!== begin atm ====================================================================================== - IMPLICIT NONE - -!------------------------------------------------------------------------------------------! -! Physical Constants: ! -!------------------------------------------------------------------------------------------! + SUBROUTINE ATM (parameters,SFCPRS ,SFCTMP ,Q2 , & + PRCPCONV,PRCPNONC ,PRCPSHCV,PRCPSNOW,PRCPGRPL,PRCPHAIL , & + SOLDN ,COSZ ,THAIR ,QAIR , & + EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD , SOLAI , & + SWDOWN ,BDFALL ,RAIN ,SNOW ,FP , FPICE ,PRCP ) +! -------------------------------------------------------------------------------------------------- +! re-process atmospheric forcing +! ---------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs - REAL, PARAMETER :: GRAV = 9.80616 !acceleration due to gravity (m/s2) - REAL, PARAMETER :: SB = 5.67E-08 !Stefan-Boltzmann constant (w/m2/k4) - REAL, PARAMETER :: VKC = 0.40 !von Karman constant - REAL, PARAMETER :: TFRZ = 273.16 !freezing/melting point (k) - REAL, PARAMETER :: HSUB = 2.8440E06 !latent heat of sublimation (j/kg) - REAL, PARAMETER :: HVAP = 2.5104E06 !latent heat of vaporization (j/kg) - REAL, PARAMETER :: HFUS = 0.3336E06 !latent heat of fusion (j/kg) - REAL, PARAMETER :: CWAT = 4.188E06 !specific heat capacity of water (j/m3/k) - REAL, PARAMETER :: CICE = 2.094E06 !specific heat capacity of ice (j/m3/k) - REAL, PARAMETER :: CPAIR = 1004.64 !heat capacity dry air at const pres (j/kg/k) - REAL, PARAMETER :: TKWAT = 0.6 !thermal conductivity of water (w/m/k) - REAL, PARAMETER :: TKICE = 2.2 !thermal conductivity of ice (w/m/k) - REAL, PARAMETER :: TKAIR = 0.023 !thermal conductivity of air (w/m/k) (not used MB: 20140718) - REAL, PARAMETER :: RAIR = 287.04 !gas constant for dry air (j/kg/k) - REAL, PARAMETER :: RW = 461.269 !gas constant for water vapor (j/kg/k) - REAL, PARAMETER :: DENH2O = 1000. !density of water (kg/m3) - REAL, PARAMETER :: DENICE = 917. !density of ice (kg/m3) + type (noahmp_parameters), intent(in) :: parameters + REAL , INTENT(IN) :: SFCPRS !pressure (pa) + REAL , INTENT(IN) :: SFCTMP !surface air temperature [k] + REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) + REAL , INTENT(IN) :: PRCPCONV ! convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPNONC ! non-convective precipitation entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSHCV ! shallow convective precip entering [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPSNOW ! snow entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPGRPL ! graupel entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: PRCPHAIL ! hail entering land model [mm/s] ! MB/AN : v3.7 + REAL , INTENT(IN) :: SOLDN !downward shortwave radiation (w/m2) + REAL , INTENT(IN) :: COSZ !cosine solar zenith angle [0-1] -! atmospheric constituants +! outputs - REAL, PARAMETER :: CO2 = 395.e-06 !co2 partial pressure - REAL, PARAMETER :: O2 = 0.209 !o2 partial pressure + REAL , INTENT(OUT) :: THAIR !potential temperature (k) + REAL , INTENT(OUT) :: QAIR !specific humidity (kg/kg) (q2/(1+q2)) + REAL , INTENT(OUT) :: EAIR !vapor pressure air (pa) + REAL , INTENT(OUT) :: RHOAIR !density air (kg/m3) + REAL , INTENT(OUT) :: QPRECC !convective precipitation (mm/s) + REAL , INTENT(OUT) :: QPRECL !large-scale precipitation (mm/s) + REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAD !incoming direct solar radiation (w/m2) + REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL , INTENT(OUT) :: SWDOWN !downward solar filtered by sun angle [w/m2] + REAL , INTENT(OUT) :: BDFALL !!bulk density of snowfall (kg/m3) AJN + REAL , INTENT(OUT) :: RAIN !rainfall (mm/s) AJN + REAL , INTENT(OUT) :: SNOW !liquid equivalent snowfall (mm/s) AJN + REAL , INTENT(OUT) :: FP !fraction of area receiving precipitation AJN + REAL , INTENT(OUT) :: FPICE !fraction of ice AJN + REAL , INTENT(OUT) :: PRCP !total precipitation [mm/s] ! MB/AN : v3.7 -! runoff parameters used for SIMTOP and SIMGM: +!locals - REAL, PARAMETER :: TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) - REAL, PARAMETER :: FSATMX = 0.38 !maximum surface saturated fraction (global mean) + REAL :: PAIR !atm bottom level pressure (pa) + REAL :: PRCP_FROZEN !total frozen precipitation [mm/s] ! MB/AN : v3.7 + REAL, PARAMETER :: RHO_GRPL = 500.0 ! graupel bulk density [kg/m3] ! MB/AN : v3.7 + REAL, PARAMETER :: RHO_HAIL = 917.0 ! hail bulk density [kg/m3] ! MB/AN : v3.7 +! -------------------------------------------------------------------------------------------------- -! adjustable parameters for snow processes +!jref: seems like PAIR should be P1000mb?? + PAIR = SFCPRS ! atm bottom level pressure (pa) + THAIR = SFCTMP * (SFCPRS/PAIR)**(RAIR/CPAIR) -! REAL, PARAMETER :: MFSNO = 2.50 !melting factor (-) ! MB: move to MPTABLE in v3.7 - REAL, PARAMETER :: Z0SNO = 0.002 !snow surface roughness length (m) (0.002) - REAL, PARAMETER :: SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) - REAL, PARAMETER :: SWEMX = 1.00 !new snow mass to fully cover old snow (mm) - !equivalent to 10mm depth (density = 100 kg/m3) + QAIR = Q2 ! In WRF, driver converts to specific humidity - INTEGER, PRIVATE, PARAMETER :: MVT = 27 - INTEGER, PRIVATE, PARAMETER :: MBAND = 2 -!------------------------------------------------------------------------------------------! -! From the veg section of MPTABLE.TBL -!------------------------------------------------------------------------------------------! + EAIR = QAIR*SFCPRS / (0.622+0.378*QAIR) + RHOAIR = (SFCPRS-0.378*EAIR) / (RAIR*SFCTMP) - INTEGER :: ISURBAN - INTEGER :: ISWATER - INTEGER :: ISBARREN - INTEGER :: ISICE - INTEGER :: EBLFOREST - - REAL :: CH2OP !maximum intercepted h2o per unit lai+sai (mm) - REAL :: DLEAF !characteristic leaf dimension (m) - REAL :: Z0MVT !momentum roughness length (m) - REAL :: HVT !top of canopy (m) - REAL :: HVB !bottom of canopy (m) - REAL :: DEN !tree density (no. of trunks per m2) - REAL :: RC !tree crown radius (m) - REAL :: MFSNO !snowmelt m parameter () - REAL :: SAIM(12) !monthly stem area index, one-sided - REAL :: LAIM(12) !monthly leaf area index, one-sided - REAL :: SLA !single-side leaf area per Kg [m2/kg] - REAL :: DILEFC !coeficient for leaf stress death [1/s] - REAL :: DILEFW !coeficient for leaf stress death [1/s] - REAL :: FRAGR !fraction of growth respiration !original was 0.3 - REAL :: LTOVRC !leaf turnover [1/s] - - REAL :: C3PSN !photosynthetic pathway: 0. = c4, 1. = c3 - REAL :: KC25 !co2 michaelis-menten constant at 25c (pa) - REAL :: AKC !q10 for kc25 - REAL :: KO25 !o2 michaelis-menten constant at 25c (pa) - REAL :: AKO !q10 for ko25 - REAL :: VCMX25 !maximum rate of carboxylation at 25c (umol co2/m**2/s) - REAL :: AVCMX !q10 for vcmx25 - REAL :: BP !minimum leaf conductance (umol/m**2/s) - REAL :: MP !slope of conductance-to-photosynthesis relationship - REAL :: QE25 !quantum efficiency at 25c (umol co2 / umol photon) - REAL :: AQE !q10 for qe25 - REAL :: RMF25 !leaf maintenance respiration at 25c (umol co2/m**2/s) - REAL :: RMS25 !stem maintenance respiration at 25c (umol co2/kg bio/s) - REAL :: RMR25 !root maintenance respiration at 25c (umol co2/kg bio/s) - REAL :: ARM !q10 for maintenance respiration - REAL :: FOLNMX !foliage nitrogen concentration when f(n)=1 (%) - REAL :: TMIN !minimum temperature for photosynthesis (k) - - REAL :: XL !leaf/stem orientation index - REAL :: RHOL(MBAND) !leaf reflectance: 1=vis, 2=nir - REAL :: RHOS(MBAND) !stem reflectance: 1=vis, 2=nir - REAL :: TAUL(MBAND) !leaf transmittance: 1=vis, 2=nir - REAL :: TAUS(MBAND) !stem transmittance: 1=vis, 2=nir + IF(COSZ <= 0.) THEN + SWDOWN = 0. + ELSE + SWDOWN = SOLDN + END IF - REAL :: MRP !microbial respiration parameter (umol co2 /kg c/ s) - REAL :: CWPVT !empirical canopy wind parameter + SOLAD(1) = SWDOWN*0.7*0.5 ! direct vis + SOLAD(2) = SWDOWN*0.7*0.5 ! direct nir + SOLAI(1) = SWDOWN*0.3*0.5 ! diffuse vis + SOLAI(2) = SWDOWN*0.3*0.5 ! diffuse nir - REAL :: WRRAT !wood to non-wood ratio - REAL :: WDPOOL !wood pool (switch 1 or 0) depending on woody or not [-] - REAL :: TDLEF !characteristic T for leaf freezing [K] + PRCP = PRCPCONV + PRCPNONC + PRCPSHCV - INTEGER :: NROOT !number of soil layers with root present - REAL :: RGL !Parameter used in radiation stress function - REAL :: RSMIN !Minimum stomatal resistance [s m-1] - REAL :: HS !Parameter used in vapor pressure deficit function - REAL :: TOPT !Optimum transpiration air temperature [K] - REAL :: RSMAX !Maximal stomatal resistance [s m-1] + IF(OPT_SNF == 4) THEN + QPRECC = PRCPCONV + PRCPSHCV + QPRECL = PRCPNONC + ELSE + QPRECC = 0.10 * PRCP ! should be from the atmospheric model + QPRECL = 0.90 * PRCP ! should be from the atmospheric model + END IF - REAL SLAREA - REAL EPS(5) +! fractional area that receives precipitation (see, Niu et al. 2005) + + FP = 0.0 + IF(QPRECC + QPRECL > 0.) & + FP = (QPRECC + QPRECL) / (10.*QPRECC + QPRECL) -!------------------------------------------------------------------------------------------! -! From the rad section of MPTABLE.TBL -!------------------------------------------------------------------------------------------! +! partition precipitation into rain and snow. Moved from CANWAT MB/AN: v3.7 - REAL :: ALBSAT(MBAND) !saturated soil albedos: 1=vis, 2=nir - REAL :: ALBDRY(MBAND) !dry soil albedos: 1=vis, 2=nir - REAL :: ALBICE(MBAND) !albedo land ice: 1=vis, 2=nir - REAL :: ALBLAK(MBAND) !albedo frozen lakes: 1=vis, 2=nir - REAL :: OMEGAS(MBAND) !two-stream parameter omega for snow - REAL :: BETADS !two-stream parameter betad for snow - REAL :: BETAIS !two-stream parameter betad for snow - REAL :: EG(2) !emissivity -!------------------------------------------------------------------------------------------! -! From the SOILPARM.TBL tables, as functions of soil category. -!------------------------------------------------------------------------------------------! - REAL :: BEXP !B parameter - REAL :: SMCDRY !dry soil moisture threshold where direct evap from top - !layer ends (volumetric) (not used MB: 20140718) - REAL :: SMCWLT !wilting point soil moisture (volumetric) - REAL :: SMCREF !reference soil moisture (field capacity) (volumetric) - REAL :: SMCMAX !porosity, saturated value of soil moisture (volumetric) - REAL :: F1 !soil thermal diffusivity/conductivity coef (not used MB: 20140718) - REAL :: PSISAT !saturated soil matric potential - REAL :: DKSAT !saturated soil hydraulic conductivity - REAL :: DWSAT !saturated soil hydraulic diffusivity - REAL :: QUARTZ !soil quartz content -!------------------------------------------------------------------------------------------! -! From the GENPARM.TBL file -!------------------------------------------------------------------------------------------! - REAL :: SLOPE !slope index (0 - 1) - REAL :: CSOIL !vol. soil heat capacity [j/m3/K] - REAL :: ZBOT !Depth (m) of lower boundary soil temperature - REAL :: CZIL !Calculate roughness length of heat +! Jordan (1991) - REAL :: KDT !used in compute maximum infiltration rate (in INFIL) - REAL :: FRZX !used in compute maximum infiltration rate (in INFIL) + IF(OPT_SNF == 1) THEN + IF(SFCTMP > TFRZ+2.5)THEN + FPICE = 0. + ELSE + IF(SFCTMP <= TFRZ+0.5)THEN + FPICE = 1.0 + ELSE IF(SFCTMP <= TFRZ+2.)THEN + FPICE = 1.-(-54.632 + 0.2*SFCTMP) + ELSE + FPICE = 0.6 + ENDIF + ENDIF + ENDIF - INTEGER :: BARE - INTEGER :: NATURAL + IF(OPT_SNF == 2) THEN + IF(SFCTMP >= TFRZ+2.2) THEN + FPICE = 0. + ELSE + FPICE = 1.0 + ENDIF + ENDIF + IF(OPT_SNF == 3) THEN + IF(SFCTMP >= TFRZ) THEN + FPICE = 0. + ELSE + FPICE = 1.0 + ENDIF + ENDIF -CONTAINS +! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625 +! fresh snow density - SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR) + BDFALL = MIN(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59)) !MB/AN: change to MIN + IF(OPT_SNF == 4) THEN + PRCP_FROZEN = PRCPSNOW + PRCPGRPL + PRCPHAIL + IF(PRCPNONC > 0. .and. PRCP_FROZEN > 0.) THEN + FPICE = MIN(1.0,PRCP_FROZEN/PRCPNONC) + FPICE = MAX(0.0,FPICE) + BDFALL = BDFALL*(PRCPSNOW/PRCP_FROZEN) + RHO_GRPL*(PRCPGRPL/PRCP_FROZEN) + & + RHO_HAIL*(PRCPHAIL/PRCP_FROZEN) + ELSE + FPICE = 0.0 + ENDIF + + ENDIF - USE NOAHMP_VEG_PARAMETERS - USE NOAHMP_SOIL_PARAMETERS - USE NOAHMP_RAD_PARAMETERS + RAIN = PRCP * (1.-FPICE) + SNOW = PRCP * FPICE - implicit none - INTEGER, INTENT(INOUT) :: VEGTYPE - INTEGER, INTENT(IN) :: SOILTYPE - INTEGER, INTENT(IN) :: SLOPETYPE - INTEGER, INTENT(IN) :: SOILCOLOR - - REAL :: REFDK - REAL :: REFKDT - REAL :: FRZK - REAL :: FRZFACT - - ISURBAN = ISURBAN_TABLE - ISWATER = ISWATER_TABLE - ISBARREN = ISBARREN_TABLE - ISICE = ISICE_TABLE - EBLFOREST = EBLFOREST_TABLE - - IF( VEGTYPE == 31 .or.VEGTYPE == 32 .or. VEGTYPE == 33) THEN - VEGTYPE = ISURBAN - ENDIF + END SUBROUTINE ATM -!------------------------------------------------------------------------------------------! -! Transfer veg parameters -!------------------------------------------------------------------------------------------! +!== begin phenology ================================================================================ - CH2OP = CH2OP_TABLE(VEGTYPE) !maximum intercepted h2o per unit lai+sai (mm) - DLEAF = DLEAF_TABLE(VEGTYPE) !characteristic leaf dimension (m) - Z0MVT = Z0MVT_TABLE(VEGTYPE) !momentum roughness length (m) - HVT = HVT_TABLE(VEGTYPE) !top of canopy (m) - HVB = HVB_TABLE(VEGTYPE) !bottom of canopy (m) - DEN = DEN_TABLE(VEGTYPE) !tree density (no. of trunks per m2) - RC = RC_TABLE(VEGTYPE) !tree crown radius (m) - MFSNO = MFSNO_TABLE(VEGTYPE) !snowmelt m parameter () - SAIM = SAIM_TABLE(VEGTYPE,:) !monthly stem area index, one-sided - LAIM = LAIM_TABLE(VEGTYPE,:) !monthly leaf area index, one-sided - SLA = SLA_TABLE(VEGTYPE) !single-side leaf area per Kg [m2/kg] - DILEFC = DILEFC_TABLE(VEGTYPE) !coeficient for leaf stress death [1/s] - DILEFW = DILEFW_TABLE(VEGTYPE) !coeficient for leaf stress death [1/s] - FRAGR = FRAGR_TABLE(VEGTYPE) !fraction of growth respiration !original was 0.3 - LTOVRC = LTOVRC_TABLE(VEGTYPE) !leaf turnover [1/s] - - C3PSN = C3PSN_TABLE(VEGTYPE) !photosynthetic pathway: 0. = c4, 1. = c3 - KC25 = KC25_TABLE(VEGTYPE) !co2 michaelis-menten constant at 25c (pa) - AKC = AKC_TABLE(VEGTYPE) !q10 for kc25 - KO25 = KO25_TABLE(VEGTYPE) !o2 michaelis-menten constant at 25c (pa) - AKO = AKO_TABLE(VEGTYPE) !q10 for ko25 - VCMX25 = VCMX25_TABLE(VEGTYPE) !maximum rate of carboxylation at 25c (umol co2/m**2/s) - AVCMX = AVCMX_TABLE(VEGTYPE) !q10 for vcmx25 - BP = BP_TABLE(VEGTYPE) !minimum leaf conductance (umol/m**2/s) - MP = MP_TABLE(VEGTYPE) !slope of conductance-to-photosynthesis relationship - QE25 = QE25_TABLE(VEGTYPE) !quantum efficiency at 25c (umol co2 / umol photon) - AQE = AQE_TABLE(VEGTYPE) !q10 for qe25 - RMF25 = RMF25_TABLE(VEGTYPE) !leaf maintenance respiration at 25c (umol co2/m**2/s) - RMS25 = RMS25_TABLE(VEGTYPE) !stem maintenance respiration at 25c (umol co2/kg bio/s) - RMR25 = RMR25_TABLE(VEGTYPE) !root maintenance respiration at 25c (umol co2/kg bio/s) - ARM = ARM_TABLE(VEGTYPE) !q10 for maintenance respiration - FOLNMX = FOLNMX_TABLE(VEGTYPE) !foliage nitrogen concentration when f(n)=1 (%) - TMIN = TMIN_TABLE(VEGTYPE) !minimum temperature for photosynthesis (k) - - XL = XL_TABLE(VEGTYPE) !leaf/stem orientation index - RHOL = RHOL_TABLE(VEGTYPE,:) !leaf reflectance: 1=vis, 2=nir - RHOS = RHOS_TABLE(VEGTYPE,:) !stem reflectance: 1=vis, 2=nir - TAUL = TAUL_TABLE(VEGTYPE,:) !leaf transmittance: 1=vis, 2=nir - TAUS = TAUS_TABLE(VEGTYPE,:) !stem transmittance: 1=vis, 2=nir - - MRP = MRP_TABLE(VEGTYPE) !microbial respiration parameter (umol co2 /kg c/ s) - CWPVT = CWPVT_TABLE(VEGTYPE) !empirical canopy wind parameter - - WRRAT = WRRAT_TABLE(VEGTYPE) !wood to non-wood ratio - WDPOOL = WDPOOL_TABLE(VEGTYPE) !wood pool (switch 1 or 0) depending on woody or not [-] - TDLEF = TDLEF_TABLE(VEGTYPE) !characteristic T for leaf freezing [K] - - NROOT = NROOT_TABLE(VEGTYPE) !number of soil layers with root present - RGL = RGL_TABLE(VEGTYPE) !Parameter used in radiation stress function - RSMIN = RS_TABLE(VEGTYPE) !Minimum stomatal resistance [s m-1] - HS = HS_TABLE(VEGTYPE) !Parameter used in vapor pressure deficit function - TOPT = TOPT_TABLE(VEGTYPE) !Optimum transpiration air temperature [K] - RSMAX = RSMAX_TABLE(VEGTYPE) !Maximal stomatal resistance [s m-1] + SUBROUTINE PHENOLOGY (parameters,VEGTYP , SNOWH , TV , LAT , YEARLEN , JULIAN , & !in + LAI , SAI , TROOT , ELAI , ESAI , IGS) -!------------------------------------------------------------------------------------------! -! Transfer rad parameters -!------------------------------------------------------------------------------------------! +! -------------------------------------------------------------------------------------------------- +! vegetation phenology considering vegeation canopy being buries by snow and evolution in time +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN ) :: VEGTYP !vegetation type + REAL , INTENT(IN ) :: SNOWH !snow height [m] + REAL , INTENT(IN ) :: TV !vegetation temperature (k) + REAL , INTENT(IN ) :: LAT !latitude (radians) + INTEGER , INTENT(IN ) :: YEARLEN!Number of days in the particular year + REAL , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) + real , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) + REAL , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow + REAL , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow - ALBSAT = ALBSAT_TABLE(SOILCOLOR,:) - ALBDRY = ALBDRY_TABLE(SOILCOLOR,:) - ALBICE = ALBICE_TABLE - ALBLAK = ALBLAK_TABLE ! not used - OMEGAS = OMEGAS_TABLE - BETADS = BETADS_TABLE - BETAIS = BETAIS_TABLE - EG = EG_TABLE - -! ---------------------------------------------------------------------- -! Transfer soil parameters -! ---------------------------------------------------------------------- - - BEXP = BEXP_TABLE (SOILTYPE) - DKSAT = DKSAT_TABLE (SOILTYPE) - DWSAT = DWSAT_TABLE (SOILTYPE) - F1 = F1_TABLE (SOILTYPE) - PSISAT = PSISAT_TABLE (SOILTYPE) - QUARTZ = QUARTZ_TABLE (SOILTYPE) - SMCDRY = SMCDRY_TABLE (SOILTYPE) - SMCMAX = SMCMAX_TABLE (SOILTYPE) - SMCREF = SMCREF_TABLE (SOILTYPE) - SMCWLT = SMCWLT_TABLE (SOILTYPE) - -! ---------------------------------------------------------------------- -! Transfer GENPARM parameters -! ---------------------------------------------------------------------- - CSOIL = CSOIL_TABLE - ZBOT = ZBOT_TABLE - CZIL = CZIL_TABLE - - FRZK = FRZK_TABLE - REFDK = REFDK_TABLE - REFKDT = REFKDT_TABLE - KDT = REFKDT * DKSAT / REFDK - SLOPE = SLOPE_TABLE(SLOPETYPE) - - IF(VEGTYPE==ISURBAN)THEN ! Hardcoding some urban parameters for soil - SMCMAX = 0.45 - SMCREF = 0.42 - SMCWLT = 0.40 - SMCDRY = 0.40 - CSOIL = 3.E6 - ENDIF +! outputs + REAL , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow + REAL , INTENT(OUT ) :: ESAI !stem area index, after burying by snow + REAL , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) -! adjust FRZK parameter to actual soil type: FRZK * FRZFACT +! locals - IF(SOILTYPE /= 14) then - FRZFACT = (SMCMAX / SMCREF) * (0.412 / 0.468) - FRZX = FRZK * FRZFACT - END IF + REAL :: DB !thickness of canopy buried by snow (m) + REAL :: FB !fraction of canopy buried by snow + REAL :: SNOWHC !critical snow depth at which short vege + !is fully covered by snow - END SUBROUTINE TRANSFER_MP_PARAMETERS + INTEGER :: K !index + INTEGER :: IT1,IT2 !interpolation months + REAL :: DAY !current day of year ( 0 <= DAY < YEARLEN ) + REAL :: WT1,WT2 !interpolation weights + REAL :: T !current month (1.00, ..., 12.00) +! -------------------------------------------------------------------------------------------------- -END MODULE NOAHMP_PARAMETERS + IF ( DVEG == 1 .or. DVEG == 3 .or. DVEG == 4 ) THEN -! ================================================================================================== + IF (LAT >= 0.) THEN + ! Northern Hemisphere + DAY = JULIAN + ELSE + ! Southern Hemisphere. DAY is shifted by 1/2 year. + DAY = MOD ( JULIAN + ( 0.5 * YEARLEN ) , REAL(YEARLEN) ) + ENDIF -MODULE NOAHMP_ROUTINES - USE NOAHMP_GLOBALS - IMPLICIT NONE + T = 12. * DAY / REAL(YEARLEN) + IT1 = T + 0.5 + IT2 = IT1 + 1 + WT1 = (IT1+0.5) - T + WT2 = 1.-WT1 + IF (IT1 .LT. 1) IT1 = 12 + IF (IT2 .GT. 12) IT2 = 1 - public :: noahmp_options - public :: NOAHMP_SFLX - public :: FRH2O + LAI = WT1*parameters%LAIM(IT1) + WT2*parameters%LAIM(IT2) + SAI = WT1*parameters%SAIM(IT1) + WT2*parameters%SAIM(IT2) + ENDIF - private :: ATM - private :: PHENOLOGY - private :: PRECIP_HEAT - private :: ENERGY - private :: THERMOPROP - private :: CSNOW - private :: TDFCND - private :: RADIATION - private :: ALBEDO - private :: SNOW_AGE - private :: SNOWALB_BATS - private :: SNOWALB_CLASS - private :: GROUNDALB - private :: TWOSTREAM - private :: SURRAD - private :: VEGE_FLUX - private :: SFCDIF1 - private :: SFCDIF2 - private :: STOMATA - private :: CANRES - private :: ESAT - private :: RAGRB - private :: BARE_FLUX - private :: TSNOSOI - private :: HRT - private :: HSTEP - private :: ROSR12 - private :: PHASECHANGE + IF(DVEG == 7 .or. DVEG == 8 .or. DVEG == 9) THEN + SAI = MAX(0.05,0.1 * LAI) ! when reading LAI, set SAI to 10% LAI, but not below 0.05 MB: v3.8 + IF (LAI < 0.05) SAI = 0.0 ! if LAI below minimum, make sure SAI = 0 + ENDIF - private :: WATER - private :: CANWATER - private :: SNOWWATER - private :: SNOWFALL - private :: COMBINE - private :: DIVIDE - private :: COMBO - private :: COMPACT - private :: SNOWH2O - private :: SOILWATER - private :: ZWTEQ - private :: INFIL - private :: SRT - private :: WDFCND1 - private :: WDFCND2 -! private :: INFIL - private :: SSTEP - private :: GROUNDWATER - private :: SHALLOWWATERTABLE + IF (SAI < 0.05 .and. DVEG /= 10) SAI = 0.0 ! MB: SAI CHECK, change to 0.05 v3.6 + IF (LAI < 0.05 .OR. SAI == 0.0 .and. DVEG /= 10) LAI = 0.0 ! MB: LAI CHECK - private :: CARBON - private :: CO2FLUX -! private :: BVOCFLUX -! private :: CH4FLUX + IF ( ( VEGTYP == parameters%iswater ) .OR. ( VEGTYP == parameters%ISBARREN ) .OR. & + ( VEGTYP == parameters%ISICE ) .or. ( parameters%urban_flag ) ) THEN + LAI = 0. + SAI = 0. + ENDIF - private :: ERROR +!buried by snow -contains -! -!== begin noahmp_sflx ============================================================================== + DB = MIN( MAX(SNOWH - parameters%HVB,0.), parameters%HVT-parameters%HVB ) + FB = DB / MAX(1.E-06,parameters%HVT-parameters%HVB) - SUBROUTINE NOAHMP_SFLX (& - ILOC , JLOC , LAT , YEARLEN , JULIAN , COSZ , & ! IN : Time/Space-related - DT , DX , DZ8W , NSOIL , ZSOIL , NSNOW , & ! IN : Model configuration - SHDFAC , SHDMAX , VEGTYP , ICE , IST , & ! IN : Vegetation/Soil characteristics - SMCEQ , & ! IN : Vegetation/Soil characteristics - SFCTMP , SFCPRS , PSFC , UU , VV , Q2 , & ! IN : Forcing - QC , SOLDN , LWDN , & ! IN : Forcing - PRCPCONV, PRCPNONC, PRCPSHCV, PRCPSNOW, PRCPGRPL, PRCPHAIL, & ! IN : Forcing - TBOT , CO2AIR , O2AIR , FOLN , FICEOLD , ZLVL , & ! IN : Forcing - ALBOLD , SNEQVO , & ! IN/OUT : - STC , SH2O , SMC , TAH , EAH , FWET , & ! IN/OUT : - CANLIQ , CANICE , TV , TG , QSFC , QSNOW , & ! IN/OUT : - ISNOW , ZSNSO , SNOWH , SNEQV , SNICE , SNLIQ , & ! IN/OUT : - ZWT , WA , WT , WSLAKE , LFMASS , RTMASS , & ! IN/OUT : - STMASS , WOOD , STBLCP , FASTCP , LAI , SAI , & ! IN/OUT : - CM , CH , TAUSS , & ! IN/OUT : - SMCWTD ,DEEPRECH , RECH , & ! IN/OUT : - Z0WRF , & - FSA , FSR , FIRA , FSH , SSOIL , FCEV , & ! OUT : - FGEV , FCTR , ECAN , ETRAN , EDIR , TRAD , & ! OUT : - TGB , TGV , T2MV , T2MB , Q2V , Q2B , & ! OUT : - RUNSRF , RUNSUB , APAR , PSN , SAV , SAG , & ! OUT : - FSNO , NEE , GPP , NPP , FVEG , ALBEDO , & ! OUT : - QSNBOT , PONDING , PONDING1, PONDING2, RSSUN , RSSHA , & ! OUT : - BGAP , WGAP , CHV , CHB , EMISSI , & ! OUT : - SHG , SHC , SHB , EVG , EVB , GHV , & ! OUT : - GHB , IRG , IRC , IRB , TR , EVC , & ! OUT : - CHLEAF , CHUC , CHV2 , CHB2 , FPICE , PAHV , & - PAHG , PAHB , PAH & -#ifdef WRF_HYDRO - ,SFCHEADRT & ! IN/OUT : -#endif - ) + IF(parameters%HVT> 0. .AND. parameters%HVT <= 1.0) THEN !MB: change to 1.0 and 0.2 to reflect + SNOWHC = parameters%HVT*EXP(-SNOWH/0.2) ! changes to HVT in MPTABLE + FB = MIN(SNOWH,SNOWHC)/SNOWHC + ENDIF -! -------------------------------------------------------------------------------------------------- -! Initial code: Guo-Yue Niu, Oct. 2007 -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: NROOT, & ! VEG DEPENDENT - ISBARREN, ISURBAN ! MP CONSTANT -! -------------------------------------------------------------------------------------------------- - implicit none -! -------------------------------------------------------------------------------------------------- -! input - INTEGER , INTENT(IN) :: ICE !ice (ice = 1) - INTEGER , INTENT(IN) :: IST !surface type 1->soil; 2->lake - INTEGER , INTENT(IN) :: VEGTYP !vegetation type - INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER , INTENT(IN) :: NSOIL !no. of soil layers - INTEGER , INTENT(IN) :: ILOC !grid index - INTEGER , INTENT(IN) :: JLOC !grid index - REAL , INTENT(IN) :: DT !time step [sec] - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf (m) - REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) lowest model layer - REAL , INTENT(IN) :: SFCTMP !surface air temperature [K] - REAL , INTENT(IN) :: UU !wind speed in eastward dir (m/s) - REAL , INTENT(IN) :: VV !wind speed in northward dir (m/s) - REAL , INTENT(IN) :: SOLDN !downward shortwave radiation (w/m2) - REAL , INTENT(IN) :: LWDN !downward longwave radiation (w/m2) - REAL , INTENT(IN) :: SFCPRS !pressure (pa) - REAL , INTENT(INOUT) :: ZLVL !reference height (m) - REAL , INTENT(IN) :: COSZ !cosine solar zenith angle [0-1] - REAL , INTENT(IN) :: TBOT !bottom condition for soil temp. [K] - REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) [1-saturated] - REAL , INTENT(IN) :: SHDFAC !green vegetation fraction [0.0-1.0] - INTEGER , INTENT(IN) :: YEARLEN!Number of days in the particular year. - REAL , INTENT(IN) :: JULIAN !Julian day of year (floating point) - REAL , INTENT(IN) :: LAT !latitude (radians) - REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD!ice fraction at last timestep - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] - REAL , INTENT(IN) :: PRCPCONV ! convective precipitation entering [mm/s] ! MB/AN : v3.7 - REAL , INTENT(IN) :: PRCPNONC ! non-convective precipitation entering [mm/s] ! MB/AN : v3.7 - REAL , INTENT(IN) :: PRCPSHCV ! shallow convective precip entering [mm/s] ! MB/AN : v3.7 - REAL , INTENT(IN) :: PRCPSNOW ! snow entering land model [mm/s] ! MB/AN : v3.7 - REAL , INTENT(IN) :: PRCPGRPL ! graupel entering land model [mm/s] ! MB/AN : v3.7 - REAL , INTENT(IN) :: PRCPHAIL ! hail entering land model [mm/s] ! MB/AN : v3.7 + ELAI = LAI*(1.-FB) + ESAI = SAI*(1.-FB) + IF (ESAI < 0.05 .and. DVEG /= 10) ESAI = 0.0 ! MB: ESAI CHECK, change to 0.05 v3.6 + IF (ELAI < 0.05 .OR. ESAI == 0.0 .and. DVEG /= 10) ELAI = 0.0 ! MB: LAI CHECK -!jref:start; in - REAL , INTENT(IN) :: QC !cloud water mixing ratio - REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer - REAL , INTENT(IN) :: PSFC !pressure at lowest model layer - REAL , INTENT(IN) :: DZ8W !thickness of lowest layer - REAL , INTENT(IN) :: DX - REAL , INTENT(IN) :: SHDMAX !yearly max vegetation fraction -!jref:end + IF (TV .GT. parameters%TMIN) THEN + IGS = 1. + ELSE + IGS = 0. + ENDIF -#ifdef WRF_HYDRO - REAL , INTENT(INOUT) :: sfcheadrt -#endif + END SUBROUTINE PHENOLOGY -! input/output : need arbitary intial values - REAL , INTENT(INOUT) :: QSNOW !snowfall [mm/s] - REAL , INTENT(INOUT) :: FWET !wetted or snowed fraction of canopy (-) - REAL , INTENT(INOUT) :: SNEQVO !snow mass at last time step (mm) - REAL , INTENT(INOUT) :: EAH !canopy air vapor pressure (pa) - REAL , INTENT(INOUT) :: TAH !canopy air tmeperature (k) - REAL , INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) - REAL , INTENT(INOUT) :: CM !momentum drag coefficient - REAL , INTENT(INOUT) :: CH !sensible heat exchange coefficient - REAL , INTENT(INOUT) :: TAUSS !non-dimensional snow age +!== begin precip_heat ============================================================================== -! prognostic variables - INTEGER , INTENT(INOUT) :: ISNOW !actual no. of snow layers [-] - REAL , INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) - REAL , INTENT(INOUT) :: CANICE !intercepted ice mass (mm) - REAL , INTENT(INOUT) :: SNEQV !snow water eqv. [mm] - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !soil moisture (ice + liq.) [m3/m3] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !layer-bottom depth from snow surf [m] - REAL , INTENT(INOUT) :: SNOWH !snow height [m] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] - REAL , INTENT(INOUT) :: TV !vegetation temperature (k) - REAL , INTENT(INOUT) :: TG !ground temperature (k) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil temperature [k] - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !liquid soil moisture [m3/m3] - REAL , INTENT(INOUT) :: ZWT !depth to water table [m] - REAL , INTENT(INOUT) :: WA !water storage in aquifer [mm] - REAL , INTENT(INOUT) :: WT !water in aquifer&saturated soil [mm] - REAL , INTENT(INOUT) :: WSLAKE !lake water storage (can be neg.) (mm) - REAL, INTENT(INOUT) :: SMCWTD !soil water content between bottom of the soil and water table [m3/m3] - REAL, INTENT(INOUT) :: DEEPRECH !recharge to or from the water table when deep [m] - REAL, INTENT(INOUT) :: RECH !recharge to or from the water table when shallow [m] (diagnostic) + SUBROUTINE PRECIP_HEAT (parameters,ILOC ,JLOC ,VEGTYP ,DT ,UU ,VV , & !in + ELAI ,ESAI ,FVEG ,IST , & !in + BDFALL ,RAIN ,SNOW ,FP , & !in + CANLIQ ,CANICE ,TV ,SFCTMP ,TG , & !in + QINTR ,QDRIPR ,QTHROR ,QINTS ,QDRIPS ,QTHROS , & !out + PAHV ,PAHG ,PAHB ,QRAIN ,QSNOW ,SNOWHIN, & !out + FWET ,CMC ) !out -! output - REAL , INTENT(OUT) :: Z0WRF !combined z0 sent to coupled model - REAL , INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) - REAL , INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) - REAL , INTENT(OUT) :: FIRA !total net LW rad (w/m2) [+ to atm] - REAL , INTENT(OUT) :: FSH !total sensible heat (w/m2) [+ to atm] - REAL , INTENT(OUT) :: FCEV !canopy evap heat (w/m2) [+ to atm] - REAL , INTENT(OUT) :: FGEV !ground evap heat (w/m2) [+ to atm] - REAL , INTENT(OUT) :: FCTR !transpiration heat (w/m2) [+ to atm] - REAL , INTENT(OUT) :: SSOIL !ground heat flux (w/m2) [+ to soil] - REAL , INTENT(OUT) :: TRAD !surface radiative temperature (k) - REAL :: TS !surface temperature (k) - REAL , INTENT(OUT) :: ECAN !evaporation of intercepted water (mm/s) - REAL , INTENT(OUT) :: ETRAN !transpiration rate (mm/s) - REAL , INTENT(OUT) :: EDIR !soil surface evaporation rate (mm/s] - REAL , INTENT(OUT) :: RUNSRF !surface runoff [mm/s] - REAL , INTENT(OUT) :: RUNSUB !baseflow (saturation excess) [mm/s] - REAL , INTENT(OUT) :: PSN !total photosynthesis (umol co2/m2/s) [+] - REAL , INTENT(OUT) :: APAR !photosyn active energy by canopy (w/m2) - REAL , INTENT(OUT) :: SAV !solar rad absorbed by veg. (w/m2) - REAL , INTENT(OUT) :: SAG !solar rad absorbed by ground (w/m2) - REAL , INTENT(OUT) :: FSNO !snow cover fraction on the ground (-) - REAL , INTENT(OUT) :: FVEG !green vegetation fraction [0.0-1.0] - REAL , INTENT(OUT) :: ALBEDO !surface albedo [-] - REAL :: ERRWAT !water error [kg m{-2}] - REAL , INTENT(OUT) :: QSNBOT !snowmelt out bottom of pack [mm/s] - REAL , INTENT(OUT) :: PONDING!surface ponding [mm] - REAL , INTENT(OUT) :: PONDING1!surface ponding [mm] - REAL , INTENT(OUT) :: PONDING2!surface ponding [mm] +! ------------------------ code history ------------------------------ +! Michael Barlage: Oct 2013 - split CANWATER to calculate precip movement for +! tracking of advected heat +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! ------------------------ input/output variables -------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: ILOC !grid index + INTEGER,INTENT(IN) :: JLOC !grid index + INTEGER,INTENT(IN) :: VEGTYP !vegetation type + INTEGER,INTENT(IN) :: IST !surface type 1-soil; 2-lake + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: UU !u-direction wind speed [m/s] + REAL, INTENT(IN) :: VV !v-direction wind speed [m/s] + REAL, INTENT(IN) :: ELAI !leaf area index, after burying by snow + REAL, INTENT(IN) :: ESAI !stem area index, after burying by snow + REAL, INTENT(IN) :: FVEG !greeness vegetation fraction (-) + REAL, INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) + REAL, INTENT(IN) :: RAIN !rainfall (mm/s) + REAL, INTENT(IN) :: SNOW !snowfall (mm/s) + REAL, INTENT(IN) :: FP !fraction of the gridcell that receives precipitation + REAL, INTENT(IN) :: TV !vegetation temperature (k) + REAL, INTENT(IN) :: SFCTMP !model-level temperature (k) + REAL, INTENT(IN) :: TG !ground temperature (k) -!jref:start; output - REAL , INTENT(OUT) :: T2MV !2-m air temperature over vegetated part [k] - REAL , INTENT(OUT) :: T2MB !2-m air temperature over bare ground part [k] - REAL, INTENT(OUT) :: RSSUN !sunlit leaf stomatal resistance (s/m) - REAL, INTENT(OUT) :: RSSHA !shaded leaf stomatal resistance (s/m) - REAL, INTENT(OUT) :: BGAP - REAL, INTENT(OUT) :: WGAP - REAL, INTENT(OUT) :: TGV - REAL, INTENT(OUT) :: TGB - REAL :: Q1 - REAL, INTENT(OUT) :: EMISSI -!jref:end +! input & output + REAL, INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) + REAL, INTENT(INOUT) :: CANICE !intercepted ice mass (mm) -! local - INTEGER :: IZ !do-loop index - INTEGER, DIMENSION(-NSNOW+1:NSOIL) :: IMELT !phase change index [1-melt; 2-freeze] - REAL :: CMC !intercepted water (CANICE+CANLIQ) (mm) - REAL :: TAUX !wind stress: e-w (n/m2) - REAL :: TAUY !wind stress: n-s (n/m2) - REAL :: RHOAIR !density air (kg/m3) -! REAL, DIMENSION( 1: 5) :: VOCFLX !voc fluxes [ug C m-2 h-1] - REAL, DIMENSION(-NSNOW+1:NSOIL) :: DZSNSO !snow/soil layer thickness [m] - REAL :: THAIR !potential temperature (k) - REAL :: QAIR !specific humidity (kg/kg) (q2/(1+q2)) - REAL :: EAIR !vapor pressure air (pa) - REAL, DIMENSION( 1: 2) :: SOLAD !incoming direct solar rad (w/m2) - REAL, DIMENSION( 1: 2) :: SOLAI !incoming diffuse solar rad (w/m2) - REAL :: QPRECC !convective precipitation (mm/s) - REAL :: QPRECL !large-scale precipitation (mm/s) - REAL :: IGS !growing season index (0=off, 1=on) - REAL :: ELAI !leaf area index, after burying by snow - REAL :: ESAI !stem area index, after burying by snow - REAL :: BEVAP !soil water evaporation factor (0 - 1) - REAL, DIMENSION( 1:NSOIL) :: BTRANI !Soil water transpiration factor (0 - 1) - REAL :: BTRAN !soil water transpiration factor (0 - 1) - REAL :: QIN !groundwater recharge [mm/s] - REAL :: QDIS !groundwater discharge [mm/s] - REAL, DIMENSION( 1:NSOIL) :: SICE !soil ice content (m3/m3) - REAL, DIMENSION(-NSNOW+1: 0) :: SNICEV !partial volume ice of snow [m3/m3] - REAL, DIMENSION(-NSNOW+1: 0) :: SNLIQV !partial volume liq of snow [m3/m3] - REAL, DIMENSION(-NSNOW+1: 0) :: EPORE !effective porosity [m3/m3] - REAL :: TOTSC !total soil carbon (g/m2) - REAL :: TOTLB !total living carbon (g/m2) - REAL :: T2M !2-meter air temperature (k) - REAL :: QDEW !ground surface dew rate [mm/s] - REAL :: QVAP !ground surface evap. rate [mm/s] - REAL :: LATHEA !latent heat [j/kg] - REAL :: SWDOWN !downward solar [w/m2] - REAL :: QMELT !snowmelt [mm/s] - REAL :: BEG_WB !water storage at begin of a step [mm] - REAL,INTENT(OUT) :: IRC !canopy net LW rad. [w/m2] [+ to atm] - REAL,INTENT(OUT) :: IRG !ground net LW rad. [w/m2] [+ to atm] - REAL,INTENT(OUT) :: SHC !canopy sen. heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: SHG !ground sen. heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: EVG !ground evap. heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: GHV !ground heat flux [w/m2] [+ to soil] - REAL,INTENT(OUT) :: IRB !net longwave rad. [w/m2] [+ to atm] - REAL,INTENT(OUT) :: SHB !sensible heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: EVB !evaporation heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: GHB !ground heat flux [w/m2] [+ to soil] - REAL,INTENT(OUT) :: EVC !canopy evap. heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: TR !transpiration heat [w/m2] [+ to atm] - REAL, INTENT(OUT) :: FPICE !snow fraction in precipitation +! output + REAL, INTENT(OUT) :: QINTR !interception rate for rain (mm/s) + REAL, INTENT(OUT) :: QDRIPR !drip rate for rain (mm/s) + REAL, INTENT(OUT) :: QTHROR !throughfall for rain (mm/s) + REAL, INTENT(OUT) :: QINTS !interception (loading) rate for snowfall (mm/s) + REAL, INTENT(OUT) :: QDRIPS !drip (unloading) rate for intercepted snow (mm/s) + REAL, INTENT(OUT) :: QTHROS !throughfall of snowfall (mm/s) REAL, INTENT(OUT) :: PAHV !precipitation advected heat - vegetation net (W/m2) REAL, INTENT(OUT) :: PAHG !precipitation advected heat - under canopy net (W/m2) REAL, INTENT(OUT) :: PAHB !precipitation advected heat - bare ground net (W/m2) - REAL, INTENT(OUT) :: PAH !precipitation advected heat - total (W/m2) - -!jref:start - REAL :: FSRV - REAL :: FSRG - REAL,INTENT(OUT) :: Q2V - REAL,INTENT(OUT) :: Q2B - REAL :: Q2E - REAL :: QFX - REAL,INTENT(OUT) :: CHV !sensible heat exchange coefficient over vegetated fraction - REAL,INTENT(OUT) :: CHB !sensible heat exchange coefficient over bare-ground - REAL,INTENT(OUT) :: CHLEAF !leaf exchange coefficient - REAL,INTENT(OUT) :: CHUC !under canopy exchange coefficient - REAL,INTENT(OUT) :: CHV2 !sensible heat exchange coefficient over vegetated fraction - REAL,INTENT(OUT) :: CHB2 !sensible heat exchange coefficient over bare-ground -!jref:end + REAL, INTENT(OUT) :: QRAIN !rain at ground srf (mm/s) [+] + REAL, INTENT(OUT) :: QSNOW !snow at ground srf (mm/s) [+] + REAL, INTENT(OUT) :: SNOWHIN !snow depth increasing rate (m/s) + REAL, INTENT(OUT) :: FWET !wetted or snowed fraction of the canopy (-) + REAL, INTENT(OUT) :: CMC !intercepted water (mm) +! -------------------------------------------------------------------- -! carbon -! inputs - REAL , INTENT(IN) :: CO2AIR !atmospheric co2 concentration (pa) - REAL , INTENT(IN) :: O2AIR !atmospheric o2 concentration (pa) +! ------------------------ local variables --------------------------- + REAL :: MAXSNO !canopy capacity for snow interception (mm) + REAL :: MAXLIQ !canopy capacity for rain interception (mm) + REAL :: FT !temperature factor for unloading rate + REAL :: FV !wind factor for unloading rate + REAL :: PAH_AC !precipitation advected heat - air to canopy (W/m2) + REAL :: PAH_CG !precipitation advected heat - canopy to ground (W/m2) + REAL :: PAH_AG !precipitation advected heat - air to ground (W/m2) + REAL :: ICEDRIP !canice unloading +! -------------------------------------------------------------------- +! initialization -! inputs and outputs : prognostic variables - REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] - REAL , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2] - REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] - REAL , INTENT(INOUT) :: WOOD !mass of wood (incl. woody roots) [g/m2] - REAL , INTENT(INOUT) :: STBLCP !stable carbon in deep soil [g/m2] - REAL , INTENT(INOUT) :: FASTCP !short-lived carbon, shallow soil [g/m2] - REAL , INTENT(INOUT) :: LAI !leaf area index [-] - REAL , INTENT(INOUT) :: SAI !stem area index [-] + QINTR = 0. + QDRIPR = 0. + QTHROR = 0. + QINTR = 0. + QINTS = 0. + QDRIPS = 0. + QTHROS = 0. + PAH_AC = 0. + PAH_CG = 0. + PAH_AG = 0. + PAHV = 0. + PAHG = 0. + PAHB = 0. + QRAIN = 0.0 + QSNOW = 0.0 + SNOWHIN = 0.0 + ICEDRIP = 0.0 +! print*, "precip_heat begin canopy balance:",canliq+canice+(rain+snow)*dt +! print*, "precip_heat snow*3600.0:",snow*3600.0 +! print*, "precip_heat rain*3600.0:",rain*3600.0 +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq -! outputs - REAL , INTENT(OUT) :: NEE !net ecosys exchange (g/m2/s CO2) - REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s C] - REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2/s C] - REAL :: AUTORS !net ecosystem respiration (g/m2/s C) - REAL :: HETERS !organic respiration (g/m2/s C) - REAL :: TROOT !root-zone averaged temperature (k) - REAL :: BDFALL !bulk density of new snow (kg/m3) ! MB/AN: v3.7 - REAL :: RAIN !rain rate (mm/s) ! MB/AN: v3.7 - REAL :: SNOW !liquid equivalent snow rate (mm/s) ! MB/AN: v3.7 - REAL :: FP ! MB/AN: v3.7 - REAL :: PRCP ! MB/AN: v3.7 -!more local variables for precip heat MB - REAL :: QINTR !interception rate for rain (mm/s) - REAL :: QDRIPR !drip rate for rain (mm/s) - REAL :: QTHROR !throughfall for rain (mm/s) - REAL :: QINTS !interception (loading) rate for snowfall (mm/s) - REAL :: QDRIPS !drip (unloading) rate for intercepted snow (mm/s) - REAL :: QTHROS !throughfall of snowfall (mm/s) - REAL :: QRAIN !rain at ground srf (mm/s) [+] - REAL :: SNOWHIN !snow depth increasing rate (m/s) - REAL :: LATHEAV !latent heat vap./sublimation (j/kg) - REAL :: LATHEAG !latent heat vap./sublimation (j/kg) - LOGICAL :: FROZEN_GROUND ! used to define latent heat pathway - LOGICAL :: FROZEN_CANOPY ! used to define latent heat pathway +! --------------------------- liquid water ------------------------------ +! maximum canopy water - ! INTENT (OUT) variables need to be assigned a value. These normally get assigned values - ! only if DVEG == 2. - nee = 0.0 - npp = 0.0 - gpp = 0.0 - PAHV = 0. - PAHG = 0. - PAHB = 0. - PAH = 0. + MAXLIQ = parameters%CH2OP * (ELAI+ ESAI) -! -------------------------------------------------------------------------------------------------- -! re-process atmospheric forcing +! average interception and throughfall - CALL ATM (SFCPRS ,SFCTMP ,Q2 , & - PRCPCONV, PRCPNONC,PRCPSHCV,PRCPSNOW,PRCPGRPL,PRCPHAIL, & - SOLDN ,COSZ ,THAIR ,QAIR , & - EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD ,SOLAI , & - SWDOWN ,BDFALL ,RAIN ,SNOW ,FP ,FPICE , PRCP ) + IF((ELAI+ ESAI).GT.0.) THEN + QINTR = FVEG * RAIN * FP ! interception capability + QINTR = MIN(QINTR, (MAXLIQ - CANLIQ)/DT * (1.-EXP(-RAIN*DT/MAXLIQ)) ) + QINTR = MAX(QINTR, 0.) + QDRIPR = FVEG * RAIN - QINTR + QTHROR = (1.-FVEG) * RAIN + CANLIQ=MAX(0.,CANLIQ+QINTR*DT) + ELSE + QINTR = 0. + QDRIPR = 0. + QTHROR = RAIN + IF(CANLIQ > 0.) THEN ! FOR CASE OF CANOPY GETTING BURIED + QDRIPR = QDRIPR + CANLIQ/DT + CANLIQ = 0.0 + END IF + END IF + +! heat transported by liquid water -! snow/soil layer thickness (m) + PAH_AC = FVEG * RAIN * (CWAT/1000.0) * (SFCTMP - TV) + PAH_CG = QDRIPR * (CWAT/1000.0) * (TV - TG) + PAH_AG = QTHROR * (CWAT/1000.0) * (SFCTMP - TG) +! print*, "precip_heat PAH_AC:",PAH_AC +! print*, "precip_heat PAH_CG:",PAH_CG +! print*, "precip_heat PAH_AG:",PAH_AG - DO IZ = ISNOW+1, NSOIL - IF(IZ == ISNOW+1) THEN - DZSNSO(IZ) = - ZSNSO(IZ) - ELSE - DZSNSO(IZ) = ZSNSO(IZ-1) - ZSNSO(IZ) - END IF - END DO +! --------------------------- canopy ice ------------------------------ +! for canopy ice -! root-zone temperature + MAXSNO = 6.6*(0.27+46./BDFALL) * (ELAI+ ESAI) - TROOT = 0. - DO IZ=1,NROOT - TROOT = TROOT + STC(IZ)*DZSNSO(IZ)/(-ZSOIL(NROOT)) - ENDDO + IF((ELAI+ ESAI).GT.0.) THEN + QINTS = FVEG * SNOW * FP + QINTS = MIN(QINTS, (MAXSNO - CANICE)/DT * (1.-EXP(-SNOW*DT/MAXSNO)) ) + QINTS = MAX(QINTS, 0.) + FT = MAX(0.0,(TV - 270.15) / 1.87E5) + FV = SQRT(UU*UU + VV*VV) / 1.56E5 + ! MB: changed below to reflect the rain assumption that all precip gets intercepted + ICEDRIP = MAX(0.,CANICE) * (FV+FT) !MB: removed /DT + QDRIPS = (FVEG * SNOW - QINTS) + ICEDRIP + QTHROS = (1.0-FVEG) * SNOW + CANICE= MAX(0.,CANICE + (QINTS - ICEDRIP)*DT) + ELSE + QINTS = 0. + QDRIPS = 0. + QTHROS = SNOW + IF(CANICE > 0.) THEN ! FOR CASE OF CANOPY GETTING BURIED + QDRIPS = QDRIPS + CANICE/DT + CANICE = 0.0 + END IF + ENDIF +! print*, "precip_heat canopy through:",3600.0*(FVEG * SNOW - QINTS) +! print*, "precip_heat canopy drip:",3600.0*MAX(0.,CANICE) * (FV+FT) -! total water storage for water balance check - - IF(IST == 1) THEN - BEG_WB = CANLIQ + CANICE + SNEQV + WA - DO IZ = 1,NSOIL - BEG_WB = BEG_WB + SMC(IZ) * DZSNSO(IZ) * 1000. - END DO - END IF +! wetted fraction of canopy -! vegetation phenology + IF(CANICE.GT.0.) THEN + FWET = MAX(0.,CANICE) / MAX(MAXSNO,1.E-06) + ELSE + FWET = MAX(0.,CANLIQ) / MAX(MAXLIQ,1.E-06) + ENDIF + FWET = MIN(FWET, 1.) ** 0.667 - CALL PHENOLOGY (VEGTYP , SNOWH , TV , LAT , YEARLEN , JULIAN , & !in - LAI , SAI , TROOT , ELAI , ESAI ,IGS) +! total canopy water -!input GVF should be consistent with LAI - IF(DVEG == 1) THEN - FVEG = SHDFAC - IF(FVEG <= 0.05) FVEG = 0.05 - ELSE IF (DVEG == 2 .or. DVEG == 3) THEN - FVEG = 1.-EXP(-0.52*(LAI+SAI)) - IF(FVEG <= 0.05) FVEG = 0.05 - ELSE IF (DVEG == 4 .or. DVEG == 5) THEN - FVEG = SHDMAX - IF(FVEG <= 0.05) FVEG = 0.05 - ELSE - WRITE(*,*) "-------- FATAL CALLED IN SFLX -----------" - CALL wrf_error_fatal("Namelist parameter DVEG unknown") - ENDIF - IF(VEGTYP == ISURBAN .OR. VEGTYP == ISBARREN) FVEG = 0.0 - IF(ELAI+ESAI == 0.0) FVEG = 0.0 + CMC = CANLIQ + CANICE - CALL PRECIP_HEAT(ILOC ,JLOC ,VEGTYP ,DT ,UU ,VV , & !in - ELAI ,ESAI ,FVEG ,IST , & !in - BDFALL ,RAIN ,SNOW ,FP , & !in - CANLIQ ,CANICE ,TV ,SFCTMP ,TG , & !in - QINTR ,QDRIPR ,QTHROR ,QINTS ,QDRIPS ,QTHROS , & !out - PAHV ,PAHG ,PAHB ,QRAIN ,QSNOW ,SNOWHIN, & !out - FWET ,CMC ) !out +! heat transported by snow/ice -! compute energy budget (momentum & energy fluxes and phase changes) + PAH_AC = PAH_AC + FVEG * SNOW * (CICE/1000.0) * (SFCTMP - TV) + PAH_CG = PAH_CG + QDRIPS * (CICE/1000.0) * (TV - TG) + PAH_AG = PAH_AG + QTHROS * (CICE/1000.0) * (SFCTMP - TG) + + PAHV = PAH_AC - PAH_CG + PAHG = PAH_CG + PAHB = PAH_AG + + IF (FVEG > 0.0 .AND. FVEG < 1.0) THEN + PAHG = PAHG / FVEG ! these will be multiplied by fraction later + PAHB = PAHB / (1.0-FVEG) + ELSEIF (FVEG <= 0.0) THEN + PAHB = PAHG + PAHB ! for case of canopy getting buried + PAHG = 0.0 + PAHV = 0.0 + ELSEIF (FVEG >= 1.0) THEN + PAHB = 0.0 + END IF + + PAHV = MAX(PAHV,-20.0) ! Put some artificial limits here for stability + PAHV = MIN(PAHV,20.0) + PAHG = MAX(PAHG,-20.0) + PAHG = MIN(PAHG,20.0) + PAHB = MAX(PAHB,-20.0) + PAHB = MIN(PAHB,20.0) + +! print*, 'precip_heat sfctmp,tv,tg:',sfctmp,tv,tg +! print*, 'precip_heat 3600.0*qints+qdrips+qthros:',3600.0*(qints+qdrips+qthros) +! print*, "precip_heat maxsno:",maxsno +! print*, "precip_heat PAH_AC:",PAH_AC +! print*, "precip_heat PAH_CG:",PAH_CG +! print*, "precip_heat PAH_AG:",PAH_AG + +! print*, "precip_heat PAHV:",PAHV +! print*, "precip_heat PAHG:",PAHG +! print*, "precip_heat PAHB:",PAHB +! print*, "precip_heat fveg:",fveg +! print*, "precip_heat qints*3600.0:",qints*3600.0 +! print*, "precip_heat qdrips*3600.0:",qdrips*3600.0 +! print*, "precip_heat qthros*3600.0:",qthros*3600.0 + +! rain or snow on the ground - CALL ENERGY (ICE ,VEGTYP ,IST ,NSNOW ,NSOIL , & !in - ISNOW ,DT ,RHOAIR ,SFCPRS ,QAIR , & !in - SFCTMP ,THAIR ,LWDN ,UU ,VV ,ZLVL , & !in - CO2AIR ,O2AIR ,SOLAD ,SOLAI ,COSZ ,IGS , & !in - EAIR ,TBOT ,ZSNSO ,ZSOIL , & !in - ELAI ,ESAI ,FWET ,FOLN , & !in - FVEG ,PAHV ,PAHG ,PAHB , & !in - QSNOW ,DZSNSO ,LAT ,CANLIQ ,CANICE ,iloc, jloc , & !in - Z0WRF , & - IMELT ,SNICEV ,SNLIQV ,EPORE ,T2M ,FSNO , & !out - SAV ,SAG ,QMELT ,FSA ,FSR ,TAUX , & !out - TAUY ,FIRA ,FSH ,FCEV ,FGEV ,FCTR , & !out - TRAD ,PSN ,APAR ,SSOIL ,BTRANI ,BTRAN , & !out - PONDING,TS ,LATHEAV , LATHEAG , frozen_canopy,frozen_ground, & !out - TV ,TG ,STC ,SNOWH ,EAH ,TAH , & !inout - SNEQVO ,SNEQV ,SH2O ,SMC ,SNICE ,SNLIQ , & !inout - ALBOLD ,CM ,CH ,DX ,DZ8W ,Q2 , & !inout - TAUSS , & !inout -!jref:start - QC ,QSFC ,PSFC , & !in - T2MV ,T2MB ,FSRV , & - FSRG ,RSSUN ,RSSHA ,BGAP ,WGAP, TGV,TGB,& - Q1 ,Q2V ,Q2B ,Q2E ,CHV ,CHB , & !out - EMISSI ,PAH , & - SHG,SHC,SHB,EVG,EVB,GHV,GHB,IRG,IRC,IRB,TR,EVC,CHLEAF,CHUC,CHV2,CHB2 ) !out -!jref:end + QRAIN = QDRIPR + QTHROR + QSNOW = QDRIPS + QTHROS + SNOWHIN = QSNOW/BDFALL - SICE(:) = MAX(0.0, SMC(:) - SH2O(:)) - SNEQVO = SNEQV + IF (IST == 2 .AND. TG > TFRZ) THEN + QSNOW = 0. + SNOWHIN = 0. + END IF +! print*, "precip_heat qsnow*3600.0:",qsnow*3600.0 +! print*, "precip_heat qrain*3600.0:",qrain*3600.0 +! print*, "precip_heat SNOWHIN:",SNOWHIN +! print*, "precip_heat canice:",canice +! print*, "precip_heat canliq:",canliq +! print*, "precip_heat end canopy balance:",canliq+canice+(qrain+qsnow)*dt + - QVAP = MAX( FGEV/LATHEAG, 0.) ! positive part of fgev; Barlage change to ground v3.6 - QDEW = ABS( MIN(FGEV/LATHEAG, 0.)) ! negative part of fgev - EDIR = QVAP - QDEW + END SUBROUTINE PRECIP_HEAT -! compute water budgets (water storages, ET components, and runoff) +!== begin error ==================================================================================== - CALL WATER (VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in - VV ,FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , & !in - ESAI ,SFCTMP ,QVAP ,QDEW ,ZSOIL ,BTRANI , & !in - FICEOLD,PONDING,TG ,IST ,FVEG ,iloc,jloc , SMCEQ , & !in - BDFALL ,FP ,RAIN ,SNOW , & !in MB/AN: v3.7 - QSNOW ,QRAIN ,SNOWHIN,LATHEAV,LATHEAG,frozen_canopy,frozen_ground, & !in MB - ISNOW ,CANLIQ ,CANICE ,TV ,SNOWH ,SNEQV , & !inout - SNICE ,SNLIQ ,STC ,ZSNSO ,SH2O ,SMC , & !inout - SICE ,ZWT ,WA ,WT ,DZSNSO ,WSLAKE , & !inout - SMCWTD ,DEEPRECH,RECH , & !inout - CMC ,ECAN ,ETRAN ,FWET ,RUNSRF ,RUNSUB , & !out - QIN ,QDIS ,PONDING1 ,PONDING2,& - QSNBOT & -#ifdef WRF_HYDRO - ,sfcheadrt & -#endif - ) !out + SUBROUTINE ERROR (parameters,SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , & + FGEV ,FCTR ,SSOIL ,BEG_WB ,CANLIQ ,CANICE , & + SNEQV ,WA ,SMC ,DZSNSO ,PRCP ,ECAN , & + ETRAN ,EDIR ,RUNSRF ,RUNSUB ,DT ,NSOIL , & + NSNOW ,IST ,ERRWAT, ILOC ,JLOC ,FVEG , & + SAV ,SAG ,FSRV ,FSRG ,ZWT ,PAH , & + PAHV ,PAHG ,PAHB ) +! -------------------------------------------------------------------------------------------------- +! check surface energy balance and water balance +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + INTEGER , INTENT(IN) :: IST !surface type 1->soil; 2->lake + INTEGER , INTENT(IN) :: ILOC !grid index + INTEGER , INTENT(IN) :: JLOC !grid index + REAL , INTENT(IN) :: SWDOWN !downward solar filtered by sun angle [w/m2] + REAL , INTENT(IN) :: FSA !total absorbed solar radiation (w/m2) + REAL , INTENT(IN) :: FSR !total reflected solar radiation (w/m2) + REAL , INTENT(IN) :: FIRA !total net longwave rad (w/m2) [+ to atm] + REAL , INTENT(IN) :: FSH !total sensible heat (w/m2) [+ to atm] + REAL , INTENT(IN) :: FCEV !canopy evaporation heat (w/m2) [+ to atm] + REAL , INTENT(IN) :: FGEV !ground evaporation heat (w/m2) [+ to atm] + REAL , INTENT(IN) :: FCTR !transpiration heat flux (w/m2) [+ to atm] + REAL , INTENT(IN) :: SSOIL !ground heat flux (w/m2) [+ to soil] + REAL , INTENT(IN) :: FVEG + REAL , INTENT(IN) :: SAV + REAL , INTENT(IN) :: SAG + REAL , INTENT(IN) :: FSRV + REAL , INTENT(IN) :: FSRG + REAL , INTENT(IN) :: ZWT -! write(*,'(a20,10F15.5)') 'SFLX:RUNOFF=',RUNSRF*DT,RUNSUB*DT,EDIR*DT + REAL , INTENT(IN) :: PRCP !precipitation rate (kg m-2 s-1) + REAL , INTENT(IN) :: ECAN !evaporation of intercepted water (mm/s) + REAL , INTENT(IN) :: ETRAN !transpiration rate (mm/s) + REAL , INTENT(IN) :: EDIR !soil surface evaporation rate[mm/s] + REAL , INTENT(IN) :: RUNSRF !surface runoff [mm/s] + REAL , INTENT(IN) :: RUNSUB !baseflow (saturation excess) [mm/s] + REAL , INTENT(IN) :: CANLIQ !intercepted liquid water (mm) + REAL , INTENT(IN) :: CANICE !intercepted ice mass (mm) + REAL , INTENT(IN) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] + REAL , INTENT(IN) :: WA !water storage in aquifer [mm] + REAL , INTENT(IN) :: DT !time step [sec] + REAL , INTENT(IN) :: BEG_WB !water storage at begin of a timesetp [mm] + REAL , INTENT(OUT) :: ERRWAT !error in water balance [mm/timestep] + REAL, INTENT(IN) :: PAH !precipitation advected heat - total (W/m2) + REAL, INTENT(IN) :: PAHV !precipitation advected heat - total (W/m2) + REAL, INTENT(IN) :: PAHG !precipitation advected heat - total (W/m2) + REAL, INTENT(IN) :: PAHB !precipitation advected heat - total (W/m2) -! compute carbon budgets (carbon storages and co2 & bvoc fluxes) + INTEGER :: IZ !do-loop index + REAL :: END_WB !water storage at end of a timestep [mm] + !KWM REAL :: ERRWAT !error in water balance [mm/timestep] + REAL :: ERRENG !error in surface energy balance [w/m2] + REAL :: ERRSW !error in shortwave radiation balance [w/m2] + REAL :: FSRVG + CHARACTER(len=256) :: message +! -------------------------------------------------------------------------------------------------- +!jref:start + ERRSW = SWDOWN - (FSA + FSR) +! ERRSW = SWDOWN - (SAV+SAG + FSRV+FSRG) +! WRITE(*,*) "ERRSW =",ERRSW + IF (ABS(ERRSW) > 0.01) THEN ! w/m2 + WRITE(*,*) "VEGETATION!" + WRITE(*,*) "SWDOWN*FVEG =",SWDOWN*FVEG + WRITE(*,*) "FVEG*(SAV+SAG) =",FVEG*SAV + SAG + WRITE(*,*) "FVEG*(FSRV +FSRG)=",FVEG*FSRV + FSRG + WRITE(*,*) "GROUND!" + WRITE(*,*) "(1-.FVEG)*SWDOWN =",(1.-FVEG)*SWDOWN + WRITE(*,*) "(1.-FVEG)*SAG =",(1.-FVEG)*SAG + WRITE(*,*) "(1.-FVEG)*FSRG=",(1.-FVEG)*FSRG + WRITE(*,*) "FSRV =",FSRV + WRITE(*,*) "FSRG =",FSRG + WRITE(*,*) "FSR =",FSR + WRITE(*,*) "SAV =",SAV + WRITE(*,*) "SAG =",SAG + WRITE(*,*) "FSA =",FSA +!jref:end + WRITE(message,*) 'ERRSW =',ERRSW + call wrf_message(trim(message)) + call wrf_error_fatal("Stop in Noah-MP") + END IF - IF (DVEG == 2 .OR. DVEG == 5) THEN - CALL CARBON (NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL , & !in - DZSNSO ,STC ,SMC ,TV ,TG ,PSN , & !in - FOLN ,BTRAN ,APAR ,FVEG ,IGS , & !in - TROOT ,IST ,LAT ,iloc ,jloc , & !in - LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP , & !inout - GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC , & !out - TOTLB ,LAI ,SAI ) !out + ERRENG = SAV+SAG-(FIRA+FSH+FCEV+FGEV+FCTR+SSOIL) +PAH +! ERRENG = FVEG*SAV+SAG-(FIRA+FSH+FCEV+FGEV+FCTR+SSOIL) +! WRITE(*,*) "ERRENG =",ERRENG + IF(ABS(ERRENG) > 0.01) THEN + write(message,*) 'ERRENG =',ERRENG,' at i,j: ',ILOC,JLOC + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Net solar: ",FSA + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Net longwave: ",FIRA + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Total sensible: ",FSH + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Canopy evap: ",FCEV + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Ground evap: ",FGEV + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Transpiration: ",FCTR + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Total ground: ",SSOIL + call wrf_message(trim(message)) + WRITE(message,'(a17,4F10.4)') "Precip advected: ",PAH,PAHV,PAHG,PAHB + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Precip: ",PRCP + call wrf_message(trim(message)) + WRITE(message,'(a17,F10.4)') "Veg fraction: ",FVEG + call wrf_message(trim(message)) + call wrf_error_fatal("Energy budget problem in NOAHMP LSM") END IF -! water and energy balance check - - CALL ERROR (SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , & !in - FGEV ,FCTR ,SSOIL ,BEG_WB ,CANLIQ ,CANICE , & !in - SNEQV ,WA ,SMC ,DZSNSO ,PRCP ,ECAN , & !in - ETRAN ,EDIR ,RUNSRF ,RUNSUB ,DT ,NSOIL , & !in - NSNOW ,IST ,ERRWAT ,ILOC , JLOC ,FVEG , & - SAV ,SAG ,FSRV ,FSRG ,ZWT ,PAH , & - PAHV ,PAHG ,PAHB ) !in ( Except ERRWAT, which is out ) - -! urban - jref - QFX = ETRAN + ECAN + EDIR - IF ( VEGTYP == ISURBAN ) THEN - QSFC = (QFX/RHOAIR*CH) + QAIR - Q2B = QSFC - END IF + IF (IST == 1) THEN !soil + END_WB = CANLIQ + CANICE + SNEQV + WA + DO IZ = 1,NSOIL + END_WB = END_WB + SMC(IZ) * DZSNSO(IZ) * 1000. + END DO + ERRWAT = END_WB-BEG_WB-(PRCP-ECAN-ETRAN-EDIR-RUNSRF-RUNSUB)*DT - IF(SNOWH <= 1.E-6 .OR. SNEQV <= 1.E-3) THEN - SNOWH = 0.0 - SNEQV = 0.0 - END IF +#ifndef WRF_HYDRO + IF(ABS(ERRWAT) > 0.1) THEN + if (ERRWAT > 0) then + call wrf_message ('The model is gaining water (ERRWAT is positive)') + else + call wrf_message('The model is losing water (ERRWAT is negative)') + endif + write(message, *) 'ERRWAT =',ERRWAT, "kg m{-2} timestep{-1}" + call wrf_message(trim(message)) + WRITE(message, & + '(" I J END_WB BEG_WB PRCP ECAN EDIR ETRAN RUNSRF RUNSUB")') + call wrf_message(trim(message)) + WRITE(message,'(i6,1x,i6,1x,2f15.3,9f11.5)')ILOC,JLOC,END_WB,BEG_WB,PRCP*DT,ECAN*DT,& + EDIR*DT,ETRAN*DT,RUNSRF*DT,RUNSUB*DT,ZWT + call wrf_message(trim(message)) + call wrf_error_fatal("Water budget problem in NOAHMP LSM") + END IF +#endif + ELSE !KWM + ERRWAT = 0.0 !KWM + ENDIF - IF(SWDOWN.NE.0.) THEN - ALBEDO = FSR / SWDOWN - ELSE - ALBEDO = -999.9 - END IF - + END SUBROUTINE ERROR - END SUBROUTINE NOAHMP_SFLX +!== begin energy =================================================================================== -!== begin atm ====================================================================================== + SUBROUTINE ENERGY (parameters,ICE ,VEGTYP ,IST ,NSNOW ,NSOIL , & !in + ISNOW ,DT ,RHOAIR ,SFCPRS ,QAIR , & !in + SFCTMP ,THAIR ,LWDN ,UU ,VV ,ZREF , & !in + CO2AIR ,O2AIR ,SOLAD ,SOLAI ,COSZ ,IGS , & !in + EAIR ,TBOT ,ZSNSO ,ZSOIL , & !in + ELAI ,ESAI ,FWET ,FOLN , & !in + FVEG ,PAHV ,PAHG ,PAHB , & !in + QSNOW ,DZSNSO ,LAT ,CANLIQ ,CANICE ,ILOC , JLOC, & !in + Z0WRF , & + IMELT ,SNICEV ,SNLIQV ,EPORE ,T2M ,FSNO , & !out + SAV ,SAG ,QMELT ,FSA ,FSR ,TAUX , & !out + TAUY ,FIRA ,FSH ,FCEV ,FGEV ,FCTR , & !out + TRAD ,PSN ,APAR ,SSOIL ,BTRANI ,BTRAN , & !out + PONDING,TS ,LATHEAV , LATHEAG , frozen_canopy,frozen_ground, & !out + TV ,TG ,STC ,SNOWH ,EAH ,TAH , & !inout + SNEQVO ,SNEQV ,SH2O ,SMC ,SNICE ,SNLIQ , & !inout + ALBOLD ,CM ,CH ,DX ,DZ8W ,Q2 , & !inout + TAUSS , & !inout +!jref:start + QC ,QSFC ,PSFC , & !in + T2MV ,T2MB ,FSRV , & + FSRG ,RSSUN ,RSSHA ,BGAP ,WGAP,TGV,TGB,& + Q1 ,Q2V ,Q2B ,Q2E ,CHV ,CHB, EMISSI,PAH ,& + SHG,SHC,SHB,EVG,EVB,GHV,GHB,IRG,IRC,IRB,TR,EVC,CHLEAF,CHUC,CHV2,CHB2 ) !out +!jref:end - SUBROUTINE ATM (SFCPRS ,SFCTMP ,Q2 , & - PRCPCONV,PRCPNONC ,PRCPSHCV,PRCPSNOW,PRCPGRPL,PRCPHAIL , & - SOLDN ,COSZ ,THAIR ,QAIR , & - EAIR ,RHOAIR ,QPRECC ,QPRECL ,SOLAD , SOLAI , & - SWDOWN ,BDFALL ,RAIN ,SNOW ,FP , FPICE ,PRCP ) ! -------------------------------------------------------------------------------------------------- -! re-process atmospheric forcing -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: RAIR, CPAIR, TFRZ ! MP CONSTANT +! we use different approaches to deal with subgrid features of radiation transfer and turbulent +! transfer. We use 'tile' approach to compute turbulent fluxes, while we use modified two- +! stream to compute radiation transfer. Tile approach, assemblying vegetation canopies together, +! may expose too much ground surfaces (either covered by snow or grass) to solar radiation. The +! modified two-stream assumes vegetation covers fully the gridcell but with gaps between tree +! crowns. +! -------------------------------------------------------------------------------------------------- +! turbulence transfer : 'tile' approach to compute energy fluxes in vegetated fraction and +! bare fraction separately and then sum them up weighted by fraction +! -------------------------------------- +! / O O O O O O O O / / +! / | | | | | | | | / / +! / O O O O O O O O / / +! / | | |tile1| | | | / tile2 / +! / O O O O O O O O / bare / +! / | | | vegetated | | / / +! / O O O O O O O O / / +! / | | | | | | | | / / +! -------------------------------------- +! -------------------------------------------------------------------------------------------------- +! radiation transfer : modified two-stream (Yang and Friedl, 2003, JGR; Niu ang Yang, 2004, JGR) +! -------------------------------------- two-stream treats leaves as +! / O O O O O O O O / cloud over the entire grid-cell, +! / | | | | | | | | / while the modified two-stream +! / O O O O O O O O / aggregates cloudy leaves into +! / | | | | | | | | / tree crowns with gaps (as shown in +! / O O O O O O O O / the left figure). We assume these +! / | | | | | | | | / tree crowns are evenly distributed +! / O O O O O O O O / within the gridcell with 100% veg +! / | | | | | | | | / fraction, but with gaps. The 'tile' +! -------------------------------------- approach overlaps too much shadows. ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! inputs + type (noahmp_parameters), intent(in) :: parameters + integer , INTENT(IN) :: ILOC + integer , INTENT(IN) :: JLOC + INTEGER , INTENT(IN) :: ICE !ice (ice = 1) + INTEGER , INTENT(IN) :: VEGTYP !vegetation physiology type + INTEGER , INTENT(IN) :: IST !surface type: 1->soil; 2->lake + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + INTEGER , INTENT(IN) :: ISNOW !actual no. of snow layers + REAL , INTENT(IN) :: DT !time step [sec] + REAL , INTENT(IN) :: QSNOW !snowfall on the ground (mm/s) + REAL , INTENT(IN) :: RHOAIR !density air (kg/m3) + REAL , INTENT(IN) :: EAIR !vapor pressure air (pa) + REAL , INTENT(IN) :: SFCPRS !pressure (pa) + REAL , INTENT(IN) :: QAIR !specific humidity (kg/kg) + REAL , INTENT(IN) :: SFCTMP !air temperature (k) + REAL , INTENT(IN) :: THAIR !potential temperature (k) + REAL , INTENT(IN) :: LWDN !downward longwave radiation (w/m2) + REAL , INTENT(IN) :: UU !wind speed in e-w dir (m/s) + REAL , INTENT(IN) :: VV !wind speed in n-s dir (m/s) + REAL , DIMENSION( 1: 2), INTENT(IN) :: SOLAD !incoming direct solar rad. (w/m2) + REAL , DIMENSION( 1: 2), INTENT(IN) :: SOLAI !incoming diffuse solar rad. (w/m2) + REAL , INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL , INTENT(IN) :: ELAI !LAI adjusted for burying by snow + REAL , INTENT(IN) :: ESAI !LAI adjusted for burying by snow + REAL , INTENT(IN) :: FWET !fraction of canopy that is wet [-] + REAL , INTENT(IN) :: FVEG !greeness vegetation fraction (-) + REAL , INTENT(IN) :: LAT !latitude (radians) + REAL , INTENT(IN) :: CANLIQ !canopy-intercepted liquid water (mm) + REAL , INTENT(IN) :: CANICE !canopy-intercepted ice mass (mm) + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) + REAL , INTENT(IN) :: CO2AIR !atmospheric co2 concentration (pa) + REAL , INTENT(IN) :: O2AIR !atmospheric o2 concentration (pa) + REAL , INTENT(IN) :: IGS !growing season index (0=off, 1=on) - REAL , INTENT(IN) :: SFCPRS !pressure (pa) - REAL , INTENT(IN) :: SFCTMP !surface air temperature [k] - REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) - REAL , INTENT(IN) :: PRCPCONV ! convective precipitation entering [mm/s] ! MB/AN : v3.7 - REAL , INTENT(IN) :: PRCPNONC ! non-convective precipitation entering [mm/s] ! MB/AN : v3.7 - REAL , INTENT(IN) :: PRCPSHCV ! shallow convective precip entering [mm/s] ! MB/AN : v3.7 - REAL , INTENT(IN) :: PRCPSNOW ! snow entering land model [mm/s] ! MB/AN : v3.7 - REAL , INTENT(IN) :: PRCPGRPL ! graupel entering land model [mm/s] ! MB/AN : v3.7 - REAL , INTENT(IN) :: PRCPHAIL ! hail entering land model [mm/s] ! MB/AN : v3.7 - REAL , INTENT(IN) :: SOLDN !downward shortwave radiation (w/m2) - REAL , INTENT(IN) :: COSZ !cosine solar zenith angle [0-1] - -! outputs - - REAL , INTENT(OUT) :: THAIR !potential temperature (k) - REAL , INTENT(OUT) :: QAIR !specific humidity (kg/kg) (q2/(1+q2)) - REAL , INTENT(OUT) :: EAIR !vapor pressure air (pa) - REAL , INTENT(OUT) :: RHOAIR !density air (kg/m3) - REAL , INTENT(OUT) :: QPRECC !convective precipitation (mm/s) - REAL , INTENT(OUT) :: QPRECL !large-scale precipitation (mm/s) - REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAD !incoming direct solar radiation (w/m2) - REAL, DIMENSION( 1: 2), INTENT(OUT) :: SOLAI !incoming diffuse solar radiation (w/m2) - REAL , INTENT(OUT) :: SWDOWN !downward solar filtered by sun angle [w/m2] - REAL , INTENT(OUT) :: BDFALL !!bulk density of snowfall (kg/m3) AJN - REAL , INTENT(OUT) :: RAIN !rainfall (mm/s) AJN - REAL , INTENT(OUT) :: SNOW !liquid equivalent snowfall (mm/s) AJN - REAL , INTENT(OUT) :: FP !fraction of area receiving precipitation AJN - REAL , INTENT(OUT) :: FPICE !fraction of ice AJN - REAL , INTENT(OUT) :: PRCP !total precipitation [mm/s] ! MB/AN : v3.7 - -!locals - - REAL :: PAIR !atm bottom level pressure (pa) - REAL :: PRCP_FROZEN !total frozen precipitation [mm/s] ! MB/AN : v3.7 - REAL, PARAMETER :: RHO_GRPL = 500.0 ! graupel bulk density [kg/m3] ! MB/AN : v3.7 - REAL, PARAMETER :: RHO_HAIL = 917.0 ! hail bulk density [kg/m3] ! MB/AN : v3.7 -! -------------------------------------------------------------------------------------------------- - -!jref: seems like PAIR should be P1000mb?? - PAIR = SFCPRS ! atm bottom level pressure (pa) - THAIR = SFCTMP * (SFCPRS/PAIR)**(RAIR/CPAIR) - - QAIR = Q2 ! In WRF, driver converts to specific humidity - - EAIR = QAIR*SFCPRS / (0.622+0.378*QAIR) - RHOAIR = (SFCPRS-0.378*EAIR) / (RAIR*SFCTMP) - - IF(COSZ <= 0.) THEN - SWDOWN = 0. - ELSE - SWDOWN = SOLDN - END IF - - SOLAD(1) = SWDOWN*0.7*0.5 ! direct vis - SOLAD(2) = SWDOWN*0.7*0.5 ! direct nir - SOLAI(1) = SWDOWN*0.3*0.5 ! diffuse vis - SOLAI(2) = SWDOWN*0.3*0.5 ! diffuse nir - - PRCP = PRCPCONV + PRCPNONC + PRCPSHCV + REAL , INTENT(IN) :: ZREF !reference height (m) + REAL , INTENT(IN) :: TBOT !bottom condition for soil temp. (k) + REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !layer-bottom depth from snow surf [m] + REAL , DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf [m] + REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !depth of snow & soil layer-bottom [m] + REAL, INTENT(IN) :: PAHV !precipitation advected heat - vegetation net (W/m2) + REAL, INTENT(IN) :: PAHG !precipitation advected heat - under canopy net (W/m2) + REAL, INTENT(IN) :: PAHB !precipitation advected heat - bare ground net (W/m2) - IF(OPT_SNF == 4) THEN - QPRECC = PRCPCONV + PRCPSHCV - QPRECL = PRCPNONC - ELSE - QPRECC = 0.10 * PRCP ! should be from the atmospheric model - QPRECL = 0.90 * PRCP ! should be from the atmospheric model - END IF +!jref:start; in + REAL , INTENT(IN) :: QC !cloud water mixing ratio + REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer + REAL , INTENT(IN) :: PSFC !pressure at lowest model layer + REAL , INTENT(IN) :: DX !horisontal resolution + REAL , INTENT(IN) :: DZ8W !thickness of lowest layer + REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) +!jref:end -! fractional area that receives precipitation (see, Niu et al. 2005) - - FP = 0.0 - IF(QPRECC + QPRECL > 0.) & - FP = (QPRECC + QPRECL) / (10.*QPRECC + QPRECL) +! outputs + REAL , INTENT(OUT) :: Z0WRF !combined z0 sent to coupled model + INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT !phase change index [1-melt; 2-freeze] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume ice [m3/m3] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume liq. water [m3/m3] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] + REAL , INTENT(OUT) :: FSNO !snow cover fraction (-) + REAL , INTENT(OUT) :: QMELT !snowmelt [mm/s] + REAL , INTENT(OUT) :: PONDING!pounding at ground [mm] + REAL , INTENT(OUT) :: SAV !solar rad. absorbed by veg. (w/m2) + REAL , INTENT(OUT) :: SAG !solar rad. absorbed by ground (w/m2) + REAL , INTENT(OUT) :: FSA !tot. absorbed solar radiation (w/m2) + REAL , INTENT(OUT) :: FSR !tot. reflected solar radiation (w/m2) + REAL , INTENT(OUT) :: TAUX !wind stress: e-w (n/m2) + REAL , INTENT(OUT) :: TAUY !wind stress: n-s (n/m2) + REAL , INTENT(OUT) :: FIRA !total net LW. rad (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FSH !total sensible heat (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FCEV !canopy evaporation (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FGEV !ground evaporation (w/m2) [+ to atm] + REAL , INTENT(OUT) :: FCTR !transpiration (w/m2) [+ to atm] + REAL , INTENT(OUT) :: TRAD !radiative temperature (k) + REAL , INTENT(OUT) :: T2M !2 m height air temperature (k) + REAL , INTENT(OUT) :: PSN !total photosyn. (umolco2/m2/s) [+] + REAL , INTENT(OUT) :: APAR !total photosyn. active energy (w/m2) + REAL , INTENT(OUT) :: SSOIL !ground heat flux (w/m2) [+ to soil] + REAL , DIMENSION( 1:NSOIL), INTENT(OUT) :: BTRANI !soil water transpiration factor (0-1) + REAL , INTENT(OUT) :: BTRAN !soil water transpiration factor (0-1) +! REAL , INTENT(OUT) :: LATHEA !latent heat vap./sublimation (j/kg) + REAL , INTENT(OUT) :: LATHEAV !latent heat vap./sublimation (j/kg) + REAL , INTENT(OUT) :: LATHEAG !latent heat vap./sublimation (j/kg) + LOGICAL , INTENT(OUT) :: FROZEN_GROUND ! used to define latent heat pathway + LOGICAL , INTENT(OUT) :: FROZEN_CANOPY ! used to define latent heat pathway -! partition precipitation into rain and snow. Moved from CANWAT MB/AN: v3.7 +!jref:start + REAL , INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) + REAL , INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: RSSUN !sunlit leaf stomatal resistance (s/m) + REAL, INTENT(OUT) :: RSSHA !shaded leaf stomatal resistance (s/m) +!jref:end - out for debug -! Jordan (1991) +!jref:start; output + REAL , INTENT(OUT) :: T2MV !2-m air temperature over vegetated part [k] + REAL , INTENT(OUT) :: T2MB !2-m air temperature over bare ground part [k] + REAL , INTENT(OUT) :: BGAP + REAL , INTENT(OUT) :: WGAP +!jref:end - IF(OPT_SNF == 1) THEN - IF(SFCTMP > TFRZ+2.5)THEN - FPICE = 0. - ELSE - IF(SFCTMP <= TFRZ+0.5)THEN - FPICE = 1.0 - ELSE IF(SFCTMP <= TFRZ+2.)THEN - FPICE = 1.-(-54.632 + 0.2*SFCTMP) - ELSE - FPICE = 0.6 - ENDIF - ENDIF - ENDIF +! input & output + REAL , INTENT(INOUT) :: TS !surface temperature (k) + REAL , INTENT(INOUT) :: TV !vegetation temperature (k) + REAL , INTENT(INOUT) :: TG !ground temperature (k) + REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil temperature [k] + REAL , INTENT(INOUT) :: SNOWH !snow height [m] + REAL , INTENT(INOUT) :: SNEQV !snow mass (mm) + REAL , INTENT(INOUT) :: SNEQVO !snow mass at last time step (mm) + REAL , DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !liquid soil moisture [m3/m3] + REAL , DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL , DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow ice mass (kg/m2) + REAL , DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow liq mass (kg/m2) + REAL , INTENT(INOUT) :: EAH !canopy air vapor pressure (pa) + REAL , INTENT(INOUT) :: TAH !canopy air temperature (k) + REAL , INTENT(INOUT) :: ALBOLD !snow albedo at last time step(CLASS type) + REAL , INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL , INTENT(INOUT) :: CM !momentum drag coefficient + REAL , INTENT(INOUT) :: CH !sensible heat exchange coefficient + REAL , INTENT(INOUT) :: Q1 +! REAL :: Q2E + REAL, INTENT(OUT) :: EMISSI + REAL, INTENT(OUT) :: PAH !precipitation advected heat - total (W/m2) - IF(OPT_SNF == 2) THEN - IF(SFCTMP >= TFRZ+2.2) THEN - FPICE = 0. - ELSE - FPICE = 1.0 - ENDIF - ENDIF +! local + INTEGER :: IZ !do-loop index + LOGICAL :: VEG !true if vegetated surface + REAL :: UR !wind speed at height ZLVL (m/s) + REAL :: ZLVL !reference height (m) + REAL :: FSUN !sunlit fraction of canopy [-] + REAL :: RB !leaf boundary layer resistance (s/m) + REAL :: RSURF !ground surface resistance (s/m) + REAL :: L_RSURF!Dry-layer thickness for computing RSURF (Sakaguchi and Zeng, 2009) + REAL :: D_RSURF!Reduced vapor diffusivity in soil for computing RSURF (SZ09) + REAL :: BEVAP !soil water evaporation factor (0- 1) + REAL :: MOL !Monin-Obukhov length (m) + REAL :: VAI !sum of LAI + stem area index [m2/m2] + REAL :: CWP !canopy wind extinction parameter + REAL :: ZPD !zero plane displacement (m) + REAL :: Z0M !z0 momentum (m) + REAL :: ZPDG !zero plane displacement (m) + REAL :: Z0MG !z0 momentum, ground (m) + REAL :: EMV !vegetation emissivity + REAL :: EMG !ground emissivity + REAL :: FIRE !emitted IR (w/m2) - IF(OPT_SNF == 3) THEN - IF(SFCTMP >= TFRZ) THEN - FPICE = 0. - ELSE - FPICE = 1.0 - ENDIF - ENDIF + REAL :: LAISUN !sunlit leaf area index (m2/m2) + REAL :: LAISHA !shaded leaf area index (m2/m2) + REAL :: PSNSUN !sunlit photosynthesis (umolco2/m2/s) + REAL :: PSNSHA !shaded photosynthesis (umolco2/m2/s) +!jref:start - for debug +! REAL :: RSSUN !sunlit stomatal resistance (s/m) +! REAL :: RSSHA !shaded stomatal resistance (s/m) +!jref:end - for debug + REAL :: PARSUN !par absorbed per sunlit LAI (w/m2) + REAL :: PARSHA !par absorbed per shaded LAI (w/m2) -! Hedstrom NR and JW Pomeroy (1998), Hydrol. Processes, 12, 1611-1625 -! fresh snow density + REAL, DIMENSION(-NSNOW+1:NSOIL) :: FACT !temporary used in phase change + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DF !thermal conductivity [w/m/k] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: HCPCT !heat capacity [j/m3/k] + REAL :: BDSNO !bulk density of snow (kg/m3) + REAL :: FMELT !melting factor for snow cover frac + REAL :: GX !temporary variable + REAL, DIMENSION(-NSNOW+1:NSOIL) :: PHI !light through water (w/m2) +! REAL :: GAMMA !psychrometric constant (pa/k) + REAL :: GAMMAV !psychrometric constant (pa/k) + REAL :: GAMMAG !psychrometric constant (pa/k) + REAL :: PSI !surface layer soil matrix potential (m) + REAL :: RHSUR !raltive humidity in surface soil/snow air space (-) - BDFALL = MIN(120.,67.92+51.25*EXP((SFCTMP-TFRZ)/2.59)) !MB/AN: change to MIN - IF(OPT_SNF == 4) THEN - PRCP_FROZEN = PRCPSNOW + PRCPGRPL + PRCPHAIL - IF(PRCPNONC > 0. .and. PRCP_FROZEN > 0.) THEN - FPICE = MIN(1.0,PRCP_FROZEN/PRCPNONC) - FPICE = MAX(0.0,FPICE) - BDFALL = BDFALL*(PRCPSNOW/PRCP_FROZEN) + RHO_GRPL*(PRCPGRPL/PRCP_FROZEN) + & - RHO_HAIL*(PRCPHAIL/PRCP_FROZEN) - ELSE - FPICE = 0.0 - ENDIF - - ENDIF +! temperature and fluxes over vegetated fraction - RAIN = PRCP * (1.-FPICE) - SNOW = PRCP * FPICE + REAL :: TAUXV !wind stress: e-w dir [n/m2] + REAL :: TAUYV !wind stress: n-s dir [n/m2] + REAL,INTENT(OUT) :: IRC !canopy net LW rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: IRG !ground net LW rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHC !canopy sen. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHG !ground sen. heat [w/m2] [+ to atm] +!jref:start + REAL,INTENT(OUT) :: Q2V + REAL,INTENT(OUT) :: Q2B + REAL,INTENT(OUT) :: Q2E +!jref:end + REAL,INTENT(OUT) :: EVC !canopy evap. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: EVG !ground evap. heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: TR !transpiration heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: GHV !ground heat flux [w/m2] [+ to soil] + REAL,INTENT(OUT) :: TGV !ground surface temp. [k] + REAL :: CMV !momentum drag coefficient + REAL,INTENT(OUT) :: CHV !sensible heat exchange coefficient +! temperature and fluxes over bare soil fraction - END SUBROUTINE ATM + REAL :: TAUXB !wind stress: e-w dir [n/m2] + REAL :: TAUYB !wind stress: n-s dir [n/m2] + REAL,INTENT(OUT) :: IRB !net longwave rad. [w/m2] [+ to atm] + REAL,INTENT(OUT) :: SHB !sensible heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: EVB !evaporation heat [w/m2] [+ to atm] + REAL,INTENT(OUT) :: GHB !ground heat flux [w/m2] [+ to soil] + REAL,INTENT(OUT) :: TGB !ground surface temp. [k] + REAL :: CMB !momentum drag coefficient + REAL,INTENT(OUT) :: CHB !sensible heat exchange coefficient + REAL,INTENT(OUT) :: CHLEAF !leaf exchange coefficient + REAL,INTENT(OUT) :: CHUC !under canopy exchange coefficient +!jref:start + REAL,INTENT(OUT) :: CHV2 !sensible heat conductance, canopy air to ZLVL air (m/s) + REAL,INTENT(OUT) :: CHB2 !sensible heat conductance, canopy air to ZLVL air (m/s) + REAL :: noahmpres -!== begin phenology ================================================================================ +!jref:end - SUBROUTINE PHENOLOGY (VEGTYP , SNOWH , TV , LAT , YEARLEN , JULIAN , & !in - LAI , SAI , TROOT , ELAI , ESAI , IGS) + REAL, PARAMETER :: MPE = 1.E-6 + REAL, PARAMETER :: PSIWLT = -150. !metric potential for wilting point (m) + REAL, PARAMETER :: Z0 = 0.01 ! Bare-soil roughness length (m) (i.e., under the canopy) -! -------------------------------------------------------------------------------------------------- -! vegetation phenology considering vegeation canopy being buries by snow and evolution in time -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY : LAIM, SAIM, HVT, HVB, TMIN, & ! VEGETATION DEPENDENT - ISBARREN, ISICE, ISURBAN, ISWATER ! MP CONSTANT -! -------------------------------------------------------------------------------------------------- - IMPLICIT NONE -! -------------------------------------------------------------------------------------------------- -! inputs - INTEGER , INTENT(IN ) :: VEGTYP !vegetation type - REAL , INTENT(IN ) :: SNOWH !snow height [m] - REAL , INTENT(IN ) :: TV !vegetation temperature (k) - REAL , INTENT(IN ) :: LAT !latitude (radians) - INTEGER , INTENT(IN ) :: YEARLEN!Number of days in the particular year - REAL , INTENT(IN ) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) - real , INTENT(IN ) :: TROOT !root-zone averaged temperature (k) - REAL , INTENT(INOUT) :: LAI !LAI, unadjusted for burying by snow - REAL , INTENT(INOUT) :: SAI !SAI, unadjusted for burying by snow +! --------------------------------------------------------------------------------------------------- +! initialize fluxes from veg. fraction -! outputs - REAL , INTENT(OUT ) :: ELAI !leaf area index, after burying by snow - REAL , INTENT(OUT ) :: ESAI !stem area index, after burying by snow - REAL , INTENT(OUT ) :: IGS !growing season index (0=off, 1=on) + TAUXV = 0. + TAUYV = 0. + IRC = 0. + SHC = 0. + IRG = 0. + SHG = 0. + EVG = 0. + EVC = 0. + TR = 0. + GHV = 0. + PSNSUN = 0. + PSNSHA = 0. + T2MV = 0. + Q2V = 0. + CHV = 0. + CHLEAF = 0. + CHUC = 0. + CHV2 = 0. -! locals +! wind speed at reference height: ur >= 1 - REAL :: DB !thickness of canopy buried by snow (m) - REAL :: FB !fraction of canopy buried by snow - REAL :: SNOWHC !critical snow depth at which short vege - !is fully covered by snow + UR = MAX( SQRT(UU**2.+VV**2.), 1. ) - INTEGER :: K !index - INTEGER :: IT1,IT2 !interpolation months - REAL :: DAY !current day of year ( 0 <= DAY < YEARLEN ) - REAL :: WT1,WT2 !interpolation weights - REAL :: T !current month (1.00, ..., 12.00) -! -------------------------------------------------------------------------------------------------- +! vegetated or non-vegetated - IF ( DVEG == 1 .or. DVEG == 3 .or. DVEG == 4 ) THEN + VAI = ELAI + ESAI + VEG = .FALSE. + IF(VAI > 0.) VEG = .TRUE. - IF (LAT >= 0.) THEN - ! Northern Hemisphere - DAY = JULIAN - ELSE - ! Southern Hemisphere. DAY is shifted by 1/2 year. - DAY = MOD ( JULIAN + ( 0.5 * YEARLEN ) , REAL(YEARLEN) ) +! ground snow cover fraction [Niu and Yang, 2007, JGR] + + FSNO = 0. + IF(SNOWH.GT.0.) THEN + BDSNO = SNEQV / SNOWH + FMELT = (BDSNO/100.)**parameters%MFSNO + FSNO = TANH( SNOWH /(2.5* Z0 * FMELT)) ENDIF - T = 12. * DAY / REAL(YEARLEN) - IT1 = T + 0.5 - IT2 = IT1 + 1 - WT1 = (IT1+0.5) - T - WT2 = 1.-WT1 - IF (IT1 .LT. 1) IT1 = 12 - IF (IT2 .GT. 12) IT2 = 1 +! ground roughness length - LAI = WT1*LAIM(IT1) + WT2*LAIM(IT2) - SAI = WT1*SAIM(IT1) + WT2*SAIM(IT2) - ENDIF - IF (SAI < 0.05) SAI = 0.0 ! MB: SAI CHECK, change to 0.05 v3.6 - IF (LAI < 0.05 .OR. SAI == 0.0) LAI = 0.0 ! MB: LAI CHECK + IF(IST == 2) THEN + IF(TG .LE. TFRZ) THEN + Z0MG = 0.01 * (1.0-FSNO) + FSNO * parameters%Z0SNO + ELSE + Z0MG = 0.01 + END IF + ELSE + Z0MG = Z0 * (1.0-FSNO) + FSNO * parameters%Z0SNO + END IF - IF ( ( VEGTYP == ISWATER ) .OR. ( VEGTYP == ISBARREN ) .OR. ( VEGTYP == ISICE ) .or. ( VEGTYP == ISURBAN) ) THEN - LAI = 0. - SAI = 0. - ENDIF +! roughness length and displacement height -!buried by snow + ZPDG = SNOWH + IF(VEG) THEN + Z0M = parameters%Z0MVT + ZPD = 0.65 * parameters%HVT + IF(SNOWH.GT.ZPD) ZPD = SNOWH + ELSE + Z0M = Z0MG + ZPD = ZPDG + END IF - DB = MIN( MAX(SNOWH - HVB,0.), HVT-HVB ) - FB = DB / MAX(1.E-06,HVT-HVB) + ZLVL = MAX(ZPD,parameters%HVT) + ZREF + IF(ZPDG >= ZLVL) ZLVL = ZPDG + ZREF +! UR = UR*LOG(ZLVL/Z0M)/LOG(10./Z0M) !input UR is at 10m - IF(HVT> 0. .AND. HVT <= 1.0) THEN !MB: change to 1.0 and 0.2 to reflect - SNOWHC = HVT*EXP(-SNOWH/0.2) ! changes to HVT in MPTABLE - FB = MIN(SNOWH,SNOWHC)/SNOWHC - ENDIF +! canopy wind absorption coeffcient - ELAI = LAI*(1.-FB) - ESAI = SAI*(1.-FB) - IF (ESAI < 0.05) ESAI = 0.0 ! MB: ESAI CHECK, change to 0.05 v3.6 - IF (ELAI < 0.05 .OR. ESAI == 0.0) ELAI = 0.0 ! MB: LAI CHECK + CWP = parameters%CWPVT - IF (TV .GT. TMIN) THEN - IGS = 1. - ELSE - IGS = 0. - ENDIF +! Thermal properties of soil, snow, lake, and frozen soil - END SUBROUTINE PHENOLOGY + CALL THERMOPROP (parameters,NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , & !in + DT ,SNOWH ,SNICE ,SNLIQ , & !in + SMC ,SH2O ,TG ,STC ,UR , & !in + LAT ,Z0M ,ZLVL ,VEGTYP , & !in + DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , & !out + FACT ) !out -!== begin precip_heat ============================================================================== +! Solar radiation: absorbed & reflected by the ground and canopy - SUBROUTINE PRECIP_HEAT (ILOC ,JLOC ,VEGTYP ,DT ,UU ,VV , & !in - ELAI ,ESAI ,FVEG ,IST , & !in - BDFALL ,RAIN ,SNOW ,FP , & !in - CANLIQ ,CANICE ,TV ,SFCTMP ,TG , & !in - QINTR ,QDRIPR ,QTHROR ,QINTS ,QDRIPS ,QTHROS , & !out - PAHV ,PAHG ,PAHB ,QRAIN ,QSNOW ,SNOWHIN, & !out - FWET ,CMC ) !out + CALL RADIATION (parameters,VEGTYP ,IST ,ICE ,NSOIL , & !in + SNEQVO ,SNEQV ,DT ,COSZ ,SNOWH , & !in + TG ,TV ,FSNO ,QSNOW ,FWET , & !in + ELAI ,ESAI ,SMC ,SOLAD ,SOLAI , & !in + FVEG ,ILOC ,JLOC , & !in + ALBOLD ,TAUSS , & !inout + FSUN ,LAISUN ,LAISHA ,PARSUN ,PARSHA , & !out + SAV ,SAG ,FSR ,FSA ,FSRV , & + FSRG ,BGAP ,WGAP ) !out -! ------------------------ code history ------------------------------ -! Michael Barlage: Oct 2013 - split CANWATER to calculate precip movement for -! tracking of advected heat -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY : CH2OP, CWAT, CICE, TFRZ ! VEGETATION DEPENDENT -! -------------------------------------------------------------------- - IMPLICIT NONE -! ------------------------ input/output variables -------------------- -! input - INTEGER,INTENT(IN) :: ILOC !grid index - INTEGER,INTENT(IN) :: JLOC !grid index - INTEGER,INTENT(IN) :: VEGTYP !vegetation type - INTEGER,INTENT(IN) :: IST !surface type 1-soil; 2-lake - REAL, INTENT(IN) :: DT !main time step (s) - REAL, INTENT(IN) :: UU !u-direction wind speed [m/s] - REAL, INTENT(IN) :: VV !v-direction wind speed [m/s] - REAL, INTENT(IN) :: ELAI !leaf area index, after burying by snow - REAL, INTENT(IN) :: ESAI !stem area index, after burying by snow - REAL, INTENT(IN) :: FVEG !greeness vegetation fraction (-) - REAL, INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) - REAL, INTENT(IN) :: RAIN !rainfall (mm/s) - REAL, INTENT(IN) :: SNOW !snowfall (mm/s) - REAL, INTENT(IN) :: FP !fraction of the gridcell that receives precipitation - REAL, INTENT(IN) :: TV !vegetation temperature (k) - REAL, INTENT(IN) :: SFCTMP !model-level temperature (k) - REAL, INTENT(IN) :: TG !ground temperature (k) +! vegetation and ground emissivity -! input & output - REAL, INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) - REAL, INTENT(INOUT) :: CANICE !intercepted ice mass (mm) + EMV = 1. - EXP(-(ELAI+ESAI)/1.0) + IF (ICE == 1) THEN + EMG = 0.98*(1.-FSNO) + 1.0*FSNO + ELSE + EMG = parameters%EG(IST)*(1.-FSNO) + 1.0*FSNO + END IF -! output - REAL, INTENT(OUT) :: QINTR !interception rate for rain (mm/s) - REAL, INTENT(OUT) :: QDRIPR !drip rate for rain (mm/s) - REAL, INTENT(OUT) :: QTHROR !throughfall for rain (mm/s) - REAL, INTENT(OUT) :: QINTS !interception (loading) rate for snowfall (mm/s) - REAL, INTENT(OUT) :: QDRIPS !drip (unloading) rate for intercepted snow (mm/s) - REAL, INTENT(OUT) :: QTHROS !throughfall of snowfall (mm/s) - REAL, INTENT(OUT) :: PAHV !precipitation advected heat - vegetation net (W/m2) - REAL, INTENT(OUT) :: PAHG !precipitation advected heat - under canopy net (W/m2) - REAL, INTENT(OUT) :: PAHB !precipitation advected heat - bare ground net (W/m2) - REAL, INTENT(OUT) :: QRAIN !rain at ground srf (mm/s) [+] - REAL, INTENT(OUT) :: QSNOW !snow at ground srf (mm/s) [+] - REAL, INTENT(OUT) :: SNOWHIN !snow depth increasing rate (m/s) - REAL, INTENT(OUT) :: FWET !wetted or snowed fraction of the canopy (-) - REAL, INTENT(OUT) :: CMC !intercepted water (mm) -! -------------------------------------------------------------------- +! soil moisture factor controlling stomatal resistance + + BTRAN = 0. -! ------------------------ local variables --------------------------- - REAL :: MAXSNO !canopy capacity for snow interception (mm) - REAL :: MAXLIQ !canopy capacity for rain interception (mm) - REAL :: FT !temperature factor for unloading rate - REAL :: FV !wind factor for unloading rate - REAL :: PAH_AC !precipitation advected heat - air to canopy (W/m2) - REAL :: PAH_CG !precipitation advected heat - canopy to ground (W/m2) - REAL :: PAH_AG !precipitation advected heat - air to ground (W/m2) - REAL :: ICEDRIP !canice unloading -! -------------------------------------------------------------------- -! initialization + IF(IST ==1 ) THEN + DO IZ = 1, parameters%NROOT + IF(OPT_BTR == 1) then ! Noah + GX = (SH2O(IZ)-parameters%SMCWLT(IZ)) / (parameters%SMCREF(IZ)-parameters%SMCWLT(IZ)) + END IF + IF(OPT_BTR == 2) then ! CLM + PSI = MAX(PSIWLT,-parameters%PSISAT(IZ)*(MAX(0.01,SH2O(IZ))/parameters%SMCMAX(IZ))**(-parameters%BEXP(IZ)) ) + GX = (1.-PSI/PSIWLT)/(1.+parameters%PSISAT(IZ)/PSIWLT) + END IF + IF(OPT_BTR == 3) then ! SSiB + PSI = MAX(PSIWLT,-parameters%PSISAT(IZ)*(MAX(0.01,SH2O(IZ))/parameters%SMCMAX(IZ))**(-parameters%BEXP(IZ)) ) + GX = 1.-EXP(-5.8*(LOG(PSIWLT/PSI))) + END IF + + GX = MIN(1.,MAX(0.,GX)) + BTRANI(IZ) = MAX(MPE,DZSNSO(IZ) / (-ZSOIL(parameters%NROOT)) * GX) + BTRAN = BTRAN + BTRANI(IZ) + END DO + BTRAN = MAX(MPE,BTRAN) - QINTR = 0. - QDRIPR = 0. - QTHROR = 0. - QINTR = 0. - QINTS = 0. - QDRIPS = 0. - QTHROS = 0. - PAH_AC = 0. - PAH_CG = 0. - PAH_AG = 0. - PAHV = 0. - PAHG = 0. - PAHB = 0. - QRAIN = 0.0 - QSNOW = 0.0 - SNOWHIN = 0.0 - ICEDRIP = 0.0 -! print*, "precip_heat begin canopy balance:",canliq+canice+(rain+snow)*dt -! print*, "precip_heat snow*3600.0:",snow*3600.0 -! print*, "precip_heat rain*3600.0:",rain*3600.0 -! print*, "precip_heat canice:",canice -! print*, "precip_heat canliq:",canliq + BTRANI(1:parameters%NROOT) = BTRANI(1:parameters%NROOT)/BTRAN + END IF -! --------------------------- liquid water ------------------------------ -! maximum canopy water +! soil surface resistance for ground evap. - MAXLIQ = CH2OP * (ELAI+ ESAI) + BEVAP = MAX(0.0,SH2O(1)/parameters%SMCMAX(1)) + IF(IST == 2) THEN + RSURF = 1. ! avoid being divided by 0 + RHSUR = 1.0 + ELSE -! average interception and throughfall + IF(OPT_RSF == 1 .OR. OPT_RSF == 4) THEN + ! RSURF based on Sakaguchi and Zeng, 2009 + ! taking the "residual water content" to be the wilting point, + ! and correcting the exponent on the D term (typo in SZ09 ?) + L_RSURF = (-ZSOIL(1)) * ( exp ( (1.0 - MIN(1.0,SH2O(1)/parameters%SMCMAX(1))) ** 5 ) - 1.0 ) / ( 2.71828 - 1.0 ) + D_RSURF = 2.2E-5 * parameters%SMCMAX(1) * parameters%SMCMAX(1) * ( 1.0 - parameters%SMCWLT(1) / parameters%SMCMAX(1) ) ** (2.0+3.0/parameters%BEXP(1)) + RSURF = L_RSURF / D_RSURF + ELSEIF(OPT_RSF == 2) THEN + RSURF = FSNO * 1. + (1.-FSNO)* EXP(8.25-4.225*BEVAP) !Sellers (1992) ! Older RSURF computations + ELSEIF(OPT_RSF == 3) THEN + RSURF = FSNO * 1. + (1.-FSNO)* EXP(8.25-6.0 *BEVAP) !adjusted to decrease RSURF for wet soil + ENDIF - IF((ELAI+ ESAI).GT.0.) THEN - QINTR = FVEG * RAIN * FP ! interception capability - QINTR = MIN(QINTR, (MAXLIQ - CANLIQ)/DT * (1.-EXP(-RAIN*DT/MAXLIQ)) ) - QINTR = MAX(QINTR, 0.) - QDRIPR = FVEG * RAIN - QINTR - QTHROR = (1.-FVEG) * RAIN - CANLIQ=MAX(0.,CANLIQ+QINTR*DT) - ELSE - QINTR = 0. - QDRIPR = 0. - QTHROR = RAIN - IF(CANLIQ > 0.) THEN ! FOR CASE OF CANOPY GETTING BURIED - QDRIPR = QDRIPR + CANLIQ/DT - CANLIQ = 0.0 - END IF - END IF - -! heat transported by liquid water + IF(OPT_RSF == 4) THEN ! AD: FSNO weighted; snow RSURF set in MPTABLE v3.8 + RSURF = 1. / (FSNO * (1./parameters%RSURF_SNOW) + (1.-FSNO) * (1./max(RSURF, 0.001))) + ENDIF - PAH_AC = FVEG * RAIN * (CWAT/1000.0) * (SFCTMP - TV) - PAH_CG = QDRIPR * (CWAT/1000.0) * (TV - TG) - PAH_AG = QTHROR * (CWAT/1000.0) * (SFCTMP - TG) -! print*, "precip_heat PAH_AC:",PAH_AC -! print*, "precip_heat PAH_CG:",PAH_CG -! print*, "precip_heat PAH_AG:",PAH_AG + IF(SH2O(1) < 0.01 .and. SNOWH == 0.) RSURF = 1.E6 + PSI = -parameters%PSISAT(1)*(MAX(0.01,SH2O(1))/parameters%SMCMAX(1))**(-parameters%BEXP(1)) + RHSUR = FSNO + (1.-FSNO) * EXP(PSI*GRAV/(RW*TG)) + END IF -! --------------------------- canopy ice ------------------------------ -! for canopy ice +! urban - jref + IF (parameters%urban_flag .and. SNOWH == 0. ) THEN + RSURF = 1.E6 + ENDIF - MAXSNO = 6.6*(0.27+46./BDFALL) * (ELAI+ ESAI) +! set psychrometric constant - IF((ELAI+ ESAI).GT.0.) THEN - QINTS = FVEG * SNOW * FP - QINTS = MIN(QINTS, (MAXSNO - CANICE)/DT * (1.-EXP(-SNOW*DT/MAXSNO)) ) - QINTS = MAX(QINTS, 0.) - FT = MAX(0.0,(TV - 270.15) / 1.87E5) - FV = SQRT(UU*UU + VV*VV) / 1.56E5 - ! MB: changed below to reflect the rain assumption that all precip gets intercepted - ICEDRIP = MAX(0.,CANICE) * (FV+FT) !MB: removed /DT - QDRIPS = (FVEG * SNOW - QINTS) + ICEDRIP - QTHROS = (1.0-FVEG) * SNOW - CANICE= MAX(0.,CANICE + (QINTS - ICEDRIP)*DT) - ELSE - QINTS = 0. - QDRIPS = 0. - QTHROS = SNOW - IF(CANICE > 0.) THEN ! FOR CASE OF CANOPY GETTING BURIED - QDRIPS = QDRIPS + CANICE/DT - CANICE = 0.0 - END IF - ENDIF -! print*, "precip_heat canopy through:",3600.0*(FVEG * SNOW - QINTS) -! print*, "precip_heat canopy drip:",3600.0*MAX(0.,CANICE) * (FV+FT) + IF (TV .GT. TFRZ) THEN ! Barlage: add distinction between ground and + LATHEAV = HVAP ! vegetation in v3.6 + frozen_canopy = .false. + ELSE + LATHEAV = HSUB + frozen_canopy = .true. + END IF + GAMMAV = CPAIR*SFCPRS/(0.622*LATHEAV) -! wetted fraction of canopy + IF (TG .GT. TFRZ) THEN + LATHEAG = HVAP + frozen_ground = .false. + ELSE + LATHEAG = HSUB + frozen_ground = .true. + END IF + GAMMAG = CPAIR*SFCPRS/(0.622*LATHEAG) + +! IF (SFCTMP .GT. TFRZ) THEN +! LATHEA = HVAP +! ELSE +! LATHEA = HSUB +! END IF +! GAMMA = CPAIR*SFCPRS/(0.622*LATHEA) - IF(CANICE.GT.0.) THEN - FWET = MAX(0.,CANICE) / MAX(MAXSNO,1.E-06) - ELSE - FWET = MAX(0.,CANLIQ) / MAX(MAXLIQ,1.E-06) - ENDIF - FWET = MIN(FWET, 1.) ** 0.667 +! Surface temperatures of the ground and canopy and energy fluxes -! total canopy water + IF (VEG .AND. FVEG > 0) THEN + TGV = TG + CMV = CM + CHV = CH + CALL VEGE_FLUX (parameters,NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in + DT ,SAV ,SAG ,LWDN ,UR , & !in + UU ,VV ,SFCTMP ,THAIR ,QAIR , & !in + EAIR ,RHOAIR ,SNOWH ,VAI ,GAMMAV ,GAMMAG , & !in + FWET ,LAISUN ,LAISHA ,CWP ,DZSNSO , & !in + ZLVL ,ZPD ,Z0M ,FVEG , & !in + Z0MG ,EMV ,EMG ,CANLIQ ,FSNO, & !in + CANICE ,STC ,DF ,RSSUN ,RSSHA , & !in + RSURF ,LATHEAV ,LATHEAG ,PARSUN ,PARSHA ,IGS , & !in + FOLN ,CO2AIR ,O2AIR ,BTRAN ,SFCPRS , & !in + RHSUR ,ILOC ,JLOC ,Q2 ,PAHV ,PAHG , & !in + EAH ,TAH ,TV ,TGV ,CMV , & !inout + CHV ,DX ,DZ8W , & !inout + TAUXV ,TAUYV ,IRG ,IRC ,SHG , & !out + SHC ,EVG ,EVC ,TR ,GHV , & !out + T2MV ,PSNSUN ,PSNSHA , & !out +!jref:start + QC ,QSFC ,PSFC , & !in + Q2V ,CHV2, CHLEAF, CHUC) !inout +!jref:end + END IF - CMC = CANLIQ + CANICE + TGB = TG + CMB = CM + CHB = CH + CALL BARE_FLUX (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in + LWDN ,UR ,UU ,VV ,SFCTMP , & !in + THAIR ,QAIR ,EAIR ,RHOAIR ,SNOWH , & !in + DZSNSO ,ZLVL ,ZPDG ,Z0MG ,FSNO, & !in + EMG ,STC ,DF ,RSURF ,LATHEAG , & !in + GAMMAG ,RHSUR ,ILOC ,JLOC ,Q2 ,PAHB , & !in + TGB ,CMB ,CHB , & !inout + TAUXB ,TAUYB ,IRB ,SHB ,EVB , & !out + GHB ,T2MB ,DX ,DZ8W ,VEGTYP , & !out +!jref:start + QC ,QSFC ,PSFC , & !in + SFCPRS ,Q2B, CHB2) !in +!jref:end -! heat transported by snow/ice +!energy balance at vege canopy: SAV =(IRC+SHC+EVC+TR) *FVEG at FVEG +!energy balance at vege ground: SAG* FVEG =(IRG+SHG+EVG+GHV) *FVEG at FVEG +!energy balance at bare ground: SAG*(1.-FVEG)=(IRB+SHB+EVB+GHB)*(1.-FVEG) at 1-FVEG - PAH_AC = PAH_AC + FVEG * SNOW * (CICE/1000.0) * (SFCTMP - TV) - PAH_CG = PAH_CG + QDRIPS * (CICE/1000.0) * (TV - TG) - PAH_AG = PAH_AG + QTHROS * (CICE/1000.0) * (SFCTMP - TG) - - PAHV = PAH_AC - PAH_CG - PAHG = PAH_CG - PAHB = PAH_AG - - IF (FVEG > 0.0 .AND. FVEG < 1.0) THEN - PAHG = PAHG / FVEG ! these will be multiplied by fraction later - PAHB = PAHB / (1.0-FVEG) - ELSEIF (FVEG <= 0.0) THEN - PAHB = PAHG + PAHB ! for case of canopy getting buried - PAHG = 0.0 - PAHV = 0.0 - ELSEIF (FVEG >= 1.0) THEN - PAHB = 0.0 - END IF - - PAHV = MAX(PAHV,-20.0) ! Put some artificial limits here for stability - PAHV = MIN(PAHV,20.0) - PAHG = MAX(PAHG,-20.0) - PAHG = MIN(PAHG,20.0) - PAHB = MAX(PAHB,-20.0) - PAHB = MIN(PAHB,20.0) - -! print*, 'precip_heat sfctmp,tv,tg:',sfctmp,tv,tg -! print*, 'precip_heat 3600.0*qints+qdrips+qthros:',3600.0*(qints+qdrips+qthros) -! print*, "precip_heat maxsno:",maxsno -! print*, "precip_heat PAH_AC:",PAH_AC -! print*, "precip_heat PAH_CG:",PAH_CG -! print*, "precip_heat PAH_AG:",PAH_AG - -! print*, "precip_heat PAHV:",PAHV -! print*, "precip_heat PAHG:",PAHG -! print*, "precip_heat PAHB:",PAHB -! print*, "precip_heat fveg:",fveg -! print*, "precip_heat qints*3600.0:",qints*3600.0 -! print*, "precip_heat qdrips*3600.0:",qdrips*3600.0 -! print*, "precip_heat qthros*3600.0:",qthros*3600.0 - -! rain or snow on the ground + IF (VEG .AND. FVEG > 0) THEN + TAUX = FVEG * TAUXV + (1.0 - FVEG) * TAUXB + TAUY = FVEG * TAUYV + (1.0 - FVEG) * TAUYB + FIRA = FVEG * IRG + (1.0 - FVEG) * IRB + IRC + FSH = FVEG * SHG + (1.0 - FVEG) * SHB + SHC + FGEV = FVEG * EVG + (1.0 - FVEG) * EVB + SSOIL = FVEG * GHV + (1.0 - FVEG) * GHB + FCEV = EVC + FCTR = TR + PAH = FVEG * PAHG + (1.0 - FVEG) * PAHB + PAHV + TG = FVEG * TGV + (1.0 - FVEG) * TGB + T2M = FVEG * T2MV + (1.0 - FVEG) * T2MB + TS = FVEG * TV + (1.0 - FVEG) * TGB + CM = FVEG * CMV + (1.0 - FVEG) * CMB ! better way to average? + CH = FVEG * CHV + (1.0 - FVEG) * CHB + Q1 = FVEG * (EAH*0.622/(SFCPRS - 0.378*EAH)) + (1.0 - FVEG)*QSFC + Q2E = FVEG * Q2V + (1.0 - FVEG) * Q2B + Z0WRF = Z0M + ELSE + TAUX = TAUXB + TAUY = TAUYB + FIRA = IRB + FSH = SHB + FGEV = EVB + SSOIL = GHB + TG = TGB + T2M = T2MB + FCEV = 0. + FCTR = 0. + PAH = PAHB + TS = TG + CM = CMB + CH = CHB + Q1 = QSFC + Q2E = Q2B + RSSUN = 0.0 + RSSHA = 0.0 + TGV = TGB + CHV = CHB + Z0WRF = Z0MG + END IF - QRAIN = QDRIPR + QTHROR - QSNOW = QDRIPS + QTHROS - SNOWHIN = QSNOW/BDFALL + FIRE = LWDN + FIRA - IF (IST == 2 .AND. TG > TFRZ) THEN - QSNOW = 0. - SNOWHIN = 0. - END IF -! print*, "precip_heat qsnow*3600.0:",qsnow*3600.0 -! print*, "precip_heat qrain*3600.0:",qrain*3600.0 -! print*, "precip_heat SNOWHIN:",SNOWHIN -! print*, "precip_heat canice:",canice -! print*, "precip_heat canliq:",canliq -! print*, "precip_heat end canopy balance:",canliq+canice+(qrain+qsnow)*dt - + IF(FIRE <=0.) THEN + WRITE(6,*) 'emitted longwave <0; skin T may be wrong due to inconsistent' + WRITE(6,*) 'input of SHDFAC with LAI' + WRITE(6,*) ILOC, JLOC, 'SHDFAC=',FVEG,'VAI=',VAI,'TV=',TV,'TG=',TG + WRITE(6,*) 'LWDN=',LWDN,'FIRA=',FIRA,'SNOWH=',SNOWH + call wrf_error_fatal("STOP in Noah-MP") + END IF - END SUBROUTINE PRECIP_HEAT + ! Compute a net emissivity + EMISSI = FVEG * ( EMG*(1-EMV) + EMV + EMV*(1-EMV)*(1-EMG) ) + & + (1-FVEG) * EMG -!== begin error ==================================================================================== + ! When we're computing a TRAD, subtract from the emitted IR the + ! reflected portion of the incoming LWDN, so we're just + ! considering the IR originating in the canopy/ground system. + + TRAD = ( ( FIRE - (1-EMISSI)*LWDN ) / (EMISSI*SB) ) ** 0.25 - SUBROUTINE ERROR (SWDOWN ,FSA ,FSR ,FIRA ,FSH ,FCEV , & - FGEV ,FCTR ,SSOIL ,BEG_WB ,CANLIQ ,CANICE , & - SNEQV ,WA ,SMC ,DZSNSO ,PRCP ,ECAN , & - ETRAN ,EDIR ,RUNSRF ,RUNSUB ,DT ,NSOIL , & - NSNOW ,IST ,ERRWAT, ILOC ,JLOC ,FVEG , & - SAV ,SAG ,FSRV ,FSRG ,ZWT ,PAH , & - PAHV ,PAHG ,PAHB ) -! -------------------------------------------------------------------------------------------------- -! check surface energy balance and water balance -! -------------------------------------------------------------------------------------------------- - IMPLICIT NONE -! -------------------------------------------------------------------------------------------------- -! inputs - INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER , INTENT(IN) :: NSOIL !number of soil layers - INTEGER , INTENT(IN) :: IST !surface type 1->soil; 2->lake - INTEGER , INTENT(IN) :: ILOC !grid index - INTEGER , INTENT(IN) :: JLOC !grid index - REAL , INTENT(IN) :: SWDOWN !downward solar filtered by sun angle [w/m2] - REAL , INTENT(IN) :: FSA !total absorbed solar radiation (w/m2) - REAL , INTENT(IN) :: FSR !total reflected solar radiation (w/m2) - REAL , INTENT(IN) :: FIRA !total net longwave rad (w/m2) [+ to atm] - REAL , INTENT(IN) :: FSH !total sensible heat (w/m2) [+ to atm] - REAL , INTENT(IN) :: FCEV !canopy evaporation heat (w/m2) [+ to atm] - REAL , INTENT(IN) :: FGEV !ground evaporation heat (w/m2) [+ to atm] - REAL , INTENT(IN) :: FCTR !transpiration heat flux (w/m2) [+ to atm] - REAL , INTENT(IN) :: SSOIL !ground heat flux (w/m2) [+ to soil] - REAL , INTENT(IN) :: FVEG - REAL , INTENT(IN) :: SAV - REAL , INTENT(IN) :: SAG - REAL , INTENT(IN) :: FSRV - REAL , INTENT(IN) :: FSRG - REAL , INTENT(IN) :: ZWT + ! Old TRAD calculation not taking into account Emissivity: + ! TRAD = (FIRE/SB)**0.25 - REAL , INTENT(IN) :: PRCP !precipitation rate (kg m-2 s-1) - REAL , INTENT(IN) :: ECAN !evaporation of intercepted water (mm/s) - REAL , INTENT(IN) :: ETRAN !transpiration rate (mm/s) - REAL , INTENT(IN) :: EDIR !soil surface evaporation rate[mm/s] - REAL , INTENT(IN) :: RUNSRF !surface runoff [mm/s] - REAL , INTENT(IN) :: RUNSUB !baseflow (saturation excess) [mm/s] - REAL , INTENT(IN) :: CANLIQ !intercepted liquid water (mm) - REAL , INTENT(IN) :: CANICE !intercepted ice mass (mm) - REAL , INTENT(IN) :: SNEQV !snow water eqv. [mm] - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice + liq.) [m3/m3] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] - REAL , INTENT(IN) :: WA !water storage in aquifer [mm] - REAL , INTENT(IN) :: DT !time step [sec] - REAL , INTENT(IN) :: BEG_WB !water storage at begin of a timesetp [mm] - REAL , INTENT(OUT) :: ERRWAT !error in water balance [mm/timestep] - REAL, INTENT(IN) :: PAH !precipitation advected heat - total (W/m2) - REAL, INTENT(IN) :: PAHV !precipitation advected heat - total (W/m2) - REAL, INTENT(IN) :: PAHG !precipitation advected heat - total (W/m2) - REAL, INTENT(IN) :: PAHB !precipitation advected heat - total (W/m2) + APAR = PARSUN*LAISUN + PARSHA*LAISHA + PSN = PSNSUN*LAISUN + PSNSHA*LAISHA - INTEGER :: IZ !do-loop index - REAL :: END_WB !water storage at end of a timestep [mm] - !KWM REAL :: ERRWAT !error in water balance [mm/timestep] - REAL :: ERRENG !error in surface energy balance [w/m2] - REAL :: ERRSW !error in shortwave radiation balance [w/m2] - REAL :: FSRVG - CHARACTER(len=256) :: message -! -------------------------------------------------------------------------------------------------- -!jref:start - ERRSW = SWDOWN - (FSA + FSR) -! ERRSW = SWDOWN - (SAV+SAG + FSRV+FSRG) -! WRITE(*,*) "ERRSW =",ERRSW - IF (ABS(ERRSW) > 0.01) THEN ! w/m2 - WRITE(*,*) "VEGETATION!" - WRITE(*,*) "SWDOWN*FVEG =",SWDOWN*FVEG - WRITE(*,*) "FVEG*(SAV+SAG) =",FVEG*SAV + SAG - WRITE(*,*) "FVEG*(FSRV +FSRG)=",FVEG*FSRV + FSRG - WRITE(*,*) "GROUND!" - WRITE(*,*) "(1-.FVEG)*SWDOWN =",(1.-FVEG)*SWDOWN - WRITE(*,*) "(1.-FVEG)*SAG =",(1.-FVEG)*SAG - WRITE(*,*) "(1.-FVEG)*FSRG=",(1.-FVEG)*FSRG - WRITE(*,*) "FSRV =",FSRV - WRITE(*,*) "FSRG =",FSRG - WRITE(*,*) "FSR =",FSR - WRITE(*,*) "SAV =",SAV - WRITE(*,*) "SAG =",SAG - WRITE(*,*) "FSA =",FSA -!jref:end - WRITE(message,*) 'ERRSW =',ERRSW - call wrf_message(trim(message)) - call wrf_error_fatal("Stop in Noah-MP") - END IF +! 3L snow & 4L soil temperatures - ERRENG = SAV+SAG-(FIRA+FSH+FCEV+FGEV+FCTR+SSOIL) +PAH -! ERRENG = FVEG*SAV+SAG-(FIRA+FSH+FCEV+FGEV+FCTR+SSOIL) -! WRITE(*,*) "ERRENG =",ERRENG - IF(ABS(ERRENG) > 0.01) THEN - write(message,*) 'ERRENG =',ERRENG,' at i,j: ',ILOC,JLOC - call wrf_message(trim(message)) - WRITE(message,'(a17,F10.4)') "Net solar: ",FSA - call wrf_message(trim(message)) - WRITE(message,'(a17,F10.4)') "Net longwave: ",FIRA - call wrf_message(trim(message)) - WRITE(message,'(a17,F10.4)') "Total sensible: ",FSH - call wrf_message(trim(message)) - WRITE(message,'(a17,F10.4)') "Canopy evap: ",FCEV - call wrf_message(trim(message)) - WRITE(message,'(a17,F10.4)') "Ground evap: ",FGEV - call wrf_message(trim(message)) - WRITE(message,'(a17,F10.4)') "Transpiration: ",FCTR - call wrf_message(trim(message)) - WRITE(message,'(a17,F10.4)') "Total ground: ",SSOIL - call wrf_message(trim(message)) - WRITE(message,'(a17,4F10.4)') "Precip advected: ",PAH,PAHV,PAHG,PAHB - call wrf_message(trim(message)) - WRITE(message,'(a17,F10.4)') "Precip: ",PRCP - call wrf_message(trim(message)) - WRITE(message,'(a17,F10.4)') "Veg fraction: ",FVEG - call wrf_message(trim(message)) - call wrf_error_fatal("Energy budget problem in NOAHMP LSM") - END IF + CALL TSNOSOI (parameters,ICE ,NSOIL ,NSNOW ,ISNOW ,IST , & !in + TBOT ,ZSNSO ,SSOIL ,DF ,HCPCT , & !in + SAG ,DT ,SNOWH ,DZSNSO , & !in + TG ,ILOC ,JLOC , & !in + STC ) !inout - IF (IST == 1) THEN !soil - END_WB = CANLIQ + CANICE + SNEQV + WA - DO IZ = 1,NSOIL - END_WB = END_WB + SMC(IZ) * DZSNSO(IZ) * 1000. - END DO - ERRWAT = END_WB-BEG_WB-(PRCP-ECAN-ETRAN-EDIR-RUNSRF-RUNSUB)*DT +! adjusting snow surface temperature + IF(OPT_STC == 2) THEN + IF (SNOWH > 0.05 .AND. TG > TFRZ) THEN + TGV = TFRZ + TGB = TFRZ + IF (VEG .AND. FVEG > 0) THEN + TG = FVEG * TGV + (1.0 - FVEG) * TGB + TS = FVEG * TV + (1.0 - FVEG) * TGB + ELSE + TG = TGB + TS = TGB + END IF + END IF + END IF -#ifndef WRF_HYDRO - IF(ABS(ERRWAT) > 0.1) THEN - if (ERRWAT > 0) then - call wrf_message ('The model is gaining water (ERRWAT is positive)') - else - call wrf_message('The model is losing water (ERRWAT is negative)') - endif - write(message, *) 'ERRWAT =',ERRWAT, "kg m{-2} timestep{-1}" - call wrf_message(trim(message)) - WRITE(message, & - '(" I J END_WB BEG_WB PRCP ECAN EDIR ETRAN RUNSRF RUNSUB")') - call wrf_message(trim(message)) - WRITE(message,'(i6,1x,i6,1x,2f15.3,9f11.5)')ILOC,JLOC,END_WB,BEG_WB,PRCP*DT,ECAN*DT,& - EDIR*DT,ETRAN*DT,RUNSRF*DT,RUNSUB*DT,ZWT - call wrf_message(trim(message)) - call wrf_error_fatal("Water budget problem in NOAHMP LSM") - END IF -#endif - ELSE !KWM - ERRWAT = 0.0 !KWM - ENDIF +! Energy released or consumed by snow & frozen soil - END SUBROUTINE ERROR + CALL PHASECHANGE (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in + DZSNSO ,HCPCT ,IST ,ILOC ,JLOC , & !in + STC ,SNICE ,SNLIQ ,SNEQV ,SNOWH , & !inout + SMC ,SH2O , & !inout + QMELT ,IMELT ,PONDING ) !out -!== begin energy =================================================================================== - SUBROUTINE ENERGY (ICE ,VEGTYP ,IST ,NSNOW ,NSOIL , & !in - ISNOW ,DT ,RHOAIR ,SFCPRS ,QAIR , & !in - SFCTMP ,THAIR ,LWDN ,UU ,VV ,ZREF , & !in - CO2AIR ,O2AIR ,SOLAD ,SOLAI ,COSZ ,IGS , & !in - EAIR ,TBOT ,ZSNSO ,ZSOIL , & !in - ELAI ,ESAI ,FWET ,FOLN , & !in - FVEG ,PAHV ,PAHG ,PAHB , & !in - QSNOW ,DZSNSO ,LAT ,CANLIQ ,CANICE ,ILOC , JLOC, & !in - Z0WRF , & - IMELT ,SNICEV ,SNLIQV ,EPORE ,T2M ,FSNO , & !out - SAV ,SAG ,QMELT ,FSA ,FSR ,TAUX , & !out - TAUY ,FIRA ,FSH ,FCEV ,FGEV ,FCTR , & !out - TRAD ,PSN ,APAR ,SSOIL ,BTRANI ,BTRAN , & !out - PONDING,TS ,LATHEAV , LATHEAG , frozen_canopy,frozen_ground, & !out - TV ,TG ,STC ,SNOWH ,EAH ,TAH , & !inout - SNEQVO ,SNEQV ,SH2O ,SMC ,SNICE ,SNLIQ , & !inout - ALBOLD ,CM ,CH ,DX ,DZ8W ,Q2 , & !inout - TAUSS , & !inout -!jref:start - QC ,QSFC ,PSFC , & !in - T2MV ,T2MB ,FSRV , & - FSRG ,RSSUN ,RSSHA ,BGAP ,WGAP,TGV,TGB,& - Q1 ,Q2V ,Q2B ,Q2E ,CHV ,CHB, EMISSI,PAH ,& - SHG,SHC,SHB,EVG,EVB,GHV,GHB,IRG,IRC,IRB,TR,EVC,CHLEAF,CHUC,CHV2,CHB2 ) !out -!jref:end + END SUBROUTINE ENERGY -! -------------------------------------------------------------------------------------------------- -! we use different approaches to deal with subgrid features of radiation transfer and turbulent -! transfer. We use 'tile' approach to compute turbulent fluxes, while we use modified two- -! stream to compute radiation transfer. Tile approach, assemblying vegetation canopies together, -! may expose too much ground surfaces (either covered by snow or grass) to solar radiation. The -! modified two-stream assumes vegetation covers fully the gridcell but with gaps between tree -! crowns. -! -------------------------------------------------------------------------------------------------- -! turbulence transfer : 'tile' approach to compute energy fluxes in vegetated fraction and -! bare fraction separately and then sum them up weighted by fraction -! -------------------------------------- -! / O O O O O O O O / / -! / | | | | | | | | / / -! / O O O O O O O O / / -! / | | |tile1| | | | / tile2 / -! / O O O O O O O O / bare / -! / | | | vegetated | | / / -! / O O O O O O O O / / -! / | | | | | | | | / / -! -------------------------------------- -! -------------------------------------------------------------------------------------------------- -! radiation transfer : modified two-stream (Yang and Friedl, 2003, JGR; Niu ang Yang, 2004, JGR) -! -------------------------------------- two-stream treats leaves as -! / O O O O O O O O / cloud over the entire grid-cell, -! / | | | | | | | | / while the modified two-stream -! / O O O O O O O O / aggregates cloudy leaves into -! / | | | | | | | | / tree crowns with gaps (as shown in -! / O O O O O O O O / the left figure). We assume these -! / | | | | | | | | / tree crowns are evenly distributed -! / O O O O O O O O / within the gridcell with 100% veg -! / | | | | | | | | / fraction, but with gaps. The 'tile' -! -------------------------------------- approach overlaps too much shadows. -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX, SMCREF, SMCWLT, & ! SOIL DEPENDENT - HVT, Z0MVT, CWPVT, NROOT, & ! VEGETATION DEPENDENT - EG, & ! SURFACE DEPENDENT - Z0SNO, MFSNO, & ! SNOW GLOBAL - GRAV, SB, TFRZ, RW, HVAP, HSUB, CPAIR, & ! MP CONSTANT - ISURBAN ! MP CONSTANT -! -------------------------------------------------------------------------------------------------- +!== begin thermoprop =============================================================================== + + SUBROUTINE THERMOPROP (parameters,NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , & !in + DT ,SNOWH ,SNICE ,SNLIQ , & !in + SMC ,SH2O ,TG ,STC ,UR , & !in + LAT ,Z0M ,ZLVL ,VEGTYP , & !in + DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , & !out + FACT ) !out +! ------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! inputs - integer , INTENT(IN) :: ILOC - integer , INTENT(IN) :: JLOC - INTEGER , INTENT(IN) :: ICE !ice (ice = 1) - INTEGER , INTENT(IN) :: VEGTYP !vegetation physiology type - INTEGER , INTENT(IN) :: IST !surface type: 1->soil; 2->lake - INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER , INTENT(IN) :: NSOIL !number of soil layers - INTEGER , INTENT(IN) :: ISNOW !actual no. of snow layers - REAL , INTENT(IN) :: DT !time step [sec] - REAL , INTENT(IN) :: QSNOW !snowfall on the ground (mm/s) - REAL , INTENT(IN) :: RHOAIR !density air (kg/m3) - REAL , INTENT(IN) :: EAIR !vapor pressure air (pa) - REAL , INTENT(IN) :: SFCPRS !pressure (pa) - REAL , INTENT(IN) :: QAIR !specific humidity (kg/kg) - REAL , INTENT(IN) :: SFCTMP !air temperature (k) - REAL , INTENT(IN) :: THAIR !potential temperature (k) - REAL , INTENT(IN) :: LWDN !downward longwave radiation (w/m2) - REAL , INTENT(IN) :: UU !wind speed in e-w dir (m/s) - REAL , INTENT(IN) :: VV !wind speed in n-s dir (m/s) - REAL , DIMENSION( 1: 2), INTENT(IN) :: SOLAD !incoming direct solar rad. (w/m2) - REAL , DIMENSION( 1: 2), INTENT(IN) :: SOLAI !incoming diffuse solar rad. (w/m2) - REAL , INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) - REAL , INTENT(IN) :: ELAI !LAI adjusted for burying by snow - REAL , INTENT(IN) :: ESAI !LAI adjusted for burying by snow - REAL , INTENT(IN) :: FWET !fraction of canopy that is wet [-] - REAL , INTENT(IN) :: FVEG !greeness vegetation fraction (-) - REAL , INTENT(IN) :: LAT !latitude (radians) - REAL , INTENT(IN) :: CANLIQ !canopy-intercepted liquid water (mm) - REAL , INTENT(IN) :: CANICE !canopy-intercepted ice mass (mm) - REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) - REAL , INTENT(IN) :: CO2AIR !atmospheric co2 concentration (pa) - REAL , INTENT(IN) :: O2AIR !atmospheric o2 concentration (pa) - REAL , INTENT(IN) :: IGS !growing season index (0=off, 1=on) - - REAL , INTENT(IN) :: ZREF !reference height (m) - REAL , INTENT(IN) :: TBOT !bottom condition for soil temp. (k) - REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !layer-bottom depth from snow surf [m] - REAL , DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !layer-bottom depth from soil surf [m] - REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !depth of snow & soil layer-bottom [m] - REAL, INTENT(IN) :: PAHV !precipitation advected heat - vegetation net (W/m2) - REAL, INTENT(IN) :: PAHG !precipitation advected heat - under canopy net (W/m2) - REAL, INTENT(IN) :: PAHB !precipitation advected heat - bare ground net (W/m2) - -!jref:start; in - REAL , INTENT(IN) :: QC !cloud water mixing ratio - REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer - REAL , INTENT(IN) :: PSFC !pressure at lowest model layer - REAL , INTENT(IN) :: DX !horisontal resolution - REAL , INTENT(IN) :: DZ8W !thickness of lowest layer - REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) -!jref:end + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: ISNOW !actual no. of snow layers + INTEGER , INTENT(IN) :: IST !surface type + REAL , INTENT(IN) :: DT !time step [s] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow ice mass (kg/m2) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow liq mass (kg/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thickness of snow/soil layers [m] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SH2O !liquid soil moisture [m3/m3] + REAL , INTENT(IN) :: SNOWH !snow height [m] + REAL, INTENT(IN) :: TG !surface temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil/lake temp. (k) + REAL, INTENT(IN) :: UR !wind speed at ZLVL (m/s) + REAL, INTENT(IN) :: LAT !latitude (radians) + REAL, INTENT(IN) :: Z0M !roughness length (m) + REAL, INTENT(IN) :: ZLVL !reference height (m) + INTEGER , INTENT(IN) :: VEGTYP !vegtyp type ! outputs - REAL , INTENT(OUT) :: Z0WRF !combined z0 sent to coupled model - INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT !phase change index [1-melt; 2-freeze] - REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume ice [m3/m3] - REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume liq. water [m3/m3] - REAL , DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] - REAL , INTENT(OUT) :: FSNO !snow cover fraction (-) - REAL , INTENT(OUT) :: QMELT !snowmelt [mm/s] - REAL , INTENT(OUT) :: PONDING!pounding at ground [mm] - REAL , INTENT(OUT) :: SAV !solar rad. absorbed by veg. (w/m2) - REAL , INTENT(OUT) :: SAG !solar rad. absorbed by ground (w/m2) - REAL , INTENT(OUT) :: FSA !tot. absorbed solar radiation (w/m2) - REAL , INTENT(OUT) :: FSR !tot. reflected solar radiation (w/m2) - REAL , INTENT(OUT) :: TAUX !wind stress: e-w (n/m2) - REAL , INTENT(OUT) :: TAUY !wind stress: n-s (n/m2) - REAL , INTENT(OUT) :: FIRA !total net LW. rad (w/m2) [+ to atm] - REAL , INTENT(OUT) :: FSH !total sensible heat (w/m2) [+ to atm] - REAL , INTENT(OUT) :: FCEV !canopy evaporation (w/m2) [+ to atm] - REAL , INTENT(OUT) :: FGEV !ground evaporation (w/m2) [+ to atm] - REAL , INTENT(OUT) :: FCTR !transpiration (w/m2) [+ to atm] - REAL , INTENT(OUT) :: TRAD !radiative temperature (k) - REAL , INTENT(OUT) :: T2M !2 m height air temperature (k) - REAL , INTENT(OUT) :: PSN !total photosyn. (umolco2/m2/s) [+] - REAL , INTENT(OUT) :: APAR !total photosyn. active energy (w/m2) - REAL , INTENT(OUT) :: SSOIL !ground heat flux (w/m2) [+ to soil] - REAL , DIMENSION( 1:NSOIL), INTENT(OUT) :: BTRANI !soil water transpiration factor (0-1) - REAL , INTENT(OUT) :: BTRAN !soil water transpiration factor (0-1) -! REAL , INTENT(OUT) :: LATHEA !latent heat vap./sublimation (j/kg) - REAL , INTENT(OUT) :: LATHEAV !latent heat vap./sublimation (j/kg) - REAL , INTENT(OUT) :: LATHEAG !latent heat vap./sublimation (j/kg) - LOGICAL , INTENT(OUT) :: FROZEN_GROUND ! used to define latent heat pathway - LOGICAL , INTENT(OUT) :: FROZEN_CANOPY ! used to define latent heat pathway + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: DF !thermal conductivity [w/m/k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: HCPCT !heat capacity [j/m3/k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume of ice [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume of liquid water [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: FACT !computing energy for phase change +! -------------------------------------------------------------------------------------------------- +! locals + + INTEGER :: IZ + REAL, DIMENSION(-NSNOW+1: 0) :: CVSNO !volumetric specific heat (j/m3/k) + REAL, DIMENSION(-NSNOW+1: 0) :: TKSNO !snow thermal conductivity (j/m3/k) + REAL, DIMENSION( 1:NSOIL) :: SICE !soil ice content +! -------------------------------------------------------------------------------------------------- -!jref:start - REAL , INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) - REAL , INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) - REAL, INTENT(OUT) :: RSSUN !sunlit leaf stomatal resistance (s/m) - REAL, INTENT(OUT) :: RSSHA !shaded leaf stomatal resistance (s/m) -!jref:end - out for debug +! compute snow thermal conductivity and heat capacity -!jref:start; output - REAL , INTENT(OUT) :: T2MV !2-m air temperature over vegetated part [k] - REAL , INTENT(OUT) :: T2MB !2-m air temperature over bare ground part [k] - REAL , INTENT(OUT) :: BGAP - REAL , INTENT(OUT) :: WGAP -!jref:end + CALL CSNOW (parameters,ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , & !in + TKSNO ,CVSNO ,SNICEV ,SNLIQV ,EPORE ) !out -! input & output - REAL , INTENT(INOUT) :: TS !surface temperature (k) - REAL , INTENT(INOUT) :: TV !vegetation temperature (k) - REAL , INTENT(INOUT) :: TG !ground temperature (k) - REAL , DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil temperature [k] - REAL , INTENT(INOUT) :: SNOWH !snow height [m] - REAL , INTENT(INOUT) :: SNEQV !snow mass (mm) - REAL , INTENT(INOUT) :: SNEQVO !snow mass at last time step (mm) - REAL , DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !liquid soil moisture [m3/m3] - REAL , DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !soil moisture (ice + liq.) [m3/m3] - REAL , DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow ice mass (kg/m2) - REAL , DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow liq mass (kg/m2) - REAL , INTENT(INOUT) :: EAH !canopy air vapor pressure (pa) - REAL , INTENT(INOUT) :: TAH !canopy air temperature (k) - REAL , INTENT(INOUT) :: ALBOLD !snow albedo at last time step(CLASS type) - REAL , INTENT(INOUT) :: TAUSS !non-dimensional snow age - REAL , INTENT(INOUT) :: CM !momentum drag coefficient - REAL , INTENT(INOUT) :: CH !sensible heat exchange coefficient - REAL , INTENT(INOUT) :: Q1 -! REAL :: Q2E - REAL, INTENT(OUT) :: EMISSI - REAL, INTENT(OUT) :: PAH !precipitation advected heat - total (W/m2) + DO IZ = ISNOW+1, 0 + DF (IZ) = TKSNO(IZ) + HCPCT(IZ) = CVSNO(IZ) + END DO -! local - INTEGER :: IZ !do-loop index - LOGICAL :: VEG !true if vegetated surface - REAL :: UR !wind speed at height ZLVL (m/s) - REAL :: ZLVL !reference height (m) - REAL :: FSUN !sunlit fraction of canopy [-] - REAL :: RB !leaf boundary layer resistance (s/m) - REAL :: RSURF !ground surface resistance (s/m) - REAL :: L_RSURF!Dry-layer thickness for computing RSURF (Sakaguchi and Zeng, 2009) - REAL :: D_RSURF!Reduced vapor diffusivity in soil for computing RSURF (SZ09) - REAL :: BEVAP !soil water evaporation factor (0- 1) - REAL :: MOL !Monin-Obukhov length (m) - REAL :: VAI !sum of LAI + stem area index [m2/m2] - REAL :: CWP !canopy wind extinction parameter - REAL :: ZPD !zero plane displacement (m) - REAL :: Z0M !z0 momentum (m) - REAL :: ZPDG !zero plane displacement (m) - REAL :: Z0MG !z0 momentum, ground (m) - REAL :: EMV !vegetation emissivity - REAL :: EMG !ground emissivity - REAL :: FIRE !emitted IR (w/m2) +! compute soil thermal properties - REAL :: LAISUN !sunlit leaf area index (m2/m2) - REAL :: LAISHA !shaded leaf area index (m2/m2) - REAL :: PSNSUN !sunlit photosynthesis (umolco2/m2/s) - REAL :: PSNSHA !shaded photosynthesis (umolco2/m2/s) -!jref:start - for debug -! REAL :: RSSUN !sunlit stomatal resistance (s/m) -! REAL :: RSSHA !shaded stomatal resistance (s/m) -!jref:end - for debug - REAL :: PARSUN !par absorbed per sunlit LAI (w/m2) - REAL :: PARSHA !par absorbed per shaded LAI (w/m2) + DO IZ = 1, NSOIL + SICE(IZ) = SMC(IZ) - SH2O(IZ) + HCPCT(IZ) = SH2O(IZ)*CWAT + (1.0-parameters%SMCMAX(IZ))*parameters%CSOIL & + + (parameters%SMCMAX(IZ)-SMC(IZ))*CPAIR + SICE(IZ)*CICE + CALL TDFCND (parameters,IZ,DF(IZ), SMC(IZ), SH2O(IZ)) + END DO + + IF ( parameters%urban_flag ) THEN + DO IZ = 1,NSOIL + DF(IZ) = 3.24 + END DO + ENDIF - REAL, DIMENSION(-NSNOW+1:NSOIL) :: FACT !temporary used in phase change - REAL, DIMENSION(-NSNOW+1:NSOIL) :: DF !thermal conductivity [w/m/k] - REAL, DIMENSION(-NSNOW+1:NSOIL) :: HCPCT !heat capacity [j/m3/k] - REAL :: BDSNO !bulk density of snow (kg/m3) - REAL :: FMELT !melting factor for snow cover frac - REAL :: GX !temporary variable - REAL, DIMENSION(-NSNOW+1:NSOIL) :: PHI !light through water (w/m2) -! REAL :: GAMMA !psychrometric constant (pa/k) - REAL :: GAMMAV !psychrometric constant (pa/k) - REAL :: GAMMAG !psychrometric constant (pa/k) - REAL :: PSI !surface layer soil matrix potential (m) - REAL :: RHSUR !raltive humidity in surface soil/snow air space (-) +! heat flux reduction effect from the overlying green canopy, adapted from +! section 2.1.2 of Peters-Lidard et al. (1997, JGR, VOL 102(D4)). +! not in use because of the separation of the canopy layer from the ground. +! but this may represent the effects of leaf litter (Niu comments) +! DF1 = DF1 * EXP (SBETA * SHDFAC) -! temperature and fluxes over vegetated fraction +! compute lake thermal properties +! (no consideration of turbulent mixing for this version) - REAL :: TAUXV !wind stress: e-w dir [n/m2] - REAL :: TAUYV !wind stress: n-s dir [n/m2] - REAL,INTENT(OUT) :: IRC !canopy net LW rad. [w/m2] [+ to atm] - REAL,INTENT(OUT) :: IRG !ground net LW rad. [w/m2] [+ to atm] - REAL,INTENT(OUT) :: SHC !canopy sen. heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: SHG !ground sen. heat [w/m2] [+ to atm] -!jref:start - REAL,INTENT(OUT) :: Q2V - REAL,INTENT(OUT) :: Q2B - REAL,INTENT(OUT) :: Q2E -!jref:end - REAL,INTENT(OUT) :: EVC !canopy evap. heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: EVG !ground evap. heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: TR !transpiration heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: GHV !ground heat flux [w/m2] [+ to soil] - REAL,INTENT(OUT) :: TGV !ground surface temp. [k] - REAL :: CMV !momentum drag coefficient - REAL,INTENT(OUT) :: CHV !sensible heat exchange coefficient + IF(IST == 2) THEN + DO IZ = 1, NSOIL + IF(STC(IZ) > TFRZ) THEN + HCPCT(IZ) = CWAT + DF(IZ) = TKWAT !+ KEDDY * CWAT + ELSE + HCPCT(IZ) = CICE + DF(IZ) = TKICE + END IF + END DO + END IF -! temperature and fluxes over bare soil fraction +! combine a temporary variable used for melting/freezing of snow and frozen soil - REAL :: TAUXB !wind stress: e-w dir [n/m2] - REAL :: TAUYB !wind stress: n-s dir [n/m2] - REAL,INTENT(OUT) :: IRB !net longwave rad. [w/m2] [+ to atm] - REAL,INTENT(OUT) :: SHB !sensible heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: EVB !evaporation heat [w/m2] [+ to atm] - REAL,INTENT(OUT) :: GHB !ground heat flux [w/m2] [+ to soil] - REAL,INTENT(OUT) :: TGB !ground surface temp. [k] - REAL :: CMB !momentum drag coefficient - REAL,INTENT(OUT) :: CHB !sensible heat exchange coefficient - REAL,INTENT(OUT) :: CHLEAF !leaf exchange coefficient - REAL,INTENT(OUT) :: CHUC !under canopy exchange coefficient -!jref:start - REAL,INTENT(OUT) :: CHV2 !sensible heat conductance, canopy air to ZLVL air (m/s) - REAL,INTENT(OUT) :: CHB2 !sensible heat conductance, canopy air to ZLVL air (m/s) - REAL :: noahmpres + DO IZ = ISNOW+1,NSOIL + FACT(IZ) = DT/(HCPCT(IZ)*DZSNSO(IZ)) + END DO -!jref:end +! snow/soil interface - REAL, PARAMETER :: MPE = 1.E-6 - REAL, PARAMETER :: PSIWLT = -150. !metric potential for wilting point (m) - REAL, PARAMETER :: Z0 = 0.01 ! Bare-soil roughness length (m) (i.e., under the canopy) + IF(ISNOW == 0) THEN + DF(1) = (DF(1)*DZSNSO(1)+0.35*SNOWH) / (SNOWH +DZSNSO(1)) + ELSE + DF(1) = (DF(1)*DZSNSO(1)+DF(0)*DZSNSO(0)) / (DZSNSO(0)+DZSNSO(1)) + END IF -! --------------------------------------------------------------------------------------------------- -! initialize fluxes from veg. fraction - TAUXV = 0. - TAUYV = 0. - IRC = 0. - SHC = 0. - IRG = 0. - SHG = 0. - EVG = 0. - EVC = 0. - TR = 0. - GHV = 0. - PSNSUN = 0. - PSNSHA = 0. - T2MV = 0. - Q2V = 0. - CHV = 0. - CHLEAF = 0. - CHUC = 0. - CHV2 = 0. + END SUBROUTINE THERMOPROP -! wind speed at reference height: ur >= 1 +!== begin csnow ==================================================================================== - UR = MAX( SQRT(UU**2.+VV**2.), 1. ) + SUBROUTINE CSNOW (parameters,ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , & !in + TKSNO ,CVSNO ,SNICEV ,SNLIQV ,EPORE ) !out +! -------------------------------------------------------------------------------------------------- +! Snow bulk density,volumetric capacity, and thermal conductivity +!--------------------------------------------------------------------------------------------------- + IMPLICIT NONE +!--------------------------------------------------------------------------------------------------- +! inputs -! vegetated or non-vegetated + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ISNOW !number of snow layers (-) + INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow ice mass (kg/m2) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow liq mass (kg/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] - VAI = ELAI + ESAI - VEG = .FALSE. - IF(VAI > 0.) VEG = .TRUE. +! outputs -! ground snow cover fraction [Niu and Yang, 2007, JGR] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: CVSNO !volumetric specific heat (j/m3/k) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: TKSNO !thermal conductivity (w/m/k) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume of ice [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume of liquid water [m3/m3] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] - FSNO = 0. - IF(SNOWH.GT.0.) THEN - BDSNO = SNEQV / SNOWH - FMELT = (BDSNO/100.)**MFSNO - FSNO = TANH( SNOWH /(2.5* Z0 * FMELT)) - ENDIF +! locals -! ground roughness length + INTEGER :: IZ + REAL, DIMENSION(-NSNOW+1: 0) :: BDSNOI !bulk density of snow(kg/m3) - IF(IST == 2) THEN - IF(TG .LE. TFRZ) THEN - Z0MG = 0.01 * (1.0-FSNO) + FSNO * Z0SNO - ELSE - Z0MG = 0.01 - END IF - ELSE - Z0MG = Z0 * (1.0-FSNO) + FSNO * Z0SNO - END IF +!--------------------------------------------------------------------------------------------------- +! thermal capacity of snow -! roughness length and displacement height + DO IZ = ISNOW+1, 0 + SNICEV(IZ) = MIN(1., SNICE(IZ)/(DZSNSO(IZ)*DENICE) ) + EPORE(IZ) = 1. - SNICEV(IZ) + SNLIQV(IZ) = MIN(EPORE(IZ),SNLIQ(IZ)/(DZSNSO(IZ)*DENH2O)) + ENDDO - ZPDG = SNOWH - IF(VEG) THEN - Z0M = Z0MVT - ZPD = 0.65 * HVT - IF(SNOWH.GT.ZPD) ZPD = SNOWH - ELSE - Z0M = Z0MG - ZPD = ZPDG - END IF + DO IZ = ISNOW+1, 0 + BDSNOI(IZ) = (SNICE(IZ)+SNLIQ(IZ))/DZSNSO(IZ) + CVSNO(IZ) = CICE*SNICEV(IZ)+CWAT*SNLIQV(IZ) +! CVSNO(IZ) = 0.525E06 ! constant + enddo + +! thermal conductivity of snow + + DO IZ = ISNOW+1, 0 + TKSNO(IZ) = 3.2217E-6*BDSNOI(IZ)**2. ! Stieglitz(yen,1965) +! TKSNO(IZ) = 2E-2+2.5E-6*BDSNOI(IZ)*BDSNOI(IZ) ! Anderson, 1976 +! TKSNO(IZ) = 0.35 ! constant +! TKSNO(IZ) = 2.576E-6*BDSNOI(IZ)**2. + 0.074 ! Verseghy (1991) +! TKSNO(IZ) = 2.22*(BDSNOI(IZ)/1000.)**1.88 ! Douvill(Yen, 1981) + ENDDO - ZLVL = MAX(ZPD,HVT) + ZREF - IF(ZPDG >= ZLVL) ZLVL = ZPDG + ZREF -! UR = UR*LOG(ZLVL/Z0M)/LOG(10./Z0M) !input UR is at 10m + END SUBROUTINE CSNOW -! canopy wind absorption coeffcient +!== begin tdfcnd =================================================================================== - CWP = CWPVT + SUBROUTINE TDFCND (parameters, ISOIL, DF, SMC, SH2O) +! -------------------------------------------------------------------------------------------------- +! Calculate thermal diffusivity and conductivity of the soil. +! Peters-Lidard approach (Peters-Lidard et al., 1998) +! -------------------------------------------------------------------------------------------------- +! Code history: +! June 2001 changes: frozen soil condition. +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ISOIL ! soil layer + REAL, INTENT(IN) :: SMC ! total soil water + REAL, INTENT(IN) :: SH2O ! liq. soil water + REAL, INTENT(OUT) :: DF ! thermal diffusivity -! Thermal properties of soil, snow, lake, and frozen soil +! local variables + REAL :: AKE + REAL :: GAMMD + REAL :: THKDRY + REAL :: THKO ! thermal conductivity for other soil components + REAL :: THKQTZ ! thermal conductivity for quartz + REAL :: THKSAT ! + REAL :: THKS ! thermal conductivity for the solids + REAL :: THKW ! water thermal conductivity + REAL :: SATRATIO + REAL :: XU + REAL :: XUNFROZ +! -------------------------------------------------------------------------------------------------- +! We now get quartz as an input argument (set in routine redprm): +! DATA QUARTZ /0.82, 0.10, 0.25, 0.60, 0.52, +! & 0.35, 0.60, 0.40, 0.82/ +! -------------------------------------------------------------------------------------------------- +! If the soil has any moisture content compute a partial sum/product +! otherwise use a constant value which works well with most soils +! -------------------------------------------------------------------------------------------------- +! QUARTZ ....QUARTZ CONTENT (SOIL TYPE DEPENDENT) +! -------------------------------------------------------------------------------------------------- +! USE AS IN PETERS-LIDARD, 1998 (MODIF. FROM JOHANSEN, 1975). - CALL THERMOPROP (NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , & !in - DT ,SNOWH ,SNICE ,SNLIQ , & !in - SMC ,SH2O ,TG ,STC ,UR , & !in - LAT ,Z0M ,ZLVL ,VEGTYP , & !in - DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , & !out - FACT ) !out +! PABLO GRUNMANN, 08/17/98 +! Refs.: +! Farouki, O.T.,1986: Thermal properties of soils. Series on Rock +! and Soil Mechanics, Vol. 11, Trans Tech, 136 pp. +! Johansen, O., 1975: Thermal conductivity of soils. PH.D. Thesis, +! University of Trondheim, +! Peters-Lidard, C. D., et al., 1998: The effect of soil thermal +! conductivity parameterization on surface energy fluxes +! and temperatures. Journal of The Atmospheric Sciences, +! Vol. 55, pp. 1209-1224. +! -------------------------------------------------------------------------------------------------- +! NEEDS PARAMETERS +! POROSITY(SOIL TYPE): +! POROS = SMCMAX +! SATURATION RATIO: +! PARAMETERS W/(M.K) + SATRATIO = SMC / parameters%SMCMAX(ISOIL) + THKW = 0.57 +! IF (QUARTZ .LE. 0.2) THKO = 3.0 + THKO = 2.0 +! SOLIDS' CONDUCTIVITY +! QUARTZ' CONDUCTIVITY + THKQTZ = 7.7 -! Solar radiation: absorbed & reflected by the ground and canopy +! UNFROZEN FRACTION (FROM 1., i.e., 100%LIQUID, TO 0. (100% FROZEN)) + THKS = (THKQTZ ** parameters%QUARTZ(ISOIL))* (THKO ** (1. - parameters%QUARTZ(ISOIL))) - CALL RADIATION (VEGTYP ,IST ,ICE ,NSOIL , & !in - SNEQVO ,SNEQV ,DT ,COSZ ,SNOWH , & !in - TG ,TV ,FSNO ,QSNOW ,FWET , & !in - ELAI ,ESAI ,SMC ,SOLAD ,SOLAI , & !in - FVEG ,ILOC ,JLOC , & !in - ALBOLD ,TAUSS , & !inout - FSUN ,LAISUN ,LAISHA ,PARSUN ,PARSHA , & !out - SAV ,SAG ,FSR ,FSA ,FSRV , & - FSRG ,BGAP ,WGAP ) !out +! UNFROZEN VOLUME FOR SATURATION (POROSITY*XUNFROZ) + XUNFROZ = SH2O / SMC +! SATURATED THERMAL CONDUCTIVITY + XU = XUNFROZ * parameters%SMCMAX(ISOIL) -! vegetation and ground emissivity +! DRY DENSITY IN KG/M3 + THKSAT = THKS ** (1. - parameters%SMCMAX(ISOIL))* TKICE ** (parameters%SMCMAX(ISOIL) - XU)* THKW ** & + (XU) - EMV = 1. - EXP(-(ELAI+ESAI)/1.0) - IF (ICE == 1) THEN - EMG = 0.98*(1.-FSNO) + 1.0*FSNO - ELSE - EMG = EG(IST)*(1.-FSNO) + 1.0*FSNO - END IF +! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 + GAMMD = (1. - parameters%SMCMAX(ISOIL))*2700. -! soil moisture factor controlling stomatal resistance - - BTRAN = 0. + THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD) +! FROZEN + IF ( (SH2O + 0.0005) < SMC ) THEN + AKE = SATRATIO +! UNFROZEN +! RANGE OF VALIDITY FOR THE KERSTEN NUMBER (AKE) + ELSE - IF(IST ==1 ) THEN - DO IZ = 1, NROOT - IF(OPT_BTR == 1) then ! Noah - GX = (SH2O(IZ)-SMCWLT) / (SMCREF-SMCWLT) - END IF - IF(OPT_BTR == 2) then ! CLM - PSI = MAX(PSIWLT,-PSISAT*(MAX(0.01,SH2O(IZ))/SMCMAX)**(-BEXP) ) - GX = (1.-PSI/PSIWLT)/(1.+PSISAT/PSIWLT) - END IF - IF(OPT_BTR == 3) then ! SSiB - PSI = MAX(PSIWLT,-PSISAT*(MAX(0.01,SH2O(IZ))/SMCMAX)**(-BEXP) ) - GX = 1.-EXP(-5.8*(LOG(PSIWLT/PSI))) - END IF - - GX = MIN(1.,MAX(0.,GX)) - BTRANI(IZ) = MAX(MPE,DZSNSO(IZ) / (-ZSOIL(NROOT)) * GX) - BTRAN = BTRAN + BTRANI(IZ) - END DO - BTRAN = MAX(MPE,BTRAN) +! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT +! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) +! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998). - BTRANI(1:NROOT) = BTRANI(1:NROOT)/BTRAN - END IF + IF ( SATRATIO > 0.1 ) THEN -! soil surface resistance for ground evap. + AKE = LOG10 (SATRATIO) + 1.0 - BEVAP = MAX(0.0,SH2O(1)/SMCMAX) - IF(IST == 2) THEN - RSURF = 1. ! avoid being divided by 0 - RHSUR = 1.0 - ELSE +! USE K = KDRY + ELSE + + AKE = 0.0 + END IF +! THERMAL CONDUCTIVITY - ! RSURF based on Sakaguchi and Zeng, 2009 - ! taking the "residual water content" to be the wilting point, - ! and correcting the exponent on the D term (typo in SZ09 ?) - L_RSURF = (-ZSOIL(1)) * ( exp ( (1.0 - MIN(1.0,SH2O(1)/SMCMAX)) ** 5 ) - 1.0 ) / ( 2.71828 - 1.0 ) - D_RSURF = 2.2E-5 * SMCMAX * SMCMAX * ( 1.0 - SMCWLT / SMCMAX ) ** (2.0+3.0/BEXP) - RSURF = L_RSURF / D_RSURF + END IF - ! Older RSURF computations: - ! RSURF = FSNO * 1. + (1.-FSNO)* EXP(8.25-4.225*BEVAP) !Sellers (1992) - ! RSURF = FSNO * 1. + (1.-FSNO)* EXP(8.25-6.0 *BEVAP) !adjusted to decrease RSURF for wet soil + DF = AKE * (THKSAT - THKDRY) + THKDRY - IF(SH2O(1) < 0.01 .and. SNOWH == 0.) RSURF = 1.E6 - PSI = -PSISAT*(MAX(0.01,SH2O(1))/SMCMAX)**(-BEXP) - RHSUR = FSNO + (1.-FSNO) * EXP(PSI*GRAV/(RW*TG)) - END IF -! urban - jref - IF (VEGTYP == ISURBAN .and. SNOWH == 0. ) THEN - RSURF = 1.E6 - ENDIF + end subroutine TDFCND -! set psychrometric constant +!== begin radiation ================================================================================ - IF (TV .GT. TFRZ) THEN ! Barlage: add distinction between ground and - LATHEAV = HVAP ! vegetation in v3.6 - frozen_canopy = .false. - ELSE - LATHEAV = HSUB - frozen_canopy = .true. - END IF - GAMMAV = CPAIR*SFCPRS/(0.622*LATHEAV) + SUBROUTINE RADIATION (parameters,VEGTYP ,IST ,ICE ,NSOIL , & !in + SNEQVO ,SNEQV ,DT ,COSZ ,SNOWH , & !in + TG ,TV ,FSNO ,QSNOW ,FWET , & !in + ELAI ,ESAI ,SMC ,SOLAD ,SOLAI , & !in + FVEG ,ILOC ,JLOC , & !in + ALBOLD ,TAUSS , & !inout + FSUN ,LAISUN ,LAISHA ,PARSUN ,PARSHA , & !out + SAV ,SAG ,FSR ,FSA ,FSRV , & + FSRG ,BGAP ,WGAP) !out +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + INTEGER, INTENT(IN) :: VEGTYP !vegetation type + INTEGER, INTENT(IN) :: IST !surface type + INTEGER, INTENT(IN) :: ICE !ice (ice = 1) + INTEGER, INTENT(IN) :: NSOIL !number of soil layers - IF (TG .GT. TFRZ) THEN - LATHEAG = HVAP - frozen_ground = .false. - ELSE - LATHEAG = HSUB - frozen_ground = .true. - END IF - GAMMAG = CPAIR*SFCPRS/(0.622*LATHEAG) + REAL, INTENT(IN) :: DT !time step [s] + REAL, INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL, INTENT(IN) :: SNEQV !snow mass (mm) + REAL, INTENT(IN) :: SNOWH !snow height (mm) + REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: TV !vegetation temperature (k) + REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: FWET !fraction of canopy that is wet + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water [m3/m3] + REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL, INTENT(IN) :: FSNO !snow cover fraction (-) + REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] -! IF (SFCTMP .GT. TFRZ) THEN -! LATHEA = HVAP -! ELSE -! LATHEA = HSUB -! END IF -! GAMMA = CPAIR*SFCPRS/(0.622*LATHEA) +! inout + REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age. -! Surface temperatures of the ground and canopy and energy fluxes +! output + REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) + REAL, INTENT(OUT) :: LAISUN !sunlit leaf area (-) + REAL, INTENT(OUT) :: LAISHA !shaded leaf area (-) + REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) - IF (VEG .AND. FVEG > 0) THEN - TGV = TG - CMV = CM - CHV = CH - CALL VEGE_FLUX (NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in - DT ,SAV ,SAG ,LWDN ,UR , & !in - UU ,VV ,SFCTMP ,THAIR ,QAIR , & !in - EAIR ,RHOAIR ,SNOWH ,VAI ,GAMMAV ,GAMMAG , & !in - FWET ,LAISUN ,LAISHA ,CWP ,DZSNSO , & !in - ZLVL ,ZPD ,Z0M ,FVEG , & !in - Z0MG ,EMV ,EMG ,CANLIQ ,FSNO, & !in - CANICE ,STC ,DF ,RSSUN ,RSSHA , & !in - RSURF ,LATHEAV ,LATHEAG ,PARSUN ,PARSHA ,IGS , & !in - FOLN ,CO2AIR ,O2AIR ,BTRAN ,SFCPRS , & !in - RHSUR ,ILOC ,JLOC ,Q2 ,PAHV ,PAHG , & !in - EAH ,TAH ,TV ,TGV ,CMV , & !inout - CHV ,DX ,DZ8W , & !inout - TAUXV ,TAUYV ,IRG ,IRC ,SHG , & !out - SHC ,EVG ,EVC ,TR ,GHV , & !out - T2MV ,PSNSUN ,PSNSHA , & !out -!jref:start - QC ,QSFC ,PSFC , & !in - Q2V ,CHV2, CHLEAF, CHUC) !inout -!jref:end - END IF +!jref:start + REAL, INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: BGAP + REAL, INTENT(OUT) :: WGAP +!jref:end + +! local + REAL :: FAGE !snow age function (0 - new snow) + REAL, DIMENSION(1:2) :: ALBGRD !ground albedo (direct) + REAL, DIMENSION(1:2) :: ALBGRI !ground albedo (diffuse) + REAL, DIMENSION(1:2) :: ALBD !surface albedo (direct) + REAL, DIMENSION(1:2) :: ALBI !surface albedo (diffuse) + REAL, DIMENSION(1:2) :: FABD !flux abs by veg (per unit direct flux) + REAL, DIMENSION(1:2) :: FABI !flux abs by veg (per unit diffuse flux) + REAL, DIMENSION(1:2) :: FTDD !down direct flux below veg (per unit dir flux) + REAL, DIMENSION(1:2) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL, DIMENSION(1:2) :: FTII !down diffuse flux below veg (per unit dif flux) +!jref:start + REAL, DIMENSION(1:2) :: FREVI + REAL, DIMENSION(1:2) :: FREVD + REAL, DIMENSION(1:2) :: FREGI + REAL, DIMENSION(1:2) :: FREGD +!jref:end - TGB = TG - CMB = CM - CHB = CH - CALL BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in - LWDN ,UR ,UU ,VV ,SFCTMP , & !in - THAIR ,QAIR ,EAIR ,RHOAIR ,SNOWH , & !in - DZSNSO ,ZLVL ,ZPDG ,Z0MG ,FSNO, & !in - EMG ,STC ,DF ,RSURF ,LATHEAG , & !in - GAMMAG ,RHSUR ,ILOC ,JLOC ,Q2 ,PAHB , & !in - TGB ,CMB ,CHB , & !inout - TAUXB ,TAUYB ,IRB ,SHB ,EVB , & !out - GHB ,T2MB ,DX ,DZ8W ,VEGTYP , & !out -!jref:start - QC ,QSFC ,PSFC , & !in - SFCPRS ,Q2B, CHB2) !in -!jref:end + REAL :: FSHA !shaded fraction of canopy + REAL :: VAI !total LAI + stem area index, one sided -!energy balance at vege canopy: SAV =(IRC+SHC+EVC+TR) *FVEG at FVEG -!energy balance at vege ground: SAG* FVEG =(IRG+SHG+EVG+GHV) *FVEG at FVEG -!energy balance at bare ground: SAG*(1.-FVEG)=(IRB+SHB+EVB+GHB)*(1.-FVEG) at 1-FVEG + REAL,PARAMETER :: MPE = 1.E-6 + LOGICAL VEG !true: vegetated for surface temperature calculation - IF (VEG .AND. FVEG > 0) THEN - TAUX = FVEG * TAUXV + (1.0 - FVEG) * TAUXB - TAUY = FVEG * TAUYV + (1.0 - FVEG) * TAUYB - FIRA = FVEG * IRG + (1.0 - FVEG) * IRB + IRC - FSH = FVEG * SHG + (1.0 - FVEG) * SHB + SHC - FGEV = FVEG * EVG + (1.0 - FVEG) * EVB - SSOIL = FVEG * GHV + (1.0 - FVEG) * GHB - FCEV = EVC - FCTR = TR - PAH = FVEG * PAHG + (1.0 - FVEG) * PAHB + PAHV - TG = FVEG * TGV + (1.0 - FVEG) * TGB - T2M = FVEG * T2MV + (1.0 - FVEG) * T2MB - TS = FVEG * TV + (1.0 - FVEG) * TGB - CM = FVEG * CMV + (1.0 - FVEG) * CMB ! better way to average? - CH = FVEG * CHV + (1.0 - FVEG) * CHB - Q1 = FVEG * (EAH*0.622/(SFCPRS - 0.378*EAH)) + (1.0 - FVEG)*QSFC - Q2E = FVEG * Q2V + (1.0 - FVEG) * Q2B - Z0WRF = Z0M - ELSE - TAUX = TAUXB - TAUY = TAUYB - FIRA = IRB - FSH = SHB - FGEV = EVB - SSOIL = GHB - TG = TGB - T2M = T2MB - FCEV = 0. - FCTR = 0. - PAH = PAHB - TS = TG - CM = CMB - CH = CHB - Q1 = QSFC - Q2E = Q2B - RSSUN = 0.0 - RSSHA = 0.0 - TGV = TGB - CHV = CHB - Z0WRF = Z0MG - END IF +! -------------------------------------------------------------------------------------------------- - FIRE = LWDN + FIRA +! surface abeldo - IF(FIRE <=0.) THEN - WRITE(6,*) 'emitted longwave <0; skin T may be wrong due to inconsistent' - WRITE(6,*) 'input of SHDFAC with LAI' - WRITE(6,*) ILOC, JLOC, 'SHDFAC=',FVEG,'VAI=',VAI,'TV=',TV,'TG=',TG - WRITE(6,*) 'LWDN=',LWDN,'FIRA=',FIRA,'SNOWH=',SNOWH - call wrf_error_fatal("STOP in Noah-MP") - END IF + CALL ALBEDO (parameters,VEGTYP ,IST ,ICE ,NSOIL , & !in + DT ,COSZ ,FAGE ,ELAI ,ESAI , & !in + TG ,TV ,SNOWH ,FSNO ,FWET , & !in + SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , & !in + ILOC ,JLOC , & !in + ALBOLD ,TAUSS , & !inout + ALBGRD ,ALBGRI ,ALBD ,ALBI ,FABD , & !out + FABI ,FTDD ,FTID ,FTII ,FSUN , & !) !out + FREVI ,FREVD ,FREGD ,FREGI ,BGAP , & !inout + WGAP) - ! Compute a net emissivity - EMISSI = FVEG * ( EMG*(1-EMV) + EMV + EMV*(1-EMV)*(1-EMG) ) + & - (1-FVEG) * EMG +! surface radiation - ! When we're computing a TRAD, subtract from the emitted IR the - ! reflected portion of the incoming LWDN, so we're just - ! considering the IR originating in the canopy/ground system. - - TRAD = ( ( FIRE - (1-EMISSI)*LWDN ) / (EMISSI*SB) ) ** 0.25 + FSHA = 1.-FSUN + LAISUN = ELAI*FSUN + LAISHA = ELAI*FSHA + VAI = ELAI+ ESAI + IF (VAI .GT. 0.) THEN + VEG = .TRUE. + ELSE + VEG = .FALSE. + END IF - ! Old TRAD calculation not taking into account Emissivity: - ! TRAD = (FIRE/SB)**0.25 + CALL SURRAD (parameters,MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in + LAISUN ,LAISHA ,SOLAD ,SOLAI ,FABD , & !in + FABI ,FTDD ,FTID ,FTII ,ALBGRD , & !in + ALBGRI ,ALBD ,ALBI ,ILOC ,JLOC , & !in + PARSUN ,PARSHA ,SAV ,SAG ,FSA , & !out + FSR , & !out + FREVI ,FREVD ,FREGD ,FREGI ,FSRV , & !inout + FSRG) - APAR = PARSUN*LAISUN + PARSHA*LAISHA - PSN = PSNSUN*LAISUN + PSNSHA*LAISHA + END SUBROUTINE RADIATION -! 3L snow & 4L soil temperatures +!== begin albedo =================================================================================== - CALL TSNOSOI (ICE ,NSOIL ,NSNOW ,ISNOW ,IST , & !in - TBOT ,ZSNSO ,SSOIL ,DF ,HCPCT , & !in - SAG ,DT ,SNOWH ,DZSNSO , & !in - TG ,ILOC ,JLOC , & !in - STC ) !inout + SUBROUTINE ALBEDO (parameters,VEGTYP ,IST ,ICE ,NSOIL , & !in + DT ,COSZ ,FAGE ,ELAI ,ESAI , & !in + TG ,TV ,SNOWH ,FSNO ,FWET , & !in + SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , & !in + ILOC ,JLOC , & !in + ALBOLD ,TAUSS , & !inout + ALBGRD ,ALBGRI ,ALBD ,ALBI ,FABD , & !out + FABI ,FTDD ,FTID ,FTII ,FSUN , & !out + FREVI ,FREVD ,FREGD ,FREGI ,BGAP , & !out + WGAP) -! adjusting snow surface temperature - IF(OPT_STC == 2) THEN - IF (SNOWH > 0.05 .AND. TG > TFRZ) THEN - TGV = TFRZ - TGB = TFRZ - IF (VEG .AND. FVEG > 0) THEN - TG = FVEG * TGV + (1.0 - FVEG) * TGB - TS = FVEG * TV + (1.0 - FVEG) * TGB - ELSE - TG = TGB - TS = TGB - END IF - END IF - END IF +! -------------------------------------------------------------------------------------------------- +! surface albedos. also fluxes (per unit incoming direct and diffuse +! radiation) reflected, transmitted, and absorbed by vegetation. +! also sunlit fraction of the canopy. +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + INTEGER, INTENT(IN) :: NSOIL !number of soil layers + INTEGER, INTENT(IN) :: VEGTYP !vegetation type + INTEGER, INTENT(IN) :: IST !surface type + INTEGER, INTENT(IN) :: ICE !ice (ice = 1) -! Energy released or consumed by snow & frozen soil + REAL, INTENT(IN) :: DT !time step [sec] + REAL, INTENT(IN) :: QSNOW !snowfall + REAL, INTENT(IN) :: COSZ !cosine solar zenith angle for next time step + REAL, INTENT(IN) :: SNOWH !snow height (mm) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: TV !vegetation temperature (k) + REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow + REAL, INTENT(IN) :: FSNO !fraction of grid covered by snow + REAL, INTENT(IN) :: FWET !fraction of canopy that is wet + REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL, INTENT(IN) :: SNEQV !snow mass (mm) + REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water (m3/m3) - CALL PHASECHANGE (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in - DZSNSO ,HCPCT ,IST ,ILOC ,JLOC , & !in - STC ,SNICE ,SNLIQ ,SNEQV ,SNOWH , & !inout - SMC ,SH2O , & !inout - QMELT ,IMELT ,PONDING ) !out +! inout + REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) + REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age +! output + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBD !surface albedo (direct) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBI !surface albedo (diffuse) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FABD !flux abs by veg (per unit direct flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FABI !flux abs by veg (per unit diffuse flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FTDD !down direct flux below veg (per unit dir flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FTID !down diffuse flux below veg (per unit dir flux) + REAL, DIMENSION(1: 2), INTENT(OUT) :: FTII !down diffuse flux below veg (per unit dif flux) + REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) +!jref:start + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVD + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVI + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGD + REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGI + REAL, INTENT(OUT) :: BGAP + REAL, INTENT(OUT) :: WGAP +!jref:end - END SUBROUTINE ENERGY +! ------------------------------------------------------------------------ +! ------------------------ local variables ------------------------------- +! local + REAL :: FAGE !snow age function + REAL :: ALB + INTEGER :: IB !indices + INTEGER :: NBAND !number of solar radiation wave bands + INTEGER :: IC !direct beam: ic=0; diffuse: ic=1 -!== begin thermoprop =============================================================================== + REAL :: WL !fraction of LAI+SAI that is LAI + REAL :: WS !fraction of LAI+SAI that is SAI + REAL :: MPE !prevents overflow for division by zero - SUBROUTINE THERMOPROP (NSOIL ,NSNOW ,ISNOW ,IST ,DZSNSO , & !in - DT ,SNOWH ,SNICE ,SNLIQ , & !in - SMC ,SH2O ,TG ,STC ,UR , & !in - LAT ,Z0M ,ZLVL ,VEGTYP , & !in - DF ,HCPCT ,SNICEV ,SNLIQV ,EPORE , & !out - FACT ) !out -! ------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: CSOIL, SMCMAX, & ! SOIL DEPENDENT - TFRZ, TKICE, TKWAT, CICE, CWAT, CPAIR, & ! MP CONSTANT - ISURBAN ! MP CONSTANT -! ------------------------------------------------------------------------------------------------- - IMPLICIT NONE -! -------------------------------------------------------------------------------------------------- -! inputs - INTEGER , INTENT(IN) :: NSOIL !number of soil layers - INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER , INTENT(IN) :: ISNOW !actual no. of snow layers - INTEGER , INTENT(IN) :: IST !surface type - REAL , INTENT(IN) :: DT !time step [s] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow ice mass (kg/m2) - REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow liq mass (kg/m2) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thickness of snow/soil layers [m] - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice + liq.) [m3/m3] - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SH2O !liquid soil moisture [m3/m3] - REAL , INTENT(IN) :: SNOWH !snow height [m] - REAL, INTENT(IN) :: TG !surface temperature (k) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil/lake temp. (k) - REAL, INTENT(IN) :: UR !wind speed at ZLVL (m/s) - REAL, INTENT(IN) :: LAT !latitude (radians) - REAL, INTENT(IN) :: Z0M !roughness length (m) - REAL, INTENT(IN) :: ZLVL !reference height (m) - INTEGER , INTENT(IN) :: VEGTYP !vegtyp type + REAL, DIMENSION(1:2) :: RHO !leaf/stem reflectance weighted by fraction LAI and SAI + REAL, DIMENSION(1:2) :: TAU !leaf/stem transmittance weighted by fraction LAI and SAI + REAL, DIMENSION(1:2) :: FTDI !down direct flux below veg per unit dif flux = 0 + REAL, DIMENSION(1:2) :: ALBSND !snow albedo (direct) + REAL, DIMENSION(1:2) :: ALBSNI !snow albedo (diffuse) -! outputs - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: DF !thermal conductivity [w/m/k] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: HCPCT !heat capacity [j/m3/k] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume of ice [m3/m3] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume of liquid water [m3/m3] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: FACT !computing energy for phase change -! -------------------------------------------------------------------------------------------------- -! locals + REAL :: VAI !ELAI+ESAI + REAL :: GDIR !average projected leaf/stem area in solar direction + REAL :: EXT !optical depth direct beam per unit leaf + stem area - INTEGER :: IZ - REAL, DIMENSION(-NSNOW+1: 0) :: CVSNO !volumetric specific heat (j/m3/k) - REAL, DIMENSION(-NSNOW+1: 0) :: TKSNO !snow thermal conductivity (j/m3/k) - REAL, DIMENSION( 1:NSOIL) :: SICE !soil ice content ! -------------------------------------------------------------------------------------------------- -! compute snow thermal conductivity and heat capacity + NBAND = 2 + MPE = 1.E-06 + BGAP = 0. + WGAP = 0. - CALL CSNOW (ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , & !in - TKSNO ,CVSNO ,SNICEV ,SNLIQV ,EPORE ) !out +! initialize output because solar radiation only done if COSZ > 0 - DO IZ = ISNOW+1, 0 - DF (IZ) = TKSNO(IZ) - HCPCT(IZ) = CVSNO(IZ) - END DO + DO IB = 1, NBAND + ALBD(IB) = 0. + ALBI(IB) = 0. + ALBGRD(IB) = 0. + ALBGRI(IB) = 0. + FABD(IB) = 0. + FABI(IB) = 0. + FTDD(IB) = 0. + FTID(IB) = 0. + FTII(IB) = 0. + IF (IB.EQ.1) FSUN = 0. + END DO -! compute soil thermal properties + IF(COSZ <= 0) GOTO 100 - DO IZ = 1, NSOIL - SICE(IZ) = SMC(IZ) - SH2O(IZ) - HCPCT(IZ) = SH2O(IZ)*CWAT + (1.0-SMCMAX)*CSOIL & - + (SMCMAX-SMC(IZ))*CPAIR + SICE(IZ)*CICE - CALL TDFCND (DF(IZ), SMC(IZ), SH2O(IZ)) - END DO - - IF ( VEGTYP == ISURBAN ) THEN - DO IZ = 1,NSOIL - DF(IZ) = 3.24 - END DO - ENDIF +! weight reflectance/transmittance by LAI and SAI -! heat flux reduction effect from the overlying green canopy, adapted from -! section 2.1.2 of Peters-Lidard et al. (1997, JGR, VOL 102(D4)). -! not in use because of the separation of the canopy layer from the ground. -! but this may represent the effects of leaf litter (Niu comments) -! DF1 = DF1 * EXP (SBETA * SHDFAC) + DO IB = 1, NBAND + VAI = ELAI + ESAI + WL = ELAI / MAX(VAI,MPE) + WS = ESAI / MAX(VAI,MPE) + RHO(IB) = MAX(parameters%RHOL(IB)*WL+parameters%RHOS(IB)*WS, MPE) + TAU(IB) = MAX(parameters%TAUL(IB)*WL+parameters%TAUS(IB)*WS, MPE) + END DO -! compute lake thermal properties -! (no consideration of turbulent mixing for this version) +! snow age - IF(IST == 2) THEN - DO IZ = 1, NSOIL - IF(STC(IZ) > TFRZ) THEN - HCPCT(IZ) = CWAT - DF(IZ) = TKWAT !+ KEDDY * CWAT - ELSE - HCPCT(IZ) = CICE - DF(IZ) = TKICE - END IF - END DO - END IF + CALL SNOW_AGE (parameters,DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) -! combine a temporary variable used for melting/freezing of snow and frozen soil +! snow albedos: only if COSZ > 0 and FSNO > 0 - DO IZ = ISNOW+1,NSOIL - FACT(IZ) = DT/(HCPCT(IZ)*DZSNSO(IZ)) - END DO + IF(OPT_ALB == 1) & + CALL SNOWALB_BATS (parameters,NBAND, FSNO,COSZ,FAGE,ALBSND,ALBSNI) + IF(OPT_ALB == 2) THEN + CALL SNOWALB_CLASS (parameters,NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) + ALBOLD = ALB + END IF -! snow/soil interface +! ground surface albedo - IF(ISNOW == 0) THEN - DF(1) = (DF(1)*DZSNSO(1)+0.35*SNOWH) / (SNOWH +DZSNSO(1)) - ELSE - DF(1) = (DF(1)*DZSNSO(1)+DF(0)*DZSNSO(0)) / (DZSNSO(0)+DZSNSO(1)) - END IF + CALL GROUNDALB (parameters,NSOIL ,NBAND ,ICE ,IST , & !in + FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , & !in + TG ,ILOC ,JLOC , & !in + ALBGRD ,ALBGRI ) !out +! loop over NBAND wavebands to calculate surface albedos and solar +! fluxes for unit incoming direct (IC=0) and diffuse flux (IC=1) - END SUBROUTINE THERMOPROP + DO IB = 1, NBAND + IC = 0 ! direct + CALL TWOSTREAM (parameters,IB ,IC ,VEGTYP ,COSZ ,VAI , & !in + FWET ,TV ,ALBGRD ,ALBGRI ,RHO , & !in + TAU ,FVEG ,IST ,ILOC ,JLOC , & !in + FABD ,ALBD ,FTDD ,FTID ,GDIR , &!) !out + FREVD ,FREGD ,BGAP ,WGAP) -!== begin csnow ==================================================================================== + IC = 1 ! diffuse + CALL TWOSTREAM (parameters,IB ,IC ,VEGTYP ,COSZ ,VAI , & !in + FWET ,TV ,ALBGRD ,ALBGRI ,RHO , & !in + TAU ,FVEG ,IST ,ILOC ,JLOC , & !in + FABI ,ALBI ,FTDI ,FTII ,GDIR , & !) !out + FREVI ,FREGI ,BGAP ,WGAP) - SUBROUTINE CSNOW (ISNOW ,NSNOW ,NSOIL ,SNICE ,SNLIQ ,DZSNSO , & !in - TKSNO ,CVSNO ,SNICEV ,SNLIQV ,EPORE ) !out -! -------------------------------------------------------------------------------------------------- -! Snow bulk density,volumetric capacity, and thermal conductivity -!--------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: DENICE, DENH2O, CICE, CWAT ! MP CONSTANT -!--------------------------------------------------------------------------------------------------- - IMPLICIT NONE -!--------------------------------------------------------------------------------------------------- -! inputs + END DO - INTEGER, INTENT(IN) :: ISNOW !number of snow layers (-) - INTEGER , INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER , INTENT(IN) :: NSOIL !number of soil layers - REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow ice mass (kg/m2) - REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow liq mass (kg/m2) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] +! sunlit fraction of canopy. set FSUN = 0 if FSUN < 0.01. -! outputs + EXT = GDIR/COSZ * SQRT(1.-RHO(1)-TAU(1)) + FSUN = (1.-EXP(-EXT*VAI)) / MAX(EXT*VAI,MPE) + EXT = FSUN - REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: CVSNO !volumetric specific heat (j/m3/k) - REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: TKSNO !thermal conductivity (w/m/k) - REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNICEV !partial volume of ice [m3/m3] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: SNLIQV !partial volume of liquid water [m3/m3] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(OUT) :: EPORE !effective porosity [m3/m3] + IF (EXT .LT. 0.01) THEN + WL = 0. + ELSE + WL = EXT + END IF + FSUN = WL -! locals +100 CONTINUE - INTEGER :: IZ - REAL, DIMENSION(-NSNOW+1: 0) :: BDSNOI !bulk density of snow(kg/m3) + END SUBROUTINE ALBEDO -!--------------------------------------------------------------------------------------------------- -! thermal capacity of snow +!== begin surrad =================================================================================== - DO IZ = ISNOW+1, 0 - SNICEV(IZ) = MIN(1., SNICE(IZ)/(DZSNSO(IZ)*DENICE) ) - EPORE(IZ) = 1. - SNICEV(IZ) - SNLIQV(IZ) = MIN(EPORE(IZ),SNLIQ(IZ)/(DZSNSO(IZ)*DENH2O)) - ENDDO + SUBROUTINE SURRAD (parameters,MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in + LAISUN ,LAISHA ,SOLAD ,SOLAI ,FABD , & !in + FABI ,FTDD ,FTID ,FTII ,ALBGRD , & !in + ALBGRI ,ALBD ,ALBI ,ILOC ,JLOC , & !in + PARSUN ,PARSHA ,SAV ,SAG ,FSA , & !out + FSR , & !) !out + FREVI ,FREVD ,FREGD ,FREGI ,FSRV , & + FSRG) !inout - DO IZ = ISNOW+1, 0 - BDSNOI(IZ) = (SNICE(IZ)+SNLIQ(IZ))/DZSNSO(IZ) - CVSNO(IZ) = CICE*SNICEV(IZ)+CWAT*SNLIQV(IZ) -! CVSNO(IZ) = 0.525E06 ! constant - enddo +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input -! thermal conductivity of snow + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + REAL, INTENT(IN) :: MPE !prevents underflow errors if division by zero - DO IZ = ISNOW+1, 0 - TKSNO(IZ) = 3.2217E-6*BDSNOI(IZ)**2. ! Stieglitz(yen,1965) -! TKSNO(IZ) = 2E-2+2.5E-6*BDSNOI(IZ)*BDSNOI(IZ) ! Anderson, 1976 -! TKSNO(IZ) = 0.35 ! constant -! TKSNO(IZ) = 2.576E-6*BDSNOI(IZ)**2. + 0.074 ! Verseghy (1991) -! TKSNO(IZ) = 2.22*(BDSNOI(IZ)/1000.)**1.88 ! Douvill(Yen, 1981) - ENDDO + REAL, INTENT(IN) :: FSUN !sunlit fraction of canopy + REAL, INTENT(IN) :: FSHA !shaded fraction of canopy + REAL, INTENT(IN) :: ELAI !leaf area, one-sided + REAL, INTENT(IN) :: VAI !leaf + stem area, one-sided + REAL, INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided + REAL, INTENT(IN) :: LAISHA !shaded leaf area index, one-sided - END SUBROUTINE CSNOW + REAL, DIMENSION(1:2), INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) + REAL, DIMENSION(1:2), INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) + REAL, DIMENSION(1:2), INTENT(IN) :: FABD !flux abs by veg (per unit incoming direct flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FABI !flux abs by veg (per unit incoming diffuse flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FTDD !down dir flux below veg (per incoming dir flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FTID !down dif flux below veg (per incoming dir flux) + REAL, DIMENSION(1:2), INTENT(IN) :: FTII !down dif flux below veg (per incoming dif flux) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !ground albedo (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !ground albedo (diffuse) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBD !overall surface albedo (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBI !overall surface albedo (diffuse) -!== begin tdfcnd =================================================================================== + REAL, DIMENSION(1:2), INTENT(IN) :: FREVD !overall surface albedo veg (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: FREVI !overall surface albedo veg (diffuse) + REAL, DIMENSION(1:2), INTENT(IN) :: FREGD !overall surface albedo grd (direct) + REAL, DIMENSION(1:2), INTENT(IN) :: FREGI !overall surface albedo grd (diffuse) - SUBROUTINE TDFCND ( DF, SMC, SH2O) -! -------------------------------------------------------------------------------------------------- -! Calculate thermal diffusivity and conductivity of the soil. -! Peters-Lidard approach (Peters-Lidard et al., 1998) -! -------------------------------------------------------------------------------------------------- -! Code history: -! June 2001 changes: frozen soil condition. -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: QUARTZ, SMCMAX, & ! SOIL DEPENDENT - TKICE ! MP CONSTANT -! -------------------------------------------------------------------------------------------------- - IMPLICIT NONE - REAL, INTENT(IN) :: SMC ! total soil water - REAL, INTENT(IN) :: SH2O ! liq. soil water - REAL, INTENT(OUT) :: DF ! thermal diffusivity +! output -! local variables - REAL :: AKE - REAL :: GAMMD - REAL :: THKDRY - REAL :: THKO ! thermal conductivity for other soil components - REAL :: THKQTZ ! thermal conductivity for quartz - REAL :: THKSAT ! - REAL :: THKS ! thermal conductivity for the solids - REAL :: THKW ! water thermal conductivity - REAL :: SATRATIO - REAL :: XU - REAL :: XUNFROZ -! -------------------------------------------------------------------------------------------------- -! We now get quartz as an input argument (set in routine redprm): -! DATA QUARTZ /0.82, 0.10, 0.25, 0.60, 0.52, -! & 0.35, 0.60, 0.40, 0.82/ -! -------------------------------------------------------------------------------------------------- -! If the soil has any moisture content compute a partial sum/product -! otherwise use a constant value which works well with most soils -! -------------------------------------------------------------------------------------------------- -! QUARTZ ....QUARTZ CONTENT (SOIL TYPE DEPENDENT) -! -------------------------------------------------------------------------------------------------- -! USE AS IN PETERS-LIDARD, 1998 (MODIF. FROM JOHANSEN, 1975). + REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) + REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) + REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) + REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) + REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) + REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) + REAL, INTENT(OUT) :: FSRV !reflected solar radiation by vegetation + REAL, INTENT(OUT) :: FSRG !reflected solar radiation by ground + +! ------------------------ local variables ---------------------------------------------------- + INTEGER :: IB !waveband number (1=vis, 2=nir) + INTEGER :: NBAND !number of solar radiation waveband classes + + REAL :: ABS !absorbed solar radiation (w/m2) + REAL :: RNIR !reflected solar radiation [nir] (w/m2) + REAL :: RVIS !reflected solar radiation [vis] (w/m2) + REAL :: LAIFRA !leaf area fraction of canopy + REAL :: TRD !transmitted solar radiation: direct (w/m2) + REAL :: TRI !transmitted solar radiation: diffuse (w/m2) + REAL, DIMENSION(1:2) :: CAD !direct beam absorbed by canopy (w/m2) + REAL, DIMENSION(1:2) :: CAI !diffuse radiation absorbed by canopy (w/m2) +! --------------------------------------------------------------------------------------------- + NBAND = 2 + +! zero summed solar fluxes + + SAG = 0. + SAV = 0. + FSA = 0. -! PABLO GRUNMANN, 08/17/98 -! Refs.: -! Farouki, O.T.,1986: Thermal properties of soils. Series on Rock -! and Soil Mechanics, Vol. 11, Trans Tech, 136 pp. -! Johansen, O., 1975: Thermal conductivity of soils. PH.D. Thesis, -! University of Trondheim, -! Peters-Lidard, C. D., et al., 1998: The effect of soil thermal -! conductivity parameterization on surface energy fluxes -! and temperatures. Journal of The Atmospheric Sciences, -! Vol. 55, pp. 1209-1224. -! -------------------------------------------------------------------------------------------------- -! NEEDS PARAMETERS -! POROSITY(SOIL TYPE): -! POROS = SMCMAX -! SATURATION RATIO: -! PARAMETERS W/(M.K) - SATRATIO = SMC / SMCMAX - THKW = 0.57 -! IF (QUARTZ .LE. 0.2) THKO = 3.0 - THKO = 2.0 -! SOLIDS' CONDUCTIVITY -! QUARTZ' CONDUCTIVITY - THKQTZ = 7.7 +! loop over nband wavebands -! UNFROZEN FRACTION (FROM 1., i.e., 100%LIQUID, TO 0. (100% FROZEN)) - THKS = (THKQTZ ** QUARTZ)* (THKO ** (1. - QUARTZ)) + DO IB = 1, NBAND -! UNFROZEN VOLUME FOR SATURATION (POROSITY*XUNFROZ) - XUNFROZ = SH2O / SMC -! SATURATED THERMAL CONDUCTIVITY - XU = XUNFROZ * SMCMAX +! absorbed by canopy -! DRY DENSITY IN KG/M3 - THKSAT = THKS ** (1. - SMCMAX)* TKICE ** (SMCMAX - XU)* THKW ** & - (XU) + CAD(IB) = SOLAD(IB)*FABD(IB) + CAI(IB) = SOLAI(IB)*FABI(IB) + SAV = SAV + CAD(IB) + CAI(IB) + FSA = FSA + CAD(IB) + CAI(IB) + +! transmitted solar fluxes incident on ground -! DRY THERMAL CONDUCTIVITY IN W.M-1.K-1 - GAMMD = (1. - SMCMAX)*2700. + TRD = SOLAD(IB)*FTDD(IB) + TRI = SOLAD(IB)*FTID(IB) + SOLAI(IB)*FTII(IB) - THKDRY = (0.135* GAMMD+ 64.7)/ (2700. - 0.947* GAMMD) -! FROZEN - IF ( (SH2O + 0.0005) < SMC ) THEN - AKE = SATRATIO -! UNFROZEN -! RANGE OF VALIDITY FOR THE KERSTEN NUMBER (AKE) - ELSE +! solar radiation absorbed by ground surface -! KERSTEN NUMBER (USING "FINE" FORMULA, VALID FOR SOILS CONTAINING AT -! LEAST 5% OF PARTICLES WITH DIAMETER LESS THAN 2.E-6 METERS.) -! (FOR "COARSE" FORMULA, SEE PETERS-LIDARD ET AL., 1998). + ABS = TRD*(1.-ALBGRD(IB)) + TRI*(1.-ALBGRI(IB)) + SAG = SAG + ABS + FSA = FSA + ABS + END DO - IF ( SATRATIO > 0.1 ) THEN +! partition visible canopy absorption to sunlit and shaded fractions +! to get average absorbed par for sunlit and shaded leaves - AKE = LOG10 (SATRATIO) + 1.0 + LAIFRA = ELAI / MAX(VAI,MPE) + IF (FSUN .GT. 0.) THEN + PARSUN = (CAD(1)+FSUN*CAI(1)) * LAIFRA / MAX(LAISUN,MPE) + PARSHA = (FSHA*CAI(1))*LAIFRA / MAX(LAISHA,MPE) + ELSE + PARSUN = 0. + PARSHA = (CAD(1)+CAI(1))*LAIFRA /MAX(LAISHA,MPE) + ENDIF -! USE K = KDRY - ELSE +! reflected solar radiation - AKE = 0.0 - END IF -! THERMAL CONDUCTIVITY + RVIS = ALBD(1)*SOLAD(1) + ALBI(1)*SOLAI(1) + RNIR = ALBD(2)*SOLAD(2) + ALBI(2)*SOLAI(2) + FSR = RVIS + RNIR - END IF +! reflected solar radiation of veg. and ground (combined ground) + FSRV = FREVD(1)*SOLAD(1)+FREVI(1)*SOLAI(1)+FREVD(2)*SOLAD(2)+FREVI(2)*SOLAI(2) + FSRG = FREGD(1)*SOLAD(1)+FREGI(1)*SOLAI(1)+FREGD(2)*SOLAD(2)+FREGI(2)*SOLAI(2) - DF = AKE * (THKSAT - THKDRY) + THKDRY + END SUBROUTINE SURRAD - end subroutine TDFCND +!== begin snow_age ================================================================================= -!== begin radiation ================================================================================ + SUBROUTINE SNOW_AGE (parameters,DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ------------------------ code history ------------------------------------------------------------ +! from BATS +! ------------------------ input/output variables -------------------------------------------------- +!input + type (noahmp_parameters), intent(in) :: parameters + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) + REAL, INTENT(IN) :: SNEQV !snow water per unit ground area (mm) - SUBROUTINE RADIATION (VEGTYP ,IST ,ICE ,NSOIL , & !in - SNEQVO ,SNEQV ,DT ,COSZ ,SNOWH , & !in - TG ,TV ,FSNO ,QSNOW ,FWET , & !in - ELAI ,ESAI ,SMC ,SOLAD ,SOLAI , & !in - FVEG ,ILOC ,JLOC , & !in - ALBOLD ,TAUSS , & !inout - FSUN ,LAISUN ,LAISHA ,PARSUN ,PARSHA , & !out - SAV ,SAG ,FSR ,FSA ,FSRV , & - FSRG ,BGAP ,WGAP) !out +!output + REAL, INTENT(OUT) :: FAGE !snow age + +!input/output + REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age +!local + REAL :: TAGE !total aging effects + REAL :: AGE1 !effects of grain growth due to vapor diffusion + REAL :: AGE2 !effects of grain growth at freezing of melt water + REAL :: AGE3 !effects of soot + REAL :: DELA !temporary variable + REAL :: SGE !temporary variable + REAL :: DELS !temporary variable + REAL :: DELA0 !temporary variable + REAL :: ARG !temporary variable +! See Yang et al. (1997) J.of Climate for detail. +!--------------------------------------------------------------------------------------------------- + + IF(SNEQV.LE.0.0) THEN + TAUSS = 0. + ELSE IF (SNEQV.GT.800.) THEN + TAUSS = 0. + ELSE + DELA0 = 1.E-6*DT + ARG = 5.E3*(1./TFRZ-1./TG) + AGE1 = EXP(ARG) + AGE2 = EXP(AMIN1(0.,10.*ARG)) + AGE3 = 0.3 + TAGE = AGE1+AGE2+AGE3 + DELA = DELA0*TAGE + DELS = AMAX1(0.0,SNEQV-SNEQVO) / parameters%SWEMX + SGE = (TAUSS+DELA)*(1.0-DELS) + TAUSS = AMAX1(0.,SGE) + ENDIF + + FAGE= TAUSS/(TAUSS+1.) + + END SUBROUTINE SNOW_AGE + +!== begin snowalb_bats ============================================================================= + + SUBROUTINE SNOWALB_BATS (parameters,NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! input - INTEGER, INTENT(IN) :: ILOC - INTEGER, INTENT(IN) :: JLOC - INTEGER, INTENT(IN) :: VEGTYP !vegetation type - INTEGER, INTENT(IN) :: IST !surface type - INTEGER, INTENT(IN) :: ICE !ice (ice = 1) - INTEGER, INTENT(IN) :: NSOIL !number of soil layers - REAL, INTENT(IN) :: DT !time step [s] - REAL, INTENT(IN) :: QSNOW !snowfall (mm/s) - REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL, INTENT(IN) :: SNEQV !snow mass (mm) - REAL, INTENT(IN) :: SNOWH !snow height (mm) - REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: TV !vegetation temperature (k) - REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: FWET !fraction of canopy that is wet - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water [m3/m3] - REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) - REAL, DIMENSION(1:2) , INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) - REAL, INTENT(IN) :: FSNO !snow cover fraction (-) - REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: NBAND !number of waveband classes -! inout - REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) - REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age. + REAL,INTENT(IN) :: COSZ !cosine solar zenith angle + REAL,INTENT(IN) :: FSNO !snow cover fraction (-) + REAL,INTENT(IN) :: FAGE !snow age correction ! output - REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) - REAL, INTENT(OUT) :: LAISUN !sunlit leaf area (-) - REAL, INTENT(OUT) :: LAISHA !shaded leaf area (-) - REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) - REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) - REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) - REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) - REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) - REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) - -!jref:start - REAL, INTENT(OUT) :: FSRV !veg. reflected solar radiation (w/m2) - REAL, INTENT(OUT) :: FSRG !ground reflected solar radiation (w/m2) - REAL, INTENT(OUT) :: BGAP - REAL, INTENT(OUT) :: WGAP -!jref:end - -! local - REAL :: FAGE !snow age function (0 - new snow) - REAL, DIMENSION(1:2) :: ALBGRD !ground albedo (direct) - REAL, DIMENSION(1:2) :: ALBGRI !ground albedo (diffuse) - REAL, DIMENSION(1:2) :: ALBD !surface albedo (direct) - REAL, DIMENSION(1:2) :: ALBI !surface albedo (diffuse) - REAL, DIMENSION(1:2) :: FABD !flux abs by veg (per unit direct flux) - REAL, DIMENSION(1:2) :: FABI !flux abs by veg (per unit diffuse flux) - REAL, DIMENSION(1:2) :: FTDD !down direct flux below veg (per unit dir flux) - REAL, DIMENSION(1:2) :: FTID !down diffuse flux below veg (per unit dir flux) - REAL, DIMENSION(1:2) :: FTII !down diffuse flux below veg (per unit dif flux) -!jref:start - REAL, DIMENSION(1:2) :: FREVI - REAL, DIMENSION(1:2) :: FREVD - REAL, DIMENSION(1:2) :: FREGI - REAL, DIMENSION(1:2) :: FREGD -!jref:end - - REAL :: FSHA !shaded fraction of canopy - REAL :: VAI !total LAI + stem area index, one sided - REAL,PARAMETER :: MPE = 1.E-6 - LOGICAL VEG !true: vegetated for surface temperature calculation + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- -! -------------------------------------------------------------------------------------------------- +! ------------------------ local variables ---------------------------------------------------- + INTEGER :: IB !waveband class -! surface abeldo + REAL :: FZEN !zenith angle correction + REAL :: CF1 !temperary variable + REAL :: SL2 !2.*SL + REAL :: SL1 !1/SL + REAL :: SL !adjustable parameter + REAL, PARAMETER :: C1 = 0.2 !default in BATS + REAL, PARAMETER :: C2 = 0.5 !default in BATS +! REAL, PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's +! REAL, PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) +! --------------------------------------------------------------------------------------------- +! zero albedos for all points - CALL ALBEDO (VEGTYP ,IST ,ICE ,NSOIL , & !in - DT ,COSZ ,FAGE ,ELAI ,ESAI , & !in - TG ,TV ,SNOWH ,FSNO ,FWET , & !in - SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , & !in - ILOC ,JLOC , & !in - ALBOLD ,TAUSS , & !inout - ALBGRD ,ALBGRI ,ALBD ,ALBI ,FABD , & !out - FABI ,FTDD ,FTID ,FTII ,FSUN , & !) !out - FREVI ,FREVD ,FREGD ,FREGI ,BGAP , & !inout - WGAP) + ALBSND(1: NBAND) = 0. + ALBSNI(1: NBAND) = 0. -! surface radiation +! when cosz > 0 - FSHA = 1.-FSUN - LAISUN = ELAI*FSUN - LAISHA = ELAI*FSHA - VAI = ELAI+ ESAI - IF (VAI .GT. 0.) THEN - VEG = .TRUE. - ELSE - VEG = .FALSE. - END IF + SL=2.0 + SL1=1./SL + SL2=2.*SL + CF1=((1.+SL1)/(1.+SL2*COSZ)-SL1) + FZEN=AMAX1(CF1,0.) - CALL SURRAD (MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in - LAISUN ,LAISHA ,SOLAD ,SOLAI ,FABD , & !in - FABI ,FTDD ,FTID ,FTII ,ALBGRD , & !in - ALBGRI ,ALBD ,ALBI ,ILOC ,JLOC , & !in - PARSUN ,PARSHA ,SAV ,SAG ,FSA , & !out - FSR , & !out - FREVI ,FREVD ,FREGD ,FREGI ,FSRV , & !inout - FSRG) + ALBSNI(1)=0.95*(1.-C1*FAGE) + ALBSNI(2)=0.65*(1.-C2*FAGE) - END SUBROUTINE RADIATION + ALBSND(1)=ALBSNI(1)+0.4*FZEN*(1.-ALBSNI(1)) ! vis direct + ALBSND(2)=ALBSNI(2)+0.4*FZEN*(1.-ALBSNI(2)) ! nir direct -!== begin albedo =================================================================================== + END SUBROUTINE SNOWALB_BATS - SUBROUTINE ALBEDO (VEGTYP ,IST ,ICE ,NSOIL , & !in - DT ,COSZ ,FAGE ,ELAI ,ESAI , & !in - TG ,TV ,SNOWH ,FSNO ,FWET , & !in - SMC ,SNEQVO ,SNEQV ,QSNOW ,FVEG , & !in - ILOC ,JLOC , & !in - ALBOLD ,TAUSS , & !inout - ALBGRD ,ALBGRI ,ALBD ,ALBI ,FABD , & !out - FABI ,FTDD ,FTID ,FTII ,FSUN , & !out - FREVI ,FREVD ,FREGD ,FREGI ,BGAP , & !out - WGAP) +!== begin snowalb_class ============================================================================ -! -------------------------------------------------------------------------------------------------- -! surface albedos. also fluxes (per unit incoming direct and diffuse -! radiation) reflected, transmitted, and absorbed by vegetation. -! also sunlit fraction of the canopy. -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: RHOL, RHOS, TAUL, TAUS ! VEGETATION AND RAD DEPENDENT -! -------------------------------------------------------------------------------------------------- + SUBROUTINE SNOWALB_CLASS (parameters,NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) +! ---------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! input - INTEGER, INTENT(IN) :: ILOC - INTEGER, INTENT(IN) :: JLOC - INTEGER, INTENT(IN) :: NSOIL !number of soil layers - INTEGER, INTENT(IN) :: VEGTYP !vegetation type - INTEGER, INTENT(IN) :: IST !surface type - INTEGER, INTENT(IN) :: ICE !ice (ice = 1) - REAL, INTENT(IN) :: DT !time step [sec] - REAL, INTENT(IN) :: QSNOW !snowfall - REAL, INTENT(IN) :: COSZ !cosine solar zenith angle for next time step - REAL, INTENT(IN) :: SNOWH !snow height (mm) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: TV !vegetation temperature (k) - REAL, INTENT(IN) :: ELAI !LAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: ESAI !SAI, one-sided, adjusted for burying by snow - REAL, INTENT(IN) :: FSNO !fraction of grid covered by snow - REAL, INTENT(IN) :: FWET !fraction of canopy that is wet - REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL, INTENT(IN) :: SNEQV !snow mass (mm) - REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water (m3/m3) + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: ILOC !grid index + INTEGER,INTENT(IN) :: JLOC !grid index + INTEGER,INTENT(IN) :: NBAND !number of waveband classes -! inout - REAL, INTENT(INOUT) :: ALBOLD !snow albedo at last time step (CLASS type) - REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age + REAL,INTENT(IN) :: QSNOW !snowfall (mm/s) + REAL,INTENT(IN) :: DT !time step (sec) + REAL,INTENT(IN) :: ALBOLD !snow albedo at last time step -! output - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBD !surface albedo (direct) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBI !surface albedo (diffuse) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FABD !flux abs by veg (per unit direct flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FABI !flux abs by veg (per unit diffuse flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FTDD !down direct flux below veg (per unit dir flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FTID !down diffuse flux below veg (per unit dir flux) - REAL, DIMENSION(1: 2), INTENT(OUT) :: FTII !down diffuse flux below veg (per unit dif flux) - REAL, INTENT(OUT) :: FSUN !sunlit fraction of canopy (-) -!jref:start - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVD - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREVI - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGD - REAL, DIMENSION(1: 2), INTENT(OUT) :: FREGI - REAL, INTENT(OUT) :: BGAP - REAL, INTENT(OUT) :: WGAP -!jref:end +! in & out -! ------------------------------------------------------------------------ -! ------------------------ local variables ------------------------------- -! local - REAL :: FAGE !snow age function - REAL :: ALB - INTEGER :: IB !indices - INTEGER :: NBAND !number of solar radiation wave bands - INTEGER :: IC !direct beam: ic=0; diffuse: ic=1 + REAL, INTENT(INOUT) :: ALB ! +! output - REAL :: WL !fraction of LAI+SAI that is LAI - REAL :: WS !fraction of LAI+SAI that is SAI - REAL :: MPE !prevents overflow for division by zero + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) + REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse +! --------------------------------------------------------------------------------------------- - REAL, DIMENSION(1:2) :: RHO !leaf/stem reflectance weighted by fraction LAI and SAI - REAL, DIMENSION(1:2) :: TAU !leaf/stem transmittance weighted by fraction LAI and SAI - REAL, DIMENSION(1:2) :: FTDI !down direct flux below veg per unit dif flux = 0 - REAL, DIMENSION(1:2) :: ALBSND !snow albedo (direct) - REAL, DIMENSION(1:2) :: ALBSNI !snow albedo (diffuse) +! ------------------------ local variables ---------------------------------------------------- + INTEGER :: IB !waveband class - REAL :: VAI !ELAI+ESAI - REAL :: GDIR !average projected leaf/stem area in solar direction - REAL :: EXT !optical depth direct beam per unit leaf + stem area +! --------------------------------------------------------------------------------------------- +! zero albedos for all points -! -------------------------------------------------------------------------------------------------- + ALBSND(1: NBAND) = 0. + ALBSNI(1: NBAND) = 0. - NBAND = 2 - MPE = 1.E-06 - BGAP = 0. - WGAP = 0. +! when cosz > 0 -! initialize output because solar radiation only done if COSZ > 0 + ALB = 0.55 + (ALBOLD-0.55) * EXP(-0.01*DT/3600.) - DO IB = 1, NBAND - ALBD(IB) = 0. - ALBI(IB) = 0. - ALBGRD(IB) = 0. - ALBGRI(IB) = 0. - FABD(IB) = 0. - FABI(IB) = 0. - FTDD(IB) = 0. - FTID(IB) = 0. - FTII(IB) = 0. - IF (IB.EQ.1) FSUN = 0. - END DO +! 1 mm fresh snow(SWE) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 +! here assume 1cm snow depth will fully cover the old snow - IF(COSZ <= 0) GOTO 100 + IF (QSNOW > 0.) then + ALB = ALB + MIN(QSNOW,parameters%SWEMX/DT) * (0.84-ALB)/(parameters%SWEMX/DT) + ENDIF -! weight reflectance/transmittance by LAI and SAI + ALBSNI(1)= ALB ! vis diffuse + ALBSNI(2)= ALB ! nir diffuse + ALBSND(1)= ALB ! vis direct + ALBSND(2)= ALB ! nir direct - DO IB = 1, NBAND - VAI = ELAI + ESAI - WL = ELAI / MAX(VAI,MPE) - WS = ESAI / MAX(VAI,MPE) - RHO(IB) = MAX(RHOL(IB)*WL+RHOS(IB)*WS, MPE) - TAU(IB) = MAX(TAUL(IB)*WL+TAUS(IB)*WS, MPE) - END DO + END SUBROUTINE SNOWALB_CLASS -! snow age +!== begin groundalb ================================================================================ - CALL SNOW_AGE (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) + SUBROUTINE GROUNDALB (parameters,NSOIL ,NBAND ,ICE ,IST , & !in + FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , & !in + TG ,ILOC ,JLOC , & !in + ALBGRD ,ALBGRI ) !out +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +!input -! snow albedos: only if COSZ > 0 and FSNO > 0 + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL !number of soil layers + INTEGER, INTENT(IN) :: NBAND !number of solar radiation waveband classes + INTEGER, INTENT(IN) :: ICE !value of ist for land ice + INTEGER, INTENT(IN) :: IST !surface type + REAL, INTENT(IN) :: FSNO !fraction of surface covered with snow (-) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water content (m3/m3) + REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSND !direct beam snow albedo (vis, nir) + REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSNI !diffuse snow albedo (vis, nir) - IF(OPT_ALB == 1) & - CALL SNOWALB_BATS (NBAND, FSNO,COSZ,FAGE,ALBSND,ALBSNI) - IF(OPT_ALB == 2) THEN - CALL SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) - ALBOLD = ALB - END IF +!output -! ground surface albedo + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir) + REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir) - CALL GROUNDALB (NSOIL ,NBAND ,ICE ,IST , & !in - FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , & !in - TG ,ILOC ,JLOC , & !in - ALBGRD ,ALBGRI ) !out +!local -! loop over NBAND wavebands to calculate surface albedos and solar -! fluxes for unit incoming direct (IC=0) and diffuse flux (IC=1) + INTEGER :: IB !waveband number (1=vis, 2=nir) + REAL :: INC !soil water correction factor for soil albedo + REAL :: ALBSOD !soil albedo (direct) + REAL :: ALBSOI !soil albedo (diffuse) +! -------------------------------------------------------------------------------------------------- DO IB = 1, NBAND - IC = 0 ! direct - CALL TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in - FWET ,TV ,ALBGRD ,ALBGRI ,RHO , & !in - TAU ,FVEG ,IST ,ILOC ,JLOC , & !in - FABD ,ALBD ,FTDD ,FTID ,GDIR , &!) !out - FREVD ,FREGD ,BGAP ,WGAP) - - IC = 1 ! diffuse - CALL TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in - FWET ,TV ,ALBGRD ,ALBGRI ,RHO , & !in - TAU ,FVEG ,IST ,ILOC ,JLOC , & !in - FABI ,ALBI ,FTDI ,FTII ,GDIR , & !) !out - FREVI ,FREGI ,BGAP ,WGAP) - - END DO - -! sunlit fraction of canopy. set FSUN = 0 if FSUN < 0.01. + INC = MAX(0.11-0.40*SMC(1), 0.) + IF (IST .EQ. 1) THEN !soil + ALBSOD = MIN(parameters%ALBSAT(IB)+INC,parameters%ALBDRY(IB)) + ALBSOI = ALBSOD + ELSE IF (TG .GT. TFRZ) THEN !unfrozen lake, wetland + ALBSOD = 0.06/(MAX(0.01,COSZ)**1.7 + 0.15) + ALBSOI = 0.06 + ELSE !frozen lake, wetland + ALBSOD = parameters%ALBLAK(IB) + ALBSOI = ALBSOD + END IF - EXT = GDIR/COSZ * SQRT(1.-RHO(1)-TAU(1)) - FSUN = (1.-EXP(-EXT*VAI)) / MAX(EXT*VAI,MPE) - EXT = FSUN +! increase desert and semi-desert albedos - IF (EXT .LT. 0.01) THEN - WL = 0. - ELSE - WL = EXT - END IF - FSUN = WL +! IF (IST .EQ. 1 .AND. ISC .EQ. 9) THEN +! ALBSOD = ALBSOD + 0.10 +! ALBSOI = ALBSOI + 0.10 +! end if -100 CONTINUE + ALBGRD(IB) = ALBSOD*(1.-FSNO) + ALBSND(IB)*FSNO + ALBGRI(IB) = ALBSOI*(1.-FSNO) + ALBSNI(IB)*FSNO + END DO - END SUBROUTINE ALBEDO + END SUBROUTINE GROUNDALB -!== begin surrad =================================================================================== +!== begin twostream ================================================================================ - SUBROUTINE SURRAD (MPE ,FSUN ,FSHA ,ELAI ,VAI , & !in - LAISUN ,LAISHA ,SOLAD ,SOLAI ,FABD , & !in - FABI ,FTDD ,FTID ,FTII ,ALBGRD , & !in - ALBGRI ,ALBD ,ALBI ,ILOC ,JLOC , & !in - PARSUN ,PARSHA ,SAV ,SAG ,FSA , & !out - FSR , & !) !out - FREVI ,FREVD ,FREGD ,FREGI ,FSRV , & - FSRG) !inout + SUBROUTINE TWOSTREAM (parameters,IB ,IC ,VEGTYP ,COSZ ,VAI , & !in + FWET ,T ,ALBGRD ,ALBGRI ,RHO , & !in + TAU ,FVEG ,IST ,ILOC ,JLOC , & !in + FAB ,FRE ,FTD ,FTI ,GDIR , & !) !out + FREV ,FREG ,BGAP ,WGAP) +! -------------------------------------------------------------------------------------------------- +! use two-stream approximation of Dickinson (1983) Adv Geophysics +! 25:305-353 and Sellers (1985) Int J Remote Sensing 6:1335-1372 +! to calculate fluxes absorbed by vegetation, reflected by vegetation, +! and transmitted through vegetation for unit incoming direct or diffuse +! flux given an underlying surface with known albedo. ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! input - INTEGER, INTENT(IN) :: ILOC - INTEGER, INTENT(IN) :: JLOC - REAL, INTENT(IN) :: MPE !prevents underflow errors if division by zero + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: IST !surface type + INTEGER, INTENT(IN) :: IB !waveband number + INTEGER, INTENT(IN) :: IC !0=unit incoming direct; 1=unit incoming diffuse + INTEGER, INTENT(IN) :: VEGTYP !vegetation type + + REAL, INTENT(IN) :: COSZ !cosine of direct zenith angle (0-1) + REAL, INTENT(IN) :: VAI !one-sided leaf+stem area index (m2/m2) + REAL, INTENT(IN) :: FWET !fraction of lai, sai that is wetted (-) + REAL, INTENT(IN) :: T !surface temperature (k) - REAL, INTENT(IN) :: FSUN !sunlit fraction of canopy - REAL, INTENT(IN) :: FSHA !shaded fraction of canopy - REAL, INTENT(IN) :: ELAI !leaf area, one-sided - REAL, INTENT(IN) :: VAI !leaf + stem area, one-sided - REAL, INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided - REAL, INTENT(IN) :: LAISHA !shaded leaf area index, one-sided + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !direct albedo of underlying surface (-) + REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !diffuse albedo of underlying surface (-) + REAL, DIMENSION(1:2), INTENT(IN) :: RHO !leaf+stem reflectance + REAL, DIMENSION(1:2), INTENT(IN) :: TAU !leaf+stem transmittance + REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] - REAL, DIMENSION(1:2), INTENT(IN) :: SOLAD !incoming direct solar radiation (w/m2) - REAL, DIMENSION(1:2), INTENT(IN) :: SOLAI !incoming diffuse solar radiation (w/m2) - REAL, DIMENSION(1:2), INTENT(IN) :: FABD !flux abs by veg (per unit incoming direct flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FABI !flux abs by veg (per unit incoming diffuse flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FTDD !down dir flux below veg (per incoming dir flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FTID !down dif flux below veg (per incoming dir flux) - REAL, DIMENSION(1:2), INTENT(IN) :: FTII !down dif flux below veg (per incoming dif flux) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !ground albedo (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !ground albedo (diffuse) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBD !overall surface albedo (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBI !overall surface albedo (diffuse) +! output - REAL, DIMENSION(1:2), INTENT(IN) :: FREVD !overall surface albedo veg (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: FREVI !overall surface albedo veg (diffuse) - REAL, DIMENSION(1:2), INTENT(IN) :: FREGD !overall surface albedo grd (direct) - REAL, DIMENSION(1:2), INTENT(IN) :: FREGI !overall surface albedo grd (diffuse) + REAL, DIMENSION(1:2), INTENT(OUT) :: FAB !flux abs by veg layer (per unit incoming flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FRE !flux refl above veg layer (per unit incoming flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FTD !down dir flux below veg layer (per unit in flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FTI !down dif flux below veg layer (per unit in flux) + REAL, INTENT(OUT) :: GDIR !projected leaf+stem area in solar direction + REAL, DIMENSION(1:2), INTENT(OUT) :: FREV !flux reflected by veg layer (per unit incoming flux) + REAL, DIMENSION(1:2), INTENT(OUT) :: FREG !flux reflected by ground (per unit incoming flux) -! output +! local + REAL :: OMEGA !fraction of intercepted radiation that is scattered + REAL :: OMEGAL !omega for leaves + REAL :: BETAI !upscatter parameter for diffuse radiation + REAL :: BETAIL !betai for leaves + REAL :: BETAD !upscatter parameter for direct beam radiation + REAL :: BETADL !betad for leaves + REAL :: EXT !optical depth of direct beam per unit leaf area + REAL :: AVMU !average diffuse optical depth - REAL, INTENT(OUT) :: PARSUN !average absorbed par for sunlit leaves (w/m2) - REAL, INTENT(OUT) :: PARSHA !average absorbed par for shaded leaves (w/m2) - REAL, INTENT(OUT) :: SAV !solar radiation absorbed by vegetation (w/m2) - REAL, INTENT(OUT) :: SAG !solar radiation absorbed by ground (w/m2) - REAL, INTENT(OUT) :: FSA !total absorbed solar radiation (w/m2) - REAL, INTENT(OUT) :: FSR !total reflected solar radiation (w/m2) - REAL, INTENT(OUT) :: FSRV !reflected solar radiation by vegetation - REAL, INTENT(OUT) :: FSRG !reflected solar radiation by ground + REAL :: COSZI !0.001 <= cosz <= 1.000 + REAL :: ASU !single scattering albedo + REAL :: CHIL ! -0.4 <= xl <= 0.6 -! ------------------------ local variables ---------------------------------------------------- - INTEGER :: IB !waveband number (1=vis, 2=nir) - INTEGER :: NBAND !number of solar radiation waveband classes + REAL :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9 + REAL :: P1,P2,P3,P4,S1,S2,U1,U2,U3 + REAL :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10 + REAL :: PHI1,PHI2,SIGMA + REAL :: FTDS,FTIS,FRES + REAL :: DENFVEG + REAL :: VAI_SPREAD +!jref:start + REAL :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR + REAL :: THETAZ +!jref:end - REAL :: ABS !absorbed solar radiation (w/m2) - REAL :: RNIR !reflected solar radiation [nir] (w/m2) - REAL :: RVIS !reflected solar radiation [vis] (w/m2) - REAL :: LAIFRA !leaf area fraction of canopy - REAL :: TRD !transmitted solar radiation: direct (w/m2) - REAL :: TRI !transmitted solar radiation: diffuse (w/m2) - REAL, DIMENSION(1:2) :: CAD !direct beam absorbed by canopy (w/m2) - REAL, DIMENSION(1:2) :: CAI !diffuse radiation absorbed by canopy (w/m2) -! --------------------------------------------------------------------------------------------- - NBAND = 2 +! variables for the modified two-stream scheme +! Niu and Yang (2004), JGR -! zero summed solar fluxes + REAL, PARAMETER :: PAI = 3.14159265 + REAL :: HD !crown depth (m) + REAL :: BB !vertical crown radius (m) + REAL :: THETAP !angle conversion from SZA + REAL :: FA !foliage volume density (m-1) + REAL :: NEWVAI !effective LSAI (-) - SAG = 0. - SAV = 0. - FSA = 0. + REAL,INTENT(INOUT) :: BGAP !between canopy gap fraction for beam (-) + REAL,INTENT(INOUT) :: WGAP !within canopy gap fraction for beam (-) -! loop over nband wavebands + REAL :: KOPEN !gap fraction for diffue light (-) + REAL :: GAP !total gap fraction for beam ( <=1-shafac ) - DO IB = 1, NBAND +! ----------------------------------------------------------------- +! compute within and between gaps + VAI_SPREAD = VAI + if(VAI == 0.0) THEN + GAP = 1.0 + KOPEN = 1.0 + ELSE + IF(OPT_RAD == 1) THEN + DENFVEG = -LOG(MAX(1.0-FVEG,0.01))/(PAI*parameters%RC**2) + HD = parameters%HVT - parameters%HVB + BB = 0.5 * HD + THETAP = ATAN(BB/parameters%RC * TAN(ACOS(MAX(0.01,COSZ))) ) + ! BGAP = EXP(-parameters%DEN * PAI * parameters%RC**2/COS(THETAP) ) + BGAP = EXP(-DENFVEG * PAI * parameters%RC**2/COS(THETAP) ) + FA = VAI/(1.33 * PAI * parameters%RC**3.0 *(BB/parameters%RC)*DENFVEG) + NEWVAI = HD*FA + WGAP = (1.0-BGAP) * EXP(-0.5*NEWVAI/COSZ) + GAP = MIN(1.0-FVEG, BGAP+WGAP) -! absorbed by canopy + KOPEN = 0.05 + END IF - CAD(IB) = SOLAD(IB)*FABD(IB) - CAI(IB) = SOLAI(IB)*FABI(IB) - SAV = SAV + CAD(IB) + CAI(IB) - FSA = FSA + CAD(IB) + CAI(IB) - -! transmitted solar fluxes incident on ground + IF(OPT_RAD == 2) THEN + GAP = 0.0 + KOPEN = 0.0 + END IF - TRD = SOLAD(IB)*FTDD(IB) - TRI = SOLAD(IB)*FTID(IB) + SOLAI(IB)*FTII(IB) + IF(OPT_RAD == 3) THEN + GAP = 1.0-FVEG + KOPEN = 1.0-FVEG + END IF + end if -! solar radiation absorbed by ground surface +! calculate two-stream parameters OMEGA, BETAD, BETAI, AVMU, GDIR, EXT. +! OMEGA, BETAD, BETAI are adjusted for snow. values for OMEGA*BETAD +! and OMEGA*BETAI are calculated and then divided by the new OMEGA +! because the product OMEGA*BETAI, OMEGA*BETAD is used in solution. +! also, the transmittances and reflectances (TAU, RHO) are linear +! weights of leaf and stem values. - ABS = TRD*(1.-ALBGRD(IB)) + TRI*(1.-ALBGRI(IB)) - SAG = SAG + ABS - FSA = FSA + ABS - END DO + COSZI = MAX(0.001, COSZ) + CHIL = MIN( MAX(parameters%XL, -0.4), 0.6) + IF (ABS(CHIL) .LE. 0.01) CHIL = 0.01 + PHI1 = 0.5 - 0.633*CHIL - 0.330*CHIL*CHIL + PHI2 = 0.877 * (1.-2.*PHI1) + GDIR = PHI1 + PHI2*COSZI + EXT = GDIR/COSZI + AVMU = ( 1. - PHI1/PHI2 * LOG((PHI1+PHI2)/PHI1) ) / PHI2 + OMEGAL = RHO(IB) + TAU(IB) + TMP0 = GDIR + PHI2*COSZI + TMP1 = PHI1*COSZI + ASU = 0.5*OMEGAL*GDIR/TMP0 * ( 1.-TMP1/TMP0*LOG((TMP1+TMP0)/TMP1) ) + BETADL = (1.+AVMU*EXT)/(OMEGAL*AVMU*EXT)*ASU + BETAIL = 0.5 * ( RHO(IB)+TAU(IB) + (RHO(IB)-TAU(IB)) & + * ((1.+CHIL)/2.)**2 ) / OMEGAL -! partition visible canopy absorption to sunlit and shaded fractions -! to get average absorbed par for sunlit and shaded leaves +! adjust omega, betad, and betai for intercepted snow - LAIFRA = ELAI / MAX(VAI,MPE) - IF (FSUN .GT. 0.) THEN - PARSUN = (CAD(1)+FSUN*CAI(1)) * LAIFRA / MAX(LAISUN,MPE) - PARSHA = (FSHA*CAI(1))*LAIFRA / MAX(LAISHA,MPE) + IF (T .GT. TFRZ) THEN !no snow + TMP0 = OMEGAL + TMP1 = BETADL + TMP2 = BETAIL ELSE - PARSUN = 0. - PARSHA = (CAD(1)+CAI(1))*LAIFRA /MAX(LAISHA,MPE) - ENDIF + TMP0 = (1.-FWET)*OMEGAL + FWET*parameters%OMEGAS(IB) + TMP1 = ( (1.-FWET)*OMEGAL*BETADL + FWET*parameters%OMEGAS(IB)*parameters%BETADS ) / TMP0 + TMP2 = ( (1.-FWET)*OMEGAL*BETAIL + FWET*parameters%OMEGAS(IB)*parameters%BETAIS ) / TMP0 + END IF -! reflected solar radiation + OMEGA = TMP0 + BETAD = TMP1 + BETAI = TMP2 - RVIS = ALBD(1)*SOLAD(1) + ALBI(1)*SOLAI(1) - RNIR = ALBD(2)*SOLAD(2) + ALBI(2)*SOLAI(2) - FSR = RVIS + RNIR +! absorbed, reflected, transmitted fluxes per unit incoming radiation -! reflected solar radiation of veg. and ground (combined ground) - FSRV = FREVD(1)*SOLAD(1)+FREVI(1)*SOLAI(1)+FREVD(2)*SOLAD(2)+FREVI(2)*SOLAI(2) - FSRG = FREGD(1)*SOLAD(1)+FREGI(1)*SOLAI(1)+FREGD(2)*SOLAD(2)+FREGI(2)*SOLAI(2) + B = 1. - OMEGA + OMEGA*BETAI + C = OMEGA*BETAI + TMP0 = AVMU*EXT + D = TMP0 * OMEGA*BETAD + F = TMP0 * OMEGA*(1.-BETAD) + TMP1 = B*B - C*C + H = SQRT(TMP1) / AVMU + SIGMA = TMP0*TMP0 - TMP1 + if ( ABS (SIGMA) < 1.e-6 ) SIGMA = SIGN(1.e-6,SIGMA) + P1 = B + AVMU*H + P2 = B - AVMU*H + P3 = B + TMP0 + P4 = B - TMP0 + S1 = EXP(-H*VAI) + S2 = EXP(-EXT*VAI) + IF (IC .EQ. 0) THEN + U1 = B - C/ALBGRD(IB) + U2 = B - C*ALBGRD(IB) + U3 = F + C*ALBGRD(IB) + ELSE + U1 = B - C/ALBGRI(IB) + U2 = B - C*ALBGRI(IB) + U3 = F + C*ALBGRI(IB) + END IF + TMP2 = U1 - AVMU*H + TMP3 = U1 + AVMU*H + D1 = P1*TMP2/S1 - P2*TMP3*S1 + TMP4 = U2 + AVMU*H + TMP5 = U2 - AVMU*H + D2 = TMP4/S1 - TMP5*S1 + H1 = -D*P4 - C*F + TMP6 = D - H1*P3/SIGMA + TMP7 = ( D - C - H1/SIGMA*(U1+TMP0) ) * S2 + H2 = ( TMP6*TMP2/S1 - P2*TMP7 ) / D1 + H3 = - ( TMP6*TMP3*S1 - P1*TMP7 ) / D1 + H4 = -F*P3 - C*D + TMP8 = H4/SIGMA + TMP9 = ( U3 - TMP8*(U2-TMP0) ) * S2 + H5 = - ( TMP8*TMP4/S1 + TMP9 ) / D2 + H6 = ( TMP8*TMP5*S1 + TMP9 ) / D2 + H7 = (C*TMP2) / (D1*S1) + H8 = (-C*TMP3*S1) / D1 + H9 = TMP4 / (D2*S1) + H10 = (-TMP5*S1) / D2 +! downward direct and diffuse fluxes below vegetation +! Niu and Yang (2004), JGR. - END SUBROUTINE SURRAD + IF (IC .EQ. 0) THEN + FTDS = S2 *(1.0-GAP) + GAP + FTIS = (H4*S2/SIGMA + H5*S1 + H6/S1)*(1.0-GAP) + ELSE + FTDS = 0. + FTIS = (H9*S1 + H10/S1)*(1.0-KOPEN) + KOPEN + END IF + FTD(IB) = FTDS + FTI(IB) = FTIS + +! flux reflected by the surface (veg. and ground) + + IF (IC .EQ. 0) THEN + FRES = (H1/SIGMA + H2 + H3)*(1.0-GAP ) + ALBGRD(IB)*GAP + FREVEG = (H1/SIGMA + H2 + H3)*(1.0-GAP ) + FREBAR = ALBGRD(IB)*GAP !jref - separate veg. and ground reflection + ELSE + FRES = (H7 + H8) *(1.0-KOPEN) + ALBGRI(IB)*KOPEN + FREVEG = (H7 + H8) *(1.0-KOPEN) + ALBGRI(IB)*KOPEN + FREBAR = 0 !jref - separate veg. and ground reflection + END IF + FRE(IB) = FRES -!== begin snow_age ================================================================================= + FREV(IB) = FREVEG + FREG(IB) = FREBAR - SUBROUTINE SNOW_AGE (DT,TG,SNEQVO,SNEQV,TAUSS,FAGE) -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: SWEMX, & ! SNOW GLOBAL - TFRZ ! MP CONSTANT -! -------------------------------------------------------------------------------------------------- - IMPLICIT NONE -! ------------------------ code history ------------------------------------------------------------ -! from BATS -! ------------------------ input/output variables -------------------------------------------------- -!input - REAL, INTENT(IN) :: DT !main time step (s) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: SNEQVO !snow mass at last time step(mm) - REAL, INTENT(IN) :: SNEQV !snow water per unit ground area (mm) +! flux absorbed by vegetation -!output - REAL, INTENT(OUT) :: FAGE !snow age + FAB(IB) = 1. - FRE(IB) - (1.-ALBGRD(IB))*FTD(IB) & + - (1.-ALBGRI(IB))*FTI(IB) -!input/output - REAL, INTENT(INOUT) :: TAUSS !non-dimensional snow age -!local - REAL :: TAGE !total aging effects - REAL :: AGE1 !effects of grain growth due to vapor diffusion - REAL :: AGE2 !effects of grain growth at freezing of melt water - REAL :: AGE3 !effects of soot - REAL :: DELA !temporary variable - REAL :: SGE !temporary variable - REAL :: DELS !temporary variable - REAL :: DELA0 !temporary variable - REAL :: ARG !temporary variable -! See Yang et al. (1997) J.of Climate for detail. -!--------------------------------------------------------------------------------------------------- +!if(iloc == 1.and.jloc == 2) then +! write(*,'(a7,2i2,5(a6,f8.4),2(a9,f8.4))') "ib,ic: ",ib,ic," GAP: ",GAP," FTD: ",FTD(IB)," FTI: ",FTI(IB)," FRE: ", & +! FRE(IB)," FAB: ",FAB(IB)," ALBGRD: ",ALBGRD(IB)," ALBGRI: ",ALBGRI(IB) +!end if - IF(SNEQV.LE.0.0) THEN - TAUSS = 0. - ELSE IF (SNEQV.GT.800.) THEN - TAUSS = 0. - ELSE - DELA0 = 1.E-6*DT - ARG = 5.E3*(1./TFRZ-1./TG) - AGE1 = EXP(ARG) - AGE2 = EXP(AMIN1(0.,10.*ARG)) - AGE3 = 0.3 - TAGE = AGE1+AGE2+AGE3 - DELA = DELA0*TAGE - DELS = AMAX1(0.0,SNEQV-SNEQVO) / SWEMX - SGE = (TAUSS+DELA)*(1.0-DELS) - TAUSS = AMAX1(0.,SGE) - ENDIF + END SUBROUTINE TWOSTREAM - FAGE= TAUSS/(TAUSS+1.) +!== begin vege_flux ================================================================================ - END SUBROUTINE SNOW_AGE + SUBROUTINE VEGE_FLUX(parameters,NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in + DT ,SAV ,SAG ,LWDN ,UR , & !in + UU ,VV ,SFCTMP ,THAIR ,QAIR , & !in + EAIR ,RHOAIR ,SNOWH ,VAI ,GAMMAV ,GAMMAG, & !in + FWET ,LAISUN ,LAISHA ,CWP ,DZSNSO , & !in + ZLVL ,ZPD ,Z0M ,FVEG , & !in + Z0MG ,EMV ,EMG ,CANLIQ ,FSNO, & !in + CANICE ,STC ,DF ,RSSUN ,RSSHA , & !in + RSURF ,LATHEAV ,LATHEAG ,PARSUN ,PARSHA ,IGS , & !in + FOLN ,CO2AIR ,O2AIR ,BTRAN ,SFCPRS , & !in + RHSUR ,ILOC ,JLOC ,Q2 ,PAHV ,PAHG , & !in + EAH ,TAH ,TV ,TG ,CM , & !inout + CH ,DX ,DZ8W , & ! + TAUXV ,TAUYV ,IRG ,IRC ,SHG , & !out + SHC ,EVG ,EVC ,TR ,GH , & !out + T2MV ,PSNSUN ,PSNSHA , & !out + QC ,QSFC ,PSFC , & !in + Q2V ,CAH2 ,CHLEAF ,CHUC ) !inout -!== begin snowalb_bats ============================================================================= +! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve for vegetation (tv) and +! ground (tg) temperatures that balance the surface energy budgets - SUBROUTINE SNOWALB_BATS (NBAND,FSNO,COSZ,FAGE,ALBSND,ALBSNI) +! vegetated: +! -SAV + IRC[TV] + SHC[TV] + EVC[TV] + TR[TV] = 0 +! -SAG + IRG[TG] + SHG[TG] + EVG[TG] + GH[TG] = 0 ! -------------------------------------------------------------------------------------------------- IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + LOGICAL, INTENT(IN) :: VEG !true if vegetated surface + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !number of soil layers + INTEGER, INTENT(IN) :: ISNOW !actual no. of snow layers + INTEGER, INTENT(IN) :: VEGTYP !vegetation physiology type + REAL, INTENT(IN) :: FVEG !greeness vegetation fraction (-) + REAL, INTENT(IN) :: SAV !solar rad absorbed by veg (w/m2) + REAL, INTENT(IN) :: SAG !solar rad absorbed by ground (w/m2) + REAL, INTENT(IN) :: LWDN !atmospheric longwave radiation (w/m2) + REAL, INTENT(IN) :: UR !wind speed at height zlvl (m/s) + REAL, INTENT(IN) :: UU !wind speed in eastward dir (m/s) + REAL, INTENT(IN) :: VV !wind speed in northward dir (m/s) + REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) + REAL, INTENT(IN) :: THAIR !potential temp at reference height (k) + REAL, INTENT(IN) :: EAIR !vapor pressure air at zlvl (pa) + REAL, INTENT(IN) :: QAIR !specific humidity at zlvl (kg/kg) + REAL, INTENT(IN) :: RHOAIR !density air (kg/m**3) + REAL, INTENT(IN) :: DT !time step (s) + REAL, INTENT(IN) :: FSNO !snow fraction - INTEGER,INTENT(IN) :: NBAND !number of waveband classes + REAL, INTENT(IN) :: SNOWH !actual snow depth [m] + REAL, INTENT(IN) :: FWET !wetted fraction of canopy + REAL, INTENT(IN) :: CWP !canopy wind parameter - REAL,INTENT(IN) :: COSZ !cosine solar zenith angle - REAL,INTENT(IN) :: FSNO !snow cover fraction (-) - REAL,INTENT(IN) :: FAGE !snow age correction + REAL, INTENT(IN) :: VAI !total leaf area index + stem area index + REAL, INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided (m2/m2) + REAL, INTENT(IN) :: LAISHA !shaded leaf area index, one-sided (m2/m2) + REAL, INTENT(IN) :: ZLVL !reference height (m) + REAL, INTENT(IN) :: ZPD !zero plane displacement (m) + REAL, INTENT(IN) :: Z0M !roughness length, momentum (m) + REAL, INTENT(IN) :: Z0MG !roughness length, momentum, ground (m) + REAL, INTENT(IN) :: EMV !vegetation emissivity + REAL, INTENT(IN) :: EMG !ground emissivity + + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !soil/snow temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity of snow/soil (w/m/k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thinkness of snow/soil layers (m) + REAL, INTENT(IN) :: CANLIQ !intercepted liquid water (mm) + REAL, INTENT(IN) :: CANICE !intercepted ice mass (mm) + REAL, INTENT(IN) :: RSURF !ground surface resistance (s/m) +! REAL, INTENT(IN) :: GAMMA !psychrometric constant (pa/K) +! REAL, INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg) + REAL, INTENT(IN) :: GAMMAV !psychrometric constant (pa/K) + REAL, INTENT(IN) :: LATHEAV !latent heat of vaporization/subli (j/kg) + REAL, INTENT(IN) :: GAMMAG !psychrometric constant (pa/K) + REAL, INTENT(IN) :: LATHEAG !latent heat of vaporization/subli (j/kg) + REAL, INTENT(IN) :: PARSUN !par absorbed per unit sunlit lai (w/m2) + REAL, INTENT(IN) :: PARSHA !par absorbed per unit shaded lai (w/m2) + REAL, INTENT(IN) :: FOLN !foliage nitrogen (%) + REAL, INTENT(IN) :: CO2AIR !atmospheric co2 concentration (pa) + REAL, INTENT(IN) :: O2AIR !atmospheric o2 concentration (pa) + REAL, INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL, INTENT(IN) :: SFCPRS !pressure (pa) + REAL, INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) + REAL, INTENT(IN) :: RHSUR !raltive humidity in surface soil/snow air space (-) + + REAL , INTENT(IN) :: QC !cloud water mixing ratio + REAL , INTENT(IN) :: PSFC !pressure at lowest model layer + REAL , INTENT(IN) :: DX !grid spacing + REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) + REAL , INTENT(IN) :: DZ8W !thickness of lowest layer + REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer + REAL, INTENT(IN) :: PAHV !precipitation advected heat - canopy net IN (W/m2) + REAL, INTENT(IN) :: PAHG !precipitation advected heat - ground net IN (W/m2) + +! input/output + REAL, INTENT(INOUT) :: EAH !canopy air vapor pressure (pa) + REAL, INTENT(INOUT) :: TAH !canopy air temperature (k) + REAL, INTENT(INOUT) :: TV !vegetation temperature (k) + REAL, INTENT(INOUT) :: TG !ground temperature (k) + REAL, INTENT(INOUT) :: CM !momentum drag coefficient + REAL, INTENT(INOUT) :: CH !sensible heat exchange coefficient ! output +! -FSA + FIRA + FSH + (FCEV + FCTR + FGEV) + FCST + SSOIL = 0 + REAL, INTENT(OUT) :: TAUXV !wind stress: e-w (n/m2) + REAL, INTENT(OUT) :: TAUYV !wind stress: n-s (n/m2) + REAL, INTENT(OUT) :: IRC !net longwave radiation (w/m2) [+= to atm] + REAL, INTENT(OUT) :: SHC !sensible heat flux (w/m2) [+= to atm] + REAL, INTENT(OUT) :: EVC !evaporation heat flux (w/m2) [+= to atm] + REAL, INTENT(OUT) :: IRG !net longwave radiation (w/m2) [+= to atm] + REAL, INTENT(OUT) :: SHG !sensible heat flux (w/m2) [+= to atm] + REAL, INTENT(OUT) :: EVG !evaporation heat flux (w/m2) [+= to atm] + REAL, INTENT(OUT) :: TR !transpiration heat flux (w/m2)[+= to atm] + REAL, INTENT(OUT) :: GH !ground heat (w/m2) [+ = to soil] + REAL, INTENT(OUT) :: T2MV !2 m height air temperature (k) + REAL, INTENT(OUT) :: PSNSUN !sunlit leaf photosynthesis (umolco2/m2/s) + REAL, INTENT(OUT) :: PSNSHA !shaded leaf photosynthesis (umolco2/m2/s) + REAL, INTENT(OUT) :: CHLEAF !leaf exchange coefficient + REAL, INTENT(OUT) :: CHUC !under canopy exchange coefficient - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse -! --------------------------------------------------------------------------------------------- + REAL, INTENT(OUT) :: Q2V + REAL :: CAH !sensible heat conductance, canopy air to ZLVL air (m/s) + REAL :: U10V !10 m wind speed in eastward dir (m/s) + REAL :: V10V !10 m wind speed in eastward dir (m/s) + REAL :: WSPD ! ------------------------ local variables ---------------------------------------------------- - INTEGER :: IB !waveband class + REAL :: CW !water vapor exchange coefficient + REAL :: FV !friction velocity (m/s) + REAL :: WSTAR !friction velocity n vertical direction (m/s) (only for SFCDIF2) + REAL :: Z0H !roughness length, sensible heat (m) + REAL :: Z0HG !roughness length, sensible heat (m) + REAL :: RB !bulk leaf boundary layer resistance (s/m) + REAL :: RAMC !aerodynamic resistance for momentum (s/m) + REAL :: RAHC !aerodynamic resistance for sensible heat (s/m) + REAL :: RAWC !aerodynamic resistance for water vapor (s/m) + REAL :: RAMG !aerodynamic resistance for momentum (s/m) + REAL :: RAHG !aerodynamic resistance for sensible heat (s/m) + REAL :: RAWG !aerodynamic resistance for water vapor (s/m) - REAL :: FZEN !zenith angle correction - REAL :: CF1 !temperary variable - REAL :: SL2 !2.*SL - REAL :: SL1 !1/SL - REAL :: SL !adjustable parameter - REAL, PARAMETER :: C1 = 0.2 !default in BATS - REAL, PARAMETER :: C2 = 0.5 !default in BATS -! REAL, PARAMETER :: C1 = 0.2 * 2. ! double the default to match Sleepers River's -! REAL, PARAMETER :: C2 = 0.5 * 2. ! snow surface albedo (double aging effects) -! --------------------------------------------------------------------------------------------- -! zero albedos for all points + REAL, INTENT(OUT) :: RSSUN !sunlit leaf stomatal resistance (s/m) + REAL, INTENT(OUT) :: RSSHA !shaded leaf stomatal resistance (s/m) - ALBSND(1: NBAND) = 0. - ALBSNI(1: NBAND) = 0. + REAL :: MOL !Monin-Obukhov length (m) + REAL :: DTV !change in tv, last iteration (k) + REAL :: DTG !change in tg, last iteration (k) -! when cosz > 0 + REAL :: AIR,CIR !coefficients for ir as function of ts**4 + REAL :: CSH !coefficients for sh as function of ts + REAL :: CEV !coefficients for ev as function of esat[ts] + REAL :: CGH !coefficients for st as function of ts + REAL :: ATR,CTR !coefficients for tr as function of esat[ts] + REAL :: ATA,BTA !coefficients for tah as function of ts + REAL :: AEA,BEA !coefficients for eah as function of esat[ts] - SL=2.0 - SL1=1./SL - SL2=2.*SL - CF1=((1.+SL1)/(1.+SL2*COSZ)-SL1) - FZEN=AMAX1(CF1,0.) + REAL :: ESTV !saturation vapor pressure at tv (pa) + REAL :: ESTG !saturation vapor pressure at tg (pa) + REAL :: DESTV !d(es)/dt at ts (pa/k) + REAL :: DESTG !d(es)/dt at tg (pa/k) + REAL :: ESATW !es for water + REAL :: ESATI !es for ice + REAL :: DSATW !d(es)/dt at tg (pa/k) for water + REAL :: DSATI !d(es)/dt at tg (pa/k) for ice + + REAL :: FM !momentum stability correction, weighted by prior iters + REAL :: FH !sen heat stability correction, weighted by prior iters + REAL :: FHG !sen heat stability correction, ground + REAL :: HCAN !canopy height (m) [note: hcan >= z0mg] + + REAL :: A !temporary calculation + REAL :: B !temporary calculation + REAL :: CVH !sensible heat conductance, leaf surface to canopy air (m/s) + REAL :: CAW !latent heat conductance, canopy air ZLVL air (m/s) + REAL :: CTW !transpiration conductance, leaf to canopy air (m/s) + REAL :: CEW !evaporation conductance, leaf to canopy air (m/s) + REAL :: CGW !latent heat conductance, ground to canopy air (m/s) + REAL :: COND !sum of conductances (s/m) + REAL :: UC !wind speed at top of canopy (m/s) + REAL :: KH !turbulent transfer coefficient, sensible heat, (m2/s) + REAL :: H !temporary sensible heat flux (w/m2) + REAL :: HG !temporary sensible heat flux (w/m2) + REAL :: MOZ !Monin-Obukhov stability parameter + REAL :: MOZG !Monin-Obukhov stability parameter + REAL :: MOZOLD !Monin-Obukhov stability parameter from prior iteration + REAL :: FM2 !Monin-Obukhov momentum adjustment at 2m + REAL :: FH2 !Monin-Obukhov heat adjustment at 2m + REAL :: CH2 !Surface exchange at 2m + REAL :: THSTAR !Surface exchange at 2m - ALBSNI(1)=0.95*(1.-C1*FAGE) - ALBSNI(2)=0.65*(1.-C2*FAGE) + REAL :: THVAIR + REAL :: THAH + REAL :: RAHC2 !aerodynamic resistance for sensible heat (s/m) + REAL :: RAWC2 !aerodynamic resistance for water vapor (s/m) + REAL, INTENT(OUT):: CAH2 !sensible heat conductance for diagnostics + REAL :: CH2V !exchange coefficient for 2m over vegetation. + REAL :: CQ2V !exchange coefficient for 2m over vegetation. + REAL :: EAH2 !2m vapor pressure over canopy + REAL :: QFX !moisture flux + REAL :: E1 - ALBSND(1)=ALBSNI(1)+0.4*FZEN*(1.-ALBSNI(1)) ! vis direct - ALBSND(2)=ALBSNI(2)+0.4*FZEN*(1.-ALBSNI(2)) ! nir direct - END SUBROUTINE SNOWALB_BATS + REAL :: VAIE !total leaf area index + stem area index,effective + REAL :: LAISUNE !sunlit leaf area index, one-sided (m2/m2),effective + REAL :: LAISHAE !shaded leaf area index, one-sided (m2/m2),effective -!== begin snowalb_class ============================================================================ + INTEGER :: K !index + INTEGER :: ITER !iteration index - SUBROUTINE SNOWALB_CLASS (NBAND,QSNOW,DT,ALB,ALBOLD,ALBSND,ALBSNI,ILOC,JLOC) -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: SWEMX ! SNOW GLOBAL -! -------------------------------------------------------------------------------------------------- - IMPLICIT NONE -! -------------------------------------------------------------------------------------------------- -! input +!jref - NITERC test from 5 to 20 + INTEGER, PARAMETER :: NITERC = 20 !number of iterations for surface temperature +!jref - NITERG test from 3-5 + INTEGER, PARAMETER :: NITERG = 5 !number of iterations for ground temperature + INTEGER :: MOZSGN !number of times MOZ changes sign + REAL :: MPE !prevents overflow error if division by zero - INTEGER,INTENT(IN) :: ILOC !grid index - INTEGER,INTENT(IN) :: JLOC !grid index - INTEGER,INTENT(IN) :: NBAND !number of waveband classes + INTEGER :: LITER !Last iteration - REAL,INTENT(IN) :: QSNOW !snowfall (mm/s) - REAL,INTENT(IN) :: DT !time step (sec) - REAL,INTENT(IN) :: ALBOLD !snow albedo at last time step -! in & out + REAL :: T, TDC !Kelvin to degree Celsius with limit -50 to +50 - REAL, INTENT(INOUT) :: ALB ! -! output + character(len=80) :: message - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSND !snow albedo for direct(1=vis, 2=nir) - REAL, DIMENSION(1:2),INTENT(OUT) :: ALBSNI !snow albedo for diffuse + TDC(T) = MIN( 50., MAX(-50.,(T-TFRZ)) ) ! --------------------------------------------------------------------------------------------- -! ------------------------ local variables ---------------------------------------------------- - INTEGER :: IB !waveband class + MPE = 1E-6 + LITER = 0 + FV = 0.1 ! --------------------------------------------------------------------------------------------- -! zero albedos for all points - - ALBSND(1: NBAND) = 0. - ALBSNI(1: NBAND) = 0. - -! when cosz > 0 - - ALB = 0.55 + (ALBOLD-0.55) * EXP(-0.01*DT/3600.) - -! 1 mm fresh snow(SWE) -- 10mm snow depth, assumed the fresh snow density 100kg/m3 -! here assume 1cm snow depth will fully cover the old snow +! initialization variables that do not depend on stability iteration +! --------------------------------------------------------------------------------------------- + DTV = 0. + DTG = 0. + MOZ = 0. + MOZSGN = 0 + MOZOLD = 0. + HG = 0. + H = 0. + QFX = 0. - IF (QSNOW > 0.) then - ALB = ALB + MIN(QSNOW,SWEMX/DT) * (0.84-ALB)/(SWEMX/DT) - ENDIF +! convert grid-cell LAI to the fractional vegetated area (FVEG) - ALBSNI(1)= ALB ! vis diffuse - ALBSNI(2)= ALB ! nir diffuse - ALBSND(1)= ALB ! vis direct - ALBSND(2)= ALB ! nir direct + VAIE = MIN(6.,VAI / FVEG) + LAISUNE = MIN(6.,LAISUN / FVEG) + LAISHAE = MIN(6.,LAISHA / FVEG) - END SUBROUTINE SNOWALB_CLASS +! saturation vapor pressure at ground temperature -!== begin groundalb ================================================================================ + T = TDC(TG) + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + IF (T .GT. 0.) THEN + ESTG = ESATW + ELSE + ESTG = ESATI + END IF - SUBROUTINE GROUNDALB (NSOIL ,NBAND ,ICE ,IST , & !in - FSNO ,SMC ,ALBSND ,ALBSNI ,COSZ , & !in - TG ,ILOC ,JLOC , & !in - ALBGRD ,ALBGRI ) !out -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: ALBSAT, ALBDRY, ALBLAK, & ! SOIL/SURFACE AND RAD DEPENDENT - TFRZ ! MP CONSTANT -! -------------------------------------------------------------------------------------------------- - IMPLICIT NONE -! -------------------------------------------------------------------------------------------------- -!input +!jref - consistent surface specific humidity for sfcdif3 and sfcdif4 - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: NSOIL !number of soil layers - INTEGER, INTENT(IN) :: NBAND !number of solar radiation waveband classes - INTEGER, INTENT(IN) :: ICE !value of ist for land ice - INTEGER, INTENT(IN) :: IST !surface type - REAL, INTENT(IN) :: FSNO !fraction of surface covered with snow (-) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: COSZ !cosine solar zenith angle (0-1) - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC !volumetric soil water content (m3/m3) - REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSND !direct beam snow albedo (vis, nir) - REAL, DIMENSION(1: 2), INTENT(IN) :: ALBSNI !diffuse snow albedo (vis, nir) + QSFC = 0.622*EAIR/(PSFC-0.378*EAIR) -!output +! canopy height - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRD !ground albedo (direct beam: vis, nir) - REAL, DIMENSION(1: 2), INTENT(OUT) :: ALBGRI !ground albedo (diffuse: vis, nir) + HCAN = parameters%HVT + UC = UR*LOG(HCAN/Z0M)/LOG(ZLVL/Z0M) + UC = UR*LOG((HCAN-ZPD+Z0M)/Z0M)/LOG(ZLVL/Z0M) ! MB: add ZPD v3.7 + IF((HCAN-ZPD) <= 0.) THEN + WRITE(message,*) "CRITICAL PROBLEM: HCAN <= ZPD" + call wrf_message ( message ) + WRITE(message,*) 'i,j point=',ILOC, JLOC + call wrf_message ( message ) + WRITE(message,*) 'HCAN =',HCAN + call wrf_message ( message ) + WRITE(message,*) 'ZPD =',ZPD + call wrf_message ( message ) + write (message, *) 'SNOWH =',SNOWH + call wrf_message ( message ) + call wrf_error_fatal ( "CRITICAL PROBLEM IN MODULE_SF_NOAHMPLSM:VEGEFLUX" ) + END IF -!local +! prepare for longwave rad. - INTEGER :: IB !waveband number (1=vis, 2=nir) - REAL :: INC !soil water correction factor for soil albedo - REAL :: ALBSOD !soil albedo (direct) - REAL :: ALBSOI !soil albedo (diffuse) -! -------------------------------------------------------------------------------------------------- + AIR = -EMV*(1.+(1.-EMV)*(1.-EMG))*LWDN - EMV*EMG*SB*TG**4 + CIR = (2.-EMV*(1.-EMG))*EMV*SB +! --------------------------------------------------------------------------------------------- + loop1: DO ITER = 1, NITERC ! begin stability iteration - DO IB = 1, NBAND - INC = MAX(0.11-0.40*SMC(1), 0.) - IF (IST .EQ. 1) THEN !soil - ALBSOD = MIN(ALBSAT(IB)+INC,ALBDRY(IB)) - ALBSOI = ALBSOD - ELSE IF (TG .GT. TFRZ) THEN !unfrozen lake, wetland - ALBSOD = 0.06/(MAX(0.01,COSZ)**1.7 + 0.15) - ALBSOI = 0.06 - ELSE !frozen lake, wetland - ALBSOD = ALBLAK(IB) - ALBSOI = ALBSOD - END IF + IF(ITER == 1) THEN + Z0H = Z0M + Z0HG = Z0MG + ELSE + Z0H = Z0M !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0M)) + Z0HG = Z0MG !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0MG)) + END IF -! increase desert and semi-desert albedos +! aerodyn resistances between heights zlvl and d+z0v -! IF (IST .EQ. 1 .AND. ISC .EQ. 9) THEN -! ALBSOD = ALBSOD + 0.10 -! ALBSOI = ALBSOI + 0.10 -! end if + IF(OPT_SFC == 1) THEN + CALL SFCDIF1(parameters,ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in + ZLVL ,ZPD ,Z0M ,Z0H ,UR , & !in + MPE ,ILOC ,JLOC , & !in + MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, & !inout + CM ,CH ,FV ,CH2 ) !out + ENDIF + + IF(OPT_SFC == 2) THEN + CALL SFCDIF2(parameters,ITER ,Z0M ,TAH ,THAIR ,UR , & !in + ZLVL ,ILOC ,JLOC , & !in + CM ,CH ,MOZ ,WSTAR , & !in + FV ) !out + ! Undo the multiplication by windspeed that SFCDIF2 + ! applies to exchange coefficients CH and CM: + CH = CH / UR + CM = CM / UR + ENDIF - ALBGRD(IB) = ALBSOD*(1.-FSNO) + ALBSND(IB)*FSNO - ALBGRI(IB) = ALBSOI*(1.-FSNO) + ALBSNI(IB)*FSNO - END DO + RAMC = MAX(1.,1./(CM*UR)) + RAHC = MAX(1.,1./(CH*UR)) + RAWC = RAHC - END SUBROUTINE GROUNDALB +! aerodyn resistance between heights z0g and d+z0v, RAG, and leaf +! boundary layer resistance, RB + + CALL RAGRB(parameters,ITER ,VAIE ,RHOAIR ,HG ,TAH , & !in + ZPD ,Z0MG ,Z0HG ,HCAN ,UC , & !in + Z0H ,FV ,CWP ,VEGTYP ,MPE , & !in + TV ,MOZG ,FHG ,ILOC ,JLOC , & !inout + RAMG ,RAHG ,RAWG ,RB ) !out -!== begin twostream ================================================================================ +! es and d(es)/dt evaluated at tv - SUBROUTINE TWOSTREAM (IB ,IC ,VEGTYP ,COSZ ,VAI , & !in - FWET ,T ,ALBGRD ,ALBGRI ,RHO , & !in - TAU ,FVEG ,IST ,ILOC ,JLOC , & !in - FAB ,FRE ,FTD ,FTI ,GDIR , & !) !out - FREV ,FREG ,BGAP ,WGAP) + T = TDC(TV) + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + IF (T .GT. 0.) THEN + ESTV = ESATW + DESTV = DSATW + ELSE + ESTV = ESATI + DESTV = DSATI + END IF -! -------------------------------------------------------------------------------------------------- -! use two-stream approximation of Dickinson (1983) Adv Geophysics -! 25:305-353 and Sellers (1985) Int J Remote Sensing 6:1335-1372 -! to calculate fluxes absorbed by vegetation, reflected by vegetation, -! and transmitted through vegetation for unit incoming direct or diffuse -! flux given an underlying surface with known albedo. -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: RC, HVT, HVB, DEN, XL, & ! VEGETATION DEPENDENT - OMEGAS, BETADS, BETAIS, & ! RAD DEPENDENT - TFRZ ! MP CONSTANT -! -------------------------------------------------------------------------------------------------- - IMPLICIT NONE -! -------------------------------------------------------------------------------------------------- -! input +! stomatal resistance + + IF(ITER == 1) THEN + IF (OPT_CRS == 1) then ! Ball-Berry + CALL STOMATA (parameters,VEGTYP,MPE ,PARSUN ,FOLN ,ILOC , JLOC , & !in + TV ,ESTV ,EAH ,SFCTMP,SFCPRS, & !in + O2AIR ,CO2AIR,IGS ,BTRAN ,RB , & !in + RSSUN ,PSNSUN) !out - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: IST !surface type - INTEGER, INTENT(IN) :: IB !waveband number - INTEGER, INTENT(IN) :: IC !0=unit incoming direct; 1=unit incoming diffuse - INTEGER, INTENT(IN) :: VEGTYP !vegetation type + CALL STOMATA (parameters,VEGTYP,MPE ,PARSHA ,FOLN ,ILOC , JLOC , & !in + TV ,ESTV ,EAH ,SFCTMP,SFCPRS, & !in + O2AIR ,CO2AIR,IGS ,BTRAN ,RB , & !in + RSSHA ,PSNSHA) !out + END IF - REAL, INTENT(IN) :: COSZ !cosine of direct zenith angle (0-1) - REAL, INTENT(IN) :: VAI !one-sided leaf+stem area index (m2/m2) - REAL, INTENT(IN) :: FWET !fraction of lai, sai that is wetted (-) - REAL, INTENT(IN) :: T !surface temperature (k) + IF (OPT_CRS == 2) then ! Jarvis + CALL CANRES (parameters,PARSUN,TV ,BTRAN ,EAH ,SFCPRS, & !in + RSSUN ,PSNSUN,ILOC ,JLOC ) !out - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRD !direct albedo of underlying surface (-) - REAL, DIMENSION(1:2), INTENT(IN) :: ALBGRI !diffuse albedo of underlying surface (-) - REAL, DIMENSION(1:2), INTENT(IN) :: RHO !leaf+stem reflectance - REAL, DIMENSION(1:2), INTENT(IN) :: TAU !leaf+stem transmittance - REAL, INTENT(IN) :: FVEG !green vegetation fraction [0.0-1.0] + CALL CANRES (parameters,PARSHA,TV ,BTRAN ,EAH ,SFCPRS, & !in + RSSHA ,PSNSHA,ILOC ,JLOC ) !out + END IF + END IF -! output +! prepare for sensible heat flux above veg. - REAL, DIMENSION(1:2), INTENT(OUT) :: FAB !flux abs by veg layer (per unit incoming flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FRE !flux refl above veg layer (per unit incoming flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FTD !down dir flux below veg layer (per unit in flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FTI !down dif flux below veg layer (per unit in flux) - REAL, INTENT(OUT) :: GDIR !projected leaf+stem area in solar direction - REAL, DIMENSION(1:2), INTENT(OUT) :: FREV !flux reflected by veg layer (per unit incoming flux) - REAL, DIMENSION(1:2), INTENT(OUT) :: FREG !flux reflected by ground (per unit incoming flux) + CAH = 1./RAHC + CVH = 2.*VAIE/RB + CGH = 1./RAHG + COND = CAH + CVH + CGH + ATA = (SFCTMP*CAH + TG*CGH) / COND + BTA = CVH/COND + CSH = (1.-BTA)*RHOAIR*CPAIR*CVH -! local - REAL :: OMEGA !fraction of intercepted radiation that is scattered - REAL :: OMEGAL !omega for leaves - REAL :: BETAI !upscatter parameter for diffuse radiation - REAL :: BETAIL !betai for leaves - REAL :: BETAD !upscatter parameter for direct beam radiation - REAL :: BETADL !betad for leaves - REAL :: EXT !optical depth of direct beam per unit leaf area - REAL :: AVMU !average diffuse optical depth +! prepare for latent heat flux above veg. - REAL :: COSZI !0.001 <= cosz <= 1.000 - REAL :: ASU !single scattering albedo - REAL :: CHIL ! -0.4 <= xl <= 0.6 + CAW = 1./RAWC + CEW = FWET*VAIE/RB + CTW = (1.-FWET)*(LAISUNE/(RB+RSSUN) + LAISHAE/(RB+RSSHA)) + CGW = 1./(RAWG+RSURF) + COND = CAW + CEW + CTW + CGW + AEA = (EAIR*CAW + ESTG*CGW) / COND + BEA = (CEW+CTW)/COND + CEV = (1.-BEA)*CEW*RHOAIR*CPAIR/GAMMAV ! Barlage: change to vegetation v3.6 + CTR = (1.-BEA)*CTW*RHOAIR*CPAIR/GAMMAV - REAL :: TMP0,TMP1,TMP2,TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9 - REAL :: P1,P2,P3,P4,S1,S2,U1,U2,U3 - REAL :: B,C,D,D1,D2,F,H,H1,H2,H3,H4,H5,H6,H7,H8,H9,H10 - REAL :: PHI1,PHI2,SIGMA - REAL :: FTDS,FTIS,FRES - REAL :: DENFVEG - REAL :: VAI_SPREAD -!jref:start - REAL :: FREVEG,FREBAR,FTDVEG,FTIVEG,FTDBAR,FTIBAR - REAL :: THETAZ -!jref:end +! evaluate surface fluxes with current temperature and solve for dts -! variables for the modified two-stream scheme -! Niu and Yang (2004), JGR + TAH = ATA + BTA*TV ! canopy air T. + EAH = AEA + BEA*ESTV ! canopy air e - REAL, PARAMETER :: PAI = 3.14159265 - REAL :: HD !crown depth (m) - REAL :: BB !vertical crown radius (m) - REAL :: THETAP !angle conversion from SZA - REAL :: FA !foliage volume density (m-1) - REAL :: NEWVAI !effective LSAI (-) + IRC = FVEG*(AIR + CIR*TV**4) + SHC = FVEG*RHOAIR*CPAIR*CVH * ( TV-TAH) + EVC = FVEG*RHOAIR*CPAIR*CEW * (ESTV-EAH) / GAMMAV ! Barlage: change to v in v3.6 + TR = FVEG*RHOAIR*CPAIR*CTW * (ESTV-EAH) / GAMMAV + IF (TV > TFRZ) THEN + EVC = MIN(CANLIQ*LATHEAV/DT,EVC) ! Barlage: add if block for canice in v3.6 + ELSE + EVC = MIN(CANICE*LATHEAV/DT,EVC) + END IF - REAL,INTENT(INOUT) :: BGAP !between canopy gap fraction for beam (-) - REAL,INTENT(INOUT) :: WGAP !within canopy gap fraction for beam (-) + B = SAV-IRC-SHC-EVC-TR+PAHV !additional w/m2 + A = FVEG*(4.*CIR*TV**3 + CSH + (CEV+CTR)*DESTV) !volumetric heat capacity + DTV = B/A - REAL :: KOPEN !gap fraction for diffue light (-) - REAL :: GAP !total gap fraction for beam ( <=1-shafac ) + IRC = IRC + FVEG*4.*CIR*TV**3*DTV + SHC = SHC + FVEG*CSH*DTV + EVC = EVC + FVEG*CEV*DESTV*DTV + TR = TR + FVEG*CTR*DESTV*DTV -! ----------------------------------------------------------------- -! compute within and between gaps - VAI_SPREAD = VAI - if(VAI == 0.0) THEN - GAP = 1.0 - KOPEN = 1.0 - ELSE - IF(OPT_RAD == 1) THEN - DENFVEG = -LOG(MAX(1.0-FVEG,0.01))/(PAI*RC**2) - HD = HVT - HVB - BB = 0.5 * HD - THETAP = ATAN(BB/RC * TAN(ACOS(MAX(0.01,COSZ))) ) - ! BGAP = EXP(-DEN * PAI * RC**2/COS(THETAP) ) - BGAP = EXP(-DENFVEG * PAI * RC**2/COS(THETAP) ) - FA = VAI/(1.33 * PAI * RC**3.0 *(BB/RC)*DENFVEG) - NEWVAI = HD*FA - WGAP = (1.0-BGAP) * EXP(-0.5*NEWVAI/COSZ) - GAP = MIN(1.0-FVEG, BGAP+WGAP) +! update vegetation surface temperature + TV = TV + DTV +! TAH = ATA + BTA*TV ! canopy air T; update here for consistency - KOPEN = 0.05 - END IF +! for computing M-O length in the next iteration + H = RHOAIR*CPAIR*(TAH - SFCTMP) /RAHC + HG = RHOAIR*CPAIR*(TG - TAH) /RAHG - IF(OPT_RAD == 2) THEN - GAP = 0.0 - KOPEN = 0.0 - END IF +! consistent specific humidity from canopy air vapor pressure + QSFC = (0.622*EAH)/(SFCPRS-0.378*EAH) - IF(OPT_RAD == 3) THEN - GAP = 1.0-FVEG - KOPEN = 1.0-FVEG - END IF - end if + IF (LITER == 1) THEN + exit loop1 + ENDIF + IF (ITER >= 5 .AND. ABS(DTV) <= 0.01 .AND. LITER == 0) THEN + LITER = 1 + ENDIF -! calculate two-stream parameters OMEGA, BETAD, BETAI, AVMU, GDIR, EXT. -! OMEGA, BETAD, BETAI are adjusted for snow. values for OMEGA*BETAD -! and OMEGA*BETAI are calculated and then divided by the new OMEGA -! because the product OMEGA*BETAI, OMEGA*BETAD is used in solution. -! also, the transmittances and reflectances (TAU, RHO) are linear -! weights of leaf and stem values. + END DO loop1 ! end stability iteration - COSZI = MAX(0.001, COSZ) - CHIL = MIN( MAX(XL, -0.4), 0.6) - IF (ABS(CHIL) .LE. 0.01) CHIL = 0.01 - PHI1 = 0.5 - 0.633*CHIL - 0.330*CHIL*CHIL - PHI2 = 0.877 * (1.-2.*PHI1) - GDIR = PHI1 + PHI2*COSZI - EXT = GDIR/COSZI - AVMU = ( 1. - PHI1/PHI2 * LOG((PHI1+PHI2)/PHI1) ) / PHI2 - OMEGAL = RHO(IB) + TAU(IB) - TMP0 = GDIR + PHI2*COSZI - TMP1 = PHI1*COSZI - ASU = 0.5*OMEGAL*GDIR/TMP0 * ( 1.-TMP1/TMP0*LOG((TMP1+TMP0)/TMP1) ) - BETADL = (1.+AVMU*EXT)/(OMEGAL*AVMU*EXT)*ASU - BETAIL = 0.5 * ( RHO(IB)+TAU(IB) + (RHO(IB)-TAU(IB)) & - * ((1.+CHIL)/2.)**2 ) / OMEGAL +! under-canopy fluxes and tg -! adjust omega, betad, and betai for intercepted snow + AIR = - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4 + CIR = EMG*SB + CSH = RHOAIR*CPAIR/RAHG + CEV = RHOAIR*CPAIR / (GAMMAG*(RAWG+RSURF)) ! Barlage: change to ground v3.6 + CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1) - IF (T .GT. TFRZ) THEN !no snow - TMP0 = OMEGAL - TMP1 = BETADL - TMP2 = BETAIL - ELSE - TMP0 = (1.-FWET)*OMEGAL + FWET*OMEGAS(IB) - TMP1 = ( (1.-FWET)*OMEGAL*BETADL + FWET*OMEGAS(IB)*BETADS ) / TMP0 - TMP2 = ( (1.-FWET)*OMEGAL*BETAIL + FWET*OMEGAS(IB)*BETAIS ) / TMP0 - END IF + loop2: DO ITER = 1, NITERG - OMEGA = TMP0 - BETAD = TMP1 - BETAI = TMP2 + T = TDC(TG) + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + IF (T .GT. 0.) THEN + ESTG = ESATW + DESTG = DSATW + ELSE + ESTG = ESATI + DESTG = DSATI + END IF -! absorbed, reflected, transmitted fluxes per unit incoming radiation + IRG = CIR*TG**4 + AIR + SHG = CSH * (TG - TAH ) + EVG = CEV * (ESTG*RHSUR - EAH ) + GH = CGH * (TG - STC(ISNOW+1)) - B = 1. - OMEGA + OMEGA*BETAI - C = OMEGA*BETAI - TMP0 = AVMU*EXT - D = TMP0 * OMEGA*BETAD - F = TMP0 * OMEGA*(1.-BETAD) - TMP1 = B*B - C*C - H = SQRT(TMP1) / AVMU - SIGMA = TMP0*TMP0 - TMP1 - if ( ABS (SIGMA) < 1.e-6 ) SIGMA = SIGN(1.e-6,SIGMA) - P1 = B + AVMU*H - P2 = B - AVMU*H - P3 = B + TMP0 - P4 = B - TMP0 - S1 = EXP(-H*VAI) - S2 = EXP(-EXT*VAI) - IF (IC .EQ. 0) THEN - U1 = B - C/ALBGRD(IB) - U2 = B - C*ALBGRD(IB) - U3 = F + C*ALBGRD(IB) - ELSE - U1 = B - C/ALBGRI(IB) - U2 = B - C*ALBGRI(IB) - U3 = F + C*ALBGRI(IB) - END IF - TMP2 = U1 - AVMU*H - TMP3 = U1 + AVMU*H - D1 = P1*TMP2/S1 - P2*TMP3*S1 - TMP4 = U2 + AVMU*H - TMP5 = U2 - AVMU*H - D2 = TMP4/S1 - TMP5*S1 - H1 = -D*P4 - C*F - TMP6 = D - H1*P3/SIGMA - TMP7 = ( D - C - H1/SIGMA*(U1+TMP0) ) * S2 - H2 = ( TMP6*TMP2/S1 - P2*TMP7 ) / D1 - H3 = - ( TMP6*TMP3*S1 - P1*TMP7 ) / D1 - H4 = -F*P3 - C*D - TMP8 = H4/SIGMA - TMP9 = ( U3 - TMP8*(U2-TMP0) ) * S2 - H5 = - ( TMP8*TMP4/S1 + TMP9 ) / D2 - H6 = ( TMP8*TMP5*S1 + TMP9 ) / D2 - H7 = (C*TMP2) / (D1*S1) - H8 = (-C*TMP3*S1) / D1 - H9 = TMP4 / (D2*S1) - H10 = (-TMP5*S1) / D2 + B = SAG-IRG-SHG-EVG-GH+PAHG + A = 4.*CIR*TG**3+CSH+CEV*DESTG+CGH + DTG = B/A -! downward direct and diffuse fluxes below vegetation -! Niu and Yang (2004), JGR. + IRG = IRG + 4.*CIR*TG**3*DTG + SHG = SHG + CSH*DTG + EVG = EVG + CEV*DESTG*DTG + GH = GH + CGH*DTG + TG = TG + DTG - IF (IC .EQ. 0) THEN - FTDS = S2 *(1.0-GAP) + GAP - FTIS = (H4*S2/SIGMA + H5*S1 + H6/S1)*(1.0-GAP) - ELSE - FTDS = 0. - FTIS = (H9*S1 + H10/S1)*(1.0-KOPEN) + KOPEN - END IF - FTD(IB) = FTDS - FTI(IB) = FTIS + END DO loop2 + +! TAH = (CAH*SFCTMP + CVH*TV + CGH*TG)/(CAH + CVH + CGH) -! flux reflected by the surface (veg. and ground) +! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes. - IF (IC .EQ. 0) THEN - FRES = (H1/SIGMA + H2 + H3)*(1.0-GAP ) + ALBGRD(IB)*GAP - FREVEG = (H1/SIGMA + H2 + H3)*(1.0-GAP ) - FREBAR = ALBGRD(IB)*GAP !jref - separate veg. and ground reflection - ELSE - FRES = (H7 + H8) *(1.0-KOPEN) + ALBGRI(IB)*KOPEN - FREVEG = (H7 + H8) *(1.0-KOPEN) + ALBGRI(IB)*KOPEN - FREBAR = 0 !jref - separate veg. and ground reflection + IF(OPT_STC == 1 .OR. OPT_STC == 3) THEN + IF (SNOWH > 0.05 .AND. TG > TFRZ) THEN + IF(OPT_STC == 1) TG = TFRZ + IF(OPT_STC == 3) TG = (1.-FSNO)*TG + FSNO*TFRZ ! MB: allow TG>0C during melt v3.7 + IRG = CIR*TG**4 - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4 + SHG = CSH * (TG - TAH) + EVG = CEV * (ESTG*RHSUR - EAH) + GH = SAG+PAHG - (IRG+SHG+EVG) + END IF END IF - FRE(IB) = FRES - FREV(IB) = FREVEG - FREG(IB) = FREBAR +! wind stresses -! flux absorbed by vegetation + TAUXV = -RHOAIR*CM*UR*UU + TAUYV = -RHOAIR*CM*UR*VV - FAB(IB) = 1. - FRE(IB) - (1.-ALBGRD(IB))*FTD(IB) & - - (1.-ALBGRI(IB))*FTI(IB) +! consistent vegetation air temperature and vapor pressure since TG is not consistent with the TAH/EAH +! calculation. +! TAH = SFCTMP + (SHG+SHC)/(RHOAIR*CPAIR*CAH) +! TAH = SFCTMP + (SHG*FVEG+SHC)/(RHOAIR*CPAIR*CAH) ! ground flux need fveg +! EAH = EAIR + (EVC+FVEG*(TR+EVG))/(RHOAIR*CAW*CPAIR/GAMMAG ) +! QFX = (QSFC-QAIR)*RHOAIR*CAW !*CPAIR/GAMMAG -!if(iloc == 1.and.jloc == 2) then -! write(*,'(a7,2i2,5(a6,f8.4),2(a9,f8.4))') "ib,ic: ",ib,ic," GAP: ",GAP," FTD: ",FTD(IB)," FTI: ",FTI(IB)," FRE: ", & -! FRE(IB)," FAB: ",FAB(IB)," ALBGRD: ",ALBGRD(IB)," ALBGRI: ",ALBGRI(IB) -!end if +! 2m temperature over vegetation ( corrected for low CQ2V values ) + IF (OPT_SFC == 1 .OR. OPT_SFC == 2) THEN +! CAH2 = FV*1./VKC*LOG((2.+Z0H)/Z0H) + CAH2 = FV*VKC/LOG((2.+Z0H)/Z0H) + CAH2 = FV*VKC/(LOG((2.+Z0H)/Z0H)-FH2) + CQ2V = CAH2 + IF (CAH2 .LT. 1.E-5 ) THEN + T2MV = TAH +! Q2V = (EAH*0.622/(SFCPRS - 0.378*EAH)) + Q2V = QSFC + ELSE + T2MV = TAH - (SHG+SHC/FVEG)/(RHOAIR*CPAIR) * 1./CAH2 +! Q2V = (EAH*0.622/(SFCPRS - 0.378*EAH))- QFX/(RHOAIR*FV)* 1./VKC * LOG((2.+Z0H)/Z0H) + Q2V = QSFC - ((EVC+TR)/FVEG+EVG)/(LATHEAV*RHOAIR) * 1./CQ2V + ENDIF + ENDIF - END SUBROUTINE TWOSTREAM +! update CH for output + CH = CAH + CHLEAF = CVH + CHUC = 1./RAHG -!== begin vege_flux ================================================================================ + END SUBROUTINE VEGE_FLUX - SUBROUTINE VEGE_FLUX(NSNOW ,NSOIL ,ISNOW ,VEGTYP ,VEG , & !in - DT ,SAV ,SAG ,LWDN ,UR , & !in - UU ,VV ,SFCTMP ,THAIR ,QAIR , & !in - EAIR ,RHOAIR ,SNOWH ,VAI ,GAMMAV ,GAMMAG, & !in - FWET ,LAISUN ,LAISHA ,CWP ,DZSNSO , & !in - ZLVL ,ZPD ,Z0M ,FVEG , & !in - Z0MG ,EMV ,EMG ,CANLIQ ,FSNO, & !in - CANICE ,STC ,DF ,RSSUN ,RSSHA , & !in - RSURF ,LATHEAV ,LATHEAG ,PARSUN ,PARSHA ,IGS , & !in - FOLN ,CO2AIR ,O2AIR ,BTRAN ,SFCPRS , & !in - RHSUR ,ILOC ,JLOC ,Q2 ,PAHV ,PAHG , & !in - EAH ,TAH ,TV ,TG ,CM , & !inout - CH ,DX ,DZ8W , & ! - TAUXV ,TAUYV ,IRG ,IRC ,SHG , & !out - SHC ,EVG ,EVC ,TR ,GH , & !out - T2MV ,PSNSUN ,PSNSHA , & !out - QC ,QSFC ,PSFC , & !in - Q2V ,CAH2 ,CHLEAF ,CHUC ) !inout +!== begin bare_flux ================================================================================ -! -------------------------------------------------------------------------------------------------- -! use newton-raphson iteration to solve for vegetation (tv) and -! ground (tg) temperatures that balance the surface energy budgets + SUBROUTINE BARE_FLUX (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in + LWDN ,UR ,UU ,VV ,SFCTMP , & !in + THAIR ,QAIR ,EAIR ,RHOAIR ,SNOWH , & !in + DZSNSO ,ZLVL ,ZPD ,Z0M ,FSNO , & !in + EMG ,STC ,DF ,RSURF ,LATHEA , & !in + GAMMA ,RHSUR ,ILOC ,JLOC ,Q2 ,PAHB , & !in + TGB ,CM ,CH , & !inout + TAUXB ,TAUYB ,IRB ,SHB ,EVB , & !out + GHB ,T2MB ,DX ,DZ8W ,IVGTYP , & !out + QC ,QSFC ,PSFC , & !in + SFCPRS ,Q2B ,EHB2 ) !in -! vegetated: -! -SAV + IRC[TV] + SHC[TV] + EVC[TV] + TR[TV] = 0 -! -SAG + IRG[TG] + SHG[TG] + EVG[TG] + GH[TG] = 0 -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: HVT, & ! VEGETATION DEPENDENT - SB, VKC, TFRZ, CPAIR ! MP CONSTANT ! -------------------------------------------------------------------------------------------------- +! use newton-raphson iteration to solve ground (tg) temperature +! that balances the surface energy budgets for bare soil fraction. + +! bare soil: +! -SAB + IRB[TG] + SHB[TG] + EVB[TG] + GHB[TG] = 0 +! ---------------------------------------------------------------------- IMPLICIT NONE -! -------------------------------------------------------------------------------------------------- +! ---------------------------------------------------------------------- ! input - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - LOGICAL, INTENT(IN) :: VEG !true if vegetated surface - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + type (noahmp_parameters), intent(in) :: parameters + integer , INTENT(IN) :: ILOC !grid index + integer , INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers INTEGER, INTENT(IN) :: NSOIL !number of soil layers INTEGER, INTENT(IN) :: ISNOW !actual no. of snow layers - INTEGER, INTENT(IN) :: VEGTYP !vegetation physiology type - REAL, INTENT(IN) :: FVEG !greeness vegetation fraction (-) - REAL, INTENT(IN) :: SAV !solar rad absorbed by veg (w/m2) - REAL, INTENT(IN) :: SAG !solar rad absorbed by ground (w/m2) + REAL, INTENT(IN) :: DT !time step (s) + REAL, INTENT(IN) :: SAG !solar radiation absorbed by ground (w/m2) REAL, INTENT(IN) :: LWDN !atmospheric longwave radiation (w/m2) REAL, INTENT(IN) :: UR !wind speed at height zlvl (m/s) REAL, INTENT(IN) :: UU !wind speed in eastward dir (m/s) REAL, INTENT(IN) :: VV !wind speed in northward dir (m/s) REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) - REAL, INTENT(IN) :: THAIR !potential temp at reference height (k) - REAL, INTENT(IN) :: EAIR !vapor pressure air at zlvl (pa) - REAL, INTENT(IN) :: QAIR !specific humidity at zlvl (kg/kg) - REAL, INTENT(IN) :: RHOAIR !density air (kg/m**3) - REAL, INTENT(IN) :: DT !time step (s) - REAL, INTENT(IN) :: FSNO !snow fraction - + REAL, INTENT(IN) :: THAIR !potential temperature at height zlvl (k) + REAL, INTENT(IN) :: QAIR !specific humidity at height zlvl (kg/kg) + REAL, INTENT(IN) :: EAIR !vapor pressure air at height (pa) + REAL, INTENT(IN) :: RHOAIR !density air (kg/m3) REAL, INTENT(IN) :: SNOWH !actual snow depth [m] - REAL, INTENT(IN) :: FWET !wetted fraction of canopy - REAL, INTENT(IN) :: CWP !canopy wind parameter - - REAL, INTENT(IN) :: VAI !total leaf area index + stem area index - REAL, INTENT(IN) :: LAISUN !sunlit leaf area index, one-sided (m2/m2) - REAL, INTENT(IN) :: LAISHA !shaded leaf area index, one-sided (m2/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thickness of snow/soil layers (m) REAL, INTENT(IN) :: ZLVL !reference height (m) REAL, INTENT(IN) :: ZPD !zero plane displacement (m) - REAL, INTENT(IN) :: Z0M !roughness length, momentum (m) - REAL, INTENT(IN) :: Z0MG !roughness length, momentum, ground (m) - REAL, INTENT(IN) :: EMV !vegetation emissivity + REAL, INTENT(IN) :: Z0M !roughness length, momentum, ground (m) REAL, INTENT(IN) :: EMG !ground emissivity - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !soil/snow temperature (k) REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity of snow/soil (w/m/k) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thinkness of snow/soil layers (m) - REAL, INTENT(IN) :: CANLIQ !intercepted liquid water (mm) - REAL, INTENT(IN) :: CANICE !intercepted ice mass (mm) REAL, INTENT(IN) :: RSURF !ground surface resistance (s/m) -! REAL, INTENT(IN) :: GAMMA !psychrometric constant (pa/K) -! REAL, INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg) - REAL, INTENT(IN) :: GAMMAV !psychrometric constant (pa/K) - REAL, INTENT(IN) :: LATHEAV !latent heat of vaporization/subli (j/kg) - REAL, INTENT(IN) :: GAMMAG !psychrometric constant (pa/K) - REAL, INTENT(IN) :: LATHEAG !latent heat of vaporization/subli (j/kg) - REAL, INTENT(IN) :: PARSUN !par absorbed per unit sunlit lai (w/m2) - REAL, INTENT(IN) :: PARSHA !par absorbed per unit shaded lai (w/m2) - REAL, INTENT(IN) :: FOLN !foliage nitrogen (%) - REAL, INTENT(IN) :: CO2AIR !atmospheric co2 concentration (pa) - REAL, INTENT(IN) :: O2AIR !atmospheric o2 concentration (pa) - REAL, INTENT(IN) :: IGS !growing season index (0=off, 1=on) - REAL, INTENT(IN) :: SFCPRS !pressure (pa) - REAL, INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) + REAL, INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg) + REAL, INTENT(IN) :: GAMMA !psychrometric constant (pa/k) REAL, INTENT(IN) :: RHSUR !raltive humidity in surface soil/snow air space (-) + REAL, INTENT(IN) :: FSNO !snow fraction +!jref:start; in + INTEGER , INTENT(IN) :: IVGTYP REAL , INTENT(IN) :: QC !cloud water mixing ratio + REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer REAL , INTENT(IN) :: PSFC !pressure at lowest model layer - REAL , INTENT(IN) :: DX !grid spacing + REAL , INTENT(IN) :: SFCPRS !pressure at lowest model layer + REAL , INTENT(IN) :: DX !horisontal grid spacing REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) REAL , INTENT(IN) :: DZ8W !thickness of lowest layer - REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer - REAL, INTENT(IN) :: PAHV !precipitation advected heat - canopy net IN (W/m2) - REAL, INTENT(IN) :: PAHG !precipitation advected heat - ground net IN (W/m2) +!jref:end + REAL, INTENT(IN) :: PAHB !precipitation advected heat - ground net IN (W/m2) ! input/output - REAL, INTENT(INOUT) :: EAH !canopy air vapor pressure (pa) - REAL, INTENT(INOUT) :: TAH !canopy air temperature (k) - REAL, INTENT(INOUT) :: TV !vegetation temperature (k) - REAL, INTENT(INOUT) :: TG !ground temperature (k) + REAL, INTENT(INOUT) :: TGB !ground temperature (k) REAL, INTENT(INOUT) :: CM !momentum drag coefficient REAL, INTENT(INOUT) :: CH !sensible heat exchange coefficient ! output -! -FSA + FIRA + FSH + (FCEV + FCTR + FGEV) + FCST + SSOIL = 0 - REAL, INTENT(OUT) :: TAUXV !wind stress: e-w (n/m2) - REAL, INTENT(OUT) :: TAUYV !wind stress: n-s (n/m2) - REAL, INTENT(OUT) :: IRC !net longwave radiation (w/m2) [+= to atm] - REAL, INTENT(OUT) :: SHC !sensible heat flux (w/m2) [+= to atm] - REAL, INTENT(OUT) :: EVC !evaporation heat flux (w/m2) [+= to atm] - REAL, INTENT(OUT) :: IRG !net longwave radiation (w/m2) [+= to atm] - REAL, INTENT(OUT) :: SHG !sensible heat flux (w/m2) [+= to atm] - REAL, INTENT(OUT) :: EVG !evaporation heat flux (w/m2) [+= to atm] - REAL, INTENT(OUT) :: TR !transpiration heat flux (w/m2)[+= to atm] - REAL, INTENT(OUT) :: GH !ground heat (w/m2) [+ = to soil] - REAL, INTENT(OUT) :: T2MV !2 m height air temperature (k) - REAL, INTENT(OUT) :: PSNSUN !sunlit leaf photosynthesis (umolco2/m2/s) - REAL, INTENT(OUT) :: PSNSHA !shaded leaf photosynthesis (umolco2/m2/s) - REAL, INTENT(OUT) :: CHLEAF !leaf exchange coefficient - REAL, INTENT(OUT) :: CHUC !under canopy exchange coefficient +! -SAB + IRB[TG] + SHB[TG] + EVB[TG] + GHB[TG] = 0 - REAL, INTENT(OUT) :: Q2V - REAL :: CAH !sensible heat conductance, canopy air to ZLVL air (m/s) - REAL :: U10V !10 m wind speed in eastward dir (m/s) - REAL :: V10V !10 m wind speed in eastward dir (m/s) + REAL, INTENT(OUT) :: TAUXB !wind stress: e-w (n/m2) + REAL, INTENT(OUT) :: TAUYB !wind stress: n-s (n/m2) + REAL, INTENT(OUT) :: IRB !net longwave rad (w/m2) [+ to atm] + REAL, INTENT(OUT) :: SHB !sensible heat flux (w/m2) [+ to atm] + REAL, INTENT(OUT) :: EVB !latent heat flux (w/m2) [+ to atm] + REAL, INTENT(OUT) :: GHB !ground heat flux (w/m2) [+ to soil] + REAL, INTENT(OUT) :: T2MB !2 m height air temperature (k) +!jref:start + REAL, INTENT(OUT) :: Q2B !bare ground heat conductance + REAL :: EHB !bare ground heat conductance + REAL :: U10B !10 m wind speed in eastward dir (m/s) + REAL :: V10B !10 m wind speed in eastward dir (m/s) REAL :: WSPD +!jref:end -! ------------------------ local variables ---------------------------------------------------- - REAL :: CW !water vapor exchange coefficient - REAL :: FV !friction velocity (m/s) - REAL :: WSTAR !friction velocity n vertical direction (m/s) (only for SFCDIF2) - REAL :: Z0H !roughness length, sensible heat (m) - REAL :: Z0HG !roughness length, sensible heat (m) - REAL :: RB !bulk leaf boundary layer resistance (s/m) - REAL :: RAMC !aerodynamic resistance for momentum (s/m) - REAL :: RAHC !aerodynamic resistance for sensible heat (s/m) - REAL :: RAWC !aerodynamic resistance for water vapor (s/m) - REAL :: RAMG !aerodynamic resistance for momentum (s/m) - REAL :: RAHG !aerodynamic resistance for sensible heat (s/m) - REAL :: RAWG !aerodynamic resistance for water vapor (s/m) +! local variables - REAL, INTENT(OUT) :: RSSUN !sunlit leaf stomatal resistance (s/m) - REAL, INTENT(OUT) :: RSSHA !shaded leaf stomatal resistance (s/m) + REAL :: TAUX !wind stress: e-w (n/m2) + REAL :: TAUY !wind stress: n-s (n/m2) + REAL :: FIRA !total net longwave rad (w/m2) [+ to atm] + REAL :: FSH !total sensible heat flux (w/m2) [+ to atm] + REAL :: FGEV !ground evaporation heat flux (w/m2)[+ to atm] + REAL :: SSOIL !soil heat flux (w/m2) [+ to soil] + REAL :: FIRE !emitted ir (w/m2) + REAL :: TRAD !radiative temperature (k) + REAL :: TAH !"surface" temperature at height z0h+zpd (k) - REAL :: MOL !Monin-Obukhov length (m) - REAL :: DTV !change in tv, last iteration (k) - REAL :: DTG !change in tg, last iteration (k) + REAL :: CW !water vapor exchange coefficient + REAL :: FV !friction velocity (m/s) + REAL :: WSTAR !friction velocity n vertical direction (m/s) (only for SFCDIF2) + REAL :: Z0H !roughness length, sensible heat, ground (m) + REAL :: RB !bulk leaf boundary layer resistance (s/m) + REAL :: RAMB !aerodynamic resistance for momentum (s/m) + REAL :: RAHB !aerodynamic resistance for sensible heat (s/m) + REAL :: RAWB !aerodynamic resistance for water vapor (s/m) + REAL :: MOL !Monin-Obukhov length (m) + REAL :: DTG !change in tg, last iteration (k) - REAL :: AIR,CIR !coefficients for ir as function of ts**4 - REAL :: CSH !coefficients for sh as function of ts - REAL :: CEV !coefficients for ev as function of esat[ts] - REAL :: CGH !coefficients for st as function of ts - REAL :: ATR,CTR !coefficients for tr as function of esat[ts] - REAL :: ATA,BTA !coefficients for tah as function of ts - REAL :: AEA,BEA !coefficients for eah as function of esat[ts] + REAL :: CIR !coefficients for ir as function of ts**4 + REAL :: CSH !coefficients for sh as function of ts + REAL :: CEV !coefficients for ev as function of esat[ts] + REAL :: CGH !coefficients for st as function of ts - REAL :: ESTV !saturation vapor pressure at tv (pa) - REAL :: ESTG !saturation vapor pressure at tg (pa) - REAL :: DESTV !d(es)/dt at ts (pa/k) - REAL :: DESTG !d(es)/dt at tg (pa/k) - REAL :: ESATW !es for water - REAL :: ESATI !es for ice - REAL :: DSATW !d(es)/dt at tg (pa/k) for water - REAL :: DSATI !d(es)/dt at tg (pa/k) for ice +!jref:start + REAL :: RAHB2 !aerodynamic resistance for sensible heat 2m (s/m) + REAL :: RAWB2 !aerodynamic resistance for water vapor 2m (s/m) + REAL,INTENT(OUT) :: EHB2 !sensible heat conductance for diagnostics + REAL :: CH2B !exchange coefficient for 2m temp. + REAL :: CQ2B !exchange coefficient for 2m temp. + REAL :: THVAIR !virtual potential air temp + REAL :: THGH !potential ground temp + REAL :: EMB !momentum conductance + REAL :: QFX !moisture flux + REAL :: ESTG2 !saturation vapor pressure at 2m (pa) + INTEGER :: VEGTYP !vegetation type set to isbarren + REAL :: E1 +!jref:end - REAL :: FM !momentum stability correction, weighted by prior iters - REAL :: FH !sen heat stability correction, weighted by prior iters - REAL :: FHG !sen heat stability correction, ground - REAL :: HCAN !canopy height (m) [note: hcan >= z0mg] + REAL :: ESTG !saturation vapor pressure at tg (pa) + REAL :: DESTG !d(es)/dt at tg (pa/K) + REAL :: ESATW !es for water + REAL :: ESATI !es for ice + REAL :: DSATW !d(es)/dt at tg (pa/K) for water + REAL :: DSATI !d(es)/dt at tg (pa/K) for ice - REAL :: A !temporary calculation - REAL :: B !temporary calculation - REAL :: CVH !sensible heat conductance, leaf surface to canopy air (m/s) - REAL :: CAW !latent heat conductance, canopy air ZLVL air (m/s) - REAL :: CTW !transpiration conductance, leaf to canopy air (m/s) - REAL :: CEW !evaporation conductance, leaf to canopy air (m/s) - REAL :: CGW !latent heat conductance, ground to canopy air (m/s) - REAL :: COND !sum of conductances (s/m) - REAL :: UC !wind speed at top of canopy (m/s) - REAL :: KH !turbulent transfer coefficient, sensible heat, (m2/s) - REAL :: H !temporary sensible heat flux (w/m2) - REAL :: HG !temporary sensible heat flux (w/m2) - REAL :: MOZ !Monin-Obukhov stability parameter - REAL :: MOZG !Monin-Obukhov stability parameter - REAL :: MOZOLD !Monin-Obukhov stability parameter from prior iteration + REAL :: A !temporary calculation + REAL :: B !temporary calculation + REAL :: H !temporary sensible heat flux (w/m2) + REAL :: MOZ !Monin-Obukhov stability parameter + REAL :: MOZOLD !Monin-Obukhov stability parameter from prior iteration + REAL :: FM !momentum stability correction, weighted by prior iters + REAL :: FH !sen heat stability correction, weighted by prior iters + INTEGER :: MOZSGN !number of times MOZ changes sign REAL :: FM2 !Monin-Obukhov momentum adjustment at 2m REAL :: FH2 !Monin-Obukhov heat adjustment at 2m REAL :: CH2 !Surface exchange at 2m - REAL :: THSTAR !Surface exchange at 2m - REAL :: THVAIR - REAL :: THAH - REAL :: RAHC2 !aerodynamic resistance for sensible heat (s/m) - REAL :: RAWC2 !aerodynamic resistance for water vapor (s/m) - REAL, INTENT(OUT):: CAH2 !sensible heat conductance for diagnostics - REAL :: CH2V !exchange coefficient for 2m over vegetation. - REAL :: CQ2V !exchange coefficient for 2m over vegetation. - REAL :: EAH2 !2m vapor pressure over canopy - REAL :: QFX !moisture flux - REAL :: E1 + INTEGER :: ITER !iteration index + INTEGER :: NITERB !number of iterations for surface temperature + REAL :: MPE !prevents overflow error if division by zero +!jref:start +! DATA NITERB /3/ + DATA NITERB /5/ + SAVE NITERB + REAL :: T, TDC !Kelvin to degree Celsius with limit -50 to +50 + TDC(T) = MIN( 50., MAX(-50.,(T-TFRZ)) ) +! ----------------------------------------------------------------- +! initialization variables that do not depend on stability iteration +! ----------------------------------------------------------------- + MPE = 1E-6 + DTG = 0. + MOZ = 0. + MOZSGN = 0 + MOZOLD = 0. + H = 0. + QFX = 0. + FV = 0.1 - REAL :: VAIE !total leaf area index + stem area index,effective - REAL :: LAISUNE !sunlit leaf area index, one-sided (m2/m2),effective - REAL :: LAISHAE !shaded leaf area index, one-sided (m2/m2),effective + CIR = EMG*SB + CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1) - INTEGER :: K !index - INTEGER :: ITER !iteration index +! ----------------------------------------------------------------- + loop3: DO ITER = 1, NITERB ! begin stability iteration -!jref - NITERC test from 5 to 20 - INTEGER, PARAMETER :: NITERC = 20 !number of iterations for surface temperature -!jref - NITERG test from 3-5 - INTEGER, PARAMETER :: NITERG = 5 !number of iterations for ground temperature - INTEGER :: MOZSGN !number of times MOZ changes sign - REAL :: MPE !prevents overflow error if division by zero + IF(ITER == 1) THEN + Z0H = Z0M + ELSE + Z0H = Z0M !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0M)) + END IF - INTEGER :: LITER !Last iteration + IF(OPT_SFC == 1) THEN + CALL SFCDIF1(parameters,ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in + ZLVL ,ZPD ,Z0M ,Z0H ,UR , & !in + MPE ,ILOC ,JLOC , & !in + MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, & !inout + CM ,CH ,FV ,CH2 ) !out + ENDIF + IF(OPT_SFC == 2) THEN + CALL SFCDIF2(parameters,ITER ,Z0M ,TGB ,THAIR ,UR , & !in + ZLVL ,ILOC ,JLOC , & !in + CM ,CH ,MOZ ,WSTAR , & !in + FV ) !out + ! Undo the multiplication by windspeed that SFCDIF2 + ! applies to exchange coefficients CH and CM: + CH = CH / UR + CM = CM / UR + IF(SNOWH > 0.) THEN + CM = MIN(0.01,CM) ! CM & CH are too large, causing + CH = MIN(0.01,CH) ! computational instability + END IF - REAL :: T, TDC !Kelvin to degree Celsius with limit -50 to +50 + ENDIF - character(len=80) :: message + RAMB = MAX(1.,1./(CM*UR)) + RAHB = MAX(1.,1./(CH*UR)) + RAWB = RAHB - TDC(T) = MIN( 50., MAX(-50.,(T-TFRZ)) ) -! --------------------------------------------------------------------------------------------- +!jref - variables for diagnostics + EMB = 1./RAMB + EHB = 1./RAHB - MPE = 1E-6 - LITER = 0 - FV = 0.1 +! es and d(es)/dt evaluated at tg -! --------------------------------------------------------------------------------------------- -! initialization variables that do not depend on stability iteration -! --------------------------------------------------------------------------------------------- - DTV = 0. - DTG = 0. - MOZ = 0. - MOZSGN = 0 - MOZOLD = 0. - HG = 0. - H = 0. - QFX = 0. + T = TDC(TGB) + CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) + IF (T .GT. 0.) THEN + ESTG = ESATW + DESTG = DSATW + ELSE + ESTG = ESATI + DESTG = DSATI + END IF -! convert grid-cell LAI to the fractional vegetated area (FVEG) + CSH = RHOAIR*CPAIR/RAHB + CEV = RHOAIR*CPAIR/GAMMA/(RSURF+RAWB) - VAIE = MIN(6.,VAI / FVEG) - LAISUNE = MIN(6.,LAISUN / FVEG) - LAISHAE = MIN(6.,LAISHA / FVEG) +! surface fluxes and dtg -! saturation vapor pressure at ground temperature + IRB = CIR * TGB**4 - EMG*LWDN + SHB = CSH * (TGB - SFCTMP ) + EVB = CEV * (ESTG*RHSUR - EAIR ) + GHB = CGH * (TGB - STC(ISNOW+1)) - T = TDC(TG) + B = SAG-IRB-SHB-EVB-GHB+PAHB + A = 4.*CIR*TGB**3 + CSH + CEV*DESTG + CGH + DTG = B/A + + IRB = IRB + 4.*CIR*TGB**3*DTG + SHB = SHB + CSH*DTG + EVB = EVB + CEV*DESTG*DTG + GHB = GHB + CGH*DTG + +! update ground surface temperature + TGB = TGB + DTG + +! for M-O length + H = CSH * (TGB - SFCTMP) + + T = TDC(TGB) CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) IF (T .GT. 0.) THEN - ESTG = ESATW + ESTG = ESATW ELSE - ESTG = ESATI + ESTG = ESATI END IF + QSFC = 0.622*(ESTG*RHSUR)/(PSFC-0.378*(ESTG*RHSUR)) -!jref - consistent surface specific humidity for sfcdif3 and sfcdif4 + QFX = (QSFC-QAIR)*CEV*GAMMA/CPAIR - QSFC = 0.622*EAIR/(PSFC-0.378*EAIR) + END DO loop3 ! end stability iteration +! ----------------------------------------------------------------- + +! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes. + + IF(OPT_STC == 1 .OR. OPT_STC == 3) THEN + IF (SNOWH > 0.05 .AND. TGB > TFRZ) THEN + IF(OPT_STC == 1) TGB = TFRZ + IF(OPT_STC == 3) TGB = (1.-FSNO)*TGB + FSNO*TFRZ ! MB: allow TG>0C during melt v3.7 + IRB = CIR * TGB**4 - EMG*LWDN + SHB = CSH * (TGB - SFCTMP) + EVB = CEV * (ESTG*RHSUR - EAIR ) !ESTG reevaluate ? + GHB = SAG+PAHB - (IRB+SHB+EVB) + END IF + END IF + +! wind stresses + + TAUXB = -RHOAIR*CM*UR*UU + TAUYB = -RHOAIR*CM*UR*VV + +!jref:start; errors in original equation corrected. +! 2m air temperature + IF(OPT_SFC == 1 .OR. OPT_SFC ==2) THEN + EHB2 = FV*VKC/LOG((2.+Z0H)/Z0H) + EHB2 = FV*VKC/(LOG((2.+Z0H)/Z0H)-FH2) + CQ2B = EHB2 + IF (EHB2.lt.1.E-5 ) THEN + T2MB = TGB + Q2B = QSFC + ELSE + T2MB = TGB - SHB/(RHOAIR*CPAIR) * 1./EHB2 + Q2B = QSFC - EVB/(LATHEA*RHOAIR)*(1./CQ2B + RSURF) + ENDIF + IF (parameters%urban_flag) Q2B = QSFC + END IF + +! update CH + CH = EHB + + END SUBROUTINE BARE_FLUX + +!== begin ragrb ==================================================================================== + + SUBROUTINE RAGRB(parameters,ITER ,VAI ,RHOAIR ,HG ,TAH , & !in + ZPD ,Z0MG ,Z0HG ,HCAN ,UC , & !in + Z0H ,FV ,CWP ,VEGTYP ,MPE , & !in + TV ,MOZG ,FHG ,ILOC ,JLOC , & !inout + RAMG ,RAHG ,RAWG ,RB ) !out +! -------------------------------------------------------------------------------------------------- +! compute under-canopy aerodynamic resistance RAG and leaf boundary layer +! resistance RB +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: ITER !iteration index + INTEGER, INTENT(IN) :: VEGTYP !vegetation physiology type + REAL, INTENT(IN) :: VAI !total LAI + stem area index, one sided + REAL, INTENT(IN) :: RHOAIR !density air (kg/m3) + REAL, INTENT(IN) :: HG !ground sensible heat flux (w/m2) + REAL, INTENT(IN) :: TV !vegetation temperature (k) + REAL, INTENT(IN) :: TAH !air temperature at height z0h+zpd (k) + REAL, INTENT(IN) :: ZPD !zero plane displacement (m) + REAL, INTENT(IN) :: Z0MG !roughness length, momentum, ground (m) + REAL, INTENT(IN) :: HCAN !canopy height (m) [note: hcan >= z0mg] + REAL, INTENT(IN) :: UC !wind speed at top of canopy (m/s) + REAL, INTENT(IN) :: Z0H !roughness length, sensible heat (m) + REAL, INTENT(IN) :: Z0HG !roughness length, sensible heat, ground (m) + REAL, INTENT(IN) :: FV !friction velocity (m/s) + REAL, INTENT(IN) :: CWP !canopy wind parameter + REAL, INTENT(IN) :: MPE !prevents overflow error if division by zero + +! in & out + + REAL, INTENT(INOUT) :: MOZG !Monin-Obukhov stability parameter + REAL, INTENT(INOUT) :: FHG !stability correction -! canopy height +! outputs + REAL :: RAMG !aerodynamic resistance for momentum (s/m) + REAL :: RAHG !aerodynamic resistance for sensible heat (s/m) + REAL :: RAWG !aerodynamic resistance for water vapor (s/m) + REAL :: RB !bulk leaf boundary layer resistance (s/m) - HCAN = HVT - UC = UR*LOG(HCAN/Z0M)/LOG(ZLVL/Z0M) - UC = UR*LOG((HCAN-ZPD+Z0M)/Z0M)/LOG(ZLVL/Z0M) ! MB: add ZPD v3.7 - IF((HCAN-ZPD) <= 0.) THEN - WRITE(message,*) "CRITICAL PROBLEM: HCAN <= ZPD" - call wrf_message ( message ) - WRITE(message,*) 'i,j point=',ILOC, JLOC - call wrf_message ( message ) - WRITE(message,*) 'HCAN =',HCAN - call wrf_message ( message ) - WRITE(message,*) 'ZPD =',ZPD - call wrf_message ( message ) - write (message, *) 'SNOWH =',SNOWH - call wrf_message ( message ) - call wrf_error_fatal ( "CRITICAL PROBLEM IN MODULE_SF_NOAHMPLSM:VEGEFLUX" ) - END IF -! prepare for longwave rad. + REAL :: KH !turbulent transfer coefficient, sensible heat, (m2/s) + REAL :: TMP1 !temporary calculation + REAL :: TMP2 !temporary calculation + REAL :: TMPRAH2 !temporary calculation for aerodynamic resistances + REAL :: TMPRB !temporary calculation for rb + real :: MOLG,FHGNEW,CWPC +! -------------------------------------------------------------------------------------------------- +! stability correction to below canopy resistance - AIR = -EMV*(1.+(1.-EMV)*(1.-EMG))*LWDN - EMV*EMG*SB*TG**4 - CIR = (2.-EMV*(1.-EMG))*EMV*SB -! --------------------------------------------------------------------------------------------- - loop1: DO ITER = 1, NITERC ! begin stability iteration + MOZG = 0. + MOLG = 0. - IF(ITER == 1) THEN - Z0H = Z0M - Z0HG = Z0MG - ELSE - Z0H = Z0M !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0M)) - Z0HG = Z0MG !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0MG)) + IF(ITER > 1) THEN + TMP1 = VKC * (GRAV/TAH) * HG/(RHOAIR*CPAIR) + IF (ABS(TMP1) .LE. MPE) TMP1 = MPE + MOLG = -1. * FV**3 / TMP1 + MOZG = MIN( (ZPD-Z0MG)/MOLG, 1.) END IF -! aerodyn resistances between heights zlvl and d+z0v - - IF(OPT_SFC == 1) THEN - CALL SFCDIF1(ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in - ZLVL ,ZPD ,Z0M ,Z0H ,UR , & !in - MPE ,ILOC ,JLOC , & !in - MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, & !inout - CM ,CH ,FV ,CH2 ) !out + IF (MOZG < 0.) THEN + FHGNEW = (1. - 15.*MOZG)**(-0.25) + ELSE + FHGNEW = 1.+ 4.7*MOZG ENDIF - - IF(OPT_SFC == 2) THEN - CALL SFCDIF2(ITER ,Z0M ,TAH ,THAIR ,UR , & !in - ZLVL ,ILOC ,JLOC , & !in - CM ,CH ,MOZ ,WSTAR , & !in - FV ) !out - ! Undo the multiplication by windspeed that SFCDIF2 - ! applies to exchange coefficients CH and CM: - CH = CH / UR - CM = CM / UR + + IF (ITER == 1) THEN + FHG = FHGNEW + ELSE + FHG = 0.5 * (FHG+FHGNEW) ENDIF - RAMC = MAX(1.,1./(CM*UR)) - RAHC = MAX(1.,1./(CH*UR)) - RAWC = RAHC + CWPC = (CWP * VAI * HCAN * FHG)**0.5 +! CWPC = (CWP*FHG)**0.5 -! aerodyn resistance between heights z0g and d+z0v, RAG, and leaf -! boundary layer resistance, RB - - CALL RAGRB(ITER ,VAIE ,RHOAIR ,HG ,TAH , & !in - ZPD ,Z0MG ,Z0HG ,HCAN ,UC , & !in - Z0H ,FV ,CWP ,VEGTYP ,MPE , & !in - TV ,MOZG ,FHG ,ILOC ,JLOC , & !inout - RAMG ,RAHG ,RAWG ,RB ) !out + TMP1 = EXP( -CWPC*Z0HG/HCAN ) + TMP2 = EXP( -CWPC*(Z0H+ZPD)/HCAN ) + TMPRAH2 = HCAN*EXP(CWPC) / CWPC * (TMP1-TMP2) -! es and d(es)/dt evaluated at tv +! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. - T = TDC(TV) - CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) - IF (T .GT. 0.) THEN - ESTV = ESATW - DESTV = DSATW - ELSE - ESTV = ESATI - DESTV = DSATI - END IF + KH = MAX ( VKC*FV*(HCAN-ZPD), MPE ) + RAMG = 0. + RAHG = TMPRAH2 / KH + RAWG = RAHG -! stomatal resistance - - IF(ITER == 1) THEN - IF (OPT_CRS == 1) then ! Ball-Berry - CALL STOMATA (VEGTYP,MPE ,PARSUN ,FOLN ,ILOC , JLOC , & !in - TV ,ESTV ,EAH ,SFCTMP,SFCPRS, & !in - O2AIR ,CO2AIR,IGS ,BTRAN ,RB , & !in - RSSUN ,PSNSUN) !out +! leaf boundary layer resistance - CALL STOMATA (VEGTYP,MPE ,PARSHA ,FOLN ,ILOC , JLOC , & !in - TV ,ESTV ,EAH ,SFCTMP,SFCPRS, & !in - O2AIR ,CO2AIR,IGS ,BTRAN ,RB , & !in - RSSHA ,PSNSHA) !out - END IF + TMPRB = CWPC*50. / (1. - EXP(-CWPC/2.)) + RB = TMPRB * SQRT(parameters%DLEAF/UC) +! RB = 200 - IF (OPT_CRS == 2) then ! Jarvis - CALL CANRES (PARSUN,TV ,BTRAN ,EAH ,SFCPRS, & !in - RSSUN ,PSNSUN,ILOC ,JLOC ) !out + END SUBROUTINE RAGRB - CALL CANRES (PARSHA,TV ,BTRAN ,EAH ,SFCPRS, & !in - RSSHA ,PSNSHA,ILOC ,JLOC ) !out - END IF - END IF +!== begin sfcdif1 ================================================================================== -! prepare for sensible heat flux above veg. + SUBROUTINE SFCDIF1(parameters,ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in + & ZLVL ,ZPD ,Z0M ,Z0H ,UR , & !in + & MPE ,ILOC ,JLOC , & !in + & MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, & !inout + & CM ,CH ,FV ,CH2 ) !out +! ------------------------------------------------------------------------------------------------- +! computing surface drag coefficient CM for momentum and CH for heat +! ------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! ------------------------------------------------------------------------------------------------- +! inputs + + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: ITER !iteration index + REAL, INTENT(IN) :: SFCTMP !temperature at reference height (k) + REAL, INTENT(IN) :: RHOAIR !density air (kg/m**3) + REAL, INTENT(IN) :: H !sensible heat flux (w/m2) [+ to atm] + REAL, INTENT(IN) :: QAIR !specific humidity at reference height (kg/kg) + REAL, INTENT(IN) :: ZLVL !reference height (m) + REAL, INTENT(IN) :: ZPD !zero plane displacement (m) + REAL, INTENT(IN) :: Z0H !roughness length, sensible heat, ground (m) + REAL, INTENT(IN) :: Z0M !roughness length, momentum, ground (m) + REAL, INTENT(IN) :: UR !wind speed (m/s) + REAL, INTENT(IN) :: MPE !prevents overflow error if division by zero +! in & out - CAH = 1./RAHC - CVH = 2.*VAIE/RB - CGH = 1./RAHG - COND = CAH + CVH + CGH - ATA = (SFCTMP*CAH + TG*CGH) / COND - BTA = CVH/COND - CSH = (1.-BTA)*RHOAIR*CPAIR*CVH + INTEGER, INTENT(INOUT) :: MOZSGN !number of times moz changes sign + REAL, INTENT(INOUT) :: MOZ !Monin-Obukhov stability (z/L) + REAL, INTENT(INOUT) :: FM !momentum stability correction, weighted by prior iters + REAL, INTENT(INOUT) :: FH !sen heat stability correction, weighted by prior iters + REAL, INTENT(INOUT) :: FM2 !sen heat stability correction, weighted by prior iters + REAL, INTENT(INOUT) :: FH2 !sen heat stability correction, weighted by prior iters -! prepare for latent heat flux above veg. +! outputs - CAW = 1./RAWC - CEW = FWET*VAIE/RB - CTW = (1.-FWET)*(LAISUNE/(RB+RSSUN) + LAISHAE/(RB+RSSHA)) - CGW = 1./(RAWG+RSURF) - COND = CAW + CEW + CTW + CGW - AEA = (EAIR*CAW + ESTG*CGW) / COND - BEA = (CEW+CTW)/COND - CEV = (1.-BEA)*CEW*RHOAIR*CPAIR/GAMMAV ! Barlage: change to vegetation v3.6 - CTR = (1.-BEA)*CTW*RHOAIR*CPAIR/GAMMAV + REAL, INTENT(OUT) :: CM !drag coefficient for momentum + REAL, INTENT(OUT) :: CH !drag coefficient for heat + REAL, INTENT(OUT) :: FV !friction velocity (m/s) + REAL, INTENT(OUT) :: CH2 !drag coefficient for heat -! evaluate surface fluxes with current temperature and solve for dts +! locals + REAL :: MOL !Monin-Obukhov length (m) + REAL :: TMPCM !temporary calculation for CM + REAL :: TMPCH !temporary calculation for CH + REAL :: FMNEW !stability correction factor, momentum, for current moz + REAL :: FHNEW !stability correction factor, sen heat, for current moz + REAL :: MOZOLD !Monin-Obukhov stability parameter from prior iteration + REAL :: TMP1,TMP2,TMP3,TMP4,TMP5 !temporary calculation + REAL :: TVIR !temporary virtual temperature (k) + REAL :: MOZ2 !2/L + REAL :: TMPCM2 !temporary calculation for CM2 + REAL :: TMPCH2 !temporary calculation for CH2 + REAL :: FM2NEW !stability correction factor, momentum, for current moz + REAL :: FH2NEW !stability correction factor, sen heat, for current moz + REAL :: TMP12,TMP22,TMP32 !temporary calculation - TAH = ATA + BTA*TV ! canopy air T. - EAH = AEA + BEA*ESTV ! canopy air e + REAL :: CMFM, CHFH, CM2FM2, CH2FH2 +! ------------------------------------------------------------------------------------------------- +! Monin-Obukhov stability parameter moz for next iteration - IRC = FVEG*(AIR + CIR*TV**4) - SHC = FVEG*RHOAIR*CPAIR*CVH * ( TV-TAH) - EVC = FVEG*RHOAIR*CPAIR*CEW * (ESTV-EAH) / GAMMAV ! Barlage: change to v in v3.6 - TR = FVEG*RHOAIR*CPAIR*CTW * (ESTV-EAH) / GAMMAV - IF (TV > TFRZ) THEN - EVC = MIN(CANLIQ*LATHEAV/DT,EVC) ! Barlage: add if block for canice in v3.6 - ELSE - EVC = MIN(CANICE*LATHEAV/DT,EVC) - END IF + MOZOLD = MOZ + + IF(ZLVL <= ZPD) THEN + write(*,*) 'critical problem: ZLVL <= ZPD; model stops' + call wrf_error_fatal("STOP in Noah-MP") + ENDIF - B = SAV-IRC-SHC-EVC-TR+PAHV !additional w/m2 - A = FVEG*(4.*CIR*TV**3 + CSH + (CEV+CTR)*DESTV) !volumetric heat capacity - DTV = B/A + TMPCM = LOG((ZLVL-ZPD) / Z0M) + TMPCH = LOG((ZLVL-ZPD) / Z0H) + TMPCM2 = LOG((2.0 + Z0M) / Z0M) + TMPCH2 = LOG((2.0 + Z0H) / Z0H) - IRC = IRC + FVEG*4.*CIR*TV**3*DTV - SHC = SHC + FVEG*CSH*DTV - EVC = EVC + FVEG*CEV*DESTV*DTV - TR = TR + FVEG*CTR*DESTV*DTV + IF(ITER == 1) THEN + FV = 0.0 + MOZ = 0.0 + MOL = 0.0 + MOZ2 = 0.0 + ELSE + TVIR = (1. + 0.61*QAIR) * SFCTMP + TMP1 = VKC * (GRAV/TVIR) * H/(RHOAIR*CPAIR) + IF (ABS(TMP1) .LE. MPE) TMP1 = MPE + MOL = -1. * FV**3 / TMP1 + MOZ = MIN( (ZLVL-ZPD)/MOL, 1.) + MOZ2 = MIN( (2.0 + Z0H)/MOL, 1.) + ENDIF -! update vegetation surface temperature - TV = TV + DTV -! TAH = ATA + BTA*TV ! canopy air T; update here for consistency +! accumulate number of times moz changes sign. + + IF (MOZOLD*MOZ .LT. 0.) MOZSGN = MOZSGN+1 + IF (MOZSGN .GE. 2) THEN + MOZ = 0. + FM = 0. + FH = 0. + MOZ2 = 0. + FM2 = 0. + FH2 = 0. + ENDIF + +! evaluate stability-dependent variables using moz from prior iteration + IF (MOZ .LT. 0.) THEN + TMP1 = (1. - 16.*MOZ)**0.25 + TMP2 = LOG((1.+TMP1*TMP1)/2.) + TMP3 = LOG((1.+TMP1)/2.) + FMNEW = 2.*TMP3 + TMP2 - 2.*ATAN(TMP1) + 1.5707963 + FHNEW = 2*TMP2 -! for computing M-O length in the next iteration - H = RHOAIR*CPAIR*(TAH - SFCTMP) /RAHC - HG = RHOAIR*CPAIR*(TG - TAH) /RAHG +! 2-meter + TMP12 = (1. - 16.*MOZ2)**0.25 + TMP22 = LOG((1.+TMP12*TMP12)/2.) + TMP32 = LOG((1.+TMP12)/2.) + FM2NEW = 2.*TMP32 + TMP22 - 2.*ATAN(TMP12) + 1.5707963 + FH2NEW = 2*TMP22 + ELSE + FMNEW = -5.*MOZ + FHNEW = FMNEW + FM2NEW = -5.*MOZ2 + FH2NEW = FM2NEW + ENDIF -! consistent specific humidity from canopy air vapor pressure - QSFC = (0.622*EAH)/(SFCPRS-0.378*EAH) +! except for first iteration, weight stability factors for previous +! iteration to help avoid flip-flops from one iteration to the next - IF (LITER == 1) THEN - exit loop1 - ENDIF - IF (ITER >= 5 .AND. ABS(DTV) <= 0.01 .AND. LITER == 0) THEN - LITER = 1 - ENDIF + IF (ITER == 1) THEN + FM = FMNEW + FH = FHNEW + FM2 = FM2NEW + FH2 = FH2NEW + ELSE + FM = 0.5 * (FM+FMNEW) + FH = 0.5 * (FH+FHNEW) + FM2 = 0.5 * (FM2+FM2NEW) + FH2 = 0.5 * (FH2+FH2NEW) + ENDIF - END DO loop1 ! end stability iteration +! exchange coefficients -! under-canopy fluxes and tg + FH = MIN(FH,0.9*TMPCH) + FM = MIN(FM,0.9*TMPCM) + FH2 = MIN(FH2,0.9*TMPCH2) + FM2 = MIN(FM2,0.9*TMPCM2) - AIR = - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4 - CIR = EMG*SB - CSH = RHOAIR*CPAIR/RAHG - CEV = RHOAIR*CPAIR / (GAMMAG*(RAWG+RSURF)) ! Barlage: change to ground v3.6 - CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1) + CMFM = TMPCM-FM + CHFH = TMPCH-FH + CM2FM2 = TMPCM2-FM2 + CH2FH2 = TMPCH2-FH2 + IF(ABS(CMFM) <= MPE) CMFM = MPE + IF(ABS(CHFH) <= MPE) CHFH = MPE + IF(ABS(CM2FM2) <= MPE) CM2FM2 = MPE + IF(ABS(CH2FH2) <= MPE) CH2FH2 = MPE + CM = VKC*VKC/(CMFM*CMFM) + CH = VKC*VKC/(CMFM*CHFH) + CH2 = VKC*VKC/(CM2FM2*CH2FH2) + +! friction velocity - loop2: DO ITER = 1, NITERG + FV = UR * SQRT(CM) + CH2 = VKC*FV/CH2FH2 - T = TDC(TG) - CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) - IF (T .GT. 0.) THEN - ESTG = ESATW - DESTG = DSATW - ELSE - ESTG = ESATI - DESTG = DSATI - END IF + END SUBROUTINE SFCDIF1 - IRG = CIR*TG**4 + AIR - SHG = CSH * (TG - TAH ) - EVG = CEV * (ESTG*RHSUR - EAH ) - GH = CGH * (TG - STC(ISNOW+1)) +!== begin sfcdif2 ================================================================================== - B = SAG-IRG-SHG-EVG-GH+PAHG - A = 4.*CIR*TG**3+CSH+CEV*DESTG+CGH - DTG = B/A + SUBROUTINE SFCDIF2(parameters,ITER ,Z0 ,THZ0 ,THLM ,SFCSPD , & !in + ZLM ,ILOC ,JLOC , & !in + AKMS ,AKHS ,RLMO ,WSTAR2 , & !in + USTAR ) !out - IRG = IRG + 4.*CIR*TG**3*DTG - SHG = SHG + CSH*DTG - EVG = EVG + CEV*DESTG*DTG - GH = GH + CGH*DTG - TG = TG + DTG +! ------------------------------------------------------------------------------------------------- +! SUBROUTINE SFCDIF (renamed SFCDIF_off to avoid clash with Eta PBL) +! ------------------------------------------------------------------------------------------------- +! CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS. +! SEE CHEN ET AL (1997, BLM) +! ------------------------------------------------------------------------------------------------- + IMPLICIT NONE + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + INTEGER, INTENT(IN) :: ITER + REAL, INTENT(IN) :: ZLM, Z0, THZ0, THLM, SFCSPD + REAL, intent(INOUT) :: AKMS + REAL, intent(INOUT) :: AKHS + REAL, intent(INOUT) :: RLMO + REAL, intent(INOUT) :: WSTAR2 + REAL, intent(OUT) :: USTAR - END DO loop2 - -! TAH = (CAH*SFCTMP + CVH*TV + CGH*TG)/(CAH + CVH + CGH) + REAL ZZ, PSLMU, PSLMS, PSLHU, PSLHS + REAL XX, PSPMU, YY, PSPMS, PSPHU, PSPHS + REAL ZILFC, ZU, ZT, RDZ, CXCH + REAL DTHV, DU2, BTGH, ZSLU, ZSLT, RLOGU, RLOGT + REAL ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4 -! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes. + REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, & + & RLMA - IF(OPT_STC == 1 .OR. OPT_STC == 3) THEN - IF (SNOWH > 0.05 .AND. TG > TFRZ) THEN - TG = TFRZ - IF(OPT_STC == 3) TG = (1.-FSNO)*TG + FSNO*TFRZ ! MB: allow TG>0C during melt v3.7 - IRG = CIR*TG**4 - EMG*(1.-EMV)*LWDN - EMG*EMV*SB*TV**4 - SHG = CSH * (TG - TAH) - EVG = CEV * (ESTG*RHSUR - EAH) - GH = SAG+PAHG - (IRG+SHG+EVG) - END IF - END IF + INTEGER ILECH, ITR -! wind stresses + INTEGER, PARAMETER :: ITRMX = 5 + REAL, PARAMETER :: WWST = 1.2 + REAL, PARAMETER :: WWST2 = WWST * WWST + REAL, PARAMETER :: VKRM = 0.40 + REAL, PARAMETER :: EXCM = 0.001 + REAL, PARAMETER :: BETA = 1.0 / 270.0 + REAL, PARAMETER :: BTG = BETA * GRAV + REAL, PARAMETER :: ELFC = VKRM * BTG + REAL, PARAMETER :: WOLD = 0.15 + REAL, PARAMETER :: WNEW = 1.0 - WOLD + REAL, PARAMETER :: PIHF = 3.14159265 / 2. + REAL, PARAMETER :: EPSU2 = 1.E-4 + REAL, PARAMETER :: EPSUST = 0.07 + REAL, PARAMETER :: EPSIT = 1.E-4 + REAL, PARAMETER :: EPSA = 1.E-8 + REAL, PARAMETER :: ZTMIN = -5.0 + REAL, PARAMETER :: ZTMAX = 1.0 + REAL, PARAMETER :: HPBL = 1000.0 + REAL, PARAMETER :: SQVISC = 258.2 + REAL, PARAMETER :: RIC = 0.183 + REAL, PARAMETER :: RRIC = 1.0 / RIC + REAL, PARAMETER :: FHNEU = 0.8 + REAL, PARAMETER :: RFC = 0.191 + REAL, PARAMETER :: RFAC = RIC / ( FHNEU * RFC * RFC ) - TAUXV = -RHOAIR*CM*UR*UU - TAUYV = -RHOAIR*CM*UR*VV +! ---------------------------------------------------------------------- +! NOTE: THE TWO CODE BLOCKS BELOW DEFINE FUNCTIONS +! ---------------------------------------------------------------------- +! LECH'S SURFACE FUNCTIONS + PSLMU (ZZ)= -0.96* log (1.0-4.5* ZZ) + PSLMS (ZZ)= ZZ * RRIC -2.076* (1. -1./ (ZZ +1.)) + PSLHU (ZZ)= -0.96* log (1.0-4.5* ZZ) + PSLHS (ZZ)= ZZ * RFAC -2.076* (1. -1./ (ZZ +1.)) +! PAULSON'S SURFACE FUNCTIONS + PSPMU (XX)= -2.* log ( (XX +1.)*0.5) - log ( (XX * XX +1.)*0.5) & + & +2.* ATAN (XX) & + &- PIHF + PSPMS (YY)= 5.* YY + PSPHU (XX)= -2.* log ( (XX * XX +1.)*0.5) + PSPHS (YY)= 5.* YY -! consistent vegetation air temperature and vapor pressure since TG is not consistent with the TAH/EAH -! calculation. -! TAH = SFCTMP + (SHG+SHC)/(RHOAIR*CPAIR*CAH) -! TAH = SFCTMP + (SHG*FVEG+SHC)/(RHOAIR*CPAIR*CAH) ! ground flux need fveg -! EAH = EAIR + (EVC+FVEG*(TR+EVG))/(RHOAIR*CAW*CPAIR/GAMMAG ) -! QFX = (QSFC-QAIR)*RHOAIR*CAW !*CPAIR/GAMMAG +! THIS ROUTINE SFCDIF CAN HANDLE BOTH OVER OPEN WATER (SEA, OCEAN) AND +! OVER SOLID SURFACE (LAND, SEA-ICE). +! ---------------------------------------------------------------------- +! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1 +! C......ZTFC=0.1 +! CZIL: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT +! ---------------------------------------------------------------------- + ILECH = 0 -! 2m temperature over vegetation ( corrected for low CQ2V values ) - IF (OPT_SFC == 1 .OR. OPT_SFC == 2) THEN -! CAH2 = FV*1./VKC*LOG((2.+Z0H)/Z0H) - CAH2 = FV*VKC/LOG((2.+Z0H)/Z0H) - CAH2 = FV*VKC/(LOG((2.+Z0H)/Z0H)-FH2) - CQ2V = CAH2 - IF (CAH2 .LT. 1.E-5 ) THEN - T2MV = TAH -! Q2V = (EAH*0.622/(SFCPRS - 0.378*EAH)) - Q2V = QSFC - ELSE - T2MV = TAH - (SHG+SHC/FVEG)/(RHOAIR*CPAIR) * 1./CAH2 -! Q2V = (EAH*0.622/(SFCPRS - 0.378*EAH))- QFX/(RHOAIR*FV)* 1./VKC * LOG((2.+Z0H)/Z0H) - Q2V = QSFC - ((EVC+TR)/FVEG+EVG)/(LATHEAV*RHOAIR) * 1./CQ2V - ENDIF - ENDIF +! ---------------------------------------------------------------------- + ZILFC = - parameters%CZIL * VKRM * SQVISC + ZU = Z0 + RDZ = 1./ ZLM + CXCH = EXCM * RDZ + DTHV = THLM - THZ0 -! update CH for output - CH = CAH - CHLEAF = CVH - CHUC = 1./RAHG +! BELJARS CORRECTION OF USTAR + DU2 = MAX (SFCSPD * SFCSPD,EPSU2) + BTGH = BTG * HPBL - END SUBROUTINE VEGE_FLUX + IF(ITER == 1) THEN + IF (BTGH * AKHS * DTHV .ne. 0.0) THEN + WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) + ELSE + WSTAR2 = 0.0 + END IF + USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) + RLMO = ELFC * AKHS * DTHV / USTAR **3 + END IF + +! ZILITINKEVITCH APPROACH FOR ZT + ZT = MAX(1.E-6,EXP (ZILFC * SQRT (USTAR * Z0))* Z0) + ZSLU = ZLM + ZU + ZSLT = ZLM + ZT + RLOGU = log (ZSLU / ZU) + RLOGT = log (ZSLT / ZT) -!== begin bare_flux ================================================================================ +! ---------------------------------------------------------------------- +! 1./MONIN-OBUKKHOV LENGTH-SCALE +! ---------------------------------------------------------------------- + ZETALT = MAX (ZSLT * RLMO,ZTMIN) + RLMO = ZETALT / ZSLT + ZETALU = ZSLU * RLMO + ZETAU = ZU * RLMO + ZETAT = ZT * RLMO - SUBROUTINE BARE_FLUX (NSNOW ,NSOIL ,ISNOW ,DT ,SAG , & !in - LWDN ,UR ,UU ,VV ,SFCTMP , & !in - THAIR ,QAIR ,EAIR ,RHOAIR ,SNOWH , & !in - DZSNSO ,ZLVL ,ZPD ,Z0M ,FSNO , & !in - EMG ,STC ,DF ,RSURF ,LATHEA , & !in - GAMMA ,RHSUR ,ILOC ,JLOC ,Q2 ,PAHB , & !in - TGB ,CM ,CH , & !inout - TAUXB ,TAUYB ,IRB ,SHB ,EVB , & !out - GHB ,T2MB ,DX ,DZ8W ,IVGTYP , & !out - QC ,QSFC ,PSFC , & !in - SFCPRS ,Q2B ,EHB2 ) !in + IF (ILECH .eq. 0) THEN + IF (RLMO .lt. 0.)THEN + XLU4 = 1. -16.* ZETALU + XLT4 = 1. -16.* ZETALT + XU4 = 1. -16.* ZETAU + XT4 = 1. -16.* ZETAT + XLU = SQRT (SQRT (XLU4)) + XLT = SQRT (SQRT (XLT4)) + XU = SQRT (SQRT (XU4)) -! -------------------------------------------------------------------------------------------------- -! use newton-raphson iteration to solve ground (tg) temperature -! that balances the surface energy budgets for bare soil fraction. + XT = SQRT (SQRT (XT4)) + PSMZ = PSPMU (XU) + SIMM = PSPMU (XLU) - PSMZ + RLOGU + PSHZ = PSPHU (XT) + SIMH = PSPHU (XLT) - PSHZ + RLOGT + ELSE + ZETALU = MIN (ZETALU,ZTMAX) + ZETALT = MIN (ZETALT,ZTMAX) + PSMZ = PSPMS (ZETAU) + SIMM = PSPMS (ZETALU) - PSMZ + RLOGU + PSHZ = PSPHS (ZETAT) + SIMH = PSPHS (ZETALT) - PSHZ + RLOGT + END IF +! ---------------------------------------------------------------------- +! LECH'S FUNCTIONS +! ---------------------------------------------------------------------- + ELSE + IF (RLMO .lt. 0.)THEN + PSMZ = PSLMU (ZETAU) + SIMM = PSLMU (ZETALU) - PSMZ + RLOGU + PSHZ = PSLHU (ZETAT) + SIMH = PSLHU (ZETALT) - PSHZ + RLOGT + ELSE + ZETALU = MIN (ZETALU,ZTMAX) + ZETALT = MIN (ZETALT,ZTMAX) + PSMZ = PSLMS (ZETAU) + SIMM = PSLMS (ZETALU) - PSMZ + RLOGU + PSHZ = PSLHS (ZETAT) + SIMH = PSLHS (ZETALT) - PSHZ + RLOGT + END IF +! ---------------------------------------------------------------------- + END IF -! bare soil: -! -SAB + IRB[TG] + SHB[TG] + EVB[TG] + GHB[TG] = 0 ! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: SB, VKC, TFRZ, CPAIR, ISURBAN ! MP CONSTANT +! BELJAARS CORRECTION FOR USTAR ! ---------------------------------------------------------------------- - IMPLICIT NONE + USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) + +! ZILITINKEVITCH FIX FOR ZT + ZT = MAX(1.E-6,EXP (ZILFC * SQRT (USTAR * Z0))* Z0) + ZSLT = ZLM + ZT +!----------------------------------------------------------------------- + RLOGT = log (ZSLT / ZT) + USTARK = USTAR * VKRM + AKMS = MAX (USTARK / SIMM,CXCH) +!----------------------------------------------------------------------- +! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO +!----------------------------------------------------------------------- + AKHS = MAX (USTARK / SIMH,CXCH) + + IF (BTGH * AKHS * DTHV .ne. 0.0) THEN + WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) + ELSE + WSTAR2 = 0.0 + END IF +!----------------------------------------------------------------------- + RLMN = ELFC * AKHS * DTHV / USTAR **3 +!----------------------------------------------------------------------- +! IF(ABS((RLMN-RLMO)/RLMA).LT.EPSIT) GO TO 110 +!----------------------------------------------------------------------- + RLMA = RLMO * WOLD+ RLMN * WNEW +!----------------------------------------------------------------------- + RLMO = RLMA + +! write(*,'(a20,10f15.6)')'SFCDIF: RLMO=',RLMO,RLMN,ELFC , AKHS , DTHV , USTAR +! END DO ! ---------------------------------------------------------------------- -! input - integer , INTENT(IN) :: ILOC !grid index - integer , INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER, INTENT(IN) :: NSOIL !number of soil layers - INTEGER, INTENT(IN) :: ISNOW !actual no. of snow layers - REAL, INTENT(IN) :: DT !time step (s) - REAL, INTENT(IN) :: SAG !solar radiation absorbed by ground (w/m2) - REAL, INTENT(IN) :: LWDN !atmospheric longwave radiation (w/m2) - REAL, INTENT(IN) :: UR !wind speed at height zlvl (m/s) - REAL, INTENT(IN) :: UU !wind speed in eastward dir (m/s) - REAL, INTENT(IN) :: VV !wind speed in northward dir (m/s) - REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) - REAL, INTENT(IN) :: THAIR !potential temperature at height zlvl (k) - REAL, INTENT(IN) :: QAIR !specific humidity at height zlvl (kg/kg) - REAL, INTENT(IN) :: EAIR !vapor pressure air at height (pa) - REAL, INTENT(IN) :: RHOAIR !density air (kg/m3) - REAL, INTENT(IN) :: SNOWH !actual snow depth [m] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !thickness of snow/soil layers (m) - REAL, INTENT(IN) :: ZLVL !reference height (m) - REAL, INTENT(IN) :: ZPD !zero plane displacement (m) - REAL, INTENT(IN) :: Z0M !roughness length, momentum, ground (m) - REAL, INTENT(IN) :: EMG !ground emissivity - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !soil/snow temperature (k) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity of snow/soil (w/m/k) - REAL, INTENT(IN) :: RSURF !ground surface resistance (s/m) - REAL, INTENT(IN) :: LATHEA !latent heat of vaporization/subli (j/kg) - REAL, INTENT(IN) :: GAMMA !psychrometric constant (pa/k) - REAL, INTENT(IN) :: RHSUR !raltive humidity in surface soil/snow air space (-) - REAL, INTENT(IN) :: FSNO !snow fraction + END SUBROUTINE SFCDIF2 -!jref:start; in - INTEGER , INTENT(IN) :: IVGTYP - REAL , INTENT(IN) :: QC !cloud water mixing ratio - REAL , INTENT(INOUT) :: QSFC !mixing ratio at lowest model layer - REAL , INTENT(IN) :: PSFC !pressure at lowest model layer - REAL , INTENT(IN) :: SFCPRS !pressure at lowest model layer - REAL , INTENT(IN) :: DX !horisontal grid spacing - REAL , INTENT(IN) :: Q2 !mixing ratio (kg/kg) - REAL , INTENT(IN) :: DZ8W !thickness of lowest layer -!jref:end - REAL, INTENT(IN) :: PAHB !precipitation advected heat - ground net IN (W/m2) +!== begin esat ===================================================================================== -! input/output - REAL, INTENT(INOUT) :: TGB !ground temperature (k) - REAL, INTENT(INOUT) :: CM !momentum drag coefficient - REAL, INTENT(INOUT) :: CH !sensible heat exchange coefficient + SUBROUTINE ESAT(T, ESW, ESI, DESW, DESI) +!--------------------------------------------------------------------------------------------------- +! use polynomials to calculate saturation vapor pressure and derivative with +! respect to temperature: over water when t > 0 c and over ice when t <= 0 c + IMPLICIT NONE +!--------------------------------------------------------------------------------------------------- +! in -! output -! -SAB + IRB[TG] + SHB[TG] + EVB[TG] + GHB[TG] = 0 + REAL, intent(in) :: T !temperature - REAL, INTENT(OUT) :: TAUXB !wind stress: e-w (n/m2) - REAL, INTENT(OUT) :: TAUYB !wind stress: n-s (n/m2) - REAL, INTENT(OUT) :: IRB !net longwave rad (w/m2) [+ to atm] - REAL, INTENT(OUT) :: SHB !sensible heat flux (w/m2) [+ to atm] - REAL, INTENT(OUT) :: EVB !latent heat flux (w/m2) [+ to atm] - REAL, INTENT(OUT) :: GHB !ground heat flux (w/m2) [+ to soil] - REAL, INTENT(OUT) :: T2MB !2 m height air temperature (k) -!jref:start - REAL, INTENT(OUT) :: Q2B !bare ground heat conductance - REAL :: EHB !bare ground heat conductance - REAL :: U10B !10 m wind speed in eastward dir (m/s) - REAL :: V10B !10 m wind speed in eastward dir (m/s) - REAL :: WSPD -!jref:end +!out -! local variables + REAL, intent(out) :: ESW !saturation vapor pressure over water (pa) + REAL, intent(out) :: ESI !saturation vapor pressure over ice (pa) + REAL, intent(out) :: DESW !d(esat)/dt over water (pa/K) + REAL, intent(out) :: DESI !d(esat)/dt over ice (pa/K) - REAL :: TAUX !wind stress: e-w (n/m2) - REAL :: TAUY !wind stress: n-s (n/m2) - REAL :: FIRA !total net longwave rad (w/m2) [+ to atm] - REAL :: FSH !total sensible heat flux (w/m2) [+ to atm] - REAL :: FGEV !ground evaporation heat flux (w/m2)[+ to atm] - REAL :: SSOIL !soil heat flux (w/m2) [+ to soil] - REAL :: FIRE !emitted ir (w/m2) - REAL :: TRAD !radiative temperature (k) - REAL :: TAH !"surface" temperature at height z0h+zpd (k) +! local - REAL :: CW !water vapor exchange coefficient - REAL :: FV !friction velocity (m/s) - REAL :: WSTAR !friction velocity n vertical direction (m/s) (only for SFCDIF2) - REAL :: Z0H !roughness length, sensible heat, ground (m) - REAL :: RB !bulk leaf boundary layer resistance (s/m) - REAL :: RAMB !aerodynamic resistance for momentum (s/m) - REAL :: RAHB !aerodynamic resistance for sensible heat (s/m) - REAL :: RAWB !aerodynamic resistance for water vapor (s/m) - REAL :: MOL !Monin-Obukhov length (m) - REAL :: DTG !change in tg, last iteration (k) + REAL :: A0,A1,A2,A3,A4,A5,A6 !coefficients for esat over water + REAL :: B0,B1,B2,B3,B4,B5,B6 !coefficients for esat over ice + REAL :: C0,C1,C2,C3,C4,C5,C6 !coefficients for dsat over water + REAL :: D0,D1,D2,D3,D4,D5,D6 !coefficients for dsat over ice - REAL :: CIR !coefficients for ir as function of ts**4 - REAL :: CSH !coefficients for sh as function of ts - REAL :: CEV !coefficients for ev as function of esat[ts] - REAL :: CGH !coefficients for st as function of ts + PARAMETER (A0=6.107799961 , A1=4.436518521E-01, & + A2=1.428945805E-02, A3=2.650648471E-04, & + A4=3.031240396E-06, A5=2.034080948E-08, & + A6=6.136820929E-11) -!jref:start - REAL :: RAHB2 !aerodynamic resistance for sensible heat 2m (s/m) - REAL :: RAWB2 !aerodynamic resistance for water vapor 2m (s/m) - REAL,INTENT(OUT) :: EHB2 !sensible heat conductance for diagnostics - REAL :: CH2B !exchange coefficient for 2m temp. - REAL :: CQ2B !exchange coefficient for 2m temp. - REAL :: THVAIR !virtual potential air temp - REAL :: THGH !potential ground temp - REAL :: EMB !momentum conductance - REAL :: QFX !moisture flux - REAL :: ESTG2 !saturation vapor pressure at 2m (pa) - INTEGER :: VEGTYP !vegetation type set to isbarren - REAL :: E1 -!jref:end + PARAMETER (B0=6.109177956 , B1=5.034698970E-01, & + B2=1.886013408E-02, B3=4.176223716E-04, & + B4=5.824720280E-06, B5=4.838803174E-08, & + B6=1.838826904E-10) - REAL :: ESTG !saturation vapor pressure at tg (pa) - REAL :: DESTG !d(es)/dt at tg (pa/K) - REAL :: ESATW !es for water - REAL :: ESATI !es for ice - REAL :: DSATW !d(es)/dt at tg (pa/K) for water - REAL :: DSATI !d(es)/dt at tg (pa/K) for ice + PARAMETER (C0= 4.438099984E-01, C1=2.857002636E-02, & + C2= 7.938054040E-04, C3=1.215215065E-05, & + C4= 1.036561403E-07, C5=3.532421810e-10, & + C6=-7.090244804E-13) - REAL :: A !temporary calculation - REAL :: B !temporary calculation - REAL :: H !temporary sensible heat flux (w/m2) - REAL :: MOZ !Monin-Obukhov stability parameter - REAL :: MOZOLD !Monin-Obukhov stability parameter from prior iteration - REAL :: FM !momentum stability correction, weighted by prior iters - REAL :: FH !sen heat stability correction, weighted by prior iters - INTEGER :: MOZSGN !number of times MOZ changes sign - REAL :: FM2 !Monin-Obukhov momentum adjustment at 2m - REAL :: FH2 !Monin-Obukhov heat adjustment at 2m - REAL :: CH2 !Surface exchange at 2m + PARAMETER (D0=5.030305237E-01, D1=3.773255020E-02, & + D2=1.267995369E-03, D3=2.477563108E-05, & + D4=3.005693132E-07, D5=2.158542548E-09, & + D6=7.131097725E-12) - INTEGER :: ITER !iteration index - INTEGER :: NITERB !number of iterations for surface temperature - REAL :: MPE !prevents overflow error if division by zero -!jref:start -! DATA NITERB /3/ - DATA NITERB /5/ - SAVE NITERB - REAL :: T, TDC !Kelvin to degree Celsius with limit -50 to +50 - TDC(T) = MIN( 50., MAX(-50.,(T-TFRZ)) ) + ESW = 100.*(A0+T*(A1+T*(A2+T*(A3+T*(A4+T*(A5+T*A6)))))) + ESI = 100.*(B0+T*(B1+T*(B2+T*(B3+T*(B4+T*(B5+T*B6)))))) + DESW = 100.*(C0+T*(C1+T*(C2+T*(C3+T*(C4+T*(C5+T*C6)))))) + DESI = 100.*(D0+T*(D1+T*(D2+T*(D3+T*(D4+T*(D5+T*D6)))))) -! ----------------------------------------------------------------- -! initialization variables that do not depend on stability iteration -! ----------------------------------------------------------------- - MPE = 1E-6 - DTG = 0. - MOZ = 0. - MOZSGN = 0 - MOZOLD = 0. - H = 0. - QFX = 0. - FV = 0.1 + END SUBROUTINE ESAT - CIR = EMG*SB - CGH = 2.*DF(ISNOW+1)/DZSNSO(ISNOW+1) +!== begin stomata ================================================================================== -! ----------------------------------------------------------------- - loop3: DO ITER = 1, NITERB ! begin stability iteration + SUBROUTINE STOMATA (parameters,VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in + TV ,EI ,EA ,SFCTMP ,SFCPRS , & !in + O2 ,CO2 ,IGS ,BTRAN ,RB , & !in + RS ,PSN ) !out +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: ILOC !grid index + INTEGER,INTENT(IN) :: JLOC !grid index + INTEGER,INTENT(IN) :: VEGTYP !vegetation physiology type - IF(ITER == 1) THEN - Z0H = Z0M - ELSE - Z0H = Z0M !* EXP(-CZIL*0.4*258.2*SQRT(FV*Z0M)) - END IF + REAL, INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL, INTENT(IN) :: MPE !prevents division by zero errors - IF(OPT_SFC == 1) THEN - CALL SFCDIF1(ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in - ZLVL ,ZPD ,Z0M ,Z0H ,UR , & !in - MPE ,ILOC ,JLOC , & !in - MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, & !inout - CM ,CH ,FV ,CH2 ) !out - ENDIF + REAL, INTENT(IN) :: TV !foliage temperature (k) + REAL, INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) + REAL, INTENT(IN) :: EA !vapor pressure of canopy air (pa) + REAL, INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) + REAL, INTENT(IN) :: O2 !atmospheric o2 concentration (pa) + REAL, INTENT(IN) :: CO2 !atmospheric co2 concentration (pa) + REAL, INTENT(IN) :: SFCPRS !air pressure at reference height (pa) + REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) + REAL, INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) + REAL, INTENT(IN) :: FOLN !foliage nitrogen concentration (%) + REAL, INTENT(IN) :: RB !boundary layer resistance (s/m) - IF(OPT_SFC == 2) THEN - CALL SFCDIF2(ITER ,Z0M ,TGB ,THAIR ,UR , & !in - ZLVL ,ILOC ,JLOC , & !in - CM ,CH ,MOZ ,WSTAR , & !in - FV ) !out - ! Undo the multiplication by windspeed that SFCDIF2 - ! applies to exchange coefficients CH and CM: - CH = CH / UR - CM = CM / UR - IF(SNOWH > 0.) THEN - CM = MIN(0.01,CM) ! CM & CH are too large, causing - CH = MIN(0.01,CH) ! computational instability - END IF +! output + REAL, INTENT(OUT) :: RS !leaf stomatal resistance (s/m) + REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umol co2 /m2/ s) [always +] - ENDIF +! in&out + REAL :: RLB !boundary layer resistance (s m2 / umol) +! --------------------------------------------------------------------------------------------- - RAMB = MAX(1.,1./(CM*UR)) - RAHB = MAX(1.,1./(CH*UR)) - RAWB = RAHB +! ------------------------ local variables ---------------------------------------------------- + INTEGER :: ITER !iteration index + INTEGER :: NITER !number of iterations -!jref - variables for diagnostics - EMB = 1./RAMB - EHB = 1./RAHB + DATA NITER /3/ + SAVE NITER -! es and d(es)/dt evaluated at tg + REAL :: AB !used in statement functions + REAL :: BC !used in statement functions + REAL :: F1 !generic temperature response (statement function) + REAL :: F2 !generic temperature inhibition (statement function) + REAL :: TC !foliage temperature (degree Celsius) + REAL :: CS !co2 concentration at leaf surface (pa) + REAL :: KC !co2 Michaelis-Menten constant (pa) + REAL :: KO !o2 Michaelis-Menten constant (pa) + REAL :: A,B,C,Q !intermediate calculations for RS + REAL :: R1,R2 !roots for RS + REAL :: FNF !foliage nitrogen adjustment factor (0 to 1) + REAL :: PPF !absorb photosynthetic photon flux (umol photons/m2/s) + REAL :: WC !Rubisco limited photosynthesis (umol co2/m2/s) + REAL :: WJ !light limited photosynthesis (umol co2/m2/s) + REAL :: WE !export limited photosynthesis (umol co2/m2/s) + REAL :: CP !co2 compensation point (pa) + REAL :: CI !internal co2 (pa) + REAL :: AWC !intermediate calculation for wc + REAL :: VCMX !maximum rate of carbonylation (umol co2/m2/s) + REAL :: J !electron transport (umol co2/m2/s) + REAL :: CEA !constrain ea or else model blows up + REAL :: CF !s m2/umol -> s/m - T = TDC(TGB) - CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) - IF (T .GT. 0.) THEN - ESTG = ESATW - DESTG = DSATW - ELSE - ESTG = ESATI - DESTG = DSATI - END IF + F1(AB,BC) = AB**((BC-25.)/10.) + F2(AB) = 1. + EXP((-2.2E05+710.*(AB+273.16))/(8.314*(AB+273.16))) + REAL :: T +! --------------------------------------------------------------------------------------------- - CSH = RHOAIR*CPAIR/RAHB - CEV = RHOAIR*CPAIR/GAMMA/(RSURF+RAWB) +! initialize RS=RSMAX and PSN=0 because will only do calculations +! for APAR > 0, in which case RS <= RSMAX and PSN >= 0 -! surface fluxes and dtg + CF = SFCPRS/(8.314*SFCTMP)*1.e06 + RS = 1./parameters%BP * CF + PSN = 0. - IRB = CIR * TGB**4 - EMG*LWDN - SHB = CSH * (TGB - SFCTMP ) - EVB = CEV * (ESTG*RHSUR - EAIR ) - GHB = CGH * (TGB - STC(ISNOW+1)) + IF (APAR .LE. 0.) RETURN - B = SAG-IRB-SHB-EVB-GHB+PAHB - A = 4.*CIR*TGB**3 + CSH + CEV*DESTG + CGH - DTG = B/A + FNF = MIN( FOLN/MAX(MPE,parameters%FOLNMX), 1.0 ) + TC = TV-TFRZ + PPF = 4.6*APAR + J = PPF*parameters%QE25 + KC = parameters%KC25 * F1(parameters%AKC,TC) + KO = parameters%KO25 * F1(parameters%AKO,TC) + AWC = KC * (1.+O2/KO) + CP = 0.5*KC/KO*O2*0.21 + VCMX = parameters%VCMX25 / F2(TC) * FNF * BTRAN * F1(parameters%AVCMX,TC) - IRB = IRB + 4.*CIR*TGB**3*DTG - SHB = SHB + CSH*DTG - EVB = EVB + CEV*DESTG*DTG - GHB = GHB + CGH*DTG +! first guess ci -! update ground surface temperature - TGB = TGB + DTG + CI = 0.7*CO2*parameters%C3PSN + 0.4*CO2*(1.-parameters%C3PSN) -! for M-O length - H = CSH * (TGB - SFCTMP) +! rb: s/m -> s m**2 / umol - T = TDC(TGB) - CALL ESAT(T, ESATW, ESATI, DSATW, DSATI) - IF (T .GT. 0.) THEN - ESTG = ESATW - ELSE - ESTG = ESATI - END IF - QSFC = 0.622*(ESTG*RHSUR)/(PSFC-0.378*(ESTG*RHSUR)) + RLB = RB/CF - QFX = (QSFC-QAIR)*CEV*GAMMA/CPAIR +! constrain ea - END DO loop3 ! end stability iteration -! ----------------------------------------------------------------- + CEA = MAX(0.25*EI*parameters%C3PSN+0.40*EI*(1.-parameters%C3PSN), MIN(EA,EI) ) -! if snow on ground and TG > TFRZ: reset TG = TFRZ. reevaluate ground fluxes. +! ci iteration +!jref: C3PSN is equal to 1 for all veg types. + DO ITER = 1, NITER + WJ = MAX(CI-CP,0.)*J/(CI+2.*CP)*parameters%C3PSN + J*(1.-parameters%C3PSN) + WC = MAX(CI-CP,0.)*VCMX/(CI+AWC)*parameters%C3PSN + VCMX*(1.-parameters%C3PSN) + WE = 0.5*VCMX*parameters%C3PSN + 4000.*VCMX*CI/SFCPRS*(1.-parameters%C3PSN) + PSN = MIN(WJ,WC,WE) * IGS - IF(OPT_STC == 1 .OR. OPT_STC == 3) THEN - IF (SNOWH > 0.05 .AND. TGB > TFRZ) THEN - TGB = TFRZ - IF(OPT_STC == 3) TGB = (1.-FSNO)*TGB + FSNO*TFRZ ! MB: allow TG>0C during melt v3.7 - IRB = CIR * TGB**4 - EMG*LWDN - SHB = CSH * (TGB - SFCTMP) - EVB = CEV * (ESTG*RHSUR - EAIR ) !ESTG reevaluate ? - GHB = SAG+PAHB - (IRB+SHB+EVB) - END IF - END IF + CS = MAX( CO2-1.37*RLB*SFCPRS*PSN, MPE ) + A = parameters%MP*PSN*SFCPRS*CEA / (CS*EI) + parameters%BP + B = ( parameters%MP*PSN*SFCPRS/CS + parameters%BP ) * RLB - 1. + C = -RLB + IF (B .GE. 0.) THEN + Q = -0.5*( B + SQRT(B*B-4.*A*C) ) + ELSE + Q = -0.5*( B - SQRT(B*B-4.*A*C) ) + END IF + R1 = Q/A + R2 = C/Q + RS = MAX(R1,R2) + CI = MAX( CS-PSN*SFCPRS*1.65*RS, 0. ) + END DO -! wind stresses - - TAUXB = -RHOAIR*CM*UR*UU - TAUYB = -RHOAIR*CM*UR*VV +! rs, rb: s m**2 / umol -> s/m -!jref:start; errors in original equation corrected. -! 2m air temperature - IF(OPT_SFC == 1 .OR. OPT_SFC ==2) THEN - EHB2 = FV*VKC/LOG((2.+Z0H)/Z0H) - EHB2 = FV*VKC/(LOG((2.+Z0H)/Z0H)-FH2) - CQ2B = EHB2 - IF (EHB2.lt.1.E-5 ) THEN - T2MB = TGB - Q2B = QSFC - ELSE - T2MB = TGB - SHB/(RHOAIR*CPAIR) * 1./EHB2 - Q2B = QSFC - EVB/(LATHEA*RHOAIR)*(1./CQ2B + RSURF) - ENDIF - IF (IVGTYP == ISURBAN) Q2B = QSFC - END IF + RS = RS*CF -! update CH - CH = EHB + END SUBROUTINE STOMATA - END SUBROUTINE BARE_FLUX +!== begin canres =================================================================================== -!== begin ragrb ==================================================================================== + SUBROUTINE CANRES (parameters,PAR ,SFCTMP,RCSOIL ,EAH ,SFCPRS , & !in + RC ,PSN ,ILOC ,JLOC ) !out - SUBROUTINE RAGRB(ITER ,VAI ,RHOAIR ,HG ,TAH , & !in - ZPD ,Z0MG ,Z0HG ,HCAN ,UC , & !in - Z0H ,FV ,CWP ,VEGTYP ,MPE , & !in - TV ,MOZG ,FHG ,ILOC ,JLOC , & !inout - RAMG ,RAHG ,RAWG ,RB ) !out ! -------------------------------------------------------------------------------------------------- -! compute under-canopy aerodynamic resistance RAG and leaf boundary layer -! resistance RB +! calculate canopy resistance which depends on incoming solar radiation, +! air temperature, atmospheric water vapor pressure deficit at the +! lowest model level, and soil moisture (preferably unfrozen soil +! moisture rather than total) ! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: DLEAF, & ! VEGETATION DEPENDENT - GRAV, VKC, CPAIR ! MP CONSTANT +! source: Jarvis (1976), Noilhan and Planton (1989, MWR), Jacquemin and +! Noilhan (1990, BLM). Chen et al (1996, JGR, Vol 101(D3), 7251-7268), +! eqns 12-14 and table 2 of sec. 3.1.2 ! -------------------------------------------------------------------------------------------------- - IMPLICIT NONE +!niu USE module_Noahlsm_utility +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE ! -------------------------------------------------------------------------------------------------- ! inputs - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: ITER !iteration index - INTEGER, INTENT(IN) :: VEGTYP !vegetation physiology type - REAL, INTENT(IN) :: VAI !total LAI + stem area index, one sided - REAL, INTENT(IN) :: RHOAIR !density air (kg/m3) - REAL, INTENT(IN) :: HG !ground sensible heat flux (w/m2) - REAL, INTENT(IN) :: TV !vegetation temperature (k) - REAL, INTENT(IN) :: TAH !air temperature at height z0h+zpd (k) - REAL, INTENT(IN) :: ZPD !zero plane displacement (m) - REAL, INTENT(IN) :: Z0MG !roughness length, momentum, ground (m) - REAL, INTENT(IN) :: HCAN !canopy height (m) [note: hcan >= z0mg] - REAL, INTENT(IN) :: UC !wind speed at top of canopy (m/s) - REAL, INTENT(IN) :: Z0H !roughness length, sensible heat (m) - REAL, INTENT(IN) :: Z0HG !roughness length, sensible heat, ground (m) - REAL, INTENT(IN) :: FV !friction velocity (m/s) - REAL, INTENT(IN) :: CWP !canopy wind parameter - REAL, INTENT(IN) :: MPE !prevents overflow error if division by zero + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + REAL, INTENT(IN) :: PAR !par absorbed per unit sunlit lai (w/m2) + REAL, INTENT(IN) :: SFCTMP !canopy air temperature + REAL, INTENT(IN) :: SFCPRS !surface pressure (pa) + REAL, INTENT(IN) :: EAH !water vapor pressure (pa) + REAL, INTENT(IN) :: RCSOIL !soil moisture stress factor + +!outputs + + REAL, INTENT(OUT) :: RC !canopy resistance per unit LAI + REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umolco2/m2/s) + +!local + + REAL :: RCQ + REAL :: RCS + REAL :: RCT + REAL :: FF + REAL :: Q2 !water vapor mixing ratio (kg/kg) + REAL :: Q2SAT !saturation Q2 + REAL :: DQSDT2 !d(Q2SAT)/d(T) + +! RSMIN, RSMAX, TOPT, RGL, HS are canopy stress parameters set in REDPRM +! ---------------------------------------------------------------------- +! initialize canopy resistance multiplier terms. +! ---------------------------------------------------------------------- + RC = 0.0 + RCS = 0.0 + RCT = 0.0 + RCQ = 0.0 -! in & out +! compute Q2 and Q2SAT - REAL, INTENT(INOUT) :: MOZG !Monin-Obukhov stability parameter - REAL, INTENT(INOUT) :: FHG !stability correction + Q2 = 0.622 * EAH / (SFCPRS - 0.378 * EAH) !specific humidity [kg/kg] + Q2 = Q2 / (1.0 + Q2) !mixing ratio [kg/kg] -! outputs - REAL :: RAMG !aerodynamic resistance for momentum (s/m) - REAL :: RAHG !aerodynamic resistance for sensible heat (s/m) - REAL :: RAWG !aerodynamic resistance for water vapor (s/m) - REAL :: RB !bulk leaf boundary layer resistance (s/m) + CALL CALHUM(parameters,SFCTMP, SFCPRS, Q2SAT, DQSDT2) +! contribution due to incoming solar radiation - REAL :: KH !turbulent transfer coefficient, sensible heat, (m2/s) - REAL :: TMP1 !temporary calculation - REAL :: TMP2 !temporary calculation - REAL :: TMPRAH2 !temporary calculation for aerodynamic resistances - REAL :: TMPRB !temporary calculation for rb - real :: MOLG,FHGNEW,CWPC -! -------------------------------------------------------------------------------------------------- -! stability correction to below canopy resistance + FF = 2.0 * PAR / parameters%RGL + RCS = (FF + parameters%RSMIN / parameters%RSMAX) / (1.0+ FF) + RCS = MAX (RCS,0.0001) - MOZG = 0. - MOLG = 0. +! contribution due to air temperature - IF(ITER > 1) THEN - TMP1 = VKC * (GRAV/TAH) * HG/(RHOAIR*CPAIR) - IF (ABS(TMP1) .LE. MPE) TMP1 = MPE - MOLG = -1. * FV**3 / TMP1 - MOZG = MIN( (ZPD-Z0MG)/MOLG, 1.) - END IF + RCT = 1.0- 0.0016* ( (parameters%TOPT - SFCTMP)**2.0) + RCT = MAX (RCT,0.0001) - IF (MOZG < 0.) THEN - FHGNEW = (1. - 15.*MOZG)**(-0.25) - ELSE - FHGNEW = 1.+ 4.7*MOZG - ENDIF +! contribution due to vapor pressure deficit - IF (ITER == 1) THEN - FHG = FHGNEW - ELSE - FHG = 0.5 * (FHG+FHGNEW) - ENDIF + RCQ = 1.0/ (1.0+ parameters%HS * MAX(0.,Q2SAT-Q2)) + RCQ = MAX (RCQ,0.01) - CWPC = (CWP * VAI * HCAN * FHG)**0.5 -! CWPC = (CWP*FHG)**0.5 +! determine canopy resistance due to all factors - TMP1 = EXP( -CWPC*Z0HG/HCAN ) - TMP2 = EXP( -CWPC*(Z0H+ZPD)/HCAN ) - TMPRAH2 = HCAN*EXP(CWPC) / CWPC * (TMP1-TMP2) + RC = parameters%RSMIN / (RCS * RCT * RCQ * RCSOIL) + PSN = -999.99 ! PSN not applied for dynamic carbon -! aerodynamic resistances raw and rah between heights zpd+z0h and z0hg. + END SUBROUTINE CANRES - KH = MAX ( VKC*FV*(HCAN-ZPD), MPE ) - RAMG = 0. - RAHG = TMPRAH2 / KH - RAWG = RAHG +!== begin calhum =================================================================================== -! leaf boundary layer resistance + SUBROUTINE CALHUM(parameters,SFCTMP, SFCPRS, Q2SAT, DQSDT2) - TMPRB = CWPC*50. / (1. - EXP(-CWPC/2.)) - RB = TMPRB * SQRT(DLEAF/UC) -! RB = 200 + IMPLICIT NONE - END SUBROUTINE RAGRB + type (noahmp_parameters), intent(in) :: parameters + REAL, INTENT(IN) :: SFCTMP, SFCPRS + REAL, INTENT(OUT) :: Q2SAT, DQSDT2 + REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & + A23M4=A2*(A3-A4), E0=0.611, RV=461.0, & + EPSILON=0.622 + REAL :: ES, SFCPRSX -!== begin sfcdif1 ================================================================================== +! Q2SAT: saturated mixing ratio + ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) ) +! convert SFCPRS from Pa to KPa + SFCPRSX = SFCPRS*1.E-3 + Q2SAT = EPSILON * ES / (SFCPRSX-ES) +! convert from g/g to g/kg + Q2SAT = Q2SAT * 1.E3 +! Q2SAT is currently a 'mixing ratio' - SUBROUTINE SFCDIF1(ITER ,SFCTMP ,RHOAIR ,H ,QAIR , & !in - & ZLVL ,ZPD ,Z0M ,Z0H ,UR , & !in - & MPE ,ILOC ,JLOC , & !in - & MOZ ,MOZSGN ,FM ,FH ,FM2,FH2, & !inout - & CM ,CH ,FV ,CH2 ) !out -! ------------------------------------------------------------------------------------------------- -! computing surface drag coefficient CM for momentum and CH for heat -! ------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: GRAV, VKC, CPAIR ! MP CONSTANT -! ------------------------------------------------------------------------------------------------- - IMPLICIT NONE -! ------------------------------------------------------------------------------------------------- -! inputs - - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: ITER !iteration index - REAL, INTENT(IN) :: SFCTMP !temperature at reference height (k) - REAL, INTENT(IN) :: RHOAIR !density air (kg/m**3) - REAL, INTENT(IN) :: H !sensible heat flux (w/m2) [+ to atm] - REAL, INTENT(IN) :: QAIR !specific humidity at reference height (kg/kg) - REAL, INTENT(IN) :: ZLVL !reference height (m) - REAL, INTENT(IN) :: ZPD !zero plane displacement (m) - REAL, INTENT(IN) :: Z0H !roughness length, sensible heat, ground (m) - REAL, INTENT(IN) :: Z0M !roughness length, momentum, ground (m) - REAL, INTENT(IN) :: UR !wind speed (m/s) - REAL, INTENT(IN) :: MPE !prevents overflow error if division by zero -! in & out +! DQSDT2 is calculated assuming Q2SAT is a specific humidity + DQSDT2=(Q2SAT/(1+Q2SAT))*A23M4/(SFCTMP-A4)**2 - INTEGER, INTENT(INOUT) :: MOZSGN !number of times moz changes sign - REAL, INTENT(INOUT) :: MOZ !Monin-Obukhov stability (z/L) - REAL, INTENT(INOUT) :: FM !momentum stability correction, weighted by prior iters - REAL, INTENT(INOUT) :: FH !sen heat stability correction, weighted by prior iters - REAL, INTENT(INOUT) :: FM2 !sen heat stability correction, weighted by prior iters - REAL, INTENT(INOUT) :: FH2 !sen heat stability correction, weighted by prior iters +! DG Q2SAT needs to be in g/g when returned for SFLX + Q2SAT = Q2SAT / 1.E3 -! outputs + END SUBROUTINE CALHUM - REAL, INTENT(OUT) :: CM !drag coefficient for momentum - REAL, INTENT(OUT) :: CH !drag coefficient for heat - REAL, INTENT(OUT) :: FV !friction velocity (m/s) - REAL, INTENT(OUT) :: CH2 !drag coefficient for heat +!== begin tsnosoi ================================================================================== -! locals - REAL :: MOL !Monin-Obukhov length (m) - REAL :: TMPCM !temporary calculation for CM - REAL :: TMPCH !temporary calculation for CH - REAL :: FMNEW !stability correction factor, momentum, for current moz - REAL :: FHNEW !stability correction factor, sen heat, for current moz - REAL :: MOZOLD !Monin-Obukhov stability parameter from prior iteration - REAL :: TMP1,TMP2,TMP3,TMP4,TMP5 !temporary calculation - REAL :: TVIR !temporary virtual temperature (k) - REAL :: MOZ2 !2/L - REAL :: TMPCM2 !temporary calculation for CM2 - REAL :: TMPCH2 !temporary calculation for CH2 - REAL :: FM2NEW !stability correction factor, momentum, for current moz - REAL :: FH2NEW !stability correction factor, sen heat, for current moz - REAL :: TMP12,TMP22,TMP32 !temporary calculation + SUBROUTINE TSNOSOI (parameters,ICE ,NSOIL ,NSNOW ,ISNOW ,IST , & !in + TBOT ,ZSNSO ,SSOIL ,DF ,HCPCT , & !in + SAG ,DT ,SNOWH ,DZSNSO , & !in + TG ,ILOC ,JLOC , & !in + STC ) !inout +! -------------------------------------------------------------------------------------------------- +! Compute snow (up to 3L) and soil (4L) temperature. Note that snow temperatures +! during melting season may exceed melting point (TFRZ) but later in PHASECHANGE +! subroutine the snow temperatures are reset to TFRZ for melting snow. +! -------------------------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------------------------- +!input - REAL :: CMFM, CHFH, CM2FM2, CH2FH2 -! ------------------------------------------------------------------------------------------------- -! Monin-Obukhov stability parameter moz for next iteration + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + INTEGER, INTENT(IN) :: ICE ! + INTEGER, INTENT(IN) :: NSOIL !no of soil layers (4) + INTEGER, INTENT(IN) :: NSNOW !maximum no of snow layers (3) + INTEGER, INTENT(IN) :: ISNOW !actual no of snow layers + INTEGER, INTENT(IN) :: IST !surface type - MOZOLD = MOZ - - IF(ZLVL <= ZPD) THEN - write(*,*) 'critical problem: ZLVL <= ZPD; model stops' - call wrf_error_fatal("STOP in Noah-MP") - ENDIF + REAL, INTENT(IN) :: DT !time step (s) + REAL, INTENT(IN) :: TBOT ! + REAL, INTENT(IN) :: SSOIL !ground heat flux (w/m2) + REAL, INTENT(IN) :: SAG !solar rad. absorbed by ground (w/m2) + REAL, INTENT(IN) :: SNOWH !snow depth (m) + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !layer-bot. depth from snow surf.(m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness (m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT !heat capacity (J/m3/k) - TMPCM = LOG((ZLVL-ZPD) / Z0M) - TMPCH = LOG((ZLVL-ZPD) / Z0H) - TMPCM2 = LOG((2.0 + Z0M) / Z0M) - TMPCH2 = LOG((2.0 + Z0H) / Z0H) +!input and output - IF(ITER == 1) THEN - FV = 0.0 - MOZ = 0.0 - MOL = 0.0 - MOZ2 = 0.0 - ELSE - TVIR = (1. + 0.61*QAIR) * SFCTMP - TMP1 = VKC * (GRAV/TVIR) * H/(RHOAIR*CPAIR) - IF (ABS(TMP1) .LE. MPE) TMP1 = MPE - MOL = -1. * FV**3 / TMP1 - MOZ = MIN( (ZLVL-ZPD)/MOL, 1.) - MOZ2 = MIN( (2.0 + Z0H)/MOL, 1.) - ENDIF + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC -! accumulate number of times moz changes sign. +!local - IF (MOZOLD*MOZ .LT. 0.) MOZSGN = MOZSGN+1 - IF (MOZSGN .GE. 2) THEN - MOZ = 0. - FM = 0. - FH = 0. - MOZ2 = 0. - FM2 = 0. - FH2 = 0. - ENDIF + INTEGER :: IZ + REAL :: ZBOTSNO !ZBOT from snow surface + REAL, DIMENSION(-NSNOW+1:NSOIL) :: AI, BI, CI, RHSTS + REAL :: EFLXB !energy influx from soil bottom (w/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL) :: PHI !light through water (w/m2) -! evaluate stability-dependent variables using moz from prior iteration - IF (MOZ .LT. 0.) THEN - TMP1 = (1. - 16.*MOZ)**0.25 - TMP2 = LOG((1.+TMP1*TMP1)/2.) - TMP3 = LOG((1.+TMP1)/2.) - FMNEW = 2.*TMP3 + TMP2 - 2.*ATAN(TMP1) + 1.5707963 - FHNEW = 2*TMP2 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: TBEG + REAL :: ERR_EST !heat storage error (w/m2) + REAL :: SSOIL2 !ground heat flux (w/m2) (for energy check) + REAL :: EFLXB2 !heat flux from the bottom (w/m2) (for energy check) + character(len=256) :: message +! ---------------------------------------------------------------------- +! compute solar penetration through water, needs more work -! 2-meter - TMP12 = (1. - 16.*MOZ2)**0.25 - TMP22 = LOG((1.+TMP12*TMP12)/2.) - TMP32 = LOG((1.+TMP12)/2.) - FM2NEW = 2.*TMP32 + TMP22 - 2.*ATAN(TMP12) + 1.5707963 - FH2NEW = 2*TMP22 - ELSE - FMNEW = -5.*MOZ - FHNEW = FMNEW - FM2NEW = -5.*MOZ2 - FH2NEW = FM2NEW - ENDIF + PHI(ISNOW+1:NSOIL) = 0. -! except for first iteration, weight stability factors for previous -! iteration to help avoid flip-flops from one iteration to the next +! adjust ZBOT from soil surface to ZBOTSNO from snow surface - IF (ITER == 1) THEN - FM = FMNEW - FH = FHNEW - FM2 = FM2NEW - FH2 = FH2NEW - ELSE - FM = 0.5 * (FM+FMNEW) - FH = 0.5 * (FH+FHNEW) - FM2 = 0.5 * (FM2+FM2NEW) - FH2 = 0.5 * (FH2+FH2NEW) - ENDIF + ZBOTSNO = parameters%ZBOT - SNOWH !from snow surface + +! snow/soil heat storage for energy balance check + + DO IZ = ISNOW+1, NSOIL + TBEG(IZ) = STC(IZ) + ENDDO -! exchange coefficients +! compute soil temperatures - FH = MIN(FH,0.9*TMPCH) - FM = MIN(FM,0.9*TMPCM) - FH2 = MIN(FH2,0.9*TMPCH2) - FM2 = MIN(FM2,0.9*TMPCM2) + CALL HRT (parameters,NSNOW ,NSOIL ,ISNOW ,ZSNSO , & + STC ,TBOT ,ZBOTSNO ,DT , & + DF ,HCPCT ,SSOIL ,PHI , & + AI ,BI ,CI ,RHSTS , & + EFLXB ) - CMFM = TMPCM-FM - CHFH = TMPCH-FH - CM2FM2 = TMPCM2-FM2 - CH2FH2 = TMPCH2-FH2 - IF(ABS(CMFM) <= MPE) CMFM = MPE - IF(ABS(CHFH) <= MPE) CHFH = MPE - IF(ABS(CM2FM2) <= MPE) CM2FM2 = MPE - IF(ABS(CH2FH2) <= MPE) CH2FH2 = MPE - CM = VKC*VKC/(CMFM*CMFM) - CH = VKC*VKC/(CMFM*CHFH) - CH2 = VKC*VKC/(CM2FM2*CH2FH2) - -! friction velocity + CALL HSTEP (parameters,NSNOW ,NSOIL ,ISNOW ,DT , & + AI ,BI ,CI ,RHSTS , & + STC ) - FV = UR * SQRT(CM) - CH2 = VKC*FV/CH2FH2 +! update ground heat flux just for energy check, but not for final output +! otherwise, it would break the surface energy balance - END SUBROUTINE SFCDIF1 + IF(OPT_TBOT == 1) THEN + EFLXB2 = 0. + ELSE IF(OPT_TBOT == 2) THEN + EFLXB2 = DF(NSOIL)*(TBOT-STC(NSOIL)) / & + (0.5*(ZSNSO(NSOIL-1)+ZSNSO(NSOIL)) - ZBOTSNO) + END IF -!== begin sfcdif2 ================================================================================== + ! Skip the energy balance check for now, until we can make it work + ! right for small time steps. + return - SUBROUTINE SFCDIF2(ITER ,Z0 ,THZ0 ,THLM ,SFCSPD , & !in - ZLM ,ILOC ,JLOC , & !in - AKMS ,AKHS ,RLMO ,WSTAR2 , & !in - USTAR ) !out +! energy balance check -! ------------------------------------------------------------------------------------------------- -! SUBROUTINE SFCDIF (renamed SFCDIF_off to avoid clash with Eta PBL) -! ------------------------------------------------------------------------------------------------- -! CALCULATE SURFACE LAYER EXCHANGE COEFFICIENTS VIA ITERATIVE PROCESS. -! SEE CHEN ET AL (1997, BLM) -! ------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: CZIL, & ! GENPARM DEPENDENT - GRAV ! MP CONSTANT -! ---------------------------------------------------------------------- - IMPLICIT NONE - INTEGER, INTENT(IN) :: ILOC - INTEGER, INTENT(IN) :: JLOC - INTEGER, INTENT(IN) :: ITER - REAL, INTENT(IN) :: ZLM, Z0, THZ0, THLM, SFCSPD - REAL, intent(INOUT) :: AKMS - REAL, intent(INOUT) :: AKHS - REAL, intent(INOUT) :: RLMO - REAL, intent(INOUT) :: WSTAR2 - REAL, intent(OUT) :: USTAR + ERR_EST = 0.0 + DO IZ = ISNOW+1, NSOIL + ERR_EST = ERR_EST + (STC(IZ)-TBEG(IZ)) * DZSNSO(IZ) * HCPCT(IZ) / DT + ENDDO - REAL ZZ, PSLMU, PSLMS, PSLHU, PSLHS - REAL XX, PSPMU, YY, PSPMS, PSPHU, PSPHS - REAL ZILFC, ZU, ZT, RDZ, CXCH - REAL DTHV, DU2, BTGH, ZSLU, ZSLT, RLOGU, RLOGT - REAL ZETALT, ZETALU, ZETAU, ZETAT, XLU4, XLT4, XU4, XT4 + if (OPT_STC == 1 .OR. OPT_STC == 3) THEN ! semi-implicit + ERR_EST = ERR_EST - (SSOIL +EFLXB) + ELSE ! full-implicit + SSOIL2 = DF(ISNOW+1)*(TG-STC(ISNOW+1))/(0.5*DZSNSO(ISNOW+1)) !M. Barlage + ERR_EST = ERR_EST - (SSOIL2+EFLXB2) + ENDIF - REAL XLU, XLT, XU, XT, PSMZ, SIMM, PSHZ, SIMH, USTARK, RLMN, & - & RLMA + IF (ABS(ERR_EST) > 1.) THEN ! W/m2 + WRITE(message,*) 'TSNOSOI is losing(-)/gaining(+) false energy',ERR_EST,' W/m2' + call wrf_message(trim(message)) + WRITE(message,'(i6,1x,i6,1x,i3,F18.13,5F20.12)') & + ILOC, JLOC, IST,ERR_EST,SSOIL,SNOWH,TG,STC(ISNOW+1),EFLXB + call wrf_message(trim(message)) + !niu STOP + END IF - INTEGER ILECH, ITR + END SUBROUTINE TSNOSOI - INTEGER, PARAMETER :: ITRMX = 5 - REAL, PARAMETER :: WWST = 1.2 - REAL, PARAMETER :: WWST2 = WWST * WWST - REAL, PARAMETER :: VKRM = 0.40 - REAL, PARAMETER :: EXCM = 0.001 - REAL, PARAMETER :: BETA = 1.0 / 270.0 - REAL, PARAMETER :: BTG = BETA * GRAV - REAL, PARAMETER :: ELFC = VKRM * BTG - REAL, PARAMETER :: WOLD = 0.15 - REAL, PARAMETER :: WNEW = 1.0 - WOLD - REAL, PARAMETER :: PIHF = 3.14159265 / 2. - REAL, PARAMETER :: EPSU2 = 1.E-4 - REAL, PARAMETER :: EPSUST = 0.07 - REAL, PARAMETER :: EPSIT = 1.E-4 - REAL, PARAMETER :: EPSA = 1.E-8 - REAL, PARAMETER :: ZTMIN = -5.0 - REAL, PARAMETER :: ZTMAX = 1.0 - REAL, PARAMETER :: HPBL = 1000.0 - REAL, PARAMETER :: SQVISC = 258.2 - REAL, PARAMETER :: RIC = 0.183 - REAL, PARAMETER :: RRIC = 1.0 / RIC - REAL, PARAMETER :: FHNEU = 0.8 - REAL, PARAMETER :: RFC = 0.191 - REAL, PARAMETER :: RFAC = RIC / ( FHNEU * RFC * RFC ) +!== begin hrt ====================================================================================== + SUBROUTINE HRT (parameters,NSNOW ,NSOIL ,ISNOW ,ZSNSO , & + STC ,TBOT ,ZBOT ,DT , & + DF ,HCPCT ,SSOIL ,PHI , & + AI ,BI ,CI ,RHSTS , & + BOTFLX ) ! ---------------------------------------------------------------------- -! NOTE: THE TWO CODE BLOCKS BELOW DEFINE FUNCTIONS ! ---------------------------------------------------------------------- -! LECH'S SURFACE FUNCTIONS - PSLMU (ZZ)= -0.96* log (1.0-4.5* ZZ) - PSLMS (ZZ)= ZZ * RRIC -2.076* (1. -1./ (ZZ +1.)) - PSLHU (ZZ)= -0.96* log (1.0-4.5* ZZ) - PSLHS (ZZ)= ZZ * RFAC -2.076* (1. -1./ (ZZ +1.)) -! PAULSON'S SURFACE FUNCTIONS - PSPMU (XX)= -2.* log ( (XX +1.)*0.5) - log ( (XX * XX +1.)*0.5) & - & +2.* ATAN (XX) & - &- PIHF - PSPMS (YY)= 5.* YY - PSPHU (XX)= -2.* log ( (XX * XX +1.)*0.5) - PSPHS (YY)= 5.* YY - -! THIS ROUTINE SFCDIF CAN HANDLE BOTH OVER OPEN WATER (SEA, OCEAN) AND -! OVER SOLID SURFACE (LAND, SEA-ICE). +! calculate the right hand side of the time tendency term of the soil +! thermal diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. ! ---------------------------------------------------------------------- -! ZTFC: RATIO OF ZOH/ZOM LESS OR EQUAL THAN 1 -! C......ZTFC=0.1 -! CZIL: CONSTANT C IN Zilitinkevich, S. S.1995,:NOTE ABOUT ZT + IMPLICIT NONE ! ---------------------------------------------------------------------- - ILECH = 0 +! input -! ---------------------------------------------------------------------- - ZILFC = - CZIL * VKRM * SQVISC - ZU = Z0 - RDZ = 1./ ZLM - CXCH = EXCM * RDZ - DTHV = THLM - THZ0 + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL !no of soil layers (4) + INTEGER, INTENT(IN) :: NSNOW !maximum no of snow layers (3) + INTEGER, INTENT(IN) :: ISNOW !actual no of snow layers + REAL, INTENT(IN) :: TBOT !bottom soil temp. at ZBOT (k) + REAL, INTENT(IN) :: ZBOT !depth of lower boundary condition (m) + !from soil surface not snow surface + REAL, INTENT(IN) :: DT !time step (s) + REAL, INTENT(IN) :: SSOIL !ground heat flux (w/m2) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !depth of layer-bottom of snow/soil (m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature (k) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity [w/m/k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT !heat capacity [j/m3/k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: PHI !light through water (w/m2) -! BELJARS CORRECTION OF USTAR - DU2 = MAX (SFCSPD * SFCSPD,EPSU2) - BTGH = BTG * HPBL +! output - IF(ITER == 1) THEN - IF (BTGH * AKHS * DTHV .ne. 0.0) THEN - WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) - ELSE - WSTAR2 = 0.0 - END IF - USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) - RLMO = ELFC * AKHS * DTHV / USTAR **3 - END IF - -! ZILITINKEVITCH APPROACH FOR ZT - ZT = MAX(1.E-6,EXP (ZILFC * SQRT (USTAR * Z0))* Z0) - ZSLU = ZLM + ZU - ZSLT = ZLM + ZT - RLOGU = log (ZSLU / ZU) - RLOGT = log (ZSLT / ZT) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: RHSTS !right-hand side of the matrix + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: AI !left-hand side coefficient + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: BI !left-hand side coefficient + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: CI !left-hand side coefficient + REAL, INTENT(OUT) :: BOTFLX !energy influx from soil bottom (w/m2) +! local + + INTEGER :: K + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DDZ + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DZ + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DENOM + REAL, DIMENSION(-NSNOW+1:NSOIL) :: DTSDZ + REAL, DIMENSION(-NSNOW+1:NSOIL) :: EFLUX + REAL :: TEMP1 ! ---------------------------------------------------------------------- -! 1./MONIN-OBUKKHOV LENGTH-SCALE -! ---------------------------------------------------------------------- - ZETALT = MAX (ZSLT * RLMO,ZTMIN) - RLMO = ZETALT / ZSLT - ZETALU = ZSLU * RLMO - ZETAU = ZU * RLMO - ZETAT = ZT * RLMO - IF (ILECH .eq. 0) THEN - IF (RLMO .lt. 0.)THEN - XLU4 = 1. -16.* ZETALU - XLT4 = 1. -16.* ZETALT - XU4 = 1. -16.* ZETAU - XT4 = 1. -16.* ZETAT - XLU = SQRT (SQRT (XLU4)) - XLT = SQRT (SQRT (XLT4)) - XU = SQRT (SQRT (XU4)) + DO K = ISNOW+1, NSOIL + IF (K == ISNOW+1) THEN + DENOM(K) = - ZSNSO(K) * HCPCT(K) + TEMP1 = - ZSNSO(K+1) + DDZ(K) = 2.0 / TEMP1 + DTSDZ(K) = 2.0 * (STC(K) - STC(K+1)) / TEMP1 + EFLUX(K) = DF(K) * DTSDZ(K) - SSOIL - PHI(K) + ELSE IF (K < NSOIL) THEN + DENOM(K) = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K) + TEMP1 = ZSNSO(K-1) - ZSNSO(K+1) + DDZ(K) = 2.0 / TEMP1 + DTSDZ(K) = 2.0 * (STC(K) - STC(K+1)) / TEMP1 + EFLUX(K) = (DF(K)*DTSDZ(K) - DF(K-1)*DTSDZ(K-1)) - PHI(K) + ELSE IF (K == NSOIL) THEN + DENOM(K) = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K) + TEMP1 = ZSNSO(K-1) - ZSNSO(K) + IF(OPT_TBOT == 1) THEN + BOTFLX = 0. + END IF + IF(OPT_TBOT == 2) THEN + DTSDZ(K) = (STC(K) - TBOT) / ( 0.5*(ZSNSO(K-1)+ZSNSO(K)) - ZBOT) + BOTFLX = -DF(K) * DTSDZ(K) + END IF + EFLUX(K) = (-BOTFLX - DF(K-1)*DTSDZ(K-1) ) - PHI(K) + END IF + END DO + + DO K = ISNOW+1, NSOIL + IF (K == ISNOW+1) THEN + AI(K) = 0.0 + CI(K) = - DF(K) * DDZ(K) / DENOM(K) + IF (OPT_STC == 1 .OR. OPT_STC == 3 ) THEN + BI(K) = - CI(K) + END IF + IF (OPT_STC == 2) THEN + BI(K) = - CI(K) + DF(K)/(0.5*ZSNSO(K)*ZSNSO(K)*HCPCT(K)) + END IF + ELSE IF (K < NSOIL) THEN + AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) + CI(K) = - DF(K ) * DDZ(K ) / DENOM(K) + BI(K) = - (AI(K) + CI (K)) + ELSE IF (K == NSOIL) THEN + AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) + CI(K) = 0.0 + BI(K) = - (AI(K) + CI(K)) + END IF + RHSTS(K) = EFLUX(K)/ (-DENOM(K)) + END DO - XT = SQRT (SQRT (XT4)) - PSMZ = PSPMU (XU) - SIMM = PSPMU (XLU) - PSMZ + RLOGU - PSHZ = PSPHU (XT) - SIMH = PSPHU (XLT) - PSHZ + RLOGT - ELSE - ZETALU = MIN (ZETALU,ZTMAX) - ZETALT = MIN (ZETALT,ZTMAX) - PSMZ = PSPMS (ZETAU) - SIMM = PSPMS (ZETALU) - PSMZ + RLOGU - PSHZ = PSPHS (ZETAT) - SIMH = PSPHS (ZETALT) - PSHZ + RLOGT - END IF -! ---------------------------------------------------------------------- -! LECH'S FUNCTIONS -! ---------------------------------------------------------------------- - ELSE - IF (RLMO .lt. 0.)THEN - PSMZ = PSLMU (ZETAU) - SIMM = PSLMU (ZETALU) - PSMZ + RLOGU - PSHZ = PSLHU (ZETAT) - SIMH = PSLHU (ZETALT) - PSHZ + RLOGT - ELSE - ZETALU = MIN (ZETALU,ZTMAX) - ZETALT = MIN (ZETALT,ZTMAX) - PSMZ = PSLMS (ZETAU) - SIMM = PSLMS (ZETALU) - PSMZ + RLOGU - PSHZ = PSLHS (ZETAT) - SIMH = PSLHS (ZETALT) - PSHZ + RLOGT - END IF -! ---------------------------------------------------------------------- - END IF + END SUBROUTINE HRT +!== begin hstep ==================================================================================== + + SUBROUTINE HSTEP (parameters,NSNOW ,NSOIL ,ISNOW ,DT , & + AI ,BI ,CI ,RHSTS , & + STC ) ! ---------------------------------------------------------------------- -! BELJAARS CORRECTION FOR USTAR +! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. ! ---------------------------------------------------------------------- - USTAR = MAX (SQRT (AKMS * SQRT (DU2+ WSTAR2)),EPSUST) + implicit none +! ---------------------------------------------------------------------- +! input -! ZILITINKEVITCH FIX FOR ZT - ZT = MAX(1.E-6,EXP (ZILFC * SQRT (USTAR * Z0))* Z0) - ZSLT = ZLM + ZT -!----------------------------------------------------------------------- - RLOGT = log (ZSLT / ZT) - USTARK = USTAR * VKRM - AKMS = MAX (USTARK / SIMM,CXCH) -!----------------------------------------------------------------------- -! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO -!----------------------------------------------------------------------- - AKHS = MAX (USTARK / SIMH,CXCH) + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL + INTEGER, INTENT(IN) :: NSNOW + INTEGER, INTENT(IN) :: ISNOW + REAL, INTENT(IN) :: DT - IF (BTGH * AKHS * DTHV .ne. 0.0) THEN - WSTAR2 = WWST2* ABS (BTGH * AKHS * DTHV)** (2./3.) - ELSE - WSTAR2 = 0.0 - END IF -!----------------------------------------------------------------------- - RLMN = ELFC * AKHS * DTHV / USTAR **3 -!----------------------------------------------------------------------- -! IF(ABS((RLMN-RLMO)/RLMA).LT.EPSIT) GO TO 110 -!----------------------------------------------------------------------- - RLMA = RLMO * WOLD+ RLMN * WNEW -!----------------------------------------------------------------------- - RLMO = RLMA +! output & input + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: RHSTS + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: AI + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: BI + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: CI + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC -! write(*,'(a20,10f15.6)')'SFCDIF: RLMO=',RLMO,RLMN,ELFC , AKHS , DTHV , USTAR -! END DO +! local + INTEGER :: K + REAL, DIMENSION(-NSNOW+1:NSOIL) :: RHSTSIN + REAL, DIMENSION(-NSNOW+1:NSOIL) :: CIIN ! ---------------------------------------------------------------------- - END SUBROUTINE SFCDIF2 -!== begin esat ===================================================================================== + DO K = ISNOW+1,NSOIL + RHSTS(K) = RHSTS(K) * DT + AI(K) = AI(K) * DT + BI(K) = 1. + BI(K) * DT + CI(K) = CI(K) * DT + END DO - SUBROUTINE ESAT(T, ESW, ESI, DESW, DESI) -!--------------------------------------------------------------------------------------------------- -! use polynomials to calculate saturation vapor pressure and derivative with -! respect to temperature: over water when t > 0 c and over ice when t <= 0 c - IMPLICIT NONE -!--------------------------------------------------------------------------------------------------- -! in +! copy values for input variables before call to rosr12 - REAL, intent(in) :: T !temperature + DO K = ISNOW+1,NSOIL + RHSTSIN(K) = RHSTS(K) + CIIN(K) = CI(K) + END DO -!out +! solve the tri-diagonal matrix equation - REAL, intent(out) :: ESW !saturation vapor pressure over water (pa) - REAL, intent(out) :: ESI !saturation vapor pressure over ice (pa) - REAL, intent(out) :: DESW !d(esat)/dt over water (pa/K) - REAL, intent(out) :: DESI !d(esat)/dt over ice (pa/K) + CALL ROSR12 (CI,AI,BI,CIIN,RHSTSIN,RHSTS,ISNOW+1,NSOIL,NSNOW) -! local +! update snow & soil temperature - REAL :: A0,A1,A2,A3,A4,A5,A6 !coefficients for esat over water - REAL :: B0,B1,B2,B3,B4,B5,B6 !coefficients for esat over ice - REAL :: C0,C1,C2,C3,C4,C5,C6 !coefficients for dsat over water - REAL :: D0,D1,D2,D3,D4,D5,D6 !coefficients for dsat over ice + DO K = ISNOW+1,NSOIL + STC (K) = STC (K) + CI (K) + END DO - PARAMETER (A0=6.107799961 , A1=4.436518521E-01, & - A2=1.428945805E-02, A3=2.650648471E-04, & - A4=3.031240396E-06, A5=2.034080948E-08, & - A6=6.136820929E-11) + END SUBROUTINE HSTEP - PARAMETER (B0=6.109177956 , B1=5.034698970E-01, & - B2=1.886013408E-02, B3=4.176223716E-04, & - B4=5.824720280E-06, B5=4.838803174E-08, & - B6=1.838826904E-10) +!== begin rosr12 =================================================================================== - PARAMETER (C0= 4.438099984E-01, C1=2.857002636E-02, & - C2= 7.938054040E-04, C3=1.215215065E-05, & - C4= 1.036561403E-07, C5=3.532421810e-10, & - C6=-7.090244804E-13) + SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NTOP,NSOIL,NSNOW) +! ---------------------------------------------------------------------- +! SUBROUTINE ROSR12 +! ---------------------------------------------------------------------- +! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: +! ### ### ### ### ### ### +! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # +! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # +! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # +! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # +! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # +! # . . # # . # = # . # +! # . . # # . # # . # +! # . . # # . # # . # +! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# +! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# +! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # +! ### ### ### ### ### ### +! ---------------------------------------------------------------------- + IMPLICIT NONE - PARAMETER (D0=5.030305237E-01, D1=3.773255020E-02, & - D2=1.267995369E-03, D3=2.477563108E-05, & - D4=3.005693132E-07, D5=2.158542548E-09, & - D6=7.131097725E-12) + INTEGER, INTENT(IN) :: NTOP + INTEGER, INTENT(IN) :: NSOIL,NSNOW + INTEGER :: K, KK - ESW = 100.*(A0+T*(A1+T*(A2+T*(A3+T*(A4+T*(A5+T*A6)))))) - ESI = 100.*(B0+T*(B1+T*(B2+T*(B3+T*(B4+T*(B5+T*B6)))))) - DESW = 100.*(C0+T*(C1+T*(C2+T*(C3+T*(C4+T*(C5+T*C6)))))) - DESI = 100.*(D0+T*(D1+T*(D2+T*(D3+T*(D4+T*(D5+T*D6)))))) + REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(IN):: A, B, D + REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(INOUT):: C,P,DELTA - END SUBROUTINE ESAT +! ---------------------------------------------------------------------- +! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + C (NSOIL) = 0.0 + P (NTOP) = - C (NTOP) / B (NTOP) +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR THE 1ST SOIL LAYER +! ---------------------------------------------------------------------- + DELTA (NTOP) = D (NTOP) / B (NTOP) +! ---------------------------------------------------------------------- +! SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = NTOP+1,NSOIL + P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) ) + DELTA (K) = (D (K) - A (K)* DELTA (K -1))* (1.0/ (B (K) + A (K)& + * P (K -1))) + END DO +! ---------------------------------------------------------------------- +! SET P TO DELTA FOR LOWEST SOIL LAYER +! ---------------------------------------------------------------------- + P (NSOIL) = DELTA (NSOIL) +! ---------------------------------------------------------------------- +! ADJUST P FOR SOIL LAYERS 2 THRU NSOIL +! ---------------------------------------------------------------------- + DO K = NTOP+1,NSOIL + KK = NSOIL - K + (NTOP-1) + 1 + P (KK) = P (KK) * P (KK +1) + DELTA (KK) + END DO +! ---------------------------------------------------------------------- + END SUBROUTINE ROSR12 -!== begin stomata ================================================================================== +!== begin phasechange ============================================================================== - SUBROUTINE STOMATA (VEGTYP ,MPE ,APAR ,FOLN ,ILOC , JLOC, & !in - TV ,EI ,EA ,SFCTMP ,SFCPRS , & !in - O2 ,CO2 ,IGS ,BTRAN ,RB , & !in - RS ,PSN ) !out -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: BP, MP, FOLNMX, QE25, KC25, KO25, & ! VEGETATION DEPENDENT - AKC, AKO, VCMX25, AVCMX, C3PSN, & ! VEGETATION DEPENDENT - TFRZ ! MP CONSTANT -! -------------------------------------------------------------------------------------------------- + SUBROUTINE PHASECHANGE (parameters,NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in + DZSNSO ,HCPCT ,IST ,ILOC ,JLOC , & !in + STC ,SNICE ,SNLIQ ,SNEQV ,SNOWH , & !inout + SMC ,SH2O , & !inout + QMELT ,IMELT ,PONDING ) !out +! ---------------------------------------------------------------------- +! melting/freezing of snow water and soil water +! ---------------------------------------------------------------------- IMPLICIT NONE -! -------------------------------------------------------------------------------------------------- -! input - INTEGER,INTENT(IN) :: ILOC !grid index - INTEGER,INTENT(IN) :: JLOC !grid index - INTEGER,INTENT(IN) :: VEGTYP !vegetation physiology type +! ---------------------------------------------------------------------- +! inputs - REAL, INTENT(IN) :: IGS !growing season index (0=off, 1=on) - REAL, INTENT(IN) :: MPE !prevents division by zero errors + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [=3] + INTEGER, INTENT(IN) :: NSOIL !No. of soil layers [=4] + INTEGER, INTENT(IN) :: ISNOW !actual no. of snow layers [<=3] + INTEGER, INTENT(IN) :: IST !surface type: 1->soil; 2->lake + REAL, INTENT(IN) :: DT !land model time step (sec) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: FACT !temporary + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT !heat capacity (J/m3/k) + +! outputs + INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT !phase change index + REAL, INTENT(OUT) :: QMELT !snowmelt rate [mm/s] + REAL, INTENT(OUT) :: PONDING!snowmelt when snow has no layer [mm] + +! inputs and outputs + + REAL, INTENT(INOUT) :: SNEQV + REAL, INTENT(INOUT) :: SNOWH + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil layer temperature [k] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !total soil water [m3/m3] + REAL, DIMENSION(-NSNOW+1:0) , INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1:0) , INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + +! local + + INTEGER :: J !do loop index + REAL, DIMENSION(-NSNOW+1:NSOIL) :: HM !energy residual [w/m2] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: XM !melting or freezing water [kg/m2] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: WMASS0 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: WICE0 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: WLIQ0 + REAL, DIMENSION(-NSNOW+1:NSOIL) :: MICE !soil/snow ice mass [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: MLIQ !soil/snow liquid water mass [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL) :: SUPERCOOL !supercooled water in soil (kg/m2) + REAL :: HEATR !energy residual or loss after melting/freezing + REAL :: TEMP1 !temporary variables [kg/m2] + REAL :: PROPOR + REAL :: SMP !frozen water potential (mm) + REAL :: XMF !total latent heat of phase change - REAL, INTENT(IN) :: TV !foliage temperature (k) - REAL, INTENT(IN) :: EI !vapor pressure inside leaf (sat vapor press at tv) (pa) - REAL, INTENT(IN) :: EA !vapor pressure of canopy air (pa) - REAL, INTENT(IN) :: APAR !par absorbed per unit lai (w/m2) - REAL, INTENT(IN) :: O2 !atmospheric o2 concentration (pa) - REAL, INTENT(IN) :: CO2 !atmospheric co2 concentration (pa) - REAL, INTENT(IN) :: SFCPRS !air pressure at reference height (pa) - REAL, INTENT(IN) :: SFCTMP !air temperature at reference height (k) - REAL, INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) - REAL, INTENT(IN) :: FOLN !foliage nitrogen concentration (%) - REAL, INTENT(IN) :: RB !boundary layer resistance (s/m) +! ---------------------------------------------------------------------- +! Initialization -! output - REAL, INTENT(OUT) :: RS !leaf stomatal resistance (s/m) - REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umol co2 /m2/ s) [always +] + QMELT = 0. + PONDING = 0. + XMF = 0. -! in&out - REAL :: RLB !boundary layer resistance (s m2 / umol) -! --------------------------------------------------------------------------------------------- + DO J = -NSNOW+1, NSOIL + SUPERCOOL(J) = 0.0 + END DO -! ------------------------ local variables ---------------------------------------------------- - INTEGER :: ITER !iteration index - INTEGER :: NITER !number of iterations + DO J = ISNOW+1,0 ! all layers + MICE(J) = SNICE(J) + MLIQ(J) = SNLIQ(J) + END DO - DATA NITER /3/ - SAVE NITER + DO J = 1, NSOIL ! soil + MLIQ(J) = SH2O(J) * DZSNSO(J) * 1000. + MICE(J) = (SMC(J) - SH2O(J)) * DZSNSO(J) * 1000. + END DO - REAL :: AB !used in statement functions - REAL :: BC !used in statement functions - REAL :: F1 !generic temperature response (statement function) - REAL :: F2 !generic temperature inhibition (statement function) - REAL :: TC !foliage temperature (degree Celsius) - REAL :: CS !co2 concentration at leaf surface (pa) - REAL :: KC !co2 Michaelis-Menten constant (pa) - REAL :: KO !o2 Michaelis-Menten constant (pa) - REAL :: A,B,C,Q !intermediate calculations for RS - REAL :: R1,R2 !roots for RS - REAL :: FNF !foliage nitrogen adjustment factor (0 to 1) - REAL :: PPF !absorb photosynthetic photon flux (umol photons/m2/s) - REAL :: WC !Rubisco limited photosynthesis (umol co2/m2/s) - REAL :: WJ !light limited photosynthesis (umol co2/m2/s) - REAL :: WE !export limited photosynthesis (umol co2/m2/s) - REAL :: CP !co2 compensation point (pa) - REAL :: CI !internal co2 (pa) - REAL :: AWC !intermediate calculation for wc - REAL :: VCMX !maximum rate of carbonylation (umol co2/m2/s) - REAL :: J !electron transport (umol co2/m2/s) - REAL :: CEA !constrain ea or else model blows up - REAL :: CF !s m2/umol -> s/m + DO J = ISNOW+1,NSOIL ! all layers + IMELT(J) = 0 + HM(J) = 0. + XM(J) = 0. + WICE0(J) = MICE(J) + WLIQ0(J) = MLIQ(J) + WMASS0(J) = MICE(J) + MLIQ(J) + ENDDO - F1(AB,BC) = AB**((BC-25.)/10.) - F2(AB) = 1. + EXP((-2.2E05+710.*(AB+273.16))/(8.314*(AB+273.16))) - REAL :: T -! --------------------------------------------------------------------------------------------- + if(ist == 1) then + DO J = 1,NSOIL + IF (OPT_FRZ == 1) THEN + IF(STC(J) < TFRZ) THEN + SMP = HFUS*(TFRZ-STC(J))/(GRAV*STC(J)) !(m) + SUPERCOOL(J) = parameters%SMCMAX(J)*(SMP/parameters%PSISAT(J))**(-1./parameters%BEXP(J)) + SUPERCOOL(J) = SUPERCOOL(J)*DZSNSO(J)*1000. !(mm) + END IF + END IF + IF (OPT_FRZ == 2) THEN + CALL FRH2O (parameters,J,SUPERCOOL(J),STC(J),SMC(J),SH2O(J)) + SUPERCOOL(J) = SUPERCOOL(J)*DZSNSO(J)*1000. !(mm) + END IF + ENDDO + end if -! initialize RS=RSMAX and PSN=0 because will only do calculations -! for APAR > 0, in which case RS <= RSMAX and PSN >= 0 + DO J = ISNOW+1,NSOIL + IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN !melting + IMELT(J) = 1 + ENDIF + IF (MLIQ(J) > SUPERCOOL(J) .AND. STC(J) < TFRZ) THEN + IMELT(J) = 2 + ENDIF - CF = SFCPRS/(8.314*SFCTMP)*1.e06 - RS = 1./BP * CF - PSN = 0. + ! If snow exists, but its thickness is not enough to create a layer + IF (ISNOW == 0 .AND. SNEQV > 0. .AND. J == 1) THEN + IF (STC(J) >= TFRZ) THEN + IMELT(J) = 1 + ENDIF + ENDIF + ENDDO - IF (APAR .LE. 0.) RETURN +! Calculate the energy surplus and loss for melting and freezing - FNF = MIN( FOLN/MAX(MPE,FOLNMX), 1.0 ) - TC = TV-TFRZ - PPF = 4.6*APAR - J = PPF*QE25 - KC = KC25 * F1(AKC,TC) - KO = KO25 * F1(AKO,TC) - AWC = KC * (1.+O2/KO) - CP = 0.5*KC/KO*O2*0.21 - VCMX = VCMX25 / F2(TC) * FNF * BTRAN * F1(AVCMX,TC) + DO J = ISNOW+1,NSOIL + IF (IMELT(J) > 0) THEN + HM(J) = (STC(J)-TFRZ)/FACT(J) + STC(J) = TFRZ + ENDIF -! first guess ci + IF (IMELT(J) == 1 .AND. HM(J) < 0.) THEN + HM(J) = 0. + IMELT(J) = 0 + ENDIF + IF (IMELT(J) == 2 .AND. HM(J) > 0.) THEN + HM(J) = 0. + IMELT(J) = 0 + ENDIF + XM(J) = HM(J)*DT/HFUS + ENDDO - CI = 0.7*CO2*C3PSN + 0.4*CO2*(1.-C3PSN) +! The rate of melting and freezing for snow without a layer, needs more work. -! rb: s/m -> s m**2 / umol + IF (ISNOW == 0 .AND. SNEQV > 0. .AND. XM(1) > 0.) THEN + TEMP1 = SNEQV + SNEQV = MAX(0.,TEMP1-XM(1)) + PROPOR = SNEQV/TEMP1 + SNOWH = MAX(0.,PROPOR * SNOWH) + HEATR = HM(1) - HFUS*(TEMP1-SNEQV)/DT + IF (HEATR > 0.) THEN + XM(1) = HEATR*DT/HFUS + HM(1) = HEATR + ELSE + XM(1) = 0. + HM(1) = 0. + ENDIF + QMELT = MAX(0.,(TEMP1-SNEQV))/DT + XMF = HFUS*QMELT + PONDING = TEMP1-SNEQV + ENDIF - RLB = RB/CF +! The rate of melting and freezing for snow and soil -! constrain ea + DO J = ISNOW+1,NSOIL + IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN - CEA = MAX(0.25*EI*C3PSN+0.40*EI*(1.-C3PSN), MIN(EA,EI) ) + HEATR = 0. + IF (XM(J) > 0.) THEN + MICE(J) = MAX(0., WICE0(J)-XM(J)) + HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT + ELSE IF (XM(J) < 0.) THEN + IF (J <= 0) THEN ! snow + MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J)) + ELSE ! soil + IF (WMASS0(J) < SUPERCOOL(J)) THEN + MICE(J) = 0. + ELSE + MICE(J) = MIN(WMASS0(J) - SUPERCOOL(J),WICE0(J)-XM(J)) + MICE(J) = MAX(MICE(J),0.0) + ENDIF + ENDIF + HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT + ENDIF -! ci iteration -!jref: C3PSN is equal to 1 for all veg types. - DO ITER = 1, NITER - WJ = MAX(CI-CP,0.)*J/(CI+2.*CP)*C3PSN + J*(1.-C3PSN) - WC = MAX(CI-CP,0.)*VCMX/(CI+AWC)*C3PSN + VCMX*(1.-C3PSN) - WE = 0.5*VCMX*C3PSN + 4000.*VCMX*CI/SFCPRS*(1.-C3PSN) - PSN = MIN(WJ,WC,WE) * IGS + MLIQ(J) = MAX(0.,WMASS0(J)-MICE(J)) - CS = MAX( CO2-1.37*RLB*SFCPRS*PSN, MPE ) - A = MP*PSN*SFCPRS*CEA / (CS*EI) + BP - B = ( MP*PSN*SFCPRS/CS + BP ) * RLB - 1. - C = -RLB - IF (B .GE. 0.) THEN - Q = -0.5*( B + SQRT(B*B-4.*A*C) ) - ELSE - Q = -0.5*( B - SQRT(B*B-4.*A*C) ) + IF (ABS(HEATR) > 0.) THEN + STC(J) = STC(J) + FACT(J)*HEATR + IF (J <= 0) THEN ! snow + IF (MLIQ(J)*MICE(J)>0.) STC(J) = TFRZ END IF - R1 = Q/A - R2 = C/Q - RS = MAX(R1,R2) - CI = MAX( CS-PSN*SFCPRS*1.65*RS, 0. ) - END DO + ENDIF -! rs, rb: s m**2 / umol -> s/m + XMF = XMF + HFUS * (WICE0(J)-MICE(J))/DT - RS = RS*CF + IF (J < 1) THEN + QMELT = QMELT + MAX(0.,(WICE0(J)-MICE(J)))/DT + ENDIF + ENDIF + ENDDO - END SUBROUTINE STOMATA + DO J = ISNOW+1,0 ! snow + SNLIQ(J) = MLIQ(J) + SNICE(J) = MICE(J) + END DO -!== begin canres =================================================================================== + DO J = 1, NSOIL ! soil + SH2O(J) = MLIQ(J) / (1000. * DZSNSO(J)) + SMC(J) = (MLIQ(J) + MICE(J)) / (1000. * DZSNSO(J)) + END DO + + END SUBROUTINE PHASECHANGE - SUBROUTINE CANRES (PAR ,SFCTMP,RCSOIL ,EAH ,SFCPRS , & !in - RC ,PSN ,ILOC ,JLOC ) !out +!== begin frh2o ==================================================================================== -! -------------------------------------------------------------------------------------------------- -! calculate canopy resistance which depends on incoming solar radiation, -! air temperature, atmospheric water vapor pressure deficit at the -! lowest model level, and soil moisture (preferably unfrozen soil -! moisture rather than total) -! -------------------------------------------------------------------------------------------------- -! source: Jarvis (1976), Noilhan and Planton (1989, MWR), Jacquemin and -! Noilhan (1990, BLM). Chen et al (1996, JGR, Vol 101(D3), 7251-7268), -! eqns 12-14 and table 2 of sec. 3.1.2 -! -------------------------------------------------------------------------------------------------- -!niu USE module_Noahlsm_utility -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: RGL, RSMIN, RSMAX, HS, TOPT ! VEGETATION DEPENDENT -! -------------------------------------------------------------------------------------------------- - IMPLICIT NONE -! -------------------------------------------------------------------------------------------------- -! inputs + SUBROUTINE FRH2O (parameters,ISOIL,FREE,TKELV,SMC,SH2O) + +! ---------------------------------------------------------------------- +! SUBROUTINE FRH2O +! ---------------------------------------------------------------------- +! CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT IF +! TEMPERATURE IS BELOW 273.15K (TFRZ). REQUIRES NEWTON-TYPE ITERATION +! TO SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF KOREN ET AL +! (1999, JGR, VOL 104(D16), 19569-19585). +! ---------------------------------------------------------------------- +! NEW VERSION (JUNE 2001): MUCH FASTER AND MORE ACCURATE NEWTON +! ITERATION ACHIEVED BY FIRST TAKING LOG OF EQN CITED ABOVE -- LESS THAN +! 4 (TYPICALLY 1 OR 2) ITERATIONS ACHIEVES CONVERGENCE. ALSO, EXPLICIT +! 1-STEP SOLUTION OPTION FOR SPECIAL CASE OF PARAMETER CK=0, WHICH +! REDUCES THE ORIGINAL IMPLICIT EQUATION TO A SIMPLER EXPLICIT FORM, +! KNOWN AS THE "FLERCHINGER EQN". IMPROVED HANDLING OF SOLUTION IN THE +! LIMIT OF FREEZING POINT TEMPERATURE TFRZ. +! ---------------------------------------------------------------------- +! INPUT: + +! TKELV.........TEMPERATURE (Kelvin) +! SMC...........TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC) +! SH2O..........LIQUID SOIL MOISTURE CONTENT (VOLUMETRIC) +! B.............SOIL TYPE "B" PARAMETER (FROM REDPRM) +! PSISAT........SATURATED SOIL MATRIC POTENTIAL (FROM REDPRM) - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - REAL, INTENT(IN) :: PAR !par absorbed per unit sunlit lai (w/m2) - REAL, INTENT(IN) :: SFCTMP !canopy air temperature - REAL, INTENT(IN) :: SFCPRS !surface pressure (pa) - REAL, INTENT(IN) :: EAH !water vapor pressure (pa) - REAL, INTENT(IN) :: RCSOIL !soil moisture stress factor +! OUTPUT: +! FREE..........SUPERCOOLED LIQUID WATER CONTENT [m3/m3] +! ---------------------------------------------------------------------- + IMPLICIT NONE + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: ISOIL + REAL, INTENT(IN) :: SH2O,SMC,TKELV + REAL, INTENT(OUT) :: FREE + REAL :: BX,DENOM,DF,DSWL,FK,SWL,SWLK + INTEGER :: NLOG,KCOUNT +! PARAMETER(CK = 0.0) + REAL, PARAMETER :: CK = 8.0, BLIM = 5.5, ERROR = 0.005, & + DICE = 920.0 + CHARACTER(LEN=80) :: message -!outputs +! ---------------------------------------------------------------------- +! LIMITS ON PARAMETER B: B < 5.5 (use parameter BLIM) +! SIMULATIONS SHOWED IF B > 5.5 UNFROZEN WATER CONTENT IS +! NON-REALISTICALLY HIGH AT VERY LOW TEMPERATURES. +! ---------------------------------------------------------------------- + BX = parameters%BEXP(ISOIL) +! ---------------------------------------------------------------------- +! INITIALIZING ITERATIONS COUNTER AND ITERATIVE SOLUTION FLAG. +! ---------------------------------------------------------------------- - REAL, INTENT(OUT) :: RC !canopy resistance per unit LAI - REAL, INTENT(OUT) :: PSN !foliage photosynthesis (umolco2/m2/s) + IF (parameters%BEXP(ISOIL) > BLIM) BX = BLIM + NLOG = 0 -!local +! ---------------------------------------------------------------------- +! IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (TFRZ), SH2O = SMC +! ---------------------------------------------------------------------- + KCOUNT = 0 + IF (TKELV > (TFRZ- 1.E-3)) THEN + FREE = SMC + ELSE - REAL :: RCQ - REAL :: RCS - REAL :: RCT - REAL :: FF - REAL :: Q2 !water vapor mixing ratio (kg/kg) - REAL :: Q2SAT !saturation Q2 - REAL :: DQSDT2 !d(Q2SAT)/d(T) +! ---------------------------------------------------------------------- +! OPTION 1: ITERATED SOLUTION IN KOREN ET AL, JGR, 1999, EQN 17 +! ---------------------------------------------------------------------- +! INITIAL GUESS FOR SWL (frozen content) +! ---------------------------------------------------------------------- + IF (CK /= 0.0) THEN + SWL = SMC - SH2O +! ---------------------------------------------------------------------- +! KEEP WITHIN BOUNDS. +! ---------------------------------------------------------------------- + IF (SWL > (SMC -0.02)) SWL = SMC -0.02 +! ---------------------------------------------------------------------- +! START OF ITERATIONS +! ---------------------------------------------------------------------- + IF (SWL < 0.) SWL = 0. +1001 Continue + IF (.NOT.( (NLOG < 10) .AND. (KCOUNT == 0))) goto 1002 + NLOG = NLOG +1 + DF = ALOG ( ( parameters%PSISAT(ISOIL) * GRAV / HFUS ) * ( ( 1. + CK * SWL )**2.) * & + ( parameters%SMCMAX(ISOIL) / (SMC - SWL) )** BX) - ALOG ( - ( & + TKELV - TFRZ)/ TKELV) + DENOM = 2. * CK / ( 1. + CK * SWL ) + BX / ( SMC - SWL ) + SWLK = SWL - DF / DENOM +! ---------------------------------------------------------------------- +! BOUNDS USEFUL FOR MATHEMATICAL SOLUTION. +! ---------------------------------------------------------------------- + IF (SWLK > (SMC -0.02)) SWLK = SMC - 0.02 + IF (SWLK < 0.) SWLK = 0. -! RSMIN, RSMAX, TOPT, RGL, HS are canopy stress parameters set in REDPRM ! ---------------------------------------------------------------------- -! initialize canopy resistance multiplier terms. +! MATHEMATICAL SOLUTION BOUNDS APPLIED. ! ---------------------------------------------------------------------- - RC = 0.0 - RCS = 0.0 - RCT = 0.0 - RCQ = 0.0 + DSWL = ABS (SWLK - SWL) +! IF MORE THAN 10 ITERATIONS, USE EXPLICIT METHOD (CK=0 APPROX.) +! WHEN DSWL LESS OR EQ. ERROR, NO MORE ITERATIONS REQUIRED. +! ---------------------------------------------------------------------- + SWL = SWLK + IF ( DSWL <= ERROR ) THEN + KCOUNT = KCOUNT +1 + END IF +! ---------------------------------------------------------------------- +! END OF ITERATIONS +! ---------------------------------------------------------------------- +! BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION. +! ---------------------------------------------------------------------- + goto 1001 +1002 continue + FREE = SMC - SWL + END IF +! ---------------------------------------------------------------------- +! END OPTION 1 +! ---------------------------------------------------------------------- +! ---------------------------------------------------------------------- +! OPTION 2: EXPLICIT SOLUTION FOR FLERCHINGER EQ. i.e. CK=0 +! IN KOREN ET AL., JGR, 1999, EQN 17 +! APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION +! ---------------------------------------------------------------------- + IF (KCOUNT == 0) THEN + write(message, '("Flerchinger used in NEW version. Iterations=", I6)') NLOG + call wrf_message(trim(message)) + FK = ( ( (HFUS / (GRAV * ( - parameters%PSISAT(ISOIL))))* & + ( (TKELV - TFRZ)/ TKELV))** ( -1/ BX))* parameters%SMCMAX(ISOIL) + IF (FK < 0.02) FK = 0.02 + FREE = MIN (FK, SMC) +! ---------------------------------------------------------------------- +! END OPTION 2 +! ---------------------------------------------------------------------- + END IF + END IF +! ---------------------------------------------------------------------- + END SUBROUTINE FRH2O +! ---------------------------------------------------------------------- +! ================================================================================================== +! **********************End of energy subroutines*********************** +! ================================================================================================== -! compute Q2 and Q2SAT +!== begin water ==================================================================================== - Q2 = 0.622 * EAH / (SFCPRS - 0.378 * EAH) !specific humidity [kg/kg] - Q2 = Q2 / (1.0 + Q2) !mixing ratio [kg/kg] + SUBROUTINE WATER (parameters,VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in + VV ,FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , & !in + ESAI ,SFCTMP ,QVAP ,QDEW ,ZSOIL ,BTRANI , & !in + FICEOLD,PONDING,TG ,IST ,FVEG ,ILOC ,JLOC ,SMCEQ , & !in + BDFALL ,FP ,RAIN ,SNOW, & !in MB/AN: v3.7 + QSNOW ,QRAIN ,SNOWHIN,LATHEAV,LATHEAG,frozen_canopy,frozen_ground, & !in MB + ISNOW ,CANLIQ ,CANICE ,TV ,SNOWH ,SNEQV , & !inout + SNICE ,SNLIQ ,STC ,ZSNSO ,SH2O ,SMC , & !inout + SICE ,ZWT ,WA ,WT ,DZSNSO ,WSLAKE , & !inout + SMCWTD ,DEEPRECH,RECH , & !inout + CMC ,ECAN ,ETRAN ,FWET ,RUNSRF ,RUNSUB , & !out + QIN ,QDIS ,PONDING1 ,PONDING2, & + QSNBOT & +#ifdef WRF_HYDRO + ,sfcheadrt & +#endif + ) !out +! ---------------------------------------------------------------------- +! Code history: +! Initial code: Guo-Yue Niu, Oct. 2007 +! ---------------------------------------------------------------------- + implicit none +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: VEGTYP !vegetation type + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER , INTENT(IN) :: IST !surface type 1-soil; 2-lake + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [1-melt; 2-freeze] + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: UU !u-direction wind speed [m/s] + REAL, INTENT(IN) :: VV !v-direction wind speed [m/s] + REAL, INTENT(IN) :: FCEV !canopy evaporation (w/m2) [+ to atm ] + REAL, INTENT(IN) :: FCTR !transpiration (w/m2) [+ to atm] + REAL, INTENT(IN) :: QPRECC !convective precipitation (mm/s) + REAL, INTENT(IN) :: QPRECL !large-scale precipitation (mm/s) + REAL, INTENT(IN) :: ELAI !leaf area index, after burying by snow + REAL, INTENT(IN) :: ESAI !stem area index, after burying by snow + REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] + REAL, INTENT(IN) :: QVAP !soil surface evaporation rate[mm/s] + REAL, INTENT(IN) :: QDEW !soil surface dew rate[mm/s] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil surface + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: BTRANI !soil water stress factor (0 to 1) + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD !ice fraction at last timestep +! REAL , INTENT(IN) :: PONDING ![mm] + REAL , INTENT(IN) :: TG !ground temperature (k) + REAL , INTENT(IN) :: FVEG !greeness vegetation fraction (-) + REAL , INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) ! MB/AN: v3.7 + REAL , INTENT(IN) :: FP !fraction of the gridcell that receives precipitation ! MB/AN: v3.7 + REAL , INTENT(IN) :: RAIN !rainfall (mm/s) ! MB/AN: v3.7 + REAL , INTENT(IN) :: SNOW !snowfall (mm/s) ! MB/AN: v3.7 + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] (used in m-m&f groundwater dynamics) + REAL , INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] + REAL , INTENT(IN) :: QRAIN !rain at ground srf (mm) [+] + REAL , INTENT(IN) :: SNOWHIN !snow depth increasing rate (m/s) - CALL CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) +! input/output + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) + REAL, INTENT(INOUT) :: CANICE !intercepted ice mass (mm) + REAL, INTENT(INOUT) :: TV !vegetation temperature (k) + REAL, INTENT(INOUT) :: SNOWH !snow height [m] + REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil layer temperature [k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !depth of snow/soil layer-bottom + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !snow/soil layer thickness [m] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water content [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice content [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !total soil water content [m3/m3] + REAL, INTENT(INOUT) :: ZWT !the depth to water table [m] + REAL, INTENT(INOUT) :: WA !water storage in aquifer [mm] + REAL, INTENT(INOUT) :: WT !water storage in aquifer + !+ stuarated soil [mm] + REAL, INTENT(INOUT) :: WSLAKE !water storage in lake (can be -) (mm) + REAL , INTENT(INOUT) :: PONDING ![mm] + REAL, INTENT(INOUT) :: SMCWTD !soil water content between bottom of the soil and water table [m3/m3] + REAL, INTENT(INOUT) :: DEEPRECH !recharge to or from the water table when deep [m] + REAL, INTENT(INOUT) :: RECH !recharge to or from the water table when shallow [m] (diagnostic) -! contribution due to incoming solar radiation +! output + REAL, INTENT(OUT) :: CMC !intercepted water per ground area (mm) + REAL, INTENT(OUT) :: ECAN !evap of intercepted water (mm/s) [+] + REAL, INTENT(OUT) :: ETRAN !transpiration rate (mm/s) [+] + REAL, INTENT(OUT) :: FWET !wetted/snowed fraction of canopy (-) + REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL, INTENT(OUT) :: RUNSUB !baseflow (sturation excess) [mm/s] + REAL, INTENT(OUT) :: QIN !groundwater recharge [mm/s] + REAL, INTENT(OUT) :: QDIS !groundwater discharge [mm/s] + REAL, INTENT(OUT) :: PONDING1 + REAL, INTENT(OUT) :: PONDING2 + REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] + REAL , INTENT(IN) :: LATHEAV !latent heat vap./sublimation (j/kg) + REAL , INTENT(IN) :: LATHEAG !latent heat vap./sublimation (j/kg) + LOGICAL , INTENT(IN) :: FROZEN_GROUND ! used to define latent heat pathway + LOGICAL , INTENT(IN) :: FROZEN_CANOPY ! used to define latent heat pathway - FF = 2.0 * PAR / RGL - RCS = (FF + RSMIN / RSMAX) / (1.0+ FF) - RCS = MAX (RCS,0.0001) -! contribution due to air temperature +! local + INTEGER :: IZ + REAL :: QINSUR !water input on soil surface [m/s] + REAL :: QSEVA !soil surface evap rate [mm/s] + REAL :: QSDEW !soil surface dew rate [mm/s] + REAL :: QSNFRO !snow surface frost rate[mm/s] + REAL :: QSNSUB !snow surface sublimation rate [mm/s] + REAL, DIMENSION( 1:NSOIL) :: ETRANI !transpiration rate (mm/s) [+] + REAL, DIMENSION( 1:NSOIL) :: WCND !hydraulic conductivity (m/s) + REAL :: QDRAIN !soil-bottom free drainage [mm/s] + REAL :: SNOFLOW !glacier flow [mm/s] + REAL :: FCRMAX !maximum of FCR (-) - RCT = 1.0- 0.0016* ( (TOPT - SFCTMP)**2.0) - RCT = MAX (RCT,0.0001) + REAL, PARAMETER :: WSLMAX = 5000. !maximum lake water storage (mm) -! contribution due to vapor pressure deficit +#ifdef WRF_HYDRO + REAL , INTENT(INOUT) :: sfcheadrt +#endif - RCQ = 1.0/ (1.0+ HS * MAX(0.,Q2SAT-Q2)) - RCQ = MAX (RCQ,0.01) +! ---------------------------------------------------------------------- +! initialize -! determine canopy resistance due to all factors + ETRANI(1:NSOIL) = 0. + SNOFLOW = 0. + RUNSUB = 0. + QINSUR = 0. - RC = RSMIN / (RCS * RCT * RCQ * RCSOIL) - PSN = -999.99 ! PSN not applied for dynamic carbon +! canopy-intercepted snowfall/rainfall, drips, and throughfall - END SUBROUTINE CANRES + CALL CANWATER (parameters,VEGTYP ,DT , & !in + FCEV ,FCTR ,ELAI , & !in + ESAI ,TG ,FVEG ,ILOC , JLOC, & !in + BDFALL ,FROZEN_CANOPY , & !in + CANLIQ ,CANICE ,TV , & !inout + CMC ,ECAN ,ETRAN , & !out + FWET ) !out -!== begin calhum =================================================================================== +! sublimation, frost, evaporation, and dew - SUBROUTINE CALHUM(SFCTMP, SFCPRS, Q2SAT, DQSDT2) + QSNSUB = 0. + IF (SNEQV > 0.) THEN + QSNSUB = MIN(QVAP, SNEQV/DT) + ENDIF + QSEVA = QVAP-QSNSUB - IMPLICIT NONE + QSNFRO = 0. + IF (SNEQV > 0.) THEN + QSNFRO = QDEW + ENDIF + QSDEW = QDEW - QSNFRO - REAL, INTENT(IN) :: SFCTMP, SFCPRS - REAL, INTENT(OUT) :: Q2SAT, DQSDT2 - REAL, PARAMETER :: A2=17.67,A3=273.15,A4=29.65, ELWV=2.501E6, & - A23M4=A2*(A3-A4), E0=0.611, RV=461.0, & - EPSILON=0.622 - REAL :: ES, SFCPRSX + CALL SNOWWATER (parameters,NSNOW ,NSOIL ,IMELT ,DT ,ZSOIL , & !in + & SFCTMP ,SNOWHIN,QSNOW ,QSNFRO ,QSNSUB , & !in + & QRAIN ,FICEOLD,ILOC ,JLOC , & !in + & ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout + & SH2O ,SICE ,STC ,ZSNSO ,DZSNSO , & !inout + & QSNBOT ,SNOFLOW,PONDING1 ,PONDING2) !out -! Q2SAT: saturated mixing ratio - ES = E0 * EXP ( ELWV/RV*(1./A3 - 1./SFCTMP) ) -! convert SFCPRS from Pa to KPa - SFCPRSX = SFCPRS*1.E-3 - Q2SAT = EPSILON * ES / (SFCPRSX-ES) -! convert from g/g to g/kg - Q2SAT = Q2SAT * 1.E3 -! Q2SAT is currently a 'mixing ratio' + IF(FROZEN_GROUND) THEN + SICE(1) = SICE(1) + (QSDEW-QSEVA)*DT/(DZSNSO(1)*1000.) + QSDEW = 0.0 + QSEVA = 0.0 + IF(SICE(1) < 0.) THEN + SH2O(1) = SH2O(1) + SICE(1) + SICE(1) = 0. + END IF + END IF -! DQSDT2 is calculated assuming Q2SAT is a specific humidity - DQSDT2=(Q2SAT/(1+Q2SAT))*A23M4/(SFCTMP-A4)**2 +! convert units (mm/s -> m/s) -! DG Q2SAT needs to be in g/g when returned for SFLX - Q2SAT = Q2SAT / 1.E3 + !PONDING: melting water from snow when there is no layer + QINSUR = (PONDING+PONDING1+PONDING2)/DT * 0.001 +! QINSUR = PONDING/DT * 0.001 - END SUBROUTINE CALHUM + IF(ISNOW == 0) THEN + QINSUR = QINSUR+(QSNBOT + QSDEW + QRAIN) * 0.001 + ELSE + QINSUR = QINSUR+(QSNBOT + QSDEW) * 0.001 + ENDIF -!== begin tsnosoi ================================================================================== + QSEVA = QSEVA * 0.001 - SUBROUTINE TSNOSOI (ICE ,NSOIL ,NSNOW ,ISNOW ,IST , & !in - TBOT ,ZSNSO ,SSOIL ,DF ,HCPCT , & !in - SAG ,DT ,SNOWH ,DZSNSO , & !in - TG ,ILOC ,JLOC , & !in - STC ) !inout -! -------------------------------------------------------------------------------------------------- -! Compute snow (up to 3L) and soil (4L) temperature. Note that snow temperatures -! during melting season may exceed melting point (TFRZ) but later in PHASECHANGE -! subroutine the snow temperatures are reset to TFRZ for melting snow. -! -------------------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: ZBOT ! GENPARM DEPENDENT -! -------------------------------------------------------------------------------------------------- - IMPLICIT NONE -! -------------------------------------------------------------------------------------------------- -!input + DO IZ = 1, parameters%NROOT + ETRANI(IZ) = ETRAN * BTRANI(IZ) * 0.001 + ENDDO - INTEGER, INTENT(IN) :: ILOC - INTEGER, INTENT(IN) :: JLOC - INTEGER, INTENT(IN) :: ICE ! - INTEGER, INTENT(IN) :: NSOIL !no of soil layers (4) - INTEGER, INTENT(IN) :: NSNOW !maximum no of snow layers (3) - INTEGER, INTENT(IN) :: ISNOW !actual no of snow layers - INTEGER, INTENT(IN) :: IST !surface type +#ifdef WRF_HYDRO + QINSUR = QINSUR+sfcheadrt/DT*0.001 !sfcheadrt units (m) +#endif - REAL, INTENT(IN) :: DT !time step (s) - REAL, INTENT(IN) :: TBOT ! - REAL, INTENT(IN) :: SSOIL !ground heat flux (w/m2) - REAL, INTENT(IN) :: SAG !solar rad. absorbed by ground (w/m2) - REAL, INTENT(IN) :: SNOWH !snow depth (m) - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !layer-bot. depth from snow surf.(m) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness (m) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT !heat capacity (J/m3/k) +! lake/soil water balances -!input and output + IF (IST == 2) THEN ! lake + RUNSRF = 0. + IF(WSLAKE >= WSLMAX) RUNSRF = QINSUR*1000. !mm/s + WSLAKE = WSLAKE + (QINSUR-QSEVA)*1000.*DT -RUNSRF*DT !mm + ELSE ! soil + CALL SOILWATER (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in + QINSUR ,QSEVA ,ETRANI ,SICE ,ILOC , JLOC , & !in + SH2O ,SMC ,ZWT ,VEGTYP , & !inout + SMCWTD, DEEPRECH , & !inout + RUNSRF ,QDRAIN ,RUNSUB ,WCND ,FCRMAX ) !out + + IF(OPT_RUN == 1) THEN + CALL GROUNDWATER (parameters,NSNOW ,NSOIL ,DT ,SICE ,ZSOIL , & !in + STC ,WCND ,FCRMAX ,ILOC ,JLOC , & !in + SH2O ,ZWT ,WA ,WT , & !inout + QIN ,QDIS ) !out + RUNSUB = QDIS !mm/s + END IF - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC + IF(OPT_RUN == 3 .or. OPT_RUN == 4) THEN + RUNSUB = RUNSUB + QDRAIN !mm/s + END IF -!local + DO IZ = 1,NSOIL + SMC(IZ) = SH2O(IZ) + SICE(IZ) + ENDDO + + IF(OPT_RUN == 5) THEN + CALL SHALLOWWATERTABLE (parameters,NSNOW ,NSOIL, ZSOIL, DT , & !in + DZSNSO ,SMCEQ ,ILOC , JLOC , & !in + SMC ,ZWT ,SMCWTD ,RECH, QDRAIN ) !inout - INTEGER :: IZ - REAL :: ZBOTSNO !ZBOT from snow surface - REAL, DIMENSION(-NSNOW+1:NSOIL) :: AI, BI, CI, RHSTS - REAL :: EFLXB !energy influx from soil bottom (w/m2) - REAL, DIMENSION(-NSNOW+1:NSOIL) :: PHI !light through water (w/m2) + SH2O(NSOIL) = SMC(NSOIL) - SICE(NSOIL) + RUNSUB = RUNSUB + QDRAIN !it really comes from subroutine watertable, which is not called with the same frequency as the soil routines here + WA = 0. + ENDIF - REAL, DIMENSION(-NSNOW+1:NSOIL) :: TBEG - REAL :: ERR_EST !heat storage error (w/m2) - REAL :: SSOIL2 !ground heat flux (w/m2) (for energy check) - REAL :: EFLXB2 !heat flux from the bottom (w/m2) (for energy check) - character(len=256) :: message -! ---------------------------------------------------------------------- -! compute solar penetration through water, needs more work + ENDIF - PHI(ISNOW+1:NSOIL) = 0. + RUNSUB = RUNSUB + SNOFLOW !mm/s -! adjust ZBOT from soil surface to ZBOTSNO from snow surface + END SUBROUTINE WATER - ZBOTSNO = ZBOT - SNOWH !from snow surface +!== begin canwater ================================================================================= -! snow/soil heat storage for energy balance check + SUBROUTINE CANWATER (parameters,VEGTYP ,DT , & !in + FCEV ,FCTR ,ELAI , & !in + ESAI ,TG ,FVEG ,ILOC , JLOC , & !in + BDFALL ,FROZEN_CANOPY , & !in + CANLIQ ,CANICE ,TV , & !inout + CMC ,ECAN ,ETRAN , & !out + FWET ) !out - DO IZ = ISNOW+1, NSOIL - TBEG(IZ) = STC(IZ) - ENDDO +! ------------------------ code history ------------------------------ +! canopy hydrology +! -------------------------------------------------------------------- + IMPLICIT NONE +! ------------------------ input/output variables -------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER,INTENT(IN) :: ILOC !grid index + INTEGER,INTENT(IN) :: JLOC !grid index + INTEGER,INTENT(IN) :: VEGTYP !vegetation type + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: FCEV !canopy evaporation (w/m2) [+ = to atm] + REAL, INTENT(IN) :: FCTR !transpiration (w/m2) [+ = to atm] + REAL, INTENT(IN) :: ELAI !leaf area index, after burying by snow + REAL, INTENT(IN) :: ESAI !stem area index, after burying by snow + REAL, INTENT(IN) :: TG !ground temperature (k) + REAL, INTENT(IN) :: FVEG !greeness vegetation fraction (-) + LOGICAL , INTENT(IN) :: FROZEN_CANOPY ! used to define latent heat pathway + REAL , INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) ! MB/AN: v3.7 -! compute soil temperatures +! input & output + REAL, INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) + REAL, INTENT(INOUT) :: CANICE !intercepted ice mass (mm) + REAL, INTENT(INOUT) :: TV !vegetation temperature (k) - CALL HRT (NSNOW ,NSOIL ,ISNOW ,ZSNSO , & - STC ,TBOT ,ZBOTSNO ,DT , & - DF ,HCPCT ,SSOIL ,PHI , & - AI ,BI ,CI ,RHSTS , & - EFLXB ) +! output + REAL, INTENT(OUT) :: CMC !intercepted water (mm) + REAL, INTENT(OUT) :: ECAN !evaporation of intercepted water (mm/s) [+] + REAL, INTENT(OUT) :: ETRAN !transpiration rate (mm/s) [+] + REAL, INTENT(OUT) :: FWET !wetted or snowed fraction of the canopy (-) +! -------------------------------------------------------------------- - CALL HSTEP (NSNOW ,NSOIL ,ISNOW ,DT , & - AI ,BI ,CI ,RHSTS , & - STC ) +! ------------------------ local variables --------------------------- + REAL :: MAXSNO !canopy capacity for snow interception (mm) + REAL :: MAXLIQ !canopy capacity for rain interception (mm) + REAL :: QEVAC !evaporation rate (mm/s) + REAL :: QDEWC !dew rate (mm/s) + REAL :: QFROC !frost rate (mm/s) + REAL :: QSUBC !sublimation rate (mm/s) + REAL :: QMELTC !melting rate of canopy snow (mm/s) + REAL :: QFRZC !refreezing rate of canopy liquid water (mm/s) + REAL :: CANMAS !total canopy mass (kg/m2) +! -------------------------------------------------------------------- +! initialization -! update ground heat flux just for energy check, but not for final output -! otherwise, it would break the surface energy balance + ECAN = 0.0 - IF(OPT_TBOT == 1) THEN - EFLXB2 = 0. - ELSE IF(OPT_TBOT == 2) THEN - EFLXB2 = DF(NSOIL)*(TBOT-STC(NSOIL)) / & - (0.5*(ZSNSO(NSOIL-1)+ZSNSO(NSOIL)) - ZBOTSNO) - END IF +! --------------------------- liquid water ------------------------------ +! maximum canopy water - ! Skip the energy balance check for now, until we can make it work - ! right for small time steps. - return + MAXLIQ = parameters%CH2OP * (ELAI+ ESAI) -! energy balance check +! evaporation, transpiration, and dew - ERR_EST = 0.0 - DO IZ = ISNOW+1, NSOIL - ERR_EST = ERR_EST + (STC(IZ)-TBEG(IZ)) * DZSNSO(IZ) * HCPCT(IZ) / DT - ENDDO + IF (.NOT.FROZEN_CANOPY) THEN ! Barlage: change to frozen_canopy + ETRAN = MAX( FCTR/HVAP, 0. ) + QEVAC = MAX( FCEV/HVAP, 0. ) + QDEWC = ABS( MIN( FCEV/HVAP, 0. ) ) + QSUBC = 0. + QFROC = 0. + ELSE + ETRAN = MAX( FCTR/HSUB, 0. ) + QEVAC = 0. + QDEWC = 0. + QSUBC = MAX( FCEV/HSUB, 0. ) + QFROC = ABS( MIN( FCEV/HSUB, 0. ) ) + ENDIF - if (OPT_STC == 1) THEN ! semi-implicit - ERR_EST = ERR_EST - (SSOIL +EFLXB) - ELSE ! full-implicit - SSOIL2 = DF(ISNOW+1)*(TG-STC(ISNOW+1))/(0.5*DZSNSO(ISNOW+1)) !M. Barlage - ERR_EST = ERR_EST - (SSOIL2+EFLXB2) - ENDIF +! canopy water balance. for convenience allow dew to bring CANLIQ above +! maxh2o or else would have to re-adjust drip - IF (ABS(ERR_EST) > 1.) THEN ! W/m2 - WRITE(message,*) 'TSNOSOI is losing(-)/gaining(+) false energy',ERR_EST,' W/m2' - call wrf_message(trim(message)) - WRITE(message,'(i6,1x,i6,1x,i3,F18.13,5F20.12)') & - ILOC, JLOC, IST,ERR_EST,SSOIL,SNOWH,TG,STC(ISNOW+1),EFLXB - call wrf_message(trim(message)) - !niu STOP - END IF + QEVAC = MIN(CANLIQ/DT,QEVAC) + CANLIQ=MAX(0.,CANLIQ+(QDEWC-QEVAC)*DT) + IF(CANLIQ <= 1.E-06) CANLIQ = 0.0 - END SUBROUTINE TSNOSOI +! --------------------------- canopy ice ------------------------------ +! for canopy ice -!== begin hrt ====================================================================================== + MAXSNO = 6.6*(0.27+46./BDFALL) * (ELAI+ ESAI) - SUBROUTINE HRT (NSNOW ,NSOIL ,ISNOW ,ZSNSO , & - STC ,TBOT ,ZBOT ,DT , & - DF ,HCPCT ,SSOIL ,PHI , & - AI ,BI ,CI ,RHSTS , & - BOTFLX ) -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- -! calculate the right hand side of the time tendency term of the soil -! thermal diffusion equation. also to compute ( prepare ) the matrix -! coefficients for the tri-diagonal matrix of the implicit time scheme. -! ---------------------------------------------------------------------- - IMPLICIT NONE -! ---------------------------------------------------------------------- -! input + QSUBC = MIN(CANICE/DT,QSUBC) + CANICE= MAX(0.,CANICE + (QFROC-QSUBC)*DT) + IF(CANICE.LE.1.E-6) CANICE = 0. + +! wetted fraction of canopy - INTEGER, INTENT(IN) :: NSOIL !no of soil layers (4) - INTEGER, INTENT(IN) :: NSNOW !maximum no of snow layers (3) - INTEGER, INTENT(IN) :: ISNOW !actual no of snow layers - REAL, INTENT(IN) :: TBOT !bottom soil temp. at ZBOT (k) - REAL, INTENT(IN) :: ZBOT !depth of lower boundary condition (m) - !from soil surface not snow surface - REAL, INTENT(IN) :: DT !time step (s) - REAL, INTENT(IN) :: SSOIL !ground heat flux (w/m2) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: ZSNSO !depth of layer-bottom of snow/soil (m) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature (k) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DF !thermal conductivity [w/m/k] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT !heat capacity [j/m3/k] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: PHI !light through water (w/m2) + IF(CANICE.GT.0.) THEN + FWET = MAX(0.,CANICE) / MAX(MAXSNO,1.E-06) + ELSE + FWET = MAX(0.,CANLIQ) / MAX(MAXLIQ,1.E-06) + ENDIF + FWET = MIN(FWET, 1.) ** 0.667 -! output +! phase change - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: RHSTS !right-hand side of the matrix - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: AI !left-hand side coefficient - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: BI !left-hand side coefficient - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: CI !left-hand side coefficient - REAL, INTENT(OUT) :: BOTFLX !energy influx from soil bottom (w/m2) + QMELTC = 0. + QFRZC = 0. -! local + IF(CANICE.GT.1.E-6.AND.TV.GT.TFRZ) THEN + QMELTC = MIN(CANICE/DT,(TV-TFRZ)*CICE*CANICE/DENICE/(DT*HFUS)) + CANICE = MAX(0.,CANICE - QMELTC*DT) + CANLIQ = MAX(0.,CANLIQ + QMELTC*DT) + TV = FWET*TFRZ + (1.-FWET)*TV + ENDIF - INTEGER :: K - REAL, DIMENSION(-NSNOW+1:NSOIL) :: DDZ - REAL, DIMENSION(-NSNOW+1:NSOIL) :: DZ - REAL, DIMENSION(-NSNOW+1:NSOIL) :: DENOM - REAL, DIMENSION(-NSNOW+1:NSOIL) :: DTSDZ - REAL, DIMENSION(-NSNOW+1:NSOIL) :: EFLUX - REAL :: TEMP1 -! ---------------------------------------------------------------------- + IF(CANLIQ.GT.1.E-6.AND.TV.LT.TFRZ) THEN + QFRZC = MIN(CANLIQ/DT,(TFRZ-TV)*CWAT*CANLIQ/DENH2O/(DT*HFUS)) + CANLIQ = MAX(0.,CANLIQ - QFRZC*DT) + CANICE = MAX(0.,CANICE + QFRZC*DT) + TV = FWET*TFRZ + (1.-FWET)*TV + ENDIF - DO K = ISNOW+1, NSOIL - IF (K == ISNOW+1) THEN - DENOM(K) = - ZSNSO(K) * HCPCT(K) - TEMP1 = - ZSNSO(K+1) - DDZ(K) = 2.0 / TEMP1 - DTSDZ(K) = 2.0 * (STC(K) - STC(K+1)) / TEMP1 - EFLUX(K) = DF(K) * DTSDZ(K) - SSOIL - PHI(K) - ELSE IF (K < NSOIL) THEN - DENOM(K) = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K) - TEMP1 = ZSNSO(K-1) - ZSNSO(K+1) - DDZ(K) = 2.0 / TEMP1 - DTSDZ(K) = 2.0 * (STC(K) - STC(K+1)) / TEMP1 - EFLUX(K) = (DF(K)*DTSDZ(K) - DF(K-1)*DTSDZ(K-1)) - PHI(K) - ELSE IF (K == NSOIL) THEN - DENOM(K) = (ZSNSO(K-1) - ZSNSO(K)) * HCPCT(K) - TEMP1 = ZSNSO(K-1) - ZSNSO(K) - IF(OPT_TBOT == 1) THEN - BOTFLX = 0. - END IF - IF(OPT_TBOT == 2) THEN - DTSDZ(K) = (STC(K) - TBOT) / ( 0.5*(ZSNSO(K-1)+ZSNSO(K)) - ZBOT) - BOTFLX = -DF(K) * DTSDZ(K) - END IF - EFLUX(K) = (-BOTFLX - DF(K-1)*DTSDZ(K-1) ) - PHI(K) - END IF - END DO +! total canopy water - DO K = ISNOW+1, NSOIL - IF (K == ISNOW+1) THEN - AI(K) = 0.0 - CI(K) = - DF(K) * DDZ(K) / DENOM(K) - IF (OPT_STC == 1) THEN - BI(K) = - CI(K) - END IF - IF (OPT_STC == 2) THEN - BI(K) = - CI(K) + DF(K)/(0.5*ZSNSO(K)*ZSNSO(K)*HCPCT(K)) - END IF - ELSE IF (K < NSOIL) THEN - AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) - CI(K) = - DF(K ) * DDZ(K ) / DENOM(K) - BI(K) = - (AI(K) + CI (K)) - ELSE IF (K == NSOIL) THEN - AI(K) = - DF(K-1) * DDZ(K-1) / DENOM(K) - CI(K) = 0.0 - BI(K) = - (AI(K) + CI(K)) - END IF - RHSTS(K) = EFLUX(K)/ (-DENOM(K)) - END DO + CMC = CANLIQ + CANICE - END SUBROUTINE HRT +! total canopy evaporation -!== begin hstep ==================================================================================== + ECAN = QEVAC + QSUBC - QDEWC - QFROC - SUBROUTINE HSTEP (NSNOW ,NSOIL ,ISNOW ,DT , & - AI ,BI ,CI ,RHSTS , & - STC ) -! ---------------------------------------------------------------------- -! CALCULATE/UPDATE THE SOIL TEMPERATURE FIELD. + END SUBROUTINE CANWATER + +!== begin snowwater ================================================================================ + + SUBROUTINE SNOWWATER (parameters,NSNOW ,NSOIL ,IMELT ,DT ,ZSOIL , & !in + SFCTMP ,SNOWHIN,QSNOW ,QSNFRO ,QSNSUB , & !in + QRAIN ,FICEOLD,ILOC ,JLOC , & !in + ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout + SH2O ,SICE ,STC ,ZSNSO ,DZSNSO , & !inout + QSNBOT ,SNOFLOW,PONDING1 ,PONDING2) !out ! ---------------------------------------------------------------------- - implicit none + IMPLICIT NONE ! ---------------------------------------------------------------------- ! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [0-no melt;1-melt] + REAL, INTENT(IN) :: DT !time step (s) + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil surface + REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] + REAL, INTENT(IN) :: SNOWHIN!snow depth increasing rate (m/s) + REAL, INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] + REAL, INTENT(IN) :: QSNFRO !snow surface frost rate[mm/s] + REAL, INTENT(IN) :: QSNSUB !snow surface sublimation rate[mm/s] + REAL, INTENT(IN) :: QRAIN !snow surface rain rate[mm/s] + REAL, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: FICEOLD!ice fraction at last timestep - INTEGER, INTENT(IN) :: NSOIL - INTEGER, INTENT(IN) :: NSNOW - INTEGER, INTENT(IN) :: ISNOW - REAL, INTENT(IN) :: DT +! input & output + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, INTENT(INOUT) :: SNOWH !snow height [m] + REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !depth of snow/soil layer-bottom + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !snow/soil layer thickness [m] -! output & input - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: RHSTS - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: AI - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: BI - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: CI - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC +! output + REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] + REAL, INTENT(OUT) :: SNOFLOW!glacier flow [mm] + REAL, INTENT(OUT) :: PONDING1 + REAL, INTENT(OUT) :: PONDING2 ! local - INTEGER :: K - REAL, DIMENSION(-NSNOW+1:NSOIL) :: RHSTSIN - REAL, DIMENSION(-NSNOW+1:NSOIL) :: CIIN + INTEGER :: IZ,i + REAL :: BDSNOW !bulk density of snow (kg/m3) ! ---------------------------------------------------------------------- + SNOFLOW = 0.0 + PONDING1 = 0.0 + PONDING2 = 0.0 - DO K = ISNOW+1,NSOIL - RHSTS(K) = RHSTS(K) * DT - AI(K) = AI(K) * DT - BI(K) = 1. + BI(K) * DT - CI(K) = CI(K) * DT - END DO + CALL SNOWFALL (parameters,NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN, & !in + SFCTMP ,ILOC ,JLOC , & !in + ISNOW ,SNOWH ,DZSNSO ,STC ,SNICE , & !inout + SNLIQ ,SNEQV ) !inout -! copy values for input variables before call to rosr12 +! MB: do each if block separately - DO K = ISNOW+1,NSOIL - RHSTSIN(K) = RHSTS(K) - CIIN(K) = CI(K) - END DO + IF(ISNOW < 0) & ! when multi-layer + CALL COMPACT (parameters,NSNOW ,NSOIL ,DT ,STC ,SNICE , & !in + SNLIQ ,ZSOIL ,IMELT ,FICEOLD,ILOC , JLOC ,& !in + ISNOW ,DZSNSO ,ZSNSO ) !inout -! solve the tri-diagonal matrix equation + IF(ISNOW < 0) & !when multi-layer + CALL COMBINE (parameters,NSNOW ,NSOIL ,ILOC ,JLOC , & !in + ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout + DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout + PONDING1 ,PONDING2) !out - CALL ROSR12 (CI,AI,BI,CIIN,RHSTSIN,RHSTS,ISNOW+1,NSOIL,NSNOW) + IF(ISNOW < 0) & !when multi-layer + CALL DIVIDE (parameters,NSNOW ,NSOIL , & !in + ISNOW ,STC ,SNICE ,SNLIQ ,DZSNSO ) !inout -! update snow & soil temperature + CALL SNOWH2O (parameters,NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in + QRAIN ,ILOC ,JLOC , & !in + ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout + SNLIQ ,SH2O ,SICE ,STC , & !inout + QSNBOT ,PONDING1 ,PONDING2) !out - DO K = ISNOW+1,NSOIL - STC (K) = STC (K) + CI (K) - END DO +!set empty snow layers to zero - END SUBROUTINE HSTEP + do iz = -nsnow+1, isnow + snice(iz) = 0. + snliq(iz) = 0. + stc(iz) = 0. + dzsnso(iz)= 0. + zsnso(iz) = 0. + enddo -!== begin rosr12 =================================================================================== +!to obtain equilibrium state of snow in glacier region + + IF(SNEQV > 2000.) THEN ! 2000 mm -> maximum water depth + BDSNOW = SNICE(0) / DZSNSO(0) + SNOFLOW = (SNEQV - 2000.) + SNICE(0) = SNICE(0) - SNOFLOW + DZSNSO(0) = DZSNSO(0) - SNOFLOW/BDSNOW + SNOFLOW = SNOFLOW / DT + END IF + +! sum up snow mass for layered snow + + IF(ISNOW < 0) THEN ! MB: only do for multi-layer + SNEQV = 0. + DO IZ = ISNOW+1,0 + SNEQV = SNEQV + SNICE(IZ) + SNLIQ(IZ) + ENDDO + END IF + +! Reset ZSNSO and layer thinkness DZSNSO + + DO IZ = ISNOW+1, 0 + DZSNSO(IZ) = -DZSNSO(IZ) + END DO - SUBROUTINE ROSR12 (P,A,B,C,D,DELTA,NTOP,NSOIL,NSNOW) -! ---------------------------------------------------------------------- -! SUBROUTINE ROSR12 -! ---------------------------------------------------------------------- -! INVERT (SOLVE) THE TRI-DIAGONAL MATRIX PROBLEM SHOWN BELOW: -! ### ### ### ### ### ### -! #B(1), C(1), 0 , 0 , 0 , . . . , 0 # # # # # -! #A(2), B(2), C(2), 0 , 0 , . . . , 0 # # # # # -! # 0 , A(3), B(3), C(3), 0 , . . . , 0 # # # # D(3) # -! # 0 , 0 , A(4), B(4), C(4), . . . , 0 # # P(4) # # D(4) # -! # 0 , 0 , 0 , A(5), B(5), . . . , 0 # # P(5) # # D(5) # -! # . . # # . # = # . # -! # . . # # . # # . # -! # . . # # . # # . # -! # 0 , . . . , 0 , A(M-2), B(M-2), C(M-2), 0 # #P(M-2)# #D(M-2)# -! # 0 , . . . , 0 , 0 , A(M-1), B(M-1), C(M-1)# #P(M-1)# #D(M-1)# -! # 0 , . . . , 0 , 0 , 0 , A(M) , B(M) # # P(M) # # D(M) # -! ### ### ### ### ### ### -! ---------------------------------------------------------------------- - IMPLICIT NONE + DZSNSO(1) = ZSOIL(1) + DO IZ = 2,NSOIL + DZSNSO(IZ) = (ZSOIL(IZ) - ZSOIL(IZ-1)) + END DO - INTEGER, INTENT(IN) :: NTOP - INTEGER, INTENT(IN) :: NSOIL,NSNOW - INTEGER :: K, KK + ZSNSO(ISNOW+1) = DZSNSO(ISNOW+1) + DO IZ = ISNOW+2 ,NSOIL + ZSNSO(IZ) = ZSNSO(IZ-1) + DZSNSO(IZ) + ENDDO - REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(IN):: A, B, D - REAL, DIMENSION(-NSNOW+1:NSOIL),INTENT(INOUT):: C,P,DELTA + DO IZ = ISNOW+1 ,NSOIL + DZSNSO(IZ) = -DZSNSO(IZ) + END DO -! ---------------------------------------------------------------------- -! INITIALIZE EQN COEF C FOR THE LOWEST SOIL LAYER -! ---------------------------------------------------------------------- - C (NSOIL) = 0.0 - P (NTOP) = - C (NTOP) / B (NTOP) -! ---------------------------------------------------------------------- -! SOLVE THE COEFS FOR THE 1ST SOIL LAYER -! ---------------------------------------------------------------------- - DELTA (NTOP) = D (NTOP) / B (NTOP) -! ---------------------------------------------------------------------- -! SOLVE THE COEFS FOR SOIL LAYERS 2 THRU NSOIL -! ---------------------------------------------------------------------- - DO K = NTOP+1,NSOIL - P (K) = - C (K) * ( 1.0 / (B (K) + A (K) * P (K -1)) ) - DELTA (K) = (D (K) - A (K)* DELTA (K -1))* (1.0/ (B (K) + A (K)& - * P (K -1))) - END DO -! ---------------------------------------------------------------------- -! SET P TO DELTA FOR LOWEST SOIL LAYER -! ---------------------------------------------------------------------- - P (NSOIL) = DELTA (NSOIL) -! ---------------------------------------------------------------------- -! ADJUST P FOR SOIL LAYERS 2 THRU NSOIL -! ---------------------------------------------------------------------- - DO K = NTOP+1,NSOIL - KK = NSOIL - K + (NTOP-1) + 1 - P (KK) = P (KK) * P (KK +1) + DELTA (KK) - END DO -! ---------------------------------------------------------------------- - END SUBROUTINE ROSR12 + END SUBROUTINE SNOWWATER -!== begin phasechange ============================================================================== +!== begin snowfall ================================================================================= - SUBROUTINE PHASECHANGE (NSNOW ,NSOIL ,ISNOW ,DT ,FACT , & !in - DZSNSO ,HCPCT ,IST ,ILOC ,JLOC , & !in - STC ,SNICE ,SNLIQ ,SNEQV ,SNOWH , & !inout - SMC ,SH2O , & !inout - QMELT ,IMELT ,PONDING ) !out -! ---------------------------------------------------------------------- -! melting/freezing of snow water and soil water + SUBROUTINE SNOWFALL (parameters,NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN , & !in + SFCTMP ,ILOC ,JLOC , & !in + ISNOW ,SNOWH ,DZSNSO ,STC ,SNICE , & !inout + SNLIQ ,SNEQV ) !inout ! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX, & ! SOIL DEPENDENT - GRAV, TFRZ, HFUS ! MP CONSTANT +! snow depth and density to account for the new snowfall. +! new values of snow depth & density returned. ! ---------------------------------------------------------------------- - IMPLICIT NONE + IMPLICIT NONE ! ---------------------------------------------------------------------- -! inputs - - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [=3] - INTEGER, INTENT(IN) :: NSOIL !No. of soil layers [=4] - INTEGER, INTENT(IN) :: ISNOW !actual no. of snow layers [<=3] - INTEGER, INTENT(IN) :: IST !surface type: 1->soil; 2->lake - REAL, INTENT(IN) :: DT !land model time step (sec) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: FACT !temporary - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: HCPCT !heat capacity (J/m3/k) +! input -! outputs - INTEGER, DIMENSION(-NSNOW+1:NSOIL), INTENT(OUT) :: IMELT !phase change index - REAL, INTENT(OUT) :: QMELT !snowmelt rate [mm/s] - REAL, INTENT(OUT) :: PONDING!snowmelt when snow has no layer [mm] + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + REAL, INTENT(IN) :: DT !main time step (s) + REAL, INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] + REAL, INTENT(IN) :: SNOWHIN!snow depth increasing rate (m/s) + REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] -! inputs and outputs +! input and output - REAL, INTENT(INOUT) :: SNEQV - REAL, INTENT(INOUT) :: SNOWH - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil layer temperature [k] - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water [m3/m3] - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !total soil water [m3/m3] - REAL, DIMENSION(-NSNOW+1:0) , INTENT(INOUT) :: SNICE !snow layer ice [mm] - REAL, DIMENSION(-NSNOW+1:0) , INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, INTENT(INOUT) :: SNOWH !snow depth [m] + REAL, INTENT(INOUT) :: SNEQV !swow water equivalent [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !thickness of snow/soil layers (m) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] ! local - INTEGER :: J !do loop index - REAL, DIMENSION(-NSNOW+1:NSOIL) :: HM !energy residual [w/m2] - REAL, DIMENSION(-NSNOW+1:NSOIL) :: XM !melting or freezing water [kg/m2] - REAL, DIMENSION(-NSNOW+1:NSOIL) :: WMASS0 - REAL, DIMENSION(-NSNOW+1:NSOIL) :: WICE0 - REAL, DIMENSION(-NSNOW+1:NSOIL) :: WLIQ0 - REAL, DIMENSION(-NSNOW+1:NSOIL) :: MICE !soil/snow ice mass [mm] - REAL, DIMENSION(-NSNOW+1:NSOIL) :: MLIQ !soil/snow liquid water mass [mm] - REAL, DIMENSION(-NSNOW+1:NSOIL) :: SUPERCOOL !supercooled water in soil (kg/m2) - REAL :: HEATR !energy residual or loss after melting/freezing - REAL :: TEMP1 !temporary variables [kg/m2] - REAL :: PROPOR - REAL :: SMP !frozen water potential (mm) - REAL :: XMF !total latent heat of phase change - + INTEGER :: NEWNODE ! 0-no new layers, 1-creating new layers ! ---------------------------------------------------------------------- -! Initialization + NEWNODE = 0 - QMELT = 0. - PONDING = 0. - XMF = 0. +! shallow snow / no layer - DO J = -NSNOW+1, NSOIL - SUPERCOOL(J) = 0.0 - END DO + IF(ISNOW == 0 .and. QSNOW > 0.) THEN + SNOWH = SNOWH + SNOWHIN * DT + SNEQV = SNEQV + QSNOW * DT + END IF - DO J = ISNOW+1,0 ! all layers - MICE(J) = SNICE(J) - MLIQ(J) = SNLIQ(J) - END DO +! creating a new layer + + IF(ISNOW == 0 .AND. QSNOW>0. .AND. SNOWH >= 0.025) THEN !MB: change limit +! IF(ISNOW == 0 .AND. QSNOW>0. .AND. SNOWH >= 0.05) THEN + ISNOW = -1 + NEWNODE = 1 + DZSNSO(0)= SNOWH + SNOWH = 0. + STC(0) = MIN(273.16, SFCTMP) ! temporary setup + SNICE(0) = SNEQV + SNLIQ(0) = 0. + END IF - DO J = 1, NSOIL ! soil - MLIQ(J) = SH2O(J) * DZSNSO(J) * 1000. - MICE(J) = (SMC(J) - SH2O(J)) * DZSNSO(J) * 1000. - END DO +! snow with layers - DO J = ISNOW+1,NSOIL ! all layers - IMELT(J) = 0 - HM(J) = 0. - XM(J) = 0. - WICE0(J) = MICE(J) - WLIQ0(J) = MLIQ(J) - WMASS0(J) = MICE(J) + MLIQ(J) - ENDDO + IF(ISNOW < 0 .AND. NEWNODE == 0 .AND. QSNOW > 0.) then + SNICE(ISNOW+1) = SNICE(ISNOW+1) + QSNOW * DT + DZSNSO(ISNOW+1) = DZSNSO(ISNOW+1) + SNOWHIN * DT + ENDIF - if(ist == 1) then - DO J = 1,NSOIL - IF (OPT_FRZ == 1) THEN - IF(STC(J) < TFRZ) THEN - SMP = HFUS*(TFRZ-STC(J))/(GRAV*STC(J)) !(m) - SUPERCOOL(J) = SMCMAX*(SMP/PSISAT)**(-1./BEXP) - SUPERCOOL(J) = SUPERCOOL(J)*DZSNSO(J)*1000. !(mm) - END IF - END IF - IF (OPT_FRZ == 2) THEN - CALL FRH2O (SUPERCOOL(J),STC(J),SMC(J),SH2O(J)) - SUPERCOOL(J) = SUPERCOOL(J)*DZSNSO(J)*1000. !(mm) - END IF - ENDDO - end if +! ---------------------------------------------------------------------- + END SUBROUTINE SNOWFALL - DO J = ISNOW+1,NSOIL - IF (MICE(J) > 0. .AND. STC(J) >= TFRZ) THEN !melting - IMELT(J) = 1 - ENDIF - IF (MLIQ(J) > SUPERCOOL(J) .AND. STC(J) < TFRZ) THEN - IMELT(J) = 2 - ENDIF +!== begin combine ================================================================================== - ! If snow exists, but its thickness is not enough to create a layer - IF (ISNOW == 0 .AND. SNEQV > 0. .AND. J == 1) THEN - IF (STC(J) >= TFRZ) THEN - IMELT(J) = 1 - ENDIF - ENDIF - ENDDO + SUBROUTINE COMBINE (parameters,NSNOW ,NSOIL ,ILOC ,JLOC , & !in + ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout + DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout + PONDING1 ,PONDING2) !out +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input -! Calculate the energy surplus and loss for melting and freezing + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC + INTEGER, INTENT(IN) :: JLOC + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers - DO J = ISNOW+1,NSOIL - IF (IMELT(J) > 0) THEN - HM(J) = (STC(J)-TFRZ)/FACT(J) - STC(J) = TFRZ - ENDIF +! input and output - IF (IMELT(J) == 1 .AND. HM(J) < 0.) THEN - HM(J) = 0. - IMELT(J) = 0 - ENDIF - IF (IMELT(J) == 2 .AND. HM(J) > 0.) THEN - HM(J) = 0. - IMELT(J) = 0 - ENDIF - XM(J) = HM(J)*DT/HFUS - ENDDO + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO!snow layer depth [m] + REAL, INTENT(INOUT) :: sneqv !snow water equivalent [m] + REAL, INTENT(INOUT) :: snowh !snow depth [m] + REAL, INTENT(OUT) :: PONDING1 + REAL, INTENT(OUT) :: PONDING2 -! The rate of melting and freezing for snow without a layer, needs more work. +! local variables: - IF (ISNOW == 0 .AND. SNEQV > 0. .AND. XM(1) > 0.) THEN - TEMP1 = SNEQV - SNEQV = MAX(0.,TEMP1-XM(1)) - PROPOR = SNEQV/TEMP1 - SNOWH = MAX(0.,PROPOR * SNOWH) - HEATR = HM(1) - HFUS*(TEMP1-SNEQV)/DT - IF (HEATR > 0.) THEN - XM(1) = HEATR*DT/HFUS - HM(1) = HEATR - ELSE - XM(1) = 0. - HM(1) = 0. - ENDIF - QMELT = MAX(0.,(TEMP1-SNEQV))/DT - XMF = HFUS*QMELT - PONDING = TEMP1-SNEQV - ENDIF + INTEGER :: I,J,K,L ! node indices + INTEGER :: ISNOW_OLD ! number of top snow layer + INTEGER :: MSSI ! node index + INTEGER :: NEIBOR ! adjacent node selected for combination + REAL :: ZWICE ! total ice mass in snow + REAL :: ZWLIQ ! total liquid water in snow -! The rate of melting and freezing for snow and soil + REAL :: DZMIN(3) ! minimum of top snow layer +! DATA DZMIN /0.045, 0.05, 0.2/ + DATA DZMIN /0.025, 0.025, 0.1/ ! MB: change limit +!----------------------------------------------------------------------- - DO J = ISNOW+1,NSOIL - IF (IMELT(J) > 0 .AND. ABS(HM(J)) > 0.) THEN + ISNOW_OLD = ISNOW - HEATR = 0. - IF (XM(J) > 0.) THEN - MICE(J) = MAX(0., WICE0(J)-XM(J)) - HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT - ELSE IF (XM(J) < 0.) THEN - IF (J <= 0) THEN ! snow - MICE(J) = MIN(WMASS0(J), WICE0(J)-XM(J)) - ELSE ! soil - IF (WMASS0(J) < SUPERCOOL(J)) THEN - MICE(J) = 0. + DO J = ISNOW_OLD+1,0 + IF (SNICE(J) <= .1) THEN + IF(J /= 0) THEN + SNLIQ(J+1) = SNLIQ(J+1) + SNLIQ(J) + SNICE(J+1) = SNICE(J+1) + SNICE(J) + ELSE + IF (ISNOW_OLD < -1) THEN ! MB/KM: change to ISNOW + SNLIQ(J-1) = SNLIQ(J-1) + SNLIQ(J) + SNICE(J-1) = SNICE(J-1) + SNICE(J) ELSE - MICE(J) = MIN(WMASS0(J) - SUPERCOOL(J),WICE0(J)-XM(J)) - MICE(J) = MAX(MICE(J),0.0) + IF(SNICE(J) >= 0.) THEN + PONDING1 = SNLIQ(J) ! ISNOW WILL GET SET TO ZERO BELOW; PONDING1 WILL GET + SNEQV = SNICE(J) ! ADDED TO PONDING FROM PHASECHANGE PONDING SHOULD BE + SNOWH = DZSNSO(J) ! ZERO HERE BECAUSE IT WAS CALCULATED FOR THIN SNOW + ELSE ! SNICE OVER-SUBLIMATED EARLIER + PONDING1 = SNLIQ(J) + SNICE(J) + IF(PONDING1 < 0.) THEN ! IF SNICE AND SNLIQ SUBLIMATES REMOVE FROM SOIL + SICE(1) = MAX(0.0,SICE(1)+PONDING1/(DZSNSO(1)*1000.)) + PONDING1 = 0.0 + END IF + SNEQV = 0.0 + SNOWH = 0.0 + END IF + SNLIQ(J) = 0.0 + SNICE(J) = 0.0 + DZSNSO(J) = 0.0 ENDIF - ENDIF - HEATR = HM(J) - HFUS*(WICE0(J)-MICE(J))/DT - ENDIF +! SH2O(1) = SH2O(1)+SNLIQ(J)/(DZSNSO(1)*1000.) +! SICE(1) = SICE(1)+SNICE(J)/(DZSNSO(1)*1000.) + ENDIF - MLIQ(J) = MAX(0.,WMASS0(J)-MICE(J)) + ! shift all elements above this down by one. + IF (J > ISNOW+1 .AND. ISNOW < -1) THEN + DO I = J, ISNOW+2, -1 + STC(I) = STC(I-1) + SNLIQ(I) = SNLIQ(I-1) + SNICE(I) = SNICE(I-1) + DZSNSO(I)= DZSNSO(I-1) + END DO + END IF + ISNOW = ISNOW + 1 + END IF + END DO - IF (ABS(HEATR) > 0.) THEN - STC(J) = STC(J) + FACT(J)*HEATR - IF (J <= 0) THEN ! snow - IF (MLIQ(J)*MICE(J)>0.) STC(J) = TFRZ - END IF - ENDIF +! to conserve water in case of too large surface sublimation - XMF = XMF + HFUS * (WICE0(J)-MICE(J))/DT + IF(SICE(1) < 0.) THEN + SH2O(1) = SH2O(1) + SICE(1) + SICE(1) = 0. + END IF - IF (J < 1) THEN - QMELT = QMELT + MAX(0.,(WICE0(J)-MICE(J)))/DT - ENDIF - ENDIF - ENDDO + IF(ISNOW ==0) RETURN ! MB: get out if no longer multi-layer - DO J = ISNOW+1,0 ! snow - SNLIQ(J) = MLIQ(J) - SNICE(J) = MICE(J) - END DO + SNEQV = 0. + SNOWH = 0. + ZWICE = 0. + ZWLIQ = 0. - DO J = 1, NSOIL ! soil - SH2O(J) = MLIQ(J) / (1000. * DZSNSO(J)) - SMC(J) = (MLIQ(J) + MICE(J)) / (1000. * DZSNSO(J)) - END DO - - END SUBROUTINE PHASECHANGE + DO J = ISNOW+1,0 + SNEQV = SNEQV + SNICE(J) + SNLIQ(J) + SNOWH = SNOWH + DZSNSO(J) + ZWICE = ZWICE + SNICE(J) + ZWLIQ = ZWLIQ + SNLIQ(J) + END DO -!== begin frh2o ==================================================================================== +! check the snow depth - all snow gone +! the liquid water assumes ponding on soil surface. - SUBROUTINE FRH2O (FREE,TKELV,SMC,SH2O) + IF (SNOWH < 0.025 .AND. ISNOW < 0 ) THEN ! MB: change limit +! IF (SNOWH < 0.05 .AND. ISNOW < 0 ) THEN + ISNOW = 0 + SNEQV = ZWICE + PONDING2 = ZWLIQ ! LIMIT OF ISNOW < 0 MEANS INPUT PONDING + IF(SNEQV <= 0.) SNOWH = 0. ! SHOULD BE ZERO; SEE ABOVE + END IF -! ---------------------------------------------------------------------- -! SUBROUTINE FRH2O -! ---------------------------------------------------------------------- -! CALCULATE AMOUNT OF SUPERCOOLED LIQUID SOIL WATER CONTENT IF -! TEMPERATURE IS BELOW 273.15K (TFRZ). REQUIRES NEWTON-TYPE ITERATION -! TO SOLVE THE NONLINEAR IMPLICIT EQUATION GIVEN IN EQN 17 OF KOREN ET AL -! (1999, JGR, VOL 104(D16), 19569-19585). -! ---------------------------------------------------------------------- -! NEW VERSION (JUNE 2001): MUCH FASTER AND MORE ACCURATE NEWTON -! ITERATION ACHIEVED BY FIRST TAKING LOG OF EQN CITED ABOVE -- LESS THAN -! 4 (TYPICALLY 1 OR 2) ITERATIONS ACHIEVES CONVERGENCE. ALSO, EXPLICIT -! 1-STEP SOLUTION OPTION FOR SPECIAL CASE OF PARAMETER CK=0, WHICH -! REDUCES THE ORIGINAL IMPLICIT EQUATION TO A SIMPLER EXPLICIT FORM, -! KNOWN AS THE "FLERCHINGER EQN". IMPROVED HANDLING OF SOLUTION IN THE -! LIMIT OF FREEZING POINT TEMPERATURE TFRZ. -! ---------------------------------------------------------------------- -! INPUT: +! IF (SNOWH < 0.05 ) THEN +! ISNOW = 0 +! SNEQV = ZWICE +! SH2O(1) = SH2O(1) + ZWLIQ / (DZSNSO(1) * 1000.) +! IF(SNEQV <= 0.) SNOWH = 0. +! END IF -! TKELV.........TEMPERATURE (Kelvin) -! SMC...........TOTAL SOIL MOISTURE CONTENT (VOLUMETRIC) -! SH2O..........LIQUID SOIL MOISTURE CONTENT (VOLUMETRIC) -! B.............SOIL TYPE "B" PARAMETER (FROM REDPRM) -! PSISAT........SATURATED SOIL MATRIC POTENTIAL (FROM REDPRM) +! check the snow depth - snow layers combined -! OUTPUT: -! FREE..........SUPERCOOLED LIQUID WATER CONTENT [m3/m3] -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX, & ! SOIL DEPENDENT - GRAV, TFRZ, HFUS ! MP CONSTANT -! ---------------------------------------------------------------------- - IMPLICIT NONE - REAL, INTENT(IN) :: SH2O,SMC,TKELV - REAL, INTENT(OUT) :: FREE - REAL :: BX,DENOM,DF,DSWL,FK,SWL,SWLK - INTEGER :: NLOG,KCOUNT -! PARAMETER(CK = 0.0) - REAL, PARAMETER :: CK = 8.0, BLIM = 5.5, ERROR = 0.005, & - DICE = 920.0 - CHARACTER(LEN=80) :: message + IF (ISNOW < -1) THEN -! ---------------------------------------------------------------------- -! LIMITS ON PARAMETER B: B < 5.5 (use parameter BLIM) -! SIMULATIONS SHOWED IF B > 5.5 UNFROZEN WATER CONTENT IS -! NON-REALISTICALLY HIGH AT VERY LOW TEMPERATURES. -! ---------------------------------------------------------------------- - BX = BEXP -! ---------------------------------------------------------------------- -! INITIALIZING ITERATIONS COUNTER AND ITERATIVE SOLUTION FLAG. -! ---------------------------------------------------------------------- + ISNOW_OLD = ISNOW + MSSI = 1 - IF (BEXP > BLIM) BX = BLIM - NLOG = 0 + DO I = ISNOW_OLD+1,0 + IF (DZSNSO(I) < DZMIN(MSSI)) THEN -! ---------------------------------------------------------------------- -! IF TEMPERATURE NOT SIGNIFICANTLY BELOW FREEZING (TFRZ), SH2O = SMC -! ---------------------------------------------------------------------- - KCOUNT = 0 - IF (TKELV > (TFRZ- 1.E-3)) THEN - FREE = SMC - ELSE + IF (I == ISNOW+1) THEN + NEIBOR = I + 1 + ELSE IF (I == 0) THEN + NEIBOR = I - 1 + ELSE + NEIBOR = I + 1 + IF ((DZSNSO(I-1)+DZSNSO(I)) < (DZSNSO(I+1)+DZSNSO(I))) NEIBOR = I-1 + END IF -! ---------------------------------------------------------------------- -! OPTION 1: ITERATED SOLUTION IN KOREN ET AL, JGR, 1999, EQN 17 -! ---------------------------------------------------------------------- -! INITIAL GUESS FOR SWL (frozen content) -! ---------------------------------------------------------------------- - IF (CK /= 0.0) THEN - SWL = SMC - SH2O -! ---------------------------------------------------------------------- -! KEEP WITHIN BOUNDS. -! ---------------------------------------------------------------------- - IF (SWL > (SMC -0.02)) SWL = SMC -0.02 -! ---------------------------------------------------------------------- -! START OF ITERATIONS -! ---------------------------------------------------------------------- - IF (SWL < 0.) SWL = 0. -1001 Continue - IF (.NOT.( (NLOG < 10) .AND. (KCOUNT == 0))) goto 1002 - NLOG = NLOG +1 - DF = ALOG ( ( PSISAT * GRAV / HFUS ) * ( ( 1. + CK * SWL )**2.) * & - ( SMCMAX / (SMC - SWL) )** BX) - ALOG ( - ( & - TKELV - TFRZ)/ TKELV) - DENOM = 2. * CK / ( 1. + CK * SWL ) + BX / ( SMC - SWL ) - SWLK = SWL - DF / DENOM -! ---------------------------------------------------------------------- -! BOUNDS USEFUL FOR MATHEMATICAL SOLUTION. -! ---------------------------------------------------------------------- - IF (SWLK > (SMC -0.02)) SWLK = SMC - 0.02 - IF (SWLK < 0.) SWLK = 0. + ! Node l and j are combined and stored as node j. + IF (NEIBOR > I) THEN + J = NEIBOR + L = I + ELSE + J = I + L = NEIBOR + END IF + + CALL COMBO (parameters,DZSNSO(J), SNLIQ(J), SNICE(J), & + STC(J), DZSNSO(L), SNLIQ(L), SNICE(L), STC(L) ) + + ! Now shift all elements above this down one. + IF (J-1 > ISNOW+1) THEN + DO K = J-1, ISNOW+2, -1 + STC(K) = STC(K-1) + SNICE(K) = SNICE(K-1) + SNLIQ(K) = SNLIQ(K-1) + DZSNSO(K) = DZSNSO(K-1) + END DO + END IF + + ! Decrease the number of snow layers + ISNOW = ISNOW + 1 + IF (ISNOW >= -1) EXIT + ELSE + + ! The layer thickness is greater than the prescribed minimum value + MSSI = MSSI + 1 + + END IF + END DO -! ---------------------------------------------------------------------- -! MATHEMATICAL SOLUTION BOUNDS APPLIED. -! ---------------------------------------------------------------------- - DSWL = ABS (SWLK - SWL) -! IF MORE THAN 10 ITERATIONS, USE EXPLICIT METHOD (CK=0 APPROX.) -! WHEN DSWL LESS OR EQ. ERROR, NO MORE ITERATIONS REQUIRED. -! ---------------------------------------------------------------------- - SWL = SWLK - IF ( DSWL <= ERROR ) THEN - KCOUNT = KCOUNT +1 - END IF -! ---------------------------------------------------------------------- -! END OF ITERATIONS -! ---------------------------------------------------------------------- -! BOUNDS APPLIED WITHIN DO-BLOCK ARE VALID FOR PHYSICAL SOLUTION. -! ---------------------------------------------------------------------- - goto 1001 -1002 continue - FREE = SMC - SWL - END IF -! ---------------------------------------------------------------------- -! END OPTION 1 -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- -! OPTION 2: EXPLICIT SOLUTION FOR FLERCHINGER EQ. i.e. CK=0 -! IN KOREN ET AL., JGR, 1999, EQN 17 -! APPLY PHYSICAL BOUNDS TO FLERCHINGER SOLUTION -! ---------------------------------------------------------------------- - IF (KCOUNT == 0) THEN - write(message, '("Flerchinger used in NEW version. Iterations=", I6)') NLOG - call wrf_message(trim(message)) - FK = ( ( (HFUS / (GRAV * ( - PSISAT)))* & - ( (TKELV - TFRZ)/ TKELV))** ( -1/ BX))* SMCMAX - IF (FK < 0.02) FK = 0.02 - FREE = MIN (FK, SMC) -! ---------------------------------------------------------------------- -! END OPTION 2 -! ---------------------------------------------------------------------- END IF - END IF -! ---------------------------------------------------------------------- - END SUBROUTINE FRH2O -! ---------------------------------------------------------------------- -! ================================================================================================== -! **********************End of energy subroutines*********************** -! ================================================================================================== -!== begin water ==================================================================================== + END SUBROUTINE COMBINE - SUBROUTINE WATER (VEGTYP ,NSNOW ,NSOIL ,IMELT ,DT ,UU , & !in - VV ,FCEV ,FCTR ,QPRECC ,QPRECL ,ELAI , & !in - ESAI ,SFCTMP ,QVAP ,QDEW ,ZSOIL ,BTRANI , & !in - FICEOLD,PONDING,TG ,IST ,FVEG ,ILOC ,JLOC ,SMCEQ , & !in - BDFALL ,FP ,RAIN ,SNOW, & !in MB/AN: v3.7 - QSNOW ,QRAIN ,SNOWHIN,LATHEAV,LATHEAG,frozen_canopy,frozen_ground, & !in MB - ISNOW ,CANLIQ ,CANICE ,TV ,SNOWH ,SNEQV , & !inout - SNICE ,SNLIQ ,STC ,ZSNSO ,SH2O ,SMC , & !inout - SICE ,ZWT ,WA ,WT ,DZSNSO ,WSLAKE , & !inout - SMCWTD ,DEEPRECH,RECH , & !inout - CMC ,ECAN ,ETRAN ,FWET ,RUNSRF ,RUNSUB , & !out - QIN ,QDIS ,PONDING1 ,PONDING2, & - QSNBOT & -#ifdef WRF_HYDRO - ,sfcheadrt & -#endif - ) !out -! ---------------------------------------------------------------------- -! Code history: -! Initial code: Guo-Yue Niu, Oct. 2007 -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: NROOT ! VEG DEPENDENT +!== begin divide =================================================================================== + + SUBROUTINE DIVIDE (parameters,NSNOW ,NSOIL , & !in + ISNOW ,STC ,SNICE ,SNLIQ ,DZSNSO ) !inout ! ---------------------------------------------------------------------- - implicit none + IMPLICIT NONE ! ---------------------------------------------------------------------- ! input - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: VEGTYP !vegetation type - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER , INTENT(IN) :: IST !surface type 1-soil; 2-lake - INTEGER, INTENT(IN) :: NSOIL !no. of soil layers - INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [1-melt; 2-freeze] - REAL, INTENT(IN) :: DT !main time step (s) - REAL, INTENT(IN) :: UU !u-direction wind speed [m/s] - REAL, INTENT(IN) :: VV !v-direction wind speed [m/s] - REAL, INTENT(IN) :: FCEV !canopy evaporation (w/m2) [+ to atm ] - REAL, INTENT(IN) :: FCTR !transpiration (w/m2) [+ to atm] - REAL, INTENT(IN) :: QPRECC !convective precipitation (mm/s) - REAL, INTENT(IN) :: QPRECL !large-scale precipitation (mm/s) - REAL, INTENT(IN) :: ELAI !leaf area index, after burying by snow - REAL, INTENT(IN) :: ESAI !stem area index, after burying by snow - REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] - REAL, INTENT(IN) :: QVAP !soil surface evaporation rate[mm/s] - REAL, INTENT(IN) :: QDEW !soil surface dew rate[mm/s] - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil surface - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: BTRANI !soil water stress factor (0 to 1) - REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD !ice fraction at last timestep -! REAL , INTENT(IN) :: PONDING ![mm] - REAL , INTENT(IN) :: TG !ground temperature (k) - REAL , INTENT(IN) :: FVEG !greeness vegetation fraction (-) - REAL , INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) ! MB/AN: v3.7 - REAL , INTENT(IN) :: FP !fraction of the gridcell that receives precipitation ! MB/AN: v3.7 - REAL , INTENT(IN) :: RAIN !rainfall (mm/s) ! MB/AN: v3.7 - REAL , INTENT(IN) :: SNOW !snowfall (mm/s) ! MB/AN: v3.7 - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] (used in m-m&f groundwater dynamics) - REAL , INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] - REAL , INTENT(IN) :: QRAIN !rain at ground srf (mm) [+] - REAL , INTENT(IN) :: SNOWHIN !snow depth increasing rate (m/s) - -! input/output - INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers - REAL, INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) - REAL, INTENT(INOUT) :: CANICE !intercepted ice mass (mm) - REAL, INTENT(INOUT) :: TV !vegetation temperature (k) - REAL, INTENT(INOUT) :: SNOWH !snow height [m] - REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow/soil layer temperature [k] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !depth of snow/soil layer-bottom - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !snow/soil layer thickness [m] - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water content [m3/m3] - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice content [m3/m3] - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !total soil water content [m3/m3] - REAL, INTENT(INOUT) :: ZWT !the depth to water table [m] - REAL, INTENT(INOUT) :: WA !water storage in aquifer [mm] - REAL, INTENT(INOUT) :: WT !water storage in aquifer - !+ stuarated soil [mm] - REAL, INTENT(INOUT) :: WSLAKE !water storage in lake (can be -) (mm) - REAL , INTENT(INOUT) :: PONDING ![mm] - REAL, INTENT(INOUT) :: SMCWTD !soil water content between bottom of the soil and water table [m3/m3] - REAL, INTENT(INOUT) :: DEEPRECH !recharge to or from the water table when deep [m] - REAL, INTENT(INOUT) :: RECH !recharge to or from the water table when shallow [m] (diagnostic) - -! output - REAL, INTENT(OUT) :: CMC !intercepted water per ground area (mm) - REAL, INTENT(OUT) :: ECAN !evap of intercepted water (mm/s) [+] - REAL, INTENT(OUT) :: ETRAN !transpiration rate (mm/s) [+] - REAL, INTENT(OUT) :: FWET !wetted/snowed fraction of canopy (-) - REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] - REAL, INTENT(OUT) :: RUNSUB !baseflow (sturation excess) [mm/s] - REAL, INTENT(OUT) :: QIN !groundwater recharge [mm/s] - REAL, INTENT(OUT) :: QDIS !groundwater discharge [mm/s] - REAL, INTENT(OUT) :: PONDING1 - REAL, INTENT(OUT) :: PONDING2 - REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] - REAL , INTENT(IN) :: LATHEAV !latent heat vap./sublimation (j/kg) - REAL , INTENT(IN) :: LATHEAG !latent heat vap./sublimation (j/kg) - LOGICAL , INTENT(IN) :: FROZEN_GROUND ! used to define latent heat pathway - LOGICAL , INTENT(IN) :: FROZEN_CANOPY ! used to define latent heat pathway + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [ =3] + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers [ =4] -! local - INTEGER :: IZ - REAL :: QINSUR !water input on soil surface [m/s] - REAL :: QSEVA !soil surface evap rate [mm/s] - REAL :: QSDEW !soil surface dew rate [mm/s] - REAL :: QSNFRO !snow surface frost rate[mm/s] - REAL :: QSNSUB !snow surface sublimation rate [mm/s] - REAL, DIMENSION( 1:NSOIL) :: ETRANI !transpiration rate (mm/s) [+] - REAL, DIMENSION( 1:NSOIL) :: WCND !hydraulic conductivity (m/s) - REAL :: QDRAIN !soil-bottom free drainage [mm/s] - REAL :: SNOFLOW !glacier flow [mm/s] - REAL :: FCRMAX !maximum of FCR (-) +! input and output - REAL, PARAMETER :: WSLMAX = 5000. !maximum lake water storage (mm) + INTEGER , INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO!snow layer depth [m] -#ifdef WRF_HYDRO - REAL , INTENT(INOUT) :: sfcheadrt -#endif +! local variables: + INTEGER :: J !indices + INTEGER :: MSNO !number of layer (top) to MSNO (bot) + REAL :: DRR !thickness of the combined [m] + REAL, DIMENSION( 1:NSNOW) :: DZ !snow layer thickness [m] + REAL, DIMENSION( 1:NSNOW) :: SWICE !partial volume of ice [m3/m3] + REAL, DIMENSION( 1:NSNOW) :: SWLIQ !partial volume of liquid water [m3/m3] + REAL, DIMENSION( 1:NSNOW) :: TSNO !node temperature [k] + REAL :: ZWICE !temporary + REAL :: ZWLIQ !temporary + REAL :: PROPOR!temporary + REAL :: DTDZ !temporary ! ---------------------------------------------------------------------- -! initialize - ETRANI(1:NSOIL) = 0. - SNOFLOW = 0. - RUNSUB = 0. - QINSUR = 0. + DO J = 1,NSNOW + IF (J <= ABS(ISNOW)) THEN + DZ(J) = DZSNSO(J+ISNOW) + SWICE(J) = SNICE(J+ISNOW) + SWLIQ(J) = SNLIQ(J+ISNOW) + TSNO(J) = STC(J+ISNOW) + END IF + END DO -! canopy-intercepted snowfall/rainfall, drips, and throughfall + MSNO = ABS(ISNOW) - CALL CANWATER (VEGTYP ,DT , & !in - FCEV ,FCTR ,ELAI , & !in - ESAI ,TG ,FVEG ,ILOC , JLOC, & !in - BDFALL ,FROZEN_CANOPY , & !in - CANLIQ ,CANICE ,TV , & !inout - CMC ,ECAN ,ETRAN , & !out - FWET ) !out + IF (MSNO == 1) THEN + ! Specify a new snow layer + IF (DZ(1) > 0.05) THEN + MSNO = 2 + DZ(1) = DZ(1)/2. + SWICE(1) = SWICE(1)/2. + SWLIQ(1) = SWLIQ(1)/2. + DZ(2) = DZ(1) + SWICE(2) = SWICE(1) + SWLIQ(2) = SWLIQ(1) + TSNO(2) = TSNO(1) + END IF + END IF -! sublimation, frost, evaporation, and dew + IF (MSNO > 1) THEN + IF (DZ(1) > 0.05) THEN + DRR = DZ(1) - 0.05 + PROPOR = DRR/DZ(1) + ZWICE = PROPOR*SWICE(1) + ZWLIQ = PROPOR*SWLIQ(1) + PROPOR = 0.05/DZ(1) + SWICE(1) = PROPOR*SWICE(1) + SWLIQ(1) = PROPOR*SWLIQ(1) + DZ(1) = 0.05 - QSNSUB = 0. - IF (SNEQV > 0.) THEN - QSNSUB = MIN(QVAP, SNEQV/DT) - ENDIF - QSEVA = QVAP-QSNSUB + CALL COMBO (parameters,DZ(2), SWLIQ(2), SWICE(2), TSNO(2), DRR, & + ZWLIQ, ZWICE, TSNO(1)) + + ! subdivide a new layer + IF (MSNO <= 2 .AND. DZ(2) > 0.20) THEN ! MB: change limit +! IF (MSNO <= 2 .AND. DZ(2) > 0.10) THEN + MSNO = 3 + DTDZ = (TSNO(1) - TSNO(2))/((DZ(1)+DZ(2))/2.) + DZ(2) = DZ(2)/2. + SWICE(2) = SWICE(2)/2. + SWLIQ(2) = SWLIQ(2)/2. + DZ(3) = DZ(2) + SWICE(3) = SWICE(2) + SWLIQ(3) = SWLIQ(2) + TSNO(3) = TSNO(2) - DTDZ*DZ(2)/2. + IF (TSNO(3) >= TFRZ) THEN + TSNO(3) = TSNO(2) + ELSE + TSNO(2) = TSNO(2) + DTDZ*DZ(2)/2. + ENDIF - QSNFRO = 0. - IF (SNEQV > 0.) THEN - QSNFRO = QDEW - ENDIF - QSDEW = QDEW - QSNFRO + END IF + END IF + END IF - CALL SNOWWATER (NSNOW ,NSOIL ,IMELT ,DT ,ZSOIL , & !in - & SFCTMP ,SNOWHIN,QSNOW ,QSNFRO ,QSNSUB , & !in - & QRAIN ,FICEOLD,ILOC ,JLOC , & !in - & ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout - & SH2O ,SICE ,STC ,ZSNSO ,DZSNSO , & !inout - & QSNBOT ,SNOFLOW,PONDING1 ,PONDING2) !out + IF (MSNO > 2) THEN + IF (DZ(2) > 0.2) THEN + DRR = DZ(2) - 0.2 + PROPOR = DRR/DZ(2) + ZWICE = PROPOR*SWICE(2) + ZWLIQ = PROPOR*SWLIQ(2) + PROPOR = 0.2/DZ(2) + SWICE(2) = PROPOR*SWICE(2) + SWLIQ(2) = PROPOR*SWLIQ(2) + DZ(2) = 0.2 + CALL COMBO (parameters,DZ(3), SWLIQ(3), SWICE(3), TSNO(3), DRR, & + ZWLIQ, ZWICE, TSNO(2)) + END IF + END IF - IF(FROZEN_GROUND) THEN - SICE(1) = SICE(1) + (QSDEW-QSEVA)*DT/(DZSNSO(1)*1000.) - QSDEW = 0.0 - QSEVA = 0.0 - IF(SICE(1) < 0.) THEN - SH2O(1) = SH2O(1) + SICE(1) - SICE(1) = 0. - END IF - END IF + ISNOW = -MSNO -! convert units (mm/s -> m/s) + DO J = ISNOW+1,0 + DZSNSO(J) = DZ(J-ISNOW) + SNICE(J) = SWICE(J-ISNOW) + SNLIQ(J) = SWLIQ(J-ISNOW) + STC(J) = TSNO(J-ISNOW) + END DO - !PONDING: melting water from snow when there is no layer - QINSUR = (PONDING+PONDING1+PONDING2)/DT * 0.001 -! QINSUR = PONDING/DT * 0.001 - IF(ISNOW == 0) THEN - QINSUR = QINSUR+(QSNBOT + QSDEW + QRAIN) * 0.001 - ELSE - QINSUR = QINSUR+(QSNBOT + QSDEW) * 0.001 - ENDIF +! DO J = ISNOW+1,NSOIL +! WRITE(*,'(I5,7F10.3)') J, DZSNSO(J), SNICE(J), SNLIQ(J),STC(J) +! END DO - QSEVA = QSEVA * 0.001 + END SUBROUTINE DIVIDE - DO IZ = 1, NROOT - ETRANI(IZ) = ETRAN * BTRANI(IZ) * 0.001 - ENDDO +!== begin combo ==================================================================================== -#ifdef WRF_HYDRO - QINSUR = QINSUR+sfcheadrt/DT*0.001 !sfcheadrt units (m) -#endif + SUBROUTINE COMBO(parameters,DZ, WLIQ, WICE, T, DZ2, WLIQ2, WICE2, T2) +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- -! lake/soil water balances +! ----------------------------------------------------------------------s +! input - IF (IST == 2) THEN ! lake - RUNSRF = 0. - IF(WSLAKE >= WSLMAX) RUNSRF = QINSUR*1000. !mm/s - WSLAKE = WSLAKE + (QINSUR-QSEVA)*1000.*DT -RUNSRF*DT !mm - ELSE ! soil - CALL SOILWATER (NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in - QINSUR ,QSEVA ,ETRANI ,SICE ,ILOC , JLOC , & !in - SH2O ,SMC ,ZWT ,VEGTYP , & !inout - SMCWTD, DEEPRECH , & !inout - RUNSRF ,QDRAIN ,RUNSUB ,WCND ,FCRMAX ) !out - - IF(OPT_RUN == 1) THEN - CALL GROUNDWATER (NSNOW ,NSOIL ,DT ,SICE ,ZSOIL , & !in - STC ,WCND ,FCRMAX ,ILOC ,JLOC , & !in - SH2O ,ZWT ,WA ,WT , & !inout - QIN ,QDIS ) !out - RUNSUB = QDIS !mm/s - END IF + type (noahmp_parameters), intent(in) :: parameters + REAL, INTENT(IN) :: DZ2 !nodal thickness of 2 elements being combined [m] + REAL, INTENT(IN) :: WLIQ2 !liquid water of element 2 [kg/m2] + REAL, INTENT(IN) :: WICE2 !ice of element 2 [kg/m2] + REAL, INTENT(IN) :: T2 !nodal temperature of element 2 [k] + REAL, INTENT(INOUT) :: DZ !nodal thickness of 1 elements being combined [m] + REAL, INTENT(INOUT) :: WLIQ !liquid water of element 1 + REAL, INTENT(INOUT) :: WICE !ice of element 1 [kg/m2] + REAL, INTENT(INOUT) :: T !node temperature of element 1 [k] - IF(OPT_RUN == 3 .or. OPT_RUN == 4) THEN - RUNSUB = RUNSUB + QDRAIN !mm/s - END IF +! local - DO IZ = 1,NSOIL - SMC(IZ) = SH2O(IZ) + SICE(IZ) - ENDDO - - IF(OPT_RUN == 5) THEN - CALL SHALLOWWATERTABLE (NSNOW ,NSOIL, ZSOIL, DT , & !in - DZSNSO ,SMCEQ ,ILOC , JLOC , & !in - SMC ,ZWT ,SMCWTD ,RECH, QDRAIN ) !inout + REAL :: DZC !total thickness of nodes 1 and 2 (DZC=DZ+DZ2). + REAL :: WLIQC !combined liquid water [kg/m2] + REAL :: WICEC !combined ice [kg/m2] + REAL :: TC !combined node temperature [k] + REAL :: H !enthalpy of element 1 [J/m2] + REAL :: H2 !enthalpy of element 2 [J/m2] + REAL :: HC !temporary - SH2O(NSOIL) = SMC(NSOIL) - SICE(NSOIL) - RUNSUB = RUNSUB + QDRAIN !it really comes from subroutine watertable, which is not called with the same frequency as the soil routines here - WA = 0. - ENDIF +!----------------------------------------------------------------------- - ENDIF + DZC = DZ+DZ2 + WICEC = (WICE+WICE2) + WLIQC = (WLIQ+WLIQ2) + H = (CICE*WICE+CWAT*WLIQ) * (T-TFRZ)+HFUS*WLIQ + H2= (CICE*WICE2+CWAT*WLIQ2) * (T2-TFRZ)+HFUS*WLIQ2 - RUNSUB = RUNSUB + SNOFLOW !mm/s + HC = H + H2 + IF(HC < 0.)THEN + TC = TFRZ + HC/(CICE*WICEC + CWAT*WLIQC) + ELSE IF (HC.LE.HFUS*WLIQC) THEN + TC = TFRZ + ELSE + TC = TFRZ + (HC - HFUS*WLIQC) / (CICE*WICEC + CWAT*WLIQC) + END IF - END SUBROUTINE WATER + DZ = DZC + WICE = WICEC + WLIQ = WLIQC + T = TC -!== begin canwater ================================================================================= + END SUBROUTINE COMBO - SUBROUTINE CANWATER (VEGTYP ,DT , & !in - FCEV ,FCTR ,ELAI , & !in - ESAI ,TG ,FVEG ,ILOC , JLOC , & !in - BDFALL ,FROZEN_CANOPY , & !in - CANLIQ ,CANICE ,TV , & !inout - CMC ,ECAN ,ETRAN , & !out - FWET ) !out +!== begin compact ================================================================================== -! ------------------------ code history ------------------------------ -! canopy hydrology -! -------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: CH2OP, & ! VEGETATION DEPENDENT - TFRZ, DENH2O, DENICE, CICE, CWAT, HVAP, HSUB, HFUS ! MP CONSTANT -! -------------------------------------------------------------------- + SUBROUTINE COMPACT (parameters,NSNOW ,NSOIL ,DT ,STC ,SNICE , & !in + SNLIQ ,ZSOIL ,IMELT ,FICEOLD,ILOC , JLOC , & !in + ISNOW ,DZSNSO ,ZSNSO ) !inout +! ---------------------------------------------------------------------- IMPLICIT NONE -! ------------------------ input/output variables -------------------- +! ---------------------------------------------------------------------- ! input - INTEGER,INTENT(IN) :: ILOC !grid index - INTEGER,INTENT(IN) :: JLOC !grid index - INTEGER,INTENT(IN) :: VEGTYP !vegetation type - REAL, INTENT(IN) :: DT !main time step (s) - REAL, INTENT(IN) :: FCEV !canopy evaporation (w/m2) [+ = to atm] - REAL, INTENT(IN) :: FCTR !transpiration (w/m2) [+ = to atm] - REAL, INTENT(IN) :: ELAI !leaf area index, after burying by snow - REAL, INTENT(IN) :: ESAI !stem area index, after burying by snow - REAL, INTENT(IN) :: TG !ground temperature (k) - REAL, INTENT(IN) :: FVEG !greeness vegetation fraction (-) - LOGICAL , INTENT(IN) :: FROZEN_CANOPY ! used to define latent heat pathway - REAL , INTENT(IN) :: BDFALL !bulk density of snowfall (kg/m3) ! MB/AN: v3.7 + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers [ =4] + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [ =3] + INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [0-no melt;1-melt] + REAL, INTENT(IN) :: DT !time step (sec) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow layer temperature [k] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil srf + REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD!ice fraction at last timestep -! input & output - REAL, INTENT(INOUT) :: CANLIQ !intercepted liquid water (mm) - REAL, INTENT(INOUT) :: CANICE !intercepted ice mass (mm) - REAL, INTENT(INOUT) :: TV !vegetation temperature (k) +! input and output + INTEGER, INTENT(INOUT) :: ISNOW ! actual no. of snow layers + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO ! snow layer thickness [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO ! depth of snow/soil layer-bottom -! output - REAL, INTENT(OUT) :: CMC !intercepted water (mm) - REAL, INTENT(OUT) :: ECAN !evaporation of intercepted water (mm/s) [+] - REAL, INTENT(OUT) :: ETRAN !transpiration rate (mm/s) [+] - REAL, INTENT(OUT) :: FWET !wetted or snowed fraction of the canopy (-) -! -------------------------------------------------------------------- +! local + REAL, PARAMETER :: C2 = 21.e-3 ![m3/kg] ! default 21.e-3 + REAL, PARAMETER :: C3 = 2.5e-6 ![1/s] + REAL, PARAMETER :: C4 = 0.04 ![1/k] + REAL, PARAMETER :: C5 = 2.0 ! + REAL, PARAMETER :: DM = 100.0 !upper Limit on destructive metamorphism compaction [kg/m3] + REAL, PARAMETER :: ETA0 = 0.8e+6 !viscosity coefficient [kg-s/m2] + !according to Anderson, it is between 0.52e6~1.38e6 + REAL :: BURDEN !pressure of overlying snow [kg/m2] + REAL :: DDZ1 !rate of settling of snow pack due to destructive metamorphism. + REAL :: DDZ2 !rate of compaction of snow pack due to overburden. + REAL :: DDZ3 !rate of compaction of snow pack due to melt [1/s] + REAL :: DEXPF !EXPF=exp(-c4*(273.15-STC)). + REAL :: TD !STC - TFRZ [K] + REAL :: PDZDTC !nodal rate of change in fractional-thickness due to compaction [fraction/s] + REAL :: VOID !void (1 - SNICE - SNLIQ) + REAL :: WX !water mass (ice + liquid) [kg/m2] + REAL :: BI !partial density of ice [kg/m3] + REAL, DIMENSION(-NSNOW+1:0) :: FICE !fraction of ice at current time step -! ------------------------ local variables --------------------------- - REAL :: MAXSNO !canopy capacity for snow interception (mm) - REAL :: MAXLIQ !canopy capacity for rain interception (mm) - REAL :: QEVAC !evaporation rate (mm/s) - REAL :: QDEWC !dew rate (mm/s) - REAL :: QFROC !frost rate (mm/s) - REAL :: QSUBC !sublimation rate (mm/s) - REAL :: QMELTC !melting rate of canopy snow (mm/s) - REAL :: QFRZC !refreezing rate of canopy liquid water (mm/s) - REAL :: CANMAS !total canopy mass (kg/m2) -! -------------------------------------------------------------------- -! initialization + INTEGER :: J - ECAN = 0.0 +! ---------------------------------------------------------------------- + BURDEN = 0.0 -! --------------------------- liquid water ------------------------------ -! maximum canopy water + DO J = ISNOW+1, 0 - MAXLIQ = CH2OP * (ELAI+ ESAI) + WX = SNICE(J) + SNLIQ(J) + FICE(J) = SNICE(J) / WX + VOID = 1. - (SNICE(J)/DENICE + SNLIQ(J)/DENH2O) / DZSNSO(J) -! evaporation, transpiration, and dew + ! Allow compaction only for non-saturated node and higher ice lens node. + IF (VOID > 0.001 .AND. SNICE(J) > 0.1) THEN + BI = SNICE(J) / DZSNSO(J) + TD = MAX(0.,TFRZ-STC(J)) + DEXPF = EXP(-C4*TD) - IF (.NOT.FROZEN_CANOPY) THEN ! Barlage: change to frozen_canopy - ETRAN = MAX( FCTR/HVAP, 0. ) - QEVAC = MAX( FCEV/HVAP, 0. ) - QDEWC = ABS( MIN( FCEV/HVAP, 0. ) ) - QSUBC = 0. - QFROC = 0. - ELSE - ETRAN = MAX( FCTR/HSUB, 0. ) - QEVAC = 0. - QDEWC = 0. - QSUBC = MAX( FCEV/HSUB, 0. ) - QFROC = ABS( MIN( FCEV/HSUB, 0. ) ) - ENDIF + ! Settling as a result of destructive metamorphism -! canopy water balance. for convenience allow dew to bring CANLIQ above -! maxh2o or else would have to re-adjust drip + DDZ1 = -C3*DEXPF + + IF (BI > DM) DDZ1 = DDZ1*EXP(-46.0E-3*(BI-DM)) - QEVAC = MIN(CANLIQ/DT,QEVAC) - CANLIQ=MAX(0.,CANLIQ+(QDEWC-QEVAC)*DT) - IF(CANLIQ <= 1.E-06) CANLIQ = 0.0 + ! Liquid water term -! --------------------------- canopy ice ------------------------------ -! for canopy ice + IF (SNLIQ(J) > 0.01*DZSNSO(J)) DDZ1=DDZ1*C5 - MAXSNO = 6.6*(0.27+46./BDFALL) * (ELAI+ ESAI) + ! Compaction due to overburden - QSUBC = MIN(CANICE/DT,QSUBC) - CANICE= MAX(0.,CANICE + (QFROC-QSUBC)*DT) - IF(CANICE.LE.1.E-6) CANICE = 0. - -! wetted fraction of canopy + DDZ2 = -(BURDEN+0.5*WX)*EXP(-0.08*TD-C2*BI)/ETA0 ! 0.5*WX -> self-burden - IF(CANICE.GT.0.) THEN - FWET = MAX(0.,CANICE) / MAX(MAXSNO,1.E-06) - ELSE - FWET = MAX(0.,CANLIQ) / MAX(MAXLIQ,1.E-06) - ENDIF - FWET = MIN(FWET, 1.) ** 0.667 + ! Compaction occurring during melt -! phase change + IF (IMELT(J) == 1) THEN + DDZ3 = MAX(0.,(FICEOLD(J) - FICE(J))/MAX(1.E-6,FICEOLD(J))) + DDZ3 = - DDZ3/DT ! sometimes too large + ELSE + DDZ3 = 0. + END IF - QMELTC = 0. - QFRZC = 0. + ! Time rate of fractional change in DZ (units of s-1) - IF(CANICE.GT.1.E-6.AND.TV.GT.TFRZ) THEN - QMELTC = MIN(CANICE/DT,(TV-TFRZ)*CICE*CANICE/DENICE/(DT*HFUS)) - CANICE = MAX(0.,CANICE - QMELTC*DT) - CANLIQ = MAX(0.,CANLIQ + QMELTC*DT) - TV = FWET*TFRZ + (1.-FWET)*TV - ENDIF + PDZDTC = (DDZ1 + DDZ2 + DDZ3)*DT + PDZDTC = MAX(-0.5,PDZDTC) - IF(CANLIQ.GT.1.E-6.AND.TV.LT.TFRZ) THEN - QFRZC = MIN(CANLIQ/DT,(TFRZ-TV)*CWAT*CANLIQ/DENH2O/(DT*HFUS)) - CANLIQ = MAX(0.,CANLIQ - QFRZC*DT) - CANICE = MAX(0.,CANICE + QFRZC*DT) - TV = FWET*TFRZ + (1.-FWET)*TV - ENDIF + ! The change in DZ due to compaction -! total canopy water + DZSNSO(J) = DZSNSO(J)*(1.+PDZDTC) + END IF - CMC = CANLIQ + CANICE + ! Pressure of overlying snow -! total canopy evaporation + BURDEN = BURDEN + WX - ECAN = QEVAC + QSUBC - QDEWC - QFROC + END DO - END SUBROUTINE CANWATER + END SUBROUTINE COMPACT -!== begin snowwater ================================================================================ +!== begin snowh2o ================================================================================== - SUBROUTINE SNOWWATER (NSNOW ,NSOIL ,IMELT ,DT ,ZSOIL , & !in - SFCTMP ,SNOWHIN,QSNOW ,QSNFRO ,QSNSUB , & !in - QRAIN ,FICEOLD,ILOC ,JLOC , & !in - ISNOW ,SNOWH ,SNEQV ,SNICE ,SNLIQ , & !inout - SH2O ,SICE ,STC ,ZSNSO ,DZSNSO , & !inout - QSNBOT ,SNOFLOW,PONDING1 ,PONDING2) !out + SUBROUTINE SNOWH2O (parameters,NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in + QRAIN ,ILOC ,JLOC , & !in + ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout + SNLIQ ,SH2O ,SICE ,STC , & !inout + QSNBOT ,PONDING1 ,PONDING2) !out ! ---------------------------------------------------------------------- - IMPLICIT NONE +! Renew the mass of ice lens (SNICE) and liquid (SNLIQ) of the +! surface snow layer resulting from sublimation (frost) / evaporation (dew) +! ---------------------------------------------------------------------- + IMPLICIT NONE ! ---------------------------------------------------------------------- ! input - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER, INTENT(IN) :: NSOIL !no. of soil layers - INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [0-no melt;1-melt] - REAL, INTENT(IN) :: DT !time step (s) - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil surface - REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] - REAL, INTENT(IN) :: SNOWHIN!snow depth increasing rate (m/s) - REAL, INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] - REAL, INTENT(IN) :: QSNFRO !snow surface frost rate[mm/s] - REAL, INTENT(IN) :: QSNSUB !snow surface sublimation rate[mm/s] - REAL, INTENT(IN) :: QRAIN !snow surface rain rate[mm/s] - REAL, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: FICEOLD!ice fraction at last timestep -! input & output - INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers - REAL, INTENT(INOUT) :: SNOWH !snow height [m] - REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO !depth of snow/soil layer-bottom - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !snow/soil layer thickness [m] + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers[=3] + INTEGER, INTENT(IN) :: NSOIL !No. of soil layers[=4] + REAL, INTENT(IN) :: DT !time step + REAL, INTENT(IN) :: QSNFRO !snow surface frost rate[mm/s] + REAL, INTENT(IN) :: QSNSUB !snow surface sublimation rate[mm/s] + REAL, INTENT(IN) :: QRAIN !snow surface rain rate[mm/s] ! output - REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] - REAL, INTENT(OUT) :: SNOFLOW!glacier flow [mm] - REAL, INTENT(OUT) :: PONDING1 - REAL, INTENT(OUT) :: PONDING2 -! local - INTEGER :: IZ,i - REAL :: BDSNOW !bulk density of snow (kg/m3) -! ---------------------------------------------------------------------- - SNOFLOW = 0.0 - PONDING1 = 0.0 - PONDING2 = 0.0 + REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] - CALL SNOWFALL (NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN, & !in - SFCTMP ,ILOC ,JLOC , & !in - ISNOW ,SNOWH ,DZSNSO ,STC ,SNICE , & !inout - SNLIQ ,SNEQV ) !inout +! input and output -! MB: do each if block separately + INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO ! snow layer depth [m] + REAL, INTENT(INOUT) :: SNOWH !snow height [m] + REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] + REAL, DIMENSION(-NSNOW+1:0), INTENT(INOUT) :: SNICE !snow layer ice [mm] + REAL, DIMENSION(-NSNOW+1:0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] - IF(ISNOW < 0) & ! when multi-layer - CALL COMPACT (NSNOW ,NSOIL ,DT ,STC ,SNICE , & !in - SNLIQ ,ZSOIL ,IMELT ,FICEOLD,ILOC , JLOC ,& !in - ISNOW ,DZSNSO ,ZSNSO ) !inout +! local variables: - IF(ISNOW < 0) & !when multi-layer - CALL COMBINE (NSNOW ,NSOIL ,ILOC ,JLOC , & !in - ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout - DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout - PONDING1 ,PONDING2) !out + INTEGER :: J !do loop/array indices + REAL :: QIN !water flow into the element (mm/s) + REAL :: QOUT !water flow out of the element (mm/s) + REAL :: WGDIF !ice mass after minus sublimation + REAL, DIMENSION(-NSNOW+1:0) :: VOL_LIQ !partial volume of liquid water in layer + REAL, DIMENSION(-NSNOW+1:0) :: VOL_ICE !partial volume of ice lens in layer + REAL, DIMENSION(-NSNOW+1:0) :: EPORE !effective porosity = porosity - VOL_ICE + REAL :: PROPOR, TEMP + REAL :: PONDING1, PONDING2 +! ---------------------------------------------------------------------- - IF(ISNOW < 0) & !when multi-layer - CALL DIVIDE (NSNOW ,NSOIL , & !in - ISNOW ,STC ,SNICE ,SNLIQ ,DZSNSO ) !inout +!for the case when SNEQV becomes '0' after 'COMBINE' - CALL SNOWH2O (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in - QRAIN ,ILOC ,JLOC , & !in - ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout - SNLIQ ,SH2O ,SICE ,STC , & !inout - QSNBOT ,PONDING1 ,PONDING2) !out + IF(SNEQV == 0.) THEN + SICE(1) = SICE(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.) ! Barlage: SH2O->SICE v3.6 + IF(SICE(1) < 0.) THEN + SH2O(1) = SH2O(1) + SICE(1) + SICE(1) = 0. + END IF + END IF -!set empty snow layers to zero +! for shallow snow without a layer +! snow surface sublimation may be larger than existing snow mass. To conserve water, +! excessive sublimation is used to reduce soil water. Smaller time steps would tend +! to aviod this problem. - do iz = -nsnow+1, isnow - snice(iz) = 0. - snliq(iz) = 0. - stc(iz) = 0. - dzsnso(iz)= 0. - zsnso(iz) = 0. - enddo + IF(ISNOW == 0 .and. SNEQV > 0.) THEN + TEMP = SNEQV + SNEQV = SNEQV - QSNSUB*DT + QSNFRO*DT + PROPOR = SNEQV/TEMP + SNOWH = MAX(0.,PROPOR * SNOWH) -!to obtain equilibrium state of snow in glacier region - - IF(SNEQV > 2000.) THEN ! 2000 mm -> maximum water depth - BDSNOW = SNICE(0) / DZSNSO(0) - SNOFLOW = (SNEQV - 2000.) - SNICE(0) = SNICE(0) - SNOFLOW - DZSNSO(0) = DZSNSO(0) - SNOFLOW/BDSNOW - SNOFLOW = SNOFLOW / DT + IF(SNEQV < 0.) THEN + SICE(1) = SICE(1) + SNEQV/(DZSNSO(1)*1000.) + SNEQV = 0. + SNOWH = 0. + END IF + IF(SICE(1) < 0.) THEN + SH2O(1) = SH2O(1) + SICE(1) + SICE(1) = 0. + END IF END IF -! sum up snow mass for layered snow - - IF(ISNOW < 0) THEN ! MB: only do for multi-layer - SNEQV = 0. - DO IZ = ISNOW+1,0 - SNEQV = SNEQV + SNICE(IZ) + SNLIQ(IZ) - ENDDO + IF(SNOWH <= 1.E-8 .OR. SNEQV <= 1.E-6) THEN + SNOWH = 0.0 + SNEQV = 0.0 END IF -! Reset ZSNSO and layer thinkness DZSNSO +! for deep snow - DO IZ = ISNOW+1, 0 - DZSNSO(IZ) = -DZSNSO(IZ) + IF ( ISNOW < 0 ) THEN !KWM added this IF statement to prevent out-of-bounds array references + + WGDIF = SNICE(ISNOW+1) - QSNSUB*DT + QSNFRO*DT + SNICE(ISNOW+1) = WGDIF + IF (WGDIF < 1.e-6 .and. ISNOW <0) THEN + CALL COMBINE (parameters,NSNOW ,NSOIL ,ILOC, JLOC , & !in + ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout + DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout + PONDING1, PONDING2 ) !out + ENDIF + !KWM: Subroutine COMBINE can change ISNOW to make it 0 again? + IF ( ISNOW < 0 ) THEN !KWM added this IF statement to prevent out-of-bounds array references + SNLIQ(ISNOW+1) = SNLIQ(ISNOW+1) + QRAIN * DT + SNLIQ(ISNOW+1) = MAX(0., SNLIQ(ISNOW+1)) + ENDIF + + ENDIF !KWM -- Can the ENDIF be moved toward the end of the subroutine (Just set QSNBOT=0)? + +! Porosity and partial volume + + !KWM Looks to me like loop index / IF test can be simplified. + + DO J = -NSNOW+1, 0 + IF (J >= ISNOW+1) THEN + VOL_ICE(J) = MIN(1., SNICE(J)/(DZSNSO(J)*DENICE)) + EPORE(J) = 1. - VOL_ICE(J) + VOL_LIQ(J) = MIN(EPORE(J),SNLIQ(J)/(DZSNSO(J)*DENH2O)) + END IF + END DO + + QIN = 0. + QOUT = 0. + + !KWM Looks to me like loop index / IF test can be simplified. + + DO J = -NSNOW+1, 0 + IF (J >= ISNOW+1) THEN + SNLIQ(J) = SNLIQ(J) + QIN + IF (J <= -1) THEN + IF (EPORE(J) < 0.05 .OR. EPORE(J+1) < 0.05) THEN + QOUT = 0. + ELSE + QOUT = MAX(0.,(VOL_LIQ(J)-parameters%SSI*EPORE(J))*DZSNSO(J)) + QOUT = MIN(QOUT,(1.-VOL_ICE(J+1)-VOL_LIQ(J+1))*DZSNSO(J+1)) + END IF + ELSE + QOUT = MAX(0.,(VOL_LIQ(J) - parameters%SSI*EPORE(J))*DZSNSO(J)) + END IF + QOUT = QOUT*1000. + SNLIQ(J) = SNLIQ(J) - QOUT + QIN = QOUT + END IF END DO - DZSNSO(1) = ZSOIL(1) - DO IZ = 2,NSOIL - DZSNSO(IZ) = (ZSOIL(IZ) - ZSOIL(IZ-1)) - END DO +! Liquid water from snow bottom to soil - ZSNSO(ISNOW+1) = DZSNSO(ISNOW+1) - DO IZ = ISNOW+2 ,NSOIL - ZSNSO(IZ) = ZSNSO(IZ-1) + DZSNSO(IZ) - ENDDO + QSNBOT = QOUT / DT ! mm/s - DO IZ = ISNOW+1 ,NSOIL - DZSNSO(IZ) = -DZSNSO(IZ) - END DO + END SUBROUTINE SNOWH2O - END SUBROUTINE SNOWWATER +!== begin soilwater ================================================================================ -!== begin snowfall ================================================================================= + SUBROUTINE SOILWATER (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in + QINSUR ,QSEVA ,ETRANI ,SICE ,ILOC , JLOC, & !in + SH2O ,SMC ,ZWT ,VEGTYP ,& !inout + SMCWTD, DEEPRECH ,& !inout + RUNSRF ,QDRAIN ,RUNSUB ,WCND ,FCRMAX ) !out - SUBROUTINE SNOWFALL (NSOIL ,NSNOW ,DT ,QSNOW ,SNOWHIN , & !in - SFCTMP ,ILOC ,JLOC , & !in - ISNOW ,SNOWH ,DZSNSO ,STC ,SNICE , & !inout - SNLIQ ,SNEQV ) !inout ! ---------------------------------------------------------------------- -! snow depth and density to account for the new snowfall. -! new values of snow depth & density returned. +! calculate surface runoff and soil moisture. ! ---------------------------------------------------------------------- - IMPLICIT NONE +! ---------------------------------------------------------------------- + IMPLICIT NONE ! ---------------------------------------------------------------------- ! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + REAL, INTENT(IN) :: DT !time step (sec) + REAL, INTENT(IN) :: QINSUR !water input on soil surface [mm/s] + REAL, INTENT(IN) :: QSEVA !evap from soil surface [mm/s] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ETRANI !evapotranspiration from soil layers [mm/s] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer depth [m] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE !soil ice content [m3/m3] - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: NSOIL !no. of soil layers - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers - REAL, INTENT(IN) :: DT !main time step (s) - REAL, INTENT(IN) :: QSNOW !snow at ground srf (mm/s) [+] - REAL, INTENT(IN) :: SNOWHIN!snow depth increasing rate (m/s) - REAL, INTENT(IN) :: SFCTMP !surface air temperature [k] + INTEGER, INTENT(IN) :: VEGTYP -! input and output +! input & output + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water content [m3/m3] + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC !total soil water content [m3/m3] + REAL, INTENT(INOUT) :: ZWT !water table depth [m] + REAL, INTENT(INOUT) :: SMCWTD !soil moisture between bottom of the soil and the water table [m3/m3] + REAL , INTENT(INOUT) :: DEEPRECH - INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers - REAL, INTENT(INOUT) :: SNOWH !snow depth [m] - REAL, INTENT(INOUT) :: SNEQV !swow water equivalent [m] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO !thickness of snow/soil layers (m) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] +! output + REAL, INTENT(OUT) :: QDRAIN !soil-bottom free drainage [mm/s] + REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL, INTENT(OUT) :: RUNSUB !subsurface runoff [mm/s] + REAL, INTENT(OUT) :: FCRMAX !maximum of FCR (-) + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: WCND !hydraulic conductivity (m/s) ! local + INTEGER :: K,IZ !do-loop index + INTEGER :: ITER !iteration index + REAl :: DTFINE !fine time step (s) + REAL, DIMENSION(1:NSOIL) :: RHSTT !right-hand side term of the matrix + REAL, DIMENSION(1:NSOIL) :: AI !left-hand side term + REAL, DIMENSION(1:NSOIL) :: BI !left-hand side term + REAL, DIMENSION(1:NSOIL) :: CI !left-hand side term - INTEGER :: NEWNODE ! 0-no new layers, 1-creating new layers -! ---------------------------------------------------------------------- - NEWNODE = 0 - -! shallow snow / no layer - - IF(ISNOW == 0 .and. QSNOW > 0.) THEN - SNOWH = SNOWH + SNOWHIN * DT - SNEQV = SNEQV + QSNOW * DT - END IF - -! creating a new layer - - IF(ISNOW == 0 .AND. QSNOW>0. .AND. SNOWH >= 0.025) THEN !MB: change limit -! IF(ISNOW == 0 .AND. QSNOW>0. .AND. SNOWH >= 0.05) THEN - ISNOW = -1 - NEWNODE = 1 - DZSNSO(0)= SNOWH - SNOWH = 0. - STC(0) = MIN(273.16, SFCTMP) ! temporary setup - SNICE(0) = SNEQV - SNLIQ(0) = 0. - END IF - -! snow with layers - - IF(ISNOW < 0 .AND. NEWNODE == 0 .AND. QSNOW > 0.) then - SNICE(ISNOW+1) = SNICE(ISNOW+1) + QSNOW * DT - DZSNSO(ISNOW+1) = DZSNSO(ISNOW+1) + SNOWHIN * DT - ENDIF - + REAL :: FFF !runoff decay factor (m-1) + REAL :: RSBMX !baseflow coefficient [mm/s] + REAL :: PDDUM !infiltration rate at surface (m/s) + REAL :: FICE !ice fraction in frozen soil + REAL :: WPLUS !saturation excess of the total soil [m] + REAL :: RSAT !accumulation of WPLUS (saturation excess) [m] + REAL :: SICEMAX!maximum soil ice content (m3/m3) + REAL :: SH2OMIN!minimum soil liquid water content (m3/m3) + REAL :: WTSUB !sum of WCND(K)*DZSNSO(K) + REAL :: MH2O !water mass removal (mm) + REAL :: FSAT !fractional saturated area (-) + REAL, DIMENSION(1:NSOIL) :: MLIQ ! + REAL :: XS ! + REAL :: WATMIN ! + REAL :: QDRAIN_SAVE ! + REAL :: EPORE !effective porosity [m3/m3] + REAL, DIMENSION(1:NSOIL) :: FCR !impermeable fraction due to frozen soil + INTEGER :: NITER !iteration times soil moisture (-) + REAL :: SMCTOT !2-m averaged soil moisture (m3/m3) + REAL :: DZTOT !2-m soil depth (m) + REAL, PARAMETER :: A = 4.0 ! ---------------------------------------------------------------------- - END SUBROUTINE SNOWFALL - -!== begin combine ================================================================================== + RUNSRF = 0.0 + PDDUM = 0.0 + RSAT = 0.0 - SUBROUTINE COMBINE (NSNOW ,NSOIL ,ILOC ,JLOC , & !in - ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout - DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout - PONDING1 ,PONDING2) !out -! ---------------------------------------------------------------------- - IMPLICIT NONE -! ---------------------------------------------------------------------- -! input +! for the case when snowmelt water is too large - INTEGER, INTENT(IN) :: ILOC - INTEGER, INTENT(IN) :: JLOC - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + DO K = 1,NSOIL + EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(K) - SICE(K) ) ) + RSAT = RSAT + MAX(0.,SH2O(K)-EPORE)*DZSNSO(K) + SH2O(K) = MIN(EPORE,SH2O(K)) + END DO -! input and output +!impermeable fraction due to frozen soil - INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO!snow layer depth [m] - REAL, INTENT(INOUT) :: sneqv !snow water equivalent [m] - REAL, INTENT(INOUT) :: snowh !snow depth [m] - REAL, INTENT(OUT) :: PONDING1 - REAL, INTENT(OUT) :: PONDING2 + DO K = 1,NSOIL + FICE = MIN(1.0,SICE(K)/parameters%SMCMAX(K)) + FCR(K) = MAX(0.0,EXP(-A*(1.-FICE))- EXP(-A)) / & + (1.0 - EXP(-A)) + END DO -! local variables: +! maximum soil ice content and minimum liquid water of all layers - INTEGER :: I,J,K,L ! node indices - INTEGER :: ISNOW_OLD ! number of top snow layer - INTEGER :: MSSI ! node index - INTEGER :: NEIBOR ! adjacent node selected for combination - REAL :: ZWICE ! total ice mass in snow - REAL :: ZWLIQ ! total liquid water in snow + SICEMAX = 0.0 + FCRMAX = 0.0 + SH2OMIN = parameters%SMCMAX(1) + DO K = 1,NSOIL + IF (SICE(K) > SICEMAX) SICEMAX = SICE(K) + IF (FCR(K) > FCRMAX) FCRMAX = FCR(K) + IF (SH2O(K) < SH2OMIN) SH2OMIN = SH2O(K) + END DO - REAL :: DZMIN(3) ! minimum of top snow layer -! DATA DZMIN /0.045, 0.05, 0.2/ - DATA DZMIN /0.025, 0.025, 0.1/ ! MB: change limit -!----------------------------------------------------------------------- +!subsurface runoff for runoff scheme option 2 - ISNOW_OLD = ISNOW + IF(OPT_RUN == 2) THEN + FFF = 2.0 + RSBMX = 4.0 + CALL ZWTEQ (parameters,NSOIL ,NSNOW ,ZSOIL ,DZSNSO ,SH2O ,ZWT) + RUNSUB = (1.0-FCRMAX) * RSBMX * EXP(-parameters%TIMEAN) * EXP(-FFF*ZWT) ! mm/s + END IF - DO J = ISNOW_OLD+1,0 - IF (SNICE(J) <= .1) THEN - IF(J /= 0) THEN - SNLIQ(J+1) = SNLIQ(J+1) + SNLIQ(J) - SNICE(J+1) = SNICE(J+1) + SNICE(J) - ELSE - IF (ISNOW_OLD < -1) THEN ! MB/KM: change to ISNOW - SNLIQ(J-1) = SNLIQ(J-1) + SNLIQ(J) - SNICE(J-1) = SNICE(J-1) + SNICE(J) - ELSE - IF(SNICE(J) >= 0.) THEN - PONDING1 = SNLIQ(J) ! ISNOW WILL GET SET TO ZERO BELOW; PONDING1 WILL GET - SNEQV = SNICE(J) ! ADDED TO PONDING FROM PHASECHANGE PONDING SHOULD BE - SNOWH = DZSNSO(J) ! ZERO HERE BECAUSE IT WAS CALCULATED FOR THIN SNOW - ELSE ! SNICE OVER-SUBLIMATED EARLIER - PONDING1 = SNLIQ(J) + SNICE(J) - IF(PONDING1 < 0.) THEN ! IF SNICE AND SNLIQ SUBLIMATES REMOVE FROM SOIL - SICE(1) = MAX(0.0,SICE(1)+PONDING1/(DZSNSO(1)*1000.)) - PONDING1 = 0.0 - END IF - SNEQV = 0.0 - SNOWH = 0.0 - END IF - SNLIQ(J) = 0.0 - SNICE(J) = 0.0 - DZSNSO(J) = 0.0 - ENDIF -! SH2O(1) = SH2O(1)+SNLIQ(J)/(DZSNSO(1)*1000.) -! SICE(1) = SICE(1)+SNICE(J)/(DZSNSO(1)*1000.) - ENDIF +!surface runoff and infiltration rate using different schemes - ! shift all elements above this down by one. - IF (J > ISNOW+1 .AND. ISNOW < -1) THEN - DO I = J, ISNOW+2, -1 - STC(I) = STC(I-1) - SNLIQ(I) = SNLIQ(I-1) - SNICE(I) = SNICE(I-1) - DZSNSO(I)= DZSNSO(I-1) - END DO - END IF - ISNOW = ISNOW + 1 - END IF - END DO +!jref impermable surface at urban + IF ( parameters%urban_flag ) FCR(1)= 0.95 -! to conserve water in case of too large surface sublimation + IF(OPT_RUN == 1) THEN + FFF = 6.0 + FSAT = parameters%FSATMX*EXP(-0.5*FFF*(ZWT-2.0)) + IF(QINSUR > 0.) THEN + RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) ) + PDDUM = QINSUR - RUNSRF ! m/s + END IF + END IF - IF(SICE(1) < 0.) THEN - SH2O(1) = SH2O(1) + SICE(1) - SICE(1) = 0. + IF(OPT_RUN == 5) THEN + FFF = 6.0 + FSAT = parameters%FSATMX*EXP(-0.5*FFF*MAX(-2.0-ZWT,0.)) + IF(QINSUR > 0.) THEN + RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) ) + PDDUM = QINSUR - RUNSRF ! m/s END IF + END IF - IF(ISNOW ==0) RETURN ! MB: get out if no longer multi-layer + IF(OPT_RUN == 2) THEN + FFF = 2.0 + FSAT = parameters%FSATMX*EXP(-0.5*FFF*ZWT) + IF(QINSUR > 0.) THEN + RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) ) + PDDUM = QINSUR - RUNSRF ! m/s + END IF + END IF - SNEQV = 0. - SNOWH = 0. - ZWICE = 0. - ZWLIQ = 0. + IF(OPT_RUN == 3) THEN + CALL INFIL (parameters,NSOIL ,DT ,ZSOIL ,SH2O ,SICE , & !in + SICEMAX,QINSUR , & !in + PDDUM ,RUNSRF ) !out + END IF - DO J = ISNOW+1,0 - SNEQV = SNEQV + SNICE(J) + SNLIQ(J) - SNOWH = SNOWH + DZSNSO(J) - ZWICE = ZWICE + SNICE(J) - ZWLIQ = ZWLIQ + SNLIQ(J) + IF(OPT_RUN == 4) THEN + SMCTOT = 0. + DZTOT = 0. + DO K = 1,NSOIL + DZTOT = DZTOT + DZSNSO(K) + SMCTOT = SMCTOT + SMC(K)/parameters%SMCMAX(K)*DZSNSO(K) + IF(DZTOT >= 2.0) EXIT END DO + SMCTOT = SMCTOT/DZTOT + FSAT = MAX(0.01,SMCTOT) ** 4. !BATS -! check the snow depth - all snow gone -! the liquid water assumes ponding on soil surface. + IF(QINSUR > 0.) THEN + RUNSRF = QINSUR * ((1.0-FCR(1))*FSAT+FCR(1)) + PDDUM = QINSUR - RUNSRF ! m/s + END IF + END IF - IF (SNOWH < 0.025 .AND. ISNOW < 0 ) THEN ! MB: change limit -! IF (SNOWH < 0.05 .AND. ISNOW < 0 ) THEN - ISNOW = 0 - SNEQV = ZWICE - PONDING2 = ZWLIQ ! LIMIT OF ISNOW < 0 MEANS INPUT PONDING - IF(SNEQV <= 0.) SNOWH = 0. ! SHOULD BE ZERO; SEE ABOVE +! determine iteration times and finer time step + + NITER = 1 + + IF(OPT_INF == 1) THEN !OPT_INF =2 may cause water imbalance + NITER = 3 + IF (PDDUM*DT>DZSNSO(1)*parameters%SMCMAX(1) ) THEN + NITER = NITER*2 END IF + END IF -! IF (SNOWH < 0.05 ) THEN -! ISNOW = 0 -! SNEQV = ZWICE -! SH2O(1) = SH2O(1) + ZWLIQ / (DZSNSO(1) * 1000.) -! IF(SNEQV <= 0.) SNOWH = 0. -! END IF + DTFINE = DT / NITER -! check the snow depth - snow layers combined +! solve soil moisture - IF (ISNOW < -1) THEN + QDRAIN_SAVE = 0.0 + DO ITER = 1, NITER + CALL SRT (parameters,NSOIL ,ZSOIL ,DTFINE ,PDDUM ,ETRANI , & !in + QSEVA ,SH2O ,SMC ,ZWT ,FCR , & !in + SICEMAX,FCRMAX ,ILOC ,JLOC ,SMCWTD , & !in + RHSTT ,AI ,BI ,CI ,QDRAIN , & !out + WCND ) !out + + CALL SSTEP (parameters,NSOIL ,NSNOW ,DTFINE ,ZSOIL ,DZSNSO , & !in + SICE ,ILOC ,JLOC ,ZWT , & !in + SH2O ,SMC ,AI ,BI ,CI , & !inout + RHSTT ,SMCWTD ,QDRAIN ,DEEPRECH, & !inout + WPLUS) !out + RSAT = RSAT + WPLUS + QDRAIN_SAVE = QDRAIN_SAVE + QDRAIN + END DO - ISNOW_OLD = ISNOW - MSSI = 1 + QDRAIN = QDRAIN_SAVE/NITER - DO I = ISNOW_OLD+1,0 - IF (DZSNSO(I) < DZMIN(MSSI)) THEN + RUNSRF = RUNSRF * 1000. + RSAT * 1000./DT ! m/s -> mm/s + QDRAIN = QDRAIN * 1000. - IF (I == ISNOW+1) THEN - NEIBOR = I + 1 - ELSE IF (I == 0) THEN - NEIBOR = I - 1 - ELSE - NEIBOR = I + 1 - IF ((DZSNSO(I-1)+DZSNSO(I)) < (DZSNSO(I+1)+DZSNSO(I))) NEIBOR = I-1 - END IF +!WRF_HYDRO_DJG... +!yw INFXSRT = RUNSRF * DT !mm/s -> mm - ! Node l and j are combined and stored as node j. - IF (NEIBOR > I) THEN - J = NEIBOR - L = I - ELSE - J = I - L = NEIBOR - END IF +! removal of soil water due to groundwater flow (option 2) - CALL COMBO (DZSNSO(J), SNLIQ(J), SNICE(J), & - STC(J), DZSNSO(L), SNLIQ(L), SNICE(L), STC(L) ) + IF(OPT_RUN == 2) THEN + WTSUB = 0. + DO K = 1, NSOIL + WTSUB = WTSUB + WCND(K)*DZSNSO(K) + END DO - ! Now shift all elements above this down one. - IF (J-1 > ISNOW+1) THEN - DO K = J-1, ISNOW+2, -1 - STC(K) = STC(K-1) - SNICE(K) = SNICE(K-1) - SNLIQ(K) = SNLIQ(K-1) - DZSNSO(K) = DZSNSO(K-1) - END DO - END IF + DO K = 1, NSOIL + MH2O = RUNSUB*DT*(WCND(K)*DZSNSO(K))/WTSUB ! mm + SH2O(K) = SH2O(K) - MH2O/(DZSNSO(K)*1000.) + END DO + END IF - ! Decrease the number of snow layers - ISNOW = ISNOW + 1 - IF (ISNOW >= -1) EXIT - ELSE +! Limit MLIQ to be greater than or equal to watmin. +! Get water needed to bring MLIQ equal WATMIN from lower layer. - ! The layer thickness is greater than the prescribed minimum value - MSSI = MSSI + 1 + IF(OPT_RUN /= 1) THEN + DO IZ = 1, NSOIL + MLIQ(IZ) = SH2O(IZ)*DZSNSO(IZ)*1000. + END DO - END IF - END DO + WATMIN = 0.01 ! mm + DO IZ = 1, NSOIL-1 + IF (MLIQ(IZ) .LT. 0.) THEN + XS = WATMIN-MLIQ(IZ) + ELSE + XS = 0. + END IF + MLIQ(IZ ) = MLIQ(IZ ) + XS + MLIQ(IZ+1) = MLIQ(IZ+1) - XS + END DO - END IF + IZ = NSOIL + IF (MLIQ(IZ) .LT. WATMIN) THEN + XS = WATMIN-MLIQ(IZ) + ELSE + XS = 0. + END IF + MLIQ(IZ) = MLIQ(IZ) + XS + RUNSUB = RUNSUB - XS/DT + IF(OPT_RUN == 5)DEEPRECH = DEEPRECH - XS*1.E-3 - END SUBROUTINE COMBINE + DO IZ = 1, NSOIL + SH2O(IZ) = MLIQ(IZ) / (DZSNSO(IZ)*1000.) + END DO + END IF -!== begin divide =================================================================================== + END SUBROUTINE SOILWATER - SUBROUTINE DIVIDE (NSNOW ,NSOIL , & !in - ISNOW ,STC ,SNICE ,SNLIQ ,DZSNSO ) !inout +!== begin zwteq ==================================================================================== + + SUBROUTINE ZWTEQ (parameters,NSOIL ,NSNOW ,ZSOIL ,DZSNSO ,SH2O ,ZWT) ! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: TFRZ ! MP CONSTANT +! calculate equilibrium water table depth (Niu et al., 2005) ! ---------------------------------------------------------------------- - IMPLICIT NONE + IMPLICIT NONE ! ---------------------------------------------------------------------- ! input - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [ =3] - INTEGER, INTENT(IN) :: NSOIL !no. of soil layers [ =4] + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer depth [m] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O !soil liquid water content [m3/m3] -! input and output +! output - INTEGER , INTENT(INOUT) :: ISNOW !actual no. of snow layers - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNICE !snow layer ice [mm] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO!snow layer depth [m] + REAL, INTENT(OUT) :: ZWT !water table depth [m] -! local variables: +! locals - INTEGER :: J !indices - INTEGER :: MSNO !number of layer (top) to MSNO (bot) - REAL :: DRR !thickness of the combined [m] - REAL, DIMENSION( 1:NSNOW) :: DZ !snow layer thickness [m] - REAL, DIMENSION( 1:NSNOW) :: SWICE !partial volume of ice [m3/m3] - REAL, DIMENSION( 1:NSNOW) :: SWLIQ !partial volume of liquid water [m3/m3] - REAL, DIMENSION( 1:NSNOW) :: TSNO !node temperature [k] - REAL :: ZWICE !temporary - REAL :: ZWLIQ !temporary - REAL :: PROPOR!temporary - REAL :: DTDZ !temporary + INTEGER :: K !do-loop index + INTEGER, PARAMETER :: NFINE = 100 !no. of fine soil layers of 6m soil + REAL :: WD1 !water deficit from coarse (4-L) soil moisture profile + REAL :: WD2 !water deficit from fine (100-L) soil moisture profile + REAL :: DZFINE !layer thickness of the 100-L soil layers to 6.0 m + REAL :: TEMP !temporary variable + REAL, DIMENSION(1:NFINE) :: ZFINE !layer-bottom depth of the 100-L soil layers to 6.0 m ! ---------------------------------------------------------------------- - DO J = 1,NSNOW - IF (J <= ABS(ISNOW)) THEN - DZ(J) = DZSNSO(J+ISNOW) - SWICE(J) = SNICE(J+ISNOW) - SWLIQ(J) = SNLIQ(J+ISNOW) - TSNO(J) = STC(J+ISNOW) - END IF - END DO + WD1 = 0. + DO K = 1,NSOIL + WD1 = WD1 + (parameters%SMCMAX(K)-SH2O(K)) * DZSNSO(K) ! [m] + ENDDO + + DZFINE = 3.0 * (-ZSOIL(NSOIL)) / NFINE + do K =1,NFINE + ZFINE(K) = FLOAT(K) * DZFINE + ENDDO + + ZWT = -3.*ZSOIL(NSOIL) - 0.001 ! initial value [m] + + WD2 = 0. + DO K = 1,NFINE + TEMP = 1. + (ZWT-ZFINE(K))/parameters%PSISAT(K) + WD2 = WD2 + parameters%SMCMAX(K)*(1.-TEMP**(-1./parameters%BEXP(K)))*DZFINE + IF(ABS(WD2-WD1).LE.0.01) THEN + ZWT = ZFINE(K) + EXIT + ENDIF + ENDDO + + END SUBROUTINE ZWTEQ + +!== begin infil ==================================================================================== + + SUBROUTINE INFIL (parameters,NSOIL ,DT ,ZSOIL ,SH2O ,SICE , & !in + SICEMAX,QINSUR , & !in + PDDUM ,RUNSRF ) !out +! -------------------------------------------------------------------------------- +! compute inflitration rate at soil surface and surface runoff +! -------------------------------------------------------------------------------- + IMPLICIT NONE +! -------------------------------------------------------------------------------- +! inputs + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + REAL, INTENT(IN) :: DT !time step (sec) + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O !soil liquid water content [m3/m3] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE !soil ice content [m3/m3] + REAL, INTENT(IN) :: QINSUR !water input on soil surface [mm/s] + REAL, INTENT(IN) :: SICEMAX!maximum soil ice content (m3/m3) + +! outputs + REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] + REAL, INTENT(OUT) :: PDDUM !infiltration rate at surface + +! locals + INTEGER :: IALP1, J, JJ, K + REAL :: VAL + REAL :: DDT + REAL :: PX + REAL :: DT1, DD, DICE + REAL :: FCR + REAL :: SUM + REAL :: ACRT + REAL :: WDF + REAL :: WCND + REAL :: SMCAV + REAL :: INFMAX + REAL, DIMENSION(1:NSOIL) :: DMAX + INTEGER, PARAMETER :: CVFRZ = 3 +! -------------------------------------------------------------------------------- + + IF (QINSUR > 0.0) THEN + DT1 = DT /86400. + SMCAV = parameters%SMCMAX(1) - parameters%SMCWLT(1) - MSNO = ABS(ISNOW) +! maximum infiltration rate - IF (MSNO == 1) THEN - ! Specify a new snow layer - IF (DZ(1) > 0.05) THEN - MSNO = 2 - DZ(1) = DZ(1)/2. - SWICE(1) = SWICE(1)/2. - SWLIQ(1) = SWLIQ(1)/2. - DZ(2) = DZ(1) - SWICE(2) = SWICE(1) - SWLIQ(2) = SWLIQ(1) - TSNO(2) = TSNO(1) - END IF - END IF + DMAX(1)= -ZSOIL(1) * SMCAV + DICE = -ZSOIL(1) * SICE(1) + DMAX(1)= DMAX(1)* (1.0-(SH2O(1) + SICE(1) - parameters%SMCWLT(1))/SMCAV) - IF (MSNO > 1) THEN - IF (DZ(1) > 0.05) THEN - DRR = DZ(1) - 0.05 - PROPOR = DRR/DZ(1) - ZWICE = PROPOR*SWICE(1) - ZWLIQ = PROPOR*SWLIQ(1) - PROPOR = 0.05/DZ(1) - SWICE(1) = PROPOR*SWICE(1) - SWLIQ(1) = PROPOR*SWLIQ(1) - DZ(1) = 0.05 + DD = DMAX(1) - CALL COMBO (DZ(2), SWLIQ(2), SWICE(2), TSNO(2), DRR, & - ZWLIQ, ZWICE, TSNO(1)) + DO K = 2,NSOIL + DICE = DICE + (ZSOIL(K-1) - ZSOIL(K) ) * SICE(K) + DMAX(K) = (ZSOIL(K-1) - ZSOIL(K)) * SMCAV + DMAX(K) = DMAX(K) * (1.0-(SH2O(K) + SICE(K) - parameters%SMCWLT(K))/SMCAV) + DD = DD + DMAX(K) + END DO - ! subdivide a new layer - IF (MSNO <= 2 .AND. DZ(2) > 0.20) THEN ! MB: change limit -! IF (MSNO <= 2 .AND. DZ(2) > 0.10) THEN - MSNO = 3 - DTDZ = (TSNO(1) - TSNO(2))/((DZ(1)+DZ(2))/2.) - DZ(2) = DZ(2)/2. - SWICE(2) = SWICE(2)/2. - SWLIQ(2) = SWLIQ(2)/2. - DZ(3) = DZ(2) - SWICE(3) = SWICE(2) - SWLIQ(3) = SWLIQ(2) - TSNO(3) = TSNO(2) - DTDZ*DZ(2)/2. - IF (TSNO(3) >= TFRZ) THEN - TSNO(3) = TSNO(2) - ELSE - TSNO(2) = TSNO(2) + DTDZ*DZ(2)/2. - ENDIF + VAL = (1. - EXP ( - parameters%KDT * DT1)) + DDT = DD * VAL + PX = MAX(0.,QINSUR * DT) + INFMAX = (PX * (DDT / (PX + DDT)))/ DT - END IF - END IF - END IF +! impermeable fraction due to frozen soil - IF (MSNO > 2) THEN - IF (DZ(2) > 0.2) THEN - DRR = DZ(2) - 0.2 - PROPOR = DRR/DZ(2) - ZWICE = PROPOR*SWICE(2) - ZWLIQ = PROPOR*SWLIQ(2) - PROPOR = 0.2/DZ(2) - SWICE(2) = PROPOR*SWICE(2) - SWLIQ(2) = PROPOR*SWLIQ(2) - DZ(2) = 0.2 - CALL COMBO (DZ(3), SWLIQ(3), SWICE(3), TSNO(3), DRR, & - ZWLIQ, ZWICE, TSNO(2)) - END IF + FCR = 1. + IF (DICE > 1.E-2) THEN + ACRT = CVFRZ * parameters%FRZX / DICE + SUM = 1. + IALP1 = CVFRZ - 1 + DO J = 1,IALP1 + K = 1 + DO JJ = J +1,IALP1 + K = K * JJ + END DO + SUM = SUM + (ACRT ** (CVFRZ - J)) / FLOAT(K) + END DO + FCR = 1. - EXP (-ACRT) * SUM END IF - ISNOW = -MSNO +! correction of infiltration limitation - DO J = ISNOW+1,0 - DZSNSO(J) = DZ(J-ISNOW) - SNICE(J) = SWICE(J-ISNOW) - SNLIQ(J) = SWLIQ(J-ISNOW) - STC(J) = TSNO(J-ISNOW) - END DO + INFMAX = INFMAX * FCR + +! jref for urban areas +! IF ( parameters%urban_flag ) INFMAX == INFMAX * 0.05 + CALL WDFCND2 (parameters,WDF,WCND,SH2O(1),SICEMAX,1) + INFMAX = MAX (INFMAX,WCND) + INFMAX = MIN (INFMAX,PX) -! DO J = ISNOW+1,NSOIL -! WRITE(*,'(I5,7F10.3)') J, DZSNSO(J), SNICE(J), SNLIQ(J),STC(J) -! END DO + RUNSRF= MAX(0., QINSUR - INFMAX) + PDDUM = QINSUR - RUNSRF - END SUBROUTINE DIVIDE + END IF -!== begin combo ==================================================================================== + END SUBROUTINE INFIL - SUBROUTINE COMBO(DZ, WLIQ, WICE, T, DZ2, WLIQ2, WICE2, T2) +!== begin srt ====================================================================================== + + SUBROUTINE SRT (parameters,NSOIL ,ZSOIL ,DT ,PDDUM ,ETRANI , & !in + QSEVA ,SH2O ,SMC ,ZWT ,FCR , & !in + SICEMAX,FCRMAX ,ILOC ,JLOC ,SMCWTD , & !in + RHSTT ,AI ,BI ,CI ,QDRAIN , & !out + WCND ) !out ! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: TFRZ, CICE, CWAT, HFUS ! MP CONSTANT +! calculate the right hand side of the time tendency term of the soil +! water diffusion equation. also to compute ( prepare ) the matrix +! coefficients for the tri-diagonal matrix of the implicit time scheme. ! ---------------------------------------------------------------------- IMPLICIT NONE ! ---------------------------------------------------------------------- +!input -! ----------------------------------------------------------------------s -! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL + REAL, INTENT(IN) :: DT + REAL, INTENT(IN) :: PDDUM + REAL, INTENT(IN) :: QSEVA + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ETRANI + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC + REAL, INTENT(IN) :: ZWT ! water table depth [m] + REAL, DIMENSION(1:NSOIL), INTENT(IN) :: FCR + REAL, INTENT(IN) :: FCRMAX !maximum of FCR (-) + REAL, INTENT(IN) :: SICEMAX!maximum soil ice content (m3/m3) + REAL, INTENT(IN) :: SMCWTD !soil moisture between bottom of the soil and the water table - REAL, INTENT(IN) :: DZ2 !nodal thickness of 2 elements being combined [m] - REAL, INTENT(IN) :: WLIQ2 !liquid water of element 2 [kg/m2] - REAL, INTENT(IN) :: WICE2 !ice of element 2 [kg/m2] - REAL, INTENT(IN) :: T2 !nodal temperature of element 2 [k] - REAL, INTENT(INOUT) :: DZ !nodal thickness of 1 elements being combined [m] - REAL, INTENT(INOUT) :: WLIQ !liquid water of element 1 - REAL, INTENT(INOUT) :: WICE !ice of element 1 [kg/m2] - REAL, INTENT(INOUT) :: T !node temperature of element 1 [k] +! output -! local + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTT + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: BI + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: CI + REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: WCND !hydraulic conductivity (m/s) + REAL, INTENT(OUT) :: QDRAIN !bottom drainage (m/s) - REAL :: DZC !total thickness of nodes 1 and 2 (DZC=DZ+DZ2). - REAL :: WLIQC !combined liquid water [kg/m2] - REAL :: WICEC !combined ice [kg/m2] - REAL :: TC !combined node temperature [k] - REAL :: H !enthalpy of element 1 [J/m2] - REAL :: H2 !enthalpy of element 2 [J/m2] - REAL :: HC !temporary +! local + INTEGER :: K + REAL, DIMENSION(1:NSOIL) :: DDZ + REAL, DIMENSION(1:NSOIL) :: DENOM + REAL, DIMENSION(1:NSOIL) :: DSMDZ + REAL, DIMENSION(1:NSOIL) :: WFLUX + REAL, DIMENSION(1:NSOIL) :: WDF + REAL, DIMENSION(1:NSOIL) :: SMX + REAL :: TEMP1 + REAL :: SMXWTD !soil moisture between bottom of the soil and water table + REAL :: SMXBOT !soil moisture below bottom to calculate flux -!----------------------------------------------------------------------- +! Niu and Yang (2006), J. of Hydrometeorology +! ---------------------------------------------------------------------- - DZC = DZ+DZ2 - WICEC = (WICE+WICE2) - WLIQC = (WLIQ+WLIQ2) - H = (CICE*WICE+CWAT*WLIQ) * (T-TFRZ)+HFUS*WLIQ - H2= (CICE*WICE2+CWAT*WLIQ2) * (T2-TFRZ)+HFUS*WLIQ2 + IF(OPT_INF == 1) THEN + DO K = 1, NSOIL + CALL WDFCND1 (parameters,WDF(K),WCND(K),SMC(K),FCR(K),K) + SMX(K) = SMC(K) + END DO + IF(OPT_RUN == 5)SMXWTD=SMCWTD + END IF - HC = H + H2 - IF(HC < 0.)THEN - TC = TFRZ + HC/(CICE*WICEC + CWAT*WLIQC) - ELSE IF (HC.LE.HFUS*WLIQC) THEN - TC = TFRZ - ELSE - TC = TFRZ + (HC - HFUS*WLIQC) / (CICE*WICEC + CWAT*WLIQC) + IF(OPT_INF == 2) THEN + DO K = 1, NSOIL + CALL WDFCND2 (parameters,WDF(K),WCND(K),SH2O(K),SICEMAX,K) + SMX(K) = SH2O(K) + END DO + IF(OPT_RUN == 5)SMXWTD=SMCWTD*SH2O(NSOIL)/SMC(NSOIL) !same liquid fraction as in the bottom layer END IF - DZ = DZC - WICE = WICEC - WLIQ = WLIQC - T = TC + DO K = 1, NSOIL + IF(K == 1) THEN + DENOM(K) = - ZSOIL (K) + TEMP1 = - ZSOIL (K+1) + DDZ(K) = 2.0 / TEMP1 + DSMDZ(K) = 2.0 * (SMX(K) - SMX(K+1)) / TEMP1 + WFLUX(K) = WDF(K) * DSMDZ(K) + WCND(K) - PDDUM + ETRANI(K) + QSEVA + ELSE IF (K < NSOIL) THEN + DENOM(k) = (ZSOIL(K-1) - ZSOIL(K)) + TEMP1 = (ZSOIL(K-1) - ZSOIL(K+1)) + DDZ(K) = 2.0 / TEMP1 + DSMDZ(K) = 2.0 * (SMX(K) - SMX(K+1)) / TEMP1 + WFLUX(K) = WDF(K ) * DSMDZ(K ) + WCND(K ) & + - WDF(K-1) * DSMDZ(K-1) - WCND(K-1) + ETRANI(K) + ELSE + DENOM(K) = (ZSOIL(K-1) - ZSOIL(K)) + IF(OPT_RUN == 1 .or. OPT_RUN == 2) THEN + QDRAIN = 0. + END IF + IF(OPT_RUN == 3) THEN + QDRAIN = parameters%SLOPE*WCND(K) + END IF + IF(OPT_RUN == 4) THEN + QDRAIN = (1.0-FCRMAX)*WCND(K) + END IF + IF(OPT_RUN == 5) THEN !gmm new m-m&f water table dynamics formulation + TEMP1 = 2.0 * DENOM(K) + IF(ZWT < ZSOIL(NSOIL)-DENOM(NSOIL))THEN +!gmm interpolate from below, midway to the water table, to the middle of the auxiliary layer below the soil bottom + SMXBOT = SMX(K) - (SMX(K)-SMXWTD) * DENOM(K) * 2./ (DENOM(K) + ZSOIL(K) - ZWT) + ELSE + SMXBOT = SMXWTD + ENDIF + DSMDZ(K) = 2.0 * (SMX(K) - SMXBOT) / TEMP1 + QDRAIN = WDF(K ) * DSMDZ(K ) + WCND(K ) + END IF + WFLUX(K) = -(WDF(K-1)*DSMDZ(K-1))-WCND(K-1)+ETRANI(K) + QDRAIN + END IF + END DO + + DO K = 1, NSOIL + IF(K == 1) THEN + AI(K) = 0.0 + BI(K) = WDF(K ) * DDZ(K ) / DENOM(K) + CI(K) = - BI (K) + ELSE IF (K < NSOIL) THEN + AI(K) = - WDF(K-1) * DDZ(K-1) / DENOM(K) + CI(K) = - WDF(K ) * DDZ(K ) / DENOM(K) + BI(K) = - ( AI (K) + CI (K) ) + ELSE + AI(K) = - WDF(K-1) * DDZ(K-1) / DENOM(K) + CI(K) = 0.0 + BI(K) = - ( AI (K) + CI (K) ) + END IF + RHSTT(K) = WFLUX(K) / (-DENOM(K)) + END DO + +! ---------------------------------------------------------------------- + END SUBROUTINE SRT - END SUBROUTINE COMBO +!== begin sstep ==================================================================================== -!== begin compact ================================================================================== + SUBROUTINE SSTEP (parameters,NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in + SICE ,ILOC ,JLOC ,ZWT , & !in + SH2O ,SMC ,AI ,BI ,CI , & !inout + RHSTT ,SMCWTD ,QDRAIN ,DEEPRECH, & !inout + WPLUS ) !out - SUBROUTINE COMPACT (NSNOW ,NSOIL ,DT ,STC ,SNICE , & !in - SNLIQ ,ZSOIL ,IMELT ,FICEOLD,ILOC , JLOC , & !in - ISNOW ,DZSNSO ,ZSNSO ) !inout ! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: TFRZ, DENH2O, DENICE ! MP CONSTANT +! calculate/update soil moisture content values ! ---------------------------------------------------------------------- - IMPLICIT NONE + IMPLICIT NONE ! ---------------------------------------------------------------------- -! input - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: NSOIL !no. of soil layers [ =4] - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers [ =3] - INTEGER, DIMENSION(-NSNOW+1:0) , INTENT(IN) :: IMELT !melting state index [0-no melt;1-melt] - REAL, INTENT(IN) :: DT !time step (sec) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow layer temperature [k] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNICE !snow layer ice [mm] - REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: SNLIQ !snow layer liquid water [mm] - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil srf - REAL, DIMENSION(-NSNOW+1: 0), INTENT(IN) :: FICEOLD!ice fraction at last timestep +!input -! input and output - INTEGER, INTENT(INOUT) :: ISNOW ! actual no. of snow layers - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO ! snow layer thickness [m] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: ZSNSO ! depth of snow/soil layer-bottom + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSOIL ! + INTEGER, INTENT(IN) :: NSNOW ! + REAL, INTENT(IN) :: DT + REAL, INTENT(IN) :: ZWT + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SICE + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO ! snow/soil layer thickness [m] -! local - REAL, PARAMETER :: C2 = 21.e-3 ![m3/kg] ! default 21.e-3 - REAL, PARAMETER :: C3 = 2.5e-6 ![1/s] - REAL, PARAMETER :: C4 = 0.04 ![1/k] - REAL, PARAMETER :: C5 = 2.0 ! - REAL, PARAMETER :: DM = 100.0 !upper Limit on destructive metamorphism compaction [kg/m3] - REAL, PARAMETER :: ETA0 = 0.8e+6 !viscosity coefficient [kg-s/m2] - !according to Anderson, it is between 0.52e6~1.38e6 - REAL :: BURDEN !pressure of overlying snow [kg/m2] - REAL :: DDZ1 !rate of settling of snow pack due to destructive metamorphism. - REAL :: DDZ2 !rate of compaction of snow pack due to overburden. - REAL :: DDZ3 !rate of compaction of snow pack due to melt [1/s] - REAL :: DEXPF !EXPF=exp(-c4*(273.15-STC)). - REAL :: TD !STC - TFRZ [K] - REAL :: PDZDTC !nodal rate of change in fractional-thickness due to compaction [fraction/s] - REAL :: VOID !void (1 - SNICE - SNLIQ) - REAL :: WX !water mass (ice + liquid) [kg/m2] - REAL :: BI !partial density of ice [kg/m3] - REAL, DIMENSION(-NSNOW+1:0) :: FICE !fraction of ice at current time step +!input and output + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: BI + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: CI + REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT + REAL , INTENT(INOUT) :: SMCWTD + REAL , INTENT(INOUT) :: QDRAIN + REAL , INTENT(INOUT) :: DEEPRECH - INTEGER :: J +!output + REAL, INTENT(OUT) :: WPLUS !saturation excess water (m) +!local + INTEGER :: K + REAL, DIMENSION(1:NSOIL) :: RHSTTIN + REAL, DIMENSION(1:NSOIL) :: CIIN + REAL :: STOT + REAL :: EPORE + REAL :: WMINUS ! ---------------------------------------------------------------------- - BURDEN = 0.0 + WPLUS = 0.0 - DO J = ISNOW+1, 0 + DO K = 1,NSOIL + RHSTT (K) = RHSTT(K) * DT + AI (K) = AI(K) * DT + BI (K) = 1. + BI(K) * DT + CI (K) = CI(K) * DT + END DO - WX = SNICE(J) + SNLIQ(J) - FICE(J) = SNICE(J) / WX - VOID = 1. - (SNICE(J)/DENICE + SNLIQ(J)/DENH2O) / DZSNSO(J) +! copy values for input variables before calling rosr12 - ! Allow compaction only for non-saturated node and higher ice lens node. - IF (VOID > 0.001 .AND. SNICE(J) > 0.1) THEN - BI = SNICE(J) / DZSNSO(J) - TD = MAX(0.,TFRZ-STC(J)) - DEXPF = EXP(-C4*TD) + DO K = 1,NSOIL + RHSTTIN(k) = RHSTT(K) + CIIN(k) = CI(K) + END DO - ! Settling as a result of destructive metamorphism +! call ROSR12 to solve the tri-diagonal matrix - DDZ1 = -C3*DEXPF + CALL ROSR12 (CI,AI,BI,CIIN,RHSTTIN,RHSTT,1,NSOIL,0) - IF (BI > DM) DDZ1 = DDZ1*EXP(-46.0E-3*(BI-DM)) + DO K = 1,NSOIL + SH2O(K) = SH2O(K) + CI(K) + ENDDO - ! Liquid water term +! excessive water above saturation in a layer is moved to +! its unsaturated layer like in a bucket - IF (SNLIQ(J) > 0.01*DZSNSO(J)) DDZ1=DDZ1*C5 +!gmmwith opt_run=5 there is soil moisture below nsoil, to the water table + IF(OPT_RUN == 5) THEN - ! Compaction due to overburden +!update smcwtd - DDZ2 = -(BURDEN+0.5*WX)*EXP(-0.08*TD-C2*BI)/ETA0 ! 0.5*WX -> self-burden + IF(ZWT < ZSOIL(NSOIL)-DZSNSO(NSOIL))THEN +!accumulate qdrain to update deep water table and soil moisture later + DEEPRECH = DEEPRECH + DT * QDRAIN + ELSE + SMCWTD = SMCWTD + DT * QDRAIN / DZSNSO(NSOIL) + WPLUS = MAX((SMCWTD-parameters%SMCMAX(NSOIL)), 0.0) * DZSNSO(NSOIL) + WMINUS = MAX((1.E-4-SMCWTD), 0.0) * DZSNSO(NSOIL) - ! Compaction occurring during melt + SMCWTD = MAX( MIN(SMCWTD,parameters%SMCMAX(NSOIL)) , 1.E-4) + SH2O(NSOIL) = SH2O(NSOIL) + WPLUS/DZSNSO(NSOIL) - IF (IMELT(J) == 1) THEN - DDZ3 = MAX(0.,(FICEOLD(J) - FICE(J))/MAX(1.E-6,FICEOLD(J))) - DDZ3 = - DDZ3/DT ! sometimes too large - ELSE - DDZ3 = 0. - END IF +!reduce fluxes at the bottom boundaries accordingly + QDRAIN = QDRAIN - WPLUS/DT + DEEPRECH = DEEPRECH - WMINUS + ENDIF - ! Time rate of fractional change in DZ (units of s-1) + ENDIF - PDZDTC = (DDZ1 + DDZ2 + DDZ3)*DT - PDZDTC = MAX(-0.5,PDZDTC) + DO K = NSOIL,2,-1 + EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(K) - SICE(K) ) ) + WPLUS = MAX((SH2O(K)-EPORE), 0.0) * DZSNSO(K) + SH2O(K) = MIN(EPORE,SH2O(K)) + SH2O(K-1) = SH2O(K-1) + WPLUS/DZSNSO(K-1) + END DO - ! The change in DZ due to compaction + EPORE = MAX ( 1.E-4 , ( parameters%SMCMAX(1) - SICE(1) ) ) + WPLUS = MAX((SH2O(1)-EPORE), 0.0) * DZSNSO(1) + SH2O(1) = MIN(EPORE,SH2O(1)) - DZSNSO(J) = DZSNSO(J)*(1.+PDZDTC) - END IF + END SUBROUTINE SSTEP - ! Pressure of overlying snow +!== begin wdfcnd1 ================================================================================== - BURDEN = BURDEN + WX + SUBROUTINE WDFCND1 (parameters,WDF,WCND,SMC,FCR,ISOIL) +! ---------------------------------------------------------------------- +! calculate soil water diffusivity and soil hydraulic conductivity. +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + REAL,INTENT(IN) :: SMC + REAL,INTENT(IN) :: FCR + INTEGER,INTENT(IN) :: ISOIL - END DO +! output + REAL,INTENT(OUT) :: WCND + REAL,INTENT(OUT) :: WDF - END SUBROUTINE COMPACT +! local + REAL :: EXPON + REAL :: FACTR + REAL :: VKWGT +! ---------------------------------------------------------------------- -!== begin snowh2o ================================================================================== +! soil water diffusivity - SUBROUTINE SNOWH2O (NSNOW ,NSOIL ,DT ,QSNFRO ,QSNSUB , & !in - QRAIN ,ILOC ,JLOC , & !in - ISNOW ,DZSNSO ,SNOWH ,SNEQV ,SNICE , & !inout - SNLIQ ,SH2O ,SICE ,STC , & !inout - QSNBOT ,PONDING1 ,PONDING2) !out -! ---------------------------------------------------------------------- -! Renew the mass of ice lens (SNICE) and liquid (SNLIQ) of the -! surface snow layer resulting from sublimation (frost) / evaporation (dew) + FACTR = MAX(0.01, SMC/parameters%SMCMAX(ISOIL)) + EXPON = parameters%BEXP(ISOIL) + 2.0 + WDF = parameters%DWSAT(ISOIL) * FACTR ** EXPON + WDF = WDF * (1.0 - FCR) + +! hydraulic conductivity + + EXPON = 2.0*parameters%BEXP(ISOIL) + 3.0 + WCND = parameters%DKSAT(ISOIL) * FACTR ** EXPON + WCND = WCND * (1.0 - FCR) + + END SUBROUTINE WDFCND1 + +!== begin wdfcnd2 ================================================================================== + + SUBROUTINE WDFCND2 (parameters,WDF,WCND,SMC,SICE,ISOIL) ! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: SSI, & ! SNOW GLOBAL - DENH2O, DENICE ! MP CONSTANT +! calculate soil water diffusivity and soil hydraulic conductivity. ! ---------------------------------------------------------------------- - IMPLICIT NONE + IMPLICIT NONE ! ---------------------------------------------------------------------- ! input - - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers[=3] - INTEGER, INTENT(IN) :: NSOIL !No. of soil layers[=4] - REAL, INTENT(IN) :: DT !time step - REAL, INTENT(IN) :: QSNFRO !snow surface frost rate[mm/s] - REAL, INTENT(IN) :: QSNSUB !snow surface sublimation rate[mm/s] - REAL, INTENT(IN) :: QRAIN !snow surface rain rate[mm/s] + type (noahmp_parameters), intent(in) :: parameters + REAL,INTENT(IN) :: SMC + REAL,INTENT(IN) :: SICE + INTEGER,INTENT(IN) :: ISOIL ! output + REAL,INTENT(OUT) :: WCND + REAL,INTENT(OUT) :: WDF - REAL, INTENT(OUT) :: QSNBOT !melting water out of snow bottom [mm/s] - -! input and output - - INTEGER, INTENT(INOUT) :: ISNOW !actual no. of snow layers - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: DZSNSO ! snow layer depth [m] - REAL, INTENT(INOUT) :: SNOWH !snow height [m] - REAL, INTENT(INOUT) :: SNEQV !snow water eqv. [mm] - REAL, DIMENSION(-NSNOW+1:0), INTENT(INOUT) :: SNICE !snow layer ice [mm] - REAL, DIMENSION(-NSNOW+1:0), INTENT(INOUT) :: SNLIQ !snow layer liquid water [mm] - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid moisture (m3/m3) - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SICE !soil ice moisture (m3/m3) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(INOUT) :: STC !snow layer temperature [k] +! local + REAL :: EXPON + REAL :: FACTR + REAL :: VKWGT +! ---------------------------------------------------------------------- -! local variables: +! soil water diffusivity - INTEGER :: J !do loop/array indices - REAL :: QIN !water flow into the element (mm/s) - REAL :: QOUT !water flow out of the element (mm/s) - REAL :: WGDIF !ice mass after minus sublimation - REAL, DIMENSION(-NSNOW+1:0) :: VOL_LIQ !partial volume of liquid water in layer - REAL, DIMENSION(-NSNOW+1:0) :: VOL_ICE !partial volume of ice lens in layer - REAL, DIMENSION(-NSNOW+1:0) :: EPORE !effective porosity = porosity - VOL_ICE - REAL :: PROPOR, TEMP - REAL :: PONDING1, PONDING2 -! ---------------------------------------------------------------------- + FACTR = MAX(0.01, SMC/parameters%SMCMAX(ISOIL)) + EXPON = parameters%BEXP(ISOIL) + 2.0 + WDF = parameters%DWSAT(ISOIL) * FACTR ** EXPON -!for the case when SNEQV becomes '0' after 'COMBINE' + IF (SICE > 0.0) THEN + VKWGT = 1./ (1. + (500.* SICE)**3.) + WDF = VKWGT * WDF + (1.-VKWGT)*parameters%DWSAT(ISOIL)*(0.2/parameters%SMCMAX(ISOIL))**EXPON + END IF - IF(SNEQV == 0.) THEN - SICE(1) = SICE(1) + (QSNFRO-QSNSUB)*DT/(DZSNSO(1)*1000.) ! Barlage: SH2O->SICE v3.6 - IF(SICE(1) < 0.) THEN - SH2O(1) = SH2O(1) + SICE(1) - SICE(1) = 0. - END IF - END IF +! hydraulic conductivity -! for shallow snow without a layer -! snow surface sublimation may be larger than existing snow mass. To conserve water, -! excessive sublimation is used to reduce soil water. Smaller time steps would tend -! to aviod this problem. + EXPON = 2.0*parameters%BEXP(ISOIL) + 3.0 + WCND = parameters%DKSAT(ISOIL) * FACTR ** EXPON - IF(ISNOW == 0 .and. SNEQV > 0.) THEN - TEMP = SNEQV - SNEQV = SNEQV - QSNSUB*DT + QSNFRO*DT - PROPOR = SNEQV/TEMP - SNOWH = MAX(0.,PROPOR * SNOWH) + END SUBROUTINE WDFCND2 - IF(SNEQV < 0.) THEN - SICE(1) = SICE(1) + SNEQV/(DZSNSO(1)*1000.) - SNEQV = 0. - SNOWH = 0. - END IF - IF(SICE(1) < 0.) THEN - SH2O(1) = SH2O(1) + SICE(1) - SICE(1) = 0. - END IF - END IF +!== begin groundwater ============================================================================== - IF(SNOWH <= 1.E-8 .OR. SNEQV <= 1.E-6) THEN - SNOWH = 0.0 - SNEQV = 0.0 - END IF + SUBROUTINE GROUNDWATER(parameters,NSNOW ,NSOIL ,DT ,SICE ,ZSOIL , & !in + STC ,WCND ,FCRMAX ,ILOC ,JLOC , & !in + SH2O ,ZWT ,WA ,WT , & !inout + QIN ,QDIS ) !out +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: ILOC !grid index + INTEGER, INTENT(IN) :: JLOC !grid index + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + REAL, INTENT(IN) :: DT !timestep [sec] + REAL, INTENT(IN) :: FCRMAX!maximum FCR (-) + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SICE !soil ice content [m3/m3] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: WCND !hydraulic conductivity (m/s) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature (k) -! for deep snow +! input and output + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !liquid soil water [m3/m3] + REAL, INTENT(INOUT) :: ZWT !the depth to water table [m] + REAL, INTENT(INOUT) :: WA !water storage in aquifer [mm] + REAL, INTENT(INOUT) :: WT !water storage in aquifer + !+ saturated soil [mm] +! output + REAL, INTENT(OUT) :: QIN !groundwater recharge [mm/s] + REAL, INTENT(OUT) :: QDIS !groundwater discharge [mm/s] - IF ( ISNOW < 0 ) THEN !KWM added this IF statement to prevent out-of-bounds array references +! local + REAL :: FFF !runoff decay factor (m-1) + REAL :: RSBMX !baseflow coefficient [mm/s] + INTEGER :: IZ !do-loop index + INTEGER :: IWT !layer index above water table layer + REAL, DIMENSION( 1:NSOIL) :: DZMM !layer thickness [mm] + REAL, DIMENSION( 1:NSOIL) :: ZNODE !node depth [m] + REAL, DIMENSION( 1:NSOIL) :: MLIQ !liquid water mass [kg/m2 or mm] + REAL, DIMENSION( 1:NSOIL) :: EPORE !effective porosity [-] + REAL, DIMENSION( 1:NSOIL) :: HK !hydraulic conductivity [mm/s] + REAL, DIMENSION( 1:NSOIL) :: SMC !total soil water content [m3/m3] + REAL(KIND=8) :: S_NODE!degree of saturation of IWT layer + REAL :: DZSUM !cumulative depth above water table [m] + REAL :: SMPFZ !matric potential (frozen effects) [mm] + REAL :: KA !aquifer hydraulic conductivity [mm/s] + REAL :: WH_ZWT!water head at water table [mm] + REAL :: WH !water head at layer above ZWT [mm] + REAL :: WS !water used to fill air pore [mm] + REAL :: WTSUB !sum of HK*DZMM + REAL :: WATMIN!minimum soil vol soil moisture [m3/m3] + REAL :: XS !excessive water above saturation [mm] + REAL, PARAMETER :: ROUS = 0.2 !specific yield [-] + REAL, PARAMETER :: CMIC = 0.20 !microprore content (0.0-1.0) + !0.0-close to free drainage +! ------------------------------------------------------------- + QDIS = 0.0 + QIN = 0.0 - WGDIF = SNICE(ISNOW+1) - QSNSUB*DT + QSNFRO*DT - SNICE(ISNOW+1) = WGDIF - IF (WGDIF < 1.e-6 .and. ISNOW <0) THEN - CALL COMBINE (NSNOW ,NSOIL ,ILOC, JLOC , & !in - ISNOW ,SH2O ,STC ,SNICE ,SNLIQ , & !inout - DZSNSO ,SICE ,SNOWH ,SNEQV , & !inout - PONDING1, PONDING2 ) !out - ENDIF - !KWM: Subroutine COMBINE can change ISNOW to make it 0 again? - IF ( ISNOW < 0 ) THEN !KWM added this IF statement to prevent out-of-bounds array references - SNLIQ(ISNOW+1) = SNLIQ(ISNOW+1) + QRAIN * DT - SNLIQ(ISNOW+1) = MAX(0., SNLIQ(ISNOW+1)) - ENDIF - - ENDIF !KWM -- Can the ENDIF be moved toward the end of the subroutine (Just set QSNBOT=0)? +! Derive layer-bottom depth in [mm] +!KWM: Derive layer thickness in mm -! Porosity and partial volume + DZMM(1) = -ZSOIL(1)*1.E3 + DO IZ = 2, NSOIL + DZMM(IZ) = 1.E3 * (ZSOIL(IZ - 1) - ZSOIL(IZ)) + ENDDO - !KWM Looks to me like loop index / IF test can be simplified. +! Derive node (middle) depth in [m] +!KWM: Positive number, depth below ground surface in m + ZNODE(1) = -ZSOIL(1) / 2. + DO IZ = 2, NSOIL + ZNODE(IZ) = -ZSOIL(IZ-1) + 0.5 * (ZSOIL(IZ-1) - ZSOIL(IZ)) + ENDDO - DO J = -NSNOW+1, 0 - IF (J >= ISNOW+1) THEN - VOL_ICE(J) = MIN(1., SNICE(J)/(DZSNSO(J)*DENICE)) - EPORE(J) = 1. - VOL_ICE(J) - VOL_LIQ(J) = MIN(EPORE(J),SNLIQ(J)/(DZSNSO(J)*DENH2O)) - END IF - END DO +! Convert volumetric soil moisture "sh2o" to mass - QIN = 0. - QOUT = 0. + DO IZ = 1, NSOIL + SMC(IZ) = SH2O(IZ) + SICE(IZ) + MLIQ(IZ) = SH2O(IZ) * DZMM(IZ) + EPORE(IZ) = MAX(0.01,parameters%SMCMAX(IZ) - SICE(IZ)) + HK(IZ) = 1.E3*WCND(IZ) + ENDDO - !KWM Looks to me like loop index / IF test can be simplified. +! The layer index of the first unsaturated layer, +! i.e., the layer right above the water table - DO J = -NSNOW+1, 0 - IF (J >= ISNOW+1) THEN - SNLIQ(J) = SNLIQ(J) + QIN - IF (J <= -1) THEN - IF (EPORE(J) < 0.05 .OR. EPORE(J+1) < 0.05) THEN - QOUT = 0. - ELSE - QOUT = MAX(0.,(VOL_LIQ(J)-SSI*EPORE(J))*DZSNSO(J)) - QOUT = MIN(QOUT,(1.-VOL_ICE(J+1)-VOL_LIQ(J+1))*DZSNSO(J+1)) - END IF - ELSE - QOUT = MAX(0.,(VOL_LIQ(J) - SSI*EPORE(J))*DZSNSO(J)) + IWT = NSOIL + DO IZ = 2,NSOIL + IF(ZWT .LE. -ZSOIL(IZ) ) THEN + IWT = IZ-1 + EXIT END IF - QOUT = QOUT*1000. - SNLIQ(J) = SNLIQ(J) - QOUT - QIN = QOUT - END IF - END DO - -! Liquid water from snow bottom to soil + ENDDO - QSNBOT = QOUT / DT ! mm/s +! Groundwater discharge [mm/s] - END SUBROUTINE SNOWH2O + FFF = 6.0 + RSBMX = 5.0 -!== begin soilwater ================================================================================ + QDIS = (1.0-FCRMAX)*RSBMX*EXP(-parameters%TIMEAN)*EXP(-FFF*(ZWT-2.0)) - SUBROUTINE SOILWATER (NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in - QINSUR ,QSEVA ,ETRANI ,SICE ,ILOC , JLOC, & !in - SH2O ,SMC ,ZWT ,VEGTYP ,& !inout - SMCWTD, DEEPRECH ,& !inout - RUNSRF ,QDRAIN ,RUNSUB ,WCND ,FCRMAX ) !out +! Matric potential at the layer above the water table -! ---------------------------------------------------------------------- -! calculate surface runoff and soil moisture. -! ---------------------------------------------------------------------- -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: SMCMAX, & ! SOIL DEPENDENT - TIMEAN, FSATMX, & ! RUNOFF GLOBAL - ISURBAN ! MP CONSTANT -! ---------------------------------------------------------------------- - IMPLICIT NONE -! ---------------------------------------------------------------------- -! input - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: NSOIL !no. of soil layers - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers - REAL, INTENT(IN) :: DT !time step (sec) - REAL, INTENT(IN) :: QINSUR !water input on soil surface [mm/s] - REAL, INTENT(IN) :: QSEVA !evap from soil surface [mm/s] - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ETRANI !evapotranspiration from soil layers [mm/s] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer depth [m] - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE !soil ice content [m3/m3] + S_NODE = MIN(1.0,SMC(IWT)/parameters%SMCMAX(IWT) ) + S_NODE = MAX(S_NODE,REAL(0.01,KIND=8)) + SMPFZ = -parameters%PSISAT(IWT)*1000.*S_NODE**(-parameters%BEXP(IWT)) ! m --> mm + SMPFZ = MAX(-120000.0,CMIC*SMPFZ) - INTEGER, INTENT(IN) :: VEGTYP +! Recharge rate qin to groundwater -! input & output - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O !soil liquid water content [m3/m3] - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC !total soil water content [m3/m3] - REAL, INTENT(INOUT) :: ZWT !water table depth [m] - REAL, INTENT(INOUT) :: SMCWTD !soil moisture between bottom of the soil and the water table [m3/m3] - REAL , INTENT(INOUT) :: DEEPRECH + KA = HK(IWT) -! output - REAL, INTENT(OUT) :: QDRAIN !soil-bottom free drainage [mm/s] - REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] - REAL, INTENT(OUT) :: RUNSUB !subsurface runoff [mm/s] - REAL, INTENT(OUT) :: FCRMAX !maximum of FCR (-) - REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: WCND !hydraulic conductivity (m/s) + WH_ZWT = - ZWT * 1.E3 !(mm) + WH = SMPFZ - ZNODE(IWT)*1.E3 !(mm) + QIN = - KA * (WH_ZWT-WH) /((ZWT-ZNODE(IWT))*1.E3) + QIN = MAX(-10.0/DT,MIN(10./DT,QIN)) + +! Water storage in the aquifer + saturated soil -! local - INTEGER :: K,IZ !do-loop index - INTEGER :: ITER !iteration index - REAl :: DTFINE !fine time step (s) - REAL, DIMENSION(1:NSOIL) :: RHSTT !right-hand side term of the matrix - REAL, DIMENSION(1:NSOIL) :: AI !left-hand side term - REAL, DIMENSION(1:NSOIL) :: BI !left-hand side term - REAL, DIMENSION(1:NSOIL) :: CI !left-hand side term + WT = WT + (QIN - QDIS) * DT !(mm) - REAL :: FFF !runoff decay factor (m-1) - REAL :: RSBMX !baseflow coefficient [mm/s] - REAL :: PDDUM !infiltration rate at surface (m/s) - REAL :: FICE !ice fraction in frozen soil - REAL :: WPLUS !saturation excess of the total soil [m] - REAL :: RSAT !accumulation of WPLUS (saturation excess) [m] - REAL :: SICEMAX!maximum soil ice content (m3/m3) - REAL :: SH2OMIN!minimum soil liquid water content (m3/m3) - REAL :: WTSUB !sum of WCND(K)*DZSNSO(K) - REAL :: MH2O !water mass removal (mm) - REAL :: FSAT !fractional saturated area (-) - REAL, DIMENSION(1:NSOIL) :: MLIQ ! - REAL :: XS ! - REAL :: WATMIN ! - REAL :: QDRAIN_SAVE ! - REAL :: EPORE !effective porosity [m3/m3] - REAL, DIMENSION(1:NSOIL) :: FCR !impermeable fraction due to frozen soil - INTEGER :: NITER !iteration times soil moisture (-) - REAL :: SMCTOT !2-m averaged soil moisture (m3/m3) - REAL :: DZTOT !2-m soil depth (m) - REAL, PARAMETER :: A = 4.0 -! ---------------------------------------------------------------------- - RUNSRF = 0.0 - PDDUM = 0.0 - RSAT = 0.0 + IF(IWT.EQ.NSOIL) THEN + WA = WA + (QIN - QDIS) * DT !(mm) + WT = WA + ZWT = (-ZSOIL(NSOIL) + 25.) - WA/1000./ROUS !(m) + MLIQ(NSOIL) = MLIQ(NSOIL) - QIN * DT ! [mm] -! for the case when snowmelt water is too large + MLIQ(NSOIL) = MLIQ(NSOIL) + MAX(0.,(WA - 5000.)) + WA = MIN(WA, 5000.) + ELSE + + IF (IWT.EQ.NSOIL-1) THEN + ZWT = -ZSOIL(NSOIL) & + - (WT-ROUS*1000*25.) / (EPORE(NSOIL))/1000. + ELSE + WS = 0. ! water used to fill soil air pores + DO IZ = IWT+2,NSOIL + WS = WS + EPORE(IZ) * DZMM(IZ) + ENDDO + ZWT = -ZSOIL(IWT+1) & + - (WT-ROUS*1000.*25.-WS) /(EPORE(IWT+1))/1000. + ENDIF - DO K = 1,NSOIL - EPORE = MAX ( 1.E-4 , ( SMCMAX - SICE(K) ) ) - RSAT = RSAT + MAX(0.,SH2O(K)-EPORE)*DZSNSO(K) - SH2O(K) = MIN(EPORE,SH2O(K)) - END DO + WTSUB = 0. + DO IZ = 1, NSOIL + WTSUB = WTSUB + HK(IZ)*DZMM(IZ) + END DO -!impermeable fraction due to frozen soil + DO IZ = 1, NSOIL ! Removing subsurface runoff + MLIQ(IZ) = MLIQ(IZ) - QDIS*DT*HK(IZ)*DZMM(IZ)/WTSUB + END DO + END IF - DO K = 1,NSOIL - FICE = MIN(1.0,SICE(K)/SMCMAX) - FCR(K) = MAX(0.0,EXP(-A*(1.-FICE))- EXP(-A)) / & - (1.0 - EXP(-A)) - END DO + ZWT = MAX(1.5,ZWT) -! maximum soil ice content and minimum liquid water of all layers +! +! Limit MLIQ to be greater than or equal to watmin. +! Get water needed to bring MLIQ equal WATMIN from lower layer. +! + WATMIN = 0.01 + DO IZ = 1, NSOIL-1 + IF (MLIQ(IZ) .LT. 0.) THEN + XS = WATMIN-MLIQ(IZ) + ELSE + XS = 0. + END IF + MLIQ(IZ ) = MLIQ(IZ ) + XS + MLIQ(IZ+1) = MLIQ(IZ+1) - XS + END DO - SICEMAX = 0.0 - FCRMAX = 0.0 - SH2OMIN = SMCMAX - DO K = 1,NSOIL - IF (SICE(K) > SICEMAX) SICEMAX = SICE(K) - IF (FCR(K) > FCRMAX) FCRMAX = FCR(K) - IF (SH2O(K) < SH2OMIN) SH2OMIN = SH2O(K) - END DO + IZ = NSOIL + IF (MLIQ(IZ) .LT. WATMIN) THEN + XS = WATMIN-MLIQ(IZ) + ELSE + XS = 0. + END IF + MLIQ(IZ) = MLIQ(IZ) + XS + WA = WA - XS + WT = WT - XS -!subsurface runoff for runoff scheme option 2 + DO IZ = 1, NSOIL + SH2O(IZ) = MLIQ(IZ) / DZMM(IZ) + END DO - IF(OPT_RUN == 2) THEN - FFF = 2.0 - RSBMX = 4.0 - CALL ZWTEQ (NSOIL ,NSNOW ,ZSOIL ,DZSNSO ,SH2O ,ZWT) - RUNSUB = (1.0-FCRMAX) * RSBMX * EXP(-TIMEAN) * EXP(-FFF*ZWT) ! mm/s - END IF + END SUBROUTINE GROUNDWATER -!surface runoff and infiltration rate using different schemes +!== begin shallowwatertable ======================================================================== -!jref impermable surface at urban - IF ( VEGTYP == ISURBAN ) FCR(1)= 0.95 + SUBROUTINE SHALLOWWATERTABLE (parameters,NSNOW ,NSOIL ,ZSOIL, DT , & !in + DZSNSO ,SMCEQ ,ILOC ,JLOC , & !in + SMC ,WTD ,SMCWTD ,RECH, QDRAIN ) !inout +! ---------------------------------------------------------------------- +!Diagnoses water table depth and computes recharge when the water table is within the resolved soil layers, +!according to the Miguez-Macho&Fan scheme +! ---------------------------------------------------------------------- + IMPLICIT NONE +! ---------------------------------------------------------------------- +! input + type (noahmp_parameters), intent(in) :: parameters + INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers + INTEGER, INTENT(IN) :: NSOIL !no. of soil layers + INTEGER, INTENT(IN) :: ILOC,JLOC + REAL, INTENT(IN) :: DT + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO ! snow/soil layer thickness [m] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] - IF(OPT_RUN == 1) THEN - FFF = 6.0 - FSAT = FSATMX*EXP(-0.5*FFF*(ZWT-2.0)) - IF(QINSUR > 0.) THEN - RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) ) - PDDUM = QINSUR - RUNSRF ! m/s - END IF - END IF +! input and output + REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !total soil water content [m3/m3] + REAL, INTENT(INOUT) :: WTD !the depth to water table [m] + REAL, INTENT(INOUT) :: SMCWTD !soil moisture between bottom of the soil and the water table [m3/m3] + REAL, INTENT(OUT) :: RECH ! groundwater recharge (net vertical flux across the water table), positive up + REAL, INTENT(INOUT) :: QDRAIN + +! local + INTEGER :: IZ !do-loop index + INTEGER :: IWTD !layer index above water table layer + INTEGER :: KWTD !layer index where the water table layer is + REAL :: WTDOLD + REAL :: DZUP + REAL :: SMCEQDEEP + REAL, DIMENSION( 0:NSOIL) :: ZSOIL0 +! ------------------------------------------------------------- - IF(OPT_RUN == 5) THEN - FFF = 6.0 - FSAT = FSATMX*EXP(-0.5*FFF*MAX(-2.0-ZWT,0.)) - IF(QINSUR > 0.) THEN - RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) ) - PDDUM = QINSUR - RUNSRF ! m/s - END IF - END IF - IF(OPT_RUN == 2) THEN - FFF = 2.0 - FSAT = FSATMX*EXP(-0.5*FFF*ZWT) - IF(QINSUR > 0.) THEN - RUNSRF = QINSUR * ( (1.0-FCR(1))*FSAT + FCR(1) ) - PDDUM = QINSUR - RUNSRF ! m/s - END IF - END IF +ZSOIL0(1:NSOIL) = ZSOIL(1:NSOIL) +ZSOIL0(0) = 0. + +!find the layer where the water table is + DO IZ=NSOIL,1,-1 + IF(WTD + 1.E-6 < ZSOIL0(IZ)) EXIT + ENDDO + IWTD=IZ - IF(OPT_RUN == 3) THEN - CALL INFIL (NSOIL ,DT ,ZSOIL ,SH2O ,SICE , & !in - SICEMAX,QINSUR , & !in - PDDUM ,RUNSRF ) !out - END IF + + KWTD=IWTD+1 !layer where the water table is + IF(KWTD.LE.NSOIL)THEN !wtd in the resolved layers + WTDOLD=WTD + IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN + + IF(SMC(KWTD).EQ.parameters%SMCMAX(KWTD))THEN !wtd went to the layer above + WTD=ZSOIL0(IWTD) + RECH=-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD)) + IWTD=IWTD-1 + KWTD=KWTD-1 + IF(KWTD.GE.1)THEN + IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN + WTDOLD=WTD + WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) & + - SMCEQ(KWTD)*ZSOIL0(IWTD) + parameters%SMCMAX(KWTD)*ZSOIL0(KWTD) ) / & + ( parameters%SMCMAX(KWTD)-SMCEQ(KWTD) ), ZSOIL0(IWTD)) + RECH=RECH-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD)) + ENDIF + ENDIF + ELSE !wtd stays in the layer + WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) & + - SMCEQ(KWTD)*ZSOIL0(IWTD) + parameters%SMCMAX(KWTD)*ZSOIL0(KWTD) ) / & + ( parameters%SMCMAX(KWTD)-SMCEQ(KWTD) ), ZSOIL0(IWTD)) + RECH=-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD)) + ENDIF + + ELSE !wtd has gone down to the layer below + WTD=ZSOIL0(KWTD) + RECH=-(WTDOLD-WTD) * (parameters%SMCMAX(KWTD)-SMCEQ(KWTD)) + KWTD=KWTD+1 + IWTD=IWTD+1 +!wtd crossed to the layer below. Now adjust it there + IF(KWTD.LE.NSOIL)THEN + WTDOLD=WTD + IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN + WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) & + - SMCEQ(KWTD)*ZSOIL0(IWTD) + parameters%SMCMAX(KWTD)*ZSOIL0(KWTD) ) / & + ( parameters%SMCMAX(KWTD)-SMCEQ(KWTD) ) , ZSOIL0(IWTD) ) + ELSE + WTD=ZSOIL0(KWTD) + ENDIF + RECH = RECH - (WTDOLD-WTD) * & + (parameters%SMCMAX(KWTD)-SMCEQ(KWTD)) - IF(OPT_RUN == 4) THEN - SMCTOT = 0. - DZTOT = 0. - DO K = 1,NSOIL - DZTOT = DZTOT + DZSNSO(K) - SMCTOT = SMCTOT + SMC(K)*DZSNSO(K) - IF(DZTOT >= 2.0) EXIT - END DO - SMCTOT = SMCTOT/DZTOT - FSAT = MAX(0.01,SMCTOT/SMCMAX) ** 4. !BATS + ELSE + WTDOLD=WTD +!restore smoi to equilibrium value with water from the ficticious layer below +! SMCWTD=SMCWTD-(SMCEQ(NSOIL)-SMC(NSOIL)) +! QDRAIN = QDRAIN - 1000 * (SMCEQ(NSOIL)-SMC(NSOIL)) * DZSNSO(NSOIL) / DT +! SMC(NSOIL)=SMCEQ(NSOIL) +!adjust wtd in the ficticious layer below + SMCEQDEEP = parameters%SMCMAX(NSOIL) * ( -parameters%PSISAT(NSOIL) / ( -parameters%PSISAT(NSOIL) - DZSNSO(NSOIL) ) ) ** (1./parameters%BEXP(NSOIL)) + WTD = MIN( ( SMCWTD*DZSNSO(NSOIL) & + - SMCEQDEEP*ZSOIL0(NSOIL) + parameters%SMCMAX(NSOIL)*(ZSOIL0(NSOIL)-DZSNSO(NSOIL)) ) / & + ( parameters%SMCMAX(NSOIL)-SMCEQDEEP ) , ZSOIL0(NSOIL) ) + RECH = RECH - (WTDOLD-WTD) * & + (parameters%SMCMAX(NSOIL)-SMCEQDEEP) + ENDIF + + ENDIF + ELSEIF(WTD.GE.ZSOIL0(NSOIL)-DZSNSO(NSOIL))THEN +!if wtd was already below the bottom of the resolved soil crust + WTDOLD=WTD + SMCEQDEEP = parameters%SMCMAX(NSOIL) * ( -parameters%PSISAT(NSOIL) / ( -parameters%PSISAT(NSOIL) - DZSNSO(NSOIL) ) ) ** (1./parameters%BEXP(NSOIL)) + IF(SMCWTD.GT.SMCEQDEEP)THEN + WTD = MIN( ( SMCWTD*DZSNSO(NSOIL) & + - SMCEQDEEP*ZSOIL0(NSOIL) + parameters%SMCMAX(NSOIL)*(ZSOIL0(NSOIL)-DZSNSO(NSOIL)) ) / & + ( parameters%SMCMAX(NSOIL)-SMCEQDEEP ) , ZSOIL0(NSOIL) ) + RECH = -(WTDOLD-WTD) * (parameters%SMCMAX(NSOIL)-SMCEQDEEP) + ELSE + RECH = -(WTDOLD-(ZSOIL0(NSOIL)-DZSNSO(NSOIL))) * (parameters%SMCMAX(NSOIL)-SMCEQDEEP) + WTDOLD=ZSOIL0(NSOIL)-DZSNSO(NSOIL) +!and now even further down + DZUP=(SMCEQDEEP-SMCWTD)*DZSNSO(NSOIL)/(parameters%SMCMAX(NSOIL)-SMCEQDEEP) + WTD=WTDOLD-DZUP + RECH = RECH - (parameters%SMCMAX(NSOIL)-SMCEQDEEP)*DZUP + SMCWTD=SMCEQDEEP + ENDIF - IF(QINSUR > 0.) THEN - RUNSRF = QINSUR * ((1.0-FCR(1))*FSAT+FCR(1)) - PDDUM = QINSUR - RUNSRF ! m/s - END IF - END IF + + ENDIF -! determine iteration times and finer time step +IF(IWTD.LT.NSOIL .AND. IWTD.GT.0) THEN + SMCWTD=parameters%SMCMAX(IWTD) +ELSEIF(IWTD.LT.NSOIL .AND. IWTD.LE.0) THEN + SMCWTD=parameters%SMCMAX(1) +END IF - NITER = 1 +END SUBROUTINE SHALLOWWATERTABLE - IF(OPT_INF == 1) THEN !OPT_INF =2 may cause water imbalance - NITER = 3 - IF (PDDUM*DT>DZSNSO(1)*SMCMAX ) THEN - NITER = NITER*2 - END IF - END IF +! ================================================================================================== +! ********************* end of water subroutines ****************************************** +! ================================================================================================== - DTFINE = DT / NITER +!== begin carbon =================================================================================== -! solve soil moisture + SUBROUTINE CARBON (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL , & !in + DZSNSO ,STC ,SMC ,TV ,TG ,PSN , & !in + FOLN ,BTRAN ,APAR ,FVEG ,IGS , & !in + TROOT ,IST ,LAT ,ILOC ,JLOC , & !in + LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC , & !out + TOTLB ,XLAI ,XSAI ) !out +! ------------------------------------------------------------------------------------------ + IMPLICIT NONE +! ------------------------------------------------------------------------------------------ +! inputs (carbon) - QDRAIN_SAVE = 0.0 - DO ITER = 1, NITER - CALL SRT (NSOIL ,ZSOIL ,DTFINE ,PDDUM ,ETRANI , & !in - QSEVA ,SH2O ,SMC ,ZWT ,FCR , & !in - SICEMAX,FCRMAX ,ILOC ,JLOC ,SMCWTD , & !in - RHSTT ,AI ,BI ,CI ,QDRAIN , & !out - WCND ) !out - - CALL SSTEP (NSOIL ,NSNOW ,DTFINE ,ZSOIL ,DZSNSO , & !in - SICE ,ILOC ,JLOC ,ZWT , & !in - SH2O ,SMC ,AI ,BI ,CI , & !inout - RHSTT ,SMCWTD ,QDRAIN ,DEEPRECH, & !inout - WPLUS) !out - RSAT = RSAT + WPLUS - QDRAIN_SAVE = QDRAIN_SAVE + QDRAIN - END DO + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN) :: ILOC !grid index + INTEGER , INTENT(IN) :: JLOC !grid index + INTEGER , INTENT(IN) :: VEGTYP !vegetation type + INTEGER , INTENT(IN) :: NSNOW !number of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + REAL , INTENT(IN) :: LAT !latitude (radians) + REAL , INTENT(IN) :: DT !time step (s) + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil surface + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature [k] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice + liq.) [m3/m3] + REAL , INTENT(IN) :: TV !vegetation temperature (k) + REAL , INTENT(IN) :: TG !ground temperature (k) + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) + REAL , INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) + REAL , INTENT(IN) :: PSN !total leaf photosyn (umolco2/m2/s) [+] + REAL , INTENT(IN) :: APAR !PAR by canopy (w/m2) + REAL , INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL , INTENT(IN) :: FVEG !vegetation greenness fraction + REAL , INTENT(IN) :: TROOT !root-zone averaged temperature (k) + INTEGER , INTENT(IN) :: IST !surface type 1->soil; 2->lake - QDRAIN = QDRAIN_SAVE/NITER +! input & output (carbon) - RUNSRF = RUNSRF * 1000. + RSAT * 1000./DT ! m/s -> mm/s - QDRAIN = QDRAIN * 1000. + REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] + REAL , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2] + REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] + REAL , INTENT(INOUT) :: WOOD !mass of wood (incl. woody roots) [g/m2] + REAL , INTENT(INOUT) :: STBLCP !stable carbon in deep soil [g/m2] + REAL , INTENT(INOUT) :: FASTCP !short-lived carbon in shallow soil [g/m2] -!WRF_HYDRO_DJG... -!yw INFXSRT = RUNSRF * DT !mm/s -> mm +! outputs: (carbon) -! removal of soil water due to groundwater flow (option 2) + REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s C] + REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2/s C] + REAL , INTENT(OUT) :: NEE !net ecosystem exchange [g/m2/s CO2] + REAL , INTENT(OUT) :: AUTORS !net ecosystem respiration [g/m2/s C] + REAL , INTENT(OUT) :: HETERS !organic respiration [g/m2/s C] + REAL , INTENT(OUT) :: TOTSC !total soil carbon [g/m2 C] + REAL , INTENT(OUT) :: TOTLB !total living carbon ([g/m2 C] + REAL , INTENT(OUT) :: XLAI !leaf area index [-] + REAL , INTENT(OUT) :: XSAI !stem area index [-] +! REAL , INTENT(OUT) :: VOCFLX(5) ! voc fluxes [ug C m-2 h-1] - IF(OPT_RUN == 2) THEN - WTSUB = 0. - DO K = 1, NSOIL - WTSUB = WTSUB + WCND(K)*DZSNSO(K) - END DO +! local variables - DO K = 1, NSOIL - MH2O = RUNSUB*DT*(WCND(K)*DZSNSO(K))/WTSUB ! mm - SH2O(K) = SH2O(K) - MH2O/(DZSNSO(K)*1000.) - END DO - END IF + INTEGER :: J !do-loop index + REAL :: WROOT !root zone soil water [-] + REAL :: WSTRES !water stress coeficient [-] (1. for wilting ) + REAL :: LAPM !leaf area per unit mass [m2/g] +! ------------------------------------------------------------------------------------------ -! Limit MLIQ to be greater than or equal to watmin. -! Get water needed to bring MLIQ equal WATMIN from lower layer. + IF ( ( VEGTYP == parameters%iswater ) .OR. ( VEGTYP == parameters%ISBARREN ) .OR. & + ( VEGTYP == parameters%ISICE ) .or. (parameters%urban_flag) ) THEN + XLAI = 0. + XSAI = 0. + GPP = 0. + NPP = 0. + NEE = 0. + AUTORS = 0. + HETERS = 0. + TOTSC = 0. + TOTLB = 0. + LFMASS = 0. + RTMASS = 0. + STMASS = 0. + WOOD = 0. + STBLCP = 0. + FASTCP = 0. - IF(OPT_RUN /= 1) THEN - DO IZ = 1, NSOIL - MLIQ(IZ) = SH2O(IZ)*DZSNSO(IZ)*1000. - END DO + RETURN + END IF - WATMIN = 0.01 ! mm - DO IZ = 1, NSOIL-1 - IF (MLIQ(IZ) .LT. 0.) THEN - XS = WATMIN-MLIQ(IZ) - ELSE - XS = 0. - END IF - MLIQ(IZ ) = MLIQ(IZ ) + XS - MLIQ(IZ+1) = MLIQ(IZ+1) - XS - END DO + LAPM = parameters%SLA / 1000. ! m2/kg -> m2/g - IZ = NSOIL - IF (MLIQ(IZ) .LT. WATMIN) THEN - XS = WATMIN-MLIQ(IZ) - ELSE - XS = 0. - END IF - MLIQ(IZ) = MLIQ(IZ) + XS - RUNSUB = RUNSUB - XS/DT - IF(OPT_RUN == 5)DEEPRECH = DEEPRECH - XS*1.E-3 +! water stress - DO IZ = 1, NSOIL - SH2O(IZ) = MLIQ(IZ) / (DZSNSO(IZ)*1000.) - END DO - END IF + WSTRES = 1.- BTRAN - END SUBROUTINE SOILWATER + WROOT = 0. + DO J=1,parameters%NROOT + WROOT = WROOT + SMC(J)/parameters%SMCMAX(J) * DZSNSO(J) / (-ZSOIL(parameters%NROOT)) + ENDDO -!== begin zwteq ==================================================================================== + CALL CO2FLUX (parameters,NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in + DZSNSO ,STC ,PSN ,TROOT ,TV , & !in + WROOT ,WSTRES ,FOLN ,LAPM , & !in + LAT ,ILOC ,JLOC ,FVEG , & !in + XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , & !inout + FASTCP ,STBLCP ,WOOD , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS , & !out + TOTSC ,TOTLB ) !out - SUBROUTINE ZWTEQ (NSOIL ,NSNOW ,ZSOIL ,DZSNSO ,SH2O ,ZWT) -! ---------------------------------------------------------------------- -! calculate equilibrium water table depth (Niu et al., 2005) -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX ! SOIL DEPENDENT -! ---------------------------------------------------------------------- - IMPLICIT NONE -! ---------------------------------------------------------------------- -! input +! CALL BVOC (parameters,VOCFLX, VEGTYP, VEGFAC, APAR, TV) +! CALL CH4 - INTEGER, INTENT(IN) :: NSOIL !no. of soil layers - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer depth [m] - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O !soil liquid water content [m3/m3] + END SUBROUTINE CARBON -! output +!== begin co2flux ================================================================================== - REAL, INTENT(OUT) :: ZWT !water table depth [m] + SUBROUTINE CO2FLUX (parameters,NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in + DZSNSO ,STC ,PSN ,TROOT ,TV , & !in + WROOT ,WSTRES ,FOLN ,LAPM , & !in + LAT ,ILOC ,JLOC ,FVEG , & !in + XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , & !inout + FASTCP ,STBLCP ,WOOD , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS , & !out + TOTSC ,TOTLB ) !out +! ----------------------------------------------------------------------------------------- +! The original code is from RE Dickinson et al.(1998), modifed by Guo-Yue Niu, 2004 +! ----------------------------------------------------------------------------------------- + IMPLICIT NONE +! ----------------------------------------------------------------------------------------- -! locals +! input - INTEGER :: K !do-loop index - INTEGER, PARAMETER :: NFINE = 100 !no. of fine soil layers of 6m soil - REAL :: WD1 !water deficit from coarse (4-L) soil moisture profile - REAL :: WD2 !water deficit from fine (100-L) soil moisture profile - REAL :: DZFINE !layer thickness of the 100-L soil layers to 6.0 m - REAL :: TEMP !temporary variable - REAL, DIMENSION(1:NFINE) :: ZFINE !layer-bottom depth of the 100-L soil layers to 6.0 m -! ---------------------------------------------------------------------- + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN) :: ILOC !grid index + INTEGER , INTENT(IN) :: JLOC !grid index + INTEGER , INTENT(IN) :: VEGTYP !vegetation physiology type + INTEGER , INTENT(IN) :: NSNOW !number of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + REAL , INTENT(IN) :: DT !time step (s) + REAL , INTENT(IN) :: LAT !latitude (radians) + REAL , INTENT(IN) :: IGS !growing season index (0=off, 1=on) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature [k] + REAL , INTENT(IN) :: PSN !total leaf photosynthesis (umolco2/m2/s) + REAL , INTENT(IN) :: TROOT !root-zone averaged temperature (k) + REAL , INTENT(IN) :: TV !leaf temperature (k) + REAL , INTENT(IN) :: WROOT !root zone soil water + REAL , INTENT(IN) :: WSTRES !soil water stress + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) + REAL , INTENT(IN) :: LAPM !leaf area per unit mass [m2/g] + REAL , INTENT(IN) :: FVEG !vegetation greenness fraction - WD1 = 0. - DO K = 1,NSOIL - WD1 = WD1 + (SMCMAX-SH2O(K)) * DZSNSO(K) ! [m] - ENDDO +! input and output - DZFINE = 3.0 * (-ZSOIL(NSOIL)) / NFINE - do K =1,NFINE - ZFINE(K) = FLOAT(K) * DZFINE - ENDDO + REAL , INTENT(INOUT) :: XLAI !leaf area index from leaf carbon [-] + REAL , INTENT(INOUT) :: XSAI !stem area index from leaf carbon [-] + REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] + REAL , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2] + REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] + REAL , INTENT(INOUT) :: FASTCP !short lived carbon [g/m2] + REAL , INTENT(INOUT) :: STBLCP !stable carbon pool [g/m2] + REAL , INTENT(INOUT) :: WOOD !mass of wood (incl. woody roots) [g/m2] - ZWT = -3.*ZSOIL(NSOIL) - 0.001 ! initial value [m] +! output - WD2 = 0. - DO K = 1,NFINE - TEMP = 1. + (ZWT-ZFINE(K))/PSISAT - WD2 = WD2 + SMCMAX*(1.-TEMP**(-1./BEXP))*DZFINE - IF(ABS(WD2-WD1).LE.0.01) THEN - ZWT = ZFINE(K) - EXIT - ENDIF - ENDDO + REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s] + REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2] + REAL , INTENT(OUT) :: NEE !net ecosystem exchange (autors+heters-gpp) + REAL , INTENT(OUT) :: AUTORS !net ecosystem resp. (maintance and growth) + REAL , INTENT(OUT) :: HETERS !organic respiration + REAL , INTENT(OUT) :: TOTSC !total soil carbon (g/m2) + REAL , INTENT(OUT) :: TOTLB !total living carbon (g/m2) - END SUBROUTINE ZWTEQ +! local -!== begin infil ==================================================================================== + REAL :: CFLUX !carbon flux to atmosphere [g/m2/s] + REAL :: LFMSMN !minimum leaf mass [g/m2] + REAL :: RSWOOD !wood respiration [g/m2] + REAL :: RSLEAF !leaf maintenance respiration per timestep [g/m2] + REAL :: RSROOT !fine root respiration per time step [g/m2] + REAL :: NPPL !leaf net primary productivity [g/m2/s] + REAL :: NPPR !root net primary productivity [g/m2/s] + REAL :: NPPW !wood net primary productivity [g/m2/s] + REAL :: NPPS !wood net primary productivity [g/m2/s] + REAL :: DIELF !death of leaf mass per time step [g/m2] - SUBROUTINE INFIL (NSOIL ,DT ,ZSOIL ,SH2O ,SICE , & !in - SICEMAX,QINSUR , & !in - PDDUM ,RUNSRF ) !out -! -------------------------------------------------------------------------------- -! compute inflitration rate at soil surface and surface runoff -! -------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: SMCMAX, KDT, FRZX, SMCWLT, & ! SOIL DEPENDENT - ISURBAN ! MP CONSTANT -! ---------------------------------------------------------------------- - IMPLICIT NONE -! -------------------------------------------------------------------------------- -! inputs - INTEGER, INTENT(IN) :: NSOIL !no. of soil layers - REAL, INTENT(IN) :: DT !time step (sec) - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O !soil liquid water content [m3/m3] - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SICE !soil ice content [m3/m3] - REAL, INTENT(IN) :: QINSUR !water input on soil surface [mm/s] - REAL, INTENT(IN) :: SICEMAX!maximum soil ice content (m3/m3) + REAL :: ADDNPPLF !leaf assimil after resp. losses removed [g/m2] + REAL :: ADDNPPST !stem assimil after resp. losses removed [g/m2] + REAL :: CARBFX !carbon assimilated per model step [g/m2] + REAL :: GRLEAF !growth respiration rate for leaf [g/m2/s] + REAL :: GRROOT !growth respiration rate for root [g/m2/s] + REAL :: GRWOOD !growth respiration rate for wood [g/m2/s] + REAL :: GRSTEM !growth respiration rate for stem [g/m2/s] + REAL :: LEAFPT !fraction of carbon allocated to leaves [-] + REAL :: LFDEL !maximum leaf mass available to change [g/m2/s] + REAL :: LFTOVR !stem turnover per time step [g/m2] + REAL :: STTOVR !stem turnover per time step [g/m2] + REAL :: WDTOVR !wood turnover per time step [g/m2] + REAL :: RSSOIL !soil respiration per time step [g/m2] + REAL :: RTTOVR !root carbon loss per time step by turnover [g/m2] + REAL :: STABLC !decay rate of fast carbon to slow carbon [g/m2/s] + REAL :: WOODF !calculated wood to root ratio [-] + REAL :: NONLEF !fraction of carbon to root and wood [-] + REAL :: ROOTPT !fraction of carbon flux to roots [-] + REAL :: WOODPT !fraction of carbon flux to wood [-] + REAL :: STEMPT !fraction of carbon flux to stem [-] + REAL :: RESP !leaf respiration [umol/m2/s] + REAL :: RSSTEM !stem respiration [g/m2/s] + + REAL :: FSW !soil water factor for microbial respiration + REAL :: FST !soil temperature factor for microbial respiration + REAL :: FNF !foliage nitrogen adjustemt to respiration (<= 1) + REAL :: TF !temperature factor + REAL :: RF !respiration reduction factor (<= 1) + REAL :: STDEL + REAL :: STMSMN + REAL :: SAPM !stem area per unit mass (m2/g) + REAL :: DIEST +! -------------------------- constants ------------------------------- + REAL :: BF !parameter for present wood allocation [-] + REAL :: RSWOODC !wood respiration coeficient [1/s] + REAL :: STOVRC !stem turnover coefficient [1/s] + REAL :: RSDRYC !degree of drying that reduces soil respiration [-] + REAL :: RTOVRC !root turnover coefficient [1/s] + REAL :: WSTRC !water stress coeficient [-] + REAL :: LAIMIN !minimum leaf area index [m2/m2] + REAL :: XSAMIN !minimum leaf area index [m2/m2] + REAL :: SC + REAL :: SD + REAL :: VEGFRAC -! outputs - REAL, INTENT(OUT) :: RUNSRF !surface runoff [mm/s] - REAL, INTENT(OUT) :: PDDUM !infiltration rate at surface +! Respiration as a function of temperature -! locals - INTEGER :: IALP1, J, JJ, K - REAL :: VAL - REAL :: DDT - REAL :: PX - REAL :: DT1, DD, DICE - REAL :: FCR - REAL :: SUM - REAL :: ACRT - REAL :: WDF - REAL :: WCND - REAL :: SMCAV - REAL :: INFMAX - REAL, DIMENSION(1:NSOIL) :: DMAX - INTEGER, PARAMETER :: CVFRZ = 3 -! -------------------------------------------------------------------------------- + real :: r,x + r(x) = exp(0.08*(x-298.16)) +! --------------------------------------------------------------------------------- - IF (QINSUR > 0.0) THEN - DT1 = DT /86400. - SMCAV = SMCMAX - SMCWLT +! constants + RTOVRC = 2.0E-8 !original was 2.0e-8 + RSDRYC = 40.0 !original was 40.0 + RSWOODC = 3.0E-10 ! + BF = 0.90 !original was 0.90 ! carbon to roots + WSTRC = 100.0 + LAIMIN = 0.05 + XSAMIN = 0.05 ! MB: change to prevent vegetation from not growing back in spring -! maximum infiltration rate + SAPM = 3.*0.001 ! m2/kg -->m2/g + LFMSMN = laimin/lapm + STMSMN = xsamin/sapm +! --------------------------------------------------------------------------------- - DMAX(1)= -ZSOIL(1) * SMCAV - DICE = -ZSOIL(1) * SICE(1) - DMAX(1)= DMAX(1)* (1.0-(SH2O(1) + SICE(1) - SMCWLT)/SMCAV) +! respiration - DD = DMAX(1) + IF(IGS .EQ. 0.) THEN + RF = 0.5 + ELSE + RF = 1.0 + ENDIF + + FNF = MIN( FOLN/MAX(1.E-06,parameters%FOLNMX), 1.0 ) + TF = parameters%ARM**( (TV-298.16)/10. ) + RESP = parameters%RMF25 * TF * FNF * XLAI * RF * (1.-WSTRES) ! umol/m2/s + RSLEAF = MIN((LFMASS-LFMSMN)/DT,RESP*12.e-6) ! g/m2/s + + RSROOT = parameters%RMR25*(RTMASS*1E-3)*TF *RF* 12.e-6 ! g/m2/s + RSSTEM = parameters%RMS25*((STMASS-STMSMN)*1E-3)*TF *RF* 12.e-6 ! g/m2/s + RSWOOD = RSWOODC * R(TV) * WOOD*parameters%WDPOOL - DO K = 2,NSOIL - DICE = DICE + (ZSOIL(K-1) - ZSOIL(K) ) * SICE(K) - DMAX(K) = (ZSOIL(K-1) - ZSOIL(K)) * SMCAV - DMAX(K) = DMAX(K) * (1.0-(SH2O(K) + SICE(K) - SMCWLT)/SMCAV) - DD = DD + DMAX(K) - END DO +! carbon assimilation +! 1 mole -> 12 g carbon or 44 g CO2; 1 umol -> 12.e-6 g carbon; - VAL = (1. - EXP ( - KDT * DT1)) - DDT = DD * VAL - PX = MAX(0.,QINSUR * DT) - INFMAX = (PX * (DDT / (PX + DDT)))/ DT + CARBFX = PSN * 12.e-6 ! umol co2 /m2/ s -> g/m2/s carbon -! impermeable fraction due to frozen soil +! fraction of carbon into leaf versus nonleaf - FCR = 1. - IF (DICE > 1.E-2) THEN - ACRT = CVFRZ * FRZX / DICE - SUM = 1. - IALP1 = CVFRZ - 1 - DO J = 1,IALP1 - K = 1 - DO JJ = J +1,IALP1 - K = K * JJ - END DO - SUM = SUM + (ACRT ** (CVFRZ - J)) / FLOAT(K) - END DO - FCR = 1. - EXP (-ACRT) * SUM - END IF + LEAFPT = EXP(0.01*(1.-EXP(0.75*XLAI))*XLAI) + IF(VEGTYP == parameters%EBLFOREST) LEAFPT = EXP(0.01*(1.-EXP(0.50*XLAI))*XLAI) -! correction of infiltration limitation + NONLEF = 1.0 - LEAFPT + STEMPT = XLAI/10.0*LEAFPT + LEAFPT = LEAFPT - STEMPT - INFMAX = INFMAX * FCR +! fraction of carbon into wood versus root -! jref for urban areas -! IF (VEGTYP == ISURBAN ) INFMAX == INFMAX * 0.05 + IF(WOOD.GT.0) THEN + WOODF = (1.-EXP(-BF*(parameters%WRRAT*RTMASS/WOOD))/BF)*parameters%WDPOOL + ELSE + WOODF = 0. + ENDIF - CALL WDFCND2 (WDF,WCND,SH2O(1),SICEMAX) - INFMAX = MAX (INFMAX,WCND) - INFMAX = MIN (INFMAX,PX) + ROOTPT = NONLEF*(1.-WOODF) + WOODPT = NONLEF*WOODF - RUNSRF= MAX(0., QINSUR - INFMAX) - PDDUM = QINSUR - RUNSRF +! leaf and root turnover per time step - END IF + LFTOVR = parameters%LTOVRC*5.E-7*LFMASS + STTOVR = parameters%LTOVRC*5.E-7*STMASS + RTTOVR = RTOVRC*RTMASS + WDTOVR = 9.5E-10*WOOD - END SUBROUTINE INFIL +! seasonal leaf die rate dependent on temp and water stress +! water stress is set to 1 at permanent wilting point -!== begin srt ====================================================================================== + SC = EXP(-0.3*MAX(0.,TV-parameters%TDLEF)) * (LFMASS/120.) + SD = EXP((WSTRES-1.)*WSTRC) + DIELF = LFMASS*1.E-6*(parameters%DILEFW * SD + parameters%DILEFC*SC) + DIEST = STMASS*1.E-6*(parameters%DILEFW * SD + parameters%DILEFC*SC) - SUBROUTINE SRT (NSOIL ,ZSOIL ,DT ,PDDUM ,ETRANI , & !in - QSEVA ,SH2O ,SMC ,ZWT ,FCR , & !in - SICEMAX,FCRMAX ,ILOC ,JLOC ,SMCWTD , & !in - RHSTT ,AI ,BI ,CI ,QDRAIN , & !out - WCND ) !out -! ---------------------------------------------------------------------- -! calculate the right hand side of the time tendency term of the soil -! water diffusion equation. also to compute ( prepare ) the matrix -! coefficients for the tri-diagonal matrix of the implicit time scheme. -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: SLOPE ! GENPARM DEPENDENT -! ---------------------------------------------------------------------- - IMPLICIT NONE -! ---------------------------------------------------------------------- -!input +! calculate growth respiration for leaf, rtmass and wood - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: NSOIL - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ZSOIL - REAL, INTENT(IN) :: DT - REAL, INTENT(IN) :: PDDUM - REAL, INTENT(IN) :: QSEVA - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: ETRANI - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SH2O - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: SMC - REAL, INTENT(IN) :: ZWT ! water table depth [m] - REAL, DIMENSION(1:NSOIL), INTENT(IN) :: FCR - REAL, INTENT(IN) :: FCRMAX !maximum of FCR (-) - REAL, INTENT(IN) :: SICEMAX!maximum soil ice content (m3/m3) - REAL, INTENT(IN) :: SMCWTD !soil moisture between bottom of the soil and the water table + GRLEAF = MAX(0.0,parameters%FRAGR*(LEAFPT*CARBFX - RSLEAF)) + GRSTEM = MAX(0.0,parameters%FRAGR*(STEMPT*CARBFX - RSSTEM)) + GRROOT = MAX(0.0,parameters%FRAGR*(ROOTPT*CARBFX - RSROOT)) + GRWOOD = MAX(0.0,parameters%FRAGR*(WOODPT*CARBFX - RSWOOD)) -! output +! Impose lower T limit for photosynthesis - REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: RHSTT - REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: AI - REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: BI - REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: CI - REAL, DIMENSION(1:NSOIL), INTENT(OUT) :: WCND !hydraulic conductivity (m/s) - REAL, INTENT(OUT) :: QDRAIN !bottom drainage (m/s) + ADDNPPLF = MAX(0.,LEAFPT*CARBFX - GRLEAF-RSLEAF) + ADDNPPST = MAX(0.,STEMPT*CARBFX - GRSTEM-RSSTEM) +! ADDNPPLF = LEAFPT*CARBFX - GRLEAF-RSLEAF ! MB: test Kjetil +! ADDNPPST = STEMPT*CARBFX - GRSTEM-RSSTEM ! MB: test Kjetil + IF(TV.LT.parameters%TMIN) ADDNPPLF =0. + IF(TV.LT.parameters%TMIN) ADDNPPST =0. -! local - INTEGER :: K - REAL, DIMENSION(1:NSOIL) :: DDZ - REAL, DIMENSION(1:NSOIL) :: DENOM - REAL, DIMENSION(1:NSOIL) :: DSMDZ - REAL, DIMENSION(1:NSOIL) :: WFLUX - REAL, DIMENSION(1:NSOIL) :: WDF - REAL, DIMENSION(1:NSOIL) :: SMX - REAL :: TEMP1 - REAL :: SMXWTD !soil moisture between bottom of the soil and water table - REAL :: SMXBOT !soil moisture below bottom to calculate flux +! update leaf, root, and wood carbon +! avoid reducing leaf mass below its minimum value but conserve mass -! Niu and Yang (2006), J. of Hydrometeorology -! ---------------------------------------------------------------------- + LFDEL = (LFMASS - LFMSMN)/DT + STDEL = (STMASS - STMSMN)/DT + DIELF = MIN(DIELF,LFDEL+ADDNPPLF-LFTOVR) + DIEST = MIN(DIEST,STDEL+ADDNPPST-STTOVR) - IF(OPT_INF == 1) THEN - DO K = 1, NSOIL - CALL WDFCND1 (WDF(K),WCND(K),SMC(K),FCR(K)) - SMX(K) = SMC(K) - END DO - IF(OPT_RUN == 5)SMXWTD=SMCWTD - END IF +! net primary productivities - IF(OPT_INF == 2) THEN - DO K = 1, NSOIL - CALL WDFCND2 (WDF(K),WCND(K),SH2O(K),SICEMAX) - SMX(K) = SH2O(K) - END DO - IF(OPT_RUN == 5)SMXWTD=SMCWTD*SH2O(NSOIL)/SMC(NSOIL) !same liquid fraction as in the bottom layer - END IF + NPPL = MAX(ADDNPPLF,-LFDEL) + NPPS = MAX(ADDNPPST,-STDEL) + NPPR = ROOTPT*CARBFX - RSROOT - GRROOT + NPPW = WOODPT*CARBFX - RSWOOD - GRWOOD - DO K = 1, NSOIL - IF(K == 1) THEN - DENOM(K) = - ZSOIL (K) - TEMP1 = - ZSOIL (K+1) - DDZ(K) = 2.0 / TEMP1 - DSMDZ(K) = 2.0 * (SMX(K) - SMX(K+1)) / TEMP1 - WFLUX(K) = WDF(K) * DSMDZ(K) + WCND(K) - PDDUM + ETRANI(K) + QSEVA - ELSE IF (K < NSOIL) THEN - DENOM(k) = (ZSOIL(K-1) - ZSOIL(K)) - TEMP1 = (ZSOIL(K-1) - ZSOIL(K+1)) - DDZ(K) = 2.0 / TEMP1 - DSMDZ(K) = 2.0 * (SMX(K) - SMX(K+1)) / TEMP1 - WFLUX(K) = WDF(K ) * DSMDZ(K ) + WCND(K ) & - - WDF(K-1) * DSMDZ(K-1) - WCND(K-1) + ETRANI(K) - ELSE - DENOM(K) = (ZSOIL(K-1) - ZSOIL(K)) - IF(OPT_RUN == 1 .or. OPT_RUN == 2) THEN - QDRAIN = 0. - END IF - IF(OPT_RUN == 3) THEN - QDRAIN = SLOPE*WCND(K) - END IF - IF(OPT_RUN == 4) THEN - QDRAIN = (1.0-FCRMAX)*WCND(K) - END IF - IF(OPT_RUN == 5) THEN !gmm new m-m&f water table dynamics formulation - TEMP1 = 2.0 * DENOM(K) - IF(ZWT < ZSOIL(NSOIL)-DENOM(NSOIL))THEN -!gmm interpolate from below, midway to the water table, to the middle of the auxiliary layer below the soil bottom - SMXBOT = SMX(K) - (SMX(K)-SMXWTD) * DENOM(K) * 2./ (DENOM(K) + ZSOIL(K) - ZWT) - ELSE - SMXBOT = SMXWTD - ENDIF - DSMDZ(K) = 2.0 * (SMX(K) - SMXBOT) / TEMP1 - QDRAIN = WDF(K ) * DSMDZ(K ) + WCND(K ) - END IF - WFLUX(K) = -(WDF(K-1)*DSMDZ(K-1))-WCND(K-1)+ETRANI(K) + QDRAIN - END IF - END DO +! masses of plant components - DO K = 1, NSOIL - IF(K == 1) THEN - AI(K) = 0.0 - BI(K) = WDF(K ) * DDZ(K ) / DENOM(K) - CI(K) = - BI (K) - ELSE IF (K < NSOIL) THEN - AI(K) = - WDF(K-1) * DDZ(K-1) / DENOM(K) - CI(K) = - WDF(K ) * DDZ(K ) / DENOM(K) - BI(K) = - ( AI (K) + CI (K) ) - ELSE - AI(K) = - WDF(K-1) * DDZ(K-1) / DENOM(K) - CI(K) = 0.0 - BI(K) = - ( AI (K) + CI (K) ) - END IF - RHSTT(K) = WFLUX(K) / (-DENOM(K)) - END DO + LFMASS = LFMASS + (NPPL-LFTOVR-DIELF)*DT + STMASS = STMASS + (NPPS-STTOVR-DIEST)*DT ! g/m2 + RTMASS = RTMASS + (NPPR-RTTOVR) *DT + + IF(RTMASS.LT.0.0) THEN + RTTOVR = NPPR + RTMASS = 0.0 + ENDIF + WOOD = (WOOD+(NPPW-WDTOVR)*DT)*parameters%WDPOOL -! ---------------------------------------------------------------------- - END SUBROUTINE SRT +! soil carbon budgets -!== begin sstep ==================================================================================== + FASTCP = FASTCP + (RTTOVR+LFTOVR+STTOVR+WDTOVR+DIELF+DIEST)*DT ! MB: add DIEST v3.7 - SUBROUTINE SSTEP (NSOIL ,NSNOW ,DT ,ZSOIL ,DZSNSO , & !in - SICE ,ILOC ,JLOC ,ZWT , & !in - SH2O ,SMC ,AI ,BI ,CI , & !inout - RHSTT ,SMCWTD ,QDRAIN ,DEEPRECH, & !inout - WPLUS ) !out + FST = 2.0**( (STC(1)-283.16)/10. ) + FSW = WROOT / (0.20+WROOT) * 0.23 / (0.23+WROOT) + RSSOIL = FSW * FST * parameters%MRP* MAX(0.,FASTCP*1.E-3)*12.E-6 -! ---------------------------------------------------------------------- -! calculate/update soil moisture content values -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: SMCMAX ! SOIL DEPENDENT -! ---------------------------------------------------------------------- - IMPLICIT NONE -! ---------------------------------------------------------------------- -!input + STABLC = 0.1*RSSOIL + FASTCP = FASTCP - (RSSOIL + STABLC)*DT + STBLCP = STBLCP + STABLC*DT - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: NSOIL ! - INTEGER, INTENT(IN) :: NSNOW ! - REAL, INTENT(IN) :: DT - REAL, INTENT(IN) :: ZWT - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SICE - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO ! snow/soil layer thickness [m] +! total carbon flux -!input and output - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SH2O - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: SMC - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: AI - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: BI - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: CI - REAL, DIMENSION(1:NSOIL), INTENT(INOUT) :: RHSTT - REAL , INTENT(INOUT) :: SMCWTD - REAL , INTENT(INOUT) :: QDRAIN - REAL , INTENT(INOUT) :: DEEPRECH + CFLUX = - CARBFX + RSLEAF + RSROOT + RSWOOD + RSSTEM & ! MB: add RSSTEM,GRSTEM,0.9*RSSOIL v3.7 + + 0.9*RSSOIL + GRLEAF + GRROOT + GRWOOD + GRSTEM ! g/m2/s -!output - REAL, INTENT(OUT) :: WPLUS !saturation excess water (m) +! for outputs -!local - INTEGER :: K - REAL, DIMENSION(1:NSOIL) :: RHSTTIN - REAL, DIMENSION(1:NSOIL) :: CIIN - REAL :: STOT - REAL :: EPORE - REAL :: WMINUS -! ---------------------------------------------------------------------- - WPLUS = 0.0 + GPP = CARBFX !g/m2/s C + NPP = NPPL + NPPW + NPPR +NPPS !g/m2/s C + AUTORS = RSROOT + RSWOOD + RSLEAF + RSSTEM + & !g/m2/s C MB: add RSSTEM, GRSTEM v3.7 + GRLEAF + GRROOT + GRWOOD + GRSTEM !g/m2/s C MB: add 0.9* v3.7 + HETERS = 0.9*RSSOIL !g/m2/s C + NEE = (AUTORS + HETERS - GPP)*44./12. !g/m2/s CO2 + TOTSC = FASTCP + STBLCP !g/m2 C + TOTLB = LFMASS + RTMASS +STMASS + WOOD !g/m2 C MB: add STMASS v3.7 - DO K = 1,NSOIL - RHSTT (K) = RHSTT(K) * DT - AI (K) = AI(K) * DT - BI (K) = 1. + BI(K) * DT - CI (K) = CI(K) * DT - END DO +! leaf area index and stem area index -! copy values for input variables before calling rosr12 + XLAI = MAX(LFMASS*LAPM,LAIMIN) + XSAI = MAX(STMASS*SAPM,XSAMIN) + + END SUBROUTINE CO2FLUX - DO K = 1,NSOIL - RHSTTIN(k) = RHSTT(K) - CIIN(k) = CI(K) - END DO +!== begin carbon_crop ============================================================================== -! call ROSR12 to solve the tri-diagonal matrix + SUBROUTINE CARBON_CROP (parameters,NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL ,JULIAN , & !in + DZSNSO ,STC ,SMC ,TV ,PSN ,FOLN ,BTRAN , & !in + SOLDN ,T2M , & !in + LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP ,GRAIN , & !inout + XLAI ,XSAI ,GDD , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC ,TOTLB ) !out +! ------------------------------------------------------------------------------------------ +! Initial crop version created by Xing Liu +! Initial crop version added by Barlage v3.8 - CALL ROSR12 (CI,AI,BI,CIIN,RHSTTIN,RHSTT,1,NSOIL,0) +! ------------------------------------------------------------------------------------------ + IMPLICIT NONE +! ------------------------------------------------------------------------------------------ +! inputs (carbon) - DO K = 1,NSOIL - SH2O(K) = SH2O(K) + CI(K) - ENDDO + type (noahmp_parameters), intent(in) :: parameters + INTEGER , INTENT(IN) :: NSNOW !number of snow layers + INTEGER , INTENT(IN) :: NSOIL !number of soil layers + INTEGER , INTENT(IN) :: VEGTYP !vegetation type + REAL , INTENT(IN) :: DT !time step (s) + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottomfrom soil surface + REAL , INTENT(IN) :: JULIAN !Julian day of year(fractional) ( 0 <= JULIAN < YEARLEN ) + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layerthickness [m] + REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature[k] + REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice +liq.) [m3/m3] + REAL , INTENT(IN) :: TV !vegetation temperature(k) + REAL , INTENT(IN) :: PSN !total leaf photosyn(umolco2/m2/s) [+] + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) + REAL , INTENT(IN) :: BTRAN !soil watertranspiration factor (0 to 1) + REAL , INTENT(IN) :: SOLDN !Downward solar radiation + REAL , INTENT(IN) :: T2M !air temperature -! excessive water above saturation in a layer is moved to -! its unsaturated layer like in a bucket +! input & output (carbon) -!gmmwith opt_run=5 there is soil moisture below nsoil, to the water table - IF(OPT_RUN == 5) THEN + REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] + REAL , INTENT(INOUT) :: RTMASS !mass of fine roots[g/m2] + REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] + REAL , INTENT(INOUT) :: WOOD !mass of wood (incl.woody roots) [g/m2] + REAL , INTENT(INOUT) :: STBLCP !stable carbon in deepsoil [g/m2] + REAL , INTENT(INOUT) :: FASTCP !short-lived carbon inshallow soil [g/m2] + REAL , INTENT(INOUT) :: GRAIN !mass of GRAIN [g/m2] + REAL , INTENT(INOUT) :: XLAI !leaf area index [-] + REAL , INTENT(INOUT) :: XSAI !stem area index [-] + REAL , INTENT(INOUT) :: GDD !growing degree days + +! outout + REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s C] + REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2/s C] + REAL , INTENT(OUT) :: NEE !net ecosystem exchange[g/m2/s CO2] + REAL , INTENT(OUT) :: AUTORS !net ecosystem respiration [g/m2/s C] + REAL , INTENT(OUT) :: HETERS !organic respiration[g/m2/s C] + REAL , INTENT(OUT) :: TOTSC !total soil carbon [g/m2C] + REAL , INTENT(OUT) :: TOTLB !total living carbon ([g/m2 C] -!update smcwtd +! local variables - IF(ZWT < ZSOIL(NSOIL)-DZSNSO(NSOIL))THEN -!accumulate qdrain to update deep water table and soil moisture later - DEEPRECH = DEEPRECH + DT * QDRAIN - ELSE - SMCWTD = SMCWTD + DT * QDRAIN / DZSNSO(NSOIL) - WPLUS = MAX((SMCWTD-SMCMAX), 0.0) * DZSNSO(NSOIL) - WMINUS = MAX((1.E-4-SMCWTD), 0.0) * DZSNSO(NSOIL) + INTEGER :: J !do-loop index + REAL :: WROOT !root zone soil water [-] + REAL :: WSTRES !water stress coeficient [-] (1. for wilting ) + INTEGER :: IPA !Planting index + INTEGER :: IHA !Havestindex(0=on,1=off) + INTEGER :: PGS !Plant growth stage - SMCWTD = MAX( MIN(SMCWTD,SMCMAX) , 1.E-4) - SH2O(NSOIL) = SH2O(NSOIL) + WPLUS/DZSNSO(NSOIL) + REAL :: PSNCROP -!reduce fluxes at the bottom boundaries accordingly - QDRAIN = QDRAIN - WPLUS/DT - DEEPRECH = DEEPRECH - WMINUS - ENDIF +! ------------------------------------------------------------------------------------------ + IF ( ( VEGTYP == parameters%iswater ) .OR. ( VEGTYP == parameters%ISBARREN ) .OR. & + ( VEGTYP == parameters%ISICE ) .or. (parameters%urban_flag) ) THEN + XLAI = 0. + XSAI = 0. + GPP = 0. + NPP = 0. + NEE = 0. + AUTORS = 0. + HETERS = 0. + TOTSC = 0. + TOTLB = 0. + LFMASS = 0. + RTMASS = 0. + STMASS = 0. + WOOD = 0. + STBLCP = 0. + FASTCP = 0. + GRAIN = 0. + RETURN + END IF - ENDIF +! water stress - DO K = NSOIL,2,-1 - EPORE = MAX ( 1.E-4 , ( SMCMAX - SICE(K) ) ) - WPLUS = MAX((SH2O(K)-EPORE), 0.0) * DZSNSO(K) - SH2O(K) = MIN(EPORE,SH2O(K)) - SH2O(K-1) = SH2O(K-1) + WPLUS/DZSNSO(K-1) - END DO - EPORE = MAX ( 1.E-4 , ( SMCMAX - SICE(1) ) ) - WPLUS = MAX((SH2O(1)-EPORE), 0.0) * DZSNSO(1) - SH2O(1) = MIN(EPORE,SH2O(1)) + WSTRES = 1.- BTRAN - END SUBROUTINE SSTEP + WROOT = 0. + DO J=1,parameters%NROOT + WROOT = WROOT + SMC(J)/parameters%SMCMAX(J) * DZSNSO(J) / (-ZSOIL(parameters%NROOT)) + ENDDO -!== begin wdfcnd1 ================================================================================== + CALL PSN_CROP ( parameters, & !in + SOLDN, XLAI, T2M, & !in + PSNCROP ) !out + + CALL GROWING_GDD (parameters, & !in + T2M , DT, JULIAN, & !in + GDD , & !inout + IPA , IHA, PGS) !out + + CALL CO2FLUX_CROP (parameters, & !in + DT ,STC(1) ,PSN ,TV ,WROOT ,WSTRES ,FOLN , & !in + IPA ,IHA ,PGS , & !in XING + XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , & !inout + FASTCP ,STBLCP ,WOOD ,GRAIN ,GDD , & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS , & !out + TOTSC ,TOTLB ) !out + + END SUBROUTINE CARBON_CROP + +!== begin co2flux_crop ============================================================================= + + SUBROUTINE CO2FLUX_CROP (parameters, & !in + DT ,STC ,PSN ,TV ,WROOT ,WSTRES ,FOLN , & !in + IPA ,IHA ,PGS , & !in XING + XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , & !inout + FASTCP ,STBLCP ,WOOD ,GRAIN ,GDD, & !inout + GPP ,NPP ,NEE ,AUTORS ,HETERS , & !out + TOTSC ,TOTLB ) !out +! ----------------------------------------------------------------------------------------- +! The original code from RE Dickinson et al.(1998) and Guo-Yue Niu(2004), +! modified by Xing Liu, 2014. +! +! ----------------------------------------------------------------------------------------- + IMPLICIT NONE +! ----------------------------------------------------------------------------------------- - SUBROUTINE WDFCND1 (WDF,WCND,SMC,FCR) -! ---------------------------------------------------------------------- -! calculate soil water diffusivity and soil hydraulic conductivity. -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: BEXP, DKSAT, DWSAT, SMCMAX ! SOIL DEPENDENT -! ---------------------------------------------------------------------- - IMPLICIT NONE -! ---------------------------------------------------------------------- -! input - REAL,INTENT(IN) :: SMC - REAL,INTENT(IN) :: FCR +! input -! output - REAL,INTENT(OUT) :: WCND - REAL,INTENT(OUT) :: WDF + type (noahmp_parameters), intent(in) :: parameters + REAL , INTENT(IN) :: DT !time step (s) + REAL , INTENT(IN) :: STC !soil temperature[k] + REAL , INTENT(IN) :: PSN !total leaf photosynthesis (umolco2/m2/s) + REAL , INTENT(IN) :: TV !leaf temperature (k) + REAL , INTENT(IN) :: WROOT !root zone soil water + REAL , INTENT(IN) :: WSTRES !soil water stress + REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) + INTEGER , INTENT(IN) :: IPA + INTEGER , INTENT(IN) :: IHA + INTEGER , INTENT(IN) :: PGS -! local - REAL :: EXPON - REAL :: FACTR - REAL :: VKWGT -! ---------------------------------------------------------------------- +! input and output -! soil water diffusivity + REAL , INTENT(INOUT) :: XLAI !leaf area index from leaf carbon [-] + REAL , INTENT(INOUT) :: XSAI !stem area index from leaf carbon [-] + REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] + REAL , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2] + REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] + REAL , INTENT(INOUT) :: FASTCP !short lived carbon [g/m2] + REAL , INTENT(INOUT) :: STBLCP !stable carbon pool [g/m2] + REAL , INTENT(INOUT) :: WOOD !mass of wood (incl. woody roots) [g/m2] + REAL , INTENT(INOUT) :: GRAIN !mass of grain (XING) [g/m2] + REAL , INTENT(INOUT) :: GDD !growing degree days (XING) - FACTR = MAX(0.01, SMC/SMCMAX) - EXPON = BEXP + 2.0 - WDF = DWSAT * FACTR ** EXPON - WDF = WDF * (1.0 - FCR) +! output -! hydraulic conductivity + REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s] + REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2] + REAL , INTENT(OUT) :: NEE !net ecosystem exchange (autors+heters-gpp) + REAL , INTENT(OUT) :: AUTORS !net ecosystem resp. (maintance and growth) + REAL , INTENT(OUT) :: HETERS !organic respiration + REAL , INTENT(OUT) :: TOTSC !total soil carbon (g/m2) + REAL , INTENT(OUT) :: TOTLB !total living carbon (g/m2) - EXPON = 2.0*BEXP + 3.0 - WCND = DKSAT * FACTR ** EXPON - WCND = WCND * (1.0 - FCR) +! local - END SUBROUTINE WDFCND1 + REAL :: CFLUX !carbon flux to atmosphere [g/m2/s] + REAL :: LFMSMN !minimum leaf mass [g/m2] + REAL :: RSWOOD !wood respiration [g/m2] + REAL :: RSLEAF !leaf maintenance respiration per timestep[g/m2] + REAL :: RSROOT !fine root respiration per time step [g/m2] + REAL :: RSGRAIN !grain respiration [g/m2] + REAL :: NPPL !leaf net primary productivity [g/m2/s] + REAL :: NPPR !root net primary productivity [g/m2/s] + REAL :: NPPW !wood net primary productivity [g/m2/s] + REAL :: NPPS !wood net primary productivity [g/m2/s] + REAL :: NPPG !grain net primary productivity [g/m2/s] + REAL :: DIELF !death of leaf mass per time step [g/m2] -!== begin wdfcnd2 ================================================================================== + REAL :: ADDNPPLF !leaf assimil after resp. losses removed[g/m2] + REAL :: ADDNPPST !stem assimil after resp. losses removed[g/m2] + REAL :: CARBFX !carbon assimilated per model step [g/m2] + REAL :: CBHYDRAFX!carbonhydrate assimilated per model step [g/m2] + REAL :: GRLEAF !growth respiration rate for leaf [g/m2/s] + REAL :: GRROOT !growth respiration rate for root [g/m2/s] + REAL :: GRWOOD !growth respiration rate for wood [g/m2/s] + REAL :: GRSTEM !growth respiration rate for stem [g/m2/s] + REAL :: GRGRAIN !growth respiration rate for stem [g/m2/s] + REAL :: LEAFPT !fraction of carbon allocated to leaves [-] + REAL :: LFDEL !maximum leaf mass available to change[g/m2/s] + REAL :: LFTOVR !stem turnover per time step [g/m2] + REAL :: STTOVR !stem turnover per time step [g/m2] + REAL :: WDTOVR !wood turnover per time step [g/m2] + REAL :: GRTOVR !grainturnover per time step [g/m2] + REAL :: RSSOIL !soil respiration per time step [g/m2] + REAL :: RTTOVR !root carbon loss per time step by turnover[g/m2] + REAL :: STABLC !decay rate of fast carbon to slow carbon[g/m2/s] + REAL :: WOODF !calculated wood to root ratio [-] + REAL :: NONLEF !fraction of carbon to root and wood [-] + REAL :: RESP !leaf respiration [umol/m2/s] + REAL :: RSSTEM !stem respiration [g/m2/s] - SUBROUTINE WDFCND2 (WDF,WCND,SMC,SICE) -! ---------------------------------------------------------------------- -! calculate soil water diffusivity and soil hydraulic conductivity. -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: BEXP, DKSAT, DWSAT, SMCMAX ! SOIL DEPENDENT -! ---------------------------------------------------------------------- - IMPLICIT NONE -! ---------------------------------------------------------------------- -! input - REAL,INTENT(IN) :: SMC - REAL,INTENT(IN) :: SICE + REAL :: FSW !soil water factor for microbial respiration + REAL :: FST !soil temperature factor for microbialrespiration + REAL :: FNF !foliage nitrogen adjustemt to respiration(<= 1) + REAL :: TF !temperature factor + REAL :: STDEL + REAL :: STMSMN + REAL :: SAPM !stem area per unit mass (m2/g) + REAL :: DIEST +! -------------------------- constants ------------------------------- + REAL :: BF !parameter for present wood allocation [-] + REAL :: RSWOODC !wood respiration coeficient [1/s] + REAL :: STOVRC !stem turnover coefficient [1/s] + REAL :: RSDRYC !degree of drying that reduces soilrespiration [-] + REAL :: RTOVRC !root turnover coefficient [1/s] + REAL :: WSTRC !water stress coeficient [-] + REAL :: LAIMIN !minimum leaf area index [m2/m2] + REAL :: XSAMIN !minimum leaf area index [m2/m2] + REAL :: SC + REAL :: SD + REAL :: VEGFRAC + REAL :: TEMP + +! Respiration as a function of temperature + + real :: r,x + r(x) = exp(0.08*(x-298.16)) +! --------------------------------------------------------------------------------- -! output - REAL,INTENT(OUT) :: WCND - REAL,INTENT(OUT) :: WDF +! constants + RSDRYC = 40.0 !original was 40.0 + RSWOODC = 3.0E-10 ! + BF = 0.90 !original was 0.90 ! carbon to roots + WSTRC = 100.0 + LAIMIN = 0.05 + XSAMIN = 0.01 -! local - REAL :: EXPON - REAL :: FACTR - REAL :: VKWGT -! ---------------------------------------------------------------------- + SAPM = 3.*0.001 ! m2/kg -->m2/g + LFMSMN = laimin/0.15 + STMSMN = xsamin/sapm +! --------------------------------------------------------------------------------- -! soil water diffusivity +! carbon assimilation +! 1 mole -> 12 g carbon or 44 g CO2 or 30 g CH20 + + CARBFX = PSN*12.e-6*IPA !umol co2 /m2/ s -> g/m2/s C + CBHYDRAFX = PSN*30.e-6*IPA + +! mainteinance respiration + FNF = MIN( FOLN/MAX(1.E-06,parameters%FOLN_MX), 1.0 ) + TF = parameters%Q10MR**( (TV-298.16)/10. ) + RESP = parameters%LFMR25 * TF * FNF * XLAI * (1.-WSTRES) ! umol/m2/s + RSLEAF = MIN(LFMASS/DT,RESP*30.e-6) ! g/m2/s + RSROOT = parameters%RTMR25*(RTMASS*1E-3)*TF * 30.e-6 ! g/m2/s + RSSTEM = parameters%STMR25*(STMASS*1E-3)*TF * 30.e-6 ! g/m2/s + RSGRAIN = parameters%GRAINMR25*(GRAIN*1E-3)*TF * 30.e-6 ! g/m2/s + +! calculate growth respiration for leaf, rtmass and grain + + GRLEAF = MAX(0.0,parameters%FRA_GR*(parameters%LFPT(PGS)*CBHYDRAFX - RSLEAF)) + GRSTEM = MAX(0.0,parameters%FRA_GR*(parameters%STPT(PGS)*CBHYDRAFX - RSSTEM)) + GRROOT = MAX(0.0,parameters%FRA_GR*(parameters%RTPT(PGS)*CBHYDRAFX - RSROOT)) + GRGRAIN = MAX(0.0,parameters%FRA_GR*(parameters%GRAINPT(PGS)*CBHYDRAFX - RSGRAIN)) + +! leaf turnover, stem turnover, root turnover and leaf death caused by soil +! water and soil temperature stress + + LFTOVR = parameters%LF_OVRC(PGS)*1.E-6*LFMASS + RTTOVR = parameters%RT_OVRC(PGS)*1.E-6*RTMASS + STTOVR = parameters%ST_OVRC(PGS)*1.E-6*STMASS + SC = EXP(-0.3*MAX(0.,TV-parameters%LEFREEZ)) * (LFMASS/120.) + SD = EXP((WSTRES-1.)*WSTRC) + DIELF = LFMASS*1.E-6*(parameters%DILE_FW(PGS) * SD + parameters%DILE_FC(PGS)*SC) - FACTR = MAX(0.01, SMC/SMCMAX) - EXPON = BEXP + 2.0 - WDF = DWSAT * FACTR ** EXPON +! Allocation of CBHYDRAFX to leaf, stem, root and grain at each growth stage - IF (SICE > 0.0) THEN - VKWGT = 1./ (1. + (500.* SICE)**3.) - WDF = VKWGT * WDF + (1.-VKWGT)*DWSAT*(0.2/SMCMAX)**EXPON - END IF -! hydraulic conductivity + ADDNPPLF = MAX(0.,parameters%LFPT(PGS)*CBHYDRAFX - GRLEAF-RSLEAF) + ADDNPPST = MAX(0.,parameters%STPT(PGS)*CBHYDRAFX - GRSTEM-RSSTEM) + - EXPON = 2.0*BEXP + 3.0 - WCND = DKSAT * FACTR ** EXPON +! avoid reducing leaf mass below its minimum value but conserve mass - END SUBROUTINE WDFCND2 + LFDEL = (LFMASS - LFMSMN)/DT + STDEL = (STMASS - STMSMN)/DT + DIELF = MIN(DIELF,LFDEL+ADDNPPLF-LFTOVR) -!== begin groundwater ============================================================================== +! net primary productivities - SUBROUTINE GROUNDWATER(NSNOW ,NSOIL ,DT ,SICE ,ZSOIL , & !in - STC ,WCND ,FCRMAX ,ILOC ,JLOC , & !in - SH2O ,ZWT ,WA ,WT , & !inout - QIN ,QDIS ) !out -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX, & ! SOIL DEPENDENT - TIMEAN ! RUNOFF GLOBAL -! ---------------------------------------------------------------------- - IMPLICIT NONE -! ---------------------------------------------------------------------- -! input - INTEGER, INTENT(IN) :: ILOC !grid index - INTEGER, INTENT(IN) :: JLOC !grid index - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER, INTENT(IN) :: NSOIL !no. of soil layers - REAL, INTENT(IN) :: DT !timestep [sec] - REAL, INTENT(IN) :: FCRMAX!maximum FCR (-) - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SICE !soil ice content [m3/m3] - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: WCND !hydraulic conductivity (m/s) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature (k) + NPPL = MAX(ADDNPPLF,-LFDEL) + NPPS = MAX(ADDNPPST,-STDEL) + NPPR = parameters%RTPT(PGS)*CBHYDRAFX - RSROOT - GRROOT + NPPG = parameters%GRAINPT(PGS)*CBHYDRAFX - RSGRAIN - GRGRAIN -! input and output - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SH2O !liquid soil water [m3/m3] - REAL, INTENT(INOUT) :: ZWT !the depth to water table [m] - REAL, INTENT(INOUT) :: WA !water storage in aquifer [mm] - REAL, INTENT(INOUT) :: WT !water storage in aquifer - !+ saturated soil [mm] -! output - REAL, INTENT(OUT) :: QIN !groundwater recharge [mm/s] - REAL, INTENT(OUT) :: QDIS !groundwater discharge [mm/s] +! masses of plant components + + LFMASS = LFMASS + (NPPL-LFTOVR-DIELF)*DT + STMASS = STMASS + (NPPS-STTOVR)*DT ! g/m2 + RTMASS = RTMASS + (NPPR-RTTOVR)*DT + GRAIN = GRAIN + NPPG*DT -! local - REAL :: FFF !runoff decay factor (m-1) - REAL :: RSBMX !baseflow coefficient [mm/s] - INTEGER :: IZ !do-loop index - INTEGER :: IWT !layer index above water table layer - REAL, DIMENSION( 1:NSOIL) :: DZMM !layer thickness [mm] - REAL, DIMENSION( 1:NSOIL) :: ZNODE !node depth [m] - REAL, DIMENSION( 1:NSOIL) :: MLIQ !liquid water mass [kg/m2 or mm] - REAL, DIMENSION( 1:NSOIL) :: EPORE !effective porosity [-] - REAL, DIMENSION( 1:NSOIL) :: HK !hydraulic conductivity [mm/s] - REAL, DIMENSION( 1:NSOIL) :: SMC !total soil water content [m3/m3] - REAL(KIND=8) :: S_NODE!degree of saturation of IWT layer - REAL :: DZSUM !cumulative depth above water table [m] - REAL :: SMPFZ !matric potential (frozen effects) [mm] - REAL :: KA !aquifer hydraulic conductivity [mm/s] - REAL :: WH_ZWT!water head at water table [mm] - REAL :: WH !water head at layer above ZWT [mm] - REAL :: WS !water used to fill air pore [mm] - REAL :: WTSUB !sum of HK*DZMM - REAL :: WATMIN!minimum soil vol soil moisture [m3/m3] - REAL :: XS !excessive water above saturation [mm] - REAL, PARAMETER :: ROUS = 0.2 !specific yield [-] - REAL, PARAMETER :: CMIC = 0.20 !microprore content (0.0-1.0) - !0.0-close to free drainage -! ------------------------------------------------------------- - QDIS = 0.0 - QIN = 0.0 + GPP = CBHYDRAFX* 0.4 !!g/m2/s C 0.4=12/30, CH20 to C -! Derive layer-bottom depth in [mm] -!KWM: Derive layer thickness in mm + IF(PGS==6) THEN + STMASS = STMASS - STMASS*(0.00005) + RTMASS = RTMASS - RTMASS*(0.0005) + GRAIN = GRAIN + STMASS*(0.00005) + RTMASS*(0.0005) + END IF + + IF(RTMASS.LT.0.0) THEN + RTTOVR = NPPR + RTMASS = 0.0 + ENDIF - DZMM(1) = -ZSOIL(1)*1.E3 - DO IZ = 2, NSOIL - DZMM(IZ) = 1.E3 * (ZSOIL(IZ - 1) - ZSOIL(IZ)) - ENDDO + IF(GRAIN.LT.0.0) THEN + GRAIN = 0.0 + ENDIF -! Derive node (middle) depth in [m] -!KWM: Positive number, depth below ground surface in m - ZNODE(1) = -ZSOIL(1) / 2. - DO IZ = 2, NSOIL - ZNODE(IZ) = -ZSOIL(IZ-1) + 0.5 * (ZSOIL(IZ-1) - ZSOIL(IZ)) - ENDDO + ! soil carbon budgets -! Convert volumetric soil moisture "sh2o" to mass + IF(PGS == 1 .OR. PGS == 2 .OR. PGS == 8) THEN + FASTCP=1000 + ELSE + FASTCP = FASTCP + (RTTOVR+LFTOVR+STTOVR+DIELF)*DT + END IF + FST = 2.0**( (STC-283.16)/10. ) + FSW = WROOT / (0.20+WROOT) * 0.23 / (0.23+WROOT) + RSSOIL = FSW * FST * parameters%MRP* MAX(0.,FASTCP*1.E-3)*12.E-6 - DO IZ = 1, NSOIL - SMC(IZ) = SH2O(IZ) + SICE(IZ) - MLIQ(IZ) = SH2O(IZ) * DZMM(IZ) - EPORE(IZ) = MAX(0.01,SMCMAX - SICE(IZ)) - HK(IZ) = 1.E3*WCND(IZ) - ENDDO + STABLC = 0.1*RSSOIL + FASTCP = FASTCP - (RSSOIL + STABLC)*DT + STBLCP = STBLCP + STABLC*DT -! The layer index of the first unsaturated layer, -! i.e., the layer right above the water table +! total carbon flux - IWT = NSOIL - DO IZ = 2,NSOIL - IF(ZWT .LE. -ZSOIL(IZ) ) THEN - IWT = IZ-1 - EXIT - END IF - ENDDO + CFLUX = - CARBFX + RSLEAF + RSROOT + RSSTEM & + + RSSOIL + GRLEAF + GRROOT ! g/m2/s 0.4=12/30, CH20 to C -! Groundwater discharge [mm/s] +! for outputs + !g/m2/s C - FFF = 6.0 - RSBMX = 5.0 + NPP = (NPPL + NPPS+ NPPR +NPPG)*0.4 !!g/m2/s C 0.4=12/30, CH20 to C + + + AUTORS = RSROOT + RSGRAIN + RSLEAF + & !g/m2/s C + GRLEAF + GRROOT + GRGRAIN !g/m2/s C - QDIS = (1.0-FCRMAX)*RSBMX*EXP(-TIMEAN)*EXP(-FFF*(ZWT-2.0)) + HETERS = RSSOIL !g/m2/s C + NEE = (AUTORS + HETERS - GPP)*44./30. !g/m2/s CO2 + TOTSC = FASTCP + STBLCP !g/m2 C -! Matric potential at the layer above the water table + TOTLB = LFMASS + RTMASS + GRAIN - S_NODE = MIN(1.0,SMC(IWT)/SMCMAX ) - S_NODE = MAX(S_NODE,REAL(0.01,KIND=8)) - SMPFZ = -PSISAT*1000.*S_NODE**(-BEXP) ! m --> mm - SMPFZ = MAX(-120000.0,CMIC*SMPFZ) +! leaf area index and stem area index + + XLAI = MAX(LFMASS*parameters%BIO2LAI,LAIMIN) + XSAI = MAX(STMASS*SAPM,XSAMIN) -! Recharge rate qin to groundwater + +!After harversting + IF(PGS == 8 ) THEN + LFMASS = 0.62 + STMASS = 0 + TOTLB = 0 + GPP = 0 + NPP = 0 + GRAIN = 0 + AUTORS = 0 + NEE = 0 + END IF - KA = HK(IWT) + IF(PGS == 1 .OR. PGS == 2 .OR. PGS == 8) THEN + XLAI = 0.05 + XSAI = 0.05 + LFMASS = LFMSMN + STMASS = STMSMN + RTMASS = 0 + END IF + +END SUBROUTINE CO2FLUX_CROP - WH_ZWT = - ZWT * 1.E3 !(mm) - WH = SMPFZ - ZNODE(IWT)*1.E3 !(mm) - QIN = - KA * (WH_ZWT-WH) /((ZWT-ZNODE(IWT))*1.E3) - QIN = MAX(-10.0/DT,MIN(10./DT,QIN)) - -! Water storage in the aquifer + saturated soil +!== begin growing_gdd ============================================================================== - WT = WT + (QIN - QDIS) * DT !(mm) + SUBROUTINE GROWING_GDD (parameters, & !in + T2M , DT, JULIAN, & !in + GDD , & !inout + IPA, IHA, PGS) !out +!=================================================================================================== - IF(IWT.EQ.NSOIL) THEN - WA = WA + (QIN - QDIS) * DT !(mm) - WT = WA - ZWT = (-ZSOIL(NSOIL) + 25.) - WA/1000./ROUS !(m) - MLIQ(NSOIL) = MLIQ(NSOIL) - QIN * DT ! [mm] +! input - MLIQ(NSOIL) = MLIQ(NSOIL) + MAX(0.,(WA - 5000.)) - WA = MIN(WA, 5000.) - ELSE - - IF (IWT.EQ.NSOIL-1) THEN - ZWT = -ZSOIL(NSOIL) & - - (WT-ROUS*1000*25.) / (EPORE(NSOIL))/1000. - ELSE - WS = 0. ! water used to fill soil air pores - DO IZ = IWT+2,NSOIL - WS = WS + EPORE(IZ) * DZMM(IZ) - ENDDO - ZWT = -ZSOIL(IWT+1) & - - (WT-ROUS*1000.*25.-WS) /(EPORE(IWT+1))/1000. - ENDIF + type (noahmp_parameters), intent(in) :: parameters + REAL , INTENT(IN) :: T2M !Air temperature + REAL , INTENT(IN) :: DT !time step (s) + REAL , INTENT(IN) :: JULIAN !Julian day of year (fractional) ( 0 <= JULIAN < YEARLEN ) - WTSUB = 0. - DO IZ = 1, NSOIL - WTSUB = WTSUB + HK(IZ)*DZMM(IZ) - END DO +! input and output - DO IZ = 1, NSOIL ! Removing subsurface runoff - MLIQ(IZ) = MLIQ(IZ) - QDIS*DT*HK(IZ)*DZMM(IZ)/WTSUB - END DO - END IF + REAL , INTENT(INOUT) :: GDD !growing degress days - ZWT = MAX(1.5,ZWT) +! output -! -! Limit MLIQ to be greater than or equal to watmin. -! Get water needed to bring MLIQ equal WATMIN from lower layer. -! - WATMIN = 0.01 - DO IZ = 1, NSOIL-1 - IF (MLIQ(IZ) .LT. 0.) THEN - XS = WATMIN-MLIQ(IZ) - ELSE - XS = 0. - END IF - MLIQ(IZ ) = MLIQ(IZ ) + XS - MLIQ(IZ+1) = MLIQ(IZ+1) - XS - END DO + INTEGER , INTENT(OUT) :: IPA !Planting index index(0=off, 1=on) + INTEGER , INTENT(OUT) :: IHA !Havestindex(0=on,1=off) + INTEGER , INTENT(OUT) :: PGS !Plant growth stage(1=S1,2=S2,3=S3) - IZ = NSOIL - IF (MLIQ(IZ) .LT. WATMIN) THEN - XS = WATMIN-MLIQ(IZ) - ELSE - XS = 0. - END IF - MLIQ(IZ) = MLIQ(IZ) + XS - WA = WA - XS - WT = WT - XS +!local - DO IZ = 1, NSOIL - SH2O(IZ) = MLIQ(IZ) / DZMM(IZ) - END DO + REAL :: GDDDAY !gap bewtween GDD and GDD8 + REAL :: DAYOFS2 !DAYS in stage2 + REAL :: TDIFF !temperature difference for growing degree days calculation + REAL :: TC - END SUBROUTINE GROUNDWATER + TC = T2M - 273.15 -!== begin shallowwatertable ======================================================================== +!Havestindex(0=on,1=off) - SUBROUTINE SHALLOWWATERTABLE (NSNOW ,NSOIL ,ZSOIL, DT , & !in - DZSNSO ,SMCEQ ,ILOC ,JLOC , & !in - SMC ,WTD ,SMCWTD ,RECH, QDRAIN ) !inout -! ---------------------------------------------------------------------- -!Diagnoses water table depth and computes recharge when the water table is within the resolved soil layers, -!according to the Miguez-Macho&Fan scheme -! ---------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: BEXP, PSISAT, SMCMAX ! SOIL DEPENDENT -! ---------------------------------------------------------------------- - IMPLICIT NONE -! ---------------------------------------------------------------------- -! input - INTEGER, INTENT(IN) :: NSNOW !maximum no. of snow layers - INTEGER, INTENT(IN) :: NSOIL !no. of soil layers - INTEGER, INTENT(IN) :: ILOC,JLOC - REAL, INTENT(IN) :: DT - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of soil layer-bottom [m] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO ! snow/soil layer thickness [m] - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMCEQ !equilibrium soil water content [m3/m3] + IPA = 1 + IHA = 1 -! input and output - REAL, DIMENSION( 1:NSOIL), INTENT(INOUT) :: SMC !total soil water content [m3/m3] - REAL, INTENT(INOUT) :: WTD !the depth to water table [m] - REAL, INTENT(INOUT) :: SMCWTD !soil moisture between bottom of the soil and the water table [m3/m3] - REAL, INTENT(OUT) :: RECH ! groundwater recharge (net vertical flux across the water table), positive up - REAL, INTENT(INOUT) :: QDRAIN - -! local - INTEGER :: IZ !do-loop index - INTEGER :: IWTD !layer index above water table layer - INTEGER :: KWTD !layer index where the water table layer is - REAL :: WTDOLD - REAL :: DZUP - REAL :: SMCEQDEEP - REAL, DIMENSION( 0:NSOIL) :: ZSOIL0 -! ------------------------------------------------------------- +!turn on/off the planting + + IF(JULIAN < parameters%PLTDAY) IPA = 0 + +!turn on/off the harvesting + IF(JULIAN >= parameters%HSDAY) IHA = 0 + +!Calculate the growing degree days + + IF(TC < parameters%GDDTBASE) THEN + TDIFF = 0.0 + ELSEIF(TC >= parameters%GDDTCUT) THEN + TDIFF = parameters%GDDTCUT - parameters%GDDTBASE + ELSE + TDIFF = TC - parameters%GDDTBASE + END IF + GDD = (GDD + TDIFF) * IPA * IHA -ZSOIL0(1:NSOIL) = ZSOIL(1:NSOIL) -ZSOIL0(0) = 0. + GDDDAY = GDD / (86400.0 / DT) + + ! Decide corn growth stage, based on Hybrid-Maize + ! PGS = 1 : Before planting + ! PGS = 2 : from tassel initiation to silking + ! PGS = 3 : from silking to effective grain filling + ! PGS = 4 : from effective grain filling to pysiological maturity + ! PGS = 5 : GDDM=1389 + ! PGS = 6 : + ! PGS = 7 : + ! PGS = 8 : + ! GDDM = 1389 + ! GDDM = 1555 + ! GDDSK = 0.41*GDDM +145.4+150 !from hybrid-maize + ! GDDS1 = ((GDDSK-96)/38.9-4)*21 + ! GDDS1 = 0.77*GDDSK + ! GDDS3 = GDDSK+170 + ! GDDS3 = 170 + + IF(GDDDAY > 0.0) PGS = 2 + + IF(GDDDAY >= parameters%GDDS1) PGS = 3 + + IF(GDDDAY >= parameters%GDDS2) PGS = 4 + + IF(GDDDAY >= parameters%GDDS3) PGS = 5 + + IF(GDDDAY >= parameters%GDDS4) PGS = 6 + + IF(GDDDAY >= parameters%GDDS5) PGS = 7 + + IF(JULIAN >= parameters%HSDAY) PGS = 8 -!find the layer where the water table is - DO IZ=NSOIL,1,-1 - IF(WTD + 1.E-6 < ZSOIL0(IZ)) EXIT - ENDDO - IWTD=IZ + IF(JULIAN < parameters%PLTDAY) PGS = 1 - - KWTD=IWTD+1 !layer where the water table is - IF(KWTD.LE.NSOIL)THEN !wtd in the resolved layers - WTDOLD=WTD - IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN - - IF(SMC(KWTD).EQ.SMCMAX)THEN !wtd went to the layer above - WTD=ZSOIL0(IWTD) - RECH=-(WTDOLD-WTD) * (SMCMAX-SMCEQ(KWTD)) - IWTD=IWTD-1 - KWTD=KWTD-1 - IF(KWTD.GE.1)THEN - IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN - WTDOLD=WTD - WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) & - - SMCEQ(KWTD)*ZSOIL0(IWTD) + SMCMAX*ZSOIL0(KWTD) ) / & - ( SMCMAX-SMCEQ(KWTD) ), ZSOIL0(IWTD)) - RECH=RECH-(WTDOLD-WTD) * (SMCMAX-SMCEQ(KWTD)) - ENDIF - ENDIF - ELSE !wtd stays in the layer - WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) & - - SMCEQ(KWTD)*ZSOIL0(IWTD) + SMCMAX*ZSOIL0(KWTD) ) / & - ( SMCMAX-SMCEQ(KWTD) ), ZSOIL0(IWTD)) - RECH=-(WTDOLD-WTD) * (SMCMAX-SMCEQ(KWTD)) - ENDIF - - ELSE !wtd has gone down to the layer below - WTD=ZSOIL0(KWTD) - RECH=-(WTDOLD-WTD) * (SMCMAX-SMCEQ(KWTD)) - KWTD=KWTD+1 - IWTD=IWTD+1 -!wtd crossed to the layer below. Now adjust it there - IF(KWTD.LE.NSOIL)THEN - WTDOLD=WTD - IF(SMC(KWTD).GT.SMCEQ(KWTD))THEN - WTD = MIN( ( SMC(KWTD)*DZSNSO(KWTD) & - - SMCEQ(KWTD)*ZSOIL0(IWTD) + SMCMAX*ZSOIL0(KWTD) ) / & - ( SMCMAX-SMCEQ(KWTD) ) , ZSOIL0(IWTD) ) - ELSE - WTD=ZSOIL0(KWTD) - ENDIF - RECH = RECH - (WTDOLD-WTD) * & - (SMCMAX-SMCEQ(KWTD)) +END SUBROUTINE GROWING_GDD - ELSE - WTDOLD=WTD -!restore smoi to equilibrium value with water from the ficticious layer below -! SMCWTD=SMCWTD-(SMCEQ(NSOIL)-SMC(NSOIL)) -! QDRAIN = QDRAIN - 1000 * (SMCEQ(NSOIL)-SMC(NSOIL)) * DZSNSO(NSOIL) / DT -! SMC(NSOIL)=SMCEQ(NSOIL) -!adjust wtd in the ficticious layer below - SMCEQDEEP = SMCMAX * ( -PSISAT / ( -PSISAT - DZSNSO(NSOIL) ) ) ** (1./BEXP) - WTD = MIN( ( SMCWTD*DZSNSO(NSOIL) & - - SMCEQDEEP*ZSOIL0(NSOIL) + SMCMAX*(ZSOIL0(NSOIL)-DZSNSO(NSOIL)) ) / & - ( SMCMAX-SMCEQDEEP ) , ZSOIL0(NSOIL) ) - RECH = RECH - (WTDOLD-WTD) * & - (SMCMAX-SMCEQDEEP) - ENDIF - - ENDIF - ELSEIF(WTD.GE.ZSOIL0(NSOIL)-DZSNSO(NSOIL))THEN -!if wtd was already below the bottom of the resolved soil crust - WTDOLD=WTD - SMCEQDEEP = SMCMAX * ( -PSISAT / ( -PSISAT - DZSNSO(NSOIL) ) ) ** (1./BEXP) - IF(SMCWTD.GT.SMCEQDEEP)THEN - WTD = MIN( ( SMCWTD*DZSNSO(NSOIL) & - - SMCEQDEEP*ZSOIL0(NSOIL) + SMCMAX*(ZSOIL0(NSOIL)-DZSNSO(NSOIL)) ) / & - ( SMCMAX-SMCEQDEEP ) , ZSOIL0(NSOIL) ) - RECH = -(WTDOLD-WTD) * (SMCMAX-SMCEQDEEP) - ELSE - RECH = -(WTDOLD-(ZSOIL0(NSOIL)-DZSNSO(NSOIL))) * (SMCMAX-SMCEQDEEP) - WTDOLD=ZSOIL0(NSOIL)-DZSNSO(NSOIL) -!and now even further down - DZUP=(SMCEQDEEP-SMCWTD)*DZSNSO(NSOIL)/(SMCMAX-SMCEQDEEP) - WTD=WTDOLD-DZUP - RECH = RECH - (SMCMAX-SMCEQDEEP)*DZUP - SMCWTD=SMCEQDEEP - ENDIF +!== begin psn_crop ================================================================================= - - ENDIF +SUBROUTINE PSN_CROP ( parameters, & !in + SOLDN, XLAI,T2M, & !in + PSNCROP ) !out +!=================================================================================================== -IF(IWTD.LT.NSOIL)SMCWTD=SMCMAX +! input -END SUBROUTINE SHALLOWWATERTABLE + type (noahmp_parameters), intent(in) :: parameters + REAL , INTENT(IN) :: SOLDN ! downward solar radiation + REAL , INTENT(IN) :: XLAI ! LAI + REAL , INTENT(IN) :: T2M ! air temp + REAL , INTENT(OUT) :: PSNCROP ! -! ================================================================================================== -! ********************* end of water subroutines ****************************************** -! ================================================================================================== +!local -!== begin carbon =================================================================================== + REAL :: PAR ! photosynthetically active radiation (w/m2) 1 W m-2 = 0.0864 MJ m-2 day-1 + REAL :: Amax ! Maximum CO2 assimulation rate g/co2/s + REAL :: L1 ! Three Gaussian method + REAL :: L2 ! Three Gaussian method + REAL :: L3 ! Three Gaussian method + REAL :: I1 ! Three Gaussian method + REAL :: I2 ! Three Gaussian method + REAL :: I3 ! Three Gaussian method + REAL :: A1 ! Three Gaussian method + REAL :: A2 ! Three Gaussian method + REAL :: A3 ! Three Gaussian method + REAL :: A ! CO2 Assimulation + REAL :: TC + + TC = T2M - 273.15 + + PAR = parameters%I2PAR * SOLDN * 0.0036 !w to MJ m-2 + + IF(TC < parameters%TASSIM0) THEN + Amax = 1E-10 + ELSEIF(TC >= parameters%TASSIM0 .and. TC < parameters%TASSIM1) THEN + Amax = (TC - parameters%TASSIM0) * parameters%Aref / (parameters%TASSIM1 - parameters%TASSIM0) + ELSEIF(TC >= parameters%TASSIM1 .and. TC < parameters%TASSIM2) THEN + Amax = parameters%Aref + ELSE + Amax= parameters%Aref - 0.2 * (T2M - parameters%TASSIM2) + ENDIF + + Amax = max(amax,0.01) - SUBROUTINE CARBON (NSNOW ,NSOIL ,VEGTYP ,DT ,ZSOIL , & !in - DZSNSO ,STC ,SMC ,TV ,TG ,PSN , & !in - FOLN ,BTRAN ,APAR ,FVEG ,IGS , & !in - TROOT ,IST ,LAT ,ILOC ,JLOC , & !in - LFMASS ,RTMASS ,STMASS ,WOOD ,STBLCP ,FASTCP , & !inout - GPP ,NPP ,NEE ,AUTORS ,HETERS ,TOTSC , & !out - TOTLB ,XLAI ,XSAI ) !out -! ------------------------------------------------------------------------------------------ - USE NOAHMP_PARAMETERS, ONLY: SMCMAX, SLA, NROOT, & ! SOIL AND VEGETATION DEPENDENT - ISBARREN, ISICE, ISWATER, ISURBAN ! MP CONSTANT -! ------------------------------------------------------------------------------------------ - IMPLICIT NONE -! ------------------------------------------------------------------------------------------ -! inputs (carbon) + IF(XLAI <= 0.05) THEN + L1 = 0.1127 * 0.05 !use initial LAI(0.05), avoid error + L2 = 0.5 * 0.05 + L3 = 0.8873 * 0.05 + ELSE + L1 = 0.1127 * XLAI + L2 = 0.5 * XLAI + L3 = 0.8873 * XLAI + END IF - INTEGER , INTENT(IN) :: ILOC !grid index - INTEGER , INTENT(IN) :: JLOC !grid index - INTEGER , INTENT(IN) :: VEGTYP !vegetation type - INTEGER , INTENT(IN) :: NSNOW !number of snow layers - INTEGER , INTENT(IN) :: NSOIL !number of soil layers - REAL , INTENT(IN) :: LAT !latitude (radians) - REAL , INTENT(IN) :: DT !time step (s) - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: ZSOIL !depth of layer-bottom from soil surface - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature [k] - REAL, DIMENSION( 1:NSOIL), INTENT(IN) :: SMC !soil moisture (ice + liq.) [m3/m3] - REAL , INTENT(IN) :: TV !vegetation temperature (k) - REAL , INTENT(IN) :: TG !ground temperature (k) - REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) - REAL , INTENT(IN) :: BTRAN !soil water transpiration factor (0 to 1) - REAL , INTENT(IN) :: PSN !total leaf photosyn (umolco2/m2/s) [+] - REAL , INTENT(IN) :: APAR !PAR by canopy (w/m2) - REAL , INTENT(IN) :: IGS !growing season index (0=off, 1=on) - REAL , INTENT(IN) :: FVEG !vegetation greenness fraction - REAL , INTENT(IN) :: TROOT !root-zone averaged temperature (k) - INTEGER , INTENT(IN) :: IST !surface type 1->soil; 2->lake + I1 = parameters%k * PAR * exp(-parameters%k * L1) + I2 = parameters%k * PAR * exp(-parameters%k * L2) + I3 = parameters%k * PAR * exp(-parameters%k * L3) -! input & output (carbon) + I1 = max(I1,1E-10) + I2 = max(I2,1E-10) + I3 = max(I3,1E-10) - REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] - REAL , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2] - REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] - REAL , INTENT(INOUT) :: WOOD !mass of wood (incl. woody roots) [g/m2] - REAL , INTENT(INOUT) :: STBLCP !stable carbon in deep soil [g/m2] - REAL , INTENT(INOUT) :: FASTCP !short-lived carbon in shallow soil [g/m2] + A1 = Amax * (1 - exp(-parameters%epsi * I1 / Amax)) + A2 = Amax * (1 - exp(-parameters%epsi * I2 / Amax)) * 1.6 + A3 = Amax * (1 - exp(-parameters%epsi * I3 / Amax)) -! outputs: (carbon) + IF (XLAI <= 0.05) THEN + A = (A1+A2+A3) / 3.6 * 0.05 + ELSEIF (XLAI > 0.05 .and. XLAI <= 4.0) THEN + A = (A1+A2+A3) / 3.6 * XLAI + ELSE + A = (A1+A2+A3) / 3.6 * 4 + END IF - REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s C] - REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2/s C] - REAL , INTENT(OUT) :: NEE !net ecosystem exchange [g/m2/s CO2] - REAL , INTENT(OUT) :: AUTORS !net ecosystem respiration [g/m2/s C] - REAL , INTENT(OUT) :: HETERS !organic respiration [g/m2/s C] - REAL , INTENT(OUT) :: TOTSC !total soil carbon [g/m2 C] - REAL , INTENT(OUT) :: TOTLB !total living carbon ([g/m2 C] - REAL , INTENT(OUT) :: XLAI !leaf area index [-] - REAL , INTENT(OUT) :: XSAI !stem area index [-] -! REAL , INTENT(OUT) :: VOCFLX(5) ! voc fluxes [ug C m-2 h-1] + A = A * parameters%PSNRF ! Attainable -! local variables + PSNCROP = 6.313 * A ! (1/44) * 1000000)/3600 = 6.313 - INTEGER :: J !do-loop index - REAL :: WROOT !root zone soil water [-] - REAL :: WSTRES !water stress coeficient [-] (1. for wilting ) - REAL :: LAPM !leaf area per unit mass [m2/g] +END SUBROUTINE PSN_CROP + +!== begin bvocflux ================================================================================= + +! SUBROUTINE BVOCFLUX(parameters,VOCFLX, VEGTYP, VEGFRAC, APAR, TV ) +! ! ------------------------------------------------------------------------------------------ +! implicit none +! ------------------------------------------------------------------------------------------ +! +! ------------------------ code history --------------------------- +! source file: BVOC +! purpose: BVOC emissions +! DESCRIPTION: +! Volatile organic compound emission +! This code simulates volatile organic compound emissions +! following the algorithm presented in Guenther, A., 1999: Modeling +! Biogenic Volatile Organic Compound Emissions to the Atmosphere. In +! Reactive Hydrocarbons in the Atmosphere, Ch. 3 +! This model relies on the assumption that 90% of isoprene and monoterpene +! emissions originate from canopy foliage: +! E = epsilon * gamma * density * delta +! The factor delta (longterm activity factor) applies to isoprene emission +! from deciduous plants only. We neglect this factor at the present time. +! This factor is discussed in Guenther (1997). +! Subroutine written to operate at the patch level. +! IN FINAL IMPLEMENTATION, REMEMBER: +! 1. may wish to call this routine only as freq. as rad. calculations +! 2. may wish to place epsilon values directly in pft-physiology file +! ------------------------ input/output variables ----------------- +! input +! integer ,INTENT(IN) :: vegtyp !vegetation type +! real ,INTENT(IN) :: vegfrac !green vegetation fraction [0.0-1.0] +! real ,INTENT(IN) :: apar !photosynthesis active energy by canopy (w/m2) +! real ,INTENT(IN) :: tv !vegetation canopy temperature (k) +! +! output +! real ,INTENT(OUT) :: vocflx(5) ! voc fluxes [ug C m-2 h-1] +! +! Local Variables +! +! real, parameter :: R = 8.314 ! univ. gas constant [J K-1 mol-1] +! real, parameter :: alpha = 0.0027 ! empirical coefficient +! real, parameter :: cl1 = 1.066 ! empirical coefficient +! real, parameter :: ct1 = 95000.0 ! empirical coefficient [J mol-1] +! real, parameter :: ct2 = 230000.0 ! empirical coefficient [J mol-1] +! real, parameter :: ct3 = 0.961 ! empirical coefficient +! real, parameter :: tm = 314.0 ! empirical coefficient [K] +! real, parameter :: tstd = 303.0 ! std temperature [K] +! real, parameter :: bet = 0.09 ! beta empirical coefficient [K-1] +! +! integer ivoc ! do-loop index +! integer ityp ! do-loop index +! real epsilon(5) +! real gamma(5) +! real density +! real elai +! real par,cl,reciprod,ct +! +! epsilon : +! +! do ivoc = 1, 5 +! epsilon(ivoc) = parameters%eps(VEGTYP,ivoc) +! end do +! +! gamma : Activity factor. Units [dimensionless] +! +! reciprod = 1. / (R * tv * tstd) +! ct = exp(ct1 * (tv - tstd) * reciprod) / & +! (ct3 + exp(ct2 * (tv - tm) * reciprod)) +! +! par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s) +! cl = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5) +! +! gamma(1) = cl * ct ! for isoprenes +! +! do ivoc = 2, 5 +! gamma(ivoc) = exp(bet * (tv - tstd)) +! end do +! +! Foliage density +! +! transform vegfrac to lai +! +! elai = max(0.0,-6.5/2.5*alog((1.-vegfrac))) +! density = elai / (parameters%slarea(VEGTYP) * 0.5) +! +! calculate the voc flux +! +! do ivoc = 1, 5 +! vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density +! end do +! +! end subroutine bvocflux +! ================================================================================================== +! ********************************* end of carbon subroutines ***************************** +! ================================================================================================== - IF ( ( VEGTYP == ISWATER ) .OR. ( VEGTYP == ISBARREN ) .OR. ( VEGTYP == ISICE ) .or. (VEGTYP == ISURBAN) ) THEN - XLAI = 0. - XSAI = 0. - GPP = 0. - NPP = 0. - NEE = 0. - AUTORS = 0. - HETERS = 0. - TOTSC = 0. - TOTLB = 0. - LFMASS = 0. - RTMASS = 0. - STMASS = 0. - WOOD = 0. - STBLCP = 0. - FASTCP = 0. +!== begin noahmp_options =========================================================================== + + subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & + iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc, & + iopt_rsf ) + + implicit none + + INTEGER, INTENT(IN) :: idveg !dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 + INTEGER, INTENT(IN) :: iopt_crs !canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis) + INTEGER, INTENT(IN) :: iopt_btr !soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB) + INTEGER, INTENT(IN) :: iopt_run !runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS) + INTEGER, INTENT(IN) :: iopt_sfc !surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97) + INTEGER, INTENT(IN) :: iopt_frz !supercooled liquid water (1-> NY06; 2->Koren99) + INTEGER, INTENT(IN) :: iopt_inf !frozen soil permeability (1-> NY06; 2->Koren99) + INTEGER, INTENT(IN) :: iopt_rad !radiation transfer (1->gap=F(3D,cosz); 2->gap=0; 3->gap=1-Fveg) + INTEGER, INTENT(IN) :: iopt_alb !snow surface albedo (1->BATS; 2->CLASS) + INTEGER, INTENT(IN) :: iopt_snf !rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah) + INTEGER, INTENT(IN) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->Noah) - RETURN - END IF + INTEGER, INTENT(IN) :: iopt_stc !snow/soil temperature time scheme (only layer 1) + ! 1 -> semi-implicit; 2 -> full implicit (original Noah) + INTEGER, INTENT(IN) :: iopt_rsf !surface resistance (1->Sakaguchi/Zeng; 2->Seller; 3->mod Sellers; 4->1+snow) - LAPM = SLA / 1000. ! m2/kg -> m2/g +! ------------------------------------------------------------------------------------------------- -! water stress + dveg = idveg + + opt_crs = iopt_crs + opt_btr = iopt_btr + opt_run = iopt_run + opt_sfc = iopt_sfc + opt_frz = iopt_frz + opt_inf = iopt_inf + opt_rad = iopt_rad + opt_alb = iopt_alb + opt_snf = iopt_snf + opt_tbot = iopt_tbot + opt_stc = iopt_stc + opt_rsf = iopt_rsf + + end subroutine noahmp_options + +END MODULE MODULE_SF_NOAHMPLSM - WSTRES = 1.- BTRAN +MODULE NOAHMP_TABLES - WROOT = 0. - DO J=1,NROOT - WROOT = WROOT + SMC(J)/SMCMAX * DZSNSO(J) / (-ZSOIL(NROOT)) - ENDDO + IMPLICIT NONE - CALL CO2FLUX (NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in - DZSNSO ,STC ,PSN ,TROOT ,TV , & !in - WROOT ,WSTRES ,FOLN ,LAPM , & !in - LAT ,ILOC ,JLOC ,FVEG , & !in - XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , & !inout - FASTCP ,STBLCP ,WOOD , & !inout - GPP ,NPP ,NEE ,AUTORS ,HETERS , & !out - TOTSC ,TOTLB ) !out + INTEGER, PRIVATE, PARAMETER :: MVT = 27 + INTEGER, PRIVATE, PARAMETER :: MBAND = 2 + INTEGER, PRIVATE, PARAMETER :: MSC = 8 + INTEGER, PRIVATE, PARAMETER :: MAX_SOILTYP = 30 + INTEGER, PRIVATE, PARAMETER :: NCROP = 5 + INTEGER, PRIVATE, PARAMETER :: NSTAGE = 8 -! CALL BVOC (VOCFLX, VEGTYP, VEGFAC, APAR, TV) -! CALL CH4 +! MPTABLE.TBL vegetation parameters - END SUBROUTINE CARBON + INTEGER :: ISURBAN_TABLE + INTEGER :: ISWATER_TABLE + INTEGER :: ISBARREN_TABLE + INTEGER :: ISICE_TABLE + INTEGER :: EBLFOREST_TABLE + INTEGER :: LOW_DENSITY_RESIDENTIAL_TABLE + INTEGER :: HIGH_DENSITY_RESIDENTIAL_TABLE + INTEGER :: HIGH_INTENSITY_INDUSTRIAL_TABLE -!== begin co2flux ================================================================================== + REAL :: CH2OP_TABLE(MVT) !maximum intercepted h2o per unit lai+sai (mm) + REAL :: DLEAF_TABLE(MVT) !characteristic leaf dimension (m) + REAL :: Z0MVT_TABLE(MVT) !momentum roughness length (m) + REAL :: HVT_TABLE(MVT) !top of canopy (m) + REAL :: HVB_TABLE(MVT) !bottom of canopy (m) + REAL :: DEN_TABLE(MVT) !tree density (no. of trunks per m2) + REAL :: RC_TABLE(MVT) !tree crown radius (m) + REAL :: MFSNO_TABLE(MVT) !snowmelt curve parameter () + REAL :: SAIM_TABLE(MVT,12) !monthly stem area index, one-sided + REAL :: LAIM_TABLE(MVT,12) !monthly leaf area index, one-sided + REAL :: SLA_TABLE(MVT) !single-side leaf area per Kg [m2/kg] + REAL :: DILEFC_TABLE(MVT) !coeficient for leaf stress death [1/s] + REAL :: DILEFW_TABLE(MVT) !coeficient for leaf stress death [1/s] + REAL :: FRAGR_TABLE(MVT) !fraction of growth respiration !original was 0.3 + REAL :: LTOVRC_TABLE(MVT) !leaf turnover [1/s] - SUBROUTINE CO2FLUX (NSNOW ,NSOIL ,VEGTYP ,IGS ,DT , & !in - DZSNSO ,STC ,PSN ,TROOT ,TV , & !in - WROOT ,WSTRES ,FOLN ,LAPM , & !in - LAT ,ILOC ,JLOC ,FVEG , & !in - XLAI ,XSAI ,LFMASS ,RTMASS ,STMASS , & !inout - FASTCP ,STBLCP ,WOOD , & !inout - GPP ,NPP ,NEE ,AUTORS ,HETERS , & !out - TOTSC ,TOTLB ) !out -! ----------------------------------------------------------------------------------------- -! The original code is from RE Dickinson et al.(1998), modifed by Guo-Yue Niu, 2004 -! ----------------------------------------------------------------------------------------- - USE NOAHMP_PARAMETERS, ONLY: FOLNMX, ARM, RMF25, RMR25, RMS25, WDPOOL, WRRAT, LTOVRC, & - TDLEF, DILEFW, DILEFC, FRAGR, TMIN, MRP, & ! VEGETATION DEPENDENT - EBLFOREST ! VEG CONSTANT -! -------------------------------------------------------------------------------------------------- - IMPLICIT NONE -! ----------------------------------------------------------------------------------------- + REAL :: C3PSN_TABLE(MVT) !photosynthetic pathway: 0. = c4, 1. = c3 + REAL :: KC25_TABLE(MVT) !co2 michaelis-menten constant at 25c (pa) + REAL :: AKC_TABLE(MVT) !q10 for kc25 + REAL :: KO25_TABLE(MVT) !o2 michaelis-menten constant at 25c (pa) + REAL :: AKO_TABLE(MVT) !q10 for ko25 + REAL :: VCMX25_TABLE(MVT) !maximum rate of carboxylation at 25c (umol co2/m**2/s) + REAL :: AVCMX_TABLE(MVT) !q10 for vcmx25 + REAL :: BP_TABLE(MVT) !minimum leaf conductance (umol/m**2/s) + REAL :: MP_TABLE(MVT) !slope of conductance-to-photosynthesis relationship + REAL :: QE25_TABLE(MVT) !quantum efficiency at 25c (umol co2 / umol photon) + REAL :: AQE_TABLE(MVT) !q10 for qe25 + REAL :: RMF25_TABLE(MVT) !leaf maintenance respiration at 25c (umol co2/m**2/s) + REAL :: RMS25_TABLE(MVT) !stem maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: RMR25_TABLE(MVT) !root maintenance respiration at 25c (umol co2/kg bio/s) + REAL :: ARM_TABLE(MVT) !q10 for maintenance respiration + REAL :: FOLNMX_TABLE(MVT) !foliage nitrogen concentration when f(n)=1 (%) + REAL :: TMIN_TABLE(MVT) !minimum temperature for photosynthesis (k) -! input + REAL :: XL_TABLE(MVT) !leaf/stem orientation index + REAL :: RHOL_TABLE(MVT,MBAND) !leaf reflectance: 1=vis, 2=nir + REAL :: RHOS_TABLE(MVT,MBAND) !stem reflectance: 1=vis, 2=nir + REAL :: TAUL_TABLE(MVT,MBAND) !leaf transmittance: 1=vis, 2=nir + REAL :: TAUS_TABLE(MVT,MBAND) !stem transmittance: 1=vis, 2=nir - INTEGER , INTENT(IN) :: ILOC !grid index - INTEGER , INTENT(IN) :: JLOC !grid index - INTEGER , INTENT(IN) :: VEGTYP !vegetation physiology type - INTEGER , INTENT(IN) :: NSNOW !number of snow layers - INTEGER , INTENT(IN) :: NSOIL !number of soil layers - REAL , INTENT(IN) :: DT !time step (s) - REAL , INTENT(IN) :: LAT !latitude (radians) - REAL , INTENT(IN) :: IGS !growing season index (0=off, 1=on) - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: DZSNSO !snow/soil layer thickness [m] - REAL, DIMENSION(-NSNOW+1:NSOIL), INTENT(IN) :: STC !snow/soil temperature [k] - REAL , INTENT(IN) :: PSN !total leaf photosynthesis (umolco2/m2/s) - REAL , INTENT(IN) :: TROOT !root-zone averaged temperature (k) - REAL , INTENT(IN) :: TV !leaf temperature (k) - REAL , INTENT(IN) :: WROOT !root zone soil water - REAL , INTENT(IN) :: WSTRES !soil water stress - REAL , INTENT(IN) :: FOLN !foliage nitrogen (%) - REAL , INTENT(IN) :: LAPM !leaf area per unit mass [m2/g] - REAL , INTENT(IN) :: FVEG !vegetation greenness fraction + REAL :: MRP_TABLE(MVT) !microbial respiration parameter (umol co2 /kg c/ s) + REAL :: CWPVT_TABLE(MVT) !empirical canopy wind parameter -! input and output + REAL :: WRRAT_TABLE(MVT) !wood to non-wood ratio + REAL :: WDPOOL_TABLE(MVT) !wood pool (switch 1 or 0) depending on woody or not [-] + REAL :: TDLEF_TABLE(MVT) !characteristic T for leaf freezing [K] - REAL , INTENT(INOUT) :: XLAI !leaf area index from leaf carbon [-] - REAL , INTENT(INOUT) :: XSAI !stem area index from leaf carbon [-] - REAL , INTENT(INOUT) :: LFMASS !leaf mass [g/m2] - REAL , INTENT(INOUT) :: RTMASS !mass of fine roots [g/m2] - REAL , INTENT(INOUT) :: STMASS !stem mass [g/m2] - REAL , INTENT(INOUT) :: FASTCP !short lived carbon [g/m2] - REAL , INTENT(INOUT) :: STBLCP !stable carbon pool [g/m2] - REAL , INTENT(INOUT) :: WOOD !mass of wood (incl. woody roots) [g/m2] + REAL :: NROOT_TABLE(MVT) !number of soil layers with root present + REAL :: RGL_TABLE(MVT) !Parameter used in radiation stress function + REAL :: RS_TABLE(MVT) !Minimum stomatal resistance [s m-1] + REAL :: HS_TABLE(MVT) !Parameter used in vapor pressure deficit function + REAL :: TOPT_TABLE(MVT) !Optimum transpiration air temperature [K] + REAL :: RSMAX_TABLE(MVT) !Maximal stomatal resistance [s m-1] -! output +! SOILPARM.TBL parameters - REAL , INTENT(OUT) :: GPP !net instantaneous assimilation [g/m2/s] - REAL , INTENT(OUT) :: NPP !net primary productivity [g/m2] - REAL , INTENT(OUT) :: NEE !net ecosystem exchange (autors+heters-gpp) - REAL , INTENT(OUT) :: AUTORS !net ecosystem resp. (maintance and growth) - REAL , INTENT(OUT) :: HETERS !organic respiration - REAL , INTENT(OUT) :: TOTSC !total soil carbon (g/m2) - REAL , INTENT(OUT) :: TOTLB !total living carbon (g/m2) + INTEGER :: SLCATS -! local + REAL :: BEXP_TABLE(MAX_SOILTYP) !maximum intercepted h2o per unit lai+sai (mm) + REAL :: SMCDRY_TABLE(MAX_SOILTYP) !characteristic leaf dimension (m) + REAL :: F1_TABLE(MAX_SOILTYP) !momentum roughness length (m) + REAL :: SMCMAX_TABLE(MAX_SOILTYP) !top of canopy (m) + REAL :: SMCREF_TABLE(MAX_SOILTYP) !bottom of canopy (m) + REAL :: PSISAT_TABLE(MAX_SOILTYP) !tree density (no. of trunks per m2) + REAL :: DKSAT_TABLE(MAX_SOILTYP) !tree crown radius (m) + REAL :: DWSAT_TABLE(MAX_SOILTYP) !monthly stem area index, one-sided + REAL :: SMCWLT_TABLE(MAX_SOILTYP) !monthly leaf area index, one-sided + REAL :: QUARTZ_TABLE(MAX_SOILTYP) !single-side leaf area per Kg [m2/kg] - REAL :: CFLUX !carbon flux to atmosphere [g/m2/s] - REAL :: LFMSMN !minimum leaf mass [g/m2] - REAL :: RSWOOD !wood respiration [g/m2] - REAL :: RSLEAF !leaf maintenance respiration per timestep [g/m2] - REAL :: RSROOT !fine root respiration per time step [g/m2] - REAL :: NPPL !leaf net primary productivity [g/m2/s] - REAL :: NPPR !root net primary productivity [g/m2/s] - REAL :: NPPW !wood net primary productivity [g/m2/s] - REAL :: NPPS !wood net primary productivity [g/m2/s] - REAL :: DIELF !death of leaf mass per time step [g/m2] +! GENPARM.TBL parameters - REAL :: ADDNPPLF !leaf assimil after resp. losses removed [g/m2] - REAL :: ADDNPPST !stem assimil after resp. losses removed [g/m2] - REAL :: CARBFX !carbon assimilated per model step [g/m2] - REAL :: GRLEAF !growth respiration rate for leaf [g/m2/s] - REAL :: GRROOT !growth respiration rate for root [g/m2/s] - REAL :: GRWOOD !growth respiration rate for wood [g/m2/s] - REAL :: GRSTEM !growth respiration rate for stem [g/m2/s] - REAL :: LEAFPT !fraction of carbon allocated to leaves [-] - REAL :: LFDEL !maximum leaf mass available to change [g/m2/s] - REAL :: LFTOVR !stem turnover per time step [g/m2] - REAL :: STTOVR !stem turnover per time step [g/m2] - REAL :: WDTOVR !wood turnover per time step [g/m2] - REAL :: RSSOIL !soil respiration per time step [g/m2] - REAL :: RTTOVR !root carbon loss per time step by turnover [g/m2] - REAL :: STABLC !decay rate of fast carbon to slow carbon [g/m2/s] - REAL :: WOODF !calculated wood to root ratio [-] - REAL :: NONLEF !fraction of carbon to root and wood [-] - REAL :: ROOTPT !fraction of carbon flux to roots [-] - REAL :: WOODPT !fraction of carbon flux to wood [-] - REAL :: STEMPT !fraction of carbon flux to stem [-] - REAL :: RESP !leaf respiration [umol/m2/s] - REAL :: RSSTEM !stem respiration [g/m2/s] + REAL :: SLOPE_TABLE(9) !slope factor for soil drainage + + REAL :: CSOIL_TABLE !Soil heat capacity [J m-3 K-1] + REAL :: REFDK_TABLE !Parameter in the surface runoff parameterization + REAL :: REFKDT_TABLE !Parameter in the surface runoff parameterization + REAL :: FRZK_TABLE !Frozen ground parameter + REAL :: ZBOT_TABLE !Depth [m] of lower boundary soil temperature + REAL :: CZIL_TABLE !Parameter used in the calculation of the roughness length for heat - REAL :: FSW !soil water factor for microbial respiration - REAL :: FST !soil temperature factor for microbial respiration - REAL :: FNF !foliage nitrogen adjustemt to respiration (<= 1) - REAL :: TF !temperature factor - REAL :: RF !respiration reduction factor (<= 1) - REAL :: STDEL - REAL :: STMSMN - REAL :: SAPM !stem area per unit mass (m2/g) - REAL :: DIEST -! -------------------------- constants ------------------------------- - REAL :: BF !parameter for present wood allocation [-] - REAL :: RSWOODC !wood respiration coeficient [1/s] - REAL :: STOVRC !stem turnover coefficient [1/s] - REAL :: RSDRYC !degree of drying that reduces soil respiration [-] - REAL :: RTOVRC !root turnover coefficient [1/s] - REAL :: WSTRC !water stress coeficient [-] - REAL :: LAIMIN !minimum leaf area index [m2/m2] - REAL :: XSAMIN !minimum leaf area index [m2/m2] - REAL :: SC - REAL :: SD - REAL :: VEGFRAC +! MPTABLE.TBL radiation parameters -! Respiration as a function of temperature + REAL :: ALBSAT_TABLE(MSC,MBAND) !saturated soil albedos: 1=vis, 2=nir + REAL :: ALBDRY_TABLE(MSC,MBAND) !dry soil albedos: 1=vis, 2=nir + REAL :: ALBICE_TABLE(MBAND) !albedo land ice: 1=vis, 2=nir + REAL :: ALBLAK_TABLE(MBAND) !albedo frozen lakes: 1=vis, 2=nir + REAL :: OMEGAS_TABLE(MBAND) !two-stream parameter omega for snow + REAL :: BETADS_TABLE !two-stream parameter betad for snow + REAL :: BETAIS_TABLE !two-stream parameter betad for snow + REAL :: EG_TABLE(2) !emissivity - real :: r,x - r(x) = exp(0.08*(x-298.16)) -! --------------------------------------------------------------------------------- +! MPTABLE.TBL global parameters + + REAL :: CO2_TABLE !co2 partial pressure + REAL :: O2_TABLE !o2 partial pressure + REAL :: TIMEAN_TABLE !gridcell mean topgraphic index (global mean) + REAL :: FSATMX_TABLE !maximum surface saturated fraction (global mean) + REAL :: Z0SNO_TABLE !snow surface roughness length (m) (0.002) + REAL :: SSI_TABLE !liquid water holding capacity for snowpack (m3/m3) (0.03) + REAL :: SWEMX_TABLE !new snow mass to fully cover old snow (mm) + REAL :: RSURF_SNOW_TABLE !surface resistance for snow(s/m) + +! MPTABLE.TBL crop parameters + + INTEGER :: PLTDAY_TABLE(NCROP) ! Planting date + INTEGER :: HSDAY_TABLE(NCROP) ! Harvest date + REAL :: PLANTPOP_TABLE(NCROP) ! Plant density [per ha] - used? + REAL :: IRRI_TABLE(NCROP) ! Irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + + REAL :: GDDTBASE_TABLE(NCROP) ! Base temperature for GDD accumulation [C] + REAL :: GDDTCUT_TABLE(NCROP) ! Upper temperature for GDD accumulation [C] + REAL :: GDDS1_TABLE(NCROP) ! GDD from seeding to emergence + REAL :: GDDS2_TABLE(NCROP) ! GDD from seeding to initial vegetative + REAL :: GDDS3_TABLE(NCROP) ! GDD from seeding to post vegetative + REAL :: GDDS4_TABLE(NCROP) ! GDD from seeding to intial reproductive + REAL :: GDDS5_TABLE(NCROP) ! GDD from seeding to pysical maturity + + INTEGER :: C3C4_TABLE(NCROP) ! photosynthetic pathway: 1. = c3 2. = c4 + REAL :: AREF_TABLE(NCROP) ! reference maximum CO2 assimulation rate + REAL :: PSNRF_TABLE(NCROP) ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) + REAL :: I2PAR_TABLE(NCROP) ! Fraction of incoming solar radiation to photosynthetically active radiation + REAL :: TASSIM0_TABLE(NCROP) ! Minimum temperature for CO2 assimulation [C] + REAL :: TASSIM1_TABLE(NCROP) ! CO2 assimulation linearly increasing until temperature reaches T1 [C] + REAL :: TASSIM2_TABLE(NCROP) ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C] + REAL :: K_TABLE(NCROP) ! light extinction coefficient + REAL :: EPSI_TABLE(NCROP) ! initial light use efficiency + + REAL :: Q10MR_TABLE(NCROP) ! q10 for maintainance respiration + REAL :: FOLN_MX_TABLE(NCROP) ! foliage nitrogen concentration when f(n)=1 (%) + REAL :: LEFREEZ_TABLE(NCROP) ! characteristic T for leaf freezing [K] + + REAL :: DILE_FC_TABLE(NCROP,NSTAGE) ! coeficient for temperature leaf stress death [1/s] + REAL :: DILE_FW_TABLE(NCROP,NSTAGE) ! coeficient for water leaf stress death [1/s] + REAL :: FRA_GR_TABLE(NCROP) ! fraction of growth respiration + + REAL :: LF_OVRC_TABLE(NCROP,NSTAGE) ! fraction of leaf turnover [1/s] + REAL :: ST_OVRC_TABLE(NCROP,NSTAGE) ! fraction of stem turnover [1/s] + REAL :: RT_OVRC_TABLE(NCROP,NSTAGE) ! fraction of root tunrover [1/s] + REAL :: LFMR25_TABLE(NCROP) ! leaf maintenance respiration at 25C [umol CO2/m**2 /s] + REAL :: STMR25_TABLE(NCROP) ! stem maintenance respiration at 25C [umol CO2/kg bio/s] + REAL :: RTMR25_TABLE(NCROP) ! root maintenance respiration at 25C [umol CO2/kg bio/s] + REAL :: GRAINMR25_TABLE(NCROP) ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + + REAL :: LFPT_TABLE(NCROP,NSTAGE) ! fraction of carbohydrate flux to leaf + REAL :: STPT_TABLE(NCROP,NSTAGE) ! fraction of carbohydrate flux to stem + REAL :: RTPT_TABLE(NCROP,NSTAGE) ! fraction of carbohydrate flux to root + REAL :: GRAINPT_TABLE(NCROP,NSTAGE) ! fraction of carbohydrate flux to grain + REAL :: BIO2LAI_TABLE(NCROP) ! leaf are per living leaf biomass [m^2/kg] -! constants - RTOVRC = 2.0E-8 !original was 2.0e-8 - RSDRYC = 40.0 !original was 40.0 - RSWOODC = 3.0E-10 ! - BF = 0.90 !original was 0.90 ! carbon to roots - WSTRC = 100.0 - LAIMIN = 0.05 - XSAMIN = 0.05 ! MB: change to prevent vegetation from not growing back in spring +CONTAINS - SAPM = 3.*0.001 ! m2/kg -->m2/g - LFMSMN = laimin/lapm - STMSMN = xsamin/sapm -! --------------------------------------------------------------------------------- + subroutine read_mp_veg_parameters(DATASET_IDENTIFIER) + implicit none + character(len=*), intent(in) :: DATASET_IDENTIFIER + integer :: ierr + INTEGER :: IK,IM + + integer :: NVEG + character(len=256) :: VEG_DATASET_DESCRIPTION -! respiration + INTEGER :: ISURBAN + INTEGER :: ISWATER + INTEGER :: ISBARREN + INTEGER :: ISICE + INTEGER :: EBLFOREST + INTEGER :: LOW_DENSITY_RESIDENTIAL + INTEGER :: HIGH_DENSITY_RESIDENTIAL + INTEGER :: HIGH_INTENSITY_INDUSTRIAL - IF(IGS .EQ. 0.) THEN - RF = 0.5 - ELSE - RF = 1.0 - ENDIF - - FNF = MIN( FOLN/MAX(1.E-06,FOLNMX), 1.0 ) - TF = ARM**( (TV-298.16)/10. ) - RESP = RMF25 * TF * FNF * XLAI * RF * (1.-WSTRES) ! umol/m2/s - RSLEAF = MIN((LFMASS-LFMSMN)/DT,RESP*12.e-6) ! g/m2/s - - RSROOT = RMR25*(RTMASS*1E-3)*TF *RF* 12.e-6 ! g/m2/s - RSSTEM = RMS25*((STMASS-STMSMN)*1E-3)*TF *RF* 12.e-6 ! g/m2/s - RSWOOD = RSWOODC * R(TV) * WOOD*WDPOOL + REAL, DIMENSION(MVT) :: SAI_JAN,SAI_FEB,SAI_MAR,SAI_APR,SAI_MAY,SAI_JUN, & + SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC + REAL, DIMENSION(MVT) :: LAI_JAN,LAI_FEB,LAI_MAR,LAI_APR,LAI_MAY,LAI_JUN, & + LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC + REAL, DIMENSION(MVT) :: RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, & + TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR + REAL, DIMENSION(MVT) :: CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, & + AVCMX, AQE, LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , & + BP, MP, QE25, RMS25, RMR25, ARM, FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & + SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 + + NAMELIST / noahmp_usgs_veg_categories / VEG_DATASET_DESCRIPTION, NVEG + NAMELIST / noahmp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, EBLFOREST, & + LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & + LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, & + FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & + SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN,SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC, & + LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN,LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC, & + RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR, SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 + + NAMELIST / noahmp_modis_veg_categories / VEG_DATASET_DESCRIPTION, NVEG + NAMELIST / noahmp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, EBLFOREST, & + LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL, & + CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, & + LTOVRC, DILEFC, DILEFW, RMF25 , SLA , FRAGR , TMIN , VCMX25, TDLEF , BP, MP, QE25, RMS25, RMR25, ARM, & + FOLNMX, WDPOOL, WRRAT, MRP, NROOT, RGL, RS, HS, TOPT, RSMAX, & + SAI_JAN, SAI_FEB, SAI_MAR, SAI_APR, SAI_MAY, SAI_JUN,SAI_JUL,SAI_AUG,SAI_SEP,SAI_OCT,SAI_NOV,SAI_DEC, & + LAI_JAN, LAI_FEB, LAI_MAR, LAI_APR, LAI_MAY, LAI_JUN,LAI_JUL,LAI_AUG,LAI_SEP,LAI_OCT,LAI_NOV,LAI_DEC, & + RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR, SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5 -! carbon assimilation -! 1 mole -> 12 g carbon or 44 g CO2; 1 umol -> 12.e-6 g carbon; + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + CH2OP_TABLE = -1.E36 + DLEAF_TABLE = -1.E36 + Z0MVT_TABLE = -1.E36 + HVT_TABLE = -1.E36 + HVB_TABLE = -1.E36 + DEN_TABLE = -1.E36 + RC_TABLE = -1.E36 + MFSNO_TABLE = -1.E36 + RHOL_TABLE = -1.E36 + RHOS_TABLE = -1.E36 + TAUL_TABLE = -1.E36 + TAUS_TABLE = -1.E36 + XL_TABLE = -1.E36 + CWPVT_TABLE = -1.E36 + C3PSN_TABLE = -1.E36 + KC25_TABLE = -1.E36 + AKC_TABLE = -1.E36 + KO25_TABLE = -1.E36 + AKO_TABLE = -1.E36 + AVCMX_TABLE = -1.E36 + AQE_TABLE = -1.E36 + LTOVRC_TABLE = -1.E36 + DILEFC_TABLE = -1.E36 + DILEFW_TABLE = -1.E36 + RMF25_TABLE = -1.E36 + SLA_TABLE = -1.E36 + FRAGR_TABLE = -1.E36 + TMIN_TABLE = -1.E36 + VCMX25_TABLE = -1.E36 + TDLEF_TABLE = -1.E36 + BP_TABLE = -1.E36 + MP_TABLE = -1.E36 + QE25_TABLE = -1.E36 + RMS25_TABLE = -1.E36 + RMR25_TABLE = -1.E36 + ARM_TABLE = -1.E36 + FOLNMX_TABLE = -1.E36 + WDPOOL_TABLE = -1.E36 + WRRAT_TABLE = -1.E36 + MRP_TABLE = -1.E36 + SAIM_TABLE = -1.E36 + LAIM_TABLE = -1.E36 + NROOT_TABLE = -1.E36 + RGL_TABLE = -1.E36 + RS_TABLE = -1.E36 + HS_TABLE = -1.E36 + TOPT_TABLE = -1.E36 + RSMAX_TABLE = -1.E36 + ISURBAN_TABLE = -99999 + ISWATER_TABLE = -99999 + ISBARREN_TABLE = -99999 + ISICE_TABLE = -99999 + EBLFOREST_TABLE = -99999 + LOW_DENSITY_RESIDENTIAL_TABLE = -99999 + HIGH_DENSITY_RESIDENTIAL_TABLE = -99999 + HIGH_INTENSITY_INDUSTRIAL_TABLE = -99999 - CARBFX = PSN * 12.e-6 ! umol co2 /m2/ s -> g/m2/s carbon + open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) + if (ierr /= 0) then + write(*,'("****** Error ******************************************************")') + write(*,'("Cannot find file MPTABLE.TBL")') + write(*,'("STOP")') + write(*,'("*******************************************************************")') + call wrf_error_fatal("STOP in Noah-MP read_mp_veg_parameters") + endif -! fraction of carbon into leaf versus nonleaf + if ( trim(DATASET_IDENTIFIER) == "USGS" ) then + read(15,noahmp_usgs_veg_categories) + read(15,noahmp_usgs_parameters) + else if ( trim(DATASET_IDENTIFIER) == "MODIFIED_IGBP_MODIS_NOAH" ) then + read(15,noahmp_modis_veg_categories) + read(15,noahmp_modis_parameters) + else + write(*,'("Unrecognized DATASET_IDENTIFIER in subroutine READ_MP_VEG_PARAMETERS")') + write(*,'("DATASET_IDENTIFIER = ''", A, "''")') trim(DATASET_IDENTIFIER) + call wrf_error_fatal("STOP in Noah-MP read_mp_veg_parameters") + endif + close(15) - LEAFPT = EXP(0.01*(1.-EXP(0.75*XLAI))*XLAI) - IF(VEGTYP ==EBLFOREST) LEAFPT = EXP(0.01*(1.-EXP(0.50*XLAI))*XLAI) + ISURBAN_TABLE = ISURBAN + ISWATER_TABLE = ISWATER + ISBARREN_TABLE = ISBARREN + ISICE_TABLE = ISICE + EBLFOREST_TABLE = EBLFOREST + LOW_DENSITY_RESIDENTIAL_TABLE = LOW_DENSITY_RESIDENTIAL + HIGH_DENSITY_RESIDENTIAL_TABLE = HIGH_DENSITY_RESIDENTIAL + HIGH_INTENSITY_INDUSTRIAL_TABLE = HIGH_INTENSITY_INDUSTRIAL - NONLEF = 1.0 - LEAFPT - STEMPT = XLAI/10.0*LEAFPT - LEAFPT = LEAFPT - STEMPT + CH2OP_TABLE(1:NVEG) = CH2OP(1:NVEG) + DLEAF_TABLE(1:NVEG) = DLEAF(1:NVEG) + Z0MVT_TABLE(1:NVEG) = Z0MVT(1:NVEG) + HVT_TABLE(1:NVEG) = HVT(1:NVEG) + HVB_TABLE(1:NVEG) = HVB(1:NVEG) + DEN_TABLE(1:NVEG) = DEN(1:NVEG) + RC_TABLE(1:NVEG) = RC(1:NVEG) + MFSNO_TABLE(1:NVEG) = MFSNO(1:NVEG) + XL_TABLE(1:NVEG) = XL(1:NVEG) + CWPVT_TABLE(1:NVEG) = CWPVT(1:NVEG) + C3PSN_TABLE(1:NVEG) = C3PSN(1:NVEG) + KC25_TABLE(1:NVEG) = KC25(1:NVEG) + AKC_TABLE(1:NVEG) = AKC(1:NVEG) + KO25_TABLE(1:NVEG) = KO25(1:NVEG) + AKO_TABLE(1:NVEG) = AKO(1:NVEG) + AVCMX_TABLE(1:NVEG) = AVCMX(1:NVEG) + AQE_TABLE(1:NVEG) = AQE(1:NVEG) + LTOVRC_TABLE(1:NVEG) = LTOVRC(1:NVEG) + DILEFC_TABLE(1:NVEG) = DILEFC(1:NVEG) + DILEFW_TABLE(1:NVEG) = DILEFW(1:NVEG) + RMF25_TABLE(1:NVEG) = RMF25(1:NVEG) + SLA_TABLE(1:NVEG) = SLA(1:NVEG) + FRAGR_TABLE(1:NVEG) = FRAGR(1:NVEG) + TMIN_TABLE(1:NVEG) = TMIN(1:NVEG) + VCMX25_TABLE(1:NVEG) = VCMX25(1:NVEG) + TDLEF_TABLE(1:NVEG) = TDLEF(1:NVEG) + BP_TABLE(1:NVEG) = BP(1:NVEG) + MP_TABLE(1:NVEG) = MP(1:NVEG) + QE25_TABLE(1:NVEG) = QE25(1:NVEG) + RMS25_TABLE(1:NVEG) = RMS25(1:NVEG) + RMR25_TABLE(1:NVEG) = RMR25(1:NVEG) + ARM_TABLE(1:NVEG) = ARM(1:NVEG) + FOLNMX_TABLE(1:NVEG) = FOLNMX(1:NVEG) + WDPOOL_TABLE(1:NVEG) = WDPOOL(1:NVEG) + WRRAT_TABLE(1:NVEG) = WRRAT(1:NVEG) + MRP_TABLE(1:NVEG) = MRP(1:NVEG) + NROOT_TABLE(1:NVEG) = NROOT(1:NVEG) + RGL_TABLE(1:NVEG) = RGL(1:NVEG) + RS_TABLE(1:NVEG) = RS(1:NVEG) + HS_TABLE(1:NVEG) = HS(1:NVEG) + TOPT_TABLE(1:NVEG) = TOPT(1:NVEG) + RSMAX_TABLE(1:NVEG) = RSMAX(1:NVEG) + + ! Put LAI and SAI into 2d array from monthly lines in table; same for canopy radiation properties -! fraction of carbon into wood versus root + SAIM_TABLE(1:NVEG, 1) = SAI_JAN(1:NVEG) + SAIM_TABLE(1:NVEG, 2) = SAI_FEB(1:NVEG) + SAIM_TABLE(1:NVEG, 3) = SAI_MAR(1:NVEG) + SAIM_TABLE(1:NVEG, 4) = SAI_APR(1:NVEG) + SAIM_TABLE(1:NVEG, 5) = SAI_MAY(1:NVEG) + SAIM_TABLE(1:NVEG, 6) = SAI_JUN(1:NVEG) + SAIM_TABLE(1:NVEG, 7) = SAI_JUL(1:NVEG) + SAIM_TABLE(1:NVEG, 8) = SAI_AUG(1:NVEG) + SAIM_TABLE(1:NVEG, 9) = SAI_SEP(1:NVEG) + SAIM_TABLE(1:NVEG,10) = SAI_OCT(1:NVEG) + SAIM_TABLE(1:NVEG,11) = SAI_NOV(1:NVEG) + SAIM_TABLE(1:NVEG,12) = SAI_DEC(1:NVEG) - IF(WOOD.GT.0) THEN - WOODF = (1.-EXP(-BF*(WRRAT*RTMASS/WOOD))/BF)*WDPOOL - ELSE - WOODF = 0. - ENDIF + LAIM_TABLE(1:NVEG, 1) = LAI_JAN(1:NVEG) + LAIM_TABLE(1:NVEG, 2) = LAI_FEB(1:NVEG) + LAIM_TABLE(1:NVEG, 3) = LAI_MAR(1:NVEG) + LAIM_TABLE(1:NVEG, 4) = LAI_APR(1:NVEG) + LAIM_TABLE(1:NVEG, 5) = LAI_MAY(1:NVEG) + LAIM_TABLE(1:NVEG, 6) = LAI_JUN(1:NVEG) + LAIM_TABLE(1:NVEG, 7) = LAI_JUL(1:NVEG) + LAIM_TABLE(1:NVEG, 8) = LAI_AUG(1:NVEG) + LAIM_TABLE(1:NVEG, 9) = LAI_SEP(1:NVEG) + LAIM_TABLE(1:NVEG,10) = LAI_OCT(1:NVEG) + LAIM_TABLE(1:NVEG,11) = LAI_NOV(1:NVEG) + LAIM_TABLE(1:NVEG,12) = LAI_DEC(1:NVEG) - ROOTPT = NONLEF*(1.-WOODF) - WOODPT = NONLEF*WOODF + RHOL_TABLE(1:NVEG,1) = RHOL_VIS(1:NVEG) !leaf reflectance: 1=vis, 2=nir + RHOL_TABLE(1:NVEG,2) = RHOL_NIR(1:NVEG) !leaf reflectance: 1=vis, 2=nir + RHOS_TABLE(1:NVEG,1) = RHOS_VIS(1:NVEG) !stem reflectance: 1=vis, 2=nir + RHOS_TABLE(1:NVEG,2) = RHOS_NIR(1:NVEG) !stem reflectance: 1=vis, 2=nir + TAUL_TABLE(1:NVEG,1) = TAUL_VIS(1:NVEG) !leaf transmittance: 1=vis, 2=nir + TAUL_TABLE(1:NVEG,2) = TAUL_NIR(1:NVEG) !leaf transmittance: 1=vis, 2=nir + TAUS_TABLE(1:NVEG,1) = TAUS_VIS(1:NVEG) !stem transmittance: 1=vis, 2=nir + TAUS_TABLE(1:NVEG,2) = TAUS_NIR(1:NVEG) !stem transmittance: 1=vis, 2=nir -! leaf and root turnover per time step + end subroutine read_mp_veg_parameters - LFTOVR = LTOVRC*5.E-7*LFMASS - STTOVR = LTOVRC*5.E-7*STMASS - RTTOVR = RTOVRC*RTMASS - WDTOVR = 9.5E-10*WOOD + subroutine read_mp_soil_parameters() + IMPLICIT NONE + INTEGER :: IERR + CHARACTER*4 :: SLTYPE + INTEGER :: ITMP, NUM_SLOPE, LC + CHARACTER(len=256) :: message + -! seasonal leaf die rate dependent on temp and water stress -! water stress is set to 1 at permanent wilting point + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + BEXP_TABLE = -1.E36 + SMCDRY_TABLE = -1.E36 + F1_TABLE = -1.E36 + SMCMAX_TABLE = -1.E36 + SMCREF_TABLE = -1.E36 + PSISAT_TABLE = -1.E36 + DKSAT_TABLE = -1.E36 + DWSAT_TABLE = -1.E36 + SMCWLT_TABLE = -1.E36 + QUARTZ_TABLE = -1.E36 + SLOPE_TABLE = -1.E36 + CSOIL_TABLE = -1.E36 + REFDK_TABLE = -1.E36 + REFKDT_TABLE = -1.E36 + FRZK_TABLE = -1.E36 + ZBOT_TABLE = -1.E36 + CZIL_TABLE = -1.E36 - SC = EXP(-0.3*MAX(0.,TV-TDLEF)) * (LFMASS/120.) - SD = EXP((WSTRES-1.)*WSTRC) - DIELF = LFMASS*1.E-6*(DILEFW * SD + DILEFC*SC) - DIEST = STMASS*1.E-6*(DILEFW * SD + DILEFC*SC) +! +!-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL +! + OPEN(19, FILE='SOILPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) + IF(ierr .NE. 0 ) THEN + WRITE(message,FMT='(A)') 'module_sf_noahmpdrv.F: read_mp_soil_parameters: failure opening SOILPARM.TBL' + CALL wrf_error_fatal ( message ) + END IF -! calculate growth respiration for leaf, rtmass and wood + READ (19,*) + READ (19,*) SLTYPE + READ (19,*) SLCATS + WRITE( message , * ) 'SOIL TEXTURE CLASSIFICATION = ', TRIM ( SLTYPE ) , ' FOUND', & + SLCATS,' CATEGORIES' + CALL wrf_message ( message ) - GRLEAF = MAX(0.0,FRAGR*(LEAFPT*CARBFX - RSLEAF)) - GRSTEM = MAX(0.0,FRAGR*(STEMPT*CARBFX - RSSTEM)) - GRROOT = MAX(0.0,FRAGR*(ROOTPT*CARBFX - RSROOT)) - GRWOOD = MAX(0.0,FRAGR*(WOODPT*CARBFX - RSWOOD)) + DO LC=1,SLCATS + READ (19,*) ITMP,BEXP_TABLE(LC),SMCDRY_TABLE(LC),F1_TABLE(LC),SMCMAX_TABLE(LC), & + SMCREF_TABLE(LC),PSISAT_TABLE(LC),DKSAT_TABLE(LC), DWSAT_TABLE(LC), & + SMCWLT_TABLE(LC), QUARTZ_TABLE(LC) + ENDDO -! Impose lower T limit for photosynthesis + CLOSE (19) - ADDNPPLF = MAX(0.,LEAFPT*CARBFX - GRLEAF-RSLEAF) - ADDNPPST = MAX(0.,STEMPT*CARBFX - GRSTEM-RSSTEM) -! ADDNPPLF = LEAFPT*CARBFX - GRLEAF-RSLEAF ! MB: test Kjetil -! ADDNPPST = STEMPT*CARBFX - GRSTEM-RSSTEM ! MB: test Kjetil - IF(TV.LT.TMIN) ADDNPPLF =0. - IF(TV.LT.TMIN) ADDNPPST =0. +! +!-----READ IN GENERAL PARAMETERS FROM GENPARM.TBL +! + OPEN(19, FILE='GENPARM.TBL',FORM='FORMATTED',STATUS='OLD',IOSTAT=ierr) + IF(ierr .NE. 0 ) THEN + WRITE(message,FMT='(A)') 'module_sf_noahlsm.F: read_mp_soil_parameters: failure opening GENPARM.TBL' + CALL wrf_error_fatal ( message ) + END IF -! update leaf, root, and wood carbon -! avoid reducing leaf mass below its minimum value but conserve mass + READ (19,*) + READ (19,*) + READ (19,*) NUM_SLOPE - LFDEL = (LFMASS - LFMSMN)/DT - STDEL = (STMASS - STMSMN)/DT - DIELF = MIN(DIELF,LFDEL+ADDNPPLF-LFTOVR) - DIEST = MIN(DIEST,STDEL+ADDNPPST-STTOVR) + DO LC=1,NUM_SLOPE + READ (19,*) SLOPE_TABLE(LC) + ENDDO -! net primary productivities + READ (19,*) + READ (19,*) + READ (19,*) + READ (19,*) + READ (19,*) + READ (19,*) CSOIL_TABLE + READ (19,*) + READ (19,*) + READ (19,*) + READ (19,*) REFDK_TABLE + READ (19,*) + READ (19,*) REFKDT_TABLE + READ (19,*) + READ (19,*) FRZK_TABLE + READ (19,*) + READ (19,*) ZBOT_TABLE + READ (19,*) + READ (19,*) CZIL_TABLE + READ (19,*) + READ (19,*) + READ (19,*) + READ (19,*) - NPPL = MAX(ADDNPPLF,-LFDEL) - NPPS = MAX(ADDNPPST,-STDEL) - NPPR = ROOTPT*CARBFX - RSROOT - GRROOT - NPPW = WOODPT*CARBFX - RSWOOD - GRWOOD + CLOSE (19) -! masses of plant components + end subroutine read_mp_soil_parameters - LFMASS = LFMASS + (NPPL-LFTOVR-DIELF)*DT - STMASS = STMASS + (NPPS-STTOVR-DIEST)*DT ! g/m2 - RTMASS = RTMASS + (NPPR-RTTOVR) *DT + subroutine read_mp_rad_parameters() + implicit none + integer :: ierr - IF(RTMASS.LT.0.0) THEN - RTTOVR = NPPR - RTMASS = 0.0 - ENDIF - WOOD = (WOOD+(NPPW-WDTOVR)*DT)*WDPOOL + REAL :: ALBICE(MBAND),ALBLAK(MBAND),OMEGAS(MBAND),BETADS,BETAIS,EG(2) + REAL :: ALBSAT_VIS(MSC) + REAL :: ALBSAT_NIR(MSC) + REAL :: ALBDRY_VIS(MSC) + REAL :: ALBDRY_NIR(MSC) -! soil carbon budgets + NAMELIST / noahmp_rad_parameters / ALBSAT_VIS,ALBSAT_NIR,ALBDRY_VIS,ALBDRY_NIR,ALBICE,ALBLAK,OMEGAS,BETADS,BETAIS,EG - FASTCP = FASTCP + (RTTOVR+LFTOVR+STTOVR+WDTOVR+DIELF+DIEST)*DT ! MB: add DIEST v3.7 - FST = 2.0**( (STC(1)-283.16)/10. ) - FSW = WROOT / (0.20+WROOT) * 0.23 / (0.23+WROOT) - RSSOIL = FSW * FST * MRP* MAX(0.,FASTCP*1.E-3)*12.E-6 + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + ALBSAT_TABLE = -1.E36 + ALBDRY_TABLE = -1.E36 + ALBICE_TABLE = -1.E36 + ALBLAK_TABLE = -1.E36 + OMEGAS_TABLE = -1.E36 + BETADS_TABLE = -1.E36 + BETAIS_TABLE = -1.E36 + EG_TABLE = -1.E36 - STABLC = 0.1*RSSOIL - FASTCP = FASTCP - (RSSOIL + STABLC)*DT - STBLCP = STBLCP + STABLC*DT + open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) + if (ierr /= 0) then + write(*,'("****** Error ******************************************************")') + write(*,'("Cannot find file MPTABLE.TBL")') + write(*,'("STOP")') + write(*,'("*******************************************************************")') + call wrf_error_fatal("STOP in Noah-MP read_mp_rad_parameters") + endif -! total carbon flux + read(15,noahmp_rad_parameters) + close(15) - CFLUX = - CARBFX + RSLEAF + RSROOT + RSWOOD + RSSTEM & ! MB: add RSSTEM,GRSTEM,0.9*RSSOIL v3.7 - + 0.9*RSSOIL + GRLEAF + GRROOT + GRWOOD + GRSTEM ! g/m2/s + ALBSAT_TABLE(:,1) = ALBSAT_VIS ! saturated soil albedos: 1=vis, 2=nir + ALBSAT_TABLE(:,2) = ALBSAT_NIR ! saturated soil albedos: 1=vis, 2=nir + ALBDRY_TABLE(:,1) = ALBDRY_VIS ! dry soil albedos: 1=vis, 2=nir + ALBDRY_TABLE(:,2) = ALBDRY_NIR ! dry soil albedos: 1=vis, 2=nir + ALBICE_TABLE = ALBICE + ALBLAK_TABLE = ALBLAK + OMEGAS_TABLE = OMEGAS + BETADS_TABLE = BETADS + BETAIS_TABLE = BETAIS + EG_TABLE = EG -! for outputs + end subroutine read_mp_rad_parameters - GPP = CARBFX !g/m2/s C - NPP = NPPL + NPPW + NPPR +NPPS !g/m2/s C - AUTORS = RSROOT + RSWOOD + RSLEAF + RSSTEM + & !g/m2/s C MB: add RSSTEM, GRSTEM v3.7 - GRLEAF + GRROOT + GRWOOD + GRSTEM !g/m2/s C MB: add 0.9* v3.7 - HETERS = 0.9*RSSOIL !g/m2/s C - NEE = (AUTORS + HETERS - GPP)*44./12. !g/m2/s CO2 - TOTSC = FASTCP + STBLCP !g/m2 C - TOTLB = LFMASS + RTMASS +STMASS + WOOD !g/m2 C MB: add STMASS v3.7 + subroutine read_mp_global_parameters() + implicit none + integer :: ierr -! leaf area index and stem area index + REAL :: CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SWEMX,RSURF_SNOW - XLAI = MAX(LFMASS*LAPM,LAIMIN) - XSAI = MAX(STMASS*SAPM,XSAMIN) - - END SUBROUTINE CO2FLUX + NAMELIST / noahmp_global_parameters / CO2,O2,TIMEAN,FSATMX,Z0SNO,SSI,SWEMX,RSURF_SNOW -!== begin bvocflux ================================================================================= -! SUBROUTINE BVOCFLUX(VOCFLX, VEGTYP, VEGFRAC, APAR, TV ) -! use NOAHMP_VEG_PARAMETERS , ONLY : SLAREA, EPS -! ------------------------------------------------------------------------------------------ -! -! ------------------------------------------------------------------------------------------ -! implicit none -! ------------------------------------------------------------------------------------------ -! -! ------------------------ code history --------------------------- -! source file: BVOC -! purpose: BVOC emissions -! DESCRIPTION: -! Volatile organic compound emission -! This code simulates volatile organic compound emissions -! following the algorithm presented in Guenther, A., 1999: Modeling -! Biogenic Volatile Organic Compound Emissions to the Atmosphere. In -! Reactive Hydrocarbons in the Atmosphere, Ch. 3 -! This model relies on the assumption that 90% of isoprene and monoterpene -! emissions originate from canopy foliage: -! E = epsilon * gamma * density * delta -! The factor delta (longterm activity factor) applies to isoprene emission -! from deciduous plants only. We neglect this factor at the present time. -! This factor is discussed in Guenther (1997). -! Subroutine written to operate at the patch level. -! IN FINAL IMPLEMENTATION, REMEMBER: -! 1. may wish to call this routine only as freq. as rad. calculations -! 2. may wish to place epsilon values directly in pft-physiology file -! ------------------------ input/output variables ----------------- -! input -! integer ,INTENT(IN) :: vegtyp !vegetation type -! real ,INTENT(IN) :: vegfrac !green vegetation fraction [0.0-1.0] -! real ,INTENT(IN) :: apar !photosynthesis active energy by canopy (w/m2) -! real ,INTENT(IN) :: tv !vegetation canopy temperature (k) -! -! output -! real ,INTENT(OUT) :: vocflx(5) ! voc fluxes [ug C m-2 h-1] -! -! Local Variables -! -! real, parameter :: R = 8.314 ! univ. gas constant [J K-1 mol-1] -! real, parameter :: alpha = 0.0027 ! empirical coefficient -! real, parameter :: cl1 = 1.066 ! empirical coefficient -! real, parameter :: ct1 = 95000.0 ! empirical coefficient [J mol-1] -! real, parameter :: ct2 = 230000.0 ! empirical coefficient [J mol-1] -! real, parameter :: ct3 = 0.961 ! empirical coefficient -! real, parameter :: tm = 314.0 ! empirical coefficient [K] -! real, parameter :: tstd = 303.0 ! std temperature [K] -! real, parameter :: bet = 0.09 ! beta empirical coefficient [K-1] -! -! integer ivoc ! do-loop index -! integer ityp ! do-loop index -! real epsilon(5) -! real gamma(5) -! real density -! real elai -! real par,cl,reciprod,ct -! -! epsilon : -! -! do ivoc = 1, 5 -! epsilon(ivoc) = eps(VEGTYP,ivoc) -! end do -! -! gamma : Activity factor. Units [dimensionless] -! -! reciprod = 1. / (R * tv * tstd) -! ct = exp(ct1 * (tv - tstd) * reciprod) / & -! (ct3 + exp(ct2 * (tv - tm) * reciprod)) -! -! par = apar * 4.6 ! (multiply w/m2 by 4.6 to get umol/m2/s) -! cl = alpha * cl1 * par * (1. + alpha * alpha * par * par)**(-0.5) -! -! gamma(1) = cl * ct ! for isoprenes -! -! do ivoc = 2, 5 -! gamma(ivoc) = exp(bet * (tv - tstd)) -! end do -! -! Foliage density -! -! transform vegfrac to lai -! -! elai = max(0.0,-6.5/2.5*alog((1.-vegfrac))) -! density = elai / (slarea(VEGTYP) * 0.5) -! -! calculate the voc flux -! -! do ivoc = 1, 5 -! vocflx(ivoc) = epsilon(ivoc) * gamma(ivoc) * density -! end do -! -! end subroutine bvocflux -! ================================================================================================== -! ********************************* end of carbon subroutines ***************************** -! ================================================================================================== + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + CO2_TABLE = -1.E36 + O2_TABLE = -1.E36 + TIMEAN_TABLE = -1.E36 + FSATMX_TABLE = -1.E36 + Z0SNO_TABLE = -1.E36 + SSI_TABLE = -1.E36 + SWEMX_TABLE = -1.E36 +RSURF_SNOW_TABLE = -1.E36 -!== begin noahmp_options =========================================================================== + open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) + if (ierr /= 0) then + write(*,'("****** Error ******************************************************")') + write(*,'("Cannot find file MPTABLE.TBL")') + write(*,'("STOP")') + write(*,'("*******************************************************************")') + call wrf_error_fatal("STOP in Noah-MP read_mp_global_parameters") + endif - subroutine noahmp_options(idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz , & - iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot, iopt_stc ) + read(15,noahmp_global_parameters) + close(15) - implicit none + CO2_TABLE = CO2 + O2_TABLE = O2 + TIMEAN_TABLE = TIMEAN + FSATMX_TABLE = FSATMX + Z0SNO_TABLE = Z0SNO + SSI_TABLE = SSI + SWEMX_TABLE = SWEMX +RSURF_SNOW_TABLE = RSURF_SNOW - INTEGER, INTENT(IN) :: idveg !dynamic vegetation (1 -> off ; 2 -> on) with opt_crs = 1 - INTEGER, INTENT(IN) :: iopt_crs !canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis) - INTEGER, INTENT(IN) :: iopt_btr !soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB) - INTEGER, INTENT(IN) :: iopt_run !runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS) - INTEGER, INTENT(IN) :: iopt_sfc !surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97) - INTEGER, INTENT(IN) :: iopt_frz !supercooled liquid water (1-> NY06; 2->Koren99) - INTEGER, INTENT(IN) :: iopt_inf !frozen soil permeability (1-> NY06; 2->Koren99) - INTEGER, INTENT(IN) :: iopt_rad !radiation transfer (1->gap=F(3D,cosz); 2->gap=0; 3->gap=1-Fveg) - INTEGER, INTENT(IN) :: iopt_alb !snow surface albedo (1->BATS; 2->CLASS) - INTEGER, INTENT(IN) :: iopt_snf !rainfall & snowfall (1-Jordan91; 2->BATS; 3->Noah) - INTEGER, INTENT(IN) :: iopt_tbot !lower boundary of soil temperature (1->zero-flux; 2->Noah) + end subroutine read_mp_global_parameters - INTEGER, INTENT(IN) :: iopt_stc !snow/soil temperature time scheme (only layer 1) - ! 1 -> semi-implicit; 2 -> full implicit (original Noah) + subroutine read_mp_crop_parameters() + implicit none + integer :: ierr -! ------------------------------------------------------------------------------------------------- + INTEGER, DIMENSION(NCROP) :: PLTDAY + INTEGER, DIMENSION(NCROP) :: HSDAY + REAL, DIMENSION(NCROP) :: PLANTPOP + REAL, DIMENSION(NCROP) :: IRRI + REAL, DIMENSION(NCROP) :: GDDTBASE + REAL, DIMENSION(NCROP) :: GDDTCUT + REAL, DIMENSION(NCROP) :: GDDS1 + REAL, DIMENSION(NCROP) :: GDDS2 + REAL, DIMENSION(NCROP) :: GDDS3 + REAL, DIMENSION(NCROP) :: GDDS4 + REAL, DIMENSION(NCROP) :: GDDS5 + INTEGER, DIMENSION(NCROP) :: C3C4 + REAL, DIMENSION(NCROP) :: AREF + REAL, DIMENSION(NCROP) :: PSNRF + REAL, DIMENSION(NCROP) :: I2PAR + REAL, DIMENSION(NCROP) :: TASSIM0 + REAL, DIMENSION(NCROP) :: TASSIM1 + REAL, DIMENSION(NCROP) :: TASSIM2 + REAL, DIMENSION(NCROP) :: K + REAL, DIMENSION(NCROP) :: EPSI + REAL, DIMENSION(NCROP) :: Q10MR + REAL, DIMENSION(NCROP) :: FOLN_MX + REAL, DIMENSION(NCROP) :: LEFREEZ + REAL, DIMENSION(NCROP) :: DILE_FC_S1,DILE_FC_S2,DILE_FC_S3,DILE_FC_S4,DILE_FC_S5,DILE_FC_S6,DILE_FC_S7,DILE_FC_S8 + REAL, DIMENSION(NCROP) :: DILE_FW_S1,DILE_FW_S2,DILE_FW_S3,DILE_FW_S4,DILE_FW_S5,DILE_FW_S6,DILE_FW_S7,DILE_FW_S8 + REAL, DIMENSION(NCROP) :: FRA_GR + REAL, DIMENSION(NCROP) :: LF_OVRC_S1,LF_OVRC_S2,LF_OVRC_S3,LF_OVRC_S4,LF_OVRC_S5,LF_OVRC_S6,LF_OVRC_S7,LF_OVRC_S8 + REAL, DIMENSION(NCROP) :: ST_OVRC_S1,ST_OVRC_S2,ST_OVRC_S3,ST_OVRC_S4,ST_OVRC_S5,ST_OVRC_S6,ST_OVRC_S7,ST_OVRC_S8 + REAL, DIMENSION(NCROP) :: RT_OVRC_S1,RT_OVRC_S2,RT_OVRC_S3,RT_OVRC_S4,RT_OVRC_S5,RT_OVRC_S6,RT_OVRC_S7,RT_OVRC_S8 + REAL, DIMENSION(NCROP) :: LFMR25 + REAL, DIMENSION(NCROP) :: STMR25 + REAL, DIMENSION(NCROP) :: RTMR25 + REAL, DIMENSION(NCROP) :: GRAINMR25 + REAL, DIMENSION(NCROP) :: LFPT_S1,LFPT_S2,LFPT_S3,LFPT_S4,LFPT_S5,LFPT_S6,LFPT_S7,LFPT_S8 + REAL, DIMENSION(NCROP) :: STPT_S1,STPT_S2,STPT_S3,STPT_S4,STPT_S5,STPT_S6,STPT_S7,STPT_S8 + REAL, DIMENSION(NCROP) :: RTPT_S1,RTPT_S2,RTPT_S3,RTPT_S4,RTPT_S5,RTPT_S6,RTPT_S7,RTPT_S8 + REAL, DIMENSION(NCROP) :: GRAINPT_S1,GRAINPT_S2,GRAINPT_S3,GRAINPT_S4,GRAINPT_S5,GRAINPT_S6,GRAINPT_S7,GRAINPT_S8 + REAL, DIMENSION(NCROP) :: BIO2LAI + + + NAMELIST / noahmp_crop_parameters / PLTDAY, HSDAY, PLANTPOP, IRRI, GDDTBASE, GDDTCUT, GDDS1, GDDS2, & + GDDS3, GDDS4, GDDS5, C3C4, AREF, PSNRF, I2PAR, TASSIM0, & + TASSIM1, TASSIM2, K, EPSI, Q10MR, FOLN_MX, LEFREEZ, & + DILE_FC_S1,DILE_FC_S2,DILE_FC_S3,DILE_FC_S4,DILE_FC_S5,DILE_FC_S6,DILE_FC_S7,DILE_FC_S8, & + DILE_FW_S1,DILE_FW_S2,DILE_FW_S3,DILE_FW_S4,DILE_FW_S5,DILE_FW_S6,DILE_FW_S7,DILE_FW_S8, & + FRA_GR, & + LF_OVRC_S1,LF_OVRC_S2,LF_OVRC_S3,LF_OVRC_S4,LF_OVRC_S5,LF_OVRC_S6,LF_OVRC_S7,LF_OVRC_S8, & + ST_OVRC_S1,ST_OVRC_S2,ST_OVRC_S3,ST_OVRC_S4,ST_OVRC_S5,ST_OVRC_S6,ST_OVRC_S7,ST_OVRC_S8, & + RT_OVRC_S1,RT_OVRC_S2,RT_OVRC_S3,RT_OVRC_S4,RT_OVRC_S5,RT_OVRC_S6,RT_OVRC_S7,RT_OVRC_S8, & + LFMR25, STMR25, RTMR25, GRAINMR25, & + LFPT_S1, LFPT_S2, LFPT_S3, LFPT_S4, LFPT_S5, LFPT_S6, LFPT_S7, LFPT_S8, & + STPT_S1, STPT_S2, STPT_S3, STPT_S4, STPT_S5, STPT_S6, STPT_S7, STPT_S8, & + RTPT_S1, RTPT_S2, RTPT_S3, RTPT_S4, RTPT_S5, RTPT_S6, RTPT_S7, RTPT_S8, & + GRAINPT_S1,GRAINPT_S2,GRAINPT_S3,GRAINPT_S4,GRAINPT_S5,GRAINPT_S6,GRAINPT_S7,GRAINPT_S8, & + BIO2LAI - dveg = idveg - - opt_crs = iopt_crs - opt_btr = iopt_btr - opt_run = iopt_run - opt_sfc = iopt_sfc - opt_frz = iopt_frz - opt_inf = iopt_inf - opt_rad = iopt_rad - opt_alb = iopt_alb - opt_snf = iopt_snf - opt_tbot = iopt_tbot - opt_stc = iopt_stc - - end subroutine noahmp_options - -END MODULE NOAHMP_ROUTINES + ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything. + PLTDAY_TABLE = -99999 + HSDAY_TABLE = -99999 + PLANTPOP_TABLE = -1.E36 + IRRI_TABLE = -1.E36 + GDDTBASE_TABLE = -1.E36 + GDDTCUT_TABLE = -1.E36 + GDDS1_TABLE = -1.E36 + GDDS2_TABLE = -1.E36 + GDDS3_TABLE = -1.E36 + GDDS4_TABLE = -1.E36 + GDDS5_TABLE = -1.E36 + C3C4_TABLE = -99999 + AREF_TABLE = -1.E36 + PSNRF_TABLE = -1.E36 + I2PAR_TABLE = -1.E36 + TASSIM0_TABLE = -1.E36 + TASSIM1_TABLE = -1.E36 + TASSIM2_TABLE = -1.E36 + K_TABLE = -1.E36 + EPSI_TABLE = -1.E36 + Q10MR_TABLE = -1.E36 + FOLN_MX_TABLE = -1.E36 + LEFREEZ_TABLE = -1.E36 + DILE_FC_TABLE = -1.E36 + DILE_FW_TABLE = -1.E36 + FRA_GR_TABLE = -1.E36 + LF_OVRC_TABLE = -1.E36 + ST_OVRC_TABLE = -1.E36 + RT_OVRC_TABLE = -1.E36 + LFMR25_TABLE = -1.E36 + STMR25_TABLE = -1.E36 + RTMR25_TABLE = -1.E36 + GRAINMR25_TABLE = -1.E36 + LFPT_TABLE = -1.E36 + STPT_TABLE = -1.E36 + RTPT_TABLE = -1.E36 + GRAINPT_TABLE = -1.E36 + BIO2LAI_TABLE = -1.E36 -!== begin footer =================================================================================== -MODULE MODULE_SF_NOAHMPLSM + open(15, file="MPTABLE.TBL", status='old', form='formatted', action='read', iostat=ierr) + if (ierr /= 0) then + write(*,'("****** Error ******************************************************")') + write(*,'("Cannot find file MPTABLE.TBL")') + write(*,'("STOP")') + write(*,'("*******************************************************************")') + call wrf_error_fatal("STOP in Noah-MP read_mp_rad_parameters") + endif + + read(15,noahmp_crop_parameters) + close(15) - USE NOAHMP_ROUTINES - USE NOAHMP_GLOBALS + PLTDAY_TABLE = PLTDAY + HSDAY_TABLE = HSDAY + PLANTPOP_TABLE = PLANTPOP + IRRI_TABLE = IRRI + GDDTBASE_TABLE = GDDTBASE + GDDTCUT_TABLE = GDDTCUT + GDDS1_TABLE = GDDS1 + GDDS2_TABLE = GDDS2 + GDDS3_TABLE = GDDS3 + GDDS4_TABLE = GDDS4 + GDDS5_TABLE = GDDS5 + C3C4_TABLE = C3C4 + AREF_TABLE = AREF + PSNRF_TABLE = PSNRF + I2PAR_TABLE = I2PAR + TASSIM0_TABLE = TASSIM0 + TASSIM1_TABLE = TASSIM1 + TASSIM2_TABLE = TASSIM2 + K_TABLE = K + EPSI_TABLE = EPSI + Q10MR_TABLE = Q10MR + FOLN_MX_TABLE = FOLN_MX + LEFREEZ_TABLE = LEFREEZ + DILE_FC_TABLE(:,1) = DILE_FC_S1 + DILE_FC_TABLE(:,2) = DILE_FC_S2 + DILE_FC_TABLE(:,3) = DILE_FC_S3 + DILE_FC_TABLE(:,4) = DILE_FC_S4 + DILE_FC_TABLE(:,5) = DILE_FC_S5 + DILE_FC_TABLE(:,6) = DILE_FC_S6 + DILE_FC_TABLE(:,7) = DILE_FC_S7 + DILE_FC_TABLE(:,8) = DILE_FC_S8 + DILE_FW_TABLE(:,1) = DILE_FW_S1 + DILE_FW_TABLE(:,2) = DILE_FW_S2 + DILE_FW_TABLE(:,3) = DILE_FW_S3 + DILE_FW_TABLE(:,4) = DILE_FW_S4 + DILE_FW_TABLE(:,5) = DILE_FW_S5 + DILE_FW_TABLE(:,6) = DILE_FW_S6 + DILE_FW_TABLE(:,7) = DILE_FW_S7 + DILE_FW_TABLE(:,8) = DILE_FW_S8 + FRA_GR_TABLE = FRA_GR + LF_OVRC_TABLE(:,1) = LF_OVRC_S1 + LF_OVRC_TABLE(:,2) = LF_OVRC_S2 + LF_OVRC_TABLE(:,3) = LF_OVRC_S3 + LF_OVRC_TABLE(:,4) = LF_OVRC_S4 + LF_OVRC_TABLE(:,5) = LF_OVRC_S5 + LF_OVRC_TABLE(:,6) = LF_OVRC_S6 + LF_OVRC_TABLE(:,7) = LF_OVRC_S7 + LF_OVRC_TABLE(:,8) = LF_OVRC_S8 + ST_OVRC_TABLE(:,1) = ST_OVRC_S1 + ST_OVRC_TABLE(:,2) = ST_OVRC_S2 + ST_OVRC_TABLE(:,3) = ST_OVRC_S3 + ST_OVRC_TABLE(:,4) = ST_OVRC_S4 + ST_OVRC_TABLE(:,5) = ST_OVRC_S5 + ST_OVRC_TABLE(:,6) = ST_OVRC_S6 + ST_OVRC_TABLE(:,7) = ST_OVRC_S7 + ST_OVRC_TABLE(:,8) = ST_OVRC_S8 + RT_OVRC_TABLE(:,1) = RT_OVRC_S1 + RT_OVRC_TABLE(:,2) = RT_OVRC_S2 + RT_OVRC_TABLE(:,3) = RT_OVRC_S3 + RT_OVRC_TABLE(:,4) = RT_OVRC_S4 + RT_OVRC_TABLE(:,5) = RT_OVRC_S5 + RT_OVRC_TABLE(:,6) = RT_OVRC_S6 + RT_OVRC_TABLE(:,7) = RT_OVRC_S7 + RT_OVRC_TABLE(:,8) = RT_OVRC_S8 + LFMR25_TABLE = LFMR25 + STMR25_TABLE = STMR25 + RTMR25_TABLE = RTMR25 + GRAINMR25_TABLE = GRAINMR25 + LFPT_TABLE(:,1) = LFPT_S1 + LFPT_TABLE(:,2) = LFPT_S2 + LFPT_TABLE(:,3) = LFPT_S3 + LFPT_TABLE(:,4) = LFPT_S4 + LFPT_TABLE(:,5) = LFPT_S5 + LFPT_TABLE(:,6) = LFPT_S6 + LFPT_TABLE(:,7) = LFPT_S7 + LFPT_TABLE(:,8) = LFPT_S8 + STPT_TABLE(:,1) = STPT_S1 + STPT_TABLE(:,2) = STPT_S2 + STPT_TABLE(:,3) = STPT_S3 + STPT_TABLE(:,4) = STPT_S4 + STPT_TABLE(:,5) = STPT_S5 + STPT_TABLE(:,6) = STPT_S6 + STPT_TABLE(:,7) = STPT_S7 + STPT_TABLE(:,8) = STPT_S8 + RTPT_TABLE(:,1) = RTPT_S1 + RTPT_TABLE(:,2) = RTPT_S2 + RTPT_TABLE(:,3) = RTPT_S3 + RTPT_TABLE(:,4) = RTPT_S4 + RTPT_TABLE(:,5) = RTPT_S5 + RTPT_TABLE(:,6) = RTPT_S6 + RTPT_TABLE(:,7) = RTPT_S7 + RTPT_TABLE(:,8) = RTPT_S8 + GRAINPT_TABLE(:,1) = GRAINPT_S1 + GRAINPT_TABLE(:,2) = GRAINPT_S2 + GRAINPT_TABLE(:,3) = GRAINPT_S3 + GRAINPT_TABLE(:,4) = GRAINPT_S4 + GRAINPT_TABLE(:,5) = GRAINPT_S5 + GRAINPT_TABLE(:,6) = GRAINPT_S6 + GRAINPT_TABLE(:,7) = GRAINPT_S7 + GRAINPT_TABLE(:,8) = GRAINPT_S8 + BIO2LAI_TABLE = BIO2LAI + + end subroutine read_mp_crop_parameters + +END MODULE NOAHMP_TABLES -END MODULE MODULE_SF_NOAHMPLSM diff --git a/wrfv2_fire/phys/module_sf_ocean_driver.F b/wrfv2_fire/phys/module_sf_ocean_driver.F index a35b8610..c3a8e827 100644 --- a/wrfv2_fire/phys/module_sf_ocean_driver.F +++ b/wrfv2_fire/phys/module_sf_ocean_driver.F @@ -8,7 +8,7 @@ MODULE module_sf_ocean_driver SUBROUTINE OCEAN_DRIVER(tml,t0ml,hml,h0ml,huml,hvml,ust,u_phy,v_phy, & tmoml,f,g,oml_gamma, & XLAND,HFX,LH,TSK,GSW,GLW,EMISS, & - DELTSM,STBOLT, & + DELTSM,STBOLT,OML_RELAXATION_TIME, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -41,6 +41,8 @@ SUBROUTINE OCEAN_DRIVER(tml,t0ml,hml,h0ml,huml,hvml,ust,u_phy,v_phy, & !-- HUML ocean mixed layer u component of wind !-- HVML ocean mixed layer v component of wind !-- OML_GAMMA deep water lapse rate (K m-1) +!-- OML_RELAXATION_TIME Time scale (s) to relax TML to T0ML, H to H0, +! HUML and HVML to 0; value <=0 means no relaxation !-- UAIR,VAIR lowest model level wind component !-- UST frictional velocity !-- HFX upward heat flux at the surface (W/m^2) @@ -82,7 +84,7 @@ SUBROUTINE OCEAN_DRIVER(tml,t0ml,hml,h0ml,huml,hvml,ust,u_phy,v_phy, & UST, F, TMOML REAL, INTENT(IN ) :: G - REAL, INTENT(IN ) :: OML_GAMMA + REAL, INTENT(IN ) :: OML_GAMMA, OML_RELAXATION_TIME ! LOCAL VARS @@ -120,6 +122,7 @@ SUBROUTINE OCEAN_DRIVER(tml,t0ml,hml,h0ml,huml,hvml,ust,u_phy,v_phy, & LH(i,j),GSW(i,j),GLW(i,j),TMOML(i,j), & U_PHY(i,kts,j),V_PHY(i,kts,j),UST(i,j),F(i,j), & EMISS(i,j),STBOLT,G,DELTSM,OML_GAMMA, & + OML_RELAXATION_TIME, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) diff --git a/wrfv2_fire/phys/module_sf_oml.F b/wrfv2_fire/phys/module_sf_oml.F index bf0549ed..5a7b66cf 100644 --- a/wrfv2_fire/phys/module_sf_oml.F +++ b/wrfv2_fire/phys/module_sf_oml.F @@ -9,6 +9,7 @@ SUBROUTINE OML1D(I,J,TML,T0ML,H,H0,HUML, & HVML,TSK,HFX, & LH,GSW,GLW,TMOML, & UAIR,VAIR,UST,F,EMISS,STBOLT,G,DT,OML_GAMMA, & + OML_RELAXATION_TIME, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -42,6 +43,8 @@ SUBROUTINE OML1D(I,J,TML,T0ML,H,H0,HUML, & !-- F Coriolis parameter !-- DT time step (second) !-- G acceleration due to gravity +!-- OML_RELAXATION_TIME time scale (s) to relax TML to T0ML, H to H0, +! HUML and HVML to 0; value <=0 means no relaxation ! !---------------------------------------------------------------- INTEGER, INTENT(IN ) :: I, J @@ -49,12 +52,12 @@ SUBROUTINE OML1D(I,J,TML,T0ML,H,H0,HUML, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - REAL, INTENT(INOUT) :: TML, H, H0, HUML, HVML, TSK + REAL, INTENT(INOUT) :: TML, H, HUML, HVML, TSK - REAL, INTENT(IN ) :: T0ML, HFX, LH, GSW, GLW, & + REAL, INTENT(IN ) :: T0ML, H0, HFX, LH, GSW, GLW, & UAIR, VAIR, UST, F, EMISS, TMOML - REAL, INTENT(IN) :: STBOLT, G, DT, OML_GAMMA + REAL, INTENT(IN) :: STBOLT, G, DT, OML_GAMMA, OML_RELAXATION_TIME ! Local REAL :: rhoair, rhowater, Gam, alp, BV2, A1, A2, B2, u, v, wspd, & @@ -137,6 +140,16 @@ SUBROUTINE OML1D(I,J,TML,T0ML,H,H0,HUML, & u=0. v=0. endif + +! relax TML T0ML and H to H0, HUML and HVML to 0 + + if (oml_relaxation_time .gt. 0.) then + tml = tml - (tml-t0ml)*dt/oml_relaxation_time + h = h - (h-h0)*dt/oml_relaxation_time + huml = huml - huml*dt/oml_relaxation_time + hvml = hvml - hvml*dt/oml_relaxation_time + end if + tsk=tml ! if(h.gt.100.)print *,i,j,h,tml,' h,tml' diff --git a/wrfv2_fire/phys/module_sf_pxlsm.F b/wrfv2_fire/phys/module_sf_pxlsm.F index a6051534..e9588c6f 100755 --- a/wrfv2_fire/phys/module_sf_pxlsm.F +++ b/wrfv2_fire/phys/module_sf_pxlsm.F @@ -29,7 +29,7 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & ITIMESTEP,CURR_SECS,NSOIL,DT,ANAL_INTERVAL, & XLAND, XICE, ALBBCK, ALBEDO, & SNOALB, SMOIS, TSLB, MAVAIL, TA2, & - QA2, ZS,DZS, PSIH, & + QA2, QSFC, ZS,DZS, PSIH, & LANDUSEF,SOILCTOP,SOILCBOT,VEGFRA,VEGF_PX, & ISLTYP,RA,RS,LAI,IMPERV,CANFRA,NLCAT,NSCAT, & HFX,QFX,LH,TSK,SST,ZNT,CANWAT, & @@ -113,6 +113,12 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & ! - Impervious surface and canopy fraction data can be used if processed (otherwise 0% so no impact) ! to alter surface heat capacity (See SURFPX subroutine for details) in urban areas and refine ! LAI and VEGF_PX estimations (see VEGLAND subroutine). +! +! JP 12/2015 - Surface water vapor mixing ratio calculation added for land surface, which is passed to PX-SFCLAY +! for use over all non-water and non-frozen surfaces. +! - PAR function and impact on transpiration modified according to Echer et al.(2015). See P-X LSM documentation +! for full reference. These act to reduce moisture bias near surface during PBL transition. +! !-------------------------------------------------------------------------------------------------------------- !-------------------------------------------------------------------------------------------------------------- ! ARGUMENT LIST: @@ -169,8 +175,12 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & !-- RA Aerodynamic resistence !-- RS Stomatal resistence !-- LAI Leaf area index (weighted according to fractional landuse) +!-- ZNT rougness length +!-- QSFC Sat. water vapor mixing ratio at the surface interface + !-- IMPERV Fraction (percent) of grid cell that is impervious surface (concrete/road/non-veg) !-- CANFRA Fraction (percent) of grid cell that is covered with tree canopy + !-- NLCAT Number of landuse categories !-- NSCAT Number of soil categories @@ -179,7 +189,6 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & !-- LH net upward latent heat flux at surface (W/m^2) !-- TSK surface skin temperature (K) !-- SST sea surface temperature -!-- ZNT rougness length !-- CANWAT Canopy water (mm) !-- GRDFLX Ground heat flux @@ -253,7 +262,7 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & REAL, DIMENSION(1:NSOIL), INTENT(IN)::ZS,DZS REAL, DIMENSION( ims:ime , 1:NSOIL, jms:jme ), INTENT(INOUT) :: SMOIS, TSLB - REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: RA, RS, LAI, ZNT + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: RA, RS, LAI, ZNT, QSFC REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT):: GRDFLX, TSK, TA2, QA2 REAL, DIMENSION( ims:ime , 1:NLCAT, jms:jme ), INTENT(IN):: LANDUSEF @@ -313,7 +322,7 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & FWSAT,FWFC,FWWLT,FB,FCGSAT,FJP,FAS, & FSEAS, T2I, HC_SNOW, SNOW_FRA,SNOWALB, & QST12,ZFUNC,ZF1,ZA2,QV2, DT_FDDA, & - FC2R,FC1SAT, DTPBL + FC2R,FC1SAT, DTPBL, RAW CHARACTER (LEN = 6) :: LAND_USE_TYPE @@ -562,6 +571,8 @@ SUBROUTINE pxlsm(U3D, V3D, DZ8W, QV3D,T3D,TH3D, RHO, & TSK(I,J) = TSLB(I,1,J) ! Skin temp set to 1 cm soil temperature in PX for now CANWAT(I,J) = WR * 1000. ! convert WR back to mm for CANWAT + RAW = RA(I,J) + 4.503 / USTAR + QSFC(I,J) = QFX(I,J) * RAW / DENS1 + QV1 ENDDO ! END MIAN I LOOP ENDDO ! END MAIN J LOOP @@ -1479,15 +1490,19 @@ SUBROUTINE QFLUX (DENS1, QV1, TA1, RG, RAW, QSS, & ! in !!!-RADIATION IF (RSTMIN .GT. 130.0) THEN ! RADL = 30.0 ! W/M2 - F1MAX = 1.-0.03*LAI +! F1MAX = 1.-0.03*LAI + F1MAX = 1.-0.02*LAI !Echer2015 Trees ELSE ! RADL = 100.0 ! W/M2 - F1MAX = 1.-0.05*LAI +! F1MAX = 1.-0.05*LAI + F1MAX = 1.-0.07*LAI !Echer2015 crops/grass ENDIF ! RADF = 1.1 * RG / (RADL * LAI) ! NP89 - EQN34 ! F1 = (RSTMIN / RSMAX + RADF) / (1.0 + RADF) - PAR = 0.45 * RG - F1 = F1MAX*(2./(1.+EXP(-0.014*PAR))-1.) +! PAR = 0.45 * RG + PAR = 0.45 * RG * 4.566 ! converted from W/m2 to umoles/m2/s (1/.219) Echer2015 +! F1 = F1MAX*(2./(1.+EXP(-0.014*PAR))-1.) + F1 = F1MAX*(1.0-exp(-0.0017*PAR)) !Echer2015 F1 = AMAX1(F1,RSTMIN / RSMAX) !!!-SOIL MOISTURE diff --git a/wrfv2_fire/phys/module_sf_pxsfclay.F b/wrfv2_fire/phys/module_sf_pxsfclay.F index 29da30bc..81c2bc60 100755 --- a/wrfv2_fire/phys/module_sf_pxsfclay.F +++ b/wrfv2_fire/phys/module_sf_pxsfclay.F @@ -25,6 +25,7 @@ SUBROUTINE PXSFCLAY(U3D,V3D,T3D,TH3D,QV3D,P3D,dz8w, & U10,V10, & GZ1OZ0,WSPD,BR,ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & + itimestep, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -45,6 +46,13 @@ SUBROUTINE PXSFCLAY(U3D,V3D,T3D,TH3D,QV3D,P3D,dz8w, & ! REVISION HISTORY: ! A. Xiu 2/2005 - developed WRF version based on the MM5 PX LSM ! R. Gilliam 7/2006 - completed implementation into WRF model +! J. Pleim 12/2015 - Saturation WV mixing ratio was recomputed internally for all surfaces. +! Now, it's only recomputed internally at initial timestep or over water. +! Otherwise, the surface water vapor mixing ratio is read in from PXLSM where +! it is computed from the water vapor surface flux from previous time step. +! Also, The MOL calculation was modified to use the water vapor surface flux +! from previous time step to compute surface buoyancy flux. +! !*********************************************************************** !------------------------------------------------------------------- !-- U3D 3D u-velocity interpolated to theta points (m/s) @@ -121,7 +129,7 @@ SUBROUTINE PXSFCLAY(U3D,V3D,T3D,TH3D,QV3D,P3D,dz8w, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ! - INTEGER, INTENT(IN ) :: ISFFLX + INTEGER, INTENT(IN ) :: ISFFLX, ITIMESTEP REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 REAL, INTENT(IN ) :: EP1,EP2,KARMAN ! @@ -141,15 +149,15 @@ SUBROUTINE PXSFCLAY(U3D,V3D,T3D,TH3D,QV3D,P3D,dz8w, & TSK REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT ) :: U10, & - V10, & - QSFC + V10 + ! REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: REGIME, & HFX, & QFX, & LH, & - MOL,RMOL + MOL,RMOL,QSFC !m the following 5 are change to memory size ! REAL, DIMENSION( ims:ime, jms:jme ) , & @@ -222,6 +230,7 @@ SUBROUTINE PXSFCLAY(U3D,V3D,T3D,TH3D,QV3D,P3D,dz8w, & QSFC(ims,j),LH(ims,j), & GZ1OZ0(ims,j),WSPD(ims,j),BR(ims,j),ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & + itimestep, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -237,6 +246,7 @@ SUBROUTINE PXSFCLAY1D(J,US,VS,T1D,THETA1,QV1D,P1D,dz8w1d, & U10,V10,FLHC,FLQC,QGH, & QSFC,LH,GZ1OZ0,WSPD,BR,ISFFLX,DX, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & + itimestep, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -251,7 +261,7 @@ SUBROUTINE PXSFCLAY1D(J,US,VS,T1D,THETA1,QV1D,P1D,dz8w1d, & its,ite, jts,jte, kts,kte, & J ! - INTEGER, INTENT(IN ) :: ISFFLX + INTEGER, INTENT(IN ) :: ISFFLX, ITIMESTEP REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 REAL, INTENT(IN ) :: EP1,EP2,KARMAN @@ -290,11 +300,11 @@ SUBROUTINE PXSFCLAY1D(J,US,VS,T1D,THETA1,QV1D,P1D,dz8w1d, & REAL, DIMENSION( ims:ime ) , & INTENT(INOUT) :: & - QGH + QGH,QSFC REAL, DIMENSION( ims:ime ) , & INTENT(OUT) :: U10,V10, & - QSFC,LH + LH REAL, INTENT(IN ) :: CP,G,ROVCP,XLV,DX,R @@ -336,7 +346,7 @@ SUBROUTINE PXSFCLAY1D(J,US,VS,T1D,THETA1,QV1D,P1D,dz8w1d, & REAL :: XMOL,ZOBOL,Z10OL,ZNTOL,YNT,YOB,X1,X2 REAL :: G2OZ0,G10OZ0,RA2,ZOLL REAL :: TV0,CPOT,RICRITI,AM,AH,SQLNZZ0,RBH,RBW,TSTV - REAL :: PSIH2, PSIM2, PSIH10, PSIM10, CQS + REAL :: PSIH2, PSIM2, PSIH10, PSIM10, CQS,TMPVTCON,TST,QST !-------------------------------Exicutable starts here-------------------- @@ -352,8 +362,18 @@ SUBROUTINE PXSFCLAY1D(J,US,VS,T1D,THETA1,QV1D,P1D,dz8w1d, & !-----Compute virtual potential temperature at surface ! DO I=its,ite - E1=SVP1*EXP( SVP2*(TG(I)-SVPT0)/(TG(I)-SVP3) ) - QSFC(I)=EP2*E1/(PSFC(I)-E1) + IF (TG(I) .LT. 273.15) THEN + !SATURATION VAPOR PRESSURE WRT ICE (SVP1=.6112; 10*mb) + E1=SVP1*EXP(4648*(1./273.15 - 1./TG(I)) - & + & 11.64*LOG(273.15/TG(I)) + 0.02265*(273.15 - TG(I))) + ELSE + !SATURATION VAPOR PRESSURE WRT WATER (Bolton 1980) + E1=SVP1*EXP( SVP2*(TG(I)-SVPT0)/(TG(I)-SVP3) ) + ENDIF +!-- If water or initial timestep use saturation MR for qsfc, otherwise use from LSM + IF (xland(i).gt.1.5 .or. QSFC(i).le.0.0.or.itimestep.eq.1) THEN + QSFC(I)=EP2*E1/(PSFC(I)-E1) + ENDIF ! QGH CHANGED TO USE LOWEST-LEVEL AIR TEMP CONSISTENT WITH MYJSFC CHANGE ! Q2SAT = QGH IN LSM @@ -365,9 +385,10 @@ SUBROUTINE PXSFCLAY1D(J,US,VS,T1D,THETA1,QV1D,P1D,dz8w1d, & !.......... compute the thetav at ground DO I = its, ite - TV0 = TG(I) * (1.0 + EP1 * QSFC(I)*MAVAIL(I)) +! TV0 = TG(I) * (1.0 + EP1 * QSFC(I)*MAVAIL(I)) + TV0 = TG(I) * (1.0 + EP1 * QSFC(I)) CPOT = (100./PSFC(I))**ROVCP - TH0(I) = TV0 * (100./PSFC(I))**ROVCP + TH0(I) = TV0 * CPOT THETAG(I) = CPOT * TG(I) ENDDO ! @@ -449,12 +470,22 @@ SUBROUTINE PXSFCLAY1D(J,US,VS,T1D,THETA1,QV1D,P1D,dz8w1d, & RA(I) = PR0 * (GZ1OZ0(I) - PSIH(I)) / (KARMAN * UST(I)) RBH = 5.0 / UST(I) ! 5/U* ! WESELY AND HICKS (1977) -! ------- RB FOR WATER VAPOR = 5*(0.599/0.709)^2/3 /UST = 4.47/UST hi - RBW = 4.47/UST(I) +! ------- RB FOR WATER VAPOR = 5*(0.606/0.709)^2/3 /UST = 4.503/UST hi + RBW = 4.503/UST(I) CHS(I) = 1./(RA(I) + RBH) CQS = 1./(RA(I) + RBW) MOL(I) = DTG * CHS(I) / UST(I) ! This is really TST - TSTV = (THETAV1(I) - TH0(I)) * CHS(I) / UST(I) +! TSTV = (THETAV1(I) - TH0(I)) * CHS(I) / UST(I) + TMPVTCON = 1.0 + EP1 * QV1D(i) ! COnversion factor for virtual temperature +! TST = -hfx(i)/(rhox(i)*cp*ust(i)) + TST = DTG * CHS(I)/UST(i) + QST = -QFX(i) / (UST(i)*rhox(i)) + IF (itimestep.eq.1) THEN + TSTV = (THETAV1(I) - TH0(I)) * CHS(I) / UST(I) + ELSE + TSTV = TST*TMPVTCON + THETAV1(i)*EP1*QST + ENDIF + IF (ABS(TSTV) .LT. 1.E-5) TSTV = 1.E-5 MOLENGTH(I) = THETAV1(I) * UST(I) * UST(I) / (KARMAN * & G * TSTV) diff --git a/wrfv2_fire/phys/module_sf_ruclsm.F b/wrfv2_fire/phys/module_sf_ruclsm.F index 1e0004e7..9334a1b6 100644 --- a/wrfv2_fire/phys/module_sf_ruclsm.F +++ b/wrfv2_fire/phys/module_sf_ruclsm.F @@ -7,7 +7,7 @@ MODULE module_sf_ruclsm USE module_wrf_error ! VEGETATION PARAMETERS - INTEGER :: LUCATS , BARE, NATURAL, CROP + INTEGER :: LUCATS , BARE, NATURAL, CROP, URBAN integer, PARAMETER :: NLUS=50 CHARACTER*8 LUTYPE INTEGER, DIMENSION(1:NLUS) :: IFORTBL @@ -164,10 +164,10 @@ SUBROUTINE LSMRUC( & INTENT(IN ) :: RAINBL, & GLW, & GSW, & + ALBBCK, & FLHC, & FLQC, & CHS , & - EMISS, & XICE, & XLAND, & ! ALBBCK, & @@ -198,7 +198,7 @@ SUBROUTINE LSMRUC( & CANWAT, & ! new SNOALB, & ALB, & - ALBBCK, & + EMISS, & LAI, & MAVAIL, & SFCEXC, & @@ -279,8 +279,8 @@ SUBROUTINE LSMRUC( & REAL, DIMENSION( ims:ime, 1:nsl, jms:jme) & :: KEEPFR3DFLAG, & SMFR3D - REAL, DIMENSION( ims:ime, jms:jme ) :: & + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: & RHOSNF, & !RHO of snowfall PRECIPFR, & ! time-step frozen precip SNOWFALLAC @@ -508,6 +508,7 @@ SUBROUTINE LSMRUC( & print *, 'LSMRUC, I,J,xland, QFX,HFX from SFCLAY',i,j,xland(i,j), & qfx(i,j),hfx(i,j) print *, ' GSW, GLW =',gsw(i,j),glw(i,j) + print *, 'SNHEI=',snhei print *, 'SOILT, TSO start of time step =',soilt(i,j),(tso(i,k,j),k=1,nsl) print *, 'SOILMOIS start of time step =',(soilmois(i,k,j),k=1,nsl) print *, 'SMFROZEN start of time step =',(smfr3d(i,k,j),k=1,nsl) @@ -539,8 +540,18 @@ SUBROUTINE LSMRUC( & prcpncliq = rainncv(i,j)*(1.-frzfrac(i,j)) prcpncfr = rainncv(i,j)*frzfrac(i,j) !- apply the same frozen precipitation fraction to convective precip - prcpculiq = max(0.,(rainbl(i,j)-rainncv(i,j))*(1-frzfrac(i,j))) + if(frzfrac(i,j) > 0.) then + prcpculiq = max(0.,(rainbl(i,j)-rainncv(i,j))*(1.-frzfrac(i,j))) prcpcufr = max(0.,(rainbl(i,j)-rainncv(i,j))*frzfrac(i,j)) + else + if(tabs < 273.) then + prcpcufr = max(0.,(rainbl(i,j)-rainncv(i,j))) + prcpculiq = 0. + else + prcpcufr = 0. + prcpculiq = max(0.,(rainbl(i,j)-rainncv(i,j))) + endif ! tabs < 273. + endif ! frzfrac > 0. !--- 1*e-3 is to convert from mm/s to m/s PRCPMS = (prcpncliq + prcpculiq)/DT*1.e-3 NEWSNMS = (prcpncfr + prcpcufr)/DT*1.e-3 @@ -672,7 +683,7 @@ SUBROUTINE LSMRUC( & ENDIF !--- initializing soil and surface properties CALL SOILVEGIN ( mosaic_lu, mosaic_soil,soilfrac,nscat,shdmin(i,j),shdmax(i,j),& - NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J)*0.01,& + NLCAT,ILAND,ISOIL,iswater,MYJ,IFOREST,lufrac,VEGFRA(I,J), & EMISSL(I,J),PC(I,J),ZNT(I,J),LAI(I,J),RDLAI2D, & QWRTZ,RHOCS,BCLH,DQM,KSAT,PSIS,QMIN,REF,WILT,i,j ) IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN @@ -688,7 +699,7 @@ SUBROUTINE LSMRUC( & ENDIF CN=CFACTR_DATA ! exponent - SAT=max(1.e-4,CMCMAX_DATA * LAI(I,J) * 0.01*VEGFRA(I,J)) ! canopy water saturated + SAT=max(1.e-4,(min(0.75,(CMCMAX_DATA * LAI(I,J) * 0.01*VEGFRA(I,J))))) ! canopy water saturated !-- definition of number of soil levels in the rooting zone ! IF(iforest(ivgtyp(i,j)).ne.1) THEN @@ -701,7 +712,7 @@ SUBROUTINE LSMRUC( & meltfactor = 2.0 do k=2,nzs - if(zsmain(k).ge.0.6) then + if(zsmain(k).ge.0.4) then NROOT=K goto 111 endif @@ -800,7 +811,7 @@ SUBROUTINE LSMRUC( & ref = 1. qmin = 0. wilt = 0. - emissl(i,j) = 1.0 + emissl(i,j) = 0.98 patmb=P8w(i,1,j)*1.e-2 qvg (i,j) = QSN(SOILT(i,j),TBQ)/PATMB @@ -867,8 +878,8 @@ SUBROUTINE LSMRUC( & CALL SFCTMP (dt,ktau,conflx,i,j, & !--- input variables nzs,nddzs,nroot,meltfactor, & !added meltfactor - iland,isoil,xland(i,j),ivgtyp(i,j),PRCPMS, & - NEWSNMS,SNWE,SNHEI,SNOWFRAC, & + iland,isoil,xland(i,j),ivgtyp(i,j),isltyp(i,j), & + PRCPMS, NEWSNMS,SNWE,SNHEI,SNOWFRAC, & RHOSN,RHONEWSN,RHOSNFALL, & snowrat,grauprat,icerat,curat, & PATM,TABS,QVATM,QCATM,RHO, & @@ -1008,6 +1019,8 @@ SUBROUTINE LSMRUC( & endif ENDIF + if(snow(i,j)==0.) EMISSL(i,j) = LEMITBL(IVGTYP(i,j)) + EMISS (I,J) = EMISSL(I,J) ! SNOW is in [mm], SNWE is in [m]; CANWAT is in mm, CANWATR is in m SNOW (i,j) = SNWE*1000. SNOWH (I,J) = SNHEI @@ -1053,7 +1066,7 @@ SUBROUTINE LSMRUC( & ! The heat of freezing/thawing of soil water is not computed explicitly ! and is responsible for the residual in the energy budget. ! endif - budget(i,j)=budget(i,j)-smf(i,j) +! budget(i,j)=budget(i,j)-smf(i,j) ac=0. as=0. @@ -1088,7 +1101,7 @@ SUBROUTINE LSMRUC( & smelt(i,j)*dt*1.e3, & (smavail(i,j)-smtotold(i,j)) - print *,'SNOW-SNOWold',i,j,snwe,snowold(i,j) + print *,'SNOW,SNOWold',i,j,snwe,snowold(i,j) print *,'SNOW-SNOWold',i,j,max(0.,snwe-snowold(i,j)) print *,'CANWATold, canwat ',i,j,canwatold(i,j),canwat(i,j) print *,'canwat(i,j)-canwatold(i,j)',max(0.,canwat(i,j)-canwatold(i,j)) @@ -1117,7 +1130,7 @@ END SUBROUTINE LSMRUC SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & !--- input variables nzs,nddzs,nroot,meltfactor, & - ILAND,ISOIL,XLAND,IVGTYP,PRCPMS, & + ILAND,ISOIL,XLAND,IVGTYP,ISLTYP,PRCPMS, & NEWSNMS,SNWE,SNHEI,SNOWFRAC, & RHOSN,RHONEWSN,RHOSNFALL, & snowrat,grauprat,icerat,curat, & @@ -1171,7 +1184,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & QKMS, & TKMS - INTEGER, INTENT(IN ) :: IVGTYP + INTEGER, INTENT(IN ) :: IVGTYP, ISLTYP !--- 2-D variables REAL , & INTENT(INOUT) :: EMISS, & @@ -1323,8 +1336,8 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & REAL :: rhonewgr,rhonewice - REAL :: RNET,GSWNEW,EMISSN,ZNTSN, GSWin - REAL :: VEGFRAC + REAL :: RNET,GSWNEW,GSWIN,EMISSN,ZNTSN,EMISS_snowfree + REAL :: VEGFRAC, snow_mosaic, snfr real :: cice, albice, albsn, drip, dripsn, dripnosn !----------------------------------------------------------------- @@ -1335,6 +1348,8 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & SNWE,RHOSN,SNOM,SMELT,TS1D ENDIF + snow_mosaic=0. + snfr = 1. NEWSN=0. newsnowratio = 0. snowfracnewsn=0. @@ -1347,6 +1362,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & VEGFRAC=0.01*VEGFRA dripsn = 0. dripnosn = 0. + smf = 0. !---initialize local arrays for sea ice do k=1,nzs @@ -1362,6 +1378,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & ALBice=ALB_SNOW_FREE ALBsn=alb_snow EMISSN = 0.98 + EMISS_snowfree = LEMITBL(IVGTYP) !--- sea ice properties !--- N.N Zubov "Arctic Ice" @@ -1384,7 +1401,8 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & endif IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'I,J,KTAU,QKMS,TKMS', i,j,ktau,qkms,tkms +! print *,'I,J,KTAU,QKMS,TKMS', i,j,ktau,qkms,tkms + print *,'alb_snow_free',ALB_SNOW_FREE print *,'GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE',& GSW,GSWnew,GLW,SOILT,EMISS,ALB,ALBice,SNWE ENDIF @@ -1471,28 +1489,66 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & ! Update water intercepted by the canopy drip = 0. - IF (vegfrac.GT.0.) THEN + IF (vegfrac.GT.0.01) THEN dd1=CST+(DELT*PRCPMS+NEWSN*RHOnewSN*1.E-3)*vegfrac CST=DD1 IF(CST.GT.SAT) THEN CST=SAT DRIP=DD1-SAT ENDIF + ELSE + CST=0. + DRIP=0. ENDIF IF(SNHEI.GT.0.0) THEN !-- SNOW on the ground !--- Land-use category should be changed to snow/ice for grid points with snow>0 ILAND=ISICE +!24nov15 - based on field exp on Pleasant View soccer fields +! if(meltfactor > 1.5) then ! all veg. types, except forests ! SNHEI_CRIT is a threshold for fractional snow +! SNHEI_CRIT=0.01*1.e3/rhosn SNHEI_CRIT=0.01601*1.e3/rhosn +! Petzold - 1 cm of fresh snow overwrites effects from old snow. +! Need to test SNHEI_CRIT_newsn=0.01 +! SNHEI_CRIT_newsn=0.01 SNHEI_CRIT_newsn=0.0005*1.e3/rhosn - SNOWFRAC=MIN(1.,SNHEI/SNHEI_CRIT) +! else ! forests +!24nov15 +! SNHEI_CRIT=0.02*1.e3/rhosn +! SNHEI_CRIT_newsn=0.001*1.e3/rhosn +! endif + +! SNOWFRAC=MIN(1.,SNHEI/SNHEI_CRIT) + SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) +!24nov15 - SNOWFRAC for urban category < 0.5 + if(ivgtyp == urban) snowfrac=min(0.7,snowfrac) +! if(meltfactor > 1.5) then +! if(isltyp > 9 .and. isltyp < 13) then +!24nov15 clay soil types - SNOFRAC < 0.9 +! snowfrac=min(0.9,snowfrac) +! endif +! else +!24nov15 - SNOWFRAC for forests < 0.75 +! snowfrac=min(0.85,snowfrac) +! endif + +! SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT)) + if(snowfrac < 0.3 .and. tabs > 275.) then +! turn on snow "mosaic" when snowfrac < 0.3 + snow_mosaic = 1. + endif + + if(newsn > 0. ) SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) - if(newsn > 0. ) then + KEEP_SNOW_ALBEDO = 0. + IF (NEWSN > 0. .and. snowfracnewsn > 0.99) THEN ! new snow - SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn) - endif + KEEP_SNOW_ALBEDO = 1. + snow_mosaic=0. ! ??? + ENDIF + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *,'SNHEI_CRIT,SNOWFRAC,SNHEI_CRIT_newsn,SNOWFRACnewsn', & SNHEI_CRIT,SNOWFRAC,SNHEI_CRIT_newsn,SNOWFRACnewsn @@ -1511,9 +1567,6 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & ENDIF - KEEP_SNOW_ALBEDO = 0. - IF (NEWSN > 0. .and. snowfracnewsn > 0.99) KEEP_SNOW_ALBEDO = 1. - !--- GSWNEW in-coming solar for snow on land or on ice ! GSWNEW=GSWnew/(1.-ALB) !-- Time to update snow and ice albedo @@ -1524,25 +1577,39 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & ! ALB_SNOW across Canada's forested areas is very low - 0.27-0.35, this ! causes significant warm biases. Limiting ALB in these areas to be higher than 0.4 ! hwlps with these biases.. - ALBsn=max(0.4,alb_snow) -! ALBsn = MAX(keep_snow_albedo*alb_snow, & -! MIN((alb_snow_free + & -! (alb_snow - alb_snow_free) * snowfrac), alb_snow)) + if( snow_mosaic == 1.) then + ALBsn=alb_snow +! ALBsn=max(0.4,alb_snow) + Emiss= emissn + else + ALBsn = MAX(keep_snow_albedo*alb_snow, & + MIN((alb_snow_free + & + (alb_snow - alb_snow_free) * snowfrac), alb_snow)) + + Emiss = MAX(keep_snow_albedo*emissn, & + MIN((emiss_snowfree + & + (emissn - emiss_snowfree) * snowfrac), emissn)) + endif + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! if(i.eq.279.and.j.eq.263) then + print *,'Snow on soil ALBsn,emiss,snow_mosaic',i,j,ALBsn,emiss,snow_mosaic + ENDIF !28mar11 if canopy is covered with snow to 95% of its capacity and snow depth is ! higher than patchy snow treshold - then snow albedo is not less than 0.55 ! (inspired by the flight from Fairbanks to Seatle) - if(cst.ge.0.95*sat .and. snowfrac .gt.0.99)then - albsn=max(alb_snow,0.55) - endif + +!test if(cst.ge.0.95*sat .and. snowfrac .gt.0.99)then +! albsn=max(alb_snow,0.55) +! endif !-- ALB dependence on snow temperature. When snow temperature is !-- below critical value of -10C - no change to albedo. !-- If temperature is higher that -10C then albedo is decreasing. !-- The minimum albedo at t=0C for snow on land is 15% less than !-- albedo of temperatures below -10C. - if(albsn.lt.0.4) then -! ALB=ALBsn - ALBsn=max(0.4,alb_snow) + if(albsn.lt.0.4 .or. keep_snow_albedo==1) then + ALB=ALBsn +! ALB=max(0.4,alb_snow) else !-- change albedo when no fresh snow and snow albedo is higher than 0.5 ALB = MIN(ALBSN,MAX(ALBSN - 0.1*(soilt - 263.15)/ & @@ -1550,10 +1617,20 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & endif ELSE !----- SNOW on ice -! ALBsn = MAX(keep_snow_albedo*alb_snow, & -! MIN((albice + (alb_snow - albice) * snowfrac), alb_snow)) - ALBsn=alb_snow + if( snow_mosaic == 1.) then + ALBsn=alb_snow + Emiss= emissn + else + ALBsn = MAX(keep_snow_albedo*alb_snow, & + MIN((albice + (alb_snow - albice) * snowfrac), alb_snow)) + Emiss = MAX(keep_snow_albedo*emissn, & + MIN((emiss_snowfree + & + (emissn - emiss_snowfree) * snowfrac), emissn)) + endif + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,'Snow on ice snow_mosaic,ALBsn,emiss',i,j,ALBsn,emiss,snow_mosaic + ENDIF !-- ALB dependence on snow temperature. When snow temperature is !-- below critical value of -10C - no change to albedo. !-- If temperature is higher that -10C then albedo is decreasing. @@ -1567,8 +1644,11 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & ENDIF + if (snow_mosaic==1.) then !may 2014 - treat separately snow-free and snow-covered areas - if (snowfrac < 1.) then + + if(SEAICE .LT. 0.5) then +! LAND ! portion not covered with snow ! compute absorbed GSW for snow-free portion @@ -1576,16 +1656,13 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT - XINET = EMISS*(GLW-UPFLUX) + XINET = EMISS_snowfree*(GLW-UPFLUX) RNET = GSWnew + XINET IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.266.and.j.eq.447) then +! if(i.eq.442.and.j.eq.260) then print *,'Fractional snow - snowfrac=',snowfrac - print *,'Snowfrac<1 GSWnew -',GSWnew,'SOILT, RNET',soilt,rnet + print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet ENDIF - - if(SEAICE .LT. 0.5) then -! LAND do k=1,nzs soilm1ds(k) = soilm1d(k) ts1ds(k) = ts1d(k) @@ -1601,14 +1678,15 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & csts = cst mavails = mavail smelt=0. + runoff1s=0. + runoff2s=0. dripnosn=drip*(1.-snowfrac) CALL SOIL( & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & -!test PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & - EMISS,RNET,QKMS,TKMS,PC,csts,dripnosn, & + EMISS_snowfree,RNET,QKMS,TKMS,PC,csts,dripnosn, & rho,vegfrac,lai, & !--- soil fixed fields QWRTZ,rhocs,dqm,qmin,ref,wilt, & @@ -1625,6 +1703,20 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & infiltrs,smf) else ! SEA ICE +! portion not covered with snow +! compute absorbed GSW for snow-free portion + + gswnew=GSWin*(1.-albice) +!-------------- + T3 = STBOLT*SOILT*SOILT*SOILT + UPFLUX = T3 *SOILT + XINET = EMISS_snowfree*(GLW-UPFLUX) + RNET = GSWnew + XINET + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN +! if(i.eq.442.and.j.eq.260) then + print *,'Fractional snow - snowfrac=',snowfrac + print *,'Snowfrac<1 GSWin,GSWnew -',GSWin,GSWnew,'SOILT, RNET',soilt,rnet + ENDIF do k=1,nzs ts1ds(k) = ts1d(k) enddo @@ -1633,13 +1725,14 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & qsgs = qsg qcgs = qcg smelt=0. + runoff1s=0. + runoff2s=0. CALL SICE( & !--- input variables i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & -! PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew, & - EMISS,RNET,QKMS,TKMS,rho, & + 0.98,RNET,QKMS,TKMS,rho, & !--- sea ice parameters tice,rhosice,capice,thdifice, & zsmain,zshalf,DTDZS,DTDZS2,tbq, & @@ -1668,16 +1761,16 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & !return gswnew to incoming solar IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.266.and.j.eq.447) then +! if(i.eq.442.and.j.eq.260) then print *,'gswnew,alb_snow_free,alb',gswnew,alb_snow_free,alb ENDIF ! gswnew=gswnew/(1.-alb_snow_free) IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.266.and.j.eq.447) then +! if(i.eq.442.and.j.eq.260) then print *,'Incoming GSWnew snowfrac<1 -',gswnew ENDIF - endif ! snowfrac < 1. + endif ! snow_mosaic=1. !--- recompute absorbed solar radiation and net radiation !--- for updated value of snow albedo - ALB @@ -1686,10 +1779,11 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & !-------------- T3 = STBOLT*SOILT*SOILT*SOILT UPFLUX = T3 *SOILT - XINET = EMISSN*(GLW-UPFLUX) + XINET = EMISS*(GLW-UPFLUX) RNET = GSWnew + XINET IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! if(i.eq.266.and.j.eq.447) then +! if(i.eq.442.and.j.eq.260) then +! if(i.eq.271.and.j.eq.242) then print *,'RNET=',rnet print *,'SNOW - I,J,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB',& i,j,newsn,snwe,snhei,GSW,GSWnew,GLW,UPFLUX,ALB @@ -1697,13 +1791,19 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & if (SEAICE .LT. 0.5) then ! LAND - dripsn = drip*snowfrac + if(snow_mosaic==1.)then + dripsn = drip*snowfrac + snfr=1. + else + dripsn = drip + snfr=snowfrac + endif CALL SNOWSOIL ( & !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & - meltfactor,rhonewsn, & ! new - ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snowfrac, & + meltfactor,rhonewsn,SNHEI_CRIT, & ! new + ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & RHOSN,PATM,QVATM,QCATM, & - GLW,GSWnew,EMISSN,RNET,IVGTYP, & + GLW,GSWnew,EMISS,RNET,IVGTYP, & QKMS,TKMS,PC,CST,dripsn, & RHO,VEGFRAC,ALB,ZNT,lai, & MYJ, & @@ -1722,12 +1822,18 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & mavail,soilice,soiliqw,infiltr ) else ! SEA ICE + if(snow_mosaic==1.)then + snfr=1. + else + snfr=snowfrac + endif + CALL SNOWSEAICE ( & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & - meltfactor,rhonewsn, & ! new - ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snowfrac, & + meltfactor,rhonewsn,SNHEI_CRIT, & ! new + ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr, & RHOSN,PATM,QVATM,QCATM, & - GLW,GSWnew,EMISSN,RNET, & + GLW,GSWnew,EMISS,RNET, & QKMS,TKMS,RHO, & !--- sea ice parameters ALB,ZNT, & @@ -1758,39 +1864,45 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & enddo endif + if(snhei.eq.0.) then !--- all snow is melted alb=alb_snow_free iland=ivgtyp endif + if (snow_mosaic==1.) then ! May 2014 - now combine snow covered and snow-free land fluxes, soil temp, moist, ! etc. - if (snowfrac < 1.) then if(SEAICE .LT. 0.5) then ! LAND IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN -! print *,'SOILT snow on land', soilt -! print *,'SOILT on snow-free land', soilts - if(i.eq.416.and.j.eq.116) then +! if(i.eq.442.and.j.eq.260) then + print *,'SOILT snow on land', ktau, i,j,soilt + print *,'SOILT on snow-free land', i,j,soilts + print *,'ts1d,ts1ds',i,j,ts1d,ts1ds + print *,' SNOW flux',i,j, snflx print *,' Ground flux on snow-covered land',i,j, s print *,' Ground flux on snow-free land', i,j,ss print *,' CSTS, CST', i,j,csts,cst - endif ENDIF do k=1,nzs soilm1d(k) = soilm1ds(k)*(1.-snowfrac) + soilm1d(k)*snowfrac ts1d(k) = ts1ds(k)*(1.-snowfrac) + ts1d(k)*snowfrac smfrkeep(k) = smfrkeeps(k)*(1.-snowfrac) + smfrkeep(k)*snowfrac - keepfr(k) = keepfrs(k)*(1.-snowfrac) + keepfr(k)*snowfrac + if(snowfrac > 0.5) then + keepfr(k) = keepfr(k) + else + keepfr(k) = keepfrs(k) + endif soilice(k) = soilices(k)*(1.-snowfrac) + soilice(k)*snowfrac soiliqw(k) = soiliqws(k)*(1.-snowfrac) + soiliqw(k)*snowfrac enddo dew = dews*(1.-snowfrac) + dew*snowfrac soilt = soilts*(1.-snowfrac) + soilt*snowfrac qvg = qvgs*(1.-snowfrac) + qvg*snowfrac - qsg = qsgs*(1.-snowfrac) + qsgs*snowfrac - qcg = qcgs*(1.-snowfrac) + qcgs*snowfrac + qsg = qsgs*(1.-snowfrac) + qsg*snowfrac + qcg = qcgs*(1.-snowfrac) + qcg*snowfrac edir1 = edir1s*(1.-snowfrac) + edir1*snowfrac ec1 = ec1s*(1.-snowfrac) + ec1*snowfrac cst = csts*(1.-snowfrac) + cst*snowfrac @@ -1799,12 +1911,20 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & qfx = qfxs*(1.-snowfrac) + qfx*snowfrac hfx = hfxs*(1.-snowfrac) + hfx*snowfrac s = ss*(1.-snowfrac) + s*snowfrac - evapl = evapls*(1.-snowfrac) + evapl*snowfrac + evapl = evapls*(1.-snowfrac) sublim = sublim*snowfrac prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac fltot = fltots*(1.-snowfrac) + fltot*snowfrac !alb - alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac + ALB = MAX(keep_snow_albedo*alb, & + MIN((alb_snow_free + (alb - alb_snow_free) * snowfrac), alb)) + + Emiss = MAX(keep_snow_albedo*emissn, & + MIN((emiss_snowfree + & + (emissn - emiss_snowfree) * snowfrac), emissn)) + +! alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac +! emiss=emiss_snowfree*(1.-snowfrac) + emissn*snowfrac ! if(abs(fltot) > 2.) then ! print *,'i,j,fltot,snowfrac,fltots',fltot,snowfrac,fltots,i,j @@ -1819,10 +1939,9 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & infiltr = infiltrs*(1.-snowfrac) + infiltr*snowfrac IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - if(i.eq.266.and.j.eq.447) then print *,' Ground flux combined', i,j, s - endif print *,'SOILT combined on land', soilt + print *,'TS combined on land', ts1d ENDIF else ! SEA ICE @@ -1836,17 +1955,25 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & dew = dews*(1.-snowfrac) + dew*snowfrac soilt = soilts*(1.-snowfrac) + soilt*snowfrac qvg = qvgs*(1.-snowfrac) + qvg*snowfrac - qsg = qsgs*(1.-snowfrac) + qsgs*snowfrac - qcg = qcgs*(1.-snowfrac) + qcgs*snowfrac + qsg = qsgs*(1.-snowfrac) + qsg*snowfrac + qcg = qcgs*(1.-snowfrac) + qcg*snowfrac eeta = eetas*(1.-snowfrac) + eeta*snowfrac qfx = qfxs*(1.-snowfrac) + qfx*snowfrac hfx = hfxs*(1.-snowfrac) + hfx*snowfrac s = ss*(1.-snowfrac) + s*snowfrac - evapl = evapls*(1.-snowfrac) + evapl*snowfrac + sublim = eeta prcpl = prcpls*(1.-snowfrac) + prcpl*snowfrac fltot = fltots*(1.-snowfrac) + fltot*snowfrac !alb - alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac + ALB = MAX(keep_snow_albedo*alb, & + MIN((albice + (alb - alb_snow_free) * snowfrac), alb)) + + Emiss = MAX(keep_snow_albedo*emissn, & + MIN((emiss_snowfree + & + (emissn - emiss_snowfree) * snowfrac), emissn)) + +! alb=alb_snow_free*(1.-snowfrac) + alb*snowfrac +! emiss=1.*(1.-snowfrac) + emissn*snowfrac runoff1 = runoff1s*(1.-snowfrac) + runoff1*snowfrac runoff2 = runoff2s*(1.-snowfrac) + runoff2*snowfrac smelt = smelt * snowfrac @@ -1857,8 +1984,12 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & print *,'SOILT combined on ice', soilt ENDIF endif - endif ! snowfrac < 1. + endif ! snow_mosaic = 1. +! run-total accumulated snow based on snowfall and snowmelt in [m] + + snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio)) + ELSE !--- no snow snheiprint=0. @@ -1934,9 +2065,6 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j, & endif ENDIF -! run-total accumulated snow based on snowfall and snowmelt in [m] - - snowfallac = snowfallac + max(0.,(newsn - rhowater/rhonewsn*smelt*delt*newsnowratio)) ! RETURN ! END @@ -2334,8 +2462,8 @@ SUBROUTINE SOIL ( & !--- transpiration may take place. WETCAN=(CST/SAT)**CN +! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN - if(lai > 1.) wetcan=wetcan/lai !************************************************************** ! TRANSF computes transpiration function @@ -2432,6 +2560,7 @@ SUBROUTINE SOIL ( & zsmain,zshalf,diffu,hydro, & QSG,QVG,QCG,QCATM,QVATM,-PRCPMS, & QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC, & + 0., & !-- soil properties DQM,QMIN,REF,KSAT,RAS,INFMAX, & !-- output @@ -2539,8 +2668,8 @@ SUBROUTINE SOIL ( & IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN ! IF(i.eq.440.and.j.eq.180 .or. qfx.gt.1000..or.i.eq.417.and.j.eq.540) then print *,'SOIL - FLTOT,RNET,HFT,QFX,S,X=',i,j,FLTOT,RNET,HFT,XLV*EETA,s,x - print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,cmc2ms*ras,vegfrac',& - edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,cmc2ms*ras,vegfrac + print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac',& + edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac ENDIF if(detal(1) .ne. 0.) then ! SMF - energy of phase change in the first soil layer @@ -2826,7 +2955,7 @@ END SUBROUTINE SICE SUBROUTINE SNOWSOIL ( & !--- input variables i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot, & - meltfactor,rhonewsn, & ! new + meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC, & RHOSN, & PATM,QVATM,QCATM, & @@ -2925,7 +3054,8 @@ SUBROUTINE SNOWSOIL ( & INTEGER, INTENT(IN ) :: i,j,isoil REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & - RAINF,NEWSNOW,RHONEWSN,meltfactor + RAINF,NEWSNOW,RHONEWSN, & + SNHEI_CRIT,meltfactor LOGICAL, INTENT(IN ) :: myj @@ -3067,8 +3197,8 @@ SUBROUTINE SNOWSOIL ( & XLVm=XLV+XLMELT ! STBOLT=5.670151E-8 -!--- SNOW flag -- 99 - ILAND=99 +!--- SNOW flag -- ISICE +! ILAND=isice !--- DELTSN - is the threshold for splitting the snow layer into 2 layers. !--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, @@ -3080,19 +3210,26 @@ SUBROUTINE SNOWSOIL ( & !save SOILT and QVG soiltold=soilt - qgold=qsg + qgold=qvg x=0. ! increase thinkness of top snow layer from 3 cm SWE to 5 cm SWE +! DELTSN=5.*SNHEI_CRIT +! snth=0.4*SNHEI_CRIT + DELTSN=0.05*1.e3/rhosn - snth=0.01601*1.e3/rhosn + snth=0.01*1.e3/rhosn +! snth=0.01601*1.e3/rhosn + +! if(i.eq.442.and.j.eq.260) then +! print *,'deltsn,snhei,snth',i,j,deltsn,snhei,snth +! ENDIF -! when the snow depth is marginally higher than DELTSN, +! For 2-layer snow model when the snow depth is marginally higher than DELTSN, ! reset DELTSN to half of snow depth. - IF(SNHEI.GE.DELTSN.and.SNHEI.lt.DELTSN+SNTH) THEN - deltsn=0.5*snhei -! if(snhei-deltsn-snth.lt.snth) deltsn=0.5*snhei + IF(SNHEI.GE.DELTSN+SNTH) THEN + if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *,'DELTSN is changed,deltsn,snhei,snth',i,j,deltsn,snhei,snth ENDIF @@ -3102,7 +3239,7 @@ SUBROUTINE SNOWSOIL ( & CI=RHOICE*2100. RAS=RHO*1.E-3 RIW=rhoice*1.e-3 - MAVAIL=1. +! MAVAIL=1. RSM=0. DO K=1,NZS @@ -3300,8 +3437,8 @@ SUBROUTINE SNOWSOIL ( & ENDIF WETCAN=(CST/SAT)**CN +! if(lai > 1.) wetcan=wetcan/lai DRYCAN=1.-WETCAN - if(lai > 1.) wetcan=wetcan/lai !************************************************************** ! TRANSF computes transpiration function @@ -3347,7 +3484,7 @@ SUBROUTINE SNOWSOIL ( & !--- output variables snweprint,snheiprint,rsm, & tso,soilt,soilt1,tsnav,qvg,qsg,qcg, & - smelt,snoh,snflx,ilnb,x) + smelt,snoh,snflx,s,ilnb,x) !************************************************************************ !--- RECALCULATION OF DEW USING NEW VALUE OF QSG OR TRANSP IF NO DEW @@ -3407,8 +3544,9 @@ SUBROUTINE SNOWSOIL ( & delt,nzs,nddzs,DTDZS,DTDZS2,RIW, & zsmain,zshalf,diffu,hydro, & QSG,QVG,QCG,QCATM,QVATM,-PRCPMS, & - 0.,TRANSP,0., & + QKMS,TRANSP,0., & 0.,SMELT,soilice,vegfrac, & + snowfrac, & !-- soil properties DQM,QMIN,REF,KSAT,RAS,INFMAX, & !-- output @@ -3425,7 +3563,7 @@ SUBROUTINE SNOWSOIL ( & ! 21apr2009 ! SNOM [mm] goes into the passed-in ACSNOM variable in the grid derived type SNOM=SNOM+SMELT*DELT*1.e3 - +! !--- KEEPFR is 1 when the temperature and moisture in soil !--- are both increasing. In this case soil ice should not !--- be increasing according to the freezing curve. @@ -3460,7 +3598,7 @@ SUBROUTINE SNOWSOIL ( & print *,'abs temp HFX',hft ENDIF Q1 = - FQ*RAS* (QVATM - QSG) - + CMC2MS=0. IF (Q1.LT.0.) THEN ! --- condensation EDIR1=0. @@ -3513,12 +3651,14 @@ SUBROUTINE SNOWSOIL ( & ENDIF ENDIF S=SNFLX +! sublim=eeta + sublim=EDIR1*1.E3 ! Energy budget FLTOT=RNET-HFT-XLVm*EETA-S-SNOH-x IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *,'SNOWSOIL - FLTOT,RNET,HFT,QFX,S,SNOH,X=',FLTOT,RNET,HFT,XLVm*EETA,s,SNOH,X - print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,cmc2ms*ras,vegfrac,beta',& - edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,cmc2ms*ras,vegfrac,beta + print *,'edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac,beta',& + edir1,ec1,ett1,mavail,qkms,qvatm,qvg,qsg,vegfrac,beta ENDIF 222 CONTINUE @@ -3534,7 +3674,7 @@ END SUBROUTINE SNOWSOIL SUBROUTINE SNOWSEAICE( & i,j,isoil,delt,ktau,conflx,nzs,nddzs, & - meltfactor,rhonewsn, & ! new + meltfactor,rhonewsn,SNHEI_CRIT, & ! new ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac, & RHOSN,PATM,QVATM,QCATM, & GLW,GSW,EMISS,RNET, & @@ -3566,7 +3706,8 @@ SUBROUTINE SNOWSEAICE( & INTEGER, INTENT(IN ) :: i,j,isoil REAL, INTENT(IN ) :: DELT,CONFLX,PRCPMS , & - RAINF,NEWSNOW,RHONEWSN,meltfactor + RAINF,NEWSNOW,RHONEWSN, & + meltfactor, snhei_crit real :: rhonewcsn !--- 3-D Atmospheric variables @@ -3676,8 +3817,8 @@ SUBROUTINE SNOWSEAICE( & XLVm=XLV+XLMELT ! STBOLT=5.670151E-8 -!--- SNOW flag -- 99 - ILAND=99 +!--- SNOW flag -- ISICE +! ILAND=isice !--- DELTSN - is the threshold for splitting the snow layer into 2 layers. !--- With snow density 400 kg/m^3, this threshold is equal to 7.5 cm, @@ -3688,21 +3829,23 @@ SUBROUTINE SNOWSEAICE( & !--- equals 4 cm for snow density 400 kg/m^3. ! increase thickness of top snow layer from 3 cm SWE to 5 cm SWE +! DELTSN=5.*SNHEI_CRIT +! snth=0.4*SNHEI_CRIT + DELTSN=0.05*1.e3/rhosn - snth=0.01601*1.e3/rhosn + snth=0.01*1.e3/rhosn +! snth=0.01601*1.e3/rhosn -! when the snow depth is marginlly higher than DELTSN, +! For 2-layer snow model when the snow depth is marginlly higher than DELTSN, ! reset DELTSN to half of snow depth. - IF(SNHEI.GE.DELTSN.and.SNHEI.lt.DELTSN+SNTH) THEN - deltsn=0.5*snhei -! if(snhei-deltsn-snth.lt.snth) deltsn=0.5*snhei + IF(SNHEI.GE.DELTSN+SNTH) THEN + if(snhei-deltsn-snth.lt.snth) deltsn=0.5*(snhei-snth) IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *,'DELTSN ICE is changed,deltsn,snhei,snth', & i,j, deltsn,snhei,snth ENDIF ENDIF - RHOICE=900. CI=RHOICE*2100. RAS=RHO*1.E-3 @@ -3784,7 +3927,7 @@ SUBROUTINE SNOWSEAICE( & if(snhei.le.DELTSN+SNTH) then !-- 1-layer snow model ilnb=1 - snprim=snhei + snprim=max(snth,snhei) soilt1=tso(1) tsob=tso(1) XSN = DELT/2./(zshalf(2)+0.5*SNPRIM) @@ -3831,15 +3974,15 @@ SUBROUTINE SNOWSEAICE( & endif ENDIF - IF(SNHEI.LT.SNTH.AND.SNHEI.GE.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first sea ice layer. - fsn=SNHEI/(SNHEI+zsmain(2)) + snprim=SNHEI+zsmain(2) + fsn=SNHEI/snprim fso=1.-fsn soilt1=tso(1) tsob=tso(2) - snprim=SNHEI+zsmain(2) - XSN = DELT/2./(zshalf(3)+0.5*snprim) + XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) DDZSN = XSN /snprim X1SN = DDZSN * (fsn*thdifsn+fso*thdifice(1)) X2=DTDZS(2)*THDIFICE(2) @@ -3968,13 +4111,13 @@ SUBROUTINE SNOWSEAICE( & ! blended TSO(2)=min(271.4,(rhtso(NZS1)+cotso(NZS1)*SOILT)) tso(1)=min(271.4,(tso(2)+(soilt-tso(2))*fso)) - SOILT1=SOILT + SOILT1=TSO(1) tsob=TSO(2) ELSE ! snow is melted TSO(1)=min(271.4,SOILT) - SOILT1=SOILT - tsob=tso(2) + SOILT1=min(271.4,SOILT) + tsob=tso(1) ENDIF !---- Final solution for TSO in sea ice IF (SNHEI > 0. .and. SNHEI < SNTH) THEN @@ -3989,20 +4132,29 @@ SUBROUTINE SNOWSEAICE( & TSO(K)=min(271.4,rhtso(KK)+cotso(KK)*TSO(K-1)) END DO ENDIF +!--- For thin snow layer combined with the top soil layer +!--- TSO(i,j,1) is computed by linear interpolation between SOILT +!--- and TSO(i,j,2) +! if(SNHEI.LT.SNTH.AND.SNHEI.GT.0.)then +! tso(1)=min(271.4,tso(2)+(soilt-tso(2))*fso) +! soilt1=tso(1) +! tsob = tso(2) +! endif if(nmelt.eq.1) go to 220 !--- IF SOILT > 273.15 F then melting of snow can happen ! IF(SOILT.GT.273.15.AND.SNWE.GT.0.) THEN ! if all snow can evaporate, then there is nothing to melt - IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0.) THEN + IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0..AND.SNHEI.GT.0.) THEN ! nmelt = 1 - soiltfrac=273.15 +! soiltfrac=273.15 + soiltfrac=snowfrac*273.15+(1.-snowfrac)*min(271.4,SOILT) QSG= QSN(soiltfrac,TBQ)/PP T3 = STBOLT*TNold*TNold*TNold - UPFLUX = T3 * 0.5*(TNold+SOILT) + UPFLUX = T3 * 0.5*(TNold+SOILTfrac) XINET = EMISS*(GLW-UPFLUX) ! RNET = GSW + XINET EPOT = -QKMS*(QVATM-QSG) @@ -4097,9 +4249,10 @@ SUBROUTINE SNOWSEAICE( & !-- update liquid equivalent of snow depth !-- for evaporation and snow melt SNWE = AMAX1(0.,(SNWEPR- & - (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & + (SMELT+BETA*EPOT*RAS)*DELT & +! (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & ) ) - +!!!! soilt=soiltfrac !--- If there is no snow melting then just evaporation !--- or condensation changes SNWE @@ -4107,7 +4260,8 @@ SUBROUTINE SNOWSEAICE( & if(snhei.ne.0.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & - BETA*EPOT*RAS*DELT*snowfrac)) + BETA*EPOT*RAS*DELT)) +! BETA*EPOT*RAS*DELT*snowfrac)) endif ENDIF @@ -4251,7 +4405,7 @@ SUBROUTINE SNOWSEAICE( & !-- Restore sea-ice parameters if snow is less than threshold IF(SNHEI.EQ.0.) then tsnav=soilt-273.15 - emiss=1. + emiss=0.98 znt=0.011 alb=0.55 ENDIF @@ -4449,7 +4603,10 @@ SUBROUTINE SOILTEMP( & !--- THE HEAT BALANCE EQUATION (Smirnova et al., 1996, EQ. 21,26) RHCS=CAP(1) - fex=1.5 +! fex > 1. - reduces direct evaporation, and makes surface forecast drier +! and warmer +! fex=1.5 + fex=1. H=MAVAIL**fex ! IF(DEW.NE.0.)THEN ! DRYCAN=0. @@ -4511,7 +4668,8 @@ SUBROUTINE SOILTEMP( & CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil) Q1=TX2+H*QS1 IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN - print *,'VILKA2 - TS1,QS1,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 +! if(i.eq.279.and.j.eq.263) then + print *,'VILKA2 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1 ENDIF IF(Q1.GT.QS1) GOTO 90 QSG=QS1 @@ -4592,7 +4750,7 @@ SUBROUTINE SNOWTEMP( & !--- output variables SNWEPRINT,SNHEIPRINT,RSM, & TSO,SOILT,SOILT1,TSNAV,QVG,QSG,QCG, & - SMELT,SNOH,SNFLX,ILNB,X) + SMELT,SNOH,SNFLX,S,ILNB,X) !******************************************************************** ! Energy budget equation and heat diffusion eqn are @@ -4720,6 +4878,7 @@ SUBROUTINE SNOWTEMP( & SMELT, & SNOH, & SNFLX, & + S, & SOILT, & SOILT1, & TSNAV @@ -4757,7 +4916,6 @@ SUBROUTINE SNOWTEMP( & ec1, & ett1, & eeta, & - s, & qfx, & hfx @@ -4800,7 +4958,7 @@ SUBROUTINE SNOWTEMP( & NZS1=NZS-1 NZS2=NZS-2 - QGOLD=QSG + QGOLD=QVG DZSTOP=1./(ZSMAIN(2)-ZSMAIN(1)) !****************************************************************************** @@ -4834,7 +4992,7 @@ SUBROUTINE SNOWTEMP( & print *,'1-layer - snth,snhei,deltsn',snth,snhei,deltsn ENDIF ilnb=1 - snprim=snhei + snprim=max(snth,snhei) tsob=tso(1) soilt1=tso(1) XSN = DELT/2./(zshalf(2)+0.5*SNPRIM) @@ -4860,7 +5018,7 @@ SUBROUTINE SNOWTEMP( & ilnb=2 snprim=deltsn tsob=soilt1 - XSN = DELT/2./(0.5*SNHEI) + XSN = DELT/2./(0.5*deltsn) XSN1= DELT/2./(zshalf(2)+0.5*(SNHEI-DELTSN)) DDZSN = XSN / DELTSN DDZSN1 = XSN1 / (SNHEI-DELTSN) @@ -4883,16 +5041,16 @@ SUBROUTINE SNOWTEMP( & -273.15 endif ENDIF -! IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then - IF(SNHEI.LT.SNTH.AND.SNHEI.GE.0.) then + IF(SNHEI.LT.SNTH.AND.SNHEI.GT.0.) then +! IF(SNHEI.LT.SNTH.AND.SNHEI.GE.0.) then !--- snow is too thin to be treated separately, therefore it !--- is combined with the first soil layer. - fsn=SNHEI/(SNHEI+zsmain(2)) + snprim=SNHEI+zsmain(2) + fsn=SNHEI/snprim fso=1.-fsn soilt1=tso(1) tsob=tso(2) - snprim=SNHEI+zsmain(2) - XSN = DELT/2./(zshalf(3)+0.5*snprim) + XSN = DELT/2./((zshalf(3)-zsmain(2))+0.5*snprim) DDZSN = XSN /snprim X1SN = DDZSN * (fsn*thdifsn+fso*thdif(1)) X2=DTDZS(2)*THDIF(2) @@ -4967,6 +5125,9 @@ SUBROUTINE SNOWTEMP( & snprim R22SN = snprim*snprim*0.5 & /((fsn*THDIFSN+fso*THDIF(1))*delt) + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN + print *,' Combined D9SN,R22SN,D1SN,D2SN: ',D9SN,R22SN,D1SN,D2SN + ENDIF ENDIF IF(SNHEI.eq.0.)then !--- all snow is sublimated @@ -5079,13 +5240,15 @@ SUBROUTINE SNOWTEMP( & ! blended TSO(2)=rhtso(NZS1)+cotso(NZS1)*SOILT tso(1)=(tso(2)+(soilt-tso(2))*fso) - SOILT1=SOILT + SOILT1=TSO(1) tsob=TSO(2) ELSE -! snow is melted +!-- very thin or zero snow. If snow is thin we suppose that +!--- tso(i,j,1)=SOILT, and later we recompute tso(i,j,1) TSO(1)=SOILT SOILT1=SOILT - tsob=tso(2) + tsob=TSO(1) +!new tsob=tso(2) ENDIF !---- Final solution for TSO @@ -5102,6 +5265,15 @@ SUBROUTINE SNOWTEMP( & TSO(K)=rhtso(KK)+cotso(KK)*TSO(K-1) END DO ENDIF +!--- For thin snow layer combined with the top soil layer +!--- TSO(1) is recomputed by linear interpolation between SOILT +!--- and TSO(i,j,2) +! if(SNHEI.LT.SNTH.AND.SNHEI.GT.0.)then +! tso(1)=tso(2)+(soilt-tso(2))*fso +! soilt1=tso(1) +! tsob = tso(2) +! endif + IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN ! IF(i.eq.266.and.j.eq.447) then @@ -5115,8 +5287,9 @@ SUBROUTINE SNOWTEMP( & ! if all snow can evaporate, then there is nothing to melt IF(SOILT.GT.273.15.AND.SNWEPR-BETA*EPOT*RAS*DELT.GT.0.AND.SNHEI.GT.0.) THEN nmelt = 1 - soiltfrac=273.15 + soiltfrac=snowfrac*273.15+(1.-snowfrac)*SOILT QSG=min(QSG, QSN(soiltfrac,TBQ)/PP) + qvg=qsg T3 = STBOLT*TN*TN*TN UPFLUX = T3 * 0.5*(TN + SOILTfrac) XINET = EMISS*(GLW-UPFLUX) @@ -5167,11 +5340,11 @@ SUBROUTINE SNOWTEMP( & ! X= (R21+D9SN*R22SN)*(soiltfrac-TN) + & - XLVM*R210*(QSG-QGOLD) + XLVM*R210*(QVG-QGOLD) IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *,'SNOWTEMP storage ',i,j,x - print *,'R21,D9sn,r22sn,soiltfrac,tn,qsg,qgold,snprim', & - R21,D9sn,r22sn,soiltfrac,tn,qsg,qgold,snprim + print *,'R21,D9sn,r22sn,soiltfrac,tn,qsg,qvg,qgold,snprim', & + R21,D9sn,r22sn,soiltfrac,tn,qsg,qvg,qgold,snprim ENDIF !-- SNOH is energy flux of snow phase change @@ -5198,7 +5371,7 @@ SUBROUTINE SNOWTEMP( & ENDIF ! rr - potential melting - rr=SNWEPR/delt-BETA*EPOT*RAS + rr=max(0.,SNWEPR/delt-BETA*EPOT*RAS) SMELT=min(SMELT,rr) IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *,'4- SMELT i,j,smelt,rr',i,j,smelt,rr @@ -5220,7 +5393,7 @@ SUBROUTINE SNOWTEMP( & rsm=0. endif !18apr08 rsm is part of melted water that stays in snow as liquid - SMELT=SMELT-rsm/delt + SMELT=max(0.,SMELT-rsm/delt) IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN print *,'5- SMELT i,j,smelt,rsm,snwepr,rsmfrac', & i,j,smelt,rsm,snwepr,rsmfrac @@ -5229,7 +5402,8 @@ SUBROUTINE SNOWTEMP( & !-- update of liquid equivalent of snow depth !-- due to evaporation and snow melt SNWE = AMAX1(0.,(SNWEPR- & - (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & + (SMELT+BETA*EPOT*RAS)*DELT & +! (SMELT+BETA*EPOT*RAS)*DELT*snowfrac & ! (SMELT+BETA*EPOT*RAS*UMVEG)*DELT & ) ) !--- If there is no snow melting then just evaporation @@ -5238,7 +5412,8 @@ SUBROUTINE SNOWTEMP( & if(snhei.ne.0.) then EPOT=-QKMS*(QVATM-QSG) SNWE = AMAX1(0.,(SNWEPR- & - BETA*EPOT*RAS*DELT*snowfrac)) + BETA*EPOT*RAS*DELT)) +! BETA*EPOT*RAS*DELT*snowfrac)) endif ENDIF @@ -5271,12 +5446,16 @@ SUBROUTINE SNOWTEMP( & IF(SNHEI.GE.SNTH)then S=thdifsn*RHOCSN*(soilt-TSOB)/SNPRIM SNFLX=S + S=D9*(tso(1)-tso(2)) ELSEIF(SNHEI.lt.SNTH.and.SNHEI.GT.0.) then S=(fsn*thdifsn*rhocsn+fso*thdif(1)*rhcs)* & (soilt-TSOB)/snprim SNFLX=S + S=D9*(tso(1)-tso(2)) ELSE - SNFLX=D9SN*(SOILT-TSOB) + S=D9SN*(SOILT-TSOB) + SNFLX=S + S=D9*(tso(1)-tso(2)) ENDIF SNHEI=SNWE *1.E3 / RHOSN @@ -5297,7 +5476,7 @@ SUBROUTINE SNOWTEMP( & hsn = snhei endif - soiltfrac=273.15 + soiltfrac=snowfrac*273.15+(1.-snowfrac)*TSO(1) SNOHG=(TSO(1)-soiltfrac)*(cap(1)*zshalf(2)+ & RHOCSN*0.5*hsn) / DELT @@ -5318,7 +5497,8 @@ SUBROUTINE SNOWTEMP( & print *,'TSO(1),soiltfrac,smeltg,SNODIF',TSO(1),soiltfrac,smeltg,SNODIF ENDIF - snwe=max(0.,snwe-smeltg*delt*snowfrac) +! snwe=max(0.,snwe-smeltg*delt*snowfrac) + snwe=max(0.,snwe-smeltg*delt) SNHEI=SNWE *1.E3 / RHOSN if(snhei > 0.) TSO(1) = soiltfrac @@ -5381,7 +5561,7 @@ SUBROUTINE SOILMOIST ( & ZSMAIN,ZSHALF,DIFFU,HYDRO, & QSG,QVG,QCG,QCATM,QVATM,PRCP, & QKMS,TRANSP,DRIP, & - DEW,SMELT,SOILICE,VEGFRAC, & + DEW,SMELT,SOILICE,VEGFRAC,SNOWFRAC, & !--soil properties DQM,QMIN,REF,KSAT,RAS,INFMAX, & !--output @@ -5447,7 +5627,7 @@ SUBROUTINE SOILMOIST ( & REAL, INTENT(IN ) :: QSG,QVG,QCG,QCATM,QVATM , & QKMS,VEGFRAC,DRIP,PRCP , & - DEW,SMELT , & + DEW,SMELT,SNOWFRAC , & DQM,QMIN,REF,KSAT,RAS,RIW ! output @@ -5669,7 +5849,10 @@ SUBROUTINE SOILMOIST ( & R7=.5*DZS/DELT R4=R4+R7 FLX=FLX-SOILMOIS(1)*R7 - R8=UMVEG*R6 +! R8 is for direct evaporation from soil, which occurs +! only from snow-free areas +! R8=UMVEG*R6 + R8=UMVEG*R6*(1.-snowfrac) QTOT=QVATM+QCATM R9=TRANS R10=QTOT-QSG @@ -5740,8 +5923,9 @@ SUBROUTINE SOILMOIST ( & ENDIF ! RUNOFF2=RUNOFF2+hydro(nzs)*SOILMOIS(NZS) - MAVAIL=max(.00001,min(1.,SOILMOIS(1)/(REF-QMIN))) ! MAVAIL=max(.00001,min(1.,SOILMOIS(1)/DQM)) +! MAVAIL=max(.00001,min(1.,SOILMOIS(1)/(REF-QMIN))) + MAVAIL=max(.00001,min(1.,(SOILMOIS(1)/(REF-QMIN)*(1.-snowfrac)+1.*snowfrac))) ! RETURN ! END @@ -6054,9 +6238,9 @@ SUBROUTINE TRANSF( & ENDIF !-- uncomment next line for non-linear root distribution ! change made in Nov.2014 - TRANF(1)=part(1) +! TRANF(1)=part(1) ! linear root distribution -! TRANF(1)=TRANF(1)*FTEM + TRANF(1)=TRANF(1)*FTEM DO K=2,NROOT totliq=soiliqw(k)+qmin @@ -6433,10 +6617,19 @@ SUBROUTINE SOILVEGIN ( mosaic_lu,mosaic_soil,soilfrac,nscat, & ! 11oct2012 - seasonal correction on ZNT for crops and LAI for all veg. types ! factor = 1 with minimum greenness --> vegfrac = shdmin (cold season) - if((vegfrac - shdmin) .le. 0.) then +! if((vegfrac - shdmin) .le. 0.) then +! factor = 1. +! else +! factor = 1. - max(0.,min(1.,((vegfrac - shdmin)/(shdmax-shdmin)))) +! endif + +! 11oct2012 - seasonal correction on ZNT for crops and LAI for all veg. types +! factor = 1 with minimum greenness --> vegfrac = shdmin (cold season) +! SHDMAX, SHDMIN and VEGFRAC are in % here. + if((shdmax - shdmin) .lt. 1) then factor = 1. else - factor = 1. - max(0.,min(1.,((vegfrac - shdmin)/(shdmax-shdmin)))) + factor = 1. - max(0.,min(1.,(vegfrac - shdmin)/max(1.,(shdmax-shdmin)))) endif do k = 1,nlcat @@ -6896,6 +7089,13 @@ SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) READ (19,*)NATURAL READ (19,*) READ (19,*)CROP + READ (19,*) + READ (19,*,iostat=ierr)URBAN + if ( ierr /= 0 ) call wrf_message ( "-------- VEGPARM.TBL READ ERROR --------") + if ( ierr /= 0 ) call wrf_message ( "Problem read URBAN from VEGPARM.TBL") + if ( ierr /= 0 ) call wrf_message ( " -- Use updated version of VEGPARM.TBL ") + if ( ierr /= 0 ) call wrf_error_fatal ( "Problem read URBAN from VEGPARM.TBL") + ENDIF 2002 CONTINUE @@ -6932,9 +7132,10 @@ SUBROUTINE RUCLSM_SOILVEGPARM( MMINLURUC, MMINSL) CALL wrf_dm_bcast_real ( CMCMAX_DATA , 1 ) CALL wrf_dm_bcast_real ( CFACTR_DATA , 1 ) CALL wrf_dm_bcast_real ( RSMAX_DATA , 1 ) - CALL wrf_dm_bcast_integer ( BARE , 1 ) - CALL wrf_dm_bcast_integer ( NATURAL , 1 ) - CALL wrf_dm_bcast_integer ( CROP , 1 ) + CALL wrf_dm_bcast_integer ( BARE , 1 ) + CALL wrf_dm_bcast_integer ( NATURAL , 1 ) + CALL wrf_dm_bcast_integer ( CROP , 1 ) + CALL wrf_dm_bcast_integer ( URBAN , 1 ) ! !-----READ IN SOIL PROPERTIES FROM SOILPARM.TBL diff --git a/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F b/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F index 484df2b2..eacf433d 100644 --- a/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F +++ b/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F @@ -4,11 +4,11 @@ MODULE module_sf_sfcdiags_ruclsm CONTAINS - SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS,CHS2,CQS2,T2,TH2,Q2, & - T3D,QV3D,RHO3D,P3D, & - CP,R_d,ROVCP, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & + SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CQS,CQS2,CHS,CHS2,T2,TH2,Q2, & + T3D,QV3D,RHO3D,P3D,PSFC2D, & + CP,R_d,ROVCP, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !------------------------------------------------------------------- IMPLICIT NONE @@ -24,10 +24,12 @@ SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS,CHS2,CQS2,T2,TH2,Q2, & REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(INOUT) :: Q2, & TH2, & - T2 + T2 REAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(IN) :: & + PSFC2D, & CHS, & + CQS, & CHS2, & CQS2 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & @@ -48,17 +50,20 @@ SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS,CHS2,CQS2,T2,TH2,Q2, & DO J=jts,jte DO I=its,ite - RHO = RHO3D(i,kms,j) - PSFC = P3D(I,kms,J) + RHO = RHO3D(i,1,j) +! PSFC = P3D(I,kms,J) ! Assume that 2-m pressure also equal to PSFC -! P2m = PSFC(I,J)*EXP(-0.068283/t3d(i,1,j)) + PSFC = PSFC2D(I,J) +! P2m = PSFC2D(I,J)*EXP(-0.068283/t3d(i,1,j)) + if ( flux ) then !!! 2-m Temperature - T2 - if(CHS2(I,J).lt.1.E-5) then +! if(CHS2(I,J).lt.1.E-5) then ! may be to small treshold? -! if(CHS2(I,J).lt.3.E-3 .AND. HFX(I,J).lt.0.) then + if(CHS2(I,J).lt.3.E-3 .AND. HFX(I,J).lt.0.) then +! when stable - let 2-m temperature be equal the first atm. level temp. ! TH2(I,J) = TSK(I,J)*(1.E5/PSFC(I,J))**ROVCP - TH2(I,J) = t3d(i,kms,j)*(1.E5/PSFC)**ROVCP + TH2(I,J) = t3d(i,1,j)*(1.E5/PSFC)**ROVCP else TH2(I,J) = TSK(I,J)*(1.E5/PSFC)**ROVCP - HFX(I,J)/(RHO*CP*CHS2(I,J)) ! T2(I,J) = TSK(I,J) - HFX(I,J)/(RHO*CP*CHS2(I,J)) @@ -66,32 +71,35 @@ SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS,CHS2,CQS2,T2,TH2,Q2, & ! TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**ROVCP T2(I,J) = TH2(I,J)*(1.E-5*PSFC)**ROVCP ! check that T2 values lie in the range between TSK and T at the 1st level - x2m = MAX(MIN(tsk(i,j),t3d(i,kms,j)) , t2(i,j)) - t2(i,j) = MIN(MAX(tsk(i,j),t3d(i,kms,j)) , x2m) + x2m = MAX(MIN(tsk(i,j),t3d(i,1,j)) , t2(i,j)) + t2(i,j) = MIN(MAX(tsk(i,j),t3d(i,1,j)) , x2m) + else + T2(I,J) = tsk(i,j) - CHS(I,J)/CHS2(I,J)*(tsk(i,j) - t3d(i,1,j)) + endif ! flux method TH2(I,J) = T2(I,J)*(1.E5/PSFC)**ROVCP !!! 2-m Water vapor mixing ratio - Q2 - qlev1 = qv3d(i,kms,j) + qlev1 = qv3d(i,1,j) ! saturation check - tempc=t3d(i,kms,j)-273.15 + tempc=t3d(i,1,j)-273.15 if (tempc .le. 0.0) then ! over ice - qsat = rsif(p3d(i,kms,j), t3d(i,kms,j)) + qsat = rsif(p3d(i,1,j), t3d(i,1,j)) else - qsat = rslf(p3d(i,kms,j), t3d(i,kms,j)) + qsat = rslf(p3d(i,1,j), t3d(i,1,j)) endif !remove oversaturation at level 1 qlev1 = min(qsat, qlev1) -! Compute QSFC proxy from QFX, qlev1 and CHS +! Compute QSFC proxy from QFX, qlev1 and CQS ! Use of QSFCprox is more accurate diagnostics for densely vegetated areas, ! like cropland in summer - qsfcprox=qlev1+QFX(I,J)/(RHO*CHS(I,J)) + qsfcprox=qlev1+QFX(I,J)/(RHO*CQS(I,J)) qsfcmr = qsfc(i,j)/(1.-qsfc(i,j)) ! if(i.eq.426.and.j.eq.250) then -!! cropland point +!! RAP cropland point ! print *,'qsfc,qsfcmr,qsfcprox,qlev1',qsfc(i,j),qsfcmr,qsfcprox,qlev1 ! print *,'(qsfcprox-qsfcmr)/qsfcmr =', (qsfcprox-qsfcmr)/qsfcmr ! endif @@ -107,8 +115,8 @@ SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS,CHS2,CQS2,T2,TH2,Q2, & endif else ! QFX is not used - Q2(I,J) = qsfcmr - CHS(I,J)/CHS2(I,J)*(qsfcmr - qlev1) - endif + Q2(I,J) = qsfcmr - CQS(I,J)/CQS2(I,J)*(qsfcmr - qlev1) + endif ! flux ! Check that Q2 values lie between QSFCmr and qlev1 x2m = MAX(MIN(qsfcmr,qlev1) , q2(i,j)) diff --git a/wrfv2_fire/phys/module_sf_sfclayrev.F b/wrfv2_fire/phys/module_sf_sfclayrev.F index dd12722f..8ae60066 100644 --- a/wrfv2_fire/phys/module_sf_sfclayrev.F +++ b/wrfv2_fire/phys/module_sf_sfclayrev.F @@ -1089,6 +1089,8 @@ function zolri(ri,z,z0) ! ----------------------------------------------------------------------- ! function zolri2(zol2,ri2,z,z0) +! + if(zol2*ri2 .lt. 0.)zol2=0. ! limit zol2 - must be same sign as ri2 ! zol20=zol2*z0/z ! z0/L zol3=zol2+zol20 ! (z+z0)/L diff --git a/wrfv2_fire/phys/module_sf_ssib.F b/wrfv2_fire/phys/module_sf_ssib.F index acdc1cee..8e968b2f 100755 --- a/wrfv2_fire/phys/module_sf_ssib.F +++ b/wrfv2_fire/phys/module_sf_ssib.F @@ -4008,10 +4008,14 @@ SUBROUTINE RASIT5(TRIB,CTNI,CUNI,RA,Z2,Z0,D,ZZWIND,UMM1, & 310 CONTINUE ! CU=1./CUI - CT=1./CTI +! CT=1./CTI !Correction 3/8/16 USTAR =UM*CU RAF = CTI / USTAR - IF (RAF.LT.0.80) RAF = 0.80 + IF (RAF.LT.0.80) THEN + RAF = 0.80 + CTI = RAF*USTAR + ENDIF + CT = 1./CTI !Correction 3/8/16 ! RA = RAF ! diff --git a/wrfv2_fire/phys/module_sf_urban.F b/wrfv2_fire/phys/module_sf_urban.F index 772ee954..85177445 100644 --- a/wrfv2_fire/phys/module_sf_urban.F +++ b/wrfv2_fire/phys/module_sf_urban.F @@ -2403,6 +2403,10 @@ END SUBROUTINE urban_param_init SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, & ! in ims,ime,jms,jme,kms,kme,num_soil_layers, & ! in ! num_roof_layers,num_wall_layers,num_road_layers, & ! in +! num_roof_layers,num_wall_layers,num_road_layers, & !urban + LOW_DENSITY_RESIDENTIAL, & + HIGH_DENSITY_RESIDENTIAL, & + HIGH_INTENSITY_INDUSTRIAL, & restart,sf_urban_physics, & !in XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D, & ! inout TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D, & ! inout @@ -2433,6 +2437,7 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, IMPLICIT NONE INTEGER, INTENT(IN) :: ISURBAN, sf_urban_physics + INTEGER, INTENT(IN) :: LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL INTEGER, INTENT(IN) :: ims,ime,jms,jme,kms,kme,num_soil_layers INTEGER, INTENT(IN) :: num_urban_layers !multi-layer urban INTEGER, INTENT(IN) :: num_urban_hi !multi-layer urban @@ -2585,8 +2590,8 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, SWITCH_URB=1 ENDIF - IF( IVGTYP(I,J) == 31) THEN - UTYPE_URB2D(I,J) = 3 ! low-intensity residential + IF( IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL) THEN + UTYPE_URB2D(I,J) = 1 ! low-intensity residential UTYPE_URB = UTYPE_URB2D(I,J) ! low-intensity residential IF (HGT_URB2D(I,J)>0.) THEN CONTINUE @@ -2620,7 +2625,7 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, SWITCH_URB=1 ENDIF - IF( IVGTYP(I,J) == 32) THEN + IF( IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL) THEN UTYPE_URB2D(I,J) = 2 ! high-intensity UTYPE_URB = UTYPE_URB2D(I,J) ! high-intensity IF (HGT_URB2D(I,J)>0.) THEN @@ -2655,8 +2660,8 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, SWITCH_URB=1 ENDIF - IF( IVGTYP(I,J) == 33) THEN - UTYPE_URB2D(I,J) = 1 ! Commercial/Industrial/Transportation + IF( IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN + UTYPE_URB2D(I,J) = 3 ! Commercial/Industrial/Transportation UTYPE_URB = UTYPE_URB2D(I,J) ! Commercial/Industrial/Transportation IF (HGT_URB2D(I,J)>0.) THEN CONTINUE @@ -2720,6 +2725,7 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, XXXG_URB2D(I,J)=0. XXXC_URB2D(I,J)=0. + IF ( sf_urban_physics == 1 ) THEN DRELR_URB2D(I,J) = 0. DRELB_URB2D(I,J) = 0. DRELG_URB2D(I,J) = 0. @@ -2727,8 +2733,9 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, FLXHUMB_URB2D(I,J) = 0. FLXHUMG_URB2D(I,J) = 0. CMCR_URB2D(I,J) = 0. - TGR_URB2D(I,J)=TSURFACE0_URB(I,J)+0. + ENDIF + TC_URB2D(I,J)=TSURFACE0_URB(I,J)+0. TR_URB2D(I,J)=TSURFACE0_URB(I,J)+0. TB_URB2D(I,J)=TSURFACE0_URB(I,J)+0. @@ -2736,7 +2743,7 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, ! TS_URB2D(I,J)=TSURFACE0_URB(I,J)+0. -! DO K=1,num_roof_layers +! DO K=1,num_roof_layers ! DO K=1,num_soil_layers ! TRL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0. ! TRL_URB3D(I,2,J)=TLAYER0_URB(I,2,J)+0. @@ -2748,6 +2755,7 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, TRL_URB3D(I,3,J)=TLAYER0_URB(I,2,J)+0. TRL_URB3D(I,4,J)=TLAYER0_URB(I,2,J)+(TLAYER0_URB(I,3,J)-TLAYER0_URB(I,2,J))*0.29 + IF ( sf_urban_physics == 1 ) THEN TGRL_URB3D(I,1,J)=TLAYER0_URB(I,1,J)+0. TGRL_URB3D(I,2,J)=0.5*(TLAYER0_URB(I,1,J)+TLAYER0_URB(I,2,J)) TGRL_URB3D(I,3,J)=TLAYER0_URB(I,2,J)+0. @@ -2757,6 +2765,7 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, SMR_URB3D(I,2,J)=0.2 SMR_URB3D(I,3,J)=0.2 SMR_URB3D(I,4,J)=0. + ENDIF ! END DO ! DO K=1,num_wall_layers @@ -2906,9 +2915,6 @@ SUBROUTINE urban_var_init(ISURBAN, TSURFACE0_URB,TLAYER0_URB,TDEEP0_URB,IVGTYP, END IF END IF - - - END DO END DO RETURN diff --git a/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F b/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F index f4658142..c9e6d5a6 100644 --- a/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F +++ b/wrfv2_fire/phys/module_shcu_camuwshcu_driver.F @@ -416,19 +416,19 @@ SUBROUTINE camuwshcu_driver( & rushten(i,k,j) = utnd(1,kflip) rvshten(i,k,j) = vtnd(1,kflip) rthshten(i,k,j) = (stnd(1,kflip)+qsten_det(1,kflip))/cpair/pi_phy(i,k,j) - rqvshten(i,k,j) = qhtnd(1,kflip)/(1. - qv(i,k,j)) + rqvshten(i,k,j) = qhtnd(1,kflip)*(1. + qv(i,k,j))**2 if( p_qc >= param_first_scalar ) & - rqcshten(i,k,j) = (qctnd(1,kflip)+qcten_det(1,kflip))/(1. - qv(i,k,j)) + rqcshten(i,k,j) = (qctnd(1,kflip)+qcten_det(1,kflip))*(1. + qv(i,k,j)) if( p_qi >= param_first_scalar ) & - rqishten(i,k,j) = (qitnd(1,kflip)+qiten_det(1,kflip))/(1. - qv(i,k,j)) + rqishten(i,k,j) = (qitnd(1,kflip)+qiten_det(1,kflip))*(1. + qv(i,k,j)) if( p_qnc >= param_first_scalar ) then call cnst_get_ind( 'NUMLIQ', m ) - rqcnshten(i,k,j) = (tnd_tracer(1,kflip,m)+qcnten_det(1,kflip))/(1. - qv(i,k,j)) + rqcnshten(i,k,j) = (tnd_tracer(1,kflip,m)+qcnten_det(1,kflip))*(1. + qv(i,k,j)) endif if( p_qni >= param_first_scalar ) then call cnst_get_ind( 'NUMICE', m ) - rqinshten(i,k,j) = (tnd_tracer(1,kflip,m)+qinten_det(1,kflip))/(1. - qv(i,k,j)) + rqinshten(i,k,j) = (tnd_tracer(1,kflip,m)+qinten_det(1,kflip))*(1. + qv(i,k,j)) endif end do !k-loop to kte !PMA< diff --git a/wrfv2_fire/phys/module_surface_driver.F b/wrfv2_fire/phys/module_surface_driver.F index 8c246753..042d3763 100644 --- a/wrfv2_fire/phys/module_surface_driver.F +++ b/wrfv2_fire/phys/module_surface_driver.F @@ -19,6 +19,9 @@ SUBROUTINE surface_driver( & & ,num_soil_layers,p8w,pblh,pi_phy,pshltr,fm,fhh,psih & #if (NMM_CORE==1) & ,psim,p_phy,q10,q2,qfx,taux,tauy,qsfc,qshltr,qz0 & + & ,icoef_sf,lcurr_sf & !for gfdl-sf drag + & ,pert_Cd, ens_random_seed, ens_Cdamp & + & ,cd_out,ch_out & #else & ,psim,p_phy,q10,q2,qfx,qsfc,qshltr,qz0 & #endif @@ -27,8 +30,8 @@ SUBROUTINE surface_driver( & & ,smcrel & & ,th10,th2,thz0,th_phy,tmn,tshltr,tsk,tslb & & ,tyr,tyra,tdly,tlag,lagday,nyear,nday,tmn_update,yr & - & ,t_phy,u10,udrunoff,ust,uz0,u_frame,u_phy,v10,vegfra & - & ,uoce,voce & + & ,t_phy,u10,udrunoff,ust,uz0 & + & ,u_frame,u_phy,v10,vegfra,uoce,voce & & ,vz0,v_frame,v_phy,warm_rain,wspd,xice,xland,z,znt & & ,max_edom,cplmask & #if (HWRF==1) @@ -51,11 +54,13 @@ SUBROUTINE surface_driver( & & ,pxlsm_smois_init, pxlsm_soil_nudge & ! PX-LSM & ,idveg ,iopt_crs ,iopt_btr ,iopt_run ,iopt_sfc ,iopt_frz & & ,iopt_inf ,iopt_rad ,iopt_alb ,iopt_snf ,iopt_tbot ,iopt_stc & + & ,iopt_gla ,iopt_rsf & & ,isnowxy ,tvxy ,tgxy ,canicexy ,canliqxy ,eahxy & & ,tahxy ,cmxy ,chxy ,fwetxy ,sneqvoxy ,alboldxy & & ,qsnowxy ,wslakexy ,zwtxy ,waxy ,wtxy ,tsnoxy & & ,zsnsoxy ,snicexy ,snliqxy ,lfmassxy ,rtmassxy ,stmassxy & & ,woodxy ,stblcpxy ,fastcpxy ,xsaixy ,taussxy & + & ,grainxy ,gddxy & & ,t2mvxy ,t2mbxy ,q2mvxy ,q2mbxy & & ,tradxy ,neexy ,gppxy ,nppxy ,fvegxy ,runsfxy & & ,runsbxy ,ecanxy ,edirxy ,etranxy ,fsaxy ,firaxy & @@ -68,10 +73,12 @@ SUBROUTINE surface_driver( & & ,smcwtdxy ,rechxy ,deeprechxy,fdepthxy,areaxy ,rivercondxy, riverbedxy & & ,eqzwt ,pexpxy ,qrfxy ,qspringxy,qslatxy ,qrfsxy ,qspringsxy & & ,smoiseq ,wtddt ,stepwtd & + & ,opt_thcnd & ! Noah UA changes & ,ua_phys,flx4,fvb,fbur,fgsn & #if (EM_CORE==1) & ,ch,tsq,qsq,cov,Sh3d,el_pbl,bl_mynn_cloudpdf & ! MYNN + & ,icloud_bl,qc_bl,cldfra_bl & ! MYNN & ,fgdp,dfgdp,vdfg,grav_settling & ! Katata - fog dep #endif & ,lakedepth2d, savedtke12d, snowdp2d, h2osno2d & !lake @@ -218,6 +225,7 @@ SUBROUTINE surface_driver( & ! Optional ocean model & ,sf_ocean_physics,oml_hml0,oml_gamma & & ,tml,t0ml,hml,h0ml,huml,hvml,f,tmoml & + & ,oml_relaxation_time & & ,ustm,ck,cka,cd,cda,isftcflx,iz0tlnd & & ,isurban, mminlu & & ,snotime & @@ -262,8 +270,9 @@ SUBROUTINE surface_driver( & & ,TS_URB2D_mosaic & !danli mosaic & ,TS_RUL2D_mosaic & !danli mosaic & ,ZOL & !ckay + & ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas & !fasdas & ) - + #if ( ! NMM_CORE == 1 ) USE module_state_description, ONLY : SFCLAYSCHEME & ,SFCLAYREVSCHEME & @@ -311,6 +320,7 @@ SUBROUTINE surface_driver( & USE module_sf_qnsesfc USE module_sf_gfs USE module_sf_noahdrv ! danli mosaic, the " ,only : lsm " needs to be deleted + USE module_sf_noahlsm, only : LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL USE module_sf_noahmpdrv, only : noahmplsm USE module_sf_noahmp_groundwater USE module_sf_noah_seaice_drv @@ -483,6 +493,7 @@ SUBROUTINE surface_driver( & !-- sf_ocean_physics whether to call ocean model from slab (1 = oml, 2=3d PWP) !-- oml_hml0 initial mixed layer depth (if real-data not available, default 50 m) !-- oml_gamma lapse rate below mixed layer in ocean (default 0.14 K m-1) +!-- oml_relaxation_time time the oml will take to get back to its original state (seconds) !-- ck enthalpy exchange coeff at 10 meters !-- cd momentum exchange coeff at 10 meters !-- cka enthalpy exchange coeff at the lowest model level @@ -593,6 +604,11 @@ SUBROUTINE surface_driver( & #if (NMM_CORE==1) real , intent(IN ):: SFENTH + INTEGER, INTENT(IN):: ICOEF_SF + LOGICAL, INTENT(IN):: LCURR_SF + logical,intent(in),optional :: pert_Cd + integer,intent(in),optional :: ens_random_seed + real,intent(in),optional :: ens_Cdamp #endif REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT):: SMOIS REAL, DIMENSION( ims:ime , 1:num_soil_layers, jms:jme ), INTENT(INOUT):: TSLB @@ -639,6 +655,8 @@ SUBROUTINE surface_driver( & #if (NMM_CORE==1) REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT):: TAUX REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT):: TAUY + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT):: cd_out + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT):: ch_out #endif REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: QSFC REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: QZ0 @@ -807,7 +825,8 @@ SUBROUTINE surface_driver( & ! NoahMP specific fields INTEGER, OPTIONAL, INTENT(IN) :: idveg, iopt_crs, iopt_btr, iopt_run, iopt_sfc , iopt_frz, & - iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, iopt_stc + iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, iopt_stc, & + iopt_gla, iopt_rsf INTEGER, OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: ISNOWXY REAL, OPTIONAL, DIMENSION(ims:ime ,-2:num_soil_layers, jms:jme), INTENT(INOUT) :: ZSNSOXY @@ -815,6 +834,7 @@ SUBROUTINE surface_driver( & REAL, OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: & TVXY, TGXY,CANICEXY,CANLIQXY, EAHXY, TAHXY, CMXY, CHXY, FWETXY,SNEQVOXY,ALBOLDXY, & QSNOWXY,WSLAKEXY, ZWTXY, WAXY, WTXY,LFMASSXY,RTMASSXY,STMASSXY, WOODXY,STBLCPXY,FASTCPXY, & + GRAINXY, GDDXY, & XSAIXY, TAUSSXY, T2MVXY, T2MBXY, Q2MVXY, Q2MBXY, TRADXY, NEEXY, GPPXY, & NPPXY, FVEGXY, RUNSFXY, RUNSBXY, ECANXY, EDIRXY, ETRANXY, FSAXY, FIRAXY, APARXY, PSNXY, & SAVXY, SAGXY, RSSUNXY, RSSHAXY, BGAPXY, WGAPXY, TGVXY, TGBXY, CHVXY, CHBXY, SHGXY, & @@ -830,6 +850,7 @@ SUBROUTINE surface_driver( & SMCWTDXY, RECHXY, DEEPRECHXY, FDEPTHXY, AREAXY, RIVERCONDXY, RIVERBEDXY, & EQZWT, PEXPXY, QRFXY, QSPRINGXY, QSLATXY, QRFSXY, QSPRINGSXY + INTEGER, INTENT(IN ):: OPT_THCND ! Noah UA changes LOGICAL, INTENT(IN) :: ua_phys REAL, DIMENSION(ims:ime , jms:jme), INTENT(OUT) :: flx4,fvb,fbur,fgsn @@ -895,14 +916,15 @@ SUBROUTINE surface_driver( & REAL, DIMENSION( ims:ime , jms:jme ), & &OPTIONAL, INTENT(INOUT ):: ch -!Katata-added - extra in-output - REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT):: fgdp,dfgdp,vdfg - INTEGER, OPTIONAL, INTENT(IN) :: grav_settling +!Katata-added - extra in-output + REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL, INTENT(INOUT):: fgdp,dfgdp,vdfg + INTEGER, OPTIONAL, INTENT(IN) :: grav_settling !Katata-end REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & - &OPTIONAL, INTENT(IN ):: tsq,qsq,cov,Sh3d,el_pbl - INTEGER, OPTIONAL, INTENT(IN) :: bl_mynn_cloudpdf + &OPTIONAL, INTENT(IN ):: tsq,qsq,cov,Sh3d,el_pbl,qc_bl,cldfra_bl + INTEGER, OPTIONAL, INTENT(IN) :: bl_mynn_cloudpdf, & + icloud_bl #endif @@ -916,6 +938,7 @@ SUBROUTINE surface_driver( & INTEGER, OPTIONAL, INTENT(IN ):: SF_OCEAN_PHYSICS REAL , OPTIONAL, INTENT(IN ):: OML_HML0 REAL , OPTIONAL, INTENT(IN ):: OML_GAMMA + REAL , OPTIONAL, INTENT(IN ):: OML_RELAXATION_TIME ! ! Observation nudging ! @@ -1087,9 +1110,11 @@ SUBROUTINE surface_driver( & REAL, DIMENSION( ims:ime, jms:jme ) :: & QGH, & CHS, & + CQS, & CPM, & CHS2, & CQS2 + ! SSIB local variables REAL ZDIFF REAL, DIMENSION( ims:ime , jms:jme ) :: XICE_save @@ -1284,6 +1309,13 @@ SUBROUTINE surface_driver( & LOGICAL :: run_param , doing_adapt_dt , decided LOGICAL :: do_adapt ! +! FASDAS +! + REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT), OPTIONAL :: SDA_HFX,SDA_QFX,HFX_BOTH, QFX_BOTH, QNORM + INTEGER, INTENT(IN ) :: fasdas +! local vars + REAL, DIMENSION( ims:ime, jms:jme ) :: HFXOLD, QFXOLD + REAL :: HFX_KAY, QFX_KAY ! !------------------------------------------------------------------ ! Initialize local variables @@ -1354,6 +1386,10 @@ SUBROUTINE surface_driver( & CHS(i,j) = 0. CPM(i,j) = 0. CHS2(i,j) = 0. +#if (NMM_CORE==1) + Cd_out(i,j) = 0. + Ch_out(i,j) = 0. +#endif ENDDO ENDDO ENDDO @@ -1915,7 +1951,7 @@ SUBROUTINE surface_driver( & xland,hfx,qfx,lh,tsk,flhc,flqc,qgh,qsfc,rmol, & u10,v10, & gz1oz0,wspd,br,isfflx,dx, & - svp1,svp2,svp3,svpt0,ep_1,ep_2,karman, & + svp1,svp2,svp3,svpt0,ep_1,ep_2,karman,itimestep, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) @@ -2126,6 +2162,7 @@ SUBROUTINE surface_driver( & svp1,svp2,svp3,svpt0,ep_1,ep_2,karman, & &itimestep,ch,th_phy,pi_phy,qc_curr,rho, & &tsq,qsq,cov,Sh3d,el_pbl,qcg, & + &icloud_bl,qc_bl,cldfra_bl, & XICE,SST,TSK_SEA, & CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA,& HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & @@ -2144,6 +2181,7 @@ SUBROUTINE surface_driver( & svp1,svp2,svp3,svpt0,ep_1,ep_2,karman, & &itimestep,ch,th_phy,pi_phy,qc_curr,rho, & &tsq,qsq,cov,Sh3D,el_pbl,qcg, & + &icloud_bl,qc_bl,cldfra_bl, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij),j_start(ij),j_end(ij),kts,kte,& @@ -2232,8 +2270,11 @@ SUBROUTINE surface_driver( & UST,PSIM,PSIH, & XLAND,HFX,QFX,TAUX,TAUY,LH,GSW,GLW,TSK,FLHC,FLQC, & ! gopal's doing for Ocean coupling QGH,QSFC,U10,V10, & + ICOEF_SF, LCURR_SF, & + pert_Cd, ens_random_seed, ens_Cdamp, & GZ1OZ0,WSPD,BR,ISFFLX, & EP_1,EP_2,KARMAN,GFDL_NTSFLG,SFENTH, & + cd_out, ch_out, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij),j_start(ij),j_end(ij),kts,kte ) @@ -2459,7 +2500,7 @@ SUBROUTINE surface_driver( & xice_threshold, & rdlai2d,usemonalb, & br, & !? - NOAHRES, & + NOAHRES,opt_thcnd, & NLCAT,landusef,landusef2, & ! danli mosaic sf_surface_mosaic,mosaic_cat,mosaic_cat_index, & ! danli mosaic TSK_mosaic,QSFC_mosaic, & ! danli mosaic @@ -2523,7 +2564,9 @@ SUBROUTINE surface_driver( & a_e_bep,b_u_bep,b_v_bep, & !O multi-layer urban b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban dl_u_bep,sf_bep,vl_bep & !O multi-layer urban - ,sfcheadrt,INFXSRT, soldrain) + ,sfcheadrt,INFXSRT, soldrain & !hydro + ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas & ! fasdas + ) ELSE CALL wrf_error_fatal('Lack arguments to call lsm_mosaic') @@ -2531,6 +2574,36 @@ SUBROUTINE surface_driver( & ELSEIF (sf_surface_mosaic == 0) THEN +! +! FASDAS +! + IF( fasdas == 1 ) THEN + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + +!ckay2015 only do indirect nudging over land areas + IF(XLAND(i,j) .GT. 1.5) then + SDA_QFX(I,J) = 0.0 + SDA_HFX(I,J) = 0.0 + END IF + +! TWG2015 Removed lines that update fluxes to ensure this section only defines +! the output + QFXOLD(I,J)=QFX(I,J) + QFX_KAY = SDA_QFX(I,J)*RHO(I,1,J)*DZ8W(I,1,J) + QFX_KAY = QFX_KAY * QNORM(I,J) + QFX_BOTH(I,J)=QFX(I,J)+QFX_KAY + + HFXOLD(I,J)=HFX(I,J) + HFX_KAY = SDA_HFX(I,J)*RHO(I,1,J)*CPM(I,J)*DZ8W(I,1,J) + HFX_BOTH(I,J)=HFX(I,J)+HFX_KAY + + ENDDO + ENDDO + END IF +! +! END FASDAS +! CALL lsm(dz8w,qv_curr,p8w,t_phy,tsk, & hfx,qfx,lh,grdflx,qgh,gsw,swdown,glw,smstav,smstot, & sfcrunoff,udrunoff,ivgtyp,isltyp,isurban,isice,vegfra, & @@ -2552,7 +2625,7 @@ SUBROUTINE surface_driver( & xice_threshold, & rdlai2d,usemonalb, & br, & !? - NOAHRES, & + NOAHRES,opt_thcnd, & ua_phys,flx4,fvb,fbur,fgsn, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -2596,8 +2669,15 @@ SUBROUTINE surface_driver( & a_e_bep,b_u_bep,b_v_bep, & !O multi-layer urban b_t_bep,b_q_bep,b_e_bep,dlg_bep, & !O multi-layer urban dl_u_bep,sf_bep,vl_bep & !O multi-layer urban - ,sfcheadrt,INFXSRT, soldrain) - + ,sfcheadrt,INFXSRT, soldrain & +! +! FASDAS +! + ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas & +! +! END FASDAS +! + ) ENDIF call seaice_noah( SEAICE_ALBEDO_OPT, SEAICE_ALBEDO_DEFAULT, SEAICE_THICKNESS_OPT, & @@ -2686,8 +2766,10 @@ SUBROUTINE surface_driver( & IF(SF_URBAN_PHYSICS.eq.1) THEN DO j=j_start(ij),j_end(ij) !urban DO i=i_start(ij),i_end(ij) !urban - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & !urban - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN !urban + IF( IVGTYP(I,J) == ISURBAN .or. & + IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & !urban + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or.& + IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN !urban U10(I,J) = U10_URB2D(I,J) !urban V10(I,J) = V10_URB2D(I,J) !urban PSIM(I,J) = PSIM_URB2D(I,J) !urban @@ -2704,8 +2786,10 @@ SUBROUTINE surface_driver( & IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN DO j=j_start(ij),j_end(ij) !urban DO i=i_start(ij),i_end(ij) !urban - IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == 31 .or. & !urban - IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN !urban + IF( IVGTYP(I,J) == ISURBAN .or. & + IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. & !urban + IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. & + IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL) THEN !urban T2(I,J) = TH_PHY(i,1,j)/((1.E5/PSFC(I,J))**RCP) !urban TH2(I,J) = TH_PHY(i,1,j) !urban Q2(I,J) = qv_curr(i,1,j) !urban @@ -2810,7 +2894,7 @@ SUBROUTINE surface_driver( & XLAND, XICE, XICE_THRESHOLD, & IDVEG, IOPT_CRS, IOPT_BTR, IOPT_RUN, IOPT_SFC, IOPT_FRZ, & IOPT_INF, IOPT_RAD, IOPT_ALB, IOPT_SNF, IOPT_TBOT, IOPT_STC, & - IZ0TLND, & + IOPT_GLA, IOPT_RSF, IZ0TLND, & T_PHY, QV_CURR, U_PHY, V_PHY, SWDOWN, GLW, & P8W, RAINBL, SR, & TSK, HFX, QFX, LH, GRDFLX, SMSTAV, & @@ -2823,7 +2907,7 @@ SUBROUTINE surface_driver( & QSNOWXY, WSLAKEXY, ZWTXY, WAXY, WTXY, TSNOXY, & ZSNSOXY, SNICEXY, SNLIQXY, LFMASSXY, RTMASSXY, STMASSXY, & WOODXY, STBLCPXY, FASTCPXY, LAI, XSAIXY, TAUSSXY, & - SMOISEQ, SMCWTDXY,DEEPRECHXY, RECHXY, & ! IN/OUT Noah MP only + SMOISEQ, SMCWTDXY,DEEPRECHXY, RECHXY, GRAINXY, GDDXY, & ! IN/OUT Noah MP only T2MVXY, T2MBXY, Q2MVXY, Q2MBXY, & TRADXY, NEEXY, GPPXY, NPPXY, FVEGXY, RUNSFXY, & RUNSBXY, ECANXY, EDIRXY, ETRANXY, FSAXY, FIRAXY, & @@ -3118,13 +3202,20 @@ SUBROUTINE surface_driver( & endif ENDIF - CALL SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CHS,CHS2,CQS2,T2,TH2,Q2, & - T_PHY,QV_CURR,RHO,P_PHY, & - CP,R_d,RCP, & - ids,ide, jds,jde, kds,kde, & - ims,ime, jms,jme, kms,kme, & - i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) +! Compute CHS and CQS that will be used in 2-m diagnostics + DO j=j_start(ij),j_end(ij) + DO i=i_start(ij),i_end(ij) + cqs(i,j)=flqc(i,j)/(mavail(i,j)*rho(i,kts,j)) + chs(i,j)=flhc(i,j)/(cpm(i,j)*rho(i,kts,j) ) + ENDDO + ENDDO + CALL SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CQS,CQS2,CHS,CHS2,T2,TH2,Q2, & + T_PHY,QV_CURR,RHO,P_PHY,PSFC, & + CP,R_d,RCP, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte ) ELSE CALL wrf_error_fatal('Lacking arguments for RUCLSM in surface driver') @@ -3164,7 +3255,7 @@ SUBROUTINE surface_driver( & psfc, gsw, glw, rainbl, emiss, & ITIMESTEP, curr_secs, num_soil_layers, DT, & anal_interval, xland, xice, albbck, albedo, & - snoalb, smois, tslb, mavail,T2, Q2, & + snoalb, smois, tslb, mavail,T2, Q2, qsfc, & zs, dzs, psih, & landusef,soilctop,soilcbot,vegfra, vegf_px, & isltyp,ra,rs,lai,imperv,canfra,nlcat,nscat, & @@ -3696,7 +3787,7 @@ SUBROUTINE surface_driver( & CALL ocean_driver(tml,t0ml,hml,h0ml,huml,hvml,ust,u_phy,v_phy, & tmoml,f,g,oml_gamma, & xland,hfx,lh,tsk,gsw,glw,emiss, & - dtbl,STBOLT, & + dtbl,STBOLT,oml_relaxation_time, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte, & @@ -4526,6 +4617,7 @@ SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & &itimestep,ch,th3d,pi3d,qc3d,rho, & &tsq,qsq,cov,Sh3d,el_pbl,qcg, & + &icloud_bl,qc_bl,cldfra_bl, & XICE,SST,TSK_SEA, & CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA, & HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA, & @@ -4542,7 +4634,7 @@ SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte - INTEGER, INTENT(IN ) :: ISFFLX,bl_mynn_cloudpdf + INTEGER, INTENT(IN ) :: ISFFLX,bl_mynn_cloudpdf,icloud_bl REAL, INTENT(IN ) :: SVP1,SVP2,SVP3,SVPT0 REAL, INTENT(IN ) :: EP1,EP2,KARMAN @@ -4607,7 +4699,8 @@ SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & REAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: ch REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) :: & &QC3D,& - &th3d,pi3d,tsq,qsq,cov,Sh3d,el_pbl + &th3d,pi3d,tsq,qsq,cov,Sh3d,el_pbl,& + &qc_bl,cldfra_bl REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ) , & INTENT(OUT) :: ck,cka,cd,cda @@ -4780,6 +4873,7 @@ SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & &itimestep,ch,th3d,pi3d,qc3d,rho, & &tsq,qsq,cov,sh3d,el_pbl,qcg, & + &icloud_bl,qc_bl,cldfra_bl, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -4866,6 +4960,7 @@ SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w, & SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & &itimestep,CH_SEA,th3d,pi3d,qc3d,rho, & &tsq,qsq,cov,sh3d,el_pbl,qcg, & + &icloud_bl,qc_bl,cldfra_bl, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte, & @@ -6213,7 +6308,7 @@ SUBROUTINE pxsfclay_seaice_wrapper(U3D,V3D,T3D,TH3D,QV3D,P3D,dz8w, & XLAND,HFX,QFX,LH,TSK_LOCAL,FLHC,FLQC,QGH,QSFC,RMOL, & U10,V10, & GZ1OZ0,WSPD,BR,ISFFLX,DX, & - SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & + SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,ITIMESTEP,& ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -6271,7 +6366,7 @@ SUBROUTINE pxsfclay_seaice_wrapper(U3D,V3D,T3D,TH3D,QV3D,P3D,dz8w, & XLAND_SEA,HFX_SEA,QFX_SEA,LH_SEA,TSK_SEA,FLHC_SEA,FLQC_SEA,QGH_SEA,QSFC_SEA,RMOL_SEA, & U10_SEA,V10_SEA, & GZ1OZ0_SEA,WSPD_SEA,BR_SEA,ISFFLX,DX, & - SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN, & + SVP1,SVP2,SVP3,SVPT0,EP1,EP2,KARMAN,ITIMESTEP,& ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) @@ -6491,6 +6586,9 @@ SUBROUTINE get_local_ice_tsk ( ims, ime, jms, jme, & ! Local INTEGER :: i,j + REAL :: TICE_MIN + + TICE_MIN = 221.4 DO j = JTS , JTE DO i = ITS , ITE @@ -6525,6 +6623,7 @@ SUBROUTINE get_local_ice_tsk ( ims, ime, jms, jme, & TSK_ICE(i,j) = MIN( TSK(i,j), 273.15 ) ELSE TSK_ICE(i,j) = ( TSK(i,j) - (1.0-XICE(i,j)) * SST(i,j) ) / XICE(i,j) + IF ( TSK_ICE(i,j) < TICE_MIN ) TSK_ICE(i,j) = TICE_MIN ENDIF IF ( ( XICE(i,j) < 0.2 ) .AND. ( TSK(i,j) < 253.15 ) ) THEN diff --git a/wrfv2_fire/run/MPTABLE.TBL b/wrfv2_fire/run/MPTABLE.TBL index d225d1f2..54760dfe 100644 --- a/wrfv2_fire/run/MPTABLE.TBL +++ b/wrfv2_fire/run/MPTABLE.TBL @@ -1,8 +1,8 @@ -&noah_mp_usgs_veg_categories +&noahmp_usgs_veg_categories VEG_DATASET_DESCRIPTION = "USGS" NVEG = 27 / -&noah_mp_usgs_parameters +&noahmp_usgs_parameters ! NVEG = 27 ! 1: Urban and Built-Up Land ! 2: Dryland Cropland and Pasture @@ -32,11 +32,14 @@ ! 26: Lava ! 27: White Sand - ISURBAN = 1 - ISWATER = 16 - ISBARREN = 19 - ISICE = 24 - EBLFOREST = 13 + ISURBAN = 1 + ISWATER = 16 + ISBARREN = 19 + ISICE = 24 + EBLFOREST = 13 + LOW_DENSITY_RESIDENTIAL = 31 + HIGH_DENSITY_RESIDENTIAL = 32 + HIGH_INTENSITY_INDUSTRIAL = 33 !--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 @@ -144,12 +147,12 @@ EPS5 = 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, / -&noah_mp_modis_veg_categories +&noahmp_modis_veg_categories VEG_DATASET_DESCRIPTION = "modified igbp modis noah" NVEG = 20 / -&noah_mp_modis_parameters +&noahmp_modis_parameters ! 1 'Evergreen Needleleaf Forest' -> USGS 14 ! 2, 'Evergreen Broadleaf Forest' -> USGS 13 ! 3, 'Deciduous Needleleaf Forest' -> USGS 12 @@ -171,11 +174,14 @@ ! 19, 'Mixed Tundra' -> USGS 22 ! 20, 'Barren Tundra' -> USGS 23 - ISURBAN = 13 - ISWATER = 17 - ISBARREN = 16 - ISICE = 15 - EBLFOREST = 2 + ISURBAN = 13 + ISWATER = 17 + ISBARREN = 16 + ISICE = 15 + EBLFOREST = 2 + LOW_DENSITY_RESIDENTIAL = 31 + HIGH_DENSITY_RESIDENTIAL = 32 + HIGH_INTENSITY_INDUSTRIAL = 33 !--------------------------------------------------------------------------------------------------------------------------------------------------------------------- ! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 @@ -284,7 +290,7 @@ / -&noah_mp_rad_parameters +&noahmp_rad_parameters !------------------------------------------------------------------------------ ! 1 2 3 4 5 6 7 8 soil color index for soil albedo !------------------------------------------------------------------------------ @@ -300,3 +306,160 @@ EG = 0.97, 0.98 ! emissivity soil surface 1-soil;2-lake / + +&noahmp_global_parameters + +! atmospheric constituants + + CO2 = 395.e-06 !co2 partial pressure + O2 = 0.209 !o2 partial pressure + +! runoff parameters used for SIMTOP and SIMGM: + + TIMEAN = 10.5 !gridcell mean topgraphic index (global mean) + FSATMX = 0.38 !maximum surface saturated fraction (global mean) + +! adjustable parameters for snow processes + + Z0SNO = 0.002 !snow surface roughness length (m) (0.002) + SSI = 0.03 !liquid water holding capacity for snowpack (m3/m3) (0.03) + SWEMX = 1.00 !new snow mass to fully cover old snow (mm) + !equivalent to 10mm depth (density = 100 kg/m3) + RSURF_SNOW = 50.0 !surface resistence for snow [s/m] + +/ + +&noahmp_crop_parameters + + ! NCROP = 5 + ! 1: Corn + ! 2: Soybean + ! 3: Sorghum + ! 4: Rice + ! 5: Winter wheat + +!---------------------------------------------------------- +! 1 2 3 4 5 +!---------------------------------------------------------- + +PLTDAY = 130, 111, 111, 111, 111, ! Planting date +HSDAY = 280, 300, 300, 300, 300, ! Harvest date +PLANTPOP = 78.0, 78.0, 78.0, 78.0, 78.0, ! Plant density [per ha] - used? +IRRI = 0.0, 0.0, 0.0, 0.0, 0.0, ! Irrigation strategy 0= non-irrigation 1=irrigation (no water-stress) + +GDDTBASE = 10.0, 10.0, 10.0, 10.0, 10.0, ! Base temperature for GDD accumulation [C] +GDDTCUT = 30.0, 30.0, 30.0, 30.0, 30.0, ! Upper temperature for GDD accumulation [C] +GDDS1 = 60.0, 50.0, 50.0, 50.0, 50.0, ! GDD from seeding to emergence +GDDS2 = 675.0, 718.0, 718.0, 718.0, 718.0, ! GDD from seeding to initial vegetative +GDDS3 = 1183.0, 933.0, 933.0, 933.0, 933.0, ! GDD from seeding to post vegetative +GDDS4 = 1253.0, 1103.0, 1103.0, 1103.0, 1103.0, ! GDD from seeding to intial reproductive +GDDS5 = 1605.0, 1555.0, 1555.0, 1555.0, 1555.0, ! GDD from seeding to pysical maturity + +C3C4 = 2.0, 1.0, 2.0, 2.0, 2.0, ! photosynthetic pathway: 1. = c3 2. = c4 +Aref = 7.0, 7.0, 7.0, 7.0, 7.0, ! reference maximum CO2 assimulation rate +PSNRF = 0.85, 0.85, 0.85, 0.85, 0.85, ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds) +I2PAR = 0.5, 0.5, 0.5, 0.5, 0.5, ! Fraction of incoming solar radiation to photosynthetically active radiation +TASSIM0 = 8.0, 8.0, 8.0, 8.0, 8.0, ! Minimum temperature for CO2 assimulation [C] +TASSIM1 = 18.0, 18.0, 18.0, 18.0, 18.0, ! CO2 assimulation linearly increasing until temperature reaches T1 [C] +TASSIM2 = 30.0, 30.0, 30.0, 30.0, 30.0, ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C] +K = 0.55, 0.55, 0.55, 0.55, 0.55, ! light extinction coefficient +EPSI = 12.5, 12.5, 12.5, 12.5, 12.5, ! initial light use efficiency + +Q10MR = 2.0, 2.0, 2.0, 2.0, 2.0, ! q10 for maintainance respiration +FOLN_MX = 1.5, 1.5, 1.5, 1.5, 1.5, ! foliage nitrogen concentration when f(n)=1 (%) +LEFREEZ = 268, 268, 268, 268, 268, ! characteristic T for leaf freezing [K] + +DILE_FC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for temperature leaf stress death [1/s] +DILE_FC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +DILE_FC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FC_S5 = 0.5, 0.5, 0.5, 0.5, 0.5, +DILE_FC_S6 = 0.5, 0.5, 0.5, 0.5, 0.5, +DILE_FC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +DILE_FW_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! coeficient for water leaf stress death [1/s] +DILE_FW_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +DILE_FW_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FW_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FW_S5 = 0.2, 0.2, 0.2, 0.2, 0.2, +DILE_FW_S6 = 0.2, 0.2, 0.2, 0.2, 0.2, +DILE_FW_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +DILE_FW_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +FRA_GR = 0.2, 0.2, 0.2, 0.2, 0.2, ! fraction of growth respiration + +LF_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of leaf turnover [1/s] +LF_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +LF_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +LF_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +LF_OVRC_S5 = 0.2, 0.48, 0.48, 0.48, 0.48, +LF_OVRC_S6 = 0.3, 0.48, 0.48, 0.48, 0.48, +LF_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +LF_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +ST_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of stem turnover [1/s] +ST_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +ST_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +ST_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +ST_OVRC_S5 = 0.12, 0.12, 0.12, 0.12, 0.12, +ST_OVRC_S6 = 0.06, 0.06, 0.06, 0.06, 0.06, +ST_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +ST_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +RT_OVRC_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of root tunrover [1/s] +RT_OVRC_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +RT_OVRC_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +RT_OVRC_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +RT_OVRC_S5 = 0.12, 0.12, 0.12, 0.12, 0.12, +RT_OVRC_S6 = 0.06, 0.06, 0.06, 0.06, 0.06, +RT_OVRC_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +RT_OVRC_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + + +LFMR25 = 1.0, 1.0, 1.0, 1.0, 1.0, ! leaf maintenance respiration at 25C [umol CO2/m**2 /s] +STMR25 = 0.05, 0.1, 0.1, 0.1, 0.1, ! stem maintenance respiration at 25C [umol CO2/kg bio/s] +RTMR25 = 0.05, 0.0, 0.0, 0.0, 0.0, ! root maintenance respiration at 25C [umol CO2/kg bio/s] +GRAINMR25 = 0.0, 0.1, 0.1, 0.1, 0.1, ! grain maintenance respiration at 25C [umol CO2/kg bio/s] + +LFPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to leaf +LFPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +LFPT_S3 = 0.4, 0.4, 0.4, 0.4, 0.4, +LFPT_S4 = 0.2, 0.2, 0.2, 0.2, 0.2, +LFPT_S5 = 0.0, 0.0, 0.0, 0.0, 0.0, +LFPT_S6 = 0.0, 0.0, 0.0, 0.0, 0.0, +LFPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +LFPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +STPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to stem +STPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +STPT_S3 = 0.2, 0.2, 0.2, 0.2, 0.2, +STPT_S4 = 0.5, 0.5, 0.5, 0.5, 0.5, +STPT_S5 = 0.0, 0.15, 0.15, 0.15, 0.15, +STPT_S6 = 0.0, 0.05, 0.05, 0.05, 0.05, +STPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +STPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +RTPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to root +RTPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +RTPT_S3 = 0.34, 0.4, 0.4, 0.4, 0.4, +RTPT_S4 = 0.3, 0.3, 0.3, 0.3, 0.3, +RTPT_S5 = 0.05, 0.05, 0.05, 0.05, 0.05, +RTPT_S6 = 0.0, 0.05, 0.05, 0.05, 0.05, +RTPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +RTPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + +GRAINPT_S1 = 0.0, 0.0, 0.0, 0.0, 0.0, ! fraction of carbohydrate flux to grain +GRAINPT_S2 = 0.0, 0.0, 0.0, 0.0, 0.0, ! One row for each of 8 stages +GRAINPT_S3 = 0.0, 0.0, 0.0, 0.0, 0.0, +GRAINPT_S4 = 0.0, 0.0, 0.0, 0.0, 0.0, +GRAINPT_S5 = 0.95, 0.8, 0.8, 0.8, 0.8, +GRAINPT_S6 = 1.0, 0.9, 0.9, 0.9, 0.9, +GRAINPT_S7 = 0.0, 0.0, 0.0, 0.0, 0.0, +GRAINPT_S8 = 0.0, 0.0, 0.0, 0.0, 0.0, + + +BIO2LAI = 0.035, 0.015, 0.015, 0.015, 0.015, ! leaf are per living leaf biomass [m^2/kg] + +/ + diff --git a/wrfv2_fire/run/README.namelist b/wrfv2_fire/run/README.namelist index 49dbed83..302e6019 100644 --- a/wrfv2_fire/run/README.namelist +++ b/wrfv2_fire/run/README.namelist @@ -239,6 +239,9 @@ Namelist variables specifically for the WPS input for real: ; level of max wind information in real. With a value of 300 hPa, then ; a max wind value at 500 hPa will be ignored. ; ARW real only. + use_maxw_level ; 0=do not use max wind speed level in vertical interpolation inside + ; of the ARW real program, 1 = use level + use_trop_level ; as above, with tropopause level data sfcp_to_sfcp = .false. ; Optional method to compute model's surface pressure when incoming ; data only has surface pressure and terrain, but not SLP smooth_cg_topo = .false. ; Smooth the outer rows and columns of domain 1's topography w.r.t. @@ -265,7 +268,11 @@ Namelist variables specifically for the WPS input for real: ; the terrain following portion of the hybrid vertical ; coordinate (p > ptsgm) and the purely ; isobaric portion of the vertical coordinate (p < ptsgm) - vert_refine_fact = 1 ; vertical refinement factor for ndown + vert_refine_fact = 1 ; vertical refinement factor for ndown, not used for concurrent vertical grid refinement + vert_refine_method (max_dom) = 0 ; vertical refinement method (new in 3.7) + 0: no vertical refinement + 1: integer vertical refinement + 2: use specified or computed eta levels for vertical refinement Users may explicitly define full eta levels. Given are two distributions for 28 and 35 levels. The number of levels must agree with the number of eta surfaces allocated (e_vert). Users may alternatively request @@ -302,6 +309,9 @@ a known first several layers, then generates equi-height spaced levels up to the 0.3746, 0.3412, 0.3098, 0.2802, 0.2524, 0.2267, 0.2028, 0.1803, 0.1593, 0.1398, 0.1219, 0.1054, 0.0904, 0.0766, 0.0645, 0.0534, 0.0433, 0.0341, 0.0259, 0.0185, 0.0118, 0.0056, 0. + ideal_init_method method to compute alb in idealized cases in start_em (new in 3.8) + = 1, alb from phb (default); = 2, alb from t_init + Horizontal interpolation options, coarse grid to fine grid. The default is to use the Smolarkiewicz "SINT" method. However, this is known to break with the implementation inside of WRF for large refinement ratios (such as 15:1). For those @@ -517,6 +527,9 @@ Namelist variables for controlling the adaptive time step option: no_mp_heating = 0 ; normal = 1 ; turn off latent heating from a microphysics scheme + use_mp_re = 1 ; whether to use effective radii computed in mp schemes in RRTMG (new in 3.8). + 0: do not use; 1: use effective radii + (The mp schemes that compute effective radii are 3,4,6,8,14,16,17-21) ra_lw_physics (max_dom) longwave radiation option = 0, no longwave radiation @@ -586,6 +599,7 @@ Namelist variables for controlling the adaptive time step option: = 0, none = 1, using Tegen (1997) data, = 2, using J. A. Ruiz-Arias method (see other aer_* options) + = 3, using G. Thompson's water/ice friendly climatological aerosol alevsiz = 12 for Tegen aerosol input levels, set automatically no_src_types = 6 for Tegen aerosols: organic and black carbon, sea salt, sulfalte, dust, and stratospheric aerosol (volcanic ashes - currently 0), set automatically @@ -679,11 +693,42 @@ Namelist variables for controlling the adaptive time step option: = 1, turn on topographic surface wind correction from Jimenez (YSU PBL only, and require extra input from geogrid) = 2, turn on topographic surface wind correction from Mass (YSU PBL only) + bl_mynn_tkebudget (max_dom) = 0, default off; = 1 adds MYNN tke budget terms to output bl_mynn_tkeadvect (max_dom) = .false., default off; = .true. do MYNN tke advection + icloud_bl option to couple the subgrid-scale clouds from the PBL scheme (MYNN only) + to radiation schemes + 0: no coupling; 1: activate coupling to radiation (default) + bl_mynn_cloudmix option to activate mixing of qc and qi in MYNN + 0: no mixing of qc & qi; 1: mixing activated (default). + Note qnc and qni are mixed when scalar_pblmix =1. + bl_mynn_mixlength option to change mixing length formulation in MYNN + 0:original as in Nakanishi and Niino 2009, + 1:RAP/HRRR (default, including BouLac in free atmosphere), + 2:experimental (includes cloud-specific mixing length and a scale-aware mixing + length, following Ito et al. 2015, BLM). Option 2 has been well tested with + the edmf options. + bl_mynn_cloudpdf option to switch to different cloud PDFs to represent subgrid clouds + 0: original (Sommeria and Deardorf 1977); + 1: Kuwano et al 2010?, similar to option 0, but uses resolved scale gradients + as opposed to higher order moments ; + 2: from Chaboureau and Bechtold (2002, JAS, with mods, default) + bl_mynn_edmf option to activate mass-flux scheme in MYNN + 1: for StEM; 2: for TEMF; default =0, just regular MYNN. + Related (hidden) options: + bl_mynn_edmf_mom option to activate momentum transport in MYNN mass-flux scheme + (assuming bl_mynn_edmf > 0) + 0: no momentum transport; 1: momentum transport activated (default) + bl_mynn_edmf_tke option to activate TKE transport in MYNN mass-flux scheme + (assuming bl_mynn_edmf > 0) + 0: no TKE transport (default);1: activate TKE transport + scalar_pblmix (max_dom) = 1 ; mix scalar fields consistent with PBL option (exch_h) tracer_pblmix (max_dom) = 1 ; mix tracer fields consistent with PBL option (exch_h) shinhong_tke_diag (max_dom) = 0 ; diagnostic TKE and mixing length from Shin-Hong PBL + opt_thcnd option to treat thermal conductivity in Noah LSM (new in 3.8) + = 1, original (default) + = 2, McCumber and Pielke for silt loam and sandy loam sf_surface_mosaic option to mosaic landuse categories for Noah LSM = 0 ; default; use dominant category only = 1 ; use mosaic landuse categories @@ -700,6 +745,7 @@ Namelist variables for controlling the adaptive time step option: = 5, Grell 3D ensemble scheme = 6, Modifed Tiedtke scheme (ARW only) = 7, Zhang-McFarlane scheme from CAM5 (CESM 1_0_1) + = 10, Modified Kain-Fritsch scheme with trigger function based on PDFs (ARW only) = 11, Multi-scale Kain-Fritsch scheme = 14, New GFS simplified Arakawa-Schubert scheme from YSU (ARW only) = 16, A newer Tiedtke scheme @@ -716,6 +762,9 @@ Namelist variables for controlling the adaptive time step option: ishallow = 1, Shallow convection used with Grell 3D ensemble schemes (cu_physics = 3 or 5) clos_choice = 0, closure choice (place holder only) cu_diag = 0, additional t-averaged stuff for cu physics (cu_phys = 3, 5 and 93 only) + kf_edrates (max_dom) = 0, Add entrainment/detrainment rates and convective timescale output variables for KF-based + cumulus schemes (cu_phys = 1, 11 and 99 only) (new in 3.8) + = 0, no output; = 1, additional output convtrans_avglen_m = 30, averaging time for variables used by convective transport (call cu_phys options) and radiation routines (only cu_phys=3,5 and 93) (minutes) cu_rad_feedback (max_dom) = .false. ; sub-grid cloud effect to the optical depth in radiation currently it works only for GF, G3, GD and KF scheme @@ -730,6 +779,17 @@ Namelist variables for controlling the adaptive time step option: = 3, for small grid distances (DX < 5 km) nsas_dx_factor = 0, default option = 1, NSAS grid-distance dependent option (new in 3.6) + For KF-CuP scheme: recommended to use with cu_rad_feedback + shallowcu_forced_ra(max_dom) radiative impact of shallow Cu by a prescribed maximum cloud fraction + = .false., option off, default + = .true., radiative impact of shallow cu with a cloud fraction value of 0.36 + numbins(max_dom) number of perturbations for potential temperature and mixing ratio in the CuP PDF, + should be an odd number (21 is a recommended value) + thBinSize(max_dom) bin size of potential temperature perturbation increment (0.01 K) + rBinSize(max_dom) bin size of mixing ratio perturbation increment (1.0e-4 kg/kg) + minDeepFreq(max_dom) minimum frequency required before deep convection is allowed (0.333) + minShallowFreq(max_dom) minimum frequency required before shallow convection is allowed (1.0e-2) + shcu_aerosols_opt(max_dom) whether aerosols in shcu: 0=none, 2=prognostic (run with WRF-Chem), ncnvc (max_dom) = FOR NMM: number of fundamental timesteps between calls to convection; the value is set in Registry.NMM @@ -770,23 +830,23 @@ Namelist variables for controlling the adaptive time step option: Sundqvist et al. (1989) (since 3.7) swrad_scat = 1. ; scattering tuning parameter (default 1. is 1.e-5 m2/kg) (works for ra_sw_physics = 1 option only) - surface_input_source = 1, ; where landuse and soil category data come from: + surface_input_source = 3, ; where landuse and soil category data come from: 1 = WPS/geogrid but with dominant categories recomputed 2 = GRIB data from another model (only possible (VEGCAT/SOILCAT are in met_em files from WPS) - 3 = use dominant land and soil categories from WPS/geogrid + 3 = use dominant land and soil categories from WPS/geogrid (default since 3.8) num_soil_layers = 5, ; number of soil layers in land surface model = 5: thermal diffusion scheme = 4: Noah landsurface model - = 6: RUC landsurface model + = 6 or 9: RUC landsurface model = 10: CLM4 landsurface model = 2: Pleim-Xu landsurface model = 3: SSiB landsurface model - num_land_cat = 24, ; number of land categories in input data. + num_land_cat = 21, ; number of land categories in input data. 24 - for USGS (default); 20 for MODIS 28 - for USGS if including lake category - 21 - for MODIS if including lake category + 21 - for MODIS if including lake category (default since 3.8) 40 - for NCLD num_soil_cat = 16, ; number of soil categories in input data @@ -830,6 +890,8 @@ Namelist variables for controlling the adaptive time step option: ; works with sf_surface_physics = 1 only oml_hml0 = 50 ; oml model can be initialized with a constant depth everywhere (m) oml_gamma = 0.14 ; oml deep water lapse rate (K m-1) + oml_relaxation_time = 0. ; Relaxation time (in second) of mixed layer ocean model back to original values + (an example value is 259200 sec. (3 days)) (new in 3.8) omdt = 1. ; 3D PWP time step (min). It can be set to be the same as WRF time step ; in corresponding nested grids, but omdt should be no less than 1.0 minute. ocean_levels = 30 ; number of vertical levels in 3DPWP. Note that the depth of each ocean @@ -1018,6 +1080,14 @@ Options for use with the Noah-MP Land Surface Model: ; 1 = semi-implicit ; 2 = full-implicit ; 3 = semi-implicit where Ts uses snow cover fraction + opt_gla = 1, ; Noah-MP glacier treatment option (new in 3.8) + ; 1 = includes phase change + ; 2 = slab ice (Noah) + opt_rsf = 1, ; Noah-MP surface evaporation resistence option (new in 3.8) + ; 1 -> Sakaguchi and Zeng, 2009 + ; 2 -> Sellers (1992) + ; 3 -> adjusted Sellers to decrease RSURF for wet soil + ; 4 -> option 1 for non-snow; rsurf = rsurf_snow for snow (set in MPTABLE); AD v3.8 / &fdda @@ -1043,7 +1113,10 @@ Options for use with the Noah-MP Land Surface Model: if_ramping = 0 ; 0= nudging ends as a step function, 1= ramping nudging down at end of period dtramp_min = 60.0 ; time (min) for ramping function, 60.0=ramping starts at last analysis time, -60.0=ramping ends at last analysis time - grid_sfdda (max_dom) = 0 ; surface fdda switch (1, on; 0, off) + grid_sfdda (max_dom) = 0 ; surface fdda switch + 0: off; + 1: nudging selected surface fields; + 2: FASDAS (flux-adjusting surface data assimilation system) sgfdda_inname = "wrfsfdda_d" ; defined name for sfc nudgingi in input file (from program obsgrid) sgfdda_end_h (max_dom) = 6 ; time (in hours) to stop sfc nudging after start of forecast sgfdda_interval_m (max_dom) = 180 ; time interval (in min) between sfc analysis times (must use minutes) @@ -1191,7 +1264,7 @@ The following are for observation nudging: (dampcoef nondimensional ~0.01-0.1) 2 = with Rayleigh damping (dampcoef inverse time scale [1/s] e.g. .003; idealized case only not for real-data cases) - 3 = with w-Rayleigh damping (dampcoef inverse time scale [1/s] e.g. .05; + 3 = with w-Rayleigh damping (dampcoef inverse time scale [1/s] e.g. .2; for real-data cases) use_theta_m = 0 ; 1: use theta_m=theta(1+1.61Qv) 0: use dry theta in dynamics @@ -1354,6 +1427,10 @@ The following are for observation nudging: Only 40 for jpeg2000 or 41 for PNG are supported +By default the pressure and height level data goes into stream 23 and 22, respectively. Using +the vertical interpolation options requires the user to define an io_form and interval for +the requested stream. See examples.namelist. + &diags: p_lev_diags = 1, ; Vertically interpolate diagnostics to p-levels 0=NO, 1=YES @@ -1365,6 +1442,12 @@ The following are for observation nudging: (p_hyd). The p_hyd option is the default and less noisy. Total pressure is consistent with what is done in various post-proc packages. + z_lev_diags = 0, ; Vertically interpolate diagnostics to z-levels + 0=NO, 1=YES + num_z_levels = 2, ; Number of height levels to interpolate to + z_levels = 0, ; List of height values (m) to interpolate data to. + ; Positive numbers are for height above mean sea level (i.e. a flight level) + ; Negative numbers are for levels above ground / AFWA diagnostics: diff --git a/wrfv2_fire/run/URBPARM.TBL b/wrfv2_fire/run/URBPARM.TBL index 5c0a3d56..cb4d31d3 100644 --- a/wrfv2_fire/run/URBPARM.TBL +++ b/wrfv2_fire/run/URBPARM.TBL @@ -10,44 +10,44 @@ Number of urban categories: 3 # # Where there are multiple columns of values, the values refer, in -# order, to: 1) Commercial, 2) High intensity residential, and 3) Low -# intensity residential: I.e.: +# order, to: 1) Low density residential, 2) High density residential, +# and 3) Commercial: I.e.: # # Index: 1 2 3 -# Type: Commercial, Hi-dens Res, Low-dens Res +# Type: Low-dens Res, Hi-dens Res, Commercial # # # ZR: Roof level (building height) [ m ] # (sf_urban_physics=1) -ZR: 10.0, 7.5, 5.0 +ZR: 5.0, 7.5, 10.0 # # SIGMA_ZED: Standard Deviation of roof height [ m ] # (sf_urban_physics=1) -SIGMA_ZED: 4.0, 3.0, 1.0 +SIGMA_ZED: 1.0, 3.0, 4.0 # # ROOF_WIDTH: Roof (i.e., building) width [ m ] # (sf_urban_physics=1) -ROOF_WIDTH: 10.0, 9.4, 8.3 +ROOF_WIDTH: 8.3, 9.4, 10.0 # # ROAD_WIDTH: road width [ m ] # (sf_urban_physics=1) # -ROAD_WIDTH: 10.0, 9.4, 8.3 +ROAD_WIDTH: 8.3, 9.4, 10.0 # # AH: Anthropogenic heat [ W m{-2} ] # (sf_urban_physics=1) # -AH: 90.0, 50.0, 20.0 +AH: 20.0, 50.0, 90.0 # @@ -55,7 +55,177 @@ AH: 90.0, 50.0, 20.0 # (sf_urban_physics=1) # -ALH: 40.0, 25.0, 20.0 +ALH: 20.0, 25.0, 40.0 + +# +# AKANDA_URBAN: Coefficient modifying the Kanda approach to computing +# surface layer exchange coefficients. +# (sf_urban_physics=1) + +AKANDA_URBAN: 1.29 1.29 1.29 + +# +# DDZR: Thickness of each roof layer [ m ] +# This is currently NOT a function urban type, but a function +# of the number of layers. Number of layers must be 4, for now. +# (sf_urban_physics=1) + + +DDZR: 0.05, 0.05, 0.05, 0.05 + +# +# DDZB: Thickness of each building wall layer [ m ] +# This is currently NOT a function urban type, but a function +# of the number of layers. Number of layers must be 4, for now. +# (sf_urban_physics=1) +# + +DDZB: 0.05, 0.05, 0.05, 0.05 + +# +# DDZG: Thickness of each ground (road) layer [ m ] +# This is currently NOT a function urban type, but a function +# of the number of layers. Number of layers must be 4, for now. +# (sf_urban_physics=1) +# + +DDZG: 0.05, 0.25, 0.50, 0.75 + +# +# BOUNDR: Lower boundary condition for roof layer temperature [ 1: Zero-Flux, 2: T = Constant ] +# (sf_urban_physics=1) +# + +BOUNDR: 1 + +# +# BOUNDB: Lower boundary condition for wall layer temperature [ 1: Zero-Flux, 2: T = Constant ] +# (sf_urban_physics=1) +# + +BOUNDB: 1 + +# +# BOUNDG: Lower boundary condition for ground (road) layer temperature [ 1: Zero-Flux, 2: T = Constant ] +# (sf_urban_physics=1) +# + +BOUNDG: 1 + +# +# Ch of Wall and Road [ 1: M-O Similarity Theory, 2: Empirical Form of Narita et al., 1997 (recommended) ] +# (sf_urban_physics=1) +# + +CH_SCHEME: 2 + +# +# Surface and Layer Temperatures [ 1: 4-layer model, 2: Force-Restore method ] +# (sf_urban_physics=1) +# + +TS_SCHEME: 1 + +# +# AHOPTION [ 0: No anthropogenic heating, 1: Anthropogenic heating will be added to sensible heat flux term ] +# (sf_urban_physics=1) +# + +AHOPTION: 0 + +# +# Anthropogenic Heating diurnal profile. +# Multiplication factor applied to AH (as defined in the table above) +# Hourly values ( 24 of them ), starting at 01 hours Local Time. +# For sub-hourly model time steps, value changes on the hour and is +# held constant until the next hour. +# (sf_urban_physics=1) +# + +AHDIUPRF: 0.16 0.13 0.08 0.07 0.08 0.26 0.67 0.99 0.89 0.79 0.74 0.73 0.75 0.76 0.82 0.90 1.00 0.95 0.68 0.61 0.53 0.35 0.21 0.18 + +# +# ALHOPTION [ 0: No anthropogenic latent heat, 1: Anthropogenic heating will be added to latent heat flux term ] +# (sf_urban_physics=1) +# + +ALHOPTION: 0 + +# +# Anthropogenic latent heat: seasonal coefficient of daily maximum values +# From left to right in order: Spring (MAM), Summer(JJA), Fall(SON), Winter(DJF) +# (sf_urban_physics=1) +# + +ALHSEASON: 0.43 1.00 0.54 0.40 + +# +# Anthropogenic latent heat diurnal profile. +# Multiplication factor applied to seasonal ALH (as defined above) +# Half-hourly values ( 48 of them ), starting at 00:30 hours Local Time. +# (sf_urban_physics=1) +# + +ALHDIUPRF: 0.436 0.421 0.391 0.356 0.311 0.301 0.306 0.295 0.253 0.205 0.177 0.162 0.148 0.121 0.118 0.146 0.210 0.250 0.227 0.162 0.127 0.184 0.306 0.413 0.487 0.559 0.639 0.728 0.754 0.812 0.867 0.969 1.000 0.949 0.840 0.775 0.758 0.756 0.706 0.658 0.637 0.632 0.636 0.633 0.639 0.615 0.553 0.485 + +# Oasis effect +# Multiplication factor applied to potential ET of vegetation in urban areas +# Value should be larger than 1 when actived +# (sf_urban_physics=1) + +OASIS: 1.0 + +# Evaporation scheme for impervious surfaces (for roof, wall, and road) +# [1: Hypothesized evaporation during large rainfall events (Original) +# [2: Water-holding scheme over impervious surface, Yang et al., 2014 +# (sf_urban_physics=1) + +IMP_SCHEME: 1 + +# Porosity of pavement materials on impervious surface +# For calculating latent heat flux over impervious surface +# From left to right in order: roof, wall, road +# (sf_urban_physics=1,IMP_SCHEME=2) +# + +PORIMP: 0.45 0.45 0.45 + +# Maximum water-holding depth of pavement materials on impervious surface [m] +# For calculating latent heat flux over impervious surface +# From left to right in order: roof, wall, road +# (sf_urban_physics=1,IMP_SCHEME=2) +# + +DENGIMP: 0.001 0.0002 0.001 + +# Urban irrigation scheme, for vegetation in urban area and green roof +# [0: No irrigation +# [1: Summertime (May-Sep) irrigation everyday at 9pm +# (sf_urban_physics=1) + +IRI_SCHEME: 0 + +# +# GROPTION [ 0: No green roof, 1: Enable green roof simulation] +# (sf_urban_physics=1) +# + +GROPTION: 0 + +# Surface fraction of green roof over urban rooftop (0-1) +# (sf_urban_physics=1) +# + +FGR: 0.0 + +# +# DZGR: Thickness of each layer on green roof [ m ] +# Green roof structure: 4-layers +# 1: Top Soil layer 2:Soil layer 3: Growing Medium layer +# 4: concrete roof (depth depends on DDZR defined earlier in this table) +# (sf_urban_physics=1) + +DZGR: 0.05 0.10 0.15 0.20 # # FRC_URB: Fraction of the urban landscape which does not have natural @@ -63,7 +233,7 @@ ALH: 40.0, 25.0, 20.0 # (sf_urban_physics=1,2,3) # -FRC_URB: 0.95, 0.9, 0.5 +FRC_URB: 0.5, 0.9, 0.95 # # CAPR: Heat capacity of roof [ J m{-3} K{-1} ] @@ -173,11 +343,25 @@ Z0G: 0.01, 0.01, 0.01 Z0R: 0.01, 0.01, 0.01 # -# AKANDA_URBAN: Coefficient modifying the Kanda approach to computing -# surface layer exchange coefficients. -# (sf_urban_physics=1) +# TRLEND: Lower boundary condition for roof temperature [ K ] +# (sf_urban_physics=1,2,3) +# -AKANDA_URBAN: 1.29 1.29 1.29 +TRLEND: 293.00, 293.00, 293.00 + +# +# TBLEND: Lower boundary temperature for building wall temperature [ K ] +# (sf_urban_physics=1,2,3) +# + +TBLEND: 293.00, 293.00, 293.00 + +# +# TGLEND: Lower boundary temperature for ground (road) temperature [ K ] +# (sf_urban_physics=1,2,3) +# + +TGLEND: 293.00, 293.00, 293.00 # # COP: Coefficient of performance of the A/C systems [ - ] @@ -226,7 +410,7 @@ TIME_OFF: 24., 24., 24. # (sf_urban_physics=3) # -TARGTEMP: 297., 298., 298. +TARGTEMP: 298., 298., 297. # # GAPTEMP: Comfort Range of the indoor Temperature, [ K ] @@ -254,7 +438,7 @@ GAPHUM: 0.005, 0.005, 0.005 # (sf_urban_physics=3) # -PERFLO: 0.02, 0.01, 0.01 +PERFLO: 0.01, 0.01, 0.02 # # HSEQUIP: Diurnal heating profile of heat generated by equipments @@ -268,7 +452,7 @@ HSEQUIP: 0.25 0.25 0.25 0.25 0.25 0.25 0.25 0.5 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 # (sf_urban_physics=3) # -HSEQUIP_SCALE_FACTOR: 36.00, 20.00, 16.00 +HSEQUIP_SCALE_FACTOR: 16.00, 20.00, 36.00 STREET PARAMETERS: # (sf_urban_physics=2,3) @@ -277,12 +461,12 @@ STREET PARAMETERS: # category direction width width # [index] [deg from N] [m] [m] - 1 0.0 20. 20. - 1 90.0 20. 20. + 1 0.0 30. 13. + 1 90.0 30. 13. 2 0.0 25. 17. 2 90.0 25. 17. - 3 0.0 30. 13. - 3 90.0 30. 13. + 3 0.0 20. 20. + 3 90.0 20. 20. END STREET PARAMETERS @@ -291,13 +475,9 @@ BUILDING HEIGHTS: 1 # height Percentage # [m] [%] - 5.0 0.0 - 10.0 0.0 - 15.0 10.0 - 20.0 25.0 - 25.0 40.0 - 30.0 25.0 - 35.0 0.0 + 5.0 15.0 + 10.0 70.0 + 15.0 15.0 END BUILDING HEIGHTS BUILDING HEIGHTS: 2 @@ -316,190 +496,11 @@ BUILDING HEIGHTS: 3 # height Percentage # [m] [%] - 5.0 15.0 - 10.0 70.0 - 15.0 15.0 + 5.0 0.0 + 10.0 0.0 + 15.0 10.0 + 20.0 25.0 + 25.0 40.0 + 30.0 25.0 + 35.0 0.0 END BUILDING HEIGHTS -# -# DDZR: Thickness of each roof layer [ m ] -# This is currently NOT a function urban type, but a function -# of the number of layers. Number of layers must be 4, for now. -# (sf_urban_physics=1) - - -DDZR: 0.05, 0.05, 0.05, 0.05 - -# -# DDZB: Thickness of each building wall layer [ m ] -# This is currently NOT a function urban type, but a function -# of the number of layers. Number of layers must be 4, for now. -# (sf_urban_physics=1) -# - -DDZB: 0.05, 0.05, 0.05, 0.05 - -# -# DDZG: Thickness of each ground (road) layer [ m ] -# This is currently NOT a function urban type, but a function -# of the number of layers. Number of layers must be 4, for now. -# (sf_urban_physics=1) -# - -DDZG: 0.05, 0.25, 0.50, 0.75 - -# -# BOUNDR: Lower boundary condition for roof layer temperature [ 1: Zero-Flux, 2: T = Constant ] -# (sf_urban_physics=1) -# - -BOUNDR: 1 - -# -# BOUNDB: Lower boundary condition for wall layer temperature [ 1: Zero-Flux, 2: T = Constant ] -# (sf_urban_physics=1) -# - -BOUNDB: 1 - -# -# BOUNDG: Lower boundary condition for ground (road) layer temperature [ 1: Zero-Flux, 2: T = Constant ] -# (sf_urban_physics=1) -# - -BOUNDG: 1 - -# -# TRLEND: Lower boundary condition for roof temperature [ K ] -# (sf_urban_physics=1,2,3) -# - -TRLEND: 293.00, 293.00, 293.00 - -# -# TBLEND: Lower boundary temperature for building wall temperature [ K ] -# (sf_urban_physics=1,2,3) -# - -TBLEND: 293.00, 293.00, 293.00 - -# -# TGLEND: Lower boundary temperature for ground (road) temperature [ K ] -# (sf_urban_physics=1,2,3) -# - -TGLEND: 293.00, 293.00, 293.00 - -# -# Ch of Wall and Road [ 1: M-O Similarity Theory, 2: Empirical Form of Narita et al., 1997 (recommended) ] -# (sf_urban_physics=1) -# - -CH_SCHEME: 2 - -# -# Surface and Layer Temperatures [ 1: 4-layer model, 2: Force-Restore method ] -# (sf_urban_physics=1) -# - -TS_SCHEME: 1 - -# -# AHOPTION [ 0: No anthropogenic heating, 1: Anthropogenic heating will be added to sensible heat flux term ] -# (sf_urban_physics=1) -# - -AHOPTION: 0 - -# -# Anthropogenic Heating diurnal profile. -# Multiplication factor applied to AH (as defined in the table above) -# Hourly values ( 24 of them ), starting at 01 hours Local Time. -# For sub-hourly model time steps, value changes on the hour and is -# held constant until the next hour. -# (sf_urban_physics=1) -# - -AHDIUPRF: 0.16 0.13 0.08 0.07 0.08 0.26 0.67 0.99 0.89 0.79 0.74 0.73 0.75 0.76 0.82 0.90 1.00 0.95 0.68 0.61 0.53 0.35 0.21 0.18 - -# -# ALHOPTION [ 0: No anthropogenic latent heat, 1: Anthropogenic heating will be added to latent heat flux term ] -# (sf_urban_physics=1) -# - -ALHOPTION: 0 - -# -# Anthropogenic latent heat: seasonal coefficient of daily maximum values -# From left to right in order: Spring (MAM), Summer(JJA), Fall(SON), Winter(DJF) -# (sf_urban_physics=1) -# - -ALHSEASON: 0.43 1.00 0.54 0.40 - -# -# Anthropogenic latent heat diurnal profile. -# Multiplication factor applied to seasonal ALH (as defined above) -# Half-hourly values ( 48 of them ), starting at 00:30 hours Local Time. -# (sf_urban_physics=1) -# - -ALHDIUPRF: 0.436 0.421 0.391 0.356 0.311 0.301 0.306 0.295 0.253 0.205 0.177 0.162 0.148 0.121 0.118 0.146 0.210 0.250 0.227 0.162 0.127 0.184 0.306 0.413 0.487 0.559 0.639 0.728 0.754 0.812 0.867 0.969 1.000 0.949 0.840 0.775 0.758 0.756 0.706 0.658 0.637 0.632 0.636 0.633 0.639 0.615 0.553 0.485 - -# Oasis effect -# Multiplication factor applied to potential ET of vegetation in urban areas -# Value should be larger than 1 when actived -# (sf_urban_physics=1) - -OASIS: 1.0 - -# Evaporation scheme for impervious surfaces (for roof, wall, and road) -# [1: Hypothesized evaporation during large rainfall events (Original) -# [2: Water-holding scheme over impervious surface, Yang et al., 2014 -# (sf_urban_physics=1) - -IMP_SCHEME: 1 - -# Porosity of pavement materials on impervious surface -# For calculating latent heat flux over impervious surface -# From left to right in order: roof, wall, road -# (sf_urban_physics=1,IMP_SCHEME=2) -# - -PORIMP: 0.45 0.45 0.45 - -# Maximum water-holding depth of pavement materials on impervious surface [m] -# For calculating latent heat flux over impervious surface -# From left to right in order: roof, wall, road -# (sf_urban_physics=1,IMP_SCHEME=2) -# - -DENGIMP: 0.001 0.0002 0.001 - -# Urban irrigation scheme, for vegetation in urban area and green roof -# [0: No irrigation -# [1: Summertime (May-Sep) irrigation everyday at 9pm -# (sf_urban_physics=1) - -IRI_SCHEME: 0 - -# -# GROPTION [ 0: No green roof, 1: Enable green roof simulation] -# (sf_urban_physics=1) -# - -GROPTION: 0 - -# Surface fraction of green roof over urban rooftop (0-1) -# (sf_urban_physics=1) -# - -FGR: 0.0 - -# -# DZGR: Thickness of each layer on green roof [ m ] -# Green roof structure: 4-layers -# 1: Top Soil layer 2:Soil layer 3: Growing Medium layer -# 4: concrete roof (depth depends on DDZR defined earlier in this table) -# (sf_urban_physics=1) - -DZGR: 0.05 0.10 0.15 0.20 diff --git a/wrfv2_fire/run/URBPARM_UZE.TBL b/wrfv2_fire/run/URBPARM_UZE.TBL index 1cfeeab6..e1ea2643 100644 --- a/wrfv2_fire/run/URBPARM_UZE.TBL +++ b/wrfv2_fire/run/URBPARM_UZE.TBL @@ -14,40 +14,40 @@ Number of urban categories: 3 # urban zone, and 3) UZE Low-density urban zone: I.e.: # # Index: 1 2 3 -# UZE Urban Zone: High Dens, Med Dens, Low Dens +# UZE Urban Zone: Low Dens, Med Dens, High Dens # # # ZR: Roof level (building height) [ m ] # (sf_urban_physics=1) -ZR: 18.0, 15.0, 6.0 +ZR: 6.0, 15.0, 18.0 # # SIGMA_ZED: Standard Deviation of roof height [ m ] # (sf_urban_physics=1) -SIGMA_ZED: 3.0, 1.5, 1.0 +SIGMA_ZED: 1.0, 1.5, 3.0 # # ROOF_WIDTH: Roof (i.e., building) width [ m ] # (sf_urban_physics=1) -ROOF_WIDTH: 22.0, 20.0, 8.0 +ROOF_WIDTH: 8.0, 20.0, 22.0 # # ROAD_WIDTH: road width [ m ] # (sf_urban_physics=1) # -ROAD_WIDTH: 8.0, 10.0, 15.0 +ROAD_WIDTH: 15.0, 10.0, 8.0 # # AH: Anthropogenic heat [ W m{-2} ] # (sf_urban_physics=1) # -AH: 90.0, 50.0, 20.0 +AH: 20.0, 50.0, 90.0 # # FRC_URB: Fraction of the urban landscape which does not have natural @@ -55,21 +55,21 @@ AH: 90.0, 50.0, 20.0 # (sf_urban_physics=1,2,3) # -FRC_URB: 0.75, 0.6, 0.5 +FRC_URB: 0.5, 0.6, 0.75 # # CAPR: Heat capacity of roof [ J m{-3} K{-1} ] # (sf_urban_physics=1,2,3) # -CAPR: 1.5E6, 1.2E6, 1.0E6, +CAPR: 1.0E6, 1.2E6, 1.5E6, # # CAPB: Heat capacity of building wall [ J m{-3} K{-1} ] # (sf_urban_physics=1,2,3) # -CAPB: 1.4E6, 1.2E6, 1.2E6, +CAPB: 1.2E6, 1.2E6, 1.4E6, # # CAPG: Heat capacity of ground (road) [ J m{-3} K{-1} ] @@ -83,7 +83,7 @@ CAPG: 1.5E6, 1.5E6, 1.5E6, # (sf_urban_physics=1,2,3) # -AKSR: 0.8, 0.4, 0.4, +AKSR: 0.4, 0.4, 0.8, # # AKSB: Thermal conductivity of building wall [ J m{-1} s{-1} K{-1} ] @@ -104,7 +104,7 @@ AKSG: 0.8, 0.8, 0.8, # (sf_urban_physics=1,2,3) # -ALBR: 0.10, 0.10, 0.15 +ALBR: 0.15, 0.10, 0.10 # # ALBB: Surface albedo of building wall [ fraction ] @@ -218,7 +218,7 @@ TIME_OFF: 24., 24., 24. # (sf_urban_physics=3) # -TARGTEMP: 297., 298., 298. +TARGTEMP: 298., 298., 297. # # GAPTEMP: Comfort Range of the indoor Temperature, [ K ] @@ -246,7 +246,7 @@ GAPHUM: 0.005, 0.005, 0.005 # (sf_urban_physics=3) # -PERFLO: 0.02, 0.01, 0.01 +PERFLO: 0.01, 0.01, 0.02 # # HSEQUIP: Diurnal heating profile of heat generated by equipments @@ -260,7 +260,7 @@ HSEQUIP: 0.25 0.25 0.25 0.25 0.25 0.25 0.25 0.5 1.0 1.0 1.0 1.0 1.0 1.0 1.0 1.0 # (sf_urban_physics=3) # -HSEQUIP_SCALE_FACTOR: 36.00, 20.00, 16.00 +HSEQUIP_SCALE_FACTOR: 16.00, 20.00, 36.00 STREET PARAMETERS: # (sf_urban_physics=2,3) @@ -269,12 +269,12 @@ STREET PARAMETERS: # category direction width width # [index] [deg from N] [m] [m] - 1 0.0 20. 20. - 1 90.0 20. 20. + 1 0.0 30. 13. + 1 90.0 30. 13. 2 0.0 25. 17. 2 90.0 25. 17. - 3 0.0 30. 13. - 3 90.0 30. 13. + 3 0.0 20. 20. + 3 90.0 20. 20. END STREET PARAMETERS @@ -283,13 +283,9 @@ BUILDING HEIGHTS: 1 # height Percentage # [m] [%] - 5.0 0.0 - 10.0 0.0 - 15.0 10.0 - 20.0 25.0 - 25.0 40.0 - 30.0 25.0 - 35.0 0.0 + 5.0 15.0 + 10.0 70.0 + 15.0 15.0 END BUILDING HEIGHTS BUILDING HEIGHTS: 2 @@ -308,9 +304,13 @@ BUILDING HEIGHTS: 3 # height Percentage # [m] [%] - 5.0 15.0 - 10.0 70.0 - 15.0 15.0 + 5.0 0.0 + 10.0 0.0 + 15.0 10.0 + 20.0 25.0 + 25.0 40.0 + 30.0 25.0 + 35.0 0.0 END BUILDING HEIGHTS # # DDZR: Thickness of each roof layer [ m ] diff --git a/wrfv2_fire/run/VEGPARM.TBL b/wrfv2_fire/run/VEGPARM.TBL index 0e9b5b7b..5b7ab79a 100644 --- a/wrfv2_fire/run/VEGPARM.TBL +++ b/wrfv2_fire/run/VEGPARM.TBL @@ -42,6 +42,12 @@ NATURAL 5 CROP 3 +LOW_DENSITY_RESIDENTIAL +31 +HIGH_DENSITY_RESIDENTIAL +32 +HIGH_INTENSITY_INDUSTRIAL +33 Vegetation Parameters MODIFIED_IGBP_MODIS_NOAH 20,1, 'SHDFAC NROOT RS RGL HS SNUP MAXALB LAIMIN LAIMAX EMISSMIN EMISSMAX ALBEDOMIN ALBEDOMAX Z0MIN Z0MAX ZTOPV ZBOTV' @@ -79,6 +85,75 @@ NATURAL 14 CROP 12 +LOW_DENSITY_RESIDENTIAL +31 +HIGH_DENSITY_RESIDENTIAL +32 +HIGH_INTENSITY_INDUSTRIAL +33 +Vegetation Parameters +NLCD40 +40,1, 'SHDFAC NROOT RS RGL HS SNUP MAXALB LAIMIN LAIMAX EMISSMIN EMISSMAX ALBEDOMIN ALBEDOMAX Z0MIN Z0MAX ZTOPV ZBOTV' +1, .70, 4, 125., 30., 47.35, 0.08, 52., 5.00, 6.40, .950, .950, .12, .12, .50, .50, 17.00, 8.50, 'Evergreen Needleleaf Forest' +2, .95, 4, 150., 30., 41.69, 0.08, 35., 3.08, 6.48, .950, .950, .12, .12, .50, .50, 35.00, 1.00, 'Evergreen Broadleaf Forest' +3, .70, 4, 150., 30., 47.35, 0.08, 54., 1.00, 5.16, .930, .940, .14, .15, .50, .50, 14.00, 7.00, 'Deciduous Needleleaf Forest' +4, .80, 4, 100., 30., 54.53, 0.08, 58., 1.85, 3.31, .930, .930, .16, .17, .50, .50, 20.00, 11.50, 'Deciduous Broadleaf Forest' +5, .80, 4, 125., 30., 51.93, 0.08, 53., 2.80, 5.50, .930, .970, .17, .25, .20, .50, 18.00, 10.00, 'Mixed Forest' +6, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.50, 0.10, 'Closed Shrubland' +7, .70, 3, 170., 100., 39.18, 0.035, 65., 0.60, 2.60, .930, .950, .22, .30, .01, .06, 0.50, 0.10, 'Open Shrubland' +8, .50, 3, 70., 65., 54.53, 0.04, 50., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.00, 0.00, 'Woody Savanna' +9, .50, 3, 70., 65., 54.53, 0.04, 50., 0.50, 3.66, .920, .920, .20, .20, .15, .15, 0.50, 0.10, 'Savanna' +10, .80, 3, 40., 100., 36.35, 0.04, 70., 0.52, 2.90, .920, .960, .19, .23, .10, .12, 0.50, 0.10, 'Grassland' +11, .60, 2, 100., 30., 51.93, 0.02, 50., 1.75, 5.72, .950, .950, .14, .14, .30, .30, 0.50, 0.10, 'Permanent Wetland' +12, .80, 3, 40., 100., 36.25, 0.04, 66., 1.50, 5.68, .920, .985, .15, .23, .05, .15, 0.50, 0.10, 'Cropland' +13, .10, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .15, .15, .50, .50, 0.00, 0.00, 'Urban and Built-Up' +14, .80, 3, 40., 100., 36.25, 0.04, 66., 2.29, 4.29, .920, .980, .18, .23, .05, .14, 0.50, 0.10, 'Cropland / Natural Veg. Mosaic' +15, .00, 1, 999., 999., 999.0, 0.02, 82., 0.01, 0.01, .950, .950, .55, .70, 0.001, 0.001, 0.00, 0.00, 'Permanent Snow' +16, .01, 1, 999., 999., 999.0, 0.02, 75., 0.10, 0.75, .900, .900, .38, .38, .01, .01, 0.02, 0.01, 'Barren / Sparsely Vegetated' +17, .00, 0, 100., 30., 51.75, 0.01, 70., 0.01, 0.01, .980, .980, .08, .08, 0.0001, 0.0001, 0.00, 0.00, 'IGBP Water' +18, .00, 0, 999., 999., 999.0, 999., 999., 999.0, 999.0, 999., 999.0, 999.0, 999.0, 999.0, 999.0, 0.00, 0.00, 'Unclassified' +19, .00, 0, 999., 999., 999.0, 999., 999., 999.0, 999.0, 999., 999.0, 999.0, 999.0, 999.0, 999.0, 0.00, 0.00, 'Fill Value' +20, .00, 0, 999., 999., 999.0, 999., 999., 999.0, 999.0, 999., 999.0, 999.0, 999.0, 999.0, 999.0, 0.00, 0.00, 'Unclassified' +21, .00, 0, 100., 30., 51.75, 0.01, 70., 0.01, 0.01, .980, .980, .08, .08, 0.0001, 0.0001, 0.00, 0.00, 'Open Water' +22, .00, 1, 999., 999., 999.0, 0.02, 82., 0.01, 0.01, .950, .950, .55, .70, 0.001, 0.001, 0.00, 0.00, 'Perennial Ice/Snow' +23, .30, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, .50, .50, 0.00, 0.00, 'Developed Open Space' +24, .27, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, .70, .70, 0.00, 0.00, 'Developed Low Intensity' +25, .02, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, 1.5, 1.5, 0.00, 0.00, 'Developed Medium Intensity' +26, .11, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, 2.0, 2.0, 0.00, 0.00, 'Developed High Intensity' +27, .01, 1, 999., 999., 999.0, 0.02, 75., 0.10, 0.75, .900, .900, .38, .38, .01, .01, 0.02, 0.01, 'Barren Land' +28, .80, 4, 125., 30., 54.70, 0.08, 56., 1.00, 5.16, .930, .940, .14, .17, .50, .50, 20.00, 11.50, 'Deciduous Forest' +29, .95, 4, 140., 30., 44.00, 0.08, 42., 3.08, 6.48, .950, .950, .12, .12, .50, .50, 17.00, 8.50, 'Evergreen Forest' +30, .80, 4, 125., 30., 51.93, 0.08, 53., 2.80, 5.50, .930, .970, .17, .25, .20, .50, 18.00, 10.00, 'Mixed Forest' +31, .70, 3, 170., 100., 39.18, 0.035, 65., 1.00, 4.00, .930, .950, .16, .30, .01, .04, 0.50, 0.10, 'Dwarf Scrub' +32, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .22, .30, .01, .05, 0.50, 0.10, 'Shrub/Scrub' +33, .80, 3, 40., 100., 36.35, 0.04, 70., 0.52, 2.90, .920, .960, .19, .23, .10, .12, 0.50, 0.10, 'Grassland/Herbaceous' +34, .60, 2, 40., 100., 60.00, 0.01, 68., 1.50, 5.65, .950, .950, .14, .14, .20, .20, 0.50, 0.10, 'Sedge/Herbaceous' +35, .60, 2, 40., 100., 60.00, 0.01, 68., 1.00, 2.00, .950, .950, .31, .31, .01, .01, 0.00, 0.00, 'Lichens' +36, .60, 2, 40., 100., 60.00, 0.01, 68., 1.00, 2.00, .950, .950, .24, .24, .01, .01, 0.00, 0.00, 'Moss' +37, .80, 3, 40., 100., 36.25, 0.04, 66., 1.56, 5.68, .920, .985, .17, .23, .05, .15, 0.50, 0.10, 'Pasture/Hay' +38, .80, 3, 40., 100., 36.25, 0.04, 66., 1.56, 5.68, .930, .985, .20, .25, .02, .10, 0.50, 0.10, 'Cultivated Crops' +39, .60, 2, 100., 30., 51.93, 0.02, 50., 0.70, 3.50, .950, .950, .14, .14, .40, .40, 20.00, 11.50, 'Woody Wetland' +40, .60, 2, 40., 100., 60.00, 0.01, 68., 0.70, 3.50, .950, .950, .12, .12, .20, .20, 0.50, 0.10, 'Emergent Herbaceous Wetland' +TOPT_DATA +298.0 +CMCMAX_DATA +0.5E-3 +CFACTR_DATA +0.5 +RSMAX_DATA +5000.0 +BARE +16 +NATURAL +14 +CROP +12 +LOW_DENSITY_RESIDENTIAL +24 +HIGH_DENSITY_RESIDENTIAL +26 +HIGH_INTENSITY_INDUSTRIAL +99 Vegetation Parameters USGS-RUC 28,1, 'ALBEDO Z0 LEMI PC SHDFAC IFOR RS RGL HS SNUP LAI MAXALB' @@ -124,6 +199,8 @@ NATURAL 5 CROP 3 +URBAN +1 Vegetation Parameters MODI-RUC 21,1, 'ALBEDO Z0 LEMI PC SHDFAC IFOR RS RGL HS SNUP LAI MAXALB' @@ -162,60 +239,5 @@ NATURAL 10 CROP 12 -Vegetation Parameters -NLCD40 -40,1, 'SHDFAC NROOT RS RGL HS SNUP MAXALB LAIMIN LAIMAX EMISSMIN EMISSMAX ALBEDOMIN ALBEDOMAX Z0MIN Z0MAX ZTOPV ZBOTV' -1, .70, 4, 125., 30., 47.35, 0.08, 52., 5.00, 6.40, .950, .950, .12, .12, .50, .50, 17.00, 8.50, 'Evergreen Needleleaf Forest' -2, .95, 4, 150., 30., 41.69, 0.08, 35., 3.08, 6.48, .950, .950, .12, .12, .50, .50, 35.00, 1.00, 'Evergreen Broadleaf Forest' -3, .70, 4, 150., 30., 47.35, 0.08, 54., 1.00, 5.16, .930, .940, .14, .15, .50, .50, 14.00, 7.00, 'Deciduous Needleleaf Forest' -4, .80, 4, 100., 30., 54.53, 0.08, 58., 1.85, 3.31, .930, .930, .16, .17, .50, .50, 20.00, 11.50, 'Deciduous Broadleaf Forest' -5, .80, 4, 125., 30., 51.93, 0.08, 53., 2.80, 5.50, .930, .970, .17, .25, .20, .50, 18.00, 10.00, 'Mixed Forest' -6, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.50, 0.10, 'Closed Shrubland' -7, .70, 3, 170., 100., 39.18, 0.035, 65., 0.60, 2.60, .930, .950, .22, .30, .01, .06, 0.50, 0.10, 'Open Shrubland' -8, .50, 3, 70., 65., 54.53, 0.04, 50., 0.50, 3.66, .930, .930, .25, .30, .01, .05, 0.00, 0.00, 'Woody Savanna' -9, .50, 3, 70., 65., 54.53, 0.04, 50., 0.50, 3.66, .920, .920, .20, .20, .15, .15, 0.50, 0.10, 'Savanna' -10, .80, 3, 40., 100., 36.35, 0.04, 70., 0.52, 2.90, .920, .960, .19, .23, .10, .12, 0.50, 0.10, 'Grassland' -11, .60, 2, 100., 30., 51.93, 0.02, 50., 1.75, 5.72, .950, .950, .14, .14, .30, .30, 0.50, 0.10, 'Permanent Wetland' -12, .80, 3, 40., 100., 36.25, 0.04, 66., 1.50, 5.68, .920, .985, .15, .23, .05, .15, 0.50, 0.10, 'Cropland' -13, .10, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .15, .15, .50, .50, 0.00, 0.00, 'Urban and Built-Up' -14, .80, 3, 40., 100., 36.25, 0.04, 66., 2.29, 4.29, .920, .980, .18, .23, .05, .14, 0.50, 0.10, 'Cropland / Natural Veg. Mosaic' -15, .00, 1, 999., 999., 999.0, 0.02, 82., 0.01, 0.01, .950, .950, .55, .70, 0.001, 0.001, 0.00, 0.00, 'Permanent Snow' -16, .01, 1, 999., 999., 999.0, 0.02, 75., 0.10, 0.75, .900, .900, .38, .38, .01, .01, 0.02, 0.01, 'Barren / Sparsely Vegetated' -17, .00, 0, 100., 30., 51.75, 0.01, 70., 0.01, 0.01, .980, .980, .08, .08, 0.0001, 0.0001, 0.00, 0.00, 'IGBP Water' -18, .00, 0, 999., 999., 999.0, 999., 999., 999.0, 999.0, 999., 999.0, 999.0, 999.0, 999.0, 999.0, 0.00, 0.00, 'Unclassified' -19, .00, 0, 999., 999., 999.0, 999., 999., 999.0, 999.0, 999., 999.0, 999.0, 999.0, 999.0, 999.0, 0.00, 0.00, 'Fill Value' -20, .00, 0, 999., 999., 999.0, 999., 999., 999.0, 999.0, 999., 999.0, 999.0, 999.0, 999.0, 999.0, 0.00, 0.00, 'Unclassified' -21, .00, 0, 100., 30., 51.75, 0.01, 70., 0.01, 0.01, .980, .980, .08, .08, 0.0001, 0.0001, 0.00, 0.00, 'Open Water' -22, .00, 1, 999., 999., 999.0, 0.02, 82., 0.01, 0.01, .950, .950, .55, .70, 0.001, 0.001, 0.00, 0.00, 'Perennial Ice/Snow' -23, .30, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, .50, .50, 0.00, 0.00, 'Developed Open Space' -24, .27, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, .70, .70, 0.00, 0.00, 'Developed Low Intensity' -25, .02, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, 1.5, 1.5, 0.00, 0.00, 'Developed Medium Intensity' -26, .11, 1, 200., 999., 999.0, 0.04, 46., 1.00, 1.00, .880, .880, .20, .20, 2.0, 2.0, 0.00, 0.00, 'Developed High Intensity' -27, .01, 1, 999., 999., 999.0, 0.02, 75., 0.10, 0.75, .900, .900, .38, .38, .01, .01, 0.02, 0.01, 'Barren Land' -28, .80, 4, 125., 30., 54.70, 0.08, 56., 1.00, 5.16, .930, .940, .14, .17, .50, .50, 20.00, 11.50, 'Deciduous Forest' -29, .95, 4, 140., 30., 44.00, 0.08, 42., 3.08, 6.48, .950, .950, .12, .12, .50, .50, 17.00, 8.50, 'Evergreen Forest' -30, .80, 4, 125., 30., 51.93, 0.08, 53., 2.80, 5.50, .930, .970, .17, .25, .20, .50, 18.00, 10.00, 'Mixed Forest' -31, .70, 3, 170., 100., 39.18, 0.035, 65., 1.00, 4.00, .930, .950, .16, .30, .01, .04, 0.50, 0.10, 'Dwarf Scrub' -32, .70, 3, 300., 100., 42.00, 0.03, 60., 0.50, 3.66, .930, .930, .22, .30, .01, .05, 0.50, 0.10, 'Shrub/Scrub' -33, .80, 3, 40., 100., 36.35, 0.04, 70., 0.52, 2.90, .920, .960, .19, .23, .10, .12, 0.50, 0.10, 'Grassland/Herbaceous' -34, .60, 2, 40., 100., 60.00, 0.01, 68., 1.50, 5.65, .950, .950, .14, .14, .20, .20, 0.50, 0.10, 'Sedge/Herbaceous' -35, .60, 2, 40., 100., 60.00, 0.01, 68., 1.00, 2.00, .950, .950, .31, .31, .01, .01, 0.00, 0.00, 'Lichens' -36, .60, 2, 40., 100., 60.00, 0.01, 68., 1.00, 2.00, .950, .950, .24, .24, .01, .01, 0.00, 0.00, 'Moss' -37, .80, 3, 40., 100., 36.25, 0.04, 66., 1.56, 5.68, .920, .985, .17, .23, .05, .15, 0.50, 0.10, 'Pasture/Hay' -38, .80, 3, 40., 100., 36.25, 0.04, 66., 1.56, 5.68, .930, .985, .20, .25, .02, .10, 0.50, 0.10, 'Cultivated Crops' -39, .60, 2, 100., 30., 51.93, 0.02, 50., 0.70, 3.50, .950, .950, .14, .14, .40, .40, 20.00, 11.50, 'Woody Wetland' -40, .60, 2, 40., 100., 60.00, 0.01, 68., 0.70, 3.50, .950, .950, .12, .12, .20, .20, 0.50, 0.10, 'Emergent Herbaceous Wetland' -TOPT_DATA -298.0 -CMCMAX_DATA -0.5E-3 -CFACTR_DATA -0.5 -RSMAX_DATA -5000.0 -BARE -16 -NATURAL -14 -CROP -12 +URBAN +13 diff --git a/wrfv2_fire/share/dfi.F b/wrfv2_fire/share/dfi.F index b3762d5e..41d8ebf2 100644 --- a/wrfv2_fire/share/dfi.F +++ b/wrfv2_fire/share/dfi.F @@ -547,7 +547,7 @@ SUBROUTINE dfi_write_initialized_state( grid ) TYPE (domain) , POINTER :: grid INTEGER :: fid, ierr CHARACTER (LEN=80) :: wrf_error_message - CHARACTER (LEN=80) :: rstname + CHARACTER (LEN=256) :: rstname CHARACTER (LEN=132) :: message TYPE (grid_config_rec_type) :: config_flags @@ -580,7 +580,7 @@ SUBROUTINE tdfi_write_analyzed_state ( grid ) TYPE (domain) , POINTER :: grid INTEGER :: fid, ierr CHARACTER (LEN=80) :: wrf_error_message - CHARACTER (LEN=80) :: rstname + CHARACTER (LEN=256) :: rstname CHARACTER (LEN=132) :: message TYPE (grid_config_rec_type) :: config_flags diff --git a/wrfv2_fire/share/init_modules.F b/wrfv2_fire/share/init_modules.F index fae28b56..d3555987 100644 --- a/wrfv2_fire/share/init_modules.F +++ b/wrfv2_fire/share/init_modules.F @@ -14,13 +14,19 @@ SUBROUTINE init_modules( phase ) USE module_io , ONLY : init_module_io #ifdef DM_PARALLEL USE module_wrf_quilt , ONLY : init_module_wrf_quilt - USE module_dm , ONLY : init_module_dm, split_communicator + USE module_dm , ONLY : init_module_dm, split_communicator,hwrf_coupler_init +#else + USE module_dm , ONLY : init_module_dm #endif #ifdef INTIO USE module_ext_internal , ONLY : init_module_ext_internal #endif USE module_wrf_error , ONLY : init_module_wrf_error +#if ( DA_CORE != 1 ) + USE module_cpl, ONLY : coupler_on, cpl_init +#endif + ! ! This routine USES the modules in WRF and then calls the init routines ! they provide to perform module specific initializations at the @@ -50,6 +56,8 @@ SUBROUTINE init_modules( phase ) INTEGER, INTENT(IN) :: phase ! phase==1 means return after MPI_INIT() ! phase==2 means resume after MPI_INIT() +integer mpi_comm_here,myrank_,ntasks_,ierr_ + IF ( phase == 1 ) THEN CALL init_module_bc CALL init_module_configure @@ -62,13 +70,25 @@ SUBROUTINE init_modules( phase ) CALL init_module_ext_internal !! must be called before quilt #endif #ifdef DM_PARALLEL - CALL split_communicator - CALL init_module_wrf_quilt !! this *must* be called before init_module_dm +# if ( HWRF == 1 ) +! jm 20150807 +! jm this was moved to here so that the coupler can divide up the tasks before the model starts doing it for quilting, nesting etc. +! jm the idea is that the atmosphere will see only the communicator with the tasks it is supposed to use for that stuff +! jm hwrf_coupler_init is defined in external/RSL_LITE/module_dm.F + CALL hwrf_coupler_init +# endif +# if ( HWRF == 1 ) + CALL init_module_wrf_quilt !! this *must* be called before init_module_dm ! We must never reach this line or phase 2 in an I/O server. + CALL split_communicator +# else + CALL split_communicator + CALL init_module_wrf_quilt !! this *must* be called before init_module_dm +# endif - CALL init_module_dm #endif + CALL init_module_dm ELSE CALL init_module_wrf_error ! must be called after init_module_dm diff --git a/wrfv2_fire/share/input_wrf.F b/wrfv2_fire/share/input_wrf.F index 69cbd783..e4ad69ae 100644 --- a/wrfv2_fire/share/input_wrf.F +++ b/wrfv2_fire/share/input_wrf.F @@ -12,8 +12,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) USE module_utility IMPLICIT NONE -#include -#include +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags INTEGER, INTENT(IN) :: fid @@ -48,7 +48,7 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) Type(WRFU_Time) time, currtime, currentTime CHARACTER*19 new_date CHARACTER*24 base_date - CHARACTER*80 fname + CHARACTER*256 fname CHARACTER*80 dname, memord, sim_type LOGICAL dryrun INTEGER idt @@ -92,7 +92,7 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) ! Local variables: are we are using the correct hypsometric option for ARW ideal cases. - CHARACTER (LEN=80) :: input_name + CHARACTER (LEN=256) :: input_name INTEGER :: loop, hypsometric_opt, icount CHARACTER (LEN=256) :: a_message @@ -501,7 +501,9 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr ) CALL nl_set_map_proj ( grid%id , config_flags%map_proj ) grid%map_proj = config_flags%map_proj + mminlu = " " CALL wrf_get_dom_ti_char ( fid , 'MMINLU', mminlu , ierr ) + IF ( ierr .NE. 0 ) mminlu = " " #if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) ) IF ( ( ( switch .EQ. input_only ) .OR. ( switch .EQ. restart_only ) ) .AND. & ( ( config_flags%io_form_input .EQ. 2 ) .OR. & diff --git a/wrfv2_fire/share/interp_fcn.F b/wrfv2_fire/share/interp_fcn.F index 56259156..ac9a0d33 100644 --- a/wrfv2_fire/share/interp_fcn.F +++ b/wrfv2_fire/share/interp_fcn.F @@ -2338,25 +2338,25 @@ SUBROUTINE bdy_interp1( cfld, & ! CD field ! WEST IF ( ni .ge. nids .and. ni .lt. nids + sz ) THEN bdy_txs( nj,k,ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_xs( nj,k,ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + bdy_xs( nj,k,ni ) = nfld(ni,k,nj) ENDIF ! SOUTH IF ( nj .ge. njds .and. nj .lt. njds + sz ) THEN bdy_tys( ni,k,nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_ys( ni,k,nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + bdy_ys( ni,k,nj ) = nfld(ni,k,nj) ENDIF ! EAST IF ( xstag ) THEN IF ( ni .ge. nide - sz + 1 .AND. ni .le. nide ) THEN bdy_txe( nj,k,nide-ni+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_xe( nj,k,nide-ni+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + bdy_xe( nj,k,nide-ni+1 ) = nfld(ni,k,nj) ENDIF ELSE IF ( ni .ge. nide - sz .AND. ni .le. nide-1 ) THEN bdy_txe( nj,k,nide-ni ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_xe( nj,k,nide-ni ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + bdy_xe( nj,k,nide-ni ) = nfld(ni,k,nj) ENDIF ENDIF @@ -2364,12 +2364,12 @@ SUBROUTINE bdy_interp1( cfld, & ! CD field IF ( ystag ) THEN IF ( nj .ge. njde - sz + 1 .AND. nj .le. njde ) THEN bdy_tye( ni,k,njde-nj+1 ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_ye( ni,k,njde-nj+1 ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + bdy_ye( ni,k,njde-nj+1 ) = nfld(ni,k,nj) ENDIF ELSE IF ( nj .ge. njde - sz .AND. nj .le. njde-1 ) THEN bdy_tye(ni,k,njde-nj ) = rdt*(psca(ci+shw,cj+shw,ip+1+(jp)*nri)-nfld(ni,k,nj)) - bdy_ye( ni,k,njde-nj ) = psca(ci+shw,cj+shw,ip+1+(jp)*nri ) + bdy_ye( ni,k,njde-nj ) = nfld(ni,k,nj) ENDIF ENDIF @@ -2509,14 +2509,14 @@ SUBROUTINE bdy_interp2( cfld, & ! CD field IF ( ni .LT. nids + sz ) THEN bdy_txs(nj,nk,ni) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) - bdy_xs (nj,nk,ni) = nfld_horiz_interp(ni,nk,nj) + bdy_xs (nj,nk,ni) = nfld(ni,nk,nj) END IF ! SOUTH boundary IF ( nj .LT. njds + sz ) THEN bdy_tys(ni,nk,nj) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) - bdy_ys (ni,nk,nj) = nfld_horiz_interp(ni,nk,nj) + bdy_ys (ni,nk,nj) = nfld(ni,nk,nj) END IF ! EAST boundary @@ -2524,12 +2524,12 @@ SUBROUTINE bdy_interp2( cfld, & ! CD field IF ( xstag ) THEN IF ( ( ni .GE. nide - sz + 1 ) .AND. ( ni .LE. nide ) ) THEN bdy_txe(nj,nk,nide-ni+1) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) - bdy_xe (nj,nk,nide-ni+1) = nfld_horiz_interp(ni,nk,nj) + bdy_xe (nj,nk,nide-ni+1) = nfld(ni,nk,nj) END IF ELSE IF ( ( ni .GE. nide - sz ) .AND. ( ni .LE. nide-1 ) ) THEN bdy_txe(nj,nk,nide-ni ) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) - bdy_xe (nj,nk,nide-ni ) = nfld_horiz_interp(ni,nk,nj) + bdy_xe (nj,nk,nide-ni ) = nfld(ni,nk,nj) END IF END IF @@ -2538,12 +2538,12 @@ SUBROUTINE bdy_interp2( cfld, & ! CD field IF ( ystag ) THEN IF ( ( nj .GE. njde - sz + 1 ) .AND. ( nj .LE. njde ) ) THEN bdy_tye(ni,nk,njde-nj+1) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) - bdy_ye (ni,nk,njde-nj+1) = nfld_horiz_interp(ni,nk,nj) + bdy_ye (ni,nk,njde-nj+1) = nfld(ni,nk,nj) END IF ELSE IF ( ( nj .GE. njde - sz ) .AND. ( nj .LE. njde-1 ) ) THEN bdy_tye(ni,nk,njde-nj ) = rdt*(nfld_horiz_interp(ni,nk,nj)-nfld(ni,nk,nj)) - bdy_ye (ni,nk,njde-nj ) = nfld_horiz_interp(ni,nk,nj) + bdy_ye (ni,nk,njde-nj ) = nfld(ni,nk,nj) END IF END IF diff --git a/wrfv2_fire/share/mediation_feedback_domain.F b/wrfv2_fire/share/mediation_feedback_domain.F index ddc53cb3..c108fb86 100644 --- a/wrfv2_fire/share/mediation_feedback_domain.F +++ b/wrfv2_fire/share/mediation_feedback_domain.F @@ -6,8 +6,10 @@ SUBROUTINE med_feedback_domain ( parent_grid , nested_grid ) USE module_domain USE module_configure USE module_intermediate_nmm -#ifdef NMM_FIND_LOAD_IMBALANCE - USE module_dm, only: local_communicator +#ifdef DM_PARALLEL + USE module_dm, ONLY: local_communicator, intercomm_active +#else + USE module_dm, ONLY: intercomm_active #endif IMPLICIT NONE TYPE(domain), POINTER :: parent_grid , nested_grid @@ -57,7 +59,7 @@ SUBROUTINE feedback_domain_em_part1 ( grid, nested_grid, config_flags & TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: nested_grid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE feedback_domain_em_part1 SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid , nested_grid, config_flags & ! @@ -70,7 +72,7 @@ SUBROUTINE feedback_domain_em_part2 ( grid, intermediate_grid , nested_grid, con TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: nested_grid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE feedback_domain_em_part2 SUBROUTINE update_after_feedback_em ( grid & ! @@ -80,7 +82,7 @@ SUBROUTINE update_after_feedback_em ( grid & USE module_domain USE module_configure TYPE(domain), TARGET :: grid ! name of the grid being dereferenced (must be "grid") -# include +# include "dummy_new_decl.inc" END SUBROUTINE update_after_feedback_em #endif #endif @@ -103,7 +105,7 @@ SUBROUTINE feedback_domain_nmm_part1 ( grid, nested_grid, config_flags & TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: nested_grid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE feedback_domain_nmm_part1 ! SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid , nested_grid, config_flags & @@ -117,15 +119,10 @@ SUBROUTINE feedback_domain_nmm_part2 ( grid, intermediate_grid , nested_grid, co TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: nested_grid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE feedback_domain_nmm_part2 -#endif -! ---------------------------------------------------------- -! Interface definitions for COAMPS (placeholder) -! ---------------------------------------------------------- -#if (COAMPS_CORE == 1 ) #endif END INTERFACE ! ---------------------------------------------------------- @@ -135,9 +132,6 @@ END SUBROUTINE feedback_domain_nmm_part2 ! ---------------------------------------------------------- ! Executable code ! ---------------------------------------------------------- -#ifdef NMM_FIND_LOAD_IMBALANCE - this_time=now_time() -#endif ! ---------------------------------------------------------- ! Feedback calls for EM CORE. ! ---------------------------------------------------------- @@ -146,8 +140,8 @@ END SUBROUTINE feedback_domain_nmm_part2 CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) parent_grid%ht_coarse = parent_grid%ht grid => nested_grid%intermediate_grid -# if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10)))) - CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & +# if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) + CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , intercomm_active( grid%id ), & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & @@ -157,29 +151,39 @@ END SUBROUTINE feedback_domain_nmm_part2 grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose ) # endif + CALL wrf_dm_nestexchange_init + IF ( nested_grid%active_this_task ) THEN grid => nested_grid%intermediate_grid CALL feedback_domain_em_part1 ( grid, nested_grid, config_flags & ! # include "actual_new_args.inc" ! ) + ENDIF grid => parent_grid grid%nest_mask = 0. + CALL feedback_domain_em_part2 ( grid , nested_grid%intermediate_grid, nested_grid , config_flags & ! # include "actual_new_args.inc" ) + WHERE ( grid%nest_pos .NE. 9021000. ) grid%ht = grid%ht_coarse + CALL push_communicators_for_domain(grid%id) CALL update_after_feedback_em ( grid & ! # include "actual_new_args.inc" ! ) + CALL pop_communicators_for_domain + grid => nested_grid%intermediate_grid -# if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10)))) +# if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) + IF ( intercomm_active( grid%id ) ) THEN CALL dealloc_space_field ( grid ) + ENDIF # endif # endif #endif @@ -198,9 +202,10 @@ END SUBROUTINE feedback_domain_nmm_part2 CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) grid => nested_grid%intermediate_grid !dusan orig CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & -# if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10)))) +# if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) +! IF ( grid%active_this_task ) THEN CALL ensure_space_field & - ( grid, grid%id , 1 , 3 , .FALSE. , & + ( grid, grid%id , 1 , 3 , .FALSE. , grid%active_this_task , & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & @@ -209,6 +214,7 @@ END SUBROUTINE feedback_domain_nmm_part2 grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose ) +! ENDIF # endif nested_grid%intermediate_grid%interp_mp=parent_grid%interp_mp .or. nested_grid%interp_mp #if (HWRF == 1) @@ -223,101 +229,36 @@ END SUBROUTINE feedback_domain_nmm_part2 ! STEP 1: Copy from parent grid to intermediate grid: grid => parent_grid #if (NMM_NEST==1) -!# include "deref_kludge.h" - -#ifdef NMM_FIND_LOAD_IMBALANCE - ttime=now_time() - call mpi_barrier(local_communicator,ierr) -#endif - call parent_to_inter_part1(parent_grid, nested_grid%intermediate_grid, & nested_grid, config_flags) -#ifdef NMM_FIND_LOAD_IMBALANCE - call mpi_barrier(local_communicator,ierr) - p2i_1_now=now_time()-ttime - p2i_1_time(nested_grid%id)=p2i_1_time(nested_grid%id)+p2i_1_now - - ttime=now_time() - call mpi_barrier(local_communicator,ierr) -#endif - grid => nested_grid%intermediate_grid - call parent_to_inter_part2(nested_grid%intermediate_grid, config_flags) + call parent_to_inter_part2(nested_grid%intermediate_grid, nested_grid, config_flags) -#ifdef NMM_FIND_LOAD_IMBALANCE - call mpi_barrier(local_communicator,ierr) - p2i_2_now=now_time()-ttime - p2i_2_time(nested_grid%id)=p2i_2_time(nested_grid%id)+p2i_2_now -#endif #endif + IF ( nested_grid%active_this_task ) THEN ! STEP 2: Interpolate from nest grid to intermediate grid grid => nested_grid%intermediate_grid !# include "deref_kludge.h" -#ifdef NMM_FIND_LOAD_IMBALANCE - ttime=now_time() - call mpi_barrier(local_communicator,ierr) -#endif CALL feedback_domain_nmm_part1 ( grid, nested_grid, config_flags & ! # include "actual_new_args.inc" ! ) -#ifdef NMM_FIND_LOAD_IMBALANCE - call mpi_barrier(local_communicator,ierr) - feed1_now=now_time()-ttime - feed1_time(nested_grid%id)=feed1_time(nested_grid%id)+feed1_now - ttime=now_time() - call mpi_barrier(local_communicator,ierr) -#endif + ENDIF grid => parent_grid -!# include "deref_kludge.h" - ! CALL feedback_domain_nmm_part2 ( grid , nested_grid%intermediate_grid, nested_grid , config_flags & ! # include "actual_new_args.inc" ! ) -#ifdef NMM_FIND_LOAD_IMBALANCE - call mpi_barrier(local_communicator,ierr) - feed2_now=now_time()-ttime - feed2_time(nested_grid%id)=feed2_time(nested_grid%id)+feed2_now - grid => nested_grid%intermediate_grid -#endif + #endif ! ------------------------------------------------------ ! End of Feedback calls for NMM. ! ------------------------------------------------------ -! ------------------------------------------------------ -! ------------------------------------------------------ -! Feedback calls for COAMPS. (Placeholder) -! ------------------------------------------------------ -#if (COAMPS_CORE == 1) -#endif -! ------------------------------------------------------ -! End of Feedback calls for COAMPS. -! ------------------------------------------------------ -#ifdef NMM_FIND_LOAD_IMBALANCE - this_time=now_time()-this_time - total_time(nested_grid%id)=total_time(nested_grid%id)+this_time -30 format('med_feedback_domain for grid ',I0,' to grid ',I0,': ',F12.6,'s; running total: ',F12.6,'s') - write(message,30) nested_grid%id,parent_grid%id,this_time,total_time(nested_grid%id) - call wrf_debug(1,message) -#if (NMM_NEST==1) -40 format(' feedback parts: p2i1=',F7.4,'/',F10.4,' (',F6.2,'%) p2i2=',F7.4,'/',F10.4,' (',F6.2,'%)') - write(message,40) & - p2i_1_now,p2i_1_time(nested_grid%id),p2i_1_time(nested_grid%id)/total_time(nested_grid%id)*100., & - p2i_2_now,p2i_2_time(nested_grid%id),p2i_2_time(nested_grid%id)/total_time(nested_grid%id)*100. - call wrf_debug(1,message) -#endif -50 format(' feedback parts: feed1=',F7.4,'/',F10.4,' (',F6.2,'%) feed2=',F7.4,'/',F10.4,' (',F6.2,'%)') - write(message,50) & - feed1_now,feed1_time(nested_grid%id),feed1_time(nested_grid%id)/total_time(nested_grid%id)*100., & - feed2_now,feed2_time(nested_grid%id),feed2_time(nested_grid%id)/total_time(nested_grid%id)*100. - call wrf_debug(1,message) -#endif RETURN END SUBROUTINE med_feedback_domain diff --git a/wrfv2_fire/share/mediation_force_domain.F b/wrfv2_fire/share/mediation_force_domain.F index 69043c2e..dffa9233 100644 --- a/wrfv2_fire/share/mediation_force_domain.F +++ b/wrfv2_fire/share/mediation_force_domain.F @@ -8,6 +8,13 @@ SUBROUTINE med_force_domain ( parent_grid , nested_grid ) USE module_domain USE module_configure USE module_intermediate_nmm +#ifdef DM_PARALLEL + USE module_dm, ONLY : intercomm_active, & + mpi_comm_to_kid, mpi_comm_to_mom, which_kid +#else + USE module_dm, ONLY : intercomm_active +#endif + IMPLICIT NONE TYPE(domain), POINTER :: parent_grid , nested_grid TYPE(domain), POINTER :: grid @@ -46,7 +53,7 @@ SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE interp_domain_em_part1 SUBROUTINE force_domain_em_part2 ( grid, nested_grid, parent_grid, config_flags & @@ -60,7 +67,7 @@ SUBROUTINE force_domain_em_part2 ( grid, nested_grid, parent_grid, config_flags TYPE(domain), POINTER :: nested_grid TYPE(domain), POINTER :: parent_grid ! KAL added for vertical nesting TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE force_domain_em_part2 ! ---------------------------------------------------------- @@ -76,7 +83,7 @@ SUBROUTINE couple_or_uncouple_em ( grid, config_flags , couple & TYPE(domain), INTENT(INOUT) :: grid TYPE (grid_config_rec_type) :: config_flags LOGICAL, INTENT( IN) :: couple -# include +# include "dummy_new_decl.inc" END SUBROUTINE couple_or_uncouple_em #endif #endif @@ -99,7 +106,7 @@ SUBROUTINE force_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flags TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE force_domain_nmm_part1 SUBROUTINE before_interp_halos_nmm(grid,config_flags & @@ -111,7 +118,7 @@ SUBROUTINE before_interp_halos_nmm(grid,config_flags & USE MODULE_CONFIGURE TYPE(domain), POINTER :: grid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE before_interp_halos_nmm SUBROUTINE force_domain_nmm_part2 ( grid, nested_grid, config_flags & @@ -125,7 +132,7 @@ SUBROUTINE force_domain_nmm_part2 ( grid, nested_grid, config_flags & TYPE(domain), POINTER :: nested_grid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE force_domain_nmm_part2 !======================================================================= ! End of gopal's doing. @@ -134,8 +141,6 @@ END SUBROUTINE force_domain_nmm_part2 ! ---------------------------------------------------------- ! Interface definitions for COAMPS (placeholder) ! ---------------------------------------------------------- -#if (COAMPS_CORE == 1) -#endif END INTERFACE ! ---------------------------------------------------------- ! End of Interface blocks @@ -144,9 +149,6 @@ END SUBROUTINE force_domain_nmm_part2 ! ---------------------------------------------------------- ! Executable code ! ---------------------------------------------------------- -#ifdef NMM_FIND_LOAD_IMBALANCE -this_time=now_time() -#endif ! ---------------------------------------------------------- ! Forcing calls for EM CORE. ! ---------------------------------------------------------- @@ -155,8 +157,9 @@ END SUBROUTINE force_domain_nmm_part2 CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) grid => nested_grid%intermediate_grid -# if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10)))) - CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & +# if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) +! IF ( intercomm_active(grid%id) ) THEN + CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , intercomm_active(grid%id), & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & @@ -165,25 +168,34 @@ END SUBROUTINE force_domain_nmm_part2 grid%sm31x, grid%em31x, grid%sm32x, grid%em32x, grid%sm33x, grid%em33x, & ! x-xpose grid%sm31y, grid%em31y, grid%sm32y, grid%em32y, grid%sm33y, grid%em33y & ! y-xpose ) +! ENDIF # endif ! couple parent domain grid => parent_grid + IF ( grid%active_this_task ) THEN + CALL push_communicators_for_domain(grid%id) ! swich config_flags to point to parent rconfig info - CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) - CALL couple_or_uncouple_em ( grid , config_flags , .true. & + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL couple_or_uncouple_em ( grid , config_flags , .true. & ! # include "actual_new_args.inc" ! ) + CALL pop_communicators_for_domain + ENDIF ! couple nested domain grid => nested_grid - CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) - CALL couple_or_uncouple_em ( grid , config_flags , .true. & + IF ( grid%active_this_task ) THEN + CALL push_communicators_for_domain(grid%id) + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL couple_or_uncouple_em ( grid , config_flags , .true. & ! # include "actual_new_args.inc" ! ) + CALL pop_communicators_for_domain + ENDIF ! perform first part: transfer data from parent to intermediate domain ! at the same resolution but on the same decomposition as the nest ! note that this will involve communication on multiple DM procs @@ -195,13 +207,27 @@ END SUBROUTINE force_domain_nmm_part2 ! ! T. Hutchinson, WSI 1/23/07 ! - nested_grid%intermediate_grid%dt = grid%dt - CALL interp_domain_em_part1 ( grid , nested_grid%intermediate_grid, nested_grid, config_flags & + IF ( parent_grid%active_this_task .AND. nested_grid%active_this_task ) THEN + nested_grid%intermediate_grid%dt = grid%dt + ENDIF + IF ( parent_grid%active_this_task ) THEN + CALL BYTE_BCAST( parent_grid%dt,RWORDSIZE,mpi_comm_to_kid( which_kid( nested_grid%id ) , parent_grid%id )) + ELSE IF ( nested_grid%active_this_task ) THEN + CALL BYTE_BCAST( nested_grid%dt,RWORDSIZE,mpi_comm_to_mom( nested_grid%id ) ) + ENDIF + + IF ( parent_grid%active_this_task .OR. nested_grid%active_this_task ) THEN + CALL wrf_dm_nestexchange_init + + CALL interp_domain_em_part1 ( grid , nested_grid%intermediate_grid, nested_grid, config_flags & ! # include "actual_new_args.inc" ! ) + ENDIF + + IF ( nested_grid%active_this_task ) THEN grid => nested_grid%intermediate_grid ! perform 2nd part: run interpolation on the intermediate domain ! and compute the values for the nest boundaries @@ -212,30 +238,41 @@ END SUBROUTINE force_domain_nmm_part2 # include "actual_new_args.inc" ! ) + ENDIF ! uncouple the nest grid => nested_grid - CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) - CALL couple_or_uncouple_em ( grid , config_flags , .false. & + IF ( grid%active_this_task ) THEN + CALL push_communicators_for_domain(grid%id) + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL couple_or_uncouple_em ( grid , config_flags , .false. & ! # include "actual_new_args.inc" ! ) + CALL pop_communicators_for_domain + ENDIF ! uncouple the parent grid => parent_grid - CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) - CALL couple_or_uncouple_em ( grid , config_flags , .false. & + IF ( grid%active_this_task ) THEN + CALL push_communicators_for_domain(grid%id) + CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + CALL couple_or_uncouple_em ( grid , config_flags , .false. & ! # include "actual_new_args.inc" ! ) + CALL pop_communicators_for_domain + ENDIF IF ( nested_grid%first_force ) THEN nested_grid%first_force = .FALSE. ENDIF nested_grid%dtbc = 0. ! grid => nested_grid%intermediate_grid -# if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10)))) - CALL dealloc_space_field ( grid ) +# if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) + IF ( intercomm_active(grid%id) ) THEN + CALL dealloc_space_field ( grid ) + ENDIF # endif # endif #endif @@ -255,9 +292,9 @@ END SUBROUTINE force_domain_nmm_part2 grid => nested_grid%intermediate_grid !dusan orig CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & -# if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10)))) - CALL ensure_space_field & - ( grid, grid%id , 1 , 3 , .FALSE. , & +# if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) + CALL ensure_space_field & + ( grid, grid%id , 1 , 3 , .FALSE. , intercomm_active(grid%id), & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & @@ -284,6 +321,7 @@ END SUBROUTINE force_domain_nmm_part2 ! IF ( .NOT. ( config_flags%restart .AND. nested_grid%first_force ) ) THEN ! couple nested domain grid => nested_grid +IF ( grid%active_this_task ) THEN CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) ! Apply halos on weights and indices: call before_interp_halos_nmm(grid,config_flags & @@ -291,6 +329,7 @@ END SUBROUTINE force_domain_nmm_part2 # include "actual_new_args.inc" ! ) +ENDIF ! Copy interpolation information from parent grid to intermediate grid: ! grid => parent_grid @@ -302,6 +341,8 @@ END SUBROUTINE force_domain_nmm_part2 ! Transfer remaining information from parent to intermediate grid: grid => parent_grid +IF ( grid%active_this_task .OR. nested_grid%active_this_task ) THEN + CALL wrf_dm_nestexchange_init CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) CALL force_domain_nmm_part1 ( grid , nested_grid%intermediate_grid, & nested_grid, config_flags & @@ -309,18 +350,19 @@ END SUBROUTINE force_domain_nmm_part2 # include "actual_new_args.inc" ! ) +ENDIF +IF ( nested_grid%active_this_task ) THEN grid => nested_grid%intermediate_grid - IF ( .NOT. ( config_flags%restart .AND. nested_grid%first_force ) ) THEN - ! Finish transfering information from parent to intermediate - ! grid, then run interpolation on the intermediate domain and - ! compute the values for the nest boundaries. - CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) - CALL force_domain_nmm_part2 ( grid, nested_grid, config_flags & + ! Finish transfering information from parent to intermediate + ! grid, then run interpolation on the intermediate domain and + ! compute the values for the nest boundaries. + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) + CALL force_domain_nmm_part2 ( grid, nested_grid, config_flags & ! # include "actual_new_args.inc" ! ) - ENDIF ! not restart and first_force +ENDIF IF ( nested_grid%first_force ) THEN nested_grid%first_force = .FALSE. @@ -344,13 +386,6 @@ END SUBROUTINE force_domain_nmm_part2 ! ------------------------------------------------------ ! End of Forcing calls for COAMPS. ! ------------------------------------------------------ -#ifdef NMM_FIND_LOAD_IMBALANCE - this_time=now_time()-this_time - total_time(parent_grid%id)=total_time(parent_grid%id)+this_time -30 format('med_force_domain for grid ',I0,' to grid ',I0,': ',F12.6,'s; running total: ',F12.6,'s') - write(message,30) parent_grid%id,nested_grid%id,this_time,total_time(parent_grid%id) - call wrf_debug(1,message) -#endif RETURN END SUBROUTINE med_force_domain diff --git a/wrfv2_fire/share/mediation_integrate.F b/wrfv2_fire/share/mediation_integrate.F index 09f033c1..73a09541 100644 --- a/wrfv2_fire/share/mediation_integrate.F +++ b/wrfv2_fire/share/mediation_integrate.F @@ -5,8 +5,8 @@ SUBROUTINE med_calc_model_time ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain, domain_clock_get - USE module_configure , ONLY : grid_config_rec_type + USE module_domain , ONLY : domain, domain_clock_get + USE module_configure , ONLY : grid_config_rec_type ! Model layer USE module_date_time @@ -29,8 +29,8 @@ END SUBROUTINE med_calc_model_time SUBROUTINE med_before_solve_io ( grid , config_flags ) ! Driver layer USE module_state_description - USE module_domain , ONLY : domain, domain_clock_get - USE module_configure , ONLY : grid_config_rec_type + USE module_domain , ONLY : domain, domain_clock_get + USE module_configure , ONLY : grid_config_rec_type USE module_streams ! Model layer USE module_utility @@ -44,7 +44,7 @@ SUBROUTINE med_before_solve_io ( grid , config_flags ) INTEGER :: ialarm INTEGER :: rc TYPE(WRFU_Time) :: currTime, startTime -#ifdef HWRF +#if ( HWRF == 1 ) INTEGER :: hr, min, sec, ms,julyr,julday REAL :: GMT #endif @@ -53,9 +53,9 @@ SUBROUTINE med_before_solve_io ( grid , config_flags ) CALL WRFU_ClockGet( grid%domain_clock, CurrTime=currTime, StartTime=startTime ) - - IF( WRFU_AlarmIsRinging( grid%alarms( HISTORY_ALARM ), rc=rc ) .AND. & - (grid%dfi_write_dfi_history .OR. grid%dfi_stage == DFI_FST .OR. grid%dfi_opt == DFI_NODFI) ) THEN + + IF( (WRFU_AlarmIsRinging( grid%alarms( HISTORY_ALARM ), rc=rc ) .AND. & + (grid%dfi_write_dfi_history .OR. grid%dfi_stage == DFI_FST .OR. grid%dfi_opt == DFI_NODFI) )) THEN IF ( ( config_flags%restart ) .AND. & ( config_flags%write_hist_at_0h_rst ) .AND. & ( currTime .EQ. startTime ) ) THEN @@ -171,7 +171,7 @@ SUBROUTINE med_before_solve_io ( grid , config_flags ) CALL WRFU_ClockGet( grid%domain_clock, CurrTime=currTime, StartTime=startTime ) IF ( ( WRFU_AlarmIsRinging( grid%alarms( RESTART_ALARM ), rc=rc ) ) .AND. & ( currTime .NE. startTime ) ) THEN -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing CALL domain_clock_get( grid, current_time=CurrTime ) CALL WRFU_TimeGet( CurrTime, YY=julyr, dayOfYear=julday, H=hr, M=min, S=sec, MS=ms, rc=rc) @@ -198,9 +198,9 @@ END SUBROUTINE med_before_solve_io SUBROUTINE med_after_solve_io ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer IMPLICIT NONE @@ -221,9 +221,9 @@ END SUBROUTINE med_after_solve_io SUBROUTINE med_pre_nest_initial ( parent , newid , config_flags ) ! Driver layer #ifdef MOVE_NESTS - USE module_domain , ONLY : domain, domain_clock_get + USE module_domain , ONLY : domain, domain_clock_get #else - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain #endif #ifdef ESMFIO USE module_utility , ONLY : WRFU_Time @@ -232,7 +232,7 @@ SUBROUTINE med_pre_nest_initial ( parent , newid , config_flags ) #endif USE module_timing USE module_io_domain - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer IMPLICIT NONE @@ -291,11 +291,15 @@ END SUBROUTINE med_pre_nest_initial SUBROUTINE med_nest_initial ( parent , nest , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get , get_ijk_from_grid + USE module_domain , ONLY : domain , domain_clock_get , get_ijk_from_grid USE module_timing USE module_io_domain - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type USE module_utility +#ifdef DM_PARALLEL + USE module_dm, ONLY : local_communicator, & + mpi_comm_to_mom, mpi_comm_to_kid, which_kid +#endif ! Model layer IMPLICIT NONE @@ -308,7 +312,7 @@ SUBROUTINE med_nest_initial ( parent , nest , config_flags ) ! Local LOGICAL, EXTERNAL :: wrf_dm_on_monitor TYPE(WRFU_Time) :: strt_time, cur_time - CHARACTER * 80 :: rstname , timestr + CHARACTER * 256 :: rstname , timestr CHARACTER * 256 :: message INTEGER :: fid INTEGER :: ierr @@ -338,39 +342,40 @@ SUBROUTINE med_nest_initial ( parent , nest , config_flags ) INTERFACE SUBROUTINE med_interp_domain ( parent , nest ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_interp_domain !KAL - SUBROUTINE init_domain_vert_nesting ( parent, nest ) + SUBROUTINE init_domain_vert_nesting ( parent, nest, use_baseparam_fr_nml ) !KAL this is a driver to initialize the vertical coordinates for the nest when vertical nesting is used. USE module_domain, ONLY : domain IMPLICIT NONE TYPE(domain), POINTER :: parent, nest + LOGICAL :: use_baseparam_fr_nml END SUBROUTINE init_domain_vert_nesting SUBROUTINE med_interp_domain_small ( parent , nest ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_interp_domain_small SUBROUTINE med_initialdata_input_ptr( nest , config_flags ) - USE module_domain , ONLY : domain - USE module_configure , ONLY : grid_config_rec_type + USE module_domain , ONLY : domain + USE module_configure , ONLY : grid_config_rec_type TYPE (grid_config_rec_type), INTENT(IN) :: config_flags TYPE(domain) , POINTER :: nest END SUBROUTINE med_initialdata_input_ptr SUBROUTINE med_nest_feedback ( parent , nest , config_flags ) - USE module_domain , ONLY : domain - USE module_configure , ONLY : grid_config_rec_type + USE module_domain , ONLY : domain + USE module_configure , ONLY : grid_config_rec_type TYPE (domain), POINTER :: nest , parent TYPE (grid_config_rec_type), INTENT(IN) :: config_flags END SUBROUTINE med_nest_feedback SUBROUTINE start_domain ( grid , allowed_to_move ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE(domain) :: grid LOGICAL, INTENT(IN) :: allowed_to_move END SUBROUTINE start_domain @@ -401,7 +406,7 @@ SUBROUTINE input_terrain_rsmas ( grid , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE ( domain ) :: grid INTEGER :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & @@ -423,11 +428,13 @@ END SUBROUTINE wrf_tsin IF ( .not. ( config_flags%restart .AND. strt_time .EQ. cur_time ) ) THEN nest%first_force = .true. + IF ( nest%active_this_task ) THEN ! initialize nest with interpolated data from the parent - nest%imask_nostag = 1 - nest%imask_xstag = 1 - nest%imask_ystag = 1 - nest%imask_xystag = 1 + nest%imask_nostag = 1 + nest%imask_xstag = 1 + nest%imask_ystag = 1 + nest%imask_xystag = 1 + ENDIF #ifdef MOVE_NESTS parent%nest_pos = parent%ht @@ -436,10 +443,10 @@ END SUBROUTINE wrf_tsin ! initialize some other constants (and 1d arrays in z) CALL init_domain_constants ( parent, nest ) - + if (nest%e_vert /= parent%e_vert) then ! set up coordinate variables for nest with vertical grid refinement (1d variables in z are done later in med_interp_domain) - CALL init_domain_vert_nesting ( parent, nest ) + CALL init_domain_vert_nesting ( parent, nest, config_flags%use_baseparam_fr_nml ) endif @@ -538,11 +545,14 @@ END SUBROUTINE wrf_tsin #if (DA_CORE != 1) ! For nests without an input file, we still need to read time series locations ! from the tslist file - CALL wrf_tsin( nest , ierr ) + IF ( nest%active_this_task) THEN + CALL push_communicators_for_domain( nest%id ) + CALL wrf_tsin( nest , ierr ) + CALL pop_communicators_for_domain + ENDIF #endif END IF - ! feedback, mostly for this new terrain, but it is the safe thing to do parent%ht_coarse = parent%ht @@ -558,12 +568,26 @@ END SUBROUTINE wrf_tsin ! set some other initial fields, fill out halos, base fields; re-do parent due ! to new terrain elevation from feedback - nest%imask_nostag = 1 - nest%imask_xstag = 1 - nest%imask_ystag = 1 - nest%imask_xystag = 1 - nest%press_adj = .TRUE. - CALL start_domain ( nest , .TRUE. ) + + IF ( nest%active_this_task) THEN + nest%imask_nostag = 1 + nest%imask_xstag = 1 + nest%imask_ystag = 1 + nest%imask_xystag = 1 + nest%press_adj = .TRUE. + CALL push_communicators_for_domain( nest%id ) + CALL start_domain ( nest , .TRUE. ) + CALL pop_communicators_for_domain + ENDIF + +#if defined(DM_PARALLEL) && ! defined(STUBMPI) + CALL push_communicators_for_domain( parent%id ) + CALL MPI_Barrier( local_communicator, ierr ) + CALL pop_communicators_for_domain +#endif + + IF ( parent%active_this_task ) THEN + CALL push_communicators_for_domain( parent%id ) ! kludge: 20040604 CALL get_ijk_from_grid ( parent , & ids, ide, jds, jde, kds, kde, & @@ -613,10 +637,13 @@ END SUBROUTINE wrf_tsin DEALLOCATE( save_sfcrunoff ) DEALLOCATE( save_udrunoff ) ! end of kludge: 20040604 - + CALL pop_communicators_for_domain + ENDIF ELSE ! restart +!TODO -- have to look at restarts yet + IF ( wrf_dm_on_monitor() ) CALL start_timing CALL domain_clock_get( nest, current_timestr=timestr ) @@ -711,12 +738,12 @@ END SUBROUTINE wrf_tsin INTERFACE SUBROUTINE med_nest_egrid_configure ( parent , nest ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_nest_egrid_configure SUBROUTINE med_construct_egrid_weights ( parent , nest ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_construct_egrid_weights @@ -745,31 +772,31 @@ SUBROUTINE BASE_STATE_PARENT ( Z3d,Q3d,T3d,PSTD, & END SUBROUTINE BASE_STATE_PARENT SUBROUTINE NEST_TERRAIN ( nest, config_flags ) - USE module_domain , ONLY : domain - USE module_configure , ONLY : grid_config_rec_type + USE module_domain , ONLY : domain + USE module_configure , ONLY : grid_config_rec_type TYPE(domain) , POINTER :: nest TYPE(grid_config_rec_type) , INTENT(IN) :: config_flags END SUBROUTINE NEST_TERRAIN SUBROUTINE med_interp_domain ( parent , nest ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_interp_domain SUBROUTINE med_init_domain_constants_nmm ( parent, nest ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_init_domain_constants_nmm SUBROUTINE start_domain ( grid , allowed_to_move ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE(domain) :: grid LOGICAL, INTENT(IN) :: allowed_to_move END SUBROUTINE start_domain END INTERFACE -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing test if (config_flags%restart .or. nest%analysis) then nest%first_force = .true. @@ -865,19 +892,34 @@ END SUBROUTINE start_domain KPE = nest%ep33 + IF ( nest%active_this_task ) THEN CALL NEST_TERRAIN ( nest, config_flags ) + ENDIF ! Initialize some more constants required especially for terrain adjustment processes + IF ( nest%active_this_task .AND. parent%active_this_task ) THEN nest%PSTD=parent%PSTD - nest%KZMAX=KME - parent%KZMAX=KME ! just for safety + ENDIF +#ifdef DM_PARALLEL + IF ( nest%active_this_task .OR. parent%active_this_task ) THEN + IF ( parent%active_this_task ) THEN + CALL BYTE_BCAST( parent%PSTD, KME*RWORDSIZE, mpi_comm_to_kid( which_kid( nest%id ) , parent%id ) ) + ELSE + CALL BYTE_BCAST( nest%PSTD, KME*RWORDSIZE, mpi_comm_to_mom( nest%id ) ) + ENDIF + ENDIF +#endif - DO J = JPS, MIN(JPE,JDE-1) - DO I = IPS, MIN(IPE,IDE-1) - nest%fis(I,J)=nest%hres_fis(I,J) - ENDDO - ENDDO + IF ( nest%active_this_task ) THEN + nest%KZMAX=KME + parent%KZMAX=KME ! just for safety + + DO J = JPS, MIN(JPE,JDE-1) + DO I = IPS, MIN(IPE,IDE-1) + nest%fis(I,J)=nest%hres_fis(I,J) + ENDDO + ENDDO !-------------------------------------------------------------------------- ! interpolation call @@ -885,19 +927,22 @@ END SUBROUTINE start_domain ! initialize nest with interpolated data from the parent - nest%imask_nostag = 0 - nest%imask_xstag = 0 - nest%imask_ystag = 0 - nest%imask_xystag = 0 + nest%imask_nostag = 0 + nest%imask_xstag = 0 + nest%imask_ystag = 0 + nest%imask_xystag = 0 + ENDIF -#ifdef HWRF +#if ( HWRF == 1 ) CALL med_interp_domain( parent, nest ) #else CALL domain_clock_get( parent, start_time=strt_time, current_time=cur_time ) IF ( .not. ( config_flags%restart .AND. strt_time .EQ. cur_time ) ) THEN +write(0,*)__FILE__,__LINE__,parent%id,nest%id CALL med_interp_domain( parent, nest ) +write(0,*)__FILE__,__LINE__ ELSE @@ -928,9 +973,14 @@ END SUBROUTINE start_domain ! set some other initial fields, fill out halos, etc. !-------------------------------------------------------------------------------------- - CALL start_domain ( nest, .TRUE.) + IF ( nest%active_this_task) THEN + CALL push_communicators_for_domain( nest%id ) + CALL start_domain ( nest, .TRUE.) + CALL pop_communicators_for_domain + ENDIF + -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing: else for analysis or restart option !zhang test @@ -941,8 +991,12 @@ END SUBROUTINE start_domain CALL nl_set_julyr (nest%id, config_flags%julyr) CALL nl_set_julday ( nest%id , config_flags%julday ) !zhang test ends + IF ( nest%active_this_task) THEN CALL model_to_grid_config_rec ( nest%id , model_config_rec , nest_config_flags ) - CALL med_analysis_out ( nest, nest_config_flags ) + CALL push_communicators_for_domain( nest%id ) + CALL med_analysis_out ( nest, nest_config_flags ) + CALL pop_communicators_for_domain + ENDIF ELSE @@ -951,10 +1005,16 @@ END SUBROUTINE start_domain !------------------------------------------------------------------------------------ !zhang's doing + IF ( nest%active_this_task) THEN IF( nest%analysis .and. .not. config_flags%restart)THEN + CALL push_communicators_for_domain( nest%id ) CALL med_analysis_in ( nest, config_flags ) + CALL pop_communicators_for_domain ELSE IF (config_flags%restart)THEN + CALL push_communicators_for_domain( nest%id ) CALL med_restart_in ( nest, config_flags ) + CALL pop_communicators_for_domain + ENDIF ENDIF !end of zhang's doing @@ -987,7 +1047,12 @@ END SUBROUTINE start_domain ! analysis back to false for future use !-------------------------------------------------------------------------------------- + + IF ( nest%active_this_task) THEN + CALL push_communicators_for_domain( nest%id ) CALL start_domain ( nest, .TRUE.) + CALL pop_communicators_for_domain + ENDIF nest%analysis=.FALSE. CALL nl_set_analysis( nest%id, nest%analysis) @@ -1004,7 +1069,7 @@ END SUBROUTINE start_domain END SUBROUTINE med_nest_initial SUBROUTINE init_domain_constants ( parent , nest ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain IMPLICIT NONE TYPE(domain) :: parent , nest #if (EM_CORE == 1) @@ -1015,9 +1080,9 @@ END SUBROUTINE init_domain_constants SUBROUTINE med_nest_force ( parent , nest ) ! Driver layer - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer ! External USE module_utility @@ -1037,11 +1102,11 @@ SUBROUTINE med_nest_force ( parent , nest ) INTERFACE SUBROUTINE med_force_domain ( parent , nest ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_force_domain SUBROUTINE med_interp_domain ( parent , nest ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_interp_domain #if (NMM_CORE == 1 && NMM_NEST == 1) @@ -1115,10 +1180,12 @@ END SUBROUTINE BASE_STATE_PARENT IF ( .NOT. WRFU_ClockIsStopTime(nest%domain_clock ,rc=rc) ) THEN ! initialize nest with interpolated data from the parent - nest%imask_nostag = 1 - nest%imask_xstag = 1 - nest%imask_ystag = 1 - nest%imask_xystag = 1 + IF ( nest%active_this_task ) THEN + nest%imask_nostag = 1 + nest%imask_xstag = 1 + nest%imask_ystag = 1 + nest%imask_xystag = 1 + ENDIF CALL med_force_domain( parent, nest ) ENDIF @@ -1129,9 +1196,9 @@ END SUBROUTINE med_nest_force SUBROUTINE med_nest_feedback ( parent , nest , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , get_ijk_from_grid + USE module_domain , ONLY : domain , get_ijk_from_grid USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer ! External USE module_utility @@ -1150,7 +1217,7 @@ SUBROUTINE med_nest_feedback ( parent , nest , config_flags ) INTERFACE SUBROUTINE med_feedback_domain ( parent , nest ) - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_feedback_domain END INTERFACE @@ -1159,6 +1226,7 @@ END SUBROUTINE med_feedback_domain IF ( config_flags%feedback .NE. 0 ) THEN CALL med_feedback_domain( parent, nest ) #ifdef MOVE_NESTS + IF ( parent%active_this_task) THEN CALL get_ijk_from_grid ( parent , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -1177,6 +1245,7 @@ END SUBROUTINE med_feedback_domain ENDDO ENDDO #endif + ENDIF #endif END IF @@ -1186,8 +1255,8 @@ END SUBROUTINE med_nest_feedback SUBROUTINE med_last_solve_io ( grid , config_flags ) ! Driver layer USE module_state_description - USE module_domain , ONLY : domain, domain_clock_get - USE module_configure , ONLY : grid_config_rec_type + USE module_domain , ONLY : domain, domain_clock_get + USE module_configure , ONLY : grid_config_rec_type USE module_utility USE module_streams ! Model layer @@ -1199,7 +1268,7 @@ SUBROUTINE med_last_solve_io ( grid , config_flags ) TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags ! Local INTEGER :: rc -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing TYPE(WRFU_Time) :: CurrTime !zhang new INTEGER :: hr, min, sec, ms,julyr,julday @@ -1230,7 +1299,7 @@ SUBROUTINE med_last_solve_io ( grid , config_flags ) ! - RESTART OUTPUT IF( WRFU_AlarmIsRinging( grid%alarms( RESTART_ALARM ), rc=rc ) ) THEN -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing !zhang new CALL ESMF_TimeGet( grid%current_time, YY=julyr, dayOfYear=julday, H=hr, M=min, S=sec, MS=ms, rc=rc) CALL domain_clock_get( grid, current_time=CurrTime ) @@ -1254,7 +1323,7 @@ END SUBROUTINE med_last_solve_io !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#ifdef HWRF +#if ( HWRF == 1 ) !================================================================================== ! Added for the NMM 3d var. This is simply an extension of med_restart_out. ! The file is simply called wrfanal***. This is gopal's doing @@ -1262,11 +1331,11 @@ END SUBROUTINE med_last_solve_io ! SUBROUTINE med_analysis_in ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain, domain_clock_get + USE module_domain , ONLY : domain, domain_clock_get USE module_io_domain USE module_timing ! Model layer - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type USE module_bc_time_utilities !zhang USE WRF_ESMF_MOD @@ -1278,7 +1347,7 @@ SUBROUTINE med_analysis_in ( grid , config_flags ) ! Local LOGICAL, EXTERNAL :: wrf_dm_on_monitor - CHARACTER*80 :: rstname , outname + CHARACTER*256 :: rstname , outname INTEGER :: fid , rid CHARACTER (LEN=256) :: message INTEGER :: ierr @@ -1342,11 +1411,11 @@ END SUBROUTINE med_analysis_in !========================================================================================================= SUBROUTINE med_analysis_out ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain, domain_clock_get + USE module_domain , ONLY : domain, domain_clock_get USE module_io_domain USE module_timing ! Model layer - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type USE module_bc_time_utilities !zhang USE WRF_ESMF_MOD @@ -1358,7 +1427,7 @@ SUBROUTINE med_analysis_out ( grid , config_flags ) ! Local LOGICAL, EXTERNAL :: wrf_dm_on_monitor - CHARACTER*80 :: rstname , outname + CHARACTER*256 :: rstname , outname INTEGER :: fid , rid CHARACTER (LEN=256) :: message INTEGER :: ierr @@ -1405,10 +1474,10 @@ END SUBROUTINE med_analysis_out RECURSIVE SUBROUTINE med_restart_out ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer ! USE module_bc_time_utilities USE module_utility @@ -1421,7 +1490,7 @@ RECURSIVE SUBROUTINE med_restart_out ( grid , config_flags ) ! Local LOGICAL, EXTERNAL :: wrf_dm_on_monitor - CHARACTER*80 :: rstname , outname + CHARACTER*256 :: rstname , outname INTEGER :: fid , rid, kid CHARACTER (LEN=256) :: message INTEGER :: ierr @@ -1471,10 +1540,10 @@ END SUBROUTINE med_restart_out #ifdef EXTRA_HWRF_DEBUG_STUFF SUBROUTINE med_boundary_out ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer ! USE module_bc_time_utilities USE module_utility @@ -1488,7 +1557,7 @@ SUBROUTINE med_boundary_out ( grid , config_flags ) ! Local LOGICAL, EXTERNAL :: wrf_dm_on_monitor - CHARACTER*80 :: rstname , outname + CHARACTER*256 :: rstname , outname INTEGER :: fid , rid, kid CHARACTER (LEN=256) :: message INTEGER :: ierr @@ -1519,16 +1588,16 @@ END SUBROUTINE med_boundary_out #endif !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#ifdef HWRF +#if ( HWRF == 1 ) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !zhang's doing SUBROUTINE med_restart_in ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain, domain_clock_get + USE module_domain , ONLY : domain, domain_clock_get USE module_io_domain USE module_timing ! Model layer - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type USE module_bc_time_utilities IMPLICIT NONE @@ -1539,7 +1608,7 @@ SUBROUTINE med_restart_in ( grid , config_flags ) ! Local LOGICAL, EXTERNAL :: wrf_dm_on_monitor - CHARACTER*80 :: rstname , outname + CHARACTER*256 :: rstname , outname INTEGER :: fid , rid CHARACTER (LEN=256) :: message INTEGER :: ierr @@ -1582,10 +1651,11 @@ END SUBROUTINE med_restart_in SUBROUTINE med_hist_out ( grid , stream, config_flags ) ! Driver layer - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain USE module_timing USE module_io_domain - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type + USE module_dm, ONLY : intercomm_active ! USE module_bc_time_utilities USE module_utility @@ -1596,10 +1666,12 @@ SUBROUTINE med_hist_out ( grid , stream, config_flags ) INTEGER , INTENT(IN) :: stream ! Local LOGICAL, EXTERNAL :: wrf_dm_on_monitor - CHARACTER*80 :: fname, n2 + CHARACTER*256 :: fname, n2 CHARACTER (LEN=256) :: message INTEGER :: ierr + IF ( .NOT. grid%active_this_task ) RETURN + IF ( wrf_dm_on_monitor() ) THEN CALL start_timing END IF @@ -1609,7 +1681,7 @@ SUBROUTINE med_hist_out ( grid , stream, config_flags ) CALL wrf_error_fatal( message ) ENDIF -#ifdef HWRF +#if ( HWRF == 1 ) ! HWRF special: auxhist2 and auxhist3 are duplicates of ! history (0), so there is no point in outputting more than one of ! them at the same time. Prefer 0 over 2, and 2 over 3: @@ -1643,6 +1715,8 @@ SUBROUTINE med_hist_out ( grid , stream, config_flags ) SELECT CASE( stream ) CASE ( HISTORY_ALARM ) IF ( grid%nframes(stream) >= config_flags%frames_per_outfile ) THEN +write(0,*)__FILE__,__LINE__,trim(n2) +write(0,*)__FILE__,__LINE__,' grid%id ',grid%id,' grid%oid ',grid%oid CALL close_dataset ( grid%oid , config_flags , n2 ) grid%oid = 0 grid%nframes(stream) = 0 @@ -1666,8 +1740,8 @@ END SUBROUTINE med_hist_out #if (DA_CORE != 1) SUBROUTINE med_fddaobs_in ( grid , config_flags ) - USE module_domain , ONLY : domain - USE module_configure , ONLY : grid_config_rec_type + USE module_domain , ONLY : domain + USE module_configure , ONLY : grid_config_rec_type IMPLICIT NONE TYPE(domain) :: grid TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags @@ -1678,10 +1752,10 @@ END SUBROUTINE med_fddaobs_in SUBROUTINE med_auxinput_in ( grid , stream, config_flags ) ! Driver layer - USE module_domain , ONLY : domain + USE module_domain , ONLY : domain USE module_io_domain ! Model layer - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! USE module_bc_time_utilities USE module_utility @@ -1721,10 +1795,10 @@ END SUBROUTINE med_auxinput_in SUBROUTINE med_filter_out ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer USE module_bc_time_utilities @@ -1735,7 +1809,7 @@ SUBROUTINE med_filter_out ( grid , config_flags ) TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags LOGICAL, EXTERNAL :: wrf_dm_on_monitor - CHARACTER*80 :: rstname , outname + CHARACTER*256 :: rstname , outname INTEGER :: fid , rid CHARACTER (LEN=256) :: message INTEGER :: ierr @@ -1778,17 +1852,17 @@ END SUBROUTINE med_filter_out SUBROUTINE med_latbound_in ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get, head_grid + USE module_domain , ONLY : domain , domain_clock_get, head_grid USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer ! USE module_bc_time_utilities USE module_utility IMPLICIT NONE -#include +#include "wrf_status_codes.h" ! Arguments TYPE(domain) :: grid @@ -1800,7 +1874,7 @@ SUBROUTINE med_latbound_in ( grid , config_flags ) INTEGER :: idum1 , idum2 , ierr , open_status , fid, rc REAL :: bfrq CHARACTER (LEN=256) :: message - CHARACTER (LEN=80) :: bdyname + CHARACTER (LEN=256) :: bdyname Type (WRFU_Time ) :: startTime, stopTime, currentTime Type (WRFU_TimeInterval ) :: stepTime integer myproc,i,j,k @@ -1808,7 +1882,7 @@ SUBROUTINE med_latbound_in ( grid , config_flags ) CHARACTER(LEN=80) :: timestr #endif -#include +#include "wrf_io_flags.h" CALL wrf_debug ( 200 , 'in med_latbound_in' ) @@ -1818,7 +1892,7 @@ SUBROUTINE med_latbound_in ( grid , config_flags ) IF ( (grid%dfi_opt .EQ. DFI_DDFI .OR. grid%dfi_opt .EQ. DFI_TDFI) .AND. grid%dfi_stage .EQ. DFI_FWD ) RETURN ! #endif - IF ( grid%id .EQ. 1 .AND. config_flags%specified .AND. config_flags%io_form_boundary .GT. 0 ) THEN + IF ( grid%active_this_task .AND. grid%id .EQ. 1 .AND. config_flags%specified .AND. config_flags%io_form_boundary .GT. 0 ) THEN CALL domain_clock_get( grid, current_time=currentTime, & start_time=startTime, & @@ -1912,8 +1986,8 @@ END SUBROUTINE med_latbound_in SUBROUTINE med_setup_step ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain - USE module_configure , ONLY : grid_config_rec_type + USE module_domain , ONLY : domain + USE module_configure , ONLY : grid_config_rec_type ! Model layer IMPLICIT NONE @@ -1942,8 +2016,8 @@ END SUBROUTINE med_setup_step SUBROUTINE med_endup_step ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain - USE module_configure , ONLY : grid_config_rec_type, model_config_rec + USE module_domain , ONLY : domain + USE module_configure , ONLY : grid_config_rec_type, model_config_rec ! Model layer IMPLICIT NONE @@ -1979,10 +2053,10 @@ END SUBROUTINE med_endup_step SUBROUTINE open_aux_u ( grid , config_flags, stream, alarm_id, & auxinput_inname, oid, insub, ierr ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain ! Model layer - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! USE module_bc_time_utilities USE module_utility @@ -1997,7 +2071,8 @@ SUBROUTINE open_aux_u ( grid , config_flags, stream, alarm_id, & EXTERNAL insub INTEGER , INTENT(OUT) :: ierr ! Local - CHARACTER*80 :: fname, n2 + INTEGER :: stream_l + CHARACTER*256 :: fname, n2 CHARACTER (LEN=256) :: message CHARACTER*80 :: timestr TYPE(WRFU_Time) :: ST,CT @@ -2019,14 +2094,11 @@ SUBROUTINE open_aux_u ( grid , config_flags, stream, alarm_id, & ENDIF CALL construct_filename2a ( fname , auxinput_inname, & grid%id , 2 , timestr ) - IF ( stream-first_input .EQ. 10 ) THEN - WRITE(n2,'("DATASET=AUXINPUT10")') - ELSE IF ( stream-first_input .EQ. 11 ) THEN - WRITE(n2,'("DATASET=AUXINPUT11")') - ELSE IF ( stream-first_input .GE. 10 ) THEN - WRITE(n2,'("DATASET=AUXINPUT",I2)')stream-first_input + stream_l = stream-auxinput1_only+1 + IF ( stream_l .GE. 10 ) THEN + WRITE(n2,'("DATASET=AUXINPUT",I2)')stream_l ELSE - WRITE(n2,'("DATASET=AUXINPUT",I1)')stream-first_input + WRITE(n2,'("DATASET=AUXINPUT",I1)')stream_l ENDIF WRITE ( message , '("open_aux_u : opening ",A," for reading. DATASET ",A)') TRIM ( fname ),TRIM(n2) CALL wrf_debug( 1, message ) @@ -2052,10 +2124,10 @@ END SUBROUTINE open_aux_u SUBROUTINE open_hist_w ( grid , config_flags, stream, alarm_id, & hist_outname, oid, outsub, fname, n2, ierr ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain ! Model layer - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! USE module_bc_time_utilities USE module_utility IMPLICIT NONE @@ -2071,6 +2143,7 @@ SUBROUTINE open_hist_w ( grid , config_flags, stream, alarm_id, & INTEGER , INTENT(OUT) :: ierr ! Local INTEGER :: len_n2 + INTEGER :: stream_l CHARACTER (LEN=256) :: message CHARACTER*80 :: timestr TYPE(WRFU_Time) :: ST,CT @@ -2093,12 +2166,13 @@ SUBROUTINE open_hist_w ( grid , config_flags, stream, alarm_id, & ENDIF CALL construct_filename2a ( fname , hist_outname, & grid%id , 2 , timestr ) - IF ( stream-first_history .EQ. history_only ) THEN + stream_l = stream-auxhist1_only+1 + IF ( stream .EQ. history_only ) THEN WRITE(n2,'("DATASET=HISTORY")') - ELSE IF ( stream-first_history .GE. 10 ) THEN - WRITE(n2,'("DATASET=AUXHIST",I2)')stream-first_history + ELSE IF ( stream_l .GE. 10 ) THEN + WRITE(n2,'("DATASET=AUXHIST",I2)')stream_l ELSE - WRITE(n2,'("DATASET=AUXHIST",I1)')stream-first_history + WRITE(n2,'("DATASET=AUXHIST",I1)')stream_l ENDIF IF ( oid .eq. 0 ) THEN WRITE ( message , '("open_hist_w : opening ",A," for writing. ")') TRIM ( fname ) @@ -2130,10 +2204,10 @@ END SUBROUTINE open_hist_w SUBROUTINE med_read_wrf_chem_input ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer USE module_bc_time_utilities #ifdef DM_PARALLEL @@ -2156,9 +2230,9 @@ SUBROUTINE med_read_wrf_chem_input ( grid , config_flags ) REAL :: time, tupdate real, allocatable :: dumc0(:,:,:) CHARACTER (LEN=256) :: message, current_date_char, date_string - CHARACTER (LEN=80) :: inpname + CHARACTER (LEN=256) :: inpname -#include +#include "wrf_io_flags.h" ! IF ( grid%id .EQ. 1 ) THEN CALL domain_clock_get( grid, current_timestr=current_date_char ) @@ -2210,10 +2284,10 @@ END SUBROUTINE med_read_wrf_chem_input !------------------------------------------------------------------------ SUBROUTINE med_read_wrf_chem_emiss ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer USE module_bc_time_utilities #ifdef DM_PARALLEL @@ -2240,9 +2314,9 @@ SUBROUTINE med_read_wrf_chem_emiss ( grid , config_flags ) REAL :: time, tupdate real, allocatable :: dumc0(:,:,:) CHARACTER (LEN=256) :: message, current_date_char, date_string - CHARACTER (LEN=80) :: inpname + CHARACTER (LEN=256) :: inpname -#include +#include "wrf_io_flags.h" CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) @@ -2409,10 +2483,10 @@ END SUBROUTINE med_read_wrf_chem_emiss SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer USE module_bc_time_utilities #ifdef DM_PARALLEL @@ -2435,9 +2509,9 @@ SUBROUTINE med_read_wrf_chem_bioemiss ( grid , config_flags ) REAL :: time, tupdate real, allocatable :: dumc0(:,:,:) CHARACTER (LEN=256) :: message, current_date_char, date_string - CHARACTER (LEN=80) :: inpname + CHARACTER (LEN=256) :: inpname -#include +#include "wrf_io_flags.h" ! IF ( grid%id .EQ. 1 ) THEN CALL domain_clock_get( grid, current_timestr=current_date_char ) @@ -2473,10 +2547,10 @@ END SUBROUTINE med_read_wrf_chem_bioemiss !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SUBROUTINE med_read_wrf_chem_emissopt4 ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer USE module_bc_time_utilities #ifdef DM_PARALLEL @@ -2499,9 +2573,9 @@ SUBROUTINE med_read_wrf_chem_emissopt4 ( grid , config_flags ) REAL :: time, tupdate real, allocatable :: dumc0(:,:,:) CHARACTER (LEN=256) :: message, current_date_char, date_string - CHARACTER (LEN=80) :: inpname + CHARACTER (LEN=256) :: inpname -#include +#include "wrf_io_flags.h" ! IF ( grid%id .EQ. 1 ) THEN CALL domain_clock_get( grid, current_timestr=current_date_char ) @@ -2540,10 +2614,10 @@ END SUBROUTINE med_read_wrf_chem_emissopt4 SUBROUTINE med_read_wrf_chem_dms_emiss ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer USE module_bc_time_utilities #ifdef DM_PARALLEL @@ -2566,9 +2640,9 @@ SUBROUTINE med_read_wrf_chem_dms_emiss ( grid , config_flags ) REAL :: time, tupdate real, allocatable :: dumc0(:,:,:) CHARACTER (LEN=256) :: message, current_date_char, date_string - CHARACTER (LEN=80) :: inpname + CHARACTER (LEN=256) :: inpname -#include +#include "wrf_io_flags.h" ! IF ( grid%id .EQ. 1 ) THEN CALL domain_clock_get( grid, current_timestr=current_date_char ) @@ -2607,10 +2681,10 @@ END SUBROUTINE med_read_wrf_chem_dms_emiss SUBROUTINE med_read_wrf_chem_gocart_bg ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer USE module_bc_time_utilities #ifdef DM_PARALLEL @@ -2633,9 +2707,9 @@ SUBROUTINE med_read_wrf_chem_gocart_bg ( grid , config_flags ) REAL :: time, tupdate real, allocatable :: dumc0(:,:,:) CHARACTER (LEN=256) :: message, current_date_char, date_string - CHARACTER (LEN=80) :: inpname + CHARACTER (LEN=256) :: inpname -#include +#include "wrf_io_flags.h" ! IF ( grid%id .EQ. 1 ) THEN CALL domain_clock_get( grid, current_timestr=current_date_char ) @@ -2678,10 +2752,10 @@ END SUBROUTINE med_read_wrf_chem_gocart_bg SUBROUTINE med_read_wrf_volc_emiss ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer USE module_bc_time_utilities #ifdef DM_PARALLEL @@ -2704,9 +2778,9 @@ SUBROUTINE med_read_wrf_volc_emiss ( grid , config_flags ) REAL :: time, tupdate real, allocatable :: dumc0(:,:,:) CHARACTER (LEN=256) :: message, current_date_char, date_string - CHARACTER (LEN=80) :: inpname + CHARACTER (LEN=256) :: inpname -#include +#include "wrf_io_flags.h" CALL domain_clock_get( grid, current_timestr=current_date_char ) CALL construct_filename1 ( inpname , 'wrfchemv' , grid%id , 2 ) @@ -2740,10 +2814,10 @@ END SUBROUTINE med_read_wrf_volc_emiss !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SUBROUTINE med_read_wrf_chem_emissopt3 ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain , domain_clock_get + USE module_domain , ONLY : domain , domain_clock_get USE module_io_domain USE module_timing - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type ! Model layer USE module_bc_time_utilities #ifdef DM_PARALLEL @@ -2766,9 +2840,9 @@ SUBROUTINE med_read_wrf_chem_emissopt3 ( grid , config_flags ) REAL :: time, tupdate real, allocatable :: dumc0(:,:,:) CHARACTER (LEN=256) :: message, current_date_char, date_string - CHARACTER (LEN=80) :: inpname + CHARACTER (LEN=256) :: inpname -#include +#include "wrf_io_flags.h" ! IF ( grid%id .EQ. 1 ) THEN CALL domain_clock_get( grid, current_timestr=current_date_char ) @@ -2805,15 +2879,15 @@ END SUBROUTINE med_read_wrf_chem_emissopt3 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing for outputing restart namelist parameters RECURSIVE SUBROUTINE med_namelist_out ( grid , config_flags ) ! Driver layer - USE module_domain , ONLY : domain, domain_clock_get + USE module_domain , ONLY : domain, domain_clock_get USE module_io_domain USE module_timing ! Model layer - USE module_configure , ONLY : grid_config_rec_type + USE module_configure , ONLY : grid_config_rec_type USE module_bc_time_utilities !zhang new USE WRF_ESMF_MOD USE module_utility @@ -2831,7 +2905,7 @@ RECURSIVE SUBROUTINE med_namelist_out ( grid , config_flags ) INTEGER :: nout,rc,kid INTEGER :: hr, min, sec, ms,julyr,julday REAL :: GMT - CHARACTER*80 :: prefix, outname + CHARACTER*256 :: prefix, outname CHARACTER*80 :: timestr LOGICAL :: exist LOGICAL,EXTERNAL :: wrf_dm_on_monitor diff --git a/wrfv2_fire/share/mediation_interp_domain.F b/wrfv2_fire/share/mediation_interp_domain.F index 09733308..4497e223 100644 --- a/wrfv2_fire/share/mediation_interp_domain.F +++ b/wrfv2_fire/share/mediation_interp_domain.F @@ -5,6 +5,7 @@ SUBROUTINE med_interp_domain ( parent_grid , nested_grid ) USE module_domain USE module_configure USE module_timing + IMPLICIT NONE TYPE(domain), POINTER :: parent_grid , nested_grid TYPE(domain), POINTER :: grid @@ -39,7 +40,7 @@ SUBROUTINE interp_domain_em_part1 ( grid, intermediate_grid, ngrid, config_flags TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE interp_domain_em_part1 SUBROUTINE interp_domain_em_part2 ( grid, nested_grid, parent_grid, config_flags & @@ -53,7 +54,7 @@ SUBROUTINE interp_domain_em_part2 ( grid, nested_grid, parent_grid, config_flags TYPE(domain), POINTER :: nested_grid TYPE(domain), POINTER :: parent_grid !KAL added for vertical nesting TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE interp_domain_em_part2 #endif ! ---------------------------------------------------------- @@ -75,7 +76,7 @@ SUBROUTINE interp_domain_nmm_part1 ( grid, intermediate_grid, ngrid, config_flag TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE interp_domain_nmm_part1 SUBROUTINE interp_domain_nmm_part2 ( grid, nested_grid, config_flags & @@ -88,7 +89,7 @@ SUBROUTINE interp_domain_nmm_part2 ( grid, nested_grid, config_flags & TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: nested_grid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE interp_domain_nmm_part2 !======================================================================= @@ -117,11 +118,14 @@ END SUBROUTINE interp_domain_nmm_part2 ! from the external communications package (e.g. RSL) ! ---------------------------------------------------------- #if (EM_CORE == 1 && defined( DM_PARALLEL )) + + CALL wrf_dm_nestexchange_init + CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) grid => nested_grid%intermediate_grid -# if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10)))) +# if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) - CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & + CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , nested_grid%active_this_task, & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & @@ -140,6 +144,7 @@ END SUBROUTINE interp_domain_nmm_part2 # include "actual_new_args.inc" ! ) + IF ( nested_grid%active_this_task ) THEN grid => nested_grid%intermediate_grid CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) @@ -148,11 +153,14 @@ END SUBROUTINE interp_domain_nmm_part2 # include "actual_new_args.inc" ! ) + ENDIF grid => nested_grid%intermediate_grid CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) -# if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10)))) - CALL dealloc_space_field ( grid ) +# if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) + IF ( grid%active_this_task ) THEN + CALL dealloc_space_field ( grid ) + ENDIF # endif #endif ! ------------------------------------------------------ @@ -167,11 +175,12 @@ END SUBROUTINE interp_domain_nmm_part2 ! Added for the NMM core. This is gopal's doing. !======================================================================= ! + CALL wrf_dm_nestexchange_init CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) grid => nested_grid%intermediate_grid -# if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10)))) - CALL ensure_space_field & - ( grid, grid%id , 1 , 2 , .TRUE. , & +# if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) + CALL ensure_space_field & + ( grid, grid%id , 1 , 2 , .TRUE. , nested_grid%active_this_task, & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & @@ -198,6 +207,7 @@ END SUBROUTINE interp_domain_nmm_part2 ) grid => nested_grid%intermediate_grid CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + IF ( nested_grid%active_this_task ) THEN CALL interp_domain_nmm_part2 ( grid, nested_grid, config_flags & ! @@ -207,6 +217,7 @@ END SUBROUTINE interp_domain_nmm_part2 grid => nested_grid%intermediate_grid CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) + ENDIF ! ------------------------------------------------------------ ! End of gopal's doing ! ------------------------------------------------------------ @@ -214,22 +225,6 @@ END SUBROUTINE interp_domain_nmm_part2 ! ------------------------------------------------------ ! End of Interpolation calls for NMM. ! ------------------------------------------------------ -! ------------------------------------------------------ -! ------------------------------------------------------ -! Interpolation calls for COAMPS. (Placeholder) -! ------------------------------------------------------ -#if (COAMPS_CORE == 1) -#endif -! ------------------------------------------------------ -! End of Interpolation calls for COAMPS. -! ------------------------------------------------------ -#ifdef NMM_FIND_LOAD_IMBALANCE - this_time=now_time()-this_time - total_time(parent_grid%id)=total_time(parent_grid%id)+this_time -30 format('med_interp_domain for grid ',I0,' to grid ',I0,': ',F12.6,'s; running total: ',F12.6,'s') - write(message,30) parent_grid%id,nested_grid%id,this_time,total_time(parent_grid%id) - call wrf_debug(1,message) -#endif RETURN END SUBROUTINE med_interp_domain @@ -238,6 +233,9 @@ SUBROUTINE med_interp_domain_small ( parent_grid , nested_grid ) USE module_domain USE module_configure USE module_timing +#if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) + USE module_dm, ONLY : intercomm_active +#endif IMPLICIT NONE TYPE(domain), POINTER :: parent_grid , nested_grid TYPE(domain), POINTER :: grid @@ -258,7 +256,7 @@ SUBROUTINE interp_domain_em_small_part1 ( grid, intermediate_grid, ngrid, config TYPE(domain), POINTER :: intermediate_grid TYPE(domain), POINTER :: ngrid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE interp_domain_em_small_part1 SUBROUTINE interp_domain_em_small_part2 ( grid, nested_grid, config_flags & @@ -271,7 +269,7 @@ SUBROUTINE interp_domain_em_small_part2 ( grid, nested_grid, config_flags & TYPE(domain), POINTER :: grid ! name of the grid being dereferenced (must be "grid") TYPE(domain), POINTER :: nested_grid TYPE (grid_config_rec_type) :: config_flags -# include +# include "dummy_new_decl.inc" END SUBROUTINE interp_domain_em_small_part2 #endif END INTERFACE @@ -285,9 +283,9 @@ END SUBROUTINE interp_domain_em_small_part2 #if (EM_CORE == 1 && defined( DM_PARALLEL )) CALL model_to_grid_config_rec ( nested_grid%id , model_config_rec , config_flags ) grid => nested_grid%intermediate_grid -# if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10)))) +# if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) - CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , & + CALL alloc_space_field ( grid, grid%id , 1 , 2 , .TRUE. , nested_grid%active_this_task, & grid%sd31, grid%ed31, grid%sd32, grid%ed32, grid%sd33, grid%ed33, & grid%sm31, grid%em31, grid%sm32, grid%em32, grid%sm33, grid%em33, & grid%sp31, grid%ep31, grid%sp32, grid%ep32, grid%sp33, grid%ep33, & @@ -316,8 +314,10 @@ END SUBROUTINE interp_domain_em_small_part2 grid => nested_grid%intermediate_grid CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags ) -# if (defined(MOVE_NESTS) || (!defined(SGIALTIX) && (!defined(FUJITSU_FX10)))) +# if (defined(MOVE_NESTS) || ((!defined(KEEP_INT_AROUND)) && (!defined(SGIALTIX)) && (!defined(FUJITSU_FX10)))) + IF ( intercomm_active( grid%id ) ) THEN CALL dealloc_space_field ( grid ) + ENDIF # endif #endif ! ------------------------------------------------------ diff --git a/wrfv2_fire/share/mediation_nest_move.F b/wrfv2_fire/share/mediation_nest_move.F index 2c937638..d324ab7b 100644 --- a/wrfv2_fire/share/mediation_nest_move.F +++ b/wrfv2_fire/share/mediation_nest_move.F @@ -2,24 +2,28 @@ SUBROUTINE med_nest_move ( parent, nest ) ! Driver layer USE module_domain, ONLY : domain, get_ijk_from_grid, adjust_domain_dims_for_move + USE module_driver_constants, ONLY : max_nests USE module_utility USE module_timing USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec USE module_state_description ! USE module_io_domain - USE module_dm, ONLY : wrf_dm_move_nest +#if defined(DM_PARALLEL) && ! defined(STUBMPI) + USE module_dm, ONLY : wrf_dm_move_nest,nest_task_offsets,mpi_comm_to_kid,mpi_comm_to_mom, which_kid +#endif + IMPLICIT NONE TYPE(domain) , POINTER :: parent, nest, grid - INTEGER dx, dy ! number of parent domain points to move + INTEGER dx, dy, origdy ! number of parent domain points to move #ifdef MOVE_NESTS ! Local CHARACTER*256 mess - INTEGER i, j, p, parent_grid_ratio + INTEGER i, j, k, p, parent_grid_ratio INTEGER px, py ! number and direction of nd points to move INTEGER :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe - INTEGER ierr, fid -#ifdef HWRF + INTEGER ierr, fid, comzilla, kid +#if ( HWRF == 1 ) REAL,PARAMETER :: con_g =9.80665e+0! gravity (m/s2) REAL,PARAMETER :: con_rd =2.8705e+2 ! gas constant air (J/kg/K) REAL :: TLAP,TBAR,EPSI @@ -29,9 +33,9 @@ SUBROUTINE med_nest_move ( parent, nest ) TYPE (grid_config_rec_type) :: config_flags LOGICAL, EXTERNAL :: wrf_dm_on_monitor LOGICAL, EXTERNAL :: should_not_move -#ifdef HWRF +#if ( HWRF == 1 ) !XUEJIN added for HWRFx - INTEGER :: k,idum1,idum2 + INTEGER :: idum1,idum2 INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE #else ! @@ -43,7 +47,7 @@ SUBROUTINE med_interp_domain ( parent , nest ) IMPLICIT NONE TYPE(domain) , POINTER :: parent , nest END SUBROUTINE med_interp_domain -!#ifdef HWRFX +!#if ( HWRF == 1 )X ! XUEJIN added this directive here to exclude the ARW code !#else SUBROUTINE start_domain ( grid , allowed_to_move ) @@ -56,7 +60,7 @@ END SUBROUTINE start_domain #if ( EM_CORE == 1 ) SUBROUTINE shift_domain_em ( grid, disp_x, disp_y & ! -# include +# include "dummy_new_args.inc" ! ) USE module_domain, ONLY : domain @@ -64,7 +68,7 @@ SUBROUTINE shift_domain_em ( grid, disp_x, disp_y & IMPLICIT NONE INTEGER disp_x, disp_y TYPE(domain) , POINTER :: grid -# include +# include "dummy_new_decl.inc" END SUBROUTINE shift_domain_em #endif #if ( NMM_CORE == 1 ) @@ -89,7 +93,7 @@ SUBROUTINE BASE_STATE_PARENT ( Z3d,Q3d,T3d,PSTD, & IMS,IME,JMS,JME,KMS,KME, & IPS,IPE,JPS,JPE,KPS,KPE ) ! -#ifdef HWRF +#if ( HWRF == 1 ) !XUEJIN added for HWRFx USE MODULE_MODEL_CONSTANTS #else @@ -124,17 +128,17 @@ END SUBROUTINE med_init_domain_constants_nmm SUBROUTINE shift_domain_nmm ( grid, disp_x, disp_y & ! -# include +# include "dummy_new_args.inc" ! ) USE module_domain IMPLICIT NONE INTEGER disp_x, disp_y TYPE(domain) , POINTER :: grid -#include +#include "dummy_new_decl.inc" END SUBROUTINE shift_domain_nmm #endif -#ifdef HWRF +#if ( HWRF == 1 ) ! XUEJIN added this directive here to exclude the ARW code #else LOGICAL FUNCTION time_for_move ( parent , nest , dx , dy ) @@ -145,7 +149,7 @@ LOGICAL FUNCTION time_for_move ( parent , nest , dx , dy ) END FUNCTION time_for_move #endif -#ifdef HWRF +#if ( HWRF == 1 ) #if (NMM_CORE == 1 && NMM_NEST == 1) ! LOGICAL FUNCTION nest_roam ( parent , nest , dx , dy ) !REPLACED BY KWON ! @@ -160,7 +164,7 @@ END FUNCTION direction_of_move #endif #endif -#ifdef HWRF +#if ( HWRF == 1 ) ! XUEJIN added this directive here to exclude the ARW code #else SUBROUTINE input_terrain_rsmas ( grid , & @@ -219,7 +223,7 @@ END SUBROUTINE copy_3d_field ! mask should be defined in nest domain -#ifdef HWRF +#if ( HWRF == 1 ) check_direction_of_move: IF ( direction_of_move ( parent , nest , dx, dy ) ) THEN #else check_for_move: IF ( time_for_move ( parent , nest , dx, dy ) ) THEN @@ -234,8 +238,9 @@ END SUBROUTINE copy_3d_field #endif #if (NMM_CORE == 1 && NMM_NEST == 1) IF(MOD(dy,2) .NE. 0)THEN + origdy = dy dy=dy+sign(1,dy) - WRITE(mess,*)'WARNING: DY REDEFINED FOR THE NMM CORE AND RE-SET TO MASS POINT dy=',dy + WRITE(mess,*)'WARNING: DY REDEFINED FOR THE NMM CORE AND RE-SET FROM ',origdy,' TO MASS POINT dy=',dy call wrf_debug(1,mess) ENDIF @@ -270,14 +275,14 @@ END SUBROUTINE copy_3d_field #if ( EM_CORE == 1 ) CALL shift_domain_em( grid, dx, dy & ! -# include +# include "actual_new_args.inc" ! ) #endif #if (NMM_CORE == 1 && NMM_NEST == 1) CALL shift_domain_nmm( grid, dx, dy & ! -# include +# include "actual_new_args.inc" ! ) #endif @@ -286,15 +291,30 @@ END SUBROUTINE copy_3d_field py = grid%parent_grid_ratio*dy grid%i_parent_start = grid%i_parent_start + px / grid%parent_grid_ratio - CALL nl_set_i_parent_start( grid%id, grid%i_parent_start ) grid%j_parent_start = grid%j_parent_start + py / grid%parent_grid_ratio + +#if defined(DM_PARALLEL) && ! defined(STUBMPI) + IF ( (parent%active_this_task .OR. grid%active_this_task) ) THEN + IF ( parent%active_this_task ) THEN + comzilla = mpi_comm_to_kid( which_kid( grid%id ) , parent%id ) + ELSE + comzilla = mpi_comm_to_mom( grid%id ) + ENDIF + CALL BYTE_BCAST_FROM_ROOT( grid%i_parent_start, IWORDSIZE, nest_task_offsets(nest%id), comzilla ) ! + CALL BYTE_BCAST_FROM_ROOT( grid%j_parent_start, IWORDSIZE, nest_task_offsets(nest%id), comzilla ) ! + ENDIF + + CALL nl_set_i_parent_start( grid%id, grid%i_parent_start ) CALL nl_set_j_parent_start( grid%id, grid%j_parent_start ) + CALL push_communicators_for_domain(grid%id) IF ( wrf_dm_on_monitor() ) THEN write(mess,*) & 'Grid ',grid%id,' New SW corner (in parent x and y):',grid%i_parent_start, grid%j_parent_start CALL wrf_message(TRIM(mess)) ENDIF + CALL pop_communicators_for_domain(grid%id) +#endif #if (NMM_CORE == 1 && NMM_NEST == 1) @@ -324,7 +344,8 @@ END SUBROUTINE copy_3d_field ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe ) -#ifdef HWRF + IF ( nest%active_this_task ) THEN +#if ( HWRF == 1 ) ! adjust pint & pressure depth due to height change in nest_terrain ! assume lapse rate of 6.1K/1km TLAP=6.1/(con_g*1000.) @@ -351,6 +372,7 @@ END SUBROUTINE copy_3d_field nest%fis(I,J)=nest%hres_fis(I,J) ENDDO ENDDO + ENDIF ! ! De-reference dimension information stored in the grid data structure. @@ -399,6 +421,7 @@ END SUBROUTINE copy_3d_field CALL nl_get_input_from_hires( nest%id , input_from_hires ) IF ( input_from_hires ) THEN + IF ( nest%active_this_task ) THEN ! store horizontally interpolated terrain in temp location CALL copy_3d_field ( nest%ht_fine , nest%ht , & ids , ide , jds , jde , 1 , 1 , & @@ -430,6 +453,7 @@ END SUBROUTINE copy_3d_field ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & ips , ipe , jps , jpe , kps , kpe ) + ENDIF ! CALL model_to_grid_config_rec ( parent%id , model_config_rec , config_flags ) @@ -475,7 +499,15 @@ END SUBROUTINE copy_3d_field #if ( EM_CORE == 1 ) nest%press_adj = .FALSE. #endif - CALL start_domain ( nest , .FALSE. ) + +#if defined(DM_PARALLEL) && ! defined(STUBMPI) + + IF ( nest%active_this_task ) THEN + CALL push_communicators_for_domain(nest%id) + CALL start_domain ( nest , .FALSE. ) + CALL pop_communicators_for_domain + ENDIF +#endif config_flags%restart = saved_restart_value grid%restart = saved_restart_value CALL nl_set_restart ( 1, saved_restart_value ) @@ -486,6 +518,7 @@ END SUBROUTINE copy_3d_field ! this should be registry generated. ! #if ( EM_CORE == 1 ) + IF ( nest%active_this_task ) THEN do k = kms,kme where ( nest%imask_xstag .EQ. 1 ) nest%u_1(:,k,:) = nest%u_2(:,k,:) where ( nest%imask_ystag .EQ. 1 ) nest%v_1(:,k,:) = nest%v_2(:,k,:) @@ -495,9 +528,10 @@ END SUBROUTINE copy_3d_field where ( nest%imask_nostag .EQ. 1 ) nest%tke_1(:,k,:) = nest%tke_2(:,k,:) enddo where ( nest%imask_nostag .EQ. 1 ) nest%mu_1(:,:) = nest%mu_2(:,:) + ENDIF #endif ! -#ifdef HWRF +#if ( HWRF == 1 ) ENDIF check_direction_of_move #else ENDIF check_for_move @@ -637,6 +671,16 @@ LOGICAL FUNCTION time_for_move2 ( parent , grid , move_cd_x, move_cd_y ) ids, ide-1 , jds , jde-1 , 1 , 1 , & ims, ime , jms , jme , 1 , 1 , & ips, ipe , jps , jpe , 1 , 1 ) +#if(NMM_CORE==1) + CALL wrf_patch_to_global_real ( grid%hlat , xlat , grid%domdesc, "z", "xy", & + ids, ide-1 , jds , jde-1 , 1 , 1 , & + ims, ime , jms , jme , 1 , 1 , & + ips, ipe , jps , jpe , 1 , 1 ) + CALL wrf_patch_to_global_real ( grid%hlon , xlong , grid%domdesc, "z", "xy", & + ids, ide-1 , jds , jde-1 , 1 , 1 , & + ims, ime , jms , jme , 1 , 1 , & + ips, ipe , jps , jpe , 1 , 1 ) +#else CALL wrf_patch_to_global_real ( grid%xlat , xlat , grid%domdesc, "z", "xy", & ids, ide-1 , jds , jde-1 , 1 , 1 , & ims, ime , jms , jme , 1 , 1 , & @@ -645,6 +689,7 @@ LOGICAL FUNCTION time_for_move2 ( parent , grid , move_cd_x, move_cd_y ) ids, ide-1 , jds , jde-1 , 1 , 1 , & ims, ime , jms , jme , 1 , 1 , & ips, ipe , jps , jpe , 1 , 1 ) +#endif CALL wrf_patch_to_global_real ( grid%ht , terrain , grid%domdesc, "z", "xy", & ids, ide-1 , jds , jde-1 , 1 , 1 , & ims, ime , jms , jme , 1 , 1 , & @@ -1124,8 +1169,9 @@ END FUNCTION time_for_move2 CALL wrf_dm_move_nest ( grid , grid%nests(kid)%ptr%intermediate_grid , -move_cd_x*pgr, -move_cd_y*pgr ) CALL adjust_domain_dims_for_move( grid%nests(kid)%ptr%intermediate_grid , -move_cd_x*pgr, -move_cd_y*pgr ) grid%nests(kid)%ptr%i_parent_start = grid%nests(kid)%ptr%i_parent_start - move_cd_x*pgr - CALL nl_set_i_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%i_parent_start ) grid%nests(kid)%ptr%j_parent_start = grid%nests(kid)%ptr%j_parent_start - move_cd_y*pgr + + CALL nl_set_i_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%i_parent_start ) CALL nl_set_j_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%j_parent_start ) ENDIF @@ -1190,7 +1236,7 @@ LOGICAL FUNCTION should_not_move ( id ) should_not_move = retval END FUNCTION -#ifdef HWRF +#if ( HWRF == 1 ) LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y ) USE module_domain USE module_configure @@ -1202,7 +1248,7 @@ LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y ) INTEGER, INTENT(OUT) :: move_cd_x , move_cd_y CHARACTER*256 mess ! local - INTEGER :: coral_dist, ikid + INTEGER :: corral_dist, ikid INTEGER :: dw, de, ds, dn, idum, jdum INTEGER :: cids, cide, cjds, cjde, ckds, ckde, & cims, cime, cjms, cjme, ckms, ckme, & @@ -1212,8 +1258,9 @@ LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y ) nips, nipe, njps, njpe, nkps, nkpe real :: dx,dy,kid_ic,kid_jc,my_ic,my_jc,pgr,pgrn,hr,two_dt,when,before,after real, parameter :: pmult=1.35 - integer :: inew,jnew - logical :: abort + integer :: inew,jnew,ierr,comzilla,itmp_pos,itmp_neg + integer :: corral_x, corral_y, min_corral_x, min_corral_y + logical :: abort,mvnest_l ! PURPOSE: DECIDE THE DIRECTION OF MOVE ! Three modes: @@ -1239,12 +1286,15 @@ LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y ) ! MODIFIED: SAM TRAHAN, April 1, 2011 to add vortex_tracker, and the ! nest-following vortex tracker (option 2) - + if(grid%id==1) then + min_corral_x=7 + min_corral_y=12 + else + min_corral_x=5 + min_corral_y=5 + endif abort=.false. ! will be set to .true. if any safety checks fail - - - ! INITIALIZE NEST MOTION TO DISABLED move_cd_x=0 move_cd_y=0 @@ -1276,23 +1326,26 @@ LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y ) ! SWITCH OFF NEST MOTION IF TOO CLOSE TO ANY OF THE BOUNDARIES - coral_dist=(grid%ed31+grid%parent_grid_ratio-1)/grid%parent_grid_ratio - IF(grid%i_parent_start .le. 5) then + corral_x = max(min_corral_x,grid%corral_x) + corral_y = max(min_corral_y,grid%corral_y) + + corral_dist=(grid%ed31+grid%parent_grid_ratio-1)/grid%parent_grid_ratio + IF(grid%i_parent_start .le. corral_x) then abort=.true. write(mess,'("d",I0,": cannot move: too close to parent d",I0," -X boundary")') grid%id,parent%id call wrf_message(trim(mess)) - ELSEIF((grid%i_parent_start+coral_dist) .ge. parent%ed31 - 5)THEN + ELSEIF((grid%i_parent_start+corral_dist) .ge. parent%ed31 - corral_x)THEN abort=.true. write(mess,'("d",I0,": cannot move: too close to parent d",I0," +X boundary")') grid%id,parent%id call wrf_message(trim(mess)) ENDIF - coral_dist=(grid%ed32+grid%parent_grid_ratio-1)/grid%parent_grid_ratio - IF(grid%j_parent_start .le. 5) THEN + corral_dist=(grid%ed32+grid%parent_grid_ratio-1)/grid%parent_grid_ratio + IF(grid%j_parent_start .le. corral_y) THEN abort=.true. write(mess,'("d",I0,": cannot move: too close to parent d",I0," -Y boundary")') grid%id,parent%id call wrf_message(trim(mess)) - ELSEIF((grid%j_parent_start+coral_dist) .ge. parent%ed32 - 5)THEN + ELSEIF((grid%j_parent_start+corral_dist) .ge. parent%ed32 - corral_y)THEN abort=.true. write(mess,'("d",I0,": cannot move: too close to parent d",I0," +Y boundary")') grid%id,parent%id call wrf_message(trim(mess)) @@ -1300,6 +1353,20 @@ LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y ) ! ! DETERMINE AUTOMATICALLY THE DIRECTION OF GRID MOTION ! + + IF ( .NOT. grid%active_this_task ) grid%mvnest = .FALSE. ! prevent inactive grids from turning on movement + IF ( (parent%active_this_task .OR. grid%active_this_task) ) THEN + IF ( parent%active_this_task ) THEN + comzilla = mpi_comm_to_kid( which_kid( grid%id ) , parent%id ) + ELSE + comzilla = mpi_comm_to_mom( grid%id ) + ENDIF + CALL MPI_Allreduce( grid%mvnest , mvnest_l, 1, MPI_LOGICAL, MPI_LOR, comzilla, ierr ) + grid%mvnest = mvnest_l + ENDIF + + CALL push_communicators_for_domain(grid%id) + can_move: if(grid%num_moves.eq.-99 .and. grid%mvnest .and. .not. abort) then if(wrf_dm_on_monitor() .and. .not. abort) then @@ -1441,7 +1508,7 @@ LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y ) endif can_move ! Abort motion if any child domain would end up within this - ! domain's coral distance or outside of this domain. + ! domain's corral distance or outside of this domain. nest_safety: IF ( grid%num_nests .GT. 0 .and. ( move_cd_x/=0 .or. move_cd_y/=0 ) ) THEN abort=.false. nest_loop: do ikid=1,grid%num_nests @@ -1449,23 +1516,25 @@ LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y ) inew=kid%i_parent_start-move_cd_x*kid%parent_grid_ratio jnew=kid%j_parent_start-move_cd_y*kid%parent_grid_ratio - coral_dist=(kid%ed31+kid%parent_grid_ratio-1)/kid%parent_grid_ratio - IF(inew <= 5)THEN + corral_dist=(kid%ed31+kid%parent_grid_ratio-1)/kid%parent_grid_ratio + corral_x = max(min_corral_x,grid%corral_x) + corral_y = max(min_corral_y,grid%corral_y) + IF(inew <= corral_x)THEN abort=.true. write(mess,'("d",I0,": cannot move: nest d",I0," would be too close to -X bdy")') grid%id,kid%id call wrf_message(mess) - ELSEIF((inew+coral_dist) >= grid%ed31 - 5) THEN + ELSEIF((inew+corral_dist) >= grid%ed31 - corral_x) THEN abort=.true. write(mess,'("d",I0,": cannot move: nest d",I0," would be too close to +X bdy")') grid%id,kid%id call wrf_message(mess) ENDIF - coral_dist=(kid%ed32+kid%parent_grid_ratio-1)/kid%parent_grid_ratio - IF(jnew .le. 5)THEN + corral_dist=(kid%ed32+kid%parent_grid_ratio-1)/kid%parent_grid_ratio + IF(jnew .le. corral_y)THEN abort=.true. write(mess,'("d",I0,": cannot move: nest d",I0," would be too close to -Y bdy")') grid%id,kid%id call wrf_message(mess) - ELSEIF((jnew+coral_dist) .ge. grid%ed32 - 5) THEN + ELSEIF((jnew+corral_dist) .ge. grid%ed32 - corral_y) THEN abort=.true. write(mess,'("d",I0,": cannot move: nest d",I0," would be too close to +Y bdy")') grid%id,kid%id call wrf_message(mess) @@ -1484,6 +1553,31 @@ LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y ) call wrf_message(mess) endif + IF ( .NOT. grid%active_this_task ) THEN + grid%mvnest = .FALSE. ! prevent inactive grids from turning on movement + grid%move_cd_x = 0 + grid%move_cd_y = 0 + ENDIF + + IF ( (parent%active_this_task .OR. grid%active_this_task) ) THEN + CALL MPI_Allreduce( grid%mvnest , mvnest_l, 1, MPI_LOGICAL, MPI_LOR, comzilla, ierr ) + grid%mvnest = mvnest_l + CALL MPI_Allreduce( move_cd_x , itmp_pos, 1, MPI_INTEGER, MPI_MAX, comzilla, ierr ) + CALL MPI_Allreduce( move_cd_x , itmp_neg, 1, MPI_INTEGER, MPI_MIN, comzilla, ierr ) + IF ( itmp_pos .NE. 0 ) THEN + move_cd_x = itmp_pos + ELSE + move_cd_x = itmp_neg + ENDIF + CALL MPI_Allreduce( move_cd_y , itmp_pos, 1, MPI_INTEGER, MPI_MAX, comzilla, ierr ) + CALL MPI_Allreduce( move_cd_y , itmp_neg, 1, MPI_INTEGER, MPI_MIN, comzilla, ierr ) + IF ( itmp_pos .NE. 0 ) THEN + move_cd_y = itmp_pos + ELSE + move_cd_y = itmp_neg + ENDIF + ENDIF + if(move_cd_x/=0 .or. move_cd_y/=0) then direction_of_move2 = .true. grid%moved = .true. @@ -1493,6 +1587,8 @@ LOGICAL FUNCTION direction_of_move2 ( parent , grid , move_cd_x, move_cd_y ) ! other vortex trackers set NTIME0 in STATS_FOR_MOVE endif endif + + CALL pop_communicators_for_domain(grid%id) RETURN @@ -1522,9 +1618,11 @@ LOGICAL FUNCTION direction_of_move ( parent , grid , move_cd_x, move_cd_y ) nids, nide, njds, njde, nkds, nkde, & nims, nime, njms, njme, nkms, nkme, & nips, nipe, njps, njpe, nkps, nkpe - INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE - INTEGER :: IMS,IME,JMS,JME,KMS,KME - INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE + INTEGER :: IDS,IDE,JDS,JDE,KDS,KDE + INTEGER :: IMS,IME,JMS,JME,KMS,KME + INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE + INTEGER :: IpS,IpE,JpS,JpE,KpS,KpE + INTEGER comzilla character*255 :: message ! interface INTERFACE @@ -1596,6 +1694,21 @@ end subroutine init_hnear direction_of_move = direction_of_move2 ( parent , grid , move_cd_x, move_cd_y ) +! any nest grid needs to know if grid is moving + IF ( grid%id .GT. 1 .AND. grid%num_nests .GT. 0 ) THEN + IF ( (.NOT. (grid%active_this_task .AND. grid%nests(kid)%ptr%active_this_task) ) .AND. & + (grid%active_this_task .OR. grid%nests(kid)%ptr%active_this_task) ) THEN + IF ( grid%active_this_task ) THEN + comzilla = mpi_comm_to_kid( kid , grid%id ) + ELSE + comzilla = mpi_comm_to_mom( grid%nests(kid)%ptr%id ) + ENDIF + CALL BYTE_BCAST( move_cd_x, IWORDSIZE, comzilla ) ! + CALL BYTE_BCAST( move_cd_y, IWORDSIZE, comzilla ) ! + ENDIF + direction_of_move = ( move_cd_x .NE. 0 ) .OR. ( move_cd_y .NE. 0 ) + ENDIF + if(grid%vortex_tracker == 1) then return ! Old HWRF tracker has nothing more to do. endif @@ -1630,13 +1743,26 @@ end subroutine init_hnear cims, cime, cjms, cjme, ckms, ckme, & cips, cipe, cjps, cjpe, ckps, ckpe ) CALL nl_get_parent_grid_ratio ( grid%nests(kid)%ptr%id , pgr ) + ! need to adjust the intermediate domain of the nest in relation to this + ! domain since we're moving + IF(MOD(move_cd_y,2) .NE. 0)THEN + move_cd_y=move_cd_y+sign(1,move_cd_y) + WRITE(message,*)'WARNING: move_cd_y REDEFINED FOR THE NMM CORE AND RE-SET TO MASS POINT move_cd_y=',move_cd_y + call wrf_debug(1,message) + ENDIF + + IF (grid%active_this_task .OR. grid%nests(kid)%ptr%active_this_task ) THEN + IF ( grid%active_this_task ) THEN + comzilla = mpi_comm_to_kid( kid , grid%id ) + ELSE + comzilla = mpi_comm_to_mom( grid%nests(kid)%ptr%id ) + ENDIF + + CALL BYTE_BCAST( grid%nests(kid)%ptr%i_parent_start, IWORDSIZE, comzilla ) ! + CALL BYTE_BCAST( grid%nests(kid)%ptr%j_parent_start, IWORDSIZE, comzilla ) ! + CALL BYTE_BCAST( move_cd_x, IWORDSIZE, comzilla ) ! + CALL BYTE_BCAST( move_cd_y, IWORDSIZE, comzilla ) ! - ! need to adjust the intermediate domain of the nest in relation to this - ! domain since we're moving - IF(MOD(move_cd_y,2) .NE. 0)THEN - move_cd_y=move_cd_y+sign(1,move_cd_y) - WRITE(message,*)'WARNING: move_cd_y REDEFINED FOR THE NMM CORE AND RE-SET TO MASS POINT move_cd_y=',move_cd_y - call wrf_debug(1,message) ENDIF CALL wrf_dm_move_nest ( grid , grid%nests(kid)%ptr%intermediate_grid , -move_cd_x*pgr, -move_cd_y*pgr ) @@ -1644,56 +1770,60 @@ end subroutine init_hnear grid%nests(kid)%ptr%i_parent_start = grid%nests(kid)%ptr%i_parent_start - move_cd_x*pgr write(message,*)'grid%nests(kid)%ptr%i_parent_start =',grid%nests(kid)%ptr%i_parent_start,grid%nests(kid)%ptr%id call wrf_debug(1,message) - CALL nl_set_i_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%i_parent_start ) + grid%nests(kid)%ptr%j_parent_start = grid%nests(kid)%ptr%j_parent_start - move_cd_y*pgr write(message,*)'grid%nests(kid)%ptr%j_parent_start =',grid%nests(kid)%ptr%j_parent_start,grid%nests(kid)%ptr%id call wrf_debug(1,message) + + CALL nl_set_i_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%i_parent_start ) CALL nl_set_j_parent_start( grid%nests(kid)%ptr%id, grid%nests(kid)%ptr%j_parent_start ) - IDS = grid%nests(kid)%ptr%sd31 - IDE = grid%nests(kid)%ptr%ed31 - JDS = grid%nests(kid)%ptr%sd32 - JDE = grid%nests(kid)%ptr%ed32 - KDS = grid%nests(kid)%ptr%sd33 - KDE = grid%nests(kid)%ptr%ed33 - - IMS = grid%nests(kid)%ptr%sm31 - IME = grid%nests(kid)%ptr%em31 - JMS = grid%nests(kid)%ptr%sm32 - JME = grid%nests(kid)%ptr%em32 - KMS = grid%nests(kid)%ptr%sm33 - KME = grid%nests(kid)%ptr%em33 - - ITS = grid%nests(kid)%ptr%sp31 - ITE = grid%nests(kid)%ptr%ep31 - JTS = grid%nests(kid)%ptr%sp32 - JTE = grid%nests(kid)%ptr%ep32 - KTS = grid%nests(kid)%ptr%sp33 - KTE = grid%nests(kid)%ptr%ep33 - - CALL G2T2H_new( grid%nests(kid)%ptr%IIH,grid%nests(kid)%ptr%JJH, & ! output grid index in parent grid - grid%nests(kid)%ptr%HBWGT1,grid%nests(kid)%ptr%HBWGT2, & ! output weights in terms of parent grid - grid%nests(kid)%ptr%HBWGT3,grid%nests(kid)%ptr%HBWGT4, & - grid%nests(kid)%ptr%I_PARENT_START,grid%nests(kid)%ptr%J_PARENT_START, & ! nest start I, J in parent domain - 3, & ! Ratio of parent and child grid ( always = 3 for NMM) - IDS,IDE,JDS,JDE,KDS,KDE, & ! target (nest) dimensions - IMS,IME,JMS,JME,KMS,KME, & - ITS,ITE,JTS,JTE,KTS,KTE ) - CALL G2T2V_new( grid%nests(kid)%ptr%IIV,grid%nests(kid)%ptr%JJV, & ! output grid index in parent grid - grid%nests(kid)%ptr%VBWGT1,grid%nests(kid)%ptr%VBWGT2, & ! output weights in terms of parent grid - grid%nests(kid)%ptr%VBWGT3,grid%nests(kid)%ptr%VBWGT4, & - grid%nests(kid)%ptr%I_PARENT_START,grid%nests(kid)%ptr%J_PARENT_START, & ! nest start I, J in parent domain - 3, & ! Ratio of parent and child grid ( always = 3 for NMM) - IDS,IDE,JDS,JDE,KDS,KDE, & ! target (nest) dimensions - IMS,IME,JMS,JME,KMS,KME, & - ITS,ITE,JTS,JTE,KTS,KTE ) - - CALL init_hnear( grid%nests(kid)%ptr%IIH,grid%nests(kid)%ptr%JJH, & ! output grid index in parent grid - grid%nests(kid)%ptr%HBWGT1,grid%nests(kid)%ptr%HBWGT2, & ! output weights in terms of parent grid - grid%nests(kid)%ptr%HBWGT3,grid%nests(kid)%ptr%HBWGT4, & - grid%nests(kid)%ptr%hnear_i,grid%nests(kid)%ptr%hnear_j, & - IDS,IDE,JDS,JDE,KDS,KDE, & ! target (nest) dimensions - IMS,IME,JMS,JME,KMS,KME, & - ITS,ITE,JTS,JTE,KTS,KTE ) + + IF ( grid%nests(kid)%ptr%active_this_task ) THEN + IDS = grid%nests(kid)%ptr%sd31 + IDE = grid%nests(kid)%ptr%ed31 + JDS = grid%nests(kid)%ptr%sd32 + JDE = grid%nests(kid)%ptr%ed32 + KDS = grid%nests(kid)%ptr%sd33 + KDE = grid%nests(kid)%ptr%ed33 + + IMS = grid%nests(kid)%ptr%sm31 + IME = grid%nests(kid)%ptr%em31 + JMS = grid%nests(kid)%ptr%sm32 + JME = grid%nests(kid)%ptr%em32 + KMS = grid%nests(kid)%ptr%sm33 + KME = grid%nests(kid)%ptr%em33 + + ITS = grid%nests(kid)%ptr%sp31 + ITE = grid%nests(kid)%ptr%ep31 + JTS = grid%nests(kid)%ptr%sp32 + JTE = grid%nests(kid)%ptr%ep32 + KTS = grid%nests(kid)%ptr%sp33 + KTE = grid%nests(kid)%ptr%ep33 + + CALL G2T2H_new( grid%nests(kid)%ptr%IIH,grid%nests(kid)%ptr%JJH, & ! output grid index in parent grid + grid%nests(kid)%ptr%HBWGT1,grid%nests(kid)%ptr%HBWGT2, & ! output weights in terms of parent grid + grid%nests(kid)%ptr%HBWGT3,grid%nests(kid)%ptr%HBWGT4, & + grid%nests(kid)%ptr%I_PARENT_START,grid%nests(kid)%ptr%J_PARENT_START, & ! nest start I, J in parent domain + 3, & ! Ratio of parent and child grid ( always = 3 for NMM) + IDS,IDE,JDS,JDE,KDS,KDE, & ! target (nest) dimensions + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) + CALL G2T2V_new( grid%nests(kid)%ptr%IIV,grid%nests(kid)%ptr%JJV, & ! output grid index in parent grid + grid%nests(kid)%ptr%VBWGT1,grid%nests(kid)%ptr%VBWGT2, & ! output weights in terms of parent grid + grid%nests(kid)%ptr%VBWGT3,grid%nests(kid)%ptr%VBWGT4, & + grid%nests(kid)%ptr%I_PARENT_START,grid%nests(kid)%ptr%J_PARENT_START, & ! nest start I, J in parent domain + 3, & ! Ratio of parent and child grid ( always = 3 for NMM) + IDS,IDE,JDS,JDE,KDS,KDE, & ! target (nest) dimensions + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) + CALL init_hnear( grid%nests(kid)%ptr%IIH,grid%nests(kid)%ptr%JJH, & ! output grid index in parent grid + grid%nests(kid)%ptr%HBWGT1,grid%nests(kid)%ptr%HBWGT2, & ! output weights in terms of parent grid + grid%nests(kid)%ptr%HBWGT3,grid%nests(kid)%ptr%HBWGT4, & + grid%nests(kid)%ptr%hnear_i,grid%nests(kid)%ptr%hnear_j, & + IDS,IDE,JDS,JDE,KDS,KDE, & ! target (nest) dimensions + IMS,IME,JMS,JME,KMS,KME, & + ITS,ITE,JTS,JTE,KTS,KTE ) + ENDIF ENDIF no_nests if(grid%vortex_tracker == 6 .or. grid%vortex_tracker == 7) then @@ -1726,3 +1856,56 @@ end subroutine init_hnear RETURN END FUNCTION direction_of_move #endif + + +SUBROUTINE reconcile_nest_positions_over_tasks ( grid ) + USE module_driver_constants, ONLY : max_nests, max_domains + USE module_domain, ONLY : domain, find_grid_by_id + USE module_utility + USE module_configure, ONLY : grid_config_rec_type, model_config_rec, model_to_grid_config_rec + USE module_state_description +#ifdef DM_PARALLEL + USE module_dm, ONLY : wrf_dm_move_nest, nest_task_offsets,mpi_comm_to_kid,mpi_comm_to_mom, which_kid & + ,comm_start, nest_pes_x, nest_pes_y,local_communicator + IMPLICIT NONE + TYPE(domain) , POINTER :: grid, result_grid +!local + INTEGER kid + INTEGER itask + INTEGER max_dom, id + INTEGER buf(max_domains,2) + + CALL nl_get_max_dom( 1 , max_dom ) + IF ( grid%num_nests .GT. 1 ) THEN + IF ( grid%active_this_task ) THEN + DO kid = 1, max_nests + ! which task is active? + IF ( ASSOCIATED( grid%nests(kid)%ptr ) ) THEN + ! check to see if the starting task for the nest is within the range of tasks + ! of the parent's local communicator; that task should be the root of the bcast on this grid's (the parent's) communicator + ! since it is active in both the parent and nest and should have valid parent_start information; + ! otoh, if it is outside then the parent and nest are not sharing processors + itask = comm_start( grid%nests(kid)%ptr%id ) - comm_start( grid%id ) + buf(:,1) = model_config_rec%i_parent_start + buf(:,2) = model_config_rec%j_parent_start + IF ( itask .GE. 0 .AND. itask .LT. nest_pes_x(grid%id)*nest_pes_y(grid%id) ) THEN + CALL push_communicators_for_domain(grid%id) + CALL BYTE_BCAST_FROM_ROOT( buf, 2*max_domains*IWORDSIZE, itask, local_communicator) + CALL pop_communicators_for_domain + ENDIF + DO id = 1, max_dom + CALL find_grid_by_id ( id, grid%nests(kid)%ptr, result_grid ) + IF ( ASSOCIATED(result_grid) .AND. .NOT. result_grid%active_this_task ) THEN + model_config_rec%i_parent_start(id) = buf(id,1) + model_config_rec%j_parent_start(id) = buf(id,2) + result_grid%i_parent_start = model_config_rec%i_parent_start(id) + result_grid%j_parent_start = model_config_rec%j_parent_start(id) + ENDIF + ENDDO + END IF + END DO + ENDIF + ENDIF +#endif +END SUBROUTINE reconcile_nest_positions_over_tasks + diff --git a/wrfv2_fire/share/mediation_wrfmain.F b/wrfv2_fire/share/mediation_wrfmain.F index 5353dab3..53117d5e 100644 --- a/wrfv2_fire/share/mediation_wrfmain.F +++ b/wrfv2_fire/share/mediation_wrfmain.F @@ -45,7 +45,7 @@ END SUBROUTINE start_domain TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags ! Local INTEGER :: fid , ierr , myproc - CHARACTER (LEN=80) :: inpname , rstname, timestr + CHARACTER (LEN=256) :: inpname , rstname, timestr CHARACTER (LEN=80) :: message LOGICAL :: restart LOGICAL, EXTERNAL :: wrf_dm_on_monitor @@ -163,28 +163,85 @@ SUBROUTINE med_shutdown_io ( grid , config_flags ) USE module_io_domain ! Model layer USE module_configure + USE module_dm, ONLY : domain_active_this_task IMPLICIT NONE + INTERFACE + RECURSIVE SUBROUTINE med_shutdown_io_recurse ( grid , config_flags ) + USE module_domain + USE module_configure + TYPE (domain) , POINTER :: grid + TYPE (grid_config_rec_type), INTENT(IN) :: config_flags + END SUBROUTINE med_shutdown_io_recurse + END INTERFACE ! Arguments - TYPE(domain) :: grid + TYPE(domain), TARGET :: grid TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags ! Local + TYPE(domain),POINTER :: grid_ptr CHARACTER (LEN=80) :: message - INTEGER :: ierr + INTEGER :: id, ierr - IF ( grid%oid > 0 ) CALL close_dataset ( grid%oid , config_flags , "DATASET=HISTORY" ) IF ( grid%lbc_fid > 0 ) CALL close_dataset ( grid%lbc_fid , config_flags , "DATASET=BOUNDARY" ) -! registry generated closes for auxhist streams -#include "shutdown_closes.inc" + grid_ptr => grid + CALL med_shutdown_io_recurse ( grid_ptr , config_flags ) +#if ( HWRF == 1 ) + DO id = 1, max_domains + IF( domain_active_this_task(id) ) THEN + CALL push_communicators_for_domain(id) + CALL wrf_ioexit( ierr ) ! shut down the quilt I/O + CALL pop_communicators_for_domain + ENDIF + ENDDO +#else CALL wrf_ioexit( ierr ) ! shut down the quilt I/O +#endif RETURN END SUBROUTINE med_shutdown_io +RECURSIVE SUBROUTINE med_shutdown_io_recurse ( grid , config_flags ) + ! Driver layer + USE module_domain + USE module_io_domain + ! Model layer + USE module_configure + + IMPLICIT NONE + + ! Arguments + TYPE(domain), POINTER :: grid + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + ! Local + TYPE(domain), POINTER :: grid_ptr + CHARACTER (LEN=80) :: message + INTEGER :: kid + INTEGER :: ierr + + IF ( ASSOCIATED( grid ) ) THEN + CALL push_communicators_for_domain(grid%id) + IF ( grid%oid > 0 ) CALL close_dataset ( grid%oid , config_flags , "DATASET=HISTORY" ) +! registry generated closes for auxhist streams +# include "shutdown_closes.inc" + grid_ptr => grid + DO WHILE ( ASSOCIATED( grid_ptr ) ) + DO kid = 1, max_nests + IF ( ASSOCIATED( grid_ptr%nests(kid)%ptr ) ) THEN + CALL med_shutdown_io_recurse ( grid_ptr%nests(kid)%ptr, config_flags ) + ENDIF + ENDDO + grid_ptr => grid_ptr%sibling + ENDDO + CALL pop_communicators_for_domain + ENDIF + RETURN +END SUBROUTINE med_shutdown_io_recurse + + SUBROUTINE med_add_config_info_to_grid ( grid ) USE module_domain @@ -199,7 +256,7 @@ SUBROUTINE med_add_config_info_to_grid ( grid ) #define SOURCE_RECORD model_config_rec % #define SOURCE_REC_DEX (grid%id) #define DEST_RECORD grid % -#include +#include "config_assigns.inc" RETURN diff --git a/wrfv2_fire/share/module_check_a_mundo.F b/wrfv2_fire/share/module_check_a_mundo.F index b00716db..4a28ece4 100644 --- a/wrfv2_fire/share/module_check_a_mundo.F +++ b/wrfv2_fire/share/module_check_a_mundo.F @@ -41,32 +41,47 @@ SUBROUTINE check_nml_consistency IMPLICIT NONE - LOGICAL :: exists + LOGICAL :: exists, vnest LOGICAL , EXTERNAL :: wrf_dm_on_monitor - INTEGER :: i, oops + INTEGER :: i, j, oops, d1_value LOGICAL :: km_opt_already_done , diff_opt_already_done +!TWG2015 +! +!FASDAS +! + LOGICAL :: rinblw_already_done +! +!END FASDAS +! + LOGICAL :: fatal_error + INTEGER :: count_fatal_error !----------------------------------------------------------------------- ! Set up the WRF Hydro namelist option to allow dynamic allocation of ! variables. !----------------------------------------------------------------------- + fatal_error = .false. + count_fatal_error = 0 #ifdef WRF_HYDRO model_config_rec % wrf_hydro = 1 #else model_config_rec % wrf_hydro = 0 #endif -#if (defined MOVE_NESTS) && (defined VORTEX_CENTER) +#if (NMM_CORE == 1) && (NMM_NEST == 1) !----------------------------------------------------------------------- -! A known problem with moving nests. Users with number of eta levels -! above 55 get a model crash. +! Ensure that minimum NMM corral distances are supplied for all domains. !----------------------------------------------------------------------- - - IF ( ( model_config_rec % max_dom .GT. 1 ) .AND. & - ( model_config_rec %e_vert(1) .GT. 55 ) ) THEN - wrf_err_message = '--- ERROR: Known problem. Moving nests need e_vert .LE. 55' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) - END IF + do i=1,model_config_rec%max_dom + if(model_config_rec%corral_x(i)<5) then + call wrf_message("Corral X distance must be at least 5 due to intermediate domain halos.") + model_config_rec%corral_x(i)=5 + endif + if(model_config_rec%corral_y(i)<5) then + call wrf_message("Corral Y distance must be at least 5 due to intermediate domain halos.") + model_config_rec%corral_y(i)=5 + endif + enddo #endif #if (EM_CORE == 1) @@ -77,24 +92,24 @@ SUBROUTINE check_nml_consistency ! 3. The option may not be used with rad_nudge. !----------------------------------------------------------------------- - IF ( ( model_config_rec % max_dom .GT. 1 ) .AND. & - ( model_config_rec % use_theta_m .EQ. 1 ) ) THEN - wrf_err_message = '--- ERROR: The use_theta_m option is only available for single domain cases' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) - END IF - IF ( ( model_config_rec % use_theta_m .EQ. 1 ) .AND. & ( model_config_rec % damp_opt .EQ. 2 ) ) THEN CALL wrf_message ( "The use_theta_m option may not be paired with damp_opt=2." ) wrf_err_message = '--- ERROR: Either turn off use_theta_m, or select a different damp_opt option' - CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + ! CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF IF ( ( model_config_rec % use_theta_m .EQ. 1 ) .AND. & ( model_config_rec % rad_nudge .EQ. 1 ) ) THEN CALL wrf_message ( "The use_theta_m option may not be paired with rad_nudge=1." ) wrf_err_message = '--- ERROR: Either turn off use_theta_m, or turn off the rad_nudge option' - CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + ! CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF @@ -137,44 +152,36 @@ SUBROUTINE check_nml_consistency IF ( ( model_config_rec % km_opt(1) .EQ. -1 ) .OR. & ( model_config_rec % diff_opt(1) .EQ. -1 ) ) THEN wrf_err_message = '--- ERROR: Both km_opt and diff_opt need to be set in the namelist.input file.' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF + + #endif !----------------------------------------------------------------------- ! Check that NSSL microphysics is not allowed for WRF-NMM run !----------------------------------------------------------------------- -#if (NMM_CORE == 1) || (HWRF == 1) +#if (NMM_CORE == 1) || (HWRF == 1) DO i = 1, model_config_rec % max_dom IF ( model_config_rec % mp_physics(i) == nssl_2mom .OR. & model_config_rec % mp_physics(i) == nssl_2momccn .OR. & model_config_rec % mp_physics(i) == nssl_1mom .OR. & model_config_rec % mp_physics(i) == nssl_1momlfo .OR. & - model_config_rec % mp_physics(i) == nssl_2momg ) THEN - wrf_err_message = '--- ERROR: NSSL scheme cannot run with WRF-NMM ' + model_config_rec % mp_physics(i) == nssl_2momg ) THEN + wrf_err_message = '--- ERROR: Chosen microphysics scheme cannot run with WRF-NMM ' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Fix mp_physics in namelist.input ' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF ENDDO #endif -!----------------------------------------------------------------------- -! Check: if ETAMPNEW microphysics is selected, this has moved to option 95 -!----------------------------------------------------------------------- - DO i = 1, model_config_rec % max_dom - IF ( model_config_rec % mp_physics(i) == etamp_hr ) THEN - wrf_err_message = '--- RESET: ETAMPNEW scheme is now mp_physics=95' - CALL wrf_message ( wrf_err_message ) - model_config_rec % mp_physics(i) = etampnew - END IF - IF ( model_config_rec % mp_physics_dfi(i) == etamp_hr_dfi ) THEN - wrf_err_message = '--- RESET: ETAMPNEW_DFI scheme is now mp_physics_dfi=95' - CALL wrf_message ( wrf_err_message ) - model_config_rec % mp_physics_dfi(i) = etampnew_dfi - END IF - ENDDO - !----------------------------------------------------------------------- ! Check that all values of sf_surface_physics are the same for all domains !----------------------------------------------------------------------- @@ -185,7 +192,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: sf_surface_physics must be equal for all domains ' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Fix sf_surface_physics in namelist.input ' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF ENDDO @@ -200,7 +210,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: sf_sfclay_physics must be equal for all domains ' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Fix sf_sfclay_physics in namelist.input ' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF ENDDO @@ -212,12 +225,16 @@ SUBROUTINE check_nml_consistency DO i = 2, model_config_rec % max_dom IF ( model_config_rec % mp_physics(i) .NE. & model_config_rec % mp_physics(1) ) THEN - wrf_err_message = '--- ERROR: mp_physics must be equal for all domains ' + wrf_err_message = '--- NOTE: mp_physics must be equal for all domains ' CALL wrf_message ( wrf_err_message ) - wrf_err_message = '--- Fix mp_physics in namelist.input ' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + wrf_err_message = '--- NOTE: ----> Setting all mp_physics entries to value defined in the inner most domain' + CALL wrf_message ( TRIM( wrf_err_message ) ) END IF ENDDO + d1_value = model_config_rec%mp_physics(model_config_rec % max_dom) + DO i = 1, model_config_rec % max_dom-1 + model_config_rec%mp_physics(i) = d1_value + END DO !----------------------------------------------------------------------- @@ -230,7 +247,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: ra_lw_physics must be equal for all domains ' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Fix ra_lw_physics in namelist.input ' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF ENDDO @@ -240,11 +260,29 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: ra_sw_physics must be equal for all domains ' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Fix ra_sw_physics in namelist.input ' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF ENDDO +!------------------------------------------------------------------------------ +! Check that a value for time_step is given, and is not just set to default (-1) +!------------------------------------------------------------------------------ + + IF ( ( model_config_rec % use_wps_input == 0 ) .AND. & + ( model_config_rec % time_step .EQ. -1 ) ) THEN + + wrf_err_message = '--- ERROR: Known problem. time_step must be set to a positive integer' + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 + + END IF + !----------------------------------------------------------------------- ! Check that all values of bl_pbl_physics are the same for all domains !----------------------------------------------------------------------- @@ -255,7 +293,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: bl_pbl_physics must be equal for all domains (or = zero)' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Fix bl_pbl_physics in namelist.input ' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF ENDDO @@ -271,7 +312,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: cu_physics must be equal for all domains (or = zero)' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Fix cu_physics in namelist.input ' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF ENDDO @@ -297,7 +341,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: If fine_input_stream /= 0, io_form_auxinput2 must be /= 0' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Set io_form_auxinput2 in the time_control namelist (probably to 2).' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF ENDDO @@ -311,6 +358,24 @@ SUBROUTINE check_nml_consistency model_config_rec%lagrange_order = 1 END IF +!----------------------------------------------------------------------- +! Check for domain consistency for urban options. +!----------------------------------------------------------------------- + + d1_value = model_config_rec%sf_urban_physics(1) + DO i = 2, model_config_rec % max_dom + IF ( model_config_rec%sf_urban_physics(i) /= d1_value ) THEN + WRITE(wrf_err_message, * ) '--- NOTE: sf_urban_physics option must be identical in each domain' + CALL wrf_message ( TRIM ( wrf_err_message ) ) + WRITE(wrf_err_message, * ) '--- NOTE: ----> Resetting namelist values to that defined on the inner most domain' + CALL wrf_message ( TRIM ( wrf_err_message ) ) + ENDIF + END DO + d1_value = model_config_rec%sf_urban_physics(model_config_rec % max_dom) + DO i = 1, model_config_rec % max_dom-1 + model_config_rec%sf_urban_physics(i) = d1_value + END DO + !----------------------------------------------------------------------- ! Check for consistency in the Noah-MP options !----------------------------------------------------------------------- @@ -324,7 +389,10 @@ SUBROUTINE check_nml_consistency WRITE(wrf_err_message, '(" --- ERROR: Noah-MP LSM scheme (sf_surface_physics==", I2, ")")') NOAHMPSCHEME CALL wrf_message ( TRIM ( wrf_err_message ) ) WRITE(wrf_err_message, '(" does not work with urban physics schemes")') - CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 ENDIF END IF @@ -342,7 +410,10 @@ SUBROUTINE check_nml_consistency CALL wrf_message ( TRIM ( wrf_err_message ) ) write (wrf_err_message, '(" sf_surface_physics == ", I2, " (Noah) or ", I2, " (Noah-MP).")') & LSMSCHEME, NOAHMPSCHEME - call wrf_error_fatal ( TRIM ( wrf_err_message ) ) + ! call wrf_error_fatal ( TRIM ( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF @@ -364,7 +435,10 @@ SUBROUTINE check_nml_consistency WRITE(wrf_err_message, '(" does not work with NMM ")') CALL wrf_message ( TRIM ( wrf_err_message ) ) WRITE(wrf_err_message, '("Select a different LSM scheme ")') - CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM ( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF END DO #endif @@ -386,7 +460,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = ' and should not be changed from their default value for SPPT' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- ERROR: If you really want to modify "kminforct" etc., edit module_check a_mundo.' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 endif endif ENDDO @@ -400,7 +477,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = ' and should not be changed from their default value for RAND_PERTURB' CALL wrf_message ( wrf_err_message ) wrf_err_message = ' ABORT. If you really want to modify "kminforct" etc., edit module_check a_mundo.' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 endif endif ENDDO @@ -469,7 +549,10 @@ SUBROUTINE check_nml_consistency #if (WRF_CHEM != 1) wrf_err_message = '--- ERROR: This option is only for WRF_CHEM.' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 #endif model_config_rec % rand_perturb_on=1 @@ -482,7 +565,10 @@ SUBROUTINE check_nml_consistency IF ( .NOT. model_config_rec % have_bcs_chem(1) ) THEN wrf_err_message = '--- ERROR: This perturb_chem_bdy option needs '// & 'have_bcs_chem = .true. in chem.' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 ENDIF #endif @@ -531,7 +617,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: bl_pbl_physics must be set to 1 for cu_physics = 11 ' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Fix bl_pbl_physics in namelist.input OR use another cu_physics option ' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF DO i = 1, model_config_rec % max_dom @@ -544,23 +633,6 @@ SUBROUTINE check_nml_consistency END IF ENDDO -!----------------------------------------------------------------------- -! cu_physics = 10 (Cumulus-potential KF) does not work in 3.7 yet -!----------------------------------------------------------------------- - - oops = 0 - DO i = 1, model_config_rec % max_dom - IF ( model_config_rec%cu_physics(i) .EQ. KFCUPSCHEME ) THEN - oops = oops + 1 - END IF - ENDDO ! Loop over domains - IF ( oops .GT. 0 ) THEN - wrf_err_message = '--- ERROR: cu_physics = 10 is not available in 3.7 ' - CALL wrf_message ( wrf_err_message ) - wrf_err_message = '--- Please select another cu_physics option ' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) - END IF - #endif !----------------------------------------------------------------------- @@ -586,7 +658,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: If sst_update /= 0, io_form_auxinput4 must be /= 0' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Set io_form_auxinput4 in the time_control namelist (probably to 2).' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF END IF @@ -613,12 +688,15 @@ SUBROUTINE check_nml_consistency !----------------------------------------------------------------------- DO i = 1, model_config_rec % max_dom - IF ( ( model_config_rec%grid_sfdda(i) .EQ. 1 ).AND. & + IF ( ( model_config_rec%grid_sfdda(i) .GT. 0 ).AND. & ( model_config_rec%grid_fdda (i) .NE. 1 ) ) THEN - wrf_err_message = '--- ERROR: If grid_sfdda = 1, then grid_fdda must also = 1 for that domain ' + wrf_err_message = '--- ERROR: If grid_sfdda >= 1, then grid_fdda must also = 1 for that domain ' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Change grid_fdda or grid_sfdda in namelist.input ' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF ENDDO @@ -692,6 +770,68 @@ SUBROUTINE check_nml_consistency ENDDO ! Loop over domains +!----------------------------------------------------------------------- +! If grid_sfdda = 2, we turn it into derived namelist fasdas +!----------------------------------------------------------------------- + + DO i = 1, model_config_rec % max_dom + model_config_rec%fasdas(i) = 0 + IF ( model_config_rec%grid_sfdda(i) .EQ. 2 ) THEN + model_config_rec%fasdas(i) = 1 + END IF + ENDDO +! +!----------------------------------------------------------------------- +! FASDAS: Check that rinblw is set for max_domains in the namelist if sffdda is active +!----------------------------------------------------------------------- + rinblw_already_done = .FALSE. + DO j = 1, model_config_rec%max_dom + IF (model_config_rec%grid_sfdda(j) .EQ. 1 ) THEN + DO i = 2, model_config_rec%max_dom + IF ( model_config_rec%rinblw(i) .EQ. -1 ) THEN + model_config_rec%rinblw(i) = model_config_rec % rinblw(1) + IF ( .NOT. rinblw_already_done ) THEN + CALL wrf_message ( "Setting blank rinblw entries to domain #1 values.") + CALL wrf_message ( " --> The rinblw entry in the namelist.input is now max_domains." ) + END IF + rinblw_already_done = .TRUE. + END IF + ENDDO + +!------------------------------------------------------------------------ +! Check that rinblw is not -1 if sfdda is active +!------------------------------------------------------------------------ + IF ( model_config_rec%rinblw(1) .EQ. -1 ) THEN + wrf_err_message = '--- ERROR: rinblw needs to be set in the namelist.input file.' + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 + END IF + END IF + END DO + +!------------------------------------------------------------------------ +! Check to see if FASDAS is active +!------------------------------------------------------------------------ + DO i = 1, model_config_rec%max_dom + IF (model_config_rec%fasdas(i) .EQ. 1 ) THEN + CALL wrf_message ( "FASDAS is active. Mixed Layer fdda is inactive") + END IF + +!------------------------------------------------------------------------ +! Check to make sure sfdda is active if FASDAS is in namelist +!------------------------------------------------------------------------ +! IF (model_config_rec%fasdas(i) .EQ. 1 ) THEN +! IF (model_config_rec%grid_sfdda(i) .EQ. 0) THEN +! wrf_err_message = '--- ERROR: sfdda needs to be set in the namelist.input file to run FASDAS.' +! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) +! END IF +! END IF + END DO +! +!END FASDAS +! !----------------------------------------------------------------------- ! Only implement the mfshconv option if the QNSE PBL is activated. !----------------------------------------------------------------------- @@ -731,6 +871,24 @@ SUBROUTINE check_nml_consistency CALL wrf_message ( wrf_err_message ) END IF +!----------------------------------------------------------------------- +! bl_mynn_edmf > 0 over-rules both shcu_physics & ishallow +!----------------------------------------------------------------------- + + oops = 0 + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec%bl_mynn_edmf(i) .EQ. MYNN_STEM_EDMF .OR. & + model_config_rec%bl_mynn_edmf(i) .EQ. MYNN_TEMF_EDMF) THEN + model_config_rec%shcu_physics(i) = 0 ! maxdom + model_config_rec%ishallow = 0 ! not maxdom + oops = oops + 1 + END IF + ENDDO ! Loop over domains + IF ( oops .GT. 0 ) THEN + wrf_err_message = 'bl_mynn_edmf > 0 requires both shcu_physics=0 & ishallow=0' + CALL wrf_message ( wrf_err_message ) + END IF + !----------------------------------------------------------------------- ! We need to know if any of the cumulus schemes are active. This ! allows the model to allocate space. @@ -756,19 +914,45 @@ SUBROUTINE check_nml_consistency ENDDO !----------------------------------------------------------------------- -! gwd_opt = 1 only works with YSU PBL. +! gwd_opt = 1 only works with YSU & MYNN PBL. !----------------------------------------------------------------------- oops = 0 DO i = 1, model_config_rec % max_dom - IF ( ( model_config_rec%bl_pbl_physics(i) .NE. YSUSCHEME ) .AND. & - ( model_config_rec%gwd_opt .EQ. GWDOPT ) ) THEN - model_config_rec%gwd_opt = 0 - oops = oops + 1 + IF (model_config_rec%gwd_opt == 1 ) THEN + IF ( (model_config_rec%bl_pbl_physics(i) .EQ. YSUSCHEME ) .OR. & + (model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME2 ) .OR. & + (model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME3) ) THEN + !NO PROBLEM + ELSE + model_config_rec%gwd_opt = 0 + oops = oops + 1 + END IF END IF ENDDO ! Loop over domains IF ( oops .GT. 0 ) THEN - wrf_err_message = '--- NOTE: bl_pbl_physics /= 1, implies gwd_opt cannot be 1, resetting' + wrf_err_message = '--- NOTE: bl_pbl_physics /= 1,5,6 implies gwd_opt cannot be 1, resetting' + CALL wrf_message ( wrf_err_message ) + END IF + +!----------------------------------------------------------------------- +! Make sure icloud_bl is only used when MYNN is chosen. +!----------------------------------------------------------------------- + + oops = 0 + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec%icloud_bl .eq. 1) THEN + IF ( model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME2 .OR. & + model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME3 ) THEN + !CORRECTLY CONFIGURED + ELSE + model_config_rec%icloud_bl = 0 + oops = oops + 1 + END IF + END IF + ENDDO ! Loop over domains + IF ( oops .GT. 0 ) THEN + wrf_err_message = 'Need MYNN PBL for icloud_bl = 1, resetting to 0' CALL wrf_message ( wrf_err_message ) END IF @@ -784,7 +968,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: If grid_fdda /= 0, io_form_gfdda must be /= 0' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Set io_form_gfdda in the time_control namelist (probably to 2).' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF END IF IF ( MAXVAL( model_config_rec%grid_sfdda ) .EQ. 0 ) THEN @@ -794,7 +981,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: If grid_sfdda /= 0, io_form_sgfdda must be /= 0' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Set io_form_sgfdda in the time_control namelist (probably to 2).' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF END IF @@ -815,7 +1005,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: provide: auxhist23_interval (max_dom) and io_form_auxhist23' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Add supporting IO for stream 23 for pressure-level diags' - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF END DO DO i = 1, model_config_rec % max_dom @@ -827,6 +1020,40 @@ SUBROUTINE check_nml_consistency END DO END IF + +!----------------------------------------------------------------------- +! If we have asked for the height-level diagnostics, make sure we can output them +!----------------------------------------------------------------------- + + IF ( model_config_rec%z_lev_diags .EQ. 1 ) THEN + DO i = 1, model_config_rec % max_dom + IF ( ( MAX ( model_config_rec%auxhist22_interval (i) , & + model_config_rec%auxhist22_interval_d(i) , & + model_config_rec%auxhist22_interval_h(i) , & + model_config_rec%auxhist22_interval_m(i) , & + model_config_rec%auxhist22_interval_s(i) ) == 0 ) .OR. & + ( model_config_rec%io_form_auxhist22 == 0 ) ) THEN + wrf_err_message = '--- ERROR: z_lev_diags requires auxhist22 file information' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = '--- ERROR: provide: auxhist22_interval (max_dom) and io_form_auxhist22' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = '--- Add supporting IO for stream 22 for height-level diags' + ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 + END IF + END DO + DO i = 1, model_config_rec % max_dom + model_config_rec%z_lev_interval(i) = model_config_rec%auxhist22_interval (i)* 60 + & + model_config_rec%auxhist22_interval_d(i)*86400 + & + model_config_rec%auxhist22_interval_h(i)* 3600 + & + model_config_rec%auxhist22_interval_m(i)* 60 + & + model_config_rec%auxhist22_interval_s(i) + END DO + END IF + + !----------------------------------------------------------------------- ! For nwp_diagnostics = 1, history_interval must be used. !----------------------------------------------------------------------- @@ -836,7 +1063,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: nwp_diagnostics requires the use of "history_interval" namelist.' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Replace interval variable with "history_interval".' - CALL wrf_error_fatal ( wrf_err_message ) + ! CALL wrf_error_fatal ( wrf_err_message ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF !----------------------------------------------------------------------- @@ -850,7 +1080,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: The namelist.input variable "omlcall" has been renamed.' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Replace "omlcall" with the new name "sf_ocean_physics".' - CALL wrf_error_fatal ( wrf_err_message ) + !CALL wrf_error_fatal ( wrf_err_message ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF !----------------------------------------------------------------------- @@ -878,6 +1111,25 @@ SUBROUTINE check_nml_consistency END IF END IF +!----------------------------------------------------------------------- +! When digital filtering is turned on, if no specific time step is given to be +! used during the digitial filtering period, then the standard WRF time +! step is used. If neither time steps are specified, then fatal error. +!----------------------------------------------------------------------- + + IF ( .NOT. model_config_rec%dfi_opt .EQ. DFI_NODFI ) THEN + IF ( model_config_rec%time_step_dfi .EQ. -1 ) THEN + model_config_rec%time_step_dfi = model_config_rec%time_step + IF ( model_config_rec%time_step_dfi .EQ. -1 ) THEN + wrf_err_message = '--- ERROR: DFI Timestep or standard WRF time step must be specified.' + ! CALL wrf_error_fatal ( wrf_err_message ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 + END IF + END IF + END IF + !----------------------------------------------------------------------- ! The cu_rad_feedback namelist flag with the two Grell cumulus parameterization ! schemes needs to have the namelist flag cu_diag=1 @@ -914,7 +1166,35 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- Grell (G3) CU scheme' CALL wrf_message ( wrf_err_message ) wrf_err_message = '--- Grell-Devenyi (GD) CU scheme' - CALL wrf_error_fatal ( wrf_err_message ) + ! CALL wrf_error_fatal ( wrf_err_message ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 + END IF + END IF + END DO + +!----------------------------------------------------------------------- +! The namelist flag kf_edrates=1 must have one of the three KF cumulus parameterizations +! turned on. All other cumulus parameterizations need to have kf_edrates=0 +!----------------------------------------------------------------------- + + DO i = 1, model_config_rec % max_dom + IF ( model_config_rec%kf_edrates(i) .EQ. KFEDRATES ) THEN + IF ( ( model_config_rec%cu_physics(i) .NE. KFETASCHEME ) .AND. & + ( model_config_rec%cu_physics(i) .NE. MSKFSCHEME ) .AND. & + ( model_config_rec%cu_physics(i) .NE. KFSCHEME ) ) THEN + wrf_err_message = '--- ERROR: Using kf_edrates=1 requires use of one of the following KF schemes:' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = '--- Kain-Fritsch (cu_physics=1)' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = '--- Multi-scale Kain-Fritsch (cu_physics=11)' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = '--- old Kain-Fritsch (cu_physics=99)' + ! CALL wrf_error_fatal ( wrf_err_message ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF END IF END DO @@ -959,11 +1239,17 @@ SUBROUTINE check_nml_consistency IF ( ( model_config_rec%bl_pbl_physics(i) .EQ. TEMFPBLSCHEME ) .AND. & ( model_config_rec%sf_sfclay_physics(i) .NE. TEMFSFCSCHEME ) ) THEN wrf_err_message = '--- ERROR: Using bl_pbl_physics=10 requires sf_sfclay_physics=10 ' - CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + ! CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 ELSEIF ( ( model_config_rec%bl_pbl_physics(i) .NE. TEMFPBLSCHEME ) .AND. & ( model_config_rec%sf_sfclay_physics(i) .EQ. TEMFSFCSCHEME ) ) THEN wrf_err_message = '--- ERROR: Using sf_sfclay_physics=10 requires bl_pbl_physics=10 ' - CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + ! CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF ENDDO ! Loop over domains @@ -974,7 +1260,10 @@ SUBROUTINE check_nml_consistency IF ( model_config_rec%tmn_update .EQ. 1 .AND. & model_config_rec%lagday .EQ. 1 ) THEN wrf_err_message = '--- ERROR: Using tmn_update=1 requires lagday=150 ' - CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + ! CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF !----------------------------------------------------------------------- @@ -985,7 +1274,10 @@ SUBROUTINE check_nml_consistency IF ( ( model_config_rec%bl_pbl_physics(i) .EQ. TEMFPBLSCHEME ) .AND. & (model_config_rec%dfi_opt .NE. DFI_NODFI) ) THEN wrf_err_message = '--- ERROR: DFI not available for bl_pbl_physics=10 ' - CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + ! CALL wrf_error_fatal ( TRIM(wrf_err_message) ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF ENDDO ! Loop over domains @@ -1015,7 +1307,10 @@ SUBROUTINE check_nml_consistency wrf_err_message = '--- ERROR: However, the WRF CLM scheme was not compiled in WRF.' CALL wrf_debug ( 0, TRIM(wrf_err_message) ) wrf_err_message = '--- ERROR: Please place the -DWRF_USE_CLM option in configure.wrf file, and recompile.' - CALL wrf_error_fatal ( wrf_err_message ) + ! CALL wrf_error_fatal ( wrf_err_message ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF #endif @@ -1056,25 +1351,83 @@ SUBROUTINE check_nml_consistency END IF !----------------------------------------------------------------------- -! Check that vertical levels are defined in a logical way. +! DJW Check that we're not using ndown and vertical nesting. !----------------------------------------------------------------------- + DO i=1,model_config_rec%max_dom + IF ((model_config_rec%vert_refine_method(i) .NE. 0) .AND. (model_config_rec%vert_refine_fact .NE. 1)) THEN + write(wrf_err_message,'(A)') '--- ERROR: vert_refine_fact is ndown specific and cannot be used with vert_refine_method, and vice versa.' + CALL wrf_message( wrf_err_message ) + ENDIF + ENDDO +!----------------------------------------------------------------------- +! DJW Check that only one type of vertical nesting is enabled. +!----------------------------------------------------------------------- + DO i=1,model_config_rec%max_dom + IF (model_config_rec%vert_refine_method(i) .NE. 0) THEN + DO j=1,model_config_rec%max_dom + IF ((model_config_rec%vert_refine_method(i) .NE. model_config_rec%vert_refine_method(j)) .AND. (model_config_rec%vert_refine_method(j) .NE. 0)) THEN + write(wrf_err_message,'(A,I1,A,I2,A,I1,A,I2,A)') '--- ERROR: vert_refine_method differs on grid ids ',model_config_rec%grid_id(i),' and ',model_config_rec%grid_id(j),'. Only one type of vertical grid nesting can be used at a time.' + ! CALL wrf_error_fatal( wrf_err_message ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 + ENDIF + ENDDO + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! DJW Check that e_vert is the same for nested domains not using +! vertical nesting. Don't do this check if we're using ndown. +!----------------------------------------------------------------------- + IF ((model_config_rec%max_dom .GT. 1) .AND. (model_config_rec%vert_refine_fact .EQ. 1)) THEN + DO i=1,model_config_rec%max_dom + IF (((model_config_rec%parent_id(i) .NE. 0) .AND. (model_config_rec%parent_id(i) .NE. model_config_rec%grid_id(i))) .AND. (model_config_rec%vert_refine_method(i) .EQ. 0)) THEN + DO j=1,model_config_rec%max_dom + IF ((i .NE. j) .AND. (model_config_rec%parent_id(i) .EQ. model_config_rec%grid_id(j))) THEN + IF (model_config_rec%e_vert(i) .NE. model_config_rec%e_vert(j)) THEN + write(wrf_err_message,'(A,I2,A,I2,A)') '--- ERROR: e_vert differs on grid ids ',model_config_rec%grid_id(i),' and ',model_config_rec%grid_id(j),'. Set vert_refine_method or make e_vert consistent.' + ! CALL wrf_error_fatal( wrf_err_message ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 + ENDIF + ENDIF + ENDDO + ENDIF + ENDDO + ENDIF + +!----------------------------------------------------------------------- +! Check that vertical levels are defined in a logical way. +! DJW Check that domains without a parent do not have vertical +! nesting enabled. +!----------------------------------------------------------------------- + DO i=1,model_config_rec%max_dom + IF ((model_config_rec%parent_id(i) .EQ. 0) .OR. (model_config_rec%parent_id(i) .EQ. model_config_rec%grid_id(i))) THEN + IF (model_config_rec%vert_refine_method(i) .NE. 0) THEN + write(wrf_err_message,'(A,I1,A,I2,A)') '--- ERROR: vert_refine_method=',model_config_rec%vert_refine_method(i),' for grid_id=',model_config_rec%grid_id(i),', must be 0 for a non-nested domain.' + ! CALL wrf_error_fatal( wrf_err_message ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 + ENDIF + ENDIF + ENDDO + +!----------------------------------------------------------------------- +! DJW Check that we've got appropriate e_vert for integer refinement. +!----------------------------------------------------------------------- DO i = 1, model_config_rec % max_dom IF (model_config_rec%vert_refine_method(i) .EQ. 1) THEN - IF (i .EQ. 1) THEN - wrf_err_message = '--- INFO: vert_refine_method=1 for d01, must be 0., resetting value internally' - CALL wrf_message ( wrf_err_message ) - model_config_rec%vert_refine_method(i) = 0 - ELSE - IF (MOD((model_config_rec%e_vert(i)-1),(model_config_rec%e_vert(i-1)-1)) .NE. 0) THEN - wrf_err_message = '--- ERROR: incompatible e_vert for use with int-refinement.' - CALL wrf_error_fatal ( wrf_err_message ) - ENDIF - ENDIF - ELSEIF (model_config_rec%vert_refine_method(i) .EQ. 2) THEN - IF (i .EQ. 1) THEN - wrf_err_message = '--- ERROR: vert_refine_method=2 for d01, must be 0.' - CALL wrf_error_fatal ( wrf_err_message ) + j = model_config_rec%parent_id(i) + IF (MOD(model_config_rec%e_vert(i)-1, model_config_rec%e_vert(j)-1) .NE. 0) THEN + write(wrf_err_message,'(A,I2,A,I2,A)') "--- ERROR: grid_id=",i," and parent (grid_id=",j,") have incompatible e_vert's for vertical nesting with integer refinement." + ! CALL wrf_error_fatal ( wrf_err_message ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 ENDIF ENDIF ENDDO @@ -1082,49 +1435,91 @@ SUBROUTINE check_nml_consistency !----------------------------------------------------------------------- ! Consistency checks between vertical refinement and radiation ! scheme selection. For "choose any vertical levels" for the nest, -! only RRTM and RRTMG are eligible. +! only RRTM is eligible. !----------------------------------------------------------------------- DO i = 2, model_config_rec % max_dom - IF (model_config_rec%vert_refine_method(i) .EQ. 2) THEN - IF ( ( ( model_config_rec%ra_lw_physics(i) .EQ. RRTMSCHEME ) .OR. & - ( model_config_rec%ra_lw_physics(i) .EQ. RRTMG_LWSCHEME ) .OR. & - ( model_config_rec%ra_lw_physics(i) .EQ. RRTMG_LWSCHEME_FAST ) ) .AND. & - ( ( model_config_rec%ra_sw_physics(i) .EQ. SWRADSCHEME ) .OR. & - ( model_config_rec%ra_sw_physics(i) .EQ. RRTMG_SWSCHEME ) .OR. & - ( model_config_rec%ra_sw_physics(i) .EQ. RRTMG_SWSCHEME_FAST ) ) ) THEN + IF (model_config_rec%vert_refine_method(i) .NE. 0) THEN + IF ( ( ( model_config_rec%ra_lw_physics(i) .EQ. 0 ) .OR. & + ( model_config_rec%ra_lw_physics(i) .EQ. RRTMSCHEME ) ) .AND. & + ( ( model_config_rec%ra_sw_physics(i) .EQ. 0 ) .OR. & + ( model_config_rec%ra_sw_physics(i) .EQ. SWRADSCHEME ) ) ) THEN ! We are OK, I just hate writing backwards / negative / convoluted if tests ! that are not easily comprehensible. ELSE wrf_err_message = '--- ERROR: vert_refine_method=2 only works with either RRTM or RRTMG' - CALL wrf_error_fatal ( wrf_err_message ) + ! CALL wrf_error_fatal ( wrf_err_message ) + CALL wrf_debug ( 0, TRIM( wrf_err_message ) ) + fatal_error = .true. + count_fatal_error = count_fatal_error + 1 END IF END IF END DO +!----------------------------------------------------------------------- +! Remapping namelist variables for gridded and surface fdda to aux streams 9 and 10. +! Relocated here so that the remappings are after checking the namelist for inconsistencies. +!----------------------------------------------------------------------- + +# include "../dyn_em/namelist_remappings_em.h" + +#endif + +#if (EM_CORE == 1) +!----------------------------------------------------------------------- +! For the real program (ARW only), check that the vertical interpolation options +! selected by the user are consistent. +! 1. If the user has turned-off using the surface level, do not allow the force +! option to select how many layers the surface is to be used through. +! 2. If the user has turned-off using the surface level, do not allow the +! lowest level from surface option to be activated. +!----------------------------------------------------------------------- + + IF ( model_config_rec % use_wps_input .EQ. 1 ) THEN + IF ( ( .NOT. model_config_rec % use_surface ) .AND. & + ( model_config_rec % force_sfc_in_vinterp .GT. 0 ) ) THEN + wrf_err_message = '--- NOTE: Inconsistent vertical interpolation settings in program real.' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = '--- NOTE: With use_surface=F, automatically setting force_sfc_in_vinterp=0.' + CALL wrf_message ( wrf_err_message ) + model_config_rec % force_sfc_in_vinterp = 0 + END IF + IF ( ( .NOT. model_config_rec % use_surface ) .AND. & + ( model_config_rec % lowest_lev_from_sfc ) ) THEN + wrf_err_message = '--- NOTE: Inconsistent vertical interpolation settings in program real.' + CALL wrf_message ( wrf_err_message ) + wrf_err_message = '--- NOTE: With use_surface=F, automatically setting lowest_lev_from_sfc=F.' + CALL wrf_message ( wrf_err_message ) + model_config_rec % lowest_lev_from_sfc = .FALSE. + END IF + END IF +#endif + !----------------------------------------------------------------------- ! Set the namelist parameter o3input to 0 for the radiation schemes other ! than RRTMG_LWSCHEME and RRTMG_SWSCHEME. !----------------------------------------------------------------------- - IF ( ( model_config_rec % ra_lw_physics(1) .NE. RRTMG_LWSCHEME ) .OR. & - ( model_config_rec % ra_sw_physics(1) .NE. RRTMG_SWSCHEME ) .OR. & - ( model_config_rec % ra_lw_physics(1) .NE. RRTMG_LWSCHEME_FAST ) .OR. & - ( model_config_rec % ra_sw_physics(1) .NE. RRTMG_SWSCHEME_FAST ) ) THEN + IF ( ( model_config_rec % ra_lw_physics(1) .EQ. RRTMG_LWSCHEME ) .OR. & + ( model_config_rec % ra_sw_physics(1) .EQ. RRTMG_SWSCHEME ) .OR. & + ( model_config_rec % ra_lw_physics(1) .EQ. RRTMG_LWSCHEME_FAST ) .OR. & + ( model_config_rec % ra_sw_physics(1) .EQ. RRTMG_SWSCHEME_FAST ) ) THEN + wrf_err_message = '--- NOTE: RRTMG radiation is used, namelist ' // & + 'value for o3input (ozone input) is used ' +! CALL wrf_message ( wrf_err_message ) + ELSE model_config_rec % o3input = 0 wrf_err_message = '--- NOTE: RRTMG radiation is not used, setting: ' // & 'o3input=0 to avoid data pre-processing' CALL wrf_message ( wrf_err_message ) END IF -!----------------------------------------------------------------------- -! Remapping namelist variables for gridded and surface fdda to aux streams 9 and 10. -! Relocated here so that the remappings are after checking the namelist for inconsistencies. -!----------------------------------------------------------------------- - -# include "../dyn_em/namelist_remappings_em.h" - -#endif + IF ( fatal_error ) THEN + WRITE (wrf_err_message, FMT='(A,I6, A)') 'NOTE: ', count_fatal_error, & + ' namelist settings are wrong. Please check and reset these options' + + CALL wrf_error_fatal ( wrf_err_message ) + END IF END SUBROUTINE @@ -1146,6 +1541,7 @@ SUBROUTINE set_physics_rconfigs INTEGER :: numsoiltemp , nummosaictemp INTEGER :: i + !----------------------------------------------------------------------- ! Set the namelist mosaic_cat_soil parameter for the Noah-mosaic scheme if sf_surface_mosaic == 1. !----------------------------------------------------------------------- @@ -1280,6 +1676,7 @@ SUBROUTINE set_physics_rconfigs END SUBROUTINE set_physics_rconfigs + !======================================================================= END MODULE module_check_a_mundo diff --git a/wrfv2_fire/share/module_interp_nmm.F b/wrfv2_fire/share/module_interp_nmm.F index e23715b1..e1f56fc5 100644 --- a/wrfv2_fire/share/module_interp_nmm.F +++ b/wrfv2_fire/share/module_interp_nmm.F @@ -2505,7 +2505,7 @@ subroutine interp_T_PD_Q(method, pd_interp, nx, nz, & enddo -201 format('Target domain surface height ',F0.4,'m is higher than the model top ',F0.4,'m of the source domain. ABORTING') +201 format('interp_T_PD_Q: Target domain surface height ',F0.4,'m is higher than the model top ',F0.4,'m of the source domain. ABORTING') write(message,201) zB,znext call wrf_error_fatal(message) enddo xloop @@ -2813,7 +2813,7 @@ subroutine interp_T_PD_Q_kpres(method, pd_interp, nx, nz, & enddo -201 format('Target domain surface height ',F0.4,'m is higher than the model top ',F0.4,'m of the source domain. ABORTING') +201 format('interp_T_PD_Q_kpres: Target domain surface height ',F0.4,'m is higher than the model top ',F0.4,'m of the source domain. ABORTING') write(message,201) zB,znext call wrf_error_fatal(message) enddo xloop diff --git a/wrfv2_fire/share/module_io_domain.F b/wrfv2_fire/share/module_io_domain.F index 14b0391a..7b2b115c 100644 --- a/wrfv2_fire/share/module_io_domain.F +++ b/wrfv2_fire/share/module_io_domain.F @@ -202,16 +202,52 @@ SUBROUTINE construct_filename2a( result , basename , fld1 , len1 , date_char ) result=basename CALL zero_pad ( t1 , fld1 , len1 ) - i = index( basename , '' ) - l = len(trim(basename)) - IF ( i .GT. 0 ) THEN - result = basename(1:i-1) // TRIM(t1) // basename(i+8:l) - ENDIF + + +! The string name length 12345678 including < > ----| +! |||||||| | + i = index( result , '' ) ! is this | + DO WHILE ( i .GT. 0 ) ! value | + l = len(trim(result)) ! \/ + result = result (1:i-1) // TRIM(t1) // result(i+8:l) + i = index( result , '' ) + END DO + i = index( result , '' ) - l = len(trim(result)) - IF ( i .GT. 0 ) THEN + DO WHILE ( i .GT. 0 ) + l = len(trim(result)) result = result(1:i-1) // TRIM(date_char) // result(i+6:l) - ENDIF + i = index( result , '' ) + END DO + + i = index( result , '' ) + DO WHILE ( i .GT. 0 ) + l = len(trim(result)) + result = result(1:i-1) // TRIM(date_char( 1: 4)) // result(i+6:l) + i = index( result , '' ) + END DO + + i = index( result , '' ) + DO WHILE ( i .GT. 0 ) + l = len(trim(result)) + result = result(1:i-1) // TRIM(date_char( 6: 7)) // result(i+7:l) + i = index( result , '' ) + END DO + + i = index( result , '' ) + DO WHILE ( i .GT. 0 ) + l = len(trim(result)) + result = result(1:i-1) // TRIM(date_char( 9:10)) // result(i+5:l) + i = index( result , '' ) + END DO + + i = index( result , '' ) + DO WHILE ( i .GT. 0 ) + l = len(trim(result)) + result = result(1:i-1) // TRIM(date_char(12:13)) // result(i+6:l) + i = index( result , '' ) + END DO + CALL maybe_remove_colons(result) RETURN END SUBROUTINE construct_filename2a @@ -306,17 +342,52 @@ SUBROUTINE construct_filename4a( result , basename , fld1 , len1 , date_char , i END IF l = len(trim(basename)) result = basename(1:l) // TRIM(ext) - i = index( result , '' ) - l = len(trim(result)) - IF ( i .GT. 0 ) THEN - result = result(1:i-1) // TRIM(t1) // result(i+8:l) - ENDIF + +! The string name length 12345678 including < > ----| +! |||||||| | + i = index( result , '' ) ! is this | + DO WHILE ( i .GT. 0 ) ! value | + l = len(trim(result )) ! \/ + result = result (1:i-1) // TRIM(t1) // result (i+8:l) + i = index( result , '' ) + END DO + i = index( result , '' ) - l = len(trim(result)) - IF ( i .GT. 0 ) THEN + DO WHILE ( i .GT. 0 ) + l = len(trim(result)) result = result(1:i-1) // TRIM(date_char) // result(i+6:l) - ENDIF + i = index( result , '' ) + END DO + + i = index( result , '' ) + DO WHILE ( i .GT. 0 ) + l = len(trim(result)) + result = result(1:i-1) // TRIM(date_char( 1: 4)) // result(i+6:l) + i = index( result , '' ) + END DO + + i = index( result , '' ) + DO WHILE ( i .GT. 0 ) + l = len(trim(result)) + result = result(1:i-1) // TRIM(date_char( 6: 7)) // result(i+7:l) + i = index( result , '' ) + END DO + + i = index( result , '' ) + DO WHILE ( i .GT. 0 ) + l = len(trim(result)) + result = result(1:i-1) // TRIM(date_char( 9:10)) // result(i+5:l) + i = index( result , '' ) + END DO + + i = index( result , '' ) + DO WHILE ( i .GT. 0 ) + l = len(trim(result)) + result = result(1:i-1) // TRIM(date_char(12:13)) // result(i+6:l) + i = index( result , '' ) + END DO CALL maybe_remove_colons(result) + RETURN END SUBROUTINE construct_filename4a @@ -402,8 +473,9 @@ SUBROUTINE maybe_remove_colons( FileName ) DO i = 3, l IF ( FileName(i:i) .EQ. ':' ) THEN FileName(i:i) = '_' - ELSE IF ( FileName(i:i) .EQ. '-' ) THEN - FileName(i:i) = '_' +! Remove this modification to filename - dashes are OK +! ELSE IF ( FileName(i:i) .EQ. '-' ) THEN +! FileName(i:i) = '_' ENDIF ENDDO ENDIF diff --git a/wrfv2_fire/share/module_model_constants.F b/wrfv2_fire/share/module_model_constants.F index 468a83c1..aaa17503 100644 --- a/wrfv2_fire/share/module_model_constants.F +++ b/wrfv2_fire/share/module_model_constants.F @@ -105,7 +105,7 @@ MODULE module_model_constants REAL , PARAMETER :: epsfc=1./1.05 REAL , PARAMETER :: epswet=0.0 REAL , PARAMETER :: fcdif=1./3. -#ifdef HWRF +#if ( HWRF == 1 ) REAL , PARAMETER :: fcm=0.0 #else REAL , PARAMETER :: fcm=0.00003 @@ -130,7 +130,7 @@ MODULE module_model_constants REAL , PARAMETER :: wght=0.35 REAL , PARAMETER :: wpc=0.075 REAL , PARAMETER :: z0land=0.10 -#ifdef HWRF +#if ( HWRF == 1 ) REAL , PARAMETER :: z0max=0.01 #else REAL , PARAMETER :: z0max=0.008 diff --git a/wrfv2_fire/share/module_optional_input.F b/wrfv2_fire/share/module_optional_input.F index cf8bd022..8fc0acb6 100644 --- a/wrfv2_fire/share/module_optional_input.F +++ b/wrfv2_fire/share/module_optional_input.F @@ -37,6 +37,7 @@ MODULE module_optional_input INTEGER :: flag_hgtmaxw , flag_pmaxw , flag_tmaxw , flag_umaxw , flag_vmaxw , & flag_hgttrop , flag_ptrop , flag_ttrop , flag_utrop , flag_vtrop + INTEGER :: flag_pmaxwnn , flag_ptropnn INTEGER :: flag_extra_levels INTEGER :: num_soil_levels_input @@ -509,11 +510,13 @@ SUBROUTINE optional_levels ( grid , fid , & flag_hgtmaxw = 0 flag_pmaxw = 0 + flag_pmaxwnn = 0 flag_tmaxw = 0 flag_umaxw = 0 flag_vmaxw = 0 flag_hgttrop = 0 flag_ptrop = 0 + flag_ptropnn = 0 flag_ttrop = 0 flag_utrop = 0 flag_vtrop = 0 @@ -529,6 +532,11 @@ SUBROUTINE optional_levels ( grid , fid , & IF ( ierr .EQ. 0 ) THEN flag_pmaxw = itmp END IF + flag_name(1:8) = 'PMAXWNN ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_pmaxwnn = itmp + END IF flag_name(1:8) = 'TMAXW ' CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) IF ( ierr .EQ. 0 ) THEN @@ -554,6 +562,11 @@ SUBROUTINE optional_levels ( grid , fid , & IF ( ierr .EQ. 0 ) THEN flag_ptrop = itmp END IF + flag_name(1:8) = 'PTROPNN ' + CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) + IF ( ierr .EQ. 0 ) THEN + flag_ptropnn = itmp + END IF flag_name(1:8) = 'TTROP ' CALL wrf_get_dom_ti_integer ( fid, 'FLAG_' // flag_name, itmp, 1, icnt, ierr ) IF ( ierr .EQ. 0 ) THEN @@ -570,6 +583,26 @@ SUBROUTINE optional_levels ( grid , fid , & flag_vtrop = itmp END IF + ! Newer versions of WPS supply a nearest-neighbor version of pressure and a + ! pressure that is suitable for interpolation. If the nearest neighbor is + ! missing, all fields are set to unavailable. + + IF ( flag_pmaxwnn .EQ. 0 ) THEN + flag_hgtmaxw = 0 + flag_pmaxw = 0 + flag_tmaxw = 0 + flag_umaxw = 0 + flag_vmaxw = 0 + END IF + + IF ( flag_ptropnn .EQ. 0 ) THEN + flag_hgttrop = 0 + flag_ptrop = 0 + flag_ttrop = 0 + flag_utrop = 0 + flag_vtrop = 0 + END IF + flag_extra_levels = flag_hgtmaxw*flag_pmaxw*flag_tmaxw*flag_umaxw*flag_vmaxw* & flag_hgttrop*flag_ptrop*flag_ttrop*flag_utrop*flag_vtrop diff --git a/wrfv2_fire/share/module_soil_pre.F b/wrfv2_fire/share/module_soil_pre.F index fa1b55ff..82158919 100644 --- a/wrfv2_fire/share/module_soil_pre.F +++ b/wrfv2_fire/share/module_soil_pre.F @@ -1355,7 +1355,6 @@ SUBROUTINE init_soil_1_ideal(tsk,tmn,tslb,xland, & IF (num_soil_layers.NE.1)THEN DO j=jts,jtf - IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE DO l=1,num_soil_layers DO i=its,itf tslb(i,l,j)=( tsk(i,j)*(zs(num_soil_layers)-zs(l)) + tmn(i,j)*(zs(l)-zs(1)) ) / & @@ -1783,7 +1782,6 @@ SUBROUTINE init_soil_2_ideal ( xland,xice,vegfra,snow,canwat, & DO j=jts,jtf DO l=1,num_soil_layers DO i=its,itf - IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE if (xland(i,j) .lt. 1.5) then smois(i,1,j)=0.30 smois(i,2,j)=0.30 diff --git a/wrfv2_fire/share/output_wrf.F b/wrfv2_fire/share/output_wrf.F index 6514ea59..88e81913 100644 --- a/wrfv2_fire/share/output_wrf.F +++ b/wrfv2_fire/share/output_wrf.F @@ -12,8 +12,8 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) USE module_model_constants USE module_utility IMPLICIT NONE -#include -#include +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags INTEGER, INTENT(IN) :: fid, switch @@ -39,7 +39,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) INTEGER km_opt, diff_opt, damp_opt, & mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, & sf_surface_physics, bl_pbl_physics, cu_physics, hypsometric_opt, sf_lake_physics, & - use_theta_m + use_theta_m, use_maxw_level, use_trop_level INTEGER swint_opt, aer_type,aer_aod550_opt,aer_angexp_opt,aer_ssa_opt,aer_asy_opt, aer_opt REAL aer_aod550_val,aer_angexp_val,aer_ssa_val,aer_asy_val REAL khdif, kvdif, swrad_scat, dampcoef,radt,bldt,cudt @@ -81,7 +81,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CHARACTER*80 dname, memord CHARACTER*256 message - CHARACTER*80 fname + CHARACTER*256 fname CHARACTER*80 char_junk CHARACTER(LEN=256) :: MMINLU INTEGER ibuf(1) @@ -176,6 +176,8 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) #if (EM_CORE == 1) call nl_get_hypsometric_opt ( 1, hypsometric_opt ) call nl_get_use_theta_m ( 1, use_theta_m ) + call nl_get_use_maxw_level ( 1, use_maxw_level ) + call nl_get_use_trop_level ( 1, use_trop_level ) CALL nl_get_moist_adv_opt ( grid%id , moist_adv_opt ) CALL nl_get_scalar_adv_opt ( grid%id , scalar_adv_opt ) CALL nl_get_tke_adv_opt ( grid%id , tke_adv_opt ) @@ -210,7 +212,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL nl_get_dtramp_min ( 1 , dtramp_min ) ENDIF - IF ( grid_sfdda == 1 ) THEN + IF ( grid_sfdda >= 1 ) THEN CALL nl_get_guv_sfc ( grid%id , guv_sfc ) CALL nl_get_gt_sfc ( grid%id , gt_sfc ) CALL nl_get_gq_sfc ( grid%id , gq_sfc ) @@ -331,7 +333,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL wrf_put_dom_ti_char ( fid , 'START_DATE', TRIM(start_date) , ierr ) IF ( switch .EQ. input_only) THEN CALL wrf_put_dom_ti_char ( fid , 'SIMULATION_START_DATE', TRIM(start_date) , ierr ) -#ifdef HWRF +#if ( HWRF == 1 ) ELSE #else ELSE IF ( ( switch .EQ. restart_only ) .OR. ( switch .EQ. history_only ) ) THEN @@ -642,6 +644,10 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'SGFDDA_END_H', sgfdda_end_h , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'HYPSOMETRIC_OPT', hypsometric_opt , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'USE_THETA_M', use_theta_m , 1 , ierr ) + IF ( switch .EQ. input_only) THEN + CALL wrf_put_dom_ti_integer ( fid, 'USE_MAXW_LEVEL', use_maxw_level , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'USE_TROP_LEVEL', use_trop_level , 1 , ierr ) + END IF #endif IF ( switch .EQ. history_only ) THEN @@ -705,7 +711,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL wrf_put_dom_ti_real ( fid, 'DTRAMP_MIN', dtramp_min , 1 , ierr ) ENDIF - IF ( grid_sfdda == 1 ) THEN + IF ( grid_sfdda >= 1 ) THEN CALL wrf_put_dom_ti_real ( fid, 'GUV_SFC', guv_sfc , 1 , ierr ) CALL wrf_put_dom_ti_real ( fid, 'GT_SFC', gt_sfc , 1 , ierr ) CALL wrf_put_dom_ti_real ( fid, 'GQ_SFC', gq_sfc , 1 , ierr ) @@ -757,6 +763,8 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'OPT_SNF', config_flags%opt_snf , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'OPT_TBOT', config_flags%opt_tbot , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid, 'OPT_STC', config_flags%opt_stc , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'OPT_GLA', config_flags%opt_gla , 1 , ierr ) + CALL wrf_put_dom_ti_integer ( fid, 'OPT_RSF', config_flags%opt_rsf , 1 , ierr ) ENDIF @@ -908,7 +916,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) CALL wrf_put_dom_ti_integer ( fid , 'ISOILWATER' , config_flags%isoilwater , 1 , ierr ) ! added these fields for restarting of moving nests, JM !For HWRF: zhang -#if defined (HWRF) +#if ( HWRF == 1 ) CALL wrf_put_dom_ti_integer ( fid , 'I_PARENT_START' , grid%i_parent_start , 1 , ierr ) CALL wrf_put_dom_ti_integer ( fid , 'J_PARENT_START' , grid%j_parent_start , 1 , ierr ) #elif ! defined(EM_CORE) @@ -1505,7 +1513,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr ) IF ( switch .EQ. history_only .AND. config_flags%output_ready_flag ) THEN WRITE ( wrf_err_message , FMT='(I2.2)' ) grid%id - CALL get_nio_tasks_in_group ( nio_tasks_per_group ) + CALL get_nio_tasks_in_group ( grid%id, nio_tasks_per_group ) IF ( nio_tasks_per_group .EQ. 0 ) THEN OPEN ( UNIT = 99 , & FILE = 'wrfoutReady_d' // wrf_err_message(1:2) // '_' // TRIM(current_date) , & diff --git a/wrfv2_fire/share/set_timekeeping.F b/wrfv2_fire/share/set_timekeeping.F index f0f064e8..4aa2e64f 100644 --- a/wrfv2_fire/share/set_timekeeping.F +++ b/wrfv2_fire/share/set_timekeeping.F @@ -13,7 +13,7 @@ SUBROUTINE Setup_Timekeeping ( grid ) INTEGER :: start_year,start_month,start_day,start_hour,start_minute,start_second INTEGER :: end_year,end_month,end_day,end_hour,end_minute,end_second INTEGER :: vortex_interval -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing real (kind=8) :: day_in_sec REAL :: tstart @@ -85,7 +85,7 @@ SUBROUTINE Setup_Timekeeping ( grid ) CALL nl_get_start_hour(grid%id,start_hour) CALL nl_get_start_minute(grid%id,start_minute) CALL nl_get_start_second(grid%id,start_second) -#ifdef HWRF +#if ( HWRF == 1 ) !zhang's doing - check with zhan before adding this bit ! CALL nl_get_tstart ( grid%id , tstart ) ! CALL jdn_sec(day_in_sec,start_year,start_month,start_day,start_hour,start_minute,start_second) diff --git a/wrfv2_fire/share/sint.F b/wrfv2_fire/share/sint.F index d543a8f7..859e2a44 100644 --- a/wrfv2_fire/share/sint.F +++ b/wrfv2_fire/share/sint.F @@ -218,9 +218,9 @@ SUBROUTINE SINTB(XF1, XF , & REAL XF(ims:ime,jms:jme,NF) REAL XF1(ims:ime,jms:jme,NF) ! - REAL Y(ims:ime,jms:jme,-IOR:IOR), & - Z(ims:ime,jms:jme,-IOR:IOR), & - F(ims:ime,jms:jme,0:1) + REAL Y(-IOR:IOR), & + Z(ims:ime,-IOR:IOR), & + F(0:1) ! INTEGER I,J,II,JJ,IIM INTEGER N2STAR, N2END, N1STAR, N1END @@ -230,9 +230,9 @@ SUBROUTINE SINTB(XF1, XF , & ! PARAMETER(NONOS=1) ! PARAMETER(N1OS=N1*NONOS+1-NONOS,N2OS=N2*NONOS+1-NONOS) ! - REAL W(ims:ime,jms:jme),OV(ims:ime,jms:jme),UN(ims:ime,jms:jme) - REAL MXM(ims:ime,jms:jme),MN(ims:ime,jms:jme) - REAL FL(ims:ime,jms:jme,0:1) + REAL W,OV,UN + REAL MXM,MN + REAL FL(0:1) REAL XIG(NF*NF), XJG(NF*NF) ! NF is the parent to child grid refinement ratio integer rr @@ -276,55 +276,39 @@ SUBROUTINE SINTB(XF1, XF , & DO 50 J=-IOR,IOR !cdir unroll=5 - DO 51 I=-IOR,IOR DO 511 II=N1STAR,N1END - Y(II,JJ,I)=XF1(II+I,JJ+J,IIM) - 511 CONTINUE - 51 CONTINUE + Y(-2)=XF1(II-2,JJ+J,IIM) + Y(-1)=XF1(II-1,JJ+J,IIM) + Y(0)=XF1(II,JJ+J,IIM) + Y(1)=XF1(II+1,JJ+J,IIM) + Y(2)=XF1(II+2,JJ+J,IIM) - DO 811 II=N1STAR,N1END - FL(II,JJ,0)=DONOR(Y(II,JJ,-1),Y(II,JJ,0),XIG(IIM)) - FL(II,JJ,1)=DONOR(Y(II,JJ,0),Y(II,JJ,1),XIG(IIM)) - 811 CONTINUE - DO 812 II=N1STAR,N1END - W(II,JJ)=Y(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0)) - 812 CONTINUE - DO 813 II=N1STAR,N1END - MXM(II,JJ)= & - AMAX1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1), & - W(II,JJ)) - MN(II,JJ)=AMIN1(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),W(II,JJ)) - 813 CONTINUE - DO 312 II=N1STAR,N1END - F(II,JJ,0)= & - TR4(Y(II,JJ,-2),Y(II,JJ,-1),Y(II,JJ,0), & - Y(II,JJ,1),XIG(IIM)) - F(II,JJ,1)= & - TR4(Y(II,JJ,-1),Y(II,JJ,0),Y(II,JJ,1),Y(II,JJ,2),& + FL(0)=DONOR(Y(-1),Y(0),XIG(IIM)) + FL(1)=DONOR(Y(0),Y(1),XIG(IIM)) + W=Y(0)-(FL(1)-FL(0)) + MXM= & + AMAX1(Y(-1),Y(0),Y(1), & + W) + MN=AMIN1(Y(-1),Y(0),Y(1),W) + F(0)= & + TR4(Y(-2),Y(-1),Y(0), & + Y(1),XIG(IIM)) + F(1)= & + TR4(Y(-1),Y(0),Y(1),Y(2),& XIG(IIM)) - 312 CONTINUE - DO 822 II=N1STAR,N1END - F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0) - F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1) - 822 CONTINUE - DO 823 II=N1STAR,N1END - OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+ & - PP(F(II,JJ,0))+EP) - UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))- & - PN(F(II,JJ,0))+EP) - 823 CONTINUE - DO 824 II=N1STAR,N1END - F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+ & - PN(F(II,JJ,0))*AMIN1(1.,UN(II,JJ)) - F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+ & - PN(F(II,JJ,1))*AMIN1(1.,OV(II,JJ)) - 824 CONTINUE - DO 825 II=N1STAR,N1END - Y(II,JJ,0)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0)) - 825 CONTINUE - DO 361 II=N1STAR,N1END - Z(II,JJ,J)=Y(II,JJ,0) - 361 CONTINUE + F(0)=F(0)-FL(0) + F(1)=F(1)-FL(1) + OV=(MXM-W)/(-PN(F(1))+ & + PP(F(0))+EP) + UN=(W-MN)/(PP(F(1))- & + PN(F(0))+EP) + F(0)=PP(F(0))*AMIN1(1.,OV)+ & + PN(F(0))*AMIN1(1.,UN) + F(1)=PP(F(1))*AMIN1(1.,UN)+ & + PN(F(1))*AMIN1(1.,OV) + Y(0)=W-(F(1)-F(0)) + Z(II,J)=Y(0) + 511 CONTINUE ! ! END IF FIRST J LOOP ! @@ -332,45 +316,30 @@ SUBROUTINE SINTB(XF1, XF , & 50 CONTINUE DO 911 II=N1STAR,N1END - FL(II,JJ,0)=DONOR(Z(II,JJ,-1),Z(II,JJ,0),XJG(IIM)) - FL(II,JJ,1)=DONOR(Z(II,JJ,0),Z(II,JJ,1),XJG(IIM)) - 911 CONTINUE - DO 912 II=N1STAR,N1END - W(II,JJ)=Z(II,JJ,0)-(FL(II,JJ,1)-FL(II,JJ,0)) - 912 CONTINUE - DO 913 II=N1STAR,N1END - MXM(II,JJ)=AMAX1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ)) - MN(II,JJ)=AMIN1(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),W(II,JJ)) - 913 CONTINUE - DO 412 II=N1STAR,N1END - F(II,JJ,0)= & - TR4(Z(II,JJ,-2),Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1)& - ,XJG(IIM)) - F(II,JJ,1)= & - TR4(Z(II,JJ,-1),Z(II,JJ,0),Z(II,JJ,1),Z(II,JJ,2), & - XJG(IIM)) - 412 CONTINUE - DO 922 II=N1STAR,N1END - F(II,JJ,0)=F(II,JJ,0)-FL(II,JJ,0) - F(II,JJ,1)=F(II,JJ,1)-FL(II,JJ,1) - 922 CONTINUE - DO 923 II=N1STAR,N1END - OV(II,JJ)=(MXM(II,JJ)-W(II,JJ))/(-PN(F(II,JJ,1))+ & - PP(F(II,JJ,0))+EP) - UN(II,JJ)=(W(II,JJ)-MN(II,JJ))/(PP(F(II,JJ,1))-PN(F(II,JJ,0))+ & + FL(0)=DONOR(Z(II,-1),Z(II,0),XJG(IIM)) + FL(1)=DONOR(Z(II,0),Z(II,1),XJG(IIM)) + W=Z(II,0)-(FL(1)-FL(0)) + MXM=AMAX1(Z(II,-1),Z(II,0),Z(II,1),W) + MN=AMIN1(Z(II,-1),Z(II,0),Z(II,1),W) + F(0)= & + TR4(Z(II,-2),Z(II,-1),Z(II,0),Z(II,1)& + ,XJG(IIM)) + F(1)= & + TR4(Z(II,-1),Z(II,0),Z(II,1),Z(II,2), & + XJG(IIM)) + F(0)=F(0)-FL(0) + F(1)=F(1)-FL(1) + OV=(MXM-W)/(-PN(F(1))+ & + PP(F(0))+EP) + UN=(W-MN)/(PP(F(1))-PN(F(0))+ & EP) - 923 CONTINUE - DO 924 II=N1STAR,N1END - F(II,JJ,0)=PP(F(II,JJ,0))*AMIN1(1.,OV(II,JJ))+PN(F(II,JJ,0)) & - *AMIN1(1.,UN(II,JJ)) - F(II,JJ,1)=PP(F(II,JJ,1))*AMIN1(1.,UN(II,JJ))+PN(F(II,JJ,1)) & - *AMIN1(1.,OV(II,JJ)) - 924 CONTINUE + F(0)=PP(F(0))*AMIN1(1.,OV)+PN(F(0)) & + *AMIN1(1.,UN) + F(1)=PP(F(1))*AMIN1(1.,UN)+PN(F(1)) & + *AMIN1(1.,OV) + XF(II,JJ,IIM)=W-(F(1)-F(0)) + 911 CONTINUE 9000 CONTINUE - DO 925 JJ=N2STAR,N2END - DO 925 II=N1STAR,N1END - XF(II,JJ,IIM)=W(II,JJ)-(F(II,JJ,1)-F(II,JJ,0)) - 925 CONTINUE ! 2000 CONTINUE diff --git a/wrfv2_fire/share/solve_interface.F b/wrfv2_fire/share/solve_interface.F index 5084a6c3..fcdef177 100644 --- a/wrfv2_fire/share/solve_interface.F +++ b/wrfv2_fire/share/solve_interface.F @@ -13,16 +13,16 @@ SUBROUTINE solve_interface ( grid ) INTERFACE #if (EM_CORE == 1 && DA_CORE != 1) -# include +# include "solve_em.int" #endif #if (NMM_CORE == 1) -# include +# include "solve_nmm.int" #endif #if (COAMPS_CORE == 1) -# include +# include "solve_coamps.int" #endif #if (EXP_CORE == 1) -# include +# include "solve_exp.int" #endif END INTERFACE @@ -37,7 +37,7 @@ SUBROUTINE solve_interface ( grid ) #if (EM_CORE == 1 && DA_CORE != 1) CALL solve_em ( grid , config_flags & ! -# include +# include "actual_new_args.inc" ! ) @@ -46,7 +46,7 @@ SUBROUTINE solve_interface ( grid ) CALL chem_driver ( grid , config_flags & ! -# include +# include "actual_new_args.inc" ! ) ENDIF @@ -55,7 +55,7 @@ SUBROUTINE solve_interface ( grid ) #if (NMM_CORE == 1) CALL solve_nmm ( grid , config_flags & ! -# include +# include "actual_new_args.inc" ! ) # if ( WRF_CHEM == 1 ) @@ -63,7 +63,7 @@ SUBROUTINE solve_interface ( grid ) CALL chem_driver ( grid , config_flags & ! -# include +# include "actual_new_args.inc" ! ) ENDIF @@ -72,7 +72,7 @@ SUBROUTINE solve_interface ( grid ) #if (COAMPS_CORE == 1) CALL solve_coamps ( grid , config_flags & ! -# include +# include "actual_new_args.inc" ! ) #endif @@ -82,7 +82,7 @@ SUBROUTINE solve_interface ( grid ) #if (EXP_CORE == 1) CALL solve_exp ( grid & ! -# include +# include "exp_actual_args.inc" ! ) #endif diff --git a/wrfv2_fire/share/start_domain.F b/wrfv2_fire/share/start_domain.F index daa26e09..daf5a858 100644 --- a/wrfv2_fire/share/start_domain.F +++ b/wrfv2_fire/share/start_domain.F @@ -39,21 +39,21 @@ END SUBROUTINE calc_track_locations #if ((EM_CORE == 1) && (DA_CORE != 1)) CALL start_domain_em( grid, allowed_to_read & ! -# include +# include "actual_new_args.inc" ! ) #endif #if (NMM_CORE == 1) CALL start_domain_nmm( grid, allowed_to_read & ! -# include +# include "actual_new_args.inc" ! ) #endif #if (COAMPS_CORE == 1) CALL start_domain_coamps( grid, allowed_to_read & ! -# include +# include "actual_new_args.inc" ! ) #endif diff --git a/wrfv2_fire/share/track_input.F b/wrfv2_fire/share/track_input.F index 517b3b7e..de2d107d 100644 --- a/wrfv2_fire/share/track_input.F +++ b/wrfv2_fire/share/track_input.F @@ -5,8 +5,8 @@ SUBROUTINE track_input ( grid , ierr ) IMPLICIT NONE -#include -#include +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" TYPE(domain), INTENT(INOUT) :: grid INTEGER, INTENT(INOUT) :: ierr diff --git a/wrfv2_fire/share/wrf_bdyin.F b/wrfv2_fire/share/wrf_bdyin.F index 8325c0be..8387d19d 100644 --- a/wrfv2_fire/share/wrf_bdyin.F +++ b/wrfv2_fire/share/wrf_bdyin.F @@ -9,8 +9,8 @@ SUBROUTINE wrf_bdyin ( fid , grid , config_flags , switch , ierr ) USE module_bc_time_utilities USE module_utility IMPLICIT NONE -#include -#include +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags INTEGER, INTENT(IN) :: fid @@ -51,7 +51,7 @@ SUBROUTINE wrf_bdyin ( fid , grid , config_flags , switch , ierr ) ips, ipe, jps, jpe, kps, kpe ) -#include +#include "wrf_bdyin.inc" RETURN END diff --git a/wrfv2_fire/share/wrf_bdyout.F b/wrfv2_fire/share/wrf_bdyout.F index 35c84096..bbada428 100644 --- a/wrfv2_fire/share/wrf_bdyout.F +++ b/wrfv2_fire/share/wrf_bdyout.F @@ -9,8 +9,8 @@ SUBROUTINE wrf_bdyout ( fid , grid , config_flags, switch , & USE module_scalar_tables USE module_utility IMPLICIT NONE -#include -#include +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags INTEGER, INTENT(IN) :: fid, switch @@ -50,7 +50,7 @@ SUBROUTINE wrf_bdyout ( fid , grid , config_flags, switch , & ! of module_io_wrf ! generated by the registry -#include +#include "wrf_bdyout.inc" RETURN END diff --git a/wrfv2_fire/share/wrf_fddaobs_in.F b/wrfv2_fire/share/wrf_fddaobs_in.F index 4e8e0192..a10e8972 100644 --- a/wrfv2_fire/share/wrf_fddaobs_in.F +++ b/wrfv2_fire/share/wrf_fddaobs_in.F @@ -306,6 +306,8 @@ SUBROUTINE in4dob(inest, xtime, ktau, ktaur, dtmin, & integer :: iyear, itimob !obsnypatch integer :: errcnt DATA NMOVE/0/,NVOLA/61/ + character*140 file_name_on_obs_unit, obs_domain_file_name + integer :: obs_domain_file_unit ! if(ieof(inest).eq.2.and.fdob%nstat.eq.0)then ! IF (iprt) print *,'returning from in4dob' @@ -419,13 +421,15 @@ SUBROUTINE in4dob(inest, xtime, ktau, ktaur, dtmin, & ! open file if at beginning or restart IF(KTAU.EQ.0.OR.KTAU.EQ.KTAUR) THEN fdob%RTLAST=-999. - INQUIRE (NVOLA+INEST-1,OPENED=OPENED) - IF (.NOT. OPENED) THEN + obs_domain_file_unit = NVOLA+INEST-1 + INQUIRE (obs_domain_file_unit,NAME=file_name_on_obs_unit,OPENED=OPENED) + !Build obs nudging file name (OBS_DOMAINX01 where X is the current domain number) ifon(inest)=1 write(fonc(1:2),'(i2)')ifon(inest) if(fonc(1:1).eq.' ')fonc(1:1)='0' - INQUIRE (file='OBS_DOMAIN'//CHAR(INEST+ICHAR('0'))//fonc(1:2) & - ,EXIST=exist) + obs_domain_file_name='OBS_DOMAIN'//CHAR(INEST+ICHAR('0'))//fonc(1:2) + IF (.NOT. OPENED) THEN + INQUIRE (file=obs_domain_file_name,EXIST=exist) if(exist)then IF (iprt) THEN write(msg,*) 'opening first fdda obs file, fonc=', & @@ -434,15 +438,27 @@ SUBROUTINE in4dob(inest, xtime, ktau, ktaur, dtmin, & write(msg,*) 'ifon=',ifon(inest) call wrf_message(msg) ENDIF - OPEN(NVOLA+INEST-1, & - FILE='OBS_DOMAIN'//CHAR(INEST+ICHAR('0'))//fonc(1:2), & - FORM='FORMATTED',STATUS='OLD') + OPEN(obs_domain_file_unit,FILE=obs_domain_file_name,FORM='FORMATTED',STATUS='OLD') else ! no first file to open IF (iprt) call wrf_message("there are no fdda obs files to open") return endif - + ELSE + !If the unit for observation nudging file is already open make sure the file + !name matches the expected name to ensure that some other part of WRF has + !not opened a file using the same unit number + IF(file_name_on_obs_unit .ne. obs_domain_file_name) THEN + write(msg,*) 'File open on obs nudging unit (',obs_domain_file_unit,') with wrong name' + call wrf_message(msg) + write(msg,*) 'File open on obs nudging unit is named ',& + trim(adjustl(file_name_on_obs_unit)),' but it should be named ',& + trim(adjustl(obs_domain_file_name)) + call wrf_message(msg) + write(msg,*) 'This likely means this unit number was opened elsewhere in WRF' + call wrf_message(msg) + call wrf_error_fatal ( 'wrf_fddaobs_in: in4dob STOP Obs nudging file name mismatch' ) + ENDIF ENDIF ENDIF !end if(KTAU.EQ.0.OR.KTAU.EQ.KTAUR) ! print *,'at jc check1' diff --git a/wrfv2_fire/share/wrf_restartin.F b/wrfv2_fire/share/wrf_restartin.F index 35139c3d..e8464da4 100644 --- a/wrfv2_fire/share/wrf_restartin.F +++ b/wrfv2_fire/share/wrf_restartin.F @@ -9,8 +9,8 @@ SUBROUTINE wrf_restartin ( fid , grid , config_flags , switch , ierr ) USE module_bc_time_utilities USE module_utility IMPLICIT NONE -#include -#include +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags INTEGER, INTENT(IN) :: fid @@ -51,7 +51,7 @@ SUBROUTINE wrf_restartin ( fid , grid , config_flags , switch , ierr ) ips, ipe, jps, jpe, kps, kpe ) -#include +#include "wrf_restartin.inc" RETURN END diff --git a/wrfv2_fire/share/wrf_restartout.F b/wrfv2_fire/share/wrf_restartout.F index 5e95a0ef..951650d4 100644 --- a/wrfv2_fire/share/wrf_restartout.F +++ b/wrfv2_fire/share/wrf_restartout.F @@ -9,8 +9,8 @@ SUBROUTINE wrf_restartout ( fid , grid , config_flags, switch , & USE module_scalar_tables USE module_utility IMPLICIT NONE -#include -#include +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" TYPE(domain) :: grid TYPE(grid_config_rec_type), INTENT(INOUT) :: config_flags INTEGER, INTENT(IN) :: fid, switch @@ -50,7 +50,7 @@ SUBROUTINE wrf_restartout ( fid , grid , config_flags, switch , & ! of module_io_wrf ! generated by the registry -#include +#include "wrf_restartout.inc" RETURN END diff --git a/wrfv2_fire/share/wrf_timeseries.F b/wrfv2_fire/share/wrf_timeseries.F index 4ef91ff1..2de85fc3 100644 --- a/wrfv2_fire/share/wrf_timeseries.F +++ b/wrfv2_fire/share/wrf_timeseries.F @@ -63,8 +63,13 @@ SUBROUTINE calc_ts_locations( grid ) IF (ips <= 1 .AND. 1 <= ipe .AND. & jps <= 1 .AND. 1 <= jpe) THEN +#if(NMM_CORE==1) + known_lat = grid%hlat(1,1) + known_lon = grid%hlon(1,1) +#else known_lat = grid%xlat(1,1) known_lon = grid%xlong(1,1) +#endif ELSE known_lat = 9999. known_lon = 9999. @@ -180,8 +185,13 @@ SUBROUTINE calc_ts_locations( grid ) ts_xlong = 1.E30 ts_hgt = 1.E30 ELSE +#if(NMM_CORE==1) + ts_xlat = grid%hlat(grid%itsloc(k),grid%jtsloc(k)) + ts_xlong = grid%hlon(grid%itsloc(k),grid%jtsloc(k)) +#else ts_xlat = grid%xlat(grid%itsloc(k),grid%jtsloc(k)) ts_xlong = grid%xlong(grid%itsloc(k),grid%jtsloc(k)) +#endif #if (EM_CORE == 1) ts_hgt = grid%ht(grid%itsloc(k),grid%jtsloc(k)) #endif diff --git a/wrfv2_fire/share/wrf_tsin.F b/wrfv2_fire/share/wrf_tsin.F index 9ad3c666..13bfbacb 100644 --- a/wrfv2_fire/share/wrf_tsin.F +++ b/wrfv2_fire/share/wrf_tsin.F @@ -5,8 +5,8 @@ SUBROUTINE wrf_tsin ( grid , ierr ) IMPLICIT NONE -#include -#include +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" TYPE(domain), INTENT(INOUT) :: grid INTEGER, INTENT(INOUT) :: ierr diff --git a/wrfv2_fire/test/em_convrad/run_me_first.csh b/wrfv2_fire/test/em_convrad/run_me_first.csh index f9fe64ba..5f6ecb63 100755 --- a/wrfv2_fire/test/em_convrad/run_me_first.csh +++ b/wrfv2_fire/test/em_convrad/run_me_first.csh @@ -1,6 +1,6 @@ #!/bin/csh -echo Setting up seabreeze2d_x case by linking data files into this directory +echo Setting up em_convrad case by linking data files into this directory echo linking to some physics data files in ../../run directory @@ -8,5 +8,8 @@ ln -sf ../../run/LANDUSE.TBL . ln -sf ../../run/RRTM_DATA . ln -sf ../../run/RRTMG_LW_DATA . ln -sf ../../run/RRTMG_SW_DATA . +ln -sf ../../run/ozone.formatted . +ln -sf ../../run/ozone_lat.formatted . +ln -sf ../../run/ozone_plev.formatted . echo done diff --git a/wrfv2_fire/test/em_les/input_sounding.SGP b/wrfv2_fire/test/em_les/input_sounding.SGP new file mode 100644 index 00000000..f796c148 --- /dev/null +++ b/wrfv2_fire/test/em_les/input_sounding.SGP @@ -0,0 +1,737 @@ + 959.3770 295.1785 12.8526 + 12.9000 295.7188 13.0106 0.5077 9.6867 + 21.3000 295.8720 13.0536 0.5443 10.3857 + 29.8000 295.9546 13.0170 0.7813 11.1727 + 39.7000 295.9502 12.9626 1.0372 11.8547 + 51.9000 295.9282 12.8787 1.0982 12.5521 + 64.6000 295.9108 12.7958 1.3902 13.2271 + 75.9000 295.8895 12.7231 1.6940 13.7964 + 85.7000 295.9149 12.7006 1.7793 14.4912 + 94.9000 295.9646 12.7047 2.1293 15.1511 + 105.3000 296.0978 12.7778 2.2129 15.7453 + 118.0000 296.1299 12.7682 2.5812 16.2969 + 131.1000 296.0255 12.6548 2.9694 16.8402 + 143.2000 295.9722 12.5883 3.0562 17.3326 + 153.7000 295.9639 12.5675 3.4727 17.8656 + 163.4000 295.9772 12.5578 3.5681 18.3564 + 171.1000 295.9921 12.5503 3.9919 18.7804 + 175.3000 296.0341 12.5750 4.0751 19.1717 + 182.1000 296.1206 12.6148 4.4990 19.4874 + 194.7000 296.4078 12.7705 4.5890 19.8771 + 206.8000 296.7807 13.0016 5.0078 20.0851 + 215.3000 296.8949 13.0504 5.0804 20.3762 + 221.9000 297.0311 13.1307 5.5128 20.5742 + 231.6000 296.9842 13.0419 5.5646 20.7674 + 242.8000 296.9518 12.9560 5.6164 20.9606 + 252.9000 296.9087 12.8692 6.0089 20.9555 + 263.7000 297.0257 12.9109 6.0089 20.9555 + 275.7000 297.2048 13.0005 6.0365 21.0516 + 289.7000 297.2206 12.9501 6.4322 21.0387 + 303.5000 297.2143 12.8884 6.4614 21.1343 + 315.4000 297.0776 12.7447 6.8293 21.0183 + 326.1000 297.1110 12.7496 6.8602 21.1135 + 336.7000 297.2867 12.8688 6.8911 21.2086 + 349.0000 297.3676 12.9015 7.2927 21.1796 + 361.5000 297.3390 12.8450 7.3253 21.2742 + 371.0000 297.3201 12.8138 7.7297 21.2371 + 380.1000 297.3385 12.8128 7.7639 21.3310 + 390.6000 297.3700 12.8149 8.2066 21.3790 + 400.6000 297.3875 12.8098 8.6160 21.3252 + 410.0000 297.4091 12.8136 8.6534 21.4179 + 420.1000 297.4371 12.8197 9.0650 21.3557 + 431.0000 297.4838 12.8236 9.1431 21.5398 + 441.5000 297.6705 12.9310 9.5583 21.4683 + 451.6000 297.8006 12.9856 9.5990 21.5597 + 462.9000 297.9438 13.0308 10.0161 21.4795 + 475.1000 298.1479 13.1078 10.1006 21.6608 + 488.0000 298.3579 13.1858 10.5209 21.5711 + 499.6000 298.4310 13.1617 10.9866 21.5624 + 510.2000 298.8040 13.3800 11.0320 21.6515 + 520.3000 299.0278 13.4708 11.4551 21.5439 + 530.9000 299.0724 13.3988 11.5490 21.7205 + 543.2000 299.3894 13.5456 11.9748 21.6031 + 555.4000 299.6853 13.6795 12.4000 21.4774 + 566.7000 299.6847 13.5833 12.5000 21.6506 + 577.9000 299.6421 13.4663 12.9275 21.5149 + 589.0000 299.5986 13.3629 12.9790 21.6006 + 600.8000 299.5402 13.2394 13.4070 21.4556 + 614.1000 299.5394 13.1480 13.8883 21.3861 + 627.5000 299.7038 13.1865 13.9428 21.4700 + 639.7000 299.8466 13.2105 14.3713 21.3063 + 651.0000 300.0515 13.2702 14.7983 21.1341 + 662.6000 300.3741 13.4276 14.8556 21.2160 + 676.3000 300.6355 13.5238 15.2824 21.0344 + 690.0000 300.6999 13.4603 15.7074 20.8444 + 703.1000 300.7174 13.3657 15.7676 20.9243 + 717.5000 300.7787 13.3197 16.1919 20.7247 + 731.6000 300.8363 13.2733 16.6141 20.5167 + 743.8000 300.7928 13.1618 16.6770 20.5944 + 755.6000 300.8077 13.1052 17.0982 20.3768 + 768.2000 300.8823 13.0960 17.5168 20.1507 + 781.4000 300.9734 13.1003 17.5824 20.2262 + 795.2000 301.1017 13.1349 17.9996 19.9906 + 809.1000 301.2095 13.1529 18.4140 19.7466 + 823.6000 301.2933 13.1492 18.8252 19.4941 + 838.4000 301.3689 13.1401 18.8252 19.4941 + 852.8000 301.4305 13.1247 19.2333 19.2333 + 867.0000 301.5110 13.1284 19.6380 18.9642 + 881.6000 301.6062 13.1475 20.0391 18.6868 + 896.4000 301.6611 13.1368 20.3622 18.3342 + 911.1000 301.7266 13.1200 20.4365 18.4011 + 925.9000 301.7912 13.0886 20.8300 18.1072 + 939.4000 302.1570 13.2779 21.1428 17.7409 + 952.8000 302.7412 13.6257 21.5269 17.4322 + 968.0000 303.1231 13.7718 21.5269 17.4322 + 982.6000 303.2709 13.7130 21.9067 17.1154 + 996.9000 303.3105 13.5553 22.2021 16.7305 + 1011.1000 303.4757 13.4999 22.2819 16.7906 + 1025.6000 304.0928 13.8230 22.5716 16.3992 + 1040.2000 304.2609 13.7763 22.8543 16.0028 + 1055.0000 304.1802 13.5318 23.1301 15.6015 + 1068.2000 304.2509 13.4350 23.1301 15.6015 + 1078.6000 304.3141 13.3485 23.3989 15.1954 + 1087.9000 304.4814 13.3353 23.3989 15.1954 + 1096.3000 304.7036 13.3468 23.6605 14.7848 + 1105.1000 304.8652 13.2646 23.9150 14.3696 + 1114.8000 305.0161 13.1102 23.8292 14.3181 + 1124.1000 305.2366 13.0078 24.0755 13.9000 + 1133.2000 305.4868 12.9306 24.0755 13.9000 + 1142.1000 305.5976 12.7378 24.2270 13.4292 + 1150.3000 305.6813 12.5041 24.1395 13.3807 + 1157.9000 305.7894 12.2819 24.2811 12.9105 + 1164.8000 306.0489 12.1239 24.1928 12.8635 + 1172.8000 306.3199 11.9011 24.1045 12.8166 + 1181.1000 306.5618 11.5798 24.2354 12.3485 + 1189.3000 306.7912 11.1601 24.1463 12.3031 + 1197.8000 307.0776 10.6743 23.9681 12.2123 + 1206.8000 307.4746 10.2426 24.0877 11.7483 + 1215.1000 307.8961 9.8622 23.9079 11.6607 + 1222.8000 308.1422 9.4503 23.8180 11.6168 + 1230.5000 308.2106 8.9997 23.6383 11.5292 + 1238.0000 308.2664 8.4339 23.4585 11.4415 + 1246.0000 308.5066 7.8129 23.4734 10.9458 + 1255.8000 309.1115 7.3508 23.3827 10.9035 + 1266.1000 309.5442 6.8502 23.2015 10.8190 + 1275.0000 309.6461 6.2214 23.0202 10.7345 + 1283.3000 309.7407 5.7482 22.8390 10.6500 + 1291.1000 310.0114 5.4465 22.6577 10.5655 + 1298.4000 310.3815 5.1925 22.3858 10.4387 + 1305.3000 310.5670 4.9101 22.2045 10.3541 + 1312.3000 310.6599 4.6882 22.0233 10.2696 + 1319.8000 310.7169 4.5403 21.8420 10.1851 + 1327.0000 310.7593 4.4206 21.6608 10.1006 + 1334.4000 310.7922 4.3013 21.4795 10.0161 + 1341.9000 310.8485 4.1580 21.2982 9.9315 + 1349.4000 310.9988 4.0044 21.1170 9.8470 + 1356.8000 311.1705 3.8284 20.8451 9.7202 + 1364.2000 311.3634 3.6400 20.4925 9.9949 + 1371.9000 311.5692 3.4301 20.3127 9.9072 + 1379.8000 311.7561 3.2248 20.1330 9.8195 + 1388.1000 311.9570 3.0497 19.9532 9.7318 + 1395.5000 312.0764 2.8888 19.7735 9.6442 + 1402.5000 312.1588 2.7419 19.5937 9.5565 + 1409.5000 312.2518 2.6318 19.5038 9.5127 + 1416.5000 312.3565 2.5427 19.1566 9.7608 + 1424.0000 312.4445 2.4608 18.9784 9.6700 + 1431.5000 312.5209 2.3889 18.8002 9.5792 + 1439.3000 312.5700 2.3245 18.6220 9.4884 + 1447.0000 312.6393 2.2580 18.5329 9.4430 + 1454.4000 312.6725 2.1896 18.1887 9.6711 + 1461.5000 312.7035 2.1210 18.1004 9.6242 + 1468.3000 312.7844 2.0586 17.9238 9.5303 + 1475.4000 312.8473 1.9995 17.8355 9.4833 + 1482.7000 312.9020 1.9452 17.6590 9.3894 + 1490.1000 312.9461 1.8964 17.4049 9.6477 + 1497.5000 312.9914 1.8544 17.2300 9.5507 + 1504.4000 313.0206 1.8177 17.1425 9.5023 + 1511.2000 313.0583 1.7824 17.0551 9.4538 + 1518.1000 313.0770 1.7453 16.8802 9.3568 + 1525.1000 313.1287 1.7103 16.7927 9.3083 + 1532.3000 313.2231 1.6783 16.5411 9.5500 + 1539.4000 313.2973 1.6430 16.4545 9.5000 + 1546.4000 313.3386 1.6036 16.2813 9.4000 + 1553.3000 313.3873 1.5640 16.1947 9.3500 + 1560.1000 313.4478 1.5257 16.1081 9.3000 + 1566.9000 313.5084 1.4801 16.0215 9.2500 + 1573.7000 313.5881 1.4103 15.9349 9.2000 + 1580.5000 313.6701 1.3376 15.6862 9.4252 + 1586.9000 313.7477 1.2706 15.6004 9.3737 + 1593.1000 313.8327 1.2096 15.5147 9.3222 + 1599.9000 313.9138 1.1580 15.5147 9.3222 + 1606.8000 313.9748 1.1143 15.4290 9.2707 + 1613.3000 314.0313 1.0789 15.3433 9.2192 + 1619.6000 314.0762 1.0439 15.2576 9.1677 + 1626.0000 314.1104 1.0091 15.1719 9.1162 + 1632.3000 314.1436 0.9820 15.1719 9.1162 + 1638.6000 314.1768 0.9621 15.0861 9.0647 + 1645.1000 314.2028 0.9486 14.8408 9.2736 + 1651.7000 314.2502 0.9430 14.8408 9.2736 + 1657.4000 314.2661 0.9426 14.7560 9.2206 + 1663.7000 314.2674 0.9412 14.6712 9.1676 + 1670.2000 314.2818 0.9404 14.6712 9.1676 + 1676.2000 314.2798 0.9390 14.5864 9.1146 + 1682.7000 314.2942 0.9383 14.5864 9.1146 + 1689.2000 314.2980 0.9370 14.5864 9.1146 + 1695.7000 314.3007 0.9358 14.5016 9.0616 + 1701.8000 314.3119 0.9344 14.5016 9.0616 + 1708.2000 314.3028 0.9313 14.4168 9.0086 + 1714.0000 314.3106 0.9285 14.4168 9.0086 + 1719.6000 314.3257 0.9256 14.4168 9.0086 + 1725.6000 314.3347 0.9216 14.3320 8.9556 + 1731.8000 314.3461 0.9177 14.3320 8.9556 + 1737.8000 314.3445 0.9135 14.3320 8.9556 + 1743.7000 314.3524 0.9103 14.3320 8.9556 + 1749.8000 314.3734 0.9081 14.2472 8.9026 + 1755.7000 314.3922 0.9063 14.2472 8.9026 + 1761.3000 314.4064 0.9047 14.2472 8.9026 + 1766.8999 314.4122 0.9026 14.2472 8.9026 + 1772.3999 314.4051 0.9000 14.2472 8.9026 + 1777.8000 314.4087 0.8979 14.2472 8.9026 + 1782.8000 314.4173 0.8962 14.2472 8.9026 + 1788.2000 314.4198 0.8941 14.1624 8.8497 + 1793.7000 314.4235 0.8920 14.1624 8.8497 + 1798.8999 314.4249 0.8899 14.1624 8.8497 + 1804.3999 314.4286 0.8878 14.1624 8.8497 + 1809.8000 314.4312 0.8857 14.0058 9.0955 + 1815.0000 314.4435 0.8842 14.0058 9.0955 + 1820.3999 314.4450 0.8821 14.0058 9.0955 + 1825.8999 314.4392 0.8795 14.0058 9.0955 + 1831.3999 314.4431 0.8774 14.0058 9.0955 + 1836.8000 314.4351 0.8748 14.0058 9.0955 + 1841.8000 314.4440 0.8732 14.0058 9.0955 + 1847.2000 314.4468 0.8711 14.0058 9.0955 + 1851.8999 314.4427 0.8690 14.0058 9.0955 + 1856.8000 314.4398 0.8668 14.0058 9.0955 + 1862.0000 314.4403 0.8647 14.0058 9.0955 + 1867.0000 314.4386 0.8626 13.9219 9.0410 + 1872.0000 314.4488 0.8611 13.9219 9.0410 + 1876.8999 314.4471 0.8589 13.9219 9.0410 + 1881.8999 314.4454 0.8568 13.9219 9.0410 + 1887.2000 314.4473 0.8548 13.9219 9.0410 + 1892.5000 314.4599 0.8533 13.9219 9.0410 + 1897.8999 314.4629 0.8513 13.9219 9.0410 + 1903.2000 314.4637 0.8492 13.9219 9.0410 + 1908.5000 314.4656 0.8472 13.9219 9.0410 + 1914.0000 314.4687 0.8452 13.9219 9.0410 + 1919.1001 314.4695 0.8431 13.9219 9.0410 + 1924.1001 314.4669 0.8410 13.9219 9.0410 + 1929.0000 314.4762 0.8395 13.9219 9.0410 + 1934.2000 314.4759 0.8374 13.9219 9.0410 + 1939.2000 314.4649 0.8349 13.9219 9.0410 + 1944.3000 314.4635 0.8328 13.9219 9.0410 + 1948.8999 314.4586 0.8307 13.9219 9.0410 + 1953.7000 314.4657 0.8291 13.8381 8.9865 + 1958.8999 314.4667 0.8271 13.8381 8.9865 + 1964.3000 314.4689 0.8250 13.8381 8.9865 + 1969.6001 314.4711 0.8229 13.8381 8.9865 + 1975.0000 314.4745 0.8208 13.8381 8.9865 + 1980.2000 314.4853 0.8191 13.8381 8.9865 + 1985.3999 314.4864 0.8169 13.9219 9.0410 + 1990.3000 314.4732 0.8142 13.9219 9.0410 + 1994.8000 314.4673 0.8120 13.9219 9.0410 + 1999.8000 314.4759 0.8104 13.9219 9.0410 + 2004.7000 314.4735 0.8084 13.7620 9.2826 + 2009.7000 314.4713 0.8065 13.7620 9.2826 + 2014.3000 314.4666 0.8047 13.7620 9.2826 + 2018.3000 314.4646 0.8032 13.7620 9.2826 + 2022.7000 314.4685 0.8019 13.7620 9.2826 + 2027.2000 314.4615 0.8000 13.7620 9.2826 + 2031.7000 314.4546 0.8025 13.8449 9.3385 + 2036.0000 314.4574 0.8082 13.8449 9.3385 + 2040.3000 314.4481 0.8160 13.8449 9.3385 + 2044.5000 314.4497 0.8269 13.8449 9.3385 + 2048.8999 314.4417 0.8402 13.8449 9.3385 + 2053.2000 314.4325 0.8516 13.8449 9.3385 + 2057.5000 314.4245 0.8632 13.9278 9.3944 + 2061.8999 314.4274 0.8754 13.9278 9.3944 + 2066.5000 314.4326 0.8856 13.9278 9.3944 + 2071.1001 314.4378 0.8937 13.9278 9.3944 + 2075.3999 314.4395 0.8998 13.9278 9.3944 + 2080.1001 314.4352 0.9032 13.9278 9.3944 + 2085.0000 314.4440 0.9052 14.0107 9.4504 + 2090.1001 314.4433 0.9066 14.0107 9.4504 + 2094.8000 314.4390 0.9079 14.0107 9.4504 + 2099.0000 314.4396 0.9097 14.0107 9.4504 + 2103.5000 314.4438 0.9116 14.0107 9.4504 + 2108.1001 314.4492 0.9134 14.0107 9.4504 + 2112.7000 314.4546 0.9153 14.0936 9.5063 + 2117.3000 314.4709 0.9178 14.0936 9.5063 + 2122.1001 314.4679 0.9191 14.0936 9.5063 + 2126.8000 314.4734 0.9209 14.0936 9.5063 + 2130.8999 314.4742 0.9234 14.0936 9.5063 + 2135.3000 314.4652 0.9260 14.0936 9.5063 + 2140.0000 314.4828 0.9305 13.9256 9.7508 + 2144.6001 314.4775 0.9346 13.9256 9.7508 + 2149.3000 314.4831 0.9400 13.9256 9.7508 + 2153.8999 314.4888 0.9453 13.9256 9.7508 + 2158.6001 314.4944 0.9507 13.9256 9.7508 + 2163.2000 314.5000 0.9596 14.0075 9.8082 + 2167.8999 314.5056 0.9719 14.0075 9.8082 + 2172.5000 314.5126 0.9880 14.0075 9.8082 + 2177.2000 314.5183 1.0077 14.0075 9.8082 + 2181.8000 314.5240 1.0314 14.0075 9.8082 + 2186.5000 314.5298 1.0554 14.0075 9.8082 + 2191.2000 314.5356 1.0797 14.0075 9.8082 + 2195.8000 314.5292 1.1038 14.0075 9.8082 + 2200.3000 314.5351 1.1263 14.0075 9.8082 + 2204.8000 314.5276 1.1457 14.0075 9.8082 + 2209.2000 314.5299 1.1598 14.0075 9.8082 + 2213.7000 314.5237 1.1689 14.0075 9.8082 + 2218.5000 314.5199 1.1763 13.8342 10.0511 + 2223.2000 314.5161 1.1836 13.8342 10.0511 + 2228.2000 314.5148 1.1909 13.8342 10.0511 + 2233.7000 314.5183 1.1983 13.8342 10.0511 + 2238.7000 314.5170 1.2068 13.9151 10.1099 + 2243.6001 314.5146 1.2166 13.9151 10.1099 + 2248.3000 314.5097 1.2275 13.9151 10.1099 + 2252.7000 314.5133 1.2404 13.9151 10.1099 + 2257.3000 314.5182 1.2547 13.9151 10.1099 + 2261.8000 314.5121 1.2679 13.9151 10.1099 + 2266.3999 314.5170 1.2817 13.9151 10.1099 + 2271.5000 314.5159 1.2945 13.9151 10.1099 + 2276.5000 314.5148 1.3071 13.9960 10.1687 + 2281.1001 314.5197 1.3203 13.9960 10.1687 + 2285.3999 314.5114 1.3326 13.8164 10.4114 + 2289.7000 314.5030 1.3422 13.8164 10.4114 + 2294.3000 314.5068 1.3500 13.8164 10.4114 + 2299.2000 314.5046 1.3544 13.8164 10.4114 + 2304.0000 314.5121 1.3569 13.8164 10.4114 + 2308.8000 314.5196 1.3568 13.8963 10.4716 + 2313.8000 314.5186 1.3559 13.8963 10.4716 + 2319.0000 314.5189 1.3550 13.8963 10.4716 + 2324.1001 314.5302 1.3549 13.8963 10.4716 + 2329.3000 314.5305 1.3540 13.8963 10.4716 + 2333.8999 314.5357 1.3538 13.8963 10.4716 + 2338.2000 314.5372 1.3536 13.8963 10.4716 + 2342.6001 314.5521 1.3543 13.9761 10.5318 + 2347.3000 314.5586 1.3542 13.7902 10.7741 + 2352.3000 314.5676 1.3541 13.7902 10.7741 + 2356.8000 314.5728 1.3539 13.7902 10.7741 + 2361.5000 314.5891 1.3546 13.7902 10.7741 + 2366.0000 314.6041 1.3553 13.7902 10.7741 + 2370.5000 314.6082 1.3551 13.7902 10.7741 + 2375.5000 314.6173 1.3555 13.7902 10.7741 + 2380.2000 314.6130 1.3554 13.7902 10.7741 + 2385.0000 314.5990 1.3551 13.7902 10.7741 + 2390.5000 314.6021 1.3562 13.7902 10.7741 + 2396.0000 314.6064 1.3578 13.7902 10.7741 + 2401.3000 314.6084 1.3593 13.7902 10.7741 + 2406.7000 314.6116 1.3609 13.7902 10.7741 + 2411.6001 314.6196 1.3633 13.7902 10.7741 + 2416.3999 314.6166 1.3647 13.7902 10.7741 + 2421.3999 314.6259 1.3649 13.7902 10.7741 + 2426.5000 314.6255 1.3621 13.7902 10.7741 + 2431.3000 314.6336 1.3581 13.7902 10.7741 + 2436.0000 314.6392 1.3519 13.7114 10.7125 + 2441.1001 314.6596 1.3445 13.7114 10.7125 + 2446.2000 314.6824 1.3372 13.7114 10.7125 + 2451.3999 314.6931 1.3290 13.7114 10.7125 + 2456.1001 314.6891 1.3200 13.7114 10.7125 + 2461.0000 314.6974 1.3119 13.7114 10.7125 + 2466.1001 314.7093 1.3019 13.7114 10.7125 + 2471.1001 314.7176 1.2901 13.6326 10.6509 + 2476.1001 314.7162 1.2756 13.6326 10.6509 + 2481.3000 314.7270 1.2602 13.6326 10.6509 + 2486.0000 314.7451 1.2438 13.6326 10.6509 + 2491.2000 314.7573 1.2294 13.6326 10.6509 + 2497.3000 314.7781 1.2177 13.6326 10.6509 + 2502.8999 314.7953 1.2086 13.5538 10.5894 + 2508.3000 314.7978 1.2012 13.5538 10.5894 + 2513.7000 314.7893 1.1955 13.5538 10.5894 + 2519.0000 314.8016 1.1915 13.5538 10.5894 + 2524.2000 314.8139 1.1874 13.5538 10.5894 + 2529.5000 314.8263 1.1834 13.5538 10.5894 + 2535.0000 314.8301 1.1786 13.4750 10.5278 + 2540.5000 314.8463 1.1747 13.4750 10.5278 + 2546.1001 314.8503 1.1700 13.6567 10.2910 + 2551.5000 314.8530 1.1652 13.6567 10.2910 + 2557.3000 314.8497 1.1598 13.6567 10.2910 + 2562.8000 314.8427 1.1544 13.6567 10.2910 + 2567.8999 314.8418 1.1497 13.6567 10.2910 + 2573.6001 314.8484 1.1451 13.5768 10.2309 + 2579.3000 314.8550 1.1405 13.5768 10.2309 + 2584.6001 314.8456 1.1351 13.5768 10.2309 + 2589.8000 314.8460 1.1305 13.5768 10.2309 + 2595.3999 314.8404 1.1252 13.5768 10.2309 + 2601.3000 314.8484 1.1207 13.5768 10.2309 + 2607.3000 314.8578 1.1162 13.5768 10.2309 + 2613.1001 314.8646 1.1117 13.5768 10.2309 + 2618.8999 314.8714 1.1072 13.5768 10.2309 + 2625.2000 314.8626 1.1013 13.5768 10.2309 + 2631.3000 314.8733 1.0968 13.4969 10.1707 + 2637.1001 314.8680 1.0916 13.4969 10.1707 + 2643.1001 314.8885 1.0879 13.4969 10.1707 + 2649.1001 314.8870 1.0828 13.4969 10.1707 + 2655.1001 314.8856 1.0776 13.4969 10.1707 + 2660.8000 314.8914 1.0732 13.4969 10.1707 + 2667.1001 314.8926 1.0678 13.4969 10.1707 + 2673.1001 314.9023 1.0628 13.4969 10.1707 + 2678.8000 314.8984 1.0568 13.4969 10.1707 + 2684.6001 314.8933 1.0505 13.4969 10.1707 + 2690.3000 314.9006 1.0446 13.4969 10.1707 + 2695.8999 314.9053 1.0393 13.4171 10.1105 + 2701.7000 314.9127 1.0347 13.4171 10.1105 + 2707.7000 314.9102 1.0301 13.4171 10.1105 + 2713.7000 314.9091 1.0261 13.4171 10.1105 + 2719.3999 314.9139 1.0235 13.4171 10.1105 + 2725.6001 314.9155 1.0202 13.4171 10.1105 + 2731.8999 314.9059 1.0163 13.5915 9.8748 + 2738.3999 314.8756 1.0110 13.5915 9.8748 + 2745.0000 314.9033 1.0092 13.5915 9.8748 + 2751.2000 314.9147 1.0066 13.5915 9.8748 + 2757.8000 314.9203 1.0035 13.5915 9.8748 + 2764.3999 314.9246 1.0003 13.5915 9.8748 + 2771.0000 314.9290 0.9972 13.5915 9.8748 + 2777.5000 314.9333 0.9940 13.5915 9.8748 + 2783.5000 314.9424 0.9915 13.5915 9.8748 + 2789.3999 314.9502 0.9889 13.5915 9.8748 + 2795.0000 314.9555 0.9863 13.5915 9.8748 + 2801.2000 314.9562 0.9832 13.5915 9.8748 + 2807.7000 314.9484 0.9794 13.5915 9.8748 + 2813.8000 314.9589 0.9769 13.5915 9.8748 + 2820.1001 314.9610 0.9738 13.5915 9.8748 + 2826.7000 314.9658 0.9707 13.5915 9.8748 + 2833.2000 314.9692 0.9676 13.7618 9.6361 + 2840.0000 314.9766 0.9646 13.7618 9.6361 + 2846.8000 314.9828 0.9615 13.7618 9.6361 + 2853.1001 314.9962 0.9591 13.7618 9.6361 + 2859.2000 314.9959 0.9560 13.7618 9.6361 + 2865.7000 315.0094 0.9536 13.8437 9.6934 + 2872.5000 315.0170 0.9506 13.8437 9.6934 + 2879.2000 315.0109 0.9469 13.8437 9.6934 + 2885.5000 315.0233 0.9445 13.8437 9.6934 + 2892.0000 315.0271 0.9415 13.8437 9.6934 + 2898.6001 315.0211 0.9379 13.8437 9.6934 + 2905.5000 315.0401 0.9356 13.8437 9.6934 + 2912.2000 315.0468 0.9327 13.8437 9.6934 + 2919.0000 315.0534 0.9297 13.8437 9.6934 + 2925.7000 315.0600 0.9268 13.9256 9.7508 + 2932.3000 315.0654 0.9238 13.9256 9.7508 + 2939.1001 315.0821 0.9215 14.0936 9.5063 + 2945.7000 315.0764 0.9180 14.0936 9.5063 + 2952.2000 315.0793 0.9150 14.0936 9.5063 + 2958.8000 315.0849 0.9121 14.0936 9.5063 + 2965.6001 315.0794 0.9089 14.0936 9.5063 + 2972.3000 315.0752 0.9060 14.0936 9.5063 + 2979.2000 315.0836 0.9040 14.0936 9.5063 + 2986.6001 315.0861 0.9017 14.1765 9.5622 + 2993.7000 315.0847 0.8997 14.1765 9.5622 + 3000.1001 315.0866 0.8982 14.1765 9.5622 + 3006.6001 315.0912 0.8966 14.1765 9.5622 + 3013.1001 315.0833 0.8942 14.1765 9.5622 + 3019.3000 315.0840 0.8924 14.1765 9.5622 + 3025.7000 315.0873 0.8905 14.1765 9.5622 + 3032.3999 315.0809 0.8878 14.1765 9.5622 + 3038.8000 315.0843 0.8858 14.1765 9.5622 + 3045.1001 315.0739 0.8831 14.2594 9.6181 + 3051.6001 315.0775 0.8811 14.2594 9.6181 + 3058.0000 315.0811 0.8791 14.2594 9.6181 + 3064.7000 315.0748 0.8764 14.2594 9.6181 + 3071.5000 315.0713 0.8747 14.2594 9.6181 + 3078.5000 315.0691 0.8738 14.2594 9.6181 + 3085.3000 315.0769 0.8744 14.2594 9.6181 + 3092.5000 315.0775 0.8752 14.0894 9.8655 + 3099.6001 315.0754 0.8768 14.0894 9.8655 + 3106.1001 315.0793 0.8790 14.0894 9.8655 + 3112.8999 315.0746 0.8805 14.0894 9.8655 + 3119.8000 315.0840 0.8827 14.0894 9.8655 + 3126.5000 315.0782 0.8842 14.0894 9.8655 + 3133.8000 315.0790 0.8857 14.0894 9.8655 + 3140.8999 315.0773 0.8867 14.0894 9.8655 + 3147.8999 315.0769 0.8870 14.0894 9.8655 + 3155.2000 315.0766 0.8868 14.0894 9.8655 + 3162.2000 315.0876 0.8866 14.0894 9.8655 + 3169.5000 315.0761 0.8846 14.0894 9.8655 + 3176.5000 315.0746 0.8832 14.0894 9.8655 + 3183.6001 315.0844 0.8824 13.9151 10.1099 + 3190.3999 315.0915 0.8815 13.9151 10.1099 + 3197.3999 315.1014 0.8807 13.9151 10.1099 + 3205.0000 315.1055 0.8793 13.9151 10.1099 + 3212.1001 315.1042 0.8779 13.9151 10.1099 + 3218.8999 315.1003 0.8765 13.9151 10.1099 + 3225.8000 315.1091 0.8760 13.9151 10.1099 + 3232.3000 315.1236 0.8765 13.9151 10.1099 + 3238.8999 315.1184 0.8762 13.9151 10.1099 + 3245.5000 315.1120 0.8762 13.8342 10.0511 + 3251.8999 315.1028 0.8766 13.6567 10.2910 + 3258.7000 315.1090 0.8777 13.6567 10.2910 + 3265.1001 315.1012 0.8802 13.6567 10.2910 + 3271.7000 315.1062 0.8853 13.6567 10.2910 + 3279.3000 315.0995 0.8914 13.6567 10.2910 + 3286.2000 315.0961 0.9001 13.6567 10.2910 + 3292.7000 315.0997 0.9114 13.6567 10.2910 + 3299.7000 315.1090 0.9228 13.6567 10.2910 + 3306.8000 315.0970 0.9328 13.6567 10.2910 + 3313.8000 315.0951 0.9427 13.4750 10.5278 + 3320.5000 315.1017 0.9524 13.4750 10.5278 + 3327.2000 315.1070 0.9612 13.4750 10.5278 + 3334.2000 315.1165 0.9693 13.4750 10.5278 + 3341.3999 315.1274 0.9766 13.4750 10.5278 + 3348.3999 315.1257 0.9831 13.4750 10.5278 + 3355.6001 315.1254 0.9891 13.4750 10.5278 + 3362.3999 315.1337 0.9946 13.4750 10.5278 + 3369.0000 315.1492 1.0007 13.4750 10.5278 + 3375.7000 315.1435 1.0053 13.2892 10.7614 + 3382.3000 315.1379 1.0094 13.2892 10.7614 + 3389.2000 315.1450 1.0136 13.2892 10.7614 + 3396.1001 315.1649 1.0180 13.3669 10.8243 + 3403.3999 315.1776 1.0211 13.3669 10.8243 + 3410.5000 315.1877 1.0236 13.3669 10.8243 + 3417.3999 315.1850 1.0254 13.3669 10.8243 + 3424.0000 315.1670 1.0264 13.3669 10.8243 + 3430.7000 315.1729 1.0289 13.3669 10.8243 + 3437.1001 315.1989 1.0331 13.3669 10.8243 + 3443.8000 315.2163 1.0368 13.2526 11.1202 + 3450.6001 315.2111 1.0391 13.2526 11.1202 + 3457.0000 315.2145 1.0423 13.2526 11.1202 + 3463.5000 315.2179 1.0455 13.2526 11.1202 + 3470.1001 315.2114 1.0491 13.2526 11.1202 + 3476.6001 315.2150 1.0544 13.2526 11.1202 + 3483.1001 315.2185 1.0609 13.3292 11.1845 + 3489.3999 315.2207 1.0683 13.3292 11.1845 + 3495.6001 315.2215 1.0768 13.3292 11.1845 + 3501.8000 315.2224 1.0853 13.3292 11.1845 + 3508.2000 315.2247 1.0912 13.3292 11.1845 + 3514.6001 315.2384 1.0953 13.3292 11.1845 + 3521.0000 315.2408 1.0960 13.2074 11.4810 + 3527.3000 315.2418 1.0948 13.2074 11.4810 + 3533.6001 315.2443 1.0912 13.2074 11.4810 + 3540.1001 315.2482 1.0878 13.2074 11.4810 + 3546.7000 315.2294 1.0831 13.2074 11.4810 + 3553.3999 315.2348 1.0801 13.2074 11.4810 + 3559.8000 315.2389 1.0767 13.2074 11.4810 + 3566.1001 315.2287 1.0726 13.2074 11.4810 + 3572.3000 315.2286 1.0703 13.2074 11.4810 + 3578.5000 315.2299 1.0689 13.2074 11.4810 + 3584.8999 315.2327 1.0686 13.2074 11.4810 + 3591.3000 315.2355 1.0693 13.2074 11.4810 + 3598.0000 315.2413 1.0710 13.2074 11.4810 + 3604.2000 315.2414 1.0726 13.2074 11.4810 + 3610.2000 315.2400 1.0742 13.2074 11.4810 + 3616.3999 315.2402 1.0751 13.2074 11.4810 + 3622.6001 315.2418 1.0752 13.2074 11.4810 + 3628.6001 315.2391 1.0746 13.2074 11.4810 + 3634.7000 315.2379 1.0732 13.0050 11.7098 + 3641.0000 315.2397 1.0712 13.0050 11.7098 + 3646.8999 315.2371 1.0691 12.9307 11.6429 + 3652.6001 315.2432 1.0678 12.9307 11.6429 + 3658.5000 315.2521 1.0665 12.9307 11.6429 + 3664.5000 315.2511 1.0644 12.9307 11.6429 + 3670.6001 315.2501 1.0623 12.9307 11.6429 + 3676.8999 315.2635 1.0611 12.9307 11.6429 + 3683.3999 315.2669 1.0594 12.8564 11.5760 + 3689.8999 315.2704 1.0579 12.8564 11.5760 + 3696.3000 315.2725 1.0567 12.8564 11.5760 + 3702.3999 315.2717 1.0557 12.8564 11.5760 + 3708.2000 315.2681 1.0549 12.8564 11.5760 + 3713.8999 315.2745 1.0549 12.7821 11.5090 + 3719.8999 315.2838 1.0540 12.7821 11.5090 + 3726.0000 315.2961 1.0524 12.7821 11.5090 + 3731.8999 315.2797 1.0483 12.7821 11.5090 + 3737.7000 315.2777 1.0442 12.7821 11.5090 + 3743.8000 315.2872 1.0400 12.7078 11.4421 + 3750.0000 315.2881 1.0352 12.7078 11.4421 + 3755.8999 315.2848 1.0309 12.7078 11.4421 + 3761.7000 315.2815 1.0273 12.7078 11.4421 + 3767.8999 315.2811 1.0241 12.7078 11.4421 + 3773.6001 315.2878 1.0219 12.7078 11.4421 + 3779.5000 315.2846 1.0193 12.7078 11.4421 + 3784.8999 315.2871 1.0171 12.5061 11.6622 + 3790.2998 315.2910 1.0147 12.5061 11.6622 + 3796.3999 315.2908 1.0116 12.4330 11.5940 + 3802.2998 315.2992 1.0093 12.4330 11.5940 + 3808.0000 315.3162 1.0076 12.4330 11.5940 + 3813.7002 315.3002 1.0044 12.4330 11.5940 + 3819.5000 315.2843 1.0018 12.4330 11.5940 + 3825.2998 315.2914 1.0014 12.4330 11.5940 + 3830.7998 315.3085 1.0023 12.4330 11.5940 + 3836.8999 315.2956 1.0016 12.4330 11.5940 + 3842.7002 315.3143 1.0031 12.4330 11.5940 + 3848.2998 315.3085 1.0032 12.4330 11.5940 + 3853.7998 315.3128 1.0039 12.4330 11.5940 + 3859.1001 315.3027 1.0038 12.4330 11.5940 + 3865.3999 315.2928 1.0027 12.2288 11.8092 + 3871.3999 315.3031 1.0024 12.2288 11.8092 + 3876.7998 315.3061 1.0016 12.2288 11.8092 + 3882.2002 315.3091 1.0003 12.2288 11.8092 + 3887.5000 315.2991 0.9977 12.2288 11.8092 + 3893.1001 315.2936 0.9952 12.2288 11.8092 + 3898.2998 315.2937 0.9933 12.2288 11.8092 + 3903.6001 315.2953 0.9915 12.2288 11.8092 + 3908.7998 315.3070 0.9904 12.2288 11.8092 + 3913.7002 315.3158 0.9892 12.2288 11.8092 + 3918.7998 315.3160 0.9873 12.0208 12.0208 + 3924.3999 315.3207 0.9855 12.0208 12.0208 + 3929.7002 315.3124 0.9830 12.0208 12.0208 + 3935.2998 315.3172 0.9812 12.0208 12.0208 + 3941.0000 315.3119 0.9788 12.0208 12.0208 + 3946.7002 315.3067 0.9765 12.0208 12.0208 + 3952.1001 315.3101 0.9750 12.0208 12.0208 + 3957.2998 315.3105 0.9737 12.0208 12.0208 + 3962.7002 315.3255 0.9733 12.0208 12.0208 + 3967.8999 315.3144 0.9717 11.8092 12.2288 + 3973.0000 315.3033 0.9700 11.8092 12.2288 + 3978.2002 315.3039 0.9690 11.8092 12.2288 + 3983.5000 315.2944 0.9674 11.8092 12.2288 + 3988.8999 315.3080 0.9683 11.8092 12.2288 + 3994.7002 315.3161 0.9696 11.8092 12.2288 + 4000.7002 315.3489 0.9735 11.8092 12.2288 + 4006.0000 315.3612 0.9776 11.8092 12.2288 + 4011.2002 315.3634 0.9821 11.8092 12.2288 + 4016.6001 315.3772 0.9874 11.8092 12.2288 + 4022.0000 315.3810 0.9918 11.5940 12.4330 + 4028.3999 315.3722 0.9949 11.5940 12.4330 + 4034.5000 315.4052 1.0006 11.5940 12.4330 + 4039.8999 315.4323 1.0059 11.5940 12.4330 + 4044.7998 315.4185 1.0085 11.5940 12.4330 + 4050.2002 315.4210 1.0117 11.5940 12.4330 + 4056.0000 315.4280 1.0145 11.5940 12.4330 + 4061.2998 315.4189 1.0166 11.5940 12.4330 + 4066.6001 315.4083 1.0185 11.5940 12.4330 + 4071.8999 315.4109 1.0213 11.5940 12.4330 + 4077.6001 315.4180 1.0241 11.5940 12.4330 + 4083.2002 315.4221 1.0268 11.6622 12.5062 + 4088.6001 315.4263 1.0295 11.6622 12.5062 + 4093.5000 315.4229 1.0320 11.6622 12.5062 + 4099.0000 315.4272 1.0349 11.6622 12.5062 + 4104.7998 315.4229 1.0373 11.6622 12.5062 + 4110.6001 315.4317 1.0408 11.6622 12.5062 + 4116.3999 315.4275 1.0437 11.6622 12.5062 + 4122.1001 315.4217 1.0467 11.6622 12.5062 + 4127.8999 315.4292 1.0506 11.7304 12.5793 + 4133.6001 315.4250 1.0536 11.7304 12.5793 + 4139.3999 315.4194 1.0559 11.7304 12.5793 + 4145.1001 315.4269 1.0584 11.7304 12.5793 + 4150.8999 315.4229 1.0594 11.7304 12.5793 + 4156.6001 315.4173 1.0597 11.7304 12.5793 + 4162.3999 315.4134 1.0593 11.7986 12.6524 + 4168.1001 315.4195 1.0598 11.7986 12.6524 + 4173.8999 315.4156 1.0594 11.7986 12.6524 + 4179.6001 315.4102 1.0590 11.7986 12.6524 + 4185.3999 315.4180 1.0594 11.7986 12.6524 + 4191.0000 315.4111 1.0595 11.7986 12.6524 + 4196.1001 315.3996 1.0599 11.8668 12.7256 + 4201.7002 315.4044 1.0617 11.8668 12.7256 + 4207.3999 315.3992 1.0632 11.8668 12.7256 + 4213.1001 315.4056 1.0660 11.8668 12.7256 + 4219.1001 315.4050 1.0677 12.0871 12.5165 + 4224.8999 315.4115 1.0697 12.1565 12.5884 + 4230.7002 315.3963 1.0697 12.1565 12.5884 + 4237.2002 315.4005 1.0702 12.1565 12.5884 + 4243.2002 315.3985 1.0703 12.1565 12.5884 + 4248.2998 315.3974 1.0710 12.1565 12.5884 + 4252.7002 315.4119 1.0730 12.2260 12.6604 + 4257.6001 315.4109 1.0735 12.2260 12.6604 + 4263.0000 315.4013 1.0730 12.2260 12.6604 + 4268.6001 315.4065 1.0733 12.2260 12.6604 + 4274.3999 315.4133 1.0735 12.2260 12.6604 + 4279.7002 315.4037 1.0728 12.2955 12.7323 + 4284.6001 315.4013 1.0728 12.2955 12.7323 + 4289.5000 315.4106 1.0737 12.2955 12.7323 + 4294.2998 315.4198 1.0746 12.2955 12.7323 + 4298.7002 315.4229 1.0755 12.5865 12.5865 + 4303.2998 315.4159 1.0757 12.5865 12.5865 + 4308.6001 315.4182 1.0761 12.5865 12.5865 + 4314.7998 315.4066 1.0749 12.5865 12.5865 + 4321.2998 315.3879 1.0730 12.6572 12.6572 + 4327.0000 315.4052 1.0742 12.6572 12.6572 + 4332.2998 315.4076 1.0745 12.6572 12.6572 + 4338.2998 315.4062 1.0741 12.6572 12.6572 + 4345.2998 315.4041 1.0730 12.7279 12.7279 + 4352.2002 315.4005 1.0719 12.7279 12.7279 + 4356.8999 315.4070 1.0729 12.7279 12.7279 + 4361.6001 315.4135 1.0738 12.7279 12.7279 + 4367.1001 315.4060 1.0733 12.7986 12.7986 + 4373.6001 315.3877 1.0713 12.7986 12.7986 + 4379.2998 315.3818 1.0708 12.7986 12.7986 + 4384.0000 315.3767 1.0709 12.7986 12.7986 + 4389.2002 315.3545 1.0695 12.8693 12.8693 + 4394.6001 315.3573 1.0697 12.8693 12.8693 + 4400.7002 315.3680 1.0701 12.8693 12.8693 + 4407.3999 315.3749 1.0697 12.9401 12.9401 + 4412.3999 315.3731 1.0698 12.9401 12.9401 + 4416.3999 315.3602 1.0698 12.9401 12.9401 + 4420.7998 315.3623 1.0706 12.9401 12.9401 + 4425.3999 315.3691 1.0715 13.0108 13.0108 + 4431.0000 315.3871 1.0725 13.0108 13.0108 + 4437.0000 315.3730 1.0711 13.0108 13.0108 + 4442.8999 315.3823 1.0719 13.0815 13.0815 + 4448.8999 315.3918 1.0731 13.0815 13.0815 + 4455.7998 315.3874 1.0734 13.0815 13.0815 + 4463.7998 315.3855 1.0735 13.0815 13.0815 + 4472.2002 315.3885 1.0742 13.1522 13.1522 + 4481.2998 315.3861 1.0742 13.1522 13.1522 + 4490.5000 315.3855 1.0741 13.1522 13.1522 + 4499.3999 315.3817 1.0739 13.1522 13.1522 + 4507.5000 315.3802 1.0750 13.2229 13.2229 + 4514.0000 315.3729 1.0772 13.4517 12.9901 + 4519.2002 315.3615 1.0805 13.4517 12.9901 + 4524.2998 315.3618 1.0852 13.4517 12.9901 + 4529.6001 315.3756 1.0913 13.5236 13.0596 + 4535.8999 315.3888 1.0937 13.5236 13.0596 + 4542.6001 315.3951 1.0925 13.5236 13.0596 + 4549.0000 315.3967 1.0901 13.5236 13.0596 + 4555.2002 315.3747 1.0851 13.5236 13.0596 + 4560.8999 315.3817 1.0815 13.5955 13.1290 + 4566.1001 315.3823 1.0787 13.5955 13.1290 + 4571.3999 315.3845 1.0768 13.5955 13.1290 + 4576.8999 315.3884 1.0750 13.5955 13.1290 + 4583.0000 315.3869 1.0711 13.5955 13.1290 + 4589.1001 315.3753 1.0662 13.5955 13.1290 + 4595.1001 315.3723 1.0678 13.6675 13.1985 + 4601.0000 315.3812 1.0756 13.6675 13.1985 + 4607.7002 315.3761 1.0819 13.6675 13.1985 + 4614.7998 315.3626 1.0890 13.6675 13.1985 + 4621.2002 315.3544 1.0973 13.6675 13.1985 + 4627.7998 315.3715 1.1032 13.6675 13.1985 + 4634.2998 315.3634 1.1033 13.6675 13.1985 + 4640.3999 315.3521 1.1035 13.7394 13.2680 + 4646.7002 315.3527 1.1045 13.7394 13.2680 + 4653.3999 315.3582 1.1056 13.7394 13.2680 + 4659.5000 315.3589 1.1065 13.7394 13.2680 + 4664.8999 315.3735 1.1108 13.9689 13.0262 + 4670.7002 315.3693 1.1152 13.9689 13.0262 + 4677.2998 315.3615 1.1192 13.9689 13.0262 + 4684.2002 315.3586 1.1239 14.0420 13.0944 + 4690.5000 315.3730 1.1307 14.0420 13.0944 + 4697.0000 315.3891 1.1363 14.0420 13.0944 + 4703.7998 315.3728 1.1381 14.0420 13.0944 + 4709.6001 315.3689 1.1416 14.0420 13.0944 + 4715.3999 315.3515 1.1440 14.1151 13.1626 + 4721.5000 315.3509 1.1474 14.1151 13.1626 + 4727.2002 315.3708 1.1551 14.1151 13.1626 + 4733.7002 315.3736 1.1606 14.1151 13.1626 + 4740.1001 315.3646 1.1647 14.1883 13.2308 + 4746.5000 315.3794 1.1701 14.1883 13.2308 + 4753.5000 315.3770 1.1733 14.1883 13.2308 + 4760.5000 315.3748 1.1734 14.1883 13.2308 + 4767.7998 315.3639 1.1728 14.2614 13.2990 + 4776.1001 315.3782 1.1734 14.2614 13.2990 + 4785.0000 315.3738 1.1722 14.2614 13.2990 + 4792.6001 315.3784 1.1727 14.3345 13.3672 + 4800.2002 315.3950 1.1741 14.3345 13.3672 + 4808.3999 315.3825 1.1730 14.3345 13.3672 + 4816.3999 315.3684 1.1717 14.4077 13.4354 + 4823.7998 315.3596 1.1713 14.4077 13.4354 + 4830.5000 315.3648 1.1710 14.4077 13.4354 + 4838.7998 315.3781 1.1686 14.4808 13.5036 + 4848.7998 315.3638 1.1625 14.4808 13.5036 + 4857.1001 315.3773 1.1597 14.4808 13.5036 + 4864.0000 315.3502 1.1549 14.7886 13.3157 + 4869.8999 315.3353 1.1532 14.7886 13.3157 + 4876.7002 315.3543 1.1549 14.8629 13.3826 + 4884.7998 315.3528 1.1545 14.8629 13.3826 + 4892.7998 315.3496 1.1539 14.8629 13.3826 + 4900.2998 315.3654 1.1551 14.9372 13.4495 + 4906.7998 315.3813 1.1575 14.9372 13.4495 + 4914.6001 315.3886 1.1589 15.0115 13.5164 + 4923.6001 315.3615 1.1573 15.0115 13.5164 + 4932.2998 315.3432 1.1571 15.0858 13.5834 + 4941.6001 315.3454 1.1592 15.0858 13.5834 + 4949.7002 315.3427 1.1625 15.1602 13.6503 + 4957.0000 315.3452 1.1672 15.1602 13.6503 + 4966.1001 315.3545 1.1712 15.3961 13.3836 + 4976.2998 315.3655 1.1745 15.4715 13.4492 + 4985.7998 315.3698 1.1769 15.4715 13.4492 + 4994.2002 315.3469 1.1775 15.5470 13.5148 + 5000.0000 315.3584 1.1798 15.5470 13.5148 diff --git a/wrfv2_fire/test/em_les/namelist.input b/wrfv2_fire/test/em_les/namelist.input index 11b993d9..31407246 100644 --- a/wrfv2_fire/test/em_les/namelist.input +++ b/wrfv2_fire/test/em_les/namelist.input @@ -74,7 +74,7 @@ diff_opt = 2, 2, 2, km_opt = 2, 2, 2, damp_opt = 0, - zdamp = 15000., 5000., 5000., + zdamp = 5000., 5000., 5000., dampcoef = 0.1, 0.2, 0.2 khdif = 1., 1., .05, kvdif = 1., 1., .05, diff --git a/wrfv2_fire/test/em_les/namelist.input.SGP b/wrfv2_fire/test/em_les/namelist.input.SGP new file mode 100644 index 00000000..6f25f598 --- /dev/null +++ b/wrfv2_fire/test/em_les/namelist.input.SGP @@ -0,0 +1,139 @@ + &time_control + run_days = 0, + run_hours = 30, + run_minutes = 00, + run_seconds = 0, + start_year = 2008, 2008,2001, + start_month = 05, 05, 07, + start_day = 13, 13, 11, + start_hour = 12, 12, 00, + start_minute = 00, 00, 00, + start_second = 00, 00, 00, + end_year = 2008, 2008,2001, + end_month = 05, 05,07, + end_day = 13, 13,11, + end_hour = 13, 13, 08, + end_minute = 00, 00, 00, + end_second = 00, 00, 00, + history_interval = 1, 1, 10, + frames_per_outfile = 1, 1, 18, + restart = .False., + restart_interval = 60, + io_form_history = 2 + io_form_restart = 2 + io_form_input = 2 + io_form_boundary = 2 + debug_level = 0 + / + + &domains + time_step = 0, + time_step_fract_num = 1, + time_step_fract_den = 2, + max_dom = 1, + s_we = 1, 1, 1, + e_we = 33, 34, 82, + s_sn = 1, 1, 1, + e_sn = 33, 34, 82, + s_vert = 1, 1, 1, + e_vert = 251, 251, 51, + dx = 100, 33.3333, + dy = 100, 33.3333, + ztop = 5000, 5000,1500, + grid_id = 1, 2, 3, + parent_id = 0, 1, 2, + i_parent_start = 1, 13, 36, + j_parent_start = 1, 13, 36, + parent_grid_ratio = 1, 3, 3, + parent_time_step_ratio = 1, 3, 3, + feedback = 0, + smooth_option = 1 + / + nproc_x = 4, + nproc_y = 4, + + &physics + mp_physics = 0, 0, 8, + progn = 0, 0, 1, + ra_lw_physics = 0, 0, 0, + ra_sw_physics = 0, 0, 0, + radt = 1, 1, 5, + cam_abs_freq_s = 21600, + levsiz = 59, + paerlev = 29, + cam_abs_dim1 = 4, + cam_abs_dim2 = 51, + sf_sfclay_physics = 1, 1, 1, + sf_surface_physics = 0, 0, 0, + bl_pbl_physics = 0, 0, 0, + bldt = 0, 0, 0, + cu_physics = 0, 0, 0, + cudt = 5, 5, 5, + isfflx = 1, + ifsnow = 0, + icloud = 1, + num_soil_layers = 5, + mp_zero_out = 0, + / + + &fdda + / + + &dynamics + rk_ord = 3, + diff_opt = 0, + km_opt = 0, + damp_opt = 1, + w_damping = 0, + zdamp = 350., 350., 250., + dampcoef = 0.02, 0.02,0.02, + base_temp = 290., + base_pres = 100000., + base_lapse = 50., + khdif = 0., 0., 500, + kvdif = 0., 0., 500, + c_s = 0.18, 0.18, 0.18, + c_k = 0.1, 0.10, 0.10, + mix_isotropic = 0, 0, 1, + smdiv = 0.1, 0.1, 0.1, + emdiv = 0.01, 0.01, 0.01, + epssm = 0.1, 0.1, 0.1, + pert_coriolis = .false., .false., .true., + top_lid = .true., .true., .true., + tke_heat_flux = 0.02, 0.02, 0.02, + tke_drag_coefficient = 0.0013, 0.0013, 0.0013, + mix_full_fields = .true., .true., .true., + non_hydrostatic = .true., .true., .true., + time_step_sound = 6, 6, 10, + h_mom_adv_order = 5, 5, 5, + v_mom_adv_order = 3, 3, 3, + h_sca_adv_order = 5, 5, 5, + v_sca_adv_order = 3, 3, 3, + moist_adv_opt = 2, 2, 1, + scalar_adv_opt = 2, 2, 1, + chem_adv_opt = 2, 2, 1, + tke_adv_opt = 2, 2, 1, + use_theta_m = 1 + / + + &bdy_control + periodic_x = .true., .false.,.false., + symmetric_xs = .false.,.false.,.false., + symmetric_xe = .false.,.false.,.false., + open_xs = .false.,.false.,.false., + open_xe = .false.,.false.,.false., + periodic_y = .true., .false.,.false., + symmetric_ys = .false.,.false.,.false., + symmetric_ye = .false.,.false.,.false., + open_ys = .false.,.false.,.false., + open_ye = .false.,.false.,.false., + nested = .false., .true., .true., + / + + &grib2 + / + + &namelist_quilt + nio_tasks_per_group = 0, + nio_groups = 1, + / diff --git a/wrfv2_fire/test/em_les/namelist.input_shalconv b/wrfv2_fire/test/em_les/namelist.input_shalconv index aad3986e..c761f3cc 100644 --- a/wrfv2_fire/test/em_les/namelist.input_shalconv +++ b/wrfv2_fire/test/em_les/namelist.input_shalconv @@ -75,7 +75,7 @@ diff_opt = 2, 2, 2, km_opt = 2, 2, 2, damp_opt = 0, - zdamp = 15000., 5000., 5000., + zdamp = 5000., 5000., 5000., dampcoef = 0.1, 0.2, 0.2 khdif = 1., 1., .05, kvdif = 1., 1., .05, diff --git a/wrfv2_fire/test/em_real/examples.namelist b/wrfv2_fire/test/em_real/examples.namelist index fc0a6c72..8ef7877f 100755 --- a/wrfv2_fire/test/em_real/examples.namelist +++ b/wrfv2_fire/test/em_real/examples.namelist @@ -350,7 +350,10 @@ between selected output times (e.g. daily) in auxhist3 frames_per_auxhist3 = 1 / -** for pressure-level (and some surface) diagnostics, output is on stream 23 + +** for pressure-level (and some surface) diagnostics, output is on stream 23, +where the listed pressure levels are in Pa. For the height level interpolation, +the unit is stream 22. &time_control io_form_auxhist23 = 2, @@ -367,6 +370,23 @@ between selected output times (e.g. daily) in auxhist3 / +** for height-level diagnostics, output is on stream 22 (negative values +for z_levels means AGL, so -500 is 500 m AGL, and 10000 is 10 km). + + &time_control + io_form_auxhist22 = 2, + auxhist22_interval = 30, 30, 30, + frames_per_auxhist22 = 1, 1, 1, + auxhist22_outname = "ZLEVS_d_" + / + + &diags + z_lev_diags = 1 + num_z_levels = 2 + z_levels = -500, 10000 + / + + ** Using different flux formulation for tropical storm simulations (best for grid spacing less than 2 km) simple 1-D ocean mixed layer, or University of Miami 3DPWP ocean model @@ -455,22 +475,18 @@ inforamtion is ignored. The default is 300 hPa. The user may also select the level that when exceeded the trop and maxw fields are ignored (due to the horizontal pressure difference detecting a user-defined discontinuity, and the metgrid horizontal interpolation across the -discontinuity would be suspect). +discontinuity would be suspect). By default, this option is turned off. +The user may choose to individually activate the vertical interpolation of +either the level of max winds .OR. the tropopause level. -Default (all units Pa): +Default (all pressure units Pa): &domains maxw_horiz_pres_diff = 5000 trop_horiz_pres_diff = 5000 maxw_above_this_level = 30000 + use_maxw_level = 0 (0=do not use level, 1 = use level) + use_trop_level = 0 (0=do not use level, 1 = use level) -To test the sensitivity, a user may shut off the usage of the new data -by making the minimum acceptable vertical level for max winds ABOVE anything -physically possible inside of real, and also by setting the horizontal -pressure difference SMALLER than anything possible. - &domains - maxw_horiz_pres_diff = -1 - trop_horiz_pres_diff = -1 - maxw_above_this_level = 1 @@ -505,3 +521,23 @@ the turbine type: windturbines.txt skebs = 1, 1, 1, rand_perturb = 1, 1, 1, + +** Using kfcupscheme cu_physics (cumulus scheme option). This has been tested with +the CAM radiation scheme and is not recommended with other radiation schemes. +Regarding cu_rad_feedback, users want the parameterized clouds to affect radiation. +Turning it off is only useful as a sensitivity study to determine the importance of +that effect. Regarding shallowcu_forced_ra option, setting it to true will override +the cloud fraction calculations to a prescribed maximum cloud fraction (a value of 0.36) +which can be changed by the user for sensitivity testing purposes. + +&physics + cu_physics = 10, 10, 10, + ra_lw_physics = 3, 3, 3, + ra_sw_physics = 3, 3, 3, + cu_rad_feedback =.true.,.true.,.true., + shallowcu_forced_ra = .false.,.false.,.false., + numBins = 21, 21, 21, + thBinSize = 0.1, 0.1, 0.1, + rBinSize = 0.0001,0.0001,0.0001, + minDeepFreq = 0.333, 0.333, 0.333, + minShallowFreq = 0.01, 0.01, 0.01, diff --git a/wrfv2_fire/test/em_real/namelist.input b/wrfv2_fire/test/em_real/namelist.input index af0853b7..f1ff2ee8 100755 --- a/wrfv2_fire/test/em_real/namelist.input +++ b/wrfv2_fire/test/em_real/namelist.input @@ -65,8 +65,9 @@ isfflx = 1, ifsnow = 1, icloud = 1, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 4, + num_land_cat = 21, sf_urban_physics = 0, 0, 0, / diff --git a/wrfv2_fire/test/em_real/namelist.input.4km b/wrfv2_fire/test/em_real/namelist.input.4km index dd1af61d..22479cb1 100755 --- a/wrfv2_fire/test/em_real/namelist.input.4km +++ b/wrfv2_fire/test/em_real/namelist.input.4km @@ -65,8 +65,9 @@ isfflx = 1, ifsnow = 0, icloud = 1, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 4, + num_land_cat = 21, sf_urban_physics = 0, 0, 0, / diff --git a/wrfv2_fire/test/em_real/namelist.input.chem b/wrfv2_fire/test/em_real/namelist.input.chem index 920fa0a6..3ce181d1 100644 --- a/wrfv2_fire/test/em_real/namelist.input.chem +++ b/wrfv2_fire/test/em_real/namelist.input.chem @@ -70,8 +70,9 @@ isfflx = 1, ifsnow = 1, icloud = 1, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 4, + num_land_cat = 21, sf_urban_physics = 0, 0, 0, maxiens = 1, maxens = 3, diff --git a/wrfv2_fire/test/em_real/namelist.input.diags b/wrfv2_fire/test/em_real/namelist.input.diags index b7ab6f7a..b45611b2 100755 --- a/wrfv2_fire/test/em_real/namelist.input.diags +++ b/wrfv2_fire/test/em_real/namelist.input.diags @@ -76,8 +76,9 @@ isfflx = 1, ifsnow = 0, icloud = 1, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 4, + num_land_cat = 21, sf_urban_physics = 0, 0, 0, maxiens = 1, maxens = 3, diff --git a/wrfv2_fire/test/em_real/namelist.input.fire b/wrfv2_fire/test/em_real/namelist.input.fire index 751ae09c..aea47084 100644 --- a/wrfv2_fire/test/em_real/namelist.input.fire +++ b/wrfv2_fire/test/em_real/namelist.input.fire @@ -65,8 +65,9 @@ bldt = 0, cu_physics = 1, cudt = 5, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 5, + num_land_cat = 21, sf_urban_physics = 0, / diff --git a/wrfv2_fire/test/em_real/namelist.input.global b/wrfv2_fire/test/em_real/namelist.input.global index d575279e..aa938c20 100755 --- a/wrfv2_fire/test/em_real/namelist.input.global +++ b/wrfv2_fire/test/em_real/namelist.input.global @@ -66,8 +66,9 @@ isfflx = 1, ifsnow = 0, icloud = 1, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 5, + num_land_cat = 21, mp_zero_out = 0, / diff --git a/wrfv2_fire/test/em_real/namelist.input.jan00 b/wrfv2_fire/test/em_real/namelist.input.jan00 index 17aaae1a..8b97a646 100755 --- a/wrfv2_fire/test/em_real/namelist.input.jan00 +++ b/wrfv2_fire/test/em_real/namelist.input.jan00 @@ -65,8 +65,9 @@ isfflx = 1, ifsnow = 0, icloud = 1, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 4, + num_land_cat = 21, sf_urban_physics = 0, 0, 0, maxiens = 1, maxens = 3, diff --git a/wrfv2_fire/test/em_real/namelist.input.jun01 b/wrfv2_fire/test/em_real/namelist.input.jun01 index 10f519ab..b3227982 100755 --- a/wrfv2_fire/test/em_real/namelist.input.jun01 +++ b/wrfv2_fire/test/em_real/namelist.input.jun01 @@ -65,8 +65,9 @@ isfflx = 1, ifsnow = 0, icloud = 1, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 4, + num_land_cat = 21, sf_urban_physics = 0, 0, 0, / diff --git a/wrfv2_fire/test/em_real/namelist.input.ndown_1 b/wrfv2_fire/test/em_real/namelist.input.ndown_1 index cbc93556..173cc135 100755 --- a/wrfv2_fire/test/em_real/namelist.input.ndown_1 +++ b/wrfv2_fire/test/em_real/namelist.input.ndown_1 @@ -76,8 +76,9 @@ isfflx = 1, ifsnow = 0, icloud = 1, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 4, + num_land_cat = 21, sf_urban_physics = 0, 0, 0, maxiens = 1, maxens = 3, diff --git a/wrfv2_fire/test/em_real/namelist.input.ndown_2 b/wrfv2_fire/test/em_real/namelist.input.ndown_2 index a1e2c89c..7454243f 100755 --- a/wrfv2_fire/test/em_real/namelist.input.ndown_2 +++ b/wrfv2_fire/test/em_real/namelist.input.ndown_2 @@ -78,8 +78,9 @@ isfflx = 1, ifsnow = 0, icloud = 1, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 4, + num_land_cat = 21, sf_urban_physics = 0, 0, 0, maxiens = 1, maxens = 3, diff --git a/wrfv2_fire/test/em_real/namelist.input.ndown_3 b/wrfv2_fire/test/em_real/namelist.input.ndown_3 index 331e266c..cceaddca 100755 --- a/wrfv2_fire/test/em_real/namelist.input.ndown_3 +++ b/wrfv2_fire/test/em_real/namelist.input.ndown_3 @@ -78,8 +78,9 @@ isfflx = 1, ifsnow = 0, icloud = 1, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 4, + num_land_cat = 21, sf_urban_physics = 0, 0, 0, maxiens = 1, maxens = 3, diff --git a/wrfv2_fire/test/em_real/namelist.input.volc b/wrfv2_fire/test/em_real/namelist.input.volc index 31ba573e..0d236597 100755 --- a/wrfv2_fire/test/em_real/namelist.input.volc +++ b/wrfv2_fire/test/em_real/namelist.input.volc @@ -65,8 +65,9 @@ isfflx = 1, ifsnow = 0, icloud = 1, - surface_input_source = 1, + surface_input_source = 3, num_soil_layers = 4, + num_land_cat = 21, sf_urban_physics = 0, 0, 0, maxiens = 1, maxens = 3, diff --git a/wrfv2_fire/test/em_scm_xy/README.scm b/wrfv2_fire/test/em_scm_xy/README.scm index 76b7cc43..f1c6ffd1 100644 --- a/wrfv2_fire/test/em_scm_xy/README.scm +++ b/wrfv2_fire/test/em_scm_xy/README.scm @@ -4,7 +4,7 @@ README updated 9 Feb. 2009. ------------------------------------------------------------------------- -Author: Josh Hacker, NCAR (now at NPS) +Author: Josh Hacker, NCAR ------------------------------------------------------------------------- @@ -69,7 +69,7 @@ available, and is called make_scm_forcing.ncl. See the documentation at the beginning of this. The example that comes with the release is documented below. I have a much more sophisticated script to create forcing from a series of met_em files. Please contact me if you would -like to work with me on that (jphacker at nps.edu). +like to work with me on that (hacker at ucar.edu). ------------------------------------------------------------------------- diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/namelist.input b/wrfv2_fire/test/nmm_tropical_cyclone/namelist.input index 01aecea6..7159c97c 100644 --- a/wrfv2_fire/test/nmm_tropical_cyclone/namelist.input +++ b/wrfv2_fire/test/nmm_tropical_cyclone/namelist.input @@ -40,13 +40,13 @@ time_step_fract_den = 1, max_dom = 3, s_we = 1, 1, 1, - e_we = 160, 88, 190, + e_we = 216, 106, 198, s_sn = 1, 1, 1, - e_sn = 310, 170, 302, + e_sn = 432, 204, 354, s_vert = 1, 1, 1, - e_vert = 43, 43, 43, - dx = 0.18, .06, .02, - dy = 0.18, .06, .02, + e_vert = 61, 61, 61, + dx = 0.135, .045, .015, + dy = 0.135, .045, .015, grid_id = 1, 2, 3, tile_sz_x = 0, @@ -57,21 +57,14 @@ parent_id = 0, 1, 2, parent_grid_ratio = 1, 3, 3, parent_time_step_ratio = 1, 3, 3, - i_parent_start = 0, 66, 12, - j_parent_start = 0, 126, 35, + i_parent_start = 0, 90, 20, + j_parent_start = 0, 182, 45, feedback = 1, num_moves = -99 - num_metgrid_levels = 22, - p_top_requested = 5000, - ptsgm = 42000 - eta_levels = 1.0, .9919699, .9827400, .9721600, .9600599, .9462600, - .9306099, .9129300, .8930600, .8708600, .8462000, .8190300, - .7893100, .7570800, .7224600, .6856500, .6469100, .6066099, - .5651600, .5230500, .4807700, .4388600, .3978000, .3580500, - .3200099, .2840100, .2502900, .2190100, .1902600, .1640600, - .1403600, .1190600, .1000500, .0831600, .0682400, .0551200, - .0436200, .0335700, .0248200, .0172200, .0106300, .0049200, - .0000000, + num_metgrid_levels = 27, + p_top_requested = 200.0, + ptsgm = 15000, + eta_levels = 1.0, 0.995253, 0.990479, 0.985679, 0.980781, 0.975782, 0.970684, 0.965486, 0.960187, 0.954689, 0.948991, 0.943093, 0.936895, 0.930397, 0.923599, 0.916402, 0.908404, 0.899507, 0.888811, 0.876814, 0.862914, 0.847114, 0.829314, 0.809114, 0.786714, 0.762114, 0.735314, 0.706714, 0.676614, 0.645814, 0.614214, 0.582114, 0.549714, 0.517114, 0.484394, 0.451894, 0.419694, 0.388094, 0.356994, 0.326694, 0.297694, 0.270694, 0.245894, 0.223694, 0.203594, 0.185494, 0.169294, 0.154394, 0.140494, 0.127094, 0.114294, 0.101894, 0.089794, 0.078094, 0.066594, 0.055294, 0.044144, 0.033054, 0.022004, 0.010994, 0.0, use_prep_hybrid = F, num_metgrid_soil_levels = 4, / @@ -96,7 +89,7 @@ nphs = 2,6,6 , ncnvc = 2,6,6 , - movemin = 3,6,18 , + movemin = 3,6,12 , ! IMPORTANT: dt*nphs*movemin for domain 2 and 3 must be 540 and 180, respectively ! AND the history output times (10800, 10800, 3600) must be @@ -106,7 +99,7 @@ sas_pgcon = 0.55,0.2,0.2 , sas_mass_flux = 0.5,0.5,0.5, co2tf = 1, - vortex_tracker = 2, 2, 6, + vortex_tracker = 2, 2, 7, ! Disable nest movement at certain intervals to prevent junk in the output files: nomove_freq = 0.0, 6.0, 6.0, ! hours diff --git a/wrfv2_fire/tools/check_for_bad_includes.pl b/wrfv2_fire/tools/check_for_bad_includes.pl new file mode 100755 index 00000000..455df8ea --- /dev/null +++ b/wrfv2_fire/tools/check_for_bad_includes.pl @@ -0,0 +1,81 @@ +#!/usr/bin/perl -w +# +# Script to replace all incorrect "include" statements in WRF trunk. For user-defined files, +# include statements must use quotes, not brackets, according to the C standard: +# +# INCORRECT +# #include +# +# CORRECT +# #include "model_data_order.inc" + +# OPTIONS: +# use "--search_path" to specify the search pattern for files you want to edit. +# - Separate different search patterns with spaces +# - Be sure to escape wildcard characters with a backslash! +# - Default is --search_path="../\*/\*.F ../\*/\*/\*.F ../\*/\*/\*/\*.F ../\*/\*/\*/\*/\*.F ../\*/\*.inc ../\*/\*/\*.f90 ../\*/\*/\*/\*.f90" +# use "--dryrun=yes" to do a dry run, where all the output of what would be changed is printed out, but no changes are made. +# +# Created by Michael Kavulich, November 2015 +# No rights reserved +# + +use strict; +use warnings; +use File::Basename; +use Getopt::Long; + +my $dryrun = "no"; +my $search_path = "../\*/\*.F ../\*/\*/\*.F ../\*/\*/\*/\*.F ../\*/\*/\*/\*/\*.F ../\*/\*.inc ../\*/\*/\*.f90 ../\*/\*/\*/\*.f90"; +GetOptions ('search_path=s' => \$search_path, + "dryrun:s" => \$dryrun ) or die "\nInvalid option(s) specified, view script comments for help\n"; + +print "\nSearching for brackets in file(s): $search_path\n\n"; + +my @source_files=glob("$search_path"); + +my $found=0; +my $notfound=0; +my $changed=0; +foreach my $filename (@source_files) { + open (IN, $filename) or die "Cannot open file $filename for read: $!"; + my @lines=; + close IN; + + if (grep(/#(\s*)(include|INCLUDE)(\s*)", $filename) or die "Cannot open file $filename for write: $!"; + foreach my $line (@lines) { + if ($line =~ /#(\s*)(include|INCLUDE)(\s*)]/,$line; + if ($inc_files[1] =~ //\"$inc_files[1]\"/; + print "Changed line to: $linetemp\n"; + } else { + $line =~ s/<$inc_files[1]>/\"$inc_files[1]\"/; + print "Changed line to: $line\n"; + } + $changed++; + } + } + print OUT $line; + } + close OUT; +} + +print "\nBrackets found in $found files.\n"; +print "\nBrackets NOT found in $notfound files.\n"; +print "\n$changed lines changed\n"; diff --git a/wrfv2_fire/tools/commit_form.txt b/wrfv2_fire/tools/commit_form.txt new file mode 100644 index 00000000..f55173ee --- /dev/null +++ b/wrfv2_fire/tools/commit_form.txt @@ -0,0 +1,42 @@ +TYPE: bug fix, enhancement, new feature, feature removed, no impact, text only + +KEYWORDS: 5 to 10 words related to commit + +SOURCE: Either "developer's name (affiliation)" .XOR. "internal" for a WRF Dev committee member + +PURPOSE: single line, usually one sentence + +DESCRIPTION OF CHANGES: +Paragraph describing problem, solution, and required changes. + +LIST OF MODIFIED FILES (annotated if not obvious, not required to be on a single line): + +TESTS CONDUCTED (explicitly state mandatory, voluntary, and assigned tests, not required to be on a single line): + + + + +Description of commit types: +- "bug fix" + Fixing a demonstrably incorrect portion of code + +- "enhancement" + Changing an existing portion of the code; though the old code was not unambiguously + wrong, this change presumably improves the code + +- "new feature" + Adding a new feature to the code + +- "feature removed" + Removing an existing feature of the code + +- "no impact" + For display changes such as changing the "version_decl", changing variable names, + improving error messages, changing quoted Registry elements, or otherwise changing what + appears in the log/out/error files but not impacting history/restart output results, timing + performance, or memory footprint + +- "text only" + For README and comments, changing quoted Registry elements, white space alignment, or other + changes which have no impact on program output or log files. Additionally, any change which + does not impact any of the compiled code. diff --git a/wrfv2_fire/tools/data.h b/wrfv2_fire/tools/data.h index 39d77de7..e9a80bc4 100644 --- a/wrfv2_fire/tools/data.h +++ b/wrfv2_fire/tools/data.h @@ -16,7 +16,7 @@ typedef struct node_struct { int stag_x ; int stag_y ; int stag_z ; - int nmm_v_grid, mp_var, full_feedback ; + int nmm_v_grid, mp_var, full_feedback, no_feedback ; int subject_to_communication ; int boundary_array ; int boundary_array_4d ; diff --git a/wrfv2_fire/tools/gen_allocs.c b/wrfv2_fire/tools/gen_allocs.c index 78929b06..13164a57 100644 --- a/wrfv2_fire/tools/gen_allocs.c +++ b/wrfv2_fire/tools/gen_allocs.c @@ -220,7 +220,7 @@ if ( tag == 1 ) /* check for errors in memory allocation */ - if ( ! p->boundary_array ) { fprintf(fp,"IF(in_use_for_config(id,'%s')",fname) ; } + if ( ! p->boundary_array ) { fprintf(fp,"IF(okay_to_alloc.AND.in_use_for_config(id,'%s')",fname) ; } else { fprintf(fp,"IF(.TRUE.") ; } if ( ! ( p->node_kind & FOURD ) && sw == 1 && diff --git a/wrfv2_fire/tools/gen_scalar_indices.c b/wrfv2_fire/tools/gen_scalar_indices.c index 5b1fed20..6c66c578 100644 --- a/wrfv2_fire/tools/gen_scalar_indices.c +++ b/wrfv2_fire/tools/gen_scalar_indices.c @@ -16,7 +16,7 @@ int gen_scalar_indices ( char * dirname ) { - FILE * fp, *fp5[7] ; + FILE * fp, *fp5[26] ; char fname[NAMELEN], fname5[NAMELEN] ; char * fn = "scalar_indices.inc" ; char * fn2 = "scalar_tables.inc" ; @@ -24,22 +24,17 @@ gen_scalar_indices ( char * dirname ) char * fn4 = "scalar_indices_init.inc" ; int i ; - char fn5[7][NAMELEN] ; - - strcpy( fn5[0], "in_use_for_config_ac.inc" ) ; /* hashing to make the run time function being generated faster */ - strcpy( fn5[1], "in_use_for_config_df.inc" ) ; - strcpy( fn5[2], "in_use_for_config_gk.inc" ) ; - strcpy( fn5[3], "in_use_for_config_ln.inc" ) ; - strcpy( fn5[4], "in_use_for_config_os.inc" ) ; - strcpy( fn5[5], "in_use_for_config_tw.inc" ) ; - strcpy( fn5[6], "in_use_for_config_xz.inc" ) ; + char fn5[26][NAMELEN] ; strcpy( fname, fn ) ; if ( strlen(dirname) > 0 ) { sprintf(fname,"%s/%s",dirname,fn) ; } if ((fp = fopen( fname , "w" )) == NULL ) return(1) ; print_warning(fp,fname) ; - for ( i = 0 ; i < 7 ; i++ ) { + /* hashing to make the run time function being generated faster */ + for ( i = 0 ; i < 26 ; i++ ) + { + sprintf(fn5[i],"in_use_for_config_%c.inc",'a'+i) ; strcpy( fname5, fn5[i] ) ; if ( strlen(dirname) > 0 ) { sprintf(fname5,"%s/%s",dirname,fn5[i]) ; } if ((fp5[i] = fopen( fname5 , "w" )) == NULL ) return(1) ; @@ -47,7 +42,8 @@ gen_scalar_indices ( char * dirname ) } gen_scalar_indices1 ( fp, fp5 ) ; close_the_file( fp ) ; - for ( i = 0 ; i < 7 ; i++ ) { + for ( i = 0 ; i < 26 ; i++ ) + { close_the_file( fp5[i] ) ; } @@ -196,14 +192,7 @@ gen_scalar_indices1 ( FILE * fp, FILE ** fp2 ) } make_lower_case(fname) ; - fo = 0 ; - if ( 'x' <= fname[0] ) { fo = 6 ; } - else if ( 't' <= fname[0] ) { fo = 5 ; } - else if ( 'o' <= fname[0] ) { fo = 4 ; } - else if ( 'l' <= fname[0] ) { fo = 3 ; } - else if ( 'g' <= fname[0] ) { fo = 2 ; } - else if ( 'd' <= fname[0] ) { fo = 1 ; } - else { fo = 0 ; } + fo = fname[0]-'a' ; fprintf(fp2[fo],"IF(TRIM(vname).EQ.'%s')THEN\n",fname) ; fprintf(fp2[fo]," IF(uses.EQ.0)THEN\n"); diff --git a/wrfv2_fire/tools/reg_parse.c b/wrfv2_fire/tools/reg_parse.c index 78f5496f..ee84e60b 100644 --- a/wrfv2_fire/tools/reg_parse.c +++ b/wrfv2_fire/tools/reg_parse.c @@ -291,7 +291,6 @@ pre_parse( char * dir, FILE * infile, FILE * outfile ) continue ; } } -normal: /* otherwise output the line as is */ fprintf(outfile,"%s\n",parseline_save) ; parseline[0] = '\0' ; /* reset parseline */ @@ -306,7 +305,7 @@ reg_parse( FILE * infile ) char inln[7000], parseline[7000] ; char *p, *q ; char *tokens[MAXTOKENS], *toktmp[MAXTOKENS] ; - int i, ii ; + int i, ii, idim ; int defining_state_field, defining_rconfig_field, defining_i1_field ; parseline[0] = '\0' ; @@ -453,6 +452,7 @@ reg_parse( FILE * infile ) field_struct->stag_x = 0 ; field_struct->stag_y = 0 ; field_struct->stag_z = 0 ; field_struct->mp_var = 0 ; field_struct->nmm_v_grid=0 ; field_struct->full_feedback = 0; + field_struct->no_feedback = 0; for ( i = 0 ; i < strlen(tokens[FIELD_STAG]) ; i++ ) { if ( tolower(tokens[FIELD_STAG][i]) == 'x' || sw_all_x_staggered ) field_struct->stag_x = 1 ; @@ -464,6 +464,8 @@ reg_parse( FILE * infile ) field_struct->mp_var = 1; if ( tolower(tokens[FIELD_STAG][i]) == 'f' ) field_struct->full_feedback = 1; + if ( tolower(tokens[FIELD_STAG][i]) == 'n' ) + field_struct->no_feedback = 1; } field_struct->restart = 0 ; field_struct->boundary = 0 ; @@ -639,12 +641,12 @@ reg_parse( FILE * infile ) #endif } #if NMM_CORE==1 - if(dims_ikj_inner(field_struct) && !strcasestr(fcn_name,"ikj")) { + if(dims_ikj_inner(field_struct) && !strcasestr(fcn_name,"ikj") && !strcasestr(fcn_name,"nointerp")) { fprintf(stderr,"ERROR: %s %c %s: you must use IKJ interpolators for IKJ arrays.\n", tokens[FIELD_SYM],x,fcn_name); exit(1); } - if(dims_ij_inner(field_struct) && strcasestr(fcn_name,"ikj")) { + if(dims_ij_inner(field_struct) && strcasestr(fcn_name,"ikj") && !strcasestr(fcn_name,"nointerp")) { fprintf(stderr,"ERROR: %s %c %s: you cannot use IKJ interpolators for IJ arrays.\n", tokens[FIELD_SYM],x,fcn_name); exit(1); diff --git a/wrfv2_fire/tools/standard.c b/wrfv2_fire/tools/standard.c index 060e4aef..2b34beb8 100644 --- a/wrfv2_fire/tools/standard.c +++ b/wrfv2_fire/tools/standard.c @@ -1,5 +1,6 @@ #include #include +#include #define LINELEN 8192 #define STRINGLEN 1024 From 3685f9d93c424c3988c201bd94be33ee5323df29 Mon Sep 17 00:00:00 2001 From: Jan Mandel Date: Sun, 3 Dec 2017 00:11:44 -0700 Subject: [PATCH 04/15] WRFV3.9.1.1 --- wrfv2_fire/Makefile | 72 +- wrfv2_fire/README | 47 +- wrfv2_fire/README.DA | 95 +- wrfv2_fire/README.hybrid_vert_coord | 223 + wrfv2_fire/Registry/Registry.EM | 13 +- wrfv2_fire/Registry/Registry.EM_CHEM | 10 + wrfv2_fire/Registry/Registry.EM_COMMON | 343 +- wrfv2_fire/Registry/Registry.EM_COMMON.var | 1 + wrfv2_fire/Registry/Registry.NMM | 94 +- wrfv2_fire/Registry/Registry.wrfvar | 1 + wrfv2_fire/Registry/registry.afwa | 17 +- wrfv2_fire/Registry/registry.chem | 520 +- wrfv2_fire/Registry/registry.dimspec | 2 + wrfv2_fire/Registry/registry.fire | 2 +- wrfv2_fire/Registry/registry.hyb_coord | 56 + wrfv2_fire/Registry/registry.new3d_gca | 63 + wrfv2_fire/Registry/registry.new3d_wif | 72 + wrfv2_fire/Registry/registry.rasm_diag | 92 + wrfv2_fire/Registry/registry.sbm | 3 - wrfv2_fire/Registry/registry.stoch | 83 +- wrfv2_fire/Registry/registry.tornado | 4 +- wrfv2_fire/Registry/registry.tracker | 12 +- wrfv2_fire/Registry/registry.var | 135 +- wrfv2_fire/arch/Config_new.pl | 39 +- wrfv2_fire/arch/configure_new.defaults | 350 +- wrfv2_fire/arch/noopt_exceptions | 24 - wrfv2_fire/arch/noopt_exceptions_f | 17 - wrfv2_fire/arch/postamble_new | 19 +- wrfv2_fire/arch/preamble_new | 7 +- wrfv2_fire/chem/KPP/clean_kpp | 2 +- wrfv2_fire/chem/KPP/compile_wkc | 27 + ...ate_rconst_saprc99_mosaic_8bin_vbs2_aq.inc | 3 + ...ate_rconst_saprc99_mosaic_8bin_vbs2_aq.inc | 2 + ...ate_rconst_saprc99_mosaic_8bin_vbs2_aq.inc | 2 + ...pp_mechd_a_saprc99_mosaic_8bin_vbs2_aq.inc | 1 + ...pp_mechd_b_saprc99_mosaic_8bin_vbs2_aq.inc | 1 + ...pp_mechd_e_saprc99_mosaic_8bin_vbs2_aq.inc | 1 + ...p_mechd_ia_saprc99_mosaic_8bin_vbs2_aq.inc | 1 + ...p_mechd_ib_saprc99_mosaic_8bin_vbs2_aq.inc | 1 + ..._mechd_ibu_saprc99_mosaic_8bin_vbs2_aq.inc | 1 + ...pp_mechd_l_saprc99_mosaic_8bin_vbs2_aq.inc | 1 + ...pp_mechd_u_saprc99_mosaic_8bin_vbs2_aq.inc | 1 + wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags | 1 - wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/Makefile | 4 +- .../mozart_mosaic_4bin.tuv.jmap | 25 + .../mozart_mosaic_4bin_aq.tuv.jmap | 25 + .../KPP/mechanisms/mozcart/mozcart.tuv.jmap | 25 + .../saprc99_mosaic_8bin_vbs2_aq/atoms_red | 107 + .../saprc99_mosaic_8bin_vbs2_aq.def | 30 + .../saprc99_mosaic_8bin_vbs2_aq.eqn | 443 + .../saprc99_mosaic_8bin_vbs2_aq.kpp | 10 + .../saprc99_mosaic_8bin_vbs2_aq.spc | 102 + .../saprc99_mosaic_8bin_vbs2_aq_wrfkpp.equiv | 9 + wrfv2_fire/chem/KPP/util/wkc/Makefile.tuv | 15 + wrfv2_fire/chem/KPP/util/wkc/tuv_kpp.c | 217 + wrfv2_fire/chem/Makefile | 9 + wrfv2_fire/chem/aerosol_driver.F | 12 +- wrfv2_fire/chem/chem_driver.F | 13 +- wrfv2_fire/chem/chemics_init.F | 77 +- wrfv2_fire/chem/cloudchem_driver.F | 2 +- wrfv2_fire/chem/depend.chem | 22 +- wrfv2_fire/chem/dry_dep_driver.F | 2 +- wrfv2_fire/chem/emissions_driver.F | 27 +- wrfv2_fire/chem/la_srb.F | 533 + wrfv2_fire/chem/module_add_emis_cptec.F | 2 +- wrfv2_fire/chem/module_add_emiss_burn.F | 2 +- wrfv2_fire/chem/module_aerosols_soa_vbs.F | 16 +- wrfv2_fire/chem/module_aerosols_sorgam.F | 10 +- wrfv2_fire/chem/module_bioemi_megan2.F | 90 +- wrfv2_fire/chem/module_cam_mam_newnuc.F | 4 +- wrfv2_fire/chem/module_chem_cup.F | 8 + wrfv2_fire/chem/module_gocart_dmsemis.F | 4 +- wrfv2_fire/chem/module_gocart_dust.F | 4 +- wrfv2_fire/chem/module_gocart_seasalt.F | 4 +- wrfv2_fire/chem/module_mosaic_addemiss.F | 298 +- wrfv2_fire/chem/module_mosaic_driver.F | 679 +- wrfv2_fire/chem/module_mosaic_therm.F | 10 +- wrfv2_fire/chem/module_mozcart_wetscav.F | 16 +- wrfv2_fire/chem/module_phot_mad.F | 6 +- wrfv2_fire/chem/module_phot_tuv.F | 2175 ++ wrfv2_fire/chem/module_plumerise1.F | 51 + wrfv2_fire/chem/module_sea_salt_emis.F | 4 +- wrfv2_fire/chem/module_subs_tuv.F | 946 + wrfv2_fire/chem/module_wetscav_driver.F | 6 + wrfv2_fire/chem/numer.F | 506 + wrfv2_fire/chem/optical_driver.F | 4 +- wrfv2_fire/chem/params.mod.F | 52 + wrfv2_fire/chem/params_mod.F | 25 + wrfv2_fire/chem/photolysis_driver.F | 35 +- wrfv2_fire/chem/rdxs.F | 1105 + wrfv2_fire/chem/rtrans.F | 534 + wrfv2_fire/chem/rxn.F | 5660 +++ wrfv2_fire/clean | 6 +- wrfv2_fire/compile | 53 +- wrfv2_fire/configure | 68 +- wrfv2_fire/dyn_em/adapt_timestep_em.F | 16 +- wrfv2_fire/dyn_em/couple_or_uncouple_em.F | 109 +- wrfv2_fire/dyn_em/module_advect_em.F | 3384 +- wrfv2_fire/dyn_em/module_after_all_rk_steps.F | 3 +- wrfv2_fire/dyn_em/module_bc_em.F | 338 +- .../dyn_em/module_big_step_utilities_em.F | 854 +- wrfv2_fire/dyn_em/module_diffusion_em.F | 1100 +- wrfv2_fire/dyn_em/module_em.F | 402 +- .../dyn_em/module_first_rk_step_part1.F | 74 +- .../dyn_em/module_first_rk_step_part2.F | 106 +- wrfv2_fire/dyn_em/module_initialize_b_wave.F | 17 + wrfv2_fire/dyn_em/module_initialize_convrad.F | 17 + wrfv2_fire/dyn_em/module_initialize_fire.F | 17 + .../dyn_em/module_initialize_grav2d_x.F | 17 + .../dyn_em/module_initialize_heldsuarez.F | 17 + .../dyn_em/module_initialize_hill2d_x.F | 247 +- wrfv2_fire/dyn_em/module_initialize_les.F | 202 +- .../dyn_em/module_initialize_quarter_ss.F | 17 + wrfv2_fire/dyn_em/module_initialize_real.F | 1123 +- wrfv2_fire/dyn_em/module_initialize_scm_xy.F | 17 + .../dyn_em/module_initialize_seabreeze2d_x.F | 17 + .../dyn_em/module_initialize_squall2d_x.F | 17 + .../dyn_em/module_initialize_squall2d_y.F | 17 + .../module_initialize_tropical_cyclone.F | 17 + wrfv2_fire/dyn_em/module_polarfft.F | 20 +- wrfv2_fire/dyn_em/module_sfs_driver.F | 2 +- wrfv2_fire/dyn_em/module_sfs_nba.F | 2 +- wrfv2_fire/dyn_em/module_small_step_em.F | 234 +- wrfv2_fire/dyn_em/module_stoch.F | 197 +- wrfv2_fire/dyn_em/nest_init_utils.F | 52 +- wrfv2_fire/dyn_em/solve_em.F | 286 +- wrfv2_fire/dyn_em/start_em.F | 462 +- wrfv2_fire/dyn_nmm/module_BNDRY_COND.F | 62 +- wrfv2_fire/dyn_nmm/module_IGWAVE_ADJUST.F | 16 +- wrfv2_fire/dyn_nmm/module_NEST_UTIL.F | 56 + wrfv2_fire/dyn_nmm/module_NONHY_DYNAM.F | 27 +- wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F | 201 +- wrfv2_fire/dyn_nmm/module_initialize_real.F | 10 + .../module_initialize_tropical_cyclone.F | 107 +- wrfv2_fire/dyn_nmm/module_membrane_mslp.F | 6 +- wrfv2_fire/dyn_nmm/module_swath.F | 146 +- wrfv2_fire/dyn_nmm/module_tornado_genesis.F | 7 +- wrfv2_fire/dyn_nmm/solve_nmm.F | 209 +- wrfv2_fire/dyn_nmm/start_domain_nmm.F | 105 +- wrfv2_fire/external/.gitignore | 17 + wrfv2_fire/external/RSL_LITE/module_dm.F | 193 +- wrfv2_fire/external/atm_ocn/atm_comm.F | 324 +- wrfv2_fire/external/atm_ocn/cmpcomm.F | 16 +- .../external/atm_ocn/module_PATCH_QUILT.F | 400 +- .../external/esmf_time_f90/ESMF_TimeMgr.inc | 1 + wrfv2_fire/external/esmf_time_f90/Meat.F90 | 82 + wrfv2_fire/external/io_esmf/makefile | 3 - wrfv2_fire/external/io_netcdf/wrf_io.F90 | 12 +- wrfv2_fire/external/io_pio/Makefile | 2 +- wrfv2_fire/external/io_pio/field_routines.F90 | 2 +- wrfv2_fire/external/io_pio/pio_routines.F90 | 2 +- .../external/io_pio/read_bdy_routines.F90 | 2 +- wrfv2_fire/external/io_pio/wrf_data_pio.F90 | 2 +- wrfv2_fire/external/io_pio/wrf_io.F90 | 2 +- wrfv2_fire/frame/module_configure.F | 8 +- wrfv2_fire/frame/module_cpl.F | 9 +- wrfv2_fire/frame/module_domain.F | 22 +- wrfv2_fire/frame/module_io_quilt_old.F | 3 +- wrfv2_fire/frame/module_tiles.F | 5 +- wrfv2_fire/hydro/CPL/WRF_cpl/Makefile | 34 + wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl | 9 + .../hydro/CPL/WRF_cpl/module_wrf_HYDRO.F | 415 + .../CPL/WRF_cpl/module_wrf_HYDRO_downscale.F | 439 + wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F | 57 + wrfv2_fire/hydro/Data_Rec/Makefile | 28 + .../hydro/Data_Rec/gw_field_include.inc | 34 + .../hydro/Data_Rec/module_GW_baseflow_data.F | 9 + wrfv2_fire/hydro/Data_Rec/module_RT_data.F | 30 + .../hydro/Data_Rec/module_gw_gw2d_data.F | 30 + wrfv2_fire/hydro/Data_Rec/module_namelist.F | 410 + wrfv2_fire/hydro/Data_Rec/namelist.inc | 65 + wrfv2_fire/hydro/Data_Rec/rt_include.inc | 218 + wrfv2_fire/hydro/HYDRO_drv/Makefile | 29 + wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F | 1665 + wrfv2_fire/hydro/MPP/CPL_WRF.F | 225 + wrfv2_fire/hydro/MPP/Makefile | 39 + wrfv2_fire/hydro/MPP/module_mpp_GWBUCKET.F | 236 + wrfv2_fire/hydro/MPP/module_mpp_ReachLS.F | 1089 + wrfv2_fire/hydro/MPP/mpp_land.F | 2346 ++ wrfv2_fire/hydro/README.hydro | 123 + wrfv2_fire/hydro/Rapid_routing/.gitignore | 24 + wrfv2_fire/hydro/Rapid_routing/LICENSE | 24 + wrfv2_fire/hydro/Rapid_routing/README | 9 + .../hydro/Rapid_routing/hrldas_RAPID_drv.F90 | 18 + .../Rapid_routing/hrldas_RAPID_wrapper.F90 | 210 + wrfv2_fire/hydro/Rapid_routing/makefile | 245 + wrfv2_fire/hydro/Rapid_routing/makefile.cpl | 197 + wrfv2_fire/hydro/Rapid_routing/makefile.orig | 229 + .../hydro/Rapid_routing/rapid_arrays.F90 | 709 + .../Rapid_routing/rapid_close_Qfor_file.F90 | 40 + .../Rapid_routing/rapid_close_Qhum_file.F90 | 40 + .../Rapid_routing/rapid_close_Qobs_file.F90 | 40 + .../Rapid_routing/rapid_close_Qout_file.F90 | 42 + .../Rapid_routing/rapid_close_Vlat_file.F90 | 42 + .../Rapid_routing/rapid_create_Qout_file.F90 | 65 + .../hydro/Rapid_routing/rapid_create_obj.F90 | 219 + .../hydro/Rapid_routing/rapid_destro_obj.F90 | 147 + .../hydro/Rapid_routing/rapid_final.F90 | 192 + .../hydro/Rapid_routing/rapid_get_Qdam.F90 | 129 + .../hydro/Rapid_routing/rapid_hsh_mat.F90 | 236 + wrfv2_fire/hydro/Rapid_routing/rapid_init.F90 | 397 + wrfv2_fire/hydro/Rapid_routing/rapid_main.F90 | 299 + wrfv2_fire/hydro/Rapid_routing/rapid_namelist | 109 + .../hydro/Rapid_routing/rapid_net_mat.F90 | 331 + .../hydro/Rapid_routing/rapid_net_mat_brk.F90 | 286 + .../hydro/Rapid_routing/rapid_obs_mat.F90 | 106 + .../Rapid_routing/rapid_open_Qfor_file.F90 | 43 + .../Rapid_routing/rapid_open_Qhum_file.F90 | 43 + .../Rapid_routing/rapid_open_Qobs_file.F90 | 43 + .../Rapid_routing/rapid_open_Qout_file.F90 | 50 + .../Rapid_routing/rapid_open_Vlat_file.F90 | 49 + .../hydro/Rapid_routing/rapid_phiroutine.F90 | 277 + .../Rapid_routing/rapid_read_Qfor_file.F90 | 74 + .../Rapid_routing/rapid_read_Qhum_file.F90 | 75 + .../Rapid_routing/rapid_read_Qobs_file.F90 | 75 + .../Rapid_routing/rapid_read_Vlat_file.F90 | 79 + .../Rapid_routing/rapid_read_namelist.F90 | 38 + .../hydro/Rapid_routing/rapid_routing.F90 | 268 + .../Rapid_routing/rapid_routing_param.F90 | 100 + .../hydro/Rapid_routing/rapid_script.sh | 11 + .../hydro/Rapid_routing/rapid_set_Qext0.F90 | 103 + wrfv2_fire/hydro/Rapid_routing/rapid_var.F90 | 538 + .../Rapid_routing/rapid_write_Qout_file.F90 | 82 + wrfv2_fire/hydro/Routing/Makefile | 99 + wrfv2_fire/hydro/Routing/Noah_distr_routing.F | 3007 ++ wrfv2_fire/hydro/Routing/module_GW_baseflow.F | 528 + wrfv2_fire/hydro/Routing/module_HYDRO_io.F | 9923 +++++ wrfv2_fire/hydro/Routing/module_HYDRO_utils.F | 417 + wrfv2_fire/hydro/Routing/module_RT.F | 1290 + wrfv2_fire/hydro/Routing/module_UDMAP.F | 569 + .../hydro/Routing/module_channel_routing.F | 2277 ++ .../hydro/Routing/module_date_utilities_rt.F | 1032 + wrfv2_fire/hydro/Routing/module_gw_gw2d.F | 2159 ++ wrfv2_fire/hydro/Routing/module_lsm_forcing.F | 3291 ++ .../Routing/module_noah_chan_param_init_rt.F | 114 + wrfv2_fire/hydro/Routing/rtFunction.F | 222 + wrfv2_fire/hydro/Run/HYDRO.TBL | 51 + wrfv2_fire/hydro/Run/hydro.namelist | 102 + wrfv2_fire/hydro/arc/Makefile.Noah | 30 + wrfv2_fire/hydro/arc/Makefile.NoahMP | 30 + wrfv2_fire/hydro/arc/Makefile.mpp | 17 + wrfv2_fire/hydro/arc/Makefile.seq | 36 + wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r | 43 + wrfv2_fire/hydro/arc/macros.mpp.gfort | 46 + wrfv2_fire/hydro/arc/macros.mpp.ifort | 96 + wrfv2_fire/hydro/arc/macros.mpp.ifort.luna | 96 + wrfv2_fire/hydro/arc/macros.mpp.linux | 67 + wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r | 43 + wrfv2_fire/hydro/arc/macros.seq.gfort | 47 + wrfv2_fire/hydro/arc/macros.seq.ifort | 60 + wrfv2_fire/hydro/arc/macros.seq.linux | 61 + wrfv2_fire/hydro/configure | 113 + wrfv2_fire/hydro/template/HYDRO/HYDRO.TBL | 50 + .../hydro/template/HYDRO/hydro.namelist | 142 + wrfv2_fire/hydro/wrf_hydro_config | 28 + wrfv2_fire/inc/.gitignore | 14 + wrfv2_fire/inc/version_decl | 2 +- wrfv2_fire/main/Makefile | 2 +- wrfv2_fire/main/depend.common | 55 +- wrfv2_fire/main/module_wrf_top.F | 13 + wrfv2_fire/main/ndown_em.F | 54 +- wrfv2_fire/main/real_em.F | 15 + wrfv2_fire/phys/Makefile | 12 +- wrfv2_fire/phys/module_bl_gfs.F | 59 + wrfv2_fire/phys/module_bl_gfs2011.F | 1509 - wrfv2_fire/phys/module_bl_gfsedmf.F | 2216 ++ wrfv2_fire/phys/module_bl_gwdo.F | 25 +- wrfv2_fire/phys/module_bl_mfshconvpbl.F | 2 +- wrfv2_fire/phys/module_bl_mynn.F | 1578 +- wrfv2_fire/phys/module_bl_shinhong.F | 27 +- wrfv2_fire/phys/module_bl_temf.F | 6 +- wrfv2_fire/phys/module_bl_ysu.F | 217 +- wrfv2_fire/phys/module_cu_camzm_driver.F | 2 +- wrfv2_fire/phys/module_cu_g3.F | 6 +- wrfv2_fire/phys/module_cu_gf.F | 4900 --- wrfv2_fire/phys/module_cu_gf_deep.F | 4351 +++ wrfv2_fire/phys/module_cu_gf_sh.F | 846 + wrfv2_fire/phys/module_cu_gf_wrfdrv.F | 733 + wrfv2_fire/phys/module_cu_mesosas.F | 7780 ---- wrfv2_fire/phys/module_cu_nsas.F | 43 +- wrfv2_fire/phys/module_cu_ntiedtke.F | 442 +- wrfv2_fire/phys/module_cu_scalesas.F | 4476 +++ wrfv2_fire/phys/module_cumulus_driver.F | 90 +- wrfv2_fire/phys/module_diag_afwa.F | 169 +- wrfv2_fire/phys/module_diag_afwa_hail.F | 852 - wrfv2_fire/phys/module_diag_hailcast.F | 1347 + wrfv2_fire/phys/module_diag_misc.F | 11 - wrfv2_fire/phys/module_diag_rasm.F | 1242 + wrfv2_fire/phys/module_diagnostics_driver.F | 155 +- wrfv2_fire/phys/module_fdda_psufddagd.F | 2 +- wrfv2_fire/phys/module_fddaobs_driver.F | 13 +- wrfv2_fire/phys/module_fddaobs_rtfdda.F | 16 +- wrfv2_fire/phys/module_fr_fire_atm.F | 8 +- wrfv2_fire/phys/module_fr_fire_driver_wrf.F | 2 +- wrfv2_fire/phys/module_gocart_seasalt.F | 4 +- wrfv2_fire/phys/module_ltng_cpmpr92z.F | 2 +- wrfv2_fire/phys/module_ltng_crmpr92.F | 6 +- wrfv2_fire/phys/module_ltng_iccg.F | 10 +- wrfv2_fire/phys/module_microphysics_driver.F | 174 +- wrfv2_fire/phys/module_mp_fast_sbm.F | 30 +- wrfv2_fire/phys/module_mp_full_sbm.F | 77 +- wrfv2_fire/phys/module_mp_morr_two_moment.F | 44 +- wrfv2_fire/phys/module_mp_nssl_2mom.F | 1312 +- wrfv2_fire/phys/module_mp_p3.F | 5164 +++ wrfv2_fire/phys/module_mp_thompson.F | 157 +- wrfv2_fire/phys/module_mp_wdm5.F | 6 +- wrfv2_fire/phys/module_mp_wdm6.F | 9 +- wrfv2_fire/phys/module_mp_wsm3.F | 7 +- wrfv2_fire/phys/module_mp_wsm5.F | 7 +- wrfv2_fire/phys/module_mp_wsm6.F | 49 +- wrfv2_fire/phys/module_pbl_driver.F | 83 +- wrfv2_fire/phys/module_physics_addtendc.F | 2 +- wrfv2_fire/phys/module_physics_init.F | 132 +- wrfv2_fire/phys/module_ra_cam.F | 8 +- wrfv2_fire/phys/module_ra_cam_support.F | 7 + wrfv2_fire/phys/module_ra_flg.F | 2 +- wrfv2_fire/phys/module_ra_goddard.F | 18 +- wrfv2_fire/phys/module_ra_rrtmg_lw.F | 35 +- wrfv2_fire/phys/module_ra_rrtmg_lwf.F | 35 +- wrfv2_fire/phys/module_ra_rrtmg_sw.F | 15 + wrfv2_fire/phys/module_ra_rrtmg_swf.F | 25 +- wrfv2_fire/phys/module_radiation_driver.F | 228 +- wrfv2_fire/phys/module_sf_bem.F | 10 +- wrfv2_fire/phys/module_sf_bep.F | 10 +- wrfv2_fire/phys/module_sf_bep_bem.F | 28 +- wrfv2_fire/phys/module_sf_exchcoef.F | 84 + wrfv2_fire/phys/module_sf_gfdl.F | 207 +- wrfv2_fire/phys/module_sf_mynn.F | 244 +- wrfv2_fire/phys/module_sf_noahdrv.F | 34 +- wrfv2_fire/phys/module_sf_noahlsm.F | 4 +- .../phys/module_sf_noahmp_groundwater.F | 5 +- wrfv2_fire/phys/module_sf_noahmpdrv.F | 1083 +- wrfv2_fire/phys/module_sf_noahmplsm.F | 174 +- wrfv2_fire/phys/module_sf_oml.F | 10 + wrfv2_fire/phys/module_sf_pxsfclay.F | 21 +- wrfv2_fire/phys/module_sf_ruclsm.F | 650 +- wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F | 7 +- wrfv2_fire/phys/module_sf_sfclay.F | 2 + wrfv2_fire/phys/module_sf_sfclayrev.F | 55 +- wrfv2_fire/phys/module_sf_urban.F | 10 +- wrfv2_fire/phys/module_surface_driver.F | 187 +- wrfv2_fire/run/MPTABLE.TBL | 8 +- wrfv2_fire/run/README.namelist | 430 +- wrfv2_fire/run/README.rasm_diag | 51 + wrfv2_fire/run/SOILPARM.TBL | 40 +- wrfv2_fire/run/create_p3_lookupTable_1.f90 | 1803 + wrfv2_fire/run/p3_lookup_table_1.dat | 31000 ++++++++++++++++ wrfv2_fire/share/Makefile | 1 + wrfv2_fire/share/dfi.F | 102 +- wrfv2_fire/share/input_wrf.F | 159 +- wrfv2_fire/share/interp_fcn.F | 571 +- wrfv2_fire/share/mediation_integrate.F | 41 +- wrfv2_fire/share/module_bc.F | 22 +- wrfv2_fire/share/module_check_a_mundo.F | 658 +- wrfv2_fire/share/module_interp_nmm.F | 57 +- wrfv2_fire/share/module_soil_pre.F | 88 +- wrfv2_fire/share/module_trajectory.F | 3053 ++ wrfv2_fire/share/output_wrf.F | 35 +- wrfv2_fire/share/solve_interface.F | 15 + wrfv2_fire/test/em_fire/README.txt | 25 +- ...ut_sounding => input_sounding_hill_simple} | 0 ...nput_sounding => input_sounding_two_fires} | 0 ...amelist.fire => namelist.fire_hill_simple} | 0 .../namelist.fire => namelist.fire_two_fires} | 0 wrfv2_fire/test/em_fire/namelist.input | 1 + ...elist.input => namelist.input_hill_simple} | 0 ...amelist.input => namelist.input_two_fires} | 0 .../extras/input_sounding-U=10,N=0.01 | 602 + .../extras/input_sounding-U=15,N=0.01 | 602 + .../extras/input_sounding-layers-20mps | 602 + ...km_deep-20km_damping-dampcoef=0.1-etac=0.2 | 103 + ...m_deep-15km_damping-dampcoef=0.08-etac=0.2 | 103 + .../em_hill2d_x/extras/namelist.input-HILL | 103 + .../em_hill2d_x/extras/namelist.input-HILL-51 | 103 + .../extras/namelist.input-HILL-schar | 103 + wrfv2_fire/test/em_real/.gitignore | 27 + wrfv2_fire/test/em_real/examples.namelist | 82 +- wrfv2_fire/test/em_real/namelist.input | 12 +- wrfv2_fire/test/em_real/namelist.input.4km | 10 +- wrfv2_fire/test/em_real/namelist.input.global | 19 +- wrfv2_fire/test/em_real/namelist.input.jan00 | 14 +- wrfv2_fire/test/em_real/namelist.input.jun01 | 9 +- .../README.NMM.TROPICAL_CYCLONE | 5 +- wrfv2_fire/test/nmm_tropical_cyclone/land.nml | 22 + .../test/nmm_tropical_cyclone/namelist.input | 59 +- .../test/nmm_tropical_cyclone/namelist.wps | 29 +- wrfv2_fire/tools/any_updates_in_registry.csh | 85 + wrfv2_fire/tools/commit_form.txt | 19 +- wrfv2_fire/tools/fortran_2008_gamma_test.F | 7 + wrfv2_fire/tools/gen_allocs.c | 17 +- wrfv2_fire/tools/gen_scalar_indices.c | 28 +- wrfv2_fire/tools/non_ascii_finder.F | 240 + wrfv2_fire/tools/protos.h | 2 +- wrfv2_fire/tools/test_nml_domains.csh | 159 + wrfv2_fire/tools/update_fork.pl | 71 + 395 files changed, 130148 insertions(+), 22975 deletions(-) create mode 100644 wrfv2_fire/README.hybrid_vert_coord create mode 100644 wrfv2_fire/Registry/registry.hyb_coord create mode 100644 wrfv2_fire/Registry/registry.new3d_gca create mode 100644 wrfv2_fire/Registry/registry.new3d_wif create mode 100644 wrfv2_fire/Registry/registry.rasm_diag create mode 100644 wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_args_to_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_args_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_decls_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_a_saprc99_mosaic_8bin_vbs2_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_b_saprc99_mosaic_8bin_vbs2_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_e_saprc99_mosaic_8bin_vbs2_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ia_saprc99_mosaic_8bin_vbs2_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ib_saprc99_mosaic_8bin_vbs2_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ibu_saprc99_mosaic_8bin_vbs2_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_l_saprc99_mosaic_8bin_vbs2_aq.inc create mode 100644 wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_u_saprc99_mosaic_8bin_vbs2_aq.inc delete mode 100644 wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags create mode 100644 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.tuv.jmap create mode 100644 wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.tuv.jmap create mode 100644 wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.tuv.jmap create mode 100755 wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/atoms_red create mode 100755 wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.def create mode 100755 wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.eqn create mode 100644 wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.kpp create mode 100755 wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.spc create mode 100644 wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq_wrfkpp.equiv create mode 100644 wrfv2_fire/chem/KPP/util/wkc/Makefile.tuv create mode 100644 wrfv2_fire/chem/KPP/util/wkc/tuv_kpp.c mode change 100755 => 100644 wrfv2_fire/chem/emissions_driver.F create mode 100644 wrfv2_fire/chem/la_srb.F create mode 100644 wrfv2_fire/chem/module_phot_tuv.F create mode 100644 wrfv2_fire/chem/module_subs_tuv.F create mode 100644 wrfv2_fire/chem/numer.F create mode 100644 wrfv2_fire/chem/params.mod.F create mode 100644 wrfv2_fire/chem/params_mod.F create mode 100644 wrfv2_fire/chem/rdxs.F create mode 100644 wrfv2_fire/chem/rtrans.F create mode 100644 wrfv2_fire/chem/rxn.F create mode 100644 wrfv2_fire/external/.gitignore create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/Makefile create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F create mode 100644 wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F create mode 100644 wrfv2_fire/hydro/Data_Rec/Makefile create mode 100644 wrfv2_fire/hydro/Data_Rec/gw_field_include.inc create mode 100644 wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F create mode 100644 wrfv2_fire/hydro/Data_Rec/module_RT_data.F create mode 100644 wrfv2_fire/hydro/Data_Rec/module_gw_gw2d_data.F create mode 100644 wrfv2_fire/hydro/Data_Rec/module_namelist.F create mode 100644 wrfv2_fire/hydro/Data_Rec/namelist.inc create mode 100644 wrfv2_fire/hydro/Data_Rec/rt_include.inc create mode 100644 wrfv2_fire/hydro/HYDRO_drv/Makefile create mode 100644 wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F create mode 100644 wrfv2_fire/hydro/MPP/CPL_WRF.F create mode 100644 wrfv2_fire/hydro/MPP/Makefile create mode 100644 wrfv2_fire/hydro/MPP/module_mpp_GWBUCKET.F create mode 100644 wrfv2_fire/hydro/MPP/module_mpp_ReachLS.F create mode 100644 wrfv2_fire/hydro/MPP/mpp_land.F create mode 100644 wrfv2_fire/hydro/README.hydro create mode 100644 wrfv2_fire/hydro/Rapid_routing/.gitignore create mode 100644 wrfv2_fire/hydro/Rapid_routing/LICENSE create mode 100644 wrfv2_fire/hydro/Rapid_routing/README create mode 100644 wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_drv.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_wrapper.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/makefile create mode 100644 wrfv2_fire/hydro/Rapid_routing/makefile.cpl create mode 100644 wrfv2_fire/hydro/Rapid_routing/makefile.orig create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_arrays.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_close_Qfor_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_close_Qhum_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_close_Qobs_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_close_Qout_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_close_Vlat_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_create_Qout_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_create_obj.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_destro_obj.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_final.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_get_Qdam.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_hsh_mat.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_init.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_main.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_namelist create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_net_mat.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_net_mat_brk.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_obs_mat.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_open_Qfor_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_open_Qhum_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_open_Qobs_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_open_Qout_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_open_Vlat_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_phiroutine.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_read_Qfor_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_read_Qhum_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_read_Qobs_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_read_Vlat_file.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_read_namelist.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_routing.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_routing_param.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_script.sh create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_set_Qext0.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_var.F90 create mode 100644 wrfv2_fire/hydro/Rapid_routing/rapid_write_Qout_file.F90 create mode 100644 wrfv2_fire/hydro/Routing/Makefile create mode 100644 wrfv2_fire/hydro/Routing/Noah_distr_routing.F create mode 100644 wrfv2_fire/hydro/Routing/module_GW_baseflow.F create mode 100644 wrfv2_fire/hydro/Routing/module_HYDRO_io.F create mode 100644 wrfv2_fire/hydro/Routing/module_HYDRO_utils.F create mode 100644 wrfv2_fire/hydro/Routing/module_RT.F create mode 100644 wrfv2_fire/hydro/Routing/module_UDMAP.F create mode 100644 wrfv2_fire/hydro/Routing/module_channel_routing.F create mode 100644 wrfv2_fire/hydro/Routing/module_date_utilities_rt.F create mode 100644 wrfv2_fire/hydro/Routing/module_gw_gw2d.F create mode 100644 wrfv2_fire/hydro/Routing/module_lsm_forcing.F create mode 100644 wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F create mode 100644 wrfv2_fire/hydro/Routing/rtFunction.F create mode 100644 wrfv2_fire/hydro/Run/HYDRO.TBL create mode 100644 wrfv2_fire/hydro/Run/hydro.namelist create mode 100644 wrfv2_fire/hydro/arc/Makefile.Noah create mode 100644 wrfv2_fire/hydro/arc/Makefile.NoahMP create mode 100644 wrfv2_fire/hydro/arc/Makefile.mpp create mode 100644 wrfv2_fire/hydro/arc/Makefile.seq create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.gfort create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.ifort create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.ifort.luna create mode 100644 wrfv2_fire/hydro/arc/macros.mpp.linux create mode 100644 wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r create mode 100644 wrfv2_fire/hydro/arc/macros.seq.gfort create mode 100644 wrfv2_fire/hydro/arc/macros.seq.ifort create mode 100644 wrfv2_fire/hydro/arc/macros.seq.linux create mode 100755 wrfv2_fire/hydro/configure create mode 100644 wrfv2_fire/hydro/template/HYDRO/HYDRO.TBL create mode 100644 wrfv2_fire/hydro/template/HYDRO/hydro.namelist create mode 100755 wrfv2_fire/hydro/wrf_hydro_config create mode 100644 wrfv2_fire/inc/.gitignore delete mode 100755 wrfv2_fire/phys/module_bl_gfs2011.F create mode 100755 wrfv2_fire/phys/module_bl_gfsedmf.F delete mode 100644 wrfv2_fire/phys/module_cu_gf.F create mode 100644 wrfv2_fire/phys/module_cu_gf_deep.F create mode 100644 wrfv2_fire/phys/module_cu_gf_sh.F create mode 100644 wrfv2_fire/phys/module_cu_gf_wrfdrv.F delete mode 100644 wrfv2_fire/phys/module_cu_mesosas.F create mode 100755 wrfv2_fire/phys/module_cu_scalesas.F delete mode 100644 wrfv2_fire/phys/module_diag_afwa_hail.F create mode 100644 wrfv2_fire/phys/module_diag_hailcast.F create mode 100644 wrfv2_fire/phys/module_diag_rasm.F create mode 100644 wrfv2_fire/phys/module_mp_p3.F mode change 100644 => 100755 wrfv2_fire/phys/module_sf_mynn.F mode change 100755 => 100644 wrfv2_fire/phys/module_sf_pxsfclay.F create mode 100644 wrfv2_fire/run/README.rasm_diag create mode 100644 wrfv2_fire/run/create_p3_lookupTable_1.f90 create mode 100644 wrfv2_fire/run/p3_lookup_table_1.dat create mode 100644 wrfv2_fire/share/module_trajectory.F rename wrfv2_fire/test/em_fire/{hill_simple/input_sounding => input_sounding_hill_simple} (100%) rename wrfv2_fire/test/em_fire/{two_fires/input_sounding => input_sounding_two_fires} (100%) rename wrfv2_fire/test/em_fire/{hill_simple/namelist.fire => namelist.fire_hill_simple} (100%) rename wrfv2_fire/test/em_fire/{two_fires/namelist.fire => namelist.fire_two_fires} (100%) create mode 120000 wrfv2_fire/test/em_fire/namelist.input rename wrfv2_fire/test/em_fire/{hill_simple/namelist.input => namelist.input_hill_simple} (100%) rename wrfv2_fire/test/em_fire/{two_fires/namelist.input => namelist.input_two_fires} (100%) create mode 100644 wrfv2_fire/test/em_hill2d_x/extras/input_sounding-U=10,N=0.01 create mode 100644 wrfv2_fire/test/em_hill2d_x/extras/input_sounding-U=15,N=0.01 create mode 100644 wrfv2_fire/test/em_hill2d_x/extras/input_sounding-layers-20mps create mode 100644 wrfv2_fire/test/em_hill2d_x/extras/namelist.input-100m_hill-10mps-N^2=0.0001-30km_deep-20km_damping-dampcoef=0.1-etac=0.2 create mode 100644 wrfv2_fire/test/em_hill2d_x/extras/namelist.input-700m_hill-15mps-n^2=0.0001-25km_deep-15km_damping-dampcoef=0.08-etac=0.2 create mode 100644 wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL create mode 100644 wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL-51 create mode 100644 wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL-schar create mode 100644 wrfv2_fire/test/em_real/.gitignore create mode 100644 wrfv2_fire/test/nmm_tropical_cyclone/land.nml create mode 100755 wrfv2_fire/tools/any_updates_in_registry.csh create mode 100644 wrfv2_fire/tools/fortran_2008_gamma_test.F create mode 100644 wrfv2_fire/tools/non_ascii_finder.F create mode 100755 wrfv2_fire/tools/test_nml_domains.csh create mode 100755 wrfv2_fire/tools/update_fork.pl diff --git a/wrfv2_fire/Makefile b/wrfv2_fire/Makefile index 8cbdfa50..11ef97c6 100644 --- a/wrfv2_fire/Makefile +++ b/wrfv2_fire/Makefile @@ -109,13 +109,12 @@ wrf : framework_only all_wrfvar : $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" ext $(MAKE) MODULE_DIRS="$(DA_WRFVAR_MODULES)" toolsdir - if [ $(CRTM) ] ; then \ - (cd var/external/crtm_2.1.3; \ - export ABI_CRTM="${ABI_CRTM}"; . configure/$(SFC_CRTM).setup; $(MAKE) $(J) ) ; \ + if [ $(CRTM) -ne 0 ] ; then \ + (cd var/external/crtm_2.2.3; $(MAKE) $(J)) ; \ fi if [ $(BUFR) ] ; then \ (cd var/external/bufr; \ - $(MAKE) $(J) FC="$(SFC)" CC="$(SCC)" CPP="$(CPP)" CPPFLAGS="$(CPPFLAGS)" CFLAGS="$(CFLAGS)" FFLAGS="$(FCDEBUG) $(FORMAT_FIXED)" RANLIB="$(RANLIB)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ) ; \ + $(MAKE) $(J) FC="$(SFC)" CC="$(SCC)" CPP="$(CPP)" CPPFLAGS="$(CPPFLAGS)" CFLAGS="$(CFLAGS)" FFLAGS="$(FCOPTIM) $(FORMAT_FIXED)" RANLIB="$(RANLIB)" AR="$(AR)" ARFLAGS="$(ARFLAGS)" ) ; \ fi ### Use 'make' to avoid '-i -r' above: if [ $(WAVELET) ] ; then \ @@ -163,7 +162,7 @@ em_fire : wrf ( cd test/em_fire ; /bin/sh create_links.sh ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_fire/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_fire/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @@ -189,7 +188,7 @@ em_quarter_ss : wrf ( cd test/em_quarter_ss ; /bin/rm -f termvels.asc ; ln -s ../../run/termvels.asc . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_quarter_ss/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_quarter_ss/input_sounding . ) @echo " " @@ -222,7 +221,7 @@ em_squall2d_x : wrf ( cd test/em_squall2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_squall2d_x/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_squall2d_x/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @@ -257,7 +256,7 @@ em_squall2d_y : wrf ( cd test/em_squall2d_y ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_squall2d_y/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_squall2d_y/input_sounding . ) @echo " " @@ -290,7 +289,7 @@ em_b_wave : wrf ( cd test/em_b_wave ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_b_wave/namelist.input . ) ( cd run ; /bin/rm -f input_jet ; ln -s ../test/em_b_wave/input_jet . ) @echo " " @@ -323,7 +322,7 @@ em_les : wrf ( cd test/em_les ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_les/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_les/input_sounding . ) @echo " " @@ -356,7 +355,7 @@ em_seabreeze2d_x : wrf ( cd test/em_seabreeze2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_seabreeze2d_x/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_seabreeze2d_x/input_sounding . ) @echo " " @@ -387,7 +386,7 @@ em_convrad : wrf ( cd test/em_convrad ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_convrad/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_convrad/input_sounding . ) @echo "build started: $(START_OF_COMPILE)" @@ -403,7 +402,7 @@ em_tropical_cyclone : wrf ( cd test/em_tropical_cyclone ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_tropical_cyclone/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_tropical_cyclone/input_sounding . ) @echo " " @@ -436,7 +435,7 @@ em_scm_xy : wrf ( cd test/em_scm_xy ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_scm_xy/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_scm_xy/input_sounding . ) @echo " " @@ -513,6 +512,7 @@ em_real : wrf ln -sf ../../run/aerosol_lon.formatted . ; \ ln -sf ../../run/aerosol_plev.formatted . ; \ ln -sf ../../run/CCN_ACTIVATE.BIN . ; \ + ln -sf ../../run/p3_lookup_table_1.dat . ; \ if [ $(RWORDSIZE) -eq 8 ] ; then \ ln -sf ../../run/ETAMPNEW_DATA_DBL ETAMPNEW_DATA ; \ ln -sf ../../run/ETAMPNEW_DATA.expanded_rain_DBL ETAMPNEW_DATA.expanded_rain ; \ @@ -577,6 +577,7 @@ em_real : wrf ln -sf ../../run/bulkdens.asc_s_0_03_0_9 . ; \ ln -sf ../../run/bulkradii.asc_s_0_03_0_9 . ; \ ln -sf ../../run/CCN_ACTIVATE.BIN . ; \ + ln -sf ../../run/p3_lookup_table_1.dat . ; \ if [ $(RWORDSIZE) -eq 8 ] ; then \ ln -sf ../../run/ETAMPNEW_DATA_DBL ETAMPNEW_DATA ; \ ln -sf ../../run/ETAMPNEW_DATA.expanded_rain_DBL ETAMPNEW_DATA.expanded_rain ; \ @@ -600,7 +601,7 @@ em_real : wrf ( cd run ; /bin/rm -f ndown.exe ; ln -s ../main/ndown.exe . ) #TEMPORARILY REMOVED ( cd run ; /bin/rm -f nup.exe ; ln -s ../main/nup.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) @echo " " @echo "==========================================================================" @@ -633,7 +634,7 @@ em_hill2d_x : wrf ( cd test/em_hill2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_hill2d_x/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_hill2d_x/input_sounding . ) @echo " " @@ -666,7 +667,7 @@ em_grav2d_x : wrf ( cd test/em_grav2d_x ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_grav2d_x/namelist.input . ) ( cd run ; /bin/rm -f input_sounding ; ln -s ../test/em_grav2d_x/input_sounding . ) @echo " " @@ -699,7 +700,7 @@ em_heldsuarez : wrf ( cd test/em_heldsuarez ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_heldsuarez/namelist.input . ) @echo " " @echo "==========================================================================" @@ -729,7 +730,7 @@ emi_conv : wrf ( cd test/em_real ; /bin/rm -f convert_emiss.exe ; ln -s ../../chem/convert_emiss.exe . ) ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) #### emissions opt 3 converter @@ -740,7 +741,7 @@ opt3_conv : wrf ( cd test/em_real ; /bin/rm -f convert_fireemiss.exe ; ln -s ../../chem/convert_fireemiss.exe . ) ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) #### biogenic emissions converter @@ -751,7 +752,7 @@ bio_conv : wrf ( cd test/em_real ; /bin/rm -f convert_bioemiss.exe ; ln -s ../../chem/convert_bioemiss.exe . ) ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) bioemiss_conv_megan2 : wrf @@ -760,7 +761,7 @@ bioemiss_conv_megan2 : wrf ( cd test/em_real ; /bin/rm -f convert_bioemiss_megan2.exe ; ln -s ../../chem/convert_bioemiss_megan2.exe . ) ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) #### DMS emissions converter @@ -771,7 +772,7 @@ dms_conv : wrf ( cd test/em_real ; /bin/rm -f convert_dms.exe ; ln -s ../../chem/convert_dms.exe . ) ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) @@ -783,7 +784,7 @@ dust_conv : wrf ( cd test/em_real ; /bin/rm -f convert_dust.exe ; ln -s ../../chem/convert_dust.exe . ) ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) #### GOCART background state for oh, no3 and h2o2 converter @@ -794,7 +795,7 @@ gocart_conv : wrf ( cd test/em_real ; /bin/rm -f convert_gocart.exe ; ln -s ../../chem/convert_gocart.exe . ) ( cd test/em_real ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/em_real/namelist.input . ) @@ -809,7 +810,7 @@ nmm_tropical_cyclone : nmm_wrf ( cd test/nmm_tropical_cyclone ; /bin/rm -f README.namelist ; ln -s ../../run/README.namelist . ) ( cd run ; /bin/rm -f ideal.exe ; ln -s ../main/ideal.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/nmm_tropical_cyclone/namelist.input . ) @echo "build started: $(START_OF_COMPILE)" @echo "build completed:" `date` @@ -842,7 +843,7 @@ nmm_real : nmm_wrf ( cd test/nmm_real ; /bin/rm -f co2_trans ; ln -s ../../run/co2_trans . ) ( cd run ; /bin/rm -f real_nmm.exe ; ln -s ../main/real_nmm.exe . ) ( cd run ; if test -f namelist.input ; then \ - /bin/cp -f namelist.input namelist.input.backup ; fi ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; fi ; \ /bin/rm -f namelist.input ; cp ../test/nmm_real/namelist.input . ) @@ -867,22 +868,27 @@ framework : @ echo '--------------------------------------' ( cd frame ; $(MAKE) $(J) framework; \ cd ../external/io_netcdf ; \ - $(MAKE) NETCDFPATH="$(NETCDFPATH)" FC="$(FC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \ + $(MAKE) NETCDFPATH="$(NETCDFPATH)" \ + FC="$(FC) $(FCBASEOPTS) $(PROMOTION) $(FCDEBUG) $(OMP)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR" diffwrf; \ cd ../io_netcdf ; \ - $(MAKE) NETCDFPATH="$(NETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \ + $(MAKE) NETCDFPATH="$(NETCDFPATH)" \ + FC="$(SFC) $(FCBASEOPTS) $(PROMOTION) $(FCDEBUG) $(OMP)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR"; \ cd ../io_pio ; \ - echo SKIPPING PIO BUILD $(MAKE) NETCDFPATH="$(PNETCDFPATH)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" \ + echo SKIPPING PIO BUILD $(MAKE) NETCDFPATH="$(PNETCDFPATH)" \ + FC="$(SFC) $(FCBASEOPTS) $(PROMOTION) $(FCDEBUG) $(OMP)" RANLIB="$(RANLIB)" \ CPP="$(CPP)" LDFLAGS="$(LDFLAGS)" TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ LIB_LOCAL="$(LIB_LOCAL)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR"; \ cd ../io_int ; \ - $(MAKE) SFC="$(SFC) $(FCBASEOPTS)" FC="$(SFC) $(FCBASEOPTS)" RANLIB="$(RANLIB)" CPP="$(CPP) $(ARCH_LOCAL)" DM_FC="$(DM_FC) $(FCBASEOPTS)"\ + $(MAKE) SFC="$(SFC) $(FCBASEOPTS)" \ + FC="$(SFC) $(FCBASEOPTS) $(PROMOTION) $(FCDEBUG) $(OMP)" \ + RANLIB="$(RANLIB)" CPP="$(CPP) $(ARCH_LOCAL)" DM_FC="$(DM_FC) $(FCBASEOPTS)"\ TRADFLAG="$(TRADFLAG)" ESMF_IO_LIB_EXT="$(ESMF_IO_LIB_EXT)" \ ESMF_MOD_DEPENDENCE="$(ESMF_MOD_DEPENDENCE)" AR="INTERNAL_BUILD_ERROR_SHOULD_NOT_NEED_AR" diffwrf ; \ cd ../../frame ) @@ -962,6 +968,10 @@ fortran_2003_flush_test: fortran_2003_fflush_test: @cd tools ; /bin/rm -f fortran_2003_fflush_test.{exe,o} ; $(SFC) -o fortran_2003_fflush_test.exe fortran_2003_fflush_test.F ; cd .. +# rule used by configure to test if Fortran 2008 gamma intrinsic function is available +fortran_2008_gamma_test: + @cd tools ; /bin/rm -f fortran_2008_gamma_test.{exe,o} ; $(SFC) -o fortran_2008_gamma_test.exe fortran_2008_gamma_test.F ; cd .. + ### 3.b. sub-rule to build the experimental core # uncomment the two lines after exp_core for EXP diff --git a/wrfv2_fire/README b/wrfv2_fire/README index 17d5db9b..95af8ae9 100644 --- a/wrfv2_fire/README +++ b/wrfv2_fire/README @@ -1,4 +1,4 @@ -WRF Model Version 3.8 (April 8, 2016) +WRF Model Version 3.9.1.1 (August 28, 2017) http://wrf-model.org/users/users.php ------------------------ @@ -27,6 +27,38 @@ infringement actions. This is the main directory for the WRF Version 3 source code release. ====================================== +V3.9.1.1 Release Notes (8/28/17): +------------------- + +- Version 3.9.1.1 has only limited bug fixes compared to version 3.9.1. + For more information on WRF V3.9.1.1 release, visit WRF User's home pages + http://www2.mmm.ucar.edu/wrf/users/, and + http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide. + + +V3.9.1 Release Notes (8/17/17): +------------------- + +- For more information on WRF V3.9.1 release, visit WRF User's home pages + http://www2.mmm.ucar.edu/wrf/users/, and + http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide. + + +V3.9 Release Notes (4/17/17): +------------------- + +- For more information on WRF V3.9 release, visit WRF User's home pages + http://www2.mmm.ucar.edu/wrf/users/, and + http://www.dtcenter.org/wrf-nmm/users/, and read the online User's Guide. + + +V3.8.1 Release Notes (8/12/16) (rev 9553): +------------------- + +- For more information on WRF V3.8.1 release, visit WRF User's home pages + http://www2.mmm.ucar.edu/wrf/users/, and + read the online User's Guide. + V3.8 Release Notes (4/8/16) (rev 9345): ------------------- @@ -233,6 +265,13 @@ WRF update history: - V3.5.1: Sept 23, 2013 - V3.6: April 18, 2014 - V3.6.1: Aug 14, 2014 +- V3.7: April 20, 2015 +- V3.7.1: Aug 14, 2015 +- V3.8: April 8, 2016 +- V3.8.1: Aug 12, 2016 +- V3.9: Apr 17, 2017 +- V3.9.1: Aug 17, 2017 +- V3.9.1.1: Aug 28, 2017 ====================================== @@ -272,6 +311,8 @@ How to compile and run? setenv WRFIO_NCD_LARGE_FILE_SUPPORT 1 + This becomes default since V3.9. + 2. Since V3.2, we support using multiple processors for compilation. The default number of processors used is 2. But if you have any problem with compilation, please try using one processor to compile. To do this, set @@ -333,6 +374,7 @@ What is in WRF V3? * global modeling capability on latitude-longitude grid * digital filter initialization * WENO advection options + * Hybrid sigma-pressure vertical coordinate (since V3.9) - Two-way nesting: * multiple domains and multiple nest levels @@ -350,7 +392,7 @@ What is in WRF V3? * microphysics (Kessler/ WRF Single Moment 3, 5 and 6 classes / Lin et al./ Mibrandt 2-moment / Eta Ferrier / Thompson / Goddard / 2-moment Morrison / WRF Double Moment 5 and 6 classes / SBU-Lin 5-classes / NSSL 2-moment and 1-moment / CAM 5.1 ) / Thompson aerosol-aware / - HUJI full and fast SBM + HUJI full and fast SBM / P3 * cumulus parameterization (Kain-Fritsch with shallow convection / Betts-Miller-Janjic / Grell-Devenyi ensemble / Grell 3D (with shallow convection option) / Grell-Freitas ensemble / @@ -386,6 +428,7 @@ What is in WRF V3? * three-dimensional, surface analysis nudging, and flux-adjusting surface data nudging * observation nudging * spectral nudging + * flux-adjusting surface data nudging - Software diff --git a/wrfv2_fire/README.DA b/wrfv2_fire/README.DA index 9f60c14b..bd61d309 100644 --- a/wrfv2_fire/README.DA +++ b/wrfv2_fire/README.DA @@ -23,6 +23,79 @@ WRFDA, including infringement actions. This is the main directory for the WRFDA Version 3 source code release. ====================================== +V3.9.1 Release Notes : +------------------- + +Version 3.9.1 was released on August 17, 2017. + + For more information about WRFDA, visit the WRFDA Users home page + http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html + + Updated features: + + - Reduced memory usage for non-4DVAR runs + - Some bugs have been fixed + +See http://www2.mmm.ucar.edu/wrf/users/wrfda/updates-3.9.1.html for a full list of updates + +====================================== + +V3.9 Release Notes : +------------------- + +Version 3.9 was released on April 17, 2017. + + For more information about WRFDA, visit the WRFDA Users home page + http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html + + New features: + + - AMSR2 cloudy radiance assimilation + - 4DEnVar assimilation capability + - Radar "null-echo" assimilation + + Updates: + - Many bug fixes and performance improvements, including: + - For use_radar_rhv=true, total reflectivity and retrieved hydrometeors were calculated incorrectly + - Several compile-time and run-time bugs for PGI compilers + - Updated CRTM to version 2.2.3 (from 2.1.3) + - New run-time options for improving surface data assimilation (FM-12 SYNOP) + - Improved implementation of cloud control variables (no longer requires conditional compilation) + - New run-time options for calculating cloud base height for use_radar_rqv=true + - WRFPLUS has been upgraded to V3.9 and is consistent with the released WRF version 3.9. + +See http://www2.mmm.ucar.edu/wrf/users/wrfda/updates-3.9.html for a full list of updates + +====================================== + +V3.8.1 Release Notes : +------------------- + +Version 3.8.1 was released on August 12, 2016. + + For more information about WRFDA, visit the WRFDA Users home page + http://www2.mmm.ucar.edu/wrf/users/wrfda/index.html + + Updated features: + + - Additional information is now printed to log files, including: + - Domain mapping info + - Extra minimization info + - CRTM-specific code is now compiled automatically + - A number of issues have been fixed for this release, including: + - Fixed compilation problems for Fujitsu compilers + - A fix for some BUFR compilation problems if user has certain environment variables set + - A fix for crashes with 4DVAR assimilation when using RRTMG radiation physics + - Avoiding alarming (but harmless) error messages from GEN_BE stage 0 + - Fixing CRTM compilation problems for some Cray platforms + - Cleaning up various log file outputs and clarifying some error messages + - Fixed some incorrect default variables for certain physics options + - WRFPLUS has been upgraded to V3.8.1 and is consistent with the released WRF version 3.8.1. + +See http://www2.mmm.ucar.edu/wrf/users/wrfda/updates-3.8.1.html for a full list of updates + +====================================== + V3.8 Release Notes : ------------------- @@ -374,25 +447,29 @@ WRFDA update history: - V3.4.1: Aug 16, 2012 - V3.5: Apr 18, 2013 - V3.5.1: Sep 23, 2013 -- V3.6: Apr 15, 2014 +- V3.6: Apr 18, 2014 +- V3.6.1: Aug 14, 2014 +- V3.7: Apr 20, 2015 +- V3.7.1: Aug 14, 2015 +- V3.8: Apr 8, 2016 +- V3.8.1: Aug 12, 2016 +- V3.9: Apr 17, 2017 ====================================== How to compile and run? ----------------------- -- In WRFDA directory, type 'configure wrfda - this will create a configure.wrf +- In WRFDA directory, type `configure wrfda` - this will create a configure.wrf file that has appropriate compile options for the supported computers. - Note: WRFDA only requires netCDF library starting with V3.1.1. + Note: WRFDA only requires netCDF library for compilation Install netCDF library with the same compiler that will be used to compile WRFDA. - NCEP BUFR and CRTM 2.0.2 libs are included in the WRFDA tar file. + NCEP BUFR and CRTM libs are included in the WRFDA tar file. Set environment variables properly according to your applications before you type 'configure wrfda'. For example, - setenv NETCDF /usr/local/netcdf-pgi - setenv BUFR 1 (optional, set to compile WRFDA with NCEP BUFR capability) - setenv CRTM 1 (optional, set to compile WRFDA with CRTM capability) - setenv RTTOV /usr/local/rttov10 (optional, set to compile WRFDA with RTTOV capability) + setenv NETCDF /usr/local/netcdf + setenv RTTOV /usr/local/rttov11 (optional, set to compile WRFDA with RTTOV capability) - Type 'compile all_wrfvar' when you are ready: @@ -404,3 +481,5 @@ How to compile and run? Some basic instruction/namelist.input are available in sub-directories of WRFDA/var/test. +- See the Users Guide (http://www2.mmm.ucar.edu/wrf/users/wrfda/usersguide.html) for more detailed instructions. + diff --git a/wrfv2_fire/README.hybrid_vert_coord b/wrfv2_fire/README.hybrid_vert_coord new file mode 100644 index 00000000..0eafa4fc --- /dev/null +++ b/wrfv2_fire/README.hybrid_vert_coord @@ -0,0 +1,223 @@ +Hybrid Vertical Coordinate +-------------------------- + +Starting with the WRF v3.9 release (Spring 2017), the option for a Hybrid +Vertical Coordinate (HVC) has been added to the existing Terrain Following +(TF) vertical coordinate in the WRF model. The HVC option requires that a user +activate both a compile-time and a run-time flag. + +HVC: What is it, what's available +--------------------------------- + +The HVC option is a "hybrid" vertical coordinate, in that the eta levels are +terrain following near the surface, and then relax towards an isobaric surface +aloft. The purpose of this coordinate option is to reduce the artificial +influence of topography towards the top of the model. + +Due to the usual annual upgrades in physics and dynamics, the WRF model never +gives bit-reproducible results from one release to the next. However, within +this single release, the WRF model is able to give bit-for-bit results when +the TF model is compared to the WRF model built with the HVC option (but with +the run-time options set to emulate the TF coordinate). + +The "2d flow over a hill" and LES ideal cases both fully support the HVC option. +All of the other ideal cases are essentially hard-coded to be used in the TF +mode only. Any ideal case (other than 2d hill and LES) will gracefully stop if +a user requests to activate the HVC option at run time. Also for bullet- +proofing, any attempt to use the HVC run-time option for any WRF simulation +when the code was built for TF only, will result in a graceful fatal error. + +The real program and the WRF model need to consistently use the same run-time +setting for either TF or HVC. The code will stop if the user mixes the vertical +coordinate run-time settings between real and WRF (or between ideal and WRF). +The WRF code has been modified to use pre-v3.9 input and lateral boundary +files, but only for the run-time choice of the TF coordinate. + +Choosing the TF vs the HVC Option +--------------------------------- + +By default, both the compile-time and run-time options are set to use the +TF coordinate option. + +To activate the HVC build, the "configure" command is given an additional +option: +./configure -hyb + +Once the code is built with the HVC option, still by default the model will +produce results bit-wise identical to the TF build results. To turn on the HVC +run-time option, a switch is set in the namelist.input file: +&dynamics + hybrid_opt = 2 +/ + +This is a single entry value, which is set to zero by default through the +Registry. For completeness, to explicitly turn off the HVC in the +namelist.input file: +&dynamics + hybrid_opt = 0 +/ + +A second run-time option is available for the HVC capability, which allows the +user to select the eta level at which the WRF model surfaces become completely +isobaric. Setting this value is not intuitive, and a reasonable value that +should work globally has been set as the default. For sensitivity testing of +the model results to the level at which the model eta coordinates become +isobaric, the user may modify the critical eta level defined in the +namelist.input file. +&dynamics + etac = 0.2 +/ + +As the value of etac increases (from 0 towards 1), more eta levels are impacted +as increasing numbers of levels (downward from the model top) are flattened +out. On the one hand, that is a good thing, and this "flattening of the +coordinate surfaces" is the entire purpose of the HVC option. However, over +areas of high topography (not necessarily steep or complex), the vertical eta +levels get too compressed when etac values larger than about etac = 0.22. Over +the Himalayan Plateau with a 10 hPa model lid, a value of etac = 0.25 causes +model failures. Globally then, a value of 0.2 is considered "safe". + +Run-time and Compile-time options for HVC +----------------------------------------- + +Here is a easy reference table showing the WRF model behavior with the +combination of the compile-time and run-time settings for the HVC. + + Compile-time Option + ---------------------------------------- + | ./configure | ./configure -hyb | + | TF | HVC | + | | | + -------------------------------------------------------- + | | | | + | Default | Default | Default | + | hybrid_opt=0 | TF | TF | + | | Behavior | Behavior | +Run-Time Option |------------------------------------------------------- + | | | | + | HVC | Model | HVC | + | hybrid_opt=2 | stops - | Behavior | + | | FATAL | | + -------------------------------------------------------- + +How the code has been modified +------------------------------ + +For the v3.9 release, the largest block of modifications required to the source +code for the HVC capability is with the variable defined as the column pressure +in the TF coordinate (referred to generally as "mu"). This is one of the +variables that has both a perturbation and a base-state value, also staggerings +for different variables, and even different time levels. All together, nearly +thirty "mu" variables needed to be processed. For the HVC modification, the 2d +"mu" fields still retain the meaning of column pressure, but the definition of +d(p_dry))/d(eta) has been generalized, and is now 3d. + +Almost all instances of a 2d "mu" field have been transformed into a 3d field +with the application of two 1d arrays (a multiplication and an addition). For +the base-state "mu" and total "mu" fields, functionally this new field is +defined as: +mu_new_3d(i,k,j) = c1(k) * mu(i,j) + c2(k) + +For perturbation "mu" fields, only the multiplicative scaling is applied: +mu_new_3d(i,k,j) = c1(k) * mu(i,j) + +Even with each instance of "mu" being scaled and most instances of "mu" getting +an offset applied, the elapsed time to run TF vs HVC appears to be quite small. +Most of the instances of the required 3d "mu" are handled on the fly, meaning +that no new 3d arrays for "mu" have been introduced in the Registry. Inside the +WRF modeling system, most of the "mu" variables are transformed into 3d arrays +within each computational DO LOOP in which they appear. This technique of +computing the 3d "mu" fields only as required removes the need to introduce +more temporary 3d arrays, and as mentioned, the redundant computation does +not seem to impact the overall timing of the model. + +Cautionary note +--------------- + +Since the references to the "mu" fields are modified automatically at +compile-time within the source, users are strongly encouraged to thoroughly +test any code addition that needs to directly utilize one or more of the "mu" +fields. + +Users are also warned that the original definitions of base-state and +dry pressure are no longer generally valid. Most users will find either p'+pb +or p_hyd as satisfactory pressure substitutes. + +CPP: variable argument list macros +---------------------------------- + +To introduce this vertical coordinate capability required changes to thousands +of lines of code. Fortunately, most of this "convert 2d mu to 3d mu" was +handled with some traditional Unix text processing utilities. You will notice +extra intermediate files that are constructed during the WRF build (if you are +viewing the build log), and there are cpp header lines in quite a few of the +modules in the dyn_em directory. + +A side-effect of the HVC build is that the cpp flag -traditional-cpp is no +longer available, and has been removed from the arch/configure_new.defaults +file. + +What to Notice on Output +------------------------ + +There are a couple of ways to determine if the model output (and as stated +previously, mandatorially the model IC and BC files also) was built and run +with the HVC option. + +Visually, with a simple netcdf viewer (such as ncview), look at the horizontal +levels of the field "PB" in an area of topography. For a few consecutive levels +downward from the model lid, each value on a specific level should be +nearly identical. For the TF option, the signature of the topography is +evident even at the penultimate level. + +The netcdf files also have metadata included to indicate if the hybrid +vertical coordinate option was used. + +For code that was built with the TF compile-time option: +>ncdump -h wrfinput_d01 | grep HYBRID + :HYBRID_OPT = -1 ; + +For code that was built with the HVC compile-time option, but with the TF +run-time option: +>ncdump -h wrfinput_d01 | grep HYBRID + :HYBRID_OPT = 0 ; + +For code that was built with the HVC compile-time option, and with the HVC +run-time option: +>ncdump -h wrfinput_d01 | grep HYBRID + :HYBRID_OPT = 2 ; + +What WRF capabilities are OK with HVC +------------------------------------- + +With WRF v3.9, this is an initial release of the HVC capability. We would like +as many users as possible to try the HVC option and provide feedback. However, +this is an initial release of a new capability within WRF ARW, so care should be +taken. The default behavior is still TF. Tests have been conducted with a +number of the WRF system's other signature features: FDDA, adaptive time +stepping, DFI, global domains, nesting, moving nests, and ndown. A couple of +physics schemes had to be modified, so now all physical parameterization +schemes fully support the HVC option. + +The WRF developers have worked in conjunction with the developers of the other +major WRF system components. Both WRF DA 3dVAR and WRF Chem fully function with the +hybrid coordinate. With the introduction of the HVC option, the standard WRF +post-processing tools are also fully supported: NCL, UPP, and RIP. + +What WRF capabilities are NOT supported with HVC +------------------------------------------------ + +Only two of the idealized initialization programs are enabled with the HVC +option. However, those unsupported cases have a flat surface, so the expected +impact with the HVC option would not be large. + +The one capability that is not functioning with the HVC option is vertical +refinement. + +Registry information +-------------------- + +The Registry file that contains all of the information for the hybrid +coordinate is Registry/registry.hybrid. In the comments at the top of this file +is a brief description of the component pieces that constitute new 3d "mu": +d(p_dry)/d(eta). diff --git a/wrfv2_fire/Registry/Registry.EM b/wrfv2_fire/Registry/Registry.EM index f2e5491f..1b4062ca 100644 --- a/wrfv2_fire/Registry/Registry.EM +++ b/wrfv2_fire/Registry/Registry.EM @@ -15,19 +15,23 @@ include registry.ssib include registry.lake include registry.diags include registry.afwa +include registry.rasm_diag include registry.sbm include registry.elec include registry.bdy_perturb +include registry.hyb_coord +include registry.new3d_wif + # added to output 5 for ESMF -state real landmask ij misc 1 - i0125rh05d=(interp_fcnm_imask)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" +state real landmask ij misc 1 - i0125rh056d=(interp_fcnm_imask)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" state real lakemask ij misc 1 - i012rhd=(interp_fcnm_imask)u=(copy_fcnm) "LAKEMASK" "LAKE MASK (1 FOR LAKE, 0 FOR NON-LAKE)" "" # Masked SST interpolation from the CG #state real SST ij misc 1 - i01245rh05d=(interp_mask_field:lu_index,iswater)f=(p2c_mask:lu_index,tslb,num_soil_layers,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" # Simple SST interpolation from the CG #state real SST ij misc 1 - i01245rh05d=(interp_mask_field:lu_index,iswater)f=(p2c) "SST" "SEA SURFACE TEMPERATURE" "K" -state real SST ij misc 1 - i01245rh05d=(interp_mask_field:lu_index,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" +state real SST ij misc 1 - i01245rh0d=(interp_mask_field:lu_index,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" state real SST_INPUT ij misc 1 - rh "SST_INPUT" "SEA SURFACE TEMPERATURE FROM WRFLOWINPUT FILE" "K" @@ -51,5 +55,8 @@ state real tr17_8 ikjftb tracer 1 - irhusdf=(bdy_in package tracer_test1 tracer_opt==2 - tracer:tr17_1,tr17_2,tr17_3,tr17_4,tr17_5,tr17_6,tr17_7,tr17_8 - +package restofwrf use_wps_input==0 - - +package realonly use_wps_input==1 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,lai12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,cl_gc,cf_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc,prho_gc,pdrho_gc,qnr_gc,soil_layers,soil_levels,st,sm,sw,soilt,soilm,sm000007,sm007028,sm028100,sm100255,st000007,st007028,st028100,st100255,sm000010,sm010040,sm040100,sm100200,sm010200,soilm000,soilm005,soilm020,soilm040,soilm160,soilm300,sw000010,sw010040,sw040100,sw100200,sw010200,soilw000,soilw005,soilw020,soilw040,soilw160,soilw300,st000010,st010040,st040100,st100200,st010200,soilt000,soilt005,soilt020,soilt040,soilt160,soilt300,fad0_urb2d,fad135_urb2d,fad45_urb2d,pad_urb2d,fad90_urb2d,rad_urb2d,car_urb2d,h2w_urb2d,svf_urb2d,z0s_urb2d,z0r_urb2d,z0m_urb2d,zds_urb2d,zdm_urb2d,zdr_urb2d,qnwfa_gc,qnwfa_now,qnwfa_jan,qnwfa_feb,qnwfa_mar,qnwfa_apr,qnwfa_may,qnwfa_jun,qnwfa_jul,qnwfa_aug,qnwfa_sep,qnwfa_oct,qnwfa_nov,qnwfa_dec,qnifa_gc,qnifa_now,qnifa_jan,qnifa_feb,qnifa_mar,qnifa_apr,qnifa_may,qnifa_jun,qnifa_jul,qnifa_aug,qnifa_sep,qnifa_oct,qnifa_nov,qnifa_dec,qntemp,qntemp2,hgtmaxw,pmaxw,tmaxw,umaxw,vmaxw,hgttrop,ptrop,ttrop,utrop,vtrop,urb_param + +package tconly use_wps_input==2 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc diff --git a/wrfv2_fire/Registry/Registry.EM_CHEM b/wrfv2_fire/Registry/Registry.EM_CHEM index 5a377781..c05b7d18 100644 --- a/wrfv2_fire/Registry/Registry.EM_CHEM +++ b/wrfv2_fire/Registry/Registry.EM_CHEM @@ -16,8 +16,12 @@ include registry.ssib include registry.sbm include registry.diags include registry.afwa +include registry.rasm_diag include registry.elec include registry.bdy_perturb +include registry.new3d_gca +include registry.hyb_coord +include registry.new3d_wif state real landmask ij misc 1 - i012rh0d=(interp_fcnm_imask)u=(copy_fcnm) "LANDMASK" "LAND MASK (1 FOR LAND, 0 FOR WATER)" "" state real lakemask ij misc 1 - i012rh0d=(interp_fcnm_imask)u=(copy_fcnm) "LAKEMASK" "LAKE MASK (1 FOR LAND, 0 FOR WATER)" "" @@ -28,3 +32,9 @@ state real lakemask ij misc 1 - i012rh0d=(int #state real SST ij misc 1 - i0124rh0d=(interp_mask_field:lu_index,iswater)f=(p2c) "SST" "SEA SURFACE TEMPERATURE" "K" state real SST ij misc 1 - i0124rh0d=(interp_mask_field:lu_index,iswater) "SST" "SEA SURFACE TEMPERATURE" "K" state real SST_INPUT ij misc 1 - rh "SST_INPUT" "SEA SURFACE TEMPERATURE FROM WRFLOWINPUT FILE" "K" + +package restofwrf use_wps_input==0 - - + +package realonly use_wps_input==1 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,lai12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,cl_gc,cf_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc,prho_gc,pdrho_gc,qnr_gc,soil_layers,soil_levels,st,sm,sw,soilt,soilm,sm000007,sm007028,sm028100,sm100255,st000007,st007028,st028100,st100255,sm000010,sm010040,sm040100,sm100200,sm010200,soilm000,soilm005,soilm020,soilm040,soilm160,soilm300,sw000010,sw010040,sw040100,sw100200,sw010200,soilw000,soilw005,soilw020,soilw040,soilw160,soilw300,st000010,st010040,st040100,st100200,st010200,soilt000,soilt005,soilt020,soilt040,soilt160,soilt300,fad0_urb2d,fad135_urb2d,fad45_urb2d,pad_urb2d,fad90_urb2d,rad_urb2d,car_urb2d,h2w_urb2d,svf_urb2d,z0s_urb2d,z0r_urb2d,z0m_urb2d,zds_urb2d,zdm_urb2d,zdr_urb2d,qnwfa_gc,qnwfa_now,qnwfa_jan,qnwfa_feb,qnwfa_mar,qnwfa_apr,qnwfa_may,qnwfa_jun,qnwfa_jul,qnwfa_aug,qnwfa_sep,qnwfa_oct,qnwfa_nov,qnwfa_dec,qnifa_gc,qnifa_now,qnifa_jan,qnifa_feb,qnifa_mar,qnifa_apr,qnifa_may,qnifa_jun,qnifa_jul,qnifa_aug,qnifa_sep,qnifa_oct,qnifa_nov,qnifa_dec,qntemp,qntemp2,hgtmaxw,pmaxw,tmaxw,umaxw,vmaxw,hgttrop,ptrop,ttrop,utrop,vtrop,urb_param + +package tconly use_wps_input==2 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc diff --git a/wrfv2_fire/Registry/Registry.EM_COMMON b/wrfv2_fire/Registry/Registry.EM_COMMON index bc008654..6eb6ee2f 100644 --- a/wrfv2_fire/Registry/Registry.EM_COMMON +++ b/wrfv2_fire/Registry/Registry.EM_COMMON @@ -50,8 +50,8 @@ # table entries are of the form #
# -state real XLAT ij misc 1 - i0123rh01{22}{23}du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" -state real XLONG ij misc 1 - i0123rh01{22}{23}du=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLAT ij misc 1 - i0123rh0156{22}{23}du=(copy_fcnm) "XLAT" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" +state real XLONG ij misc 1 - i0123rh0156{22}{23}d=(interp_fcn_blint_ll:xlat,input_from_file)u=(copy_fcnm) "XLONG" "LONGITUDE, WEST IS NEGATIVE" "degree_east" # It is required that LU_INDEX appears before any variable that is # interpolated with a mask, as lu_index supplies that mask. @@ -121,34 +121,34 @@ state real qg_gc igj dyn_em 1 Z i1 "QG" " state real qh_gc igj dyn_em 1 Z i1 "QH" "hail mixing ratio" "kg kg-1" state real qni_gc igj dyn_em 1 Z i1 "QNI" "ice num concentration" "m-3" state real qnr_gc igj dyn_em 1 Z i1 "QNR" "rain num concentration" "m-3" -state real qnwfa_gc igj dyn_em 1 Z i1 "QNWFA" "water-friendly aerosol num concentration" "m-3" -state real qnifa_gc igj dyn_em 1 Z i1 "QNIFA" "water-friendly aerosol num concentration" "m-3" -state real qnwfa_now igj dyn_em 1 Z - "QNWFA_NOW" "num water-friendly aerosol Now" "kg-1" -state real qnwfa_jan igj dyn_em 1 Z i1 "QNWFA_JAN" "num water-friendly aerosol Jan" "kg-1" -state real qnwfa_feb igj dyn_em 1 Z i1 "QNWFA_FEB" "num water-friendly aerosol Feb" "kg-1" -state real qnwfa_mar igj dyn_em 1 Z i1 "QNWFA_MAR" "num water-friendly aerosol Mar" "kg-1" -state real qnwfa_apr igj dyn_em 1 Z i1 "QNWFA_APR" "num water-friendly aerosol Apr" "kg-1" -state real qnwfa_may igj dyn_em 1 Z i1 "QNWFA_MAY" "num water-friendly aerosol May" "kg-1" -state real qnwfa_jun igj dyn_em 1 Z i1 "QNWFA_JUN" "num water-friendly aerosol Jun" "kg-1" -state real qnwfa_jul igj dyn_em 1 Z i1 "QNWFA_JUL" "num water-friendly aerosol Jul" "kg-1" -state real qnwfa_aug igj dyn_em 1 Z i1 "QNWFA_AUG" "num water-friendly aerosol Aug" "kg-1" -state real qnwfa_sep igj dyn_em 1 Z i1 "QNWFA_SEP" "num water-friendly aerosol Sep" "kg-1" -state real qnwfa_oct igj dyn_em 1 Z i1 "QNWFA_OCT" "num water-friendly aerosol Oct" "kg-1" -state real qnwfa_nov igj dyn_em 1 Z i1 "QNWFA_NOV" "num water-friendly aerosol Nov" "kg-1" -state real qnwfa_dec igj dyn_em 1 Z i1 "QNWFA_DEC" "num water-friendly aerosol Dec" "kg-1" -state real qnifa_now igj dyn_em 1 Z - "QNIFA_NOW" "num ice-friendly aerosol Now" "kg-1" -state real qnifa_jan igj dyn_em 1 Z i1 "QNIFA_JAN" "num ice-friendly aerosol Jan" "kg-1" -state real qnifa_feb igj dyn_em 1 Z i1 "QNIFA_FEB" "num ice-friendly aerosol Feb" "kg-1" -state real qnifa_mar igj dyn_em 1 Z i1 "QNIFA_MAR" "num ice-friendly aerosol Mar" "kg-1" -state real qnifa_apr igj dyn_em 1 Z i1 "QNIFA_APR" "num ice-friendly aerosol Apr" "kg-1" -state real qnifa_may igj dyn_em 1 Z i1 "QNIFA_MAY" "num ice-friendly aerosol May" "kg-1" -state real qnifa_jun igj dyn_em 1 Z i1 "QNIFA_JUN" "num ice-friendly aerosol Jun" "kg-1" -state real qnifa_jul igj dyn_em 1 Z i1 "QNIFA_JUL" "num ice-friendly aerosol Jul" "kg-1" -state real qnifa_aug igj dyn_em 1 Z i1 "QNIFA_AUG" "num ice-friendly aerosol Aug" "kg-1" -state real qnifa_sep igj dyn_em 1 Z i1 "QNIFA_SEP" "num ice-friendly aerosol Sep" "kg-1" -state real qnifa_oct igj dyn_em 1 Z i1 "QNIFA_OCT" "num ice-friendly aerosol Oct" "kg-1" -state real qnifa_nov igj dyn_em 1 Z i1 "QNIFA_NOV" "num ice-friendly aerosol Nov" "kg-1" -state real qnifa_dec igj dyn_em 1 Z i1 "QNIFA_DEC" "num ice-friendly aerosol Dec" "kg-1" +state real qnwfa_gc igj dyn_em 1 Z i1 "QNWFA" "water-friendly aerosol num concentration" "# kg-1" +state real qnifa_gc igj dyn_em 1 Z i1 "QNIFA" "water-friendly aerosol num concentration" "# kg-1" +state real qnwfa_now igj dyn_em 1 Z - "QNWFA_NOW" "num water-friendly aerosol Now" "# kg-1" +state real qnwfa_jan igj dyn_em 1 Z i1 "QNWFA_JAN" "num water-friendly aerosol Jan" "# kg-1" +state real qnwfa_feb igj dyn_em 1 Z i1 "QNWFA_FEB" "num water-friendly aerosol Feb" "# kg-1" +state real qnwfa_mar igj dyn_em 1 Z i1 "QNWFA_MAR" "num water-friendly aerosol Mar" "# kg-1" +state real qnwfa_apr igj dyn_em 1 Z i1 "QNWFA_APR" "num water-friendly aerosol Apr" "# kg-1" +state real qnwfa_may igj dyn_em 1 Z i1 "QNWFA_MAY" "num water-friendly aerosol May" "# kg-1" +state real qnwfa_jun igj dyn_em 1 Z i1 "QNWFA_JUN" "num water-friendly aerosol Jun" "# kg-1" +state real qnwfa_jul igj dyn_em 1 Z i1 "QNWFA_JUL" "num water-friendly aerosol Jul" "# kg-1" +state real qnwfa_aug igj dyn_em 1 Z i1 "QNWFA_AUG" "num water-friendly aerosol Aug" "# kg-1" +state real qnwfa_sep igj dyn_em 1 Z i1 "QNWFA_SEP" "num water-friendly aerosol Sep" "# kg-1" +state real qnwfa_oct igj dyn_em 1 Z i1 "QNWFA_OCT" "num water-friendly aerosol Oct" "# kg-1" +state real qnwfa_nov igj dyn_em 1 Z i1 "QNWFA_NOV" "num water-friendly aerosol Nov" "# kg-1" +state real qnwfa_dec igj dyn_em 1 Z i1 "QNWFA_DEC" "num water-friendly aerosol Dec" "# kg-1" +state real qnifa_now igj dyn_em 1 Z - "QNIFA_NOW" "num ice-friendly aerosol Now" "# kg-1" +state real qnifa_jan igj dyn_em 1 Z i1 "QNIFA_JAN" "num ice-friendly aerosol Jan" "# kg-1" +state real qnifa_feb igj dyn_em 1 Z i1 "QNIFA_FEB" "num ice-friendly aerosol Feb" "# kg-1" +state real qnifa_mar igj dyn_em 1 Z i1 "QNIFA_MAR" "num ice-friendly aerosol Mar" "# kg-1" +state real qnifa_apr igj dyn_em 1 Z i1 "QNIFA_APR" "num ice-friendly aerosol Apr" "# kg-1" +state real qnifa_may igj dyn_em 1 Z i1 "QNIFA_MAY" "num ice-friendly aerosol May" "# kg-1" +state real qnifa_jun igj dyn_em 1 Z i1 "QNIFA_JUN" "num ice-friendly aerosol Jun" "# kg-1" +state real qnifa_jul igj dyn_em 1 Z i1 "QNIFA_JUL" "num ice-friendly aerosol Jul" "# kg-1" +state real qnifa_aug igj dyn_em 1 Z i1 "QNIFA_AUG" "num ice-friendly aerosol Aug" "# kg-1" +state real qnifa_sep igj dyn_em 1 Z i1 "QNIFA_SEP" "num ice-friendly aerosol Sep" "# kg-1" +state real qnifa_oct igj dyn_em 1 Z i1 "QNIFA_OCT" "num ice-friendly aerosol Oct" "# kg-1" +state real qnifa_nov igj dyn_em 1 Z i1 "QNIFA_NOV" "num ice-friendly aerosol Nov" "# kg-1" +state real qnifa_dec igj dyn_em 1 Z i1 "QNIFA_DEC" "num ice-friendly aerosol Dec" "# kg-1" state real qntemp imj dyn_em 1 Z - "QNTEMP" "temporary var for time interp" "" state real qntemp2 ij dyn_em 1 - - "QNTEMP2" "temporary var2D for time interp" "" state real t_max_p ij dyn_em 1 - i0d "T_MAX_P" "temperature at max pressure" "K" @@ -313,9 +313,9 @@ state real mub_save ij dyn_em 1 - - state real mu0 ij dyn_em 1 - i1 "mu0" "initial dry mass in column" "Pa" state real mudf ij dyn_em 1 - - "mudf" "" "" state real muu ij dyn_em 1 X - "muu" -i1 real muus ij dyn_em 1 - +state real muus ij dyn_em 1 X - "muus" state real muv ij dyn_em 1 Y - "muv" -i1 real muvs ij dyn_em 1 - +state real muvs ij dyn_em 1 Y - "muvs" state real mut ij dyn_em 1 - - "mut" state real muts ij dyn_em 1 - - "muts" i1 real muave ij dyn_em 1 - @@ -338,8 +338,8 @@ state real p ikj dyn_em 1 - irh "p state real al ikj dyn_em 1 - r "al" "inverse perturbation density" "m3 kg-1" state real alt ikj dyn_em 1 - r "alt" "inverse density" "m3 kg-1" state real alb ikj dyn_em 1 - rdus "alb" "inverse base density" "m3 kg-1" -state real zx ikj dyn_em 1 X - " " " " " " -state real zy ikj dyn_em 1 Y - " " " " " " +state real zx ikj dyn_em 1 XZ - " " " " " " +state real zy ikj dyn_em 1 YZ - " " " " " " state real rdz ikj dyn_em 1 Z - " " " " " " state real rdzw ikj dyn_em 1 Z - " " " " " " state real pb ikj dyn_em 1 - irhdus "pb" "BASE STATE PRESSURE " "Pa" @@ -523,17 +523,16 @@ state real qnn ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QNCCN" "CCN Number concentration" "# kg(-1)" state real qnc ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QNCLOUD" "cloud water Number concentration" "# kg(-1)" -state real qnwfa ikjftb scalar 1 - \ - i0rhusdf=(bdy_interp:dt) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" -state real qnifa ikjftb scalar 1 - \ - i0rhusdf=(bdy_interp:dt) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" state real qvolg ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QVGRAUPEL" "Graupel Particle Volume" "m(3) kg(-1)" state real qvolh ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QVHAIL" "Hail Particle Volume" "m(3) kg(-1)" state real qrimef ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QRIMEF" "rime factor * qi" "kg kg-1" - +state real qir ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QIR" "Rime ice mass-1 mixing ratio" "kg kg(-1)" +state real qib ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QIB" "Rime ice volume-1 mixing ratio" "m(3) kg(-1)" state real - ikjftb dfi_scalar 1 - - - state real dfi_qndrop ikjftb dfi_scalar 1 - \ @@ -554,14 +553,16 @@ state real dfi_qnn ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNCC" "DFI CNN Number concentration" "# kg(-1)" state real dfi_qnc ikjftb dfi_scalar 1 - \ rusdf=(bdy_interp:dt) "DFI_QNCLOUD" "DFI Cloud Number concentration" "# kg(-1)" -state real dfi_qnwfa ikjftb dfi_scalar 1 - \ - i0rhusdf=(bdy_interp:dt) "DFI_QNWFA" "DFI water-friendly aerosol number con" "# kg(-1)" -state real dfi_qnifa ikjftb dfi_scalar 1 - \ - i0rhusdf=(bdy_interp:dt) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" state real dfi_qvolg ikjftb dfi_scalar 1 - \ rhusdf=(bdy_interp:dt) "DFI_QVGRAUPEL" "DFI Graupel Particle Volume" "m(3) kg(-1)" state real dfi_qvolh ikjftb dfi_scalar 1 - \ rhusdf=(bdy_interp:dt) "DFI_QVHAIL" "DFI Hail Particle Volume" "m(3) kg(-1)" +state real dfi_qir ikjftb dfi_scalar 1 - \ + rhusdf=(bdy_interp:dt) "DFI_QIR" "DFI Rime ice mass-1 mixing ratio" "kg kg(-1)" +state real dfi_qib ikjftb dfi_scalar 1 - \ + rhusdf=(bdy_interp:dt) "DFI_QIB" "DFI Rime ice volume-1 mixing ratio" "m(3) kg(-1)" +state real dfi_qke_adv ikjftb dfi_scalar 1 - \ + rusdf=(bdy_interp:dt) "dfi_qke_adv" "DFI twice TKE from MYNN" "m2 s-2" #----------------------------------------------------------------------------------------------------------------------------------------------------------------- @@ -730,6 +731,7 @@ state real ACGRDFLX ij misc 1 - rhdu state real SFCEXC ij misc 1 - r "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "m s-1" state real ACSNOW ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "ACSNOW" "ACCUMULATED SNOW" "kg m-2" +state real ACRUNOFF ij misc 1 - irhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "ACRUNOFF" "ACCUMULATED RUNOFF" "kg m-2" state real ACSNOM ij misc 1 - rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" state real SNOW ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOW" "SNOW WATER EQUIVALENT" "kg m-2" state real SNOWH ij misc 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "SNOWH" "PHYSICAL SNOW DEPTH" "m" @@ -800,11 +802,11 @@ state real SMR_URB3D ilj misc 1 Z rd=(interp_m state real TRL_URB3D ilj misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TRL_URB" "ROOF LAYER TEMPERATURE" "K" state real TBL_URB3D ilj misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TBL_URB" "WALL LAYER TEMPERATURE" "K" state real TGL_URB3D ilj misc 1 Z rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TGL_URB" "ROAD LAYER TEMPERATURE" "K" -state real SH_URB2D ij misc 1 - r "SH_URB" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" -state real LH_URB2D ij misc 1 - r "LH_URB" "LATENT HEAT FLUX FROM URBAN SFC" "W m{-2}" -state real G_URB2D ij misc 1 - r "G_URB" "GROUND HEAT FLUX INTO URBAN" "W m{-2}" -state real RN_URB2D ij misc 1 - r "RN_URB" "NET RADIATION ON URBAN SFC" "W m{-2}" -state real TS_URB2D ij misc 1 - r "TS_URB" "SKIN TEMPERATURE" "K" +state real SH_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "SH_URB" "SENSIBLE HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real LH_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "LH_URB" "LATENT HEAT FLUX FROM URBAN SFC" "W m{-2}" +state real G_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "G_URB" "GROUND HEAT FLUX INTO URBAN" "W m{-2}" +state real RN_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "RN_URB" "NET RADIATION ON URBAN SFC" "W m{-2}" +state real TS_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "TS_URB" "SKIN TEMPERATURE" "K" state real FRC_URB2D ij misc 1 - i10rd=(interp_fcnm)u=(copy_fcnm) "FRC_URB2D" "URBAN FRACTION" "dimensionless" state integer UTYPE_URB2D ij misc 1 - rd=(interp_fcnm)u=(copy_fcnm) "UTYPE_URB" "URBAN TYPE" "dimensionless" state real TRB_URB4D i{ulay}j misc 1 Z r "TRB_URB4D" "ROOF LAYER TEMPERATURE" "K" @@ -884,8 +886,8 @@ state real WSTAR_YSU ij misc 1 - - "WSTAR state real DELTA_YSU ij misc 1 - - "DELTA_YSU" "entrainment layer depth from ysupbl" "m" # MYJ PBL variables; GBM PBL: EXCH_H, EXCH_M -state real EXCH_H ikj misc 1 Z r "EXCH_H" "SCALAR EXCHANGE COEFFICIENTS " -state real EXCH_M ikj misc 1 Z r "EXCH_M" "EXCHANGE COEFFICIENTS " +state real EXCH_H ikj misc 1 Z r "EXCH_H" "SCALAR EXCHANGE COEFFICIENTS " "m2 s-1" +state real EXCH_M ikj misc 1 Z r "EXCH_M" "EXCHANGE COEFFICIENTS " "m2 s-1" state real CT ij misc 1 - r "CT" "COUNTERGRADIENT TERM" "K" state real THZ0 ij misc 1 - r "THZ0" "POTENTIAL TEMPERATURE AT ZNT" "K" state real Z0 ij misc 1 - r "Z0" "Background ROUGHNESS LENGTH" "m" @@ -1036,7 +1038,7 @@ state real acfrcv ij misc 1 - - state integer ncfrcv ij misc 1 - - # new rad variables -state real o3rad ikj misc 1 - irdf=(p2c) "o3rad" "RADIATION 3D OZONE" "ppmv" +state real o3rad ikj misc 1 - irh "o3rad" "RADIATION 3D OZONE" "ppmv" # incoming optical depth derived from aerosol data state real aerodm i{lsa}jm{ty} misc 1 - - - @@ -1158,7 +1160,7 @@ state real f ij misc 1 - i012rhdu=(co state real e ij misc 1 - i012rhdu=(copy_fcnm) "e" "Coriolis cosine latitude term" "s-1" state real sina ij misc 1 - i012rhdu=(copy_fcnm) "SINALPHA" "Local sine of map rotation" "" state real cosa ij misc 1 - i012rhdu=(copy_fcnm) "COSALPHA" "Local cosine of map rotation" "" -state real ht ij misc 1 - i012rhdus "HGT" "Terrain Height" "m" +state real ht ij misc 1 - i012rh056dus "HGT" "Terrain Height" "m" state real ht_fine ij misc 1 - - "HGT_FINE" "Fine Terrain Height" "m" state real ht_int ij misc 1 - - "HGT_INT" "Terrain Height Horizontally Interpolated" "m" state real ht_input ij misc 1 - - "HGT_INPUT" "Terrain Height from FG Input File" "m" @@ -1190,6 +1192,7 @@ state logical just_read_auxinput4 - misc - - r "we_jus state logical just_read_boundary - misc - - r "we_just_d01_LBC" "1=BOUNDARY ALARM RINGING, 0=NO BOUNDARY ALARM" "-" state real mf_fft - misc - - r "mf_fft" "Mass point map factor at equatorward FFT filter location" "" state real p_top - misc - - irh "p_top" "PRESSURE TOP OF THE MODEL" "Pa" +state logical got_var_sso - misc - - i02r "got_var_sso" "whether VAR_SSO was included in WPS output (beginning V3.4)" "" #BSINGH - Adding all these variables for CuP scheme[any var before t00] state real lat_ll_t - dyn_em - - ir "lat_ll_t" "latitude lower left, temp point" "degrees" @@ -1247,28 +1250,28 @@ state real SSWUP ij misc 1 - h "S # Other physics variables -state real RUSHTEN ikj misc 1 - r "RUSHTEN" "COUPLED X WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "Pa m s-2" -state real RVSHTEN ikj misc 1 - r "RVSHTEN" "COUPLED Y WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "Pa m s-2" -state real RTHSHTEN ikj misc 1 - r "RTHSHTEN" "COUPLED THETA TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "Pa K s-1" -state real RQVSHTEN ikj misc 1 - r "RQVSHTEN" "COUPLED Q_V TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQRSHTEN ikj misc 1 - r "RQRSHTEN" "COUPLED Q_R TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQCSHTEN ikj misc 1 - r "RQCSHTEN" "COUPLED Q_C TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQSSHTEN ikj misc 1 - r "RQSSHTEN" "COUPLED Q_S TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQISHTEN ikj misc 1 - r "RQISHTEN" "COUPLED Q_I TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQGSHTEN ikj misc 1 - r "RQGSHTEN" "COUPLED Q_G TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQCNSHTEN ikj misc 1 - r "RQCNSHTEN" "COUPLED Q_CN TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQINSHTEN ikj misc 1 - r "RQINSHTEN" "COUPLED Q_IN TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "Pa kg kg-1 s-1" - -state real RUCUTEN ikj misc 1 - r "RUCUTEN" "COUPLED X WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION" "Pa m s-2" -state real RVCUTEN ikj misc 1 - r "RVCUTEN" "COUPLED Y WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION" "Pa m s-2" -state real RTHCUTEN ikj misc 1 - r "RTHCUTEN" "COUPLED THETA TENDENCY DUE TO CUMULUS SCHEME" "Pa K s-1" -state real RQVCUTEN ikj misc 1 - r "RQVCUTEN" "COUPLED Q_V TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQRCUTEN ikj misc 1 - r "RQRCUTEN" "COUPLED Q_R TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQCCUTEN ikj misc 1 - r "RQCCUTEN" "COUPLED Q_C TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQSCUTEN ikj misc 1 - r "RQSCUTEN" "COUPLED Q_S TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQICUTEN ikj misc 1 - r "RQICUTEN" "COUPLED Q_I TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQCNCUTEN ikj misc 1 - r "RQCNCUTEN" "COUPLED Q_CN TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" -state real RQINCUTEN ikj misc 1 - r "RQINCUTEN" "COUPLED Q_IN TENDENCY DUE TO CUMULUS SCHEME" "Pa kg kg-1 s-1" +state real RUSHTEN ikj misc 1 - r "RUSHTEN" "X WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "m s-2" +state real RVSHTEN ikj misc 1 - r "RVSHTEN" "Y WIND TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "m s-2" +state real RTHSHTEN ikj misc 1 - r "RTHSHTEN" "THETA TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "K s-1" +state real RQVSHTEN ikj misc 1 - r "RQVSHTEN" "Q_V TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "kg kg-1 s-1" +state real RQRSHTEN ikj misc 1 - r "RQRSHTEN" "Q_R TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "kg kg-1 s-1" +state real RQCSHTEN ikj misc 1 - r "RQCSHTEN" "Q_C TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "kg kg-1 s-1" +state real RQSSHTEN ikj misc 1 - r "RQSSHTEN" "Q_S TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "kg kg-1 s-1" +state real RQISHTEN ikj misc 1 - r "RQISHTEN" "Q_I TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "kg kg-1 s-1" +state real RQGSHTEN ikj misc 1 - r "RQGSHTEN" "Q_G TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "kg kg-1 s-1" +state real RQCNSHTEN ikj misc 1 - r "RQCNSHTEN" "Q_CN TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "# kg-1 s-1" +state real RQINSHTEN ikj misc 1 - r "RQINSHTEN" "Q_IN TENDENCY DUE TO SHALLOW CUMULUS SCHEME" "# kg-1 s-1" + +state real RUCUTEN ikj misc 1 - r "RUCUTEN" "X WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION" "m s-2" +state real RVCUTEN ikj misc 1 - r "RVCUTEN" "Y WIND TENDENCY DUE TO CUMULUS PARAMETERIZATION" "m s-2" +state real RTHCUTEN ikj misc 1 - r "RTHCUTEN" "THETA TENDENCY DUE TO CUMULUS SCHEME" "K s-1" +state real RQVCUTEN ikj misc 1 - r "RQVCUTEN" "Q_V TENDENCY DUE TO CUMULUS SCHEME" "kg kg-1 s-1" +state real RQRCUTEN ikj misc 1 - r "RQRCUTEN" "Q_R TENDENCY DUE TO CUMULUS SCHEME" "kg kg-1 s-1" +state real RQCCUTEN ikj misc 1 - r "RQCCUTEN" "Q_C TENDENCY DUE TO CUMULUS SCHEME" "kg kg-1 s-1" +state real RQSCUTEN ikj misc 1 - r "RQSCUTEN" "Q_S TENDENCY DUE TO CUMULUS SCHEME" "kg kg-1 s-1" +state real RQICUTEN ikj misc 1 - r "RQICUTEN" "Q_I TENDENCY DUE TO CUMULUS SCHEME" "kg kg-1 s-1" +state real RQCNCUTEN ikj misc 1 - r "RQCNCUTEN" "Q_CN TENDENCY DUE TO CUMULUS SCHEME" "# kg-1 s-1" +state real RQINCUTEN ikj misc 1 - r "RQINCUTEN" "Q_IN TENDENCY DUE TO CUMULUS SCHEME" "# kg-1 s-1" state real W0AVG ikj misc 1 - r "W0AVG" "AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME" "m s-1" state real RAINC ij misc 1 - rhdu "RAINC" "ACCUMULATED TOTAL CUMULUS PRECIPITATION" "mm" @@ -1289,6 +1292,11 @@ state real SNOWNCV ij misc 1 - r "S state real GRAUPELNCV ij misc 1 - r "GRAUPELNCV" "TIME-STEP NONCONVECTIVE GRAUPEL" "mm" state real HAILNCV ij misc 1 - r "HAILNCV" "TIME-STEP NONCONVECTIVE HAIL" "mm" state real refl_10cm ikj dyn_em 1 - hdu "refl_10cm" "Radar reflectivity (lamda = 10 cm)" "dBZ" +state real th_old ikj misc 1 - rusd "TH_OLD" "Old Value of Th" "K" +state real qv_old ikj misc 1 - rusd "QV_OLD" "Old Value of qv" "kg kg-1" +state real vmi3d ikj misc 1 - hdu "v_ice" "Mass-weighted ice fallspeed" "m s-1" +state real di3d ikj misc 1 - hdu "d_ice" "Mass-weighted mean ice size" "m" +state real rhopo3d ikj misc 1 - hdu "rho_ice" "Mass-weighted mean ice density" "kg m-3" # LIGHTNING NUDGING #state real ltg_dat ij misc 1 - r "ltg_dat" "gridded lightning data" "Flash per xkm x xkm per LAD_INT sec" # END LIGHTNING NUDGING @@ -1345,7 +1353,7 @@ state real RQVFTEN ikj misc 1 - r "R state integer STEPCU - misc 1 - r "STEPCU" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CONVECTION CALLS" "" -state real RTHRATEN ikj misc 1 - rd "RTHRATEN" "COUPLED THETA TENDENCY DUE TO RADIATION" "Pa K s-1" +state real RTHRATEN ikj misc 1 - rd "RTHRATEN" "THETA TENDENCY DUE TO RADIATION" "K s-1" state real RTHRATENLW ikj misc 1 - r "RTHRATLW" "UNCOUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION" "K s-1" state real RTHRATENSW ikj misc 1 - r "RTHRATSW" "UNCOUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION" "K s-1" state real CLDFRA ikj misc 1 - rh "CLDFRA" "CLOUD FRACTION" "" @@ -1476,9 +1484,9 @@ state real OLR ij misc 1 - rh " # these next 2 are for the HFSoLE/PET demo; writing these to auxhist1 output over MCEL for coupling # with wave model, only if compiled with -DMCELIO, JM 2003/05/29 state real XLAT_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLAT_U" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" -state real XLONG_U ij dyn_em 1 X i012rh01du=(copy_fcnm) "XLONG_U" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLONG_U ij dyn_em 1 X i012rh01d=(interp_fcn_blint_ll:xlat_u,input_from_file)u=(copy_fcnm) "XLONG_U" "LONGITUDE, WEST IS NEGATIVE" "degree_east" state real XLAT_V ij dyn_em 1 Y i012rh01du=(copy_fcnm) "XLAT_V" "LATITUDE, SOUTH IS NEGATIVE" "degree_north" -state real XLONG_V ij dyn_em 1 Y i012rh01du=(copy_fcnm) "XLONG_V" "LONGITUDE, WEST IS NEGATIVE" "degree_east" +state real XLONG_V ij dyn_em 1 Y i012rh01d=(interp_fcn_blint_ll:xlat_v,input_from_file)u=(copy_fcnm) "XLONG_V" "LONGITUDE, WEST IS NEGATIVE" "degree_east" state real ALBEDO ij misc 1 - rh "ALBEDO" "ALBEDO" state real CLAT ij misc 1 - i012rhdu=(copy_fcnm) "CLAT" "COMPUTATIONAL GRID LATITUDE, SOUTH IS NEGATIVE" "degree_north" state real ALBBCK ij misc 1 - i0124rh "ALBBCK" "BACKGROUND ALBEDO" "" @@ -1489,13 +1497,13 @@ state real NOAHRES ij misc 1 - h "N state real CLDEFI ij misc 1 - r "CLDEFI" "precipitation efficiency in BMJ SCHEME" "" state integer STEPRA - misc 1 - r "STEPRA" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN RADIATION CALLS" "" -state real RUBLTEN ikj misc 1 - r "RUBLTEN" "COUPLED X WIND TENDENCY DUE TO PBL PARAMETERIZATION" "Pa m s-2" -state real RVBLTEN ikj misc 1 - r "RVBLTEN" "COUPLED Y WIND TENDENCY DUE TO PBL PARAMETERIZATION" "Pa m s-2" -state real RTHBLTEN ikj misc 1 - r "RTHBLTEN" "COUPLED THETA TENDENCY DUE TO PBL PARAMETERIZATION" "Pa K s-1" -state real RQVBLTEN ikj misc 1 - r "RQVBLTEN" "COUPLED Q_V TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" -state real RQCBLTEN ikj misc 1 - r "RQCBLTEN" "COUPLED Q_C TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" -state real RQIBLTEN ikj misc 1 - r "RQIBLTEN" "COUPLED Q_I TENDENCY DUE TO PBL PARAMETERIZATION" "Pa kg kg-1 s-1" -state real RQNIBLTEN ikj misc 1 - r "RQNIBLTEN" "COUPLED Q_NI TENDENCY DUE TO PBL PARAMETERIZATION" "Pa # kg-1 s-1" +state real RUBLTEN ikj misc 1 - r "RUBLTEN" "X WIND TENDENCY DUE TO PBL PARAMETERIZATION" "m s-2" +state real RVBLTEN ikj misc 1 - r "RVBLTEN" "Y WIND TENDENCY DUE TO PBL PARAMETERIZATION" "m s-2" +state real RTHBLTEN ikj misc 1 - r "RTHBLTEN" "THETA TENDENCY DUE TO PBL PARAMETERIZATION" "K s-1" +state real RQVBLTEN ikj misc 1 - r "RQVBLTEN" "Q_V TENDENCY DUE TO PBL PARAMETERIZATION" "kg kg-1 s-1" +state real RQCBLTEN ikj misc 1 - r "RQCBLTEN" "Q_C TENDENCY DUE TO PBL PARAMETERIZATION" "kg kg-1 s-1" +state real RQIBLTEN ikj misc 1 - r "RQIBLTEN" "Q_I TENDENCY DUE TO PBL PARAMETERIZATION" "kg kg-1 s-1" +state real RQNIBLTEN ikj misc 1 - r "RQNIBLTEN" "Q_NI TENDENCY DUE TO PBL PARAMETERIZATION" "# kg-1 s-1" # For Noah UA changes state real flx4 ij - 1 - - "FLX4" "sensible heat from canopy" "W m{-2}" @@ -1518,7 +1526,7 @@ state real sneqvoxy ij - 1 - i02rhd=(interp_mask_fiel state real alboldxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "albold" "snow albedo at last timestep" "-" state real qsnowxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "qsnowxy" "snowfall on the ground" "mm/s" state real wslakexy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "wslake" "lake water storage" "mm" -state real zwtxy ij - 1 - i027rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "zwt" "water table depth" "m" +state real zwtxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "zwt" "water table depth" "m" state real waxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "wa" "water in the acquifer" "mm" state real wtxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "wt" "groundwater storage" "mm" state real tsnoxy i{snly}j - 1 Z i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "tsno" "snow temperature" "K" @@ -1529,8 +1537,6 @@ state real lfmassxy ij - 1 - i02rhd=(interp_mask_fiel state real rtmassxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "rtmass" "mass of fine roots" "g/m2" state real stmassxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "stmass" "stem mass" "g/m2" state real woodxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "wood" "mass of wood" "g/m2" -state real grainxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "grain" "mass of grain" "g/m2" -state real gddxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "gdd" "growing degree days" "" state real stblcpxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "stblcp" "stable carbon pool" "g/m2" state real fastcpxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "fastcp" "short-lived carbon" "g/m2" state real xsaixy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "xsai" "stem area index" "-" @@ -1581,22 +1587,34 @@ state real chucxy ij - 1 - i02rhd=(interp_mask_fiel state real chv2xy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "chv2" "leaf exchange coefficient" "m/s" state real chb2xy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "chb2" "under canopy exchange coefficient" "m/s" state real chstarxy ij - 1 - i02rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "chstar" "dummy exchange coefficient" "m/s" -state real SMOISEQ ilj - 1 Z r "SMOISEQ" "EQ. SOIL MOISTURE" "m3 m-3" -state real smcwtdxy ij - 1 - rh "smcwtd" "deep soil moisture " "m3 m-3" -state real rechxy ij - 1 - h "rech" "water table recharge" "mm" -state real deeprechxy ij - 1 - r "deeprech" "deep water table recharge" "mm" -state real fdepthxy ij - 1 - i027r "fdepth" "e-folding depth for transmissivity " "m" -state real areaxy ij - 1 - r "area" "area of grid boxes" "m2" -state real rivercondxy ij - 1 - i027r "rivercond" "river conductance" "Kg m s-1" -state real riverbedxy ij - 1 - i027r "riverbed" "river bed depth" "m" -state real eqzwt ij - 1 - i027r "eqzwt" "equilibrium water table depth " "m" -state real pexpxy ij - 1 - i027r "pexp" "exponent for river conductance" "Kg m s-1" -state real qrfxy ij - 1 - r "qrf" "baseflow " "m" -state real qrfsxy ij - 1 - h "qrfs" "sum baseflow " "mm" -state real qspringxy ij - 1 - r "qspring" "seeping water " "m" -state real qspringsxy ij - 1 - h "qsprings" "sum seeping water " "mm" -state real qslatxy ij - 1 - h "qslat" "sum lateral flow " "mm" -state integer STEPWTD - misc 1 - r "STEPWTD" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN WTD CALLS" "" +state real SMOISEQ ilj - 1 Z r "SMOISEQ" "EQ. SOIL MOISTURE" "m3 m-3" +state real smcwtdxy ij - 1 - rh "smcwtd" "deep soil moisture " "m3 m-3" +state real rechxy ij - 1 - h "rech" "water table recharge" "mm" +state real deeprechxy ij - 1 - r "deeprech" "deep water table recharge" "mm" +state real areaxy ij - 1 - r "area" "area of grid boxes" "m2" +state real qrfxy ij - 1 - r "qrf" "baseflow " "m" +state real qrfsxy ij - 1 - h "qrfs" "sum baseflow " "mm" +state real qspringxy ij - 1 - r "qspring" "seeping water " "m" +state real qspringsxy ij - 1 - h "qsprings" "sum seeping water " "mm" +state real qslatxy ij - 1 - h "qslat" "sum lateral flow " "mm" +state integer STEPWTD - misc 1 - r "STEPWTD" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN WTD CALLS" "" +state real pexpxy ij - 1 - r "pexp" "exponent for river conductance" "Kg m s-1" +state real rivercondxy ij - 1 - r "rivercond" "river conductance" "Kg m s-1" +state real fdepthxy ij - 1 - i012rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "FDEPTH" "e-folding depth for transmissivity " "m" +state real eqzwt ij - 1 - i012rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "EQZWT" "equilibrium water table depth " "m" +state real rechclim ij - 1 - i012rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "RECHCLIM" "equilibrium recharge rate " "mm" +state real riverbedxy ij - 1 - i012rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "RIVERBED" "river bed depth" "m" + +# Crop model only + +state real grainxy ij - 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "grain" "mass of grain" "g/m2" +state real gddxy ij - 1 - i012rhd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "gdd" "growing degree days" "" +state real croptype i{crop}j - 1 Z i012rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "croptype" "crop type" "fraction" +state real planting ij - 1 - i012rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "planting" "planting date" "julian day" +state real harvest ij - 1 - i012rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "harvest" "harvest date" "julian day" +state real season_gdd ij - 1 - i012rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "season_gdd" "growing season GDD" "C" +state integer cropcat ij - 1 - rh "cropcat" "dominant crop category" "category" +state integer pgsxy ij - 1 - rh "pgs" "pgs" "" # For Noah-Mosaic danli @@ -1672,7 +1690,7 @@ state real TMN ij misc 1 - i012rhd=(int state real TYR ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TYR" "ANNUAL MEAN SFC TEMPERATURE" "K" state real TYRA ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TYRA" "ACCUMULATED YEARLY SFC TEMPERATURE FOR CURRENT YEAR" "K" state real TDLY ij misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TDLY" "ACCUMULATED DAILY SFC TEMPERATURE FOR CURRENT DAY" "K" -state real TLAG i&j misc 1 - d=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TLAG" "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS" "K" +state real TLAG i&j misc 1 - rd=(interp_mask_field:lu_index,iswater)u=(copy_fcnm) "TLAG" "DAILY MEAN SFC TEMPERATURE OF PRIOR DAYS" "K" state integer NYEAR - misc 1 - r "NYEAR" "ACCUM DAYS IN A YEAR" "" state real NDAY - misc 1 - r "NDAY" "ACCUM TIMESTEPS IN A DAY" "" state real XLAND ij misc 1 - i02rhd=(interp_fcnm_imask)u=(copy_fcnm) "XLAND" "LAND MASK (1 FOR LAND, 2 FOR WATER)" "" @@ -1741,11 +1759,11 @@ state integer save_topo_from_real - dyn_em 1 - i02rh "sa ## FDDA variables state integer STEPFG - misc 1 - r "STEPFG" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN FDDA GRID CALLS" "" -state real RUNDGDTEN ikj misc 1 X r "RUNDGDTEN" "COUPLED X WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" -state real RVNDGDTEN ikj misc 1 Y r "RVNDGDTEN" "COUPLED Y WIND TENDENCY DUE TO FDDA GRID NUDGING" "Pa m s-2" -state real RTHNDGDTEN ikj misc 1 - r "RTHNDGDTEN" "COUPLED THETA TENDENCY DUE TO FDDA GRID NUDGING" "Pa K s-1" -state real RPHNDGDTEN ikj misc 1 - r "RPHNDGDTEN" "COUPLED GEOPOTENTIAL TENDENCY DUE TO FDDA GRID NUDGING" "Pa m2 s-3" -state real RQVNDGDTEN ikj misc 1 - r "RQVNDGDTEN" "COUPLED Q_V TENDENCY DUE TO FDDA GRID NUDGING" "Pa kg kg-1 s-1" +state real RUNDGDTEN ikj misc 1 X r "RUNDGDTEN" "X WIND TENDENCY DUE TO FDDA GRID NUDGING" "m s-2" +state real RVNDGDTEN ikj misc 1 Y r "RVNDGDTEN" "Y WIND TENDENCY DUE TO FDDA GRID NUDGING" "m s-2" +state real RTHNDGDTEN ikj misc 1 - r "RTHNDGDTEN" "THETA TENDENCY DUE TO FDDA GRID NUDGING" "K s-1" +state real RPHNDGDTEN ikj misc 1 - r "RPHNDGDTEN" "GEOPOTENTIAL TENDENCY DUE TO FDDA GRID NUDGING" "m2 s-3" +state real RQVNDGDTEN ikj misc 1 - r "RQVNDGDTEN" "Q_V TENDENCY DUE TO FDDA GRID NUDGING" "kg kg-1 s-1" state real RMUNDGDTEN ij misc 1 - r "RMUNDGDTEN" "MU TENDENCY DUE TO FDDA GRID NUDGING" "Pa s-1" state real - ikjf fdda3d 1 - - - state real U_NDG_NEW ikjf fdda3d 1 X i{10}r "U_NDG_NEW" "NEW X WIND FOR FDDA GRID NUDGING" "m s-1" @@ -1889,7 +1907,7 @@ rconfig integer end_day namelist,time_control max_domains rconfig integer end_hour namelist,time_control max_domains 12 irh "end_hour" "2 DIGIT HOUR OF THE DAY OF END OF MODEL, 0-23" "HOURS" rconfig integer end_minute namelist,time_control max_domains 00 irh "end_minute" "2 DIGIT MINUTE OF THE HOUR OF END OF MODEL, 0-59" "MINUTES" rconfig integer end_second namelist,time_control max_domains 00 irh "end_second" "2 DIGIT SECOND OF THE MINUTE OF END OF MODEL, 0-59" "SECONDS" -rconfig integer interval_seconds namelist,time_control 1 43200 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" +rconfig integer interval_seconds namelist,time_control 1 10800 irh "interval_seconds" "SECONDS BETWEEN ANALYSIS AND BOUNDARY PERIODS" "SECONDS" rconfig logical input_from_file namelist,time_control max_domains .false. irh "input_from_file" "T/F INPUT FOR THIS DOMAIN FROM A SEPARATE INPUT FILE" "" rconfig integer fine_input_stream namelist,time_control max_domains 0 irh "fine_input_stream" "0 THROUGH 11, WHAT INPUT STREAM IS FINE GRID IC FROM" "" rconfig logical input_from_hires namelist,time_control max_domains .false. irh "input_from_hires" "T/F INPUT FOR THIS DOMAIN FROM USGS HI RES TERRAIN" "" @@ -2072,7 +2090,7 @@ rconfig integer ocean_levels namelist,domains 1 30 i rconfig real ocean_z namelist,domains max_ocean -1 - "vertical profile of layer depths for ocean" "m" rconfig real ocean_t namelist,domains max_ocean -1 - "vertical profile of ocean temps" "K" rconfig real ocean_s namelist,domains max_ocean -1 - "vertical profile of salinity" -rconfig integer num_traj namelist,domains 1 25 irh "num_traj" "#of trajectory" "" +rconfig integer num_traj namelist,domains 1 1000 irh "num_traj" "#of trajectory" "" # variable for time series of vertical profile of U, V, Theta, GHT,a nd QVAPOR rconfig integer max_ts_level namelist,domains 1 15 - "max_ts_level" "Highest model level for time series output" @@ -2095,9 +2113,10 @@ rconfig real vmax_ratio namelist,tc max_bogus -999. i rconfig real rankine_lid namelist,tc 1 -999. irh "top pressure limit for the tc bogus scheme" # Physics +rconfig character physics_suite namelist,physics 1 "none" rh "Physics suite selection" "physics suite to use for all domains: CONUS, tropical, or none" "character string" rconfig logical force_read_thompson namelist,physics 1 .false. rconfig logical write_thompson_tables namelist,physics 1 .true. -rconfig integer mp_physics namelist,physics max_domains 0 irh "mp_physics" "" "" +rconfig integer mp_physics namelist,physics max_domains -1 irh "mp_physics" "" "" #rconfig integer milbrandt_ccntype namelist,physics max_domains 0 rh "milbrandt select maritime(1)/continental(2)" "" "" rconfig real nssl_cccn namelist,physics max_domains 0.5e9 rh "Base CCN concentration for NSSL microphysics" "" "" rconfig real nssl_alphah namelist,physics max_domains 0 rh "Graupel PSD shape paramter" "" "" @@ -2129,13 +2148,13 @@ rconfig real aitken_mode namelist,physics 1 30 rconfig real coarse_mode namelist,physics 1 0.2e6 rh "coarse_mode" "" "" rconfig integer do_radar_ref namelist,physics 1 0 rh "compute radar reflectivity for a number of schemes" "" "" rconfig integer compute_radar_ref derived 1 0 - "compute_radar_ref" "0/1 flag: compute radar reflectivity, either do_radar_ref=1 .or. (milbrandt or NSSL schemes)" -rconfig integer ra_lw_physics namelist,physics max_domains 0 rh "ra_lw_physics" "" "" -rconfig integer ra_sw_physics namelist,physics max_domains 0 rh "ra_sw_physics" "" "" +rconfig integer ra_lw_physics namelist,physics max_domains -1 rh "ra_lw_physics" "" "" +rconfig integer ra_sw_physics namelist,physics max_domains -1 rh "ra_sw_physics" "" "" rconfig real radt namelist,physics max_domains 0 h "RADT" "" "" rconfig real naer namelist,physics max_domains 1e9 rh "NAER" "" "" -rconfig integer sf_sfclay_physics namelist,physics max_domains 0 rh "sf_sfclay_physics" "" "" -rconfig integer sf_surface_physics namelist,physics max_domains 0 rh "sf_surface_physics" "" "" -rconfig integer bl_pbl_physics namelist,physics max_domains 0 rh "bl_pbl_physics" "" "" +rconfig integer sf_sfclay_physics namelist,physics max_domains -1 rh "sf_sfclay_physics" "" "" +rconfig integer sf_surface_physics namelist,physics max_domains -1 rh "sf_surface_physics" "" "" +rconfig integer bl_pbl_physics namelist,physics max_domains -1 rh "bl_pbl_physics" "" "" rconfig integer bl_mynn_tkebudget namelist,physics max_domains 0 rh "bl_mynn_tkebudget" "" "" rconfig integer ysu_topdown_pblmix namelist,physics 1 0 rh "ysu_topdown_pblmix" "" "" rconfig integer shinhong_tke_diag namelist,physics max_domains 0 rh "shinhong_tke_diag" "" "" @@ -2152,7 +2171,7 @@ rconfig integer icloud_bl namelist,physics 1 1 rconfig integer mfshconv namelist,physics max_domains 1 rh "mfshconv" "To activate mass flux scheme with qnse, 1=true or 0=false" "" rconfig integer sf_urban_physics namelist,physics max_domains 0 rh "sf_urban_physics" "activate urban model 0=no, 1=Noah_UCM 2=BEP_UCM" "" rconfig real BLDT namelist,physics max_domains 0 h "BLDT" "" "" -rconfig integer cu_physics namelist,physics max_domains 0 rh "cu_physics" "" "" +rconfig integer cu_physics namelist,physics max_domains -1 rh "cu_physics" "" "" rconfig integer shcu_physics namelist,physics max_domains 0 rh "shcu_physics" "" "" rconfig integer cu_diag namelist,physics max_domains 0 rh "cu_diag" "additional t-averaged stuff for cuphys" "" rconfig integer kf_edrates namelist,physics max_domains 0 rh "kf_edrates" "output entrainment/detrainment rates and convective timescale for KF schemes" "" @@ -2210,8 +2229,8 @@ rconfig integer paerlev namelist,physics 1 1 rconfig integer cam_abs_dim1 namelist,physics 1 1 - "cam_abs_dim1" "dimension for absnxt in CAM radiation" "" rconfig integer cam_abs_dim2 namelist,physics 1 1 - "cam_abs_dim2" "dimension for abstot in CAM radiation" "" rconfig integer lagday namelist,physics 1 150 - "lagday" "" "" -rconfig integer no_src_types namelist,physics 1 1 - "no_src_types" "Number of aerosoal types from EC (6)" "" -rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosoal optical depth data levels from EC (12)" "" +rconfig integer no_src_types namelist,physics 1 1 - "no_src_types" "Number of aerosol types from EC. (6 - Tegan aerosols)" "" +rconfig integer alevsiz namelist,physics 1 1 - "alevsiz" "Number of aerosol optical depth data levels from EC (12)" "" rconfig integer o3input namelist,physics 1 2 - "o3input" "ozone input for RRTMG for CG domain: original = 0; CAM ozone = 2" "" rconfig integer aer_opt namelist,physics 1 0 - "aer_opt" "aerosol input option for radiation" "" rconfig integer swint_opt namelist,physics 1 0 - "swint_opt" "interpolation option for sw radiation" "" @@ -2236,11 +2255,12 @@ rconfig real minDeepFreq namelist,physics max_domains 1 rconfig real minShallowFreq namelist,physics max_domains 1 - "Minimum frequency required for shallow convection" rconfig integer shcu_aerosols_opt namelist,physics max_domains 0 - "aerosols in shcu: 0=none, 2=prognostic " "" -rconfig integer ICLOUD_CU derived 1 0 - "ICLOUD_CU" "" "" +rconfig integer ICLOUD_CU derived max_domains 0 - "ICLOUD_CU" "" "" rconfig integer pxlsm_smois_init namelist,physics max_domains 1 irh "PXLSM_SMOIS_INIT" "Soil moisture initialization option 0-From analysis 1-From MAVAIL" "" rconfig integer omlcall namelist,physics 1 0 h "omlcall" "temporary holder to allow checking for new name: oml_opt" rconfig integer sf_ocean_physics namelist,physics 1 0 h "sf_ocean_physics" "activate ocean model 0=no, 1=1d mixed layer, 2=3D PWP" "" rconfig integer traj_opt namelist,physics 1 0 h "traj_opt" "activate trajectory calculation 0=no, 1=on" "" +rconfig logical dm_has_traj namelist,physics max_domains .false. rh "has_traj" "activate trajectory calculation per domain" "" rconfig integer tracercall namelist,physics 1 0 h "tracercall" "activate tracer calculation 0=no, 1=on" "" rconfig real OMDT namelist,physics 1 1 h "OMDT" "Timestep of ocean model" "s" rconfig real oml_hml0 namelist,physics 1 50 h "oml_hml0" "oml initial mixed layer depth value" "m" @@ -2268,6 +2288,7 @@ rconfig real mp_tend_lim namelist,physics 1 10 rconfig real prec_acc_dt namelist,physics max_domains 0. h "prec_acc_dt" "bucket reset time interval between outputs for cumulus or grid scale precipitation" "minutes" rconfig integer prec_acc_opt derived 1 0 - "prec_acc_opt" "option to output precip in a time window" "" rconfig integer bucketr_opt derived 1 0 - "bucketr_opt" "option to output water accum based on bucket_mm " "" +rconfig integer bucketf_opt derived 1 0 - "bucketf_opt" "option to output radiation accum based on bucket_J " "" rconfig integer process_time_series derived 1 0 - "process_time_series" "0=no, 1=yes" "" @@ -2287,7 +2308,7 @@ rconfig integer hail_opt namelist,physics 1 0 rconfig integer dveg namelist,noah_mp 1 4 h "dveg" "dynamic vegetation (1 -> off ; 2 -> on)" "" rconfig integer opt_crs namelist,noah_mp 1 1 h "opt_crs" "canopy stomatal resistance (1-> Ball-Berry; 2->Jarvis)" "" rconfig integer opt_btr namelist,noah_mp 1 1 h "opt_btr" "soil moisture factor for stomatal resistance (1-> Noah; 2-> CLM; 3-> SSiB)" "" -rconfig integer opt_run namelist,noah_mp 1 1 h "opt_run" "runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS)" "" +rconfig integer opt_run namelist,noah_mp 1 3 h "opt_run" "runoff and groundwater (1->SIMGM; 2->SIMTOP; 3->Schaake96; 4->BATS)" "" rconfig integer opt_sfc namelist,noah_mp 1 1 h "opt_sfc" "surface layer drag coeff (CH & CM) (1->M-O; 2->Chen97)" "" rconfig integer opt_frz namelist,noah_mp 1 1 h "opt_frz" "supercooled liquid water (1-> NY06; 2->Koren99)" "" rconfig integer opt_inf namelist,noah_mp 1 1 h "opt_inf" "frozen soil permeability (1-> NY06; 2->Koren99)" "" @@ -2406,7 +2427,7 @@ rconfig integer num_force_layers namelist,scm 1 8 rh rconfig integer scm_lu_index namelist,scm 1 2 rh "scm_lu_index" "SCM landuse index" "" rconfig integer scm_isltyp namelist,scm 1 4 rh "scm_isltyp" "SCM soil category" "" rconfig real scm_vegfra namelist,scm 1 0.5 rh "scm_vegfra" "SCM vegetation fraction" "" -rconfig integer scm_canwat namelist,scm 1 0.0 rh "scm_canwat" "SCM canopy water" "kg m-2" +rconfig real scm_canwat namelist,scm 1 0.0 rh "scm_canwat" "SCM canopy water" "kg m-2" rconfig real scm_lat namelist,scm 1 36.605 rh "scm_lat" "SCM latitude" "degrees" rconfig real scm_lon namelist,scm 1 -97.485 rh "scm_lon" "SCM longitude" "degrees" rconfig logical scm_th_t_tend namelist,scm 1 .true. rh "scm_th_t_adv" "Turn on large scale theta tendency in SCM" "" @@ -2442,6 +2463,7 @@ rconfig integer km_opt_dfi namelist,dynamics max_domains 1 rconfig integer damp_opt namelist,dynamics 1 0 irh "damp_opt" "" "" rconfig integer rad_nudge namelist,dynamics 1 0 irh "rad_nudge" "" "" rconfig integer gwd_opt namelist,dynamics 1 0 irh "gwd_opt" "" "" +rconfig real max_rot_angle_gwd namelist,dynamics 1 22.5 irh "max_rot_angle_gwd" "max projection rotation angle permitted for gwd_opt=1" "" rconfig real zdamp namelist,dynamics max_domains 5000. h "zdamp" "" "" rconfig real dampcoef namelist,dynamics max_domains 0. h "dampcoef" "" "" rconfig real khdif namelist,dynamics max_domains 0 h "khdif" "" "" @@ -2566,6 +2588,7 @@ rconfig integer map_proj derived max_domains rconfig integer use_wps_input derived 1 0 - "use_wps_input" "0/1/2 flag, using wps input" "0=no, 1=real, 2=tc" rconfig integer dfi_stage derived max_domains 3 - "dfi_stage" "current stage of DFI processing" "0=DFI setup, 1=DFI backward integration, 2=DFI forward integration, 3=WRF forecast" rconfig integer mp_physics_dfi derived max_domains -1 - "mp_physics_dfi" "" "-1 = no DFI and so no need to allocate DFI moist and scalar variables, >0 = running with DFI, so allocate DFI moist and scalar variables appropriate for selected microphysics package" +rconfig integer bl_pbl_physics_dfi derived max_domains -1 - "bl_pbl_physics_dfi" "" "-1 = no DFI and so no need to allocate DFI qke_adv variable, >0 = running with DFI, so allocate DFI qke_adv variable appropriate for selected PBL package" # # Single dummy declaration to define a nodyn dyn option @@ -2589,7 +2612,7 @@ package kesslerscheme mp_physics==1 - moist:qv,qc package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg package wsm3scheme mp_physics==3 - moist:qv,qc,qr;state:re_cloud,re_ice,re_snow package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs;state:re_cloud,re_ice,re_snow -package fer_mp_hires mp_physics==5 - moist:qv,qc,qr,qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy +package fer_mp_hires mp_physics==5 - moist:qv,qc,qr,qi;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy package fer_mp_hires_advect mp_physics==15 - moist:qv,qc,qr,qi;scalar:qrimef package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg;state:re_cloud,re_ice,re_snow package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg @@ -2607,6 +2630,8 @@ package nssl_1mom mp_physics==19 - moist:qv,qc package nssl_1momlfo mp_physics==21 - moist:qv,qc,qr,qi,qs,qg package nssl_2momg mp_physics==22 - moist:qv,qc,qr,qi,qs,qg;scalar:qndrop,qnr,qni,qns,qng,qvolg;state:re_cloud,re_ice,re_snow package thompsonaero mp_physics==28 - moist:qv,qc,qr,qi,qs,qg;scalar:qni,qnr,qnc,qnwfa,qnifa;state:re_cloud,re_ice,re_snow,qnwfa2d,taod5503d,taod5502d +package p3_1category mp_physics==50 - moist:qv,qc,qr,qi;scalar:qni,qnr,qir,qib;state:re_cloud,re_ice,vmi3d,rhopo3d,di3d,refl_10cm,th_old,qv_old +package p3_1category_nc mp_physics==51 - moist:qv,qc,qr,qi;scalar:qnc,qni,qnr,qir,qib;state:re_cloud,re_ice,vmi3d,rhopo3d,di3d,refl_10cm,th_old,qv_old package etampnew mp_physics==95 - moist:qv,qc,qr,qs;scalar:qt;state:f_ice_phy,f_rain_phy,f_rimef_phy package radar_refl compute_radar_ref==1 - state:refl_10cm,refd_max @@ -2618,7 +2643,7 @@ package kesslerscheme_dfi mp_physics_dfi==1 - dfi_moist:dfi package linscheme_dfi mp_physics_dfi==2 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package wsm3scheme_dfi mp_physics_dfi==3 - dfi_moist:dfi_qv,dfi_qc,dfi_qr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package wsm5scheme_dfi mp_physics_dfi==4 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow -package fer_mp_hires_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt +package fer_mp_hires_dfi mp_physics_dfi==5 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi;dfi_scalar:dfi_qt package wsm6scheme_dfi mp_physics_dfi==6 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow package gsfcgcescheme_dfi mp_physics_dfi==7 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package thompson_dfi mp_physics_dfi==8 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow @@ -2633,6 +2658,8 @@ package nssl_2mom_dficcn mp_physics_dfi==18 - dfi_moist:dfi package nssl_1mom_dfi mp_physics_dfi==19 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg,dfi_qh;dfi_scalar:dfi_qvolg package nssl_1momlfo_dfi mp_physics_dfi==21 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg package thompsonaero_dfi mp_physics_dfi==28 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi,dfi_qs,dfi_qg;dfi_scalar:dfi_qni,dfi_qnr,dfi_qnc,dfi_qnwfa,dfi_qnifa;state:dfi_re_cloud,dfi_re_ice,dfi_re_snow +package p3_1category_dfi mp_physics_dfi==50 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi;dfi_scalar:dfi_qni,dfi_qnr,dfi_qir,dfi_qib;state:dfi_re_cloud,dfi_re_ice +package p3_1category_nc_dfi mp_physics_dfi==51 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qi;dfi_scalar:dfi_qnc,dfi_qni,dfi_qnr,dfi_qir,dfi_qib;state:dfi_re_cloud,dfi_re_ice package etampnew_dfi mp_physics_dfi==95 - dfi_moist:dfi_qv,dfi_qc,dfi_qr,dfi_qs;dfi_scalar:dfi_qt package noprogn progn==0 - - @@ -2642,9 +2669,9 @@ package noqndrop alloc_qndropsource==0 - - package qndrop alloc_qndropsource==1 - state:qndropsource package rrtmscheme ra_lw_physics==1 - - -package camlwscheme ra_lw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc;state:emstot,abstot,absnxt,acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,taucldc,taucldi -package rrtmg_lwscheme ra_lw_physics==4 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,o3rad -package rrtmg_lwscheme_fast ra_lw_physics==24 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,o3rad +package camlwscheme ra_lw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc;state:emstot,abstot,absnxt,acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,taucldc,taucldi +package rrtmg_lwscheme ra_lw_physics==4 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,o3rad +package rrtmg_lwscheme_fast ra_lw_physics==24 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,o3rad package goddardlwscheme ra_lw_physics==5 - state:tlwdn,tlwup,slwdn,slwup,taucldc,taucldi package flglwscheme ra_lw_physics==7 - - package heldsuarez ra_lw_physics==31 - - @@ -2652,9 +2679,9 @@ package gfdllwscheme ra_lw_physics==99 - - package swradscheme ra_sw_physics==1 - - package gsfcswscheme ra_sw_physics==2 - state:taucldc,taucldi -package camswscheme ra_sw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc;state:emstot,abstot,absnxt,acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,taucldc,taucldi -package rrtmg_swscheme ra_sw_physics==4 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,o3rad;aerod:ocarbon,seasalt,dust,bcarbon,sulfate,upperaer -package rrtmg_swscheme_fast ra_sw_physics==24 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,o3rad;aerod:ocarbon,seasalt,dust,bcarbon,sulfate,upperaer +package camswscheme ra_sw_physics==3 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;aerosolc:sul,sslt,dust1,dust2,dust3,dust4,ocpho,bcpho,ocphi,bcphi,bg,volc;state:emstot,abstot,absnxt,acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,aclwupt,aclwuptc,aclwdnt,aclwdntc,aclwupb,aclwupbc,aclwdnb,aclwdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,lwupt,lwuptc,lwdnt,lwdntc,lwupb,lwupbc,lwdnb,lwdnbc,taucldc,taucldi +package rrtmg_swscheme ra_sw_physics==4 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,o3rad;aerod:ocarbon,seasalt,dust,bcarbon,sulfate,upperaer +package rrtmg_swscheme_fast ra_sw_physics==24 - ozmixm:mth01,mth02,mth03,mth04,mth05,mth06,mth07,mth08,mth09,mth10,mth11,mth12;state:acswupt,acswuptc,acswdnt,acswdntc,acswupb,acswupbc,acswdnb,acswdnbc,swupt,swuptc,swdnt,swdntc,swupb,swupbc,swdnb,swdnbc,o3rad;aerod:ocarbon,seasalt,dust,bcarbon,sulfate,upperaer package goddardswscheme ra_sw_physics==5 - state:tswdn,tswup,sswdn,sswup,taucldc,taucldi package flgswscheme ra_sw_physics==7 - - package gfdlswscheme ra_sw_physics==99 - - @@ -2675,8 +2702,8 @@ package bep_bemscheme sf_urban_physics==3 - state:a_u_bep package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn,smcrel -package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag,soilt1,rhosnf,snowfallac,precipfr -package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy,fdepthxy,areaxy,rivercondxy,riverbedxy,eqzwt,pexpxy,qrfxy,qrfsxy,qspringxy,qspringsxy,qslatxy,stepwtd,gddxy,grainxy +package ruclsmscheme sf_surface_physics==3 - state:smfr3d,keepfr3dflag,soilt1,rhosnf,snowfallac,precipfr,acrunoff +package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy,fdepthxy,areaxy,rivercondxy,riverbedxy,eqzwt,pexpxy,qrfxy,qrfsxy,qspringxy,qspringsxy,qslatxy,stepwtd,rechclim,gddxy,grainxy,croptype,planting,harvest,season_gdd,cropcat,pgsxy package clmscheme sf_surface_physics==5 - state:numc,nump,sabv,sabg,lwup,lhsoi,lhveg,lhtran,snl,snowdp,wtc,wtp,h2osno,t_grnd,t_veg,h2ocan,h2ocan_col,t2m_max,t2m_min,t2clm,t_ref2m,h2osoi_liq_s1,h2osoi_liq_s2,h2osoi_liq_s3,h2osoi_liq_s4,h2osoi_liq_s5,h2osoi_liq1,h2osoi_liq2,h2osoi_liq3,h2osoi_liq4,h2osoi_liq5,h2osoi_liq6,h2osoi_liq7,h2osoi_liq8,h2osoi_liq9,h2osoi_liq10,h2osoi_ice_s1,h2osoi_ice_s2,h2osoi_ice_s3,h2osoi_ice_s4,h2osoi_ice_s5,h2osoi_ice1,h2osoi_ice2,h2osoi_ice3,h2osoi_ice4,h2osoi_ice5,h2osoi_ice6,h2osoi_ice7,h2osoi_ice8,h2osoi_ice9,h2osoi_ice10,t_soisno_s1,t_soisno_s2,t_soisno_s3,t_soisno_s4,t_soisno_s5,t_soisno1,t_soisno2,t_soisno3,t_soisno4,t_soisno5,t_soisno6,t_soisno7,t_soisno8,t_soisno9,t_soisno10,dzsnow1,dzsnow2,dzsnow3,dzsnow4,dzsnow5,snowrds1,snowrds2,snowrds3,snowrds4,snowrds5,t_lake1,t_lake2,t_lake3,t_lake4,t_lake5,t_lake6,t_lake7,t_lake8,t_lake9,t_lake10,h2osoi_vol1,h2osoi_vol2,h2osoi_vol3,h2osoi_vol4,h2osoi_vol5,h2osoi_vol6,h2osoi_vol7,h2osoi_vol8,h2osoi_vol9,h2osoi_vol10,albedosubgrid,lhsubgrid,hfxsubgrid,lwupsubgrid,q2subgrid,sabvsubgrid,sabgsubgrid,nrasubgrid,swupsubgrid package pxlsmscheme sf_surface_physics==7 - state:t2_ndg_new,q2_ndg_new,t2_ndg_old,q2_ndg_old,vegf_px,imperv,canfra package ssibscheme sf_surface_physics==8 - state:ssib_fm,ssib_fh,ssib_cm,ssibxdd,ssib_br,ssib_lhf,ssib_shf,ssib_ghf,ssib_egs,ssib_eci,ssib_ect,ssib_egi,ssib_egt,ssib_sdn,ssib_sup,ssib_ldn,ssib_lup,ssib_wat,ssib_shc,ssib_shg,ssib_lai,ssib_vcf,ssib_z00,ssib_veg,isnow,swe,snowden,snowdepth,tkair,dzo1,wo1,tssn1,tssno1,bwo1,bto1,cto1,fio1,flo1,bio1,blo1,ho1,dzo2,wo2,tssn2,tssno2,bwo2,bto2,cto2,fio2,flo2,bio2,blo2,ho2,dzo3,wo3,tssn3,tssno3,bwo3,bto3,cto3,fio3,flo3,bio3,blo3,ho3,dzo4,wo4,tssn4,tssno4,bwo4,bto4,cto4,fio4,flo4,bio4,blo4,ho4 @@ -2702,11 +2729,15 @@ package mynn_stem_edmf bl_mynn_edmf==1 - state:edmf_a, package mynn_temf_edmf bl_mynn_edmf==2 - state:edmf_a,edmf_w,edmf_thl,edmf_qt,edmf_ent,edmf_qc package pbl_cloud icloud_bl==1 - state:cldfra_bl,qc_bl +# dfi +package mynnpblscheme2_dfi bl_pbl_physics_dfi==5 - dfi_scalar:dfi_qke_adv +package mynnpblscheme3_dfi bl_pbl_physics_dfi==6 - dfi_scalar:dfi_qke_adv + package nocuscheme cu_physics==0 - - package kfetascheme cu_physics==1 - state:w0avg package bmjscheme cu_physics==2 - - package gfscheme cu_physics==3 - state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow -package osasscheme cu_physics==4 - - +package scalesasscheme cu_physics==4 - - package g3scheme cu_physics==5 - state:cugd_qvten,cugd_tten,cugd_qvtens,cugd_ttens,cugd_qcten,xmb_shallow,k22_shallow,kbcon_shallow,ktop_shallow package tiedtkescheme cu_physics==6 - - package camzmscheme cu_physics==7 - state:precz,zmdt,zmdq,zmdice,zmdliq,evaptzm,fzsntzm,evsntzm,evapqzm,zmflxprc,zmflxsnw,zmntprpd,zmntsnpd,zmeiheat,cmfmc,cmfmcdzm,preccdzm,pconvb,pconvt,cape,zmmtu,zmmtv,zmmu,zmmd,zmupgu,zmupgd,zmvpgu,zmvpgd,zmicuu,zmicud,zmicvu,zmicvd,evapcdp3d,icwmrdp3d,rprddp3d,dp3d,du3d,ed3d,eu3d,md3d,mu3d,dsubcld2d,ideep2d,jt2d,maxg2d,lengath2d,dlf,rliq,tpert2d @@ -2715,8 +2746,8 @@ package mskfscheme cu_physics==11 - state:w0avg,w package nsasscheme cu_physics==14 - - package ntiedtkescheme cu_physics==16 - - package gdscheme cu_physics==93 - - -package sasscheme cu_physics==84 - - -package meso_sas cu_physics==85 - - +package sasscheme cu_physics==94 - - +package osasscheme cu_physics==95 - - package kfscheme cu_physics==99 - state:w0avg package g3tave cu_diag==1 - state:GD_CLOUD,GD_CLOUD2,GD_CLDFR,GD_CLOUD_A,GD_CLOUD2_A,kbcon_deep,ktop_deep,k22_deep @@ -2762,9 +2793,7 @@ package scmopt scm_force==1 - state:z_force package prec_acc prec_acc_opt==1 - state:prec_acc_c,prec_acc_nc,snow_acc_nc package bucketropt bucketr_opt==1 - state:i_rainc,i_rainnc - -package restofwrf use_wps_input==0 - - - +package bucketfopt bucketf_opt==1 - state:i_acswupt,i_acswuptc,i_acswdnt,i_acswdntc,i_acswupb,i_acswupbc,i_acswdnb,i_acswdnbc,i_aclwupt,i_aclwuptc,i_aclwdnt,i_aclwdntc,i_aclwupb,i_aclwupbc,i_aclwdnb,i_aclwdnbc package original_mom momentum_adv_opt==1 package weno_mom momentum_adv_opt==3 @@ -2789,10 +2818,6 @@ package dfi_dfl dfi_opt==1 - state:dfi_u,d package dfi_ddfi dfi_opt==2 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad package dfi_tdfi dfi_opt==3 - state:dfi_u,dfi_v,dfi_w,dfi_ph,dfi_phb,dfi_ph0,dfi_php,dfi_t,dfi_p,dfi_ww,dfi_mu,dfi_tke,dfi_pb,dfi_al,dfi_alt,dfi_TSLB,dfi_SMOIS,dfi_SNOW,dfi_SNOWH,dfi_CANWAT,dfi_SMFR3D,dfi_KEEPFR3DFLAG,dfi_TSK,dfi_SOILT1,dfi_TSNAV,dfi_SNOWC,dfi_QVG,dfi_rh,dfi_tten_rad -package realonly use_wps_input==1 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,lai12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,cl_gc,cf_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc,prho_gc,pdrho_gc,qnr_gc,soil_layers,soil_levels,st,sm,sw,soilt,soilm,sm000007,sm007028,sm028100,sm100255,st000007,st007028,st028100,st100255,sm000010,sm010040,sm040100,sm100200,sm010200,soilm000,soilm005,soilm020,soilm040,soilm160,soilm300,sw000010,sw010040,sw040100,sw100200,sw010200,soilw000,soilw005,soilw020,soilw040,soilw160,soilw300,st000010,st010040,st040100,st100200,st010200,soilt000,soilt005,soilt020,soilt040,soilt160,soilt300,fad0_urb2d,fad135_urb2d,fad45_urb2d,pad_urb2d,fad90_urb2d,rad_urb2d,car_urb2d,h2w_urb2d,svf_urb2d,z0s_urb2d,z0r_urb2d,z0m_urb2d,zds_urb2d,zdm_urb2d,zdr_urb2d,qnwfa_gc,qnwfa_now,qnwfa_jan,qnwfa_feb,qnwfa_mar,qnwfa_apr,qnwfa_may,qnwfa_jun,qnwfa_jul,qnwfa_aug,qnwfa_sep,qnwfa_oct,qnwfa_nov,qnwfa_dec,qnifa_gc,qnifa_now,qnifa_jan,qnifa_feb,qnifa_mar,qnifa_apr,qnifa_may,qnifa_jun,qnifa_jul,qnifa_aug,qnifa_sep,qnifa_oct,qnifa_nov,qnifa_dec,qntemp,qntemp2,hgtmaxw,pmaxw,tmaxw,umaxw,vmaxw,hgttrop,ptrop,ttrop,utrop,vtrop,urb_param - -package tconly use_wps_input==2 - state:u_gc,v_gc,t_gc,rh_gc,ght_gc,p_gc,xlat_gc,xlong_gc,ht_gc,tsk_gc,tavgsfc,tmn_gc,pslv_gc,sct_dom_gc,scb_dom_gc,greenfrac,albedo12m,pd_gc,psfc_gc,intq_gc,pdhs,sh_gc,qv_gc,qr_gc,qc_gc,qs_gc,qi_gc,qg_gc,qh_gc,qni_gc,icefrac_gc - package reg_interp nest_interp_coord==0 - - package flat_p_interp nest_interp_coord==1 - state:t_max_p,ght_max_p,max_p,t_min_p,ght_min_p,min_p @@ -2816,7 +2841,22 @@ package icedepth_one seaice_thickness_opt==1 - state:icedept #Time series options for text output package notseries process_time_series==0 - - package tseries process_time_series==1 - state:ts_hour,ts_u,ts_v,ts_q,ts_t,ts_psfc,ts_glw,ts_gsw,ts_hfx,ts_lh,ts_tsk,ts_tslb,ts_clw,ts_rainc,ts_rainnc,ts_u_profile,ts_v_profile,ts_gph_profile,ts_th_profile - + +# WRF-HAILCAST +state real HAILCAST_DHAIL1 ij misc 1 - - "HAILCAST_DHAIL1" "WRF-HAILCAST Hail Diameter, 1st rank order" "mm" +state real HAILCAST_DHAIL2 ij misc 1 - - "HAILCAST_DHAIL2" "WRF-HAILCAST Hail Diameter, 2nd rank order" "mm" +state real HAILCAST_DHAIL3 ij misc 1 - - "HAILCAST_DHAIL3" "WRF-HAILCAST Hail Diameter, 3rd rank order" "mm" +state real HAILCAST_DHAIL4 ij misc 1 - - "HAILCAST_DHAIL4" "WRF-HAILCAST Hail Diameter, 4th rank order" "mm" +state real HAILCAST_DHAIL5 ij misc 1 - - "HAILCAST_DHAIL5" "WRF-HAILCAST Hail Diameter, 5th rank order" "mm" +state real HAILCAST_DIAM_MEAN ij misc 1 - rh02 "HAILCAST_DIAM_MEAN" "WRF-HAILCAST Mean Hail Diameter" "mm" +state real HAILCAST_DIAM_STD ij misc 1 - rh02 "HAILCAST_DIAM_STD" "WRF-HAILCAST Stand. Dev. Hail Diameter" "mm" +state real HAILCAST_WUP_MASK ij misc 1 - r "HAILCAST_WUP_MASK" "Updraft mask, 1 if > 10m/s" "" +state real HAILCAST_WDUR ij misc 1 - r "HAILCAST_WDUR" "Updraft duration" "sec" + +package hailcast hailcast_opt==1 - state:hailcast_diam_mean,hailcast_diam_std,hailcast_dhail1,hailcast_dhail2,hailcast_dhail3,hailcast_dhail4,hailcast_dhail5 +rconfig integer hailcast_opt namelist,physics max_domains 0 rh "hailcast_opt" "WRF-HAILCAST option, 1: on" "" +halo HALO_EM_PHYS_HCW dyn_em 8:hailcast_wup_mask, hailcast_wdur + # lightning state real ic_flashcount ij misc 1 - rh "ic_flashcount" "Accumulated IC flash count" "#" @@ -2896,9 +2936,9 @@ halo HALO_EM_TKE_ADVECT_3 dyn_em 24:tke_2 halo HALO_EM_TKE_ADVECT_5 dyn_em 48:tke_2 halo HALO_EM_TKE_A dyn_em 4:ph_2,phb halo HALO_EM_TKE_B dyn_em 4:z,rdz,rdzw,zx,zy -halo HALO_EM_TKE_C dyn_em 8:u_2,v_2,z,zx,zy,rdz,rdzw,ustm +halo HALO_EM_TKE_C dyn_em 8:u_2,v_2,z,zx,zy,rdz,rdzw,ustm,ust halo HALO_EM_TKE_D dyn_em 8:defor11,defor22,defor33,defor12,defor13,defor23,div -halo HALO_EM_TKE_E dyn_em 8:xkmv,xkmh,xkhv,xkhh,BN2,moist +halo HALO_EM_TKE_E dyn_em 8:xkmv,xkmh,xkhv,xkhh,BN2,moist,rho halo HALO_EM_TKE_3 dyn_em 24:tke_1,tke_2 halo HALO_EM_TKE_5 dyn_em 48:tke_1,tke_2 halo HALO_EM_TKE_7 dyn_em 80:tke_1,tke_2 @@ -2910,8 +2950,8 @@ halo HALO_EM_B2 dyn_em 4:ru_tend,rv_tend halo HALO_EM_C dyn_em 4:u_2,v_2 halo HALO_EM_C2 dyn_em 4:ph_2,al,p,mu_2,muts,mudf halo HALO_EM_D dyn_em 24:ru_m,rv_m,ww_m,mut,muts -halo HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,scalar;4:mu_2,al -halo HALO_EM_D2_5 dyn_em 48:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,scalar;4:mu_2,al +halo HALO_EM_D2_3 dyn_em 24:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,scalar,tke_2;4:mu_2,al +halo HALO_EM_D2_5 dyn_em 48:u_2,v_2,w_2,t_2,ph_2;24:moist,chem,tracer,scalar,tke_2;4:mu_2,al halo HALO_EM_D3_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,tracer,scalar;4:mu_1,mu_2 halo HALO_EM_D3_5 dyn_em 48:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,moist,chem,tracer,scalar;4:mu_1,mu_2 halo HALO_EM_E_3 dyn_em 24:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,;4:mu_1,mu_2 @@ -2961,6 +3001,7 @@ period PERIOD_EM_COUPLE_B dyn_em 3:ph_1,ph_2,w_1,w_2,t_1,t_2,u_1,u_2,v_1,v_2, #cyl for trajectory halo HALO_EM_F dyn_em 24:muu,muv,mut +halo HALO_EM_F_1 dyn_em 24:muus,muvs ## For moving nests #halo em_shift_halo_y dyn_em 48:imask_nostag,imask_xstag,imask_ystag,imask_xystag,u_2,v_2,t_2 @@ -2996,8 +3037,8 @@ period PERIOD_BDY_EM_TKE_OLD dyn_em 4:tke_1 period PERIOD_BDY_EM_E dyn_em 2:u_2,v_2,ht period PERIOD_EM_HYDRO_UV dyn_em 1:u_2,v_2 period PERIOD_BDY_EM_A dyn_em 2:ru,rv,rw,ww,php,alt,p,muu,muv,mut,ph_2,al -period PERIOD_BDY_EM_A1 dyn_em 3:rdzw,rdz,z,zx,zy,ustm -period PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,rucuten,rvcuten,xkmh,xkmv,xkhh,xkhv,div,defor11,defor22,defor12,defor13,defor23,defor33,tke_2 +period PERIOD_BDY_EM_A1 dyn_em 3:rdzw,rdz,z,zx,zy,ustm,ust +period PERIOD_BDY_EM_PHY_BC dyn_em 2:rublten,rvblten,rucuten,rvcuten,xkmh,xkmv,xkhh,xkhv,div,defor11,defor22,defor12,defor13,defor23,defor33,tke_2,rho period PERIOD_BDY_EM_FDDA_BC dyn_em 2:rundgdten,rvndgdten period PERIOD_BDY_EM_B dyn_em 2:ru_tend,rv_tend,ph_2,al,p,t_1,t_save,u_save,v_save,mu_1,mu_2,mudf,php,alt,pb period PERIOD_BDY_EM_B3 dyn_em 2:ph_2,al,p,mu_2,muts,mudf @@ -3006,6 +3047,8 @@ period PERIOD_BDY_EM_C dyn_em 2:u_2,u_save,v_2,v_save,t_2,t_save,muv,msfvx,ms period PERIOD_BDY_EM_D dyn_em 3:u_2,v_2,w_2,t_2,ph_2,mu_2,tke_2 period PERIOD_BDY_EM_D3 dyn_em 3:u_1,u_2,v_1,v_2,w_1,w_2,t_1,t_2,ph_1,ph_2,tke_1,tke_2,mu_1,mu_2 period PERIOD_EM_DA dyn_em 2:ru_m,rv_m,ww_m,mut,muts +period PERIOD_EM_F dyn_em 2:muus,muvs +period PERIOD_EM_G dyn_em 2:msftx,msfux,msfvy period PERIOD_EM_THETAM dyn_em 3:t_1,t_2,h_diabatic # diff --git a/wrfv2_fire/Registry/Registry.EM_COMMON.var b/wrfv2_fire/Registry/Registry.EM_COMMON.var index 81876811..63547e43 100644 --- a/wrfv2_fire/Registry/Registry.EM_COMMON.var +++ b/wrfv2_fire/Registry/Registry.EM_COMMON.var @@ -342,6 +342,7 @@ state real PBLH ij misc 1 - irh "P state real HFX ij misc 1 - irh "HFX" "UPWARD HEAT FLUX AT THE SURFACE" "W m-2" state real QFX ij misc 1 - irh "QFX" "UPWARD MOISTURE FLUX AT THE SURFACE" "kg m-2 s-1" state real REGIME ij misc 1 - irh "REGIME" "FLAGS: 1=Night/Stable, 2=Mechanical Turbulent, 3=Forced Conv, 4=Free Conv" "" +state integer KPBL ij misc 1 - irh "KPBL" "LEVEL OF PBL TOP" "" # #--------------------------------------------------------------------------------------------------------------------------------------- diff --git a/wrfv2_fire/Registry/Registry.NMM b/wrfv2_fire/Registry/Registry.NMM index 4ed53c67..43b74761 100644 --- a/wrfv2_fire/Registry/Registry.NMM +++ b/wrfv2_fire/Registry/Registry.NMM @@ -162,6 +162,11 @@ ifdef HWRF=1 include registry.tracker endif +# For compilation only; any setting other than zero will cause the simulation to halt +rconfig integer traj_opt namelist,physics 1 0 h "traj_opt" "activate trajectory calculation 0=no, 1=on" "" +rconfig logical dm_has_traj namelist,physics max_domains .false. rh "has_traj" "activate trajectory calculation per domain" "" +rconfig integer num_traj namelist,domains 1 1000 irh "num_traj" "#of trajectory" "" + # Nest motion safeguard: don't let nest get close to parent boundary. # Default values are lowest possible - anything lower would read # outside of memory in intermediate domain. @@ -175,7 +180,7 @@ rconfig integer corral_y namelist,domains max_domains 5 h "corral_y state real pdyn ij dyn_nmm 1 - rh "PDYN" "Dynamic pressure at mean sea level" state real mslp ij dyn_nmm 1 - rh "MSLP" "Shuell Mean Sea Level Pressure" "Pa" ifdef HWRF=1 -state real best_mslp ij dyn_nmm 1 - rh0123 "BEST_MSLP" "Best Mean Sea Level Pressure (Shuell or Membrane)" "Pa" +state real best_mslp ij dyn_nmm 1 - rh0123d=(DownCopy) "BEST_MSLP" "Best Mean Sea Level Pressure (Shuell or Membrane)" "Pa" endif state real sqws ij dyn_nmm 1 - r "SQWS" "SQUARE OF WIND SPEED AT LEVEL 10" state integer xloc - dyn_nmm 2 - r "XLOC" "I-LOCATION OF MINIMUM DYNAMIC PRESSURE" @@ -266,7 +271,7 @@ state real hbm2 ij dyn_nmm 1 - irh0123 "HBM2" " state real hbm3 ij dyn_nmm 1 - irh "HBM3" "Height boundary mask; =0 outer 3 rows on H points" "" state real vbm2 ij dyn_nmm 1 - irh "VBM2" "Velocity boundary mask; =0 outer 2 rows on V points" "" state real vbm3 ij dyn_nmm 1 - irh "VBM3" "Velocity boundary mask; =0 outer 3 rows on V points" "" -state real sm ij dyn_nmm 1 f i01rh0123d=(DownNear) "SM" "Sea mask; =1 for sea, =0 for land" "" +state real sm ijb dyn_nmm 1 - i01rh0123d=(DownNear)f=(BdyNear) "SM" "Sea mask; =1 for sea, =0 for land" "" state real sice ij dyn_nmm 1 f irh023d=(DownNear) "SICE" "Sea ice mask; =1 for sea ice, =0 for no sea ice" "" # # module_VRBLS @@ -391,9 +396,32 @@ state real mixht ij dyn_nmm 1 - rh "MIXHT" state real ustar ij dyn_nmm 1 - irh023d=(DownNear) "USTAR" "Friction velocity" "m s-1" state real z0 ij dyn_nmm 1 - i01rh023d=(DownNear) "Z0" "Thermal Roughness length" "m" state real mz0 ij dyn_nmm 1 - h "MZ0" "momentum Roughness length" "m" +state real scurx ij dyn_nmm 1 - irh023d=(DownNear)f=(force_sst_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,FORCE_SST) "SCURX" "Surface Currents(X)" "m s-1" +state real scury ij dyn_nmm 1 - irh023d=(DownNear)f=(force_sst_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,FORCE_SST) "SCURY" "Surface Currents(Y)" "m s-1" +state real charn ij dyn_nmm 1 - irh023d=(DownNear)f=(force_sst_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,FORCE_SST) "CHARN" "Charnock Coeff" " " +state real msang ij dyn_nmm 1 - irh023d=(DownNear)f=(force_sst_nmm:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,FORCE_SST) "MSANG" "Wind/Stress Angle" "Radian" +state real rchno ij dyn_nmm 1 - irh023 "RCHNO" "Richardson number" " " +state real zsig1 ij dyn_nmm 1 - irh023 "ZSIG1" "Height of lowest model level" "m" +state real ulowl ij dyn_nmm 1 - irh023 "ULOWL" "U at Lowest Level" "m s-1" +state real vlowl ij dyn_nmm 1 - irh023 "VLOWL" "V at Lowest Level" "m s-1" state real rc2d ij dyn_nmm 1 - h "RC2D" "critical Richardson number" "m" -state real dku3d ijk dyn_nmm 1 - h "DKU3D" "Momentum Diffusivity" "m*m/s" -state real dkt3d ijk dyn_nmm 1 - h "DKT3D" "Thermal Diffusivity" "m*m/s" +state real dku3d ijk dyn_nmm 1 - rh "DKU3D" "Momentum Diffusivity" "m*m/s" +state real dkt3d ijk dyn_nmm 1 - rh "DKT3D" "Thermal Diffusivity" "m*m/s" + +state real SCALEFUN ij dyn_nmm 1 - rh023 "SCALEFUN" "CNV Mass Scale function(0-1)" " " +state real SCALEFUN1 ij dyn_nmm 1 - rh023 "SCALEFUN1" "CNV Mass Scale function 1(0-1)" " " +state real SIGMU ij dyn_nmm 1 - rh023 "SIGMU" "CNV deep updraft fractio n(0-1)" " " +state real SIGMU1 ij dyn_nmm 1 - rh023 "SIGMU1" "CNV shallow updraft fra ction(0-1)" +state real DTHCUDT ijk dyn_nmm 1 - rh "DTHCUDT" "TH tendency due to CU" "K/s" +state real DQVCUDT ijk dyn_nmm 1 - rh "DQVCUDT" "QV tendency due to CU" "kg/kg/s" +state real DQRCUDT ijk dyn_nmm 1 - rh "DQRCUDT" "QR tendency due to CU" "kg/kg/s" +state real DQCCUDT ijk dyn_nmm 1 - rh "DQCCUDT" "QC tendency due to CU" "Kg/kg/s" +state real DQICUDT ijk dyn_nmm 1 - rh "DQICUDT" "QI tendency due to CU" "Kg/kg/s" +state real DQSCUDT ijk dyn_nmm 1 - rh "DQSCUDT" "QS tendency due to CU" "Kg/kg/s" +state real DTHBLDT ijk dyn_nmm 1 - rh "DTHBLDT" "TH tendency due to PBL" "K/s" +state real DQVBLDT ijk dyn_nmm 1 - rh "DQVBLDT" "QV tendency due to PBL" "Kg/kg/s" +state real DUBLDT ijk dyn_nmm 1 - rh "DUBLDT" "U tendency due to PBL" "m/s/s" +state real DVBLDT ijk dyn_nmm 1 - rh "DVBLDT" "V tendency due to PBL" "m/s/s" state real hpbl2d ij dyn_nmm 1 - irh "HPBL2D" "HEIGHT OF PBL from new GFS pbl" "m" state real heat2d ij dyn_nmm 1 - irh "HEAT2D" "" "" state real evap2d ij dyn_nmm 1 - irh "EVAP2D" "" "" @@ -403,12 +431,12 @@ state real mavail ij dyn_nmm 1 - i state real qsh ij dyn_nmm 1 - irh023d=(DownCopy) "QS" "Surface specific humidity" "kg kg-1" state real twbs ij dyn_nmm 1 - irh0123 "TWBS" "Instantaneous sensible heat flux" "W m-2" state real qwbs ij dyn_nmm 1 - irh0123 "QWBS" "Instantaneous latent heat flux" "W m-2" -state real taux ij dyn_nmm 1 - irh0123 "TAUX" "Instantaneous stress along X direction in KG/M/S^2" -state real tauy ij dyn_nmm 1 - irh0123 "TAUY" "Instantaneous stress along Y direction in KG/M/S^2" +state real taux ij dyn_nmm 1 - irh0123d=(DownCopy) "TAUX" "Instantaneous stress along X direction in KG/M/S^2" +state real tauy ij dyn_nmm 1 - irh0123d=(DownCopy) "TAUY" "Instantaneous stress along Y direction in KG/M/S^2" state real prec ij dyn_nmm 1 - rh023 "PREC" "Precipitation in physics timestep" "m" state real aprec ij dyn_nmm 1 - rh state real acprec ij dyn_nmm 1 - rh0123d=(DownCopy) "ACPREC" "Accumulatedtotal precipitation" "m" -state real cuprec ij dyn_nmm 1 - rh023 "CUPREC" "Accumulated convective precipitation" "m" +state real cuprec ij dyn_nmm 1 - rh0123d=(DownCopy) "CUPREC" "Accumulated convective precipitation" "m" state real lspa ij dyn_nmm 1 - h023 "LSPA" "Land Surface Precipitation Accumulation" "kg m-2" state real ddata ij dyn_nmm 1 - - "DDATA" "Observed precip to each physics timestep" "kg m-2" state real accliq ij dyn_nmm 1 - r @@ -432,8 +460,8 @@ state real AKMS_OUT ij dyn_nmm 1 - rh023 "AKMS_OUT" "Outp # # module_PHYS # -state real cd_out ij dyn_nmm 1 - rh023 "CD_OUT" "sfc exch coeff for momentum" "m2 s-1" -state real ch_out ij dyn_nmm 1 - rh023 "CH_OUT" "sfc exch coeff for heat" "m2 s-1" +state real cd_out ij dyn_nmm 1 - rh0123d=(DownCopy) "CD_OUT" "sfc exch coeff for momentum" "m2 s-1" +state real ch_out ij dyn_nmm 1 - rh0123d=(DownCopy) "CH_OUT" "sfc exch coeff for heat" "m2 s-1" state real albase ij dyn_nmm 1 - i01rh023d=(DownCopy) "ALBASE" "Base albedo" "" state real albedo ij dyn_nmm 1 - irh023 "ALBEDO" "Dynamic albedo" "" @@ -545,6 +573,11 @@ rconfig real aer_angexp_val namelist,physics max_domains 1. rconfig real aer_ssa_val namelist,physics max_domains 0.85 irh "aer_ssa_val" "fixed value for aerosol single-scattering albedo. Valid when aer_ssa_opt=1" "" rconfig real aer_asy_val namelist,physics max_domains 0.90 irh "aer_asy_val" "fixed value for aerosol asymmetry parameter. Valid when aer_asy_opt=1" "" +# +# module_IGWAVE_ADJUST.F + +state real avgPchg - dyn_nmm 1 - r "avgPchg" "Average global change (hPa/3h)" "hPa/3h" + # module_CLDWTR.F # state real cwm ijkb dyn_nmm 1 - rh023u=(UpMass:@ECopy,0.0)d=(DownMass:@ECopy,0.0)f=(BdyMass:@ECopy,0.0) "CWM" "Total condensate" "kg kg-1" @@ -960,6 +993,7 @@ state real GRDFLX ij misc 1 - irh "GRD state real ALBBCK ij misc 1 - i0124r "ALBBCK" "BACKGROUND ALBEDO" "NA" state real SFCEXC ij misc 1 - irh023 "SFCEXC " "SURFACE EXCHANGE COEFFICIENT" "" state real SNOTIME ij misc 1 - r "SNOTIME" "SNOTIME" "" +state real ACRUNOFF ij misc 1 - rh "ACRUNOFF" "ACCUMULATED SURFACE RUNOFF" "" state real ACSNOW ij misc 1 - irh023 "ACSNOW" "ACCUMULATED SNOW" "kg m-2" state real ACSNOM ij misc 1 - irh023 "ACSNOM" "ACCUMULATED MELTED SNOW" "kg m-2" state real RMOL ij misc 1 - ir "RMOL" "" "" @@ -1095,8 +1129,6 @@ state real lfmassxy ij - 1 - i02rhd=(interp_mask_land state real rtmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "rtmass" "mass of fine roots" "g/m2" state real stmassxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "stmass" "stem mass" "g/m2" state real woodxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "wood" "mass of wood" "g/m2" -state real grainxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "grain" "mass of grain" "g/m2" -state real gddxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "gdd" "growing degree days" "" state real stblcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "stblcp" "stable carbon pool" "g/m2" state real fastcpxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "fastcp" "short-lived carbon" "g/m2" state real xsaixy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "xsai" "stem area index" "-" @@ -1151,6 +1183,18 @@ state real SMOISEQ ilj - 1 Z r "SMOIS state real smcwtdxy ij - 1 - rh "smcwtd" "deep soil moisture " "m3 m-3" state real rechxy ij - 1 - h "rech" "water table recharge" "mm" state real deeprechxy ij - 1 - r "deeprech" "deep water table recharge" "mm" + +# Crop model only + +state real grainxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "grain" "mass of grain" "g/m2" +state real gddxy ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "gdd" "growing degree days" "" +state real croptype i{crop}j - 1 Z i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "croptype" "crop type" "fraction" +state real planting ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "planting" "planting date" "julian day" +state real harvest ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "harvest" "harvest date" "julian day" +state real season_gdd ij - 1 - i02rhd=(interp_mask_land_field:lu_index)u=(UpNear) "season_gdd" "growing season GDD" "C" +state integer cropcat ij - 1 - rh "cropcat" "dominant crop category" "category" +state integer pgsxy ij - 1 - rh "pgs" "pgs" "" + # added state for etampnew microphysics (needed for restarts) state real mp_restart_state p misc 1 - r "MP_RESTART_STATE" "STATE VECTOR FOR MICROPHYSICS RESTARTS" @@ -1427,10 +1471,7 @@ rconfig logical rdlai2d namelist,physics 1 .fa rconfig logical ua_phys namelist,physics 1 .false. h "ua_phys" "activate UA Noah changes" "" rconfig integer opt_thcnd namelist,physics 1 1 h "opt_thcnd" "thermal conductivity option in Noah LSM" "" -ifdef HWRF=1 rconfig integer gwd_opt namelist,physics max_domains 2 irh "gwd_opt" "activate gravity wave drag: 0=off, 1=ARW, 2=NMM" "" -endif -rconfig integer gwd_opt namelist,physics max_domains 0 irh "gwd_opt" "activate gravity wave drag: 0=off, 1=ARW, 2=NMM" "" rconfig integer iz0tlnd namelist,physics 1 0 h "iz0tlnd" "switch to control land thermal roughness length" "" rconfig real sas_pgcon namelist,physics max_domains 0.55 irh0123 "sas_pgcon" "convectively forced pressure gradient factor (SAS scheme)" "" @@ -1447,6 +1488,7 @@ endif rconfig integer random_seed namelist,physics max_domains 0 irh "random_seed" "random number generator seed" rconfig integer icoef_sf namelist,physics max_domains 0 irh012 3 "icoef_sf" "Option for exchange coefficients in the surface flux scheme" "" +rconfig integer iwavecpl namelist,physics max_domains 0 irh012 3 "iwavecpl" "Option for activate coupling to sea surface wave model" "" rconfig logical lcurr_sf namelist,physics max_domains .false. irh012 3 "lcurr_sf" "Option to include ocean currents in the surface flux calculations" "" ifdef HWRF=1 @@ -1551,7 +1593,7 @@ rconfig real c_k namelist,dynamics max_domains 0 rconfig real smdiv namelist,dynamics max_domains 0. h "smdiv" "" "" rconfig real emdiv namelist,dynamics max_domains 0. h "emdiv" "" "" rconfig real epssm namelist,dynamics max_domains .1 h "epssm" "" "" -rconfig logical keepnh namelist,dynamics max_domains .true. rh "KEEPNH" "When .false., non-hydrostatic state is discarded at nest move." "" +rconfig integer nhmove namelist,dynamics max_domains -1 rh "NHMOVE" "Action when nest move: 0=discard non-hydro state -1=keep nh state everywhere 1=keep except near nest edge" "" rconfig logical non_hydrostatic namelist,dynamics max_domains .true. irh "non_hydrostatic" "" "" rconfig integer time_step_sound namelist,dynamics max_domains 10 h "time_step_sound" "" "" rconfig integer h_mom_adv_order namelist,dynamics max_domains 3 rh "h_mom_adv_order" "" "" @@ -1580,6 +1622,8 @@ rconfig real codamp namelist,dynamics max_domains 6. rconfig real coac namelist,dynamics max_domains 1.6 irh "coac" "horizontal diffusion weighting factor (larger = more diffusion) " "" rconfig real slophc namelist,dynamics max_domains 6.363961e-3 irh "slophc" "Maximum model level slope (dZ/dy) for which hor diffusion is applied" "" rconfig real wp namelist,dynamics max_domains 0. irh "wp" "Off-centering weight in the updating of nonhyrostatic eps" +rconfig real dwdt_damping_lev namelist,dynamics max_domains 0. irh "dwdt_damping_lev" "specify the non-hydro dw/dt damping level in stratosphere (in Pa), 0: no damping " + rconfig integer terrain_smoothing namelist,dynamics 1 1 irh "parallel_smooth" "nest_terrain smoothing method 0=none, 1=old, 2=new" @@ -1683,6 +1727,8 @@ package nssl_2momccn mp_physics==18 - moist:qv,qc,q package nssl_1mom mp_physics==19 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qvolg package nssl_1momlfo mp_physics==21 - moist:qv,qc,qr,qi,qs,qg package nssl_2momg mp_physics==22 - moist:qv,qc,qr,qi,qs,qg;scalar:qndrop,qnr,qni,qns,qng,qvolg;state:re_cloud,re_ice,re_snow +package p3_1category mp_physics==50 - moist:qv +package p3_1category_nc mp_physics==51 - moist:qv package etamp_hwrf mp_physics==85 - moist:qv,qc,qr,qi,qs;state:f_ice,f_rain,f_rimef package etampnew mp_physics==95 - moist:qv,qc,qr,qs;state:f_ice,f_rain,f_rimef package radar_refl compute_radar_ref==1 - state:refl_10cm,refd_max @@ -1741,9 +1787,9 @@ package gbmpblscheme sf_sfclay_physics==12 - - package slabscheme sf_surface_physics==1 - - package lsmscheme sf_surface_physics==2 - state:flx4,fvb,fbur,fgsn -package ruclsmscheme sf_surface_physics==3 - - +package ruclsmscheme sf_surface_physics==3 - state:ACRUNOFF -package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy,lake_depth +package noahmpscheme sf_surface_physics==4 - state:isnowxy,tvxy,tgxy,canliqxy,canicexy,eahxy,tahxy,cmxy,chxy,fwetxy,sneqvoxy,alboldxy,qsnowxy,wslakexy,zwtxy,waxy,wtxy,tsnoxy,zsnsoxy,snicexy,snliqxy,lfmassxy,rtmassxy,stmassxy,woodxy,stblcpxy,fastcpxy,xsaixy,taussxy,t2mvxy,t2mbxy,q2mvxy,q2mbxy,tradxy,neexy,gppxy,nppxy,fvegxy,qinxy,runsfxy,runsbxy,ecanxy,edirxy,etranxy,fsaxy,firaxy,aparxy,psnxy,savxy,sagxy,rssunxy,rsshaxy,bgapxy,wgapxy,tgvxy,tgbxy,chvxy,chbxy,shgxy,shcxy,shbxy,evgxy,evbxy,ghvxy,ghbxy,irgxy,ircxy,irbxy,trxy,evcxy,chleafxy,chucxy,chv2xy,chb2xy,chstarxy,smoiseq,smcwtdxy,rechxy,deeprechxy,fdepthxy,areaxy,rivercondxy,riverbedxy,eqzwt,pexpxy,qrfxy,qrfsxy,qspringxy,qspringsxy,qslatxy,stepwtd,gddxy,grainxy,croptype,planting,harvest,season_gdd,cropcat,pgsxy package clmscheme sf_surface_physics==5 - - package gfdlslab sf_surface_physics==88 - - @@ -1751,8 +1797,8 @@ package pxlsmscheme sf_surface_physics==7 - - package ssibscheme sf_surface_physics==8 - - package ysuscheme bl_pbl_physics==1 - - package myjpblscheme bl_pbl_physics==2 - - -package gfsscheme bl_pbl_physics==3 - state:hpbl2d,heat2d,evap2d,rc2d -package gfs2011scheme bl_pbl_physics==83 - state:hpbl2d,heat2d,evap2d +package gfsscheme bl_pbl_physics==93 - state:hpbl2d,heat2d,evap2d,rc2d +package gfsedmfscheme bl_pbl_physics==3 - state:hpbl2d,heat2d,evap2d package qnsepblscheme bl_pbl_physics==4 - - package acmpblscheme bl_pbl_physics==7 - - package boulacscheme bl_pbl_physics==8 - - @@ -1765,9 +1811,9 @@ package fitchscheme windfarm_opt==1 - - package kfetascheme cu_physics==1 - - package bmjscheme cu_physics==2 - - package gdscheme cu_physics==93 - - -package sasscheme cu_physics==84 - state:hpbl2d,heat2d,evap2d -package meso_sas cu_physics==85 - state:hpbl2d,heat2d,evap2d -package osasscheme cu_physics==4 - state:randstate1,randstate2,randstate3,randstate4,random +package sasscheme cu_physics==94 - state:hpbl2d,heat2d,evap2d +package scalesasscheme cu_physics==4 - state:hpbl2d,heat2d,evap2d +package osasscheme cu_physics==95 - state:randstate1,randstate2,randstate3,randstate4,random package g3scheme cu_physics==5 - - package gfscheme cu_physics==3 - - package camzmscheme cu_physics==7 - - @@ -1848,7 +1894,7 @@ halo HALO_NMM_INIT_5 dyn_nmm 120:CPGFU,CURV,FCP halo HALO_NMM_INIT_6 dyn_nmm 120:FDIV,FAD,F halo HALO_NMM_INIT_7 dyn_nmm 120:DDMPU,DDMPV,GLAT halo HALO_NMM_INIT_8 dyn_nmm 120:GLON,EPSR,TG -halo HALO_NMM_INIT_9 dyn_nmm 120:GFFC,SST,ALBASE +halo HALO_NMM_INIT_9 dyn_nmm 120:GFFC,SST,ALBASE,SCURX,SCURY,CHARN,MSANG #halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV,IVGTYP halo HALO_NMM_INIT_10 dyn_nmm 120:HDAC,HDACV #halo HALO_NMM_INIT_11 dyn_nmm 120:ISLTYP,ISLOPE,VEGFRC @@ -1912,7 +1958,7 @@ halo HALO_NMM_TURBL_B dyn_nmm 8:dudt,dvdt # following halos added for nesting purpose (gopal's doing): halo HALO_NMM_TRACK dyn_nmm 120:sm,pdyn,mslp,sqws -halo HALO_NMM_FORCE_DOWN_SST dyn_nmm 120:sst +halo HALO_NMM_FORCE_DOWN_SST dyn_nmm 120:sst,scurx,scury,charn,msang halo HALO_NMM_WEIGHTS dyn_nmm 48:IIH,JJH,HBWGT1,HBWGT2,HBWGT3,HBWGT4,IIV,JJV,VBWGT1,VBWGT2,VBWGT3,VBWGT4,HNEAR_I,HNEAR_J #halo HALO_NMM_FORCE_DOWN1 dyn_nmm 24:t,u,v,q,q2,cwm,pint,pd,hres_fis,fis,pdyn_parent,pdyn_smooth diff --git a/wrfv2_fire/Registry/Registry.wrfvar b/wrfv2_fire/Registry/Registry.wrfvar index 70d2119a..aa3c5bba 100644 --- a/wrfv2_fire/Registry/Registry.wrfvar +++ b/wrfv2_fire/Registry/Registry.wrfvar @@ -3,6 +3,7 @@ include registry.dimspec include Registry.EM_COMMON.var include registry.io_boilerplate include registry.var +include registry.hyb_coord state real - ijkft a_scalar 1 - - - state real - ijkft g_scalar 1 - - - diff --git a/wrfv2_fire/Registry/registry.afwa b/wrfv2_fire/Registry/registry.afwa index 9af2da32..2821b70a 100644 --- a/wrfv2_fire/Registry/registry.afwa +++ b/wrfv2_fire/Registry/registry.afwa @@ -18,7 +18,6 @@ rconfig integer afwa_cloud_opt namelist,afwa max_domains 0 rconfig integer afwa_therm_opt namelist,afwa max_domains 0 rh "afwa_therm_opt" "AFWA Diagnostic: Thermal indices option, 1: on" "" rconfig integer afwa_turb_opt namelist,afwa max_domains 0 rh "afwa_turb_opt" "AFWA Diagnostic: Turbulence option, 1: on" "" rconfig integer afwa_buoy_opt namelist,afwa max_domains 0 rh "afwa_buoy_opt" "AFWA Diagnostic: Buoyancy option, 1: on" "" -rconfig integer afwa_hailcast_opt namelist,afwa max_domains 0 rh "afwa_hailcast_opt" "AFWA Diagnostic: Hailcast option, 1: on" "" rconfig real afwa_ptype_ccn_tmp namelist,afwa 1 264.15 h "afwa_ptype_ccn_tmp" "AFWA Diagnostic: CCN temperature for precipitation type calculation" "K" rconfig real afwa_ptype_tot_melt namelist,afwa 1 50.0 h "afwa_ptype_tot_melt" "AFWA Diagnostic: Total melting energy for precipitation type calculation" "J kg-1" rconfig integer afwa_bad_data_check namelist,afwa 1 0 r "afwa_bad_data_check" "AFWA Diagnostic: Stop model when bogus data is found (eg U>300m/s), 1: on" "" @@ -83,15 +82,6 @@ state real MIDRH_MIN_OLD ij misc 1 - r state real AFWA_HAIL ij misc 1 - rh02 "AFWA_HAIL" "AFWA Diagnostic: Hail Diameter (Weibull)" "mm" state real AFWA_LLWS ij misc 1 - rh02 "AFWA_LLWS" "AFWA Diagnostic: 0-2000 ft wind shear" "m s-1" state real AFWA_TORNADO ij misc 1 - rh02 "AFWA_TORNADO" "AFWA Diagnostic: Tornado wind speed (Weibull)" "m s-1" -state real AFWA_HAIL_NEW1 ij misc 1 - - "AFWA_HAIL_NEW1" "AFWA Diagnostic: New Hail Diameter, 1st rank order" "mm" -state real AFWA_HAIL_NEW2 ij misc 1 - - "AFWA_HAIL_NEW2" "AFWA Diagnostic: New Hail Diameter, 2nd rank order" "mm" -state real AFWA_HAIL_NEW3 ij misc 1 - - "AFWA_HAIL_NEW3" "AFWA Diagnostic: New Hail Diameter, 3rd rank order" "mm" -state real AFWA_HAIL_NEW4 ij misc 1 - - "AFWA_HAIL_NEW4" "AFWA Diagnostic: New Hail Diameter, 4th rank order" "mm" -state real AFWA_HAIL_NEW5 ij misc 1 - - "AFWA_HAIL_NEW5" "AFWA Diagnostic: New Hail Diameter, 5th rank order" "mm" -state real AFWA_HAIL_NEWMEAN ij misc 1 - rh02 "AFWA_HAIL_NEWMEAN" "AFWA Diagnostic: New Mean Hail Diameter (Selin)" "mm" -state real AFWA_HAIL_NEWSTD ij misc 1 - rh02 "AFWA_HAIL_NEWSTD" "AFWA Diagnostic: New Stand. Dev. Hail Diameter (Selin)" "mm" -state real WUP_MASK ij misc 1 - r "WUP_MASK" "Updraft mask, 1 if > 10m/s" "" -state real WDUR ij misc 1 - r "WDUR" "Updraft duration" "sec" state real TORNADO_MASK ij misc 1 - r "TORNADO_MASK" "Tornado mask, 1 if AFWA tornado > 0" "" state real TORNADO_DUR ij misc 1 - r "TORNADO_DUR" "Tornado duration" "sec" @@ -101,14 +91,13 @@ package afwa_diag afwa_diag_opt==1 - state:afwa_ms package afwa_ptype afwa_ptype_opt==1 - state:afwa_precip,afwa_totprecip,afwa_rain,afwa_snow,afwa_ice,afwa_fzra,afwa_snowfall package afwa_vil afwa_vil_opt==1 - state:vil,radarvil package afwa_radar afwa_radar_opt==1 - state:echotop,refd_com,refd -package afwa_severe afwa_severe_opt==1 - state:w_up_max,w_dn_max,tcoli_max,up_heli_max,grpl_flx_max,w_mean,afwa_hail,afwa_cape,afwa_zlfc,afwa_plfc,wup_mask,wdur,tornado_mask,tornado_dur,midrh_min,midrh_min_old,afwa_lidx,afwa_cin,afwa_tornado,afwa_llws +package afwa_severe afwa_severe_opt==1 - state:w_up_max,w_dn_max,tcoli_max,up_heli_max,grpl_flx_max,w_mean,afwa_hail,afwa_cape,afwa_zlfc,afwa_plfc,tornado_mask,tornado_dur,midrh_min,midrh_min_old,afwa_lidx,afwa_cin,afwa_tornado,afwa_llws package afwa_icing afwa_icing_opt==1 - state:fzlev,icingtop,icingbot,qicing_lg,qicing_sm,icing_lg,icing_sm,qicing_lg_max,qicing_sm_max package afwa_cloud afwa_cloud_opt==1 - state:afwa_cloud,afwa_cloud_ceil package afwa_vis afwa_vis_opt==1 - state:afwa_vis,afwa_vis_dust,afwa_vis_alpha package afwa_therm afwa_therm_opt==1 - state:afwa_heatidx,afwa_wchill,afwa_fits package afwa_turb afwa_turb_opt==1 - state:afwa_turb,afwa_llturb,afwa_llturblgt,afwa_llturbmdt,afwa_llturbsvr,afwa_tlyrbot,afwa_tlyrtop package afwa_buoy afwa_buoy_opt==1 - state:afwa_cape,afwa_zlfc,afwa_plfc,afwa_lidx,afwa_cape_mu,afwa_cin,afwa_cin_mu -package afwa_hailcast afwa_hailcast_opt==1 - state:afwa_hail_newmean,afwa_hail_newstd,afwa_hail_new1,afwa_hail_new2,afwa_hail_new3,afwa_hail_new4,afwa_hail_new5 -# For AFWA Diagnostics 1-d hail model (Selin) -halo HALO_EM_PHYS_W dyn_em 8:wup_mask, wdur, tornado_mask, tornado_dur +# For AFWA Diagnostics +halo HALO_EM_PHYS_W dyn_em 8:tornado_mask, tornado_dur diff --git a/wrfv2_fire/Registry/registry.chem b/wrfv2_fire/Registry/registry.chem index 32091f49..568a0f4d 100644 --- a/wrfv2_fire/Registry/registry.chem +++ b/wrfv2_fire/Registry/registry.chem @@ -67,8 +67,8 @@ state real e_ald i+jf emis_ant 1 Z i5r "E_A state real e_ket i+jf emis_ant 1 Z i5r "E_KET" "EMISSIONS" "mol km^-2 hr^-1" state real e_ora2 i+jf emis_ant 1 Z i5r "E_ORA2" "EMISSIONS" "mol km^-2 hr^-1" state real e_nh3 i+jf emis_ant 1 Z i5r "E_NH3" "EMISSIONS" "mol km^-2 hr^-1" -state real e_pm_25 i+jf emis_ant 1 Z i5r "E_PM_25" "EMISSIONS" "mol km^-2 hr^-1" -state real e_pm_10 i+jf emis_ant 1 Z i5r "E_PM_10" "EMISSIONS" "mol km^-2 hr^-1" +state real e_pm_25 i+jf emis_ant 1 Z i5r "E_PM_25" "EMISSIONS" "ug/m3 m/s" +state real e_pm_10 i+jf emis_ant 1 Z i5r "E_PM_10" "EMISSIONS" "ug/m3 m/s" state real e_pm25i i+jf emis_ant 1 Z i5r "E_PM25I" "EMISSION RATE OF UNIDEN. PM2.5 MASS" "ug/m3 m/s" state real e_pm25j i+jf emis_ant 1 Z i5r "E_PM25J" "EMISSION RATE OF J-MODE UNIDEN. PM2.5 MASS" "ug/m3 m/s" state real e_eci i+jf emis_ant 1 Z i5r "E_ECI" "EMISSION RATE OF I-MODE EC" "ug/m3 m/s" @@ -1041,7 +1041,6 @@ state integer num_vert_mix - misc - - r "n # # Wet deposition # - state real wd_so4_sc ij misc 1 - rdu "wd_so4_sc" "SO4 surface wet deposition, accumulated (Sc)" "mmol/m2" state real wd_no3_sc ij misc 1 - rdu "wd_no3_sc" "NO3 surface wet deposition, accumulated (Sc)" "mmol/m2" # added wet deposition totals for NH4 and OA for MOZART coupled version @@ -1092,179 +1091,179 @@ state real asoa ikj misc 1 - r "ASO state real dms_0 ij misc 1 - i08rh "DMS_0 " "dms oceanic concentrations" "nM/L" #Diagnostic Aerosol species -state real hoa_a01 ikj misc 1 - r "hoa_a01" "hoa_a01" "ug m^-3" -state real hoa_a02 ikj misc 1 - r "hoa_a02" "hoa_a02" "ug m^-3" -state real hoa_a03 ikj misc 1 - r "hoa_a03" "hoa_a03" "ug m^-3" -state real hoa_a04 ikj misc 1 - r "hoa_a04" "hoa_a04" "ug m^-3" -state real hoa_a05 ikj misc 1 - r "hoa_a05" "hoa_a05" "ug m^-3" -state real hoa_a06 ikj misc 1 - r "hoa_a06" "hoa_a06" "ug m^-3" -state real hoa_a07 ikj misc 1 - r "hoa_a07" "hoa_a07" "ug m^-3" -state real hoa_a08 ikj misc 1 - r "hoa_a08" "hoa_a08" "ug m^-3" - -state real soa_a01 ikj misc 1 - r "soa_a01" "soa_a01" "ug m^-3" -state real soa_a02 ikj misc 1 - r "soa_a02" "soa_a02" "ug m^-3" -state real soa_a03 ikj misc 1 - r "soa_a03" "soa_a03" "ug m^-3" -state real soa_a04 ikj misc 1 - r "soa_a04" "soa_a04" "ug m^-3" -state real soa_a05 ikj misc 1 - r "soa_a05" "soa_a05" "ug m^-3" -state real soa_a06 ikj misc 1 - r "soa_a06" "soa_a06" "ug m^-3" -state real soa_a07 ikj misc 1 - r "soa_a07" "soa_a07" "ug m^-3" -state real soa_a08 ikj misc 1 - r "soa_a08" "soa_a08" "ug m^-3" - -state real bboa_a01 ikj misc 1 - r "bboa_a01" "bboa_a01" "ug m^-3" -state real bboa_a02 ikj misc 1 - r "bboa_a02" "bboa_a02" "ug m^-3" -state real bboa_a03 ikj misc 1 - r "bboa_a03" "bboa_a03" "ug m^-3" -state real bboa_a04 ikj misc 1 - r "bboa_a04" "bboa_a04" "ug m^-3" -state real bboa_a05 ikj misc 1 - r "bboa_a05" "bboa_a05" "ug m^-3" -state real bboa_a06 ikj misc 1 - r "bboa_a06" "bboa_a06" "ug m^-3" -state real bboa_a07 ikj misc 1 - r "bboa_a07" "bboa_a07" "ug m^-3" -state real bboa_a08 ikj misc 1 - r "bboa_a08" "bboa_a08" "ug m^-3" - -state real bbsoa_a01 ikj misc 1 - r "bbsoa_a01" "bbsoa_a01" "ug m^-3" -state real bbsoa_a02 ikj misc 1 - r "bbsoa_a02" "bbsoa_a02" "ug m^-3" -state real bbsoa_a03 ikj misc 1 - r "bbsoa_a03" "bbsoa_a03" "ug m^-3" -state real bbsoa_a04 ikj misc 1 - r "bbsoa_a04" "bbsoa_a04" "ug m^-3" -state real bbsoa_a05 ikj misc 1 - r "bbsoa_a05" "bbsoa_a05" "ug m^-3" -state real bbsoa_a06 ikj misc 1 - r "bbsoa_a06" "bbsoa_a06" "ug m^-3" -state real bbsoa_a07 ikj misc 1 - r "bbsoa_a07" "bbsoa_a07" "ug m^-3" -state real bbsoa_a08 ikj misc 1 - r "bbsoa_a08" "bbsoa_a08" "ug m^-3" - -state real hsoa_a01 ikj misc 1 - r "hsoa_a01" "hsoa_a01" "ug m^-3" -state real hsoa_a02 ikj misc 1 - r "hsoa_a02" "hsoa_a02" "ug m^-3" -state real hsoa_a03 ikj misc 1 - r "hsoa_a03" "hsoa_a03" "ug m^-3" -state real hsoa_a04 ikj misc 1 - r "hsoa_a04" "hsoa_a04" "ug m^-3" -state real hsoa_a05 ikj misc 1 - r "hsoa_a05" "hsoa_a05" "ug m^-3" -state real hsoa_a06 ikj misc 1 - r "hsoa_a06" "hsoa_a06" "ug m^-3" -state real hsoa_a07 ikj misc 1 - r "hsoa_a07" "hsoa_a07" "ug m^-3" -state real hsoa_a08 ikj misc 1 - r "hsoa_a08" "hsoa_a08" "ug m^-3" - -state real biog_a01 ikj misc 1 - r "biog_a01" "biog_a01" "ug m^-3" -state real biog_a02 ikj misc 1 - r "biog_a02" "biog_a02" "ug m^-3" -state real biog_a03 ikj misc 1 - r "biog_a03" "biog_a03" "ug m^-3" -state real biog_a04 ikj misc 1 - r "biog_a04" "biog_a04" "ug m^-3" -state real biog_a05 ikj misc 1 - r "biog_a05" "biog_a05" "ug m^-3" -state real biog_a06 ikj misc 1 - r "biog_a06" "biog_a06" "ug m^-3" -state real biog_a07 ikj misc 1 - r "biog_a07" "biog_a07" "ug m^-3" -state real biog_a08 ikj misc 1 - r "biog_a08" "biog_a08" "ug m^-3" - -state real arosoa_a01 ikj misc 1 - r "arosoa_a01" "arosoa_a01" "ug m^-3" -state real arosoa_a02 ikj misc 1 - r "arosoa_a02" "arosoa_a02" "ug m^-3" -state real arosoa_a03 ikj misc 1 - r "arosoa_a03" "arosoa_a03" "ug m^-3" -state real arosoa_a04 ikj misc 1 - r "arosoa_a04" "arosoa_a04" "ug m^-3" -state real arosoa_a05 ikj misc 1 - r "arosoa_a05" "arosoa_a05" "ug m^-3" -state real arosoa_a06 ikj misc 1 - r "arosoa_a06" "arosoa_a06" "ug m^-3" -state real arosoa_a07 ikj misc 1 - r "arosoa_a07" "arosoa_a07" "ug m^-3" -state real arosoa_a08 ikj misc 1 - r "arosoa_a08" "arosoa_a08" "ug m^-3" - -state real totoa_a01 ikj misc 1 - r "totoa_a01" "totoa_a01" "ug m^-3" -state real totoa_a02 ikj misc 1 - r "totoa_a02" "totoa_a02" "ug m^-3" -state real totoa_a03 ikj misc 1 - r "totoa_a03" "totoa_a03" "ug m^-3" -state real totoa_a04 ikj misc 1 - r "totoa_a04" "totoa_a04" "ug m^-3" -state real totoa_a05 ikj misc 1 - r "totoa_a05" "totoa_a05" "ug m^-3" -state real totoa_a06 ikj misc 1 - r "totoa_a06" "totoa_a06" "ug m^-3" -state real totoa_a07 ikj misc 1 - r "totoa_a07" "totoa_a07" "ug m^-3" -state real totoa_a08 ikj misc 1 - r "totoa_a08" "totoa_a08" "ug m^-3" - -state real hsoa_c ikj misc 1 - r "hsoa_c" "hsoa_c" "ug m^-3" -state real hsoa_o ikj misc 1 - r "hsoa_o" "hsoa_o" "ug m^-3" -state real bbsoa_c ikj misc 1 - r "bbsoa_c" "bbsoa_c" "ug m^-3" -state real bbsoa_o ikj misc 1 - r "bbsoa_o" "bbsoa_o" "ug m^-3" -state real biog_v1 ikj misc 1 - r "biog_v1" "biog_v1" "ug m^-3" -state real biog_v2 ikj misc 1 - r "biog_v2" "biog_v2" "ug m^-3" -state real biog_v3 ikj misc 1 - r "biog_v3" "biog_v3" "ug m^-3" -state real biog_v4 ikj misc 1 - r "biog_v4" "biog_v4" "ug m^-3" -state real ant_v1 ikj misc 1 - r "ant_v1" "ant_v1" "ug m^-3" -state real ant_v2 ikj misc 1 - r "ant_v2" "ant_v2" "ug m^-3" -state real ant_v3 ikj misc 1 - r "ant_v3" "ant_v3" "ug m^-3" -state real ant_v4 ikj misc 1 - r "ant_v4" "ant_v4" "ug m^-3" +state real hoa_a01 ikj misc 1 - - "hoa_a01" "hoa_a01" "ug m^-3" +state real hoa_a02 ikj misc 1 - - "hoa_a02" "hoa_a02" "ug m^-3" +state real hoa_a03 ikj misc 1 - - "hoa_a03" "hoa_a03" "ug m^-3" +state real hoa_a04 ikj misc 1 - - "hoa_a04" "hoa_a04" "ug m^-3" +state real hoa_a05 ikj misc 1 - - "hoa_a05" "hoa_a05" "ug m^-3" +state real hoa_a06 ikj misc 1 - - "hoa_a06" "hoa_a06" "ug m^-3" +state real hoa_a07 ikj misc 1 - - "hoa_a07" "hoa_a07" "ug m^-3" +state real hoa_a08 ikj misc 1 - - "hoa_a08" "hoa_a08" "ug m^-3" + +state real soa_a01 ikj misc 1 - - "soa_a01" "soa_a01" "ug m^-3" +state real soa_a02 ikj misc 1 - - "soa_a02" "soa_a02" "ug m^-3" +state real soa_a03 ikj misc 1 - - "soa_a03" "soa_a03" "ug m^-3" +state real soa_a04 ikj misc 1 - - "soa_a04" "soa_a04" "ug m^-3" +state real soa_a05 ikj misc 1 - - "soa_a05" "soa_a05" "ug m^-3" +state real soa_a06 ikj misc 1 - - "soa_a06" "soa_a06" "ug m^-3" +state real soa_a07 ikj misc 1 - - "soa_a07" "soa_a07" "ug m^-3" +state real soa_a08 ikj misc 1 - - "soa_a08" "soa_a08" "ug m^-3" + +state real bboa_a01 ikj misc 1 - - "bboa_a01" "bboa_a01" "ug m^-3" +state real bboa_a02 ikj misc 1 - - "bboa_a02" "bboa_a02" "ug m^-3" +state real bboa_a03 ikj misc 1 - - "bboa_a03" "bboa_a03" "ug m^-3" +state real bboa_a04 ikj misc 1 - - "bboa_a04" "bboa_a04" "ug m^-3" +state real bboa_a05 ikj misc 1 - - "bboa_a05" "bboa_a05" "ug m^-3" +state real bboa_a06 ikj misc 1 - - "bboa_a06" "bboa_a06" "ug m^-3" +state real bboa_a07 ikj misc 1 - - "bboa_a07" "bboa_a07" "ug m^-3" +state real bboa_a08 ikj misc 1 - - "bboa_a08" "bboa_a08" "ug m^-3" + +state real bbsoa_a01 ikj misc 1 - - "bbsoa_a01" "bbsoa_a01" "ug m^-3" +state real bbsoa_a02 ikj misc 1 - - "bbsoa_a02" "bbsoa_a02" "ug m^-3" +state real bbsoa_a03 ikj misc 1 - - "bbsoa_a03" "bbsoa_a03" "ug m^-3" +state real bbsoa_a04 ikj misc 1 - - "bbsoa_a04" "bbsoa_a04" "ug m^-3" +state real bbsoa_a05 ikj misc 1 - - "bbsoa_a05" "bbsoa_a05" "ug m^-3" +state real bbsoa_a06 ikj misc 1 - - "bbsoa_a06" "bbsoa_a06" "ug m^-3" +state real bbsoa_a07 ikj misc 1 - - "bbsoa_a07" "bbsoa_a07" "ug m^-3" +state real bbsoa_a08 ikj misc 1 - - "bbsoa_a08" "bbsoa_a08" "ug m^-3" + +state real hsoa_a01 ikj misc 1 - - "hsoa_a01" "hsoa_a01" "ug m^-3" +state real hsoa_a02 ikj misc 1 - - "hsoa_a02" "hsoa_a02" "ug m^-3" +state real hsoa_a03 ikj misc 1 - - "hsoa_a03" "hsoa_a03" "ug m^-3" +state real hsoa_a04 ikj misc 1 - - "hsoa_a04" "hsoa_a04" "ug m^-3" +state real hsoa_a05 ikj misc 1 - - "hsoa_a05" "hsoa_a05" "ug m^-3" +state real hsoa_a06 ikj misc 1 - - "hsoa_a06" "hsoa_a06" "ug m^-3" +state real hsoa_a07 ikj misc 1 - - "hsoa_a07" "hsoa_a07" "ug m^-3" +state real hsoa_a08 ikj misc 1 - - "hsoa_a08" "hsoa_a08" "ug m^-3" + +state real biog_a01 ikj misc 1 - - "biog_a01" "biog_a01" "ug m^-3" +state real biog_a02 ikj misc 1 - - "biog_a02" "biog_a02" "ug m^-3" +state real biog_a03 ikj misc 1 - - "biog_a03" "biog_a03" "ug m^-3" +state real biog_a04 ikj misc 1 - - "biog_a04" "biog_a04" "ug m^-3" +state real biog_a05 ikj misc 1 - - "biog_a05" "biog_a05" "ug m^-3" +state real biog_a06 ikj misc 1 - - "biog_a06" "biog_a06" "ug m^-3" +state real biog_a07 ikj misc 1 - - "biog_a07" "biog_a07" "ug m^-3" +state real biog_a08 ikj misc 1 - - "biog_a08" "biog_a08" "ug m^-3" + +state real arosoa_a01 ikj misc 1 - - "arosoa_a01" "arosoa_a01" "ug m^-3" +state real arosoa_a02 ikj misc 1 - - "arosoa_a02" "arosoa_a02" "ug m^-3" +state real arosoa_a03 ikj misc 1 - - "arosoa_a03" "arosoa_a03" "ug m^-3" +state real arosoa_a04 ikj misc 1 - - "arosoa_a04" "arosoa_a04" "ug m^-3" +state real arosoa_a05 ikj misc 1 - - "arosoa_a05" "arosoa_a05" "ug m^-3" +state real arosoa_a06 ikj misc 1 - - "arosoa_a06" "arosoa_a06" "ug m^-3" +state real arosoa_a07 ikj misc 1 - - "arosoa_a07" "arosoa_a07" "ug m^-3" +state real arosoa_a08 ikj misc 1 - - "arosoa_a08" "arosoa_a08" "ug m^-3" + +state real totoa_a01 ikj misc 1 - r "totoa_a01" "totoa_a01" "ug m^-3" +state real totoa_a02 ikj misc 1 - r "totoa_a02" "totoa_a02" "ug m^-3" +state real totoa_a03 ikj misc 1 - r "totoa_a03" "totoa_a03" "ug m^-3" +state real totoa_a04 ikj misc 1 - r "totoa_a04" "totoa_a04" "ug m^-3" +state real totoa_a05 ikj misc 1 - r "totoa_a05" "totoa_a05" "ug m^-3" +state real totoa_a06 ikj misc 1 - r "totoa_a06" "totoa_a06" "ug m^-3" +state real totoa_a07 ikj misc 1 - r "totoa_a07" "totoa_a07" "ug m^-3" +state real totoa_a08 ikj misc 1 - r "totoa_a08" "totoa_a08" "ug m^-3" + +state real hsoa_c ikj misc 1 - - "hsoa_c" "hsoa_c" "ug m^-3" +state real hsoa_o ikj misc 1 - - "hsoa_o" "hsoa_o" "ug m^-3" +state real bbsoa_c ikj misc 1 - - "bbsoa_c" "bbsoa_c" "ug m^-3" +state real bbsoa_o ikj misc 1 - - "bbsoa_o" "bbsoa_o" "ug m^-3" +state real biog_v1 ikj misc 1 - - "biog_v1" "biog_v1" "ug m^-3" +state real biog_v2 ikj misc 1 - - "biog_v2" "biog_v2" "ug m^-3" +state real biog_v3 ikj misc 1 - - "biog_v3" "biog_v3" "ug m^-3" +state real biog_v4 ikj misc 1 - - "biog_v4" "biog_v4" "ug m^-3" +state real ant_v1 ikj misc 1 - - "ant_v1" "ant_v1" "ug m^-3" +state real ant_v2 ikj misc 1 - - "ant_v2" "ant_v2" "ug m^-3" +state real ant_v3 ikj misc 1 - - "ant_v3" "ant_v3" "ug m^-3" +state real ant_v4 ikj misc 1 - - "ant_v4" "ant_v4" "ug m^-3" + state integer vbs_nbin v misc 1 - r "vbs_nbin" "vbs_nbin" "" #Diagnostic Aerosol species for cloud borne species -state real hoa_cw01 ikj misc 1 - r "hoa_cw01" "hoa_cw01" "ug m^-3" -state real hoa_cw02 ikj misc 1 - r "hoa_cw02" "hoa_cw02" "ug m^-3" -state real hoa_cw03 ikj misc 1 - r "hoa_cw03" "hoa_cw03" "ug m^-3" -state real hoa_cw04 ikj misc 1 - r "hoa_cw04" "hoa_cw04" "ug m^-3" -state real hoa_cw05 ikj misc 1 - r "hoa_cw05" "hoa_cw05" "ug m^-3" -state real hoa_cw06 ikj misc 1 - r "hoa_cw06" "hoa_cw06" "ug m^-3" -state real hoa_cw07 ikj misc 1 - r "hoa_cw07" "hoa_cw07" "ug m^-3" -state real hoa_cw08 ikj misc 1 - r "hoa_cw08" "hoa_cw08" "ug m^-3" - -state real soa_cw01 ikj misc 1 - r "soa_cw01" "soa_cw01" "ug m^-3" -state real soa_cw02 ikj misc 1 - r "soa_cw02" "soa_cw02" "ug m^-3" -state real soa_cw03 ikj misc 1 - r "soa_cw03" "soa_cw03" "ug m^-3" -state real soa_cw04 ikj misc 1 - r "soa_cw04" "soa_cw04" "ug m^-3" -state real soa_cw05 ikj misc 1 - r "soa_cw05" "soa_cw05" "ug m^-3" -state real soa_cw06 ikj misc 1 - r "soa_cw06" "soa_cw06" "ug m^-3" -state real soa_cw07 ikj misc 1 - r "soa_cw07" "soa_cw07" "ug m^-3" -state real soa_cw08 ikj misc 1 - r "soa_cw08" "soa_cw08" "ug m^-3" - -state real bboa_cw01 ikj misc 1 - r "bboa_cw01" "bboa_cw01" "ug m^-3" -state real bboa_cw02 ikj misc 1 - r "bboa_cw02" "bboa_cw02" "ug m^-3" -state real bboa_cw03 ikj misc 1 - r "bboa_cw03" "bboa_cw03" "ug m^-3" -state real bboa_cw04 ikj misc 1 - r "bboa_cw04" "bboa_cw04" "ug m^-3" -state real bboa_cw05 ikj misc 1 - r "bboa_cw05" "bboa_cw05" "ug m^-3" -state real bboa_cw06 ikj misc 1 - r "bboa_cw06" "bboa_cw06" "ug m^-3" -state real bboa_cw07 ikj misc 1 - r "bboa_cw07" "bboa_cw07" "ug m^-3" -state real bboa_cw08 ikj misc 1 - r "bboa_cw08" "bboa_cw08" "ug m^-3" - -state real bbsoa_cw01 ikj misc 1 - r "bbsoa_cw01" "bbsoa_cw01" "ug m^-3" -state real bbsoa_cw02 ikj misc 1 - r "bbsoa_cw02" "bbsoa_cw02" "ug m^-3" -state real bbsoa_cw03 ikj misc 1 - r "bbsoa_cw03" "bbsoa_cw03" "ug m^-3" -state real bbsoa_cw04 ikj misc 1 - r "bbsoa_cw04" "bbsoa_cw04" "ug m^-3" -state real bbsoa_cw05 ikj misc 1 - r "bbsoa_cw05" "bbsoa_cw05" "ug m^-3" -state real bbsoa_cw06 ikj misc 1 - r "bbsoa_cw06" "bbsoa_cw06" "ug m^-3" -state real bbsoa_cw07 ikj misc 1 - r "bbsoa_cw07" "bbsoa_cw07" "ug m^-3" -state real bbsoa_cw08 ikj misc 1 - r "bbsoa_cw08" "bbsoa_cw08" "ug m^-3" - -state real hsoa_cw01 ikj misc 1 - r "hsoa_cw01" "hsoa_cw01" "ug m^-3" -state real hsoa_cw02 ikj misc 1 - r "hsoa_cw02" "hsoa_cw02" "ug m^-3" -state real hsoa_cw03 ikj misc 1 - r "hsoa_cw03" "hsoa_cw03" "ug m^-3" -state real hsoa_cw04 ikj misc 1 - r "hsoa_cw04" "hsoa_cw04" "ug m^-3" -state real hsoa_cw05 ikj misc 1 - r "hsoa_cw05" "hsoa_cw05" "ug m^-3" -state real hsoa_cw06 ikj misc 1 - r "hsoa_cw06" "hsoa_cw06" "ug m^-3" -state real hsoa_cw07 ikj misc 1 - r "hsoa_cw07" "hsoa_cw07" "ug m^-3" -state real hsoa_cw08 ikj misc 1 - r "hsoa_cw08" "hsoa_cw08" "ug m^-3" - -state real biog_cw01 ikj misc 1 - r "biog_cw01" "biog_cw01" "ug m^-3" -state real biog_cw02 ikj misc 1 - r "biog_cw02" "biog_cw02" "ug m^-3" -state real biog_cw03 ikj misc 1 - r "biog_cw03" "biog_cw03" "ug m^-3" -state real biog_cw04 ikj misc 1 - r "biog_cw04" "biog_cw04" "ug m^-3" -state real biog_cw05 ikj misc 1 - r "biog_cw05" "biog_cw05" "ug m^-3" -state real biog_cw06 ikj misc 1 - r "biog_cw06" "biog_cw06" "ug m^-3" -state real biog_cw07 ikj misc 1 - r "biog_cw07" "biog_cw07" "ug m^-3" -state real biog_cw08 ikj misc 1 - r "biog_cw08" "biog_cw08" "ug m^-3" - -state real arosoa_cw01 ikj misc 1 - r "arosoa_cw01" "arosoa_cw01" "ug m^-3" -state real arosoa_cw02 ikj misc 1 - r "arosoa_cw02" "arosoa_cw02" "ug m^-3" -state real arosoa_cw03 ikj misc 1 - r "arosoa_cw03" "arosoa_cw03" "ug m^-3" -state real arosoa_cw04 ikj misc 1 - r "arosoa_cw04" "arosoa_cw04" "ug m^-3" -state real arosoa_cw05 ikj misc 1 - r "arosoa_cw05" "arosoa_cw05" "ug m^-3" -state real arosoa_cw06 ikj misc 1 - r "arosoa_cw06" "arosoa_cw06" "ug m^-3" -state real arosoa_cw07 ikj misc 1 - r "arosoa_cw07" "arosoa_cw07" "ug m^-3" -state real arosoa_cw08 ikj misc 1 - r "arosoa_cw08" "arosoa_cw08" "ug m^-3" - -state real totoa_cw01 ikj misc 1 - r "totoa_cw01" "totoa_cw01" "ug m^-3" -state real totoa_cw02 ikj misc 1 - r "totoa_cw02" "totoa_cw02" "ug m^-3" -state real totoa_cw03 ikj misc 1 - r "totoa_cw03" "totoa_cw03" "ug m^-3" -state real totoa_cw04 ikj misc 1 - r "totoa_cw04" "totoa_cw04" "ug m^-3" -state real totoa_cw05 ikj misc 1 - r "totoa_cw05" "totoa_cw05" "ug m^-3" -state real totoa_cw06 ikj misc 1 - r "totoa_cw06" "totoa_cw06" "ug m^-3" -state real totoa_cw07 ikj misc 1 - r "totoa_cw07" "totoa_cw07" "ug m^-3" -state real totoa_cw08 ikj misc 1 - r "totoa_cw08" "totoa_cw08" "ug m^-3" - -state real hsoa_cw_c ikj misc 1 - r "hsoa_cw_c" "hsoa_cw_c" "ug m^-3" -state real hsoa_cw_o ikj misc 1 - r "hsoa_cw_o" "hsoa_cw_o" "ug m^-3" -state real bbsoa_cw_c ikj misc 1 - r "bbsoa_cw_c" "bbsoa_cw_c" "ug m^-3" -state real bbsoa_cw_o ikj misc 1 - r "bbsoa_cw_o" "bbsoa_cw_o" "ug m^-3" -state real ant_cw_v1 ikj misc 1 - r "ant_cw_v1" "ant_cw_v1" "ug m^-3" -state real biog_cw_v1 ikj misc 1 - r "biog_cw_v1" "biog_cw_v1" "ug m^-3" - -state real smpa_v1 ikj misc 1 - r "smpa_v1" "smpa_v1" "ug m^-3" -state real smpbb_v1 ikj misc 1 - r "smpbb_v1" "smpbb_v1" "ug m^-3" -state real asmpsoa_a01 ikj misc 1 - r "asmpsoa_a01" "asmpsoa_a01" "ug m^-3" -state real asmpsoa_a02 ikj misc 1 - r "asmpsoa_a02" "asmpsoa_a02" "ug m^-3" -state real asmpsoa_a03 ikj misc 1 - r "asmpsoa_a03" "asmpsoa_a03" "ug m^-3" -state real asmpsoa_a04 ikj misc 1 - r "asmpsoa_a04" "asmpsoa_a04" "ug m^-3" - +state real hoa_cw01 ikj misc 1 - - "hoa_cw01" "hoa_cw01" "ug m^-3" +state real hoa_cw02 ikj misc 1 - - "hoa_cw02" "hoa_cw02" "ug m^-3" +state real hoa_cw03 ikj misc 1 - - "hoa_cw03" "hoa_cw03" "ug m^-3" +state real hoa_cw04 ikj misc 1 - - "hoa_cw04" "hoa_cw04" "ug m^-3" +state real hoa_cw05 ikj misc 1 - - "hoa_cw05" "hoa_cw05" "ug m^-3" +state real hoa_cw06 ikj misc 1 - - "hoa_cw06" "hoa_cw06" "ug m^-3" +state real hoa_cw07 ikj misc 1 - - "hoa_cw07" "hoa_cw07" "ug m^-3" +state real hoa_cw08 ikj misc 1 - - "hoa_cw08" "hoa_cw08" "ug m^-3" + +state real soa_cw01 ikj misc 1 - - "soa_cw01" "soa_cw01" "ug m^-3" +state real soa_cw02 ikj misc 1 - - "soa_cw02" "soa_cw02" "ug m^-3" +state real soa_cw03 ikj misc 1 - - "soa_cw03" "soa_cw03" "ug m^-3" +state real soa_cw04 ikj misc 1 - - "soa_cw04" "soa_cw04" "ug m^-3" +state real soa_cw05 ikj misc 1 - - "soa_cw05" "soa_cw05" "ug m^-3" +state real soa_cw06 ikj misc 1 - - "soa_cw06" "soa_cw06" "ug m^-3" +state real soa_cw07 ikj misc 1 - - "soa_cw07" "soa_cw07" "ug m^-3" +state real soa_cw08 ikj misc 1 - - "soa_cw08" "soa_cw08" "ug m^-3" + +state real bboa_cw01 ikj misc 1 - - "bboa_cw01" "bboa_cw01" "ug m^-3" +state real bboa_cw02 ikj misc 1 - - "bboa_cw02" "bboa_cw02" "ug m^-3" +state real bboa_cw03 ikj misc 1 - - "bboa_cw03" "bboa_cw03" "ug m^-3" +state real bboa_cw04 ikj misc 1 - - "bboa_cw04" "bboa_cw04" "ug m^-3" +state real bboa_cw05 ikj misc 1 - - "bboa_cw05" "bboa_cw05" "ug m^-3" +state real bboa_cw06 ikj misc 1 - - "bboa_cw06" "bboa_cw06" "ug m^-3" +state real bboa_cw07 ikj misc 1 - - "bboa_cw07" "bboa_cw07" "ug m^-3" +state real bboa_cw08 ikj misc 1 - - "bboa_cw08" "bboa_cw08" "ug m^-3" + +state real bbsoa_cw01 ikj misc 1 - - "bbsoa_cw01" "bbsoa_cw01" "ug m^-3" +state real bbsoa_cw02 ikj misc 1 - - "bbsoa_cw02" "bbsoa_cw02" "ug m^-3" +state real bbsoa_cw03 ikj misc 1 - - "bbsoa_cw03" "bbsoa_cw03" "ug m^-3" +state real bbsoa_cw04 ikj misc 1 - - "bbsoa_cw04" "bbsoa_cw04" "ug m^-3" +state real bbsoa_cw05 ikj misc 1 - - "bbsoa_cw05" "bbsoa_cw05" "ug m^-3" +state real bbsoa_cw06 ikj misc 1 - - "bbsoa_cw06" "bbsoa_cw06" "ug m^-3" +state real bbsoa_cw07 ikj misc 1 - - "bbsoa_cw07" "bbsoa_cw07" "ug m^-3" +state real bbsoa_cw08 ikj misc 1 - - "bbsoa_cw08" "bbsoa_cw08" "ug m^-3" + +state real hsoa_cw01 ikj misc 1 - - "hsoa_cw01" "hsoa_cw01" "ug m^-3" +state real hsoa_cw02 ikj misc 1 - - "hsoa_cw02" "hsoa_cw02" "ug m^-3" +state real hsoa_cw03 ikj misc 1 - - "hsoa_cw03" "hsoa_cw03" "ug m^-3" +state real hsoa_cw04 ikj misc 1 - - "hsoa_cw04" "hsoa_cw04" "ug m^-3" +state real hsoa_cw05 ikj misc 1 - - "hsoa_cw05" "hsoa_cw05" "ug m^-3" +state real hsoa_cw06 ikj misc 1 - - "hsoa_cw06" "hsoa_cw06" "ug m^-3" +state real hsoa_cw07 ikj misc 1 - - "hsoa_cw07" "hsoa_cw07" "ug m^-3" +state real hsoa_cw08 ikj misc 1 - - "hsoa_cw08" "hsoa_cw08" "ug m^-3" + +state real biog_cw01 ikj misc 1 - - "biog_cw01" "biog_cw01" "ug m^-3" +state real biog_cw02 ikj misc 1 - - "biog_cw02" "biog_cw02" "ug m^-3" +state real biog_cw03 ikj misc 1 - - "biog_cw03" "biog_cw03" "ug m^-3" +state real biog_cw04 ikj misc 1 - - "biog_cw04" "biog_cw04" "ug m^-3" +state real biog_cw05 ikj misc 1 - - "biog_cw05" "biog_cw05" "ug m^-3" +state real biog_cw06 ikj misc 1 - - "biog_cw06" "biog_cw06" "ug m^-3" +state real biog_cw07 ikj misc 1 - - "biog_cw07" "biog_cw07" "ug m^-3" +state real biog_cw08 ikj misc 1 - - "biog_cw08" "biog_cw08" "ug m^-3" + +state real arosoa_cw01 ikj misc 1 - - "arosoa_cw01" "arosoa_cw01" "ug m^-3" +state real arosoa_cw02 ikj misc 1 - - "arosoa_cw02" "arosoa_cw02" "ug m^-3" +state real arosoa_cw03 ikj misc 1 - - "arosoa_cw03" "arosoa_cw03" "ug m^-3" +state real arosoa_cw04 ikj misc 1 - - "arosoa_cw04" "arosoa_cw04" "ug m^-3" +state real arosoa_cw05 ikj misc 1 - - "arosoa_cw05" "arosoa_cw05" "ug m^-3" +state real arosoa_cw06 ikj misc 1 - - "arosoa_cw06" "arosoa_cw06" "ug m^-3" +state real arosoa_cw07 ikj misc 1 - - "arosoa_cw07" "arosoa_cw07" "ug m^-3" +state real arosoa_cw08 ikj misc 1 - - "arosoa_cw08" "arosoa_cw08" "ug m^-3" + +state real totoa_cw01 ikj misc 1 - - "totoa_cw01" "totoa_cw01" "ug m^-3" +state real totoa_cw02 ikj misc 1 - - "totoa_cw02" "totoa_cw02" "ug m^-3" +state real totoa_cw03 ikj misc 1 - - "totoa_cw03" "totoa_cw03" "ug m^-3" +state real totoa_cw04 ikj misc 1 - - "totoa_cw04" "totoa_cw04" "ug m^-3" +state real totoa_cw05 ikj misc 1 - - "totoa_cw05" "totoa_cw05" "ug m^-3" +state real totoa_cw06 ikj misc 1 - - "totoa_cw06" "totoa_cw06" "ug m^-3" +state real totoa_cw07 ikj misc 1 - - "totoa_cw07" "totoa_cw07" "ug m^-3" +state real totoa_cw08 ikj misc 1 - - "totoa_cw08" "totoa_cw08" "ug m^-3" + +state real hsoa_cw_c ikj misc 1 - - "hsoa_cw_c" "hsoa_cw_c" "ug m^-3" +state real hsoa_cw_o ikj misc 1 - - "hsoa_cw_o" "hsoa_cw_o" "ug m^-3" +state real bbsoa_cw_c ikj misc 1 - - "bbsoa_cw_c" "bbsoa_cw_c" "ug m^-3" +state real bbsoa_cw_o ikj misc 1 - - "bbsoa_cw_o" "bbsoa_cw_o" "ug m^-3" +state real ant_cw_v1 ikj misc 1 - - "ant_cw_v1" "ant_cw_v1" "ug m^-3" +state real biog_cw_v1 ikj misc 1 - - "biog_cw_v1" "biog_cw_v1" "ug m^-3" + +state real smpa_v1 ikj misc 1 - - "smpa_v1" "smpa_v1" "ug m^-3" +state real smpbb_v1 ikj misc 1 - - "smpbb_v1" "smpbb_v1" "ug m^-3" +state real asmpsoa_a01 ikj misc 1 - - "asmpsoa_a01" "asmpsoa_a01" "ug m^-3" +state real asmpsoa_a02 ikj misc 1 - - "asmpsoa_a02" "asmpsoa_a02" "ug m^-3" +state real asmpsoa_a03 ikj misc 1 - - "asmpsoa_a03" "asmpsoa_a03" "ug m^-3" +state real asmpsoa_a04 ikj misc 1 - - "asmpsoa_a04" "asmpsoa_a04" "ug m^-3" # photolysis rates state real ph_o31d ikj misc 1 - r "PHOTR2" "O31D Photolysis Rate" "min{-1}" @@ -1296,30 +1295,37 @@ state real ph_acet ikj misc 1 - r "PH state real ph_mglo ikj misc 1 - r "PHOTR103" "mglo photolysis rate" "min{-1}" state real ph_hno4_2 ikj misc 1 - r "PHOTR104" "mglo photolysis rate" "min{-1}" # mozart photolysis rates -state real ph_n2o ikj misc 1 - - "PHOTR114" "n2o photolysis rate" "min{-1}" -state real ph_pooh ikj misc 1 - - "PHOTR118" "pooh photolysis rate" "min{-1}" -state real ph_mpan ikj misc 1 - - "PHOTR119" "mpan photolysis rate" "min{-1}" -state real ph_mvk ikj misc 1 - - "PHOTR135" "mvk photolysis rate" "min{-1}" -state real ph_etooh ikj misc 1 - - "PHOTR120" "c2h5ooh photolysis rate" "min{-1}" -state real ph_prooh ikj misc 1 - - "PHOTR121" "c3h7ooh photolysis rate" "min{-1}" -state real ph_onitr ikj misc 1 - - "PHOTR122" "onitr photolysis rate" "min{-1}" -state real ph_acetol ikj misc 1 - - "PHOTR123" "hyac photolysis rate" "min{-1}" -state real ph_glyald ikj misc 1 - - "PHOTR124" "glyald photolysis rate" "min{-1}" -state real ph_hyac ikj misc 1 - - "PHOTR140" "hyac photolysis rate" "min{-1}" -state real ph_mek ikj misc 1 - - "PHOTR125" "mek photolysis rate" "min{-1}" -state real ph_open ikj misc 1 - - "PHOTR126" "bigald photolysis rate" "min{-1}" -state real ph_gly ikj misc 1 - - "PHOTR127" "glyoxal photolysis rate" "min{-1}" -state real ph_acetp ikj misc 1 - - "PHOTR128" "rooh photolysis rate" "min{-1}" -state real ph_xooh ikj misc 1 - - "PHOTR129" "xooh photolysis rate" "min{-1}" -state real ph_isooh ikj misc 1 - - "PHOTR130" "isopooh photolysis rate" "min{-1}" -state real ph_alkooh ikj misc 1 - - "PHOTR131" "alkooh photolysis rate" "min{-1}" -state real ph_mekooh ikj misc 1 - - "PHOTR132" "mekooh photolysis rate" "min{-1}" -state real ph_tolooh ikj misc 1 - - "PHOTR133" "tolooh photolysis rate" "min{-1}" -state real ph_terpooh ikj misc 1 - - "PHOTR134" "terpooh photolysis rate" "min{-1}" +state real ph_n2o ikj misc 1 - r "PHOTR114" "n2o photolysis rate" "min{-1}" +state real ph_pooh ikj misc 1 - r "PHOTR118" "pooh photolysis rate" "min{-1}" +state real ph_mpan ikj misc 1 - r "PHOTR119" "mpan photolysis rate" "min{-1}" +state real ph_mvk ikj misc 1 - r "PHOTR135" "mvk photolysis rate" "min{-1}" +state real ph_etooh ikj misc 1 - r "PHOTR120" "c2h5ooh photolysis rate" "min{-1}" +state real ph_prooh ikj misc 1 - r "PHOTR121" "c3h7ooh photolysis rate" "min{-1}" +state real ph_onitr ikj misc 1 - r "PHOTR122" "onitr photolysis rate" "min{-1}" +state real ph_acetol ikj misc 1 - r "PHOTR123" "hyac photolysis rate" "min{-1}" +state real ph_glyald ikj misc 1 - r "PHOTR124" "glyald photolysis rate" "min{-1}" +state real ph_hyac ikj misc 1 - r "PHOTR140" "hyac photolysis rate" "min{-1}" +state real ph_mek ikj misc 1 - r "PHOTR125" "mek photolysis rate" "min{-1}" +state real ph_open ikj misc 1 - r "PHOTR126" "bigald photolysis rate" "min{-1}" +state real ph_gly ikj misc 1 - r "PHOTR127" "glyoxal photolysis rate" "min{-1}" +state real ph_acetp ikj misc 1 - r "PHOTR128" "rooh photolysis rate" "min{-1}" +state real ph_xooh ikj misc 1 - r "PHOTR129" "xooh photolysis rate" "min{-1}" +state real ph_isooh ikj misc 1 - r "PHOTR130" "isopooh photolysis rate" "min{-1}" +state real ph_alkooh ikj misc 1 - r "PHOTR131" "alkooh photolysis rate" "min{-1}" +state real ph_mekooh ikj misc 1 - r "PHOTR132" "mekooh photolysis rate" "min{-1}" +state real ph_tolooh ikj misc 1 - r "PHOTR133" "tolooh photolysis rate" "min{-1}" +state real ph_terpooh ikj misc 1 - r "PHOTR134" "terpooh photolysis rate" "min{-1}" # cb05cl photolysis rates -state real ph_cl2 ikj misc 1 - h "PHOTR201" "cl2 photolysis rate" "min{-1}" -state real ph_hocl ikj misc 1 - h "PHOTR202" "hocl photolysis rate" "min{-1}" -state real ph_fmcl ikj misc 1 - h "PHOTR203" "fmcl photolysis rate" "min{-1}" +state real ph_cl2 ikj misc 1 - rh "PHOTR201" "cl2 photolysis rate" "min{-1}" +state real ph_hocl ikj misc 1 - rh "PHOTR202" "hocl photolysis rate" "min{-1}" +state real ph_fmcl ikj misc 1 - rh "PHOTR203" "fmcl photolysis rate" "min{-1}" +# photolysis rad field diagnostic variables +state real ph_par ikj misc 1 - - "ph_par" "Photosynthetic Active Radiation" "W m-2" +state real ph_erythema ikj misc 1 - - "ph_erythema" "Erythema Action Spectrum" "W m-2" +state real af_dir ikj misc 1 - - "af_dir" "actinic direct solar flux" "W m-2 nm-1" +state real af_up ikj misc 1 - - "af_up" "actinic up flux" "W m-2 nm-1" +state real af_dn ikj misc 1 - - "af_dn" "actinic down flux" "W m-2 nm-1" +state real dt_cld ikj misc 1 - - "dt_cld" "cloud optical depth" "" # # Aerosol optical properties from Mie code for rrtmg radiation @@ -1382,6 +1388,7 @@ state real l4aer ikj= misc 1 - r "L4 state real l5aer ikj= misc 1 - r "L5AER" "legendre polynomial 5" "?" state real l6aer ikj= misc 1 - r "L6AER" "legendre polynomial 6" "?" state real l7aer ikj= misc 1 - r "L7AER" "legendre polynomial 7" "?" + # chem variables for "cup" convective cloud parameterization state integer chem_cupflag ikj misc 1 - - "CHEM_CUPFLAG" "flag for cup chemistry - positive when there is cup conv. cloud chemistry at ikj" @@ -1423,7 +1430,6 @@ state real water_1to4_ic_cup ikj misc 1 - - "W state real water_5to6_ic_cup ikj misc 1 - - "WATER_5to6_IC_CUP" "interstitial sulfate (Ddry>625 nm and Ddry<2500) within convective cloud" "ug/kg-dryair" - # non-transported aerosol variables state real h2oaj ikj misc 1 - r "h2oaj" "Aerosol water conc. Acc.mode" "?" state real h2oai ikj misc 1 - r "h2oai" "Aerosol water conc. Aitken mode" "?" @@ -1483,25 +1489,25 @@ state real tbu_o ikj misc 1 - r "tbu_o" "Radi # Additional variables for CO2 and GHG options # The following variables are to run the VPRM model; The vegfra_vprm is for VPRM only and it's different than VEGFRA in wrfinput state real - i{ghgv}jf vprm_in - - - - "VPRM input fields" "" -state real vegfra_vprm i{ghgv}jf vprm_in 1 - i{15}rh "VEGFRA_VPRM" " " " " -state real evi i{ghgv}jf vprm_in 1 - i{15}rh "EVI" " " " " -state real evi_min i{ghgv}jf vprm_in 1 - i{15}rh "EVI_MIN" " " " " -state real evi_max i{ghgv}jf vprm_in 1 - i{15}rh "EVI_MAX" " " " " -state real lswi i{ghgv}jf vprm_in 1 - i{15}rh "LSWI" " " " " -state real lswi_max i{ghgv}jf vprm_in 1 - i{15}rh "LSWI_MAX" " " " " -state real lswi_min i{ghgv}jf vprm_in 1 - i{15}rh "LSWI_MIN" " " " " +state real vegfra_vprm i{ghgv}jf vprm_in 1 - i{15}r "VEGFRA_VPRM" " " " " +state real evi i{ghgv}jf vprm_in 1 - i{15}r "EVI" " " " " +state real evi_min i{ghgv}jf vprm_in 1 - i{15}r "EVI_MIN" " " " " +state real evi_max i{ghgv}jf vprm_in 1 - i{15}r "EVI_MAX" " " " " +state real lswi i{ghgv}jf vprm_in 1 - i{15}r "LSWI" " " " " +state real lswi_max i{ghgv}jf vprm_in 1 - i{15}r "LSWI_MAX" " " " " +state real lswi_min i{ghgv}jf vprm_in 1 - i{15}r "LSWI_MIN" " " " " # VPRM parameters to constrain GEE and RESP fluxes -state real rad_vprm {ghgv} misc 1 - h "RAD_VPRM" " " " " -state real lambda_vprm {ghgv} misc 1 - h "LAMBDA_VPRM" " " " " -state real alpha_vprm {ghgv} misc 1 - h "ALPHA_VPRM" " " " " -state real resp_vprm {ghgv} misc 1 - h "RESP_VPRM" " " " " +state real rad_vprm {ghgv} misc 1 - - "RAD_VPRM" " " " " +state real lambda_vprm {ghgv} misc 1 - - "LAMBDA_VPRM" " " " " +state real alpha_vprm {ghgv} misc 1 - - "ALPHA_VPRM" " " " " +state real resp_vprm {ghgv} misc 1 - - "RESP_VPRM" " " " " # Parameters and fields to run the Kaplan model state real - ivjf wet_in - - - - "Wetland input fields" "" -state real cpool ivjf wet_in 1 - i{15}rh "CPOOL" "LPJ Carbon pool" "gC/m^2" -state real wetmap ivjf wet_in 1 - i{15}rh "WETMAP" "Kaplan potential wetland map" "" -state real t_ann ivjf wet_in 1 - i{15}rh "T_ANN" "mean annual temperature" "K" +state real cpool ivjf wet_in 1 - i{15}r "CPOOL" "LPJ Carbon pool" "gC/m^2" +state real wetmap ivjf wet_in 1 - i{15}r "WETMAP" "Kaplan potential wetland map" "" +state real t_ann ivjf wet_in 1 - i{15}r "T_ANN" "mean annual temperature" "K" # Parameters to for calculating the termite emissions online state real biomt_par {ghgt} misc 1 - - "BIOMT_PAR" "biomass termite per vegetation type" "g/m^2" @@ -1652,11 +1658,7 @@ state real biog4_o ikjftb chem 1 - i0{12}rhusdf=(bd state real smpa ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "smpa" "smpa mixing ratio" "ppmv" state real smpbb ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "smpbb" "smpbb mixing ratio" "ppmv" - - - #RACM has a few more variables to those of RADM2 (ETE is equivilant to OL2 from RADM2) - state real ete ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ete" "ETE mixing ratio" "ppmv" state real co2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "co2" "CO2 mixing ratio" "ppmv" state real ch4 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "ch4" "CH4 mixing ratio" "ppmv" @@ -2034,7 +2036,6 @@ state real tracer_ens ikjftb chem 1 - i0{12}rhusdf=(bd state real - ikjftb tracer 1 - - - state real smoke ikjftb tracer 1 - irhusdf=(bdy_interp:dt) "smoke" "tracing smoke" - -#state real tr17_0 ikjftb tracer 1 - i8rhusdf=(bdy_interp:dt) "tr17_0" "tr17_0" - state real tr17_1 ikjftb tracer 1 - i8rhusdf=(bdy_interp:dt) "tr17_1" "tr17_1" - state real tr17_2 ikjftb tracer 1 - i8rhusdf=(bdy_interp:dt) "tr17_2" "tr17_2" - state real tr17_3 ikjftb tracer 1 - i8rhusdf=(bdy_interp:dt) "tr17_3" "tr17_3" - @@ -2043,7 +2044,6 @@ state real tr17_5 ikjftb tracer 1 - i8rhusdf=(bdy_i state real tr17_6 ikjftb tracer 1 - i8rhusdf=(bdy_interp:dt) "tr17_6" "tr17_6" - state real tr17_7 ikjftb tracer 1 - i8rhusdf=(bdy_interp:dt) "tr17_7" "tr17_7" - state real tr17_8 ikjftb tracer 1 - i8rhusdf=(bdy_interp:dt) "tr17_8" "tr17_8" - -#state real tr17_9 ikjftb tracer 1 - i8rhusdf=(bdy_interp:dt) "tr17_9" "tr17_9" - state real tr18_0 ikjftb tracer 1 - i8rhusdf=(bdy_interp:dt) "tr18_0" "tr18_0" - state real tr18_1 ikjftb tracer 1 - i8rhusdf=(bdy_interp:dt) "tr18_1" "tr18_1" - state real tr18_2 ikjftb tracer 1 - i8rhusdf=(bdy_interp:dt) "tr18_2" "tr18_2" - @@ -2320,9 +2320,8 @@ state real ison ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real mahp ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "mahp" "MAHP concentration" "ppm" state real mpan ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "mpan" "MPAN concentration" "ppm" state real nald ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "nald" "NALD concentration" "ppm" -#cms-- note: ison is probably quite soluble -#Additional MOSAIC aerosol variables inside the chem array... +#Additional MOSAIC aerosol variables inside the chem array... state real so4_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "so4_a01" "Sulfate, aerosol bin 01" "ug/kg-dryair" state real no3_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "no3_a01" "Nitrate, aerosol bin 01" "ug/kg-dryair" state real aro1_a01 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "aro1_a01" "ARO1, aerosol bin 01" "ug/kg-dryair" @@ -3500,9 +3499,8 @@ state real opcg1_f_c_cw08 ikjftb chem 1 - irusdf=(bdy_int state real opcg1_f_o_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "opcg1_f_o_cw08" "opcg1_f_o_cw08, aerosol bin 01" "ug/kg-dryair" state real ant1_c_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "ant1_c_cw08" "ant1_c_cw08, aerosol bin 01" "ug/kg-dryair" state real biog1_c_cw08 ikjftb chem 1 - irusdf=(bdy_interp:dt) "biog1_c_cw08" "biog1_c_cw08, aerosol bin 01" "ug/kg-dryair" - - #BSINGH -ENDS + # GOCART Aerosols state real bc1 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "BC1" "Hydrophobic Black Carbon" "ug/kg-dryair" state real bc2 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "BC2" "Hydrophilic Black Carbon" "ug/kg-dryair" @@ -3521,7 +3519,6 @@ state real seas_3 ikjftb chem 1 - i0{12}rhusdf=(bdy_ state real seas_4 ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "SEAS_4" "sea-salt size bin 4: 7.5um effective radius" "ug/kg-dryair" #Additional CAM modal aerosol variables inside the chem array... - state real soag ikjftb chem 1 - irhusdf=(bdy_interp:dt) "soag" "Gas-phase SOA" "ppmv" state real so4_a1 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "so4_a1" "Sulfate aerosol, mode 1" "ug/kg-dryair" @@ -3611,6 +3608,7 @@ state real so4_c7 ikjftb chem 1 - irhusdf=(bdy_inter state real nh4_c7 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "nh4_c7" "Ammonium aerosol, mode 7" "ug/kg-dryair" state real dst_c7 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "dst_c7" "Dust aerosol, mode 7" "ug/kg-dryair" state real num_c7 ikjftb chem 1 - irhusdf=(bdy_interp:dt) "num_c7" "Aerosol number, mode 7" "#/kg-dryair" + # KPP Mechanism from MATCH-MPI MAINZ global chemistry state real pa ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "pa" "" "" state real aca ikjftb chem 1 - i0{12}rhusdf=(bdy_interp:dt) "aca" "" "" @@ -3656,14 +3654,6 @@ state real meo2no2 ikjftb chem 1 - i0{12}rhusdf=(bdy_ #End MATCH-MPI MAINZ global chemistry -# time averaged stuff -#state integer STEPAVE_COUNT - misc 1 - r "STEPAVE_COUNT" "time steps contained in averages for convective transport" "" -#state real RAINCV_A ij misc 1 - r "RAINCV_A" "taveragd TIME-STEP CUMULUS PRECIPITATION" "mm" -#state real RAINCV_B ij misc 1 - r "RAINCV_B" "taveragd TIME-STEP CUMULUS PRECIPITATION" "mm" -#state real GD_CLOUD_A ikj misc 1 - r "GD_CLOUD_A" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" -#state real GD_CLOUD2_A ikj misc 1 - r "GD_CLOUD2_A" "taveragd cloud ice mix ratio in GD" "kg kg-1" -#state real GD_CLOUD_B ikj misc 1 - r "GD_CLOUD_B" "taveragd CLOUD WATER MIXING RAIO IN GD CLOUD" "kg kg-1" -#state real GD_CLOUD2_B ikj misc 1 - r "GD_CLOUD2_B" "taveragd cloud ice mix ratio in GD" "kg kg-1" state integer STEPBIOE - misc 1 - r "STEPBIOE" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN BIOGENIC EMIS CALLS" "NA" state integer STEPPHOT - misc 1 - r "STEPPHOT" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN PHOTOLYSIS CALLS" "NA" state integer STEPCHEM - misc 1 - r "STEPCHEM" "NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CHEM MECH CALLS" "NA" @@ -3733,14 +3723,23 @@ rconfig integer aerchem_onoff namelist,chem max_domains rconfig integer wetscav_onoff namelist,chem max_domains 0 rh "wetscav_onoff" "" "" rconfig integer dustwd_onoff namelist,chem max_domains 0 rh "dustwd_onoff" "" "" rconfig integer cldchem_onoff namelist,chem max_domains 0 rh "cldchem_onoff" "" "" +# for TUV photolysis scheme +rconfig logical is_full_tuv namelist,chem max_domains .true. rh "is_full_tuv" "" "" +rconfig real lambda_cutoff namelist,chem max_domains 250. rh "lambda_cutoff" "" "" +# for cloud handling in TUV photolysis scheme +rconfig integer cld_od_opt namelist,chem max_domains 1 rh "cld_od_opt" "" "" +rconfig integer pht_cldfrc_opt namelist,chem max_domains 1 rh "pht_cldfrc_opt" "" "" rconfig integer vertmix_onoff namelist,chem max_domains 1 rh "vertmix_onoff" "" "" rconfig integer chem_in_opt namelist,chem max_domains 0 rh "chem_in_opt" "" "" rconfig integer phot_opt namelist,chem max_domains 0 rh "phot_opt" "" "" rconfig integer gas_drydep_opt namelist,chem max_domains 1 rh "gas_drydep_opt" "" "" rconfig integer aer_drydep_opt namelist,chem max_domains 1 rh "aer_drydep_opt" "" "" rconfig integer diagnostic_chem namelist,chem max_domains 1 rh "diagnostic_chem" "" "" +rconfig integer aero_diag_opt namelist,chem max_domains 0 rh "diagnostic_aerosol" "" "" +rconfig integer aero_cw_diag_opt namelist,chem max_domains 0 rh "diagnostic_cw_aerosol" "" "" +rconfig integer kfcup_diag namelist,chem max_domains 0 rh "kfcup_daig" "" "" rconfig integer aer_aerodynres_opt namelist,chem max_domains 1 rh "aer_aerodynres_opt" "" "" -rconfig integer emiss_opt namelist,chem max_domains 4 rh "emiss_opt" "" "" +rconfig integer emiss_opt namelist,chem max_domains 0 rh "emiss_opt" "" "" rconfig integer emiss_opt_vol namelist,chem max_domains 0 rh "emiss_opt_vol" "" "" rconfig integer dust_opt namelist,chem 1 0 rh "dust_opt" "" "" rconfig integer dust_schme namelist,chem 1 2 rh "dust_schme" "" "" @@ -3785,13 +3784,13 @@ rconfig real dust_gamma namelist,chem 1 1. rh rconfig real dust_smtune namelist,chem 1 1. rh "dust_smtune" "AFWA Dust soil moisture tuning constant" "" rconfig real dust_ustune namelist,chem 1 1. rh "dust_ustune" "AFWA Dust friction velocity tuning constant" "" # Dust source region selector -rconfig integer dust_dsr namelist,chem 1 0. rh "dust_dsr" "AFWA Dust dust source region: 0 Ginoux (default), 1 DRI" "" +rconfig integer dust_dsr namelist,chem 1 0 rh "dust_dsr" "AFWA Dust dust source region: 0 Ginoux (default), 1 DRI" "" # Vegetation mask selector (to be applied to dust source region) -rconfig integer dust_veg namelist,chem 1 0. rh "dust_veg" "AFWA Dust veg. mask: 0 Ginoux, 1 12mo GreenFrac, 2 8day MODIS LAI" "" +rconfig integer dust_veg namelist,chem 1 0 rh "dust_veg" "AFWA Dust veg. mask: 0 Ginoux, 1 12mo GreenFrac, 2 8day MODIS LAI" "" # Soil texture selector -rconfig integer dust_soils namelist,chem 1 0. rh "dust_soils" "AFWA Dust clayfrac and sandfrac: 0 WRF (default), 1 NGA" "" +rconfig integer dust_soils namelist,chem 1 0 rh "dust_soils" "AFWA Dust clayfrac and sandfrac: 0 WRF (default), 1 NGA" "" # Soil moisture selector -rconfig integer dust_smois namelist,chem 1 0. rh "dust_smois" "AFWA Dust soil moisture option: 0 gravimetric, 1 volumetric" "" +rconfig integer dust_smois namelist,chem 1 0 rh "dust_smois" "AFWA Dust soil moisture option: 0 gravimetric, 1 volumetric" "" # Volcanic ash height rconfig real emiss_ash_hgt namelist,chem 1 0. rh "emiss_ash_hgt" "Volcanic ash cloud top elevation (AGL)" "" @@ -3808,6 +3807,10 @@ rconfig integer track_tuv_lev namelist,chem 1 51 # control for N2O5 heterogenenous chemistry option in MOSAIC rconfig integer n2o5_hetchem namelist,chem 1 0 rh "n2o5_hetchem" "" "" +# +# control for AF wavelength +rconfig real af_lambda_start namelist,chem max_domains 200. rh "start wavelength for AF output" "nm" "" +rconfig real af_lambda_end namelist,chem max_domains 340. rh "end wavelength for AF output" "nm" "" # CHEMISTRY PACKAGE DEFINITIONS # @@ -3817,9 +3820,6 @@ package radm2sorg chem_opt==2 - chem:so2,sulf package cbmz chem_opt==5 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,dms,msa,dmso,dmso2,ch3so2h,ch3sch2oo,ch3so2,ch3so3,ch3so2oo,ch3so2ch2oo,mtf package cbmz_bb chem_opt==6 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2 package cbmz_mosaic_4bin chem_opt==7 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04 -#Normal cbmz_mosaic_8bin package -#package cbmz_mosaic_8bin chem_opt==8 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,num_a08 -#Alternative cbmz_mosaic_8bin with dust chemistry (ca & co aerosol) package cbmz_mosaic_8bin chem_opt==8 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,num_a08,ca_a01,ca_a02,ca_a03,ca_a04,ca_a05,ca_a06,ca_a07,ca_a08,co3_a01,co3_a02,co3_a03,co3_a04,co3_a05,co3_a06,co3_a07,co3_a08 package cbmz_mosaic_4bin_aq chem_opt==9 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_cw01,no3_cw01,cl_cw01,nh4_cw01,na_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,cl_cw02,nh4_cw02,na_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,cl_cw03,nh4_cw03,na_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,cl_cw04,nh4_cw04,na_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04 package cbmz_mosaic_8bin_aq chem_opt==10 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,num_a08,so4_cw01,no3_cw01,cl_cw01,nh4_cw01,na_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,cl_cw02,nh4_cw02,na_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,cl_cw03,nh4_cw03,na_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,cl_cw04,nh4_cw04,na_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04,so4_cw05,no3_cw05,cl_cw05,nh4_cw05,na_cw05,oin_cw05,oc_cw05,bc_cw05,num_cw05,so4_cw06,no3_cw06,cl_cw06,nh4_cw06,na_cw06,oin_cw06,oc_cw06,bc_cw06,num_cw06,so4_cw07,no3_cw07,cl_cw07,nh4_cw07,na_cw07,oin_cw07,oc_cw07,bc_cw07,num_cw07,so4_cw08,no3_cw08,cl_cw08,nh4_cw08,na_cw08,oin_cw08,oc_cw08,bc_cw08,num_cw08 @@ -3886,15 +3886,11 @@ package cb05_sorg_vbs_aq_kpp chem_opt==132 - package cbmz_mosaic_kpp chem_opt==170 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,ch4,aro1,aro2,alk1,ole1,api1,api2,lim1,lim2,api,lim,isopo2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,aro1_a01,aro2_a01,alk1_a01,ole1_a01,api1_a01,api2_a01,lim1_a01,lim2_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,aro1_a02,aro2_a02,alk1_a02,ole1_a02,api1_a02,api2_a02,lim1_a02,lim2_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,aro1_a03,aro2_a03,alk1_a03,ole1_a03,api1_a03,api2_a03,lim1_a03,lim2_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,aro1_a04,aro2_a04,alk1_a04,ole1_a04,api1_a04,api2_a04,lim1_a04,lim2_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,aro1_a05,aro2_a05,alk1_a05,ole1_a05,api1_a05,api2_a05,lim1_a05,lim2_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,aro1_a06,aro2_a06,alk1_a06,ole1_a06,api1_a06,api2_a06,lim1_a06,lim2_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,aro1_a07,aro2_a07,alk1_a07,ole1_a07,api1_a07,api2_a07,lim1_a07,lim2_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,aro1_a08,aro2_a08,alk1_a08,ole1_a08,api1_a08,api2_a08,lim1_a08,lim2_a08,num_a08,ca_a01,ca_a02,ca_a03,ca_a04,ca_a05,ca_a06,ca_a07,ca_a08,co3_a01,co3_a02,co3_a03,co3_a04,co3_a05,co3_a06,co3_a07,co3_a08 - #SAPRCNOV new package, automatically created using diff_mechanisSpc_wrfRegistry.m script (pablo-saide@uiowa.edu) package saprc99_kpp chem_opt==195 - chem:o3,h2o2,no,no2,no3,n2o5,hono,hno3,hno4,so2,h2so4,co,hcho,ccho,rcho,acet,mek,hcooh,meoh,etoh,cco_oh,rco_oh,gly,mgly,bacl,cres,bald,isoprod,methacro,mvk,prod2,dcb1,dcb2,dcb3,ethene,isoprene,c2h6,c3h8,c2h2,c3h6,alk3,alk4,alk5,aro1,aro2,ole1,ole2,terp,rno3,nphe,phen,pan,pan2,pbzn,ma_pan,co2,cco_ooh,rco_o2,rco_ooh,xn,xc,ho,ho2,c_o2,cooh,rooh,ro2_r,r2o2,ro2_n,cco_o2,bzco_o2,ma_rco3,nh3,hcl,ch4 package saprc99_mosaic_4bin_vbs2_kpp chem_opt==198 - chem:o3,h2o2,no,no2,no3,n2o5,hono,hno3,hno4,so2,h2so4,co,hcho,ccho,rcho,acet,mek,hcooh,meoh,etoh,cco_oh,rco_oh,gly,mgly,bacl,cres,bald,isoprod,methacro,mvk,prod2,dcb1,dcb2,dcb3,ethene,isoprene,c2h6,c3h8,c2h2,c3h6,alk3,alk4,alk5,aro1,aro2,ole1,ole2,terp,rno3,nphe,phen,pan,pan2,pbzn,ma_pan,co2,cco_ooh,rco_o2,rco_ooh,xn,xc,ho,ho2,c_o2,cooh,rooh,ro2_r,r2o2,ro2_n,cco_o2,bzco_o2,ma_rco3,sesq,pcg1_b_c,pcg2_b_c,pcg1_b_o,pcg2_b_o,opcg1_b_c,opcg1_b_o,pcg1_f_c,pcg2_f_c,pcg1_f_o,pcg2_f_o,opcg1_f_c,opcg1_f_o,psd1,psd2,nh3,hcl,nume,den,ant1_c,ant1_o,biog1_c,biog1_o,ch4,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,pcg1_b_c_a01,pcg2_b_c_a01,pcg1_b_o_a01,pcg2_b_o_a01,opcg1_b_c_a01,opcg1_b_o_a01,pcg1_f_c_a01,pcg2_f_c_a01,pcg1_f_o_a01,pcg2_f_o_a01,opcg1_f_c_a01,opcg1_f_o_a01,ant1_c_a01,ant1_o_a01,biog1_c_a01,biog1_o_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,pcg1_b_c_a02,pcg2_b_c_a02,pcg1_b_o_a02,pcg2_b_o_a02,opcg1_b_c_a02,opcg1_b_o_a02,pcg1_f_c_a02,pcg2_f_c_a02,pcg1_f_o_a02,pcg2_f_o_a02,opcg1_f_c_a02,opcg1_f_o_a02,ant1_c_a02,ant1_o_a02,biog1_c_a02,biog1_o_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,pcg1_b_c_a03,pcg2_b_c_a03,pcg1_b_o_a03,pcg2_b_o_a03,opcg1_b_c_a03,opcg1_b_o_a03,pcg1_f_c_a03,pcg2_f_c_a03,pcg1_f_o_a03,pcg2_f_o_a03,opcg1_f_c_a03,opcg1_f_o_a03,ant1_c_a03,ant1_o_a03,biog1_c_a03,biog1_o_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,pcg1_b_c_a04,pcg2_b_c_a04,pcg1_b_o_a04,pcg2_b_o_a04,opcg1_b_c_a04,opcg1_b_o_a04,pcg1_f_c_a04,pcg2_f_c_a04,pcg1_f_o_a04,pcg2_f_o_a04,opcg1_f_c_a04,opcg1_f_o_a04,ant1_c_a04,ant1_o_a04,biog1_c_a04,biog1_o_a04,num_a04,ca_a01,ca_a02,ca_a03,ca_a04,co3_a01,co3_a02,co3_a03,co3_a04 - -# using an empirical soa scheme for anthropogenic and biomass burning sources -#package mozart_mosaic_4bin_vbs0_kpp chem_opt==201 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,c10h16,terpo2,tol,cres,to2,xoh,onit,isopn,dms,nh3,nume,den,voca,vocbb,smpa,smpbb,biog1_c,biog1_o,meko2,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,smpa_a01,smpbb_a01,biog1_c_a01,biog1_o_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,smpa_a02,smpbb_a02,biog1_c_a02,biog1_o_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,smpa_a03,smpbb_a03,biog1_c_a03,biog1_o_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,smpa_a04,smpbb_a04,biog1_c_a04,biog1_o_a04,num_a04,ca_a01,ca_a02,ca_a03,ca_a04,co3_a01,co3_a02,co3_a03,co3_a04 package mozart_mosaic_4bin_kpp chem_opt==201 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,hcooh,c2h2,hoch2oo,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,apin,bpin,limon,myrc,bcary,terprod1,terprod2,terp2o2,terp2ooh,nterpo2,terpo2,tol,cres,to2,onit,isopn,dms,mbo,mboo2,hmprop,hmpropo2,mboooh,mbono3o2,nh3,nume,den,voca,vocbb,smpa,smpbb,biog1_c,biog1_o,benzene,phen,bepomuc,benzo2,pheno2,pheno,phenooh,c6h5o2,c6h5ooh,benzooh,bigald1,bigald2,bigald3,bigald4,malo2,tepomuc,bzoo,bzooh,bald,acbzo2,dicarbo2,mdialo2,xyl,xylol,xylolo2,xylolooh,xyleno2,xylenooh,pbznit,hono,meko2,so4_a01,no3_a01,smpa_a01,smpbb_a01,glysoa_sfc_a01,biog1_c_a01,biog1_o_a01,cl_a01,co3_a01,nh4_a01,na_a01,ca_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,smpa_a02,smpbb_a02,glysoa_sfc_a02,biog1_c_a02,biog1_o_a02,cl_a02,co3_a02,nh4_a02,na_a02,ca_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,smpa_a03,smpbb_a03,glysoa_sfc_a03,biog1_c_a03,biog1_o_a03,cl_a03,co3_a03,nh4_a03,na_a03,ca_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,smpa_a04,smpbb_a04,glysoa_sfc_a04,biog1_c_a04,biog1_o_a04,cl_a04,co3_a04,nh4_a04,na_a04,ca_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04 # complete aq-phase chem. and wet scavenging version with MOZART, HONO, VOC reactivity + VBS SOA package mozart_mosaic_4bin_aq_kpp chem_opt==202 - chem:o3,o1d_cb4,o,no,no2,no3,n2o5,hno3,hno4,so2,ho,ho2,h2o2,sulf,co,hcho,hcooh,c2h2,hoch2oo,ch3ooh,ch3o2,ch4,h2,eo2,ch3cooh,c2h4,n2o,ch3oh,aco3,acet,mgly,paa,gly,c3h6ooh,pan,mpan,macr,mvk,c3h6,etooh,prooh,acetp,xooh,onitr,isooh,acetol,glyald,mek,eto2,open,alkooh,mekooh,tolooh,terpooh,ald,mco3,c2h5oh,eo,c2h6,c3h8,pro2,po2,aceto2,bigene,bigalk,eneo2,alko2,isopr,iso2,mvko2,mvkooh,hydrald,xo2,apin,bpin,limon,myrc,bcary,terprod1,terprod2,terp2o2,terp2ooh,nterpo2,terpo2,tol,cres,to2,onit,isopn,dms,mbo,mboo2,hmprop,hmpropo2,mboooh,mbono3o2,nh3,nume,den,cvasoaX,cvasoa1,cvasoa2,cvasoa3,cvasoa4,cvbsoaX,cvbsoa1,cvbsoa2,cvbsoa3,cvbsoa4,benzene,phen,bepomuc,benzo2,pheno2,pheno,phenooh,c6h5o2,c6h5ooh,benzooh,bigald1,bigald2,bigald3,bigald4,malo2,tepomuc,bzoo,bzooh,bald,acbzo2,dicarbo2,mdialo2,xyl,xylol,xylolo2,xylolooh,xyleno2,xylenooh,pbznit,hono,meko2,so4_a01,no3_a01,asoaX_a01,asoa1_a01,asoa2_a01,asoa3_a01,asoa4_a01,bsoaX_a01,bsoa1_a01,bsoa2_a01,bsoa3_a01,bsoa4_a01,glysoa_r1_a01,glysoa_r2_a01,glysoa_sfc_a01,glysoa_nh4_a01,glysoa_oh_a01,cl_a01,co3_a01,nh4_a01,na_a01,ca_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,num_a01,so4_a02,no3_a02,asoaX_a02,asoa1_a02,asoa2_a02,asoa3_a02,asoa4_a02,bsoaX_a02,bsoa1_a02,bsoa2_a02,bsoa3_a02,bsoa4_a02,glysoa_r1_a02,glysoa_r2_a02,glysoa_sfc_a02,glysoa_nh4_a02,glysoa_oh_a02,cl_a02,co3_a02,nh4_a02,na_a02,ca_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,num_a02,so4_a03,no3_a03,asoaX_a03,asoa1_a03,asoa2_a03,asoa3_a03,asoa4_a03,bsoaX_a03,bsoa1_a03,bsoa2_a03,bsoa3_a03,bsoa4_a03,glysoa_r1_a03,glysoa_r2_a03,glysoa_sfc_a03,glysoa_nh4_a03,glysoa_oh_a03,cl_a03,co3_a03,nh4_a03,na_a03,ca_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,num_a03,so4_a04,no3_a04,asoaX_a04,asoa1_a04,asoa2_a04,asoa3_a04,asoa4_a04,bsoaX_a04,bsoa1_a04,bsoa2_a04,bsoa3_a04,bsoa4_a04,glysoa_r1_a04,glysoa_r2_a04,glysoa_sfc_a04,glysoa_nh4_a04,glysoa_oh_a04,cl_a04,co3_a04,nh4_a04,na_a04,ca_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,num_a04,so4_cw01,no3_cw01,asoaX_cw01,asoa1_cw01,asoa2_cw01,asoa3_cw01,asoa4_cw01,bsoaX_cw01,bsoa1_cw01,bsoa2_cw01,bsoa3_cw01,bsoa4_cw01,glysoa_r1_cw01,glysoa_r2_cw01,glysoa_sfc_cw01,glysoa_nh4_cw01,glysoa_oh_cw01,cl_cw01,co3_cw01,nh4_cw01,na_cw01,ca_cw01,oin_cw01,oc_cw01,bc_cw01,num_cw01,so4_cw02,no3_cw02,asoaX_cw02,asoa1_cw02,asoa2_cw02,asoa3_cw02,asoa4_cw02,bsoaX_cw02,bsoa1_cw02,bsoa2_cw02,bsoa3_cw02,bsoa4_cw02,glysoa_r1_cw02,glysoa_r2_cw02,glysoa_sfc_cw02,glysoa_nh4_cw02,glysoa_oh_cw02,cl_cw02,co3_cw02,nh4_cw02,na_cw02,ca_cw02,oin_cw02,oc_cw02,bc_cw02,num_cw02,so4_cw03,no3_cw03,asoaX_cw03,asoa1_cw03,asoa2_cw03,asoa3_cw03,asoa4_cw03,bsoaX_cw03,bsoa1_cw03,bsoa2_cw03,bsoa3_cw03,bsoa4_cw03,glysoa_r1_cw03,glysoa_r2_cw03,glysoa_sfc_cw03,glysoa_nh4_cw03,glysoa_oh_cw03,cl_cw03,co3_cw03,nh4_cw03,na_cw03,ca_cw03,oin_cw03,oc_cw03,bc_cw03,num_cw03,so4_cw04,no3_cw04,asoaX_cw04,asoa1_cw04,asoa2_cw04,asoa3_cw04,asoa4_cw04,bsoaX_cw04,bsoa1_cw04,bsoa2_cw04,bsoa3_cw04,bsoa4_cw04,glysoa_r1_cw04,glysoa_r2_cw04,glysoa_sfc_cw04,glysoa_nh4_cw04,glysoa_oh_cw04,cl_cw04,co3_cw04,nh4_cw04,na_cw04,ca_cw04,oin_cw04,oc_cw04,bc_cw04,num_cw04 @@ -3905,13 +3901,6 @@ package saprc99_mosaic_8bin_vbs2_aq_kpp chem_opt==203 - chem:o3,h2o2, package saprc99_mosaic_8bin_vbs2_kpp chem_opt==204 - chem:o3,h2o2,no,no2,no3,n2o5,hono,hno3,hno4,so2,h2so4,co,hcho,ccho,rcho,acet,mek,hcooh,meoh,etoh,cco_oh,rco_oh,gly,mgly,bacl,cres,bald,isoprod,methacro,mvk,prod2,dcb1,dcb2,dcb3,ethene,isoprene,c2h6,c3h8,c2h2,c3h6,alk3,alk4,alk5,aro1,aro2,ole1,ole2,terp,rno3,nphe,phen,pan,pan2,pbzn,ma_pan,co2,cco_ooh,rco_o2,rco_ooh,xn,xc,ho,ho2,c_o2,cooh,rooh,ro2_r,r2o2,ro2_n,cco_o2,bzco_o2,ma_rco3,sesq,pcg1_b_c,pcg2_b_c,pcg1_b_o,pcg2_b_o,opcg1_b_c,opcg1_b_o,pcg1_f_c,pcg2_f_c,pcg1_f_o,pcg2_f_o,opcg1_f_c,opcg1_f_o,psd1,psd2,nh3,hcl,nume,den,ant1_c,biog1_c,ant2_c,biog2_c,biog3_c,biog1_o,biog2_o,ant3_c,ant4_c,bgas,agas,ch4,so4_a01,no3_a01,cl_a01,nh4_a01,na_a01,oin_a01,oc_a01,bc_a01,hysw_a01,water_a01,pcg1_b_c_a01,pcg1_b_o_a01,opcg1_b_c_a01,opcg1_b_o_a01,pcg1_f_c_a01,pcg1_f_o_a01,opcg1_f_c_a01,opcg1_f_o_a01,ant1_c_a01,biog1_c_a01,ant2_c_a01,biog2_c_a01,biog3_c_a01,biog1_o_a01,biog2_o_a01,ant3_c_a01,ant4_c_a01,num_a01,so4_a02,no3_a02,cl_a02,nh4_a02,na_a02,oin_a02,oc_a02,bc_a02,hysw_a02,water_a02,pcg1_b_c_a02,pcg1_b_o_a02,opcg1_b_c_a02,opcg1_b_o_a02,pcg1_f_c_a02,pcg1_f_o_a02,opcg1_f_c_a02,opcg1_f_o_a02,ant1_c_a02,biog1_c_a02,ant2_c_a02,biog2_c_a02,biog3_c_a02,biog1_o_a02,biog2_o_a02,ant3_c_a02,ant4_c_a02,num_a02,so4_a03,no3_a03,cl_a03,nh4_a03,na_a03,oin_a03,oc_a03,bc_a03,hysw_a03,water_a03,pcg1_b_c_a03,pcg1_b_o_a03,opcg1_b_c_a03,opcg1_b_o_a03,pcg1_f_c_a03,pcg1_f_o_a03,opcg1_f_c_a03,opcg1_f_o_a03,ant1_c_a03,biog1_c_a03,ant2_c_a03,biog2_c_a03,biog3_c_a03,biog1_o_a03,biog2_o_a03,ant3_c_a03,ant4_c_a03,num_a03,so4_a04,no3_a04,cl_a04,nh4_a04,na_a04,oin_a04,oc_a04,bc_a04,hysw_a04,water_a04,pcg1_b_c_a04,pcg1_b_o_a04,opcg1_b_c_a04,opcg1_b_o_a04,pcg1_f_c_a04,pcg1_f_o_a04,opcg1_f_c_a04,opcg1_f_o_a04,ant1_c_a04,biog1_c_a04,ant2_c_a04,biog2_c_a04,biog3_c_a04,biog1_o_a04,biog2_o_a04,ant3_c_a04,ant4_c_a04,num_a04,so4_a05,no3_a05,cl_a05,nh4_a05,na_a05,oin_a05,oc_a05,bc_a05,hysw_a05,water_a05,pcg1_b_c_a05,pcg1_b_o_a05,opcg1_b_c_a05,opcg1_b_o_a05,pcg1_f_c_a05,pcg1_f_o_a05,opcg1_f_c_a05,opcg1_f_o_a05,ant1_c_a05,biog1_c_a05,ant2_c_a05,biog2_c_a05,biog3_c_a05,biog1_o_a05,biog2_o_a05,ant3_c_a05,ant4_c_a05,num_a05,so4_a06,no3_a06,cl_a06,nh4_a06,na_a06,oin_a06,oc_a06,bc_a06,hysw_a06,water_a06,pcg1_b_c_a06,pcg1_b_o_a06,opcg1_b_c_a06,opcg1_b_o_a06,pcg1_f_c_a06,pcg1_f_o_a06,opcg1_f_c_a06,opcg1_f_o_a06,ant1_c_a06,biog1_c_a06,ant2_c_a06,biog2_c_a06,biog3_c_a06,biog1_o_a06,biog2_o_a06,ant3_c_a06,ant4_c_a06,num_a06,so4_a07,no3_a07,cl_a07,nh4_a07,na_a07,oin_a07,oc_a07,bc_a07,hysw_a07,water_a07,pcg1_b_c_a07,pcg1_b_o_a07,opcg1_b_c_a07,opcg1_b_o_a07,pcg1_f_c_a07,pcg1_f_o_a07,opcg1_f_c_a07,opcg1_f_o_a07,ant1_c_a07,biog1_c_a07,ant2_c_a07,biog2_c_a07,biog3_c_a07,biog1_o_a07,biog2_o_a07,ant3_c_a07,ant4_c_a07,num_a07,so4_a08,no3_a08,cl_a08,nh4_a08,na_a08,oin_a08,oc_a08,bc_a08,hysw_a08,water_a08,pcg1_b_c_a08,pcg1_b_o_a08,opcg1_b_c_a08,opcg1_b_o_a08,pcg1_f_c_a08,pcg1_f_o_a08,opcg1_f_c_a08,opcg1_f_o_a08,ant1_c_a08,biog1_c_a08,ant2_c_a08,biog2_c_a08,biog3_c_a08,biog1_o_a08,biog2_o_a08,ant3_c_a08,ant4_c_a08,num_a08 - - - - - - - # KPP mechanism from MATCH-MPI Mainz used for global chemistry package nmhc9_kpp chem_opt==200 - chem:o3,h2o2,ch4,op1,hcho,ch3oh,co,hno3,no3,n2o5,hno4,no,no2,isopr,mvk,iso2,isooh,mvko2,mvkooh,ison,aca,acol,hcooh,mpan,naca,pan,pa,paa,mglo,c2h6,eTooh,ald,c3h8,pRooh,acet,acooh,eTo2,pRo2,aco2,c3h6,c3h6ooh,c2h4,c4h10,buooh,mek,mekooh,mEcoco,c3h6o2,c4h9o2,meko2,onit,pRono2,ch3o2,acetol,acetp,aceto2,ch3cooh,c4h9ooh,mEoh,ho,ho2,mEo2,mEo2no2 @@ -3939,12 +3928,6 @@ package cbmz_cam_mam3_aq chem_opt==503 - chem:so2,su package cbmz_cam_mam7_aq chem_opt==504 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,ora1,ora2,nh3,n2o5,no3,pan,eth,co,ol2,olt,oli,tol,xyl,hono,hno4,ket,mgly,onit,csl,iso,ho,ho2,hcl,ch3o2,ethp,ch3oh,c2h5oh,par,to2,cro,open,op3,c2o3,ro2,ano2,nap,xo2,xpar,isoprd,isopp,isopn,isopo2,soag,so4_a1,nh4_a1,pom_a1,soa_a1,bc_a1,ncl_a1,wtr_a1,num_a1,so4_a2,nh4_a2,soa_a2,ncl_a2,wtr_a2,num_a2,pom_a3,bc_a3,wtr_a3,num_a3,ncl_a4,so4_a4,nh4_a4,wtr_a4,num_a4,dst_a5,so4_a5,nh4_a5,wtr_a5,num_a5,ncl_a6,so4_a6,nh4_a6,wtr_a6,num_a6,dst_a7,so4_a7,nh4_a7,wtr_a7,num_a7,so4_c1,nh4_c1,pom_c1,soa_c1,bc_c1,ncl_c1,num_c1,so4_c2,nh4_c2,soa_c2,ncl_c2,num_c2,pom_c3,bc_c3,num_c3,ncl_c4,so4_c4,nh4_c4,num_c4,dst_c5,so4_c5,nh4_c5,num_c5,ncl_c6,so4_c6,nh4_c6,num_c6,dst_c7,so4_c7,nh4_c7,num_c7 -#package radm2_cam_mam3 chem_opt==411 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,hcl,ho,ho2,soag,so4_a1,pom_a1,soa_a1,bc_a1,dst_a1,ncl_a1,wtr_a1,num_a1,so4_a2,soa_a2,ncl_a2,wtr_a2,num_a2,dst_a3,ncl_a3,so4_a3,wtr_a3,num_a3 - -#package radm2_cam_mam7 chem_opt==412 - chem:so2,sulf,no2,no,o3,hno3,h2o2,ald,hcho,op1,op2,paa,ora1,ora2,nh3,n2o5,no3,pan,hc3,hc5,hc8,eth,co,ol2,olt,oli,tol,xyl,aco3,tpan,hono,hno4,ket,gly,mgly,dcb,onit,csl,iso,hcl,ho,ho2,soag,so4_a1,nh4_a1,pom_a1,soa_a1,bc_a1,ncl_a1,wtr_a1,num_a1,so4_a2,nh4_a2,soa_a2,ncl_a2,wtr_a2,num_a2,pom_a3,bc_a3,wtr_a3,num_a3,ncl_a4,so4_a4,nh4_a4,wtr_a4,num_a4,dst_a5,so4_a5,nh4_a5,wtr_a5,num_a5,ncl_a6,so4_a6,nh4_a6,wtr_a6,num_a6,dst_a7,so4_a7,nh4_a7,wtr_a7,num_a7 -# -# - # CRIMECH gas phase package crimech_kpp chem_opt==600 - chem:dms,dmso,dmso2,ch3sch2oo,ch3s,ch3so,ch3so2,ch3so3,msa,msia,nh3,hcl,so2,hso3,no2,o3,hno3,h2o2,ch3cho,hcho,ch3ooh,c2h5ooh,paa,hcooh,n2o5,no3,pan,c3h8,nc4h10,c2h6,co,c2h4,toluene,oxyl,aco3,hono,hno4,ket,c5h8,ho,ho2,so3,no,benzene,npropol,c2h2,c3h6,tbut2ene,c2h5cho,ch3co2h,mek,ch3oh,c2h5oh,ipropol,ch3no3,c2h5no3,hoc2h4no3,prooh,hoc2h4ooh,carb14,carb17,rn10no3,rn13no3,rn19no3,rn9no3,rn12no3,rn15no3,rn18no3,rn16no3,rn10ooh,rn13ooh,rn16ooh,rn19ooh,rn8ooh,rn11ooh,rn14ooh,rn17ooh,rn9ooh,rn12ooh,rn15ooh,rn18ooh,nrn6ooh,nrn9ooh,nrn12ooh,apinene,bpinene,carb7,carb10,carb13,carb16,carb3,carb6,carb9,carb12,carb15,c2h5co3h,c2h5co3,ppn,hoch2cho,hoch2co3,hoch2co3h,phan,ccarb12,ch3cl,ch2cl2,chcl3,ch3ccl3,cdicleth,tdicleth,tricleth,tce,ucarb12,ucarb10,ru14no3,ru14ooh,ru12ooh,ru10ooh,mpan,ru12pan,nucarb12,nru14ooh,nru12ooh,noa,ra13no3,ra13ooh,udcarb8,aroh14,raroh14,arnoh14,ra16no3,ra16ooh,udcarb11,aroh17,raroh17,arnoh17,udcarb14,ra19co2,ra19no3,ra19ooh,rtn28no3,rtn28ooh,tncarb26,rtn26ooh,nrtn28ooh,rtn26pan,rtn25ooh,rtn24ooh,rtn23ooh,rtn14ooh,rtn10ooh,tncarb10,rtn25no3,tncarb15,rcooh25,rtx28no3,rtx28ooh,txcarb24,rtx24no3,rtx24ooh,txcarb22,rtx22no3,rtx22ooh,nrtx28ooh,carb11a,anhy,ch3o2no2,ch4,sulf,rtn23no3,tncarb12,tncarb11,tm123b,tm124b,tm135b,oethtol,methtol,pethtol,ra22no3,ra22ooh,dime35eb,ra25no3,udcarb17,ra25ooh,ch3oo,c2h5o2,hoch2ch2o2,ic3h7o2,rn10o2,rn13o2,rn16o2,rn19o2,rn9o2,rn12o2,rn15o2,rn18o2,nrn6o2,nrn9o2,nrn12o2,rn11o2,rn14o2,rn8o2,rn17o2,rn13ao2,rn16ao2,rn15ao2,rn18ao2,ru10o2,nru14o2,nru12o2,ra13o2,nrtx28o2,rtx24o2,rtx28o2,rtn25o2,rtn24o2,rtn23o2,rtn14o2,rtn10o2,nrtn28o2,rtn26o2,rtn28o2,ra19ao2,ru14o2,ru12o2,ra16o2,rtx22o2,ra22ao2,ra22bo2,ra25o2,ic3h7no3 # CRIMECH gas phase and original aqueous MOSAIC @@ -3968,7 +3951,7 @@ package esaprcnov emiss_opt==13 - emis_ant: # For CB05 mechanism based on CBMZ speciation, used with emiss_inpt_opt = 102 package ecb05_opt1 emiss_opt==14 - emis_ant:e_no2,e_xyl,e_tol,e_terp,e_so2,e_ora2,e_olt,e_oli,e_ol2,e_no,e_nh3,e_iso,e_hcl,e_hcho,e_eth,e_csl,e_co,e_ch3oh,e_c2h5oh,e_ald,e_aldx,e_hc3,e_hc5,e_hc8,e_ket,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_so4c,e_no3c,e_orgc,e_ecc,e_pm10 # For CB05 emissions inventory base on CB05 speciation, used with emiss_inpt_opt = 101 -package ecb05_opt2 emiss_opt==15 - emis_ant:e_acet,e_par,e_alk1,e_alk2,e_alk3,e_alk4,e_alk5,e_tol,e_xyl,e_bald,e_ald2,e_ccooh,e_co,e_cres,e_eth,e_etha,e_gly,e_form,e_hcooh,e_iprod,e_isop,e_macr,e_mek,e_meoh,e_meo2,e_etoh,e_mgly,e_nh3,e_hcl,e_no,e_no2,e_iole,e_ole,e_phen,e_prod2,e_aldx,e_rcooh,e_so2,e_psulf,e_terp,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_so4c,e_no3c,e_orgc,e_ecc,e_pm10 +package ecb05_opt2 emiss_opt==15 - emis_ant:e_acet,e_par,e_alk3,e_alk4,e_alk5,e_tol,e_xyl,e_bald,e_ald2,e_ccooh,e_co,e_cres,e_eth,e_etha,e_gly,e_form,e_hcooh,e_iprod,e_isop,e_macr,e_mek,e_meoh,e_meo2,e_etoh,e_mgly,e_nh3,e_hcl,e_no,e_no2,e_iole,e_ole,e_phen,e_prod2,e_aldx,e_so2,e_psulf,e_terp,e_pm25i,e_pm25j,e_eci,e_ecj,e_orgi,e_orgj,e_so4i,e_so4j,e_no3i,e_no3j,e_so4c,e_no3c,e_orgc,e_ecc,e_pm10 # Anthropogenic CO2, CO and CH4 emissions: package eco2 emiss_opt==16 - emis_ant:e_co2,e_co2tst,e_co @@ -3980,27 +3963,31 @@ package vash emiss_opt_vol==1 - emis_vol:e_va package vashso2 emiss_opt_vol==2 - emis_vol:e_vash1,e_vash2,e_vash3,e_vash4,e_vash5,e_vash6,e_vash7,e_vash8,e_vash9,e_vash10,e_vso2 # -#package seasalt_pnnl emiss_ssalt_opt==1 - - -#package monahan emiss_ssalt_opt==2 - - -#cms-- +package photmad phot_opt==1 - state:uvrad,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho,ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho,ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,ph_macr,ph_n2o5,ph_o2,ph_pan,ph_acet,ph_mglo,ph_hno4_2,ph_n2o,ph_pooh,ph_mpan,ph_mvk,ph_etooh,ph_prooh,ph_onitr,ph_acetol,ph_glyald,ph_hyac,ph_mek,ph_open,ph_gly,ph_acetp,ph_xooh,ph_isooh,ph_alkooh,ph_mekooh,ph_tolooh,ph_terpooh,ph_cl2,ph_hocl,ph_fmcl +package photfastj phot_opt==2 - state:ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho,ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho,ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,ph_macr,ph_n2o5,ph_o2,ph_pan,ph_acet,ph_mglo,ph_hno4_2,ph_n2o,ph_pooh,ph_mpan,ph_mvk,ph_etooh,ph_prooh,ph_onitr,ph_acetol,ph_glyald,ph_hyac,ph_mek,ph_open,ph_gly,ph_acetp,ph_xooh,ph_isooh,ph_alkooh,ph_mekooh,ph_tolooh,ph_terpooh,ph_cl2,ph_hocl,ph_fmcl +package ftuv phot_opt==3 - state:radfld,adjcoe,phrate,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho,ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho,ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,ph_macr,ph_n2o5,ph_o2,ph_pan,ph_acet,ph_mglo,ph_hno4_2,ph_n2o,ph_pooh,ph_mpan,ph_mvk,ph_etooh,ph_prooh,ph_onitr,ph_acetol,ph_glyald,ph_hyac,ph_mek,ph_open,ph_gly,ph_acetp,ph_xooh,ph_isooh,ph_alkooh,ph_mekooh,ph_tolooh,ph_terpooh,ph_cl2,ph_hocl,ph_fmcl +package tuv phot_opt==4 - state:uvrad,dt_cld,af_dir,af_dn,af_up,ph_par,ph_erythema,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho,ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho,ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,ph_macr,ph_n2o5,ph_o2,ph_pan,ph_acet,ph_mglo,ph_hno4_2,ph_n2o,ph_pooh,ph_mpan,ph_mvk,ph_etooh,ph_prooh,ph_onitr,ph_acetol,ph_glyald,ph_hyac,ph_mek,ph_open,ph_gly,ph_acetp,ph_xooh,ph_isooh,ph_alkooh,ph_mekooh,ph_tolooh,ph_terpooh,ph_cl2,ph_hocl,ph_fmcl -package photmad phot_opt==1 - - -package photfastj phot_opt==2 - - -package ftuv phot_opt==3 - - package wesely gas_drydep_opt==1 - - # # diagnostic packages, first for deposition velocities (original package for Mozart) # package depvel1 diagnostic_chem==1 - dvel:dvel_o3,dvel_no,dvel_no2,dvel_nh3,dvel_hno3,dvel_hno4,dvel_h2o2,dvel_co,dvel_ch3ooh,dvel_hcho,dvel_ch3oh,dvel_eo2,dvel_ald,dvel_ch3cooh,dvel_acet,dvel_mgly,dvel_gly,dvel_paa,dvel_pooh,dvel_pan,dvel_mpan,dvel_mco3,dvel_mvkooh,dvel_c2h5oh,dvel_etooh,dvel_prooh,dvel_acetp,dvel_onit,dvel_onitr,dvel_isooh,dvel_acetol,dvel_glyald,dvel_hydrald,dvel_alkooh,dvel_mekooh,dvel_tolooh,dvel_xooh,dvel_so2,dvel_so4,dvel_terpooh,dvel_cvasoaX,dvel_cvasoa1,dvel_cvasoa2,dvel_cvasoa3,dvel_cvasoa4,dvel_cvbsoaX,dvel_cvbsoa1,dvel_cvbsoa2,dvel_cvbsoa3,dvel_cvbsoa4,ddmass_o3,ddmass_no,ddmass_no2,ddmass_nh3,ddmass_hno3,ddmass_hno4,ddmass_h2o2,ddmass_co,ddmass_ch3ooh,ddmass_hcho,ddmass_ch3oh,ddmass_eo2,ddmass_ald,ddmass_ch3cooh,ddmass_acet,ddmass_mgly,ddmass_gly,ddmass_paa,ddmass_pooh,ddmass_pan,ddmass_mpan,ddmass_mco3,ddmass_mvkooh,ddmass_c2h5oh,ddmass_etooh,ddmass_prooh,ddmass_acetp,ddmass_onit,ddmass_onitr,ddmass_isooh,ddmass_acetol,ddmass_glyald,ddmass_hydrald,ddmass_alkooh,ddmass_mekooh,ddmass_tolooh,ddmass_xooh,ddmass_so2,ddmass_so4,ddmass_terpooh,ddmass_cvasoaX,ddmass_cvasoa1,ddmass_cvasoa2,ddmass_cvasoa3,ddmass_cvasoa4,ddmass_cvbsoaX,ddmass_cvbsoa1,ddmass_cvbsoa2,ddmass_cvbsoa3,ddmass_cvbsoa4,ddmass_so4_a01,ddmass_no3_a01,ddmass_cl_a01,ddmass_nh4_a01,ddmass_na_a01,ddmass_oin_a01,ddmass_oc_a01,ddmass_bc_a01,ddmass_smpa_a01,ddmass_smpbb_a01,ddmass_glysoa_a01,ddmass_biog1_c_a01,ddmass_biog1_o_a01,ddmass_asoaX_a01,ddmass_asoa1_a01,ddmass_asoa2_a01,ddmass_asoa3_a01,ddmass_asoa4_a01,ddmass_bsoaX_a01,ddmass_bsoa1_a01,ddmass_bsoa2_a01,ddmass_bsoa3_a01,ddmass_bsoa4_a01,ddmass_so4_a02,ddmass_no3_a02,ddmass_cl_a02,ddmass_nh4_a02,ddmass_na_a02,ddmass_oin_a02,ddmass_oc_a02,ddmass_bc_a02,ddmass_smpa_a02,ddmass_smpbb_a02,ddmass_glysoa_a02,ddmass_biog1_c_a02,ddmass_biog1_o_a02,ddmass_asoaX_a02,ddmass_asoa1_a02,ddmass_asoa2_a02,ddmass_asoa3_a02,ddmass_asoa4_a02,ddmass_bsoaX_a02,ddmass_bsoa1_a02,ddmass_bsoa2_a02,ddmass_bsoa3_a02,ddmass_bsoa4_a02,ddmass_so4_a03,ddmass_no3_a03,ddmass_cl_a03,ddmass_nh4_a03,ddmass_na_a03,ddmass_oin_a03,ddmass_oc_a03,ddmass_bc_a03,ddmass_smpa_a03,ddmass_smpbb_a03,ddmass_glysoa_a03,ddmass_biog1_c_a03,ddmass_biog1_o_a03,ddmass_asoaX_a03,ddmass_asoa1_a03,ddmass_asoa2_a03,ddmass_asoa3_a03,ddmass_asoa4_a03,ddmass_bsoaX_a03,ddmass_bsoa1_a03,ddmass_bsoa2_a03,ddmass_bsoa3_a03,ddmass_bsoa4_a03,ddmass_so4_a04,ddmass_no3_a04,ddmass_cl_a04,ddmass_nh4_a04,ddmass_na_a04,ddmass_oin_a04,ddmass_oc_a04,ddmass_bc_a04,ddmass_smpa_a04,ddmass_smpbb_a04,ddmass_glysoa_a04,ddmass_biog1_c_a04,ddmass_biog1_o_a04,ddmass_asoaX_a04,ddmass_asoa1_a04,ddmass_asoa2_a04,ddmass_asoa3_a04,ddmass_asoa4_a04,ddmass_bsoaX_a04,ddmass_bsoa1_a04,ddmass_bsoa2_a04,ddmass_bsoa3_a04,ddmass_bsoa4_a04,ddmass_ca_a01,ddmass_ca_a02,ddmass_ca_a03,ddmass_ca_a04,ddmass_co3_a01,ddmass_co3_a02,ddmass_co3_a03,ddmass_co3_a04,ddmass_so4_cw01,ddmass_no3_cw01,ddmass_cl_cw01,ddmass_nh4_cw01,ddmass_na_cw01,ddmass_oin_cw01,ddmass_oc_cw01,ddmass_bc_cw01,ddmass_smpa_cw01,ddmass_smpbb_cw01,ddmass_glysoa_cw01,ddmass_biog1_c_cw01,ddmass_biog1_o_cw01,ddmass_asoaX_cw01,ddmass_asoa1_cw01,ddmass_asoa2_cw01,ddmass_asoa3_cw01,ddmass_asoa4_cw01,ddmass_bsoaX_cw01,ddmass_bsoa1_cw01,ddmass_bsoa2_cw01,ddmass_bsoa3_cw01,ddmass_bsoa4_cw01,ddmass_so4_cw02,ddmass_no3_cw02,ddmass_cl_cw02,ddmass_nh4_cw02,ddmass_na_cw02,ddmass_oin_cw02,ddmass_oc_cw02,ddmass_bc_cw02,ddmass_smpa_cw02,ddmass_smpbb_cw02,ddmass_glysoa_cw02,ddmass_biog1_c_cw02,ddmass_biog1_o_cw02,ddmass_asoaX_cw02,ddmass_asoa1_cw02,ddmass_asoa2_cw02,ddmass_asoa3_cw02,ddmass_asoa4_cw02,ddmass_bsoaX_cw02,ddmass_bsoa1_cw02,ddmass_bsoa2_cw02,ddmass_bsoa3_cw02,ddmass_bsoa4_cw02,ddmass_so4_cw03,ddmass_no3_cw03,ddmass_cl_cw03,ddmass_nh4_cw03,ddmass_na_cw03,ddmass_oin_cw03,ddmass_oc_cw03,ddmass_bc_cw03,ddmass_smpa_cw03,ddmass_smpbb_cw03,ddmass_glysoa_cw03,ddmass_biog1_c_cw03,ddmass_biog1_o_cw03,ddmass_asoaX_cw03,ddmass_asoa1_cw03,ddmass_asoa2_cw03,ddmass_asoa3_cw03,ddmass_asoa4_cw03,ddmass_bsoaX_cw03,ddmass_bsoa1_cw03,ddmass_bsoa2_cw03,ddmass_bsoa3_cw03,ddmass_bsoa4_cw03,ddmass_so4_cw04,ddmass_no3_cw04,ddmass_cl_cw04,ddmass_nh4_cw04,ddmass_na_cw04,ddmass_oin_cw04,ddmass_oc_cw04,ddmass_bc_cw04,ddmass_smpa_cw04,ddmass_smpbb_cw04,ddmass_glysoa_cw04,ddmass_biog1_c_cw04,ddmass_biog1_o_cw04,ddmass_asoaX_cw04,ddmass_asoa1_cw04,ddmass_asoa2_cw04,ddmass_asoa3_cw04,ddmass_asoa4_cw04,ddmass_bsoaX_cw04,ddmass_bsoa1_cw04,ddmass_bsoa2_cw04,ddmass_bsoa3_cw04,ddmass_bsoa4_cw04,ddmass_ca_cw01,ddmass_ca_cw02,ddmass_ca_cw03,ddmass_ca_cw04,ddmass_co3_cw01,ddmass_co3_cw02,ddmass_co3_cw03,ddmass_co3_cw04 + +package opti_aero aero_diag_opt==0 - state:totoa_a01,totoa_a02,totoa_a03,totoa_a04,totoa_a05,totoa_a06,totoa_a07,totoa_a08 +package diag_aero aero_diag_opt==1 - state:hoa_a01,hoa_a02,hoa_a03,hoa_a04,hoa_a05,hoa_a06,hoa_a07,hoa_a08,soa_a01,soa_a02,soa_a03,soa_a04,soa_a05,soa_a06,soa_a07,soa_a08,bboa_a01,bboa_a02,bboa_a03,bboa_a04,bboa_a05,bboa_a06,bboa_a07,bboa_a08,bbsoa_a01,bbsoa_a02,bbsoa_a03,bbsoa_a04,bbsoa_a05,bbsoa_a06,bbsoa_a07,bbsoa_a08,hsoa_a01,hsoa_a02,hsoa_a03,hsoa_a04,hsoa_a05,hsoa_a06,hsoa_a07,hsoa_a08,biog_a01,biog_a02,biog_a03,biog_a04,biog_a05,biog_a06,biog_a07,biog_a08,arosoa_a01,arosoa_a02,arosoa_a03,arosoa_a04,arosoa_a05,arosoa_a06,arosoa_a07,arosoa_a08,totoa_a01,totoa_a02,totoa_a03,totoa_a04,totoa_a05,totoa_a06,totoa_a07,totoa_a08,hsoa_c,hsoa_o,bbsoa_c,bbsoa_o,biog_v1,biog_v2,biog_v3,biog_v4,ant_v1,ant_v2,ant_v3,ant_v4,smpa_v1,smpbb_v1,asmpsoa_a01,asmpsoa_a02,asmpsoa_a03,asmpsoa_a04 +# +package diag_cw_aero aero_cw_diag_opt==1 - state:hoa_cw01,hoa_cw02,hoa_cw03,hoa_cw04,hoa_cw05,hoa_cw06,hoa_cw07,hoa_cw08,soa_cw01,soa_cw02,soa_cw03,soa_cw04,soa_cw05,soa_cw06,soa_cw07,soa_cw08,bboa_cw01,bboa_cw02,bboa_cw03,bboa_cw04,bboa_cw05,bboa_cw06,bboa_cw07,bboa_cw08,bbsoa_cw01,bbsoa_cw02,bbsoa_cw03,bbsoa_cw04,bbsoa_cw05,bbsoa_cw06,bbsoa_cw07,bbsoa_cw08,hsoa_cw01,hsoa_cw02,hsoa_cw03,hsoa_cw04,hsoa_cw05,hsoa_cw06,hsoa_cw07,hsoa_cw08,biog_cw01,biog_cw02,biog_cw03,biog_cw04,biog_cw05,biog_cw06,biog_cw07,biog_cw08,arosoa_cw01,arosoa_cw02,arosoa_cw03,arosoa_cw04,arosoa_cw05,arosoa_cw06,arosoa_cw07,arosoa_cw08,totoa_cw01,totoa_cw02,totoa_cw03,totoa_cw04,totoa_cw05,totoa_cw06,totoa_cw07,totoa_cw08,hsoa_cw_c,hsoa_cw_o,bbsoa_cw_c,bbsoa_cw_o,biog_cw_v1,ant_cw_v1 +package cu_kfcup_select kfcup_diag==1 - state: chem_cupflag, co_a_ic_cup, hno3_a_ic_cup, so4_a_1to4_ic_cup, so4_cw_1to4_ic_cup, nh4_a_1to4_ic_cup, nh4_cw_1to4_ic_cup, no3_a_1to4_ic_cup, no3_cw_1to4_ic_cup, oa_a_1to4_ic_cup, oa_cw_1to4_ic_cup, oin_a_1to4_ic_cup, oin_cw_1to4_ic_cup, bc_a_1to4_ic_cup, bc_cw_1to4_ic_cup, na_a_1to4_ic_cup, na_cw_1to4_ic_cup, cl_a_1to4_ic_cup, cl_cw_1to4_ic_cup, so4_a_5to6_ic_cup, so4_cw_5to6_ic_cup, nh4_a_5to6_ic_cup, nh4_cw_5to6_ic_cup, no3_a_5to6_ic_cup, no3_cw_5to6_ic_cup, oa_a_5to6_ic_cup, oa_cw_5to6_ic_cup, oin_a_5to6_ic_cup, oin_cw_5to6_ic_cup, bc_a_5to6_ic_cup, bc_cw_5to6_ic_cup, na_a_5to6_ic_cup, na_cw_5to6_ic_cup, cl_a_5to6_ic_cup, cl_cw_5to6_ic_cup, water_1to4_ic_cup, water_5to6_ic_cup # package gunther1 bio_emiss_opt==1 - - package beis314 bio_emiss_opt==2 - - package megan2 bio_emiss_opt==3 - state:mebio_isop,mebio_apin,mebio_bcar,mebio_acet,mebio_mbo,mebio_no,msebio_isop,mlai,pftp_bt,pftp_nt,pftp_sb,pftp_hb,mtsa,mswdown,EFmegan # Biospheric CO2 and CH4 emissions -package ebioco2 bio_emiss_opt==16 - vprm_in:vegfra_vprm,evi,evi_min,evi_max,lswi,lswi_max,lswi_min;eghg_bio:ebio_gee,ebio_res,ebio_co2oce -package ebioghg bio_emiss_opt==17 - vprm_in:vegfra_vprm,evi,evi_min,evi_max,lswi,lswi_max,lswi_min;wet_in:cpool,wetmap,t_ann;eghg_bio:ebio_gee,ebio_res,ebio_co2oce,ebio_ch4wet,ebio_ch4soil,ebio_ch4term +package ebioco2 bio_emiss_opt==16 - state:rad_vprm,lambda_vprm,alpha_vprm,resp_vprm;vprm_in:vegfra_vprm,evi,evi_min,evi_max,lswi,lswi_max,lswi_min;eghg_bio:ebio_gee,ebio_res,ebio_co2oce +package ebioghg bio_emiss_opt==17 - state:rad_vprm,lambda_vprm,alpha_vprm,resp_vprm;vprm_in:vegfra_vprm,evi,evi_min,evi_max,lswi,lswi_max,lswi_min;wet_in:cpool,wetmap,t_ann;eghg_bio:ebio_gee,ebio_res,ebio_co2oce,ebio_ch4wet,ebio_ch4soil,ebio_ch4term # the following arrays only needed for burn options package biomassb biomass_burn_opt==1 - state:mean_fct_agtf,mean_fct_agef,mean_fct_agsv,mean_fct_aggr,firesize_agtf,firesize_agef,firesize_agsv,firesize_aggr;ebu:ebu_no,ebu_no2,ebu_co,ebu_co2,ebu_eth,ebu_hc3,ebu_hc5,ebu_hc8,ebu_ete,ebu_olt,ebu_oli,ebu_pm25,ebu_pm10,ebu_dien,ebu_iso,ebu_api,ebu_lim,ebu_tol,ebu_csl,ebu_hcho,ebu_ald,ebu_ket,ebu_macr,ebu_ora1,ebu_ora2,ebu_so2,ebu_nh3,ebu_oc,ebu_bc,ebu_sulf,ebu_dms;ebu_in:ebu_in_no,ebu_in_no2,ebu_in_co,ebu_in_co2,ebu_in_eth,ebu_in_hc3,ebu_in_hc5,ebu_in_hc8,ebu_in_ete,ebu_in_olt,ebu_in_oli,ebu_in_pm25,ebu_in_pm10,ebu_in_dien,ebu_in_iso,ebu_in_api,ebu_in_lim,ebu_in_tol,ebu_in_csl,ebu_in_hcho,ebu_in_ald,ebu_in_xyl,ebu_in_ket,ebu_in_macr,ebu_in_ora1,ebu_in_ora2,ebu_in_so2,ebu_in_nh3,ebu_in_oc,ebu_in_bc,ebu_in_sulf,ebu_in_dms,ebu_in_ash @@ -4087,6 +4074,11 @@ rconfig integer lnox_opt namelist,chem max_domains 0 rconfig logical lnox_passive namelist,chem max_domains .false. rh "lnox_passive" "true = tracer only (no emission)" "" rconfig real ltng_temp_upper namelist,physics max_domains -45. - "ltng_temp_upper" "Upper isotherm for lightning modes" "C" rconfig real ltng_temp_lower namelist,physics max_domains -15. - "ltng_temp_lower" "Lower isotherm for lightning modes" "C" +# exo model o2,o3 column densities +rconfig logical has_o3_exo_coldens namelist,chem 1 .false. rh "has_exo_coldens" "true = use exo model o2,o3 column denisties" "" +rconfig real du_at_grnd namelist,chem 1 300. rh "O3 at ground" "O3 at ground" "o3 Dobson units" +rconfig logical scale_o3_to_grnd_exo_coldens namelist,chem 1 .false. rh "scale o3 column to exo_coldens" "true = scale to exo model o3 column denisties" "" +rconfig logical scale_o3_to_du_at_grnd namelist,chem 1 .false. rh "scale o3 column to du_at_grnd" "true = scale to DU at ground" "" package lnox_opt_none lnox_opt==0 - - package lnox_opt_ott lnox_opt==1 - tracer:lnox_total diff --git a/wrfv2_fire/Registry/registry.dimspec b/wrfv2_fire/Registry/registry.dimspec index fe86cdd0..cb1925a2 100644 --- a/wrfv2_fire/Registry/registry.dimspec +++ b/wrfv2_fire/Registry/registry.dimspec @@ -45,6 +45,7 @@ dimspec n - constant=(0:6) c ifdef HWRF=1 dimspec otrak - namelist=num_old_fixes c old_fixes endif +dimspec maxkid - constant=100 c max_nest_domain_id endif dimspec snly 2 namelist=num_snow_layers z snow_layers @@ -76,6 +77,7 @@ dimspec = - constant=4 c num_bands dimspec lake_ssl 2 constant=15 z snow_and_soil_levels dimspec lake_intl 2 constant=16 z interface_levels dimspec lake_sll 2 constant=10 z soil_levels_or_lake_levels +dimspec crop 2 constant=5 z crop_types # Dimensions required only for Chemistry diff --git a/wrfv2_fire/Registry/registry.fire b/wrfv2_fire/Registry/registry.fire index 481d1835..a092b7bf 100644 --- a/wrfv2_fire/Registry/registry.fire +++ b/wrfv2_fire/Registry/registry.fire @@ -72,7 +72,7 @@ state real ischap *i*j fire 1 z hr "ISCHAP" rconfig integer ifire namelist,fire max_domains 0 rconfig integer fire_boundary_guard namelist,fire max_domains 2 - "fire_boundary_guard" "cells to stop when fire close to domain boundary" # ignition for sfire -rconfig integer fire_num_ignitions namelist,fire max_domains 0. - "fire_num_ignitions" "number of ignition lines" +rconfig integer fire_num_ignitions namelist,fire max_domains 0 - "fire_num_ignitions" "number of ignition lines" rconfig real fire_ignition_ros1 namelist,fire max_domains 0.01 - "fire_ignition_ros1" "rate of spread during ignition" "m/s" rconfig real fire_ignition_start_lon1 namelist,fire max_domains 0. - "fire_ignition_start_long1" "long coord of start of ignition line" "deg" rconfig real fire_ignition_start_lat1 namelist,fire max_domains 0. - "fire_ignition_start_lat1" "lat coord of start of ignition line" "deg" diff --git a/wrfv2_fire/Registry/registry.hyb_coord b/wrfv2_fire/Registry/registry.hyb_coord new file mode 100644 index 00000000..5548e836 --- /dev/null +++ b/wrfv2_fire/Registry/registry.hyb_coord @@ -0,0 +1,56 @@ +# Dry pressure, Pd +# Dry surface pressure = Pds +# Model top pressure = Pt +# Mass in column, Pc = Pds - Pt + +# Total dry pressure +# Pd = BF ( Pds - Pt ) + ( eta - BF ) ( P0 - Pt ) + Pt + +# Hybrid coordinate: mu is still d(Pd)/d(eta) +# new MUT = d Pd / d eta = d BF / d eta * ( Pcb + Pc ) + ( 1 - d BF / d eta ) * ( P0 - Pt ) + +# Define two columnar constants, function only of eta and other constants, specifically for the "mu" replacements. +# C1 = d BF / d eta +# C2 = ( 1 - d BF / d eta ) * ( P0 - Pt ) + +# Total field +# new MUT(i,k,j) = C1(k) * ( Pcb(i,j) + Pc(i,j) ) + C2(k) + +# Base-state, background field +# new MUB(i,k,j) = C1(k) * Pcb(i,j) + C2(k) + +# Perturbation field +# new MU(i,k,j) = C1(k) * Pc(i,j) + +# Define two columnar constants, function only of eta and other constants, specifically for the "pressure" replacements. +# C3 = BF +# C4 = ( eta - BF ) * ( P0 - Pt ) + +# new dry pressure Pd(i,k,j) = C3(k) * ( Pds(i,j) - Pt ) + C4(k) + Pt + + +#
+ +state real bf k misc 1 Z i02rh0{22}{23}{24} "BF" "full levels, bf=0 => isobaric; bf=znw => sigma" "Dimensionless" +state real c1h k misc 1 - i02rh0{22}{23}{24} "C1H" "half levels, c1h = d bf / d eta, using znw" "Dimensionless" +state real c2h k misc 1 - i02rh0{22}{23}{24} "C2H" "half levels, c2h = (1-c1h)*(p0-pt)" "Pa" + +state real bh k misc 1 - i02rh0{22}{23}{24} "BH" "half levels, bh=0 => isobaric; bh=znu => sigma" "Dimensionless" +state real c1f k misc 1 Z i02rh0{22}{23}{24} "C1F" "full levels, c1f = d bf / d eta, using znu" "Dimensionless" +state real c2f k misc 1 Z i02rh0{22}{23}{24} "C2F" "full levels, c2f = (1-c1f)*(p0-pt)" "Pa" + +state real c3h k misc 1 - i02rh0{22}{23}{24} "C3H" "half levels, c3h = bh" "Dimensionless" +state real c4h k misc 1 - i02rh0{22}{23}{24} "C4H" "half levels, c4h = (eta-bh)*(p0-pt)+pt, using znu" "Pa" + +state real c3f k misc 1 Z i02rh0{22}{23}{24} "C3F" "full levels, c3f = bf" "Dimensionless" +state real c4f k misc 1 Z i02rh0{22}{23}{24} "C4F" "full levels, c4f = (eta-bf)*(p0-pt)+pt, using znw" "Pa" + +state real pcb ij dyn_em 1 - irhdus "PCB" "base state dry air mass in column" "Pa" +state real pc ijb dyn_em 2 - irhusdf=(bdy_interp:dt) "PC" "perturbation dry air mass in column" "Pa" + + + + +#
+rconfig integer hybrid_opt namelist,dynamics 1 0 i0 "HYBRID_OPT" "0=Original WRF coordinate, 1=Terrain Following using hybrid formulation, 2=Klemp cubic form with etac" "Flag" +rconfig real etac namelist,dynamics 1 0.2 i0 "ETAC" "znw(k) < etac, eta surfaces are isobaric, 0.2 is a good default" "Pa/Pa" diff --git a/wrfv2_fire/Registry/registry.new3d_gca b/wrfv2_fire/Registry/registry.new3d_gca new file mode 100644 index 00000000..700351b7 --- /dev/null +++ b/wrfv2_fire/Registry/registry.new3d_gca @@ -0,0 +1,63 @@ +############################################################################### +# This is an example registry. +# It has the necessary pieces to allow a set of input fields to come +# into the real program from metgrid. These fields are assumed to +# be on a separate vertical coordinate from the standard metgrid +# atmospheric fields. The usual purpose for this would be for +# bringing in aerosols. +############################################################################### + +### G C A +### GOCART AEROSOL + +dimspec gca 2 namelist=num_gca_levels z num_gca_levels + +rconfig integer num_gca_levels namelist,domains 1 27 irh "num_gca_levels" "number of levels in the GOcart Aerosol input" "" + +state real p_gca i{gca}j dyn_em 1 Z i1 "P_GCA" "Pressure for using Aerosol-GOcart option" "Pa" + +state real oh_gca_now i{gca}j dyn_em 1 Z - "OH_NOW" "Background OH for Aerosol-GOcart option Now" "kg kg-1" +state real oh_gca_jan i{gca}j dyn_em 1 Z i1 "OH_JAN" "Background OH for Aerosol-GOcart option Jan" "kg kg-1" +state real oh_gca_feb i{gca}j dyn_em 1 Z i1 "OH_FEB" "Background OH for Aerosol-GOcart option Feb" "kg kg-1" +state real oh_gca_mar i{gca}j dyn_em 1 Z i1 "OH_MAR" "Background OH for Aerosol-GOcart option Mar" "kg kg-1" +state real oh_gca_apr i{gca}j dyn_em 1 Z i1 "OH_APR" "Background OH for Aerosol-GOcart option Apr" "kg kg-1" +state real oh_gca_may i{gca}j dyn_em 1 Z i1 "OH_MAY" "Background OH for Aerosol-GOcart option May" "kg kg-1" +state real oh_gca_jun i{gca}j dyn_em 1 Z i1 "OH_JUN" "Background OH for Aerosol-GOcart option Jun" "kg kg-1" +state real oh_gca_jul i{gca}j dyn_em 1 Z i1 "OH_JUL" "Background OH for Aerosol-GOcart option Jul" "kg kg-1" +state real oh_gca_aug i{gca}j dyn_em 1 Z i1 "OH_AUG" "Background OH for Aerosol-GOcart option Aug" "kg kg-1" +state real oh_gca_sep i{gca}j dyn_em 1 Z i1 "OH_SEP" "Background OH for Aerosol-GOcart option Sep" "kg kg-1" +state real oh_gca_oct i{gca}j dyn_em 1 Z i1 "OH_OCT" "Background OH for Aerosol-GOcart option Oct" "kg kg-1" +state real oh_gca_nov i{gca}j dyn_em 1 Z i1 "OH_NOV" "Background OH for Aerosol-GOcart option Nov" "kg kg-1" +state real oh_gca_dec i{gca}j dyn_em 1 Z i1 "OH_DEC" "Background OH for Aerosol-GOcart option Dec" "kg kg-1" + +state real h2o2_gca_now i{gca}j dyn_em 1 Z - "H2O2_NOW" "Background H2O2 for Aerosol-GOcart option Now" "kg kg-1" +state real h2o2_gca_jan i{gca}j dyn_em 1 Z i1 "H2O2_JAN" "Background H2O2 for Aerosol-GOcart option Jan" "kg kg-1" +state real h2o2_gca_feb i{gca}j dyn_em 1 Z i1 "H2O2_FEB" "Background H2O2 for Aerosol-GOcart option Feb" "kg kg-1" +state real h2o2_gca_mar i{gca}j dyn_em 1 Z i1 "H2O2_MAR" "Background H2O2 for Aerosol-GOcart option Mar" "kg kg-1" +state real h2o2_gca_apr i{gca}j dyn_em 1 Z i1 "H2O2_APR" "Background H2O2 for Aerosol-GOcart option Apr" "kg kg-1" +state real h2o2_gca_may i{gca}j dyn_em 1 Z i1 "H2O2_MAY" "Background H2O2 for Aerosol-GOcart option May" "kg kg-1" +state real h2o2_gca_jun i{gca}j dyn_em 1 Z i1 "H2O2_JUN" "Background H2O2 for Aerosol-GOcart option Jun" "kg kg-1" +state real h2o2_gca_jul i{gca}j dyn_em 1 Z i1 "H2O2_JUL" "Background H2O2 for Aerosol-GOcart option Jul" "kg kg-1" +state real h2o2_gca_aug i{gca}j dyn_em 1 Z i1 "H2O2_AUG" "Background H2O2 for Aerosol-GOcart option Aug" "kg kg-1" +state real h2o2_gca_sep i{gca}j dyn_em 1 Z i1 "H2O2_SEP" "Background H2O2 for Aerosol-GOcart option Sep" "kg kg-1" +state real h2o2_gca_oct i{gca}j dyn_em 1 Z i1 "H2O2_OCT" "Background H2O2 for Aerosol-GOcart option Oct" "kg kg-1" +state real h2o2_gca_nov i{gca}j dyn_em 1 Z i1 "H2O2_NOV" "Background H2O2 for Aerosol-GOcart option Nov" "kg kg-1" +state real h2o2_gca_dec i{gca}j dyn_em 1 Z i1 "H2O2_DEC" "Background H2O2 for Aerosol-GOcart option Dec" "kg kg-1" + +state real no3_gca_now i{gca}j dyn_em 1 Z - "NO3_NOW" "Background NO3 for Aerosol-GOcart option Now" "kg kg-1" +state real no3_gca_jan i{gca}j dyn_em 1 Z i1 "NO3_JAN" "Background NO3 for Aerosol-GOcart option Jan" "kg kg-1" +state real no3_gca_feb i{gca}j dyn_em 1 Z i1 "NO3_FEB" "Background NO3 for Aerosol-GOcart option Feb" "kg kg-1" +state real no3_gca_mar i{gca}j dyn_em 1 Z i1 "NO3_MAR" "Background NO3 for Aerosol-GOcart option Mar" "kg kg-1" +state real no3_gca_apr i{gca}j dyn_em 1 Z i1 "NO3_APR" "Background NO3 for Aerosol-GOcart option Apr" "kg kg-1" +state real no3_gca_may i{gca}j dyn_em 1 Z i1 "NO3_MAY" "Background NO3 for Aerosol-GOcart option May" "kg kg-1" +state real no3_gca_jun i{gca}j dyn_em 1 Z i1 "NO3_JUN" "Background NO3 for Aerosol-GOcart option Jun" "kg kg-1" +state real no3_gca_jul i{gca}j dyn_em 1 Z i1 "NO3_JUL" "Background NO3 for Aerosol-GOcart option Jul" "kg kg-1" +state real no3_gca_aug i{gca}j dyn_em 1 Z i1 "NO3_AUG" "Background NO3 for Aerosol-GOcart option Aug" "kg kg-1" +state real no3_gca_sep i{gca}j dyn_em 1 Z i1 "NO3_SEP" "Background NO3 for Aerosol-GOcart option Sep" "kg kg-1" +state real no3_gca_oct i{gca}j dyn_em 1 Z i1 "NO3_OCT" "Background NO3 for Aerosol-GOcart option Oct" "kg kg-1" +state real no3_gca_nov i{gca}j dyn_em 1 Z i1 "NO3_NOV" "Background NO3 for Aerosol-GOcart option Nov" "kg kg-1" +state real no3_gca_dec i{gca}j dyn_em 1 Z i1 "NO3_DEC" "Background NO3 for Aerosol-GOcart option Dec" "kg kg-1" + +rconfig integer gca_input_opt namelist,domains 1 0 irh "gca_input_opt" "0=do not process the GOcart Aerosol input from metgrid" + +package use_gca_input gca_input_opt==1 - state:p_gca,oh_gca_now,oh_gca_jan,oh_gca_feb,oh_gca_mar,oh_gca_apr,oh_gca_may,oh_gca_jun,oh_gca_jul,oh_gca_aug,oh_gca_sep,oh_gca_oct,oh_gca_nov,oh_gca_dec,h2o2_gca_now,h2o2_gca_jan,h2o2_gca_feb,h2o2_gca_mar,h2o2_gca_apr,h2o2_gca_may,h2o2_gca_jun,h2o2_gca_jul,h2o2_gca_aug,h2o2_gca_sep,h2o2_gca_oct,h2o2_gca_nov,h2o2_gca_dec,no3_gca_now,no3_gca_jan,no3_gca_feb,no3_gca_mar,no3_gca_apr,no3_gca_may,no3_gca_jun,no3_gca_jul,no3_gca_aug,no3_gca_sep,no3_gca_oct,no3_gca_nov,no3_gca_dec diff --git a/wrfv2_fire/Registry/registry.new3d_wif b/wrfv2_fire/Registry/registry.new3d_wif new file mode 100644 index 00000000..34fd535f --- /dev/null +++ b/wrfv2_fire/Registry/registry.new3d_wif @@ -0,0 +1,72 @@ +/############################################################################## +# This is an example registry. +# It has the necessary pieces to allow a set of input fields to come +# into the real program from metgrid. These fields are assumed to +# be on a separate vertical coordinate from the standard metgrid +# atmospheric fields. The usual purpose for this would be for +# bringing in aerosols. +# A different pressure for each month. +# The output from real is placed into the scalar arrays. +############################################################################### + +### Thompson Water Ice Friendly Aerosols WIF + +dimspec wif 2 namelist=num_wif_levels z num_wif_levels + +rconfig integer num_wif_levels namelist,domains 1 27 irh "num_wif_levels" "number of levels in the Thompson Water Ice Friendly Aerosols" "" +rconfig integer wif_input_opt namelist,domains 1 0 irh "wif_input_opt" "0=do not process the Water Ice Friendly Aerosol input from metgrid" + +state real p_wif_now i{wif}j dyn_em 1 Z - "P_WIF_NOW" "Pressure for Water Ice Friendly Aerosols Now" "Pa" +state real p_wif_jan i{wif}j dyn_em 1 Z i1 "P_WIF_JAN" "Pressure for Water Ice Friendly Aerosols Jan" "Pa" +state real p_wif_feb i{wif}j dyn_em 1 Z i1 "P_WIF_FEB" "Pressure for Water Ice Friendly Aerosols Feb" "Pa" +state real p_wif_mar i{wif}j dyn_em 1 Z i1 "P_WIF_MAR" "Pressure for Water Ice Friendly Aerosols Mar" "Pa" +state real p_wif_apr i{wif}j dyn_em 1 Z i1 "P_WIF_APR" "Pressure for Water Ice Friendly Aerosols Apr" "Pa" +state real p_wif_may i{wif}j dyn_em 1 Z i1 "P_WIF_MAY" "Pressure for Water Ice Friendly Aerosols May" "Pa" +state real p_wif_jun i{wif}j dyn_em 1 Z i1 "P_WIF_JUN" "Pressure for Water Ice Friendly Aerosols Jun" "Pa" +state real p_wif_jul i{wif}j dyn_em 1 Z i1 "P_WIF_JUL" "Pressure for Water Ice Friendly Aerosols Jul" "Pa" +state real p_wif_aug i{wif}j dyn_em 1 Z i1 "P_WIF_AUG" "Pressure for Water Ice Friendly Aerosols Aug" "Pa" +state real p_wif_sep i{wif}j dyn_em 1 Z i1 "P_WIF_SEP" "Pressure for Water Ice Friendly Aerosols Sep" "Pa" +state real p_wif_oct i{wif}j dyn_em 1 Z i1 "P_WIF_OCT" "Pressure for Water Ice Friendly Aerosols Oct" "Pa" +state real p_wif_nov i{wif}j dyn_em 1 Z i1 "P_WIF_NOV" "Pressure for Water Ice Friendly Aerosols Nov" "Pa" +state real p_wif_dec i{wif}j dyn_em 1 Z i1 "P_WIF_DEC" "Pressure for Water Ice Friendly Aerosols Dec" "Pa" + +state real w_wif_now i{wif}j dyn_em 1 Z - "W_WIF_NOW" "Background Water Friendly Aerosol option Now" "# kg-1" +state real w_wif_jan i{wif}j dyn_em 1 Z i1 "W_WIF_JAN" "Background Water Friendly Aerosol option Jan" "# kg-1" +state real w_wif_feb i{wif}j dyn_em 1 Z i1 "W_WIF_FEB" "Background Water Friendly Aerosol option Feb" "# kg-1" +state real w_wif_mar i{wif}j dyn_em 1 Z i1 "W_WIF_MAR" "Background Water Friendly Aerosol option Mar" "# kg-1" +state real w_wif_apr i{wif}j dyn_em 1 Z i1 "W_WIF_APR" "Background Water Friendly Aerosol option Apr" "# kg-1" +state real w_wif_may i{wif}j dyn_em 1 Z i1 "W_WIF_MAY" "Background Water Friendly Aerosol option May" "# kg-1" +state real w_wif_jun i{wif}j dyn_em 1 Z i1 "W_WIF_JUN" "Background Water Friendly Aerosol option Jun" "# kg-1" +state real w_wif_jul i{wif}j dyn_em 1 Z i1 "W_WIF_JUL" "Background Water Friendly Aerosol option Jul" "# kg-1" +state real w_wif_aug i{wif}j dyn_em 1 Z i1 "W_WIF_AUG" "Background Water Friendly Aerosol option Aug" "# kg-1" +state real w_wif_sep i{wif}j dyn_em 1 Z i1 "W_WIF_SEP" "Background Water Friendly Aerosol option Sep" "# kg-1" +state real w_wif_oct i{wif}j dyn_em 1 Z i1 "W_WIF_OCT" "Background Water Friendly Aerosol option Oct" "# kg-1" +state real w_wif_nov i{wif}j dyn_em 1 Z i1 "W_WIF_NOV" "Background Water Friendly Aerosol option Nov" "# kg-1" +state real w_wif_dec i{wif}j dyn_em 1 Z i1 "W_WIF_DEC" "Background Water Friendly Aerosol option Dec" "# kg-1" + +state real i_wif_now i{wif}j dyn_em 1 Z - "I_WIF_NOW" "Background Ice Friendly Aerosol option Now" "# kg-1" +state real i_wif_jan i{wif}j dyn_em 1 Z i1 "I_WIF_JAN" "Background Ice Friendly Aerosol option Jan" "# kg-1" +state real i_wif_feb i{wif}j dyn_em 1 Z i1 "I_WIF_FEB" "Background Ice Friendly Aerosol option Feb" "# kg-1" +state real i_wif_mar i{wif}j dyn_em 1 Z i1 "I_WIF_MAR" "Background Ice Friendly Aerosol option Mar" "# kg-1" +state real i_wif_apr i{wif}j dyn_em 1 Z i1 "I_WIF_APR" "Background Ice Friendly Aerosol option Apr" "# kg-1" +state real i_wif_may i{wif}j dyn_em 1 Z i1 "I_WIF_MAY" "Background Ice Friendly Aerosol option May" "# kg-1" +state real i_wif_jun i{wif}j dyn_em 1 Z i1 "I_WIF_JUN" "Background Ice Friendly Aerosol option Jun" "# kg-1" +state real i_wif_jul i{wif}j dyn_em 1 Z i1 "I_WIF_JUL" "Background Ice Friendly Aerosol option Jul" "# kg-1" +state real i_wif_aug i{wif}j dyn_em 1 Z i1 "I_WIF_AUG" "Background Ice Friendly Aerosol option Aug" "# kg-1" +state real i_wif_sep i{wif}j dyn_em 1 Z i1 "I_WIF_SEP" "Background Ice Friendly Aerosol option Sep" "# kg-1" +state real i_wif_oct i{wif}j dyn_em 1 Z i1 "I_WIF_OCT" "Background Ice Friendly Aerosol option Oct" "# kg-1" +state real i_wif_nov i{wif}j dyn_em 1 Z i1 "I_WIF_NOV" "Background Ice Friendly Aerosol option Nov" "# kg-1" +state real i_wif_dec i{wif}j dyn_em 1 Z i1 "I_WIF_DEC" "Background Ice Friendly Aerosol option Dec" "# kg-1" + +package use_wif_input wif_input_opt==1 - state:p_wif_now,p_wif_jan,p_wif_feb,p_wif_mar,p_wif_apr,p_wif_may,p_wif_jun,p_wif_jul,p_wif_aug,p_wif_sep,p_wif_oct,p_wif_nov,p_wif_dec,w_wif_now,w_wif_jan,w_wif_feb,w_wif_mar,w_wif_apr,w_wif_may,w_wif_jun,w_wif_jul,w_wif_aug,w_wif_sep,w_wif_oct,w_wif_nov,w_wif_dec,i_wif_now,i_wif_jan,i_wif_feb,i_wif_mar,i_wif_apr,i_wif_may,i_wif_jun,i_wif_jul,i_wif_aug,i_wif_sep,i_wif_oct,i_wif_nov,i_wif_dec + +state real qnwfa ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QNWFA" "water-friendly aerosol number con" "# kg(-1)" +state real qnifa ikjftb scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "QNIFA" "ice-friendly aerosol number con" "# kg(-1)" + +state real dfi_qnwfa ikjftb dfi_scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "DFI_QNWFA" "DFI water-friendly aerosol number con" "# kg(-1)" +state real dfi_qnifa ikjftb dfi_scalar 1 - \ + i0rhusdf=(bdy_interp:dt) "DFI_QNIFA" "DFI ice-friendly aerosol number con" "# kg(-1)" + diff --git a/wrfv2_fire/Registry/registry.rasm_diag b/wrfv2_fire/Registry/registry.rasm_diag new file mode 100644 index 00000000..fab26758 --- /dev/null +++ b/wrfv2_fire/Registry/registry.rasm_diag @@ -0,0 +1,92 @@ +# Registry file specifically for additional RASM diagnostic climate output. +# -Created by Jose Renteria, Amy Solomon, Mark Seefeldt + +# New dimspec. Set the number of periods per day for monthly diurnal averaging + +dimspec dc 2 constant=8 z diurnal_cycles + +# Namelist parameters + +rconfig integer mean_diag namelist,time_control 1 0 - "mean diagnostics flag" +rconfig integer mean_freq namelist,time_control 1 0 - "mean output frequency" +rconfig integer mean_interval namelist,time_control max_domains 0 - "mean output interval" +rconfig integer mean_diag_interval namelist,time_control max_domains 0 - "mean output interval m" +rconfig integer mean_diag_interval_s namelist,time_control max_domains 0 - "mean output interval s" +rconfig integer mean_diag_interval_m namelist,time_control max_domains 0 - "mean output interval m" +rconfig integer mean_diag_interval_h namelist,time_control max_domains 0 - "mean output interval h" +rconfig integer mean_diag_interval_d namelist,time_control max_domains 0 - "mean output interval d" +rconfig integer mean_diag_interval_mo namelist,time_control max_domains 0 - "mean output interval mo" +rconfig integer diurnal_diag namelist,time_control 1 0 - "diurnal diagnostics flag" + +# Climate: Mean - output arrays of averages +state real PSFC_MEAN ij misc 1 - rh5 "PSFC_M" "AVERAGE SURFACE PRESSURE" "Pa" +state real TSK_MEAN ij misc 1 - rh5 "TSK_M" "AVERAGE SURFACE SKIN TEMPERATURE" "K" +state real PMSL_MEAN ij misc 1 - rh5 "PMSL_M" "AVERAGE SEA LEVEL PRESSURE" "Pa" +state real T2_MEAN ij misc 1 - rh5 "T2_M" "AVERAGE TEMPERATURE AT 2M" "K" +state real TH2_MEAN ij misc 1 - rh5 "TH2_M" "AVERAGE POTENTIAL TEMPERATURE AT 2M" "K" +state real Q2_MEAN ij misc 1 - rh5 "Q2_M" "AVERAGE WATER VAPOR MIXING RATIO AT 2M" "kg kg-1" +state real U10_MEAN ij misc 1 - rh5 "U10_M" "AVERAGE U-COMPONENT OF WIND AT 10M" "m s-1" +state real V10_MEAN ij misc 1 - rh5 "V10_M" "AVERAGE V-COMPONENT OF WIND AT 10M" "m s-1" +state real HFX_MEAN ij misc 1 - rh5 "HFX_M" "AVERAGE SENSIBLE HEAT FLUX AT THE SURFACE" "W m-2" +state real LH_MEAN ij misc 1 - rh5 "LH_M" "AVERAGE LATENT HEAT FLUX AT THE SURFACE" "W m-2" +state real SWDNB_MEAN ij misc 1 - rh5 "SWDNB_M" "AVERAGE DOWNWARD SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real GLW_MEAN ij misc 1 - rh5 "GLW_M" "AVERAGE DOWNWARD LONGWAVE FLUX AT GROUND SURFACE" "W m-2" +state real LWUPB_MEAN ij misc 1 - rh5 "LWUPB_M" "AVERAGE UPWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" +state real SWUPB_MEAN ij misc 1 - rh5 "SWUPB_M" "AVERAGE UPWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWUPT_MEAN ij misc 1 - rh5 "SWUPT_M" "AVERAGE UPWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real SWDNT_MEAN ij misc 1 - rh5 "SWDNT_M" "AVERAGE DOWNWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real LWUPT_MEAN ij misc 1 - rh5 "LWUPT_M" "AVERAGE UPWELLING LONGWAVE FLUX AT TOP" "W m-2" +state real LWDNT_MEAN ij misc 1 - rh5 "LWDNT_M" "AVERAGE DOWNWELLING LONGWAVE FLUX AT TOP" "W m-2" +state character OUTDATE_MEAN - misc - - - "" "" +state integer NSTEPS_MEAN - misc - - r "NSTEP_M" "NUMBER OF MEAN STEPS ACCUMULATED" + +# Climate: Diurnal - output arrays of averages for each cycle +state real PSFC_DIURN i{dc}j misc 1 - rh6 "PSFC_D" "DIURNAL AVERAGE SURFACE PRESSURE" "Pa" +state real TSK_DIURN i{dc}j misc 1 - rh6 "TSK_D" "DIURNAL AVERAGE SURFACE SKIN TEMPERATURE" "K" +state real T2_DIURN i{dc}j misc 1 - rh6 "T2_D" "DIURNAL AVERAGE TEMPERATURE AT 2M" "K" +state real TH2_DIURN i{dc}j misc 1 - rh6 "TH2_D" "DIURNAL AVERAGE POTENTIAL TEMPERATURE AT 2M" "K" +state real Q2_DIURN i{dc}j misc 1 - rh6 "Q2_D" "DIURNAL AVERAGE WATER VAPOR MIXING RATIO AT 2M" "kg kg-1" +state real U10_DIURN i{dc}j misc 1 - rh6 "U10_D" "DIURNAL AVERAGE U-COMPONENT OF WIND AT 10M" "m s-1" +state real V10_DIURN i{dc}j misc 1 - rh6 "V10_D" "DIURNAL AVERAGE V-COMPONENT OF WIND AT 10M" "m s-1" +state real HFX_DIURN i{dc}j misc 1 - rh6 "HFX_D" "DIURNAL AVERAGE SENSIBLE HEAT FLUX AT THE SURFACE" "W m-2" +state real LH_DIURN i{dc}j misc 1 - rh6 "LH_D" "DIURNAL AVERAGE LATENT HEAT FLUX AT THE SURFACE" "W m-2" +state real SWDNB_DIURN i{dc}j misc 1 - rh6 "SWDNB_D" "DIURNAL AVERAGE DOWNWARD SHORTWAVE FLUX AT GROUND SURFACE" "W m-2" +state real GLW_DIURN i{dc}j misc 1 - rh6 "GLW_D" "DIURNAL AVERAGE DOWNWARD LONGWAVE FLUX AT GROUND SURFACE" "W m-2" +state real LWUPB_DIURN i{dc}j misc 1 - rh6 "LWUPB_D" "DIURNAL AVERAGE UPWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" +state real SWUPB_DIURN i{dc}j misc 1 - rh6 "SWUPB_D" "DIURNAL AVERAGE UPWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWUPT_DIURN i{dc}j misc 1 - rh6 "SWUPT_D" "DIURNAL AVERAGE UPWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real SWDNT_DIURN i{dc}j misc 1 - rh6 "SWDNT_D" "DIURNAL AVERAGE DOWNWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real LWUPT_DIURN i{dc}j misc 1 - rh6 "LWUPT_D" "DIURNAL AVERAGE UPWELLING LONGWAVE FLUX AT TOP" "W m-2" +state real LWDNT_DIURN i{dc}j misc 1 - rh6 "LWDNT_D" "DIURNAL AVERAGE DOWNWELLING LONGWAVE FLUX AT TOP" "W m-2" +state character OUTDATE_DIURN - misc - - - "" "" +state integer NSTEPS_DIURN - misc - - r "NSTEP_D" "NUMBER OF DIURNAL STEPS ACCUMULATED" + +# Climate: Diurnal variables to computer intermediate avereges +state real PSFC_DTMP ij misc 1 - r "PSFC_DTM" "DIURNAL TEMP AVERAGE SURFACE PRESSURE" "Pa" +state real TSK_DTMP ij misc 1 - r "TSK_DTM" "DIURNAL TEMP AVERAGE SURFACE SKIN TEMPERATURE" "K" +state real T2_DTMP ij misc 1 - r "T2_DTM" "DIURNAL TEMP AVERAGE TEMPERATURE AT 2M" "K" +state real TH2_DTMP ij misc 1 - r "TH2_DTM" "DIURNAL TEMP AVERAGE POTENTIAL TEMPERATURE AT 2M" "K" +state real Q2_DTMP ij misc 1 - r "Q2_DTM" "DIURNAL TEMP WATER VAPOR MIXING RATIO AT 2M" "kg kg-1" +state real U10_DTMP ij misc 1 - r "U10_DTM" "DIURNAL TEMP U-COMPONENT OF WIND AT 10M" "m s-1" +state real V10_DTMP ij misc 1 - r "V10_DTM" "DIURNAL TEMP V-COMPONENT OF WIND AT 10M" "m s-1" +state real HFX_DTMP ij misc 1 - r "HFX_DTM" "DIURNAL TEMP AVERAGE SENSIBLE HEAT FLUX AT THE SURFACE" "W m-2" +state real LH_DTMP ij misc 1 - r "LH_DTM" "DIURNAL TEMP AVERAGE LATENT HEAT FLUX AT THE SURFACE" "W m-2" +state real SWDNB_DTMP ij misc 1 - r "SWDNB_DTM" "DIURNAL TEMP AVERAGE DOWNWARD SHORT WAVE FLUX AT GROUND SURFACE" "W m-2" +state real GLW_DTMP ij misc 1 - r "GLW_DTM" "DIURNAL TEMP AVERAGE DOWNWARD LONG WAVE FLUX AT GROUND SURFACE" "W m-2" +state real LWUPB_DTMP ij misc 1 - r "LWUPB_DTM" "DIURNAL TEMP AVERAGE UPWELLING LONGWAVE FLUX AT BOTTOM" "W m-2" +state real SWUPB_DTMP ij misc 1 - r "SWUPB_DTM" "DIURNAL TEMP AVERAGE UPWELLING SHORTWAVE FLUX AT BOTTOM" "W m-2" +state real SWUPT_DTMP ij misc 1 - r "SWUPT_DTM" "DIURNAL TEMP AVERAGE UPWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real SWDNT_DTMP ij misc 1 - r "SWDNT_DTM" "DIURNAL TEMP AVERAGE DOWNWELLING SHORTWAVE FLUX AT TOP" "W m-2" +state real LWUPT_DTMP ij misc 1 - r "LWUPT_DTM" "DIURNAL TEMP AVERAGE UPWELLING LONGWAVE FLUX AT TOP" "W m-2" +state real LWDNT_DTMP ij misc 1 - r "LWDNT_DTM" "DIURNAL TEMP AVERAGE DOWNWELLING LONGWAVE FLUX AT TOP" "W m-2" +state integer NSTEPSMEAN_DIURN - misc - - r "NSTEP_DTM" "NUMBER OF MEAN STEPS ACCUMULATED IN DIURNAL Calculation" + +# Package declaration for RASM diagnostic output + +# -RASM_DIAG: Mean +package mean_diag_off mean_diag==0 - - +package mean_diag_on mean_diag==1 - state:psfc_mean,tsk_mean,pmsl_mean,t2_mean,th2_mean,q2_mean,u10_mean,v10_mean,hfx_mean,lh_mean,swdnb_mean,glw_mean,lwupb_mean,swupb_mean,swupt_mean,swdnt_mean,lwupt_mean,lwdnt_mean + +# -RASM_DIAG: Diurnal +package diurnal_diag_off diurnal_diag==0 - - +package diurnal_diag_on diurnal_diag==1 - state:psfc_diurn,tsk_diurn,t2_diurn,th2_diurn,q2_diurn,u10_diurn,v10_diurn,hfx_diurn,lh_diurn,swdnb_diurn,glw_diurn,lwupb_diurn,swupb_diurn,swupt_diurn,swdnt_diurn,lwupt_diurn,lwdnt_diurn diff --git a/wrfv2_fire/Registry/registry.sbm b/wrfv2_fire/Registry/registry.sbm index 57790ad8..5160b931 100644 --- a/wrfv2_fire/Registry/registry.sbm +++ b/wrfv2_fire/Registry/registry.sbm @@ -290,9 +290,6 @@ state real qip_effr ikjftb scalar 1 - \ state real qid_effr ikjftb scalar 1 - \ i0rhusdf=(bdy_interp:dt) "QID_EFF_RADIUS" "QID Effective Radius" "Microns" -state real th_old ikj misc 1 - rusd "TH_OLD" "Old Value of Th" "K" -state real qv_old ikj misc 1 - rusd "QV_OLD" "Old Value of qv" "kg kg-1" - state real kext_ql ikj misc 1 - rh05 "KEXT_QL" " Extinction Coefficient for water " "m-1" state real kext_qic ikj misc 1 - rh05 "KEXT_QIC" " Extinction Coefficient for ice columns " "m-1" state real kext_qip ikj misc 1 - rh05 "KEXT_QIP" " Extinction Coefficient for ice plates " "m-1" diff --git a/wrfv2_fire/Registry/registry.stoch b/wrfv2_fire/Registry/registry.stoch index f1ce95e8..57fda079 100644 --- a/wrfv2_fire/Registry/registry.stoch +++ b/wrfv2_fire/Registry/registry.stoch @@ -6,10 +6,16 @@ state real VERTSTRUCS ikj dyn_em 1 - rd "VERTSTRUCS" "ver # full or possibly thin (i.e., length of 1) 3D arrays depending of dimension i{stoclev}j +state real field_sf i{stoclev}j dyn_em 1 - rhdf=(p2c) "field_sf " "field for surface perturbations " "" +state real field_pbl i{stoclev}j dyn_em 1 - rhdf=(p2c) "field_pbl " "field for surface perturbations " "" +state real field_conv i{stoclev}j dyn_em 1 - rhdf=(p2c) "field_conv " "field for surface perturbations " "" state real ru_tendf_stoch i{stoclev}j dyn_em 1 X rhdf=(p2c) "ru_tendf_stoch" "stochastic forcing, U " "m/s^2" state real rv_tendf_stoch i{stoclev}j dyn_em 1 Y rhdf=(p2c) "rv_tendf_stoch" "stochastic forcing, V " "m/s^2" state real rt_tendf_stoch i{stoclev}j dyn_em 1 - rhdf=(p2c) "rt_tendf_stoch" "stochastic forcing, T " "K/s" state real rand_pert i{stoclev}j dyn_em 1 - rhdf=(p2c) "rand_pert" "randomn field " "" +state real pattern_spp_conv i{stoclev}j dyn_em 1 - rhdf=(p2c) "pattern_spp_conv" "pattern sppt conv" "" +state real pattern_spp_pbl i{stoclev}j dyn_em 1 - rhdf=(p2c) "pattern_spp_pbl" "pattern sppt pbl" "" +state real pattern_spp_lsm i{stoclev}j dyn_em 1 - rhdf=(p2c) "pattern_spp_lsm" "pattern sppt lsm" "" state real rstoch i{stoclev}j dyn_em 1 - rhdf=(p2c) "rstoch" "randomn field for SPPT" "" state real RAND_REAL i{stoclev}j dyn_em 1 XYZ - "RAND_REAL" "array for FFTs" "" @@ -27,6 +33,22 @@ state real SPFORCC ij misc 1 XY r "SPFORCC" "rea state real SPFORCS ij misc 1 XY r "SPFORCS" "imag. spect. coeff. of randomn perturbation field" "" "" state real SP_AMP ij misc 1 - r "SP_AMP" "amplitude of random perturbation field" "" "" +state real SPFORCC2 ij misc 1 XY irh "SPFORCC2" "real spect. coeff. of randomn perturbation field" "" "" +state real SPFORCS2 ij misc 1 XY irh "SPFORCS2" "imag. spect. coeff. of randomn perturbation field" "" "" +state real SP_AMP2 ij misc 1 - r "SP_AMP2" "amplitude of random perturbation field" "" "" + +state real SPFORCC3 ij misc 1 XY irh "SPFORCC3" "real spect. coeff. of randomn perturbation field" "" "" +state real SPFORCS3 ij misc 1 XY irh "SPFORCS3" "imag. spect. coeff. of randomn perturbation field" "" "" +state real SP_AMP3 ij misc 1 - r "SP_AMP3" "amplitude of random perturbation field" "" "" + +state real SPFORCC4 ij misc 1 XY irh "SPFORCC4" "real spect. coeff. of randomn perturbation field" "" "" +state real SPFORCS4 ij misc 1 XY irh "SPFORCS4" "imag. spect. coeff. of randomn perturbation field" "" "" +state real SP_AMP4 ij misc 1 - r "SP_AMP4" "amplitude of random perturbation field" "" "" + +state real SPFORCC5 ij misc 1 XY r "SPFORCC5" "real spect. coeff. of randomn perturbation field" "" "" +state real SPFORCS5 ij misc 1 XY r "SPFORCS5" "imag. spect. coeff. of randomn perturbation field" "" "" +state real SP_AMP5 ij misc 1 - r "SP_AMP5" "amplitude of random perturbation field" "" "" + state real SPPTFORCC ij misc 1 XY r "SPPTFORCC" "real spect. coeff. of randomn perturbation field in SPPT" "" "" state real SPPTFORCS ij misc 1 XY r "SPPTFORCS" "imag. spect. coeff. of randomn perturbation field in SPPT" "" "" state real SPPT_AMP ij misc 1 - r "SPPT_AMP" "amplitude of random perturbation field in SPPT" "" "" @@ -35,9 +57,12 @@ state real SPPT_AMP ij misc 1 - r "SPPT_AMP" "amp # 1d arrays state real VERTAMPT k misc 1 - r "VERTAMPT" "vert. amplitude of stoch. temperature perturb." "" "" state real VERTAMPUV k misc 1 - r "VERTAMPUV" "vert. amplitude of stoch. u,v perturb." "" "" -state integer ISEEDARR_RAND_PERT k misc 1 - rh "ISEEDARR_RAND_PERTURB" "Array to hold seed for restart, RAND_PERT" "" "" -state integer ISEEDARR_SPPT k misc 1 - rh "ISEEDARR_SPPT" "Array to hold seed for restart, SPPT" "" "" -state integer ISEEDARR_SKEBS k misc 1 - rh "ISEEDARR_SKEBS" "Array to hold seed for restart, SKEBS" "" "" +state integer ISEEDARR_SPPT k misc 1 - rh "ISEEDARR_SPPT" "Array to hold seed for restart, SPPT" "" "" +state integer ISEEDARR_SKEBS k misc 1 - rh "ISEEDARR_SKEBS" "Array to hold seed for restart, SKEBS" "" "" +state integer ISEEDARR_RAND_PERT k misc 1 - rh "ISEEDARR_RAND_PERTURB" "Array to hold seed for restart, RAND_PERT" "" "" +state integer iseedarr_spp_conv k misc 1 - rh "iseedarray_spp_conv" "Array to hold seed for restart, RAND_PERT2" "" "" +state integer iseedarr_spp_pbl k misc 1 - rh "iseedarray_spp_pbl" "Array to hold seed for restart, RAND_PERT3" "" "" +state integer iseedarr_spp_lsm k misc 1 - rh "iseedarray_spp_lsm" "Array to hold seed for restart, RAND_PERT4" "" "" # 1d arrays for FFT transpose state real RAND_REAL_xxx i{stoclev}jx dyn_em 1 XYZ @@ -53,6 +78,9 @@ state real ALPH_T - misc 1 - - "A state real ALPH_PSI - misc 1 - - "ALPH_PSI " "autoregressive coeff. for psi perturb." "" state real ALPH_SPPT - misc 1 - - "ALPH_SPPT" "autoregressive coeff. for tendf perturb." "" state real ALPH_RAND - misc 1 - - "ALPH_RAND " "autoregressive coeff. for generic rand. pert." "" +state real ALPH_RAND2 - misc 1 - - "ALPH_RAND2" "autoregressive coeff. for generic rand. pert." "" +state real ALPH_RAND3 - misc 1 - - "ALPH_RAND3" "autoregressive coeff. for generic rand. pert." "" +state real ALPH_RAND4 - misc 1 - - "ALPH_RAND4" "autoregressive coeff. for generic rand. pert." "" state logical did_stoch - misc 1 - r "DID_STOCH" "Logical to tell us that we already did the initialization for dom 1" "" # Namelist parameters for random number streams @@ -85,6 +113,7 @@ rconfig integer lmaxforch derived 1 0 rconfig integer kmaxforcth derived 1 0 - "sneak variable to make it work" "" "" rconfig integer lmaxforcth derived 1 0 - "sneak variable to make it work" "" "" + # Namelist parameters for stochastically parameterized perturbation tendencies (SPPT) rconfig integer sppt namelist,stoch max_domains 0 - "generate array with random perturbations: 0=off, 1=on" @@ -93,7 +122,7 @@ rconfig real stddev_cutoff_sppt namelist,stoch max_domains rconfig real lengthscale_sppt namelist,stoch max_domains 150000.0 - "Correlation length scale in meters for SPPT" rconfig real timescale_sppt namelist,stoch max_domains 21600.0 - "Decorrelation time scale in s for SPPT" rconfig integer sppt_vertstruc namelist,stoch 1 0 - "vertical structure for sppt: 0=constant, 1=random phase" -rconfig integer ISEED_SPPT namelist,stoch 1 53 - "ISEED_SPPT" "RANDOM SEED FOR SPPT " "" +rconfig integer iseed_sppt namelist,stoch 1 53 - "ISEED_SPPT" "RANDOM SEED FOR SPPT " "" # Namelist parameters for random perturbations @@ -103,20 +132,58 @@ rconfig real stddev_cutoff_rand_pert namelist,stoch max_domains rconfig real lengthscale_rand_pert namelist,stoch max_domains 500000.0 - "Correlation length scale in meters" rconfig real timescale_rand_pert namelist,stoch max_domains 21600.0 - "Decorrelation time scale in s" rconfig integer rand_pert_vertstruc namelist,stoch 1 0 - "vertical structure for random perturb: 0=constant, 1=random phase" -rconfig integer ISEED_RAND_PERT namelist,stoch 1 17 - "ISEED_RAND_PERT" "RANDOM SEED FOR RAND_PERT " "" +rconfig integer iseed_rand_pert namelist,stoch 1 17 - "ISEED_RAND_PERT" "RANDOM SEED FOR RAND_PERT " "" + +# Namelist parameters for stochastic perturbed parameters + +rconfig integer spp namelist,stoch max_domains 0 - "generate array with random perturbations: 0=off, 1=on" +rconfig logical hrrr_cycling namelist,stoch 1 .false. - "switch to control restart in quasi-cycled hrrr-forecasts" +# Namelist parameters for stochastic perturbed parameters (SPP) for convective scheme + +rconfig integer spp_conv namelist,stoch max_domains 0 - "generate array with random perturbations: 0=off, 1=on" +rconfig real gridpt_stddev_spp_conv namelist,stoch max_domains 0.3 - "gridpoint standard deviation of random perturbations" +rconfig real stddev_cutoff_spp_conv namelist,stoch max_domains 3.0 - "cutoff tails of pdf above this threshold standard deviation" +rconfig real lengthscale_spp_conv namelist,stoch max_domains 150000.0 - "Correlation length scale in meters" +rconfig real timescale_spp_conv namelist,stoch max_domains 21600.0 - "Decorrelation time scale in s" +rconfig integer vertstruc_spp_conv namelist,stoch 1 0 - "vertical structure for random perturb: 0=constant, 1=random phase" +rconfig integer iseed_spp_conv namelist,stoch 1 171 - "ISEED_RAND_PERT" "RANDOM SEED FOR RAND_PERT " "" + +# Namelist parameters for stochastic perturbed parameters (SPP) for pbl + +rconfig integer spp_pbl namelist,stoch max_domains 0 - "generate array with random perturbations: 0=off, 1=on" +rconfig real gridpt_stddev_spp_pbl namelist,stoch max_domains 0.15 - "gridpoint standard deviation of random perturbations" +rconfig real stddev_cutoff_spp_pbl namelist,stoch max_domains 2.0 - "cutoff tails of pdf above this threshold standard deviation" +rconfig real lengthscale_spp_pbl namelist,stoch max_domains 700000.0 - "Correlation length scale in meters" +rconfig real timescale_spp_pbl namelist,stoch max_domains 21600.0 - "Decorrelation time scale in s" +rconfig integer vertstruc_spp_pbl namelist,stoch 1 0 - "vertical structure for random perturb: 0=constant, 1=random phase" +rconfig integer iseed_spp_pbl namelist,stoch 1 217 - "ISEED_RAND_PERT" "RANDOM SEED FOR RAND_PERT " "" + + +# Namelist parameters for stochastic perturbed parameters (SPP) for lsm + +rconfig integer spp_lsm namelist,stoch max_domains 0 - "generate array with random perturbations: 0=off, 1=on" +rconfig real gridpt_stddev_spp_lsm namelist,stoch max_domains 0.3 - "gridpoint standard deviation of random perturbations" +rconfig real stddev_cutoff_spp_lsm namelist,stoch max_domains 3.0 - "cutoff tails of pdf above this threshold standard deviation" +rconfig real lengthscale_spp_lsm namelist,stoch max_domains 50000.0 - "Correlation length scale in meters" +rconfig real timescale_spp_lsm namelist,stoch max_domains 86400.0 - "Decorrelation time scale in s" +rconfig integer vertstruc_spp_lsm namelist,stoch 1 0 - "vertical structure for random perturb: 0=constant, 1=random phase" +rconfig integer iseed_spp_lsm namelist,stoch 1 317 - "ISEED_RAND_PERT" "RANDOM SEED FOR RAND_PERT " "" # Derived namelist parameters used in share/module_check_amundo.F rconfig integer skebs_on derived 1 0 - "skebs_on" "skebs arrays are declared&filled for all domains" "" rconfig integer sppt_on derived 1 0 - "sppt_on" "sppt arrays are declared&filled for all domains" "" +rconfig integer spp_on derived 1 0 - "skebs_on" "skebs arrays are declared&filled for all domains" "" rconfig integer rand_perturb_on derived 1 0 - "rand_perturb_on " "random perturb. array is declared&filled for all domains" "" rconfig integer num_stoch_levels derived 1 1 - "num_stoch_levels" "number of vertical levels of random fields" "" # Package declarations -package sppt_perturb sppt_on==1 - state:rstoch,SPPTFORCS,SPPTFORCC,SPPT_AMP,VERTSTRUCC,VERTSTRUCS,VERTAMPT,RAND_REAL,RAND_IMAG,RAND_REAL_xxx,RAND_REAL_yyy,RAND_IMAG_xxx,RAND_IMAG_yyy +package sppt_perturb sppt_on==1 - state:rstoch,SPPTFORCS,SPPTFORCC,SPPT_AMP,VERTSTRUCC,VERTSTRUCS,VERTAMPT,RAND_REAL,RAND_IMAG,RAND_REAL_xxx,RAND_REAL_yyy,RAND_IMAG_xxx,RAND_IMAG_yyy + +package skebs_perturb skebs_on==1 - state:ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch,SPSTREAMFORCC,SPSTREAMFORCS,SPTFORCC,SPTFORCS,SPSTREAM_AMP,SPT_AMP,VERTSTRUCC,VERTSTRUCS,VERTAMPT,VERTAMPUV,RAND_REAL,RAND_IMAG,RAND_REAL_xxx,RAND_REAL_yyy,RAND_IMAG_xxx,RAND_IMAG_yyy -package random_perturb rand_perturb_on==1 - state:rand_pert,SPFORCS,SPFORCC,SP_AMP,VERTSTRUCC,VERTSTRUCS,VERTAMPT,RAND_REAL,RAND_IMAG,RAND_REAL_xxx,RAND_REAL_yyy,RAND_IMAG_xxx,RAND_IMAG_yyy +package random_perturb rand_perturb_on==1 - state:rand_pert,SPFORCS,SPFORCC,SP_AMP,VERTSTRUCC,VERTSTRUCS,VERTAMPT,RAND_REAL,RAND_IMAG,RAND_REAL_xxx,RAND_REAL_yyy,RAND_IMAG_xxx,RAND_IMAG_yyy -package skebs_perturb skebs_on==1 - state:ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch,SPSTREAMFORCC,SPSTREAMFORCS,SPTFORCC,SPTFORCS,SPSTREAM_AMP,SPT_AMP,VERTSTRUCC,VERTSTRUCS,VERTAMPT,VERTAMPUV,RAND_REAL,RAND_IMAG,RAND_REAL_xxx,RAND_REAL_yyy,RAND_IMAG_xxx,RAND_IMAG_yyy +package stoch_param_perturb spp_on==1 - state:pattern_spp_conv,field_conv,SPFORCS2,SPFORCC2,SP_AMP2,pattern_spp_pbl,field_pbl,SPFORCS3,SPFORCC3,SP_AMP3,pattern_spp_lsm,field_sf,SPFORCS4,SPFORCC4,SP_AMP4,VERTSTRUCC,VERTSTRUCS,VERTAMPT,RAND_REAL,RAND_IMAG,RAND_REAL_xxx,RAND_REAL_yyy,RAND_IMAG_xxx,RAND_IMAG_yyy diff --git a/wrfv2_fire/Registry/registry.tornado b/wrfv2_fire/Registry/registry.tornado index 9bdcdd83..f01c4a5d 100644 --- a/wrfv2_fire/Registry/registry.tornado +++ b/wrfv2_fire/Registry/registry.tornado @@ -7,8 +7,8 @@ # That, and downscale feedback, are needed to ensure correct # multi-domain maximum calculations. state real tg_max_m10wind ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MAX_M10WIND" "Maximum 10m wind magnitude since last output time." "m s-1" -state real tg_max_wwind ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MAX_WWIND" "Maximum vertical wind below 400mbar since last output time" "m s-1" -state real tg_min_wwind ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MIN_WWIND" "Minimum vertical wind below 400mbar since last output time" "m s-1" +state real tg_max_wwind ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MAX_WWIND" "Maximum vertical wind in lowest 400mbar of atmos since last output time" "m s-1" +state real tg_min_wwind ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MIN_WWIND" "Minimum vertical wind in lowest 400mbar of atmos since last output time" "m s-1" state real tg_max_zhel_25 ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MAX_ZHEL_25" "Maximum helicity vertical term 2-5km above ground since last output time" "m2 s-2" state real tg_min_zhel_25 ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MIN_ZHEL_25" "Minimum helicity vertical term 2-5km above ground since last output time" "m2 s-2" state real tg_max_zhel_03 ij dyn_nmm 1 f rh0123u=(UpMax)d=(DownCopy) "TG_MAX_ZHEL_03" "Maximum helicity vertical term 0-3km above ground since last output time" "m2 s-2" diff --git a/wrfv2_fire/Registry/registry.tracker b/wrfv2_fire/Registry/registry.tracker index cb7394b7..da5e8a81 100644 --- a/wrfv2_fire/Registry/registry.tracker +++ b/wrfv2_fire/Registry/registry.tracker @@ -5,9 +5,16 @@ # Note that the {otrak} dimension is declared in registry.dimspec -state integer interesting ij dyn_nmm 1 - rh "interesting" "Bitmask for area of interest flags (0=not in area of interest)" "" +state integer interesting ij dyn_nmm 1 - rh01 "interesting" "Bitmask for area of interest flags (0=not in area of interest)" "" +state integer nest_imid {maxkid} dyn_nmm 1 - r "nest_imid" "Last X-dir. middle point for each child domains" +state integer nest_jmid {maxkid} dyn_nmm 1 - r "nest_jmid" "Last Y-dir. middle point for each child domains" +state real cuprecip_swath ij dyn_nmm 1 - rh01u=(UpMax)d=(DownCopy) "cuprecip_swath" "Accumulated convective precip in area of interest" "m" state real precip_swath ij dyn_nmm 1 - rh01u=(UpMax)d=(DownCopy) "precip_swath" "Accumulated total precip in area of interest" "m" state real windsq_swath ij dyn_nmm 1 - rh01u=(UpMax)d=(DownCopy) "windsq_swath" "Accumulated maximum square of wind magnitude in area of interest" "m2 s-2" +state real suswind_time - dyn_nmm 1 - r "suswind_time" "Time over which suswind has been accumulated so far." "s" +state real suswind ij dyn_nmm 1 - rh01u=(UpMax)d=(DownCopy) "suswind" "Sustained wind over sustainment interval" "m s-1" +state real wind10_ratio ij dyn_nmm 1 - rd=(DownCopy) "wind10_ratio" "Ratio of lowest model level wind to 10m wind" "" +state real suswind_swath ij dyn_nmm 1 - rh01u=(UpMax)d=(DownCopy) "suswind_swath" "Maximum sustained wind over accumulation interval" "m s-1" state logical update_interest - dyn_nmm .false. - r "update_interest" ".true. = need to update area of interest" "" rconfig real interest_rad_storm namelist,physics max_domains 500 irh01 "interest_rad_storm" "Storm radius of interest for swaths." "km" @@ -19,9 +26,10 @@ rconfig integer interest_self namelist,physics max_domains 0 irh01 "inter rconfig integer interest_storms namelist,physics max_domains 1 irh01 "interest_kids" "Flag for enabling area of interest around storm center." "" # Swath mode. Note there is only one of these: it is NOT per domain: -rconfig integer swath_mode namelist,physics - 1 irh01 "swath_mode" "1=enable swaths, 0=disable" "" +rconfig integer swath_mode namelist,physics - 2 irh01 "swath_mode" "2=2016 HWRF, 1=2015 HWRF, 0=disable" "" package vt_swath swath_mode==1 - state:interesting,precip_swath,windsq_swath +package vt_swath_2016 swath_mode==2 - state:interesting,precip_swath,windsq_swath,suswind_swath,suswind,wind10_ratio,cuprecip_swath halo HALO_NMM_SWATH dyn_nmm 24:precip_swath,windsq_swath diff --git a/wrfv2_fire/Registry/registry.var b/wrfv2_fire/Registry/registry.var index 91a0f099..df68eb73 100644 --- a/wrfv2_fire/Registry/registry.var +++ b/wrfv2_fire/Registry/registry.var @@ -61,8 +61,8 @@ state real a_qs ijkft a_moist 1 - rh "A_QSNOW state real g_qs ijkft g_moist 1 - rh "G_QSNOW" "Snow mixing ratio" "kg kg-1" state real a_qg ijkft a_moist 1 - rh "A_QGRAUP" "Graupel mixing ratio" "kg kg-1" state real g_qg ijkft g_moist 1 - rh "G_QGRAUP" "Graupel mixing ratio" "kg kg-1" -state real a_qh ijkft a_moist 1 - rh "A_QHAIL" "Hail mixing ratio" "kg kg-1" -state real g_qh ijkft g_moist 1 - rh "G_QHAIL" "Hail mixing ratio" "kg kg-1" +#state real a_qh ijkft a_moist 1 - rh "A_QHAIL" "Hail mixing ratio" "kg kg-1" +#state real g_qh ijkft g_moist 1 - rh "G_QHAIL" "Hail mixing ratio" "kg kg-1" # Other Misc State Variables state real g_h_diabatic ijk misc 1 - rdu "g_h_diabatic" "MICROPHYSICS LATENT HEATING" "K s-1" state real a_h_diabatic ijk misc 1 - rdu "a_h_diabatic" "MICROPHYSICS LATENT HEATING" "K s-1" @@ -162,7 +162,6 @@ rconfig logical use_radar_rv namelist,wrfvar4 1 .false. - "use rconfig logical use_radar_rf namelist,wrfvar4 1 .false. - "use_radar_rf" "" "" rconfig logical use_radar_rqv namelist,wrfvar4 1 .false. - "use_radar_rqv" "" "" rconfig logical use_radar_rhv namelist,wrfvar4 1 .false. - "use_radar_rhv" "" "" -rconfig logical use_3dvar_phy namelist,wrfvar4 1 .true. - "use_3dvar_phy" "" "" rconfig logical use_rainobs namelist,wrfvar4 1 .false. - "use_rainobs" "" "" rconfig logical use_hirs2obs namelist,wrfvar4 1 .false. - "use_hirs2obs" "" "" rconfig logical use_hirs3obs namelist,wrfvar4 1 .false. - "use_hirs3obs" "" "" @@ -257,7 +256,8 @@ rconfig logical read_lanczos namelist,wrfvar6 1 .false. - "rea rconfig logical write_lanczos namelist,wrfvar6 1 .false. - "write_lanczos" "" "" rconfig logical orthonorm_gradient namelist,wrfvar6 1 .false. - "orthonorm_gradient" "" "" rconfig integer cv_options namelist,wrfvar7 1 5 - "cv_options" "" "" -rconfig integer cloud_cv_options namelist,wrfvar7 1 1 - "cloud_cv_options" "" "" +rconfig integer cloud_cv_options namelist,wrfvar7 1 0 - "cloud_cv_options" "0: off, 1: qt, 3: specified qc,qr,qi,qs,qg BE" "" +rconfig logical use_cv_w namelist,wrfvar7 1 .false. - "use_cv_w" "if activate w control variable when cloud_cv_options=3" "" rconfig real as1 namelist,wrfvar7 3*max_outer_iterations -1.0 - "as1" "" "" rconfig real as2 namelist,wrfvar7 3*max_outer_iterations -1.0 - "as2" "" "" rconfig real as3 namelist,wrfvar7 3*max_outer_iterations -1.0 - "as3" "" "" @@ -323,7 +323,14 @@ rconfig integer seed_array1 namelist,wrfvar11 1 1 - "se rconfig integer seed_array2 namelist,wrfvar11 1 1 - "seed_array2" "" "" rconfig integer sfc_assi_options namelist,wrfvar11 1 1 - "sfc_assi_options" "" "" rconfig logical psfc_from_slp namelist,wrfvar11 1 .false. - "psfc_from_slp" "" "" +rconfig logical sfcht_adjust_q namelist,wrfvar11 1 .false. - "sfcht_adjust_q" "" "" +rconfig integer sfc_hori_intp_options namelist,wrfvar11 1 1 - "sfc_hori_intp_options" "how the background is calculated" "1: 4-point, 2: nearest point" +rconfig integer q_error_options namelist,wrfvar11 1 1 - "q_error_options" "how specific humidity errors are calculated from RH errors" "1: orig, 2: new" +rconfig real max_stheight_diff namelist,wrfvar11 1 100.0 - "max_stheight_diff" "Stations whose |Zdiff|>max_stHeight_diff will not be assimilated when sfc_assi_options=1" "m" +rconfig real stn_ht_diff_scale namelist,wrfvar11 1 200.0 - "stn_ht_diff_scale" "factor=exp(|Zdiff|/stn_ht_diff_scale)" "m" +rconfig logical obs_err_inflate namelist,wrfvar11 1 .false. - "obs_err_inflate" "switch for inflating obs err by exp(|Zdiff|/stn_ht_diff_scale)" "" rconfig logical calculate_cg_cost_fn namelist,wrfvar11 1 .false. - "calculate_cg_cost_fn" "" "" +rconfig logical write_detail_grad_fn namelist,wrfvar11 1 .false. - "write_detail_grad_fn" "calculate and write out gradient of each iteration in grad_fn" "" rconfig logical lat_stats_option namelist,wrfvar11 1 .false. - "lat_stats_option" "" "" rconfig integer interp_option namelist,wrfvar11 1 1 - "interp_option" "" "" rconfig integer balance_type namelist,wrfvar12 1 3 - "balance_type" "" "For use_wpec: 1 = geostrophic; 2 = cyclostrophic; 3 = both" @@ -358,8 +365,8 @@ rconfig integer rttov_emis_atlas_mw namelist,wrfvar14 1 0 - "rt rconfig integer rtminit_print namelist,wrfvar14 1 1 - "rtminit_print" "" "" rconfig integer rtminit_nsensor namelist,wrfvar14 1 1 - "rtminit_nsensor" "" "" rconfig integer rtminit_platform namelist,wrfvar14 max_instruments -1 - "rtminit_platform" "" "" -rconfig integer rtminit_satid namelist,wrfvar14 max_instruments -1.0 - "rtminit_satid" "" "" -rconfig integer rtminit_sensor namelist,wrfvar14 max_instruments -1.0 - "rtminit_sensor" "" "" +rconfig integer rtminit_satid namelist,wrfvar14 max_instruments -1 - "rtminit_satid" "" "" +rconfig integer rtminit_sensor namelist,wrfvar14 max_instruments -1 - "rtminit_sensor" "" "" rconfig integer rad_monitoring namelist,wrfvar14 max_instruments 0 - "rad_monitoring" "" "" rconfig real thinning_mesh namelist,wrfvar14 max_instruments 60.0 - "thinning_mesh" "" "" rconfig logical thinning namelist,wrfvar14 1 .true. - "thinning " "" "" @@ -420,6 +427,9 @@ rconfig real pseudo_y namelist,wrfvar15 1 1.0 - "ps rconfig real pseudo_z namelist,wrfvar15 1 1.0 - "pseudo_z" "" "" rconfig real pseudo_val namelist,wrfvar15 1 1.0 - "pseudo_val" "" "" rconfig real pseudo_err namelist,wrfvar15 1 1.0 - "pseudo_err" "" "" +rconfig real pseudo_elv namelist,wrfvar15 1 -999.99 - "pseudo_elv" "pseudo ob elevation, used by pseudo tpw/ztd" "m" +rconfig integer ep_para_read namelist,wrfvar16 1 0 - "ep_para_read" "how the ensemble perturbations are read" "0: serial read, 1: parallel read" +rconfig integer rden_bin namelist,wrfvar16 1 1 - "rden_bin" "number of bins/batches to read ensemble perturbations in parallel" "" rconfig integer alphacv_method namelist,wrfvar16 1 2 - "alphacv_method" "" "" rconfig integer ensdim_alpha namelist,wrfvar16 1 0 - "ensdim_alpha" "" "" rconfig integer alpha_truncation namelist,wrfvar16 1 0 - "alpha_truncation" "" "" @@ -430,6 +440,7 @@ rconfig logical alpha_vertloc namelist,wrfvar16 1 .false. - "al rconfig logical alpha_hydrometeors namelist,wrfvar16 1 .false. - "alpha_hydrometeors" "" "" rconfig logical hybrid_dual_res namelist,wrfvar16 1 .false. - "hybrid_dual_res" "" "" rconfig integer dual_res_upscale_opt namelist,wrfvar16 1 3 - "dual_res_upscale_opt" "" "" +rconfig logical use_4denvar namelist,wrfvar16 1 .false. - "4D-En-Var" "switch for activating 4D-Ensemble-Var" "" rconfig character analysis_type namelist,wrfvar17 1 "3D-VAR" - "analysis_type" "" "" rconfig integer sensitivity_option namelist,wrfvar17 1 -1 - "sensitivity_option" "" "" rconfig logical adj_sens namelist,wrfvar17 1 .false. - "adj_sens" "" "" @@ -438,6 +449,18 @@ rconfig character pseudo_var namelist,wrfvar19 1 "t" rconfig character documentation_url namelist,wrfvar20 1 "http://www.mmm.ucar.edu/people/wrfhelp/wrfvar/code/trunk" - "documentation_url" "" "" rconfig character time_window_min namelist,wrfvar21 1 "2002-08-02_21:00:00.0000" - "time_window_min" "" "" rconfig character time_window_max namelist,wrfvar22 1 "2002-08-03_03:00:00.0000" - "time_window_max" "" "" +rconfig integer radar_non_precip_opt namelist,radar_da 1 0 - "radar_non_precip_opt" "" "0: off, 1: KNU scheme" +rconfig real radar_non_precip_rf namelist,radar_da 1 -999.99 - "radar_non_precip_rf" "rf value used to indicate non-precip ob" "dBZ" +rconfig real radar_non_precip_rh_w namelist,radar_da 1 95.0 - "radar_non_precip_rh_w" "RH wrt water for non_precip rqv" "%" +rconfig real radar_non_precip_rh_i namelist,radar_da 1 85.0 - "radar_non_precip_rh_i" "RH wrt ice for non_precip rqv" "%" +rconfig integer cloudbase_calc_opt namelist,radar_da 1 1 - "cloudbase_calc_opt" "" "1: KNU scheme, 2: NCAR scheme" +rconfig real radar_saturated_rf namelist,radar_da 1 25.0 - "radar_saturated_rf" "rf value used to indicate saturated rqv" "dBZ" +rconfig real radar_rqv_thresh1 namelist,radar_da 1 40.0 - "radar_rqv_thresh1" "rf value used to scale down rqv" "dBZ" +rconfig real radar_rqv_thresh2 namelist,radar_da 1 50.0 - "radar_rqv_thresh2" "rf value used to scale down rqv" "dBZ" +rconfig real radar_rqv_rh1 namelist,radar_da 1 85.0 - "radar_rqv_rh1" "RH for (radar_saturated_rf < rf < radar_rqv_thresh1)" "%" +rconfig real radar_rqv_rh2 namelist,radar_da 1 95.0 - "radar_rqv_rh2" "RH for (radar_rqv_thresh1 < rf < radar_rqv_thresh2)" "%" +rconfig real radar_rqv_h_lbound namelist,radar_da 1 -999.0 - "radar_rqv_h_lbound" "height lower bound for rqv" "m" +rconfig real radar_rqv_h_ubound namelist,radar_da 1 -999.0 - "radar_rqv_h_ubound" "height upper bound for rqv" "m" rconfig logical jcdfi_use namelist,perturbation 1 .false. - "jcdfi_use" "JcDFI on/off" "" rconfig integer jcdfi_diag namelist,perturbation 1 1 - "jcdfi_diag" "JcDFI diag. on/off" "" rconfig real jcdfi_penalty namelist,perturbation 1 10. - "jcdfi_penalty" "Penalty parameter for JcDF" "" @@ -448,6 +471,8 @@ rconfig logical var4d_run namelist,perturbation 1 .true. - rconfig integer mp_physics_ad namelist,physics max_domains 98 - "mp_physics_ad" "" "" # NAMELIST DERIVED rconfig integer mp_physics_4dvar derived max_domains -1 - "mp_physics_4dvar" "" "-1 = no 4dvar and so no need to allocate a_ and g_ moist and scalar variables, >0 = running 4dvar, so allocate a_ and g_ moist and scalar variables appropriate for selected microphysics package" +rconfig integer mp_physics_da derived max_domains 1 - "mp_physics_da" "" "1 when mp_physics>0 for allocating moist variables" +rconfig integer mp_physics_da_4dvar derived max_domains -1 - "mp_physics_da_4dvar" "" "1 when mp_physics>0 for allocating g_/a_moist variables" # #--------------------------------------------------------------------------------------------------------------------------------------- # Package Declarations @@ -462,31 +487,16 @@ package dyn_em_ad dyn_opt==302 - - package dyn_em_tst dyn_opt==402 - - package dyn_em_var dyn_opt==502 - - -package passiveqv mp_physics==0 - moist:qv;g_moist:g_qv;a_moist:a_qv -package kesslerscheme mp_physics==1 - moist:qv,qc,qr;g_moist:g_qv,g_qc,g_qr;a_moist:a_qv,a_qc,a_qr -package linscheme mp_physics==2 - moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg -package sbu_ylinscheme mp_physics==13 - moist:qv,qc,qr,qi,qs -package wsm3scheme mp_physics==3 - moist:qv,qc,qr;g_moist:g_qv,g_qc,g_qr;a_moist:a_qv,a_qc,a_qr -package wsm5scheme mp_physics==4 - moist:qv,qc,qr,qi,qs;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs -package etamp_hr mp_physics==5 - moist:qv,qc,qr,qs;g_moist:g_qv,g_qc,g_qr,g_qs;a_moist:a_qv,a_qc,a_qr,a_qs;scalar:qt -package wsm6scheme mp_physics==6 - moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg -package gsfcgcescheme mp_physics==7 - moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg -package thompson mp_physics==8 - moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg;scalar:qni,qnr -package milbrandt2mom mp_physics==9 - moist:qv,qc,qr,qi,qs,qg,qh;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg,g_qh;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg,a_qh;scalar:qnc,qnr,qni,qns,qng,qnh -package morr_two_moment mp_physics==10 - moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg;scalar:qni,qns,qnr,qng -#package milbrandt3mom mp_physics==12 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qzr,qzi,qzs,qzg,qzh -package wdm5scheme mp_physics==14 - moist:qv,qc,qr,qi,qs;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs;scalar:qnn,qnc,qnr -package wdm6scheme mp_physics==16 - moist:qv,qc,qr,qi,qs,qg;g_moist:g_qv,g_qc,g_qr,g_qi,g_qs,g_qg;a_moist:a_qv,a_qc,a_qr,a_qi,a_qs,a_qg;scalar:qnn,qnc,qnr -package nssl_2mom mp_physics==17 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnc,qnr,qni,qns,qng,qnh,qvolg -package nssl_2momccn mp_physics==18 - moist:qv,qc,qr,qi,qs,qg,qh;scalar:qnn,qnc,qnr,qni,qns,qng,qnh,qvolg -package etampnew mp_physics==95 - moist:qv,qc,qr,qs;g_moist:g_qv,g_qc,g_qr,g_qs;a_moist:a_qv,a_qc,a_qr,a_qs;scalar:qt -package lscondscheme mp_physics==98 - moist:qv;g_moist:g_qv;a_moist:a_qv -package mkesslerscheme mp_physics==99 - moist:qv,qc,qr;g_moist:g_qv,g_qc,g_qr;a_moist:a_qv,a_qc,a_qr +package mp_phys_zero mp_physics_da==0 - moist:qv +package mp_phys_set mp_physics_da==1 - moist:qv,qc,qr,qi,qs,qg + +package nomoist_4dvar mp_physics_da_4dvar==-1 - - +package passiveqv_4dvar mp_physics_da_4dvar==0 - g_moist:g_qv;a_moist:a_qv +package warmrain_4dvar mp_physics_da_4dvar==1 - g_moist:g_qv,g_qc,g_qr;a_moist:a_qv,a_qc,a_qr package surfdragscheme bl_pbl_physics==98 - - package ducuscheme cu_physics==98 - - - # only need to specify these once; not for every io_form* variable # Placeholders for additional packages (we can go beyond zzz # but that will entail modifying frame/module_io.F and frame/md_calls.m4) @@ -508,8 +518,8 @@ halo HALO_X6A_A dyn_em 4:x6a%u,x6a%v halo HALO_EM_C_TL dyn_em 4:g_u_2,g_v_2,g_rainc,g_rainnc halo HALO_XB dyn_em 24:xb%psac,xb%rough,xb%u,xb%v,xb%w,xb%wh,xb%t,xb%p,xb%q,xb%qs,xb%qrn,xb%qcw,xb%qci,xb%qsn,xb%qgr,xb%qt,xb%rho,xb%rh,xb%h,xb%hf,xb%u10,xb%v10,xb%t2,xb%q2,xb%psfc,xb%regime,xb%ztd,xb%tpw,xb%speed,xb%tb19v,xb%tb19h,xb%tb22v,xb%tb37v,xb%tb37h,xb%tb85v,xb%tb85h,xb%ref,xb%reflog,xb%delt,xb%slp,xb%tsk,xb%smois,xb%tslb,xb%xice,xb%ivgtyp,xb%isltyp,xb%vegfra,xb%snowh,xb%snow halo HALO_XA dyn_em 24:xa%u,xa%v,xa%q,xa%p,xa%t,xa%rho,xa%rh,xa%psfc,xa%qcw,xa%qrn,xa%qci,xa%qt,xa%qsn,xa%qgr -halo HALO_XA_ALL dyn_em 24:xa%u,xa%v,xa%q,xa%p,xa%t,xa%rho,xa%rh,xa%psfc,xa%qcw,xa%qrn,xa%qci,xa%qt,xa%qsn,xa%qgr,xa%geoh,xa%mu -halo HALO_XB_ALL dyn_em 24:xb%u,xb%v,xb%p,xb%rho,xb%h +halo HALO_XA_WPEC dyn_em 24:xa%geoh,xa%mu +halo HALO_XB_WPEC dyn_em 24:xb%u,xb%v,xb%p,xb%rho,xb%h halo HALO_XA_CLOUD dyn_em 24:xa%q,xa%t,xa%qcw,xa%qrn,xa%qci,xa%qsn,xa%qgr halo HALO_SFC_XA dyn_em 24:xa%u10,xa%v10,xa%t2,xa%q2 halo HALO_SSMI_XA dyn_em 24:xa%ztd,xa%tpw,xa%speed,xa%tb19v,xa%tb19h,xa%tb22v,xa%tb37v,xa%tb37h,xa%tb85v,xa%tb85h,xa%ref @@ -544,6 +554,11 @@ typedef ep_type real v2 ijk9 - 1 - typedef ep_type real v3 ijk9 - 1 - - typedef ep_type real v4 ijk9 - 1 - - typedef ep_type real v5 ijk9 - 1 - - +typedef ep_type real cw ijk9 - 1 - - +typedef ep_type real rn ijk9 - 1 - - +typedef ep_type real ci ijk9 - 1 - - +typedef ep_type real sn ijk9 - 1 - - +typedef ep_type real gr ijk9 - 1 - - # END EP_TYPE DEFINITION # BEGIN XB_TYPE DEFINITION: typedef xb_type integer map @@ -692,6 +707,18 @@ typedef x_type real tb37h ij - 1 - typedef x_type real tb85v ij - 1 - - typedef x_type real tb85h ij - 1 - - # END TYPE x_type +# BEGIN X_subTYPE DEFINITION +typedef x_subtype real u ijk - 1 X - +typedef x_subtype real v ijk - 1 Y - +typedef x_subtype real t ijk - 1 - - +typedef x_subtype real q ijk - 1 - - +typedef x_subtype real psfc ij - 1 - - +typedef x_subtype real qrn ijk - 1 - - +typedef x_subtype real qcw ijk - 1 - - +typedef x_subtype real qci ijk - 1 - - +typedef x_subtype real qsn ijk - 1 - - +typedef x_subtype real qgr ijk - 1 - - +# END TYPE x_subtype # BEGIN XPOSE_TYPE DEFINITION: # typedef xpose_type integer domdesc @@ -791,11 +818,55 @@ state real dummy i dyn_em 1 # #Set state state vp_type vv - - -state vp_type vv6 - - state vp_type vp - - -state vp_type vp6 - - state ep_type ep - - state xb_type xb - - state x_type xa - - -state x_type x6a - - +state x_subtype xa_ens - - +state x_type xa_static - - state xpose_type xp - - + +ifdef VAR4D +state vp_type vv6 - - +state vp_type vp6 - - +state x_type x6a - - +endif + +rconfig integer adj_sens_used derived 1 0 - "adj_sens_used" "turn on if adj_sens=true" +rconfig integer var4d_used derived 1 0 - "var4d_used" "turn on if var4d=true" + +package no_adj_sens adj_sens_used==0 - - +package do_adj_sens adj_sens_used==1 - state:a_u,a_v,a_t,a_mu,a_ph,g_u,g_v,g_t,g_mu,g_ph;a_moist:a_qv;g_moist:g_qv +package no_var4d var4d_used==0 - - +package do_var4d var4d_used==1 - state:a_u,a_v,a_w,a_ph,a_t,a_mu,a_p,a_z,g_u,g_v,g_w,g_ph,g_t,g_mu,g_p,g_z,a_h_diabatic,g_h_diabatic,a_rainc,g_rainc,a_rainnc,g_rainnc,a_raincv,g_raincv,a_rainncv,g_rainncv + +rconfig integer cv_w_used derived 1 0 - "cv_w_used" "turn on if use_cv_w=true" +rconfig integer ens_used derived 1 0 - "ens_used" "turn on if ensdim_alpha>0" +rconfig integer cloud_ens_used derived 1 0 - "cloud_ens_used" "turn on if alpha_hydrometeors=true" +rconfig integer var4d_cloudcv derived 1 -1 - "var4d_cloudcv" "turn on if var4d=true and cloud_cv_options>0" +rconfig integer var4d_w_cv derived 1 0 - "var4d_w_cv" "turn on if var4d=true and use_cv_w=true" +rconfig integer wpec_used derived 1 0 - "wpec_used" "turn on if use_wpec=true" +rconfig integer alloc_xa_static derived 1 0 - "alloc_xa_static" "turn on if use_4denvar=true and num_fgat_time>1" + +#package derived types +package no_cloud_cv cloud_cv_options==0 - - +package cloud_cv_1 cloud_cv_options==1 - state:xa%qt,xa%qrn,xa%qcw +package cloud_cv_2 cloud_cv_options==2 - state:xa%qrn,xa%qcw,xa%qci,xa%qsn,xa%qgr,vp%v6,vp%v7,vp%v8,vp%v9,vp%v10,vv%v6,vv%v7,vv%v8,vv%v9,vv%v10 +package cloud_cv_3 cloud_cv_options==3 - state:xa%qrn,xa%qcw,xa%qci,xa%qsn,xa%qgr,vp%v6,vp%v7,vp%v8,vp%v9,vp%v10,vv%v6,vv%v7,vv%v8,vv%v9,vv%v10 +package not_var4d var4d_cloudcv==-1 - - +package no_var4d_ccv var4d_cloudcv==0 - state:vp6%v1,vp6%v2,vp6%v3,vp6%v4,vp6%v5,vv6%v1,vv6%v2,vv6%v3,vv6%v4,vv6%v5,xa%qrn,xa%qcw +package var4d_ccv_1 var4d_cloudcv==1 - state:vp6%v1,vp6%v2,vp6%v3,vp6%v4,vp6%v5,vv6%v1,vv6%v2,vv6%v3,vv6%v4,vv6%v5,x6a%qt,x6a%qrn,x6a%qcw +package var4d_ccv_2 var4d_cloudcv==2 - state:vp6%v1,vp6%v2,vp6%v3,vp6%v4,vp6%v5,vv6%v1,vv6%v2,vv6%v3,vv6%v4,vv6%v5,vp6%v6,vp6%v7,vp6%v8,vp6%v9,vp6%v10,vv6%v6,vv6%v7,vv6%v8,vv6%v9,vv6%v10,x6a%qrn,x6a%qcw,x6a%qci,x6a%qsn,x6a%qgr +package var4d_ccv_3 var4d_cloudcv==3 - state:vp6%v1,vp6%v2,vp6%v3,vp6%v4,vp6%v5,vv6%v1,vv6%v2,vv6%v3,vv6%v4,vv6%v5,vp6%v6,vp6%v7,vp6%v8,vp6%v9,vp6%v10,vv6%v6,vv6%v7,vv6%v8,vv6%v9,vv6%v10,x6a%qrn,x6a%qcw,x6a%qci,x6a%qsn,x6a%qgr +package no_cv_w cv_w_used==0 - - +package has_cv_w cv_w_used==1 - state:vp%v11,vv%v11 +package no_var4d_cv_w var4d_w_cv==0 - - +package has_var4d_cv_w var4d_w_cv==1 - state:vp6%v11,vv6%v11 +package no_ens ens_used==0 - - +package has_ens ens_used==1 - state:xa_ens%u,xa_ens%v,xa_ens%t,xa_ens%q,xa_ens%psfc,ep%v1,ep%v2,ep%v3,ep%v4,ep%v5,vp%alpha,vv%alpha +package no_ens_cloud cloud_ens_used==0 - - +package has_ens_cloud cloud_ens_used==1 - state:xa_ens%qrn,xa_ens%qcw,xa_ens%qci,xa_ens%qsn,xa_ens%qgr,ep%cw,ep%rn,ep%ci,ep%sn,ep%gr +package no_wpec wpec_used==0 - - +package has_wpec wpec_used==1 - state:xa%grad_p_x,xa%grad_p_y,xa%geoh,xa%mu,xb%xb_p_x,xb%xb_p_y +package no_xa_static alloc_xa_static==0 - - +package has_xa_static alloc_xa_static==1 - state:xa_static%psfc,xa_static%mu,xa_static%u,xa_static%v,xa_static%t,xa_static%q,xa_static%w,xa_static%p,xa_static%geoh,xa_static%rh,xa_static%rho,xa_static%wh,xa_static%ref,xa_static%tgrn,xa_static%u10,xa_static%v10,xa_static%t2,xa_static%q2,xa_static%ztd,xa_static%tpw,xa_static%speed,xa_static%tb19v,xa_static%tb19h,xa_static%tb22v,xa_static%tb37v,xa_static%tb37h,xa_static%tb85v,xa_static%tb85h,xa_static%qt,xa_static%qrn,xa_static%qcw,xa_static%qci,xa_static%qsn,xa_static%qgr diff --git a/wrfv2_fire/arch/Config_new.pl b/wrfv2_fire/arch/Config_new.pl index 34415a91..34102b1b 100644 --- a/wrfv2_fire/arch/Config_new.pl +++ b/wrfv2_fire/arch/Config_new.pl @@ -21,6 +21,7 @@ $sw_rwordsize="\$\(NATIVE_RWORDSIZE\)"; $sw_rttov_flag = "" ; $sw_rttov_inc = "" ; +$sw_rttov_path = "" ; $sw_crtm_flag = "" ; $sw_cloudcv_flag = "" ; $sw_4dvar_flag = "" ; @@ -50,6 +51,9 @@ $sw_curl_path = ""; $sw_curl_lib = "-lcurl"; $sw_terrain_and_landuse = ""; +$sw_tfl = "" ; +$sw_cfl = "" ; +$sw_config_line = "" ; while ( substr( $ARGV[0], 0, 1 ) eq "-" ) { if ( substr( $ARGV[0], 1, 5 ) eq "perl=" ) @@ -205,6 +209,18 @@ { $sw_ompparallel=substr( $ARGV[0], 13 ) ; } + if ( substr( $ARGV[0], 1, 4 ) eq "tfl=" ) + { + $sw_tfl=substr( $ARGV[0], 5 ) ; + } + if ( substr( $ARGV[0], 1, 4 ) eq "cfl=" ) + { + $sw_cfl=substr( $ARGV[0], 5 ) ; + } + if ( substr( $ARGV[0], 1, 12 ) eq "config_line=" ) + { + $sw_config_line=substr( $ARGV[0], 13 ) ; + } shift @ARGV ; } @@ -258,14 +274,24 @@ if ( $ENV{WRF_DA_CORE} eq "1" || $sw_da_core eq "-DDA_CORE=1" ) { $sw_rwordsize = "8"; - if ( $ENV{CRTM} ) + if(defined $ENV{'CRTM'}) + { + if ( $ENV{CRTM} ne "0" ) + { + $sw_crtm_flag = "-DCRTM"; + } + } + else { - $sw_crtm_flag = "-DCRTM"; + { + $sw_crtm_flag = "-DCRTM"; + } } if ( $ENV{RTTOV} ) { $sw_rttov_flag = "-DRTTOV"; $sw_rttov_inc = "-I$ENV{RTTOV}/include -I$ENV{RTTOV}/mod"; + $sw_rttov_path= $ENV{RTTOV}; } if ( $ENV{CLOUD_CV} ) { @@ -390,6 +416,8 @@ { $validresponse = 1 ; } else { printf("\nInvalid response (%d)\n",$response);} + $response_opt = $response ; + chop $response_opt ; } printf "------------------------------------------------------------------------\n" ; @@ -434,11 +462,14 @@ $_ =~ s/CONFIGURE_DMPARALLEL/$sw_dmparallelflag/g ; $_ =~ s/CONFIGURE_STUBMPI/$sw_stubmpi/g ; $_ =~ s/CONFIGURE_NESTOPT/$sw_nest_opt/g ; + $_ =~ s/CONFIGURE_TRADFLAG/$sw_tfl/g ; + $_ =~ s/CONFIGURE_CPPFLAGS/$sw_cfl/g ; $_ =~ s/CONFIGURE_4DVAR_FLAG/$sw_4dvar_flag/g ; $_ =~ s/CONFIGURE_WRFPLUS_PATH/$sw_wrfplus_path/g ; $_ =~ s/CONFIGURE_CRTM_FLAG/$sw_crtm_flag/g ; $_ =~ s/CONFIGURE_RTTOV_FLAG/$sw_rttov_flag/g ; $_ =~ s/CONFIGURE_RTTOV_INC/$sw_rttov_inc/g ; + $_ =~ s/CONFIGURE_RTTOV_PATH/$sw_rttov_path/g ; $_ =~ s/CONFIGURE_CLOUDCV_FLAG/$sw_cloudcv_flag/g ; $_ =~ s/CONFIGURE_WAVELET_FLAG/$sw_wavelet_flag/g ; if ( $sw_ifort_r8 ) { @@ -651,6 +682,7 @@ if ( $response == 0 ) { if ( ! ( $paropt eq 'serial' || $paropt eq 'smpar' ) ) { $response = 1 ; } } + $response_nesting = $response ; if ( ( $response == 1 ) || ( $response == 2 ) || ( $response == 3 ) ) { if ( ( $paropt eq 'serial' || $paropt eq 'smpar' ) ) { # nesting without MPI $sw_stubmpi = "-DSTUBMPI" ; @@ -760,6 +792,9 @@ $_ =~ s:CONFIGURE_NMM_CORE:$sw_nmm_core:g ; $_ =~ s:CONFIGURE_COAMPS_CORE:$sw_coamps_core:g ; $_ =~ s:CONFIGURE_EXP_CORE:$sw_exp_core:g ; + $_ =~ s/CONFIGURE_CONFIG_LINE/$sw_config_line/g ; + $_ =~ s/CONFIGURE_CONFIG_NUM/Compiler choice: $response_opt/g ; + $_ =~ s/CONFIGURE_CONFIG_NEST/Nesting option: $response_nesting/g ; $_ =~ s/CONFIGURE_DEP_LIB_PATH/$sw_dep_lib_path/g ; diff --git a/wrfv2_fire/arch/configure_new.defaults b/wrfv2_fire/arch/configure_new.defaults index 112e72fd..bc311eae 100644 --- a/wrfv2_fire/arch/configure_new.defaults +++ b/wrfv2_fire/arch/configure_new.defaults @@ -33,8 +33,8 @@ BYTESWAPIO = #-FIX_BYTE_SWAP_IF_NECESSARY_FOR_BIG_ENDIAN FCBASEOPTS_NO_G = -w -Wf'-M noflunf -M nozdiv' $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -I/SX/usr/include/module/dwdadW64/ -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = sxar ARFLAGS = ru M4 = m4 -B 14000 @@ -77,8 +77,8 @@ BYTESWAPIO = -fconvert=big-endian -frecord-marker=4 FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -120,8 +120,8 @@ BYTESWAPIO = -fendian=big FCBASEOPTS_NO_G = -Wno=101,139,155,158 $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -fmod=$(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -163,8 +163,8 @@ BYTESWAPIO = -byteswapio FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -206,8 +206,8 @@ BYTESWAPIO = -byteswapio FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -248,8 +248,8 @@ FCSUFFIX = BYTESWAPIO = -byteswapio FCBASEOPTS = -w $(FCDEBUG) $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -321,11 +321,12 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 @@ -367,11 +368,12 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl FCBASEOPTS_NO_G = -w -openmp -auto -ftz -fno-alias -fp-model fast=1 -no-prec-div -no-prec-sqrt $(FORMAT_FREE) $(BYTESWAPIO) -auto -align array64byte #-vec-report6 FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 @@ -413,11 +415,12 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl FCBASEOPTS_NO_G = -w $(OMP) -auto -ftz -fno-alias -fp-model fast=1 -no-prec-div -no-prec-sqrt $(FORMAT_FREE) $(BYTESWAPIO) -auto -align array64byte #-vec-report6 FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 @@ -483,11 +486,12 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 @@ -531,11 +535,12 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 @@ -609,13 +614,14 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common #FCBASEOPTS_NO_G = -w -ftz -align all -fno-alias -IPF-fp-relaxed $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) LIB_LOCAL = -L/usr/lib -lmpi MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 @@ -691,13 +697,14 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common #FCBASEOPTS_NO_G = -w -ftz -align all -fno-alias -IPF-fp-relaxed $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) LIB_LOCAL = -L/usr/lib -lmpi MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 @@ -739,8 +746,8 @@ BYTESWAPIO = -byteswapio FCBASEOPTS_NO_G = -w -fno-second-underscore $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -782,8 +789,8 @@ BYTESWAPIO = -fconvert=big-endian -frecord-marker=4 FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -G @@ -825,8 +832,8 @@ BYTESWAPIO = -byteswapio FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) -Mnomod MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = cpp -P -xassembler-with-cpp +TRADFLAG = CONFIGURE_TRADFLAG +CPP = cpp CONFIGURE_CPPFLAGS -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -866,12 +873,13 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl # added -fno-common at suggestion of R. Dubtsov as workaround for failing to link program_name FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = cpp -P -xassembler-with-cpp +TRADFLAG = CONFIGURE_TRADFLAG +CPP = cpp CONFIGURE_CPPFLAGS -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -911,11 +919,12 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl FCBASEOPTS_NO_G = -fp-model precise -w -ftz -align all -fno-alias -fno-common $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = cpp -P -xassembler-with-cpp +TRADFLAG = CONFIGURE_TRADFLAG +CPP = cpp CONFIGURE_CPPFLAGS -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -958,8 +967,8 @@ FCBASEOPTS_NO_G = -Wno=101,139,155,158 $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) LIB_LOCAL = -L/usr/lib -lSystemStubs MODULE_SRCH_FLAG = -fmod=$(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = cpp -P -xassembler-with-cpp +TRADFLAG = CONFIGURE_TRADFLAG +CPP = cpp CONFIGURE_CPPFLAGS -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1001,8 +1010,8 @@ BYTESWAPIO = -fconvert=big-endian -frecord-marker=4 FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = cpp -P -xassembler-with-cpp +TRADFLAG = CONFIGURE_TRADFLAG +CPP = cpp CONFIGURE_CPPFLAGS -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1044,8 +1053,8 @@ BYTESWAPIO = -fconvert=big-endian -frecord-marker=4 FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = cpp -P -xassembler-with-cpp +TRADFLAG = CONFIGURE_TRADFLAG +CPP = cpp CONFIGURE_CPPFLAGS -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1089,8 +1098,8 @@ BYTESWAPIO = FCBASEOPTS_NO_G = -qsave -qmaxmem=32767 -qspillsize=32767 -w FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -fmod=$(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1137,8 +1146,8 @@ BYTESWAPIO = FCBASEOPTS_NO_G = -w -qspill=81920 -qmaxmem=-1 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap -C # -qinitauto=7FF7FFFF FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = #-traditional # causing troubles with xl cpp on AIX, -traditional removed fom default settings -CPP = /lib/cpp -P +TRADFLAG = #CONFIGURE_TRADFLAG # causing troubles with xl cpp on AIX, -traditional removed fom default settings +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 20000 @@ -1189,7 +1198,7 @@ MODULE_SRCH_FLAG = TRADFLAG = # instead of the GNU CPP, the CPP shipped with XLF should be used, # which does not work with the -traditional flag -CPP = $(XLF_BASE)/exe/cpp -P +CPP = $(XLF_BASE)/exe/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1250,8 +1259,8 @@ BYTESWAPIO = -byteswapio FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OPTERON_TYPE) $(OMP) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P $(TRADFLAG) +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS $(TRADFLAG) AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1266,27 +1275,30 @@ CC_TOOLS = $(SCC) DESCRIPTION = CRAY CCE ($SFC/$SCC): Cray XE and XC # OpenMP is enabled by default for Cray CCE compiler # This turns it off -OMP = -hnoomp +NOOMP = -hnoomp DMPARALLEL = # 1 OMPCPP = # -D_OPENMP OMP = # -homp OMPCC = # -homp -SFC = ftn +SFC = ftn $(NOOMP) SCC = cc CCOMP = gcc -DM_FC = ftn +DM_FC = ftn $(NOOMP) DM_CC = cc FC = $(DM_FC) CC = $(DM_CC) LD = $(FC) RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = -s integer32 +PROMOTION = -s integer32 -s real`expr 8 \* $(RWORDSIZE)` ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM CFLAGS_LOCAL = -O3 LDFLAGS_LOCAL = +# uncomment this for wrfda build +#LIB_LOCAL = -L$(WRF_SRC_ROOT_DIR)/external/fftpack/fftpack5 -lfftpack \ +# -L$(WRF_SRC_ROOT_DIR)/external/RSL_LITE -lrsl_lite CPLUSPLUSLIB = ESMF_LDFLAG = $(CPLUSPLUSLIB) -FCOPTIM = +FCOPTIM = # -Ofp3 FCREDUCEDOPT = $(FCOPTIM) FCNOOPT = -O1 -Ofp1 -Oipa0 -Onomodinline FCDEBUG = # -g -O0 # -K trap=fp -R bc @@ -1297,8 +1309,8 @@ BYTESWAPIO = -h byteswapio FCBASEOPTS_NO_G = -N1023 $(FORMAT_FREE) $(BYTESWAPIO) #-ra FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 @@ -1341,11 +1353,13 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian -FCBASEOPTS_NO_G = -w -ftz -fno-alias -align all $(FORMAT_FREE) $(BYTESWAPIO) #-vec-report6 +RECORDLENGTH = -assume byterecl +#add -fp-model precise in FCBASEOPTS_NO_G to improve the accuracy of WRFPLUS check_AD test, suggested by Thomas Schwitalla. +FCBASEOPTS_NO_G = -w -ftz -fno-alias -align all $(FORMAT_FREE) $(BYTESWAPIO) #-fp-model precise #-vec-report6 FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 @@ -1353,48 +1367,6 @@ RANLIB = ranlib RLFLAGS = CC_TOOLS = gcc -########################################################### -#ARCH Fujitsu FX10 Linux SPARC64IXfx, mpifrtpx and mpifccpx compilers #serial smpar dmpar dm+sm -# -DESCRIPTION = FUJITSU ($SFC/$SCC): FX10 SPARC64 IXfx -DMPARALLEL = # 1 -OMPCPP = # -D_OPENMP -OMP = # -Kopenmp -OMPCC = # -Kopenmp -SFC = frtpx -SCC = fccpx -CCOMP = fccpx -DM_FC = mpifrtpx -DM_CC = mpifccpx -DMPI2_SUPPORT -DMPI2_THREAD_SUPPORT -FC = CONFIGURE_FC -CC = CONFIGURE_CC -LD = $(FC) -RWORDSIZE = CONFIGURE_RWORDSIZE -PROMOTION = -CcdRR$(RWORDSIZE) -ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM -CFLAGS_LOCAL = -Kfast -Xg -DSUN -LDFLAGS_LOCAL = -CPLUSPLUSLIB = -ESMF_LDFLAG = $(CPLUSPLUSLIB) -FCOPTIM = -Kfast -FCREDUCEDOPT = $(FCOPTIM) -FCNOOPT = -O1 -FCDEBUG = # -g $(FCNOOPT) -FORMAT_FIXED = -Fixed -FORMAT_FREE = -Free -FCSUFFIX = -BYTESWAPIO = -FCBASEOPTS_NO_G = -Kautoobjstack,ocl -V -Qa,d,i,p,t,x -Koptmsg=2 $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) -FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) -MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P -AR = ar -ARFLAGS = ru -M4 = m4 -RANLIB = ranlib -RLFLAGS = -CC_TOOLS = /usr/bin/gcc -Wall ########################################################### #ARCH Linux ppc64 BG /L blxlf compiler with blxlc # dmpar @@ -1434,12 +1406,12 @@ BYTESWAPIO = FCBASEOPTS_NO_G = -w -qspill=20000 -qmaxmem=64000 $(FORMAT_FREE) $(BYTESWAPIO) $(MPI_INC) #-qflttrap=zerodivide:invalid:enable -qsigtrap FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional +TRADFLAG = CONFIGURE_TRADFLAG # this might be different on different systems but we want the xlf version of cpp, not Linux's # NYBlue -CPP = /opt/ibmcmp/xlf/bg/10.1/exe/cpp -P +CPP = /opt/ibmcmp/xlf/bg/10.1/exe/cpp CONFIGURE_CPPFLAGS # frost.ucar.edu -CPP = /opt/ibmcmp/xlf/9.1/exe/cpp -P +CPP = /opt/ibmcmp/xlf/9.1/exe/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1483,10 +1455,10 @@ BYTESWAPIO = FCBASEOPTS_NO_G = -w -qspill=20000 -qmaxmem=64000 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional +TRADFLAG = CONFIGURE_TRADFLAG # this might be different on different systems but we want the xlf version of cpp, not Linux's # surveyor.alcf.anl.gov -CPP = /opt/ibmcmp/xlf/bg/11.1/exe/cpp -P +CPP = /opt/ibmcmp/xlf/bg/11.1/exe/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1528,9 +1500,9 @@ BYTESWAPIO = FCBASEOPTS_NO_G = -w -qspill=20000 -qmaxmem=32767 $(FORMAT_FREE) $(BYTESWAPIO) #-qflttrap=zerodivide:invalid:enable -qsigtrap FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional +TRADFLAG = CONFIGURE_TRADFLAG # this might be different on different systems but we want the xlf version of cpp, not Linux -CPP = /opt/ibmcmp/xlf/11.1/exe/cpp -P +CPP = /opt/ibmcmp/xlf/11.1/exe/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1572,8 +1544,8 @@ BYTESWAPIO = -byteswapio FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1672,8 +1644,8 @@ BYTESWAPIO = -byteswapio FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1715,8 +1687,8 @@ BYTESWAPIO = -byteswapio FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) -Mnomod MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = cpp -P -xassembler-with-cpp +TRADFLAG = CONFIGURE_TRADFLAG +CPP = cpp CONFIGURE_CPPFLAGS -xassembler-with-cpp AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1724,6 +1696,95 @@ RANLIB = ranlib RLFLAGS = -c CC_TOOLS = cc +########################################################### +#ARCH Darwin (MACOS) intel compiler with icc #serial smpar dmpar dm+sm +# +DESCRIPTION = INTEL ($SFC/$SCC): Open MPI +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -openmp -fpp -auto +OMPCC = # -openmp -fpp -auto +SFC = ifort +SCC = icc +CCOMP = icc +DM_FC = mpif90 +DM_CC = mpicc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -real-size `expr 8 \* $(RWORDSIZE)` -i4 +ARCH_LOCAL = -DMACOS -DNONSTANDARD_SYSTEM_FUNC -DWRF_USE_CLM +CFLAGS_LOCAL = -w -O3 -ip -DMACOS #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -no-multibyte-chars -DMACOS +# increase stack size; also note that for OpenMP, set environment OMP_STACKSIZE 4G or greater +LDFLAGS_LOCAL = -ip -Wl,-stack_addr,0xF10000000 -Wl,-stack_size,0x64000000 #-xHost -fp-model fast=2 -no-prec-div -no-prec-sqrt -ftz -align all -fno-alias -fno-common +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -O3 +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 -fno-inline -no-ip +FCDEBUG = # -g $(FCNOOPT) -traceback # -fpe0 -check noarg_temp_created,bounds,format,output_conversion,pointers,uninit -ftrapuv -unroll0 -u +FORMAT_FIXED = -FI +FORMAT_FREE = -FR +FCSUFFIX = +BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl +# added -fno-common at suggestion of R. Dubtsov as workaround for failing to link program_name +FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) #-xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = +TRADFLAG = CONFIGURE_TRADFLAG +CPP = cpp CONFIGURE_CPPFLAGS -xassembler-with-cpp +AR = ar +ARFLAGS = ru +M4 = m4 -B 14000 +RANLIB = ranlib +RLFLAGS = -c +CC_TOOLS = cc + +########################################################### +#ARCH Darwin (MACOS) gfortran with gcc openmpi #serial smpar dmpar dm+sm +# +DESCRIPTION = GNU ($SFC/$SCC): Open MPI +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -fopenmp +OMPCC = # -fopenmp +SFC = gfortran +SCC = gcc +CCOMP = gcc +DM_FC = mpif90 +DM_CC = mpicc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = #-fdefault-real-8 +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DMACOS -DWRF_USE_CLM +CFLAGS_LOCAL = -w -O3 -c -DMACOS +LDFLAGS_LOCAL = +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -O2 -ftree-vectorize -funroll-loops +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 +FCDEBUG = # -g $(FCNOOPT) # -fbacktrace -ggdb -fcheck=bounds,do,mem,pointer -ffpe-trap=invalid,zero,overflow +FORMAT_FIXED = -ffixed-form +FORMAT_FREE = -ffree-form -ffree-line-length-none +FCSUFFIX = +BYTESWAPIO = -fconvert=big-endian -frecord-marker=4 +FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = +TRADFLAG = CONFIGURE_TRADFLAG +CPP = cpp CONFIGURE_CPPFLAGS -xassembler-with-cpp +AR = ar +ARFLAGS = ru +M4 = m4 -B 14000 +RANLIB = ranlib +RLFLAGS = -c +CC_TOOLS = $(SCC) + ########################################################### #ARCH Linux x86_64 ppc64le i486 i586 i686, PGI compiler with pgcc -f90= # serial smpar dmpar dm+sm # @@ -1758,8 +1819,8 @@ BYTESWAPIO = -byteswapio FCBASEOPTS_NO_G = -w $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -module $(WRF_SRC_ROOT_DIR)/main -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 -B 14000 @@ -1798,11 +1859,12 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) -xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common -xCORE-AVX2 FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 @@ -1811,7 +1873,7 @@ RLFLAGS = CC_TOOLS = $(SCC) ########################################################### -#ARCH Linux x86_64 ppc64le i486 i586 i686 #serial smpar dmpar dm+sm +#ARCH Linux KNL x86_64 ppc64le i486 i586 i686 #serial smpar dmpar dm+sm # DESCRIPTION = INTEL ($SFC/$SCC): KNL MIC DMPARALLEL = # 1 @@ -1841,11 +1903,12 @@ FORMAT_FIXED = -FI FORMAT_FREE = -FR FCSUFFIX = BYTESWAPIO = -convert big_endian +RECORDLENGTH = -assume byterecl FCBASEOPTS_NO_G = -ip -fp-model precise -w -ftz -align all -fno-alias $(FORMAT_FREE) $(BYTESWAPIO) -xHost -fp-model fast=2 -no-heap-arrays -no-prec-div -no-prec-sqrt -fno-common -xMIC-AVX512 FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) MODULE_SRCH_FLAG = -TRADFLAG = -traditional -CPP = /lib/cpp -P +TRADFLAG = CONFIGURE_TRADFLAG +CPP = /lib/cpp CONFIGURE_CPPFLAGS AR = ar ARFLAGS = ru M4 = m4 @@ -1853,7 +1916,52 @@ RANLIB = ranlib RLFLAGS = CC_TOOLS = $(SCC) +#insert new stanza here + +########################################################### +#ARCH Fujitsu FX10/FX100 Linux x86_64 SPARC64IXfx/SPARC64Xlfx, mpifrtpx and mpifccpx compilers #serial smpar dmpar dm+sm +# +DESCRIPTION = FUJITSU ($SFC/$SCC): FX10/FX100 SPARC64 IXfx/Xlfx +DMPARALLEL = # 1 +OMPCPP = # -D_OPENMP +OMP = # -Kopenmp +OMPCC = # -Kopenmp +SFC = frtpx +SCC = fccpx +CCOMP = fccpx +DM_FC = mpifrtpx +DM_CC = mpifccpx -DMPI2_SUPPORT -DMPI2_THREAD_SUPPORT +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +RWORDSIZE = CONFIGURE_RWORDSIZE +PROMOTION = -CcdRR$(RWORDSIZE) +ARCH_LOCAL = -DNONSTANDARD_SYSTEM_SUBR -DWRF_USE_CLM +CFLAGS_LOCAL = -Kfast -Xg -DSUN +LDFLAGS_LOCAL = +CPLUSPLUSLIB = +ESMF_LDFLAG = $(CPLUSPLUSLIB) +FCOPTIM = -Kfast +FCREDUCEDOPT = $(FCOPTIM) +FCNOOPT = -O0 +FCDEBUG = # -g $(FCNOOPT) +FORMAT_FIXED = -Fixed +FORMAT_FREE = -Free +FCSUFFIX = +BYTESWAPIO = +FCBASEOPTS_NO_G = -Kautoobjstack,ocl -fw $(FORMAT_FREE) $(BYTESWAPIO) $(OMP) +FCBASEOPTS = $(FCBASEOPTS_NO_G) $(FCDEBUG) +MODULE_SRCH_FLAG = +TRADFLAG = -traditional +CPP = /lib/cpp -P +AR = ar +ARFLAGS = ru +M4 = m4 +RANLIB = ranlib +RLFLAGS = +CC_TOOLS = /usr/bin/gcc -Wall +#insert new stanza before the Fujitsu block, keep Fujitsu at the end of the list ########################################################### #ARCH NULL diff --git a/wrfv2_fire/arch/noopt_exceptions b/wrfv2_fire/arch/noopt_exceptions index 95544e54..fa71e8e5 100644 --- a/wrfv2_fire/arch/noopt_exceptions +++ b/wrfv2_fire/arch/noopt_exceptions @@ -6,7 +6,6 @@ input_wrf.o : input_wrf.F module_io.o : module_io.F mediation_feedback_domain.o : mediation_feedback_domain.F mediation_force_domain.o : mediation_force_domain.F -mediation_integrate.o : mediation_integrate.F track_driver.o : track_driver.F mediation_interp_domain.o : mediation_interp_domain.F module_comm_dm.o : module_comm_dm.F @@ -16,7 +15,6 @@ module_comm_dm_2.o : module_comm_dm_2.F module_comm_dm_3.o : module_comm_dm_3.F module_comm_nesting_dm.o : module_comm_nesting_dm.F module_configure.o : module_configure.F -module_dm.o : module_dm.F module_domain.o : module_domain.F module_domain_type.o : module_domain_type.F module_alloc_space_0.o : module_alloc_space_0.F @@ -30,14 +28,8 @@ module_alloc_space_7.o : module_alloc_space_7.F module_alloc_space_8.o : module_alloc_space_8.F module_alloc_space_9.o : module_alloc_space_9.F module_tiles.o : module_tiles.F -module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F module_initialize.o : module_initialize.F module_physics_init.o : module_physics_init.F -module_initialize_b_wave.o : module_initialize_b_wave.F -module_initialize_hill2d_x.o : module_initialize_hill2d_x.F -module_initialize_quarter_ss.o : module_initialize_quarter_ss.F -module_initialize_real.o : module_initialize_real.F -module_initialize_real.o: module_initialize_real.F module_initialize_squall2d_x.o : module_initialize_squall2d_x.F module_initialize_squall2d_y.o : module_initialize_squall2d_y.F module_initialize_scm_xy.o : module_initialize_scm_xy.F @@ -49,11 +41,9 @@ module_wps_io_arw.o : module_wps_io_arw.F module_state_description.o : module_state_description.F output_wrf.o : output_wrf.F shift_domain_em.o : shift_domain_em.F -solve_em.o : solve_em.F solve_interface.o : solve_interface.F start_domain.o : start_domain.F start_domain_nmm.o : start_domain_nmm.F -start_em.o : start_em.F wrf_auxhist10in.o : wrf_auxhist10in.F wrf_auxhist10out.o : wrf_auxhist10out.F wrf_auxhist11in.o : wrf_auxhist11in.F @@ -119,15 +109,9 @@ convert_nmm.o \ init_modules_em.o \ mediation_feedback_domain.o \ mediation_force_domain.o \ -mediation_integrate.o \ track_driver.o \ mediation_interp_domain.o \ -module_dm.o \ -module_fddaobs_rtfdda.o \ module_initialize.o \ -module_initialize_b_wave.o \ -module_initialize_hill2d_x.o \ -module_initialize_quarter_ss.o \ module_initialize_real.o \ module_initialize_squall2d_x.o \ module_initialize_squall2d_y.o \ @@ -143,7 +127,6 @@ shift_domain_em.o \ solve_interface.o \ start_domain.o \ start_domain_nmm.o \ -start_em.o \ wrf_fddaobs_in.o \ wrf_tsin.o : $(RM) $@ @@ -163,13 +146,6 @@ wrf_tsin.o : $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(FCSUFFIX) $*.f90 ; \ fi -solve_em.o : - $(RM) $@ - $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F > $*.bb - $(SED_FTN) $*.bb | $(CPP) $(TRADFLAG) > $*.f90 - $(RM) $*.b $*.bb - $(FC) -c $(PROMOTION) $(FCNOOPT) $(FCBASEOPTS) $(MODULE_DIRS) $(OMP) $(SOLVE_EM_SPECIAL) $(FCSUFFIX) $*.f90 - module_sf_ruclsm.o : module_sf_ruclsm.F module_sf_ruclsm.o : diff --git a/wrfv2_fire/arch/noopt_exceptions_f b/wrfv2_fire/arch/noopt_exceptions_f index ad8cd99e..60389385 100644 --- a/wrfv2_fire/arch/noopt_exceptions_f +++ b/wrfv2_fire/arch/noopt_exceptions_f @@ -7,7 +7,6 @@ # mediation_interp_domain.o : mediation_interp_domain.F # compile these without high optimization to speed compile -mediation_integrate.o : mediation_integrate.F track_driver.o : track_driver.F convert_nmm.o : convert_nmm.F init_modules_em.o : init_modules_em.F @@ -20,7 +19,6 @@ module_comm_dm_2.o : module_comm_dm_2.F module_comm_dm_3.o : module_comm_dm_3.F module_comm_nesting_dm.o : module_comm_nesting_dm.F module_configure.o : module_configure.F -module_dm.o : module_dm.F module_domain.o : module_domain.F module_domain_type.o : module_domain_type.F module_alloc_space_0.o : module_alloc_space_0.F @@ -34,14 +32,8 @@ module_alloc_space_7.o : module_alloc_space_7.F module_alloc_space_8.o : module_alloc_space_8.F module_alloc_space_9.o : module_alloc_space_9.F module_tiles.o : module_tiles.F -module_fddaobs_rtfdda.o : module_fddaobs_rtfdda.F module_initialize.o : module_initialize.F module_physics_init.o : module_physics_init.F -module_initialize_b_wave.o : module_initialize_b_wave.F -module_initialize_hill2d_x.o : module_initialize_hill2d_x.F -module_initialize_quarter_ss.o : module_initialize_quarter_ss.F -module_initialize_real.o : module_initialize_real.F -module_initialize_real.o: module_initialize_real.F module_initialize_squall2d_x.o : module_initialize_squall2d_x.F module_initialize_squall2d_y.o : module_initialize_squall2d_y.F module_initialize_scm_xy.o : module_initialize_scm_xy.F @@ -54,7 +46,6 @@ module_state_description.o : module_state_description.F output_wrf.o : output_wrf.F solve_interface.o : solve_interface.F start_domain.o : start_domain.F -start_em.o : start_em.F wrf_bdyin.o : wrf_bdyin.F wrf_bdyout.o : wrf_bdyout.F wrf_ext_read_field.o : wrf_ext_read_field.F @@ -72,17 +63,10 @@ nl_get_1_routines.o : nl_get_1_routines.F nl_set_0_routines.o : nl_set_0_routines.F nl_set_1_routines.o : nl_set_1_routines.F -mediation_integrate.o \ track_driver.o \ convert_nmm.o \ init_modules_em.o \ -module_dm.o \ -module_fddaobs_rtfdda.o \ module_initialize.o \ -module_initialize_b_wave.o \ -module_initialize_hill2d_x.o \ -module_initialize_quarter_ss.o \ -module_initialize_real.o \ module_initialize_squall2d_x.o \ module_initialize_squall2d_y.o \ module_initialize_scm_xy.o \ @@ -95,7 +79,6 @@ module_tiles.o \ output_wrf.o \ solve_interface.o \ start_domain.o \ -start_em.o \ wrf_fddaobs_in.o \ wrf_tsin.o : $(RM) $@ diff --git a/wrfv2_fire/arch/postamble_new b/wrfv2_fire/arch/postamble_new index 31ede179..dd555d67 100644 --- a/wrfv2_fire/arch/postamble_new +++ b/wrfv2_fire/arch/postamble_new @@ -69,6 +69,7 @@ CPPFLAGS = $(ARCHFLAGS) $(ENVCOMPDEFS) -I$(LIBINCLUDE) $(TRADFLAG) CON NETCDFPATH = CONFIGURE_NETCDF_PATH HDF5PATH = CONFIGURE_HDF5_PATH WRFPLUSPATH = CONFIGURE_WRFPLUS_PATH +RTTOVPATH = CONFIGURE_RTTOV_PATH PNETCDFPATH = CONFIGURE_PNETCDF_PATH bundled: io_only CONFIGURE_ATMOCN @@ -175,15 +176,19 @@ wrfio_esmf : .F.i: $(RM) $@ - $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.F > $@ + sed -e "s/grid%mu/gridmu/g" -e "s/grid%Mu/gridMu/g" -e "s/^\!.*'.*//" -e "s/^ *\!.*'.*//" $*.F > $*.G + $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.G > $*.H + sed -e "s/gridmu/grid%mu/g" -e "s/gridMu/grid%Mu/g" $*.H > $*.i mv $*.i $(DEVTOP)/pick/$*.f90 cp $*.F $(DEVTOP)/pick .F.o: $(RM) $@ - $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.F > $*.bb + sed -e "s/grid%mu/gridmu/g" -e "s/grid%Mu/gridMu/g" -e "s/^\!.*'.*//" -e "s/^ *\!.*'.*//" $*.F > $*.G + $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $(OMPCPP) $*.G > $*.H + sed -e "s/gridmu/grid%mu/g" -e "s/gridMu/grid%Mu/g" $*.H > $*.bb $(SED_FTN) $*.bb | $(CPP) $(TRADFLAG) > $*.f90 - $(RM) $*.b $*.bb + $(RM) $*.G $*.H $*.bb @ if echo $(ARCHFLAGS) | $(FGREP) 'DVAR4D'; then \ echo COMPILING $*.F for 4DVAR ; \ $(WRF_SRC_ROOT_DIR)/var/build/da_name_space.pl $*.f90 > $*.f90.tmp ; \ @@ -194,9 +199,11 @@ wrfio_esmf : .F.f90: $(RM) $@ - $(SED_FTN) $*.F > $*.b - $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.b > $@ - $(RM) $*.b + sed -e "s/grid%mu/gridmu/g" -e "s/grid%Mu/gridMu/g" -e "s/^\!.*'.*//" -e "s/^ *\!.*'.*//" $*.F > $*.G + $(SED_FTN) $*.G > $*.H + $(CPP) -I$(WRF_SRC_ROOT_DIR)/inc $(CPPFLAGS) $*.H > $*.I + sed -e "s/gridmu/grid%mu/g" -e "s/gridMu/grid%Mu/g" $*.I > $@ + $(RM) $*.G $*.H $*.I .f90.o: $(RM) $@ diff --git a/wrfv2_fire/arch/preamble_new b/wrfv2_fire/arch/preamble_new index e50f2035..3a252799 100644 --- a/wrfv2_fire/arch/preamble_new +++ b/wrfv2_fire/arch/preamble_new @@ -1,5 +1,10 @@ # configure.wrf # +# Original configure options used: +# CONFIGURE_CONFIG_LINE +# CONFIGURE_CONFIG_NUM +# CONFIGURE_CONFIG_NEST +# # This file was automatically generated by the configure script in the # top level directory. You may make changes to the settings in this # file but be aware they will be overwritten each time you run configure. @@ -7,7 +12,7 @@ # first installed. # # To permanently change options, change the settings for your platform -# in the file arch/configure.defaults then rerun configure. +# in the file arch/configure_new.defaults then rerun configure. # SHELL = /bin/sh DEVTOP = `pwd` diff --git a/wrfv2_fire/chem/KPP/clean_kpp b/wrfv2_fire/chem/KPP/clean_kpp index 2045dae4..bbae5883 100755 --- a/wrfv2_fire/chem/KPP/clean_kpp +++ b/wrfv2_fire/chem/KPP/clean_kpp @@ -33,7 +33,7 @@ end #coupler -( cd util/wkc; make clean ) +( cd util/wkc; make clean; make -f Makefile.tuv clean ) diff --git a/wrfv2_fire/chem/KPP/compile_wkc b/wrfv2_fire/chem/KPP/compile_wkc index 9ab21264..1d0cdc19 100755 --- a/wrfv2_fire/chem/KPP/compile_wkc +++ b/wrfv2_fire/chem/KPP/compile_wkc @@ -14,6 +14,7 @@ setenv WKC_HOME ${WRFC_ROOT}/chem/${WKC_DIRNAME} # KPP_HOME: environment variable needed by KPP # note: this is not plain KPP setenv KPP_HOME ${WKC_HOME}/kpp/kpp-2.1 +mkdir -p ${KPP_HOME}/bin setenv WKC_KPP ${KPP_HOME}/bin/kpp @@ -51,6 +52,10 @@ echo "-----------------------------------------" echo compile the coupler cd $WKC_HOME/util/wkc; make -i -r +#compile the tuv_kpp +echo compile the tuv_kpp +make -f Makefile.tuv + echo "-----------------------------------------" # if Registry was edited touch run_wkc @@ -67,6 +72,14 @@ echo "Run kpp for mechanisms in chem/KPP/mechanisms" cd $WKC_HOME set kpp_files = ( mechanisms/*/*.kpp ) +# Remove tuv inc files +set found = 0 +if ( -e ${WRFC_ROOT}/inc/tuv2wrf_jvals.inc ) then + rm -f ${WRFC_ROOT}/inc/tuv2wrf_jvals.inc; +endif +if ( -e ${WRFC_ROOT}/inc/tuvdef_jvals.inc ) then + rm -f ${WRFC_ROOT}/inc/tuvdef_jvals.inc; +endif foreach file ( $kpp_files ) @@ -102,6 +115,15 @@ echo $kdir echo model $model make MODEL=$model KPP=$WKC_KPP WRFC_ROOT=$WRFC_ROOT +# generate tuv photolysis inc files + if( -e $model.tuv.jmap ) then + if( $found == 0 ) then + $WKC_HOME/util/wkc/tuv_kpp FIRST + set found = 1 + endif + $WKC_HOME/util/wkc/tuv_kpp $model + endif + if ( `echo $WRFC_ROOT | awk '{print ( length ( $1 ) > 40 ) }' `) then echo WARNING: If kpp fails here the path to WRF-Chem might be too long for yacc ... endif @@ -115,6 +137,11 @@ echo $kdir end +# finish tuv photolysis inc files +if( $found == 1 ) then + $WKC_HOME/util/wkc/tuv_kpp LAST +endif + echo "=========================================================" ################################################### diff --git a/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_args_to_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_args_to_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc new file mode 100644 index 00000000..c105d056 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_args_to_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc @@ -0,0 +1,3 @@ + var(ind_NUME),var(ind_DEN), & + +! diff --git a/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_args_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_args_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc new file mode 100644 index 00000000..4b07deeb --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_args_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc @@ -0,0 +1,2 @@ +nume,den, & +! diff --git a/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_decls_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_decls_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc new file mode 100644 index 00000000..b6c1a1b3 --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/extra_decls_update_rconst_saprc99_mosaic_8bin_vbs2_aq.inc @@ -0,0 +1,2 @@ +REAL(KIND=dp), INTENT(IN) :: nume,den +! diff --git a/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_a_saprc99_mosaic_8bin_vbs2_aq.inc b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_a_saprc99_mosaic_8bin_vbs2_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_a_saprc99_mosaic_8bin_vbs2_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_b_saprc99_mosaic_8bin_vbs2_aq.inc b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_b_saprc99_mosaic_8bin_vbs2_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_b_saprc99_mosaic_8bin_vbs2_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_e_saprc99_mosaic_8bin_vbs2_aq.inc b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_e_saprc99_mosaic_8bin_vbs2_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_e_saprc99_mosaic_8bin_vbs2_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ia_saprc99_mosaic_8bin_vbs2_aq.inc b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ia_saprc99_mosaic_8bin_vbs2_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ia_saprc99_mosaic_8bin_vbs2_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ib_saprc99_mosaic_8bin_vbs2_aq.inc b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ib_saprc99_mosaic_8bin_vbs2_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ib_saprc99_mosaic_8bin_vbs2_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ibu_saprc99_mosaic_8bin_vbs2_aq.inc b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ibu_saprc99_mosaic_8bin_vbs2_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_ibu_saprc99_mosaic_8bin_vbs2_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_l_saprc99_mosaic_8bin_vbs2_aq.inc b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_l_saprc99_mosaic_8bin_vbs2_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_l_saprc99_mosaic_8bin_vbs2_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_u_saprc99_mosaic_8bin_vbs2_aq.inc b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_u_saprc99_mosaic_8bin_vbs2_aq.inc new file mode 100644 index 00000000..cdf4cb4f --- /dev/null +++ b/wrfv2_fire/chem/KPP/inc/saprc99_mosaic_8bin_vbs2_aq/kpp_mechd_u_saprc99_mosaic_8bin_vbs2_aq.inc @@ -0,0 +1 @@ +! diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags deleted file mode 100644 index e5c77ec6..00000000 --- a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/cflags +++ /dev/null @@ -1 +0,0 @@ - -Aa diff --git a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/Makefile b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/Makefile index 20bdfc08..7472fd34 100755 --- a/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/Makefile +++ b/wrfv2_fire/chem/KPP/kpp/kpp-2.1/src/Makefile @@ -63,8 +63,8 @@ OBJS = \ debug.o kpp: $(OBJS) - @echo " "$(SCC) $(CC_FLAGS) $(CLFLAGS) $(CFLAGS) $(OBJS) -L$(FLEX_LIB_DIR) -lfl -ll -o kpp - @$(SCC) $(CC_FLAGS) $(CFLAGS) $(CLFLAGS) $(OBJS) -L$(FLEX_LIB_DIR) -lfl -ll -o kpp + @echo " "$(SCC) $(CC_FLAGS) $(CFLAGS) $(OBJS) $(CLFLAGS) -L$(FLEX_LIB_DIR) -lfl -o kpp + @$(SCC) $(CC_FLAGS) $(CFLAGS) $(OBJS) $(CLFLAGS) -L$(FLEX_LIB_DIR) -lfl -o kpp @mv kpp ../bin clean: diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.tuv.jmap b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.tuv.jmap new file mode 100644 index 00000000..4ab2b78e --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin/mozart_mosaic_4bin.tuv.jmap @@ -0,0 +1,25 @@ +o2 : j_o2 +o31d : j_o1d +o33p : j_o3p +no2 : j_no2 +n2o5 : j_n2o5_b +n2o : j_n2o +hno3 : j_hno3 +no3o : j_no3_a +hno4 : j_hno4 +h2o2 : j_h2o2 +ch3o2h : j_ch3ooh +ch2or : j_ch2o_r +ch2om : j_ch2o_m +ch3cho : j_ch3cho_a + j_ch3cho_b + j_ch3cho_c +pooh : j_hoch2ooh +pan : j_pan_a + j_pan_b +macr : j_macr +mvk : j_mvk +ch3coch3 : j_ch3coch3 +ch3cocho : j_mgly +hyac : j_hyac_a + j_hyac_b +glyald : j_glyald_a + j_glyald_b + j_glyald_c +mek : j_mek +gly : j_gly_a + j_gly_b + j_gly_c +hno2 : j_hno2 diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.tuv.jmap b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.tuv.jmap new file mode 100644 index 00000000..4ab2b78e --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozart_mosaic_4bin_aq/mozart_mosaic_4bin_aq.tuv.jmap @@ -0,0 +1,25 @@ +o2 : j_o2 +o31d : j_o1d +o33p : j_o3p +no2 : j_no2 +n2o5 : j_n2o5_b +n2o : j_n2o +hno3 : j_hno3 +no3o : j_no3_a +hno4 : j_hno4 +h2o2 : j_h2o2 +ch3o2h : j_ch3ooh +ch2or : j_ch2o_r +ch2om : j_ch2o_m +ch3cho : j_ch3cho_a + j_ch3cho_b + j_ch3cho_c +pooh : j_hoch2ooh +pan : j_pan_a + j_pan_b +macr : j_macr +mvk : j_mvk +ch3coch3 : j_ch3coch3 +ch3cocho : j_mgly +hyac : j_hyac_a + j_hyac_b +glyald : j_glyald_a + j_glyald_b + j_glyald_c +mek : j_mek +gly : j_gly_a + j_gly_b + j_gly_c +hno2 : j_hno2 diff --git a/wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.tuv.jmap b/wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.tuv.jmap new file mode 100644 index 00000000..4ab2b78e --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/mozcart/mozcart.tuv.jmap @@ -0,0 +1,25 @@ +o2 : j_o2 +o31d : j_o1d +o33p : j_o3p +no2 : j_no2 +n2o5 : j_n2o5_b +n2o : j_n2o +hno3 : j_hno3 +no3o : j_no3_a +hno4 : j_hno4 +h2o2 : j_h2o2 +ch3o2h : j_ch3ooh +ch2or : j_ch2o_r +ch2om : j_ch2o_m +ch3cho : j_ch3cho_a + j_ch3cho_b + j_ch3cho_c +pooh : j_hoch2ooh +pan : j_pan_a + j_pan_b +macr : j_macr +mvk : j_mvk +ch3coch3 : j_ch3coch3 +ch3cocho : j_mgly +hyac : j_hyac_a + j_hyac_b +glyald : j_glyald_a + j_glyald_b + j_glyald_c +mek : j_mek +gly : j_gly_a + j_gly_b + j_gly_c +hno2 : j_hno2 diff --git a/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/atoms_red b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/atoms_red new file mode 100755 index 00000000..2578ad27 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/atoms_red @@ -0,0 +1,107 @@ +#ATOMS + H { 1 Hydrogen }; + He { 2 Helium }; + Li { 3 Litium }; + Be { 4 }; + B { 5 }; + C { 6 }; + N { 7 }; + O { 8 }; + F { 9 }; + Ne { 10 }; + Na { 11 }; + Mg { 12 }; + Al { 13 }; + Si { 14 }; + P { 15 }; + S { 16 }; + Cl { 17 }; + Ar { 18 }; + K { 19 }; + Ca { 20 }; + Sc { 21 }; + Ti { 22 }; + V { 23 }; + Cr { 24 }; + Mn { 25 }; + Fe { 26 }; + Co { 27 }; + Ni { 28 }; + Cu { 29 }; + Zn { 30 }; + Ga { 31 }; + Ge { 32 }; + As { 33 }; + Se { 34 }; + Br { 35 }; + Kr { 36 }; + Rb { 37 }; + Sr { 38 }; + Y { 39 }; + Zr { 40 }; + Nb { 41 }; + Mu { 42 }; + Tc { 43 }; + Ru { 44 }; + Rh { 45 }; + Pd { 46 }; + Ag { 47 }; + Cd { 48 }; + In { 49 }; + Sn { 50 }; + Sb { 51 }; + Te { 52 }; + I { 53 }; + Xe { 54 }; + Cs { 55 }; + Ba { 56 }; + La { 57 }; + Ce { 58 }; + Pr { 59 }; + Nd { 60 }; + Pm { 61 }; + Sm { 62 }; + Eu { 63 }; + Gd { 64 }; + Tb { 65 }; + Dy { 66 }; + Ho { 67 }; + Er { 68 }; + Tm { 69 }; + Yb { 70 }; + Lu { 71 }; + Hf { 72 }; + Ta { 73 }; + W { 74 }; + Re { 75 }; + Os { 76 }; + Ir { 77 }; + Pt { 78 }; + Au { 79 }; + Hg { 80 }; + Tl { 81 }; + Pb { 82 }; + Bi { 83 }; + Po { 84 }; + At { 85 }; + Rn { 86 }; + Fr { 87 }; + Ra { 88 }; + Ac { 89 }; + Th { 90 }; + Pa { 91 }; + U { 92 }; + Np { 93 }; + Pu { 94 }; + Am { 95 }; + Cm { 96 }; + Bk { 97 }; + Cf { 98 }; + Es { 99 }; + Fm {100 }; + Md {101 }; + No {102 }; + Lr {103 }; + Unq {104 }; + Unp {105 }; + Unh {106 }; diff --git a/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.def b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.def new file mode 100755 index 00000000..70a0bf03 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.def @@ -0,0 +1,30 @@ +#include atoms_red +#include saprc99_mosaic_8bin_vbs2_aq.spc +#include saprc99_mosaic_8bin_vbs2_aq.eqn + + + +#INLINE F90_RATES +!__________________________________________________ + + REAL(KIND=dp) FUNCTION Keff ( A0,B0,C0, TEMP,X1,X2,y1,y2 ) + REAL(KIND=dp),INTENT(IN) :: X1,X2,y1,y2 + REAL(KIND=dp),INTENT(IN) :: TEMP + REAL(KIND=dp),INTENT(IN):: A0,B0,C0 + Keff = A0 * EXP(- B0 /TEMP ) & + *(TEMP/300._dp)**C0*(y1*X1/(X1 + X2 + 1.0e-35) & + +y2*(1-X1/(X1 + X2 + 1.0e-35))) + END FUNCTION Keff +!__________________________________________________ + + REAL(KIND=dp) FUNCTION Keff2 ( C0,X1,X2,y1,y2 ) + REAL(KIND=dp),INTENT(IN) :: X1,X2,y1,y2 + REAL(KIND=dp),INTENT(IN):: C0 + Keff2 = C0*(y1*X1/(X1 + X2 + 1.0e-35) & + +y2*(1-X1/(X1 + X2 + 1.0e-35 ))) + END FUNCTION Keff2 +!__________________________________________________ +#ENDINLINE + + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.eqn b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.eqn new file mode 100755 index 00000000..ce75986a --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.eqn @@ -0,0 +1,443 @@ +#EQUATIONS {SAPRC99_MOSAIC_8BIN_VBS2_AQ by Manish Shrivastava} + +{1} NO2 + hv = NO + O3P : j(Pj_no2) ; +{2} O3P + M {O2+air} = O3 : 0.20946e0*C_M*ARR(5.68D-34,0.0_dp,-2.80_dp,TEMP) ; +{3} O3P + O3 = M {2O2} : ARR(8.00D-12,2060.0_dp,0.0_dp,TEMP) ; +{4} O3P + NO + M {AIR} = NO2 : ARR(1.00D-31,0.0_dp,-1.60_dp,TEMP) ; +{5} O3P + NO2 = NO : ARR(6.50D-12,-120.0_dp,0.0_dp,TEMP) ; +{6} O3P + NO2 = NO3 : FALL(9.00D-32,0.0_dp,-2.00_dp,2.20D-11,0.0_dp,0.0_dp,0.80_dp,TEMP,C_M) ; +{7} O3 + NO = NO2 : ARR(1.80D-12,1370.0_dp,0.0_dp,TEMP) ; +{8} O3 + NO2 = NO3 : ARR(1.40D-13,2470.0_dp,0.0_dp,TEMP) ; +{9} NO + NO3 = NO2 + NO2 : ARR(1.80D-11,-110.0_dp,0.0_dp,TEMP) ; +{10} NO + NO + M {O2} = NO2 + NO2 : 0.20946e0*ARR(3.30D-39,-530.0_dp,0.0_dp,TEMP) ; +{11} NO2 + NO3 = N2O5 : FALL(2.80D-30,0.0_dp,-3.50_dp,2.00D-12,0.0_dp,0.20_dp,0.45_dp,TEMP,C_M) ; +{12} N2O5 = NO2 + NO3 : FALL(1.D-3,11000.0_dp,-3.5_dp,9.7D14,11080.0_dp,0.1_dp,0.45_dp,TEMP,C_M) ; +{13} N2O5 + H2O = HNO3 + HNO3 : 2.60D-22 ; +{14} NO2 + NO3 = NO + NO2 : ARR(4.50D-14,1260.0_dp,0.0_dp,TEMP) ; +{15} NO3 + hv = NO : j(Pj_no3o2) ; +{16} NO3 + hv = NO2 + O3P : j(Pj_no3o) ; +{17} O3 + hv = O3P : j(Pj_o33p) ; +{18} O3 + hv = O1D : j(Pj_o31d) ; +{19} O1D + H2O = OH + OH : 2.20D-10 ; +{20} O1D + M {AIR} = O3P : ARR(2.09D-11,-95.0_dp,0.0_dp,TEMP) ; +{21} OH + NO = HONO+psd1 : FALL(7.00D-31,0.0_dp,-2.60_dp,3.60D-11,0.0_dp,-0.10_dp,0.60_dp,TEMP,C_M) ; +{22} HONO + hv = OH + NO : 0.9000_dp*j(Pj_hno2) ; +{23} HONO + hv = HO2 + NO2 : 0.1000_dp*j(Pj_hno2) ; +{24} OH + HONO = NO2+psd1 : ARR(2.70D-12,-260.0_dp,0.0_dp,TEMP) ; +{25} OH + NO2 = HNO3+psd1 : FALL(2.43D-30, 0.0_dp,-3.10_dp,1.67D-11,0.0_dp,-2.10_dp,0.60_dp,TEMP,C_M) ; +{26} OH + NO3 = HO2 + NO2+psd1 : 2.00D-11 ; +{27} OH + HNO3 = NO3+psd1 : EP2(7.20D-15,-785.0_dp,4.10D-16,-1440.0_dp,1.90D-33,-725.0_dp,TEMP,C_M) ; +{28} HNO3 + hv = OH + NO2 : j(Pj_hno3) ; +{29} OH + CO = HO2+psd1 : EP3(1.30D-13,0.0_dp,3.19D-33,0.0_dp,TEMP,C_M) ; +{30} OH + O3 = HO2+psd1 : ARR(1.90D-12,1000.0_dp,0.0_dp,TEMP) ; +{31} HO2 + NO = OH + NO2 : ARR(3.40D-12,-270.0_dp,0.0_dp,TEMP) ; +{32} HO2 + NO2 = HNO4 : FALL(1.80D-31,0.0_dp,-3.20_dp,4.70D-12,0.0_dp,0.0_dp,0.60_dp,TEMP,C_M) ; +{33} HNO4 = HO2 + NO2 : FALL(4.10D-05,10650.0_dp,0.0_dp,5.7D15,11170.0_dp,0.0_dp,0.5_dp,TEMP,C_M) ; +{34} HNO4 + hv = 0.61HO2 + 0.61NO2 + 0.39OH + + 0.39NO3 : j(Pj_hno4) ; +{35} HNO4 + OH = NO2 : ARR(1.50D-12,-360.0_dp,0.0_dp,TEMP) ; +{36} HO2 + O3 = OH : ARR(1.40D-14,600.0_dp,0.0_dp,TEMP) ; +{37} HO2 + HO2 = H2O2 : EP3(2.20D-13,-600.0_dp,1.85D-33,-980.0_dp,TEMP,C_M) ; +{38} HO2 + HO2 + H2O = H2O2 : EP3(3.08D-34,-2800.0_dp,2.59D-54,-3180.0_dp,TEMP,C_M) ; +{39} NO3 + HO2 = 0.8OH + 0.8NO2 + 0.2HNO3 : 4.00D-12 ; +{40} NO3 + NO3 = NO2 + NO2 : ARR(8.50D-13,2450.0_dp,0.0_dp,TEMP) ; +{41} H2O2 + hv = OH + OH : j(Pj_h2o2) ; +{42} H2O2 + OH = HO2 : ARR(2.90D-12,160.0_dp,0.0_dp,TEMP) ; +{43} OH + HO2 = H2O + M {O2}+psd1 : ARR(4.80D-11,-250.0_dp,0.0_dp,TEMP) ; +{44} OH + SO2 = HO2 + H2SO4+psd1 : FALL(4.00D-31,0.0_dp,-3.30_dp,2.00D-12,0.0_dp,0.0_dp,0.45_dp,TEMP,C_M) ; +{45} OH + M {H2} = HO2+psd1 : 5.40D-7*ARR(7.70D-12,2100.0_dp,0.0_dp,TEMP) ; +{46} C_O2 + NO = NO2 + HCHO + HO2 +nume: ARR(2.80D-12,-285.0_dp,0.0_dp,TEMP) ; +{47} C_O2 + HO2 = COOH +den: ARR(3.80D-13,-780.0_dp,0.0_dp,TEMP) ; +{48} C_O2 + NO3 = HCHO + HO2 + NO2 +nume: 1.30D-12 ; +{49} C_O2 + C_O2 = MEOH + HCHO +den: ARR(2.45D-14,-710.0_dp,0.0_dp,TEMP) ; +{50} C_O2 + C_O2 = HCHO + HCHO + HO2 + HO2 +den: ARR(5.90D-13,509.0_dp,0.0_dp,TEMP) ; +{51} RO2_R + NO = nume+NO2 + HO2 : ARR(2.70D-12,-360.0_dp,0.0_dp,TEMP) ; +{52} RO2_R + HO2 = ROOH+den : ARR(1.90D-13,-1300.0_dp,0.0_dp,TEMP) ; +{53} RO2_R + NO3 = NO2 + HO2 +nume : 2.30D-12 ; +{54} RO2_R + C_O2 = HO2 + 0.75HCHO + + 0.25MEOH +den: 2.00D-13 ; +{55} RO2_R + RO2_R = HO2+den : 3.50D-14 ; +{56} R2O2 + NO = NO2+nume : 1.0_dp*ARR(2.70D-12,-360.0_dp,0.0_dp,TEMP) ; +{57} R2O2 + HO2 = HO2+den : 1.0_dp*ARR(1.90D-13,-1300.0_dp,0.0_dp,TEMP) ; +{58} R2O2 + NO3 = NO2+nume : 1.0_dp*2.30D-12 ; +{59} R2O2 + C_O2 = C_O2+den : 1.0_dp*2.00D-13 ; +{60} R2O2 + RO2_R = RO2_R+den : 1.0_dp*3.50D-14 ; +{61} R2O2 + R2O2 = R2O2 + R2O2+den : 0.0_dp ; +{62} RO2_N + NO = RNO3+nume : 1.0_dp*ARR(2.70D-12,-360.0_dp,0.0_dp,TEMP) ; +{63} RO2_N + HO2 = ROOH+den : 1.0_dp*ARR(1.90D-13,-1300.0_dp,0.0_dp,TEMP) ; +{64} RO2_N + C_O2 = HO2 + 0.25MEOH + + 0.5MEK + 0.5PROD2 + 0.75HCHO +den: 1.0_dp*2.00D-13 ; +{65} RO2_N + NO3 = NO2 + HO2 + MEK +nume : 1.0_dp*2.30D-12 ; +{66} RO2_N + RO2_R = HO2 + 0.5MEK + + 0.5PROD2+den : 1.0_dp*3.50D-14 ; +{67} RO2_N + R2O2 = RO2_N+den : 1.0_dp*3.50D-14 ; +{68} RO2_N + RO2_N =MEK + HO2 + PROD2+den : 1.0_dp*3.50D-14 ; +{69} CCO_O2 + NO2 = PAN : FALL(2.70D-28,0.0_dp,-7.10_dp,1.20D-11,0.0_dp,-0.90_dp,0.30_dp,TEMP,C_M) ; +{70} PAN = CCO_O2 + NO2 : FALL(4.90D-3,12100.0_dp,0.0_dp,4.0D16,13600.0_dp,0._dp,0.3_dp,TEMP,C_M) ; +{71} CCO_O2 + NO = C_O2 + NO2 : ARR(7.80D-12,-300.0_dp,0.0_dp,TEMP) ; +{72} CCO_O2 + HO2 = 0.75CCO_OOH + + 0.25CCO_OH + 0.25O3 : ARR(4.30D-13,-1040.0_dp,0.0_dp,TEMP) ; +{73} CCO_O2 + NO3 = C_O2 + NO2 : 4.00D-12 ; +{74} CCO_O2 + C_O2 = CCO_OH + HCHO : ARR(1.80D-12,-500.0_dp,0.0_dp,TEMP) ; +{75} CCO_O2 + RO2_R = CCO_OH : 7.50D-12 ; +{76} CCO_O2 + R2O2 = CCO_O2 : 1.0_dp*7.50D-12 ; +{77} CCO_O2 + RO2_N = CCO_OH + PROD2 : 1.0_dp*7.50D-12 ; +{78} CCO_O2 + CCO_O2 = C_O2 + C_O2 : ARR(2.90D-12,-500.0_dp,0.0_dp,TEMP) ; +{79} RCO_O2 + NO2 = PAN2 : ARR(1.20D-11,0.0_dp,-0.90_dp,TEMP) ; +{80} PAN2 = RCO_O2 + NO2 : ARR(2.00D15,12800.0_dp,0.0_dp,TEMP) ; +{81} RCO_O2 + NO = NO2 + CCHO + RO2_R : ARR(1.25D-11,-240.0_dp,0.0_dp,TEMP) ; +{82} RCO_O2 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : 1.0_dp*ARR(4.30D-13,-1040.0_dp,0.0_dp,TEMP) ; +{83} RCO_O2 + NO3 = NO2 + CCHO + RO2_R : 1.0_dp*4.00D-12 ; +{84} RCO_O2 + C_O2 = RCO_OH + HCHO : 1.0_dp*ARR(1.80D-12,-500.0_dp,0.0_dp,TEMP) ; +{85} RCO_O2 + RO2_R = RCO_OH : 1.0_dp*7.50D-12 ; +{86} RCO_O2 + R2O2 = RCO_O2 : 1.0_dp*7.50D-12 ; +{87} RCO_O2 + RO2_N = RCO_OH + PROD2 : 1.0_dp*7.50D-12 ; +{88} RCO_O2 + CCO_O2 = C_O2 + CCHO + RO2_R : 1.0_dp*ARR(2.90D-12,-500.0_dp,0.0_dp,TEMP) ; +{89} RCO_O2 + RCO_O2 = CCHO + CCHO + RO2_R + RO2_R : 1.0_dp*ARR(2.90D-12,-500.0_dp,0.0_dp,TEMP) ; +{90} BZCO_O2 + NO2 = PBZN : 1.37D-11 ; +{91} PBZN = BZCO_O2 + NO2 : ARR(7.90D16,14000.0_dp,0.0_dp,TEMP) ; +{92} BZCO_O2 + NO = NO2 + BZ_O + R2O2 : 1.0_dp*ARR(1.25D-11,-240.0_dp,0.0_dp,TEMP) ; +{93} BZCO_O2 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : 1.0_dp*ARR(4.30D-13,-1040.0_dp,0.0_dp,TEMP) ; +{94} BZCO_O2 + NO3 = NO2 + BZ_O + R2O2 : 1.0_dp*4.00D-12 ; +{95} BZCO_O2 + C_O2 = RCO_OH + HCHO : 1.0_dp*ARR(1.80D-12,-500.0_dp,0.0_dp,TEMP) ; +{96} BZCO_O2 + RO2_R = RCO_OH : 1.0_dp*7.50D-12 ; +{97} BZCO_O2 + R2O2 = BZCO_O2 : 1.0_dp*7.50D-12 ; +{98} BZCO_O2 + RO2_N = RCO_OH + PROD2 : 1.0_dp*7.50D-12 ; +{99} BZCO_O2 + CCO_O2 = C_O2 + BZ_O + R2O2 : 1.0_dp*ARR(2.90D-12,-500.0_dp,0.0_dp,TEMP) ; +{100} BZCO_O2 + RCO_O2 = CCHO + RO2_R + + BZ_O + R2O2 : 1.0_dp*ARR(2.90D-12,-500.0_dp,0.0_dp,TEMP) ; +{101} BZCO_O2 + BZCO_O2 = BZ_O + BZ_O + R2O2 + R2O2 : 1.0_dp*ARR(2.90D-12,-500.0_dp,0.0_dp,TEMP) ; +{102} MA_RCO3 + NO2 = MA_PAN : 1.0_dp*ARR(1.20D-11,0.0_dp,-0.90_dp,TEMP) ; +{103} MA_PAN = MA_RCO3 + NO2 : ARR(1.60D16,13486.0_dp,0.0_dp,TEMP) ; +{104} MA_RCO3 + NO = NO2 + HCHO + CCO_O2 : 1.0_dp*ARR(1.25D-11,-240.0_dp,0.0_dp,TEMP) ; +{105} MA_RCO3 + HO2 = 0.75RCO_OOH + + 0.25RCO_OH + 0.25O3 : 1.0_dp*ARR(4.30D-13,-1040.0_dp,0.0_dp,TEMP) ; +{106} MA_RCO3 + NO3 = NO2 + HCHO + CCO_O2 : 1.0_dp*4.00D-12 ; +{107} MA_RCO3 + C_O2 = RCO_OH + HCHO : 1.0_dp*ARR(1.80D-12,-500.0_dp,0.0_dp,TEMP) ; +{108} MA_RCO3 + RO2_R = RCO_OH : 1.0_dp*7.50D-12 ; +{109} MA_RCO3 + R2O2 = MA_RCO3 : 1.0_dp*7.50D-12 ; +{110} MA_RCO3 + RO2_N = RCO_OH + RCO_OH : 1.0_dp*7.50D-12 ; +{111} MA_RCO3 + CCO_O2 = C_O2 + HCHO + + CCO_O2 : 1.0_dp*ARR(2.90D-12,-500.0_dp,0.0_dp,TEMP) ; +{112} MA_RCO3 + RCO_O2 = HCHO + CCO_O2 + + CCHO + RO2_R : 1.0_dp*ARR(2.90D-12,-500.0_dp,0.0_dp,TEMP) ; +{113} MA_RCO3 + BZCO_O2 = HCHO + CCO_O2 + + BZ_O + R2O2 : 1.0_dp*ARR(2.90D-12,-500.0_dp,0.0_dp,TEMP) ; +{114} MA_RCO3 + MA_RCO3 = HCHO + HCHO + CCO_O2 + CCO_O2 : 1.0_dp*ARR(2.90D-12,-500.0_dp,0.0_dp,TEMP) ; +{115} TBU_O + NO2 = RNO3 : 2.40D-11 ; +{116} TBU_O = ACET + C_O2 : ARR(7.50D14,8152.0_dp,0.0_dp,TEMP) ; +{117} BZ_O + NO2 = NPHE : ARR(2.30D-11,-150.0_dp,0.0_dp,TEMP) ; +{118} BZ_O + HO2 = PHEN : 1.0_dp*ARR(1.90D-13,-1300.0_dp,0.0_dp,TEMP) ; +{119} BZ_O = PHEN : 1.00D-03 ; +{120} BZNO2_O + NO2 = XN + XN + XC + XC + XC + XC + XC + XC : 1.0_dp*ARR(7.50D14,8152.0_dp,0.0_dp,TEMP) ; +{121} BZNO2_O + HO2 = NPHE : 1.0_dp*ARR(2.30D-11,-150.0_dp,0.0_dp,TEMP) ; +{122} BZNO2_O = NPHE : 1.0_dp*1.0_dp*ARR(1.90D-13,-1300.0_dp,0.0_dp,TEMP) ; +{123} HCHO + hv = HO2 + HO2 + CO : j(Pj_ch2or) ; +{124} HCHO + hv = CO : j(Pj_ch2om) ; +{125} HCHO + OH = HO2 + CO+psd1 : ARR(8.60D-12,-20.0_dp,0.0_dp,TEMP) ; +{126} HCHO + HO2 = HOCOO : ARR(9.70D-15,-625.0_dp,0.0_dp,TEMP) ; +{127} HOCOO = HO2 + HCHO : ARR(2.40D12,7000.0_dp,0.0_dp,TEMP) ; +{128} HOCOO + NO = HCOOH + NO2 + HO2 : 1.0_dp*ARR(2.80D-12,-285.0_dp,0.0_dp,TEMP) ; +{129} HCHO + NO3 = HNO3 + HO2 + CO : ARR(2.00D-12,2431.0_dp,0.0_dp,TEMP) ; +{130} CCHO + OH = CCO_O2+psd1 : ARR(5.60D-12,-310.0_dp,0.0_dp,TEMP) ; +{131} CCHO +hv = CO + HO2 + C_O2 : 0.1900_dp*j(Pj_ch2or) ; +{132} CCHO + NO3 = HNO3 + CCO_O2 : ARR(1.40D-12,1860.0_dp,0.0_dp,TEMP) ; +{133} RCHO + OH = 0.034RO2_R + 0.001RO2_N + + 0.965RCO_O2 + 0.034CO+ 0.034CCHO +psd1 : 2.00D-11 ; +{134} RCHO + hv = CCHO + RO2_R + CO + HO2 : 0.6500_dp*j(Pj_ch2or) ; +{135} RCHO + NO3 = HNO3 + RCO_O2 : ARR(1.40D-12,1771.0_dp,0.0_dp,TEMP) ; +{136} ACET + OH = HCHO + CCO_O2 + R2O2 +psd1 : ARR(1.10D-12,520.0_dp,0.0_dp,TEMP) ; +{137} ACET + hv = CCO_O2 + C_O2 : 0.0230_dp*j(Pj_ch2or) ; +{138} MEK + OH = 0.37RO2_R + 0.042RO2_N + + 0.616R2O2+ 0.492CCO_O2 + + 0.096RCO_O2 + 0.115HCHO + + 0.482CCHO + 0.37RCHO +psd1: ARR(1.30D-12,25.0_dp,2.0_dp,TEMP) ; +{139} MEK + hv = CCO_O2 + CCHO + RO2_R : 0.0650_dp*j(Pj_ch2or) ; +{140} MEOH + OH = HCHO + HO2+psd1 : ARR(3.10D-12,360.0_dp,2.0_dp,TEMP) ; +{141} ETOH + OH = 0.95HO2 + 0.05RO2_R + + 0.081HCHO + 0.96CCHO+psd1 : ARR(0.0_dp,0.0_dp,1.0_dp,TEMP) ; +{142} COOH + OH = 0.35HCHO + 0.35OH + + 0.65C_O2+psd1 : ARR(2.90D-12,-190.0_dp,0.0_dp,TEMP) ; +{143} COOH + hv = HCHO + HO2 + OH : j(Pj_ch3o2h) ; +{144} ROOH + OH = RCHO + 0.34RO2_R + + 0.66OH +psd1 : 1.10D-11 ; +{145} ROOH + hv = RCHO + HO2 + OH : 0.2100_dp*j(Pj_ch2or) ; +{146} GLY + hv = CO + CO + HO2 + HO2 : j(Pj_hcochob) ; +{147} GLY + hv = HCHO + CO : 0.2000_dp*j(Pj_hcocho) ; +{148} GLY + OH = 0.63HO2 + 1.26CO+ + 0.37RCO_O2+psd1 : 1.10D-11 ; +{149} GLY + NO3 = HNO3 + 0.63HO2 + + 1.26CO+ 0.37RCO_O2 : ARR(2.80D-12,2376.0_dp,0.0_dp,TEMP) ; +{150} MGLY + hv = HO2 + CO + CCO_O2 : 1.3000_dp*j(Pj_ch3cocho) ; +{151} MGLY + OH = CO + CCO_O2+psd1 : 1.50D-11 ; +{152} MGLY + NO3 = HNO3 + CO + CCO_O2 : ARR(1.40D-12,1895.0_dp,0.0_dp,TEMP) ; +{153} BACL + hv = CCO_O2 + CCO_O2 : 2.3000_dp*j(Pj_ch3cocho) ; +{154} PHEN + OH = 0.24BZ_O + 0.76RO2_R + + 0.23GLY+psd1 : 2.63D-11 ; +{155} PHEN + NO3 = HNO3 + BZ_O : 3.78D-12 ; +{156} CRES + OH = 0.24BZ_O + 0.76RO2_R + + 0.23MGLY+psd1 : 4.20D-11 ; +{157} CRES + NO3 = HNO3 + BZ_O : 1.37D-11 ; +{158} NPHE + NO3 = HNO3 + BZNO2_O : 1.0_dp*2.63D-11 ; +{159} BALD + OH = BZCO_O2 +psd1: 1.29D-11 ; +{160} BALD + hv = XC + XC + XC + XC + XC + XC + XC : 1.7000_dp*j(Pj_ch2or) ; +{161} BALD + NO3 = HNO3 + BZCO_O2 : ARR(1.40D-12,1872.0_dp,0.0_dp,TEMP) ; +{162} METHACRO + OH = 0.5RO2_R + 0.416CO+ + 0.084HCHO + 0.416MEK + + 0.084MGLY + 0.5MA_RCO3+psd1 : ARR(1.86D-11,-176.0_dp,0.0_dp,TEMP) ; +{163} METHACRO + O3 = 0.008HO2 + 0.1RO2_R + + 0.208OH + 0.1RCO_O2 + 0.45CO+ + 0.2HCHO + 0.9MGLY + 0.333HCOOH : ARR(1.36D-15,2114.0_dp,0.0_dp,TEMP) ; +{164} METHACRO + NO3 = 0.5HNO3 + 0.5RO2_R + + 0.5CO+ 0.5MA_RCO3 : ARR(1.50D-12,1726.0_dp,0.0_dp,TEMP) ; +{165} METHACRO + O3P = RCHO : 6.34D-12 ; +{166} METHACRO + hv = 0.34HO2 + 0.33RO2_R + + 0.33OH + 0.67CCO_O2 + 0.67CO+ + 0.67HCHO + 0.33MA_RCO3 : 0.0470_dp*j(Pj_ch2om) ; +{167} MVK + OH = 0.3RO2_R + 0.025RO2_N + + 0.675R2O2+ 0.675CCO_O2 + + 0.3HCHO + 0.675RCHO + 0.3MGLY +psd1: ARR(4.14D-12,-453.0_dp,0.0_dp,TEMP) ; +{168} MVK + O3 = 0.064HO2 + 0.05RO2_R + + 0.164OH + 0.05RCO_O2 + 0.475CO+ + 0.1HCHO + 0.95MGLY + 0.351HCOOH : ARR(7.51D-16,1520.0_dp,0.0_dp,TEMP) ; +{169} MVK + O3P = 0.45RCHO + 0.55MEK : 4.32D-12 ; +{170} MVK + hv = 0.3C_O2 + 0.7CO+ 0.7PROD2 + + 0.3MA_RCO3 : 0.6300_dp*j(Pj_macr) ; +{171} ISOPROD + OH = 0.67RO2_R + + 0.041RO2_N + 0.289MA_RCO3 + + 0.336CO+ 0.055HCHO + 0.129CCHO + + 0.013RCHO + 0.15MEK + 0.332PROD2 + + 0.15GLY + 0.174MGLY+psd1 : 6.19D-11 ; +{172} ISOPROD + O3 = 0.4HO2 + 0.048RO2_R + + 0.048RCO_O2 + 0.285OH + + 0.498CO+ 0.125HCHO + 0.047CCHO + + 0.21MEK + 0.023GLY + 0.742MGLY + + 0.1HCOOH + 0.372RCO_OH : 4.18D-18 ; +{173} ISOPROD + NO3 = 0.799RO2_R + + 0.051RO2_N + 0.15MA_RCO3 + 0.572CO+ + 0.15HNO3 + 0.227HCHO + 0.218RCHO + + 0.008MGLY + 0.572RNO3 : 1.00D-13 ; +{174} ISOPROD + hv = 1.233HO2 + 0.467CCO_O2 + + 0.3RCO_O2 + 1.233CO+ 0.3HCHO + + 0.467CCHO + 0.233MEK : 0.0038_dp*j(Pj_hcochest) ; +{175} PROD2 + OH = 0.379HO2 + 0.473RO2_R + + 0.07RO2_N + 0.029CCO_O2 + + 0.049RCO_O2 + 0.213HCHO + + 0.084CCHO + 0.558RCHO + + 0.115MEK + 0.329PROD2+psd1 : 1.50D-11 ; +{176} PROD2 + hv = 0.96RO2_R + 0.04RO2_N + + 0.515R2O2+ 0.667CCO_O2 + + 0.333RCO_O2 + 0.506HCHO + + 0.246CCHO + 0.71RCHO : 0.3000_dp*j(Pj_ch3coc2h5) ; +{177} RNO3 + OH = 0.338NO2 + 0.113HO2 + + 0.376RO2_R + 0.173RO2_N + + 0.596R2O2+ 0.01HCHO + + 0.439CCHO + 0.213RCHO + + 0.006ACET + 0.177MEK + + 0.048PROD2 + 0.31RNO3+psd1 : 7.80D-12 ; +{178} RNO3 + hv = NO2 + 0.341HO2 + 0.564RO2_R + + 0.095RO2_N + 0.152R2O2+ 0.134HCHO + + 0.431CCHO + 0.147RCHO + 0.02ACET + + 0.243MEK + 0.435PROD2 : 1.2000_dp*j(Pj_ch3ono2) ; +{179} DCB1 + OH = RCHO + RO2_R + CO +psd1 : 5.00D-11 ; +{180} DCB1 + O3 = 1.5HO2 + 0.5OH + + 1.5CO + GLY : 2.00D-18 ; +{181} DCB2 + OH = R2O2 + RCHO + CCO_O2+psd1 : 5.00D-11 ; +{182} DCB2 + hv = RO2_R + 0.5CCO_O2 + 0.5HO2 + + CO + R2O2 + 0.5GLY + 0.5MGLY : 2.0000_dp*j(Pj_hcochest) ; +{183} DCB3 + OH = R2O2 + RCHO + CCO_O2+psd1 : 5.00D-11 ; +{184} DCB3 + hv = RO2_R + 0.5CCO_O2 + 0.5HO2 + + CO + R2O2 + 0.5GLY + 0.5MGLY : 6.8000_dp*j(Pj_hcochest) ; +{185} CH4 + OH = C_O2+psd1 : ARR(2.15D-12,1735.0_dp,0.0_dp,TEMP) ; +{186} ETHENE + OH = RO2_R + 1.61HCHO + + 0.195CCHO+psd1 : ARR(1.96D-12,-438.0_dp,0.0_dp,TEMP) ; +{187} ETHENE + O3 = 0.12OH + 0.12HO2 + + 0.5CO+ HCHO + 0.37HCOOH : ARR(9.14D-15,2580.0_dp,0.0_dp,TEMP) ; +{188} ETHENE + NO3 = RO2_R + RCHO : ARR(4.39D-13,2282.0_dp,2.0_dp,TEMP) ; +{189} ETHENE + O3P = 0.5HO2 + 0.2RO2_R + + 0.3C_O2 + 0.491CO+ 0.191HCHO + + 0.25CCHO + 0.009GLY : ARR(1.04D-11,792.0_dp,0.0_dp,TEMP) ; +{190} ISOPRENE + OH = 0.907RO2_R + + 0.093RO2_N + 0.079R2O2+ + 0.624HCHO + 0.23METHACRO + + 0.32MVK + 0.357ISOPROD+psd1 : ARR(2.50D-11,-408.0_dp,0.0_dp,TEMP) ; +{191} ISOPRENE + O3 = 0.266OH + + 0.066RO2_R + 0.008RO2_N + + 0.126R2O2+ 0.192MA_RCO3 + + 0.275CO+ 0.592HCHO + 0.1PROD2 + + 0.39METHACRO + 0.16MVK + + 0.204HCOOH + 0.15RCO_OH : ARR(7.86D-15,1912.0_dp,0.0_dp,TEMP) ; +{192} ISOPRENE + NO3 = 0.187NO2 + + 0.749RO2_R + 0.064RO2_N + + 0.187R2O2+ 0.936ISOPROD : ARR(3.03D-12,448.0_dp,0.0_dp,TEMP) ; +{193} ISOPRENE + O3P = 0.01RO2_N + + 0.24R2O2+ 0.25C_O2 + 0.24MA_RCO3 + + 0.24HCHO + 0.75PROD2 : 3.60D-11 ; +{194} TERP + OH = 0.75RO2_R + 0.25RO2_N + + 0.5R2O2+ 0.276HCHO + + 0.474RCHO + 0.276PROD2+psd1 : ARR(1.83D-11,-449.0_dp,0.0_dp,TEMP) ; +{195} TERP + O3 = 0.567OH + 0.033HO2 + + 0.031RO2_R + 0.18RO2_N + + 0.729R2O2+ 0.123CCO_O2 + + 0.201RCO_O2 + 0.157CO+ + 0.235HCHO + 0.205RCHO + 0.13ACET + + 0.276PROD2 + 0.001GLY + 0.031BACL + + 0.103HCOOH + 0.189RCO_OH : ARR(1.08D-15,821.0_dp,0.0_dp,TEMP) ; +{196} TERP + NO3 = 0.474NO2 + + 0.276RO2_R + 0.25RO2_N + + 0.75R2O2+ 0.474RCHO + 0.276RNO3 : ARR(3.66D-12,-175.0_dp,0.0_dp,TEMP) ; +{197} TERP + O3P = 0.147RCHO + 0.853PROD2 : 3.27D-11 ; +{198} SESQ + OH = 0.75RO2_R + 0.25RO2_N + + 0.5R2O2+ 0.276HCHO + + 0.474RCHO + 0.276PROD2+psd1 : 6.80D-11 ; +{199} SESQ + O3 = 0.567OH + 0.033HO2 + + 0.031RO2_R + 0.18RO2_N + + 0.729R2O2+ 0.123CCO_O2 + + 0.201RCO_O2 + 0.157CO+ + 0.235HCHO + 0.205RCHO + 0.13ACET + + 0.276PROD2 + 0.001GLY + 0.031BACL + + 0.103HCOOH + 0.189RCO_OH : 6.21D-17 ; +{200} SESQ + NO3 = 0.474NO2 + + 0.276RO2_R + 0.25RO2_N + + 0.75R2O2+ 0.474RCHO + 0.276RNO3 : 8.29D-12 ; +{201} SESQ + O3P = 0.147RCHO + 0.853PROD2 : 3.27D-11 ; + +{202} C2H6 + OH = RO2_R + CCHO+psd1 : ARR(1.37D-12,498.0_dp,2.0_dp,TEMP) ; +{203} C3H8 + OH = 0.965RO2_R + 0.035RO2_N + + 0.261RCHO + 0.704ACET+psd1 : ARR(0.0_dp,0.0_dp,1.0_dp,TEMP) ; +{204} C2H2 + OH = 0.603OH + 0.297HO2 + + 0.1RO2_R + 0.393CO + 0.096HCHO + + 0.607GLY + 0.297HCOOH+psd1 : ARR(9.87D-12,671.0_dp,0.0_dp,TEMP) ; +{205} ALK3 + OH = 0.695RO2_R + 0.07RO2_N + + 0.559R2O2+ 0.236TBU_O + 0.026HCHO + + 0.445CCHO + 0.122RCHO + 0.024ACET + + 0.332MEK+psd1 : ARR(1.019D-11,434.0_dp,0.0_dp,TEMP) ; +{206} ALK4 + OH = 0.835RO2_R + 0.143RO2_N + + 0.936R2O2+ 0.011C_O2 + 0.011CCO_O2 + + 0.002CO+ 0.024HCHO + 0.455CCHO + + 0.244RCHO + 0.452ACET + 0.11MEK + + 0.125PROD2+psd1 : ARR(5.946D-12,91.0_dp,0.0_dp,TEMP) ; +{207} ALK5 + OH = 0.653RO2_R + 0.347RO2_N + + 0.948R2O2+ 0.026HCHO + 0.099CCHO + + 0.204RCHO + 0.072ACET + 0.089MEK + + 0.417PROD2+psd1 : ARR(1.112D-11,52.0_dp,0.0_dp,TEMP) ; +{208} ARO1 + OH = 0.224HO2 + 0.765RO2_R + + 0.011RO2_N + 0.055PROD2 + 0.118GLY + + 0.119MGLY + 0.017PHEN + 0.207CRES + + 0.059BALD + 0.491DCB1 + 0.108DCB2 + + 0.051DCB3+psd1 : ARR(1.81D-12,-355.0_dp,0.0_dp,TEMP) ; +{209} ARO2 + OH = 0.187HO2 + 0.804RO2_R + + 0.009RO2_N + 0.097GLY + 0.287MGLY + + 0.087BACL + 0.187CRES + 0.05BALD + + 0.561DCB1 + 0.099DCB2 + 0.093DCB3+psd1 : 2.640D-11 ; +{210} OLE1 + OH = 0.91RO2_R + 0.09RO2_N + + 0.205R2O2+ 0.732HCHO + 0.294CCHO + + 0.497RCHO + 0.005ACET + 0.119PROD2 + psd1 : ARR(7.095D-12,-451.0_dp,0.0_dp,TEMP) ; +{211} OLE1 + O3 = 0.155OH + 0.056HO2 + + 0.022RO2_R + 0.001RO2_N + + 0.076C_O2 + 0.345CO+ 0.5HCHO + + 0.154CCHO + 0.363RCHO + 0.001ACET + + 0.215PROD2 + 0.185HCOOH + + 0.05CCO_OH + 0.119RCO_OH : ARR(2.617D-15,1640.0_dp,0.0_dp,TEMP) ; +{212} OLE1 + NO3 = 0.824RO2_R + 0.176RO2_N + + 0.488R2O2+ 0.009CCHO + 0.037RCHO + + 0.024ACET + 0.511RNO3 : ARR(4.453D-14,376.0_dp,0.0_dp,TEMP) ; +{213} OLE1 + O3P = 0.45RCHO + 0.437MEK + + 0.113PROD2 : ARR(1.074D-11,234.0_dp,0.0_dp,TEMP) ; +{214} OLE2 + OH = 0.918RO2_R + 0.082RO2_N + + 0.001R2O2+ 0.244HCHO + 0.732CCHO + + 0.511RCHO + 0.127ACET + 0.072MEK + + 0.061BALD + 0.025METHACRO + + 0.025ISOPROD + psd1 : ARR(1.743D-11,-384.0_dp,0.0_dp,TEMP) ; +{215} OLE2 + O3 = 0.378OH + 0.003HO2 + + 0.033RO2_R + 0.002RO2_N + 0.137R2O2+ + 0.197C_O2 + 0.137CCO_O2 + + 0.006RCO_O2 + 0.265CO+ 0.269HCHO + + 0.456CCHO + 0.305RCHO + 0.045ACET + + 0.026MEK + 0.043PROD2 + 0.042BALD + + 0.026METHACRO + 0.019MVK + + 0.073HCOOH + 0.129CCO_OH + + 0.247RCO_OH : ARR(5.022D-16,461.0_dp,0.0_dp,TEMP) ; +{216} OLE2 + NO3 = 0.391NO2 + 0.442RO2_R + + 0.136RO2_N + 0.711R2O2+ 0.03C_O2 + + 0.079HCHO + 0.507CCHO + 0.151RCHO + + 0.102ACET + 0.001MEK + 0.015BALD + + 0.048MVK + 0.321RNO3 : 7.265D-13 ; +{217} OLE2 + O3P = 0.013HO2 + 0.012RO2_R + + 0.001RO2_N + 0.012CO+ 0.069RCHO + + 0.659MEK + 0.259PROD2 + + 0.012METHACRO : 2.085D-11 ; +{218} C2H2 + O3 = 0.5OH + 1.5HO2 + + 1.5CO + 0.5CO2 : 2.20D-10 ; +{219} C3H6 + OH = 0.984RO2_R + 0.016RO2_N + + 0.984HCHO + 0.984CCHO + 0.048XC +psd1 : 2.20D-10 ; +{220} C3H6 + O3 = 0.32OH + 0.06HO2 + + 0.26C_O2 + 0.51CO + 0.135CO2 + 0.5HCHO + + 0.5CCHO + 0.185HCOOH + 0.17CCO_OH + 0.07XC : 2.20D-10 ; +{221} C3H6 + NO3 = 0.949RO2_R + 0.051RO2_N + + 2.693XC + 1.0XN : 2.20D-10 ; +{222} C3H6 + O3P = 0.45RCHO + 0.55MEK + + 0.55XC : 2.20D-10 ; +{223} SO2 = H2SO4 : 2.20D-10 ; +{224} HO2 = PROD : 7.0D-7 ; +{225} SO2 = PROD : 2.20D-10 ; +{226} H2SO4 = PROD : 2.20D-10 ; +{227} HNO3 = PROD : 2.20D-10 ; +{228} H2O2 = PROD : 2.20D-10 ; +{229} CO2 = PROD : 7.0D-7 ; +{230} ALK4 + OH = ant1_c + ALK4 + OH : Keff(5.946D-12,91.0_dp,0.0_dp,TEMP,nume,den,0.011_dp,0.022_dp) ; +{231} ALK5 + OH = ant1_c + ALK5 + OH : Keff(1.112D-11,52.0_dp,0.0_dp,TEMP,nume,den,0.064_dp,0.128_dp) ; +{232} OLE1 + OH = ant1_c + OLE1 + OH : Keff(7.095D-12,-451.0_dp,0.0_dp,TEMP,nume,den,0.0002_dp,0.0012_dp) ; +{233} OLE2 + OH = ant1_c + OLE2 + OH : Keff(1.743D-11,-384.0_dp,0.0_dp,TEMP,nume,den,0.0009_dp,0.0073_dp) ; +{234} ARO1 + OH = ant1_c + ARO1 + OH : Keff(1.81D-12,-355.0_dp,0.0_dp,TEMP,nume,den,0.0322_dp,0.1447_dp) ; +{235} ARO2 + OH = ant1_c + ARO2 + OH : Keff2(2.640D-11,nume,den,0.0228_dp,0.1367_dp) ; +{236} ISOPRENE + OH = biog1_c + ISOPRENE + OH : Keff(2.50D-11,-408.0_dp,0.0_dp,TEMP,nume,den,0.0038_dp,0.0109_dp) ; +{237} ISOPRENE + O3 = biog1_c + ISOPRENE + O3 : Keff(7.86D-15,1912.0_dp,0.0_dp,TEMP,nume,den,0.0019_dp,0.0038_dp) ;) ; +{238} ISOPRENE + NO3 =0.0327biog1_c +ISOPRENE + NO3 : ARR(3.03D-12,448.0_dp,0.0_dp,TEMP) ; +{239} TERP + OH = biog1_c + TERP + OH : Keff(1.83D-11,-449.0_dp,0.0_dp,TEMP,nume,den,0.036_dp,0.2065_dp) ; +{240} TERP + O3 = biog1_c + TERP + O3 : Keff(1.08D-15,821.0_dp,0.0_dp,TEMP,nume,den,0.0109_dp,0.0545_dp) ; +{241} TERP + NO3 = 0.0545biog1_c + TERP + NO3 : ARR(3.66D-12,-175.0_dp,0.0_dp,TEMP) ; +{242} SESQ + OH = biog1_c + SESQ + OH : Keff2(6.80D-11,nume,den,0.6912_dp,0.3403_dp) ; +{243} SESQ + O3 = biog1_c + SESQ + O3 : Keff2(6.21D-17,nume,den,0.0163_dp,0.0816_dp) ; +{244} SESQ + NO3 = 0.0816biog1_c + SESQ + NO3 : 8.29D-12 ; +{245} PCG1_B_C + OH = PCG1_B_C + psd2 : 0.0D0; +{246} PCG1_B_O + OH = PCG1_B_O +OH+ psd2 : 0.0D0; +{247} OPCG1_B_C + OH = OPCG1_B_C + psd2 : 0.0D0; +{248} OPCG1_B_O + OH = OPCG1_B_O +OH+ psd2 : 0.0D0; +{249} PCG1_F_C + OH = PCG1_F_C + psd2 : 0.0D0; +{250} PCG1_F_O + OH = PCG1_F_O +OH + psd2 : 0.0D0; +{251} OPCG1_F_C + OH = OPCG1_F_C + psd2 : 0.0D0; +{252} OPCG1_F_O + OH = OPCG1_F_O +OH + psd2 : 0.0D0; +{253} PCG2_B_C + OH = OPCG1_B_C + 0.5OPCG1_B_O + psd2 : 0.5714D-11 ; +{254} PCG2_B_O + OH = OPCG1_B_O +OH + psd2 : 0.5714D-11 ; +{255} PCG2_F_C + OH = OPCG1_F_C + 0.5OPCG1_F_O + psd2 : 0.5714D-11 ; +{256} PCG2_F_O + OH = OPCG1_F_O +OH + psd2 : 0.5714D-11 ; + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.kpp b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.kpp new file mode 100644 index 00000000..7ac3b6fd --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.kpp @@ -0,0 +1,10 @@ +#MODEL saprc99_mosaic_8bin_vbs2_aq +#LANGUAGE Fortran90 +#DOUBLE ON +#INTEGRATOR WRF_conform/rosenbrock +#DRIVER general +#JACOBIAN SPARSE_LU_ROW +#HESSIAN OFF +#STOICMAT OFF +#WRFCONFORM + diff --git a/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.spc b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.spc new file mode 100755 index 00000000..ee154644 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq.spc @@ -0,0 +1,102 @@ +#DEFVAR + O3 = 3O; + H2O2 = 2H + 2O; + NO = N + O; + NO2 = N + 2O; + NO3 = N + 3O; + N2O5 = 2N + 5O; + HONO = H + 2O + N; + HNO3 = H + N + 3O; + HNO4 = H + N + 4O; + SO2 = S + 2O; + H2SO4 = 2H + S + 4O; + CO = C + O; + HCHO = 2H + C + O; + CCHO = 2C + H + O; + RCHO = 3C + IGNORE; + ACET = IGNORE; + MEK = IGNORE; + HCOOH = 2H + C + 2O; + MEOH = IGNORE; + ETOH = IGNORE; + CCO_OH = IGNORE; + RCO_OH = IGNORE; + GLY = IGNORE; + MGLY = 3C + 4H + 2O; + BACL = IGNORE; + CRES = IGNORE; + BALD = IGNORE; + ISOPROD = IGNORE; + METHACRO = IGNORE; + MVK = IGNORE; + PROD2 = IGNORE; + DCB1 = IGNORE; + DCB2 = IGNORE; + DCB3 = IGNORE; + ETHENE = 2C + 4H; + ISOPRENE = IGNORE; + C2H6 = 2C + 6H; + C3H8 = 3C + 8H; + C2H2 = 2C + 2H; + C3H6 = 3C + 6H; + ALK3 = IGNORE; + ALK4 = IGNORE; + ALK5 = IGNORE; + ARO1 = IGNORE; + ARO2 = IGNORE; + OLE1 = IGNORE; + OLE2 = IGNORE; + TERP = IGNORE; + SESQ = IGNORE; + RNO3 = IGNORE; + NPHE = IGNORE; + PHEN = IGNORE; + PAN = 2C + 3H + 5O + N; + PAN2 = N + IGNORE; + PBZN = N + IGNORE; + MA_PAN = N + IGNORE; + CO2 = C + 2O; + CCO_OOH = 2C + 3O + H; + RCO_O2 = IGNORE; + RCO_OOH = IGNORE; + XN = IGNORE; + XC = IGNORE; + O3P = O; + O1D = O; + OH = H + O; + HO2 = H+ 2O; + C_O2 = IGNORE; + COOH = C + 2O + H; + ROOH = IGNORE; + RO2_R = IGNORE; + R2O2 = IGNORE; + RO2_N = IGNORE; + HOCOO = H + 3O + C; + CCO_O2 = IGNORE; + BZCO_O2 = IGNORE; + BZNO2_O = IGNORE; + BZ_O = IGNORE; + MA_RCO3 = IGNORE; + TBU_O = IGNORE; + NUME = IGNORE; + DEN=IGNORE; + ANT1_c=IGNORE; + BIOG1_c=IGNORE; + PSD1=IGNORE; + PSD2=IGNORE; + PCG1_B_C = IGNORE; + PCG2_B_C = IGNORE; + PCG1_B_O = IGNORE; + PCG2_B_O = IGNORE; + OPCG1_B_C = IGNORE; + OPCG1_B_O = IGNORE; + PCG1_F_C = IGNORE; + PCG2_F_C = IGNORE; + PCG1_F_O = IGNORE; + PCG2_F_O = IGNORE; + OPCG1_F_C = IGNORE; + OPCG1_F_O = IGNORE; + CH4 = C + 4H; +#DEFFIX + H2O = 2H + O; + M = IGNORE; diff --git a/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq_wrfkpp.equiv b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq_wrfkpp.equiv new file mode 100644 index 00000000..d8932228 --- /dev/null +++ b/wrfv2_fire/chem/KPP/mechanisms/saprc99_mosaic_8bin_vbs2_aq/saprc99_mosaic_8bin_vbs2_aq_wrfkpp.equiv @@ -0,0 +1,9 @@ +! use this file for species that have different +! names in WRF and KPP +! +! currently case sensitive ! +! +! left column right column +! name in WRF name in KPP +HO OH + diff --git a/wrfv2_fire/chem/KPP/util/wkc/Makefile.tuv b/wrfv2_fire/chem/KPP/util/wkc/Makefile.tuv new file mode 100644 index 00000000..4cdfd6a3 --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/Makefile.tuv @@ -0,0 +1,15 @@ +.SUFFIXES: .c .o + +include ../../configure.kpp + +DEBUG = -g +OBJ = tuv_kpp.o + +tuv_kpp : $(OBJ) + $(SCC) -o tuv_kpp $(DEBUG) $(OBJ) + +.c.o : + $(SCC) -c $(DEBUG) $< + +clean: + /bin/rm -f $(OBJ) diff --git a/wrfv2_fire/chem/KPP/util/wkc/tuv_kpp.c b/wrfv2_fire/chem/KPP/util/wkc/tuv_kpp.c new file mode 100644 index 00000000..cd878c5d --- /dev/null +++ b/wrfv2_fire/chem/KPP/util/wkc/tuv_kpp.c @@ -0,0 +1,217 @@ +#include +#include +#include +#include +#include +#include +#include + +#define NAMELEN 132 +#define JLEN 32 + +typedef struct tuv_node_struct { + char name[NAMELEN]; + int ndx; + int dup; + struct tuv_node_struct *next; +} tuv_node; + +typedef struct wrf_node_struct { + char name[NAMELEN]; + int ndx; + struct wrf_node_struct *next; + struct tuv_node_struct *tuv_node; +} wrf_node; + +int tuv_match( wrf_node *head, char *match_name ); + +int main( int argc, char *argv[], char *env[] ) { + char fname_in[NAMELEN], dir[NAMELEN], fname_inc[NAMELEN]; + char inln[NAMELEN], outln[NAMELEN], piece[JLEN]; + char squezzed[NAMELEN]; + char *wrf_jname, *cwrk, *tuv_jspec, *token; + char *tuv_jname; + FILE * fp_in, *fp_set, *fp_def; + wrf_node *Wrf_node; + wrf_node *Wrf_HEAD; + tuv_node *Tuv_node, *Tuv_node_wrk; + + int l, m, n, nwrf, ntuv, nltuv; + int j_o2_ndx; + + char mech[NAMELEN]; + + strcpy( fname_in , "" ) ; + + argv++; + strcpy( mech,*argv ); + + fprintf(stderr,"tuv_kpp: Argument = %s\n",mech); +// open and write inc files + + if( !strcmp(mech,"LAST") ) + strcpy(fname_inc,"../../inc/tuv2wrf_jvals.inc"); + else + strcpy(fname_inc,"../../../../inc/tuv2wrf_jvals.inc"); + if( (fp_set = fopen( fname_inc,"a" )) == NULL ) { + fprintf(stderr,"Can not open %s\n",fname_inc ); + return(-1); + } + if( !strcmp(mech,"LAST") ) + strcpy(fname_inc,"../../inc/tuvdef_jvals.inc"); + else + strcpy(fname_inc,"../../../../inc/tuvdef_jvals.inc"); + if( (fp_def = fopen( fname_inc,"a" )) == NULL ) { + fprintf(stderr,"Can not open %s\n",fname_inc ); + return(-1); + } + + if( !strcmp(mech,"FIRST") ) { + fprintf(fp_set," select case( config_flags%%chem_opt )\n"); + fprintf(fp_def," select case( config_flags%%chem_opt )\n"); + } + else if( !strcmp(mech,"LAST") ) { + fprintf(fp_set," end select\n"); + fprintf(fp_def," end select\n"); + } + else { + fprintf(stderr,"tuv_kpp: Mechanism = %s\n",mech); + sprintf( fname_in,"%s.tuv.jmap",mech ); + if( (fp_in = fopen( fname_in,"r" )) == NULL ) { + fprintf(stderr,"File %s does not exist\n",fname_in ); + return(-1); + } + + Wrf_node = (wrf_node *)malloc( sizeof(wrf_node) ); + if( Wrf_node == NULL ) { + fprintf(stderr,"Failed to allocate Wrf_node\n"); + return(-1); + } + Wrf_HEAD = Wrf_node; + + nwrf = 0; ntuv = 0; + while( fgets( inln,NAMELEN,fp_in ) != NULL ) { + if( nwrf > 0 ) { + Wrf_node->next = (wrf_node *)malloc( sizeof(wrf_node) ); + if( Wrf_node == NULL ) { + fprintf(stderr,"Failed to allocate Wrf_node\n"); + return(-1); + } + Wrf_node = Wrf_node->next; + } +// remove white space from input line + l = 0; + for( m = 0; m < strlen( inln ); m++ ) { + if( inln[m] != ' ' ) + squezzed[l++] = inln[m]; + } + squezzed[l-1] = '\0'; + tuv_jspec = index( squezzed,':' ); + if( tuv_jspec == NULL ) { + fprintf(stderr,"Input j mapping is invalid\n"); + return(-1); + } + *tuv_jspec = '\0'; + tuv_jspec++; + strcpy( Wrf_node->name,squezzed ); + nwrf++; + Wrf_node->ndx = nwrf; + token = strtok( tuv_jspec,"+" ); + nltuv = 0; + for( ;; ) { + if( token != NULL ) { + Tuv_node_wrk = (tuv_node *)malloc( sizeof(tuv_node) ); + if( Tuv_node_wrk == NULL ) { + fprintf(stderr,"Failed to allocate Tuv_node\n"); + return(-1); + } + strcpy( Tuv_node_wrk->name,token ); + n = tuv_match( Wrf_HEAD, token ); + if( n == 0 ) { + ntuv++; + Tuv_node_wrk->ndx = ntuv; + } + else { + Tuv_node_wrk->dup = 1; + Tuv_node_wrk->ndx = n; + } + if( nltuv == 0 ) Wrf_node->tuv_node = Tuv_node_wrk; + else Tuv_node->next = Tuv_node_wrk; + Tuv_node = Tuv_node_wrk; + token = strtok( NULL,"+" ); + nltuv++; + } + else break; + } + } + + fclose( fp_in ); + +// enumerate the wrf jspecs + +// fprintf(stderr,"\n"); +// fprintf(stderr,"WRF photo rates\n"); +// for( Wrf_node = Wrf_HEAD; Wrf_node != NULL; Wrf_node = Wrf_node->next ) { +// fprintf(stderr,"%s\n",Wrf_node->name); +// } + +// enumerate the tuv jspecs + +// fprintf(stderr,"\n"); +// fprintf(stderr,"TUV photo rates\n"); +// for( Wrf_node = Wrf_HEAD; Wrf_node != NULL; Wrf_node = Wrf_node->next ) { +// for( Tuv_node = Wrf_node->tuv_node; Tuv_node != NULL; Tuv_node = Tuv_node->next ) { +// fprintf(stderr,"%s\n",Tuv_node->name); +// } +//} + +// write inc files + + fprintf(fp_set," case( %s_kpp )\n",mech); + fprintf(fp_def," case( %s_kpp )\n",mech); + n = 0; + j_o2_ndx = 0; + for( Wrf_node = Wrf_HEAD; Wrf_node != NULL; Wrf_node = Wrf_node->next ) { + sprintf(outln," ph_%s(i,kts:kte,j) = ",Wrf_node->name); + if( Wrf_node == Wrf_HEAD) { + fprintf(fp_def," nj = %d\n",ntuv); + fprintf(fp_def," allocate( tuv_jname(nj) )\n"); + } + nltuv = 0; + for( Tuv_node = Wrf_node->tuv_node; Tuv_node != NULL; Tuv_node = Tuv_node->next ) { + if( nltuv == 0 ) + sprintf(piece,"tuv_prate(kts:kte,%d)",Tuv_node->ndx); + else + sprintf(piece," + tuv_prate(kts:kte,%d)",Tuv_node->ndx); + strcat( outln,piece ); + nltuv++; + if( !Tuv_node->dup ) { + n++; + fprintf(fp_def," tuv_jname(%d) = '%s'\n",n,Tuv_node->name); + if( !strcmp( Tuv_node->name,"j_o2" ) ) + j_o2_ndx = n; + } + } + fprintf(fp_set,"%s\n",outln); + } + fprintf(fp_def," j_o2_ndx = %d\n",j_o2_ndx); + } + fclose( fp_set ); + fclose( fp_def ); + return(0); +} + +int tuv_match( wrf_node *head, char *match_name ) { + + wrf_node *wrfnode; + tuv_node *thisnode; + + for( wrfnode = head; wrfnode != NULL; wrfnode = wrfnode->next ) { + for( thisnode = wrfnode->tuv_node; thisnode != NULL; thisnode = thisnode->next ) { + if( !strcmp( thisnode->name,match_name ) ) + return( thisnode->ndx ); + } + } + + return( 0 ); +} diff --git a/wrfv2_fire/chem/Makefile b/wrfv2_fire/chem/Makefile index cdc7351d..a7c9220e 100755 --- a/wrfv2_fire/chem/Makefile +++ b/wrfv2_fire/chem/Makefile @@ -97,6 +97,15 @@ MODULES = \ module_mosaic_wetscav.o \ module_mosaic_therm.o \ module_phot_mad.o \ + params.mod.o \ + numer.o \ + rdxs.o \ + rxn.o \ + params_mod.o \ + module_phot_tuv.o \ + module_subs_tuv.o \ + rtrans.o \ + la_srb.o \ module_radm.o \ module_sorgam_aqchem.o \ module_sorgam_vbs_aqchem.o \ diff --git a/wrfv2_fire/chem/aerosol_driver.F b/wrfv2_fire/chem/aerosol_driver.F index c16c3300..18a2fa0b 100755 --- a/wrfv2_fire/chem/aerosol_driver.F +++ b/wrfv2_fire/chem/aerosol_driver.F @@ -492,7 +492,7 @@ SUBROUTINE sum_pm_driver ( config_flags, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (RACM_SOA_VBS_KPP) + CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) CALL wrf_debug(15,'sum_pm_driver: calling sum_pm_soa_vbs') CALL sum_pm_soa_vbs ( & alt, chem, h2oaj, h2oai, & @@ -523,7 +523,7 @@ SUBROUTINE sum_pm_driver ( config_flags, & its,ite, jts,jte, kts,kte ) CALL wrf_debug(15,'sum_pm_driver: calling sum_vbs2') - call sum_vbs2 ( & + call sum_vbs2 ( config_flags%aero_diag_opt, & alt, chem, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & hoa_a05,hoa_a06,hoa_a07,hoa_a08, & @@ -559,7 +559,7 @@ SUBROUTINE sum_pm_driver ( config_flags, & its,ite, jts,jte, kts,kte ) CALL wrf_debug(15,'sum_pm_driver: calling sum_vbs0') - call sum_vbs0 ( & + call sum_vbs0 ( config_flags%aero_diag_opt, & alt, chem, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & bboa_a01,bboa_a02,bboa_a03,bboa_a04, & @@ -587,7 +587,7 @@ SUBROUTINE sum_pm_driver ( config_flags, & its,ite, jts,jte, kts,kte ) CALL wrf_debug(15,'sum_pm_driver: calling sum_vbs4') - call sum_vbs4 ( & + call sum_vbs4 ( config_flags%aero_diag_opt, & alt, chem, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & soa_a01,soa_a02,soa_a03,soa_a04, & @@ -610,7 +610,7 @@ SUBROUTINE sum_pm_driver ( config_flags, & its,ite, jts,jte, kts,kte ) CALL wrf_debug(15,'sum_pm_driver: calling sum_vbs2') - call sum_vbs2 ( & + call sum_vbs2 ( config_flags%aero_diag_opt, & alt, chem, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & hoa_a05,hoa_a06,hoa_a07,hoa_a08, & @@ -637,6 +637,7 @@ SUBROUTINE sum_pm_driver ( config_flags, & + IF( config_flags%aero_cw_diag_opt == diag_cw_aero ) THEN CALL wrf_debug(15,'sum_pm_driver: calling sum_aq_vbs2') call sum_aq_vbs2 ( & alt, chem, & @@ -654,6 +655,7 @@ SUBROUTINE sum_pm_driver ( config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + ENDIF !BSINGH -ENDS CASE DEFAULT diff --git a/wrfv2_fire/chem/chem_driver.F b/wrfv2_fire/chem/chem_driver.F index 4a5b00f2..3dcd41ca 100755 --- a/wrfv2_fire/chem/chem_driver.F +++ b/wrfv2_fire/chem/chem_driver.F @@ -26,6 +26,7 @@ subroutine chem_driver ( grid , config_flags & USE module_dep_simple USE module_bioemi_simple USE module_phot_mad + USE module_phot_tuv, only : tuv_timestep_init USE module_ftuv_driver, only : ftuv_timestep_init USE module_aerosols_sorgam USE module_chem_utilities @@ -53,6 +54,7 @@ subroutine chem_driver ( grid , config_flags & pcnst =>pcnst_runtime, numgas_mam, cam_mam_aerosols USE module_cu_camzm_driver, only: zm_conv_tend_2 USE module_cam_mam_gas_wetdep_driver, only: cam_mam_gas_wetdep_driver + USE module_trajectory, only: trajectory_dchm_tstep_init, trajectory_dchm_tstep_set IMPLICIT NONE @@ -892,9 +894,10 @@ end SUBROUTINE sum_pm_driver call wrf_debug(15,'calling photolysis driver') call photolysis_driver (grid%id,curr_secs,ktau,grid%dt, & config_flags,haveaer, & + grid%dt_cld,grid%af_dir,grid%af_dn,grid%af_up,grid%ph_par,grid%ph_erythema, & grid%gmt,ijulian,t_phy,moist,grid%aerwrf,p8w,t8w,p_phy, & chem,rho,dz8w,grid%xlat,grid%xlong, & - z_at_w, & + zmid,z_at_w, & grid%qc_cu,grid%qi_cu, & grid%ph_macr,grid%ph_o31d,grid%ph_o33p,grid%ph_no2,grid%ph_no3o2, & grid%ph_no3o,grid%ph_hno2,grid%ph_hno3,grid%ph_hno4,grid%ph_h2o2, & @@ -1133,7 +1136,9 @@ end SUBROUTINE sum_pm_driver ! Calculate rate of n2o5 hydrolysis call wrf_debug(15,'calling calc_het_n2o5') - + write(msg,'(''chem_driver('',i2.2,''): Calling dchm_tstep_init'')') grid%id + call wrf_debug( 200,trim(msg) ) + call trajectory_dchm_tstep_init( grid, do_chemstep ) ! ! For the chemistry tracer mode, only emissions and vertical mixing are done. @@ -1224,6 +1229,10 @@ end SUBROUTINE sum_pm_driver ! chem(its:ite,kts:kte,jts:jte,p_h2o2)=vch2o2_old(its:ite,kts:kte,jts:jte) endif + write(msg,'(''chem_driver('',i2.2,''): Calling dchm_tstep_set'')') grid%id + call wrf_debug( 200,trim(msg) ) + call trajectory_dchm_tstep_set( grid ) + IF(config_flags%conv_tr_aqchem == 0 ) THEN so2so4_selecta: SELECT CASE(config_flags%chem_opt) CASE (RADM2SORG,RADM2SORG_KPP,RACMSORG_KPP,RACM_SOA_VBS_KPP) diff --git a/wrfv2_fire/chem/chemics_init.F b/wrfv2_fire/chem/chemics_init.F index 90f10502..9131ee43 100755 --- a/wrfv2_fire/chem/chemics_init.F +++ b/wrfv2_fire/chem/chemics_init.F @@ -33,6 +33,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, USE module_phot_mad USE module_ftuv_driver, only : ftuv_init + USE module_phot_tuv, only : tuv_init USE module_mozcart_wetscav, only : wetscav_mozcart_init USE module_aerosols_sorgam USE module_aerosols_soa_vbs, only: aerosols_soa_vbs_init @@ -142,12 +143,12 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, #ifdef CHEM_DBG_I call print_chem_species_index( config_flags%chem_opt ) #endif - program_name = "* PROGRAM:WRF/CHEM " // TRIM(release_version) // " MODEL" + program_name = "* PROGRAM:WRF-Chem " // TRIM(release_version) // " MODEL" call wrf_message("*********************************************************************") call wrf_message(program_name) call wrf_message("* *") -call wrf_message("* PLEASE REPORT ANY BUGS TO WRF/CHEM HELP at *") +call wrf_message("* PLEASE REPORT ANY BUGS TO WRF-Chem HELP at *") call wrf_message("* *") call wrf_message("* wrfchemhelp.gsd@noaa.gov *") call wrf_message("* *") @@ -217,12 +218,10 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, CALL wrf_debug(15,'calling RACM/MADE/SORGAM with AQCHEM chemistry from chem_driver') call wrf_message("WARNING: RACM_ESRLSORG_AQCHEM_KPP chemistry option is highly experimental and not recommended for use.") ! call wrf_error_fatal("ERROR: experimental option selected, please contact wrfchemhelp for assistance") -!!! TUCCELLA CASE (RACM_SOA_VBS_AQCHEM_KPP ) numgas_mam = numgas CALL wrf_debug(15,'calling RACM/MADE/SOA-VBS with AQCHEM chemistry from chem_driver') - call wrf_message("WARNING: RACM_SOA_VBS_AQCHEM_KPP chemistry option is highly experimental and not recommended for use.") -! call wrf_error_fatal("ERROR: experimental option selected, please contact wrfchemhelp for assistance") +! call wrf_message("WARNING: RACM_SOA_VBS_AQCHEM_KPP chemistry option is highly experimental and not recommended for use.") CASE (CO2_TRACER, GHG_TRACER ) call wrf_message("WARNING: Users interested in the GHG options should check the comments/references in header of module_ghg_fluxes") CASE (CBMZ_CAM_MAM3_NOAQ) @@ -280,6 +279,18 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts ) endif +!----------------------------------------------------------------------- +! Check TUV photolysis for chem_opt compatability +!----------------------------------------------------------------------- + if (config_flags%phot_opt == TUV ) then + if (config_flags%chem_opt /= mozart_mosaic_4bin_kpp .and. & + config_flags%chem_opt /= mozart_mosaic_4bin_aq_kpp .and. & + config_flags%chem_opt /= mozcart_kpp ) THEN + write(message_txt,'(''--- ERROR: chem_opt '',a,'' not setup for TUV photolysis at this time'')') & + config_flags%chem_opt + CALL wrf_error_fatal( trim(message_txt) ) + endif + endif !!! TUCCELLA if ( config_flags%wetscav_onoff == 1 ) then @@ -305,9 +316,9 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_error_fatal("ERROR: wet scavenging option requires mp_phys = 2 (Lin et al.) or 10 (Morrison) or 11 (CAMMGMP) or 17/18/22 NSSL_2mom to function.") endif elseif( id == 1 ) then - if ( config_flags%mp_physics /= 8 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 17 & + if ( config_flags%mp_physics /= 6 .and. config_flags%mp_physics /= 8 .and. config_flags%mp_physics /= 10 .and. config_flags%mp_physics /= 17 & .and. config_flags%mp_physics /= 18 .and. config_flags%mp_physics /= 22) then - call wrf_error_fatal("ERROR: wet scavenging option for MOZART,MOZCART requires mp_phys = 8 (Thompson) or 10 (Morrison) .or 17/18/22 (NSSL 2-moment) to function.") + call wrf_error_fatal("ERROR: wet scavenging option for MOZART,MOZCART requires mp_phys = 6 (WSM6) or 8 (Thompson) or 10 (Morrison) .or 17/18/22 (NSSL 2-moment) to function.") else write(message_txt,*) 'chem_init: calling wetscav_mozcart_init for domain ',id call wrf_message( trim(message_txt) ) @@ -336,6 +347,21 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif endif + !BSINGH - kfcup schme only works with Mosaic aqueoue packages: + ! *** NOTE *** + ! KFCUP should in theory work with any chem_opt package that uses MOSAIC and has cloud-borne aerosols (*_aq*). + ! However, it was only tested with chem_opt=203 (saprc99_mosaic_8bin_vbs2_aq_kpp) + ! during implementation into WRF-Chem in April 2017 at PNNL. + if ( config_flags%cu_physics == 10) then + if( config_flags%chem_opt /= 9 .and. config_flags%chem_opt /= 10 .and. & + config_flags%chem_opt /= 32 .and. config_flags%chem_opt /= 34 .and. & + config_flags%chem_opt /= 202 .and. config_flags%chem_opt /= 203 .and. & + config_flags%chem_opt /= 601 .and. config_flags%chem_opt /= 611 ) then + call wrf_error_fatal("ERROR: kfcupscheme requires chem_opt = 9, 10, 32, 34, 202, 203, 601 or 611 to function.") + endif + endif + + if ( config_flags%cu_physics == 5 .OR. config_flags%cu_physics == 3) then if ( config_flags%cu_diag == 0) then call wrf_message(" No time averaged variables. Time averaged chem variables requires cu_diag = 1") @@ -353,8 +379,23 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call wrf_error_fatal("ERROR: chem_conv_tr=1 requires cu_diag=1") endif + if ( config_flags%cu_physics == 10 .and. config_flags%kfcup_diag == 0) then + call wrf_error_fatal("ERROR: cu_physics == 10 requires kfcup_diag == 1") + endif + + if ( config_flags%chem_conv_tr == 0 .and. config_flags%kfcup_diag == 1) then + call wrf_error_fatal("ERROR: kfcup_diag == 1 requires chem_conv_tr == 1") + endif + + if ( config_flags%cu_physics /= 10 .and. config_flags%kfcup_diag == 1) then + call wrf_error_fatal("ERROR: kfcup_diag == 1 requires cu_physics == 10") + endif + + if ( config_flags%bio_emiss_opt .EQ. 3 .AND. config_flags%ne_area .LT. num_chem ) then - call wrf_error_fatal("ERROR: MEGAN biogenics requires ne_area to be equal or greater than num_chem") + write(message_txt,'(''ERROR: MEGAN biogenics requires ne_area('',i6,'') >= num_chem('',i6,'')'')') config_flags%ne_area,num_chem +! call wrf_error_fatal("ERROR: MEGAN biogenics requires ne_area to be equal or greater than num_chem") + call wrf_error_fatal( trim(message_txt) ) endif IF ( config_flags%chem_opt == 0 .AND. config_flags%aer_ra_feedback .NE. 0 ) THEN @@ -594,6 +635,20 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, call ftuv_init( id, its, ite, jts, jte, kte, & ide, jde, config_flags,config_flags%num_land_cat,mminlu_loc ) + CASE (TUV) + if( config_flags%cld_od_opt > 3 .or. config_flags%cld_od_opt < 1 ) then + call wrf_error_fatal("cld_od_opt must be {1,2,3}") + endif + if( config_flags%pht_cldfrc_opt > 2 .or. config_flags%pht_cldfrc_opt < 1 ) then + call wrf_error_fatal("pht_cldfrc_opt must be {1,2}") + endif + write(message_txt,'(''chemics_init('',i2.2,''): call tuv phot initialization'')') id + CALL wrf_debug( 0,trim(message_txt) ) + call tuv_init( id, config_flags, z_at_w, aerwrf, g, & + grid%af_lambda_start, grid%af_lambda_end,grid%lambda_cutoff,& + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) !--- END SELECT phot_select @@ -1717,7 +1772,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif chem(its:ite,kts:min(kte,kde-1),jts:jte,:)=max(chem(its:ite,kts:min(kte,kde-1),jts:jte,:),epsilc) ! - CASE (RACM_SOA_VBS_AQCHEM_KPP,CB05_SORG_VBS_AQ_KPP) + CASE (CB05_SORG_VBS_AQ_KPP) CALL wrf_debug(15,'call MADE/SOA_VBS aerosols initialization') call aerosols_sorgam_vbs_init(chem,convfac,z_at_w, & @@ -1744,7 +1799,7 @@ subroutine chem_init (id,chem,emis_ant,scalar,dt,bioemdt,photdt,chemdt,stepbioe, endif chem(its:ite,kts:min(kte,kde-1),jts:jte,:)=max(chem(its:ite,kts:min(kte,kde-1),jts:jte,:),epsilc) - CASE (RACM_SOA_VBS_KPP) + CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) CALL wrf_debug(15,'call MADE/SOA_VBS aerosols initialization') call aerosols_soa_vbs_init(chem,convfac,z_at_w, & @@ -3313,7 +3368,7 @@ subroutine print_chem_species_index( chem_opt ) print*,p_ac0,"ac0" print*,p_corn,"corn" !!! TUCCELLA -case (RACM_SOA_VBS_AQCHEM_KPP) + case (RACM_SOA_VBS_AQCHEM_KPP) print*,p_so4aj,"so4aj" print*,p_so4ai,"so4ai" print*,p_nh4aj,"nh4aj" diff --git a/wrfv2_fire/chem/cloudchem_driver.F b/wrfv2_fire/chem/cloudchem_driver.F index 0b216818..d3116bf2 100644 --- a/wrfv2_fire/chem/cloudchem_driver.F +++ b/wrfv2_fire/chem/cloudchem_driver.F @@ -249,7 +249,7 @@ SUBROUTINE cloudchem_driver( & CASE ( RADM2SORG_AQCHEM, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, & - CB05_SORG_AQ_KPP ) + CB05_SORG_AQ_KPP,RACM_SOA_VBS_AQCHEM_KPP ) call wrf_debug(15, & 'cloudchem_driver calling sorgam_aqchem_driver') diff --git a/wrfv2_fire/chem/depend.chem b/wrfv2_fire/chem/depend.chem index 71d9b206..d1a43a93 100644 --- a/wrfv2_fire/chem/depend.chem +++ b/wrfv2_fire/chem/depend.chem @@ -103,6 +103,22 @@ module_cb05_initmixrats.o: module_input_chem_data.o module_cb05_vbs_initmixrats.o: module_input_chem_data.o +params.mod.o: + +numer.o: + +rdxs.o: params.mod.o numer.o + +rxn.o: params.mod.o numer.o rdxs.o + +rtrans.o: params_mod.o + +la_srb.o: params_mod.o + +module_subs_tuv.o: params_mod.o la_srb.o rtrans.o + +module_phot_tuv.o: params_mod.o module_subs_tuv.o la_srb.o rxn.o rdxs.o + module_phot_mad.o: module_data_radm2.o module_phot_fastj.o: module_mosaic_driver.o module_peg_util.o module_data_cbmz.o @@ -258,13 +274,13 @@ module_aer_drydep.o: module_data_sorgam.o module_aerosols_sorgam.o module_aeroso module_interpolate.o: -chemics_init.o: module_cbm4_initmixrats.o module_cbmz_initmixrats.o module_gocart_aerosols.o ../phys/module_data_gocart_dust.o module_data_gocart_seas.o module_data_gocartchem.o module_gocart_chem.o module_dep_simple.o module_ftuv_driver.o module_phot_mad.o module_gocart_chem.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_aerosols_soa_vbs.o module_mixactivate_wrappers.o module_mosaic_driver.o module_input_chem_data.o module_cam_mam_init.o module_cam_mam_wetscav.o module_prep_wetscav_sorgam.o module_aerosols_sorgam_vbs.o +chemics_init.o: module_cbm4_initmixrats.o module_cbmz_initmixrats.o module_gocart_aerosols.o ../phys/module_data_gocart_dust.o module_data_gocart_seas.o module_data_gocartchem.o module_gocart_chem.o module_dep_simple.o module_ftuv_driver.o module_phot_mad.o module_gocart_chem.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_aerosols_soa_vbs.o module_mixactivate_wrappers.o module_mosaic_driver.o module_input_chem_data.o module_cam_mam_init.o module_cam_mam_wetscav.o module_prep_wetscav_sorgam.o module_aerosols_sorgam_vbs.o module_phot_tuv.o module_tropopause.o: module_interpolate.o module_upper_bc_driver.o: module_tropopause.o -chem_driver.o: module_radm.o ../dyn_em/module_convtrans_prep.o module_chem_utilities.o module_data_radm2.o module_dep_simple.o module_bioemi_simple.o module_vertmx_wrf.o module_phot_mad.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_aerosols_sorgam_vbs.o module_data_cbmz.o module_cbmz.o module_wetscav_driver.o dry_dep_driver.o emissions_driver.o module_input_tracer.o module_input_tracer_data.o module_tropopause.o module_upper_bc_driver.o module_ctrans_grell.o module_data_soa_vbs.o module_aer_opt_out.o module_data_sorgam.o module_gocart_so2so4.o ../phys/module_cu_camzm_driver.o module_cam_mam_gas_wetdep_driver.o module_dust_load.o module_chem_cup.o +chem_driver.o: module_radm.o ../dyn_em/module_convtrans_prep.o module_chem_utilities.o module_data_radm2.o module_dep_simple.o module_bioemi_simple.o module_vertmx_wrf.o module_phot_mad.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_aerosols_sorgam_vbs.o module_data_cbmz.o module_cbmz.o module_wetscav_driver.o dry_dep_driver.o emissions_driver.o module_input_tracer.o module_input_tracer_data.o module_tropopause.o module_upper_bc_driver.o module_ctrans_grell.o module_data_soa_vbs.o module_aer_opt_out.o module_data_sorgam.o module_gocart_so2so4.o ../phys/module_cu_camzm_driver.o module_cam_mam_gas_wetdep_driver.o module_dust_load.o module_chem_cup.o ../share/module_trajectory.o aerosol_driver.o: module_data_sorgam.o module_aerosols_sorgam.o module_data_soa_vbs.o module_aerosols_soa_vbs.o module_aerosols_sorgam_vbs.o module_mosaic_driver.o @@ -274,7 +290,7 @@ module_sorgam_vbs_aqchem.o: module_ctrans_aqchem.o module_data_sorgam_vbs.o cloudchem_driver.o: module_mosaic_cloudchem.o module_sorgam_cloudchem.o module_sorgam_vbs_cloudchem.o module_sorgam_vbs_aqchem.o -photolysis_driver.o: module_phot_mad.o module_phot_fastj.o module_ftuv_driver.o +photolysis_driver.o: module_phot_mad.o module_phot_fastj.o module_ftuv_driver.o module_phot_tuv.o mechanism_driver.o: module_data_radm2.o module_radm.o module_aerosols_sorgam.o module_aerosols_soa_vbs.o module_data_cbmz.o module_cbmz.o diff --git a/wrfv2_fire/chem/dry_dep_driver.F b/wrfv2_fire/chem/dry_dep_driver.F index f496ec6a..f0d974b7 100755 --- a/wrfv2_fire/chem/dry_dep_driver.F +++ b/wrfv2_fire/chem/dry_dep_driver.F @@ -1064,7 +1064,7 @@ subroutine dry_dep_driver(id,curr_secs,ktau,dtstep,config_flags, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) - CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) + CASE (RACM_SOA_VBS_AQCHEM_KPP) CALL wrf_debug(15,'call mixactivate for soa-vbs aerosol') call soa_vbs_mixactivate ( & id, ktau, dtstep, config_flags, idrydep_onoff, & diff --git a/wrfv2_fire/chem/emissions_driver.F b/wrfv2_fire/chem/emissions_driver.F old mode 100755 new mode 100644 index 1ee719f8..bbba9778 --- a/wrfv2_fire/chem/emissions_driver.F +++ b/wrfv2_fire/chem/emissions_driver.F @@ -391,18 +391,18 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ! volcanic emissions ! - ashz_above_vent=emiss_ash_height + z_at_w(i,kts,j) + ashz_above_vent=emiss_ash_height - z_at_w(i,kts,j) write(message,'("Found and adjusted active volcano at j,kts,kpe = ",3i8)') j,kts,kte call wrf_message (message) ! write(0,*)emiss_ash_height,emiss_ash_mass,ashz_above_vent do k=kte-1,kts,-1 - if(z_at_w(i,k,j) < ashz_above_vent)then + if(z_at_w(i,k,j) < emiss_ash_height)then k_final=k+1 exit endif enddo do k=kte-1,kts,-1 - if(z_at_w(i,k,j) < (1.-base_umbrel)*ashz_above_vent)then + if(z_at_w(i,k,j) < ((1.-base_umbrel)*ashz_above_vent)+z_at_w(i,kts,j))then k_initial=k exit endif @@ -814,7 +814,6 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) endif -!!! TUCCELLA CASE (BEIS314) if( do_bioemiss ) then beis314_check_mechanism_ok: SELECT CASE(config_flags%chem_opt) @@ -889,7 +888,6 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & !!! **************** END BIOGENICS, ADD EMISSIONS FOR VARIOUS PACKAGES ! -!!! TUCCELLA gas_addemiss_select: SELECT CASE(config_flags%chem_opt) CASE (RADM2, RADM2_KPP, RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP, & RACM_KPP, RACMPM_KPP, RACM_MIM_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP, & @@ -973,9 +971,21 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) call wrf_debug(15,'emissions_driver calling cb05_addemiss_bio') - ! Do NOT call add_biogenics if using MEGAN v2.04 biogenic emissions - ! module - if ( config_flags%bio_emiss_opt .ne. megan2 ) then + ! fixed a bug related to CB05 MEGAN mapping by KW 03/20/2017 + if (config_flags%bio_emiss_opt .ne. 0 .and. & + config_flags%bio_emiss_opt .ne. GUNTHER1) then + call add_biogenics(id,dtstep,dz8w,config_flags, rho_phy,chem, & + e_bio,ne_area, & + ebio_iso,ebio_oli,ebio_api,ebio_lim,ebio_xyl, & + ebio_hc3,ebio_ete,ebio_olt,ebio_ket,ebio_ald, & + ebio_hcho,ebio_eth,ebio_ora2,ebio_co,ebio_nr,ebio_no, & + ebio_sesq,ebio_mbo, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif + + if ( config_flags%bio_emiss_opt .eq. GUNTHER1 ) then call cb05_addemiss_bio( id, dtstep, dz8w, config_flags, & rho_phy, chem, e_bio, ne_area, emis_ant(ims,kms,jms,p_e_iso),& ids,ide, jds,jde, kds,kde, & @@ -1481,7 +1491,6 @@ subroutine emissions_driver(id,ktau,dtstep,DX, & its,ite, jts,jte, kts,kte ) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -!!! TUCCELLA CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) call wrf_debug(15,'emissions_driver calling soa_vbs_addemiss') call soa_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, & diff --git a/wrfv2_fire/chem/la_srb.F b/wrfv2_fire/chem/la_srb.F new file mode 100644 index 00000000..89f8b436 --- /dev/null +++ b/wrfv2_fire/chem/la_srb.F @@ -0,0 +1,533 @@ +!============================================================================= +! This file contains the following subroutines, related to the calculation +! of radiation at Lyman-alpha and Schumann-Runge wavelengths: +! la_srb +! lymana +! schum +! effxs +! calc_params +! init_xs +! sjo2 +! and the following functions +! chebev +!============================================================================= + + module SRB + + implicit none + + private + public :: la_srb, sjo2, init_srb + public :: nchebev_term, nchebev_wave + public :: chebev_ac, chebev_bc + public :: ila, isrb + + INTEGER, parameter :: kla = 2 + INTEGER, PARAMETER :: ksrb = 18 + integer, parameter :: nla = kla - 1 + integer, parameter :: nsrb = ksrb - 1 + + integer :: nchebev_term, nchebev_wave + + integer :: ila, isrb + REAL(8) :: b(3), c(3), d(3), e(3) + REAL(8), allocatable :: chebev_ac(:,:) + REAL(8), allocatable :: chebev_bc(:,:) + + REAL :: xslod(nsrb) + REAL :: wlsrb(ksrb) + REAL :: wlla(kla) + + CONTAINS + + SUBROUTINE init_srb + + b(:) = (/ 6.8431e-01_8, 2.29841e-01_8, 8.65412e-02_8 /) + c(:) = (/ 8.22114e-21_8, 1.77556e-20_8, 8.22112e-21_8 /) + d(:) = (/ 6.0073e-21_8, 4.28569e-21_8, 1.28059e-20_8 /) + e(:) = (/ 8.21666e-21_8, 1.63296e-20_8, 4.85121e-17_8 /) + xslod(:) = (/6.2180730E-21, 5.8473627E-22, 5.6996334E-22, & + 4.5627094E-22, 1.7668250E-22, 1.1178808E-22, & + 1.2040544E-22, 4.0994668E-23, 1.8450616E-23, & + 1.5639540E-23, 8.7961075E-24, 7.6475608E-24, & + 7.6260556E-24, 7.5565696E-24, 7.6334338E-24, & + 7.4371992E-24, 7.3642966E-24 /) + wlla(:) = (/ 121.4, 121.9/) + wlsrb(:) = (/174.4, 177.0, 178.6, 180.2, 181.8, & + 183.5, 185.2, 186.9, 188.7, 190.5, & + 192.3, 194.2, 196.1, 198.0, 200.0, & + 202.0, 204.1, 205.8/) + + END SUBROUTINE init_srb + + SUBROUTINE la_srb( nlyr, z, tlev, wmin, & + vcol, scol, o2_xs, dto2, srb_o2_xs ) +!----------------------------------------------------------------------------- +!= PURPOSE: +!= Compute equivalent optical depths for O2 absorption, and O2 effective +!= absorption cross sections, parameterized in the Lyman-alpha and SR bands +!----------------------------------------------------------------------------- +!= PARAMETERS: +!= NZ - INTEGER, number of specified altitude levels in the working (I) +!= grid +!= Z - REAL, specified altitude working grid (km) (I) +!= NW - INTEGER, number of specified intervals + 1 in working (I) +!= wavelength grid +!= WL - REAL, vector of lxower limits of wavelength intervals in (I) +!= working wavelength grid +!= CZ - REAL, number of air molecules per cm^2 at each specified (I) +!= altitude layer +!= ZEN - REAL, solar zenith angle (I) +!= +!= O2XS1 - REAL, O2 cross section from rdo2xs (I) +!= +!= DTO2 - REAL, optical depth due to O2 absorption at each specified (O) +!= vertical layer at each specified wavelength +!= O2XS - REAL, molecular absorption cross section in SR bands at (O) +!= each specified altitude and wavelength. Includes Herzberg +!= continuum. +!----------------------------------------------------------------------------- + + use params_mod, only : o2vmr, largest + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + INTEGER, intent(in) :: nlyr + REAL, intent(in) :: wmin + REAL, intent(in) :: z(:) + REAL, intent(in) :: tlev(:) + + REAL, intent(in) :: vcol(:) + REAL, intent(in) :: scol(:) + REAL, intent(in) :: o2_xs(:) + REAL, intent(inout) :: dto2(:,:) + REAL, intent(inout) :: srb_o2_xs(:,:) + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + REAL :: secchi(nlyr) + REAL :: o2col(nlyr) + +!----------------------------------------------------------------------------- +! Lyman-alpha variables +! O2 optical depth and equivalent cross section in the Lyman-alpha region +!----------------------------------------------------------------------------- + INTEGER :: nlev + INTEGER :: nlev_srb + INTEGER :: k, iw, wn + REAL :: dto2la(nlyr,nla), o2xsla(nlyr,nla) + +!----------------------------------------------------------------------------- +! grid on which Koppers' parameterization is defined +! O2 optical depth and equivalent cross section on Koppers' grid +!----------------------------------------------------------------------------- + REAL :: dto2k(nlyr,nsrb), o2xsk(nlyr,nsrb) + + nlev_srb = size( srb_o2_xs,dim=2 ) + nlev = nlyr +!---------------------------------------------------------------------- +! initalize O2 cross sections +!---------------------------------------------------------------------- + DO k = 1, nlev_srb + srb_o2_xs(:,k) = o2_xs(:) + END DO + + IF( wmin <= wlsrb(nsrb) ) THEN +!---------------------------------------------------------------------- +! Slant O2 column and x-sections. +!---------------------------------------------------------------------- + o2col(:nlyr) = o2vmr * scol(:nlyr) +!---------------------------------------------------------------------- +! Effective secant of solar zenith angle. +! Use 2.0 if no direct sun (value for isotropic radiation) +! For nz, use value at nz-1 +!---------------------------------------------------------------------- + WHERE( scol(:nlyr) > .1*largest ) + secchi(:nlyr) = 2. + ELSEWHERE + secchi(:nlyr) = scol(:nlyr)/vcol(:nlyr) + ENDWHERE + +!--------------------------------------------------------------------- +! Lyman-Alpha parameterization, output values of O2 optical depth +! and O2 effective (equivalent) cross section +!---------------------------------------------------------------------- + CALL lymana( nlyr, o2col, secchi, dto2la, o2xsla ) + DO wn = ila, ila + nla - 1 + iw = wn - ila + 1 + dto2(:nlyr,wn) = dto2la(:nlyr,iw) + srb_o2_xs(wn,:nlev_srb) = o2xsla(2:nlev_srb+1,iw) + ENDDO + +!------------------------------------------------------------------------------ +! Koppers' parameterization of the SR bands, output values of O2 +! optical depth and O2 equivalent cross section +!------------------------------------------------------------------------------ + CALL schum( nlyr, o2col, tlev, secchi, dto2k, o2xsk ) + DO wn = isrb, isrb + nsrb - 1 + iw = wn - isrb + 1 + dto2(:nlyr,wn) = dto2k(:nlyr,iw) + srb_o2_xs(wn,:nlev_srb) = o2xsk(2:nlev_srb+1,iw) + ENDDO + ENDIF + + END SUBROUTINE la_srb + + SUBROUTINE lymana( nlyr, o2col, secchi, dto2la, o2xsla ) +!----------------------------------------------------------------------------- +!= PURPOSE: +!= Calculate the effective absorption cross section of O2 in the Lyman-Alpha +!= bands and an effective O2 optical depth at all altitudes. Parameterized +!= after: Chabrillat, S., and G. Kockarts, Simple parameterization of the +!= absorption of the solar Lyman-Alpha line, Geophysical Research Letters, +!= Vol.24, No.21, pp 2659-2662, 1997. +!----------------------------------------------------------------------------- +!= PARAMETERS: +!= NZ - INTEGER, number of specified altitude levels in the working (I) +!= grid +!= O2COL - REAL, slant overhead O2 column (molec/cc) at each specified (I) +!= altitude +!= DTO2LA - REAL, optical depth due to O2 absorption at each specified (O) +!= vertical layer +!= O2XSLA - REAL, molecular absorption cross section in LA bands (O) +!----------------------------------------------------------------------------- + + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + INTEGER, intent(in) :: nlyr + REAL, intent(in) :: o2col(:) + REAL, intent(in) :: secchi(:) + REAL, intent(inout) :: dto2la(nlyr,nla), o2xsla(nlyr,nla) + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + REAL, parameter :: xsmin = 1.e-20 + REAL(8), parameter :: rmmin = 1.e-100_8 + + INTEGER :: k, kp1, wn + REAL(8) :: o2_col + REAL(8) :: rm(nlyr), ro2(nlyr) + REAL(8) :: rm_wrk(3), ro2_wrk(3) + + do wn = 1,nla + dto2la(:nlyr,wn) = 0. + o2xsla(:nlyr,wn) = 0. + end do +!----------------------------------------------------------------------------- +! calculate reduction factors at every layer +!----------------------------------------------------------------------------- + rm(:nlyr) = 0._8 + ro2(:nlyr) = 0._8 + DO k = 1, nlyr + o2_col = real( o2col(k),8 ) + rm_wrk(:) = b(:) * EXP( -c(:) * o2_col ) + ro2_wrk(:) = d(:) * EXP( -e(:) * o2_col ) + rm(k) = sum( rm_wrk ) + ro2(k) = sum( ro2_wrk ) + ENDDO + +!----------------------------------------------------------------------------- +! calculate effective O2 optical depths and effective O2 cross sections +!----------------------------------------------------------------------------- + DO k = 1, nlyr-1 + kp1 = k + 1 + IF (rm(k) > rmmin) THEN + IF (ro2(k) > rmmin) THEN + o2xsla(k,1) = REAL( ro2(k)/rm(k) ) + ELSE + o2xsla(k,1) = xsmin + ENDIF + + IF (rm(kp1) > 0._8) THEN + dto2la(k,1) = LOG( rm(kp1) )/secchi(kp1) & + - LOG( rm(k)) /secchi(k) + ELSE + dto2la(k,1) = 1000. + ENDIF + ELSE + dto2la(k,1) = 1000. + o2xsla(k,1) = xsmin + ENDIF + END DO + +!----------------------------------------------------------------------------- +! do top layer separately +!----------------------------------------------------------------------------- + IF( rm(nlyr) > rmmin ) THEN + o2xsla(nlyr,1) = REAL( ro2(nlyr)/rm(nlyr) ) + ELSE + o2xsla(nlyr,1) = xsmin + ENDIF + + END SUBROUTINE lymana + + SUBROUTINE schum( nlyr, o2col, tlev, secchi, dto2, o2xsk ) +!----------------------------------------------------------------------------- +!= PURPOSE: +!= Calculate the equivalent absorption cross section of O2 in the SR bands. +!= The algorithm is based on parameterization of G.A. Koppers, and +!= D.P. Murtagh [ref. Ann.Geophys., 14 68-79, 1996] +!= Final values do include effects from the Herzberg continuum. +!----------------------------------------------------------------------------- +!= PARAMETERS: +!= NZ - INTEGER, number of specified altitude levels in the working (I) +!= grid +!= O2COL - REAL, slant overhead O2 column (molec/cc) at each specified (I) +!= altitude +!= TLEV - tmeperature at each level +!= SECCHI - ratio of slant to vertical o2 columns +!= DTO2 - REAL, optical depth due to O2 absorption at each specified +!= vertical layer at each specified wavelength +!= O2XSK - REAL, molecular absorption cross section in SR bands at +!= each specified wavelength. Includes Herzberg continuum +!----------------------------------------------------------------------------- + + use params_mod, only : precis + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + INTEGER, intent(in) :: nlyr + REAL, intent(in) :: o2col(:) + REAL, intent(in) :: tlev(:), secchi(:) + REAL, intent(inout) :: dto2(nlyr,nsrb), o2xsk(nlyr,nsrb) + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + REAL, parameter :: o2col_min = exp( 38. ) + + INTEGER :: wn, k, ktop, ktop1, kbot, nlyrm1 + REAL :: x + REAL :: o2col1(nlyr) + REAL :: xs(nsrb) + + nlyrm1 = nlyr - 1 +!----------------------------------------------------------------------------- +! ...Initialize cross sections to values at large optical depth +!----------------------------------------------------------------------------- + DO wn = 1, nsrb + o2xsk(:nlyr,wn) = xslod(wn) + END DO + +!----------------------------------------------------------------------------- +! Calculate cross sections +! Set smallest O2col = exp(38.) molec cm-2 +! to stay in range of parameterization +! given by Koppers et al. at top of atm. +!----------------------------------------------------------------------------- + ktop = 2*nlyr + kbot = 0 + + DO k = 1,nlyr + o2col1(k) = MAX( o2col(k),o2col_min ) + x = LOG( o2col1(k) ) + IF (x < 38.0) THEN + ktop1 = k-1 + ktop = MIN(ktop1,ktop) + ELSE IF (x > 56.0) THEN + kbot = k + ELSE + CALL effxs( x, tlev(k), xs ) + o2xsk(k,:nsrb) = xs(:nsrb) + ENDIF + END DO + +!----------------------------------------------------------------------------- +! fill in cross section where X is out of range by repeating edge table values +! Do not allow kbot = nlyr to avoid division by zero in no light case. +!----------------------------------------------------------------------------- + IF( kbot == nlyr) then + kbot = nlyrm1 + ENDIF + + IF( kbot > 0 ) THEN + DO wn = 1,nsrb + o2xsk(:kbot,wn) = o2xsk(kbot+1,wn) + END DO + ENDIF + + IF( ktop < nlyr ) THEN + DO wn = 1,nsrb + o2xsk(ktop+1:nlyr,wn) = o2xsk(ktop,wn) + END DO + ENDIF + +!----------------------------------------------------------------------------- +! Calculate incremental optical depths +!----------------------------------------------------------------------------- + dto2(nlyr,1:nsrb) = 0.0 ! set optical depth to zero at top + DO wn = 1,nsrb +!----------------------------------------------------------------------------- +! ... calculate an optical depth weighted by density, +! put in mean value estimate, if in shade +!----------------------------------------------------------------------------- + WHERE (ABS(1. - o2col1(2:nlyr)/o2col1(:nlyrm1)) <= 2.*precis) + dto2(:nlyrm1,wn) = o2xsk(2:nlyr,wn)*o2col1(2:nlyr)/real(nlyrm1) + ELSEWHERE + dto2(:nlyr-1,wn) = ABS( & + (o2xsk(2:nlyr,wn)*o2col1(2:nlyr) - o2xsk(:nlyrm1,wn)*o2col1(:nlyrm1)) & + /(1. + LOG(o2xsk(2:nlyr,wn)/o2xsk(:nlyrm1,wn)) & + / LOG(o2col1(2:nlyr)/o2col1(:nlyrm1))) ) +!----------------------------------------------------------------------------- +! ... change to vertical optical depth +!----------------------------------------------------------------------------- + dto2(:nlyrm1,wn) = 2. * dto2(:nlyrm1,wn)/(secchi(:nlyr-1)+secchi(2:nlyr)) + ENDWHERE + END DO + + END SUBROUTINE schum + + SUBROUTINE EFFXS( x, t, xs ) +!----------------------------------------------------------------------------- +! Subroutine for evaluating the effective cross section +! of O2 in the Schumann-Runge bands using parameterization +! of G.A. Koppers, and D.P. Murtagh [ref. Ann.Geophys., 14 +! 68-79, 1996] +! +! method: +! ln(xs) = A(X)[T-220]+B(X) +! X = log of slant column of O2 +! A,B calculated from Chebyshev polynomial coeffs +! AC and BC using NR routine chebev. Assume interval +! is 38 0.) THEN + chebev = 0.0 + ELSE + d = 0. + dd = 0. + y = (2.*x - a - b)/(b - a) + y2 = 2.*y + DO J = m,2,-1 + sv = d + d = y2*d - dd + real( c(J),4 ) + dd = sv + END DO + chebev = y*d - dd + 0.5*real( c(1),4 ) + ENDIF + + END FUNCTION chebev + + SUBROUTINE sjo2( nlyr, nwave, xso2, xsqy ) +!----------------------------------------------------------------------------- +!= PURPOSE: +!= Update the weighting function (cross section x quantum yield) for O2 +!= photolysis. The strong spectral variations in the O2 cross sections are +!= parameterized into a few bands for Lyman-alpha (121.4-121.9 nm, one band) +!= and Schumann-Runge (174.4-205.8, nsrb bands) regions. The parameterizations +!= depend on the overhead O2 column, and therefore on altitude and solar +!= zenith angle, so they need to be updated at each time/zenith step. +!----------------------------------------------------------------------------- +!= PARAMETERS: +!= NZ - INTEGER, number of altitude levels in working altitude grid (I) +!= NW - INTEGER, number of specified intervals + 1 in working (I) +!= wavelength grid +!= XSO2 - REAL, molecular absorption cross section in SR bands at (I) +!= each specified altitude and wavelength. Includes Herzberg +!= continuum. +!= NJ - INTEGER, index of O2 photolysis in array SQ (I) +!= xsqy - REAL, cross section x quantum yield (cm^2) for each (O) +!= photolysis reaction, at each wavelength and each altitude level +!----------------------------------------------------------------------------- + + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + INTEGER, intent(in) :: nlyr, nwave + REAL, intent(in) :: xso2(:,:) + REAL, intent(inout) :: xsqy(:,:) + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + INTEGER :: k + +!----------------------------------------------------------------------------- +! O2 + hv -> O + O +! quantum yield assumed to be unity +! assign cross section values at all wavelengths and at all altitudes +! qy = 1. +!----------------------------------------------------------------------------- + DO k = 1, nlyr + xsqy(:nwave,k) = xso2(:nwave,k) + END DO + + END SUBROUTINE sjo2 + + end module SRB diff --git a/wrfv2_fire/chem/module_add_emis_cptec.F b/wrfv2_fire/chem/module_add_emis_cptec.F index 997ff028..90443f63 100644 --- a/wrfv2_fire/chem/module_add_emis_cptec.F +++ b/wrfv2_fire/chem/module_add_emis_cptec.F @@ -85,7 +85,7 @@ subroutine add_emis_cptec(id,dtstep,ktau,dz8w,config_flags, & tign = real(idays)*24.*3600. ! Modulacao da queimada media durante o ciclo diurno(unidade: 1/s) ! com a int( r_q dt) (0 - 24h)= 1. - timeq= ( time + float(itime1)*0.01*3600. - tign ) + timeq= ( time + float(itime1)*3600. - tign ) timeq=mod(timeq,86400.) diff --git a/wrfv2_fire/chem/module_add_emiss_burn.F b/wrfv2_fire/chem/module_add_emiss_burn.F index c2365711..67c8dea3 100644 --- a/wrfv2_fire/chem/module_add_emiss_burn.F +++ b/wrfv2_fire/chem/module_add_emiss_burn.F @@ -160,7 +160,7 @@ subroutine add_emis_burn(id,dtstep,ktau,dz8w,rho_phy,chem, & enddo enddo enddo - CASE (RADM2SORG,RACMSORG_KPP, RADM2SORG_KPP, RACM_ESRLSORG_KPP, RACM_SOA_VBS_KPP, & + CASE (RADM2SORG,RACMSORG_KPP, RADM2SORG_KPP, RACM_ESRLSORG_KPP, RACM_SOA_VBS_KPP, RACM_SOA_VBS_AQCHEM_KPP, & RADM2SORG_AQ, RADM2SORG_AQCHEM, RACMSORG_AQ, RACMSORG_AQCHEM_KPP,RACM_ESRLSORG_AQCHEM_KPP) do j=jts,jte do i=its,ite diff --git a/wrfv2_fire/chem/module_aerosols_soa_vbs.F b/wrfv2_fire/chem/module_aerosols_soa_vbs.F index 5b31c763..78f9cff8 100644 --- a/wrfv2_fire/chem/module_aerosols_soa_vbs.F +++ b/wrfv2_fire/chem/module_aerosols_soa_vbs.F @@ -6751,14 +6751,10 @@ SUBROUTINE soa_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) end if - if( seasalt_emiss_active == 2 ) then -! call Monahan_seasalt_emiss( & -! dtstep, u10, v10, alt, dz8w, xland, chem, & -! ids,ide, jds,jde, kds,kde, & -! ims,ime, jms,jme, kms,kme, & -! its,ite, jts,jte, kts,kte ) - end if + ! if( seasalt_emiss_active == 2 ) then + ! end if if( dust_opt == 2 ) then + call wrf_message("WARNING: You are calling DUSTRAN dust emission scheme with MOSAIC, which is highly experimental and not recommended for use. Please use dust_opt==13") call soa_vbs_dust_emiss( & slai, ust, smois, ivgtyp, isltyp, & id, dtstep, u10, v10, alt, dz8w, & @@ -6767,7 +6763,9 @@ SUBROUTINE soa_vbs_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, chem, ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) end if - if( dust_opt == 3 ) then + ! dust_opt changed to 13 since it conflicts with gocart/afwa + if( dust_opt == 13 ) then + !czhao -------------------------- call soa_vbs_dust_gocartemis( & ktau,dtstep,num_soil_layers,alt,u_phy, & v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, & @@ -7350,7 +7348,7 @@ subroutine soa_vbs_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & jdustcon = sum(bems(1:5))*accfrac/airmas ! kg/kg-dryair jdustcon = jdustcon * converi ! ug/kg-dryair - chem(i,k,j,p_p25)=chem(i,k,j,p_p25j) + jdustcon + chem(i,k,j,p_p25j)=chem(i,k,j,p_p25j) + jdustcon chem(i,k,j,p_soila)=chem(i,k,j,p_soila) + cdustcon ! czhao doing dust number emission following pm10 diff --git a/wrfv2_fire/chem/module_aerosols_sorgam.F b/wrfv2_fire/chem/module_aerosols_sorgam.F index 03ce44df..c58ddcde 100644 --- a/wrfv2_fire/chem/module_aerosols_sorgam.F +++ b/wrfv2_fire/chem/module_aerosols_sorgam.F @@ -8042,6 +8042,10 @@ SUBROUTINE sorgam_addemiss( & ! its,ite, jts,jte, kts,kte ) end if if( dust_opt == 2 ) then + !czhao+++++++++++++++++++++++++++ + call wrf_message("WARNING: You are calling DUSTRAN dust emission scheme with MOSAIC, which is highly experimental and not recommended for use. Please use dust_opt==13") + !czhao--------------------------- + call sorgam_dust_emiss( & slai, ust, smois, ivgtyp, isltyp, & id, dtstep, u10, v10, alt, dz8w, & @@ -8050,8 +8054,10 @@ SUBROUTINE sorgam_addemiss( & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) end if -! dust_opt changed to 5 since it conflicts with gocart/afwa - if( dust_opt == 5 ) then + !czhao ++++++++++++++++++++++++++ +! dust_opt changed to 13 since it conflicts with gocart/afwa + if( dust_opt == 13 ) then + !czhao -------------------------- call sorgam_dust_gocartemis( & ktau,dtstep,num_soil_layers,alt,u_phy, & v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, & diff --git a/wrfv2_fire/chem/module_bioemi_megan2.F b/wrfv2_fire/chem/module_bioemi_megan2.F index 50d7ef27..ea38ad50 100644 --- a/wrfv2_fire/chem/module_bioemi_megan2.F +++ b/wrfv2_fire/chem/module_bioemi_megan2.F @@ -268,10 +268,6 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & !...Some light-dependent factor (dimensionless) REAL :: ldf - !...conversion factor to convert emissions rates in - !...mol km-2 hr-1 to concentrations in ppm - REAL :: emis2ppm - !...conversion factor from mol km-2 hr-1 to ppm m min-1 REAL :: convert2 @@ -769,14 +765,6 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ! the gas-phase mechanism species - !...conversion factor to convert emissions rates in - !...mol km-2 hr-1 to concentrations in ppm - ! 0.02897 kg/mol is molecular of air - ! rho_phy is air density in kg air/m3 - ! dz8w is layer height in meters - ! dtstep is time step in seconds - emis2ppm = 0.02897*dtstep/(rho_phy(i,kts,j)*dz8w(i,kts,j)*3600.) - !...conversion factor from mol km-2 hr-1 to ppm m min-1 !...(e_bio is in units of ppm m min-1) convert2 = 0.02897/(rho_phy(i,kts,j)*60.) @@ -1137,7 +1125,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & END DO - CASE (RACM_SOA_VBS_AQCHEM_KPP,CB05_SORG_AQ_KPP) + CASE (CB05_SORG_AQ_KPP) DO icount = 1, n_megan2cb05 IF ( p_of_cb05 (icount) .NE. non_react ) THEN @@ -1154,29 +1142,6 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ! Emission rate for mechanism species in mol km-2 hr-1 gas_emis = cb05_per_megan(icount) * E_megan2(p_of_megan2cb05(icount)) - ! Increase gas-phase concentrations (in ppmv) due to - ! biogenic emissions - chem(i,kts,j,p_in_chem) = chem(i,kts,j,p_in_chem) + gas_emis*emis2ppm - - IF ( p_in_chem .EQ. p_apin ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - IF ( p_in_chem .EQ. p_bpin ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - IF ( p_in_chem .EQ. p_hum ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - IF ( p_in_chem .EQ. p_lim ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - IF ( p_in_chem .EQ. p_oci ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - IF ( p_in_chem .EQ. p_ter ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - ! Add emissions to diagnostic output variables. ! ebio_xxx (mol km-2 hr-1) were originally used by the ! BEIS3.11 biogenic emissions module. @@ -1198,10 +1163,10 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & END IF IF ( p_in_chem .EQ. p_apin ) THEN ebio_api(i,j) = ebio_api(i,j) + gas_emis - e_bio(i,j,p_apin-1) = e_bio(i,j,p_apin-1) + gas_emis*convert2 + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_bpin ) THEN - e_bio(i,j,p_bpin-1) = e_bio(i,j,p_bpin-1) + gas_emis*convert2 + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_ch4 ) THEN e_bio(i,j,p_ch4-1) = e_bio(i,j,p_ch4-1) + gas_emis*convert2 @@ -1227,14 +1192,14 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & e_bio(i,j,p_form-1) = e_bio(i,j,p_form-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_hum ) THEN - e_bio(i,j,p_hum-1) = e_bio(i,j,p_hum-1) + gas_emis*convert2 + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_iole ) THEN e_bio(i,j,p_iole-1) = e_bio(i,j,p_iole-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_lim ) THEN ebio_lim(i,j) = ebio_lim(i,j) + gas_emis - e_bio(i,j,p_lim-1) = e_bio(i,j,p_lim-1) + gas_emis*convert2 + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_meoh ) THEN e_bio(i,j,p_meoh-1) = e_bio(i,j,p_meoh-1) + gas_emis*convert2 @@ -1247,7 +1212,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & e_bio(i,j,p_no-1) = e_bio(i,j,p_no-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_oci ) THEN - e_bio(i,j,p_oci-1) = e_bio(i,j,p_oci-1) + gas_emis*convert2 + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_ole ) THEN e_bio(i,j,p_ole-1) = e_bio(i,j,p_ole-1) + gas_emis*convert2 @@ -1259,6 +1224,10 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ebio_terp(i,j) = ebio_terp(i,j) + gas_emis e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF + IF ( p_in_chem .EQ. p_ter ) THEN + ebio_terp(i,j) = ebio_terp(i,j) + gas_emis + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 + END IF IF ( p_in_chem .EQ. p_tol ) THEN e_bio(i,j,p_tol-1) = e_bio(i,j,p_tol-1) + gas_emis*convert2 END IF @@ -1285,29 +1254,6 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ! Emission rate for mechanism species in mol km-2 hr-1 gas_emis = cb05vbs_per_megan(icount) * E_megan2(p_of_megan2cb05vbs(icount)) - ! Increase gas-phase concentrations (in ppmv) due to - ! biogenic emissions - chem(i,kts,j,p_in_chem) = chem(i,kts,j,p_in_chem) + gas_emis*emis2ppm - - IF ( p_in_chem .EQ. p_apin ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - IF ( p_in_chem .EQ. p_bpin ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - IF ( p_in_chem .EQ. p_hum ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - IF ( p_in_chem .EQ. p_lim ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - IF ( p_in_chem .EQ. p_oci ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - IF ( p_in_chem .EQ. p_ter ) THEN - chem(i,kts,j,p_terp) = chem(i,kts,j,p_terp) + gas_emis*emis2ppm - END IF - ! Add emissions to diagnostic output variables. ! ebio_xxx (mol km-2 hr-1) were originally used by the ! BEIS3.11 biogenic emissions module. @@ -1329,10 +1275,10 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & END IF IF ( p_in_chem .EQ. p_apin ) THEN ebio_api(i,j) = ebio_api(i,j) + gas_emis - e_bio(i,j,p_apin-1) = e_bio(i,j,p_apin-1) + gas_emis*convert2 + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_bpin ) THEN - e_bio(i,j,p_bpin-1) = e_bio(i,j,p_bpin-1) + gas_emis*convert2 + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_ch4 ) THEN e_bio(i,j,p_ch4-1) = e_bio(i,j,p_ch4-1) + gas_emis*convert2 @@ -1358,14 +1304,14 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & e_bio(i,j,p_form-1) = e_bio(i,j,p_form-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_hum ) THEN - e_bio(i,j,p_hum-1) = e_bio(i,j,p_hum-1) + gas_emis*convert2 + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_iole ) THEN e_bio(i,j,p_iole-1) = e_bio(i,j,p_iole-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_lim ) THEN ebio_lim(i,j) = ebio_lim(i,j) + gas_emis - e_bio(i,j,p_lim-1) = e_bio(i,j,p_lim-1) + gas_emis*convert2 + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_meoh ) THEN e_bio(i,j,p_meoh-1) = e_bio(i,j,p_meoh-1) + gas_emis*convert2 @@ -1378,7 +1324,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & e_bio(i,j,p_no-1) = e_bio(i,j,p_no-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_oci ) THEN - e_bio(i,j,p_oci-1) = e_bio(i,j,p_oci-1) + gas_emis*convert2 + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF IF ( p_in_chem .EQ. p_ole ) THEN e_bio(i,j,p_ole-1) = e_bio(i,j,p_ole-1) + gas_emis*convert2 @@ -1390,6 +1336,10 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & ebio_terp(i,j) = ebio_terp(i,j) + gas_emis e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 END IF + IF ( p_in_chem .EQ. p_ter ) THEN + ebio_terp(i,j) = ebio_terp(i,j) + gas_emis + e_bio(i,j,p_terp-1) = e_bio(i,j,p_terp-1) + gas_emis*convert2 + END IF IF ( p_in_chem .EQ. p_tol ) THEN e_bio(i,j,p_tol-1) = e_bio(i,j,p_tol-1) + gas_emis*convert2 END IF @@ -1400,7 +1350,7 @@ SUBROUTINE bio_emissions_megan2(id,config_flags,ktau,dtstep, & END DO - CASE (RACM_SOA_VBS_KPP) + CASE (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP) DO icount = 1, n_megan2racmSOA diff --git a/wrfv2_fire/chem/module_cam_mam_newnuc.F b/wrfv2_fire/chem/module_cam_mam_newnuc.F index e869e6a7..12c3f664 100644 --- a/wrfv2_fire/chem/module_cam_mam_newnuc.F +++ b/wrfv2_fire/chem/module_cam_mam_newnuc.F @@ -643,7 +643,7 @@ subroutine mer07_veh02_nuc_mosaic_1box( & ! rates at tropospheric conditions, ! j. geophys. res., 112, d15207, doi:10.1029/2006jd0027977 ! -! vehkamäki, h., m. kulmala, i. napari, k.e.j. lehtinen, +! vehkamaki, h., m. kulmala, i. napari, k.e.j. lehtinen, ! c. timmreck, m. noppel and a. laaksonen, 2002, ! an improved parameterization for sulfuric acid-water nucleation ! rates for tropospheric and stratospheric conditions, @@ -1261,7 +1261,7 @@ subroutine binary_nuc_vehk2002( temp, rh, so4vol, & ! ! calculates binary nucleation rate and critical cluster size ! using the parameterization in -! vehkamäki, h., m. kulmala, i. napari, k.e.j. lehtinen, +! vehkamaki, h., m. kulmala, i. napari, k.e.j. lehtinen, ! c. timmreck, m. noppel and a. laaksonen, 2002, ! an improved parameterization for sulfuric acid-water nucleation ! rates for tropospheric and stratospheric conditions, diff --git a/wrfv2_fire/chem/module_chem_cup.F b/wrfv2_fire/chem/module_chem_cup.F index 2de7926e..3012ae18 100644 --- a/wrfv2_fire/chem/module_chem_cup.F +++ b/wrfv2_fire/chem/module_chem_cup.F @@ -12,6 +12,14 @@ ! EXPRESS OR IMPLIED, OR ASSUMES ANY LIABILITY FOR THE USE OF THIS SOFTWARE. ! ! MOSAIC module: see module_mosaic_driver.F for references and terms of use + +! *** NOTE *** +! This module should in theory work with any chem_opt package that uses MOSAIC +!and has cloud-borne aerosols. However, it was only tested with chem_opt=203 +!(saprc99_mosaic_8bin_vbs2_aq_kpp) during implementation into WRF-Chem in +!April 2017 at PNNL. + + !********************************************************************************** ! file module_chem_cup.F diff --git a/wrfv2_fire/chem/module_gocart_dmsemis.F b/wrfv2_fire/chem/module_gocart_dmsemis.F index d9305121..eb92a6f4 100644 --- a/wrfv2_fire/chem/module_gocart_dmsemis.F +++ b/wrfv2_fire/chem/module_gocart_dmsemis.F @@ -60,7 +60,7 @@ subroutine gocart_dmsemis(dt,config_flags,alt,t_phy,u_phy, & do j=jts,jte do i=its,ite ! -! donṫ do this over land +! don't do this over land ! if(xland(i,j).gt.1.5)then ilwi(1,1)=0 @@ -73,7 +73,7 @@ subroutine gocart_dmsemis(dt,config_flags,alt,t_phy,u_phy, & dxy(1)=dx*dx tskin(1,1)=tsk(i,j) ! -! we donṫ trust the u10,v10 values, is model layers are very thin near surface +! we don't trust the u10,v10 values, is model layers are very thin near surface ! if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) diff --git a/wrfv2_fire/chem/module_gocart_dust.F b/wrfv2_fire/chem/module_gocart_dust.F index 0d09bfc4..51386002 100644 --- a/wrfv2_fire/chem/module_gocart_dust.F +++ b/wrfv2_fire/chem/module_gocart_dust.F @@ -299,8 +299,8 @@ SUBROUTINE source_du( imx,jmx,lmx,nmx, dt1, tc, & IF (dsrc < 0.0) dsrc = 0.0 ! Update dust mixing ratio at first model level. - tc(i,j,1,n) = tc(i,j,1,n) + .2*dsrc / airmas(i,j,1) - bems(i,j,n) = .2*dsrc + tc(i,j,1,n) = tc(i,j,1,n) + dsrc / airmas(i,j,1) + bems(i,j,n) = dsrc END DO END DO END DO diff --git a/wrfv2_fire/chem/module_gocart_seasalt.F b/wrfv2_fire/chem/module_gocart_seasalt.F index 0a4fc037..ea4508fc 100644 --- a/wrfv2_fire/chem/module_gocart_seasalt.F +++ b/wrfv2_fire/chem/module_gocart_seasalt.F @@ -63,7 +63,7 @@ subroutine gocart_seasalt_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u_p do j=jts,jte do i=its,ite ! -! donṫ do dust over water!!! +! don't do dust over water!!! ! if(xland(i,j).gt.1.5.and.z_at_w(i,kts,j).lt.1.e-3)then ilwi(1,1)=0 @@ -78,7 +78,7 @@ subroutine gocart_seasalt_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u_p w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g ! -! we donṫ trust the u10,v10 values, is model layers are very thin near surface +! we don't trust the u10,v10 values, is model layers are very thin near surface ! if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) ! diff --git a/wrfv2_fire/chem/module_mosaic_addemiss.F b/wrfv2_fire/chem/module_mosaic_addemiss.F index ac52cb28..874bdcde 100644 --- a/wrfv2_fire/chem/module_mosaic_addemiss.F +++ b/wrfv2_fire/chem/module_mosaic_addemiss.F @@ -157,6 +157,14 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & ! (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.933, 0.067 /) ! as of apr-2005 ! (/ 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, 0.16, 0.84 /) ! "old" +!++ SAN Fractionation for PREP-Chem Fire emissions ++! +! New fractions for biomass burning emissions. Based on Janhall et. al. (2010) +! Based on average fresh smoke emissions from 20 data points +! mean_Dp = .117um, geometric_std = 1.7 +real, save :: fr8b_bburn_mosaic(8) = & + (/ 0.0092, 0.1385, 0.4548, 0.3388, 0.0567, 0.002, 0.0, 0.0/) +!--SAN + ! fraction of TNO black carbon <1um emissions that go into each of ! the mosaic 8 "standard" sections - Doug (4/3/2011) @@ -207,22 +215,28 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & real :: fr_tno_oc_tra(8) real :: fr_tno_mosaic_f(8) real :: fr_tno_mosaic_c(8) +!++ SAN + real :: fr_aem_gc2mosaic_f(8) ! extra arrays for GOCART->MOSAIC mapping + real :: fr_aem_gc2mosaic_c(8) + real :: bburn_mosaic_f(8) ! Arrays to hold biomass-burning size + real :: bburn_mosaic_c(8) ! Arrays to hold biomass-burning size +!-- SAN double precision :: chem_sum(num_chem) - character*80 msg + character(len=80) :: msg ! *** currently only works with ntype_aer = 1 - itype = 1 - iphase = ai_phase + itype = 1 + iphase = ai_phase - if (num_ebu.le.0 ) then - print*,'no biomass burning species',num_ebu - stop - endif +! if (num_ebu.le.0 ) then +! call wrf_error_fatal( 'mosaic_addemiss: no biomass burning species' ) +! print*,'no biomass burning species',num_ebu +! stop +! endif -! ! compute factors used for apportioning either ! the MADE-SORGAM emissions (i=aitken, j=accum, c=coarse modes) OR ! the MOSAIC emission (f=fine (< 2.5 um), c=coarse (> 2.5 um)) @@ -240,25 +254,26 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & ! ! note: if fr_aem_sorgam_y > 0, then fr_aem_mosaic_y = 0, and vice-versa ! - if ((nsize_aer(itype) .ne. 4) .and. (nsize_aer(itype) .ne. 8)) then - write(msg,'(a,i5)') & - 'subr mosaic_addemiss - nsize_aer(itype) must be ' // & - '4 or 8 but = ', & - nsize_aer(itype) - call wrf_error_fatal( msg ) - end if - - fr_aem_sorgam_i(:) = 0.0 - fr_aem_sorgam_j(:) = 0.0 - fr_aem_sorgam_c(:) = 0.0 - fr_aem_mosaic_f(:) = 0.0 - fr_aem_mosaic_c(:) = 0.0 - fr_tno_bc1(:) = 0.0 - fr_tno_ec25(:) = 0.0 - fr_tno_oc_dom(:) = 0.0 - fr_tno_oc_tra(:) = 0.0 - fr_tno_mosaic_f(:) = 0.0 - fr_tno_mosaic_c(:) = 0.0 + if ((nsize_aer(itype) .ne. 4) .and. (nsize_aer(itype) .ne. 8)) then + write(msg,'(a,i5)') & + 'subr mosaic_addemiss - nsize_aer(itype) must be ' // & + '4 or 8 but = ', nsize_aer(itype) + call wrf_error_fatal( msg ) + end if + + fr_aem_sorgam_i(:) = 0.0 + fr_aem_sorgam_j(:) = 0.0 + fr_aem_sorgam_c(:) = 0.0 + fr_aem_mosaic_f(:) = 0.0 + fr_aem_mosaic_c(:) = 0.0 + fr_tno_bc1(:) = 0.0 + fr_tno_ec25(:) = 0.0 + fr_tno_oc_dom(:) = 0.0 + fr_tno_oc_tra(:) = 0.0 + fr_tno_mosaic_f(:) = 0.0 + fr_tno_mosaic_c(:) = 0.0 + fr_aem_gc2mosaic_f(:) = 0.0 + fr_aem_gc2mosaic_c(:) = 0.0 emiss_inpt_select_1: SELECT CASE( config_flags%emiss_inpt_opt ) @@ -278,7 +293,34 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & end do end if - CASE( emiss_inpt_pnnl_cm ) +!++ SAN, 2015-04-09 +! Added mapping routine from GOCART aerosol emission variables to MOSAIC +! This will be the case if emissions were prepared using PREP-Chem in RAMD2-GOCART mode. +! (Use with emiss_opt = 5/6, ECPTEC/GOCART_ECPTEC, emiss_inpt_opt == emiss_inpt_default) +!!! Maybe more consistant to add a new emiss_inpt_opt, but this requires more extensive changes +!!! and testing in other parts of WRF-Chem, may cause confusion... Thoughts? + + if( config_flags%emiss_opt == 5 .or. config_flags%emiss_opt == 6 ) then + CALL wrf_debug(15,'mosaic_addemiss: emiss_opt = eptec') + CALL wrf_debug(15,'mosaic_addemiss: gocart speciation being mapped to mosaic') + + fr_aem_sorgam_i(:) = 0.0 + fr_aem_sorgam_j(:) = 0.0 + fr_aem_sorgam_c(:) = 0.0 + +! Use FM MOSAIC mapping for SO4, OC, BC and PM2.5, CM mosaic for PM10 + if (nsize_aer(itype) .eq. 8) then + fr_aem_gc2mosaic_f(:) = fr8b_aem_mosaic_f(:) + fr_aem_gc2mosaic_c(:) = fr8b_aem_mosaic_c(:) + elseif (nsize_aer(itype) .eq. 4) then + do n = 1, nsize_aer(itype) + fr_aem_gc2mosaic_f(n) = fr8b_aem_mosaic_f(2*n-1) + fr8b_aem_mosaic_f(2*n) + fr_aem_gc2mosaic_c(n) = fr8b_aem_mosaic_c(2*n-1) + fr8b_aem_mosaic_c(2*n) + end do + endif + endif +!-- SAN + CASE( emiss_inpt_pnnl_cm ) if (nsize_aer(itype) .eq. 8) then fr_aem_mosaic_f(:) = fr8b_aem_mosaic_f(:) fr_aem_mosaic_c(:) = fr8b_aem_mosaic_c(:) @@ -321,9 +363,28 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & END SELECT emiss_inpt_select_1 +!++ SAN 2015-04-09: Mapping fire emissions to MOSAIC +! get arrays for apportioning mass into MOSAIC bins for fire emissions + fire_inpt_select: SELECT CASE (config_flags%biomass_burn_opt) + CASE (BIOMASSB,BIOMASSB_MOZC) + if (nsize_aer(itype) .eq. 8) then + bburn_mosaic_f(:) = fr8b_bburn_mosaic(:) +!++SAN + bburn_mosaic_c(:) = fr8b_aem_mosaic_c(:) +!--SAN + else if (nsize_aer(itype) .eq. 4) then + do n = 1, nsize_aer(itype) + bburn_mosaic_f(n) = fr8b_bburn_mosaic(2*n-1) + fr8b_bburn_mosaic(2*n) +!++SAN + bburn_mosaic_c(n) = fr8b_aem_mosaic_c(2*n-1) + fr8b_aem_mosaic_c(2*n) +!--SAN + end do + end if + END SELECT fire_inpt_select + ! when mosaic_addemiss_active <= 0, set fr's to zero, ! which causes the changes to chem(...) to be zero - if (mosaic_addemiss_active <= 0.and.biom_active.le.0) then + if (mosaic_addemiss_active <= 0 .and. biom_active <= 0) then fr_aem_sorgam_i(:) = 0.0 fr_aem_sorgam_j(:) = 0.0 fr_aem_sorgam_c(:) = 0.0 @@ -370,26 +431,28 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & do 1820 k = 1, min(config_flags%kemit,kte) do 1810 i = its, ite -! compute mass emissions [(ug/m3)*m/s] for each species +! compute anthropogenic mass emissions [(ug/m3)*m/s] for each species ! using the apportioning fractions -! czhao add biomass burning emissions here for MOSAIC aerosols - aem_so4 = fr_aem_mosaic_f(n)*(emis_ant(i,k,j,p_e_so4j)+ebu(i,k,j,p_ebu_sulf)) & - + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_so4c) & - + fr_aem_sorgam_i(n)*(emis_ant(i,k,j,p_e_so4i)+0.25*ebu(i,k,j,p_ebu_sulf)) & - + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_so4j)+0.75*ebu(i,k,j,p_ebu_sulf)) + aem_so4 = fr_aem_mosaic_f(n)*emis_ant(i,k,j,p_e_so4j) & + + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_so4c) & + + fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_so4i) & + + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_so4j) aem_no3 = fr_aem_mosaic_f(n)*emis_ant(i,k,j,p_e_no3j) & + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_no3c) & + fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_no3i) & + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_no3j) - aem_oc = fr_aem_mosaic_f(n)*(emis_ant(i,k,j,p_e_orgj)+ebu(i,k,j,p_ebu_oc)) & + aem_oc = fr_aem_mosaic_f(n)*emis_ant(i,k,j,p_e_orgj) & + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_orgc) & - + fr_aem_sorgam_i(n)*(emis_ant(i,k,j,p_e_orgi)+0.25*ebu(i,k,j,p_ebu_oc)) & - + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_orgj)+0.75*ebu(i,k,j,p_ebu_oc)) & + + fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_orgi) & + + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_orgj) & + fr_tno_oc_dom(n)*emis_ant(i,k,j,p_e_oc_dom) & + fr_tno_oc_tra(n)*emis_ant(i,k,j,p_e_oc_tra) & - + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_oc_25_10) + + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_oc_25_10) & +!++SAN + + fr_aem_gc2mosaic_f(n)*emis_ant(i,k,j,p_e_oc) +!--SAN chem_select_1 : SELECT CASE( config_flags%chem_opt ) CASE(SAPRC99_MOSAIC_4BIN_VBS2_KPP, SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP, & @@ -397,20 +460,30 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & aem_oc = 0.0 END SELECT chem_select_1 - aem_bc = fr_aem_mosaic_f(n)*(emis_ant(i,k,j,p_e_ecj)+ebu(i,k,j,p_ebu_bc)) & - + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_ecc) & - + fr_aem_sorgam_i(n)*(emis_ant(i,k,j,p_e_eci)+0.25*ebu(i,k,j,p_ebu_bc)) & - + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_ecj)+0.75*ebu(i,k,j,p_ebu_bc)) & - + fr_tno_bc1(n)*emis_ant(i,k,j,p_e_bc_1) & - + fr_tno_ec25(n)*emis_ant(i,k,j,p_e_ec_1_25) & - + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_ec_25_10) - - aem_oin = fr_aem_mosaic_f(n)*(emis_ant(i,k,j,p_e_pm25j)+ebu(i,k,j,p_ebu_pm25)) & + aem_bc = fr_aem_mosaic_f(n)*emis_ant(i,k,j,p_e_ecj) & + + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_ecc) & + + fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_eci) & + + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_ecj) & + + fr_tno_bc1(n)*emis_ant(i,k,j,p_e_bc_1) & + + fr_tno_ec25(n)*emis_ant(i,k,j,p_e_ec_1_25) & + + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_ec_25_10) & +!++SAN + + fr_aem_gc2mosaic_f(n)*emis_ant(i,k,j,p_e_bc) +!--SAN + + aem_oin = fr_aem_mosaic_f(n)*emis_ant(i,k,j,p_e_pm25j) & + fr_aem_mosaic_c(n)*emis_ant(i,k,j,p_e_pm_10) & - + fr_aem_sorgam_i(n)*(emis_ant(i,k,j,p_e_pm25i)+0.25*ebu(i,k,j,p_ebu_pm25)) & - + fr_aem_sorgam_j(n)*(emis_ant(i,k,j,p_e_pm25j)+0.75*ebu(i,k,j,p_ebu_pm25)) & - + fr_tno_mosaic_f(n)*emis_ant(i,k,j,p_e_oin_25) & - + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_oin_10) + + fr_aem_sorgam_i(n)*emis_ant(i,k,j,p_e_pm25i) & + + fr_aem_sorgam_j(n)*emis_ant(i,k,j,p_e_pm25j) & +!++SAN + + fr_aem_sorgam_c(n)*emis_ant(i,k,j,p_e_pm_10) & +!--SAN + + fr_tno_mosaic_f(n)*emis_ant(i,k,j,p_e_oin_25) & + + fr_tno_mosaic_c(n)*emis_ant(i,k,j,p_e_oin_10) & +!++SAN + + fr_aem_gc2mosaic_f(n)*emis_ant(i,k,j,p_e_pm25) & + + fr_aem_gc2mosaic_f(n)*emis_ant(i,k,j,p_e_pm10) +!--SAN ! emissions for these species are currently zero @@ -500,6 +573,117 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & 1900 continue + if (num_ebu <= 0 ) then + return + endif + +!++ SAN, 2015-04-09. +! ---------------------- ADD BIOMASS BURNING EMISSIONS ----------------------------! +! - new case select for adding biomass burning emissions. +! First reset all emissions to make sure we don't double count anthropogenic emissions + aem_so4 = 0. + aem_no3 = 0. + aem_oc = 0. + aem_bc = 0. + aem_oin = 0. + aem_num = 0. + + fire_select: SELECT CASE(config_flags%biomass_burn_opt) + CASE (BIOMASSB,BIOMASSB_MOZC) + CALL wrf_debug(15,'mosaic_addemiss: adding fire emissions to MOSAIC') +! CALL wrf_debug(15,'e_oin_fm = PM2.5 - OC - BC') +! CALL wrf_debug(15,'e_oin_cm = PM10 - PM2.5') + +size_loop: & + do n = 1, nsize_aer(itype) + do j = jts, jte + do k = kts, kte ! Loop up to kte for fire emissions (with plumerise) + do i = its, ite +! compute mass biomass burning emissions [(ug/m3)*m/s] for each species +! using the apportioning fractions + aem_so4 = bburn_mosaic_f(n)*ebu(i,k,j,p_ebu_sulf) + aem_oc = bburn_mosaic_f(n)*ebu(i,k,j,p_ebu_oc) + aem_bc = bburn_mosaic_f(n)*ebu(i,k,j,p_ebu_bc) +! Option to calculate OIN fraction of total PM for fire emissions +! Assume all OC and BC is in FM. + aem_oin = bburn_mosaic_f(n)*ebu(i,k,j,p_ebu_pm25) & + + bburn_mosaic_c(n)*ebu(i,k,j,p_ebu_pm10) + + chem_select_3 : SELECT CASE( config_flags%chem_opt ) + CASE(SAPRC99_MOSAIC_4BIN_VBS2_KPP) ! Set the oc to zero for VBS + aem_oc = 0.0 + END SELECT chem_select_3 + +! emissions for these species are currently zero + aem_nh4 = 0.0 + aem_na = 0.0 + aem_cl = 0.0 + aem_ca = 0.0 + aem_co3 = 0.0 + aem_msa = 0.0 + + ! compute number emissions + ! first sum the mass-emissions/density + aem_num = & + (aem_so4/dens_so4_aer) + (aem_no3/dens_no3_aer) + & + (aem_cl /dens_cl_aer ) + (aem_msa/dens_msa_aer) + & + (aem_co3/dens_co3_aer) + (aem_nh4/dens_nh4_aer) + & + (aem_na /dens_na_aer ) + (aem_ca /dens_ca_aer ) + & + (aem_oin/dens_oin_aer) + (aem_oc /dens_oc_aer ) + & + (aem_bc /dens_bc_aer ) + + ! then multiply by 1.0e-6 to convert ug to g + ! and divide by particle volume at center of section (cm3) + aem_num = aem_num*1.0e-6/volumcen_sect(n,itype) + + ! apply the emissions and convert from flux to mixing ratio + ! fact = (dtstep/dz8w(i,k,j))*(28.966/1000.) + fact = (dtstep/dz8w(i,k,j))*alt(i,k,j) + + ! rce 22-nov-2004 - change to using the "..._aer" species pointers + l = lptr_so4_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_so4*fact + + l = lptr_no3_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_no3*fact + + l = lptr_cl_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_cl*fact + + l = lptr_msa_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_msa*fact + + l = lptr_co3_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_co3*fact + + l = lptr_nh4_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_nh4*fact + + l = lptr_na_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_na*fact + + l = lptr_ca_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_ca*fact + + l = lptr_oin_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_oin*fact + + l = lptr_oc_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_oc*fact + + l = lptr_bc_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_bc*fact + + l = numptr_aer(n,itype,iphase) + if (l >= p1st) chem(i,k,j,l) = chem(i,k,j,l) + aem_num*fact + + end do + end do + end do + end do size_loop + END SELECT fire_select +!-- SAN - end adding fire emissions. + ! do mass check final calc if (mosaic_addemiss_masscheck > 0) call addemiss_masscheck( & @@ -541,13 +725,18 @@ subroutine mosaic_addemiss( id, dtstep, u10, v10, alt, dz8w, xland, & ! do dust emissions ! jdf: preliminary version that has not been made generic for situation if (dust_opt == 2) then + !czhao+++++++++++++++++++++++++++ + call wrf_message("WARNING: You are calling DUSTRAN dust emission scheme with MOSAIC, which is highly experimental and not recommended for use. Please use dust_opt==13") + !czhao--------------------------- call mosaic_dust_emiss( slai, ust, smois, ivgtyp, isltyp, & id, dtstep, u10, v10, alt, dz8w, xland, config_flags, chem, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) endif - if (dust_opt == 3) then + !czhao+++++++++++++++++++++++++++ + if (dust_opt == 13) then + !czhao--------------------------- call mosaic_dust_gocartemis (ktau,dtstep,config_flags%num_soil_layers,alt,u_phy, & v_phy,chem,rho_phy,dz8w,smois,u10,v10,p8w,erod, & ivgtyp,isltyp,xland,dx,g, & @@ -1962,9 +2151,6 @@ subroutine mosaic_dust_gocartemis (ktau,dt,num_soil_layers,alt,u_phy, & airden=rho_phy(i,kts,j) dxy=dx*dx - if (i==40.and.j==50) then - print*,'check moisture ',gwet - endif call mosaic_source_du( nmx, dt, & erodin, ilwi, dxy, w10m, gwet, airden, airmas, & bems,start_month,g) diff --git a/wrfv2_fire/chem/module_mosaic_driver.F b/wrfv2_fire/chem/module_mosaic_driver.F index 52d4247c..b21a0f1c 100644 --- a/wrfv2_fire/chem/module_mosaic_driver.F +++ b/wrfv2_fire/chem/module_mosaic_driver.F @@ -1129,7 +1129,7 @@ end subroutine sum_pm_mosaic_vbs4 !----------------------------------------------------------------------- - subroutine sum_vbs0 ( & + subroutine sum_vbs0 ( aero_diag_opt, & alt, chem, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & bboa_a01,bboa_a02,bboa_a03,bboa_a04, & @@ -1150,6 +1150,7 @@ subroutine sum_vbs0 ( & USE module_data_mosaic_asect IMPLICIT NONE + INTEGER, INTENT(IN ) :: aero_diag_opt INTEGER, INTENT(IN ) :: & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -1180,6 +1181,12 @@ subroutine sum_vbs0 ( & jmax = min(jte,jde-1) kmax = kte + totoa_a01(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a02(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a03(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a04(its:imax,kts:kmax,jts:jmax) = 0. + + if( aero_diag_opt > 0 ) then hoa_a01(its:imax,kts:kmax,jts:jmax) = 0. soa_a01(its:imax,kts:kmax,jts:jmax) = 0. bboa_a01(its:imax,kts:kmax,jts:jmax) = 0. @@ -1187,7 +1194,6 @@ subroutine sum_vbs0 ( & biog_a01(its:imax,kts:kmax,jts:jmax) = 0. asmpsoa_a01(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a01(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a01(its:imax,kts:kmax,jts:jmax) = 0. hoa_a02(its:imax,kts:kmax,jts:jmax) = 0. soa_a02(its:imax,kts:kmax,jts:jmax) = 0. @@ -1196,7 +1202,6 @@ subroutine sum_vbs0 ( & asmpsoa_a02(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a02(its:imax,kts:kmax,jts:jmax) = 0. biog_a02(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a02(its:imax,kts:kmax,jts:jmax) = 0. hoa_a03(its:imax,kts:kmax,jts:jmax) = 0. soa_a03(its:imax,kts:kmax,jts:jmax) = 0. @@ -1205,7 +1210,6 @@ subroutine sum_vbs0 ( & asmpsoa_a03(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a03(its:imax,kts:kmax,jts:jmax) = 0. biog_a03(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a03(its:imax,kts:kmax,jts:jmax) = 0. hoa_a04(its:imax,kts:kmax,jts:jmax) = 0. soa_a04(its:imax,kts:kmax,jts:jmax) = 0. @@ -1214,7 +1218,6 @@ subroutine sum_vbs0 ( & asmpsoa_a04(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a04(its:imax,kts:kmax,jts:jmax) = 0. biog_a04(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a04(its:imax,kts:kmax,jts:jmax) = 0. ! Species to calculate O:C ratios biog_v1(its:imax,kts:kmax,jts:jmax) = 0. @@ -1227,9 +1230,66 @@ subroutine sum_vbs0 ( & ant_v2(its:imax,kts:kmax,jts:jmax) = 0. ant_v3(its:imax,kts:kmax,jts:jmax) = 0. ant_v4(its:imax,kts:kmax,jts:jmax) = 0. + endif + do iphase=1,nphase_aer + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + totoa_a01(i,k,j)= totoa_a01(i,k,j) & + + chem(i,k,j,lptr_smpa_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_smpbb_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(1,itype,iphase)) + totoa_a02(i,k,j)= totoa_a02(i,k,j) & + + chem(i,k,j,lptr_oc_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_smpa_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_smpbb_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase)) + totoa_a03(i,k,j)= totoa_a03(i,k,j) & + + chem(i,k,j,lptr_smpa_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_smpbb_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(3,itype,iphase)) + totoa_a04(i,k,j)= totoa_a04(i,k,j) & + + chem(i,k,j,lptr_smpa_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_smpbb_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(4,itype,iphase)) + enddo + enddo + enddo + enddo ! type + enddo ! phase + + if( aero_diag_opt > 0 ) then do iphase=1,nphase_aer do itype=1,ntype_aer do n = 1, nsize_aer(itype) !The 4th bin is 2.5-10um and outside the AMS measurements @@ -1324,18 +1384,6 @@ subroutine sum_vbs0 ( & asmpsoa_a01(i,k,j)= asmpsoa_a01(i,k,j) & + chem(i,k,j,lptr_smpa_aer(1,itype,iphase)) - totoa_a01(i,k,j)= totoa_a01(i,k,j) & - + chem(i,k,j,lptr_smpa_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_smpbb_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r1_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r2_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_oh_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_sfc_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_nh4_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(1,itype,iphase)) - enddo enddo enddo @@ -1399,18 +1447,6 @@ subroutine sum_vbs0 ( & asmpsoa_a02(i,k,j)= asmpsoa_a02(i,k,j) & + chem(i,k,j,lptr_smpa_aer(2,itype,iphase)) - totoa_a02(i,k,j)= totoa_a02(i,k,j) & - + chem(i,k,j,lptr_oc_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r1_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r2_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_sfc_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_oh_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_nh4_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_smpa_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_smpbb_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase)) - enddo enddo enddo @@ -1470,20 +1506,6 @@ subroutine sum_vbs0 ( & asmpsoa_a03(i,k,j)= asmpsoa_a03(i,k,j) & + chem(i,k,j,lptr_smpa_aer(3,itype,iphase)) - - totoa_a03(i,k,j)= totoa_a03(i,k,j) & - + chem(i,k,j,lptr_smpa_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_smpbb_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r1_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r2_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_sfc_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_oh_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_nh4_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(3,itype,iphase)) - - enddo enddo enddo @@ -1548,29 +1570,24 @@ subroutine sum_vbs0 ( & asmpsoa_a04(i,k,j)= asmpsoa_a04(i,k,j) & + chem(i,k,j,lptr_smpa_aer(4,itype,iphase)) - - - totoa_a04(i,k,j)= totoa_a04(i,k,j) & - + chem(i,k,j,lptr_smpa_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_smpbb_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r1_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r2_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_sfc_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_oh_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_nh4_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(4,itype,iphase)) - - - enddo enddo enddo enddo ! type enddo ! phase + endif !Factor of 1.4 used below to convert OC to OA + totoa_a01(its:imax,kts:kmax,jts:jmax) =totoa_a01(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + totoa_a02(its:imax,kts:kmax,jts:jmax) =totoa_a02(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + totoa_a03(its:imax,kts:kmax,jts:jmax) =totoa_a03(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + totoa_a04(its:imax,kts:kmax,jts:jmax) =totoa_a04(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + + if( aero_diag_opt > 0 ) then hoa_a01(its:imax,kts:kmax,jts:jmax) =hoa_a01(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) soa_a01(its:imax,kts:kmax,jts:jmax) =soa_a01(its:imax,kts:kmax,jts:jmax) & @@ -1588,8 +1605,6 @@ subroutine sum_vbs0 ( & / alt(its:imax,kts:kmax,jts:jmax) - totoa_a01(its:imax,kts:kmax,jts:jmax) =totoa_a01(its:imax,kts:kmax,jts:jmax) & - / alt(its:imax,kts:kmax,jts:jmax) hoa_a02(its:imax,kts:kmax,jts:jmax) =hoa_a02(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) @@ -1605,8 +1620,6 @@ subroutine sum_vbs0 ( & asmpsoa_a02(its:imax,kts:kmax,jts:jmax) =asmpsoa_a02(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) - totoa_a02(its:imax,kts:kmax,jts:jmax) =totoa_a02(its:imax,kts:kmax,jts:jmax) & - / alt(its:imax,kts:kmax,jts:jmax) hoa_a03(its:imax,kts:kmax,jts:jmax) =hoa_a03(its:imax,kts:kmax,jts:jmax) & @@ -1623,8 +1636,6 @@ subroutine sum_vbs0 ( & asmpsoa_a03(its:imax,kts:kmax,jts:jmax) =asmpsoa_a03(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) - totoa_a03(its:imax,kts:kmax,jts:jmax) =totoa_a03(its:imax,kts:kmax,jts:jmax) & - / alt(its:imax,kts:kmax,jts:jmax) hoa_a04(its:imax,kts:kmax,jts:jmax) =hoa_a04(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) @@ -1639,16 +1650,15 @@ subroutine sum_vbs0 ( & / alt(its:imax,kts:kmax,jts:jmax) asmpsoa_a04(its:imax,kts:kmax,jts:jmax) =asmpsoa_a04(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) + endif - totoa_a04(its:imax,kts:kmax,jts:jmax) =totoa_a04(its:imax,kts:kmax,jts:jmax) & - / alt(its:imax,kts:kmax,jts:jmax) end subroutine sum_vbs0 !----------------------------------------------------------------------- - subroutine sum_vbs2 ( & + subroutine sum_vbs2 ( aero_diag_opt, & alt, chem, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & hoa_a05,hoa_a06,hoa_a07,hoa_a08, & !BSINGH(12/04/2013): Added 4 more bins(5 to 8) for all apecies @@ -1677,6 +1687,7 @@ subroutine sum_vbs2 ( & USE module_data_mosaic_asect IMPLICIT NONE + INTEGER, INTENT(IN ) :: aero_diag_opt INTEGER, INTENT(IN ) :: & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -1716,6 +1727,16 @@ subroutine sum_vbs2 ( & jmax = min(jte,jde-1) kmax = kte + totoa_a01(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a02(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a03(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a04(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a05(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a06(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a07(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a08(its:imax,kts:kmax,jts:jmax) = 0. + + if( aero_diag_opt > 0 ) then hoa_a01(its:imax,kts:kmax,jts:jmax) = 0. soa_a01(its:imax,kts:kmax,jts:jmax) = 0. bboa_a01(its:imax,kts:kmax,jts:jmax) = 0. @@ -1723,7 +1744,6 @@ subroutine sum_vbs2 ( & hsoa_a01(its:imax,kts:kmax,jts:jmax) = 0. biog_a01(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a01(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a01(its:imax,kts:kmax,jts:jmax) = 0. hoa_a02(its:imax,kts:kmax,jts:jmax) = 0. soa_a02(its:imax,kts:kmax,jts:jmax) = 0. @@ -1732,7 +1752,6 @@ subroutine sum_vbs2 ( & hsoa_a02(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a02(its:imax,kts:kmax,jts:jmax) = 0. biog_a02(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a02(its:imax,kts:kmax,jts:jmax) = 0. hoa_a03(its:imax,kts:kmax,jts:jmax) = 0. soa_a03(its:imax,kts:kmax,jts:jmax) = 0. @@ -1741,7 +1760,6 @@ subroutine sum_vbs2 ( & hsoa_a03(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a03(its:imax,kts:kmax,jts:jmax) = 0. biog_a03(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a03(its:imax,kts:kmax,jts:jmax) = 0. hoa_a04(its:imax,kts:kmax,jts:jmax) = 0. soa_a04(its:imax,kts:kmax,jts:jmax) = 0. @@ -1750,7 +1768,6 @@ subroutine sum_vbs2 ( & hsoa_a04(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a04(its:imax,kts:kmax,jts:jmax) = 0. biog_a04(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a04(its:imax,kts:kmax,jts:jmax) = 0. hoa_a05(its:imax,kts:kmax,jts:jmax) = 0. @@ -1760,7 +1777,6 @@ subroutine sum_vbs2 ( & hsoa_a05(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a05(its:imax,kts:kmax,jts:jmax) = 0. biog_a05(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a05(its:imax,kts:kmax,jts:jmax) = 0. hoa_a06(its:imax,kts:kmax,jts:jmax) = 0. soa_a06(its:imax,kts:kmax,jts:jmax) = 0. @@ -1769,7 +1785,6 @@ subroutine sum_vbs2 ( & hsoa_a06(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a06(its:imax,kts:kmax,jts:jmax) = 0. biog_a06(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a06(its:imax,kts:kmax,jts:jmax) = 0. hoa_a07(its:imax,kts:kmax,jts:jmax) = 0. soa_a07(its:imax,kts:kmax,jts:jmax) = 0. @@ -1778,7 +1793,6 @@ subroutine sum_vbs2 ( & hsoa_a07(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a07(its:imax,kts:kmax,jts:jmax) = 0. biog_a07(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a07(its:imax,kts:kmax,jts:jmax) = 0. hoa_a08(its:imax,kts:kmax,jts:jmax) = 0. soa_a08(its:imax,kts:kmax,jts:jmax) = 0. @@ -1787,7 +1801,6 @@ subroutine sum_vbs2 ( & hsoa_a08(its:imax,kts:kmax,jts:jmax) = 0. arosoa_a08(its:imax,kts:kmax,jts:jmax) = 0. biog_a08(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a08(its:imax,kts:kmax,jts:jmax) = 0. @@ -1804,8 +1817,156 @@ subroutine sum_vbs2 ( & ant_v2(its:imax,kts:kmax,jts:jmax) = 0. ant_v3(its:imax,kts:kmax,jts:jmax) = 0. ant_v4(its:imax,kts:kmax,jts:jmax) = 0. + endif +! NOTE - summation seems to be wrong for code below, but not my code so did not fix... + iphase = 1 + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + totoa_a01(i,k,j) = (chem(i,k,j,lptr_pcg1_b_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(1,itype,iphase))) + totoa_a02(i,k,j) = (chem(i,k,j,lptr_pcg1_b_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(2,itype,iphase))) + totoa_a03(i,k,j) = (chem(i,k,j,lptr_pcg1_b_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(3,itype,iphase))) + totoa_a04(i,k,j) = (chem(i,k,j,lptr_pcg1_b_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(4,itype,iphase))) + totoa_a05(i,k,j) = (chem(i,k,j,lptr_pcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(5,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(5,itype,iphase))) + totoa_a06(i,k,j) = (chem(i,k,j,lptr_pcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(6,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(6,itype,iphase))) + totoa_a07(i,k,j) = (chem(i,k,j,lptr_pcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(7,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(7,itype,iphase))) + totoa_a08(i,k,j) = (chem(i,k,j,lptr_pcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_b_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_b_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_b_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg1_f_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_pcg2_f_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_ant1_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_ant1_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_biog1_c_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(8,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(8,itype,iphase))) + enddo + enddo + enddo + enddo ! type + if( aero_diag_opt > 0 ) then !do iphase=1,nphase_aer!BSINGH - Commented out as we need to add only phase 1 (interstitial) values species iphase = 1 do itype=1,ntype_aer @@ -1852,6 +2013,7 @@ subroutine sum_vbs2 ( & ! NOTE - summation also wrong for code below, but not my code so did not fix... !do iphase=1,nphase_aer !BSINGH - Commented out as we need to add only phase 1 (interstitial) values species + iphase = 1 do itype=1,ntype_aer do j=jts,jmax @@ -1891,24 +2053,6 @@ subroutine sum_vbs2 ( & - totoa_a01(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_c_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_b_o_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_o_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_c_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_o_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_c_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_c_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_o_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_o_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_c_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_o_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_ant1_c_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_ant1_o_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(1,itype,iphase))) - enddo enddo @@ -1954,27 +2098,6 @@ subroutine sum_vbs2 ( & biog_a02(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase))) - - - totoa_a02(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_b_o_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_o_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_o_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_o_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_o_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_o_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_ant1_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_ant1_o_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(2,itype,iphase))) - - enddo enddo enddo @@ -2019,27 +2142,6 @@ subroutine sum_vbs2 ( & biog_a03(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase))) - - - totoa_a03(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_c_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_b_o_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_o_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_c_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_o_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_c_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_c_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_o_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_o_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_c_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_o_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_ant1_c_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_ant1_o_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(3,itype,iphase))) - - enddo enddo enddo @@ -2078,32 +2180,11 @@ subroutine sum_vbs2 ( & bbsoa_a04(i,k,j)= (chem(i,k,j,lptr_opcg1_b_c_aer(4,itype,iphase)) & + chem(i,k,j,lptr_opcg1_b_o_aer(4,itype,iphase))) - hsoa_a04(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_o_aer(4,itype,iphase))) - - biog_a04(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase))) - - - - totoa_a04(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_b_o_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_o_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_o_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_o_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_o_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_o_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_ant1_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_ant1_o_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(4,itype,iphase))) - + hsoa_a04(i,k,j)= ( chem(i,k,j,lptr_opcg1_f_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_opcg1_f_o_aer(4,itype,iphase))) + + biog_a04(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_biog1_o_aer(4,itype,iphase))) enddo enddo @@ -2146,27 +2227,6 @@ subroutine sum_vbs2 ( & biog_a05(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(5,itype,iphase)) & + chem(i,k,j,lptr_biog1_o_aer(5,itype,iphase))) - - - totoa_a05(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_c_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_b_o_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_o_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_c_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_o_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_c_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_c_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_o_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_o_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_c_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_o_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_ant1_c_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_ant1_o_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(5,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(5,itype,iphase))) - - enddo enddo enddo @@ -2210,27 +2270,6 @@ subroutine sum_vbs2 ( & biog_a06(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(6,itype,iphase)) & + chem(i,k,j,lptr_biog1_o_aer(6,itype,iphase))) - - - totoa_a06(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_c_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_b_o_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_o_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_c_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_o_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_c_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_c_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_o_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_o_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_c_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_o_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_ant1_c_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_ant1_o_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(6,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(6,itype,iphase))) - - enddo enddo enddo @@ -2274,27 +2313,6 @@ subroutine sum_vbs2 ( & biog_a07(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(7,itype,iphase)) & + chem(i,k,j,lptr_biog1_o_aer(7,itype,iphase))) - - - totoa_a07(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_c_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_b_o_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_o_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_c_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_o_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_c_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_c_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_o_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_o_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_c_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_o_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_ant1_c_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_ant1_o_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(7,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(7,itype,iphase))) - - enddo enddo enddo @@ -2338,31 +2356,11 @@ subroutine sum_vbs2 ( & biog_a08(i,k,j)= (chem(i,k,j,lptr_biog1_c_aer(8,itype,iphase)) & + chem(i,k,j,lptr_biog1_o_aer(8,itype,iphase))) - - - totoa_a08(i,k,j)= ( chem(i,k,j,lptr_pcg1_b_c_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_c_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_b_o_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_b_o_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_c_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_b_o_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_c_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_c_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_pcg1_f_o_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_pcg2_f_o_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_c_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_opcg1_f_o_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_ant1_c_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_ant1_o_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_biog1_c_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_biog1_o_aer(8,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(8,itype,iphase))) - - enddo enddo enddo enddo ! type + endif end subroutine sum_vbs2 @@ -2985,7 +2983,7 @@ end subroutine sum_aq_vbs2 !----------------------------------------------------------------------- - subroutine sum_vbs4 ( & + subroutine sum_vbs4 ( aero_diag_opt, & alt, chem, & hoa_a01,hoa_a02,hoa_a03,hoa_a04, & soa_a01,soa_a02,soa_a03,soa_a04, & @@ -3001,6 +2999,7 @@ subroutine sum_vbs4 ( & USE module_data_mosaic_asect IMPLICIT NONE + INTEGER, INTENT(IN ) :: aero_diag_opt INTEGER, INTENT(IN ) :: & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & @@ -3027,25 +3026,27 @@ subroutine sum_vbs4 ( & jmax = min(jte,jde-1) kmax = kte + totoa_a01(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a02(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a03(its:imax,kts:kmax,jts:jmax) = 0. + totoa_a04(its:imax,kts:kmax,jts:jmax) = 0. + + if( aero_diag_opt > 0 ) then hoa_a01(its:imax,kts:kmax,jts:jmax) = 0. soa_a01(its:imax,kts:kmax,jts:jmax) = 0. biog_a01(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a01(its:imax,kts:kmax,jts:jmax) = 0. hoa_a02(its:imax,kts:kmax,jts:jmax) = 0. soa_a02(its:imax,kts:kmax,jts:jmax) = 0. biog_a02(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a02(its:imax,kts:kmax,jts:jmax) = 0. hoa_a03(its:imax,kts:kmax,jts:jmax) = 0. soa_a03(its:imax,kts:kmax,jts:jmax) = 0. biog_a03(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a03(its:imax,kts:kmax,jts:jmax) = 0. hoa_a04(its:imax,kts:kmax,jts:jmax) = 0. soa_a04(its:imax,kts:kmax,jts:jmax) = 0. biog_a04(its:imax,kts:kmax,jts:jmax) = 0. - totoa_a04(its:imax,kts:kmax,jts:jmax) = 0. ! Species to calculate O:C ratios biog_v1(its:imax,kts:kmax,jts:jmax) = 0. @@ -3056,9 +3057,88 @@ subroutine sum_vbs4 ( & ant_v2(its:imax,kts:kmax,jts:jmax) = 0. ant_v3(its:imax,kts:kmax,jts:jmax) = 0. ant_v4(its:imax,kts:kmax,jts:jmax) = 0. + endif + do iphase=1,nphase_aer + do itype=1,ntype_aer + do j=jts,jmax + do k=kts,kmax + do i=its,imax + totoa_a01(i,k,j)= totoa_a01(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(1,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(1,itype,iphase)) + totoa_a02(i,k,j)= totoa_a02(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(2,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(2,itype,iphase)) + totoa_a03(i,k,j)= totoa_a03(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(3,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(3,itype,iphase)) + totoa_a04(i,k,j)= totoa_a04(i,k,j) & + + chem(i,k,j,lptr_asoaX_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa3_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_asoa4_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoaX_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa3_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_bsoa4_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r1_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_r2_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_oh_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_sfc_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_glysoa_nh4_aer(4,itype,iphase)) & + + chem(i,k,j,lptr_oc_aer(4,itype,iphase)) + enddo + enddo + enddo + enddo ! type + enddo ! phase - + if( aero_diag_opt > 0 ) then do iphase=1,nphase_aer do itype=1,ntype_aer do n = 1, nsize_aer(itype) !The 4th bin is 2.5-10um and outside the AMS measurements @@ -3122,26 +3202,6 @@ subroutine sum_vbs4 ( & + chem(i,k,j,lptr_bsoa2_aer(1,itype,iphase)) & + chem(i,k,j,lptr_bsoa3_aer(1,itype,iphase)) & + chem(i,k,j,lptr_bsoa4_aer(1,itype,iphase)) - - totoa_a01(i,k,j)= totoa_a01(i,k,j) & - + chem(i,k,j,lptr_asoaX_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_asoa1_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_asoa2_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_asoa3_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_asoa4_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_bsoaX_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_bsoa1_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_bsoa2_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_bsoa3_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_bsoa4_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r1_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r2_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_oh_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_sfc_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_nh4_aer(1,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(1,itype,iphase)) - - enddo enddo enddo @@ -3178,26 +3238,6 @@ subroutine sum_vbs4 ( & + chem(i,k,j,lptr_bsoa2_aer(2,itype,iphase)) & + chem(i,k,j,lptr_bsoa3_aer(2,itype,iphase)) & + chem(i,k,j,lptr_bsoa4_aer(2,itype,iphase)) - - totoa_a02(i,k,j)= totoa_a02(i,k,j) & - + chem(i,k,j,lptr_asoaX_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_asoa1_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_asoa2_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_asoa3_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_asoa4_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_bsoaX_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_bsoa1_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_bsoa2_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_bsoa3_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_bsoa4_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r1_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r2_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_oh_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_sfc_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_nh4_aer(2,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(2,itype,iphase)) - - enddo enddo enddo @@ -3234,24 +3274,6 @@ subroutine sum_vbs4 ( & + chem(i,k,j,lptr_bsoa2_aer(3,itype,iphase)) & + chem(i,k,j,lptr_bsoa3_aer(3,itype,iphase)) & + chem(i,k,j,lptr_bsoa4_aer(3,itype,iphase)) - - totoa_a03(i,k,j)= totoa_a03(i,k,j) & - + chem(i,k,j,lptr_asoaX_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_asoa1_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_asoa2_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_asoa3_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_asoa4_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_bsoaX_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_bsoa1_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_bsoa2_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_bsoa3_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_bsoa4_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r1_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r2_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_oh_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_sfc_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_nh4_aer(3,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(3,itype,iphase)) enddo enddo enddo @@ -3288,39 +3310,29 @@ subroutine sum_vbs4 ( & + chem(i,k,j,lptr_bsoa2_aer(4,itype,iphase)) & + chem(i,k,j,lptr_bsoa3_aer(4,itype,iphase)) & + chem(i,k,j,lptr_bsoa4_aer(4,itype,iphase)) - - totoa_a04(i,k,j)= totoa_a04(i,k,j) & - + chem(i,k,j,lptr_asoaX_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_asoa1_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_asoa2_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_asoa3_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_asoa4_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_bsoaX_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_bsoa1_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_bsoa2_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_bsoa3_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_bsoa4_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r1_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_r2_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_oh_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_sfc_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_glysoa_nh4_aer(4,itype,iphase)) & - + chem(i,k,j,lptr_oc_aer(4,itype,iphase)) enddo enddo enddo enddo ! type enddo ! phase + endif !Factor of 1.4 used below to convert OC to OA + totoa_a01(its:imax,kts:kmax,jts:jmax) =totoa_a01(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + totoa_a02(its:imax,kts:kmax,jts:jmax) =totoa_a02(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + totoa_a03(its:imax,kts:kmax,jts:jmax) =totoa_a03(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + totoa_a04(its:imax,kts:kmax,jts:jmax) =totoa_a04(its:imax,kts:kmax,jts:jmax) & + / alt(its:imax,kts:kmax,jts:jmax) + if( aero_diag_opt > 0 ) then hoa_a01(its:imax,kts:kmax,jts:jmax) =hoa_a01(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) soa_a01(its:imax,kts:kmax,jts:jmax) =soa_a01(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) biog_a01(its:imax,kts:kmax,jts:jmax) =biog_a01(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) - totoa_a01(its:imax,kts:kmax,jts:jmax) =totoa_a01(its:imax,kts:kmax,jts:jmax) & - / alt(its:imax,kts:kmax,jts:jmax) hoa_a02(its:imax,kts:kmax,jts:jmax) =hoa_a02(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) @@ -3328,8 +3340,6 @@ subroutine sum_vbs4 ( & / alt(its:imax,kts:kmax,jts:jmax) biog_a02(its:imax,kts:kmax,jts:jmax) =biog_a02(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) - totoa_a02(its:imax,kts:kmax,jts:jmax) =totoa_a02(its:imax,kts:kmax,jts:jmax) & - / alt(its:imax,kts:kmax,jts:jmax) hoa_a03(its:imax,kts:kmax,jts:jmax) =hoa_a03(its:imax,kts:kmax,jts:jmax) & @@ -3338,8 +3348,6 @@ subroutine sum_vbs4 ( & / alt(its:imax,kts:kmax,jts:jmax) biog_a03(its:imax,kts:kmax,jts:jmax) =biog_a03(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) - totoa_a03(its:imax,kts:kmax,jts:jmax) =totoa_a03(its:imax,kts:kmax,jts:jmax) & - / alt(its:imax,kts:kmax,jts:jmax) hoa_a04(its:imax,kts:kmax,jts:jmax) =hoa_a04(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) @@ -3347,8 +3355,7 @@ subroutine sum_vbs4 ( & / alt(its:imax,kts:kmax,jts:jmax) biog_a04(its:imax,kts:kmax,jts:jmax) =biog_a04(its:imax,kts:kmax,jts:jmax) & / alt(its:imax,kts:kmax,jts:jmax) - totoa_a04(its:imax,kts:kmax,jts:jmax) =totoa_a04(its:imax,kts:kmax,jts:jmax) & - / alt(its:imax,kts:kmax,jts:jmax) + endif end subroutine sum_vbs4 diff --git a/wrfv2_fire/chem/module_mosaic_therm.F b/wrfv2_fire/chem/module_mosaic_therm.F index cc5d6178..fd9118ab 100644 --- a/wrfv2_fire/chem/module_mosaic_therm.F +++ b/wrfv2_fire/chem/module_mosaic_therm.F @@ -8715,14 +8715,16 @@ subroutine calc_dry_n_wet_aerosol_props(ibin) dens_dry_a(ibin) = mass_dry_a(ibin)/vol_dry_a(ibin) ! g/cc(aerosol) dens_wet_a(ibin) = mass_wet_a(ibin)/vol_wet_a(ibin) ! g/cc(aerosol) -! calculate mean dry and wet particle surface areas - area_dry_a(ibin)= 0.785398*num_a(ibin)*Dp_dry_a(ibin)**2 ! cm^2/cc(air) - area_wet_a(ibin)= 0.785398*num_a(ibin)*Dp_wet_a(ibin)**2 ! cm^2/cc(air) - ! calculate mean dry and wet particle diameters dp_dry_a(ibin)=(1.90985*vol_dry_a(ibin)/num_a(ibin))**0.3333333 ! cm dp_wet_a(ibin)=(1.90985*vol_wet_a(ibin)/num_a(ibin))**0.3333333 ! cm +! calculate mean dry and wet particle surface areas + area_dry_a(ibin)= 3.14159*num_a(ibin)*dp_dry_a(ibin)**2 ! cm^2/cc(air) + area_wet_a(ibin)= 3.14159*num_a(ibin)*dp_wet_a(ibin)**2 ! cm^2/cc(air) + + + ! calculate volume average refractive index ! load comp_a array do je = 1, nelectrolyte diff --git a/wrfv2_fire/chem/module_mozcart_wetscav.F b/wrfv2_fire/chem/module_mozcart_wetscav.F index 75a3d1b7..659c6996 100644 --- a/wrfv2_fire/chem/module_mozcart_wetscav.F +++ b/wrfv2_fire/chem/module_mozcart_wetscav.F @@ -15,7 +15,7 @@ MODULE module_mozcart_wetscav ! 20130716 acd_ck_vbsmoz start ! added OVOC washout ! integer, parameter :: wetscav_tab_cnt = 37 - integer, parameter :: wetscav_tab_cnt = 37 + 10 + integer, parameter :: wetscav_tab_cnt = 37 + 11 ! 20130716 acd_ck_vbsmoz end real, parameter :: zero = 0. real, parameter :: one = 1. @@ -138,6 +138,7 @@ subroutine wetscav_mozcart_init( id, numgas, config_flags ) ! 20140619 acd_mb_bugfix end wet_scav_tab(37) = wet_scav( 'sulf', p_sulf, (/1e+11, 0., 0., 0., 0., 0./), 98.078, .false., 0. ) ! order of magnitude approx. (Gmitro and Vermeulen, 1964) ! 20131125 acd_ck_bugfix end + wet_scav_tab(38) = wet_scav( 'hcooh', p_hcooh, (/8.9E+03, 6100., 1.8E-04, -20., 0., 0./), 46.02538, .true., 0.68 ) ! 20130729 acd_ck_vbsmoz start ! 20130911 acd_ck_vbsdep mark @@ -152,6 +153,7 @@ subroutine wetscav_mozcart_init( id, numgas, config_flags ) wet_scav_tab(45) = wet_scav( 'cvbsoa2', p_cvbsoa2, (/7.00E+08, 6014., 0., 0., 0., 0./), 180.0, .false., 0. ) wet_scav_tab(46) = wet_scav( 'cvbsoa3', p_cvbsoa3, (/9.33E+07, 6014., 0., 0., 0., 0./), 180.0, .false., 0. ) wet_scav_tab(47) = wet_scav( 'cvbsoa4', p_cvbsoa4, (/1.24E+07, 6014., 0., 0., 0., 0./), 180.0, .false., 0. ) + wet_scav_tab(48) = wet_scav( 'hcooh', p_hcooh, (/8.9E+03, 6100., 1.8E-04, -20., 0., 0./), 46.02538, .true., 0.68 ) ENDIF ! 20130729 acd_ck_vbsmoz end @@ -424,9 +426,9 @@ subroutine wetscav_mozcart( id, ktau, dtstep, ktauc, config_flags, dhr = wet_scav_tab(m1)%heff(6) dk2s(kts:ktem1) = e298*exp( dhr*tfac(kts:ktem1) ) if( pndx == p_co2 ) then - heff(kts:ktem1,m) = heff(kts:ktem1,m)*(1. + dk1s(:)*ph_inv)*(1. + dk2s(:)*ph_inv) + heff(kts:ktem1,m) = heff(kts:ktem1,m)*(1. + dk1s(kts:ktem1)*ph_inv)*(1. + dk2s(kts:ktem1)*ph_inv) elseif( pndx == p_nh3 ) then - heff(kts:ktem1,m) = heff(kts:ktem1,m)*(1. + dk1s(:)*ph/dk2s(:)) + heff(kts:ktem1,m) = heff(kts:ktem1,m)*(1. + dk1s(kts:ktem1)*ph/dk2s(kts:ktem1)) endif endif endif @@ -1913,10 +1915,10 @@ end function DEMPIRICAL function GAMMA( X ) !----------------------------------------------------------------------- -! Purpose: Compute the gamma function â(x) -! Input : x --- Argument of â(x) -! ( x is not equal to 0,-1,-2,úúú ) -! Output: GA --- â(x) +! Purpose: Compute the gamma function Ahat(x) +! Input : x --- Argument of Ahat(x) +! ( x is not equal to 0,-1,-2, ... ) +! Output: GA --- Ahat(x) !----------------------------------------------------------------------- !----------------------------------------------------------------------- diff --git a/wrfv2_fire/chem/module_phot_mad.F b/wrfv2_fire/chem/module_phot_mad.F index 37b80d31..626a9527 100755 --- a/wrfv2_fire/chem/module_phot_mad.F +++ b/wrfv2_fire/chem/module_phot_mad.F @@ -1340,14 +1340,16 @@ subroutine madronich1_driver(id,curr_secs,ktau,config_flags,haveaer,& tt(k+1) = t_phy(i,k,j) rhoa(k+1) = rho_phy(i,k,j) o33(k+1) = max(1.e-3,chem(i,k,j,p_o3)) - if(present(gd_cloud) .and. present(gd_cloud2))then + + IF (config_flags%cu_diag==1) THEN qll(k+1) = 1.e3*(moist(i,k,j,p_qc)+moist(i,k,j,p_qi)+ & gd_cloud(i,k,j)+gd_cloud2(i,k,j)) & *rho_phy(i,k,j) else qll(k+1) = 1.e3*(moist(i,k,j,p_qc)+moist(i,k,j,p_qi)) & *rho_phy(i,k,j) - endif + ENDIF + if(qll(k+1).lt.1.e-5)qll(k+1) = 0. phizz(k+1) = z_at_w(i,k+1,j)*.001-z_at_w(i,1,j)*.001 ! if((i.eq.1.and.j.eq.17))then diff --git a/wrfv2_fire/chem/module_phot_tuv.F b/wrfv2_fire/chem/module_phot_tuv.F new file mode 100644 index 00000000..0abba710 --- /dev/null +++ b/wrfv2_fire/chem/module_phot_tuv.F @@ -0,0 +1,2175 @@ +!#define SW_DEBUG + + module module_phot_tuv + + use params_mod, only : dp, m2km, ppm2vmr, o2vmr, km2cm, m2s + + IMPLICIT NONE + + private + public :: tuv_driver, tuv_init, tuv_timestep_init + + real, parameter :: conv1 = km2cm*.5 + real, parameter :: conv2 = conv1*ppm2vmr + real, parameter :: bext340 = 5.E-6 + real, parameter :: bexth2o = 5.E-6 + + integer :: nj + integer :: nlambda_start = 1 + integer :: nlambda_af_start = 1 + integer :: nlambda_af_end = 1 + integer :: nconc, ntemp, nwave + integer :: n_temp_data, n_o3_data, n_air_dens_data + integer :: j_o2_ndx = -1 + integer :: last, next + integer :: curjulday = 0 + integer, allocatable :: rxn_ndx(:) + real :: dels + real :: esfact + logical :: has_exo_coldens + logical :: tuv_is_initialized = .false. + + real, allocatable :: temp_tab(:) + real, allocatable :: conc_tab(:) + real, allocatable :: del_temp_tab(:) + real, allocatable :: del_conc_tab(:) + real, allocatable :: wl(:) + real, allocatable :: wc(:) + real, allocatable :: dw(:) + real, allocatable :: w_fac(:) + real, allocatable :: etfl(:) + real, allocatable :: albedo(:) + real, allocatable :: o2_xs(:) + real, allocatable :: so2_xs(:) + real, allocatable :: par_wght(:) + real, allocatable :: ery_wght(:) + real, allocatable :: z_temp_data(:), temp_data(:) + real, allocatable :: z_o3_data(:), o3_data(:) + real, allocatable :: z_air_dens_data(:), air_dens_data(:) + real, allocatable :: o3_xs_tab(:,:) + real, allocatable :: no2_xs_tab(:,:) + real, allocatable :: xsqy_tab(:,:,:,:) + character(len=32), allocatable :: tuv_jname(:) + logical :: has_so2, has_no2 + logical :: is_full_tuv = .true. +! logical :: is_full_tuv = .false. + logical :: rxn_initialized + logical, allocatable :: xsqy_is_zdep(:) + + type column_density + integer :: ncoldens_levs + integer :: ndays_of_year + real(8), pointer :: col_levs(:) + real(8), pointer :: day_of_year(:) + real(8), pointer :: o3_col_dens(:,:,:,:) + real(8), pointer :: o2_col_dens(:,:,:,:) + logical :: is_allocated + end type column_density + + type(column_density), allocatable :: col_dens(:) + + CONTAINS + + subroutine tuv_driver( & + dm, curr_secs, ktau, config_flags, haveaer, & + gmt, julday, t_phy, moist, aerwrf, & + p8w, t8w, p_phy, chem, rho_phy, & + dz8w, xlat, xlong, z, z_at_w, gd_cloud, gd_cloud2, & + tauaer1,tauaer2,tauaer3,tauaer4, & + gaer1,gaer2,gaer3,gaer4, & + waer1,waer2,waer3,waer4, & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2, & + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob, & + ph_n2o5,ph_o2,ph_n2o,ph_pooh,ph_pan,ph_mvk,ph_hyac, & + ph_glyald,ph_mek,ph_gly, & + pm2_5_dry,pm2_5_water,uvrad, & + dt_cld,af_dir,af_dn,af_up,par,erythema, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure + USE module_state_description + USE module_model_constants + USE module_data_radm2 + USE tuv_subs, only : tuv_radfld, sundis, calc_zenith + USE module_params, only : kz + USE srb, only : sjo2 + USE module_rxn, only : xsqy_table => xsqy_tab, the_subs, set_initialization + USE module_rxn, only : get_initialization + USE module_xsections, only : o3xs, no2xs_jpl06a + +!--------------------------------------------------------------------- +! ... dummy arguments +!--------------------------------------------------------------------- + INTEGER, INTENT(IN ) :: dm,julday, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte + INTEGER, INTENT(IN ) :: ktau + REAL(KIND=8), INTENT(IN ) :: curr_secs + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_moist ), & + INTENT(IN ) :: moist + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + pm2_5_dry,pm2_5_water + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + gd_cloud,gd_cloud2 + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(IN ) :: tauaer1, tauaer2, tauaer3, tauaer4, & + waer1, waer2, waer3, waer4, & + gaer1, gaer2, gaer3, gaer4 + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), & + INTENT(INOUT ) :: & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,& + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + ph_n2o5,ph_o2,ph_n2o,ph_pooh,ph_pan,ph_mvk,ph_hyac, & + ph_glyald,ph_mek,ph_gly + REAL, INTENT(INOUT) :: dt_cld(ims:ime,kms:kme,jms:jme), & + af_dir(ims:ime,kms:kme,jms:jme), & + af_dn(ims:ime,kms:kme,jms:jme), & + af_up(ims:ime,kms:kme,jms:jme), & + par(ims:ime,kms:kme,jms:jme), & + erythema(ims:ime,kms:kme,jms:jme) + REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ), & + INTENT(IN ) :: chem + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , & + INTENT(IN ) :: & + z, & + t_phy, & + p_phy, & + dz8w, & + t8w,p8w,z_at_w , & + aerwrf , & + rho_phy + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(IN ) :: & + xlat, & + xlong + REAL, DIMENSION( ims:ime , jms:jme ) , & + INTENT(INOUT ) :: uvrad + REAL, INTENT(IN ) :: gmt + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + + LOGICAL, INTENT(IN) :: haveaer + +!--------------------------------------------------------------------- +! ... local variables +!--------------------------------------------------------------------- + real, parameter :: boltz = 1.38065e-23 ! J/K/molecule + real, parameter :: xair_kg = 1.e3/28.97*6.023e23*1.e-6 + real(dp), parameter :: Pa2hPa = .01_dp + + integer :: astat, ierr + integer :: k, ki, kp1, i, j, n, wn + integer :: ktsm1, ktem1 + integer :: nlev, nlyr + integer :: jndx + integer :: n_tuv_z, n_exo_z, last_n_tuv_z + integer :: min_ndx(2), max_ndx(2) + integer :: myproc + integer(kind=8) :: ixhour + integer :: minndx(2) + + real :: xmin, gmtp, uvb_dd1, uvb_du1, uvb_dir1 + real :: zenith, dobsi + real :: delz_top + real(kind=8) :: xtime, xhour + real :: max_tauaer + real :: Dobson(2) + real :: xsect(nwave) + real :: wrk(nwave), wrk_lam(nwave) +! real :: tlev(kts-1:kte) +! real :: tlyr(kts-1:kte) +! real :: o33(kts-1:kte) + real :: rhoa(kts-1:kte) +! real :: dens_air(kts-1:kte) + real :: aerext(kts-1:kte) +! real :: qll(kts-1:kte) +! real :: aircol(kts-1:kte) +! real :: o3col(kts-1:kte) +! real :: o2col(kts-1:kte) +! real :: so2col(kts-1:kte) +! real :: no2col(kts-1:kte) + real :: dtcld_col(kts:kte) +! real :: cldfrac(kts-1:kte) + real :: par_col(kts:kte) +! real :: tauaer300(kts-1:kte), tauaer400(kts-1:kte), & +! tauaer600(kts-1:kte), tauaer999(kts-1:kte) +! real :: waer300(kts-1:kte), waer400(kts-1:kte), & +! waer600(kts-1:kte), waer999(kts-1:kte) +! real :: gaer300(kts-1:kte), gaer400(kts-1:kte), & +! gaer600(kts-1:kte), gaer999(kts-1:kte) + real :: zen_angle(ims:ime,jms:jme) + real :: z_top(its:ite,jts:jte) + real :: z_exo(1), dens_exo(1), temp_exo(1) + real :: dummy(kz) + real(dp) :: p_top(its:ite,jts:jte) + real(dp) :: o2_exo_col(its:ite,jts:jte) + real(dp) :: o3_exo_col(its:ite,jts:jte) + real(dp) :: o3_exo_col_at_grnd(its:ite,jts:jte) + + logical :: do_alloc + logical :: has_aer_ra_feedback + + real, allocatable :: tuv_z(:) + real, allocatable :: dtuv_z(:) + real, allocatable :: cldfrac(:) + real, allocatable :: qll(:) + real, allocatable :: tlev(:) + real, allocatable :: tlyr(:) + real, allocatable :: dens_air(:) + real, allocatable :: o33(:) + real, allocatable :: aircol(:) + real, allocatable :: o3col(:) + real, allocatable :: o2col(:) + real, allocatable :: so2col(:) + real, allocatable :: no2col(:) + real, allocatable :: tauaer300(:), tauaer400(:), tauaer600(:), tauaer999(:) + real, allocatable :: waer300(:), waer400(:), waer600(:), waer999(:) + real, allocatable :: gaer300(:), gaer400(:), gaer600(:), gaer999(:) + + real, allocatable :: dtcld(:,:), dtaer(:,:) + real, allocatable :: omcld(:,:), omaer(:,:) + real, allocatable :: gcld(:,:), gaer(:,:) + + real, allocatable :: rad_fld(:,:) + real, allocatable :: e_fld(:,:) + real, allocatable :: tuv_prate(:,:) + real, allocatable :: xsqy(:,:) + real, allocatable :: srb_o2_xs(:,:) + real, allocatable :: o3_xs(:,:), o3_xs_tpose(:,:) + real, allocatable :: no2_xs(:,:), no2_xs_tpose(:,:) + real, allocatable :: rad_fld_tpose(:,:) + real, allocatable :: dir_fld(:,:), dwn_fld(:,:), up_fld(:,:) + real, allocatable :: e_dir(:,:), e_dn(:,:), e_up(:,:) + + REAL :: zexo_grd(2*kte) + CHARACTER(len=256) :: msg + +#ifdef SW_DEBUG + logical :: tuv_diags +#endif + + call wrf_get_myproc( myproc ) + has_aer_ra_feedback = config_flags%aer_ra_feedback == 1 + + xtime = curr_secs/60._8 ! min since simulation start + ixhour = int( gmt+.01,8 ) + int( xtime/60._8,8 ) + xhour = real( ixhour,8 ) + xmin = 60.*gmt + real( xtime-xhour*60._8,4 ) + gmtp = real( mod(xhour,24._8),4 ) + gmtp = gmtp + xmin/60. + + call calc_zenith( xlat, -xlong, & + julday, real(gmtp,8), zen_angle, & + its, ite, jts, jte, & + ims, ime, jms, jme ) + +#ifdef SW_DEBUG + if( myproc == 6 ) then + write(*,'(''tuv_drvr: its,jts = '',2i5)') its,jts + minndx(:) = minloc( zen_angle(its:ite,jts:jte) ) + write(*,'(''tuv_drvr: min zen_angle ndx = '',2i5)') minndx(:) + write(*,'(''tuv_drvr: min zen_angle = '',1p,g15.8)') minval( zen_angle(its:ite,jts:jte) ) + minndx(1) = minndx(1) + its - 1 + minndx(2) = minndx(2) + jts - 1 + write(*,'(''tuv_drvr: minndx = '',2i5)') minndx(:) + write(*,'(''tuv_drvr: min zen_angle = '',1p,g15.8)') zen_angle(minndx(1),minndx(2)) + endif +#endif + + + do j = jts,jte + where( zen_angle(its:ite,j) == 90. ) + zen_angle(its:ite,j) = 89.9 + endwhere + end do + + ktsm1 = kts - 1 ; ktem1 = kte - 1 + + allocate( tuv_prate(kts:kte,nj),stat=ierr ) + if( ierr /= 0 ) then + call wrf_error_fatal( 'tuv_driver: failed to allocate tuv_prate' ) + endif + +any_daylight: & + if( any( zen_angle(its:ite,jts:jte) < 90. ) ) then + if( config_flags%has_o3_exo_coldens ) then +! p_top(its:ite,jts:jte) = Pa2hPa * real( p_phy(its:ite,kte,jts:jte),dp ) + z_exo(1) = 50. + call z_interp( z_air_dens_data, air_dens_data, n_air_dens_data, & + z_exo, dens_exo ) + call z_interp( z_temp_data, temp_data, n_temp_data, z_exo, temp_exo ) + p_top(its:ite,jts:jte) = temp_exo(1)*boltz*dens_exo(1)*1.e6*Pa2hPa + call tuv_timestep_init( dm, julday ) + call p_interp( o2_exo_col, o3_exo_col, o3_exo_col_at_grnd, p_top, & + dm, its, ite, jts, jte ) + endif + allocate( rad_fld(nwave,kts:kte),e_fld(kts:kte,nwave),stat=astat ) + ierr = ierr + astat + allocate( dir_fld(kts:kte,nwave), dwn_fld(kts:kte,nwave), up_fld(kts:kte,nwave),stat=astat ) + ierr = ierr + astat + allocate( e_dir(kts:kte,nwave), e_dn(kts:kte,nwave), e_up(kts:kte,nwave),stat=astat ) + ierr = ierr + astat + if( .not. is_full_tuv ) then + if( any( .not. xsqy_is_zdep(:) ) ) then + allocate( rad_fld_tpose(kts:kte,nwave),stat=astat ) + endif + elseif( any( xsqy_table(2:nj)%tpflag == 0 ) ) then + allocate( rad_fld_tpose(kts:kte,nwave),stat=astat ) + endif + ierr = ierr + astat + allocate( srb_o2_xs(nwave,kts:kte) ) + ierr = ierr + astat + allocate( xsqy(nwave,kts:kte) ) + ierr = ierr + astat + if( ierr /= 0 ) then + call wrf_error_fatal( 'tuv_driver: failed to allocate rad_fld ... xsqy' ) + endif +!----------------------------------------------------------------------------- +! set solar distance factor +!----------------------------------------------------------------------------- + if( curjulday /= julday ) then + curjulday = julday + esfact = sundis( julday ) + endif + if( .not. config_flags%scale_o3_to_grnd_exo_coldens ) then + if( config_flags%scale_o3_to_du_at_grnd ) then + dobsi = max( 0.,config_flags%du_at_grnd ) + else + dobsi = 0. + endif + endif + endif any_daylight + + if( ierr /= 0 ) then + call wrf_error_fatal( 'tuv_driver: failed to allocate module variables' ) + endif + + z_top(:,:) = 0. + do j = jts,jte + do i = its,ite + if( zen_angle(i,j) < 90. ) then + wrk(1) = m2km*(z(i,kte,j) - z_at_w(i,kts,j)) + z_top(i,j) = real( ceiling(wrk(1)) ) + delz_top = z_top(i,j) - wrk(1) + if( delz_top < .3 ) then + z_top(i,j) = z_top(i,j) + 1. + endif + endif + end do + end do + + if( is_full_tuv ) then + rxn_initialized = .not. get_initialization() + if( .not. rxn_initialized ) then + do n = 1,nj + jndx = rxn_ndx(n) + if( jndx /= -1 ) then + call the_subs(jndx)%xsqy_sub(nwave+1,wl,wc,kz,dummy,dummy,jndx) + endif + enddo + call set_initialization( status=.false. ) + endif + endif + + last_n_tuv_z = -1 +lat_loop : & + do j = jts,jte +long_loop : & + do i = its,ite +#ifdef SW_DEBUG + tuv_diags = i == minndx(1) .and. j == minndx(2) +#endif + do n = 1,nj + tuv_prate(:,n) = 0. + end do + zenith = zen_angle(i,j) +!--------------------------------------------------------------------- +! if night, skip radiative field calculation +!--------------------------------------------------------------------- +has_daylight : & + if( zenith < 90. ) then + do k = kts,kte + rad_fld(:,k) = 0. + end do + do wn = 1,nwave + e_fld(:,wn) = 0. + end do + wrk(1) = m2km*(z(i,kte,j) - z_at_w(i,kts,j)) + call setzgrid( wrk(1), n_exo_z, zexo_grd ) + n_tuv_z = kte + n_exo_z + nlev = n_tuv_z - ktsm1 + 1 + nlyr = nlev - 1 + do_alloc = n_tuv_z /= last_n_tuv_z + last_n_tuv_z = n_tuv_z +!--------------------------------------------------------------------- +! allocate column variables +!--------------------------------------------------------------------- + if( do_alloc ) then + call tuv_deallocate + call tuv_allocate + endif + +!--------------------------------------------------------------------- +! column vertical grid including exo-model top +!--------------------------------------------------------------------- + tuv_z(ktsm1) = 0. + tuv_z(kts:kte) = (z(i,kts:kte,j) - z_at_w(i,kts,j))*m2km + tuv_z(kte+1:kte+n_exo_z) = zexo_grd(1:n_exo_z) +! tuv_z(kte+1:kte+n_exo_z) = real( (/ (n,n=k,k+n_exo_z-1) /) ) +! tuv_z(kte+n_exo_z+1:n_tuv_z) = real( (/ (25+5*n,n=1,5) /) ) +!--------------------------------------------------------------------- +! cloud fraction +!--------------------------------------------------------------------- + cldfrac(:) = 0. + if( config_flags%cld_od_opt > 1 ) then + if( config_flags%pht_cldfrc_opt == 1 ) then + call cldfrac_binary( cldfrac(kts:kte), & + moist(i,kts:kte,j,p_qc), moist(i,kts:kte,j,p_qi), & + moist(i,kts:kte,j,p_qs), kts, kte ) + elseif( config_flags%pht_cldfrc_opt == 2 ) then + if( config_flags%cu_diag == 1 ) then + call cldfrac_fractional( cldfrac(kts:kte), & + moist(i,kts:kte,j,p_qv), & + moist(i,kts:kte,j,p_qc) + gd_cloud(i,kts:kte,j), & + moist(i,kts:kte,j,p_qi) + gd_cloud2(i,kts:kte,j), & + moist(i,kts:kte,j,p_qs), & + p_phy(i,kts:kte,j), t_phy(i,kts:kte,j), kts, kte ) + else + call cldfrac_fractional( cldfrac(kts:kte), & + moist(i,kts:kte,j,p_qv), moist(i,kts:kte,j,p_qc), & + moist(i,kts:kte,j,p_qi), moist(i,kts:kte,j,p_qs), & + p_phy(i,kts:kte,j), t_phy(i,kts:kte,j), kts, kte ) + endif + endif + endif +!--------------------------------------------------------------------- +! aerosols +!--------------------------------------------------------------------- + tauaer300(:) = 0. + tauaer400(:) = 0. + tauaer600(:) = 0. + tauaer999(:) = 0. + waer300(:) = 0. + waer400(:) = 0. + waer600(:) = 0. + waer999(:) = 0. + gaer300(:) = 0. + gaer400(:) = 0. + gaer600(:) = 0. + gaer999(:) = 0. + if( has_aer_ra_feedback ) then + tauaer300(kts:kte) = tauaer1(i,kts:kte,j) + tauaer400(kts:kte) = tauaer2(i,kts:kte,j) + tauaer600(kts:kte) = tauaer3(i,kts:kte,j) + tauaer999(kts:kte) = tauaer4(i,kts:kte,j) + waer300(kts:kte) = waer1(i,kts:kte,j) + waer400(kts:kte) = waer2(i,kts:kte,j) + waer600(kts:kte) = waer3(i,kts:kte,j) + waer999(kts:kte) = waer4(i,kts:kte,j) + gaer300(kts:kte) = gaer1(i,kts:kte,j) + gaer400(kts:kte) = gaer2(i,kts:kte,j) + gaer600(kts:kte) = gaer3(i,kts:kte,j) + gaer999(kts:kte) = gaer4(i,kts:kte,j) + tauaer300(ktsm1) = tauaer300(kts) + tauaer400(ktsm1) = tauaer400(kts) + tauaer600(ktsm1) = tauaer600(kts) + tauaer999(ktsm1) = tauaer999(kts) + waer300(ktsm1) = waer300(kts) + waer400(ktsm1) = waer400(kts) + waer600(ktsm1) = waer600(kts) + waer999(ktsm1) = waer999(kts) + gaer300(ktsm1) = gaer300(kts) + gaer400(ktsm1) = gaer400(kts) + gaer600(ktsm1) = gaer600(kts) + gaer999(ktsm1) = gaer999(kts) + endif + + tlev(ktsm1) = t8w(i,kts,j) + tlev(kts:kte) = t_phy(i,kts:kte,j) + call z_interp( z_temp_data, temp_data, n_temp_data, & + tuv_z(kte+1:n_tuv_z), tlev(kte+1:n_tuv_z) ) + tlyr(ktsm1:n_tuv_z-1) = .5*(tlev(ktsm1:n_tuv_z-1) + tlev(kts:n_tuv_z)) + + rhoa(ktsm1) = p8w(i,kts,j)/(t8w(i,kts,j)*r_d) + rhoa(kts:kte) = rho_phy(i,kts:kte,j) + dens_air(ktsm1:kte) = xair_kg*rhoa(ktsm1:kte) ! air num.(molecules/cm^3) + call z_interp( z_air_dens_data, air_dens_data, n_air_dens_data, & + tuv_z(kte+1:n_tuv_z), dens_air(kte+1:n_tuv_z) ) + + o33(kts:kte) = ppm2vmr*chem(i,kts:kte,j,p_o3)*dens_air(kts:kte) + o33(ktsm1) = o33(kts) + call z_interp( z_o3_data, o3_data, n_o3_data, & + tuv_z(kte+1:n_tuv_z), o33(kte+1:n_tuv_z) ) + + qll(:) = 0. + qll(kts:kte) = moist(i,kts:kte,j,p_qc) + moist(i,kts:kte,j,p_qi) + if( config_flags%cu_diag == 1 ) then + qll(kts:kte) = qll(kts:kte) + gd_cloud(i,kts:kte,j) + gd_cloud2(i,kts:kte,j) + endif + qll(kts:kte) = 1.e3*rhoa(kts:kte)*qll(kts:kte) + where( qll(kts:kte) < 1.e-5 ) + qll(kts:kte) = 0. + endwhere + + if( haveaer .and. ktau > 1 )then + aerext(ktsm1) = aerext(kts) + else + aerext(ktsm1) = aerwrf(i,kts,j) + endif + + if( .not. is_full_tuv ) then + call xs_int( o3_xs, tlyr, o3_xs_tab ) + call xs_int( no2_xs, tlyr, no2_xs_tab ) + else + call o3xs( nlyr,tlyr,nwave+1,wl,o3_xs_tpose ) + call no2xs_jpl06a( nlyr,tlyr,nwave+1,wl,no2_xs_tpose ) + o3_xs = transpose( o3_xs_tpose ) + no2_xs = transpose( no2_xs_tpose ) + endif + + dtuv_z(ktsm1:n_tuv_z-1) = tuv_z(kts:n_tuv_z) - tuv_z(ktsm1:n_tuv_z-1) + aircol(ktsm1:n_tuv_z-1) = & + km2cm*dtuv_z(ktsm1:n_tuv_z-1) & + *real(sqrt(real(dens_air(kts:n_tuv_z),kind=8)*real(dens_air(ktsm1:n_tuv_z-1),kind=8)),kind=4) +! km2cm*dtuv_z(ktsm1:n_tuv_z-1)*(dens_air(kts:n_tuv_z) - dens_air(ktsm1:n_tuv_z-1)) & +! / log( dens_air(kts:n_tuv_z)/dens_air(ktsm1:n_tuv_z-1) ) + o3col(ktsm1:n_tuv_z-1) = conv1*dtuv_z(ktsm1:n_tuv_z-1)*(o33(kts:n_tuv_z) + o33(ktsm1:n_tuv_z-1)) + o2col(ktsm1:n_tuv_z-1) = o2vmr*aircol(ktsm1:n_tuv_z-1) + if( config_flags%has_o3_exo_coldens ) then + o3col(n_tuv_z-1) = o3col(n_tuv_z-1) + real( o3_exo_col(i,j),4 ) + o2col(n_tuv_z-1) = o2col(n_tuv_z-1) + real( o2_exo_col(i,j),4 ) + aircol(n_tuv_z-1) = aircol(n_tuv_z-1) + o2col(n_tuv_z-1)/o2vmr + endif + if( config_flags%scale_o3_to_grnd_exo_coldens ) then + dobsi = real( o3_exo_col_at_grnd(i,j),4 ) + endif + + so2col(:) = 0. + if( has_so2 ) then + so2col(ktsm1) = conv2*dtuv_z(ktsm1) & + *chem(i,kts,j,p_so2)*(dens_air(ktsm1) + dens_air(kts)) + so2col(kts:ktem1) = conv2*dtuv_z(kts:ktem1) & + *(chem(i,kts:ktem1,j,p_so2)*dens_air(kts:ktem1) & + + chem(i,kts+1:kte,j,p_so2)*dens_air(kts+1:kte)) + endif + no2col(:) = 0. + if( has_no2 ) then + no2col(ktsm1) = conv2*dtuv_z(ktsm1) & + *chem(i,kts,j,p_no2)*(dens_air(ktsm1) + dens_air(kts)) + no2col(kts:ktem1) = conv2*dtuv_z(kts:ktem1) & + *(chem(i,kts:ktem1,j,p_no2)*dens_air(kts:ktem1) & + + chem(i,kts+1:kte,j,p_no2)*dens_air(kts+1:kte)) + endif + + call tuv_radfld( nlambda_start, config_flags%cld_od_opt, cldfrac, & + nlyr, nwave, zenith, tuv_z, albedo, & + aircol, o2col, o3col, so2col, no2col, & + tauaer300, tauaer400, tauaer600, tauaer999, & + waer300, waer400, waer600, waer999, & + gaer300, gaer400, gaer600, gaer999, & + dtaer, omaer, gaer, dtcld, omcld, gcld, & + has_aer_ra_feedback, & + qll, dobsi, o3_xs, no2_xs, o2_xs, & + so2_xs, wl(1), wc, tlev, srb_o2_xs, rad_fld, e_fld, & + e_dir, e_dn, e_up, & + dir_fld, dwn_fld, up_fld, dtcld_col ) + + do k = kts,kte + af_dir(i,k,j) = dot_product( dir_fld(k,nlambda_af_start:nlambda_af_end),dw(nlambda_af_start:nlambda_af_end) ) + af_dn(i,k,j) = dot_product( dwn_fld(k,nlambda_af_start:nlambda_af_end),dw(nlambda_af_start:nlambda_af_end) ) + af_up(i,k,j) = dot_product( up_fld(k,nlambda_af_start:nlambda_af_end),dw(nlambda_af_start:nlambda_af_end) ) + end do + + dt_cld(i,kts:kte,j) = dtcld_col(kts:kte) + wrk(nlambda_start:nwave) = dw(nlambda_start:nwave)*etfl(nlambda_start:nwave) + wrk_lam(nlambda_start:nwave) = wrk(nlambda_start:nwave)*par_wght(nlambda_start:nwave) + par(i,kts:kte,j) = matmul( e_fld(kts:kte,nlambda_start:nwave), wrk_lam(nlambda_start:nwave) ) + wrk_lam(nlambda_start:nwave) = wrk(nlambda_start:nwave)*ery_wght(nlambda_start:nwave) + erythema(i,kts:kte,j) = matmul( e_fld(kts:kte,nlambda_start:nwave), wrk_lam(nlambda_start:nwave) ) + + if( .not. is_full_tuv ) then + if( any( .not. xsqy_is_zdep(:) ) ) then + rad_fld_tpose = transpose( rad_fld ) + endif + elseif( any( xsqy_table(1:nj)%tpflag == 0 ) ) then + rad_fld_tpose = transpose( rad_fld ) + endif + +#ifdef SW_DEBUG + if( tuv_diags ) then + Dobson(1) = sum( o3col(ktsm1:ktem1) )/2.687e16 + Dobson(2) = o3col(kte)/2.687e16 + write(*,'(''tuv_drvr: o3col = '',1p,2g15.8)') Dobson(:) + open(unit=33,file='wrfchm_inp') + write(33,*) nlev + write(33,*) kte + write(33,*) tuv_z(ktsm1:n_tuv_z) + write(33,*) tlev(ktsm1:n_tuv_z) + write(33,*) o3col(ktsm1:n_tuv_z-1) + write(33,*) so2col(ktsm1:n_tuv_z-1) + write(33,*) no2col(ktsm1:n_tuv_z-1) + write(33,*) dens_air(ktsm1:n_tuv_z) + write(33,*) aircol(ktsm1:n_tuv_z-1) + do wn = 1,nwave + write(33,*) dtaer(ktsm1:n_tuv_z-1,wn) + end do + do wn = 1,nwave + write(33,*) omaer(ktsm1:n_tuv_z-1,wn) + end do + do wn = 1,nwave + write(33,*) gaer(ktsm1:n_tuv_z-1,wn) + end do + do wn = 1,nwave + write(33,*) dtcld(ktsm1:n_tuv_z-1,wn) + end do + do wn = 1,nwave + write(33,*) omcld(ktsm1:n_tuv_z-1,wn) + end do + do wn = 1,nwave + write(33,*) gcld(ktsm1:n_tuv_z-1,wn) + end do + write(33,*) zen_angle(i,j) + write(33,*) esfact + write(33,*) dobsi + close( 33 ) + + open(unit=33,file='WRF-TUV.flx.out' ) + do n = nlambda_start,nwave + write(33,*) dir_fld(kts:kte,n) + end do + write(33,*) ' ' + do n = nlambda_start,nwave + write(33,*) dwn_fld(kts:kte,n) + end do + write(33,*) ' ' + do n = nlambda_start,nwave + write(33,*) up_fld(kts:kte,n) + end do + write(33,*) ' ' + do n = nlambda_start,nwave + write(33,*) rad_fld_tpose(kts:kte,n) + end do + close( 33 ) + endif +#endif + +rate_loop: & + do n = 1,nj +!--------------------------------------------------------------------- +! set cross-section x quantum yields +!--------------------------------------------------------------------- + if( n /= j_o2_ndx ) then + if( .not. is_full_tuv ) then + if( xsqy_is_zdep(n) ) then + call xsqy_int( n, xsqy, tlev(kts:kte), dens_air(kts:kte) ) + endif + else + jndx = rxn_ndx(n) + if( jndx /= -1 ) then + if( xsqy_table(jndx)%tpflag /= 0 ) then + call the_subs(jndx)%xsqy_sub(nwave+1,wl,wc,nlev,tlev,dens_air,jndx) + endif + endif + endif + elseif( .not. is_full_tuv ) then + call sjo2( kte, nwave, srb_o2_xs, xsqy ) + endif +!--------------------------------------------------------------------- +! compute tuv photorates +!--------------------------------------------------------------------- + if( .not. is_full_tuv ) then + if( xsqy_is_zdep(n) ) then + do k = kts,kte + xsect(nlambda_start:nwave) = xsqy(nlambda_start:nwave,k)*w_fac(nlambda_start:nwave)*esfact + tuv_prate(k,n) = m2s*dot_product( rad_fld(nlambda_start:nwave,k),xsect(nlambda_start:nwave) ) + end do + else + xsect(nlambda_start:nwave) = xsqy_tab(nlambda_start:nwave,1,1,n)*w_fac(nlambda_start:nwave)*esfact + tuv_prate(:,n) = m2s*matmul( rad_fld_tpose(:,nlambda_start:nwave),xsect(nlambda_start:nwave) ) + endif + else + if( n /= j_o2_ndx ) then + if( xsqy_table(jndx)%tpflag > 0 ) then + do k = kts,kte + xsect(nlambda_start:nwave) = xsqy_table(jndx)%sq(k+1,nlambda_start:nwave)*w_fac(nlambda_start:nwave)*esfact + tuv_prate(k,n) = m2s*dot_product( rad_fld(nlambda_start:nwave,k),xsect(nlambda_start:nwave) ) + end do + else + xsect(nlambda_start:nwave) = xsqy_table(jndx)%sq(nlambda_start:nwave,1)*w_fac(nlambda_start:nwave)*esfact + tuv_prate(:,n) = m2s*matmul( rad_fld_tpose(:,nlambda_start:nwave),xsect(nlambda_start:nwave) ) + endif + else + do k = kts,kte + xsect(nlambda_start:nwave) = srb_o2_xs(nlambda_start:nwave,k)*w_fac(nlambda_start:nwave)*esfact + tuv_prate(k,n) = m2s*dot_product( rad_fld(nlambda_start:nwave,k),xsect(nlambda_start:nwave) ) + end do + endif + endif + end do rate_loop + +#ifdef SW_DEBUG + if( myproc == 6 ) then + if( tuv_diags ) then + open(unit=33,file='WRF-TUV.j.out' ) + do n = 1,nj + select case( n ) + case( 2:4,7:10,12:13 ) + do k = kts,kte,5 + write(33,'(1p,5g15.7)') tuv_prate(k:min(k+4,kte),n)/m2s + end do + if( n < 13 ) then + write(33,*) ' ' + endif + end select + end do + close(33) + call wrf_abort + endif + endif +#endif + endif has_daylight +#if ( WRF_KPP == 1 ) +#include "tuv2wrf_jvals.inc" +#endif + + end do long_loop + end do lat_loop + +#ifdef SW_DEBUG + if( any( zen_angle(its:ite,jts:jte) < 90. ) ) then + min_ndx(:) = minloc( z_top,mask=z_top>0. ) + min_ndx(:) = (/ min_ndx(1) + its - 1,min_ndx(2) + jts - 1 /) + max_ndx(:) = maxloc( z_top,mask=z_top>0. ) + max_ndx(:) = (/ max_ndx(1) + its - 1,max_ndx(2) + jts - 1 /) + write(msg,'(''tuv_driver: z_top min indices = '',2i6)') min_ndx(:) + call wrf_debug( 0,trim(msg) ) + write(msg,'(''tuv_driver: z_top max indices = '',2i6)') max_ndx(:) + call wrf_debug( 0,trim(msg) ) + write(msg,'(''tuv_driver: z_top min,max = '',1p2g15.7)') z_top(min_ndx(1),min_ndx(2)),z_top(max_ndx(1),max_ndx(2)) + call wrf_debug( 0,trim(msg) ) + endif +#endif + + call tuv_deallocate + + ierr = 0 + if( allocated( rad_fld ) ) then + deallocate( rad_fld,stat=astat ) + ierr = ierr + astat + deallocate( dir_fld, dwn_fld, up_fld,stat=astat ) + ierr = ierr + astat + deallocate( e_dir, e_dn, e_up,stat=astat ) + ierr = ierr + astat + endif + if( allocated( rad_fld_tpose ) ) then + deallocate( rad_fld_tpose,stat=astat ) + ierr = ierr + astat + endif + if( allocated( e_fld ) ) then + deallocate( e_fld,stat=astat ) + ierr = ierr + astat + endif + if( allocated( xsqy ) ) then + deallocate( xsqy,stat=astat ) + ierr = ierr + astat + endif + if( allocated( srb_o2_xs ) ) then + deallocate( srb_o2_xs,stat=astat ) + ierr = ierr + astat + endif + + if( allocated( tuv_prate ) ) then + deallocate( tuv_prate,stat=astat ) + ierr = ierr + astat + endif + + if( ierr /= 0 ) then + call wrf_error_fatal( 'tuv_driver: failed to deallocate local variables' ) + endif + + CONTAINS + + subroutine setzgrid( ztop, nexo, zexo_grd ) +!--------------------------------------------------------------------- +! set the vertical grid above model top up to 50 km for photorate +! calculation +!--------------------------------------------------------------------- + + integer, intent(out) :: nexo + real, intent(in) :: ztop + real, intent(out) :: zexo_grd(:) + + real, parameter :: ztrop = 25. + real, parameter :: dztrop = 1. + real, parameter :: zlid = 50. + real, parameter :: dzlid = 5. + + real :: z + real :: zBase + + nexo = 0 + if( ztop >= zlid ) then + return + elseif( ztop <= ztrop ) then + zBase = ztrop + else + zBase = dzlid*real( int(ztop/dzlid) ) + endif + + z = int( ztop ) + do while( z < ztrop ) + z = z + dztrop + nexo = nexo + 1 + zexo_grd(nexo) = z + enddo + + z = zBase + do while( z < zlid ) + z = z + dzlid + nexo = nexo + 1 + zexo_grd(nexo) = z + end do + + end subroutine setzgrid + + subroutine tuv_allocate +!--------------------------------------------------------------------- +! allocate column variables +!--------------------------------------------------------------------- + + allocate( tuv_z(ktsm1:n_tuv_z),dtuv_z(ktsm1:n_tuv_z-1),stat=ierr ) + allocate( cldfrac(ktsm1:n_tuv_z),stat=astat ) + ierr = ierr + astat + allocate( qll(ktsm1:n_tuv_z),stat=astat ) + ierr = ierr + astat + allocate( tlev(ktsm1:n_tuv_z),tlyr(ktsm1:n_tuv_z-1),stat=astat ) + ierr = ierr + astat + allocate( dens_air(ktsm1:n_tuv_z),stat=astat ) + ierr = ierr + astat + allocate( o33(ktsm1:n_tuv_z),stat=astat ) + ierr = ierr + astat + allocate( o3_xs(nwave,ktsm1:n_tuv_z-1),stat=astat ) + ierr = ierr + astat + if( is_full_tuv ) then + allocate( o3_xs_tpose(ktsm1:n_tuv_z-1,nwave),stat=astat ) + ierr = ierr + astat + allocate( no2_xs_tpose(ktsm1:n_tuv_z-1,nwave),stat=astat ) + ierr = ierr + astat + endif + allocate( no2_xs(nwave,ktsm1:n_tuv_z-1),stat=astat ) + ierr = ierr + astat + allocate( aircol(ktsm1:n_tuv_z-1),stat=astat ) + ierr = ierr + astat + allocate( o2col(ktsm1:n_tuv_z-1),stat=astat ) + ierr = ierr + astat + allocate( o3col(ktsm1:n_tuv_z-1),stat=astat ) + ierr = ierr + astat + allocate( no2col(ktsm1:n_tuv_z-1),stat=astat ) + ierr = ierr + astat + allocate( so2col(ktsm1:n_tuv_z-1),stat=astat ) + ierr = ierr + astat + allocate( tauaer300(ktsm1:n_tuv_z-1),tauaer400(ktsm1:n_tuv_z-1), & + tauaer600(ktsm1:n_tuv_z-1),tauaer999(ktsm1:n_tuv_z-1),stat=astat ) + ierr = ierr + astat + allocate( waer300(ktsm1:n_tuv_z-1),waer400(ktsm1:n_tuv_z-1), & + waer600(ktsm1:n_tuv_z-1),waer999(ktsm1:n_tuv_z-1),stat=astat ) + ierr = ierr + astat + allocate( gaer300(ktsm1:n_tuv_z-1),gaer400(ktsm1:n_tuv_z-1), & + gaer600(ktsm1:n_tuv_z-1),gaer999(ktsm1:n_tuv_z-1),stat=astat ) + ierr = ierr + astat + allocate( dtaer(ktsm1:n_tuv_z-1,nwave),omaer(ktsm1:n_tuv_z-1,nwave), & + gaer(ktsm1:n_tuv_z-1,nwave),stat=astat ) + ierr = ierr + astat + allocate( dtcld(ktsm1:n_tuv_z-1,nwave),omcld(ktsm1:n_tuv_z-1,nwave), & + gcld(ktsm1:n_tuv_z-1,nwave),stat=astat ) + ierr = ierr + astat + + if( ierr /= 0 ) then + call wrf_error_fatal( 'tuv_driver: failed to allocate column variables' ) + endif + + end subroutine tuv_allocate + + subroutine tuv_deallocate +!--------------------------------------------------------------------- +! deallocate column variables +!--------------------------------------------------------------------- + + integer :: astat, ierr + + ierr = 0 + if( allocated( tuv_z ) ) then + deallocate( tuv_z,stat=astat ) + ierr = ierr + astat + endif + if( allocated( dtuv_z ) ) then + deallocate( dtuv_z,stat=astat ) + ierr = ierr + astat + endif + if( allocated( cldfrac ) ) then + deallocate( cldfrac,stat=astat ) + ierr = ierr + astat + endif + if( allocated( qll ) ) then + deallocate( qll,stat=astat ) + ierr = ierr + astat + endif + if( allocated( tlev ) ) then + deallocate( tlev,stat=astat ) + ierr = ierr + astat + endif + if( allocated( tlyr ) ) then + deallocate( tlyr,stat=astat ) + ierr = ierr + astat + endif + if( allocated( dens_air ) ) then + deallocate( dens_air,stat=astat ) + ierr = ierr + astat + endif + if( allocated( o33 ) ) then + deallocate( o33,stat=astat ) + ierr = ierr + astat + endif + if( allocated( o3_xs ) ) then + deallocate( o3_xs,stat=astat ) + ierr = ierr + astat + endif + if( allocated( o3_xs_tpose ) ) then + deallocate( o3_xs_tpose,stat=astat ) + ierr = ierr + astat + endif + if( allocated( no2_xs ) ) then + deallocate( no2_xs,stat=astat ) + ierr = ierr + astat + endif + if( allocated( no2_xs_tpose ) ) then + deallocate( no2_xs_tpose,stat=astat ) + ierr = ierr + astat + endif + if( allocated( aircol ) ) then + deallocate( aircol,stat=astat ) + ierr = ierr + astat + endif + if( allocated( o2col ) ) then + deallocate( o2col,stat=astat ) + ierr = ierr + astat + endif + if( allocated( o3col ) ) then + deallocate( o3col,stat=astat ) + ierr = ierr + astat + endif + if( allocated( no2col ) ) then + deallocate( no2col,stat=astat ) + ierr = ierr + astat + endif + if( allocated( so2col ) ) then + deallocate( so2col,stat=astat ) + ierr = ierr + astat + endif + if( allocated( tauaer300 ) ) then + deallocate( tauaer300, waer300, gaer300,stat=astat ) + ierr = ierr + astat + endif + if( allocated( tauaer400 ) ) then + deallocate( tauaer400, waer400, gaer400,stat=astat ) + ierr = ierr + astat + endif + if( allocated( tauaer600 ) ) then + deallocate( tauaer600, waer600, gaer600,stat=astat ) + ierr = ierr + astat + endif + if( allocated( tauaer999 ) ) then + deallocate( tauaer999, waer999, gaer999,stat=astat ) + ierr = ierr + astat + endif + if( allocated( dtcld ) ) then + deallocate( dtcld, omcld, gcld,stat=astat ) + ierr = ierr + astat + endif + if( allocated( dtaer ) ) then + deallocate( dtaer, omaer, gaer,stat=astat ) + ierr = ierr + astat + endif + + if( ierr /= 0 ) then + call wrf_error_fatal( 'tuv_deallocate: failed to deallocate all variables' ) + endif + + end subroutine tuv_deallocate + + end subroutine tuv_driver + + subroutine tuv_init( & + domain, config_flags, z_at_w, aerwrf, g, & + af_lambda_start, af_lambda_end, start_lambda, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + + USE module_configure + USE params_mod, only : lambda_cutoff + USE srb, only : init_srb + USE module_state_description, only : p_so2, p_no2, param_first_scalar + USE module_rxn, only : rxn_init, xsqy_table => xsqy_tab, npht_tab + USE module_rxn, only : get_initialization + + ! .. Scalar Arguments .. + INTEGER, INTENT (IN) :: domain + INTEGER, INTENT (IN) :: ide, ids, ime, ims, ite, its, jde, jds, & + jme, jms, jte, jts, kde, kds, kme, kms, kte, kts + REAL, INTENT (IN) :: g + REAL, INTENT (IN) :: af_lambda_start, af_lambda_end, start_lambda + ! .. Array Arguments .. + REAL, INTENT (INOUT) :: aerwrf(ims:ime,kms:kme,jms:jme) + REAL, INTENT (IN) :: z_at_w(ims:ime,kms:kme,jms:jme) + + TYPE(grid_config_rec_type), INTENT(IN) :: config_flags + + ! .. Local Scalars .. + INTEGER :: astat + INTEGER :: i, j, k, n, wn + ! .. Local Arrays .. + CHARACTER(len=256) :: msg + +#ifndef NETCDF + call wrf_error_fatal( 'tuv_init: requires netcdf' ) +#endif + + DO j = jts, min(jte,jde-1) + DO k = kts, min(kte,kde-1) + DO i = its, min(ite,ide-1) + aerwrf(i,k,j) = 0. + END DO + END DO + END DO + + +is_initialized: & + if( .not. tuv_is_initialized ) then + has_exo_coldens = config_flags%has_o3_exo_coldens .or. config_flags%scale_o3_to_grnd_exo_coldens + is_full_tuv = config_flags%is_full_tuv +#if ( WRF_KPP == 1 ) +#include "tuvdef_jvals.inc" +#endif + call get_xsqy_tab + if( .not. is_full_tuv ) then + allocate( xsqy_is_zdep(nj),stat=astat ) + if( astat /= 0 ) then + call wrf_error_fatal( 'tuv_init: failed to allocate xsqy_is_zdep' ) + endif + xsqy_is_zdep(:) = .false. + if( j_o2_ndx > 0 ) then + xsqy_is_zdep(j_o2_ndx) = .true. + endif + do n = 1,nj + if( n /= j_o2_ndx ) then +t_loop : do j = 1,nconc + do i = 1,ntemp + if( any( xsqy_tab(:,i,j,n) /= xsqy_tab(:,1,1,n) ) ) then + xsqy_is_zdep(n) = .true. + exit t_loop + endif + end do + end do t_loop + endif + end do + endif + has_so2 = p_so2 >= param_first_scalar + has_no2 = p_no2 >= param_first_scalar + call init_srb +!--------------------------------------------------------------------- +! ... locate starting wave bin +!--------------------------------------------------------------------- + lambda_cutoff = start_lambda + do nlambda_start = 1,nwave + if( wc(nlambda_start) >= lambda_cutoff ) then + exit + endif + end do + if( nlambda_start > nwave ) then + write(msg,'(''tuv_init: '',1pg15.7,'' is not in photo wavelength interval ('',g15.7,'','',g15.7,'')'')') & + lambda_cutoff,wl(1),wl(nwave+1) + call wrf_error_fatal( trim(msg) ) + endif +!--------------------------------------------------------------------- +! ... locate af output wave bins +!--------------------------------------------------------------------- + do nlambda_af_start = nlambda_start,nwave + if( wl(nlambda_af_start) <= af_lambda_start .and. & + wl(nlambda_af_start+1) >= af_lambda_start ) then + exit + endif + end do + do nlambda_af_end = nlambda_start,nwave + if( wl(nlambda_af_end) <= af_lambda_end .and. & + wl(nlambda_af_end+1) >= af_lambda_end ) then + exit + endif + end do + allocate( par_wght(nwave), ery_wght(nwave), stat=astat ) + if( astat /= 0 ) then + call wrf_error_fatal( 'tuv_init: failed to allocate par_wght,ery_wght' ) + endif +!--------------------------------------------------------------------- +! ... set PAR weight +!--------------------------------------------------------------------- + where (wc(:) > 400. .AND. wc(:) < 700.) + par_wght(:) = 8.36e-3 * wc(:) + elsewhere + par_wght(:) = 0. + end where +!--------------------------------------------------------------------- +! ... set erythema weight +!--------------------------------------------------------------------- + call fery( nwave, wc, ery_wght ) +!--------------------------------------------------------------------- +! ... set surface albedo +!--------------------------------------------------------------------- + DO wn = 1,nwave + IF (wl(wn)<400.) then + albedo(wn) = 0.05 + elseIF (wl(wn)>=400. .AND. wl(wn)<450.) then + albedo(wn) = 0.06 + elseIF (wl(wn)>=450. .AND. wl(wn)<500.) then + albedo(wn) = 0.08 + elseIF (wl(wn)>=500. .AND. wl(wn)<550.) then + albedo(wn) = 0.10 + elseIF (wl(wn)>=550. .AND. wl(wn)<600.) then + albedo(wn) = 0.11 + elseIF (wl(wn)>=600. .AND. wl(wn)<640.) then + albedo(wn) = 0.12 + elseIF (wl(wn)>=640. .AND. wl(wn)<660.) then + albedo(wn) = 0.135 + elseIF (wl(wn)>=660.) then + albedo(wn) = 0.15 + endIF + END DO +!--------------------------------------------------------------------- +! ... if full TUV then initialize +!--------------------------------------------------------------------- + if( is_full_tuv ) then + call rxn_init( nwave+1,wl ) + allocate( rxn_ndx(nj),stat=astat ) + if( astat /= 0 ) then + call wrf_error_fatal( 'tuv_init: failed to allocate rxn_ndx' ) + endif + rxn_ndx(1:nj) = -1 + do j = 1,nj + if( j /= j_o2_ndx ) then + do n = 2,npht_tab + if( trim(xsqy_table(n)%wrf_label) == trim(tuv_jname(j)) ) then + rxn_ndx(j) = n + exit + endif + enddo + endif + enddo + rxn_initialized = .not. get_initialization() + endif + tuv_is_initialized = .true. + endif is_initialized + +!--------------------------------------------------------------------- +! ... get exo model column densities +!--------------------------------------------------------------------- + if( has_exo_coldens ) then + call get_exo_coldens( domain, config_flags%exo_coldens_inname, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) + endif + + end subroutine tuv_init + + subroutine get_xsqy_tab +!--------------------------------------------------------------------- +! ... read in the cross section,quantum yield tables +!--------------------------------------------------------------------- + + use params_mod, only : hc + use srb, only : ila, isrb + use srb, only : nchebev_term, nchebev_wave + use srb, only : chebev_ac, chebev_bc + +!--------------------------------------------------------------------- +! ... local variables +!--------------------------------------------------------------------- + integer :: astat, ierr + integer :: m + integer :: ncid, dimid, varid + character(len=132) :: filename + character(len=132) :: err_msg + character(len=64) :: varname + +#ifdef NETCDF +include 'netcdf.inc' + +!--------------------------------------------------------------------- +! ... function declarations +!--------------------------------------------------------------------- + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + +master_proc_a: & + if( wrf_dm_on_monitor() ) then + filename = 'wrf_tuv_xsqy.nc' + err_msg = 'get_xsqy_tab: failed to open file ' // trim(filename) + call handle_ncerr( nf_open( trim(filename), nf_noclobber, ncid ), trim(err_msg) ) +!--------------------------------------------------------------------- +! ... get dimensions +!--------------------------------------------------------------------- + err_msg = 'get_xsqy_tab: failed to get nwave id' + call handle_ncerr( nf_inq_dimid( ncid, 'nwave', dimid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get nwave' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, nwave ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get ntemp id' + call handle_ncerr( nf_inq_dimid( ncid, 'ntemp', dimid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get ntemp' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, ntemp ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get nconc id' + call handle_ncerr( nf_inq_dimid( ncid, 'nconc', dimid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get nconc' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, nconc ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get nchebev_term id' + call handle_ncerr( nf_inq_dimid( ncid, 'nchebev_term', dimid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get nchebev' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, nchebev_term ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get nchebev_wave id' + call handle_ncerr( nf_inq_dimid( ncid, 'nchebev_wave', dimid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get nchebev' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, nchebev_wave ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get n_temp_data id' + call handle_ncerr( nf_inq_dimid( ncid, 'n_temp_data', dimid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get n_temp_data' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, n_temp_data ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get n_o3_data id' + call handle_ncerr( nf_inq_dimid( ncid, 'n_o3_data', dimid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get n_o3_data' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, n_o3_data ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get n_air_dens_data id' + call handle_ncerr( nf_inq_dimid( ncid, 'n_air_dens_data', dimid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get n_air_dens_data' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, n_air_dens_data ), trim(err_msg) ) + endif master_proc_a +#ifdef DM_PARALLEL +!--------------------------------------------------------------------- +! ... bcast the dimensions +!--------------------------------------------------------------------- + CALL wrf_dm_bcast_bytes ( nwave, IWORDSIZE ) + CALL wrf_dm_bcast_bytes ( ntemp, IWORDSIZE ) + CALL wrf_dm_bcast_bytes ( nconc, IWORDSIZE ) + CALL wrf_dm_bcast_bytes ( n_temp_data, IWORDSIZE ) + CALL wrf_dm_bcast_bytes ( n_o3_data, IWORDSIZE ) + CALL wrf_dm_bcast_bytes ( n_air_dens_data, IWORDSIZE ) + CALL wrf_dm_bcast_bytes ( nchebev_term, IWORDSIZE ) + CALL wrf_dm_bcast_bytes ( nchebev_wave, IWORDSIZE ) +#endif +!--------------------------------------------------------------------- +! ... allocate module arrays +!--------------------------------------------------------------------- + ierr = 0 + allocate( z_temp_data(n_temp_data), z_o3_data(n_o3_data), & + z_air_dens_data(n_air_dens_data),stat=astat ) + ierr = astat + ierr + allocate( temp_data(n_temp_data), o3_data(n_o3_data), & + air_dens_data(n_air_dens_data),stat=astat ) + ierr = astat + ierr + allocate( wl(nwave+1), wc(nwave), dw(nwave), w_fac(nwave), & + etfl(nwave), albedo(nwave), stat=astat ) + ierr = astat + ierr + if( .not. is_full_tuv ) then + allocate( temp_tab(ntemp), conc_tab(nconc), stat=astat ) + ierr = astat + ierr + allocate( del_temp_tab(ntemp-1), del_conc_tab(nconc-1), stat=astat ) + ierr = astat + ierr + endif + allocate( chebev_ac(nchebev_term,nchebev_wave), stat=astat ) + ierr = astat + ierr + allocate( chebev_bc(nchebev_term,nchebev_wave), stat=astat ) + ierr = astat + ierr + allocate( o2_xs(nwave), so2_xs(nwave), stat=astat ) + ierr = astat + ierr + allocate( o3_xs_tab(nwave,ntemp), no2_xs_tab(nwave,ntemp), stat=astat ) + ierr = astat + ierr + if( .not. is_full_tuv ) then + allocate( xsqy_tab(nwave,ntemp,nconc,nj), stat=astat ) + ierr = astat + ierr + endif + if( ierr /= 0 ) then + call wrf_error_fatal( 'tuv_init: failed to allocate z_temp_data ... xsqy_tab' ) + endif +!--------------------------------------------------------------------- +! ... read arrays +!--------------------------------------------------------------------- +master_proc_b: & + if( wrf_dm_on_monitor() ) then + err_msg = 'get_xsqy_tab: failed to get z_temp_data variable id' + call handle_ncerr( nf_inq_varid( ncid, 'z_temp_data', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read z_temp_data variable' + call handle_ncerr( nf_get_var_real( ncid, varid, z_temp_data ), trim(err_msg) ) + + err_msg = 'get_xsqy_tab: failed to get z_o3_data variable id' + call handle_ncerr( nf_inq_varid( ncid, 'z_o3_data', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read z_o3_data variable' + call handle_ncerr( nf_get_var_real( ncid, varid, z_o3_data ), trim(err_msg) ) + + err_msg = 'get_xsqy_tab: failed to get z_air_dens_data variable id' + call handle_ncerr( nf_inq_varid( ncid, 'z_air_dens_data', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read z_air_dens_data variable' + call handle_ncerr( nf_get_var_real( ncid, varid, z_air_dens_data ), trim(err_msg) ) + + err_msg = 'get_xsqy_tab: failed to get temp_data variable id' + call handle_ncerr( nf_inq_varid( ncid, 'temp_data', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read temp_data variable' + call handle_ncerr( nf_get_var_real( ncid, varid, temp_data ), trim(err_msg) ) + + err_msg = 'get_xsqy_tab: failed to get o3_data variable id' + call handle_ncerr( nf_inq_varid( ncid, 'o3_data', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read o3_data variable' + call handle_ncerr( nf_get_var_real( ncid, varid, o3_data ), trim(err_msg) ) + + err_msg = 'get_xsqy_tab: failed to get air_dens_data variable id' + call handle_ncerr( nf_inq_varid( ncid, 'air_dens_data', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read air_dens_data variable' + call handle_ncerr( nf_get_var_real( ncid, varid, air_dens_data ), trim(err_msg) ) + + err_msg = 'get_xsqy_tab: failed to get wl variable id' + call handle_ncerr( nf_inq_varid( ncid, 'wl', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read wl variable' + call handle_ncerr( nf_get_var_real( ncid, varid, wl ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get wc variable id' + call handle_ncerr( nf_inq_varid( ncid, 'wc', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read wc variable' + call handle_ncerr( nf_get_var_real( ncid, varid, wc ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get etfl variable id' + call handle_ncerr( nf_inq_varid( ncid, 'etf', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read etfl variable' + call handle_ncerr( nf_get_var_real( ncid, varid, etfl ), trim(err_msg) ) + + err_msg = 'get_xsqy_tab: failed to get chebev_ac variable id' + call handle_ncerr( nf_inq_varid( ncid, 'chebev_ac', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read chebev_ac variable' + call handle_ncerr( nf_get_var_double( ncid, varid, chebev_ac ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to get chebev_bc variable id' + call handle_ncerr( nf_inq_varid( ncid, 'chebev_bc', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read chebev_bc variable' + call handle_ncerr( nf_get_var_double( ncid, varid, chebev_bc ), trim(err_msg) ) + + err_msg = 'get_xsqy_tab: failed to get ila variable id' + call handle_ncerr( nf_inq_varid( ncid, 'ila', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read ila variable' + call handle_ncerr( nf_get_var_int( ncid, varid, ila ), trim(err_msg) ) + + err_msg = 'get_xsqy_tab: failed to get isrb variable id' + call handle_ncerr( nf_inq_varid( ncid, 'isrb', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read isrb variable' + call handle_ncerr( nf_get_var_int( ncid, varid, isrb ), trim(err_msg) ) + + if( .not. is_full_tuv ) then + err_msg = 'get_xsqy_tab: failed to temp_tab variable id' + call handle_ncerr( nf_inq_varid( ncid, 'temps', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read temp_tab variable' + call handle_ncerr( nf_get_var_real( ncid, varid, temp_tab ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to conc_tab variable id' + call handle_ncerr( nf_inq_varid( ncid, 'concs', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read conc_tab variable' + call handle_ncerr( nf_get_var_real( ncid, varid, conc_tab ), trim(err_msg) ) + endif + err_msg = 'get_xsqy_tab: failed to o2_xs variable id' + call handle_ncerr( nf_inq_varid( ncid, 'o2_xs', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read o2_xs variable' + call handle_ncerr( nf_get_var_real( ncid, varid, o2_xs ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to so2_xs variable id' + call handle_ncerr( nf_inq_varid( ncid, 'so2_xs', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read so2_xs variable' + call handle_ncerr( nf_get_var_real( ncid, varid, so2_xs ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to o3_xs_tab variable id' + call handle_ncerr( nf_inq_varid( ncid, 'o3_xs', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read o3_xs_tab variable' + call handle_ncerr( nf_get_var_real( ncid, varid, o3_xs_tab ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to no2_xs_tab variable id' + call handle_ncerr( nf_inq_varid( ncid, 'no2_xs', varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read no2_xs_tab variable' + call handle_ncerr( nf_get_var_real( ncid, varid, no2_xs_tab ), trim(err_msg) ) + if( .not. is_full_tuv ) then + do m = 1,nj + varname = trim(tuv_jname(m)) // '_xsqy' + err_msg = 'get_xsqy_tab: failed to ' // trim(varname) //' variable id' + call handle_ncerr( nf_inq_varid( ncid, trim(varname), varid ), trim(err_msg) ) + err_msg = 'get_xsqy_tab: failed to read ' // trim(varname) // ' variable' + call handle_ncerr( nf_get_var_real( ncid, varid, xsqy_tab(:,:,:,m) ), trim(err_msg) ) + end do + endif + endif master_proc_b + +#ifdef DM_PARALLEL +!--------------------------------------------------------------------- +! ... bcast the arrays +!--------------------------------------------------------------------- + CALL wrf_dm_bcast_bytes ( ila, IWORDSIZE ) + CALL wrf_dm_bcast_bytes ( isrb, IWORDSIZE ) + CALL wrf_dm_bcast_bytes( wl, (nwave+1)*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( wc, nwave*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( etfl, nwave*RWORDSIZE ) + if( .not. is_full_tuv ) then + CALL wrf_dm_bcast_bytes( temp_tab, ntemp*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( conc_tab, nconc*RWORDSIZE ) + endif + CALL wrf_dm_bcast_bytes( o2_xs, nwave*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( so2_xs, nwave*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( z_temp_data, n_temp_data*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( z_o3_data, n_o3_data*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( z_air_dens_data, n_air_dens_data*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( temp_data, n_temp_data*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( o3_data, n_o3_data*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( air_dens_data, n_air_dens_data*RWORDSIZE ) +#if RWORDSIZE == 4 + CALL wrf_dm_bcast_bytes( chebev_ac, nchebev_term*nchebev_wave*2*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( chebev_bc, nchebev_term*nchebev_wave*2*RWORDSIZE ) +#endif +#if RWORDSIZE == 8 + CALL wrf_dm_bcast_bytes( chebev_ac, nchebev_term*nchebev_wave*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( chebev_bc, nchebev_term*nchebev_wave*RWORDSIZE ) +#endif + CALL wrf_dm_bcast_bytes( o3_xs_tab, nwave*ntemp*RWORDSIZE ) + CALL wrf_dm_bcast_bytes( no2_xs_tab, nwave*ntemp*RWORDSIZE ) + if( .not. is_full_tuv ) then + CALL wrf_dm_bcast_bytes( xsqy_tab, nwave*ntemp*nconc*nj*RWORDSIZE ) + endif +#endif + + if( .not. is_full_tuv ) then + del_temp_tab(:ntemp-1) = 1./(temp_tab(2:ntemp) - temp_tab(1:ntemp-1)) + del_conc_tab(:nconc-1) = 1./(conc_tab(2:nconc) - conc_tab(1:nconc-1)) + endif + dw(:nwave) = wl(2:nwave+1) - wl(1:nwave) + w_fac(:nwave) = dw(:nwave)*etfl(:nwave)*1.e-13*wc(:nwave)/hc + + if( wrf_dm_on_monitor() ) then + err_msg = 'get_xsqy_tab: failed to close file ' // trim(filename) + call handle_ncerr( nf_close( ncid ),trim(err_msg) ) + endif +#endif + + end subroutine get_xsqy_tab + + subroutine get_exo_coldens( dm, exo_coldens_filename, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) +!--------------------------------------------------------------------- +! ... read in the exo column o2,o3 densities +!--------------------------------------------------------------------- + +!--------------------------------------------------------------------- +! ... dummy arguments +!--------------------------------------------------------------------- + integer, intent(in) :: dm + integer, intent(in) :: ide, ids, ime, ims, ite, its, jde, jds, & + jme, jms, jte, jts, kde, kds, kme, kms, kte, kts + character(len=*), intent(in) :: exo_coldens_filename + +!--------------------------------------------------------------------- +! ... local variables +!--------------------------------------------------------------------- + INTEGER :: i, j, k + integer :: astat + integer :: ncid + integer :: dimid + integer :: varid + integer :: max_dom + integer :: cpos + integer :: iend, jend + integer :: lon_e, lat_e + integer :: ncoldens_levs + integer :: ndays_of_year +! real, allocatable :: coldens(:,:,:,:) + character(len=128) :: err_msg + character(len=64) :: filename + character(len=2) :: id_num + +!--------------------------------------------------------------------- +! ... function declarations +!--------------------------------------------------------------------- + LOGICAL, EXTERNAL :: wrf_dm_on_monitor + +#ifdef NETCDF +include 'netcdf.inc' +#define DM_BCAST_MACRO(A) CALL wrf_dm_bcast_bytes ( A , size ( A ) * DWORDSIZE ) + +!--------------------------------------------------------------------- +! ... allocate column_density type +!--------------------------------------------------------------------- + if( .not. allocated(col_dens) ) then + CALL nl_get_max_dom( 1,max_dom ) + allocate( col_dens(max_dom),stat=astat ) + if( astat /= 0 ) then + call wrf_error_fatal( 'get_exo_coldens: failed to allocate col_dens' ) + endif + write(err_msg,'(''get_exo_coldens: intializing '',i2,'' domains'')') max_dom + call wrf_message( trim(err_msg) ) + col_dens(:)%is_allocated = .false. + endif +!--------------------------------------------------------------------- +! ... open column density netcdf file +!--------------------------------------------------------------------- +col_dens_allocated : & + if( .not. col_dens(dm)%is_allocated ) then +! if( wrf_dm_on_monitor() ) then + cpos = index( exo_coldens_filename, '' ) + if( cpos > 0 ) then + write(id_num,'(i2.2)') dm + filename = exo_coldens_filename(:cpos-1) // 'd' // id_num + else + filename = trim( exo_coldens_filename ) + endif + err_msg = 'get_exo_coldens: intializing domain ' // id_num + call wrf_message( trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to open file ' // trim(filename) + call handle_ncerr( nf_open( trim(filename), nf_noclobber, ncid ), trim(err_msg) ) +!--------------------------------------------------------------------- +! ... get dimensions +!--------------------------------------------------------------------- + err_msg = 'get_exo_coldens: failed to get col_dens levels id' + call handle_ncerr( nf_inq_dimid( ncid, 'coldens_levs', dimid ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to get col_dens levels' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, ncoldens_levs ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to get number of days in year id' + call handle_ncerr( nf_inq_dimid( ncid, 'ndays_of_year', dimid ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to get number of days in year' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, ndays_of_year ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to get west_east id' + call handle_ncerr( nf_inq_dimid( ncid, 'west_east', dimid ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to get west_east' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, lon_e ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to get south_north id' + call handle_ncerr( nf_inq_dimid( ncid, 'south_north', dimid ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to get south_north' + call handle_ncerr( nf_inq_dimlen( ncid, dimid, lat_e ), trim(err_msg) ) +! end IF +#ifdef DM_PARALLEL +!--------------------------------------------------------------------- +! ... bcast the dimensions +!--------------------------------------------------------------------- +! CALL wrf_dm_bcast_bytes ( ncoldens_levs , IWORDSIZE ) +! CALL wrf_dm_bcast_bytes ( ndays_of_year , IWORDSIZE ) +! CALL wrf_dm_bcast_bytes ( lon_e , IWORDSIZE ) +! CALL wrf_dm_bcast_bytes ( lat_e , IWORDSIZE ) +#endif +!--------------------------------------------------------------------- +! ... allocate local arrays +!--------------------------------------------------------------------- + iend = min( ite,ide-1 ) + jend = min( jte,jde-1 ) +! allocate( coldens(lon_e,lat_e,ncoldens_levs,ndays_of_year), stat=astat ) +! if( astat /= 0 ) then +! call wrf_error_fatal( 'get_exo_coldens: failed to allocate coldens' ) +! end if +!--------------------------------------------------------------------- +! ... allocate column_density type component arrays +!--------------------------------------------------------------------- + col_dens(dm)%ncoldens_levs = ncoldens_levs + col_dens(dm)%ndays_of_year = ndays_of_year + allocate( col_dens(dm)%col_levs(ncoldens_levs), & + col_dens(dm)%day_of_year(ndays_of_year), stat=astat ) + if( astat /= 0 ) then + call wrf_error_fatal( 'get_exo_coldens: failed to allocate col_levs,day_of_year' ) + end if + allocate( col_dens(dm)%o3_col_dens(its:iend,jts:jend,ncoldens_levs,ndays_of_year), & + col_dens(dm)%o2_col_dens(its:iend,jts:jend,ncoldens_levs,ndays_of_year), stat=astat ) + if( astat /= 0 ) then + call wrf_error_fatal( 'get_exo_coldens: failed to allocate o3_col_dens,o2_col_dens' ) + end if + col_dens(dm)%is_allocated = .true. +!--------------------------------------------------------------------- +! ... read arrays +!--------------------------------------------------------------------- +! IF ( wrf_dm_on_monitor() ) THEN + err_msg = 'get_exo_coldens: failed to get col_levs variable id' + call handle_ncerr( nf_inq_varid( ncid, 'coldens_levs', varid ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to read col_levs variable' + call handle_ncerr( nf_get_var_double( ncid, varid, col_dens(dm)%col_levs ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to get days_of_year variable id' + call handle_ncerr( nf_inq_varid( ncid, 'days_of_year', varid ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to read days_of_year variable' + call handle_ncerr( nf_get_var_double( ncid, varid, col_dens(dm)%day_of_year ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to get o3 col_dens variable id' + call handle_ncerr( nf_inq_varid( ncid, 'o3_column_density', varid ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to read o3 col_dens variable' +! call handle_ncerr( nf_get_var_real( ncid, varid, coldens ), trim(err_msg) ) + call handle_ncerr( nf_get_vara_double( ncid, varid, (/its,jts,1,1/), & + (/iend-its+1,jend-jts+1,ncoldens_levs,ndays_of_year/), & + col_dens(dm)%o3_col_dens(its:iend,jts:jend,1:ncoldens_levs,1:ndays_of_year) ), trim(err_msg) ) +! ENDIF + +#ifdef DM_PARALLEL +! call wrf_debug( 0,'get_exo_coldens: bcast col_levs' ) +! DM_BCAST_MACRO(col_dens(dm)%col_levs) +! call wrf_debug( 0,'get_exo_coldens: bcast day_of_year' ) +! DM_BCAST_MACRO(col_dens(dm)%day_of_year) +! call wrf_debug( 0,'get_exo_coldens: bcast o3_col_dens' ) +! CALL wrf_dm_bcast_bytes ( coldens, size(coldens)*RWORDSIZE ) +#endif + +! col_dens(dm)%o3_col_dens(its:iend,jts:jend,:ncoldens_levs,:ndays_of_year) = & +! coldens(its:iend,jts:jend,:ncoldens_levs,:ndays_of_year) + +! IF ( wrf_dm_on_monitor() ) THEN + err_msg = 'get_exo_coldens: failed to get o2 col_dens variable id' + call handle_ncerr( nf_inq_varid( ncid, 'o2_column_density', varid ), trim(err_msg) ) + err_msg = 'get_exo_coldens: failed to read o2 col_dens variable' +! call handle_ncerr( nf_get_var_real( ncid, varid, coldens ), trim(err_msg) ) + call handle_ncerr( nf_get_vara_double( ncid, varid, (/its,jts,1,1/), & + (/iend-its+1,jend-jts+1,ncoldens_levs,ndays_of_year/), & + col_dens(dm)%o2_col_dens(its:iend,jts:jend,1:ncoldens_levs,1:ndays_of_year) ), trim(err_msg) ) +!--------------------------------------------------------------------- +! ... close column density netcdf file +!--------------------------------------------------------------------- + err_msg = 'get_exo_coldens: failed to close file ' // trim(filename) + call handle_ncerr( nf_close( ncid ), trim(err_msg) ) +! end if + +#ifdef DM_PARALLEL +! call wrf_debug( 0,'get_exo_coldens: bcast o2_col_dens' ) +! CALL wrf_dm_bcast_bytes ( coldens, size(coldens)*RWORDSIZE ) +#endif + +! col_dens(dm)%o2_col_dens(its:iend,jts:jend,:ncoldens_levs,:ndays_of_year) = & +! coldens(its:iend,jts:jend,:ncoldens_levs,:ndays_of_year) + +! deallocate( coldens ) + +!--------------------------------------------------------------------- +! ... some diagnostics +!--------------------------------------------------------------------- + call wrf_debug( 100,' ' ) + write(err_msg,'(''get_exo_coldens: coldens variables for domain '',i2)') dm + call wrf_debug( 100,trim(err_msg) ) + call wrf_debug( 100,'get_exo_coldens: days_of_year' ) + do k = 1,ndays_of_year,5 + write(err_msg,'(1p,5g15.7)') col_dens(dm)%day_of_year(k:min(k+4,ndays_of_year)) + call wrf_debug( 100,trim(err_msg) ) + end do + call wrf_debug( 100,'get_exo_coldens: coldens levels' ) + do k = 1,ncoldens_levs,5 + write(err_msg,'(1p,5g15.7)') col_dens(dm)%col_levs(k:min(k+4,ncoldens_levs)) + call wrf_debug( 100,trim(err_msg) ) + end do + call wrf_debug( 100,' ' ) + endif col_dens_allocated +#endif + + end subroutine get_exo_coldens + + subroutine tuv_timestep_init( dm, julday ) +!----------------------------------------------------------------------------- +! ... setup the exo column time interpolation +!----------------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + integer, intent(in) :: dm ! domain number + integer, intent(in) :: julday ! day of year at present time step + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + integer :: m + real(dp) :: calday + + calday = real( julday,kind=dp) + if( calday < col_dens(dm)%day_of_year(1) ) then + next = 1 + last = 12 + dels = (365._dp + calday - col_dens(dm)%day_of_year(12)) & + / (365._dp + col_dens(dm)%day_of_year(1) - col_dens(dm)%day_of_year(12)) + else if( calday >= col_dens(dm)%day_of_year(12) ) then + next = 1 + last = 12 + dels = (calday - col_dens(dm)%day_of_year(12)) & + / (365. + col_dens(dm)%day_of_year(1) - col_dens(dm)%day_of_year(12)) + else + do m = 11,1,-1 + if( calday >= col_dens(dm)%day_of_year(m) ) then + exit + end if + end do + last = m + next = m + 1 + dels = (calday - col_dens(dm)%day_of_year(m)) / (col_dens(dm)%day_of_year(m+1) - col_dens(dm)%day_of_year(m)) + end if + + end subroutine tuv_timestep_init + + subroutine z_interp( z_tab, tab, ntab, z_out, out ) + + integer, intent(in) :: ntab + real, intent(in) :: z_tab(ntab) + real, intent(in) :: tab(ntab) + real, intent(in) :: z_out(:) + real, intent(out) :: out(:) +!--------------------------------------------------------------- +! ... altitude interpolation +!--------------------------------------------------------------- + + integer :: k, kt, ktm1, n + real :: delz + + n = size(out) + do k = 1,n + if( z_out(k) <= z_tab(1) ) then + out(k) = z_tab(1) + elseif( z_out(k) >= z_tab(ntab) ) then + out(k) = z_tab(ntab) + else + do kt = 1,ntab + if( z_tab(kt) >= z_out(k) ) then + ktm1 = kt - 1 + delz = (z_out(k) - z_tab(ktm1))/(z_tab(kt) - z_tab(ktm1)) + out(k) = tab(ktm1) + delz*(tab(kt) - tab(ktm1)) + exit + endif + end do + endif + end do + + end subroutine z_interp + + subroutine p_interp( o2_exo_col, o3_exo_col, o3_exo_col_at_grnd, ptop, & + dm, its, ite, jts, jte ) +!--------------------------------------------------------------- +! ... pressure interpolation for exo col density +!--------------------------------------------------------------- + + implicit none + +!--------------------------------------------------------------- +! ... dummy arguments +!--------------------------------------------------------------- + integer, intent(in) :: dm + integer, intent(in) :: its, ite + integer, intent(in) :: jts, jte + real(dp), intent(in) :: ptop(its:ite,jts:jte) ! pressure at photolysis top (hPa) + real(dp), intent(out) :: o2_exo_col(its:ite,jts:jte) ! exo model o2 column density (molecules/cm^2) + real(dp), intent(out) :: o3_exo_col(its:ite,jts:jte) ! exo model o3 column density (molecules/cm^2) + real(dp), intent(out) :: o3_exo_col_at_grnd(its:ite,jts:jte) ! exo model o3 column density at grnd (molecules/cm^2) + +!--------------------------------------------------------------- +! ... local variables +!--------------------------------------------------------------- + integer :: i, j, k, ku, kl + integer :: Kgrnd + real(dp) :: pinterp + real(dp) :: delp + real(dp) :: tint_vals(2) + + Kgrnd = col_dens(dm)%ncoldens_levs + +lat_loop : & + do j = jts,jte +long_loop : & + do i = its,ite + pinterp = ptop(i,j) + if( pinterp < col_dens(dm)%col_levs(1) ) then + ku = 1 + kl = 1 + delp = 0._dp + else + do ku = 2,col_dens(dm)%ncoldens_levs + if( pinterp <= col_dens(dm)%col_levs(ku) ) then + kl = ku - 1 + delp = log( pinterp/col_dens(dm)%col_levs(kl) )/log( col_dens(dm)%col_levs(ku)/col_dens(dm)%col_levs(kl) ) + exit + end if + end do + end if + tint_vals(1) = col_dens(dm)%o2_col_dens(i,j,kl,last) & + + delp * (col_dens(dm)%o2_col_dens(i,j,ku,last) & + - col_dens(dm)%o2_col_dens(i,j,kl,last)) + tint_vals(2) = col_dens(dm)%o2_col_dens(i,j,kl,next) & + + delp * (col_dens(dm)%o2_col_dens(i,j,ku,next) & + - col_dens(dm)%o2_col_dens(i,j,kl,next)) + o2_exo_col(i,j) = tint_vals(1) + dels * (tint_vals(2) - tint_vals(1)) + tint_vals(1) = col_dens(dm)%o3_col_dens(i,j,kl,last) & + + delp * (col_dens(dm)%o3_col_dens(i,j,ku,last) & + - col_dens(dm)%o3_col_dens(i,j,kl,last)) + tint_vals(2) = col_dens(dm)%o3_col_dens(i,j,kl,next) & + + delp * (col_dens(dm)%o3_col_dens(i,j,ku,next) & + - col_dens(dm)%o3_col_dens(i,j,kl,next)) + o3_exo_col(i,j) = tint_vals(1) + dels * (tint_vals(2) - tint_vals(1)) + tint_vals(1) = col_dens(dm)%o3_col_dens(i,j,Kgrnd,last) + tint_vals(2) = col_dens(dm)%o3_col_dens(i,j,Kgrnd,next) + o3_exo_col_at_grnd(i,j) = tint_vals(1) + dels * (tint_vals(2) - tint_vals(1)) + end do long_loop + end do lat_loop + + end subroutine p_interp + + subroutine xsqy_int( n, xsqy, tlev, dens_air ) +!--------------------------------------------------------------------- +! ... interpolate m,t tables for xs * qy +!--------------------------------------------------------------------- + + integer, intent(in) :: n + real, intent(in) :: tlev(:) + real, intent(in) :: dens_air(:) + real, intent(out) :: xsqy(:,:) + + real, parameter :: m0 = 2.45e19 + integer :: tndx, mndx, tndxp1, mndxp1 + integer :: k, ku + real :: temp, dens + real :: w(4) + real :: del_t, del_d + + ku = size( tlev ) + do k = 1,ku + temp = tlev(k) + do tndx = 1,ntemp + if( temp_tab(tndx) > temp ) then + exit + endif + end do + tndx = max( min( tndx,ntemp ) - 1,1 ) + tndxp1 = tndx + 1 + del_t = max( 0.,min( 1.,(temp - temp_tab(tndx))*del_temp_tab(tndx) ) ) + +! dens = dens_air(k) + dens = dens_air(k)/m0 + do mndx = 1,nconc + if( conc_tab(mndx) > dens ) then + exit + endif + end do + mndx = max( min( mndx,nconc ) - 1,1 ) + mndxp1 = mndx + 1 + del_d = max( 0.,min( 1.,(dens - conc_tab(mndx))*del_conc_tab(mndx) ) ) + + w(1) = (1. - del_t)*(1. - del_d) + w(2) = del_t*(1. - del_d) + w(3) = (1. - del_t)*del_d + w(4) = del_t*del_d + + xsqy(1:nwave,k) = w(1)*xsqy_tab(1:nwave,tndx,mndx,n) & + + w(2)*xsqy_tab(1:nwave,tndxp1,mndx,n) & + + w(3)*xsqy_tab(1:nwave,tndx,mndxp1,n) & + + w(4)*xsqy_tab(1:nwave,tndxp1,mndxp1,n) + end do + + end subroutine xsqy_int + + subroutine xs_int( xs, tlev, xs_tab ) +!--------------------------------------------------------------------- +! ... interpolate tables for xs +!--------------------------------------------------------------------- + + real, intent(in) :: tlev(:) + real, intent(in) :: xs_tab(:,:) + real, intent(out) :: xs(:,:) + + integer :: tndx, tndxp1 + integer :: k, ku + real :: temp + real :: w(2) + real :: del_t + + ku = size( tlev ) + do k = 1,ku + temp = tlev(k) + do tndx = 1,ntemp + if( temp_tab(tndx) > temp ) then + exit + endif + end do + tndx = max( min( tndx,ntemp ) - 1,1 ) + tndxp1 = tndx + 1 + del_t = max( 0.,min( 1.,(temp - temp_tab(tndx))*del_temp_tab(tndx) ) ) + + w(1) = (1. - del_t) + w(2) = del_t + + xs(1:nwave,k) = w(1)*xs_tab(1:nwave,tndx) & + + w(2)*xs_tab(1:nwave,tndxp1) + end do + + end subroutine xs_int + + FUNCTION chap(zeta) + ! chapman function is used when the solar zenith angle exceeds + ! 75 deg. + ! interpolates between values given in, e.g., mccartney (1976). + ! .. Scalar Arguments .. + REAL, intent(in) :: zeta + ! .. Local Scalars .. + REAL :: rm + INTEGER :: i + LOGICAL :: fnd + ! .. Local Arrays .. + REAL :: y(75:96) + ! .. Function Return Value .. + REAL :: chap + ! .. Data Statements .. + DATA (y(i),i=75,96) & + /3.800, 4.055, 4.348, 4.687, 5.083, 5.551, 6.113, & + 6.799, 7.650, 8.732, 10.144, 12.051, 14.730, 18.686, 24.905, 35.466, & + 55.211, 96.753, 197., 485., 1476., 9999./ + + fnd = .false. + DO i = 75, 96 + rm = real(i) + IF (zeta < rm) then + chap = y(i) + (y(i+1) - y(i))*(zeta - (rm - 1.)) + fnd = .true. + exit + ENDIF + END DO + + IF( .not. fnd ) then + chap = y(96) + ENDIF + + END FUNCTION chap + + SUBROUTINE fery( nwave, w, wght ) +!----------------------------------------------------------------------------- +!= PURPOSE: +!= Calculate the action spectrum value for erythema at a given wavelength +!= according to: McKinlay, A.F and B.L.Diffey, A reference action spectrum +!= for ultraviolet induced erythema in human skin, CIE Journal, vol 6, +!= pp 17-22, 1987. +!= Value at 300 nm = 0.6486 +!----------------------------------------------------------------------------- + + INTEGER, intent(in) :: nwave + REAL, intent(in) :: w(:) + REAL, intent(out) :: wght(:) + + WHERE( w(1:nwave) < 298. ) + wght(1:nwave) = 1. + ELSEWHERE( w(1:nwave) >= 298. .AND. w(1:nwave) < 328. ) + wght(1:nwave) = 10.**(0.094*(298. - w(1:nwave))) + ELSEWHERE( w(1:nwave) >= 328. .AND. w(1:nwave) < 400. ) + wght(1:nwave) = 10.**(0.015*(139. - w(1:nwave))) + ELSEWHERE( w(1:nwave) >= 400. ) + wght(1:nwave) = 1.e-36 + ENDWHERE + + END SUBROUTINE fery + + SUBROUTINE cldfrac_binary( CLDFRA,QC,QI, QS, kts, kte ) +!--------------------------------------------------------------------- +! !DESCRIPTION: +! Compute cloud fraction from input ice, snow, and cloud water fields +! if provided. +! +! Whether QI or QC is active or not is determined from the indices of +! the fields into the 4D scalar arrays in WRF. These indices are +! P_QI and P_QC, respectively, and they are passed in to the routine +! to enable testing to see if QI and QC represent active fields in +! the moisture 4D scalar array carried by WRF. +! +! If a field is active its index will have a value greater than or +! equal to PARAM_FIRST_SCALAR, which is also an input argument to +! this routine. +!EOP +!--------------------------------------------------------------------- + + IMPLICIT NONE + + INTEGER, INTENT(IN) :: kts, kte + + REAL, INTENT(OUT ) :: CLDFRA(kts:kte) + + REAL, INTENT(IN) :: QI(kts:kte), & + QC(kts:kte), & + QS(kts:kte) +!---------------------------------------------------------------------- +! local variables +!---------------------------------------------------------------------- + REAL, parameter :: thresh = 1.e-9 + + INTEGER :: j + + where( (qc(kts:kte) + qi(kts:kte) + qs(kts:kte)) > thresh ) + cldfra(kts:kte) = 1. + elsewhere + cldfra(kts:kte) = 0. + endwhere + + END SUBROUTINE cldfrac_binary + + SUBROUTINE cldfrac_fractional( CLDFRA, QV, QC, QI, QS, & + p_phy, t_phy, & + kts, kte ) + +!---------------------------------------------------------------------- +! dummy arguments +!---------------------------------------------------------------------- + INTEGER, INTENT(IN) :: kts,kte + + REAL, INTENT(OUT) :: CLDFRA(kts:kte) + + REAL, INTENT(IN) :: QV(kts:kte), & + QI(kts:kte), & + QC(kts:kte), & + QS(kts:kte), & + t_phy(kts:kte), & + p_phy(kts:kte) + + +!---------------------------------------------------------------------- +! local variables +!---------------------------------------------------------------------- + REAL , PARAMETER :: ALPHA0 = 100. + REAL , PARAMETER :: GAMMA = 0.49 + REAL , PARAMETER :: QCLDMIN = 1.E-12 + REAL , PARAMETER :: PEXP = 0.25 + REAL , PARAMETER :: RHGRID =1.0 + REAL , PARAMETER :: SVP1 = 0.61078 + REAL , PARAMETER :: SVP2 = 17.2693882 + REAL , PARAMETER :: SVPI2 = 21.8745584 + REAL , PARAMETER :: SVP3 = 35.86 + REAL , PARAMETER :: SVPI3 = 7.66 + REAL , PARAMETER :: SVPT0 = 273.15 + REAL , PARAMETER :: r_d = 287. + REAL , PARAMETER :: r_v = 461.6 + REAL , PARAMETER :: ep_2 = r_d/r_v + + INTEGER :: i,j,k + INTEGER :: imax, jmax, kmax + REAL :: RHUM, tc, esw, esi, weight, qvsw, qvsi, qvs_weight + REAL :: QCLD, DENOM, ARG, SUBSAT, wrk + REAL :: relhum_max, wrk_max + + +! !DESCRIPTION: +!---------------------------------------------------------------------- +! Compute cloud fraction from input ice and cloud water fields +! if provided. +! +! Whether QI or QC is active or not is determined from the indices of +! the fields into the 4D scalar arrays in WRF. These indices are +! P_QI and P_QC, respectively, and they are passed in to the routine +! to enable testing to see if QI and QC represent active fields in +! the moisture 4D scalar array carried by WRF. +! +! If a field is active its index will have a value greater than or +! equal to PARAM_FIRST_SCALAR, which is also an input argument to +! this routine. +!---------------------------------------------------------------------- +!EOP + + +!----------------------------------------------------------------------- +! COMPUTE GRID-SCALE CLOUD COVER FOR RADIATION +! (modified by Ferrier, Feb '02) +! +! Cloud fraction parameterization follows Randall, 1994 +! (see Hong et al., 1998) +!----------------------------------------------------------------------- +! Note: ep_2=287./461.6 Rd/Rv +! Note: R_D=287. + +! Alternative calculation for critical RH for grid saturation +! RHGRID=0.90+.08*((100.-DX)/95.)**.5 + +! Calculate saturation mixing ratio weighted according to the fractions of +! water and ice. +! Following: +! Murray, F.W. 1966. ``On the computation of Saturation Vapor Pressure'' J. Appl. Meteor. 6 p.204 +! es (in mb) = 6.1078 . exp[ a . (T-273.16)/ (T-b) ] +! +! over ice over water +! a = 21.8745584 17.2693882 +! b = 7.66 35.86 +!--------------------------------------------------------------------- + + relhum_max = -100. + wrk_max = -10000. + imax = 0; kmax = 0; jmax = 0 + +vert_loop: & + DO k = kts,kte +!--------------------------------------------------------------------- +! Determine cloud fraction (modified from original algorithm) +!--------------------------------------------------------------------- + QCLD = QI(k) + QC(k) + QS(k) +has_cloud : & + IF( QCLD >= QCLDMIN ) THEN + tc = t_phy(k) - SVPT0 + esw = 1000.0 * SVP1 * EXP( SVP2 * tc / ( t_phy(k) - SVP3 ) ) + esi = 1000.0 * SVP1 * EXP( SVPI2 * tc / ( t_phy(k) - SVPI3 ) ) + QVSW = EP_2 * esw / ( p_phy(k) - esw ) + QVSI = EP_2 * esi / ( p_phy(k) - esi ) + + weight = (QI(k) + QS(k)) / QCLD + QVS_WEIGHT = (1. - weight)*QVSW + weight*QVSI + RHUM = QV(k)/QVS_WEIGHT !--- Relative humidity +!--------------------------------------------------------------------- +! Assume zero cloud fraction if there is no cloud mixing ratio +!--------------------------------------------------------------------- + IF( RHUM >= RHGRID )THEN +!--------------------------------------------------------------------- +! Assume cloud fraction of unity if near saturation and the cloud +! mixing ratio is at or above the minimum threshold +!--------------------------------------------------------------------- + CLDFRA(k) = 1. + ELSE +!--------------------------------------------------------------------- +! Adaptation of original algorithm (Randall, 1994; Zhao, 1995) +! modified based on assumed grid-scale saturation at RH=RHgrid. +!--------------------------------------------------------------------- + SUBSAT = MAX( 1.E-10,RHGRID*QVS_WEIGHT - QV(k) ) + DENOM = SUBSAT**GAMMA + ARG = MAX( -6.9,-ALPHA0*QCLD/DENOM ) ! <-- EXP(-6.9)=.001 +!--------------------------------------------------------------------- +! prevent negative values (new) +!--------------------------------------------------------------------- + RHUM = MAX( 1.E-10, RHUM ) + wrk = (RHUM/RHGRID)**PEXP*(1. - EXP( ARG )) + IF( wrk >= .01 ) then + CLDFRA(k) = wrk + ENDIF + ENDIF + ENDIF has_cloud + END DO vert_loop + + END SUBROUTINE cldfrac_fractional + +#ifdef NETCDF + subroutine handle_ncerr( ret, mes ) +!--------------------------------------------------------------------- +! ... netcdf error handling routine +!--------------------------------------------------------------------- + + implicit none + +!--------------------------------------------------------------------- +! ... dummy arguments +!--------------------------------------------------------------------- + integer, intent(in) :: ret + character(len=*), intent(in) :: mes + +include 'netcdf.inc' + + if( ret /= nf_noerr ) then + call wrf_message( trim(mes) ) + call wrf_message( trim(nf_strerror(ret)) ) + call wrf_abort + end if + + end subroutine handle_ncerr +#endif + + end module module_phot_tuv diff --git a/wrfv2_fire/chem/module_plumerise1.F b/wrfv2_fire/chem/module_plumerise1.F index 64a51048..30da0515 100644 --- a/wrfv2_fire/chem/module_plumerise1.F +++ b/wrfv2_fire/chem/module_plumerise1.F @@ -339,6 +339,57 @@ subroutine plumerise_driver (id,ktau,dtstep, & ebu(i,k,j,p_ebu_bc) = ebu(i,k,j,p_ebu_bc)*ratio end do endif + +!psp add for other treatments + elseif (config_flags%biomass_burn_opt == BIOMASSB) then + +!------------------------------------------------------------------- +! we input total emissions instead of smoldering emissions: +! ratio of smolderling to total +!------------------------------------------------------------------- + sum = 0. + do k = kts,kte + sum = sum + ebu(i,k,j,p_ebu_co) + end do + if( sum > 0. ) then + ratio = ebu(i,kts,j,p_ebu_co)/sum + else + ratio = 0. + endif + + do k = kts,kte + ebu(i,k,j,p_ebu_no) = ebu(i,k,j,p_ebu_no)*ratio + ebu(i,k,j,p_ebu_no2) = ebu(i,k,j,p_ebu_no2)*ratio + ebu(i,k,j,p_ebu_co) = ebu(i,k,j,p_ebu_co)*ratio + ebu(i,k,j,p_ebu_co2) = ebu(i,k,j,p_ebu_co2)*ratio + ebu(i,k,j,p_ebu_eth) = ebu(i,k,j,p_ebu_eth)*ratio + ebu(i,k,j,p_ebu_hc3) = ebu(i,k,j,p_ebu_hc3)*ratio + ebu(i,k,j,p_ebu_hc5) = ebu(i,k,j,p_ebu_hc5)*ratio + ebu(i,k,j,p_ebu_hc8) = ebu(i,k,j,p_ebu_hc8)*ratio + ebu(i,k,j,p_ebu_ete) = ebu(i,k,j,p_ebu_ete)*ratio + ebu(i,k,j,p_ebu_olt) = ebu(i,k,j,p_ebu_olt)*ratio + ebu(i,k,j,p_ebu_oli) = ebu(i,k,j,p_ebu_oli)*ratio + ebu(i,k,j,p_ebu_pm25) = ebu(i,k,j,p_ebu_pm25)*ratio + ebu(i,k,j,p_ebu_pm10) = ebu(i,k,j,p_ebu_pm10)*ratio + ebu(i,k,j,p_ebu_dien) = ebu(i,k,j,p_ebu_dien)*ratio + ebu(i,k,j,p_ebu_iso) = ebu(i,k,j,p_ebu_iso)*ratio + ebu(i,k,j,p_ebu_api) = ebu(i,k,j,p_ebu_api)*ratio + ebu(i,k,j,p_ebu_lim) = ebu(i,k,j,p_ebu_lim)*ratio + ebu(i,k,j,p_ebu_tol) = ebu(i,k,j,p_ebu_tol)*ratio + ebu(i,k,j,p_ebu_csl) = ebu(i,k,j,p_ebu_csl)*ratio + ebu(i,k,j,p_ebu_hcho) = ebu(i,k,j,p_ebu_hcho)*ratio + ebu(i,k,j,p_ebu_ald) = ebu(i,k,j,p_ebu_ald)*ratio + ebu(i,k,j,p_ebu_ket) = ebu(i,k,j,p_ebu_ket)*ratio + ebu(i,k,j,p_ebu_macr) = ebu(i,k,j,p_ebu_macr)*ratio + ebu(i,k,j,p_ebu_ora1) = ebu(i,k,j,p_ebu_ora1)*ratio + ebu(i,k,j,p_ebu_ora2) = ebu(i,k,j,p_ebu_ora2)*ratio + ebu(i,k,j,p_ebu_so2) = ebu(i,k,j,p_ebu_so2)*ratio + ebu(i,k,j,p_ebu_nh3) = ebu(i,k,j,p_ebu_nh3)*ratio + ebu(i,k,j,p_ebu_oc) = ebu(i,k,j,p_ebu_oc)*ratio + ebu(i,k,j,p_ebu_bc) = ebu(i,k,j,p_ebu_bc)*ratio + ebu(i,k,j,p_ebu_sulf) = ebu(i,k,j,p_ebu_sulf)*ratio + ebu(i,k,j,p_ebu_dms) = ebu(i,k,j,p_ebu_dms)*ratio + end do end if is_mozcart end if has_total_emissions diff --git a/wrfv2_fire/chem/module_sea_salt_emis.F b/wrfv2_fire/chem/module_sea_salt_emis.F index 5623b9d6..d2a49e25 100644 --- a/wrfv2_fire/chem/module_sea_salt_emis.F +++ b/wrfv2_fire/chem/module_sea_salt_emis.F @@ -56,7 +56,7 @@ subroutine gocart_dust_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u_phy, do j=jts,jte do i=its,ite ! -! donṫ do dust over water!!! +! don't do dust over water!!! ! if(xland(i,j).gt.1.5)then ilwi(1,1)=1 @@ -67,7 +67,7 @@ subroutine gocart_dust_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u_phy, w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j)) airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g ! -! we donṫ trust the u10,v10 values, is model layers are very thin near surface +! we don't trust the u10,v10 values, is model layers are very thin near surface ! if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j)) ! diff --git a/wrfv2_fire/chem/module_subs_tuv.F b/wrfv2_fire/chem/module_subs_tuv.F new file mode 100644 index 00000000..d15c5680 --- /dev/null +++ b/wrfv2_fire/chem/module_subs_tuv.F @@ -0,0 +1,946 @@ + MODULE tuv_subs + + use params_mod, only : dp + + IMPLICIT none + + private + public :: tuv_radfld, sundis, calc_zenith + + integer :: nstr = 1 ! stream count + + CONTAINS + + SUBROUTINE tuv_radfld( nlambda_start, cld_od_opt, cldfrac, nlyr, nwave, & + zenith, z, albedo, & + aircol, o2col, o3col, so2col, no2col, & + tauaer300, tauaer400, tauaer600, tauaer999, & + waer300, waer400, waer600, waer999, & + gaer300, gaer400, gaer600, gaer999, & + dtaer, omaer, gaer, dtcld, omcld, gcld, & + has_aer_ra_feedback, & + qll, dobsi, o3_xs, no2_xs, o2_xs, & + so2_xs, wmin, wc, tlev, srb_o2_xs, radfld, efld, & + e_dir, e_dn, e_up, & +#ifdef SW_DEBUG + dir_fld, dwn_fld, up_fld, dt_cld, tuv_diags ) +#else + dir_fld, dwn_fld, up_fld, dt_cld ) +#endif +!----------------------------------------------------------------------------- +! ... calculate the radiation field +!----------------------------------------------------------------------------- + + use srb, only : la_srb + use rad_trans, only : rtlink + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + integer, intent(in) :: nlambda_start + integer, intent(in) :: nlyr + integer, intent(in) :: nwave + integer, intent(in) :: cld_od_opt + real, intent(in) :: zenith + real, intent(in) :: dobsi + real, intent(in) :: wmin + real, intent(in) :: z(:) + real, intent(in) :: albedo(:) + real, intent(in) :: aircol(:) + real, intent(in) :: o2col(:) + real, intent(in) :: o3col(:) + real, intent(in) :: so2col(:) + real, intent(in) :: no2col(:) + real, intent(in) :: tauaer300(:) + real, intent(in) :: tauaer400(:) + real, intent(in) :: tauaer600(:) + real, intent(in) :: tauaer999(:) + real, intent(in) :: waer300(:) + real, intent(in) :: waer400(:) + real, intent(in) :: waer600(:) + real, intent(in) :: waer999(:) + real, intent(in) :: gaer300(:) + real, intent(in) :: gaer400(:) + real, intent(in) :: gaer600(:) + real, intent(in) :: gaer999(:) + real, intent(in) :: qll(:) + real, intent(in) :: wc(:) + real, intent(in) :: tlev(:) + real, intent(in) :: cldfrac(:) + real, intent(in) :: o2_xs(:) + real, intent(in) :: so2_xs(:) + real, intent(in) :: o3_xs(:,:) + real, intent(in) :: no2_xs(:,:) + real, intent(out) :: srb_o2_xs(:,:) + real, intent(out) :: radfld(:,:) + real, intent(out) :: efld(:,:) + real, intent(inout) :: dir_fld(:,:), dwn_fld(:,:), up_fld(:,:) + real, intent(inout) :: e_dir(:,:), e_dn(:,:), e_up(:,:) + real, intent(inout) :: dt_cld(:) + real, intent(inout) :: dtaer(:,:), omaer(:,:), gaer(:,:) + real, intent(inout) :: dtcld(:,:), omcld(:,:), gcld(:,:) + logical, intent(in) :: has_aer_ra_feedback +#ifdef SW_DEBUG + logical, intent(in) :: tuv_diags +#endif + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + integer :: k, n + integer :: wn + integer :: n_radlev, n_radlevp1 + integer :: nid(0:nlyr) + real :: dtrl(nlyr,nwave) + real :: dto2(nlyr,nwave) + real :: dto3(nlyr,nwave) + real :: dtso2(nlyr,nwave) + real :: dtno2(nlyr,nwave) +! real :: dtcld(nlyr,nwave) +! real :: dtaer(nlyr,nwave) + real :: dtsnw(nlyr,nwave) + +! real :: omcld(nlyr,nwave) +! real :: gcld(nlyr,nwave) +! real :: omaer(nlyr,nwave) +! real :: gaer(nlyr,nwave) + real :: omsnw(nlyr,nwave) + real :: gsnw(nlyr,nwave) + + real :: edir(nlyr+1) + real :: edn(nlyr+1) + real :: eup(nlyr+1) + real :: fdir(nlyr+1) + real :: fdn(nlyr+1) + real :: fup(nlyr+1) + + real :: vcol(nlyr) + real :: scol(nlyr) + + real :: dsdh(0:nlyr,nlyr) + + n_radlev = size( radfld,dim=2 ) + n_radlevp1 = n_radlev + 1 + + do wn = 1,nwave + omcld(:,wn) = 0. + omaer(:,wn) = 0. + omsnw(:,wn) = 0. + gcld(:,wn) = 0. + gaer(:,wn) = 0. + gsnw(:,wn) = 0. + dtcld(:,wn) = 0. + dtaer(:,wn) = 0. + dtsnw(:,wn) = 0. + end do + + call odrl( wc, aircol, dtrl ) + call seto2( o2col, o2_xs, dto2 ) + call odo3( o3col, o3_xs, dto3, dobsi ) + call setso2( so2col, so2_xs, dtso2 ) + call setno2( no2col, no2_xs, dtno2 ) +!------------------------------------------------------------- +! aerosol optical depths +!------------------------------------------------------------- + if( has_aer_ra_feedback ) then + call setaer( nlambda_start, wc, tauaer300, tauaer400, & + tauaer600, tauaer999, waer300, & + waer400, waer600, waer999, & + gaer300, gaer400, gaer600, & + gaer999, dtaer, omaer, gaer ) + endif +!------------------------------------------------------------- +! cloud optical depths (cloud water units = g/m3) +!------------------------------------------------------------- + call setcld( nlambda_start, cld_od_opt, z, qll, cldfrac, & + dtcld, omcld, gcld ) + dt_cld(:n_radlev) = dtcld(2:n_radlevp1,1) + + call sphers( nlyr, z, zenith, dsdh, nid ) + +#ifdef SW_DEBUG + if( tuv_diags ) then + open(unit=33,file='WRF-TUV.dbg.out') + write(33,*) 'tuv_radfld: tuv_diags' + write(33,'(''nlyr = '',i4)') nlyr + write(33,'(''dsdh(1,1) = '',1p,g15.7)') dsdh(1,1) + write(33,*) 'dsdh(nlyr,:)' + do n = 1,nlyr,5 + write(33,'(1p,5g15.7)') dsdh(nlyr,n:min(n+4,nlyr)) + end do + close(33) + endif +#endif + + call airmas( nlyr, dsdh, nid, aircol, vcol, scol ) + call la_srb( nlyr, z, tlev, wmin, & + vcol, scol, o2_xs, dto2, srb_o2_xs ) + + do wn = nlambda_start,nwave + call rtlink( & + nstr, nlyr+1, nlyr, nwave, & + wn, albedo(wn), zenith, & + dsdh, nid, & + dtrl, & + dto3, & + dto2, & + dtso2, & + dtno2, & + dtcld, omcld, gcld, & + dtaer, omaer, gaer, & + dtsnw, omsnw, gsnw, & +#ifdef SW_DEBUG + edir, edn, eup, fdir, fdn, fup, tuv_diags ) +#else + edir, edn, eup, fdir, fdn, fup ) +#endif +! radfld(wn,1:nlyr-1) = fdir(2:nlyr) + fdn(2:nlyr) + fup(2:nlyr) +! efld(1:nlyr-1,wn) = edir(2:nlyr) + edn(2:nlyr) + eup(2:nlyr) +! dir_fld(1:nlyr-1,wn) = fdir(2:nlyr) +! dwn_fld(1:nlyr-1,wn) = fdn(2:nlyr) +! up_fld(1:nlyr-1,wn) = fup(2:nlyr) +! e_dir(1:nlyr-1,wn) = edir(2:nlyr) +! e_dn(1:nlyr-1,wn) = edn(2:nlyr) +! e_up(1:nlyr-1,wn) = eup(2:nlyr) + radfld(wn,1:n_radlev) = fdir(2:n_radlevp1) + fdn(2:n_radlevp1) + fup(2:n_radlevp1) + efld(1:n_radlev,wn) = edir(2:n_radlevp1) + edn(2:n_radlevp1) + eup(2:n_radlevp1) + dir_fld(1:n_radlev,wn) = fdir(2:n_radlevp1) + dwn_fld(1:n_radlev,wn) = fdn(2:n_radlevp1) + up_fld(1:n_radlev,wn) = fup(2:n_radlevp1) + e_dir(1:n_radlev,wn) = edir(2:n_radlevp1) + e_dn(1:n_radlev,wn) = edn(2:n_radlevp1) + e_up(1:n_radlev,wn) = eup(2:n_radlevp1) + end do + + END SUBROUTINE tuv_radfld + + SUBROUTINE odrl( wc, aircol, dtrl ) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Compute Rayleigh optical depths as a function of altitude and wavelength =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= C - REAL, number of air molecules per cm^2 at each specified (O)=* +!= altitude layer =* +!= DTRL - REAL, Rayleigh optical depth at each specified altitude (O)=* +!= and each specified wavelength =* +!-----------------------------------------------------------------------------* + +!-----------------------------------------------------------------------------* +! ...dummy arguments +!-----------------------------------------------------------------------------* + REAL, intent(in) :: aircol(:) + REAL, intent(in) :: wc(:) + REAL, intent(out) :: dtrl(:,:) + +!-----------------------------------------------------------------------------* +! ...local variables +!-----------------------------------------------------------------------------* + INTEGER :: nwave, nlyr + INTEGER :: wn + REAL :: srayl, wmicrn, xx + + nwave = size( wc ) + nlyr = size( aircol ) +!-----------------------------------------------------------------------------* +! compute Rayleigh cross sections and depths: +!-----------------------------------------------------------------------------* + DO wn = 1,nwave +!-----------------------------------------------------------------------------* +! Rayleigh scattering cross section from WMO 1985 (originally from +! Nicolet, M., On the molecular scattering in the terrestrial atmosphere: +! An empirical formula for its calculation in the homoshpere, Planet. +! Space Sci., 32, 1467-1468, 1984. +!-----------------------------------------------------------------------------* + wmicrn = wc(wn)*1.E-3 + IF( wmicrn <= 0.55 ) THEN + xx = 3.6772 + 0.389*wmicrn + 0.09426/wmicrn + ELSE + xx = 4.04 + ENDIF + srayl = 4.02e-28/(wmicrn)**xx +!-----------------------------------------------------------------------------* +! alternate (older) expression from +! Frohlich and Shaw, Appl.Opt. v.11, p.1773 (1980). +!-----------------------------------------------------------------------------* + dtrl(:nlyr,wn) = aircol(:nlyr)*srayl + END DO + + END SUBROUTINE odrl + + SUBROUTINE odo3( o3col, o3xs, dto3, dobsi ) +!----------------------------------------------------------------------------- +!= NAME: Optical Depths of O3 +!= PURPOSE: +!= Compute ozone optical depths as a function of altitude and wavelength +!----------------------------------------------------------------------------- +!= PARAMETERS: +!= O3XS - REAL, molecular absoprtion cross section (cm^2) of O3 at (I) +!= each specified wavelength and altitude +!= C - REAL, ozone vertical column increments, molec cm-2, for each (I) +!= layer +!= DTO3 - REAL, optical depth due to ozone absorption at each (O) +!= specified altitude at each specified wavelength +!----------------------------------------------------------------------------- + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + REAL, intent(in) :: dobsi + REAL, intent(in) :: o3col(:) + REAL, intent(in) :: o3xs(:,:) + REAL, intent(inout) :: dto3(:,:) + + INTEGER :: nlyr, nwave + INTEGER :: wn + REAL :: dob_at_grnd, scale_fac + + nwave = size(o3xs,dim=1) + nlyr = size(o3col) + + if( dobsi == 0. ) then +!----------------------------------------------------------------------------- +! no scaling +!----------------------------------------------------------------------------- + DO wn = 1,nwave + dto3(:nlyr,wn) = o3col(:nlyr) * o3xs(wn,:nlyr) + END DO + else +!----------------------------------------------------------------------------- +! scale model o3 column to dobsi +!----------------------------------------------------------------------------- + dob_at_grnd = sum( o3col(:nlyr) )/2.687e16 + scale_fac = dobsi/dob_at_grnd + DO wn = 1,nwave + dto3(:nlyr,wn) = scale_fac * o3col(:nlyr) * o3xs(wn,:nlyr) + END DO + endif + + END SUBROUTINE odo3 + + SUBROUTINE seto2( o2col, o2xs1, dto2 ) +!----------------------------------------------------------------------------- +!= PURPOSE: +!= Set up an altitude profile of air molecules. Subroutine includes a +!= shape-conserving scaling method that allows scaling of the entire +!= profile to a given sea-level pressure. +!----------------------------------------------------------------------------- +!= PARAMETERS: +!= CZ - REAL, number of air molecules per cm^2 at each specified (O) +!= altitude layer +!----------------------------------------------------------------------------- + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + REAL, intent(in) :: o2col(:) + REAL, intent(in) :: o2xs1(:) + REAL, intent(out) :: dto2(:,:) + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + INTEGER :: nlyr, nwave + INTEGER :: wn + + nwave = size(o2xs1) + nlyr = size(o2col) + +!----------------------------------------------------------------------------- +! Assumes that O2 = 20.95 % of air density. If desire different O2 +! profile (e.g. for upper atmosphere) then can load it here. +!----------------------------------------------------------------------------- + DO wn = 1,nwave + dto2(:nlyr,wn) = o2col(:nlyr) * o2xs1(wn) + ENDDO + + END SUBROUTINE seto2 + + SUBROUTINE setso2( colso2, so2_xs, dtso2 ) +!----------------------------------------------------------------------------- +!= PURPOSE: +!= Set up an altitude profile of SO2 molecules, and corresponding absorption +!= optical depths. Subroutine includes a shape-conserving scaling method +!= that allows scaling of the entire profile to a given overhead SO2 +!= column amount. +!----------------------------------------------------------------------------- +!= PARAMETERS: +!= SO2_XS - REAL, molecular absoprtion cross section (cm^2) of O2 at (I) +!= each specified wavelength +!= DTSO2 - REAL, optical depth due to SO2 absorption at each (O) +!= specified altitude at each specified wavelength +!----------------------------------------------------------------------------- + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + REAL, intent(in) :: colso2(:) + REAL, intent(in) :: so2_xs(:) + REAL, intent(out) :: dtso2(:,:) + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + integer :: nwave, nlyr + integer :: wn + + nwave = size( so2_xs ) + nlyr = size( colso2 ) + + DO wn = 1,nwave + dtso2(:nlyr,wn) = colso2(:nlyr)*so2_xs(wn) + END DO + + END SUBROUTINE setso2 + + SUBROUTINE setno2( colno2, no2_xs, dtno2 ) +!----------------------------------------------------------------------------- +!= NAME: Optical Depths of no2 +!= PURPOSE: +!= Compute no2 optical depths as a function of altitude and wavelength +!----------------------------------------------------------------------------- +!= PARAMETERS: +!= NO2_XS - REAL, molecular absoprtion cross section (cm^2) of no2 at (I) +!= each specified wavelength and altitude +!= COLNO2 - REAL, no2 vertical column increments, molec cm-2, for each (I) +!= layer +!= DTNO2 - REAL, optical depth due to no2 absorption at each (O) +!= specified altitude at each specified wavelength +!----------------------------------------------------------------------------- + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + REAL, intent(in) :: colno2(:) + REAL, intent(in) :: no2_xs(:,:) + REAL, intent(inout) :: dtno2(:,:) + + INTEGER :: nlyr, nwave + INTEGER :: wn + + nwave = size(no2_xs,dim=1) + nlyr = size(colno2) + + DO wn = 1,nwave + dtno2(:nlyr,wn) = colno2(:nlyr) * no2_xs(wn,:nlyr) + END DO + + END SUBROUTINE setno2 + + subroutine setaer( nlambda_start, wc, tauaer300, tauaer400, & + tauaer600, tauaer999, & + waer300, waer400, waer600, waer999, & + gaer300, gaer400, gaer600, gaer999, & + dtaer, omaer, gaer ) +!---------------------------------------------------------------------- +! The routine is based on aerosol treatment in module_ra_rrtmg_sw.F +! INPUT: +! nzlev: number of specified altitude levels in the working grid +! z: specified altitude working grid +! Aerosol optical properties at 300, 400, 600 and 999 nm. +! tauaer300, tauaer400, tauaer600, tauaer999: Layer AODs +! waer300, waer400, waer600, waer999: Layer SSAs +! gaer300, gaer400, gaer600, gaer999: Layer asymmetry parameters + +! OUTPUT: +! dtaer: Layer AOD at FTUV wavelengths +! omaer: Layer SSA at FTUV wavelengths +! gaer : Layer asymmetry parameters at FTUV wavelengths +!------------------------------------------------------------------------ + +!----------------------------------------------------------------------------- +! Dummy arguments +!----------------------------------------------------------------------------- + integer, intent(in) :: nlambda_start + real, intent(in) :: wc(:) + real, intent(in) :: tauaer300(:), tauaer400(:), & + tauaer600(:), tauaer999(:) + real, intent(in) :: waer300(:), waer400(:), & + waer600(:), waer999(:) + real, intent(in) :: gaer300(:), gaer400(:), & + gaer600(:), gaer999(:) + real, intent(out) :: dtaer(:,:), omaer(:,:), gaer(:,:) + +!----------------------------------------------------------------------------- +! Local Variables +!----------------------------------------------------------------------------- + real, parameter :: thresh = 1.e-9 + integer :: k, wn, nlyr, nwave + real :: ang, slope, wfac + + nlyr = size(dtaer,dim=1) + nwave = size(dtaer,dim=2) + +wave_loop: & + do wn = nlambda_start,nwave + wfac = wc(wn)*1.e-3 - .6 + do k = 1,nlyr-1 +!----------------------------------------------------------------------------- +! use angstrom exponent to calculate aerosol optical depth; wc is in nm. +!----------------------------------------------------------------------------- + if( tauaer300(k) > thresh .and. tauaer999(k) > thresh ) then + ang = log(tauaer300(k)/tauaer999(k))/log(0.999/0.3) + dtaer(k,wn) = tauaer400(k)*(0.4/(wc(wn)*1.e-3))**ang +!----------------------------------------------------------------------------- +! ssa - use linear interpolation/extrapolation +!----------------------------------------------------------------------------- + slope = 5.*(waer600(k) - waer400(k)) + omaer(k,wn) = slope*wfac + waer600(k) + omaer(k,wn) = max( .4,min( 1.,omaer(k,wn) ) ) +!----------------------------------------------------------------------------- +! asymmetry parameter - use linear interpolation/extrapolation +!----------------------------------------------------------------------------- + slope = 5.*(gaer600(k) - gaer400(k)) + gaer(k,wn) = slope*wfac + gaer600(k) + gaer(k,wn) = max( .5,min( 1.,gaer(k,wn) ) ) + endif + end do + end do wave_loop + + end subroutine setaer + + subroutine setcld( nlambda_start, cld_od_opt, z, xlwc, cldfrac, & + dtcld, omcld, gcld ) +!----------------------------------------------------------------------------- +!= PURPOSE: +!= Set up cloud optical depth, single albedo and g +!----------------------------------------------------------------------------- +!= PARAMETERS: +!= PARAMETERS: +!= NZ - INTEGER, number of specified altitude levels in the working (I) +!= grid +!= Z - real(dp), specified altitude working grid (km) (I) +!= XLWC Cloud water content g/M3 (I) +!= +!= dtcld - cloud optical depth +!= omcld - cloud droplet single albedo +!= gcld - g +!----------------------------------------------------------------------------- +! +! VERTICAL DOMAIN is from bottom(1) to TOP (TOP=nz) +! CCM from top(1) to bottom(nz) +!----------------------------------------------------------------------------- + +!----------------------------------------------------------------------------- +! ... Dummy arguments +!----------------------------------------------------------------------------- + integer, intent(in) :: nlambda_start + integer, intent(in) :: cld_od_opt + real, intent(in) :: z(:) + real, intent(in) :: xlwc(:) + real, intent(in) :: cldfrac(:) + real, intent(inout) :: dtcld(:,:) + real, intent(inout) :: omcld(:,:) + real, intent(inout) :: gcld(:,:) +!----------------------------------------------------------------------------- +! ... Local variables +!----------------------------------------------------------------------------- + real, parameter :: km2m = 1.e3 ! kilometer to meter + real, parameter :: wden = 1.e6 ! g/m3 (1 m3 water = 1e6 g water) + real, parameter :: re = 10.0 * 1.e-6 ! assuming cloud drop radius = 10 um to M + real, parameter :: fac = 1./(wden*re) + + integer :: astat + integer :: wn + integer :: nlyr, nwave + real, allocatable :: wrk(:), layer_cldfrac(:) + + nlyr = size(dtcld,dim=1) + nwave = size(dtcld,dim=2) + + allocate( wrk(nlyr),layer_cldfrac(nlyr),stat=astat ) + if( astat /= 0 ) then + call wrf_error_fatal( 'setcld: failed to allocate wrk' ) + endif + +!----------------------------------------------------------------------------- +! ... calculate optical depth +!----------------------------------------------------------------------------- + wrk(1:nlyr-1) = (z(2:nlyr) - z(1:nlyr-1))*km2m ! (km -> m) + wrk(1:nlyr-1) = 1.5 * .5*(xlwc(1:nlyr-1) + xlwc(2:nlyr))*wrk(1:nlyr-1)*fac + wrk(1:nlyr-1) = max( wrk(1:nlyr-1),0. ) + if( cld_od_opt == 2 ) then + layer_cldfrac(1:nlyr-1) = .5*(cldfrac(1:nlyr-1) + cldfrac(2:nlyr)) + wrk(1:nlyr-1) = wrk(1:nlyr-1)*layer_cldfrac(1:nlyr-1)*sqrt( layer_cldfrac(1:nlyr-1) ) + endif +!---------------------------------------------------- +! ....calculate cloud optical depth T +! following Liao et al. JGR, 104, 23697, 1999 +!---------------------------------------------------- + if( any( wrk(1:nlyr-1) > 0. ) ) then + do wn = nlambda_start,nwave + dtcld(1:nlyr-1,wn) = wrk(1:nlyr-1) + omcld(1:nlyr-1,wn) = .9999 + gcld (1:nlyr-1,wn) = .85 + end do + endif + + if( allocated( wrk ) ) then + deallocate( wrk ) + endif + if( allocated( layer_cldfrac ) ) then + deallocate( layer_cldfrac ) + endif + + end subroutine setcld + + REAL FUNCTION sundis( julday ) +!----------------------------------------------------------------------------- +! purpose: +! calculate earth-sun distance variation for a given date. based on +! fourier coefficients originally from: spencer, j.w., 1971, fourier +! series representation of the position of the sun, search, 2:172 +!----------------------------------------------------------------------------- +! parameters: +! idate - integer, specification of the date, from yymmdd (i) +! esrm2 - real(dp), variation of the earth-sun distance (o) +! esrm2 = (average e/s dist)^2 / (e/s dist on day idate)^2 +!----------------------------------------------------------------------------- + + implicit none + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + integer, intent(in) :: julday + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + real(dp), parameter :: pi = 3.1415926_dp + + real(dp) :: dayn, thet0 + real(dp) :: sinth, costh, sin2th, cos2th + +!----------------------------------------------------------------------------- +! ... parse date to find day number (julian day) +!----------------------------------------------------------------------------- + dayn = real(julday - 1,kind=dp) + .5_dp +!----------------------------------------------------------------------------- +! ... define angular day number and compute esrm2: +!----------------------------------------------------------------------------- + thet0 = 2._dp*pi*dayn/365._dp +!----------------------------------------------------------------------------- +! ... calculate sin(2*thet0), cos(2*thet0) from +! addition theorems for trig functions for better +! performance; the computation of sin2th, cos2th +! is about 5-6 times faster than the evaluation +! of the intrinsic functions sin and cos +!----------------------------------------------------------------------------- + sinth = sin( thet0 ) + costh = cos( thet0 ) + sin2th = 2._dp*sinth*costh + cos2th = costh*costh - sinth*sinth + sundis = real( 1.000110_dp + .034221_dp*costh + .001280_dp*sinth & + + .000719_dp*cos2th + .000077_dp*sin2th ) + + END FUNCTION sundis + + subroutine calc_zenith( lat, long, julday, gmt, zenith, & + its, ite, jts, jte, & + ims, ime, jms, jme ) +!------------------------------------------------------------------- +! this subroutine calculates solar zenith and azimuth angles for a +! part time and location. must specify: +! input: +! lat - latitude in decimal degrees +! long - longitude in decimal degrees +! gmt - greenwich mean time - decimal military eg. +! 22.75 = 45 min after ten pm gmt +! output: +! zenith +! azimuth +! .. Scalar Arguments .. +!------------------------------------------------------------------- + integer, intent(in) :: julday + integer, intent(in) :: its,ite + integer, intent(in) :: jts,jte + integer, intent(in) :: ims,ime + integer, intent(in) :: jms,jme + real(dp), intent(in) :: gmt + real, intent(in) :: lat(ims:ime,jms:jme) + real, intent(in) :: long(ims:ime,jms:jme) + real, intent(out) :: zenith(ims:ime,jms:jme) + +!------------------------------------------------------------------- +! .. Local variables +!------------------------------------------------------------------- + real(dp), parameter :: d2r = 3.1415926_dp/180.0_dp + real(dp), parameter :: r2d = 1.0_dp/d2r + + integer :: i, j + real(dp) :: caz, csz, cw, d, ec, epsi, eqt, eyt, feqt, feqt1, & + feqt2, feqt3, feqt4, feqt5, feqt6, feqt7, lbgmt, lzgmt, ml, pepsi, & + pi, ra, raz, rdecl, reqt, rlt, rml, rra, ssw, sw, tab, w, wr, & + yt, zpt, zr + + d = real(julday,dp) + gmt/24.0_dp +!------------------------------------------------------------------- +! calc geom mean longitude +!------------------------------------------------------------------- + ml = 279.2801988_dp + d*(.9856473354_dp + 2.267E-13_dp*d) + rml = ml*d2r +!------------------------------------------------------------------- +! calc equation of time in sec +! w = mean long of perigee +! e = eccentricity +! epsi = mean obliquity of ecliptic +!------------------------------------------------------------------- + w = 282.4932328_dp + d*(4.70684E-5_dp + 3.39E-13_dp*d) + wr = w*d2r + ec = 1.6720041E-2_dp - d*(1.1444E-9_dp + 9.4E-17_dp*d) + epsi = 23.44266511_dp - d*(3.5626E-7_dp + 1.23E-15_dp*d) + pepsi = epsi*d2r + yt = (tan(pepsi/2.0_dp))**2 + cw = cos(wr) + sw = sin(wr) + ssw = sin(2.0_dp*wr) + eyt = 2._dp*ec*yt + feqt1 = -sin(rml)*cw*(eyt + 2._dp*ec) + feqt2 = cos(rml)*sw*(2._dp*ec - eyt) + feqt3 = sin(2._dp*rml)*(yt - (5._dp*ec**2/4._dp)*(cw**2 - sw**2)) + feqt4 = cos(2._dp*rml)*(5._dp*ec**2*ssw/4._dp) + feqt5 = sin(3._dp*rml)*(eyt*cw) + feqt6 = -cos(3._dp*rml)*(eyt*sw) + feqt7 = -sin(4._dp*rml)*(.5_dp*yt**2) + feqt = feqt1 + feqt2 + feqt3 + feqt4 + feqt5 + feqt6 + feqt7 + eqt = feqt*13751.0_dp + +!------------------------------------------------------------------- +! convert eq of time from sec to deg +!------------------------------------------------------------------- + reqt = eqt/240._dp +!------------------------------------------------------------------- +! calc right ascension in rads +!------------------------------------------------------------------- + ra = ml - reqt + rra = ra*d2r +!------------------------------------------------------------------- +! calc declination in rads, deg +!------------------------------------------------------------------- + tab = 0.43360_dp*sin(rra) + rdecl = atan(tab) + do j = jts,jte + do i = its,ite +!------------------------------------------------------------------- +! calc local hour angle +!------------------------------------------------------------------- + lbgmt = 12.0_dp - eqt/3600._dp + real(long(i,j),dp)*24._dp/360._dp + lzgmt = 15.0_dp*(gmt - lbgmt) + zpt = lzgmt*d2r + rlt = real(lat(i,j),dp)*d2r + csz = sin(rlt)*sin(rdecl) + cos(rlt)*cos(rdecl)*cos(zpt) + csz = min( 1._dp,csz ) + zr = acos(csz) + zenith(i,j) = real( zr/d2r,4 ) + end do + end do + + end subroutine calc_zenith + + SUBROUTINE sphers( nlyr, z, zen, dsdh, nid ) +!----------------------------------------------------------------------------- +!= PURPOSE: +!= Calculate slant path over vertical depth ds/dh in spherical geometry. +!= Calculation is based on: A.Dahlback, and K.Stamnes, A new spheric model +!= for computing the radiation field available for photolysis and heating +!= at twilight, Planet.Space Sci., v39, n5, pp. 671-683, 1991 (Appendix B) +!----------------------------------------------------------------------------- +!= PARAMETERS: +!= NZ - INTEGER, number of specified altitude levels in the working (I) +!= grid +!= Z - REAL, specified altitude working grid (km) (I) +!= ZEN - REAL, solar zenith angle (degrees) (I) +!= DSDH - REAL, slant path of direct beam through each layer crossed (O) +!= when travelling from the top of the atmosphere to layer i; +!= DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1 +!= NID - INTEGER, number of layers crossed by the direct beam when (O) +!= travelling from the top of the atmosphere to layer i; +!= NID(i), i = 0..NZ-1 +!----------------------------------------------------------------------------- +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by the +!= Free Software Foundation; either version 2 of the license, or (at your +!= option) any later version. +!= The TUV package is distributed in the hope that it will be useful, but +!= WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTIBI- +!= LITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public +!= License for more details. +!= To obtain a copy of the GNU General Public License, write to: +!= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +!----------------------------------------------------------------------------- +!= To contact the authors, please mail to: +!= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA +!= send email to: sasha@ucar.edu +!----------------------------------------------------------------------------- + + use params_mod, only : pi, radius + + IMPLICIT NONE + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + INTEGER, intent(in) :: nlyr + REAL, intent(in) :: zen + REAL, intent(in) :: z(:) + + INTEGER, intent(inout) :: nid(0:nlyr) + REAL, intent(inout) :: dsdh(0:nlyr,nlyr) + + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + REAL, parameter :: dr = pi/180. + + INTEGER :: j, jm1, k + INTEGER :: id + REAL :: re + REAL :: zd(0:nlyr) + REAL :: ds_dh(1:nlyr) + REAL(8) :: zenrad, rpsinz, rj, rjp1, dsj, dhj, ga, gb, sm + + zenrad = REAL( zen*dr,8 ) +!----------------------------------------------------------------------------- +! include the elevation above sea level to the radius of the earth: +!----------------------------------------------------------------------------- + re = radius + z(1) + +!----------------------------------------------------------------------------- +! from bottom-up to top-down +! note zd is the elevation above earth surface: +!----------------------------------------------------------------------------- + zd(0:nlyr) = z(nlyr+1:1:-1) - z(1) + +!----------------------------------------------------------------------------- +! initialize nid +!----------------------------------------------------------------------------- + nid(0:nlyr) = 0 + +!----------------------------------------------------------------------------- +! calculate ds/dh of every layer +!----------------------------------------------------------------------------- +layer_loop : & + DO k = 0, nlyr + ds_dh(:) = 0. + rpsinz = real(re + zd(k),8) * SIN(zenrad) +! IF( zen > 90.0 .AND. rpsinz < real(re,8) ) THEN + IF( zen <= 90.0 .or. rpsinz >= real(re,8) ) THEN +!----------------------------------------------------------------------------- +! Find index of layer in which the screening height lies +!----------------------------------------------------------------------------- + id = k + IF( zen > 90.0 ) THEN + DO j = 1,nlyr + IF( rpsinz < real(zd(j-1) + re,8) .AND. & + rpsinz >= real(zd(j) + re,8) ) then + id = j + ENDIF + END DO + END IF + + DO j = 1, id + jm1 = j - 1 +! IF( j == id .AND. id == k .AND. zen > 90.0 ) then + IF( j /= id .or. k /= id .or. zen <= 90.0 ) then + sm = 1.0_8 + ELSE + sm = -1.0_8 + ENDIF + rj = real(re + zd(jm1),8) + rjp1 = real(re + zd(j),8) + dhj = zd(jm1) - zd(j) + + ga = max( rj*rj - rpsinz*rpsinz,0.0_8 ) + gb = max( rjp1*rjp1 - rpsinz*rpsinz,0.0_8 ) + + IF( id > k .AND. j == id ) THEN + dsj = SQRT( ga ) + ELSE + dsj = SQRT( ga ) - sm*SQRT( gb ) + END IF + ds_dh(j) = real( dsj/dhj,4 ) + END DO + nid(k) = id + ELSE + nid(k) = -1 + ENDIF + dsdh(k,:) = ds_dh(:) + + END DO layer_loop + + END SUBROUTINE sphers + + SUBROUTINE airmas( nlyr, dsdh, nid, cz, vcol, scol ) +!----------------------------------------------------------------------------- +!= PURPOSE: +!= Calculate vertical and slant air columns, in spherical geometry, as a +!= function of altitude. +!----------------------------------------------------------------------------- +!= PARAMETERS: +!= NZ - INTEGER, number of specified altitude levels in the working (I) +!= grid +!= DSDH - REAL, slant path of direct beam through each layer crossed (O) +!= when travelling from the top of the atmosphere to layer i; +!= DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1 +!= NID - INTEGER, number of layers crossed by the direct beam when (O) +!= travelling from the top of the atmosphere to layer i; +!= NID(i), i = 0..NZ-1 +!= VCOL - REAL, output, vertical air column, molec cm-2, above level iz +!= SCOL - REAL, output, slant air column in direction of sun, above iz +!= also in molec cm-2 +!----------------------------------------------------------------------------- + + use params_mod, only : largest + + IMPLICIT NONE + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + INTEGER, intent(in) :: nlyr + INTEGER, intent(in) :: nid(0:nlyr) + REAL, intent(in) :: dsdh(0:nlyr,nlyr) + REAL, intent(in) :: cz(nlyr) + + REAL, intent(inout) :: vcol(nlyr), scol(nlyr) + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + INTEGER :: lyr, j, nlev, nlevi + REAL :: sum, vsum + +!----------------------------------------------------------------------------- +! calculate vertical and slant column from each level: work downward +!----------------------------------------------------------------------------- + nlev = nlyr + 1 + vsum = 0. + DO lyr = 1, nlyr + nlevi = nlev - lyr + vsum = vsum + cz(nlevi) + vcol(nlevi) = vsum + sum = 0. + IF( nid(lyr) < 0 ) THEN + sum = largest + ELSE +!----------------------------------------------------------------------------- +! single pass layers: +!----------------------------------------------------------------------------- + DO j = 1, MIN(nid(lyr), lyr) + sum = sum + cz(nlev-j)*dsdh(lyr,j) + END DO +!----------------------------------------------------------------------------- +! double pass layers: +!----------------------------------------------------------------------------- + DO j = MIN(nid(lyr),lyr)+1, nid(lyr) + sum = sum + 2.*cz(nlev-j)*dsdh(lyr,j) + END DO + ENDIF + scol(nlevi) = sum + END DO + + END SUBROUTINE airmas + + END MODULE tuv_subs diff --git a/wrfv2_fire/chem/module_wetscav_driver.F b/wrfv2_fire/chem/module_wetscav_driver.F index 0dd2ba13..3f09c85f 100644 --- a/wrfv2_fire/chem/module_wetscav_driver.F +++ b/wrfv2_fire/chem/module_wetscav_driver.F @@ -376,6 +376,9 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & if( config_flags%mp_physics == THOMPSON ) then rainrate(:,:,:) = rainprod(:,:,:) evaprate(:,:,:) = evapprod(:,:,:) + elseif( config_flags%mp_physics == WSM6SCHEME ) then + rainrate(:,:,:) = rainprod(:,:,:) + evaprate(:,:,:) = evapprod(:,:,:) elseif( config_flags%mp_physics == CAMMGMPSCHEME ) then rainrate(:,:,:) = prain3d(:,:,:) evaprate(:,:,:) = nevapr3d(:,:,:) @@ -407,6 +410,9 @@ subroutine wetscav_driver( id, ktau, dtstep, ktauc, config_flags, & if( config_flags%mp_physics == THOMPSON ) then rainrate(:,:,:) = rainprod(:,:,:) evaprate(:,:,:) = evapprod(:,:,:) + elseif( config_flags%mp_physics == WSM6SCHEME ) then + rainrate(:,:,:) = rainprod(:,:,:) + evaprate(:,:,:) = evapprod(:,:,:) elseif( config_flags%mp_physics == CAMMGMPSCHEME ) then rainrate(:,:,:) = prain3d(:,:,:) evaprate(:,:,:) = nevapr3d(:,:,:) diff --git a/wrfv2_fire/chem/numer.F b/wrfv2_fire/chem/numer.F new file mode 100644 index 00000000..58c1293d --- /dev/null +++ b/wrfv2_fire/chem/numer.F @@ -0,0 +1,506 @@ +! This file contains the following subroutines, related to interpolations +! of input data, addition of points to arrays, and zeroing of arrays: +! inter1 +! inter2 +! inter3 +! inter4 +! addpnt +! zero1 +! zero2 +!=============================================================================* + + SUBROUTINE inter1(ng,xg,yg, n,x,y) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Map input data given on single, discrete points, onto a discrete target =* +!= grid. =* +!= The original input data are given on single, discrete points of an =* +!= arbitrary grid and are being linearly interpolated onto a specified =* +!= discrete target grid. A typical example would be the re-gridding of a =* +!= given data set for the vertical temperature profile to match the speci- =* +!= fied altitude grid. =* +!= Some caution should be used near the end points of the grids. If the =* +!= input data set does not span the range of the target grid, the remaining =* +!= points will be set to zero, as extrapolation is not permitted. =* +!= If the input data does not encompass the target grid, use ADDPNT to =* +!= expand the input array. =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= NG - INTEGER, number of points in the target grid (I)=* +!= XG - REAL, target grid (e.g. altitude grid) (I)=* +!= YG - REAL, y-data re-gridded onto XG (O)=* +!= N - INTEGER, number of points in the input data set (I)=* +!= X - REAL, grid on which input data are defined (I)=* +!= Y - REAL, input y-data (I)=* +!-----------------------------------------------------------------------------* + + IMPLICIT NONE + +! input: + INTEGER n, ng + REAL xg(ng) + REAL x(n), y(n) + +! output: + REAL yg(ng) + +! local: + REAL slope + INTEGER jsave, i, j + + jsave = 1 + DO i = 1, ng + yg(i) = 0. + j = jsave + 10 CONTINUE + IF ((x(j) .GT. xg(i)) .OR. (xg(i) .GE. x(j+1))) THEN + j = j+1 + IF (j .LE. n-1) GOTO 10 +! ---- end of loop 10 ---- + ELSE + slope = (y(j+1)-y(j)) / (x(j+1)-x(j)) + yg(i) = y(j) + slope * (xg(i) - x(j)) + jsave = j + ENDIF + ENDDO + + END SUBROUTINE inter1 + +!=============================================================================* + + SUBROUTINE inter2(ng,xg,yg,n,x,y,ierr) + +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Map input data given on single, discrete points onto a set of target =* +!= bins. =* +!= The original input data are given on single, discrete points of an =* +!= arbitrary grid and are being linearly interpolated onto a specified set =* +!= of target bins. In general, this is the case for most of the weighting =* +!= functions (action spectra, molecular cross section, and quantum yield =* +!= data), which have to be matched onto the specified wavelength intervals. =* +!= The average value in each target bin is found by averaging the trapezoi- =* +!= dal area underneath the input data curve (constructed by linearly connec-=* +!= ting the discrete input values). =* +!= Some caution should be used near the endpoints of the grids. If the =* +!= input data set does not span the range of the target grid, an error =* +!= message is printed and the execution is stopped, as extrapolation of the =* +!= data is not permitted. =* +!= If the input data does not encompass the target grid, use ADDPNT to =* +!= expand the input array. =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= NG - INTEGER, number of bins + 1 in the target grid (I)=* +!= XG - REAL, target grid (e.g., wavelength grid); bin i is defined (I)=* +!= as [XG(i),XG(i+1)] (i = 1..NG-1) =* +!= YG - REAL, y-data re-gridded onto XG, YG(i) specifies the value for (O)=* +!= bin i (i = 1..NG-1) =* +!= N - INTEGER, number of points in input grid (I)=* +!= X - REAL, grid on which input data are defined (I)=* +!= Y - REAL, input y-data (I)=* +!-----------------------------------------------------------------------------* + + IMPLICIT NONE + +! input: + INTEGER ng, n + REAL x(n), y(n), xg(ng) + +! output: + REAL yg(ng) + +! local: + REAL area, xgl, xgu + REAL darea, slope + REAL a1, a2, b1, b2 + INTEGER ngintv + INTEGER i, k, jstart + INTEGER ierr + + ierr = 0 + +! test for correct ordering of data, by increasing value of x + + DO i = 2, n + IF (x(i) .LE. x(i-1)) THEN + ierr = 1 + call wrf_debug( 0,'inter2: ERROR <<< x-grid not sorted' ) + RETURN + ENDIF + ENDDO + + DO i = 2, ng + IF (xg(i) .LE. xg(i-1)) THEN + ierr = 2 + call wrf_debug( 0,'inter2: ERROR <<< xg-grid not sorted!' ) + RETURN + ENDIF + ENDDO + +! check for xg-values outside the x-range + + IF ( (x(1) .GT. xg(1)) .OR. (x(n) .LT. xg(ng)) ) THEN + call wrf_error_fatal( 'inter2: <<< Data do not span grid; Use ADDPNT to expand data and re-run.' ) + ENDIF + +! find the integral of each grid interval and use this to +! calculate the average y value for the interval +! xgl and xgu are the lower and upper limits of the grid interval + + jstart = 1 + ngintv = ng - 1 + DO i = 1,ngintv + +! initalize: + area = 0.0 + xgl = xg(i) + xgu = xg(i+1) + +! discard data before the first grid interval and after the +! last grid interval +! for internal grid intervals, start calculating area by interpolating +! between the last point which lies in the previous interval and the +! first point inside the current interval + + k = jstart + IF (k .LE. n-1) THEN + +! if both points are before the first grid, go to the next point + 30 CONTINUE + IF (x(k+1) .LE. xgl) THEN + jstart = k - 1 + k = k+1 + IF (k .LE. n-1) GO TO 30 + ENDIF + +! if the last point is beyond the end of the grid, complete and go to the next +! grid + 40 CONTINUE + IF ((k .LE. n-1) .AND. (x(k) .LT. xgu)) THEN + jstart = k-1 +! compute x-coordinates of increment + a1 = MAX(x(k),xgl) + a2 = MIN(x(k+1),xgu) +! if points coincide, contribution is zero + IF (x(k+1).EQ.x(k)) THEN + darea = 0.e0 + ELSE + slope = (y(k+1) - y(k))/(x(k+1) - x(k)) + b1 = y(k) + slope*(a1 - x(k)) + b2 = y(k) + slope*(a2 - x(k)) + darea = (a2 - a1)*(b2 + b1)/2. + ENDIF + +! find the area under the trapezoid from a1 to a2 + area = area + darea +! go to next point + k = k+1 + GO TO 40 + ENDIF + ENDIF + +! calculate the average y after summing the areas in the interval + yg(i) = area/(xgu - xgl) + + ENDDO + + END SUBROUTINE inter2 + +!=============================================================================* + + SUBROUTINE inter3(ng,xg,yg, n,x,y, FoldIn) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Map input data given on a set of bins onto a different set of target =* +!= bins. =* +!= The input data are given on a set of bins (representing the integral =* +!= of the input quantity over the range of each bin) and are being matched =* +!= onto another set of bins (target grid). A typical example would be an =* +!= input data set spcifying the extra-terrestrial flux on wavelength inter- =* +!= vals, that has to be matched onto the working wavelength grid. =* +!= The resulting area in a given bin of the target grid is calculated by =* +!= simply adding all fractional areas of the input data that cover that =* +!= particular target bin. =* +!= Some caution should be used near the endpoints of the grids. If the =* +!= input data do not span the full range of the target grid, the area in =* +!= the "missing" bins will be assumed to be zero. If the input data extend =* +!= beyond the upper limit of the target grid, the user has the option to =* +!= integrate the "overhang" data and fold the remaining area back into the =* +!= last target bin. Using this option is recommended when re-gridding =* +!= vertical profiles that directly affect the total optical depth of the =* +!= model atmosphere. =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= NG - INTEGER, number of bins + 1 in the target grid (I)=* +!= XG - REAL, target grid (e.g. working wavelength grid); bin i (I)=* +!= is defined as [XG(i),XG(i+1)] (i = 1..NG-1) =* +!= YG - REAL, y-data re-gridded onto XG; YG(i) specifies the (O)=* +!= y-value for bin i (i = 1..NG-1) =* +!= N - INTEGER, number of bins + 1 in the input grid (I)=* +!= X - REAL, input grid (e.g. data wavelength grid); bin i is (I)=* +!= defined as [X(i),X(i+1)] (i = 1..N-1) =* +!= Y - REAL, input y-data on grid X; Y(i) specifies the (I)=* +!= y-value for bin i (i = 1..N-1) =* +!= FoldIn - Switch for folding option of "overhang" data (I)=* +!= FoldIn = 0 -> No folding of "overhang" data =* +!= FoldIn = 1 -> Integerate "overhang" data and fold back into =* +!= last target bin =* +!-----------------------------------------------------------------------------* + + IMPLICIT NONE + +! input: + INTEGER n, ng + REAL xg(ng) + REAL x(n), y(n) + + INTEGER FoldIn + +! output: + REAL yg(ng) + +! local: + REAL a1, a2, sum + REAL tail + INTEGER jstart, i, j, k + +! check whether flag given is legal + IF ((FoldIn .NE. 0) .AND. (FoldIn .NE. 1)) THEN + call wrf_error_fatal( 'inter3: ERROR <<< Value for FOLDIN invalid. Must be 0 or 1' ) + ENDIF + +! do interpolation + + jstart = 1 + DO i = 1, ng - 1 + yg(i) = 0. + sum = 0. + j = jstart + IF (j .LE. n-1) THEN + 20 CONTINUE + + IF (x(j+1) .LT. xg(i)) THEN + jstart = j + j = j+1 + IF (j .LE. n-1) GO TO 20 + ENDIF + + 25 CONTINUE + + IF ((x(j) .LE. xg(i+1)) .AND. (j .LE. n-1)) THEN + a1 = MAX(x(j),xg(i)) + a2 = MIN(x(j+1),xg(i+1)) + sum = sum + y(j) * (a2-a1)/(x(j+1)-x(j)) + j = j+1 + GO TO 25 + ENDIF + yg(i) = sum + ENDIF + ENDDO + + +! if wanted, integrate data "overhang" and fold back into last bin + + IF (FoldIn .EQ. 1) THEN + j = j-1 + a1 = xg(ng) ! upper limit of last interpolated bin + a2 = x(j+1) ! upper limit of last input bin considered +! do folding only if grids don't match up and there is more input + IF ((a2 .GT. a1) .OR. (j+1 .LT. n)) THEN + tail = y(j) * (a2-a1)/(x(j+1)-x(j)) + DO k = j+1, n-1 + tail = tail + y(k) * (x(k+1)-x(k)) + ENDDO + yg(ng-1) = yg(ng-1) + tail + ENDIF + ENDIF + + END SUBROUTINE inter3 + +!=============================================================================* + + SUBROUTINE inter4(ng,xg,yg, n,x,y, FoldIn) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Map input data given on a set of bins onto a different set of target =* +!= bins. =* +!= The input data are given on a set of bins (representing the integral =* +!= of the input quantity over the range of each bin) and are being matched =* +!= onto another set of bins (target grid). A typical example would be an =* +!= input data set spcifying the extra-terrestrial flux on wavelength inter- =* +!= vals, that has to be matched onto the working wavelength grid. =* +!= The resulting area in a given bin of the target grid is calculated by =* +!= simply adding all fractional areas of the input data that cover that =* +!= particular target bin. =* +!= Some caution should be used near the endpoints of the grids. If the =* +!= input data do not span the full range of the target grid, the area in =* +!= the "missing" bins will be assumed to be zero. If the input data extend =* +!= beyond the upper limit of the target grid, the user has the option to =* +!= integrate the "overhang" data and fold the remaining area back into the =* +!= last target bin. Using this option is recommended when re-gridding =* +!= vertical profiles that directly affect the total optical depth of the =* +!= model atmosphere. =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= NG - INTEGER, number of bins + 1 in the target grid (I)=* +!= XG - REAL, target grid (e.g. working wavelength grid); bin i (I)=* +!= is defined as [XG(i),XG(i+1)] (i = 1..NG-1) =* +!= YG - REAL, y-data re-gridded onto XG; YG(i) specifies the (O)=* +!= y-value for bin i (i = 1..NG-1) =* +!= N - INTEGER, number of bins + 1 in the input grid (I)=* +!= X - REAL, input grid (e.g. data wavelength grid); bin i is (I)=* +!= defined as [X(i),X(i+1)] (i = 1..N-1) =* +!= Y - REAL, input y-data on grid X; Y(i) specifies the (I)=* +!= y-value for bin i (i = 1..N-1) =* +!= FoldIn - Switch for folding option of "overhang" data (I)=* +!= FoldIn = 0 -> No folding of "overhang" data =* +!= FoldIn = 1 -> Integerate "overhang" data and fold back into =* +!= last target bin =* +!-----------------------------------------------------------------------------* + + IMPLICIT NONE + +! input: + INTEGER n, ng + REAL xg(ng) + REAL x(n), y(n) + + INTEGER FoldIn + +! output: + REAL yg(ng) + +! local: + REAL a1, a2, sum + REAL tail + INTEGER jstart, i, j, k + +! check whether flag given is legal + IF ((FoldIn .NE. 0) .AND. (FoldIn .NE. 1)) THEN + call wrf_error_fatal( 'inter3: ERROR <<< Value for FOLDIN invalid. Must be 0 or 1' ) + ENDIF + +! do interpolation + + jstart = 1 + DO i = 1, ng - 1 + yg(i) = 0. + sum = 0. + j = jstart + IF (j .LE. n-1) THEN + 20 CONTINUE + IF (x(j+1) .LT. xg(i)) THEN + jstart = j + j = j+1 + IF (j .LE. n-1) GO TO 20 + ENDIF + 25 CONTINUE + IF ((x(j) .LE. xg(i+1)) .AND. (j .LE. n-1)) THEN + a1 = MAX(x(j),xg(i)) + a2 = MIN(x(j+1),xg(i+1)) + sum = sum + y(j) * (a2-a1) + j = j+1 + GO TO 25 + ENDIF + yg(i) = sum /(xg(i+1)-xg(i)) + ENDIF + ENDDO + + +! if wanted, integrate data "overhang" and fold back into last bin + + IF (FoldIn .EQ. 1) THEN + j = j-1 + a1 = xg(ng) ! upper limit of last interpolated bin + a2 = x(j+1) ! upper limit of last input bin considered +! do folding only if grids don't match up and there is more input + IF ((a2 .GT. a1) .OR. (j+1 .LT. n)) THEN + tail = y(j) * (a2-a1)/(x(j+1)-x(j)) + DO k = j+1, n-1 + tail = tail + y(k) * (x(k+1)-x(k)) + ENDDO + yg(ng-1) = yg(ng-1) + tail + ENDIF + ENDIF + + END SUBROUTINE inter4 + +!=============================================================================* + + SUBROUTINE addpnt ( x, y, ld, n, xnew, ynew ) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Add a point to a set of data pairs . x must be in =* +!= ascending order =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= X - REAL vector of length LD, x-coordinates (IO)=* +!= Y - REAL vector of length LD, y-values (IO)=* +!= LD - INTEGER, dimension of X, Y exactly as declared in the calling (I)=* +!= program =* +!= N - INTEGER, number of elements in X, Y. On entry, it must be: (IO)=* +!= N < LD. On exit, N is incremented by 1. =* +!= XNEW - REAL, x-coordinate at which point is to be added (I)=* +!= YNEW - REAL, y-value of point to be added (I)=* +!-----------------------------------------------------------------------------* + + IMPLICIT NONE + +! calling parameters + + INTEGER, intent(in) :: ld + INTEGER, intent(inout) :: n + REAL, intent(inout) :: x(ld), y(ld) + REAL, intent(in) :: xnew, ynew + +! local variables + + INTEGER insert + INTEGER i + CHARACTER(len=256) :: emsg + +! check n needs to be appended at the end, just do so, +! otherwise, insert at position INSERT + + IF ( xnew .GT. x(n) ) THEN + x(n+1) = xnew + y(n+1) = ynew + ELSE +! shift all existing points one index up + DO i = n, insert, -1 + x(i+1) = x(i) + y(i+1) = y(i) + ENDDO +! insert new point + x(insert) = xnew + y(insert) = ynew + ENDIF + +! increase total number of elements in x, y + + n = n+1 + + END SUBROUTINE addpnt diff --git a/wrfv2_fire/chem/optical_driver.F b/wrfv2_fire/chem/optical_driver.F index 528fd8cf..92554e55 100755 --- a/wrfv2_fire/chem/optical_driver.F +++ b/wrfv2_fire/chem/optical_driver.F @@ -113,7 +113,7 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& select case (config_flags%chem_opt) case ( RADM2SORG, RADM2SORG_KPP, RADM2SORG_AQ, RADM2SORG_AQCHEM, & GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & - RACM_ESRLSORG_AQCHEM_KPP, RACM_SOA_VBS_KPP, & + RACM_ESRLSORG_AQCHEM_KPP, RACM_SOA_VBS_KPP, RACM_SOA_VBS_AQCHEM_KPP, & GOCARTRACM_KPP, GOCARTRADM2, & RACM_ESRLSORG_KPP, MOZCART_KPP, & CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN, CBMZ_MOSAIC_KPP, & @@ -144,7 +144,7 @@ SUBROUTINE optical_driver(id,curr_secs,dtstep,config_flags,haveaer,& case ( RADM2SORG, RACM_ESRLSORG_KPP, RADM2SORG_KPP, RADM2SORG_AQ, RADM2SORG_AQCHEM, & GOCARTRACM_KPP, GOCARTRADM2, & GOCART_SIMPLE, RACMSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP, & - RACM_ESRLSORG_AQCHEM_KPP, RACM_SOA_VBS_KPP, & + RACM_ESRLSORG_AQCHEM_KPP, RACM_SOA_VBS_KPP, RACM_SOA_VBS_AQCHEM_KPP, & CBMZSORG, CBMZSORG_AQ, MOZCART_KPP, & CBMZ_CAM_MAM3_NOAQ, CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM3_AQ, CBMZ_CAM_MAM7_AQ, & CB05_SORG_AQ_KPP, CB05_SORG_VBS_AQ_KPP ) diff --git a/wrfv2_fire/chem/params.mod.F b/wrfv2_fire/chem/params.mod.F new file mode 100644 index 00000000..90a3a474 --- /dev/null +++ b/wrfv2_fire/chem/params.mod.F @@ -0,0 +1,52 @@ + module module_params + + implicit none + +! BROADLY USED PARAMETERS: +!_________________________________________________ +! i/o file unit numbers +! output + INTEGER, PARAMETER :: kout=53 +! input + INTEGER, PARAMETER :: kin=12 +!_________________________________________________ +! altitude, wavelength, time (or solar zenith angle) grids +! altitude + integer, PARAMETER :: kz=125 +! wavelength + integer, PARAMETER :: kw=1000 +! time/sza + integer, PARAMETER :: kt=100 +!_________________________________________________ +! number of weighting functions +! wavelength dependent + integer, PARAMETER :: ks=60 +! wavelength and altitude dependent + integer, PARAMETER :: kj=150 +! wavelength dependent DOM (dissolved organic matter) spectra + integer, PARAMETER :: kdom=200 +! delta for adding points at beginning or end of data grids + real, PARAMETER :: deltax = 1.E-5 + +! some constants... + +! pi: + real, PARAMETER :: pi=3.1415926535898 + +! radius of the earth, km: + real, PARAMETER :: radius=6.371E+3 + +! Planck constant x speed of light, J m + real, PARAMETER :: hc = 6.626068E-34 * 2.99792458E8 + +! largest number of the machine: + real, PARAMETER :: largest=1.E+36 + +! small numbers (positive and negative) + real, PARAMETER :: pzero = +10./largest + real, PARAMETER :: nzero = -10./largest + +! machine precision + real, PARAMETER :: precis = 1.e-7 + + end module module_params diff --git a/wrfv2_fire/chem/params_mod.F b/wrfv2_fire/chem/params_mod.F new file mode 100644 index 00000000..b244e1bd --- /dev/null +++ b/wrfv2_fire/chem/params_mod.F @@ -0,0 +1,25 @@ + module PARAMS_MOD + + implicit none + + integer, parameter :: dp = selected_real_kind(14,300) + + real, parameter :: m2km = .001 ! meters to km + real, parameter :: ppm2vmr = 1.e-6 ! ppm to vmr + real, parameter :: o2vmr = .2095 ! o2 vmr + real, parameter :: km2cm = 1.e5 ! km to centimeters + real, parameter :: m2s = 60. ! minutes to seconds + + REAL, PARAMETER :: pi = 3.1415926535898 + REAL, PARAMETER :: radius = 6.371E+3 ! km + REAL, PARAMETER :: hc = 6.626068E-34 * 2.99792458E8 + REAL, PARAMETER :: largest=1.E+36 + + REAL, PARAMETER :: pzero = +10./largest + REAL, PARAMETER :: nzero = -10./largest + + REAL, PARAMETER :: precis = 1.e-7 + + real :: lambda_cutoff ! nm + + end module PARAMS_MOD diff --git a/wrfv2_fire/chem/photolysis_driver.F b/wrfv2_fire/chem/photolysis_driver.F index 925ae8f1..588f36da 100755 --- a/wrfv2_fire/chem/photolysis_driver.F +++ b/wrfv2_fire/chem/photolysis_driver.F @@ -2,8 +2,9 @@ ! SUBROUTINE photolysis_driver (id,curr_secs,ktau,dtstep, & config_flags,haveaer, & + dt_cld,af_dir,af_dn,af_up,par,erythema, & gmt,julday,t_phy,moist,aerwrf,p8w,t8w,p_phy, & - chem,rho_phy,dz8w,xlat,xlong,z_at_w,gd_cloud,gd_cloud2, & + chem,rho_phy,dz8w,xlat,xlong,z,z_at_w,gd_cloud,gd_cloud2, & ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2, & ph_no3o,ph_hno2,ph_hno3,ph_hno4,ph_h2o2, & ph_ch2or,ph_ch2om,ph_ch3cho,ph_ch3coch3, & @@ -36,6 +37,7 @@ SUBROUTINE photolysis_driver (id,curr_secs,ktau,dtstep, & USE module_phot_mad USE module_phot_fastj USE module_ftuv_driver + USE module_phot_tuv, only : tuv_driver INTEGER, INTENT(IN ) :: id,julday, & ids,ide, jds,jde, kds,kde, & @@ -71,6 +73,14 @@ SUBROUTINE photolysis_driver (id,curr_secs,ktau,dtstep, & ph_terpooh,ph_mvk,ph_glyald,ph_hyac, & ph_cl2,ph_hocl,ph_fmcl + REAL, INTENT(INOUT) :: & + dt_cld(ims:ime,kms:kme,jms:jme), & + af_dir(ims:ime,kms:kme,jms:jme), & + af_dn(ims:ime,kms:kme,jms:jme), & + af_up(ims:ime,kms:kme,jms:jme), & + par(ims:ime,kms:kme,jms:jme), & + erythema(ims:ime,kms:kme,jms:jme) + INTEGER, INTENT(IN ) :: nref0, nw0, tuv_jmax0 real, dimension( ims:ime, nref0, jms:jme, nw0 ), & intent(out ) :: ph_radfld @@ -111,7 +121,7 @@ SUBROUTINE photolysis_driver (id,curr_secs,ktau,dtstep, & t_phy, & p_phy, & dz8w, & - t8w,p8w,z_at_w , & + t8w,p8w,z,z_at_w, & rho_phy REAL, DIMENSION( ims:ime , jms:jme ) , & INTENT(INOUT ) :: uvrad @@ -199,6 +209,27 @@ SUBROUTINE photolysis_driver (id,curr_secs,ktau,dtstep, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) + CASE (TUV) + CALL wrf_debug(15,'calling tuv driver') + call tuv_driver( & + id, curr_secs, ktau, config_flags, haveaer, & + gmt, julday, t_phy, moist, aerwrf, & + p8w, t8w, p_phy, chem, rho_phy, & + dz8w, xlat, xlong, z, z_at_w, gd_cloud, gd_cloud2, & + tauaer1,tauaer2,tauaer3,tauaer4, & + gaer1,gaer2,gaer3,gaer4, & + waer1,waer2,waer3,waer4, & + ph_macr,ph_o31d,ph_o33p,ph_no2,ph_no3o2,ph_no3o,ph_hno2,& + ph_hno3,ph_hno4,ph_h2o2,ph_ch2or,ph_ch2om,ph_ch3cho, & + ph_ch3coch3,ph_ch3coc2h5,ph_hcocho,ph_ch3cocho, & + ph_hcochest,ph_ch3o2h,ph_ch3coo2h,ph_ch3ono2,ph_hcochob,& + ph_n2o5,ph_o2,ph_n2o,ph_pooh,ph_pan,ph_mvk,ph_hyac, & + ph_glyald,ph_mek,ph_gly, & + pm2_5_dry, pm2_5_water, uvrad, & + dt_cld,af_dir,af_dn,af_up,par,erythema, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte ) CASE DEFAULT END SELECT chem_phot_select diff --git a/wrfv2_fire/chem/rdxs.F b/wrfv2_fire/chem/rdxs.F new file mode 100644 index 00000000..ae9bbd14 --- /dev/null +++ b/wrfv2_fire/chem/rdxs.F @@ -0,0 +1,1105 @@ +! This file contains subroutines related to reading the +! absorption cross sections of gases that contribute to atmospheric transmission: +! Some of these subroutines are also called from rxn.f when loading photolysis cross sections +! for these same gases. It is possible to have different cross sections for +! transmission and for photolysis, e.g. for ozone, Bass et al. could be used +! for transmission while Molina and Molina could be used for photolysis. +! This flexibility can be useful but users should be aware. +! For xsections that are temperature dependent, caution should be used in passing the proper +! temperature to the data routines. Usually, transmission is for layers, TLAY(NZ-1), while +! photolysis is at levels, T(NZ). +! The following subroutines are her: +! rdo3xs +! o3_mol +! o3_rei +! o3_bas +! o3_wmo +! o3_jpl +! rdo2xs +! rdno2xs +! no2xs_d +! no2xs_jpl94 +! no2xs_har +! no2xs_jpl06a +! no2xs_jpl06b +! rdso2xs +!=============================================================================* + + module module_xsections + + use module_params + + IMPLICIT NONE + + public :: o3xs, rdo2xs, rdso2xs, no2xs_jpl06a + public :: rdxs_init + private + + REAL, allocatable :: rei218(:), rei228(:), rei243(:), rei295(:) + REAL :: v195, v345, v830 + REAL, allocatable :: wmo203(:), wmo273(:) + REAL :: v176, v850 + + REAL, allocatable :: jpl295(:), jpl218(:) + REAL :: v186, v825 + + REAL, allocatable :: mol226(:), mol263(:), mol298(:) + REAL :: v185, v240, v350 + + REAL, allocatable :: c0(:), c1(:), c2(:) + REAL vb245, vb342 + + REAL, allocatable :: no2xs_a(:), no2xs_b(:) + + CONTAINS + + SUBROUTINE rdxs_init( nw, wl ) + + integer, intent(in) :: nw + real, intent(in) :: wl(nw) + + integer :: istat, astat + + istat = 0 + if( .not. allocated( rei218 ) ) then + allocate( rei218(nw-1),rei228(nw-1),rei243(nw-1),rei295(nw-1),stat=astat ) + istat = istat + astat + endif + if( .not. allocated( wmo203 ) ) then + allocate( wmo203(nw-1),wmo273(nw-1),stat=astat ) + istat = istat + astat + endif + if( .not. allocated( jpl218 ) ) then + allocate( jpl218(nw-1),jpl295(nw-1),stat=astat ) + istat = istat + astat + endif + if( .not. allocated( mol226 ) ) then + allocate( mol226(nw-1),mol263(nw-1),mol298(nw-1),stat=astat ) + istat = istat + astat + endif + if( .not. allocated( c0 ) ) then + allocate( c0(nw-1),c1(nw-1),c2(nw-1),stat=astat ) + istat = istat + astat + endif + if( .not. allocated( no2xs_a ) ) then + allocate( no2xs_a(nw-1),no2xs_b(nw-1),stat=astat ) + istat = istat + astat + endif + +!_______________________________________________________________________ +! read data from different sources +! rei = Reims group (Malicet et al., Brion et al.) +! jpl = JPL 2006 evaluation +! wmo = WMO 1985 O3 assessment +! mol = Molina and Molina +! bas = Bass et al. +!_______________________________________________________________________ + CALL o3_rei(nw,wl) + CALL o3_jpl(nw,wl) + CALL o3_wmo(nw,wl) + CALL o3_mol(nw,wl) + CALL o3_bas(nw,wl) + + CALL rdno2xs(nw,wl) + + END SUBROUTINE rdxs_init + + SUBROUTINE o3xs(nz,t,nw,wl, xs) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Read ozone molecular absorption cross section. Re-grid data to match =* +!= specified wavelength working grid. Interpolate in temperature as needed =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= MABS - INTEGER, option for splicing different combinations of (I)=* +!= absorption cross secttions =* +!= NZ - INTEGER, number of altitude levels or layers (I)=* +!= T - REAL, temperature of levels or layers (I)=* +!= NW - INTEGER, number of specified intervals + 1 in working (I)=* +!= wavelength grid =* +!= WL - REAL, vector of lower limits of wavelength intervals in (I)=* +!= working wavelength grid. In vacuum, nm =* +!= XS - REAL, molecular absoprtion cross section (cm^2) of O3 at (O)=* +!= each specified wavelength (WMO value at 273) =* +!-----------------------------------------------------------------------------* + +! input: (altitude working grid) + + INTEGER, intent(in) :: nw + REAL, intent(in) :: wl(nw) + + INTEGER, intent(in) :: nz + REAL, intent(in) :: t(nz) + +! output: +! ozone absorption cross sections interpolated to +! working wavelength grid (iw) +! working altitude grid (iz) for temperature of layer or level (specified in call) +! Units are cm2 molecule-1 in vacuum + + REAL, intent(inout) :: xs(:,:) + +! internal + + INTEGER :: iz, iw + REAL :: factor, factor1 + REAL :: tc(nz) + +!***** option 1: +! assign according to wavelength range: +! 175.439 - 185.185 1985WMO (203, 273 K) +! 185.185 - 195.00 2006JPL_O3 (218, 295 K) +! 195.00 - 345.00 Reims group (218, 228, 243, 295 K) +! 345.00 - 830.00 Reims group (295 K) +! no extrapolations in temperature allowed + + DO iw = 1, nw-1 + IF(wl(iw) < v185) THEN + factor = (wmo273(iw) - wmo203(iw))/(273. - 203.) + xs(1:nz,iw) = wmo203(iw) + (t(1:nz) - 203.)*factor + WHERE (t(1:nz) <= 203.) + xs(1:nz,iw) = wmo203(iw) + ELSEWHERE (t(1:nz) >= 273.) + xs(1:nz,iw) = wmo273(iw) + ENDWHERE + ELSEIF(wl(iw) >= v185 .AND. wl(iw) < v195) THEN + factor = (jpl295(iw) - jpl218(iw))/(295. - 218.) + xs(1:nz,iw) = jpl218(iw) + (t(1:nz) - 218.)*factor + WHERE (t(1:nz) <= 218.) + xs(1:nz,iw) = jpl218(iw) + ELSEWHERE (t(1:nz) >= 295.) + xs(1:nz,iw) = jpl295(iw) + ENDWHERE + ELSEIF(wl(iw) >= v195 .AND. wl(iw) < v345) THEN + factor = .1*(rei228(iw) - rei218(iw)) + WHERE( t(1:nz) < 218. ) + xs(1:nz,iw) = rei218(iw) + ELSEWHERE( t(1:nz) >= 218. .AND. t(1:nz) < 228. ) + xs(1:nz,iw) = rei218(iw) + (t(1:nz) - 218.)*factor + ENDWHERE + factor = (rei243(iw) - rei228(iw))/15. + WHERE( t(1:nz) >= 228. .AND. t(1:nz) < 243. ) + xs(1:nz,iw) = rei228(iw) + (t(1:nz) - 228.)*factor + ENDWHERE + factor = (rei295(iw) - rei243(iw))/(295. - 243.) + WHERE( t(1:nz) >= 243. .AND. t(1:nz) < 295.) + xs(1:nz,iw) = rei243(iw) + (t(1:nz) - 243.)*factor + ELSEWHERE( t(1:nz) >= 295. ) + xs(1:nz,iw) = rei295(iw) + ENDWHERE + ELSEIF(wl(iw) >= v345) THEN + xs(1:nz,iw) = rei295(iw) + ENDIF + END DO + + END SUBROUTINE o3xs + +!=============================================================================* + + SUBROUTINE o3_rei(nw,wl) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Read and interpolate the O3 cross section from Reims group =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= NW - INTEGER, number of specified intervals + 1 in working (I)=* +!= wavelength grid =* +!= WL - REAL, vector of lower limits of wavelength intervals in (I)=* +!= working wavelength grid =* +!= REI218 - REAL, cross section (cm^2) for O3 at 218K (O)=* +!= REI228 - REAL, cross section (cm^2) for O3 at 218K (O)=* +!= REI243 - REAL, cross section (cm^2) for O3 at 218K (O)=* +!= REI295 - REAL, cross section (cm^2) for O3 at 218K (O)=* +!= V195 - REAL, exact wavelength in vacuum for data breaks (O)=* +!= e.g. start, stop, or other change =* +!= V345 - REAL, exact wavelength in vacuum for data breaks (O)=* +!= V830 - REAL, exact wavelength in vacuum for data breaks (O)=* +!-----------------------------------------------------------------------------* + +! input + + INTEGER, intent(in) :: nw + REAL, intent(in) :: wl(nw) + +!* internal + + INTEGER, PARAMETER :: kdata = 70000 + + INTEGER n1, n2, n3, n4, iw + REAL x1(kdata), x2(kdata), x3(kdata), x4(kdata) + REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata) + + INTEGER i + INTEGER ierr + +! used for air-to-vacuum wavelength conversion + + REAL ri(kdata) + CHARACTER(len=256) :: emsg + +! data from the Reims group: +!= For Hartley and Huggins bands, use temperature-dependent values from =* +!= Malicet et al., J. Atmos. Chem. v.21, pp.263-273, 1995. =* +!= over 345.01 - 830.00, use values from Brion, room temperature only + + OPEN(UNIT=kin,FILE='DATAE1/O3/1995Malicet_O3.txt',STATUS='old',iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_rei: Failed to open DATAE1/O3/1985Malicet_O3.txt' ) + endif + DO i = 1, 2 + READ(kin,*,iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_rei: Failed to read DATAE1/O3/1985Malicet_O3.txt' ) + endif + ENDDO + n1 = 15001 + n2 = 15001 + n3 = 15001 + n4 = 15001 + DO i = 1, n1 + READ(kin,*,iostat=ierr) x1(i), y1(i), y2(i), y3(i), y4(i) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_rei: Failed to read DATAE1/O3/1985Malicet_O3.txt' ) + endif + x2(i) = x1(i) + x3(i) = x1(i) + x4(i) = x1(i) + ENDDO + CLOSE (kin) + +!= over 345.01 - 830.00, use values from Brion, room temperature only +! skip datum at 345.00 because already read in from 1995Malicet + + OPEN(UNIT=kin,FILE='DATAE1/O3/1998Brion_295.txt',STATUS='old') + DO i = 1, 15 + READ(kin,*) + ENDDO + DO i = 1, 48515-15 + n1 = n1 + 1 + READ(kin,*) x1(n1), y1(n1) + ENDDO + CLOSE (kin) + + DO i = 1, n1 + ri(i) = refrac(x1(i), 2.45E19) + ENDDO + DO i = 1, n1 + x1(i) = x1(i) * ri(i) + ENDDO + + CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + CALL addpnt(x1,y1,kdata,n1, 0.,0.) + CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.) + CALL inter2(nw,wl,rei295,n1,x1,y1,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_rei: interp err = '',i5,'' in O3 xsect - Reims 295K'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + DO i = 1, n2 + ri(i) = refrac(x2(i), 2.45E19) + ENDDO + DO i = 1, n2 + x2(i) = x2(i) * ri(i) + x3(i) = x2(i) + x4(i) = x2(i) + ENDDO + + CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.) + CALL addpnt(x2,y2,kdata,n2, 0.,0.) + CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.) + CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.) + CALL inter2(nw,wl,rei243,n2,x2,y2,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_wmo: interp err = '',i5,'' in O3 xsect - Reims 243K'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.) + CALL addpnt(x3,y3,kdata,n3, 0.,0.) + CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.) + CALL addpnt(x3,y3,kdata,n3, 1.e+38,0.) + CALL inter2(nw,wl,rei228,n3,x3,y3,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_wmo: interp err = '',i5,'' in O3 xswct - Reims 228K'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + CALL addpnt(x4,y4,kdata,n4,x4(1)*(1.-deltax),0.) + CALL addpnt(x4,y4,kdata,n4, 0.,0.) + CALL addpnt(x4,y4,kdata,n4,x4(n4)*(1.+deltax),0.) + CALL addpnt(x4,y4,kdata,n4, 1.e+38,0.) + CALL inter2(nw,wl,rei218,n4,x4,y4,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_wmo: interp err = '',i5,'' in O3 xswct - Reims 218K'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + +! wavelength breaks must be converted to vacuum: + + v195 = 195.00 * refrac(195.00, 2.45E19) + v345 = 345.00 * refrac(345.00, 2.45E19) + v830 = 830.00 * refrac(830.00, 2.45E19) + + END SUBROUTINE o3_rei + +!=============================================================================* + + SUBROUTINE o3_wmo(nw,wl) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Read and interpolate the O3 cross section =* +!= data from WMO 85 Ozone Assessment =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= NW - INTEGER, number of specified intervals + 1 in working (I)=* +!= wavelength grid =* +!= WL - REAL, vector of lower limits of wavelength intervals in (I)=* +!= working wavelength grid =* +!= WMO203 - REAL, cross section (cm^2) for O3 at 203K (O)=* +!= WMO273 - REAL, cross section (cm^2) for O3 at 273K (O)=* +!= V176 - REAL, exact wavelength in vacuum for data breaks (O)=* +!= e.g. start, stop, or other change =* +!= V850 - REAL, exact wavelength in vacuum for data breaks (O)=* +!-----------------------------------------------------------------------------* + +! input + + INTEGER, intent(in) :: nw + REAL, intent(in) :: wl(nw) + +! internal + + INTEGER, parameter :: kdata = 200 + + INTEGER n1, n2 + REAL x1(kdata), x2(kdata) + REAL y1(kdata), y2(kdata) + + INTEGER i, idum, iw + REAL a1, a2, dum + INTEGER ierr + +! used for air-to-vacuum wavelength conversion + + REAL ri(kdata) + CHARACTER(len=256) :: emsg + +! output + +!---------------------------------------------------------- +! cross sections from WMO 1985 Ozone Assessment +! from 175.439 to 847.500 nm + + OPEN(UNIT=kin,FILE='DATAE1/wmo85',STATUS='old',iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_wmo: Failed to open DATAE1/wmo85' ) + endif + DO i = 1, 3 + read(kin,*,iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_wmo: Failed to read DATAE1/wmo85' ) + endif + ENDDO + n1 = 158 + n2 = 158 + DO i = 1, n1 + READ(kin,*,iostat=ierr) idum, a1, a2, dum, dum, dum, y1(i), y2(i) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_wmo: Failed to read DATAE1/wmo85' ) + endif + x1(i) = (a1+a2)/2. + x2(i) = (a1+a2)/2. + ENDDO + CLOSE (kin) + +! convert wavelengths to vacuum + + DO i = 1, n1 + ri(i) = refrac(x1(i), 2.45E19) + ENDDO + DO i = 1, n1 + x1(i) = x1(i) * ri(i) + x2(i) = x2(i) * ri(i) + ENDDO + + CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + CALL addpnt(x1,y1,kdata,n1, 0.,0.) + CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.) + CALL inter2(nw,wl,wmo203,n1,x1,y1,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_wmo: interp err = '',i5,'' in O3 cross section - WMO - 203K'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.) + CALL addpnt(x2,y2,kdata,n2, 0.,0.) + CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.) + CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.) + CALL inter2(nw,wl,wmo273,n2,x2,y2,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_wmo: interp err = '',i5,'' in O3 cross section - WMO - 273K'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + +! wavelength breaks must be converted to vacuum: + + a1 = (175.438 + 176.991) / 2. + v176 = a1 * refrac(a1,2.45E19) + + a1 = (847.5 + 852.5) / 2. + v850 = a1 * refrac(a1, 2.45E19) + + END SUBROUTINE o3_wmo + +!=============================================================================* + + SUBROUTINE o3_jpl(nw,wl) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Read and interpolate the O3 cross section from JPL 2006 =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= NW - INTEGER, number of specified intervals + 1 in working (I)=* +!= wavelength grid =* +!= WL - REAL, vector of lower limits of wavelength intervals in (I)=* +!= working wavelength grid =* +!= JPL218 - REAL, cross section (cm^2) for O3 at 218K (O)=* +!= JPL295 - REAL, cross section (cm^2) for O3 at 295K (O)=* +!= V186 - REAL, exact wavelength in vacuum for data breaks (O)=* +!= e.g. start, stop, or other change =* +!= V825 - REAL, exact wavelength in vacuum for data breaks (O)=* +!-----------------------------------------------------------------------------* + +! input + + INTEGER, intent(in) :: nw + REAL, intent(in) :: wl(nw) + +! internal + + INTEGER, parameter :: kdata = 200 + + INTEGER n1, n2, iw + REAL x1(kdata), x2(kdata) + REAL y1(kdata), y2(kdata) + + INTEGER i + REAL dum + INTEGER ierr + CHARACTER(len=256) :: emsg + +! used for air-to-vacuum wavelength conversion + + REAL ri(kdata) + +! output + + OPEN(UNIT=kin,FILE='DATAE1/O3/2006JPL_O3.txt',STATUS='old',iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_jpl: Failed to open DATAE1/O3/2006JPL_O3.txt' ) + endif + DO i = 1, 2 + read(kin,*,iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_jpl: Failed to read DATAE1/O3/2006JPL_O3.txt' ) + endif + ENDDO + n1 = 167 + n2 = 167 + DO i = 1, n1 + READ(kin,*,iostat=ierr) dum, dum, x1(i), y1(i), y2(i) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_jpl: Failed to read DATAE1/O3/2006JPL_O3.txt' ) + endif + y1(i) = y1(i) * 1.e-20 + y2(i) = y2(i) * 1.e-20 + ENDDO + CLOSE (kin) + +! convert wavelengths to vacuum + + DO i = 1, n1 + ri(i) = refrac(x1(i), 2.45E19) + ENDDO + DO i = 1, n1 + x1(i) = x1(i) * ri(i) + x2(i) = x1(i) + ENDDO + + CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + CALL addpnt(x1,y1,kdata,n1, 0.,0.) + CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.) + CALL inter2(nw,wl,jpl295,n1,x1,y1,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_jpl: interp err = '',i5,'' in file O3 cross section - WMO - 295K'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.) + CALL addpnt(x2,y2,kdata,n2, 0.,0.) + CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.) + CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.) + CALL inter2(nw,wl,jpl218,n2,x2,y2,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_jpl: interp err = '',i5,'' in file O3 cross section - WMO - 218K'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + +! wavelength breaks must be converted to vacuum: + + v186 = 186.051 * refrac(186.051, 2.45E19) + v825 = 825. * refrac(825. , 2.45E19) + + + END SUBROUTINE o3_jpl + +!=============================================================================* + + SUBROUTINE o3_mol(nw,wl) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Read and interpolate the O3 cross section from Molina and Molina 1986 =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= NW - INTEGER, number of specified intervals + 1 in working (I)=* +!= wavelength grid =* +!= WL - REAL, vector of lower limits of wavelength intervals in (I)=* +!= working wavelength grid =* +!= MOL226 - REAL, cross section (cm^2) for O3 at 226 K (O)=* +!= MOL263 - REAL, cross section (cm^2) for O3 at 263 K (O)=* +!= MOL298 - REAL, cross section (cm^2) for O3 at 298 K (O)=* +!= V185 - REAL, exact wavelength in vacuum for data breaks (O)=* +!= e.g. start, stop, or other change =* +!= V240 - REAL, exact wavelength in vacuum for data breaks (O)=* +!= V350 - REAL, exact wavelength in vacuum for data breaks (O)=* +!-----------------------------------------------------------------------------* + +! input + + INTEGER, intent(in) :: nw + REAL, intent(in) :: wl(nw) + +! internal + + INTEGER i + INTEGER ierr + + INTEGER, parameter :: kdata = 335 + INTEGER n1, n2, n3, iw + REAL x1(kdata), x2(kdata), x3(kdata) + REAL y1(kdata), y2(kdata), y3(kdata) + +! used for air-to-vacuum wavelength conversion + + REAL ri(kdata) + CHARACTER(len=256) :: emsg + +! output + + OPEN(UNIT=kin,FILE='DATAE1/O3/1986Molina.txt',STATUS='old',iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_mol: Failed to open DATAE1/O3/1986Molina.txt' ) + endif + DO i = 1, 10 + READ(kin,*,iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_mol: Failed to read DATAE1/O3/1986Molina.txt' ) + endif + ENDDO + n1 = 0 + n2 = 0 + n3 = 0 + DO i = 1, 121-10 + n1 = n1 + 1 + n3 = n3 + 1 + READ(kin,*,iostat=ierr) x1(n1), y1(n1), y3(n3) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_mol: Failed to read DATAE1/O3/1986Molina.txt' ) + endif + x3(n3) = x1(n1) + ENDDO + DO i = 1, 341-122 + n1 = n1 + 1 + n2 = n2 + 1 + n3 = n3 + 1 + READ(kin,*,iostat=ierr) x1(n1), y1(n1), y2(n2), y3(n3) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_mol: Failed to read DATAE1/O3/1986Molina.txt' ) + endif + x2(n2) = x1(n1) + x3(n3) = x1(n1) + ENDDO + CLOSE (kin) + +! convert all wavelengths from air to vacuum + + DO i = 1, n1 + ri(i) = refrac(x1(i), 2.45E19) + ENDDO + DO i = 1, n1 + x1(i) = x1(i) * ri(i) + ENDDO + + DO i = 1, n2 + ri(i) = refrac(x2(i), 2.45E19) + ENDDO + DO i = 1, n2 + x2(i) = x2(i) * ri(i) + ENDDO + + DO i = 1, n3 + ri(i) = refrac(x3(i), 2.45E19) + ENDDO + DO i = 1, n3 + x3(i) = x3(i) * ri(i) + ENDDO + +! convert wavelength breaks from air to vacuum + + v185 = 185. * refrac(185. , 2.45E19) + v240 = 240.5 * refrac(240.5, 2.45E19) + v350 = 350. * refrac(350. , 2.45E19) + +! interpolate to working grid + + CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + CALL addpnt(x1,y1,kdata,n1, 0.,0.) + CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.) + CALL inter2(nw,wl,mol226,n1,x1,y1,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_mol: interp err = '',i5,'' in O3 xsect - 226K Molina'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.) + CALL addpnt(x2,y2,kdata,n2, 0.,0.) + CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.) + CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.) + CALL inter2(nw,wl,mol263,n2,x2,y2,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_mol: interp err = '',i5,'' in O3 xsect - 263K Molina'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.) + CALL addpnt(x3,y3,kdata,n3, 0.,0.) + CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.) + CALL addpnt(x3,y3,kdata,n3, 1.e+38,0.) + CALL inter2(nw,wl,mol298,n3,x3,y3,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_mol: interp err = '',i5,'' in O3 xsect - 298K Molina'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + END SUBROUTINE o3_mol + +!=============================================================================* + + SUBROUTINE o3_bas(nw,wl) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Read and interpolate the O3 cross section from Bass 1985 =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= NW - INTEGER, number of specified intervals + 1 in working (I)=* +!= wavelength grid =* +!= WL - REAL, vector of lower limits of wavelength intervals in (I)=* +!= working wavelength grid =* +!= c0 - REAL, coefficint for polynomial fit to cross section (cm^2) (O)=* +!= c1 - REAL, coefficint for polynomial fit to cross section (cm^2) (O)=* +!= c2 - REAL, coefficint for polynomial fit to cross section (cm^2) (O)=* +!= Vb245 - REAL, exact wavelength in vacuum for data breaks (O)=* +!= e.g. start, stop, or other change =* +!= Vb342 - REAL, exact wavelength in vacuum for data breaks (O)=* +!-----------------------------------------------------------------------------* + +! input: + + INTEGER, intent(in) :: nw + REAL, intent(in) :: wl(nw) + +! internal: + + INTEGER, parameter :: kdata = 2000 + + INTEGER i, iw + INTEGER ierr + + INTEGER n1, n2, n3 + REAL x1(kdata), x2(kdata), x3(kdata) + REAL y1(kdata), y2(kdata), y3(kdata) + +! used for air-to-vacuum wavelength conversion + + REAL ri(kdata) + CHARACTER(len=256) :: emsg + + OPEN(UNIT=kin,FILE='DATAE1/O3/1985Bass_O3.txt',STATUS='old',iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_bas: Failed to open DATAE1/O3/1985Bass_O3.txt' ) + endif + DO i = 1, 8 + READ(kin,*,iostat=ierr) + ENDDO + n1 = 1915 + n2 = 1915 + n3 = 1915 + DO i = 1, n1 + READ(kin,*) x1(i), y1(i), y2(i), y3(i) + if( ierr /= 0 ) then + call wrf_error_fatal( 'o3_bas: Failed to read DATAE1/O3/1985Bass_O3.txt' ) + endif + ENDDO + CLOSE (kin) + y1(1:n1) = 1.e-20 * y1(1:n1) + y2(1:n1) = 1.e-20 * y2(1:n1) + y3(1:n1) = 1.e-20 * y3(1:n1) + +! convert all wavelengths from air to vacuum + + DO i = 1, n1 + ri(i) = refrac(x1(i), 2.45E19) + ENDDO + x1(1:n1) = x1(1:n1) * ri(1:n1) + x2(1:n1) = x1(1:n1) + x3(1:n1) = x1(1:n1) + +! convert wavelength breaks to vacuum + + vb245 = 245.018 * refrac(245.018, 2.45E19) + vb342 = 341.981 * refrac(341.981, 2.45E19) + +! interpolate to working grid + + CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + CALL addpnt(x1,y1,kdata,n1, 0.,0.) + CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax),0.) + CALL addpnt(x1,y1,kdata,n1, 1.e+38,0.) + CALL inter2(nw,wl,c0,n1,x1,y1,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_bas: interp err = '',i5,'' in O3 xsect - c0 Bass'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.) + CALL addpnt(x2,y2,kdata,n2, 0.,0.) + CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax),0.) + CALL addpnt(x2,y2,kdata,n2, 1.e+38,0.) + CALL inter2(nw,wl,c1,n2,x2,y2,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_bas: interp err = '',i5,'' in O3 xsect - c1 Bass'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),0.) + CALL addpnt(x3,y3,kdata,n3, 0.,0.) + CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),0.) + CALL addpnt(x3,y3,kdata,n3, 1.e+38,0.) + CALL inter2(nw,wl,c2,n3,x3,y3,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''o3_bas: interp err = '',i5,'' in O3 xsect - c2 Bass'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + END SUBROUTINE o3_bas + +!=============================================================================* + + SUBROUTINE rdo2xs(nw,wl,o2xs1) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Compute equivalent O2 cross section, except =* +!= the SR bands and the Lyman-alpha line. =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: +!= NW - INTEGER, number of specified intervals + 1 in working (I)=* +!= wavelength grid =* +!= WL - REAL, vector of lower limits of wavelength intervals in (I)=* +!= working wavelength grid +!= vertical layer at each specified wavelength =* +!= O2XS1 - REAL, O2 molecular absorption cross section =* +!= +!-----------------------------------------------------------------------------* + +! Input + + INTEGER, intent(in) :: nw + REAL, intent(in) :: wl(nw) + +! Output O2 xsect, temporary, will be over-written in Lyman-alpha and +! Schumann-Runge wavelength bands. + + REAL, intent(inout) :: o2xs1(:) + +! Internal + + INTEGER, parameter :: kdata = 200 + INTEGER :: i, n + INTEGER :: ierr + REAL :: x, y + REAL :: x1(kdata), y1(kdata) + CHARACTER(len=256) :: emsg + +! Read O2 absorption cross section data: +! 116.65 to 203.05 nm = from Brasseur and Solomon 1986 +! 205 to 240 nm = Yoshino et al. 1988 + +! Note that subroutine la_srb.f will over-write values in the spectral regions +! corresponding to: +! - Lyman-alpha (LA: 121.4-121.9 nm, Chabrillat and Kockarts parameterization) +! - Schumann-Runge bands (SRB: 174.4-205.8 nm, Koppers parameteriaztion) + + n = 0 + + OPEN(UNIT=kin,FILE='DATAE1/O2/O2_brasseur.abs',iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'rdso2xs: Failed to open DATAE1/O2/O2_brasseur.abs' ) + endif + DO i = 1, 7 + READ(kin,*,iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'rdso2xs: Failed to read DATAE1/O2/O2_brasseur.abs' ) + endif + ENDDO + DO i = 1, 78 + READ(kin,*,iostat=ierr) x, y + if( ierr /= 0 ) then + call wrf_error_fatal( 'rdso2xs: Failed to read DATAE1/O2/O2_brasseur.abs' ) + endif + IF (x .LE. 204.) THEN + n = n + 1 + x1(n) = x + y1(n) = y + ENDIF + ENDDO + CLOSE(kin) + + OPEN(UNIT=kin,FILE='DATAE1/O2/O2_yoshino.abs',STATUS='old',iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'rdso2xs: Failed to open DATAE1/O2/O2_yoshino.abs' ) + endif + + DO i = 1, 8 + READ(kin,*,iostat=ierr) + if( ierr /= 0 ) then + call wrf_error_fatal( 'rdso2xs: Failed to read DATAE1/O2/O2_yoshino.abs' ) + endif + ENDDO + DO i = 1, 36 + n = n + 1 + READ(kin,*,iostat=ierr) x, y + if( ierr /= 0 ) then + call wrf_error_fatal( 'rdso2xs: Failed to read DATAE1/O2/O2_yoshino.abs' ) + endif + y1(n) = y*1.E-24 + x1(n) = x + END DO + CLOSE (kin) + +! Add termination points and interpolate onto the +! user grid (set in subroutine gridw): + + CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),y1(1)) + CALL addpnt(x1,y1,kdata,n,0. ,y1(1)) + CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + CALL addpnt(x1,y1,kdata,n, 1.E+38,0.) + CALL inter2(nw,wl,o2xs1, n,x1,y1, ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''rdo2xs: interp err = '',i5,'' in O2 -> O + O'')') ierr + call wrf_error_fatal( trim(emsg) ) + ENDIF + + END SUBROUTINE rdo2xs + +!=============================================================================* + + SUBROUTINE rdno2xs(nw,wl) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Read NO2 molecular absorption cross section. Re-grid data to match =* +!= specified wavelength working grid. =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= NW - INTEGER, number of specified intervals + 1 in working (I)=* +!= wavelength grid =* +!= WL - REAL, vector of lower limits of wavelength intervals in (I)=* +!= working wavelength grid =* +!= NO2XS - REAL, molecular absoprtion cross section (cm^2) of NO2 at (O)=* +!= each specified wavelength =* +!-----------------------------------------------------------------------------* + +! input: + + INTEGER, intent(in) :: nw + REAL, intent(in) :: wl(nw) + +! locals: + INTEGER, parameter :: kdata = 100 + INTEGER :: iw + INTEGER :: i, n1, n2, ierr + REAL :: dum1, dum2 + REAL :: x1(kdata), x2(kdata), y1(kdata), y2(kdata) + +! NO2 absorption cross section from JPL2006 +! with interpolation of bin midpoints + + OPEN(UNIT=kin,FILE='DATAE1/NO2/NO2_jpl2006.abs',STATUS='old') + DO i = 1, 3 + READ(kin,*) + ENDDO + n1 = 81 + DO i = 1, n1 + READ(kin,*) dum1, dum2, y1(i), y2(i) + x1(i) = 0.5 * (dum1 + dum2) + x2(i) = x1(i) + y1(i) = y1(i)*1.E-20 + y2(i) = y2(i)*1.E-20 + ENDDO + CLOSE(kin) + n2 = n1 + + CALL addpnt(x1,y1,kdata,n1,x1(1)*(1.-deltax),0.) + CALL addpnt(x1,y1,kdata,n1, 0.,0.) + CALL addpnt(x1,y1,kdata,n1,x1(n1)*(1.+deltax), 0.) + CALL addpnt(x1,y1,kdata,n1, 1.e+38, 0.) + CALL inter2(nw,wl,no2xs_a,n1,x1,y1,ierr) + + CALL addpnt(x2,y2,kdata,n2,x2(1)*(1.-deltax),0.) + CALL addpnt(x2,y2,kdata,n2, 0.,0.) + CALL addpnt(x2,y2,kdata,n2,x2(n2)*(1.+deltax), 0.) + CALL addpnt(x2,y2,kdata,n2, 1.e+38, 0.) + CALL inter2(nw,wl,no2xs_b,n2,x2,y2,ierr) + + END SUBROUTINE rdno2xs + +!=============================================================================* + + SUBROUTINE no2xs_jpl06a(nz,t,nw,wl, no2xs) + +! interpolate NO2 xs from JPL2006 + +! input: + + INTEGER, intent(in) :: nz + INTEGER, intent(in) :: nw + REAL, intent(in) :: t(nz) + REAL, intent(in) :: wl(nw) + +! output: + + REAL, intent(inout) :: no2xs(:,:) + +! local + + INTEGER :: iw + REAL :: tfac(nz) + + tfac(1:nz) = (t(1:nz) - 220.)/74. + DO iw = 1, nw-1 + no2xs(1:nz,iw) = no2xs_a(iw) + (no2xs_b(iw)-no2xs_a(iw))*tfac(1:nz) + ENDDO + + END SUBROUTINE no2xs_jpl06a + +!=============================================================================* + + SUBROUTINE rdso2xs(nw,wl,so2xs) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Read SO2 molecular absorption cross section. Re-grid data to match =* +!= specified wavelength working grid. =* +!-----------------------------------------------------------------------------* + + INTEGER, parameter :: kdata = 1000 + +! input: (altitude working grid) + INTEGER, intent(in) :: nw + REAL, intent(in) :: wl(nw) + +! output: + + REAL, intent(inout) :: so2xs(nw) + +! local: + REAL x1(kdata) + REAL y1(kdata) + REAL yg(kw) + REAL dum + INTEGER ierr + INTEGER i, l, n, idum + CHARACTER(len=40) :: fil + CHARACTER(len=256) :: emsg +!************ absorption cross sections: +! SO2 absorption cross sections from J. Quant. Spectrosc. Radiat. Transfer +! 37, 165-182, 1987, T. J. McGee and J. Burris Jr. +! Angstrom vs. cm2/molecule, value at 221 K + + fil = 'DATA/McGee87' + OPEN(UNIT=kin,FILE='DATAE1/SO2/SO2xs.all',STATUS='old') + DO i = 1,3 + read(kin,*) + ENDDO + n = 704 + DO i = 1, n + READ(kin,*) x1(i), y1(i) + x1(i) = .1*x1(i) + ENDDO + CLOSE (kin) + + CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + CALL addpnt(x1,y1,kdata,n, 0.,0.) + CALL addpnt(x1,y1,kdata,n,x1(n)*(1.+deltax),0.) + CALL addpnt(x1,y1,kdata,n, 1.e+38,0.) + CALL inter2(nw,wl,so2xs,n,x1,y1,ierr) + IF (ierr .NE. 0) THEN + WRITE(emsg,'(''rdso2xs: interp err = '',i5,'' in file '',a)') ierr, fil + call wrf_error_fatal( trim(emsg) ) + ENDIF + + END SUBROUTINE rdso2xs + + real FUNCTION refrac(w,airden) + + IMPLICIT NONE + +! input vacuum wavelength, nm and air density, molec cm-3 + + REAL, intent(in) :: w, airden + +! output refractive index for standard air +! (dry air at 15 deg. C, 101.325 kPa, 0.03% CO2) + +! internal + + REAL :: sig, sigsq, dum + +! from CRC Handbook, originally from Edlen, B., Metrologia, 2, 71, 1966. +! valid from 200 nm to 2000 nm +! beyond this range, use constant value + + IF (w < 200.) then + dum = 5.e-3 + ELSEIF (w > 2000.) then + dum = 5.e-4 + ELSE + dum = 1./w + ENDIF + sig = 1.E3*dum + sigsq = sig * sig + + dum = 8342.13 + 2406030./(130. - sigsq) + 15997./(38.9 - sigsq) + +! adjust to local air density + dum = dum * airden/(2.69e19 * 273.15/288.15) + +! index of refraction: + refrac = 1. + 1.E-8 * dum + + END function refrac + + end module module_xsections diff --git a/wrfv2_fire/chem/rtrans.F b/wrfv2_fire/chem/rtrans.F new file mode 100644 index 00000000..98fcfa59 --- /dev/null +++ b/wrfv2_fire/chem/rtrans.F @@ -0,0 +1,534 @@ +!============================================================================= +! This file contains the following subroutines, related to the solution of +! the equation of radiative transfer in multiple homogeneous layers. +! rtlink +! ps2str +! tridag +!============================================================================= + + MODULE rad_trans + + IMPLICIT NONE + + private + public :: rtlink + + CONTAINS + + SUBROUTINE rtlink( & + nstr, nlev, nlyr, nwave, & + iw, albedo, zen, & + dsdh, nid, & + dtrl, & + dto3, & + dto2, & + dtso2, & + dtno2, & + dtcld, omcld, gcld, & + dtaer, omaer, gaer, & + dtsnw, omsnw, gsnw, & +#ifdef SW_DEBUG + edir, edn, eup, fdir, fdn, fup, tuv_diags ) +#else + edir, edn, eup, fdir, fdn, fup ) +#endif + + use params_mod, only : largest, pi + +!--------------------------------------------------------------------- +! ... dummy arguments +!--------------------------------------------------------------------- + INTEGER, intent(in) :: nstr + INTEGER, intent(in) :: nlev, nlyr + INTEGER, intent(in) :: nwave, iw + REAL, intent(in) :: albedo + REAL, intent(in) :: zen + REAL, intent(in) :: dsdh(0:nlyr,nlyr) + INTEGER, intent(in) :: nid(0:nlyr) + + REAL, intent(in) :: dtrl(nlyr,nwave) + REAL, intent(in) :: dto3(nlyr,nwave), dto2(nlyr,nwave) + REAL, intent(in) :: dtso2(nlyr,nwave), dtno2(nlyr,nwave) + REAL, intent(in) :: dtcld(nlyr,nwave), omcld(nlyr,nwave), gcld(nlyr,nwave) + REAL, intent(in) :: dtaer(nlyr,nwave), omaer(nlyr,nwave), gaer(nlyr,nwave) + REAL, intent(in) :: dtsnw(nlyr,nwave), omsnw(nlyr,nwave), gsnw(nlyr,nwave) + + REAL, intent(out) :: edir(nlev), edn(nlev), eup(nlev) + REAL, intent(out) :: fdir(nlev), fdn(nlev), fup(nlev) + +#ifdef SW_DEBUG + LOGICAL, intent(in) :: tuv_diags +#endif + + +!--------------------------------------------------------------------- +! ... local variables +!--------------------------------------------------------------------- + REAL, PARAMETER :: dr = pi/180. + + INTEGER :: k, kk + REAL :: dtabs,dtsct,dscld,dsaer,dssnw,dacld,daaer,dasnw + REAL :: dt(nlyr), om(nlyr), g(nlyr) + + +!--------------------------------------------------------------------- +! ... specific to ps2str +!--------------------------------------------------------------------- + LOGICAL, parameter :: delta = .true. + REAL ediri(nlev), edni(nlev), eupi(nlev) + REAL fdiri(nlev), fdni(nlev), fupi(nlev) + +!--------------------------------------------------------------------- +! initialize: +!--------------------------------------------------------------------- + fdir(1:nlev) = 0. + fup(1:nlev) = 0. + fdn(1:nlev) = 0. + edir(1:nlev) = 0. + eup(1:nlev) = 0. + edn(1:nlev) = 0. + + DO k = 1, nlyr + dscld = dtcld(k,iw)*omcld(k,iw) + dacld = dtcld(k,iw)*(1.-omcld(k,iw)) + + dsaer = dtaer(k,iw)*omaer(k,iw) + daaer = dtaer(k,iw)*(1.-omaer(k,iw)) + + dssnw = dtsnw(k,iw)*omsnw(k,iw) + dasnw = dtsnw(k,iw)*(1.-omsnw(k,iw)) + + dtsct = dtrl(k,iw) + dscld + dsaer + dssnw + dtabs = dtso2(k,iw) + dto2(k,iw) + dto3(k,iw) & + + dtno2(k,iw) + dacld + daaer + dasnw + + dtabs = max( dtabs,1./largest ) + dtsct = max( dtsct,1./largest ) + +!--------------------------------------------------------------------- +! from bottom-up to top-down +!--------------------------------------------------------------------- + kk = nlyr - k + 1 + dt(kk) = dtsct + dtabs + g(kk) = (gcld(k,iw)*dscld + gsnw(k,iw)*dssnw + gaer(k,iw)*dsaer)/dtsct + IF( dtsct /= 1./largest ) then + om(kk) = dtsct/(dtsct + dtabs) + ELSE + om(kk) = 1./largest + ENDIF + END DO + +#ifdef SW_DEBUG + if( tuv_diags .and. iw == 100 ) then + open(unit=33,file='WRF-TUV.dbg1.out') + do k = 1,nlyr,5 + write(33,'(1p,5g15.7)') dt(k:min(k+4,nlyr)) + end do + do k = 1,nlyr,5 + write(33,'(1p,5g15.7)') g(k:min(k+4,nlyr)) + end do + do k = 1,nlyr,5 + write(33,'(1p,5g15.7)') om(k:min(k+4,nlyr)) + end do + close(33) + endif +#endif + + CALL ps2str( nlyr, nlev, zen, albedo, & + dt, om, g, & + dsdh, nid, delta, & + fdiri, fupi, fdni, ediri, eupi, edni) + +!--------------------------------------------------------------------- +! from top-down to bottom-up +!--------------------------------------------------------------------- + fdir(1:nlev) = fdiri(nlev:1:-1) + fup(1:nlev) = fupi(nlev:1:-1) + fdn(1:nlev) = fdni(nlev:1:-1) + edir(1:nlev) = ediri(nlev:1:-1) + eup(1:nlev) = eupi(nlev:1:-1) + edn(1:nlev) = edni(nlev:1:-1) + + END SUBROUTINE rtlink + + SUBROUTINE ps2str( & + nlyr, nlev, zen, rsfc, & + tauu, omu, gu, & + dsdh, nid, delta, & + fdr, fup, fdn, edr, eup, edn) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Solve two-stream equations for multiple layers. The subroutine is based =* +!= on equations from: Toon et al., J.Geophys.Res., v94 (D13), Nov 20, 1989.=* +!= It contains 9 two-stream methods to choose from. A pseudo-spherical =* +!= correction has also been added. =* +!-----------------------------------------------------------------------------* +!= PARAMETERS: =* +!= NLEVEL - INTEGER, number of specified altitude levels in the working (I)=* +!= grid =* +!= ZEN - REAL, solar zenith angle (degrees) (I)=* +!= RSFC - REAL, surface albedo at current wavelength (I)=* +!= TAUU - REAL, unscaled optical depth of each layer (I)=* +!= OMU - REAL, unscaled single scattering albedo of each layer (I)=* +!= GU - REAL, unscaled asymmetry parameter of each layer (I)=* +!= DSDH - REAL, slant path of direct beam through each layer crossed (I)=* +!= when travelling from the top of the atmosphere to layer i; =* +!= DSDH(i,j), i = 0..NZ-1, j = 1..NZ-1 =* +!= NID - INTEGER, number of layers crossed by the direct beam when (I)=* +!= travelling from the top of the atmosphere to layer i; =* +!= NID(i), i = 0..NZ-1 =* +!= DELTA - LOGICAL, switch to use delta-scaling (I)=* +!= .TRUE. -> apply delta-scaling =* +!= .FALSE.-> do not apply delta-scaling =* +!= FDR - REAL, contribution of the direct component to the total (O)=* +!= actinic flux at each altitude level =* +!= FUP - REAL, contribution of the diffuse upwelling component to (O)=* +!= the total actinic flux at each altitude level =* +!= FDN - REAL, contribution of the diffuse downwelling component to (O)=* +!= the total actinic flux at each altitude level =* +!= EDR - REAL, contribution of the direct component to the total (O)=* +!= spectral irradiance at each altitude level =* +!= EUP - REAL, contribution of the diffuse upwelling component to (O)=* +!= the total spectral irradiance at each altitude level =* +!= EDN - REAL, contribution of the diffuse downwelling component to (O)=* +!= the total spectral irradiance at each altitude level =* +!-----------------------------------------------------------------------------* + + use params_mod, only : pi, precis, largest + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + INTEGER, intent(in) :: nlyr, nlev + REAL, intent(in) :: zen, rsfc + REAL, intent(in) :: tauu(nlyr), omu(nlyr), gu(nlyr) + REAL, intent(in) :: dsdh(0:nlyr,nlyr) + INTEGER, intent(in) :: nid(0:nlyr) + LOGICAL, intent(in) :: delta + + REAL, intent(out) :: fup(nlev), fdn(nlev), fdr(nlev) + REAL, intent(out) :: eup(nlev), edn(nlev), edr(nlev) + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + REAL, PARAMETER :: eps = 1.E-3 +!----------------------------------------------------------------------------- +! initial conditions: pi*solar flux = 1; diffuse incidence = 0 +!----------------------------------------------------------------------------- + REAL, PARAMETER :: pifs = 1. + REAL, PARAMETER :: fdn0 = 0. + + REAL :: mu, sum + REAL :: tausla(0:nlyr) + REAL :: tauc(0:nlyr) + REAL :: mu2(0:nlyr) + +!----------------------------------------------------------------------------- +! internal coefficients and matrix +!----------------------------------------------------------------------------- + INTEGER :: row, nlyrm1 + REAL :: lam(nlyr), taun(nlyr), bgam(nlyr) + REAL :: e1(nlyr), e2(nlyr), e3(nlyr), e4(nlyr) + REAL :: cup(nlyr), cdn(nlyr), cuptn(nlyr), cdntn(nlyr) + REAL :: mu1(nlyr) + REAL :: a(2*nlyr), b(2*nlyr), d(2*nlyr), e(2*nlyr), y(2*nlyr) + + REAL :: f, g, om, tmpg + REAL :: gam1, gam2, gam3, gam4 + REAL :: gi(nlyr), omi(nlyr) + +!----------------------------------------------------------------------------- +! For calculations of Associated Legendre Polynomials for GAMA1,2,3,4 +! in delta-function, modified quadrature, hemispheric constant, +! Hybrid modified Eddington-delta function metods, p633,Table1. +! W.E.Meador and W.R.Weaver, GAS,1980,v37,p.630 +! W.J.Wiscombe and G.W. Grams, GAS,1976,v33,p2440, +! uncomment the following two lines and the appropriate statements further +! down. +!----------------------------------------------------------------------------- + INTEGER :: mrows, mrowsm1, mrowsm2 + REAL :: expon, expon0, expon1, divisr, tmp, up, dn + REAL :: ssfc + REAL :: wrk, wrk1 + + INTEGER :: i, im1, j, k + +!----------------------------------------------------------------------------- +! MU = cosine of solar zenith angle +! RSFC = surface albedo +! TAUU = unscaled optical depth of each layer +! OMU = unscaled single scattering albedo +! GU = unscaled asymmetry factor +! KLEV = max dimension of number of layers in atmosphere +! NLYR = number of layers in the atmosphere +! NLEVEL = nlyr + 1 = number of levels +!----------------------------------------------------------------------------- + + mu = COS( zen*pi/180. ) +!----------------------------------------------------------------------------- +!************* compute coefficients for each layer: +! GAM1 - GAM4 = 2-stream coefficients, different for different approximations +! EXPON0 = calculation of e when TAU is zero +! EXPON1 = calculation of e when TAU is TAUN +! CUP and CDN = calculation when TAU is zero +! CUPTN and CDNTN = calc. when TAU is TAUN +! DIVISR = prevents division by zero +!----------------------------------------------------------------------------- + tauc(0:nlyr) = 0. + tausla(0:nlyr) = 0. + mu2(0:nlyr) = 1./SQRT(largest) + + IF( .NOT. delta ) THEN + gi(1:nlyr) = gu(1:nlyr) + omi(1:nlyr) = omu(1:nlyr) + taun(1:nlyr) = tauu(1:nlyr) + ELSE +!----------------------------------------------------------------------------- +! delta-scaling. Have to be done for delta-Eddington approximation, +! delta discrete ordinate, Practical Improved Flux Method, delta function, +! and Hybrid modified Eddington-delta function methods approximations +!----------------------------------------------------------------------------- + DO k = 1, nlyr + f = gu(k)*gu(k) + wrk = 1. - f + wrk1 = 1. - omu(k)*f + gi(k) = (gu(k) - f)/wrk + omi(k) = wrk*omu(k)/wrk1 + taun(k) = wrk1*tauu(k) + ENDDO + END IF + +!----------------------------------------------------------------------------- +! calculate slant optical depth at the top of the atmosphere when zen>90. +! in this case, higher altitude of the top layer is recommended which can +! be easily changed in gridz.f. +!----------------------------------------------------------------------------- + IF( zen > 90.0 ) THEN + IF(nid(0) < 0) THEN + tausla(0) = largest + ELSE + sum = 0.0 + DO j = 1, nid(0) + sum = sum + 2.*taun(j)*dsdh(0,j) + END DO + tausla(0) = sum + END IF + END IF + +layer_loop : & + DO i = 1, nlyr + im1 = i - 1 + g = gi(i) + om = omi(i) + tauc(i) = tauc(im1) + taun(i) + +!----------------------------------------------------------------------------- +! stay away from 1 by precision. For g, also stay away from -1 +!----------------------------------------------------------------------------- + tmpg = MIN( abs(g),1. - precis ) + g = SIGN( tmpg,g ) + om = MIN( om,1. - precis ) + +!----------------------------------------------------------------------------- +! calculate slant optical depth +!----------------------------------------------------------------------------- + IF(nid(i) < 0) THEN + tausla(i) = largest + ELSE + sum = 0.0 + DO j = 1, MIN(nid(i),i) + sum = sum + taun(j)*dsdh(i,j) + ENDDO + DO j = MIN(nid(i),i)+1,nid(i) + sum = sum + 2.*taun(j)*dsdh(i,j) + ENDDO + tausla(i) = sum + IF(tausla(i) == tausla(im1)) THEN + mu2(i) = SQRT(largest) + ELSE + mu2(i) = (tauc(i) - tauc(im1))/(tausla(i) - tausla(im1)) + mu2(i) = SIGN( MAX( ABS(mu2(i)),1./SQRT(largest) ), mu2(i) ) + END IF + END IF + +!----------------------------------------------------------------------------- +!** the following gamma equations are from pg 16,289, Table 1 +!** save mu1 for each approx. for use in converting irradiance to actinic flux +! Eddington approximation(Joseph et al., 1976, JAS, 33, 2452): +!----------------------------------------------------------------------------- + gam1 = .25*(7. - om*(4. + 3.*g)) + gam2 = -.25*(1. - om*(4. - 3.*g)) + gam3 = .25*(2. - 3.*g*mu) + gam4 = 1. - gam3 + mu1(i) = 0.5 + +!----------------------------------------------------------------------------- +! lambda = pg 16,290 equation 21 +! big gamma = pg 16,290 equation 22 +! checked limit for gam2/gam1 <<1: bgam -> (1/2)*gma2/gam1 +! so if if gam2 = 0., then bgam = 0. +!----------------------------------------------------------------------------- + lam(i) = sqrt(gam1*gam1 - gam2*gam2) + + IF( gam2 /= 0.) THEN + bgam(i) = (gam1 - lam(i))/gam2 + ELSE + bgam(i) = 0. + ENDIF + + expon = EXP( -lam(i)*taun(i) ) + +!----------------------------------------------------------------------------- +! e1 - e4 = pg 16,292 equation 44 +!----------------------------------------------------------------------------- + e1(i) = 1. + bgam(i)*expon + e2(i) = 1. - bgam(i)*expon + e3(i) = bgam(i) + expon + e4(i) = bgam(i) - expon + +!----------------------------------------------------------------------------- +! the following sets up for the C equations 23, and 24 +! found on page 16,290 +! prevent division by zero (if LAMBDA=1/MU, shift 1/MU^2 by EPS = 1.E-3 +! which is approx equiv to shifting MU by 0.5*EPS* (MU)**3 +!----------------------------------------------------------------------------- + expon0 = EXP( -tausla(im1) ) + expon1 = EXP( -tausla(i) ) + + divisr = lam(i)*lam(i) - 1./(mu2(i)*mu2(i)) + tmp = MAX( eps,abs(divisr) ) + divisr = SIGN( tmp,divisr ) + + up = om*pifs*((gam1 - 1./mu2(i))*gam3 + gam4*gam2)/divisr + dn = om*pifs*((gam1 + 1./mu2(i))*gam4 + gam2*gam3)/divisr + +!----------------------------------------------------------------------------- +! cup and cdn are when tau is equal to zero +! cuptn and cdntn are when tau is equal to taun +!----------------------------------------------------------------------------- + cup(i) = up*expon0 + cdn(i) = dn*expon0 + cuptn(i) = up*expon1 + cdntn(i) = dn*expon1 + end do layer_loop + +!----------------------------------------------------------------------------- +!**************** set up matrix ****** +! ssfc = pg 16,292 equation 37 where pi Fs is one (unity). +!----------------------------------------------------------------------------- + ssfc = rsfc*mu*EXP( -tausla(nlyr) )*pifs + +!----------------------------------------------------------------------------- +! MROWS = the number of rows in the matrix +!----------------------------------------------------------------------------- + mrows = 2*nlyr + mrowsm1 = mrows - 1 + mrowsm2 = mrows - 2 + nlyrm1 = nlyr - 1 + +!----------------------------------------------------------------------------- +! the following are from pg 16,292 equations 39 - 43. +! set up first row of matrix: +!----------------------------------------------------------------------------- + a(1) = 0. + b(1) = e1(1) + d(1) = -e2(1) + e(1) = fdn0 - cdn(1) + +!----------------------------------------------------------------------------- +! set up odd rows 3 thru (MROWS - 1): +!----------------------------------------------------------------------------- + a(3:mrowsm1:2) = e2(1:nlyrm1)*e3(1:nlyrm1) - e4(1:nlyrm1)*e1(1:nlyrm1) + b(3:mrowsm1:2) = e1(1:nlyrm1)*e1(2:nlyr) - e3(1:nlyrm1)*e3(2:nlyr) + d(3:mrowsm1:2) = e3(1:nlyrm1)*e4(2:nlyr) - e1(1:nlyrm1)*e2(2:nlyr) + e(3:mrowsm1:2) = e3(1:nlyrm1)*(cup(2:nlyr) - cuptn(1:nlyrm1)) & + + e1(1:nlyrm1)*(cdntn(1:nlyrm1) - cdn(2:nlyr)) + +!----------------------------------------------------------------------------- +! set up even rows 2 thru (MROWS - 2): +!----------------------------------------------------------------------------- + a(2:mrowsm2:2) = e2(2:nlyr)*e1(1:nlyrm1) - e3(1:nlyrm1)*e4(2:nlyr) + b(2:mrowsm2:2) = e2(1:nlyrm1)*e2(2:nlyr) - e4(1:nlyrm1)*e4(2:nlyr) + d(2:mrowsm2:2) = e1(2:nlyr)*e4(2:nlyr) - e2(2:nlyr)*e3(2:nlyr) + e(2:mrowsm2:2) = (cup(2:nlyr) - cuptn(1:nlyrm1))*e2(2:nlyr) & + - (cdn(2:nlyr) - cdntn(1:nlyrm1))*e4(2:nlyr) + +!----------------------------------------------------------------------------- +! set up last row of matrix at MROWS: +!----------------------------------------------------------------------------- + a(mrows) = e1(nlyr) - rsfc*e3(nlyr) + b(mrows) = e2(nlyr) - rsfc*e4(nlyr) + d(mrows) = 0. + e(mrows) = ssfc - cuptn(nlyr) + rsfc*cdntn(nlyr) + +!----------------------------------------------------------------------------- +! solve tri-diagonal matrix: +!----------------------------------------------------------------------------- + CALL tridag( a, b, d, e, y, mrows ) + +!----------------------------------------------------------------------------- +!*** unfold solution of matrix, compute output fluxes: +!----------------------------------------------------------------------------- +! the following equations are from pg 16,291 equations 31 & 32 +!----------------------------------------------------------------------------- + fdr(1) = EXP( -tausla(0) ) + edr(1) = mu * fdr(1) + edn(1) = fdn0 + eup(1) = y(1)*e3(1) - y(2)*e4(1) + cup(1) + fdn(1) = edn(1)/mu1(1) + fup(1) = eup(1)/mu1(1) + + fdr(2:nlev) = EXP( -tausla(1:nlyr) ) + edr(2:nlev) = mu *fdr(2:nlev) + edn(2:nlev) = y(1:mrowsm1:2)*e3(1:nlyr) + y(2:mrows:2)*e4(1:nlyr) + cdntn(1:nlyr) + eup(2:nlev) = y(1:mrowsm1:2)*e1(1:nlyr) + y(2:mrows:2)*e2(1:nlyr) + cuptn(1:nlyr) + fdn(2:nlev) = edn(2:nlev)/mu1(1:nlyr) + fup(2:nlev) = eup(2:nlev)/mu1(1:nlyr) + + END SUBROUTINE ps2str + + SUBROUTINE tridag( a, b, c, r, u, n) +!----------------------------------------------------------------------------- +! solve tridiagonal system. From Numerical Recipies, p. 40 +!----------------------------------------------------------------------------- + +!----------------------------------------------------------------------------- +! ... dummy arguments +!----------------------------------------------------------------------------- + INTEGER, intent(in) :: n + REAL, intent(in) :: a(n), b(n), c(n), r(n) + REAL, intent(out) :: u(n) + +!----------------------------------------------------------------------------- +! ... local variables +!----------------------------------------------------------------------------- + INTEGER :: j, jm1, jp1 + REAL :: bet + REAL :: gam(n) + CHARACTER(len=64) :: err_msg + + IF (b(1) == 0.) then + call wrf_error_fatal( 'tridag: zero pivot @ n == 1' ) + ENDIF + bet = b(1) + u(1) = r(1)/bet + DO j = 2, n + jm1 = j - 1 + gam(j) = c(jm1)/bet + bet = b(j) - a(j)*gam(j) + IF (bet == 0.) then + write(err_msg,'(''tridag: zero pivot @ n = '',i4)') j + call wrf_error_fatal( trim(err_msg) ) + ENDIF + u(j) = (r(j) - a(j)*u(jm1))/bet + END DO + + DO j = n - 1, 1, -1 + jp1 = j + 1 + u(j) = u(j) - gam(jp1)*u(jp1) + END DO + + END SUBROUTINE tridag + + END MODULE rad_trans diff --git a/wrfv2_fire/chem/rxn.F b/wrfv2_fire/chem/rxn.F new file mode 100644 index 00000000..604a0af2 --- /dev/null +++ b/wrfv2_fire/chem/rxn.F @@ -0,0 +1,5660 @@ +!=============================================================================* +! This file contains the following subroutines, related to reading/loading +! the product (cross section) x (quantum yield) for photo-reactions: +! r01 through r47 +! r101 through r148, skipped r116,r117, added pxCH2O +!=============================================================================* + + module module_rxn + + use module_params + + IMPLICIT NONE + + private :: fo3qy2, qyacet + + logical, private :: initialize = .true. + integer, parameter :: max_files = 5 + + integer :: npht, npht_tab + + type file_specs + integer :: nfiles + integer :: nskip(max_files) + integer :: nread(max_files) + real :: xfac(max_files) + character(len=132) :: filename(max_files) + end type file_specs + + type xs_qy_tab + integer :: tpflag + integer :: channel + integer :: jndx + real :: qyld + real, allocatable :: sq(:,:) + character(len=50) :: label + character(len=50) :: wrf_label + type(xs_qy_tab), pointer :: next + type(xs_qy_tab), pointer :: last + type(file_specs) :: filespec + end type xs_qy_tab + + type(xs_qy_tab), allocatable, target :: xsqy_tab(:) + type(xs_qy_tab), pointer :: xsqy_tab_head + type(xs_qy_tab), pointer :: xsqy_tab_tail + +!===================================================================== +! the following is fortran2003 compliant code +!===================================================================== + type xsqy_subs + procedure(xsqy), nopass, pointer :: xsqy_sub + end type xsqy_subs + + abstract interface + SUBROUTINE xsqy(nw,wl,wc,nz,tlev,airden,j) + + use module_params + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + + INTEGER, intent(inout) :: j + end SUBROUTINE xsqy + end interface + + type(xsqy_subs), allocatable :: the_subs(:) + + CONTAINS + + SUBROUTINE no_z_dep(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +! generic routine +!-----------------------------------------------------------------------------* + + use module_params + +! input + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: airden(kz) + REAL, intent(in) :: tlev(kz) + + integer, PARAMETER :: kdata=500 + +! local + REAL :: x1(kdata) + REAL :: y1(kdata) + + INTEGER :: wn + REAL :: yg(kw) + + if( initialize ) then + CALL readit + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + if( xsqy_tab(j)%qyld == 1. ) then +!*** quantum yield assumed to be unity + xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) + else + xsqy_tab(j)%sq(1:nw-1,1) = xsqy_tab(j)%qyld * yg(1:nw-1) + endif + endif + + CONTAINS + + SUBROUTINE readit + + INTEGER :: ierr + integer :: n, fileno + character(len=132) :: filename + + do fileno = 1,xsqy_tab(j)%filespec%nfiles + filename = trim( xsqy_tab(j)%filespec%filename(fileno) ) + n = xsqy_tab(j)%filespec%nread(fileno) + if( xsqy_tab(j)%filespec%nskip(fileno) >= 0 ) then + CALL base_read( filespec=trim(filename), & + skip_cnt=xsqy_tab(j)%filespec%nskip(fileno), & + rd_cnt =n,x=x1,y=y1 ) + else + CALL base_read( filespec=trim(filename),rd_cnt=n,x=x1,y=y1 ) + endif + y1(1:n) = y1(1:n) * xsqy_tab(j)%filespec%xfac(fileno) + + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + enddo + + END SUBROUTINE readit + + END SUBROUTINE no_z_dep + + LOGICAL FUNCTION get_initialization() + + get_initialization = initialize + + END FUNCTION get_initialization + + SUBROUTINE set_initialization( status ) + + LOGICAL, intent(in) :: status + + initialize = status + + END SUBROUTINE set_initialization + + SUBROUTINE rxn_init( nw, wl ) +!--------------------------------------------- +! initialize wrf-tuv +!--------------------------------------------- + + use module_xsections, only : rdxs_init + + integer, intent(in) :: nw + real, intent(in) :: wl(nw) + + integer :: astat, m, n + character(len=256) :: emsg + + call set_initialization( status=.true. ) + + if( .not. allocated( xsqy_tab ) ) then + allocate( xsqy_tab(kj),stat=astat ) + if( astat /= 0 ) then + write(emsg,'(''rxn_init: failed to allocate xsqy_tab; error = '',i4)') astat + call wrf_error_fatal( trim(emsg) ) + endif + endif + if( .not. allocated( the_subs ) ) then + allocate( the_subs(kj),stat=astat ) + if( astat /= 0 ) then + write(emsg,'(''rxn_init: failed to allocate xsqy_tab subs; error = '',i4)') astat + call wrf_error_fatal( trim(emsg) ) + endif + endif + + nullify( xsqy_tab_head ) + nullify( xsqy_tab_tail ) + + xsqy_tab(1:kj)%tpflag = 0 + xsqy_tab(1:kj)%channel = 1 + xsqy_tab(1:kj)%label = ' ' + xsqy_tab(1:kj)%qyld = 1. + xsqy_tab(1:kj)%filespec%nfiles = 1 + do m = 1,max_files + xsqy_tab(1:kj)%filespec%nskip(m) = 0 + xsqy_tab(1:kj)%filespec%nread(m) = 0 + xsqy_tab(1:kj)%filespec%xfac(m) = 1.e-20 + xsqy_tab(1:kj)%filespec%filename(m) = ' ' + end do + do m = 1,kj + nullify( xsqy_tab(m)%next ) + nullify( xsqy_tab(m)%last ) + the_subs(m)%xsqy_sub => null() + end do + + npht_tab = 2 + call setup_sub_calls( the_subs,npht_tab ) + + call diagnostics + + call rdxs_init( nw, wl ) + + END SUBROUTINE rxn_init + + subroutine setup_sub_calls( subr, m ) + + integer, intent(inout) :: m + type(xsqy_subs), intent(inout) :: subr(:) + + xsqy_tab(m)%label = 'O3 -> O2 + O(1D)' + xsqy_tab(m+1)%label = 'O3 -> O2 + O(3P)' + xsqy_tab(m)%wrf_label = 'j_o1d' + xsqy_tab(m+1)%wrf_label = 'j_o3p' + xsqy_tab(m:m+1)%jndx = (/ m,m+1 /) + xsqy_tab(m+1)%channel = 2 + xsqy_tab(m:m+1)%tpflag = 1 + subr(m)%xsqy_sub => r01 + subr(m+1)%xsqy_sub => r01 + m = m + 2 + + xsqy_tab(m)%label = 'NO2 -> NO + O(3P)' + xsqy_tab(m)%wrf_label = 'j_no2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/YLD/NO2_jpl11.yld' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 25 + subr(m)%xsqy_sub => r02 + m = m + 1 + + xsqy_tab(m)%label = 'NO3 -> NO + O2' + xsqy_tab(m+1)%label = 'NO3 -> NO2 + O(3P)' + xsqy_tab(m)%wrf_label = 'j_no3_a' + xsqy_tab(m+1)%wrf_label = 'j_no3_b' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1)%channel = 2 + xsqy_tab(m:m+1)%tpflag = 1 + xsqy_tab(m)%filespec%nfiles = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/NO3_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 6 + xsqy_tab(m)%filespec%nread(1) = 289 + xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/YLD/NO3_jpl2011.qy' + xsqy_tab(m)%filespec%nskip(2) = 5 + xsqy_tab(m)%filespec%nread(2) = 56 + xsqy_tab(m)%filespec%xfac(2) = 1.e-3 + subr(m)%xsqy_sub => r03 + subr(m+1)%xsqy_sub => r03 + m = m + 2 + + xsqy_tab(m)%label = 'N2O5 -> NO3 + NO + O(3P)' + xsqy_tab(m+1)%label = 'N2O5 -> NO3 + NO2' + xsqy_tab(m)%wrf_label = 'j_n2o5_a' + xsqy_tab(m+1)%wrf_label = 'j_n2o5_b' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1)%channel = 2 + xsqy_tab(m:m+1)%tpflag = 1 + xsqy_tab(m)%filespec%nfiles = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/N2O5_jpl11.abs' + xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/ABS/N2O5_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1:2) = (/ 4,111 /) + xsqy_tab(m)%filespec%nread(1:2) = (/ 103,8 /) + subr(m)%xsqy_sub => r04 + subr(m+1)%xsqy_sub => r04 + m = m + 2 + + xsqy_tab(m)%label = 'HNO2 -> OH + NO' + xsqy_tab(m)%wrf_label = 'j_hno2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HONO_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 3 + xsqy_tab(m)%filespec%nread(1) = 192 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'HNO3 -> OH + NO2' + xsqy_tab(m)%wrf_label = 'j_hno3' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HNO3_burk.abs' + xsqy_tab(m)%filespec%nskip(1) = 6 + xsqy_tab(m)%filespec%nread(1) = 83 + subr(m)%xsqy_sub => r06 + m = m + 1 + + xsqy_tab(m)%label = 'HNO4 -> HO2 + NO2' + xsqy_tab(m)%wrf_label = 'j_hno4' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HNO4_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 54 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'H2O2 -> 2 OH' + xsqy_tab(m)%wrf_label = 'j_h2o2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%nfiles = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/H2O2_jpl94.abs' + xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/ABS/H2O2_Kahan.abs' + xsqy_tab(m)%filespec%nskip(1:2) = (/ -1,0 /) + xsqy_tab(m)%filespec%nread(2) = 494 + subr(m)%xsqy_sub => r08 + m = m + 1 + + xsqy_tab(m)%label = 'CHBr3 -> Products' + xsqy_tab(m)%wrf_label = 'j_chbr3' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CHBr3.jpl97' + xsqy_tab(m)%filespec%nskip(1) = 6 + xsqy_tab(m)%filespec%nread(1) = 87 + subr(m)%xsqy_sub => r09 + m = m + 1 + + xsqy_tab(m)%label = 'CH3CHO -> CH3 + HCO' + xsqy_tab(m+1)%label = 'CH3CHO -> CH4 + CO' + xsqy_tab(m+2)%label = 'CH3CHO -> CH3CO + H' + xsqy_tab(m)%wrf_label = 'j_ch3cho_a' + xsqy_tab(m+1)%wrf_label = 'j_ch3cho_b' + xsqy_tab(m+2)%wrf_label = 'j_ch3cho_c' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1:m+2)%channel = (/ 2,3 /) + xsqy_tab(m:m+2)%tpflag = (/ 2,0,0 /) + xsqy_tab(m)%filespec%nfiles = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3CHO/CH3CHO_jpl11.abs' + xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/CH3CHO/CH3CHO_uip.yld' + xsqy_tab(m)%filespec%nskip(1:2) = (/ 2,4 /) + xsqy_tab(m)%filespec%nread(1:2) = (/ 101,12 /) + subr(m)%xsqy_sub => r11 + subr(m+1)%xsqy_sub => r11 + subr(m+2)%xsqy_sub => r11 + m = m + 3 + + xsqy_tab(m)%label = 'C2H5CHO -> C2H5 + HCO' + xsqy_tab(m)%wrf_label = 'j_c2h5cho' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 2 + xsqy_tab(m)%filespec%nfiles = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/C2H5CHO/C2H5CHO_iup.abs' + xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/C2H5CHO/C2H5CHO_iup.yld' + xsqy_tab(m)%filespec%nskip(1:2) = 4 + xsqy_tab(m)%filespec%nread(1:2) = (/ 106,5 /) + subr(m)%xsqy_sub => r12 + m = m + 1 + + xsqy_tab(m)%label = 'CHOCHO -> HCO + HCO' + xsqy_tab(m+1)%label = 'CHOCHO -> H2 + 2CO' + xsqy_tab(m+2)%label = 'CHOCHO -> CH2O + CO' + xsqy_tab(m)%wrf_label = 'j_gly_a' + xsqy_tab(m+1)%wrf_label = 'j_gly_b' + xsqy_tab(m+2)%wrf_label = 'j_gly_c' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1:m+2)%channel = (/ 2,3 /) + xsqy_tab(m)%filespec%nfiles = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CHOCHO/glyoxal_jpl11.abs' + xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/CHOCHO/glyoxal_jpl11.qy' + xsqy_tab(m)%filespec%nskip(1:2) = (/ 2,3 /) + xsqy_tab(m)%filespec%nread(1:2) = (/ 277,40 /) + subr(m)%xsqy_sub => r13 + subr(m+1)%xsqy_sub => r13 + subr(m+2)%xsqy_sub => r13 + m = m + 3 + + xsqy_tab(m)%label = 'CH3COCHO -> CH3CO + HCO' + xsqy_tab(m)%wrf_label = 'j_mgly' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3COCHO/CH3COCHO_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 294 + subr(m)%xsqy_sub => r14 + m = m + 1 + + xsqy_tab(m)%label = 'CH3COCH3 -> CH3CO + CH3' + xsqy_tab(m)%wrf_label = 'j_ch3coch3' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 3 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3COCH3/CH3COCH3_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 5 + xsqy_tab(m)%filespec%nread(1) = 135 + subr(m)%xsqy_sub => r15 + m = m + 1 + + xsqy_tab(m)%label = 'CH3OOH -> CH3O + OH' + xsqy_tab(m)%wrf_label = 'j_ch3ooh' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3OOH/CH3OOH_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 40 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CH3ONO2 -> CH3O + NO2' + xsqy_tab(m)%wrf_label = 'j_ch3ono2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/CH3ONO2_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 65 + subr(m)%xsqy_sub => r17 + m = m + 1 + + xsqy_tab(m)%label = 'CH3CO(OONO2) -> CH3CO(OO) + NO2' + xsqy_tab(m+1)%label = 'CH3CO(OONO2) -> CH3CO(O) + NO3' + xsqy_tab(m)%wrf_label = 'j_pan_a' + xsqy_tab(m+1)%wrf_label = 'j_pan_b' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1)%channel = 2 + xsqy_tab(m:m+1)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/PAN_talukdar.abs' + xsqy_tab(m)%filespec%nskip(1) = 14 + xsqy_tab(m)%filespec%nread(1) = 78 + subr(m)%xsqy_sub => r18 + subr(m+1)%xsqy_sub => r18 + m = m + 2 + + xsqy_tab(m)%label = 'CCl2O -> Products' + xsqy_tab(m)%wrf_label = 'j_ccl2o' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CCl2O_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CCl4 -> Products' + xsqy_tab(m)%wrf_label = 'j_ccl4' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CCl4_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 5 + xsqy_tab(m)%filespec%nread(1) = 44 + subr(m)%xsqy_sub => r20 + m = m + 1 + + xsqy_tab(m)%label = 'CClFO -> Products' + xsqy_tab(m)%wrf_label = 'j_cclfo' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CClFO_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CF2O -> Products' + xsqy_tab(m)%wrf_label = 'j_cf2o' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CF2O_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 5 + xsqy_tab(m)%filespec%nread(1) = 21 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CF2ClCFCl2 (CFC-113) -> Products' + xsqy_tab(m)%wrf_label = 'j_cf2clcfcl2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CFC-113_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => r23 + m = m + 1 + + xsqy_tab(m)%label = 'CF2ClCF2Cl (CFC-114) -> Products' + xsqy_tab(m)%wrf_label = 'j_cf2clcf2cl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CFC-114_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => r24 + m = m + 1 + + xsqy_tab(m)%label = 'CF3CF2Cl (CFC-115) -> Products' + xsqy_tab(m)%wrf_label = 'j_cf3cf2cl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CFC-115_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CCl3F (CFC-11) -> Products' + xsqy_tab(m)%wrf_label = 'j_ccl3f' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CFC-11_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => r26 + m = m + 1 + + xsqy_tab(m)%label = 'CCl2F2 (CFC-12) -> Products' + xsqy_tab(m)%wrf_label = 'j_ccl2f2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CFC-12_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => r27 + m = m + 1 + + xsqy_tab(m)%label = 'CH3Br -> Products' + xsqy_tab(m)%wrf_label = 'j_ch3br' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3Br_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CH3CCl3 -> Products' + xsqy_tab(m)%wrf_label = 'j_ch3ccl3' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3CCl3_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => r29 + m = m + 1 + + xsqy_tab(m)%label = 'CH3Cl -> Products' + xsqy_tab(m)%wrf_label = 'j_ch3cl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3Cl_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => r30 + m = m + 1 + + xsqy_tab(m)%label = 'ClOO -> Products' + xsqy_tab(m)%wrf_label = 'j_cloo' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClOO_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CF3CHCl2 (HCFC-123) -> Products' + xsqy_tab(m)%wrf_label = 'j_cf3chcl2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + subr(m)%xsqy_sub => r32 + m = m + 1 + + xsqy_tab(m)%label = 'CF3CHFCl (HCFC-124) -> Products' + xsqy_tab(m)%wrf_label = 'j_cf3chfcl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + subr(m)%xsqy_sub => r33 + m = m + 1 + + xsqy_tab(m)%label = 'CH3CFCl2 (HCFC-141b) -> Products' + xsqy_tab(m)%wrf_label = 'j_ch3cfcl2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HCFC-141b_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CH3CF2Cl (HCFC-142b) -> Products' + xsqy_tab(m)%wrf_label = 'j_ch3cf2cl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + subr(m)%xsqy_sub => r35 + m = m + 1 + + xsqy_tab(m)%label = 'CF3CF2CHCl2 (HCFC-225ca) -> Products' + xsqy_tab(m)%wrf_label = 'j_cf3cf2chcl2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HCFC-225ca_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CF2ClCF2CHFCl (HCFC-225cb) -> Products' + xsqy_tab(m)%wrf_label = 'j_cf2clcf2chfcl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HCFC-225cb_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CHClF2 (HCFC-22) -> Products' + xsqy_tab(m)%wrf_label = 'j_chclf2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HCFC-22_jpl94.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => r38 + m = m + 1 + + xsqy_tab(m)%label = 'HO2 -> OH + O' + xsqy_tab(m)%wrf_label = 'j_ho2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HO2_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 10 + xsqy_tab(m)%filespec%nread(1) = 15 + subr(m)%xsqy_sub => r39 + m = m + 1 + + xsqy_tab(m)%label = 'CF2Br2 (Halon-1202) -> Products' + xsqy_tab(m)%wrf_label = 'j_cf2bf2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Halon-1202_jpl97.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CF2BrCl (Halon-1211) -> Products' + xsqy_tab(m)%wrf_label = 'j_cf2brcl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Halon-1211_jpl97.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CF3Br (Halon-1301) -> Products' + xsqy_tab(m)%wrf_label = 'j_cf3br' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Halon-1301_jpl97.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CF2BrCF2Br (Halon-2402) -> Products' + xsqy_tab(m)%wrf_label = 'j_cf2brcf2br' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Halon-2402_jpl97.abs' + xsqy_tab(m)%filespec%nskip(1) = -1 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'N2O -> N2 + O(1D)' + xsqy_tab(m)%wrf_label = 'j_n2o' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + subr(m)%xsqy_sub => r44 + m = m + 1 + + xsqy_tab(m)%label = 'ClONO2 -> Cl + NO3' + xsqy_tab(m+1)%label = 'ClONO2 -> ClO + NO2' + xsqy_tab(m)%wrf_label = 'j_clono2_a' + xsqy_tab(m+1)%wrf_label = 'j_clono2_b' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1)%channel = 2 + xsqy_tab(m:m+1)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClONO2_jpl97.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 119 + subr(m)%xsqy_sub => r45 + subr(m+1)%xsqy_sub => r45 + m = m + 2 + + xsqy_tab(m)%label = 'BrONO2 -> BrO + NO2' + xsqy_tab(m+1)%label = 'BrONO2 -> Br + NO3' + xsqy_tab(m)%wrf_label = 'j_brono2_a' + xsqy_tab(m+1)%wrf_label = 'j_brono2_b' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1)%channel = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrONO2_jpl03.abs' + xsqy_tab(m)%filespec%nskip(1) = 13 + xsqy_tab(m)%filespec%nread(1) = 61 + subr(m)%xsqy_sub => r46 + subr(m+1)%xsqy_sub => r46 + m = m + 2 + + xsqy_tab(m)%label = 'Cl2 -> Cl + Cl' + xsqy_tab(m)%wrf_label = 'j_cl2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + subr(m)%xsqy_sub => r47 + m = m + 1 + + xsqy_tab(m)%label = 'HOCH2CHO -> CH2OH + HCO' + xsqy_tab(m+1)%label = 'HOCH2CHO -> CH3OH + CO' + xsqy_tab(m+2)%label = 'HOCH2CHO -> CH2CHO + OH' + xsqy_tab(m)%wrf_label = 'j_glyald_a' + xsqy_tab(m+1)%wrf_label = 'j_glyald_b' + xsqy_tab(m+2)%wrf_label = 'j_glyald_c' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1:m+2)%channel = (/ 2,3 /) + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH2OHCHO/glycolaldehyde_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 63 + subr(m)%xsqy_sub => r101 + subr(m+1)%xsqy_sub => r101 + subr(m+2)%xsqy_sub => r101 + m = m + 3 + + xsqy_tab(m)%label = 'CH3COCOCH3 -> Products' + xsqy_tab(m)%wrf_label = 'j_biacetyl' + xsqy_tab(m)%qyld = .158 + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3COCOCH3/biacetyl_horowitz.abs' + xsqy_tab(m)%filespec%nskip(1) = 8 + xsqy_tab(m)%filespec%nread(1) = 287 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CH3COCH=CH2 -> Products' + xsqy_tab(m)%wrf_label = 'j_mvk' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/MVK_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 146 + subr(m)%xsqy_sub => r103 + m = m + 1 + + xsqy_tab(m)%label = 'CH2=C(CH3)CHO -> Products' + xsqy_tab(m)%wrf_label = 'j_macr' + xsqy_tab(m)%qyld = .01 + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Methacrolein_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 7 + xsqy_tab(m)%filespec%nread(1) = 146 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CH3COCO(OH) -> Products' + xsqy_tab(m)%wrf_label = 'j_ch3cocooh' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH3COCOOH/pyruvic_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 139 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CH3CH2ONO2 -> CH3CH2O + NO2' + xsqy_tab(m)%wrf_label = 'j_ch3ch2ono2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/RONO2_talukdar.abs' + xsqy_tab(m)%filespec%nskip(1) = 10 + xsqy_tab(m)%filespec%nread(1) = 63 + subr(m)%xsqy_sub => r106 + m = m + 1 + + xsqy_tab(m)%label = 'CH3CHONO2CH3 -> CH3CHOCH3 + NO2' + xsqy_tab(m)%wrf_label = 'j_ch3chono2ch3' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/RONO2_talukdar.abs' + xsqy_tab(m)%filespec%nskip(1) = 10 + xsqy_tab(m)%filespec%nread(1) = 63 + subr(m)%xsqy_sub => r107 + m = m + 1 + + xsqy_tab(m)%label = 'CH2(OH)CH2(ONO2) -> CH2(OH)CH2(O.) + NO2' + xsqy_tab(m)%wrf_label = 'j_ch2ohch2ono2' + xsqy_tab(m)%jndx = m + subr(m)%xsqy_sub => r108 + m = m + 1 + + xsqy_tab(m)%label = 'CH3COCH2(ONO2) -> CH3COCH2(O.) + NO2' + xsqy_tab(m)%wrf_label = 'j_ch3coch2ono2' + xsqy_tab(m)%jndx = m + subr(m)%xsqy_sub => r109 + m = m + 1 + + xsqy_tab(m)%label = 'C(CH3)3(ONO2) -> C(CH3)3(O.) + NO2' + xsqy_tab(m)%wrf_label = 'j_bnit1' + xsqy_tab(m)%jndx = m + subr(m)%xsqy_sub => r110 + m = m + 1 + + xsqy_tab(m)%label = 'ClOOCl -> Cl + ClOO' + xsqy_tab(m)%wrf_label = 'j_cloocl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClOOCl_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 3 + xsqy_tab(m)%filespec%nread(1) = 111 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CH2(OH)COCH3 -> CH3CO + CH2(OH)' + xsqy_tab(m+1)%label = 'CH2(OH)COCH3 -> CH2(OH)CO + CH3' + xsqy_tab(m)%wrf_label = 'j_hyac_a' + xsqy_tab(m+1)%wrf_label = 'j_hyac_b' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1)%channel = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Hydroxyacetone_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 96 + subr(m)%xsqy_sub => r112 + subr(m+1)%xsqy_sub => r112 + m = m + 2 + + xsqy_tab(m)%label = 'HOBr -> OH + Br' + xsqy_tab(m)%wrf_label = 'j_hobr' + xsqy_tab(m)%jndx = m + subr(m)%xsqy_sub => r113 + m = m + 1 + + xsqy_tab(m)%label = 'BrO -> Br + O' + xsqy_tab(m)%wrf_label = 'j_bro' + xsqy_tab(m)%jndx = m + subr(m)%xsqy_sub => r114 + m = m + 1 + + xsqy_tab(m)%label = 'Br2 -> Br + Br' + xsqy_tab(m)%wrf_label = 'j_br2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Br2.abs' + xsqy_tab(m)%filespec%nskip(1) = 6 + xsqy_tab(m)%filespec%nread(1) = 29 + xsqy_tab(m)%filespec%xfac(1) = 1. + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'NO3-(aq) -> NO2(aq) + O-' + xsqy_tab(m+1)%label = 'NO3-(aq) -> NO2-(aq) + O(3P)' + xsqy_tab(m+2)%label = 'NO3-(aq) with qy=1' + xsqy_tab(m)%wrf_label = 'j_no3_aq_a' + xsqy_tab(m+1)%wrf_label = 'j_no3_aq_b' + xsqy_tab(m+2)%wrf_label = 'j_no3_aq_c' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1:m+2)%channel = (/ 2,3 /) + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/NO3-_CA03.abs' + xsqy_tab(m)%filespec%nskip(1) = 7 + xsqy_tab(m)%filespec%nread(1) = 43 + subr(m)%xsqy_sub => r118 + subr(m+1)%xsqy_sub => r118 + subr(m+2)%xsqy_sub => r118 + m = m + 3 + + xsqy_tab(m)%label = 'CH3COCH2CH3 -> CH3CO + CH2CH3' + xsqy_tab(m)%wrf_label = 'j_mek' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Martinez.abs' + xsqy_tab(m)%filespec%nskip(1) = 4 + xsqy_tab(m)%filespec%nread(1) = 96 + subr(m)%xsqy_sub => r119 + m = m + 1 + + xsqy_tab(m)%label = 'CH3CH2CO(OONO2) -> CH3CH2CO(OO) + NO2' + xsqy_tab(m+1)%label = 'CH3CH2CO(OONO2) -> CH3CH2CO(O) + NO3' + xsqy_tab(m)%wrf_label = 'j_ppn_a' + xsqy_tab(m+1)%wrf_label = 'j_ppn_b' + xsqy_tab(m:m+1)%tpflag = 1 + xsqy_tab(m)%jndx = m + xsqy_tab(m+1)%channel = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/PPN_Harwood.txt' + xsqy_tab(m)%filespec%nskip(1) = 10 + xsqy_tab(m)%filespec%nread(1) = 66 + subr(m)%xsqy_sub => r120 + subr(m+1)%xsqy_sub => r120 + m = m + 2 + + xsqy_tab(m)%label = 'HOCH2OOH -> HOCH2O. + OH' + xsqy_tab(m)%wrf_label = 'j_hoch2ooh' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HOCH2OOH_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 3 + xsqy_tab(m)%filespec%nread(1) = 32 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CH2=CHCHO -> Products' + xsqy_tab(m)%wrf_label = 'j_acrol' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Acrolein.txt' + xsqy_tab(m)%filespec%nskip(1) = 6 + xsqy_tab(m)%filespec%nread(1) = 55 + subr(m)%xsqy_sub => r122 + m = m + 1 + + xsqy_tab(m)%label = 'CH3CO(OOH) -> Products' + xsqy_tab(m)%wrf_label = 'j_ch3coooh' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/Peracetic_acid.txt' + xsqy_tab(m)%filespec%nskip(1) = 6 + xsqy_tab(m)%filespec%nread(1) = 66 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = '(CH3)2NNO -> Products' + xsqy_tab(m)%wrf_label = 'j_amine' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/dmna.abs' + xsqy_tab(m)%filespec%nskip(1) = 5 + xsqy_tab(m)%filespec%nread(1) = 132 + xsqy_tab(m)%filespec%xfac(1) = 1.e-19 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'ClO -> Cl + O(1D)' + xsqy_tab(m+1)%label = 'ClO -> Cl + O(3P)' + xsqy_tab(m)%wrf_label = 'j_clo_a' + xsqy_tab(m+1)%wrf_label = 'j_clo_b' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1)%channel = 2 + xsqy_tab(m:m+1)%tpflag = 1 + subr(m)%xsqy_sub => r125 + subr(m+1)%xsqy_sub => r125 + m = m + 2 + + xsqy_tab(m)%label = 'ClNO2 -> Cl + NO2' + xsqy_tab(m)%wrf_label = 'j_clno2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClNO2.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 26 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'BrNO -> Br + NO' + xsqy_tab(m)%wrf_label = 'j_brno' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrNO.abs' + xsqy_tab(m)%filespec%nskip(1) = 3 + xsqy_tab(m)%filespec%nread(1) = 27 + xsqy_tab(m)%filespec%xfac(1) = 1. + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'BrNO2 -> Br + NO2' + xsqy_tab(m)%wrf_label = 'j_brno2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrNO2.abs' + xsqy_tab(m)%filespec%nskip(1) = 6 + xsqy_tab(m)%filespec%nread(1) = 54 + xsqy_tab(m)%filespec%xfac(1) = 1. + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'BrONO -> Br + NO2' + xsqy_tab(m+1)%label = 'BrONO -> BrO + NO' + xsqy_tab(m)%wrf_label = 'j_brono_a' + xsqy_tab(m+1)%wrf_label = 'j_brono_b' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1)%channel = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrONO.abs' + xsqy_tab(m)%filespec%nskip(1) = 8 + xsqy_tab(m)%filespec%nread(1) = 32 + subr(m)%xsqy_sub => r129 + subr(m+1)%xsqy_sub => r129 + m = m + 2 + + xsqy_tab(m)%label = 'HOCl -> HO + Cl' + xsqy_tab(m)%wrf_label = 'j_hocl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HOCl.abs' + xsqy_tab(m)%filespec%nskip(1) = 7 + xsqy_tab(m)%filespec%nread(1) = 111 + xsqy_tab(m)%filespec%xfac(1) = 1. + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'NOCl -> NO + Cl' + xsqy_tab(m)%wrf_label = 'j_nocl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%nfiles = 2 + xsqy_tab(m)%filespec%filename(1:2) = 'DATAJ1/ABS/NOCl.abs' + xsqy_tab(m)%filespec%nskip(1:2) = (/ 7,88 /) + xsqy_tab(m)%filespec%nread(1:2) = (/ 80,61 /) + subr(m)%xsqy_sub => r131 + m = m + 1 + + xsqy_tab(m)%label = 'OClO -> Products' + xsqy_tab(m)%wrf_label = 'j_oclo' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%nfiles = 3 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/OClO.abs' + xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/ABS/OClO.abs' + xsqy_tab(m)%filespec%filename(3) = 'DATAJ1/ABS/OClO.abs' + xsqy_tab(m)%filespec%nskip(1:3) = (/ 6,1075,2142 /) + xsqy_tab(m)%filespec%nread(1:3) = (/ 1068,1067,1068 /) + subr(m)%xsqy_sub => r132 + m = m + 1 + + xsqy_tab(m)%label = 'BrCl -> Br + Cl' + xsqy_tab(m)%wrf_label = 'j_brcl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/BrCl.abs' + xsqy_tab(m)%filespec%nskip(1) = 9 + xsqy_tab(m)%filespec%nread(1) = 81 + xsqy_tab(m)%filespec%xfac(1) = 1. + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CH3(OONO2) -> CH3(OO) + NO2' + xsqy_tab(m)%wrf_label = 'j_ch3oono2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3OONO2.abs' + xsqy_tab(m)%filespec%nskip(1) = 9 + xsqy_tab(m)%filespec%nread(1) = 26 + xsqy_tab(m)%filespec%xfac(1) = 1. + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'C(CH3)3(ONO) -> C(CH3)3(O) + NO' + xsqy_tab(m)%wrf_label = 'j_bnit2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/t-butyl-nitrite.abs' + xsqy_tab(m)%filespec%nskip(1) = 4 + xsqy_tab(m)%filespec%nread(1) = 96 + xsqy_tab(m)%filespec%xfac(1) = 1. + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'ClONO -> Cl + NO2' + xsqy_tab(m)%wrf_label = 'j_clono' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/ClONO_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 3 + xsqy_tab(m)%filespec%nread(1) = 34 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'HCl -> H + Cl' + xsqy_tab(m)%wrf_label = 'j_hcl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/HCl_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 3 + xsqy_tab(m)%filespec%nread(1) = 31 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CH2O -> H + HCO' + xsqy_tab(m+1)%label = 'CH2O -> H2 + CO' + xsqy_tab(m)%wrf_label = 'j_ch2o_r' + xsqy_tab(m+1)%wrf_label = 'j_ch2o_m' + xsqy_tab(m)%jndx = m + xsqy_tab(m+1)%channel = 2 + xsqy_tab(m:m+1)%tpflag = (/ 1,3 /) + xsqy_tab(m)%filespec%nfiles = 2 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/CH2O/CH2O_jpl11.abs' + xsqy_tab(m)%filespec%filename(2) = 'DATAJ1/CH2O/CH2O_jpl11.yld' + xsqy_tab(m)%filespec%nskip(1:2) = 4 + xsqy_tab(m)%filespec%nread(1:2) = (/ 150,112 /) + subr(m)%xsqy_sub => pxCH2O + subr(m+1)%xsqy_sub => pxCH2O + m = m + 2 + + xsqy_tab(m)%label = 'CH3COOH -> CH3 + COOH' + xsqy_tab(m)%wrf_label = 'j_ch3cooh' + xsqy_tab(m)%qyld = .55 + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3COOH_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 18 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CH3OCl -> CH3O + Cl' + xsqy_tab(m)%wrf_label = 'j_ch3ocl' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CH3OCl_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 3 + xsqy_tab(m)%filespec%nread(1) = 83 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'CHCl3 -> Products' + xsqy_tab(m)%wrf_label = 'j_chcl3' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/CHCl3_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 3 + xsqy_tab(m)%filespec%nread(1) = 39 + subr(m)%xsqy_sub => r140 + m = m + 1 + + xsqy_tab(m)%label = 'C2H5ONO2 -> C2H5O + NO2' + xsqy_tab(m)%wrf_label = 'j_c2h5ono2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%tpflag = 1 + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/C2H5ONO2_iup2006.abs' + xsqy_tab(m)%filespec%nskip(1) = 4 + xsqy_tab(m)%filespec%nread(1) = 32 + subr(m)%xsqy_sub => r141 + m = m + 1 + + xsqy_tab(m)%label = 'n-C3H7ONO2 -> C3H7O + NO2' + xsqy_tab(m)%wrf_label = 'j_nc3h7ono2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/nC3H7ONO2_iup2006.abs' + xsqy_tab(m)%filespec%nskip(1) = 3 + xsqy_tab(m)%filespec%nread(1) = 32 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = '1-C4H9ONO2 -> 1-C4H9O + NO2' + xsqy_tab(m)%wrf_label = 'j_1c4h9ono2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/1C4H9ONO2_iup2006.abs' + xsqy_tab(m)%filespec%nskip(1) = 3 + xsqy_tab(m)%filespec%nread(1) = 32 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = '2-C4H9ONO2 -> 2-C4H9O + NO2' + xsqy_tab(m)%wrf_label = 'j_2c4h9ono2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/RONO2/2C4H9ONO2_iup2006.abs' + xsqy_tab(m)%filespec%nskip(1) = 3 + xsqy_tab(m)%filespec%nread(1) = 15 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'perfluoro 1-iodopropane -> products' + xsqy_tab(m)%wrf_label = 'j_perfluoro' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/PF-n-iodopropane.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 16 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'I2 -> I + I' + xsqy_tab(m)%wrf_label = 'j_i2' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/YLD/I2.qy' + xsqy_tab(m)%filespec%nskip(1) = 4 + xsqy_tab(m)%filespec%nread(1) = 12 + subr(m)%xsqy_sub => r146 + m = m + 1 + + xsqy_tab(m)%label = 'IO -> I + O' + xsqy_tab(m)%wrf_label = 'j_io' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/IO_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 133 + subr(m)%xsqy_sub => no_z_dep + m = m + 1 + + xsqy_tab(m)%label = 'IOH -> I + OH' + xsqy_tab(m)%wrf_label = 'j_ioh' + xsqy_tab(m)%jndx = m + xsqy_tab(m)%filespec%filename(1) = 'DATAJ1/ABS/IOH_jpl11.abs' + xsqy_tab(m)%filespec%nskip(1) = 2 + xsqy_tab(m)%filespec%nread(1) = 101 + subr(m)%xsqy_sub => no_z_dep + + end subroutine setup_sub_calls + +!-----------------------------------------------------------------------------* +!= *** ALL the following subroutines have the following arguments +!= *** except for the routines: +!= rxn_init, base_read, readit, add_pnts_inter2 +!= =* +!= PARAMETERS: =* +!= NW - INTEGER, number of specified intervals + 1 in working (I)=* +!= wavelength grid =* +!= WL - REAL, vector of lower limits of wavelength intervals in (I)=* +!= working wavelength grid =* +!= WC - REAL, vector of center points of wavelength intervals in (I)=* +!= working wavelength grid =* +!= NZ - INTEGER, number of altitude levels in working altitude grid (I)=* +!= TLEV - REAL, temperature (K) at each specified altitude level (I)=* +!= AIRDEN - REAL, air density (molec/cc) at each altitude level (I)=* +!= J - INTEGER, counter for number of weighting functions defined (IO)=* +!= SQ - REAL, cross section x quantum yield (cm^2) for each (O)=* +!= photolysis reaction defined, at each defined wavelength and =* +!= at each defined altitude level =* +!= JLABEL - CHARACTER(len=50) ::, string identifier for each photolysis (O)=* +!= reaction defined =* +!-----------------------------------------------------------------------------* + + SUBROUTINE r01(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product of (cross section) x (quantum yield) for the two =* +!= O3 photolysis reactions: =* +!= (a) O3 + hv -> O2 + O(1D) =* +!= (b) O3 + hv -> O2 + O(3P) =* +!= Cross section: Combined data from WMO 85 Ozone Assessment (use 273K =* +!= value from 175.439-847.5 nm) and data from Molina and =* +!= Molina (use in Hartley and Huggins bans (240.5-350 nm) =* +!= Quantum yield: Choice between =* +!= (1) data from Michelsen et al, 1994 =* +!= (2) JPL 87 recommendation =* +!= (3) JPL 90/92 recommendation (no "tail") =* +!= (4) data from Shetter et al., 1996 =* +!= (5) JPL 97 recommendation =* +!= (6) JPL 00 recommendation =* +!-----------------------------------------------------------------------------* + + use module_xsections, only : o3xs + +! input + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + + INTEGER, intent(inout) :: j + +! local + + INTEGER :: iw + REAL :: xs(nz,nw-1) + REAL :: qy1d(nz) + + if( .not. initialize ) then + call check_alloc( j, nz, nw-1 ) + +! call cross section read/interpolate routine +! cross sections from WMO 1985 Ozone Assessment +! from 175.439 to 847.500 nm. Using value at 273 K. +! Values are over-written in Hartly and Huggins bands, using different +! options depending on value of mopt: + +! mabs = 1 = mostly Reims grp (Malicet, Brion) +! mabs = 2 = JPL 2006 + + CALL o3xs(nz,tlev,nw,wl, xs) + +!****** quantum yield: +! choose quantum yield recommendation: +! kjpl87: JPL recommendation 1987 - JPL 87, 90, 92 do not "tail" +! kjpl92: JPL recommendations 1990/92 (identical) - still with no "tail" +! kjpl97: JPL recommendation 1997, includes tail, similar to Shetter et al. +! kmich : Michelsen et al., 1994 +! kshet : Shetter et al., 1996 +! kjpl00: JPL 2000 +! kmats: Matsumi et al., 2002 + +! compute cross sections and yields at different wavelengths, altitudes: + DO iw = 1, nw-1 +! quantum yields, Matsumi et al. + CALL fo3qy2(nz,wc(iw),tlev,qy1d) + if( xsqy_tab(j)%channel == 2 ) then + qy1d(1:nz) = (1. - qy1d(1:nz)) + endif + xsqy_tab(j)%sq(1:nz,iw) = qy1d(1:nz)*xs(1:nz,iw) + END DO + endif + + END SUBROUTINE r01 + +!=============================================================================* + + SUBROUTINE r02(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for NO2 =* +!= photolysis: =* +!= NO2 + hv -> NO + O(3P) =* +!= Cross section from JPL94 (can also have Davidson et al.) =* +!= Quantum yield from Gardiner, Sperry, and Calvert =* +!-----------------------------------------------------------------------------* + + use module_xsections, only : no2xs_jpl06a + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + + +! data arrays + INTEGER, parameter :: kdata = 200 + + REAL x1(kdata) + REAL y1(kdata), y2(kdata) + +! local + REAL, save :: yg1(kw), ydel(kw) + REAL :: yg2(kw) + REAL :: qy(nz) + REAL :: t(nz) + REAL :: no2xs(nz,nw-1) + INTEGER :: i, iw, n, idum, ierr + CHARACTER(len=256) :: msg + +!*************** NO2 photodissociation + + if( initialize ) then + CALL readit + ydel(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1) + else + call check_alloc( j, nz, nw-1 ) + +! options for NO2 cross section: +! 1 = Davidson et al. (1988), indepedent of T +! 2 = JPL 1994 (same as JPL 1997, JPL 2002) +! 3 = Harder et al. +! 4 = JPL 2006, interpolating between midpoints of bins +! 5 = JPL 2006, bin-to-bin interpolation + +! mabs = 4 + + CALL no2xs_jpl06a(nz,tlev,nw,wl, no2xs) + +! quantum yields +! myld = 1 NO2_calvert.yld (same as JPL2002) +! myld = 2 NO2_jpl11.yld (same as jpl2006) + +! myld = 2 + +! from jpl 2011 + + t(1:nz) = .02*(tlev(1:nz) - 298.) + DO iw = 1, nw - 1 + qy(1:nz) = yg1(iw) + ydel(iw)*t(1:nz) + xsqy_tab(j)%sq(1:nz,iw) = no2xs(1:nz,iw)*max( qy(1:nz),0. ) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit + + integer :: nsav + real :: xsav(kdata) + + n = 25 ; nsav = 25 + CALL base_read( filespec='DATAJ1/YLD/NO2_jpl11.yld', & + skip_cnt=2,rd_cnt=n,x=x1,y=y1,y1=y2 ) + xsav(1:n) = x1(1:n) + CALL add_pnts_inter2(x1,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/y1(1),0./)) + n = nsav + x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/y2(1),0./)) + + END SUBROUTINE readit + + END SUBROUTINE r02 + +!=============================================================================* + + SUBROUTINE r03(nw,wl,wc,nz,tlev,airden,j) + +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (absorptioon cross section) x (quantum yield) for =* +!= both channels of NO3 photolysis: =* +!= (a) NO3 + hv -> NO2 + O(3P) =* +!= (b) NO3 + hv -> NO + O2 =* +!= Cross section combined from Graham and Johnston (<600 nm) and JPL 94 =* +!= Quantum yield from Madronich (1988) =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + INTEGER, PARAMETER :: kdata=350 + + REAL x(kdata), x1(kdata) + REAL y1(kdata) + real q1_298(kdata), q1_230(kdata), q1_190(kdata) + real q2_298(kdata), q2_230(kdata), q2_190(kdata) + real :: sq_wrk(nz) + +! local + real, parameter :: tfac1 = 1./(230. - 190.) + real, parameter :: tfac2 = 1./(298. - 230.) + + REAL :: qy, qy1, qy2, xsect + REAL, save :: yg1(kw) + real, save :: yg_298(kw,2), yg_230(kw,2), yg_190(kw,2) + real, save :: delabs(kw,2,2) + real :: t(nz) + + INTEGER i, iw, iz, n, idum, chnl + INTEGER ierr + LOGICAL, save :: is_initialized = .false. + + if( initialize ) then + if( .not. is_initialized ) then +! yields from JPL2011: + CALL readit + delabs(1:nw-1,1,1) = yg_230(1:nw-1,1) - yg_190(1:nw-1,1) + delabs(1:nw-1,2,1) = yg_298(1:nw-1,1) - yg_230(1:nw-1,1) + delabs(1:nw-1,1,2) = yg_230(1:nw-1,2) - yg_190(1:nw-1,2) + delabs(1:nw-1,2,2) = yg_298(1:nw-1,2) - yg_230(1:nw-1,2) + is_initialized = .true. + endif + else + call check_alloc( j, nz, nw-1 ) + +! mabs = 3: JPL11 +! mabs = 3 +! myld = 2 from JPL-2011 +! myld = 2 + +! compute T-dependent quantum yields + chnl = xsqy_tab(j)%channel + DO iw = 1, nw-1 + xsect = yg1(iw) + where(tlev(1:nz) <= 190. ) + sq_wrk(1:nz) = yg_190(iw,chnl)*xsect + elsewhere(tlev(1:nz) > 190. .and. tlev(1:nz) <= 230. ) + t(1:nz) = tfac1*(tlev(1:nz) - 190.) + sq_wrk(1:nz) = yg_190(iw,chnl) + delabs(iw,1,chnl)*t(1:nz) + elsewhere(tlev(1:nz) > 230. .and. tlev(1:nz) <= 298. ) + t(1:nz) = tfac2*(tlev(1:nz) - 230.) + sq_wrk(1:nz) = yg_230(iw,chnl) + delabs(iw,2,chnl)*t(1:nz) + elsewhere(tlev(1:nz) > 298. ) + sq_wrk(1:nz) = yg_298(iw,chnl) + endwhere + xsqy_tab(j)%sq(1:nz,iw) = sq_wrk(1:nz)*xsect + ENDDO + endif + + CONTAINS + + SUBROUTINE readit + + integer :: nsav + real :: xsav(kdata) + + n = 289 + CALL base_read( filespec='DATAJ1/ABS/NO3_jpl11.abs', & + skip_cnt=6,rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n)*1.E-20 + CALL add_pnts_inter2(x1,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = 56 ; nsav = 56 + CALL base_read( filespec='DATAJ1/YLD/NO3_jpl2011.qy', & + skip_cnt=5,rd_cnt=n,x=x,y=q1_298, & + y1=q1_230,y2=q1_190,y3=q2_298, & + y4=q2_230,y5=q2_190 ) + xsav(1:n) = x(1:n) + q1_298(1:n) = q1_298(1:n)*.001 + q1_230(1:n) = q1_230(1:n)*.001 + q1_190(1:n) = q1_190(1:n)*.001 + q2_298(1:n) = q2_298(1:n)*.001 + q2_230(1:n) = q2_230(1:n)*.001 + q2_190(1:n) = q2_190(1:n)*.001 + + CALL add_pnts_inter2(x,q1_298,yg_298,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + n = nsav ; x(1:n) = xsav(1:n) + CALL add_pnts_inter2(x,q1_230,yg_230,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + n = nsav ; x(1:n) = xsav(1:n) + CALL add_pnts_inter2(x,q1_190,yg_190,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x(1:n) = xsav(1:n) + CALL add_pnts_inter2(x,q2_298,yg_298(1,2),kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/1.,0./)) + n = nsav ; x(1:n) = xsav(1:n) + CALL add_pnts_inter2(x,q2_230,yg_230(1,2),kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/1.,0./)) + n = nsav ; x(1:n) = xsav(1:n) + CALL add_pnts_inter2(x,q2_190,yg_190(1,2),kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/1.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r03 + +!=============================================================================* + + SUBROUTINE r04(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product of (cross section) x (quantum yiels) for N2O5 photolysis =* +!= reactions: =* +!= (a) N2O5 + hv -> NO3 + NO + O(3P) =* +!= (b) N2O5 + hv -> NO3 + NO2 =* +!= Cross section from JPL2011: use tabulated values for 300K, correct for =* +!= temperature. +!= Quantum yield: Analysis of data in JPL94 (->DATAJ1/YLD/N2O5.qy) =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + INTEGER, PARAMETER :: kdata = 200 + + REAL x1(kdata), x2(kdata) + REAL y1(kdata), A(kdata), B(kdata) + INTEGER :: n, n1, n2 + +! local + INTEGER :: iw + REAL :: xs + REAL, save :: yg1(kw), yg2(kw) + REAL :: dum(nz) + REAL :: t(nz) + LOGICAL, save :: is_initialized = .false. + + if( initialize ) then + if( .not. is_initialized ) then + CALL readit + is_initialized = .true. + endif + else + call check_alloc( j, nz, nw-1 ) + if( xsqy_tab(j)%channel == 1 ) then + DO iw = 1,nw-1 + xsqy_tab(j)%sq(1:nz,iw) = 0. + ENDDO + elseif( xsqy_tab(j)%channel == 2 ) then +! temperature dependence only valid for 233 - 295 K. Extend to 300. + t(1:nz) = MAX(233.,MIN(tlev(1:nz),300.)) + + DO iw = 1, nw - 1 +! Apply temperature correction to 300K values. Do not use A-coefficients +! because they are inconsistent with the values at 300K. +! quantum yield = 1 for NO2 + NO3, zero for other channels + dum(1:nz) = 1000.*yg2(iw)*(300. - t(1:nz))/(300.*t(1:nz)) + xsqy_tab(j)%sq(1:nz,iw) = yg1(iw) * 10.**(dum(1:nz)) + ENDDO + endif + endif + + CONTAINS + + SUBROUTINE readit +! cross section from jpl2011, at 300 K + + n1 = 103 + CALL base_read( filespec='DATAJ1/ABS/N2O5_jpl11.abs', & + skip_cnt=4,rd_cnt=n1,x=x1,y=y1 ) + y1(1:n1) = y1(1:n1) * 1.E-20 + CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + +! read temperature dependence coefficients: + n2 = 8 + CALL base_read( filespec='DATAJ1/ABS/N2O5_jpl11.abs', & + skip_cnt=111,rd_cnt=n2,x=x2,y=A,y1=B ) + + CALL add_pnts_inter2(x2,B,yg2,kdata,n2, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r04 + +!=============================================================================* + + SUBROUTINE r06(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product of (cross section) x (quantum yield) for HNO3 photolysis =* +!= HNO3 + hv -> OH + NO2 =* +!= Cross section: Burkholder et al., 1993 =* +!= Quantum yield: Assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER n1 + REAL x1(kdata), x2(kdata) + REAL y1(kdata), y2(kdata) + +! local + real :: t(nz) + REAL, save :: yg1(kw), yg2(kw) + INTEGER i, iw + INTEGER ierr + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) +! quantum yield = 1 +! correct for temperature dependence + t(1:nz) = tlev(1:nz) - 298. + DO iw = 1, nw - 1 + xsqy_tab(j)%sq(1:nz,iw) = yg1(iw) * exp( yg2(iw)*t(1:nz) ) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +! HNO3 cross section parameters from Burkholder et al. 1993 + + integer :: nsav + real :: xsav(kdata) + real :: yends(2) + + n1 = 83 ; nsav = 83 + CALL base_read( filespec='DATAJ1/ABS/HNO3_burk.abs', & + skip_cnt=6,rd_cnt=n1,x=y1,y=y2 ) + + x1(1:n1) = (/ (184. + real(i)*2.,i=1,n1) /) + xsav(1:n1) = x1(1:n1) + + y1(1:n1) = y1(1:n1) * 1.e-20 + CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + y2(1:n1) = y2(1:n1) * 1.e-3 + yends(:) = (/ y2(1),y2(n1) /) + n1 = nsav ; x1(1:n1) = xsav(1:n1) + CALL add_pnts_inter2(x1,y2,yg2,kdata,n1, & + nw,wl,xsqy_tab(j)%label,deltax,yends) + + END SUBROUTINE readit + + END SUBROUTINE r06 + +!=============================================================================* + + SUBROUTINE r08(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product of (cross section) x (quantum yield) for H2O2 photolysis =* +!= H2O2 + hv -> 2 OH =* +!= Cross section: From JPL97, tabulated values @ 298K for <260nm, T-depend.=* +!= parameterization for 260-350nm =* +!= Quantum yield: Assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=600 + + REAL x1(kdata) + REAL y1(kdata) + +! local + real, parameter :: A0 = 6.4761E+04 + real, parameter :: A1 = -9.2170972E+02 + real, parameter :: A2 = 4.535649 + real, parameter :: A3 = -4.4589016E-03 + real, parameter :: A4 = -4.035101E-05 + real, parameter :: A5 = 1.6878206E-07 + real, parameter :: A6 = -2.652014E-10 + real, parameter :: A7 = 1.5534675E-13 + + real, parameter :: B0 = 6.8123E+03 + real, parameter :: B1 = -5.1351E+01 + real, parameter :: B2 = 1.1522E-01 + real, parameter :: B3 = -3.0493E-05 + real, parameter :: B4 = -1.0924E-07 + + INTEGER i, iw, n, idum + INTEGER ierr + REAL lambda + REAL sumA, sumB + REAL :: t(nz) + REAL :: chi(nz) + REAL, save :: yg(kw) + +! cross section from Lin et al. 1978 + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) +! quantum yield = 1 + t(1:nz) = MIN(MAX(tlev(1:nz),200.),400.) + chi(1:nz) = 1./(1. + EXP(-1265./t(1:nz))) + DO iw = 1, nw - 1 +! Parameterization (JPL94) +! Range 260-350 nm; 200-400 K + IF ((wl(iw) .GE. 260.) .AND. (wl(iw) .LT. 350.)) THEN + lambda = wc(iw) + sumA = ((((((A7*lambda + A6)*lambda + A5)*lambda + & + A4)*lambda +A3)*lambda + A2)*lambda + & + A1)*lambda + A0 + sumB = (((B4*lambda + B3)*lambda + B2)*lambda + & + B1)*lambda + B0 + + xsqy_tab(j)%sq(1:nz,iw) = & + (chi(1:nz) * sumA + (1. - chi(1:nz))*sumB)*1.E-21 + ELSE + xsqy_tab(j)%sq(1:nz,iw) = yg(iw) + ENDIF + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +! cross section from JPL94 (identical to JPL97) +! tabulated data up to 260 nm + + integer :: n1 + + CALL base_read( filespec='DATAJ1/ABS/H2O2_jpl94.abs', & + rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.E-20 + + n1 = 494 + CALL base_read( filespec='DATAJ1/ABS/H2O2_Kahan.abs', & + skip_cnt=0,rd_cnt=n1,x=x1(n+1:),y=y1(n+1:) ) + + n = n + n1 + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r08 + +!=============================================================================* + + SUBROUTINE r09(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product of (cross section) x (quantum yield) for CHBr3 photolysis=* +!= CHBr3 + hv -> Products =* +!= Cross section: Choice of data from Atlas (?Talukdar???) or JPL97 =* +!= Quantum yield: Assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=200 + + INTEGER n1 + REAL x1(kdata) + REAL y1(kdata) + +! local + REAL, save :: yg(kw) + real :: t(nz) + + INTEGER i, iw, n + INTEGER ierr + INTEGER iz + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +! option: + +! kopt = 1: cross section from Elliot Atlas, 1997 +! kopt = 2: cross section from JPL 1997 +! kopt = 2 + +! quantum yield = 1 + + t(1:nz) = 273. - tlev(1:nz) + DO iw = 1, nw - 1 + IF (wc(iw) .GT. 290. .AND. wc(iw) .LT. 340. ) then + where( tlev(1:nz) > 210. .AND. tlev(1:nz) < 300. ) + xsqy_tab(j)%sq(1:nz,iw) = & + EXP( (.06183 - .000241*wc(iw))*t(1:nz) & + - (2.376 + 0.14757*wc(iw)) ) + elsewhere + xsqy_tab(j)%sq(1:nz,iw) = yg(iw) + endwhere + ELSE + xsqy_tab(j)%sq(1:nz,iw) = yg(iw) + ENDIF + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +! jpl97, with temperature dependence formula, +!w = 290 nm to 340 nm, +!T = 210K to 300 K +!sigma, cm2 = exp((0.06183-0.000241*w)*(273.-T)-(2.376+0.14757*w)) + + n1 = 87 + CALL base_read( filespec='DATAJ1/ABS/CHBr3.jpl97', & + skip_cnt=6,rd_cnt=n1,x=x1,y=y1 ) + + y1(1:n1) = y1(1:n1) * 1.e-20 + CALL add_pnts_inter2(x1,y1,yg,kdata,n1, & + nw,wl,xsqy_tab(j)%label,deltax,(/y1(1),0./)) + + END SUBROUTINE readit + + END SUBROUTINE r09 + +!=============================================================================* + + SUBROUTINE r11(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CH3CHO photolysis: =* +!= (a) CH3CHO + hv -> CH3 + HCO =* +!= (b) CH3CHO + hv -> CH4 + CO =* +!= (c) CH3CHO + hv -> CH3CO + H =* +!= Cross section: Choice between =* +!= (1) IUPAC 97 data, from Martinez et al. =* +!= (2) Calvert and Pitts =* +!= (3) Martinez et al., Table 1 scanned from paper =* +!= (4) KFA tabulations =* +!= Quantum yields: Choice between =* +!= (1) IUPAC 97, pressure correction using Horowith and =* +!= Calvert, 1982 =* +!= (2) NCAR data file, from Moortgat, 1986 =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=150 + + INTEGER i, n + INTEGER n1, n2 + REAL x1(kdata), x2(kdata) + REAL y1(kdata), y2(kdata) + +! local + INTEGER :: m, ierr + INTEGER :: iw + INTEGER :: chnl + REAL :: qy2, qy3 + REAL :: sig + REAL :: dum + REAL :: qy1_n0, qy1_0, x + REAL, save :: yg(kw), yg1(kw), yg2(kw), yg3(kw) + REAL :: qy1(nz) + LOGICAL, save :: is_initialized = .false. + + chnl = xsqy_tab(j)%channel + if( initialize ) then + if( .not. is_initialized ) then + CALL readit + is_initialized = .true. + endif + if( chnl > 1 ) then + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + if( chnl == 2 ) then + xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * yg2(1:nw-1) + elseif( chnl == 3 ) then + xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * yg3(1:nw-1) + endif + endif + else + if( xsqy_tab(j)%channel == 1 ) then + call check_alloc( j, nz, nw-1 ) +! mabs = 5 +! myld = 1 + DO iw = 1, nw - 1 + sig = yg(iw) +! quantum yields: +! input yields at n0 = 1 atm + qy1_n0 = yg1(iw) +! Pressure correction for CH3 + CHO channel: +! Assume pressure-dependence only for qy1, not qy2 or qy2. +! Assume total yield 1 at zero pressure + qy1_0 = 1. - (yg2(iw) + yg3(iw)) + +! compute coefficient: +! Stern-Volmer: 1/q = 1/q0 + k N and N0 = 1 atm, +! then x = K N0 q0 = qy_0/qy_N0 - 1 + if (qy1_n0 > 0.) then + x = qy1_0/qy1_n0 - 1. + else + x = 0. + endif + + qy1(1:nz) = qy1_n0 * (1. + x) / (1. + x * airden(1:nz)/2.465E19) + qy1(1:nz) = MIN( 1.,MAX(0.,qy1(1:nz)) ) + xsqy_tab(j)%sq(1:nz,iw) = sig * qy1(1:nz) + ENDDO + endif + endif + + CONTAINS + + SUBROUTINE readit + + integer :: nsav + real :: xsav(kdata) + + n = 101 + CALL base_read( filespec='DATAJ1/CH3CHO/CH3CHO_jpl11.abs', & + skip_cnt=2,rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.e-20 + + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + +! quantum yields + + n = 12 ; nsav = 12 + CALL base_read( filespec='DATAJ1/CH3CHO/CH3CHO_iup.yld', & + skip_cnt=4,rd_cnt=n,x=x1,y=y2,y1=y1 ) + xsav(1:n) = x1(1:n) + + CALL add_pnts_inter2(x1,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + n = nsav + x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + yg3(1:nw-1) = 0. + + END SUBROUTINE readit + + END SUBROUTINE r11 + +!=============================================================================* + + SUBROUTINE r12(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for C2H5CHO =* +!= photolysis: =* +!= C2H5CHO + hv -> C2H5 + HCO =* +!= =* +!= Cross section: Choice between =* +!= (1) IUPAC 97 data, from Martinez et al. =* +!= (2) Calvert and Pitts, as tabulated by KFA =* +!= Quantum yield: IUPAC 97 recommendation =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + + integer, PARAMETER :: kdata=150 + + INTEGER i, n + INTEGER n1 + REAL x1(kdata) + REAL y1(kdata) + +! local + REAL, save :: yg(kw), yg1(kw) + REAL :: qy1(nz) + REAL sig + INTEGER ierr + INTEGER iw + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +! Absorption: +! 1: IUPAC-97 data, from Martinez et al. +! 2: Calvert and Pitts, as tabulated by KFA. + +! Quantum yield +! 1: IUPAC-97 data + +! mabs = 1 +! myld = 1 + + DO iw = 1, nw - 1 +! quantum yields: +! use Stern-Volmer pressure dependence: + IF (yg1(iw) .LT. pzero) THEN + xsqy_tab(j)%sq(1:nz,iw) = 0. + ELSE + qy1(1:nz) = 1./(1. + (1./yg1(iw) - 1.)*airden(1:nz)/2.45e19) + qy1(1:nz) = MIN(qy1(1:nz),1.) + xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * qy1(1:nz) + ENDIF + ENDDO + endif + + CONTAINS + + SUBROUTINE readit + + character(len=256) :: emsg + + n = 106 + CALL base_read( filespec='DATAJ1/C2H5CHO/C2H5CHO_iup.abs', & + skip_cnt=4,rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.e-20 + + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + +! quantum yields + + n = 5 + CALL base_read( filespec='DATAJ1/C2H5CHO/C2H5CHO_iup.yld', & + skip_cnt=4,rd_cnt=n,x=x1,y=y1 ) + + CALL addpnt(x1,y1,kdata,n,x1(1)*(1.-deltax),0.) + CALL addpnt(x1,y1,kdata,n, 0.,0.) + CALL addpnt(x1,y1,kdata,n,340.,0.) + CALL addpnt(x1,y1,kdata,n, 1.e+38,0.) + CALL inter2(nw,wl,yg1,n,x1,y1,ierr) + IF (ierr .NE. 0) THEN + write(emsg,'(''readit: Error '',i5,'' in inter2 for '',a)') ierr,trim(xsqy_tab(j)%label) + call wrf_error_fatal( trim(emsg) ) + ENDIF + + END SUBROUTINE readit + + END SUBROUTINE r12 + +!=============================================================================* + + SUBROUTINE r13(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for CHOCHO =* +!= photolysis: =* +!= CHOCHO + hv -> Products =* +!= =* +!= Cross section: Choice between =* +!= (1) Plum et al., as tabulated by IUPAC 97 =* +!= (2) Plum et al., as tabulated by KFA. =* +!= (3) Orlando et al. =* +!= (4) Horowitz et al., 2001 =* +!= Quantum yield: IUPAC 97 recommendation =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=500 + + INTEGER i, n + REAL x(kdata), x1(kdata) + REAL y1(kdata), y2(kdata), y3(kdata) + +! local + REAL, save :: yg(kw), yg1(kw), yg2(kw), yg3(kw) + INTEGER :: ierr + LOGICAL, save :: is_initialized = .false. + +! mabs = 5 +! myld = 2 + + if( initialize ) then + if( .not. is_initialized ) then + CALL readit + is_initialized = .true. + endif + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + if( xsqy_tab(j)%channel == 1 ) then + xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * yg1(1:nw-1) + elseif( xsqy_tab(j)%channel == 2 ) then + xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * yg2(1:nw-1) + elseif( xsqy_tab(j)%channel == 3 ) then + xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * yg3(1:nw-1) + endif + endif + + CONTAINS + + SUBROUTINE readit + + integer :: nsav + real :: dum(kdata) + real :: xsav(kdata) + real :: yends(2) + + n = 277 + CALL base_read( filespec='DATAJ1/CHOCHO/glyoxal_jpl11.abs', & + skip_cnt=2,rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.e-20 + yends(:) = 0. + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,yends) + +! quantum yields + + n = 40 ; nsav = 40 + CALL base_read( filespec='DATAJ1/CHOCHO/glyoxal_jpl11.qy', & + skip_cnt=3,rd_cnt=n,x=x,y=dum,y1=y1,y2=y2,y3=y3 ) + xsav(1:n) = x(1:n) + yends(1) = y1(1) + CALL add_pnts_inter2(x,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,yends) + n = nsav ; x(1:n) = xsav(1:n) + yends(1) = y2(1) + CALL add_pnts_inter2(x,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,yends) + n = nsav ; x(1:n) = xsav(1:n) + yends(1) = y3(1) + CALL add_pnts_inter2(x,y3,yg3,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,yends) + + END SUBROUTINE readit + + END SUBROUTINE r13 + +!=============================================================================* + + SUBROUTINE r14(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for CH3COCHO =* +!= photolysis: =* +!= CH3COCHO + hv -> CH3CO + HCO =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=500 + + INTEGER i, n + INTEGER n1, n2 + REAL x1(kdata) + REAL y1(kdata) + +! local + REAL, save :: yg(kw) + REAL qy + REAL sig + INTEGER ierr + INTEGER iw + REAL phi0, kq + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +! mabs = 8 +! myld = 5 + + DO iw = 1, nw - 1 + sig = yg(iw) +! quantum yields: +! zero pressure yield: +! 1.0 for wc < 380 nm +! 0.0 for wc > 440 nm +! linear in between: + phi0 = 1. - (wc(iw) - 380.)/60. + phi0 = MIN(MAX(0.,phi0),1.) + +! Pressure correction: quenching coefficient, torr-1 +! in air, Koch and Moortgat: + kq = 1.36e8 * EXP(-8793./wc(iw)) +! in N2, Chen et al: + IF(phi0 .GT. 0.) THEN + IF (wc(iw) .GE. 380. .AND. wc(iw) .LE. 440.) THEN + xsqy_tab(j)%sq(1:nz,iw) = sig * phi0 & + / (phi0 + kq * airden(1:nz) * 760./2.456E19) + ELSE + xsqy_tab(j)%sq(1:nz,iw) = sig * phi0 + ENDIF + ELSE + xsqy_tab(j)%sq(1:nz,iw) = 0. + ENDIF + ENDDO + endif + + CONTAINS + + SUBROUTINE readit + + n = 294 + CALL base_read( filespec='DATAJ1/CH3COCHO/CH3COCHO_jpl11.abs', & + skip_cnt=2,rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.e-20 + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r14 + +!=============================================================================* + + SUBROUTINE r15(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CH3COCH3 photolysis=* +!= CH3COCH3 + hv -> Products =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + + integer, PARAMETER :: kdata=150 + + INTEGER :: i, n + REAL x1(kdata) + REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata) + +! local + REAL, save :: yg(kw), yg2(kw), yg3(kw) + REAL :: qy(nz) + REAL :: sig(nz) + REAL :: T(nz) + real :: fac(nz) + INTEGER ierr + INTEGER iw + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +! mabs = 4 +! myld = 4 + + T(1:nz) = MIN(MAX(tlev(1:nz), 235.),298.) + DO iw = 1, nw - 1 + sig(1:nz) = yg(iw) * (1. + t(1:nz)*(yg2(iw) + t(1:nz)*yg3(iw))) + CALL qyacet(nz, wc(iw), tlev, airden, fac) + xsqy_tab(j)%sq(1:nz,iw) = sig(1:nz)*min(max(0.,fac(1:nz)),1.) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit + + integer :: nsav + real :: xsav(kdata) + + n = 135 ; nsav = 135 + CALL base_read( filespec='DATAJ1/CH3COCH3/CH3COCH3_jpl11.abs', & + skip_cnt=5,rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3,y3=y4 ) + y1(1:n) = y1(1:n) * 1.e-20 + y2(1:n) = y2(1:n) * 1.e-3 + y3(1:n) = y3(1:n) * 1.e-5 + xsav(1:n) = x1(1:n) + + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y3,yg3,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r15 + +!=============================================================================* + + SUBROUTINE r17(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CH3ONO2 =* +!= photolysis: =* +!= CH3ONO2 + hv -> CH3O + NO2 =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + + integer, PARAMETER :: kdata = 100 + + INTEGER i, n + INTEGER iw + INTEGER n1, n2 + REAL :: x1(kdata) + REAL :: y1(kdata), y2(kdata) + +! local + REAL, save :: yg(kw), yg1(kw) + REAL :: qy + REAL :: sig + REAL :: T(nz) + INTEGER ierr + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +! mabs = 9 +! quantum yield = 1 + + T(1:nz) = tlev(1:nz) - 298. + DO iw = 1, nw - 1 + xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * exp( yg1(iw) * T(1:nz) ) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit + + integer :: nsav + real :: xsav(kdata) + + n = 65 ; nsav = 65 + CALL base_read( filespec='DATAJ1/RONO2/CH3ONO2_jpl11.abs', & + skip_cnt=2,rd_cnt=n,x=x1,y=y1,y1=y2 ) + y1(1:n) = y1(1:n) * 1.e-20 + y2(1:n) = y2(1:n) * 1.e-3 + xsav(1:n) = x1(1:n) + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y2,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r17 + +!=============================================================================* + + SUBROUTINE r18(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for PAN photolysis: =* +!= PAN + hv -> Products =* +!= =* +!= Cross section: from Talukdar et al., 1995 =* +!= Quantum yield: Assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER iw + INTEGER n + REAL :: x1(kdata) + REAL :: y1(kdata), y2(kdata) + +! local + +! quantum yield: +! from JPL 2011 values for >300 nm. +! real, parameter :: qyNO2 = .7 +! real, parameter :: qyNO3 = .3 + real, parameter :: qyld(2) = (/ .7,.3 /) + + INTEGER :: ierr, chnl + REAL, save :: yg(kw), yg2(kw) + REAL :: sig(nz), T(nz) + LOGICAL, save :: is_initialized = .false. + + if( initialize ) then + if( .not. is_initialized ) then + CALL readit + is_initialized = .true. + endif + else + call check_alloc( j, nz, nw-1 ) + + chnl = xsqy_tab(j)%channel + T(1:nz) = tlev(1:nz) - 298. + DO iw = 1, nw-1 + sig(1:nz) = yg(iw) * EXP( yg2(iw)*T(1:nz) ) + xsqy_tab(j)%sq(1:nz,iw) = qyld(chnl) * sig(1:nz) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +! cross section from +! Talukdar et al., 1995, J.Geophys.Res. 100/D7, 14163-14174 + + integer :: nsav + real :: xsav(kdata) + + n = 78 ; nsav = 78 + CALL base_read( filespec='DATAJ1/RONO2/PAN_talukdar.abs', & + skip_cnt=14,rd_cnt=n,x=x1,y=y1,y1=y2 ) + y1(1:n) = y1(1:n) * 1.E-20 + y2(1:n) = y2(1:n) * 1.E-3 + xsav(1:n) = x1(1:n) + + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r18 + +!=============================================================================* + + SUBROUTINE r20(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CCl4 photolysis: =* +!= CCl4 + hv -> Products =* +!= Cross section: from JPL 97 recommendation =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + REAL x1(kdata) + REAL y1(kdata) + +! local + real, parameter :: b0 = 1.0739 + real, parameter :: b1 = -1.6275e-2 + real, parameter :: b2 = 8.8141e-5 + real, parameter :: b3 = -1.9811e-7 + real, parameter :: b4 = 1.5022e-10 + + REAL, save :: yg(kw) + INTEGER i, iw, n, idum + INTEGER :: ierr + REAL :: tcoeff, sig + REAL :: w1 + REAL :: temp(nz) + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +! mabs = 1: jpl 1997 recommendation +! mabs = 2: jpl 2011 recommendation, with T dependence + +! mabs = 2 + +! compute temperature correction factors: + +!** quantum yield assumed to be unity + + temp(1:nz) = min(max(tlev(1:nz),210.),300.) + temp(1:nz) = temp(1:nz) - 295. + DO iw = 1, nw-1 +! compute temperature correction coefficients: + tcoeff = 0. + IF(wc(iw) .GT. 194. .AND. wc(iw) .LT. 250.) THEN + w1 = wc(iw) + tcoeff = b0 + w1*(b1 + w1*(b2 + w1*(b3 + w1*b4))) + ENDIF + xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * 10.**(tcoeff*temp(1:nz)) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!** cross sections from JPL97 recommendation (identical to 94 data) + + n = 44 + CALL base_read( filespec='DATAJ1/ABS/CCl4_jpl11.abs', & + skip_cnt=5,rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.E-20 + + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r20 + +!=============================================================================* + + SUBROUTINE r23(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CFC-113 photolysis:=* +!= CF2ClCFCl2 + hv -> Products =* +!= Cross section: from JPL 97 recommendation, linear interp. between =* +!= values at 210 and 295K =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER n1, n2 + REAL x1(kdata), x2(kdata) + REAL y1(kdata), y2(kdata) + +! local + real, parameter :: tfac1 = 1./(295. - 210.) + + REAL, save :: yg2(kw), ydel(kw) + REAL :: yg1(kw) + REAL qy + REAL :: t(nz) + REAL :: slope(nz) + INTEGER i, iw, n, idum + INTEGER iz + INTEGER ierr + + if( initialize ) then + CALL readit + ydel(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1) + else + call check_alloc( j, nz, nw-1 ) + +!** quantum yield assumed to be unity + + t(1:nz) = MAX(210.,MIN(tlev(1:nz),295.)) + slope(1:nz) = (t(1:nz) - 210.)*tfac1 + DO iw = 1, nw-1 + xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel(iw) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!** cross sections from JPL97 recommendation (identical to 94 recommendation) + + integer :: nsav + real :: xsav(kdata) + + CALL base_read( filespec='DATAJ1/ABS/CFC-113_jpl94.abs', & + rd_cnt=n,x=x1,y=y1,y1=y2 ) + y1(1:n) = y1(1:n) * 1.E-20 + y2(1:n) = y2(1:n) * 1.E-20 + xsav(1:n) = x1(1:n) + nsav = n + +!* sigma @ 295 K + CALL add_pnts_inter2(x1,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + +! sigma @ 210 K + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r23 + +!=============================================================================* + + SUBROUTINE r24(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CFC-144 photolysis:=* +!= CF2ClCF2Cl + hv -> Products =* +!= Cross section: from JPL 97 recommendation, linear interp. between values =* +!= at 210 and 295K =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER n1, n2 + REAL x1(kdata), x2(kdata) + REAL y1(kdata), y2(kdata) + +! local + real, parameter :: tfac1 = 1./(295. - 210.) + + REAL, save :: yg2(kw), ydel(kw) + REAL :: yg1(kw) + REAL qy + REAL :: t(nz) + REAL :: slope(nz) + INTEGER i, iw, n, idum + INTEGER ierr + INTEGER iz + + if( initialize ) then + CALL readit + ydel(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1) + else + call check_alloc( j, nz, nw-1 ) + +!** quantum yield assumed to be unity + + t(1:nz) = MAX(210.,MIN(tlev(1:nz),295.)) + slope(1:nz) = (t(1:nz) - 210.)*tfac1 + DO iw = 1, nw-1 + xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel(iw) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!*** cross sections from JPL97 recommendation (identical to 94 recommendation) + + integer :: nsav + real :: xsav(kdata) + + CALL base_read( filespec='DATAJ1/ABS/CFC-114_jpl94.abs', & + rd_cnt=n,x=x1,y=y1,y1=y2 ) + y1(1:n) = y1(1:n) * 1.E-20 + y2(1:n) = y2(1:n) * 1.E-20 + xsav(1:n) = x1(1:n) + nsav = n + +!* sigma @ 295 K + CALL add_pnts_inter2(x1,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) +! sigma @ 210 K + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r24 + +!=============================================================================* + + SUBROUTINE r26(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CFC-11 photolysis =* +!= CCl3F + hv -> Products =* +!= Cross section: from JPL 97 recommendation =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + + integer, PARAMETER :: kdata=100 + + REAL x1(kdata) + REAL y1(kdata) + +! local + REAL, save :: yg(kw) + REAL :: t(nz) + INTEGER :: iw, n + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +!*** quantum yield assumed to be unity + + t(1:nz) = 1.E-04 * (tlev(1:nz) - 298.) + DO iw = 1, nw-1 + xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * EXP((wc(iw)-184.9) * t(1:nz)) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!*** cross sections from JPL97 recommendation (identical to 94 recommendation) + + CALL base_read( filespec='DATAJ1/ABS/CFC-11_jpl94.abs',rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.E-20 + +!* sigma @ 298 K + + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r26 + +!=============================================================================* + + SUBROUTINE r27(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CFC-12 photolysis:=* +!= CCl2F2 + hv -> Products =* +!= Cross section: from JPL 97 recommendation =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + REAL x1(kdata) + REAL y1(kdata) + +! local + REAL, save :: yg(kw) + REAL :: t(nz) + INTEGER :: iw, n + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) +!*** quantum yield assumed to be unity + t(1:nz) = 1.E-04 * (tlev(1:nz) - 298.) + DO iw = 1, nw-1 + xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * EXP((wc(iw)-184.9) * t(1:nz)) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!*** cross sections from JPL97 recommendation (identical to 94 recommendation) + + CALL base_read( filespec='DATAJ1/ABS/CFC-12_jpl94.abs',rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.E-20 + +!* sigma @ 298 K + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r27 + +!=============================================================================* + + SUBROUTINE r29(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CH3CCl3 photolysis =* +!= CH3CCl3 + hv -> Products =* +!= Cross section: from JPL 97 recommendation, piecewise linear interp. =* +!= of data at 210, 250, and 295K =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER n1, n2, n3 + REAL x1(kdata), x2(kdata), x3(kdata) + REAL y1(kdata), y2(kdata), y3(kdata) + +! local + real, parameter :: tfac1 = 1./(250. - 210.) + real, parameter :: tfac2 = 1./(295. - 250.) + + REAL, save :: yg2(kw), yg3(kw), ydel1(kw), ydel2(kw) + REAL :: yg1(kw) + REAL qy + REAL :: t(nz) + REAL :: slope(nz) + INTEGER i, iw, n, idum + INTEGER ierr + INTEGER iz + + if( initialize ) then + CALL readit + ydel2(1:nw-1) = yg2(1:nw-1) - yg3(1:nw-1) + ydel1(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1) + else + call check_alloc( j, nz, nw-1 ) + +!*** quantum yield assumed to be unity + + t(1:nz) = MIN(295.,MAX(tlev(1:nz),210.)) + DO iw = 1, nw-1 + where( t(1:nz) <= 250. ) + slope(1:nz) = (t(1:nz) - 210.)*tfac1 + xsqy_tab(j)%sq(1:nz,iw) = yg3(iw) + slope(1:nz)*ydel2(iw) + elsewhere + slope(1:nz) = (t(1:nz) - 250.)*tfac2 + xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel1(iw) + endwhere + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!*** cross sections from JPL97 recommendation (identical to 94 recommendation) + + integer :: nsav + real :: xsav(kdata) + + CALL base_read( filespec='DATAJ1/ABS/CH3CCl3_jpl94.abs', & + rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3 ) + y1(1:n) = y1(1:n) * 1.E-20 + y2(1:n) = y2(1:n) * 1.E-20 + y3(1:n) = y3(1:n) * 1.E-20 + xsav(1:n) = x1(1:n) + nsav = n + +!* sigma @ 295 K + CALL add_pnts_inter2(x1,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) +!* sigma @ 250 K + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) +!* sigma @ 210 K + CALL add_pnts_inter2(x1,y3,yg3,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r29 + +!=============================================================================* + + SUBROUTINE r30(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CH3Cl photolysis: =* +!= CH3Cl + hv -> Products =* +!= Cross section: from JPL 97 recommendation, piecewise linear interp. =* +!= from values at 255, 279, and 296K =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER n1, n2, n3 + REAL x1(kdata), x2(kdata), x3(kdata) + REAL y1(kdata), y2(kdata), y3(kdata) + +! local + real, parameter :: tfac1 = 1./(279. - 255.) + real, parameter :: tfac2 = 1./(296. - 279.) + + REAL, save :: yg2(kw), yg3(kw) + REAL, save :: ydel1(kw), ydel2(kw) + REAL :: yg1(kw) + REAL qy + REAL :: t(nz) + REAL :: slope(nz) + INTEGER i, iw, n, idum + INTEGER ierr + INTEGER iz + + if( initialize ) then + CALL readit + ydel2(1:nw-1) = yg2(1:nw-1) - yg3(1:nw-1) + ydel1(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1) + else + call check_alloc( j, nz, nw-1 ) + +!*** quantum yield assumed to be unity + + t(1:nz) = MAX(255.,MIN(tlev(1:nz),296.)) + DO iw = 1, nw-1 + where( t(1:nz) <= 279. ) + slope(1:nz) = (t(1:nz) - 255.)*tfac1 + xsqy_tab(j)%sq(1:nz,iw) = yg3(iw) + slope(1:nz)*ydel2(iw) + elsewhere + slope(1:nz) = (t(1:nz) - 279.)*tfac2 + xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + slope(1:nz)*ydel1(iw) + endwhere + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!*** cross sections from JPL97 recommendation (identical to 94 recommendation) + + integer :: nsav + real :: xsav(kdata) + + CALL base_read( filespec='DATAJ1/ABS/CH3Cl_jpl94.abs', & + rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3 ) + y1(1:n) = y1(1:n) * 1.E-20 + y2(1:n) = y2(1:n) * 1.E-20 + y3(1:n) = y3(1:n) * 1.E-20 + xsav(1:n) = x1(1:n) + nsav = n + +!* sigma @ 296 K + CALL add_pnts_inter2(x1,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) +!* sigma @ 279 K + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) +!* sigma @ 255 K + CALL add_pnts_inter2(x1,y3,yg3,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r30 + +!=============================================================================* + + SUBROUTINE r32(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for HCFC-123 photolysis=* +!= CF3CHCl2 + hv -> Products =* +!= Cross section: from Orlando et al., 1991 =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! local + real, parameter :: LBar = 206.214 + + INTEGER i, iw, idum + INTEGER iz, k + REAL qy + REAL lambda + REAL, save :: TBar + REAL :: t(nz) + REAL :: sum(nz) + REAL, save :: coeff(4,3) + CHARACTER*120 inline + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +!*** quantum yield assumed to be unity + + DO iw = 1, nw-1 + lambda = wc(iw) +! use parameterization only up to 220 nm, as the error bars associated with +! the measurements beyond 220 nm are very large (Orlando, priv.comm.) + IF (lambda .GE. 190. .AND. lambda .LE. 220.) THEN + t(1:nz) = MIN(295.,MAX(tlev(1:nz),203.)) - TBar + sum(1:nz) = 0. + DO i = 1, 4 + sum(1:nz) = (coeff(i,1) + t(1:nz)*(coeff(i,2) + t(1:nz)*coeff(i,3))) & + * (lambda-LBar)**(i-1) + sum(1:nz) + ENDDO + xsqy_tab(j)%sq(1:nz,iw) = EXP(sum(1:nz)) + ELSE + xsqy_tab(j)%sq(1:nz,iw) = 0. + ENDIF + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!*** cross section from Orlando et al., 1991 + + OPEN(kin,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD') + READ(kin,*) idum + DO i = 1, idum-2 + READ(kin,*) + ENDDO + READ(kin,'(a120)') inline + READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3) + READ(kin,*) i,(coeff(i,k),k=1,3) + READ(kin,*) i,(coeff(i,k),k=1,3) + READ(kin,*) i,(coeff(i,k),k=1,3) + CLOSE(kin) + + END SUBROUTINE readit + + END SUBROUTINE r32 + +!=============================================================================* + + SUBROUTINE r33(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for HCFC-124 photolysis=* +!= CF3CHFCl + hv -> Products =* +!= Cross section: from Orlando et al., 1991 =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! local + real, parameter :: LBar = 206.214 + + INTEGER i, iw, n, idum + INTEGER iz, k + REAL qy + REAL lambda + REAL, save :: TBar + REAL :: t(nz) + REAL :: sum(nz) + REAL, save :: coeff(4,3) + CHARACTER*120 inline + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +!*** quantum yield assumed to be unity + + DO iw = 1, nw-1 + lambda = wc(iw) + IF (lambda .GE. 190. .AND. lambda .LE. 230.) THEN + t(1:nz) = MIN(295.,MAX(tlev(1:nz),203.)) - TBar + sum(1:nz) = 0. + DO i = 1, 4 + sum(1:nz) = (coeff(i,1) + t(1:nz)*(coeff(i,2) + t(1:nz)*coeff(i,3))) & + * (lambda-LBar)**(i-1) + sum(1:nz) + ENDDO + xsqy_tab(j)%sq(1:nz,iw) = EXP(sum(1:nz)) + ELSE + xsqy_tab(j)%sq(1:nz,iw) = 0. + ENDIF + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!*** cross section from Orlando et al., 1991 + + OPEN(kin,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD') + READ(kin,*) idum + idum = idum+5 + DO i = 1, idum-2 + READ(kin,*) + ENDDO + READ(kin,'(a120)') inline + READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3) + READ(kin,*) i,(coeff(i,k),k=1,3) + READ(kin,*) i,(coeff(i,k),k=1,3) + READ(kin,*) i,(coeff(i,k),k=1,3) + CLOSE(kin) + + END SUBROUTINE readit + + END SUBROUTINE r33 + +!=============================================================================* + + SUBROUTINE r35(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for HCFC-142b =* +!= photolysis: =* +!= CH3CF2Cl + hv -> Products =* +!= Cross section: from Orlando et al., 1991 =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! local + real, parameter :: LBar = 206.214 + + INTEGER i, iw, n, idum + INTEGER ierr + INTEGER iz, k + REAL qy + REAL lambda + REAL, save :: Tbar + REAL :: t(nz) + REAL :: sum(nz) + REAL, save :: coeff(4,3) + CHARACTER*80 inline + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +!*** quantum yield assumed to be unity + + DO iw = 1, nw-1 + lambda = wc(iw) + IF (lambda .GE. 190. .AND. lambda .LE. 230.) THEN + t(1:nz) = MIN(295.,MAX(tlev(1:nz),203.)) - TBar + sum(1:nz) = 0. + DO i = 1, 4 + sum(1:nz) = (coeff(i,1) + t(1:nz)*(coeff(i,2) + t(1:nz)*coeff(i,3))) & + * (lambda-LBar)**(i-1) + sum(1:nz) + ENDDO +! offeset exponent by 40 (exp(-40.) = 4.248e-18) to prevent exp. underflow errors +! on some machines. + xsqy_tab(j)%sq(1:nz,iw) = 4.248e-18 * EXP(sum(1:nz) + 40.) + ELSE + xsqy_tab(j)%sq(1:nz,iw) = 0. + ENDIF + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!*** cross section from Orlando et al., 1991 + + OPEN(kin,FILE='DATAJ1/ABS/HCFCs_orl.abs',STATUS='OLD') + READ(kin,*) idum + idum = idum+10 + DO i = 1, idum-2 + READ(kin,*) + ENDDO + READ(kin,'(a80)') inline + READ(inline(6:),*) TBar,i,(coeff(i,k),k=1,3) + READ(kin,*) i,(coeff(i,k),k=1,3) + READ(kin,*) i,(coeff(i,k),k=1,3) + READ(kin,*) i,(coeff(i,k),k=1,3) + CLOSE(kin) + + END SUBROUTINE readit + + END SUBROUTINE r35 + +!=============================================================================* + + SUBROUTINE r38(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for HCFC-22 photolysis =* +!= CHClF2 + hv -> Products =* +!= Cross section: from JPL 97 recommendation, piecewise linear interp. =* +!= from values at 210, 230, 250, 279, and 295 K =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER n1, n2, n3, n4, n5 + REAL x1(kdata), x2(kdata), x3(kdata), x4(kdata), x5(kdata) + REAL y1(kdata), y2(kdata), y3(kdata), y4(kdata), y5(kdata) + +! local + real, parameter :: tfac1 = 1./(230. - 210.) + real, parameter :: tfac2 = 1./(250. - 230.) + real, parameter :: tfac3 = 1./(270. - 250.) + real, parameter :: tfac4 = 1./(295. - 270.) + + REAL qy + REAL, save :: yg2(kw), yg3(kw), yg4(kw), yg5(kw) + REAL :: yg1(kw) + REAL, save :: ydel1(kw), ydel2(kw), ydel3(kw), ydel4(kw) + REAL :: t(nz), t1(nz), t2(nz), t3(nz), t4(nz) + REAL :: slope(nz) + INTEGER i, iw, n, idum + INTEGER ierr + INTEGER iz + + if( initialize ) then + CALL readit + ydel4(1:nw-1) = yg4(1:nw-1) - yg5(1:nw-1) + ydel3(1:nw-1) = yg3(1:nw-1) - yg4(1:nw-1) + ydel2(1:nw-1) = yg2(1:nw-1) - yg3(1:nw-1) + ydel1(1:nw-1) = yg1(1:nw-1) - yg2(1:nw-1) + else + call check_alloc( j, nz, nw-1 ) + +!*** quantum yield assumed to be unity + + t(1:nz) = MIN(295.,MAX(tlev(1:nz),210.)) + t1(1:nz) = (t(1:nz) - 210.)*tfac1 + t2(1:nz) = (t(1:nz) - 230.)*tfac2 + t3(1:nz) = (t(1:nz) - 250.)*tfac3 + t4(1:nz) = (t(1:nz) - 270.)*tfac4 + DO iw = 1, nw-1 + where( t(1:nz) <= 230. ) + xsqy_tab(j)%sq(1:nz,iw) = yg5(iw) + t1(1:nz)*ydel4(iw) + elsewhere( t(1:nz) > 230. .and. t(1:nz) <= 250. ) + xsqy_tab(j)%sq(1:nz,iw) = yg4(iw) + t2(1:nz)*ydel3(iw) + elsewhere( t(1:nz) > 250. .and. t(1:nz) <= 270. ) + xsqy_tab(j)%sq(1:nz,iw) = yg3(iw) + t3(1:nz)*ydel2(iw) + elsewhere + xsqy_tab(j)%sq(1:nz,iw) = yg2(iw) + t4(1:nz)*ydel1(iw) + endwhere + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!*** cross sections from JPL97 recommendation (identical to 94 recommendation) + + integer :: nsav + real :: xsav(kdata) + + CALL base_read( filespec='DATAJ1/ABS/HCFC-22_jpl94.abs', & + rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3,y3=y4,y4=y5 ) + y1(1:n) = y1(1:n) * 1.E-20 + y2(1:n) = y2(1:n) * 1.E-20 + y3(1:n) = y3(1:n) * 1.E-20 + y4(1:n) = y4(1:n) * 1.E-20 + y5(1:n) = y5(1:n) * 1.E-20 + nsav = n ; xsav(1:n) = x1(1:n) + +!* sigma @ 295 K + CALL add_pnts_inter2(x1,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) +!* sigma @ 270 K + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) +!* sigma @ 250 K + CALL add_pnts_inter2(x1,y3,yg3,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) +!* sigma @ 230 K + CALL add_pnts_inter2(x1,y4,yg4,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) +!* sigma @ 210 K + CALL add_pnts_inter2(x1,y5,yg5,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r38 + +!=============================================================================* + + SUBROUTINE r39(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for HO2 photolysis: =* +!= HO2 + hv -> OH + O =* +!= Cross section: from JPL 97 recommendation =* +!= Quantum yield: assumed shape based on work by Lee, 1982; normalized =* +!= to unity at 248 nm =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + REAL x1(kdata) + REAL y1(kdata) + +! local + real, parameter :: tfac1 = 1./(248. - 193.) + real, parameter :: xfac1 = 1./15. + + REAL :: yg(kw) + REAL :: qy(nw) + INTEGER :: n, idum + + if( initialize ) then + CALL readit + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + WHERE( wc(1:nw-1) >= 248. ) + qy(1:nw-1) = 1. + ELSEWHERE + qy(1:nw-1) = max( (1. + (wc(1:nw-1) - 193.)*14.*tfac1)*xfac1,0. ) + ENDWHERE + xsqy_tab(j)%sq(1:nw-1,1) = qy(1:nw-1) * yg(1:nw-1) + endif + + CONTAINS + + SUBROUTINE readit +!*** cross sections from JPL11 recommendation + + n = 15 + CALL base_read( filespec='DATAJ1/ABS/HO2_jpl11.abs', & + skip_cnt=10,rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.E-20 + + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r39 + +!=============================================================================* + + SUBROUTINE r44(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for N2O photolysis: =* +!= N2O + hv -> N2 + O(1D) =* +!= Cross section: from JPL 97 recommendation =* +!= Quantum yield: assumed to be unity, based on Greenblatt and Ravishankara =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! local + real, parameter :: A0 = 68.21023 + real, parameter :: A1 = -4.071805 + real, parameter :: A2 = 4.301146E-02 + real, parameter :: A3 = -1.777846E-04 + real, parameter :: A4 = 2.520672E-07 + + real, parameter :: B0 = 123.4014 + real, parameter :: B1 = -2.116255 + real, parameter :: B2 = 1.111572E-02 + real, parameter :: B3 = -1.881058E-05 + + INTEGER :: iw + REAL, save :: a(kw), b(kw) + REAL :: lambda + REAL :: t(nz) + REAL :: bt(nz) + + if( initialize ) then + DO iw = 1, nw-1 + lambda = wc(iw) + IF (lambda >= 173. .AND. lambda <= 240.) THEN + A(iw) = (((A4*lambda+A3)*lambda+A2)*lambda+A1)*lambda+A0 + B(iw) = (((B3*lambda+B2)*lambda+B1)*lambda+B0) + ENDIF + ENDDO + else + call check_alloc( j, nz, nw-1 ) + +!*** cross sections according to JPL97 recommendation (identical to 94 rec.) +!*** see file DATAJ1/ABS/N2O_jpl94.abs for detail +!*** quantum yield of N(4s) and NO(2Pi) is less than 1% (Greenblatt and +!*** Ravishankara), so quantum yield of O(1D) is assumed to be unity + + t(1:nz) = MAX(194.,MIN(tlev(1:nz),320.)) + DO iw = 1, nw-1 + lambda = wc(iw) + IF (lambda >= 173. .AND. lambda <= 240.) THEN + BT(1:nz) = (t(1:nz) - 300.)*EXP(B(iw)) + xsqy_tab(j)%sq(1:nz,iw) = EXP(A(iw)+BT(1:nz)) + ELSE + xsqy_tab(j)%sq(1:nz,iw) = 0. + ENDIF + ENDDO + endif + + END SUBROUTINE r44 + +!=============================================================================* + + SUBROUTINE r45(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for ClONO2 photolysis: =* +!= ClONO2 + hv -> Products =* +!= =* +!= Cross section: JPL 97 recommendation =* +!= Quantum yield: JPL 97 recommendation =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=150 + + REAL x1(kdata) + REAL y1(kdata),y2(kdata),y3(kdata) + +! local + REAL qy1, qy2 + REAL :: xs(nz) + real :: t(nz) + REAL, save :: yg1(kw), yg2(kw), yg3(kw) + INTEGER i, iw, n, idum, chnl + INTEGER ierr + INTEGER iz + LOGICAL, save :: is_initialized = .false. + + if( initialize ) then + if( .not. is_initialized ) then + CALL readit + is_initialized = .true. + endif + else + call check_alloc( j, nz, nw-1 ) + + t(1:nz) = tlev(1:nz) - 296. + chnl = xsqy_tab(j)%channel + DO iw = 1, nw-1 +!** quantum yields (from jpl97, same in jpl2011) + IF( wc(iw) .LT. 308.) THEN + qy1 = 0.6 + ELSEIF( (wc(iw) .GE. 308) .AND. (wc(iw) .LE. 364.) ) THEN + qy1 = 7.143e-3 * wc(iw) - 1.6 + ELSEIF( wc(iw) .GT. 364. ) THEN + qy1 = 1.0 + ENDIF + IF( chnl == 2 ) then + qy1 = 1.0 - qy1 + ENDIF +! compute T-dependent cross section + xs(1:nz) = yg1(iw) * (1. + t(1:nz) & + * (yg2(iw) + t(1:nz)*yg3(iw))) + xsqy_tab(j)%sq(1:nz,iw) = qy1 * xs(1:nz) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +!** cross sections from JPL97 recommendation. Same in JPL-2011. + + integer :: nsav + real :: xsav(kz) + + n = 119 ; nsav = 119 + CALL base_read( filespec='DATAJ1/ABS/ClONO2_jpl97.abs', & + skip_cnt=2,rd_cnt=n,x=x1,y=y1,y1=y2,y2=y3 ) + xsav(1:n) = x1(1:n) + y1(1:n) = y1(1:n) * 1.E-20 + + CALL add_pnts_inter2(x1,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y3,yg3,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r45 + +!=============================================================================* + + SUBROUTINE r46(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for BrONO2 photolysis: =* +!= BrONO2 + hv -> Products =* +!= =* +!= Cross section: JPL 03 recommendation =* +!= Quantum yield: JPL 03 recommendation =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + REAL x1(kdata) + REAL y1(kdata) + +! local + REAL, parameter :: qyld(2) = (/ .15,.85 /) + + REAL :: yg1(kw) + INTEGER :: n + INTEGER :: chnl + + if( initialize ) then + CALL readit + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + chnl = xsqy_tab(j)%channel + xsqy_tab(j)%sq(1:nw-1,1) = qyld(chnl) * yg1(1:nw-1) + endif + + CONTAINS + + SUBROUTINE readit +!** cross sections from JPL03 recommendation + + n = 61 + CALL base_read( filespec='DATAJ1/ABS/BrONO2_jpl03.abs', & + skip_cnt=13,rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.E-20 + + CALL add_pnts_inter2(x1,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r46 + +!=============================================================================* + + SUBROUTINE r47(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for Cl2 photolysis: =* +!= Cl2 + hv -> 2 Cl =* +!= =* +!= Cross section: JPL 97 recommendation =* +!= Quantum yield: 1 (Calvert and Pitts, 1966) =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! local + real :: ex1(nz), ex2(nz) + real :: alpha(kz) + INTEGER iz, iw + + real :: aa, bb, bb2, sig + + if( .not. initialize ) then + call check_alloc( j, nz, nw-1 ) + +! mabs = 1: Finlayson-Pitts and Pitts +! mabs = 2: JPL2011 formula + + DO iz = 1, nz + aa = 402.7/tlev(iz) + bb = exp(aa) + bb2 = bb*bb + alpha(iz) = (bb2 - 1.)/(bb2 + 1.) + ENDDO + +!** quantum yield = 1 (Calvert and Pitts, 1966) + + DO iw = 1, nw-1 + ex1(1:nz) = 27.3 * exp(-99.0 * alpha(1:nz) * (log(329.5/wc(iw)))**2) + ex2(1:nz) = .932 * exp(-91.5 * alpha(1:nz) * (log(406.5/wc(iw)))**2) + xsqy_tab(j)%sq(1:nz,iw) = 1.e-20 * sqrt(alpha(1:nz)) * (ex1(1:nz) + ex2(1:nz)) + ENDDO + endif + + END SUBROUTINE r47 + +!=============================================================================* + + SUBROUTINE r101(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for CH2(OH)CHO =* +!= (glycolaldehye, hydroxy acetaldehyde) photolysis: =* +!= CH2(OH)CHO + hv -> Products =* +!= =* +!= Quantum yield about 50% =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER :: n + REAL x(kdata), y(kdata) + +! local + real, parameter :: qyld(3) = (/ .83, .10, .07 /) + + REAL :: yg(kw) + INTEGER :: chnl + + if( initialize ) then + chnl = xsqy_tab(j)%channel + CALL readit + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * qyld(chnl) + endif + + CONTAINS + + SUBROUTINE readit + + n = 63 + CALL base_read( filespec='DATAJ1/CH2OHCHO/glycolaldehyde_jpl11.abs', & + skip_cnt=2,rd_cnt=n,x=x,y=y ) + y(1:n) = y(1:n) * 1.e-20 + + CALL add_pnts_inter2(x,y,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r101 + +!=============================================================================* + + SUBROUTINE r103(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for CH3COCHCH2 =* +!= Methyl vinyl ketone photolysis: =* +!= CH3COCH=CH2 + hv -> Products =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=150 + + INTEGER i, n + REAL x(kdata), y(kdata) + +! local + REAL, save :: yg(kw) + REAL :: qy(nz) + INTEGER ierr + INTEGER iw + INTEGER mabs + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +! mabs = 1: Schneider and moortgat +! mabs = 2: jpl 2011 +! mabs = 2 + +! quantum yield from +! Gierczak, T., J. B. Burkholder, R. K. Talukdar, A. Mellouki, S. B. Barone, +! and A. R. Ravishankara, Atmospheric fate of methyl vinyl ketone and methacrolein, +! J. Photochem. Photobiol A: Chemistry, 110 1-10, 1997. +! depends on pressure and wavelength, set upper limit to 1.0 + + DO iw = 1, nw - 1 + qy(1:nz) = exp(-0.055*(wc(iw) - 308.)) & + / (5.5 + 9.2e-19*airden(1:nz)) + qy(1:nz) = min(qy(1:nz), 1.) + xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * qy(1:nz) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit + + n = 146 + CALL base_read( filespec='DATAJ1/ABS/MVK_jpl11.abs', & + skip_cnt=2,rd_cnt=n,x=x,y=y ) + y(1:n) = y(1:n) * 1.e-20 + + CALL add_pnts_inter2(x,y,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r103 + +!=============================================================================* + + SUBROUTINE r106(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for CH3CH2ONO2 =* +!= ethyl nitrate photolysis: =* +!= CH3CH2ONO2 + hv -> CH3CH2O + NO2 =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER i, n1, n2 + REAL x1(kdata), y1(kdata) + REAL x2(kdata), y2(kdata) + +! local + INTEGER ierr + INTEGER iw + REAL dum + REAL qy, sig + REAL, save :: yg1(kw), yg2(kw) + real :: t(nz) + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +! quantum yield = 1 + + t(1:nz) = tlev(1:nz) - 298. + DO iw = 1, nw - 1 + xsqy_tab(j)%sq(1:nz,iw) = yg1(iw)*exp(yg2(iw)*t(1:nz)) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit + + integer :: n + real :: wrk(kdata) + character(len=256) :: emsg + + n = 63 + CALL base_read( filespec='DATAJ1/RONO2/RONO2_talukdar.abs', & + skip_cnt=10,rd_cnt=n,x=x1,y=wrk,y1=wrk, & + y2=y1,y3=y2,y4=wrk,y5=wrk ) + + x2(1:n) = x1(1:n) + + n1 = count( y1(1:n) > 0. ) + if( n1 > 0 ) then + wrk(1:n1) = pack( y1(1:n),mask=y1(1:n) > 0. ) + y1(1:n1) = wrk(1:n1) * 1.e-20 + wrk(1:n1) = pack( x1(1:n),mask=y1(1:n) > 0. ) + x1(1:n1) = wrk(1:n1) + CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + else + yg1(:nw) = 0. + endif + + + n2 = count( y2(1:n) > 0. ) + if( n2 > 0 ) then + wrk(1:n2) = pack( y2(1:n),mask=y2(1:n) > 0. ) + y2(1:n2) = wrk(1:n2) * 1.e-3 + wrk(1:n2) = pack( x2(1:n),mask=y2(1:n) > 0. ) + x2(1:n2) = wrk(1:n2) + CALL addpnt(x2,y2,kdata,n2, 0.,y2(1)) + CALL addpnt(x2,y2,kdata,n2, 1.e+38,y2(n2)) + CALL inter2(nw,wl,yg2,n2,x2,y2,ierr) + IF (ierr .NE. 0) THEN + write(emsg,'(''readit: Error '',i5,'' in inter2 for '',a)') ierr,trim(xsqy_tab(j)%label) + call wrf_error_fatal( trim(emsg) ) + ENDIF + else + yg2(:nw) = 0. + endif + + END SUBROUTINE readit + + END SUBROUTINE r106 + +!=============================================================================* + + SUBROUTINE r107(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for CH3CHONO2CH3 =* +!= isopropyl nitrate photolysis: =* +!= CH3CHONO2CH3 + hv -> CH3CHOCH3 + NO2 =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER i, n1, n2 + REAL x1(kdata), y1(kdata) + REAL x2(kdata), y2(kdata) + +! local + INTEGER ierr + INTEGER iw + REAL dum + REAL qy, sig + REAL, save :: yg1(kw), yg2(kw) + real :: t(nz) + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +! quantum yield = 1 + + t(1:nz) = tlev(1:nz) - 298. + DO iw = 1, nw - 1 + xsqy_tab(j)%sq(1:nz,iw) = yg1(iw)*exp(yg2(iw)*t(1:nz)) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit + + integer :: n + real :: wrk(kdata) + character(len=256) :: emsg + + n = 63 + CALL base_read( filespec='DATAJ1/RONO2/RONO2_talukdar.abs', & + skip_cnt=10,rd_cnt=n,x=x1,y=wrk, & + y1=wrk,y2=wrk,y3=wrk,y4=y1,y5=y2 ) + + x2(1:n) = x1(1:n) + + n1 = count( y1(1:n) > 0. ) + if( n1 > 0 ) then + wrk(1:n1) = pack( y1(1:n),mask=y1(1:n) > 0. ) + y1(1:n1) = wrk(1:n1) * 1.e-20 + wrk(1:n1) = pack( x1(1:n),mask=y1(1:n) > 0. ) + x1(1:n1) = wrk(1:n1) + CALL add_pnts_inter2(x1,y1,yg1,kdata,n1, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + else + yg1(:nw) = 0. + endif + + n2 = count( y2(1:n) > 0. ) + if( n2 > 0 ) then + wrk(1:n2) = pack( y2(1:n),mask=y2(1:n) > 0. ) + y2(1:n2) = wrk(1:n2) * 1.e-3 + wrk(1:n2) = pack( x2(1:n),mask=y2(1:n) > 0. ) + x2(1:n2) = wrk(1:n2) + CALL addpnt(x2,y2,kdata,n2, 0.,y2(1)) + CALL addpnt(x2,y2,kdata,n2, 1.e+38,y2(n2)) + CALL inter2(nw,wl,yg2,n2,x2,y2,ierr) + IF (ierr .NE. 0) THEN + write(emsg,'(''readit: Error '',i5,'' in inter2 for '',a)') ierr,trim(xsqy_tab(j)%label) + call wrf_error_fatal( trim(emsg) ) + ENDIF + else + yg2(:nw) = 0. + endif + + END SUBROUTINE readit + + END SUBROUTINE r107 + +!=============================================================================* + + SUBROUTINE r108(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for =* +!= nitroxy ethanol CH2(OH)CH2(ONO2) + hv -> CH2(OH)CH2(O.) + NO2 =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! local +! coefficients from Roberts and Fajer 1989, over 270-306 nm + real, parameter ::a = -2.359E-3 + real, parameter ::b = 1.2478 + real, parameter ::c = -210.4 + + if( initialize ) then + call check_alloc( ndx=j, nz=nw-1, nw=1 ) +! quantum yield = 1 + WHERE( wc(1:nw-1) >= 270. .AND. wc(1:nw-1) <= 306. ) + xsqy_tab(j)%sq(1:nw-1,1) = EXP(c + wc(1:nw-1)*(b + wc(1:nw-1)*a)) + ELSEWHERE + xsqy_tab(j)%sq(1:nw-1,1) = 0. + ENDWHERE + endif + + END SUBROUTINE r108 + +!=============================================================================* + + SUBROUTINE r109(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for =* +!= nitroxy acetone CH3COCH2(ONO2) + hv -> CH3COCH2(O.) + NO2 =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! local +! coefficients from Roberts and Fajer 1989, over 284-335 nm + real, parameter :: a = -1.365E-3 + real, parameter :: b = 0.7834 + real, parameter :: c = -156.8 + + if( initialize ) then + call check_alloc( ndx=j, nz=nw-1, nw=1 ) +! quantum yield = 1 + WHERE( wc(1:nw-1) >= 284. .AND. wc(1:nw-1) <= 335. ) + xsqy_tab(j)%sq(1:nw-1,1) = EXP(c + wc(1:nw-1)*(b + wc(1:nw-1)*a)) + ELSEWHERE + xsqy_tab(j)%sq(1:nw-1,1) = 0. + ENDWHERE + endif + + END SUBROUTINE r109 + +!=============================================================================* + + SUBROUTINE r110(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for =* +!= t-butyl nitrate C(CH3)3(ONO2) + hv -> C(CH3)(O.) + NO2 =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! local +! coefficients from Roberts and Fajer 1989, over 270-330 nm + real, parameter ::a = -0.993E-3 + real, parameter ::b = 0.5307 + real, parameter ::c = -115.5 + + if( initialize ) then + call check_alloc( ndx=j, nz=nw-1, nw=1 ) +! quantum yield = 1 + WHERE( wc(1:nw-1) >= 270. .AND. wc(1:nw-1) <= 330. ) + xsqy_tab(j)%sq(1:nw-1,1) = EXP(c + wc(1:nw-1)*(b + wc(1:nw-1)*a)) + ELSEWHERE + xsqy_tab(j)%sq(1:nw-1,1) = 0. + ENDWHERE + endif + + END SUBROUTINE r110 + +!=============================================================================* + + SUBROUTINE r112(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for hydroxyacetone =* +!= CH2(OH)COCH3 photolysis: =* +!= CH2(OH)COCH3 -> CH3CO + CH2OH +!= -> CH2(OH)CO + CH3 =* +!= =* +!= Cross section from Orlando et al. (1999) =* +!= =* +!= Quantum yield assumed 0.325 for each channel (J. Orlando, priv.comm.2003)=* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER :: n + REAL :: x(kdata), y(kdata) + +! local + REAL, parameter :: qy = .325 + + REAL :: yg(kw) + + if( initialize ) then + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + CALL readit + xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) * qy + endif + + CONTAINS + + SUBROUTINE readit + + n = 96 + CALL base_read( filespec='DATAJ1/ABS/Hydroxyacetone_jpl11.abs', & + skip_cnt=2,rd_cnt=n,x=x,y=y ) + y(1:n) = y(1:n) * 1.e-20 + + CALL add_pnts_inter2(x,y,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r112 + +!=============================================================================* + + SUBROUTINE r113(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for HOBr =* +!= HOBr -> OH + Br =* +!= Cross section from JPL 2003 =* +!= Quantum yield assumed unity as in JPL2003 =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! local + REAL :: sig(nw) + REAL :: xfac1(nw) + INTEGER :: iw + + if( initialize ) then + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + xsqy_tab(j)%sq(1:nw-1,1) = 0. + WHERE( wc(1:nw-1) >= 250. .and. wc(1:nw-1) <= 550. ) + xfac1(1:nw-1) = 1./wc(1:nw-1) + sig(1:nw-1) = 24.77 * exp( -109.80*(LOG(284.01*xfac1(1:nw-1)))**2 ) & + + 12.22 * exp( -93.63*(LOG(350.57*xfac1(1:nw-1)))**2 ) & + + 2.283 * exp(- 242.40*(LOG(457.38*xfac1(1:nw-1)))**2 ) + xsqy_tab(j)%sq(1:nw-1,1) = sig(1:nw-1) * 1.e-20 + ENDWHERE + endif + + END SUBROUTINE r113 + +!=============================================================================* + + SUBROUTINE r114(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for BrO =* +!= BrO -> Br + O =* +!= Cross section from JPL 2003 =* +!= Quantum yield assumed unity as in JPL2003 =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! local + INTEGER :: i, n + REAL :: x(20), y(20) + REAL :: dum + REAL :: yg(kw) + + if( initialize ) then + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + OPEN(UNIT=kin,FILE='DATAJ1/ABS/BrO.jpl03',STATUS='old') + DO i = 1, 14 + READ(kin,*) + ENDDO + n = 15 + DO i = 1, n + READ(kin,*) x(i), dum, y(i) + ENDDO + CLOSE(kin) + + y(1:n) = y(1:n) * 1.e-20 + n = n + 1 + x(n) = dum +! use bin-to-bin interpolation + CALL inter4(nw,wl,yg,n,x,y,1) + xsqy_tab(j)%sq(1:nw-1,1) = yg(1:nw-1) + endif + + END SUBROUTINE r114 + +!=============================================================================* + + SUBROUTINE r118(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= NO3-(aq) photolysis for snow simulations =* +!= a) NO3-(aq) + hv -> NO2 + O- =* +!= b) NO3-(aq) + hv -> NO2- + O(3P) =* +!= Cross section: =* +!= Burley & Johnston, Geophys. Res. Lett., 19, 1359-1362 (1992) =* +!= Chu & Anastasio, J. Phys. Chem. A, 107, 9594-9602 (2003) =* +!= Quantum yield: =* +!= Warneck & Wurzinger, J. Phys. Chem., 92, 6278-6283 (1988) =* +!= Chu & Anastasio, J. Phys. Chem. A, 107, 9594-9602 (2003) =* +!-----------------------------------------------------------------------------* +!= NOTE: user may have to manually add these reactions to the end of the =* +!= reaction list in file usrinp to include these reactions for a snow run: =* +!= T 74 NO3-(aq) -> NO2 + O- =* +!= T 75 NO3-(aq) -> NO2- + O(3P) =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=50 + + REAL x1(kdata),x2(kdata) + REAL y1(kdata),y2(kdata) ! y1 = 20'C, y2 = -20'C + +! local + REAL, parameter :: qyld(2:3) = (/ 1.1e-3,1. /) +! REAL, parameter :: qy2 = 1.1e-3 +! REAL, parameter :: qy3 = 1. + + REAL, save :: yg2(kw) + REAL :: qy1(nz) + INTEGER i, iw, n, idum + integer :: chnl + LOGICAL, save :: is_initialized = .false. + + chnl = xsqy_tab(j)%channel + if( initialize ) then + if( .not. is_initialized ) then + CALL readit + is_initialized = .true. + endif + if( chnl > 1 ) then + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + xsqy_tab(j)%sq(1:nw-1,1) = qyld(chnl)*yg2(1:nw-1) + endif + else + if( chnl == 1 ) then + call check_alloc( j, nz, nw-1 ) + + qy1(1:nz) = exp(-2400./tlev(1:nz) + 3.6) ! Chu & Anastasio, 2003 + DO iw = 1, nw-1 + xsqy_tab(j)%sq(1:nz,iw) = qy1(1:nz)*yg2(iw) + ENDDO + endif + endif + + CONTAINS + + SUBROUTINE readit +!** NO3-(aq) cross sections from Chu and Anastasio 2003: +! convert from molar abs log10 to cm2 per molec + + real :: wrk(kdata) + + n = 43 + CALL base_read( filespec='DATAJ1/ABS/NO3-_CA03.abs', & + skip_cnt=7,rd_cnt=n,x=x1,y=y1,y1=wrk, & + y2=wrk,y3=wrk,y4=wrk ) + y1(1:n) = y1(1:n) * 3.82e-21 + CALL add_pnts_inter2(x1,y1,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r118 + +!=============================================================================* + + SUBROUTINE r119(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide the product (cross section) x (quantum yield) for =* +!= methylethylketone =* +!= CH3COCH2CH3 photolysis: =* +!= CH3COCH2CH3 -> CH3CO + CH2CH3 =* +!= =* +!= Cross section from Martinez et al. (1992) =* +!= =* +!= Quantum yield assumed 0.325 for each channel (J. Orlando, priv.comm.2003)=* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER i, n + REAL x(kdata), y(kdata) + +! local + REAL, save :: yg(kw) + REAL :: ptorr(nz) + REAL :: qy(nz) + INTEGER ierr + INTEGER iw + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +! Quantum Yields from +! Raber, W.H. (1992) PhD Thesis, Johannes Gutenberg-Universitaet, Mainz, Germany. +! other channels assumed negligible (less than 10%). +! Total quantum yield = 0.38 at 760 Torr. +! Stern-Volmer form given: 1/phi = 0.96 + 2.22e-3*P(torr) +! compute local pressure in torr + + ptorr(1:nz) = 760.*airden(1:nz)/2.69e19 + qy(1:nz) = min( 1./(0.96 + 2.22E-3*ptorr(1:nz)),1. ) + DO iw = 1, nw-1 + xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * qy(1:nz) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit + + real :: wrk(kdata) + n = 96 + CALL base_read( filespec='DATAJ1/ABS/Martinez.abs', & + skip_cnt=4,rd_cnt=n,x=x,y=wrk,y1=y, & + y2=wrk,y3=wrk ) + y(1:n) = y(1:n) * 1.e-20 + + CALL add_pnts_inter2(x,y,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r119 + +!=============================================================================* + + SUBROUTINE r120(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for PPN photolysis: =* +!= PPN + hv -> Products =* +!= =* +!= Cross section: from JPL 2006 (originally from Harwood et al. 2003) =* +!= Quantum yield: Assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER :: iw + INTEGER :: n + REAL :: x1(kdata), x2(kdata) + REAL :: y1(kdata), y2(kdata) + +! local + real, parameter :: qyld(2) = (/ 0.61,0.39 /) + + INTEGER :: chnl + REAL, save :: yg(kw), yg2(kw) + real :: t(nz) + REAL :: sig(nz) + LOGICAL, save :: is_initialized = .false. + + if( initialize ) then + if( .not. is_initialized ) then + CALL readit + is_initialized = .true. + endif + else + call check_alloc( j, nz, nw-1 ) + + chnl = xsqy_tab(j)%channel + t(1:nz) = tlev(1:nz) - 298. + DO iw = 1, nw-1 + sig(1:nz) = yg(iw) * EXP(yg2(iw)*t(1:nz)) + xsqy_tab(j)%sq(1:nz,iw) = qyld(chnl) * sig(1:nz) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +! cross section from JPL 2011 (originally from Harwood et al. 2003) + + integer :: nsav + real :: xsav(kdata) + + n = 66 ; nsav = 66 + CALL base_read( filespec='DATAJ1/ABS/PPN_Harwood.txt', & + skip_cnt=10,rd_cnt=n,x=x1,y=y1,y1=y2 ) + y1(1:n) = y1(1:n) * 1.E-20 + y2(1:n) = y2(1:n) * 1E-3 + xsav(1:n) = x1(1:n) + + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r120 + +!=============================================================================* + + SUBROUTINE r122(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CH2=CHCHO =* +!= (acrolein) photolysis: =* +!= CH2=CHCHO + hv -> Products =* +!= =* +!= Cross section: from JPL 2006 (originally from Magneron et al. =* +!= Quantum yield: P-dependent, JPL 2006 orig. from Gardner et al. =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=100 + + INTEGER iw + INTEGER i, n + INTEGER n2 + REAL x1(kdata), x2(kdata) + REAL y1(kdata), y2(kdata) + +! local + REAL, save :: yg(kw) + real :: qy(nz), qym1(nz) + REAL sig + INTEGER ierr + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +! quantum yields are pressure dependent between air number densities +! of 8e17 and 2.6e19, Gardner et al.: + DO iw = 1, nw-1 + where( airden(1:nz) > 2.6e19 ) + qy(1:nz) = 0.004 + elsewhere( airden(1:nz) > 8.e17 .and. airden(1:nz) <= 2.6e19 ) + qym1(1:nz) = 0.086 + 1.613e-17 * airden(1:nz) + qy(1:nz) = 0.004 + 1./qym1(1:nz) + elsewhere( airden(1:nz) <= 8.e17 ) + qym1(1:nz) = 0.086 + 1.613e-17 * 8.e17 + qy(1:nz) = 0.004 + 1./qym1(1:nz) + endwhere + xsqy_tab(j)%sq(1:nz,iw) = qy(1:nz) * yg(iw) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +! cross section from JPL 2006 (originally from Magneron et al.) + + n = 55 + CALL base_read( filespec='DATAJ1/ABS/Acrolein.txt',skip_cnt=6,rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.E-20 + + CALL add_pnts_inter2(x1,y1,yg,kdata,n,nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r122 + +!=============================================================================* + + SUBROUTINE r125(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for ClO photolysis =* +!= ClO + hv -> Cl + O =* +!= =* +!= Cross section: from Maric and Burrows 1999 =* +!= Quantum yield: Assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + + INTEGER, intent(inout) :: j +! data arrays + integer, PARAMETER :: kdata=500 + + INTEGER iw + INTEGER i, n + REAL x1(kdata) + REAL y1(kdata) + INTEGER ierr + +! local + REAL :: yg(kw) + REAL qy1, qy2 + + real, save :: tmp(12) + real, save :: ygt(kw,12) + real x(kdata), y(kdata,12) + real tx, xdum + integer m, nn, ii + real yy + INTEGER m1, m2 + LOGICAL, save :: is_initialized = .false. + + if( initialize ) then + if( .not. is_initialized ) then + CALL readit + tmp(1) = 180. + tmp(2:12) = (/ (190. + 10.*real(m-1),m=2,12) /) + is_initialized = .true. + endif + else + call check_alloc( j, nz, nw-1 ) + + DO i = 1, nz + tx = tlev(i) +! locate temperature indices for interpolation: + m1 = 1 + INT(.1*(tx - 190.)) + m1 = MIN(MAX(1 ,m1),11) + m2 = m1 + 1 + DO iw = 1, nw-1 + yy = ygt(iw,m1) + (ygt(iw,m2) - ygt(iw,m1)) & + * (tx - tmp(m1))/(tmp(m2) - tmp(m1)) +! threshold for O(1D) productionis 263.4 nm: + if(wc(iw) .lt. 263.4) then + qy1 = 1. + else + qy1 = 0. + endif + qy2 = 1. - qy1 + if( xsqy_tab(j)%channel == 1 ) then + xsqy_tab(j)%sq(i,iw) = qy1 * yy + elseif( xsqy_tab(j)%channel == 2 ) then + xsqy_tab(j)%sq(i,iw) = qy2 * yy + endif + ENDDO + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +! cross section from +! Maric D. and J.P. Burrows, J. Quantitative Spectroscopy and +! Radiative Transfer 62, 345-369, 1999. Data was downloaded from +! their web site on 15 September 2009. + + integer :: nsav + real :: xsav(kdata) + + OPEN(UNIT=kin,FILE='DATAJ1/ABS/ClO_spectrum.prn',STATUS='OLD') + DO i = 1, 2 + READ(kin,*) + ENDDO + nn = 453 ; nsav = 453 + DO ii = 1, nn + i = nn - ii + 1 + READ(kin,*) xdum, x(i), xdum, (y(i,m), m = 1, 12) + ENDDO + CLOSE(kin) + + xsav(1:nn) = x(1:nn) + DO m = 1, 12 + nn = nsav + x1(1:nn) = xsav(1:nn) + y1(1:nn) = y(1:nn,m) + CALL add_pnts_inter2(x1,y1,yg,kdata,nn, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + ygt(1:nw-1,m) = yg(1:nw-1) + ENDDO + + END SUBROUTINE readit + + END SUBROUTINE r125 + +!=============================================================================* + + SUBROUTINE r129(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for bromine nitrite =* +!= BrONO -> Br + NO2 =* +!= BrONO -> BrO + NO =* +!= =* +!= Cross section: from IUPAC (vol.3) =* +!= Quantum yield: Assumed to be 0.5 for each channel =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=50 + + INTEGER :: n + INTEGER :: chnl + REAL :: x1(kdata) + REAL :: y1(kdata) + +! local + real, parameter :: qyld(2) = 0.5 + + REAL :: yg(kw) + + if( initialize ) then + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + CALL readit + chnl = xsqy_tab(j)%channel + xsqy_tab(j)%sq(1:nw-1,1) = qyld(chnl) * yg(1:nw-1) + endif + + CONTAINS + + SUBROUTINE readit +! cross section from IUPAC (vol III) 2007 + + n = 32 + CALL base_read( filespec='DATAJ1/ABS/BrONO.abs', & + skip_cnt=8,rd_cnt=n,x=x1,y=y1 ) + + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r129 + +!****************************************************************** + + SUBROUTINE r131(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for +!= NOCl -> NO + Cl =* +!= Cross section: from IUPAC (vol.3) =* +!= Quantum yield: Assumed to be 1 =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=150 + + INTEGER iw + INTEGER i, n, ii + REAL x1(kdata), y1(kdata) + REAL y223(kdata),y243(kdata),y263(kdata),y298(kdata), & + y323(kdata), y343(kdata) + INTEGER ierr + +! local + REAL, save :: yg223(kw),yg243(kw),yg263(kw), & + yg298(kw),yg323(kw), yg343(kw) + REAL qy, sig + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) +! quantum yields assumed unity + DO iw = 1, nw-1 + where( tlev(1:nz) .le. 223. ) + xsqy_tab(j)%sq(1:nz,iw) = yg223(iw) + elsewhere (tlev(1:nz) .gt. 223. .and. tlev(1:nz) .le. 243. ) + xsqy_tab(j)%sq(1:nz,iw) = yg223(iw) & + + (yg243(iw) - yg223(iw))*(tlev(1:nz) - 223.)*.05 + elsewhere (tlev(1:nz) .gt. 243. .and. tlev(1:nz) .le. 263. ) + xsqy_tab(j)%sq(1:nz,iw) = yg243(iw) & + + (yg263(iw) - yg243(iw))*(tlev(1:nz) - 243.)*.05 + elsewhere (tlev(1:nz) .gt. 263. .and. tlev(1:nz) .le. 298. ) + xsqy_tab(j)%sq(1:nz,iw) = yg263(iw) & + + (yg298(iw) - yg263(iw))*(tlev(1:nz) - 263.)/35. + elsewhere (tlev(1:nz) .gt. 298. .and. tlev(1:nz) .le. 323. ) + xsqy_tab(j)%sq(1:nz,iw) = yg298(iw) & + + (yg323(iw) - yg298(iw))*(tlev(1:nz) - 298.)*.04 + elsewhere (tlev(1:nz) .gt. 323. .and. tlev(1:nz) .le. 343. ) + xsqy_tab(j)%sq(1:nz,iw) = yg323(iw) & + + (yg343(iw) - yg323(iw))*(tlev(1:nz) - 323.)*.05 + elsewhere (tlev(1:nz) .gt. 343. ) + xsqy_tab(j)%sq(1:nz,iw) = 0. + endwhere + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +! cross section from IUPAC (vol III) 2007 + + integer :: nsav + real :: xsav(kdata) + + n = 80 + CALL base_read( filespec='DATAJ1/ABS/NOCl.abs', & + skip_cnt=7,rd_cnt=n,x=x1,y=y1 ) + y223(1:n) = y1(1:n) + y243(1:n) = y1(1:n) + y263(1:n) = y1(1:n) + y298(1:n) = y1(1:n) + y323(1:n) = y1(1:n) + y343(1:n) = y1(1:n) + ii = 61 + CALL base_read( filespec='DATAJ1/ABS/NOCl.abs', & + skip_cnt=88,rd_cnt=ii,x=x1(n+1:),y=y223(n+1:), & + y1=y243(n+1:),y2=y263(n+1:),y3=y298(n+1:), & + y4=y323(n+1:),y5=y343(n+1:) ) + + n = n + ii + nsav = n ; xsav(1:n) = x1(1:n) + + CALL add_pnts_inter2(x1,y223,yg223,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y243,yg243,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y263,yg263,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y298,yg298,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y323,yg323,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y343,yg343,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r131 + +!****************************************************************** + + SUBROUTINE r132(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for +!= OClO -> Products =* +!= Cross section: from Wahner et al., J. Phys. Chem. 91, 2734, 1987 =* +!= Quantum yield: Assumed to be 1 =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=2000 + + INTEGER iw + INTEGER i, n + REAL x1(kdata), y1(kdata) + integer nn, n204, n296, n378 + REAL x204(kdata),x296(kdata),x378(kdata) + REAL y204(kdata),y296(kdata),y378(kdata) + + INTEGER ierr + +! local + REAL, save :: yg204(kw),yg296(kw),yg378(kw) + REAL qy, sig + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) +! quantum yields assumed unity + DO iw = 1, nw-1 + where(tlev(1:nz) .le. 204. ) + xsqy_tab(j)%sq(1:nz,iw) = yg204(iw) + elsewhere (tlev(1:nz) .gt. 204. .and. tlev(1:nz) .le. 296. ) + xsqy_tab(j)%sq(1:nz,iw) = yg204(iw) & + + (yg296(iw) - yg204(iw))*(tlev(1:nz) - 204.)/92. + elsewhere (tlev(1:nz) .gt. 296. .and. tlev(1:nz) .le. 378. ) + xsqy_tab(j)%sq(1:nz,iw) = yg296(iw) & + + (yg378(iw) - yg296(iw))*(tlev(1:nz) - 296.)/82. + elsewhere (tlev(1:nz) .gt. 378. ) + xsqy_tab(j)%sq(1:nz,iw) = yg378(iw) + endwhere + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +! cross section from +!A. Wahner, G.S. tyndall, A.R. Ravishankara, J. Phys. Chem., 91, 2734, (1987). +!Supplementary Data, as quoted at: +!http://www.atmosphere.mpg.de/enid/26b4b5172008b02407b2e47f08de2fa1,0/Spectra/Introduction_1rr.html + + OPEN(UNIT=kin,FILE='DATAJ1/ABS/OClO.abs',STATUS='OLD') + DO i = 1, 6 + READ(kin,*) + ENDDO + n204 = 1074-6 + DO i = 1, n204 + READ(kin,*) x204(i), y204(i) + ENDDO + + READ(kin,*) + n296 = 1067 + do i = 1, n296 + read(kin,*) x296(i), y296(i) + enddo + + read(kin,*) + n378 = 1068 + do i = 1, n378 + read(kin,*) x378(i), y378(i) + enddo + + CLOSE(kin) + + CALL add_pnts_inter2(x204,y204,yg204,kdata,n204, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + CALL add_pnts_inter2(x296,y296,yg296,kdata,n296, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + CALL add_pnts_inter2(x378,y378,yg378,kdata,n378, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r132 + +!****************************************************************** + + SUBROUTINE pxCH2O(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= JPL 2011 recommendation. =* +!= Provide product of (cross section) x (quantum yield) for CH2O photolysis =* +!= (a) CH2O + hv -> H + HCO =* +!= (b) CH2O + hv -> H2 + CO =* +!= written by s. madronich march 2013 +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + + integer, PARAMETER :: kdata=200 + +! data arrays + INTEGER iw + INTEGER n, n1, n2 + REAL x1(kdata), x2(kdata) + REAL y298(kdata), tcoef(kdata) + REAL qr(kdata), qm(kdata) + +! local + INTEGER ierr + REAL ak300 + real qyr300, qym300 + REAL, save :: yg1(kw), yg2(kw), yg3(kw), yg4(kw) + REAL :: t(nz), t1(nz) + REAL :: sig(nz) + REAL :: qymt(nz) + REAL :: akt(nz) + LOGICAL, save :: is_initialized = .false. + + if( initialize ) then + if( .not. is_initialized ) then + CALL readit + is_initialized = .true. + endif + else + call check_alloc( j, nz, nw-1 ) + + t(1:nz) = tlev(1:nz) - 298. + t1(1:nz) = (300. - tlev(1:nz))/80. + DO iw = 1, nw - 1 +! correct cross section for temperature dependence: + sig(1:nz) = yg1(iw) + yg2(iw) * t(1:nz) +! assign room temperature quantum yields for radical and molecular channels + qyr300 = yg3(iw) + qym300 = yg4(iw) +! between 330 ande 360 nm, molecular channel is pressure and temperature dependent. + IF (wc(iw) .ge. 330. .and. wc(iw) .lt. 360. .and. qym300 .gt. 0.) then + ak300 = (1. - (qym300+qyr300))/(qym300*(1. - qyr300)) + ak300 = ak300/2.45e19 + akt(1:nz) = ak300 * (1. + 0.05 * (wc(iw) - 329.) * t1(1:nz)) + qymt(1:nz) = 1./(1./(1.-qyr300) + akt(1:nz)*airden(1:nz)) + ELSE + qymt(1:nz) = qym300 + ENDIF + if( xsqy_tab(j)%channel == 1 ) then + xsqy_tab(j)%sq(1:nz,iw) = sig(1:nz) * qyr300 + elseif( xsqy_tab(j)%channel == 2 ) then + xsqy_tab(j)%sq(1:nz,iw) = sig(1:nz) * qymt(1:nz) + endif + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +! read JPL2011 cross section data: + + integer :: nsav + real :: xsav(kdata) + + n = 150 ; nsav = 150 + CALL base_read( filespec='DATAJ1/CH2O/CH2O_jpl11.abs', & + skip_cnt=4,rd_cnt=n,x=x1,y=y298, & + y1=tcoef ) + y298(1:n) = y298(1:n) * 1.e-20 + tcoef(1:n) = tcoef(1:n) * 1.e-24 + xsav(1:n) = x1(1:n) + +! terminate endpoints and interpolate to working grid + CALL add_pnts_inter2(x1,y298,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,tcoef,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + +! quantum yields: Read, terminate, interpolate: + + n = 112 ; nsav = 112 + CALL base_read( filespec='DATAJ1/CH2O/CH2O_jpl11.yld', & + skip_cnt=4,rd_cnt=n,x=x1,y=qr,y1=qm ) + xsav(1:n) = x1(1:n) + + CALL add_pnts_inter2(x1,qr,yg3,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/qr(1),0./)) + + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,qm,yg4,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/qm(1),0./)) + + END SUBROUTINE readit + + END SUBROUTINE pxCH2O + +!=============================================================================* + + SUBROUTINE r140(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for CHCl3 photolysis: =* +!= CHCL3 + hv -> Products =* +!= Cross section: from JPL 2011 recommendation =* +!= Quantum yield: assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=50 + + REAL x1(kdata) + REAL y1(kdata) + +! local +! temperature correction factors: + real, parameter :: b0 = 3.7973 + real, parameter :: b1 = -7.0913e-2 + real, parameter :: b2 = 4.9397e-4 + real, parameter :: b3 = -1.5226e-6 + real, parameter :: b4 = 1.7555e-9 + + INTEGER :: iw, n + REAL, save :: yg(kw) + REAL :: tcoeff + REAL :: w1 + REAL :: sig(nz) + REAL :: temp(nz) + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) + +!** quantum yield assumed to be unity + temp(1:nz) = min(max(tlev(1:nz),210.),300.) - 295. + DO iw = 1, nw-1 +! compute temperature correction coefficients: + tcoeff = 0. + w1 = wc(iw) + IF(w1 > 190. .AND. w1 < 240.) THEN + tcoeff = b0 + w1*(b1 + w1*(b2 + w1*(b3 + w1*b4))) + ENDIF + xsqy_tab(j)%sq(1:nz,iw) = yg(iw) * 10.**(tcoeff*temp(1:nz)) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit + + n = 39 + CALL base_read( filespec='DATAJ1/ABS/CHCl3_jpl11.abs', & + skip_cnt=3,rd_cnt=n,x=x1,y=y1 ) + y1(1:n) = y1(1:n) * 1.E-20 + + CALL add_pnts_inter2(x1,y1,yg,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r140 + +!=============================================================================* + + SUBROUTINE r141(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for C2H5ONO2 =* +!= photolysis: =* +!= C2H5ONO2 + hv -> C2H5O + NO2 =* +!= =* +!= Cross section: IUPAC 2006 (Atkinson et al., ACP, 6, 3625-4055, 2006) =* +!= Quantum yield: Assumed to be unity =* +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata = 50 + + INTEGER :: iw + REAL :: x1(kdata), x2(kdata) + REAL :: y1(kdata), y2(kdata) + +! local + REAL, save :: yg1(kw), yg2(kw) + real :: t(nz) + + if( initialize ) then + CALL readit + else + call check_alloc( j, nz, nw-1 ) +! quantum yield = 1 + t(1:nz) = tlev(1:nz) - 298. + DO iw = 1, nw - 1 + xsqy_tab(j)%sq(1:nz,iw) = yg1(iw) * exp(yg2(iw) * t(1:nz)) + ENDDO + endif + + CONTAINS + + SUBROUTINE readit +! mabs: absorption cross section options: 1: IUPAC 2006 + + integer :: n, nsav + real :: xsav(kdata) + + n = 32 ; nsav = 32 + CALL base_read( filespec='DATAJ1/RONO2/C2H5ONO2_iup2006.abs', & + skip_cnt=4,rd_cnt=n,x=x1,y=y1,y1=y2 ) + y1(1:n) = y1(1:n) * 1.e-20 + y2(1:n) = y2(1:n) * 1.e-3 + xsav(1:n) = x1(1:n) + + CALL add_pnts_inter2(x1,y1,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + n = nsav ; x1(1:n) = xsav(1:n) + CALL add_pnts_inter2(x1,y2,yg2,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r141 + + SUBROUTINE r146(nw,wl,wc,nz,tlev,airden,j) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +!= Provide product (cross section) x (quantum yield) for =* +!= molecular Iodine, I2 =* +!= cross section from JPL2011 =* +!= Quantum yield: wave-dep, from Brewer and Tellinhuisen, 1972 =* +!= Quantum yield for Unimolecular Dissociation of I2 in Visible Absorption =* +!= J. Chem. Phys. 56, 3929-3937, 1972. +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nw + INTEGER, intent(in) :: nz + INTEGER, intent(inout) :: j + REAL, intent(in) :: wl(kw), wc(kw) + REAL, intent(in) :: tlev(kz) + REAL, intent(in) :: airden(kz) + +! data arrays + integer, PARAMETER :: kdata=200 + + INTEGER :: n + REAL :: x(kdata), y(kdata) + +! local + REAL :: yg1(kw), yg2(kw) + + if( initialize ) then + call check_alloc( ndx=j, nz=nw-1, nw=1 ) + CALL readit + xsqy_tab(j)%sq(1:nw-1,1) = yg1(1:nw-1) * yg2(1:nw-1) + endif + + CONTAINS + + SUBROUTINE readit +! cross section from JPL2011 + + n = 104 + CALL base_read( filespec='DATAJ1/ABS/I2_jpl11.abs', & + skip_cnt=2,rd_cnt=n,x=x,y=y ) + y(1:n) = y(1:n) * 1.e-20 + + CALL add_pnts_inter2(x,y,yg1,kdata,n, & + nw,wl,xsqy_tab(j)%label,deltax,(/0.,0./)) + +! quantum yields + + n = 12 + CALL base_read( filespec='DATAJ1/YLD/I2.qy',skip_cnt=4,rd_cnt=n,x=x,y=y ) + + CALL add_pnts_inter2(x,y,yg2,kdata,n,nw,wl,xsqy_tab(j)%label,deltax,(/1.,0./)) + + END SUBROUTINE readit + + END SUBROUTINE r146 + + SUBROUTINE add_pnts_inter2(xin,yin,yout,kdata,n,nw,wl,jlabel,deltax,yends) + + integer, intent(in) :: kdata + integer, intent(in) :: n + integer, intent(in) :: nw + real, intent(in) :: deltax + real, intent(in) :: wl(nw) + real, intent(in) :: xin(kdata) + real, intent(in) :: yin(kdata) + real, intent(in) :: yends(2) + real, intent(inout) :: yout(kdata) + character(len=*), intent(in) :: jlabel + + integer :: ierr, m + real :: xwrk(kdata), ywrk(kdata) + character(len=256) :: emsg + + m = n + xwrk(1:n) = xin(1:n) + ywrk(1:n) = yin(1:n) + CALL addpnt(xwrk,ywrk,kdata,m,xin(1)*(1.-deltax),yends(1)) + CALL addpnt(xwrk,ywrk,kdata,m, 0.,yends(1)) + CALL addpnt(xwrk,ywrk,kdata,m,xin(n)*(1.+deltax),yends(2)) + CALL addpnt(xwrk,ywrk,kdata,m, 1.e+38,yends(2)) + + CALL inter2(nw,wl,yout,m,xwrk,ywrk,ierr) + + IF (ierr /= 0) THEN + write(emsg,'(''add_pnts_inter2: Error '',i5,'' in inter2 for '',a)') ierr,trim(jlabel) + call wrf_error_fatal( trim(emsg) ) + ENDIF + + END SUBROUTINE add_pnts_inter2 + + SUBROUTINE base_read( filespec, skip_cnt, rd_cnt,x, y, y1, y2, y3, y4, y5 ) + + integer, optional, intent(in) :: skip_cnt + integer, intent(inout) :: rd_cnt + real, intent(inout) :: x(:), y(:) + real, optional, intent(inout) :: y1(:), y2(:), y3(:) + real, optional, intent(inout) :: y4(:), y5(:) + character(len=*), intent(in) :: filespec + + integer :: i, idum + integer :: y_to_rd + integer :: ios, err_cnt + character(len=256) :: emsg + + y_to_rd = 1 + if( present(y5) ) y_to_rd = y_to_rd + 1 + if( present(y4) ) y_to_rd = y_to_rd + 1 + if( present(y3) ) y_to_rd = y_to_rd + 1 + if( present(y2) ) y_to_rd = y_to_rd + 1 + if( present(y1) ) y_to_rd = y_to_rd + 1 + + OPEN(UNIT=kin,FILE=trim(filespec),STATUS='old',IOSTAT=ios) + IF( ios /= 0 ) then + write(emsg,'(''base_read: failed to open '',a)') trim(filespec) + call wrf_error_fatal( trim(emsg) ) + ENDIF + + if( present(skip_cnt) ) then + DO i = 1, skip_cnt + READ(kin,*,IOSTAT=ios) + IF( ios /= 0 ) exit + END DO + else + READ(kin,*,IOSTAT=ios) idum,rd_cnt + IF( ios == 0 ) then + DO i = 1, idum-2 + READ(kin,*,IOSTAT=ios) + IF( ios /= 0 ) exit + ENDDO + ENDIF + endif + + IF( ios /= 0 ) then + write(emsg,'(''base_read: failed to read '',a)') trim(filespec) + call wrf_error_fatal( trim(emsg) ) + ENDIF + + select case( y_to_rd ) + case( 1 ) + DO i = 1, rd_cnt + READ(kin,*,IOSTAT=ios) x(i), y(i) + IF( ios /= 0 ) exit + END DO + case( 2 ) + DO i = 1, rd_cnt + READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i) + IF( ios /= 0 ) exit + END DO + case( 3 ) + DO i = 1, rd_cnt + READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i), y2(i) + IF( ios /= 0 ) exit + END DO + case( 4 ) + DO i = 1, rd_cnt + READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i), y2(i), y3(i) + IF( ios /= 0 ) exit + END DO + case( 5 ) + DO i = 1, rd_cnt + READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i), y2(i), y3(i),y4(i) + IF( ios /= 0 ) exit + END DO + case( 6 ) + DO i = 1, rd_cnt + READ(kin,*,IOSTAT=ios) x(i), y(i), y1(i), y2(i), y3(i),y4(i),y5(i) + IF( ios /= 0 ) exit + END DO + end select + + CLOSE (kin) + + IF( ios /= 0 ) then + write(emsg,'(''base_read: failed to read '',a)') trim(filespec) + call wrf_error_fatal( trim(emsg) ) + ENDIF + + END SUBROUTINE base_read + + SUBROUTINE fo3qy2(nz, w, t, qyld) +!-----------------------------------------------------------------------------* +!= PURPOSE: =* +! function to calculate the quantum yield O3 + hv -> O(1D) + O2, =* +! according to: +! Matsumi, Y., F. J. Comes, G. Hancock, A. Hofzumanhays, A. J. Hynes, +! M. Kawasaki, and A. R. Ravishankara, QUantum yields for production of O(1D) +! in the ultraviolet photolysis of ozone: Recommendation based on evaluation +! of laboratory data, J. Geophys. Res., 107, 10.1029/2001JD000510, 2002. +!-----------------------------------------------------------------------------* + + INTEGER, intent(in) :: nz + REAL, intent(in) :: w + REAL, intent(in) :: t(:) + REAL, intent(inout) :: qyld(:) + + REAL, parameter :: A(3) = (/ 0.8036, 8.9061, 0.1192/) + REAL, parameter :: X(3) = (/ 304.225, 314.957, 310.737/) + REAL, parameter :: om(3) = (/ 5.576, 6.601, 2.187/) + + REAL, parameter :: q1 = 1. + + REAL :: kt(nz) + REAL :: q2(nz), qdiv(nz) + + + kT(1:nz) = 0.695 * t(1:nz) + q2(1:nz) = exp(-825.518/kT(1:nz)) + + kT(1:nz) = t(1:nz)/300. + qdiv(1:nz) = 1/(q1 + q2(1:nz)) + + IF(w .LE. 305.) THEN + qyld(1:nz) = 0.90 + ELSEIF(w .GT. 305. .AND. w .LE. 328.) THEN + qyld(1:nz) = 0.0765 + a(1)*q1*qdiv(1:nz)*EXP(-((x(1) - w)/om(1))**4) & + + kT(1:nz)*(a(2)*kT(1:nz)*q2*qdiv(1:nz)*EXP(-((x(2) - w)/om(2))**2) & + + a(3)*sqrt(kT(1:nz))*EXP(-((x(3) - w)/om(3))**2)) + ELSEIF(w .GT. 328. .AND. w .LE. 340.) THEN + qyld(1:nz) = 0.08 + ELSEIF(w .GT. 340.) THEN + qyld(1:nz) = 0. + ENDIF + + END SUBROUTINE fo3qy2 + + SUBROUTINE qyacet(nz, w, T, M, fac) +! This file contains subroutines used for calculation of quantum yields for +! various photoreactions: +! qyacet - q.y. for acetone, based on Blitz et al. (2004) + +! Compute acetone quantum yields according to the parameterization of: +! Blitz, M. A., D. E. Heard, M. J. Pilling, S. R. Arnold, and M. P. Chipperfield +! (2004), Pressure and temperature-dependent quantum yields for the +! photodissociation of acetone between 279 and 327.5 nm, Geophys. +! Res. Lett., 31, L06111, doi:10.1029/2003GL018793. + + IMPLICIT NONE + +! input: +! w = wavelength, nm +! T = temperature, K +! m = air number density, molec. cm-3 + + INTEGER, intent(in) :: nz + REAL, intent(in) :: w + REAL, intent(in) :: T(:), M(:) + REAL, intent(inout) :: fac(:) + +! internal: + + REAL :: wfac + REAL :: a0(nz), a1(nz), a2(nz), a3(nz), a4(nz) + REAL :: b0(nz), b1(nz), b2(nz), b3(nz), b4(nz) + REAL :: c3(nz) + REAL :: cA0(nz), cA1(nz), cA2(nz), cA3(nz), cA4(nz) + real :: dumexp(nz) + +! fac = quantum yield for product CH3CO (acetyl radical) + + REAL :: fco(nz) + REAL :: tfac(nz) + +!** set out-of-range values: +! use low pressure limits for shorter wavelengths +! set to zero beyound 327.5 + + IF(w .LT. 279.) THEN + fac(1:nz) = 0.95 + ELSEIF(w .GT. 327.) THEN + fac(1:nz) = 0. + ELSE + wfac = 1.e7/w +!** CO (carbon monoxide) quantum yields: + tfac(1:nz) = t(1:nz)/295. + a0(1:nz) = 0.350 * tfac(1:nz)**(-1.28) + b0(1:nz) = 0.068 * tfac(1:nz)**(-2.65) +!*SM: prevent exponent overflow in rare cases: + + dumexp(1:nz) = b0(1:nz)*(w - 248.) + where( dumexp(1:nz) > 80. ) + cA0(1:nz) = 5.e34 + elsewhere + cA0(1:nz) = exp(dumexp(1:nz)) * a0(1:nz) / (1. - a0(1:nz)) + endwhere + + fco(1:nz) = 1. / (1. + cA0(1:nz)) + +!** CH3CO (acetyl radical) quantum yields: + + IF(w >= 279. .AND. w < 302.) THEN + a1(1:nz) = 1.600E-19 * tfac(1:nz)**(-2.38) + b1(1:nz) = 0.55E-3 * tfac(1:nz)**(-3.19) + cA1(1:nz) = a1(1:nz) * EXP(-b1(1:nz)*(wfac - 33113.)) + fac(1:nz) = (1. - fco(1:nz)) / (1. + cA1(1:nz) * M(1:nz)) + ELSEIF(w >= 302. .AND. w <= 327.) THEN + a2(1:nz) = 1.62E-17 * tfac(1:nz)**(-10.03) + b2(1:nz) = 1.79E-3 * tfac(1:nz)**(-1.364) + cA2(1:nz) = a2(1:nz) * EXP(-b2(1:nz)*(wfac - 30488.)) + + a3(1:nz) = 26.29 * tfac(1:nz)**(-6.59) + b3(1:nz) = 5.72E-7 * tfac(1:nz)**(-2.93) + c3(1:nz) = 30006. * tfac(1:nz)**(-0.064) + ca3(1:nz) = a3(1:nz) * EXP(-b3(1:nz)*((1.e7/w) - c3(1:nz))**2) + + a4(1:nz) = 1.67E-15 * tfac(1:nz)**(-7.25) + b4(1:nz) = 2.08E-3 * tfac(1:nz)**(-1.16) + cA4(1:nz) = a4(1:nz) * EXP(-b4(1:nz)*(wfac - 30488.)) + + fac(1:nz) = (1. - fco(1:nz)) * (1. + cA3(1:nz) + cA4(1:nz) * M(1:nz)) & + / ((1. + cA3(1:nz) + cA2(1:nz) * M(1:nz)) * (1. + cA4(1:nz) * M(1:nz))) + ENDIF + ENDIF + + END SUBROUTINE qyacet + + SUBROUTINE diagnostics + + integer :: m, n, n1 + + open( unit=44,file='TUV.diags') + + write(44,*) 'Photolysis diags' + write(44,*) ' ' + write(44,'(i3,'' Total photorates'')') npht_tab + write(44,*) ' ' + do m = 2,npht_tab + write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) + enddo + write(44,*) ' ' + write(44,'(''Wrf labels'')') + write(44,*) ' ' + do m = 2,npht_tab + write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%wrf_label) + enddo + + write(44,*) ' ' + write(44,'(i3,'' Photorate(s) with no p,temp dependence'')') & + count(xsqy_tab(2:npht_tab)%tpflag == 0) + write(44,*) ' ' + do m = 2,npht_tab + if( xsqy_tab(m)%tpflag == 0 ) then + write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) + endif + enddo + + write(44,*) ' ' + write(44,'(i3,'' Photorate(s) with temp dependence'')') & + count(xsqy_tab(2:npht_tab)%tpflag == 1) + write(44,*) ' ' + do m = 2,npht_tab + if( xsqy_tab(m)%tpflag == 1 ) then + write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) + endif + enddo + + write(44,*) ' ' + write(44,'(i3,'' Photorate(s) with press dependence'')') & + count(xsqy_tab(2:npht_tab)%tpflag == 2) + write(44,*) ' ' + do m = 2,npht_tab + if( xsqy_tab(m)%tpflag == 2 ) then + write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) + endif + enddo + + write(44,*) ' ' + write(44,'(i3,'' Photorate(s) with temp,press dependence'')') & + count(xsqy_tab(2:npht_tab)%tpflag == 3) + write(44,*) ' ' + do m = 2,npht_tab + if( xsqy_tab(m)%tpflag == 3 ) then + write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) + endif + enddo + + write(44,*) ' ' + write(44,'(i3,'' Photorate(s) with second channel'')') & + count(xsqy_tab(2:npht_tab)%channel == 2) + write(44,*) ' ' + do m = 2,npht_tab + if( xsqy_tab(m)%channel == 2 ) then + write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) + endif + enddo + + write(44,*) ' ' + write(44,'(i3,'' Photorate(s) with third channel'')') & + count(xsqy_tab(2:npht_tab)%channel == 3) + write(44,*) ' ' + do m = 2,npht_tab + if( xsqy_tab(m)%channel == 3 ) then + write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) + endif + enddo + + write(44,*) ' ' + write(44,'(i3,'' Photorate(s) with multiple input files'')') & + count(xsqy_tab(2:npht_tab)%filespec%nfiles > 1) + write(44,*) ' ' + do m = 2,npht_tab + if( xsqy_tab(m)%filespec%nfiles > 1 ) then + write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) + endif + enddo + + write(44,*) ' ' + write(44,'('' Photorate(s) with skip == -1'')') + write(44,*) ' ' + do m = 2,npht_tab + n = xsqy_tab(m)%filespec%nfiles + do n1 = 1,n + if( xsqy_tab(m)%filespec%nskip(n1) == -1 ) then + write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) + endif + enddo + enddo + + write(44,*) ' ' + write(44,'('' Photorate(s) with skip >= 0'')') + write(44,*) ' ' + do m = 2,npht_tab + n = xsqy_tab(m)%filespec%nfiles + do n1 = 1,n + if( xsqy_tab(m)%filespec%nskip(n1) >= 0 .and. & + xsqy_tab(m)%filespec%filename(n1) /= ' ' ) then + write(44,'(i3,2x,a)') m,trim(xsqy_tab(m)%label) + endif + enddo + enddo + + write(44,*) ' ' + write(44,'('' Photorate(s) with xfac /= 1.e-20'')') + write(44,*) ' ' + do m = 2,npht_tab + n = xsqy_tab(m)%filespec%nfiles + do n1 = 1,n + if( xsqy_tab(m)%filespec%xfac(n1) /= 1.e-20 ) then + write(44,'(i3,2x,a,1pg15.7)') & + m,trim(xsqy_tab(m)%label),xsqy_tab(m)%filespec%xfac(n1) + endif + enddo + enddo + + write(44,*) ' ' + write(44,'('' Filenames'')') + write(44,*) ' ' + do m = 2,npht_tab + n = xsqy_tab(m)%filespec%nfiles + do n1 = 1,n + if( xsqy_tab(m)%filespec%filename(n1) /= ' ' ) then + write(44,'(i3,2x,a,3x,i4,3x,i4)') & + m,trim(xsqy_tab(m)%filespec%filename(n1)), & + xsqy_tab(m)%filespec%nskip(n1), & + xsqy_tab(m)%filespec%nread(n1) + endif + enddo + enddo + + close( 44 ) + + END SUBROUTINE diagnostics + + INTEGER FUNCTION get_xsqy_tab_ndx( jlabel,wrf_label ) + + character(len=*), optional, intent(in) :: jlabel + character(len=*), optional, intent(in) :: wrf_label + + integer :: m + + get_xsqy_tab_ndx = -1 + + if( present(jlabel) ) then + do m = 2,npht_tab + if( trim(jlabel) == trim(xsqy_tab(m)%label) ) then + get_xsqy_tab_ndx = m + exit + endif + enddo + elseif( present(wrf_label) ) then + do m = 2,npht_tab + if( trim(wrf_label) == trim(xsqy_tab(m)%wrf_label) ) then + get_xsqy_tab_ndx = m + exit + endif + enddo + endif + + + END FUNCTION get_xsqy_tab_ndx + + SUBROUTINE check_alloc( ndx, nz, nw ) + + integer, intent(in) :: ndx + integer, intent(in) :: nz + integer, intent(in) :: nw + + integer :: astat + character(len=256) :: emsg + + if( .not. allocated(xsqy_tab(ndx)%sq) ) then + allocate( xsqy_tab(ndx)%sq(nz,nw),stat=astat ) + elseif( size(xsqy_tab(ndx)%sq,dim=1) /= nz ) then + deallocate( xsqy_tab(ndx)%sq ) + allocate( xsqy_tab(ndx)%sq(nz,nw),stat=astat ) + else + astat = 0 + endif + + if( astat /= 0 ) then + write(emsg,'(''check_alloc: failed to alloc sq; error = '',i4)') astat + call wrf_error_fatal( trim(emsg) ) + endif + + END SUBROUTINE check_alloc + + end module module_rxn diff --git a/wrfv2_fire/clean b/wrfv2_fire/clean index ada8356f..600d200f 100755 --- a/wrfv2_fire/clean +++ b/wrfv2_fire/clean @@ -48,7 +48,7 @@ if ( "$arg" == '-a' || "$arg" == '-aa' ) then endif if ( "$arg" != '-aa' ) then ( cd run ; /bin/rm -f gm* out* fort* ideal* *.exe input_sounding ; \ - /bin/cp -f namelist.input namelist.input.backup ; \ + /bin/cp -f namelist.input namelist.input.backup.`date +%Y-%m-%d_%H_%M_%S` ; \ /bin/rm -f namelist.input ) >& /dev/null ( cd test/exp_real ; /bin/rm -f gm* out* fort* real* ) ( cd test ; rm -f */*.exe */ETAMPNEW_DATA* */GENPARM.TBL */LANDUSE.TBL */README.namelist \ @@ -61,13 +61,13 @@ if ( "$arg" == '-a' || "$arg" == '-aa' ) then */ozone.formatted */ozone_lat.formatted */ozone_plev.formatted \ */aerosol.formatted */aerosol_lat.formatted */aerosol_plev.formatted */aerosol_lon.formatted \ */kernels.asc_s_0_03_0_9 */bulkradii.asc_s_0_03_0_9 */bulkdens.asc_s_0_03_0_9 \ - */constants.asc \ + */constants.asc */p3_lookup_table_1.dat \ */masses.asc */kernels_z.asc */capacity.asc */termvels.asc */coeff_p.asc */coeff_q.asc \ */gribmap.txt */tr??t?? */co2_trans */namelist.output ) >& /dev/null else if ( "$arg" == '-aa' ) then /bin/rm -f configure.wrf.backup /bin/rm -f Registry/Registry.backup - /bin/rm -f run/namelist.input.backup + /bin/rm -f run/namelist.input.backup.* endif endif diff --git a/wrfv2_fire/compile b/wrfv2_fire/compile index 75e18935..f701610d 100755 --- a/wrfv2_fire/compile +++ b/wrfv2_fire/compile @@ -145,6 +145,14 @@ else if ( ! $?DA_ARCHFLAGS ) setenv DA_ARCHFLAGS "" + if ( ( $WRF_CHEM == 1 ) && ( $WRF_DA_CORE == 1 ) ) then + echo " " + echo "WRFDA can not be compiled with WRF_CHEM=1" + echo "unset the WRF_CHEM env variable." + echo " " + exit + endif + if ( ( $WRF_DA_CORE == 1 ) && ( ! -d var ) ) then echo " " echo "You need to download and untar the Var code, or" @@ -295,31 +303,50 @@ else endif setenv BUFR 1 - setenv CRTM 1 - if ( $?CRTM ) then + set CRTM = ( `grep "\-DCRTM" configure.wrf | sed -e 's/\\//g' | sed 's/-//g' ` ) + if ( $CRTM != "" ) then + echo " " + echo "Will compile with CRTM library" + echo " " if ( ! $?BUFR ) then echo " " - echo "BUFR library will be compiled for radiance data ingest." + echo "BUFR library is needed for radiance data ingest." + echo "setting BUFR=1" echo " " + setenv BUFR 1 endif setenv CRTM_CPP "-DCRTM" - setenv CRTM_LIB "-L../external/crtm_2.1.3/libsrc -lCRTM" - setenv CRTM_SRC "-I../external/crtm_2.1.3/libsrc" - setenv SFC_CRTM `grep '^SFC' configure.wrf | awk '{print $3}' | sed -e 's/\// /g' | awk '{print $NF}'` - setenv ABI_CRTM `grep '^SFC' configure.wrf | sed -n 's/.*\(\-m[0-9]\{2\}\).*/\1/p'` + setenv CRTM_LIB "-L../external/crtm_2.2.3/libsrc -lCRTM" + setenv CRTM_SRC "-I../external/crtm_2.2.3/libsrc" + #setenv SFC_CRTM `grep '^SFC' configure.wrf | awk '{print $3}' | sed -e 's/\// /g' | awk '{print $NF}'` + #setenv ABI_CRTM `grep '^SFC' configure.wrf | sed -n 's/.*\(\-m[0-9]\{2\}\).*/\1/p'` + setenv CRTM 1 else + echo " " + echo "Compiling WRFDA without CRTM library" + echo " " setenv CRTM_CPP " " setenv CRTM_LIB " " setenv CRTM_SRC " " + setenv CRTM 0 endif - if ( $?RTTOV ) then + set RTTOV = ( `grep "^RTTOVPATH" configure.wrf | cut -d"=" -f2-` ) + if ( $RTTOV == "" ) then + setenv RTTOV_LIB " " + setenv RTTOV_SRC " " + unsetenv RTTOV + else + echo " " + echo "Compiling with RTTOV libraries in:" + echo $RTTOV + echo " " if ( ! $?BUFR ) then echo " " echo "BUFR library is needed for radiance data ingest." + echo "setting BUFR=1" echo " " setenv BUFR 1 endif - setenv RTTOV_CPP "-DRTTOV" if ( -e ${RTTOV}/lib/librttov11.1.0_main.a ) then setenv RTTOV_LIB "-L${RTTOV}/lib -lrttov11.1.0_coef_io -lrttov11.1.0_emis_atlas -lrttov11.1.0_main" else if ( -e ${RTTOV}/lib/librttov11.2.0_main.a ) then @@ -333,16 +360,16 @@ else exit 1 endif setenv RTTOV_SRC "-I${RTTOV}/include -I${RTTOV}/mod" - else - setenv RTTOV_CPP " " - setenv RTTOV_LIB " " - setenv RTTOV_SRC " " endif set hdf5path = ( `grep "^HDF5PATH" configure.wrf | cut -d"=" -f2-` ) if ( $hdf5path == "" ) then setenv HDF5_INC "" unsetenv HDF5 else + echo " " + echo "Compiling with HDF5 libraries in:" + echo $hdf5path + echo " " setenv HDF5_INC "-I${hdf5path}/include" setenv HDF5 1 endif diff --git a/wrfv2_fire/configure b/wrfv2_fire/configure index 5aaaaa39..97901f69 100755 --- a/wrfv2_fire/configure +++ b/wrfv2_fire/configure @@ -7,10 +7,14 @@ thiscmd=$0 FORTRAN_COMPILER_TIMER="" opt_level="-f" rword="-r4" +vnest="NOVN" +hyb="NOHYB" print_usage="" chemistry="" wrf_core="" +config_line="$0 " while [ $# -ge 1 ]; do + config_line="$config_line $1" case $1 in -d) opt_level="-d" ;; -D) opt_level="-D" ;; @@ -18,10 +22,12 @@ while [ $# -ge 1 ]; do -f) opt_level="-f" ;; -h) print_usage="yes" ;; -help) print_usage="yes" ;; + -hyb) hyb="HYB" ;; -os) shift ; WRF_OS=$1 ;; -mach) shift ; WRF_MACH=$1 ;; -r8) rword="-r8" ;; -time) shift ; FORTRAN_COMPILER_TIMER=$1 ;; + -vn) vnest="VN" ;; chem) WRF_CHEM=1 ;; kpp) WRF_KPP=1 ;; radardfi) WRF_DFI_RADAR=1 ;; @@ -44,6 +50,7 @@ if [ -n "$print_usage" ] ; then echo '-d build with debugging information and no optimization' echo '-D build with -d AND floating traps, traceback, uninitialized variables' echo '-r8 build with 8 byte reals' + echo '-hyb build with hybrid vertical coordinate (HVC) for ARW only' echo '-help print this message' echo '*****************************************************************************' echo ' ' @@ -401,6 +408,35 @@ else echo "PHDF5 not set in environment. Will configure WRF for use without." fi +if [ "$wrf_core" = "DA_CORE" -o "$wrf_core" = "4D_DA_CORE" ] ; then + if [ -n "$RTTOV" ] ; then + echo "Will use RTTOV in dir: $RTTOV" + else + echo "RTTOV not set in environment. Will configure WRFDA for use without." + fi +fi + +# For the hybrid build, stay away from NMM and DA; Vertical nesting is +# a problem for ARW + +if [ -n "$WRF_NMM_CORE" -a "$WRF_NMM_CORE" = "1" ] ; then + TFL="-traditional-cpp" + CFL="-P -nostdinc" +elif [ "$wrf_core" = "DA_CORE" -o "$wrf_core" = "4D_DA_CORE" ] ; then + TFL="-traditional-cpp" + CFL="-P -nostdinc" +elif [ "$vnest" = "VN" ] ; then + TFL="-traditional-cpp" + CFL="-P -nostdinc" +elif [ "$hyb" = "NOHYB" ] ; then + TFL="-traditional-cpp" + CFL="-P -nostdinc" +else + TFL=" " + CFL="-P -C -nostdinc" + compileflags="${compileflags}!-DHYBRID_COORD=1" +fi + if [ "$wrf_core" = "4D_DA_CORE" ]; then if [ -n "$WRFPLUS_DIR" ] ; then echo "Will use WRFPLUS in dir: $WRFPLUS_DIR" @@ -597,7 +633,7 @@ if test -n "$PERL" ; then $PERL arch/Config_new.pl -dmparallel=$COMMLIB -ompparallel=$OMP -perl=$PERL \ -netcdf=$NETCDF -pnetcdf=$PNETCDF -hdf5=$HDF5 -phdf5=$PHDF5 -os=$os -mach=$mach -ldflags=$ldflags \ -compileflags=$compileflags -opt_level=$opt_level -USENETCDFF=$USENETCDFF -USENETCDF=$USENETCDF \ - -time=$FORTRAN_COMPILER_TIMER \ + -time=$FORTRAN_COMPILER_TIMER -tfl="$TFL" -cfl="$CFL" -config_line="$config_line" \ -wrf_core=$wrf_core -gpfs=$GPFS_PATH -curl=$CURL_PATH -dep_lib_path="$DEP_LIB_PATH" if test ! -f configure.wrf ; then echo "configure.wrf not created! Exiting configure script..." @@ -616,7 +652,8 @@ if test -n "$PERL" ; then if [ "$rword" = "-r8" ] ; then srch=`grep -i "^SFC" configure.wrf | grep -i "gfortran"` if [ -n "$srch" ] ; then - sed -e '/^PROMOTION/s/#//' configure.wrf > configure.wrf.edit + sed -e '/^PROMOTION/s/#//' \ + -e '/^RWORDSIZE/s/$(NATIVE_RWORDSIZE)/8/' configure.wrf > configure.wrf.edit else sed -e '/^RWORDSIZE/s/$(NATIVE_RWORDSIZE)/8/' configure.wrf > configure.wrf.edit fi @@ -721,10 +758,10 @@ if test -n "$NETCDF" ; then fi grep nf_format_64bit $NETCDF/include/netcdf.inc > /dev/null configure_aaaa=$? ; export configure_aaaa - if [ $configure_aaaa -a -z "$WRFIO_NCD_LARGE_FILE_SUPPORT" ] ; then + if [ $configure_aaaa -a -z "$WRFIO_NCD_NO_LARGE_FILE_SUPPORT" ] ; then echo "NetCDF users note:" - echo " This installation of NetCDF supports large file support. To enable large file" - echo " support in NetCDF, set the environment variable WRFIO_NCD_LARGE_FILE_SUPPORT" + echo " This installation of NetCDF supports large file support. To DISABLE large file" + echo " support in NetCDF, set the environment variable WRFIO_NCD_NO_LARGE_FILE_SUPPORT" echo " to 1 and run configure again. Set to any other value to avoid this message." fi fi @@ -1035,6 +1072,27 @@ if [ $retval -ne 0 ] ; then fi fi +# testing for Fortran 2008 intrinsic gamma function +make fortran_2008_gamma_test > tools/fortran_2008_gamma.log 2>&1 +rm -f tools/fortran_2008_gamma.log +retval=-1 +if [ -f tools/fortran_2008_gamma_test.exe ] ; then + retval=0 +fi +if [ $retval -ne 0 ] ; then + sed -e '/^ARCH_LOCAL/s/$/ -DNO_GAMMA_SUPPORT/' configure.wrf > configure.wrf.edit + mv configure.wrf.edit configure.wrf + echo " " + echo " " + echo "************************** W A R N I N G ************************************" + echo " " + echo "There are some Fortran 2008 features in WRF that your compiler does not recognize" + echo "The intrinsic gamma function is not available, required by some schemes." + echo "That code is stubbbed out, and those schemes are unavailable at run-time." + echo " " + echo "*****************************************************************************" +fi + # testing for netcdf4 IO features if [ -n "$NETCDF4" ] ; then if [ $NETCDF4 -eq 1 ] ; then diff --git a/wrfv2_fire/dyn_em/adapt_timestep_em.F b/wrfv2_fire/dyn_em/adapt_timestep_em.F index ea7c3a85..96d8f7e4 100644 --- a/wrfv2_fire/dyn_em/adapt_timestep_em.F +++ b/wrfv2_fire/dyn_em/adapt_timestep_em.F @@ -123,7 +123,12 @@ RECURSIVE SUBROUTINE adapt_timestep(grid, config_flags) ! ! Else, calculate the time step based on cfl. ! - if ( ( domain_get_advanceCount ( grid ) .EQ. 1 ) .AND. ( .NOT. config_flags%restart ) ) then + !BPR BEGIN + !At the initial time advanceCount == 0, but the following line instead looked + !for advanceCount == 1 + !if ( ( domain_get_advanceCount ( grid ) .EQ. 1 ) .AND. ( .NOT. config_flags%restart ) ) then + if ( ( domain_get_advanceCount ( grid ) .EQ. 0 ) .AND. ( .NOT. config_flags%restart ) ) then + !BPR END if ( grid%starting_time_step_den .EQ. 0 ) then CALL WRFU_TimeIntervalSet(dtInterval, Sn=grid%starting_time_step, Sd=1) else @@ -471,6 +476,15 @@ SUBROUTINE calc_dt(dtInterval, max_cfl, max_increase_factor, precision, & ! factor = ( target_cfl - 0.5 * (max_cfl - target_cfl) ) / max_cfl + + ! BPR BEGIN + ! Factor can be negative in some cases so prevent factor from being + ! lower than 0.1 + ! Otherwise model crashes can occur in normalize_basetime noting that + ! denominator of seconds cannot be negative + factor = MAX(0.1,factor) + ! BPR END + num = INT(factor * precision + 0.5) den = precision diff --git a/wrfv2_fire/dyn_em/couple_or_uncouple_em.F b/wrfv2_fire/dyn_em/couple_or_uncouple_em.F index 4af40a07..4fd6c320 100644 --- a/wrfv2_fire/dyn_em/couple_or_uncouple_em.F +++ b/wrfv2_fire/dyn_em/couple_or_uncouple_em.F @@ -1,3 +1,18 @@ +! sed -e "s/grid%mu/gridmu/g" -e "s/grid%Mu/gridMu/g" couple_or_uncouple_em.F | cpp -DHYBRID_COORD | sed -e "s/gridmu/grid%mu/g" -e "s/gridMu/grid%Mu/g" >> couple_or_uncouple_em.next +#if ( HYBRID_COORD==1 ) +# define gridmu_2(...) (grid%c1h(k)*XXPC2HXX(__VA_ARGS__)) +# define XXPC2HXX(...) grid%mu_2(__VA_ARGS__) + +# define gridmub(...) (grid%c1h(k)*XXPCBHXX(__VA_ARGS__)+grid%c2h(k)) +# define XXPCBHXX(...) grid%mub(__VA_ARGS__) + +# define gridMu_2(...) (grid%c1f(k)*XXPC2FXX(__VA_ARGS__)) +# define XXPC2FXX(...) grid%Mu_2(__VA_ARGS__) + +# define gridMub(...) (grid%c1f(k)*XXPCBFXX(__VA_ARGS__)+grid%c2f(k)) +# define XXPCBFXX(...) grid%Mub(__VA_ARGS__) +#endif + !WRF:MEDIATION_LAYER:couple_uncouple_utility SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & @@ -51,7 +66,7 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & INTEGER :: num_3d_c, num_3d_m, num_3d_s REAL :: mu_factor - REAL, DIMENSION(grid%sm31:grid%em31,grid%sm33:grid%em33) :: mut_2, muut_2, muvt_2, muwt_2 + REAL, DIMENSION(grid%sm31:grid%em31,grid%sm32:grid%em32,grid%sm33:grid%em33) :: mutf_2, muth_2, muut_2, muvt_2, muwt_2 ! De-reference dimension information stored in the grid data structure. IF ( .NOT. grid%active_this_task ) RETURN @@ -117,9 +132,19 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & ! write(6,*) ' coupling: setting mu arrays ' DO j = max(jds,jps),min(jde-1,jpe) + DO k = kps,kpe DO i = max(ids,ips),min(ide-1,ipe) - mut_2(i,j) = grid%mub(i,j) + grid%mu_2(i,j) - muwt_2(i,j) = (grid%mub(i,j) + grid%mu_2(i,j))/grid%msfty(i,j) ! w coupled with y + mutf_2(i,k,j) = grid%Mub(i,j) + grid%Mu_2(i,j) + muwt_2(i,k,j) = (grid%Mub(i,j) + grid%Mu_2(i,j))/grid%msfty(i,j) ! w coupled with y + ENDDO + ENDDO + ENDDO + + DO j = max(jds,jps),min(jde-1,jpe) + DO k = kps,kpe-1 + DO i = max(ids,ips),min(ide-1,ipe) + muth_2(i,k,j) = grid%mub(i,j) + grid%mu_2(i,j) + ENDDO ENDDO ENDDO @@ -128,9 +153,11 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & ! write(6,*) ' coupling: setting muv and muv arrays ' DO j = max(jds,jps),min(jde-1,jpe) + DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - muut_2(i,j) = 0.5*(grid%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j))/grid%msfuy(i,j) ! u coupled with y - muvt_2(i,j) = 0.5*(grid%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1))/grid%msfvx(i,j) ! v coupled with x + muut_2(i,k,j) = 0.5*(grid%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j))/grid%msfuy(i,j) ! u coupled with y + muvt_2(i,k,j) = 0.5*(grid%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1))/grid%msfvx(i,j) ! v coupled with x + ENDDO ENDDO ENDDO @@ -138,14 +165,18 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & IF ( jpe .eq. jde ) THEN j = jde + DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - muvt_2(i,j) = (grid%mub(i,j-1) + grid%mu_2(i,j-1))/grid%msfvx(i,j) ! v coupled with x + muvt_2(i,k,j) = (grid%mub(i,j-1) + grid%mu_2(i,j-1))/grid%msfvx(i,j) ! v coupled with x + ENDDO ENDDO ENDIF IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN i = ide DO j = max(jds,jps),min(jde-1,jpe) - muut_2(i,j) = (grid%mub(i-1,j) + grid%mu_2(i-1,j))/grid%msfuy(i,j) ! u coupled with y + DO k = kps,kpe-1 + muut_2(i,k,j) = (grid%mub(i-1,j) + grid%mu_2(i-1,j))/grid%msfuy(i,j) ! u coupled with y + ENDDO ENDDO ENDIF @@ -153,14 +184,18 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & IF ( jpe .eq. jde ) THEN j = jde + DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - muvt_2(i,j) = 0.5*(grid%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1))/grid%msfvx(i,j) ! v coupled with x + muvt_2(i,k,j) = 0.5*(grid%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1))/grid%msfvx(i,j) ! v coupled with x + ENDDO ENDDO ENDIF IF ( ipe .eq. ide ) THEN i = ide DO j = max(jds,jps),min(jde-1,jpe) - muut_2(i,j) = 0.5*(grid%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j))/grid%msfuy(i,j) ! u coupled with y + DO k = kps,kpe-1 + muut_2(i,k,j) = 0.5*(grid%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j))/grid%msfuy(i,j) ! u coupled with y + ENDDO ENDDO ENDIF @@ -171,23 +206,37 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & ! write(6,*) ' uncoupling: setting mu arrays ' DO j = max(jds,jps),min(jde-1,jpe) + DO k = kps,kpe DO i = max(ids,ips),min(ide-1,ipe) - mut_2(i,j) = 1./(grid%mub(i,j) + grid%mu_2(i,j)) - muwt_2(i,j) = grid%msfty(i,j)/(grid%mub(i,j) + grid%mu_2(i,j)) ! w coupled with y + mutf_2(i,k,j) = 1./(grid%Mub(i,j) + grid%Mu_2(i,j)) + muwt_2(i,k,j) = grid%msfty(i,j)/(grid%Mub(i,j) + grid%Mu_2(i,j)) ! w coupled with y + ENDDO + ENDDO + ENDDO + + DO j = max(jds,jps),min(jde-1,jpe) + DO k = kps,kpe-1 + DO i = max(ids,ips),min(ide-1,ipe) + muth_2(i,k,j) = 1./(grid%mub(i,j) + grid%mu_2(i,j)) + ENDDO ENDDO ENDDO ! write(6,*) ' uncoupling: setting muv arrays ' DO j = max(jds,jps),min(jde-1,jpe) + DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - muut_2(i,j) = 2.*grid%msfuy(i,j)/(grid%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j)) ! u coupled with y + muut_2(i,k,j) = 2.*grid%msfuy(i,j)/(grid%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j)) ! u coupled with y + ENDDO ENDDO ENDDO DO j = max(jds,jps),min(jde-1,jpe) + DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - muvt_2(i,j) = 2.*grid%msfvx(i,j)/(grid%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1)) ! v coupled with x + muvt_2(i,k,j) = 2.*grid%msfvx(i,j)/(grid%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1)) ! v coupled with x + ENDDO ENDDO ENDDO @@ -195,14 +244,18 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & IF ( jpe .eq. jde ) THEN j = jde + DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - muvt_2(i,j) = grid%msfvx(i,j)/(grid%mub(i,j-1) + grid%mu_2(i,j-1)) ! v coupled with x + muvt_2(i,k,j) = grid%msfvx(i,j)/(grid%mub(i,j-1) + grid%mu_2(i,j-1)) ! v coupled with x + ENDDO ENDDO ENDIF IF ( ipe .eq. ide .AND. .NOT. config_flags%periodic_x ) THEN i = ide DO j = max(jds,jps),min(jde-1,jpe) - muut_2(i,j) = grid%msfuy(i,j)/(grid%mub(i-1,j) + grid%mu_2(i-1,j)) ! u coupled with y + DO k = kps,kpe-1 + muut_2(i,k,j) = grid%msfuy(i,j)/(grid%mub(i-1,j) + grid%mu_2(i-1,j)) ! u coupled with y + ENDDO ENDDO ENDIF @@ -210,14 +263,18 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & IF ( jpe .eq. jde ) THEN j = jde + DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - muvt_2(i,j) = 2.*grid%msfvx(i,j)/(grid%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1)) ! v coupled with x + muvt_2(i,k,j) = 2.*grid%msfvx(i,j)/(grid%mub(i,j)+grid%mub(i,j-1) + grid%mu_2(i,j) + grid%mu_2(i,j-1)) ! v coupled with x + ENDDO ENDDO ENDIF IF ( ipe .eq. ide ) THEN i = ide DO j = max(jds,jps),min(jde-1,jpe) - muut_2(i,j) = 2.*grid%msfuy(i,j)/(grid%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j)) ! u coupled with y + DO k = kps,kpe-1 + muut_2(i,k,j) = 2.*grid%msfuy(i,j)/(grid%mub(i,j)+grid%mub(i-1,j) + grid%mu_2(i,j) + grid%mu_2(i-1,j)) ! u coupled with y + ENDDO ENDDO ENDIF @@ -233,14 +290,14 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & DO k = kps,kpe DO i = max(ids,ips),min(ide-1,ipe) - grid%ph_2(i,k,j) = grid%ph_2(i,k,j)*mut_2(i,j) - grid%w_2(i,k,j) = grid%w_2(i,k,j)*muwt_2(i,j) + grid%ph_2(i,k,j) = grid%ph_2(i,k,j)*mutf_2(i,k,j) + grid%w_2(i,k,j) = grid%w_2(i,k,j)*muwt_2(i,k,j) ENDDO ENDDO DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - grid%t_2(i,k,j) = grid%t_2(i,k,j)*mut_2(i,j) + grid%t_2(i,k,j) = grid%t_2(i,k,j)*muth_2(i,k,j) ENDDO ENDDO @@ -248,7 +305,7 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & DO im = PARAM_FIRST_SCALAR, num_3d_m DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - moist(i,k,j,im) = moist(i,k,j,im)*mut_2(i,j) + moist(i,k,j,im) = moist(i,k,j,im)*muth_2(i,k,j) ENDDO ENDDO ENDDO @@ -258,7 +315,7 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & DO im = PARAM_FIRST_SCALAR, num_3d_c DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - chem(i,k,j,im) = chem(i,k,j,im)*mut_2(i,j) + chem(i,k,j,im) = chem(i,k,j,im)*muth_2(i,k,j) ENDDO ENDDO ENDDO @@ -268,7 +325,7 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & DO im = PARAM_FIRST_SCALAR, num_3d_s DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - scalar(i,k,j,im) = scalar(i,k,j,im)*mut_2(i,j) + scalar(i,k,j,im) = scalar(i,k,j,im)*muth_2(i,k,j) ENDDO ENDDO ENDDO @@ -278,7 +335,7 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & DO im = PARAM_FIRST_SCALAR, num_tracer DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - tracer(i,k,j,im) = tracer(i,k,j,im)*mut_2(i,j) + tracer(i,k,j,im) = tracer(i,k,j,im)*muth_2(i,k,j) ENDDO ENDDO ENDDO @@ -288,7 +345,7 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & DO k = kps,kpe-1 DO i = max(ids,ips),min(ide,ipe) - grid%u_2(i,k,j) = grid%u_2(i,k,j)*muut_2(i,j) + grid%u_2(i,k,j) = grid%u_2(i,k,j)*muut_2(i,k,j) ENDDO ENDDO @@ -300,7 +357,7 @@ SUBROUTINE couple_or_uncouple_em ( grid , config_flags , couple & DO j = max(jds,jps),min(jde,jpe) DO k = kps,kpe-1 DO i = max(ids,ips),min(ide-1,ipe) - grid%v_2(i,k,j) = grid%v_2(i,k,j)*muvt_2(i,j) + grid%v_2(i,k,j) = grid%v_2(i,k,j)*muvt_2(i,k,j) ENDDO ENDDO ENDDO diff --git a/wrfv2_fire/dyn_em/module_advect_em.F b/wrfv2_fire/dyn_em/module_advect_em.F index 1399447e..755fed30 100644 --- a/wrfv2_fire/dyn_em/module_advect_em.F +++ b/wrfv2_fire/dyn_em/module_advect_em.F @@ -1,6 +1,128 @@ +#if ( HYBRID_COORD==1 ) +# define mub(...) (c1(k)*XXPCBXX(__VA_ARGS__)+c2(k)) +# define XXPCBXX(...) mub(__VA_ARGS__) + +# define mut(...) (c1(k)*XXPCTXX(__VA_ARGS__)+c2(k)) +# define XXPCTXX(...) mut(__VA_ARGS__) + +# define mu_old(...) (c1(k)*XXPCOLDXX(__VA_ARGS__)) +# define XXPCOLDXX(...) mu_old(__VA_ARGS__) +#endif + !WRF:MODEL_LAYER:DYNAMICS ! -#if ( ! defined(ADVECT_KERNEL) ) +#if ( defined(ADVECT_KERNEL) ) +! cpp -traditional -C -P -DADVECT_KERNEL module_advect_em.F > advection_kernel.f90 +! gfortran -ffree-form -ffree-line-length-none advection_kernel.f90 +! ./a.out +MODULE advection_kernel + TYPE grid_config_rec_type + INTEGER :: scalar_adv_opt = 0 + INTEGER :: h_sca_adv_order = 5 + INTEGER :: v_sca_adv_order = 3 + LOGICAL :: periodic_x = .false. + LOGICAL :: periodic_y = .false. + LOGICAL :: symmetric_xs = .false. + LOGICAL :: symmetric_xe = .false. + LOGICAL :: symmetric_ys = .false. + LOGICAL :: symmetric_ye = .false. + LOGICAL :: open_xs = .false. + LOGICAL :: open_xe = .false. + LOGICAL :: open_ys = .false. + LOGICAL :: open_ye = .false. + LOGICAL :: specified = .true. + LOGICAL :: nested = .false. + LOGICAL :: polar = .false. + END TYPE grid_config_rec_type + CHARACTER (LEN=256) :: wrf_err_message +CONTAINS +!---------------------------------------------------------------- +SUBROUTINE wrf_error_fatal ( message ) + IMPLICIT NONE + CHARACTER(LEN=*) , INTENT(IN) :: message + PRINT *,'advect_scalar_pd: FATAL MESSAGE = ',TRIM(message) + STOP 12345 +END SUBROUTINE wrf_error_fatal +!---------------------------------------------------------------- +SUBROUTINE init ( config_flags ) + IMPLICIT NONE + TYPE (grid_config_rec_type) :: config_flags + config_flags%h_sca_adv_order = 5 + config_flags%v_sca_adv_order = 3 + config_flags%periodic_x = .true. + config_flags%periodic_y = .true. + config_flags%symmetric_xs = .false. + config_flags%symmetric_xe = .false. + config_flags%symmetric_ys = .false. + config_flags%symmetric_ye = .false. + config_flags%open_xs = .false. + config_flags%open_xe = .false. + config_flags%open_ys = .false. + config_flags%open_ye = .false. + config_flags%specified = .false. + config_flags%nested = .false. +END SUBROUTINE init +!---------------------------------------------------------------- +SUBROUTINE tophat ( field, num_scalars , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + IMPLICIT NONE + INTEGER , INTENT(IN ) :: num_scalars , ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + REAL , DIMENSION( ims:ime , kms:kme , jms:jme , num_scalars ) , INTENT(OUT) :: field + INTEGER :: i, j, k , n + + field = 0 + + DO n = 1 , num_scalars + DO j = jts , jte + DO k = kts , kte + DO i = its , ite + IF ( i .gt. 35 .and. i.lt. 55 ) THEN + field (i,k,j,n) = 1. + END IF + END DO + END DO + END DO + END DO +END SUBROUTINE tophat +!---------------------------------------------------------------- +SUBROUTINE column (loop , data_list, its,ite) + IMPLICIT NONE + INTEGER , INTENT(IN) :: loop, its, ite + REAL , INTENT(IN) , DIMENSION(its:ite) :: data_list + INTEGER , DIMENSION(its:ite) :: data_int + INTEGER :: i + CHARACTER (len = 10 ) :: filename + + IF ( loop.EQ.0 ) THEN + OPEN (unit=7,file = "x_locations.txt" , & + form = "formatted" , & + access = "sequential" ) + + DO i = its,ite + write (7,*) i + END DO + close (7) + END IF + + WRITE(filename,fmt='(i6.6,".txt")') loop + OPEN (unit=7,file = filename , & + form = "formatted" , & + access = "sequential" ) + + data_int = NINT(data_list * 100 ) + DO i = its,ite + write (7,*) data_int(i) + END DO + close (7) + +END SUBROUTINE column +!---------------------------------------------------------------- +#elif ( ! defined(ADVECT_KERNEL) ) + MODULE module_advect_em USE module_bc @@ -13,6 +135,7 @@ MODULE module_advect_em SUBROUTINE advect_u ( u, u_old, tendency, & ru, rv, rom, & + c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -50,7 +173,9 @@ SUBROUTINE advect_u ( u, u_old, tendency, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & - rdzw + rdzw, & + c1, & + c2 REAL , INTENT(IN ) :: rdx, & rdy @@ -1414,6 +1539,7 @@ END SUBROUTINE advect_u SUBROUTINE advect_v ( v, v_old, tendency, & ru, rv, rom, & + c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -1451,7 +1577,9 @@ SUBROUTINE advect_v ( v, v_old, tendency, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & - rdzw + rdzw, & + c1, & + c2 REAL , INTENT(IN ) :: rdx, & rdy @@ -2907,8 +3035,10 @@ END SUBROUTINE advect_v !------------------------------------------------------------------- +#endif SUBROUTINE advect_scalar ( field, field_old, tendency, & ru, rv, rom, & + c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -2946,7 +3076,9 @@ SUBROUTINE advect_scalar ( field, field_old, tendency, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & - rdzw + rdzw, & + c1, & + c2 REAL , INTENT(IN ) :: rdx, & rdy @@ -4235,11 +4367,13 @@ SUBROUTINE advect_scalar ( field, field_old, tendency, & ENDIF vert_order_test END SUBROUTINE advect_scalar +#if ( ! defined(ADVECT_KERNEL) ) !--------------------------------------------------------------------------------- SUBROUTINE advect_w ( w, w_old, tendency, & ru, rv, rom, & + c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -4277,7 +4411,9 @@ SUBROUTINE advect_w ( w, w_old, tendency, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & - rdzu + rdzu, & + c1, & + c2 REAL , INTENT(IN ) :: rdx, & rdy @@ -5938,75 +6074,12 @@ SUBROUTINE advect_w ( w, w_old, tendency, & END SUBROUTINE advect_w !---------------------------------------------------------------- -#else -! cpp -traditional -C -P -DADVECT_KERNEL module_advect_em.F > advection_kernel.f90 -! ifort, pgfortran, gfortran advection_kernel.f90 -! a.out - -MODULE advection_kernel - - TYPE grid_config_rec_type - INTEGER :: h_sca_adv_order = 5 - INTEGER :: v_sca_adv_order = 3 - - LOGICAL :: periodic_x = .false. - LOGICAL :: periodic_y = .false. - - LOGICAL :: symmetric_xs = .false. - LOGICAL :: symmetric_xe = .false. - LOGICAL :: symmetric_ys = .false. - LOGICAL :: symmetric_ye = .false. - - LOGICAL :: open_xs = .false. - LOGICAL :: open_xe = .false. - LOGICAL :: open_ys = .false. - LOGICAL :: open_ye = .false. - - LOGICAL :: specified = .true. - LOGICAL :: nested = .false. - LOGICAL :: polar = .false. - END TYPE grid_config_rec_type - - CHARACTER (LEN=256) :: wrf_err_message - -CONTAINS - -!---------------------------------------------------------------- - -SUBROUTINE wrf_error_fatal ( message ) - IMPLICIT NONE - CHARACTER(LEN=*) , INTENT(IN) :: message - PRINT *,'advect_scalar_pd: FATAL MESSAGE = ',TRIM(message) - STOP 12345 -END SUBROUTINE wrf_error_fatal - -!---------------------------------------------------------------- - -SUBROUTINE init ( config_flags ) - IMPLICIT NONE - TYPE (grid_config_rec_type) :: config_flags - config_flags%h_sca_adv_order = 5 - config_flags%v_sca_adv_order = 3 - config_flags%periodic_x = .false. - config_flags%periodic_y = .false. - config_flags%symmetric_xs = .false. - config_flags%symmetric_xe = .false. - config_flags%symmetric_ys = .false. - config_flags%symmetric_ye = .false. - config_flags%open_xs = .false. - config_flags%open_xe = .false. - config_flags%open_ys = .false. - config_flags%open_ye = .false. - config_flags%specified = .true. - config_flags%nested = .false. -END SUBROUTINE init -!---------------------------------------------------------------- #endif - SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & h_tendency, z_tendency, & ru, rv, rom, & + c1, c2, & mut, mub, mu_old, & time_step, config_flags, & tenddec, & @@ -6060,7 +6133,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & - rdzw + rdzw, & + c1, & + c2 REAL , INTENT(IN ) :: rdx, & rdy, & @@ -6089,7 +6164,9 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & INTEGER :: jp1, jp0, jtmp - REAL :: flux_out, ph_low, scale + REAL,DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: flux_out, ph_low + REAL :: scale + !REAL :: flux_out, ph_low, scale REAL, PARAMETER :: eps=1.e-20 @@ -7645,13 +7722,22 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & #endif DO i=i_start, i_end - ph_low = (mub(i,j)+mu_old(i,j))*field_old(i,k,j) & + ph_low(i,k,j) = (mub(i,j)+mu_old(i,j))*field_old(i,k,j) & - dt*( msftx(i,j)*msfty(i,j)*( & rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) + & rdy*(fqyl(i,k,j+1)-fqyl(i,k,j)) ) & +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) ) - flux_out = dt*( (msftx(i,j)*msfty(i,j))*( & + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_end + DO k=kts, ktf +!DIR$ vector always + DO i=i_start, i_end + + flux_out(i,k,j) = dt*( (msftx(i,j)*msfty(i,j))*( & rdx*( max(0.,fqx (i+1,k,j)) & -min(0.,fqx (i ,k,j)) ) & +rdy*( max(0.,fqy (i,k,j+1)) & @@ -7659,9 +7745,16 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & +msfty(i,j)*rdzw(k)*( min(0.,fqz (i,k+1,j)) & -max(0.,fqz (i,k ,j)) ) ) - IF( flux_out .gt. ph_low ) THEN + ENDDO + ENDDO + ENDDO - scale = max(0.,ph_low/(flux_out+eps)) + DO j=j_start, j_end + DO k=kts, ktf +!DIR$ vector always + DO i=i_start, i_end + IF( flux_out(i,k,j) .gt. ph_low(i,k,j) ) THEN + scale = max(0.,ph_low(i,k,j)/(flux_out(i,k,j)+eps)) IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j) IF( fqx (i ,k,j) .lt. 0.) fqx(i ,k,j) = scale*fqx(i ,k,j) IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1) @@ -7782,309 +7875,112 @@ SUBROUTINE advect_scalar_pd ( field, field_old, tendency, & END IF END SUBROUTINE advect_scalar_pd -#if ( defined(ADVECT_KERNEL) ) !---------------------------------------------------------------- -END MODULE advection_kernel - -!================================================================ -!================================================================ - -PROGRAM feeder - - USE advection_kernel - +SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & + ru, rv, rom, & + c1, c2, & + mut, time_step, config_flags, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, & + fzm, fzp, & + rdx, rdy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +! +! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS. +! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; +! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; Also used by Bryan 2005, Mon. Wea. Rev. +! IMPLICIT NONE - INTEGER , PARAMETER :: MAX_SCALARS = 15 + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - TYPE(grid_config_rec_type) :: config_flags + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & + field_old, & + ru, & + rv, & + rom - LOGICAL :: tenddec = .TRUE. + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency - INTEGER :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & + msfuy, & + msfvx, & + msfvy, & + msftx, & + msfty - REAL , DIMENSION( :,:,:,: ) , ALLOCATABLE :: field, & - field_old - REAL , DIMENSION( :,:,: ) , ALLOCATABLE :: ru, & - rv, & - rom + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & + fzp, & + rdzw, & + c1, & + c2 - REAL , DIMENSION( :,: ), ALLOCATABLE :: mut, mub, mu_old + REAL , INTENT(IN ) :: rdx, & + rdy + INTEGER , INTENT(IN ) :: time_step - REAL , DIMENSION( :,:,: ), ALLOCATABLE :: tendency - REAL , DIMENSION( :,:,: ), ALLOCATABLE :: h_tendency, z_tendency + ! Local data + + INTEGER :: i, j, k, itf, jtf, ktf + INTEGER :: i_start, i_end, j_start, j_end + INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f + INTEGER :: jmin, jmax, jp, jm, imin, imax - REAL , DIMENSION( :,: ), ALLOCATABLE :: msfux, & - msfuy, & - msfvx, & - msfvy, & - msftx, & - msfty + INTEGER , PARAMETER :: is=0, js=0, ks=0 - REAL , DIMENSION( : ), ALLOCATABLE :: fzm, & - fzp, & - rdzw, znw + REAL :: mrdx, mrdy, ub, vb, vw + REAL , DIMENSION(its:ite, kts:kte) :: vflux - REAL :: rdx, & - rdy, & - dt - INTEGER :: time_step, im + REAL, DIMENSION( its-is:ite+1, kts:kte ) :: fqx +! REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx + REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy - INTEGER :: i, j, k, loop + INTEGER :: horz_order, vert_order + + LOGICAL :: degrade_xs, degrade_ys + LOGICAL :: degrade_xe, degrade_ye - PRINT *,'Init dimensions' + INTEGER :: jp1, jp0, jtmp - ids = 1; ide = 90; jds = 1; jde = 90; kds = 1; kde = 50 - ims = -5; ime = 55; jms = -5; jme = 55; kms = -5; kme = 55 - its = 1; ite = 50; jts = 1; jte = 50; kts = 1; kte = 50 + real :: dir, vv + real :: ue,uw,vs,vn,wb,wt + real, parameter :: f30 = 7./12., f31 = 1./12. + real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60. - PRINT *,'ALLOCATE two 4d fields' - PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1)*MAX_SCALARS - ALLOCATE ( field(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) ) - ALLOCATE ( field_old(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) ) + integer kt,kb + + + real :: qim2, qim1, qi, qip1, qip2 + double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk + double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-28 + integer, parameter :: pw = 2 - PRINT *,'ALLOCATE three 3d fields U, V, W' - PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1) - ALLOCATE ( ru(ims:ime , kms:kme , jms:jme ) ) - ALLOCATE ( rv(ims:ime , kms:kme , jms:jme ) ) - ALLOCATE ( rom(ims:ime , kms:kme , jms:jme ) ) - PRINT *,'ALLOCATE three 2d MU fields' - PRINT *,(ime-ims+1)*(jme-jms+1) - ALLOCATE ( mut( ims:ime , jms:jme ) ) - ALLOCATE ( mub( ims:ime , jms:jme ) ) - ALLOCATE ( mu_old( ims:ime , jms:jme ) ) +! definition of flux operators, 3rd, 4th, 5th or 6th order - PRINT *,'ALLOCATE three 3d tendency' - PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1) - ALLOCATE ( tendency( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE ( h_tendency( ims:ime , kms:kme , jms:jme ) ) - ALLOCATE ( z_tendency( ims:ime , kms:kme , jms:jme ) ) - - PRINT *,'ALLOCATE six 2d map factors' - PRINT *,(ime-ims+1)*(jme-jms+1) - ALLOCATE ( msfux( ims:ime , jms:jme ) ) - ALLOCATE ( msfuy( ims:ime , jms:jme ) ) - ALLOCATE ( msfvx( ims:ime , jms:jme ) ) - ALLOCATE ( msfvy( ims:ime , jms:jme ) ) - ALLOCATE ( msftx( ims:ime , jms:jme ) ) - ALLOCATE ( msfty( ims:ime , jms:jme ) ) - - PRINT *,'ALLOCATE 1d arrays' - ALLOCATE ( fzm( kms:kme ) ) - ALLOCATE ( fzp( kms:kme ) ) - ALLOCATE ( rdzw( kms:kme ) ) - ALLOCATE ( znw( kms:kme ) ) - - PRINT *,'CALL init' - CALL init ( config_flags) - - PRINT *,'RANDOM two 3d fields' - CALL RANDOM_NUMBER ( field ) - CALL RANDOM_NUMBER ( field_old ) - field = field - 0.5 - field_old = field_old - 0.5 - - PRINT *,'RANDOM three 3d tendencies' - CALL RANDOM_NUMBER ( tendency ) - CALL RANDOM_NUMBER ( h_tendency ) - CALL RANDOM_NUMBER ( z_tendency ) - tendency = tendency - 0.5 - h_tendency = h_tendency - 0.5 - z_tendency = z_tendency - 0.5 - - PRINT *,'RANDOM three 2d MU' - mub = 95000 - mut = 100000 - CALL RANDOM_NUMBER ( mu_old ) - mu_old = 100000 - mu_old*100 - - PRINT *,'RANDOM three 3d couple momentum' - CALL RANDOM_NUMBER ( ru ) - CALL RANDOM_NUMBER ( rv ) - CALL RANDOM_NUMBER ( rom ) - DO j = jts, jte - DO k = kts, kte - DO i = its, ite - ru(i,k,j) = ru(i,k,j) * mut(i,j) - rv(i,k,j) = rv(i,k,j) * mut(i,j) - rom(i,k,j) = rom(i,k,j) * mut(i,j) - END DO - END DO - END DO - - time_step = -1 - - msfux = 1 - msfuy = 1 - msfvx = 1 - msfvy = 1 - msftx = 1 - msfty = 1 - - rdx = 1/10000. - rdy = 1/10000. - - DO k = kts, kte - znw(k) = 1 - (real(k)-kts)/(real(kte)-kts) - END DO - - DO k = kts, kte-1 - rdzw(k) = 1./(znw(k)-znw(k+1)) - END DO - - CALL RANDOM_NUMBER ( fzm ) - fzp = 1. - fzm - - ! Loop over advection enough times to get some meaningful timings. - - DO loop = 1 , 100 - - ! A representative number of times to call the advection in a time period. - - PRINT *,'LOOP over scalars' - DO im = 1 , MAX_SCALARS - PRINT *,'CALL advect for loop = ',im,', of ',MAX_SCALARS,' loops' - CALL advect_scalar_pd ( field(ims,kms,jms,im), & - field_old(ims,kms,jms,im), & - tendency(ims,kms,jms), & - h_tendency(ims,kms,jms), & - z_tendency(ims,kms,jms), & - ru, rv, rom, mut, mub, mu_old, & - time_step, config_flags, tenddec, & - msfux, msfuy, msfvx, msfvy, & - msftx, msfty, fzm, fzp, & - rdx, rdy, rdzw,dt, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) - - END DO - END DO - -END PROGRAM feeder -#else - -!---------------------------------------------------------------- - -SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & - ru, rv, rom, & - mut, mub, mu_old, & - time_step, config_flags, & - msfux, msfuy, msfvx, msfvy, & - msftx, msfty, & - fzm, fzp, & - rdx, rdy, rdzw, dt, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) - -! this is a first cut at a positive definite advection option -! for scalars in WRF. This version is memory intensive -> -! we save 3d arrays of x, y and z both high and low order fluxes -! (six in all). Alternatively, we could sweep in a direction -! and lower the cost considerably. - -! uses the Smolarkiewicz MWR 1989 approach, with addition of first-order -! fluxes initially - -! WCS, 3 December 2002, 24 February 2003 - -! -! ERM Dec. 2011: replaced 5th-order fluxes with 5th-order WENO (Weighted -! Essentially Non-Oscillatory) scheme -! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; -! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; -! - - IMPLICIT NONE - - ! Input data - - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - - REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & - field_old, & - ru, & - rv, & - rom - - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, mub, mu_old - REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency - - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & - msfuy, & - msfvx, & - msfvy, & - msftx, & - msfty - - REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & - fzp, & - rdzw - - REAL , INTENT(IN ) :: rdx, & - rdy, & - dt - INTEGER , INTENT(IN ) :: time_step - - ! Local data - - INTEGER :: i, j, k, itf, jtf, ktf - INTEGER :: i_start, i_end, j_start, j_end - INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f - INTEGER :: jmin, jmax, jp, jm, imin, imax - - REAL :: mrdx, mrdy, ub, vb, uw, vw, mu - -! storage for high and low order fluxes - - REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqx, fqy, fqz - REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqxl, fqyl, fqzl - - INTEGER :: horz_order, vert_order - - LOGICAL :: degrade_xs, degrade_ys - LOGICAL :: degrade_xe, degrade_ye - - INTEGER :: jp1, jp0, jtmp - - REAL :: flux_out, ph_low, scale - REAL, PARAMETER :: eps=1.e-20 - - real :: dir, vv - real :: ue,vs,vn,wb,wt - real, parameter :: f30 = 7./12., f31 = 1./12. - real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60. - - real :: qim2, qim1, qi, qip1, qip2 - double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk - double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps1=1.0d-28 - integer, parameter :: pw = 2 - - -! definition of flux operators, 3rd, 4th, 5th or 6th order - - REAL :: flux3, flux4, flux5, flux6, flux_upwind - REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr + REAL :: flux3, flux4, flux5, flux6 + REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel flux4(q_im2, q_im1, q_i, q_ip1, ua) = & (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2) flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & - sign(1,time_step)*sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) + sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2) & @@ -8095,34 +7991,23 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & -sign(1,time_step)*sign(1.,ua)*(1./60.)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) ) - flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 & - +0.5*max(-1.0,(cr-abs(cr)))*q_i + LOGICAL :: specified -! flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 & -! +0.5*(1.-sign(1.,cr))*q_i -! flux_upwind(q_im1, q_i, cr ) = 0. + specified = .false. + if(config_flags%specified .or. config_flags%nested) specified = .true. - REAL :: dx,dy,dz +! set order for the advection schemes - LOGICAL, PARAMETER :: pd_limit = .true. + ktf=MIN(kte,kde-1) + horz_order = 5 ! config_flags%h_sca_adv_order + vert_order = 5 ! config_flags%v_sca_adv_order -! set order for the advection schemes +! begin with horizontal flux divergence +! here is the choice of flux operators -! write(6,*) ' in pd advection routine ' - ! Empty arrays just in case: - IF (config_flags%polar) THEN - fqx(:,:,:) = 0. - fqy(:,:,:) = 0. - fqz(:,:,:) = 0. - fqxl(:,:,:) = 0. - fqyl(:,:,:) = 0. - fqzl(:,:,:) = 0. - END IF - ktf=MIN(kte,kde-1) - horz_order = config_flags%h_sca_adv_order - vert_order = config_flags%v_sca_adv_order + IF( horz_order == 5 ) THEN ! determine boundary mods for flux operators ! We degrade the flux operators from 3rd/4th order @@ -8136,20 +8021,12 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & degrade_ys = .true. degrade_ye = .true. -! begin with horizontal flux divergence -! here is the choice of flux operators - - -! horizontal_order_test : IF( horz_order == 6 ) THEN - -! ELSE IF( horz_order == 5 ) THEN - IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & - (ite < ide-4) ) degrade_xe = .false. + (ite < ide-3) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. @@ -8159,49 +8036,57 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & !--------------- y - advection first -!-- y flux compute; these bounds are for periodic and sym b.c. - ktf=MIN(kte,kde-1) - i_start = its-1 - i_end = MIN(ite,ide-1)+1 - j_start = jts-1 - j_end = MIN(jte,jde-1)+1 - j_start_f = j_start - j_end_f = j_end+1 + i_start = its + i_end = MIN(ite,ide-1) -!-- modify loop bounds if open or specified -! IF(degrade_xs) i_start = MAX(its-1,ids-1) -! IF(degrade_xe) i_end = MIN(ite+1,ide-2) - IF(degrade_xs) i_start = MAX(its-1,ids) - IF(degrade_xe) i_end = MIN(ite+1,ide-1) +! check for U + IF ( is == 1 ) THEN + i_start = its + i_end = ite + IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) + IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) + IF ( config_flags%periodic_x ) i_start = its + IF ( config_flags%periodic_x ) i_end = ite + ENDIF + + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + j_start_f = j_start + j_end_f = j_end+1 IF(degrade_ys) then - j_start = MAX(jts-1,jds+1) + j_start = MAX(jts,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then - j_end = MIN(jte+1,jde-2) + j_end = MIN(jte,jde-2) j_end_f = jde-3 ENDIF -! compute fluxes, 5th order + IF(config_flags%polar) j_end = MIN(jte,jde-1) - j_loop_y_flux_5 : DO j = j_start, j_end+1 +! compute fluxes, 5th or 6th order + + jp1 = 2 + jp0 = 1 + + j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end +! vel = rv(i,k,j) + vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) ) - dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy - mu = 0.5*(mut(i,j)+mut(i,j-1)) - vel = rv(i,k,j) - cr = vel*dt/dy/mu - fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) - - IF ( vel .ge. 0.0 ) THEN + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = field(i,k,j+1) qip1 = field(i,k,j ) qi = field(i,k,j-1) @@ -8223,127 +8108,164 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 - wi0 = gi0 / (eps1 + beta0)**pw - wi1 = gi1 / (eps1 + beta1)**pw - wi2 = gi2 / (eps1 + beta2)**pw + wi0 = gi0 / (eps + beta0)**pw + wi1 = gi1 / (eps + beta1)**pw + wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 - fqy( i, k, j ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk + fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk -! fqy( i, k, j ) = vel*flux5( & +! fqy( i, k, jp1 ) = vel*flux5( & ! field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & ! field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) - - fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) - ENDDO ENDDO + ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end - - dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy - mu = 0.5*(mut(i,j)+mut(i,j-1)) - vel = rv(i,k,j) - cr = vel*dt/dy/mu - fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) - - fqy(i,k, j) = 0.5*rv(i,k,j)* & + fqy(i,k, jp1) = 0.5*rv(i,k,j)* & +! fqy(i,k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )* & (field(i,k,j)+field(i,k,j-1)) - fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) - ENDDO ENDDO - ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end - - dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy - mu = 0.5*(mut(i,j)+mut(i,j-1)) +! vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) ) vel = rv(i,k,j) - cr = vel*dt/dy/mu - fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) - - fqy( i, k, j ) = vel*flux3( & + fqy( i, k, jp1 ) = vel*flux3( & field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) - fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) - ENDDO ENDDO - ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end - - dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy - mu = 0.5*(mut(i,j)+mut(i,j-1)) - vel = rv(i,k,j) - cr = vel*dt/dy/mu - fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) - - fqy(i, k, j ) = 0.5*rv(i,k,j)* & +! fqy(i, k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )* & + fqy(i, k, jp1) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) - fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) - ENDDO ENDDO - ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary + ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end - - dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy - mu = 0.5*(mut(i,j)+mut(i,j-1)) vel = rv(i,k,j) - cr = vel*dt/dy/mu - fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) - - fqy( i, k, j) = vel*flux3( & +! vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) ) + fqy( i, k, jp1) = vel*flux3( & field(i,k,j-2),field(i,k,j-1), & field(i,k,j),field(i,k,j+1),vel ) - fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) - ENDDO ENDDO - ENDIF + ENDIF - ENDDO j_loop_y_flux_5 +! y flux-divergence into tendency -! next, x flux + IF ( is == 0 ) THEN + ! Comments on polar boundary conditions + ! Same process as for advect_u - tendencies run from jds to jde-1 + ! (latitudes are as for u grid, longitudes are displaced) + ! Therefore: flow is only from one side for points next to poles + IF ( config_flags%polar .AND. (j == jds+1) ) THEN + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) + END DO + END DO + ELSE IF( config_flags%polar .AND. (j == jde) ) THEN + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS + tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) + END DO + END DO + ELSE ! normal code -!-- these bounds are for periodic and sym conditions + IF(j > j_start) THEN - i_start = its-1 - i_end = MIN(ite,ide-1)+1 - i_start_f = i_start - i_end_f = i_end+1 + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO - j_start = jts-1 - j_end = MIN(jte,jde-1)+1 + ENDIF + ENDIF + ELSEIF ( is == 1 ) THEN -!-- modify loop bounds for open and specified b.c + ! (j > j_start) will miss the u(,,jds) tendency + IF ( config_flags%polar .AND. (j == jds+1) ) THEN + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) + END DO + END DO + ! This would be seen by (j > j_start) but we need to zero out the NP tendency + ELSE IF( config_flags%polar .AND. (j == jde) ) THEN + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS + tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) + END DO + END DO + ELSE ! normal code -! IF(degrade_ys) j_start = MAX(jts-1,jds+1) -! IF(degrade_ye) j_end = MIN(jte+1,jde-2) - IF(degrade_ys) j_start = MAX(jts-1,jds) - IF(degrade_ye) j_end = MIN(jte+1,jde-1) + IF(j > j_start) THEN + + DO k=kts,ktf + DO i = i_start, i_end + mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS + tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) + ENDDO + ENDDO + + ENDIF + + END IF + + ENDIF + + jtmp = jp1 + jp1 = jp0 + jp0 = jtmp + + ENDDO j_loop_y_flux_5 + +! next, x - flux divergence + + i_start = its + i_end = MIN(ite,ide-1) + + j_start = jts + j_end = MIN(jte,jde-1) + +! higher order flux has a 5 or 7 point stencil, so compute +! bounds so we can switch to second order flux close to the boundary + + i_start_f = i_start + i_end_f = i_end+1 IF(degrade_xs) then - i_start = MAX(ids+1,its-1) - i_start_f = ids+3 + i_start = MAX(ids+1,its) +! i_start_f = i_start+2 + i_start_f = MIN(i_start+2,ids+3) ENDIF IF(degrade_xe) then - i_end = MIN(ide-2,ite+1) + i_end = MIN(ide-2,ite) i_end_f = ide-3 ENDIF @@ -8351,19 +8273,15 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & DO j = j_start, j_end -! 5th order flux +! 5th or 6th order flux DO k=kts,ktf DO i = i_start_f, i_end_f - - dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx - mu = 0.5*(mut(i,j)+mut(i-1,j)) - vel = ru(i,k,j) - cr = vel*dt/dx/mu - fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) +! vel = ru(i,k,j) + vel = 0.5*( ru(i,k,j) + ru(i-is,k-ks,j-js) ) - IF ( vel .ge. 0.0 ) THEN + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = field(i+1,k,j) qip1 = field(i, k,j) qi = field(i-1,k,j) @@ -8385,20 +8303,18 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 - wi0 = gi0 / (eps1 + beta0)**pw - wi1 = gi1 / (eps1 + beta1)**pw - wi2 = gi2 / (eps1 + beta2)**pw + wi0 = gi0 / (eps + beta0)**pw + wi1 = gi1 / (eps + beta1)**pw + wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 - fqx(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk + fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk -! fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & +! fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & ! field(i-1,k,j), field(i ,k,j), & ! field(i+1,k,j), field(i+2,k,j), & ! vel ) - fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) - ENDDO ENDDO @@ -8410,30 +8326,19 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & IF(i == ids+1) THEN ! second order DO k=kts,ktf - dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx - mu = 0.5*(mut(i,j)+mut(i-1,j)) - vel = ru(i,k,j)/mu - cr = vel*dt/dx - fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) - fqx(i,k,j) = 0.5*(ru(i,k,j)) & + fqx(i,k) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) - fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf - dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx - mu = 0.5*(mut(i,j)+mut(i-1,j)) vel = ru(i,k,j) - cr = vel*dt/dx/mu - fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) - fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & - field(i ,k,j), field(i+1,k,j), & - vel ) - fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) ENDDO - ENDIF + END IF ENDDO @@ -8445,46 +8350,47 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf - dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx - mu = 0.5*(mut(i,j)+mut(i-1,j)) - vel = ru(i,k,j) - cr = vel*dt/dx/mu - fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) - fqx(i,k,j) = 0.5*(ru(i,k,j)) & + fqx(i,k) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) - fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) - ENDDO - ENDIF - - - IF( i == ide-2 ) THEN ! third order flux one in from the boundary - DO k=kts,ktf - dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx - mu = 0.5*(mut(i,j)+mut(i-1,j)) - vel = ru(i,k,j) - cr = vel*dt/dx/mu - fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) - fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & - field(i ,k,j), field(i+1,k,j), & - vel ) - fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO - ENDIF - - ENDDO - - ENDIF + ENDIF - ENDDO ! enddo for outer J loop + IF( i == ide-2 ) THEN ! third order flux one in from the boundary + DO k=kts,ktf + vel = ru(i,k,j) + fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + ENDDO + ENDIF -!--- end of 5th order horizontal flux calculation + ENDDO -! ELSE + ENDIF -! WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order -! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) +! x flux-divergence into tendency -! ENDIF horizontal_order_test + IF ( is == 0 ) THEN + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + ELSEIF ( is == 1 ) THEN + DO k=kts,ktf + DO i = i_start, i_end + mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS + tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + ENDDO + ENDDO + ENDIF + + ENDDO + + + ENDIF + ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. @@ -8561,80 +8467,32 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & ENDIF - IF( (config_flags%polar) .and. (jts == jds) ) THEN - - ! Assuming rv(i,k,jds) = 0. - DO i = i_start, i_end - DO k = kts, ktf - vb = MIN( 0.5*rv(i,k,jts+1), 0. ) - tendency(i,k,jts) = tendency(i,k,jts) & - - rdy*( & - vb*( field_old(i,k,jts+1) & - - field_old(i,k,jts ) ) + & - field(i,k,jts)*rv(i,k,jts+1) & - ) - ENDDO - ENDDO - - ENDIF - - IF( (config_flags%polar) .and. (jte == jde)) THEN - - ! Assuming rv(i,k,jde) = 0. - DO i = i_start, i_end - DO k = kts, ktf - vb = MAX( 0.5*rv(i,k,jte-1), 0. ) - tendency(i,k,j_end) = tendency(i,k,j_end) & - - rdy*( & - vb*( field_old(i,k,j_end ) & - - field_old(i,k,j_end-1) ) + & - field(i,k,j_end)*(-rv(i,k,jte-1)) & - ) - ENDDO - ENDDO - - ENDIF !-------------------- vertical advection +! Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my) +! Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my) +! So we don't need to make a correction for advect_scalar -!-- loop bounds for periodic or sym conditions - - i_start = its-1 - i_end = MIN(ite,ide-1)+1 - j_start = jts-1 - j_end = MIN(jte,jde-1)+1 - -!-- loop bounds for open or specified conditions - - IF(degrade_xs) i_start = MAX(its-1,ids) - IF(degrade_xe) i_end = MIN(ite+1,ide-1) - IF(degrade_ys) j_start = MAX(jts-1,jds) - IF(degrade_ye) j_end = MIN(jte+1,jde-1) + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) -! vert_order_test : IF (vert_order == 6) THEN + DO i = i_start, i_end + vflux(i,kts)=0. + vflux(i,kte)=0. + ENDDO -! ELSE IF (vert_order == 5) THEN DO j = j_start, j_end - DO i = i_start, i_end - fqz(i,1,j) = 0. - fqzl(i,1,j) = 0. - fqz(i,kde,j) = 0. - fqzl(i,kde,j) = 0. - ENDDO - DO k=kts+3,ktf-2 DO i = i_start, i_end - dz = 2./(rdzw(k)+rdzw(k-1)) - mu = 0.5*(mut(i,j)+mut(i,j)) - vel = rom(i,k,j) - cr = vel*dt/dz/mu - fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) - +! vel = rom(i,k,j) + vel = 0.5*( rom(i,k,j) + rom(i-is,k-ks,j-js) ) - IF( -vel .ge. 0.0 ) THEN + IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = field(i,k+1,j) qip1 = field(i,k ,j) qi = field(i,k-1,j) @@ -8656,263 +8514,103 @@ SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 - wi0 = gi0 / (eps1 + beta0)**pw - wi1 = gi1 / (eps1 + beta1)**pw - wi2 = gi2 / (eps1 + beta2)**pw + wi0 = gi0 / (eps + beta0)**pw + wi1 = gi1 / (eps + beta1)**pw + wi2 = gi2 / (eps + beta2)**pw sumwk = wi0 + wi1 + wi2 - fqz(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk + vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk -! fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & -! field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) - fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) +! vflux(i,k) = vel*flux5( & +! field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & +! field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) ENDDO ENDDO DO i = i_start, i_end k=kts+1 - dz = 2./(rdzw(k)+rdzw(k-1)) - mu = 0.5*(mut(i,j)+mut(i,j)) - vel = rom(i,k,j) - cr = vel*dt/dz/mu - fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) - fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) - fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) - - k=kts+2 - dz = 2./(rdzw(k)+rdzw(k-1)) - mu = 0.5*(mut(i,j)+mut(i,j)) - vel = rom(i,k,j) - cr = vel*dt/dz/mu - fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) - - fqz(i,k,j) = vel*flux3( & - field(i,k-2,j), field(i,k-1,j), & - field(i,k ,j), field(i,k+1,j), -vel ) - fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) - - k=ktf-1 - dz = 2./(rdzw(k)+rdzw(k-1)) - mu = 0.5*(mut(i,j)+mut(i,j)) - vel = rom(i,k,j) - cr = vel*dt/dz/mu - fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) - - fqz(i,k,j) = vel*flux3( & - field(i,k-2,j), field(i,k-1,j), & - field(i,k ,j), field(i,k+1,j), -vel ) - fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + + k = kts+2 + vel=rom(i,k,j) + vflux(i,k) = vel*flux3( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + k = ktf-1 + vel=rom(i,k,j) + vflux(i,k) = vel*flux3( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) k=ktf - dz = 2./(rdzw(k)+rdzw(k-1)) - mu = 0.5*(mut(i,j)+mut(i,j)) - vel = rom(i,k,j) - cr = vel*dt/dz/mu - fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) - fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) - fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + ENDDO + DO k=kts,ktf + DO i = i_start, i_end + tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) + ENDDO ENDDO ENDDO -! ELSE - -! WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order -! CALL wrf_error_fatal ( wrf_err_message ) -! ENDIF vert_order_test +END SUBROUTINE advect_scalar_weno - IF (pd_limit) THEN +!--------------------------------------------------------------------------------- -! positive definite filter +SUBROUTINE advect_scalar_wenopd ( field, field_old, tendency, & + ru, rv, rom, & + c1, c2, & + mut, mub, mu_old, & + time_step, config_flags, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, & + fzm, fzp, & + rdx, rdy, rdzw, dt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) - i_start = its-1 - i_end = MIN(ite,ide-1)+1 - j_start = jts-1 - j_end = MIN(jte,jde-1)+1 +! this is a first cut at a positive definite advection option +! for scalars in WRF. This version is memory intensive -> +! we save 3d arrays of x, y and z both high and low order fluxes +! (six in all). Alternatively, we could sweep in a direction +! and lower the cost considerably. -!-- loop bounds for open or specified conditions +! uses the Smolarkiewicz MWR 1989 approach, with addition of first-order +! fluxes initially - IF(degrade_xs) i_start = MAX(its-1,ids) - IF(degrade_xe) i_end = MIN(ite+1,ide-1) - IF(degrade_ys) j_start = MAX(jts-1,jds) - IF(degrade_ye) j_end = MIN(jte+1,jde-1) +! WCS, 3 December 2002, 24 February 2003 - IF(config_flags%specified .or. config_flags%nested) THEN - IF (degrade_xs) i_start = MAX(its-1,ids+1) - IF (degrade_xe) i_end = MIN(ite+1,ide-2) - IF (degrade_ys) j_start = MAX(jts-1,jds+1) - IF (degrade_ye) j_end = MIN(jte+1,jde-2) - END IF +! +! ERM Dec. 2011: replaced 5th-order fluxes with 5th-order WENO (Weighted +! Essentially Non-Oscillatory) scheme +! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; +! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; +! - IF(config_flags%open_xs) THEN - IF (degrade_xs) i_start = MAX(its-1,ids+1) - END IF - IF(config_flags%open_xe) THEN - IF (degrade_xe) i_end = MIN(ite+1,ide-2) - END IF - IF(config_flags%open_ys) THEN - IF (degrade_ys) j_start = MAX(jts-1,jds+1) - END IF - IF(config_flags%open_ye) THEN - IF (degrade_ye) j_end = MIN(jte+1,jde-2) - END IF - ! ADT note: - ! We don't want to change j_start and j_end - ! for polar BC's since we want to calculate - ! fluxes for directions other than y at the - ! edge + IMPLICIT NONE + + ! Input data + + TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags -!-- here is the limiter... + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte - DO j=j_start, j_end - DO k=kts, ktf - DO i=i_start, i_end + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & + field_old, & + ru, & + rv, & + rom - ph_low = (mub(i,j)+mu_old(i,j))*field_old(i,k,j) & - - dt*( msftx(i,j)*msfty(i,j)*( & - rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) + & - rdy*(fqyl(i,k,j+1)-fqyl(i,k,j)) ) & - +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) ) - - flux_out = dt*( (msftx(i,j)*msfty(i,j))*( & - rdx*( max(0.,fqx (i+1,k,j)) & - -min(0.,fqx (i ,k,j)) ) & - +rdy*( max(0.,fqy (i,k,j+1)) & - -min(0.,fqy (i,k,j )) ) ) & - +msfty(i,j)*rdzw(k)*( min(0.,fqz (i,k+1,j)) & - -max(0.,fqz (i,k ,j)) ) ) - - IF( flux_out .gt. ph_low ) THEN - - scale = max(0.,ph_low/(flux_out+eps)) - IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j) - IF( fqx (i ,k,j) .lt. 0.) fqx(i ,k,j) = scale*fqx(i ,k,j) - IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1) - IF( fqy (i,k,j ) .lt. 0.) fqy(i,k,j ) = scale*fqy(i,k,j ) -! note: z flux is opposite sign in mass coordinate because -! vertical coordinate decreases with increasing k - IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j) - IF( fqz (i,k ,j) .gt. 0.) fqz(i,k ,j) = scale*fqz(i,k ,j) - - END IF - - ENDDO - ENDDO - ENDDO - - END IF - -! add in the pd-limited flux divergence - - i_start = its - i_end = MIN(ite,ide-1) - j_start = jts - j_end = MIN(jte,jde-1) - - DO j = j_start, j_end - DO k = kts, ktf - DO i = i_start, i_end - - tendency (i,k,j) = tendency(i,k,j) & - -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) & - +fqzl(i,k+1,j)-fqzl(i,k,j)) - - ENDDO - ENDDO - ENDDO - -! x flux divergence -! - IF(degrade_xs) i_start = MAX(its,ids+1) - IF(degrade_xe) i_end = MIN(ite,ide-2) - - DO j = j_start, j_end - DO k = kts, ktf - DO i = i_start, i_end - - ! Un-"canceled" map scale factor, ADT Eq. 48 - tendency (i,k,j) = tendency(i,k,j) & - - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) & - +fqxl(i+1,k,j)-fqxl(i,k,j)) ) - - ENDDO - ENDDO - ENDDO - -! y flux divergence -! - i_start = its - i_end = MIN(ite,ide-1) - IF(degrade_ys) j_start = MAX(jts,jds+1) - IF(degrade_ye) j_end = MIN(jte,jde-2) - - DO j = j_start, j_end - DO k = kts, ktf - DO i = i_start, i_end - - ! Un-"canceled" map scale factor, ADT Eq. 48 - ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606 - tendency (i,k,j) = tendency(i,k,j) & - - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) & - +fqyl(i,k,j+1)-fqyl(i,k,j)) ) - - ENDDO - ENDDO - ENDDO - -END SUBROUTINE advect_scalar_wenopd - -!---------------------------------------------------------------- - -SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & - h_tendency, z_tendency, & - ru, rv, rom, & - mut, mub, mu_old, & - config_flags, & - tenddec, & - msfux, msfuy, msfvx, msfvy, & - msftx, msfty, & - fzm, fzp, & - rdx, rdy, rdzw, dt, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) - -! monotonic advection option -! for scalars in WRF RK3 advection. This version is memory intensive -> -! we save 3d arrays of x, y and z both high and low order fluxes -! (six in all). Alternatively, we could sweep in a direction -! and lower the cost considerably. - -! uses the Smolarkiewicz MWR 1989 approach, with addition of first-order -! fluxes initially - - IMPLICIT NONE - - ! Input data - - TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags - - LOGICAL , INTENT(IN ) :: tenddec ! tendency flag - - INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte - - REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & - field_old, & - ru, & - rv, & - rom - - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, mub, mu_old - REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency - REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT( OUT) :: h_tendency, z_tendency + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, mub, mu_old + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & @@ -8923,11 +8621,14 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & - rdzw + rdzw, & + c1, & + c2 REAL , INTENT(IN ) :: rdx, & rdy, & dt + INTEGER , INTENT(IN ) :: time_step ! Local data @@ -8937,16 +8638,11 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & INTEGER :: jmin, jmax, jp, jm, imin, imax REAL :: mrdx, mrdy, ub, vb, uw, vw, mu - REAL , DIMENSION(its:ite, kts:kte) :: vflux - ! storage for high and low order fluxes - REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: fqx, fqy, fqz - REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: fqxl, fqyl, fqzl - REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: qmin, qmax - REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: scale_in, scale_out - REAL :: ph_upwind + REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqx, fqy, fqz + REAL, DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: fqxl, fqyl, fqzl INTEGER :: horz_order, vert_order @@ -8954,12 +8650,23 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & LOGICAL :: degrade_xe, degrade_ye INTEGER :: jp1, jp0, jtmp - - REAL :: flux_out, ph_low, flux_in, ph_hi, scale + + REAL,DIMENSION( its-1:ite+2, kts:kte, jts-1:jte+2 ) :: flux_out, ph_low + REAL :: scale REAL, PARAMETER :: eps=1.e-20 + real :: dir, vv + real :: ue,vs,vn,wb,wt + real, parameter :: f30 = 7./12., f31 = 1./12. + real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60. -! definition of flux operators, 3rd, 4rth, 5th or 6th order + real :: qim2, qim1, qi, qip1, qip2 + double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk + double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps1=1.0d-28 + integer, parameter :: pw = 2 + + +! definition of flux operators, 3rd, 4th, 5th or 6th order REAL :: flux3, flux4, flux5, flux6, flux_upwind REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr @@ -8969,7 +8676,7 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & flux3(q_im2, q_im1, q_i, q_ip1, ua) = & flux4(q_im2, q_im1, q_i, q_ip1, ua) + & - sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) + sign(1,time_step)*sign(1.,ua)*(1./12.)*((q_ip1 - q_im2)-3.*(q_i-q_im1)) flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & (37./60.)*(q_i+q_im1) - (2./15.)*(q_ip1+q_im2) & @@ -8977,46 +8684,40 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & - -sign(1.,ua)*(1./60.)*( & + -sign(1,time_step)*sign(1.,ua)*(1./60.)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) ) + flux_upwind(q_im1, q_i, cr ) = 0.5*min( 1.0,(cr+abs(cr)))*q_im1 & + +0.5*max(-1.0,(cr-abs(cr)))*q_i + +! flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 & +! +0.5*(1.-sign(1.,cr))*q_i ! flux_upwind(q_im1, q_i, cr ) = 0. - flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 & - +0.5*(1.-sign(1.,cr))*q_i - LOGICAL, PARAMETER :: mono_limit = .true. + REAL :: dx,dy,dz + + LOGICAL, PARAMETER :: pd_limit = .true. ! set order for the advection schemes +! write(6,*) ' in pd advection routine ' + + ! Empty arrays just in case: + IF (config_flags%polar) THEN + fqx(:,:,:) = 0. + fqy(:,:,:) = 0. + fqz(:,:,:) = 0. + fqxl(:,:,:) = 0. + fqyl(:,:,:) = 0. + fqzl(:,:,:) = 0. + END IF + ktf=MIN(kte,kde-1) horz_order = config_flags%h_sca_adv_order vert_order = config_flags%v_sca_adv_order - do j=jts-2,jte+2 - do k=kts,kte - do i=its-2,ite+2 - qmin(i,k,j) = field_old(i,k,j) - qmax(i,k,j) = field_old(i,k,j) - scale_in(i,k,j) = 1. - scale_out(i,k,j) = 1. - fqx(i,k,j) = 0. - fqy(i,k,j) = 0. - fqz(i,k,j) = 0. - fqxl(i,k,j) = 0. - fqyl(i,k,j) = 0. - fqzl(i,k,j) = 0. - enddo - enddo - enddo - -! begin with horizontal flux divergence -! here is the choice of flux operators - - - horizontal_order_test : IF( horz_order == 5 ) THEN - ! determine boundary mods for flux operators -! We degrade the flux operators from 3rd/4rth order +! We degrade the flux operators from 3rd/4th order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application @@ -9027,6 +8728,14 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & degrade_ys = .true. degrade_ye = .true. +! begin with horizontal flux divergence +! here is the choice of flux operators + + +! horizontal_order_test : IF( horz_order == 6 ) THEN + +! ELSE IF( horz_order == 5 ) THEN + IF( config_flags%periodic_x .or. & config_flags%symmetric_xs .or. & (its > ids+3) ) degrade_xs = .false. @@ -9054,23 +8763,11 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & !-- modify loop bounds if open or specified -! WCS 20090218 -! IF(degrade_xs) i_start = its -! IF(degrade_xe) i_end = MIN(ite,ide-1) +! IF(degrade_xs) i_start = MAX(its-1,ids-1) +! IF(degrade_xe) i_end = MIN(ite+1,ide-2) IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) -! WCS 20090218 -! IF(degrade_ys) then -! j_start = MAX(jts,jds+1) -! j_start_f = jds+3 -! ENDIF -! -! IF(degrade_ye) then -! j_end = MIN(jte,jde-2) -! j_end_f = jde-3 -! ENDIF - IF(degrade_ys) then j_start = MAX(jts-1,jds+1) j_start_f = jds+3 @@ -9090,73 +8787,85 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & DO k=kts,ktf DO i = i_start, i_end + dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy + mu = 0.5*(mut(i,j)+mut(i,j-1)) vel = rv(i,k,j) - cr = vel - fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), vel) - - fqy( i, k, j ) = vel*flux5( & - field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & - field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) - - fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) - - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) - else - qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) - qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) - end if - - ENDDO - ENDDO + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN + qip2 = field(i,k,j+1) + qip1 = field(i,k,j ) + qi = field(i,k,j-1) + qim1 = field(i,k,j-2) + qim2 = field(i,k,j-3) + ELSE + qip2 = field(i,k,j-2) + qip1 = field(i,k,j-1) + qi = field(i,k,j ) + qim1 = field(i,k,j+1) + qim2 = field(i,k,j+2) + ENDIF + + f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi + f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 + f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 + + beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 + beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 + beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 + + wi0 = gi0 / (eps1 + beta0)**pw + wi1 = gi1 / (eps1 + beta1)**pw + wi2 = gi2 / (eps1 + beta2)**pw + + sumwk = wi0 + wi1 + wi2 + + fqy( i, k, j ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk + +! fqy( i, k, j ) = vel*flux5( & +! field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & +! field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) + + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + ENDDO + ENDDO ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end + dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy + mu = 0.5*(mut(i,j)+mut(i,j-1)) vel = rv(i,k,j) - cr = vel - fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i,k, j) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) - else - qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) - qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) - end if - ENDDO ENDDO - ELSE IF ( j == jds+2 ) THEN ! third of 4rth order flux 2 in from south boundary + ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end + dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy + mu = 0.5*(mut(i,j)+mut(i,j-1)) vel = rv(i,k,j) - cr = vel - fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j ) = vel*flux3( & field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) - else - qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) - qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) - end if - ENDDO ENDDO @@ -9165,47 +8874,35 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & DO k=kts,ktf DO i = i_start, i_end + dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy + mu = 0.5*(mut(i,j)+mut(i,j-1)) vel = rv(i,k,j) - cr = vel - fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy(i, k, j ) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) - else - qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) - qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) - end if - ENDDO ENDDO - ELSE IF ( j == jde-2 ) THEN ! 3rd or 4rth order flux 2 in from north boundary + ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end + dy = 2./(msftx(i,j)+msftx(i,j-1))/rdy ! ADT eqn 48 d/dy + mu = 0.5*(mut(i,j)+mut(i,j-1)) vel = rv(i,k,j) - cr = vel - fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + cr = vel*dt/dy/mu + fqyl(i,k,j) = mu*(dy/dt)*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) fqy( i, k, j) = vel*flux3( & field(i,k,j-2),field(i,k,j-1), & field(i,k,j),field(i,k,j+1),vel ) fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) - else - qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) - qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) - end if - ENDDO ENDDO @@ -9227,23 +8924,11 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & !-- modify loop bounds for open and specified b.c -! WCS 20090218 -! IF(degrade_ys) j_start = jts -! IF(degrade_ye) j_end = MIN(jte,jde-1) +! IF(degrade_ys) j_start = MAX(jts-1,jds+1) +! IF(degrade_ye) j_end = MIN(jte+1,jde-2) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) -! WCS 20090218 -! IF(degrade_xs) then -! i_start = MAX(ids+1,its) -! i_start_f = i_start+2 -! ENDIF - -! IF(degrade_xe) then -! i_end = MIN(ide-2,ite) -! i_end_f = ide-3 -! ENDIF - IF(degrade_xs) then i_start = MAX(ids+1,its-1) i_start_f = ids+3 @@ -9258,78 +8943,87 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & DO j = j_start, j_end -! 5th or 6th order flux +! 5th order flux DO k=kts,ktf DO i = i_start_f, i_end_f + dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx + mu = 0.5*(mut(i,j)+mut(i-1,j)) vel = ru(i,k,j) - cr = vel - fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) - fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & - field(i-1,k,j), field(i ,k,j), & - field(i+1,k,j), field(i+2,k,j), & - vel ) - fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) - else - qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) - qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) - end if + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN + qip2 = field(i+1,k,j) + qip1 = field(i, k,j) + qi = field(i-1,k,j) + qim1 = field(i-2,k,j) + qim2 = field(i-3,k,j) + ELSE + qip2 = field(i-2,k,j) + qip1 = field(i-1,k,j) + qi = field(i, k,j) + qim1 = field(i+1,k,j) + qim2 = field(i+2,k,j) + ENDIF + + f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi + f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 + f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 + + beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 + beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 + beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 + + wi0 = gi0 / (eps1 + beta0)**pw + wi1 = gi1 / (eps1 + beta1)**pw + wi2 = gi2 / (eps1 + beta2)**pw + + sumwk = wi0 + wi1 + wi2 + + fqx(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk + +! fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & +! field(i-1,k,j), field(i ,k,j), & +! field(i+1,k,j), field(i+2,k,j), & +! vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) -! WCS 20090218 degrade_xs and xe recoded - IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf - vel = ru(i,k,j) - cr = vel - fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) - + dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx + mu = 0.5*(mut(i,j)+mut(i-1,j)) + vel = ru(i,k,j)/mu + cr = vel*dt/dx + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) - fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) - - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) - else - qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) - qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) - end if ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf + dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx + mu = 0.5*(mut(i,j)+mut(i-1,j)) vel = ru(i,k,j) - cr = vel - fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) - - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) - else - qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) - qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) - end if ENDDO ENDIF @@ -9343,53 +9037,46 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf + dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx + mu = 0.5*(mut(i,j)+mut(i-1,j)) vel = ru(i,k,j) - cr = vel - fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) - - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) - else - qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) - qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) - end if ENDDO ENDIF + IF( i == ide-2 ) THEN ! third order flux one in from the boundary DO k=kts,ktf + dx = 2./(msfty(i,j)+msfty(i-1,j))/rdx ! ADT eqn 48 d/dx + mu = 0.5*(mut(i,j)+mut(i-1,j)) vel = ru(i,k,j) - cr = vel - fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + cr = vel*dt/dx/mu + fqxl(i,k,j) = mu*(dx/dt)*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & field(i ,k,j), field(i+1,k,j), & vel ) fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) - - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) - else - qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) - qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) - end if ENDDO ENDIF + ENDDO + ENDIF ENDDO ! enddo for outer J loop - ELSE +!--- end of 5th order horizontal flux calculation - WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_mono, h_order not known ',horz_order - CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) +! ELSE - ENDIF horizontal_order_test +! WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_pd, h_order not known ',horz_order +! CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + +! ENDIF horizontal_order_test ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. @@ -9466,30 +9153,60 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & ENDIF -!-------------------- vertical advection - -!-- loop bounds for periodic or sym conditions - - i_start = its-1 - i_end = MIN(ite,ide-1)+1 - j_start = jts-1 - j_end = MIN(jte,jde-1)+1 - -!-- loop bounds for open or specified conditions + IF( (config_flags%polar) .and. (jts == jds) ) THEN -! WCS 20090218 -! IF(degrade_xs) i_start = its -! IF(degrade_xe) i_end = MIN(ite,ide-1) -! IF(degrade_ys) j_start = jts -! IF(degrade_ye) j_end = MIN(jte,jde-1) + ! Assuming rv(i,k,jds) = 0. + DO i = i_start, i_end + DO k = kts, ktf + vb = MIN( 0.5*rv(i,k,jts+1), 0. ) + tendency(i,k,jts) = tendency(i,k,jts) & + - rdy*( & + vb*( field_old(i,k,jts+1) & + - field_old(i,k,jts ) ) + & + field(i,k,jts)*rv(i,k,jts+1) & + ) + ENDDO + ENDDO + + ENDIF + + IF( (config_flags%polar) .and. (jte == jde)) THEN + + ! Assuming rv(i,k,jde) = 0. + DO i = i_start, i_end + DO k = kts, ktf + vb = MAX( 0.5*rv(i,k,jte-1), 0. ) + tendency(i,k,j_end) = tendency(i,k,j_end) & + - rdy*( & + vb*( field_old(i,k,j_end ) & + - field_old(i,k,j_end-1) ) + & + field(i,k,j_end)*(-rv(i,k,jte-1)) & + ) + ENDDO + ENDDO + + ENDIF + +!-------------------- vertical advection + +!-- loop bounds for periodic or sym conditions + + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + +!-- loop bounds for open or specified conditions IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) IF(degrade_ys) j_start = MAX(jts-1,jds) IF(degrade_ye) j_end = MIN(jte+1,jde-1) +! vert_order_test : IF (vert_order == 6) THEN + - vert_order_test : IF (vert_order == 3) THEN +! ELSE IF (vert_order == 5) THEN DO j = j_start, j_end @@ -9500,108 +9217,117 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & fqzl(i,kde,j) = 0. ENDDO - DO k=kts+2,ktf-1 + DO k=kts+3,ktf-2 DO i = i_start, i_end - + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) vel = rom(i,k,j) - cr = -vel - fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) - fqz(i,k,j) = vel*flux3( & - field(i,k-2,j), field(i,k-1,j), & - field(i,k ,j), field(i,k+1,j), -vel ) - fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) - else - qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) - qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) - end if + IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN + qip2 = field(i,k+1,j) + qip1 = field(i,k ,j) + qi = field(i,k-1,j) + qim1 = field(i,k-2,j) + qim2 = field(i,k-3,j) + ELSE + qip2 = field(i,k-2,j) + qip1 = field(i,k-1,j) + qi = field(i,k ,j) + qim1 = field(i,k+1,j) + qim2 = field(i,k+2,j) + ENDIF + + f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi + f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 + f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 + + beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 + beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 + beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 + + wi0 = gi0 / (eps1 + beta0)**pw + wi1 = gi1 / (eps1 + beta1)**pw + wi2 = gi2 / (eps1 + beta2)**pw + + sumwk = wi0 + wi1 + wi2 + + fqz(i,k,j) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk +! fqz(i,k,j) = vel*flux5( field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & +! field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) ENDDO ENDDO DO i = i_start, i_end k=kts+1 + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) vel = rom(i,k,j) - cr = -vel - fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) - else - qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) - qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) - end if + k=kts+2 + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + + fqz(i,k,j) = vel*flux3( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + k=ktf-1 + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) + vel = rom(i,k,j) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + + fqz(i,k,j) = vel*flux3( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) k=ktf + dz = 2./(rdzw(k)+rdzw(k-1)) + mu = 0.5*(mut(i,j)+mut(i,j)) vel = rom(i,k,j) - cr = -vel - fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + cr = vel*dt/dz/mu + fqzl(i,k,j) = mu*(dz/dt)*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) - if(cr.gt. 0) then - qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) - qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) - else - qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) - qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) - end if ENDDO ENDDO - ELSE - WRITE (wrf_err_message,*) ' advect_scalar_mono, v_order not known ',vert_order - CALL wrf_error_fatal ( wrf_err_message ) +! ELSE - ENDIF vert_order_test +! WRITE (wrf_err_message,*) ' advect_scalar_pd, v_order not known ',vert_order +! CALL wrf_error_fatal ( wrf_err_message ) - IF (mono_limit) THEN +! ENDIF vert_order_test -! montonic filter + IF (pd_limit) THEN + +! positive definite filter i_start = its-1 i_end = MIN(ite,ide-1)+1 j_start = jts-1 j_end = MIN(jte,jde-1)+1 -! WCS 20090218 - !-- loop bounds for open or specified conditions -! -! IF(degrade_xs) i_start = its -! IF(degrade_xe) i_end = MIN(ite,ide-1) -! IF(degrade_ys) j_start = jts -! IF(degrade_ye) j_end = MIN(jte,jde-1) -! -! IF(config_flags%specified .or. config_flags%nested) THEN -! IF (degrade_xs) i_start = MAX(its,ids+1) -! IF (degrade_xe) i_end = MIN(ite,ide-2) -! IF (degrade_ys) j_start = MAX(jts,jds+1) -! IF (degrade_ye) j_end = MIN(jte,jde-2) -! END IF -! -! IF(config_flags%open_xs) THEN -! IF (degrade_xs) i_start = MAX(its,ids+1) -! END IF -! IF(config_flags%open_xe) THEN -! IF (degrade_xe) i_end = MIN(ite,ide-2) -! END IF -! IF(config_flags%open_ys) THEN -! IF (degrade_ys) j_start = MAX(jts,jds+1) -! END IF -! IF(config_flags%open_ye) THEN -! IF (degrade_ye) j_end = MIN(jte,jde-2) -! END IF IF(degrade_xs) i_start = MAX(its-1,ids) IF(degrade_xe) i_end = MIN(ite+1,ide-1) @@ -9627,32 +9353,39 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & IF(config_flags%open_ye) THEN IF (degrade_ye) j_end = MIN(jte+1,jde-2) END IF + ! ADT note: + ! We don't want to change j_start and j_end + ! for polar BC's since we want to calculate + ! fluxes for directions other than y at the + ! edge !-- here is the limiter... DO j=j_start, j_end DO k=kts, ktf +#ifdef XEON_SIMD +!DIR$ simd +#else +!DIR$ vector always +#endif DO i=i_start, i_end - ph_upwind = (mub(i,j)+mu_old(i,j))*field_old(i,k,j) & - - dt*( msftx(i,j)*msfty(i,j)*( & - rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) + & - rdy*(fqyl(i,k,j+1)-fqyl(i,k,j)) ) & - +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) ) - - flux_in = -dt*( (msftx(i,j)*msfty(i,j))*( & - rdx*( min(0.,fqx (i+1,k,j)) & - -max(0.,fqx (i ,k,j)) ) & - +rdy*( min(0.,fqy (i,k,j+1)) & - -max(0.,fqy (i,k,j )) ) ) & - +msfty(i,j)*rdzw(k)*( max(0.,fqz (i,k+1,j)) & - -min(0.,fqz (i,k ,j)) ) ) + ph_low(i,k,j) = (mub(i,j)+mu_old(i,j))*field_old(i,k,j) & + - dt*( msftx(i,j)*msfty(i,j)*( & + rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) + & + rdy*(fqyl(i,k,j+1)-fqyl(i,k,j)) ) & + +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) ) - ph_hi = mut(i,j)*qmax(i,k,j) - ph_upwind - IF( flux_in .gt. ph_hi ) scale_in(i,k,j) = max(0.,ph_hi/(flux_in+eps)) + ENDDO + ENDDO + ENDDO + DO j=j_start, j_end + DO k=kts, ktf +!DIR$ vector always + DO i=i_start, i_end - flux_out = dt*( (msftx(i,j)*msfty(i,j))*( & + flux_out(i,k,j) = dt*( (msftx(i,j)*msfty(i,j))*( & rdx*( max(0.,fqx (i+1,k,j)) & -min(0.,fqx (i ,k,j)) ) & +rdy*( max(0.,fqy (i,k,j+1)) & @@ -9660,53 +9393,36 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & +msfty(i,j)*rdzw(k)*( min(0.,fqz (i,k+1,j)) & -max(0.,fqz (i,k ,j)) ) ) - ph_low = ph_upwind - mut(i,j)*qmin(i,k,j) - IF( flux_out .gt. ph_low ) scale_out(i,k,j) = max(0.,ph_low/(flux_out+eps)) - ENDDO ENDDO ENDDO DO j=j_start, j_end DO k=kts, ktf - DO i=i_start, i_end+1 - IF( fqx (i,k,j) .gt. 0.) then - fqx(i,k,j) = min(scale_in(i,k,j),scale_out(i-1,k,j))*fqx(i,k,j) - ELSE - fqx(i,k,j) = min(scale_out(i,k,j),scale_in(i-1,k,j))*fqx(i,k,j) - ENDIF - ENDDO - ENDDO - ENDDO - - DO j=j_start, j_end+1 - DO k=kts, ktf - DO i=i_start, i_end - IF( fqy (i,k,j) .gt. 0.) then - fqy(i,k,j) = min(scale_in(i,k,j),scale_out(i,k,j-1))*fqy(i,k,j) - ELSE - fqy(i,k,j) = min(scale_out(i,k,j),scale_in(i,k,j-1))*fqy(i,k,j) - ENDIF - ENDDO - ENDDO - ENDDO - - DO j=j_start, j_end - DO k=kts+1, ktf - DO i=i_start, i_end - IF( fqz (i,k,j) .lt. 0.) then - fqz(i,k,j) = min(scale_in(i,k,j),scale_out(i,k-1,j))*fqz(i,k,j) - ELSE - fqz(i,k,j) = min(scale_out(i,k,j),scale_in(i,k-1,j))*fqz(i,k,j) - ENDIF +!DIR$ vector always + DO i=i_start, i_end + + IF( flux_out(i,k,j) .gt. ph_low(i,k,j) ) THEN + + scale = max(0.,ph_low(i,k,j)/(flux_out(i,k,j)+eps)) + IF( fqx (i+1,k,j) .gt. 0.) fqx(i+1,k,j) = scale*fqx(i+1,k,j) + IF( fqx (i ,k,j) .lt. 0.) fqx(i ,k,j) = scale*fqx(i ,k,j) + IF( fqy (i,k,j+1) .gt. 0.) fqy(i,k,j+1) = scale*fqy(i,k,j+1) + IF( fqy (i,k,j ) .lt. 0.) fqy(i,k,j ) = scale*fqy(i,k,j ) +! note: z flux is opposite sign in mass coordinate because +! vertical coordinate decreases with increasing k + IF( fqz (i,k+1,j) .lt. 0.) fqz(i,k+1,j) = scale*fqz(i,k+1,j) + IF( fqz (i,k ,j) .gt. 0.) fqz(i,k ,j) = scale*fqz(i,k ,j) + + END IF + ENDDO ENDDO ENDDO END IF -! add in the mono-limited flux divergence -! we need to fix this for open b.c set *********** +! add in the pd-limited flux divergence i_start = its i_end = MIN(ite,ide-1) @@ -9725,26 +9441,8 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & ENDDO ENDDO - IF(tenddec) THEN - DO j = j_start, j_end - DO k = kts, ktf - DO i = i_start, i_end - - z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) & - +fqzl(i,k+1,j)-fqzl(i,k,j)) - - ENDDO - ENDDO - ENDDO - END IF - ! x flux divergence ! - -! WCS 20090218 -! IF(degrade_xs) i_start = i_start + 1 -! IF(degrade_xe) i_end = i_end - 1 - IF(degrade_xs) i_start = MAX(its,ids+1) IF(degrade_xe) i_end = MIN(ite,ide-2) @@ -9761,29 +9459,10 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & ENDDO ENDDO - IF(tenddec) THEN - DO j = j_start, j_end - DO k = kts, ktf - DO i = i_start, i_end - - h_tendency (i,k,j) = 0. & - - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) & - +fqxl(i+1,k,j)-fqxl(i,k,j)) ) - - ENDDO - ENDDO - ENDDO - END IF - ! y flux divergence ! i_start = its i_end = MIN(ite,ide-1) - -! WCS 20090218 -! IF(degrade_ys) j_start = j_start + 1 -! IF(degrade_ye) j_end = j_end - 1 - IF(degrade_ys) j_start = MAX(jts,jds+1) IF(degrade_ye) j_end = MIN(jte,jde-2) @@ -9792,6 +9471,7 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & DO i = i_start, i_end ! Un-"canceled" map scale factor, ADT Eq. 48 + ! It is correct to use msftx (and not msfty), per W. Skamarock, 20080606 tendency (i,k,j) = tendency(i,k,j) & - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) & +fqyl(i,k,j+1)-fqyl(i,k,j)) ) @@ -9800,58 +9480,55 @@ SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & ENDDO ENDDO - IF(tenddec) THEN - DO j = j_start, j_end - DO k = kts, ktf - DO i = i_start, i_end - - h_tendency (i,k,j) = h_tendency (i,k,j) & - - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) & - +fqyl(i,k,j+1)-fqyl(i,k,j)) ) +END SUBROUTINE advect_scalar_wenopd - ENDDO - ENDDO - ENDDO - END IF +!---------------------------------------------------------------- -END SUBROUTINE advect_scalar_mono +SUBROUTINE advect_scalar_mono ( field, field_old, tendency, & + h_tendency, z_tendency, & + ru, rv, rom, & + c1, c2, & + mut, mub, mu_old, & + config_flags, & + tenddec, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, & + fzm, fzp, & + rdx, rdy, rdzw, dt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) -!----------------------------------------------------------- +! monotonic advection option +! for scalars in WRF RK3 advection. This version is memory intensive -> +! we save 3d arrays of x, y and z both high and low order fluxes +! (six in all). Alternatively, we could sweep in a direction +! and lower the cost considerably. +! uses the Smolarkiewicz MWR 1989 approach, with addition of first-order +! fluxes initially -SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & - ru, rv, rom, & - mut, time_step, config_flags, & - msfux, msfuy, msfvx, msfvy, & - msftx, msfty, & - fzm, fzp, & - rdx, rdy, rdzw, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) -! -! 5th-order WENO (Weighted Essentially Non-Oscillatory) scheme adapted from COMMAS. -! See Jiang and Shu, 1996, J. Comp. Phys. v. 126, 202-223; -! Shu 2003, Int. J. Comp. Fluid Dyn. v. 17 107-118; Also used by Bryan 2005, Mon. Wea. Rev. -! IMPLICIT NONE ! Input data TYPE(grid_config_rec_type), INTENT(IN ) :: config_flags + LOGICAL , INTENT(IN ) :: tenddec ! tendency flag + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte - + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field, & field_old, & ru, & rv, & rom - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut, mub, mu_old REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT( OUT) :: h_tendency, z_tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & @@ -9862,12 +9539,13 @@ SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & - rdzw + rdzw, & + c1, & + c2 REAL , INTENT(IN ) :: rdx, & - rdy - INTEGER , INTENT(IN ) :: time_step - + rdy, & + dt ! Local data @@ -9876,15 +9554,17 @@ SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & INTEGER :: i_start_f, i_end_f, j_start_f, j_end_f INTEGER :: jmin, jmax, jp, jm, imin, imax - INTEGER , PARAMETER :: is=0, js=0, ks=0 - - REAL :: mrdx, mrdy, ub, vb, vw + REAL :: mrdx, mrdy, ub, vb, uw, vw, mu REAL , DIMENSION(its:ite, kts:kte) :: vflux - REAL, DIMENSION( its-is:ite+1, kts:kte ) :: fqx -! REAL, DIMENSION( its:ite+1, kts:kte ) :: fqx - REAL, DIMENSION( its:ite, kts:kte, 2 ) :: fqy +! storage for high and low order fluxes + + REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: fqx, fqy, fqz + REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: fqxl, fqyl, fqzl + REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: qmin, qmax + REAL, DIMENSION( its-2:ite+2, kts:kte, jts-2:jte+2 ) :: scale_in, scale_out + REAL :: ph_upwind INTEGER :: horz_order, vert_order @@ -9893,25 +9573,14 @@ SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & INTEGER :: jp1, jp0, jtmp - real :: dir, vv - real :: ue,uw,vs,vn,wb,wt - real, parameter :: f30 = 7./12., f31 = 1./12. - real, parameter :: f50 = 37./60., f51 = 2./15., f52 = 1./60. - - - integer kt,kb - - - real :: qim2, qim1, qi, qip1, qip2 - double precision :: beta0, beta1, beta2, f0, f1, f2, wi0, wi1, wi2, sumwk - double precision, parameter :: gi0 = 1.d0/10.d0, gi1 = 6.d0/10.d0, gi2 = 3.d0/10.d0, eps=1.0d-28 - integer, parameter :: pw = 2 + REAL :: flux_out, ph_low, flux_in, ph_hi, scale + REAL, PARAMETER :: eps=1.e-20 -! definition of flux operators, 3rd, 4th, 5th or 6th order +! definition of flux operators, 3rd, 4rth, 5th or 6th order - REAL :: flux3, flux4, flux5, flux6 - REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel + REAL :: flux3, flux4, flux5, flux6, flux_upwind + REAL :: q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua, vel, cr flux4(q_im2, q_im1, q_i, q_ip1, ua) = & (7./12.)*(q_i + q_im1) - (1./12.)*(q_ip1 + q_im2) @@ -9926,29 +9595,46 @@ SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & flux5(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) = & flux6(q_im3, q_im2, q_im1, q_i, q_ip1, q_ip2, ua) & - -sign(1,time_step)*sign(1.,ua)*(1./60.)*( & + -sign(1.,ua)*(1./60.)*( & (q_ip2-q_im3)-5.*(q_ip1-q_im2)+10.*(q_i-q_im1) ) - LOGICAL :: specified +! flux_upwind(q_im1, q_i, cr ) = 0. + flux_upwind(q_im1, q_i, cr ) = 0.5*(1.+sign(1.,cr))*q_im1 & + +0.5*(1.-sign(1.,cr))*q_i - specified = .false. - if(config_flags%specified .or. config_flags%nested) specified = .true. + LOGICAL, PARAMETER :: mono_limit = .true. ! set order for the advection schemes ktf=MIN(kte,kde-1) - horz_order = 5 ! config_flags%h_sca_adv_order - vert_order = 5 ! config_flags%v_sca_adv_order + horz_order = config_flags%h_sca_adv_order + vert_order = config_flags%v_sca_adv_order + + do j=jts-2,jte+2 + do k=kts,kte + do i=its-2,ite+2 + qmin(i,k,j) = field_old(i,k,j) + qmax(i,k,j) = field_old(i,k,j) + scale_in(i,k,j) = 1. + scale_out(i,k,j) = 1. + fqx(i,k,j) = 0. + fqy(i,k,j) = 0. + fqz(i,k,j) = 0. + fqxl(i,k,j) = 0. + fqyl(i,k,j) = 0. + fqzl(i,k,j) = 0. + enddo + enddo + enddo ! begin with horizontal flux divergence ! here is the choice of flux operators - - IF( horz_order == 5 ) THEN + horizontal_order_test : IF( horz_order == 5 ) THEN ! determine boundary mods for flux operators -! We degrade the flux operators from 3rd/4th order +! We degrade the flux operators from 3rd/4rth order ! to second order one gridpoint in from the boundaries for ! all boundary conditions except periodic and symmetry - these ! conditions have boundary zone data fill for correct application @@ -9964,7 +9650,7 @@ SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & (its > ids+3) ) degrade_xs = .false. IF( config_flags%periodic_x .or. & config_flags%symmetric_xe .or. & - (ite < ide-3) ) degrade_xe = .false. + (ite < ide-4) ) degrade_xe = .false. IF( config_flags%periodic_y .or. & config_flags%symmetric_ys .or. & (jts > jds+3) ) degrade_ys = .false. @@ -9974,236 +9660,215 @@ SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & !--------------- y - advection first - ktf=MIN(kte,kde-1) - i_start = its - i_end = MIN(ite,ide-1) - +!-- y flux compute; these bounds are for periodic and sym b.c. -! check for U - IF ( is == 1 ) THEN - i_start = its - i_end = ite - IF ( config_flags%open_xs .or. specified ) i_start = MAX(ids+1,its) - IF ( config_flags%open_xe .or. specified ) i_end = MIN(ide-1,ite) - IF ( config_flags%periodic_x ) i_start = its - IF ( config_flags%periodic_x ) i_end = ite - ENDIF + ktf=MIN(kte,kde-1) + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + j_start_f = j_start + j_end_f = j_end+1 - j_start = jts - j_end = MIN(jte,jde-1) +!-- modify loop bounds if open or specified -! higher order flux has a 5 or 7 point stencil, so compute -! bounds so we can switch to second order flux close to the boundary +! WCS 20090218 +! IF(degrade_xs) i_start = its +! IF(degrade_xe) i_end = MIN(ite,ide-1) + IF(degrade_xs) i_start = MAX(its-1,ids) + IF(degrade_xe) i_end = MIN(ite+1,ide-1) - j_start_f = j_start - j_end_f = j_end+1 +! WCS 20090218 +! IF(degrade_ys) then +! j_start = MAX(jts,jds+1) +! j_start_f = jds+3 +! ENDIF +! +! IF(degrade_ye) then +! j_end = MIN(jte,jde-2) +! j_end_f = jde-3 +! ENDIF IF(degrade_ys) then - j_start = MAX(jts,jds+1) + j_start = MAX(jts-1,jds+1) j_start_f = jds+3 ENDIF IF(degrade_ye) then - j_end = MIN(jte,jde-2) + j_end = MIN(jte+1,jde-2) j_end_f = jde-3 ENDIF - IF(config_flags%polar) j_end = MIN(jte,jde-1) - -! compute fluxes, 5th or 6th order - - jp1 = 2 - jp0 = 1 +! compute fluxes, 5th order - j_loop_y_flux_5 : DO j = j_start, j_end+1 + j_loop_y_flux_5 : DO j = j_start, j_end+1 IF( (j >= j_start_f ) .and. (j <= j_end_f) ) THEN ! use full stencil DO k=kts,ktf DO i = i_start, i_end -! vel = rv(i,k,j) - vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) ) - IF ( vel .ge. 0.0 ) THEN - qip2 = field(i,k,j+1) - qip1 = field(i,k,j ) - qi = field(i,k,j-1) - qim1 = field(i,k,j-2) - qim2 = field(i,k,j-3) - ELSE - qip2 = field(i,k,j-2) - qip1 = field(i,k,j-1) - qi = field(i,k,j ) - qim1 = field(i,k,j+1) - qim2 = field(i,k,j+2) - ENDIF - - f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi - f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 - f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 - - beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 - beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 - beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 - - wi0 = gi0 / (eps + beta0)**pw - wi1 = gi1 / (eps + beta1)**pw - wi2 = gi2 / (eps + beta2)**pw - - sumwk = wi0 + wi1 + wi2 - - fqy( i, k, jp1 ) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk + vel = rv(i,k,j) + cr = vel + fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), vel) + + fqy( i, k, j ) = vel*flux5( & + field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & + field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) + + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) + else + qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) + qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) + end if -! fqy( i, k, jp1 ) = vel*flux5( & -! field(i,k,j-3), field(i,k,j-2), field(i,k,j-1), & -! field(i,k,j ), field(i,k,j+1), field(i,k,j+2), vel ) ENDDO ENDDO - ELSE IF ( j == jds+1 ) THEN ! 2nd order flux next to south boundary DO k=kts,ktf DO i = i_start, i_end - fqy(i,k, jp1) = 0.5*rv(i,k,j)* & -! fqy(i,k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )* & + + vel = rv(i,k,j) + cr = vel + fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy(i,k, j) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) + else + qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) + qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) + end if + ENDDO ENDDO - ELSE IF ( j == jds+2 ) THEN ! third of 4th order flux 2 in from south boundary + ELSE IF ( j == jds+2 ) THEN ! third of 4rth order flux 2 in from south boundary DO k=kts,ktf DO i = i_start, i_end -! vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) ) + vel = rv(i,k,j) - fqy( i, k, jp1 ) = vel*flux3( & + cr = vel + fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy( i, k, j ) = vel*flux3( & field(i,k,j-2),field(i,k,j-1),field(i,k,j),field(i,k,j+1),vel ) + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) + else + qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) + qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) + end if + ENDDO ENDDO - ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary + ELSE IF ( j == jde-1 ) THEN ! 2nd order flux next to north boundary DO k=kts,ktf DO i = i_start, i_end -! fqy(i, k, jp1) = 0.5*0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) )* & - fqy(i, k, jp1) = 0.5*rv(i,k,j)* & + + vel = rv(i,k,j) + cr = vel + fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy(i, k, j ) = 0.5*rv(i,k,j)* & (field(i,k,j)+field(i,k,j-1)) + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) + + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) + else + qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) + qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) + end if + ENDDO ENDDO - ELSE IF ( j == jde-2 ) THEN ! 3rd or 4th order flux 2 in from north boundary + ELSE IF ( j == jde-2 ) THEN ! 3rd or 4rth order flux 2 in from north boundary DO k=kts,ktf DO i = i_start, i_end + vel = rv(i,k,j) -! vel = 0.5*( rv(i,k,j) + rv(i-is,k-ks,j-js) ) - fqy( i, k, jp1) = vel*flux3( & + cr = vel + fqyl(i,k,j) = vel*flux_upwind(field_old(i,k,j-1), field_old(i,k,j ), cr) + + fqy( i, k, j) = vel*flux3( & field(i,k,j-2),field(i,k,j-1), & field(i,k,j),field(i,k,j+1),vel ) - ENDDO - ENDDO - - ENDIF - -! y flux-divergence into tendency - - IF ( is == 0 ) THEN - ! Comments on polar boundary conditions - ! Same process as for advect_u - tendencies run from jds to jde-1 - ! (latitudes are as for u grid, longitudes are displaced) - ! Therefore: flow is only from one side for points next to poles - IF ( config_flags%polar .AND. (j == jds+1) ) THEN - DO k=kts,ktf - DO i = i_start, i_end - mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS - tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) - END DO - END DO - ELSE IF( config_flags%polar .AND. (j == jde) ) THEN - DO k=kts,ktf - DO i = i_start, i_end - mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS - tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) - END DO - END DO - ELSE ! normal code - - IF(j > j_start) THEN - - DO k=kts,ktf - DO i = i_start, i_end - mrdy=msftx(i,j-1)*rdy ! see ADT eqn 48 [rho->rho*q] dividing by my, 2nd term RHS - tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) - ENDDO - ENDDO - - ENDIF - ENDIF - ELSEIF ( is == 1 ) THEN + fqy(i,k,j) = fqy(i,k,j) - fqyl(i,k,j) - ! (j > j_start) will miss the u(,,jds) tendency - IF ( config_flags%polar .AND. (j == jds+1) ) THEN - DO k=kts,ktf - DO i = i_start, i_end - mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS - tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*fqy(i,k,jp1) - END DO - END DO - ! This would be seen by (j > j_start) but we need to zero out the NP tendency - ELSE IF( config_flags%polar .AND. (j == jde) ) THEN - DO k=kts,ktf - DO i = i_start, i_end - mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS - tendency(i,k,j-1) = tendency(i,k,j-1) + mrdy*fqy(i,k,jp0) - END DO - END DO - ELSE ! normal code + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k,j-1)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k,j-1)) + else + qmax(i,k,j-1) = amax1(qmax(i,k,j-1),field_old(i,k,j)) + qmin(i,k,j-1) = amin1(qmin(i,k,j-1),field_old(i,k,j)) + end if - IF(j > j_start) THEN + ENDDO + ENDDO - DO k=kts,ktf - DO i = i_start, i_end - mrdy=msfux(i,j-1)*rdy ! ADT eqn 44, 2nd term on RHS - tendency(i,k,j-1) = tendency(i,k,j-1) - mrdy*(fqy(i,k,jp1)-fqy(i,k,jp0)) - ENDDO - ENDDO + ENDIF - ENDIF + ENDDO j_loop_y_flux_5 - END IF - - ENDIF +! next, x flux - jtmp = jp1 - jp1 = jp0 - jp0 = jtmp +!-- these bounds are for periodic and sym conditions - ENDDO j_loop_y_flux_5 + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + i_start_f = i_start + i_end_f = i_end+1 -! next, x - flux divergence + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 - i_start = its - i_end = MIN(ite,ide-1) +!-- modify loop bounds for open and specified b.c - j_start = jts - j_end = MIN(jte,jde-1) +! WCS 20090218 +! IF(degrade_ys) j_start = jts +! IF(degrade_ye) j_end = MIN(jte,jde-1) + IF(degrade_ys) j_start = MAX(jts-1,jds) + IF(degrade_ye) j_end = MIN(jte+1,jde-1) -! higher order flux has a 5 or 7 point stencil, so compute -! bounds so we can switch to second order flux close to the boundary +! WCS 20090218 +! IF(degrade_xs) then +! i_start = MAX(ids+1,its) +! i_start_f = i_start+2 +! ENDIF - i_start_f = i_start - i_end_f = i_end+1 +! IF(degrade_xe) then +! i_end = MIN(ide-2,ite) +! i_end_f = ide-3 +! ENDIF IF(degrade_xs) then - i_start = MAX(ids+1,its) -! i_start_f = i_start+2 - i_start_f = MIN(i_start+2,ids+3) + i_start = MAX(ids+1,its-1) + i_start_f = ids+3 ENDIF IF(degrade_xe) then - i_end = MIN(ide-2,ite) + i_end = MIN(ide-2,ite+1) i_end_f = ide-3 ENDIF @@ -10215,68 +9880,76 @@ SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & DO k=kts,ktf DO i = i_start_f, i_end_f -! vel = ru(i,k,j) - vel = 0.5*( ru(i,k,j) + ru(i-is,k-ks,j-js) ) + vel = ru(i,k,j) + cr = vel + fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) - IF ( vel .ge. 0.0 ) THEN - qip2 = field(i+1,k,j) - qip1 = field(i, k,j) - qi = field(i-1,k,j) - qim1 = field(i-2,k,j) - qim2 = field(i-3,k,j) - ELSE - qip2 = field(i-2,k,j) - qip1 = field(i-1,k,j) - qi = field(i, k,j) - qim1 = field(i+1,k,j) - qim2 = field(i+2,k,j) - ENDIF - - f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi - f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 - f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 - - beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 - beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 - beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 - - wi0 = gi0 / (eps + beta0)**pw - wi1 = gi1 / (eps + beta1)**pw - wi2 = gi2 / (eps + beta2)**pw - - sumwk = wi0 + wi1 + wi2 - - fqx(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk + fqx( i,k,j ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & + field(i-1,k,j), field(i ,k,j), & + field(i+1,k,j), field(i+2,k,j), & + vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) + else + qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) + qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) + end if -! fqx( i,k ) = vel*flux5( field(i-3,k,j), field(i-2,k,j), & -! field(i-1,k,j), field(i ,k,j), & -! field(i+1,k,j), field(i+2,k,j), & -! vel ) ENDDO ENDDO ! lower order fluxes close to boundaries (if not periodic or symmetric) +! WCS 20090218 degrade_xs and xe recoded + IF( degrade_xs ) THEN DO i=i_start,i_start_f-1 IF(i == ids+1) THEN ! second order DO k=kts,ktf - fqx(i,k) = 0.5*(ru(i,k,j)) & + vel = ru(i,k,j) + cr = vel + fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + + fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) + + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) + else + qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) + qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) + end if ENDDO ENDIF IF(i == ids+2) THEN ! third order DO k=kts,ktf vel = ru(i,k,j) - fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & - field(i ,k,j), field(i+1,k,j), & - vel ) + cr = vel + fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) + + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) + else + qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) + qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) + end if ENDDO - END IF + ENDIF ENDDO @@ -10288,47 +9961,53 @@ SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & IF( i == ide-1 ) THEN ! second order flux next to the boundary DO k=kts,ktf - fqx(i,k) = 0.5*(ru(i,k,j)) & + vel = ru(i,k,j) + cr = vel + fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx(i,k,j) = 0.5*(ru(i,k,j)) & *(field(i,k,j)+field(i-1,k,j)) - ENDDO - ENDIF - - IF( i == ide-2 ) THEN ! third order flux one in from the boundary - DO k=kts,ktf - vel = ru(i,k,j) - fqx( i,k ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & - field(i ,k,j), field(i+1,k,j), & - vel ) - ENDDO - ENDIF - - ENDDO + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) - ENDIF + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) + else + qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) + qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) + end if + ENDDO + ENDIF -! x flux-divergence into tendency + IF( i == ide-2 ) THEN ! third order flux one in from the boundary + DO k=kts,ktf + vel = ru(i,k,j) + cr = vel + fqxl(i,k,j) = vel*flux_upwind(field_old(i-1,k,j), field_old(i,k,j ), cr) + fqx( i,k,j ) = vel*flux3( field(i-2,k,j), field(i-1,k,j), & + field(i ,k,j), field(i+1,k,j), & + vel ) + fqx(i,k,j) = fqx(i,k,j) - fqxl(i,k,j) - IF ( is == 0 ) THEN - DO k=kts,ktf - DO i = i_start, i_end - mrdx=msftx(i,j)*rdx ! see ADT eqn 48 [rho->rho*q] dividing by my, 1st term RHS - tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) - ENDDO - ENDDO - ELSEIF ( is == 1 ) THEN - DO k=kts,ktf - DO i = i_start, i_end - mrdx=msfux(i,j)*rdx ! ADT eqn 44, 1st term on RHS - tendency(i,k,j) = tendency(i,k,j) - mrdx*(fqx(i+1,k)-fqx(i,k)) + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i-1,k,j)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i-1,k,j)) + else + qmax(i-1,k,j) = amax1(qmax(i-1,k,j),field_old(i,k,j)) + qmin(i-1,k,j) = amin1(qmin(i-1,k,j),field_old(i,k,j)) + end if + ENDDO + ENDIF ENDDO - ENDDO - ENDIF + ENDIF - ENDDO + ENDDO ! enddo for outer J loop + ELSE - ENDIF - + WRITE ( wrf_err_message , * ) 'module_advect: advect_scalar_mono, h_order not known ',horz_order + CALL wrf_error_fatal ( TRIM( wrf_err_message ) ) + + ENDIF horizontal_order_test ! pick up the rest of the horizontal radiation boundary conditions. ! (these are the computations that don't require 'cb'. @@ -10405,103 +10084,658 @@ SUBROUTINE advect_scalar_weno ( field, field_old, tendency, & ENDIF - !-------------------- vertical advection -! Scalar equation has 3rd term on RHS = - partial d/dz (q rho w /my) -! Here we have: - partial d/dz (q*rom) = - partial d/dz (q rho w / my) -! So we don't need to make a correction for advect_scalar - i_start = its - i_end = MIN(ite,ide-1) - j_start = jts - j_end = MIN(jte,jde-1) +!-- loop bounds for periodic or sym conditions - DO i = i_start, i_end - vflux(i,kts)=0. - vflux(i,kte)=0. - ENDDO + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 +!-- loop bounds for open or specified conditions +! WCS 20090218 +! IF(degrade_xs) i_start = its +! IF(degrade_xe) i_end = MIN(ite,ide-1) +! IF(degrade_ys) j_start = jts +! IF(degrade_ye) j_end = MIN(jte,jde-1) - DO j = j_start, j_end + IF(degrade_xs) i_start = MAX(its-1,ids) + IF(degrade_xe) i_end = MIN(ite+1,ide-1) + IF(degrade_ys) j_start = MAX(jts-1,jds) + IF(degrade_ye) j_end = MIN(jte+1,jde-1) - DO k=kts+3,ktf-2 - DO i = i_start, i_end -! vel = rom(i,k,j) - vel = 0.5*( rom(i,k,j) + rom(i-is,k-ks,j-js) ) - IF( -vel .ge. 0.0 ) THEN - qip2 = field(i,k+1,j) - qip1 = field(i,k ,j) - qi = field(i,k-1,j) - qim1 = field(i,k-2,j) - qim2 = field(i,k-3,j) - ELSE - qip2 = field(i,k-2,j) - qip1 = field(i,k-1,j) - qi = field(i,k ,j) - qim1 = field(i,k+1,j) - qim2 = field(i,k+2,j) - ENDIF - - f0 = 1./3.*qim2 - 7./6.*qim1 + 11./6.*qi - f1 = -1./6.*qim1 + 5./6.*qi + 1./3. *qip1 - f2 = 1./3.*qi + 5./6.*qip1 - 1./6. *qip2 - - beta0 = 13./12.*(qim2 - 2.*qim1 + qi )**2 + 1./4.*(qim2 - 4.*qim1 + 3.*qi)**2 - beta1 = 13./12.*(qim1 - 2.*qi + qip1)**2 + 1./4.*(qim1 - qip1)**2 - beta2 = 13./12.*(qi - 2.*qip1 + qip2)**2 + 1./4.*(qip2 - 4.*qip1 + 3.*qi)**2 - - wi0 = gi0 / (eps + beta0)**pw - wi1 = gi1 / (eps + beta1)**pw - wi2 = gi2 / (eps + beta2)**pw - - sumwk = wi0 + wi1 + wi2 - - vflux(i,k) = vel * (wi0*f0 + wi1*f1 + wi2*f2) / sumwk + vert_order_test : IF (vert_order == 3) THEN -! vflux(i,k) = vel*flux5( & -! field(i,k-3,j), field(i,k-2,j), field(i,k-1,j), & -! field(i,k ,j), field(i,k+1,j), field(i,k+2,j), -vel ) - ENDDO + DO j = j_start, j_end + + DO i = i_start, i_end + fqz(i,1,j) = 0. + fqzl(i,1,j) = 0. + fqz(i,kde,j) = 0. + fqzl(i,kde,j) = 0. ENDDO + DO k=kts+2,ktf-1 DO i = i_start, i_end - k=kts+1 - vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) - - k = kts+2 - vel=rom(i,k,j) - vflux(i,k) = vel*flux3( & - field(i,k-2,j), field(i,k-1,j), & - field(i,k ,j), field(i,k+1,j), -vel ) - k = ktf-1 - vel=rom(i,k,j) - vflux(i,k) = vel*flux3( & - field(i,k-2,j), field(i,k-1,j), & - field(i,k ,j), field(i,k+1,j), -vel ) + vel = rom(i,k,j) + cr = -vel + fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) - k=ktf - vflux(i,k)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) - ENDDO + fqz(i,k,j) = vel*flux3( & + field(i,k-2,j), field(i,k-1,j), & + field(i,k ,j), field(i,k+1,j), -vel ) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) + else + qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) + qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) + end if - DO k=kts,ktf - DO i = i_start, i_end - tendency(i,k,j)=tendency(i,k,j)-rdzw(k)*(vflux(i,k+1)-vflux(i,k)) ENDDO ENDDO - ENDDO - + DO i = i_start, i_end + k=kts+1 + vel = rom(i,k,j) + cr = -vel + fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) -END SUBROUTINE advect_scalar_weno + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) + else + qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) + qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) + end if + + k=ktf + vel = rom(i,k,j) + cr = -vel + fqzl(i,k,j) = vel*flux_upwind(field_old(i,k-1,j), field_old(i,k,j ), cr) + fqz(i,k,j)=rom(i,k,j)*(fzm(k)*field(i,k,j)+fzp(k)*field(i,k-1,j)) + fqz(i,k,j) = fqz(i,k,j) - fqzl(i,k,j) + + if(cr.gt. 0) then + qmax(i,k,j) = amax1(qmax(i,k,j),field_old(i,k-1,j)) + qmin(i,k,j) = amin1(qmin(i,k,j),field_old(i,k-1,j)) + else + qmax(i,k-1,j) = amax1(qmax(i,k-1,j),field_old(i,k,j)) + qmin(i,k-1,j) = amin1(qmin(i,k-1,j),field_old(i,k,j)) + end if + ENDDO + + ENDDO + + ELSE + + WRITE (wrf_err_message,*) ' advect_scalar_mono, v_order not known ',vert_order + CALL wrf_error_fatal ( wrf_err_message ) + + ENDIF vert_order_test + + IF (mono_limit) THEN + +! montonic filter + + i_start = its-1 + i_end = MIN(ite,ide-1)+1 + j_start = jts-1 + j_end = MIN(jte,jde-1)+1 + +! WCS 20090218 + +!-- loop bounds for open or specified conditions +! +! IF(degrade_xs) i_start = its +! IF(degrade_xe) i_end = MIN(ite,ide-1) +! IF(degrade_ys) j_start = jts +! IF(degrade_ye) j_end = MIN(jte,jde-1) +! +! IF(config_flags%specified .or. config_flags%nested) THEN +! IF (degrade_xs) i_start = MAX(its,ids+1) +! IF (degrade_xe) i_end = MIN(ite,ide-2) +! IF (degrade_ys) j_start = MAX(jts,jds+1) +! IF (degrade_ye) j_end = MIN(jte,jde-2) +! END IF +! +! IF(config_flags%open_xs) THEN +! IF (degrade_xs) i_start = MAX(its,ids+1) +! END IF +! IF(config_flags%open_xe) THEN +! IF (degrade_xe) i_end = MIN(ite,ide-2) +! END IF +! IF(config_flags%open_ys) THEN +! IF (degrade_ys) j_start = MAX(jts,jds+1) +! END IF +! IF(config_flags%open_ye) THEN +! IF (degrade_ye) j_end = MIN(jte,jde-2) +! END IF + + IF(degrade_xs) i_start = MAX(its-1,ids) + IF(degrade_xe) i_end = MIN(ite+1,ide-1) + IF(degrade_ys) j_start = MAX(jts-1,jds) + IF(degrade_ye) j_end = MIN(jte+1,jde-1) + + IF(config_flags%specified .or. config_flags%nested) THEN + IF (degrade_xs) i_start = MAX(its-1,ids+1) + IF (degrade_xe) i_end = MIN(ite+1,ide-2) + IF (degrade_ys) j_start = MAX(jts-1,jds+1) + IF (degrade_ye) j_end = MIN(jte+1,jde-2) + END IF + + IF(config_flags%open_xs) THEN + IF (degrade_xs) i_start = MAX(its-1,ids+1) + END IF + IF(config_flags%open_xe) THEN + IF (degrade_xe) i_end = MIN(ite+1,ide-2) + END IF + IF(config_flags%open_ys) THEN + IF (degrade_ys) j_start = MAX(jts-1,jds+1) + END IF + IF(config_flags%open_ye) THEN + IF (degrade_ye) j_end = MIN(jte+1,jde-2) + END IF + +!-- here is the limiter... + + DO j=j_start, j_end + DO k=kts, ktf + DO i=i_start, i_end + + ph_upwind = (mub(i,j)+mu_old(i,j))*field_old(i,k,j) & + - dt*( msftx(i,j)*msfty(i,j)*( & + rdx*(fqxl(i+1,k,j)-fqxl(i,k,j)) + & + rdy*(fqyl(i,k,j+1)-fqyl(i,k,j)) ) & + +msfty(i,j)*rdzw(k)*(fqzl(i,k+1,j)-fqzl(i,k,j)) ) + + flux_in = -dt*( (msftx(i,j)*msfty(i,j))*( & + rdx*( min(0.,fqx (i+1,k,j)) & + -max(0.,fqx (i ,k,j)) ) & + +rdy*( min(0.,fqy (i,k,j+1)) & + -max(0.,fqy (i,k,j )) ) ) & + +msfty(i,j)*rdzw(k)*( max(0.,fqz (i,k+1,j)) & + -min(0.,fqz (i,k ,j)) ) ) + + ph_hi = mut(i,j)*qmax(i,k,j) - ph_upwind + IF( flux_in .gt. ph_hi ) scale_in(i,k,j) = max(0.,ph_hi/(flux_in+eps)) + + + flux_out = dt*( (msftx(i,j)*msfty(i,j))*( & + rdx*( max(0.,fqx (i+1,k,j)) & + -min(0.,fqx (i ,k,j)) ) & + +rdy*( max(0.,fqy (i,k,j+1)) & + -min(0.,fqy (i,k,j )) ) ) & + +msfty(i,j)*rdzw(k)*( min(0.,fqz (i,k+1,j)) & + -max(0.,fqz (i,k ,j)) ) ) + + ph_low = ph_upwind - mut(i,j)*qmin(i,k,j) + IF( flux_out .gt. ph_low ) scale_out(i,k,j) = max(0.,ph_low/(flux_out+eps)) + + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_end + DO k=kts, ktf + DO i=i_start, i_end+1 + IF( fqx (i,k,j) .gt. 0.) then + fqx(i,k,j) = min(scale_in(i,k,j),scale_out(i-1,k,j))*fqx(i,k,j) + ELSE + fqx(i,k,j) = min(scale_out(i,k,j),scale_in(i-1,k,j))*fqx(i,k,j) + ENDIF + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_end+1 + DO k=kts, ktf + DO i=i_start, i_end + IF( fqy (i,k,j) .gt. 0.) then + fqy(i,k,j) = min(scale_in(i,k,j),scale_out(i,k,j-1))*fqy(i,k,j) + ELSE + fqy(i,k,j) = min(scale_out(i,k,j),scale_in(i,k,j-1))*fqy(i,k,j) + ENDIF + ENDDO + ENDDO + ENDDO + + DO j=j_start, j_end + DO k=kts+1, ktf + DO i=i_start, i_end + IF( fqz (i,k,j) .lt. 0.) then + fqz(i,k,j) = min(scale_in(i,k,j),scale_out(i,k-1,j))*fqz(i,k,j) + ELSE + fqz(i,k,j) = min(scale_out(i,k,j),scale_in(i,k-1,j))*fqz(i,k,j) + ENDIF + ENDDO + ENDDO + ENDDO + + END IF + +! add in the mono-limited flux divergence +! we need to fix this for open b.c set *********** + + i_start = its + i_end = MIN(ite,ide-1) + j_start = jts + j_end = MIN(jte,jde-1) + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + tendency (i,k,j) = tendency(i,k,j) & + -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) & + +fqzl(i,k+1,j)-fqzl(i,k,j)) + + ENDDO + ENDDO + ENDDO + + IF(tenddec) THEN + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + z_tendency (i,k,j) = 0. -rdzw(k)*( fqz (i,k+1,j)-fqz (i,k,j) & + +fqzl(i,k+1,j)-fqzl(i,k,j)) + + ENDDO + ENDDO + ENDDO + END IF + +! x flux divergence +! + +! WCS 20090218 +! IF(degrade_xs) i_start = i_start + 1 +! IF(degrade_xe) i_end = i_end - 1 + + IF(degrade_xs) i_start = MAX(its,ids+1) + IF(degrade_xe) i_end = MIN(ite,ide-2) + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + ! Un-"canceled" map scale factor, ADT Eq. 48 + tendency (i,k,j) = tendency(i,k,j) & + - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) & + +fqxl(i+1,k,j)-fqxl(i,k,j)) ) + + ENDDO + ENDDO + ENDDO + + IF(tenddec) THEN + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + h_tendency (i,k,j) = 0. & + - msftx(i,j)*( rdx*( fqx (i+1,k,j)-fqx (i,k,j) & + +fqxl(i+1,k,j)-fqxl(i,k,j)) ) + + ENDDO + ENDDO + ENDDO + END IF + +! y flux divergence +! + i_start = its + i_end = MIN(ite,ide-1) + +! WCS 20090218 +! IF(degrade_ys) j_start = j_start + 1 +! IF(degrade_ye) j_end = j_end - 1 + + IF(degrade_ys) j_start = MAX(jts,jds+1) + IF(degrade_ye) j_end = MIN(jte,jde-2) + + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + ! Un-"canceled" map scale factor, ADT Eq. 48 + tendency (i,k,j) = tendency(i,k,j) & + - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) & + +fqyl(i,k,j+1)-fqyl(i,k,j)) ) + + ENDDO + ENDDO + ENDDO + + IF(tenddec) THEN + DO j = j_start, j_end + DO k = kts, ktf + DO i = i_start, i_end + + h_tendency (i,k,j) = h_tendency (i,k,j) & + - msftx(i,j)*( rdy*( fqy (i,k,j+1)-fqy (i,k,j) & + +fqyl(i,k,j+1)-fqyl(i,k,j)) ) + + ENDDO + ENDDO + ENDDO + END IF + +END SUBROUTINE advect_scalar_mono + +!----------------------------------------------------------- + +#if ( defined(ADVECT_KERNEL) ) + +END MODULE advection_kernel +!================================================================ +!================================================================ +PROGRAM feeder + USE advection_kernel + IMPLICIT NONE + INTEGER , PARAMETER :: MAX_SCALARS = 1 + TYPE(grid_config_rec_type) :: config_flags + LOGICAL :: tenddec = .false. + INTEGER :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + REAL , DIMENSION( :,:,:,: ) , ALLOCATABLE :: field, & + field_old + REAL , DIMENSION( :,:,: ) , ALLOCATABLE :: ru, & + rv, & + rom + REAL , DIMENSION( :,: ), ALLOCATABLE :: mut, mub, mu_old + REAL , DIMENSION( :,:,: ), ALLOCATABLE :: tendency + REAL , DIMENSION( :,:,: ), ALLOCATABLE :: h_tendency, z_tendency + REAL , DIMENSION( :,: ), ALLOCATABLE :: msfux, & + msfuy, & + msfvx, & + msfvy, & + msftx, & + msfty + REAL , DIMENSION( : ), ALLOCATABLE :: fzm, & + fzp, & + rdzw, znw,dnw, rdnw, dn, rdn + REAL :: rdx, & + rdy, & + dt + INTEGER :: time_step, im + INTEGER :: i, j, k, n, loop + + config_flags%scalar_adv_opt = 2 + + PRINT *,'Init dimensions' + ids = 1; ide = 91; jds = 1; jde = 3; kds = 1; kde =10 + ims = -5; ime = 96; jms = -5; jme = 8; kms = 1; kme = 10 + its = 1; ite = 91; jts = 1; jte = 3; kts = 1; kte = 10 + PRINT *,'ALLOCATE two 4d fields' + PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1)*MAX_SCALARS + ALLOCATE ( field(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) ) + ALLOCATE ( field_old(ims:ime , kms:kme , jms:jme, MAX_SCALARS ) ) + PRINT *,'ALLOCATE three 3d fields U, V, W' + PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1) + ALLOCATE ( ru(ims:ime , kms:kme , jms:jme ) ) + ALLOCATE ( rv(ims:ime , kms:kme , jms:jme ) ) + ALLOCATE ( rom(ims:ime , kms:kme , jms:jme ) ) + PRINT *,'ALLOCATE three 2d MU fields' + PRINT *,(ime-ims+1)*(jme-jms+1) + ALLOCATE ( mut( ims:ime , jms:jme ) ) + ALLOCATE ( mub( ims:ime , jms:jme ) ) + ALLOCATE ( mu_old( ims:ime , jms:jme ) ) + PRINT *,'ALLOCATE three 3d tendency' + PRINT *,(ime-ims+1)*(kme-kms+1)*(jme-jms+1) + ALLOCATE ( tendency( ims:ime , kms:kme , jms:jme ) ) + ALLOCATE ( h_tendency( ims:ime , kms:kme , jms:jme ) ) + ALLOCATE ( z_tendency( ims:ime , kms:kme , jms:jme ) ) + PRINT *,'ALLOCATE six 2d map factors' + PRINT *,(ime-ims+1)*(jme-jms+1) + ALLOCATE ( msfux( ims:ime , jms:jme ) ) + ALLOCATE ( msfuy( ims:ime , jms:jme ) ) + ALLOCATE ( msfvx( ims:ime , jms:jme ) ) + ALLOCATE ( msfvy( ims:ime , jms:jme ) ) + ALLOCATE ( msftx( ims:ime , jms:jme ) ) + ALLOCATE ( msfty( ims:ime , jms:jme ) ) + PRINT *,'ALLOCATE 1d arrays' + ALLOCATE ( fzm( kms:kme ) ) + ALLOCATE ( fzp( kms:kme ) ) + ALLOCATE ( rdzw( kms:kme ) ) + ALLOCATE ( znw( kms:kme ) ) + ALLOCATE ( dnw( kms:kme ) ) + ALLOCATE (rdnw( kms:kme ) ) + ALLOCATE ( dn ( kms:kme ) ) + ALLOCATE (rdn ( kms:kme ) ) + PRINT *,'CALL init' + CALL init ( config_flags) + CALL tophat ( field , MAX_SCALARS ,& + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + CALL tophat ( field_old , MAX_SCALARS , & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + h_tendency = 0 + z_tendency = 0 + mub = 1 + mut = 1 + mu_old = 0 + ru = 90 + rv = 0 + rom = 0 + msfux = 1 + msfuy = 1 + msfvx = 1 + msfvy = 1 + msftx = 1 + msfty = 1 + rdx = 1/1000. + rdy = 1/1000. + DO k = kts, kte + znw(k) = 1 - (real(k)-kts)/(real(kte)-kts) + END DO + DO k = kts, kte-1 + rdzw(k) = 1./(znw(k)-znw(k+1)) + END DO + DO k=1, kde-1 + dnw(k) = znw(k+1) - znw(k) + rdnw(k) = 1./dnw(k) + ENDDO + DO k=2, kde-1 + dn(k) = 0.5*(dnw(k)+dnw(k-1)) + rdn(k) = 1./dn(k) + fzp(k) = .5* dnw(k )/dn(k) + fzm(k) = .5* dnw(k-1)/dn(k) + ENDDO + + time_step = 5 + dt = time_step + + field = field_old + + ! Loop over advection enough times to get some meaningful timings. + CALL column ( 0 , field(:,1,2,1) , its, ite ) + DO loop = 1 , 2000 + ! A representative number of times to call the advection in a time period. + IF ( loop .EQ. ((loop)/200)*200 )THEN + PRINT *,'LOOP over scalars',loop + END IF + DO im = 1 , MAX_SCALARS + + tendency = 0 + CALL advect_scalar ( field(ims,kms,jms,im), & + field_old(ims,kms,jms,im), & + tendency(ims,kms,jms), & + ru, rv, rom, & + mut, time_step/3, config_flags, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, & + fzm, fzp, & + rdx, rdy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + DO n = 1 , MAX_SCALARS + field(:,:,:,n) = field_old(:,:,:,n) + dt * tendency(:,:,:) / 3. + END DO + + tendency = 0 + CALL advect_scalar ( field(ims,kms,jms,im), & + field_old(ims,kms,jms,im), & + tendency(ims,kms,jms), & + ru, rv, rom, & + mut, time_step/2, config_flags, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, & + fzm, fzp, & + rdx, rdy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + DO n = 1 , MAX_SCALARS + field(:,:,:,n) = field_old(:,:,:,n) + dt * tendency(:,:,:) / 2. + END DO + + tendency = 0 + IF (config_flags%scalar_adv_opt .EQ. 0 ) THEN + CALL advect_scalar ( field(ims,kms,jms,im), & + field_old(ims,kms,jms,im), & + tendency(ims,kms,jms), & + ru, rv, rom, & + mut, time_step, config_flags, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, & + fzm, fzp, & + rdx, rdy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ELSE IF (config_flags%scalar_adv_opt .EQ. 1 ) THEN + CALL advect_scalar_pd ( field(ims,kms,jms,im), & + field_old(ims,kms,jms,im), & + tendency(ims,kms,jms), & + h_tendency(ims,kms,jms), & + z_tendency(ims,kms,jms), & + ru, rv, rom, mut, mub, mu_old, & + time_step, config_flags, tenddec, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, fzm, fzp, & + rdx, rdy, rdzw,dt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ELSE IF (config_flags%scalar_adv_opt .EQ. 2 ) THEN + CALL advect_scalar_mono ( field(ims,kms,jms,im), & + field_old(ims,kms,jms,im), & + tendency(ims,kms,jms), & + h_tendency(ims,kms,jms), & + z_tendency(ims,kms,jms), & + ru, rv, rom, mut, mub, mu_old, & + config_flags, tenddec, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, fzm, fzp, & + rdx, rdy, rdzw,dt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ELSE IF (config_flags%scalar_adv_opt .EQ. 3 ) THEN + CALL advect_scalar_weno ( field(ims,kms,jms,im), & + field_old(ims,kms,jms,im), & + tendency(ims,kms,jms), & + ru, rv, rom, & + mut, time_step, config_flags, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, & + fzm, fzp, & + rdx, rdy, rdzw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ELSE IF (config_flags%scalar_adv_opt .EQ. 4 ) THEN + CALL advect_scalar_wenopd ( field(ims,kms,jms,im), & + field_old(ims,kms,jms,im), & + tendency(ims,kms,jms), & + ru, rv, rom, & + mut, mub, mu_old, & + time_step, config_flags, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, & + fzm, fzp, & + rdx, rdy, rdzw, dt, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + END IF + DO n = 1 , MAX_SCALARS + field(:,:,:,n) = field_old(:,:,:,n) + dt * ( tendency(:,:,:) ) + END DO + + DO k = 1 , kde + field (:,k,:,:) = field (:,2,:,:) + END DO + + field (:,:,2,:) = field (:,:,1,:) + field (:,:,3,:) = field (:,:,1,:) + + field (ite+0,:,:,:) = field(ids+0,:,:,:) + field (ite+1,:,:,:) = field(ids+1,:,:,:) + field (ite+2,:,:,:) = field(ids+2,:,:,:) + field (ite+3,:,:,:) = field(ids+3,:,:,:) + field (ite+4,:,:,:) = field(ids+4,:,:,:) + field (ids-0,:,:,:) = field(ite-0,:,:,:) + field (ids-1,:,:,:) = field(ite-1,:,:,:) + field (ids-2,:,:,:) = field(ite-2,:,:,:) + field (ids-3,:,:,:) = field(ite-3,:,:,:) + field (ids-4,:,:,:) = field(ite-4,:,:,:) + + field_old = field + + IF ( loop .EQ. (loop/200)*200 ) THEN + CALL column ( loop , field(:,1,2,1) , its, ite ) + END IF + END DO + END DO + + print *,' ' + print *,'=============================== ' + print *,' ' + print *,'Lines to input to gnuplot' + print *,' ' + print *,"set term x11" + IF (config_flags%scalar_adv_opt .EQ. 0 ) THEN + print *,'set title "Scalar Advection" font ",20"' + ELSE IF (config_flags%scalar_adv_opt .EQ. 1 ) THEN + print *,'set title "PD Advection" font ",20"' + ELSE IF (config_flags%scalar_adv_opt .EQ. 2 ) THEN + print *,'set title "Mono Advection" font ",20"' + ELSE IF (config_flags%scalar_adv_opt .EQ. 3 ) THEN + print *,'set title "WENO Advection" font ",20"' + ELSE IF (config_flags%scalar_adv_opt .EQ. 3 ) THEN + print *,'set title "WENO PD Advection" font ",20"' + END IF + print *,"set yrange[-20:120]" + print *,"plot [0:90] '000000.txt' with lines , '000200.txt' with lines , '000400.txt' with lines , '000600.txt' with lines , '000800.txt' with lines , '001000.txt' with lines " + print *,"plot [0:90] '000000.txt' with lines , '001200.txt' with lines , '001400.txt' with lines , '001600.txt' with lines , '001800.txt' with lines , '002000.txt' with lines " + +END PROGRAM feeder +#endif +#if ( !defined(ADVECT_KERNEL) ) !--------------------------------------------------------------------------------- SUBROUTINE advect_weno_u ( u, u_old, tendency, & ru, rv, rom, & + c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -10545,7 +10779,9 @@ SUBROUTINE advect_weno_u ( u, u_old, tendency, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & - rdzw + rdzw, & + c1, & + c2 REAL , INTENT(IN ) :: rdx, & rdy @@ -10699,7 +10935,7 @@ SUBROUTINE advect_weno_u ( u, u_old, tendency, & DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i-1,k,j)) - IF ( vel .ge. 0.0 ) THEN + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = u(i,k,j+1) qip1 = u(i,k,j ) qi = u(i,k,j-1) @@ -10852,7 +11088,7 @@ SUBROUTINE advect_weno_u ( u, u_old, tendency, & DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i-1,k,j)) - IF ( vel .ge. 0.0 ) THEN + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = u(i+1,k,j) qip1 = u(i, k,j) qi = u(i-1,k,j) @@ -11076,7 +11312,7 @@ SUBROUTINE advect_weno_u ( u, u_old, tendency, & DO i = i_start, i_end vel=0.5*(rom(i-1,k,j)+rom(i,k,j)) - IF( -vel .ge. 0.0 ) THEN + IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = u(i,k+1,j) qip1 = u(i,k ,j) qi = u(i,k-1,j) @@ -11146,6 +11382,7 @@ END SUBROUTINE advect_weno_u SUBROUTINE advect_weno_v ( v, v_old, tendency, & ru, rv, rom, & + c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -11189,7 +11426,9 @@ SUBROUTINE advect_weno_v ( v, v_old, tendency, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & - rdzw + rdzw, & + c1, & + c2 REAL , INTENT(IN ) :: rdx, & rdy @@ -11341,7 +11580,7 @@ SUBROUTINE advect_weno_v ( v, v_old, tendency, & DO i = i_start, i_end vel = 0.5*(rv(i,k,j)+rv(i,k,j-1)) - IF ( vel .ge. 0.0 ) THEN + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = v(i,k,j+1) qip1 = v(i,k,j ) qi = v(i,k,j-1) @@ -11508,7 +11747,7 @@ SUBROUTINE advect_weno_v ( v, v_old, tendency, & DO i = i_start_f, i_end_f vel = 0.5*(ru(i,k,j)+ru(i,k,j-1)) - IF ( vel .ge. 0.0 ) THEN + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = v(i+1,k,j) qip1 = v(i, k,j) qi = v(i-1,k,j) @@ -11762,7 +12001,7 @@ SUBROUTINE advect_weno_v ( v, v_old, tendency, & DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k,j-1)) - IF( -vel .ge. 0.0 ) THEN + IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = v(i,k+1,j) qip1 = v(i,k ,j) qi = v(i,k-1,j) @@ -11838,6 +12077,7 @@ END SUBROUTINE advect_weno_v SUBROUTINE advect_weno_w ( w, w_old, tendency, & ru, rv, rom, & + c1, c2, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -11881,7 +12121,9 @@ SUBROUTINE advect_weno_w ( w, w_old, tendency, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fzm, & fzp, & - rdzu + rdzu, & + c1, & + c2 REAL , INTENT(IN ) :: rdx, & rdy @@ -12027,7 +12269,7 @@ SUBROUTINE advect_weno_w ( w, w_old, tendency, & DO i = i_start, i_end vel = fzm(k)*rv(i,k,j)+fzp(k)*rv(i,k-1,j) - IF ( vel .ge. 0.0 ) THEN + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = w(i,k,j+1) qip1 = w(i,k,j ) qi = w(i,k,j-1) @@ -12067,7 +12309,7 @@ SUBROUTINE advect_weno_w ( w, w_old, tendency, & DO i = i_start, i_end vel = (2.-fzm(k-1))*rv(i,k-1,j)-fzp(k-1)*rv(i,k-2,j) - IF ( vel .ge. 0.0 ) THEN + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = w(i,k,j+1) qip1 = w(i,k,j ) qi = w(i,k,j-1) @@ -12246,7 +12488,7 @@ SUBROUTINE advect_weno_w ( w, w_old, tendency, & DO i = i_start_f, i_end_f vel = fzm(k)*ru(i,k,j)+fzp(k)*ru(i,k-1,j) - IF ( vel .ge. 0.0 ) THEN + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = w(i+1,k,j) qip1 = w(i, k,j) qi = w(i-1,k,j) @@ -12287,7 +12529,7 @@ SUBROUTINE advect_weno_w ( w, w_old, tendency, & DO i = i_start_f, i_end_f vel = (2.-fzm(k-1))*ru(i,k-1,j)-fzp(k-1)*ru(i,k-2,j) - IF ( vel .ge. 0.0 ) THEN + IF ( vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = w(i+1,k,j) qip1 = w(i, k,j) qi = w(i-1,k,j) @@ -12584,7 +12826,7 @@ SUBROUTINE advect_weno_w ( w, w_old, tendency, & DO i = i_start, i_end vel=0.5*(rom(i,k,j)+rom(i,k-1,j)) - IF( -vel .ge. 0.0 ) THEN + IF( -vel*sign(1,time_step) .ge. 0.0 ) THEN qip2 = w(i,k+1,j) qip1 = w(i,k ,j) qi = w(i,k-1,j) diff --git a/wrfv2_fire/dyn_em/module_after_all_rk_steps.F b/wrfv2_fire/dyn_em/module_after_all_rk_steps.F index aa81b0df..cc0ee30f 100644 --- a/wrfv2_fire/dyn_em/module_after_all_rk_steps.F +++ b/wrfv2_fire/dyn_em/module_after_all_rk_steps.F @@ -52,7 +52,7 @@ SUBROUTINE after_all_rk_steps ( grid, config_flags, & ,local_communicator_periodic, wrf_dm_maxval USE module_comm_dm, ONLY : & - halo_em_phys_w_sub + halo_em_phys_w_sub, halo_em_phys_hcw_sub #endif !============================================================= @@ -138,6 +138,7 @@ SUBROUTINE after_all_rk_steps ( grid, config_flags, & ! Include patch communications !============================================================= # include "HALO_EM_PHYS_W.inc" +# include "HALO_EM_PHYS_HCW.inc" #endif !============================================================= diff --git a/wrfv2_fire/dyn_em/module_bc_em.F b/wrfv2_fire/dyn_em/module_bc_em.F index 1cbf7453..cf3c741f 100644 --- a/wrfv2_fire/dyn_em/module_bc_em.F +++ b/wrfv2_fire/dyn_em/module_bc_em.F @@ -1,19 +1,33 @@ +#if ( HYBRID_COORD==1 ) +# define mut(...) (c1(k)*XXPCTXX(__VA_ARGS__)+c2(k)) +# define XXPCTXX(...) mut(__VA_ARGS__) + +# define muts(...) (c1(k)*XXPCTSXX(__VA_ARGS__)+c2(k)) +# define XXPCTSXX(...) muts(__VA_ARGS__) + +# define mu_old(...) (c1(k)*XXPCOLDXX(__VA_ARGS__)+c2(k)) +# define XXPCOLDXX(...) mu_old(__VA_ARGS__) +#endif + !WRF:MODEL_LAYER:BOUNDARY ! MODULE module_bc_em - USE module_bc - USE module_configure + USE module_bc, ONLY: set_physical_bc2d, set_physical_bc3d, spec_bdytend, & + spec_bdytend_perturb, relax_bdytend_tile, relax_bdytend, & + spec_bdytend_perturb_chem + USE module_configure, ONLY: grid_config_rec_type USE module_wrf_error - USE module_model_constants + USE module_model_constants, ONLY: R_d, R_v, T0 CONTAINS !------------------------------------------------------------------------ - SUBROUTINE spec_bdyupdate_ph( ph_save, field, & - field_tend, mu_tend, muts, dt, & - variable_in, config_flags, & + SUBROUTINE spec_bdyupdate_ph( ph_save, field, & + field_tend, mu_tend, muts, & + c1, c2, dt, & + variable_in, config_flags, & spec_zone, & ids,ide, jds,jde, kds,kde, & ! domain dims ims,ime, jms,jme, kms,kme, & ! memory dims @@ -38,6 +52,7 @@ SUBROUTINE spec_bdyupdate_ph( ph_save, field, & REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field REAL, DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(IN ) :: field_tend, ph_save REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: mu_tend, muts + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: c1, c2 TYPE( grid_config_rec_type ) config_flags CHARACTER :: variable @@ -81,7 +96,7 @@ SUBROUTINE spec_bdyupdate_ph( ph_save, field, & DO k = kts, ktf DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) - mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j) + MU_OLD(i,j) = MUTS(i,j) - dt*MU_TEND(i,j) field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + & dt*field_tend(i,k,j)/muts(i,j) + & @@ -100,7 +115,7 @@ SUBROUTINE spec_bdyupdate_ph( ph_save, field, & DO k = kts, ktf DO i = max(its,b_limit+ibs), min(itf,ibe-b_limit) - mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j) + MU_OLD(i,j) = MUTS(i,j) - dt*MU_TEND(i,j) field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + & dt*field_tend(i,k,j)/muts(i,j) + & @@ -119,7 +134,7 @@ SUBROUTINE spec_bdyupdate_ph( ph_save, field, & DO k = kts, ktf DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) - mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j) + MU_OLD(i,j) = MUTS(i,j) - dt*MU_TEND(i,j) field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + & dt*field_tend(i,k,j)/muts(i,j) + & @@ -137,7 +152,7 @@ SUBROUTINE spec_bdyupdate_ph( ph_save, field, & DO k = kts, ktf DO j = max(jts,b_dist+jbs+1), min(jtf,jbe-b_dist-1) - mu_old(i,j) = muts(i,j) - dt*mu_tend(i,j) + MU_OLD(i,j) = MUTS(i,j) - dt*MU_TEND(i,j) field(i,k,j) = field(i,k,j)*mu_old(i,j)/muts(i,j) + & dt*field_tend(i,k,j)/muts(i,j) + & @@ -155,7 +170,7 @@ END SUBROUTINE spec_bdyupdate_ph SUBROUTINE relax_bdy_dry ( config_flags, & ru_tendf, rv_tendf, ph_tendf, t_tendf, & - rw_tendf, mu_tend, & + rw_tendf, mu_tend, c1h, c2h, c1f, c2f, & ru, rv, ph, t, & w, mu, mut, & u_bxs,u_bxe,u_bys,u_bye, & @@ -200,6 +215,9 @@ SUBROUTINE relax_bdy_dry ( config_flags, & rw_tendf, & t_tendf REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(INOUT) :: mu_tend + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h, c1f, c2f + REAL , DIMENSION( spec_bdy_width) , INTENT(IN ) :: fcx, gcx REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: u_bxs,u_bxe, & @@ -263,13 +281,13 @@ SUBROUTINE relax_bdy_dry ( config_flags, & j_start = max(jts-1, jds) j_end = min(jte+1, jde-1) - DO j=j_start,j_end - DO k=kts,kte - DO i=i_start,i_end - rfield(i,k,j) = ph(i,k,j)*mut(i,j) - ENDDO - ENDDO - ENDDO + CALL mass_weight ( ph , mut , rfield , c1f, c2f, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its-1,ite+1 , jts-1,jte+1 , & ! rfield dims + kts,kte, & ! rfield + i_start,i_end, j_start,j_end, kts,kte) ! tile dims + CALL relax_bdytend_tile ( rfield, ph_tendf, & ph_bxs,ph_bxe,ph_bys,ph_bye, ph_btxs,ph_btxe,ph_btys,ph_btye, & 'h' , config_flags, & @@ -280,13 +298,14 @@ SUBROUTINE relax_bdy_dry ( config_flags, & ips,ipe, jps,jpe, kps,kpe, & ! patch dims its,ite, jts,jte, kts,kte, & its-1, ite+1, jts-1,jte+1,kts,kte ) ! dims of first argument - DO j=j_start,j_end - DO k=kts,kte-1 - DO i=i_start,i_end - rfield(i,k,j) = t(i,k,j)*mut(i,j) - ENDDO - ENDDO - ENDDO + + CALL mass_weight ( t, mut , rfield , c1h, c2h, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its-1,ite+1 , jts-1,jte+1 , & ! rfield dims + kts,kte, & ! rfield + i_start,i_end, j_start,j_end, kts,kte-1) ! tile dims + CALL relax_bdytend_tile ( rfield, t_tendf, & t_bxs,t_bxe,t_bys,t_bye, t_btxs,t_btxe,t_btys,t_btye, & 't' , config_flags, & @@ -297,6 +316,7 @@ SUBROUTINE relax_bdy_dry ( config_flags, & ips,ipe, jps,jpe, kps,kpe, & ! patch dims its,ite, jts,jte, kts,kte, & its-1, ite+1, jts-1,jte+1,kts,kte ) ! dims of first argument + CALL relax_bdytend ( mu, mu_tend, & mu_bxs,mu_bxe,mu_bys,mu_bye, mu_btxs,mu_btxe,mu_btys,mu_btye, & 'm' , config_flags, & @@ -314,14 +334,13 @@ SUBROUTINE relax_bdy_dry ( config_flags, & j_start = max(jts-1, jds) j_end = min(jte+1, jde-1) - DO j=j_start,j_end - DO k=kts,kte - DO i=i_start,i_end - rfield(i,k,j) = w(i,k,j)*mut(i,j) - ENDDO - ENDDO - ENDDO - + CALL mass_weight ( w , mut , rfield , c1f, c2f, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + its-1,ite+1 , jts-1,jte+1 , & ! rfield dims + kts,kte, & ! rfield + i_start,i_end, j_start,j_end, kts,kte) ! tile dims + CALL relax_bdytend_tile ( rfield, rw_tendf, & w_bxs,w_bxe,w_bys,w_bye, w_btxs,w_btxe,w_btys,w_btye, & 'h' , config_flags, & @@ -334,11 +353,10 @@ SUBROUTINE relax_bdy_dry ( config_flags, & its-1, ite+1, jts-1,jte+1,kts,kte ) ! dims of first argument END IF - END SUBROUTINE relax_bdy_dry !------------------------------------------------------------------------ SUBROUTINE relax_bdy_scalar ( scalar_tend, & - scalar, mu, & + scalar, mu, c1h, c2h, & scalar_bxs,scalar_bxe,scalar_bys,scalar_bye, & scalar_btxs,scalar_btxe,scalar_btys,scalar_btye, & spec_bdy_width, spec_zone, relax_zone, & @@ -368,6 +386,7 @@ SUBROUTINE relax_bdy_scalar ( scalar_tend, & scalar_btxs,scalar_btxe REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: scalar_bys,scalar_bye, & scalar_btys,scalar_btye + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h REAL, INTENT(IN ) :: dtbc !Local INTEGER :: i,j,k, i_start, i_end, j_start, j_end @@ -381,13 +400,11 @@ SUBROUTINE relax_bdy_scalar ( scalar_tend, & j_start = max(jts-1, jds) j_end = min(jte+1, jde-1) - DO j=j_start,j_end - DO k=kts,min(kte,kde-1) - DO i=i_start,i_end - rscalar(i,k,j) = scalar(i,k,j)*mu(i,j) - ENDDO - ENDDO - ENDDO + CALL mass_weight ( scalar , mu , rscalar, c1h, c2h, & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + ims,ime, jms,jme, kms,kme, & ! rfield dims + i_start,i_end, j_start,j_end, kts,kte-1) ! tile dims CALL relax_bdytend (rscalar, scalar_tend, & scalar_bxs,scalar_bxe,scalar_bys,scalar_bye, scalar_btxs,scalar_btxe,scalar_btys,scalar_btye, & @@ -532,7 +549,7 @@ END SUBROUTINE spec_bdy_dry !------------------------------------------------------------------------ SUBROUTINE spec_bdy_dry_perturb ( config_flags, & - ru_tend, rv_tend, t_tend,mu_2, mub, & + ru_tend, rv_tend, t_tend,mu_2, mub, c1, c2, & msfu, msfv, msft, & field_u_tend_perturb,field_v_tend_perturb,field_t_tend_perturb, & spec_bdy_width, spec_zone, & @@ -563,13 +580,15 @@ SUBROUTINE spec_bdy_dry_perturb ( config_flags, REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: msfu REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: msfv REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN ) :: msft + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: c1, c2 REAL, DIMENSION( ims:ime , kms:kme_stoch , jms:jme ), INTENT(IN ) :: field_u_tend_perturb, & field_v_tend_perturb, & field_t_tend_perturb CALL spec_bdytend_perturb ( ru_tend, & - field_u_tend_perturb, mu_2,mub, & + field_u_tend_perturb, & + mu_2,mub, c1, c2, & 'u', msfu, config_flags, & spec_bdy_width, spec_zone, & kme_stoch, & ! stoch dims @@ -578,7 +597,8 @@ SUBROUTINE spec_bdy_dry_perturb ( config_flags, ips,ipe, jps,jpe, kps,kpe, & ! patch dims its,ite, jts,jte, kts,kte ) CALL spec_bdytend_perturb ( rv_tend, & - field_v_tend_perturb,mu_2,mub, & + field_v_tend_perturb, & + mu_2,mub, c1, c2, & 'v', msfv, config_flags, & spec_bdy_width, spec_zone, & kme_stoch, & ! stoch dims @@ -588,7 +608,8 @@ SUBROUTINE spec_bdy_dry_perturb ( config_flags, its,ite, jts,jte, kts,kte ) CALL spec_bdytend_perturb ( t_tend, & - field_t_tend_perturb,mu_2,mub, & + field_t_tend_perturb, & + mu_2,mub, c1, c2, & 't', msft, config_flags, & spec_bdy_width, spec_zone, & kme_stoch, & ! stoch dims @@ -700,7 +721,7 @@ SUBROUTINE set_phys_bc_dry_1( config_flags, u_1, u_2, v_1, v_2, & its,ite, jts,jte, kts,kte ) ! -! this is just a wraper to call the boundary condition routines +! this is just a wrapper to call the boundary condition routines ! for each variable ! @@ -803,7 +824,7 @@ SUBROUTINE set_phys_bc_dry_2( config_flags, & its,ite, jts,jte, kts,kte ) ! -! this is just a wraper to call the boundary condition routines +! this is just a wrapper to call the boundary condition routines ! for each variable ! @@ -905,7 +926,7 @@ SUBROUTINE set_phys_bc_smallstep_1( config_flags, ru_1, du, rv_1, dv, & its,ite, jts,jte, kts,kte ) ! -! this is just a wraper to call the boundary condition routines +! this is just a wrapper to call the boundary condition routines ! for each variable ! @@ -954,7 +975,7 @@ SUBROUTINE rk_phys_bc_dry_1( config_flags, u, v, rw, w, & its,ite, jts,jte, kts,kte ) ! -! this is just a wraper to call the boundary condition routines +! this is just a wrapper to call the boundary condition routines ! for each variable ! @@ -1039,7 +1060,7 @@ SUBROUTINE rk_phys_bc_dry_2( config_flags, u, v, w, & its,ite, jts,jte, kts,kte ) ! -! this is just a wraper to call the boundary condition routines +! this is just a wrapper to call the boundary condition routines ! for each variable ! @@ -1338,10 +1359,10 @@ SUBROUTINE theta_and_thetam_lbc_only ( & mu_bdy_ys, mu_bdy_ye, & mu_bdy_tend_xs, mu_bdy_tend_xe, & mu_bdy_tend_ys, mu_bdy_tend_ye, & - t_bdy_xs, t_bdy_xe, & - t_bdy_ys, t_bdy_ye, & - t_bdy_tend_xs, t_bdy_tend_xe, & - t_bdy_tend_ys, t_bdy_tend_ye, & + orig_t_bdy_xs, orig_t_bdy_xe, & + orig_t_bdy_ys, orig_t_bdy_ye, & + orig_t_bdy_tend_xs, orig_t_bdy_tend_xe,& + orig_t_bdy_tend_ys, orig_t_bdy_tend_ye,& moist_bdy_xs, moist_bdy_xe, & moist_bdy_ys, moist_bdy_ye, & moist_bdy_tend_xs, moist_bdy_tend_xe, & @@ -1378,10 +1399,10 @@ SUBROUTINE theta_and_thetam_lbc_only ( & REAL, DIMENSION( jms:jme , 1 , spec_bdy_width ), INTENT(IN ) :: mu_bdy_tend_xs, mu_bdy_tend_xe REAL, DIMENSION( ims:ime , 1 , spec_bdy_width ), INTENT(IN ) :: mu_bdy_tend_ys, mu_bdy_tend_ye - REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(INOUT) :: t_bdy_xs, t_bdy_xe - REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(INOUT) :: t_bdy_ys, t_bdy_ye - REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(INOUT) :: t_bdy_tend_xs, t_bdy_tend_xe - REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(INOUT) :: t_bdy_tend_ys, t_bdy_tend_ye + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(INOUT) :: orig_t_bdy_xs, orig_t_bdy_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(INOUT) :: orig_t_bdy_ys, orig_t_bdy_ye + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(INOUT) :: orig_t_bdy_tend_xs, orig_t_bdy_tend_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(INOUT) :: orig_t_bdy_tend_ys, orig_t_bdy_tend_ye REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN ) :: moist_bdy_xs, moist_bdy_xe REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: moist_bdy_ys, moist_bdy_ye @@ -1389,6 +1410,19 @@ SUBROUTINE theta_and_thetam_lbc_only ( & REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN ) :: moist_bdy_tend_ys, moist_bdy_tend_ye ! Local variables +#ifdef _OPENMP + INTEGER, EXTERNAL :: omp_get_thread_num +#endif + + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ) :: t_bdy_xs, t_bdy_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ) :: t_bdy_ys, t_bdy_ye + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ) :: t_bdy_tend_xs, t_bdy_tend_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ) :: t_bdy_tend_ys, t_bdy_tend_ye + + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ) :: new_t_bdy_xs, new_t_bdy_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ) :: new_t_bdy_ys, new_t_bdy_ye + REAL, DIMENSION( jms:jme , kds:kde , spec_bdy_width ) :: new_t_bdy_tend_xs, new_t_bdy_tend_xe + REAL, DIMENSION( ims:ime , kds:kde , spec_bdy_width ) :: new_t_bdy_tend_ys, new_t_bdy_tend_ye INTEGER :: i, j, k, ii, jj @@ -1448,17 +1482,23 @@ SUBROUTINE theta_and_thetam_lbc_only ( & ! serial, OpenMP, or MPI. For OpenMP, we do not want any overlap between tiles that ! are on the same task (either OpenMP only, or OpenMP+MPI). - IF ( its .EQ. ips ) THEN - i_min = ips-4 + IF ( its .EQ. ids ) THEN + i_min = its + ELSE IF ( its .EQ. ips ) THEN + i_min = ims ELSE i_min = its END IF + i_min = MAX(ids,i_min) - IF ( ite .EQ. ipe ) THEN - i_max = ipe+4 + IF ( ite .EQ. ide ) THEN + i_max = ite + ELSE IF ( ite .EQ. ipe ) THEN + i_max = ime ELSE i_max = ite END IF + i_max = MIN(i_max,ide-1) ! South and north lateral boundaries. This is the i-extent of its through ite, but j only ! goes to within spec_bdy_width of the top and bottom (north and south) boundaries. @@ -1469,9 +1509,16 @@ SUBROUTINE theta_and_thetam_lbc_only ( & DO jj = MAX(jts,1) , MIN(jte,jde-1,spec_bdy_width) j = jj DO k = kts , kte-1 -! DO i = MAX(1,its-4) , MIN(ite+4,ide-1) -! DO i = MAX(1,its,ips-4) , MIN(ite,ipe+4,ide-1) - DO i = MAX(1,i_min) , MIN(i_max,ide-1) + DO i = i_min , i_max + t_bdy_ys (i,k,j) = orig_t_bdy_ys (i,k,j) + t_bdy_tend_ys(i,k,j) = orig_t_bdy_tend_ys(i,k,j) + END DO + END DO + END DO + DO jj = MAX(jts,1) , MIN(jte,jde-1,spec_bdy_width) + j = jj + DO k = kts , kte-1 + DO i = i_min , i_max mu_old_bdy_ys = mu_bdy_ys(i,1,j) + mub(i,jj) t_old_bdy_ys = ( t_bdy_ys(i,k,j) ) / mu_old_bdy_ys moist_old_bdy_ys = ( moist_bdy_ys(i,k,j) ) / mu_old_bdy_ys @@ -1481,12 +1528,12 @@ SUBROUTINE theta_and_thetam_lbc_only ( & t_old_bdy_tend_ys = ( t_new_bdy_ys - t_old_bdy_ys ) / dt_interval moist_old_bdy_tend_ys = ( moist_new_bdy_ys - moist_old_bdy_ys ) / dt_interval IF ( theta_to_thetam ) THEN - t_bdy_ys(i,k,j) = ( ( ( t_old_bdy_ys + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_ys ) ) - T0 ) * mu_old_bdy_ys - t_bdy_tend_ys(i,k,j) = ( ( mu_new_bdy_ys * ( ( t_new_bdy_ys + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_ys ) - T0 ) ) - & + new_t_bdy_ys(i,k,j) = ( ( ( t_old_bdy_ys + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_ys ) ) - T0 ) * mu_old_bdy_ys + new_t_bdy_tend_ys(i,k,j) = ( ( mu_new_bdy_ys * ( ( t_new_bdy_ys + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_ys ) - T0 ) ) - & ( mu_old_bdy_ys * ( ( t_old_bdy_ys + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_ys ) - T0 ) ) ) / dt_interval ELSE - t_bdy_ys(i,k,j) = ( ( ( t_old_bdy_ys + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_ys ) ) - T0 ) * mu_old_bdy_ys - t_bdy_tend_ys(i,k,j) = ( ( mu_new_bdy_ys * ( ( t_new_bdy_ys + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_ys ) - T0 ) ) - & + new_t_bdy_ys(i,k,j) = ( ( ( t_old_bdy_ys + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_ys ) ) - T0 ) * mu_old_bdy_ys + new_t_bdy_tend_ys(i,k,j) = ( ( mu_new_bdy_ys * ( ( t_new_bdy_ys + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_ys ) - T0 ) ) - & ( mu_old_bdy_ys * ( ( t_old_bdy_ys + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_ys ) - T0 ) ) ) / dt_interval END IF END DO @@ -1499,9 +1546,16 @@ SUBROUTINE theta_and_thetam_lbc_only ( & DO jj = MIN(jde-1,jte) , MAX(jde-spec_bdy_width,jts) , -1 j = jde-jj DO k = kts , kte-1 -! DO i = MAX(1,its-4) , MIN(ite+4,ide-1) -! DO i = MAX(1,its,ips-4) , MIN(ite,ipe+4,ide-1) - DO i = MAX(1,i_min) , MIN(i_max,ide-1) + DO i = i_min , i_max + t_bdy_ye (i,k,j) = orig_t_bdy_ye (i,k,j) + t_bdy_tend_ye(i,k,j) = orig_t_bdy_tend_ye(i,k,j) + END DO + END DO + END DO + DO jj = MIN(jde-1,jte) , MAX(jde-spec_bdy_width,jts) , -1 + j = jde-jj + DO k = kts , kte-1 + DO i = i_min , i_max mu_old_bdy_ye = mu_bdy_ye(i,1,j) + mub(i,jj) t_old_bdy_ye = ( t_bdy_ye(i,k,j) ) / mu_old_bdy_ye moist_old_bdy_ye = ( moist_bdy_ye(i,k,j) ) / mu_old_bdy_ye @@ -1511,12 +1565,12 @@ SUBROUTINE theta_and_thetam_lbc_only ( & t_old_bdy_tend_ye = ( t_new_bdy_ye - t_old_bdy_ye ) / dt_interval moist_old_bdy_tend_ye = ( moist_new_bdy_ye - moist_old_bdy_ye ) / dt_interval IF ( theta_to_thetam ) THEN - t_bdy_ye(i,k,j) = ( ( ( t_old_bdy_ye + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_ye ) ) - T0 ) * mu_old_bdy_ye - t_bdy_tend_ye(i,k,j) = ( ( mu_new_bdy_ye * ( ( t_new_bdy_ye + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_ye ) - T0 ) ) - & + new_t_bdy_ye(i,k,j) = ( ( ( t_old_bdy_ye + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_ye ) ) - T0 ) * mu_old_bdy_ye + new_t_bdy_tend_ye(i,k,j) = ( ( mu_new_bdy_ye * ( ( t_new_bdy_ye + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_ye ) - T0 ) ) - & ( mu_old_bdy_ye * ( ( t_old_bdy_ye + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_ye ) - T0 ) ) ) / dt_interval ELSE - t_bdy_ye(i,k,j) = ( ( ( t_old_bdy_ye + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_ye ) ) - T0 ) * mu_old_bdy_ye - t_bdy_tend_ye(i,k,j) = ( ( mu_new_bdy_ye * ( ( t_new_bdy_ye + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_ye ) - T0 ) ) - & + new_t_bdy_ye(i,k,j) = ( ( ( t_old_bdy_ye + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_ye ) ) - T0 ) * mu_old_bdy_ye + new_t_bdy_tend_ye(i,k,j) = ( ( mu_new_bdy_ye * ( ( t_new_bdy_ye + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_ye ) - T0 ) ) - & ( mu_old_bdy_ye * ( ( t_old_bdy_ye + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_ye ) - T0 ) ) ) / dt_interval END IF END DO @@ -1527,17 +1581,23 @@ SUBROUTINE theta_and_thetam_lbc_only ( & ! serial, OpenMP, or MPI. For OpenMP, we do not want any overlap between tiles that ! are on the same task (either OpenMP only, or OpenMP+MPI). - IF ( jts .EQ. jps ) THEN - j_min = jps-4 + IF ( jts .EQ. jds ) THEN + j_min = jts + ELSE IF ( jts .EQ. jps ) THEN + j_min = jms ELSE j_min = jts END IF + j_min = MAX(jds,j_min) - IF ( jte .EQ. jpe ) THEN - j_max = jpe+4 + IF ( jte .EQ. jde ) THEN + j_max = jte + ELSE IF ( jte .EQ. jpe ) THEN + j_max = jme ELSE j_max = jte END IF + j_max = MIN(j_max,jde-1) ! West and east lateral boundaries. This is the j-extent of jts through jte, but i only ! goes to within spec_bdy_width of the left and right (west and east) boundaries. @@ -1548,9 +1608,16 @@ SUBROUTINE theta_and_thetam_lbc_only ( & DO ii = MAX(its,1) , MIN(ite,ide-1,spec_bdy_width) i = ii DO k = kts , kte-1 -! DO j = MAX(1,jts-4) , MIN(jte+4,jde-1) -! DO j = MAX(1,jts,jps-4) , MIN(jte,jpe+4,jde-1) - DO j = MAX(1,j_min) , MIN(j_max,jde-1) + DO j = j_min , j_max + t_bdy_xs (j,k,i) = orig_t_bdy_xs (j,k,i) + t_bdy_tend_xs(j,k,i) = orig_t_bdy_tend_xs(j,k,i) + END DO + END DO + END DO + DO ii = MAX(its,1) , MIN(ite,ide-1,spec_bdy_width) + i = ii + DO k = kts , kte-1 + DO j = j_min , j_max mu_old_bdy_xs = mu_bdy_xs(j,1,i) + mub(ii,j) t_old_bdy_xs = ( t_bdy_xs(j,k,i) ) / mu_old_bdy_xs moist_old_bdy_xs = ( moist_bdy_xs(j,k,i) ) / mu_old_bdy_xs @@ -1560,12 +1627,12 @@ SUBROUTINE theta_and_thetam_lbc_only ( & t_old_bdy_tend_xs = ( t_new_bdy_xs - t_old_bdy_xs ) / dt_interval moist_old_bdy_tend_xs = ( moist_new_bdy_xs - moist_old_bdy_xs ) / dt_interval IF ( theta_to_thetam ) THEN - t_bdy_xs(j,k,i) = ( ( ( t_old_bdy_xs + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_xs ) ) - T0 ) * mu_old_bdy_xs - t_bdy_tend_xs(j,k,i) = ( ( mu_new_bdy_xs * ( ( t_new_bdy_xs + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_xs ) - T0 ) ) - & + new_t_bdy_xs(j,k,i) = ( ( ( t_old_bdy_xs + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_xs ) ) - T0 ) * mu_old_bdy_xs + new_t_bdy_tend_xs(j,k,i) = ( ( mu_new_bdy_xs * ( ( t_new_bdy_xs + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_xs ) - T0 ) ) - & ( mu_old_bdy_xs * ( ( t_old_bdy_xs + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_xs ) - T0 ) ) ) / dt_interval ELSE - t_bdy_xs(j,k,i) = ( ( ( t_old_bdy_xs + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_xs ) ) - T0 ) * mu_old_bdy_xs - t_bdy_tend_xs(j,k,i) = ( ( mu_new_bdy_xs * ( ( t_new_bdy_xs + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_xs ) - T0 ) ) - & + new_t_bdy_xs(j,k,i) = ( ( ( t_old_bdy_xs + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_xs ) ) - T0 ) * mu_old_bdy_xs + new_t_bdy_tend_xs(j,k,i) = ( ( mu_new_bdy_xs * ( ( t_new_bdy_xs + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_xs ) - T0 ) ) - & ( mu_old_bdy_xs * ( ( t_old_bdy_xs + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_xs ) - T0 ) ) ) / dt_interval END IF END DO @@ -1578,9 +1645,16 @@ SUBROUTINE theta_and_thetam_lbc_only ( & DO ii = MIN(ide-1,ite) , MAX(ide-spec_bdy_width,its) , -1 i = ide-ii DO k = kts , kte-1 -! DO j = MAX(1,jts-4) , MIN(jte+4,jde-1) -! DO j = MAX(1,jts,jps-4) , MIN(jte,jpe+4,jde-1) - DO j = MAX(1,j_min) , MIN(j_max,jde-1) + DO j = j_min , j_max + t_bdy_xe (j,k,i) = orig_t_bdy_xe (j,k,i) + t_bdy_tend_xe(j,k,i) = orig_t_bdy_tend_xe(j,k,i) + END DO + END DO + END DO + DO ii = MIN(ide-1,ite) , MAX(ide-spec_bdy_width,its) , -1 + i = ide-ii + DO k = kts , kte-1 + DO j = j_min , j_max mu_old_bdy_xe = mu_bdy_xe(j,1,i) + mub(ii,j) t_old_bdy_xe = ( t_bdy_xe(j,k,i) ) / mu_old_bdy_xe moist_old_bdy_xe = ( moist_bdy_xe(j,k,i) ) / mu_old_bdy_xe @@ -1590,20 +1664,94 @@ SUBROUTINE theta_and_thetam_lbc_only ( & t_old_bdy_tend_xe = ( t_new_bdy_xe - t_old_bdy_xe ) / dt_interval moist_old_bdy_tend_xe = ( moist_new_bdy_xe - moist_old_bdy_xe ) / dt_interval IF ( theta_to_thetam ) THEN - t_bdy_xe(j,k,i) = ( ( ( t_old_bdy_xe + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_xe ) ) - T0 ) * mu_old_bdy_xe - t_bdy_tend_xe(j,k,i) = ( ( mu_new_bdy_xe * ( ( t_new_bdy_xe + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_xe ) - T0 ) ) - & + new_t_bdy_xe(j,k,i) = ( ( ( t_old_bdy_xe + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_xe ) ) - T0 ) * mu_old_bdy_xe + new_t_bdy_tend_xe(j,k,i) = ( ( mu_new_bdy_xe * ( ( t_new_bdy_xe + T0 ) * ( 1. + (R_v/R_d) * moist_new_bdy_xe ) - T0 ) ) - & ( mu_old_bdy_xe * ( ( t_old_bdy_xe + T0 ) * ( 1. + (R_v/R_d) * moist_old_bdy_xe ) - T0 ) ) ) / dt_interval ELSE - t_bdy_xe(j,k,i) = ( ( ( t_old_bdy_xe + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_xe ) ) - T0 ) * mu_old_bdy_xe - t_bdy_tend_xe(j,k,i) = ( ( mu_new_bdy_xe * ( ( t_new_bdy_xe + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_xe ) - T0 ) ) - & + new_t_bdy_xe(j,k,i) = ( ( ( t_old_bdy_xe + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_xe ) ) - T0 ) * mu_old_bdy_xe + new_t_bdy_tend_xe(j,k,i) = ( ( mu_new_bdy_xe * ( ( t_new_bdy_xe + T0 ) / ( 1. + (R_v/R_d) * moist_new_bdy_xe ) - T0 ) ) - & ( mu_old_bdy_xe * ( ( t_old_bdy_xe + T0 ) / ( 1. + (R_v/R_d) * moist_old_bdy_xe ) - T0 ) ) ) / dt_interval END IF END DO END DO END DO + ! Put the final values for the tendencies into the arrays that get passed + ! back out to the calling routine. + + DO jj = MAX(jts,1) , MIN(jte,jde-1,spec_bdy_width) + j = jj + DO k = kts , kte-1 + DO i = i_min , i_max + orig_t_bdy_ys (i,k,j) = new_t_bdy_ys (i,k,j) + orig_t_bdy_tend_ys(i,k,j) = new_t_bdy_tend_ys(i,k,j) + END DO + END DO + END DO + + DO jj = MIN(jde-1,jte) , MAX(jde-spec_bdy_width,jts) , -1 + j = jde-jj + DO k = kts , kte-1 + DO i = i_min , i_max + orig_t_bdy_ye (i,k,j) = new_t_bdy_ye (i,k,j) + orig_t_bdy_tend_ye(i,k,j) = new_t_bdy_tend_ye(i,k,j) + END DO + END DO + END DO + + DO ii = its , MIN(ite,ide-1,spec_bdy_width) + i = ii + DO k = kts , kte-1 + DO j = j_min , j_max + orig_t_bdy_xs (j,k,i) = new_t_bdy_xs (j,k,i) + orig_t_bdy_tend_xs(j,k,i) = new_t_bdy_tend_xs(j,k,i) + END DO + END DO + END DO + + DO ii = MIN(ide-1,ite) , MAX(ide-spec_bdy_width,its) , -1 + i = ide-ii + DO k = kts , kte-1 + DO j = j_min , j_max + orig_t_bdy_xe (j,k,i) = new_t_bdy_xe (j,k,i) + orig_t_bdy_tend_xe(j,k,i) = new_t_bdy_tend_xe(j,k,i) + END DO + END DO + END DO + END SUBROUTINE theta_and_thetam_lbc_only !------------------------------------------------------------------------ + + SUBROUTINE mass_weight ( field , mut, rfield , c1 , c2 , & + ids,ide, jds,jde, kds,kde, & ! domain dims + ims,ime, jms,jme, kms,kme, & ! memory dims + irs,ire, jrs,jre, krs,kre, & ! rfield dims + its,ite, jts,jte, kts,kte ) ! tile dims + + IMPLICIT NONE + + INTEGER , INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + irs,ire, jrs,jre, krs,kre, & + its,ite, jts,jte, kts,kte + REAL , DIMENSION(ims:ime, kms:kme, jms:jme) , INTENT(IN ) :: field + REAL , DIMENSION(ims:ime, jms:jme) , INTENT(IN ) :: mut + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1, c2 + REAL , DIMENSION(irs:ire, krs:kre, jrs:jre) , INTENT( OUT) :: rfield + + ! Local loop counters + + INTEGER :: i , j , k + + DO j = jts , jte + DO k = kts , kte + DO i = its , ite + rfield(i,k,j) = field(i,k,j) * mut(i,j) + END DO + END DO + END DO + + END SUBROUTINE mass_weight END MODULE module_bc_em diff --git a/wrfv2_fire/dyn_em/module_big_step_utilities_em.F b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F index ef87db4c..61811767 100644 --- a/wrfv2_fire/dyn_em/module_big_step_utilities_em.F +++ b/wrfv2_fire/dyn_em/module_big_step_utilities_em.F @@ -1,3 +1,38 @@ +#if ( HYBRID_COORD==1 ) +# define mut(...) (c1f(k)*XXPCTXX(__VA_ARGS__)+c2f(k)) +# define XXPCTXX(...) mut(__VA_ARGS__) + +# define muu(...) (c1h(k)*XXPCUXX(__VA_ARGS__)+c2h(k)) +# define XXPCUXX(...) muu(__VA_ARGS__) + +# define muv(...) (c1h(k)*XXPCVXX(__VA_ARGS__)+c2h(k)) +# define XXPCVXX(...) muv(__VA_ARGS__) + +# define mu(...) (c1(k)*XXPCXX(__VA_ARGS__)) +# define XXPCXX(...) mu(__VA_ARGS__) + +# define mub(...) (c1(k)*XXPCBXX(__VA_ARGS__)+c2(k)) +# define XXPCBXX(...) mub(__VA_ARGS__) + +# define muts(...) (c1(k)*XXPCTSXX(__VA_ARGS__)+c2(k)) +# define XXPCTSXX(...) muts(__VA_ARGS__) + +# define muuf(...) (c1f(k)*XXPCUFXX(__VA_ARGS__)+c2f(k)) +# define XXPCUFXX(...) muuf(__VA_ARGS__) + +# define muvf(...) (c1f(k)*XXPCVFXX(__VA_ARGS__)+c2f(k)) +# define XXPCVFXX(...) muvf(__VA_ARGS__) + +# define muf(...) (c1f(k)*XXPCFXX(__VA_ARGS__)) +# define XXPCFXX(...) muf(__VA_ARGS__) + +# define mubf(...) (c1f(k)*XXPCBFXX(__VA_ARGS__)+c2f(k)) +# define XXPCBFXX(...) mubf(__VA_ARGS__) + +# define MUT(...) (c1(k)*XXPCTHXX(__VA_ARGS__)+c2(k)) +# define XXPCTHXX(...) MUT(__VA_ARGS__) +#endif + !wrf:MODEL_LAYER:DYNAMICS ! @@ -60,58 +95,58 @@ SUBROUTINE calc_mu_uv ( config_flags, & IF ( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN DO j=jts,jtf DO i=its,itf - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j)) ENDDO ENDDO ELSE IF ( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN DO j=jts,jtf DO i=its+1,itf - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j)) ENDDO ENDDO i=its im = its if(config_flags%periodic_x) im = its-1 DO j=jts,jtf -! muu(i,j) = mu(i,j) +mub(i,j) +! MUU(i,j) = MU(i,j) +MUB(i,j) ! fix for periodic b.c., 13 march 2004, wcs - muu(i,j) = 0.5*(mu(i,j)+mu(im,j)+mub(i,j)+mub(im,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(im,j)+MUB(i,j)+MUB(im,j)) ENDDO ELSE IF ( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN DO j=jts,jtf DO i=its,itf-1 - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j)) ENDDO ENDDO i=ite im = ite-1 if(config_flags%periodic_x) im = ite DO j=jts,jtf -! muu(i,j) = mu(i-1,j) +mub(i-1,j) +! MUU(i,j) = MU(i-1,j) +MUB(i-1,j) ! fix for periodic b.c., 13 march 2004, wcs - muu(i,j) = 0.5*(mu(i-1,j)+mu(im,j)+mub(i-1,j)+mub(im,j)) + MUU(i,j) = 0.5*(MU(i-1,j)+MU(im,j)+MUB(i-1,j)+MUB(im,j)) ENDDO ELSE IF ( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN DO j=jts,jtf DO i=its+1,itf-1 - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j)) ENDDO ENDDO i=its im = its if(config_flags%periodic_x) im = its-1 DO j=jts,jtf -! muu(i,j) = mu(i,j) +mub(i,j) +! MUU(i,j) = MU(i,j) +MUB(i,j) ! fix for periodic b.c., 13 march 2004, wcs - muu(i,j) = 0.5*(mu(i,j)+mu(im,j)+mub(i,j)+mub(im,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(im,j)+MUB(i,j)+MUB(im,j)) ENDDO i=ite im = ite-1 if(config_flags%periodic_x) im = ite DO j=jts,jtf -! muu(i,j) = mu(i-1,j) +mub(i-1,j) +! MUU(i,j) = MU(i-1,j) +MUB(i-1,j) ! fix for periodic b.c., 13 march 2004, wcs - muu(i,j) = 0.5*(mu(i-1,j)+mu(im,j)+mub(i-1,j)+mub(im,j)) + MUU(i,j) = 0.5*(MU(i-1,j)+MU(im,j)+MUB(i-1,j)+MUB(im,j)) ENDDO END IF @@ -121,58 +156,58 @@ SUBROUTINE calc_mu_uv ( config_flags, & IF ( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN DO j=jts,jtf DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1)) ENDDO ENDDO ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN DO j=jts+1,jtf DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1)) ENDDO ENDDO j=jts jm = jts if(config_flags%periodic_y) jm = jts-1 DO i=its,itf -! muv(i,j) = mu(i,j) +mub(i,j) +! MUV(i,j) = MU(i,j) +MUB(i,j) ! fix for periodic b.c., 13 march 2004, wcs - muv(i,j) = 0.5*(mu(i,j)+mu(i,jm)+mub(i,j)+mub(i,jm)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,jm)+MUB(i,j)+MUB(i,jm)) ENDDO ELSE IF ( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN DO j=jts,jtf-1 DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1)) ENDDO ENDDO j=jte jm = jte-1 if(config_flags%periodic_y) jm = jte DO i=its,itf -! muv(i,j) = mu(i,j-1) +mub(i,j-1) +! MUV(i,j) = MU(i,j-1) +MUB(i,j-1) ! fix for periodic b.c., 13 march 2004, wcs - muv(i,j) = 0.5*(mu(i,j-1)+mu(i,jm)+mub(i,j-1)+mub(i,jm)) + MUV(i,j) = 0.5*(MU(i,j-1)+MU(i,jm)+MUB(i,j-1)+MUB(i,jm)) ENDDO ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN DO j=jts+1,jtf-1 DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1)) ENDDO ENDDO j=jts jm = jts if(config_flags%periodic_y) jm = jts-1 DO i=its,itf -! muv(i,j) = mu(i,j) +mub(i,j) +! MUV(i,j) = MU(i,j) +MUB(i,j) ! fix for periodic b.c., 13 march 2004, wcs - muv(i,j) = 0.5*(mu(i,j)+mu(i,jm)+mub(i,j)+mub(i,jm)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,jm)+MUB(i,j)+MUB(i,jm)) ENDDO j=jte jm = jte-1 if(config_flags%periodic_y) jm = jte DO i=its,itf -! muv(i,j) = mu(i,j-1) +mub(i,j-1) +! MUV(i,j) = MU(i,j-1) +MUB(i,j-1) ! fix for periodic b.c., 13 march 2004, wcs - muv(i,j) = 0.5*(mu(i,j-1)+mu(i,jm)+mub(i,j-1)+mub(i,jm)) + MUV(i,j) = 0.5*(MU(i,j-1)+MU(i,jm)+MUB(i,j-1)+MUB(i,jm)) ENDDO END IF @@ -217,50 +252,50 @@ SUBROUTINE calc_mu_uv_1 ( config_flags, & IF ( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN DO j=jts,jtf DO i=its,itf - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)) ENDDO ENDDO ELSE IF ( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN DO j=jts,jtf DO i=its+1,itf - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)) ENDDO ENDDO i=its im = its if(config_flags%periodic_x) im = its-1 DO j=jts,jtf - muu(i,j) = 0.5*(mu(i,j)+mu(im,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(im,j)) ENDDO ELSE IF ( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN DO j=jts,jtf DO i=its,itf-1 - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)) ENDDO ENDDO i=ite im = ite-1 if(config_flags%periodic_x) im = ite DO j=jts,jtf - muu(i,j) = 0.5*(mu(i-1,j)+mu(im,j)) + MUU(i,j) = 0.5*(MU(i-1,j)+MU(im,j)) ENDDO ELSE IF ( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN DO j=jts,jtf DO i=its+1,itf-1 - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)) ENDDO ENDDO i=its im = its if(config_flags%periodic_x) im = its-1 DO j=jts,jtf - muu(i,j) = 0.5*(mu(i,j)+mu(im,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(im,j)) ENDDO i=ite im = ite-1 if(config_flags%periodic_x) im = ite DO j=jts,jtf - muu(i,j) = 0.5*(mu(i-1,j)+mu(im,j)) + MUU(i,j) = 0.5*(MU(i-1,j)+MU(im,j)) ENDDO END IF @@ -270,50 +305,50 @@ SUBROUTINE calc_mu_uv_1 ( config_flags, & IF ( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN DO j=jts,jtf DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)) ENDDO ENDDO ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN DO j=jts+1,jtf DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)) ENDDO ENDDO j=jts jm = jts if(config_flags%periodic_y) jm = jts-1 DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,jm)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,jm)) ENDDO ELSE IF ( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN DO j=jts,jtf-1 DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)) ENDDO ENDDO j=jte jm = jte-1 if(config_flags%periodic_y) jm = jte DO i=its,itf - muv(i,j) = 0.5*(mu(i,j-1)+mu(i,jm)) + MUV(i,j) = 0.5*(MU(i,j-1)+MU(i,jm)) ENDDO ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN DO j=jts+1,jtf-1 DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)) ENDDO ENDDO j=jts jm = jts if(config_flags%periodic_y) jm = jts-1 DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,jm)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,jm)) ENDDO j=jte jm = jte-1 if(config_flags%periodic_y) jm = jte DO i=its,itf - muv(i,j) = 0.5*(mu(i,j-1)+mu(i,jm)) + MUV(i,j) = 0.5*(MU(i,j-1)+MU(i,jm)) ENDDO END IF @@ -328,6 +363,7 @@ END SUBROUTINE calc_mu_uv_1 SUBROUTINE couple_momentum ( muu, ru, u, msfu, & muv, rv, v, msfv, msfv_inv, & mut, rw, w, msft, & + c1h, c2h, c1f, c2f, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -346,6 +382,7 @@ SUBROUTINE couple_momentum ( muu, ru, u, msfu, & REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfu, msfv, msft, msfv_inv REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: u, v, w + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h, c1f, c2f ! Local data @@ -378,7 +415,6 @@ SUBROUTINE couple_momentum ( muu, ru, u, msfu, & DO k=kts,ktf DO i=its,itf rv(i,k,j)=v(i,k,j)*muv(i,j)*msfv_inv(i,j) -! rv(i,k,j)=v(i,k,j)*muv(i,j)/msfv(i,j) ENDDO ENDDO ENDDO @@ -431,42 +467,42 @@ SUBROUTINE calc_mu_staggered ( mu, mub, muu, muv, & IF ( ( its .NE. ids ) .AND. ( ite .NE. ide ) ) THEN DO j=jts,jtf DO i=its,itf - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j)) ENDDO ENDDO ELSE IF ( ( its .EQ. ids ) .AND. ( ite .NE. ide ) ) THEN DO j=jts,jtf DO i=its+1,itf - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j)) ENDDO ENDDO i=its DO j=jts,jtf - muu(i,j) = mu(i,j) +mub(i,j) + MUU(i,j) = MU(i,j) +MUB(i,j) ENDDO ELSE IF ( ( its .NE. ids ) .AND. ( ite .EQ. ide ) ) THEN DO j=jts,jtf DO i=its,itf-1 - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j)) ENDDO ENDDO i=ite DO j=jts,jtf - muu(i,j) = mu(i-1,j) +mub(i-1,j) + MUU(i,j) = MU(i-1,j) +MUB(i-1,j) ENDDO ELSE IF ( ( its .EQ. ids ) .AND. ( ite .EQ. ide ) ) THEN DO j=jts,jtf DO i=its+1,itf-1 - muu(i,j) = 0.5*(mu(i,j)+mu(i-1,j)+mub(i,j)+mub(i-1,j)) + MUU(i,j) = 0.5*(MU(i,j)+MU(i-1,j)+MUB(i,j)+MUB(i-1,j)) ENDDO ENDDO i=its DO j=jts,jtf - muu(i,j) = mu(i,j) +mub(i,j) + MUU(i,j) = MU(i,j) +MUB(i,j) ENDDO i=ite DO j=jts,jtf - muu(i,j) = mu(i-1,j) +mub(i-1,j) + MUU(i,j) = MU(i-1,j) +MUB(i-1,j) ENDDO END IF @@ -476,42 +512,42 @@ SUBROUTINE calc_mu_staggered ( mu, mub, muu, muv, & IF ( ( jts .NE. jds ) .AND. ( jte .NE. jde ) ) THEN DO j=jts,jtf DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1)) ENDDO ENDDO ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .NE. jde ) ) THEN DO j=jts+1,jtf DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1)) ENDDO ENDDO j=jts DO i=its,itf - muv(i,j) = mu(i,j) +mub(i,j) + MUV(i,j) = MU(i,j) +MUB(i,j) ENDDO ELSE IF ( ( jts .NE. jds ) .AND. ( jte .EQ. jde ) ) THEN DO j=jts,jtf-1 DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1)) ENDDO ENDDO j=jte DO i=its,itf - muv(i,j) = mu(i,j-1) +mub(i,j-1) + MUV(i,j) = MU(i,j-1) +MUB(i,j-1) ENDDO ELSE IF ( ( jts .EQ. jds ) .AND. ( jte .EQ. jde ) ) THEN DO j=jts+1,jtf-1 DO i=its,itf - muv(i,j) = 0.5*(mu(i,j)+mu(i,j-1)+mub(i,j)+mub(i,j-1)) + MUV(i,j) = 0.5*(MU(i,j)+MU(i,j-1)+MUB(i,j)+MUB(i,j-1)) ENDDO ENDDO j=jts DO i=its,itf - muv(i,j) = mu(i,j) +mub(i,j) + MUV(i,j) = MU(i,j) +MUB(i,j) ENDDO j=jte DO i=its,itf - muv(i,j) = mu(i,j-1) +mub(i,j-1) + MUV(i,j) = MU(i,j-1) +MUB(i,j-1) ENDDO END IF @@ -520,7 +556,7 @@ END SUBROUTINE calc_mu_staggered !------------------------------------------------------------------------------- SUBROUTINE couple ( mu, mub, rfield, field, name, & - msf, & + msf, c1h, c2h, c1, c2, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -540,6 +576,8 @@ SUBROUTINE couple ( mu, mub, rfield, field, name, & REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu, mub, msf REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(IN ) :: field + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h, c1, c2 ! Local data @@ -633,7 +671,7 @@ END SUBROUTINE couple !------------------------------------------------------------------------------- -SUBROUTINE calc_ww_cp ( u, v, mup, mub, ww, & +SUBROUTINE calc_ww_cp ( u, v, mup, mub, c1h, c2h, ww, & rdx, rdy, msftx, msfty, & msfux, msfuy, msfvx, msfvx_inv, & msfvy, dnw, & @@ -657,6 +695,7 @@ SUBROUTINE calc_ww_cp ( u, v, mup, mub, ww, & msfvx, msfvy, & msfvx_inv REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT ) :: ww REAL , INTENT(IN ) :: rdx, rdy @@ -692,16 +731,13 @@ SUBROUTINE calc_ww_cp ( u, v, mup, mub, ww, & DO j=jts,jtf DO i=its,min(ite+1,ide) - ! u is always coupled with my - muu(i,j) = 0.5*(mup(i,j)+mub(i,j)+mup(i-1,j)+mub(i-1,j))/msfuy(i,j) + MUU(i,j) = 0.5*(MUP(i,j)+MUB(i,j)+MUP(i-1,j)+MUB(i-1,j)) ENDDO ENDDO DO j=jts,min(jte+1,jde) DO i=its,itf - ! v is always coupled with mx -! muv(i,j) = 0.5*(mup(i,j)+mub(i,j)+mup(i,j-1)+mub(i,j-1))/msfvx(i,j) - muv(i,j) = 0.5*(mup(i,j)+mub(i,j)+mup(i,j-1)+mub(i,j-1))*msfvx_inv(i,j) + MUV(i,j) = 0.5*(MUP(i,j)+MUB(i,j)+MUP(i,j-1)+MUB(i,j-1)) ENDDO ENDDO @@ -742,8 +778,8 @@ SUBROUTINE calc_ww_cp ( u, v, mup, mub, ww, & DO k=kts,ktf DO i=its,itf - divv(i,k) = msftx(i,j)*dnw(k)*( rdx*(muu(i+1,j)*u(i+1,k,j)-muu(i,j)*u(i,k,j)) & - +rdy*(muv(i,j+1)*v(i,k,j+1)-muv(i,j)*v(i,k,j)) ) + divv(i,k) = msftx(i,j)*dnw(k)*( rdx*(muu(i+1,j)*u(i+1,k,j)/msfuy(i+1,j)-muu(i,j)*u(i,k,j)/msfuy(i,j)) & + +rdy*(muv(i,j+1)*v(i,k,j+1)*msfvx_inv(i,j+1)-muv(i,j)*v(i,k,j)*msfvx_inv(i,j)) ) ! dmdt(i) = dmdt(i) + dnw(k)* ( rdx*(ru(i+1,k,j)-ru(i,k,j)) & ! +rdy*(rv(i,k,j+1)-rv(i,k,j)) ) @@ -770,7 +806,7 @@ SUBROUTINE calc_ww_cp ( u, v, mup, mub, ww, & ! +rdx*(ru(i+1,k-1,j)-ru(i,k-1,j)) & ! +rdy*(rv(i,k-1,j+1)-rv(i,k-1,j)) ) - ww(i,k,j)=ww(i,k-1,j) - dnw(k-1)*dmdt(i) - divv(i,k-1) + ww(i,k,j)=ww(i,k-1,j) - dnw(k-1)*c1h(k-1)*dmdt(i) - divv(i,k-1) ENDDO ENDDO @@ -949,8 +985,10 @@ END SUBROUTINE calc_alt !---------------------------------------------------------------------- SUBROUTINE calc_p_rho_phi ( moist, n_moist, hypsometric_opt, & - al, alb, mu, muts, ph, phb, p, pb, & - t, p0, t0, ptop, znu, znw, dnw, rdnw, & + al, alb, mu, muts, & + c1, c2, c3h, c4h, c3f, c4f, & + ph, phb, p, pb, & + t, p0, t0, ptop, znu, znw, dnw, rdnw, & rdn, non_hydrostatic, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -983,11 +1021,13 @@ SUBROUTINE calc_p_rho_phi ( moist, n_moist, hypsometric_opt, & REAL, DIMENSION( kms:kme ), INTENT(IN ) :: znu, znw, dnw, rdnw, rdn + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: c1, c2, c3h, c4h, c3f, c4f + REAL, INTENT(IN ) :: t0, p0, ptop ! Local stuff - INTEGER :: i, j, k, itf, jtf, ktf, ispe + INTEGER :: i, j, k, kk, itf, jtf, ktf, ispe REAL :: qvf, qtot, qf1, qf2 REAL, DIMENSION( its:ite) :: temp,cpovcv_v REAL :: pfu, phm, pfd @@ -1035,9 +1075,15 @@ SUBROUTINE calc_p_rho_phi ( moist, n_moist, hypsometric_opt, & DO j=jts,jtf DO k=kts,ktf DO i=its,itf +#if !( HYBRID_COORD==1 ) pfu = muts(i,j)*znw(k+1)+ptop pfd = muts(i,j)*znw(k) +ptop phm = muts(i,j)*znu(k) +ptop +#elif ( HYBRID_COORD==1 ) + pfu = c3f(k+1)*MUTS(i,j) + c4f(k+1) + ptop + pfd = c3f(k )*MUTS(i,j) + c4f(k ) + ptop + phm = c3h(k )*MUTS(i,j) + c4h(k ) + ptop +#endif al(i,k,j) = (ph(i,k+1,j)-ph(i,k,j)+phb(i,k+1,j)-phb(i,k,j))/phm/LOG(pfd/pfu)-alb(i,k,j) END DO END DO @@ -1163,11 +1209,12 @@ SUBROUTINE calc_p_rho_phi ( moist, n_moist, hypsometric_opt, & IF (hypsometric_opt == 1) THEN DO j=jts,jtf - DO k=2,ktf+1 ! integrate hydrostatic equation for geopotential + DO kk=2,ktf+1 ! integrate hydrostatic equation for geopotential + k = kk-1 DO i=its,itf - ph(i,k,j) = ph(i,k-1,j) - (dnw(k-1))*( & - (muts(i,j))*al(i,k-1,j)+ & - mu(i,j)*alb(i,k-1,j) ) + ph(i,k+1,j) = ph(i,k,j) - (dnw(k))*( & + (muts(i,j))*al(i,k,j)+ & + mu(i,j)*alb(i,k,j) ) ENDDO ENDDO ENDDO @@ -1182,9 +1229,15 @@ SUBROUTINE calc_p_rho_phi ( moist, n_moist, hypsometric_opt, & DO k=kts+1,ktf+1 DO i=its,itf +#if !( HYBRID_COORD==1 ) pfu = muts(i,j)*znw(k) +ptop pfd = muts(i,j)*znw(k-1)+ptop phm = muts(i,j)*znu(k-1)+ptop +#elif ( HYBRID_COORD==1 ) + pfu = c3f(k )*MUTS(i,j) + c4f(k ) + ptop + pfd = c3f(k-1)*MUTS(i,j) + c4f(k-1) + ptop + phm = c3h(k-1)*MUTS(i,j) + c4h(k-1) + ptop +#endif ph(i,k,j) = ph(i,k-1,j) + (al(i,k-1,j)+alb(i,k-1,j))*phm*LOG(pfd/pfu) ENDDO ENDDO @@ -1247,7 +1300,8 @@ END SUBROUTINE calc_php !------------------------------------------------------------------------------- -SUBROUTINE diagnose_w( ph_tend, ph_new, ph_old, w, mu, dt, & +SUBROUTINE diagnose_w( ph_tend, ph_new, ph_old, w, mut, & + c1f, c2f, dt, & u, v, ht, & cf1, cf2, cf3, rdx, rdy, & msftx, msfty, & @@ -1270,7 +1324,9 @@ SUBROUTINE diagnose_w( ph_tend, ph_new, ph_old, w, mu, dt, & REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT( OUT) :: w - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: mu, ht, msftx, msfty + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: mut, ht, msftx, msfty + + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: c1f, c2f REAL, INTENT(IN ) :: dt, cf1, cf2, cf3, rdx, rdy @@ -1328,7 +1384,7 @@ SUBROUTINE diagnose_w( ph_tend, ph_new, ph_old, w, mu, dt, & DO k = 2, kte DO i = its, itf w(i,k,j) = msfty(i,j)*( (ph_new(i,k,j)-ph_old(i,k,j))/dt & - - ph_tend(i,k,j)/mu(i,j) )/g + - ph_tend(i,k,j)/mut(i,j) )/g ENDDO ENDDO @@ -1341,7 +1397,8 @@ END SUBROUTINE diagnose_w SUBROUTINE rhs_ph( ph_tend, u, v, ww, & ph, ph_old, phb, w, & - mut, muu, muv, & + mut, muuf, muvf, & + c1f, c2f, & fnm, fnp, & rdnw, cfn, cfn1, rdx, rdy, & msfux, msfuy, msfvx, & @@ -1371,7 +1428,7 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) :: ph_tend - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: muu, muv, mut, & + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: muuf, muvf, mut, & msfux, msfuy, & msfvx, msfvy, & msftx, msfty, & @@ -1379,6 +1436,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & REAL, DIMENSION( kms:kme ), INTENT(IN ) :: rdnw, fnm, fnp + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: c1f, c2f + + REAL, INTENT(IN ) :: cfn, cfn1, rdx, rdy LOGICAL, INTENT(IN ) :: non_hydrostatic @@ -1486,9 +1546,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* & - ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)* & + ( muvf(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)* & (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & - +muv(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j )* & + +muvf(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j )* & (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) ENDDO ENDDO @@ -1496,9 +1556,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* & - ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)* & + ( muvf(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)* & (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & - +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j )* & + +muvf(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j )* & (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) ENDDO @@ -1519,9 +1579,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))* & - ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)* & + ( muuf(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)* & (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & - +muu(i ,j)*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j)* & + +muuf(i ,j)*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j)* & (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) ENDDO ENDDO @@ -1529,9 +1589,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))* & - ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)* & + ( muuf(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)* & (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & - +muu(i ,j)*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux( i,j)* & + +muuf(i ,j)*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux( i,j)* & (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) ENDDO @@ -1554,8 +1614,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))*( & - ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1) & - +muv(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j ))* (1./12.)*( & + ( muvf(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1) & + +muvf(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j ))* (1./12.)*( & 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & -(ph(i,k,j+2)-ph(i,k,j-2)) & +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & @@ -1568,8 +1628,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))*( & - ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) & - +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j ))* (1./12.)*( & + ( muvf(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) & + +muvf(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j ))* (1./12.)*( & 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & -(ph(i,k,j+2)-ph(i,k,j-2)) & +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & @@ -1587,9 +1647,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* & - ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)* & + ( muvf(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)* & (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & - +muv(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j )* & + +muvf(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j )* & (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) ENDDO ENDDO @@ -1597,9 +1657,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* & - ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)* & + ( muvf(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)* & (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & - +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j )* & + +muvf(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j )* & (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) ENDDO @@ -1611,9 +1671,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* & - ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)* & + ( muvf(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)* & (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & - +muv(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j )* & + +muvf(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j )* & (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) ENDDO ENDDO @@ -1621,9 +1681,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* & - ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)* & + ( muvf(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)* & (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & - +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j )* & + +muvf(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j )* & (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) ENDDO @@ -1644,8 +1704,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*( & - ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j) & - +muu(i,j )*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j) )* (1./12.)*( & + ( muuf(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j) & + +muuf(i,j )*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j) )* (1./12.)*( & 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & -(ph(i+2,k,j)-ph(i-2,k,j)) & +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & @@ -1656,8 +1716,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*( & - ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) & - +muu(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux(i ,j) )* (1./12.)*( & + ( muuf(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) & + +muuf(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux(i ,j) )* (1./12.)*( & 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & -(ph(i+2,k,j)-ph(i-2,k,j)) & +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & @@ -1675,9 +1735,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO j = j_start, jtf DO k = 2, kte-1 ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))* & - ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)* & + ( muuf(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)* & (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & - +muu(i ,j)*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j)* & + +muuf(i ,j)*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j)* & (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) ENDDO ENDDO @@ -1685,9 +1745,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO j = j_start, jtf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))* & - ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)* & + ( muuf(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)* & (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & - +muu(i ,j)*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux( i,j)* & + +muuf(i ,j)*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux( i,j)* & (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) ENDDO @@ -1699,9 +1759,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO j = j_start, jtf DO k = 2, kte-1 ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))* & - ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)* & + ( muuf(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)* & (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & - +muu(i ,j)*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j)* & + +muuf(i ,j)*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j)* & (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) ENDDO ENDDO @@ -1709,9 +1769,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO j = j_start, jtf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))* & - ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)* & + ( muuf(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)* & (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & - +muu(i ,j)*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux( i,j)* & + +muuf(i ,j)*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux( i,j)* & (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) ENDDO @@ -1739,8 +1799,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* ( & - ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1) & - +muv(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j ) )* (1./60.)*( & + ( muvf(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1) & + +muvf(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j ) )* (1./60.)*( & 45.*(ph(i,k,j+1)-ph(i,k,j-1)) & -9.*(ph(i,k,j+2)-ph(i,k,j-2)) & +(ph(i,k,j+3)-ph(i,k,j-3)) & @@ -1755,8 +1815,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* ( & - ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) & - +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j ) )* (1./60.)*( & + ( muvf(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) & + +muvf(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j ) )* (1./60.)*( & 45.*(ph(i,k,j+1)-ph(i,k,j-1)) & -9.*(ph(i,k,j+2)-ph(i,k,j-2)) & +(ph(i,k,j+3)-ph(i,k,j-3)) & @@ -1776,8 +1836,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* ( & - ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1) & - +muv(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j ) )* (1./12.)*( & + ( muvf(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1) & + +muvf(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j ) )* (1./12.)*( & 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & -(ph(i,k,j+2)-ph(i,k,j-2)) & +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & @@ -1790,8 +1850,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* ( & - ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) & - +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j) )* (1./12.)*( & + ( muvf(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) & + +muvf(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j) )* (1./12.)*( & 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & -(ph(i,k,j+2)-ph(i,k,j-2)) & +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & @@ -1806,8 +1866,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* ( & - ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1) & - +muv(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j) )* (1./12.)*( & + ( muvf(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1) & + +muvf(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j) )* (1./12.)*( & 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & -(ph(i,k,j+2)-ph(i,k,j-2)) & +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & @@ -1820,8 +1880,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* ( & - ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) & - +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j) )* (1./12.)*( & + ( muvf(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1) & + +muvf(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j) )* (1./12.)*( & 8.*(ph(i,k,j+1)-ph(i,k,j-1)) & -(ph(i,k,j+2)-ph(i,k,j-2)) & +8.*(phb(i,k,j+1)-phb(i,k,j-1)) & @@ -1839,9 +1899,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* & - ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)* & + ( muvf(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)* & (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & - +muv(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j )* & + +muvf(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j )* & (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) ENDDO ENDDO @@ -1849,9 +1909,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* & - ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)* & + ( muvf(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)* & (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & - +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j )* & + +muvf(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j )* & (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) ENDDO @@ -1863,9 +1923,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdy/msfty(i,j))* & - ( muv(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)* & + ( muvf(i,j+1)*(v(i,k,j+1)+v(i,k-1,j+1))*msfvy(i,j+1)* & (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & - +muv(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j )* & + +muvf(i,j )*(v(i,k,j )+v(i,k-1,j ))*msfvy(i,j )* & (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) ENDDO ENDDO @@ -1873,9 +1933,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdy/msfty(i,j))* & - ( muv(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)* & + ( muvf(i,j+1)*(cfn*v(i,k-1,j+1)+cfn1*v(i,k-2,j+1))*msfvy(i,j+1)* & (phb(i,k,j+1)-phb(i,k,j )+ph(i,k,j+1)-ph(i,k,j )) & - +muv(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j )* & + +muvf(i,j )*(cfn*v(i,k-1,j )+cfn1*v(i,k-2,j ))*msfvy(i,j )* & (phb(i,k,j )-phb(i,k,j-1)+ph(i,k,j )-ph(i,k,j-1)) ) ENDDO @@ -1896,8 +1956,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO k = 2, kte-1 DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*( & - ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j) & - +muu(i,j )*(u(i,k,j )+u(i,k-1,j ))*msfux(i,j) )* (1./60.)*( & + ( muuf(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j) & + +muuf(i,j )*(u(i,k,j )+u(i,k-1,j ))*msfux(i,j) )* (1./60.)*( & 45.*(ph(i+1,k,j)-ph(i-1,k,j)) & -9.*(ph(i+2,k,j)-ph(i-2,k,j)) & +(ph(i+3,k,j)-ph(i-3,k,j)) & @@ -1910,8 +1970,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO i = i_start, itf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*( & - ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) & - +muu(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) )* (1./60.)*( & + ( muuf(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) & + +muuf(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) )* (1./60.)*( & 45.*(ph(i+1,k,j)-ph(i-1,k,j)) & -9.*(ph(i+2,k,j)-ph(i-2,k,j)) & +(ph(i+3,k,j)-ph(i-3,k,j)) & @@ -1929,8 +1989,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO j = j_start, jtf DO k = 2, kte-1 ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*( & - ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j) & - +muu(i,j )*(u(i,k,j )+u(i,k-1,j ))*msfux(i,j) )* (1./12.)*( & + ( muuf(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j) & + +muuf(i,j )*(u(i,k,j )+u(i,k-1,j ))*msfux(i,j) )* (1./12.)*( & 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & -(ph(i+2,k,j)-ph(i-2,k,j)) & +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & @@ -1938,8 +1998,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & ENDDO k = kte ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*( & - ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) & - +muu(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) )* (1./12.)*( & + ( muuf(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) & + +muuf(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) )* (1./12.)*( & 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & -(ph(i+2,k,j)-ph(i-2,k,j)) & +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & @@ -1953,8 +2013,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO j = j_start, jtf DO k = 2, kte-1 ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))*( & - ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j) & - +muu(i,j )*(u(i,k,j )+u(i,k-1,j ))*msfux(i,j) )* (1./12.)*( & + ( muuf(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j) & + +muuf(i,j )*(u(i,k,j )+u(i,k-1,j ))*msfux(i,j) )* (1./12.)*( & 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & -(ph(i+2,k,j)-ph(i-2,k,j)) & +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & @@ -1962,8 +2022,8 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & ENDDO k = kte ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))*( & - ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) & - +muu(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) )* (1./12.)*( & + ( muuf(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j) & + +muuf(i,j )*(cfn*u(i ,k-1,j)+cfn1*u(i,k-2,j))*msfux(i,j) )* (1./12.)*( & 8.*(ph(i+1,k,j)-ph(i-1,k,j)) & -(ph(i+2,k,j)-ph(i-2,k,j)) & +8.*(phb(i+1,k,j)-phb(i-1,k,j)) & @@ -1981,9 +2041,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO j = j_start, jtf DO k = 2, kte-1 ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))* & - ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)* & + ( muuf(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)* & (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & - +muu(i ,j)*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j)* & + +muuf(i ,j)*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j)* & (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) ENDDO ENDDO @@ -1991,9 +2051,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO j = j_start, jtf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))* & - ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)* & + ( muuf(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)* & (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & - +muu(i ,j)*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux( i,j)* & + +muuf(i ,j)*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux( i,j)* & (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) ENDDO @@ -2005,9 +2065,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & DO j = j_start, jtf DO k = 2, kte-1 ph_tend(i,k,j)=ph_tend(i,k,j) - (0.25*rdx/msfty(i,j))* & - ( muu(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)* & + ( muuf(i+1,j)*(u(i+1,k,j)+u(i+1,k-1,j))*msfux(i+1,j)* & (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & - +muu(i ,j)*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j)* & + +muuf(i ,j)*(u(i ,k,j)+u(i ,k-1,j))*msfux(i ,j)* & (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) ENDDO ENDDO @@ -2015,9 +2075,9 @@ SUBROUTINE rhs_ph( ph_tend, u, v, ww, & k = kte DO j = j_start, jtf ph_tend(i,k,j)=ph_tend(i,k,j) - (0.5*rdx/msfty(i,j))* & - ( muu(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)* & + ( muuf(i+1,j)*(cfn*u(i+1,k-1,j)+cfn1*u(i+1,k-2,j))*msfux(i+1,j)* & (phb(i+1,k,j)-phb(i ,k,j)+ph(i+1,k,j)-ph(i ,k,j)) & - +muu(i ,j)*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux( i,j)* & + +muuf(i ,j)*(cfn*u(i ,k-1,j)+cfn1*u(i ,k-2,j))*msfux( i,j)* & (phb(i ,k,j)-phb(i-1,k,j)+ph(i ,k,j)-ph(i-1,k,j)) ) ENDDO @@ -2136,7 +2196,7 @@ END SUBROUTINE rhs_ph SUBROUTINE horizontal_pressure_gradient( ru_tend,rv_tend, & ph,alt,p,pb,al,php,cqu,cqv, & - muu,muv,mu,fnm,fnp,rdnw, & + muu,muv,mu,c1h,c2h,fnm,fnp,rdnw,& cf1,cf2,cf3,cfn,cfn1, & rdx,rdy,msfux,msfuy,& msfvx,msfvy,msftx,msfty, & @@ -2181,11 +2241,14 @@ SUBROUTINE horizontal_pressure_gradient( ru_tend,rv_tend, & REAL, DIMENSION( kms:kme ), INTENT(IN ) :: rdnw, fnm, fnp + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: c1h, c2h + REAL, INTENT(IN ) :: rdx, rdy, cf1, cf2, cf3, cfn, cfn1 INTEGER :: i,j,k, itf, jtf, ktf, i_start, j_start REAL, DIMENSION( ims:ime, kms:kme ) :: dpn REAL :: dpx, dpy + REAL, DIMENSION( kms:kme ) :: c1 LOGICAL :: specified @@ -2197,6 +2260,7 @@ SUBROUTINE horizontal_pressure_gradient( ru_tend,rv_tend, & ! ! + c1 = c1h specified = .false. if(config_flags%specified .or. config_flags%nested) specified = .true. @@ -2366,7 +2430,8 @@ END SUBROUTINE horizontal_pressure_gradient !------------------------------------------------------------------------------- -SUBROUTINE pg_buoy_w( rw_tend, p, cqw, mu, mub, & +SUBROUTINE pg_buoy_w( rw_tend, p, cqw, muf, mubf, & + c1f, c2f, & rdnw, rdn, g, msftx, msfty, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -2386,10 +2451,12 @@ SUBROUTINE pg_buoy_w( rw_tend, p, cqw, mu, mub, & REAL, DIMENSION( ims:ime, kms:kme , jms:jme ), INTENT(INOUT) :: rw_tend - REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: mub, mu, msftx, msfty + REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: mubf, muf, msftx, msfty REAL, DIMENSION( kms:kme ), INTENT(IN ) :: rdnw, rdn + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: c1f, c2f + REAL, INTENT(IN ) :: g INTEGER :: itf, jtf, i, j, k @@ -2426,7 +2493,7 @@ SUBROUTINE pg_buoy_w( rw_tend, p, cqw, mu, mub, & cq2 = cqw(i,k-1,j)*cq1 rw_tend(i,k,j) = rw_tend(i,k,j)+(1./msfty(i,j))*g*( & cq1*2.*rdnw(k-1)*( -p(i,k-1,j)) & - -mu(i,j)-cq2*mub(i,j) ) + -muf(i,j)-cq2*mubf(i,j) ) END DO DO k = 2, kde-1 @@ -2436,7 +2503,7 @@ SUBROUTINE pg_buoy_w( rw_tend, p, cqw, mu, mub, & cqw(i,k,j) = cq1 rw_tend(i,k,j) = rw_tend(i,k,j)+(1./msfty(i,j))*g*( & cq1*rdn(k)*(p(i,k,j)-p(i,k-1,j)) & - -mu(i,j)-cq2*mub(i,j) ) + -muf(i,j)-cq2*mubf(i,j) ) END DO ENDDO @@ -2448,13 +2515,13 @@ END SUBROUTINE pg_buoy_w !------------------------------------------------------------------------------- SUBROUTINE w_damp( rw_tend, max_vert_cfl,max_horiz_cfl, & - u, v, ww, w, mut, rdnw, & - rdx, rdy, msfux, msfuy, & - msfvx, msfvy, dt, & - config_flags, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) + u, v, ww, w, mut, c1f, c2f, rdnw, & + rdx, rdy, msfux, msfuy, & + msfvx, msfvy, dt, & + config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) USE module_llxy IMPLICIT NONE @@ -2479,6 +2546,8 @@ SUBROUTINE w_damp( rw_tend, max_vert_cfl,max_horiz_cfl, & REAL, DIMENSION( kms:kme ), INTENT(IN ) :: rdnw + REAL, DIMENSION( kms:kme ), INTENT(IN ) :: c1f, c2f + REAL, INTENT(IN) :: dt REAL, INTENT(IN) :: rdx, rdy REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, msfuy @@ -2519,15 +2588,15 @@ SUBROUTINE w_damp( rw_tend, max_vert_cfl,max_horiz_cfl, & max_horiz_cfl = 0. total = 0 - IF(config_flags%map_proj == PROJ_CASSINI ) then + IF(config_flags%polar ) then msfxffl = 1.0/COS(config_flags%fft_filter_lat*degrad) END IF IF ( config_flags%w_damping == 1 ) THEN #ifdef OPTIMIZE_CFL_TEST ! 20121025, L. Meadows vector optimization does not include special case for Cassini - IF(config_flags%map_proj == PROJ_CASSINI ) then - CALL wrf_error_fatal('module_big_step_utilities_em.F: -DOPTIMIZE_CFL_TEST option does not support PROJ_CASSINI') + IF(config_flags%polar ) then + CALL wrf_error_fatal('module_big_step_utilities_em.F: -DOPTIMIZE_CFL_TEST option does not support global domains') END IF #endif @@ -2544,7 +2613,7 @@ SUBROUTINE w_damp( rw_tend, max_vert_cfl,max_horiz_cfl, & max_vert_cfl = vert_cfl ENDIF # else - IF(config_flags%map_proj == PROJ_CASSINI ) then + IF(config_flags%polar ) then msfuxt = MIN(msfux(i,j), msfxffl) ELSE msfuxt = msfux(i,j) @@ -2602,7 +2671,7 @@ SUBROUTINE w_damp( rw_tend, max_vert_cfl,max_horiz_cfl, & ENDIF # else ! L. Meadows MIC optimization, 20121025 - IF(config_flags%map_proj == PROJ_CASSINI ) then + IF(config_flags%polar ) then msfuxt = MIN(msfux(i,j), msfxffl) ELSE msfuxt = msfux(i,j) @@ -2660,7 +2729,7 @@ END SUBROUTINE w_damp !------------------------------------------------------------------------------- -SUBROUTINE horizontal_diffusion ( name, field, tendency, mu, & +SUBROUTINE horizontal_diffusion ( name, field, tendency, MUT, c1, c2, & config_flags, & msfux, msfuy, msfvx, msfvx_inv, & msfvy, msftx, msfty, & @@ -2685,7 +2754,7 @@ SUBROUTINE horizontal_diffusion ( name, field, tendency, mu, & REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: MUT REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & @@ -2695,6 +2764,8 @@ SUBROUTINE horizontal_diffusion ( name, field, tendency, mu, & msftx, & msfty + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1, c2 + REAL , INTENT(IN ) :: rdx, & rdy, & khdif @@ -2744,14 +2815,14 @@ SUBROUTINE horizontal_diffusion ( name, field, tendency, mu, & ! The interior is grad: (m_x*d/dx), the exterior is div: (m_x*m_y*d/dx(/m_y)) ! setting up different averagings of m^2 partial d/dX and m^2 partial d/dY - mkrdxm=(msftx(i-1,j)/msfty(i-1,j))*mu(i-1,j)*xkmhd(i-1,k,j)*rdx - mkrdxp=(msftx(i,j)/msfty(i,j))*mu(i,j)*xkmhd(i,k,j)*rdx + mkrdxm=(msftx(i-1,j)/msfty(i-1,j))*MUT(i-1,j)*xkmhd(i-1,k,j)*rdx + mkrdxp=(msftx(i,j)/msfty(i,j))*MUT(i,j)*xkmhd(i,k,j)*rdx mrdx=msfux(i,j)*msfuy(i,j)*rdx mkrdym=( (msfuy(i,j)+msfuy(i,j-1))/(msfux(i,j)+msfux(i,j-1)) )* & - 0.25*(mu(i,j)+mu(i,j-1)+mu(i-1,j-1)+mu(i-1,j))* & + 0.25*(MUT(i,j)+MUT(i,j-1)+MUT(i-1,j-1)+MUT(i-1,j))* & 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i-1,k,j-1)+xkmhd(i-1,k,j))*rdy mkrdyp=( (msfuy(i,j)+msfuy(i,j+1))/(msfux(i,j)+msfux(i,j+1)) )* & - 0.25*(mu(i,j)+mu(i,j+1)+mu(i-1,j+1)+mu(i-1,j))* & + 0.25*(MUT(i,j)+MUT(i,j+1)+MUT(i-1,j+1)+MUT(i-1,j))* & 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j+1)+xkmhd(i-1,k,j+1)+xkmhd(i-1,k,j))*rdy ! need to do four-corners (t) for diffusion coefficient as there are ! no values at u,v points @@ -2791,10 +2862,10 @@ SUBROUTINE horizontal_diffusion ( name, field, tendency, mu, & DO i = i_start, i_end mkrdxm=( (msfvx(i,j)+msfvx(i-1,j))/(msfvy(i,j)+msfvy(i-1,j)) )* & - 0.25*(mu(i,j)+mu(i,j-1)+mu(i-1,j-1)+mu(i-1,j))* & + 0.25*(MUT(i,j)+MUT(i,j-1)+MUT(i-1,j-1)+MUT(i-1,j))* & 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i-1,k,j-1)+xkmhd(i-1,k,j))*rdx mkrdxp=( (msfvx(i,j)+msfvx(i+1,j))/(msfvy(i,j)+msfvy(i+1,j)) )* & - 0.25*(mu(i,j)+mu(i,j-1)+mu(i+1,j-1)+mu(i+1,j))* & + 0.25*(MUT(i,j)+MUT(i,j-1)+MUT(i+1,j-1)+MUT(i+1,j))* & 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i+1,k,j-1)+xkmhd(i+1,k,j))*rdx mrdx=msfvx(i,j)*msfvy(i,j)*rdx mkrdym=(msfty(i,j-1)/msftx(i,j-1))*xkmhd(i,k,j-1)*rdy @@ -2829,19 +2900,19 @@ SUBROUTINE horizontal_diffusion ( name, field, tendency, mu, & DO i = i_start, i_end mkrdxm=(msfux(i,j)/msfuy(i,j))* & - 0.25*(mu(i,j)+mu(i-1,j)+mu(i,j)+mu(i-1,j))* & + 0.25*(MUT(i,j)+MUT(i-1,j)+MUT(i,j)+MUT(i-1,j))* & 0.25*(xkmhd(i,k,j)+xkmhd(i-1,k,j)+xkmhd(i,k-1,j)+xkmhd(i-1,k-1,j))*rdx mkrdxp=(msfux(i+1,j)/msfuy(i+1,j))* & - 0.25*(mu(i+1,j)+mu(i,j)+mu(i+1,j)+mu(i,j))* & + 0.25*(MUT(i+1,j)+MUT(i,j)+MUT(i+1,j)+MUT(i,j))* & 0.25*(xkmhd(i+1,k,j)+xkmhd(i,k,j)+xkmhd(i+1,k-1,j)+xkmhd(i,k-1,j))*rdx mrdx=msftx(i,j)*msfty(i,j)*rdx ! mkrdym=(msfvy(i,j)/msfvx(i,j))* & mkrdym=(msfvy(i,j)*msfvx_inv(i,j))* & - 0.25*(mu(i,j)+mu(i,j-1)+mu(i,j)+mu(i,j-1))* & + 0.25*(MUT(i,j)+MUT(i,j-1)+MUT(i,j)+MUT(i,j-1))* & 0.25*(xkmhd(i,k,j)+xkmhd(i,k,j-1)+xkmhd(i,k-1,j)+xkmhd(i,k-1,j-1))*rdy ! mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))* & mkrdyp=(msfvy(i,j+1)*msfvx_inv(i,j+1))* & - 0.25*(mu(i,j+1)+mu(i,j)+mu(i,j+1)+mu(i,j))* & + 0.25*(MUT(i,j+1)+MUT(i,j)+MUT(i,j+1)+MUT(i,j))* & 0.25*(xkmhd(i,k,j+1)+xkmhd(i,k,j)+xkmhd(i,k-1,j+1)+xkmhd(i,k-1,j))*rdy mrdy=msftx(i,j)*msfty(i,j)*rdy @@ -2873,13 +2944,13 @@ SUBROUTINE horizontal_diffusion ( name, field, tendency, mu, & DO k=kts,ktf DO i = i_start, i_end - mkrdxm=(msfux(i,j)/msfuy(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i-1,k,j))*0.5*(mu(i,j)+mu(i-1,j))*rdx - mkrdxp=(msfux(i+1,j)/msfuy(i+1,j))*0.5*(xkmhd(i+1,k,j)+xkmhd(i,k,j))*0.5*(mu(i+1,j)+mu(i,j))*rdx + mkrdxm=(msfux(i,j)/msfuy(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i-1,k,j))*0.5*(MUT(i,j)+MUT(i-1,j))*rdx + mkrdxp=(msfux(i+1,j)/msfuy(i+1,j))*0.5*(xkmhd(i+1,k,j)+xkmhd(i,k,j))*0.5*(MUT(i+1,j)+MUT(i,j))*rdx mrdx=msftx(i,j)*msfty(i,j)*rdx -! mkrdym=(msfvy(i,j)/msfvx(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy - mkrdym=(msfvy(i,j)*msfvx_inv(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy -! mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy - mkrdyp=(msfvy(i,j+1)*msfvx_inv(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy +! mkrdym=(msfvy(i,j)/msfvx(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(MUT(i,j)+MUT(i,j-1))*rdy + mkrdym=(msfvy(i,j)*msfvx_inv(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(MUT(i,j)+MUT(i,j-1))*rdy +! mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(MUT(i,j+1)+MUT(i,j))*rdy + mkrdyp=(msfvy(i,j+1)*msfvx_inv(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(MUT(i,j+1)+MUT(i,j))*rdy mrdy=msftx(i,j)*msfty(i,j)*rdy tendency(i,k,j)=tendency(i,k,j)+( & @@ -2897,7 +2968,7 @@ END SUBROUTINE horizontal_diffusion !----------------------------------------------------------------------------------------- -SUBROUTINE horizontal_diffusion_3dmp ( name, field, tendency, mu, & +SUBROUTINE horizontal_diffusion_3dmp ( name, field, tendency, MUT, c1, c2, & config_flags, base_3d, & msfux, msfuy, msfvx, msfvx_inv, & msfvy, msftx, msfty, & @@ -2924,7 +2995,7 @@ SUBROUTINE horizontal_diffusion_3dmp ( name, field, tendency, mu, & REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: MUT REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & @@ -2934,6 +3005,8 @@ SUBROUTINE horizontal_diffusion_3dmp ( name, field, tendency, mu, & msftx, & msfty + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1, c2 + REAL , INTENT(IN ) :: rdx, & rdy, & khdif @@ -2978,13 +3051,13 @@ SUBROUTINE horizontal_diffusion_3dmp ( name, field, tendency, mu, & DO k=kts,ktf DO i = i_start, i_end - mkrdxm=(msfux(i,j)/msfuy(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i-1,k,j))*0.5*(mu(i,j)+mu(i-1,j))*rdx - mkrdxp=(msfux(i+1,j)/msfuy(i+1,j))*0.5*(xkmhd(i+1,k,j)+xkmhd(i,k,j))*0.5*(mu(i+1,j)+mu(i,j))*rdx + mkrdxm=(msfux(i,j)/msfuy(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i-1,k,j))*0.5*(MUT(i,j)+MUT(i-1,j))*rdx + mkrdxp=(msfux(i+1,j)/msfuy(i+1,j))*0.5*(xkmhd(i+1,k,j)+xkmhd(i,k,j))*0.5*(MUT(i+1,j)+MUT(i,j))*rdx mrdx=msftx(i,j)*msfty(i,j)*rdx -! mkrdym=(msfvy(i,j)/msfvx(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy -! mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy - mkrdym=(msfvy(i,j)*msfvx_inv(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(mu(i,j)+mu(i,j-1))*rdy - mkrdyp=(msfvy(i,j+1)*msfvx_inv(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(mu(i,j+1)+mu(i,j))*rdy +! mkrdym=(msfvy(i,j)/msfvx(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(MUT(i,j)+MUT(i,j-1))*rdy +! mkrdyp=(msfvy(i,j+1)/msfvx(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(MUT(i,j+1)+MUT(i,j))*rdy + mkrdym=(msfvy(i,j)*msfvx_inv(i,j))*0.5*(xkmhd(i,k,j)+xkmhd(i,k,j-1))*0.5*(MUT(i,j)+MUT(i,j-1))*rdy + mkrdyp=(msfvy(i,j+1)*msfvx_inv(i,j+1))*0.5*(xkmhd(i,k,j+1)+xkmhd(i,k,j))*0.5*(MUT(i,j+1)+MUT(i,j))*rdy mrdy=msftx(i,j)*msfty(i,j)*rdy tendency(i,k,j)=tendency(i,k,j)+( & @@ -3006,8 +3079,8 @@ END SUBROUTINE horizontal_diffusion_3dmp !----------------------------------------------------------------------------------------- SUBROUTINE vertical_diffusion ( name, field, tendency, & - config_flags, & - alt, mut, rdn, rdnw, kvdif, & + config_flags, c1, c2, & + alt, MUT, rdn, rdnw, kvdif, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -3031,10 +3104,12 @@ SUBROUTINE vertical_diffusion ( name, field, tendency, & REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: MUT REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: rdn, rdnw + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1, c2 + REAL , INTENT(IN ) :: kvdif ! Local data @@ -3084,7 +3159,7 @@ SUBROUTINE vertical_diffusion ( name, field, tendency, & DO k=kts+1,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j) & - +rdn(k)*g*g/mut(i,j)/(0.5*(alt(i,k,j)+alt(i,k-1,j))) & + +rdn(k)*g*g/MUT(i,j)/(0.5*(alt(i,k,j)+alt(i,k-1,j))) & *(vflux(i,k)-vflux(i,k-1)) ENDDO ENDDO @@ -3117,7 +3192,7 @@ SUBROUTINE vertical_diffusion ( name, field, tendency, & DO k=kts,ktf DO i = i_start, i_end - tendency(i,k,j)=tendency(i,k,j)+g*g/mut(i,j)/alt(i,k,j) & + tendency(i,k,j)=tendency(i,k,j)+g*g/MUT(i,j)/alt(i,k,j) & *rdnw(k)*(vflux(i,k)-vflux(i,k-1)) ENDDO ENDDO @@ -3132,8 +3207,8 @@ END SUBROUTINE vertical_diffusion !------------------------------------------------------------------------------- SUBROUTINE vertical_diffusion_mp ( field, tendency, config_flags, & - base, & - alt, mut, rdn, rdnw, kvdif, & + base, c1, c2, & + alt, MUT, rdn, rdnw, kvdif, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -3155,12 +3230,14 @@ SUBROUTINE vertical_diffusion_mp ( field, tendency, config_flags, & REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: MUT REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: rdn, & rdnw, & base + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1, c2 + REAL , INTENT(IN ) :: kvdif ! Local data @@ -3211,7 +3288,7 @@ SUBROUTINE vertical_diffusion_mp ( field, tendency, config_flags, & DO k=kts,ktf DO i = i_start, i_end - tendency(i,k,j)=tendency(i,k,j)+g*g/mut(i,j)/alt(i,k,j) & + tendency(i,k,j)=tendency(i,k,j)+g*g/MUT(i,j)/alt(i,k,j) & *rdnw(k)*(vflux(i,k)-vflux(i,k-1)) ENDDO ENDDO @@ -3224,8 +3301,8 @@ END SUBROUTINE vertical_diffusion_mp !------------------------------------------------------------------------------- SUBROUTINE vertical_diffusion_3dmp ( field, tendency, config_flags, & - base_3d, & - alt, mut, rdn, rdnw, kvdif, & + base_3d, c1, c2, & + alt, MUT, rdn, rdnw, kvdif, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -3248,11 +3325,13 @@ SUBROUTINE vertical_diffusion_3dmp ( field, tendency, config_flags, & REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mut + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: MUT REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: rdn, & rdnw + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1, c2 + REAL , INTENT(IN ) :: kvdif ! Local data @@ -3304,7 +3383,7 @@ SUBROUTINE vertical_diffusion_3dmp ( field, tendency, config_flags, & DO k=kts,ktf DO i = i_start, i_end - tendency(i,k,j)=tendency(i,k,j)+g*g/mut(i,j)/alt(i,k,j) & + tendency(i,k,j)=tendency(i,k,j)+g*g/MUT(i,j)/alt(i,k,j) & *rdnw(k)*(vflux(i,k)-vflux(i,k-1)) ENDDO ENDDO @@ -3318,7 +3397,7 @@ END SUBROUTINE vertical_diffusion_3dmp SUBROUTINE vertical_diffusion_u ( field, tendency, & - config_flags, u_base, & + config_flags, u_base, c1h,c2h,& alt, muu, rdn, rdnw, kvdif, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3345,6 +3424,8 @@ SUBROUTINE vertical_diffusion_u ( field, tendency, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: rdn, rdnw, u_base + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h + REAL , INTENT(IN ) :: kvdif ! Local data @@ -3419,7 +3500,7 @@ END SUBROUTINE vertical_diffusion_u SUBROUTINE vertical_diffusion_v ( field, tendency, & - config_flags, v_base, & + config_flags, v_base, c1h,c2h,& alt, muv, rdn, rdnw, kvdif, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3441,6 +3522,8 @@ SUBROUTINE vertical_diffusion_v ( field, tendency, & alt REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: rdn, rdnw, v_base + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: muv @@ -3780,7 +3863,7 @@ END SUBROUTINE coriolis SUBROUTINE perturbation_coriolis ( ru_in, rv_in, rw, ru_tend, rv_tend, rw_tend, & config_flags, & u_base, v_base, z_base, & - muu, muv, phb, ph, & + muu, muv, c1h, c2h, phb, ph, & msftx, msfty, msfux, msfuy, msfvx, msfvy, & f, e, sina, cosa, fzm, fzp, & ids, ide, jds, jde, kds, kde, & @@ -3829,6 +3912,8 @@ SUBROUTINE perturbation_coriolis ( ru_in, rv_in, rw, ru_tend, rv_tend, rw_tend, REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: u_base, & v_base, & z_base + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h ! Local storage @@ -4392,6 +4477,8 @@ SUBROUTINE curvature ( ru, rv, rw, u, v, w, ru_tend, rv_tend, rw_tend, & END SUBROUTINE curvature +#if 0 +DANGER - this is a bad routine to have laying around - someone could use it !------------------------------------------------------------------------------ SUBROUTINE decouple ( rr, rfield, field, name, config_flags, & @@ -4488,6 +4575,7 @@ SUBROUTINE decouple ( rr, rfield, field, name, config_flags, & ENDIF END SUBROUTINE decouple +#endif !------------------------------------------------------------------------------- @@ -4649,28 +4737,15 @@ END SUBROUTINE pole_point_bc !====================================================================== SUBROUTINE phy_prep ( config_flags, & ! input - mu, muu, muv, u, v, p, pb, alt, ph, & ! input - phb, t, tsk, moist, n_moist, & ! input + mut, muu, muv, & + c1h, c2h, c1f, c2f, & + u, v, p, pb, alt, ph, & ! input + phb, t, moist, n_moist, & ! input rho, th_phy, p_phy , pi_phy , & ! output u_phy, v_phy, p8w, t_phy, t8w, & ! output z, z_at_w, dz8w, & ! output p_hyd, p_hyd_w, dnw, & ! output fzm, fzp, znw, p_top, & ! params - RTHRATEN, & - RTHBLTEN, RUBLTEN, RVBLTEN, & - RQVBLTEN, RQCBLTEN, RQIBLTEN, & - RUCUTEN, RVCUTEN, RTHCUTEN, & - RQVCUTEN, RQCCUTEN, RQRCUTEN, & - RQICUTEN, RQSCUTEN, & - RUSHTEN, RVSHTEN, RTHSHTEN, & - RQVSHTEN, RQCSHTEN, RQRSHTEN, & - RQISHTEN, RQSSHTEN, RQGSHTEN, & - RTHFTEN, RQVFTEN, & - RUNDGDTEN, RVNDGDTEN, RTHNDGDTEN, & - RPHNDGDTEN,RQVNDGDTEN, RMUNDGDTEN, & -!jdf - landmask, xland, & -!jdf ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -4688,7 +4763,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input REAL, DIMENSION( ims:ime, kms:kme , jms:jme , n_moist ), INTENT(IN) :: moist - REAL , DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: TSK, mu, muu, muv + REAL , DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: mut, muu, muv REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , & INTENT( OUT) :: u_phy, & @@ -4727,55 +4802,9 @@ SUBROUTINE phy_prep ( config_flags, & ! input REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: znw, & dnw - REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & - INTENT(INOUT) :: RTHRATEN - - REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & - INTENT(INOUT) :: RUCUTEN, & - RVCUTEN, & - RTHCUTEN, & - RQVCUTEN, & - RQCCUTEN, & - RQRCUTEN, & - RQICUTEN, & - RQSCUTEN, & - RUSHTEN, & - RVSHTEN, & - RTHSHTEN, & - RQVSHTEN, & - RQCSHTEN, & - RQRSHTEN, & - RQISHTEN, & - RQSSHTEN, & - RQGSHTEN - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(INOUT) :: RUBLTEN, & - RVBLTEN, & - RTHBLTEN, & - RQVBLTEN, & - RQCBLTEN, & - RQIBLTEN - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(INOUT) :: RTHFTEN, & - RQVFTEN - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & - INTENT(INOUT) :: RUNDGDTEN, & - RVNDGDTEN, & - RTHNDGDTEN, & - RPHNDGDTEN, & - RQVNDGDTEN - - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: RMUNDGDTEN -!jdf - REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(INOUT) :: landmask, & - xland -!jdf + REAL, DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h, c1f, c2f + REAL, DIMENSION( kms:kme ) :: c1, c2 INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, j_startv INTEGER :: i, j, k REAL :: w1, w2, z0, z1, z2 @@ -4787,12 +4816,12 @@ SUBROUTINE phy_prep ( config_flags, & ! input ! ! ! phys_prep calculates a number of diagnostic quantities needed by -! the physics routines. It also decouples the physics tendencies from -! the column dry-air mass (the physics routines expect to see/update the -! uncoupled tendencies). +! the physics routines. ! ! + c1 = c1h + c2 = c2h ! set up loop bounds for this grid's boundary conditions i_start = its @@ -4802,13 +4831,6 @@ SUBROUTINE phy_prep ( config_flags, & ! input k_start = kts k_end = min( kte, kde-1 ) -!jdf -! do j = j_start,j_end -! do i = i_start, i_end -! if(landmask(i,j).lt.0.5) xland(i,j)=2.0 -! enddo -! enddo -!jdf ! compute thermodynamics and velocities at pressure points (or half levels) @@ -4921,7 +4943,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input do n = PARAM_FIRST_SCALAR,n_moist qtot = qtot + moist(i,k,j,n) enddo - p_hyd_w(i,k,j) = p_hyd_w(i,k+1,j) - (1.+qtot)*mu(i,j)*dnw(k) + p_hyd_w(i,k,j) = p_hyd_w(i,k+1,j) - (1.+qtot)*MUT(i,j)*dnw(k) ! p_hyd_w(i,k,j) = p_hyd_w(i,k+1,j)+1./alt(i,k,j)*(1.+moist(i,k,j,P_QV))*g*dz8w(i,k,j) enddo enddo @@ -4937,6 +4959,117 @@ SUBROUTINE phy_prep ( config_flags, & ! input enddo enddo +END SUBROUTINE phy_prep + + +!====================================================================== +! routine to decouple physics tendencies +!====================================================================== + + SUBROUTINE phy_prep_part2 ( config_flags, & + mut,muu,muv, & + c1h, c2h, c1f, c2f, & + RTHRATEN, & + RTHBLTEN, RUBLTEN, RVBLTEN, & + RQVBLTEN, RQCBLTEN, RQIBLTEN, & + RUCUTEN, RVCUTEN, RTHCUTEN, & + RQVCUTEN, RQCCUTEN, RQRCUTEN, & + RQICUTEN, RQSCUTEN, & + RUSHTEN, RVSHTEN, RTHSHTEN, & + RQVSHTEN, RQCSHTEN, RQRSHTEN, & + RQISHTEN, RQSSHTEN, RQGSHTEN, & + RTHFTEN, RQVFTEN, & + RUNDGDTEN, RVNDGDTEN, RTHNDGDTEN, & + RPHNDGDTEN,RQVNDGDTEN, RMUNDGDTEN, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!---------------------------------------------------------------------- + IMPLICIT NONE +!---------------------------------------------------------------------- + + TYPE(grid_config_rec_type) , INTENT(IN ) :: config_flags + + INTEGER , INTENT(IN ) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + + REAL , DIMENSION( ims:ime, jms:jme ), INTENT(IN ) :: mut, muu, muv + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: RTHRATEN + + REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), & + INTENT(INOUT) :: RUCUTEN, & + RVCUTEN, & + RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN, & + RUSHTEN, & + RVSHTEN, & + RTHSHTEN, & + RQVSHTEN, & + RQCSHTEN, & + RQRSHTEN, & + RQISHTEN, & + RQSSHTEN, & + RQGSHTEN + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RUBLTEN, & + RVBLTEN, & + RTHBLTEN, & + RQVBLTEN, & + RQCBLTEN, & + RQIBLTEN + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RTHFTEN, & + RQVFTEN + + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & + INTENT(INOUT) :: RUNDGDTEN, & + RVNDGDTEN, & + RTHNDGDTEN, & + RPHNDGDTEN, & + RQVNDGDTEN + + REAL, DIMENSION( ims:ime, jms:jme ) , & + INTENT(INOUT) :: RMUNDGDTEN + + REAL, DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h, c1f, c2f + + REAL, DIMENSION( kms:kme ) :: c1, c2 + + INTEGER :: i_start, i_end, j_start, j_end, k_start, k_end, i_startu, j_startv + INTEGER :: i, j, k + +!----------------------------------------------------------------------- + +! +! +! It decouples the physics tendencies from +! the column dry-air mass (the physics routines expect to see/update the +! uncoupled tendencies). +! +! + +! set up loop bounds for this grid's boundary conditions + + i_start = its + i_end = min( ite,ide-1 ) + j_start = jts + j_end = min( jte,jde-1 ) + + k_start = kts + k_end = min( kte, kde-1 ) + + c1 = c1h + c2 = c2h + ! decouple all physics tendencies IF (config_flags%ra_lw_physics .gt. 0 .or. config_flags%ra_sw_physics .gt. 0) THEN @@ -4944,7 +5077,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO K=k_start,k_end DO I=i_start,i_end - RTHRATEN(I,K,J)=RTHRATEN(I,K,J)/mu(I,J) + RTHRATEN(I,K,J)=RTHRATEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -4956,9 +5089,9 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RUCUTEN(I,K,J) =RUCUTEN(I,K,J)/mu(I,J) - RVCUTEN(I,K,J) =RVCUTEN(I,K,J)/mu(I,J) - RTHCUTEN(I,K,J)=RTHCUTEN(I,K,J)/mu(I,J) + RUCUTEN(I,K,J) =RUCUTEN(I,K,J)/MUT(I,J) + RVCUTEN(I,K,J) =RVCUTEN(I,K,J)/MUT(I,J) + RTHCUTEN(I,K,J)=RTHCUTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -4967,7 +5100,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQVCUTEN(I,K,J)=RQVCUTEN(I,K,J)/mu(I,J) + RQVCUTEN(I,K,J)=RQVCUTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -4977,7 +5110,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQCCUTEN(I,K,J)=RQCCUTEN(I,K,J)/mu(I,J) + RQCCUTEN(I,K,J)=RQCCUTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -4987,7 +5120,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQRCUTEN(I,K,J)=RQRCUTEN(I,K,J)/mu(I,J) + RQRCUTEN(I,K,J)=RQRCUTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -4997,7 +5130,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQICUTEN(I,K,J)=RQICUTEN(I,K,J)/mu(I,J) + RQICUTEN(I,K,J)=RQICUTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5007,7 +5140,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQSCUTEN(I,K,J)=RQSCUTEN(I,K,J)/mu(I,J) + RQSCUTEN(I,K,J)=RQSCUTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5020,9 +5153,9 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RUSHTEN(I,K,J) =RUSHTEN(I,K,J)/mu(I,J) - RVSHTEN(I,K,J) =RVSHTEN(I,K,J)/mu(I,J) - RTHSHTEN(I,K,J)=RTHSHTEN(I,K,J)/mu(I,J) + RUSHTEN(I,K,J) =RUSHTEN(I,K,J)/MUT(I,J) + RVSHTEN(I,K,J) =RVSHTEN(I,K,J)/MUT(I,J) + RTHSHTEN(I,K,J)=RTHSHTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5031,7 +5164,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQVSHTEN(I,K,J)=RQVSHTEN(I,K,J)/mu(I,J) + RQVSHTEN(I,K,J)=RQVSHTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5041,7 +5174,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQCSHTEN(I,K,J)=RQCSHTEN(I,K,J)/mu(I,J) + RQCSHTEN(I,K,J)=RQCSHTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5051,7 +5184,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQRSHTEN(I,K,J)=RQRSHTEN(I,K,J)/mu(I,J) + RQRSHTEN(I,K,J)=RQRSHTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5061,7 +5194,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQISHTEN(I,K,J)=RQISHTEN(I,K,J)/mu(I,J) + RQISHTEN(I,K,J)=RQISHTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5071,7 +5204,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQSSHTEN(I,K,J)=RQSSHTEN(I,K,J)/mu(I,J) + RQSSHTEN(I,K,J)=RQSSHTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5081,7 +5214,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQGSHTEN(I,K,J)=RQGSHTEN(I,K,J)/mu(I,J) + RQGSHTEN(I,K,J)=RQGSHTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5094,9 +5227,9 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO K=k_start,k_end DO I=i_start,i_end - RUBLTEN(I,K,J) =RUBLTEN(I,K,J)/mu(I,J) - RVBLTEN(I,K,J) =RVBLTEN(I,K,J)/mu(I,J) - RTHBLTEN(I,K,J)=RTHBLTEN(I,K,J)/mu(I,J) + RUBLTEN(I,K,J) =RUBLTEN(I,K,J)/MUT(I,J) + RVBLTEN(I,K,J) =RVBLTEN(I,K,J)/MUT(I,J) + RTHBLTEN(I,K,J)=RTHBLTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5105,7 +5238,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO K=k_start,k_end DO I=i_start,i_end - RQVBLTEN(I,K,J)=RQVBLTEN(I,K,J)/mu(I,J) + RQVBLTEN(I,K,J)=RQVBLTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5115,7 +5248,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO K=k_start,k_end DO I=i_start,i_end - RQCBLTEN(I,K,J)=RQCBLTEN(I,K,J)/mu(I,J) + RQCBLTEN(I,K,J)=RQCBLTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5125,7 +5258,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO K=k_start,k_end DO I=i_start,i_end - RQIBLTEN(I,K,J)=RQIBLTEN(I,K,J)/mu(I,J) + RQIBLTEN(I,K,J)=RQIBLTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5146,7 +5279,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RTHFTEN(I,K,J)=RTHFTEN(I,K,J)/mu(I,J) + RTHFTEN(I,K,J)=RTHFTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5155,7 +5288,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO I=i_start,i_end DO K=k_start,k_end - RQVFTEN(I,K,J)=RQVFTEN(I,K,J)/mu(I,J) + RQVFTEN(I,K,J)=RQVFTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5189,7 +5322,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO K=k_start,k_end DO I=i_start,i_end - RTHNDGDTEN(I,K,J)=RTHNDGDTEN(I,K,J)/mu(I,J) + RTHNDGDTEN(I,K,J)=RTHNDGDTEN(I,K,J)/MUT(I,J) ! RMUNDGDTEN(I,J) - no coupling ENDDO ENDDO @@ -5199,7 +5332,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO K=k_start,kte DO I=i_start,i_end - RPHNDGDTEN(I,K,J)=RPHNDGDTEN(I,K,J)/mu(I,J) + RPHNDGDTEN(I,K,J)=RPHNDGDTEN(I,K,J)/mut(I,J) ENDDO ENDDO ENDDO @@ -5209,7 +5342,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input DO J=j_start,j_end DO K=k_start,k_end DO I=i_start,i_end - RQVNDGDTEN(I,K,J)=RQVNDGDTEN(I,K,J)/mu(I,J) + RQVNDGDTEN(I,K,J)=RQVNDGDTEN(I,K,J)/MUT(I,J) ENDDO ENDDO ENDDO @@ -5218,8 +5351,7 @@ SUBROUTINE phy_prep ( config_flags, & ! input ENDIF -END SUBROUTINE phy_prep - +END SUBROUTINE phy_prep_part2 !------------------------------------------------------------ SUBROUTINE moist_physics_prep_em( t_new, t_old, t0, rho, al, alb, & @@ -5606,6 +5738,7 @@ END SUBROUTINE set_tend SUBROUTINE rk_rayleigh_damp( ru_tendf, rv_tendf, & rw_tendf, t_tendf, & u, v, w, t, t_init, & + c1h, c2h, c1f, c2f, & mut, muu, muv, ph, phb, & u_base, v_base, t_base, z_base, & dampcoef, zdamp, & @@ -5662,6 +5795,9 @@ SUBROUTINE rk_rayleigh_damp( ru_tendf, rv_tendf, & REAL, DIMENSION( kms:kme ) , INTENT(IN ) & :: u_base, v_base, t_base, z_base + REAL, DIMENSION( kms:kme ) , INTENT(IN ) & + :: c1h, c2h, c1f, c2f + REAL, INTENT(IN ) & :: dampcoef, zdamp @@ -5670,6 +5806,9 @@ SUBROUTINE rk_rayleigh_damp( ru_tendf, rv_tendf, & INTEGER & :: i_start, i_end, j_start, j_end, k_start, k_end, i, j, k, ktf, k1, k2 + REAL, DIMENSION( kms:kme ) & + :: c1, c2 + REAL & :: pii, dcoef, z, ztop @@ -5680,6 +5819,9 @@ SUBROUTINE rk_rayleigh_damp( ru_tendf, rv_tendf, & ! End declarations. !----------------------------------------------------------------------- + c1 = c1h + c2 = c2h + pii = 2.0 * asin(1.0) ktf = MIN( kte, kde-1 ) @@ -5857,7 +5999,7 @@ SUBROUTINE rk_rayleigh_damp( ru_tendf, rv_tendf, & dcoef = 1.0 - MIN( 1.0, ( ztop - z00(k) ) / zdamp ) dcoef = (SIN( 0.5 * pii * dcoef ) )**2 t_tendf(i,k,j) = t_tendf(i,k,j) - & - mut(i,j) * ( dcoef * dampcoef ) * & + MUT(i,j) * ( dcoef * dampcoef ) * & ( t(i,k,j) - t00(k) ) END DO @@ -5873,7 +6015,7 @@ END SUBROUTINE rk_rayleigh_damp !============================================================================== SUBROUTINE theta_relaxation( t_tendf, t, t_init, & - mut, ph, phb, & + MUT, c1, c2, ph, phb, & t_base, z_base, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -5904,7 +6046,10 @@ SUBROUTINE theta_relaxation( t_tendf, t, t_init, & :: t, t_init, ph, phb REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & - :: mut + :: MUT + + REAL, DIMENSION( kms:kme), INTENT( IN ) & + :: c1, c2 REAL, DIMENSION( kms:kme ) , INTENT(IN ) & :: t_base, z_base @@ -5964,7 +6109,7 @@ SUBROUTINE theta_relaxation( t_tendf, t, t_init, & ! limit rterm: rterm = min( rterm , rmax ) rterm = max( rterm , rmin ) - t_tendf(i,k,j) = t_tendf(i,k,j) + mut(i,j)*rterm + t_tendf(i,k,j) = t_tendf(i,k,j) + MUT(i,j)*rterm END DO END DO @@ -5975,8 +6120,8 @@ END SUBROUTINE theta_relaxation !============================================================================== !============================================================================== - SUBROUTINE sixth_order_diffusion( name, field, tendency, mu, dt, & - config_flags, & + SUBROUTINE sixth_order_diffusion( name, field, tendency, MUT, dt, & + config_flags, c1, c2, & diff_6th_opt, diff_6th_factor, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -6013,7 +6158,10 @@ SUBROUTINE sixth_order_diffusion( name, field, tendency, mu, dt, & :: field REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN) & - :: mu + :: MUT + + REAL, DIMENSION( kms:kme ), INTENT(IN) & + :: c1, c2 REAL, INTENT(IN) & :: dt @@ -6146,26 +6294,26 @@ SUBROUTINE sixth_order_diffusion( name, field, tendency, mu, dt, & ! Apply 6th-order diffusion in x direction. IF ( name .EQ. 'u' ) THEN - mu_avg_p0 = mu(i-1,j) - mu_avg_p1 = mu(i ,j) + mu_avg_p0 = MUT(i-1,j) + mu_avg_p1 = MUT(i ,j) ELSE IF ( name .EQ. 'v' ) THEN mu_avg_p0 = 0.25 * ( & - mu(i-1,j-1) + & - mu(i ,j-1) + & - mu(i-1,j ) + & - mu(i ,j ) ) + MUT(i-1,j-1) + & + MUT(i ,j-1) + & + MUT(i-1,j ) + & + MUT(i ,j ) ) mu_avg_p1 = 0.25 * ( & - mu(i ,j-1) + & - mu(i+1,j-1) + & - mu(i ,j ) + & - mu(i+1,j ) ) + MUT(i ,j-1) + & + MUT(i+1,j-1) + & + MUT(i ,j ) + & + MUT(i+1,j ) ) ELSE mu_avg_p0 = 0.5 * ( & - mu(i-1,j) + & - mu(i ,j) ) + MUT(i-1,j) + & + MUT(i ,j) ) mu_avg_p1 = 0.5 * ( & - mu(i ,j) + & - mu(i+1,j) ) + MUT(i ,j) + & + MUT(i+1,j) ) END IF tendency_x = diff_6th_coef * & @@ -6206,25 +6354,25 @@ SUBROUTINE sixth_order_diffusion( name, field, tendency, mu, dt, & IF ( name .EQ. 'u' ) THEN mu_avg_p0 = 0.25 * ( & - mu(i-1,j-1) + & - mu(i ,j-1) + & - mu(i-1,j ) + & - mu(i ,j ) ) + MUT(i-1,j-1) + & + MUT(i ,j-1) + & + MUT(i-1,j ) + & + MUT(i ,j ) ) mu_avg_p1 = 0.25 * ( & - mu(i-1,j ) + & - mu(i ,j ) + & - mu(i-1,j+1) + & - mu(i ,j+1) ) + MUT(i-1,j ) + & + MUT(i ,j ) + & + MUT(i-1,j+1) + & + MUT(i ,j+1) ) ELSE IF ( name .EQ. 'v' ) THEN - mu_avg_p0 = mu(i,j-1) - mu_avg_p1 = mu(i,j ) + mu_avg_p0 = MUT(i,j-1) + mu_avg_p1 = MUT(i,j ) ELSE mu_avg_p0 = 0.5 * ( & - mu(i,j-1) + & - mu(i,j ) ) + MUT(i,j-1) + & + MUT(i,j ) ) mu_avg_p1 = 0.5 * ( & - mu(i,j ) + & - mu(i,j+1) ) + MUT(i,j ) + & + MUT(i,j+1) ) END IF tendency_y = diff_6th_coef * & diff --git a/wrfv2_fire/dyn_em/module_diffusion_em.F b/wrfv2_fire/dyn_em/module_diffusion_em.F index 0f58472f..eacd5d2d 100644 --- a/wrfv2_fire/dyn_em/module_diffusion_em.F +++ b/wrfv2_fire/dyn_em/module_diffusion_em.F @@ -1,11 +1,16 @@ +#if ( HYBRID_COORD==1 ) +# define mu(...) (c1(k)*XXPCTXX(__VA_ARGS__)+c2(k)) +# define XXPCTXX(...) mu(__VA_ARGS__) +#endif + ! WRF:MODEL_LAYER:PHYSICS - + MODULE module_diffusion_em USE module_bc, only: set_physical_bc3d USE module_state_description, only: p_m23, p_m13, p_m22, p_m33, p_r23, p_r13, p_r12, p_m12, p_m11 USE module_big_step_utilities_em, only: grid_config_rec_type, param_first_scalar, p_qv, p_qi, p_qc - USE module_model_constants + USE module_model_constants CONTAINS @@ -15,7 +20,7 @@ MODULE module_diffusion_em SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & defor11, defor22, defor33, & defor12, defor13, defor23, & - nba_rij, n_nba_rij, & !JDM + nba_rij, n_nba_rij, & u_base, v_base, msfux, msfuy, & msfvx, msfvy, msftx, msfty, & rdx, rdy, dn, dnw, rdz, rdzw, & @@ -72,11 +77,11 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & :: u, v, w, zx, zy, rdz, rdzw REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & - :: defor11, defor22, defor33, defor12, defor13, defor23, div + :: defor11, defor22, defor33, defor12, defor13, defor23, div - INTEGER, INTENT( IN ) :: n_nba_rij !JDM + INTEGER, INTENT( IN ) :: n_nba_rij - REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_rij), INTENT(INOUT) & !JDM + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_rij), INTENT(INOUT) & :: nba_rij @@ -388,7 +393,7 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & END DO END DO -! End calculation of vertical divergence. +! End calculation of vertical divergence. !----------------------------------------------------------------------- ! Three-dimensional divergence is now finished and values are in array @@ -403,7 +408,7 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & ! (see e.g. Haltiner and Williams p. 441) !======================================================================= -! Calculate the final three deformations (defor12, defor13, defor23) at +! Calculate the final three deformations (defor12, defor13, defor23) at ! vorticity points. i_start = its @@ -413,7 +418,7 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & IF ( config_flags%open_xs .OR. config_flags%specified .OR. & config_flags%nested) i_start = MAX( ids+1, its ) - IF ( config_flags%open_xe .OR. config_flags%specified .OR. & + IF ( config_flags%open_xe .OR. config_flags%specified .OR. & config_flags%nested) i_end = MIN( ide-1, ite ) IF ( config_flags%open_ys .OR. config_flags%specified .OR. & config_flags%nested) j_start = MAX( jds+1, jts ) @@ -445,7 +450,7 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & DO j =j_start-1, j_end DO k =kts, ktf DO i =i_start, i_end - ! Fixes to set_physical_bc2/3d for polar boundary conditions + ! Fixes to set_physical_bc2/3d for polar boundary conditions ! remove issues with loop over j hat(i,k,j) = u(i,k,j) / msfux(i,j) END DO @@ -497,7 +502,7 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & END DO ! End calculation of du/dy. -!---------------------------------------------------------------------- +!---------------------------------------------------------------------- !----------------------------------------------------------------------- ! Add the first term to defor12 (du/dy+dv/dx) at vorticity points. @@ -507,7 +512,7 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & ! partial dpsi/dx * partial dv^/dpsi + ! partial dpsi/dy * partial du^/dpsi) ! Here deal with m^2 * (partial du^/dY + partial dpsi/dy * partial du^/dpsi) -! Still need to add v^ terms: +! Still need to add v^ terms: ! m^2 * (partial dv^/dX + partial dpsi/dx * partial dv^/dpsi) DO j = j_start, j_end @@ -602,11 +607,11 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & !JDM____________________________________________________________________ ! -! s12 = du/dy + dv/dx +! s12 = du/dy + dv/dx ! = (du/dy - dz/dy*du/dz) + (dv/dx - dz/dx*dv/dz) ! ______defor12______ ___tmp1___ ! -! r12 = du/dy - dv/dx +! r12 = du/dy - dv/dx ! = (du/dy - dz/dy*du/dz) - (dv/dx - dz/dx*dv/dz) ! ______defor12______ ___tmp1___ !_______________________________________________________________________ @@ -616,9 +621,9 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & DO k = kts, ktf DO i = i_start, i_end - nba_rij(i,k,j,P_r12) = defor12(i,k,j) - & - mm(i,j) * ( & - rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) + nba_rij(i,k,j,P_r12) = defor12(i,k,j) - & + mm(i,j) * ( & + rdx * ( hat(i,k,j) - hat(i-1,k,j) ) - tmp1(i,k,j) ) defor12(i,k,j) = defor12(i,k,j) + & mm(i,j) * ( & @@ -632,21 +637,21 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & !----------------------------------------------------------------------- ! Update the boundary for defor12 (might need to change later). - + IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN DO j = jts, jte DO k = kts, kte defor12(ids,k,j) = defor12(ids+1,k,j) - nba_rij(ids,k,j,P_r12) = nba_rij(ids+1,k,j,P_r12) + nba_rij(ids,k,j,P_r12) = nba_rij(ids+1,k,j,P_r12) END DO END DO END IF - + IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN DO k = kts, kte DO i = its, ite defor12(i,k,jds) = defor12(i,k,jds+1) - nba_rij(i,k,jds,P_r12) = nba_rij(i,k,jds+1,P_r12) + nba_rij(i,k,jds,P_r12) = nba_rij(i,k,jds+1,P_r12) END DO END DO END IF @@ -655,7 +660,7 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & DO j = jts, jte DO k = kts, kte defor12(ide,k,j) = defor12(ide-1,k,j) - nba_rij(ide,k,j,P_r12) = nba_rij(ide-1,k,j,P_r12) + nba_rij(ide,k,j,P_r12) = nba_rij(ide-1,k,j,P_r12) END DO END DO END IF @@ -664,7 +669,7 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & DO k = kts, kte DO i = its, ite defor12(i,k,jde) = defor12(i,k,jde-1) - nba_rij(i,k,jde,P_r12) = nba_rij(i,k,jde-1,P_r12) + nba_rij(i,k,jde,P_r12) = nba_rij(i,k,jde-1,P_r12) END DO END DO END IF @@ -686,7 +691,7 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & !----------------------------------------------------------------------- ! Update the boundary for defor12 (might need to change later). - + IF ( .NOT. config_flags%periodic_x .AND. i_start .EQ. ids+1 ) THEN DO j = jts, jte DO k = kts, kte @@ -694,7 +699,7 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & END DO END DO END IF - + IF ( .NOT. config_flags%periodic_y .AND. j_start .EQ. jds+1) THEN DO k = kts, kte DO i = its, ite @@ -867,25 +872,25 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & !JDM____________________________________________________________________ ! -! s13 = du/dz + dw/dx +! s13 = du/dz + dw/dx ! = du/dz + (dw/dx - dz/dx*dw/dz) ! = tmp1 + ______defor13______ ! -! r13 = du/dz - dw/dx -! = du/dz - (dw/dx - dz/dx*dw/dz) -! = tmp1 - ______defor13______ +! r13 = du/dz - dw/dx +! = du/dz - (dw/dx - dz/dx*dw/dz) +! = tmp1 - ______defor13______ !_______________________________________________________________________ DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end - nba_rij(i,k,j,P_r13) = tmp1(i,k,j) - defor13(i,k,j) + nba_rij(i,k,j,P_r13) = tmp1(i,k,j) - defor13(i,k,j) defor13(i,k,j) = defor13(i,k,j) + tmp1(i,k,j) END DO END DO END DO - DO j = j_start, j_end !change for different surface B. C. + DO j = j_start, j_end !change for different surface B. C. DO i = i_start, i_end nba_rij(i,kts ,j,P_r13) = 0.0 nba_rij(i,ktf+1,j,P_r13) = 0.0 @@ -1044,20 +1049,20 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & !JDM___________________________________________________________________ ! -! s23 = dv/dz + dw/dy +! s23 = dv/dz + dw/dy ! = dv/dz + (dw/dy - dz/dy*dw/dz) ! tmp1 + ______defor23______ ! -! r23 = dv/dz - dw/dy -! = dv/dz - (dw/dy - dz/dy*dw/dz) -! = tmp1 - ______defor23______ +! r23 = dv/dz - dw/dy +! = dv/dz - (dw/dy - dz/dy*dw/dz) +! = tmp1 - ______defor23______ ! Add tmp1 to defor23. DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end - nba_rij(i,k,j,P_r23) = tmp1(i,k,j) - defor23(i,k,j) + nba_rij(i,k,j,P_r23) = tmp1(i,k,j) - defor23(i,k,j) defor23(i,k,j) = defor23(i,k,j) + tmp1(i,k,j) END DO END DO @@ -1082,8 +1087,8 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & DO k = kts, kte defor13(ids,k,j) = defor13(ids+1,k,j) defor23(ids,k,j) = defor23(ids+1,k,j) - nba_rij(ids,k,j,P_r13) = nba_rij(ids+1,k,j,P_r13) - nba_rij(ids,k,j,P_r23) = nba_rij(ids+1,k,j,P_r23) + nba_rij(ids,k,j,P_r13) = nba_rij(ids+1,k,j,P_r13) + nba_rij(ids,k,j,P_r23) = nba_rij(ids+1,k,j,P_r23) END DO END DO END IF @@ -1093,8 +1098,8 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & DO i = its, ite defor13(i,k,jds) = defor13(i,k,jds+1) defor23(i,k,jds) = defor23(i,k,jds+1) - nba_rij(i,k,jds,P_r13) = nba_rij(i,k,jds+1,P_r13) - nba_rij(i,k,jds,P_r23) = nba_rij(i,k,jds+1,P_r23) + nba_rij(i,k,jds,P_r13) = nba_rij(i,k,jds+1,P_r13) + nba_rij(i,k,jds,P_r23) = nba_rij(i,k,jds+1,P_r23) END DO END DO END IF @@ -1104,8 +1109,8 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & DO k = kts, kte defor13(ide,k,j) = defor13(ide-1,k,j) defor23(ide,k,j) = defor23(ide-1,k,j) - nba_rij(ide,k,j,P_r13) = nba_rij(ide-1,k,j,P_r13) - nba_rij(ide,k,j,P_r23) = nba_rij(ide-1,k,j,P_r23) + nba_rij(ide,k,j,P_r13) = nba_rij(ide-1,k,j,P_r13) + nba_rij(ide,k,j,P_r23) = nba_rij(ide-1,k,j,P_r23) END DO END DO END IF @@ -1115,8 +1120,8 @@ SUBROUTINE cal_deform_and_div( config_flags, u, v, w, div, & DO i = its, ite defor13(i,k,jde) = defor13(i,k,jde-1) defor23(i,k,jde) = defor23(i,k,jde-1) - nba_rij(i,k,jde,P_r13) = nba_rij(i,k,jde-1,P_r13) - nba_rij(i,k,jde,P_r23) = nba_rij(i,k,jde-1,P_r23) + nba_rij(i,k,jde,P_r13) = nba_rij(i,k,jde-1,P_r13) + nba_rij(i,k,jde,P_r23) = nba_rij(i,k,jde-1,P_r23) END DO END DO END IF @@ -1223,13 +1228,13 @@ SUBROUTINE calculate_km_kh( config_flags, dt, & IMPLICIT NONE TYPE( grid_config_rec_type ), INTENT( IN ) & - :: config_flags + :: config_flags INTEGER, INTENT( IN ) & - :: n_moist, damp_opt, isotropic, & + :: n_moist, damp_opt, isotropic, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte + its, ite, jts, jte, kts, kte LOGICAL, INTENT( IN ) & :: warm_rain @@ -1244,7 +1249,7 @@ SUBROUTINE calculate_km_kh( config_flags, dt, & :: moist REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & - :: xkmv, xkmh, xkhv, xkhh, BN2 + :: xkmv, xkmh, xkhv, xkhh, BN2 REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT( IN ) & :: defor11, defor22, defor33, defor12, defor13, defor23, & @@ -1291,7 +1296,7 @@ SUBROUTINE calculate_km_kh( config_flags, dt, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CASE (2) + CASE (2) CALL tke_km( config_flags, xkmh, xkmv, & xkhh, xkhv, BN2, tke, p8w, t8w, theta, & rdz, rdzw, dx, dy, dt, isotropic, & @@ -1299,7 +1304,7 @@ SUBROUTINE calculate_km_kh( config_flags, dt, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CASE (3) + CASE (3) CALL smag_km( config_flags, xkmh, xkmv, & xkhh, xkhv, BN2, div, & defor11, defor22, defor33, & @@ -1309,7 +1314,7 @@ SUBROUTINE calculate_km_kh( config_flags, dt, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CASE (4) + CASE (4) CALL smag2d_km( config_flags, xkmh, xkmv, & xkhh, xkhv, defor11, defor22, defor12, & rdzw, dx, dy, msftx, msfty, & @@ -1360,7 +1365,7 @@ SUBROUTINE cal_dampkm( config_flags,xkmh,xkhh,xkmv,xkhv, & REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: xkmh , & xkhh , & xkmv , & - xkhv + xkhv REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rdz, & rdzw @@ -1499,7 +1504,7 @@ SUBROUTINE calculate_N2( config_flags, BN2, moist, & :: BN2 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & - :: rdz, rdzw, theta, t, p, p8w, t8w + :: rdz, rdzw, theta, t, p, p8w, t8w REAL, DIMENSION( kms:kme ), INTENT( IN ) & :: dnw, dn @@ -1547,7 +1552,7 @@ SUBROUTINE calculate_N2( config_flags, BN2, moist, & config_flags%nested) j_end = MIN( jde-2 ,jte ) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) - + IF ( P_QC .GT. PARAM_FIRST_SCALAR) THEN DO j = j_start, j_end DO k = kts, ktf @@ -1565,7 +1570,7 @@ SUBROUTINE calculate_N2( config_flags, BN2, moist, & END DO END DO END IF - + DO j = jts, jte DO k = kts, kte DO i = its, ite @@ -1573,14 +1578,14 @@ SUBROUTINE calculate_N2( config_flags, BN2, moist, & END DO END DO END DO - + DO j = jts,jte DO i = its,ite tmp1sfc(i,j) = 0.0 tmp1top(i,j) = 0.0 END DO END DO - + DO ispe = PARAM_FIRST_SCALAR, n_moist IF ( ispe .EQ. P_QV .OR. ispe .EQ. P_QC .OR. ispe .EQ. P_QI) THEN DO j = j_start, j_end @@ -1590,7 +1595,7 @@ SUBROUTINE calculate_N2( config_flags, BN2, moist, & END DO END DO END DO - + DO j = j_start, j_end DO i = i_start, i_end tmp1sfc(i,j) = tmp1sfc(i,j) + & @@ -1617,7 +1622,7 @@ SUBROUTINE calculate_N2( config_flags, BN2, moist, & END DO END DO END DO - + DO j = j_start, j_end DO k = kts+1, ktf-1 DO i = i_start, i_end @@ -1685,14 +1690,14 @@ SUBROUTINE calculate_N2( config_flags, BN2, moist, & ENDIF END DO END DO - + !...... MARTA: change in computation of BN2 at the top, WCS 040331 DO j = j_start, j_end DO i = i_start, i_end BN2(i,ktf,j)=BN2(i,ktf-1,j) END DO - END DO + END DO ! end of MARTA/WCS change END SUBROUTINE calculate_N2 @@ -1717,7 +1722,7 @@ SUBROUTINE isotropic_km( config_flags, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte - REAL , INTENT(IN ) :: khdif,kvdif + REAL , INTENT(IN ) :: khdif,kvdif REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(INOUT) :: xkmh, & xkmv, & @@ -1791,7 +1796,7 @@ SUBROUTINE smag_km( config_flags,xkmh,xkmv,xkhh,xkhv,BN2, & xkhh, & xkhv - REAL , DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(IN ) :: & + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(IN ) :: & defor11, & defor22, & defor33, & @@ -1944,7 +1949,7 @@ SUBROUTINE smag2d_km( config_flags,xkmh,xkmv,xkhh,xkhv, & xkhh, & xkhv - REAL , DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(IN ) :: & + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(IN ) :: & defor11, & defor22, & defor12 @@ -2127,7 +2132,7 @@ SUBROUTINE tke_km( config_flags, xkmh, xkmv, xkhh, xkhv, & DO j = j_start, j_end DO k = kts+1, ktf-1 DO i = i_start, i_end - tmpdz = 1.0 / rdz(i,k+1,j) + 1.0 / rdz(i,k,j) + tmpdz = 1.0 / rdz(i,k+1,j) + 1.0 / rdz(i,k,j) dthrdn(i,k,j) = ( theta(i,k+1,j) - theta(i,k-1,j) ) / tmpdz END DO END DO @@ -2136,7 +2141,7 @@ SUBROUTINE tke_km( config_flags, xkmh, xkmv, xkhh, xkhv, & k = kts DO j = j_start, j_end DO i = i_start, i_end - tmpdz = 1.0 / rdzw(i,k+1,j) + 1.0 / rdzw(i,k,j) + tmpdz = 1.0 / rdzw(i,k+1,j) + 1.0 / rdzw(i,k,j) thetasfc = T8w(i,kts,j) / ( p8w(i,k,j) / p1000mb )**( R_d / Cp ) dthrdn(i,k,j) = ( theta(i,k+1,j) - thetasfc ) / tmpdz END DO @@ -2279,16 +2284,16 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & chem_tendf, n_chem, & scalar_tendf, n_scalar, & tracer_tendf, n_tracer, & - thp, theta, mu, tke, config_flags, & + thp, theta, tke, config_flags, & defor11, defor22, defor12, & defor13, defor23, & - nba_mij, n_nba_mij, & !JDM + nba_mij, n_nba_mij, & div, & moist, chem, scalar,tracer, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, xkmh, xkhh,km_opt, & rdx, rdy, rdz, rdzw, fnm, fnp, & - cf1, cf2, cf3, zx, zy, dn, dnw, & + cf1, cf2, cf3, zx, zy, dn, dnw, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -2310,16 +2315,15 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp - REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw - REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & msfvy, & msftx, & - msfty, & - mu + msfty REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::rt_tendf,& ru_tendf,& @@ -2343,13 +2347,13 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & INTENT(IN ) :: moist REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_chem), & - INTENT(IN ) :: chem + INTENT(IN ) :: chem REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_scalar) , & - INTENT(IN ) :: scalar + INTENT(IN ) :: scalar REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_tracer) , & - INTENT(IN ) :: tracer + INTENT(IN ) :: tracer REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor11, & defor22, & @@ -2365,18 +2369,19 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & thp, & tke, & rdz, & - rdzw + rdzw, & + rho REAL , INTENT(IN ) :: rdx, & rdy - INTEGER, INTENT( IN ) :: n_nba_mij !JDM + INTEGER, INTENT( IN ) :: n_nba_mij - REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij ! LOCAL VARS - + INTEGER :: im, ic, is ! REAL , DIMENSION(its-1:ite+1, kts:kte, jts-1:jte+1) :: xkhh @@ -2387,41 +2392,41 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & !----------------------------------------------------------------------- ! Call diffusion subroutines. - CALL horizontal_diffusion_u_2( ru_tendf, mu, config_flags, & + CALL horizontal_diffusion_u_2( ru_tendf, config_flags, & defor11, defor12, div, & - nba_mij, n_nba_mij, & !JDM + nba_mij, n_nba_mij, & tke(ims,kms,jms), & msfux, msfuy, xkmh, rdx, rdy, fnm, fnp, & - zx, zy, rdzw, & + dnw, zx, zy, rdzw, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CALL horizontal_diffusion_v_2( rv_tendf, mu, config_flags, & + CALL horizontal_diffusion_v_2( rv_tendf, config_flags, & defor12, defor22, div, & - nba_mij, n_nba_mij, & !JDM + nba_mij, n_nba_mij, & tke(ims,kms,jms), & msfvx, msfvy, xkmh, rdx, rdy, fnm, fnp, & - zx, zy, rdzw, & + dnw, zx, zy, rdzw, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CALL horizontal_diffusion_w_2( rw_tendf, mu, config_flags, & + CALL horizontal_diffusion_w_2( rw_tendf, config_flags, & defor13, defor23, div, & - nba_mij, n_nba_mij, & !JDM + nba_mij, n_nba_mij, & tke(ims,kms,jms), & msftx, msfty, xkmh, rdx, rdy, fnm, fnp, & - zx, zy, rdz, & + dn, zx, zy, rdz, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CALL horizontal_diffusion_s ( rt_tendf, mu, config_flags, thp, & + CALL horizontal_diffusion_s ( rt_tendf, config_flags, thp, & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & - zx, zy, rdz, rdzw, dnw, dn, & + zx, zy, rdz, rdzw, dnw, dn, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -2429,28 +2434,28 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & IF (km_opt .eq. 2) & CALL horizontal_diffusion_s ( tke_tendf(ims,kms,jms), & - mu, config_flags, & + config_flags, & tke(ims,kms,jms), & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & - zx, zy, rdz, rdzw, dnw, dn, & + zx, zy, rdz, rdzw, dnw, dn, rho, & .true., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - IF (n_moist .ge. PARAM_FIRST_SCALAR) THEN + IF (n_moist .ge. PARAM_FIRST_SCALAR) THEN moist_loop: do im = PARAM_FIRST_SCALAR, n_moist CALL horizontal_diffusion_s( moist_tendf(ims,kms,jms,im), & - mu, config_flags, & + config_flags, & moist(ims,kms,jms,im), & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & - zx, zy, rdz, rdzw, dnw, dn, & + zx, zy, rdz, rdzw, dnw, dn, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -2460,37 +2465,37 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & ENDIF - IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN + IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN chem_loop: do ic = PARAM_FIRST_SCALAR, n_chem CALL horizontal_diffusion_s( chem_tendf(ims,kms,jms,ic), & - mu, config_flags, & + config_flags, & chem(ims,kms,jms,ic), & - msftx, msfty, msfux, msfuy, & - msfvx, msfvy, xkhh, rdx, rdy, & - fnm, fnp, cf1, cf2, cf3, & - zx, zy, rdz, rdzw, dnw, dn, & - .false., & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) + msftx, msfty, msfux, msfuy, & + msfvx, msfvy, xkhh, rdx, rdy, & + fnm, fnp, cf1, cf2, cf3, & + zx, zy, rdz, rdzw, dnw, dn, rho,& + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) ENDDO chem_loop ENDIF - IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN + IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN tracer_loop: do ic = PARAM_FIRST_SCALAR, n_tracer CALL horizontal_diffusion_s( tracer_tendf(ims,kms,jms,ic), & - mu, config_flags, & + config_flags, & tracer(ims,kms,jms,ic), & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & - zx, zy, rdz, rdzw, dnw, dn, & + zx, zy, rdz, rdzw, dnw, dn, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -2499,17 +2504,17 @@ SUBROUTINE horizontal_diffusion_2 ( rt_tendf, ru_tendf, rv_tendf, rw_tendf, & ENDDO tracer_loop ENDIF - IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN + IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN scalar_loop: do is = PARAM_FIRST_SCALAR, n_scalar CALL horizontal_diffusion_s( scalar_tendf(ims,kms,jms,is), & - mu, config_flags, & + config_flags, & scalar(ims,kms,jms,is), & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & - zx, zy, rdz, rdzw, dnw, dn, & + zx, zy, rdz, rdzw, dnw, dn, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -2524,13 +2529,13 @@ END SUBROUTINE horizontal_diffusion_2 !======================================================================= !======================================================================= -SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & +SUBROUTINE horizontal_diffusion_u_2( tendency, config_flags, & defor11, defor12, div, & - nba_mij, n_nba_mij, & !JDM + nba_mij, n_nba_mij, & tke, & msfux, msfuy, & xkmh, rdx, rdy, fnm, fnp, & - zx, zy, rdzw, & + dnw, zx, zy, rdzw, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -2548,74 +2553,80 @@ SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfux, & - msfuy, & - mu + msfuy REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency - REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rdzw - - + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rdzw, & + rho + + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) ::defor11, & defor12, & - div, & - tke, & + div, & + tke, & xkmh, & zx, & zy - INTEGER, INTENT( IN ) :: n_nba_mij !JDM + INTEGER, INTENT( IN ) :: n_nba_mij - REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij REAL , INTENT(IN ) :: rdx, & rdy ! Local data - + INTEGER :: i, j, k, ktf INTEGER :: i_start, i_end, j_start, j_end - INTEGER :: is_ext,ie_ext,js_ext,je_ext + INTEGER :: is_ext,ie_ext,js_ext,je_ext REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau1avg, & titau2avg, & - titau1, & - titau2, & - xkxavg, & - rravg + titau1, & + titau2, & + xkxavg, & + rravg, & + zy_at_u, & + zx_at_u + ! new -! zxavg, & +! zxavg, & ! zyavg REAL :: mrdx, mrdy, rcoup REAL :: tmpzy, tmpzeta_z + REAL :: tmpdz + REAL :: term1, term2, term3 ! End declarations. !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) - + !----------------------------------------------------------------------- ! u : p (.), u(|), w(-) -! +! ! p u p u u u ! ! p | . | . | . | k+1 | . | . | . | k+1 -! -! w - 13 - - k+1 13 k+1 ! -! p | 11 O 11 | . | k | 12 O 12 | . | k +! w - 13 - - k+1 13 k+1 +! +! p | 11 O 11 | . | k | 12 O 12 | . | k ! -! w - 13 - - k 13 k +! w - 13 - - k 13 k ! ! p | . | . | . | k-1 | . | . | . | k-1 ! -! i-1 i i i+1 j-1 j j j+1 j+1 +! i-1 i i i+1 j-1 j j j+1 j+1 ! i_start = its @@ -2634,14 +2645,14 @@ SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = ite -! titau1 = titau11 +! titau1 = titau11 is_ext=1 ie_ext=0 js_ext=0 je_ext=0 CALL cal_titau_11_22_33( config_flags, titau1, & - mu, tke, xkmh, defor11, & - nba_mij(ims,kms,jms,P_m11), & !JDM + tke, xkmh, defor11, & + nba_mij(ims,kms,jms,P_m11), rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -2653,15 +2664,15 @@ SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & js_ext=0 je_ext=1 CALL cal_titau_12_21( config_flags, titau2, & - mu, xkmh, defor12, & - nba_mij(ims,kms,jms,P_m12), & !JDM + xkmh, defor12, & + nba_mij(ims,kms,jms,P_m12), rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! titau1avg = titau11avg -! titau2avg = titau12avg +! titau2avg = titau12avg DO j = j_start, j_end DO k = kts+1,ktf @@ -2670,14 +2681,19 @@ SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & fnp(k)*(titau1(i-1,k-1,j)+titau1(i,k-1,j))) titau2avg(i,k,j)=0.5*(fnm(k)*(titau2(i,k ,j+1)+titau2(i,k ,j))+ & fnp(k)*(titau2(i,k-1,j+1)+titau2(i,k-1,j))) - tmpzy = 0.25*( zy(i-1,k,j )+zy(i,k,j )+ & - zy(i-1,k,j+1)+zy(i,k,j+1) ) +! tmpzy = 0.25*( zy(i-1,k,j )+zy(i,k,j )+ & +! zy(i-1,k,j+1)+zy(i,k,j+1) ) ! tmpzeta_z = 0.5*(zeta_z(i,j)+zeta_z(i-1,j)) ! titau1avg(i,k,j)=titau1avg(i,k,j)*zx(i,k,j)*tmpzeta_z ! titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy *tmpzeta_z - titau1avg(i,k,j)=titau1avg(i,k,j)*zx(i,k,j) - titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy + zx_at_u(i, k, j) = 0.5 * (zx(i, k, j) + zx(i, k + 1 , j)) + zy_at_u(i, k, j) = 0.125 * (zy(i - 1, k, j) + zy(i, k, j) + & + zy(i - 1, k, j + 1) + zy(i, k, j + 1) + zy(i - 1, k + 1, j) + & + zy(i, k + 1, j) + zy(i - 1, k + 1, j + 1) + zy(i, k + 1, j + 1)) + +! titau1avg(i,k,j)=titau1avg(i,k,j)*zx(i,k,j) +! titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy ENDDO ENDDO @@ -2689,6 +2705,10 @@ SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & titau1avg(i,ktf+1,j)=0. titau2avg(i,kts,j)=0. titau2avg(i,ktf+1,j)=0. + zx_at_u(i, kts, j) = 0.5 * (zx(i, kts, j) + zx(i, kts + 1 , j)) + zy_at_u(i, kts, j) = 0.125 * (zy(i - 1, kts, j) + zy(i, kts, j) + & + zy(i - 1, kts, j + 1) + zy(i, kts, j + 1) + zy(i - 1, kts + 1, j) + & + zy(i, kts + 1, j) + zy(i - 1, kts + 1, j + 1) + zy(i, kts + 1, j + 1)) ENDDO ENDDO ! @@ -2698,12 +2718,14 @@ SUBROUTINE horizontal_diffusion_u_2( tendency, mu, config_flags, & mrdx=msfux(i,j)*rdx mrdy=msfuy(i,j)*rdy - tendency(i,k,j)=tendency(i,k,j)- & - (mrdx*(titau1(i,k,j )-titau1(i-1,k,j))+ & - mrdy*(titau2(i,k,j+1)-titau2(i,k,j ))- & - msfuy(i,j)*rdzw(i,k,j)*((titau1avg(i,k+1,j)-titau1avg(i,k,j))+ & - (titau2avg(i,k+1,j)-titau2avg(i,k,j)) & - ) ) + + tmpdz = (1./rdzw(i,k,j)+1./rdzw(i-1,k,j))/2. + tendency(i,k,j)=tendency(i,k,j) + g*tmpdz/dnw(k) * & + (mrdx*(titau1(i,k,j ) - titau1(i-1,k,j)) + & + mrdy*(titau2(i,k,j+1) - titau2(i ,k,j)) - & + msfuy(i,j)*zx_at_u(i,k,j)*(titau1avg(i,k+1,j)-titau1avg(i,k,j)) / tmpdz - & + msfuy(i,j)*zy_at_u(i,k,j)*(titau2avg(i,k+1,j)-titau2avg(i,k,j)) / tmpdz & + ) ENDDO ENDDO ENDDO @@ -2713,13 +2735,13 @@ END SUBROUTINE horizontal_diffusion_u_2 !======================================================================= !======================================================================= -SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & +SUBROUTINE horizontal_diffusion_v_2( tendency, config_flags, & defor12, defor22, div, & - nba_mij, n_nba_mij, & !JDM + nba_mij, n_nba_mij, & tke, & msfvx, msfvy, & xkmh, rdx, rdy, fnm, fnp, & - zx, zy, rdzw, & + dnw, zx, zy, rdzw, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -2737,10 +2759,10 @@ SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfvx, & - msfvy, & - mu + msfvy REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency @@ -2751,11 +2773,12 @@ SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & xkmh, & zx, & zy, & - rdzw + rdzw, & + rho - INTEGER, INTENT( IN ) :: n_nba_mij !JDM + INTEGER, INTENT( IN ) :: n_nba_mij - REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij REAL , INTENT(IN ) :: rdx, & @@ -2766,43 +2789,45 @@ SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & INTEGER :: i, j, k, ktf INTEGER :: i_start, i_end, j_start, j_end - INTEGER :: is_ext,ie_ext,js_ext,je_ext + INTEGER :: is_ext,ie_ext,js_ext,je_ext REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau1avg, & titau2avg, & titau1, & titau2, & xkxavg, & - rravg + rravg, & + zy_at_v, & + zx_at_v ! new ! zxavg, & ! zyavg REAL :: mrdx, mrdy, rcoup - + REAL :: tmpdz REAL :: tmpzx, tmpzeta_z ! End declarations. !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) - + !----------------------------------------------------------------------- ! v : p (.), v(+), w(-) -! +! ! p v p v v v ! ! p + . + . + . + k+1 + . + . + . + k+1 -! -! w - 23 - - k+1 23 k+1 ! -! p + 22 O 22 + . + k + 21 O 21 + . + k +! w - 23 - - k+1 23 k+1 +! +! p + 22 O 22 + . + k + 21 O 21 + . + k ! -! w - 23 - - k 23 k +! w - 23 - - k 23 k ! ! p + . + . + . + k-1 + . + . + . + k-1 ! -! j-1 j j j+1 i-1 i i i+1 i+1 +! j-1 j j j+1 i-1 i i i+1 i+1 ! i_start = its @@ -2826,13 +2851,13 @@ SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & ie_ext=1 js_ext=0 je_ext=0 - CALL cal_titau_12_21( config_flags, titau1, & - mu, xkmh, defor12, & - nba_mij(ims,kms,jms,P_m12), & !JDM - is_ext,ie_ext,js_ext,je_ext, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) + CALL cal_titau_12_21( config_flags, titau1, & + xkmh, defor12, & + nba_mij(ims,kms,jms,P_m12),rho, & + is_ext,ie_ext,js_ext,je_ext, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) ! titau2 = titau22 is_ext=0 @@ -2840,8 +2865,8 @@ SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & js_ext=1 je_ext=0 CALL cal_titau_11_22_33( config_flags, titau2, & - mu, tke, xkmh, defor22, & - nba_mij(ims,kms,jms,P_m22), & !JDM + tke, xkmh, defor22, & + nba_mij(ims,kms,jms,P_m22),rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -2855,12 +2880,15 @@ SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & titau2avg(i,k,j)=0.5*(fnm(k)*(titau2(i,k ,j-1)+titau2(i,k ,j))+ & fnp(k)*(titau2(i,k-1,j-1)+titau2(i,k-1,j))) - tmpzx = 0.25*( zx(i,k,j )+zx(i+1,k,j )+ & - zx(i,k,j-1)+zx(i+1,k,j-1) ) +! tmpzx = 0.25*( zx(i,k,j )+zx(i+1,k,j )+ & +! zx(i,k,j-1)+zx(i+1,k,j-1) ) + zx_at_v(i, k, j) = 0.125 * (zx(i, k, j) + zx(i + 1, k, j) + & + zx(i, k, j - 1) + zx(i + 1, k, j - 1) + zx(i, k + 1, j) + & + zx(i + 1, k + 1, j) + zx(i, k + 1, j - 1) + zx(i + 1, k + 1, j - 1)) + zy_at_v(i, k, j) = 0.5 * (zy(i, k, j) + zy(i, k + 1 , j)) - - titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx - titau2avg(i,k,j)=titau2avg(i,k,j)*zy(i,k,j) +! titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx +! titau2avg(i,k,j)=titau2avg(i,k,j)*zy(i,k,j) ENDDO @@ -2873,22 +2901,26 @@ SUBROUTINE horizontal_diffusion_v_2( tendency, mu, config_flags, & titau1avg(i,ktf+1,j)=0. titau2avg(i,kts,j)=0. titau2avg(i,ktf+1,j)=0. + zx_at_v(i, kts, j) = 0.125 * (zx(i, kts, j) + zx(i + 1, kts, j) + & + zx(i, kts, j - 1) + zx(i + 1, kts, j - 1) + zx(i, kts + 1, j) + & + zx(i + 1, kts + 1, j) + zx(i, kts + 1, j - 1) + zx(i + 1, kts + 1, j - 1)) + zy_at_v(i, kts, j) = 0.5 * (zy(i, kts, j) + zy(i, kts + 1 , j)) ENDDO ENDDO ! DO j = j_start, j_end DO k = kts,ktf DO i = i_start, i_end - + mrdx=msfvx(i,j)*rdx mrdy=msfvy(i,j)*rdy - tendency(i,k,j)=tendency(i,k,j)- & - (mrdy*(titau2(i ,k,j)-titau2(i,k,j-1))+ & - mrdx*(titau1(i+1,k,j)-titau1(i,k,j ))- & - msfvy(i,j)*rdzw(i,k,j)*((titau1avg(i,k+1,j)-titau1avg(i,k,j))+ & - (titau2avg(i,k+1,j)-titau2avg(i,k,j)) & - ) & - ) + tmpdz = (1./rdzw(i,k,j)+1./rdzw(i,k,j-1))/2. + tendency(i,k,j)=tendency(i,k,j) + g*tmpdz/dnw(k) * & + (mrdy*(titau2(i,k,j ) - titau2(i,k,j-1)) + & + mrdx*(titau1(i+1,k,j) - titau1(i ,k,j)) - & + msfvy(i,j)*zx_at_v(i,k,j)*(titau1avg(i,k+1,j)-titau1avg(i,k,j)) / tmpdz - & + msfvy(i,j)*zy_at_v(i,k,j)*(titau2avg(i,k+1,j)-titau2avg(i,k,j)) / tmpdz & + ) ENDDO ENDDO @@ -2899,13 +2931,13 @@ END SUBROUTINE horizontal_diffusion_v_2 !======================================================================= !======================================================================= -SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & +SUBROUTINE horizontal_diffusion_w_2( tendency, config_flags, & defor13, defor23, div, & - nba_mij, n_nba_mij, & !JDM + nba_mij, n_nba_mij, & tke, & msftx, msfty, & xkmh, rdx, rdy, fnm, fnp, & - zx, zy, rdz, & + dn, zx, zy, rdz, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -2923,10 +2955,10 @@ SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msftx, & - msfty, & - mu + msfty REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency @@ -2937,11 +2969,12 @@ SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & xkmh, & zx, & zy, & - rdz + rdz, & + rho - INTEGER, INTENT( IN ) :: n_nba_mij !JDM + INTEGER, INTENT( IN ) :: n_nba_mij - REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij REAL , INTENT(IN ) :: rdx, & @@ -2952,14 +2985,16 @@ SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & INTEGER :: i, j, k, ktf INTEGER :: i_start, i_end, j_start, j_end - INTEGER :: is_ext,ie_ext,js_ext,je_ext + INTEGER :: is_ext,ie_ext,js_ext,je_ext REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau1avg, & titau2avg, & titau1, & titau2, & xkxavg, & - rravg + rravg, & + zx_at_w, & + zy_at_w ! new ! zxavg, & ! zyavg @@ -2972,23 +3007,23 @@ SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) - + !----------------------------------------------------------------------- ! w : p (.), u(|), v(+), w(-) -! -! p u p u p v p v ! -! w - - - k+1 w - - - k+1 +! p u p u p v p v ! -! p . | 33 | . k p . + 33 + . k +! w - - - k+1 w - - - k+1 ! -! w - 31 O 31 - k w - 32 O 32 - k +! p . | 33 | . k p . + 33 + . k ! -! p . | 33 | . k-1 p . | 33 | . k-1 +! w - 31 O 31 - k w - 32 O 32 - k ! -! w - - - k-1 w - - - k-1 +! p . | 33 | . k-1 p . | 33 | . k-1 ! -! i-1 i i i+1 j-1 j j j+1 +! w - - - k-1 w - - - k-1 +! +! i-1 i i i+1 j-1 j j j+1 ! i_start = its i_end = MIN(ite,ide-1) @@ -3012,8 +3047,8 @@ SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & js_ext=0 je_ext=0 CALL cal_titau_13_31( config_flags, titau1, defor13, & - nba_mij(ims,kms,jms,P_m13), & !JDM - mu, xkmh, fnm, fnp, & + nba_mij(ims,kms,jms,P_m13), & + xkmh, fnm, fnp, rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3025,8 +3060,8 @@ SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & js_ext=0 je_ext=1 CALL cal_titau_23_32( config_flags, titau2, defor23, & - nba_mij(ims,kms,jms,P_m23), & !JDM - mu, xkmh, fnm, fnp, & + nba_mij(ims,kms,jms,P_m23), & + xkmh, fnm, fnp, rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3042,14 +3077,16 @@ SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & titau1(i+1,k ,j)+titau1(i,k ,j)) titau2avg(i,k,j)=0.25*(titau2(i,k+1,j+1)+titau2(i,k+1,j)+ & titau2(i,k ,j+1)+titau2(i,k ,j)) + zx_at_w(i, k, j) = 0.5 * (zx(i, k, j) + zx(i + 1, k, j)) + zy_at_w(i, k, j) = 0.5 * (zy(i, k, j) + zy(i, k, j + 1)) ! new - tmpzx =0.25*( zx(i,k ,j)+zx(i+1,k ,j)+ & - zx(i,k+1,j)+zx(i+1,k+1,j) ) - tmpzy =0.25*( zy(i,k ,j)+zy(i,k ,j+1)+ & - zy(i,k+1,j)+zy(i,k+1,j+1) ) +! tmpzx =0.25*( zx(i,k ,j)+zx(i+1,k ,j)+ & +! zx(i,k+1,j)+zx(i+1,k+1,j) ) +! tmpzy =0.25*( zy(i,k ,j)+zy(i,k ,j+1)+ & +! zy(i,k+1,j)+zy(i,k+1,j+1) ) - titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx - titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy +! titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx +! titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy ! titau1avg(i,k,j)=titau1avg(i,k,j)*tmpzx*zeta_z(i,j) ! titau2avg(i,k,j)=titau2avg(i,k,j)*tmpzy*zeta_z(i,j) ENDDO @@ -3070,17 +3107,13 @@ SUBROUTINE horizontal_diffusion_w_2( tendency, mu, config_flags, & mrdx=msftx(i,j)*rdx mrdy=msfty(i,j)*rdy - tendency(i,k,j)=tendency(i,k,j)- & - (mrdx*(titau1(i+1,k,j)-titau1(i,k,j))+ & - mrdy*(titau2(i,k,j+1)-titau2(i,k,j))- & - msfty(i,j)*rdz(i,k,j)*(titau1avg(i,k,j)-titau1avg(i,k-1,j)+ & - titau2avg(i,k,j)-titau2avg(i,k-1,j) & - ) & + tendency(i,k,j)=tendency(i,k,j) + g/(dn(k)*rdz(i,k,j)) * & + (mrdx*(titau1(i+1,k,j)-titau1(i,k,j))+ & + mrdy*(titau2(i,k,j+1)-titau2(i,k,j))- & + msfty(i,j)*rdz(i,k,j)*(zx_at_w(i,k,j)*(titau1avg(i,k,j)-titau1avg(i,k-1,j))+ & + zy_at_w(i,k,j)*(titau2avg(i,k,j)-titau2avg(i,k-1,j)) & + ) & ) -! msft(i,j)/dn(k)*(titau1avg(i,k,j)-titau1avg(i,k-1,j)+ & -! titau2avg(i,k,j)-titau2avg(i,k-1,j) & -! ) & -! ) ENDDO ENDDO ENDDO @@ -3090,11 +3123,11 @@ END SUBROUTINE horizontal_diffusion_w_2 !======================================================================= !======================================================================= -SUBROUTINE horizontal_diffusion_s (tendency, mu, config_flags, var, & +SUBROUTINE horizontal_diffusion_s (tendency, config_flags, var, & msftx, msfty, msfux, msfuy, & msfvx, msfvy, xkhh, rdx, rdy, & fnm, fnp, cf1, cf2, cf3, & - zx, zy, rdz, rdzw, dnw, dn, & + zx, zy, rdz, rdzw, dnw, dn, rho, & doing_tke, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3127,17 +3160,13 @@ SUBROUTINE horizontal_diffusion_s (tendency, mu, config_flags, var, & REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msftx REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: msfty - REAL , DIMENSION( ims:ime, jms:jme) , INTENT(IN ) :: mu - -! REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1), & -! INTENT(IN ) :: xkhh - REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) :: tendency REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: & xkhh, & rdz, & - rdzw + rdzw, & + rho REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: var, & zx, & @@ -3156,10 +3185,9 @@ SUBROUTINE horizontal_diffusion_s (tendency, mu, config_flags, var, & H2avg, & H1, & H2, & - xkxavg -! new -! zxavg, & -! zyavg + xkxavg, & + zx_at_m, & + zy_at_m REAL , DIMENSION( its:ite, kts:kte, jts:jte) :: tmptendf @@ -3171,23 +3199,23 @@ SUBROUTINE horizontal_diffusion_s (tendency, mu, config_flags, var, & !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) - + !----------------------------------------------------------------------- ! scalars: t (.), u(|), v(+), w(-) -! -! t u t u t v t v ! -! w - 3 - k+1 w - 3 - k+1 +! t u t u t v t v +! +! w - 3 - k+1 w - 3 - k+1 ! -! t . 1 O 1 . k t . 2 O 2 . k +! t . 1 O 1 . k t . 2 O 2 . k ! -! w - 3 - k w - 3 - k +! w - 3 - k w - 3 - k ! -! t . | . | . k-1 t . + . + . k-1 +! t . | . | . k-1 t . + . + . k-1 ! -! w - - - k-1 w - - - k-1 +! w - - - k-1 w - - - k-1 ! -! t i-1 i i i+1 j-1 j j j+1 +! t i-1 i i i+1 j-1 j j j+1 ! ktes1=kte-1 @@ -3226,9 +3254,7 @@ SUBROUTINE horizontal_diffusion_s (tendency, mu, config_flags, var, & DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end + 1 -! new -! zxavg(i,k,j) =0.5*( zx(i-1,k,j)+ zx(i,k,j)) - xkxavg(i,k,j)=0.5*(xkhh(i-1,k,j)+xkhh(i,k,j)) + xkxavg(i,k,j)=0.5*(xkhh(i-1,k,j)+xkhh(i,k,j))*0.5*(rho(i-1,k,j)+rho(i,k,j)) ENDDO ENDDO ENDDO @@ -3260,7 +3286,7 @@ SUBROUTINE horizontal_diffusion_s (tendency, mu, config_flags, var, & ! new tmpzx = 0.5*( zx(i,k,j)+ zx(i,k+1,j)) rdzu = 2./(1./rdzw(i,k,j) + 1./rdzw(i-1,k,j)) - H1(i,k,j)=-msfuy(i,j)*xkxavg(i,k,j)*( & + H1(i,k,j)=-msfux(i,j)*xkxavg(i,k,j)*( & rdx*(var(i,k,j)-var(i-1,k,j)) - tmpzx* & (H1avg(i,k+1,j)-H1avg(i,k,j))*rdzu ) @@ -3277,9 +3303,7 @@ SUBROUTINE horizontal_diffusion_s (tendency, mu, config_flags, var, & DO j = j_start, j_end + 1 DO k = kts, ktf DO i = i_start, i_end -! new -! zyavg(i,k,j) =0.5*( zy(i,k,j-1)+ zy(i,k,j)) - xkxavg(i,k,j)=0.5*(xkhh(i,k,j-1)+xkhh(i,k,j)) + xkxavg(i,k,j)=0.5*(xkhh(i,k,j-1)+xkhh(i,k,j))*0.5*(rho(i,k,j-1)+rho(i,k,j)) ENDDO ENDDO ENDDO @@ -3287,7 +3311,6 @@ SUBROUTINE horizontal_diffusion_s (tendency, mu, config_flags, var, & DO j = j_start, j_end + 1 DO k = kts+1, ktf DO i = i_start, i_end -! new H2avg(i,k,j)=0.5*(fnm(k)*(var(i,k ,j-1)+var(i,k ,j))+ & fnp(k)*(var(i,k-1,j-1)+var(i,k-1,j))) ENDDO @@ -3338,24 +3361,24 @@ SUBROUTINE horizontal_diffusion_s (tendency, mu, config_flags, var, & ! H1avg(i,k,j)=zx*H1avg*zeta_z ! H2avg(i,k,j)=zy*H2avg*zeta_z - tmpzx = 0.5*( zx(i,k,j)+ zx(i+1,k,j )) - tmpzy = 0.5*( zy(i,k,j)+ zy(i ,k,j+1)) - - H1avg(i,k,j)=H1avg(i,k,j)*tmpzx - H2avg(i,k,j)=H2avg(i,k,j)*tmpzy + zx_at_m(i, k, j) = 0.25*(zx(i,k,j)+ zx(i+1,k,j) + zx(i,k+1,j)+ zx(i+1,k+1,j)) + zy_at_m(i, k, j) = 0.25*(zy(i,k,j)+ zy(i,k,j+1) + zy(i,k+1,j)+ zy(i,k+1,j+1)) ! H1avg(i,k,j)=H1avg(i,k,j)*tmpzx*zeta_z(i,j) ! H2avg(i,k,j)=H2avg(i,k,j)*tmpzy*zeta_z(i,j) ENDDO ENDDO ENDDO - + DO j = j_start, j_end DO i = i_start, i_end H1avg(i,kts ,j)=0. H1avg(i,ktf+1,j)=0. H2avg(i,kts ,j)=0. H2avg(i,ktf+1,j)=0. + zx_at_m(i, kts, j) = 0.25*(zx(i,kts,j)+ zx(i+1,kts,j) + zx(i,kts+1,j)+ zx(i+1,kts+1,j)) + zy_at_m(i, kts, j) = 0.25*(zy(i,kts,j)+ zy(i,kts,j+1) + zy(i,kts+1,j)+ zy(i,kts+1,j+1)) + ENDDO ENDDO @@ -3366,20 +3389,16 @@ SUBROUTINE horizontal_diffusion_s (tendency, mu, config_flags, var, & mrdx=msftx(i,j)*rdx mrdy=msfty(i,j)*rdy - tendency(i,k,j)=tendency(i,k,j)- & - (mrdx*0.5*((mu(i+1,j)+mu(i,j))*H1(i+1,k,j)- & - (mu(i-1,j)+mu(i,j))*H1(i ,k,j))+ & - mrdy*0.5*((mu(i,j+1)+mu(i,j))*H2(i,k,j+1)- & - (mu(i,j-1)+mu(i,j))*H2(i,k,j ))- & - msfty(i,j)*mu(i,j)*(H1avg(i,k+1,j)-H1avg(i,k,j)+ & - H2avg(i,k+1,j)-H2avg(i,k,j) & - )*rdzw(i,k,j) & - ) - + tendency(i,k,j)=tendency(i,k,j) + g/(dnw(k)*rdzw(i,k,j)) * & + (mrdx*(H1(i+1,k,j)-H1(i ,k,j)) + & + mrdy*(H2(i,k,j+1)-H2(i,k,j )) - & + msftx(i,j)*zx_at_m(i, k, j)*(H1avg(i,k+1,j)-H1avg(i,k,j))*rdzw(i,k,j) - & + msfty(i,j)*zy_at_m(i, k, j)*(H2avg(i,k+1,j)-H2avg(i,k,j))*rdzw(i,k,j) & + ) ENDDO ENDDO ENDDO - + IF ( doing_tke ) THEN DO j = j_start, j_end DO k = kts,ktf @@ -3402,9 +3421,9 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & scalar_tendf, n_scalar, & tracer_tendf, n_tracer, & u_2, v_2, & - thp,u_base,v_base,t_base,qv_base,mu,tke, & + thp,u_base,v_base,t_base,qv_base,tke, & config_flags,defor13,defor23,defor33, & - nba_mij, n_nba_mij, & !JDM + nba_mij, n_nba_mij, & div, & moist,chem,scalar,tracer, & xkmv,xkhv,xkmh,km_opt, & ! xkmh added @@ -3431,7 +3450,6 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnp REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dnw REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: qv_base REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: u_base @@ -3442,7 +3460,7 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & rv_tendf,& rw_tendf,& tke_tendf,& - rt_tendf + rt_tendf REAL , DIMENSION( ims:ime, kms:kme, jms:jme, n_moist), & INTENT(INOUT) :: moist_tendf @@ -3479,12 +3497,12 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & v_2, & rdzw - INTEGER, INTENT( IN ) :: n_nba_mij !JDM + INTEGER, INTENT( IN ) :: n_nba_mij - REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij - REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rho + REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(IN ) :: rho REAL , DIMENSION( ims:ime, jms:jme), INTENT(INOUT) :: hfx, & qfx REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: ust @@ -3522,28 +3540,28 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & ! !----------------------------------------------------------------------- - CALL vertical_diffusion_u_2( ru_tendf, config_flags, mu, & + CALL vertical_diffusion_u_2( ru_tendf, config_flags, & defor13, xkmv, & - nba_mij, n_nba_mij, & !JDM - dnw, rdzw, fnm, fnp, & + nba_mij, n_nba_mij, & + dnw, rdzw, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CALL vertical_diffusion_v_2( rv_tendf, config_flags, mu, & + CALL vertical_diffusion_v_2( rv_tendf, config_flags, & defor23, xkmv, & - nba_mij, n_nba_mij, & !JDM - dnw, rdzw, fnm, fnp, & + nba_mij, n_nba_mij, & + dnw, rdzw, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CALL vertical_diffusion_w_2( rw_tendf, config_flags, mu, & + CALL vertical_diffusion_w_2( rw_tendf, config_flags, & defor33, tke(ims,kms,jms), & - nba_mij, n_nba_mij, & !JDM - div, xkmh, & !Mod from RR Oct2013 was xkmv - dn, rdz, & + nba_mij, n_nba_mij, & + div, xkmh, & + dn, rdz, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -3567,12 +3585,12 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & v_2(i ,kts,j+1)+ & v_2(i-1,kts,j )+ & v_2(i-1,kts,j+1))/4)**2))+epsilon - tao_xz=cd0*V0_u*u_2(i,kts,j) - ru_tendf(i,kts,j)=ru_tendf(i,kts,j) & - -0.25*(mu(i,j)+mu(i-1,j))*tao_xz*(rdzw(i,kts,j)+rdzw(i-1,kts,j)) + + tao_xz=cd0*V0_u*u_2(i,kts,j)*(rho(i,kts,j)+rho(i-1,kts,j))/2. + ru_tendf(i,kts,j)=ru_tendf(i,kts,j) + g*tao_xz/dnw(kts) IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN nba_mij(i,kts,j,P_m13) = -tao_xz - ENDIF + ENDIF ENDDO ENDDO ! @@ -3585,9 +3603,9 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & u_2(i ,kts,j-1)+ & u_2(i+1,kts,j )+ & u_2(i+1,kts,j-1))/4)**2))+epsilon - tao_yz=cd0*V0_v*v_2(i,kts,j) - rv_tendf(i,kts,j)=rv_tendf(i,kts,j) & - -0.25*(mu(i,j)+mu(i,j-1))*tao_yz*(rdzw(i,kts,j)+rdzw(i,kts,j-1)) + + tao_yz=cd0*V0_v*v_2(i,kts,j)*(rho(i,kts,j)+rho(i,kts,j-1))/2. + rv_tendf(i,kts,j)=rv_tendf(i,kts,j) + g*tao_yz/dnw(kts) IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN nba_mij(i,kts,j,P_m23) = -tao_yz ENDIF @@ -3605,15 +3623,15 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & v_2(i-1,kts,j )+ & v_2(i-1,kts,j+1))/4)**2))+epsilon ustar=0.5*(ust(i,j)+ust(i-1,j)) - tao_xz=ustar*ustar*u_2(i,kts,j)/V0_u - ru_tendf(i,kts,j)=ru_tendf(i,kts,j) & - -0.25*(mu(i,j)+mu(i-1,j))*tao_xz*(rdzw(i,kts,j)+rdzw(i-1,kts,j)) + + tao_xz=ustar*ustar*u_2(i,kts,j)*(rho(i,kts,j)+rho(i-1,kts,j))/(2.*V0_u) + ru_tendf(i,kts,j)=ru_tendf(i,kts,j) + g*tao_xz/dnw(kts) IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN nba_mij(i,kts,j,P_m13) = -tao_xz ENDIF ENDDO ENDDO - + DO j = j_start, jte DO i = i_start, i_end V0_v=0. @@ -3624,9 +3642,9 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & u_2(i+1,kts,j )+ & u_2(i+1,kts,j-1))/4)**2))+epsilon ustar=0.5*(ust(i,j)+ust(i,j-1)) - tao_yz=ustar*ustar*v_2(i,kts,j)/V0_v - rv_tendf(i,kts,j)=rv_tendf(i,kts,j) & - -0.25*(mu(i,j)+mu(i,j-1))*tao_yz*(rdzw(i,kts,j)+rdzw(i,kts,j-1)) + + tao_yz=ustar*ustar*v_2(i,kts,j)*(rho(i,kts,j)+rho(i,kts,j-1))/(2.*V0_v) + rv_tendf(i,kts,j)=rv_tendf(i,kts,j) + g*tao_yz/dnw(kts) IF ( (config_flags%m_opt .EQ. 1) .OR. (config_flags%sfs_opt .GT. 0) ) THEN nba_mij(i,kts,j,P_m23) = -tao_yz ENDIF @@ -3664,8 +3682,8 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & END IF - CALL vertical_diffusion_s( rt_tendf, config_flags, var_mix, mu, xkhv, & - dn, dnw, rdz, rdzw, fnm, fnp, & + CALL vertical_diffusion_s( rt_tendf, config_flags, var_mix, xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3683,10 +3701,10 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & ! set in namelist.input DO j = j_start, j_end DO i = i_start, i_end - cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) - hfx(i,j)=heat_flux*cp*rho(i,1,j) ! provided for output only + cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) + hfx(i,j)=heat_flux*cpm*rho(i,kts,j) ! provided for output only rt_tendf(i,kts,j)=rt_tendf(i,kts,j) & - +mu(i,j)*heat_flux*rdzw(i,kts,j) + -g*heat_flux*rho(i,kts,j)/dnw(kts) ENDDO ENDDO @@ -3695,9 +3713,9 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & DO i = i_start, i_end cpm = cp * (1. + 0.8 * moist(i,kts,j,P_QV)) - heat_flux = hfx(i,j)/cpm/rho(i,1,j) + heat_flux = hfx(i,j)/cpm rt_tendf(i,kts,j)=rt_tendf(i,kts,j) & - +mu(i,j)*heat_flux*rdzw(i,kts,j) + -g*heat_flux/dnw(kts) ENDDO ENDDO @@ -3714,15 +3732,15 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & If (km_opt .eq. 2) then CALL vertical_diffusion_s( tke_tendf(ims,kms,jms), & config_flags, tke(ims,kms,jms), & - mu, xkhv, & - dn, dnw, rdz, rdzw, fnm, fnp, & + xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, rho, & .true., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) endif - - IF (n_moist .ge. PARAM_FIRST_SCALAR) THEN + + IF (n_moist .ge. PARAM_FIRST_SCALAR) THEN moist_loop: do im = PARAM_FIRST_SCALAR, n_moist @@ -3751,8 +3769,8 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & CALL vertical_diffusion_s( moist_tendf(ims,kms,jms,im), & config_flags, var_mix, & - mu, xkhv, & - dn, dnw, rdz, rdzw, fnm, fnp, & + xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3766,13 +3784,13 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & qflux: SELECT CASE( config_flags%isfflx ) CASE (0) ! do nothing - CASE (1,2) ! with surface moisture flux + CASE (1,2) ! with surface moisture flux IF ( im == P_QV ) THEN DO j = j_start, j_end DO i = i_start, i_end - moist_flux = qfx(i,j)/rho(i,1,j)/(1.+moist(i,kts,j,P_QV)) + moist_flux = qfx(i,j) moist_tendf(i,kts,j,im)=moist_tendf(i,kts,j,im) & - +mu(i,j)*moist_flux*rdzw(i,kts,j) + -g*moist_flux/dnw(kts) ENDDO ENDDO ENDIF @@ -3788,30 +3806,30 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & ENDIF - IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN + IF (n_chem .ge. PARAM_FIRST_SCALAR) THEN chem_loop: do im = PARAM_FIRST_SCALAR, n_chem CALL vertical_diffusion_s( chem_tendf(ims,kms,jms,im), & config_flags, chem(ims,kms,jms,im), & - mu, xkhv, & - dn, dnw, rdz, rdzw, fnm, fnp, & - .false., & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & + xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, rho, & + .false., & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ENDDO chem_loop ENDIF - IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN + IF (n_tracer .ge. PARAM_FIRST_SCALAR) THEN tracer_loop: do im = PARAM_FIRST_SCALAR, n_tracer CALL vertical_diffusion_s( tracer_tendf(ims,kms,jms,im), & config_flags, tracer(ims,kms,jms,im), & - mu, xkhv, & - dn, dnw, rdz, rdzw, fnm, fnp, & + xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3821,14 +3839,14 @@ SUBROUTINE vertical_diffusion_2 ( ru_tendf, rv_tendf, rw_tendf, rt_tendf, & ENDIF - IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN + IF (n_scalar .ge. PARAM_FIRST_SCALAR) THEN scalar_loop: do im = PARAM_FIRST_SCALAR, n_scalar CALL vertical_diffusion_s( scalar_tendf(ims,kms,jms,im), & config_flags, scalar(ims,kms,jms,im), & - mu, xkhv, & - dn, dnw, rdz, rdzw, fnm, fnp, & + xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, rho, & .false., & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3842,10 +3860,10 @@ END SUBROUTINE vertical_diffusion_2 !======================================================================= !======================================================================= -SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, mu, & +SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, & defor13, xkmv, & - nba_mij, n_nba_mij, & !JDM - dnw, rdzw, fnm, fnp, & + nba_mij, n_nba_mij, & + dnw, rdzw, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -3871,21 +3889,20 @@ SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, mu, & REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & INTENT(IN ) ::defor13, & xkmv, & - rdzw + rdzw, & + rho - INTEGER, INTENT( IN ) :: n_nba_mij !JDM + INTEGER, INTENT( IN ) :: n_nba_mij - REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu - ! LOCAL VARS INTEGER :: i, j, k, ktf INTEGER :: i_start, i_end, j_start, j_end - INTEGER :: is_ext,ie_ext,js_ext,je_ext + INTEGER :: is_ext,ie_ext,js_ext,je_ext REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau3 @@ -3897,7 +3914,7 @@ SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, mu, & !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) - + i_start = its i_end = ite j_start = jts @@ -3920,8 +3937,8 @@ SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, mu, & js_ext=0 je_ext=0 CALL cal_titau_13_31( config_flags, titau3, defor13, & - nba_mij(ims,kms,jms,P_m13), & !JDM - mu, xkmv, fnm, fnp, & + nba_mij(ims,kms,jms,P_m13), & + xkmv, fnm, fnp, rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3931,7 +3948,7 @@ SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, mu, & DO k=kts+1,ktf DO i = i_start, i_end - rdzu = 2./(1./rdzw(i,k,j) + 1./rdzw(i-1,k,j)) + rdzu = -g/(dnw(k)) tendency(i,k,j)=tendency(i,k,j)-rdzu*(titau3(i,k+1,j)-titau3(i,k,j)) ENDDO @@ -3944,8 +3961,8 @@ SUBROUTINE vertical_diffusion_u_2( tendency, config_flags, mu, & DO j = j_start, j_end k=kts DO i = i_start, i_end - - rdzu = 2./(1./rdzw(i,k,j) + 1./rdzw(i-1,k,j)) + + rdzu = -g/dnw(k) tendency(i,k,j)=tendency(i,k,j)-rdzu*(titau3(i,k+1,j)) ENDDO ENDDO @@ -3956,10 +3973,10 @@ END SUBROUTINE vertical_diffusion_u_2 !======================================================================= !======================================================================= -SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, mu, & +SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, & defor23, xkmv, & - nba_mij, n_nba_mij, & !JDM - dnw, rdzw, fnm, fnp, & + nba_mij, n_nba_mij, & + dnw, rdzw, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -3983,21 +4000,20 @@ SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, mu, & REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & INTENT(IN ) ::defor23, & xkmv, & - rdzw + rdzw, & + rho - INTEGER, INTENT( IN ) :: n_nba_mij !JDM + INTEGER, INTENT( IN ) :: n_nba_mij - REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: mu - ! LOCAL VARS INTEGER :: i, j, k, ktf INTEGER :: i_start, i_end, j_start, j_end - INTEGER :: is_ext,ie_ext,js_ext,je_ext + INTEGER :: is_ext,ie_ext,js_ext,je_ext REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau3 @@ -4009,7 +4025,7 @@ SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, mu, & !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) - + i_start = its i_end = MIN(ite,ide-1) j_start = jts @@ -4032,8 +4048,8 @@ SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, mu, & js_ext=0 je_ext=0 CALL cal_titau_23_32( config_flags, titau3, defor23, & - nba_mij(ims,kms,jms,P_m23), & !JDM - mu, xkmv, fnm, fnp, & + nba_mij(ims,kms,jms,P_m23), & + xkmv, fnm, fnp, rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4043,7 +4059,7 @@ SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, mu, & DO k = kts+1,ktf DO i = i_start, i_end - rdzv = 2./(1./rdzw(i,k,j) + 1./rdzw(i,k,j-1)) + rdzv = - g / dnw(k) tendency(i,k,j)=tendency(i,k,j)-rdzv*(titau3(i,k+1,j)-titau3(i,k,j)) ENDDO @@ -4056,10 +4072,10 @@ SUBROUTINE vertical_diffusion_v_2( tendency, config_flags, mu, & DO j = j_start, j_end k=kts DO i = i_start, i_end - - rdzv = 2./(1./rdzw(i,k,j) + 1./rdzw(i,k,j-1)) - tendency(i,k,j)=tendency(i,k,j)-rdzv*(titau3(i,k+1,j)) - + + rdzv = - g / dnw(k) + tendency(i,k,j)=tendency(i,k,j)-rdzv*(titau3(i,k+1,j)) + ENDDO ENDDO ! ******** MODIF... @@ -4069,11 +4085,11 @@ END SUBROUTINE vertical_diffusion_v_2 !======================================================================= !======================================================================= -SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & +SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, & defor33, tke, & - nba_mij, n_nba_mij, & !JDM + nba_mij, n_nba_mij, & div, xkmh, & - dn, rdz, & + dn, rdz, fnm, fnp, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -4089,7 +4105,7 @@ SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte - REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: dn, fnm, fnp REAL , DIMENSION( ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::tendency @@ -4098,21 +4114,20 @@ SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & tke, & div, & xkmh, & - rdz + rdz, & + rho - INTEGER, INTENT( IN ) :: n_nba_mij !JDM + INTEGER, INTENT( IN ) :: n_nba_mij - REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & !JDM + REAL , DIMENSION(ims:ime, kms:kme, jms:jme, n_nba_mij), INTENT(INOUT) & :: nba_mij - REAL , DIMENSION( ims:ime, jms:jme), INTENT(IN ) :: mu - ! LOCAL VARS INTEGER :: i, j, k, ktf INTEGER :: i_start, i_end, j_start, j_end - INTEGER :: is_ext,ie_ext,js_ext,je_ext + INTEGER :: is_ext,ie_ext,js_ext,je_ext REAL , DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1) :: titau3 @@ -4120,7 +4135,7 @@ SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) - + i_start = its i_end = MIN(ite,ide-1) j_start = jts @@ -4143,8 +4158,8 @@ SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & js_ext=0 je_ext=0 CALL cal_titau_11_22_33( config_flags, titau3, & - mu, tke, xkmh, defor33, & ! from RR 20131023 was xkmv - nba_mij(ims,kms,jms,P_m33), & !JDM + tke, xkmh, defor33, & + nba_mij(ims,kms,jms,P_m33), rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4161,7 +4176,7 @@ SUBROUTINE vertical_diffusion_w_2(tendency, config_flags, mu, & DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end - tendency(i,k,j)=tendency(i,k,j)-rdz(i,k,j)*(titau3(i,k,j)-titau3(i,k-1,j)) + tendency(i,k,j)=tendency(i,k,j)+ g*(titau3(i,k,j)-titau3(i,k-1,j))/dn(k) ENDDO ENDDO ENDDO @@ -4171,8 +4186,8 @@ END SUBROUTINE vertical_diffusion_w_2 !======================================================================= !======================================================================= -SUBROUTINE vertical_diffusion_s( tendency, config_flags, var, mu, xkhv, & - dn, dnw, rdz, rdzw, fnm, fnp, & +SUBROUTINE vertical_diffusion_s( tendency, config_flags, var, xkhv, & + dn, dnw, rdz, rdzw, fnm, fnp, rho, & doing_tke, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4200,12 +4215,11 @@ SUBROUTINE vertical_diffusion_s( tendency, config_flags, var, mu, xkhv, & REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(IN) :: xkhv - REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN) :: mu - REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & INTENT(IN ) :: var, & rdz, & - rdzw + rdzw, & + rho ! LOCAL VARS INTEGER :: i, j, k, ktf @@ -4222,7 +4236,7 @@ SUBROUTINE vertical_diffusion_s( tendency, config_flags, var, mu, xkhv, & !----------------------------------------------------------------------- ktf=MIN(kte,kde-1) - + i_start = its i_end = MIN(ite,ide-1) j_start = jts @@ -4257,9 +4271,8 @@ SUBROUTINE vertical_diffusion_s( tendency, config_flags, var, mu, xkhv, & DO k = kts+1,ktf DO i = i_start, i_end xkxavg(i,k,j)=fnm(k)*xkhv(i,k,j)+fnp(k)*xkhv(i,k-1,j) + xkxavg(i,k,j)=xkxavg(i,k,j)*(fnm(k)*rho(i,k,j)+fnp(k)*rho(i,k-1,j)) H3(i,k,j)=-xkxavg(i,k,j)*(var(i,k,j)-var(i,k-1,j))*rdz(i,k,j) -! H3(i,k,j)=-xkxavg(i,k,j)*zeta_z(i,j)* & -! (var(i,k,j)-var(i,k-1,j))/dn(k) ENDDO ENDDO ENDDO @@ -4268,8 +4281,6 @@ SUBROUTINE vertical_diffusion_s( tendency, config_flags, var, mu, xkhv, & DO i = i_start, i_end H3(i,kts,j)=0. H3(i,ktf+1,j)=0. -! H3(i,kts,j)=H3(i,kts+1,j) -! H3(i,ktf+1,j)=H3(i,ktf,j) ENDDO ENDDO @@ -4277,7 +4288,7 @@ SUBROUTINE vertical_diffusion_s( tendency, config_flags, var, mu, xkhv, & DO k = kts,ktf DO i = i_start, i_end tendency(i,k,j)=tendency(i,k,j) & - -mu(i,j)*(H3(i,k+1,j)-H3(i,k,j))*rdzw(i,k,j) + + g * (H3(i,k+1,j)-H3(i,k,j))/dnw(k) ENDDO ENDDO ENDDO @@ -4299,8 +4310,8 @@ END SUBROUTINE vertical_diffusion_s !======================================================================= SUBROUTINE cal_titau_11_22_33( config_flags, titau, & - mu, tke, xkx, defor, & - mtau, & !JDM + tke, xkx, defor, & + mtau, rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4333,19 +4344,16 @@ SUBROUTINE cal_titau_11_22_33( config_flags, titau, & its, ite, jts, jte, kts, kte INTEGER, INTENT( IN ) & - :: is_ext, ie_ext, js_ext, je_ext + :: is_ext, ie_ext, js_ext, je_ext REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & - :: titau + :: titau REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & - :: defor, xkx, tke - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & !JDM - :: mtau + :: defor, xkx, tke, rho - REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & - :: mu + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: mtau ! Local variables. @@ -4374,9 +4382,9 @@ SUBROUTINE cal_titau_11_22_33( config_flags, titau, & IF ( config_flags%periodic_x ) i_end = ite i_start = i_start - is_ext - i_end = i_end + ie_ext + i_end = i_end + ie_ext j_start = j_start - js_ext - j_end = j_end + je_ext + j_end = j_end + je_ext IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES @@ -4384,13 +4392,13 @@ SUBROUTINE cal_titau_11_22_33( config_flags, titau, & DO k = kts, ktf DO i = i_start, i_end - titau(i,k,j) = mu(i,j) * mtau(i,k,j) + titau(i,k,j) = rho(i,k,j) * mtau(i,k,j) END DO END DO - END DO + END DO - ELSE !NOT NBA + ELSE !NOT NBA IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT @@ -4398,28 +4406,28 @@ SUBROUTINE cal_titau_11_22_33( config_flags, titau, & DO k = kts, ktf DO i = i_start, i_end - titau(i,k,j) = - mu(i,j) * xkx(i,k,j) * defor(i,k,j) - mtau(i,k,j) = - xkx(i,k,j) * defor(i,k,j) - + titau(i,k,j) = - rho(i,k,j) * xkx(i,k,j) * defor(i,k,j) + mtau(i,k,j) = - xkx(i,k,j) * defor(i,k,j) + END DO END DO END DO - ELSE !NO STRESS OUTPUT + ELSE !NO STRESS OUTPUT DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end - titau(i,k,j) = - mu(i,j) * xkx(i,k,j) * defor(i,k,j) + titau(i,k,j) = - rho(i,k,j) * xkx(i,k,j) * defor(i,k,j) END DO END DO END DO - ENDIF + ENDIF - ENDIF + ENDIF END SUBROUTINE cal_titau_11_22_33 @@ -4427,8 +4435,8 @@ END SUBROUTINE cal_titau_11_22_33 !======================================================================= SUBROUTINE cal_titau_12_21( config_flags, titau, & - mu, xkx, defor, & - mtau, & !JDM + xkx, defor, & + mtau, rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4461,19 +4469,16 @@ SUBROUTINE cal_titau_12_21( config_flags, titau, & its, ite, jts, jte, kts, kte INTEGER, INTENT( IN ) & - :: is_ext, ie_ext, js_ext, je_ext + :: is_ext, ie_ext, js_ext, je_ext REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & - :: titau - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & - :: defor, xkx + :: titau - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & !JDM - :: mtau + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + :: defor, xkx, rho - REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & - :: mu + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: mtau ! Local variables. @@ -4481,10 +4486,7 @@ SUBROUTINE cal_titau_12_21( config_flags, titau, & :: i, j, k, ktf, i_start, i_end, j_start, j_end REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ) & - :: xkxavg - - REAL, DIMENSION( its-1:ite+1, jts-1:jte+1 ) & - :: muavg + :: xkxavg ! End declarations. !----------------------------------------------------------------------- @@ -4510,50 +4512,44 @@ SUBROUTINE cal_titau_12_21( config_flags, titau, & IF ( config_flags%periodic_x ) i_end = ite i_start = i_start - is_ext - i_end = i_end + ie_ext + i_end = i_end + ie_ext j_start = j_start - js_ext - j_end = j_end + je_ext + j_end = j_end + je_ext DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end xkxavg(i,k,j) = 0.25 * ( xkx(i-1,k,j ) + xkx(i,k,j ) + & xkx(i-1,k,j-1) + xkx(i,k,j-1) ) + xkxavg(i,k,j) = xkxavg(i,k,j) * .25 * ( rho(i-1,k,j ) + rho(i,k,j ) + & + rho(i-1,k,j-1) + rho(i,k,j-1) ) END DO END DO END DO - DO j = j_start, j_end - DO i = i_start, i_end - muavg(i,j) = 0.25 * ( mu(i-1,j ) + mu(i,j ) + & - mu(i-1,j-1) + mu(i,j-1) ) - END DO - END DO - ! titau12 or titau21 IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES - + DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end - titau(i,k,j) = muavg(i,j) * mtau(i,k,j) + titau(i,k,j) = rho(i,k,j) * mtau(i,k,j) END DO END DO END DO ELSE ! NOT NBA - + IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end - - titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) - mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) + titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) + mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) / rho(i,k,j) END DO END DO @@ -4565,7 +4561,7 @@ SUBROUTINE cal_titau_12_21( config_flags, titau, & DO k = kts, ktf DO i = i_start, i_end - titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) END DO END DO @@ -4573,16 +4569,16 @@ SUBROUTINE cal_titau_12_21( config_flags, titau, & ENDIF - ENDIF + ENDIF END SUBROUTINE cal_titau_12_21 !======================================================================= SUBROUTINE cal_titau_13_31( config_flags, titau, & - defor, & - mtau, & !JDM - mu, xkx, fnm, fnp, & + defor, & + mtau, & + xkx, fnm, fnp, rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4615,22 +4611,19 @@ SUBROUTINE cal_titau_13_31( config_flags, titau, & its, ite, jts, jte, kts, kte INTEGER, INTENT( IN ) & - :: is_ext, ie_ext, js_ext, je_ext + :: is_ext, ie_ext, js_ext, je_ext REAL, DIMENSION( kms:kme ), INTENT( IN ) & :: fnm, fnp REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & - :: titau - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme), INTENT( IN ) & - :: defor, xkx + :: titau - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & !JDM - :: mtau + REAL, DIMENSION( ims:ime, kms:kme, jms:jme), INTENT( IN ) & + :: defor, xkx, rho - REAL, DIMENSION( ims:ime, jms:jme), INTENT( IN ) & - :: mu + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: mtau ! Local variables. @@ -4638,10 +4631,7 @@ SUBROUTINE cal_titau_13_31( config_flags, titau, & :: i, j, k, ktf, i_start, i_end, j_start, j_end REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ) & - :: xkxavg - - REAL, DIMENSION( its-1:ite+1, jts-1:jte+1 ) & - :: muavg + :: xkxavg ! End declarations. !----------------------------------------------------------------------- @@ -4667,46 +4657,42 @@ SUBROUTINE cal_titau_13_31( config_flags, titau, & IF ( config_flags%periodic_x ) i_end = ite i_start = i_start - is_ext - i_end = i_end + ie_ext + i_end = i_end + ie_ext j_start = j_start - js_ext - j_end = j_end + je_ext + j_end = j_end + je_ext DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end xkxavg(i,k,j) = 0.5 * ( fnm(k) * ( xkx(i,k ,j) + xkx(i-1,k ,j) ) + & fnp(k) * ( xkx(i,k-1,j) + xkx(i-1,k-1,j) ) ) + xkxavg(i,k,j) = xkxavg(i,k,j) * 0.5 * ( fnm(k) * ( rho(i-1,k ,j) + rho(i,k ,j) ) + & + fnp(k) * ( rho(i-1,k-1,j) + rho(i,k-1,j) ) ) END DO END DO END DO - DO j = j_start, j_end - DO i = i_start, i_end - muavg(i,j) = 0.5 * ( mu(i,j) + mu(i-1,j) ) - END DO - END DO - IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES - + DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end - titau(i,k,j) = muavg(i,j) * mtau(i,k,j) + titau(i,k,j) = rho(i,k,j) * mtau(i,k,j) ENDDO ENDDO ENDDO ELSE ! NOT NBA - + IF ( config_flags%m_opt .EQ. 1 ) THEN ! ASSIGN STRESS TO MTAU FOR OUTPUT DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end - titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) - mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) - + titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) + mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) / rho(i,k,j) + ENDDO ENDDO ENDDO @@ -4717,15 +4703,15 @@ SUBROUTINE cal_titau_13_31( config_flags, titau, & DO k = kts+1, ktf DO i = i_start, i_end - titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) ENDDO ENDDO ENDDO - ENDIF + ENDIF - ENDIF + ENDIF DO j = j_start, j_end DO i = i_start, i_end @@ -4740,8 +4726,8 @@ END SUBROUTINE cal_titau_13_31 !======================================================================= SUBROUTINE cal_titau_23_32( config_flags, titau, defor, & - mtau, & !JDM - mu, xkx, fnm, fnp, & + mtau, & + xkx, fnm, fnp, rho, & is_ext, ie_ext, js_ext, je_ext, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -4774,22 +4760,19 @@ SUBROUTINE cal_titau_23_32( config_flags, titau, defor, & its, ite, jts, jte, kts, kte INTEGER, INTENT( IN ) & - :: is_ext,ie_ext,js_ext,je_ext + :: is_ext,ie_ext,js_ext,je_ext REAL, DIMENSION( kms:kme ), INTENT( IN ) & :: fnm, fnp - REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & - :: titau - + REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ), INTENT( INOUT ) & + :: titau + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & - :: defor, xkx - - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & !JDM - :: mtau + :: defor, xkx, rho - REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & - :: mu + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & + :: mtau ! Local variables. @@ -4797,10 +4780,7 @@ SUBROUTINE cal_titau_23_32( config_flags, titau, defor, & :: i, j, k, ktf, i_start, i_end, j_start, j_end REAL, DIMENSION( its-1:ite+1, kts:kte, jts-1:jte+1 ) & - :: xkxavg - - REAL, DIMENSION( its-1:ite+1, jts-1:jte+1 ) & - :: muavg + :: xkxavg ! End declarations. !----------------------------------------------------------------------- @@ -4826,32 +4806,28 @@ SUBROUTINE cal_titau_23_32( config_flags, titau, defor, & IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) i_start = i_start - is_ext - i_end = i_end + ie_ext + i_end = i_end + ie_ext j_start = j_start - js_ext - j_end = j_end + je_ext + j_end = j_end + je_ext DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end xkxavg(i,k,j) = 0.5 * ( fnm(k) * ( xkx(i,k ,j) + xkx(i,k ,j-1) ) + & fnp(k) * ( xkx(i,k-1,j) + xkx(i,k-1,j-1) ) ) + xkxavg(i,k,j) = xkxavg(i,k,j) * 0.5 * ( fnm(k) * ( rho(i,k ,j) + rho(i,k ,j-1) ) + & + fnp(k) * ( rho(i,k-1,j) + rho(i,k-1,j-1) ) ) END DO END DO END DO - - DO j = j_start, j_end - DO i = i_start, i_end - muavg(i,j) = 0.5 * ( mu(i,j) + mu(i,j-1) ) - END DO - END DO - + IF ( config_flags%sfs_opt .GT. 0 ) THEN ! USE NBA MODEL SFS STRESSES DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end - titau(i,k,j) = muavg(i,j) * mtau(i,k,j) + titau(i,k,j) = rho(i,k,j) * mtau(i,k,j) END DO END DO @@ -4865,8 +4841,8 @@ SUBROUTINE cal_titau_23_32( config_flags, titau, defor, & DO k = kts+1, ktf DO i = i_start, i_end - titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) - mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) + titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) + mtau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) / rho(i,k,j) END DO END DO @@ -4878,15 +4854,15 @@ SUBROUTINE cal_titau_23_32( config_flags, titau, defor, & DO k = kts+1, ktf DO i = i_start, i_end - titau(i,k,j) = - muavg(i,j) * xkxavg(i,k,j) * defor(i,k,j) + titau(i,k,j) = - xkxavg(i,k,j) * defor(i,k,j) END DO END DO END DO - ENDIF + ENDIF - ENDIF + ENDIF DO j = j_start, j_end DO i = i_start, i_end @@ -4901,7 +4877,7 @@ END SUBROUTINE cal_titau_23_32 !======================================================================= SUBROUTINE phy_bc ( config_flags,div,defor11,defor22,defor33, & - defor12,defor13,defor23,xkmh,xkmv,xkhh,xkhv,tke, & + defor12,defor13,defor23,xkmh,xkmv,xkhh,xkhv,tke,rho, & RUBLTEN, RVBLTEN, & RUCUTEN, RVCUTEN, & RUSHTEN, RVSHTEN, & @@ -4939,7 +4915,8 @@ SUBROUTINE phy_bc ( config_flags,div,defor11,defor22,defor33, & xkhh, & xkhv, & tke, & - div + div, & + rho ! End declarations. !----------------------------------------------------------------------- @@ -4992,7 +4969,7 @@ SUBROUTINE phy_bc ( config_flags,div,defor11,defor22,defor33, & ENDIF - ! move out of the conditional, below; horiz coeffs needed for + ! move out of the conditional, below; horiz coeffs needed for ! all diff_opt cases. JM CALL set_physical_bc3d( xkmh , 't', config_flags, & @@ -5063,9 +5040,14 @@ SUBROUTINE phy_bc ( config_flags,div,defor11,defor22,defor33, & ips, ipe, jps, jpe, kps, kpe, & its, ite, jts, jte, kts, kte ) + CALL set_physical_bc3d( rho , 't', config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & + its, ite, jts, jte, kts, kte ) ENDIF -END SUBROUTINE phy_bc +END SUBROUTINE phy_bc !======================================================================= !======================================================================= @@ -5073,7 +5055,7 @@ END SUBROUTINE phy_bc SUBROUTINE tke_rhs( tendency, BN2, config_flags, & defor11, defor22, defor33, & defor12, defor13, defor23, & - u, v, w, div, tke, mu, & + u, v, w, div, tke, mu, c1, c2, & theta, p, p8w, t8w, z, fnm, fnp, & cf1, cf2, cf3, msftx, msfty, & xkmh, xkmv, xkhv, & @@ -5117,6 +5099,8 @@ SUBROUTINE tke_rhs( tendency, BN2, config_flags, & REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: mu + REAL, DIMENSION( kms:kme) , INTENT( IN ) & + :: c1, c2 REAL, DIMENSION ( ims:ime, jms:jme ), INTENT( IN ) & :: hfx, ust, qfx @@ -5134,7 +5118,8 @@ SUBROUTINE tke_rhs( tendency, BN2, config_flags, & CALL tke_shear( tendency, config_flags, & defor11, defor22, defor33, & defor12, defor13, defor23, & - u, v, w, tke, ust, mu, fnm, fnp, & + u, v, w, tke, ust, mu, & + c1, c2, fnm, fnp, & cf1, cf2, cf3, msftx, msfty, & xkmh, xkmv, & rdx, rdy, zx, zy, rdz, rdzw, dnw, dn, & @@ -5142,15 +5127,15 @@ SUBROUTINE tke_rhs( tendency, BN2, config_flags, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CALL tke_buoyancy( tendency, config_flags, mu, & + CALL tke_buoyancy( tendency, config_flags, mu, c1, c2, & tke, xkhv, BN2, theta, dt, & hfx, qfx, qv, rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) + its, ite, jts, jte, kts, kte ) - CALL tke_dissip( tendency, config_flags, & - mu, tke, bn2, theta, p8w, t8w, z, & + CALL tke_dissip( tendency, config_flags, mu, c1, c2, & + tke, bn2, theta, p8w, t8w, z, & dx, dy,rdz, rdzw, isotropic, & msftx, msfty, & ids, ide, jds, jde, kds, kde, & @@ -5175,7 +5160,7 @@ SUBROUTINE tke_rhs( tendency, BN2, config_flags, & config_flags%nested) j_end = MIN(jde-2,jte) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) - + DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end @@ -5190,6 +5175,7 @@ END SUBROUTINE tke_rhs !======================================================================= SUBROUTINE tke_buoyancy( tendency, config_flags, mu, & + c1, c2, & tke, xkhv, BN2, theta, dt, & hfx, qfx, qv, rho, & ids, ide, jds, jde, kds, kde, & @@ -5216,16 +5202,18 @@ SUBROUTINE tke_buoyancy( tendency, config_flags, mu, & :: tendency REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & - :: xkhv, tke, BN2, theta + :: xkhv, tke, BN2, theta REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: mu + REAL, DIMENSION( kms:kme) , INTENT( IN ) & + :: c1, c2 REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT ( IN ) & :: qv, rho REAL, DIMENSION(ims:ime, jms:jme ), INTENT ( IN ) :: hfx, qfx - + ! Local variables. INTEGER & @@ -5261,7 +5249,7 @@ SUBROUTINE tke_buoyancy( tendency, config_flags, mu, & config_flags%nested ) j_end = MIN( jde-2, jte ) IF ( config_flags%periodic_x ) i_start = its IF ( config_flags%periodic_x ) i_end = MIN( ite, ide-1 ) - + DO j = j_start, j_end DO k = kts+1, ktf DO i = i_start, i_end @@ -5283,18 +5271,18 @@ SUBROUTINE tke_buoyancy( tendency, config_flags, mu, & ! LES mods K=KTS DO j = j_start, j_end - DO i = i_start, i_end - heat_flux = heat_flux0 + DO i = i_start, i_end + heat_flux = heat_flux0 tendency(i,k,j)= tendency(i,k,j) - & mu(i,j)*((xkhv(i,k,j)*BN2(i,k,j))- (g/theta(i,k,j))*heat_flux)/2. ENDDO - ENDDO + ENDDO CASE (1) ! use surface heat flux computed from surface routine K=KTS DO j = j_start, j_end - DO i = i_start, i_end + DO i = i_start, i_end cpm = cp * (1. + 0.8*qv(i,k,j)) heat_flux = (hfx(i,j)/cpm)/rho(i,k,j) @@ -5302,7 +5290,7 @@ SUBROUTINE tke_buoyancy( tendency, config_flags, mu, & mu(i,j)*((xkhv(i,k,j)*BN2(i,k,j))- (g/theta(i,k,j))*heat_flux)/2. ENDDO - ENDDO + ENDDO CASE DEFAULT CALL wrf_error_fatal( 'isfflx value invalid for diff_opt=2' ) @@ -5320,7 +5308,8 @@ END SUBROUTINE tke_buoyancy !======================================================================= SUBROUTINE tke_dissip( tendency, config_flags, & - mu, tke, bn2, theta, p8w, t8w, z, & + mu, c1, c2, & + tke, bn2, theta, p8w, t8w, z, & dx, dy, rdz, rdzw, isotropic, & msftx, msfty, & ids, ide, jds, jde, kds, kde, & @@ -5354,15 +5343,17 @@ SUBROUTINE tke_dissip( tendency, config_flags, & INTEGER, INTENT( IN ) :: isotropic REAL, INTENT( IN ) & :: dx, dy - + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: tendency - + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: tke, bn2, theta, p8w, t8w, z, rdz, rdzw REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: mu + REAL, DIMENSION( kms:kme) , INTENT( IN ) & + :: c1, c2 REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: msftx, msfty @@ -5374,7 +5365,7 @@ SUBROUTINE tke_dissip( tendency, config_flags, & REAL, DIMENSION( its:ite, kts:kte, jts:jte ) & :: l_scale - REAL, DIMENSION( its:ite ) & + REAL, DIMENSION( its:ite ) & :: sumtke, sumtkez INTEGER & @@ -5420,7 +5411,7 @@ SUBROUTINE tke_dissip( tendency, config_flags, & deltas = ( dx/msftx(i,j) * dy/msfty(i,j) / rdzw(i,k,j) )**0.33333333 tketmp = MAX( tke(i,k,j), 1.0e-6 ) -! Apply Deardorff's (1980) "wall effect" at the bottom of the domain. +! Apply Deardorff's (1980) "wall effect" at the bottom of the domain. ! For LES with fine grid, no need for this wall effect! IF ( k .eq. kts .or. k .eq. ktf ) then @@ -5443,7 +5434,8 @@ END SUBROUTINE tke_dissip SUBROUTINE tke_shear( tendency, config_flags, & defor11, defor22, defor33, & defor12, defor13, defor23, & - u, v, w, tke, ust, mu, fnm, fnp, & + u, v, w, tke, ust, mu, c1, c2, & + fnm, fnp, & cf1, cf2, cf3, msftx, msfty, & xkmh, xkmv, & rdx, rdy, zx, zy, rdz, rdzw, dn, dnw, & @@ -5460,14 +5452,14 @@ SUBROUTINE tke_shear( tendency, config_flags, & ! kinetic energy by stresses due to sheared wind. ! References: Klemp and Wilhelmson (JAS 1978) -! Deardorff (B-L Meteor 1980) +! Deardorff (B-L Meteor 1980) ! Chen and Dudhia (NCAR WRF physics report 2000) ! Key: ! avg temporary working array -! cf1 -! cf2 +! cf1 +! cf2 ! cf3 ! defor11 deformation term ( du/dx + du/dx ) ! defor12 deformation term ( dv/dx + du/dy ); same as defor21 @@ -5515,12 +5507,14 @@ SUBROUTINE tke_shear( tendency, config_flags, & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( INOUT ) & :: tendency - REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & + REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT( IN ) & :: defor11, defor22, defor33, defor12, defor13, defor23, & tke, xkmh, xkmv, zx, zy, u, v, w, rdz, rdzw REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: mu + REAL, DIMENSION( kms:kme) , INTENT( IN ) & + :: c1, c2 REAL, DIMENSION( ims:ime, jms:jme ), INTENT( IN ) & :: ust @@ -5530,7 +5524,7 @@ SUBROUTINE tke_shear( tendency, config_flags, & INTEGER & :: i, j, k, ktf, ktes1, ktes2, & i_start, i_end, j_start, j_end, & - is_ext, ie_ext, js_ext, je_ext + is_ext, ie_ext, js_ext, je_ext REAL & :: mtau @@ -5549,7 +5543,7 @@ SUBROUTINE tke_shear( tendency, config_flags, & ktf = MIN( kte, kde-1 ) ktes1 = kte-1 ktes2 = kte-2 - + i_start = its i_end = MIN( ite, ide-1 ) j_start = jts @@ -5582,7 +5576,7 @@ SUBROUTINE tke_shear( tendency, config_flags, & ! square of a deformation that is then multiplied by an exchange ! coefficiant. The same exchange coefficient is assumed for horizontal ! and vertical coefficients for some of the terms (the vertical value is -! the one used). +! the one used). ! For defor11. @@ -5597,7 +5591,7 @@ SUBROUTINE tke_shear( tendency, config_flags, & ! For defor22. - DO j = j_start, j_end + DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tendency(i,k,j) = tendency(i,k,j) + 0.5 * & @@ -5608,7 +5602,7 @@ SUBROUTINE tke_shear( tendency, config_flags, & ! For defor33. - DO j = j_start, j_end + DO j = j_start, j_end DO k = kts, ktf DO i = i_start, i_end tendency(i,k,j) = tendency(i,k,j) + 0.5 * & @@ -5678,9 +5672,9 @@ SUBROUTINE tke_shear( tendency, config_flags, & uflux: SELECT CASE( config_flags%isfflx ) CASE (0) ! Assume cd a constant, specified in namelist - cd0 = config_flags%tke_drag_coefficient ! drag coefficient set + cd0 = config_flags%tke_drag_coefficient ! drag coefficient set ! in namelist.input - DO j = j_start, j_end + DO j = j_start, j_end DO i = i_start, i_end absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2) @@ -5752,9 +5746,9 @@ SUBROUTINE tke_shear( tendency, config_flags, & vflux: SELECT CASE( config_flags%isfflx ) CASE (0) ! Assume cd a constant, specified in namelist - cd0 = config_flags%tke_drag_coefficient ! constant drag coefficient + cd0 = config_flags%tke_drag_coefficient ! constant drag coefficient ! set in namelist.input - DO j = j_start, j_end + DO j = j_start, j_end DO i = i_start, i_end absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2) @@ -5768,7 +5762,7 @@ SUBROUTINE tke_shear( tendency, config_flags, & CASE (1,2) ! ustar computed from surface routine - DO j = j_start, j_end + DO j = j_start, j_end DO i = i_start, i_end absU=0.5*sqrt((u(i,k,j)+u(i+1,k,j))**2+(v(i,k,j)+v(i,k,j+1))**2)+epsilon @@ -6026,7 +6020,7 @@ SUBROUTINE compute_diff_metrics( config_flags, ph, phb, z, rdz, rdzw, & END IF END IF - + ! Calculate z at p points. DO j = j_start, j_end diff --git a/wrfv2_fire/dyn_em/module_em.F b/wrfv2_fire/dyn_em/module_em.F index 9383c663..2181212b 100644 --- a/wrfv2_fire/dyn_em/module_em.F +++ b/wrfv2_fire/dyn_em/module_em.F @@ -1,3 +1,29 @@ +#if ( HYBRID_COORD==1 ) +# define mut(...) (c1(k)*XXPCTXX(__VA_ARGS__)+c2(k)) +# define XXPCTXX(...) mut(__VA_ARGS__) + +# define muu(...) (c1(k)*XXPCUXX(__VA_ARGS__)+c2(k)) +# define XXPCUXX(...) muu(__VA_ARGS__) + +# define muv(...) (c1(k)*XXPCVXX(__VA_ARGS__)+c2(k)) +# define XXPCVXX(...) muv(__VA_ARGS__) + +# define MUT(...) (c1f(k)*XXPCTFXX(__VA_ARGS__)+c2f(k)) +# define XXPCTFXX(...) MUT(__VA_ARGS__) + +# define MUU(...) (c1h(k)*XXPCUHXX(__VA_ARGS__)+c2h(k)) +# define XXPCUHXX(...) MUU(__VA_ARGS__) + +# define MUV(...) (c1h(k)*XXPCVHXX(__VA_ARGS__)+c2h(k)) +# define XXPCVHXX(...) MUV(__VA_ARGS__) + +# define muold(...) (c1(k)*XXPCTOLDXX(__VA_ARGS__)+c2(k)) +# define XXPCTOLDXX(...) muold(__VA_ARGS__) + +# define munew(...) (c1(k)*XXPCTNEWXX(__VA_ARGS__)+c2(k)) +# define XXPCTNEWXX(...) munew(__VA_ARGS__) +#endif + !WRF:MODEL_LAYER:DYNAMICS ! @@ -34,7 +60,7 @@ MODULE module_em SUBROUTINE rk_step_prep ( config_flags, rk_step, & u, v, w, t, ph, mu, & - moist, & + c1h, c2h, c1f, c2f, moist, & ru, rv, rw, ww, php, alt, & muu, muv, & mub, mut, phb, pb, p, al, alb, & @@ -109,6 +135,7 @@ SUBROUTINE rk_step_prep ( config_flags, rk_step, & mut REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: fnm, fnp, dnw + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h, c1f, c2f integer :: k @@ -151,12 +178,13 @@ SUBROUTINE rk_step_prep ( config_flags, rk_step, & CALL couple_momentum( muu, ru, u, msfuy, & muv, rv, v, msfvx, msfvx_inv, & mut, rw, w, msfty, & + c1h, c2h, c1f, c2f, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ! new call, couples V with mu, also has correct map factors. WCS, 3 june 2001 - CALL calc_ww_cp ( u, v, mu, mub, ww, & + CALL calc_ww_cp ( u, v, mu, mub, c1h, c2h, ww, & rdx, rdy, msftx, msfty, & msfux, msfuy, msfvx, msfvx_inv, & msfvy, dnw, & @@ -192,7 +220,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & u, v, w, t, ph, & u_old, v_old, w_old, t_old, ph_old, & h_diabatic, phb,t_init, & - mu, mut, muu, muv, mub, & + mu, mut, muu, muv, mub, c1h, c2h, c1f, c2f, & al, alt, p, pb, php, cqu, cqv, cqw, & u_base, v_base, t_base, qv_base, z_base, & msfux, msfuy, msfvx, msfvx_inv, & @@ -303,7 +331,11 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & v_base, & t_base, & qv_base, & - z_base + z_base, & + c1h, & + c2h, & + c1f, & + c2f REAL , INTENT(IN ) :: rdx, & rdy, & @@ -414,6 +446,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & IF( (rk_step == 3) .and. ( adv_opt == WENO_MOM ) ) THEN CALL advect_weno_u ( u, u , ru_tend, ru, rv, ww, & + c1h, c2h, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -425,6 +458,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & ELSE CALL advect_u ( u, u , ru_tend, ru, rv, ww, & + c1h, c2h, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -437,6 +471,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & IF( (rk_step == 3) .and. ( adv_opt == WENO_MOM ) ) THEN CALL advect_weno_v ( v, v , rv_tend, ru, rv, ww, & + c1h, c2h, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -448,6 +483,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & ELSE CALL advect_v ( v, v , rv_tend, ru, rv, ww, & + c1h, c2h, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -461,6 +497,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & IF (non_hydrostatic) THEN IF( (rk_step == 3) .and. ( adv_opt == WENO_MOM ) ) THEN CALL advect_weno_w ( w, w, rw_tend, ru, rv, ww, & + c1h, c2h, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -472,6 +509,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & ELSE CALL advect_w ( w, w, rw_tend, ru, rv, ww, & + c1h, c2h, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, & @@ -483,7 +521,28 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & ENDIF ! theta flux divergence +! 11/2016 ERM: Use WENO for theta flux on 3rd RK step if using WENO_SCALAR or WENOPD_SCALAR +! to be consistent with other scalar fluxes + IF( ( config_flags%scalar_adv_opt == WENO_SCALAR & + .or. config_flags%scalar_adv_opt == WENOPD_SCALAR & + .or. config_flags%moist_adv_opt == WENO_SCALAR & + .or. config_flags%moist_adv_opt == WENOPD_SCALAR & + ) .and. (rk_step == 3) ) THEN +! also use weno for monotonic scalar option so that the h_ and z_tendency arrays are not needed + + CALL advect_scalar_weno ( t, t, t_tend, ru, rv, ww, & + c1h, c2h, mut, time_step, & + config_flags, & + msfux, msfuy, msfvx, msfvy, & + msftx, msfty, fnm, fnp, & + rdx, rdy, rdnw, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ELSE + CALL advect_scalar ( t, t, t_tend, ru, rv, ww, & + c1h, c2h, & mut, time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, fnm, fnp, & @@ -492,6 +551,8 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) + ENDIF + IF ( config_flags%cu_physics == GDSCHEME .OR. & config_flags%cu_physics == GFSCHEME .OR. & config_flags%cu_physics == G3SCHEME .OR. & @@ -508,6 +569,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & CALL rhs_ph( ph_tend, u, v, ww, ph, ph, phb, w, & mut, muu, muv, & + c1f, c2f, & fnm, fnp, & rdnw, cfn, cfn1, rdx, rdy, & msfux, msfuy, msfvx, & @@ -521,7 +583,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & CALL horizontal_pressure_gradient( ru_tend,rv_tend, & ph,alt,p,pb,al,php,cqu,cqv, & - muu,muv,mu,fnm,fnp,rdnw, & + muu,muv,mu,c1h,c2h,fnm,fnp,rdnw,& cf1,cf2,cf3,cfn,cfn1, & rdx,rdy,msfux,msfuy, & msfvx,msfvy,msftx,msfty, & @@ -533,20 +595,21 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & IF (non_hydrostatic) THEN CALL pg_buoy_w( rw_tend, p, cqw, mu, mub, & + c1f,c2f, & rdnw, rdn, g, msftx, msfty, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) ENDIF - CALL w_damp ( rw_tend, max_vert_cfl, & - max_horiz_cfl, & - u, v, ww, w, mut, rdnw, & - rdx, rdy, msfux, msfuy, msfvx, & - msfvy, dt, config_flags, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte ) + CALL w_damp ( rw_tend, max_vert_cfl, & + max_horiz_cfl, & + u, v, ww, w, mut, c1f, c2f, rdnw, & + rdx, rdy, msfux, msfuy, msfvx, & + msfvy, dt, config_flags, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) IF(config_flags%pert_coriolis) THEN @@ -554,7 +617,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & ru_tend, rv_tend, rw_tend, & config_flags, & u_base, v_base, z_base, & - muu, muv, phb, ph, & + muu, muv, c1h, c2h, phb, ph, & msftx, msfty, msfux, msfuy, & msfvx, msfvy, & f, e, sina, cosa, fnm, fnp, & @@ -604,7 +667,8 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & diff_opt1 : IF (config_flags%diff_opt .eq. 1) THEN - CALL horizontal_diffusion ('u', u, ru_tendf, mut, config_flags, & + CALL horizontal_diffusion ('u', u, ru_tendf, mut, & + c1h, c2h, config_flags, & msfux, msfuy, msfvx, msfvx_inv, & msfvy,msftx, msfty, & khdif, xkmhd, rdx, rdy, & @@ -612,7 +676,8 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CALL horizontal_diffusion ('v', v, rv_tendf, mut, config_flags, & + CALL horizontal_diffusion ('v', v, rv_tendf, mut, & + c1h, c2h, config_flags, & msfux, msfuy, msfvx, msfvx_inv, & msfvy,msftx, msfty, & khdif, xkmhd, rdx, rdy, & @@ -620,7 +685,8 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) - CALL horizontal_diffusion ('w', w, rw_tendf, mut, config_flags, & + CALL horizontal_diffusion ('w', w, rw_tendf, mut, & + c1f, c2f, config_flags, & msfux, msfuy, msfvx, msfvx_inv, & msfvy,msftx, msfty, & khdif, xkmhd, rdx, rdy, & @@ -630,6 +696,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & khdq = 3.*khdif CALL horizontal_diffusion_3dmp ( 'm', t, t_tendf, mut, & + c1h, c2h, & config_flags, t_init, & msfux, msfuy, msfvx, msfvx_inv, & msfvy, msftx, msfty, & @@ -641,14 +708,14 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & pbl_test : IF (config_flags%bl_pbl_physics .eq. 0) THEN CALL vertical_diffusion_u ( u, ru_tendf, config_flags, & - u_base, & + u_base, c1h, c2h, & alt, muu, rdn, rdnw, kvdif, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CALL vertical_diffusion_v ( v, rv_tendf, config_flags, & - v_base, & + v_base, c1h, c2h, & alt, muv, rdn, rdnw, kvdif, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -656,6 +723,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & IF (non_hydrostatic) & CALL vertical_diffusion ( 'w', w, rw_tendf, config_flags, & + c1f, c2f, & alt, mut, rdn, rdnw, kvdif, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -663,6 +731,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & kvdq = 3.*kvdif CALL vertical_diffusion_3dmp ( t, t_tendf, config_flags, t_init, & + c1h, c2h, & alt, mut, rdn, rdnw, kvdq , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -677,14 +746,14 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & IF ( diff_6th_opt .NE. 0 ) THEN CALL sixth_order_diffusion( 'u', u, ru_tendf, mut, dt, & - config_flags, & + config_flags, c1h, c2h, & diff_6th_opt, diff_6th_factor, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CALL sixth_order_diffusion( 'v', v, rv_tendf, mut, dt, & - config_flags, & + config_flags, c1h, c2h, & diff_6th_opt, diff_6th_factor, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -692,14 +761,14 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & IF (non_hydrostatic) & CALL sixth_order_diffusion( 'w', w, rw_tendf, mut, dt, & - config_flags, & + config_flags, c1f, c2f, & diff_6th_opt, diff_6th_factor, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) CALL sixth_order_diffusion( 'm', t, t_tendf, mut, dt, & - config_flags, & + config_flags, c1h, c2h, & diff_6th_opt, diff_6th_factor, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -711,6 +780,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & CALL rk_rayleigh_damp( ru_tendf, rv_tendf, & rw_tendf, t_tendf, & u, v, w, t, t_init, & + c1h, c2h, c1f, c2f, & mut, muu, muv, ph, phb, & u_base, v_base, t_base, z_base, & dampcoef, zdamp, & @@ -720,7 +790,7 @@ SUBROUTINE rk_tendency ( config_flags, rk_step, & IF( rad_nudge .eq. 1 ) & CALL theta_relaxation( t_tendf, t, t_init, & - mut, ph, phb, & + mut, c1h, c2h, ph, phb, & t_base, z_base, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -735,7 +805,7 @@ END SUBROUTINE rk_tendency SUBROUTINE rk_addtend_dry ( ru_tend, rv_tend, rw_tend, ph_tend, t_tend, & ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf, & u_save, v_save, w_save, ph_save, t_save, & - mu_tend, mu_tendf, rk_step, & + mu_tend, mu_tendf, rk_step, c1, c2, & h_diabatic, mut, msftx, msfty, msfux, msfuy, & msfvx, msfvx_inv, msfvy, & ids,ide, jds,jde, kds,kde, & @@ -783,6 +853,7 @@ SUBROUTINE rk_addtend_dry ( ru_tend, rv_tend, rw_tend, ph_tend, t_tend, & msfvx_inv, & msfvy + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1, c2 ! Local INTEGER :: i, j, k @@ -860,7 +931,7 @@ SUBROUTINE rk_addtend_dry ( ru_tend, rv_tend, rw_tend, ph_tend, t_tend, & DO j = jts,MIN(jte,jde-1) DO i = its,MIN(ite,ide-1) ! mu tendencies not coupled with 1/msf - mu_tend(i,j) = mu_tend(i,j) + mu_tendf(i,j) + MU_TEND(i,j) = MU_TEND(i,j) + MU_TENDF(i,j) ENDDO ENDDO @@ -872,7 +943,7 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & tenddec, & rk_step, dt, & ru, rv, ww, mut, mub, mu_old, & - alt, & + c1h, c2h, alt, & scalar_old, scalar, & scalar_tends, advect_tend, & h_tendency, z_tendency, & @@ -927,6 +998,8 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & rdnw, & base + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h + REAL , DIMENSION( ims:ime , jms:jme ) , INTENT(IN ) :: msfux, & msfuy, & msfvx, & @@ -994,7 +1067,8 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & advect_tend(ims,kms,jms), & h_tendency(ims,kms,jms), & z_tendency(ims,kms,jms), & - ru, rv, ww, mut, mub, mu_old, & + ru, rv, ww, c1h, c2h, & + mut, mub, mu_old, & time_step, config_flags, tenddec, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, fnm, fnp, & @@ -1010,7 +1084,8 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & advect_tend(ims,kms,jms), & h_tendency(ims,kms,jms), & z_tendency(ims,kms,jms), & - ru, rv, ww, mut, mub, mu_old, & + ru, rv, ww, c1h, c2h, & + mut, mub, mu_old, & config_flags, tenddec, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, fnm, fnp, & @@ -1024,7 +1099,8 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & CALL advect_scalar_weno ( scalar(ims,kms,jms,im), & scalar(ims,kms,jms,im), & advect_tend(ims,kms,jms), & - ru, rv, ww, mut, time_step, & + ru, rv, ww, c1h, c2h, & + mut, time_step, & config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, fnm, fnp, & @@ -1038,7 +1114,8 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & CALL advect_scalar_wenopd ( scalar(ims,kms,jms,im), & scalar_old(ims,kms,jms,im), & advect_tend(ims,kms,jms), & - ru, rv, ww, mut, mub, mu_old, & + ru, rv, ww, c1h, c2h, & + mut, mub, mu_old, & time_step, config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, fnm, fnp, & @@ -1052,7 +1129,8 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & CALL advect_scalar ( scalar(ims,kms,jms,im), & scalar(ims,kms,jms,im), & advect_tend(ims,kms,jms), & - ru, rv, ww, mut, time_step, & + ru, rv, ww, c1h, c2h, & + mut, time_step, & config_flags, & msfux, msfuy, msfvx, msfvy, & msftx, msfty, fnm, fnp, & @@ -1081,7 +1159,7 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & CALL horizontal_diffusion ( 'm', scalar(ims,kms,jms,im), & scalar_tends(ims,kms,jms,im), mut, & - config_flags, & + c1h, c2h, config_flags, & msfux, msfuy, msfvx, msfvx_inv, & msfvy, msftx, msfty, & khdq , xkmhd, rdx, rdy, & @@ -1095,7 +1173,7 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & CALL vertical_diffusion_mp ( scalar(ims,kms,jms,im), & scalar_tends(ims,kms,jms,im), & - config_flags, base, & + config_flags, base, c1h, c2h, & alt, mut, rdn, rdnw, kvdq , & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -1105,7 +1183,7 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & CALL vertical_diffusion ( 'm', scalar(ims,kms,jms,im), & scalar_tends(ims,kms,jms,im), & - config_flags, & + config_flags, c1h, c2h, & alt, mut, rdn, rdnw, kvdq, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -1120,7 +1198,7 @@ SUBROUTINE rk_scalar_tend ( scs, sce, config_flags, & IF ( diff_6th_opt .NE. 0 ) & CALL sixth_order_diffusion( 'm', scalar(ims,kms,jms,im), & scalar_tends(ims,kms,jms,im), & - mut, dt, config_flags, & + mut, dt, config_flags, c1h,c2h,& diff_6th_opt, diff_6th_factor, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -1134,10 +1212,10 @@ END SUBROUTINE rk_scalar_tend !------------------------------------------------------------------------------- -SUBROUTINE q_diabatic_add ( scs, sce, & - dt, mu, & +SUBROUTINE q_diabatic_add ( scs, sce, & + dt, mut, c1, c2, & qv_diabatic, qc_diabatic, & - scalar_tends, & + scalar_tends, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte ) @@ -1152,7 +1230,9 @@ SUBROUTINE q_diabatic_add ( scs, sce, & its, ite, jts, jte, kts, kte REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN ) :: mu + INTENT(IN ) :: mut + + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1, c2 REAL, DIMENSION(ims:ime, kms:kme, jms:jme ), & INTENT(IN ) :: qv_diabatic, qc_diabatic @@ -1182,7 +1262,7 @@ SUBROUTINE q_diabatic_add ( scs, sce, & DO j = jts,MIN(jte,jde-1) DO k = kts,kte-1 DO i = its,MIN(ite,ide-1) - scalar_tends(i,k,j,im) = scalar_tends(i,k,j,im) + qv_diabatic(i,k,j)*mu(I,J) + scalar_tends(i,k,j,im) = scalar_tends(i,k,j,im) + qv_diabatic(i,k,j)*mut(I,J) ENDDO ENDDO ENDDO @@ -1192,7 +1272,7 @@ SUBROUTINE q_diabatic_add ( scs, sce, & DO j = jts,MIN(jte,jde-1) DO k = kts,kte-1 DO i = its,MIN(ite,ide-1) - scalar_tends(i,k,j,im) = scalar_tends(i,k,j,im) + qc_diabatic(i,k,j)*mu(I,J) + scalar_tends(i,k,j,im) = scalar_tends(i,k,j,im) + qc_diabatic(i,k,j)*mut(I,J) ENDDO ENDDO ENDDO @@ -1278,7 +1358,7 @@ SUBROUTINE rk_update_scalar( scs, sce, & advh_t, advz_t, & advect_tend, & h_tendency, z_tendency, & - msftx, msfty, & + msftx, msfty, c1, c2, & mu_old, mu_new, mu_base, & rk_step, dt, spec_zone, & config_flags, & @@ -1321,9 +1401,11 @@ SUBROUTINE rk_update_scalar( scs, sce, & msftx, & msfty + REAL, DIMENSION(kms:kme ), INTENT(IN ) :: c1, c2 + INTEGER :: i,j,k,im REAL :: sc_middle, msfsq - REAL, DIMENSION(its:ite) :: muold, r_munew + REAL, DIMENSION(its:ite) :: muold, munew REAL, DIMENSION(its:ite, kts:kte, jts:jte ) :: tendency @@ -1399,8 +1481,8 @@ SUBROUTINE rk_update_scalar( scs, sce, & DO j = jts, min(jte,jde-1) DO i = its, min(ite,ide-1) - muold(i) = mu_old(i,j) + mu_base(i,j) - r_munew(i) = 1./(mu_new(i,j) + mu_base(i,j)) + MUOLD(i) = MU_OLD(i,j) + MU_BASE(i,j) + MUNEW(i) = MU_NEW(i,j) + MU_BASE(i,j) ENDDO DO k = kts, min(kte,kde-1) @@ -1408,7 +1490,7 @@ SUBROUTINE rk_update_scalar( scs, sce, & scalar_1(i,k,j,im) = scalar_2(i,k,j,im) scalar_2(i,k,j,im) = (muold(i)*scalar_1(i,k,j,im) & - + dt*tendency(i,k,j))*r_munew(i) + + dt*tendency(i,k,j))/munew(i) ENDDO ENDDO @@ -1450,15 +1532,15 @@ SUBROUTINE rk_update_scalar( scs, sce, & DO j = jts, min(jte,jde-1) DO i = its, min(ite,ide-1) - muold(i) = mu_old(i,j) + mu_base(i,j) - r_munew(i) = 1./(mu_new(i,j) + mu_base(i,j)) + MUOLD(i) = MU_OLD(i,j) + MU_BASE(i,j) + MUNEW(i) = MU_NEW(i,j) + MU_BASE(i,j) ENDDO DO k = kts, min(kte,kde-1) DO i = its, min(ite,ide-1) scalar_2(i,k,j,im) = (muold(i)*scalar_1(i,k,j,im) & - + dt*tendency(i,k,j))*r_munew(i) + + dt*tendency(i,k,j))/munew(i) ENDDO ENDDO @@ -1469,8 +1551,8 @@ SUBROUTINE rk_update_scalar( scs, sce, & DO k = kts, min(kte,kde-1) DO i = its, min(ite,ide-1) - advh_t(i,k,j) = advh_t(i,k,j) + (dt*h_tendency(i,k,j)* msfty(i,j))*r_munew(i) - advz_t(i,k,j) = advz_t(i,k,j) + (dt*z_tendency(i,k,j)* msfty(i,j))*r_munew(i) + advh_t(i,k,j) = advh_t(i,k,j) + (dt*h_tendency(i,k,j)* msfty(i,j))/munew(i) + advz_t(i,k,j) = advz_t(i,k,j) + (dt*z_tendency(i,k,j)* msfty(i,j))/munew(i) ENDDO ENDDO @@ -1489,6 +1571,7 @@ END SUBROUTINE rk_update_scalar SUBROUTINE rk_update_scalar_pd( scs, sce, & scalar, sc_tend, & + c1, c2, & mu_old, mu_new, mu_base, & rk_step, dt, spec_zone, & config_flags, & @@ -1517,9 +1600,11 @@ SUBROUTINE rk_update_scalar_pd( scs, sce, & mu_new, & mu_base + REAL, DIMENSION(kms:kme ), INTENT(IN ) :: c1, c2 + INTEGER :: i,j,k,im REAL :: sc_middle, msfsq - REAL, DIMENSION(its:ite) :: muold, r_munew + REAL, DIMENSION(its:ite) :: muold, munew REAL, DIMENSION(its:ite, kts:kte, jts:jte ) :: tendency @@ -1582,15 +1667,15 @@ SUBROUTINE rk_update_scalar_pd( scs, sce, & DO j = jts, min(jte,jde-1) DO i = its, min(ite,ide-1) - muold(i) = mu_old(i,j) + mu_base(i,j) - r_munew(i) = 1./(mu_new(i,j) + mu_base(i,j)) + MUOLD(i) = MU_OLD(i,j) + MU_BASE(i,j) + MUNEW(i) = MU_NEW(i,j) + MU_BASE(i,j) ENDDO DO k = kts, min(kte,kde-1) DO i = its, min(ite,ide-1) scalar(i,k,j,im) = (muold(i)*scalar(i,k,j,im) & - + dt*tendency(i,k,j))*r_munew(i) + + dt*tendency(i,k,j))/munew(i) ENDDO ENDDO ENDDO @@ -1760,7 +1845,8 @@ end subroutine dump_data !----------------------------------------------------------------------- -SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & +SUBROUTINE calculate_phy_tend (config_flags,c1,c2, & + mut,muu,muv,pi3d, & RTHRATEN, & RUBLTEN,RVBLTEN,RTHBLTEN, & RQVBLTEN,RQCBLTEN,RQIBLTEN, & @@ -1789,9 +1875,12 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) , & INTENT(IN ) :: pi3d + + REAL, DIMENSION( kms:kme ) , & + INTENT(IN ) :: c1, c2 REAL, DIMENSION( ims:ime, jms:jme ) , & - INTENT(IN ) :: mu, & + INTENT(IN ) :: mut, & muu, & muv @@ -1876,7 +1965,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO K=kts,ktf DO I=its,itf - RTHRATEN(I,K,J)=mu(I,J)*RTHRATEN(I,K,J) + RTHRATEN(I,K,J)=mut(I,J)*RTHRATEN(I,K,J) ENDDO ENDDO ENDDO @@ -1890,10 +1979,10 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO I=its,itf DO K=kts,ktf - RUCUTEN(I,K,J) =mu(I,J)*RUCUTEN(I,K,J) - RVCUTEN(I,K,J) =mu(I,J)*RVCUTEN(I,K,J) - RTHCUTEN(I,K,J)=mu(I,J)*RTHCUTEN(I,K,J) - RQVCUTEN(I,K,J)=mu(I,J)*RQVCUTEN(I,K,J) + RUCUTEN(I,K,J) =mut(I,J)*RUCUTEN(I,K,J) + RVCUTEN(I,K,J) =mut(I,J)*RVCUTEN(I,K,J) + RTHCUTEN(I,K,J)=mut(I,J)*RTHCUTEN(I,K,J) + RQVCUTEN(I,K,J)=mut(I,J)*RQVCUTEN(I,K,J) ENDDO ENDDO ENDDO @@ -1902,7 +1991,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO I=its,itf DO K=kts,ktf - RQCCUTEN(I,K,J)=mu(I,J)*RQCCUTEN(I,K,J) + RQCCUTEN(I,K,J)=mut(I,J)*RQCCUTEN(I,K,J) ENDDO ENDDO ENDDO @@ -1912,7 +2001,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO I=its,itf DO K=kts,ktf - RQRCUTEN(I,K,J)=mu(I,J)*RQRCUTEN(I,K,J) + RQRCUTEN(I,K,J)=mut(I,J)*RQRCUTEN(I,K,J) ENDDO ENDDO ENDDO @@ -1922,7 +2011,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO I=its,itf DO K=kts,ktf - RQICUTEN(I,K,J)=mu(I,J)*RQICUTEN(I,K,J) + RQICUTEN(I,K,J)=mut(I,J)*RQICUTEN(I,K,J) ENDDO ENDDO ENDDO @@ -1932,7 +2021,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO I=its,itf DO K=kts,ktf - RQSCUTEN(I,K,J)=mu(I,J)*RQSCUTEN(I,K,J) + RQSCUTEN(I,K,J)=mut(I,J)*RQSCUTEN(I,K,J) ENDDO ENDDO ENDDO @@ -1947,10 +2036,10 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO I=its,itf DO K=kts,ktf - RUSHTEN(I,K,J) =mu(I,J)*RUSHTEN(I,K,J) - RVSHTEN(I,K,J) =mu(I,J)*RVSHTEN(I,K,J) - RTHSHTEN(I,K,J)=mu(I,J)*RTHSHTEN(I,K,J) - RQVSHTEN(I,K,J)=mu(I,J)*RQVSHTEN(I,K,J) + RUSHTEN(I,K,J) =mut(I,J)*RUSHTEN(I,K,J) + RVSHTEN(I,K,J) =mut(I,J)*RVSHTEN(I,K,J) + RTHSHTEN(I,K,J)=mut(I,J)*RTHSHTEN(I,K,J) + RQVSHTEN(I,K,J)=mut(I,J)*RQVSHTEN(I,K,J) ENDDO ENDDO ENDDO @@ -1959,7 +2048,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO I=its,itf DO K=kts,ktf - RQCSHTEN(I,K,J)=mu(I,J)*RQCSHTEN(I,K,J) + RQCSHTEN(I,K,J)=mut(I,J)*RQCSHTEN(I,K,J) ENDDO ENDDO ENDDO @@ -1969,7 +2058,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO I=its,itf DO K=kts,ktf - RQRSHTEN(I,K,J)=mu(I,J)*RQRSHTEN(I,K,J) + RQRSHTEN(I,K,J)=mut(I,J)*RQRSHTEN(I,K,J) ENDDO ENDDO ENDDO @@ -1979,7 +2068,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO I=its,itf DO K=kts,ktf - RQISHTEN(I,K,J)=mu(I,J)*RQISHTEN(I,K,J) + RQISHTEN(I,K,J)=mut(I,J)*RQISHTEN(I,K,J) ENDDO ENDDO ENDDO @@ -1989,7 +2078,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO I=its,itf DO K=kts,ktf - RQSSHTEN(I,K,J)=mu(I,J)*RQSSHTEN(I,K,J) + RQSSHTEN(I,K,J)=mut(I,J)*RQSSHTEN(I,K,J) ENDDO ENDDO ENDDO @@ -1999,7 +2088,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO I=its,itf DO K=kts,ktf - RQGSHTEN(I,K,J)=mu(I,J)*RQGSHTEN(I,K,J) + RQGSHTEN(I,K,J)=mut(I,J)*RQGSHTEN(I,K,J) ENDDO ENDDO ENDDO @@ -2014,9 +2103,9 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO K=kts,ktf DO I=its,itf - RUBLTEN(I,K,J) =mu(I,J)*RUBLTEN(I,K,J) - RVBLTEN(I,K,J) =mu(I,J)*RVBLTEN(I,K,J) - RTHBLTEN(I,K,J)=mu(I,J)*RTHBLTEN(I,K,J) + RUBLTEN(I,K,J) =mut(I,J)*RUBLTEN(I,K,J) + RVBLTEN(I,K,J) =mut(I,J)*RVBLTEN(I,K,J) + RTHBLTEN(I,K,J)=mut(I,J)*RTHBLTEN(I,K,J) ENDDO ENDDO ENDDO @@ -2025,7 +2114,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO K=kts,ktf DO I=its,itf - RQVBLTEN(I,K,J)=mu(I,J)*RQVBLTEN(I,K,J) + RQVBLTEN(I,K,J)=mut(I,J)*RQVBLTEN(I,K,J) ENDDO ENDDO ENDDO @@ -2035,7 +2124,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO K=kts,ktf DO I=its,itf - RQCBLTEN(I,K,J)=mu(I,J)*RQCBLTEN(I,K,J) + RQCBLTEN(I,K,J)=mut(I,J)*RQCBLTEN(I,K,J) ENDDO ENDDO ENDDO @@ -2045,7 +2134,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO K=kts,ktf DO I=its,itf - RQIBLTEN(I,K,J)=mu(I,J)*RQIBLTEN(I,K,J) + RQIBLTEN(I,K,J)=mut(I,J)*RQIBLTEN(I,K,J) ENDDO ENDDO ENDDO @@ -2066,7 +2155,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & ! write(*,'(a,3i6,e15.5)') 'u_ten before=',i,k,j, RUNDGDTEN(i,k,j) RUNDGDTEN(I,K,J) =muu(I,J)*RUNDGDTEN(I,K,J) ! if( i == itf/2 .AND. j == jtf/2 .AND. k==ktf/2 ) & -! write(*,'(a,2f15.5)') 'mu, muu=',mu(i,j), muu(i,j) +! write(*,'(a,2f15.5)') 'mu, muu=',mut(I,J), muu(i,j) ! if( i == itf/2 .AND. j == jtf/2 .AND. k == ktf/2 ) & ! write(*,'(a,3i6,e15.5)') 'u_ten after=',i,k,j, RUNDGDTEN(i,k,j) ! if( RUNDGDTEN(i,k,j) > 30.0 ) write(*,*) 'IKJ=',i,k,j @@ -2086,7 +2175,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO I=its,itf ! if( i == itf/2 .AND. j == jtf/2 .AND. k == ktf/2 ) & ! write(*,'(a,3i6,e15.5)') 'th before=',i,k,j, RTHNDGDTEN(I,K,J) - RTHNDGDTEN(I,K,J)=mu(I,J)*RTHNDGDTEN(I,K,J) + RTHNDGDTEN(I,K,J)=mut(I,J)*RTHNDGDTEN(I,K,J) ! RMUNDGDTEN(I,J) - no coupling ! if( i == itf/2 .AND. j == jtf/2 .AND. k == ktf/2 ) & ! write(*,'(a,3i6,e15.5)') 'th after=',i,k,j, RTHNDGDTEN(I,K,J) @@ -2098,7 +2187,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO K=kts,ktf DO I=its,itf - RQVNDGDTEN(I,K,J)=mu(I,J)*RQVNDGDTEN(I,K,J) + RQVNDGDTEN(I,K,J)=mut(I,J)*RQVNDGDTEN(I,K,J) ENDDO ENDDO ENDDO @@ -2112,7 +2201,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO K=kts,ktf DO I=its,itf - scalar_tend(I,K,J,im)=mu(I,J)*scalar_tend(I,K,J,im) + scalar_tend(I,K,J,im)=mut(I,J)*scalar_tend(I,K,J,im) ENDDO ENDDO ENDDO @@ -2122,7 +2211,7 @@ SUBROUTINE calculate_phy_tend (config_flags,mu,muu,muv,pi3d, & DO J=jts,jtf DO K=kts,ktf DO I=its,itf - tracer_tend(I,K,J,im)=mu(I,J)*tracer_tend(I,K,J,im) + tracer_tend(I,K,J,im)=mut(I,J)*tracer_tend(I,K,J,im) ENDDO ENDDO ENDDO @@ -2204,7 +2293,8 @@ END SUBROUTINE bound_tke !Chiaying Lee RSMAS/UM !---------------------------------------------------------------------------------- subroutine trajectory ( grid,config_flags, & - dt,itimestep,ru_m, rv_m, ww_m, mut,muu,muv,& + dt,itimestep,ru_m, rv_m, ww_m, & + mut,muu,muv,c1h,c2h,c1f,c2f, & rdx, rdy, rdn, rdnw,rdzw, & traj_i,traj_j,traj_k, & traj_long,traj_lat, & @@ -2215,6 +2305,12 @@ subroutine trajectory ( grid,config_flags, & its, ite, jts, jte, kts, kte ) !--------------------------------------------------------------------------------------------------- + + use module_date_time + use module_utility + use module_domain, only : domain_clock_get + use module_trajectory, only : traject, traj_cnt + implicit none !--------------------------------------------------------------------------------------------------- ! Subroutine trajectory calculates forward Lagrangian trajectory @@ -2243,6 +2339,8 @@ subroutine trajectory ( grid,config_flags, & REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: rdn, & rdnw + REAL , DIMENSION( kms:kme ) , INTENT(IN ) :: c1h, c2h, c1f, c2f + REAL , DIMENSION( ims:ime , kms:kme, jms:jme ) , & INTENT(IN ) :: ru_m, & rv_m, & @@ -2256,7 +2354,10 @@ subroutine trajectory ( grid,config_flags, & real, dimension(ims:ime,kms:kme,jms:jme)::u,v,w real, dimension(ims:ime,jms:jme),intent(in)::msft,msfu,msfv real, dimension(ims:ime,jms:jme),intent(in)::muu,muv,mut - integer :: i_traj,j_traj,k_traj,tjk,k + integer :: j,k + integer :: i_beg,i_end + integer :: i_traj,j_traj,k_traj,tjk + integer :: dm real :: traj_u,traj_v,traj_w real :: rdx_grid,rdy_grid,rdz_grid real :: deltx, delty, deltz,ax @@ -2270,9 +2371,14 @@ subroutine trajectory ( grid,config_flags, & real :: w_temp_upper,w_temp_lower real :: eta_old, eta_new integer :: keta, keta_temp + character(len=19) :: current_timestr, next_timestr, wrk_timestr + character(len=256) :: dbg_mes + logical :: has_proj_map ! varalbe for map projectory real:: known_lat, known_lon - TYPE (grid_config_rec_type) :: config_flags_temp + TYPE (grid_config_rec_type) :: config_flags_temp + TYPE(WRFU_Time) :: current_time, next_time + TYPE(WRFU_Time) :: start_time, stop_time config_flags_temp = config_flags call trajmapproj(grid, config_flags_temp,proj) @@ -2280,19 +2386,25 @@ subroutine trajectory ( grid,config_flags, & ! convert ru_m, rv_m and ww_m in u,v,w const1=1.0/2.0/sqrt(2.0) -do k=kms,kme - u(:,k,:)=ru_m(:,k,:)/muu(:,:)*msfu(:,:) - v(:,k,:)=rv_m(:,k,:)/muv(:,:)*msfv(:,:) - w(:,k,:)=ww_m(:,k,:)/mut(:,:)*msft(:,:) -enddo -do tjk = 1,config_flags%num_traj - eta_old = 0.0 - eta_new = 0.0 - keta=0 - keta_temp=0 - if (traj_i(tjk) .ne. -9999.0) then - if ( ( proj%code .EQ. PROJ_LC ) .OR. & - ( proj%code .EQ. PROJ_PS ) .OR. & + + dm = grid%id + + write(dbg_mes,'(''trajectory('',i2.2,''): Entering trajectory'')') dm + call wrf_debug(200,trim(dbg_mes) ) + + i_beg = max( 1,its-1 ) + i_end = min( ite+2,ide-1 ) + do j=max(1,jts-1),min(jte+2,jde-1) + do k=kms,kme-1 + u(its:i_end,k,j)=ru_m(its:i_end,k,j)/MUU(its:i_end,j)*msfu(its:i_end,j) + v(its:i_end,k,j)=rv_m(its:i_end,k,j)/MUV(its:i_end,j)*msfv(its:i_end,j) + enddo + do k=kms,kme + w(its:i_end,k,j)=ww_m(its:i_end,k,j)/MUT(its:i_end,j)*msft(its:i_end,j) + enddo + enddo + has_proj_map = & + ( proj%code .EQ. PROJ_LC ) .OR. & ( proj%code .EQ. PROJ_PS_WGS84 ) .OR. & ( proj%code .EQ. PROJ_ALBERS_NAD83 ) .OR. & ( proj%code .EQ. PROJ_MERC ) .OR. & @@ -2300,16 +2412,49 @@ subroutine trajectory ( grid,config_flags, & ( proj%code .EQ. PROJ_CYL ) .OR. & ( proj%code .EQ. PROJ_CASSINI ) .OR. & ( proj%code .EQ. PROJ_GAUSS ) .OR. & - ( proj%code .EQ. PROJ_ROTLL ) ) THEN - call latlon_to_ij (proj, traj_lat(tjk),traj_long(tjk),traj_i(tjk),traj_j(tjk)) + ( proj%code .EQ. PROJ_ROTLL ) + +traj_loop: & +do tjk = 1,traj_cnt(dm) +!do tjk = 1,config_flags%num_traj +traj_is_active: & + if (traj_i(tjk) .ne. -9999.0) then + eta_old = 0.0 + eta_new = 0.0 + keta = 0 + keta_temp = 0 + if( has_proj_map ) then + call latlon_to_ij (proj, & +traj_lat(tjk),traj_long(tjk),traj_i(tjk),traj_j(tjk)) end if - i_traj=floor(traj_i(tjk)) ! find the lower_left_bottom corner for trajectory - j_traj=floor(traj_j(tjk)) ! - k_traj=floor(traj_k(tjk)) ! - if ((i_traj .ge. its .and. i_traj .le. ite .and. i_traj .lt. ide) .and. & - (j_traj .ge. jts .and. j_traj .le. jte .and. j_traj .lt. jde) .and. & - (k_traj .le. kte .and. k_traj .lt. kde)) then + i_traj = floor(traj_i(tjk)) ! find the lower_left_bottom corner for +!trajectory + j_traj = floor(traj_j(tjk)) ! + k_traj = floor(traj_k(tjk)) ! +traj_in_domain: & + if ((i_traj .ge. its .and. i_traj .le. ite .and. i_traj .lt. ide) .and. & + (j_traj .ge. jts .and. j_traj .le. jte .and. j_traj .lt. jde) .and. & + (k_traj .le. kte .and. k_traj .lt. kde)) then +!----------------------------------------------------------------------------- +! is trajectory in time interval? +!----------------------------------------------------------------------------- + call domain_clock_get( grid, current_time=current_time, & +current_timestr=current_timestr) + call geth_newdate( next_timestr, current_timestr, int(grid%dt) ) + call wrf_atotime( next_timestr, next_time ) + wrk_timestr(1:19) = traject(tjk,dm)%start_time(1:19) +! write(*,*) ' ' +! write(*,*) traject(tjk,dm) +! write(dbg_mes,'(''trajectory('',i2,2,''): tjk,start_time = '',i3,1x,a)') & +! dm,tjk,wrk_timestr +! call wrf_debug( 200,trim(dbg_mes) ) + call wrf_atotime( wrk_timestr(1:19), start_time ) + wrk_timestr(1:19) = traject(tjk,dm)%stop_time(1:19) + call wrf_atotime( wrk_timestr(1:19), stop_time ) +is_in_time_interval: & + if( next_time .ge. start_time .and. next_time .le. stop_time & + .and. .not. traject(tjk,dm)%is_stationary ) then ! for u : check x stagger if (traj_i(tjk)-real(floor(traj_i(tjk))) .ge. 0.5 ) then i_u=floor(traj_i(tjk)) + 1 @@ -2450,32 +2595,25 @@ subroutine trajectory ( grid,config_flags, & traj_k(tjk) = traj_k(tjk)-0.5 endif !! convert i,j,k into lon, lat - if ( ( proj%code .EQ. PROJ_LC ) .OR. & - ( proj%code .EQ. PROJ_PS ) .OR. & - ( proj%code .EQ. PROJ_PS_WGS84 ) .OR. & - ( proj%code .EQ. PROJ_ALBERS_NAD83 ) .OR. & - ( proj%code .EQ. PROJ_MERC ) .OR. & - ( proj%code .EQ. PROJ_LATLON ) .OR. & - ( proj%code .EQ. PROJ_CYL ) .OR. & - ( proj%code .EQ. PROJ_CASSINI ) .OR. & - ( proj%code .EQ. PROJ_GAUSS ) .OR. & - ( proj%code .EQ. PROJ_ROTLL ) ) THEN - call ij_to_latlon (proj, traj_i(tjk), traj_j(tjk),traj_lat(tjk),traj_long(tjk)) - end if - else + if( has_proj_map ) then + call ij_to_latlon (proj, traj_i(tjk), & + traj_j(tjk),traj_lat(tjk),traj_long(tjk)) + endif + endif is_in_time_interval + else traj_in_domain traj_i(tjk) = -9999.0 traj_j(tjk) = -9999.0 traj_k(tjk) = -9999.0 traj_long(tjk) = -9999.0 traj_lat(tjk) = -9999.0 - endif - endif - traj_i(tjk) = wrf_dm_max_real(traj_i(tjk))! save the information from highest fomain - traj_j(tjk) = wrf_dm_max_real(traj_j(tjk)) - traj_k(tjk) = wrf_dm_max_real(traj_k(tjk)) - traj_long(tjk) = wrf_dm_max_real(traj_long(tjk)) - traj_lat(tjk) = wrf_dm_max_real(traj_lat(tjk)) -enddo + endif traj_in_domain + endif traj_is_active + traj_i(tjk) = wrf_dm_max_real(traj_i(tjk)) + traj_j(tjk) = wrf_dm_max_real(traj_j(tjk)) + traj_k(tjk) = wrf_dm_max_real(traj_k(tjk)) + traj_long(tjk) = wrf_dm_max_real(traj_long(tjk)) + traj_lat(tjk) = wrf_dm_max_real(traj_lat(tjk)) +enddo traj_loop !end trajectory END SUBROUTINE trajectory diff --git a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F index dd9b7c0f..655422ac 100644 --- a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F +++ b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F @@ -187,28 +187,14 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & CALL wrf_debug ( 200 , ' call phy_prep' ) CALL phy_prep ( config_flags, & - grid%mut, grid%muu, grid%muv, grid%u_2, & - grid%v_2, grid%p, grid%pb, grid%alt, & - grid%ph_2, grid%phb, grid%t_2, grid%tsk, moist, num_moist, & + grid%mut, grid%muu, grid%muv, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & + grid%u_2, grid%v_2, grid%p, grid%pb, grid%alt, & + grid%ph_2, grid%phb, grid%t_2, moist, num_moist, & grid%rho,th_phy, p_phy, pi_phy, grid%u_phy, grid%v_phy, & p8w, t_phy, t8w, grid%z, grid%z_at_w, dz8w, & grid%p_hyd, grid%p_hyd_w, grid%dnw, & grid%fnm, grid%fnp, grid%znw, grid%p_top, & - grid%rthraten, & - grid%rthblten, grid%rublten, grid%rvblten, & - grid%rqvblten, grid%rqcblten, grid%rqiblten, & - grid%rucuten, grid%rvcuten, grid%rthcuten, & - grid%rqvcuten, grid%rqccuten, grid%rqrcuten, & - grid%rqicuten, grid%rqscuten, & - grid%rushten, grid%rvshten, grid%rthshten, & - grid%rqvshten, grid%rqcshten, grid%rqrshten, & - grid%rqishten, grid%rqsshten, grid%rqgshten, & - grid%rthften, grid%rqvften, & - grid%RUNDGDTEN, grid%RVNDGDTEN, grid%RTHNDGDTEN, & - grid%RPHNDGDTEN,grid%RQVNDGDTEN, grid%RMUNDGDTEN,& -!jdf - grid%landmask,grid%xland, & -!jdf ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & grid%i_start(ij), grid%i_end(ij), & @@ -338,7 +324,7 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & , LRADIUS=grid%LRADIUS,IRADIUS=grid%IRADIUS & !BSINGH(01/22/2014) & , CLDFRA_DP=grid%cldfra_dp & ! ckay for subgrid cloud & , CLDFRA_SH=grid%cldfra_sh & - & , icloud_bl=config_flags%icloud_bl & !JOE: subgrid BL clouds + & , icloud_bl=config_flags%icloud_bl & !JOE: subgrid BL clouds & , qc_bl=grid%qc_bl,cldfra_bl=grid%cldfra_bl & !JOE: subgrid bl clouds & , re_cloud=grid%re_cloud, re_ice=grid%re_ice, re_snow=grid%re_snow & ! G. Thompson & , has_reqc=grid%has_reqc, has_reqi=grid%has_reqi, has_reqs=grid%has_reqs & ! G. Thompson @@ -479,8 +465,8 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,QSHLTR=grid%qshltr ,QZ0=grid%qz0 ,RAINCV=grid%raincv & & ,RA_LW_PHYSICS=config_flags%ra_lw_physics ,RHO=grid%rho & & ,RMOL=grid%rmol ,SFCEVP=grid%sfcevp ,SFCEXC=grid%sfcexc & - & ,SFCRUNOFF=grid%sfcrunoff & - & ,opt_thcnd=config_flags%opt_thcnd & + & ,SFCRUNOFF=grid%sfcrunoff,ACRUNOFF=grid%ACRUNOFF & + & ,opt_thcnd=config_flags%opt_thcnd & & ,SF_SFCLAY_PHYSICS=config_flags%sf_sfclay_physics & & ,SF_SURFACE_PHYSICS=config_flags%sf_surface_physics ,SH2O=grid%sh2o & & ,SHDMAX=grid%shdmax ,SHDMIN=grid%shdmin ,SMOIS=grid%smois & @@ -726,7 +712,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & , zsnsoxy=grid%zsnsoxy , snicexy=grid%snicexy , snliqxy=grid%snliqxy & & ,lfmassxy=grid%lfmassxy ,rtmassxy=grid%rtmassxy,stmassxy=grid%stmassxy & & , woodxy=grid%woodxy ,stblcpxy=grid%stblcpxy,fastcpxy=grid%fastcpxy & - & , grainxy=grid%grainxy , gddxy=grid%gddxy & + & , grainxy=grid%grainxy , gddxy=grid%gddxy , pgsxy=grid%pgsxy & + & , cropcat=grid%cropcat & + & ,planting=grid%planting , harvest=grid%harvest ,season_gdd=grid%season_gdd & & , xsaixy=grid%xsaixy , taussxy=grid%taussxy & & , t2mvxy=grid%t2mvxy , t2mbxy=grid%t2mbxy & & , q2mvxy=grid%q2mvxy , q2mbxy=grid%q2mbxy & @@ -831,6 +819,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,ZOL=grid%ZOL & & ,SDA_HFX=grid%SDA_HFX, SDA_QFX=grid%SDA_QFX,HFX_BOTH=grid%HFX_BOTH & !fasdas & ,QFX_BOTH=grid%QFX_BOTH,QNORM=grid%QNORM,fasdas=config_flags%fasdas & !fasdas + & ,spp_lsm=config_flags%spp_lsm,pattern_spp_lsm=grid%pattern_spp_lsm & !SPP + & ,field_sf=grid%field_sf & !SPP + & ,spp_pbl=config_flags%spp_pbl,pattern_spp_pbl=grid%pattern_spp_pbl & !SPP & ) #ifdef WRF_HYDRO @@ -938,21 +929,23 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,bl_mynn_tkebudget=config_flags%bl_mynn_tkebudget & & ,bl_mynn_cloudpdf=config_flags%bl_mynn_cloudpdf & & ,bl_mynn_mixlength=config_flags%bl_mynn_mixlength & - & , icloud_bl=config_flags%icloud_bl & !JOE: subgrid cloud - & , qc_bl=grid%qc_bl,cldfra_bl=grid%cldfra_bl & !JOE: subgrid cloud - & ,bl_mynn_edmf=config_flags%bl_mynn_edmf & !JOE- MYNN edmf - & ,bl_mynn_edmf_mom=config_flags%bl_mynn_edmf_mom & !JOE- MYNN edmf - & ,bl_mynn_edmf_tke=config_flags%bl_mynn_edmf_tke & !JOE- MYNN edmf - & ,bl_mynn_edmf_part=config_flags%bl_mynn_edmf_part & !JOE- MYNN edmf - & ,bl_mynn_cloudmix=config_flags%bl_mynn_cloudmix & !JOE- MYNN cloud mixing - & ,bl_mynn_mixqt=config_flags%bl_mynn_mixqt & !JOE- MYNN tendency method + & ,icloud_bl=config_flags%icloud_bl & + & ,qc_bl=grid%qc_bl,cldfra_bl=grid%cldfra_bl & + & ,bl_mynn_edmf=config_flags%bl_mynn_edmf & + & ,bl_mynn_edmf_mom=config_flags%bl_mynn_edmf_mom & + & ,bl_mynn_edmf_tke=config_flags%bl_mynn_edmf_tke & + & ,bl_mynn_edmf_part=config_flags%bl_mynn_edmf_part & + & ,bl_mynn_cloudmix=config_flags%bl_mynn_cloudmix & + & ,bl_mynn_mixqt=config_flags%bl_mynn_mixqt & & ,edmf_a=grid%edmf_a,edmf_w=grid%edmf_w & & ,edmf_thl=grid%edmf_thl,edmf_qt=grid%edmf_qt & - & ,edmf_ent=grid%edmf_ent,edmf_qc=grid%edmf_qc & !JOE- MYNN edmf + & ,edmf_ent=grid%edmf_ent,edmf_qc=grid%edmf_qc & & ,rmol=grid%rmol, ch=grid%ch & & ,qcg=grid%qcg, grav_settling=config_flags%grav_settling & ! & ,K_m=grid%K_m, K_h=grid%K_h, K_q=grid%K_q & - & ,vdfg=grid%vdfg & ! Katata - fogdep + & ,vdfg=grid%vdfg & + & ,spp_pbl=config_flags%spp_pbl & !SPP + & ,pattern_spp_pbl=grid%pattern_spp_pbl & !SPP !GWD for ARW & ,GWD_OPT=config_flags%gwd_opt & & ,DTAUX3D=grid%dtaux3d,DTAUY3D=grid%dtauy3d & @@ -999,6 +992,23 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & & ,QNORM=grid%QNORM, fasdas=config_flags%fasdas & !fasdas & ) +#if (WRF_CHEM == 1) +#ifdef DM_PARALLEL + IF ( num_chem >= PARAM_FIRST_SCALAR .AND. (config_flags%bl_pbl_physics == & + & mynnpblscheme2 .OR. config_flags%bl_pbl_physics == mynnpblscheme3) ) then + CALL wrf_debug ( 200 , ' call HALO CHEM AFTER PBL' ) + IF ( config_flags%h_sca_adv_order <= 4 ) THEN +# include "HALO_EM_CHEM_E_3.inc" + ELSE IF ( config_flags%h_sca_adv_order <= 6 ) THEN +# include "HALO_EM_CHEM_E_5.inc" + ELSE + WRITE(message,*)'solve_em: invalid h_mom_adv_order = ',& + & config_flags%h_mom_adv_order + ENDIF + ENDIF +#endif +#endif + BENCH_END(pbl_driver_tim) !***** diff --git a/wrfv2_fire/dyn_em/module_first_rk_step_part2.F b/wrfv2_fire/dyn_em/module_first_rk_step_part2.F index 8f012328..8e255a4f 100644 --- a/wrfv2_fire/dyn_em/module_first_rk_step_part2.F +++ b/wrfv2_fire/dyn_em/module_first_rk_step_part2.F @@ -163,6 +163,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & config_flags%restart, grid%iseedarr_skebs, & grid%DX,grid%DY,grid%skebs_vertstruc, & grid%rt_tendf_stoch, & + grid%stddev_cutoff_sppt,grid%gridpt_stddev_sppt, & grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPUV ) ! Update streamfunction, backtransform U CALL RAND_PERT_UPDATE(grid,'U', & @@ -181,6 +182,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & config_flags%restart, grid%iseedarr_skebs, & grid%DX,grid%DY,grid%skebs_vertstruc, & grid%ru_tendf_stoch, & + grid%stddev_cutoff_sppt,grid%gridpt_stddev_sppt, & grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPUV ) ! Don't update streamfunction, backtransform V CALL RAND_PERT_UPDATE(grid,'V', & @@ -199,6 +201,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & config_flags%restart, grid%iseedarr_skebs, & grid%DX,grid%DY,grid%skebs_vertstruc, & grid%rv_tendf_stoch, & + grid%stddev_cutoff_sppt,grid%gridpt_stddev_sppt, & grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT ) ENDIF !skebs_on @@ -219,6 +222,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & config_flags%restart, grid%iseedarr_sppt, & grid%DX,grid%DY,grid%sppt_vertstruc, & grid%rstoch, & + grid%stddev_cutoff_sppt,grid%gridpt_stddev_sppt, & grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT ) ENDIF !sppt_on @@ -239,8 +243,69 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & config_flags%restart, grid%iseedarr_rand_pert, & grid%DX,grid%DY,grid%rand_pert_vertstruc, & grid%RAND_PERT, & + grid%stddev_cutoff_rand_pert,grid%gridpt_stddev_rand_pert, & grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT ) - ENDIF !rand_perturb_on + ENDIF !rand_perturb_on + if ((grid%spp_conv==1).and.(grid%id .EQ. 1 )) then + CALL RAND_PERT_UPDATE(grid,'T', & + grid%SPFORCS2,grid%SPFORCC2, & + grid%SP_AMP2,grid%ALPH_RAND2, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + k_start, k_end, & + imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey, & + grid%num_stoch_levels,grid%num_stoch_levels, & + grid%num_stoch_levels,grid%num_stoch_levels, & + config_flags%restart, grid%iseedarr_spp_conv, & + grid%DX,grid%DY,grid%vertstruc_spp_conv, & + grid%pattern_spp_conv, & + grid%stddev_cutoff_spp_conv,grid%gridpt_stddev_spp_conv, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT ) + ENDIF !spp_conv + if ((grid%spp_pbl==1).and.(grid%id .EQ. 1 )) then + CALL RAND_PERT_UPDATE(grid,'T', & + grid%SPFORCS3,grid%SPFORCC3, & + grid%SP_AMP3,grid%ALPH_RAND3, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + k_start, k_end, & + imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey, & + grid%num_stoch_levels,grid%num_stoch_levels, & + grid%num_stoch_levels,grid%num_stoch_levels, & + config_flags%restart, grid%iseedarr_spp_pbl, & + grid%DX,grid%DY,grid%vertstruc_spp_pbl, & + grid%pattern_spp_pbl, & + grid%stddev_cutoff_spp_pbl,grid%gridpt_stddev_spp_pbl, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT ) + ENDIF !spp_pbl + if ((grid%spp_lsm==1).and.(grid%id .EQ. 1 )) then + CALL RAND_PERT_UPDATE(grid,'T', & + grid%SPFORCS4,grid%SPFORCC4, & + grid%SP_AMP4,grid%ALPH_RAND4, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + k_start, k_end, & + imsx,imex,jmsx,jmex,kmsx,kmex, & + ipsx,ipex,jpsx,jpex,kpsx,kpex, & + imsy,imey,jmsy,jmey,kmsy,kmey, & + ipsy,ipey,jpsy,jpey,kpsy,kpey, & + grid%num_stoch_levels,grid%num_stoch_levels, & + grid%num_stoch_levels,grid%num_stoch_levels, & + config_flags%restart, grid%iseedarr_spp_lsm, & + grid%DX,grid%DY,grid%vertstruc_spp_lsm, & + grid%pattern_spp_lsm, & + grid%stddev_cutoff_spp_lsm,grid%gridpt_stddev_spp_lsm, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT ) + ENDIF !spp_lsm ! calculate_phy_tend @@ -251,7 +316,8 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & DO ij = 1 , grid%num_tiles CALL wrf_debug ( 200 , ' call calculate_phy_tend' ) - CALL calculate_phy_tend (config_flags,grid%mut,grid%muu,grid%muv,pi_phy, & + CALL calculate_phy_tend (config_flags,grid%c1h,grid%c2h, & + grid%mut,grid%muu,grid%muv,pi_phy, & grid%rthraten, & grid%rublten,grid%rvblten,grid%rthblten, & grid%rqvblten,grid%rqcblten,grid%rqiblten, & @@ -328,14 +394,14 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%i_start(ij), grid%i_end(ij), & grid%j_start(ij), grid%j_end(ij), & k_start , k_end ) - CALL set_physical_bc3d( grid%zx , 'w', config_flags, & + CALL set_physical_bc3d( grid%zx , 'e', config_flags, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe, & grid%i_start(ij), grid%i_end(ij), & grid%j_start(ij), grid%j_end(ij), & k_start , k_end ) - CALL set_physical_bc3d( grid%zy , 'w', config_flags, & + CALL set_physical_bc3d( grid%zy , 'f', config_flags, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & ips, ipe, jps, jpe, kps, kpe, & @@ -348,7 +414,13 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & ips, ipe, jps, jpe, & grid%i_start(ij), grid%i_end(ij), & grid%j_start(ij), grid%j_end(ij) ) - + CALL set_physical_bc2d( grid%ust, 't', config_flags, & + ids, ide, jds, jde, & + ims, ime, jms, jme, & + ips, ipe, jps, jpe, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij) ) + ENDDO !$OMP END PARALLEL DO BENCH_END(tke_diff_bc_tim) @@ -439,7 +511,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%cf1, grid%cf2, grid%cf3, grid%warm_rain, & grid%mix_upper_bound, & grid%msftx, grid%msfty, & - grid%zx, grid%zy, & + grid%zx, grid%zy, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & grid%i_start(ij), grid%i_end(ij), & @@ -473,7 +545,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & CALL phy_bc (config_flags,grid%div,grid%defor11,grid%defor22,grid%defor33, & grid%defor12,grid%defor13,grid%defor23, & grid%xkmh,grid%xkmv,grid%xkhh,grid%xkhv, & - grid%tke_2, & + grid%tke_2,grid%rho, & grid%rublten, grid%rvblten, & grid%rucuten, grid%rvcuten, & grid%rushten, grid%rvshten, & @@ -554,7 +626,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & config_flags%cu_physics == TIEDTKESCHEME .or. & config_flags%cu_physics == NTIEDTKESCHEME .or. & config_flags%cu_physics == CAMZMSCHEME .or. & - config_flags%cu_physics == MESO_SAS .or. & + config_flags%cu_physics == SCALESASSCHEME .or. & config_flags%cu_physics == NSASSCHEME ) THEN # include "HALO_EM_PHYS_CU.inc" ENDIF @@ -642,7 +714,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%ru_tendf_stoch, & grid%rv_tendf_stoch, & grid%rt_tendf_stoch, & - grid%mu_2 , grid%mub, & + grid%mu_2, grid%mub, grid%c1h, grid%c2h, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & grid%i_start(ij), grid%i_end(ij), & @@ -676,6 +748,12 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & ! do rayleigh (and zonal-average newtonian) damping during ! first iteration of RK loop only +============================================================= +INTENTIONALLY PLACED HERE TO BREAK COMPILE +The DAMPTOP routine needs to have 1d column arrays c1 and c2 +to correctly use the column pressures mut, muu, and muv. +============================================================= + IF ( (config_flags%damp_opt == 101) .OR. & (config_flags%damp_opt == 103) ) THEN !$OMP PARALLEL DO & @@ -707,7 +785,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%defor33, & grid%defor12,grid%defor13,grid%defor23, & grid%u_2,grid%v_2,grid%w_2,grid%div, & - grid%tke_2,grid%mut, & + grid%tke_2,grid%mut,grid%c1h,grid%c2h, & th_phy,p_phy,p8w,t8w,grid%z,grid%fnm, & grid%fnp,grid%cf1,grid%cf2,grid%cf3, & grid%msftx,grid%msfty,grid%xkmh, & @@ -750,7 +828,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & tracer_tend, num_tracer, & grid%u_2, grid%v_2, & grid%t_2,grid%u_base,grid%v_base,grid%t_base,grid%qv_base, & - grid%mut,grid%tke_2,config_flags, & + grid%tke_2, config_flags, & grid%defor13,grid%defor23,grid%defor33, & nba_mij, num_nba_mij, & !JDM grid%div, moist, chem, scalar,tracer, & @@ -782,7 +860,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & scalar_tend, num_scalar, & tracer_tend, num_tracer, & grid%t_2, th_phy, & - grid%mut, grid%tke_2, config_flags, & + grid%tke_2, config_flags, & grid%defor11, grid%defor22, grid%defor12, & grid%defor13, grid%defor23, & nba_mij, num_nba_mij, & !JDM @@ -792,7 +870,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & grid%msfty, grid%xkmh, grid%xkhh, config_flags%km_opt, & grid%rdx, grid%rdy, grid%rdz, grid%rdzw, & grid%fnm, grid%fnp, grid%cf1, grid%cf2, grid%cf3, & - grid%zx, grid%zy, grid%dn, grid%dnw, & + grid%zx, grid%zy, grid%dn, grid%dnw, grid%rho, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & grid%i_start(ij), grid%i_end(ij), & @@ -847,7 +925,7 @@ SUBROUTINE first_rk_step_part2 ( grid , config_flags & model_config_rec%nobs_err_flds, & grid%fdob%nstat, grid%fdob%varobs, grid%fdob%errf, & grid%dx, grid%KPBL,grid%HT, & - grid%mut, grid%muu, grid%muv, & + grid%mut, grid%muu, grid%muv, grid%c1h, grid%c2h, & grid%msftx, grid%msfty, grid%msfux, grid%msfuy, grid%msfvx, grid%msfvy, & p_phy, t_tendf, t0, & grid%u_2, grid%v_2, grid%t_2, & diff --git a/wrfv2_fire/dyn_em/module_initialize_b_wave.F b/wrfv2_fire/dyn_em/module_initialize_b_wave.F index a4804b41..ee98038d 100644 --- a/wrfv2_fire/dyn_em/module_initialize_b_wave.F +++ b/wrfv2_fire/dyn_em/module_initialize_b_wave.F @@ -239,6 +239,23 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO + + IF ( config_flags%hybrid_opt .NE. 0 ) THEN + call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) + END IF + grid%hybrid_opt = 0 + + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + ENDDO + DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) diff --git a/wrfv2_fire/dyn_em/module_initialize_convrad.F b/wrfv2_fire/dyn_em/module_initialize_convrad.F index 5eb7bf03..a7e690aa 100644 --- a/wrfv2_fire/dyn_em/module_initialize_convrad.F +++ b/wrfv2_fire/dyn_em/module_initialize_convrad.F @@ -301,6 +301,23 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO + + IF ( config_flags%hybrid_opt .NE. 0 ) THEN + call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) + END IF + grid%hybrid_opt = 0 + + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + ENDDO + DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) diff --git a/wrfv2_fire/dyn_em/module_initialize_fire.F b/wrfv2_fire/dyn_em/module_initialize_fire.F index d4387656..7fe293ca 100644 --- a/wrfv2_fire/dyn_em/module_initialize_fire.F +++ b/wrfv2_fire/dyn_em/module_initialize_fire.F @@ -352,6 +352,23 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO + + IF ( config_flags%hybrid_opt .NE. 0 ) THEN + call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) + END IF + grid%hybrid_opt = 0 + + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + ENDDO + DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) diff --git a/wrfv2_fire/dyn_em/module_initialize_grav2d_x.F b/wrfv2_fire/dyn_em/module_initialize_grav2d_x.F index 48e29779..b98f49b9 100644 --- a/wrfv2_fire/dyn_em/module_initialize_grav2d_x.F +++ b/wrfv2_fire/dyn_em/module_initialize_grav2d_x.F @@ -250,6 +250,23 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO + + IF ( config_flags%hybrid_opt .NE. 0 ) THEN + call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) + END IF + grid%hybrid_opt = 0 + + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + ENDDO + DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) diff --git a/wrfv2_fire/dyn_em/module_initialize_heldsuarez.F b/wrfv2_fire/dyn_em/module_initialize_heldsuarez.F index 8ed6a47d..69531006 100644 --- a/wrfv2_fire/dyn_em/module_initialize_heldsuarez.F +++ b/wrfv2_fire/dyn_em/module_initialize_heldsuarez.F @@ -247,6 +247,23 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO + + IF ( config_flags%hybrid_opt .NE. 0 ) THEN + call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) + END IF + grid%hybrid_opt = 0 + + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + ENDDO + DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) diff --git a/wrfv2_fire/dyn_em/module_initialize_hill2d_x.F b/wrfv2_fire/dyn_em/module_initialize_hill2d_x.F index d8fcfb46..87f15cfb 100644 --- a/wrfv2_fire/dyn_em/module_initialize_hill2d_x.F +++ b/wrfv2_fire/dyn_em/module_initialize_hill2d_x.F @@ -1,3 +1,18 @@ +! sed -e "s/grid%mu/gridmu/g" -e "s/grid%Mu/gridMu/g" module_initialize_hill2d_x.F | cpp -DHYBRID_COORD | sed -e "s/gridmu/grid%mu/g" -e "s/gridMu/grid%Mu/g" >> module_initialize_hill2d_x.next +#if ( HYBRID_COORD==1 ) +# define gridmu_1(...) (grid%c1h(k)*XXPC1HXX(__VA_ARGS__)) +# define XXPC1HXX(...) grid%mu_1(__VA_ARGS__) + +# define gridMu_1(...) (grid%c1f(k)*XXPC1FXX(__VA_ARGS__)) +# define XXPC1FXX(...) grid%Mu_1(__VA_ARGS__) + +# define gridmub(...) (grid%c1h(k)*XXPCBHXX(__VA_ARGS__)+grid%c2h(k)) +# define XXPCBHXX(...) grid%mub(__VA_ARGS__) + +# define gridMub(...) (grid%c1f(k)*XXPCBFXX(__VA_ARGS__)+grid%c2f(k)) +# define XXPCBFXX(...) grid%Mub(__VA_ARGS__) +#endif + !IDEAL:MODEL_LAYER:INITIALIZATION ! @@ -84,7 +99,7 @@ SUBROUTINE init_domain_rk ( grid & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte, & - i, j, k + i, j, k, kk ! Local data @@ -111,6 +126,11 @@ SUBROUTINE init_domain_rk ( grid & REAL :: xa1, xal1,pii,hm1 ! data for intercomparison setup from dale + REAL :: B1, B2, B3, B4, B5, sin_arg + + REAL :: Nsq, z, z1, z2 + INTEGER :: iter_loop + SELECT CASE ( model_data_order ) CASE ( DATA_ORDER_ZXY ) kds = grid%sd31 ; kde = grid%ed31 ; @@ -283,6 +303,109 @@ SUBROUTINE init_domain_rk ( grid & grid%p_top = interp_0( p_in, zk, config_flags%ztop, nl_in ) +! Fill in the hybrid coordinate coefficients + + DO k=1, kde + IF ( config_flags%hybrid_opt .EQ. 0 ) THEN + grid%c3f(k) = grid%znw(k) + ELSE IF ( config_flags%hybrid_opt .EQ. 1 ) THEN + grid%c3f(k) = grid%znw(k) + ELSE IF ( config_flags%hybrid_opt .EQ. 2 ) THEN + B1 = 2. * grid%etac**2 * ( 1. - grid%etac ) + B2 = -grid%etac * ( 4. - 3. * grid%etac - grid%etac**3 ) + B3 = 2. * ( 1. - grid%etac**3 ) + B4 = - ( 1. - grid%etac**2 ) + B5 = (1.-grid%etac)**4 + grid%c3f(k) = ( B1 + B2*grid%znw(k) + B3*grid%znw(k)**2 + B4*grid%znw(k)**3 ) / B5 + IF ( grid%znw(k) .LT. grid%etac ) THEN + grid%c3f(k) = 0. + END IF + IF ( k .EQ. kds ) THEN + grid%c3f(k) = 1. + ELSE IF ( k .EQ. kde ) THEN + grid%c3f(k) = 0. + END IF + ELSE IF ( config_flags%hybrid_opt .EQ. 3 ) THEN + IF ( grid%znw(k) .GE. grid%etac ) THEN + sin_arg = (1./(1.-grid%etac))*(grid%znw(k)-1.)+1 + grid%c3f(k) = (sin(sin_arg*3.14159265358/2.))**2 + ELSE + grid%c3f(k) = 0. + END IF + IF ( k .EQ. kds ) THEN + grid%c3f(k) = 1. + ELSE IF ( k .EQ. kds ) THEN + grid%c3f(kde) = 0. + END IF + ELSE + CALL wrf_error_fatal ( 'ERROR: --- hybrid_opt=0 ===> Standard WRF Coordinate; hybrid_opt>=1 ===> Hybrid Vertical Coordinate' ) + END IF + END DO + + DO k=1, kde + grid%c4f(k) = ( grid%znw(k) - grid%c3f(k) ) * ( p1000mb - grid%p_top ) + ENDDO + + ! Now on half levels, just add up and divide by 2 (for c3h). Use (eta-c3)*(p00-pt) for c4 on half levels. + + DO k=1, kde-1 + grid%c3h(k) = ( grid%c3f(k+1) + grid%c3f(k) ) * 0.5 + grid%c4h(k) = ( grid%znu(k) - grid%c3h(k) ) * ( p1000mb - grid%p_top ) + ENDDO + + ! c1 = d(B)/d(eta). We define c1f as c1 on FULL levels. For a vertical difference, + ! we need to use B and eta on half levels. The k-loop ends up referring to the + ! full levels, neglecting the top and bottom. + + DO k=kds+1, kde-1 + grid%c1f(k) = ( grid%c3h(k) - grid%c3h(k-1) ) / ( grid%znu(k) - grid%znu(k-1) ) + ENDDO + + ! The boundary conditions to get the coefficients: + ! 1) At k=kts: define d(B)/d(eta) = 1. This gives us the same value of B and d(B)/d(eta) + ! when doing the sigma-only B=eta. + ! 2) At k=kte: with the new vertical coordinate, define d(B)/d(eta) = 0. The curve B SMOOTHLY + ! goes to zero, and at the very top, B continues to SMOOTHLY go to zero. Note that for + ! almost all cases of non B=eta, B is ALREADY=ZERO at the top, so this is a reasonable BC to + ! assume. + ! 3) At k=kte: when trying to mimic the original vertical coordinate, since B = eta, then + ! d(B)/d(eta) = 1. + + grid%c1f(kds) = 1. + IF ( ( config_flags%hybrid_opt .EQ. 0 ) .OR. ( config_flags%hybrid_opt .EQ. 1 ) ) THEN + grid%c1f(kde) = 1. + ELSE + grid%c1f(kde) = 0. + END IF + + ! c2 = ( 1. - c1(k) ) * (p00 - pt). There is no vertical differencing, so we can do the + ! full kds to kde looping. + + DO k=kds, kde + grid%c2f(k) = ( 1. - grid%c1f(k) ) * ( p1000mb - grid%p_top ) + END DO + + ! Now on half levels for c1 and c2. The c1h will result from the full level c3 and full + ! level eta differences. The c2 value use the half level c1(k). + + DO k=1, kde-1 + grid%c1h(k) = ( grid%c3f(k+1) - grid%c3f(k) ) / ( grid%znw(k+1) - grid%znw(k) ) + grid%c2h(k) = ( 1. - grid%c1h(k) ) * ( p1000mb - grid%p_top ) + END DO + +#if 0 + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + END DO +#endif + DO j=jts,jte DO i=its,ite ! flat surface !! grid%ht(i,j) = 0. @@ -299,13 +422,17 @@ SUBROUTINE init_domain_rk ( grid & DO I = its, ite p_surf = interp_0( p_in, zk, grid%phb(i,1,j)/g, nl_in ) - grid%mub(i,j) = p_surf-grid%p_top + grid%MUB(i,j) = p_surf-grid%p_top ! this is dry hydrostatic sounding (base state), so given grid%p (coordinate), ! interp theta (from interp) and compute 1/rho from eqn. of state DO K = 1, kte-1 +#if !( HYBRID_COORD==1 ) p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top +#elif ( HYBRID_COORD==1 ) + p_level = grid%c3h(k)*(p_surf - grid%p_top) + grid%c4h(k) + grid%p_top +#endif grid%pb(i,k,j) = p_level grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0 grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm @@ -315,15 +442,20 @@ SUBROUTINE init_domain_rk ( grid & ! sounding, but this assures that the base state is in exact hydrostatic balance with ! respect to the model eqns. - DO k = 2,kte - grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j) + DO kk = 2,kte + k=kk - 1 + grid%phb(i,kk,j) = grid%phb(i,kk-1,j) - grid%dnw(kk-1)*grid%mub(i,j)*grid%alb(i,kk-1,j) ENDDO ENDDO ENDDO write(6,*) ' ptop is ',grid%p_top +#if !( HYBRID_COORD==1 ) write(6,*) ' base state grid%mub(1,1), p_surf is ',grid%mub(1,1),grid%mub(1,1)+grid%p_top +#elif ( HYBRID_COORD==1 ) + write(6,*) ' base state grid%MUB(1,1), p_surf is ',grid%MUB(1,1),grid%c3f(kts)*grid%MUB(1,1)+grid%c4f(kts)+grid%p_top +#endif ! calculate full state for each column - this includes moisture. @@ -342,16 +474,20 @@ SUBROUTINE init_domain_rk ( grid & ! compute the perturbation mass and the full mass - grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j) - grid%mu_2(i,j) = grid%mu_1(i,j) - grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j) + grid%MU_1(i,j) = pd_surf-grid%p_top - grid%MUB(i,j) + grid%MU_2(i,j) = grid%MU_1(i,j) + grid%MU0(i,j) = grid%MU_1(i,j) + grid%MUB(i,j) ! given the dry pressure and coordinate system, interp the potential ! temperature and qv do k=1,kde-1 +#if !( HYBRID_COORD==1 ) p_level = grid%znu(k)*(pd_surf - grid%p_top) + grid%p_top +#elif ( HYBRID_COORD==1 ) + p_level = grid%c3h(k)*(pd_surf - grid%p_top) + grid%c4h(k) + grid%p_top +#endif moist(i,k,j,P_QV) = interp_0( qv, pd_in, p_level, nl_in ) grid%t_1(i,k,j) = interp_0( theta, pd_in, p_level, nl_in ) - t0 @@ -364,30 +500,31 @@ SUBROUTINE init_domain_rk ( grid & ! vertical momentum equation) down from the top to get grid%p. ! first from the top of the model to the top pressure - k = kte-1 ! top level + kk = kte-1 ! top level + k=kk+1 - qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk,j,P_QV)) qvf2 = 1./(1.+qvf1) qvf1 = qvf1*qvf2 -! grid%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k) - grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2 - qvf = 1. + rvovrd*moist(i,k,j,P_QV) - grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* & - (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + grid%p(i,kk,j) = - 0.5*(grid%Mu_1(i,j)+qvf1*grid%Mub(i,j))/grid%rdnw(kk)/qvf2 + qvf = 1. + rvovrd*moist(i,kk,j,P_QV) + grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_1(i,kk,j)+t0)*qvf* & + (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) + grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) ! down the column - do k=kte-2,1,-1 - qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + do kk=kte-2,1,-1 + k = kk + 1 + qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk+1,j,P_QV)) qvf2 = 1./(1.+qvf1) qvf1 = qvf1*qvf2 - grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1) - qvf = 1. + rvovrd*moist(i,k,j,P_QV) - grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* & - (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + grid%p(i,kk,j) = grid%p(i,kk+1,j) - (grid%Mu_1(i,j) + qvf1*grid%Mub(i,j))/qvf2/grid%rdn(kk+1) + qvf = 1. + rvovrd*moist(i,kk,j,P_QV) + grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_1(i,kk,j)+t0)*qvf* & + (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) + grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) enddo ! this is the hydrostatic equation used in the model after the @@ -396,24 +533,70 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. - DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & - (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & - grid%mu_1(i,j)*grid%alb(i,k-1,j) ) + DO kk = 2,kte + k = kk-1 + grid%ph_1(i,kk,j) = grid%ph_1(i,kk-1,j) - (grid%dnw(kk-1))*( & + (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,kk-1,j)+ & + grid%mu_1(i,j)*grid%alb(i,kk-1,j) ) - grid%ph_2(i,k,j) = grid%ph_1(i,k,j) - grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j) + grid%ph_2(i,kk,j) = grid%ph_1(i,kk,j) + grid%ph0(i,kk,j) = grid%ph_1(i,kk,j) + grid%phb(i,kk,j) ENDDO if((i==2) .and. (j==2)) then - write(6,*) ' grid%ph_1 calc ',grid%ph_1(2,1,2),grid%ph_1(2,2,2),& + k=1 + write(6,*) ' grid%ph_1 k=1 calc ',grid%ph_1(2,k,2),& grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), & - grid%alb(2,1,2),grid%al(1,2,1),grid%rdnw(1) + grid%alb(2,k,2),grid%rdnw(k) + k=2 + write(6,*) ' grid%ph_1 k=2 calc ',grid%ph_1(2,k,2),& + grid%mu_1(2,2)+grid%mub(2,2),grid%mu_1(2,2), & + grid%alb(2,k,2) endif ENDDO ENDDO +#if 0 +!=============== + +! Test for resting atmosphere + + DO iter_loop = 1, 100 + DO J = jts, min(jde-1,jte) + DO I = its, min(ide-1,ite) + DO K = 2, kte-1 + z1 = (grid%phb(i,k+1,j)+grid%ph_1(i,k+1,j))/g + z2 = (grid%phb(i,k ,j)+grid%ph_1(i,k ,j))/g + z=(z1+z2)/2. + IF ( z .LT. 10000 ) THEN + Nsq = 1.E-4 + ELSE + Nsq = 4.E-4 + END IF + grid%t_1(i,k,j)=(grid%t_1(i,k-1,j)+t0) * EXP(Nsq / g * (z1-z2)) - t0 + grid%t_2(i,k,j)=grid%t_1(i,k,j) + qvf = 1. + rvovrd*moist(i,k,j,P_QV) + grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* & + (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) + grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + ENDDO + + DO kk = 2,kte + k = kk - 1 + grid%ph_1(i,kk,j) = grid%ph_1(i,kk-1,j) - (grid%dnw(kk-1))*( & + (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,kk-1,j)+ & + grid%mu_1(i,j)*grid%alb(i,kk-1,j) ) + + grid%ph_2(i,kk,j) = grid%ph_1(i,kk,j) + grid%ph0(i,kk,j) = grid%ph_1(i,kk,j) + grid%phb(i,kk,j) + ENDDO + ENDDO + ENDDO + END DO +!=============== +#endif + k=1 write(6,*) ' grid%mu_1 from comp ', grid%mu_1(1,1) write(6,*) ' full state sounding from comp, ph, grid%p, grid%al, grid%t_1, qv ' do k=1,kde-1 @@ -469,7 +652,11 @@ SUBROUTINE init_domain_rk ( grid & p_surf = interp_0( p_in, zk, z_at_u, nl_in ) DO K = 1, kte +#if !( HYBRID_COORD==1 ) p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top +#elif ( HYBRID_COORD==1 ) + p_level = grid%c3h(k)*(p_surf - grid%p_top) + grid%c4h(k) + grid%p_top +#endif grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in ) grid%u_2(i,k,j) = grid%u_1(i,k,j) ENDDO diff --git a/wrfv2_fire/dyn_em/module_initialize_les.F b/wrfv2_fire/dyn_em/module_initialize_les.F index 217d7da9..7677bfa3 100644 --- a/wrfv2_fire/dyn_em/module_initialize_les.F +++ b/wrfv2_fire/dyn_em/module_initialize_les.F @@ -1,3 +1,17 @@ +! sed -e "s/grid%mu/gridmu/g" -e "s/grid%Mu/gridMu/g" module_initialize_hill2d_x.F | cpp -DHYBRID_COORD | sed -e "s/gridmu/grid%mu/g" -e "s/gridMu/grid%Mu/g" >> module_initialize_hill2d_x.next +#if ( HYBRID_COORD==1 ) +# define gridmu_1(...) (grid%c1h(k)*XXPC1HXX(__VA_ARGS__)) +# define XXPC1HXX(...) grid%mu_1(__VA_ARGS__) + +# define gridMu_1(...) (grid%c1f(k)*XXPC1FXX(__VA_ARGS__)) +# define XXPC1FXX(...) grid%Mu_1(__VA_ARGS__) + +# define gridmub(...) (grid%c1h(k)*XXPCBHXX(__VA_ARGS__)+grid%c2h(k)) +# define XXPCBHXX(...) grid%mub(__VA_ARGS__) + +# define gridMub(...) (grid%c1f(k)*XXPCBFXX(__VA_ARGS__)+grid%c2f(k)) +# define XXPCBFXX(...) grid%Mub(__VA_ARGS__) +#endif !IDEAL:MODEL_LAYER:INITIALIZATION ! @@ -80,7 +94,7 @@ SUBROUTINE init_domain_rk ( grid & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte, & - i, j, k + i, j, k, kk ! Local data @@ -116,6 +130,9 @@ SUBROUTINE init_domain_rk ( grid & INTEGER :: ks, ke, id LOGICAL :: vnest !DJW T if using vertical nesting, otherwise F +! for the hybrid coordinate + REAL :: B1, B2, B3, B4, B5, sin_arg + #ifdef DM_PARALLEL # include "data_calls.inc" #endif @@ -354,6 +371,108 @@ SUBROUTINE init_domain_rk ( grid & grid%p_top = interp_0( p_in, zk, config_flags%ztop, nl_in ) +! Fill in the hybrid coordinate coefficients + + DO k=1, kde + IF ( config_flags%hybrid_opt .EQ. 0 ) THEN + grid%c3f(k) = grid%znw(k) + ELSE IF ( config_flags%hybrid_opt .EQ. 1 ) THEN + grid%c3f(k) = grid%znw(k) + ELSE IF ( config_flags%hybrid_opt .EQ. 2 ) THEN + B1 = 2. * grid%etac**2 * ( 1. - grid%etac ) + B2 = -grid%etac * ( 4. - 3. * grid%etac - grid%etac**3 ) + B3 = 2. * ( 1. - grid%etac**3 ) + B4 = - ( 1. - grid%etac**2 ) + B5 = (1.-grid%etac)**4 + grid%c3f(k) = ( B1 + B2*grid%znw(k) + B3*grid%znw(k)**2 + B4*grid%znw(k)**3 ) / B5 + IF ( grid%znw(k) .LT. grid%etac ) THEN + grid%c3f(k) = 0. + END IF + IF ( k .EQ. kds ) THEN + grid%c3f(k) = 1. + ELSE IF ( k .EQ. kde ) THEN + grid%c3f(k) = 0. + END IF + ELSE IF ( config_flags%hybrid_opt .EQ. 3 ) THEN + IF ( grid%znw(k) .GE. grid%etac ) THEN + sin_arg = (1./(1.-grid%etac))*(grid%znw(k)-1.)+1 + grid%c3f(k) = (sin(sin_arg*3.14159265358/2.))**2 + ELSE + grid%c3f(k) = 0. + END IF + IF ( k .EQ. kds ) THEN + grid%c3f(k) = 1. + ELSE IF ( k .EQ. kds ) THEN + grid%c3f(kde) = 0. + END IF + ELSE + CALL wrf_error_fatal ( 'ERROR: --- hybrid_opt=0 ===> Standard WRF Coordinate; hybrid_opt>=1 ===> Hybrid Vertical Coordinate' ) + END IF + END DO + + DO k=1, kde + grid%c4f(k) = ( grid%znw(k) - grid%c3f(k) ) * ( p1000mb - grid%p_top ) + ENDDO + + ! Now on half levels, just add up and divide by 2 (for c3h). Use (eta-c3)*(p00-pt) for c4 on half levels. + + DO k=1, kde-1 + grid%c3h(k) = ( grid%c3f(k+1) + grid%c3f(k) ) * 0.5 + grid%c4h(k) = ( grid%znu(k) - grid%c3h(k) ) * ( p1000mb - grid%p_top ) + ENDDO + + ! c1 = d(B)/d(eta). We define c1f as c1 on FULL levels. For a vertical difference, + ! we need to use B and eta on half levels. The k-loop ends up referring to the + ! full levels, neglecting the top and bottom. + + DO k=kds+1, kde-1 + grid%c1f(k) = ( grid%c3h(k) - grid%c3h(k-1) ) / ( grid%znu(k) - grid%znu(k-1) ) + ENDDO + + ! The boundary conditions to get the coefficients: + ! 1) At k=kts: define d(B)/d(eta) = 1. This gives us the same value of B and d(B)/d(eta) + ! when doing the sigma-only B=eta. + ! 2) At k=kte: with the new vertical coordinate, define d(B)/d(eta) = 0. The curve B SMOOTHLY + ! goes to zero, and at the very top, B continues to SMOOTHLY go to zero. Note that for + ! almost all cases of non B=eta, B is ALREADY=ZERO at the top, so this is a reasonable BC to + ! assume. + ! 3) At k=kte: when trying to mimic the original vertical coordinate, since B = eta, then + ! d(B)/d(eta) = 1. + + grid%c1f(kds) = 1. + IF ( ( config_flags%hybrid_opt .EQ. 0 ) .OR. ( config_flags%hybrid_opt .EQ. 1 ) ) THEN + grid%c1f(kde) = 1. + ELSE + grid%c1f(kde) = 0. + END IF + + ! c2 = ( 1. - c1(k) ) * (p00 - pt). There is no vertical differencing, so we can do the + ! full kds to kde looping. + + DO k=kds, kde + grid%c2f(k) = ( 1. - grid%c1f(k) ) * ( p1000mb - grid%p_top ) + END DO + + ! Now on half levels for c1 and c2. The c1h will result from the full level c3 and full + ! level eta differences. The c2 value use the half level c1(k). + + DO k=1, kde-1 + grid%c1h(k) = ( grid%c3f(k+1) - grid%c3f(k) ) / ( grid%znw(k+1) - grid%znw(k) ) + grid%c2h(k) = ( 1. - grid%c1h(k) ) * ( p1000mb - grid%p_top ) + END DO + +#if 0 + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + END DO +#endif DO j=jts,jte DO i=its,ite grid%ht(i,j) = 0. @@ -402,13 +521,17 @@ SUBROUTINE init_domain_rk ( grid & DO I = its, ite p_surf = interp_0( p_in, zk, grid%phb(i,1,j)/g, nl_in ) - grid%mub(i,j) = p_surf-grid%p_top + grid%MUB(i,j) = p_surf-grid%p_top ! this is dry hydrostatic sounding (base state), so given grid%p (coordinate), ! interp theta (from interp) and compute 1/rho from eqn. of state DO K = 1, kte-1 +#if !( HYBRID_COORD==1 ) p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top +#elif ( HYBRID_COORD==1 ) + p_level = grid%c3h(k)*(p_surf - grid%p_top) + grid%c4h(k) + grid%p_top +#endif grid%pb(i,k,j) = p_level grid%t_init(i,k,j) = interp_0( theta, p_in, p_level, nl_in ) - t0 grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm @@ -418,8 +541,9 @@ SUBROUTINE init_domain_rk ( grid & ! sounding, but this assures that the base state is in exact hydrostatic balance with ! respect to the model eqns. - DO k = 2,kte - grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j) + DO kk = 2,kte + k=kk - 1 + grid%phb(i,kk,j) = grid%phb(i,kk-1,j) - grid%dnw(kk-1)*grid%mub(i,j)*grid%alb(i,kk-1,j) ENDDO ENDDO @@ -427,7 +551,11 @@ SUBROUTINE init_domain_rk ( grid & IF ( wrf_dm_on_monitor() ) THEN write(6,*) ' ptop is ',grid%p_top +#if !( HYBRID_COORD==1 ) write(6,*) ' base state grid%mub(1,1), p_surf is ',grid%mub(1,1),grid%mub(1,1)+grid%p_top +#elif ( HYBRID_COORD==1 ) + write(6,*) ' base state grid%MUB(1,1), p_surf is ',grid%MUB(1,1),grid%c3f(kts)*grid%MUB(1,1)+grid%c4f(kts)+grid%p_top +#endif ENDIF ! calculate full state for each column - this includes moisture. @@ -446,16 +574,20 @@ SUBROUTINE init_domain_rk ( grid & ! compute the perturbation mass and the full mass - grid%mu_1(i,j) = pd_surf-grid%p_top - grid%mub(i,j) - grid%mu_2(i,j) = grid%mu_1(i,j) - grid%mu0(i,j) = grid%mu_1(i,j) + grid%mub(i,j) + grid%MU_1(i,j) = pd_surf-grid%p_top - grid%MUB(i,j) + grid%MU_2(i,j) = grid%MU_1(i,j) + grid%MU0(i,j) = grid%MU_1(i,j) + grid%MUB(i,j) ! given the dry pressure and coordinate system, interp the potential ! temperature and qv do k=1,kde-1 +#if !( HYBRID_COORD==1 ) p_level = grid%znu(k)*(pd_surf - grid%p_top) + grid%p_top +#elif ( HYBRID_COORD==1 ) + p_level = grid%c3h(k)*(pd_surf - grid%p_top) + grid%c4h(k) + grid%p_top +#endif moist(i,k,j,P_QV) = interp_0( qv, pd_in, p_level, nl_in ) grid%t_1(i,k,j) = interp_0( theta, pd_in, p_level, nl_in ) - t0 @@ -468,30 +600,31 @@ SUBROUTINE init_domain_rk ( grid & ! vertical momentum equation) down from the top to get grid%p. ! first from the top of the model to the top pressure - k = kte-1 ! top level + kk = kte-1 ! top level + k=kk+1 - qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk,j,P_QV)) qvf2 = 1./(1.+qvf1) qvf1 = qvf1*qvf2 -! grid%p(i,k,j) = - 0.5*grid%mu_1(i,j)/grid%rdnw(k) - grid%p(i,k,j) = - 0.5*(grid%mu_1(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2 - qvf = 1. + rvovrd*moist(i,k,j,P_QV) - grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* & - (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + grid%p(i,kk,j) = - 0.5*(grid%Mu_1(i,j)+qvf1*grid%Mub(i,j))/grid%rdnw(kk)/qvf2 + qvf = 1. + rvovrd*moist(i,kk,j,P_QV) + grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_1(i,kk,j)+t0)*qvf* & + (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) + grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) ! down the column - do k=kte-2,1,-1 - qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + do kk=kte-2,1,-1 + k = kk + 1 + qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk+1,j,P_QV)) qvf2 = 1./(1.+qvf1) qvf1 = qvf1*qvf2 - grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_1(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1) - qvf = 1. + rvovrd*moist(i,k,j,P_QV) - grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_1(i,k,j)+t0)*qvf* & - (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) + grid%p(i,kk,j) = grid%p(i,kk+1,j) - (grid%Mu_1(i,j) + qvf1*grid%Mub(i,j))/qvf2/grid%rdn(kk+1) + qvf = 1. + rvovrd*moist(i,kk,j,P_QV) + grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_1(i,kk,j)+t0)*qvf* & + (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) + grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) enddo ! this is the hydrostatic equation used in the model after the @@ -502,8 +635,8 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - & - grid%dnw(k-1)*((grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & - grid%mu_1(i,j)*grid%alb(i,k-1,j) ) + grid%dnw(k-1)*((grid%Mub(i,j)+grid%Mu_1(i,j))*grid%al(i,k-1,j)+ & + grid%Mu_1(i,j)*grid%alb(i,k-1,j) ) grid%ph_2(i,k,j) = grid%ph_1(i,k,j) grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j) @@ -565,13 +698,14 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically - DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & - (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & - grid%mu_1(i,j)*grid%alb(i,k-1,j) ) + DO kk = 2,kte + k = kk - 1 + grid%ph_1(i,kk,j) = grid%ph_1(i,kk-1,j) - (grid%dnw(kk-1))*( & + (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,kk-1,j)+ & + grid%mu_1(i,j)*grid%alb(i,kk-1,j) ) - grid%ph_2(i,k,j) = grid%ph_1(i,k,j) - grid%ph0(i,k,j) = grid%ph_1(i,k,j) + grid%phb(i,k,j) + grid%ph_2(i,kk,j) = grid%ph_1(i,kk,j) + grid%ph0(i,kk,j) = grid%ph_1(i,kk,j) + grid%phb(i,kk,j) ENDDO ENDDO @@ -611,7 +745,11 @@ SUBROUTINE init_domain_rk ( grid & p_surf = interp_0( p_in, zk, z_at_v, nl_in ) DO K = 1, kte-1 +#if !( HYBRID_COORD==1 ) p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top +#elif ( HYBRID_COORD==1 ) + p_level = grid%c3h(k)*(p_surf - grid%p_top) + grid%c4h(k) + grid%p_top +#endif grid%v_1(i,k,j) = interp_0( v, p_in, p_level, nl_in ) grid%v_2(i,k,j) = grid%v_1(i,k,j) ENDDO @@ -635,7 +773,11 @@ SUBROUTINE init_domain_rk ( grid & p_surf = interp_0( p_in, zk, z_at_u, nl_in ) DO K = 1, kte-1 +#if !( HYBRID_COORD==1 ) p_level = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top +#elif ( HYBRID_COORD==1 ) + p_level = grid%c3h(k)*(p_surf - grid%p_top) + grid%c4h(k) + grid%p_top +#endif grid%u_1(i,k,j) = interp_0( u, p_in, p_level, nl_in ) grid%u_2(i,k,j) = grid%u_1(i,k,j) ENDDO diff --git a/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F b/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F index d8c2913c..cf61f7a3 100644 --- a/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F +++ b/wrfv2_fire/dyn_em/module_initialize_quarter_ss.F @@ -235,6 +235,23 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO + + IF ( config_flags%hybrid_opt .NE. 0 ) THEN + call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) + END IF + grid%hybrid_opt = 0 + + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + ENDDO + DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) diff --git a/wrfv2_fire/dyn_em/module_initialize_real.F b/wrfv2_fire/dyn_em/module_initialize_real.F index 18813521..2ea505f0 100644 --- a/wrfv2_fire/dyn_em/module_initialize_real.F +++ b/wrfv2_fire/dyn_em/module_initialize_real.F @@ -1,3 +1,21 @@ +! sed -e "s/grid%mu/gridmu/g" -e "s/grid%Mu/gridMu/g" module_initialize_real.F | cpp -DHYBRID_COORD | sed -e "s/gridmu/grid%mu/g" -e "s/gridMu/grid%Mu/g" >> module_initialize_real.next +#if ( HYBRID_COORD==1 ) +# define gridmu0(...) (grid%c1h(k)*XXPC0HXX(__VA_ARGS__)+grid%c2h(k)) +# define XXPC0HXX(...) grid%mu0(__VA_ARGS__) + +# define gridmu_2(...) (grid%c1h(k)*XXPC2HXX(__VA_ARGS__)) +# define XXPC2HXX(...) grid%mu_2(__VA_ARGS__) + +# define gridmub(...) (grid%c1h(k)*XXPCBHXX(__VA_ARGS__)+grid%c2h(k)) +# define XXPCBHXX(...) grid%mub(__VA_ARGS__) + +# define gridMu_2(...) (grid%c1f(k)*XXPC2FXX(__VA_ARGS__)) +# define XXPC2FXX(...) grid%Mu_2(__VA_ARGS__) + +# define gridMub(...) (grid%c1f(k)*XXPCBFXX(__VA_ARGS__)+grid%c2f(k)) +# define XXPCBFXX(...) grid%Mub(__VA_ARGS__) +#endif + !REAL:MODEL_LAYER:INITIALIZATION #ifndef VERT_UNIT @@ -89,7 +107,7 @@ SUBROUTINE init_domain_rk ( grid & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte, & ips, ipe, jps, jpe, kps, kpe, & - i, j, k + i, j, k, kk INTEGER :: imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, kpex, & @@ -102,6 +120,7 @@ SUBROUTINE init_domain_rk ( grid & INTEGER :: error INTEGER :: im, num_3d_m, num_3d_s + REAL :: B1, B2, B3, B4, B5 REAL :: p_surf, p_level REAL :: cof1, cof2 REAL :: qvf , qvf1 , qvf2 , qtot, pd_surf @@ -163,6 +182,8 @@ SUBROUTINE init_domain_rk ( grid & INTEGER :: j_save + LOGICAL :: wif_upside_down + ! Dimension information stored in grid data structure. CALL cpu_time(t_start) @@ -245,7 +266,7 @@ SUBROUTINE init_domain_rk ( grid & ! Send out a quick message about the time steps based on the map scale factors. IF ( ( internal_time_loop .EQ. 1 ) .AND. ( grid%id .EQ. 1 ) .AND. & - ( .NOT. config_flags%map_proj .EQ. PROJ_CASSINI ) ) THEN + ( .NOT. config_flags%polar ) ) THEN max_mf = grid%msft(its,jts) DO j=jts,MIN(jde-1,jte) DO i=its,MIN(ide-1,ite) @@ -308,7 +329,7 @@ SUBROUTINE init_domain_rk ( grid & ( config_flags%grid_fdda .NE. 0 ) .OR. & ( config_flags%sst_update .EQ. 1 ) .OR. & ( config_flags%all_ic_times ) .OR. & - ( config_flags%map_proj .EQ. PROJ_CASSINI ) + ( config_flags%polar ) ! There are a few checks that we need to do when the input data comes in with the middle ! excluded by WPS. @@ -331,7 +352,7 @@ SUBROUTINE init_domain_rk ( grid & CALL wrf_message ( a_message ) WRITE ( a_message,* ) ' ( config_flags%smooth_cg_topo ) ', ( config_flags%smooth_cg_topo ) CALL wrf_message ( a_message ) - WRITE ( a_message,* ) ' ( config_flags%map_proj .EQ. PROJ_CASSINI ) ', ( config_flags%map_proj .EQ. PROJ_CASSINI ) + WRITE ( a_message,* ) ' ( config_flags%polar ) ', ( config_flags%polar ) CALL wrf_message ( a_message ) WRITE ( a_message,* ) 'Problems, we cannot have excluded middle data from WPS' @@ -444,14 +465,14 @@ SUBROUTINE init_domain_rk ( grid & grid%msfvx_inv(i,jte) = 0. END DO END IF - ELSE IF ( ( config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN + ELSE IF ( ( config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN DO j=jts,jte DO i=its,min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j) END DO END DO - ELSE IF ( ( .NOT. config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( flag_mf_xy .NE. 1 ) ) THEN + ELSE IF ( ( .NOT. config_flags%polar ) .AND. ( flag_mf_xy .NE. 1 ) ) THEN DO j=jts,jte DO i=its,ite IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE @@ -469,7 +490,7 @@ SUBROUTINE init_domain_rk ( grid & grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j) END DO END DO - ELSE IF ( ( .NOT. config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN + ELSE IF ( ( .NOT. config_flags%polar ) .AND. ( flag_mf_xy .EQ. 1 ) ) THEN IF ( grid%msfvx(its,jts) .EQ. 0 ) THEN CALL wrf_error_fatal ( 'Maybe you do not have the new map factors, try re-running geogrid' ) END IF @@ -479,7 +500,7 @@ SUBROUTINE init_domain_rk ( grid & grid%msfvx_inv(i,j) = 1./grid%msfvx(i,j) END DO END DO - ELSE IF ( ( config_flags%map_proj .EQ. PROJ_CASSINI ) .AND. ( flag_mf_xy .NE. 1 ) ) THEN + ELSE IF ( ( config_flags%polar ) .AND. ( flag_mf_xy .NE. 1 ) ) THEN CALL wrf_error_fatal ( 'Neither SI data nor older metgrid data can initialize a global domain' ) ENDIF @@ -633,7 +654,7 @@ SUBROUTINE init_domain_rk ( grid & END IF - ! Filter the input topography if this is a polar projection. + ! Filter the input topography if this is a global domain. IF ( ( config_flags%polar ) .AND. ( grid%fft_filter_lat .GT. 90 ) ) THEN CALL wrf_error_fatal ( 'If the polar boundary condition is used, then fft_filter_lat must be set in namelist.input' ) @@ -1042,6 +1063,28 @@ SUBROUTINE init_domain_rk ( grid & END DO END DO + ELSE IF ( flag_qv .EQ. 1 ) THEN + IF ( grid%p_gc(i_valid,num_metgrid_levels,j_valid) .LT. grid%p_gc(i_valid,2,j_valid) ) THEN + k = 2 + ELSE + k = num_metgrid_levels + END IF + + DO j = jts, MIN(jte,jde-1) + DO k = 1 , num_metgrid_levels + DO i = its, MIN(ite,ide-1) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + sat_vap_pres_mb = 0.6112*10.*EXP(17.67*(grid%t_gc(i,k,j)-273.15)/(grid%t_gc(i,k,j)-29.65)) + vap_pres_mb = grid%qv_gc(i,k,j) * grid%p_gc(i,k,j)/100. / (grid%qv_gc(i,k,j) + 0.622 ) + IF ( sat_vap_pres_mb .GT. 0 ) THEN + grid%rh_gc(i,k,j) = ( vap_pres_mb / sat_vap_pres_mb ) * 100. + ELSE + grid%rh_gc(i,k,j) = 0. + END IF + END DO + END DO + END DO + END IF ! Some data sets do not provide a 3d geopotential height field. @@ -1437,7 +1480,7 @@ SUBROUTINE init_domain_rk ( grid & DO WHILE (grid%id .GT. id) id = id+1 ks = ks+model_config_rec%e_vert(id-1) - ke = ks+model_config_rec%e_vert(id) + ke = ks+model_config_rec%e_vert(id)-1 ENDDO ENDIF eta_levels(1:kde) = model_config_rec%eta_levels(ks:ke) @@ -1502,6 +1545,96 @@ SUBROUTINE init_domain_rk ( grid & its , ite , jts , jte , kts , kte ) END IF + ! For hybrid coord + + DO k=kts, kte + IF ( config_flags%hybrid_opt .EQ. 0 ) THEN + grid%c3f(k) = grid%znw(k) + ELSE IF ( config_flags%hybrid_opt .EQ. 1 ) THEN + grid%c3f(k) = grid%znw(k) + ELSE IF ( config_flags%hybrid_opt .EQ. 2 ) THEN + B1 = 2. * grid%etac**2 * ( 1. - grid%etac ) + B2 = -grid%etac * ( 4. - 3. * grid%etac - grid%etac**3 ) + B3 = 2. * ( 1. - grid%etac**3 ) + B4 = - ( 1. - grid%etac**2 ) + B5 = (1.-grid%etac)**4 + grid%c3f(k) = ( B1 + B2*grid%znw(k) + B3*grid%znw(k)**2 + B4*grid%znw(k)**3 ) / B5 + IF ( grid%znw(k) .LT. grid%etac ) THEN + grid%c3f(k) = 0. + END IF + IF ( k .EQ. kds ) THEN + grid%c3f(k) = 1. + ELSE IF ( k .EQ. kde ) THEN + grid%c3f(k) = 0. + END IF + ELSE IF ( config_flags%hybrid_opt .EQ. 3 ) THEN + grid%c3f(k) = grid%znw(k)*sin(0.5*3.14159*grid%znw(k))**2 + IF ( k .EQ. kds ) THEN + grid%c3f(k) = 1. + ELSE IF ( k .EQ. kds ) THEN + grid%c3f(kde) = 0. + END IF + ELSE + CALL wrf_message ( 'ERROR: --- hybrid_opt' ) + CALL wrf_message ( 'ERROR: --- hybrid_opt=0 ==> Standard WRF terrain-following coordinate' ) + CALL wrf_message ( 'ERROR: --- hybrid_opt=1 ==> Standard WRF terrain-following coordinate, hybrid c1, c2, c3, c4' ) + CALL wrf_message ( 'ERROR: --- hybrid_opt=2 ==> Hybrid, Klemp polynomial' ) + CALL wrf_message ( 'ERROR: --- hybrid_opt=3 ==> Hybrid, sin^2' ) + CALL wrf_error_fatal ( 'ERROR: --- Invalid option' ) + END IF + END DO + + ! c4 is a function of c3 and eta. + + DO k=1, kde + grid%c4f(k) = ( grid%znw(k) - grid%c3f(k) ) * ( p1000mb - grid%p_top ) + ENDDO + + ! Now on half levels, just add up and divide by 2 (for c3h). Use (eta-c3)*(p00-pt) for c4 on half levels. + + DO k=1, kde-1 + grid%znu(k) = ( grid%znw(k+1) + grid%znw(k) ) * 0.5 + grid%c3h(k) = ( grid%c3f(k+1) + grid%c3f(k) ) * 0.5 + grid%c4h(k) = ( grid%znu(k) - grid%c3h(k) ) * ( p1000mb - grid%p_top ) + ENDDO + + ! c1 = d(B)/d(eta). We define c1f as c1 on FULL levels. For a vertical difference, + ! we need to use B and eta on half levels. The k-loop ends up referring to the + ! full levels, neglecting the top and bottom. + + DO k=kds+1, kde-1 + grid%c1f(k) = ( grid%c3h(k) - grid%c3h(k-1) ) / ( grid%znu(k) - grid%znu(k-1) ) + ENDDO + + ! The boundary conditions to get the coefficients: + ! 1) At k=kts: define d(B)/d(eta) = 1. This gives us the same value of B and d(B)/d(eta) + ! when doing the sigma-only B=eta. + ! 2) At k=kte: define d(B)/d(eta) = 0. The curve B SMOOTHLY goes to zero, and at the very + ! top, B continues to SMOOTHLY go to zero. Note that for almost all cases of non B=eta, + ! B is ALREADY=ZERO at the top, so this is a reasonable BC to assume. + + grid%c1f(kds) = 1. + IF ( ( config_flags%hybrid_opt .EQ. 0 ) .OR. ( config_flags%hybrid_opt .EQ. 1 ) ) THEN + grid%c1f(kde) = 1. + ELSE + grid%c1f(kde) = 0. + END IF + + ! c2 = ( 1. - c1(k) ) * (p00 - pt). There is no vertical differencing, so we can do the + ! full kds to kde looping. + + DO k=kds, kde + grid%c2f(k) = ( 1. - grid%c1f(k) ) * ( p1000mb - grid%p_top ) + ENDDO + + ! Now on half levels for c1 and c2. The c1h will result from the full level c3 and full + ! level eta differences. The c2 value use the half level c1(k). + + DO k=1, kde-1 + grid%c1h(k) = ( grid%c3f(k+1) - grid%c3f(k) ) / ( grid%znw(k+1) - grid%znw(k) ) + grid%c2h(k) = ( 1. - grid%c1h(k) ) * ( p1000mb - grid%p_top ) + ENDDO + IF ( config_flags%interp_theta ) THEN ! The input field is temperature, we want potential temp. @@ -1520,6 +1653,7 @@ SUBROUTINE init_domain_rk ( grid & ! later after the vertical interpolations are complete. CALL p_dry ( grid%mu0 , grid%znw , grid%p_top , grid%pb , want_full_levels , & + grid%c3f , grid%c3h , grid%c4f , grid%c4h , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1570,7 +1704,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Z' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1590,6 +1724,7 @@ SUBROUTINE init_domain_rk ( grid & ! Now the rest of the variables on half-levels to inteprolate. CALL p_dry ( grid%mu0 , grid%znw , grid%p_top , grid%pb , want_half_levels , & + grid%c3f , grid%c3h , grid%c4f , grid%c4h , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1625,7 +1760,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1662,13 +1797,13 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'T' , & interp_type , lagrange_order , t_extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) interp_type = grid%interp_type - ! It is better to interpolate pressure in p regardless default options + ! It is better to interpolate pressure in p regardless of the default options interp_type = 1 CALL vert_interp ( grid%p_gc , grid%pd_gc , grid%p , grid%pb , & @@ -1680,7 +1815,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'T' , & interp_type , lagrange_order , t_extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1744,7 +1879,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1774,7 +1909,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1804,7 +1939,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1824,7 +1959,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1844,7 +1979,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1864,7 +1999,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1884,7 +2019,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1904,7 +2039,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1930,7 +2065,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1945,7 +2080,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1981,7 +2116,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -1996,7 +2131,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'Q' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -2017,6 +2152,400 @@ SUBROUTINE init_domain_rk ( grid & END DO END IF +!========================================================================================= +! START OF OPTIONAL 3D DATA, USUALLY AEROSOLS +!========================================================================================= + + ! Insert source code here to vertically interpolate an extra set of 3d arrays + ! that could be on a different vertical structure than the input atmospheric + ! data. Mostly, this is expected to be for monthly data (such as background + ! aerosol information). + +#if ( WRF_CHEM == 1 ) + ! OPTIONAL DATA #1: GCA - Go Cart Aerosols: OH, H2O2, NO3 + ! Pressure name: p_gca + ! Number of vertical levels: num_gca_levels + ! Variable names (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): oh, h2o2, no3 + ! Option to interpolate data: gca_input_opt = 1 + ! Not stored in scalar arrays. + + IF ( config_flags%gca_input_opt .EQ. 1 ) THEN + + CALL wrf_debug ( 0 , 'Using monthly GOcart Aerosol input: OH, H2O2, NO3 from metgrid input file' ) + + ! There are three fields - they are 3d, so no easy way to loop over them. + ! OH - Hydroxyl + ! H2O2 - Hydrogen Peroxide + ! NO3 - Nitrate + + DO k = 1, config_flags%num_gca_levels + WRITE(a_message,*) ' transferring each K-level ', k, ' to OH, sample Jan data, ', grid % oh_gca_jan(its,k,jts) + CALL wrf_debug ( 1 , a_message) + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%qntemp(i, 1, j) = grid % oh_gca_jan(i,k,j) + grid%qntemp(i, 2, j) = grid % oh_gca_feb(i,k,j) + grid%qntemp(i, 3, j) = grid % oh_gca_mar(i,k,j) + grid%qntemp(i, 4, j) = grid % oh_gca_apr(i,k,j) + grid%qntemp(i, 5, j) = grid % oh_gca_may(i,k,j) + grid%qntemp(i, 6, j) = grid % oh_gca_jun(i,k,j) + grid%qntemp(i, 7, j) = grid % oh_gca_jul(i,k,j) + grid%qntemp(i, 8, j) = grid % oh_gca_aug(i,k,j) + grid%qntemp(i, 9, j) = grid % oh_gca_sep(i,k,j) + grid%qntemp(i,10, j) = grid % oh_gca_oct(i,k,j) + grid%qntemp(i,11, j) = grid % oh_gca_nov(i,k,j) + grid%qntemp(i,12, j) = grid % oh_gca_dec(i,k,j) + END DO + END DO + IF ( k .EQ. 1 ) THEN + WRITE(a_message,*) ' GOcart Aerosols OH (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts) + CALL wrf_debug ( 1 , a_message) + END IF + CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + IF ( k .eq. 1 ) THEN + write(a_message,*) ' GOcart Aerosols OH (now) ', grid%qntemp2(its,jts) + CALL wrf_debug ( 1 , a_message) + END IF + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid % oh_gca_now(i,k,j) = grid%qntemp2(i,j) + END DO + END DO + END DO + + CALL vert_interp ( grid % oh_gca_now , grid%p_gca , grid%backg_oh , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & + config_flags%num_gca_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , & + lowest_lev_from_sfc , use_levels_below_ground , use_surface , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + DO k = 1, config_flags%num_gca_levels + WRITE(a_message,*) ' transferring each K-level ', k, ' to H2O2, sample Jan data, ', grid %h2o2_gca_jan(its,k,jts) + CALL wrf_debug ( 1 , a_message) + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%qntemp(i, 1, j) = grid %h2o2_gca_jan(i,k,j) + grid%qntemp(i, 2, j) = grid %h2o2_gca_feb(i,k,j) + grid%qntemp(i, 3, j) = grid %h2o2_gca_mar(i,k,j) + grid%qntemp(i, 4, j) = grid %h2o2_gca_apr(i,k,j) + grid%qntemp(i, 5, j) = grid %h2o2_gca_may(i,k,j) + grid%qntemp(i, 6, j) = grid %h2o2_gca_jun(i,k,j) + grid%qntemp(i, 7, j) = grid %h2o2_gca_jul(i,k,j) + grid%qntemp(i, 8, j) = grid %h2o2_gca_aug(i,k,j) + grid%qntemp(i, 9, j) = grid %h2o2_gca_sep(i,k,j) + grid%qntemp(i,10, j) = grid %h2o2_gca_oct(i,k,j) + grid%qntemp(i,11, j) = grid %h2o2_gca_nov(i,k,j) + grid%qntemp(i,12, j) = grid %h2o2_gca_dec(i,k,j) + END DO + END DO + IF ( k .EQ. 1 ) THEN + WRITE(a_message,*) ' GOcart Aerosols H2O2 (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts) + CALL wrf_debug ( 1 , a_message) + END IF + CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + IF ( k .eq. 1 ) THEN + write(a_message,*) ' GOcart Aerosols H2O2 (now) ', grid%qntemp2(its,jts) + CALL wrf_debug ( 1 , a_message) + END IF + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid %h2o2_gca_now(i,k,j) = grid%qntemp2(i,j) + END DO + END DO + END DO + + CALL vert_interp ( grid %h2o2_gca_now , grid%p_gca , grid%backg_h2o2 , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & + config_flags%num_gca_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , & + lowest_lev_from_sfc , use_levels_below_ground , use_surface , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + DO k = 1, config_flags%num_gca_levels + WRITE(a_message,*) ' transferring each K-level ', k, ' to NO3, sample Jan data, ', grid % no3_gca_jan(its,k,jts) + CALL wrf_debug ( 1 , a_message) + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%qntemp(i, 1, j) = grid % no3_gca_jan(i,k,j) + grid%qntemp(i, 2, j) = grid % no3_gca_feb(i,k,j) + grid%qntemp(i, 3, j) = grid % no3_gca_mar(i,k,j) + grid%qntemp(i, 4, j) = grid % no3_gca_apr(i,k,j) + grid%qntemp(i, 5, j) = grid % no3_gca_may(i,k,j) + grid%qntemp(i, 6, j) = grid % no3_gca_jun(i,k,j) + grid%qntemp(i, 7, j) = grid % no3_gca_jul(i,k,j) + grid%qntemp(i, 8, j) = grid % no3_gca_aug(i,k,j) + grid%qntemp(i, 9, j) = grid % no3_gca_sep(i,k,j) + grid%qntemp(i,10, j) = grid % no3_gca_oct(i,k,j) + grid%qntemp(i,11, j) = grid % no3_gca_nov(i,k,j) + grid%qntemp(i,12, j) = grid % no3_gca_dec(i,k,j) + END DO + END DO + IF ( k .EQ. 1 ) THEN + WRITE(a_message,*) ' GOcart Aerosols NO3 (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts) + CALL wrf_debug ( 1 , a_message) + END IF + CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + IF ( k .eq. 1 ) THEN + write(a_message,*) ' GOcart Aerosols NO3 (now) ', grid%qntemp2(its,jts) + CALL wrf_debug ( 1 , a_message) + END IF + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid % no3_gca_now(i,k,j) = grid%qntemp2(i,j) + END DO + END DO + END DO + + CALL vert_interp ( grid % no3_gca_now , grid%p_gca , grid%backg_no3 , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & + config_flags%num_gca_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , & + lowest_lev_from_sfc , use_levels_below_ground , use_surface , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + END IF +#endif + + ! OPTIONAL DATA #2: Thompson Water-Friendly Ice-Friendly Aerosols + ! Pressure name (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): p_wif + ! Number of vertical levels: num_wif_levels + ! Variable names (assumed to end with _jan, _feb, _mar, ..., _nov, _dec): w_wif, i_wif + ! Option to interpolate data: wif_input_opt = 1 + ! Stored in scalar arrays, tested and assumed to be upside down. + + IF ( ( config_flags%wif_input_opt .EQ. 1 ) .AND. & + ( config_flags%mp_physics .EQ. THOMPSONAERO ) .AND. & + ( flag_qnwfa .EQ. 1 ) .AND. & + ( flag_qnifa .EQ. 1 ) ) THEN + + CALL wrf_debug ( 0 , 'Using monthly Water-Friendly and Ice-Friendly aerosols from metgrid input file' ) + + ! There are two data fields plus pressure - they are 3d, so no easy way to loop over them. + ! QNWFA - Number concentration water-friendly aerosols + ! QNIFA - Number concentration ice-friendly aerosols + + ! First, get the pressure temporally interpolated to the correct date/time since + ! this is a hybrid coordinate (not isobaric), and the pressure changes by month. + ! NOTE: The input pressure is not vertically interpolated, but the other two input + ! fields (QNWFA, QNIFA) are interpolated to the WRF eta coordinate. + + wif_upside_down = .FALSE. + IF ( grid%p_wif_jan(its,config_flags%num_wif_levels/2-1,jts) - & + grid%p_wif_jan(its,config_flags%num_wif_levels/2+1,jts) .LT. 0 ) THEN + wif_upside_down = .TRUE. + END IF + + DO k = 1, config_flags%num_wif_levels + WRITE(a_message,*) ' transferring each K-level ', k, ' to Prs WIF, sample Jan data, ', grid %p_wif_jan(its,k,jts) + CALL wrf_debug ( 1 , a_message) + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%qntemp(i, 1, j) = grid %p_wif_jan(i,k,j) + grid%qntemp(i, 2, j) = grid %p_wif_feb(i,k,j) + grid%qntemp(i, 3, j) = grid %p_wif_mar(i,k,j) + grid%qntemp(i, 4, j) = grid %p_wif_apr(i,k,j) + grid%qntemp(i, 5, j) = grid %p_wif_may(i,k,j) + grid%qntemp(i, 6, j) = grid %p_wif_jun(i,k,j) + grid%qntemp(i, 7, j) = grid %p_wif_jul(i,k,j) + grid%qntemp(i, 8, j) = grid %p_wif_aug(i,k,j) + grid%qntemp(i, 9, j) = grid %p_wif_sep(i,k,j) + grid%qntemp(i,10, j) = grid %p_wif_oct(i,k,j) + grid%qntemp(i,11, j) = grid %p_wif_nov(i,k,j) + grid%qntemp(i,12, j) = grid %p_wif_dec(i,k,j) + END DO + END DO + IF ( k .EQ. 1 ) THEN + WRITE(a_message,*) ' Prs WIF (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts) + CALL wrf_debug ( 1 , a_message) + END IF + CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + IF ( k .eq. 1 ) THEN + write(a_message,*) ' Prs WIF (now) ', grid%qntemp2(its,jts) + CALL wrf_debug ( 1 , a_message) + END IF + IF ( wif_upside_down ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid %p_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j) + END DO + END DO + ELSE IF ( .NOT. wif_upside_down ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid %p_wif_now(i, k,j) = grid%qntemp2(i,j) + END DO + END DO + END IF + END DO + + DO k = 1, config_flags%num_wif_levels + WRITE(a_message,*) ' transferring each K-level ', k, ' to QNWFA, sample Jan data, ', grid %w_wif_jan(its,k,jts) + CALL wrf_debug ( 1 , a_message) + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%qntemp(i, 1, j) = grid %w_wif_jan(i,k,j) + grid%qntemp(i, 2, j) = grid %w_wif_feb(i,k,j) + grid%qntemp(i, 3, j) = grid %w_wif_mar(i,k,j) + grid%qntemp(i, 4, j) = grid %w_wif_apr(i,k,j) + grid%qntemp(i, 5, j) = grid %w_wif_may(i,k,j) + grid%qntemp(i, 6, j) = grid %w_wif_jun(i,k,j) + grid%qntemp(i, 7, j) = grid %w_wif_jul(i,k,j) + grid%qntemp(i, 8, j) = grid %w_wif_aug(i,k,j) + grid%qntemp(i, 9, j) = grid %w_wif_sep(i,k,j) + grid%qntemp(i,10, j) = grid %w_wif_oct(i,k,j) + grid%qntemp(i,11, j) = grid %w_wif_nov(i,k,j) + grid%qntemp(i,12, j) = grid %w_wif_dec(i,k,j) + END DO + END DO + IF ( k .EQ. 1 ) THEN + WRITE(a_message,*) ' QNWFA (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts) + CALL wrf_debug ( 1 , a_message) + END IF + CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + IF ( k .eq. 1 ) THEN + write(a_message,*) ' QNWFA (now) ', grid%qntemp2(its,jts) + CALL wrf_debug ( 1 , a_message) + END IF + IF ( wif_upside_down ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid %w_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j) + END DO + END DO + ELSE IF ( .NOT. wif_upside_down ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid %w_wif_now(i, k,j) = grid%qntemp2(i,j) + END DO + END DO + END IF + END DO + + CALL vert_interp ( grid %w_wif_now , grid%p_wif_now , scalar(:,:,:,P_qnwfa) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & + config_flags%num_wif_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , & + lowest_lev_from_sfc , use_levels_below_ground , use_surface , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + DO k = 1, config_flags%num_wif_levels + WRITE(a_message,*) ' transferring each K-level ', k, ' to QNIFA, sample Jan data, ', grid %i_wif_jan(its,k,jts) + CALL wrf_debug ( 1 , a_message) + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid%qntemp(i, 1, j) = grid %i_wif_jan(i,k,j) + grid%qntemp(i, 2, j) = grid %i_wif_feb(i,k,j) + grid%qntemp(i, 3, j) = grid %i_wif_mar(i,k,j) + grid%qntemp(i, 4, j) = grid %i_wif_apr(i,k,j) + grid%qntemp(i, 5, j) = grid %i_wif_may(i,k,j) + grid%qntemp(i, 6, j) = grid %i_wif_jun(i,k,j) + grid%qntemp(i, 7, j) = grid %i_wif_jul(i,k,j) + grid%qntemp(i, 8, j) = grid %i_wif_aug(i,k,j) + grid%qntemp(i, 9, j) = grid %i_wif_sep(i,k,j) + grid%qntemp(i,10, j) = grid %i_wif_oct(i,k,j) + grid%qntemp(i,11, j) = grid %i_wif_nov(i,k,j) + grid%qntemp(i,12, j) = grid %i_wif_dec(i,k,j) + END DO + END DO + IF ( k .EQ. 1 ) THEN + WRITE(a_message,*) ' QNIFA (jan and feb) ', grid%qntemp(its,1,jts),grid%qntemp(its,2,jts) + CALL wrf_debug ( 1 , a_message) + END IF + CALL monthly_interp_to_date ( grid%qntemp , current_date , grid%qntemp2 , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + IF ( k .eq. 1 ) THEN + write(a_message,*) ' QNIFA (now) ', grid%qntemp2(its,jts) + CALL wrf_debug ( 1 , a_message) + END IF + IF ( wif_upside_down ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid %i_wif_now(i,config_flags%num_wif_levels+1-k,j) = grid%qntemp2(i,j) + END DO + END DO + ELSE IF ( .NOT. wif_upside_down ) THEN + DO j = jts, MIN(jte,jde-1) + DO i = its, MIN(ite,ide-1) + grid %i_wif_now(i, k,j) = grid%qntemp2(i,j) + END DO + END DO + END IF + END DO + + CALL vert_interp ( grid %i_wif_now , grid%p_wif_now , scalar(:,:,:,P_qnifa) , grid%pb , & + grid%hgtmaxw , grid%hgttrop , grid%pmaxw , grid%ptrop , & + grid%pmaxwnn , grid%ptropnn , & + 0 , 0 , & + config_flags%maxw_horiz_pres_diff , config_flags%trop_horiz_pres_diff , & + config_flags%maxw_above_this_level , & + config_flags%num_wif_levels , 'Q' , & + interp_type , lagrange_order , extrap_type , & + lowest_lev_from_sfc , use_levels_below_ground , use_surface , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & + ids , ide , jds , jde , kds , kde , & + ims , ime , jms , jme , kms , kme , & + its , ite , jts , jte , kts , kte ) + + ELSE IF ( ( config_flags%wif_input_opt .EQ. 1 ) .AND. & + ( config_flags%mp_physics .EQ. THOMPSONAERO ) .AND. & + ( ( flag_qnwfa .NE. 1 ) .OR. & + ( flag_qnifa .NE. 1 ) ) ) THEN + WRITE (a_message,*) 'COMMENT: QNWFA or QNIFA flags not set in metgrid input, cannot have wif_input_opt=1' + CALL wrf_debug ( 0 , a_message) + WRITE (a_message,*) 'COMMENT: QNWFA and QNIFA will be initialized to zero values' + CALL wrf_debug ( 0 , a_message) + + END IF + +!========================================================================================= +! END OF OPTIONAL 3D DATA, USUALLY AEROSOLS +!========================================================================================= + ! If this is UM data, put the dry rho-based pressure back into the dry pressure array. ! Since the dry pressure is no longer needed, no biggy. @@ -2055,7 +2584,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'U' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -2069,7 +2598,7 @@ SUBROUTINE init_domain_rk ( grid & num_metgrid_levels , 'V' , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , grid%id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -2299,94 +2828,6 @@ SUBROUTINE init_domain_rk ( grid & IF ( any_valid_points ) THEN IF ( config_flags%surface_input_source .EQ. 1 ) THEN - ! Spliti NUDAPT Urban Parameters - - IF ( ( config_flags%sf_urban_physics == 1 ) .OR. ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN - DO j = jts , MIN(jde-1,jte) - DO i = its , MIN(ide-1,ite) - IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE - grid%LP_URB2D(i,j) = grid%URB_PARAM(i,91,j) - grid%LB_URB2D(i,j) = grid%URB_PARAM(i,95,j) - grid%HGT_URB2D(i,j) = grid%URB_PARAM(i,94,j) - END DO - END DO - ENDIF - - IF ( ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN - DO j = jts , MIN(jde-1,jte) - DO i = its , MIN(ide-1,ite) - IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE - DO k = 1, 15 - grid%HI_URB2D(i,k,j) = grid%URB_PARAM(i,k+117,j) - END DO - END DO - END DO - ENDIF - - DO j = jts , MIN(jde-1,jte) - DO i = its , MIN(ide-1,ite) - IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE - IF ( config_flags%sf_urban_physics==1 ) THEN - grid%MH_URB2D(i,j) = grid%URB_PARAM(i,92,j) - grid%STDH_URB2D(i,j) = grid%URB_PARAM(i,93,j) - ENDIF - grid%H2W_URB2D(i,j) = grid%URB_PARAM(i,101,j) - grid%Z0S_URB2D(i,j) = grid%URB_PARAM(i,103,j) - grid%ZDS_URB2D(i,j) = grid%URB_PARAM(i,104,j) - grid%ZDM_URB2D(i,j) = grid%URB_PARAM(i,117,j) - IF(grid%URB_PARAM(i,100,j).eq.0)THEN - grid%CAR_URB2D(i,j) = 1.0 - ELSE - grid%CAR_URB2D(i,j) = grid%URB_PARAM(i,100,j) - END IF - IF(grid%URB_PARAM(i,102,j).eq.0)THEN - grid%SVF_URB2D(i,j) = 1.0 - ELSE - grid%SVF_URB2D(i,j) = grid%URB_PARAM(i,102,j) - END IF - END DO - END DO - - DO j = jts , MIN(jde-1,jte) - DO i = its , MIN(ide-1,ite) - IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE - DO k = 1, 15 - grid%FAD0_URB2D(i,k,j) = grid%URB_PARAM(i,k,j) - grid%FAD135_URB2D(i,k,j) = grid%URB_PARAM(i,k+15,j) - grid%FAD45_URB2D(i,k,j) = grid%URB_PARAM(i,k+30,j) - grid%FAD90_URB2D(i,k,j) = grid%URB_PARAM(i,k+45,j) - grid%PAD_URB2D(i,k,j) = grid%URB_PARAM(i,k+60,j) - grid%RAD_URB2D(i,k,j) = grid%URB_PARAM(i,k+75,j) - END DO - END DO - END DO - - DO j = jts , MIN(jde-1,jte) - DO i = its , MIN(ide-1,ite) - IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE - DO k = 1, 4 - IF ( config_flags%sf_urban_physics==1 ) THEN - grid%LF_URB2D(i,k,j) = grid%URB_PARAM(i,k+95,j) - ENDIF - grid%Z0M_URB2D(i,k,j) = grid%URB_PARAM(i,k+112,j) - END DO - END DO - END DO - - DO j = jts , MIN(jde-1,jte) - DO i = its , MIN(ide-1,ite) - IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE - grid%Z0R_URB2D(i,1,j) = grid%URB_PARAM(i,105,j) - grid%Z0R_URB2D(i,2,j) = grid%URB_PARAM(i,107,j) - grid%Z0R_URB2D(i,3,j) = grid%URB_PARAM(i,109,j) - grid%Z0R_URB2D(i,4,j) = grid%URB_PARAM(i,111,j) - grid%ZDR_URB2D(i,1,j) = grid%URB_PARAM(i,106,j) - grid%ZDR_URB2D(i,2,j) = grid%URB_PARAM(i,108,j) - grid%ZDR_URB2D(i,3,j) = grid%URB_PARAM(i,110,j) - grid%ZDR_URB2D(i,4,j) = grid%URB_PARAM(i,112,j) - END DO - END DO - ! Generate the vegetation and soil category information from the fractional input ! data, or use the existing dominant category fields if they exist. @@ -2470,6 +2911,95 @@ SUBROUTINE init_domain_rk ( grid & END IF END IF + + ! Split NUDAPT Urban Parameters + + IF ( ( config_flags%sf_urban_physics == 1 ) .OR. ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + grid%LP_URB2D(i,j) = grid%URB_PARAM(i,91,j) + grid%LB_URB2D(i,j) = grid%URB_PARAM(i,95,j) + grid%HGT_URB2D(i,j) = grid%URB_PARAM(i,94,j) + END DO + END DO + ENDIF + + IF ( ( config_flags%sf_urban_physics == 2 ) .OR. ( config_flags%sf_urban_physics == 3 ) ) THEN + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + DO k = 1, 15 + grid%HI_URB2D(i,k,j) = grid%URB_PARAM(i,k+117,j) + END DO + END DO + END DO + ENDIF + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + IF ( config_flags%sf_urban_physics==1 ) THEN + grid%MH_URB2D(i,j) = grid%URB_PARAM(i,92,j) + grid%STDH_URB2D(i,j) = grid%URB_PARAM(i,93,j) + ENDIF + grid%H2W_URB2D(i,j) = grid%URB_PARAM(i,101,j) + grid%Z0S_URB2D(i,j) = grid%URB_PARAM(i,103,j) + grid%ZDS_URB2D(i,j) = grid%URB_PARAM(i,104,j) + grid%ZDM_URB2D(i,j) = grid%URB_PARAM(i,117,j) + IF(grid%URB_PARAM(i,100,j).eq.0)THEN + grid%CAR_URB2D(i,j) = 1.0 + ELSE + grid%CAR_URB2D(i,j) = grid%URB_PARAM(i,100,j) + END IF + IF(grid%URB_PARAM(i,102,j).eq.0)THEN + grid%SVF_URB2D(i,j) = 1.0 + ELSE + grid%SVF_URB2D(i,j) = grid%URB_PARAM(i,102,j) + END IF + END DO + END DO + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + DO k = 1, 15 + grid%FAD0_URB2D(i,k,j) = grid%URB_PARAM(i,k,j) + grid%FAD135_URB2D(i,k,j) = grid%URB_PARAM(i,k+15,j) + grid%FAD45_URB2D(i,k,j) = grid%URB_PARAM(i,k+30,j) + grid%FAD90_URB2D(i,k,j) = grid%URB_PARAM(i,k+45,j) + grid%PAD_URB2D(i,k,j) = grid%URB_PARAM(i,k+60,j) + grid%RAD_URB2D(i,k,j) = grid%URB_PARAM(i,k+75,j) + END DO + END DO + END DO + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + DO k = 1, 4 + IF ( config_flags%sf_urban_physics==1 ) THEN + grid%LF_URB2D(i,k,j) = grid%URB_PARAM(i,k+95,j) + ENDIF + grid%Z0M_URB2D(i,k,j) = grid%URB_PARAM(i,k+112,j) + END DO + END DO + END DO + + DO j = jts , MIN(jde-1,jte) + DO i = its , MIN(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + grid%Z0R_URB2D(i,1,j) = grid%URB_PARAM(i,105,j) + grid%Z0R_URB2D(i,2,j) = grid%URB_PARAM(i,107,j) + grid%Z0R_URB2D(i,3,j) = grid%URB_PARAM(i,109,j) + grid%Z0R_URB2D(i,4,j) = grid%URB_PARAM(i,111,j) + grid%ZDR_URB2D(i,1,j) = grid%URB_PARAM(i,106,j) + grid%ZDR_URB2D(i,2,j) = grid%URB_PARAM(i,108,j) + grid%ZDR_URB2D(i,3,j) = grid%URB_PARAM(i,110,j) + grid%ZDR_URB2D(i,4,j) = grid%URB_PARAM(i,112,j) + END DO + END DO + END IF ! Adjustments for the seaice field PRIOR to the grid%tslb computations. This is @@ -3040,8 +3570,13 @@ SUBROUTINE init_domain_rk ( grid & DO k = 1, kte-1 +#if !( HYBRID_COORD==1 ) grid%php(i,k,j) = grid%znw(k)*(p_surf - grid%p_top) + grid%p_top ! temporary, full lev base pressure - grid%pb(i,k,j) = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top + grid%pb(i,k,j) = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top +#elif ( HYBRID_COORD==1 ) + grid%php(i,k,j) = grid%c3f(k)*(p_surf - grid%p_top)+grid%c4f(k) + grid%p_top ! temporary, full lev base pressure + grid%pb(i,k,j) = grid%c3h(k)*(p_surf - grid%p_top)+grid%c4h(k) + grid%p_top +#endif temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) ) IF ( grid%pb(i,k,j) .LT. p_strat ) THEN temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat ) @@ -3053,12 +3588,12 @@ SUBROUTINE init_domain_rk ( grid & ! Base state mu is defined as base state surface pressure minus grid%p_top - grid%mub(i,j) = p_surf - grid%p_top + grid%MUB(i,j) = p_surf - grid%p_top ! Dry surface pressure is defined as the following (this mu is from the input file ! computed from the dry pressure). Here the dry pressure is just reconstituted. - pd_surf = grid%mu0(i,j) + grid%p_top + pd_surf = grid%MU0(i,j) + grid%p_top ! Integrate base geopotential, starting at terrain elevation. This assures that ! the base state is in exact hydrostatic balance with respect to the model equations. @@ -3066,14 +3601,21 @@ SUBROUTINE init_domain_rk ( grid & grid%phb(i,1,j) = grid%ht(i,j) * g IF (grid%hypsometric_opt == 1) THEN - DO k = 2,kte - grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j) + DO kk = 2,kte + k = kk-1 + grid%phb(i,kk,j) = grid%phb(i,kk-1,j) - grid%dnw(kk-1)*grid%mub(i,j)*grid%alb(i,kk-1,j) END DO ELSE IF (grid%hypsometric_opt == 2) THEN DO k = 2,kte +#if !( HYBRID_COORD==1 ) pfu = grid%mub(i,j)*grid%znw(k) + grid%p_top pfd = grid%mub(i,j)*grid%znw(k-1) + grid%p_top phm = grid%mub(i,j)*grid%znu(k-1) + grid%p_top +#elif ( HYBRID_COORD==1 ) + pfu = grid%c3f(k )*grid%MUB(i,j)+grid%c4f(k ) + grid%p_top + pfd = grid%c3f(k-1)*grid%MUB(i,j)+grid%c4f(k-1) + grid%p_top + phm = grid%c3h(k-1)*grid%MUB(i,j)+grid%c4h(k-1) + grid%p_top +#endif grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu) END DO ELSE @@ -3097,8 +3639,8 @@ SUBROUTINE init_domain_rk ( grid & IF ( ite .EQ. ide ) THEN i = ide DO j = jts, MIN(jde-1,jte) - grid%mub(i,j) = grid%mub(i-1,j) - grid%mu_2(i,j) = grid%mu_2(i-1,j) + grid%MUB(i,j) = grid%MUB(i-1,j) + grid%MU_2(i,j) = grid%MU_2(i-1,j) DO k = 1, kte-1 grid%pb(i,k,j) = grid%pb(i-1,k,j) grid%t_init(i,k,j) = grid%t_init(i-1,k,j) @@ -3113,8 +3655,8 @@ SUBROUTINE init_domain_rk ( grid & IF ( jte .EQ. jde ) THEN j = jde DO i = its, ite - grid%mub(i,j) = grid%mub(i,j-1) - grid%mu_2(i,j) = grid%mu_2(i,j-1) + grid%MUB(i,j) = grid%MUB(i,j-1) + grid%MU_2(i,j) = grid%MU_2(i,j-1) DO k = 1, kte-1 grid%pb(i,k,j) = grid%pb(i,k,j-1) grid%t_init(i,k,j) = grid%t_init(i,k,j-1) @@ -3126,12 +3668,12 @@ SUBROUTINE init_domain_rk ( grid & END DO END IF - ! Compute the perturbation dry pressure (grid%mub + grid%mu_2 + ptop = dry grid%psfc). + ! Compute the total column perturbation dry pressure (grid%mub + grid%mu_2 + ptop = dry grid%psfc). DO j = jts, min(jde-1,jte) DO i = its, min(ide-1,ite) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE - grid%mu_2(i,j) = grid%mu0(i,j) - grid%mub(i,j) + grid%MU_2(i,j) = grid%MU0(i,j) - grid%MUB(i,j) END DO END DO @@ -3140,14 +3682,14 @@ SUBROUTINE init_domain_rk ( grid & IF ( ite .EQ. ide ) THEN i = ide DO j = jts, MIN(jde-1,jte) - grid%mu_2(i,j) = grid%mu_2(i-1,j) + grid%MU_2(i,j) = grid%MU_2(i-1,j) END DO END IF IF ( jte .EQ. jde ) THEN j = jde DO i = its, ite - grid%mu_2(i,j) = grid%mu_2(i,j-1) + grid%MU_2(i,j) = grid%MU_2(i,j-1) END DO END IF @@ -3175,38 +3717,40 @@ SUBROUTINE init_domain_rk ( grid & ! equation) down from the top to get the pressure perturbation. First get the pressure ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. - k = kte-1 + kk = kte-1 + k = kk+1 qtot=0. DO im = PARAM_FIRST_SCALAR, num_3d_m - qtot = qtot + moist(i,k,j,im) + qtot = qtot + moist(i,kk,j,im) ENDDO qvf2 = 1./(1.+qtot) qvf1 = qtot*qvf2 - grid%p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2 - qvf = 1. + rvovrd*moist(i,k,j,P_QV) - grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf& - *(((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) - grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + grid%p(i,kk,j) = - 0.5*(grid%Mu_2(i,j)+qvf1*grid%Mub(i,j))/grid%rdnw(kk)/qvf2 + qvf = 1. + rvovrd*moist(i,kk,j,P_QV) + grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf& + *(((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) + grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) + grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two ! inverse density fields (total and perturbation). - DO k=kte-2,1,-1 + DO kk=kte-2,1,-1 + k = kk + 1 qtot=0. DO im = PARAM_FIRST_SCALAR, num_3d_m - qtot = qtot + 0.5*(moist(i,k,j,im)+moist(i,k+1,j,im)) + qtot = qtot + 0.5*(moist(i,kk,j,im)+moist(i,kk+1,j,im)) ENDDO qvf2 = 1./(1.+qtot) qvf1 = qtot*qvf2 - grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_2(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1) - qvf = 1. + rvovrd*moist(i,k,j,P_QV) - grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* & - (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) - grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + grid%p(i,kk,j) = grid%p(i,kk+1,j) - (grid%Mu_2(i,j) + qvf1*grid%Mub(i,j))/qvf2/grid%rdn(kk+1) + qvf = 1. + rvovrd*moist(i,kk,j,P_QV) + grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* & + (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) + grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) + grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) END DO #if 1 @@ -3214,11 +3758,12 @@ SUBROUTINE init_domain_rk ( grid & ! the model, grid%al (inverse density) is computed from the geopotential. IF (grid%hypsometric_opt == 1) THEN - DO k = 2,kte - grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - & - grid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,k-1,j) & - + grid%mu_2(i,j)*grid%alb(i,k-1,j) ) - grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j) + DO kk = 2,kte + k = kk - 1 + grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - & + grid%dnw(kk-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,kk-1,j) & + + grid%mu_2(i,j)*grid%alb(i,kk-1,j) ) + grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j) END DO ELSE IF (grid%hypsometric_opt == 2) THEN ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure. @@ -3227,9 +3772,15 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_2(i,1,j) = grid%phb(i,1,j) DO k = 2,kte +#if !( HYBRID_COORD==1 ) pfu = grid%mu0(i,j)*grid%znw(k) + grid%p_top pfd = grid%mu0(i,j)*grid%znw(k-1) + grid%p_top phm = grid%mu0(i,j)*grid%znu(k-1) + grid%p_top +#elif ( HYBRID_COORD==1 ) + pfu = grid%c3f(k )*grid%MU0(i,j)+grid%c4f(k ) + grid%p_top + pfd = grid%c3f(k-1)*grid%MU0(i,j)+grid%c4f(k-1) + grid%p_top + phm = grid%c3h(k-1)*grid%MU0(i,j)+grid%c4h(k-1) + grid%p_top +#endif grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu) END DO @@ -3254,11 +3805,31 @@ SUBROUTINE init_domain_rk ( grid & ENDDO ELSE IF (grid%hypsometric_opt == 2) THEN DO k=kts,kte-1 +#if !( HYBRID_COORD==1 ) pfu = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k+1)+grid%p_top pfd = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k) +grid%p_top phm = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k) +grid%p_top +#elif ( HYBRID_COORD==1 ) + pfu = grid%c3f(k+1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k+1)+grid%p_top + pfd = grid%c3f(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k )+grid%p_top + phm = grid%c3h(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k )+grid%p_top +#endif + qvf=-1./(grid%mub(i,j)+grid%mu_2(i,j))*(grid%alb(i,k,j)*grid%mu_2(i,j) & + +grid%rdnw(k)*(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j))) grid%al(i,k,j) = (grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)) & /phm/LOG(pfd/pfu)-grid%alb(i,k,j) +#if 0 +if ( internal_time_loop .EQ. 1 ) THEN +if (i.eq.its .and. j.eq.its)then +if (k.eq.kts)then +print *,' k old al new al alb new alt dz (m) pres up Pres mid Pres down c3 k c3 k+1 c4 k c4 k+1' +print *,' =======================================================================================================================================================================================================================================' +endif +print *,' ',k,qvf,grid%al(i,k,j),grid%alb(i,k,j),grid%al(i,k,j)+grid%alb(i,k,j),(grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)),pfu,phm,pfd,grid%c3f(k),grid%c3f(k+1),grid%c4f(k),grid%c4f(k+1) +endif +endif +#endif + ENDDO END IF @@ -3329,7 +3900,7 @@ SUBROUTINE init_domain_rk ( grid & (1.+0.6*moist(i,1,j,P_QV)) dpmu = ( grid%php(i,1,j) + grid%p(i,1,j) ) * EXP ( g * dz500 / ( r_d * tvsfc ) ) dpmu = dpmu - ( grid%php(i,1,j) + grid%p(i,1,j) ) - grid%mu_2(i,j) = grid%mu_2(i,j) - dpmu + grid%MU_2(i,j) = grid%MU_2(i,j) - dpmu EXIT END IF @@ -3413,38 +3984,40 @@ SUBROUTINE init_domain_rk ( grid & ! equation) down from the top to get the pressure perturbation. First get the pressure ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. - k = kte-1 + kk = kte-1 + k=kk+1 qtot=0. DO im = PARAM_FIRST_SCALAR, num_3d_m - qtot = qtot + moist(i,k,j,im) + qtot = qtot + moist(i,kk,j,im) ENDDO qvf2 = 1./(1.+qtot) qvf1 = qtot*qvf2 - grid%p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2 - qvf = 1. + rvovrd*moist(i,k,j,P_QV) - grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf& - *(((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) - grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + grid%p(i,kk,j) = - 0.5*(grid%Mu_2(i,j)+qvf1*grid%Mub(i,j))/grid%rdnw(kk)/qvf2 + qvf = 1. + rvovrd*moist(i,kk,j,P_QV) + grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf& + *(((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) + grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) + grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two ! inverse density fields (total and perturbation). - DO k=kte-2,1,-1 + DO kk=kte-2,1,-1 + k = kk + 1 qtot=0. DO im = PARAM_FIRST_SCALAR, num_3d_m - qtot = qtot + 0.5*(moist(i,k,j,im)+moist(i,k+1,j,im)) + qtot = qtot + 0.5*(moist(i,kk,j,im)+moist(i,kk+1,j,im)) ENDDO qvf2 = 1./(1.+qtot) qvf1 = qtot*qvf2 - grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_2(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1) - qvf = 1. + rvovrd*moist(i,k,j,P_QV) - grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* & - (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) - grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + grid%p(i,kk,j) = grid%p(i,kk+1,j) - (grid%Mu_2(i,j) + qvf1*grid%Mub(i,j))/qvf2/grid%rdn(kk+1) + qvf = 1. + rvovrd*moist(i,kk,j,P_QV) + grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* & + (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) + grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) + grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) END DO #if 1 @@ -3453,11 +4026,12 @@ SUBROUTINE init_domain_rk ( grid & IF (grid%hypsometric_opt == 1) THEN - DO k = 2,kte - grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - & - grid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,k-1,j) & - + grid%mu_2(i,j)*grid%alb(i,k-1,j) ) - grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j) + DO kk = 2,kte + k = kk-1 + grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - & + grid%dnw(kk-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,kk-1,j) & + + grid%mu_2(i,j)*grid%alb(i,kk-1,j) ) + grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j) END DO ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure. @@ -3468,9 +4042,15 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_2(i,1,j) = grid%phb(i,1,j) DO k = 2,kte +#if !( HYBRID_COORD==1 ) pfu = grid%mu0(i,j)*grid%znw(k) + grid%p_top pfd = grid%mu0(i,j)*grid%znw(k-1) + grid%p_top phm = grid%mu0(i,j)*grid%znu(k-1) + grid%p_top +#elif ( HYBRID_COORD==1 ) + pfu = grid%c3f(k )*grid%MU0(i,j)+grid%c4f(k ) + grid%p_top + pfd = grid%c3f(k-1)*grid%MU0(i,j)+grid%c4f(k-1) + grid%p_top + phm = grid%c3h(k-1)*grid%MU0(i,j)+grid%c4h(k-1) + grid%p_top +#endif grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu) END DO @@ -3495,9 +4075,15 @@ SUBROUTINE init_domain_rk ( grid & ENDDO ELSE IF (grid%hypsometric_opt == 2) THEN DO k=kts,kte-1 +#if !( HYBRID_COORD==1 ) pfu = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k+1)+grid%p_top pfd = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k) +grid%p_top phm = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k) +grid%p_top +#elif ( HYBRID_COORD==1 ) + pfu = grid%c3f(k+1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k+1)+grid%p_top + pfd = grid%c3f(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k )+grid%p_top + phm = grid%c3h(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k )+grid%p_top +#endif grid%al(i,k,j) = (grid%ph_2(i,k+1,j)-grid%ph_2(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)) & /phm/LOG(pfd/pfu)-grid%alb(i,k,j) ENDDO @@ -3567,7 +4153,7 @@ SUBROUTINE init_domain_rk ( grid & (1.+0.6*moist(i,1,j,P_QV)) dpmu = ( grid%php(i,1,j) + grid%p(i,1,j) ) * EXP ( g * dz500 / ( r_d * tvsfc ) ) dpmu = dpmu - ( grid%php(i,1,j) + grid%p(i,1,j) ) - grid%mu_2(i,j) = grid%mu_2(i,j) - dpmu + grid%MU_2(i,j) = grid%MU_2(i,j) - dpmu EXIT END IF @@ -3776,6 +4362,21 @@ SUBROUTINE init_domain_rk ( grid & ! CALL wrf_debug ( 0 , ' DONE routine to add snow in high mountain peaks') !+---+-----------------------------------------------------------------+ +! checking whether var_sso exists in the domain + ! if so, we set got_var_sso flag to true. This is later used in external/RSL_LITE/module_dm.F + ! to check for this, when the topo_wind option is used. + grid%got_var_sso = .FALSE. + DO j=jts,MIN(jde-1,jte) + DO i=its,MIN(ide-1,ite) + IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE + IF(grid%var_sso(i,j) .NE. 0) THEN + grid%got_var_sso = .true. + ENDIF + END DO + END DO +#if ( defined(DM_PARALLEL) && ! defined(STUBMPI) ) + grid%got_var_sso = wrf_dm_lor_logical ( grid%got_var_sso ) +#endif #ifdef DM_PARALLEL # include "HALO_EM_INIT_1.inc" @@ -3852,7 +4453,7 @@ SUBROUTINE rebalance ( grid & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte, & ips, ipe, jps, jpe, kps, kpe, & - i, j, k + i, j, k, kk REAL :: temp, temp_int REAL :: pfu, pfd, phm @@ -3961,8 +4562,13 @@ SUBROUTINE rebalance ( grid & p_surf_int = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j) /a/r_d ) **0.5 ) DO k = 1, kte-1 +#if !( HYBRID_COORD==1 ) grid%pb(i,k,j) = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top pb_int = grid%znu(k)*(p_surf_int - grid%p_top) + grid%p_top +#elif ( HYBRID_COORD==1 ) + grid%pb(i,k,j) = grid%c3h(k)*(p_surf - grid%p_top) + grid%c4h(k) + grid%p_top + pb_int = grid%c3h(k)*(p_surf_int - grid%p_top) + grid%c4h(k) + grid%p_top +#endif temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) ) IF ( grid%pb(i,k,j) .LT. p_strat ) THEN temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat ) @@ -3981,12 +4587,12 @@ SUBROUTINE rebalance ( grid & ! Base state mu is defined as base state surface pressure minus grid%p_top - grid%mub(i,j) = p_surf - grid%p_top + grid%MUB(i,j) = p_surf - grid%p_top ! Dry surface pressure is defined as the following (this mu is from the input file ! computed from the dry pressure). Here the dry pressure is just reconstituted. - pd_surf = ( grid%mub(i,j) + grid%mu_2(i,j) ) + grid%p_top + pd_surf = ( grid%MUB(i,j) + grid%MU_2(i,j) ) + grid%p_top ! Integrate base geopotential, starting at terrain elevation. This assures that ! the base state is in exact hydrostatic balance with respect to the model equations. @@ -3994,14 +4600,21 @@ SUBROUTINE rebalance ( grid & grid%phb(i,1,j) = grid%ht_fine(i,j) * g IF (grid%hypsometric_opt == 1) THEN - DO k = 2,kte - grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j) + DO kk = 2,kte + k = kk - 1 + grid%phb(i,kk,j) = grid%phb(i,kk-1,j) - grid%dnw(kk-1)*grid%mub(i,j)*grid%alb(i,kk-1,j) END DO ELSE IF (grid%hypsometric_opt == 2) THEN DO k = 2,kte +#if !( HYBRID_COORD==1 ) pfu = grid%mub(i,j)*grid%znw(k) + grid%p_top pfd = grid%mub(i,j)*grid%znw(k-1) + grid%p_top phm = grid%mub(i,j)*grid%znu(k-1) + grid%p_top +#elif ( HYBRID_COORD==1 ) + pfu = grid%c3f(k )*grid%MUB(i,j)+grid%c4f(k ) + grid%p_top + pfd = grid%c3f(k-1)*grid%MUB(i,j)+grid%c4f(k-1) + grid%p_top + phm = grid%c3h(k-1)*grid%MUB(i,j)+grid%c4h(k-1) + grid%p_top +#endif grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu) END DO ELSE @@ -4033,43 +4646,46 @@ SUBROUTINE rebalance ( grid & ! equation) down from the top to get the pressure perturbation. First get the pressure ! perturbation, moisture, and inverse density (total and perturbation) at the top-most level. - k = kte-1 + kk = kte-1 + k = kk+1 - qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV)) + qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk,j,P_QV)) qvf2 = 1./(1.+qvf1) qvf1 = qvf1*qvf2 - grid%p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2 - qvf = 1. + rvovrd*moist(i,k,j,P_QV) - grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* & - (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) - grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + grid%p(i,kk,j) = - 0.5*(grid%Mu_2(i,j)+qvf1*grid%Mub(i,j))/grid%rdnw(kk)/qvf2 + qvf = 1. + rvovrd*moist(i,kk,j,P_QV) + grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* & + (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) + grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) + grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) ! Now, integrate down the column to compute the pressure perturbation, and diagnose the two ! inverse density fields (total and perturbation). - DO k=kte-2,1,-1 - qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV)) + DO kk=kte-2,1,-1 + k = kk+1 + qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk+1,j,P_QV)) qvf2 = 1./(1.+qvf1) qvf1 = qvf1*qvf2 - grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_2(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1) - qvf = 1. + rvovrd*moist(i,k,j,P_QV) - grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* & - (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j) - grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j) + grid%p(i,kk,j) = grid%p(i,kk+1,j) - (grid%Mu_2(i,j) + qvf1*grid%Mub(i,j))/qvf2/grid%rdn(kk+1) + qvf = 1. + rvovrd*moist(i,kk,j,P_QV) + grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* & + (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) + grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j) + grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j) END DO ! This is the hydrostatic equation used in the model after the small timesteps. In ! the model, grid%al (inverse density) is computed from the geopotential. IF (grid%hypsometric_opt == 1) THEN - DO k = 2,kte - grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - & - grid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,k-1,j) & - + grid%mu_2(i,j)*grid%alb(i,k-1,j) ) - grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j) + DO kk = 2,kte + k = kk-1 + grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - & + grid%dnw(kk-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,kk-1,j) & + + grid%mu_2(i,j)*grid%alb(i,kk-1,j) ) + grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j) END DO ELSE IF (grid%hypsometric_opt == 2) THEN @@ -4079,9 +4695,15 @@ SUBROUTINE rebalance ( grid & grid%ph_2(i,1,j) = grid%phb(i,1,j) DO k = 2,kte - pfu = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k) + grid%p_top - pfd = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k-1) + grid%p_top - phm = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k-1) + grid%p_top +#if !( HYBRID_COORD==1 ) + pfu = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k) +grid%p_top + pfd = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k-1) +grid%p_top + phm = (grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k-1) +grid%p_top +#elif ( HYBRID_COORD==1 ) + pfu = grid%c3f(k )*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k )+grid%p_top + pfd = grid%c3f(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4f(k-1)+grid%p_top + phm = grid%c3h(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j))+grid%c4h(k-1)+grid%p_top +#endif grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu) END DO @@ -4442,7 +5064,7 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & generic , var_type , & interp_type , lagrange_order , extrap_type , & lowest_lev_from_sfc , use_levels_below_ground , use_surface , & - zap_close_levels , force_sfc_in_vinterp , & + zap_close_levels , force_sfc_in_vinterp , id , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -4456,7 +5078,7 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & LOGICAL , INTENT(IN) :: lowest_lev_from_sfc , use_levels_below_ground , use_surface REAL , INTENT(IN) :: zap_close_levels REAL , INTENT(IN) :: maxw_horiz_pres_diff , trop_horiz_pres_diff , maxw_above_this_level - INTEGER , INTENT(IN) :: force_sfc_in_vinterp + INTEGER , INTENT(IN) :: force_sfc_in_vinterp , id INTEGER , INTENT(IN) :: ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte @@ -4477,6 +5099,7 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & ! Local vars + CHARACTER (LEN=256) :: message INTEGER :: i , j , k , ko , kn , k1 , k2 , ko_1 , ko_2 , knext INTEGER :: istart , iend , jstart , jend , kstart , kend INTEGER , DIMENSION(ims:ime,kms:kme ) :: k_above , k_below @@ -4501,6 +5124,7 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & INTEGER :: em_width LOGICAL :: hold_ups #endif + INTEGER :: final_zap_check_count , count_close_by_at_ko ! Vertical interpolation of the extra levels from metgrid: max wind and tropopause @@ -5082,6 +5706,72 @@ SUBROUTINE vert_interp ( fo , po , fnew , pnu , & END IF END IF +#if 0 + ! One final check to make sure that the delta pressures are OK. + + final_zap_check_count = 0 + DO ko = kinterp_start , kinterp_end-1 + + count_close_by_at_ko = 0 + close_by_at_ko : DO + + ! First, is the pressure difference between two neighboring layers too small? + + IF ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .LT. zap_close_levels ) THEN + + ! Make sure we are vertically located where this difference is meaningful. For + ! example, a 5 hPa zap_close_levels makes sense at 850 hPa. However, a 5 hPa + ! critical thickness is sill when the top few isobaric levels are 1, 2, 3 hPa. + + IF ( ordered_porig(ko) .GT. zap_close_levels * 10 ) THEN + + ! Now we have a grid point that we should remove. We pull out the pressure + ! and field values, then we drop the rest of the array to fill in the + ! missing spot, we increment our counter of bad values found in this column, + ! and then we reduce the count of the total number of values in the array. + + DO kn = ko+1 , kinterp_end + ordered_porig(kn-1) = ordered_porig(kn) + ordered_forig(kn-1) = ordered_forig(kn) + END DO + final_zap_check_count = final_zap_check_count + 1 + END IF + END IF + + ! Did we pull down another pressure difference into the ko and ko+1 slots that will + ! cause troubles? Make sure we don't spend an infinite amount of time in this loop. + + IF ( ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .GE. zap_close_levels ) .OR. & + ( ordered_porig(ko) .LE. zap_close_levels * 10 ) ) THEN + EXIT close_by_at_ko + ELSE IF ( count_close_by_at_ko .GT. 3 ) THEN + final_zap_check_count = 99 + EXIT close_by_at_ko + ELSE + count_close_by_at_ko = count_close_by_at_ko + 1 + CYCLE close_by_at_ko + END IF + END DO close_by_at_ko + END DO + IF ( final_zap_check_count .GT. 2 ) THEN + WRITE ( message , * ) 'We are removing too many values: ',final_zap_check_count,' for (i,j) = ',i,j + CALL wrf_error_fatal ( TRIM(message) ) + END IF + kinterp_end = kinterp_end - final_zap_check_count +#else + outer : DO ko = kinterp_start , kinterp_end-1 + IF ( ( ABS(ordered_porig(ko) - ordered_porig(ko+1)) .LT. MAX(zap_close_levels/10,50.) ) .AND. & + ( ordered_porig(ko) .GT. zap_close_levels * 10 ) ) THEN + WRITE ( message , FMT='(a,I2.2,a,F9.2,a,F9.2,a,i4,a,i4,a,a)' ) '*** -> Check your wrfinput_d',id, & + ' file, you might have input pressure levels too close together (',& + ordered_porig(ko),' Pa and ', ordered_porig(ko+1), & + ' Pa) at (',i,',',j,') for variable type ',var_type + CALL wrf_message ( TRIM(message) ) + EXIT outer + END IF + END DO outer +#endif + ! The polynomials are either in pressure or LOG(pressure). IF ( interp_type .EQ. 1 ) THEN @@ -5181,7 +5871,14 @@ SUBROUTINE lagrange_setup ( var_type , interp_type , all_x , all_y , all_dim , n print *,'p array = ',all_x print *,'f array = ',all_y print *,'p target= ',target_x - CALL wrf_error_fatal ( 'troubles, the interpolating order is too large for this few input values' ) + CALL wrf_message ( 0 , 'Troubles, the interpolating order is too large for this few input values' ) + CALL wrf_message ( 0 , 'This is usually caused by bad pressures' ) + CALL wrf_message ( 0 , 'At this (i,j), look at the input value of pressure from metgrid' ) + CALL wrf_message ( 0 , 'The surface pressure and the sea-level pressure should be reviewed, also from metgrid' ) + CALL wrf_message ( 0 , 'Finally, ridiculous values of moisture can mess up the vertical pressures, especially aloft' ) + CALL wrf_message ( 0 , 'The variable type is ' // var_type // '. This is not a unique identifer, but a type of field' ) + CALL wrf_message ( 0 , 'Check to see if all time periods with this data fail, or just this one' ) + CALL wrf_error_fatal ( 'This vertical interpolation failure is more typically associated with untested data sources to ungrib' ) END IF IF ( n .LT. 1 ) THEN @@ -5479,6 +6176,7 @@ END SUBROUTINE lagrange_interp !--------------------------------------------------------------------- SUBROUTINE p_dry ( mu0 , eta , pdht , pdry , full_levs , & + c3f , c3h , c4f , c4h , & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & its , ite , jts , jte , kts , kte ) @@ -5495,6 +6193,7 @@ SUBROUTINE p_dry ( mu0 , eta , pdht , pdry , full_levs , & REAL , DIMENSION(ims:ime, jms:jme) , INTENT(IN) :: mu0 REAL , DIMENSION( kms:kme ) , INTENT(IN) :: eta + REAL , DIMENSION( kms:kme ) , INTENT(IN) :: c3f , c3h , c4f , c4h REAL :: pdht REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(OUT) :: pdry @@ -5508,7 +6207,11 @@ SUBROUTINE p_dry ( mu0 , eta , pdht , pdry , full_levs , & DO k = kts , kte DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE - pdry(i,k,j) = eta(k) * mu0(i,j) + pdht +#if !( HYBRID_COORD==1 ) + pdry(i,k,j) = eta(k) * mu0(i,j) + pdht +#elif ( HYBRID_COORD==1 ) + pdry(i,k,j) = c3f(k) * MU0(i,j) + c4f(k) + pdht +#endif END DO END DO END DO @@ -5522,7 +6225,11 @@ SUBROUTINE p_dry ( mu0 , eta , pdht , pdry , full_levs , & DO k = kts , kte-1 DO i = its , MIN (ide-1 , ite ) IF ( skip_middle_points_t ( ids , ide , jds , jde , i , j , em_width , hold_ups ) ) CYCLE - pdry(i,k,j) = eta_h(k) * mu0(i,j) + pdht +#if !( HYBRID_COORD==1 ) + pdry(i,k,j) = eta_h(k) * mu0(i,j) + pdht +#elif ( HYBRID_COORD==1 ) + pdry(i,k,j) = c3h(k) * MU0(i,j) + c4h(k) + pdht +#endif END DO END DO END DO diff --git a/wrfv2_fire/dyn_em/module_initialize_scm_xy.F b/wrfv2_fire/dyn_em/module_initialize_scm_xy.F index 7d746a51..7093b37f 100644 --- a/wrfv2_fire/dyn_em/module_initialize_scm_xy.F +++ b/wrfv2_fire/dyn_em/module_initialize_scm_xy.F @@ -333,6 +333,23 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO + + IF ( config_flags%hybrid_opt .NE. 0 ) THEN + call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) + END IF + grid%hybrid_opt = 0 + + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + ENDDO + DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) diff --git a/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F b/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F index 63fb805b..3b6d6374 100644 --- a/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F +++ b/wrfv2_fire/dyn_em/module_initialize_seabreeze2d_x.F @@ -304,6 +304,23 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO + + IF ( config_flags%hybrid_opt .NE. 0 ) THEN + call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) + END IF + grid%hybrid_opt = 0 + + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + ENDDO + DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) diff --git a/wrfv2_fire/dyn_em/module_initialize_squall2d_x.F b/wrfv2_fire/dyn_em/module_initialize_squall2d_x.F index 6f1500e0..b5d05f77 100644 --- a/wrfv2_fire/dyn_em/module_initialize_squall2d_x.F +++ b/wrfv2_fire/dyn_em/module_initialize_squall2d_x.F @@ -233,6 +233,23 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO + + IF ( config_flags%hybrid_opt .NE. 0 ) THEN + call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) + END IF + grid%hybrid_opt = 0 + + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + ENDDO + DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) diff --git a/wrfv2_fire/dyn_em/module_initialize_squall2d_y.F b/wrfv2_fire/dyn_em/module_initialize_squall2d_y.F index 44954eac..33741a3e 100644 --- a/wrfv2_fire/dyn_em/module_initialize_squall2d_y.F +++ b/wrfv2_fire/dyn_em/module_initialize_squall2d_y.F @@ -230,6 +230,23 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO + + IF ( config_flags%hybrid_opt .NE. 0 ) THEN + call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) + END IF + grid%hybrid_opt = 0 + + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + ENDDO + DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) diff --git a/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F b/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F index 9e62f642..9f3874f1 100644 --- a/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F +++ b/wrfv2_fire/dyn_em/module_initialize_tropical_cyclone.F @@ -327,6 +327,23 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO + + IF ( config_flags%hybrid_opt .NE. 0 ) THEN + call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) + END IF + grid%hybrid_opt = 0 + + DO k=1, kde + grid%c3f(k) = grid%znw(k) + grid%c4f(k) = 0. + grid%c3h(k) = grid%znu(k) + grid%c4h(k) = 0. + grid%c1f(k) = 1. + grid%c2f(k) = 0. + grid%c1h(k) = 1. + grid%c2h(k) = 0. + ENDDO + DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) diff --git a/wrfv2_fire/dyn_em/module_polarfft.F b/wrfv2_fire/dyn_em/module_polarfft.F index a89bd532..389ee8b6 100644 --- a/wrfv2_fire/dyn_em/module_polarfft.F +++ b/wrfv2_fire/dyn_em/module_polarfft.F @@ -1,3 +1,11 @@ +#if ( HYBRID_COORD==1 ) +# define mub(...) (c1(k)*XXPCBXX(__VA_ARGS__)+c2(k)) +# define XXPCBXX(...) mub(__VA_ARGS__) + +# define mu(...) (c1(k)*XXPCXX(__VA_ARGS__)) +# define XXPCXX(...) mu(__VA_ARGS__) +#endif + MODULE module_polarfft USE module_model_constants @@ -7,7 +15,7 @@ MODULE module_polarfft CONTAINS SUBROUTINE couple_scalars_for_filter ( field & - ,mu,mub & + ,mu,mub,c1,c2 & ,ids,ide,jds,jde,kds,kde & ,ims,ime,jms,jme,kms,kme & ,ips,ipe,jps,jpe,kps,kpe ) @@ -17,6 +25,7 @@ SUBROUTINE couple_scalars_for_filter ( field & ,ips,ipe,jps,jpe,kps,kpe REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: field REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: mu,mub + REAL , DIMENSION(kms:kme) , INTENT(IN) :: c1,c2 INTEGER :: i , j , k @@ -31,7 +40,7 @@ SUBROUTINE couple_scalars_for_filter ( field & END SUBROUTINE couple_scalars_for_filter SUBROUTINE uncouple_scalars_for_filter ( field & - ,mu,mub & + ,mu,mub,c1,c2 & ,ids,ide,jds,jde,kds,kde & ,ims,ime,jms,jme,kms,kme & ,ips,ipe,jps,jpe,kps,kpe ) @@ -41,6 +50,7 @@ SUBROUTINE uncouple_scalars_for_filter ( field & ,ips,ipe,jps,jpe,kps,kpe REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: field REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: mu,mub + REAL , DIMENSION(kms:kme) , INTENT(IN) :: c1,c2 INTEGER :: i , j , k @@ -599,7 +609,7 @@ SUBROUTINE polar_filter_3d( f, xlat, piggyback, fft_filter_lat, dvlat, & ! Variables will stay in domain form since this routine is meaningless ! unless tile extent is the same as domain extent in E/W direction, i.e., ! the processor has access to all grid points in E/W direction. - ! There may be other ways of doing FFTs, but we haven't learned them yet... + ! There may be other ways of doing FFTs, but we have not learned them yet... ! Check to make sure we have full access to all E/W points IF ((its /= ids) .OR. (ite /= ide)) THEN @@ -885,7 +895,7 @@ SUBROUTINE filter_tracer ( tr3d_in , xlat , msftx , & DO j = MIN(j_lat_neg,jte) , jts , -1 ! i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 ) i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 ) -! WRITE (message,FMT='(a,i4,a,i4,f6.2,1x,f6.1,f6.1)') 'DAVE SOUTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j),mf_fft +! WRITE (message,FMT='(a,i4,a,i4,f6.2,1x,f6.1,f6.1)') 'SOUTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j),mf_fft ! CALL wrf_debug ( 0 , TRIM(message) ) DO i = its , MIN(ide-1,ite) sum = 0. @@ -915,7 +925,7 @@ SUBROUTINE filter_tracer ( tr3d_in , xlat , msftx , & DO j = MAX(j_lat_pos,jts) , MIN(jde-1,jte) ! i_kicker = MIN( MAX ( NINT(msftx(its,j)/2) , 1 ) , (ide - ids) / 2 ) i_kicker = MIN( MAX ( NINT(msftx(its,j)/mf_fft/2) , 1 ) , (ide - ids) / 2 ) -! WRITE (message,FMT='(a,i4,a,i4,f6.2,1x,f6.1,f6.1)') 'DAVE NORTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j),mf_fft +! WRITE (message,FMT='(a,i4,a,i4,f6.2,1x,f6.1,f6.1)') 'NORTH j = ' , j, ', kicker = ',i_kicker,xlat(its,j),msftx(its,j),mf_fft ! CALL wrf_debug ( 0 , TRIM(message) ) DO i = its , MIN(ide-1,ite) count = 0 diff --git a/wrfv2_fire/dyn_em/module_sfs_driver.F b/wrfv2_fire/dyn_em/module_sfs_driver.F index c9d8c137..b01db5b5 100644 --- a/wrfv2_fire/dyn_em/module_sfs_driver.F +++ b/wrfv2_fire/dyn_em/module_sfs_driver.F @@ -2,7 +2,7 @@ !============================================================================== ! -! © 2009. Lawrence Livermore National Security, LLC. All rights reserved. +! Copyright 2009. Lawrence Livermore National Security, LLC. All rights reserved. ! This work was produced at the Lawrence Livermore National Laboratory (LLNL) under ! contract no. DE-AC52-07NA27344 (Contract 44) between the U.S. Department of Energy (DOE) ! and Lawrence Livermore National Security, LLC (LLNS) for the operation of LLNL. Copyright diff --git a/wrfv2_fire/dyn_em/module_sfs_nba.F b/wrfv2_fire/dyn_em/module_sfs_nba.F index 18e5d915..614477dd 100644 --- a/wrfv2_fire/dyn_em/module_sfs_nba.F +++ b/wrfv2_fire/dyn_em/module_sfs_nba.F @@ -2,7 +2,7 @@ !============================================================================== ! -! © 2009. Lawrence Livermore National Security, LLC. All rights reserved. +! Copyright 2009. Lawrence Livermore National Security, LLC. All rights reserved. ! This work was produced at the Lawrence Livermore National Laboratory (LLNL) under ! contract no. DE-AC52-07NA27344 (Contract 44) between the U.S. Department of Energy (DOE) ! and Lawrence Livermore National Security, LLC (LLNS) for the operation of LLNL. Copyright diff --git a/wrfv2_fire/dyn_em/module_small_step_em.F b/wrfv2_fire/dyn_em/module_small_step_em.F index b5eae643..c3ed9fb0 100644 --- a/wrfv2_fire/dyn_em/module_small_step_em.F +++ b/wrfv2_fire/dyn_em/module_small_step_em.F @@ -1,3 +1,57 @@ +#if ( HYBRID_COORD==1 ) +# define mu(...) (c1h(k)*XXPCXX(__VA_ARGS__)) +# define XXPCXX(...) mu(__VA_ARGS__) + +# define mut(...) (c1f(k)*XXPCTFXX(__VA_ARGS__)+c2f(k)) +# define XXPCTFXX(...) mut(__VA_ARGS__) + +# define Mut(...) (c1h(k)*XXPCTHXX(__VA_ARGS__)+c2h(k)) +# define XXPCTHXX(...) Mut(__VA_ARGS__) + +# define muu(...) (c1h(k)*XXPCUXX(__VA_ARGS__)+c2h(k)) +# define XXPCUXX(...) muu(__VA_ARGS__) + +# define muv(...) (c1h(k)*XXPCVXX(__VA_ARGS__)+c2h(k)) +# define XXPCVXX(...) muv(__VA_ARGS__) + +# define muave(...) (c1f(k)*XXPCAVEFXX(__VA_ARGS__)) +# define XXPCAVEFXX(...) muave(__VA_ARGS__) + +# define Muave(...) (c1h(k)*XXPCAVEHXX(__VA_ARGS__)) +# define XXPCAVEHXX(...) Muave(__VA_ARGS__) + +# define muus(...) (c1h(k)*XXPCUSXX(__VA_ARGS__)+c2h(k)) +# define XXPCUSXX(...) muus(__VA_ARGS__) + +# define muvs(...) (c1h(k)*XXPCVSXX(__VA_ARGS__)+c2h(k)) +# define XXPCVSXX(...) muvs(__VA_ARGS__) + +# define mu_tend(...) (c1h(k)*XXPCTENDXX(__VA_ARGS__)) +# define XXPCTENDXX(...) mu_tend(__VA_ARGS__) + +# define dmdt(...) (c1h(k)*XXDMDTXX(__VA_ARGS__)) +# define XXDMDTXX(...) dmdt(__VA_ARGS__) + +# define muts(...) (c1f(k)*XXPCTFSXX(__VA_ARGS__)+c2f(k)) +# define XXPCTFSXX(...) muts(__VA_ARGS__) + +# define Muts(...) (c1h(k)*XXPCTHSXX(__VA_ARGS__)+c2h(k)) +# define XXPCTHSXX(...) Muts(__VA_ARGS__) + +# define mudf_xy(...) (c1h(k)*XXMUDFXYXX(__VA_ARGS__)) +# define XXMUDFXYXX(...) mudf_xy(__VA_ARGS__) + +# define MUTHK (c1h(k)*MUT(i,j)+c2h(k)) + +# define MUTHKM1 (c1h(k-1)*MUT(i,j)+c2h(k-1)) + +# define MUTHMUTF_KK ((c1h(k)*MUT(i,j)+c2h(k))*(c1f(k)*MUT(i,j)+c2f(k))) + +# define MUTHMUTF_KM1K ((c1h(k-1)*MUT(i,j)+c2h(k-1))*(c1f(k)*MUT(i,j)+c2f(k))) + +# define MUTHMUTF_KKP1 ((c1h(k)*MUT(i,j)+c2h(k))*(c1f(k+1)*MUT(i,j)+c2f(k+1))) +#endif + !WRF:MODEL_LAYER:DYNAMICS ! @@ -19,6 +73,8 @@ SUBROUTINE small_step_prep( u_1, u_2, v_1, v_2, w_1, w_2, & mub, mu_1, mu_2, & muu, muus, muv, muvs, & mut, muts, mudf, & + c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f, & u_save, v_save, w_save, & t_save, ph_save, mu_save, & ww, ww_save, & @@ -91,6 +147,9 @@ SUBROUTINE small_step_prep( u_1, u_2, v_1, v_2, w_1, w_2, & REAL, INTENT(IN) :: rdx,rdy + REAL, DIMENSION( kms:kme ),INTENT(IN ) :: c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f + ! local variables INTEGER :: i, j, k @@ -125,10 +184,10 @@ SUBROUTINE small_step_prep( u_1, u_2, v_1, v_2, w_1, w_2, & DO j=j_start, j_end DO i=i_start, i_end - mu_1(i,j)=mu_2(i,j) + MU_1(i,j)=MU_2(i,j) ww_save(i,kde,j) = 0. ww_save(i,1,j) = 0. - mudf(i,j) = 0. ! initialize external mode div damp to zero + MUDF(i,j) = 0. ! initialize external mode div damp to zero ENDDO ENDDO @@ -167,28 +226,23 @@ SUBROUTINE small_step_prep( u_1, u_2, v_1, v_2, w_1, w_2, & DO j=j_start, j_end DO i=i_start, i_end - muts(i,j)=mub(i,j)+mu_2(i,j) + MUTS(i,j)=MUB(i,j)+MU_2(i,j) ENDDO DO i=i_start, i_endu -! rk_step==1, WCS fix for tiling -! muus(i,j)=0.5*(mub(i,j)+mu_2(i,j)+mub(i-1,j)+mu_2(i-1,j)) - muus(i,j) = muu(i,j) + MUUS(i,j) = MUU(i,j) ENDDO ENDDO DO j=j_start, j_endv DO i=i_start, i_end -! rk_step==1, WCS fix for tiling -! muvs(i,j)=0.5*(mub(i,j)+mu_2(i,j)+mub(i,j-1)+mu_2(i,j-1)) - muvs(i,j) = muv(i,j) + MUVS(i,j) = MUV(i,j) ENDDO ENDDO DO j=j_start, j_end DO i=i_start, i_end - mu_save(i,j)=mu_2(i,j) - mu_2(i,j)=0. -! mu_2(i,j)=mu_2(i,j)-mu_2(i,j) + MU_SAVE(i,j)=MU_2(i,j) + MU_2(i,j)=0. ENDDO ENDDO @@ -196,23 +250,23 @@ SUBROUTINE small_step_prep( u_1, u_2, v_1, v_2, w_1, w_2, & DO j=j_start, j_end DO i=i_start, i_end - muts(i,j)=mub(i,j)+mu_1(i,j) + MUTS(i,j)=MUB(i,j)+MU_1(i,j) ENDDO DO i=i_start, i_endu - muus(i,j)=0.5*(mub(i,j)+mu_1(i,j)+mub(i-1,j)+mu_1(i-1,j)) + MUUS(i,j)=0.5*(MUB(i,j)+MU_1(i,j)+MUB(i-1,j)+MU_1(i-1,j)) ENDDO ENDDO DO j=j_start, j_endv DO i=i_start, i_end - muvs(i,j)=0.5*(mub(i,j)+mu_1(i,j)+mub(i,j-1)+mu_1(i,j-1)) + MUVS(i,j)=0.5*(MUB(i,j)+MU_1(i,j)+MUB(i,j-1)+MU_1(i,j-1)) ENDDO ENDDO DO j=j_start, j_end DO i=i_start, i_end - mu_save(i,j)=mu_2(i,j) - mu_2(i,j)=mu_1(i,j)-mu_2(i,j) + MU_SAVE(i,j)=MU_2(i,j) + MU_2(i,j)=MU_1(i,j)-MU_2(i,j) ENDDO ENDDO @@ -297,6 +351,8 @@ SUBROUTINE small_step_finish( u_2, u_1, v_2, v_1, w_2, w_1, & t_2, t_1, ph_2, ph_1, ww, ww1, & mu_2, mu_1, & mut, muts, muu, muus, muv, muvs, & + c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f, & u_save, v_save, w_save, & t_save, ph_save, mu_save, & msfux, msfuy, msfvx, msfvy, & @@ -349,6 +405,9 @@ SUBROUTINE small_step_finish( u_2, u_1, v_2, v_1, w_2, w_1, & msfvx, msfvy, & msftx, msfty + REAL, DIMENSION( kms:kme ),INTENT(IN ) :: c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f + ! local stuff @@ -443,7 +502,10 @@ END SUBROUTINE small_step_finish SUBROUTINE calc_p_rho( al, p, ph, & alt, t_2, t_1, c2a, pm1, & - mu, muts, znu, t0, & + mu, mut, & + c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f, & + znu, t0, & rdnw, dnw, smdiv, & non_hydrostatic, step, & ids, ide, jds, jde, kds, kde, & @@ -471,7 +533,7 @@ SUBROUTINE calc_p_rho( al, p, ph, & REAL, DIMENSION(ims:ime, kms:kme, jms:jme),INTENT(INOUT) :: ph, pm1 REAL, DIMENSION(ims:ime, jms:jme) , INTENT(IN ) :: mu, & - muts + mut REAL, DIMENSION(kms:kme) , INTENT(IN ) :: dnw, & rdnw, & @@ -479,6 +541,9 @@ SUBROUTINE calc_p_rho( al, p, ph, & REAL, INTENT(IN ) :: t0, smdiv + REAL, DIMENSION( kms:kme ),INTENT(IN ) :: c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f + LOGICAL, INTENT(IN ) :: non_hydrostatic ! local variables @@ -519,13 +584,13 @@ SUBROUTINE calc_p_rho( al, p, ph, & ! al computation is all dry, so ok with moisture - al(i,k,j)=-1./muts(i,j)*(alt(i,k,j)*mu(i,j) & + al(i,k,j)=-1./Mut(i,j)*(alt(i,k,j)*mu(i,j) & +rdnw(k)*(ph(i,k+1,j)-ph(i,k,j))) ! this is temporally linearized p, no moisture correction needed p(i,k,j)=c2a(i,k,j)*(alt(i,k,j)*(t_2(i,k,j)-mu(i,j)*t_1(i,k,j)) & - /(muts(i,j)*(t0+t_1(i,k,j)))-al (i,k,j)) + /(Mut(i,j)*(t0+t_1(i,k,j)))-al (i,k,j)) ENDDO ENDDO @@ -536,10 +601,14 @@ SUBROUTINE calc_p_rho( al, p, ph, & DO j=j_start, j_end DO k=k_start, k_end DO i=i_start, i_end +#if ! ( HYBRID_COORD==1 ) p(i,k,j)=mu(i,j)*znu(k) - al(i,k,j)=alt(i,k,j)*(t_2(i,k,j)-mu(i,j)*t_1(i,k,j)) & - /(muts(i,j)*(t0+t_1(i,k,j)))-p(i,k,j)/c2a(i,k,j) - ph(i,k+1,j)=ph(i,k,j)-dnw(k)*(muts(i,j)*al (i,k,j) & +#else + p(i,k,j)=MU(i,j)*c3h(k) +#endif + al(i,k,j)=alt(i,k,j)*(t_2(i,k,j)-mu(i,j)*t_1(i,k,j)) & + /(Mut(i,j)*(t0+t_1(i,k,j)))-p(i,k,j)/c2a(i,k,j) + ph(i,k+1,j)=ph(i,k,j)-dnw(k)*(Mut(i,j)*al (i,k,j) & +mu(i,j)*alt(i,k,j)) ENDDO ENDDO @@ -574,7 +643,10 @@ END SUBROUTINE calc_p_rho !---------------------------------------------------------------------- SUBROUTINE calc_coef_w( a,alpha,gamma, & - mut, cqw, & + mut, & + c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f, & + cqw, & rdn, rdnw, c2a, & dts, g, epssm, top_lid, & ids,ide, jds,jde, kds,kde, & ! domain dims @@ -607,12 +679,16 @@ SUBROUTINE calc_coef_w( a,alpha,gamma, & dts, & g + REAL, DIMENSION( kms:kme ),INTENT(IN ) :: c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f + ! Local stack data. REAL, DIMENSION(ims:ime) :: cof REAL :: b, c + REAL :: muthmutf_kk, muthmutf_km1k, muthmutf_kkp1 - INTEGER :: i, j, k, i_start, i_end, j_start, j_end, k_start, k_end + INTEGER :: i, j, k, kk, i_start, i_end, j_start, j_end, k_start, k_end INTEGER :: ij, ijp, ijm, lid_flag ! @@ -635,32 +711,49 @@ SUBROUTINE calc_coef_w( a,alpha,gamma, & outer_j_loop: DO j = j_start, j_end + k = kde-1 DO i = i_start, i_end - cof(i) = (.5*dts*g*(1.+epssm)/mut(i,j))**2 + cof(i) = (.5*dts*g*(1.+epssm))**2 a(i, 2 ,j) = 0. - a(i,kde,j) =-2.*cof(i)*rdnw(kde-1)**2*c2a(i,kde-1,j)*lid_flag +#if ! ( HYBRID_COORD ) + MUTHMUTF_KK = mut(i,j)*mut(i,j) +#endif + a(i,kde,j) =-2.*cof(i)*rdnw(kde-1)**2*c2a(i,kde-1,j)*lid_flag/MUTHMUTF_KK gamma(i,1 ,j) = 0. ENDDO - DO k=3,kde-1 + DO kk=3,kde-1 + k=kk-1 DO i=i_start, i_end - a(i,k,j) = -cqw(i,k,j)*cof(i)*rdn(k)* rdnw(k-1)*c2a(i,k-1,j) +#if ! ( HYBRID_COORD ) + MUTHMUTF_KK = mut(i,j)*mut(i,j) +#endif + a(i,kk,j) = -cqw(i,kk,j)*cof(i)*rdn(kk)* rdnw(kk-1)*c2a(i,kk-1,j)/MUTHMUTF_KK ENDDO ENDDO DO k=2,kde-1 DO i=i_start, i_end - b = 1.+cqw(i,k,j)*cof(i)*rdn(k)*(rdnw(k )*c2a(i,k,j ) & - +rdnw(k-1)*c2a(i,k-1,j)) - c = -cqw(i,k,j)*cof(i)*rdn(k)*rdnw(k )*c2a(i,k,j ) +#if ! ( HYBRID_COORD ) + MUTHMUTF_KK = mut(i,j)*mut(i,j) + MUTHMUTF_KM1K = mut(i,j)*mut(i,j) + MUTHMUTF_KKP1 = mut(i,j)*mut(i,j) +#endif + b = 1.+cqw(i,k,j)*cof(i)*rdn(k)*(rdnw(k )*c2a(i,k, j)/MUTHMUTF_KK & + +rdnw(k-1)*c2a(i,k-1,j)/MUTHMUTF_KM1K ) + c = -cqw(i,k,j)*cof(i)*rdn(k)*rdnw(k )*c2a(i,k,j )/MUTHMUTF_KKP1 alpha(i,k,j) = 1./(b-a(i,k,j)*gamma(i,k-1,j)) gamma(i,k,j) = c*alpha(i,k,j) ENDDO ENDDO + k=kde DO i=i_start, i_end - b = 1.+2.*cof(i)*rdnw(kde-1)**2*c2a(i,kde-1,j) +#if ! ( HYBRID_COORD ) + MUTHMUTF_KM1K = mut(i,j)*mut(i,j) +#endif + b = 1.+2.*cof(i)*rdnw(kde-1)**2*c2a(i,kde-1,j)/MUTHMUTF_KM1K c = 0. alpha(i,kde,j) = 1./(b-a(i,kde,j)*gamma(i,kde-1,j)) gamma(i,kde,j) = c*alpha(i,kde,j) @@ -676,6 +769,8 @@ SUBROUTINE advance_uv ( u, ru_tend, v, rv_tend, & p, pb, & ph, php, alt, al, mu, & muu, cqu, muv, cqv, mudf, & + c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f, & msfux, msfuy, msfvx, & msfvx_inv, msfvy, & rdx, rdy, dts, & @@ -744,6 +839,9 @@ SUBROUTINE advance_uv ( u, ru_tend, v, rv_tend, & cf2, & cf3, & emdiv + + REAL, DIMENSION( kms:kme ),INTENT(IN ) :: c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f ! Local 3d array from the stack (note tile size) @@ -861,7 +959,7 @@ SUBROUTINE advance_uv ( u, ru_tend, v, rv_tend, & ENDDO DO i = i_start_up, i_end_up - mudf_xy(i)= -emdiv*dx*(mudf(i,j)-mudf(i-1,j))/msfuy(i,j) + MUDF_XY(i)= -emdiv*dx*(MUDF(i,j)-MUDF(i-1,j))/msfuy(i,j) ENDDO DO k = k_start, k_end @@ -950,7 +1048,7 @@ SUBROUTINE advance_uv ( u, ru_tend, v, rv_tend, & ENDDO DO i = i_start, i_end - mudf_xy(i)= -emdiv*dy*(mudf(i,j)-mudf(i,j-1))*msfvx_inv(i,j) + MUDF_XY(i)= -emdiv*dy*(MUDF(i,j)-MUDF(i,j-1))*msfvx_inv(i,j) ENDDO IF ( ( j >= j_start_vp) & @@ -1060,8 +1158,10 @@ END SUBROUTINE advance_uv !--------------------------------------------------------------------- SUBROUTINE advance_mu_t( ww, ww_1, u, u_1, v, v_1, & - mu, mut, muave, muts, muu, muv, & - mudf, uam, vam, wwam, t, t_1, & + mu, mut, muave, muts, muu, muv, mudf,& + c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f, & + uam, vam, wwam, t, t_1, & t_ave, ft, mu_tend, & rdx, rdy, dts, epssm, & dnw, fnm, fnp, rdnw, & @@ -1132,12 +1232,15 @@ SUBROUTINE advance_mu_t( ww, ww_1, u, u_1, v, v_1, & dts, & epssm + REAL, DIMENSION( kms:kme ),INTENT(IN ) :: c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f + ! Local arrays from the stack (note tile size) REAL, DIMENSION (its:ite, kts:kte) :: wdtn, dvdxi REAL, DIMENSION (its:ite) :: dmdt - INTEGER :: i,j,k, i_start, i_end, j_start, j_end, k_start, k_end + INTEGER :: i, j, k, kk, i_start, i_end, j_start, j_end, k_start, k_end INTEGER :: i_endu, j_endv REAL :: acc @@ -1176,7 +1279,7 @@ SUBROUTINE advance_mu_t( ww, ww_1, u, u_1, v, v_1, & DO j = j_start, j_end DO i=i_start, i_end - dmdt(i) = 0. + DMDT(i) = 0. ENDDO ! NOTE: mu is not coupled with the map scale factor. ! ww (omega) IS coupled with the map scale factor. @@ -1208,20 +1311,21 @@ SUBROUTINE advance_mu_t( ww, ww_1, u, u_1, v, v_1, & -(v(i,k,j )+muv(i,j )*v_1(i,k,j )*msfvx_inv(i,j )) ) & +rdx*( (u(i+1,k,j)+muu(i+1,j)*u_1(i+1,k,j)/msfuy(i+1,j)) & -(u(i,k,j )+muu(i ,j)*u_1(i,k,j )/msfuy(i ,j)) )) - dmdt(i) = dmdt(i) + dnw(k)*dvdxi(i,k) + DMDT(i) = DMDT(i) + dnw(k)*dvdxi(i,k) ENDDO ENDDO DO i=i_start, i_end - muave(i,j) = mu(i,j) - mu(i,j) = mu(i,j)+dts*(dmdt(i)+mu_tend(i,j)) - mudf(i,j) = (dmdt(i)+mu_tend(i,j)) ! save tendency for div damp filter - muts(i,j) = mut(i,j)+mu(i,j) - muave(i,j) =.5*((1.+epssm)*mu(i,j)+(1.-epssm)*muave(i,j)) + MUAVE(i,j) = MU(i,j) + MU(i,j) = MU(i,j)+dts*(DMDT(i)+MU_TEND(i,j)) + MUDF(i,j) = (DMDT(i)+MU_TEND(i,j)) ! save tendency for div damp filter + MUTS(i,j) = MUT(i,j)+MU(i,j) + MUAVE(i,j) =.5*((1.+epssm)*MU(i,j)+(1.-epssm)*MUAVE(i,j)) ENDDO - DO k=2,k_end + DO kk=2,k_end + k=kk-1 DO i=i_start, i_end - ww(i,k,j)=ww(i,k-1,j)-dnw(k-1)*(dmdt(i)+dvdxi(i,k-1)+mu_tend(i,j))/msfty(i,j) + ww(i,kk,j)=ww(i,kk-1,j)-dnw(kk-1)*(dmdt(i)+dvdxi(i,kk-1)+mu_tend(i,j))/msfty(i,j) ENDDO END DO @@ -1306,6 +1410,8 @@ END SUBROUTINE advance_mu_t SUBROUTINE advance_w( w, rw_tend, ww, w_save, u, v, & mu1, mut, muave, muts, & + c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f, & t_2ave, t_2, t_1, & ph, ph_1, phb, ph_tend, & ht, c2a, cqw, alt, alb, & @@ -1386,6 +1492,9 @@ SUBROUTINE advance_w( w, rw_tend, ww, w_save, u, v, & t0, & epssm + REAL, DIMENSION( kms:kme ),INTENT(IN ) :: c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f + ! Stack based 3d data, tile size. REAL, DIMENSION( its:ite ) :: mut_inv, msft_inv @@ -1394,6 +1503,7 @@ SUBROUTINE advance_w( w, rw_tend, ww, w_save, u, v, & REAL, DIMENSION (kts:kte) :: dampwt real :: htop,hbot,hdepth,hk real :: pi,dampmag + REAL :: muthk, muthkm1 ! ! @@ -1453,7 +1563,6 @@ SUBROUTINE advance_w( w, rw_tend, ww, w_save, u, v, & j_loop_w: DO j = j_start, j_end DO i=i_start, i_end - mut_inv(i) = 1./mut(i,j) msft_inv(i) = 1./msfty(i,j) ENDDO @@ -1461,8 +1570,8 @@ SUBROUTINE advance_w( w, rw_tend, ww, w_save, u, v, & DO i=i_start, i_end t_2ave(i,k,j)=.5*((1.+epssm)*t_2(i,k,j) & +(1.-epssm)*t_2ave(i,k,j)) - t_2ave(i,k,j)=(t_2ave(i,k,j) + muave(i,j)*t0) & - /(muts(i,j)*(t0+t_1(i,k,j))) + t_2ave(i,k,j)=(t_2ave(i,k,j) + Muave(i,j)*t0) & + /(Muts(i,j)*(t0+t_1(i,k,j))) wdwn(i,k+1)=.5*(ww(i,k+1,j)+ww(i,k,j))*rdnw(k) & *(ph_1(i,k+1,j)-ph_1(i,k,j)+phb(i,k+1,j)-phb(i,k,j)) rhs(i,k+1) = dts*(ph_tend(i,k+1,j) + .5*g*(1.-epssm)*w(i,k+1,j)) @@ -1492,7 +1601,7 @@ SUBROUTINE advance_w( w, rw_tend, ww, w_save, u, v, & ! partial d phi/dz] DO k=2,k_end+1 DO i=i_start, i_end - rhs(i,k) = ph(i,k,j) + msfty(i,j)*rhs(i,k)*mut_inv(i) + rhs(i,k) = ph(i,k,j) + msfty(i,j)*rhs(i,k)/mut(i,j) if(top_lid .and. k.eq.k_end+1)rhs(i,k)=0. ENDDO ENDDO @@ -1534,13 +1643,18 @@ SUBROUTINE advance_w( w, rw_tend, ww, w_save, u, v, & ! above surface, begin by adding delta t * previous (coupled) w tendency DO k=2,k_end DO i=i_start, i_end +#if ! ( HYBRID_COORD==1 ) + MUTHK = mut(i,j) + MUTHKM1 = mut(i,j) +#endif + w(i,k,j)=w(i,k,j)+dts*rw_tend(i,k,j) & + msft_inv(i)*cqw(i,k,j)*( & - +.5*dts*g*mut_inv(i)*rdn(k)* & - (c2a(i,k ,j)*rdnw(k ) & + +.5*dts*g*rdn(k)* & + (c2a(i,k ,j)*rdnw(k )/MUTHK & *((1.+epssm)*(rhs(i,k+1 )-rhs(i,k )) & +(1.-epssm)*(ph(i,k+1,j)-ph(i,k ,j))) & - -c2a(i,k-1,j)*rdnw(k-1) & + -c2a(i,k-1,j)*rdnw(k-1)/MUTHKM1 & *((1.+epssm)*(rhs(i,k )-rhs(i,k-1 )) & +(1.-epssm)*(ph(i,k ,j)-ph(i,k-1,j))))) & @@ -1554,9 +1668,12 @@ SUBROUTINE advance_w( w, rw_tend, ww, w_save, u, v, & K=k_end+1 DO i=i_start, i_end +#if ! ( HYBRID_COORD==1 ) + MUTHKM1 = mut(i,j) +#endif w(i,k,j)=w(i,k,j)+dts*rw_tend(i,k,j) & +msft_inv(i)*( & - -.5*dts*g*mut_inv(i)*rdnw(k-1)**2*2.*c2a(i,k-1,j) & + -.5*dts*g/MUTHKM1*rdnw(k-1)**2*2.*c2a(i,k-1,j) & *((1.+epssm)*(rhs(i,k )-rhs(i,k-1 )) & +(1.-epssm)*(ph(i,k,j)-ph(i,k-1,j))) & -dts*g*(2.*rdnw(k-1)* & @@ -1608,6 +1725,8 @@ END SUBROUTINE advance_w SUBROUTINE sumflux ( ru, rv, ww, & u_lin, v_lin, ww_lin, & muu, muv, & + c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f, & ru_m, rv_m, ww_m, epssm, & msfux, msfuy, msfvx, msfvx_inv, msfvy, & iteration , number_of_small_timesteps, & @@ -1641,6 +1760,9 @@ SUBROUTINE sumflux ( ru, rv, ww, & msfux, msfuy, & msfvx, msfvy, msfvx_inv + REAL, DIMENSION( kms:kme ),INTENT(IN ) :: c1h, c2h, c1f, c2f, & + c3h, c4h, c3f, c4f + INTEGER :: mini, minj, mink diff --git a/wrfv2_fire/dyn_em/module_stoch.F b/wrfv2_fire/dyn_em/module_stoch.F index 50b87123..80dca70a 100644 --- a/wrfv2_fire/dyn_em/module_stoch.F +++ b/wrfv2_fire/dyn_em/module_stoch.F @@ -1,3 +1,11 @@ +#if ( HYBRID_COORD==1 ) +# define mu(...) (c1h(k)*XXPCXX(__VA_ARGS__)) +# define XXPCXX(...) mu(__VA_ARGS__) + +# define mub(...) (c1h(k)*XXPCBXX(__VA_ARGS__)+c2h(k)) +# define XXPCBXX(...) mub(__VA_ARGS__) +#endif + module module_stoch !*********************************************************************** ! @@ -91,18 +99,20 @@ module module_stoch contains !======================================================================= ! ------------------------------------------------------------------ +!!************** INITIALIZE STOCHASTIC ROUTINES ***************************** +! ------------------------------------------------------------------ ! This subroutine drives the initialization of the stochastic schemes - SUBROUTINE INITIALIZE_STOCH (grid, config_flags, & - first_trip_for_this_domain, & - ips, ipe, jps, jpe, kps, kpe, & - ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - its, ite, jts, jte, kts, kte, & + SUBROUTINE INITIALIZE_STOCH (grid, config_flags, & + first_trip_for_this_domain, & + ips, ipe, jps, jpe, kps, kpe, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte, & imsx, imex, jmsx, jmex, kmsx, kmex, & ipsx, ipex, jpsx, jpex, kpsx, kpex, & imsy, imey, jmsy, jmey, kmsy, kmey, & - ipsy, ipey, jpsy, jpey, kpsy, kpey ) + ipsy, ipey, jpsy, jpey, kpsy, kpey ) USE module_configure @@ -117,9 +127,9 @@ SUBROUTINE INITIALIZE_STOCH (grid, config_flags, & TYPE (grid_config_rec_type) :: config_flags TYPE ( domain ), INTENT(INOUT) :: grid - INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & - ims, ime, jms, jme, kms, kme, & - ips, ipe, jps, jpe, kps, kpe, & + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + ips, ipe, jps, jpe, kps, kpe, & its, ite, jts, jte, kts, kte INTEGER , INTENT(IN) :: imsx,imex,jmsx,jmex,kmsx,kmex, & ipsx,ipex,jpsx,jpex,kpsx,kpex, & @@ -135,7 +145,8 @@ SUBROUTINE INITIALIZE_STOCH (grid, config_flags, & END IF IF ((( grid%id == 1) .AND. (.NOT. grid%did_stoch)) .AND. & - (( grid%skebs_on== 1) .OR.( grid%sppt_on== 1) .OR. ( grid%rand_perturb_on== 1))) THEN + (( grid%skebs_on== 1) .OR.( grid%sppt_on== 1) .OR. ( grid%rand_perturb_on== 1) .OR. & + ( grid%spp_conv== 1) .OR. ( grid%spp_pbl== 1) .OR. ( grid%spp_lsm== 1)) ) THEN grid%did_stoch = .TRUE. @@ -143,7 +154,7 @@ SUBROUTINE INITIALIZE_STOCH (grid, config_flags, & ! Initialize SKEBS ! Initialize streamfunction (1) - if (.not.config_flags%restart) then + if ((.not.config_flags%restart) .or. (.not.config_flags%hrrr_cycling)) then call rand_seed (config_flags, grid%ISEED_SKEBS, grid%iseedarr_skebs , kms, kme) endif call SETUP_RAND_PERTURB('W', & @@ -185,7 +196,7 @@ SUBROUTINE INITIALIZE_STOCH (grid, config_flags, & IF (grid%sppt_on==1) then ! Initialize SPPT (3) - if (.not.config_flags%restart) then ! set random number seed (else iseedarray is read in from restart files) + if ((.not.config_flags%restart) .or. (.not.config_flags%hrrr_cycling)) then call rand_seed (config_flags, grid%ISEED_SPPT, grid%iseedarr_sppt , kms, kme) endif call SETUP_RAND_PERTURB('P', & @@ -209,7 +220,7 @@ SUBROUTINE INITIALIZE_STOCH (grid, config_flags, & ! Initialize RAND_PERTURB (4) IF (grid%rand_perturb_on==1) then - if (.not.config_flags%restart) then ! set random number seed (else iseedarray is read in from restart files) + if ((.not.config_flags%restart) .or. (.not.config_flags%hrrr_cycling)) then call rand_seed (config_flags, grid%ISEED_RAND_PERT, grid%iseedarr_rand_pert , kms, kme) endif call SETUP_RAND_PERTURB('R', & @@ -248,18 +259,89 @@ SUBROUTINE INITIALIZE_STOCH (grid, config_flags, & config_flags%restart, grid%iseedarr_rand_pert, & grid%DX,grid%DY,grid%rand_pert_vertstruc, & grid%RAND_PERT, & + grid%gridpt_stddev_rand_pert, & + grid%lengthscale_rand_pert, & grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT ) enddo ENDIF !rand_perturb_on ENDIF - ENDIF ! skebs or sppt or rand_perturb +! Initialize Stochastic Parameter Perturbations to convection scheme + IF (grid%spp_conv==1) then + if (.not.config_flags%restart) then ! set random number seed (else iseedarray is read in from restart files) + call rand_seed (config_flags, grid%iseed_spp_conv, grid%iseedarr_spp_conv , kms, kme) + endif + call SETUP_RAND_PERTURB('S', & + grid%vertstruc_spp_conv,config_flags%restart, & + grid%SP_AMP2, & + grid%SPFORCC2,grid%SPFORCS2,grid%ALPH_RAND2, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT, & + grid%KMINFORCT,grid%KMAXFORCT, & + grid%LMINFORCT,grid%LMAXFORCT, & + grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%time_step,grid%DX,grid%DY, & + grid%gridpt_stddev_spp_conv, & + grid%lengthscale_spp_conv, & + grid%timescale_spp_conv, & + grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI, & + grid%REXPONENT_PSI, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF +! Initialize Stochastic Parameter Peturbations (SPP) to PBL scheme + IF (grid%spp_pbl==1) then + if (.not.config_flags%restart) then ! set random number seed (else iseedarray is read in from restart files) + call rand_seed (config_flags, grid%iseed_spp_pbl, grid%iseedarr_spp_pbl , kms, kme) + endif + call SETUP_RAND_PERTURB('Q', & + grid%vertstruc_spp_pbl,config_flags%restart, & + grid%SP_AMP3, & + grid%SPFORCC3,grid%SPFORCS3,grid%ALPH_RAND3, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT, & + grid%KMINFORCT,grid%KMAXFORCT, & + grid%LMINFORCT,grid%LMAXFORCT, & + grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%time_step,grid%DX,grid%DY, & + grid%gridpt_stddev_spp_pbl, & + grid%lengthscale_spp_pbl, & + grid%timescale_spp_pbl, & + grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI, & + grid%REXPONENT_PSI, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF +! Initialize Stochastic Parameter Peturbations (SPP) to LSM scheme + IF (grid%spp_lsm==1) then + if (.not.config_flags%restart) then ! set random number seed (else iseedarray is read in from restart files) + call rand_seed (config_flags, grid%iseed_spp_lsm, grid%iseedarr_spp_lsm , kms, kme) + endif + call SETUP_RAND_PERTURB('O', & + grid%vertstruc_spp_lsm,config_flags%restart, & + grid%SP_AMP4, & + grid%SPFORCC4,grid%SPFORCS4,grid%ALPH_RAND4, & + grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT, & + grid%KMINFORCT,grid%KMAXFORCT, & + grid%LMINFORCT,grid%LMAXFORCT, & + grid%KMAXFORCTH,grid%LMAXFORCTH, & + grid%time_step,grid%DX,grid%DY, & + grid%gridpt_stddev_spp_lsm, & + grid%lengthscale_spp_lsm, & + grid%timescale_spp_lsm, & + grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI, & + grid%REXPONENT_PSI, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) + ENDIF + + ENDIF ! skebs or sppt or rand_perturb or spp - END SUBROUTINE INITIALIZE_STOCH + END SUBROUTINE INITIALIZE_STOCH + + ! --- END SETUP STOCHASTIC PERTURBATION SCHEMES ---------- -! ------------------------------------------------------------------ -!!******** INITIALIZE STOCHASTIC SCHEMES **************************** -! ------------------------------------------------------------------ subroutine SETUP_RAND_PERTURB( variable_in,& skebs_vertstruc,restart, & @@ -313,7 +395,7 @@ subroutine SETUP_RAND_PERTURB( variable_in,& KMAX=(jde-jds)+1 !NLAT LMAX=(ide-ids)+1 !NLON RY= KMAX*DY - RX= LMAX*DY + RX= LMAX*DX LENSAV= 4*(KMAX+LMAX)+INT(LOG(REAL(KMAX))) + INT(LOG(REAL(LMAX))) + 8 ! --------- ALLOCATE FIELDS FOR FFTPACK---------------------------- @@ -395,7 +477,7 @@ subroutine SETUP_RAND_PERTURB( variable_in,& WRITE(*,'('' =============================================='')') endif - IF ((variable == 'P') .or. (variable == 'R')) then + IF ((variable == 'P') .or. (variable == 'R') .or. (variable == 'S') .or. (variable == 'Q') .or. (variable == 'O')) then kappat= L_rand_perturb**2 ! L^2= kappa*T, where L is a length scale in m; set to for L=100km phi = exp (-float(itime_step)/tau_rand_perturb) alph = 1.-phi @@ -408,8 +490,7 @@ subroutine SETUP_RAND_PERTURB( variable_in,& WRITE(*,'('' '')') WRITE(*,'('' =============================================='')') WRITE(*,'('' >> Initializing Stochastically Perturbed Physics Tendency scheme << '')') - WRITE(*,'('' sppt_vertstruc '',I10)') skebs_vertstruc - WRITE(*,'('' Time step: itime_step='',I10)') itime_step + WRITE(*,'('' sppt_vertstruc '',I10)') skebs_vertstruc WRITE(*,'('' Decorrelation time of noise, Tau ='',E12.5)') tau_rand_perturb WRITE(*,'('' Autoregressive parameter Phi ='',E12.5)') phi WRITE(*,'('' Length Scale L'',E12.5)') l_rand_perturb @@ -423,17 +504,52 @@ subroutine SETUP_RAND_PERTURB( variable_in,& if (variable == 'R') then WRITE(*,'('' '')') WRITE(*,'('' =============================================='')') - WRITE(*,'('' >> Initializing random pertubations << '')') - WRITE(*,'('' rand_pert_vertstruc '',I10)') skebs_vertstruc - WRITE(*,'('' Time step: itime_step='',I10)') itime_step + WRITE(*,'('' >> Initializing random perturbations << '')') + WRITE(*,'('' rand_pert_vertstruc '',I10)') skebs_vertstruc WRITE(*,'('' Decorrelation time of noise, Tau ='',E12.5)') tau_rand_perturb WRITE(*,'('' Autoregressive parameter Phi ='',E12.5)') phi WRITE(*,'('' Length Scale L'',E12.5)') l_rand_perturb WRITE(*,'('' Variance in gridpoint space'',E12.5)') gridpt_stddev_rand_perturb WRITE(*,'('' =============================================='')') - endif ! variable - endif !is print + endif ! variable + if (variable == 'S') then + WRITE(*,'('' '')') + WRITE(*,'('' =============================================='')') + WRITE(*,'('' >> Initializing stochastic parameter perturbations for convection<< '')') + WRITE(*,'('' rand_pert_vertstruc2 '',I10)') skebs_vertstruc + WRITE(*,'('' Decorrelation time of noise, Tau ='',E12.5)') tau_rand_perturb + WRITE(*,'('' Autoregressive parameter Phi ='',E12.5)') phi + WRITE(*,'('' Length Scale L'',E12.5)') l_rand_perturb + WRITE(*,'('' Variance in gridpoint space'',E12.5)') gridpt_stddev_rand_perturb + WRITE(*,'('' =============================================='')') + endif ! variable + + if (variable == 'Q') then + WRITE(*,'('' '')') + WRITE(*,'('' =============================================='')') + WRITE(*,'('' >> Initializing stochastic parameter perturbations for PBL<< '')') + WRITE(*,'('' rand_pert_vertstruc3 '',I10)') skebs_vertstruc + WRITE(*,'('' Decorrelation time of noise, Tau ='',E12.5)') tau_rand_perturb + WRITE(*,'('' Autoregressive parameter Phi ='',E12.5)') phi + WRITE(*,'('' Length Scale L'',E12.5)') l_rand_perturb + WRITE(*,'('' Variance in gridpoint space'',E12.5)') gridpt_stddev_rand_perturb + WRITE(*,'('' =============================================='')') + endif ! variable + + if (variable == 'O') then + WRITE(*,'('' '')') + WRITE(*,'('' =============================================='')') + WRITE(*,'('' >> Initializing stochastic parameter perturbations for LSM<< '')') + WRITE(*,'('' rand_pert_vertstruc4 '',I10)') skebs_vertstruc + WRITE(*,'('' Decorrelation time of noise, Tau ='',E12.5)') tau_rand_perturb + WRITE(*,'('' Autoregressive parameter Phi ='',E12.5)') phi + WRITE(*,'('' Length Scale L'',E12.5)') l_rand_perturb + WRITE(*,'('' Variance in gridpoint space'',E12.5)') gridpt_stddev_rand_perturb + WRITE(*,'('' =============================================='')') + endif ! variable + + endif !is print ! -------------------------------------------------------------------------------------- ! Compute Normalization constants ! -------------------------------------------------------------------------------------- @@ -445,8 +561,8 @@ subroutine SETUP_RAND_PERTURB( variable_in,& DO IL=ids-1,ide if (((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((KMAXFORCT+0.5)/RX)).and.& (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((KMINFORCT-0.5)/RX))) .or. & - ((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((LMAXFORCT+0.5)/RX)).and.& - (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((LMINFORCT-0.5)/RX))))then + ((sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).lt.((LMAXFORCT+0.5)/RY)).and.& + (sqrt((IK/RY*IK/RY)+(IL/RX*IL/RX)).ge.((LMINFORCT-0.5)/RY))))then if ((IK>0).or.(IL>0)) then if (variable == 'W') then ZCHI(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT/2.) ! SKEBS :U @@ -454,7 +570,7 @@ subroutine SETUP_RAND_PERTURB( variable_in,& else if (variable == 'T') then ZCHI(IL+1,IK+1)=((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT/2.) ! SKEBS :T ZGAMMAN= ZGAMMAN + ((IK/RY*IK/RY)+(IL/RX*IL/RX))**(REXPONENT) - else if ((variable == 'P') .or. (variable == 'R')) then + else if ((variable == 'P') .or. (variable == 'R') .or. (variable == 'S') .or. (variable == 'O') .or. (variable == 'Q ')) then ZCHI(IL+1,IK+1)=exp( -2*RPI**2*kappat*((IK/RY*IK/RY)+(IL/RX*IL/RX)) ) !SPPT ZGAMMAN= ZGAMMAN + exp( -4*RPI**2*kappat*((IK/RY*IK/RY)+(IL/RX*IL/RX)) ) !SPPT endif @@ -467,7 +583,7 @@ subroutine SETUP_RAND_PERTURB( variable_in,& ZCONSTF0=SQRT(ALPH*TOT_BACKSCAT/(float(itime_step)*ZSIGMA2*ZGAMMAN))/(2*RPI) elseif (variable == 'T') then ZCONSTF0=SQRT(T0*ALPH*TOT_BACKSCAT/(float(itime_step)*cp*ZSIGMA2*ZGAMMAN)) - elseif ((variable == 'P') .or. (variable == 'R')) then + elseif ((variable == 'P') .or. (variable == 'R') .or. (variable == 'S') .or. (variable == 'O') .or. (variable == 'Q ')) then ZCONSTF0= gridpt_stddev_rand_perturb*sqrt((1.-phi**2)/(2.*ZGAMMAN)) endif @@ -656,7 +772,7 @@ END subroutine UPDATE_STOCH ! ------------------------------------------------------------------ SUBROUTINE UPDATE_STOCH_TEN(ru_tendf,rv_tendf,t_tendf, & ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch,& - mu,mub, & + mu,mub,c1h,c2h, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte, & @@ -675,6 +791,7 @@ SUBROUTINE UPDATE_STOCH_TEN(ru_tendf,rv_tendf,t_tendf, & ru_tendf_stoch,rv_tendf_stoch,rt_tendf_stoch REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: mu,mub + REAL , DIMENSION(kms:kme) , INTENT(IN) :: c1h,c2h INTEGER :: I,J,K,kh REAL :: dt,xm @@ -808,7 +925,7 @@ SUBROUTINE RAND_PERT_UPDATE (grid, variable_in, & kpe_stoch,kde_stoch,kme_stoch,kte_stoch, & restart,iseedarr, & DX,DY,skebs_vertstruc, & - RAND_PERT, & + RAND_PERT,thresh_fact,gridpt_stddev, & VERTSTRUCC,VERTSTRUCS,VERTAMP ) @@ -835,7 +952,7 @@ SUBROUTINE RAND_PERT_UPDATE (grid, variable_in, & ipsy,ipey,jpsy,jpey,kpsy,kpey INTEGER :: kpe_stoch,kde_stoch,kme_stoch,kte_stoch - REAL , INTENT(IN) :: ALPH_RAND,dx,dy + REAL , INTENT(IN) :: ALPH_RAND,dx,dy,thresh_fact,gridpt_stddev INTEGER , INTENT(IN) :: skebs_vertstruc CHARACTER, INTENT(IN) :: variable_in ! T, U, V ! T ! random field, T @@ -854,6 +971,7 @@ SUBROUTINE RAND_PERT_UPDATE (grid, variable_in, & INTEGER :: IK,IL,ILEV,NLON,NLAT,IJ,I,J,K INTEGER :: gridsp32y,gridsm32y,gridsp32x,gridsm32x,gridsp32 ,gridsm32 INTEGER :: gridep32y,gridem32y,gridep32x,gridem32x,gridep32 ,gridem32 + REAL :: thresh REAL, DIMENSION(ims:ime,kms:kme_stoch, jms:jme) :: RAND_REAL, RAND_IMAG LOGICAL :: RESTART @@ -1027,14 +1145,15 @@ SUBROUTINE RAND_PERT_UPDATE (grid, variable_in, & #endif + thresh=thresh_fact*gridpt_stddev !$OMP PARALLEL DO & !$OMP PRIVATE ( ij ) DO ij = 1 , grid%num_tiles - RAND_PERT=0.0 DO k=kts,min(kte,grid%num_stoch_levels) DO I=grid%i_start(ij), grid%i_end(ij) DO j=grid%j_start(ij), grid%j_end(ij) RAND_PERT(I,K,J)=grid%RAND_REAL(I,K,J) + RAND_PERT(I,K,J)=MAX(MIN(grid%RAND_REAL(I,K,J),thresh),-1.0*thresh) ENDDO ENDDO ENDDO @@ -1230,9 +1349,9 @@ SUBROUTINE rand_seed (config_flags, iseed1, iseedarr, kms, kme) iseedarr=0.0 do i = kms,kme-3,4 iseedarr(i )= iseed1+config_flags%nens*1000000 - iseedarr(i+1)= mod(fctime+iseed1*1000000,19211*one_big) - iseedarr(i+2)= mod(fctime+iseed1*1000000,71209*one_big) - iseedarr(i+3)= mod(fctime+iseed1*1000000,11279*one_big) + iseedarr(i+1)= mod(fctime+iseed1*config_flags%nens*1000000,19211*one_big) + iseedarr(i+2)= mod(fctime+iseed1*config_flags%nens*1000000,71209*one_big) + iseedarr(i+3)= mod(fctime+iseed1*config_flags%nens*1000000,11279*one_big) enddo end SUBROUTINE rand_seed diff --git a/wrfv2_fire/dyn_em/nest_init_utils.F b/wrfv2_fire/dyn_em/nest_init_utils.F index 774b630a..661bc4f1 100644 --- a/wrfv2_fire/dyn_em/nest_init_utils.F +++ b/wrfv2_fire/dyn_em/nest_init_utils.F @@ -1,3 +1,6 @@ +! careful adding any HYBRID_COORD stuff in here, adjust_tempqv has +! c3 and c4 to compute pressure with two reference pressures + SUBROUTINE init_domain_constants_em ( parent , nest ) USE module_domain, ONLY : domain IMPLICIT NONE @@ -98,19 +101,31 @@ SUBROUTINE init_domain_constants_em ( parent , nest ) ! 1D constants (Z) - nest%fnm = parent%fnm - nest%fnp = parent%fnp - nest%rdnw = parent%rdnw - nest%rdn = parent%rdn - nest%dnw = parent%dnw - nest%dn = parent%dn - nest%znu = parent%znu - nest%znw = parent%znw - nest%t_base = parent%t_base - nest%u_base = parent%u_base - nest%v_base = parent%v_base - nest%qv_base = parent%qv_base - nest%z_base = parent%z_base +!DAVE - maybe test if vert_nest instead +! IF ( parent%e_vert .EQ. nest%e_vert ) THEN + nest%fnm(1:parent%e_vert) = parent%fnm(1:parent%e_vert) + nest%fnp(1:parent%e_vert) = parent%fnp(1:parent%e_vert) + nest%rdnw(1:parent%e_vert) = parent%rdnw(1:parent%e_vert) + nest%rdn(1:parent%e_vert) = parent%rdn(1:parent%e_vert) + nest%dnw(1:parent%e_vert) = parent%dnw(1:parent%e_vert) + nest%dn(1:parent%e_vert) = parent%dn(1:parent%e_vert) + nest%znu(1:parent%e_vert) = parent%znu(1:parent%e_vert) + nest%znw(1:parent%e_vert) = parent%znw(1:parent%e_vert) + nest%t_base(1:parent%e_vert) = parent%t_base(1:parent%e_vert) + nest%u_base(1:parent%e_vert) = parent%u_base(1:parent%e_vert) + nest%v_base(1:parent%e_vert) = parent%v_base(1:parent%e_vert) + nest%qv_base(1:parent%e_vert) = parent%qv_base(1:parent%e_vert) + nest%z_base(1:parent%e_vert) = parent%z_base(1:parent%e_vert) + nest%c1h(1:parent%e_vert) = parent%c1h(1:parent%e_vert) + nest%c2h(1:parent%e_vert) = parent%c2h(1:parent%e_vert) + nest%c3h(1:parent%e_vert) = parent%c3h(1:parent%e_vert) + nest%c4h(1:parent%e_vert) = parent%c4h(1:parent%e_vert) + nest%c1f(1:parent%e_vert) = parent%c1f(1:parent%e_vert) + nest%c2f(1:parent%e_vert) = parent%c2f(1:parent%e_vert) + nest%c3f(1:parent%e_vert) = parent%c3f(1:parent%e_vert) + nest%c4f(1:parent%e_vert) = parent%c4f(1:parent%e_vert) +! END IF + nest%dzs = parent%dzs nest%zs = parent%zs @@ -755,7 +770,7 @@ SUBROUTINE copy_3d_field ( ter_interpolated , ter_input , & END SUBROUTINE copy_3d_field -SUBROUTINE adjust_tempqv ( mub, save_mub, znw, p_top, & +SUBROUTINE adjust_tempqv ( mub, save_mub, c3, c4, znw, p_top, & th, pp, qv, & ids , ide , jds , jde , kds , kde , & ims , ime , jms , jme , kms , kme , & @@ -777,6 +792,7 @@ SUBROUTINE adjust_tempqv ( mub, save_mub, znw, p_top, & ips , ipe , jps , jpe , kps , kpe REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: mub, save_mub REAL , DIMENSION(kms:kme) , INTENT(IN) :: znw + REAL , DIMENSION(kms:kme) , INTENT(IN) :: c3, c4 REAL , DIMENSION(ims:ime,kms:kme,jms:jme) , INTENT(INOUT) :: th, pp, qv REAL , DIMENSION(ims:ime,kms:kme,jms:jme) :: p_old, p_new, rh @@ -791,7 +807,11 @@ SUBROUTINE adjust_tempqv ( mub, save_mub, znw, p_top, & DO j = jps , MIN(jpe, jde-1) DO k = kps , kpe-1 DO i = ips , MIN(ipe, ide-1) +#if !( HYBRID_COORD==1 ) p_old(i,k,j) = 0.5*(znw(k+1)+znw(k))*save_mub(i,j) + p_top + pp(i,k,j) +#elif ( HYBRID_COORD==1 ) + p_old(i,k,j) = c4(k) + c3(k)*save_mub(i,j) + p_top + pp(i,k,j) +#endif tc = (th(i,k,j)+300.)*(p_old(i,k,j)/1.e5)**(2./7.) - 273.15 es = 610.78*exp(17.0809*tc/(234.175+tc)) e = qv(i,k,j)*p_old(i,k,j)/(0.622+qv(i,k,j)) @@ -804,7 +824,11 @@ SUBROUTINE adjust_tempqv ( mub, save_mub, znw, p_top, & DO j = jps , MIN(jpe, jde-1) DO k = kps , kpe-1 DO i = ips , MIN(ipe, ide-1) +#if !( HYBRID_COORD==1 ) p_new(i,k,j) = 0.5*(znw(k+1)+znw(k))*mub(i,j) + p_top + pp(i,k,j) +#elif ( HYBRID_COORD==1 ) + p_new(i,k,j) = c4(k) + c3(k)*mub(i,j) + p_top + pp(i,k,j) +#endif ! 2*(g/cp-6.5e-3)*R_dry/g = -191.86e-3 dth1 = -191.86e-3*(th(i,k,j)+300.)/(p_new(i,k,j)+p_old(i,k,j))*(p_new(i,k,j)-p_old(i,k,j)) dth = -191.86e-3*(th(i,k,j)+0.5*dth1+300.)/(p_new(i,k,j)+p_old(i,k,j))*(p_new(i,k,j)-p_old(i,k,j)) diff --git a/wrfv2_fire/dyn_em/solve_em.F b/wrfv2_fire/dyn_em/solve_em.F index 4f650275..a386590a 100644 --- a/wrfv2_fire/dyn_em/solve_em.F +++ b/wrfv2_fire/dyn_em/solve_em.F @@ -41,10 +41,11 @@ SUBROUTINE solve_em ( grid , config_flags & ,period_bdy_em_d_sub,period_bdy_em_e_sub,period_bdy_em_moist2_sub & ,period_bdy_em_moist_old_sub,period_bdy_em_moist_sub & ,period_bdy_em_scalar2_sub,period_bdy_em_scalar_old_sub & - ,period_bdy_em_scalar_sub,period_bdy_em_tke_old_sub & + ,period_bdy_em_scalar_sub,period_bdy_em_tke_old_sub, period_bdy_em_tke_sub & ,period_bdy_em_tracer2_sub,period_bdy_em_tracer_old_sub & ,period_bdy_em_tracer_sub,period_em_da_sub,period_em_hydro_uv_sub & - ,halo_em_f_sub,halo_em_init_4_sub,halo_em_thetam_sub,period_em_thetam_sub + ,period_em_f_sub,period_em_g_sub & + ,halo_em_f_1_sub,halo_em_init_4_sub,halo_em_thetam_sub,period_em_thetam_sub #endif USE module_utility ! Mediation layer modules @@ -169,7 +170,7 @@ SUBROUTINE solve_em ( grid , config_flags & LOGICAL :: fill_w_flag ! variables for flux-averaging code 20091223 - CHARACTER*256 :: message, message2 + CHARACTER*256 :: message, message2, message3 REAL :: old_dt TYPE(WRFU_Time) :: temp_time, CurrTime, restart_time INTEGER, PARAMETER :: precision = 100 @@ -582,7 +583,7 @@ SUBROUTINE solve_em ( grid , config_flags & CALL rk_step_prep ( config_flags, rk_step, & grid%u_2, grid%v_2, grid%w_2, grid%t_2, grid%ph_2, grid%mu_2, & - moist, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, moist, & grid%ru, grid%rv, grid%rw, grid%ww, grid%php, grid%alt, grid%muu, grid%muv, & grid%mub, grid%mut, grid%phb, grid%pb, grid%p, grid%al, grid%alb, & cqu, cqv, cqw, & @@ -846,6 +847,7 @@ SUBROUTINE solve_em ( grid , config_flags & ,grid%u_1, grid%v_1, grid%w_1, grid%t_1, grid%ph_1 & ,grid%h_diabatic, grid%phb, grid%t_init & ,grid%mu_2, grid%mut, grid%muu, grid%muv, grid%mub & + ,grid%c1h, grid%c2h, grid%c1f, grid%c2f & ,grid%al, grid%alt, grid%p, grid%pb, grid%php, cqu, cqv, cqw & ,grid%u_base, grid%v_base, grid%t_base, grid%qv_base, grid%z_base & ,grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv & @@ -928,7 +930,7 @@ SUBROUTINE solve_em ( grid , config_flags & CALL relax_bdy_dry ( config_flags, & grid%u_save, grid%v_save, ph_save, grid%t_save, & - w_save, mu_tend, & + w_save, mu_tend, grid%c1h, grid%c2h, grid%c1f, grid%c2f, & grid%ru, grid%rv, grid%ph_2, grid%t_2, & grid%w_2, grid%mu_2, grid%mut, & grid%u_bxs,grid%u_bxe,grid%u_bys,grid%u_bye, & @@ -958,7 +960,8 @@ SUBROUTINE solve_em ( grid , config_flags & ru_tendf, rv_tendf, rw_tendf, ph_tendf, t_tendf, & grid%u_save, grid%v_save, w_save, ph_save, grid%t_save, & mu_tend, mu_tendf, rk_step, & - grid%h_diabatic, grid%mut, grid%msftx, & + grid%c1h, grid%c2h, & + grid%h_diabatic, grid%mut, grid%msftx, & grid%msfty, grid%msfux,grid%msfuy, & grid%msfvx, grid%msfvx_inv, grid%msfvy, & ids,ide, jds,jde, kds,kde, & @@ -1032,7 +1035,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF( config_flags%specified .and. config_flags%perturb_bdy==1 ) THEN CALL spec_bdy_dry_perturb ( config_flags, & grid%ru_tend, grid%rv_tend, t_tend, & - grid%mu_2, grid%mub, & + grid%mu_2, grid%mub, grid%c1h, grid%c2h, & grid%msfux, grid%msfvx, grid%msft, & grid%ru_tendf_stoch, grid%rv_tendf_stoch, grid%rt_tendf_stoch, & config_flags%spec_bdy_width, grid%spec_zone, & @@ -1049,7 +1052,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF( config_flags%specified .and. config_flags%perturb_bdy==2 ) THEN CALL spec_bdy_dry_perturb ( config_flags, & grid%ru_tend, grid%rv_tend, t_tend, & - grid%mu_2, grid%mub, & + grid%mu_2, grid%mub, grid%c1h, grid%c2h, & grid%msfux, grid%msfvx, grid%msft, & grid%field_u_tend_perturb, grid%field_v_tend_perturb, grid%field_t_tend_perturb, & config_flags%spec_bdy_width, grid%spec_zone, & @@ -1107,8 +1110,10 @@ SUBROUTINE solve_em ( grid , config_flags & CALL small_step_prep( grid%u_1,grid%u_2,grid%v_1,grid%v_2,grid%w_1,grid%w_2, & grid%t_1,grid%t_2,grid%ph_1,grid%ph_2, & grid%mub, grid%mu_1, grid%mu_2, & - grid%muu, muus, grid%muv, muvs, & + grid%muu, grid%muus, grid%muv, grid%muvs, & grid%mut, grid%muts, grid%mudf, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & + grid%c3h, grid%c4h, grid%c3f, grid%c4f, & grid%u_save, grid%v_save, w_save, & grid%t_save, ph_save, mu_save, & grid%ww, ww1, & @@ -1124,7 +1129,10 @@ SUBROUTINE solve_em ( grid , config_flags & CALL calc_p_rho( grid%al, grid%p, grid%ph_2, & grid%alt, grid%t_2, grid%t_save, c2a, pm1, & - grid%mu_2, grid%muts, grid%znu, t0, & + grid%mu_2, grid%muts, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & + grid%c3h, grid%c4h, grid%c3f, grid%c4f, & + grid%znu, t0, & grid%rdnw, grid%dnw, grid%smdiv, & config_flags%non_hydrostatic, 0, & ids, ide, jds, jde, kds, kde, & @@ -1135,8 +1143,10 @@ SUBROUTINE solve_em ( grid , config_flags & IF (config_flags%non_hydrostatic) THEN CALL calc_coef_w( a,alpha,gamma, & - grid%mut, cqw, & - grid%rdn, grid%rdnw, c2a, & + grid%mut, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & + grid%c3h, grid%c4h, grid%c3f, grid%c4f, & + cqw, grid%rdn, grid%rdnw, c2a, & dts_rk, g, grid%epssm, & config_flags%top_lid, & ids, ide, jds, jde, kds, kde, & @@ -1290,8 +1300,9 @@ SUBROUTINE solve_em ( grid , config_flags & CALL advance_uv ( grid%u_2, grid%ru_tend, grid%v_2, grid%rv_tend, & grid%p, grid%pb, & grid%ph_2, grid%php, grid%alt, grid%al, & - grid%mu_2, & - grid%muu, cqu, grid%muv, cqv, grid%mudf, & + grid%mu_2, grid%muu, cqu, grid%muv, cqv, grid%mudf, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & + grid%c3h, grid%c4h, grid%c3f, grid%c4f, & grid%msfux, grid%msfuy, grid%msfvx, & grid%msfvx_inv, grid%msfvy, & grid%rdx, grid%rdy, dts_rk, & @@ -1401,7 +1412,10 @@ SUBROUTINE solve_em ( grid , config_flags & BENCH_START(advance_mu_t_tim) CALL advance_mu_t( grid%ww, ww1, grid%u_2, grid%u_save, grid%v_2, grid%v_save, & grid%mu_2, grid%mut, muave, grid%muts, grid%muu, grid%muv, & - grid%mudf, grid%ru_m, grid%rv_m, grid%ww_m, & + grid%mudf, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & + grid%c3h, grid%c4h, grid%c3f, grid%c4f, & + grid%ru_m, grid%rv_m, grid%ww_m, & grid%t_2, grid%t_save, t_2save, t_tend, & mu_tend, & grid%rdx, grid%rdy, dts_rk, grid%epssm, & @@ -1506,6 +1520,8 @@ SUBROUTINE solve_em ( grid , config_flags & CALL advance_w( grid%w_2, rw_tend, grid%ww, w_save, & grid%u_2, grid%v_2, & grid%mu_2, grid%mut, muave, grid%muts, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & + grid%c3h, grid%c4h, grid%c3f, grid%c4f, & t_2save, grid%t_2, grid%t_save, & grid%ph_2, ph_save, grid%phb, ph_tend, & grid%ht, c2a, cqw, grid%alt, grid%alb, & @@ -1571,6 +1587,8 @@ SUBROUTINE solve_em ( grid , config_flags & CALL sumflux ( grid%u_2, grid%v_2, grid%ww, & grid%u_save, grid%v_save, ww1, & grid%muu, grid%muv, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & + grid%c3h, grid%c4h, grid%c3f, grid%c4f, & grid%ru_m, grid%rv_m, grid%ww_m, grid%epssm, & grid%msfux, grid% msfuy, grid%msfvx, & grid%msfvx_inv, grid%msfvy, & @@ -1587,7 +1605,8 @@ SUBROUTINE solve_em ( grid , config_flags & BENCH_START(spec_bdynhyd_tim) IF (config_flags%non_hydrostatic) THEN CALL spec_bdyupdate_ph( ph_save, grid%ph_2, ph_tend, & - mu_tend, grid%muts, dts_rk, & + mu_tend, grid%muts, & + grid%c1f, grid%c2f, dts_rk, & 'h' , config_flags, & grid%spec_zone, & ids,ide, jds,jde, kds,kde, & @@ -1624,7 +1643,10 @@ SUBROUTINE solve_em ( grid , config_flags & BENCH_START(cald_p_rho_tim) CALL calc_p_rho( grid%al, grid%p, grid%ph_2, & grid%alt, grid%t_2, grid%t_save, c2a, pm1, & - grid%mu_2, grid%muts, grid%znu, t0, & + grid%mu_2, grid%muts, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & + grid%c3h, grid%c4h, grid%c3f, grid%c4f, & + grid%znu, t0, & grid%rdnw, grid%dnw, grid%smdiv, & config_flags%non_hydrostatic, iteration, & ids, ide, jds, jde, kds, kde, & @@ -1729,7 +1751,7 @@ SUBROUTINE solve_em ( grid , config_flags & BENCH_START(calc_mu_uv_tim) CALL calc_mu_uv_1 ( config_flags, & - grid%muts, muus, muvs, & + grid%muts, grid%muus, grid%muvs, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & grid%i_start(ij), grid%i_end(ij), & @@ -1740,7 +1762,9 @@ SUBROUTINE solve_em ( grid , config_flags & CALL small_step_finish( grid%u_2, grid%u_1, grid%v_2, grid%v_1, grid%w_2, grid%w_1, & grid%t_2, grid%t_1, grid%ph_2, grid%ph_1, grid%ww, ww1, & grid%mu_2, grid%mu_1, & - grid%mut, grid%muts, grid%muu, muus, grid%muv, muvs, & + grid%mut, grid%muts, grid%muu, grid%muus, grid%muv, grid%muvs, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & + grid%c3h, grid%c4h, grid%c3f, grid%c4f, & grid%u_save, grid%v_save, w_save, & grid%t_save, ph_save, mu_save, & grid%msfux,grid%msfuy, grid%msfvx,grid%msfvy, grid%msftx,grid%msfty, & @@ -1855,6 +1879,7 @@ SUBROUTINE solve_em ( grid , config_flags & CALL rk_update_scalar_pd( im, im, & moist_old(ims,kms,jms,im), & moist_tend(ims,kms,jms,im), & + grid%c1h, grid%c2h, & grid%mu_1, grid%mu_1, grid%mub, & rk_step, dt_rk, grid%spec_zone, & config_flags, & @@ -1917,6 +1942,7 @@ SUBROUTINE solve_em ( grid , config_flags & CALL rk_update_scalar_pd( im, im, & scalar_old(ims,kms,jms,im), & scalar_tend(ims,kms,jms,im), & + grid%c1h, grid%c2h, & grid%mu_1, grid%mu_1, grid%mub, & rk_step, dt_rk, grid%spec_zone, & config_flags, & @@ -1983,6 +2009,7 @@ SUBROUTINE solve_em ( grid , config_flags & CALL rk_update_scalar_pd( im, im, & chem_old(ims,kms,jms,im), & chem_tend(ims,kms,jms,im), & + grid%c1h, grid%c2h, & grid%mu_1, grid%mu_1, grid%mub, & rk_step, dt_rk, grid%spec_zone, & config_flags, & @@ -2044,6 +2071,7 @@ SUBROUTINE solve_em ( grid , config_flags & CALL rk_update_scalar_pd( im, im, & tracer_old(ims,kms,jms,im), & tracer_tend(ims,kms,jms,im), & + grid%c1h, grid%c2h, & grid%mu_1, grid%mu_1, grid%mub, & rk_step, dt_rk, grid%spec_zone, & config_flags, & @@ -2105,6 +2133,7 @@ SUBROUTINE solve_em ( grid , config_flags & CALL rk_update_scalar_pd( 1, 1, & grid%tke_1, & tke_tend(ims,kms,jms), & + grid%c1h, grid%c2h, & grid%mu_1, grid%mu_1, grid%mub, & rk_step, dt_rk, grid%spec_zone, & config_flags, & @@ -2208,6 +2237,7 @@ SUBROUTINE solve_em ( grid , config_flags & rk_step, dt_rk, & grid%ru_m, grid%rv_m, grid%ww_m, & grid%muts, grid%mub, grid%mu_1, & + grid%c1h, grid%c2h, & grid%alt, & moist_old(ims,kms,jms,im), & moist(ims,kms,jms,im), & @@ -2230,6 +2260,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF( im.eq.p_qv .or. im.eq.p_qc )THEN CALL q_diabatic_add ( im, im, & dt_rk, grid%mut, & + grid%c1h, grid%c2h, & grid%qv_diabatic, & grid%qc_diabatic, & moist_tend(ims,kms,jms,im), & @@ -2249,6 +2280,7 @@ SUBROUTINE solve_em ( grid , config_flags & ( config_flags%specified .AND. config_flags%have_bcs_moist ) ) THEN CALL relax_bdy_scalar ( moist_tend(ims,kms,jms,im), & moist(ims,kms,jms,im), grid%mut, & + grid%c1h, grid%c2h, & moist_bxs(jms,kms,1,im),moist_bxe(jms,kms,1,im), & moist_bys(ims,kms,1,im),moist_bye(ims,kms,1,im), & moist_btxs(jms,kms,1,im),moist_btxe(jms,kms,1,im), & @@ -2298,6 +2330,7 @@ SUBROUTINE solve_em ( grid , config_flags & advect_tend=advect_tend, & h_tendency=h_tendency, z_tendency=z_tendency, & msftx=grid%msftx,msfty=grid%msfty, & + c1=grid%c1h, c2=grid%c2h, & mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub, & rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone, & config_flags=config_flags, tenddec=tenddec, & @@ -2369,6 +2402,7 @@ SUBROUTINE solve_em ( grid , config_flags & rk_step, dt_rk, & grid%ru_m, grid%rv_m, grid%ww_m, & grid%muts, grid%mub, grid%mu_1, & + grid%c1h, grid%c2h, & grid%alt, & grid%tke_1, & grid%tke_2, & @@ -2403,6 +2437,7 @@ SUBROUTINE solve_em ( grid , config_flags & advect_tend=advect_tend, & h_tendency=h_tendency, z_tendency=z_tendency, & msftx=grid%msftx,msfty=grid%msfty, & + c1=grid%c1h, c2=grid%c2h, & mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub, & rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone, & config_flags=config_flags, tenddec=tenddec, & @@ -2456,6 +2491,7 @@ SUBROUTINE solve_em ( grid , config_flags & rk_step, dt_rk, & grid%ru_m, grid%rv_m, grid%ww_m, & grid%muts, grid%mub, grid%mu_1, & + grid%c1h, grid%c2h, & grid%alt, & chem_old(ims,kms,jms,ic), & chem(ims,kms,jms,ic), & @@ -2483,6 +2519,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF(ic.eq.1)CALL wrf_debug ( 10 , ' have_bcs_chem' ) CALL relax_bdy_scalar ( chem_tend(ims,kms,jms,ic), & chem(ims,kms,jms,ic), grid%mut, & + grid%c1h, grid%c2h, & chem_bxs(jms,kms,1,ic),chem_bxe(jms,kms,1,ic), & chem_bys(ims,kms,1,ic),chem_bye(ims,kms,1,ic), & chem_btxs(jms,kms,1,ic),chem_btxe(jms,kms,1,ic), & @@ -2531,6 +2568,7 @@ SUBROUTINE solve_em ( grid , config_flags & advect_tend=advect_tend, & h_tendency=h_tendency, z_tendency=z_tendency, & msftx=grid%msftx,msfty=grid%msfty, & + c1=grid%c1h, c2=grid%c2h, & mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub, & rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone, & config_flags=config_flags, tenddec=tenddec, & @@ -2602,10 +2640,11 @@ SUBROUTINE solve_em ( grid , config_flags & rk_step, dt_rk, & grid%ru_m, grid%rv_m, grid%ww_m, & grid%muts, grid%mub, grid%mu_1, & + grid%c1h, grid%c2h, & grid%alt, & - tracer_old(ims,kms,jms,ic), & - tracer(ims,kms,jms,ic), & - tracer_tend(ims,kms,jms,ic), & + tracer_old(ims,kms,jms,ic), & + tracer(ims,kms,jms,ic), & + tracer_tend(ims,kms,jms,ic), & advect_tend,h_tendency,z_tendency,grid%rqvften, & grid%qv_base, .false., grid%fnm, grid%fnp, & grid%msfux,grid%msfuy, grid%msfvx, grid%msfvx_inv, & @@ -2629,6 +2668,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF(ic.eq.1)CALL wrf_debug ( 10 , ' have_bcs_tracer' ) CALL relax_bdy_scalar ( tracer_tend(ims,kms,jms,ic), & tracer(ims,kms,jms,ic), grid%mut, & + grid%c1h, grid%c2h, & tracer_bxs(jms,kms,1,ic),tracer_bxe(jms,kms,1,ic), & tracer_bys(ims,kms,1,ic),tracer_bye(ims,kms,1,ic), & tracer_btxs(jms,kms,1,ic),tracer_btxe(jms,kms,1,ic), & @@ -2676,6 +2716,7 @@ SUBROUTINE solve_em ( grid , config_flags & advect_tend=advect_tend, & h_tendency=h_tendency, z_tendency=z_tendency, & msftx=grid%msftx,msfty=grid%msfty, & + c1=grid%c1h, c2=grid%c2h, & mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub, & rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone, & config_flags=config_flags, tenddec=tenddec, & @@ -2737,6 +2778,7 @@ SUBROUTINE solve_em ( grid , config_flags & rk_step, dt_rk, & grid%ru_m, grid%rv_m, grid%ww_m, & grid%muts, grid%mub, grid%mu_1, & + grid%c1h, grid%c2h, & grid%alt, & scalar_old(ims,kms,jms,is), & scalar(ims,kms,jms,is), & @@ -2762,6 +2804,7 @@ SUBROUTINE solve_em ( grid , config_flags & CALL relax_bdy_scalar ( scalar_tend(ims,kms,jms,is), & scalar(ims,kms,jms,is), grid%mut, & + grid%c1h, grid%c2h, & scalar_bxs(jms,kms,1,is),scalar_bxe(jms,kms,1,is), & scalar_bys(ims,kms,1,is),scalar_bye(ims,kms,1,is), & scalar_btxs(jms,kms,1,is),scalar_btxe(jms,kms,1,is), & @@ -2811,6 +2854,7 @@ SUBROUTINE solve_em ( grid , config_flags & advect_tend=advect_tend, & h_tendency=h_tendency, z_tendency=z_tendency, & msftx=grid%msftx,msfty=grid%msfty, & + c1=grid%c1h, c2=grid%c2h, & mu_old=grid%mu_1, mu_new=grid%mu_2, mu_base=grid%mub, & rk_step=rk_step, dt=dt_rk, spec_zone=grid%spec_zone, & config_flags=config_flags, tenddec=tenddec, & @@ -2924,6 +2968,7 @@ SUBROUTINE solve_em ( grid , config_flags & CALL calc_p_rho_phi( moist, num_3d_m, config_flags%hypsometric_opt, & grid%al, grid%alb, grid%mu_2, grid%muts, & + grid%c1h, grid%c2h, grid%c3h, grid%c4h, grid%c3f, grid%c4f, & grid%ph_2, grid%phb, grid%p, grid%pb, grid%t_2, & p0, t0, grid%p_top, grid%znu, grid%znw, grid%dnw, grid%rdnw, & grid%rdn, config_flags%non_hydrostatic, & @@ -2953,8 +2998,9 @@ SUBROUTINE solve_em ( grid , config_flags & CALL wrf_debug ( 200 , ' call filter moist ' ) DO im = PARAM_FIRST_SCALAR, num_3d_m IF ( config_flags%coupled_filtering ) THEN - CALL couple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im) & + CALL couple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & + ,C1=grid%c1h , C2=grid%c2h & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) @@ -2986,6 +3032,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF ( config_flags%coupled_filtering ) THEN CALL uncouple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & + ,C1=grid%c1h , C2=grid%c2h & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) @@ -2999,6 +3046,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF ( config_flags%coupled_filtering ) THEN CALL couple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & + ,C1=grid%c1h , C2=grid%c2h & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) @@ -3030,6 +3078,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF ( config_flags%coupled_filtering ) THEN CALL uncouple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & + ,C1=grid%c1h , C2=grid%c2h & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) @@ -3042,6 +3091,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF ( config_flags%coupled_filtering ) THEN CALL couple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & + ,C1=grid%c1h , C2=grid%c2h & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) @@ -3073,6 +3123,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF ( config_flags%coupled_filtering ) THEN CALL uncouple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & + ,C1=grid%c1h , C2=grid%c2h & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) @@ -3086,6 +3137,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF ( config_flags%coupled_filtering ) THEN CALL couple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & + ,C1=grid%c1h , C2=grid%c2h & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) @@ -3117,6 +3169,7 @@ SUBROUTINE solve_em ( grid , config_flags & IF ( config_flags%coupled_filtering ) THEN CALL uncouple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im) & ,MU=grid%mu_2 , MUB=grid%mub & + ,C1=grid%c1h , C2=grid%c2h & ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde & ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme & ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe ) @@ -3183,6 +3236,7 @@ SUBROUTINE solve_em ( grid , config_flags & # include "PERIOD_BDY_EM_CHEM2.inc" # include "PERIOD_BDY_EM_TRACER2.inc" # include "PERIOD_BDY_EM_SCALAR2.inc" +# include "PERIOD_BDY_EM_TKE.inc" #endif BENCH_START(bc_end_tim) @@ -3203,8 +3257,9 @@ SUBROUTINE solve_em ( grid , config_flags & BENCH_START(diag_w_tim) IF (.not. config_flags%non_hydrostatic) THEN - CALL diagnose_w( ph_tend, grid%ph_2, grid%ph_1, grid%w_2, grid%muts, dt_rk, & - grid%u_2, grid%v_2, grid%ht, & + CALL diagnose_w( ph_tend, grid%ph_2, grid%ph_1, grid%w_2, grid%muts, & + grid%c1f, grid%c2f, dt_rk, & + grid%u_2, grid%v_2, grid%ht, & grid%cf1, grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msftx, grid%msfty, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & @@ -3405,12 +3460,18 @@ SUBROUTINE solve_em ( grid , config_flags & !********************************************************** END DO Runge_Kutta_loop +! grid%dmudt=grid%mu_2 - grid%mu_1 IF ( config_flags%traj_opt .EQ. UM_TRAJECTORY ) THEN #ifdef DM_PARALLEL -# include "HALO_EM_F.inc" +# include "HALO_EM_F_1.inc" # include "HALO_EM_D.inc" # include "HALO_EM_INIT_4.inc" + IF( config_flags%periodic_x ) THEN +# include "PERIOD_EM_DA.inc" +# include "PERIOD_EM_F.inc" +# include "PERIOD_EM_G.inc" + ENDIF #endif !$OMP PARALLEL DO & !$OMP PRIVATE ( ij ) @@ -3418,7 +3479,8 @@ SUBROUTINE solve_em ( grid , config_flags & call trajectory (grid,config_flags, & grid%dt,grid%itimestep,grid%ru_m, grid%rv_m, grid%ww_m,& - grid%mut,grid%muu,grid%muv, & + grid%muts,grid%muus,grid%muvs, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & grid%rdx, grid%rdy, grid%rdn, grid%rdnw,grid%rdzw, & grid%traj_i,grid%traj_j,grid%traj_k, & grid%traj_long,grid%traj_lat, & @@ -3515,6 +3577,33 @@ SUBROUTINE solve_em ( grid , config_flags & ENDDO !$OMP END PARALLEL DO + !$OMP PARALLEL DO & + !$OMP PRIVATE ( ij ) + DO ij = 1 , grid%num_tiles + CALL wrf_debug ( 200 , ' call phy_prep_part2' ) + CALL phy_prep_part2 ( config_flags, & + grid%muts, grid%muus, grid%muvs, & + grid%c1h, grid%c2h, grid%c1f, grid%c2f, & + grid%rthraten, & + grid%rthblten, grid%rublten, grid%rvblten, & + grid%rqvblten, grid%rqcblten, grid%rqiblten, & + grid%rucuten, grid%rvcuten, grid%rthcuten, & + grid%rqvcuten, grid%rqccuten, grid%rqrcuten, & + grid%rqicuten, grid%rqscuten, & + grid%rushten, grid%rvshten, grid%rthshten, & + grid%rqvshten, grid%rqcshten, grid%rqrshten, & + grid%rqishten, grid%rqsshten, grid%rqgshten, & + grid%rthften, grid%rqvften, & + grid%RUNDGDTEN, grid%RVNDGDTEN, grid%RTHNDGDTEN, & + grid%RPHNDGDTEN,grid%RQVNDGDTEN, grid%RMUNDGDTEN,& + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + grid%i_start(ij), grid%i_end(ij), & + grid%j_start(ij), grid%j_end(ij), & + k_start, k_end ) + ENDDO + !$OMP END PARALLEL DO + ! !
 ! (5) time-split physics.
@@ -3609,6 +3698,9 @@ SUBROUTINE solve_em ( grid , config_flags  &
       &        ,RHO=grid%rho       ,SPEC_ZONE=grid%spec_zone              &
       &        ,SR=grid%sr              ,TH=th_phy                        &
       &        ,refl_10cm=grid%refl_10cm                                  & ! hm, 9/22/09 for refl
+      &        ,vmi3d=grid%vmi3d                                          & ! for P3
+      &        ,di3d=grid%di3d                                            & ! for P3
+      &        ,rhopo3d=grid%rhopo3d                                      & ! for P3
       &        ,WARM_RAIN=grid%warm_rain                                  &
       &        ,T8W=t8w                                                   &
       &        ,CLDFRA=grid%cldfra, EXCH_H=grid%exch_h &
@@ -3699,7 +3791,8 @@ SUBROUTINE solve_em ( grid , config_flags  &
       &        , QNIC_CURR=scalar(ims,kms,jms,P_QNIC), F_QNIC=F_QNIC          &
       &        , QNIP_CURR=scalar(ims,kms,jms,P_QNIP), F_QNIP=F_QNIP          &
       &        , QNID_CURR=scalar(ims,kms,jms,P_QNID), F_QNID=F_QNID          &
-
+      &        , QIR_CURR=scalar(ims,kms,jms,P_QIR), F_QIR=F_QIR          & ! for P3
+      &        , QIB_CURR=scalar(ims,kms,jms,P_QIB), F_QIB=F_QIB          & ! for P3
 !       &        , QZR_CURR=scalar(ims,kms,jms,P_QZR), F_QZR=F_QZR          & ! for milbrandt3mom
 !       &        , QZI_CURR=scalar(ims,kms,jms,P_QZI), F_QZI=F_QZI          & ! "
 !       &        , QZS_CURR=scalar(ims,kms,jms,P_QZS), F_QZS=F_QZS          & ! "
@@ -3707,8 +3800,9 @@ SUBROUTINE solve_em ( grid , config_flags  &
 !       &        , QZH_CURR=scalar(ims,kms,jms,P_QZH), F_QZH=F_QZH          & ! "
       &        , QVOLG_CURR=scalar(ims,kms,jms,P_QVOLG), F_QVOLG=F_QVOLG    & ! for nssl_2mom
       &        , QVOLH_CURR=scalar(ims,kms,jms,P_QVOLH), F_QVOLH=F_QVOLH    & ! for nssl_2mom
+      &        , cu_used=config_flags%cu_used                             &
       &        , qrcuten=grid%rqrcuten, qscuten=grid%rqscuten             &
-      &        , qicuten=grid%rqicuten,mu=grid%mut                        &
+      &        , qicuten=grid%rqicuten, qccuten=grid%rqccuten             &
       &        , HAIL=config_flags%gsfcgce_hail                           & ! for gsfcgce
       &        , ICE2=config_flags%gsfcgce_2ice                           & ! for gsfcgce
 !     &        , ccntype=config_flags%milbrandt_ccntype                   & ! for milbrandt (2mom)
@@ -3867,13 +3961,12 @@ SUBROUTINE solve_em ( grid , config_flags  &
        CALL wrf_debug ( 200 , ' call filter moist' )
        DO im = PARAM_FIRST_SCALAR, num_3d_m
          IF ( config_flags%coupled_filtering ) THEN
-         DO jj = jps, MIN(jpe,jde-1)
-           DO kk = kps, MIN(kpe,kde-1)
-             DO ii = ips, MIN(ipe,ide-1)
-               moist(ii,kk,jj,im)=moist(ii,kk,jj,im)*(grid%mu_2(ii,jj)+grid%mub(ii,jj))
-             ENDDO
-           ENDDO
-         ENDDO
+           CALL couple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im)        &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,C1=grid%c1h , C2=grid%c2h                                   &
+                    ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde             &
+                    ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme             &
+                    ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe          )
          END IF
  
          CALL pxft ( grid=grid                                                 &
@@ -3902,13 +3995,12 @@ SUBROUTINE solve_em ( grid , config_flags  &
                   ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
  
          IF ( config_flags%coupled_filtering ) THEN
-         DO jj = jps, MIN(jpe,jde-1)
-           DO kk = kps, MIN(kpe,kde-1)
-             DO ii = ips, MIN(ipe,ide-1)
-               moist(ii,kk,jj,im)=moist(ii,kk,jj,im)/(grid%mu_2(ii,jj)+grid%mub(ii,jj))
-             ENDDO
-           ENDDO
-         ENDDO
+           CALL uncouple_scalars_for_filter ( FIELD=moist(ims,kms,jms,im)      &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,C1=grid%c1h , C2=grid%c2h                                   &
+                    ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde             &
+                    ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme             &
+                    ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe          )
          END IF
        ENDDO
      ENDIF
@@ -3935,6 +4027,7 @@ SUBROUTINE solve_em ( grid , config_flags  &
 
      CALL calc_p_rho_phi( moist, num_3d_m, config_flags%hypsometric_opt,             &
                           grid%al, grid%alb, grid%mu_2, grid%muts,              &
+                          grid%c1h, grid%c2h, grid%c3h, grid%c4h, grid%c3f, grid%c4f, &
                           grid%ph_2, grid%phb, grid%p, grid%pb, grid%t_2,                 &
                           p0, t0, grid%p_top, grid%znu, grid%znw, grid%dnw, grid%rdnw,           &
                           grid%rdn, config_flags%non_hydrostatic,             &
@@ -3955,8 +4048,9 @@ SUBROUTINE solve_em ( grid , config_flags  &
      !$OMP PARALLEL DO   &
      !$OMP PRIVATE ( ij )
      DO ij = 1 , grid%num_tiles
-       CALL diagnose_w( ph_tend, grid%ph_2, grid%ph_1, grid%w_2, grid%muts, dt_rk,  &
-                       grid%u_2, grid%v_2, grid%ht,                           &
+       CALL diagnose_w( ph_tend, grid%ph_2, grid%ph_1, grid%w_2, grid%muts, &
+                       grid%c1f, grid%c2f, dt_rk,              &
+                       grid%u_2, grid%v_2, grid%ht,            &
                        grid%cf1, grid%cf2, grid%cf3, grid%rdx, grid%rdy, grid%msftx, grid%msfty, &
                        ids, ide, jds, jde, kds, kde,           &
                        ims, ime, jms, jme, kms, kme,           &
@@ -3980,13 +4074,12 @@ SUBROUTINE solve_em ( grid , config_flags  &
      IF ( num_3d_c >= PARAM_FIRST_SCALAR ) then
        chem_filter_loop: DO im = PARAM_FIRST_SCALAR, num_3d_c
          IF ( config_flags%coupled_filtering ) THEN
-         DO jj = jps, MIN(jpe,jde-1)
-           DO kk = kps, MIN(kpe,kde-1)
-             DO ii = ips, MIN(ipe,ide-1)
-               chem(ii,kk,jj,im)=chem(ii,kk,jj,im)*(grid%mu_2(ii,jj)+grid%mub(ii,jj))
-             ENDDO
-           ENDDO
-         ENDDO
+             CALL couple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im)               &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,C1=grid%c1h , C2=grid%c2h                                   &
+                    ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde             &
+                    ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme             &
+                    ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe           )
          END IF
 
          CALL pxft ( grid=grid                                                 &
@@ -4015,26 +4108,24 @@ SUBROUTINE solve_em ( grid , config_flags  &
                   ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
 
          IF ( config_flags%coupled_filtering ) THEN
-         DO jj = jps, MIN(jpe,jde-1)
-           DO kk = kps, MIN(kpe,kde-1)
-             DO ii = ips, MIN(ipe,ide-1)
-               chem(ii,kk,jj,im)=chem(ii,kk,jj,im)/(grid%mu_2(ii,jj)+grid%mub(ii,jj))
-             ENDDO
-           ENDDO
-         ENDDO
+             CALL uncouple_scalars_for_filter ( FIELD=chem(ims,kms,jms,im)       &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,C1=grid%c1h , C2=grid%c2h                                   &
+                    ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde             &
+                    ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme             &
+                    ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe          )
          END IF
        ENDDO chem_filter_loop
      ENDIF
      IF ( num_tracer >= PARAM_FIRST_SCALAR ) then
        tracer_filter_loop: DO im = PARAM_FIRST_SCALAR, num_tracer
          IF ( config_flags%coupled_filtering ) THEN
-         DO jj = jps, MIN(jpe,jde-1)
-           DO kk = kps, MIN(kpe,kde-1)
-             DO ii = ips, MIN(ipe,ide-1)
-               tracer(ii,kk,jj,im)=tracer(ii,kk,jj,im)*(grid%mu_2(ii,jj)+grid%mub(ii,jj))
-             ENDDO
-           ENDDO
-         ENDDO
+           CALL couple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im)         &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,C1=grid%c1h , C2=grid%c2h                                   &
+                    ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde             &
+                    ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme             &
+                    ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe           )
          END IF
 
          CALL pxft ( grid=grid                                                 &
@@ -4063,13 +4154,12 @@ SUBROUTINE solve_em ( grid , config_flags  &
                   ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
 
          IF ( config_flags%coupled_filtering ) THEN
-         DO jj = jps, MIN(jpe,jde-1)
-           DO kk = kps, MIN(kpe,kde-1)
-             DO ii = ips, MIN(ipe,ide-1)
-               tracer(ii,kk,jj,im)=tracer(ii,kk,jj,im)/(grid%mu_2(ii,jj)+grid%mub(ii,jj))
-             ENDDO
-           ENDDO
-         ENDDO
+           CALL uncouple_scalars_for_filter ( FIELD=tracer(ims,kms,jms,im)       &
+                    ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                    ,C1=grid%c1h , C2=grid%c2h                                   &
+                    ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde             &
+                    ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme             &
+                    ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe          )
          END IF
        ENDDO tracer_filter_loop
      ENDIF
@@ -4077,13 +4167,12 @@ SUBROUTINE solve_em ( grid , config_flags  &
      IF ( num_3d_s >= PARAM_FIRST_SCALAR ) then
        scalar_filter_loop: DO im = PARAM_FIRST_SCALAR, num_3d_s
          IF ( config_flags%coupled_filtering ) THEN
-         DO jj = jps, MIN(jpe,jde-1)
-           DO kk = kps, MIN(kpe,kde-1)
-             DO ii = ips, MIN(ipe,ide-1)
-               scalar(ii,kk,jj,im)=scalar(ii,kk,jj,im)*(grid%mu_2(ii,jj)+grid%mub(ii,jj))
-             ENDDO
-           ENDDO
-         ENDDO
+           CALL couple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im)       &
+                  ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                  ,C1=grid%c1h , C2=grid%c2h                                   &
+                  ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde             &
+                  ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme             &
+                  ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe          )
          END IF
 
          CALL pxft ( grid=grid                                                 &
@@ -4112,13 +4201,12 @@ SUBROUTINE solve_em ( grid , config_flags  &
                   ,ipsx=ipsx,ipex=ipex,jpsx=jmsx,jpex=jpex,kpsx=kpsx,kpex=kpex )
 
          IF ( config_flags%coupled_filtering ) THEN
-         DO jj = jps, MIN(jpe,jde-1)
-           DO kk = kps, MIN(kpe,kde-1)
-             DO ii = ips, MIN(ipe,ide-1)
-               scalar(ii,kk,jj,im)=scalar(ii,kk,jj,im)/(grid%mu_2(ii,jj)+grid%mub(ii,jj))
-             ENDDO
-           ENDDO
-         ENDDO
+           CALL uncouple_scalars_for_filter ( FIELD=scalar(ims,kms,jms,im)     &
+                  ,MU=grid%mu_2 , MUB=grid%mub                                 &
+                  ,C1=grid%c1h , C2=grid%c2h                                   &
+                  ,ids=ids,ide=ide,jds=jds,jde=jde,kds=kds,kde=kde             &
+                  ,ims=ims,ime=ime,jms=jms,jme=jme,kms=kms,kme=kme             &
+                  ,ips=ips,ipe=ipe,jps=jps,jpe=jpe,kps=kps,kpe=kpe          )
          END IF
        ENDDO scalar_filter_loop
      ENDIF
@@ -4290,7 +4378,7 @@ SUBROUTINE solve_em ( grid , config_flags  &
 
      CALL wrf_debug ( 200 , ' call spec_bdy_final' )
 
-     CALL spec_bdy_final   ( grid%u_2, muus, grid%msfuy,                              &
+     CALL spec_bdy_final   ( grid%u_2, grid%muus, grid%c1h, grid%c2h, grid%msfuy,     &
                                 grid%u_bxs, grid%u_bxe, grid%u_bys, grid%u_bye,  &
                                 grid%u_btxs,grid%u_btxe,grid%u_btys,grid%u_btye, &
                                 'u', config_flags,                               &
@@ -4303,7 +4391,7 @@ SUBROUTINE solve_em ( grid , config_flags  &
                                 grid%j_start(ij), grid%j_end(ij),       &
                                 k_start    , k_end                     )
 
-     CALL spec_bdy_final   ( grid%v_2, muvs, grid%msfvx,                              &
+     CALL spec_bdy_final   ( grid%v_2, grid%muvs, grid%c1h, grid%c2h, grid%msfvx,     &
                                 grid%v_bxs, grid%v_bxe, grid%v_bys, grid%v_bye,  &
                                 grid%v_btxs,grid%v_btxe,grid%v_btys,grid%v_btye, &
                                 'v', config_flags,                               &
@@ -4317,7 +4405,7 @@ SUBROUTINE solve_em ( grid , config_flags  &
                                 k_start    , k_end                     )
 
      IF( config_flags%nested) THEN
-       CALL spec_bdy_final   ( grid%w_2, grid%muts, grid%msfty,                              &
+       CALL spec_bdy_final   ( grid%w_2, grid%muts, grid%c1f, grid%c2f, grid%msfty, &
                                 grid%w_bxs, grid%w_bxe, grid%w_bys, grid%w_bye,  &
                                 grid%w_btxs,grid%w_btxe,grid%w_btys,grid%w_btye, &
                                 'w', config_flags,                               &
@@ -4331,7 +4419,7 @@ SUBROUTINE solve_em ( grid , config_flags  &
                                 k_start    , k_end                     )
      ENDIF
 
-     CALL spec_bdy_final   ( grid%t_2, grid%muts, grid%msfty,                              &
+     CALL spec_bdy_final   ( grid%t_2, grid%muts, grid%c1h, grid%c2h, grid%msfty,&
                                 grid%t_bxs, grid%t_bxe, grid%t_bys, grid%t_bye,  &
                                 grid%t_btxs,grid%t_btxe,grid%t_btys,grid%t_btye, &
                                 't', config_flags,                               &
@@ -4344,7 +4432,7 @@ SUBROUTINE solve_em ( grid , config_flags  &
                                 grid%j_start(ij), grid%j_end(ij),       &
                                 k_start    , k_end                     )
 
-     CALL spec_bdy_final   ( grid%ph_2, grid%muts, grid%msfty,                            &
+     CALL spec_bdy_final   ( grid%ph_2, grid%muts, grid%c1f, grid%c2f, grid%msfty,   &
                                 grid%ph_bxs, grid%ph_bxe, grid%ph_bys, grid%ph_bye,  &
                                 grid%ph_btxs,grid%ph_btxe,grid%ph_btys,grid%ph_btye, &
                                 'h', config_flags,                               &
@@ -4358,7 +4446,7 @@ SUBROUTINE solve_em ( grid , config_flags  &
                                 k_start    , k_end                     )
 
      IF( config_flags%spec_bdy_final_mu .EQ. 1 ) THEN
-     CALL spec_bdy_final   ( grid%mu_2, grid%muts, grid%msfty,                            &
+     CALL spec_bdy_final   ( grid%mu_2, grid%muts, grid%c1h, grid%c2h, grid%msfty,   &
                                 grid%mu_bxs, grid%mu_bxe, grid%mu_bys, grid%mu_bye,  &
                                 grid%mu_btxs,grid%mu_btxe,grid%mu_btys,grid%mu_btye, &
                                 'm', config_flags,                               &
@@ -4376,7 +4464,8 @@ SUBROUTINE solve_em ( grid , config_flags  &
 
      IF ( im .EQ. P_QV .OR. config_flags%nested .OR. &
              ( config_flags%specified .AND. config_flags%have_bcs_moist ) ) THEN
-        CALL spec_bdy_final   ( moist(ims,kms,jms,im), grid%muts, grid%msfty,    &
+        CALL spec_bdy_final   ( moist(ims,kms,jms,im), grid%muts,                &
+                                grid%c1h, grid%c2h, grid%msfty,                  &
                                 moist_bxs(jms,kms,1,im),moist_bxe(jms,kms,1,im), &
                                 moist_bys(ims,kms,1,im),moist_bye(ims,kms,1,im), &
                                 moist_btxs(jms,kms,1,im),moist_btxe(jms,kms,1,im), &
@@ -4399,7 +4488,8 @@ SUBROUTINE solve_em ( grid , config_flags  &
          chem_species_bdy_loop_3 : DO ic = PARAM_FIRST_SCALAR , num_3d_c
 
      IF( ( config_flags%nested ) ) THEN
-        CALL spec_bdy_final   ( chem(ims,kms,jms,ic), grid%muts, grid%msfty,    &
+        CALL spec_bdy_final   ( chem(ims,kms,jms,ic), grid%muts,               &
+                                grid%c1h, grid%c2h, grid%msfty,                &
                                 chem_bxs(jms,kms,1,ic),chem_bxe(jms,kms,1,ic), &
                                 chem_bys(ims,kms,1,ic),chem_bye(ims,kms,1,ic), &
                                 chem_btxs(jms,kms,1,ic),chem_btxe(jms,kms,1,ic), &
@@ -4422,7 +4512,8 @@ SUBROUTINE solve_em ( grid , config_flags  &
      tracer_species_bdy_loop_3 : DO im = PARAM_FIRST_SCALAR , num_tracer
 
      IF( ( config_flags%nested ) ) THEN
-        CALL spec_bdy_final   ( tracer(ims,kms,jms,im), grid%muts, grid%msfty,    &
+        CALL spec_bdy_final   ( tracer(ims,kms,jms,im), grid%muts,                 &
+                                grid%c1h, grid%c2h, grid%msfty,                    &
                                 tracer_bxs(jms,kms,1,im),tracer_bxe(jms,kms,1,im), &
                                 tracer_bys(ims,kms,1,im),tracer_bye(ims,kms,1,im), &
                                 tracer_btxs(jms,kms,1,im),tracer_btxe(jms,kms,1,im), &
@@ -4443,7 +4534,8 @@ SUBROUTINE solve_em ( grid , config_flags  &
      scalar_species_bdy_loop_3 : DO is = PARAM_FIRST_SCALAR , num_3d_s
 
      IF( ( config_flags%nested ) ) THEN
-        CALL spec_bdy_final   ( scalar(ims,kms,jms,is), grid%muts, grid%msfty,    &
+        CALL spec_bdy_final   ( scalar(ims,kms,jms,is), grid%muts,                 &
+                                grid%c1h, grid%c2h, grid%msfty,                    &
                                 scalar_bxs(jms,kms,1,is),scalar_bxe(jms,kms,1,is), &
                                 scalar_bys(ims,kms,1,is),scalar_bye(ims,kms,1,is), &
                                 scalar_btxs(jms,kms,1,is),scalar_btxe(jms,kms,1,is), &
diff --git a/wrfv2_fire/dyn_em/start_em.F b/wrfv2_fire/dyn_em/start_em.F
index 3d4a579d..848c4fb8 100644
--- a/wrfv2_fire/dyn_em/start_em.F
+++ b/wrfv2_fire/dyn_em/start_em.F
@@ -1,3 +1,21 @@
+! sed -e "s/grid%mu/gridmu/g" -e "s/grid%Mu/gridMu/g" start_em.F | cpp -DHYBRID_COORD | sed -e "s/gridmu/grid%mu/g" -e "s/gridMu/grid%Mu/g" >> start_em.next
+#if ( HYBRID_COORD==1 )
+#  define gridmu_1(...) (grid%c1h(k)*XXPC1HXX(__VA_ARGS__))
+#  define XXPC1HXX(...) grid%mu_1(__VA_ARGS__)
+
+#  define gridmu_2(...) (grid%c1h(k)*XXPC2HXX(__VA_ARGS__))
+#  define XXPC2HXX(...) grid%mu_2(__VA_ARGS__)
+
+#  define gridmub(...) (grid%c1h(k)*XXPCBHXX(__VA_ARGS__)+grid%c2h(k))
+#  define XXPCBHXX(...) grid%mub(__VA_ARGS__)
+
+#  define gridMu_2(...) (grid%c1f(k)*XXPC2FXX(__VA_ARGS__))
+#  define XXPC2FXX(...) grid%Mu_2(__VA_ARGS__)
+
+#  define gridMub(...) (grid%c1f(k)*XXPCBFXX(__VA_ARGS__)+grid%c2f(k))
+#  define XXPCBFXX(...) grid%Mub(__VA_ARGS__)
+#endif
+
 !-------------------------------------------------------------------
 
    SUBROUTINE start_domain_em ( grid, allowed_to_read &
@@ -9,10 +27,12 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
    USE module_domain, ONLY : domain, wrfu_timeinterval, get_ijk_from_grid, &
         domain_setgmtetc
    USE module_state_description
+   USE module_driver_constants
+   USE module_wrf_error
    USE module_model_constants
-   USE module_bc, ONLY : boundary_condition_check, set_physical_bc2d
-   USE module_bc_em
-   USE module_configure, ONLY : grid_config_rec_type
+   USE module_bc, ONLY : boundary_condition_check, set_physical_bc2d, set_physical_bc3d, bdyzone
+   USE module_bc_em, ONLY: lbc_fcx_gcx, set_w_surface
+   USE module_configure, ONLY : model_to_grid_config_rec, model_config_rec, grid_config_rec_type
    USE module_tiles, ONLY : set_tiles
 #ifdef DM_PARALLEL
    USE module_dm, ONLY : wrf_dm_min_real, wrf_dm_max_real, wrf_dm_maxval, &
@@ -22,11 +42,12 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
    USE module_dm, ONLY : wrf_dm_min_real, wrf_dm_max_real
 #endif
    USE module_comm_dm
-
+   USE module_llxy, ONLY : proj_cassini
    USE module_physics_init
    USE module_lightning_driver, ONLY : lightning_init
    USE module_fr_fire_driver_wrf, ONLY : fire_driver_em_init
-   USE module_stoch, ONLY : setup_rand_perturb, rand_seed, update_stoch
+   USE module_stoch, ONLY : setup_rand_perturb, rand_seed, update_stoch, initialize_stoch
+   USE module_trajectory, ONLY : trajectory_init
 #if (WRF_CHEM == 1)
    USE module_aerosols_sorgam, ONLY: sum_pm_sorgam
    USE module_gocart_aerosols, ONLY: sum_pm_gocart
@@ -94,7 +115,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
    REAL :: lat1 , lat2 , lat3 , lat4
    REAL :: lon1 , lon2 , lon3 , lon4
    INTEGER :: num_points_lat_lon , iloc , jloc
-   CHARACTER (LEN=132) :: message
+   CHARACTER (LEN=256) :: message, a_message
    TYPE(WRFU_TimeInterval) :: stepTime
    REAL, DIMENSION(:,:), ALLOCATABLE :: clat_glob
    logical :: f_flux  ! flag for computing averaged fluxes in cu_gd
@@ -121,6 +142,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 !  CCN for MP=18 initializatio
    REAL :: ccn_max_val
 
+   REAL :: max_mf, max_rot_angle
    CALL get_ijk_from_grid ( grid ,                              &
                            ids, ide, jds, jde, kds, kde,        &
                            ims, ime, jms, jme, kms, kme,        &
@@ -139,6 +161,36 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
    ALLOCATE(z_at_q(IMS:IME,KMS:KME,JMS:JME),STAT=I)  ; z_at_q = 0.
    CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
 
+   !  If the rotation angle is too large, the GWD option does not do well with the assumed U and V
+   !  being close to earth relative.
+
+   IF ( ( grid%id .EQ. 1 ) .AND. ( config_flags%gwd_opt .EQ. 1 ) ) THEN
+      max_rot_angle = ASIN(ABS(grid%sina(its,jts)))/DEGRAD
+      DO j=jts,MIN(jde-1,jte)
+         DO i=its,MIN(ide-1,ite)
+            max_rot_angle = MAX ( max_rot_angle , ASIN(ABS(grid%sina(i,j)))/DEGRAD )
+         END DO
+      END DO
+#if ( defined(DM_PARALLEL)  &&   ! defined(STUBMPI) )
+      max_rot_angle = wrf_dm_max_real ( max_rot_angle )
+#endif
+      IF ( max_rot_angle .GT. ABS(config_flags%max_rot_angle_gwd) ) THEN
+         WRITE ( a_message , FMT='(A,F5.2)' ) 'Max projection rotation angle for domain 1 = ',max_rot_angle
+         CALL wrf_message ( a_message ) 
+         WRITE ( a_message , FMT='(A)'      ) 'This projection may not be appropriate for using the gravity wave drag option.'
+         CALL wrf_message ( a_message ) 
+         WRITE ( a_message , FMT='(A)'      ) 'In namelist.input make one of the two following changes:'
+         CALL wrf_message ( a_message ) 
+         WRITE ( a_message , FMT='(A)'      ) ' 1) gwd_opt = 0 '
+         CALL wrf_message ( a_message ) 
+         WRITE ( a_message , FMT='(A,F5.2)' ) ' 2) max_rot_angle_gwd > ',max_rot_angle
+         CALL wrf_message ( a_message ) 
+         WRITE ( a_message , FMT='(A)'      ) '--- ERROR: gwd_opt does not work with this domain'
+         CALL wrf_error_fatal ( a_message ) 
+      END IF
+   END IF
+
+
    IF ( ( MOD (ide-ids,config_flags%parent_grid_ratio) .NE. 0 ) .OR. &
         ( MOD (jde-jds,config_flags%parent_grid_ratio) .NE. 0 ) ) THEN
       WRITE(message, FMT='(A,I2,":  Both MOD(",I4,"-",I1,",",I2,") and MOD(",I4,"-",I1,",",I2,") must = 0" )') &
@@ -203,6 +255,10 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 ! here we check to see if the boundary conditions are set properly
 
    CALL boundary_condition_check( config_flags, bdyzone, error, grid%id )
+! make sure that topo_wind option has var_sso data available
+    IF ((config_flags%topo_wind .EQ. 1) .AND. (.NOT. grid%got_var_sso)) THEN
+      CALL wrf_error_fatal ("topo_wind requires VAR_SSO data")
+    ENDIF
 
 !kludge - need to stop CG from resetting precip and phys tendencies to zero
 !         when we are in here due to a nest being spawned, we want to still
@@ -223,109 +279,66 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
        first_trip_for_this_domain = .TRUE.
    ENDIF
 
+      ! Print out the maximum map scale factor on the coarse domain 
+
+      IF ( ( first_trip_for_this_domain ) .AND. ( grid%id .EQ. 1 ) .AND. &
+           ( .NOT. config_flags%polar ) ) THEN
+         max_mf = grid%msft(its,jts)
+         DO j=jts,MIN(jde-1,jte)
+            DO i=its,MIN(ide-1,ite)
+               max_mf = MAX ( max_mf , grid%msft(i,j) )
+            END DO
+         END DO
+#if ( defined(DM_PARALLEL)  &&   ! defined(STUBMPI) )
+         max_mf = wrf_dm_max_real ( max_mf )
+#endif
+         WRITE ( a_message , FMT='(A,F5.2,A)' ) 'Max map factor in domain 1 = ',max_mf, &
+                                                '. Scale the dt in the model accordingly.'
+         CALL wrf_message ( a_message ) 
+      END IF
+
+    if(config_flags%cycling) then
+! Clear the buckets for diagnostics at initial time
+       DO j = jts,min(jte,jde-1)
+       DO i = its, min(ite,ide-1)
+            grid%prec_acc_nc(i,j) = 0.
+            grid%snow_acc_nc(i,j)  = 0.
+            grid%sfcrunoff  (i,j) = 0.
+            grid%udrunoff   (i,j) = 0.
+! acsnow, and acrunoff are run-total
+            grid%acrunoff   (i,j) = 0.
+            grid%acsnow     (i,j) = 0.
+       ENDDO
+       ENDDO
+    endif
+
 !   --- SETUP AND INITIALIZE STOCHASTIC PERTURBATION SCHEMES ---
 
-   IF ( first_trip_for_this_domain ) THEN
-     grid%did_stoch = .FALSE.
+   IF ( grid%itimestep .EQ. 0 ) THEN
+      first_trip_for_this_domain = .TRUE.
+   ELSE
+      first_trip_for_this_domain = .FALSE.
    END IF
 
-   IF ((( grid%id == 1) .AND. (.NOT. grid%did_stoch)) .AND. &
-       (( grid%skebs_on== 1) .OR.( grid%sppt_on== 1) .OR. ( grid%rand_perturb_on== 1))) THEN
-
-     grid%did_stoch = .TRUE.
-
-     IF (grid%skebs_on==1) then
-
-! Initialize SKEBS
-!    Initialize streamfunction (1)
-     if (.not.config_flags%restart) then 
-         call rand_seed (config_flags, grid%ISEED_SKEBS, grid%iseedarr_skebs , kms, kme)
-     endif
-     call SETUP_RAND_PERTURB('W',                                         &
-                       grid%skebs_vertstruc,config_flags%restart,         &
-                       grid%SPSTREAM_AMP,                                 &
-                       grid%SPSTREAMFORCS,grid%SPSTREAMFORCC,grid%ALPH_PSI,&
-                       grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPUV,     &
-                       grid%KMINFORCT,grid%KMAXFORCT,                     &
-                       grid%LMINFORCT,grid%LMAXFORCT,                     &
-                       grid%KMAXFORCTH,grid%LMAXFORCTH,                   &
-                       grid%time_step,grid%DX,grid%DY,                    &
-                       grid%gridpt_stddev_sppt,                           &
-                       grid%lengthscale_sppt,                             &
-                       grid%timescale_sppt,                               &
-                       grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI,               &
-                       grid%REXPONENT_PSI,                                &
-                       ids, ide, jds, jde, kds, kde,                      &
-                       ims, ime, jms, jme, kms, kme,                      &
-                       its, ite, jts, jte, kts, kte                       )
-!    Initialize potential temperature (2)
-     call SETUP_RAND_PERTURB('T',                                         &
-                       grid%skebs_vertstruc,config_flags%restart,     &
-                       grid%SPT_AMP,                                      &
-                       grid%SPTFORCS,grid%SPTFORCC,grid%ALPH_T,           &
-                       grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT,     &
-                       grid%KMINFORCT,grid%KMAXFORCT,                     &
-                       grid%LMINFORCT,grid%LMAXFORCT,                     &
-                       grid%KMAXFORCTH,grid%LMAXFORCTH,                   &
-                       grid%time_step,grid%DX,grid%DY,                    &
-                       grid%gridpt_stddev_sppt,                           &
-                       grid%lengthscale_sppt,                             &
-                       grid%timescale_sppt,                               &
-                       grid%TOT_BACKSCAT_T,grid%ZTAU_T,                   &
-                       grid%REXPONENT_T,                                  &
-                       ids, ide, jds, jde, kds, kde,                      &
-                       ims, ime, jms, jme, kms, kme,                      &
-                       its, ite, jts, jte, kts, kte                       )
-     ENDIF
-
-IF (grid%sppt_on==1) then
-! Initialize SPPT (3)
-     if (.not.config_flags%restart) then ! set random number seed (else  iseedarray is read in from restart files)
-         call rand_seed (config_flags, grid%ISEED_SPPT, grid%iseedarr_sppt  , kms, kme)
-     endif
-     call SETUP_RAND_PERTURB('P',                                         &
-                       grid%sppt_vertstruc,config_flags%restart,          &
-                       grid%SPPT_AMP,                                     &
-                       grid%SPPTFORCC,grid%SPPTFORCS,grid%ALPH_SPPT,      &
-                       grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT,     &
-                       grid%KMINFORCT,grid%KMAXFORCT,                     &
-                       grid%LMINFORCT,grid%LMAXFORCT,                     &
-                       grid%KMAXFORCTH,grid%LMAXFORCTH,                   &
-                       grid%time_step,grid%DX,grid%DY,                    &
-                       grid%gridpt_stddev_sppt,                           &
-                       grid%lengthscale_sppt,                             &
-                       grid%timescale_sppt,                               &
-                       grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI,               &
-                       grid%REXPONENT_PSI,                                &
-                       ids, ide, jds, jde, kds, kde,                      &
-                       ims, ime, jms, jme, kms, kme,                      &
-                       its, ite, jts, jte, kts, kte                       )
-     ENDIF
-
-! Initialize RAND_PERTURB (4)
-     IF (grid%rand_perturb_on==1) then
-     if (.not.config_flags%restart) then ! set random number seed (else  iseedarray is read in from restart files)
-         call rand_seed (config_flags, grid%ISEED_RAND_PERT, grid%iseedarr_rand_pert  , kms, kme)
-     endif
-     call SETUP_RAND_PERTURB('R',                                         &
-                       grid%rand_pert_vertstruc,config_flags%restart,     &
-                       grid%SP_AMP,                                       &
-                       grid%SPFORCC,grid%SPFORCS,grid%ALPH_RAND,          &
-                       grid%VERTSTRUCC,grid%VERTSTRUCS,grid%VERTAMPT,     &
-                       grid%KMINFORCT,grid%KMAXFORCT,                     &
-                       grid%LMINFORCT,grid%LMAXFORCT,                     &
-                       grid%KMAXFORCTH,grid%LMAXFORCTH,                   &
-                       grid%time_step,grid%DX,grid%DY,                    &
-                       grid%gridpt_stddev_rand_pert,                      &
-                       grid%lengthscale_rand_pert,                        &
-                       grid%timescale_rand_pert,                          &
-                       grid%TOT_BACKSCAT_PSI,grid%ZTAU_PSI,               &
-                       grid%REXPONENT_PSI,                                &
-                       ids, ide, jds, jde, kds, kde,                      &
-                       ims, ime, jms, jme, kms, kme,                      &
-                       its, ite, jts, jte, kts, kte                       )
-     ENDIF
-     ENDIF ! skebs or sppt or rand_perturb
+   IF ( .not. ( config_flags%restart .or. grid%moved .or. config_flags%hrrr_cycling) ) THEN
+       grid%itimestep=0
+   ENDIF
+
+   IF ( config_flags%restart .or. grid%moved .or. config_flags%hrrr_cycling) THEN 
+       first_trip_for_this_domain = .TRUE.
+   ENDIF
+
+   CALL INITIALIZE_STOCH  (grid, config_flags,                  &    
+                           first_trip_for_this_domain,          &    
+                           ips, ipe, jps, jpe, kps, kpe,        &    
+                           ids, ide, jds, jde, kds, kde,        &    
+                           ims, ime, jms, jme, kms, kme,        &    
+                           its, ite, jts, jte, kts, kte,        &    
+                           imsx, imex, jmsx, jmex, kmsx, kmex,  &
+                           ipsx, ipex, jpsx, jpex, kpsx, kpex,  &
+                           imsy, imey, jmsy, jmey, kmsy, kmey,  &
+                           ipsy, ipey, jpsy, jpey, kpsy, kpey   )
+
 !   --- END SETUP STOCHASTIC PERTURBATION SCHEMES ----------
 
 
@@ -550,6 +563,34 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
       !  the half eta levels and the base-profile surface pressure.  Compute 1/rho
       !  from equation of state.  The potential temperature is a perturbation from t0.
 
+      DO k = 1, kte
+#if  !( HYBRID_COORD==1 )
+         grid%c1f(k) = 1.
+         grid%c2f(k) = 0.
+         grid%c3f(k) = grid%znw(k)
+         grid%c4f(k) = 0.
+         grid%c1h(k) = 1.
+         grid%c2h(k) = 0.
+         grid%c3h(k) = grid%znu(k)
+         grid%c4h(k) = 0.
+#elif ( HYBRID_COORD==1 )
+         IF ( grid%c1f(1) .NE. 1. ) THEN
+            CALL wrf_debug ( 0 , '---- WARNING : Maybe old non-HVC input, setting default 1d array values for TF' )
+            IF ( grid%hybrid_opt .NE. 0 ) THEN
+               CALL wrf_error_fatal ( '---- Error : Cannot use old input and try to use hybrid vertical coordinate option' )
+            END IF
+            grid%c1f(k) = 1.
+            grid%c2f(k) = 0.
+            grid%c3f(k) = grid%znw(k)
+            grid%c4f(k) = 0.
+            grid%c1h(k) = 1.
+            grid%c2h(k) = 0.
+            grid%c3h(k) = grid%znu(k)
+            grid%c4h(k) = 0.
+         END IF
+#endif
+      END DO
+
       DO j = jts, MIN(jte,jde-1)
          DO i = its, MIN(ite,ide-1)
 
@@ -563,19 +604,22 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
             p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 )
 
             DO k = 1, kte-1
+#if  !( HYBRID_COORD==1 )
                grid%pb(i,k,j) = grid%znu(k)*(p_surf - grid%p_top) + grid%p_top
+#elif ( HYBRID_COORD==1 )
+               grid%pb(i,k,j) = grid%c3h(k)*(p_surf - grid%p_top) + grid%c4h(k) + grid%p_top
+#endif
                temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) )
                IF ( grid%pb(i,k,j) .LT. p_strat ) THEN
                   temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat )
                ENDIF
                grid%t_init(i,k,j) = temp*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
-!              grid%t_init(i,k,j) = (t00 + A*LOG(grid%pb(i,k,j)/p00))*(p00/grid%pb(i,k,j))**(r_d/cp) - t0
                grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
             END DO
 
             !  Base state mu is defined as base state surface pressure minus grid%p_top
 
-            grid%mub(i,j) = p_surf - grid%p_top
+            grid%MUB(i,j) = p_surf - grid%p_top
 
             !  Integrate base geopotential, starting at terrain elevation.  This assures that
             !  the base state is in exact hydrostatic balance with respect to the model equations.
@@ -584,14 +628,21 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
             grid%phb(i,1,j) = grid%ht(i,j) * g
 
             IF ( config_flags%hypsometric_opt .EQ. 1 ) THEN
-               DO k  = 2,kte
-                  grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+               DO kk  = 2,kte
+                  k = kk - 1
+                  grid%phb(i,kk,j) = grid%phb(i,kk-1,j) - grid%dnw(kk-1)*grid%mub(i,j)*grid%alb(i,kk-1,j)
                END DO
             ELSE IF ( config_flags%hypsometric_opt .EQ. 2 ) THEN
                DO k  = 2,kte
+#if  !( HYBRID_COORD==1 )
                   pfu = grid%mub(i,j)*grid%znw(k)   + grid%p_top
                   pfd = grid%mub(i,j)*grid%znw(k-1) + grid%p_top
                   phm = grid%mub(i,j)*grid%znu(k-1) + grid%p_top
+#elif ( HYBRID_COORD==1 )
+                  pfu = grid%c3f(k  )*grid%MUB(i,j) + grid%c4f(k  ) + grid%p_top
+                  pfd = grid%c3f(k-1)*grid%MUB(i,j) + grid%c4f(k-1) + grid%p_top
+                  phm = grid%c3h(k-1)*grid%MUB(i,j) + grid%c4h(k-1) + grid%p_top
+#endif
                   grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu)
                END DO
             END IF
@@ -630,7 +681,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
        DO j = jts,min(jte,jde-1)
        DO i = its, min(ite,ide-1)
            IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN
-             grid%mu_1(i,j)=grid%mu_2(i,j)
+             grid%MU_1(i,j)=grid%MU_2(i,j)
            ENDIF
        ENDDO
        ENDDO
@@ -644,7 +695,11 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
      DO k = kts,kte-1
      DO i = its, min(ite,ide-1)
        IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN
+#if  !( HYBRID_COORD==1 )
          grid%pb(i,k,j) = grid%znu(k)*grid%mub(i,j)+grid%p_top
+#elif ( HYBRID_COORD==1 )
+         grid%pb(i,k,j) = grid%c3h(k  )*grid%MUB(i,j) + grid%c4h(k  ) + grid%p_top
+#endif
          grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
        ENDIF
      ENDDO
@@ -656,7 +711,11 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
         DO k = kts,kte-1
         DO i = its, min(ite,ide-1)
           IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN
+#if  !( HYBRID_COORD==1 )
             grid%pb(i,k,j) = grid%znu(k)*grid%mub(i,j)+grid%p_top
+#elif ( HYBRID_COORD==1 )
+            grid%pb(i,k,j) = grid%c3h(k  )*grid%MUB(i,j) + grid%c4h(k  ) + grid%p_top
+#endif
             temp = MAX ( tiso, t00 + A*LOG(grid%pb(i,k,j)/p00) )
             IF ( grid%pb(i,k,j) .LT. p_strat ) THEN
                temp = tiso + A_strat * LOG ( grid%pb(i,k,j)/p_strat )
@@ -677,14 +736,21 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
        DO i = its, min(ite,ide-1)               
         grid%phb(i,1,j) = grid%ht(i,j) * g
         IF ( config_flags%hypsometric_opt .EQ. 1 ) THEN
-           DO k  = 2,kte
-              grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+           DO kk  = 2,kte
+              k = kk - 1
+              grid%phb(i,kk,j) = grid%phb(i,kk-1,j) - grid%dnw(kk-1)*grid%mub(i,j)*grid%alb(i,kk-1,j)
            END DO
         ELSE IF ( config_flags%hypsometric_opt .EQ. 2 ) THEN
            DO k  = 2,kte
+#if  !( HYBRID_COORD==1 )
               pfu = grid%mub(i,j)*grid%znw(k)   + grid%p_top
               pfd = grid%mub(i,j)*grid%znw(k-1) + grid%p_top
               phm = grid%mub(i,j)*grid%znu(k-1) + grid%p_top
+#elif ( HYBRID_COORD==1 )
+              pfu = grid%c3f(k  )*grid%MUB(i,j) + grid%c4f(k  ) + grid%p_top
+              pfd = grid%c3f(k-1)*grid%MUB(i,j) + grid%c4f(k-1) + grid%p_top
+              phm = grid%c3h(k-1)*grid%MUB(i,j) + grid%c4h(k-1) + grid%p_top
+#endif
               grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu)
             END DO
           ENDIF
@@ -698,7 +764,11 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
            DO k = kts,kte-1
            DO i = its, min(ite,ide-1)
              IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN
+#if  !( HYBRID_COORD==1 )
                grid%pb(i,k,j) = grid%znu(k)*grid%mub(i,j)+grid%p_top
+#elif ( HYBRID_COORD==1 )
+               grid%pb(i,k,j) = grid%c3h(k  )*grid%MUB(i,j) + grid%c4h(k  ) + grid%p_top
+#endif
                grid%alb(i,k,j) = -grid%rdnw(k)*(grid%phb(i,k+1,j)-grid%phb(i,k,j))/grid%mub(i,j)
                grid%t_init(i,k,j) = grid%alb(i,k,j)*(p1000mb/r_d)/((grid%pb(i,k,j)/p1000mb)**cvpm) - t0
              ENDIF
@@ -710,7 +780,11 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
            DO k = kts,kte-1
            DO i = its, min(ite,ide-1)
              IF ( grid%imask_nostag(i,j) .EQ. 1 ) THEN
+#if  !( HYBRID_COORD==1 )
                grid%pb(i,k,j) = grid%znu(k)*grid%mub(i,j)+grid%p_top
+#elif ( HYBRID_COORD==1 )
+               grid%pb(i,k,j) = grid%c3h(k  )*grid%MUB(i,j) + grid%c4h(k  ) + grid%p_top
+#endif
                grid%alb(i,k,j) = (r_d/p1000mb)*(grid%t_init(i,k,j)+t0)*(grid%pb(i,k,j)/p1000mb)**cvpm
              ENDIF
            ENDDO
@@ -722,8 +796,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
            DO j = jts,min(jte,jde-1)
            DO i = its, min(ite,ide-1)
             grid%phb(i,1,j) = grid%ht(i,j) * g 
-            DO k  = 2,kte
-              grid%phb(i,k,j) = grid%phb(i,k-1,j) - grid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+            DO kk  = 2,kte
+              k = kk - 1 
+              grid%phb(i,kk,j) = grid%phb(i,kk-1,j) - grid%dnw(kk-1)*grid%mub(i,j)*grid%alb(i,kk-1,j)
             END DO
            ENDDO
            ENDDO
@@ -785,9 +860,15 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
        DO j=jts,min(jte,jde-1)
        DO k=kts,kte-1
        DO i=its,min(ite,ide-1)
+#if  !( HYBRID_COORD==1 )
           pfu = (grid%mub(i,j)+grid%mu_1(i,j))*grid%znw(k+1)+grid%p_top
           pfd = (grid%mub(i,j)+grid%mu_1(i,j))*grid%znw(k)  +grid%p_top
           phm = (grid%mub(i,j)+grid%mu_1(i,j))*grid%znu(k)  +grid%p_top
+#elif ( HYBRID_COORD==1 )
+          pfu = grid%c3f(k+1)*(grid%MUB(i,j)+grid%MU_1(i,j)) + grid%c4f(k+1) + grid%p_top
+          pfd = grid%c3f(k  )*(grid%MUB(i,j)+grid%MU_1(i,j)) + grid%c4f(k  ) + grid%p_top
+          phm = grid%c3h(k  )*(grid%MUB(i,j)+grid%MU_1(i,j)) + grid%c4h(k  ) + grid%p_top
+#endif
           grid%al(i,k,j) = (grid%ph_1(i,k+1,j)-grid%ph_1(i,k,j)+grid%phb(i,k+1,j)-grid%phb(i,k,j)) &
                             /phm/LOG(pfd/pfu)-grid%alb(i,k,j)
        ENDDO
@@ -812,7 +893,11 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
        DO j=jts,min(jte,jde-1)
           DO i=its,min(ite,ide-1)
              p_surf = p00 * EXP ( -t00/a + ( (t00/a)**2 - 2.*g*grid%ht(i,j)/a/r_d ) **0.5 )
+#if  !( HYBRID_COORD==1 )
              grid%p_hyd_w(i,1,j) = grid%p(i,1,j) + grid%znw(1)*(p_surf - grid%p_top) + grid%p_top
+#elif ( HYBRID_COORD==1 )
+             grid%p_hyd_w(i,1,j) = grid%p(i,1,j) + grid%c3f(1)*(p_surf - grid%p_top) + grid%c4f(1) + grid%p_top
+#endif
              DO k=kts+1,kte
                 grid%p_hyd_w(i,k,j) = ( 2.*(grid%p(i,k-1,j)+grid%pb(i,k-1,j)) - grid%p_hyd_w(i,k-1,j) )
              ENDDO
@@ -821,8 +906,12 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
     ELSE
        DO j=jts,min(jte,jde-1)
           DO i=its,min(ite,ide-1)
-             p_surf = grid%mub(i,j)+grid%p_top
+             p_surf = grid%MUB(i,j)+grid%p_top
+#if  !( HYBRID_COORD==1 )
              grid%p_hyd_w(i,1,j) = grid%p(i,1,j) + grid%znw(1)*(p_surf - grid%p_top) + grid%p_top
+#elif ( HYBRID_COORD==1 )
+             grid%p_hyd_w(i,1,j) = grid%p(i,1,j) + grid%c3f(1)*(p_surf - grid%p_top) + grid%c4f(1) + grid%p_top
+#endif
              DO k=kts+1,kte
                 grid%p_hyd_w(i,k,j) = ( 2.*(grid%p(i,k-1,j)+grid%pb(i,k-1,j)) - grid%p_hyd_w(i,k-1,j) )
              ENDDO
@@ -844,13 +933,13 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
        ( ( config_flags%input_from_hires ) .OR. ( config_flags%input_from_file ) ) ) THEN
       DO j = jts, MIN(jte,jde-1)
          DO i = its, MIN(ite,ide-1)
-            grid%mu_2(i,j) = grid%mu_2(i,j) + grid%al(i,1,j) / ( grid%alt(i,1,j) * grid%alb(i,1,j) ) * &
+            grid%MU_2(i,j) = grid%MU_2(i,j) + grid%al(i,1,j) / ( grid%alt(i,1,j) * grid%alb(i,1,j) ) * &
                                     g * ( grid%ht(i,j) - grid%ht_fine(i,j) )
          END DO
        END DO
        DO j = jts,min(jte,jde-1)
        DO i = its, min(ite,ide-1)
-          grid%mu_1(i,j)=grid%mu_2(i,j)
+          grid%MU_1(i,j)=grid%MU_2(i,j)
        ENDDO
        ENDDO
 
@@ -868,7 +957,6 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 ! MPDT is the call frequency for microphysics in minutes (0 means every step)
    MPDT = 0.
 
-!tgs
    IF(config_flags%cycling) THEN
        start_of_simulation = .true.
 !  print *,'cycling, start_of_simulation -->',config_flags%cycling, start_of_simulation
@@ -884,6 +972,23 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
         ( ( grid%dfi_opt .EQ. DFI_NODFI ) .OR. ( grid%dfi_stage .EQ. DFI_FST ) ) ) THEN
 
 !  Calculate any variables that were not set
+!BPR BEGIN
+!     This subroutine is called more than once at the first time step for a
+!     given domain.  The following if statement is to prevent the code in
+!     the if statement from executing more than once per domain at the
+!     beginning of the model run (since last_step_update=-1 the first time
+!     this is reached and should be =0 after this).
+!     Without this if statement, when this code was executed for the second
+!     time it can result in grid%dt being set incorrectly.
+!     -This is because grid%dt will be set equal to grid%starting_time_step
+!      which ignores a possible denominator in the starting time step.
+!     -The first time this code is reached is also does this, but then the
+!      call to adapt_timestep correct this
+!     -Subsequent times this code is reached adapt_timestep will not correct
+!      this because it will recognize that it has already been executed for
+!      this timestep and exit out before doing the calculation.
+
+      if (grid%last_step_updated .NE. grid%itimestep) then
 
       if (grid%starting_time_step == -1) then
          grid%starting_time_step = NINT(4 * MIN(grid%dx,grid%dy) / 1000)
@@ -921,6 +1026,8 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
       CALL wrf_dm_maxval(grid%max_msftx, idex, jdex)
       CALL wrf_dm_maxval(grid%max_msfty, idex, jdex)
 #endif
+      end if
+!BPR END
 
 !     This first call just initializes variables.
 !     If a restart, get initialized variables from restart file
@@ -956,10 +1063,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
 endif
 #endif
 
-!tgs do not need physics initialization for backward DFI integration
     IF ( ( grid%dfi_opt .EQ. DFI_NODFI ) .or. &
           ( ( grid%dfi_stage .NE. DFI_BCK ) .and. &
-          ( grid%dfi_stage .NE. DFI_STARTBCK ) ) ) THEN    !tgs, mods by tah
+          ( grid%dfi_stage .NE. DFI_STARTBCK ) ) ) THEN
 
    DO ij = 1, grid%num_tiles
 
@@ -1044,11 +1150,13 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
                       grid%WSLAKEXY, grid%ZWTXY, grid%WAXY, grid%WTXY, grid%LFMASSXY, grid%RTMASSXY, & ! Optional Noah-MP
                       grid%STMASSXY, grid%WOODXY, grid%STBLCPXY, grid%FASTCPXY,                 &   ! Optional Noah-MP
                       grid%GRAINXY, grid%GDDXY,                                                 &   ! Optional Noah-MP
+                      grid%CROPTYPE, grid%CROPCAT,                                                 &   ! Optional Noah-MP
                       grid%XSAIXY,grid%LAI,                                                     &   ! Optional Noah-MP
                       grid%T2MVXY, grid%T2MBXY, grid%CHSTARXY,                                  &   ! Optional Noah-MP
                       grid%SMOISEQ  ,grid%SMCWTDXY ,grid%RECHXY, grid%DEEPRECHXY, grid%AREAXY,  & ! Optional Noah-MP
                       config_flags%wtddt ,grid%stepwtd ,grid%QRFSXY ,grid%QSPRINGSXY ,grid%QSLATXY, & ! Optional Noah-MP
                       grid%FDEPTHXY, grid%RIVERBEDXY, grid%EQZWT, grid%RIVERCONDXY, grid%PEXPXY, & ! Optional Noah-MP
+                      grid%rechclim  ,                                                           & ! Optional Noah-MP
                       grid%msftx, grid%msfty,                              &
                       grid%DZR, grid%DZB, grid%DZG,                          & !Optional urban
                       grid%TR_URB2D,grid%TB_URB2D,grid%TG_URB2D,grid%TC_URB2D,    & !Optional urban
@@ -1726,7 +1834,7 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
                 grid%dust_opt,ids,ide, jds,jde, kds,kde,                    &
                 ims,ime, jms,jme, kms,kme,                                  &
                 its,ite, jts,jte, kts,kte-1                                 )
-         case (RACM_SOA_VBS_KPP)
+         case (RACM_SOA_VBS_KPP,RACM_SOA_VBS_AQCHEM_KPP)
              call sum_pm_soa_vbs (                                           &
                  grid%alt, chem, grid%h2oaj, grid%h2oai,                                   &
                  grid%pm2_5_dry, grid%pm2_5_water, grid%pm2_5_dry_ec, grid%pm10,                &
@@ -1960,6 +2068,12 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read &
    CALL wrf_debug ( 100 , 'start_domain_em: After call to fire_driver_em_init' )
 endif
 
+if( grid%traj_opt /= no_trajectory ) then
+     call trajectory_init( grid, config_flags, &
+                           ims,ime, jms,jme, kms,kme )
+     CALL wrf_debug ( 100 , 'start_domain_em: After call to trajectory_init' )
+endif
+
 
      CALL wrf_debug ( 100 , 'start_domain_em: Returning' )
 
@@ -2023,6 +2137,7 @@ SUBROUTINE rebalance_cycl ( grid  &
       REAL :: p_surf ,  pd_surf, p_surf_int , pb_int , ht_hold
       REAL :: qvf , qvf1 , qvf2, qtot
       REAL :: pfu, pfd, phm
+      REAL :: z0, z1, z2, w1, w2
 
       !  Local domain indices and counters.
 
@@ -2033,7 +2148,7 @@ SUBROUTINE rebalance_cycl ( grid  &
                                      ims, ime, jms, jme, kms, kme, &
                                      its, ite, jts, jte, kts, kte, &
                                      ips, ipe, jps, jpe, kps, kpe, &
-                                     i, j, k, ispe, ktf
+                                     i, j, k, kk, ispe, ktf
 
       SELECT CASE ( model_data_order )
          CASE ( DATA_ORDER_ZXY )
@@ -2102,41 +2217,43 @@ SUBROUTINE rebalance_cycl ( grid  &
                !  equation) down from the top to get the pressure perturbation.  First get the pressure
                !  perturbation, moisture, and inverse density (total and perturbation) at the top-most level.
 
-               k = kte - 1
+               kk = kte - 1
+               k=kk+1
 
                qtot = 0.
                DO ispe=PARAM_FIRST_SCALAR,n_moist
-                 qtot = qtot + 0.5*(moist(i,k,j,ispe)+moist(i,k,j,ispe))
+                 qtot = qtot + 0.5*(moist(i,kk,j,ispe)+moist(i,kk,j,ispe))
                ENDDO
                qvf2 = 1./(1.+qtot)
                qvf1 = qtot*qvf2
 
-               grid%p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
-               qvf = 1.+rvovrd*moist(i,k,j,P_QV)
-               grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf*         &
-                      (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
-               grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
-               grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
+               grid%p(i,kk,j) = - 0.5*(grid%Mu_2(i,j)+qvf1*grid%Mub(i,j))/grid%rdnw(kk)/qvf2
+               qvf = 1.+rvovrd*moist(i,kk,j,P_QV)
+               grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf*         &
+                      (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
+               grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
+               grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
 
 
                !  Now, integrate down the column to compute the pressure perturbation, and diagnose the two
                !  inverse density fields (total and perturbation).
 
-        DO k=kte-2,kts,-1
+        DO kk=kte-2,kts,-1
+             k = kk + 1
 
-            qtot = 0.
+             qtot = 0.
              DO ispe=PARAM_FIRST_SCALAR,n_moist
-               qtot = qtot + 0.5*(  moist(i,k  ,j,ispe) + moist(i,k+1,j,ispe) )
+               qtot = qtot + 0.5*(  moist(i,kk  ,j,ispe) + moist(i,kk+1,j,ispe) )
              ENDDO
                qvf2 = 1./(1.+qtot)
                qvf1 = qtot*qvf2
-               grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_2(i,j) +       &
-                               qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
-               qvf = 1. + rvovrd*moist(i,k,j,P_QV)
-               grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* &
-                           (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
-               grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
-               grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
+               grid%p(i,kk,j) = grid%p(i,kk+1,j) - (grid%Mu_2(i,j) +       &
+                               qvf1*grid%Mub(i,j))/qvf2/grid%rdn(kk+1)
+               qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
+               grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
+                           (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
+               grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
+               grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
         ENDDO
 
                !  This is the hydrostatic equation used in the model after the
@@ -2145,11 +2262,12 @@ SUBROUTINE rebalance_cycl ( grid  &
                !  geopotential.
 
             IF (grid%hypsometric_opt == 1) THEN
-                  DO k  = 2,kte
-                     grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - &
-                                   grid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,k-1,j) &
-                                 + grid%mu_2(i,j)*grid%alb(i,k-1,j) )
-                     grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j)
+                  DO kk  = 2,kte
+                     k = kk - 1
+                     grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - &
+                                   grid%dnw(kk-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,kk-1,j) &
+                                 + grid%mu_2(i,j)*grid%alb(i,kk-1,j) )
+                     grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j)
                   END DO
             ELSE IF (grid%hypsometric_opt == 2) THEN
                 ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is
@@ -2160,9 +2278,15 @@ SUBROUTINE rebalance_cycl ( grid  &
 
                   grid%ph_2(i,1,j) = grid%phb(i,1,j)
                   DO k = 2,kte
+#if  !( HYBRID_COORD==1 )
                      pfu = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k)   + grid%p_top
                      pfd = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k-1) + grid%p_top
                      phm = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k-1) + grid%p_top
+#elif ( HYBRID_COORD==1 )
+                     pfu = grid%c3f(k  )*(grid%MUB(i,j)+grid%MU_2(i,j)) + grid%c4f(k  ) + grid%p_top
+                     pfd = grid%c3f(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j)) + grid%c4f(k-1) + grid%p_top
+                     phm = grid%c3h(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j)) + grid%c4h(k-1) + grid%p_top
+#endif
                      grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu)
                   END DO
 
@@ -2177,32 +2301,34 @@ SUBROUTINE rebalance_cycl ( grid  &
 
        ELSE  ! n_moist
 
-         k = kte - 1
+         kk = kte - 1
+               k = kk + 1 
 
-               qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV))
+               qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk,j,P_QV))
                qvf2 = 1./(1.+qvf1)
                qvf1 = qvf1*qvf2
 
-               grid%p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
-               qvf = 1. + rvovrd*moist(i,k,j,P_QV)
-               grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf    &
-                           *(((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
-               grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
-               grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
+               grid%p(i,kk,j) = - 0.5*(grid%Mu_2(i,j)+qvf1*grid%Mub(i,j))/grid%rdnw(kk)/qvf2
+               qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
+               grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf    &
+                           *(((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
+               grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
+               grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
 
             !  Now, integrate down the column to compute the pressure perturbation, and diagnose the two
             !  inverse density fields (total and perturbation).
 
-           DO k=kte-2,kts,-1
-               qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV))
+           DO kk=kte-2,kts,-1
+               k = kk + 1 
+               qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk+1,j,P_QV))
                qvf2 = 1./(1.+qvf1)
                qvf1 = qvf1*qvf2
-               grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_2(i,j) + qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
-               qvf = 1. + rvovrd*moist(i,k,j,P_QV)
-               grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* &
-                           (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
-               grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
-               grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
+               grid%p(i,kk,j) = grid%p(i,kk+1,j) - (grid%Mu_2(i,j) + qvf1*grid%Mub(i,j))/qvf2/grid%rdn(kk+1)
+               qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
+               grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
+                           (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
+               grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
+               grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
            ENDDO
                !  This is the hydrostatic equation used in the model after the small timesteps.  In
                !  the model, grid%al (inverse density) is computed from the geopotential.
@@ -2224,9 +2350,15 @@ SUBROUTINE rebalance_cycl ( grid  &
 
                grid%ph_2(i,1,j) = grid%phb(i,1,j)
                DO k = 2,kte
+#if  !( HYBRID_COORD==1 )
                   pfu = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k)   + grid%p_top
                   pfd = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k-1) + grid%p_top
                   phm = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k-1) + grid%p_top
+#elif ( HYBRID_COORD==1 )
+                  pfu = grid%c3f(k  )*(grid%MUB(i,j)+grid%MU_2(i,j)) + grid%c4f(k  ) + grid%p_top
+                  pfd = grid%c3f(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j)) + grid%c4f(k-1) + grid%p_top
+                  phm = grid%c3h(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j)) + grid%c4h(k-1) + grid%p_top
+#endif
                   grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu)
                END DO
 
@@ -2241,6 +2373,14 @@ SUBROUTINE rebalance_cycl ( grid  &
             END IF ! hypsometric
        ENDIF ! nmoist
 
+! update surface pressure PSFC (needed for post-processing):
+               z0 = grid%ph0(i,1,j)/g
+               z1 = 0.5*(grid%ph0(i,1,j)+grid%ph0(i,2,j))/g
+               z2 = 0.5*(grid%ph0(i,2,j)+grid%ph0(i,3,j))/g
+               w1 = (z0 - z2)/(z1 - z2)
+               w2 = 1. - w1
+               grid%psfc(i,j) = w1*(grid%p(i,1,j)+grid%pb(i,1,j))+w2*(grid%p(i,2,j)+grid%pb(i,2,j))
+
          END DO !i
         ENDDO !j
 
diff --git a/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F b/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F
index b37188de..f2e6f4b4 100644
--- a/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F
+++ b/wrfv2_fire/dyn_nmm/module_BNDRY_COND.F
@@ -36,6 +36,14 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
      &                ,V_BTXS, V_BTXE, V_BTYS, V_BTYE                   &
      &                ,Q2_BTXS, Q2_BTXE, Q2_BTYS, Q2_BTYE               &
      &                ,PD,T,Q,Q2,PINT                                   &
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+#ifdef IDEAL_NMM_TC
+     &                ,SM_BXS, SM_BXE, SM_BYS, SM_BYE                   &
+     &                ,SM_BTXS, SM_BTXE, SM_BTYS, SM_BTYE               &
+     &                ,SM                                               &
+     &                ,TH                                               &
+#endif
+!!END: LSM changes for LANDFALL : Subashini 7/27/2016
      &                ,SPEC_BDY_WIDTH,Z                                 &  
      &                ,IHE,IHW,IVE,IVW                                  &
      &                ,IDS,IDE,JDS,JDE,KDS,KDE                          &
@@ -119,7 +127,13 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
       REAL,DIMENSION(IMS:IME,1,SPEC_BDY_WIDTH)                          &
      &                           ,INTENT(INOUT) :: PD_BYS, PD_BYE       &
      &                                            ,PD_BTYS,PD_BTYE
-!
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+#ifdef IDEAL_NMM_TC
+      REAL,DIMENSION(IMS:IME,1,SPEC_BDY_WIDTH)                          &
+     &                           ,INTENT(INOUT) :: SM_BYS, SM_BYE       &
+     &                                            ,SM_BTYS,SM_BTYE
+#endif
+!!END: LSM changes for LANDFALL : Subashini 7/27/2016
       REAL,DIMENSION(IMS:IME,KMS:KME,SPEC_BDY_WIDTH)                   &
      &                           ,INTENT(INOUT) :: T_BYS, T_BYE        &
      &                                            ,U_BYS, U_BYE        &
@@ -135,7 +149,13 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
       REAL,DIMENSION(JMS:JME,1,SPEC_BDY_WIDTH)                         &
      &                           ,INTENT(INOUT) :: PD_BXS, PD_BXE      &
      &                                            ,PD_BTXS,PD_BTXE
-
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+#ifdef IDEAL_NMM_TC
+      REAL,DIMENSION(JMS:JME,1,SPEC_BDY_WIDTH)                         &
+     &                           ,INTENT(INOUT) :: SM_BXS, SM_BXE      &
+     &                                            ,SM_BTXS,SM_BTXE
+#endif
+!!END: LSM changes for LANDFALL : Subashini 7/27/2016
       REAL,DIMENSION(JMS:JME,KMS:KME,SPEC_BDY_WIDTH)                   &
      &                           ,INTENT(INOUT) :: T_BXS, T_BXE        &
      &                                            ,U_BXS, U_BXE        &
@@ -151,7 +171,11 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
 !
       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: RES
       REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: PD
-!
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+#ifdef IDEAL_NMM_TC
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: SM,TH
+#endif
+!!END: LSM changes for LANDFALL : Subashini 7/27/2016
       REAL,DIMENSION(IMS:IME,JMS:JME,KMS:KME),INTENT(INOUT) ::          &
      &                                                         PINT,Q   &
      &                                                        ,Q2,T,Z
@@ -289,6 +313,14 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
             IF(MOD(J,2)==1)THEN
               PD_BXS(J,1,IB)=PD_BXS(J,1,IB)+PD_BTXS(J,1,IB)*DT
               PD(II,J)=PD_BXS(J,1,IB)
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+#ifdef IDEAL_NMM_TC
+              IF(GRIDID.GT.1)THEN
+                SM(II,J)=SM_BXS(J,1,IB)   ! for W-E motion
+!               TH(II,J)=TH_BXS(J,1,IB)
+              ENDIF
+#endif
+!!END: LSM changes for LANDFALL : Subashini 7/27/2016
             ENDIF
           ENDDO
 !
@@ -320,6 +352,14 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
             IF(MOD(J,2)==1)THEN
               PD_BXE(J,1,IB)=PD_BXE(J,1,IB)+PD_BTXE(J,1,IB)*DT
               PD(II,J)=PD_BXE(J,1,IB)
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+#ifdef IDEAL_NMM_TC
+              IF(GRIDID.GT.1)THEN
+                 SM(II,J)=SM_BXE(J,1,IB)    ! for E-W motion
+!                TH(II,J)=TH_BXE(J,1,IB)
+              ENDIF
+#endif
+!!END: LSM changes for LANDFALL : Subashini 7/27/2016
             ENDIF
           ENDDO
 !
@@ -418,6 +458,14 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
             CWK=PD(1,J)
             JJ=J
             PD(1,JJ)=0.25*(PD(1,JJ-1)+PD(2,JJ-1)+PD(1,JJ+1)+PD(2,JJ+1))
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+#ifdef IDEAL_NMM_TC
+           IF(GRIDID.GT.1)THEN
+             SM(1,JJ)=0.5*(SM(1,JJ-1)+SM(1,JJ+1))  ! updates only along W Boundary
+!            TH(IIM-1,JJ)=0.5*(TH(IIM,JJ-1)+TH(IIM,JJ+1))
+           ENDIF
+#endif
+!!END: LSM changes for LANDFALL : Subashini 7/27/2016
 !
 !***  NESTING TEST
 !
@@ -451,6 +499,14 @@ SUBROUTINE MASS_BOUNDARY(GRIDID,NTSD,DT0,NEST,NBC,NBOCO,LAST_TIME,TSPH    &
             JJ=J
             PD(IIM-1,JJ)=0.25*(PD(IIM-1,JJ-1)+PD(IIM,JJ-1)              &
      &                        +PD(IIM-1,JJ+1)+PD(IIM,JJ+1))
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+#ifdef IDEAL_NMM_TC
+           IF(GRIDID.GT.1)THEN
+             SM(IIM-1,JJ)=0.5*(SM(IIM,JJ-1)+SM(IIM,JJ+1))  ! updates only along E Boundary
+!            TH(IIM-1,JJ)=0.5*(TH(IIM,JJ-1)+TH(IIM,JJ+1))
+           ENDIF
+#endif
+!!END: LSM changes for LANDFALL : Subashini 7/27/2016
 !
 !***  NESTING TEST
 !
diff --git a/wrfv2_fire/dyn_nmm/module_IGWAVE_ADJUST.F b/wrfv2_fire/dyn_nmm/module_IGWAVE_ADJUST.F
index 64fa56cd..48a8a610 100644
--- a/wrfv2_fire/dyn_nmm/module_IGWAVE_ADJUST.F
+++ b/wrfv2_fire/dyn_nmm/module_IGWAVE_ADJUST.F
@@ -767,14 +767,18 @@ SUBROUTINE PDTE(                                                  &
       GLOBAL_CHANGE_WRF=TASK_CHANGE/GLB_NPTS
 #endif
 
+      grid%avgPchg=global_change_wrf
+
+! NOTE: These below messages are moved to frame/module_integrate.F,
+! and are merged with the timing information.
 #ifdef DM_PARALLEL
-      if ( MYPE == 0 ) then
-        write(wrf_err_message,*) 'avg global change (hPa/3h): ', GLOBAL_CHANGE_WRF
-        call wrf_debug(1,wrf_err_message)
-      endif
+      ! if ( MYPE == 0 ) then
+      !   write(wrf_err_message,*) 'avg global change (hPa/3h): ', GLOBAL_CHANGE_WRF
+      !   call wrf_debug(1,wrf_err_message)
+      ! endif
 #else
-        write(wrf_err_message,*) 'avg global change (hPa/3h): ', GLOBAL_CHANGE_WRF
-        call wrf_debug(1,wrf_err_message)
+        ! write(wrf_err_message,*) 'avg global change (hPa/3h): ', GLOBAL_CHANGE_WRF
+        ! call wrf_debug(1,wrf_err_message)
 #endif
 
 !
diff --git a/wrfv2_fire/dyn_nmm/module_NEST_UTIL.F b/wrfv2_fire/dyn_nmm/module_NEST_UTIL.F
index db1370b4..1ccda134 100644
--- a/wrfv2_fire/dyn_nmm/module_NEST_UTIL.F
+++ b/wrfv2_fire/dyn_nmm/module_NEST_UTIL.F
@@ -387,6 +387,62 @@ SUBROUTINE MSLP_DIAG (MSLP,PINT,T,Q               &
      ENDDO
 
 END SUBROUTINE MSLP_DIAG
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+#ifdef IDEAL_NMM_TC
+SUBROUTINE MOVE_LAND (SM,TSK                      &
+                     ,SST,FIS                     &
+                     ,PINT,T,Q                    &
+                     ,NTSD                        &
+                     ,IDS,IDE,JDS,JDE,KDS,KDE     &
+                     ,IMS,IME,JMS,JME,KMS,KME     &
+                     ,ITS,ITE,JTS,JTE,KTS,KTE,DIRN)
+
+      USE MODULE_MODEL_CONSTANTS
+      USE MODULE_DM
+
+      IMPLICIT NONE
+
+!     global variables
+
+      INTEGER,INTENT(IN)                                      :: NTSD,DIRN
+
+      INTEGER,INTENT(IN)                                      :: IDS,IDE,JDS,JDE,KDS,KDE   &
+                                                                ,IMS,IME,JMS,JME,KMS,KME   &
+                                                                ,ITS,ITE,JTS,JTE,KTS,KTE
+
+      REAL, DIMENSION(IMS:IME,JMS:JME),         INTENT(INOUT) :: SM,TSK
+      REAL, DIMENSION(IMS:IME,JMS:JME),         INTENT(IN)    :: SST,FIS
+      REAL, DIMENSION(IMS:IME,JMS:JME,KMS:KME), INTENT(IN)    :: PINT,T,Q
+
+!     local variables
+
+      INTEGER                                               :: I,J,K,CNT
+      REAL                                                  :: PSFC,EXNSFC,CAPA,SUMTHS,AVGTHS
+!-----------------------------------------------------------------------------------------------------
+!
+!     Note: make appropriate changes for boundary condition updates in
+!     d02 and d03 by adding "i01rhd=(DownNear)f=(BdyNear)" for SM in the
+!     Registry.NMM_HWRF. Also module_BNDRY_COND.F needs to be updated
+!     for SM. This is subashini's doing for advecting land surface in
+!     idealized framework
+!
+     IF(DIRN == 1) THEN
+      DO J = MAX(JTS,2), MIN(JTE,JDE-1)
+       DO I = MIN(ITE,IDE),MAX(ITS,2),-1
+           SM(I,J)=SM(I-1,J)          ! Motion of land (0) from West to East
+       ENDDO
+      ENDDO
+     ELSE 
+      DO J = MAX(JTS,2), MIN(JTE,JDE-1)
+       DO I = ITS, MIN(ITE,IDE-1)
+           SM(I,J)=SM(I+1,J)          ! Motion of land (0) from East to west
+       ENDDO
+      ENDDO
+     ENDIF
+
+END SUBROUTINE MOVE_LAND
+#endif
+!!END: LSM changes for LANDFALL : Subashini 7/27/2016
 !------------------------------------------------------------------------------------------------------
 SUBROUTINE CALC_BEST_MSLP(BEST_MSLP,MSLP,MEMBRANE_MSLP,FIS &
                          ,IDS,IDE,JDS,JDE,KDS,KDE     &
diff --git a/wrfv2_fire/dyn_nmm/module_NONHY_DYNAM.F b/wrfv2_fire/dyn_nmm/module_NONHY_DYNAM.F
index 7ed66ffa..c1b59ce9 100644
--- a/wrfv2_fire/dyn_nmm/module_NONHY_DYNAM.F
+++ b/wrfv2_fire/dyn_nmm/module_NONHY_DYNAM.F
@@ -29,7 +29,7 @@ SUBROUTINE EPS(NTSD,DT,HYDRO,DX,DY,FAD                            &
                     ,FNS,FEW,FNE,FSE                                    &
                     ,T,U,V,W,W_TOT,Q,CWM                                      &
                     ,DEF3D,HDAC,BARO                                    &
-                    ,WP                                                 &    
+                    ,WP,dwdt_damping_lev                                                 &    
                     ,IHE,IHW,IVE,IVW                                    &
                     ,IDS,IDE,JDS,JDE,KDS,KDE                            &
                     ,IMS,IME,JMS,JME,KMS,KME                            &
@@ -83,6 +83,8 @@ SUBROUTINE EPS(NTSD,DT,HYDRO,DX,DY,FAD                            &
       INTEGER,INTENT(IN) :: NTSD
 !
       REAL,INTENT(IN) :: DT,DY,PDTOP,PT,WP
+! level where starts dwdt damping, read in from namelist
+      real,INTENT(IN) :: dwdt_damping_lev
 !
       REAL,DIMENSION(KMS:KME-1),INTENT(IN) :: DETA1,DETA2,AETA1
 !
@@ -392,6 +394,29 @@ SUBROUTINE EPS(NTSD,DT,HYDRO,DX,DY,FAD                            &
       ENDDO
      endif
 
+!dumping dwdt at stratsphere, Zhan
+
+      if ( dwdt_damping_lev .ge. 0.001 ) then
+        lsltp=0
+        SLTP=(PT+AETA1(KTE-1)*PDTOP+PT+AETA1(KTE)*PDTOP)*0.5
+        DO L=KTE,2,-1
+          PAVG=PT+PDTOP*(AETA1(L)+AETA1(L-1))*0.5
+          ARG=( PAVG-SLTP )/dwdt_damping_lev
+          if(arg.gt.1.) exit
+          why(l)=1.-cos(arg*pi*0.5)**2
+          lsltp=l
+        enddo
+!
+      DO l=lsltp,KTE
+       DO J=MYJS2_P1,MYJE2_P1
+        DO I=MYIS1_P1,MYIE1_P1
+            dwdt(i,j,l)=dwdt(i,j,l)*why(l)
+        ENDDO
+       ENDDO
+      ENDDO
+      endif
+!dumping dwdt at stratsphere, Zhan
+
 !$omp parallel do                                                       &
 !$omp& private(dwdtt,i,j,k)
       DO K=KTS,KTE
diff --git a/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F b/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F
index ea455e3a..394bae6a 100644
--- a/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F
+++ b/wrfv2_fire/dyn_nmm/module_PHYSICS_CALLS.F
@@ -33,6 +33,34 @@ MODULE MODULE_PHYSICS_CALLS
 !
 !-----------------------------------------------------------------------
 !***********************************************************************
+      SUBROUTINE QITEND_FER_HIRES_ADVECT(QI,QRIMEF,QITEND)
+        IMPLICIT NONE
+        REAL, INTENT(INOUT) :: QI, QRIMEF
+        REAL, INTENT(IN) :: QITEND
+        REAL :: F_RIMEF
+        real, parameter :: max_f_rimef = 60.0, min_f_rimef=1.0
+
+        ! For the advected Ferrier-Aligo, we have to handle the QRIMEF
+        ! during tendency updates.
+
+        ! Determine old rime factor from old QI and old QRIMEF:
+        IF(QI0) then
+                   grid%cuprecip_swath(i,j) = grid%cuprecip_swath(i,j) + PCPCOL
+                endif
+             endif
           endif
 #endif
 !
@@ -2868,8 +3013,14 @@ SUBROUTINE CUCNVC(NTSD,DT,NCNVC,NRADS,NRADL                       &
 !
           cps_select: SELECT CASE(config_flags%cu_physics)
 !
-          CASE (KFSCHEME,KFETASCHEME,GDSCHEME,SASSCHEME,MESO_SAS,OSASSCHEME,NSASSCHEME,TIEDTKESCHEME)
-            IF (ETAMP_Regional) THEN
+          CASE (KFSCHEME,KFETASCHEME,GDSCHEME,SASSCHEME,SCALESASSCHEME,OSASSCHEME,NSASSCHEME,TIEDTKESCHEME)
+           IF(config_flags%mp_physics==fer_mp_hires_advect) THEN
+             ! Update QI and QRIMEF:
+             call QITEND_FER_HIRES_ADVECT( &
+                  MOIST_TRANS(I,K,J,P_QI), &
+                  SCALAR(I,J,K,P_QRIMEF), &
+                  RQICUTEN(I,K,J)*DTCNVC)
+            ELSEIF (ETAMP_Regional) THEN
               MOIST_TRANS(I,K,J,P_QS)=MAX(0.,MOIST_TRANS(I,K,J,P_QS)+RQICUTEN(I,K,J)*DTCNVC+RQSCUTEN(I,K,J)*DTCNVC)
             ELSE
               MOIST_TRANS(I,K,J,P_QI)=MAX(0.,MOIST_TRANS(I,K,J,P_QI)+RQICUTEN(I,K,J)*DTCNVC)
diff --git a/wrfv2_fire/dyn_nmm/module_initialize_real.F b/wrfv2_fire/dyn_nmm/module_initialize_real.F
index b7da97f3..3a036704 100644
--- a/wrfv2_fire/dyn_nmm/module_initialize_real.F
+++ b/wrfv2_fire/dyn_nmm/module_initialize_real.F
@@ -847,6 +847,16 @@ SUBROUTINE init_domain_nmm ( grid &
 
      END IF     !   <----- END OF VERTICAL INTERPOLATION PART ---->
 
+     DO j = jts, MIN(jde-1,jte) ! <--- Initialize the arrays from WW/Ocean Biju!
+        DO i = its, MIN(ide-1,ite)
+          grid%scurx(i,j) = 0.0
+          grid%scury(i,j) = 0.0
+          grid%charn(i,j) = 0.0185
+          grid%msang(i,j) = 0.0
+          grid%rchno(i,j) = 1e-03
+          grid%zsig1(i,j) = 20.0
+        END DO
+     END DO           ! <----- END ---->
 
 !! compute SST at each time if updating SST
         if (config_flags%sst_update == 1) then
diff --git a/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F b/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F
index 8097cb3b..eda929f7 100644
--- a/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F
+++ b/wrfv2_fire/dyn_nmm/module_initialize_tropical_cyclone.F
@@ -413,6 +413,14 @@ SUBROUTINE init_domain_nmm ( grid &
      num_metgrid_levels = grid%num_metgrid_levels
 
 !---------------------------------------------------------------------
+! bug fix for albedo and emissivity
+      DO j = jts, MIN(jte,jde-1)
+         DO i = its, MIN(ite,ide-1)
+           grid%landmask(I,J) = 0.
+         END DO
+       END DO
+! end bug fix for albedo and emissivity
+
 !
 ! gopal's doing for ideal cases
 !
@@ -439,7 +447,7 @@ SUBROUTINE init_domain_nmm ( grid &
      &,          landusef_out,soilctop_out,soilcbot_out        &
      &,          num_veg_gc,num_soil_top_gc,num_soil_bot_gc    &
      &,          config_flags%dx,internal_time_loop            &
-     &,          1,grid%num_metgrid_levels                          &
+     &,          1,grid%num_metgrid_levels,config_flags%sf_surface_physics  &
      &,          ids,ide,jds,jde,kds,kde                       &
      &,          ims,ime,jms,jme,kms,kme                       &
      &,          its,ite,jts,jte,kts,kte                       )
@@ -4648,7 +4656,7 @@ SUBROUTINE vortex ( ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc              &
      &,              landusef_out,soilctop_out,soilcbot_out        &
      &,              num_veg_cat,num_soil_top_cat,num_soil_bot_cat &
      &,              dx,internal_time_loop                         &
-     &,              start_z,end_z                                 &
+     &,              start_z,end_z,sf_surface_physics              &
      &,              ids,ide,jds,jde,kds,kde                       &
      &,              ims,ime,jms,jme,kms,kme                       &
      &,              its,ite,jts,jte,kts,kte                       )
@@ -4662,7 +4670,7 @@ SUBROUTINE vortex ( ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc              &
 INTEGER, INTENT(IN):: ids,ide,jds,jde,kds,kde, &
                        ims,ime,jms,jme,kms,kme, &
                        its,ite,jts,jte,kts,kte, &
-                       internal_time_loop
+                       internal_time_loop,sf_surface_physics
 
  INTEGER, INTENT(IN):: num_veg_cat,num_soil_top_cat,num_soil_bot_cat,start_z, end_z
 
@@ -4691,7 +4699,12 @@ SUBROUTINE vortex ( ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc              &
  character*255 :: message
  REAL, ALLOCATABLE,DIMENSION(:,:)   :: psc
  REAL, ALLOCATABLE,DIMENSION(:,:,:) :: u_temp,v_temp,t_temp,ght_temp,rh_temp
-
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+ INTEGER                                         :: imin,jmin,imax,jmax,proceed,VEG_ID,SOIL_ID
+ LOGICAL                                         :: mvland, logic_temp
+ REAL                                            :: s_temp
+ NAMELIST / init_land /imin,jmin,imax,jmax,proceed,VEG_ID,SOIL_ID,mvland,logic_temp,s_temp
+!! END: LSM changes for LANDFALL : Subashini 7/27/2016
 !----------------------------------------------------------------------------
 !  PURPOSE:
 !         - HURRICANE VORTEX FILTERING
@@ -4734,15 +4747,34 @@ SUBROUTINE vortex ( ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc              &
 !
 !   SET UP IDEAL CONDITIONS
 !
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+
+    open (7,FILE='land.nml')
+    read (UNIT=7, NML=init_land)
+    close (UNIT=7)
+
+    if (mvland .and. sf_surface_physics .ne. GFDLSLAB) then
+       CALL wrf_error_fatal('LSM must be GFDLSLAB when mvland is true')
+    endif
 
     do l = 1,num_veg_cat
      do j = jts, MIN(jte,jde-1)
       do i = its, MIN(ite,ide-1)
-        if(l==16)THEN
-           landusef_out(i,j,l)=1                    ! create ocean everywhere
-        else
-            landusef_out(i,j,l)=0
-        endif
+!        create land patch that will move from W2E
+         if(mvland .and. (i .ge. imin .and. i .le. imax .and. j .ge. jmin .and. j.le. jmax))then
+            if(l==VEG_ID)THEN
+                landusef_out(i,j,l)=1                    ! barren land
+            else
+                landusef_out(i,j,l)=0
+            endif
+         else                             ! original ocean world
+            if(l==16)THEN
+               landusef_out(i,j,l)=1      ! create ocean elsewhere
+            else
+               landusef_out(i,j,l)=0
+            endif
+         endif
+!
       enddo
      enddo
     enddo
@@ -4750,41 +4782,72 @@ SUBROUTINE vortex ( ght_gc,rh_gc,t_gc,u_gc,v_gc,p_gc              &
     do l = 1,num_soil_top_cat
      do j = jts, MIN(jte,jde-1)
       do i = its, MIN(ite,ide-1)
-        if(l==14)THEN
-           soilctop_out(i,j,l)=1                    ! create ocean everywhere
-        else
-           soilctop_out(i,j,l)=0
-        endif
+!        create land patch that will move from W2E
+         if(mvland .and. (i .ge. imin .and. i .le. imax .and. j .ge. jmin .and. j.le. jmax))then
+            if(l==SOIL_ID)THEN
+              soilctop_out(i,j,l)=1       ! sandy soil
+            else
+              soilctop_out(i,j,l)=0
+            endif
+         else                             ! original ocean world
+            if(l==14)THEN
+               soilctop_out(i,j,l)=1      ! create ocean everywhere
+            else
+               soilctop_out(i,j,l)=0
+            endif
+         endif
+!
       enddo
      enddo
     enddo
+
    do l = 1,num_soil_bot_cat
      do j = jts, MIN(jte,jde-1)
       do i = its, MIN(ite,ide-1)
-        if(l==14)THEN
-           soilcbot_out(i,j,l)=1                    ! create ocean everywhere
-        else
-           soilcbot_out(i,j,l)=0
-        endif
+!        create land patch that will move from W2E
+         if(mvland .and. (i .ge. imin .and. i .le. imax .and. j .ge. jmin .and. j.le. jmax))then
+            if(l==SOIL_ID)THEN
+               soilcbot_out(i,j,l)=1       ! sandy soil
+            else
+               soilcbot_out(i,j,l)=0
+            endif
+         else                              ! original ocean world
+            if(l==14)THEN
+               soilcbot_out(i,j,l)=1       ! create ocean everywhere
+            else
+               soilcbot_out(i,j,l)=0
+            endif
+         endif
+!
       enddo
      enddo
     enddo
 
-
     landusef_gc=landusef_out       !=landusef_gc
     soilcbot_gc=soilcbot_out       !=soilcbot_gc
     soilctop_gc=soilctop_out       !=soilctop_gc
 
-
     do j = jts, MIN(jte,jde-1)
      do i = its, MIN(ite,ide-1)
       xice_gc(i,j)=0.
       ht_gc(i,j)=0.                                 ! uniform terrain
       ght_gc(i,j,1)=0.                              ! uniform gpm at level 1
-      tsk_gc(i,j)=302.0                             ! uniform SSTs
+!     create land patch that will move from W2E
+      if(mvland .and. (i .ge. imin .and. i .le. imax .and. j .ge. jmin .and.j.le. jmax))then
+       if(logic_temp .eq. .true.) then
+       tsk_gc(i,j)=s_temp                            ! uniform land temperature or t_gc(i,j,1) for applying first level temperature
+       else
+       tsk_gc(i,j)= t_gc(i,j,1)
+       endif
+      else
+       tsk_gc(i,j)=302.0                             ! uniform SSTs
+      endif
      enddo
     enddo
 
+
+!! END: LSM changes for LANDFALL : Subashini 7/27/2016
+
 !
 ! Make sure the GFDL analysis does not have temperature problems especially
 ! near the surface. I noticed some problems with the wps outputs (met_nmm file.)
diff --git a/wrfv2_fire/dyn_nmm/module_membrane_mslp.F b/wrfv2_fire/dyn_nmm/module_membrane_mslp.F
index a04e175e..d2fb59b7 100644
--- a/wrfv2_fire/dyn_nmm/module_membrane_mslp.F
+++ b/wrfv2_fire/dyn_nmm/module_membrane_mslp.F
@@ -206,7 +206,7 @@ subroutine membrane_mslp_impl(grid, &
        if(need_to_relax==0) then
  38       format('end mslp relax loop at ',I0)
           write(message,38) ipres
-          call wrf_debug(1,message)
+          call wrf_debug(2,message)
           exit
        endif
 
@@ -417,9 +417,9 @@ subroutine calculate_3D(grid,presTv,presZ,ground_mask,ground_level, &
 
 1234 format('grid ',I0,': size(',A,') = ',I0)
    write(message,1234) grid%id,'grid%p700rv',size(grid%p700rv)
-   call wrf_message(trim(message))
+   call wrf_debug(2,trim(message))
    write(message,1234) grid%id,'grid%p700u',size(grid%p700u)
-   call wrf_message(trim(message))
+   call wrf_debug(2,trim(message))
 
    wantuv=(grid%vortex_tracker == 7) ! do I need to calc. presu & presv?
 
diff --git a/wrfv2_fire/dyn_nmm/module_swath.F b/wrfv2_fire/dyn_nmm/module_swath.F
index 7431f2fd..a43de204 100644
--- a/wrfv2_fire/dyn_nmm/module_swath.F
+++ b/wrfv2_fire/dyn_nmm/module_swath.F
@@ -12,15 +12,16 @@ module module_swath
 
   private
 
-  public :: update_interest, init_swath
+  public :: update_interest, init_swath, sustained_wind, check_for_kid_move
 
 contains
 
-  subroutine init_swath(grid,config_flags,init)
+  subroutine init_swath(grid,config_flags,init,reinit)
     USE MODULE_CONFIGURE, ONLY : grid_config_rec_type
     type(domain), intent(inout) :: grid
     type(grid_config_rec_type), intent(in) :: config_flags
-    logical, intent(in) :: init ! .true. = first initialization in wrf.exe
+    logical, intent(in) :: init ! .true. = first initialization in wrf.exe, non-restart run
+    logical, intent(in) :: reinit ! .true. = first initialization in this execution of wrf.exe (may be restart)
     character*255 :: message
     if(init) then
 3088   format('Grid ',I0,' is resetting swath data.')
@@ -29,9 +30,108 @@ subroutine init_swath(grid,config_flags,init)
        if(size(grid%interesting)>1)   grid%interesting=0
        if(size(grid%precip_swath)>1)  grid%precip_swath=0
        if(size(grid%windsq_swath)>1)  grid%windsq_swath=0
+       if(size(grid%suswind)>1)       grid%suswind=0
+       if(size(grid%suswind_swath)>1) grid%suswind_swath=0
+       if(size(grid%wind10_ratio)>1)  grid%wind10_ratio=1
+       grid%suswind_time=0
+    endif
+    if(reinit) then
+3000   format('Grid ',I0,' is resetting wind sustainment timer.')
+       write(message,3000) grid%id
+       call wrf_message(message)
+       grid%suswind_time=0
     endif
   end subroutine init_swath
 
+  subroutine sustained_wind(grid,config_flags,ips,ipe,jps,jpe,turbl_step)
+    USE MODULE_CONFIGURE, ONLY : grid_config_rec_type
+    type(domain), intent(inout) :: grid
+    type(grid_config_rec_type), intent(in) :: config_flags
+    integer, intent(in) :: ips,ipe,jps,jpe
+    logical, intent(in) :: turbl_step ! .true. = PBL and surface layer just called
+    integer :: i,j
+    real :: windsq, wind10sq, maxsus,minsus
+    if(size(grid%wind10_ratio)<=1) return
+
+    update_sustained: if(turbl_step) then
+       ! Update ratio of wind and use 10m wind to update sustained
+       ! wind calculation
+       !write(0,*) 'Update wind10_ratio and sustain wind with 10m wind.'
+       maxsus=-999
+       minsus=999
+       do j=jps,jpe
+          do i=ips,ipe
+             windsq=grid%u(i,j,1)*grid%u(i,j,1) + grid%v(i,j,1)*grid%v(i,j,1)
+             wind10sq=grid%u10(i,j)*grid%u10(i,j) + grid%v10(i,j)*grid%v10(i,j)
+             if(wind10sq<1e-12) then
+                grid%wind10_ratio(i,j)=1.0
+             else
+                grid%wind10_ratio(i,j)=sqrt(windsq/wind10sq)
+             endif
+             if(grid%suswind_time>1e-5 .and. grid%suswind(i,j)>1e-3) then
+                grid%suswind(i,j)=min(grid%suswind(i,j),sqrt(wind10sq))
+             else
+                grid%suswind(i,j)=sqrt(wind10sq)
+             endif
+             maxsus=max(grid%suswind(i,j),maxsus)
+             minsus=min(grid%suswind(i,j),minsus)
+          enddo
+       enddo
+       !write(0,*) 'suswind range:',maxsus,minsus
+    else
+       ! Use lowest model level wind adjusted by previous TURBL step
+       ! wind ratio to update sustained wind calculation.
+       !write(0,*) 'Update sustain wind with lowest model level wind and wind10_ratio.'
+       maxsus=-999
+       minsus=999
+       do j=jps,jpe
+          do i=ips,ipe
+             windsq=grid%u(i,j,1)*grid%u(i,j,1) + grid%v(i,j,1)*grid%v(i,j,1)
+             if(grid%wind10_ratio(i,j)>1e-3) then
+                wind10sq=windsq/grid%wind10_ratio(i,j)
+             else
+                wind10sq=windsq
+             endif
+             if(grid%suswind_time>1e-5 .and. grid%suswind(i,j)>1e-3) then
+                grid%suswind(i,j)=min(grid%suswind(i,j),sqrt(wind10sq))
+             else
+                grid%suswind(i,j)=sqrt(wind10sq)
+             endif
+             maxsus=max(grid%suswind(i,j),maxsus)
+             minsus=min(grid%suswind(i,j),minsus)
+          enddo
+       enddo
+       !write(0,*) 'suswind range:',maxsus,minsus
+    end if update_sustained
+
+    ! Update wind sustainment time and maximum sustained wind swath:
+    grid%suswind_time = grid%suswind_time + grid%dt
+
+    !write(0,*) 'add to suswind_time: ',grid%dt
+
+    ! FIXME: grid%suswind_accum_time
+    update_swath: if(grid%suswind_time>60.0) then
+       !write(0,*) 'update suswind_swath with max of itself and suswind'
+       maxsus=-999
+       minsus=999
+       do j=jps,jpe
+          do i=ips,ipe
+             if(grid%interesting(i,j)/=0) then
+                grid%suswind_swath(i,j)=max(grid%suswind(i,j),grid%suswind_swath(i,j))
+             endif
+             wind10sq=grid%u10(i,j)*grid%u10(i,j) + grid%v10(i,j)*grid%v10(i,j)
+             grid%suswind(i,j)=sqrt(wind10sq)
+             maxsus=max(grid%suswind(i,j),maxsus)
+             minsus=min(grid%suswind(i,j),minsus)
+          enddo
+       enddo
+       grid%suswind_time=0
+       !write(0,*) 'suswind_swath range:',maxsus,minsus
+    else
+       !write(0,*) 'Not yet time to sustain: ',grid%suswind_time
+    endif update_swath
+  end subroutine sustained_wind
+
   function dx_at(grid, i,j,  ips,ipe,jps,jpe) result(dx)
     include 'mpif.h'
     type(domain), intent(inout) :: grid
@@ -63,7 +163,7 @@ subroutine storm_interest(grid)
          ids,ide,jds,jde,kds,kde, &
          ims,ime,jms,jme,kms,kme, &
          ips,ipe,jps,jpe,kps,kpe  )
-    
+
     sdistsq=grid%interest_rad_storm**2*1e6
     do j=max(jps,jds),min(jpe,jde)
        do i=max(ips,ids),min(ipe,ide)
@@ -74,10 +174,12 @@ subroutine storm_interest(grid)
     enddo
   end subroutine storm_interest
 
-  subroutine kid_scanner(parent,nest)
+  subroutine kid_scanner(parent,nest,check)
     ! Sets parent%interest to 1 within nest%intrest_rad_parent
     ! kilometers of the nest parent center.
     type(domain), intent(inout) :: parent,nest
+    logical, intent(inout), optional :: check
+
     integer :: ni1,nj1,ni2,nj2, nimid, njmid
     integer :: nims,nime,njms,njme,nkms,nkme
     integer :: nids,nide,njds,njde,nkds,nkde
@@ -122,6 +224,18 @@ subroutine kid_scanner(parent,nest)
               I0," (ki1=",I0," kj1=",I0," ki2=",I0," kj2=",I0,")")
     endif
 
+    if(present(check)) then
+       ! Just check, do not update anything
+       if ( parent%nest_imid(nest%id) /= nimid .or. &
+            parent%nest_jmid(nest%id) /= njmid ) then
+          check=.true.
+       endif
+       return
+    else
+       parent%nest_imid(nest%id) = nimid
+       parent%nest_jmid(nest%id) = njmid
+    endif
+    
     ispan =ceiling(1e3*nest%interest_rad_parent/dx)+1
     istart=max(pids,  nimid-ispan)
     iend  =min(pide-1,nimid+ispan)
@@ -185,7 +299,7 @@ subroutine print_interest(grid)
     count=wrf_dm_sum_integer(count)
 #endif
 308 format('grid ',I0,': ',I0,' of ',I0,' points (',F0.2,'%) are in area of interest.')
-    write(message,308) grid%id,count,total,real(count)/total
+    write(message,308) grid%id,count,total,real(count)/total*100.0
     call wrf_debug(1,message)
   end subroutine print_interest
 
@@ -224,6 +338,25 @@ subroutine self_interest(grid)
     enddo
   end subroutine self_interest
 
+  logical function check_for_kid_move(grid,config_flags)
+    USE MODULE_CONFIGURE, ONLY : grid_config_rec_type
+    type(domain), intent(inout) :: grid
+    type(grid_config_rec_type), intent(in) :: config_flags
+    integer :: ikid
+    check_for_kid_move=.false.
+
+    if(config_flags%interest_kids==1) then
+       do ikid=1,grid%num_nests
+          if(associated(grid%nests(ikid)%ptr)) &
+               call kid_scanner(grid,grid%nests(ikid)%ptr,check_for_kid_move)
+       enddo
+    else
+       call wrf_debug('Not checking if kid moved since I have no kids yet.')
+    endif
+    if(check_for_kid_move) &
+         call  wrf_debug(1,'At least one of my nests moved.')
+  end function check_for_kid_move
+  
   subroutine update_interest(grid,config_flags)
     USE MODULE_CONFIGURE, ONLY : grid_config_rec_type
     type(domain), intent(inout) :: grid
@@ -231,6 +364,7 @@ subroutine update_interest(grid,config_flags)
     integer :: max_dom, nestid, parent_id, ikid, ki0,kj0,kni,knj
     logical :: nestless
 
+    call wrf_debug(1,'Reset and recalculate area of interest.')
     grid%interesting=0
 
     likes_kids: if(config_flags%interest_kids==1) then
diff --git a/wrfv2_fire/dyn_nmm/module_tornado_genesis.F b/wrfv2_fire/dyn_nmm/module_tornado_genesis.F
index 5a6845fc..a8941b78 100644
--- a/wrfv2_fire/dyn_nmm/module_tornado_genesis.F
+++ b/wrfv2_fire/dyn_nmm/module_tornado_genesis.F
@@ -96,6 +96,11 @@ subroutine init_tg_vars(grid,config_flags, &
     grid%tg_interval_end=grid%tg_interval_start
     grid%tg_duration=0.0
     grid%tg_want_reset=0
+#if (HWRF == 1)
+!   this flag is used by HWRF with moving nests... N/A for NMM
+    grid%update_interest=.true.
+#endif
+
   end subroutine init_tg_vars
 
   subroutine init_tornado_genesis(grid,config_flags)
@@ -306,7 +311,7 @@ subroutine calc_tornado_genesis(grid,config_flags)
     do j=jstart,jend
        do i=istart,iend
           kloop: do k=kds+1,kde-1
-             if(grid%pint(i,j,k)wwind_cutoff) exit kloop
              w=grid%w(i,j,k)
              grid%tg_min_wwind(i,j)=min(grid%tg_min_wwind(i,j),w)
              minminw=min(minminw,grid%tg_min_wwind(i,j))
diff --git a/wrfv2_fire/dyn_nmm/solve_nmm.F b/wrfv2_fire/dyn_nmm/solve_nmm.F
index e7f42ab9..135633c0 100644
--- a/wrfv2_fire/dyn_nmm/solve_nmm.F
+++ b/wrfv2_fire/dyn_nmm/solve_nmm.F
@@ -29,7 +29,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
       USE MODULE_COMM_DM
 #endif
 #if ( HWRF == 1 )
-      USE MODULE_SWATH,                 ONLY : UPDATE_INTEREST
+      USE MODULE_SWATH,                 ONLY : UPDATE_INTEREST, SUSTAINED_WIND, CHECK_FOR_KID_MOVE
       USE MODULE_HIFREQ,                ONLY: HIFREQ_WRITE, HIFREQ_OPEN
 #endif
       USE MODULE_TORNADO_GENESIS,       ONLY: CALC_TORNADO_GENESIS, RESET_TORNADO_GENESIS
@@ -118,6 +118,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
       INTEGER :: NUM_AEROSOLC
 !
       REAL :: DT_INV,FICE,FRAIN,GPS,QI,QR,QW,WC,WP
+      REAL :: dwdt_damping_lev
 !
       LOGICAL :: LAST_TIME,OPERATIONAL_PHYSICS,ETAMP_PHYSICS
 !
@@ -149,7 +150,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &,            cucnvc_tim,gsmdrive_tim,hdiff_tim,bocoh_tim          &
      &,            pfdht_tim,ddamp_tim,bocov_tim,uv_htov_tim,sum_tim    &
 #if ( HWRF == 1 )
-     &,            sst_tim,flux_tim,hifreq_tim                          &
+     &,            sst_tim,flux_tim,hifreq_tim,wav_tim,cplstep_tim      &
 #endif
      &,            diag_tim,adjppt_tim,tornado_tim                      
 
@@ -163,6 +164,13 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
       real :: ttim,btimx
       real :: et_max,this_tim
       integer :: n_print_time
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+      integer :: move_land_time
+      integer :: SOIL_ID, VEG_ID, DIRN
+      real :: land_albedo, land_emiss, land_vgfrac, land_smc, land_z0
+      NAMELIST/param_land/SOIL_ID, VEG_ID, DIRN, land_albedo, land_emiss, land_vgfrac, land_smc,land_z0
+!! END: LSM changes for LANDFALL : Subashini 7/27/2016
+
 !
 !-----------------------------------------------------------------------
 !
@@ -312,6 +320,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
       IDTADT=model_config_rec%IDTADT
       IDTADC=model_config_rec%IDTADC
       WP=model_config_rec%WP(grid%id)
+      dwdt_damping_lev=model_config_rec%dwdt_damping_lev(grid%id)
 !
 !-----------------------------------------------------------------------
       CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
@@ -350,7 +359,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 
       ADVECT_Q2=.TRUE.
       if(CONFIG_FLAGS%BL_PBL_PHYSICS == GFSSCHEME .OR. &
-         CONFIG_FLAGS%BL_PBL_PHYSICS == GFS2011SCHEME) THEN
+         CONFIG_FLAGS%BL_PBL_PHYSICS == GFSEDMFSCHEME) THEN
          ADVECT_Q2=.FALSE.
       endif
 
@@ -468,6 +477,8 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
         tornado_tim=0.
 #if ( HWRF == 1 )
         sst_tim=0.
+        cplstep_tim=0.
+        wav_tim=0.
         flux_tim=0.
         hifreq_tim=0.
 #endif
@@ -547,6 +558,14 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
           grid%XLOC_1=(IDE-1)/2     ! This maneuvers the storm to the center of the nest quickly
           grid%YLOC_1=(JDE-1)/2     ! This maneuvers the storm to the center of the nest quickly
         ENDIF
+
+        ! If we have any nests, check to see if they moved so we know
+        ! if we need to update the nest-centric area of interest:
+        IF(grid%ntsd>1 .and. MOD(grid%ntsd,grid%nphs)==0) THEN
+           grid%update_interest = grid%update_interest .or. &
+                check_for_kid_move(grid,config_flags)
+        ENDIF
+
 #endif
 
       ENDIF
@@ -799,7 +818,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
                          grid%HLON,grid%HLAT,grid%VLON,grid%VLAT,grid%sm,                   &
                          grid%i_parent_start,grid%j_parent_start,  &
                          grid%guessdtc,grid%dtc)
-        sst_tim=sst_tim+now_time()-btimx
+        cplstep_tim=cplstep_tim+now_time()-btimx
       ENDIF
 !<-:coupling insertion
 !
@@ -1182,16 +1201,16 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
             ims,ime,jms,jme,kms,kme, &
             its,ite,jts,jte,kts,kte)
 
-      CALL EPS(grid%ntsd,GRID%DT,grid%hydro,grid%dx_nmm,grid%dy_nmm,grid%fad                     &
-     &        ,grid%aeta1,grid%deta1,grid%deta2,grid%pdtop,grid%pt                                     &
-     &        ,grid%hbm2,grid%hbm3                                                &
-     &        ,grid%pdsl,grid%pdslo,grid%pint,grid%rtop,grid%petdt,grid%pdwdt                         &
-     &        ,grid%dwdt,grid%dwdtmn,grid%dwdtmx                                       &
-     &        ,grid%fns,grid%few,grid%fne,grid%fse                                          &
-     &        ,grid%t,grid%u,grid%v,grid%w,grid%w_tot,grid%q,grid%cwm                                            &
-     &        ,grid%def3d,grid%hdac,grid%baro                                              &
-     &        ,WP                                                 &
-     &        ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                          &
+      CALL EPS(grid%ntsd,GRID%DT,grid%hydro,grid%dx_nmm,grid%dy_nmm,grid%fad  &
+     &        ,grid%aeta1,grid%deta1,grid%deta2,grid%pdtop,grid%pt      &
+     &        ,grid%hbm2,grid%hbm3                                      &
+     &        ,grid%pdsl,grid%pdslo,grid%pint,grid%rtop,grid%petdt,grid%pdwdt &
+     &        ,grid%dwdt,grid%dwdtmn,grid%dwdtmx                        &
+     &        ,grid%fns,grid%few,grid%fne,grid%fse                      &
+     &        ,grid%t,grid%u,grid%v,grid%w,grid%w_tot,grid%q,grid%cwm   &
+     &        ,grid%def3d,grid%hdac,grid%baro                           &
+     &        ,WP,dwdt_damping_lev                                      &
+     &        ,grid%ihe,grid%ihw,grid%ive,grid%ivw                      &
      &        ,IDS,IDF,JDS,JDF,KDS,KDE                                  &
      &        ,IMS,IME,JMS,JME,KMS,KME                                  &
      &        ,ITS,ITE,JTS,JTE,KTS,KTE)
@@ -1566,6 +1585,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
         btimx=now_time()
         CALL ATM_GETSST(grid%sst,grid%sm)
         sst_tim=sst_tim+now_time()-btimx
+        btimx=now_time()
+        CALL atm_getcur(grid%scurx, grid%scury)    !BT
+        CALL atm_getwstate(grid%charn,grid%msang)  !BT
+        wav_tim=wav_tim+now_time()-btimx
 !<-:Coupling insertion
       ENDIF
 #endif
@@ -1573,7 +1596,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 !***  TURBULENT PROCESSES 
 !----------------------------------------------------------------------
 !
-      IF(MOD(grid%ntsd,GRID%NPHS)==0)THEN
+      turbl_time: IF(MOD(grid%ntsd,GRID%NPHS)==0)THEN
 !
         btimx=now_time()
 !
@@ -1591,14 +1614,15 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
             ims,ime,jms,jme,kms,kme, &
             its,ite,jts,jte,kts,kte)
         CALL TURBL(grid%ntsd,GRID%DT,GRID%NPHS,RESTRT                       &
-     &            ,N_MOIST,GRID%NUM_SOIL_LAYERS,grid%sldpth,grid%dzsoil          &
+     &            ,N_MOIST,NUM_SCALAR,GRID%NUM_SOIL_LAYERS,grid%sldpth,grid%dzsoil          &
      &            ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2,grid%pdtop,grid%pt          &
      &            ,grid%sm,grid%hbm2,grid%vbm2,grid%dx_nmm,grid%dfrlg                           &
      &            ,grid%czen,grid%czmean,grid%sigt4,grid%rlwin,grid%rswin,grid%radot                 &
      &            ,grid%pd,grid%res,grid%pint,grid%t,grid%q,grid%cwm,grid%f_ice,grid%f_rain,grid%sr                 &
      &            ,grid%q2,grid%u,grid%v,grid%ths,grid%nmm_tsk,grid%sst,grid%prec,grid%sno                     &
+     &            ,grid%scurx,grid%scury                                                             &
      &            ,grid%fis,grid%z0,grid%mz0,grid%z0base,grid%ustar,grid%mixht,grid%pblh,grid%lpbl,grid%el_pbl    &   !KWON MZ0
-     &            ,MOIST,grid%rmol,grid%mol                                      &
+     &            ,MOIST,SCALAR,grid%rmol,grid%mol                                      &
      &            ,grid%exch_h,grid%exch_m,grid%f,grid%akhs,grid%akms,grid%akhs_out,grid%akms_out         &
      &            ,grid%thz0,grid%qz0,grid%uz0,grid%vz0,grid%qsh,grid%mavail                         &
      &            ,grid%stc,grid%smc,grid%cmc,grid%smstav,grid%smstot,grid%ssroff,grid%bgroff             &
@@ -1635,6 +1659,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &            ,GRID%HPBL2D, GRID%EVAP2D, GRID%HEAT2D,GRID%RC2D               &  !S&P Kwon
      &            ,GRID%SFCHEADRT,GRID%INFXSRT,GRID%SOLDRAIN           &  !Hydrology, no-op right now
      &            ,grid%cd_out,grid%ch_out                             &
+     &            ,grid%ulowl,grid%vlowl                               &
+     &            ,grid%zsig1,grid%rchno                               &
+     &            ,grid%charn,grid%msang                               &
+     &            ,grid%DUBLDT,grid%DVBLDT,grid%DTHBLDT,grid%DQVBLDT   &!wang added PBL tendency output
      &            ,IDS,IDF,JDS,JDF,KDS,KDE                             &
      &            ,IMS,IME,JMS,JME,KMS,KME                             &
      &            ,IPS,IPE,JPS,JPE,KPS,KPE                             &
@@ -1646,6 +1674,9 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 !
         turbl_tim=turbl_tim+now_time()-btimx
 #if ( HWRF == 1 )
+        btimx=now_time()
+        call sustained_wind(grid,config_flags,ips,ipe,jps,jpe,.true.)
+        diag_tim=diag_tim+now_time()-btimx
 !------------------------------------------------------------------------------
 !*** ATMOSPHERIC MODEL OUTPUTS FROM PARENT AND NESTED GRID FOR DMITRYs COUPLER
 !------------------------------------------------------------------------------
@@ -1672,16 +1703,16 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 ! Coupling insertion:->
         btimx=now_time()
         call ATM_DOFLUXES(grid%twbs,grid%qwbs,grid%rlwin,grid%rswin,grid%radot,grid%rswout, &
-        grid%taux,grid%tauy,grid%pint,grid%prec,grid%u10,grid%v10)
+        grid%taux,grid%tauy,grid%pint,grid%prec)
+        CALL atm_prepwindp(grid%ulowl,grid%vlowl,grid%rchno,grid%zsig1)
         flux_tim=flux_tim+now_time()-btimx
 !<-:Coupling insertion
 !
-
+      ENDIF
         IF(GRID%ID .EQ. 1 .AND. MOD(grid%ntsd,grid%NPHS)==0)THEN
           btimx=now_time()
           flux_tim=flux_tim+now_time()-btimx
         ENDIF
-      ENDIF
 #endif
 !
 #ifdef NMM_FIND_LOAD_IMBALANCE
@@ -1758,7 +1789,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &             ,ITS,ITE,JTS,JTE,KTS,KTE)
 !
         cltend_tim=cltend_tim+now_time()-btimx
-     ENDIF
+     ENDIF turbl_time
 !
 !----------------------------------------------------------------------
 !***  CONVECTIVE PRECIPITATION
@@ -1768,7 +1799,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &   (CONFIG_FLAGS%CU_PHYSICS.eq.KFETASCHEME .or.                     &
      &   CONFIG_FLAGS%CU_PHYSICS.eq.OSASSCHEME .or.                       &
      &   CONFIG_FLAGS%CU_PHYSICS.eq.NSASSCHEME .or.                       &
-     &   CONFIG_FLAGS%CU_PHYSICS.eq.MESO_SAS .or.                         &   !Kwon
+     &   CONFIG_FLAGS%CU_PHYSICS.eq.SCALESASSCHEME .or.                   &
      &   CONFIG_FLAGS%CU_PHYSICS.eq.SASSCHEME))THEN                       ! 
 !
 #ifdef NMM_FIND_LOAD_IMBALANCE
@@ -1822,15 +1853,13 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
        ENDIF
 !
 !----------------------------------------------------------------------
-       call wrf_message('call cucnvc')
-       call start_timing
         call check_grid(grid,config_flags,'before CUCNVC', &
             ids,ide,jds,jde,kds,kde, &
             ims,ime,jms,jme,kms,kme, &
             its,ite,jts,jte,kts,kte)
         CALL CUCNVC(grid%ntsd,GRID%DT,GRID%NCNVC,GRID%NRADS,GRID%NRADL      &
-     &             ,GPS,RESTRT,grid%hydro,grid%cldefi,N_MOIST,GRID%ENSDIM        &
-     &             ,MOIST                                              &
+     &             ,GPS,RESTRT,grid%hydro,grid%cldefi,N_MOIST,NUM_SCALAR,GRID%ENSDIM        &
+     &             ,MOIST,SCALAR                                       &
      &             ,grid%deta1,grid%deta2,grid%aeta1,grid%aeta2,grid%eta1,grid%eta2                  &
      &             ,grid%f_ice,grid%f_rain                                       &
 !***  Changes for other cu schemes, most for GD scheme
@@ -1845,12 +1874,17 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &             ,grid%prec,grid%acprec,grid%cuprec,grid%cuppt,grid%cprate                    &
      &             ,grid%sm,grid%hbm2,grid%pblh,grid%lpbl,grid%cnvbot,grid%cnvtop                         &
      &             ,grid%htop,grid%hbot,grid%htopd,grid%hbotd,grid%htops,grid%hbots                  &
-     &             ,RTHBLTEN,RQVBLTEN,RTHRATEN                         & 
+     &             ,RTHBLTEN,RQVBLTEN,RTHRATEN                          & 
 #if (NMM_CORE==1)                  
      &             ,grid%twbs,grid%qwbs                                &
-     &                 ,grid%DUCUDT, grid%DVCUDT, GRID%MOMMIX, grid%random             &
+     &             ,grid%DUCUDT, grid%DVCUDT, GRID%MOMMIX, grid%random & 
+     &             ,grid%DTHCUDT,grid%DQVCUDT,grid%DQRCUDT,grid%DQCCUDT&! wang, output CU tendency 
+     &             ,grid%DQICUDT,grid%DQSCUDT                          &
 #endif
      &             ,grid%hpbl2d,grid%evap2d,grid%heat2d                &
+     &             ,grid%dx_nmm,grid%dy_nmm                            & !wang, dx2d, dy
+     &             ,grid%scalefun, grid%scalefun1                      & !wang
+     &             ,grid%sigmu, grid%sigmu1                            & !wang
      &             ,grid%avcnvc,grid%acutim,grid%ihe,grid%ihw          &
      &             ,GRID,CONFIG_FLAGS                                  &
      &             ,IDS,IDF,JDS,JDF,KDS,KDE                            &
@@ -1861,7 +1895,6 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
             ids,ide,jds,jde,kds,kde, &
             ims,ime,jms,jme,kms,kme, &
             its,ite,jts,jte,kts,kte)
-        call end_timing('cucnvc')
 !----------------------------------------------------------------------
 !
         cucnvc_tim=cucnvc_tim+now_time()-btimx
@@ -1880,7 +1913,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
         IF(MOD(grid%ntsd, GRID%NCNVC).eq.0.and.                 &
      &    (CONFIG_FLAGS%CU_PHYSICS.eq.OSASSCHEME.or.            &
      &     CONFIG_FLAGS%CU_PHYSICS.eq.NSASSCHEME.or.            &
-     &     CONFIG_FLAGS%CU_PHYSICS.eq.MESO_SAS.or.              & !Kwon
+     &     CONFIG_FLAGS%CU_PHYSICS.eq.SCALESASSCHEME.or.        &
      &     CONFIG_FLAGS%CU_PHYSICS.eq.SASSCHEME))THEN 
 !emc_2010_bugfix_h50
 !
@@ -2104,8 +2137,16 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      &          ,grid%Q_BTYS,grid%Q_BTYE,grid%U_BTXS,grid%U_BTXE,grid%U_BTYS,grid%U_BTYE,grid%V_BTXS       &
      &          ,grid%V_BTXE,grid%V_BTYS,grid%V_BTYE,grid%Q2_BTXS,grid%Q2_BTXE,grid%Q2_BTYS,grid%Q2_BTYE   &
      &          ,grid%pd,grid%t,grid%q,grid%q2,grid%pint &
-     &          ,GRID%SPEC_BDY_WIDTH,grid%z                                  &
-     &          ,grid%ihe,grid%ihw,grid%ive,grid%ivw                                        &
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+#ifdef IDEAL_NMM_TC
+     &          ,grid%SM_BXS, grid%SM_BXE, grid%SM_BYS, grid%SM_BYE     & ! gopal's doing for land motion
+     &          ,grid%SM_BTXS, grid%SM_BTXE, grid%SM_BTYS, grid%SM_BTYE &
+     &          ,grid%SM                                                &
+     &          ,grid%THS 						&
+#endif
+!!END: LSM changes for LANDFALL : Subashini 7/27/2016
+     &          ,GRID%SPEC_BDY_WIDTH,grid%z                             &
+     &          ,grid%ihe,grid%ihw,grid%ive,grid%ivw                    &
      &          ,IDS,IDF,JDS,JDF,KDS,KDE                                &
      &          ,IMS,IME,JMS,JME,KMS,KME                                &
      &          ,ITS,ITE,JTS,JTE,KTS,KTE)
@@ -2386,7 +2427,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
              pfdht_tim + ddamp_tim + bocov_tim + uv_htov_tim + diag_tim +  &
              tornado_tim
 #if ( HWRF == 1 )
-        sum_tim = sum_tim + sst_tim + flux_tim + hifreq_tim
+        sum_tim = sum_tim + sst_tim + flux_tim + hifreq_tim + wav_tim + cplstep_tim
 #endif
 #if defined(NMM_FIND_LOAD_IMBALANCE)
         sum_tim=sum_tim + loadimbal_tim + previmbal_tim
@@ -2451,6 +2492,10 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 #if ( HWRF == 1 )
         write(message,17)' sst_tim=',sst_tim,' pct=',sst_tim/sum_tim*100.
         call wrf_message(trim(message))
+        write(message,17)' cplstep_tim=',cplstep_tim,' pct=',cplstep_tim/sum_tim*100.
+        call wrf_message(trim(message))
+        write(message,17)' wav_tim=',wav_tim,' pct=',wav_tim/sum_tim*100.
+        call wrf_message(trim(message))
         write(message,17)' flux_tim=',flux_tim,' pct=',flux_tim/sum_tim*100.
         call wrf_message(trim(message))
         write(message,17)' hifreq_tim=',hifreq_tim,' pct=',hifreq_tim/sum_tim*100.
@@ -2492,15 +2537,11 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 #ifdef MOVE_NESTS
    IF ( grid%num_moves.EQ.-99 ) THEN
      btimx=now_time()
-      call start_timing()
       call stats_for_move(grid,config_flags &
                          ,IDS,IDE,JDS,JDE,KDS,KDE &
                          ,IMS,IME,JMS,JME,KMS,KME &
                          ,IPS,IPE,JPS,JPE,KPS,KPE &
                          ,ITS,ITE,JTS,JTE,KTS,KTE)
-3303  format('stats_for_move on domain ',I0)
-      write(message,3303) grid%id
-      call end_timing(message)
    CALL wrf_debug ( 100 , 'nmm stats_for_move: after advection' )
      diag_tim=diag_tim+now_time()-btimx
    ENDIF
@@ -2525,6 +2566,83 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
      diag_tim=diag_tim+now_time()-btimx
    endif hwrfx_mlsp
 #endif
+!!BEGIN: LSM changes for LANDFALL: Subashini 7/27/2016
+#ifdef IDEAL_NMM_TC
+
+     IF(grid%NTSD==0 .and. grid%id .gt. 1)THEN  ! Initialize some variables
+           call wrf_debug(1,'NESTS INITIALIZED TO WATER WORLD')
+           grid%sm=1.0    ! Initialize a water world in the nests
+     ENDIF
+!
+     move_land_time=nint(1200./30) ! This needs to be changed for different parent domain resolution & dt.  Subashini V1.0 7.13.2016
+
+     IF(MOD(grid%NTSD,move_land_time)==0)THEN    ! n_print_time
+
+       call wrf_debug(1,'LAND ADVECTED W2E FOR IDEALIZED LSM')
+
+#ifdef DM_PARALLEL
+#    include "HALO_NMM_INIT_3.inc"
+#endif
+!open ideal_land.nml for namelist values
+
+      open(8,FILE='land.nml')
+      read(UNIT=8,NML=param_land)
+      close(UNIT=8)
+
+       CALL MOVE_LAND (grid%SM,grid%nmm_tsk        &
+                      ,grid%SST,grid%FIS           &
+                      ,grid%PINT,grid%T,grid%Q     &
+                      ,grid%NTSD                   &
+                      ,IDS,IDE,JDS,JDE,KDS,KDE     &
+                      ,IMS,IME,JMS,JME,KMS,KME     &
+                      ,ITS,ITE,JTS,JTE,KTS,KTE,DIRN)
+
+!For diurnal temp changes - comment out for constant temperature and
+!uncomment  temperature fix in module_surface_driver.F and
+!module_radiation_driver.F
+
+     IF(DIRN == 1) THEN
+      DO J = JMS, JME
+       DO I = IMS,IME
+        if(grid%SM(I,J) .le. 0.5)then
+         grid%nmm_tsk(I,J)=grid%nmm_tsk(I-1,J)
+         grid%albedo(I,J)=land_albedo
+         grid%epsr(I,J)=land_emiss
+         grid%isltyp(I,J)=SOIL_ID
+         grid%ivgtyp(I,J)=VEG_ID
+         grid%vegfrc(I,J)=land_vgfrac
+         grid%z0(I,J)=land_z0
+         DO K = 1,grid%num_soil_layers
+         grid%smc(I,K,J)=land_smc
+         ENDDO
+        endif
+       ENDDO
+      ENDDO
+     ELSE IF(DIRN == 2) THEN
+      DO J = JMS, JME
+       DO I = IME,IMS, -1
+        if(grid%SM(I,J) .le. 0.5)then
+         grid%nmm_tsk(I,J)=grid%nmm_tsk(I+1,J)
+         grid%albedo(I,J)=land_albedo
+         grid%epsr(I,J)=land_emiss
+         grid%isltyp(I,J)=SOIL_ID
+         grid%ivgtyp(I,J)=VEG_ID
+         grid%vegfrc(I,J)=land_vgfrac
+         grid%z0(I,J)=land_z0
+         DO K = 1,grid%num_soil_layers
+         grid%smc(I,K,J)=land_smc
+         ENDDO
+        endif
+       ENDDO
+      ENDDO
+     ELSE
+     CALL wrf_error_fatal ('Choose between 1 or 2 in land.nml')
+     ENDIF
+
+     ENDIF
+
+#endif
+!!END: LSM changes for LANDFALL : Subashini 7/27/2016
 
 !#define COPY_OUT
 !#include "scalar_derefs.inc"
@@ -2544,6 +2662,7 @@ SUBROUTINE SOLVE_NMM(GRID,CONFIG_FLAGS                            &
 ! Coupling insertion:->
         btimx=now_time()
         call ATM_SENDFLUXES
+        CALL atm_sendwindp  
         flux_tim=flux_tim+now_time()-btimx
 !<-:Coupling insertion
 !
@@ -2743,9 +2862,7 @@ SUBROUTINE TWR(ARRAY,KK,FIELD,ntsd,MYPE,NPES,MPI_COMM_COMP       &
       ENDIF
 !
 !----------------------------------------------------------------------
-!!!!  DO 500 K=KTS,KTE+KK     !Unflipped
-!!!!  DO 500 K=KTE+KK,KTS,-1
-      DO 500 K=KDE-1,KDS,-1   !Write LM layers top down for checking
+      write_layers: DO K=KDE-1,KDS,-1   !Write LM layers top down for checking
 !----------------------------------------------------------------------
 !
 #if defined(DM_PARALLEL) && !defined(STUBMPI)
@@ -2838,7 +2955,7 @@ SUBROUTINE TWR(ARRAY,KK,FIELD,ntsd,MYPE,NPES,MPI_COMM_COMP       &
 
 !
 !----------------------------------------------------------------------
-  500 CONTINUE
+      ENDDO write_layers
 !
       IF(MYPE==0)CLOSE(IUNIT)
 !----------------------------------------------------------------------
@@ -2933,9 +3050,7 @@ SUBROUTINE VWR(ARRAY,KK,FIELD,ntsd,MYPE,NPES,MPI_COMM_COMP       &
 !     ENDIF
 !
 !----------------------------------------------------------------------
-!!!!  DO 500 K=KTS,KTE+KK     !Unflipped
-!!!!  DO 500 K=KTE+KK,KTS,-1
-      DO 500 K=KDE-1,KDS,-1   !Write LM layers top down for checking
+      write_layers: DO K=KDE-1,KDS,-1   !Write LM layers top down for checking
 !----------------------------------------------------------------------
 !
 #if defined(DM_PARALLEL) && !defined(STUBMPI)
@@ -3027,7 +3142,7 @@ SUBROUTINE VWR(ARRAY,KK,FIELD,ntsd,MYPE,NPES,MPI_COMM_COMP       &
 #endif
 !
 !----------------------------------------------------------------------
-  500 CONTINUE
+      ENDDO write_layers
 !
       IF(MYPE==0)CLOSE(IUNIT)
 !----------------------------------------------------------------------
@@ -3398,8 +3513,8 @@ SUBROUTINE FIELD_STATS(FIELD,MYPE,MPI_COMM_COMP                  &
         POINTS=I_BY_J
         DO K=KTE,KTS,-1
           F_MEAN=SUMF_0(K)/POINTS
-          ST_DEV=SQRT((POINTS*SUMF2_0(K)-SUMF_0(K)*SUMF_0(K))/         &
-     &                (POINTS*(POINTS-1)))
+          ST_DEV=SQRT((AMAX1(0.0,POINTS*SUMF2_0(K)-SUMF_0(K)*SUMF_0(K))/ &
+     &                (POINTS*(POINTS-1))))
           RMS=SQRT(SUMF2_0(K)/POINTS)
           KFLIP=KTE-K+1
           WRITE(message,101)KFLIP,FMAX_0(K),FMIN_0(K)
diff --git a/wrfv2_fire/dyn_nmm/start_domain_nmm.F b/wrfv2_fire/dyn_nmm/start_domain_nmm.F
index ef56625a..dc787e11 100644
--- a/wrfv2_fire/dyn_nmm/start_domain_nmm.F
+++ b/wrfv2_fire/dyn_nmm/start_domain_nmm.F
@@ -66,6 +66,7 @@ SUBROUTINE START_DOMAIN_NMM(GRID, allowed_to_read                &
       USE MODULE_CLEAR_HALOS, only: clear_ij_halos
       USE MODULE_STATS_FOR_MOVE, only: vorttrak_init
       USE MODULE_SWATH, only: init_swath
+      USE MODULE_SF_EXCHCOEF, only: znot_wind10m
 #endif
       USE MODULE_TIMING
 #if ( HWRF == 1 )
@@ -159,7 +160,7 @@ END SUBROUTINE med_set_egrid_locs
       INTEGER :: I_M
 !
       INTEGER :: ILPAD2,IRPAD2,JBPAD2,JTPAD2
-      INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE
+      INTEGER :: ITS,ITE,JTS,JTE,KTS,KTE, nhki, nhkj
 !
       INTEGER,DIMENSION(3) :: LPTOP
 !
@@ -168,9 +169,12 @@ END SUBROUTINE med_set_egrid_locs
      &       ,SLPM,TERM1,THLM,TIME,TLM,TSFCK,ULM,VLM
 !
 !!!   REAL :: BLDT,CWML,EXNSFC,G_INV,PLYR,PSFC,ROG,SFCZ,THSIJ,TL
-      REAL :: CWML,EXNSFC,G_INV,PLYR,PSURF,ROG,SFCZ,THSIJ,TL,ZOQING
+      REAL :: CWML,EXNSFC,G_INV,PLYR,PSURF,ROG,SFCZ,THSIJ,TL
       REAL :: TEND, TEMPDX,TEMPDY
 #if ( HWRF == 1 )
+! For calculating 10-m wind from lowest model level wind
+      INTEGER :: ITER
+      REAL :: windlmtmp,wind10tmp,wind10new,znotmtmp,znotttmp
 !zhang's doing 
       REAL :: TSTART
 !zhang's doing ends
@@ -704,14 +708,22 @@ END SUBROUTINE med_set_egrid_locs
                             IMS,IME,JMS,JME,KMS,KME, &
                             ITS,ITE,JTS,JTE,KTS,KTE)
          call init_swath(grid, config_flags, &
-              (allowed_to_read .and. .not. restrt) )
+              (allowed_to_read .and. .not. restrt),&
+              allowed_to_read)
     ENDIF
     IF(ANAL .or. allowed_to_read) THEN
+       call wrf_debug(1,'Request update to area of interest in start_domain_nmm.')
        grid%update_interest=.true.
     ENDIF
 ! End Sam Trahan's doing for vortex tracker initialization
 #endif
 #if ( HWRF == 1 )
+! Begin Sam Trahan's change to merge two log messages for WRF_NMM
+    IF(allowed_to_read .and. .not. restrt) THEN
+       grid%avgPchg=0
+    ENDIF
+! End Sam Trahan's change to merge two log messages for WRF_NMM
+
 !zhang's doing
   IF((.NOT.RESTRT .AND. .NOT.ANAL) .OR. .NOT.allowed_to_read)THEN
 !end of zhang's doing
@@ -1533,26 +1545,27 @@ END SUBROUTINE med_set_egrid_locs
 #endif
           grid%th10(I,J)=FAC2*grid%ths(I,J)+FAC1*THLM
           grid%q10(I,J)=FAC2*grid%qsh(I,J)+FAC1*QLM
-#if ( HWRF == 1 )
+#if (HWRF == 1)
           IF(grid%sm(I,J).LT.0.5)THEN
-              grid%u10(I,J)=ULM*(log(10./grid%z0(I,J))/log(DZLM/grid%z0(I,J)))      ! this is all Qingfu's doing
+              grid%u10(I,J)=ULM*(log(10./grid%z0(I,J))/log(DZLM/grid%z0(I,J)))
               grid%v10(I,J)=VLM*(log(10./grid%z0(I,J))/log(DZLM/grid%z0(I,J)))
-              ZOQING=1.944*SQRT(grid%u10(I,J)*grid%u10(I,J)+grid%v10(I,J)*grid%v10(I,J))
-            IF(ZOQING.GT.60.)THEN
-              grid%u10(I,J)=grid%u10(I,J)*(1.12-7.2/ZOQING)
-              grid%v10(I,J)=grid%v10(I,J)*(1.12-7.2/ZOQING)
-             ENDIF
           ELSE
-             ZOQING=(0.074*SQRT(ULM*ULM+VLM*VLM)-0.58)*1.0e-3
-             ZOQING=MAX(ZOQING,grid%z0(I,J))          ! for winds greater than 12.5 m/s
-             grid%u10(I,J)=ULM*(log(10./ZOQING))/log(DZLM/ZOQING)      ! this is all Qingfu's doing
-             grid%v10(I,J)=VLM*(log(10./ZOQING))/log(DZLM/ZOQING)
-             ZOQING=1.944*SQRT(grid%u10(I,J)*grid%u10(I,J)+grid%v10(I,J)*grid%v10(I,J))
-           IF(ZOQING.GT.60.)THEN
-              grid%u10(I,J)=grid%u10(I,J)*(1.12-7.2/ZOQING)
-              grid%v10(I,J)=grid%v10(I,J)*(1.12-7.2/ZOQING)
-           END IF
-          ENDIF          
+             windlmtmp=SQRT(ULM*ULM+VLM*VLM)
+             wind10tmp=windlmtmp
+             DO ITER=1,10
+               call znot_wind10m(wind10tmp,znotttmp,znotmtmp,config_flags%icoef_sf)
+               znotmtmp=MAX(znotmtmp,1.e-6)
+               wind10new=windlmtmp*(log(10./znotmtmp))/log(DZLM/znotmtmp)
+               IF (ABS(wind10new-wind10tmp) .LE. 1.e-3 ) EXIT
+               wind10tmp=wind10new
+               IF ( ITER .GE. 10 ) THEN
+                 write(message,*) 'Warning: reached the 10th iteration step in calculating U10 from ULM'
+                 CALL wrf_message( message )
+               ENDIF
+             ENDDO
+             grid%u10(I,J)=ULM*(log(10./znotmtmp))/log(DZLM/znotmtmp)
+             grid%v10(I,J)=VLM*(log(10./znotmtmp))/log(DZLM/znotmtmp)
+          ENDIF
 #else
           grid%u10(I,J)=ULM
           grid%v10(I,J)=VLM
@@ -1625,17 +1638,24 @@ END SUBROUTINE med_set_egrid_locs
 !
 !!!!	SHOULD grid%dwdt BE REDEFINED IF RESTRT?
 
+      if(grid%nhmove<0) then
+         nhki=1
+         nhkj=1
+      elseif(grid%nhmove>0) then
+         nhki=3
+         nhkj=6
+      endif
+
       IF((.NOT.RESTRT.OR.NEST).AND. allowed_to_read)THEN ! This is gopal's inclusion for moving nest
         DO K=KPS,KPE
           DO J=JFS,JFE
-             if(.not. grid%keepnh .or. .not. nestmove &
-                    .or. j<7 .or. j+6>jfe) then
+             if(grid%nhmove==0 .or. .not. nestmove .or. jjfe) then
                 DO I=IFS,IFE
                    grid%dwdt(I,J,K)=1.
                 ENDDO
              else
-                grid%dwdt(1:3,j,k)=1.
-                grid%dwdt(ife-2:ife,j,k)=1.
+                grid%dwdt(1:nhki,j,k)=1.
+                grid%dwdt(ife-nhki+1:ife,j,k)=1.
              endif
           ENDDO
         ENDDO
@@ -1687,28 +1707,44 @@ END SUBROUTINE med_set_egrid_locs
         enddo
 #endif
         if(nestmove) then
-           if(.not.grid%keepnh) then
-              call wrf_message('Discarding non-hydrostatic state at nest move.  Set keepnh=T to retain the state.')
-           else
+           if(grid%nhmove==0) then
+              call wrf_message('Discarding non-hydrostatic state at nest move.  Set nhmove=-1 to retain the state everywhere or nhmove=1 to discard only at the boundaries.')
+           elseif(grid%nhmove>0) then
               call wrf_message('Retaining non-hydrostatic state at nest move except at nest boundaries.')
+           else
+              call wrf_message('Retaining non-hydrostatic state at nest move.')
            endif
         endif
 
+        if(grid%nhmove<0) then
+           nhki=1
+           nhkj=1
+        elseif(grid%nhmove>0) then
+           nhki=3
+           nhkj=6
+        endif
+
         DO K=KPS,KPE
         DO J=JFS,JFE
-           if(.not.nestmove .or. .not. grid%keepnh .or. j<7 .or. j+6>=jfe) then
+           if(grid%nhmove==0 .or. .not.nestmove .or. j=jfe) then
               DO I=IFS,IFE
                  grid%pint(I,J,K)=grid%eta1(K)*grid%pdtop+grid%eta2(K)*grid%pdsl(I,J)+grid%pt
                  grid%z(I,J,K)=grid%pint(I,J,K)
                  grid%w(I,J,K)=0.
               ENDDO
            else
-              grid%pint(1:3,J,K)=grid%eta1(K)*grid%pdtop+grid%eta2(K)*grid%pdsl(I,J)+grid%pt
-              grid%z(1:3,J,K)=grid%pint(I,J,K)
-              grid%w(1:3,J,K)=0.
-              grid%pint(ife-2:ife,J,K)=grid%eta1(K)*grid%pdtop+grid%eta2(K)*grid%pdsl(I,J)+grid%pt
-              grid%z(ife-2:ife,J,K)=grid%pint(I,J,K)
-              grid%w(ife-2:ife,J,K)=0.
+              ! Rotated West boundary:
+              do I=1,nhki
+                 grid%pint(I,J,K)=grid%eta1(K)*grid%pdtop+grid%eta2(K)*grid%pdsl(I,J)+grid%pt
+                 grid%z(I,J,K)=grid%pint(I,J,K)
+                 grid%w(I,J,K)=0.
+              enddo
+              ! Rotated East boundary:
+              do I=ife-nhki+1,ife
+                 grid%pint(I,J,K)=grid%eta1(K)*grid%pdtop+grid%eta2(K)*grid%pdsl(I,J)+grid%pt
+                 grid%z(I,J,K)=grid%pint(I,J,K)
+                 grid%w(I,J,K)=0.
+              enddo
            endif
         ENDDO
         ENDDO
@@ -2148,6 +2184,7 @@ END SUBROUTINE med_set_egrid_locs
      &                WTXY=grid%WTXY, LFMASSXY=grid%LFMASSXY, RTMASSXY=grid%RTMASSXY,    & ! Optional Noah-MP
      &                STMASSXY=grid%STMASSXY, WOODXY=grid%WOODXY,                        & ! Optional Noah-MP
      &                GRAINXY=grid%GRAINXY, GDDXY=grid%GDDXY,                            & ! Optional Noah-MP
+     &                CROPTYPE=grid%CROPTYPE, CROPCAT=grid%CROPCAT,                      & ! Optional Noah-MP
      &                STBLCPXY=grid%STBLCPXY, FASTCPXY=grid%FASTCPXY,                    & ! Optional Noah-MP
      &                XSAIXY=grid%XSAIXY,LAI=grid%LAI,                                   & ! Optional Noah-MP
      &                T2MVXY=grid%T2MVXY, T2MBXY=grid%T2MBXY, CHSTARXY=grid%CHSTARXY,    & ! Optional Noah-MP
diff --git a/wrfv2_fire/external/.gitignore b/wrfv2_fire/external/.gitignore
new file mode 100644
index 00000000..86611601
--- /dev/null
+++ b/wrfv2_fire/external/.gitignore
@@ -0,0 +1,17 @@
+# This is the top-level .gitignore file for the "external" directory for the #
+# WRF Model                                                                  #
+#                                                                            #
+# Filenames and wildcards added below will not be tracked by git anywhere in #
+# this directory or any of its subdirectories. Note that these rules will be #
+# supplemented by rules in the top-level .gitignore file                     #
+#                                                                            #
+# Ignored file types should include executables, build-time temporary files, #
+# and other files which should not ever be added to the code repository.     #
+#                                                                            #
+# USE CAUTION WHEN ADDING WILDCARDS, as some builds use different filename   #
+# conventions than others                                                    #
+##############################################################################
+*.f
+
+# Exceptions to top-level .gitignore: many external/ source code files use .f90 extension
+!*.f90
diff --git a/wrfv2_fire/external/RSL_LITE/module_dm.F b/wrfv2_fire/external/RSL_LITE/module_dm.F
index da95415a..cc497dfc 100644
--- a/wrfv2_fire/external/RSL_LITE/module_dm.F
+++ b/wrfv2_fire/external/RSL_LITE/module_dm.F
@@ -1,3 +1,18 @@
+! sed -e "s/grid%mu/gridmu/g" -e "s/grid%Mu/gridMu/g" module_dm.F | cpp -DDM_PARALLEL=1 -DHYBRID_COORD=1 -DEM_CORE=1 | sed -e "s/gridmu/grid%mu/g" -e "s/gridMu/grid%Mu/g" > module_dm.next
+#if ( HYBRID_COORD==1 )
+#  define gridmu_2(...) (ngrid%c1h(k)*XXPC2HXX(__VA_ARGS__))
+#  define XXPC2HXX(...) grid%mu_2(__VA_ARGS__)
+
+#  define gridmub(...) (ngrid%c1h(k)*XXPCBHXX(__VA_ARGS__)+ngrid%c2h(k))
+#  define XXPCBHXX(...) grid%mub(__VA_ARGS__)
+
+#  define gridMu_2(...) (ngrid%c1f(k)*XXPC2FXX(__VA_ARGS__))
+#  define XXPC2FXX(...) grid%Mu_2(__VA_ARGS__)
+
+#  define gridMub(...) (ngrid%c1f(k)*XXPCBFXX(__VA_ARGS__)+ngrid%c2f(k))
+#  define XXPCBFXX(...) grid%Mub(__VA_ARGS__)
+#endif
+
 #if NMM_CORE==1
 #define copy_fcnm UpNear
 #define copy_fcn UpCopy
@@ -192,7 +207,6 @@ END SUBROUTINE compute_mesh
    SUBROUTINE wrf_dm_initialize
       IMPLICIT NONE
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
       INTEGER :: local_comm_per, local_comm_x, local_comm_y, local_comm2, new_local_comm, group, newgroup, p, p1, ierr,itmp
       INTEGER, ALLOCATABLE, DIMENSION(:) :: ranks
       INTEGER comdup
@@ -1279,7 +1293,6 @@ END SUBROUTINE compute_memory_dims_rsl_lite
    INTEGER function getrealmpitype()
 #ifndef STUBMPI
       IMPLICIT NONE
-      INCLUDE 'mpif.h'
       INTEGER rtypesize, dtypesize, ierr
       CALL mpi_type_size ( MPI_REAL, rtypesize, ierr )
       CALL mpi_type_size ( MPI_DOUBLE_PRECISION, dtypesize, ierr )
@@ -1297,10 +1310,23 @@ INTEGER function getrealmpitype()
       RETURN
    END FUNCTION getrealmpitype
 
-   REAL FUNCTION wrf_dm_max_real ( inval )
+   REAL FUNCTION wrf_dm_max_int ( inval )
       IMPLICIT NONE
 #ifndef STUBMPI
       INCLUDE 'mpif.h'
+      INTEGER, intent(in) :: inval
+      INTEGER :: ierr, retval
+      CALL mpi_allreduce ( inval, retval , 1, MPI_INT, MPI_MAX, local_communicator, ierr )
+      wrf_dm_max_int = retval
+#else
+      INTEGER, intent(in) :: inval
+      wrf_dm_max_int = inval
+#endif
+   END FUNCTION wrf_dm_max_int
+
+   REAL FUNCTION wrf_dm_max_real ( inval )
+      IMPLICIT NONE
+#ifndef STUBMPI
       REAL inval, retval
       INTEGER comm,ierr
       CALL wrf_get_dm_communicator(comm)
@@ -1315,7 +1341,6 @@ END FUNCTION wrf_dm_max_real
    REAL FUNCTION wrf_dm_min_real ( inval )
       IMPLICIT NONE
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
       REAL inval, retval
       INTEGER comm,ierr
       CALL wrf_get_dm_communicator(comm)
@@ -1333,7 +1358,6 @@ SUBROUTINE wrf_dm_min_reals ( inval, retval, n )
       REAL inval(*)
       REAL retval(*)
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
       INTEGER comm,ierr
       CALL wrf_get_dm_communicator(comm)
       CALL mpi_allreduce ( inval, retval , n, getrealmpitype(), MPI_MIN, comm, ierr )
@@ -1347,7 +1371,6 @@ FUNCTION wrf_dm_sum_real8 ( inval )
      ! mean motion in HWRF moduel_tracker.
       IMPLICIT NONE
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
       REAL*8 inval, retval, wrf_dm_sum_real8
       INTEGER comm,ierr
       CALL wrf_get_dm_communicator(comm)
@@ -1362,7 +1385,6 @@ END FUNCTION wrf_dm_sum_real8
    REAL FUNCTION wrf_dm_sum_real ( inval )
       IMPLICIT NONE
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
       REAL inval, retval
       INTEGER comm,ierr
       CALL wrf_get_dm_communicator(comm)
@@ -1379,7 +1401,6 @@ SUBROUTINE wrf_dm_sum_reals (inval, retval)
       REAL, INTENT(IN)  :: inval(:)
       REAL, INTENT(OUT) :: retval(:)
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
       INTEGER comm,ierr
       CALL wrf_get_dm_communicator(comm)
       CALL mpi_allreduce ( inval, retval, SIZE(inval), getrealmpitype(), MPI_SUM, comm, ierr )
@@ -1391,7 +1412,6 @@ END SUBROUTINE wrf_dm_sum_reals
    INTEGER FUNCTION wrf_dm_sum_integer ( inval )
       IMPLICIT NONE
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
       INTEGER inval, retval
       INTEGER comm,ierr
       CALL wrf_get_dm_communicator(comm)
@@ -1408,7 +1428,6 @@ SUBROUTINE wrf_dm_sum_integers (inval, retval)
       INTEGER, INTENT(IN)  :: inval(:)
       INTEGER, INTENT(OUT) :: retval(:)
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
       INTEGER comm,ierr
       CALL wrf_get_dm_communicator(comm)
       CALL mpi_allreduce ( inval, retval, SIZE(inval), MPI_INTEGER, MPI_SUM, comm, ierr )
@@ -1477,7 +1496,6 @@ END SUBROUTINE wrf_dm_maxloc_real
    INTEGER FUNCTION wrf_dm_bxor_integer ( inval )
       IMPLICIT NONE
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
       INTEGER inval, retval
       INTEGER comm, ierr
       CALL wrf_get_dm_communicator(comm)
@@ -1489,6 +1507,37 @@ INTEGER FUNCTION wrf_dm_bxor_integer ( inval )
 #endif
    END FUNCTION wrf_dm_bxor_integer
 
+
+LOGICAL FUNCTION wrf_dm_lor_logical ( inval )
+      IMPLICIT NONE
+#ifndef STUBMPI
+      LOGICAL inval, retval
+      INTEGER comm, ierr
+      CALL wrf_get_dm_communicator(comm)
+      CALL mpi_allreduce ( inval, retval , 1, MPI_LOGICAL, MPI_LOR, comm, ierr )
+      wrf_dm_lor_logical = retval
+#else
+      LOGICAL inval
+      wrf_dm_lor_logical = inval
+#endif
+   END FUNCTION wrf_dm_lor_logical
+
+
+LOGICAL FUNCTION wrf_dm_land_logical ( inval )
+      IMPLICIT NONE
+#ifndef STUBMPI
+      LOGICAL inval, retval
+      INTEGER comm, ierr
+      CALL wrf_get_dm_communicator(comm)
+      CALL mpi_allreduce ( inval, retval , 1, MPI_LOGICAL, MPI_LAND, comm, ierr )
+      wrf_dm_land_logical = retval
+#else
+      LOGICAL inval
+      wrf_dm_land_logical = inval
+#endif
+   END FUNCTION wrf_dm_land_logical
+
+
    SUBROUTINE wrf_dm_maxval_real ( val, idex, jdex )
 # ifndef STUBMPI
       use mpi
@@ -1651,7 +1700,6 @@ SUBROUTINE hwrf_coupler_init
 #if ( HWRF == 1 )
 # ifndef STUBMPI
       IMPLICIT NONE
-      INCLUDE 'mpif.h'
       LOGICAL mpi_inited
       INTEGER mpi_comm_here,ierr
       CALL MPI_INITIALIZED( mpi_inited, ierr )
@@ -1674,7 +1722,6 @@ END SUBROUTINE hwrf_coupler_init
    SUBROUTINE split_communicator
 #ifndef STUBMPI
       IMPLICIT NONE
-      INCLUDE 'mpif.h'
       LOGICAL mpi_inited
 !      INTEGER mpi_comm_here, mpi_comm_local, comdup, comdup2, origmytask,  mytask, ntasks, ierr, io_status
       INTEGER mpi_comm_here, mpi_comm_local, comdup, comdup2, origmytask,  ierr, io_status
@@ -2122,7 +2169,6 @@ SUBROUTINE init_module_dm
 #ifndef STUBMPI
       IMPLICIT NONE
       INTEGER mpi_comm_local, mpi_comm_here, ierr, mytask, nproc
-      INCLUDE 'mpif.h'
       LOGICAL mpi_inited
       CALL mpi_initialized( mpi_inited, ierr )
       IF ( .NOT. mpi_inited ) THEN
@@ -2169,7 +2215,6 @@ SUBROUTINE get_full_obs_vector( nsta, nerrf, niobf,          &
     REAL, INTENT(INOUT)   :: errf(nerrf, niobf)
 
 #ifndef STUBMPI
-    INCLUDE 'mpif.h'
         
 ! Local declarations
     integer i, n, nlocal_dot, nlocal_crs
@@ -2355,7 +2400,6 @@ SUBROUTINE wrf_dm_maxtile_real ( val , tile)
 ! 
       INTEGER i, comm
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
 
       CALL wrf_get_dm_communicator ( comm )
       CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
@@ -2384,7 +2428,6 @@ SUBROUTINE wrf_dm_mintile_real ( val , tile)
 ! 
       INTEGER i, comm
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
 
       CALL wrf_get_dm_communicator ( comm )
       CALL mpi_allgather ( val, 1, getrealmpitype(), val_all , 1, getrealmpitype(), comm, ierr )
@@ -2413,7 +2456,6 @@ SUBROUTINE wrf_dm_mintile_double ( val , tile)
 ! 
       INTEGER i, comm
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
 
       CALL wrf_get_dm_communicator ( comm )
       CALL mpi_allgather ( val, 1, MPI_DOUBLE_PRECISION, val_all , 1, MPI_DOUBLE_PRECISION, comm, ierr )
@@ -2441,7 +2483,6 @@ SUBROUTINE wrf_dm_tile_val_int ( val , tile)
 ! 
       INTEGER i, comm
 #ifndef STUBMPI
-      INCLUDE 'mpif.h'
 
       CALL wrf_get_dm_communicator ( comm )
       CALL mpi_allgather ( val, 1, MPI_INTEGER, val_all , 1, MPI_INTEGER, comm, ierr )
@@ -4074,7 +4115,7 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags    &
       TYPE(domain), POINTER :: pgrid         !KAL added for vertical nesting
 #include "dummy_new_decl.inc"
       INTEGER nlev, msize
-      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k
+      INTEGER i,j,pig,pjg,cm,cn,nig,njg,retval,k,kk
       TYPE (grid_config_rec_type)            :: config_flags
       REAL xv(2000)
       INTEGER       ::          cids, cide, cjds, cjde, ckds, ckde,    &
@@ -4137,22 +4178,38 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags    &
       mu_m = p_surf_m - p_top_m
 !    parent
       do  k = 1,ckde
+#if  !( HYBRID_COORD==1 )
       pre_c = mu_m * pgrid%znw(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+      pre_c = mu_m * pgrid%c3f(k) + p_top_m + pgrid%c4f(k)
+#endif
       alt_w_c(k) =  -hsca_m * alog(pre_c/p_surf_m)
       enddo   
       do  k = 1,ckde-1
+#if  !( HYBRID_COORD==1 )
       pre_c = mu_m * pgrid%znu(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+      pre_c = mu_m * pgrid%c3h(k) + p_top_m + pgrid%c4h(k)
+#endif
       alt_u_c(k+1) =  -hsca_m * alog(pre_c/p_surf_m)
       enddo
       alt_u_c(1) =  alt_w_c(1) 
       alt_u_c(ckde+1) =  alt_w_c(ckde)       
 !    nest
       do  k = 1,nkde
+#if  !( HYBRID_COORD==1 )
       pre_n = mu_m * ngrid%znw(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+      pre_n = mu_m * ngrid%c3f(k) + p_top_m + ngrid%c4f(k)
+#endif
       alt_w_n(k) =  -hsca_m * alog(pre_n/p_surf_m)
       enddo
       do  k = 1,nkde-1
+#if  !( HYBRID_COORD==1 )
       pre_n = mu_m * ngrid%znu(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+      pre_n = mu_m * ngrid%c3h(k) + p_top_m + ngrid%c4h(k)
+#endif
       alt_u_n(k+1) =  -hsca_m * alog(pre_n/p_surf_m)
       enddo
       alt_u_n(1) =  alt_w_n(1)
@@ -4205,20 +4262,24 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags    &
       
          !  Uncouple the variables moist and t_2 that are used to calculate ph_2
 
-         DO j = jps,jpe
-            DO i = ips,ipe
-               DO k=kps,kpe-1
+         DO j = MAX(jds,jps),MIN(jde-1,jpe)
+            DO i = MAX(ids,ips),MIN(ide-1,ipe)
+               DO k=kds,kde-1
                   grid%t_2(i,k,j) = grid%t_2(i,k,j)/(grid%mub(i,j) + grid%mu_2(i,j))
                   moist(i,k,j,P_QV) = moist(i,k,j,P_QV)/(grid%mub(i,j) + grid%mu_2(i,j))
                END DO
             END DO
          END DO
     
-         DO j = jps, jpe
-            DO i = ips,ipe
+         DO j = MAX(jds,jps),MIN(jde-1,jpe)
+            DO i = MAX(ids,ips),MIN(ide-1,ipe)
 
                DO k = 1, kpe-1
+#if  !( HYBRID_COORD==1 )
                   grid%pb(i,k,j) = ngrid%znu(k)*grid%mub(i,j)+ngrid%p_top
+#elif ( HYBRID_COORD==1 )
+                  grid%pb(i,k,j) = ngrid%c3h(k)*grid%mub(i,j) + ngrid%c4h(k) + ngrid%p_top
+#endif
              
                   !  If this is a real run, recalc t_init.
    
@@ -4238,14 +4299,21 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags    &
    
                grid%phb(i,1,j) = grid%ht(i,j) * g
                IF (grid%hypsometric_opt == 1) THEN
-                  DO k = 2,kpe
-                     grid%phb(i,k,j) = grid%phb(i,k-1,j) - ngrid%dnw(k-1)*grid%mub(i,j)*grid%alb(i,k-1,j)
+                  DO kk = 2,kpe
+                     k = kk - 1
+                     grid%phb(i,kk,j) = grid%phb(i,k,j) - ngrid%dnw(k)*grid%mub(i,j)*grid%alb(i,k,j)
                   END DO
                ELSE IF (grid%hypsometric_opt == 2) THEN
                   DO k = 2,kpe
+#if  !( HYBRID_COORD==1 )
                      pfu = grid%mub(i,j)*ngrid%znw(k)   + ngrid%p_top
                      pfd = grid%mub(i,j)*ngrid%znw(k-1) + ngrid%p_top
                      phm = grid%mub(i,j)*ngrid%znu(k-1) + ngrid%p_top
+#elif ( HYBRID_COORD==1 )
+                     pfu = ngrid%c3f(k  )*grid%MUB(i,j) + ngrid%c4f(k  ) + ngrid%p_top
+                     pfd = ngrid%c3f(k-1)*grid%MUB(i,j) + ngrid%c4f(k-1) + ngrid%p_top
+                     phm = ngrid%c3h(k-1)*grid%MUB(i,j) + ngrid%c4h(k-1) + ngrid%p_top
+#endif
                      grid%phb(i,k,j) = grid%phb(i,k-1,j) + grid%alb(i,k-1,j)*phm*LOG(pfd/pfu)
                   END DO
                ELSE
@@ -4259,45 +4327,48 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags    &
          ALLOCATE( p (ips:ipe, kps:kpe, jps:jpe) )
          ALLOCATE( al(ips:ipe, kps:kpe, jps:jpe) )
 
-         DO j = jps, jpe
-            DO i = ips, ipe
+         DO j = MAX(jds,jps),MIN(jde-1,jpe)
+            DO i = MAX(ids,ips),MIN(ide-1,ipe)
 
                !  Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum
                !  equation) down from the top to get the pressure perturbation.  First get the pressure
                !  perturbation, moisture, and inverse density (total and perturbation) at the top-most level.
       
-               k = kpe-1
+               kk = kpe-1
+               k = kk+1
       
-               qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k,j,P_QV))
+               qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk,j,P_QV))
                qvf2 = 1./(1.+qvf1)
                qvf1 = qvf1*qvf2
       
-               p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/ngrid%rdnw(k)/qvf2
-               qvf = 1. + rvovrd*moist(i,k,j,P_QV)
-               al(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* &
-                           (((p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%alb(i,k,j)
+               p(i,kk,j) = - 0.5*(grid%Mu_2(i,j)+qvf1*grid%Mub(i,j))/ngrid%rdnw(kk)/qvf2
+               qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
+               al(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
+                           (((p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) - grid%alb(i,kk,j)
       
                !  Now, integrate down the column to compute the pressure perturbation, and diagnose the two
                !  inverse density fields (total and perturbation).
       
-               DO k=kpe-2,1,-1
-                  qvf1 = 0.5*(moist(i,k,j,P_QV)+moist(i,k+1,j,P_QV))
+               DO kk=kpe-2,1,-1
+                  k = kk + 1
+                  qvf1 = 0.5*(moist(i,kk,j,P_QV)+moist(i,kk+1,j,P_QV))
                   qvf2 = 1./(1.+qvf1)
                   qvf1 = qvf1*qvf2
-                  p(i,k,j) = p(i,k+1,j) - (grid%mu_2(i,j) + qvf1*grid%mub(i,j))/qvf2/ngrid%rdn(k+1)
-                  qvf = 1. + rvovrd*moist(i,k,j,P_QV)
-                  al(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* &
-                              (((p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm) - grid%alb(i,k,j)
+                  p(i,kk,j) = p(i,kk+1,j) - (grid%Mu_2(i,j) + qvf1*grid%Mub(i,j))/qvf2/ngrid%rdn(kk+1)
+                  qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
+                  al(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
+                              (((p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm) - grid%alb(i,kk,j)
                END DO
       
                !  This is the hydrostatic equation used in the model after the small timesteps.  In
                !  the model, grid%al (inverse density) is computed from the geopotential.
       
                IF (grid%hypsometric_opt == 1) THEN
-                  DO k  = 2,kpe
-                     grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - &
-                                        ngrid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*al(i,k-1,j) &
-                                        + grid%mu_2(i,j)*grid%alb(i,k-1,j) )
+                  DO kk = 2,kpe
+                     k = kk - 1
+                     grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - &
+                                        ngrid%dnw(kk-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*al(i,kk-1,j) &
+                                        + grid%mu_2(i,j)*grid%alb(i,kk-1,j) )
                   END DO
       
                ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is dry pressure.
@@ -4308,9 +4379,15 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags    &
       
                   grid%ph_2(i,1,j) = grid%phb(i,1,j)
                   DO k = 2,kpe
+#if  !( HYBRID_COORD==1 )
                      pfu = ( grid%mub(i,j)+grid%mu_2(i,j))*ngrid%znw(k)   + ngrid%p_top
                      pfd = ( grid%mub(i,j)+grid%mu_2(i,j))*ngrid%znw(k-1) + ngrid%p_top
                      phm = ( grid%mub(i,j)+grid%mu_2(i,j))*ngrid%znu(k-1) + ngrid%p_top
+#elif ( HYBRID_COORD==1 )
+                     pfu = ngrid%c3f(k  )*( grid%MUB(i,j)+grid%MU_2(i,j) ) + ngrid%c4f(k  ) + ngrid%p_top
+                     pfd = ngrid%c3f(k-1)*( grid%MUB(i,j)+grid%MU_2(i,j) ) + ngrid%c4f(k-1) + ngrid%p_top
+                     phm = ngrid%c3h(k-1)*( grid%MUB(i,j)+grid%MU_2(i,j) ) + ngrid%c4h(k-1) + ngrid%p_top
+#endif
                      grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + (grid%alb(i,k-1,j)+al(i,k-1,j))*phm*LOG(pfd/pfu)
                   END DO
       
@@ -4327,15 +4404,15 @@ SUBROUTINE force_domain_em_part2 ( grid, ngrid, pgrid, config_flags    &
          DEALLOCATE(al)
       
          ! Couple the variables moist and t_2, and the newly calculated ph_2
-         DO j = jps, jpe
-            DO i = ips,ipe
+         DO j = MAX(jds,jps),MIN(jde-1,jpe)
+            DO i = MAX(ids,ips),MIN(ide-1,ipe)
                DO k=kps,kpe
-               grid%ph_2(i,k,j) = grid%ph_2(i,k,j)*(grid%mub(i,j) + grid%mu_2(i,j))
+               grid%ph_2(i,k,j) = grid%ph_2(i,k,j)*(grid%Mub(i,j) + grid%Mu_2(i,j))
                END DO
             END DO
          END DO
-         DO j = jps, jpe
-            DO i = ips,ipe
+         DO j = MAX(jds,jps),MIN(jde-1,jpe)
+            DO i = MAX(ids,ips),MIN(ide-1,ipe)
                DO k=kps,kpe-1
                grid%t_2(i,k,j) = grid%t_2(i,k,j)*(grid%mub(i,j) + grid%mu_2(i,j))
                moist(i,k,j,P_QV) = moist(i,k,j,P_QV)*(grid%mub(i,j) + grid%mu_2(i,j))
@@ -4543,22 +4620,38 @@ SUBROUTINE interp_domain_em_part2 ( grid, ngrid, pgrid, config_flags    &
       mu_m = p_surf_m - p_top_m
 !    parent
       do  k = 1,ckde
+#if  !( HYBRID_COORD==1 )
       pre_c = mu_m * pgrid%znw(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+      pre_c = mu_m * pgrid%c3f(k) + p_top_m + pgrid%c4f(k)
+#endif
       alt_w_c(k) =  -hsca_m * alog(pre_c/p_surf_m)
       enddo   
       do  k = 1,ckde-1
+#if  !( HYBRID_COORD==1 )
       pre_c = mu_m * pgrid%znu(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+      pre_c = mu_m * pgrid%c3h(k) + p_top_m + pgrid%c4h(k)
+#endif
       alt_u_c(k+1) =  -hsca_m * alog(pre_c/p_surf_m)
       enddo
       alt_u_c(1) =  alt_w_c(1) 
       alt_u_c(ckde+1) =  alt_w_c(ckde)       
 !    nest
       do  k = 1,nkde
+#if  !( HYBRID_COORD==1 )
       pre_n = mu_m * ngrid%znw(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+      pre_n = mu_m * ngrid%c3f(k) + p_top_m + ngrid%c4f(k)
+#endif
       alt_w_n(k) =  -hsca_m * alog(pre_n/p_surf_m)
       enddo
       do  k = 1,nkde-1
+#if  !( HYBRID_COORD==1 )
       pre_n = mu_m * ngrid%znu(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+      pre_n = mu_m * ngrid%c3h(k) + p_top_m + ngrid%c4h(k)
+#endif
       alt_u_n(k+1) =  -hsca_m * alog(pre_n/p_surf_m)
       enddo
       alt_u_n(1) =  alt_w_n(1)
diff --git a/wrfv2_fire/external/atm_ocn/atm_comm.F b/wrfv2_fire/external/atm_ocn/atm_comm.F
index b4216240..c7175184 100644
--- a/wrfv2_fire/external/atm_ocn/atm_comm.F
+++ b/wrfv2_fire/external/atm_ocn/atm_comm.F
@@ -33,8 +33,11 @@ MODULE ATM_cc
      &                    kind_SST=kind_R, &
      &                    kind_SLM=kind_R, &
      &                    kind_lonlat=kind_R
+      INTEGER, PARAMETER  :: kind_cur = kind_r, kind_wstate = kind_r, &
+                             kind_windp = kind_r
       integer MPI_kind_R, &
      &MPI_kind_sfcflux,MPI_kind_SST,MPI_kind_SLM,MPI_kind_lonlat
+      INTEGER :: MPI_kind_cur, MPI_kind_wstate, MPI_kind_windp
       integer n_ts(ND) /0,0,0/, gid
       integer rc /5/
       real,parameter:: &
@@ -58,13 +61,31 @@ MODULE ATM_cc
         real(kind=kind_sfcflux),dimension(:,:,:),pointer:: a
       END TYPE SF_ARRAY
 
+      TYPE cur_array
+        REAL(KIND = kind_cur), dimension(:,:), pointer :: a
+      END TYPE cur_array
+      TYPE wstate_array
+        REAL(KIND = kind_wstate), dimension(:,:), pointer :: a
+      END TYPE wstate_array
+      TYPE windp_array
+        REAL(KIND = kind_windp), dimension(:,:,:), pointer :: a
+      END TYPE windp_array
+
       TYPE (SST_ARRAY), dimension(ND):: SST_cc
       TYPE (SF_ARRAY), dimension(min(ND,2)):: sf
+      TYPE (cur_array), dimension(nd) ::  ucur_cc, vcur_cc
+      TYPE (wstate_array), dimension(nd) :: alpha_cc, gamma_cc
+      TYPE (windp_array), dimension(nd) :: wwinp
 
       character*12 sgid
 
 !Controls:
       integer nunit_announce /6/, VerbLev /3/
+! To control awo couplings
+      integer ia2o /1/, &
+     &        io2a /1/, &
+     &        ia2w /1/, &
+     &        iw2a /0/
 
       SAVE
 
@@ -113,7 +134,14 @@ SUBROUTINE ATM_CMP_START(atm_comm)
 
       integer atm_comm
 
-      integer Atmos_id /1/, Atmos_master_rank_local /0/, Atmos_spec /1/
+!     integer Atmos_id /1/, Atmos_master_rank_local /0/, Atmos_spec /1/
+      integer Atmos_id /1/, Atmos_master_rank_local /0/, Atmos_spec /0/
+!                                                            <- D.S.
+!        Atmos_spec=1 for the case when the only field AM receives
+!        from Coupler is SST. Atmos_spec=0 allows receiving additional
+!        fields from C., originating from both OM, WM. (Atmos_spec does
+!        not control receiving in AM but is sent to C. thus transferring
+!        the control to C.)
       integer ibuf(1),ierr
       character*20 s
 !C
@@ -145,17 +173,17 @@ SUBROUTINE ATM_CMP_START(atm_comm)
      &component_master_rank_local,MPI_COMM_Atmos,ierr)
       call ATM_ANNOUNCE('ATM_CMP_START: WM_id broadcast',2)
       if (WM_id.gt.0) then
-        NSF_WM=2
+        NSF_WM=4
       else
         NSF_WM=0
       end if
 
       if (Ocean_spec.eq.1) then
-        NSF=4+NSF_WM
+        NSF=4
       else if (Ocean_spec.eq.2) then
-        NSF=8+NSF_WM
+        NSF=8
       else if (Ocean_spec.eq.0) then
-        NSF=NSF_WM
+        NSF=1
       else if (Coupler_id.ge.0) then
         call GLOB_ABORT(Ocean_spec-1, &
      &  'ATM_CMP_START received wrong Ocean_spec value, aborted',rc)
@@ -166,6 +194,34 @@ SUBROUTINE ATM_CMP_START(atm_comm)
      &  ' assigned (as if for POM coupling)',2)
       end if
 
+      call CMP_gnr_RECV(ia2o,1,MPI_INTEGER)
+      write(s,'(i4)') ia2o
+      call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, ia2o is '//s,2)
+      call MPI_BCAST(ia2o,1,MPI_INTEGER, &
+     &component_master_rank_local,MPI_COMM_Atmos,ierr)
+      call ATM_ANNOUNCE('ATM_CMP_START: ia2o broadcast',2)
+
+      call CMP_gnr_RECV(io2a,1,MPI_INTEGER)
+      write(s,'(i4)') io2a
+      call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, io2a is '//s,2)
+      call MPI_BCAST(io2a,1,MPI_INTEGER, &
+     &component_master_rank_local,MPI_COMM_Atmos,ierr)
+      call ATM_ANNOUNCE('ATM_CMP_START: io2a broadcast',2)
+
+      call CMP_gnr_RECV(ia2w,1,MPI_INTEGER)
+      write(s,'(i4)') ia2w
+      call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, ia2w is '//s,2)
+      call MPI_BCAST(ia2w,1,MPI_INTEGER, &
+     &component_master_rank_local,MPI_COMM_Atmos,ierr)
+      call ATM_ANNOUNCE('ATM_CMP_START: ia2w broadcast',2)
+
+      call CMP_gnr_RECV(iw2a,1,MPI_INTEGER)
+      write(s,'(i4)') iw2a
+      call ATM_ANNOUNCE('back from CMP_INTEGER_RECV, iw2a is '//s,2)
+      call MPI_BCAST(iw2a,1,MPI_INTEGER, &
+     &component_master_rank_local,MPI_COMM_Atmos,ierr)
+      call ATM_ANNOUNCE('ATM_CMP_START: iw2a broadcast',2)
+
       if (kind_R.eq.kind_REAL) then
         MPI_kind_R=MPI_kind_REAL
       else 
@@ -192,6 +248,22 @@ SUBROUTINE ATM_CMP_START(atm_comm)
         MPI_kind_lonlat=MPI_kind_alt_REAL
       end if
 
+      IF (kind_cur == kind_real) THEN
+         MPI_kind_cur = MPI_kind_real
+      ELSE
+         MPI_kind_cur = MPI_kind_alt_real
+      END IF
+      IF (kind_wstate == kind_real) THEN
+         MPI_kind_wstate = MPI_kind_real
+      ELSE
+         MPI_kind_wstate = MPI_kind_alt_real
+      END IF
+      IF (kind_windp == kind_real) THEN
+         MPI_kind_windp = MPI_kind_real
+      ELSE
+         MPI_kind_windp = MPI_kind_alt_real
+      END IF
+
       atm_comm=MPI_COMM_Atmos
 
       return
@@ -318,8 +390,11 @@ subroutine ATM_TSTEP_INIT(NTSD,NPHS,gid_,dta_, &
 
       IF (gid.le.2) THEN !** innermost grid not active in coupling **
         allocate(sf(gid)%a(ims:ime,jms:jme,NSF))
+        ALLOCATE(wwinp(gid)%a(ims:ime,jms:jme,NSF_WM))
       END IF !** innermost grid not active in coupling **
         allocate(SST_cc(gid)%a(ims:ime,jms:jme))
+      ALLOCATE(ucur_cc(gid)%a(ims:ime,jms:jme), vcur_cc(gid)%a(ims:ime,jms:jme))
+      ALLOCATE(alpha_cc(gid)%a(ims:ime,jms:jme), gamma_cc(gid)%a(ims:ime,jms:jme))
 
       END IF
 
@@ -349,7 +424,7 @@ subroutine ATM_TSTEP_INIT(NTSD,NPHS,gid_,dta_, &
       if (VerbLev.ge.2) then
          write(message,*) 'AM: ATM_TSTEP_INIT: returning ',gid,         &
      &n_ts(gid),ids,idf,jds,jdf,its,ite,jts,jte,ims,ime,jms,jme,NGP,NSF
-         call wrf_message(message)
+         call wrf_debug(2,message)
       endif
 
       RETURN
@@ -524,6 +599,7 @@ SUBROUTINE ATM_GETSST(SST,SLM)
       integer i,j
       real(kind=kind_SST) SST_g(ids:idf,jds:jdf)
 !C
+      IF ( io2a .LT. 1 ) RETURN
 
       IF (.not.PHYS) RETURN
 
@@ -574,7 +650,7 @@ SUBROUTINE ATM_GETSST(SST,SLM)
 !C
       SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, &
 !c    &USTAR,U10,V10,PINT,PREC)
-     &TX,TY,PINT,PREC,U10,V10)
+     &TX,TY,PINT,PREC)
 
       USE ATM_cc
 
@@ -583,7 +659,7 @@ SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, &
       real(kind=kind_sfcflux),dimension(ims:ime,jms:jme,kms:kme):: PINT
 
       real(kind=kind_sfcflux),dimension(ims:ime,jms:jme):: &
-     &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,TX,TY,PREC,U10,V10
+     &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,TX,TY,PREC
 !c    &TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT,USTAR,U10,V10,PINT,PREC
 !       Act. arg. for PINT is a 3d array - so this only is OK if
 !       Ps=Act.arg.(:,:.1) - actually, Ps=PINT(:,1,:)
@@ -592,6 +668,7 @@ SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, &
       real dtainv
 !C
 
+      IF ( ia2o .LT. 1 .and. ia2w .LT. 1 ) RETURN
       IF (.not.PHYS) RETURN
 
       IF (gid.gt.2) RETURN
@@ -622,26 +699,26 @@ SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, &
 !oooooooooooooooooooooooooooooo
       IF (Ocean_spec.eq.1) THEN
 !oooooooooooooooooooooooooooooo
-        sf(gid)%a(its:ite,jts:jte,1)=sf(gid)%a(its:ite,jts:jte,1)-TWBS(its:ite,jts:jte)-QWBS(its:ite,jts:jte)+RADOT(its:ite,jts:jte)-RLWIN(its:ite,jts:jte)
+        sf(gid)%a(its:ite,jts:jte,NSF-3)=sf(gid)%a(its:ite,jts:jte,NSF-3)-TWBS(its:ite,jts:jte)-QWBS(its:ite,jts:jte)+RADOT(its:ite,jts:jte)-RLWIN(its:ite,jts:jte)
                                        ! -TWBS (-QWBS) is supposed to
                                        ! be sensible (latent) heat flux,
                                        ! positive upward
-        sf(gid)%a(its:ite,jts:jte,2)=sf(gid)%a(its:ite,jts:jte,2)+SWR(its:ite,jts:jte)
-        sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)-TX(its:ite,jts:jte)
-        sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)-TY(its:ite,jts:jte)
+        sf(gid)%a(its:ite,jts:jte,NSF-2)=sf(gid)%a(its:ite,jts:jte,NSF-2)+SWR(its:ite,jts:jte)
+        sf(gid)%a(its:ite,jts:jte,NSF-1)=sf(gid)%a(its:ite,jts:jte,NSF-1)-TX(its:ite,jts:jte)
+        sf(gid)%a(its:ite,jts:jte,NSF)=sf(gid)%a(its:ite,jts:jte,NSF)-TY(its:ite,jts:jte)
                      ! <- signs for stress components are changed
 !ooooooooooooooooooooooooooooooooooo
       ELSE IF (Ocean_spec.eq.2) THEN
 !ooooooooooooooooooooooooooooooooooo
-        sf(gid)%a(its:ite,jts:jte,1)=sf(gid)%a(its:ite,jts:jte,1)+PREC(its:ite,jts:jte)
-        sf(gid)%a(its:ite,jts:jte,2)=sf(gid)%a(its:ite,jts:jte,2)-TWBS(its:ite,jts:jte)
-        sf(gid)%a(its:ite,jts:jte,3)=sf(gid)%a(its:ite,jts:jte,3)-QWBS(its:ite,jts:jte)
-        sf(gid)%a(its:ite,jts:jte,4)=sf(gid)%a(its:ite,jts:jte,4)+PINT(its:ite,jts:jte,1)-101300.
-        sf(gid)%a(its:ite,jts:jte,5)=sf(gid)%a(its:ite,jts:jte,5)-SWR(its:ite,jts:jte)-RADOT(its:ite,jts:jte)+RLWIN(its:ite,jts:jte)
-        sf(gid)%a(its:ite,jts:jte,6)=sf(gid)%a(its:ite,jts:jte,6)-SWR(its:ite,jts:jte)
-
-        sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM-1)+TX(its:ite,jts:jte)
-        sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)=sf(gid)%a(its:ite,jts:jte,NSF-NSF_WM)+TY(its:ite,jts:jte)
+        sf(gid)%a(its:ite,jts:jte,NSF-7)=sf(gid)%a(its:ite,jts:jte,NSF-7)+PREC(its:ite,jts:jte)
+        sf(gid)%a(its:ite,jts:jte,NSF-6)=sf(gid)%a(its:ite,jts:jte,NSF-6)-TWBS(its:ite,jts:jte)
+        sf(gid)%a(its:ite,jts:jte,NSF-5)=sf(gid)%a(its:ite,jts:jte,NSF-5)-QWBS(its:ite,jts:jte)
+        sf(gid)%a(its:ite,jts:jte,NSF-4)=sf(gid)%a(its:ite,jts:jte,NSF-4)+PINT(its:ite,jts:jte,1)-101300.
+        sf(gid)%a(its:ite,jts:jte,NSF-3)=sf(gid)%a(its:ite,jts:jte,NSF-3)-SWR(its:ite,jts:jte)-RADOT(its:ite,jts:jte)+RLWIN(its:ite,jts:jte)
+        sf(gid)%a(its:ite,jts:jte,NSF-2)=sf(gid)%a(its:ite,jts:jte,NSF-2)-SWR(its:ite,jts:jte)
+
+        sf(gid)%a(its:ite,jts:jte,NSF-1)=sf(gid)%a(its:ite,jts:jte,NSF-1)+TX(its:ite,jts:jte)
+        sf(gid)%a(its:ite,jts:jte,NSF)=sf(gid)%a(its:ite,jts:jte,NSF)+TY(its:ite,jts:jte)
                      ! <- signs for stress components are NOT changed
         if (nrmSF) then
           sf(gid)%a(its:ite,jts:jte,1)=sf(gid)%a(its:ite,jts:jte,1)*dtainv
@@ -651,16 +728,6 @@ SUBROUTINE ATM_DOFLUXES(TWBS,QWBS,RLWIN,RSWIN,RADOT,RSWOUT, &
       END IF
 !ooooooooooo
 
-
-!wwwwwwwwwwwwwwwwwwwwwwwww
-      IF (WM_id.gt.0) THEN
-!wwwwwwwwwwwwwwwwwwwwwwwww
-        sf(gid)%a(its:ite,jts:jte,NSF-1)=sf(gid)%a(its:ite,jts:jte,NSF-1)+U10(its:ite,jts:jte)
-        sf(gid)%a(its:ite,jts:jte,NSF)=sf(gid)%a(its:ite,jts:jte,NSF)+V10(its:ite,jts:jte)
-!wwwwwwwwwww
-      END IF
-!wwwwwwwwwww
-
       if (nrmSF) then
         sf(gid)%a=sf(gid)%a*dta2dtc
       end if
@@ -682,6 +749,7 @@ SUBROUTINE ATM_SENDFLUXES
       integer n
 !C
 
+      IF ( ia2o .LT. 1 .and. ia2w .LT. 1 ) RETURN
       if (.not.PHYS) RETURN
 
       IF (gid.gt.2) RETURN
@@ -727,3 +795,197 @@ SUBROUTINE ATM_ANNOUNCE(s,DbgLev)
 
       return
       END
+
+SUBROUTINE atm_getcur(ucur,vcur)
+
+! Bringing ocean currents .. 
+! Biju Thomas,  GSO/URI  on 4/8/2015
+! 
+   USE atm_cc
+   IMPLICIT NONE
+   REAL(KIND = kind_cur), DIMENSION(ims:ime,jms:jme) :: ucur, vcur
+   REAL(KIND = kind_cur), DIMENSION(ids:idf,jds:jdf) :: ucur_g, vcur_g
+   REAL, PARAMETER :: cur_ll = 0._kind_cur, cur_ul = 5._kind_cur,  &
+                      cur_k = 0._kind_cur
+                      
+   INTEGER :: i, j
+   LOGICAL :: getcur
+
+      IF ( io2a .LT. 2 ) RETURN
+   IF (.NOT. phys .OR. gid > 2) RETURN
+   IF (ocean_spec /= 1) CALL atm_announce('Warn: ocean currents needed',3)
+   CALL atm_announce('atm_getcur entered (phys = .true.)',3)
+   
+   getcur = ((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta == n_ts(gid)-1
+   
+   IF (getcur .NEQV. zerosf) THEN
+      CALL glob_abort(1, 'Warn: getcur does not match zerosf', rc)
+   END IF
+
+   IF (getcur) THEN
+      CALL atm_announce('atm_getcur: to receive CUR',3)
+      CALL cmp_gnr_recv(ucur_g, ngp, mpi_kind_cur)
+      CALL cmp_gnr_recv(vcur_g, ngp, mpi_kind_cur)
+      CALL disassemble(ucur_g, ucur_cc(gid)%a, kind_cur)
+      CALL disassemble(vcur_g, vcur_cc(gid)%a, kind_cur)
+      CALL atm_announce('atm_getcur: CUR received',3)
+   END IF  
+   
+   IF ( coupler_id .LT. 0 ) RETURN
+
+
+   DO j = jts,jte
+   DO i = its,ite
+     IF ( ABS(ucur_cc(gid)%a(i,j)) .GE. cur_ll .AND.                &
+          ABS(ucur_cc(gid)%a(i,j)) .LE. cur_ul ) THEN
+        ucur(i,j) = ucur_cc(gid)%a(i,j)
+     ELSE
+        ucur(i,j) = cur_k
+     ENDIF
+     IF ( ABS(vcur_cc(gid)%a(i,j)) .GE. cur_ll .AND.                &
+          ABS(vcur_cc(gid)%a(i,j)) .LE. cur_ul ) THEN
+        vcur(i,j) = vcur_cc(gid)%a(i,j)
+     ELSE
+        vcur(i,j) = cur_k
+     ENDIF
+   ENDDO
+   ENDDO
+
+END SUBROUTINE atm_getcur 
+
+SUBROUTINE atm_getwstate(alpha,gamma)
+
+! Bringing Wave state (Charnok coeff & misalignment Angle) 
+! Biju Thomas,  GSO/URI  on 4/8/2015
+!
+   USE atm_cc
+   IMPLICIT NONE
+   REAL(KIND = kind_wstate), DIMENSION(ims:ime,jms:jme) :: alpha, gamma
+   REAL(KIND = kind_wstate), DIMENSION(ids:idf,jds:jdf) :: alpha_g, &
+                                                           gamma_g
+   REAL, PARAMETER :: deg2rad=3.1415926_kind_wstate/180_kind_wstate 
+   REAL, PARAMETER :: alpha_ll = 0.0_kind_wstate, &
+                      alpha_ul = 0.2_kind_wstate, &
+                      alpha_k = 0.0185_kind_wstate, &
+                      gamma_ll = -20.0_kind_wstate*deg2rad, &
+                      gamma_ul = 20.0_kind_wstate*deg2rad, &
+                      gamma_k = 0.0_kind_wstate
+
+
+   INTEGER :: i, j
+   LOGICAL :: getwstate
+
+      IF ( iw2a .LT. 1 ) RETURN
+   IF (wm_id <= 0)  RETURN
+   IF (.NOT. phys .OR. gid > 2) RETURN
+   CALL atm_announce('atm_getstate entered (phys = .true.)',3)
+
+   getwstate = ((n_ts(gid)-1)/i_dtc2dta)*i_dtc2dta == n_ts(gid)-1
+
+   IF (getwstate .NEQV. zerosf) THEN
+      CALL glob_abort(1, 'Warn: getwstate does not match zerosf', rc)
+   END IF
+
+   IF (getwstate) THEN
+      CALL atm_announce('atm_getwsate: to receive WSTATE',3)
+      CALL cmp_gnr_recv(alpha_g, ngp, mpi_kind_wstate)
+      CALL cmp_gnr_recv(gamma_g, ngp, mpi_kind_wstate)
+      CALL disassemble(alpha_g, alpha_cc(gid)%a, kind_wstate)
+      CALL disassemble(gamma_g, gamma_cc(gid)%a, kind_wstate)
+      CALL atm_announce('atm_getwstate: WSTATE received',3)
+   END IF
+
+   IF ( coupler_id .LT. 0 ) RETURN
+   
+   
+   DO j = jts,jte
+   DO i = its,ite
+!     IF ( alpha_cc(gid)%a(i,j) .GT. alpha_ll .AND.                &
+!          alpha_cc(gid)%a(i,j) .LT. alpha_ul ) THEN
+!        alpha(i,j) = alpha_cc(gid)%a(i,j)
+!     ELSE
+!        alpha(i,j) = alpha_k
+!     ENDIF 
+     alpha(i,j) = alpha_cc(gid)%a(i,j)
+     IF ( gamma_cc(gid)%a(i,j) .GT. gamma_ll .AND.                &
+          gamma_cc(gid)%a(i,j) .LT. gamma_ul ) THEN
+        gamma(i,j) =  gamma_cc(gid)%a(i,j)
+     ELSE
+        gamma(i,j) = gamma_k
+     ENDIF
+   ENDDO
+   ENDDO
+ 
+END SUBROUTINE atm_getwstate
+
+SUBROUTINE atm_prepwindp(ulowl, vlowl, richn, zlowl)
+
+! Preparing Wind and adjusting variables (Height of lowest model level 
+!                                          Richarson number)
+! Biju Thomas,  GSO/URI  on 4/8/2015
+!
+   USE atm_cc
+   IMPLICIT NONE
+
+   REAL(KIND = kind_windp), DIMENSION(ims:ime,jms:jme) :: ulowl, vlowl, &
+                                                          richn, zlowl
+      IF ( ia2w .LT. 1 ) RETURN
+   IF (wm_id <= 0)  RETURN
+   IF (.NOT. phys .OR. gid > 2) RETURN
+
+   CALL atm_announce('atm_atm_prepwindp: entered',3)
+
+   IF (zerosf) wwinp(gid)%a = 0.0
+   
+   wwinp(gid)%a(its:ite,jts:jte,NSF_WM-1) =    &  ! D.S.
+                              wwinp(gid)%a(its:ite,jts:jte,NSF_WM-1) + &
+                              ulowl(its:ite,jts:jte)
+   wwinp(gid)%a(its:ite,jts:jte,NSF_WM) =      &  ! D.S.
+                              wwinp(gid)%a(its:ite,jts:jte,NSF_WM)   + &
+                              vlowl(its:ite,jts:jte) 
+   wwinp(gid)%a(its:ite,jts:jte,NSF_WM-3) =    &  ! D.S.
+                              wwinp(gid)%a(its:ite,jts:jte,NSF_WM-3) + &
+                              richn(its:ite,jts:jte)
+   wwinp(gid)%a(its:ite,jts:jte,NSF_WM-2) =    &  ! D.S.
+                              wwinp(gid)%a(its:ite,jts:jte,NSF_WM-2) + &
+                              zlowl(its:ite,jts:jte)
+   IF (nrmsf) THEN
+      wwinp(gid)%a = wwinp(gid)%a*dta2dtc
+   END IF  
+ 
+   CALL atm_announce('atm_atm_prepwindp: returned',3)
+
+END SUBROUTINE atm_prepwindp
+
+
+SUBROUTINE atm_sendwindp
+
+! Sending wind and it adjustment fields (U1, V1, Charnok coeff & misalignment Angle)
+! Biju Thomas,  GSO/URI  on 4/8/2015
+!
+   USE atm_cc
+   IMPLICIT NONE
+
+   INTEGER :: n
+   REAL(KIND = kind_windp), DIMENSION(ids:idf,jds:jdf) :: field
+
+      IF ( ia2w .LT. 1 ) RETURN
+   IF (wm_id <= 0)  RETURN
+   IF (.NOT. phys .OR. gid > 2) RETURN
+ 
+   IF (.NOT. sendsf) THEN
+      CALL atm_announce('atm_sendwindp entered with PHYS but not sendSF: returning'// &
+      sgid,3)
+      RETURN
+   END IF
+
+   CALL atm_announce('atm_prepwindp: entered'//sgid,3)
+
+   DO n = 1, NSF_WM
+      CALL assemble(field, wwinp(gid)%a(:,:,n), kind_windp)
+      CALL cmp_gnr_send(field, ngp, mpi_kind_windp) 
+   END DO
+
+   CALL atm_announce('atm_prepwindp: reterned'//sgid,3)
+
+END SUBROUTINE atm_sendwindp
diff --git a/wrfv2_fire/external/atm_ocn/cmpcomm.F b/wrfv2_fire/external/atm_ocn/cmpcomm.F
index a6ad1f89..a78e2853 100644
--- a/wrfv2_fire/external/atm_ocn/cmpcomm.F
+++ b/wrfv2_fire/external/atm_ocn/cmpcomm.F
@@ -133,7 +133,7 @@ SUBROUTINE CMP_INIT(id,flex)
       call MPI_COMM_SIZE(MPI_COMM_WORLD,nprocs_global,ierr)
       if (component_nprocs.eq.nprocs_global) then
         if(process_rank_local.eq.0) then
-           call wrf_message('CMP_INIT: standalone mode')
+           call wrf_debug(2,'CMP_INIT: standalone mode')
            endif
         Coupler_id=-1
         RETURN
@@ -150,12 +150,12 @@ SUBROUTINE CMP_INIT(id,flex)
       call GLOB_ABORT(ierr,'CMP_INIT: error in MPI_RECV',1)
       Coupler_rank=ibuffer(2)
       if (ibuffer(1).ne.Coupler_id) then
-        call wrf_message('CMP_INIT: stopped, rcvd ibuffer(1) value '    &
+        call wrf_debug(2,'CMP_INIT: stopped, rcvd ibuffer(1) value '    &
      &         //'is not C id: ',ibuffer(1))
         CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
       end if
       if (ibuffer(3).ne.ibuffer_size) then
-        call wrf_message('CMP_INIT: stopped, rcvd ibuffer(3) value ',   &
+        call wrf_debug(2,'CMP_INIT: stopped, rcvd ibuffer(3) value ',   &
      &   ibuffer(3),' is not ibuffer_size=',ibuffer_size)
         CALL MPI_ABORT(MPI_COMM_WORLD,2,ierr)
       end if
@@ -214,7 +214,7 @@ SUBROUTINE CMP_INTRO(master_rank_local)
         tag=my_id+54321
             write(message,*) 'CMP_INTRO: to call MPI_SEND ',            &
      &      process_rank_local, process_rank_global
-            call wrf_message(message)
+            call wrf_debug(2,message)
         call MPI_SEND(ibuf,3,MPI_INTEGER,Coupler_rank,tag, &
      &  MPI_COMM_WORLD,ierr)
         if (ierr.ne.0) then
@@ -557,7 +557,7 @@ SUBROUTINE CMP_INTEGER_SEND(F,N)
       tag=my_id
       write(message,*) 'CMP_INTEGER_SEND: to call MPI_SEND; F=',        &
      &      F,' N=',N,' Coupler_rank=',Coupler_rank,' tag=',tag
-      call wrf_message(message)
+      call wrf_debug(2,message)
       call MPI_SEND(F,N,MPI_INTEGER,Coupler_rank,tag, &
      &MPI_COMM_WORLD,ierr)
       call GLOB_ABORT(ierr,'CMP_INTEGER_SEND: error in MPI_SEND',1)
@@ -801,7 +801,7 @@ SUBROUTINE CMP_gnr_RECV(F,N,MPI_DATATYPE)
 
           write(message,'("*** CMP_gnr_RECV: illegal value of FlexLev",'&
      &    //'i9/ "*** STOPPED")') FlexLev
-          call wrf_message(message)
+          call wrf_debug(2,message)
 
         end if
 
@@ -832,7 +832,7 @@ SUBROUTINE CMP_ANNOUNCE(nunit,s)
 
       if (process_rank_local.eq.component_master_rank_local) then
          if(nunit==0 .or. nunit==6) then
-            call wrf_debug(1,s)
+            call wrf_debug(2,s)
          else
         write(nunit,*) trim(s)
          endif
@@ -897,7 +897,7 @@ SUBROUTINE CMP_STDOUT(s)
       
       open(6,file=trim(s),form='formatted',status='unknown')
 
-      call wrf_message('CMP_STDOUT: unit 6 closed, reopened as '        &
+      call wrf_debug(2,'CMP_STDOUT: unit 6 closed, reopened as '        &
      &                 //trim(s))
 
       return
diff --git a/wrfv2_fire/external/atm_ocn/module_PATCH_QUILT.F b/wrfv2_fire/external/atm_ocn/module_PATCH_QUILT.F
index bfcd3f4f..958ce4c0 100755
--- a/wrfv2_fire/external/atm_ocn/module_PATCH_QUILT.F
+++ b/wrfv2_fire/external/atm_ocn/module_PATCH_QUILT.F
@@ -60,110 +60,139 @@ SUBROUTINE PATCH(ARRAYG,ARRAYL                                    &
       INTEGER,DIMENSION(4) :: LIMITS
 !
       INTEGER,DIMENSION(MPI_STATUS_SIZE) :: ISTAT
-!-----------------------------------------------------------------------
-!***********************************************************************
-!-----------------------------------------------------------------------
-!
-!-----------------------------------------------------------------------
-!***  GET OUR TASK ID AND THE COMMUNICATOR
-!-----------------------------------------------------------------------
-!
-      CALL WRF_GET_MYPROC(MYPE)
+
+!    SUBROUTINE wrf_global_to_patch_real (globbuf,buf,domdesc,stagger,ordering,&
+!                                       DS1,DE1,DS2,DE2,DS3,DE3,&
+!                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+!                                       PS1,PE1,PS2,PE2,PS3,PE3 )
+!       IMPLICIT NONE
+!       INTEGER                         DS1,DE1,DS2,DE2,DS3,DE3,&
+!                                       MS1,ME1,MS2,ME2,MS3,ME3,&
+!                                       PS1,PE1,PS2,PE2,PS3,PE3
+!       CHARACTER *(*) stagger,ordering
+!       INTEGER fid,domdesc
+!       REAL globbuf(*)
+!       REAL buf(*)
+
       CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
-      CALL WRF_GET_NPROC(NPES)
-!
-!-----------------------------------------------------------------------
-!***  INITIALIZE THE OUTPUT ARRAY
-!-----------------------------------------------------------------------
-!
+
       DO J=JMS,JME
       DO I=IMS,IME
         ARRAYL(I,J)=0.
       ENDDO
       ENDDO
-!
-!-----------------------------------------------------------------------
-!***  TASK 0 FILLS ITS OWN LOCAL DOMAIN THEN PARCELS OUT ALL THE OTHER
-!***  PIECES TO THE OTHER TASKS.
-!-----------------------------------------------------------------------
-!
-!-----------------------------------------------------------------------
-      tasks : IF(MYPE==0)THEN
-!-----------------------------------------------------------------------
-!
-        DO J=JTS,JTE
-        DO I=ITS,ITE
-          ARRAYL(I,J)=ARRAYG(I,J)
-        ENDDO
-        ENDDO
-!
-!-----------------------------------------------------------------------
-!***  TASK 0 NEEDS THE LIMITS FROM EACH OF THE OTHER TASKS AND THEN
-!***  SENDS OUT THE APPROPRIATE PIECE OF THE GLOBAL ARRAY.
-!-----------------------------------------------------------------------
-!
-        DO IPE=1,NPES-1
-!
-          CALL MPI_RECV(LIMITS,4,MPI_INTEGER,IPE,IPE,MPI_COMM_COMP      &
-      &                ,ISTAT,IRECV)
-!
-          ISTART=LIMITS(1)
-          IEND=LIMITS(2)
-          JSTART=LIMITS(3)
-          JEND=LIMITS(4)
-!
-          NUMVALS=(IEND-ISTART+1)*(JEND-JSTART+1)
-          ALLOCATE(ARRAYX(NUMVALS),STAT=I)
- 
-          KNT=0
-!
-          DO J=JSTART,JEND
-          DO I=ISTART,IEND
-            KNT=KNT+1
-            ARRAYX(KNT)=ARRAYG(I,J)
-          ENDDO
-          ENDDO
-!
-          CALL MPI_SEND(ARRAYX,KNT,MPI_REAL,IPE,IPE,MPI_COMM_COMP,ISEND)
-!
-          DEALLOCATE(ARRAYX)
-!
-        ENDDO
-!
-!-----------------------------------------------------------------------
-!***  ALL OTHER TASKS TELL TASK 0 WHAT THEIR HORIZONTAL LIMITS ARE AND
-!***  RECEIVE THEIR PIECE OF THE GLOBAL ARRAY FROM TASK 0.
-!-----------------------------------------------------------------------
-!
-      ELSE
-!
-        LIMITS(1)=ITS
-        LIMITS(2)=ITE
-        LIMITS(3)=JTS
-        LIMITS(4)=JTE
-!
-        CALL MPI_SEND(LIMITS,4,MPI_INTEGER,0,MYPE,MPI_COMM_COMP,ISEND)
-!
-        NUMVALS=(ITE-ITS+1)*(JTE-JTS+1)
-        ALLOCATE(ARRAYX(NUMVALS),STAT=I)
-!
-        CALL MPI_RECV(ARRAYX,NUMVALS,MPI_REAL,0,MYPE,MPI_COMM_COMP      &
-     &,               ISTAT,IRECV)
-!
-        KNT=0
-!
-        DO J=JTS,JTE
-        DO I=ITS,ITE
-          KNT=KNT+1
-          ARRAYL(I,J)=ARRAYX(KNT)
-        ENDDO
-        ENDDO
-!
-        DEALLOCATE(ARRAYX)
-!
-!-----------------------------------------------------------------------
-!
-      ENDIF tasks
+      CALL wrf_global_to_patch_real(                                    &
+     &                      arrayg, arrayl, mpi_comm_comp, 'xy', 'xy'   &
+     &,                     IDS,IDE,JDS,JDE,1,1                     &
+     &,                     IMS,IME,JMS,JME,1,1                     &
+     &,                     ITS,ITE,JTS,JTE,1,1                     )
+      RETURN
+
+!!-----------------------------------------------------------------------
+!!***********************************************************************
+!!-----------------------------------------------------------------------
+!!
+!!-----------------------------------------------------------------------
+!!***  GET OUR TASK ID AND THE COMMUNICATOR
+!!-----------------------------------------------------------------------
+!!
+!      CALL WRF_GET_MYPROC(MYPE)
+!      CALL WRF_GET_DM_COMMUNICATOR(MPI_COMM_COMP)
+!      CALL WRF_GET_NPROC(NPES)
+!      allocate(requests(npes))
+!!
+!!-----------------------------------------------------------------------
+!!***  INITIALIZE THE OUTPUT ARRAY
+!!-----------------------------------------------------------------------
+!!
+!      DO J=JMS,JME
+!      DO I=IMS,IME
+!        ARRAYL(I,J)=0.
+!      ENDDO
+!      ENDDO
+!!
+!!-----------------------------------------------------------------------
+!!***  TASK 0 FILLS ITS OWN LOCAL DOMAIN THEN PARCELS OUT ALL THE OTHER
+!!***  PIECES TO THE OTHER TASKS.
+!!-----------------------------------------------------------------------
+!!
+!!-----------------------------------------------------------------------
+!      tasks : IF(MYPE==0)THEN
+!!-----------------------------------------------------------------------
+!!
+!        DO J=JTS,JTE
+!        DO I=ITS,ITE
+!          ARRAYL(I,J)=ARRAYG(I,J)
+!        ENDDO
+!        ENDDO
+!!
+!!-----------------------------------------------------------------------
+!!***  TASK 0 NEEDS THE LIMITS FROM EACH OF THE OTHER TASKS AND THEN
+!!***  SENDS OUT THE APPROPRIATE PIECE OF THE GLOBAL ARRAY.
+!!-----------------------------------------------------------------------
+!!
+!        DO IPE=1,NPES-1
+!!
+!          CALL MPI_RECV(LIMITS,4,MPI_INTEGER,IPE,IPE,MPI_COMM_COMP      &
+!      &                ,ISTAT,IRECV)
+!!
+!          ISTART=LIMITS(1)
+!          IEND=LIMITS(2)
+!          JSTART=LIMITS(3)
+!          JEND=LIMITS(4)
+!!
+!          NUMVALS=(IEND-ISTART+1)*(JEND-JSTART+1)
+!          ALLOCATE(ARRAYX(NUMVALS),STAT=I)
+! 
+!          KNT=0
+!!
+!          DO J=JSTART,JEND
+!          DO I=ISTART,IEND
+!            KNT=KNT+1
+!            ARRAYX(KNT)=ARRAYG(I,J)
+!          ENDDO
+!          ENDDO
+!!
+!          CALL MPI_SEND(ARRAYX,KNT,MPI_REAL,IPE,IPE,MPI_COMM_COMP,ISEND)
+!!
+!          DEALLOCATE(ARRAYX)
+!!
+!        ENDDO
+!!
+!!-----------------------------------------------------------------------
+!!***  ALL OTHER TASKS TELL TASK 0 WHAT THEIR HORIZONTAL LIMITS ARE AND
+!!***  RECEIVE THEIR PIECE OF THE GLOBAL ARRAY FROM TASK 0.
+!!-----------------------------------------------------------------------
+!!
+!      ELSE
+!!
+!        LIMITS(1)=ITS
+!        LIMITS(2)=ITE
+!        LIMITS(3)=JTS
+!        LIMITS(4)=JTE
+!!
+!        CALL MPI_SEND(LIMITS,4,MPI_INTEGER,0,MYPE,MPI_COMM_COMP,ISEND)
+!!
+!        NUMVALS=(ITE-ITS+1)*(JTE-JTS+1)
+!        ALLOCATE(ARRAYX(NUMVALS),STAT=I)
+!!
+!        CALL MPI_RECV(ARRAYX,NUMVALS,MPI_REAL,0,MYPE,MPI_COMM_COMP      &
+!     &,               ISTAT,IRECV)
+!!
+!        KNT=0
+!!
+!        DO J=JTS,JTE
+!        DO I=ITS,ITE
+!          KNT=KNT+1
+!          ARRAYL(I,J)=ARRAYX(KNT)
+!        ENDDO
+!        ENDDO
+!!
+!        DEALLOCATE(ARRAYX)
+!!
+!!-----------------------------------------------------------------------
+!!
+!      ENDIF tasks
 !
 !-----------------------------------------------------------------------
 !     CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
@@ -235,89 +264,98 @@ SUBROUTINE QUILT_2(ARRAYL,ARRAYG                                  &
         ARRAYG(I,J)=0.
       ENDDO
       ENDDO
-!
-!-----------------------------------------------------------------------
-!***  TASK 0 FILLS ITS OWN PART OF THE GLOBAL FIRST.
-!-----------------------------------------------------------------------
-!
-!-----------------------------------------------------------------------
-      tasks : IF(MYPE==0)THEN
-!-----------------------------------------------------------------------
-!
-        DO J=JTS,JTE
-        DO I=ITS,ITE
-          ARRAYG(I,J)=ARRAYL(I,J)
-        ENDDO
-        ENDDO
-!
-!-----------------------------------------------------------------------
-!***  TASK 0 NEEDS THE LIMITS FROM EACH OF THE OTHER TASKS AND THEN
-!***  PULLS IN THE APPROPRIATE PIECES FROM ALL OTHER TASKS.
-!-----------------------------------------------------------------------
-!
-        DO IPE=1,NPES-1
-!
-          CALL MPI_RECV(LIMITS,4,MPI_INTEGER,IPE,IPE,MPI_COMM_COMP      &
-      &                ,ISTAT,IRECV)
-!
-          ISTART=LIMITS(1)
-          IEND=LIMITS(2)
-          JSTART=LIMITS(3)
-          JEND=LIMITS(4)
-!
-          NUMVALS=(IEND-ISTART+1)*(JEND-JSTART+1)
-          ALLOCATE(ARRAYX(NUMVALS),STAT=I)
-!
-          CALL MPI_RECV(ARRAYX,NUMVALS,MPI_REAL,IPE,IPE,MPI_COMM_COMP   &
-     &                 ,ISTAT,IRECV)
-!
-          KNT=0
-!
-          DO J=JSTART,JEND
-          DO I=ISTART,IEND
-            KNT=KNT+1
-            ARRAYG(I,J)=ARRAYX(KNT)
-          ENDDO
-          ENDDO
-!
-          DEALLOCATE(ARRAYX)
-!
-        ENDDO
-!
-!-----------------------------------------------------------------------
-!***  ALL OTHER TASKS TELL TASK 0 WHAT THEIR HORIZONTAL LIMITS ARE AND
-!***  SEND THEIR LOCAL ARRAY TO TASK 0.
-!-----------------------------------------------------------------------
-!
-      ELSE
-!
-        LIMITS(1)=ITS
-        LIMITS(2)=ITE
-        LIMITS(3)=JTS
-        LIMITS(4)=JTE
-!
-        CALL MPI_SEND(LIMITS,4,MPI_INTEGER,0,MYPE,MPI_COMM_COMP,ISEND)
-!
-        NUMVALS=(ITE-ITS+1)*(JTE-JTS+1)
-        ALLOCATE(ARRAYX(NUMVALS),STAT=I)
-!
-        KNT=0
-!
-        DO J=JTS,JTE
-        DO I=ITS,ITE
-          KNT=KNT+1
-          ARRAYX(KNT)=ARRAYL(I,J)
-        ENDDO
-        ENDDO
-!
-        CALL MPI_SEND(ARRAYX,NUMVALS,MPI_REAL,0,MYPE,MPI_COMM_COMP      &
-     &,               ISEND)
-!
-        DEALLOCATE(ARRAYX)
-!
-!-----------------------------------------------------------------------
-!
-      ENDIF tasks
+
+      CALL wrf_patch_to_global_real(                                 &
+     &                      arrayl, arrayg, mpi_comm_comp, 'xy', 'xy'   &
+     &,                     IDS,IDE,JDS,JDE,1,1                     &
+     &,                     IMS,IME,JMS,JME,1,1                     &
+     &,                     ITS,ITE,JTS,JTE,1,1                     )
+
+      RETURN
+
+!!
+!!-----------------------------------------------------------------------
+!!***  TASK 0 FILLS ITS OWN PART OF THE GLOBAL FIRST.
+!!-----------------------------------------------------------------------
+!!
+!!-----------------------------------------------------------------------
+!      tasks : IF(MYPE==0)THEN
+!!-----------------------------------------------------------------------
+!!
+!        DO J=JTS,JTE
+!        DO I=ITS,ITE
+!          ARRAYG(I,J)=ARRAYL(I,J)
+!        ENDDO
+!        ENDDO
+!!
+!!-----------------------------------------------------------------------
+!!***  TASK 0 NEEDS THE LIMITS FROM EACH OF THE OTHER TASKS AND THEN
+!!***  PULLS IN THE APPROPRIATE PIECES FROM ALL OTHER TASKS.
+!!-----------------------------------------------------------------------
+!!
+!        DO IPE=1,NPES-1
+!!
+!          CALL MPI_RECV(LIMITS,4,MPI_INTEGER,IPE,IPE,MPI_COMM_COMP      &
+!      &                ,ISTAT,IRECV)
+!!
+!          ISTART=LIMITS(1)
+!          IEND=LIMITS(2)
+!          JSTART=LIMITS(3)
+!          JEND=LIMITS(4)
+!!
+!          NUMVALS=(IEND-ISTART+1)*(JEND-JSTART+1)
+!          ALLOCATE(ARRAYX(NUMVALS),STAT=I)
+!!
+!          CALL MPI_RECV(ARRAYX,NUMVALS,MPI_REAL,IPE,IPE,MPI_COMM_COMP   &
+!     &                 ,ISTAT,IRECV)
+!!
+!          KNT=0
+!!
+!          DO J=JSTART,JEND
+!          DO I=ISTART,IEND
+!            KNT=KNT+1
+!            ARRAYG(I,J)=ARRAYX(KNT)
+!          ENDDO
+!          ENDDO
+!!
+!          DEALLOCATE(ARRAYX)
+!!
+!        ENDDO
+!!
+!!-----------------------------------------------------------------------
+!!***  ALL OTHER TASKS TELL TASK 0 WHAT THEIR HORIZONTAL LIMITS ARE AND
+!!***  SEND THEIR LOCAL ARRAY TO TASK 0.
+!!-----------------------------------------------------------------------
+!!
+!      ELSE
+!!
+!        LIMITS(1)=ITS
+!        LIMITS(2)=ITE
+!        LIMITS(3)=JTS
+!        LIMITS(4)=JTE
+!!
+!        CALL MPI_SEND(LIMITS,4,MPI_INTEGER,0,MYPE,MPI_COMM_COMP,ISEND)
+!!
+!        NUMVALS=(ITE-ITS+1)*(JTE-JTS+1)
+!        ALLOCATE(ARRAYX(NUMVALS),STAT=I)
+!!
+!        KNT=0
+!!
+!        DO J=JTS,JTE
+!        DO I=ITS,ITE
+!          KNT=KNT+1
+!          ARRAYX(KNT)=ARRAYL(I,J)
+!        ENDDO
+!        ENDDO
+!!
+!        CALL MPI_SEND(ARRAYX,NUMVALS,MPI_REAL,0,MYPE,MPI_COMM_COMP      &
+!     &,               ISEND)
+!!
+!        DEALLOCATE(ARRAYX)
+!!
+!!-----------------------------------------------------------------------
+!!
+!      ENDIF tasks
 !
 !-----------------------------------------------------------------------
 !     CALL MPI_BARRIER(MPI_COMM_COMP,IRTN)
diff --git a/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc b/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc
index 78af4050..5000d9ee 100644
--- a/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc
+++ b/wrfv2_fire/external/esmf_time_f90/ESMF_TimeMgr.inc
@@ -38,6 +38,7 @@ by both C++ and F90 compilers.
 ! Note that MAX_ALARMS must match MAX_WRF_ALARMS defined in 
 ! ../../frame/module_domain.F !!!  Eliminate this dependence with 
 ! grow-as-you-go AlarmList in ESMF_Clock...  
+#include "../../inc/streams.h"
 #define MAX_ALARMS (2*(MAX_HISTORY)+10)
 
 ! TBH:  TODO:  Hook this into the WRF build so WRF can use either "no-leap" or 
diff --git a/wrfv2_fire/external/esmf_time_f90/Meat.F90 b/wrfv2_fire/external/esmf_time_f90/Meat.F90
index 8614cab9..a100229b 100644
--- a/wrfv2_fire/external/esmf_time_f90/Meat.F90
+++ b/wrfv2_fire/external/esmf_time_f90/Meat.F90
@@ -9,6 +9,11 @@ SUBROUTINE normalize_basetime( basetime )
   USE esmf_basetimemod
   IMPLICIT NONE
   TYPE(ESMF_BaseTime), INTENT(INOUT) :: basetime
+  !BPR BEGIN
+  INTEGER(ESMF_KIND_I8) :: Sn_simplified, Sd_simplified
+  INTEGER :: primes_to_check
+  !BPR END
+
 !PRINT *,'DEBUG:  BEGIN normalize_basetime()'
   ! Consistency check...  
   IF ( basetime%Sd < 0 ) THEN
@@ -41,6 +46,30 @@ SUBROUTINE normalize_basetime( basetime )
 !PRINT *,'DEBUG:  normalize_basetime() C2:  S,Sn,Sd = ',basetime%S,basetime%Sn,basetime%Sd
     ENDIF
   ENDIF
+
+  !BPR BEGIN
+  !Simplify the fraction -- otherwise the fraction can get needlessly complicated and
+  !cause WRF to crash
+  IF ( ( basetime%Sd > 0 ) .AND. (basetime%Sn > 0 ) ) THEN
+    CALL simplify( basetime%Sn, basetime%Sd, Sn_simplified, Sd_simplified )
+    basetime%Sn = Sn_simplified
+    basetime%Sd = Sd_simplified
+    !If the numerator and denominator are both larger than 10000, after simplification
+    !using the first 9 primes, the chances increase that there is a common prime factor other
+    !than the 9 searched for in the standard simplify
+    !By only searching for more than 9 primes when the numerator and denominator are
+    !large, we avoid the additional computational expense of checking additional primes
+    !for a large number of cases
+    IF ( ( basetime%Sd > 10000 ) .AND. (basetime%Sn > 10000 ) ) THEN
+      primes_to_check = 62
+      CALL simplify_numprimes( basetime%Sn, basetime%Sd, Sn_simplified, Sd_simplified, &
+                               primes_to_check )
+      basetime%Sn = Sn_simplified
+      basetime%Sd = Sd_simplified
+    ENDIF
+  ENDIF
+  !BPR END
+
 !PRINT *,'DEBUG:  END normalize_basetime()'
 END SUBROUTINE normalize_basetime
 
@@ -754,6 +783,59 @@ SUBROUTINE simplify( ni, di, no, do )
     RETURN
 END SUBROUTINE simplify
 
+!BPR BEGIN
+! Same as simplify above, but allows user to choose the number of primes to check
+SUBROUTINE simplify_numprimes( ni, di, no, do, num_primes_to_check )
+  USE esmf_basemod
+    IMPLICIT NONE
+    INTEGER(ESMF_KIND_I8), INTENT(IN)  :: ni, di
+    INTEGER(ESMF_KIND_I8), INTENT(OUT) :: no, do
+    INTEGER, INTENT(IN) :: num_primes_to_check !Number of primes to check
+    INTEGER, PARAMETER ::  nprimes = 62
+    INTEGER(ESMF_KIND_I8), DIMENSION(nprimes), PARAMETER :: primes = (/2,3,5,7,11,13,17,&
+     19,23,29,31,37,41,43,47,53,59,61,67,71,73,79,83,89,97,101,103,107,109,113,127,131,&
+     137,139,149,151,157,163,167,173,179,181,191,193,197,199,211,223,227,229,233,239,241,&
+     251,257,263,269,271,277,281,283,293/)
+    INTEGER(ESMF_KIND_I8) :: pr, d, n
+    INTEGER :: np
+    LOGICAL keepgoing
+    INTEGER :: num_primes_to_check_final !Number of primes to check after being limited to max
+                                         !available number of primes
+
+    ! If the user chooses to check more primes than are currently specified in the subroutine
+    ! then use the maximum number of primes currently specified
+    num_primes_to_check_final = min(num_primes_to_check, nprimes)
+
+    IF ( ni .EQ. 0 ) THEN
+      do = 1
+      no = 0
+      RETURN
+    ENDIF
+    IF ( mod( di , ni ) .EQ. 0 ) THEN
+      do = di / ni
+      no = 1
+      RETURN
+    ENDIF
+    d = di
+    n = ni
+    DO np = 1, num_primes_to_check_final
+      pr = primes(np)
+      keepgoing = .TRUE.
+      DO WHILE ( keepgoing )
+        keepgoing = .FALSE.
+        IF ( d/pr .NE. 0 .AND. n/pr .NE. 0 .AND. MOD(d,pr) .EQ. 0 .AND. MOD(n,pr) .EQ. 0 ) THEN
+          d = d / pr
+          n = n / pr
+          keepgoing = .TRUE.
+        ENDIF
+      ENDDO
+    ENDDO
+    do = d
+    no = n
+    RETURN
+END SUBROUTINE simplify_numprimes
+!BPR END
+
 
 !$$$ this should be named "c_esmc_timesum" or something less misleading
 SUBROUTINE c_esmc_basetimesum( time1, timeinterval, timeOut )
diff --git a/wrfv2_fire/external/io_esmf/makefile b/wrfv2_fire/external/io_esmf/makefile
index c17499f1..7667221d 100644
--- a/wrfv2_fire/external/io_esmf/makefile
+++ b/wrfv2_fire/external/io_esmf/makefile
@@ -1,11 +1,8 @@
 # these settings for compiling standalone on Compaq. Type "make -r"
-#CPP = /lib/cpp 
-#FC  = f90 -free
 
 .SUFFIXES: .F90 .o
 
 AR = ar
-#RANLIB	= ranlib
 RANLIB	= echo
 
 OBJS = module_symbols_util.o \
diff --git a/wrfv2_fire/external/io_netcdf/wrf_io.F90 b/wrfv2_fire/external/io_netcdf/wrf_io.F90
index df8af0a7..aca0fa59 100644
--- a/wrfv2_fire/external/io_netcdf/wrf_io.F90
+++ b/wrfv2_fire/external/io_netcdf/wrf_io.F90
@@ -1351,10 +1351,10 @@ SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHand
   if ( DH%use_netcdf_classic ) then
   write(msg,*) 'output will be in classic NetCDF format'
   call wrf_debug ( WARN , TRIM(msg))
-#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
-  stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID)
-#else
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
   stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID)
+#else
+  stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID)
 #endif
   else
   create_mode = nf_netcdf4
@@ -1362,10 +1362,10 @@ SUBROUTINE ext_ncd_open_for_write_begin(FileName,Comm,IOComm,SysDepInfo,DataHand
   stat = NF_SET_CHUNK_CACHE(cache_size, cache_nelem, cache_preemption)
   endif
 #else
-#ifdef WRFIO_NCD_LARGE_FILE_SUPPORT
-  stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID)
-#else
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
   stat = NF_CREATE(FileName, NF_CLOBBER, DH%NCID)
+#else
+  stat = NF_CREATE(FileName, IOR(NF_CLOBBER,NF_64BIT_OFFSET), DH%NCID)
 #endif
 #endif
   call netcdf_err(stat,Status)
diff --git a/wrfv2_fire/external/io_pio/Makefile b/wrfv2_fire/external/io_pio/Makefile
index 2f0a8163..84a4c41d 100644
--- a/wrfv2_fire/external/io_pio/Makefile
+++ b/wrfv2_fire/external/io_pio/Makefile
@@ -1,5 +1,5 @@
 #makefile to build a wrf_io with PIO
-#$Id: Makefile 7668 2014-09-29 16:48:30Z huangwei@ucar.edu $
+#$Id$
 
 FCOPTIM         = -O0 -g
 FCNOOPT         = -O0 -fno-inline -fno-ip -g
diff --git a/wrfv2_fire/external/io_pio/field_routines.F90 b/wrfv2_fire/external/io_pio/field_routines.F90
index 9dd01afa..de487484 100644
--- a/wrfv2_fire/external/io_pio/field_routines.F90
+++ b/wrfv2_fire/external/io_pio/field_routines.F90
@@ -1,5 +1,5 @@
 !------------------------------------------------------------------
-!$Id: field_routines.F90 7668 2014-09-29 16:48:30Z huangwei@ucar.edu $
+!$Id$
 !------------------------------------------------------------------
 
 subroutine ext_pio_RealFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Data,Status)
diff --git a/wrfv2_fire/external/io_pio/pio_routines.F90 b/wrfv2_fire/external/io_pio/pio_routines.F90
index 200c8cd3..f8f6b483 100644
--- a/wrfv2_fire/external/io_pio/pio_routines.F90
+++ b/wrfv2_fire/external/io_pio/pio_routines.F90
@@ -5,7 +5,7 @@
 ! Date:    June 01, 2014
 !
 !---------------------------------------------------------------------------
-!$Id: pio_routines.F90 7687 2014-10-10 04:12:05Z huangwei@ucar.edu $
+!$Id$
 !---------------------------------------------------------------------------
 
 module pio_routines
diff --git a/wrfv2_fire/external/io_pio/read_bdy_routines.F90 b/wrfv2_fire/external/io_pio/read_bdy_routines.F90
index f87a8591..bd8c1729 100644
--- a/wrfv2_fire/external/io_pio/read_bdy_routines.F90
+++ b/wrfv2_fire/external/io_pio/read_bdy_routines.F90
@@ -1,5 +1,5 @@
 !------------------------------------------------------------------
-!$Id: read_bdy_routines.F90 7621 2014-08-14 20:28:51Z huangwei@ucar.edu $
+!$Id$
 !------------------------------------------------------------------
 
 subroutine transRg2l(ds1,de1,ds2,de2,ds3,de3, &
diff --git a/wrfv2_fire/external/io_pio/wrf_data_pio.F90 b/wrfv2_fire/external/io_pio/wrf_data_pio.F90
index 01a666ed..c360f01b 100644
--- a/wrfv2_fire/external/io_pio/wrf_data_pio.F90
+++ b/wrfv2_fire/external/io_pio/wrf_data_pio.F90
@@ -5,7 +5,7 @@
 ! Date:    May 8, 2014
 !
 !---------------------------------------------------------------------------
-!$Id: wrf_data_pio.F90 7681 2014-10-08 21:23:55Z huangwei@ucar.edu $
+!$Id$
 !---------------------------------------------------------------------------
 
 module wrf_data_pio
diff --git a/wrfv2_fire/external/io_pio/wrf_io.F90 b/wrfv2_fire/external/io_pio/wrf_io.F90
index a55ecc8b..868b6d45 100644
--- a/wrfv2_fire/external/io_pio/wrf_io.F90
+++ b/wrfv2_fire/external/io_pio/wrf_io.F90
@@ -1,5 +1,5 @@
 !------------------------------------------------------------------
-!$Id: wrf_io.F90 7685 2014-10-10 01:58:54Z huangwei@ucar.edu $
+!$Id$
 !------------------------------------------------------------------
 
 subroutine ext_pio_open_for_read(DatasetName, grid, SysDepInfo, DataHandle, Status)
diff --git a/wrfv2_fire/frame/module_configure.F b/wrfv2_fire/frame/module_configure.F
index 912077e8..69f011cf 100644
--- a/wrfv2_fire/frame/module_configure.F
+++ b/wrfv2_fire/frame/module_configure.F
@@ -427,8 +427,8 @@ SUBROUTINE wrf_alt_nml_obsolete (nml_read_unit, nml_name)
      LOGICAL ::          write_qgr, write_filtered_obs
      NAMELIST /wrfvar2/  write_qgr, write_filtered_obs
 
-     LOGICAL ::         use_eos_radobs
-     NAMELIST /wrfvar4/ use_eos_radobs
+     LOGICAL ::         use_eos_radobs, use_3dvar_phy
+     NAMELIST /wrfvar4/ use_eos_radobs, use_3dvar_phy
 
      LOGICAL             :: use_crtm_kmatrix_fast
      NAMELIST /wrfvar14/    use_crtm_kmatrix_fast
@@ -508,9 +508,9 @@ SUBROUTINE wrf_alt_nml_obsolete (nml_read_unit, nml_name)
         READ   ( UNIT = nml_read_unit , NML = wrfvar4 , iostat=nml_error )
 
         IF ( nml_error .EQ. 0 ) then    ! Successul, rm variables must be problem
-           CALL wrf_debug(0, "-- Is use_eos_radobs still in your "// &
+           CALL wrf_debug(0, "-- Is use_3dvar_phy or use_eos_radobs still in your "// &
                               TRIM(nml_name)//" namelist?")
-           CALL wrf_debug(0, "-- Remove use_eos_radobs as it is obsolete.")
+           CALL wrf_debug(0, "-- Remove use_3dvar_phy, use_eos_radobs as they are obsolete.")
         ENDIF
 
 !---------------------------------- wrfvar14 -----------------------------
diff --git a/wrfv2_fire/frame/module_cpl.F b/wrfv2_fire/frame/module_cpl.F
index f55193f6..ef154f11 100644
--- a/wrfv2_fire/frame/module_cpl.F
+++ b/wrfv2_fire/frame/module_cpl.F
@@ -77,7 +77,7 @@ SUBROUTINE cpl_init( kl_comm )
             rcvname(jwrf,jext,3) = clprefix//'VOCE'                 ! receive ocean meridional surface current 
             
             ! Variables that can be sent by WRF
-            sndname(jwrf,jext,1) = clprefix//'EVAP-PRECIP'          ! send net fresh water budget: evaporation - total précipitation
+            sndname(jwrf,jext,1) = clprefix//'EVAP-PRECIP'          ! send net fresh water budget: evaporation - total precipitation
             sndname(jwrf,jext,2) = clprefix//'SURF_NET_SOLAR'       ! send net short wave flux at ground surface
             sndname(jwrf,jext,3) = clprefix//'SURF_NET_NON-SOLAR'   ! send net non-solar heat flux at ground surface
             sndname(jwrf,jext,4) = clprefix//'TAUX'                 ! send zonal wind tress at atmosphere-ocean interface
@@ -428,9 +428,16 @@ SUBROUTINE cpl_rcv( kdomwrf, cdsuffix,            &
       INTEGER :: jext                                ! external domain index
       INTEGER :: ifldid                              ! field index
       REAL, DIMENSION( ips:ipe, jps:jpe ) :: zdata   ! data received from the coupler
+      LOGICAL :: lltorcv
       !!--------------------------------------------------------------------
 
       ifldid = cpl_get_fldid( cdsuffix )
+
+      lltorcv = .false.
+      DO jext = 1, max_edom
+         lltorcv = lltorcv .OR. cpl_toreceive( kdomwrf, jext, ifldid )
+      END DO
+      IF( .not.lltorcv ) return
          
       IF( PRESENT(pdataobs) ) THEN
          pdatacpl(ips:ipe,jps:jpe) = pdataobs(ips:ipe,jps:jpe) * ( 1.0 - SUM( pcplmask(ips:ipe,1:max_edom,jps:jpe), dim = 2 ) )
diff --git a/wrfv2_fire/frame/module_domain.F b/wrfv2_fire/frame/module_domain.F
index 5302e1b6..b3672651 100644
--- a/wrfv2_fire/frame/module_domain.F
+++ b/wrfv2_fire/frame/module_domain.F
@@ -768,11 +768,13 @@ SUBROUTINE alloc_and_configure_domain ( domain_id , active_this_task, grid , par
       new_grid%max_tiles   = 0
       new_grid%num_tiles_spec   = 0
       new_grid%nframes   = 0         ! initialize the number of frames per file (array assignment)
-#if (EM_CORE == 1)
-      new_grid%stepping_to_time = .FALSE.
-      new_grid%adaptation_domain = 1
-      new_grid%last_step_updated = -1
-#endif
+!BPR BEGIN
+!#if (EM_CORE == 1)
+!      new_grid%stepping_to_time = .FALSE.
+!      new_grid%adaptation_domain = 1
+!      new_grid%last_step_updated = -1
+!#endif
+!BPR BEGIN
 
 !      IF (active) THEN
         ! only allocate state if this set of tasks actually computes that domain, jm 20140822
@@ -790,6 +792,16 @@ SUBROUTINE alloc_and_configure_domain ( domain_id , active_this_task, grid , par
 !        WRITE (wrf_err_message,*)"Not allocating storage for domain ",domain_id," on this set of tasks"
 !        CALL wrf_message(TRIM(wrf_err_message))
 !      ENDIF
+
+!BPR BEGIN
+#if (EM_CORE == 1)
+!Set these here, after alloc_space_field, which initializes at least last_step_updated to zero
+      new_grid%stepping_to_time = .FALSE.
+      new_grid%adaptation_domain = 1
+      new_grid%last_step_updated = -1
+#endif
+!BPR END
+
 #if MOVE_NESTS
 !set these here, after alloc_space_field, which initializes vc_i, vc_j to zero
       new_grid%xi = -1.0
diff --git a/wrfv2_fire/frame/module_io_quilt_old.F b/wrfv2_fire/frame/module_io_quilt_old.F
index 81d70f03..e46d8b10 100644
--- a/wrfv2_fire/frame/module_io_quilt_old.F
+++ b/wrfv2_fire/frame/module_io_quilt_old.F
@@ -5138,7 +5138,7 @@ SUBROUTINE get_mpi_comm_io_groups( retval, isrvr )
       RETURN
 END SUBROUTINE get_mpi_comm_io_groups
 
-SUBROUTINE get_nio_tasks_in_group( retval )
+SUBROUTINE get_nio_tasks_in_group( id, retval )
 !
 ! This routine returns the number of I/O server tasks in each 
 ! I/O server group.  It can be called by both clients and 
@@ -5147,6 +5147,7 @@ SUBROUTINE get_nio_tasks_in_group( retval )
 #if defined( DM_PARALLEL ) && !defined( STUBMPI )
       USE module_wrf_quilt
       IMPLICIT NONE
+      INTEGER, INTENT(IN)  :: id
       INTEGER, INTENT(OUT) :: retval
       retval = nio_tasks_in_group
 #endif
diff --git a/wrfv2_fire/frame/module_tiles.F b/wrfv2_fire/frame/module_tiles.F
index 8bd00b10..ea8190e7 100644
--- a/wrfv2_fire/frame/module_tiles.F
+++ b/wrfv2_fire/frame/module_tiles.F
@@ -334,11 +334,10 @@ SUBROUTINE set_tiles2 ( grid , ids , ide , jds , jde , ips , ipe , jps , jpe )
           tile_strategy=TILE_Y
           WRITE(mess,*)'Tile Strategy is not specified. Assuming 1D-Y'
           CALL WRF_MESSAGE ( mess )
-
-         IF ( num_tiles >= (epy-spy+1)/MIN_TILE_SIZE .and. num_tiles_x == 0 .and. num_tiles_y == 0) THEN ! number of tiles is too high. Trying to adjust
+          IF ( num_tiles > (epy-spy+1)/MIN_TILE_SIZE .and. num_tiles_x == 0 .and. num_tiles_y == 0) THEN ! number of tiles is too high. Trying to adjust
             num_tiles_x=1
             num_tiles_y=(epy-spy+1)/MIN_TILE_SIZE
-            DO WHILE (num_tiles_x*num_tiles_inc*num_tiles_y <= num_tiles)
+            DO WHILE (num_tiles_x*num_tiles_inc*num_tiles_y < num_tiles)
                num_tiles_x=num_tiles_x+1
             END DO
           num_tiles_x=num_tiles_x*num_tiles_inc
diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile
new file mode 100644
index 00000000..a37fbe0d
--- /dev/null
+++ b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile
@@ -0,0 +1,34 @@
+# Makefile 
+#
+.SUFFIXES:
+.SUFFIXES: .o .F
+
+
+
+include ../../macros
+
+MODFLAG =       -I./ -I ../../MPP -I ../../mod 
+
+WRF_ROOT = ../../..
+OBJS = \
+	module_wrf_HYDRO.o \
+	wrf_drv_HYDRO.o    
+all:	$(OBJS) 
+
+.F.o:
+	@echo ""
+	$(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f
+	$(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I$(WRF_ROOT)/frame -I$(WRF_ROOT)/main -I$(WRF_ROOT)/external/esmf_time_f90 $(*).f
+	$(RMD) $(*).f
+	@echo ""
+	ar -r ../../lib/libHYDRO.a $(@)
+
+#
+# Dependencies:
+#
+module_wrf_HYDRO.o: ../../Data_Rec/module_RT_data.o ../../Data_Rec/module_namelist.o ../../HYDRO_drv/module_HYDRO_drv.o
+
+wrf_drv_HYDRO.o: module_wrf_HYDRO.o
+
+clean:
+	rm -f *.o *.mod *.stb *~ *.f
diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl
new file mode 100644
index 00000000..64550bdb
--- /dev/null
+++ b/wrfv2_fire/hydro/CPL/WRF_cpl/Makefile.cpl
@@ -0,0 +1,9 @@
+# Makefile 
+
+all:
+	(cd ../../; make -f Makefile.comm BASIC)
+	(make)
+
+clean:
+	(make clean)
+	(cd ../../; make -f Makefile.comm clean)
diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F
new file mode 100644
index 00000000..4e2fe3a1
--- /dev/null
+++ b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO.F
@@ -0,0 +1,415 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+!  
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+module module_WRF_HYDRO
+
+#ifdef MPP_LAND
+    use module_mpp_land, only: global_nx, global_ny, decompose_data_real, &
+                 write_io_real, my_id, mpp_land_bcast_real1, IO_id, &
+                mpp_land_bcast_real, mpp_land_bcast_int1
+    use module_CPL_LAND, only: CPL_LAND_INIT, cpl_outdate
+#endif
+    use module_HYDRO_drv, only: HYDRO_ini, HYDRO_exe
+
+    use module_rt_data, only:  rt_domain
+    use module_gw_gw2d_data, only:  gw2d
+    use module_CPL_LAND, only: CPL_LAND_INIT, cpl_outdate
+    use module_namelist, only: nlst_rt
+    USE module_domain, ONLY : domain, domain_clock_get
+    USE module_configure, ONLY : grid_config_rec_type
+    !yw USE module_configure, only : config_flags
+    USE module_configure, only: model_config_rec
+ 
+
+    implicit none
+     
+    !yw   added for check soil moisture and soiltype
+    integer ::  checkSOIL_flag
+
+#ifndef MPP_LAND
+    character(len=19) :: cpl_outdate
+#endif
+!
+! added to consider the adaptive time step from WRF model. 
+    real    :: dtrt_ter0  , dtrt_ch0
+    integer ::  mm0
+
+
+
+
+CONTAINS
+
+!wrf_cpl_HYDRO will not call the off-line lsm 
+!ywGW subroutine wrf_cpl_HYDRO(HYDRO_dt,grid, config_flags, its,ite,jts,jte)
+    subroutine wrf_cpl_HYDRO(HYDRO_dt,grid,its,ite,jts,jte)
+
+       implicit none
+       TYPE ( domain ), INTENT(INOUT) :: grid
+!ywGW       TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags
+       integer its, ite, jts, jte, ij
+       real :: HYDRO_dt
+
+
+        integer k, ix,jx, mm, nn
+
+        integer ::  did
+
+        integer ntime
+
+        integer :: i,j
+        
+
+!output flux and state variable
+
+        did = 1
+
+
+        ix = ite - its + 1
+        jx = jte - jts + 1
+
+        if(HYDRO_dt .le. 0) then
+             write(6,*) "WARNING: HYDRO_dt <= 0 from land input. set it to be 1 seconds."
+             HYDRO_dt = 1
+        endif
+
+        ntime = 1
+
+    
+            nlst_rt(did)%dt = HYDRO_dt
+
+  
+        if(.not. RT_DOMAIN(did)%initialized) then
+
+
+           !yw nlst_rt(did)%nsoil = config_flags%num_soil_layers
+           !nlst_rt(did)%nsoil = model_config_rec%num_metgrid_soil_levels
+           nlst_rt(did)%nsoil = grid%num_soil_layers
+
+         
+#ifdef MPP_LAND
+           call mpp_land_bcast_int1 (nlst_rt(did)%nsoil)
+#endif
+           allocate(nlst_rt(did)%zsoil8(nlst_rt(did)%nsoil))
+           if(grid%zs(1) <  0) then
+              nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = grid%zs(1:nlst_rt(did)%nsoil)
+           else
+              nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = -1*grid%zs(1:nlst_rt(did)%nsoil)
+           endif
+
+            CALL domain_clock_get( grid, current_timestr=cpl_outdate)
+            nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19)
+            nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19)
+
+
+#ifdef MPP_LAND
+            call CPL_LAND_INIT(its,ite,jts,jte)
+#endif
+
+#ifdef HYDRO_D
+               write(6,*) "sf_surface_physics is ", grid%sf_surface_physics
+#endif
+
+           if(grid%sf_surface_physics .eq. 5) then    
+                ! clm4 
+               call HYDRO_ini(ntime,did=did,ix0=1,jx0=1)
+           else
+               call HYDRO_ini(ntime,did,ix0=ix,jx0=jx,vegtyp=grid%IVGTYP(its:ite,jts:jte),soltyp=grid%isltyp(its:ite,jts:jte))
+           endif
+
+
+
+            if(nlst_rt(did)%sys_cpl .ne. 2) then
+               call hydro_stop("In module_wrf_HYDRO.F wrf_cpl_HYDRO() - "// &
+                               "sys_cpl should be 2.  Check hydro.namelist file.")
+            endif
+
+
+            nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19)
+            nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19)
+
+            nlst_rt(did)%dt = HYDRO_dt
+            if(nlst_rt(did)%dtrt_ter .ge. HYDRO_dt) then
+               nlst_rt(did)%dtrt_ter = HYDRO_dt
+               mm0 = 1
+            else
+               mm = HYDRO_dt/nlst_rt(did)%dtrt_ter
+               if(mm*nlst_rt(did)%dtrt_ter.lt. HYDRO_dt) nlst_rt(did)%dtrt_ter = HYDRO_dt/mm
+               mm0 = mm
+            endif
+
+            dtrt_ter0 = nlst_rt(did)%dtrt_ter  
+
+            if(nlst_rt(did)%dtrt_ch .ge. HYDRO_dt) then
+               nlst_rt(did)%dtrt_ch = HYDRO_dt
+               mm0 = 1
+            else
+               mm = HYDRO_dt/nlst_rt(did)%dtrt_ch
+               if(mm*nlst_rt(did)%dtrt_ch.lt. HYDRO_dt) nlst_rt(did)%dtrt_ch = HYDRO_dt/mm
+               mm0 = mm
+            endif
+
+            dtrt_ch0 = nlst_rt(did)%dtrt_ch  
+        endif
+
+            if((mm0*nlst_rt(did)%dtrt_ter) .ne. HYDRO_dt) then   ! WRF model time step changed.
+               if(dtrt_ter0 .ge. HYDRO_dt) then
+                  nlst_rt(did)%dtrt_ter = HYDRO_dt
+                  mm0 = 1
+               else
+                  mm = HYDRO_dt/dtrt_ter0
+                  if(mm*dtrt_ter0 .lt. HYDRO_dt) nlst_rt(did)%dtrt_ter = HYDRO_dt/mm
+                  mm0 = mm
+               endif
+            endif
+
+            if((mm0*nlst_rt(did)%dtrt_ch) .ne. HYDRO_dt) then   ! WRF model time step changed.
+               if(dtrt_ch0 .ge. HYDRO_dt) then
+                  nlst_rt(did)%dtrt_ch = HYDRO_dt
+                  mm0 = 1
+               else
+                  mm = HYDRO_dt/dtrt_ch0
+                  if(mm*dtrt_ch0 .lt. HYDRO_dt) nlst_rt(did)%dtrt_ch = HYDRO_dt/mm
+                  mm0 = mm
+               endif
+            endif
+
+#ifdef HYDRO_D 
+        write(6,*) "mm, nlst_rt(did)%dt = ",mm, nlst_rt(did)%dt
+#endif
+
+        if(nlst_rt(did)%rtFlag .eq. 0) return
+
+
+        nn = nlst_rt(did)%nsoil
+
+        ! get the data from WRF 
+
+
+
+       if((.not. RT_DOMAIN(did)%initialized) .and. (nlst_rt(did)%rst_typ .eq. 1) ) then
+#ifdef HYDRO_D
+           write(6,*) "restart initial data from offline file"
+#endif
+       else
+            do k = 1, nlst_rt(did)%nsoil
+                RT_DOMAIN(did)%STC(:,:,k) = grid%TSLB(its:ite,k,jts:jte) 
+                RT_DOMAIN(did)%smc(:,:,k) = grid%smois(its:ite,k,jts:jte) 
+                RT_DOMAIN(did)%sh2ox(:,:,k) = grid%sh2o(its:ite,k,jts:jte) 
+            end do 
+            rt_domain(did)%infxsrt = grid%infxsrt(its:ite,jts:jte)
+            rt_domain(did)%soldrain = grid%soldrain(its:ite,jts:jte)
+       endif  
+
+            call HYDRO_exe(did)
+
+
+! add for update the WRF state variable.
+            do k = 1, nlst_rt(did)%nsoil
+                ! grid%TSLB(its:ite,k,jts:jte) = RT_DOMAIN(did)%STC(:,:,k)
+                grid%smois(its:ite,k,jts:jte) = RT_DOMAIN(did)%smc(:,:,k)
+                grid%sh2o(its:ite,k,jts:jte) = RT_DOMAIN(did)%sh2ox(:,:,k)
+            end do 
+
+! update WRF variable after running routing model.
+            grid%sfcheadrt(its:ite,jts:jte) = rt_domain(did)%sfcheadrt
+
+! provide groundwater soil flux to WRF for fully coupled simulations (FERSCH 09/2014)            
+            if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then
+!Wei Yu: comment the following two lines. Not ready for WRF3.7 release
+!yw             grid%qsgw(its:ite,jts:jte) = gw2d(did)%qsgw
+!yw             config_flags%gwsoilcpl = nlst_rt(did)%gwsoilcpl
+            end if
+
+!yw not sure for the following
+!           grid%xice(its:ite,jts:jte) = rt_domain(did)%sice
+
+            RT_DOMAIN(did)%initialized = .true.
+     end subroutine wrf_cpl_HYDRO
+
+
+
+
+
+!program drive rtland
+! This subroutine will be used if the 4-layer Noah lsm is not used.
+      subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp)
+!  input: z1,v1,kk1,z,ix,jx,kk
+!  output: vout
+!  interpolate based on soil layer: z1 and z 
+!  z :  soil layer of output variable.
+!  z1: array of soil layers of input variable.
+         implicit none
+         integer:: i,j,k
+         integer:: kk1, ix,jx,kk, vegtyp(ix,jx)
+         real :: z1(kk1), z(kk), v1(ix,kk1,jx),vout(ix,jx,kk)
+
+       
+         do j = 1, jx
+            do i = 1, ix
+                do k = 1, kk
+                  call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) 
+                end do
+            end do
+         end do
+      end subroutine wrf2lsm
+
+! This subroutine will be used if the 4-layer Noah lsm is not used.
+      subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp)
+!  input: z1,v1,kk1,z,ix,jx,kk
+!  output: vout
+!  interpolate based on soil layer: z1 and z 
+!  z :  soil layer of output variable.
+!  z1: array of soil layers of input variable.
+         implicit none
+         integer:: i,j,k
+         integer:: kk1, ix,jx,kk, vegtyp(ix,jx)
+         real :: z1(kk1), z(kk), v1(ix,jx,kk1),vout(ix,kk,jx)
+
+       
+         do j = 1, jx
+            do i = 1, ix
+                 do k = 1, kk
+                    call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) 
+                 end do
+            end do
+         end do
+      end subroutine lsm2wrf
+
+      subroutine interpLayer(inZ,inV,inK,outZ,outV)
+         implicit none
+         integer:: k, k1, k2
+         integer :: inK
+         real:: inV(inK),inZ(inK)
+         real:: outV, outZ, w1, w2
+
+         if(outZ .le. inZ(1)) then
+             w1 = (inZ(2)-outZ)/(inZ(2)-inZ(1))
+             w2 = (inZ(1)-outZ)/(inZ(2)-inZ(1))
+             outV = inV(1)*w1-inV(2)*w2
+             return
+         elseif(outZ .ge. inZ(inK)) then
+             w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) 
+             w2 = (outZ-inZ(inK))  /(inZ(inK)-inZ(inK-1))
+             outV = inV(inK)*w1 -inV(inK-1)* w2
+             return
+         else  
+            do k = 2, inK
+             if((inZ(k) .ge. outZ).and.(inZ(k-1) .le. outZ) ) then
+                k1  = k-1
+                k2 = k
+                w1 = (outZ-inZ(k1))/(inZ(k2)-inZ(k1))
+                w2 = (inZ(k2)-outZ)/(inZ(k2)-inZ(k1))
+                outV = inV(k2)*w1 + inV(k1)*w2
+                return 
+             end if 
+            end do
+         endif
+      end subroutine interpLayer
+
+      subroutine lsm_wrf_input(did,vegtyp,soltyp,ix,jx)
+         implicit none
+         integer did, leng
+         parameter(leng=100)
+         integer :: i,j, nn, ix,jx
+         integer, dimension(ix,jx) :: soltyp, vegtyp
+         real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc
+
+
+         where(soltyp == 14) VEGTYP = 16
+         where(VEGTYP == 16 ) soltyp = 14
+
+         RT_DOMAIN(did)%VEGTYP = vegtyp
+
+!      input OV_ROUGH from OVROUGH.TBL
+#ifdef MPP_LAND
+       if(my_id .eq. IO_id) then
+#endif
+
+#ifndef NCEP_WCOSS
+       open(71,file="HYDRO.TBL", form="formatted")
+!read OV_ROUGH first
+          read(71,*) nn
+          read(71,*)
+          do i = 1, nn
+             read(71,*) RT_DOMAIN(did)%OV_ROUGH(i)
+          end do
+!read parameter for LKSAT
+          read(71,*) nn
+          read(71,*)
+          do i = 1, nn
+             read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i)
+          end do
+       close(71)
+
+#else
+      open(13, form="formatted") 
+!read OV_ROUGH first
+          read(13,*) nn
+          read(13,*)
+          do i = 1, nn
+             read(13,*) RT_DOMAIN(did)%OV_ROUGH(i)
+          end do
+!read parameter for LKSAT
+          read(13,*) nn
+          read(13,*)
+          do i = 1, nn
+             read(13,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i)
+          end do
+       close(13)
+#endif
+#ifdef MPP_LAND
+       endif
+       call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH)
+       call mpp_land_bcast_real(leng,xdum1)
+       call mpp_land_bcast_real(leng,MAXSMC)
+       call mpp_land_bcast_real(leng,refsmc)
+       call mpp_land_bcast_real(leng,wltsmc)
+#endif
+
+       rt_domain(did)%lksat = 0.0
+       do j = 1, RT_DOMAIN(did)%jx
+             do i = 1, RT_DOMAIN(did)%ix
+                rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0
+                IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN   ! urban
+                    rt_domain(did)%SMCMAX1(i,j) = 0.45
+                    rt_domain(did)%SMCREF1(i,j) = 0.42
+                    rt_domain(did)%SMCWLT1(i,j) = 0.40
+                else
+                    rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J))
+                    rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J))
+                    rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J))
+                ENDIF
+             end do
+       end do
+
+
+      end subroutine lsm_wrf_input
+
+      subroutine  checkSoil(did) 
+          implicit none
+          integer :: did
+          where(rt_domain(did)%smc(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16
+          where(rt_domain(did)%sh2ox(:,:,1) <=0) RT_DOMAIN(did)%VEGTYP = 16
+          where(rt_domain(did)%smc(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16
+          where(rt_domain(did)%sh2ox(:,:,1) >=100) RT_DOMAIN(did)%VEGTYP = 16
+      end subroutine checkSoil
+
+end module module_wrf_HYDRO
diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F
new file mode 100644
index 00000000..cf747fe8
--- /dev/null
+++ b/wrfv2_fire/hydro/CPL/WRF_cpl/module_wrf_HYDRO_downscale.F
@@ -0,0 +1,439 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+!  
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+module module_WRF_HYDRO
+
+#ifdef MPP_LAND
+    use module_mpp_land, only: global_nx, global_ny, decompose_data_real, &
+                 write_io_real, my_id, mpp_land_bcast_real1, IO_id, &
+                mpp_land_bcast_real, mpp_land_bcast_int1
+#endif
+    use module_HYDRO_drv, only: HYDRO_ini, HYDRO_exe
+
+    use module_rt_data, only:  rt_domain
+    use module_CPL_LAND, only: cpl_outdate
+    use module_namelist, only: nlst_rt
+    USE module_domain, ONLY : domain, domain_clock_get
+
+    implicit none
+     
+    !yw   added for check soil moisture and soiltype
+    integer ::  checkSOIL_flag
+
+!
+! added to consider the adaptive time step from WRF model. 
+    real    :: dtrt0  
+    integer ::  mm0, itime
+
+
+
+
+CONTAINS
+
+!wrf_cpl_HYDRO_finescale will not call the off-line lsm 
+    subroutine wrf_cpl_HYDRO_finescale(HYDRO_dt,grid,its,ite,jts,jte)
+       use module_NoahMP_hrldas_driver, only: noah_timestep , land_driver_ini
+       implicit none
+       TYPE ( domain ), INTENT(INOUT) :: grid
+       integer its, ite, jts, jte, ij
+       real :: HYDRO_dt
+
+
+        integer k, ix,jx, mm
+
+        integer ::  did
+
+        integer ntime
+
+        integer :: i,j
+        
+
+!output flux and state variable
+
+        did = 1
+        ix = ite - its + 1
+        jx = jte - jts + 1
+
+        if(HYDRO_dt .le. 0) then
+             write(6,*) "Warning: HYDRO_dt <= 0 from land input. set it to be 1 seconds."
+             HYDRO_dt = 1
+        endif
+
+        ntime = 1
+
+    
+            nlst_rt(did)%dt = HYDRO_dt
+
+        itime = itime + 1 
+        if(.not. RT_DOMAIN(did)%initialized) then
+           itime = 1
+
+           nlst_rt(did)%nsoil = grid%num_soil_layers
+
+#ifdef MPP_LAND
+           call mpp_land_bcast_int1 (nlst_rt(did)%nsoil)
+#endif
+           allocate(nlst_rt(did)%zsoil8(nlst_rt(did)%nsoil))
+           if(grid%zs(1) <  0) then
+              nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = grid%zs(1:nlst_rt(did)%nsoil)
+           else
+              nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil) = -1*grid%zs(1:nlst_rt(did)%nsoil)
+           endif
+
+            CALL domain_clock_get( grid, current_timestr=cpl_outdate)
+            nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19)
+            nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19)
+
+!yw continue
+
+            call land_driver_ini(nn,its,ite,jts,jte)
+
+#ifdef HYDRO_D
+               write(6,*) "sf_surface_physics is ", grid%sf_surface_physics
+#endif
+            nlst_rt(did)%startdate(1:19) = cpl_outdate(1:19)
+            nlst_rt(did)%olddate(1:19) = cpl_outdate(1:19)
+
+            nlst_rt(did)%dt = HYDRO_dt
+            noah_timestep = nlst_rt(did)%dt
+
+            if(nlst_rt(did)%dtrt .lt. HYDRO_dt) then
+               nlst_rt(did)%dtrt = HYDRO_dt
+               mm0 = 1
+            else
+               mm = HYDRO_dt/nlst_rt(did)%dtrt
+               if(mm*nlst_rt(did)%dtrt .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm
+               mm0 = mm
+            endif
+
+            dtrt0 = nlst_rt(did)%dtrt  
+        endif
+
+            if((mm0*nlst_rt(did)%dtrt) .ne. HYDRO_dt) then   ! WRF model time step changed.
+               if(dtrt0 .lt. HYDRO_dt) then
+                  nlst_rt(did)%dtrt = HYDRO_dt
+                  mm0 = 1
+               else
+                  mm = HYDRO_dt/dtrt0
+                  if(mm*dtrt0 .lt. HYDRO_dt) nlst_rt(did)%dtrt = HYDRO_dt/mm
+                  mm0 = mm
+               endif
+            endif
+
+#ifdef HYDRO_D 
+        write(6,*) "mm, nlst_rt(did)%dt = ",mm, nlst_rt(did)%dt
+#endif
+
+! get forcing data from WRF
+         call wrf2l_finemesh(grid,its,ite,jts,jte)
+
+         call HYDRO_land_finemesh_exe(itime)
+
+         call l_finemesh2wrf(grid)
+
+         RT_DOMAIN(did)%initialized = .true.
+
+     end subroutine wrf_cpl_HYDRO_finescale
+
+! get the forcing data from WRF
+subroutine wrf2l_finemesh(,its,ite,jts,jte, T_PHY0,U_PHY0,V_PHY0,p_hyd_w0,RAINBL0,QV_CURR0,LAI0,VEGFRA0, &
+          emiss0, albedo0   )
+       use module_NoahMP_hrldas_driver, only: P8W, T_PHY, U_PHY, V_PHY, QV_CURR, RAINBL_tmp, LAI, VEGFRA, finemesh,finemesh_factor, &
+              emiss,albedo
+       
+       implicit none
+       real, domain(:,:),INTENT(IN) :: T_PHY0,U_PHY0,V_PHY0,p_hyd_w0,RAINBL0,QV_CURR0,LAI0,VEGFRA0, &
+             emiss0, albedo0, TSK0,HFX0, QFX0,LH0,GRDFLX0,SMSTAV0,SMSTOT0,SFCRUNOFF0, UDRUNOFF0, SNOWC0, SMOIS0, SH2O0, &
+             TSLB0, SNOW0,SNOWH0,CANWAT0,ACSNOM0,ACSNOW0,QSFC0,ISNOWXY0,TVXY0,TGXY0,CANICEXY0,CANLIQXY0,EAHXY0,TAHXY0,CMXY0, &
+             CHXY0,FWETXY0,SNEQVOXY0,ALBOLDXY0,QSNOWXY0,WSLAKEXY0,ZWTXY0,WAXY0,WTXY0,TSNOXY0,ZSNSOXY0,SNICEXY0,SNLIQXY0, &
+             LFMASSXY0,RTMASSXY0,STMASSXY0,WOODXY0,STBLCPXY0,FASTCPXY0,XLAIXY0,XSAIXY0,TAUSSXY0,SMOISEQ0,SMCWTDXY0,DEEPRECHXY0, &
+             RECHXY0, &
+
+       integer, intent(in):: its,ite,jts,jte
+       call wrf2finegrid(T_PHY0(its:ite,jts:jte), T_PHY(:,1,:),ite-its+1,jte-jts+1,finemesh_factor)
+       call wrf2finegrid(U_PHY0(its:ite,jts:jte), U_PHY(:,1,:),ite-its+1,jte-jts+1,finemesh_factor)
+       call wrf2finegrid(V_PHY0(its:ite,jts:jte), V_PHY(:,1,:),ite-its+1,jte-jts+1,finemesh_factor)
+       call wrf2finegrid(p_hyd_w0(its:ite,jts:jte), P8W(:,1,:),ite-its+1,jte-jts+1,finemesh_factor)
+       call wrf2finegrid(RAINBL0(its:ite,jts:jte), RAINBL_tmp,ite-its+1,jte-jts+1,finemesh_factor)
+       call wrf2finegrid(QV_CURR0(its:ite,jts:jte), QV_CURR(:,1,:),ite-its+1,jte-jts+1,finemesh_factor)
+!  update some varialbes.
+       if(finemesh .ne. 1) then   ! update the LAI and VEGFRA for each time step. Note: this is from the WRF grid.
+           call wrf2finegrid(albedo0(its:ite,jts:jte), albedo)
+           call wrf2finegrid(emiss0(its:ite,jts:jte), emiss)
+           call wrf2finegrid(LAI0(its:ite,jts:jte), LAI)
+           call wrf2finegrid(VEGFRA0(its:ite,jts:jte), VEGFRA)
+       endif
+end subroutine wrf2l_finemesh
+
+subroutine l_finemesh2wrf(T_PHY0,U_PHY0,V_PHY0,p_hyd_w0,RAINBL0,QV_CURR0,LAI0,VEGFRA0,its,ite,jts,jte)
+   use module_NoahMP_hrldas_driver, only: P8W, T_PHY, U_PHY, V_PHY, QV_CURR, RAINBL_tmp, LAI, VEGFRA, finemesh,finemesh_factor
+   implicit none
+!variable for output only
+   real,dimension(:,:), intent(out)::   T2MVXY0,T2MBXY0,Q2MVXY0,Q2MBXY0,TRADXY0,NEEXY0,GPPXY0,NPPXY0,FVEGXY0,RUNSFXY0,  &
+             RUNSBXY0,ECANXY0,EDIRXY0,ETRANXY0,FSAXY0,&
+             FIRAXY0,APARXY0,PSNXY0,SAVXY0,SAGXY0,RSSUNXY0,RSSHAXY0,BGAPXY0,WGAPXY0,TGVXY0,TGBXY0,CHVXY0,CHBXY0,SHGXY0,SHCXY0,SHBXY0, &
+             EVGXY0,EVBXY0,GHVXY0,GHBXY0,IRGXY0,IRCXY0,IRBXY0,TRXY0,EVCXY0,CHLEAFXY0,CHUCXY0,CHV2XY0,CHB2XY0
+
+         call finegrid2wrf(T2MVXY,T2MVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(T2MBXY,tt0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(FVEGXY,FVEGXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(Q2MVXY,Q2MVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(Q2MBXY,Q2MBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+      if(finemesh .ne. 1) then
+         call finegrid2wrf(TRADXY,TRADXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(NEEXY,NEEXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(GPPXY,GPPXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(NPPXY,NPPXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(RUNSFXY,RUNSFXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(RUNSBXY,RUNSBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(ECANXY,ECANXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(EDIRXY,EDIRXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(ETRANXY,ETRANXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(FSAXY,FSAXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(FIRAXY,FIRAXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(APARXY,APARXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(PSNXY,PSNXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(SAVXY,SAVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(SAGXY,SAGXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(RSSUNXY,RSSUNXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(RSSHAXY,RSSHAXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(BGAPXY,BGAPXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(WGAPXY,WGAPXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(TGVXY,TGVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+
+         call finegrid2wrf(TGBXY,TGBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(CHVXY,CHVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(CHBXY,CHBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(SHGXY,SHGXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(SHCXY,SHCXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(SHBXY,SHBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(EVGXY,EVGXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(EVBXY,EVBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(GHVXY,GHVXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(GHBXY,GHBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(IRGXY,IRGXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(IRCXY,IRCXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(IRBXY,IRBXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(TRXY,TRXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(EVCXY,EVCXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(CHLEAFXY,CHLEAFXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(CHUCXY,CHUCXY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(CHV2XY,CHV2XY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+         call finegrid2wrf(CHB2XY,CHB2XY0(its:ite,jts:jte),ite-its+1,jte-jts+1,finemesh_factor)
+      endif
+end subroutine l_finemesh2wrf
+
+subroutine wrf2finegrid(wrfGrid,fineGrid,ix,jx,AGGFACTRT)
+   implicit none
+   real, dimension(:,:), intent(in)::wrfGrid
+   real, dimension(:,:), intent(out)::fineGrid
+   integer:: i,j,ii,jj,ix,jx, AGGFACTRT
+   do j = 1, jx
+      do i = 1, ix 
+              do ii       =AGGFACTRT-1,0,-1
+              do jj       =AGGFACTRT-1,0,-1
+                  IXXRT=I*AGGFACTRT-ii       
+                  JYYRT=J*AGGFACTRT-jj
+                  fineGrid(ixxrt,jyyrt) = wrfGrid(i,j)
+              enddo
+              enddo
+      enddo ! end do loop for ix
+   enddo ! end do loop for jx
+end subroutine wrf2finegrid
+
+subroutine finegrid2wrf(fineGrid,wrfGrid,ix,jx,AGGFACTRT)
+   implicit none
+   real, dimension(:,:), intent(out)::wrfGrid
+   real, dimension(:,:), intent(in)::fineGrid
+   integer:: i,j,ii,jj,ix,jx, AGGFACTRT
+   do j = 1, jx
+      do i = 1, ix 
+              wrfGrid(k,j) = 0.0
+              do ii       =AGGFACTRT-1,0,-1
+              do jj       =AGGFACTRT-1,0,-1
+                  IXXRT=I*AGGFACTRT-ii       
+                  JYYRT=J*AGGFACTRT-jj
+                  wrfGrid(i,j) = wrfGrid(i,j) + fineGrid(ixxrt,jyyrt)
+              enddo
+              enddo
+              wrfGrid(i,j) = wrfGrid(i,j) / (AGGFACTRT*AGGFACTRT)
+      enddo ! end do loop for ix
+   enddo ! end do loop for jx
+end subroutine finegrid2wrf
+
+
+
+!program drive rtland
+! This subroutine will be used if the 4-layer Noah lsm is not used.
+      subroutine wrf2lsm (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp)
+!  input: z1,v1,kk1,z,ix,jx,kk
+!  output: vout
+!  interpolate based on soil layer: z1 and z 
+!  z :  soil layer of output variable.
+!  z1: array of soil layers of input variable.
+         implicit none
+         integer:: i,j,k
+         integer:: kk1, ix,jx,kk, vegtyp(ix,jx)
+         real :: z1(kk1), z(kk), v1(ix,kk1,jx),vout(ix,jx,kk)
+
+       
+         do j = 1, jx
+            do i = 1, ix
+                do k = 1, kk
+                  call interpLayer(Z1,v1(i,1:kk1,j),kk1,Z(k),vout(i,j,k)) 
+                end do
+            end do
+         end do
+      end subroutine wrf2lsm
+
+! This subroutine will be used if the 4-layer Noah lsm is not used.
+      subroutine lsm2wrf (z1,v1,kk1,z,vout,ix,jx,kk,vegtyp)
+!  input: z1,v1,kk1,z,ix,jx,kk
+!  output: vout
+!  interpolate based on soil layer: z1 and z 
+!  z :  soil layer of output variable.
+!  z1: array of soil layers of input variable.
+         implicit none
+         integer:: i,j,k
+         integer:: kk1, ix,jx,kk, vegtyp(ix,jx)
+         real :: z1(kk1), z(kk), v1(ix,jx,kk1),vout(ix,kk,jx)
+
+       
+         do j = 1, jx
+            do i = 1, ix
+                 do k = 1, kk
+                    call interpLayer(Z1,v1(i,j,1:kk1),kk1,Z(k),vout(i,k,j)) 
+                 end do
+            end do
+         end do
+      end subroutine lsm2wrf
+
+      subroutine interpLayer(inZ,inV,inK,outZ,outV)
+         implicit none
+         integer:: k, k1, k2
+         integer :: inK
+         real:: inV(inK),inZ(inK)
+         real:: outV, outZ, w1, w2
+
+         if(outZ .le. inZ(1)) then
+             w1 = (inZ(2)-outZ)/(inZ(2)-inZ(1))
+             w2 = (inZ(1)-outZ)/(inZ(2)-inZ(1))
+             outV = inV(1)*w1-inV(2)*w2
+             return
+         elseif(outZ .ge. inZ(inK)) then
+             w1 = (outZ-inZ(inK-1))/(inZ(inK)-inZ(inK-1)) 
+             w2 = (outZ-inZ(inK))  /(inZ(inK)-inZ(inK-1))
+             outV = inV(inK)*w1 -inV(inK-1)* w2
+             return
+         else  
+            do k = 2, inK
+             if((inZ(k) .ge. outZ).and.(inZ(k-1) .le. outZ) ) then
+                k1  = k-1
+                k2 = k
+                w1 = (outZ-inZ(k1))/(inZ(k2)-inZ(k1))
+                w2 = (inZ(k2)-outZ)/(inZ(k2)-inZ(k1))
+                outV = inV(k2)*w1 + inV(k1)*w2
+                return 
+             end if 
+            end do
+         endif
+      end subroutine interpLayer
+
+      subroutine lsm_wrf_input(did,vegtyp,soltyp,ix,jx)
+         implicit none
+         integer did, leng
+         parameter(leng=100)
+         integer :: i,j, nn, ix,jx
+         integer, dimension(ix,jx) :: soltyp, vegtyp
+         real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc
+
+
+         where(soltyp == 14) VEGTYP = 16
+         where(VEGTYP == 16 ) soltyp = 14
+
+         RT_DOMAIN(did)%VEGTYP = vegtyp
+
+!      input OV_ROUGH from OVROUGH.TBL
+#ifdef MPP_LAND
+       if(my_id .eq. IO_id) then
+#endif
+
+#ifndef NCEP_WCOSS
+       open(71,file="HYDRO.TBL", form="formatted")
+!read OV_ROUGH first
+          read(71,*) nn
+          read(71,*)
+          do i = 1, nn
+             read(71,*) RT_DOMAIN(did)%OV_ROUGH(i)
+          end do
+!read parameter for LKSAT
+          read(71,*) nn
+          read(71,*)
+          do i = 1, nn
+             read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i)
+          end do
+       close(71)
+#else
+
+       open(13, form="formatted")
+!read OV_ROUGH first
+          read(13,*) nn
+          read(13,*)
+          do i = 1, nn
+             read(13,*) RT_DOMAIN(did)%OV_ROUGH(i)
+          end do
+!read parameter for LKSAT
+          read(13,*) nn
+          read(13,*)
+          do i = 1, nn
+             read(13,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i)
+          end do
+       close(13)
+#endif
+
+#ifdef MPP_LAND
+       endif
+       call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH)
+       call mpp_land_bcast_real(leng,xdum1)
+       call mpp_land_bcast_real(leng,MAXSMC)
+       call mpp_land_bcast_real(leng,refsmc)
+       call mpp_land_bcast_real(leng,wltsmc)
+#endif
+
+       rt_domain(did)%lksat = 0.0
+       do j = 1, RT_DOMAIN(did)%jx
+             do i = 1, RT_DOMAIN(did)%ix
+                rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0
+                IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN   ! urban
+                    rt_domain(did)%SMCMAX1(i,j) = 0.45
+                    rt_domain(did)%SMCREF1(i,j) = 0.42
+                    rt_domain(did)%SMCWLT1(i,j) = 0.40
+                else
+                    rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J))
+                    rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J))
+                    rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J))
+                ENDIF
+             end do
+       end do
+
+      end subroutine lsm_wrf_input
+
+end module module_wrf_HYDRO
diff --git a/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F b/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F
new file mode 100644
index 00000000..f8cc01e4
--- /dev/null
+++ b/wrfv2_fire/hydro/CPL/WRF_cpl/wrf_drv_HYDRO.F
@@ -0,0 +1,57 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+!  
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+!2345678
+!ywGW       subroutine wrf_drv_HYDRO(HYDRO_dt,grid, config_flags, its,ite,jts,jte)
+       subroutine wrf_drv_HYDRO(HYDRO_dt,grid, its,ite,jts,jte)
+          use module_wrf_HYDRO, only: wrf_cpl_HYDRO
+          USE module_domain, ONLY : domain 
+          USE module_configure, ONLY : grid_config_rec_type
+       implicit none
+          integer:: its,ite,jts,jte
+          real :: HYDRO_dt
+          TYPE ( domain ), INTENT(INOUT) :: grid
+!ywGW          TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags
+          TYPE ( grid_config_rec_type ) :: config_flags
+!         return
+
+          if(grid%num_nests .lt. 1) then
+
+!ywGW             call wrf_cpl_HYDRO(HYDRO_dt, grid, config_flags, its,ite,jts,jte)  
+             call wrf_cpl_HYDRO(HYDRO_dt, grid, its,ite,jts,jte)  
+
+          endif
+       end subroutine wrf_drv_HYDRO
+
+
+       subroutine wrf_drv_HYDRO_ini(grid,its,ite,jts,jte)
+          use module_wrf_HYDRO, only: wrf_cpl_HYDRO
+          USE module_domain, ONLY : domain
+          implicit none
+           integer:: its,ite,jts,jte
+          TYPE ( domain ), INTENT(INOUT) :: grid
+
+          if(grid%num_nests .lt. 1) then
+!            call wrf_cpl_HYDRO_ini(grid,its,ite,jts,jte)  
+          endif
+
+       end subroutine wrf_drv_HYDRO_ini
+
diff --git a/wrfv2_fire/hydro/Data_Rec/Makefile b/wrfv2_fire/hydro/Data_Rec/Makefile
new file mode 100644
index 00000000..49ac4e92
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/Makefile
@@ -0,0 +1,28 @@
+# Makefile 
+#
+.SUFFIXES:
+.SUFFIXES: .o .F
+
+include ../macros
+
+OBJS = \
+	module_namelist.o \
+	module_RT_data.o \
+	module_gw_gw2d_data.o
+
+all:	$(OBJS) 
+
+.F.o:
+	@echo ""
+	$(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f
+	$(COMPILER90) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I../mod $(*).f
+	$(RMD) $(*).f
+	@echo ""
+	ar -r ../lib/libHYDRO.a $(@)
+	cp *.mod ../mod
+
+# Dependencies:
+#
+
+clean:
+	rm -f *.o *.mod *.stb *~ *.f
diff --git a/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc b/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc
new file mode 100644
index 00000000..ff9f3007
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/gw_field_include.inc
@@ -0,0 +1,34 @@
+
+ type gw_field
+      integer :: ix, jx
+      integer :: allo_status = -99
+
+      real :: dx, dt
+
+      integer, allocatable, dimension(:,:) ::  ltype     ! land-sfc type
+      real,    allocatable, dimension(:,:) ::  &
+        elev,           &  ! elev/bathymetry of sfc rel to sl (m)
+        bot,            &  ! elev. aquifer bottom rel to sl (m)
+        hycond,         &  ! hydraulic conductivity (m/s per m/m)
+        poros,          &  ! porosity (m3/m3)
+        compres,        &  ! compressibility (1/Pa)
+        ho                 ! head at start of timestep (m)
+
+      real,    allocatable, dimension(:,:) ::  &
+        h,              &  ! head, after ghmcompute (m)
+        convgw,         &  ! convergence due to gw flow (m/s)
+        excess             ! surface exceeding groundwater (mm)
+
+      real,    allocatable, dimension(:,:) ::  &
+	qdarcyRT,       &  ! approximated flux between soil and groundwater for coupled simulations on routing grid
+	qsgwrt,         &  ! flux between soil and groundwater for coupled simulations on routing grid
+	qsgw,           &  ! flux between soil and groundwater for coupled simulations on lsm grid
+	qgw_chanrt         ! flux between groundwater and channel
+
+      real  :: ebot, eocn
+      integer ::istep = 0
+      
+      real :: its, ite, jts, jte
+
+  end type gw_field
+
diff --git a/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F b/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F
new file mode 100644
index 00000000..4b171683
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/module_GW_baseflow_data.F
@@ -0,0 +1,9 @@
+Module module_GW_baseflow_data
+   IMPLICIT NONE
+   INTEGER, PARAMETER :: max_domain=5
+
+#include "gw_field_include.inc"
+      type (gw_field) :: gw2d(max_domain)
+      save gw2d
+
+end module module_GW_baseflow_data
diff --git a/wrfv2_fire/hydro/Data_Rec/module_RT_data.F b/wrfv2_fire/hydro/Data_Rec/module_RT_data.F
new file mode 100644
index 00000000..196dd68d
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/module_RT_data.F
@@ -0,0 +1,30 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+Module module_RT_data
+   IMPLICIT NONE
+   INTEGER, PARAMETER :: max_domain=5
+
+! define Routing data
+#include "rt_include.inc"
+   TYPE ( RT_FIELD ), DIMENSION (max_domain) :: RT_DOMAIN
+   save RT_DOMAIN
+   integer :: cur_did
+end module module_RT_data
diff --git a/wrfv2_fire/hydro/Data_Rec/module_gw_gw2d_data.F b/wrfv2_fire/hydro/Data_Rec/module_gw_gw2d_data.F
new file mode 100644
index 00000000..20792b7c
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/module_gw_gw2d_data.F
@@ -0,0 +1,30 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+!  
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+Module module_gw_gw2d_data
+   IMPLICIT NONE
+   INTEGER, PARAMETER :: max_domain=5
+
+#include "gw_field_include.inc"
+      type (gw_field) :: gw2d(max_domain)
+      save gw2d
+
+end module module_gw_gw2d_data
diff --git a/wrfv2_fire/hydro/Data_Rec/module_namelist.F b/wrfv2_fire/hydro/Data_Rec/module_namelist.F
new file mode 100644
index 00000000..66c6b212
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/module_namelist.F
@@ -0,0 +1,410 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+Module module_namelist
+
+#ifdef MPP_LAND
+          USE module_mpp_land
+#endif
+
+    IMPLICIT NONE
+    INTEGER, PARAMETER :: max_domain=5
+
+#include "namelist.inc"
+    TYPE(namelist_rt_field) , dimension(max_domain) :: nlst_rt
+    save nlst_rt 
+
+CONTAINS 
+
+    subroutine read_rt_nlst(nlst)     
+          implicit none
+
+          TYPE(namelist_rt_field) nlst
+
+          integer ierr
+          integer:: RT_OPTION, CHANRTSWCRT, channel_option, &
+                    SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, &
+                    GWBASESWCRT,  GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, &
+                    sys_cpl, rst_typ, rst_bi_in, rst_bi_out, &
+                    gwChanCondSw, GwPreCycles, GwSpinCycles, GwPreDiagInterval, gwsoilcpl, &
+                    UDMP_OPT
+          real:: DTRT_TER,DTRT_CH,dxrt, gwChanCondConstIn, gwChanCondConstOut, gwIhShift
+          character(len=256) :: route_topo_f=""
+          character(len=256) :: route_chan_f=""
+          character(len=256) :: route_link_f=""
+          character(len=256) :: route_lake_f=""
+          character(len=256) :: route_direction_f=""
+          character(len=256) :: route_order_f=""
+          character(len=256) :: gwbasmskfil =""
+          character(len=256) :: gwstrmfil =""
+          character(len=256) :: geo_finegrid_flnm =""
+          character(len=256) :: udmap_file =""
+          character(len=256) :: GWBUCKPARM_file = ""
+       integer :: SOLVEG_INITSWC
+       real out_dt, rst_dt
+       character(len=256)  :: RESTART_FILE = ""
+       logical            :: GwPreDiag, GwSpinUp
+       integer            :: split_output_count, order_to_write
+       integer :: igrid, iocflag
+       character(len=256) :: geo_static_flnm = ""
+       integer  :: DEEPGWSPIN
+
+       integer :: i
+
+       
+          integer ::CHRTOUT_DOMAIN           ! Netcdf point timeseries output at all channel points
+          integer ::CHRTOUT_GRID                ! Netcdf grid of channel streamflow values
+          integer ::LSMOUT_DOMAIN              ! Netcdf grid of variables passed between LSM and routing components
+          integer ::RTOUT_DOMAIN                ! Netcdf grid of terrain routing variables on routing grid
+          integer  :: output_gw
+          integer  :: outlake
+
+
+!!! add the following two dummy variables 
+       integer  :: NSOIL
+       real :: ZSOIL8(8)
+
+       logical            :: dir_e
+#ifdef WRF_HYDRO_NUDGING
+       character(len=256) :: nudgingParamFile
+       character(len=256) :: netwkReExFile
+       logical            :: readTimesliceParallel
+       logical            :: temporalPersistence
+       character(len=256) :: nudgingLastObsFile
+#endif 
+
+       namelist /HYDRO_nlist/ NSOIL, ZSOIL8,&
+            RESTART_FILE,SPLIT_OUTPUT_COUNT,IGRID,&
+            geo_static_flnm, &
+            out_dt, rst_dt, &
+            DEEPGWSPIN, SOLVEG_INITSWC, &
+            RT_OPTION, CHANRTSWCRT, channel_option, &
+                    SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, dtrt_ter,dtrt_ch,dxrt,&
+                    GwSpinCycles, GwPreCycles, GwSpinUp, GwPreDiag, GwPreDiagInterval, gwIhShift, &
+                    GWBASESWCRT, gwChanCondSw, gwChanCondConstIn, gwChanCondConstOut , &
+                    route_topo_f,route_chan_f,route_link_f,route_lake_f, &
+                    route_direction_f,route_order_f,gwbasmskfil, geo_finegrid_flnm,&
+                    gwstrmfil,GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, sys_cpl, &
+                    order_to_write , rst_typ, rst_bi_in, rst_bi_out, gwsoilcpl, &
+                    CHRTOUT_DOMAIN,CHRTOUT_GRID,LSMOUT_DOMAIN,RTOUT_DOMAIN, output_gw, outlake, udmap_file, &
+                    UDMP_OPT, GWBUCKPARM_file, iocflag
+
+   UDMP_OPT = 0
+   rst_bi_in = 0
+   rst_bi_out = 0
+   iocflag = 0
+
+
+#ifdef WRF_HYDRO_NUDGING
+   namelist /NUDGING_nlist/ nudgingParamFile,      netwkReExFile,       &
+                            readTimesliceParallel, temporalPersistence, &
+                            nudgingLastObsFile
+   ! Default values... 
+   nudgingParamFile = "DOMAIN/nudgingParams.nc"
+   netwkReExFile    = "DOMAIN/netwkReExFile.nc"
+   readTimesliceParallel = .true.
+   temporalPersistence   = .true.
+   nudgingLastObsFile = ""
+#endif 
+
+                    
+#ifdef MPP_LAND
+       if(IO_id .eq. my_id) then
+#endif
+#ifndef NCEP_WCOSS
+          open(12, file="hydro.namelist", form="FORMATTED")
+#else
+          open(12, form="FORMATTED")
+#endif
+          read(12, HYDRO_nlist, iostat=ierr)
+          if(ierr .ne. 0) call hydro_stop("HYDRO_nlst namelist error in read_rt_nlst")
+
+#ifdef WRF_HYDRO_NUDGING          
+          read(12, NUDGING_nlist, iostat=ierr)
+          if(ierr .ne. 0) call hydro_stop("NUDGING_nlst namelist error in read_rt_nlst")
+#endif
+          close(12)
+
+#ifdef MPP_LAND
+       endif
+#endif
+
+#ifdef HYDRO_REALTIME
+   if ( iocflag .eq. 4 ) RTOUT_DOMAIN = 0
+   if ( (iocflag .gt. 0) .and. (CHRTOUT_DOMAIN .eq.1) .and. (channel_option .ne. 3) ) CHRTOUT_DOMAIN = 2
+#endif
+
+#ifdef MPP_LAND
+!  call mpp_land_bcast_real1(DT)
+  call mpp_land_bcast_int1(SPLIT_OUTPUT_COUNT)
+  call mpp_land_bcast_int1(IGRID)
+  call mpp_land_bcast_int1(iocflag)
+  call mpp_land_bcast_real1(out_dt)
+  call mpp_land_bcast_real1(rst_dt)
+  call mpp_land_bcast_int1(DEEPGWSPIN)
+  call mpp_land_bcast_int1(SOLVEG_INITSWC)
+#endif
+
+
+#ifdef MPP_LAND
+      call mpp_land_bcast_int1(nlst%NSOIL)
+      do i = 1, nlst%NSOIL
+        call mpp_land_bcast_real1(nlst%ZSOIL8(i))
+      end do
+#ifdef HYDRO_D
+      write(6,*) "nlst%NSOIL = ", nlst%NSOIL
+      write(6,*) "nlst%ZSOIL8 = ",nlst%ZSOIL8
+#endif
+#endif
+
+!  nlst%DT = DT
+  nlst%RESTART_FILE = RESTART_FILE
+  nlst%SPLIT_OUTPUT_COUNT = SPLIT_OUTPUT_COUNT
+  nlst%IGRID = IGRID
+  nlst%iocflag = iocflag
+  nlst%geo_static_flnm = geo_static_flnm
+  nlst%out_dt = out_dt
+  nlst%rst_dt = rst_dt
+  nlst%DEEPGWSPIN = DEEPGWSPIN
+  nlst%SOLVEG_INITSWC = SOLVEG_INITSWC
+
+#ifdef MPP_LAND
+  call mpp_land_bcast_char(256,nlst%RESTART_FILE)
+#endif
+
+  write(nlst%hgrid,'(I1)') igrid
+
+
+  if(RESTART_FILE .eq. "") rst_typ = 0
+
+  if(rst_bi_out .eq. 1) then
+! This part works for intel not pgi
+!     inquire(directory='restart', exist=dir_e)
+      inquire(file='restart/.', exist=dir_e)
+      if(.not. dir_e) then
+         call system('mkdir restart')
+      endif
+  endif
+
+
+#ifdef MPP_LAND
+  !bcast namelist variable.
+  call mpp_land_bcast_int1(rt_option)
+  call mpp_land_bcast_int1(CHANRTSWCRT)
+  call mpp_land_bcast_int1(channel_option)
+  call mpp_land_bcast_int1(SUBRTSWCRT)
+  call mpp_land_bcast_int1(OVRTSWCRT)
+  call mpp_land_bcast_int1(AGGFACTRT)
+  call mpp_land_bcast_real1(DTRT_TER)
+  call mpp_land_bcast_real1(DTRT_CH)
+  call mpp_land_bcast_real1(DXRT)
+  call mpp_land_bcast_real1(gwChanCondConstIn)
+  call mpp_land_bcast_real1(gwChanCondConstOut)
+  call mpp_land_bcast_real1(gwIhShift)
+  call mpp_land_bcast_int1(GWBASESWCRT)
+  call mpp_land_bcast_int1(GWSOILCPL)
+  call mpp_land_bcast_int1(gwChanCondSw)
+  call mpp_land_bcast_int1(GwSpinCycles)
+  call mpp_land_bcast_int1(GwPreCycles)
+  call mpp_land_bcast_log1(GwPreDiag)
+  call mpp_land_bcast_log1(GwSpinUp)
+  call mpp_land_bcast_int1(GwPreDiagInterval)
+  call mpp_land_bcast_int1(GW_RESTART)
+  call mpp_land_bcast_int1(RSTRT_SWC  )
+  call mpp_land_bcast_int1(TERADJ_SOLAR)
+  call mpp_land_bcast_int1(sys_cpl)
+  call mpp_land_bcast_int1(rst_typ)
+  call mpp_land_bcast_int1(rst_bi_in)
+  call mpp_land_bcast_int1(rst_bi_out)
+  call mpp_land_bcast_int1(order_to_write)
+  call mpp_land_bcast_int1(CHRTOUT_DOMAIN)
+  call mpp_land_bcast_int1(output_gw)
+  call mpp_land_bcast_int1(outlake)
+  call mpp_land_bcast_int1(CHRTOUT_GRID)
+  call mpp_land_bcast_int1(LSMOUT_DOMAIN)
+  call mpp_land_bcast_int1(RTOUT_DOMAIN)
+  call mpp_land_bcast_int1(UDMP_OPT)
+#ifdef WRF_HYDRO_NUDGING
+  call mpp_land_bcast_char(256, nudgingParamFile  )
+  call mpp_land_bcast_char(256, netwkReExFile     )
+  call mpp_land_bcast_char(256, nudgingLastObsFile)
+  call mpp_land_bcast_log1(readTimesliceParallel)
+  call mpp_land_bcast_log1(temporalPersistence)
+#endif 
+#endif /* MPP_LAND */
+
+
+ 
+! run Rapid 
+    if(channel_option .eq. 4) then
+       CHANRTSWCRT = 0
+       OVRTSWCRT = 0
+       SUBRTSWCRT = 0
+    endif
+
+    nlst%CHRTOUT_DOMAIN = CHRTOUT_DOMAIN
+    nlst%output_gw      = output_gw
+    nlst%outlake      = outlake
+    nlst%CHRTOUT_GRID = CHRTOUT_GRID
+    nlst%LSMOUT_DOMAIN = LSMOUT_DOMAIN
+    nlst%RTOUT_DOMAIN = RTOUT_DOMAIN
+    nlst%RT_OPTION = RT_OPTION
+    nlst%CHANRTSWCRT = CHANRTSWCRT
+    nlst%GW_RESTART  = GW_RESTART 
+    nlst%RSTRT_SWC   = RSTRT_SWC  
+    nlst%channel_option = channel_option
+    nlst%DTRT_TER   = DTRT_TER
+    nlst%DTRT_CH   = DTRT_CH
+    nlst%DTCT      = DTRT_CH   ! small time step for grid based channel routing
+
+#ifdef MPP_LAND
+  if(my_id .eq. IO_id) then
+#endif
+    if(nlst%DT .lt. DTRT_CH) then 
+          print*, "nlst%DT,  DTRT_CH = ",nlst%DT,  DTRT_CH
+          print*, "reset DTRT_CH=nlst%DT "
+          DTRT_CH=nlst%DT
+    endif
+    if(nlst%DT .lt. DTRT_TER) then 
+          print*, "nlst%DT,  DTRT_TER = ",nlst%DT,  DTRT_TER
+          print*, "reset DTRT_TER=nlst%DT "
+          DTRT_TER=nlst%DT
+    endif
+    if(nlst%DT/DTRT_TER .ne. real(int(nlst%DT) / int(DTRT_TER)) ) then 
+         print*, "nlst%DT,  DTRT_TER = ",nlst%DT,  DTRT_TER
+         call hydro_stop("module_namelist: DT not a multiple of DTRT_TER")
+    endif
+    if(nlst%DT/DTRT_CH .ne. real(int(nlst%DT) / int(DTRT_CH)) ) then 
+         print*, "nlst%DT,  DTRT_CH = ",nlst%DT,  DTRT_CH
+         call hydro_stop("module_namelist: DT not a multiple of DTRT_CH")
+    endif
+#ifdef MPP_LAND
+  endif
+#endif
+
+    nlst%SUBRTSWCRT = SUBRTSWCRT
+    nlst%OVRTSWCRT = OVRTSWCRT
+    nlst%dxrt0 = dxrt
+    nlst%AGGFACTRT = AGGFACTRT
+    nlst%GWBASESWCRT = GWBASESWCRT
+    nlst%GWSOILCPL= GWSOILCPL
+    nlst%gwChanCondSw = gwChanCondSw
+    nlst%gwChanCondConstIn = gwChanCondConstIn
+    nlst%gwChanCondConstOut = gwChanCondConstOut
+    nlst%gwIhShift = gwIhShift
+    nlst%GwSpinCycles = GwSpinCycles
+    nlst%GwPreCycles = GwPreCycles
+    nlst%GwPreDiag = GwPreDiag
+    nlst%GwSpinUp = GwSpinUp
+    nlst%GwPreDiagInterval = GwPreDiagInterval
+    nlst%TERADJ_SOLAR = TERADJ_SOLAR
+    nlst%sys_cpl = sys_cpl
+    nlst%rst_typ = rst_typ
+    nlst%rst_bi_in = rst_bi_in
+    nlst%rst_bi_out = rst_bi_out
+    nlst%order_to_write = order_to_write
+! files
+    nlst%route_topo_f   =  route_topo_f
+    nlst%route_chan_f = route_chan_f 
+    nlst%route_link_f = route_link_f
+    nlst%route_lake_f =route_lake_f
+    nlst%route_direction_f =  route_direction_f
+    nlst%route_order_f =  route_order_f
+    nlst%gwbasmskfil =  gwbasmskfil
+    nlst%gwstrmfil =  gwstrmfil
+    nlst%geo_finegrid_flnm =  geo_finegrid_flnm
+    nlst%udmap_file =  udmap_file
+    nlst%UDMP_OPT = UDMP_OPT
+    nlst%GWBUCKPARM_file =  GWBUCKPARM_file
+#ifdef WRF_HYDRO_NUDGING
+    nlst%nudgingParamFile      = nudgingParamFile
+    nlst%netWkReExFile         = netWkReExFile
+    nlst%readTimesliceParallel = readTimesliceParallel
+    nlst%temporalPersistence   = temporalPersistence
+    nlst%nudgingLastObsFile    = nudgingLastObsFile
+#endif
+
+#ifdef MPP_LAND
+  if(my_id .eq. IO_id) then
+#endif
+#ifdef HYDRO_D
+     write(6,*) "output of the namelist file "
+    write(6,*) "nlst%udmap_file ", trim(nlst%udmap_file)
+    write(6,*) "nlst%UDMP_OPT ", nlst%UDMP_OPT
+    write(6,*) " nlst%RT_OPTION ", RT_OPTION
+    write(6,*) " nlst%CHANRTSWCRT ", CHANRTSWCRT
+    write(6,*) " nlst%GW_RESTART  ", GW_RESTART 
+    write(6,*) " nlst%RSTRT_SWC   ", RSTRT_SWC  
+    write(6,*) " nlst%channel_option ", channel_option
+    write(6,*) " nlst%DTRT_TER   ", DTRT_TER
+    write(6,*) " nlst%DTRT_CH   ", DTRT_CH
+    write(6,*) " nlst%SUBRTSWCRT ", SUBRTSWCRT
+    write(6,*) " nlst%OVRTSWCRT ", OVRTSWCRT
+    write(6,*) " nlst%dxrt0 ", dxrt
+    write(6,*) " nlst%AGGFACTRT ", AGGFACTRT
+    write(6,*) " nlst%GWBASESWCRT ", GWBASESWCRT
+    write(6,*) " nlst%GWSOILCPL ", GWSOILCPL
+    write(6,*) " nlst%gwChanCondSw ", gwChanCondSw
+    write(6,*) " nlst%gwChanCondConstIn ", gwChanCondConstIn
+    write(6,*) " nlst%gwChanCondConstOut ", gwChanCondConstOut
+    write(6,*) " nlst%gwIhShift ", gwIhShift
+    write(6,*) " nlst%GwSpinCycles ", GwSpinCycles
+    write(6,*) " nlst%GwPreDiag ", GwPreDiag
+    write(6,*) " nlst%GwPreDiagInterval ", GwPreDiagInterval
+    write(6,*) " nlst%TERADJ_SOLAR ", TERADJ_SOLAR
+    write(6,*) " nlst%sys_cpl ", sys_cpl
+    write(6,*) " nlst%rst_typ ", rst_typ
+    write(6,*) " nlst%order_to_write ", order_to_write
+    write(6,*) " nlst%route_topo_f   ",  route_topo_f
+    write(6,*) " nlst%route_chan_f ", route_chan_f 
+    write(6,*) " nlst%route_link_f ", route_link_f
+    write(6,*) " nlst%route_lake_f ",route_lake_f
+    write(6,*) " nlst%route_direction_f ",  route_direction_f
+    write(6,*) " nlst%route_order_f ",  route_order_f
+    write(6,*) " nlst%gwbasmskfil ",  gwbasmskfil
+    write(6,*) " nlst%gwstrmfil ",  gwstrmfil
+    write(6,*) " nlst%geo_finegrid_flnm ",  geo_finegrid_flnm
+#ifdef WRF_HYDRO_NUDGING
+    write(6,*) " nlst%nudgingParamFile",       trim(nudgingParamFile)
+    write(6,*) " nlst%netWkReExFile",          trim(netWkReExFile)
+    write(6,*) " nlst%readTimesliceParallel",  readTimesliceParallel
+    write(6,*) " nlst%temporalPersistence",    temporalPersistence
+    write(6,*) " nlst%nudgingLastObsFile",     trim(nudgingLastObsFile)
+#endif
+#endif /* HYDRO_D */
+#ifdef MPP_LAND
+  endif
+#endif
+
+#ifdef MPP_LAND
+  !bcast other  variable.
+      call mpp_land_bcast_real1(nlst%dt)
+#endif
+
+! derive rtFlag
+      nlst%rtFlag = 1
+      if(channel_option .eq. 4) nlst%rtFlag = 0
+!      if(CHANRTSWCRT .eq. 0 .and.  SUBRTSWCRT .eq. 0 .and. OVRTSWCRT .eq. 0 .and. GWBASESWCRT .eq. 0) nlst%rtFlag = 0
+      if(SUBRTSWCRT .eq. 0 .and. OVRTSWCRT .eq. 0 .and. GWBASESWCRT .eq. 0) nlst%rtFlag = 0
+      return
+    end subroutine read_rt_nlst
+
+
+end module module_namelist
diff --git a/wrfv2_fire/hydro/Data_Rec/namelist.inc b/wrfv2_fire/hydro/Data_Rec/namelist.inc
new file mode 100644
index 00000000..f7ba7c5f
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/namelist.inc
@@ -0,0 +1,65 @@
+   TYPE namelist_rt_field  
+      
+       integer :: nsoil, SOLVEG_INITSWC
+       real,allocatable,dimension(:) :: ZSOIL8
+       real out_dt, rst_dt, dt
+       integer :: START_YEAR, START_MONTH, START_DAY, START_HOUR, START_MIN
+       character(len=256)  :: restart_file = ""
+       integer            :: split_output_count
+       integer :: igrid
+       integer :: rst_bi_in   ! used for parallel io with large restart file.
+       integer :: rst_bi_out   ! used for parallel io with large restart file.
+                           ! each process will output the restart tile.
+       character(len=256) :: geo_static_flnm = ""
+       integer  :: DEEPGWSPIN
+       integer ::  order_to_write, rst_typ
+       character(len=256)  :: upmap_file = ""    ! user defined mapping file for NHDPLUS
+       
+!      additional character
+       character :: hgrid
+       character(len=19) :: olddate="123456"
+       character(len=19) :: startdate="123456"
+       character(len=19) :: sincedate="123456"
+
+       integer :: iocflag  ! used for NCEP REALTIME OUTPUT
+
+
+          integer:: RT_OPTION, CHANRTSWCRT, channel_option, &
+                  SUBRTSWCRT,OVRTSWCRT,AGGFACTRT, &
+                  GWBASESWCRT,  GW_RESTART,RSTRT_SWC,TERADJ_SOLAR, &
+                  sys_cpl, gwChanCondSw, GwPreCycles, GwSpinCycles, GwPreDiagInterval, &
+                  gwsoilcpl, UDMP_OPT
+          logical:: GwPreDiag, GwSpinUp
+          real:: DTRT_TER,DTRT_CH, DTCT, dxrt0,  gwChanCondConstIn, gwChanCondConstOut, gwIhShift
+          character(len=256) :: route_topo_f=""
+          character(len=256) :: route_chan_f=""
+          character(len=256) :: route_link_f=""
+          character(len=256) :: route_lake_f=""
+          character(len=256) :: route_direction_f=""
+          character(len=256) :: route_order_f=""
+          character(len=256) :: gwbasmskfil =""
+          character(len=256) :: gwstrmfil =""
+          character(len=256) :: geo_finegrid_flnm =""
+          character(len=256) :: udmap_file =""
+          character(len=256) :: GWBUCKPARM_file = ""
+
+          integer ::frxst_pts_out            ! ASCII point timeseries output at user specified points
+          integer ::CHRTOUT_DOMAIN           ! Netcdf point timeseries output at all channel points
+          integer ::CHRTOUT_GRID                ! Netcdf grid of channel streamflow values
+          integer ::LSMOUT_DOMAIN              ! Netcdf grid of variables passed between LSM and routing components
+          integer ::RTOUT_DOMAIN                ! Netcdf grid of terrain routing variables on routing grid
+          integer ::output_gw                   ! Netcdf grid of GW
+          integer ::outlake                   ! Netcdf grid of lake
+          integer :: rtFlag
+
+#ifdef WRF_HYDRO_NUDGING
+       character(len=256) :: nudgingParamFile
+       character(len=256) :: netwkReExFile
+       logical            :: readTimesliceParallel
+       logical            :: temporalPersistence
+       character(len=256) :: nudgingLastObsFile
+#endif
+
+
+   END TYPE namelist_rt_field 
+
diff --git a/wrfv2_fire/hydro/Data_Rec/rt_include.inc b/wrfv2_fire/hydro/Data_Rec/rt_include.inc
new file mode 100644
index 00000000..dbc1e853
--- /dev/null
+++ b/wrfv2_fire/hydro/Data_Rec/rt_include.inc
@@ -0,0 +1,218 @@
+   TYPE RT_FIELD  
+   INTEGER :: IX, JX
+   logical initialized
+   logical restQSTRM 
+  REAL    :: DX,GRDAREART,SUBFLORT,WATAVAILRT,QSUBDRYRT
+  REAL    :: SFHEAD1RT,INFXS1RT,QSTRMVOLTRT,QBDRYTRT,SFHEADRT,ETPND1,INFXSRTOT
+  REAL    :: LAKE_INFLOTRT,accsuminfxs,diffsuminfxs,RETDEPFRAC
+  REAL    :: VERTKSAT,l3temp,l4temp,l3moist,l4moist,RNOF1TOT,RNOF2TOT,RNOF3TOT
+  INTEGER :: IXRT,JXRT,vegct
+  INTEGER :: AGGFACYRT, AGGFACXRT, KRTel_option, FORC_TYP
+  INTEGER :: SATLYRCHKRT,DT_FRACRT
+  INTEGER ::  LAKE_CT, STRM_CT
+  REAL                                 :: RETDEP_CHAN  ! Channel retention depth
+  INTEGER :: NLINKS  !maximum number of unique links in channel
+  INTEGER :: GNLINKS  !maximum number of unique links in channel for parallel computation
+  INTEGER :: NLAKES !number of lakes modeled 
+  INTEGER :: NLINKSL !maximum number of links using linked routing
+  INTEGER :: MAXORDER !maximum stream order
+  integer :: timestep_flag    ! 1 cold start run else continue run
+
+  INTEGER :: GNLINKSL, linklsS, linklsE , nlinksize  !## for reach based channel routing
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!DJG   VARIABLES FOR ROUTING
+  INTEGER, allocatable, DIMENSION(:,:)      :: CH_NETRT !-- keeps track of the 0-1 channel network
+  INTEGER, allocatable, DIMENSION(:,:)      :: CH_LNKRT !-- linked routing grid (should combine with CH_NETRT.. redundant Gochis!)
+
+
+  INTEGER, allocatable, DIMENSION(:,:)      :: CH_NETLNK, GCH_NETLNK !-- assigns a unique value to each channel gridpoint, called links
+  REAL,    allocatable, DIMENSION(:,:)      :: LATVAL,LONVAL !-- lat lon
+  REAL,    allocatable, DIMENSION(:,:)      :: TERRAIN
+  REAL,    allocatable, DIMENSION(:,:)      :: landRunOff   ! used for NHDPLUS only
+  REAL, allocatable,    DIMENSION(:)        :: CHLAT,CHLON   !  channel lat and lon
+  ! INTEGER, allocatable, DIMENSION(:,:)    :: LAKE_MSKRT, BASIN_MSK,LAK_1K
+  INTEGER, allocatable, DIMENSION(:,:)      :: LAKE_MSKRT, LAK_1K
+  INTEGER, allocatable, DIMENSION(:,:)      :: g_LAK_1K
+  ! REAL,    allocatable, DIMENSION(:,:)      :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT, QSUBBDRYTRT
+  REAL :: QSUBBDRYTRT
+  REAL,    allocatable, DIMENSION(:,:)      :: ELRT,SOXRT,SOYRT,OVROUGHRT,RETDEPRT
+  REAL,    allocatable, DIMENSION(:,:,:)    :: SO8RT
+  INTEGER,    allocatable, DIMENSION(:,:,:) :: SO8RT_D, SO8LD_D
+  REAL,    allocatable, DIMENSION(:,:)      :: SO8LD_Vmax
+  REAL   Vmax
+  REAL,    allocatable, DIMENSION(:,:)      :: SFCHEADRT,INFXSRT,LKSAT,LKSATRT 
+  REAL,    allocatable, DIMENSION(:,:)      :: SFCHEADSUBRT,INFXSUBRT,LKSATFAC
+  REAL,    allocatable, DIMENSION(:,:)      :: QSUBRT,ZWATTABLRT,QSUBBDRYRT,SOLDEPRT
+  REAL,    allocatable, DIMENSION(:,:)      :: SUB_RESID
+  REAL,    allocatable, DIMENSION(:,:)      :: q_sfcflx_x,q_sfcflx_y
+  INTEGER,    allocatable, DIMENSION(:)      :: map_l2g, map_g2l
+
+  INTEGER :: nToInd
+  INTEGER,    allocatable, DIMENSION(:)      :: toNodeInd
+  INTEGER,    allocatable, DIMENSION(:,:)      :: gtoNode
+
+! temp arrary cwatavail
+  real, allocatable, DIMENSION(:,:,:)      :: SMCREFRT 
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!DJG   VARIABLES FOR GW/Baseflow
+  INTEGER :: numbasns
+  INTEGER :: gnumbasns
+  INTEGER, allocatable, DIMENSION(:)     :: basnsInd ! basin index for tile
+  INTEGER, allocatable, DIMENSION(:,:)   :: GWSUBBASMSK  !GW basin mask grid
+  REAL,    allocatable, DIMENSION(:,:)   :: qinflowbase  !strm inflow/baseflow from GW
+  REAL,    allocatable, DIMENSION(:,:)   :: SOLDRAIN     !time-step drainage
+  INTEGER, allocatable, DIMENSION(:,:)   :: gw_strm_msk  !GW basin mask grid
+  INTEGER, allocatable, DIMENSION(:,:)   :: gw_strm_msk_lind  !GW basin mask grid tile maping index
+  REAL,    allocatable, DIMENSION(:)     :: z_gwsubbas   !depth in GW bucket
+  REAL,    allocatable, DIMENSION(:)     :: qin_gwsubbas !flow to GW bucket
+  REAL,    allocatable, DIMENSION(:)     :: qout_gwsubbas!flow from GW bucket
+  REAL,    allocatable, DIMENSION(:)     :: gwbas_pix_ct !ct of strm pixels in
+  REAL,    allocatable, DIMENSION(:)     :: basns_area   !basin area
+  REAL,    allocatable, DIMENSION(:)     :: node_area   !nodes area
+
+  REAL,    allocatable, DIMENSION(:)     :: z_q_bas_parm !GW bucket disch params
+  INTEGER, allocatable, DIMENSION(:)     :: nhdBuckMask   ! bucket mask for NHDPLUS
+  INTEGER, allocatable, DIMENSION(:)     :: ct2_bas       !ct of lnd pixels in basn
+  REAL,    allocatable, DIMENSION(:)     :: bas_pcp      !sub-basin avg'd pcp
+  INTEGER                                :: bas
+  INTEGER, allocatable, DIMENSION(:)        :: bas_id
+  CHARACTER(len=19)                      :: header
+  CHARACTER(len=1)                       :: jnk
+  REAL, allocatable, DIMENSION(:)        :: gw_buck_coeff,gw_buck_exp,z_max  !GW bucket parameters
+!DJG Switch for Deep Sat GW Init:
+  INTEGER                                :: DEEPGWSPIN  !Switch to setup deep GW spinp
+!BF Variables for gw2d
+  integer, allocatable, dimension(:,:)      :: soiltyp, soiltypRT
+ 
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!DJG,DNY   VARIABLES FOR CHANNEL ROUTING
+!-- channel params
+  INTEGER, allocatable, DIMENSION(:)   :: LINK       !channel link
+  INTEGER, allocatable, DIMENSION(:)   :: TO_NODE    !link's to node
+  INTEGER, allocatable, DIMENSION(:)   :: FROM_NODE  !link's from node
+  INTEGER, allocatable, DIMENSION(:)   :: ORDER      !link's order
+  INTEGER, allocatable, DIMENSION(:)   :: STRMFRXSTPTS      !frxst point flag
+  CHARACTER(len=15), allocatable, DIMENSION(:) :: gages
+  !                                                    123456789012345
+  CHARACTER(len=15)                     :: gageMiss = '               '
+!  CHARACTER(len=15)                     :: gageMiss = '          -9999'
+
+  INTEGER, allocatable, DIMENSION(:)   :: TYPEL       !type of link Muskingum: 0 strm 1 lake
+                                                      !-- Diffusion: 0 edge or pour; 1 interior; 2 lake
+  INTEGER, allocatable, DIMENSION(:)   :: TYPEN      !type of link 0 strm 1 lake
+  REAL, allocatable, DIMENSION(:)      :: QLAKEI      !lake inflow in difussion scheme
+  REAL, allocatable, DIMENSION(:)      :: QLAKEO      !lake outflow in difussion scheme
+  INTEGER, allocatable, DIMENSION(:)   :: LAKENODE   !which nodes flow into which lakes
+  INTEGER, allocatable, DIMENSION(:)   :: LINKID     ! id of links on linked routing
+  REAL, allocatable, DIMENSION(:)      :: CVOL       ! channel volume
+  INTEGER, allocatable, DIMENSION(:,:)   :: pnode    !parent nodes : start from 2
+  integer :: maxv_p              ! array size for  second column of the pnode
+
+  REAL, allocatable, DIMENSION(:)      :: MUSK, MUSX !muskingum params
+  REAL, allocatable, DIMENSION(:)      :: CHANLEN    !link length
+  REAL, allocatable, DIMENSION(:)      :: MannN      !mannings N
+  REAL, allocatable, DIMENSION(:)      :: So         !link slope
+  REAL, allocatable, DIMENSION(:)      :: ChSSlp, Bw !trapezoid link params
+  REAL, allocatable, DIMENSION(:,:)    :: QLINK      !flow in link
+#ifdef WRF_HYDRO_NUDGING
+  REAL, allocatable, DIMENSION(:)      :: nudge      !difference between modeled and DA adj link flow
+#endif
+  REAL, allocatable, DIMENSION(:)      :: HLINK      !head in link
+  REAL, allocatable, DIMENSION(:)      :: ZELEV      !elevation of nodes for channel
+  INTEGER, allocatable, DIMENSION(:)   :: CHANXI,CHANYJ !map chan to fine grid
+  REAL,  DIMENSION(50)     :: BOTWID,HLINK_INIT,CHAN_SS,CHMann !Channel parms from table
+
+  REAL, allocatable, DIMENSION(:)      :: RESHT  !reservoir height
+!-- lake params
+  INTEGER, allocatable, DIMENSION(:) :: LAKEIDA     !id of lakes in routlink file
+  INTEGER, allocatable, DIMENSION(:) :: LAKEIDM     !id of LAKES Modeled in LAKEPARM.nc or tbl
+  REAL, allocatable, DIMENSION(:)    :: HRZAREA    !horizontal extent of lake, km^2
+  REAL, allocatable, DIMENSION(:)    :: WEIRL      !overtop weir length (m)
+  REAL, allocatable, DIMENSION(:)    :: ORIFICEC   !coefficient of orifice
+  REAL, allocatable, DIMENSION(:)    :: ORIFICEA   !orifice opening area (m^2)
+  REAL, allocatable, DIMENSION(:)    :: ORIFICEE   !orifice elevation (m)
+  REAL, allocatable, DIMENSION(:)    :: LATLAKE, LONLAKE,ELEVLAKE ! lake info
+
+  INTEGER, allocatable, DIMENSION(:) :: LAKEIDX ! integer index for lakes, mapped to linkid
+
+!!! accumulated variables for reach beased rt
+  REAL, allocatable, DIMENSION(:)    :: accLndRunOff, accQLateral, accStrmvolrt, accBucket
+  !REAL, allocatable, DIMENSION(:)    :: qqLndRunOff, qqStrmvolrt, qqBucket
+  REAL, allocatable, DIMENSION(:)    :: QLateral, velocity
+
+#ifdef MPP_LAND
+  INTEGER, allocatable, DIMENSION(:)    :: lake_index,nlinks_index
+  INTEGER, allocatable, DIMENSION(:,:)  :: Link_location
+  INTEGER, allocatable, DIMENSION(:)  :: LLINKID
+  integer mpp_nlinks, yw_mpp_nlinks, LNLINKSL
+#endif
+  INTEGER, allocatable, DIMENSION(:,:)      :: CH_LNKRT_SL !-- reach based links used for mapping
+
+
+  REAL,    allocatable, DIMENSION(:,:)      :: OVROUGHRTFAC,RETDEPRTFAC
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!DJG   VARIABLES FOR AGGREGATION/DISAGGREGATION
+  REAL,    allocatable, DIMENSION(:,:,:)   :: SMCRT,SMCMAXRT,SMCWLTRT,SH2OWGT,SICE
+  REAL,    allocatable, DIMENSION(:,:)     :: INFXSAGGRT
+  REAL,    allocatable, DIMENSION(:,:)     :: DHRT,QSTRMVOLRT,QBDRYRT,LAKE_INFLORT
+  REAL,    allocatable, DIMENSION(:,:)     :: QSTRMVOLRT_TS,LAKE_INFLORT_TS
+  REAL,    allocatable, DIMENSION(:,:)     :: QSTRMVOLRT_DUM,LAKE_INFLORT_DUM
+  REAL,    allocatable, DIMENSION(:,:)       :: INFXSWGT, ywtmp
+  REAL,    allocatable, DIMENSION(:)       :: SMCAGGRT,STCAGGRT,SH2OAGGRT
+  REAL    :: INFXSAGG1RT,SFCHEADAGG1RT,SFCHEADAGGRT
+  REAL,    allocatable, DIMENSION(:,:,:)       :: dist  ! 8 direction of distance
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!DJG   VARIABLES FOR ONLINE MASS BALANCE CALCULATION
+  REAL(KIND=8)    :: DCMC,DSWE,DACRAIN,DSFCEVP,DCANEVP,DEDIR,DETT,DEPND,DESNO,DSFCRNFF
+  REAL(KIND=8)    :: DSMCTOT,RESID,SUMEVP,DUG1RNFF,DUG2RNFF,SMCTOT1,SMCTOT2,DETP
+  REAL(KIND=8)    :: suminfxsrt,suminfxs1,suminfxs2,dprcp_ts
+  REAL(KIND=8)    :: CHAN_IN1,CHAN_IN2,LAKE_IN1,LAKE_IN2,zzz, CHAN_STOR,CHAN_OUT
+  REAL(KIND=8)    :: CHAN_INV,LAKE_INV  !-channel and lake inflow in volume
+  REAL(KIND=8)    :: DQBDRY
+  REAL    :: QSTRMVOLTRT1,LAKE_INFLOTRT1,QBDRYTOT1,LSMVOL
+  REAL(KIND=8),    allocatable, DIMENSION(:)   :: DSMC,SMCRTCHK
+  REAL(KIND=8),    allocatable, DIMENSION(:,:)  :: CMC_INIT,SWE_INIT
+!  REAL(KIND=8),    allocatable, DIMENSION(:,:,:) :: SMC_INIT
+  REAL(KIND=8)            :: SMC_INIT,SMC_FINAL,resid2,resid1
+  REAL(KIND=8)            :: chcksm1,chcksm2,CMC1,CMC2,prcp_in,ETATOT,dsmctot_av
+
+  integer :: g_ixrt,g_jxrt,flag
+  integer :: allo_status = -99
+  integer iywtmp
+
+
+!-- lake params
+  REAL, allocatable, DIMENSION(:)    :: LAKEMAXH   !maximum depth (m)
+  REAL, allocatable, DIMENSION(:)    :: WEIRC      !coeff of overtop weir
+  REAL, allocatable, DIMENSION(:)    :: WEIRH      !depth of Lake coef
+
+
+
+
+!DJG Modified namelist for routing and agg. variables
+  real Z_tmp
+
+  !!! define land surface grid variables
+      REAL,    allocatable, DIMENSION(:,:,:) :: SMC,STC,SH2OX
+      REAL,    allocatable, DIMENSION(:,:)   :: SMCMAX1,SMCWLT1,SMCREF1
+      INTEGER, allocatable, DIMENSION(:,:)   :: VEGTYP 
+      REAL,    allocatable, DIMENSION(:)   :: SLDPTH
+
+!!! define constant/parameter
+    real ::   ov_rough(50), ZSOIL(100)
+!  out_counts: couput counts for current run.
+!  his_out_counts: used for channel routing output and  special for restart. 
+!  his_out_counts = previous run + out_counts
+    integer :: out_counts, rst_counts, his_out_counts
+    
+    REAL,    allocatable, DIMENSION(:,:)   :: lat_lsm, lon_lsm
+    REAL,    allocatable, DIMENSION(:,:,:) :: dist_lsm
+
+   END TYPE RT_FIELD
diff --git a/wrfv2_fire/hydro/HYDRO_drv/Makefile b/wrfv2_fire/hydro/HYDRO_drv/Makefile
new file mode 100644
index 00000000..0b92dda7
--- /dev/null
+++ b/wrfv2_fire/hydro/HYDRO_drv/Makefile
@@ -0,0 +1,29 @@
+# Makefile 
+#
+.SUFFIXES:
+.SUFFIXES: .o .F
+
+include ../macros
+
+OBJS = \
+	module_HYDRO_drv.o
+all:	$(OBJS) 
+
+.F.o:
+	@echo ""
+	$(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f
+#	$(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) -I../mod $(*).f
+	$(COMPILER90) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) -I../mod $(*).f
+#	$(RMD) $(*).f
+	@echo ""
+	ar -r ../lib/libHYDRO.a $(@)
+	cp *.mod ../mod
+
+#
+# Dependencies:
+#
+module_HYDRO_drv.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o ../Data_Rec/module_gw_gw2d_data.o \
+        ../Routing/module_GW_baseflow.o ../Routing/module_HYDRO_utils.o ../Routing/module_HYDRO_io.o ../Routing/module_RT.o
+
+clean:
+	rm -f *.o *.mod *.stb *~ *.f
diff --git a/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F b/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F
new file mode 100644
index 00000000..15b43347
--- /dev/null
+++ b/wrfv2_fire/hydro/HYDRO_drv/module_HYDRO_drv.F
@@ -0,0 +1,1665 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+module module_HYDRO_drv
+#ifdef MPP_LAND 
+   use module_HYDRO_io, only:  output_rt, mpp_output_chrt, mpp_output_lakes, mpp_output_chrtgrd, &
+                               restart_out_bi, restart_in_bi, mpp_output_chrt2, mpp_output_lakes2
+   USE module_mpp_land
+#else
+   use module_HYDRO_io, only:  output_rt, output_chrt, output_chrt2, output_lakes
+#endif
+   use module_HYDRO_io, only: sub_output_gw, restart_out_nc, restart_in_nc,  &
+        get_file_dimension ,get2d_lsm_real, get2d_lsm_vegtyp, get2d_lsm_soltyp, &
+        output_lsm,  output_GW_Diag
+   use module_HYDRO_io, only : output_lakes2
+   use module_rt_data, only: rt_domain
+   use module_GW_baseflow
+   use module_gw_gw2d
+   use module_gw_gw2d_data, only: gw2d
+   use module_channel_routing, only: drive_channel, drive_channel_rsl
+   use module_namelist, only: nlst_rt, read_rt_nlst
+   use module_routing, only: getChanDim, landrt_ini
+   use module_HYDRO_utils
+!   use module_namelist
+   use module_lsm_forcing, only: geth_newdate
+#ifdef WRF_HYDRO_NUDGING
+   use module_stream_nudging,  only: init_stream_nudging
+#endif
+
+   use module_UDMAP, only: get_basn_area_nhd
+
+   implicit none
+
+#ifdef HYDRO_D
+  real :: timeOr = 0
+  real :: timeSr = 0
+  real :: timeCr = 0
+  real :: timeGW = 0
+  integer :: clock_count_1 = 0
+  integer :: clock_count_2 = 0
+  integer :: clock_rate    = 0
+#endif
+
+   
+
+   contains
+   subroutine HYDRO_rst_out(did)
+#ifdef WRF_HYDRO_NUDGING
+      use module_stream_nudging, only: output_nudging_last_obs
+#endif
+      implicit none
+      integer:: rst_out  
+      integer did, outflag
+      character(len=19) out_date
+#ifdef MPP_LAND
+      character(len=19) str_tmp
+#endif
+      rst_out = -99
+#ifdef MPP_LAND
+   if(IO_id .eq. my_id) then
+#endif
+     if(nlst_rt(did)%dt .gt. nlst_rt(did)%rst_dt*60) then
+        call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%rst_counts))
+     else
+        call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%rst_dt*60*rt_domain(did)%rst_counts))
+     endif
+     if ( (nlst_rt(did)%rst_dt .gt. 0) .and. (out_date(1:19) == nlst_rt(did)%olddate(1:19)) ) then
+           rst_out = 99
+           rt_domain(did)%rst_counts = rt_domain(did)%rst_counts + 1
+     endif
+! restart every month automatically.
+     if ( (nlst_rt(did)%olddate(9:10) == "01") .and. (nlst_rt(did)%olddate(12:13) == "00") .and. &
+          (nlst_rt(did)%olddate(15:16) == "00").and. (nlst_rt(did)%olddate(18:19) == "00") .and. &
+          (nlst_rt(did)%rst_dt .le. 0)  ) rst_out = 99
+
+#ifdef MPP_LAND
+   endif
+     call mpp_land_bcast_int1(rst_out)
+#endif
+    if(rst_out .gt. 0) then 
+#ifdef MPP_LAND
+      if(nlst_rt(did)%rst_bi_out .eq. 1) then
+             if(my_id .lt. 10) then
+                  write(str_tmp,'(I1)') my_id 
+             else if(my_id .lt. 100) then 
+                  write(str_tmp,'(I2)') my_id 
+             else if(my_id .lt. 1000) then
+                  write(str_tmp,'(I3)') my_id 
+             else if(my_id .lt. 10000) then
+                  write(str_tmp,'(I4)') my_id 
+             else if(my_id .lt. 100000) then 
+                  write(str_tmp,'(I5)') my_id 
+             else
+                continue
+             endif
+             call mpp_land_bcast_char(16,nlst_rt(did)%olddate(1:16))
+             call   RESTART_OUT_bi(trim("HYDRO_RST."//nlst_rt(did)%olddate(1:16)   &
+                 //"_DOMAIN"//trim(nlst_rt(did)%hgrid)//"."//trim(str_tmp)),  did)
+      else
+#endif
+             call   RESTART_OUT_nc(trim("HYDRO_RST."//nlst_rt(did)%olddate(1:16)   &
+                 //"_DOMAIN"//trim(nlst_rt(did)%hgrid)),  did)
+#ifdef MPP_LAND
+      endif
+#endif
+
+#ifdef WRF_HYDRO_NUDGING
+      call output_nudging_last_obs  !! only does something if temporalPersistence==TRUE
+#endif      
+   endif
+
+
+   end subroutine HYDRO_rst_out
+
+   subroutine HYDRO_out(did)
+   
+      implicit none
+      integer did, outflag, rtflag
+      character(len=19) out_date
+      integer :: Kt, ounit, i
+      real, dimension(RT_DOMAIN(did)%NLINKS,2) :: str_out
+      real, dimension(RT_DOMAIN(did)%NLINKS) :: vel_out
+
+!    real, dimension(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx):: soilmx_tmp, &
+!           runoff1x_tmp, runoff2x_tmp, runoff3x_tmp,etax_tmp, &
+!           EDIRX_tmp,ECX_tmp,ETTX_tmp,RCX_tmp,HX_tmp,acrain_tmp, &
+!           ACSNOM_tmp, esnow2d_tmp, drip2d_tmp,dewfall_tmp, fpar_tmp, &
+!           qfx_tmp, prcp_out_tmp, etpndx_tmp
+
+   outflag = -99
+
+#ifdef MPP_LAND
+   if(IO_id .eq. my_id) then
+#endif
+      if(nlst_rt(did)%olddate(1:19) .eq. nlst_rt(did)%startdate(1:19) .and. rt_domain(did)%his_out_counts .eq. 0) then
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+         write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19), rt_domain(did)%his_out_counts
+#else
+         write(78,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19), rt_domain(did)%his_out_counts
+#endif
+#endif
+         outflag = 99
+      else
+         if(nlst_rt(did)%dt .gt. nlst_rt(did)%out_dt*60) then
+             call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%dt*rt_domain(did)%out_counts))
+         else
+             call geth_newdate(out_date, nlst_rt(did)%startdate, nint(nlst_rt(did)%out_dt*60*rt_domain(did)%out_counts))
+         endif
+         if ( out_date(1:19) == nlst_rt(did)%olddate(1:19) ) then
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+             write(6,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19)
+#else
+             write(78,*) "output hydrology at time : ",nlst_rt(did)%olddate(1:19)
+#endif
+#endif
+             outflag = 99
+         endif
+      endif
+#ifdef MPP_LAND
+   endif
+     call mpp_land_bcast_int1(outflag)
+#endif
+
+     call HYDRO_rst_out(did) 
+
+     if (outflag .lt. 0) return
+
+     rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1
+
+     rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1
+
+     if(nlst_rt(did)%out_dt*60 .gt. nlst_rt(did)%DT) then
+        kt = rt_domain(did)%his_out_counts*nlst_rt(did)%out_dt*60/nlst_rt(did)%DT
+     else
+        kt = rt_domain(did)%his_out_counts
+     endif
+
+! jump the ouput for the initial time when it has restart file from routing.
+   rtflag = -99
+#ifdef MPP_LAND
+   if(IO_id .eq. my_id) then
+#endif
+       if ( (trim(nlst_rt(did)%restart_file) /= "") .and. ( nlst_rt(did)%startdate(1:19) == nlst_rt(did)%olddate(1:19) ) ) then
+#ifndef NCEP_WCOSS
+             print*, "yyyywww restart_file = ", trim(nlst_rt(did)%restart_file) 
+#else
+             write(78,*) "yyyywww restart_file = ", trim(nlst_rt(did)%restart_file) 
+#endif
+             rtflag = 1
+       endif
+#ifdef MPP_LAND
+   endif  
+   call mpp_land_bcast_int1(rtflag)
+#endif
+
+
+!yw keep the initial time otuput for debug
+      if(rtflag == 1) then 
+          rt_domain(did)%restQSTRM = .false.   !!! do not reset QSTRM.. at initial time.
+#ifndef HYDRO_REALTIME
+          return ! jump the initial time output for routing restart
+#endif
+      endif
+
+
+     if(nlst_rt(did)%LSMOUT_DOMAIN .eq. 1)  &
+     call output_lsm(trim(nlst_rt(did)%olddate(1:4)//nlst_rt(did)%olddate(6:7)//nlst_rt(did)%olddate(9:10)  &
+                 //nlst_rt(did)%olddate(12:13)//nlst_rt(did)%olddate(15:16)//  &
+                 ".LSMOUT_DOMAIN"//trim(nlst_rt(did)%hgrid)),     &
+                 did)
+
+    
+
+        if(nlst_rt(did)%SUBRTSWCRT .gt. 0 &
+             .or. nlst_rt(did)%OVRTSWCRT .gt. 0 &
+             .or. nlst_rt(did)%GWBASESWCRT .gt. 0 ) then
+
+           
+
+              if(nlst_rt(did)%RTOUT_DOMAIN .eq. 1)  &
+              call output_rt(    &
+                nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+                RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt, &
+                nlst_rt(did)%nsoil, &
+!               nlst_rt(did)%startdate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,&
+                nlst_rt(did)%sincedate, nlst_rt(did)%olddate, RT_DOMAIN(did)%QSUBRT,&
+                RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SMCRT,&
+                RT_DOMAIN(did)%SUB_RESID,       &
+                   RT_DOMAIN(did)%q_sfcflx_x,RT_DOMAIN(did)%q_sfcflx_y,&
+                RT_DOMAIN(did)%soxrt,RT_DOMAIN(did)%soyrt,&
+                RT_DOMAIN(did)%QSTRMVOLRT,RT_DOMAIN(did)%SFCHEADSUBRT, &
+                nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT,&
+                RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL,&
+                RT_DOMAIN(did)%LONVAL,RT_DOMAIN(did)%dist,nlst_rt(did)%RTOUT_DOMAIN,&
+                RT_DOMAIN(did)%QBDRYRT &
+#ifdef HYDRO_REALTIME
+		, nlst_rt(did)%iocflag &
+#endif
+		 )
+
+
+
+
+           if(nlst_rt(did)%GWBASESWCRT .eq. 3) then
+	     
+              if(nlst_rt(did)%output_gw  .eq. 1)  &
+              call sub_output_gw(    &
+                nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+                RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt,          &
+                nlst_rt(did)%nsoil,                               &
+!               nlst_rt(did)%startdate, nlst_rt(did)%olddate,    &
+                nlst_rt(did)%sincedate, nlst_rt(did)%olddate,    &
+                gw2d(did)%h, RT_DOMAIN(did)%SMCRT,                   &
+                gw2d(did)%convgw, gw2d(did)%excess,                  &
+                gw2d(did)%qsgwrt, gw2d(did)%qgw_chanrt,              &
+                nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT, &
+                RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%LATVAL,       &
+                RT_DOMAIN(did)%LONVAL,rt_domain(did)%dist,           &
+                nlst_rt(did)%output_gw)
+
+	  endif
+! BF end gw2d output section
+
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+          write(6,*) "before call output_chrt"
+          call flush(6)
+#else
+          write(78,*) "before call output_chrt"
+#endif
+#endif
+     
+           if (nlst_rt(did)%CHANRTSWCRT.eq.1.or.nlst_rt(did)%CHANRTSWCRT.eq.2) then 
+
+!ADCHANGE: Change values for within lake reaches to NA
+             str_out = RT_DOMAIN(did)%QLINK
+             vel_out = RT_DOMAIN(did)%velocity
+
+#ifdef HYDRO_REALTIME
+             if (RT_DOMAIN(did)%NLAKES .gt. 0)  then
+                    do i=1,RT_DOMAIN(did)%NLINKS
+                        if (RT_DOMAIN(did)%TYPEL(i) .eq. 2) then
+                            str_out(i,1) = -9.E15
+                            vel_out(i) = -9.E15
+                        endif
+                    end do
+             endif
+#endif
+!ADCHANGE: End
+
+             if(nlst_rt(did)%CHRTOUT_DOMAIN  .eq. 1)  then
+#ifdef MPP_LAND
+                 call mpp_output_chrt(rt_domain(did)%gnlinks,rt_domain(did)%gnlinksl,rt_domain(did)%map_l2g, &
+#else
+                 call output_chrt(  &
+#endif
+                   nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+                   RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, &
+                   nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,&
+                   RT_DOMAIN(did)%CHLAT,                                      &
+                   RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV,                &
+                   !RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt,                   &
+                   str_out, nlst_rt(did)%DT,Kt,                               &
+                   RT_DOMAIN(did)%STRMFRXSTPTS,nlst_rt(did)%order_to_write,   &
+                   RT_DOMAIN(did)%NLINKSL,nlst_rt(did)%channel_option,        &
+                   rt_domain(did)%gages, rt_domain(did)%gageMiss,             &
+                   nlst_rt(did)%dt                                            &
+#ifdef WRF_HYDRO_NUDGING
+                   , RT_DOMAIN(did)%nudge                                     &
+#endif
+                   , RT_DOMAIN(did)%accLndRunOff, RT_DOMAIN(did)%accQLateral, &
+                   RT_DOMAIN(did)%accStrmvolrt,                               &
+                   RT_DOMAIN(did)%accBucket, nlst_rt(did)%UDMP_OPT            &
+                   )
+              else
+                if(nlst_rt(did)%CHRTOUT_DOMAIN  .eq. 2)  then
+#ifdef MPP_LAND
+                     call mpp_output_chrt2(rt_domain(did)%gnlinks,rt_domain(did)%gnlinksl,rt_domain(did)%map_l2g, &
+#else
+                     call output_chrt2(  &
+#endif
+                     nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+                     RT_DOMAIN(did)%NLINKS,RT_DOMAIN(did)%ORDER, &
+                     nlst_rt(did)%sincedate,nlst_rt(did)%olddate,RT_DOMAIN(did)%CHLON,&
+                     RT_DOMAIN(did)%CHLAT,                                      &
+                     RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ZELEV,                &
+                     !RT_DOMAIN(did)%QLINK,nlst_rt(did)%DT,Kt,                   &
+                     str_out, nlst_rt(did)%DT,Kt,                               &
+                     RT_DOMAIN(did)%NLINKSL,nlst_rt(did)%channel_option,        &
+                     rt_domain(did)%linkid                                      &
+#ifdef WRF_HYDRO_NUDGING
+                     , RT_DOMAIN(did)%nudge                                     &
+#endif
+		     !, RT_DOMAIN(did)%QLateral, nlst_rt(did)%iocflag, RT_DOMAIN(did)%velocity &          
+                     , RT_DOMAIN(did)%QLateral, nlst_rt(did)%iocflag, vel_out &
+                     , RT_DOMAIN(did)%accLndRunOff,                             &
+                     RT_DOMAIN(did)%accQLateral,                                &
+                     RT_DOMAIN(did)%accStrmvolrt,                               &
+                     RT_DOMAIN(did)%accBucket,                                  &
+                     nlst_rt(did)%UDMP_OPT            &
+		     )
+                 endif
+
+              endif
+
+      
+#ifdef MPP_LAND
+              if(nlst_rt(did)%CHRTOUT_GRID  .eq. 1)  &
+              call mpp_output_chrtgrd(nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+                  RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt, RT_DOMAIN(did)%NLINKS,   &
+                  RT_DOMAIN(did)%GCH_NETLNK, &
+                  nlst_rt(did)%startdate, nlst_rt(did)%olddate, &
+                  !RT_DOMAIN(did)%qlink, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm,   &
+                  str_out, nlst_rt(did)%dt, nlst_rt(did)%geo_finegrid_flnm,   &
+                  RT_DOMAIN(did)%gnlinks,RT_DOMAIN(did)%map_l2g,                   &
+                  RT_DOMAIN(did)%g_ixrt,RT_DOMAIN(did)%g_jxrt )
+#endif
+
+               if (RT_DOMAIN(did)%NLAKES.gt.0)  then
+                      if(nlst_rt(did)%outlake .eq. 1) then
+#ifdef MPP_LAND
+                          call mpp_output_lakes( RT_DOMAIN(did)%lake_index, &
+#else
+                          call output_lakes(  &
+#endif
+                               nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+                               RT_DOMAIN(did)%NLAKES, &
+                               trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), &
+                               RT_DOMAIN(did)%LATLAKE,RT_DOMAIN(did)%LONLAKE, &
+                               RT_DOMAIN(did)%ELEVLAKE,RT_DOMAIN(did)%QLAKEI, &
+                               RT_DOMAIN(did)%QLAKEO, &
+                               RT_DOMAIN(did)%RESHT,nlst_rt(did)%DT,Kt)
+                      endif
+                      if(nlst_rt(did)%outlake .eq. 2) then
+#ifdef MPP_LAND
+                          call mpp_output_lakes2( RT_DOMAIN(did)%lake_index, &
+#else
+                          call output_lakes2(  &
+#endif
+                               nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, &
+                               RT_DOMAIN(did)%NLAKES, &
+                               trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), &
+                               RT_DOMAIN(did)%LATLAKE,RT_DOMAIN(did)%LONLAKE, &
+                               RT_DOMAIN(did)%ELEVLAKE,RT_DOMAIN(did)%QLAKEI, &
+                               RT_DOMAIN(did)%QLAKEO, &
+                               RT_DOMAIN(did)%RESHT,nlst_rt(did)%DT,Kt,RT_DOMAIN(did)%LAKEIDM)
+                      endif
+
+               endif   ! end if block of rNLAKES .gt. 0
+        endif 
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+           write(6,*) "end calling output functions"
+#else
+          write(78,*) "end calling output functions"
+#endif
+#endif
+
+        endif  ! end of routing switch
+
+
+      end subroutine HYDRO_out
+
+
+      subroutine HYDRO_rst_in(did)
+        integer :: did
+        integer:: flag 
+
+
+
+   flag = -1
+#ifdef MPP_LAND
+   if(my_id.eq.IO_id) then
+#endif
+      if (trim(nlst_rt(did)%restart_file) /= "") then
+          flag = 99
+          rt_domain(did)%timestep_flag = 99   ! continue run
+      endif 
+#ifdef MPP_LAND
+   endif 
+   call mpp_land_bcast_int1(flag)
+#endif
+
+   nlst_rt(did)%sincedate = nlst_rt(did)%startdate
+   
+   if (flag.eq.99) then
+
+#ifdef MPP_LAND
+     if(my_id.eq.IO_id) then
+#endif
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+        write(6,*) "*** read restart data: ",trim(nlst_rt(did)%restart_file)
+#else
+        write(78,*) "*** read restart data: ",trim(nlst_rt(did)%restart_file)
+#endif
+#endif
+#ifdef MPP_LAND
+     endif 
+#endif
+
+#ifdef MPP_LAND
+      if(nlst_rt(did)%rst_bi_in .eq. 1) then
+         call RESTART_IN_bi(trim(nlst_rt(did)%restart_file), did)
+      else
+#endif
+         call RESTART_IN_nc(trim(nlst_rt(did)%restart_file), did)
+#ifdef MPP_LAND
+      endif
+#endif
+
+!yw  if (trim(nlst_rt(did)%restart_file) /= "") then 
+!yw          nlst_rt(did)%restart_file = ""
+!yw  endif
+
+  endif
+ end subroutine HYDRO_rst_in
+
+     subroutine HYDRO_time_adv(did)
+        implicit none
+        character(len = 19) :: newdate 
+        integer did
+ 
+#ifdef MPP_LAND
+   if(IO_id.eq.my_id) then
+#endif
+         call geth_newdate(newdate, nlst_rt(did)%olddate, nint( nlst_rt(did)%dt))
+         nlst_rt(did)%olddate = newdate
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+         write(6,*) "current time is ",newdate
+#else
+         write(78,*) "current time is ",newdate
+#endif
+#endif
+#ifdef MPP_LAND
+   endif
+#endif
+     end subroutine HYDRO_time_adv
+  
+     subroutine HYDRO_exe(did)
+
+
+        implicit none
+        integer:: did
+        integer:: rst_out
+
+
+!       call HYDRO_out(did)
+
+
+! running land surface model
+! cpl: 0--offline run; 
+!      1-- coupling with WRF but running offline lsm; 
+!      2-- coupling with WRF but do not run offline lsm  
+!      3-- coupling with LIS and do not run offline lsm  
+!      4:  coupling with CLM
+!          if(nlst_rt(did)%SYS_CPL .eq. 0 .or. nlst_rt(did)%SYS_CPL .eq. 1 )then
+!                  call drive_noahLSF(did,kt)
+!          else
+!              ! does not run the NOAH LASF model, only read the parameter
+!              call read_land_par(did,lsm(did)%ix,lsm(did)%jx)
+!          endif
+
+
+
+
+
+           if (nlst_rt(did)%GWBASESWCRT .ne. 0     &
+               .or. nlst_rt(did)%SUBRTSWCRT .NE.0  &
+               .or. nlst_rt(did)%OVRTSWCRT .NE. 0 ) THEN
+
+
+              RT_DOMAIN(did)%QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT
+              RT_DOMAIN(did)%LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT
+
+
+
+                ! step 1) disaggregate specific fields from LSM to Hydro grid
+                if(nlst_rt(did)%SUBRTSWCRT .NE.0 .or. nlst_rt(did)%OVRTSWCRT .NE. 0) then
+                    call disaggregateDomain_drv(did)
+                endif
+                if(nlst_rt(did)%OVRTSWCRT .eq. 0) then
+                   if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+                      call RunOffDisag(RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%landRunOff,        &
+                          rt_domain(did)%dist_lsm(:,:,9),RT_DOMAIN(did)%dist(:,:,9), &
+                          RT_DOMAIN(did)%INFXSWGT, nlst_rt(did)%AGGFACTRT, RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx)
+                   endif
+                endif
+
+
+#ifdef HYDRO_D
+                call system_clock(count=clock_count_1, count_rate=clock_rate)
+#endif
+               ! step 2)
+                if(nlst_rt(did)%SUBRTSWCRT .NE.0) then
+                    call SubsurfaceRouting_drv(did)
+                endif
+#ifdef HYDRO_D
+                call system_clock(count=clock_count_2, count_rate=clock_rate)
+                timeSr = timeSr     + float(clock_count_2-clock_count_1)/float(clock_rate)
+#ifndef NCEP_WCOSS
+                write(6,*) "Timing: Subsurface Routing  accumulated time--", timeSr
+#else
+                write(78,*) "Timing: Subsurface Routing  accumulated time--", timeSr
+#endif
+#endif
+		
+		! step 3) todo split
+#ifdef HYDRO_D
+                call system_clock(count=clock_count_1, count_rate=clock_rate)
+#endif
+                if(nlst_rt(did)%OVRTSWCRT .NE. 0) then
+  		    call OverlandRouting_drv(did)
+                else
+                    RT_DOMAIN(did)%SFCHEADSUBRT = RT_DOMAIN(did)%INFXSUBRT
+                    RT_DOMAIN(did)%INFXSUBRT = 0.
+                endif
+#ifdef HYDRO_D
+                call system_clock(count=clock_count_2, count_rate=clock_rate)
+                timeOr = timeOr     + float(clock_count_2-clock_count_1)/float(clock_rate)
+#ifndef NCEP_WCOSS
+                write(6,*) "Timing: Overland Routing  accumulated time--", timeOr
+#else
+                write(78,*) "Timing: Overland Routing  accumulated time--", timeOr
+#endif
+#endif
+
+              RT_DOMAIN(did)%QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-RT_DOMAIN(did)%QSTRMVOLRT_DUM
+              RT_DOMAIN(did)%LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-RT_DOMAIN(did)%LAKE_INFLORT_DUM
+
+			
+#ifdef HYDRO_D
+                call system_clock(count=clock_count_1, count_rate=clock_rate)
+#endif
+		! step 4) baseflow or groundwater physics
+                if (nlst_rt(did)%GWBASESWCRT .gt. 0) then
+		     call driveGwBaseflow(did)
+                endif
+#ifdef HYDRO_D
+                call system_clock(count=clock_count_2, count_rate=clock_rate)
+                timeGw = timeGw     + float(clock_count_2-clock_count_1)/float(clock_rate)
+#ifndef NCEP_WCOSS
+                write(6,*) "Timing: GwBaseflow  accumulated time--", timeGw
+#else
+                write(78,*) "Timing: GwBaseflow  accumulated time--", timeGw
+#endif
+#endif
+	
+	
+#ifdef HYDRO_D
+                call system_clock(count=clock_count_1, count_rate=clock_rate)
+#endif
+		! step 5) river channel physics
+		  call driveChannelRouting(did)
+#ifdef HYDRO_D
+                call system_clock(count=clock_count_2, count_rate=clock_rate)
+                timeCr = timeCr     + float(clock_count_2-clock_count_1)/float(clock_rate)
+#ifndef NCEP_WCOSS
+                write(6,*) "Timing: Channel Routing  accumulated time--", timeCr
+#else
+                write(78,*) "Timing: Channel Routing  accumulated time--", timeCr
+#endif
+#endif
+	
+		! step 6) aggregate specific fields from Hydro to LSM grid
+               if (nlst_rt(did)%SUBRTSWCRT .NE.0  .or. nlst_rt(did)%OVRTSWCRT .NE. 0 ) THEN
+		      call aggregateDomain(did)
+               endif
+
+
+           end if
+
+
+!yw  if (nlst_rt(did)%sys_cpl .eq. 2) then
+      ! advance to next time step
+!          call HYDRO_time_adv(did)
+      ! output for history 
+!          call HYDRO_out(did)
+!yw  endif
+           call HYDRO_time_adv(did)
+           call HYDRO_out(did)
+
+
+!           write(90 + my_id,*) "finish calling hydro_exe"
+!           call flush(90+my_id)
+!          call mpp_land_sync()
+
+
+            
+           RT_DOMAIN(did)%SOLDRAIN = 0
+           RT_DOMAIN(did)%QSUBRT = 0
+
+
+
+      end subroutine HYDRO_exe
+
+      
+      
+!----------------------------------------------------      
+      subroutine driveGwBaseflow(did)
+       
+       implicit none
+       integer, intent(in) :: did
+       
+       integer :: i, jj, ii
+
+!------------------------------------------------------------------
+!DJG Begin GW/Baseflow Routines
+!-------------------------------------------------------------------
+
+  IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN     ! Switch to activate/specify GW/Baseflow
+
+!  IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN     ! Switch to activate/specify GW/Baseflow
+
+    If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then   ! Call simple bucket baseflow scheme
+
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+           write(6,*) "*****yw******start simp_gw_buck "
+#else
+          write(78,*) "*****yw******start simp_gw_buck " 
+#endif
+#endif
+
+       if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+          call simp_gw_buck_nhd(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,RT_DOMAIN(did)%jxrt,  &
+             RT_DOMAIN(did)%numbasns,nlst_rt(did)%AGGFACTRT, nlst_rt(did)%DT, RT_DOMAIN(did)%INFXSWGT,      &
+             RT_DOMAIN(did)%INFXSRT, RT_DOMAIN(did)%SOLDRAIN, RT_DOMAIN(did)%dist(:,:,9),rt_domain(did)%dist_lsm(:,:,9), &
+             RT_DOMAIN(did)%gw_buck_coeff, RT_DOMAIN(did)%gw_buck_exp, RT_DOMAIN(did)%z_max,     &
+             RT_DOMAIN(did)%z_gwsubbas, RT_DOMAIN(did)%qout_gwsubbas,RT_DOMAIN(did)%qin_gwsubbas,    &
+             nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT,          & 
+#ifdef MPP_LAND
+             RT_DOMAIN(did)%LNLINKSL &
+#else
+             RT_DOMAIN(did)%numbasns &
+#endif
+             , rt_domain(did)%basns_area, rt_domain(did)%nhdBuckMask &
+             )
+       else
+          call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,&
+             RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%gnumbasns,& 
+             RT_DOMAIN(did)%basns_area,&
+             RT_DOMAIN(did)%basnsInd, RT_DOMAIN(did)%gw_strm_msk_lind,             &
+             RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, &
+             RT_DOMAIN(did)%SOLDRAIN, &
+             RT_DOMAIN(did)%z_gwsubbas,&
+             RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,&
+             RT_DOMAIN(did)%qinflowbase,&
+             RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, &
+             RT_DOMAIN(did)%dist,nlst_rt(did)%DT,&
+             RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, &
+             RT_DOMAIN(did)%z_max,&
+             nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT)
+        endif
+
+        if(nlst_rt(did)%GWBASESWCRT .gt. 0 .and. nlst_rt(did)%output_gw .eq. 2) then
+           ! ouput of bucket information for NCAR GW option.
+            call output_GW_Diag(did)
+        endif
+
+#ifdef HYDRO_D 
+#ifndef NCEP_WCOSS
+           write(6,*) "*****yw******end simp_gw_buck "
+#else
+          write(78,*) "*****yw******end simp_gw_buck " 
+#endif
+#endif
+
+!!!For parameter setup runs output the percolation for each basin,
+!!!otherwise comment out this output...
+    else if (nlst_rt(did)%gwBaseSwCRT .eq. 3) then
+
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+           write(6,*) "*****bf******start 2d_gw_model "
+#else
+          write(78,*) "*****bf******start 2d_gw_model " 
+#endif
+#endif
+
+	   ! 	   compute qsgwrt  between lsm and gw with namelist selected coupling method
+	   ! 	   qsgwrt is defined on the routing grid  and needs to be aggregated for SFLX
+	   if (nlst_rt(did)%gwsoilcpl .GT. 0) THEN
+	     
+	     call gwSoilFlux(did)
+	     
+	   end if
+           
+	   
+	   gw2d(did)%excess = 0.
+	   
+           call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, &
+			gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, &
+			gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, &
+			gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, &
+			gw2d(did)%excess, &
+			gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, &
+			gw2d(did)%istep)
+           
+           
+	  gw2d(did)%ho = gw2d(did)%h
+ 
+          
+          
+	  ! put surface exceeding groundwater to surface routing inflow
+          RT_DOMAIN(did)%SFCHEADSUBRT = RT_DOMAIN(did)%SFCHEADSUBRT &
+	                              + gw2d(did)%excess*1000. ! convert to mm
+	  
+	  ! aggregate  qsgw from routing to lsm grid
+	  call aggregateQsgw(did)
+
+          gw2d(did)%istep =  gw2d(did)%istep + 1
+	  
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+           write(6,*) "*****bf******end 2d_gw_model "
+#else
+           write(78,*) "*****bf******end 2d_gw_model "
+#endif
+#endif
+      
+    End if
+
+  END IF    !DJG (End if for RTE SWC activation)
+!------------------------------------------------------------------
+!DJG End GW/Baseflow Routines
+!-------------------------------------------------------------------
+       
+      
+      end subroutine driveGwBaseflow
+      
+      
+      
+      
+!-------------------------------------------      
+      subroutine driveChannelRouting(did)
+       
+       implicit none
+       integer, intent(in) :: did
+       
+!-------------------------------------------------------------------
+!-------------------------------------------------------------------
+!DJG,DNY  Begin Channel and Lake Routing Routines
+!-------------------------------------------------------------------
+
+  IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN
+
+
+    if(rt_domain(did)%restQSTRM) then
+       RT_DOMAIN(did)%QSTRMVOLRT_TS = 0.000001
+       rt_domain(did)%restQSTRM = .false.
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+       write(6,*) "***** set QSTRMVOLRT_TS = 0.000001 *********"
+#else
+       write(78,*) "***** set QSTRMVOLRT_TS = 0.000001 *********" 
+#endif
+       call flush(6)
+#endif
+    endif 
+101  continue
+
+ if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+     !!! for user defined Reach based Routing method.
+
+    call drive_CHANNEL_RSL(nlst_rt(did)%UDMP_OPT,RT_DOMAIN(did)%timestep_flag, RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT,  &
+       RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS, RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, &
+       RT_DOMAIN(did)%TYPEL, RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER,   RT_DOMAIN(did)%CH_LNKRT, &
+       RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTCT, nlst_rt(did)%DTRT_CH, &
+       RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX, RT_DOMAIN(did)%QLINK, &
+       RT_DOMAIN(did)%CHANLEN, RT_DOMAIN(did)%MannN, RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp,RT_DOMAIN(did)%Bw, &
+       RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH, RT_DOMAIN(did)%WEIRH, RT_DOMAIN(did)%WEIRC, &
+       RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, RT_DOMAIN(did)%ORIFICEA, &
+       RT_DOMAIN(did)%ORIFICEE,  RT_DOMAIN(did)%CVOL, RT_DOMAIN(did)%QLAKEI, &
+       RT_DOMAIN(did)%QLAKEO, RT_DOMAIN(did)%LAKENODE, &
+       RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option,  &
+       RT_DOMAIN(did)%nlinks, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, RT_DOMAIN(did)%node_area,         &
+       RT_DOMAIN(did)%qout_gwsubbas, &
+       RT_DOMAIN(did)%LAKEIDA, RT_DOMAIN(did)%LAKEIDM, RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%LAKEIDX   &
+#ifdef MPP_LAND
+       , RT_DOMAIN(did)%nlinks_index, RT_DOMAIN(did)%mpp_nlinks, RT_DOMAIN(did)%yw_mpp_nlinks  &
+       , RT_DOMAIN(did)%LNLINKSL   &
+       , RT_DOMAIN(did)%gtoNode, RT_DOMAIN(did)%toNodeInd, RT_DOMAIN(did)%nToInd      &
+#endif
+       , RT_DOMAIN(did)%CH_LNKRT_SL, RT_DOMAIN(did)%landRunOff   &
+#ifdef WRF_HYDRO_NUDGING
+       , RT_DOMAIN(did)%nudge &
+#endif
+       , rt_domain(did)%accLndRunOff, rt_domain(did)%accQLateral, rt_domain(did)%accStrmvolrt, rt_domain(did)%accBucket &
+       , rt_domain(did)%QLateral, rt_domain(did)%velocity &
+       , rt_domain(did)%nlinksize, nlst_rt(did)%OVRTSWCRT, nlst_rt(did)%SUBRTSWCRT)
+else
+    call drive_CHANNEL(RT_DOMAIN(did)%latval,RT_DOMAIN(did)%lonval, &
+       RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, &
+       nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, &
+       RT_DOMAIN(did)%LAKE_INFLORT_TS, RT_DOMAIN(did)%QSTRMVOLRT_TS,&
+       RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,&
+       RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,&
+       RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT,RT_DOMAIN(did)%CH_LNKRT,&
+       RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTCT, nlst_rt(did)%DTRT_CH,&
+       RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX,  RT_DOMAIN(did)%QLINK, &
+       RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,&
+       RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, &
+       RT_DOMAIN(did)%Bw,&
+       RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,&
+       RT_DOMAIN(did)%WEIRH,    &
+       RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, &
+       RT_DOMAIN(did)%ORIFICEA, &
+       RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, &
+       RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,&
+       RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, &
+       RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, &
+       RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, &
+       RT_DOMAIN(did)%RETDEP_CHAN, RT_DOMAIN(did)%NLINKSL, RT_DOMAIN(did)%LINKID, &
+       RT_DOMAIN(did)%node_area  &
+#ifdef MPP_LAND
+       ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,&
+       RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, &
+       RT_DOMAIN(did)%yw_mpp_nlinks  &
+       , RT_DOMAIN(did)%LNLINKSL,RT_DOMAIN(did)%LLINKID &
+       , rt_domain(did)%gtoNode,rt_domain(did)%toNodeInd,rt_domain(did)%nToInd  &
+#endif
+       , rt_domain(did)%CH_LNKRT_SL   &
+       ,nlst_rt(did)%GwBaseSwCRT, gw2d(did)%ho, gw2d(did)%qgw_chanrt, &
+       nlst_rt(did)%gwChanCondSw, nlst_rt(did)%gwChanCondConstIn, &
+       nlst_rt(did)%gwChanCondConstOut &
+       )
+endif
+    
+    if((nlst_rt(did)%gwBaseSwCRT == 3) .and. (nlst_rt(did)%gwChanCondSw .eq. 1)) then
+      
+           ! add/rm channel-aquifer exchange contribution
+           
+           gw2d(did)%ho =  gw2d(did)%ho  &
+                        +(((gw2d(did)%qgw_chanrt*(-1)) * gw2d(did)%dt / gw2d(did)%dx**2) &
+                        /  gw2d(did)%poros)
+      
+    endif
+  endif
+
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+           write(6,*) "*****yw******end drive_CHANNEL "
+#else
+           write(78,*) "*****yw******end drive_CHANNEL " 
+#endif
+#endif
+      
+      end subroutine driveChannelRouting
+ 
+ 
+ 
+!------------------------------------------------ 
+      subroutine aggregateDomain(did)
+      
+#ifdef MPP_LAND
+        use module_mpp_land, only:  sum_real1, my_id, io_id, numprocs
+#endif
+ 
+       implicit none
+       integer, intent(in) :: did
+
+       integer :: i, j, krt, ixxrt, jyyrt, &
+                  AGGFACYRT, AGGFACXRT
+
+#ifdef HYDRO_D
+! ADCHANGE: Water balance variables
+       integer :: kk
+       real    :: smcrttot1,smctot2,sicetot2
+       real    :: suminfxsrt1,suminfxs2
+#endif
+
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+ 	print *, "Beginning Aggregation..."
+#else
+       write(78,*) "Beginning Aggregation..."
+#endif
+#endif
+
+#ifdef HYDRO_D
+! ADCHANGE: START Initial water balance variables
+! ALL VARS in MM
+        suminfxsrt1 = 0.
+        smcrttot1 = 0.
+        do i=1,RT_DOMAIN(did)%IXRT
+         do j=1,RT_DOMAIN(did)%JXRT
+            suminfxsrt1 = suminfxsrt1 + RT_DOMAIN(did)%SFCHEADSUBRT(I,J) &
+                               / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT)
+            do kk=1,nlst_rt(did)%NSOIL
+                smcrttot1 = smcrttot1 + RT_DOMAIN(did)%SMCRT(I,J,KK)*RT_DOMAIN(did)%SLDPTH(KK)*1000. &
+                               / float(RT_DOMAIN(did)%IXRT * RT_DOMAIN(did)%JXRT)
+            end do
+         end do
+        end do
+#ifdef MPP_LAND
+! not tested
+        CALL sum_real1(suminfxsrt1)
+        CALL sum_real1(smcrttot1)
+        suminfxsrt1 = suminfxsrt1/float(numprocs)
+        smcrttot1 = smcrttot1/float(numprocs)
+#endif
+! END Initial water balance variables
+#endif
+
+        do J=1,RT_DOMAIN(did)%JX
+          do I=1,RT_DOMAIN(did)%IX
+
+             RT_DOMAIN(did)%SFCHEADAGGRT = 0.
+!DJG Subgrid weighting edit...
+             RT_DOMAIN(did)%LSMVOL=0.
+             do KRT=1,nlst_rt(did)%NSOIL
+!                SMCAGGRT(KRT) = 0.
+               RT_DOMAIN(did)%SH2OAGGRT(KRT) = 0.
+             end do
+
+
+             do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1
+              do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1
+
+
+                IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT
+                JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT
+#ifdef MPP_LAND
+       if(left_id.ge.0) IXXRT=IXXRT+1
+       if(down_id.ge.0) JYYRT=JYYRT+1
+#else
+!yw ????
+!       IXXRT=IXXRT+1
+!       JYYRT=JYYRT+1
+#endif
+
+!State Variables
+                RT_DOMAIN(did)%SFCHEADAGGRT = RT_DOMAIN(did)%SFCHEADAGGRT &
+                                            + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT)
+!DJG Subgrid weighting edit...
+                RT_DOMAIN(did)%LSMVOL = RT_DOMAIN(did)%LSMVOL &
+                                      + RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) &
+                                      * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9)
+
+                do KRT=1,nlst_rt(did)%NSOIL
+!DJG               SMCAGGRT(KRT)=SMCAGGRT(KRT)+SMCRT(IXXRT,JYYRT,KRT)
+                   RT_DOMAIN(did)%SH2OAGGRT(KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) &
+                                                 + RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT)
+                end do
+
+              end do
+             end do
+
+
+
+            RT_DOMAIN(did)%SFCHEADRT(I,J) = RT_DOMAIN(did)%SFCHEADAGGRT &
+                                          / (nlst_rt(did)%AGGFACTRT**2)
+
+            do KRT=1,nlst_rt(did)%NSOIL
+!DJG              SMC(I,J,KRT)=SMCAGGRT(KRT)/(AGGFACTRT**2)
+               RT_DOMAIN(did)%SH2OX(I,J,KRT) = RT_DOMAIN(did)%SH2OAGGRT(KRT) &
+                                             / (nlst_rt(did)%AGGFACTRT**2)
+            end do
+
+
+
+!DJG Calculate subgrid weighting array...
+
+              do AGGFACYRT=nlst_rt(did)%AGGFACTRT-1,0,-1
+                do AGGFACXRT=nlst_rt(did)%AGGFACTRT-1,0,-1
+                  IXXRT=I*nlst_rt(did)%AGGFACTRT-AGGFACXRT
+                  JYYRT=J*nlst_rt(did)%AGGFACTRT-AGGFACYRT
+#ifdef MPP_LAND
+       if(left_id.ge.0) IXXRT=IXXRT+1
+       if(down_id.ge.0) JYYRT=JYYRT+1
+#else
+!yw ???
+!       IXXRT=IXXRT+1
+!       JYYRT=JYYRT+1
+#endif
+                  if (RT_DOMAIN(did)%LSMVOL.gt.0.) then
+                    RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) &
+                                          = RT_DOMAIN(did)%SFCHEADSUBRT(IXXRT,JYYRT) &
+                                          * RT_DOMAIN(did)%dist(IXXRT,JYYRT,9) &
+					  / RT_DOMAIN(did)%LSMVOL
+                  else
+                    RT_DOMAIN(did)%INFXSWGT(IXXRT,JYYRT) &
+                                          = 1./FLOAT(nlst_rt(did)%AGGFACTRT**2)
+                  end if
+
+                  do KRT=1,nlst_rt(did)%NSOIL
+
+!!!yw added for debug
+                   if(RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .lt. 0) then
+#ifndef NCEP_WCOSS
+                      print*, "Error negative SMCRT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT)
+#else
+                      write(78,*) "WARNING: negative SMCRT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT)
+#endif
+                   endif
+                   if(RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) .lt. 0) then
+#ifndef NCEP_WCOSS
+                      print *, "Error negative SH2OWGT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT)
+#else
+                      write(78,*) "WARNING: negative SH2OWGT", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT)
+#endif
+                   endif
+
+!end 
+                    IF (RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) .GT. &
+                        RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT)) THEN
+
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+                      print *, "SMCMAX exceeded upon aggregation...", &
+                           RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),  &
+                           RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT)
+#else
+                     write(78,*) "FATAL ERROR: SMCMAX exceeded upon aggregation...", &
+                           RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),  &
+                           RT_DOMAIN(did)%SMCMAXRT(IXXRT,JYYRT,KRT) 
+#endif
+#endif
+                      call hydro_stop("In module_HYDRO_drv.F aggregateDomain() - "// &
+                                      "SMCMAX exceeded upon aggregation.")
+                    END IF
+                    IF(RT_DOMAIN(did)%SH2OX(I,J,KRT).LT.0.) THEN
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+                      print *, "Erroneous value of SH2O...", &
+                                RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT
+                      print *, "Error negative SH2OX", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT)
+#else
+                     write(78,*) "Erroneous value of SH2O...", &
+                                RT_DOMAIN(did)%SH2OX(I,J,KRT),I,J,KRT
+                      write(78,*) "FATAL ERROR: negative SH2OX", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT)
+#endif
+#endif
+                      call hydro_stop("In module_HYDRO_drv.F aggregateDomain() "// &
+                                      "- Error negative SH2OX")
+                    END IF
+
+		    IF ( RT_DOMAIN(did)%SH2OX(I,J,KRT) .gt. 0 ) THEN
+                    	RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) &
+                                 = RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT) &
+                                 / RT_DOMAIN(did)%SH2OX(I,J,KRT)
+                    ELSE
+#ifdef HYDRO_D
+                         print *, "Error zero SH2OX", RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT), RT_DOMAIN(did)%SMCRT(IXXRT,JYYRT,KRT),RT_DOMAIN(did)%SH2OX(I,J,KRT)
+#endif
+                         RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = 0.0
+                    ENDIF
+!?yw
+                    RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT) = max(1.0E-05, RT_DOMAIN(did)%SH2OWGT(IXXRT,JYYRT,KRT))
+                  end do
+
+                end do
+              end do
+
+         end do
+        end do
+
+        
+#ifdef MPP_LAND
+        call MPP_LAND_COM_REAL(RT_DOMAIN(did)%INFXSWGT, &
+                               RT_DOMAIN(did)%IXRT,    &
+                               RT_DOMAIN(did)%JXRT, 99)
+	
+        do i = 1, nlst_rt(did)%NSOIL
+           call MPP_LAND_COM_REAL(RT_DOMAIN(did)%SH2OWGT(:,:,i), &
+                                  RT_DOMAIN(did)%IXRT, &
+				  RT_DOMAIN(did)%JXRT, 99)
+        end do
+#endif
+
+!DJG Update SMC with SICE (unchanged) and new value of SH2O from routing...
+	RT_DOMAIN(did)%SMC = RT_DOMAIN(did)%SH2OX + RT_DOMAIN(did)%SICE
+
+#ifdef HYDRO_D
+! ADCHANGE: START Final water balance variables
+! ALL VARS in MM
+        suminfxs2 = 0.
+        smctot2 = 0.
+        sicetot2 = 0.
+        do i=1,RT_DOMAIN(did)%IX
+         do j=1,RT_DOMAIN(did)%JX
+            suminfxs2 = suminfxs2 + RT_DOMAIN(did)%SFCHEADRT(I,J) &
+                               / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX)
+            do kk=1,nlst_rt(did)%NSOIL
+                smctot2 = smctot2 + RT_DOMAIN(did)%SMC(I,J,KK)*RT_DOMAIN(did)%SLDPTH(KK)*1000. &
+                               / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX)
+               sicetot2 = sicetot2 + RT_DOMAIN(did)%SICE(I,J,KK)*RT_DOMAIN(did)%SLDPTH(KK)*1000. &
+                                / float(RT_DOMAIN(did)%IX * RT_DOMAIN(did)%JX)
+            end do
+         end do
+        end do
+
+#ifdef MPP_LAND
+! not tested
+        CALL sum_real1(suminfxs2)
+        CALL sum_real1(smctot2)
+        CALL sum_real1(sicetot2)
+        suminfxs2 = suminfxs2/float(numprocs)
+        smctot2 = smctot2/float(numprocs)
+        sicetot2 = sicetot2/float(numprocs)
+#endif
+
+#ifdef MPP_LAND   
+       if (my_id .eq. IO_id) then
+#endif
+         print *, "Agg Mass Bal: "
+         print *, "WB_AGG!InfxsDiff", suminfxs2-suminfxsrt1
+         print *, "WB_AGG!Infxs1", suminfxsrt1
+         print *, "WB_AGG!Infxs2", suminfxs2
+         print *, "WB_AGG!SMCDiff", smctot2-smcrttot1-sicetot2
+         print *, "WB_AGG!SMC1", smcrttot1
+         print *, "WB_AGG!SMC2", smctot2
+         print *, "WB_AGG!SICE2", sicetot2
+         print *, "WB_AGG!Residual", (suminfxs2-suminfxsrt1) + &
+                         (smctot2-smcrttot1-sicetot2)
+#ifdef MPP_LAND 
+	endif
+#endif
+! END Final water balance variables
+#endif
+
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+ 	print *, "Finished Aggregation..."
+#else
+       write(78,*) "Finished Aggregation..."
+#endif
+#endif
+
+	
+      end subroutine aggregateDomain
+      
+      subroutine RunOffDisag(runoff1x_in, runoff1x, area_lsm,cellArea, infxswgt, AGGFACTRT, ix,jx)
+        implicit none
+        real, dimension(:,:) :: runoff1x_in, runoff1x, area_lsm, cellArea, infxswgt
+        integer :: i,j,ix,jx,AGGFACYRT, AGGFACXRT, AGGFACTRT, IXXRT, JYYRT
+
+        do J=1,JX
+        do I=1,IX
+             do AGGFACYRT=AGGFACTRT-1,0,-1
+             do AGGFACXRT=AGGFACTRT-1,0,-1
+               IXXRT=I*AGGFACTRT-AGGFACXRT
+               JYYRT=J*AGGFACTRT-AGGFACYRT
+#ifdef MPP_LAND
+       if(left_id.ge.0) IXXRT=IXXRT+1
+       if(down_id.ge.0) JYYRT=JYYRT+1
+#endif
+!DJG Implement subgrid weighting routine...
+               if( (runoff1x_in(i,j) .lt. 0) .or. (runoff1x_in(i,j) .gt. 1000) ) then
+                    runoff1x(IXXRT,JYYRT) = 0
+               else
+                    runoff1x(IXXRT,JYYRT)=runoff1x_in(i,j)*area_lsm(I,J)     &
+                        *INFXSWGT(IXXRT,JYYRT)/cellArea(IXXRT,JYYRT)
+               endif
+
+             enddo
+             enddo
+        enddo
+        enddo
+
+      end subroutine RunOffDisag
+      
+
+      subroutine HYDRO_ini(ntime, did,ix0,jx0, vegtyp,soltyp)
+        implicit none
+        integer ntime, did
+        integer rst_out, ix,jx
+!        integer, OPTIONAL:: ix0,jx0
+        integer:: ix0,jx0
+        integer, dimension(ix0,jx0),OPTIONAL :: vegtyp, soltyp
+
+
+#ifdef MPP_LAND
+    call  MPP_LAND_INIT()
+#endif
+
+
+! read the namelist
+! the lsm namelist will be read by rtland sequentially again.
+     call read_rt_nlst(nlst_rt(did) )
+
+     if(nlst_rt(did)%rtFlag .eq. 0) return
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! get the dimension 
+     call get_file_dimension(trim(nlst_rt(did)%geo_static_flnm), ix,jx)
+   
+       
+#ifdef MPP_LAND
+
+  if (nlst_rt(did)%sys_cpl .eq. 1 .or. nlst_rt(did)%sys_cpl .eq. 4) then
+!sys_cpl: 1-- coupling with HRLDAS but running offline lsm; 
+!         2-- coupling with WRF but do not run offline lsm  
+!         3-- coupling with LIS and do not run offline lsm  
+!         4:  coupling with CLM
+
+! create 2 dimensiaon logical mapping of the CPUs for coupling with CLM or HRLDAS.
+         call log_map2d()
+
+         global_nx = ix  ! get from land model
+         global_ny = jx  ! get from land model
+
+         call mpp_land_bcast_int1(global_nx)
+         call mpp_land_bcast_int1(global_ny)
+
+!!! temp set global_nx to ix 
+         rt_domain(did)%ix = global_nx
+         rt_domain(did)%jx = global_ny
+
+! over write the ix and jx
+         call MPP_LAND_PAR_INI(1,rt_domain(did)%ix,rt_domain(did)%jx,&
+              nlst_rt(did)%AGGFACTRT)
+   else  
+!  coupled with WRF, LIS
+         numprocs = node_info(1,1)
+
+         call wrf_LAND_set_INIT(node_info,numprocs,nlst_rt(did)%AGGFACTRT)
+
+
+         rt_domain(did)%ix = local_nx
+         rt_domain(did)%jx = local_ny
+   endif
+
+     
+
+      rt_domain(did)%g_IXRT=global_rt_nx
+      rt_domain(did)%g_JXRT=global_rt_ny
+      rt_domain(did)%ixrt = local_rt_nx
+      rt_domain(did)%jxrt = local_rt_ny
+
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+      write(6,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt"
+      write(6,*)  rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt
+      write(6,*) "rt_domain(did)%ix, rt_domain(did)%jx "
+      write(6,*) rt_domain(did)%ix, rt_domain(did)%jx 
+      write(6,*) "global_nx, global_ny, local_nx, local_ny"
+      write(6,*) global_nx, global_ny, local_nx, local_ny
+#else
+      write(78,*) "rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt"
+      write(78,*)  rt_domain(did)%g_IXRT, rt_domain(did)%g_JXRT, rt_domain(did)%ixrt, rt_domain(did)%jxrt
+      write(78,*) "rt_domain(did)%ix, rt_domain(did)%jx "
+      write(78,*) rt_domain(did)%ix, rt_domain(did)%jx 
+      write(78,*) "global_nx, global_ny, local_nx, local_ny"
+      write(78,*) global_nx, global_ny, local_nx, local_ny
+#endif
+#endif
+#else
+! sequential
+      rt_domain(did)%ix = ix
+      rt_domain(did)%jx = jx
+      rt_domain(did)%ixrt = ix*nlst_rt(did)%AGGFACTRT 
+      rt_domain(did)%jxrt = jx*nlst_rt(did)%AGGFACTRT
+#endif
+
+      
+!      allocate rt arrays
+
+
+       call getChanDim(did)
+
+
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+       write(6,*) "finish getChanDim "
+#else
+       write(78,*) "finish getChanDim "
+#endif
+#endif
+
+      if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then
+          call gw2d_allocate(did,&
+                             rt_domain(did)%ixrt,&
+                             rt_domain(did)%jxrt,&
+                             nlst_rt(did)%nsoil)
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+       write(6,*) "finish gw2d_allocate"
+#else
+       write(78,*) "finish gw2d_allocate"
+#endif
+#endif
+      endif
+
+! calculate the distance between grids for routing.
+! decompose the land parameter/data 
+
+
+!      ix0= rt_domain(did)%ix
+!      jx0= rt_domain(did)%jx
+      if(present(vegtyp)) then
+           call lsm_input(did,ix0=ix0,jx0=jx0,vegtyp0=vegtyp,soltyp0=soltyp)
+      else
+           call lsm_input(did,ix0=ix0,jx0=jx0)
+      endif
+
+
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+       write(6,*) "finish decomposion"
+#else
+       write(78,*) "finish decomposion"
+#endif
+#endif
+
+
+     call get_dist_lsm(did) 
+     call get_dist_lrt(did)
+
+
+! rt model initilization
+      call LandRT_ini(did)
+
+       
+      if(nlst_rt(did)%GWBASESWCRT .eq. 3 ) then
+	
+          call gw2d_ini(did,&
+                        nlst_rt(did)%dt,&
+                        nlst_rt(did)%dxrt0)
+#ifdef HYDRO_D                        
+#ifndef NCEP_WCOSS                      
+          write(6,*) "finish gw2d_ini"      
+#else
+          write(78,*) "finish gw2d_ini" 
+#endif
+#endif
+      endif
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+       write(6,*) "finish LandRT_ini"
+#else
+       write(78,*) "finish LandRT_ini" 
+#endif
+#endif
+
+    
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+     IF (nlst_rt(did)%TERADJ_SOLAR.EQ.1 .and. nlst_rt(did)%CHANRTSWCRT.NE.2) THEN   ! Perform ter rain adjustment of incoming solar
+#ifdef MPP_LAND
+          call MPP_seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,&
+             rt_domain(did)%TERRAIN, rt_domain(did)%dist_lsm,&
+             rt_domain(did)%ix,rt_domain(did)%jx,global_nx,global_ny)
+#else
+          call seq_land_SO8(rt_domain(did)%SO8LD_D,rt_domain(did)%SO8LD_Vmax,&
+                   rt_domain(did)%TERRAIN,rt_domain(did)%dist_lsm,&
+                   rt_domain(did)%ix,rt_domain(did)%jx)
+#endif
+    endif
+
+
+     IF (nlst_rt(did)%GWBASESWCRT .gt. 0) then
+        if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+            call get_basn_area_nhd(rt_domain(did)%basns_area)
+        else
+            call get_basn_area(did)
+        endif
+     endif
+
+     IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2 ) then
+        call get_node_area(did)
+     endif
+     
+
+#ifdef WRF_HYDRO_NUDGING
+     if(nlst_rt(did)%CHANRTSWCRT .ne. 0) call init_stream_nudging
+#endif
+
+
+!    if (trim(nlst_rt(did)%restart_file) == "") then
+! output at the initial time
+!        call HYDRO_out(did)
+!        return
+!    endif
+
+! restart the file
+
+        ! jummp the initial time output
+!        rt_domain(did)%out_counts = rt_domain(did)%out_counts + 1
+!        rt_domain(did)%his_out_counts = rt_domain(did)%his_out_counts + 1
+
+
+       call HYDRO_rst_in(did)
+
+       call HYDRO_out(did)
+
+      end subroutine HYDRO_ini
+
+      subroutine lsm_input(did,ix0,jx0,vegtyp0,soltyp0)
+         implicit none
+         integer did, leng
+         parameter(leng=100)
+         integer :: i,j, nn
+         integer, allocatable, dimension(:,:) :: soltyp
+         real, dimension(leng) :: xdum1, MAXSMC,refsmc,wltsmc
+
+        integer :: ix0,jx0
+        integer, dimension(ix0,jx0),OPTIONAL :: vegtyp0, soltyp0
+
+#ifdef HYDRO_D
+#ifndef NCEP_WCOSS
+         write(6,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx
+#else
+         write(78,*) RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx
+#endif
+#endif
+
+         allocate(soltyp(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx) )
+
+         soltyp = 0
+         call get2d_lsm_soltyp(soltyp,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm))
+
+
+         call get2d_lsm_real("HGT",RT_DOMAIN(did)%TERRAIN,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm))
+
+         call get2d_lsm_real("XLAT",RT_DOMAIN(did)%lat_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm))
+         call get2d_lsm_real("XLONG",RT_DOMAIN(did)%lon_lsm,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm))
+         call get2d_lsm_vegtyp(RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,trim(nlst_rt(did)%geo_static_flnm))
+
+
+
+            if(nlst_rt(did)%sys_cpl .eq. 2 ) then
+              ! coupling with WRF
+                if(present(soltyp0) ) then
+                   where(soltyp0 == 14) VEGTYP0 = 16
+                   where(VEGTYP0 == 16 ) soltyp0 = 14
+                   soltyp = soltyp0
+                   RT_DOMAIN(did)%VEGTYP = VEGTYP0
+                endif
+            endif
+
+         where(soltyp == 14) RT_DOMAIN(did)%VEGTYP = 16
+         where(RT_DOMAIN(did)%VEGTYP == 16 ) soltyp = 14
+
+! LKSAT, 
+! temporary set
+       RT_DOMAIN(did)%SMCRTCHK = 0
+       RT_DOMAIN(did)%SMCAGGRT = 0
+       RT_DOMAIN(did)%STCAGGRT = 0
+       RT_DOMAIN(did)%SH2OAGGRT = 0
+     
+
+       RT_DOMAIN(did)%zsoil(1:nlst_rt(did)%nsoil) = nlst_rt(did)%zsoil8(1:nlst_rt(did)%nsoil)
+
+       RT_DOMAIN(did)%sldpth(1) = abs( RT_DOMAIN(did)%zsoil(1) )
+       do i = 2, nlst_rt(did)%nsoil
+          RT_DOMAIN(did)%sldpth(i) = RT_DOMAIN(did)%zsoil(i-1)-RT_DOMAIN(did)%zsoil(i)
+       enddo
+       RT_DOMAIN(did)%SOLDEPRT = -1.0*RT_DOMAIN(did)%ZSOIL(nlst_rt(did)%NSOIL)
+
+!      input OV_ROUGH from OVROUGH.TBL
+#ifdef MPP_LAND
+       if(my_id .eq. IO_id) then
+#endif
+
+#ifndef NCEP_WCOSS
+       open(71,file="HYDRO.TBL", form="formatted") 
+!read OV_ROUGH first
+          read(71,*) nn
+          read(71,*)    
+          do i = 1, nn
+             read(71,*) RT_DOMAIN(did)%OV_ROUGH(i)
+          end do 
+!read parameter for LKSAT
+          read(71,*) nn
+          read(71,*)    
+          do i = 1, nn
+             read(71,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i)
+          end do 
+       close(71)
+#else
+       open(13, form="formatted")
+!read OV_ROUGH first
+          read(13,*) nn
+          read(13,*)    
+          do i = 1, nn
+             read(13,*) RT_DOMAIN(did)%OV_ROUGH(i)
+          end do 
+!read parameter for LKSAT
+          read(13,*) nn
+          read(13,*)    
+          do i = 1, nn
+             read(13,*) xdum1(i), MAXSMC(i),refsmc(i),wltsmc(i)
+          end do 
+       close(13)
+#endif
+
+#ifdef MPP_LAND
+       endif
+       call mpp_land_bcast_real(leng,RT_DOMAIN(did)%OV_ROUGH)
+       call mpp_land_bcast_real(leng,xdum1)
+       call mpp_land_bcast_real(leng,MAXSMC)
+       call mpp_land_bcast_real(leng,refsmc)
+       call mpp_land_bcast_real(leng,wltsmc)
+#endif
+
+       rt_domain(did)%lksat = 0.0
+       do j = 1, RT_DOMAIN(did)%jx
+             do i = 1, RT_DOMAIN(did)%ix
+                !yw rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) * 1000.0
+                rt_domain(did)%lksat(i,j) = xdum1(soltyp(i,j) ) 
+                IF(rt_domain(did)%VEGTYP(i,j) == 1 ) THEN   ! urban
+                    rt_domain(did)%SMCMAX1(i,j) = 0.45
+                    rt_domain(did)%SMCREF1(i,j) = 0.42
+                    rt_domain(did)%SMCWLT1(i,j) = 0.40
+                else
+                    rt_domain(did)%SMCMAX1(i,j) = MAXSMC(soltyp(I,J))
+                    rt_domain(did)%SMCREF1(i,j) = refsmc(soltyp(I,J))
+                    rt_domain(did)%SMCWLT1(i,j) = wltsmc(soltyp(I,J))
+                ENDIF
+             end do
+       end do
+
+
+       rt_domain(did)%soiltyp = soltyp
+       
+       if(allocated(soltyp)) deallocate(soltyp)
+
+
+      end subroutine lsm_input
+
+
+end module module_HYDRO_drv
+
+! stop the job due to the fatal error.
+      subroutine HYDRO_stop(msg)
+#ifdef MPP_LAND
+        use module_mpp_land
+#endif
+        character(len=*) :: msg
+        integer :: ierr
+        ierr = 1
+#ifndef NCEP_WCOSS
+!#ifdef HYDRO_D  !! PLEASE NEVER UNCOMMENT THIS IFDEF, it's just one incredibly useful string.
+      write(6,*) "The job is stopped due to the fatal error. ", trim(msg)
+      call flush(6)
+!#endif
+#else
+     write(78,*) "FATAL ERROR: ", trim(msg)
+      call flush(78)
+      close(78)
+#endif
+#ifdef MPP_LAND
+#ifndef HYDRO_D
+      print*, "---"
+      print*, "FATAL ERROR! Program stopped. Recompile with environment variable HYDRO_D set to 1 for enhanced debug information."
+      print*, ""
+#endif
+
+!        call mpp_land_sync()
+!        write(my_id+90,*) msg
+!        call flush(my_id+90)
+
+         call mpp_land_abort()
+         call MPI_finalize(ierr)
+#else
+         stop "FATAL ERROR: Program stopped. Recompile with environment variable HYDRO_D set to 1 for enhanced debug information."
+#endif
+
+     return
+     end  subroutine HYDRO_stop  
+
+
+! stop the job due to the fatal error.
+      subroutine HYDRO_finish()
+#ifdef MPP_LAND
+        USE module_mpp_land
+#endif
+#ifdef WRF_HYDRO_NUDGING
+        use module_stream_nudging,  only: finish_stream_nudging
+#endif
+        
+        integer :: ierr
+
+#ifdef WRF_HYDRO_NUDGING
+        call finish_stream_nudging()
+#endif
+#ifndef NCEP_WCOSS
+        print*, "The model finished successfully......."
+#else
+        write(78,*) "The model finished successfully......."
+#endif
+#ifdef MPP_LAND
+!         call mpp_land_abort()
+#ifndef NCEP_WCOSS
+         call flush(6)
+#else
+         call flush(78)
+         close(78)
+#endif
+         call mpp_land_sync()
+         call MPI_finalize(ierr)
+         stop
+#else
+
+#ifndef WRF_HYDRO_NUDGING
+         stop  !!JLM want to time at the top NoahMP level.
+#endif
+
+#endif
+
+        return
+      end  subroutine HYDRO_finish
diff --git a/wrfv2_fire/hydro/MPP/CPL_WRF.F b/wrfv2_fire/hydro/MPP/CPL_WRF.F
new file mode 100644
index 00000000..6cfb5799
--- /dev/null
+++ b/wrfv2_fire/hydro/MPP/CPL_WRF.F
@@ -0,0 +1,225 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+!   This is used as a coupler with the WRF model.
+MODULE MODULE_CPL_LAND
+
+  !use module_mpp_land, only: HYDRO_COMM_WORLD
+
+  IMPLICIT NONE
+
+  integer, public :: HYDRO_COMM_WORLD = -1
+  integer my_global_id
+ 
+  integer total_pe_num
+  integer global_ix,global_jx
+
+  integer,allocatable,dimension(:,:) :: node_info
+
+  logical initialized, cpl_land, time_step_read_rstart, &
+           time_step_write_rstart, time_step_output
+  character(len=19) cpl_outdate, cpl_rstdate
+
+  integer, public :: cartGridComm
+  integer, public :: np_up_down, np_left_right
+  integer, public :: p_up_down, p_left_right
+
+  contains
+
+  ! sets incoming communicator and then calls CPL_LAND_INIT
+  !subroutine CPL_LAND_INIT_COMM(istart,iend,jstart,jend,hydroCommunicator)
+  !  implicit none
+  !
+  !  integer :: istart,iend,jstart,jend
+  !  integer :: hydroCommunicator
+  !
+  !  HYDRO_COMM_WORLD = hydroCommunicator
+  !  call CPL_LAND_INIT(istart,iend,jstart,jend)
+  !end subroutine
+
+  subroutine CPL_LAND_INIT(istart,iend,jstart,jend)
+      implicit none
+   include "mpif.h"
+      integer ierr
+      logical mpi_inited
+      integer istart,iend,jstart,jend
+      
+      integer :: xx, ndim
+      integer, dimension(0:1) :: dims, coords
+      logical cyclic(0:1), reorder
+      data cyclic/.false.,.false./  ! not cyclic
+      data reorder/.false./   
+
+      CALL mpi_initialized( mpi_inited, ierr )
+      if ( .NOT. mpi_inited ) then
+          call mpi_init(ierr)
+          HYDRO_COMM_WORLD = MPI_COMM_WORLD
+      endif
+
+      call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_global_id, ierr )
+      call MPI_COMM_SIZE( HYDRO_COMM_WORLD, total_pe_num, ierr )
+
+      allocate(node_info(9,total_pe_num))
+
+      node_info = -99
+
+! send node info to node 0
+      node_info(1,my_global_id+1) = total_pe_num
+      node_info(6,my_global_id+1) = istart
+      node_info(7,my_global_id+1) = iend
+      node_info(8,my_global_id+1) = jstart
+      node_info(9,my_global_id+1) = jend
+
+
+      call send_info()
+      call find_left()
+      call find_right()
+      call find_up()
+      call find_down()
+
+      call send_info()
+
+      ! initialize cartesian grid communicator
+      dims(0) = 0
+      dims(1) = 0
+      do xx=1,total_pe_num
+	if(node_info(2,xx) .eq. (-1)) then
+	  dims(0) = dims(0)+1
+	endif
+	if(node_info(4,xx) .eq. (-1)) then
+	  dims(1) = dims(1)+1
+	endif
+      enddo
+      
+      ndim = 2
+      np_up_down = dims(0)
+      np_left_right = dims(1)
+
+      call MPI_Cart_create(HYDRO_COMM_WORLD, ndim, dims, &
+                          cyclic, reorder, cartGridComm, ierr)
+     
+      call MPI_CART_GET(cartGridComm, 2, dims, cyclic, coords, ierr)
+     
+      p_up_down = coords(0)
+      p_left_right = coords(1)
+
+      initialized = .false.  ! land model need to be initialized. 
+      return
+  END subroutine CPL_LAND_INIT
+
+     subroutine send_info()
+        implicit none
+   include "mpif.h"
+        integer,allocatable,dimension(:,:) :: tmp_info
+        integer  ierr, i,size, tag
+        integer mpp_status(MPI_STATUS_SIZE)
+        tag  = 9 
+        size =  9
+
+        if(my_global_id .eq. 0) then
+           do i = 1, total_pe_num-1 
+             call mpi_recv(node_info(:,i+1),size,MPI_INTEGER,  &
+                i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+           enddo
+        else
+           call mpi_send(node_info(:,my_global_id+1),size,   &
+               MPI_INTEGER,0,tag,HYDRO_COMM_WORLD,ierr)
+        endif 
+
+        call MPI_barrier( HYDRO_COMM_WORLD ,ierr)
+
+        size = 9 * total_pe_num
+        call mpi_bcast(node_info,size,MPI_INTEGER,   &
+            0,HYDRO_COMM_WORLD,ierr)
+
+        call MPI_barrier( HYDRO_COMM_WORLD ,ierr)
+
+     return
+     end  subroutine send_info
+
+     subroutine find_left()
+          implicit none
+          integer i
+          
+          node_info(2,my_global_id+1) = -1
+
+          do i = 1, total_pe_num 
+               if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. &
+                   (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. &
+                   ((node_info(7,i)+1).eq.node_info(6,my_global_id+1)) ) then
+                   node_info(2,my_global_id+1) = i - 1
+                   return
+               endif 
+          end do
+     return
+     end subroutine find_left
+
+     subroutine find_right()
+          implicit none
+          integer i
+          
+          node_info(3,my_global_id+1) = -1
+
+          do i = 1, total_pe_num 
+               if( (node_info(8,i).eq.node_info(8,my_global_id+1)) .and. &
+                   (node_info(9,i).eq.node_info(9,my_global_id+1)) .and. &
+                   ((node_info(6,i)-1).eq.node_info(7,my_global_id+1)) ) then
+                   node_info(3,my_global_id+1) = i - 1
+                   return
+               endif 
+          end do
+     return
+     end subroutine find_right
+
+     subroutine find_up()
+          implicit none
+          integer i
+          
+          node_info(4,my_global_id+1) = -1
+
+          do i = 1, total_pe_num 
+               if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. &
+                   (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. &
+                   ((node_info(8,i)-1).eq.node_info(9,my_global_id+1)) ) then
+                   node_info(4,my_global_id+1) = i - 1
+                   return
+               endif 
+          end do
+     return
+     end subroutine find_up
+
+     subroutine find_down()
+          implicit none
+          integer i
+          
+          node_info(5,my_global_id+1) = -1
+
+          do i = 1, total_pe_num 
+               if( (node_info(6,i).eq.node_info(6,my_global_id+1)) .and. &
+                   (node_info(7,i).eq.node_info(7,my_global_id+1)) .and. &
+                   ((node_info(9,i)+1).eq.node_info(8,my_global_id+1)) ) then
+                   node_info(5,my_global_id+1) = i - 1
+                   return
+               endif 
+          end do
+     return
+     end subroutine find_down
+
+END MODULE MODULE_CPL_LAND
diff --git a/wrfv2_fire/hydro/MPP/Makefile b/wrfv2_fire/hydro/MPP/Makefile
new file mode 100644
index 00000000..06333f58
--- /dev/null
+++ b/wrfv2_fire/hydro/MPP/Makefile
@@ -0,0 +1,39 @@
+# Makefile 
+#
+.SUFFIXES:
+.SUFFIXES: .o .F
+
+include ../macros
+
+OBJS =  CPL_WRF.o mpp_land.o module_mpp_ReachLS.o module_mpp_GWBUCKET.o
+
+all:	$(OBJS)
+mpp_land.o: mpp_land.F
+	@echo ""
+	$(RMD) $(*).o $(*).mod $(*).stb *~
+	$(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F
+	ar -r ../lib/libHYDRO.a $(@)
+
+CPL_WRF.o: CPL_WRF.F
+	@echo ""
+	$(RMD) $(*).o $(*).mod $(*).stb *~ *.f
+	$(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f
+	$(COMPILER90) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) $(*).f
+        
+	$(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F
+	ar -r ../lib/libHYDRO.a $(@)
+
+module_mpp_ReachLS.o: module_mpp_ReachLS.F
+	@echo ""
+	$(RMD) $(*).o $(*).mod $(*).stb *~
+	$(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F
+	ar -r ../lib/libHYDRO.a $(@)
+
+module_mpp_GWBUCKET.o: module_mpp_GWBUCKET.F
+	@echo ""
+	$(RMD) $(*).o $(*).mod $(*).stb *~
+	$(COMPILER90) $(F90FLAGS) $(LDFLAGS) -c $(*).F
+	ar -r ../lib/libHYDRO.a $(@)
+
+clean:
+	$(RMD) *.o *.mod *.stb *~
diff --git a/wrfv2_fire/hydro/MPP/module_mpp_GWBUCKET.F b/wrfv2_fire/hydro/MPP/module_mpp_GWBUCKET.F
new file mode 100644
index 00000000..c1d1f969
--- /dev/null
+++ b/wrfv2_fire/hydro/MPP/module_mpp_GWBUCKET.F
@@ -0,0 +1,236 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+!   This is used as a coupler with the WRF model.
+MODULE MODULE_mpp_GWBUCKET
+
+  use module_mpp_land, only:  io_id, my_id, mpp_status, mpp_land_max_int1, numprocs, &
+                 mpp_land_bcast_real, sum_real8,  mpp_land_sync
+  implicit none
+
+  
+
+  include "mpif.h"
+
+  integer,allocatable,dimension(:) :: sizeInd  ! size of Basins for each tile
+  integer ::  maxSizeInd
+
+  integer :: gw_ini
+
+  contains
+
+  subroutine gwbucket_ini()
+     allocate(sizeInd(numprocs))
+     sizeInd = 0
+     gw_ini = 99
+     maxSizeInd = 0
+  end subroutine gwbucket_ini
+
+ 
+  subroutine collectSizeInd(numbasns)
+     implicit none
+     integer, intent(in) :: numbasns
+     integer :: i, ierr, tag, rcv 
+
+      call mpp_land_sync()
+
+     if(gw_ini .ne. 99) call gwbucket_ini()
+
+     if(my_id .ne. IO_id) then
+          tag = 66 
+          call mpi_send(numbasns,1,MPI_INTEGER, IO_id,     &
+                tag,MPI_COMM_WORLD,ierr)
+     else
+          do i = 0, numprocs - 1
+              if(i .eq. IO_id) then
+                 sizeInd(i+1) = numbasns 
+              else
+                 tag = 66
+                 call mpi_recv(rcv,1,&
+                     MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr)
+
+                 sizeInd(i+1) = rcv
+              end if
+              if(sizeInd(i+1) .gt. maxSizeInd) maxSizeInd = sizeInd(i+1)
+          end do
+      end if
+  end subroutine collectSizeInd
+
+  subroutine gw_write_io_real(numbasns,inV,ind,outV)
+     implicit none
+     integer, intent(in) :: numbasns
+     integer :: i, ierr, tag, tag2,k
+     real,intent(in), dimension(numbasns) :: inV
+     integer,intent(in), dimension(numbasns) :: ind
+     real, dimension(:) :: outV
+     real, allocatable,dimension(:) :: vbuff
+     integer, allocatable,dimension(:) :: ibuff
+
+     if(gw_ini .ne. 99) then
+        stop "FATAL ERROR: mpp_GWBUCKET not initialized."        
+     endif 
+
+     if(my_id .eq. IO_id) then
+         outV = 0.0
+         allocate(vbuff(maxSizeInd))
+         allocate(ibuff(maxSizeInd))
+     else
+         allocate(vbuff(1))
+         allocate(ibuff(1))
+     endif
+
+     if(my_id .ne. IO_id) then
+        if(numbasns .gt. 0) then
+          tag = 62
+          call mpi_send(inV,numbasns,MPI_REAL, IO_id,     &
+                tag,MPI_COMM_WORLD,ierr)
+          tag2 = 63
+          call mpi_send(ind,numbasns,MPI_INTEGER, IO_id,     &
+                tag2,MPI_COMM_WORLD,ierr)
+        endif
+      else
+
+          do k = 1, numbasns
+              outV(ind(k)) = inV(k)  
+          end do
+
+          do i = 0, numprocs - 1
+            if(i .ne. IO_id) then
+               if(sizeInd(i+1) .gt. 0) then
+                  tag = 62
+                  call mpi_recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),&
+                      MPI_REAL,i,tag,MPI_COMM_WORLD,mpp_status,ierr)
+                  tag2 = 63
+                  call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),&
+                      MPI_INTEGER,i,tag2,MPI_COMM_WORLD,mpp_status,ierr)
+   
+                  do k = 1, sizeInd(i+1)
+                     outV(ibuff(k)) = vbuff(k) 
+                  end do
+               endif 
+             end if
+           end do
+      end if
+      if(allocated(ibuff)) deallocate(ibuff)
+      if(allocated(vbuff)) deallocate(vbuff)
+  end subroutine gw_write_io_real
+
+  subroutine gw_write_io_int(numbasns,inV,ind,outV)
+      implicit none
+      integer, intent(in) :: numbasns
+      integer :: i, ierr, tag, tag2,k
+      integer,intent(in), dimension(numbasns) :: inV
+      integer,intent(in), dimension(numbasns) :: ind
+      integer, dimension(:) :: outV
+      integer, allocatable,dimension(:) :: vbuff
+      integer, allocatable,dimension(:) :: ibuff
+ 
+      if(gw_ini .ne. 99) then
+         stop "FATAL ERROR: mpp_GWBUCKET not initialized."        
+      endif 
+ 
+      if(my_id .eq. IO_id) then
+          outV = 0.0
+          allocate(vbuff(maxSizeInd))
+          allocate(ibuff(maxSizeInd))
+      else
+          allocate(vbuff(1))
+          allocate(ibuff(1))
+      endif
+ 
+      if(my_id .ne. IO_id) then
+         if(numbasns .gt. 0) then
+           tag = 62
+           call mpi_send(inV,numbasns,MPI_INTEGER, IO_id,     &
+                 tag,MPI_COMM_WORLD,ierr)
+           tag2 = 63
+           call mpi_send(ind,numbasns,MPI_INTEGER, IO_id,     &
+                 tag2,MPI_COMM_WORLD,ierr)
+         endif
+       else
+ 
+           do k = 1, numbasns
+               outV(ind(k)) = inV(k)  
+           end do
+ 
+           do i = 0, numprocs - 1
+             if(i .ne. IO_id) then
+                if(sizeInd(i+1) .gt. 0) then
+                   tag = 62
+                   call mpi_recv(vbuff(1:sizeInd(i+1)),sizeInd(i+1),&
+                       MPI_INTEGER,i,tag,MPI_COMM_WORLD,mpp_status,ierr)
+                   tag2 = 63
+                   call mpi_recv(ibuff(1:sizeInd(i+1)),sizeInd(i+1),&
+                       MPI_INTEGER,i,tag2,MPI_COMM_WORLD,mpp_status,ierr)
+    
+                   do k = 1, sizeInd(i+1)
+                      outV(ibuff(k)) = vbuff(k) 
+                   end do
+                endif 
+              end if
+            end do
+       end if
+       deallocate(ibuff)
+       deallocate(vbuff)
+   end subroutine gw_write_io_int
+
+  subroutine gw_decompose_real(gnumbasns,numbasns,ind,inV,outV)
+     implicit none
+     integer, intent(in) :: numbasns, gnumbasns
+     integer :: i, ierr, tag, bas
+     real,intent(in), dimension(:) :: inV
+     integer,intent(in), dimension(:) :: ind
+     real, dimension(:) :: outV
+     real, dimension(gnumbasns) :: buff
+
+     outV = 0
+     if(gnumbasns .lt. 0) return
+
+     if(my_id .eq. io_id) buff = inV
+     call mpp_land_bcast_real(gnumbasns,buff)
+
+     do i = 1, numbasns
+        bas = ind(i)
+        outV(i) = buff(bas)
+     end do
+  end subroutine gw_decompose_real
+
+   subroutine gw_sum_real(vinout,nsize,gsize,ind)
+       implicit none
+       integer nsize,i,j,tag,ierr,gsize, k
+       real*8, dimension(nsize):: vinout
+       integer, dimension(nsize) :: ind
+       real*8, dimension(gsize) :: vbuff
+
+       vbuff = 0
+       do k = 1, nsize
+          vbuff(ind(k)) = vinout(k) 
+       end do
+       call sum_real8(vbuff,gsize)
+       do k = 1, nsize
+          vinout(k) = vbuff(ind(k)) 
+       end do
+    end subroutine gw_sum_real
+  
+
+
+end MODULE MODULE_mpp_GWBUCKET
+
+
diff --git a/wrfv2_fire/hydro/MPP/module_mpp_ReachLS.F b/wrfv2_fire/hydro/MPP/module_mpp_ReachLS.F
new file mode 100644
index 00000000..5434bba8
--- /dev/null
+++ b/wrfv2_fire/hydro/MPP/module_mpp_ReachLS.F
@@ -0,0 +1,1089 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+!   This is used as a coupler with the WRF model.
+MODULE MODULE_mpp_ReachLS
+
+  use module_mpp_land, only:  io_id, my_id, mpp_status, mpp_land_max_int1, mpp_land_sync, HYDRO_COMM_WORLD
+  implicit none
+
+
+  TYPE Grid2ReachMap
+      real,allocatable, dimension(:) :: sv
+      real,allocatable, dimension(:) :: rv
+      real,allocatable, dimension(:) :: rvId
+      real,allocatable, dimension(:) :: snId
+  end TYPE Grid2ReachMap
+
+  interface ReachLS_decomp
+     module procedure ReachLS_decompReal
+     module procedure ReachLS_decompInt 
+     module procedure ReachLS_decompChar
+  end interface
+
+  interface ReachLS_write_io
+     module procedure ReachLS_wReal
+     module procedure ReachLS_wReal2
+     module procedure ReachLS_wInt
+     module procedure ReachLS_wInt2
+     module procedure ReachLS_wChar
+  end interface
+
+  interface gBcastValue
+     module procedure gbcastReal
+     module procedure gbcastInt 
+     module procedure gbcastReal2
+  end interface
+
+  interface updateLinkV
+     module procedure updateLinkV8_mem
+     module procedure updateLinkV4_mem
+  end interface
+  
+
+
+  include "mpif.h"
+
+  integer,allocatable,dimension(:) :: sDataRec  ! sending data size
+  integer,allocatable,dimension(:) :: rDataRec  ! receiving data size
+  integer,allocatable,dimension(:) :: linkls_s  ! receiving data size
+  integer,allocatable,dimension(:) :: linkls_e  ! receiving data size
+  integer,allocatable,dimension(:) :: ToInd  ! size of toInd
+
+  integer ::  numprocs
+  integer, allocatable, dimension(:) :: LLINKIDINDX, aLinksl
+  integer :: LLINKLEN, gNlinksl, tmpnlinksl, l_nlinksl, max_nlinkSL
+
+  contains
+
+
+  subroutine updateLinkV8_mem(LinkV, outV)
+! for big memory data
+     implicit none
+     real, dimension(:) :: outV
+     real*8, dimension(:) :: LinkV
+     real, allocatable, dimension(:) :: gLinkV_r4
+     real*8, allocatable,dimension(:) ::  tmpBuf, gLinkV_r8
+     integer :: ierr, i, tag, k,m,lsize
+     integer, allocatable,dimension(:) :: lindex
+     if(my_id .eq. io_id) then
+           allocate(gLinkV_r4(gnlinksl))
+           allocate(gLinkV_r8(gnlinksl))
+           gLinkV_r4 = 0.0
+           gLinkV_r8 = 0.0
+           do i = 1, LLINKLEN
+               gLinkV_r8(LLINKIDINDX(i)) = LinkV(i)
+           end do
+     endif
+
+     if(my_id .ne. IO_id) then
+        
+          tag = 101
+          call mpi_send(LLINKLEN,1,MPI_INTEGER, IO_id,     &
+                tag,HYDRO_COMM_WORLD,ierr)
+          if(LLINKLEN .gt. 0) then
+              tag = 102
+              call mpi_send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id,     &
+                    tag,HYDRO_COMM_WORLD,ierr)
+              tag = 103
+              call mpi_send(LinkV,LLINKLEN,MPI_DOUBLE_PRECISION, IO_id,     &
+                   tag,HYDRO_COMM_WORLD,ierr)
+          endif
+      else   
+          do i = 0, numprocs - 1
+            if(i .ne. IO_id) then
+                tag = 101
+                call mpi_recv(lsize,1,MPI_INTEGER, i,     &
+                            tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                if(lsize .gt. 0) then
+                      allocate(lindex(lsize) )
+                      allocate(tmpBuf(lsize) )
+                      tag = 102
+                      call mpi_recv(lindex,lsize,MPI_INTEGER, i,     &
+                            tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                      tag = 103
+                      call mpi_recv(tmpBuf,lsize,&
+                            MPI_DOUBLE_PRECISION,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                      do k = 1, lsize
+                          gLinkV_r8(lindex(k)) = gLinkV_r8(lindex(k)) + tmpBuf(k)
+                      end do
+                      if(allocated(lindex)) deallocate(lindex)
+                      if(allocated(tmpBuf)) deallocate(tmpBuf)
+               endif
+            end if
+          end do
+          gLinkV_r4 = gLinkV_r8
+          if(allocated(gLinkV_r8)) deallocate(gLinkV_r8)
+      end if 
+
+      call ReachLS_decompReal(gLinkV_r4,outV)
+
+      if(my_id .eq. io_id) then
+         if(allocated(gLinkV_r4))  deallocate(gLinkV_r4)
+      endif
+  end subroutine updateLinkV8_mem
+
+  subroutine updateLinkV4_mem(LinkV, outV)
+! for big memory data
+     implicit none
+     real, dimension(:) :: outV
+     real, dimension(:) :: LinkV
+     real, allocatable, dimension(:) :: gLinkV_r4
+     real, allocatable,dimension(:) ::  tmpBuf
+     integer :: ierr, i, tag, k,m,lsize
+     integer, allocatable,dimension(:) :: lindex
+     if(my_id .eq. io_id) then
+           allocate(gLinkV_r4(gnlinksl))
+           gLinkV_r4 = 0.0
+           do i = 1, LLINKLEN
+               gLinkV_r4(LLINKIDINDX(i)) = LinkV(i)
+           end do
+     endif
+
+     if(my_id .ne. IO_id) then
+        
+          tag = 101
+          call mpi_send(LLINKLEN,1,MPI_INTEGER, IO_id,     &
+                tag,HYDRO_COMM_WORLD,ierr)
+          if(LLINKLEN .gt. 0) then
+              tag = 102
+              call mpi_send(LLINKIDINDX,LLINKLEN,MPI_INTEGER, IO_id,     &
+                    tag,HYDRO_COMM_WORLD,ierr)
+              tag = 103
+              call mpi_send(LinkV,LLINKLEN,MPI_REAL, IO_id,     &
+                   tag,HYDRO_COMM_WORLD,ierr)
+          endif
+      else   
+          do i = 0, numprocs - 1
+            if(i .ne. IO_id) then
+                tag = 101
+                call mpi_recv(lsize,1,MPI_INTEGER, i,     &
+                            tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                if(lsize .gt. 0) then
+                      allocate(lindex(lsize) )
+                      allocate(tmpBuf(lsize) )
+                      tag = 102
+                      call mpi_recv(lindex,lsize,MPI_INTEGER, i,     &
+                            tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                      tag = 103
+                      call mpi_recv(tmpBuf,lsize,&
+                            MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                      do k = 1, lsize
+                          gLinkV_r4(lindex(k)) = gLinkV_r4(lindex(k)) + tmpBuf(k)
+                      end do
+                      if(allocated(lindex)) deallocate(lindex)
+                      if(allocated(tmpBuf)) deallocate(tmpBuf)
+               endif
+            end if
+          end do
+      end if 
+
+      call ReachLS_decompReal(gLinkV_r4,outV)
+
+      if(my_id .eq. io_id) then
+          if(allocated(gLinkV_r4)) deallocate(gLinkV_r4)
+      endif
+  end subroutine updateLinkV4_mem
+
+
+  subroutine updateLinkV8(LinkV, outV)
+     implicit none
+     real, dimension(:) :: outV 
+     real*8, dimension(:) :: LinkV
+     real*8, dimension(gNlinksl) :: gLinkV,gLinkV_r
+     real, dimension(gNlinksl) :: gLinkV_r4
+     integer :: ierr, i, tag
+     gLinkV = 0.0
+     gLinkV_r = 0.0
+     do i = 1, LLINKLEN 
+         gLinkV(LLINKIDINDX(i)) = LinkV(i)
+     end do
+
+     if(my_id .ne. IO_id) then
+          tag = 102
+          call mpi_send(gLinkV,gnlinksl,MPI_DOUBLE_PRECISION, IO_id,     &
+                tag,HYDRO_COMM_WORLD,ierr)
+      else
+          gLinkV_r = gLinkV 
+          do i = 0, numprocs - 1
+            if(i .ne. IO_id) then
+               tag = 102
+               call mpi_recv(gLinkV,gnlinksl,&
+                   MPI_DOUBLE_PRECISION,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               gLinkV_r = gLinkV_r + gLinkV
+            end if
+          end do
+      end if
+      gLinkV_r4 = gLinkV_r
+
+      call ReachLS_decompReal(gLinkV_r4,outV)      
+  end subroutine updateLinkV8
+
+  subroutine updateLinkV4(LinkV, outV)
+     implicit none
+     real, dimension(:) :: outV  
+     real, dimension(:) :: LinkV
+     real, dimension(gNlinksl) :: gLinkV,gLinkV_r
+     real, dimension(gNlinksl) :: gLinkV_r4
+     integer :: ierr, i, tag
+     gLinkV = 0.0 
+     gLinkV_r = 0.0
+     do i = 1, LLINKLEN
+         gLinkV(LLINKIDINDX(i)) = LinkV(i)
+     end do
+
+     if(my_id .ne. IO_id) then
+          tag = 102
+          call mpi_send(gLinkV,gnlinksl,MPI_REAL, IO_id,     &
+                tag,HYDRO_COMM_WORLD,ierr)
+      else
+          gLinkV_r = gLinkV    
+          do i = 0, numprocs - 1
+            if(i .ne. IO_id) then
+               tag = 102
+               call mpi_recv(gLinkV,gnlinksl,&
+                   MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               gLinkV_r = gLinkV_r + gLinkV
+            end if
+          end do
+      end if
+      gLinkV_r4 = gLinkV_r
+      call ReachLS_decompReal(gLinkV_r4,outV)
+  end subroutine updateLinkV4
+
+  subroutine gbcastReal(inV, outV)
+     implicit none
+     real, dimension(:) :: outV
+     real, dimension(:) :: inV  
+     integer :: ierr
+     call ReachLS_write_io(inV,outV)
+     call mpi_bcast(outV(1:gnlinksl),gnlinksl,MPI_REAL,   &
+            IO_id,HYDRO_COMM_WORLD,ierr) 
+  end subroutine gbcastReal
+
+  subroutine gbcastReal2_old(index,size1,inV, insize, outV)
+     implicit none
+     integer :: size1, insize
+     integer,dimension(:) :: index
+     real, dimension(:) :: outV
+     real, dimension(:) :: inV  
+     real, dimension(max_nlinkSL) :: tmpV  
+     integer :: ierr, k, i, m, j, bsize
+     outV = 0
+     do i = 0, numprocs -1
+            bsize = linkls_e(i+1) - linkls_s(i+1) + 1
+         if(linkls_e(i+1) .gt. 0) then
+            if(my_id .eq. i) tmpV(1:bsize) = inV(1:bsize)
+            call mpi_bcast(tmpV(1:bsize),bsize,MPI_REAL,   &
+                i,HYDRO_COMM_WORLD,ierr) 
+            do j = 1, size1
+                do k = 1, bsize
+                   if(index(j) .eq. (linkls_s(i+1) + k -1) ) then
+                      outV(j) = tmpV(k)
+                      goto  100
+                   endif
+                end do
+ 100            continue
+            end do
+
+         endif
+     end do
+  end subroutine gbcastReal2_old
+
+  subroutine gbcastReal2(index,size1,inV, insize, outV)
+     implicit none
+     integer :: size1, insize
+     integer,dimension(:) :: index
+     real, dimension(:) :: outV
+     real, dimension(:) :: inV
+!     real, dimension(max_nlinkSL) :: tmpV
+     real, dimension(gnlinksl) :: gbuf
+     integer :: ierr, k, i, m, j, bsize
+     outV = 0
+     call ReachLS_write_io(inV,gbuf)
+     call mpi_bcast(gbuf,gnlinksl,MPI_REAL,   &
+            IO_id,HYDRO_COMM_WORLD,ierr) 
+     do j = 1, size1
+        outV(j) = gbuf(index(j))
+     end do
+  end subroutine gbcastReal2
+
+
+
+
+  subroutine gbcastInt(inV, outV)
+     implicit none
+     integer, dimension(:) :: outV
+     integer, dimension(:) :: inV  
+     integer :: ierr
+     call ReachLS_write_io(inV,outV)
+     call mpi_bcast(outV(1:gnlinksl),gnlinksl,MPI_INTEGER,   &
+            IO_id,HYDRO_COMM_WORLD,ierr) 
+  end subroutine gbcastInt 
+
+
+  subroutine getLocalIndx(glinksl,LINKID, LLINKID)
+       implicit none
+       integer, dimension(:) :: LINKID, LLINKID
+       integer :: i,k, glinksl, ierr
+       integer :: gLinkId(glinksl)
+       LLINKLEN = size(LLINKID,1)
+       allocate(LLINKIDINDX(LLINKLEN))
+       LLINKIDINDX = 0
+       gNlinksl = glinksl
+
+       call ReachLS_write_io(LINKID,gLinkId)
+
+       call mpi_bcast(gLinkId(1:glinksl),glinksl,MPI_INTEGER,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+
+       do i = 1, LLINKLEN
+           do k = 1, glinksl
+               if(LLINKID(i) .eq. gLinkId(k)) then
+                    LLINKIDINDX(i) = k
+                    goto 1001
+               endif
+           end do
+1001       continue
+       end do 
+       
+       call mpp_land_sync()
+  end subroutine getLocalIndx
+
+  subroutine ReachLS_ini(glinksl,nlinksl,linklsS, linklsE)
+     implicit none
+     integer, intent(in) :: glinksl
+     integer, intent(out) :: nlinksl, linklsS, linklsE
+     integer :: i, ii, ierr
+
+! get my_id and numprocs 
+     call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr )
+     call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr )
+
+
+     nlinksl = glinksl / numprocs 
+     allocate(linkls_s(numprocs))
+     allocate(linkls_e(numprocs))
+     allocate(aLinksl(numprocs))
+     allocate(ToInd(numprocs))
+     
+     ToInd = -1
+
+     linkls_s(1) = 1
+     linkls_e(1) = nlinksl
+     aLinksl = nlinksl
+
+     do i = 2, mod(glinksl, numprocs)+1
+         aLinksl(i) = aLinksl(i) + 1
+     end do
+     do i = 2, numprocs
+        linkls_s(i) = linkls_e(i-1)+1
+        linkls_e(i) = linkls_s(i) + aLinksl(i)-1
+     end do
+
+     nlinksl = aLinksl(my_id+1) 
+     
+     linklsS = linkls_s(my_id+1)
+     linklsE = linkls_e(my_id+1)
+     tmpnlinksl = aLinksl(my_id+1) 
+     l_nlinksl = nlinksl
+
+     max_nlinksl = l_nlinksl
+     call mpp_land_max_int1(max_nlinksl)
+     
+     gNlinksl = glinksl
+  end subroutine ReachLS_ini
+  
+  subroutine MapGrid2ReachIni(in2d)
+     implicit none
+     integer, intent(in),dimension(:,:) :: in2d 
+     integer :: ix, jx, i,j,n,ntotal, ierr
+     integer, dimension(numprocs) :: tmpS
+
+     allocate(sDataRec(numprocs))
+     allocate(rDataRec(numprocs))
+     
+     ntotal = 0
+     sDataRec = 0
+     rDataRec = 0
+     ix = size(in2d,1)
+     jx = size(in2d,2)
+     do j = 1, jx
+        do i = 1, ix
+           if(in2d(i,j) .gt. 0) then
+              do n = 1, numprocs
+                  if((in2d(i,j) .ge. linkls_s(n)) .and. (in2d(i,j) .le. linkls_e(n)) ) then
+                              sDataRec(n) = sDataRec(n) + 1
+                  endif
+              end do
+           endif
+        enddo
+     enddo   
+
+     do n = 1, numprocs
+         if(my_id .eq. n-1) then
+             tmpS = sDataRec
+         endif
+         call mpi_bcast(tmpS,numprocs,MPI_INTEGER,   &
+            n-1,HYDRO_COMM_WORLD,ierr)
+         rDataRec(n) = tmpS(n)
+     enddo
+    
+  end subroutine MapGrid2ReachIni
+
+
+  subroutine ReachLS_decompReal(inV,outV)
+      implicit none
+      real,INTENT(in),dimension(:) :: inV
+      real,INTENT(out),dimension(:) :: outV
+      integer ::  i, ierr, tag
+      tag = 11
+      if(my_id .eq. io_id) then
+         do i = 1, numprocs
+            if(i-1 .eq. io_id) then
+                if(alinksl(i) .gt. 0) then
+                   outV(1:(linkls_e(i)-linkls_s(i)+1) ) = inV(linkls_s(i):linkls_e(i))
+                endif
+            else
+                if(aLinksl(i) .gt. 0) then
+                    call mpi_send(inV(linkls_s(i):linkls_e(i)), &
+                        aLinksl(i), &
+                        MPI_REAL, i-1 ,tag,HYDRO_COMM_WORLD,ierr)
+                endif
+            endif
+         end do
+      else
+         if(aLinksl(my_id+1) .gt. 0) then
+             call mpi_recv(outV(1:(linkls_e(my_id+1)-linkls_s(my_id+1)+1) ), &  !! this one has +1!
+              aLinksl(my_id+1),                                        &
+              MPI_REAL, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+         endif
+      endif
+      call mpp_land_sync()
+  END subroutine ReachLS_decompReal
+
+  subroutine ReachLS_decompInt(inV,outV)
+      implicit none
+      integer,INTENT(in),dimension(:) :: inV
+      integer,INTENT(out),dimension(:) :: outV
+      integer ::  i, ierr, tag
+      tag = 11
+      if(my_id .eq. io_id) then
+         do i = 1, numprocs
+            if(i-1 .eq. io_id) then
+                if(alinksl(i) .gt. 0) then
+                    outV(1:linkls_e(i)-linkls_s(i)+1) = inV(linkls_s(i):linkls_e(i))
+                endif
+            else
+               if(aLinksl(i) .gt. 0) then
+                  call mpi_send(inV(linkls_s(i):linkls_e(i)), &
+                      aLinksl(i),                &
+                      MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,ierr)
+               endif
+            endif
+         end do
+      else
+          if(aLinksl(my_id+1) .gt. 0) then
+               call mpi_recv(outV(1:linkls_e(my_id+1)-linkls_s(my_id+1)+1), &
+                    alinksl(my_id+1),                           &
+                    MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+          endif
+     endif
+
+      call mpp_land_sync()
+
+  END subroutine ReachLS_decompInt
+
+
+  subroutine ReachLS_decompChar(inV,outV)
+     implicit none
+     character(len=*),intent(in), dimension(:) :: inV
+     character(len=*),intent(out),dimension(:) :: outV
+     integer ::  i, ierr, tag
+     integer :: strLen
+     strLen = len(inV(1))
+     tag = 11
+     if(my_id .eq. io_id) then
+        do i = 1, numprocs
+           if(i-1 .eq. io_id) then
+              if(alinksl(i) .gt. 0) then
+                 outV(1:(linkls_e(i)-linkls_s(i)+1)) = inV(linkls_s(i):linkls_e(i))
+              endif
+           else
+              if(aLinksl(i) .gt. 0) then
+                 ! The mpi_send takes what you give it and THEN treats each caracter as an array element.
+                 call mpi_send(inV(linkls_s(i):linkls_e(i)),       &
+                      aLinksl(i),                           &
+                      MPI_CHARACTER, i-1, tag, HYDRO_COMM_WORLD, ierr)
+              endif
+           endif
+        end do
+     else
+        if(aLinksl(my_id+1) .gt. 0) then
+           ! The mpi_recv treats each caracter as an array element.
+           call mpi_recv(outV(1 : ((linkls_e(my_id+1)-linkls_s(my_id+1)+1)) ), &  !jlm should have +1
+                alinksl(my_id+1),                                              &
+                MPI_CHARACTER, io_id, tag, HYDRO_COMM_WORLD, mpp_status,ierr            )
+        endif
+     endif
+     call mpp_land_sync()
+  end subroutine ReachLS_decompChar
+     
+     
+  subroutine ReachLS_wReal(inV,outV)
+      implicit none
+      real,INTENT(in),dimension(:) :: inV
+      real,INTENT(out),dimension(:) :: outV
+      integer :: i, ierr, tag, ss  , mm
+      outV = 0
+      if(my_id .eq. io_id) then
+         do i = 1, numprocs
+            tag = 12
+            if(i-1 .eq. io_id) then
+                if(alinksl(i) .gt. 0) then
+                   outV(linkls_s(i):linkls_e(i)) = inV(1:linkls_e(i)-linkls_s(i)+1)
+                endif
+            else
+                if(aLinksl(i) .gt. 0) then
+
+                    call mpi_recv(outV(linkls_s(i):linkls_e(i)), &
+                         aLinksl(i),                            &
+                         MPI_REAL,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                endif
+            endif
+         end do
+      else
+          if(aLinksl(my_id+1) .gt. 0) then
+               tag = 12
+               ss = size(inv,1)
+               call mpi_send(inV(1:aLinksl(my_id+1) ), &
+                      aLinksl(my_id+1),                      &
+                      MPI_REAL,io_id,tag,HYDRO_COMM_WORLD,ierr)
+          endif
+      endif
+      call mpp_land_sync()
+  END subroutine ReachLS_wReal
+
+  subroutine ReachLS_wInt(inV,outV)
+      implicit none
+      integer,INTENT(in),dimension(:) :: inV
+      integer,INTENT(out),dimension(:) :: outV
+      integer :: i, ierr, tag
+      outV = 0
+      if(my_id .eq. io_id) then
+         do i = 1, numprocs
+            if(i-1 .eq. io_id) then
+                if(alinksl(i) .gt. 0) then
+                   outV(linkls_s(i):linkls_e(i)) = inV(1:linkls_e(i)-linkls_s(i)+1)
+                endif
+            else
+               if(aLinksl(i) .gt. 0) then
+                  tag = 12
+                  call mpi_recv(outV(linkls_s(i):linkls_e(i)), &
+                       aLinksl(i),                             &
+                       MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               endif
+            endif
+         end do
+      else
+           if(aLinksl(my_id+1) .gt. 0) then
+                tag = 12
+                call mpi_send(inV(1:aLinksl(my_id+1) ), &
+                      aLinksl(my_id+1),                      &
+                      MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr)
+           endif
+      endif
+      call mpp_land_sync()
+  END subroutine ReachLS_wInt 
+
+
+  subroutine ReachLS_wInt2(inV,outV,len,glen)
+      implicit none
+      integer  :: len, glen
+      integer,INTENT(in),dimension(len) :: inV
+      integer,INTENT(out),dimension(glen) :: outV
+      integer :: i, ierr, tag
+      outV = 0
+      if(my_id .eq. io_id) then
+         do i = 1, numprocs
+            if(i-1 .eq. io_id) then
+                if(alinksl(i) .gt. 0) then
+                   outV(linkls_s(i):linkls_e(i)) = inV(1:linkls_e(i)-linkls_s(i)+1)
+                endif
+            else
+               if(aLinksl(i) .gt. 0) then
+                  tag = 12
+                  call mpi_recv(outV(linkls_s(i):linkls_e(i)), &
+                       aLinksl(i),                             &
+                       MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               endif
+            endif
+         end do
+      else
+           if(aLinksl(my_id+1) .gt. 0) then
+                tag = 12
+                call mpi_send(inV(1:aLinksl(my_id+1) ), &
+                      aLinksl(my_id+1),                      &
+                      MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr)
+           endif
+      endif  
+      call mpp_land_sync()
+  END subroutine ReachLS_wInt2
+
+  subroutine ReachLS_wReal2(inV,outV,len,glen)
+      implicit none
+      integer :: len, glen
+      real,INTENT(in),dimension(len) :: inV
+      real,INTENT(out),dimension(glen) :: outV
+      integer :: i, ierr, tag
+      outV = 0
+      if(my_id .eq. io_id) then
+         do i = 1, numprocs
+            if(i-1 .eq. io_id) then
+                if(alinksl(i) .gt. 0) then
+                   outV(linkls_s(i):linkls_e(i)) = inV(1:linkls_e(i)-linkls_s(i)+1)
+                endif
+            else
+                if(aLinksl(i) .gt. 0) then
+                    tag = 12
+                    call mpi_recv(outV(linkls_s(i):linkls_e(i)), &
+                         aLinksl(i),                            &
+                         MPI_REAL,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                endif
+            endif
+         end do
+      else
+          if(aLinksl(my_id+1) .gt. 0) then
+               tag = 12
+               call mpi_send(inV(1:aLinksl(my_id+1) ), &
+                      aLinksl(my_id+1),                      &
+                      MPI_REAL,io_id,tag,HYDRO_COMM_WORLD,ierr)
+          endif
+      endif
+      call mpp_land_sync()   
+  END subroutine ReachLS_wReal2
+
+  subroutine ReachLS_wChar(inV,outV)
+     implicit none
+     character(len=*), intent(in), dimension(:)  :: inV
+     character(len=*) ,intent(out),dimension(:) :: outV
+     integer :: i, ierr, tag
+     integer :: strLen
+     strLen = len(inV(1))
+     if(my_id .eq. io_id) then
+        do i = 1, numprocs
+           if(i-1 .eq. io_id) then
+              if(alinksl(i) .gt. 0) then
+                 outV(linkls_s(i):linkls_e(i)) = inV(1:linkls_e(i)-linkls_s(i)+1)
+              endif
+           else
+              if(aLinksl(i) .gt. 0) then
+                 tag = 12
+                 ! ? seems asymmetric with ReachLS_decompChar
+                 call mpi_recv(outV( linkls_s(i) : linkls_e(i) ), &
+!                 call mpi_recv(outV( ((linkls_s(i)-1)+1) : (linkls_e(i)) ), &
+                      aLinksl(i),                                                  &
+                      MPI_CHARACTER, i-1, tag, HYDRO_COMM_WORLD, mpp_status, ierr           )
+              endif
+           endif
+        end do
+     else
+        if(aLinksl(my_id+1) .gt. 0) then
+           tag = 12
+           ! The mpi_send takes what you give it and THEN treats each caracter as an array element.
+           call mpi_send(inV(1:aLinksl(my_id+1)),              &
+                aLinksl(my_id+1),                       &
+                MPI_CHARACTER, io_id, tag, HYDRO_COMM_WORLD, ierr)
+        endif
+     endif
+     call mpp_land_sync()   
+  end subroutine ReachLS_wChar
+
+
+  subroutine getFromInd(linkid,to,ind,indLen)
+      integer,dimension(:) :: linkid, to
+      integer, allocatable, dimension(:) ::ind
+      integer :: k, m, kk, mm,indLen
+      integer, dimension(gnlinksl) :: glinkid   
+      call ReachLS_write_io(linkid,glinkid)
+      mm = size(to,1)
+      kk = 0
+      do k = 1, gnlinksl
+          do m = 1, mm
+             if(glinkid(k) .eq. to(m) ) then
+                 kk = kk +1
+                 goto 2001
+             endif
+          end do
+2001      continue
+      end do
+      allocate(ind(kk))
+      kk = 0
+      do k = 1, gnlinksl
+          do m = 1, mm
+             if(glinkid(k) .eq. to(m) ) then
+                 kk = kk +1
+                 ind(kk) = glinkid(k)
+                 goto 2002
+             endif
+          end do
+2002      continue
+      end do
+      indLen = kk      
+
+  end subroutine getFromInd
+
+  subroutine getToInd(from,to,ind,indLen,gToNodeOut)
+      integer,dimension(:) :: from, to
+      integer, allocatable, dimension(:) ::ind
+      integer, allocatable, dimension(:,:) :: gToNodeOut
+      integer :: k, m, kk, mm,indLen, i, ierr
+      integer, dimension(gnlinksl) :: gto
+      integer:: maxNum,num
+
+      call gBcastValue(to,gto)
+
+!      mm = size(from,1)
+       mm = l_nlinksl
+ 
+      maxNum = 0
+
+      kk = 0 
+      do m = 1, mm
+          num = 0
+          do k = 1, gnlinksl
+             if(gto(k) .eq. from(m) ) then
+                 kk = kk +1
+                 num = num + 1
+             endif
+          end do
+          if(num .gt. maxNum) maxNum = num
+      end do 
+
+      allocate(ind(kk))
+      allocate(gToNodeOut(mm,maxNum+1))
+      gToNodeOut = -99
+
+      indLen = kk
+
+      kk = 0 
+      do m = 1, mm
+         num = 1
+         do k = 1, gnlinksl
+             if(gto(k) .eq. from(m) ) then
+                 kk = kk +1
+                 !yw ind(kk) = gto(k)
+                 ind(kk) = k
+                 !! gToNodeOut(m,num+1) = gto(k)
+                 gToNodeOut(m,num+1) = kk
+                 gToNodeOut(m,1) = num
+                 num = num + 1
+             endif
+          end do
+      end do 
+      ToInd(my_id+1) = kk
+      do i = 0, numprocs - 1
+         call mpi_bcast(ToInd(i+1),1,MPI_INTEGER,   &
+            i,HYDRO_COMM_WORLD,ierr)
+      end do
+
+  end subroutine getToInd
+
+  subroutine com_decomp1dInt(inV,gsize,outV,lsize)
+!     output outV and lsize
+      implicit none
+      integer,INTENT(in),dimension(:) :: inV
+      integer,allocatable,dimension(:) :: outV
+      integer ::  i, ierr, tag, imod, ncomsize
+      integer :: lsize, ssize,start, gsize, end
+      tag = 19
+      ncomsize = gsize/numprocs
+      imod = mod(gsize,numprocs)
+
+
+      if(my_id .eq. io_id) then
+         start = 0
+         end = 0
+         do i = 1, numprocs
+            if(i-1 .lt. imod) then
+                  ssize = ncomsize + 1
+            else
+                  ssize = ncomsize 
+            endif
+ 
+            start = end + 1 
+            end = start + ssize - 1
+
+            if(i-1 .eq. io_id) then
+                if(ssize .gt. 0) then
+                    allocate(outV(ssize) )
+                    outV(1:ssize) = inV(1:ssize)
+                    lsize = ssize
+                else
+                    lsize = 0    
+                endif
+            else
+                if(ssize .gt. 0 ) then  
+                   call mpi_send(inV(start:start+ssize-1), ssize,       &
+                      MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,ierr)
+                endif
+            endif
+         end do
+      else   
+              if(my_id .lt. imod) then
+                   lsize = ncomsize + 1
+              else
+                   lsize = ncomsize 
+              endif
+              if( lsize .gt. 0) then
+                  allocate(outV(lsize) )
+                  call mpi_recv(outV,lsize,                           &
+                        MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+              endif
+      endif
+      call mpp_land_sync()
+
+
+  END subroutine com_decomp1dInt
+
+  subroutine com_write1dInt(inV,lsize,outV,gsize)
+!     output outV and lsize
+      implicit none
+      integer,INTENT(in),dimension(:) :: inV
+      integer,dimension(:) :: outV
+      integer ::  i, ierr, tag, imod, ncomsize
+      integer :: lsize, rsize,start, gsize, end
+      tag = 18
+      ncomsize = gsize/numprocs
+      imod = mod(gsize,numprocs)
+
+      if(my_id .eq. io_id) then
+            start = 0
+            end = 0
+         do i = 1, numprocs
+            if(i-1 .lt. imod) then
+                  rsize = ncomsize + 1
+            else
+                  rsize = ncomsize 
+            endif
+
+            start = end + 1 
+            end = start + rsize - 1
+
+            if(i-1 .eq. io_id) then
+                if(rsize .gt. 0) then
+                    outV(1:rsize) = inV(1:rsize)
+                endif
+            else
+                if(rsize .gt. 0 ) then  
+                  call mpi_recv(outV(start:start+rsize-1), rsize,          &
+                        MPI_INTEGER, i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                endif
+            endif
+         end do
+      else   
+              if(my_id .lt. imod) then
+                   lsize = ncomsize + 1
+              else
+                   lsize = ncomsize 
+              endif
+              if( lsize .gt. 0) then
+                   call mpi_send(inV, lsize,       &
+                      MPI_INTEGER, io_id,tag,HYDRO_COMM_WORLD,ierr)
+              endif
+      endif
+
+      call mpp_land_sync()
+
+  END subroutine com_write1dInt 
+
+  subroutine pack_decomp_int(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid)
+     implicit none
+     integer :: ndata
+     integer, dimension(:) :: g1bufid,  nprocs_map, lnsizes, bufid
+     integer :: i,j,k, tag, ierr
+     integer, allocatable,dimension(:) :: buf
+     integer, dimension(:) :: istart
+     integer, dimension(numprocs) :: count
+     ! pack data
+
+
+     if(my_id .eq. io_id) then
+         allocate(buf(ndata))
+         count = 0
+         do i = 1, ndata
+            k = nprocs_map(i)
+            if( k .gt. 0) then
+               buf(istart(k) + count(k)) = g1bufid(i) 
+               count(k) = count(k) + 1
+            end if
+         end do
+!         write(6,*) " count = ", count
+!         write(6,*) " istart = ", istart
+!         write(6,*) " lnsizes = ", lnsizes
+      end if
+      !finish packing 
+
+      call mpp_land_sync()
+!      call hydro_finish()
+
+      if(my_id .ne. IO_id) then
+          tag = 72
+          if(lnsizes(my_id + 1) .gt. 0) then
+             call mpi_recv(bufid,lnsizes(my_id + 1),&
+                   MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+          endif
+      else
+          do i = 0, numprocs - 1
+            if(i .ne. my_id) then
+               tag = 72
+               if(lnsizes(i+1) .gt. 0) then
+                  call mpi_send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1),  &
+                      lnsizes(i+1),MPI_INTEGER,i, tag,HYDRO_COMM_WORLD,ierr)
+               endif
+            else
+                if(lnsizes(i+1) .gt. 0) then
+                   bufid = buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1)
+                endif
+            end if
+          end do
+       end if
+     if(my_id .eq. io_id) then 
+        if(allocated(buf)) deallocate(buf)
+     endif
+  end subroutine pack_decomp_int
+
+  subroutine pack_decomp_real8(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid)
+     implicit none
+     integer :: ndata
+     real*8, dimension(:) :: g1bufid, bufid
+     integer,dimension(:) ::  nprocs_map, lnsizes 
+     integer :: i,j,k, tag, ierr
+     real*8, allocatable,dimension(:) :: buf
+     integer, dimension(:) :: istart
+     integer, dimension(numprocs) :: count
+     ! pack data
+     if(my_id .eq. io_id) then
+         allocate(buf(ndata))
+         count = 0
+         do i = 1, ndata
+            k = nprocs_map(i)
+            if( k .gt. 0) then
+              buf(istart(k) + count(k)) = g1bufid(i) 
+              count(k) = count(k) + 1
+            endif
+         end do
+      end if
+       call mpp_land_sync()
+      if(my_id .ne. IO_id) then
+          tag = 72
+          if(lnsizes(my_id + 1) .gt. 0) then
+             call mpi_recv(bufid,lnsizes(my_id + 1),&
+                   MPI_DOUBLE_PRECISION,io_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+          endif
+      else
+          do i = 0, numprocs - 1
+            if(i .ne. my_id) then
+               tag = 72
+               if(lnsizes(i+1) .gt. 0) then
+                  call mpi_send(buf(istart(i+1):istart(i+1)+lnsizes(i+1)-1),  &
+                      lnsizes(i+1),MPI_DOUBLE_PRECISION,i, tag,HYDRO_COMM_WORLD,ierr)
+               endif
+            else
+                if(lnsizes(my_id + 1) .gt. 0) then
+                   bufid = buf(istart(i + 1):istart(i+1)+lnsizes(i+1)-1)
+                endif
+            end if
+          end do
+       end if
+     if(my_id .eq. io_id) then 
+         if(allocated(buf))  deallocate(buf)
+     endif
+  end subroutine pack_decomp_real8
+
+! this is used for nhdPlus with Lake. 
+! resolve the data from TO_NODE grids, and update back to NLINKSL grids.
+  subroutine TONODE2RSL (ind,inVar,size,gNLINKSL,NLINKSL,ioVar,flag)
+    implicit none
+    integer,intent(in) :: size,gNLINKSL,NLINKSL  ! 
+    integer,intent(in) , dimension(size) :: ind, inVar
+    integer,intent(inout), dimension(nlinksl) :: ioVar
+    integer, allocatable, dimension(:) :: gvar, buf, tmpInd
+    integer :: i,j,k, tag, ierr, tmpSize, flag
+
+    if(gNLINKSL .le. 0) return
+
+    if(my_id .eq. io_id) then
+       allocate(gvar(gNLINKSL))
+    else
+       allocate(gvar(1))
+    endif
+    call ReachLS_wInt(ioVar,gvar)
+
+      if(my_id .eq. io_id) then
+         do i = 1, numprocs
+            if(i-1 .eq. io_id) then
+                do k = 1, size
+                   if(inVar(k) .ne. flag) then
+                      gvar(ind(k)) = inVar(k)
+                   endif
+                end do
+            else
+                  tag = 82
+                  call mpi_recv(tmpSize,1,MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                  if(tmpSize .gt. 0) then
+                      allocate(buf(tmpSize))
+                      allocate(tmpInd(tmpSize))
+                      tag = 83
+                      call mpi_recv(tmpInd, tmpSize , &
+                           MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                      tag = 84
+                      call mpi_recv(buf, tmpSize , &
+                           MPI_INTEGER,i-1,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                      do k = 1, tmpSize
+                         if(buf(k) .ne. flag) then
+                             gvar(tmpInd(k)) = buf(k)
+                         endif
+                      end do
+                      if(allocated(buf))  deallocate(buf)
+                      if(allocated(tmpInd)) deallocate(tmpInd)
+                  endif
+            endif
+         end do
+      else   
+          tag = 82
+          call mpi_send(size,1,MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr)
+          if(size .gt. 0) then
+             tag = 83
+             call mpi_send(ind(1:size),size, &
+                 MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr)
+             tag = 84
+             call mpi_send(inVar(1:size),size, &
+                 MPI_INTEGER,io_id,tag,HYDRO_COMM_WORLD,ierr)
+          endif
+      endif 
+      call ReachLS_decomp(gvar, ioVar)
+      if(allocated(gvar)) deallocate(gvar)
+  end subroutine TONODE2RSL 
+
+
+END MODULE MODULE_mpp_ReachLS
+
+
diff --git a/wrfv2_fire/hydro/MPP/mpp_land.F b/wrfv2_fire/hydro/MPP/mpp_land.F
new file mode 100644
index 00000000..4ce51167
--- /dev/null
+++ b/wrfv2_fire/hydro/MPP/mpp_land.F
@@ -0,0 +1,2346 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+!#### This is a module for parallel Land model.
+MODULE MODULE_MPP_LAND
+
+  use MODULE_CPL_LAND
+
+  IMPLICIT NONE
+  include "mpif.h"
+  !integer, public :: HYDRO_COMM_WORLD ! communicator for WRF-Hydro - moved to MODULE_CPL_LAND
+  integer, public :: left_id,right_id,up_id,down_id,my_id
+  integer, public :: left_right_np,up_down_np ! define total process in two dimensions.
+  integer, public :: left_right_p ,up_down_p ! the position of the current process in the logical topography.
+  integer, public :: IO_id   ! the number for IO. (Last processor for IO)
+  integer, public :: global_nx, global_ny, local_nx,local_ny
+  integer, public :: global_rt_nx, global_rt_ny
+  integer, public :: local_rt_nx,local_rt_ny,rt_AGGFACTRT
+  integer, public :: numprocs   ! total process, get by mpi initialization.
+  integer :: local_startx, local_starty
+  integer :: local_startx_rt, local_starty_rt, local_endx_rt, local_endy_rt
+
+  integer mpp_status(MPI_STATUS_SIZE)
+
+  integer  overlap_n
+  integer, allocatable, DIMENSION(:), public :: local_nx_size,local_ny_size
+  integer, allocatable, DIMENSION(:), public :: local_rt_nx_size,local_rt_ny_size
+  integer, allocatable, DIMENSION(:), public :: startx,starty
+  integer, allocatable, DIMENSION(:), public :: mpp_nlinks
+
+  interface check_land
+     module procedure check_landreal1
+     module procedure check_landreal1d
+     module procedure check_landreal2d
+     module procedure check_landreal3d
+  end interface
+  interface write_io_land
+     module procedure write_io_real3d
+  end interface
+  interface mpp_land_bcast
+     module procedure mpp_land_bcast_real2
+     module procedure mpp_land_bcast_real_1d
+     module procedure mpp_land_bcast_real8_1d
+     module procedure mpp_land_bcast_real1
+     module procedure mpp_land_bcast_char1d 
+     module procedure mpp_land_bcast_char1
+     module procedure mpp_land_bcast_int1 
+     module procedure mpp_land_bcast_int1d 
+     module procedure mpp_land_bcast_int2d 
+     module procedure mpp_land_bcast_logical
+     
+  end interface
+ 
+  contains
+
+  subroutine LOG_MAP2d()
+    implicit none
+    integer :: ndim, ierr
+    integer, dimension(0:1) :: dims, coords
+    
+    logical cyclic(0:1), reorder
+    data cyclic/.false.,.false./  ! not cyclic
+    data reorder/.false./
+    
+      call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr )
+      call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr )
+
+      call getNX_NY(numprocs, left_right_np,up_down_np)
+      if(my_id.eq.IO_id) then
+#ifdef HYDRO_D
+            write(6,*) ""
+            write(6,*) "total process:",numprocs
+            write(6,*) "left_right_np =", left_right_np,&
+                 "up_down_np=",up_down_np
+#endif
+      end if
+
+!   ### get the row and column of the current process in the logical topography.
+!   ### left --> right, 0 -->left_right_np -1
+!   ### up --> down, 0 --> up_down_np -1
+        left_right_p = mod(my_id , left_right_np)
+        up_down_p = my_id / left_right_np
+
+!   ### get the neighbors.  -1 means no neighbor.
+        down_id = my_id - left_right_np
+        up_id =   my_id + left_right_np 
+        if( up_down_p .eq. 0) down_id = -1
+        if( up_down_p .eq. (up_down_np-1) ) up_id = -1
+
+        left_id = my_id - 1 
+        right_id = my_id + 1 
+        if( left_right_p .eq. 0) left_id = -1
+        if( left_right_p .eq. (left_right_np-1) ) right_id =-1
+    
+!    ### the IO node is the last processor.
+!yw        IO_id = numprocs - 1
+         IO_id = 0
+
+! print the information for debug.
+
+! BF  setup virtual cartesian grid topology
+      ndim = 2
+
+      dims(0) = up_down_np      ! rows
+      dims(1) = left_right_np   ! columns
+!
+     call MPI_Cart_create(HYDRO_COMM_WORLD, ndim, dims, &
+                          cyclic, reorder, cartGridComm, ierr)
+     
+     call MPI_CART_GET(cartGridComm, 2, dims, cyclic, coords, ierr)
+     
+     p_up_down = coords(0)
+     p_left_right = coords(1)
+     np_up_down = up_down_np 
+     np_left_right = left_right_np
+ 
+     
+     call mpp_land_sync()
+
+  return 
+  end  subroutine log_map2d
+!old subroutine MPP_LAND_INIT(flag, ew_numprocs, sn_numprocs)
+  subroutine MPP_LAND_INIT()
+!    ### initialize the land model logically based on the two D method. 
+!    ### Call this function directly if it is nested with WRF.
+    implicit none
+    integer :: ierr
+    integer :: ew_numprocs, sn_numprocs  ! input the processors in x and y direction.
+    logical mpi_inited
+     
+!     left_right_np = ew_numprocs
+!     up_down_np  = sn_numprocs
+
+      CALL mpi_initialized( mpi_inited, ierr )
+      if ( .NOT. mpi_inited ) then
+           call MPI_INIT( ierr )  ! stand alone land model.
+           HYDRO_COMM_WORLD = MPI_COMM_WORLD
+      else 
+           call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr )
+           call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr )
+           return
+      endif
+!     create 2d logical mapping of the CPU.
+      call log_map2d()
+      return
+  end   subroutine MPP_LAND_INIT
+
+
+     subroutine MPP_LAND_PAR_INI(over_lap,in_global_nx,in_global_ny,AGGFACTRT)
+        integer in_global_nx,in_global_ny, AGGFACTRT
+        integer :: over_lap   ! the overlaped grid number. (default is 1)
+        integer :: i
+
+        global_nx = in_global_nx
+        global_ny = in_global_ny 
+        rt_AGGFACTRT = AGGFACTRT
+        global_rt_nx = in_global_nx*AGGFACTRT
+        global_rt_ny = in_global_ny *AGGFACTRT
+        !overlap_n = 1
+!ywold        local_nx = global_nx / left_right_np 
+!ywold        if(left_right_p .eq. (left_right_np-1) ) then
+!ywold              local_nx = global_nx   &
+!ywold                    -int(global_nx/left_right_np)*(left_right_np-1)
+!ywold        end if
+!ywold        local_ny = global_ny / up_down_np 
+!ywold        if(  up_down_p .eq. (up_down_np-1) ) then
+!ywold           local_ny = global_ny  &
+!ywold                 -int(global_ny/up_down_np)*(up_down_np -1)
+!ywold       end if
+
+        local_nx = int(global_nx / left_right_np)
+        !if(global_nx .ne. (local_nx*left_right_np) ) then
+        if(mod(global_nx, left_right_np) .ne. 0) then
+            do i = 1, mod(global_nx, left_right_np)
+               if(left_right_p .eq. i ) then
+                   local_nx = local_nx + 1
+               end if
+            end do
+        end if
+
+        local_ny = int(global_ny / up_down_np)
+        !if(global_ny .ne. (local_ny * up_down_np) ) then
+        if(mod(global_ny,up_down_np) .ne. 0 ) then
+            do i = 1, mod(global_ny,up_down_np)
+                 if( up_down_p .eq. i) then
+                     local_ny = local_ny + 1
+                 end if
+            end do
+        end if
+        
+        local_rt_nx=local_nx*AGGFACTRT+2
+        local_rt_ny=local_ny*AGGFACTRT+2
+        if(left_id.lt.0) local_rt_nx = local_rt_nx -1
+        if(right_id.lt.0) local_rt_nx = local_rt_nx -1
+        if(up_id.lt.0) local_rt_ny = local_rt_ny -1
+        if(down_id.lt.0) local_rt_ny = local_rt_ny -1
+
+        call get_local_size(local_nx, local_ny,local_rt_nx,local_rt_ny)
+        call calculate_start_p()
+        
+        in_global_nx = local_nx
+        in_global_ny = local_ny
+#ifdef HYDRO_D
+        write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_nx
+        write(6,*) "my_id=",my_id,"global_rt_nx=",global_rt_ny
+        write(6,*) "my_id=",my_id,"global_nx=",global_nx
+        write(6,*) "my_id=",my_id,"global_nx=",global_ny
+#endif
+        return 
+        end  subroutine MPP_LAND_PAR_INI
+
+  subroutine MPP_LAND_LR_COM(in_out_data,NX,NY,flag)
+!   ### Communicate message on left right direction.
+    integer NX,NY
+    real in_out_data(nx,ny),data_r(2,ny)
+    integer count,size,tag,  ierr
+    integer flag   ! 99 replace the boundary, else get the sum.
+
+    if(flag .eq. 99) then ! replace the data  
+       if(right_id .ge. 0) then  !   ### send to right first.
+           tag = 11 
+           size = ny
+           call mpi_send(in_out_data(nx-1,:),size,MPI_REAL,   &
+             right_id,tag,HYDRO_COMM_WORLD,ierr)
+       end if
+       if(left_id .ge. 0) then !   receive from left
+           tag = 11
+           size = ny
+           call mpi_recv(in_out_data(1,:),size,MPI_REAL,  &
+              left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+       endif 
+
+      if(left_id .ge. 0 ) then !   ### send to left second.
+          size = ny 
+          tag = 21
+          call mpi_send(in_out_data(2,:),size,MPI_REAL,   &
+             left_id,tag,HYDRO_COMM_WORLD,ierr)
+      endif
+      if(right_id .ge. 0) then !   receive from  right
+          tag = 21
+          size = ny 
+          call mpi_recv(in_out_data(nx,:),size,MPI_REAL,&
+             right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr)
+      endif
+
+    else   ! get the sum
+
+       if(right_id .ge. 0) then !   ### send to right first.
+         tag = 11
+         size = 2*ny 
+         call mpi_send(in_out_data(nx-1:nx,:),size,MPI_REAL,   &
+             right_id,tag,HYDRO_COMM_WORLD,ierr)
+       end if
+       if(left_id .ge. 0) then !   receive from left
+          tag = 11
+          size = 2*ny
+          call mpi_recv(data_r,size,MPI_REAL,left_id,tag, &
+               HYDRO_COMM_WORLD,mpp_status,ierr)
+          in_out_data(1,:) = in_out_data(1,:) + data_r(1,:)
+          in_out_data(2,:) = in_out_data(2,:) + data_r(2,:)
+       endif 
+
+      if(left_id .ge. 0 ) then !   ### send to left second.
+          size = 2*ny
+          tag = 21
+          call mpi_send(in_out_data(1:2,:),size,MPI_REAL,   &
+             left_id,tag,HYDRO_COMM_WORLD,ierr)
+      endif
+      if(right_id .ge. 0) then !   receive from  right
+          tag = 21
+          size = 2*ny
+          call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_REAL,&
+             right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr)
+      endif
+    endif   ! end if black for flag.
+
+    return
+  end subroutine MPP_LAND_LR_COM
+
+  subroutine MPP_LAND_LR_COM8(in_out_data,NX,NY,flag)
+!   ### Communicate message on left right direction.
+    integer NX,NY
+    real*8 in_out_data(nx,ny),data_r(2,ny)
+    integer count,size,tag,  ierr
+    integer flag   ! 99 replace the boundary, else get the sum.
+
+    if(flag .eq. 99) then ! replace the data  
+       if(right_id .ge. 0) then  !   ### send to right first.
+           tag = 11 
+           size = ny
+           call mpi_send(in_out_data(nx-1,:),size,MPI_DOUBLE_PRECISION,   &
+             right_id,tag,HYDRO_COMM_WORLD,ierr)
+       end if
+       if(left_id .ge. 0) then !   receive from left
+           tag = 11
+           size = ny
+           call mpi_recv(in_out_data(1,:),size,MPI_DOUBLE_PRECISION,  &
+              left_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+       endif 
+
+      if(left_id .ge. 0 ) then !   ### send to left second.
+          size = ny 
+          tag = 21
+          call mpi_send(in_out_data(2,:),size,MPI_DOUBLE_PRECISION,   &
+             left_id,tag,HYDRO_COMM_WORLD,ierr)
+      endif
+      if(right_id .ge. 0) then !   receive from  right
+          tag = 21
+          size = ny 
+          call mpi_recv(in_out_data(nx,:),size,MPI_DOUBLE_PRECISION,&
+             right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr)
+      endif
+
+    else   ! get the sum
+
+       if(right_id .ge. 0) then !   ### send to right first.
+         tag = 11
+         size = 2*ny 
+         call mpi_send(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,   &
+             right_id,tag,HYDRO_COMM_WORLD,ierr)
+       end if
+       if(left_id .ge. 0) then !   receive from left
+          tag = 11
+          size = 2*ny
+          call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION,left_id,tag, &
+               HYDRO_COMM_WORLD,mpp_status,ierr)
+          in_out_data(1,:) = in_out_data(1,:) + data_r(1,:)
+          in_out_data(2,:) = in_out_data(2,:) + data_r(2,:)
+       endif 
+
+      if(left_id .ge. 0 ) then !   ### send to left second.
+          size = 2*ny
+          tag = 21
+          call mpi_send(in_out_data(1:2,:),size,MPI_DOUBLE_PRECISION,   &
+             left_id,tag,HYDRO_COMM_WORLD,ierr)
+      endif
+      if(right_id .ge. 0) then !   receive from  right
+          tag = 21
+          size = 2*ny
+          call mpi_recv(in_out_data(nx-1:nx,:),size,MPI_DOUBLE_PRECISION,&
+             right_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr)
+      endif
+    endif   ! end if black for flag.
+
+    return
+  end subroutine MPP_LAND_LR_COM8
+  
+  
+  subroutine get_local_size(local_nx, local_ny,rt_nx,rt_ny)
+    integer local_nx, local_ny, rt_nx,rt_ny
+    integer i,status,ierr, tag
+    integer tmp_nx,tmp_ny
+!   ### if it is IO node, get the local_size of the x and y direction 
+!   ### for all other tasks.
+    integer s_r(2)
+
+!   if(my_id .eq. IO_id) then 
+       allocate(local_nx_size(numprocs),stat = status) 
+       allocate(local_ny_size(numprocs),stat = status) 
+       allocate(local_rt_nx_size(numprocs),stat = status) 
+       allocate(local_rt_ny_size(numprocs),stat = status) 
+!   end if
+
+       call mpp_land_sync()
+
+       if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1 
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 1
+                 call mpi_recv(s_r,2,MPI_INTEGER,i, & 
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                 local_nx_size(i+1) = s_r(1)
+                 local_ny_size(i+1) = s_r(2)
+               else
+                   local_nx_size(i+1) = local_nx
+                   local_ny_size(i+1) = local_ny
+               end if
+           end do
+       else 
+           tag =  1  
+           s_r(1) = local_nx
+           s_r(2) = local_ny
+           call mpi_send(s_r,2,MPI_INTEGER, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+       end if
+
+ 
+       if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1 
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 2
+                 call mpi_recv(s_r,2,MPI_INTEGER,i, & 
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                 local_rt_nx_size(i+1) = s_r(1)
+                 local_rt_ny_size(i+1) = s_r(2)
+               else
+                   local_rt_nx_size(i+1) = rt_nx
+                   local_rt_ny_size(i+1) = rt_ny
+               end if
+           end do
+       else 
+           tag =  2  
+           s_r(1) = rt_nx
+           s_r(2) = rt_ny
+           call mpi_send(s_r,2,MPI_INTEGER, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+       end if
+       call mpp_land_sync()
+       return 
+  end  subroutine get_local_size
+
+
+  subroutine MPP_LAND_UB_COM(in_out_data,NX,NY,flag)
+!   ### Communicate message on up down direction.
+    integer NX,NY
+    real in_out_data(nx,ny),data_r(nx,2)
+    integer count,size,tag, status, ierr
+    integer flag  ! 99 replace the boundary , else get the sum of the boundary
+
+
+    if(flag .eq. 99) then  ! replace the boundary data.
+
+       if(up_id .ge. 0 ) then !   ### send to up first.
+           tag = 31
+           size = nx
+           call mpi_send(in_out_data(:,ny-1),size,MPI_REAL,   &
+               up_id,tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       if(down_id .ge. 0 ) then !   receive from down 
+           tag = 31 
+           size = nx
+           call mpi_recv(in_out_data(:,1),size,MPI_REAL, &
+              down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr)
+       endif
+   
+       if(down_id .ge. 0 ) then !   send down.
+           tag = 41
+           size = nx
+           call mpi_send(in_out_data(:,2),size,MPI_REAL,      &
+                down_id,tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       if(up_id .ge. 0 ) then !   receive from upper 
+           tag = 41 
+           size = nx
+           call mpi_recv(in_out_data(:,ny),size,MPI_REAL, &
+               up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+       endif
+     
+    else  ! flag = 1 
+
+       if(up_id .ge. 0 ) then !   ### send to up first.
+           tag = 31
+           size = nx*2
+           call mpi_send(in_out_data(:,ny-1:ny),size,MPI_REAL,   &
+               up_id,tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       if(down_id .ge. 0 ) then !   receive from down
+           tag = 31
+           size = nx*2
+           call mpi_recv(data_r,size,MPI_REAL, &
+              down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr)
+           in_out_data(:,1) = in_out_data(:,1) + data_r(:,1)
+           in_out_data(:,2) = in_out_data(:,2) + data_r(:,2)
+       endif
+
+       if(down_id .ge. 0 ) then !   send down.
+           tag = 41
+           size = nx*2
+           call mpi_send(in_out_data(:,1:2),size,MPI_REAL,      &
+                down_id,tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       if(up_id .ge. 0 ) then !   receive from upper
+           tag = 41
+           size = nx * 2
+           call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_REAL, &
+               up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+       endif
+    endif  ! end of block  flag
+    return
+  end  subroutine MPP_LAND_UB_COM
+
+  subroutine MPP_LAND_UB_COM8(in_out_data,NX,NY,flag)
+!   ### Communicate message on up down direction.
+    integer NX,NY
+    real*8 in_out_data(nx,ny),data_r(nx,2)
+    integer count,size,tag, status, ierr
+    integer flag  ! 99 replace the boundary , else get the sum of the boundary
+
+
+    if(flag .eq. 99) then  ! replace the boundary data.
+
+       if(up_id .ge. 0 ) then !   ### send to up first.
+           tag = 31
+           size = nx
+           call mpi_send(in_out_data(:,ny-1),size,MPI_DOUBLE_PRECISION,   &
+               up_id,tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       if(down_id .ge. 0 ) then !   receive from down 
+           tag = 31 
+           size = nx
+           call mpi_recv(in_out_data(:,1),size,MPI_DOUBLE_PRECISION, &
+              down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr)
+       endif
+   
+       if(down_id .ge. 0 ) then !   send down.
+           tag = 41
+           size = nx
+           call mpi_send(in_out_data(:,2),size,MPI_DOUBLE_PRECISION,      &
+                down_id,tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       if(up_id .ge. 0 ) then !   receive from upper 
+           tag = 41 
+           size = nx
+           call mpi_recv(in_out_data(:,ny),size,MPI_DOUBLE_PRECISION, &
+               up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+       endif
+     
+    else  ! flag = 1 
+
+       if(up_id .ge. 0 ) then !   ### send to up first.
+           tag = 31
+           size = nx*2
+           call mpi_send(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION,   &
+               up_id,tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       if(down_id .ge. 0 ) then !   receive from down
+           tag = 31
+           size = nx*2
+           call mpi_recv(data_r,size,MPI_DOUBLE_PRECISION, &
+              down_id,tag,HYDRO_COMM_WORLD, mpp_status,ierr)
+           in_out_data(:,1) = in_out_data(:,1) + data_r(:,1)
+           in_out_data(:,2) = in_out_data(:,2) + data_r(:,2)
+       endif
+
+       if(down_id .ge. 0 ) then !   send down.
+           tag = 41
+           size = nx*2
+           call mpi_send(in_out_data(:,1:2),size,MPI_DOUBLE_PRECISION,      &
+                down_id,tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       if(up_id .ge. 0 ) then !   receive from upper
+           tag = 41
+           size = nx * 2
+           call mpi_recv(in_out_data(:,ny-1:ny),size,MPI_DOUBLE_PRECISION, &
+               up_id,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+       endif
+    endif  ! end of block  flag
+    return
+  end  subroutine MPP_LAND_UB_COM8
+  
+  subroutine calculate_start_p()
+! calculate startx and starty
+    integer :: i,status, ierr, tag
+    integer :: r_s(2)
+    integer ::  t_nx, t_ny
+
+    allocate(starty(numprocs),stat = ierr) 
+    allocate(startx(numprocs),stat = ierr)
+
+    local_startx = int(global_nx/left_right_np) * left_right_p+1 
+    local_starty = int(global_ny/up_down_np) * up_down_p+1 
+
+!ywold
+    t_nx = 0
+    do i = 1, mod(global_nx,left_right_np)
+       if(left_right_p .gt. i ) then
+           t_nx = t_nx + 1
+       end if
+    end do
+    local_startx = local_startx + t_nx
+
+    t_ny = 0
+    do i = 1, mod(global_ny,up_down_np)
+       if( up_down_p .gt. i) then
+           t_ny = t_ny + 1
+       end if
+    end do
+    local_starty = local_starty + t_ny
+
+
+    if(left_id .lt. 0) local_startx = 1
+    if(down_id .lt. 0) local_starty = 1
+
+
+    if(my_id .eq. IO_id) then
+         startx(my_id+1) = local_startx
+         starty(my_id+1) = local_starty
+    end if
+
+    r_s(1) = local_startx
+    r_s(2) = local_starty
+    call mpp_land_sync()
+
+    if(my_id .eq. IO_id) then
+        do i = 0, numprocs - 1
+           ! block receive  from other node.
+           if(i.ne.my_id) then
+              tag = 1
+              call mpi_recv(r_s,2,MPI_INTEGER,i, &
+                   tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+              startx(i+1) = r_s(1)
+              starty(i+1) = r_s(2)
+           end if
+        end do
+     else
+           tag =  1
+           call mpi_send(r_s,2,MPI_INTEGER, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+     end if
+
+     call mpp_land_sync()
+
+! calculate the routing land start x and y
+     local_startx_rt = local_startx*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+     if(local_startx_rt.gt.1) local_startx_rt=local_startx_rt - 1
+     local_starty_rt = local_starty*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+     if(local_starty_rt.gt.1) local_starty_rt=local_starty_rt - 1
+
+     local_endx_rt   = local_startx_rt + local_rt_nx -1
+     local_endy_rt   = local_starty_rt + local_rt_ny -1
+
+     return
+  end subroutine calculate_start_p
+
+  subroutine decompose_data_real3d (in_buff,out_buff,klevel)
+      implicit none
+      integer:: klevel, k
+      real,dimension(:,:,:) ::  in_buff,out_buff
+      do k = 1, klevel
+          call decompose_data_real(in_buff(:,k,:),out_buff(:,k,:))
+      end do
+  end subroutine decompose_data_real3d
+
+
+  subroutine decompose_data_real (in_buff,out_buff)
+! usage: all of the cpu call this subroutine.
+! the IO node will distribute the data to rest of the node.
+      real,intent(in), dimension(:,:) :: in_buff
+      real,intent(out), dimension(local_nx,local_ny) :: out_buff
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+
+      tag = 2
+      if(my_id .eq. IO_id) then
+         do i = 0, numprocs - 1
+            ibegin = startx(i+1)
+            iend   = startx(i+1)+local_nx_size(i+1) -1
+            jbegin = starty(i+1)
+            jend   = starty(i+1)+local_ny_size(i+1) -1
+          
+            if(my_id .eq. i) then
+               out_buff=in_buff(ibegin:iend,jbegin:jend)
+            else
+               ! send data to the rest process.
+               size = local_nx_size(i+1)*local_ny_size(i+1)
+               call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,&
+                  MPI_REAL, i,tag,HYDRO_COMM_WORLD,ierr)
+            end if
+         end do
+      else 
+         size = local_nx*local_ny
+         call mpi_recv(out_buff,size,MPI_REAL,IO_id, &
+                tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+      end if
+      return
+  end subroutine decompose_data_real
+
+
+  subroutine decompose_data_int (in_buff,out_buff)
+! usage: all of the cpu call this subroutine.
+! the IO node will distribute the data to rest of the node.
+      integer,dimension(:,:) ::  in_buff,out_buff
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+ 
+      tag = 2
+      if(my_id .eq. IO_id) then
+         do i = 0, numprocs - 1
+            ibegin = startx(i+1)
+            iend   = startx(i+1)+local_nx_size(i+1) -1
+            jbegin = starty(i+1)
+            jend   = starty(i+1)+local_ny_size(i+1) -1
+            if(my_id .eq. i) then
+               out_buff=in_buff(ibegin:iend,jbegin:jend)
+            else
+               ! send data to the rest process.
+               size = local_nx_size(i+1)*local_ny_size(i+1)
+               call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,&
+                  MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr)
+            end if
+         end do
+      else 
+         size = local_nx*local_ny
+         call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, &
+                tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+      end if
+      return
+  end subroutine decompose_data_int
+
+  subroutine write_IO_int(in_buff,out_buff)
+! the IO node will receive the data from the rest process.
+      integer,dimension(:,:):: in_buff,  out_buff
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+      if(my_id .ne. IO_id) then
+          size = local_nx*local_ny
+          tag = 2
+          call mpi_send(in_buff,size,MPI_INTEGER, IO_id,     &
+                tag,HYDRO_COMM_WORLD,ierr)
+      else
+          do i = 0, numprocs - 1
+            ibegin = startx(i+1)
+            iend   = startx(i+1)+local_nx_size(i+1) -1
+            jbegin = starty(i+1)
+            jend   = starty(i+1)+local_ny_size(i+1) -1
+            if(i .eq. IO_id) then
+               out_buff(ibegin:iend,jbegin:jend) = in_buff 
+            else 
+               size = local_nx_size(i+1)*local_ny_size(i+1)
+               tag = 2
+               call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,&
+                   MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+            end if
+          end do
+      end if
+      return
+  end subroutine write_IO_int
+
+  subroutine write_IO_char_head(in, out, imageHead)
+  !! JLM 2015-11-30
+  !! for i is image number (starting from 0), 
+  !! this routine writes 
+  !! in(1:imageHead(i+1)) 
+  !! to 
+  !! out( (sum(imageHead(i+1-1))+1) : ((sum(imageHead(i+1-1))+1)+imageHead(i+1)) )
+  !! where out is on the IO node.
+      character(len=*), intent(in),  dimension(:) :: in 
+      character(len=*), intent(out), dimension(:) :: out
+      integer,   intent(in),  dimension(:) :: imageHead
+      integer :: tag, i, status, ierr, size
+      integer :: ibegin,iend,jbegin,jend
+      integer :: lenSize, theStart, theEnd
+      tag = 2 
+      if(my_id .ne. IO_id) then
+         lenSize = imageHead(my_id+1)*len(in(1))  !! some times necessary for character arrays?
+         if(lenSize .eq. 0) return
+         call mpi_send(in,lenSize,MPI_CHARACTER,IO_id,tag,HYDRO_COMM_WORLD,ierr)
+      else
+         do i = 0, numprocs-1
+            lenSize  = imageHead(i+1)*len(in(1))  !! necessary?
+            if(lenSize .eq. 0) cycle
+            if(i .eq. 0) then
+               theStart = 1
+            else 
+               theStart = sum(imageHead(1:(i+1-1))) +1
+            end if
+            theEnd   = theStart + imageHead(i+1) -1
+            if(i .eq. IO_id) then
+               out(theStart:theEnd) = in(1:imageHead(i+1))
+            else 
+               call mpi_recv(out(theStart:theEnd),lenSize,&
+                    MPI_CHARACTER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+            end if
+         end do
+      end if
+  end subroutine write_IO_char_head
+
+
+  subroutine write_IO_real3d(in_buff,out_buff,klevel)
+     implicit none
+! the IO node will receive the data from the rest process.
+      integer klevel, k
+      real,dimension(:,:,:):: in_buff, out_buff
+      do k = 1, klevel
+         call write_IO_real(in_buff(:,k,:),out_buff(:,k,:))
+      end do
+  end subroutine write_IO_real3d
+
+  subroutine write_IO_real(in_buff,out_buff)
+! the IO node will receive the data from the rest process.
+      real,dimension(:,:):: in_buff, out_buff
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+      if(my_id .ne. IO_id) then
+          size = local_nx*local_ny
+          tag = 2
+          call mpi_send(in_buff,size,MPI_REAL, IO_id,     &
+                tag,HYDRO_COMM_WORLD,ierr)
+      else
+          do i = 0, numprocs - 1
+            ibegin = startx(i+1)
+            iend   = startx(i+1)+local_nx_size(i+1) -1
+            jbegin = starty(i+1)
+            jend   = starty(i+1)+local_ny_size(i+1) -1
+            if(i .eq. IO_id) then
+               out_buff(ibegin:iend,jbegin:jend) = in_buff 
+            else 
+               size = local_nx_size(i+1)*local_ny_size(i+1)
+               tag = 2
+               call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,&
+                   MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+            end if
+          end do
+      end if
+      return
+  end subroutine write_IO_real
+
+  subroutine write_IO_RT_real(in_buff,out_buff)
+! the IO node will receive the data from the rest process.
+      real,dimension(:,:) ::  in_buff, out_buff
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+      if(my_id .ne. IO_id) then
+          size = local_rt_nx*local_rt_ny
+          tag = 2
+          call mpi_send(in_buff,size,MPI_REAL, IO_id,     &
+                tag,HYDRO_COMM_WORLD,ierr)
+      else
+          do i = 0, numprocs - 1
+            ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) 
+            if(ibegin.gt.1) ibegin=ibegin - 1
+            iend   = ibegin + local_rt_nx_size(i+1) -1
+            jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+            if(jbegin.gt.1) jbegin=jbegin - 1
+            jend   = jbegin + local_rt_ny_size(i+1) -1
+            if(i .eq. IO_id) then
+               out_buff(ibegin:iend,jbegin:jend) = in_buff 
+            else 
+               size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1)
+               tag = 2
+               call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,&
+                   MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+            end if
+          end do
+      end if
+      return
+  end subroutine write_IO_RT_real
+
+
+  subroutine write_IO_RT_int (in_buff,out_buff)
+! the IO node will receive the data from the rest process.
+      integer,intent(in),dimension(:,:) :: in_buff
+      integer,intent(out),dimension(:,:) ::  out_buff
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+      if(my_id .ne. IO_id) then
+          size = local_rt_nx*local_rt_ny
+          tag = 2
+          call mpi_send(in_buff,size,MPI_INTEGER, IO_id,     &
+                tag,HYDRO_COMM_WORLD,ierr)
+      else
+          do i = 0, numprocs - 1
+            ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) 
+            if(ibegin.gt.1) ibegin=ibegin - 1
+            iend   = ibegin + local_rt_nx_size(i+1) -1
+            jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+            if(jbegin.gt.1) jbegin=jbegin - 1
+            jend   = jbegin + local_rt_ny_size(i+1) -1
+            if(i .eq. IO_id) then
+               out_buff(ibegin:iend,jbegin:jend) = in_buff 
+            else 
+               size = local_rt_nx_size(i+1)*local_rt_ny_size(i+1)
+               tag = 2
+               call mpi_recv(out_buff(ibegin:iend,jbegin:jend),size,&
+                   MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+            end if
+          end do
+      end if
+      return
+  end subroutine write_IO_RT_int
+
+  subroutine mpp_land_bcast_log1(inout)
+      logical inout
+      integer ierr
+        call mpi_bcast(inout,1,MPI_LOGICAL,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_log1
+
+
+  subroutine mpp_land_bcast_int(size,inout)
+      integer size
+      integer inout(size)
+      integer ierr
+        call mpi_bcast(inout,size,MPI_INTEGER,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_int
+
+  subroutine mpp_land_bcast_int1d(inout)
+      integer len 
+      integer inout(:)
+     integer ierr
+      len = size(inout,1)
+        call mpi_bcast(inout,len,MPI_INTEGER,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_int1d
+
+  subroutine mpp_land_bcast_int1d_root(inout, rootId)
+     integer len 
+     integer inout(:)
+     integer, intent(in) :: rootId
+     integer ierr
+      len = size(inout,1)
+        call mpi_bcast(inout,len,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_int1d_root
+
+  subroutine mpp_land_bcast_int1(inout)
+      integer inout
+      integer ierr
+        call mpi_bcast(inout,1,MPI_INTEGER,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_int1
+
+  subroutine mpp_land_bcast_int1_root(inout, rootId)
+      integer inout
+      integer ierr
+      integer, intent(in) :: rootId
+        call mpi_bcast(inout,1,MPI_INTEGER,rootId,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_int1_root
+
+  subroutine mpp_land_bcast_logical(inout)
+      logical ::  inout
+      integer ierr
+        call mpi_bcast(inout,1,MPI_LOGICAL,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_logical
+
+  subroutine mpp_land_bcast_logical_root(inout, rootId)
+      logical ::  inout
+      integer, intent(in) :: rootId
+      integer ierr
+        call mpi_bcast(inout,1,MPI_LOGICAL,rootId,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_logical_root
+
+
+  subroutine mpp_land_bcast_real1(inout)
+      real inout
+      integer ierr
+        call mpi_bcast(inout,1,MPI_REAL,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return 
+  end subroutine mpp_land_bcast_real1
+
+  subroutine mpp_land_bcast_real_1d(inout)
+      integer len
+      real inout(:)
+      integer ierr
+      len = size(inout,1) 
+        call mpi_bcast(inout,len,MPI_real,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_real_1d
+
+
+  subroutine mpp_land_bcast_real_1d_root(inout, rootId)
+      integer len
+      real inout(:)
+      integer, intent(in) :: rootId
+      integer ierr
+      len = size(inout,1)
+        call mpi_bcast(inout,len,MPI_real,rootId,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+    end subroutine mpp_land_bcast_real_1d_root
+
+
+  subroutine mpp_land_bcast_real8_1d(inout)
+      integer len
+      real*8 inout(:)
+      integer ierr
+      len = size(inout,1)
+        call mpi_bcast(inout,len,MPI_double,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_real8_1d
+
+
+  subroutine mpp_land_bcast_real(size1,inout)
+      integer size1
+      ! real inout(size1)
+      real , dimension(:) :: inout
+      integer ierr, len
+        call mpi_bcast(inout,size1,MPI_real,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+        call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_real
+
+  subroutine mpp_land_bcast_int2d(inout)
+      integer length1, k,length2
+      integer inout(:,:)
+      integer ierr
+      length1 = size(inout,1)
+      length2 = size(inout,2)
+      do k = 1, length2
+        call mpi_bcast(inout(:,k),length1,MPI_INTEGER,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      end do
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_int2d
+
+  subroutine mpp_land_bcast_real2(inout)
+      integer length1, k,length2
+      real inout(:,:)
+      integer ierr
+      length1 = size(inout,1)
+      length2 = size(inout,2)
+      do k = 1, length2
+        call mpi_bcast(inout(:,k),length1,MPI_real,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      end do
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_real2
+
+  subroutine mpp_land_bcast_real3d(inout)
+      integer j, k, length1, length2, length3
+      real inout(:,:,:)
+      integer ierr
+      length1 = size(inout,1)
+      length2 = size(inout,2)
+      length3 = size(inout,3)
+      do k = 1, length3
+         do j = 1, length2
+            call mpi_bcast(inout(:,j,k), length1, MPI_real, &
+                 IO_id, HYDRO_COMM_WORLD, ierr)
+         end do
+      end do
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_real3d
+  
+  subroutine mpp_land_bcast_rd(size,inout)
+      integer size
+      real*8 inout(size)
+      integer ierr
+        call mpi_bcast(inout,size,MPI_REAL8,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_rd
+
+  subroutine mpp_land_bcast_char(size,inout)
+      integer size
+      character inout(*)
+      integer ierr
+        call mpi_bcast(inout,size,MPI_CHARACTER,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_char
+
+  subroutine mpp_land_bcast_char_root(size,inout,rootId)
+      integer size
+      character inout(*)
+      integer, intent(in) :: rootId
+      integer ierr
+        call mpi_bcast(inout,size,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_char_root
+
+
+  subroutine mpp_land_bcast_char1d(inout)
+      character(len=*) :: inout(:)
+      integer :: lenSize
+      integer :: ierr
+      lenSize = size(inout,1)*len(inout)
+      call mpi_bcast(inout,lenSize,MPI_CHARACTER,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_char1d
+
+  subroutine mpp_land_bcast_char1d_root(inout,rootId)
+      character(len=*) :: inout(:)
+      integer, intent(in) :: rootId
+      integer :: lenSize
+      integer :: ierr
+      lenSize = size(inout,1)*len(inout)
+      call mpi_bcast(inout,lenSize,MPI_CHARACTER,rootId,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_char1d_root
+
+  subroutine mpp_land_bcast_char1(inout)
+      integer len
+      character(len=*) inout
+      integer ierr
+      len = LEN_TRIM(inout)
+      call mpi_bcast(inout,len,MPI_CHARACTER,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+      call mpp_land_sync()
+    return
+  end subroutine mpp_land_bcast_char1
+
+ 
+  subroutine MPP_LAND_COM_REAL(in_out_data,NX,NY,flag)
+!   ### Communicate message on left right and up bottom directions.
+    integer NX,NY
+    integer flag != 99  test only for land model. (replace the boundary).
+                 != 1   get the sum of the boundary value.
+    real in_out_data(nx,ny)
+
+    call MPP_LAND_LR_COM(in_out_data,NX,NY,flag)
+    call MPP_LAND_UB_COM(in_out_data,NX,NY,flag)
+
+    return
+  end subroutine MPP_LAND_COM_REAL
+
+  subroutine MPP_LAND_COM_REAL8(in_out_data,NX,NY,flag)
+!   ### Communicate message on left right and up bottom directions.
+    integer NX,NY
+    integer flag != 99  test only for land model. (replace the boundary).
+                 != 1   get the sum of the boundary value.
+    real*8 in_out_data(nx,ny)
+
+    call MPP_LAND_LR_COM8(in_out_data,NX,NY,flag)
+    call MPP_LAND_UB_COM8(in_out_data,NX,NY,flag)
+
+    return
+  end subroutine MPP_LAND_COM_REAL8
+
+  subroutine MPP_LAND_COM_INTEGER(data,NX,NY,flag)
+!   ### Communicate message on left right and up bottom directions.
+    integer NX,NY
+    integer flag != 99  test only for land model. (replace the boundary).
+                 != 1   get the sum of the boundary value.
+    integer data(nx,ny)
+    real in_out_data(nx,ny)
+
+    in_out_data = data + 0.0
+    call MPP_LAND_LR_COM(in_out_data,NX,NY,flag)
+    call MPP_LAND_UB_COM(in_out_data,NX,NY,flag)
+    data = in_out_data + 0
+
+    return
+  end subroutine MPP_LAND_COM_INTEGER
+ 
+     subroutine read_restart_3(unit,nz,out)
+        integer unit,nz,i
+        real buf3(global_nx,global_ny,nz),&
+          out(local_nx,local_ny,3)
+        if(my_id.eq.IO_id) read(unit) buf3
+        do i = 1,nz
+          call decompose_data_real (buf3(:,:,i),out(:,:,i))
+        end do
+     return
+     end subroutine read_restart_3
+
+     subroutine read_restart_2(unit,out)
+        integer unit,ierr2
+        real  buf2(global_nx,global_ny),&
+          out(local_nx,local_ny)
+
+       if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2
+        call mpp_land_bcast_int1(ierr2)
+        if(ierr2 .ne. 0) return
+
+        call decompose_data_real (buf2,out)
+     return
+     end subroutine read_restart_2
+
+     subroutine read_restart_rt_2(unit,out)
+        integer unit,ierr2
+        real  buf2(global_rt_nx,global_rt_ny),&
+          out(local_rt_nx,local_rt_ny)
+
+       if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf2
+        call mpp_land_bcast_int1(ierr2)
+        if(ierr2.ne.0) return
+
+        call decompose_RT_real(buf2,out, &
+          global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny)
+     return
+     end subroutine read_restart_rt_2
+
+     subroutine read_restart_rt_3(unit,nz,out)
+        integer unit,nz,i,ierr2
+        real buf3(global_rt_nx,global_rt_ny,nz),&
+          out(local_rt_nx,local_rt_ny,3)
+
+        if(my_id.eq.IO_id) read(unit,IOSTAT=ierr2) buf3
+        call mpp_land_bcast_int1(ierr2)
+        if(ierr2.ne.0) return
+
+        do i = 1,nz
+          call decompose_RT_real (buf3(:,:,i),out(:,:,i),&
+          global_rt_nx,global_rt_ny,local_rt_nx,local_rt_ny)
+        end do
+     return
+     end subroutine read_restart_rt_3
+
+     subroutine write_restart_3(unit,nz,in)
+        integer unit,nz,i
+        real buf3(global_nx,global_ny,nz),&
+          in(local_nx,local_ny,nz)
+        do i = 1,nz
+          call write_IO_real(in(:,:,i),buf3(:,:,i))
+        end do
+        if(my_id.eq.IO_id) write(unit) buf3
+     return
+     end subroutine write_restart_3
+
+     subroutine write_restart_2(unit,in)
+        integer unit
+        real  buf2(global_nx,global_ny),&
+           in(local_nx,local_ny)
+        call write_IO_real(in,buf2)
+        if(my_id.eq.IO_id) write(unit) buf2
+     return
+     end subroutine write_restart_2
+
+     subroutine write_restart_rt_2(unit,in)
+        integer unit
+        real  buf2(global_rt_nx,global_rt_ny), &
+           in(local_rt_nx,local_rt_ny)
+        call write_IO_RT_real(in,buf2)
+        if(my_id.eq.IO_id) write(unit) buf2
+     return
+     end subroutine write_restart_rt_2
+
+     subroutine write_restart_rt_3(unit,nz,in)
+        integer unit,nz,i
+        real buf3(global_rt_nx,global_rt_ny,nz),&
+          in(local_rt_nx,local_rt_ny,nz)
+        do i = 1,nz
+          call write_IO_RT_real(in(:,:,i),buf3(:,:,i))
+        end do
+        if(my_id.eq.IO_id) write(unit) buf3
+     return
+     end subroutine write_restart_rt_3
+
+   subroutine decompose_RT_real (in_buff,out_buff,g_nx,g_ny,nx,ny)
+! usage: all of the cpu call this subroutine.
+! the IO node will distribute the data to rest of the node.
+      integer g_nx,g_ny,nx,ny
+      real,intent(in),dimension(:,:) :: in_buff
+      real,intent(out),dimension(:,:) :: out_buff
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+
+      tag = 2
+      if(my_id .eq. IO_id) then
+         do i = 0, numprocs - 1
+            ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1) 
+            if(ibegin.gt.1) ibegin=ibegin - 1
+            iend   = ibegin + local_rt_nx_size(i+1) -1
+            jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+            if(jbegin.gt.1) jbegin=jbegin - 1
+            jend   = jbegin + local_rt_ny_size(i+1) -1
+
+            if(my_id .eq. i) then
+               out_buff=in_buff(ibegin:iend,jbegin:jend)
+            else
+               ! send data to the rest process.
+               size = (iend-ibegin+1)*(jend-jbegin+1)
+               call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,&
+                  MPI_REAL, i,tag,HYDRO_COMM_WORLD,ierr)
+            end if
+         end do
+      else
+         size = nx*ny
+         call mpi_recv(out_buff,size,MPI_REAL,IO_id, &
+                tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+      end if
+      return
+  end subroutine decompose_RT_real
+
+   subroutine decompose_RT_int (in_buff,out_buff,g_nx,g_ny,nx,ny)
+! usage: all of the cpu call this subroutine.
+! the IO node will distribute the data to rest of the node.
+      integer g_nx,g_ny,nx,ny
+      integer,intent(in),dimension(:,:) ::  in_buff
+      integer,intent(out),dimension(:,:) :: out_buff
+      integer tag, i, status, ierr,size
+      integer ibegin,iend,jbegin,jend
+
+      tag = 2
+        call mpp_land_sync()
+      if(my_id .eq. IO_id) then
+         do i = 0, numprocs - 1
+            ibegin = startx(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+            if(ibegin.gt.1) ibegin=ibegin - 1
+            iend   = ibegin + local_rt_nx_size(i+1) -1
+            jbegin = starty(i+1)*rt_AGGFACTRT - (rt_AGGFACTRT-1)
+            if(jbegin.gt.1) jbegin=jbegin - 1
+            jend   = jbegin + local_rt_ny_size(i+1) -1
+
+            if(my_id .eq. i) then
+               out_buff=in_buff(ibegin:iend,jbegin:jend)
+            else
+               ! send data to the rest process.
+               size = (iend-ibegin+1)*(jend-jbegin+1)
+               call mpi_send(in_buff(ibegin:iend,jbegin:jend),size,&
+                  MPI_INTEGER, i,tag,HYDRO_COMM_WORLD,ierr)
+            end if
+         end do
+      else
+         size = nx*ny
+         call mpi_recv(out_buff,size,MPI_INTEGER,IO_id, &
+                tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+      end if
+      return
+  end subroutine decompose_RT_int
+
+  subroutine getNX_NY(nprocs, nx,ny)
+  ! calculate the nx and ny based on the total nprocs.
+    integer nprocs, nx, ny
+    integer i,j, max
+    max = nprocs
+    do j = 1, nprocs
+       if( mod(nprocs,j) .eq. 0 ) then
+           i = nprocs/j
+           if( abs(i-j) .lt. max) then
+               max = abs(i-j)
+               nx = i 
+               ny = j 
+           end if
+       end if
+    end do
+  return 
+  end subroutine getNX_NY
+
+     subroutine pack_global_22(in,   &
+        out,k)
+        integer ix,jx,k,i
+        real out(global_nx,global_ny,k)
+        real  in(local_nx,local_ny,k)
+        do i = 1, k
+          call write_IO_real(in(:,:,i),out(:,:,i))
+        enddo
+     return 
+     end subroutine pack_global_22
+
+
+  subroutine wrf_LAND_set_INIT(info,total_pe,AGGFACTRT)
+    implicit none
+    integer total_pe
+    integer info(9,total_pe),AGGFACTRT
+    integer :: ierr, status
+    integer i
+
+      call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr )
+      call MPI_COMM_SIZE( HYDRO_COMM_WORLD, numprocs, ierr )
+
+      if(numprocs .ne. total_pe) then
+         write(6,*) "FATAL ERROR: In wrf_LAND_set_INIT() - numprocs .ne. total_pe ",numprocs, total_pe 
+         call mpp_land_abort()
+      endif
+
+
+!   ### get the neighbors.  -1 means no neighbor.
+      left_id = info(2,my_id+1)
+      right_id = info(3,my_id+1)
+      up_id =   info(4,my_id+1)
+      down_id = info(5,my_id+1)
+      IO_id = 0
+
+       allocate(local_nx_size(numprocs),stat = status) 
+       allocate(local_ny_size(numprocs),stat = status) 
+       allocate(local_rt_nx_size(numprocs),stat = status) 
+       allocate(local_rt_ny_size(numprocs),stat = status) 
+       allocate(starty(numprocs),stat = ierr) 
+       allocate(startx(numprocs),stat = ierr)
+
+       i = my_id + 1
+       local_nx = info(7,i) - info(6,i) + 1
+       local_ny = info(9,i) - info(8,i) + 1
+ 
+       global_nx = 0
+       global_ny = 0
+       do i = 1, numprocs
+          global_nx = max(global_nx,info(7,i))
+          global_ny = max(global_ny,info(9,i))
+       enddo
+
+       local_rt_nx = local_nx*AGGFACTRT+2
+       local_rt_ny = local_ny*AGGFACTRT+2
+       if(left_id.lt.0) local_rt_nx = local_rt_nx -1
+       if(right_id.lt.0) local_rt_nx = local_rt_nx -1
+       if(up_id.lt.0) local_rt_ny = local_rt_ny -1
+       if(down_id.lt.0) local_rt_ny = local_rt_ny -1
+
+       global_rt_nx = global_nx*AGGFACTRT
+       global_rt_ny = global_ny*AGGFACTRT
+       rt_AGGFACTRT = AGGFACTRT
+
+       do i =1,numprocs 
+          local_nx_size(i) = info(7,i) - info(6,i) + 1
+          local_ny_size(i) = info(9,i) - info(8,i) + 1
+          startx(i)        = info(6,i) 
+          starty(i)        = info(8,i) 
+
+          local_rt_nx_size(i) = (info(7,i) - info(6,i) + 1)*AGGFACTRT+2
+          local_rt_ny_size(i) = (info(9,i) - info(8,i) + 1 )*AGGFACTRT+2
+          if(info(2,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1
+          if(info(3,i).lt.0) local_rt_nx_size(i) = local_rt_nx_size(i) -1
+          if(info(4,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1
+          if(info(5,i).lt.0) local_rt_ny_size(i) = local_rt_ny_size(i) -1
+       enddo
+      return 
+      end   subroutine wrf_LAND_set_INIT
+
+      subroutine getMy_global_id()
+          integer ierr
+          call MPI_COMM_RANK( HYDRO_COMM_WORLD, my_id, ierr )
+      return
+      end subroutine getMy_global_id
+
+  subroutine MPP_CHANNEL_COM_REAL(Link_location,ix,jy,Link_V,size,flag)
+  ! communicate the data for channel routine.
+      implicit none
+      integer ix,jy,size
+      integer Link_location(ix,jy)
+      integer i,j, flag
+      real Link_V(size), tmp_inout(ix,jy)
+
+      tmp_inout = -999
+
+      if(size .eq. 0) then  
+            tmp_inout = -999
+      else
+
+         !     map the Link_V data to tmp_inout(ix,jy)
+         do i = 1,ix 
+            if(Link_location(i,1) .gt. 0) &
+               tmp_inout(i,1) = Link_V(Link_location(i,1))
+            if(Link_location(i,2) .gt. 0) &
+               tmp_inout(i,2) = Link_V(Link_location(i,2))
+            if(Link_location(i,jy-1) .gt. 0) &
+               tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1))
+            if(Link_location(i,jy) .gt. 0) &
+               tmp_inout(i,jy) = Link_V(Link_location(i,jy))
+          enddo
+         do j = 1,jy 
+            if(Link_location(1,j) .gt. 0) &
+               tmp_inout(1,j) = Link_V(Link_location(1,j))
+            if(Link_location(2,j) .gt. 0) &
+               tmp_inout(2,j) = Link_V(Link_location(2,j))
+            if(Link_location(ix-1,j) .gt. 0) &
+               tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j))
+            if(Link_location(ix,j) .gt. 0) &
+               tmp_inout(ix,j) = Link_V(Link_location(ix,j))
+         enddo
+    endif
+
+!   commu nicate tmp_inout
+    call MPP_LAND_COM_REAL(tmp_inout, ix,jy,flag)
+
+!map the data back to Link_V
+    if(size .eq. 0) return
+      do j = 1,jy 
+            if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) &
+               Link_V(Link_location(1,j)) = tmp_inout(1,j)
+            if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) &
+               Link_V(Link_location(2,j)) = tmp_inout(2,j)
+            if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) &
+               Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j)
+            if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )&
+               Link_V(Link_location(ix,j)) = tmp_inout(ix,j)
+      enddo
+      do i = 1,ix 
+            if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )&
+               Link_V(Link_location(i,1)) = tmp_inout(i,1)
+            if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )&
+               Link_V(Link_location(i,2)) = tmp_inout(i,2)
+            if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) &
+               Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1)
+            if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) &
+               Link_V(Link_location(i,jy)) = tmp_inout(i,jy)
+      enddo
+  end subroutine MPP_CHANNEL_COM_REAL
+
+  subroutine MPP_CHANNEL_COM_INT(Link_location,ix,jy,Link_V,size,flag)
+  ! communicate the data for channel routine.
+      implicit none
+      integer ix,jy,size
+      integer Link_location(ix,jy)
+      integer i,j, flag
+      integer Link_V(size), tmp_inout(ix,jy)
+
+      if(size .eq. 0) then  
+           tmp_inout = -999
+      else
+
+         !     map the Link_V data to tmp_inout(ix,jy)
+         do i = 1,ix 
+            if(Link_location(i,1) .gt. 0) &
+               tmp_inout(i,1) = Link_V(Link_location(i,1))
+            if(Link_location(i,2) .gt. 0) &
+               tmp_inout(i,2) = Link_V(Link_location(i,2))
+            if(Link_location(i,jy-1) .gt. 0) &
+               tmp_inout(i,jy-1) = Link_V(Link_location(i,jy-1))
+            if(Link_location(i,jy) .gt. 0) &
+               tmp_inout(i,jy) = Link_V(Link_location(i,jy))
+          enddo
+         do j = 1,jy 
+            if(Link_location(1,j) .gt. 0) &
+               tmp_inout(1,j) = Link_V(Link_location(1,j))
+            if(Link_location(2,j) .gt. 0) &
+               tmp_inout(2,j) = Link_V(Link_location(2,j))
+            if(Link_location(ix-1,j) .gt. 0) &
+               tmp_inout(ix-1,j) = Link_V(Link_location(ix-1,j))
+            if(Link_location(ix,j) .gt. 0) &
+               tmp_inout(ix,j) = Link_V(Link_location(ix,j))
+         enddo
+    endif
+
+!   commu nicate tmp_inout
+    call MPP_LAND_COM_INTEGER(tmp_inout, ix,jy,flag)
+
+!map the data back to Link_V
+    if(size .eq. 0) return
+      do j = 1,jy 
+            if( (Link_location(1,j) .gt. 0) .and. (tmp_inout(1,j) .ne. -999) ) &
+               Link_V(Link_location(1,j)) = tmp_inout(1,j)
+            if((Link_location(2,j) .gt. 0) .and. (tmp_inout(2,j) .ne. -999) ) &
+               Link_V(Link_location(2,j)) = tmp_inout(2,j)
+            if((Link_location(ix-1,j) .gt. 0) .and. (tmp_inout(ix-1,j) .ne. -999)) &
+               Link_V(Link_location(ix-1,j)) = tmp_inout(ix-1,j)
+            if((Link_location(ix,j) .gt. 0) .and. (tmp_inout(ix,j) .ne. -999) )&
+               Link_V(Link_location(ix,j)) = tmp_inout(ix,j)
+      enddo
+      do i = 1,ix 
+            if((Link_location(i,1) .gt. 0) .and. (tmp_inout(i,1) .ne. -999) )&
+               Link_V(Link_location(i,1)) = tmp_inout(i,1)
+            if( (Link_location(i,2) .gt. 0) .and. (tmp_inout(i,2) .ne. -999) )&
+               Link_V(Link_location(i,2)) = tmp_inout(i,2)
+            if((Link_location(i,jy-1) .gt. 0) .and. (tmp_inout(i,jy-1) .ne. -999) ) &
+               Link_V(Link_location(i,jy-1)) = tmp_inout(i,jy-1)
+            if((Link_location(i,jy) .gt. 0) .and. (tmp_inout(i,jy) .ne. -999) ) &
+               Link_V(Link_location(i,jy)) = tmp_inout(i,jy)
+      enddo
+  end subroutine MPP_CHANNEL_COM_INT
+     subroutine print_2(unit,in,fm)
+        integer unit
+        character(len=*) fm
+        real  buf2(global_nx,global_ny),&
+           in(local_nx,local_ny)
+        call write_IO_real(in,buf2)
+        if(my_id.eq.IO_id) write(unit,*) buf2
+     return
+     end subroutine print_2
+
+     subroutine print_rt_2(unit,in)
+        integer unit
+        real  buf2(global_nx,global_ny),&
+           in(local_nx,local_ny)
+        call write_IO_real(in,buf2)
+        if(my_id.eq.IO_id) write(unit,*) buf2
+     return
+     end subroutine print_rt_2
+
+     subroutine mpp_land_max_int1(v)
+        implicit none
+        integer v, r1, max
+        integer i, ierr, tag
+        if(my_id .eq. IO_id) then
+           max = v
+           do i = 0, numprocs - 1
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 101
+                 call mpi_recv(r1,1,MPI_INTEGER,i, &
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                 if(max <= r1) max = r1 
+              end if
+           end do
+       else
+           tag =  101
+           call mpi_send(v,1,MPI_INTEGER, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+       end if
+       call mpp_land_bcast_int1(max)
+       v = max
+       return
+     end subroutine mpp_land_max_int1
+     
+     subroutine mpp_land_max_real1(v)
+        implicit none
+        real v, r1, max
+        integer i, ierr, tag
+        if(my_id .eq. IO_id) then
+           max = v
+           do i = 0, numprocs - 1
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 101
+                 call mpi_recv(r1,1,MPI_REAL,i, &
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                 if(max <= r1) max = r1 
+              end if
+           end do
+       else
+           tag =  101
+           call mpi_send(v,1,MPI_REAL, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+       end if
+       call mpp_land_bcast_real1(max)
+       v = max
+       return
+     end subroutine mpp_land_max_real1
+
+     subroutine mpp_same_int1(v)   
+        implicit none
+        integer v,r1
+        integer i, ierr, tag
+        if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 109
+                 call mpi_recv(r1,1,MPI_INTEGER,i, &
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                 if(v .ne. r1) v = -99  
+              end if
+           end do
+       else
+           tag =  109
+           call mpi_send(v,1,MPI_INTEGER, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+       end if
+       call mpp_land_bcast_int1(v)
+     end subroutine mpp_same_int1
+
+
+
+     subroutine write_chanel_real(v,map_l2g,gnlinks,nlinks,g_v)   
+        implicit none
+        integer  gnlinks,nlinks, map_l2g(nlinks)
+        real recv(nlinks), v(nlinks)
+        ! real g_v(gnlinks), tmp_v(gnlinks)
+        integer i, ierr, tag, k
+        integer length, node, message_len
+        integer,allocatable,dimension(:) :: tmp_map
+        real, allocatable, dimension(:) :: tmp_v
+        real, dimension(:) :: g_v
+
+        if(my_id .eq. io_id) then
+           allocate(tmp_map(gnlinks))
+           allocate(tmp_v(gnlinks))
+           if(nlinks .le. 0) then
+               tmp_map = -999
+           else
+               tmp_map(1:nlinks) = map_l2g(1:nlinks)
+           endif
+        else
+           allocate(tmp_map(1))
+           allocate(tmp_v(1))
+        endif
+
+        if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1
+              message_len = mpp_nlinks(i+1)
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+
+                 tag = 109
+                 call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, &
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                   tag = 119
+
+                 call mpi_recv(tmp_v(1:message_len),message_len,MPI_REAL,i,  &
+                   tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+
+                 do k = 1,message_len
+                    node = tmp_map(k) 
+                    if(node .gt. 0) then
+                      g_v(node) = tmp_v(k)
+                    else
+#ifdef HYDRO_D
+                      write(6,*) "Maping infor k=",k," node=", node
+#endif
+                    endif
+                 enddo
+              else
+                 do k = 1,nlinks
+                    node = map_l2g(k) 
+                    if(node .gt. 0) then
+                      g_v(node) = v(k)
+                    else
+#ifdef HYDRO_D
+                      write(6,*) "local Maping infor k=",k," node=",node 
+#endif
+                    endif
+                 enddo
+              end if
+            
+           end do
+        else
+           tag =  109
+           call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+           tag = 119
+           call mpi_send(v,nlinks,MPI_REAL,IO_id,   &
+               tag,HYDRO_COMM_WORLD,ierr)
+
+        end if
+           if(allocated(tmp_map)) deallocate(tmp_map)
+           if(allocated(tmp_v)) deallocate(tmp_v)
+     end subroutine write_chanel_real
+
+     subroutine write_chanel_int(v,map_l2g,gnlinks,nlinks,g_v)   
+        implicit none
+        integer gnlinks,nlinks, map_l2g(nlinks)
+        integer ::  recv(nlinks), v(nlinks)
+        integer, allocatable, dimension(:) :: tmp_map , tmp_v
+        integer, dimension(:) :: g_v
+        integer i, ierr, tag, k
+        integer length, node, message_len
+
+        if(my_id .eq. io_id) then
+           allocate(tmp_map(gnlinks))
+           allocate(tmp_v(gnlinks))
+           if(nlinks .le. 0) then
+               tmp_map = -999
+           else
+               tmp_map(1:nlinks) = map_l2g(1:nlinks)
+           endif
+        else
+           allocate(tmp_map(1))
+           allocate(tmp_v(1))
+        endif
+
+
+        if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1
+              message_len = mpp_nlinks(i+1)
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+
+                 tag = 109
+                 call mpi_recv(tmp_map(1:message_len),message_len,MPI_INTEGER,i, &
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                   tag = 119
+
+                 call mpi_recv(tmp_v(1:message_len),message_len,MPI_INTEGER,i,  &
+                   tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+
+                 do k = 1,message_len
+                    if(tmp_map(k) .gt. 0) then
+                      node = tmp_map(k) 
+                      g_v(node) = tmp_v(k)
+                    else 
+#ifdef HYDRO_D
+                      write(6,*) "Maping infor k=",k," node=",tmp_v(k)
+#endif
+                    endif
+                 enddo
+              else
+                 do k = 1,nlinks
+                    if(map_l2g(k) .gt. 0) then
+                      node = map_l2g(k) 
+                      g_v(node) = v(k)
+                    else
+#ifdef HYDRO_D
+                      write(6,*) "Maping infor k=",k," node=",map_l2g(k)
+#endif
+                    endif
+                 enddo
+              end if
+            
+           end do
+        else
+           tag =  109
+           call mpi_send(map_l2g,nlinks,MPI_INTEGER, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+           tag = 119
+           call mpi_send(v,nlinks,MPI_INTEGER,IO_id,   &
+               tag,HYDRO_COMM_WORLD,ierr)
+        end if
+           if(allocated(tmp_map)) deallocate(tmp_map)
+           if(allocated(tmp_v)) deallocate(tmp_v)
+     end subroutine write_chanel_int
+
+
+
+     subroutine write_lake_real(v,nodelist_in,nlakes)   
+        implicit none
+        real recv(nlakes), v(nlakes)
+        integer nodelist(nlakes), nlakes, nodelist_in(nlakes)
+        integer i, ierr, tag, k
+        integer length, node
+
+        nodelist = nodelist_in
+        if(my_id .eq. IO_id) then
+           do i = 0, numprocs - 1
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 129
+                 call mpi_recv(nodelist,nlakes,MPI_INTEGER,i, &
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                   tag = 139
+                 call mpi_recv(recv(:),nlakes,MPI_REAL,i,  &
+                   tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+
+                 do k = 1,nlakes
+                    if(nodelist(k) .gt. -99) then
+                       node = nodelist(k) 
+                       v(node) = recv(node)
+                    endif
+                 enddo
+              end if
+            
+           end do
+        else
+           tag =  129
+           call mpi_send(nodelist,nlakes,MPI_INTEGER, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+           tag = 139
+           call mpi_send(v,nlakes,MPI_REAL,IO_id,   &
+               tag,HYDRO_COMM_WORLD,ierr)
+        end if
+     end subroutine write_lake_real
+
+     subroutine read_rst_crt_r(unit,out,size)
+         implicit none
+        integer unit, size, ierr,ierr2
+        real  out(size),out1(size)
+        if(my_id.eq.IO_id) then
+          read(unit,IOSTAT=ierr2,end=99) out1
+          if(ierr2.eq.0) out=out1
+        endif
+99      continue
+        call mpp_land_bcast_int1(ierr2)
+        if(ierr2 .ne. 0) return
+        call mpi_bcast(out,size,MPI_REAL,   &
+            IO_id,HYDRO_COMM_WORLD,ierr)
+     return
+     end subroutine read_rst_crt_r  
+
+         subroutine write_rst_crt_r(unit,cd,map_l2g,gnlinks,nlinks)
+         integer :: unit,gnlinks,nlinks,map_l2g(nlinks)
+         real cd(nlinks)
+         real g_cd (gnlinks)
+         call write_chanel_real(cd,map_l2g,gnlinks,nlinks, g_cd)
+         write(unit) g_cd
+         return
+         end subroutine write_rst_crt_r
+
+    subroutine sum_int1d(vin,nsize)
+       implicit none
+       integer nsize,i,j,tag,ierr
+       integer, dimension(nsize):: vin,recv
+       tag = 319
+       if(nsize .le. 0) return
+       if(my_id .eq. IO_id) then
+          do i = 0, numprocs - 1
+             if(i .ne. my_id) then
+               call mpi_recv(recv,nsize,MPI_INTEGER,i,  &
+                    tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               vin(:) = vin(:) + recv(:)
+             endif
+          end do
+       else
+             call mpi_send(vin,nsize,MPI_INTEGER,IO_id,   &
+                  tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       call mpp_land_bcast_int1d(vin) 
+       return
+    end subroutine sum_int1d
+
+    subroutine combine_int1d(vin,nsize, flag)
+       implicit none
+       integer nsize,i,j,tag,ierr, flag, k
+       integer, dimension(nsize):: vin,recv
+       tag = 319
+       if(nsize .le. 0) return
+       if(my_id .eq. IO_id) then
+          do i = 0, numprocs - 1
+             if(i .ne. my_id) then
+               call mpi_recv(recv,nsize,MPI_INTEGER,i,  &
+                    tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               do k = 1, nsize
+                  if(recv(k) .ne. flag) then
+                     vin(k) = recv(k)
+                  endif
+               enddo
+             endif
+          end do
+       else
+             call mpi_send(vin,nsize,MPI_INTEGER,IO_id,   &
+                  tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       call mpp_land_bcast_int1d(vin)
+       return
+    end subroutine combine_int1d
+
+
+
+    subroutine sum_real8(vin,nsize)
+       implicit none
+       integer nsize,i,j,tag,ierr
+       real*8, dimension(nsize):: vin,recv
+       real, dimension(nsize):: v 
+       tag = 319
+       if(my_id .eq. IO_id) then
+          do i = 0, numprocs - 1
+             if(i .ne. my_id) then
+               call mpi_recv(recv,nsize,MPI_DOUBLE_PRECISION,i,  &
+                    tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               vin(:) = vin(:) + recv(:)
+             endif
+          end do
+          v = vin
+       else
+             call mpi_send(vin,nsize,MPI_DOUBLE_PRECISION,IO_id,   &
+                  tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       call mpp_land_bcast_real(nsize,v) 
+       vin = v
+       return
+    end subroutine sum_real8
+
+!  subroutine get_globalDim(ix,g_ix)
+!     implicit none
+!     integer ix,g_ix, ierr
+!     include "mpif.h"
+!
+!     if ( my_id .eq. IO_id ) then
+!           g_ix = ix
+!        call mpi_reduce( MPI_IN_PLACE, g_ix, 4, MPI_INTEGER, &
+!             MPI_SUM, 0, HYDRO_COMM_WORLD, ierr )
+!     else
+!        call mpi_reduce( ix,       0,      4, MPI_INTEGER, &
+!             MPI_SUM,  0, HYDRO_COMM_WORLD, ierr )
+!     endif
+!      call mpp_land_bcast_int1(g_ix)
+!
+!     return
+!
+!  end subroutine get_globalDim
+
+  subroutine gather_1d_real_tmp(vl,s_in,e_in,vg,sg)
+    integer sg, s,e, size, s_in, e_in
+    integer index_s(2)
+    integer tag, ierr,i
+!   s: start index, e: end index
+    real  vl(e_in-s_in+1), vg(sg)
+    s = s_in
+    e = e_in
+
+    if(my_id .eq. IO_id) then 
+        vg(s:e) = vl
+    end if
+
+     index_s(1) = s
+     index_s(2) = e
+     size = e - s + 1 
+
+    if(my_id .eq. IO_id) then
+         do i = 0, numprocs - 1 
+              if(i .ne. my_id) then
+                 !block receive  from other node.
+                 tag = 202
+                 call mpi_recv(index_s,2,MPI_INTEGER,i, & 
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+
+                 tag = 203
+                 e = index_s(2)
+                 s = index_s(1)
+                 size = e - s + 1 
+                 call mpi_recv(vg(s:e),size,MPI_REAL,  &
+                    i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+              endif
+         end do
+     else 
+           tag =  202
+           call mpi_send(index_s,2,MPI_INTEGER, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+
+           tag =  203  
+           call mpi_send(vl,size,MPI_REAL,IO_id,   &
+               tag,HYDRO_COMM_WORLD,ierr)
+     end if
+
+     return 
+  end  subroutine gather_1d_real_tmp
+
+  subroutine sum_real1(inout)
+      implicit none
+      real:: inout, send
+      integer :: ierr
+      send = inout
+      CALL MPI_ALLREDUCE(send,inout,1,MPI_REAL,MPI_SUM,HYDRO_COMM_WORLD,ierr)
+  end subroutine sum_real1 
+
+  subroutine sum_double(inout)
+      implicit none
+      real*8:: inout, send
+      integer :: ierr
+      send = inout
+      !yw CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE,MPI_SUM,HYDRO_COMM_WORLD,ierr)
+      CALL MPI_ALLREDUCE(send,inout,1,MPI_DOUBLE_PRECISION,MPI_SUM,HYDRO_COMM_WORLD,ierr)
+  end subroutine sum_double
+
+  subroutine mpp_chrt_nlinks_collect(nlinks)
+  ! collect the nlinks
+       implicit none
+       integer :: nlinks
+       integer :: i, ierr, status, tag
+       allocate(mpp_nlinks(numprocs),stat = status) 
+                 tag = 138
+       mpp_nlinks = 0
+       if(my_id .eq. IO_id) then
+          do i = 0,numprocs -1
+            if(i .ne. my_id) then
+               call mpi_recv(mpp_nlinks(i+1),1,MPI_INTEGER,i, &
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+            else
+               mpp_nlinks(i+1) = 0
+            end if
+          end do
+       else
+           call mpi_send(nlinks,1,MPI_INTEGER, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+       endif
+
+     
+  end subroutine mpp_chrt_nlinks_collect
+
+     subroutine  getLocalXY(ix,jx,startx,starty,endx,endy)
+!!! this is for NoahMP only
+        implicit none
+        integer:: ix,jx,startx,starty,endx,endy
+        startx = local_startx
+        starty = local_starty
+        endx = startx + ix -1
+        endy = starty + jx -1
+     end subroutine getLocalXY
+
+     subroutine check_landreal1(unit, inVar)
+        implicit none
+        integer :: unit
+        real :: inVar
+        if(my_id .eq. IO_id) then
+           write(unit,*) inVar
+           call flush(unit)
+        endif
+     end subroutine check_landreal1
+
+     subroutine check_landreal1d(unit, inVar)
+        implicit none
+        integer :: unit
+        real :: inVar(:)
+        if(my_id .eq. IO_id) then
+           write(unit,*) inVar
+           call flush(unit)
+        endif
+     end subroutine check_landreal1d
+     subroutine check_landreal2d(unit, inVar)
+        implicit none
+        integer :: unit
+        real :: inVar(:,:)
+        real :: g_var(global_nx,global_ny)
+        call write_io_real(inVar,g_var) 
+        if(my_id .eq. IO_id) then
+           write(unit,*) g_var 
+           call flush(unit)
+        endif
+     end subroutine check_landreal2d
+
+     subroutine check_landreal3d(unit, inVar)
+        implicit none
+        integer :: unit, k, klevel
+        real :: inVar(:,:,:)
+        real :: g_var(global_nx,global_ny)
+        klevel = size(inVar,2)
+        do k = 1, klevel
+           call write_io_real(inVar(:,k,:),g_var) 
+           if(my_id .eq. IO_id) then
+              write(unit,*) g_var
+              call flush(unit)
+           endif
+        end do
+     end subroutine check_landreal3d
+
+     subroutine mpp_collect_1d_int(nlinks,vinout)
+  ! collect the nlinks
+       implicit none
+       integer :: nlinks
+       integer :: i, ierr, status, tag
+       integer, dimension(nlinks) :: vinout
+       integer, dimension(nlinks) :: buf
+       tag = 139
+       call mpp_land_sync()
+       if(my_id .eq. IO_id) then
+          do i = 0,numprocs -1
+            if(i .ne. my_id) then
+               call mpi_recv(buf,nlinks,MPI_INTEGER,i, &
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               vinout = vinout + buf
+            end if
+          end do
+       else
+           call mpi_send(vinout,nlinks,MPI_INTEGER, IO_id,     &
+               tag,HYDRO_COMM_WORLD,ierr)
+       endif
+       call mpp_land_sync()
+       call mpp_land_bcast_int1d(vinout)
+    
+  end subroutine mpp_collect_1d_int
+
+  subroutine mpp_collect_1d_int_mem(nlinks,vinout)
+  ! consider the memory and big size data transport
+  ! collect the nlinks
+       implicit none
+       integer :: nlinks
+       integer :: i, ierr, status, tag
+       integer, dimension(nlinks) :: vinout, tmpIn
+       integer, dimension(nlinks) :: buf
+       integer :: lsize, k,m
+       integer, allocatable, dimension(:) :: tmpBuf
+
+       call mpp_land_sync()
+       if(my_id .eq. IO_id) then
+          allocate (tmpBuf(nlinks))
+          do i = 0,numprocs -1
+            if(i .ne. my_id) then
+               tag = 120
+               call mpi_recv(lsize,1,MPI_INTEGER,i, &
+                      tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               if(lsize .gt. 0) then
+                   tag = 121
+                   call mpi_recv(tmpBuf(1:lsize),lsize,MPI_INTEGER,i, &
+                        tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+                   do k = 1, lsize
+                      m = tmpBuf(k)
+                      vinout(m) = 1
+                   end do
+               endif
+            end if
+          end do
+          if(allocated(tmpBuf)) deallocate(tmpBuf)
+       else 
+           lsize = 0
+           do k = 1, nlinks
+               if(vinout(k) .gt. 0) then
+                  lsize = lsize + 1
+                  tmpIn(lsize) = k        
+               end if
+           end do 
+           tag = 120
+           call mpi_send(lsize,1,MPI_INTEGER, IO_id,     &
+                 tag,HYDRO_COMM_WORLD,ierr)
+           if(lsize .gt. 0) then
+              tag = 121
+              call mpi_send(tmpIn(1:lsize),lsize,MPI_INTEGER, IO_id,     &
+                 tag,HYDRO_COMM_WORLD,ierr)
+           endif
+       endif
+       call mpp_land_sync()
+       call mpp_land_bcast_int1d(vinout)
+   
+  end subroutine mpp_collect_1d_int_mem
+
+! stop the job due to the fatal error.
+      subroutine fatal_error_stop(msg)
+        character(len=*) :: msg
+        integer :: ierr
+      write(6,*) "The job is stoped due to the fatal error. ", trim(msg)
+      call flush(6)
+      call mpp_land_abort()
+      call MPI_finalize(ierr)
+     return
+     end  subroutine fatal_error_stop
+
+     subroutine updateLake_seqInt(in,nsize,in0)
+       implicit none
+       integer :: nsize
+       integer, dimension(nsize) :: in
+       integer, dimension(nsize) :: tmp
+       integer, dimension(:) :: in0
+       integer tag, i, status, ierr, k
+       if(nsize .le. 0) return
+
+       tag = 29
+       if(my_id .ne. IO_id) then
+          call mpi_send(in,nsize,MPI_INTEGER, IO_id,     &
+                tag,HYDRO_COMM_WORLD,ierr)
+       else
+          do i = 0, numprocs - 1
+            if(i .ne. IO_id) then
+               call mpi_recv(tmp,nsize,&
+                   MPI_INTEGER,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               do k = 1, nsize 
+                  if(in0(k) .ne. tmp(k)) in(k) = tmp(k)
+               end do
+            end if
+          end do
+       end if
+       call mpp_land_bcast_int1d(in)
+     
+     end subroutine updateLake_seqInt
+
+     subroutine updateLake_seq(in,nsize,in0)
+       implicit none
+       integer :: nsize
+       real, dimension(nsize) :: in
+       real, dimension(nsize) :: tmp
+       real, dimension(:) :: in0
+       integer tag, i, status, ierr, k
+       if(nsize .le. 0) return
+
+       tag = 29
+       if(my_id .ne. IO_id) then
+          call mpi_send(in,nsize,MPI_REAL, IO_id,     &
+                tag,HYDRO_COMM_WORLD,ierr)
+       else
+          do i = 0, numprocs - 1
+            if(i .ne. IO_id) then
+               call mpi_recv(tmp,nsize,&
+                   MPI_REAL,i,tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               do k = 1, nsize 
+                  if(in0(k) .ne. tmp(k)) in(k) = tmp(k)
+               end do
+            end if
+          end do
+       end if
+       call mpp_land_bcast_real_1d(in)
+     
+     end subroutine updateLake_seq
+
+!subroutine match1dLake:
+!global lake. Find the same lake and mark as flag
+! default of win is 0
+    subroutine match1dLake(vin,nsize,flag)
+       implicit none
+       integer nsize,i,j,tag,ierr, flag, k
+       integer, dimension(nsize):: vin,recv
+       tag = 319
+       if(nsize .le. 0) return
+       if(my_id .eq. IO_id) then
+          do i = 0, numprocs - 1
+             if(i .ne. my_id) then
+               call mpi_recv(recv,nsize,MPI_INTEGER,i,  &
+                    tag,HYDRO_COMM_WORLD,mpp_status,ierr)
+               do k = 1, nsize 
+                 if(recv(k) .eq. flag) vin(k) = flag
+                 if(vin(k) .ne. flag) then
+                   if(vin(k) .gt. 0 .and. recv(k) .gt. 0) then
+                       vin(k) = flag
+                   else
+                       if(recv(k) .gt. 0) vin(k) = recv(k)
+                   endif 
+                 endif
+               end do
+             endif
+          end do
+       else
+             call mpi_send(vin,nsize,MPI_INTEGER,IO_id,   &
+                  tag,HYDRO_COMM_WORLD,ierr)
+       endif   
+       call mpp_land_bcast_int1d(vin)
+       return  
+    end subroutine match1dLake
+
+        subroutine mpp_land_abort()
+            implicit none
+            integer ierr
+            CALL MPI_ABORT(HYDRO_COMM_WORLD,1,IERR)
+        end subroutine mpp_land_abort ! mpp_land_abort
+
+  subroutine mpp_land_sync()
+      implicit none
+      integer ierr
+      call MPI_barrier( HYDRO_COMM_WORLD ,ierr)
+      if(ierr .ne. 0) call mpp_land_abort()
+      return
+  end subroutine mpp_land_sync ! mpp_land_sync
+
+
+    subroutine mpp_comm_scalar_real(scalar, fromImage, toImage)
+    implicit none
+    real,    intent(inout) :: scalar
+    integer, intent(in)    :: fromImage, toImage
+    integer:: ierr, tag
+    tag=2   
+    if(my_id .eq. fromImage) &
+         call mpi_send(scalar, 1, MPI_REAL, &
+                       toImage, tag, HYDRO_COMM_WORLD, ierr)
+    if(my_id .eq. toImage) &
+         call mpi_recv(scalar, 1, MPI_REAL, &
+                       fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr)
+    end subroutine mpp_comm_scalar_real
+
+    subroutine mpp_comm_scalar_char(scalar, fromImage, toImage)
+    implicit none
+    character(len=*), intent(inout) :: scalar
+    integer,          intent(in)    :: fromImage, toImage
+    integer:: ierr, tag, length
+    tag=2
+    length=len(scalar)
+    if(my_id .eq. fromImage) &
+         call mpi_send(scalar, length, MPI_CHARACTER, &
+                       toImage, tag, HYDRO_COMM_WORLD, ierr)
+    if(my_id .eq. toImage) &
+         call mpi_recv(scalar, length, MPI_CHARACTER, &
+                       fromImage, tag, HYDRO_COMM_WORLD, mpp_status, ierr)
+    end subroutine mpp_comm_scalar_char
+
+    
+    
+END MODULE MODULE_MPP_LAND
+
+
+
diff --git a/wrfv2_fire/hydro/README.hydro b/wrfv2_fire/hydro/README.hydro
new file mode 100644
index 00000000..c146626a
--- /dev/null
+++ b/wrfv2_fire/hydro/README.hydro
@@ -0,0 +1,123 @@
+
+There are two parts in thi readme file.
+Part I is for fully coupled with WRF model. Part II is for offline version.
+
+
+Part I Fully coupled with WRF Model
+1. Building
+
+1) General description
+WRF-Hydro is a coupling architecture designed to simplify the coupling of terrestrial 
+hydrological models with the WRF model. The WRF-Hydro system is compiled as an independent 
+library to link with the WRF model and called by the WRF model as a function. The calling 
+of WRF-Hydro within the WRF model is controlled by a macro definition that is specified 
+as an environment setting during the compiling process. When WRF-Hydro is not activated 
+within the environment setting before the WRF configuration process, the entire system 
+defaults to the standard WRF model. To compile WRF-Hydro system, user only needs to set 
+environment variable ("setenv WRF_HYDRO 1"), and then follow the standard WRF model 
+configure and compiling process.
+
+2) Environment settings
+The following environment variables need to be set before configuring and compiling the WRF-HYDRO model, 
+(those are defined in setEnvar.csh for offline). The compiling scripts will automatic source setEnvar.csh.
+
+setenv WRF_HYDRO 1
+"1" is to activate WRF-Hydro. "0" or no definition will default to the WRF model only.
+
+setenv HYDRO_D 1
+A "1" for HYDRO_D results in WRF-Hydro producing some run-time diagnostic information. 
+When HYDRO_D is set to "0 "or not defined, the diagnostic information will not be produced 
+during run-time. 
+
+You can explicitly set the "NETCDF_INC" and "NETCDF_LIB" environment variables or just set "NETCDF".  
+If you only set "NETCDF" environment variable, the default NETCDF_INC and NETCDF_LIB inside WRF-Hydro 
+will be "$NETCDF/include" and "NETCDF/lib".
+
+setenv NETCDF_INC   "$path/netcdf/include"
+setenv NETCDF_LIB   "$path/netcdf/lib"
+
+"NETCDF_INC" and "NETCDF_LIB" are defined for the WRF-Hydro only and can be different from those 
+set for the WRF model. WRF-Hydro has two netcdf libraries for Fortran and C respectively: 
+libnetcdff and ibnetcdf. If the user's netcdf library combined them together (only has one), 
+the user will need to manually change this part in order to successfully compile WRF-Hydro. 
+See the section below on porting about how to change this.
+
+Notes:  If you are going to create model output file that is more than 2Gb,
+      you should consider using netCDF large file support function. To activate
+      this, one must set the environment variable WRFIO_NCD_LARGE_FILE_SUPPORT.
+      In c-shell environment, do
+
+      setenv WRFIO_NCD_LARGE_FILE_SUPPORT 1
+
+3) Configuring and compiling
+On the following platforms, the configuring and compiling commands are the same as WRF model 
+after the user has set up the above four environment variables. 
+The compiler options IBM AIX with xlf fortran are not fully tested. 
+Other three pgi, gfortran and intel are tested.
+As stated above, the WRF-Hydro system is called as a function inside the WRF model and thus only one executable 
+is created when WRF-Hydro is compiled with WRF.  If user compiles the system successfully, 
+only a single "wrf.exe" file will be created.
+
+2. Running
+
+The fully coupled WRF/WRF-Hydro system has the same running or execution command as that of WRF.  
+Generally the same parameters and initial files are used as when normally running WRF.  However, 
+WRF-Hydro has an additional namelist called "hydro.namelist" as well as some additional parameter 
+files (.TBL files) that are located under the "hydro/Run" directory. Users need to copy those 
+files to the directory where the "wrf.exe" is going to be executed. 
+
+For a WRF-Hydro cold start run (i.e. not from a restart file), the user needs to provide three 
+additional files that are specified in the "hydro.namelist": "GEO_STATIC_FLNM", "GEO_FINEGRID_FLNM" 
+and, depending on whether or not the baseflow-bucket model is activated, "gwbasmskfil".
+
+For running WRF-Hydro from restart file, the user needs to uncomment RESTART_FILE from 
+"hydro.namelist" by removing "!" and provide the exact name for the existing restart file 
+to be used.  Running from a restart condition is common when the land surface has been 
+`spun-up' by running WRF-Hydro in an offline or `uncoupled' capacity.
+
+3. Porting
+
+The WRF-Hydro does not presently support OPENMP. The default support platform is Linux 
+with the PGI compiler, IBM AIX with the xlf fortran compiler, and Linux with the GFORTRAN 
+(sequential) compiler. However, WRF-Hydro is fairly easy to port to other systems.  
+The basic steps to do so are as follows:
+
+1) Edit "hydro/configure", and add "exit(0);" to the second line so that "configure" will not be executed.
+2) Edit "hydro/macros" to set desired compiling options. 
+3) Under hydro/WRF_cpl directory:
+"make -f Makefile.cpl clean"
+"make -f Makefile.cpl "
+
+If there is no error, then user can compile the fully coupled WRF and WRF-Hydro model on the new platform.
+
+4. Realtime mode: 
+For realtime mode, user need to do setenv HYDRO_REALTIME before compiling the code. 
+This will thin the output. 
+
+Part II Offline compiling
+Under hydro/ directory.
+1. setenv WRF_HYDRO 1
+2. setenv NETCDF your_netcdf_library_path
+or
+setenv NETCDF_INC   "$path/netcdf/include"
+setenv NETCDF_LIB   "$path/netcdf/lib"
+3. ./configure    
+     -------> choose correct compiler
+4. ./compile_offline_NoahMP.csh   
+     ---->compile offine version with NoahMP driver
+or
+ ./compile_offline_Noah.csh  
+     ----->compile offline version with Noah driver
+5. Executable files are created under hydro/Run directory.
+
+Note: Noah and NoahMP have the same name of "namelist.hrldas". But they are different.
+
+
+6. Other Issues
+If you are doing fully coupled run and your fine mesh grid time step is  <= 1.
+
+Edit the file "dyn_em/module_first_rk_step_part1.F", change the line from
+if(HYDRO_dt .gt. 1 ) call wrf_drv_HYDRO(HYDRO_dt, grid,  &
+to
+if(HYDRO_dt .gt. 0 ) call wrf_drv_HYDRO(HYDRO_dt, grid,  &
+
diff --git a/wrfv2_fire/hydro/Rapid_routing/.gitignore b/wrfv2_fire/hydro/Rapid_routing/.gitignore
new file mode 100644
index 00000000..c79cdb9a
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/.gitignore
@@ -0,0 +1,24 @@
+#*******************************************************************************
+#.gitignore
+#*******************************************************************************
+
+#Purpose:
+#The git program is informed here to ignore the following files while performing 
+#its distributed revision control and source code management. 
+#Author:
+#Cedric H. David, 2014
+
+
+#*******************************************************************************
+#List of files that git will ignore
+#*******************************************************************************
+
+#-------------------------------------------------------------------------------
+#Initial releases of RAPID included batch submission scripts for supercomputers
+#-------------------------------------------------------------------------------
+job_*
+
+#-------------------------------------------------------------------------------
+#Legacy name for BSD 3-clause license of RAPID between 20120831 - 20131113 
+#-------------------------------------------------------------------------------
+rapid_license.txt
diff --git a/wrfv2_fire/hydro/Rapid_routing/LICENSE b/wrfv2_fire/hydro/Rapid_routing/LICENSE
new file mode 100644
index 00000000..dfe4b437
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/LICENSE
@@ -0,0 +1,24 @@
+Copyright (c) 2007-2013, Cedric H. David
+
+All rights reserved. 
+
+Redistribution and use in source and binary forms, with or without modification,
+are permitted provided that the following conditions are met: 
+* Redistributions of source code must retain the above copyright notice, this 
+  list of conditions and the following disclaimer. 
+* Redistributions in binary form must reproduce the above copyright notice, this 
+  list of conditions and the following disclaimer in the documentation and/or 
+  other materials provided with the distribution.
+* The name Cedric H. David may not be used to endorse or promote products 
+  derived from this software without specific prior written permission. 
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND 
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 
+DISCLAIMED. IN NO EVENT SHALL CEDRIC H. DAVID BE LIABLE FOR ANY DIRECT, 
+INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, 
+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 
diff --git a/wrfv2_fire/hydro/Rapid_routing/README b/wrfv2_fire/hydro/Rapid_routing/README
new file mode 100644
index 00000000..40f79a65
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/README
@@ -0,0 +1,9 @@
+The Routing Application for Parallel computatIon of Discharge (RAPID) is a river
+network routing model. Given surface and groundwater inflow to rivers, this 
+model can compute flow and volume of water everywhere in river networks made out 
+of many thousands of reaches. 
+
+For further information on RAPID including peer-reviewed publications, a manual, 
+sample input/output data, sample processing scripts and animations of model 
+results, please go to: 
+http://www.ucchm.org/david/rapid.htm
diff --git a/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_drv.F90 b/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_drv.F90
new file mode 100644
index 00000000..46ac6511
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_drv.F90
@@ -0,0 +1,18 @@
+program main_program
+  use hrldas_RAPID_wrapper , only : hrldas_RAPID_ini,hrldas_RAPID_exe
+  implicit none
+
+  integer, parameter :: ii = 224
+  integer, parameter :: jj = 242
+  real,dimension(ii,jj) :: runoff
+  integer ITIME, NTIME
+!  character(len=100) :: Qout_nc_file = './RAPID.with.WRF_hydro.0000.nc'
+
+  call hrldas_RAPID_ini(NTIME)
+
+  do ITIME=1,NTIME
+    call hrldas_RAPID_exe(runoff,ii,jj)
+  end do  
+! end loop for calling RAPID programs
+   
+  end 
diff --git a/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_wrapper.F90 b/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_wrapper.F90
new file mode 100644
index 00000000..c4a99b5c
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/hrldas_RAPID_wrapper.F90
@@ -0,0 +1,210 @@
+module hrldas_RAPID_wrapper
+!---This Wrapper provides an interface for WRF-Hydro to call RAPID--
+!	If not initialized, do initialization first
+!	If initialized, continue RAPID computation
+!---The Wrapper also contains RAPID coupler, which defines where
+!	LSM runoff is mapped into vector-based river reaches
+!---Author:
+!---Peirong Lin, 2014-2015---------------------------------------
+
+use rapid_var, only : namelist_file,                                  &
+                      Qout_file,                                      &
+                      ZV_read_riv_tot,ZV_read_obs_tot,ZV_read_hum_tot,&
+                      IS_riv_tot,IS_riv_bas,JS_riv_tot,               &
+                      IV_riv_bas_id,IV_riv_index,IV_riv_loc1,         &
+                      ierr,stage,rank,                                &
+                      ZS_TauR
+
+#include "finclude/petscsys.h"
+#include "finclude/petscvec.h"
+#include "finclude/petscvec.h90"
+#include "finclude/petscmat.h"
+#include "finclude/petscksp.h"
+#include "finclude/petscpc.h"
+#include "finclude/petscviewer.h"
+#include "finclude/petsclog.h"
+#ifndef NO_TAO
+#include "finclude/taosolver.h"
+#endif
+
+!--LPR defined variables for RAPID loop---------
+integer cnt_rapid_run
+logical initialized
+character(len=100) :: str
+character(len=100) :: Qout_nc_dir
+character(len=100) :: Qout_nc_file  !---LPR: RAPID output file name--
+integer, dimension(:), allocatable :: IV_i_index
+integer, dimension(:), allocatable :: IV_j_index
+real, dimension(:), allocatable :: ZV_areakm !--LPR: size depending on rivers
+
+CONTAINS
+
+!---SUBROUTINE TO LINK WITH WRF-HYDRO-----------------
+  subroutine hrldas_RAPID_ini(ntime)
+!    use rapid_main , only : rapid_ini
+    implicit none
+    integer :: ntime
+ 
+    if (rank==0) then
+      print *,'RAPID initialized = ',initialized
+      if(initialized)  return  !If not first time initialization
+
+      print *,'***********************************************************'
+      print *,'*******Initialize RAPID model******************************'
+      print *,'***********************************************************'
+      call rapid_ini(ntime)
+      initialized = .True.
+    end if
+    
+    call PetscLogStageRegister('Read Comp Write',stage,ierr)
+    call PetscLogStagePush(stage,ierr)
+  end subroutine hrldas_RAPID_ini
+
+
+
+!---SUBROUTINE TO LINK WITH WRF-HYDRO & DRIVE RAPID -----------------
+  subroutine hrldas_RAPID_exe(runoff,ii,jj)
+!    use rapid_main , only : rapid_main_exe
+    implicit none
+    real,dimension(ii,jj) :: runoff
+    integer :: ii,jj
+
+    !---LPR: convert LSM runoff to mm/hour (previous: mm, total runoff in a time step)
+    runoff = runoff/ZS_TauR*3600  !if LSM=3hrly, original runoff is in
+
+    !---LPR: MPI debug information------------------
+    !write(70+rank,*) "yywww test inside the rapid "
+    !call flush(70+rank)
+
+    if (rank==0) then
+      if(cnt_rapid_run==0) then
+        Qout_nc_dir = Qout_file !---define RAPID output director--------
+      end if
+      cnt_rapid_run = cnt_rapid_run + 1
+      !---LPR: define RAPID output filenames----------------------------
+      if (cnt_rapid_run < 10) then
+        write(str,100) cnt_rapid_run
+100     format('0000',i1)
+      else if (cnt_rapid_run < 100) then
+        write(str,200) cnt_rapid_run
+200     format('000',i2)
+      else if (cnt_rapid_run < 1000) then
+        write(str,300) cnt_rapid_run
+300     format('00',i3)
+      else if (cnt_rapid_run < 10000) then
+        write(str,400) cnt_rapid_run
+400     format('0',i4)
+      else
+        write(str,'(i5)') cnt_rapid_run
+      end if
+      Qout_nc_file = trim(Qout_nc_dir)//'RAPID.with.WRF_hydro.'//trim(str)//'.nc'
+      print *,'RAPID output Qout_nc_file = ',trim(Qout_nc_file)
+    end if
+
+    call rapid_main(1,runoff,ii,jj,Qout_nc_file)
+    
+    !--LPR: add to test runoff in RESTART run mode, can remove this later-----------
+    !if(cnt_rapid_run == 2) then
+    !    write(81,*) runoff
+    !endif    
+
+  end subroutine hrldas_RAPID_exe
+
+
+
+!-----------RAPID initialization call----------------------------------------------
+  subroutine rapid_ini(NTIME)
+    implicit none
+    integer NTIME
+    namelist_file='./rapid_namelist'
+
+    if (rank==0) then
+      print *,'First time RAPID initialization ... &
+          May take a while depending on size of river network ... &
+          ... Wait ...'
+      call rapid_init
+    end if    
+
+  end subroutine rapid_ini
+
+
+
+!--------------RAPID coupler: gridded runoff to vector runoff-----------------------  
+  subroutine rapid_runoff_to_inflow(ZM_runoff,ZV_Vlat,cnt_rapid_run)
+    implicit none
+
+    real, dimension(:,:), intent(in) :: ZM_runoff
+    Vec, intent(out) :: ZV_Vlat
+    integer :: cnt_rapid_run
+    integer :: JS_lon,JS_lat
+    character(len=100) :: rapid_coupling_file='./rapid_input_tx/RAPID_coupling_WRF_hydro.csv'
+    !---LPR: need to optimize code-----
+
+    !----------tease out weird runoff values-----------
+    if (rank==0) then
+      if (maxval(ZM_runoff)>1000) stop 'Runoff exceeds 1000'
+      if (minval(ZM_runoff)<0) stop 'Negative runoff'
+    !print *, 'Maximum value for ZM_runoff is:', maxval(ZM_runoff)
+    end if
+
+    !----------COUPLING START----------------------------
+    if (rank==0) then
+      !---initialize river reaches--------------------------------------
+      do JS_riv_tot=1,IS_riv_tot
+        ZV_read_riv_tot(JS_riv_tot) = 0.
+      end do
+
+      if (cnt_rapid_run==1) then
+        allocate(IV_i_index(IS_riv_tot))
+        allocate(IV_j_index(IS_riv_tot))
+        allocate(ZV_areakm(IS_riv_tot))
+        !If first time RAPID call: read coupling files
+        !----------OPTION 1: Catchment centroid-based coupling-----------
+        open(88,file=rapid_coupling_file,status='old')
+        do JS_riv_tot=1,IS_riv_tot
+          read(88,*) IV_riv_bas_id(JS_riv_tot),ZV_areakm(JS_riv_tot), &
+                   IV_i_index(JS_riv_tot),IV_j_index(JS_riv_tot)
+        end do
+        close(88)
+        print *,' LPR CHECK river 30000 ',IV_riv_bas_id(30000),ZV_areakm(30000), &
+                IV_i_index(30000),IV_j_index(30000)        
+        !---------END OPTION 1----------------------------------
+         
+        !---------OPTION 2: Area-weighted coupling----------------------
+
+        !--------END OPTION 2-----------------------------------
+
+        print *,'****First time: RAPID read coupling file successfully************'
+      end if !---LPR: only read coupling inforamtion once---------------
+
+      !---LPR: actual coupling (mapping runoff from LSM to rivers)------------
+      do JS_riv_tot=1,IS_riv_tot
+        JS_lon=IV_i_index(JS_riv_tot)
+        JS_lat=IV_j_index(JS_riv_tot)
+        !print *,'Location ::: ',JS_lon,JS_lat
+        !print *,'Values ::: ',ZM_runoff(JS_lon,JS_lat),ZV_areakm(JS_riv_tot)
+        ZV_read_riv_tot(JS_riv_tot)=ZM_runoff(JS_lon,JS_lat) &
+              *ZV_areakm(JS_riv_tot)*1000
+        !with runoff in kg/m2=mm and area in km2
+        !----LPR CHECK POINTS------------
+        if(JS_riv_tot .eq. 30000) then
+          print *,'***LPR CHECK*** m3_riv value = ',ZV_read_riv_tot(JS_riv_tot)
+        end if
+      end do
+
+      print *, '************************************************************'
+      print *, '***** LPR: RAPID coupling successful! **********************'
+      print *, '************************************************************'
+    end if
+        
+    !------write to PETSC vector---------------------------
+    if (rank==0) then
+      print *,' number of river reaches  = ',IS_riv_bas
+      call VecSetValues(ZV_Vlat,IS_riv_bas,IV_riv_loc1,&
+               ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr)
+    end if
+    call VecAssemblyBegin(ZV_Vlat,ierr)
+    call VecAssemblyEnd(ZV_Vlat,ierr)
+  end subroutine rapid_runoff_to_inflow
+
+end module hrldas_RAPID_wrapper
diff --git a/wrfv2_fire/hydro/Rapid_routing/makefile b/wrfv2_fire/hydro/Rapid_routing/makefile
new file mode 100644
index 00000000..41297072
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/makefile
@@ -0,0 +1,245 @@
+#*******************************************************************************
+#makefile
+#*******************************************************************************
+
+#Purpose:
+#This file, along with the make utility allows compiling/linking RAPID
+#Author:
+#Cedric H. David, 2008-2015
+
+
+#*******************************************************************************
+#PETSc and TAO rules and variables (where environment variables and options are)
+#*******************************************************************************
+
+#-------------------------------------------------------------------------------
+#Default RAPID - includes optimization with TAO 
+#-------------------------------------------------------------------------------
+#FPPFLAGS=
+#include ${TAO_DIR}/conf/tao_base
+
+#-------------------------------------------------------------------------------
+#If want to use RAPID without TAO, in which case the optimization is unavailable
+#-------------------------------------------------------------------------------
+FPPFLAGS=-D NO_TAO
+include ${PETSC_DIR}/conf/variables
+include ${PETSC_DIR}/conf/rules
+#include ${PETSC_DIR}/lib/petsc/conf/variables
+#include ${PETSC_DIR}/lib/petsc/conf/rules
+#PETSC_FC_INCLUDES=-I/work/02151/peirongl/_code_wrfhydro/wrf_hydro_model/trunk/NDHMS/petsc-3.6.2/include/
+#PETSC_LIB=-L/work/02151/peirongl/_code_wrfhydro/wrf_hydro_model/trunk/NDHMS/petsc-3.6.2/lib/
+
+#*******************************************************************************
+#Location of netCDF include and lib directories
+#*******************************************************************************
+NETCDF_LIB=-L ${TACC_NETCDF_LIB} -lnetcdf
+NETCDF_INCLUDE=-I ${TACC_NETCDF_INC}
+
+
+#*******************************************************************************
+#makefile instructions 
+#*******************************************************************************
+
+#-------------------------------------------------------------------------------
+#Test that environment variables are properly read by make
+#-------------------------------------------------------------------------------
+dummy: 
+	echo ${FLINKER} ${FPPFLAGS}
+
+#-------------------------------------------------------------------------------
+#Link RAPID main
+#-------------------------------------------------------------------------------
+rapid:	rapid_main.o \
+	rapid_init.o \
+	rapid_read_namelist.o \
+	rapid_arrays.o \
+	rapid_create_obj.o \
+	rapid_create_Qout_file.o \
+	rapid_open_Qout_file.o \
+	rapid_open_Vlat_file.o \
+	rapid_open_Qobs_file.o \
+	rapid_open_Qfor_file.o \
+	rapid_open_Qhum_file.o \
+	rapid_write_Qout_file.o \
+	rapid_read_Vlat_file.o \
+	rapid_read_Qobs_file.o \
+	rapid_read_Qfor_file.o \
+	rapid_read_Qhum_file.o \
+	rapid_close_Qout_file.o \
+	rapid_close_Vlat_file.o \
+	rapid_close_Qobs_file.o \
+	rapid_close_Qfor_file.o \
+	rapid_close_Qhum_file.o \
+	rapid_get_Qdam.o \
+	rapid_set_Qext0.o \
+	rapid_hsh_mat.o \
+	rapid_net_mat.o \
+	rapid_net_mat_brk.o \
+	rapid_obs_mat.o \
+	rapid_routing.o \
+	rapid_routing_param.o \
+	rapid_phiroutine.o \
+	rapid_destro_obj.o \
+	rapid_final.o \
+	rapid_var.o \
+	hrldas_RAPID_wrapper.o \
+	hrldas_RAPID_drv.o
+	${FLINKER} ${FPPFLAGS} -o \
+	rapid \
+	rapid_main.o \
+	rapid_init.o \
+	rapid_read_namelist.o \
+	rapid_arrays.o \
+	rapid_create_obj.o \
+	rapid_create_Qout_file.o \
+	rapid_open_Qout_file.o \
+	rapid_open_Vlat_file.o \
+	rapid_open_Qobs_file.o \
+	rapid_open_Qfor_file.o \
+	rapid_open_Qhum_file.o \
+	rapid_write_Qout_file.o \
+	rapid_read_Vlat_file.o \
+	rapid_read_Qobs_file.o \
+	rapid_read_Qfor_file.o \
+	rapid_read_Qhum_file.o \
+	rapid_close_Qout_file.o \
+	rapid_close_Vlat_file.o \
+	rapid_close_Qobs_file.o \
+	rapid_close_Qfor_file.o \
+	rapid_close_Qhum_file.o \
+	rapid_get_Qdam.o \
+	rapid_set_Qext0.o \
+	rapid_hsh_mat.o \
+	rapid_net_mat.o \
+	rapid_net_mat_brk.o \
+	rapid_routing.o \
+	rapid_routing_param.o \
+	rapid_obs_mat.o \
+	rapid_phiroutine.o \
+	rapid_destro_obj.o \
+	rapid_final.o \
+	rapid_var.o \
+	hrldas_RAPID_wrapper.o \
+	hrldas_RAPID_drv.o \
+	${TAO_FORTRAN_LIB} ${TAO_LIB} ${PETSC_LIB} ${NETCDF_LIB}
+	${RM} *.o *.mod 
+#	ln -sf ../src/rapid ../run/rapid
+#	ln -sf ../src/rapid ../rtk/rapid
+#----LPR: uncomment the link because no RAPID executable will be generated when
+#---------coupled with WRF-Hydro
+
+#-------------------------------------------------------------------------------
+#Compile RAPID
+#-------------------------------------------------------------------------------
+rapid_final.o:		rapid_final.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_final.F90 ${PETSC_FC_INCLUDES}
+
+rapid_destro_obj.o: 	rapid_destro_obj.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_destro_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE}
+
+rapid_phiroutine.o: 	rapid_phiroutine.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_phiroutine.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} 
+
+rapid_routing.o: 	rapid_routing.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_routing.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE}
+
+rapid_init.o: 		rapid_read_namelist.o rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_init.F90 ${PETSC_FC_INCLUDES}
+
+rapid_routing_param.o: 	rapid_routing_param.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_routing_param.F90 ${PETSC_FC_INCLUDES}
+
+rapid_obs_mat.o: 	rapid_obs_mat.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_obs_mat.F90 ${PETSC_FC_INCLUDES}
+
+rapid_net_mat_brk.o: 	rapid_net_mat_brk.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_net_mat_brk.F90 ${PETSC_FC_INCLUDES}
+
+rapid_net_mat.o: 	rapid_net_mat.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_net_mat.F90 ${PETSC_FC_INCLUDES}
+
+rapid_hsh_mat.o: 	rapid_hsh_mat.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_hsh_mat.F90 ${PETSC_FC_INCLUDES}
+
+rapid_get_Qdam.o: 	rapid_get_Qdam.F90 rapid_var.mod 
+	${FLINKER} ${FPPFLAGS} -c rapid_get_Qdam.F90 ${PETSC_FC_INCLUDES}
+
+rapid_set_Qext0.o: 	rapid_set_Qext0.F90 rapid_var.mod 
+	${FLINKER} ${FPPFLAGS} -c rapid_set_Qext0.F90 ${PETSC_FC_INCLUDES}
+
+rapid_close_Qfor_file.o: 	rapid_close_Qfor_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qfor_file.F90
+
+rapid_close_Qhum_file.o: 	rapid_close_Qhum_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qhum_file.F90
+
+rapid_close_Qobs_file.o: 	rapid_close_Qobs_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qobs_file.F90
+
+rapid_close_Vlat_file.o: 	rapid_close_Vlat_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Vlat_file.F90 ${NETCDF_INCLUDE} 
+
+rapid_close_Qout_file.o: 	rapid_close_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qout_file.F90 ${NETCDF_INCLUDE} 
+
+rapid_read_Qfor_file.o: 	rapid_read_Qfor_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Qfor_file.F90 ${PETSC_FC_INCLUDES}
+
+rapid_read_Qhum_file.o: 	rapid_read_Qhum_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Qhum_file.F90 ${PETSC_FC_INCLUDES}
+
+rapid_read_Qobs_file.o: 	rapid_read_Qobs_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Qobs_file.F90 ${PETSC_FC_INCLUDES}
+
+rapid_read_Vlat_file.o: 	rapid_read_Vlat_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Vlat_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE}
+
+rapid_write_Qout_file.o: 	rapid_write_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_write_Qout_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE}
+
+rapid_open_Qfor_file.o: 	rapid_open_Qfor_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qfor_file.F90 
+
+rapid_open_Qhum_file.o: 	rapid_open_Qhum_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qhum_file.F90 
+
+rapid_open_Qobs_file.o: 	rapid_open_Qobs_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qobs_file.F90 
+
+rapid_open_Vlat_file.o: 	rapid_open_Vlat_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Vlat_file.F90 ${NETCDF_INCLUDE}
+
+rapid_open_Qout_file.o: 	rapid_open_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qout_file.F90 ${NETCDF_INCLUDE}
+
+rapid_create_Qout_file.o: 	rapid_create_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_create_Qout_file.F90 ${NETCDF_INCLUDE}
+
+rapid_create_obj.o: 	rapid_create_obj.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_create_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE}
+
+rapid_arrays.o:	rapid_arrays.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_arrays.F90 ${PETSC_FC_INCLUDES}
+	
+rapid_read_namelist.o:	rapid_read_namelist.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_namelist.F90
+	
+rapid_var.o rapid_var.mod:	rapid_var.F90
+	${FLINKER} ${FPPFLAGS} -c rapid_var.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} 
+
+hrldas_RAPID_wrapper.mod hrldas_RAPID_wrapper.o:     hrldas_RAPID_wrapper.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c hrldas_RAPID_wrapper.F90  ${PETSC_FC_INCLUDES} ${TAO_INCLUDE}
+
+rapid_main.o:   rapid_main.F90 rapid_var.mod hrldas_RAPID_wrapper.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_main.F90 ${PETSC_FC_INCLUDES} \
+						${TAO_INCLUDE} ${NETCDF_INCLUDE}
+
+hrldas_RAPID_drv.o:     hrldas_RAPID_drv.F90 hrldas_RAPID_wrapper.mod
+	${FLINKER} ${FPPFLAGS} -c hrldas_RAPID_drv.F90  ${PETSC_FC_INCLUDE} ${TAO_INCLUDE}
+	
+#-------------------------------------------------------------------------------
+#Clean
+#-------------------------------------------------------------------------------
+clean::
+	${RM} *.o *.mod rapid ../run/rapid ../rtk/rapid
+
diff --git a/wrfv2_fire/hydro/Rapid_routing/makefile.cpl b/wrfv2_fire/hydro/Rapid_routing/makefile.cpl
new file mode 100644
index 00000000..3363744b
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/makefile.cpl
@@ -0,0 +1,197 @@
+#*******************************************************************************
+#makefile
+#*******************************************************************************
+
+#Purpose:
+#This file, along with the make utility allows compiling/linking RAPID
+#Author:
+#Cedric H. David, 2008-2015
+
+
+#*******************************************************************************
+#PETSc and TAO rules and variables (where environment variables and options are)
+#*******************************************************************************
+
+#-------------------------------------------------------------------------------
+#Default RAPID - includes optimization with TAO 
+#-------------------------------------------------------------------------------
+#FPPFLAGS=
+#include ${TAO_DIR}/conf/tao_base
+
+#-------------------------------------------------------------------------------
+#If want to use RAPID without TAO, in which case the optimization is unavailable
+#-------------------------------------------------------------------------------
+FPPFLAGS=-D NO_TAO
+include ${PETSC_DIR}/conf/variables
+include ${PETSC_DIR}/conf/rules
+
+
+#*******************************************************************************
+#Location of netCDF include and lib directories
+#*******************************************************************************
+NETCDF_LIB=-L ${TACC_NETCDF_LIB} -lnetcdf
+NETCDF_INCLUDE=-I ${TACC_NETCDF_INC}
+
+#*******************************************************************************
+#makefile instructions 
+#*******************************************************************************
+
+#-------------------------------------------------------------------------------
+#Test that environment variables are properly read by make
+#-------------------------------------------------------------------------------
+dummy: 
+	echo ${FLINKER} ${FPPFLAGS}
+
+#-------------------------------------------------------------------------------
+#Link RAPID main
+#-------------------------------------------------------------------------------
+rapid:	rapid_main.o \
+	rapid_init.o \
+	rapid_read_namelist.o \
+	rapid_arrays.o \
+	rapid_create_obj.o \
+	rapid_create_Qout_file.o \
+	rapid_open_Qout_file.o \
+	rapid_open_Vlat_file.o \
+	rapid_open_Qobs_file.o \
+	rapid_open_Qfor_file.o \
+	rapid_open_Qhum_file.o \
+	rapid_write_Qout_file.o \
+	rapid_read_Vlat_file.o \
+	rapid_read_Qobs_file.o \
+	rapid_read_Qfor_file.o \
+	rapid_read_Qhum_file.o \
+	rapid_close_Qout_file.o \
+	rapid_close_Vlat_file.o \
+	rapid_close_Qobs_file.o \
+	rapid_close_Qfor_file.o \
+	rapid_close_Qhum_file.o \
+	rapid_get_Qdam.o \
+	rapid_set_Qext0.o \
+	rapid_hsh_mat.o \
+	rapid_net_mat.o \
+	rapid_net_mat_brk.o \
+	rapid_obs_mat.o \
+	rapid_routing.o \
+	rapid_routing_param.o \
+	rapid_phiroutine.o \
+	rapid_destro_obj.o \
+	rapid_final.o \
+	rapid_var.o \
+	hrldas_RAPID_wrapper.o
+	ar -r ../lib/librapid.a *.o
+	cp *.mod ../mod/.
+#	${RM} *.o *.mod 
+
+#-------------------------------------------------------------------------------
+#Compile RAPID
+#-------------------------------------------------------------------------------
+rapid_final.o:		rapid_final.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_final.F90 ${PETSC_FC_INCLUDES}
+
+rapid_destro_obj.o: 	rapid_destro_obj.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_destro_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE}
+
+rapid_phiroutine.o: 	rapid_phiroutine.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_phiroutine.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} 
+
+rapid_routing.o: 	rapid_routing.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_routing.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE}
+
+rapid_init.o: 		rapid_read_namelist.o rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_init.F90 ${PETSC_FC_INCLUDES}
+
+rapid_routing_param.o: 	rapid_routing_param.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_routing_param.F90 ${PETSC_FC_INCLUDES}
+
+rapid_obs_mat.o: 	rapid_obs_mat.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_obs_mat.F90 ${PETSC_FC_INCLUDES}
+
+rapid_net_mat_brk.o: 	rapid_net_mat_brk.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_net_mat_brk.F90 ${PETSC_FC_INCLUDES}
+
+rapid_net_mat.o: 	rapid_net_mat.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_net_mat.F90 ${PETSC_FC_INCLUDES}
+
+rapid_hsh_mat.o: 	rapid_hsh_mat.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_hsh_mat.F90 ${PETSC_FC_INCLUDES}
+
+rapid_get_Qdam.o: 	rapid_get_Qdam.F90 rapid_var.mod 
+	${FLINKER} ${FPPFLAGS} -c rapid_get_Qdam.F90 ${PETSC_FC_INCLUDES}
+
+rapid_set_Qext0.o: 	rapid_set_Qext0.F90 rapid_var.mod 
+	${FLINKER} ${FPPFLAGS} -c rapid_set_Qext0.F90 ${PETSC_FC_INCLUDES}
+
+rapid_close_Qfor_file.o: 	rapid_close_Qfor_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qfor_file.F90
+
+rapid_close_Qhum_file.o: 	rapid_close_Qhum_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qhum_file.F90
+
+rapid_close_Qobs_file.o: 	rapid_close_Qobs_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qobs_file.F90
+
+rapid_close_Vlat_file.o: 	rapid_close_Vlat_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Vlat_file.F90 ${NETCDF_INCLUDE} 
+
+rapid_close_Qout_file.o: 	rapid_close_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qout_file.F90 ${NETCDF_INCLUDE} 
+
+rapid_read_Qfor_file.o: 	rapid_read_Qfor_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Qfor_file.F90 ${PETSC_FC_INCLUDES}
+
+rapid_read_Qhum_file.o: 	rapid_read_Qhum_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Qhum_file.F90 ${PETSC_FC_INCLUDES}
+
+rapid_read_Qobs_file.o: 	rapid_read_Qobs_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Qobs_file.F90 ${PETSC_FC_INCLUDES}
+
+rapid_read_Vlat_file.o: 	rapid_read_Vlat_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Vlat_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE}
+
+rapid_write_Qout_file.o: 	rapid_write_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_write_Qout_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE}
+
+rapid_open_Qfor_file.o: 	rapid_open_Qfor_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qfor_file.F90 
+
+rapid_open_Qhum_file.o: 	rapid_open_Qhum_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qhum_file.F90 
+
+rapid_open_Qobs_file.o: 	rapid_open_Qobs_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qobs_file.F90 
+
+rapid_open_Vlat_file.o: 	rapid_open_Vlat_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Vlat_file.F90 ${NETCDF_INCLUDE}
+
+rapid_open_Qout_file.o: 	rapid_open_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qout_file.F90 ${NETCDF_INCLUDE}
+
+rapid_create_Qout_file.o: 	rapid_create_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_create_Qout_file.F90 ${NETCDF_INCLUDE}
+
+rapid_create_obj.o: 	rapid_create_obj.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_create_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE}
+
+rapid_arrays.o:	rapid_arrays.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_arrays.F90 ${PETSC_FC_INCLUDES}
+	
+rapid_read_namelist.o:	rapid_read_namelist.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_namelist.F90
+	
+rapid_var.o rapid_var.mod:	rapid_var.F90
+	${FLINKER} ${FPPFLAGS} -c rapid_var.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} 
+
+hrldas_RAPID_wrapper.mod hrldas_RAPID_wrapper.o:     hrldas_RAPID_wrapper.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c hrldas_RAPID_wrapper.F90  ${PETSC_FC_INCLUDES} ${TAO_INCLUDE}
+
+rapid_main.o:   rapid_main.F90 rapid_var.mod hrldas_RAPID_wrapper.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_main.F90 ${PETSC_FC_INCLUDES} \
+                                                ${TAO_INCLUDE} ${NETCDF_INCLUDE}
+	
+#-------------------------------------------------------------------------------
+#Clean
+#-------------------------------------------------------------------------------
+clean::
+	${RM} *.o *.mod rapid ../run/rapid ../rtk/rapid
+
diff --git a/wrfv2_fire/hydro/Rapid_routing/makefile.orig b/wrfv2_fire/hydro/Rapid_routing/makefile.orig
new file mode 100644
index 00000000..ad4d8b53
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/makefile.orig
@@ -0,0 +1,229 @@
+#*******************************************************************************
+#makefile
+#*******************************************************************************
+
+#Purpose:
+#This file, along with the make utility allows compiling/linking RAPID
+#Author:
+#Cedric H. David, 2008-2015
+
+
+#*******************************************************************************
+#PETSc and TAO rules and variables (where environment variables and options are)
+#*******************************************************************************
+
+#-------------------------------------------------------------------------------
+#Default RAPID - includes optimization with TAO 
+#-------------------------------------------------------------------------------
+#FPPFLAGS=
+#include ${TAO_DIR}/conf/tao_base
+
+#-------------------------------------------------------------------------------
+#If want to use RAPID without TAO, in which case the optimization is unavailable
+#-------------------------------------------------------------------------------
+FPPFLAGS=-D NO_TAO
+include ${PETSC_DIR}/conf/variables
+include ${PETSC_DIR}/conf/rules
+
+
+#*******************************************************************************
+#Location of netCDF include and lib directories
+#*******************************************************************************
+NETCDF_LIB=-L ${TACC_NETCDF_LIB} -lnetcdf
+NETCDF_INCLUDE=-I ${TACC_NETCDF_INC}
+
+
+#*******************************************************************************
+#makefile instructions 
+#*******************************************************************************
+
+#-------------------------------------------------------------------------------
+#Test that environment variables are properly read by make
+#-------------------------------------------------------------------------------
+dummy: 
+	echo ${FLINKER} ${FPPFLAGS}
+
+#-------------------------------------------------------------------------------
+#Link RAPID main
+#-------------------------------------------------------------------------------
+rapid:	rapid_main.o \
+	rapid_init.o \
+	rapid_read_namelist.o \
+	rapid_arrays.o \
+	rapid_create_obj.o \
+	rapid_create_Qout_file.o \
+	rapid_open_Qout_file.o \
+	rapid_open_Vlat_file.o \
+	rapid_open_Qobs_file.o \
+	rapid_open_Qfor_file.o \
+	rapid_open_Qhum_file.o \
+	rapid_write_Qout_file.o \
+	rapid_read_Vlat_file.o \
+	rapid_read_Qobs_file.o \
+	rapid_read_Qfor_file.o \
+	rapid_read_Qhum_file.o \
+	rapid_close_Qout_file.o \
+	rapid_close_Vlat_file.o \
+	rapid_close_Qobs_file.o \
+	rapid_close_Qfor_file.o \
+	rapid_close_Qhum_file.o \
+	rapid_get_Qdam.o \
+	rapid_set_Qext0.o \
+	rapid_hsh_mat.o \
+	rapid_net_mat.o \
+	rapid_net_mat_brk.o \
+	rapid_obs_mat.o \
+	rapid_routing.o \
+	rapid_routing_param.o \
+	rapid_phiroutine.o \
+	rapid_destro_obj.o \
+	rapid_final.o \
+	rapid_var.o
+	${FLINKER} ${FPPFLAGS} -o \
+	rapid \
+	rapid_main.o \
+	rapid_init.o \
+	rapid_read_namelist.o \
+	rapid_arrays.o \
+	rapid_create_obj.o \
+	rapid_create_Qout_file.o \
+	rapid_open_Qout_file.o \
+	rapid_open_Vlat_file.o \
+	rapid_open_Qobs_file.o \
+	rapid_open_Qfor_file.o \
+	rapid_open_Qhum_file.o \
+	rapid_write_Qout_file.o \
+	rapid_read_Vlat_file.o \
+	rapid_read_Qobs_file.o \
+	rapid_read_Qfor_file.o \
+	rapid_read_Qhum_file.o \
+	rapid_close_Qout_file.o \
+	rapid_close_Vlat_file.o \
+	rapid_close_Qobs_file.o \
+	rapid_close_Qfor_file.o \
+	rapid_close_Qhum_file.o \
+	rapid_get_Qdam.o \
+	rapid_set_Qext0.o \
+	rapid_hsh_mat.o \
+	rapid_net_mat.o \
+	rapid_net_mat_brk.o \
+	rapid_routing.o \
+	rapid_routing_param.o \
+	rapid_obs_mat.o \
+	rapid_phiroutine.o \
+	rapid_destro_obj.o \
+	rapid_final.o \
+	rapid_var.o \
+	${TAO_FORTRAN_LIB} ${TAO_LIB} ${PETSC_LIB} ${NETCDF_LIB}
+	${RM} *.o *.mod 
+	ln -sf ../src/rapid ../run/rapid
+	ln -sf ../src/rapid ../rtk/rapid
+
+#-------------------------------------------------------------------------------
+#Compile RAPID
+#-------------------------------------------------------------------------------
+rapid_main.o: 	rapid_main.F90 rapid_var.mod 
+	${FLINKER} ${FPPFLAGS} -c rapid_main.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} 
+
+rapid_final.o:		rapid_final.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_final.F90 ${PETSC_FC_INCLUDES}
+
+rapid_destro_obj.o: 	rapid_destro_obj.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_destro_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE}
+
+rapid_phiroutine.o: 	rapid_phiroutine.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_phiroutine.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} 
+
+rapid_routing.o: 	rapid_routing.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_routing.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE}
+
+rapid_init.o: 		rapid_read_namelist.o rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_init.F90 ${PETSC_FC_INCLUDES}
+
+rapid_routing_param.o: 	rapid_routing_param.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_routing_param.F90 ${PETSC_FC_INCLUDES}
+
+rapid_obs_mat.o: 	rapid_obs_mat.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_obs_mat.F90 ${PETSC_FC_INCLUDES}
+
+rapid_net_mat_brk.o: 	rapid_net_mat_brk.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_net_mat_brk.F90 ${PETSC_FC_INCLUDES}
+
+rapid_net_mat.o: 	rapid_net_mat.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_net_mat.F90 ${PETSC_FC_INCLUDES}
+
+rapid_hsh_mat.o: 	rapid_hsh_mat.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_hsh_mat.F90 ${PETSC_FC_INCLUDES}
+
+rapid_get_Qdam.o: 	rapid_get_Qdam.F90 rapid_var.mod 
+	${FLINKER} ${FPPFLAGS} -c rapid_get_Qdam.F90 ${PETSC_FC_INCLUDES}
+
+rapid_set_Qext0.o: 	rapid_set_Qext0.F90 rapid_var.mod 
+	${FLINKER} ${FPPFLAGS} -c rapid_set_Qext0.F90 ${PETSC_FC_INCLUDES}
+
+rapid_close_Qfor_file.o: 	rapid_close_Qfor_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qfor_file.F90
+
+rapid_close_Qhum_file.o: 	rapid_close_Qhum_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qhum_file.F90
+
+rapid_close_Qobs_file.o: 	rapid_close_Qobs_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qobs_file.F90
+
+rapid_close_Vlat_file.o: 	rapid_close_Vlat_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Vlat_file.F90 ${NETCDF_INCLUDE} 
+
+rapid_close_Qout_file.o: 	rapid_close_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_close_Qout_file.F90 ${NETCDF_INCLUDE} 
+
+rapid_read_Qfor_file.o: 	rapid_read_Qfor_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Qfor_file.F90 ${PETSC_FC_INCLUDES}
+
+rapid_read_Qhum_file.o: 	rapid_read_Qhum_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Qhum_file.F90 ${PETSC_FC_INCLUDES}
+
+rapid_read_Qobs_file.o: 	rapid_read_Qobs_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Qobs_file.F90 ${PETSC_FC_INCLUDES}
+
+rapid_read_Vlat_file.o: 	rapid_read_Vlat_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_Vlat_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE}
+
+rapid_write_Qout_file.o: 	rapid_write_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_write_Qout_file.F90 ${PETSC_FC_INCLUDES} ${NETCDF_INCLUDE}
+
+rapid_open_Qfor_file.o: 	rapid_open_Qfor_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qfor_file.F90 
+
+rapid_open_Qhum_file.o: 	rapid_open_Qhum_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qhum_file.F90 
+
+rapid_open_Qobs_file.o: 	rapid_open_Qobs_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qobs_file.F90 
+
+rapid_open_Vlat_file.o: 	rapid_open_Vlat_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Vlat_file.F90 ${NETCDF_INCLUDE}
+
+rapid_open_Qout_file.o: 	rapid_open_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_open_Qout_file.F90 ${NETCDF_INCLUDE}
+
+rapid_create_Qout_file.o: 	rapid_create_Qout_file.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_create_Qout_file.F90 ${NETCDF_INCLUDE}
+
+rapid_create_obj.o: 	rapid_create_obj.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_create_obj.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE}
+
+rapid_arrays.o:	rapid_arrays.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_arrays.F90 ${PETSC_FC_INCLUDES}
+	
+rapid_read_namelist.o:	rapid_read_namelist.F90 rapid_var.mod
+	${FLINKER} ${FPPFLAGS} -c rapid_read_namelist.F90
+	
+rapid_var.o rapid_var.mod:	rapid_var.F90
+	${FLINKER} ${FPPFLAGS} -c rapid_var.F90 ${PETSC_FC_INCLUDES} ${TAO_INCLUDE} 
+	
+#-------------------------------------------------------------------------------
+#Clean
+#-------------------------------------------------------------------------------
+clean::
+	${RM} *.o *.mod rapid ../run/rapid ../rtk/rapid
+
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_arrays.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_arrays.F90
new file mode 100644
index 00000000..6adb263e
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_arrays.F90
@@ -0,0 +1,709 @@
+!*******************************************************************************
+!Subroutine - rapid_arrays
+!*******************************************************************************
+subroutine rapid_arrays
+
+!Purpose:
+!Create arrays from input files that are useful for RAPID. 
+!for all simulations, RAPID can run on a subset of all available river reaches
+!of the domain.
+!Three Fortran vectors are useful here:
+! - IV_riv_bas_id(IS_riv_bas) allows to know the IDs of the subbasin studied
+! - IV_riv_bas_index(IS_riv_bas) allows to know where the flow values are
+!   located in Vlat_file using the 1-based ZV_read_riv_tot
+! - IV_riv_bas_loc1(IS_riv_bas) allows to know where to ad dthe flow values in
+!   the current modeling domain using the 0-based ZV_Qout
+!When human-induced option is activated, the flow entering each given river ID 
+!is read from a file and added to the inflow the corresponding river.  
+!Three Fortran vectors are useful here: 
+! - IV_hum_bas_id(IS_hum_bas) allows to know the IDs of the humand-induced flows
+!   locations into the subbasin 
+! - IV_hum_index(IS_hum_bas) allows to know where the flow values are 
+!   located in Qhum_file using the 1-based ZV_read_hum_tot
+! - IV_hum_loc1(IS_hum_bas) allows to know where to add the flow values
+!   in the current modeling domain using the 0-based ZV_Qhum
+!When forcing option is activated, the flow exiting each given river ID is 
+!read from a file and added to the inflow of its downstream river.  
+!Three Fortran vectors are useful here: 
+! - IV_for_bas_id(IS_for_bas) allows to know the IDs of the forcing locations
+!   flowing into the subbasin 
+! - IV_for_index(IS_for_bas) allows to know where the flow values are 
+!   located in Qfor_file using the 1-based ZV_read_for_tot
+! - IV_for_loc2(IS_for_bas) allows to know where to add the flow values
+!   in the current modeling domain using the 0-based ZV_Qfor
+!When dam option is activated, the flow exiting each given river ID is 
+!obtained from a model and added to the inflow of its downstream river.  
+!Four Fortran vectors are useful here: 
+! - IV_dam_bas_id(IS_dam_bas) allows to know the IDs of the dam locations
+!   in the subbasin 
+! - IV_dam_index(IS_dam_bas) allows to know where the flow values are 
+!   located in dam model array using the 1-based ZV_read_dam_tot
+! - IV_dam_loc2(IS_dam_bas) allows to know where to add the flow values
+!   in the current modeling domain using the 0-based ZV_Qdam
+! - IV_dam_pos(IS_dam_bas) allows to know where to read the flow values for the 
+!   dam model in the current modeling domain using the 0-based ZV_Qdam
+!When RAPID is run in optimization mode, the flow measured at each given river   
+!ID is read from a file and compared to computations.  
+!Three Fortran vectors are useful here: 
+! - IV_obs_bas_id(IS_obs_bas) allows to know the IDs of the observations 
+! - IV_obs_index(IS_obs_bas) allows to know where the flow values are 
+!   located in Qobs_file using the 1-based ZV_read_obs_tot
+! - IV_obs_loc1(IS_obs_bas) allows to know where to put the flow values
+!   in the current modeling domain using the 0-based ZV_Qobs
+!Author: 
+!Cedric H. David, 2014-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   rapid_connect_file,                                         &
+                   IS_riv_tot,JS_riv_tot,JS_up,                                &
+                   IV_riv_tot_id,IV_down,IV_nbup,IM_up,IM_index_up,            &
+                   riv_bas_id_file,                                            &
+                   IS_riv_bas,JS_riv_bas,JS_riv_bas2,                          &
+                   ZM_hsh_tot,ZM_hsh_bas,                                      &
+                   IV_riv_bas_id,IV_riv_index,IV_riv_loc1,                     &
+                   BS_opt_hum,                                                 &
+                   hum_tot_id_file,                                            &
+                   IS_hum_tot,JS_hum_tot,                                      &
+                   IV_hum_tot_id,                                              &
+                   hum_use_id_file,                                            &
+                   IV_hum_use_id,                                              &
+                   IS_hum_use,JS_hum_use,                                      &
+                   IS_hum_bas,JS_hum_bas,                                      &
+                   IV_hum_bas_id,IV_hum_index,IV_hum_loc1,                     &
+                   BS_opt_for,                                                 &
+                   for_tot_id_file,                                            &
+                   IS_for_tot,JS_for_tot,                                      &
+                   IV_for_tot_id,                                              &
+                   for_use_id_file,                                            &
+                   IV_for_use_id,                                              &
+                   IS_for_use,JS_for_use,                                      &
+                   IS_for_bas,JS_for_bas,                                      &
+                   IV_for_bas_id,IV_for_index,IV_for_loc2,IV_dam_pos,          &
+                   BS_opt_dam,                                                 &
+                   dam_tot_id_file,                                            &
+                   IS_dam_tot,JS_dam_tot,                                      &
+                   IV_dam_tot_id,                                              &
+                   dam_use_id_file,                                            &
+                   IV_dam_use_id,                                              &
+                   IS_dam_use,JS_dam_use,                                      &
+                   IS_dam_bas,JS_dam_bas,                                      &
+                   IV_dam_bas_id,IV_dam_index,IV_dam_loc2,                     &
+                   IS_opt_run,                                                 &
+                   obs_tot_id_file,                                            &
+                   IS_obs_tot,JS_obs_tot,                                      &
+                   IV_obs_tot_id,                                              &
+                   obs_use_id_file,                                            &
+                   IV_obs_use_id,                                              &
+                   IS_obs_use,JS_obs_use,                                      &
+                   IS_obs_bas,JS_obs_bas,                                      &
+                   IV_obs_index,IV_obs_loc1,                                   &
+                   BS_logical,temp_char,rank,ierr,IS_one,ZS_val
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/petsclog.h" 
+!PETSc log
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Relationship between entire domain and study basin 
+!*******************************************************************************
+
+!-------------------------------------------------------------------------------
+!Read data files
+!-------------------------------------------------------------------------------
+open(10,file=rapid_connect_file,status='old')
+do JS_riv_tot=1,IS_riv_tot
+     read(10,*) IV_riv_tot_id(JS_riv_tot), IV_down(JS_riv_tot),                &
+                IV_nbup(JS_riv_tot), IM_up(JS_riv_tot,:)
+enddo
+close(10)
+
+open(11,file=riv_bas_id_file,status='old')
+do JS_riv_bas=1,IS_riv_bas
+     read(11,*) IV_riv_bas_id(JS_riv_bas)
+end do
+close(11)
+
+!-------------------------------------------------------------------------------
+!Populate hashtable-like matrices 
+!-------------------------------------------------------------------------------
+call rapid_hsh_mat
+
+!-------------------------------------------------------------------------------
+!Calculate IS_riv_bas
+!-------------------------------------------------------------------------------
+!This is actually given in the namelist
+
+!-------------------------------------------------------------------------------
+!Allocate and initialize IV_riv_index, IV_riv_loc1, and IM_index_up
+!-------------------------------------------------------------------------------
+!Allocation is actually done in rapid_init.F90
+IV_riv_index=0
+IV_riv_loc1=0
+IM_index_up=0
+
+!-------------------------------------------------------------------------------
+!Populate IV_riv_index
+!-------------------------------------------------------------------------------
+do JS_riv_bas=1,IS_riv_bas
+     ZS_val=-999
+     call MatGetValues(ZM_hsh_tot,                                             &
+                       IS_one,rank,                                            &
+                       IS_one,IV_riv_bas_id(JS_riv_bas)-1,                     & 
+                       ZS_val,ierr)
+     CHKERRQ(ierr)
+     JS_riv_tot=int(ZS_val)
+     if (JS_riv_tot>0) then
+          IV_riv_index(JS_riv_bas)=JS_riv_tot
+     else
+          write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas)
+          call PetscPrintf(PETSC_COMM_WORLD,                                   &
+                           'ERROR: reach ID' // temp_char //                   &
+                           ' not included in domain' // char(10),ierr)
+          stop
+     end if
+end do 
+!vector with (Fortran, 1-based) indexes corresponding to reaches of basin 
+!within whole network
+!IV_riv_index has two advantages.  1) it is needed in order to read inflow  
+!data (Vlat for ex).  2) It allows to avoid one other nested loop in the 
+!following, which reduces tremendously the computation time.
+
+!-------------------------------------------------------------------------------
+!Populate IV_riv_loc1
+!-------------------------------------------------------------------------------
+do JS_riv_bas=1,IS_riv_bas
+     IV_riv_loc1(JS_riv_bas)=JS_riv_bas-1
+enddo
+!vector with zero-base index corresponding to one-base index
+
+!-------------------------------------------------------------------------------
+!Populate IM_index_up
+!-------------------------------------------------------------------------------
+do JS_riv_bas2=1,IS_riv_bas
+do JS_up=1, IV_nbup(IV_riv_index(JS_riv_bas2))
+     ZS_val=-999
+     call MatGetValues(ZM_hsh_bas,                                             &
+                       IS_one,rank,                                            &
+                       IS_one,IM_up(IV_riv_index(JS_riv_bas2),JS_up)-1,        & 
+                       ZS_val,ierr)
+     CHKERRQ(ierr)
+     JS_riv_bas=int(ZS_val)
+     if (JS_riv_bas>0) IM_index_up(JS_riv_bas2,JS_up)=JS_riv_bas
+end do
+end do
+!Used in traditional Muskingum method and to quicken matrix prealloc. & creation
+
+!-------------------------------------------------------------------------------
+!Optional, display IV_riv_loc1, IV_riv_index, and IM_index_up
+!-------------------------------------------------------------------------------
+!if (rank==0) then
+!     print *, IV_riv_loc1 
+!     print *, IV_riv_index 
+!     do JS_riv_bas=1,IS_riv_bas
+!          print *, IM_index_up(JS_riv_bas,:)
+!     end do
+!end if
+
+
+!*******************************************************************************
+!If human-induced flows are used
+!*******************************************************************************
+if (BS_opt_hum) then
+call PetscPrintf(PETSC_COMM_WORLD,'WARNING: Human-induced option activated' // &
+                 char(10),ierr)
+
+!-------------------------------------------------------------------------------
+!Read data files
+!-------------------------------------------------------------------------------
+open(14,file=hum_tot_id_file,status='old')
+read(14,*) IV_hum_tot_id
+close(14)
+
+open(15,file=hum_use_id_file,status='old')
+read(15,*) IV_hum_use_id
+close(15)
+
+!-------------------------------------------------------------------------------
+!Calculate IS_hum_bas
+!-------------------------------------------------------------------------------
+write(temp_char,'(i10)') IS_hum_tot
+call PetscPrintf(PETSC_COMM_WORLD,'         Total number of human-induced ' // &
+                 'IDs in hum_tot_id_file:' // temp_char // char(10),ierr)
+
+write(temp_char,'(i10)') IS_hum_use
+call PetscPrintf(PETSC_COMM_WORLD,'         Total number of human-induced ' // &
+                 'IDs in hum_use_id_file:' // temp_char // char(10),ierr)
+
+IS_hum_bas=0
+!initialize to zero
+
+do JS_hum_use=1,IS_hum_use
+     do JS_riv_bas=1,IS_riv_bas
+          if (IV_hum_use_id(JS_hum_use)==IV_riv_bas_id(JS_riv_bas)) then
+               IS_hum_bas=IS_hum_bas+1
+          end if
+     end do
+end do
+
+write(temp_char,'(i10)') IS_hum_bas
+call PetscPrintf(PETSC_COMM_WORLD,'         Total number of human-induced ' // &
+                 'IDs in this simulation:' // temp_char // char(10),ierr)
+
+!-------------------------------------------------------------------------------
+!Allocate and initialize IV_hum_bas_id, IV_hum_index, IV_hum_loc1
+!-------------------------------------------------------------------------------
+allocate(IV_hum_bas_id(IS_hum_bas))
+allocate(IV_hum_index(IS_hum_bas))
+allocate(IV_hum_loc1(IS_hum_bas))
+
+IV_hum_bas_id=0
+IV_hum_index=0
+IV_hum_loc1=0
+
+!-------------------------------------------------------------------------------
+!Populate IV_hum_bas_id
+!-------------------------------------------------------------------------------
+if (IS_hum_bas>0) then
+
+JS_hum_bas=0
+do JS_hum_use=1,IS_hum_use
+do JS_riv_bas=1,IS_riv_bas
+     if (IV_hum_use_id(JS_hum_use)==IV_riv_bas_id(JS_riv_bas)) then
+          JS_hum_bas=JS_hum_bas+1
+          IV_hum_bas_id(JS_hum_bas)=IV_riv_bas_id(JS_riv_bas)
+     end if 
+end do
+end do
+
+end if
+
+!-------------------------------------------------------------------------------
+!Populate IV_hum_index 
+!-------------------------------------------------------------------------------
+do JS_hum_bas=1,IS_hum_bas
+do JS_hum_tot=1,IS_hum_tot
+     if (IV_hum_bas_id(JS_hum_bas)==IV_hum_tot_id(JS_hum_tot)) then
+          IV_hum_index(JS_hum_bas)=JS_hum_tot
+     end if
+end do
+end do
+
+!-------------------------------------------------------------------------------
+!Populate IV_hum_loc1
+!-------------------------------------------------------------------------------
+do JS_hum_bas=1,IS_hum_bas
+do JS_riv_bas=1,IS_riv_bas
+     if (IV_riv_bas_id(JS_riv_bas)==IV_hum_bas_id(JS_hum_bas)) then
+          IV_hum_loc1(JS_hum_bas)=JS_riv_bas-1
+     end if 
+end do
+end do
+
+!-------------------------------------------------------------------------------
+!Print warning when human-induced is used
+!-------------------------------------------------------------------------------
+if (rank==0 .and. IS_hum_bas>0) then
+     print *, '        Human-induced flows added to computed flows, using:'
+     !print *, '        IV_hum_tot_id   =', IV_hum_tot_id
+     print *, '        IV_hum_use_id   =', IV_hum_use_id
+     print *, '        IV_hum_bas_id   =', IV_hum_bas_id
+     print *, '        IV_hum_index    =', IV_hum_index
+     print *, '        IV_hum_loc1     =', IV_hum_loc1
+end if
+!Warning about human-induced flows 
+
+!-------------------------------------------------------------------------------
+!End if human-induced is used
+!-------------------------------------------------------------------------------
+end if
+
+
+!*******************************************************************************
+!If forcing is used
+!*******************************************************************************
+if (BS_opt_for) then
+call PetscPrintf(PETSC_COMM_WORLD,'WARNING: Forcing option activated'//        &
+                 char(10),ierr)
+
+!-------------------------------------------------------------------------------
+!Read data files
+!-------------------------------------------------------------------------------
+open(16,file=for_tot_id_file,status='old')
+read(16,*) IV_for_tot_id
+close(16)
+
+open(17,file=for_use_id_file,status='old')
+read(17,*) IV_for_use_id
+close(17)
+
+!-------------------------------------------------------------------------------
+!Calculate IS_for_bas
+!-------------------------------------------------------------------------------
+write(temp_char,'(i10)') IS_for_tot
+call PetscPrintf(PETSC_COMM_WORLD,'         Total number of forcing IDs in ' //&
+                 'for_tot_id_file:' // temp_char // char(10),ierr)
+
+write(temp_char,'(i10)') IS_for_use
+call PetscPrintf(PETSC_COMM_WORLD,'         Total number of forcing IDs in ' //&
+                 'for_use_id_file:' // temp_char // char(10),ierr)
+
+IS_for_bas=0
+!initialize to zero
+
+do JS_for_use=1,IS_for_use
+     do JS_riv_tot=1,IS_riv_tot
+          if (IV_for_use_id(JS_for_use)==IV_riv_tot_id(JS_riv_tot)) then
+
+     do JS_riv_bas=1,IS_riv_bas
+          if (IV_down(JS_riv_tot)==IV_riv_bas_id(JS_riv_bas)) then 
+               IS_for_bas=IS_for_bas+1
+          end if
+     end do
+
+          end if 
+     end do
+end do
+
+write(temp_char,'(i10)') IS_for_bas
+call PetscPrintf(PETSC_COMM_WORLD,'         Total number of forcing IDs in ' //&
+                 'this simulation:' // temp_char // char(10),ierr)
+
+!-------------------------------------------------------------------------------
+!Allocate and initialize the vectors IV_for_index and IV_for_loc2
+!-------------------------------------------------------------------------------
+allocate(IV_for_bas_id(IS_for_bas))
+allocate(IV_for_index(IS_for_bas))
+allocate(IV_for_loc2(IS_for_bas))
+
+IV_for_bas_id=0
+IV_for_index=0
+IV_for_loc2=0
+
+!-------------------------------------------------------------------------------
+!Populate IV_for_bas_id
+!-------------------------------------------------------------------------------
+if (IS_for_bas>0) then
+
+JS_for_bas=0
+!initialize to zero
+
+do JS_for_use=1,IS_for_use
+     do JS_riv_tot=1,IS_riv_tot
+          if (IV_for_use_id(JS_for_use)==IV_riv_tot_id(JS_riv_tot)) then
+
+     do JS_riv_bas=1,IS_riv_bas
+          if (IV_down(JS_riv_tot)==IV_riv_bas_id(JS_riv_bas)) then 
+               JS_for_bas=JS_for_bas+1
+               IV_for_bas_id(JS_for_bas)=IV_for_use_id(JS_for_use)
+          end if
+     end do
+
+          end if 
+     end do
+end do
+
+end if
+
+!-------------------------------------------------------------------------------
+!Populate IV_for_index
+!-------------------------------------------------------------------------------
+do JS_for_bas=1,IS_for_bas
+do JS_for_tot=1,IS_for_tot
+     if (IV_for_bas_id(JS_for_bas)==IV_for_tot_id(JS_for_tot)) then
+          IV_for_index(JS_for_bas)=JS_for_tot
+     end if
+end do
+end do
+
+!-------------------------------------------------------------------------------
+!Populate IV_for_loc2
+!-------------------------------------------------------------------------------
+do JS_for_bas=1,IS_for_bas
+do JS_riv_tot=1,IS_riv_tot
+     if (IV_for_bas_id(JS_for_bas)==IV_riv_tot_id(JS_riv_tot)) then
+          do JS_riv_bas=1,IS_riv_bas
+
+if (IV_down(JS_riv_tot)==IV_riv_bas_id(JS_riv_bas)) then
+     IV_for_loc2(JS_for_bas)=IV_riv_loc1(JS_riv_bas)
+end if
+
+          end do
+     end if
+end do
+end do
+
+!-------------------------------------------------------------------------------
+!Print warning when forcing is used
+!-------------------------------------------------------------------------------
+if (rank==0 .and. IS_for_bas>0) then
+     print *, '        Forcing flows replace computed flows, using:'
+     !print *, '        IV_for_tot_id   =', IV_for_tot_id
+     print *, '        IV_for_use_id   =', IV_for_use_id
+     print *, '        IV_for_bas_id   =', IV_for_bas_id
+     print *, '        IV_for_index    =', IV_for_index
+     print *, '        IV_for_loc2     =', IV_for_loc2
+end if
+!Warning about forcing downstream basins
+
+!-------------------------------------------------------------------------------
+!End if forcing is used
+!-------------------------------------------------------------------------------
+end if
+
+
+!*******************************************************************************
+!If dam model is used
+!*******************************************************************************
+if (BS_opt_dam) then
+call PetscPrintf(PETSC_COMM_WORLD,'WARNING: Dam option activated'//            &
+                 char(10),ierr)
+
+!-------------------------------------------------------------------------------
+!Read data files
+!-------------------------------------------------------------------------------
+open(18,file=dam_tot_id_file,status='old')
+read(18,*) IV_dam_tot_id
+close(18)
+
+open(19,file=dam_use_id_file,status='old')
+read(19,*) IV_dam_use_id
+close(19)
+
+!-------------------------------------------------------------------------------
+!Calculate IS_dam_bas 
+!-------------------------------------------------------------------------------
+write(temp_char,'(i10)') IS_dam_tot
+call PetscPrintf(PETSC_COMM_WORLD,'         Total number of dam IDs in ' //    &
+                 'dam_tot_id_file:' // temp_char // char(10),ierr)
+
+write(temp_char,'(i10)') IS_dam_use
+call PetscPrintf(PETSC_COMM_WORLD,'         Total number of dam IDs in ' //    &
+                 'dam_use_id_file:' // temp_char // char(10),ierr)
+
+IS_dam_bas=0
+
+do JS_dam_use=1,IS_dam_use
+do JS_riv_bas=1,IS_riv_bas
+     if (IV_dam_use_id(JS_dam_use)==IV_riv_tot_id(IV_riv_index(JS_riv_bas)))then
+          IS_dam_bas=IS_dam_bas+1
+     end if 
+end do
+end do
+
+write(temp_char,'(i10)') IS_dam_bas
+call PetscPrintf(PETSC_COMM_WORLD,'         Total number of dam IDs in ' //    &
+                 'this simulation:' // temp_char // char(10),ierr)
+
+!-------------------------------------------------------------------------------
+!Allocate and initialize IV_dam_bas_id, IV_dam_index, IV_dam_loc2, IV_dam_pos
+!-------------------------------------------------------------------------------
+allocate(IV_dam_bas_id(IS_dam_bas))
+allocate(IV_dam_index(IS_dam_bas))
+allocate(IV_dam_loc2(IS_dam_bas))
+allocate(IV_dam_pos(IS_dam_tot))
+
+IV_dam_bas_id=0
+IV_dam_index=0
+IV_dam_loc2=0
+IV_dam_pos=0
+
+!-------------------------------------------------------------------------------
+!Populate IV_dam_bas_id
+!-------------------------------------------------------------------------------
+if (IS_dam_bas>0) then
+
+JS_dam_bas=0
+
+do JS_dam_use=1,IS_dam_use
+do JS_riv_bas=1,IS_riv_bas
+     if (IV_dam_use_id(JS_dam_use)==IV_riv_tot_id(IV_riv_index(JS_riv_bas)))then
+          JS_dam_bas=JS_dam_bas+1
+          IV_dam_bas_id(JS_dam_bas)=IV_riv_tot_id(IV_riv_index(JS_riv_bas))
+     end if 
+end do
+end do
+
+end if
+
+!-------------------------------------------------------------------------------
+!Populate IV_dam_index 
+!-------------------------------------------------------------------------------
+do JS_dam_bas=1,IS_dam_bas
+do JS_dam_tot=1,IS_dam_tot
+     if (IV_dam_bas_id(JS_dam_bas)==IV_dam_tot_id(JS_dam_tot)) then
+          IV_dam_index(JS_dam_bas)=JS_dam_tot
+     end if
+end do
+end do
+
+!-------------------------------------------------------------------------------
+!Populate IV_dam_loc2
+!-------------------------------------------------------------------------------
+do JS_dam_bas=1,IS_dam_bas
+do JS_riv_tot=1,IS_riv_tot
+     if (IV_dam_bas_id(JS_dam_bas)==IV_riv_tot_id(JS_riv_tot)) then
+          do JS_riv_bas=1,IS_riv_bas
+
+if (IV_riv_bas_id(JS_riv_bas)==IV_down(JS_riv_tot)) then
+          IV_dam_loc2(JS_dam_bas)=JS_riv_bas-1
+end if 
+          end do
+     end if
+end do
+end do
+
+!-------------------------------------------------------------------------------
+!Populate IV_dam_pos
+!-------------------------------------------------------------------------------
+do JS_dam_tot=1,IS_dam_tot
+do JS_riv_bas=1,IS_riv_bas
+     if (IV_dam_tot_id(JS_dam_tot)==IV_riv_bas_id(JS_riv_bas)) then
+          IV_dam_pos(JS_dam_tot)=JS_riv_bas
+     end if
+end do
+end do
+
+!-------------------------------------------------------------------------------
+!Print warning when dam model is used
+!-------------------------------------------------------------------------------
+if (rank==0 .and. IS_dam_bas>0) then
+     print *, '        Dam flows replace computed flows, using:'
+     !print *, '        IV_dam_tot_id   =', IV_dam_tot_id
+     print *, '        IV_dam_use_id   =', IV_dam_use_id
+     print *, '        IV_dam_bas_id   =', IV_dam_bas_id
+     print *, '        IV_dam_index    =', IV_dam_index
+     print *, '        IV_dam_loc2     =', IV_dam_loc2
+end if
+
+if (rank==0 .and. IS_dam_tot>0) then
+     print *, '        IV_dam_pos      =', IV_dam_pos
+end if 
+!Warning about forcing downstream basins
+
+!-------------------------------------------------------------------------------
+!End if dam model is used
+!-------------------------------------------------------------------------------
+end if
+
+
+!*******************************************************************************
+!If optimization mode is selected 
+!*******************************************************************************
+if (IS_opt_run==2) then
+
+!-------------------------------------------------------------------------------
+!Read data files
+!-------------------------------------------------------------------------------
+open(12,file=obs_tot_id_file,status='old')
+read(12,*) IV_obs_tot_id
+close(12)
+
+open(13,file=obs_use_id_file,status='old')
+read(13,*) IV_obs_use_id
+close(13)
+
+!-------------------------------------------------------------------------------
+!Calculate IS_obs_bas
+!-------------------------------------------------------------------------------
+write(temp_char,'(i10)') IS_obs_tot
+call PetscPrintf(PETSC_COMM_WORLD,'Number of gage IDs in obs_tot_file '    //  &
+                 '                  :' // temp_char // char(10),ierr)
+write(temp_char,'(i10)') IS_obs_use
+call PetscPrintf(PETSC_COMM_WORLD,'Number of gage IDs in obs_use_file '    //  &
+                 '                  :' // temp_char // char(10),ierr)
+
+IS_obs_bas=0
+!initialize to zero
+
+do JS_obs_use=1,IS_obs_use
+     do JS_riv_bas=1,IS_riv_bas
+          if (IV_obs_use_id(JS_obs_use)==IV_riv_bas_id(JS_riv_bas)) then
+               IS_obs_bas=IS_obs_bas+1
+          end if 
+     end do
+end do
+
+write(temp_char,'(i10)') IS_obs_bas
+call PetscPrintf(PETSC_COMM_WORLD,'Number of gage IDs in '                 //  &
+                 'this simulation                :'//temp_char // char(10),ierr)
+
+!-------------------------------------------------------------------------------
+!Allocate and initialize the vectors IV_obs_index and IV_obs_loc1
+!-------------------------------------------------------------------------------
+allocate(IV_obs_index(IS_obs_bas))
+allocate(IV_obs_loc1(IS_obs_bas))
+!allocate vector size
+
+do JS_obs_bas=1,IS_obs_bas
+     IV_obs_index(JS_obs_bas)=0
+     IV_obs_loc1(JS_obs_bas)=0
+end do
+!Initialize both vectors to zero
+
+!-------------------------------------------------------------------------------
+!Populate the vectors IV_obs_index and IV_obs_loc1
+!-------------------------------------------------------------------------------
+JS_obs_bas=1
+do JS_obs_use=1,IS_obs_use
+do JS_riv_bas=1,IS_riv_bas
+     if (IV_obs_use_id(JS_obs_use)==IV_riv_bas_id(JS_riv_bas)) then
+          do JS_obs_tot=1,IS_obs_tot
+               if (IV_obs_use_id(JS_obs_use)==IV_obs_tot_id(JS_obs_tot)) then
+                    IV_obs_index(JS_obs_bas)=JS_obs_tot
+               end if
+          end do
+          IV_obs_loc1(JS_obs_bas)=JS_riv_bas-1
+          JS_obs_bas=JS_obs_bas+1
+     end if
+end do
+end do
+!Create vector IV_obs_index and IV_obs_loc1
+
+!-------------------------------------------------------------------------------
+!Optional - Display vectors
+!-------------------------------------------------------------------------------
+!if (rank==0) then
+!     print *, 'IV_obs_index=', IV_obs_index 
+!     print *, 'IV_obs_loc1  =', IV_obs_loc1 
+!end if
+
+!-------------------------------------------------------------------------------
+!End if optimization mode is selected 
+!-------------------------------------------------------------------------------
+end if
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+call PetscPrintf(PETSC_COMM_WORLD,'Arrays created'//char(10),ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+end subroutine rapid_arrays
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qfor_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qfor_file.F90
new file mode 100644
index 00000000..3ae59c74
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qfor_file.F90
@@ -0,0 +1,40 @@
+!*******************************************************************************
+!Subroutine - rapid_close_Qfor_file 
+!*******************************************************************************
+subroutine rapid_close_Qfor_file
+
+!Purpose:
+!Close Qfor_file from Fortran.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   rank
+
+
+implicit none
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Close file
+!*******************************************************************************
+if (rank==0) close(34)
+
+!*******************************************************************************
+!End subroutine
+!*******************************************************************************
+end subroutine rapid_close_Qfor_file
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qhum_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qhum_file.F90
new file mode 100644
index 00000000..4e5dd332
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qhum_file.F90
@@ -0,0 +1,40 @@
+!*******************************************************************************
+!Subroutine - rapid_close_Qhum_file 
+!*******************************************************************************
+subroutine rapid_close_Qhum_file
+
+!Purpose:
+!Close Qhum_file from Fortran.
+!Author: 
+!Cedric H. David, 2014-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   rank
+
+
+implicit none
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Close file
+!*******************************************************************************
+if (rank==0) close(36)
+
+!*******************************************************************************
+!End subroutine
+!*******************************************************************************
+end subroutine rapid_close_Qhum_file
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qobs_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qobs_file.F90
new file mode 100644
index 00000000..d2b48114
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qobs_file.F90
@@ -0,0 +1,40 @@
+!*******************************************************************************
+!Subroutine - rapid_close_Qobs_file 
+!*******************************************************************************
+subroutine rapid_close_Qobs_file
+
+!Purpose:
+!Close Qobs_file from Fortran.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   rank
+
+
+implicit none
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Close file
+!*******************************************************************************
+if (rank==0) close(33)
+
+!*******************************************************************************
+!End subroutine
+!*******************************************************************************
+end subroutine rapid_close_Qobs_file
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qout_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qout_file.F90
new file mode 100644
index 00000000..82ebfa80
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Qout_file.F90
@@ -0,0 +1,42 @@
+!*******************************************************************************
+!Subroutine - rapid_close_Qout_file 
+!*******************************************************************************
+subroutine rapid_close_Qout_file
+
+!Purpose:
+!Close Qout_file from Fortran/netCDF.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use netcdf
+use rapid_var, only :                                                          &
+                   rank,IS_nc_status,IS_nc_id_fil_Qout
+
+
+implicit none
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Close file
+!*******************************************************************************
+if (rank==0) IS_nc_status=NF90_CLOSE(IS_nc_id_fil_Qout)
+
+
+!*******************************************************************************
+!End subroutine
+!*******************************************************************************
+end subroutine rapid_close_Qout_file
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_close_Vlat_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Vlat_file.F90
new file mode 100644
index 00000000..4279b0bd
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_close_Vlat_file.F90
@@ -0,0 +1,42 @@
+!*******************************************************************************
+!Subroutine - rapid_close_Vlat_file 
+!*******************************************************************************
+subroutine rapid_close_Vlat_file
+
+!Purpose:
+!Close Qobs_file from Fortran/netCDF.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use netcdf
+use rapid_var, only :                                                          &
+                   rank,IS_nc_status,IS_nc_id_fil_Vlat
+
+
+implicit none
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Close file
+!*******************************************************************************
+if (rank==0) IS_nc_status=NF90_CLOSE(IS_nc_id_fil_Vlat)
+
+
+!*******************************************************************************
+!End subroutine
+!*******************************************************************************
+end subroutine rapid_close_Vlat_file
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_create_Qout_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_create_Qout_file.F90
new file mode 100644
index 00000000..4620b46a
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_create_Qout_file.F90
@@ -0,0 +1,65 @@
+!*******************************************************************************
+!Subroutine - rapid_create_Qout_file
+!*******************************************************************************
+subroutine rapid_create_Qout_file(Qout_file) 
+
+!Purpose:
+!Create Qout_file from Fortran/netCDF.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use netcdf
+use rapid_var, only :                                                          &
+                   rank,                                                       &
+                   IS_nc_status,IS_nc_id_fil_Qout,                             &
+                   IS_nc_id_dim_time,IS_nc_id_dim_comid,IV_nc_id_dim,          &
+                   IS_nc_id_var_Qout,IS_nc_id_var_comid,                       &
+                   IV_riv_bas_id,IS_riv_bas
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+character(len=100), intent(in):: Qout_file
+
+
+!*******************************************************************************
+!Open file
+!*******************************************************************************
+if (rank==0) then 
+
+     IS_nc_status=NF90_CREATE(Qout_file,NF90_CLOBBER,IS_nc_id_fil_Qout)
+     IS_nc_status=NF90_DEF_DIM(IS_nc_id_fil_Qout,'Time',NF90_UNLIMITED,        &
+                               IS_nc_id_dim_time)
+     IS_nc_status=NF90_DEF_DIM(IS_nc_id_fil_Qout,'COMID',IS_riv_bas,           &
+                               IS_nc_id_dim_comid)
+     IS_nc_status=NF90_DEF_VAR(IS_nc_id_fil_Qout,'COMID',NF90_INT,             &
+                               IS_nc_id_dim_comid,IS_nc_id_var_comid)
+     IV_nc_id_dim(1)=IS_nc_id_dim_comid
+     IV_nc_id_dim(2)=IS_nc_id_dim_time
+     IS_nc_status=NF90_DEF_VAR(IS_nc_id_fil_Qout,'Qout',NF90_REAL,             &
+                               IV_nc_id_dim,IS_nc_id_var_Qout)
+     IS_nc_status=NF90_ENDDEF(IS_nc_id_fil_Qout)
+     IS_nc_status=NF90_PUT_VAR(IS_nc_id_fil_Qout,IS_nc_id_var_comid,           &
+                               IV_riv_bas_id)
+     IS_nc_status=NF90_CLOSE(IS_nc_id_fil_Qout)
+
+end if
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_create_Qout_file
+
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_create_obj.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_create_obj.F90
new file mode 100644
index 00000000..e6498d69
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_create_obj.F90
@@ -0,0 +1,219 @@
+!*******************************************************************************
+!Subroutine - rapid_create_obj
+!*******************************************************************************
+subroutine rapid_create_obj 
+
+!Purpose:
+!All PETSc and TAO objects need be created (requirement of both mathematical 
+!libraries).  PETSc and TAO also need be initialized.  This is what's done here.
+!Author: 
+!Cedric H. David, 2008-2015.
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   IS_riv_bas,                                                 &
+                   ZM_hsh_tot,ZM_hsh_bas,IS_riv_id_max,                        &
+                   ZM_Net,ZM_A,ZM_T,ZM_TC1,                                    &
+                   ZM_Obs,ZV_Qobs,ZV_temp1,ZV_temp2,ZV_kfac,                   &
+                   ZV_k,ZV_x,ZV_p,ZV_pnorm,ZV_pfac,                            &
+                   ZV_C1,ZV_C2,ZV_C3,ZV_Cdenom,                                &
+                   ZV_b,ZV_babsmax,ZV_bhat,                                    &
+                   ZV_Qext,ZV_Qfor,ZV_Qlat,ZV_Qhum,ZV_Qdam,                    &
+                   ZV_Vext,ZV_Vfor,ZV_Vlat,                                    &
+                   ZV_VinitM,ZV_QoutinitM,ZV_QoutinitO,ZV_QoutbarO,            &
+                   ZV_QoutR,ZV_QoutinitR,ZV_QoutprevR,ZV_QoutbarR,ZV_QinbarR,  &
+                   ZV_QoutRabsmin,ZV_QoutRabsmax,ZV_QoutRhat,                  &
+                   ZV_VR,ZV_VinitR,ZV_VprevR,ZV_VbarR,ZV_VoutR,                &
+                   ZV_Qobsbarrec,                                              &
+                   ierr,ksp,vecscat,ZV_SeqZero,ZS_one,ZV_one,IS_one,ncore,rank
+
+#ifndef NO_TAO
+use rapid_var, only :                                                          &
+                   tao,reason,ZV_1stIndex,ZV_2ndIndex
+#endif
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+
+#ifndef NO_TAO
+#include "finclude/taosolver.h" 
+!TAO solver
+#endif
+
+
+!*******************************************************************************
+!Initialize PETSc and TAO, and create all the objects
+!*******************************************************************************
+
+!Initialize PETSc --------------------------------------------------------------
+call PetscInitialize(PETSC_NULL_CHARACTER,ierr)
+
+!Determine number associated with each processor -------------------------------
+call MPI_Comm_rank(PETSC_COMM_WORLD,rank,ierr)
+
+!Determine total number of cores used ------------------------------------------
+call MPI_Comm_size(PETSC_COMM_WORLD,ncore,ierr)
+
+!Create PETSc object that manages all Krylov methods ---------------------------
+call KSPCreate(PETSC_COMM_WORLD,ksp,ierr)
+
+!Matrices-----------------------------------------------------------------------
+call MatCreate(PETSC_COMM_WORLD,ZM_Net,ierr)
+call MatSetSizes(ZM_Net,PETSC_DECIDE,PETSC_DECIDE,IS_riv_bas,IS_riv_bas,ierr)
+call MatSetFromOptions(ZM_Net,ierr)
+call MatSetUp(ZM_Net,ierr)
+
+call MatCreate(PETSC_COMM_WORLD,ZM_A,ierr)
+call MatSetSizes(ZM_A,PETSC_DECIDE,PETSC_DECIDE,IS_riv_bas,IS_riv_bas,ierr)
+call MatSetFromOptions(ZM_A,ierr)
+call MatSetUp(ZM_A,ierr)
+
+call MatCreate(PETSC_COMM_WORLD,ZM_T,ierr)
+call MatSetSizes(ZM_T,PETSC_DECIDE,PETSC_DECIDE,IS_riv_bas,IS_riv_bas,ierr)
+call MatSetFromOptions(ZM_T,ierr)
+call MatSetUp(ZM_T,ierr)
+
+call MatCreate(PETSC_COMM_WORLD,ZM_TC1,ierr)
+call MatSetSizes(ZM_TC1,PETSC_DECIDE,PETSC_DECIDE,IS_riv_bas,IS_riv_bas,ierr)
+call MatSetFromOptions(ZM_TC1,ierr)
+call MatSetUp(ZM_TC1,ierr)
+
+call MatCreate(PETSC_COMM_WORLD,ZM_Obs,ierr)
+call MatSetSizes(ZM_Obs,PETSC_DECIDE,PETSC_DECIDE,IS_riv_bas,IS_riv_bas,ierr)
+call MatSetFromOptions(ZM_Obs,ierr)
+call MatSetUp(ZM_Obs,ierr)
+!These matrices are all square of size IS_riv_bas.  PETSC_DECIDE allows PETSc 
+!to determine the local sizes on its own. MatSetFromOptions allows to use many
+!different options at runtime, such as "-mat_type aijmumps".
+
+call MatCreate(PETSC_COMM_WORLD,ZM_hsh_tot,ierr)
+call MatSetSizes(ZM_hsh_tot,PETSC_DECIDE,PETSC_DECIDE,ncore,IS_riv_id_max,ierr)
+call MatSetFromOptions(ZM_hsh_tot,ierr)
+call MatSetUp(ZM_hsh_tot,ierr)
+
+call MatCreate(PETSC_COMM_WORLD,ZM_hsh_bas,ierr)
+call MatSetSizes(ZM_hsh_bas,PETSC_DECIDE,PETSC_DECIDE,ncore,IS_riv_id_max,ierr)
+call MatSetFromOptions(ZM_hsh_bas,ierr)
+call MatSetUp(ZM_hsh_bas,ierr)
+!These matrices are all mostly flat with size IS_riv_id_max*ncore and will store
+!the same row over all columns
+
+!Vectors of size IS_riv_bas-----------------------------------------------------
+!call VecCreateMPI(PETSC_COMM_WORLD,PETSC_DECIDE,IS_riv_bas,ZV_k,ierr)
+call VecCreate(PETSC_COMM_WORLD,ZV_k,ierr)
+call VecSetSizes(ZV_k,PETSC_DECIDE,IS_riv_bas,ierr)
+call VecSetFromOptions(ZV_k,ierr)
+!same remarks as above for sizes
+
+call VecDuplicate(ZV_k,ZV_x,ierr)
+call VecDuplicate(ZV_k,ZV_C1,ierr)
+call VecDuplicate(ZV_k,ZV_C2,ierr)
+call VecDuplicate(ZV_k,ZV_C3,ierr)
+call VecDuplicate(ZV_k,ZV_Cdenom,ierr)
+
+call VecDuplicate(ZV_k,ZV_b,ierr)
+call VecDuplicate(ZV_k,ZV_babsmax,ierr)
+call VecDuplicate(ZV_k,ZV_bhat,ierr)
+
+call VecDuplicate(ZV_k,ZV_Qext,ierr)
+call VecDuplicate(ZV_k,ZV_Qfor,ierr)
+call VecDuplicate(ZV_k,ZV_Qlat,ierr)
+call VecDuplicate(ZV_k,ZV_Qhum,ierr)
+call VecDuplicate(ZV_k,ZV_Qdam,ierr)
+call VecDuplicate(ZV_k,ZV_Vext,ierr)
+call VecDuplicate(ZV_k,ZV_Vfor,ierr)
+call VecDuplicate(ZV_k,ZV_Vlat,ierr)
+
+call VecDuplicate(ZV_k,ZV_QoutinitM,ierr)
+call VecDuplicate(ZV_k,ZV_QoutinitO,ierr)
+call VecDuplicate(ZV_k,ZV_QoutbarO,ierr)
+
+call VecDuplicate(ZV_k,ZV_QoutR,ierr)
+call VecDuplicate(ZV_k,ZV_QoutinitR,ierr)
+call VecDuplicate(ZV_k,ZV_QoutprevR,ierr)
+call VecDuplicate(ZV_k,ZV_QoutbarR,ierr)
+call VecDuplicate(ZV_k,ZV_QinbarR,ierr)
+call VecDuplicate(ZV_k,ZV_QoutRabsmin,ierr)
+call VecDuplicate(ZV_k,ZV_QoutRabsmax,ierr)
+call VecDuplicate(ZV_k,ZV_QoutRhat,ierr)
+
+call VecDuplicate(ZV_k,ZV_VinitM,ierr)
+
+call VecDuplicate(ZV_k,ZV_VR,ierr)
+call VecDuplicate(ZV_k,ZV_VinitR,ierr)
+call VecDuplicate(ZV_k,ZV_VprevR,ierr)
+call VecDuplicate(ZV_k,ZV_VbarR,ierr)
+call VecDuplicate(ZV_k,ZV_VoutR,ierr)
+
+call VecDuplicate(ZV_k,ZV_temp1,ierr)
+call VecDuplicate(ZV_k,ZV_temp2,ierr)
+call VecDuplicate(ZV_k,ZV_Qobs,ierr)
+call VecDuplicate(ZV_k,ZV_kfac,ierr)
+call VecDuplicate(ZV_k,ZV_Qobsbarrec,ierr)
+!all the other vector objects are duplicates of the first one
+
+
+!Vectors of parameters----------------------------------------------------------
+!call VecCreateMPI(PETSC_COMM_WORLD,PETSC_DECIDE,IS_one*2,ZV_p,ierr)
+call VecCreate(PETSC_COMM_WORLD,ZV_p,ierr)
+call VecSetSizes(ZV_p,PETSC_DECIDE,2*IS_one,ierr)
+call VecSetFromOptions(ZV_p,ierr)
+!same remarks as above for sizes
+
+call VecDuplicate(ZV_p,ZV_pnorm,ierr)
+call VecDuplicate(ZV_p,ZV_pfac,ierr)
+ 
+
+!Vectors and objects useful for PETSc programming-------------------------------
+call VecDuplicate(ZV_k,ZV_one,ierr)
+call VecSet(ZV_one,ZS_one,ierr)
+!this is a vector with ones a each row, used for computations
+
+call VecScatterCreateToZero(ZV_k,vecscat,ZV_SeqZero,ierr)
+!create scatter context from a distributed vector to a sequential vector on the 
+!zeroth processor.  Also creates the vector ZV_SeqZero
+
+
+!TAO specific-------------------------------------------------------------------
+#ifndef NO_TAO
+call TaoInitialize(PETSC_NULL_CHARACTER,ierr)
+!Initialize TAO
+
+call TaoCreate(PETSC_COMM_WORLD,tao,ierr)
+call TaoSetType(tao,'tao_nm',ierr)
+!Create TAO App 
+
+call VecDuplicate(ZV_p,ZV_1stIndex,ierr)
+call VecSetValues(ZV_1stIndex,IS_one,0*IS_one,ZS_one,INSERT_VALUES,ierr)
+call VecAssemblyBegin(ZV_1stIndex,ierr)
+call VecAssemblyEnd(ZV_1stIndex,ierr)
+!ZV_1stindex=[1;0]
+
+call VecDuplicate(ZV_p,ZV_2ndIndex,ierr)
+call VecSetValues(ZV_2ndIndex,IS_one,IS_one,ZS_one,INSERT_VALUES,ierr)
+call VecAssemblyBegin(ZV_2ndIndex,ierr)
+call VecAssemblyEnd(ZV_2ndIndex,ierr)
+!ZV_2ndindex=[0;1]
+#endif
+
+end subroutine rapid_create_obj
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_destro_obj.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_destro_obj.F90
new file mode 100644
index 00000000..c7c77c16
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_destro_obj.F90
@@ -0,0 +1,147 @@
+!*******************************************************************************
+!Subroutine - rapid_destro_obj
+!*******************************************************************************
+subroutine rapid_destro_obj 
+
+!Purpose:
+!All PETSc and TAO objects need be destroyed (requirement of both mathematical 
+!libraries).  PETSc and TAO also need be finalized.  This is what's done here
+!Note: only finilized here, need to add destroy of vectors.
+!Author: 
+!Cedric H. David, 2008-2015. 
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   IS_riv_bas,                                                 &
+                   ZM_hsh_tot,ZM_hsh_bas,                                      &
+                   ZM_Net,ZM_A,ZM_T,ZM_TC1,                                    &
+                   ZM_Obs,ZV_Qobs,ZV_temp1,ZV_temp2,ZV_kfac,                   &
+                   ZV_k,ZV_x,ZV_p,ZV_pnorm,ZV_pfac,                            &
+                   ZV_C1,ZV_C2,ZV_C3,ZV_Cdenom,                                &
+                   ZV_b,ZV_babsmax,ZV_bhat,                                    &
+                   ZV_Qext,ZV_Qfor,ZV_Qlat,ZV_Qhum,ZV_Qdam,                    &
+                   ZV_Vext,ZV_Vfor,ZV_Vlat,                                    &
+                   ZV_VinitM,ZV_QoutinitM,ZV_QoutinitO,ZV_QoutbarO,            &
+                   ZV_QoutR,ZV_QoutinitR,ZV_QoutprevR,ZV_QoutbarR,ZV_QinbarR,  &
+                   ZV_QoutRabsmin,ZV_QoutRabsmax,ZV_QoutRhat,                  &
+                   ZV_VR,ZV_VinitR,ZV_VprevR,ZV_VbarR,ZV_VoutR,                &
+                   ZV_Qobsbarrec,                                              &
+                   ierr,ksp,vecscat,ZV_SeqZero,ZS_one,ZV_one,IS_one
+
+#ifndef NO_TAO
+use rapid_var, only :                                                          &
+                   tao,reason,ZV_1stIndex,ZV_2ndIndex
+#endif
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+
+#ifndef NO_TAO
+#include "finclude/taosolver.h" 
+!TAO solver
+#endif
+
+
+!*******************************************************************************
+!Destruct all objects and finalize PETSc and TAO
+!*******************************************************************************
+!TAO specific-------------------------------------------------------------------
+#ifndef NO_TAO
+call VecDestroy(ZV_1stIndex,ierr)
+call VecDestroy(ZV_2ndIndex,ierr)
+call TaoDestroy(tao,ierr)
+call TaoFinalize(ierr)
+#endif
+
+call KSPDestroy(ksp,ierr)
+
+call MatDestroy(ZM_hsh_tot,ierr)
+call MatDestroy(ZM_hsh_bas,ierr)
+
+call MatDestroy(ZM_A,ierr)
+call MatDestroy(ZM_Net,ierr)
+call MatDestroy(ZM_T,ierr)
+call MatDestroy(ZM_TC1,ierr)
+call MatDestroy(ZM_Obs,ierr)
+
+call VecDestroy(ZV_k,ierr)
+call VecDestroy(ZV_x,ierr)
+call VecDestroy(ZV_C1,ierr)
+call VecDestroy(ZV_C2,ierr)
+call VecDestroy(ZV_C3,ierr)
+call VecDestroy(ZV_Cdenom,ierr)
+
+call VecDestroy(ZV_b,ierr)
+call VecDestroy(ZV_babsmax,ierr)
+call VecDestroy(ZV_bhat,ierr)
+
+call VecDestroy(ZV_Qext,ierr)
+call VecDestroy(ZV_Qfor,ierr)
+call VecDestroy(ZV_Qlat,ierr)
+call VecDestroy(ZV_Qhum,ierr)
+call VecDestroy(ZV_Qdam,ierr)
+call VecDestroy(ZV_Vext,ierr)
+call VecDestroy(ZV_Vfor,ierr)
+call VecDestroy(ZV_Vlat,ierr)
+
+call VecDestroy(ZV_QoutinitM,ierr)
+call VecDestroy(ZV_QoutinitO,ierr)
+call VecDestroy(ZV_QoutbarO,ierr)
+
+call VecDestroy(ZV_QoutR,ierr)
+call VecDestroy(ZV_QoutinitR,ierr)
+call VecDestroy(ZV_QoutprevR,ierr)
+call VecDestroy(ZV_QoutbarR,ierr)
+call VecDestroy(ZV_QinbarR,ierr)
+call VecDestroy(ZV_QoutRabsmin,ierr)
+call VecDestroy(ZV_QoutRabsmax,ierr)
+call VecDestroy(ZV_QoutRhat,ierr)
+
+call VecDestroy(ZV_VinitM,ierr)
+
+call VecDestroy(ZV_VR,ierr)
+call VecDestroy(ZV_VinitR,ierr)
+call VecDestroy(ZV_VprevR,ierr)
+call VecDestroy(ZV_VbarR,ierr)
+call VecDestroy(ZV_VoutR,ierr)
+
+call VecDestroy(ZV_temp1,ierr)
+call VecDestroy(ZV_temp2,ierr)
+call VecDestroy(ZV_Qobs,ierr)
+call VecDestroy(ZV_kfac,ierr)
+call VecDestroy(ZV_Qobsbarrec,ierr)
+
+call VecDestroy(ZV_one,ierr)
+
+call VecDestroy(ZV_p,ierr)
+call VecDestroy(ZV_pnorm,ierr)
+call VecDestroy(ZV_pfac,ierr)
+
+call VecDestroy(ZV_SeqZero,ierr)
+call VecScatterDestroy(vecscat,ierr)
+!Need to be destroyed separately even though created together
+
+call PetscFinalize(ierr)
+
+
+end subroutine rapid_destro_obj 
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_final.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_final.F90
new file mode 100644
index 00000000..a1a2ca98
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_final.F90
@@ -0,0 +1,192 @@
+!*******************************************************************************
+!Subroutine - rapid_final 
+!*******************************************************************************
+subroutine rapid_final
+
+!Purpose:
+!This subroutine allows to finalize RAPID for both regular runs and 
+!optimization runs, by performing slightly different tasks depending on what 
+!option is chosen.  
+!Finalization Initialization tasks specific to Option 1
+!     -Output final instantaneous flow
+!     -Output babsmax, QoutRabsmin and QoutRabsmax
+!Finalization Initialization tasks specific to Option 2
+!     -N/A
+!Finalization tasks common to all RAPID options:
+!     -Prints some information about the types of objects used during simulation
+!     -Destroy all PETSc and TAO objects 
+!Author: 
+!Cedric H. David, 2012-2015. 
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   IS_riv_bas,JS_riv_bas,                                      &
+                   IS_opt_routing,IS_opt_run,                                  &
+                   BS_opt_Qfinal,BS_opt_influence,                             &
+                   Qfinal_file,babsmax_file,QoutRabsmin_file,QoutRabsmax_file, &
+                   ksp,vecscat,ZV_babsmax,ZV_QoutR,ZV_SeqZero,ierr,            &
+                   ZV_pointer,rank,ZV_k,temp_char,                             &
+                   ZV_QoutRabsmin,ZV_QoutRabsmax,                              &
+                   temp_char2,ZM_A,pc,                                         &
+                   IS_ksp_iter_max
+
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/petsclog.h" 
+!PETSc log
+
+
+!*******************************************************************************
+!Finalization procedure for OPTION 1
+!*******************************************************************************
+if (IS_opt_run==1) then
+
+!-------------------------------------------------------------------------------
+!Output final instantaneous Q (ZV_QoutR)
+!-------------------------------------------------------------------------------
+if (BS_opt_Qfinal) then
+call VecScatterBegin(vecscat,ZV_QoutR,ZV_SeqZero,                              &
+                     INSERT_VALUES,SCATTER_FORWARD,ierr)
+call VecScatterEnd(vecscat,ZV_QoutR,ZV_SeqZero,                                &
+                        INSERT_VALUES,SCATTER_FORWARD,ierr)
+call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+if (rank==0) then 
+     open(31,file=Qfinal_file)
+     do JS_riv_bas=1,IS_riv_bas
+          write(31,*) ZV_pointer(JS_riv_bas)
+     end do
+     close(31)
+end if
+call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+end if
+
+!-------------------------------------------------------------------------------
+!Output maximum absolute values of vector b (right-hand side of linear system)
+!-------------------------------------------------------------------------------
+if (BS_opt_influence) then
+call VecScatterBegin(vecscat,ZV_babsmax,ZV_SeqZero,                            &
+                     INSERT_VALUES,SCATTER_FORWARD,ierr)
+call VecScatterEnd(vecscat,ZV_babsmax,ZV_SeqZero,                              &
+                        INSERT_VALUES,SCATTER_FORWARD,ierr)
+call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+if (rank==0) then 
+     open(42,file=babsmax_file)
+     do JS_riv_bas=1,IS_riv_bas
+          write(42,*) ZV_pointer(JS_riv_bas)
+     end do
+     close(42)
+end if
+call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+end if
+
+!-------------------------------------------------------------------------------
+!Output minimum absolute values of instantaneous flow 
+!-------------------------------------------------------------------------------
+if (BS_opt_influence) then
+call VecScatterBegin(vecscat,ZV_QoutRabsmin,ZV_SeqZero,                        &
+                     INSERT_VALUES,SCATTER_FORWARD,ierr)
+call VecScatterEnd(vecscat,ZV_QoutRabsmin,ZV_SeqZero,                          &
+                        INSERT_VALUES,SCATTER_FORWARD,ierr)
+call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+if (rank==0) then 
+     open(43,file=QoutRabsmin_file)
+     do JS_riv_bas=1,IS_riv_bas
+          write(43,*) ZV_pointer(JS_riv_bas)
+     end do
+     close(43)
+end if
+call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+end if
+
+!-------------------------------------------------------------------------------
+!Output maximum absolute values of instantaneous flow 
+!-------------------------------------------------------------------------------
+if (BS_opt_influence) then
+call VecScatterBegin(vecscat,ZV_QoutRabsmax,ZV_SeqZero,                        &
+                     INSERT_VALUES,SCATTER_FORWARD,ierr)
+call VecScatterEnd(vecscat,ZV_QoutRabsmax,ZV_SeqZero,                          &
+                        INSERT_VALUES,SCATTER_FORWARD,ierr)
+call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+if (rank==0) then 
+     open(44,file=QoutRabsmax_file)
+     do JS_riv_bas=1,IS_riv_bas
+          write(44,*) ZV_pointer(JS_riv_bas)
+     end do
+     close(44)
+end if
+call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+end if
+
+!-------------------------------------------------------------------------------
+!End of initialization procedure for OPTION 1
+!-------------------------------------------------------------------------------
+end if
+
+
+!*******************************************************************************
+!Some information about types of objects used within RAPID run
+!*******************************************************************************
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+call VecGetType(ZV_k,temp_char,ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'type of vector: '//temp_char//char(10),ierr)
+call MatGetType(ZM_A,temp_char,ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'type of matrix: '//temp_char//char(10),ierr)
+if (IS_opt_routing==1 .or. IS_opt_routing==3) then 
+     call KSPGetType(ksp,temp_char,ierr)
+else
+     temp_char='No KSP'
+end if
+call PetscPrintf(PETSC_COMM_WORLD,'type of KSP   : '//temp_char//char(10),ierr)
+if (IS_opt_routing==1 .or. IS_opt_routing==3) then 
+     call KSPGetPC(ksp,pc,ierr)
+     call PCGetType(pc,temp_char,ierr)
+else
+     temp_char='No PC'
+end if
+call PetscPrintf(PETSC_COMM_WORLD,'type of PC    : '//temp_char//char(10),ierr)
+#ifdef NO_TAO
+call PetscPrintf(PETSC_COMM_WORLD,char(10),ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'RAPID compiled and run without TAO',ierr)
+call PetscPrintf(PETSC_COMM_WORLD,char(10),ierr)
+#endif
+write(temp_char ,'(i10)') rank
+write(temp_char2,'(i10)') IS_ksp_iter_max
+call PetscSynchronizedPrintf(PETSC_COMM_WORLD,'Rank     :'//temp_char //', '// &
+                                              'Max KSP  :'//temp_char2//       &
+                                               char(10),ierr)
+call PetscSynchronizedFlush(PETSC_COMM_WORLD,ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+call PetscPrintf(PETSC_COMM_WORLD,char(10)//char(10)//char(10)//char(10),ierr)
+
+!*******************************************************************************
+!Destroy all objects
+!*******************************************************************************
+call rapid_destro_obj
+!destroy PETSc and TAO objects (Mat,Vec,taoapp...), finalizes the libraries
+
+
+!*******************************************************************************
+!End subroutine
+!*******************************************************************************
+end subroutine rapid_final
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_get_Qdam.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_get_Qdam.F90
new file mode 100644
index 00000000..91e58452
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_get_Qdam.F90
@@ -0,0 +1,129 @@
+!*******************************************************************************
+!Subroutine - rapid_get_Qdam
+!*******************************************************************************
+subroutine rapid_get_Qdam
+
+!Purpose:
+!Communicate with a dam subroutine to exchange inflows and outflows.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   rank,ierr,vecscat,ZV_pointer,ZV_SeqZero,ZS_one,             &
+                   ZM_Net,ZV_Qext,ZV_Qdam,ZV_QoutbarR,ZV_QinbarR,              &
+                   IS_dam_bas,IV_dam_index,IV_dam_loc2,                        &
+                   IV_dam_pos
+
+use rapid_var, only :                                                          &
+                   ZV_Qin_dam,ZV_Qout_dam,ZV_Qin_dam_prev,ZV_Qout_dam_prev
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/petsclog.h" 
+!PETSc log
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Compute previous inflow from river network and outside of river network to dams
+!*******************************************************************************
+!-------------------------------------------------------------------------------
+!Compute inflow into dams from previous river flow
+!-------------------------------------------------------------------------------
+call MatMult(ZM_Net,ZV_QoutbarR,ZV_QinbarR,ierr)           
+call VecAXPY(ZV_QinbarR,ZS_one,ZV_Qext,ierr)
+!QinbarR=Net*QoutbarR+Qext
+
+!-------------------------------------------------------------------------------
+!Set values from PETSc vector into Fortran vector 
+!-------------------------------------------------------------------------------
+if (rank==0) ZV_Qin_dam_prev=0 
+call VecScatterBegin(vecscat,ZV_QinbarR,ZV_SeqZero,                            &
+                     INSERT_VALUES,SCATTER_FORWARD,ierr)
+call VecScatterEnd(vecscat,ZV_QinbarR,ZV_SeqZero,                              &
+                        INSERT_VALUES,SCATTER_FORWARD,ierr)
+call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+if (rank==0) ZV_Qin_dam_prev=ZV_pointer(IV_dam_pos) 
+call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+!Get values from ZV_QinbarR (PETSc) into ZV_Qin_dam_prev (Fortran)
+
+
+!*******************************************************************************
+!Compute outflow from dams
+!*******************************************************************************
+!-------------------------------------------------------------------------------
+!If dam module does not exist, outflow is computed from this subroutine
+!-------------------------------------------------------------------------------
+if (rank==0) then 
+     ZV_Qout_dam=ZV_Qin_dam_prev
+end if
+
+!-------------------------------------------------------------------------------
+!If dam module does exist, use it
+!-------------------------------------------------------------------------------
+!if (rank==0) then 
+!     call dam_linear(ZV_Qin_dam_prev,ZV_Qout_dam_prev,ZV_Qout_dam)
+!end if
+
+
+!*******************************************************************************
+!Optional - Write information in stdout 
+!*******************************************************************************
+!if (rank==0) print *, 'Qin_dam_prev  =', ',', ZV_Qin_dam_prev
+!if (rank==0) print *, 'Qin_dam_prev  =', ',', ZV_Qin_dam_prev(1)
+!if (rank==0) print *, 'Qout_dam_prev =', ',', ZV_Qout_dam_prev
+!if (rank==0) print *, 'Qout_dam_prev =', ',', ZV_Qout_dam_prev(1)
+!if (rank==0) print *, ZV_Qin_dam_prev(1), ',', ZV_Qout_dam_prev(1)
+!call VecView(ZV_Qdam,PETSC_VIEWER_STDOUT_WORLD,ierr)
+
+
+!*******************************************************************************
+!Set values from Fortran vector into PETSc vector 
+!*******************************************************************************
+if (rank==0) then
+     call VecSetValues(ZV_Qdam,IS_dam_bas,IV_dam_loc2,                         &
+                       ZV_Qout_dam(IV_dam_index),INSERT_VALUES,ierr)
+end if
+
+call VecAssemblyBegin(ZV_Qdam,ierr)
+call VecAssemblyEnd(ZV_Qdam,ierr)           
+
+
+!*******************************************************************************
+!Update ZV_Qout_dam_prev - After calling dam_linear to not override init. values 
+!*******************************************************************************
+if (rank==0) then 
+     ZV_Qout_dam_prev=ZV_Qout_dam
+end if
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_get_Qdam
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_hsh_mat.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_hsh_mat.F90
new file mode 100644
index 00000000..c3a4fd64
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_hsh_mat.F90
@@ -0,0 +1,236 @@
+!*******************************************************************************
+!Subroutine - rapid_hsh_mat
+!*******************************************************************************
+subroutine rapid_hsh_mat
+
+!Purpose:
+!This creates two hashtable-like sparse matrices:
+! - IM_hsh_tot contains the index over the domain (JS_riv_tot) corresponding to
+!   each reach ID and is the same for each row
+! - IM_hsh_bas contains the index over the basin (JS_riv_bas) corresponding to
+!   each reach ID and is the same for each row
+!The choice of matrices to mimic hashtables is possible because the "keys" (i.e.
+!the reach IDs) are all integers, and the sparse structure allows to keep memory 
+!usage minimal because the number of unique reach IDs is far inferior to the
+!maximum integer value of reach ID.  Implementing a C++ hashtable within Fortran 
+!would have required much more intrusive modifications to RAPID. 
+!Thank you to Chris A. Mattmann and to Si Liu who both suggested the use of 
+!hashtables to decrease model setup time.
+!Author: 
+!Cedric H. David, 2015-2015.
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   IS_riv_tot,IS_riv_bas,                                      &
+                   JS_riv_tot,JS_riv_bas,                                      &
+                   IV_riv_tot_id,IV_riv_bas_id,                                &
+                   IS_riv_id_max,                                              &
+                   ZM_hsh_tot,ZM_hsh_bas,                                      &
+                   IS_ownfirst,IS_ownlast,                                     &
+                   IS_one,ZS_one,temp_char,temp_char2,ierr,rank,ncore
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+PetscInt, dimension(ncore)  :: IS_nz, IS_dnz, IS_onz
+PetscInt, dimension(IS_riv_tot) :: IV_tot_tmp1, IV_tot_tmp2
+PetscInt, dimension(IS_riv_bas) :: IV_bas_tmp1, IV_bas_tmp2
+
+
+!*******************************************************************************
+!Check that reach IDs are within the allowed range 
+!*******************************************************************************
+write(temp_char2,'(i10)') IS_riv_id_max 
+
+do JS_riv_tot=1,IS_riv_tot
+     if (IV_riv_tot_id(JS_riv_tot) > IS_riv_id_max) then 
+          write(temp_char,'(i10)') IV_riv_tot_id(JS_riv_tot)
+          call PetscPrintf(PETSC_COMM_WORLD,                                   &
+                           'ERROR: reach ID' // temp_char // ' in domain' //   &
+                           ' has an integer value greater than the maximum' // &
+                           ' allowed of' // temp_char2 // char(10),ierr)
+          stop
+     end if
+     if (IV_riv_tot_id(JS_riv_tot) == 0) then 
+          write(temp_char,'(i10)') JS_riv_tot
+          call PetscPrintf(PETSC_COMM_WORLD,                                   &
+                           'ERROR: reach ID located at index'// temp_char//    &
+                           ' in domain has a null value for ID'//char(10),ierr)
+          stop
+     end if
+end do
+
+do JS_riv_bas=1,IS_riv_bas
+     if (IV_riv_bas_id(JS_riv_bas) > IS_riv_id_max) then 
+          write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas)
+          call PetscPrintf(PETSC_COMM_WORLD,                                   &
+                           'ERROR: reach ID' // temp_char // ' in basin' //    &
+                           ' has an integer value greater than the maximum' // &
+                           ' allowed of' // temp_char2 // char(10),ierr)
+          stop
+     end if
+     if (IV_riv_bas_id(JS_riv_bas) == 0) then 
+          write(temp_char,'(i10)') JS_riv_bas
+          call PetscPrintf(PETSC_COMM_WORLD,                                   &
+                           'ERROR: reach ID located at index'// temp_char//    &
+                           ' in basin has a null value for ID'//char(10),ierr)
+          stop
+     end if
+end do
+
+
+!*******************************************************************************
+!Matrix preallocation
+!*******************************************************************************
+call MatGetOwnershipRangeColumn(ZM_hsh_tot,IS_ownfirst,IS_ownlast,ierr)
+
+!-------------------------------------------------------------------------------
+!ZM_hsh_tot
+!-------------------------------------------------------------------------------
+IS_nz=0
+IS_dnz=0
+IS_onz=0
+
+IS_nz=IS_riv_tot
+do JS_riv_tot=1,IS_riv_tot 
+     if (IV_riv_tot_id(JS_riv_tot) -1 >= IS_ownfirst .and.                     &
+         IV_riv_tot_id(JS_riv_tot) -1 <  IS_ownlast) then
+          IS_dnz=IS_dnz+1
+     end if
+     IS_onz=IS_nz-IS_dnz
+end do
+
+call MatSeqAIJSetPreallocation(ZM_hsh_tot,PETSC_NULL_INTEGER,IS_nz,ierr)
+call MatMPIAIJSetPreallocation(ZM_hsh_tot,                                     &
+                               PETSC_NULL_INTEGER,                             &
+                               IS_dnz,                                         &
+                               PETSC_NULL_INTEGER,                             &
+                               IS_onz,ierr)
+!print *, 'rank', rank, 'IS_ownfirst', IS_ownfirst, 'IS_ownlast', IS_ownlast,   &
+!         'IS_nz', IS_nz, 'IS_dnz', IS_dnz, 'IS_onz', IS_onz
+
+!-------------------------------------------------------------------------------
+!ZM_hsh_bas
+!-------------------------------------------------------------------------------
+IS_nz=0
+IS_dnz=0
+IS_onz=0
+
+IS_nz=IS_riv_bas
+do JS_riv_bas=1,IS_riv_bas 
+     if (IV_riv_bas_id(JS_riv_bas) -1 >= IS_ownfirst .and.                     &
+         IV_riv_bas_id(JS_riv_bas) -1 <  IS_ownlast) then
+          IS_dnz=IS_dnz+1
+     end if
+     IS_onz=IS_nz-IS_dnz
+end do
+
+call MatSeqAIJSetPreallocation(ZM_hsh_bas,PETSC_NULL_INTEGER,IS_nz,ierr)
+call MatMPIAIJSetPreallocation(ZM_hsh_bas,                                     &
+                               PETSC_NULL_INTEGER,                             &
+                               IS_dnz,                                         &
+                               PETSC_NULL_INTEGER,                             &
+                               IS_onz,ierr)
+!print *, 'rank', rank, 'IS_ownfirst', IS_ownfirst, 'IS_ownlast', IS_ownlast,   &
+!         'IS_nz', IS_nz, 'IS_dnz', IS_dnz, 'IS_onz', IS_onz
+
+!-------------------------------------------------------------------------------
+!Done with preallocation
+!-------------------------------------------------------------------------------
+call PetscPrintf(PETSC_COMM_WORLD,'Hashtable-like matrices preallocated'       &
+                 //char(10),ierr)
+
+
+!*******************************************************************************
+!Creates hashtable-like matrices
+!*******************************************************************************
+
+!-------------------------------------------------------------------------------
+!ZM_hsh_tot
+!-------------------------------------------------------------------------------
+do JS_riv_tot=1,IS_riv_tot
+     IV_tot_tmp1(JS_riv_tot)=IV_riv_tot_id(JS_riv_tot)
+     IV_tot_tmp2(JS_riv_tot)=JS_riv_tot
+end do
+call PetscSortIntWithArray(IS_riv_tot,IV_tot_tmp1(:),IV_tot_tmp2(:),ierr)
+!Populating ZM_hsh_* below much faster w/ sorted arrays than w/ IV_riv_*_id
+
+do JS_riv_tot=1,IS_riv_tot
+     call MatSetValues(ZM_hsh_tot,                                             &
+                       IS_one,rank,                                            &
+                       IS_one,IV_tot_tmp1(JS_riv_tot)-1,                       &
+                       ZS_one*IV_tot_tmp2(JS_riv_tot),INSERT_VALUES,ierr)
+     CHKERRQ(ierr)
+end do
+
+!-------------------------------------------------------------------------------
+!ZM_hsh_bas
+!-------------------------------------------------------------------------------
+do JS_riv_bas=1,IS_riv_bas
+     IV_bas_tmp1(JS_riv_bas)=IV_riv_bas_id(JS_riv_bas)
+     IV_bas_tmp2(JS_riv_bas)=JS_riv_bas
+end do
+call PetscSortIntWithArray(IS_riv_bas,IV_bas_tmp1(:),IV_bas_tmp2(:),ierr)
+!Populating ZM_hsh_* below much faster w/ sorted arrays than w/ IV_riv_*_id
+
+do JS_riv_bas=1,IS_riv_bas
+     call MatSetValues(ZM_hsh_bas,                                             &
+                       IS_one,rank,                                            &
+                       IS_one,IV_bas_tmp1(JS_riv_bas)-1,                       &
+                       ZS_one*IV_bas_tmp2(JS_riv_bas),INSERT_VALUES,ierr)
+     CHKERRQ(ierr)
+end do
+
+!-------------------------------------------------------------------------------
+!Assemble matrices
+!-------------------------------------------------------------------------------
+call MatAssemblyBegin(ZM_hsh_tot,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyEnd(ZM_hsh_tot,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyBegin(ZM_hsh_bas,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyEnd(ZM_hsh_bas,MAT_FINAL_ASSEMBLY,ierr)
+!sparse matrices need be assembled once their elements have been filled
+call PetscPrintf(PETSC_COMM_WORLD,'Hashtable-like matrices created'//char(10), &
+                 ierr)
+
+
+!*******************************************************************************
+!Display matrices on stdout
+!*******************************************************************************
+!call PetscPrintf(PETSC_COMM_WORLD,'ZM_hsh_tot'//char(10),ierr)
+!call MatView(ZM_hsh_tot,PETSC_VIEWER_STDOUT_WORLD,ierr)
+!
+!call PetscPrintf(PETSC_COMM_WORLD,'ZM_hsh_bas'//char(10),ierr)
+!call MatView(ZM_hsh_bas,PETSC_VIEWER_STDOUT_WORLD,ierr)
+
+
+!*******************************************************************************
+!End
+!*******************************************************************************
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+
+
+end subroutine rapid_hsh_mat
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_init.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_init.F90
new file mode 100644
index 00000000..71766b03
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_init.F90
@@ -0,0 +1,397 @@
+!*******************************************************************************
+!Subroutine - rapid_init 
+!*******************************************************************************
+subroutine rapid_init
+
+!Purpose:
+!This subroutine allows to initialize RAPID for both regular runs and 
+!optimization runs, by performing slightly different tasks depending on what 
+!option is chosen.  
+!Initialization tasks common to all RAPID options:
+!     -Read namelist file (sizes of domain, duration, file names, options, etc.)  
+!     -Compute number of time steps based on durations
+!     -Allocate Fortran arrays
+!     -Create all PETSc and TAO objects 
+!     -Print information and warnings
+!     -Determine IDs for various computing cores
+!     -Compute helpful arrays 
+!     -Compute the network matrix
+!     -Initialize values of flow and volume for main procedure
+!Initialization tasks specific to Option 1
+!     -Copy main initial flow and vol to routing initial flow and vol
+!     -Read k and x 
+!     -Compute linear system matrix
+!Initialization tasks specific to Option 2
+!     -Copy main initial flow to optimization initial flow
+!     -Compute the observation matrix
+!     -Read kfac and Qobsbarrec
+!     -Set initial values for the vector pnorm
+!Author: 
+!Cedric H. David, 2012-2015. 
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   IS_riv_tot,IS_riv_bas,                                      &
+                   IV_riv_bas_id,IV_riv_index,IV_riv_loc1,IV_riv_tot_id,       &
+                   IV_down,IV_nbup,IM_up,IM_index_up,IS_max_up,                &
+                   IV_nz,IV_dnz,IV_onz,                                        &
+                   BS_opt_Qinit,BS_opt_Qfinal,BS_opt_influence,                & 
+                   BS_opt_dam,BS_opt_for,BS_opt_hum,                           &
+                   IS_opt_run,IS_opt_routing,IS_opt_phi,                       &
+                   ZV_read_riv_tot,ZV_read_obs_tot,ZV_read_hum_tot,            &
+                   ZV_read_for_tot,ZV_read_dam_tot,                            &
+                   ZS_TauM,ZS_TauO,ZS_TauR,ZS_dtO,ZS_dtR,ZS_dtM,ZS_dtF,ZS_dtH, &
+                   IS_obs_tot,IS_obs_use,IS_obs_bas,                           &
+                   IV_obs_tot_id,IV_obs_use_id,                                &
+                   IV_obs_index,IV_obs_loc1,                                   &
+                   IS_hum_tot,IS_hum_use,                                      &
+                   IV_hum_tot_id,IV_hum_use_id,                                &
+                   IS_for_tot,IS_for_use,                                      &
+                   IV_for_tot_id,IV_for_use_id,                                &
+                   IS_dam_tot,IS_dam_use,                                      &
+                   IV_dam_tot_id,IV_dam_use_id,                                &
+                   ZV_Qin_dam,ZV_Qout_dam,ZV_Qin_dam_prev,ZV_Qout_dam_prev,    &
+                   ZV_Qin_dam0,ZV_Qout_dam0,                                   &
+                   ZV_QoutinitM,ZV_QoutinitO,ZV_QoutinitR,                     &
+                   ZV_VinitM,ZV_VinitR,                                        &
+                   ZV_babsmax,ZV_QoutRabsmin,ZV_QoutRabsmax,                   &
+                   IS_M,IS_O,IS_R,IS_RpO,IS_RpM,IS_RpF,IS_RpH,                 &
+                   kfac_file,x_file,k_file,Vlat_file,Qinit_file,               &
+                   Qobsbarrec_file,                                            &
+                   ZS_Qout0,ZS_V0,                                             &
+                   ZV_Qobsbarrec,                                              &
+                   ZV_k,ZV_x,ZV_kfac,ZV_p,ZV_pnorm,ZV_pfac,                    &
+                   ZS_knorm_init,ZS_xnorm_init,ZS_kfac,ZS_xfac,                &
+                   ZV_C1,ZV_C2,ZV_C3,ZM_A,                                     &
+                   ierr,ksp,rank,ncore,IS_one,ZS_one
+
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/petsclog.h" 
+!PETSc log
+
+!*******************************************************************************
+!Initialization procedure common to all options
+!*******************************************************************************
+
+!-------------------------------------------------------------------------------
+!Read name list, allocate Fortran arrays
+!-------------------------------------------------------------------------------
+call rapid_read_namelist
+
+print *,'!!!LPR enter rapid_init'
+
+allocate(IV_riv_bas_id(IS_riv_bas))
+allocate(IV_riv_index(IS_riv_bas))
+allocate(IV_riv_loc1(IS_riv_bas))
+
+allocate(IV_riv_tot_id(IS_riv_tot))
+allocate(IV_down(IS_riv_tot))
+allocate(IV_nbup(IS_riv_tot))
+allocate(IM_up(IS_riv_tot,IS_max_up))
+allocate(IM_index_up(IS_riv_tot,IS_max_up))
+
+allocate(IV_nz(IS_riv_bas))
+allocate(IV_dnz(IS_riv_bas))
+allocate(IV_onz(IS_riv_bas))
+
+allocate(ZV_read_riv_tot(IS_riv_tot))
+
+print *,'!!!LPR passed several allocation'
+
+if (IS_opt_run==2) then
+     allocate(IV_obs_tot_id(IS_obs_tot))
+     allocate(IV_obs_use_id(IS_obs_use))
+     allocate(ZV_read_obs_tot(IS_obs_tot))
+end if
+
+if (BS_opt_hum) then
+     allocate(IV_hum_tot_id(IS_hum_tot))
+     allocate(IV_hum_use_id(IS_hum_use))
+     allocate(ZV_read_hum_tot(IS_hum_tot))
+end if
+
+if (BS_opt_for) then
+     allocate(IV_for_tot_id(IS_for_tot))
+     allocate(IV_for_use_id(IS_for_use))
+     allocate(ZV_read_for_tot(IS_for_tot))
+end if
+
+if (BS_opt_dam) then
+     allocate(IV_dam_tot_id(IS_dam_tot))
+     allocate(IV_dam_use_id(IS_dam_use))
+     allocate(ZV_read_dam_tot(IS_dam_tot))
+     allocate(ZV_Qin_dam(IS_dam_tot))
+     allocate(ZV_Qin_dam_prev(IS_dam_tot))
+     allocate(ZV_Qout_dam(IS_dam_tot))
+     allocate(ZV_Qout_dam_prev(IS_dam_tot))
+     allocate(ZV_Qin_dam0(IS_dam_tot))
+     allocate(ZV_Qout_dam0(IS_dam_tot))
+end if
+
+!-------------------------------------------------------------------------------
+!Make sure some Fortran arrays are initialized to zero
+!-------------------------------------------------------------------------------
+if (BS_opt_dam) then
+     ZV_Qin_dam0 =0
+     ZV_Qout_dam0=0
+end if
+!These are not populated anywhere before being used and hold meaningless values
+
+!-------------------------------------------------------------------------------
+!Compute number of time steps
+!-------------------------------------------------------------------------------
+IS_M=int(ZS_TauM/ZS_dtM)
+IS_O=int(ZS_TauO/ZS_dtO)
+IS_R=int(ZS_TauR/ZS_dtR)
+IS_RpO=int(ZS_dtO/ZS_TauR)
+IS_RpM=int(ZS_dtM/ZS_TauR)
+IS_RpF=int(ZS_dtF/ZS_TauR)
+IS_RpH=int(ZS_dtH/ZS_TauR)
+
+!-------------------------------------------------------------------------------
+!Initialize libraries and create objects common to all options
+!-------------------------------------------------------------------------------
+print *,'!!!LPR before create obj'
+call rapid_create_obj
+print *,'!!!LPR after create obj'
+!Initialize libraries and create PETSc and TAO objects (Mat,Vec,taoapp...)
+
+!-------------------------------------------------------------------------------
+!Prints information about current model run based on info from namelist
+!-------------------------------------------------------------------------------
+if (rank==0 .and. .not. BS_opt_Qinit)                      print '(a70)',      &
+       'Not reading initial flows from a file                                  '
+if (rank==0 .and. BS_opt_Qinit)                            print '(a70)',      &
+       'Reading initial flows from a file                                      '
+if (rank==0 .and. .not. BS_opt_Qfinal .and. IS_opt_run==1) print '(a70)',      &
+       'Not writing final flows into a file                                    '
+if (rank==0 .and. BS_opt_Qfinal .and. IS_opt_run==1)       print '(a70)',      &
+       'Writing final flows into a file                                        '
+if (rank==0 .and. .not. BS_opt_for)                        print '(a70)',      &
+       'Not using forcing                                                      '
+if (rank==0 .and. BS_opt_for)                              print '(a70)',      &
+       'Using forcing                                                          '
+if (rank==0 .and. .not. BS_opt_hum)                        print '(a70)',      &
+       'Not using human-induced flows                                          '
+if (rank==0 .and. BS_opt_hum)                              print '(a70)',      &
+       'Using human-induced flows                                              '
+if (rank==0 .and. IS_opt_routing==1)                       print '(a70)',      &
+       'Routing with matrix-based Muskingum method                             '
+if (rank==0 .and. IS_opt_routing==2)                       print '(a70)',      &
+       'Routing with traditional Muskingum method                              '
+if (rank==0 .and. IS_opt_routing==3)                       print '(a70)',      &
+       'Routing with matrix-based Muskingum method using transboundary matrix  '
+if (rank==0 .and. IS_opt_run==1)                           print '(a70)',      &
+       'RAPID mode: computing flowrates                                        '
+if (rank==0 .and. IS_opt_run==2 .and. IS_opt_phi==1)       print '(a70)',      &
+       'RAPID mode: optimizing parameters, using phi1                          ' 
+if (rank==0 .and. IS_opt_run==2 .and. IS_opt_phi==2)       print '(a70)',      &
+       'RAPID mode: optimizing parameters, using phi2                          ' 
+if (rank==0)                                               print '(a10,a60)',  &
+       'Using    :', Vlat_file 
+if (rank==0 .and. IS_opt_run==1)                           print '(a10,a60)',  &
+       'Using    :',k_file 
+if (rank==0 .and. IS_opt_run==1)                           print '(a10,a60)',  &
+       'Using    :',x_file 
+if (rank==0 .and. IS_opt_run==2)                           print '(a10,a60)',  &
+       'Using    :',kfac_file 
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+
+!-------------------------------------------------------------------------------
+!Calculate helpful arrays  !--LPR: hash-table used to increase efficiency-------
+!-------------------------------------------------------------------------------
+call rapid_arrays   
+!print *,'!!!LPR after rapid_arrays'
+
+!-------------------------------------------------------------------------------
+!Calculate Network matrix
+!-------------------------------------------------------------------------------
+call rapid_net_mat
+!print *,'!!!LPR after rapid_net_mat'
+
+!-------------------------------------------------------------------------------
+!Breaks connections in Network matrix
+!-------------------------------------------------------------------------------
+if (BS_opt_for .or. BS_opt_dam) call rapid_net_mat_brk
+
+!-------------------------------------------------------------------------------
+!calculates or set initial flows and volumes
+!-------------------------------------------------------------------------------
+if (.not. BS_opt_Qinit) then
+call VecSet(ZV_QoutinitM,ZS_Qout0,ierr)
+end if
+
+if (BS_opt_Qinit) then
+print *, 'LPR: RAPID reading its own initialization file ......'
+open(30,file=Qinit_file,status='old')
+read(30,*) ZV_read_riv_tot
+close(30)
+call VecSetValues(ZV_QoutinitM,IS_riv_bas,IV_riv_loc1,                          &
+                  ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr)
+                  !here we use the output of a simulation as the intitial 
+                  !flow rates.  The simulation has to be made on the entire
+                  !domain, the initial value is taken only for the considered
+                  !basin thanks to the vector IV_riv_index
+call VecAssemblyBegin(ZV_QoutinitM,ierr)
+call VecAssemblyEnd(ZV_QoutinitM,ierr)  
+end if
+
+call VecSet(ZV_VinitM,ZS_V0,ierr)
+!Set initial volumes for Main procedure
+
+!-------------------------------------------------------------------------------
+!Initialize default values for ZV_QoutRabsmin, ZV_QoutRabsmax and ZV_babsmax
+!-------------------------------------------------------------------------------
+if (BS_opt_influence) then
+call VecSet(ZV_babsmax    ,ZS_one*0        ,ierr)
+call VecSet(ZV_QoutRabsmin,ZS_one*999999999,ierr)
+call VecSet(ZV_QoutRabsmax,ZS_one*0        ,ierr)
+end if
+
+
+!*******************************************************************************
+!Initialization procedure for OPTION 1
+!*******************************************************************************
+if (IS_opt_run==1) then
+
+!-------------------------------------------------------------------------------
+!copy main initial values into routing initial values 
+!-------------------------------------------------------------------------------
+call VecCopy(ZV_QoutinitM,ZV_QoutinitR,ierr)
+call VecCopy(ZV_VinitM,ZV_VinitR,ierr)
+
+!-------------------------------------------------------------------------------
+!Read/set k and x
+!-------------------------------------------------------------------------------
+open(20,file=k_file,status='old')
+read(20,*) ZV_read_riv_tot
+call VecSetValues(ZV_k,IS_riv_bas,IV_riv_loc1,                                 &
+                  ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr)
+call VecAssemblyBegin(ZV_k,ierr)
+call VecAssemblyEnd(ZV_k,ierr)
+close(20)
+!get values for k in a file and create the corresponding ZV_k vector
+
+open(21,file=x_file,status='old')
+read(21,*) ZV_read_riv_tot
+call VecSetValues(ZV_x,IS_riv_bas,IV_riv_loc1,                                 &
+                  ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr)
+call VecAssemblyBegin(ZV_x,ierr)
+call VecAssemblyEnd(ZV_x,ierr)
+close(21)
+!get values for x in a file and create the corresponding ZV_x vector
+
+!-------------------------------------------------------------------------------
+!Compute routing parameters and linear system matrix
+!-------------------------------------------------------------------------------
+call rapid_routing_param(ZV_k,ZV_x,ZV_C1,ZV_C2,ZV_C3,ZM_A)
+!calculate Muskingum parameters and matrix ZM_A
+
+call KSPSetOperators(ksp,ZM_A,ZM_A,DIFFERENT_NONZERO_PATTERN,ierr)
+call KSPSetType(ksp,KSPRICHARDSON,ierr)                    !default=richardson
+!call KSPSetInitialGuessNonZero(ksp,PETSC_TRUE,ierr)
+!call KSPSetInitialGuessKnoll(ksp,PETSC_TRUE,ierr)
+call KSPSetFromOptions(ksp,ierr)                           !if runtime options
+if (IS_opt_routing==3) call KSPSetType(ksp,KSPPREONLY,ierr)!default=preonly
+
+!-------------------------------------------------------------------------------
+!End of initialization procedure for OPTION 1
+!-------------------------------------------------------------------------------
+end if
+
+
+!*******************************************************************************
+!Initialization procedure for OPTION 2
+!*******************************************************************************
+if (IS_opt_run==2) then
+#ifndef NO_TAO
+
+!-------------------------------------------------------------------------------
+!Create observation matrix
+!-------------------------------------------------------------------------------
+call rapid_obs_mat
+!Create observation matrix
+
+!-------------------------------------------------------------------------------
+!copy main initial values into optimization initial values 
+!-------------------------------------------------------------------------------
+call VecCopy(ZV_QoutinitM,ZV_QoutinitO,ierr)
+!copy initial main variables into initial optimization variables
+
+!-------------------------------------------------------------------------------
+!Read/set kfac, xfac and Qobsbarrec
+!-------------------------------------------------------------------------------
+open(22,file=kfac_file,status='old')
+read(22,*) ZV_read_riv_tot
+close(22)
+call VecSetValues(ZV_kfac,IS_riv_bas,IV_riv_loc1,                              &
+                  ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr)
+                  !only looking at basin, doesn't have to be whole domain here 
+call VecAssemblyBegin(ZV_kfac,ierr)
+call VecAssemblyEnd(ZV_kfac,ierr)  
+!reads kfac and assigns to ZV_kfac
+
+if (IS_opt_phi==2) then
+open(35,file=Qobsbarrec_file,status='old')
+read(35,*) ZV_read_obs_tot
+close(35)
+call VecSetValues(ZV_Qobsbarrec,IS_obs_bas,IV_obs_loc1,                        &
+                  ZV_read_obs_tot(IV_obs_index),INSERT_VALUES,ierr)
+                  !here we only look at the observations within the basin
+                  !studied
+call VecAssemblyBegin(ZV_Qobsbarrec,ierr)
+call VecAssemblyEnd(ZV_Qobsbarrec,ierr)  
+!reads Qobsbarrec and assigns to ZV_Qobsbarrec
+end if
+
+!-------------------------------------------------------------------------------
+!Set pnorm, pfac and p
+!-------------------------------------------------------------------------------
+call VecSetValues(ZV_pnorm,IS_one,IS_one-1,ZS_knorm_init,INSERT_VALUES,ierr)
+call VecSetValues(ZV_pnorm,IS_one,IS_one,ZS_xnorm_init,INSERT_VALUES,ierr)
+call VecAssemblyBegin(ZV_pnorm,ierr)
+call VecAssemblyEnd(ZV_pnorm,ierr)
+!set pnorm to pnorm=(knorm,xnorm)
+
+!call VecSetValues(ZV_pfac,IS_one,IS_one-1,ZS_kfac,INSERT_VALUES,ierr)
+!call VecSetValues(ZV_pfac,IS_one,IS_one,ZS_xfac,INSERT_VALUES,ierr)
+!call VecAssemblyBegin(ZV_pnorm,ierr)
+!call VecAssemblyEnd(ZV_pnorm,ierr)
+!!set pfac to pfac=(kfac,xfac)
+
+!call VecPointWiseMult(ZV_p,ZV_pfac,ZV_pnorm,ierr)
+!!set p to p=pfac.*pnorm
+
+!-------------------------------------------------------------------------------
+!End of OPTION 2
+!-------------------------------------------------------------------------------
+#endif
+end if
+
+
+!*******************************************************************************
+!End of subroutine
+!*******************************************************************************
+end subroutine rapid_init
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_main.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_main.F90
new file mode 100644
index 00000000..b0d78638
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_main.F90
@@ -0,0 +1,299 @@
+!*******************************************************************************
+!Subroutine - rapid_main
+!*******************************************************************************
+subroutine rapid_main(ITIME,runoff,ii,jj,Qout_nc_file)
+!Purpose:
+!Allows to route water through a river network, and to estimate optimal 
+!parameters using the inverse method 
+!Author: 
+!Cedric H. David, 2008-2015.
+!Peirong Lin, modified starting from June 2014 to satisfy WRF-Hydro needs
+
+use netcdf
+
+!---LPR: added variable use from module Wrapper---------------------
+use hrldas_RAPID_wrapper, only: cnt_rapid_run,rapid_runoff_to_inflow
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   namelist_file,                                              &
+                   Vlat_file,Qfor_file,Qhum_file,                              &
+                   Qout_file,                                                  &
+                   IS_M,JS_M,JS_RpM,IS_RpM,IS_RpF,IS_RpH,                      &
+                   ZS_TauR,                                                    &
+                   ZV_pnorm,                                                   &
+                   ZV_C1,ZV_C2,ZV_C3,                                          &
+                   ZV_Qext,ZV_Qfor,ZV_Qlat,ZV_Qhum,ZV_Qdam,                    &
+                   ZV_Vlat,                                                    &
+                   ZV_QoutR,ZV_QoutinitR,ZV_QoutbarR,                          &
+                   ZV_VR,ZV_VinitR,ZV_VbarR,                                   &
+                   ZS_phi,                                                     &
+                   ierr,rank,stage,temp_char,temp_char2,                       &
+                   ZS_one,                                                     &
+                   IS_riv_tot,IS_riv_bas,IS_for_bas,IS_dam_bas,IS_hum_bas,     &
+                   ZS_time1,ZS_time2,ZS_time3,                                 &
+                   IV_nc_start,IV_nc_count,IV_nc_count2,                       &
+                   BS_opt_for,BS_opt_hum,BS_opt_dam,IS_opt_run
+
+#ifndef NO_TAO
+use rapid_var, only :                                                          &
+                   tao
+#endif
+
+implicit none
+external rapid_phiroutine
+!because the subroutine is called by a function
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/petsclog.h" 
+!PETSc log
+
+#ifndef NO_TAO
+#include "finclude/taosolver.h" 
+!TAO solver
+#endif
+
+integer ITIME
+integer ii,jj
+real,dimension(ii,jj) :: runoff
+real,dimension(ii,jj) :: ZM_runoff
+character(len=100) :: Qout_nc_file  !---LPR: RAPID output file name--
+
+ZM_runoff = runoff  !---LPR: pass runoff calculated by WRF-Hydro to RAPID------
+Qout_file = Qout_nc_file !---LPR: new output filename defined by Wrapper-------
+
+!*******************************************************************************
+!Initialize
+!*******************************************************************************
+!namelist_file='./rapid_namelist' !---LPR: initialize done in Wrapper----------
+!call rapid_init
+
+!*******************************************************************************
+!OPTION 1 - use to calculate flows and volumes and generate output data 
+!*******************************************************************************
+if (IS_opt_run==1) then
+
+!-------------------------------------------------------------------------------
+!Create Qout file
+!-------------------------------------------------------------------------------
+call rapid_create_Qout_file(Qout_file)
+
+!-------------------------------------------------------------------------------
+!Open files          
+!-------------------------------------------------------------------------------
+call rapid_open_Qout_file(Qout_file)
+!---LPR: IMPORTANT uncomment this sentence because runoff is NOT read from Vlat
+!call rapid_open_Vlat_file(Vlat_file)
+!---LPR: IMPORTANT uncomment this sentence because runoff is NOT read from Vlat
+if (BS_opt_for) call rapid_open_Qfor_file(Qfor_file)
+if (BS_opt_hum) call rapid_open_Qhum_file(Qhum_file)
+
+!-------------------------------------------------------------------------------
+!Make sure the vectors potentially used for inflow to dams are initially null
+!-------------------------------------------------------------------------------
+call VecSet(ZV_Qext,0*ZS_one,ierr)                         !Qext=0
+call VecSet(ZV_QoutbarR,0*ZS_one,ierr)                     !QoutbarR=0
+!This should be done by PETSc but just to be safe
+
+!-------------------------------------------------------------------------------
+!Set initial value of Qext from Qout_dam0
+!-------------------------------------------------------------------------------
+if (BS_opt_dam .and. IS_dam_bas>0) then
+     call rapid_set_Qext0                                  !Qext from Qout_dam0
+     !call VecView(ZV_Qext,PETSC_VIEWER_STDOUT_WORLD,ierr)
+end if
+
+!-------------------------------------------------------------------------------
+!Read, compute and write          
+!-------------------------------------------------------------------------------
+!---LPR: IMPORTANT uncomment the next two->defined in RAPID initialization stage
+!call PetscLogStageRegister('Read Comp Write',stage,ierr)
+!call PetscLogStagePush(stage,ierr)
+
+ZS_time3=0
+
+IV_nc_start=(/1,1/)
+IV_nc_count=(/IS_riv_tot,1/)
+IV_nc_count2=(/IS_riv_bas,1/)
+
+!---LPR uncomment this because loop is done within WRF-Hydro call--------------
+!do JS_M=1,IS_M
+!do JS_RpM=1,IS_RpM
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Read/set surface and subsurface volumes 
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!call rapid_read_Vlat_file  !---LPR: do not read Vlat file, but get Vlat from WRF-Hydro
+
+!---LPR: IMPORTANT new subroutine added in the Wrapper-----------------
+call rapid_runoff_to_inflow(ZM_runoff,ZV_Vlat,cnt_rapid_run) 
+!---LPR: IMPORTANT new subroutine added in the Wrapper-----------------
+
+call VecCopy(ZV_Vlat,ZV_Qlat,ierr)            !Qlat=Vlat
+call VecScale(ZV_Qlat,1/ZS_TauR,ierr)         !Qlat=Qlat/TauR
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Read/set upstream forcing
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+if (BS_opt_for .and. IS_for_bas>0                                              &
+                   .and. mod((JS_M-1)*IS_RpM+JS_RpM,IS_RpF)==1) then
+
+call rapid_read_Qfor_file
+
+end if 
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Run dam model based on previous values of QoutbarR and Qext to get Qdam
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+if (BS_opt_dam .and. IS_dam_bas>0) then
+
+call rapid_get_Qdam
+
+end if
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Read/set human induced flows 
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+if (BS_opt_hum .and. IS_hum_bas>0                                              &
+                   .and. mod((JS_M-1)*IS_RpM+JS_RpM,IS_RpH)==1) then
+
+call rapid_read_Qhum_file
+
+end if 
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!calculation of Qext
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+call VecCopy(ZV_Qlat,ZV_Qext,ierr)                            !Qext=Qlat
+if (BS_opt_for) call VecAXPY(ZV_Qext,ZS_one,ZV_Qfor,ierr)     !Qext=Qext+1*Qfor
+if (BS_opt_dam) call VecAXPY(ZV_Qext,ZS_one,ZV_Qdam,ierr)     !Qext=Qext+1*Qdam
+if (BS_opt_hum) call VecAXPY(ZV_Qext,ZS_one,ZV_Qhum,ierr)     !Qext=Qext+1*Qhum
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Routing procedure
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+call PetscTime(ZS_time1,ierr)
+call rapid_routing(ZV_C1,ZV_C2,ZV_C3,ZV_Qext,                                  &
+                   ZV_QoutinitR,ZV_VinitR,                                     &
+                   ZV_QoutR,ZV_QoutbarR,ZV_VR,ZV_VbarR)
+call PetscTime(ZS_time2,ierr)
+ZS_time3=ZS_time3+ZS_time2-ZS_time1
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Update variables
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+call VecCopy(ZV_QoutR,ZV_QoutinitR,ierr)
+call VecCopy(ZV_VR,ZV_VinitR,ierr)
+     
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!write outputs         
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+call rapid_write_Qout_file
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Update netCDF location         
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+if (rank==0) IV_nc_start(2)=IV_nc_start(2)+1
+!do not comment out if writing directly from the routing subroutine
+
+!end do
+!end do  !---LPR uncomment because loop if done in WRF-Hydro
+
+!-------------------------------------------------------------------------------
+!Performance statistics
+!-------------------------------------------------------------------------------
+call PetscPrintf(PETSC_COMM_WORLD,'Cumulative time for routing only'           &
+                                  //char(10),ierr)
+write(temp_char ,'(i10)')   rank
+write(temp_char2,'(f10.2)') ZS_time3
+call PetscSynchronizedPrintf(PETSC_COMM_WORLD,'Rank     :'//temp_char //', '// &
+                                              'Time     :'//temp_char2//       &
+                                               char(10),ierr)
+call PetscSynchronizedFlush(PETSC_COMM_WORLD,ierr)
+!---LPR: uncomment sentence below to avoid potential PETSC Stack Empty error-----
+!call PetscLogStagePop(ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'Output data created'//char(10),ierr)
+
+!-------------------------------------------------------------------------------
+!Close files          
+!-------------------------------------------------------------------------------
+call rapid_close_Qout_file
+!---LPR: IMPORTANT uncomment setence below-------
+!call rapid_close_Vlat_file
+if (BS_opt_for) call rapid_close_Qfor_file(Qfor_file)
+if (BS_opt_hum) call rapid_close_Qhum_file(Qhum_file)
+
+
+!-------------------------------------------------------------------------------
+!End of OPTION 1
+!-------------------------------------------------------------------------------
+end if
+
+
+!*******************************************************************************
+!OPTION 2 - Optimization 
+!*******************************************************************************
+if (IS_opt_run==2) then
+#ifndef NO_TAO
+
+!-------------------------------------------------------------------------------
+!Only one computation of phi - For testing purposes only
+!-------------------------------------------------------------------------------
+!call PetscLogStageRegister('One comp of phi',stage,ierr)
+!call PetscLogStagePush(stage,ierr)
+!!do JS_M=1,5
+!call rapid_phiroutine(tao,ZV_pnorm,ZS_phi,PETSC_NULL,ierr)
+!!enddo
+!call PetscLogStagePop(ierr)
+
+!-------------------------------------------------------------------------------
+!Optimization procedure
+!-------------------------------------------------------------------------------
+call PetscLogStageRegister('Optimization   ',stage,ierr)
+call PetscLogStagePush(stage,ierr)
+call TaoSetObjectiveRoutine(tao,rapid_phiroutine,PETSC_NULL_OBJECT,ierr)
+call TaoSetInitialVector(tao,ZV_pnorm,ierr)
+call TaoSetTolerances(tao,1.0d-4,1.0d-4,PETSC_NULL_OBJECT,PETSC_NULL_OBJECT,   &
+                      PETSC_NULL_OBJECT,ierr)
+call TaoSolve(tao,ierr)
+
+call TaoView(tao,PETSC_VIEWER_STDOUT_WORLD,ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'final normalized p=(k,x)'//char(10),ierr)
+call VecView(ZV_pnorm,PETSC_VIEWER_STDOUT_WORLD,ierr)
+call PetscLogStagePop(ierr)
+
+!-------------------------------------------------------------------------------
+!End of OPTION 2
+!-------------------------------------------------------------------------------
+#else
+if (rank==0)                                         print '(a70)',            &
+        'ERROR: The optimization mode requires RAPID to be compiled with TAO   '
+#endif
+end if
+
+
+!*******************************************************************************
+!Finalize
+!*******************************************************************************
+!call rapid_final !---LPR: no need to finalize, write RAPID output each time step
+
+!*******************************************************************************
+!End
+!*******************************************************************************
+end subroutine rapid_main
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_namelist b/wrfv2_fire/hydro/Rapid_routing/rapid_namelist
new file mode 100644
index 00000000..fdc66821
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_namelist
@@ -0,0 +1,109 @@
+&NL_namelist
+!*******************************************************************************
+!Runtime options 
+!*******************************************************************************
+BS_opt_Qinit       =.false.
+!.false. --> no initialization       .true. --> initialization
+
+BS_opt_forcing     =.false.
+!.false. --> no forcing              .true. --> forcing
+
+IS_opt_routing     =1
+!1       --> matrix-based Muskingum  2      --> traditional Muskingum
+
+IS_opt_run         =1
+!1       --> regular run             2      --> parameter optimization
+
+IS_opt_phi         =1
+!1       --> phi1                    2      --> phi2
+
+!*******************************************************************************
+!Temporal information
+!*******************************************************************************
+ZS_TauM=252460800
+!315619200 !3600*24*3652days NASA-project !San-Gua 2004-2007 Case!3600*24*1460=126144000
+!3600*24*4527
+!ZS_TauM=26092800 !Texas 2013.12.03-2014.09.30 Case, lpr 2014-03-12
+!3600*24*302
+!ZS_dtM=86400
+
+!modified on 2014/04/03
+!3600*24=86400
+ZS_dtM=86400
+!3600*3=10800
+
+
+ZS_TauO=315532800      !15724800
+!3600*24*182=15724800
+ZS_dtO=86400
+!ZS_dtO=10800
+!3600*24=86400
+
+ZS_TauR=10800
+!3600*3=10800
+ZS_dtR=900
+
+!*******************************************************************************
+!Domain in which input data is available
+!*******************************************************************************
+IS_reachtot        =68143 !for Texas; 5175 for San-Gua
+modcou_connect_file='./forecast_input_tx/rapid_connect_Reg12.csv'
+IS_max_up          =4
+m3_nc_file         ='./forecast_input_tx/m3_riv_2000_2007_NoahMP_Texas.nc'
+
+!*******************************************************************************
+!Domain in which model runs
+!*******************************************************************************
+IS_reachbas        =68143 !5175
+basin_id_file      ='./forecast_input_tx/basin_id_Reg12_hydroseq.csv'
+
+!*******************************************************************************
+!Initialization
+!*******************************************************************************
+Qinit_file         =''
+
+!*******************************************************************************
+!Available forcing data
+!*******************************************************************************
+!IS_forcingtot      =3
+!forcingtot_id_file ='./input_San_Guad/forcingtot_id_dam_springs.csv'
+!Qfor_file          ='./input_San_Guad/Qfor_dam_springs_2004_2007.csv'     
+
+!*******************************************************************************
+!Forcing data used as model runs
+!*******************************************************************************
+!IS_forcinguse      =3
+!forcinguse_id_file ='./input_San_Guad/forcinguse_id_dam_springs.csv'
+
+!*******************************************************************************
+!Regular model run
+!*******************************************************************************
+k_file             ='./forecast_input_tx/k_Reg12_Noah_MP_pb0.csv'
+x_file             ='./forecast_input_tx/x_Reg12_Noah_MP_pb0.csv'
+Qout_nc_file       ='./output_forecast_tx/Texas.2000.2007.NoahMP.Calibed.nc'
+
+!*******************************************************************************
+!Optimization
+!*******************************************************************************
+!ZS_phifac          =0.001
+!------------------------------------------------------------------------------
+!Routing parameters
+!------------------------------------------------------------------------------
+!kfac_file          ='./input_tx_noahmp_00_12_opt/kfac_TX_1km_hour.csv'   
+!xfac_file          ='' 
+!ZS_knorm_init      =4 
+!ZS_xnorm_init      =1
+!------------------------------------------------------------------------------
+!Gage observations
+!------------------------------------------------------------------------------
+!IS_gagetot         =248
+!gagetot_id_file    ='./input_tx_noahmp_00_12_opt/gage_id_Reg12_2000_2007_full.csv'
+!Qobs_file          ='./input_tx_noahmp_00_12_opt/Qobs_Reg12_2000_2007_full.csv'
+!Qobsbarrec_file    =''     
+!IS_gageuse         =248
+!gageuse_id_file    ='./input_tx_noahmp_00_12_opt/gage_id_Reg12_2000_2007_full.csv'
+!IS_strt_opt        =1
+!*******************************************************************************
+!End name list
+!*******************************************************************************
+/
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat.F90
new file mode 100644
index 00000000..61a9ec19
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat.F90
@@ -0,0 +1,331 @@
+!*******************************************************************************
+!Subroutine - rapid_net_mat
+!*******************************************************************************
+subroutine rapid_net_mat
+
+!Purpose:
+!This creates a sparse network matrix.  "1" is recorded at Net(i,j) if the reach 
+!in column j flows into the reach in line i. If some connections are missing
+!between the subbasin and the entire domain, gives warnings.  
+!A transboundary matrix is also created whose elements in the diagonal blocks 
+!are all null and the elements in the off-diagonal blocks are equal to those of 
+!the network matrix. 
+!Author: 
+!Cedric H. David, 2008-2015.
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   IS_riv_tot,IS_riv_bas,                                      &
+                   JS_riv_tot,JS_riv_bas,JS_riv_bas2,                          &
+                   IV_riv_bas_id,IV_riv_index,ZM_hsh_bas,                      &
+                   ZM_Net,ZM_A,ZM_T,ZM_TC1,BS_logical,IV_riv_tot_id,           &
+                   IV_down,IV_nbup,IM_up,JS_up,IM_index_up,                    &
+                   ierr,rank,ZS_val,                                           &
+                   IS_one,ZS_one,temp_char,IV_nz,IV_dnz,IV_onz,                &
+                   IS_ownfirst,IS_ownlast,IS_opt_routing
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+
+
+!*******************************************************************************
+!Prepare for matrix preallocation
+!*******************************************************************************
+IS_ownfirst=0
+IS_ownlast=0
+do JS_riv_bas=1,IS_riv_bas
+     IV_nz(JS_riv_bas)=0
+     IV_dnz(JS_riv_bas)=0
+     IV_onz(JS_riv_bas)=0
+end do
+!Initialize to zero
+
+call MatGetOwnershipRange(ZM_Net,IS_ownfirst,IS_ownlast,ierr)
+
+do JS_riv_bas2=1,IS_riv_bas
+do JS_up=1,IV_nbup(IV_riv_index(JS_riv_bas2))
+if (IM_index_up(JS_riv_bas2,JS_up)/=0) then
+
+     JS_riv_bas=IM_index_up(JS_riv_bas2,JS_up)
+     !Here JS_riv_bas is determined upstream of JS_riv_bas2
+     !both IS_riv_bas2 and IS_riv_bas are used here because the location
+     !of nonzeros depends on row and column in an parallel matrix
+     
+     IV_nz(JS_riv_bas2)=IV_nz(JS_riv_bas2)+1 
+     !The size of IV_nz is IS_riv_bas, IV_nz is the same across computing cores
+
+     if ((JS_riv_bas >=IS_ownfirst+1 .and.  JS_riv_bas< IS_ownlast+1) .and.    &
+         (JS_riv_bas2>=IS_ownfirst+1 .and. JS_riv_bas2< IS_ownlast+1)) then
+          IV_dnz(JS_riv_bas2)=IV_dnz(JS_riv_bas2)+1 
+     end if
+     if ((JS_riv_bas < IS_ownfirst+1 .or.  JS_riv_bas >=IS_ownlast+1) .and.    &
+         (JS_riv_bas2>=IS_ownfirst+1 .and. JS_riv_bas2< IS_ownlast+1)) then
+          IV_onz(JS_riv_bas2)=IV_onz(JS_riv_bas2)+1 
+     end if
+     !The size of IV_dnz and of IV_onz is IS_riv_bas. The values of IV_dnz and 
+     !IV_onz are not the same across computing cores.  For each core, the  
+     !only the values located in the range (IS_ownfirst+1:IS_ownlast) are 
+     !correct but only these are used in the preallocation below.
+
+end if
+end do
+end do
+
+!print *, 'rank', rank, 'IV_nz(:)' , IV_nz(:)
+!print *, 'rank', rank, 'IV_dnz(:)', IV_dnz(:)
+!print *, 'rank', rank, 'IV_onz(:)', IV_onz(:)
+
+
+!*******************************************************************************
+!Matrix preallocation
+!*******************************************************************************
+!call MatSeqAIJSetPreallocation(ZM_Net,3*IS_one,PETSC_NULL_INTEGER,ierr)
+!call MatMPIAIJSetPreallocation(ZM_Net,3*IS_one,PETSC_NULL_INTEGER,2*IS_one,    &
+!                               PETSC_NULL_INTEGER,ierr)
+!call MatSeqAIJSetPreallocation(ZM_A,4*IS_one,PETSC_NULL_INTEGER,ierr)
+!call MatMPIAIJSetPreallocation(ZM_A,4*IS_one,PETSC_NULL_INTEGER,2*IS_one,      &
+!                               PETSC_NULL_INTEGER,ierr)
+!call MatSeqAIJSetPreallocation(ZM_T,4*IS_one,PETSC_NULL_INTEGER,ierr)
+!call MatMPIAIJSetPreallocation(ZM_T,4*IS_one,PETSC_NULL_INTEGER,2*IS_one,      &
+!                               PETSC_NULL_INTEGER,ierr)
+!call MatSeqAIJSetPreallocation(ZM_TC1,4*IS_one,PETSC_NULL_INTEGER,ierr)
+!call MatMPIAIJSetPreallocation(ZM_TC1,4*IS_one,PETSC_NULL_INTEGER,2*IS_one,    &
+!                               PETSC_NULL_INTEGER,ierr)
+!Very basic preallocation assuming no more than 3 upstream elements anywhere
+!Not used here because proper preallocation is done below
+
+call MatSeqAIJSetPreallocation(ZM_Net,PETSC_NULL_INTEGER,IV_nz,ierr)
+call MatMPIAIJSetPreallocation(ZM_Net,                                         &
+                               PETSC_NULL_INTEGER,                             &
+                               IV_dnz(IS_ownfirst+1:IS_ownlast),               &
+                               PETSC_NULL_INTEGER,                             &
+                               IV_onz(IS_ownfirst+1:IS_ownlast),ierr)
+call MatSeqAIJSetPreallocation(ZM_A,PETSC_NULL_INTEGER,IV_nz+1,ierr)
+call MatMPIAIJSetPreallocation(ZM_A,                                           &
+                               PETSC_NULL_INTEGER,                             &
+                               IV_dnz(IS_ownfirst+1:IS_ownlast)+1,             &
+                               PETSC_NULL_INTEGER,                             &
+                               IV_onz(IS_ownfirst+1:IS_ownlast),ierr)
+call MatSeqAIJSetPreallocation(ZM_T,PETSC_NULL_INTEGER,0*IV_nz,ierr)
+call MatMPIAIJSetPreallocation(ZM_T,                                           &
+                               PETSC_NULL_INTEGER,                             &
+                               0*IV_dnz(IS_ownfirst+1:IS_ownlast),             &
+                               PETSC_NULL_INTEGER,                             &
+                               IV_onz(IS_ownfirst+1:IS_ownlast),ierr)
+call MatSeqAIJSetPreallocation(ZM_TC1,PETSC_NULL_INTEGER,0*IV_nz,ierr)
+call MatMPIAIJSetPreallocation(ZM_TC1,                                         &
+                               PETSC_NULL_INTEGER,                             &
+                               0*IV_dnz(IS_ownfirst+1:IS_ownlast),             &
+                               PETSC_NULL_INTEGER,                             &
+                               IV_onz(IS_ownfirst+1:IS_ownlast),ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'Network matrix preallocated'//char(10),ierr)
+
+
+!*******************************************************************************
+!Creates network matrix
+!*******************************************************************************
+if (rank==0) then
+!only first processor sets values
+
+do JS_riv_bas2=1,IS_riv_bas
+do JS_up=1,IV_nbup(IV_riv_index(JS_riv_bas2))
+if (IM_index_up(JS_riv_bas2,JS_up)/=0) then
+
+     JS_riv_bas=IM_index_up(JS_riv_bas2,JS_up)
+     !Here JS_riv_bas is determined upstream of JS_riv_bas2
+     !both IS_riv_bas2 and IS_riv_bas are used here because the location
+     !of nonzeros depends on row and column in a parallel matrix
+
+     call MatSetValues(ZM_Net,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1,        &
+                       ZS_one,INSERT_VALUES,ierr)
+     CHKERRQ(ierr)
+     !Actual values used for ZM_Net
+
+     call MatSetValues(ZM_A  ,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1,        &
+                       0*ZS_one,INSERT_VALUES,ierr)
+     CHKERRQ(ierr)
+     !zeros (instead of -C1is) are used here on the off-diagonal of ZM_A because 
+     !C1is are not yet computed, because ZM_A will later be populated based on 
+     !ZM_Net, and because ZM_Net may be later modified for forcing or dams. 
+     !Also when running RAPID in optimization mode, it is necessary to recreate
+     !ZM_A from scratch every time the parameters C1is are updated
+
+end if
+end do
+call MatSetValues(ZM_A  ,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas2-1,            &
+                  0*ZS_one,INSERT_VALUES,ierr)
+CHKERRQ(ierr)
+!zeros (instead of ones) are used on the main diagonal of ZM_A because ZM_A will
+!be diagonally scaled by ZV_C1 before the diagonal is populated by ones.
+end do
+
+end if
+
+call MatAssemblyBegin(ZM_Net,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyEnd(ZM_Net,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyBegin(ZM_A  ,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyEnd(ZM_A  ,MAT_FINAL_ASSEMBLY,ierr)
+!sparse matrices need be assembled once their elements have been filled
+call PetscPrintf(PETSC_COMM_WORLD,'Network matrix created'//char(10),ierr)
+
+
+!*******************************************************************************
+!Creates transboundary matrix
+!*******************************************************************************
+if (IS_opt_routing==3) then
+
+do JS_riv_bas2=1,IS_riv_bas
+do JS_up=1,IV_nbup(IV_riv_index(JS_riv_bas2))
+if (IM_index_up(JS_riv_bas2,JS_up)/=0) then
+
+     JS_riv_bas=IM_index_up(JS_riv_bas2,JS_up)
+     !Here JS_riv_bas is determined upstream of JS_riv_bas2
+     !both IS_riv_bas2 and IS_riv_bas are used here because the location
+     !of nonzeros depends on row and column in a parallel matrix
+
+     if ((JS_riv_bas < IS_ownfirst+1 .or.  JS_riv_bas >=IS_ownlast+1) .and.    &
+         (JS_riv_bas2>=IS_ownfirst+1 .and. JS_riv_bas2< IS_ownlast+1)) then
+
+     call MatSetValues(ZM_T,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1,          &
+                       ZS_one,INSERT_VALUES,ierr)
+     CHKERRQ(ierr)
+     !Actual values (ones) used for ZM_T
+
+     call MatSetValues(ZM_TC1,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1,        &
+                       0*ZS_one,INSERT_VALUES,ierr)
+     CHKERRQ(ierr)
+     !zeros (instead of C1is) are used here everywhere in ZM_TC1 because 
+     !C1is are not yet computed, because ZM_TC1 will later be populated based on 
+     !ZM_T, and because ZM_T may be later modified for forcing or dams. 
+     !Also when running RAPID in optimization mode, it is necessary to recreate
+     !ZM_TC1 from scratch every time the parameters C1is are updated
+
+     end if
+
+end if
+end do
+end do
+
+call MatAssemblyBegin(ZM_T,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyEnd(ZM_T,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyBegin(ZM_TC1,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyEnd(ZM_TC1,MAT_FINAL_ASSEMBLY,ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'Transboundary matrix created'//char(10),ierr)
+
+end if
+
+
+!*******************************************************************************
+!Checks for missing connections and gives warning
+!*******************************************************************************
+do JS_riv_tot=1,IS_riv_tot
+     ZS_val=-999
+     call MatGetValues(ZM_hsh_bas,                                             &
+                       IS_one,rank,                                            &
+                       IS_one,IV_riv_tot_id(JS_riv_tot)-1,                     & 
+                       ZS_val,ierr)
+     CHKERRQ(ierr)
+     JS_riv_bas2=int(ZS_val)
+     if (JS_riv_bas2>0) then
+          !print *, 'Reach ID', IV_riv_tot_id(JS_riv_tot), 'is in basin'
+     else
+          !print *, 'Reach ID', IV_riv_tot_id(JS_riv_tot), 'is not in basin'
+
+!-------------------------------------------------------------------------------
+!Looking for missing upstream connections
+!-------------------------------------------------------------------------------
+ZS_val=-999
+call MatGetValues(ZM_hsh_bas,                                                  &
+                  IS_one,rank,                                                 &
+                  IS_one,IV_down(JS_riv_tot)-1,                                & 
+                  ZS_val,ierr)
+CHKERRQ(ierr)
+JS_riv_bas=int(ZS_val)
+if(JS_riv_bas>0) then
+     write(temp_char,'(i10)') IV_riv_tot_id(JS_riv_tot)
+     call PetscPrintf(PETSC_COMM_WORLD,                                        &
+                      'WARNING: reach ID' // temp_char,ierr)
+     write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas)
+     call PetscPrintf(PETSC_COMM_WORLD,                                        &
+                      ' should be connected upstream of reach ID'              &
+                      // temp_char // char(10),ierr)
+     call PetscPrintf(PETSC_COMM_WORLD,                                        &
+                      '         Make sure upstream forcing is available'       &
+                      // char(10),ierr)
+end if
+!-------------------------------------------------------------------------------
+!Looking for missing upstream connections
+!-------------------------------------------------------------------------------
+do JS_up=1,IV_nbup(JS_riv_tot)
+ZS_val=-999
+call MatGetValues(ZM_hsh_bas,                                                  &
+                  IS_one,rank,                                                 &
+                  IS_one,IM_up(JS_riv_tot,JS_up)-1,                            & 
+                  ZS_val,ierr)
+CHKERRQ(ierr)
+JS_riv_bas=int(ZS_val)
+if (JS_riv_bas>0) then
+     write(temp_char,'(i10)') IV_riv_tot_id(JS_riv_tot)
+     call PetscPrintf(PETSC_COMM_WORLD,                                        &
+                      'WARNING: reach ID' // temp_char,ierr)
+     write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas)
+     call PetscPrintf(PETSC_COMM_WORLD,                                        &
+                      ' should be connected downstream of reach ID'            &
+                      // temp_char // char(10),ierr)
+end if
+end do
+!-------------------------------------------------------------------------------
+!Done looking
+!-------------------------------------------------------------------------------
+
+     end if
+end do
+call PetscPrintf(PETSC_COMM_WORLD,'Checked for missing connections between '// &
+                 'basin studied and rest of domain'//char(10),ierr)
+
+
+!*******************************************************************************
+!Display matrices on stdout
+!*******************************************************************************
+!call PetscPrintf(PETSC_COMM_WORLD,'ZM_Net'//char(10),ierr)
+!call MatView(ZM_Net,PETSC_VIEWER_STDOUT_WORLD,ierr)
+!
+!call PetscPrintf(PETSC_COMM_WORLD,'ZM_A'//char(10),ierr)
+!call MatView(ZM_A,PETSC_VIEWER_STDOUT_WORLD,ierr)
+!
+!if (IS_opt_routing==3) then
+!     call PetscPrintf(PETSC_COMM_WORLD,'ZM_T'//char(10),ierr)
+!     call MatView(ZM_T,PETSC_VIEWER_STDOUT_WORLD,ierr)
+!
+!     call PetscPrintf(PETSC_COMM_WORLD,'ZM_TC1'//char(10),ierr)
+!     call MatView(ZM_TC1,PETSC_VIEWER_STDOUT_WORLD,ierr)
+!end if
+
+
+!*******************************************************************************
+!End
+!*******************************************************************************
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+
+
+end subroutine rapid_net_mat
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat_brk.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat_brk.F90
new file mode 100644
index 00000000..2e3b2719
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_net_mat_brk.F90
@@ -0,0 +1,286 @@
+!*******************************************************************************
+!Subroutine - rapid_net_mat_brk
+!*******************************************************************************
+subroutine rapid_net_mat_brk
+
+!Purpose:
+!This subroutine modifies the network and transboundary matrices based on a list
+!of river IDs. 
+!The connectivity is broken between each given river ID and its downstream 
+!river.
+!Author: 
+!Cedric H. David, 2013-2015. 
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   IS_riv_bas,JS_riv_bas,JS_riv_bas2,                          &
+                   IV_riv_bas_id,IV_riv_index,                                 &
+                   ZM_Net,ZM_T,IV_down,IV_nbup,JS_up,IM_index_up,              &
+                   IS_for_bas,JS_for_bas,IV_for_bas_id,                        &
+                   IS_dam_bas,JS_dam_bas,IV_dam_bas_id,                        &
+                   ierr,rank,                                                  &
+                   IS_one,ZS_one,temp_char,                                    &
+                   IS_ownfirst,IS_ownlast,                                     &
+                   BS_opt_for,BS_opt_dam,IS_opt_routing
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+
+
+!*******************************************************************************
+!If forcing is used
+!*******************************************************************************
+if (BS_opt_for) then
+
+!-------------------------------------------------------------------------------
+!Breaks Net matrix connectivity in case forcing used is inside basin studied
+!-------------------------------------------------------------------------------
+if (IS_for_bas>0) then 
+call PetscPrintf(PETSC_COMM_WORLD,'Modifying network matrix'//char(10),ierr)
+end if
+
+if (rank==0) then
+!only first processor sets values
+do JS_for_bas=1,IS_for_bas
+     do JS_riv_bas=1,IS_riv_bas
+          if (IV_for_bas_id(JS_for_bas)==IV_riv_bas_id(JS_riv_bas)) then
+
+     do JS_riv_bas2=1,IS_riv_bas
+          if (IV_down(IV_riv_index(JS_riv_bas))==IV_riv_bas_id(JS_riv_bas2))then
+          !here JS_riv_bas2 is determined as directly downstream of JS_riv_bas
+          !and the connection between both needs be broken
+
+          call MatSetValues(ZM_Net,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1,   &
+                            0*ZS_one,INSERT_VALUES,ierr)
+          CHKERRQ(ierr)
+          !Breaks connection for matrix-based Muskingum method
+
+          do JS_up=1,IV_nbup(IV_riv_index(JS_riv_bas2))
+               if (IM_index_up(JS_riv_bas2,JS_up)==JS_riv_bas) then
+                    IM_index_up(JS_riv_bas2,JS_up)=0
+               end if
+          end do
+          !Breaks connection for traditional Muskingum method
+
+          write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas)
+          call PetscPrintf(PETSC_COMM_WORLD,                                   &
+                           '         connection broken downstream of reach ID' &
+                            // temp_char,ierr)
+          write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas2)
+          call PetscPrintf(PETSC_COMM_WORLD,                                   &
+                           ' forcing data will be used for reach ID'           &
+                           // temp_char // char(10),ierr)
+          !Writes information on connection that was just broken in stdout
+
+          end if
+     end do 
+
+          end if
+     end do
+end do
+end if
+call MatAssemblyBegin(ZM_Net,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyEnd(ZM_Net,MAT_FINAL_ASSEMBLY,ierr)
+!!sparse matrices need be assembled once their elements have been filled
+call PetscPrintf(PETSC_COMM_WORLD,'Network matrix modified for forcing'//      &
+                 char(10),ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+
+!-------------------------------------------------------------------------------
+!Breaks T matrix connectivity in case forcing is used inside basin studied
+!-------------------------------------------------------------------------------
+if (IS_opt_routing==3) then
+
+if (IS_for_bas>0) then 
+call PetscPrintf(PETSC_COMM_WORLD,'Modifying transboundary matrix'//           &
+                 char(10),ierr)
+end if
+
+do JS_for_bas=1,IS_for_bas
+     do JS_riv_bas=1,IS_riv_bas
+          if (IV_for_bas_id(JS_for_bas)==IV_riv_bas_id(JS_riv_bas)) then
+
+     do JS_riv_bas2=1,IS_riv_bas
+          if (IV_down(IV_riv_index(JS_riv_bas))==IV_riv_bas_id(JS_riv_bas2))then
+          !here JS_riv_bas2 is determined as directly downstream of JS_riv_bas
+          !and the connection between both needs be broken
+
+if ((JS_riv_bas < IS_ownfirst+1 .or.  JS_riv_bas >=IS_ownlast+1) .and.         &
+    (JS_riv_bas2>=IS_ownfirst+1 .and. JS_riv_bas2< IS_ownlast+1)) then
+
+     call MatSetValues(ZM_T,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1,          &
+                       0*ZS_one,INSERT_VALUES,ierr)
+     CHKERRQ(ierr)
+     !Breaks connection of transboundary matrix
+
+end if
+
+          end if
+     end do 
+
+          end if
+     end do
+end do
+call MatAssemblyBegin(ZM_T,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyEnd(ZM_T,MAT_FINAL_ASSEMBLY,ierr)
+!!sparse matrices need be assembled once their elements have been filled
+call PetscPrintf(PETSC_COMM_WORLD,'Transboundary matrix modified for forcing'//&
+                 char(10),ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+
+end if
+
+!-------------------------------------------------------------------------------
+!End if forcing is used
+!-------------------------------------------------------------------------------
+end if
+
+
+!*******************************************************************************
+!If dam model is used
+!*******************************************************************************
+if (BS_opt_dam) then
+
+!-------------------------------------------------------------------------------
+!Breaks matrix connectivity in case dam model is used inside basin studied
+!-------------------------------------------------------------------------------
+if (IS_dam_bas>0) then 
+call PetscPrintf(PETSC_COMM_WORLD,'Modifying network matrix'//char(10),ierr)
+end if
+
+if (rank==0) then
+!only first processor sets values
+do JS_dam_bas=1,IS_dam_bas
+     do JS_riv_bas=1,IS_riv_bas
+          if (IV_dam_bas_id(JS_dam_bas)==IV_riv_bas_id(JS_riv_bas)) then
+
+     do JS_riv_bas2=1,IS_riv_bas
+          if (IV_down(IV_riv_index(JS_riv_bas))==IV_riv_bas_id(JS_riv_bas2))then
+          !here JS_riv_bas2 is determined as directly downstream of JS_riv_bas
+          !and the connection between both needs be broken
+
+          call MatSetValues(ZM_Net,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1,   &
+                            0*ZS_one,INSERT_VALUES,ierr)
+          CHKERRQ(ierr)
+          !Breaks connection for matrix-based Muskingum method
+
+          do JS_up=1,IV_nbup(IV_riv_index(JS_riv_bas2))
+               if (IM_index_up(JS_riv_bas2,JS_up)==JS_riv_bas) then
+                    IM_index_up(JS_riv_bas2,JS_up)=0
+               end if
+          end do
+          !Breaks connection for traditional Muskingum method
+
+          
+          write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas)
+          call PetscPrintf(PETSC_COMM_WORLD,                                   &
+                           '         connection broken downstream of reach ID' &
+                            // temp_char,ierr)
+          write(temp_char,'(i10)') IV_riv_bas_id(JS_riv_bas2)
+          call PetscPrintf(PETSC_COMM_WORLD,                                   &
+                           ' dam data will be used for reach ID'           &
+                           // temp_char // char(10),ierr)
+          !Writes information on connection that was just broken in stdout
+
+          end if
+     end do 
+
+          end if
+     end do
+end do
+end if
+call MatAssemblyBegin(ZM_Net,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyEnd(ZM_Net,MAT_FINAL_ASSEMBLY,ierr)
+!sparse matrices need be assembled once their elements have been filled
+call PetscPrintf(PETSC_COMM_WORLD,'Network matrix modified for dams'//         &
+                 char(10),ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+
+!-------------------------------------------------------------------------------
+!Breaks T matrix connectivity in case dam model is used inside basin studied
+!-------------------------------------------------------------------------------
+if (IS_opt_routing==3) then
+
+if (IS_dam_bas>0) then 
+call PetscPrintf(PETSC_COMM_WORLD,'Modifying transboundary matrix'//           &
+                 char(10),ierr)
+end if
+
+do JS_dam_bas=1,IS_dam_bas
+     do JS_riv_bas=1,IS_riv_bas
+          if (IV_dam_bas_id(JS_dam_bas)==IV_riv_bas_id(JS_riv_bas)) then
+
+     do JS_riv_bas2=1,IS_riv_bas
+          if (IV_down(IV_riv_index(JS_riv_bas))==IV_riv_bas_id(JS_riv_bas2))then
+          !here JS_riv_bas2 is determined as directly downstream of JS_riv_bas
+          !and the connection between both needs be broken
+
+if ((JS_riv_bas < IS_ownfirst+1 .or.  JS_riv_bas >=IS_ownlast+1) .and.         &
+    (JS_riv_bas2>=IS_ownfirst+1 .and. JS_riv_bas2< IS_ownlast+1)) then
+
+     call MatSetValues(ZM_T,IS_one,JS_riv_bas2-1,IS_one,JS_riv_bas-1,          &
+                       0*ZS_one,INSERT_VALUES,ierr)
+     CHKERRQ(ierr)
+     !Breaks connection of transboundary matrix
+
+end if
+
+          end if
+     end do 
+
+          end if
+     end do
+end do
+call MatAssemblyBegin(ZM_T,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyEnd(ZM_T,MAT_FINAL_ASSEMBLY,ierr)
+!!sparse matrices need be assembled once their elements have been filled
+call PetscPrintf(PETSC_COMM_WORLD,'Transboundary matrix modified for dams'//   &
+                 char(10),ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+
+end if
+
+!-------------------------------------------------------------------------------
+!End if dam model is used
+!-------------------------------------------------------------------------------
+end if
+
+
+!*******************************************************************************
+!Display matrix on stdout
+!*******************************************************************************
+!call PetscPrintf(PETSC_COMM_WORLD,'ZM_Net'//char(10),ierr)
+!call MatView(ZM_Net,PETSC_VIEWER_STDOUT_WORLD,ierr)
+!
+!if (IS_opt_routing==3) then
+!     call PetscPrintf(PETSC_COMM_WORLD,'ZM_T'//char(10),ierr)
+!     call MatView(ZM_T,PETSC_VIEWER_STDOUT_WORLD,ierr)
+!end if
+
+
+!*******************************************************************************
+!End
+!*******************************************************************************
+
+
+end subroutine rapid_net_mat_brk
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_obs_mat.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_obs_mat.F90
new file mode 100644
index 00000000..4c6b7f0b
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_obs_mat.F90
@@ -0,0 +1,106 @@
+!*******************************************************************************
+!Subroutine - rapid_obs_mat
+!*******************************************************************************
+subroutine rapid_obs_mat
+
+!Purpose:
+!Creates a kronecker-type diagonal sparse matrix.  "1" is recorded at the row 
+!and column where observations are available.  
+!Author: 
+!Cedric H. David, 2008-2015. 
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   IS_riv_bas,JS_riv_bas,                                      &
+                   IS_obs_bas,JS_obs_bas,                                      &
+                   IV_riv_bas_id,IV_obs_tot_id,                                & 
+                   IV_obs_index,                                               &
+                   ZM_Obs,ZS_norm,                                             &
+                   ierr,                                                       &
+                   IS_one,ZS_one,temp_char   
+
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+
+
+!*******************************************************************************
+!Preallocation of the observation matrix
+!*******************************************************************************
+call MatSeqAIJSetPreallocation(ZM_Obs,1*IS_one,PETSC_NULL_INTEGER,ierr)
+call MatMPIAIJSetPreallocation(ZM_Obs,1*IS_one,PETSC_NULL_INTEGER,0*IS_one,    &
+                               PETSC_NULL_INTEGER,ierr)
+!Very basic preallocation assuming that all reaches have one gage.  Cannot use
+!IV_obs_loc1 for preallocation because it is of size IS_obs_bas and not 
+!IS_riv_bas. To do a better preallocation one needs to count the diagonal 
+!elements in a new vector
+
+!call PetscPrintf(PETSC_COMM_WORLD,'Observation matrix preallocated'//char(10), &
+!                 ierr)
+
+
+!*******************************************************************************
+!Creation of the observation matrix
+!*******************************************************************************
+do JS_riv_bas=1,IS_riv_bas
+     do JS_obs_bas=1,IS_obs_bas
+
+if (IV_obs_tot_id(IV_obs_index(JS_obs_bas))==IV_riv_bas_id(JS_riv_bas)) then
+          call MatSetValues(ZM_Obs,IS_one,JS_riv_bas-1,IS_one,JS_riv_bas-1,    &
+                            ZS_one,INSERT_VALUES,ierr)
+end if
+
+     enddo 
+enddo
+
+call MatAssemblyBegin(ZM_Obs,MAT_FINAL_ASSEMBLY,ierr)
+call MatAssemblyEnd(ZM_Obs,MAT_FINAL_ASSEMBLY,ierr)
+!sparse matrices need be assembled once their elements have been filled
+
+
+!*******************************************************************************
+!Optional: calculation of number of gaging stations used in subbasin
+!*******************************************************************************
+call MatNorm(ZM_Obs,NORM_FROBENIUS,ZS_norm,ierr)
+ZS_norm=ZS_norm*ZS_norm
+write(temp_char,'(f10.1)') ZS_norm
+call PetscPrintf(PETSC_COMM_WORLD,'Number of gage IDs in '           //        &
+                 'this simulation (based on norm):' // temp_char // char(10),  &
+                 ierr)
+
+
+!*******************************************************************************
+!Display matrix on stdout
+!*******************************************************************************
+!call PetscPrintf(PETSC_COMM_WORLD,'ZM_Obs:'//char(10),ierr)
+!call MatView(ZM_Obs,PETSC_VIEWER_STDOUT_WORLD,ierr)
+
+
+!*******************************************************************************
+!End
+!*******************************************************************************
+call PetscPrintf(PETSC_COMM_WORLD,'Observation matrix created'//char(10),ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+
+
+end subroutine rapid_obs_mat
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qfor_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qfor_file.F90
new file mode 100644
index 00000000..e95db532
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qfor_file.F90
@@ -0,0 +1,43 @@
+!*******************************************************************************
+!Subroutine - rapid_open_Qfor
+!*******************************************************************************
+subroutine rapid_open_Qfor_file(Qfor_file) 
+
+!Purpose:
+!Open Qfor_file from Fortran.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   rank
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+character(len=100), intent(in):: Qfor_file
+
+
+!*******************************************************************************
+!Open file
+!*******************************************************************************
+if (rank==0) open(34,file=Qfor_file,status='old')
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_open_Qfor_file
+
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qhum_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qhum_file.F90
new file mode 100644
index 00000000..9d418086
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qhum_file.F90
@@ -0,0 +1,43 @@
+!*******************************************************************************
+!Subroutine - rapid_open_Qhum
+!*******************************************************************************
+subroutine rapid_open_Qhum_file(Qhum_file) 
+
+!Purpose:
+!Open Qhum_file from Fortran.
+!Author: 
+!Cedric H. David, 2014-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   rank
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+character(len=100), intent(in):: Qhum_file
+
+
+!*******************************************************************************
+!Open file
+!*******************************************************************************
+if (rank==0) open(36,file=Qhum_file,status='old')
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_open_Qhum_file
+
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qobs_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qobs_file.F90
new file mode 100644
index 00000000..97bd509b
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qobs_file.F90
@@ -0,0 +1,43 @@
+!*******************************************************************************
+!Subroutine - rapid_open_Qobs
+!*******************************************************************************
+subroutine rapid_open_Qobs_file(Qobs_file) 
+
+!Purpose:
+!Open Qobs_file from Fortran.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   rank
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+character(len=100), intent(in):: Qobs_file
+
+
+!*******************************************************************************
+!Open file
+!*******************************************************************************
+if (rank==0) open(33,file=Qobs_file,status='old')
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_open_Qobs_file
+
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qout_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qout_file.F90
new file mode 100644
index 00000000..00736f72
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Qout_file.F90
@@ -0,0 +1,50 @@
+!*******************************************************************************
+!Subroutine - rapid_open_Qout_file
+!*******************************************************************************
+subroutine rapid_open_Qout_file(Qout_file) 
+
+!Purpose:
+!Open Qout_file from Fortran/netCDF.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use netcdf
+use rapid_var, only :                                                          &
+                   rank,IS_nc_status,IS_nc_id_fil_Qout,IS_nc_id_var_Qout
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+character(len=100), intent(in):: Qout_file
+
+
+!*******************************************************************************
+!Open file
+!*******************************************************************************
+if (rank==0) then 
+     close(99)
+     open(99,file=Qout_file,status='old')
+     close(99)
+     IS_nc_status=NF90_OPEN(Qout_file,NF90_WRITE,IS_nc_id_fil_Qout)
+     IS_nc_status=NF90_INQ_VARID(IS_nc_id_fil_Qout,'Qout',IS_nc_id_var_Qout)
+end if
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_open_Qout_file
+
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_open_Vlat_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Vlat_file.F90
new file mode 100644
index 00000000..fbe06485
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_open_Vlat_file.F90
@@ -0,0 +1,49 @@
+!*******************************************************************************
+!Subroutine - rapid_open_Vlat_file
+!*******************************************************************************
+subroutine rapid_open_Vlat_file(Vlat_file) 
+
+!Purpose:
+!Open Vlat_file from Fortran/netCDF.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use netcdf
+use rapid_var, only :                                                          &
+                   rank,IS_nc_status,IS_nc_id_fil_Vlat,IS_nc_id_var_Vlat
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+character(len=100), intent(in):: Vlat_file
+
+
+!*******************************************************************************
+!Open file
+!*******************************************************************************
+if (rank==0) then 
+     open(99,file=Vlat_file,status='old')
+     close(99)
+     IS_nc_status=NF90_OPEN(Vlat_file,NF90_NOWRITE,IS_nc_id_fil_Vlat)
+     IS_nc_status=NF90_INQ_VARID(IS_nc_id_fil_Vlat,'m3_riv',IS_nc_id_var_Vlat)
+end if
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_open_Vlat_file
+
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_phiroutine.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_phiroutine.F90
new file mode 100644
index 00000000..d2f1a159
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_phiroutine.F90
@@ -0,0 +1,277 @@
+!*******************************************************************************
+!Subroutine - rapid_phiroutine
+!*******************************************************************************
+#ifndef NO_TAO
+subroutine rapid_phiroutine(tao,ZV_pnorm,ZS_phi,IS_dummy,ierr)
+
+!Purpose:
+!Calculates a cost function phi as a function of model parameters, using means
+!over a given period of time.  The cost function represents the square error
+!between calculated flows and observed flows where observations are available.
+!Author: 
+!Cedric H. David, 2008-2015. 
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   Vlat_file,Qobs_file,Qfor_file,Qhum_file,                    &
+                   JS_O,IS_O,JS_RpO,IS_RpO,ZS_TauR,IS_RpF,IS_RpH,              &
+                   ZM_Obs,ZV_Qobs,                                             &
+                   ZV_temp1,ZV_temp2,ZS_phitemp,ZS_phifac,ZV_kfac,             &
+                   IS_riv_tot,IS_for_bas,IS_hum_bas,                           &
+                   ZS_knorm,ZS_xnorm,ZV_k,ZV_x,ZS_xfac,                        &
+                   ZV_1stIndex,ZV_2ndIndex,                                    &
+                   ZV_C1,ZV_C2,ZV_C3,ZM_A,                                     &
+                   ZV_QoutinitO,ZV_QoutinitR,                                  &
+                   ZV_QoutbarO,ZV_VinitR,ZV_VR,ZV_VbarR,                       &
+                   ZV_QoutR,ZV_QoutbarR,                                       &
+                   ZV_Vlat,ZV_Qlat,ZV_Qfor,ZV_Qext,                            &
+                   ZV_Qobsbarrec,                                              &
+                   ksp,                                                        &
+                   ZS_one,temp_char,                                           &
+                   IV_nc_start,IV_nc_count,                                    &
+                   IS_opt_phi,BS_opt_for,IS_strt_opt,IS_opt_routing,           &
+                   BS_opt_dam,IS_dam_bas,ZV_Qdam,BS_opt_hum,ZV_Qhum
+
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/taosolver.h" 
+!TAO solver
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+Vec, intent(in) :: ZV_pnorm
+TaoSolver, intent(inout)  :: tao
+PetscErrorCode, intent(out) :: ierr
+PetscScalar, intent(out):: ZS_phi
+PetscInt, intent (in) :: IS_dummy
+
+
+!*******************************************************************************
+!Set linear system corresponding to current ZV_pnorm and set initial flowrates  
+!*******************************************************************************
+ZS_phi=0
+!initialize phi to zero
+
+call VecDot(ZV_pnorm,ZV_1stIndex,ZS_knorm,ierr)
+call VecDot(ZV_pnorm,ZV_2ndIndex,ZS_xnorm,ierr)
+call VecCopy(ZV_kfac,ZV_k,ierr)
+call VecScale(ZV_k,ZS_knorm,ierr)
+call VecSet(ZV_x,ZS_xfac,ierr)
+call VecScale(ZV_x,ZS_xnorm,ierr)
+!compute ZV_k and ZV_x based on ZV_pnorm and ZV_kfac
+
+call rapid_routing_param(ZV_k,ZV_x,ZV_C1,ZV_C2,ZV_C3,ZM_A)
+!calculate Muskingum parameters and matrix ZM_A
+
+call KSPSetOperators(ksp,ZM_A,ZM_A,DIFFERENT_NONZERO_PATTERN,ierr)
+call KSPSetType(ksp,KSPRICHARDSON,ierr)                    !default=richardson
+call KSPSetFromOptions(ksp,ierr)                           !if runtime options
+!Set KSP to use matrix ZM_A
+if (IS_opt_routing==3) call KSPSetType(ksp,KSPPREONLY,ierr)!default=preonly
+
+
+!*******************************************************************************
+!Set initial values to assure subroutine always starts from same conditions 
+!*******************************************************************************
+
+!-------------------------------------------------------------------------------
+!Set initial value of instantaneous flow
+!-------------------------------------------------------------------------------
+call VecCopy(ZV_QoutinitO,ZV_QoutinitR,ierr)
+!copy initial optimization variables into initial routing variables
+
+!-------------------------------------------------------------------------------
+!Make sure the vectors potentially used for inflow to dams are initially null
+!-------------------------------------------------------------------------------
+call VecSet(ZV_Qext,0*ZS_one,ierr)                         !Qext=0
+call VecSet(ZV_QoutbarR,0*ZS_one,ierr)                     !QoutbarR=0
+!This matters only if rapid_get_Qdam is called because it uses these values
+
+!-------------------------------------------------------------------------------
+!Set initial value of Qext from Qout_dam0
+!-------------------------------------------------------------------------------
+if (BS_opt_dam .and. IS_dam_bas>0) then
+     call rapid_set_Qext0                                  !Qext from Qout_dam0
+     !call VecView(ZV_Qext,PETSC_VIEWER_STDOUT_WORLD,ierr)
+end if
+
+
+!*******************************************************************************
+!Calculate objective function for the whole period ZS_TauO
+!*******************************************************************************
+
+!-------------------------------------------------------------------------------
+!Open files
+!-------------------------------------------------------------------------------
+call rapid_open_Vlat_file(Vlat_file)
+call rapid_open_Qobs_file(Qobs_file)
+if (BS_opt_for) call rapid_open_Qfor_file(Qfor_file)
+if (BS_opt_hum) call rapid_open_Qhum_file(Qhum_file)
+
+
+!-------------------------------------------------------------------------------
+!Read and compute
+!-------------------------------------------------------------------------------
+IV_nc_start=(/1,IS_strt_opt/)
+IV_nc_count=(/IS_riv_tot,1/)
+
+
+do JS_O=1,IS_O
+
+!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + 
+!calculate mean daily flow
+!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + 
+call VecSet(ZV_QoutbarO,0*ZS_one,ierr)                 !QoutbarO=0
+
+do JS_RpO=1,IS_RpO   !loop needed here since Vlat is more frequent than Qobs
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Read/set surface and subsurface volumes 
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+call rapid_read_Vlat_file
+
+call VecCopy(ZV_Vlat,ZV_Qlat,ierr)            !Qlat=Vlat
+call VecScale(ZV_Qlat,1/ZS_TauR,ierr)         !Qlat=Qlat/TauR
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Read/set upstream forcing
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+if (BS_opt_for .and. IS_for_bas>0                                              &
+                   .and. mod((JS_O-1)*IS_RpO+JS_RpO,IS_RpF)==1) then
+
+call rapid_read_Qfor_file
+
+end if 
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Run dam model based on previous values of QoutbarR and Qext to get Qdam
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+if (BS_opt_dam .and. IS_dam_bas>0) then
+
+call rapid_get_Qdam
+
+end if
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Read/set human induced flows 
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+if (BS_opt_hum .and. IS_hum_bas>0                                              &
+                   .and. mod((JS_O-1)*IS_RpO+JS_RpO,IS_RpH)==1) then
+
+call rapid_read_Qhum_file
+
+end if 
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!calculation of Qext
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+call VecCopy(ZV_Qlat,ZV_Qext,ierr)                            !Qext=Qlat
+if (BS_opt_for) call VecAXPY(ZV_Qext,ZS_one,ZV_Qfor,ierr)     !Qext=Qext+1*Qfor
+if (BS_opt_dam) call VecAXPY(ZV_Qext,ZS_one,ZV_Qdam,ierr)     !Qext=Qext+1*Qdam
+if (BS_opt_hum) call VecAXPY(ZV_Qext,ZS_one,ZV_Qhum,ierr)     !Qext=Qext+1*Qhum
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+!Routing procedure
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+call rapid_routing(ZV_C1,ZV_C2,ZV_C3,ZV_Qext,                                  &
+                   ZV_QoutinitR,ZV_VinitR,                                     &
+                   ZV_QoutR,ZV_QoutbarR,ZV_VR,ZV_VbarR)
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+!Update variables
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+call VecCopy(ZV_QoutR,ZV_QoutinitR,ierr)
+
+call VecAXPY(ZV_QoutbarO,ZS_one/IS_RpO,ZV_QoutbarR,ierr)
+!Qoutbar=QoutbarO+QoutbarR/IS_RpO
+
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+!Update netCDF location         
+!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - 
+IV_nc_start(2)=IV_nc_start(2)+1
+
+
+enddo                !end of loop to account for forcing more frequent than obs
+
+!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + 
+!Calculate objective function for current day
+!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + 
+call rapid_read_Qobs_file
+
+!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + 
+!Objective function #1 - for current day - square error
+!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + 
+if (IS_opt_phi==1) then
+call VecWAXPY(ZV_temp1,-ZS_one,ZV_Qobs,ZV_QoutbarO,ierr)  !temp1=Qoutbar-Qobs
+call VecScale(ZV_temp1,ZS_phifac,ierr)                    !if phi too big      
+call MatMult(ZM_Obs,ZV_temp1,ZV_temp2,ierr)               !temp2=Obs*temp1
+call VecDot(ZV_temp1,ZV_temp2,ZS_phitemp,ierr)            !phitemp=temp1.temp2
+!result phitemp=(Qoutbar-Qobs)^T*Obs*(Qoutbar-Qobs)
+end if
+
+!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + 
+!Objective function #2 - for current day - square error normalized by avg flow
+!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + 
+if (IS_opt_phi==2) then
+call VecWAXPY(ZV_temp1,-ZS_one,ZV_Qobs,ZV_QoutbarO,ierr)  !temp1=Qoutbar-Qobs
+call VecPointWiseMult(ZV_temp1,ZV_temp1,ZV_Qobsbarrec,ierr)!temp1=temp1.*Qobsbarrec
+call MatMult(ZM_Obs,ZV_temp1,ZV_temp2,ierr)               !temp2=Obs*temp1
+call VecDot(ZV_temp1,ZV_temp2,ZS_phitemp,ierr)            !phitemp=temp1.temp2
+!result phitemp=[(Qoutbar-Qobs).*Qobsbarrec]^T*Obs*[(Qoutbar-Qobs).*Qobsbarrec]
+end if
+
+!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + 
+!adds daily objective function to total objective function
+!- + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + - + 
+ZS_phi=ZS_phi+ZS_phitemp
+!increments phi for each time step during the desired period of optimization
+
+enddo
+
+!-------------------------------------------------------------------------------
+!Close files 
+!-------------------------------------------------------------------------------
+call rapid_close_Vlat_file
+call rapid_close_Qobs_file
+call rapid_close_Qfor_file
+call rapid_close_Qhum_file
+
+
+!*******************************************************************************
+!Write outputs (parameters and calculated objective function)
+!*******************************************************************************
+call PetscPrintf(PETSC_COMM_WORLD,'current normalized p=(k,x)',ierr)
+call PetscPrintf(PETSC_COMM_WORLD,char(10),ierr)
+call VecView(ZV_pnorm,PETSC_VIEWER_STDOUT_WORLD,ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'corresponding value of phi',ierr)
+call PetscPrintf(PETSC_COMM_WORLD,char(10),ierr)
+write(temp_char,'(f10.3)') ZS_phi
+call PetscPrintf(PETSC_COMM_WORLD,temp_char // char(10),ierr)
+call PetscPrintf(PETSC_COMM_WORLD,'--------------------------'//char(10),ierr)
+
+
+end subroutine rapid_phiroutine
+#endif
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qfor_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qfor_file.F90
new file mode 100644
index 00000000..cb391ecc
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qfor_file.F90
@@ -0,0 +1,74 @@
+!*******************************************************************************
+!Subroutine - rapid_read_Qfor_file
+!*******************************************************************************
+subroutine rapid_read_Qfor_file
+
+!Purpose:
+!Read Qfor_file from Fortran.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   rank,ierr,ZV_read_for_tot,                                  &
+                   ZV_Qfor,IS_for_bas,IV_for_loc2,IV_for_index,ZV_read_for_tot
+
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/petsclog.h" 
+!PETSc log
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Read file
+!*******************************************************************************
+if (rank==0) read(34,*) ZV_read_for_tot
+
+
+!*******************************************************************************
+!Set values in PETSc vector
+!*******************************************************************************
+if (rank==0) then
+call VecSetValues(ZV_Qfor,IS_for_bas,IV_for_loc2,                              &
+                  ZV_read_for_tot(IV_for_index),INSERT_VALUES,ierr)
+                  !here we only look at the forcing within the basin studied 
+end if
+
+!*******************************************************************************
+!Assemble PETSc vector
+!*******************************************************************************
+call VecAssemblyBegin(ZV_Qfor,ierr)
+call VecAssemblyEnd(ZV_Qfor,ierr)
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_read_Qfor_file
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qhum_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qhum_file.F90
new file mode 100644
index 00000000..9c0c0af2
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qhum_file.F90
@@ -0,0 +1,75 @@
+!*******************************************************************************
+!Subroutine - rapid_read_Qhum_file
+!*******************************************************************************
+subroutine rapid_read_Qhum_file
+
+!Purpose:
+!Read Qhum_file from Fortran.
+!Author: 
+!Cedric H. David, 2014-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   rank,ierr,ZV_read_hum_tot,                                  &
+                   ZV_Qhum,IS_hum_bas,IV_hum_loc1,IV_hum_index,ZV_read_hum_tot
+
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/petsclog.h" 
+!PETSc log
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Read file
+!*******************************************************************************
+if (rank==0) read(36,*) ZV_read_hum_tot
+
+
+!*******************************************************************************
+!Set values in PETSc vector
+!*******************************************************************************
+if (rank==0) then
+call VecSetValues(ZV_Qhum,IS_hum_bas,IV_hum_loc1,                              &
+                  ZV_read_hum_tot(IV_hum_index),INSERT_VALUES,ierr)
+                  !here we only look at the human-induced flows within the basin 
+                  !studied 
+end if
+
+!*******************************************************************************
+!Assemble PETSc vector
+!*******************************************************************************
+call VecAssemblyBegin(ZV_Qhum,ierr)
+call VecAssemblyEnd(ZV_Qhum,ierr)
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_read_Qhum_file
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qobs_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qobs_file.F90
new file mode 100644
index 00000000..e6333dac
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Qobs_file.F90
@@ -0,0 +1,75 @@
+!*******************************************************************************
+!Subroutine - rapid_read_Qobs_file
+!*******************************************************************************
+subroutine rapid_read_Qobs_file
+
+!Purpose:
+!Read Qobs_file from Fortran.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   rank,ierr,                                                  &
+                   ZV_Qobs,IS_obs_bas,IV_obs_loc1,IV_obs_index,ZV_read_obs_tot
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/petsclog.h" 
+!PETSc log
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Read file
+!*******************************************************************************
+if (rank==0) read(33,*) ZV_read_obs_tot
+
+
+!*******************************************************************************
+!Set values in PETSc vector
+!*******************************************************************************
+if (rank==0) then
+call VecSetValues(ZV_Qobs,IS_obs_bas,IV_obs_loc1,                              &
+                  ZV_read_obs_tot(IV_obs_index),INSERT_VALUES,ierr)
+                  !here we only look at the observations within the basin
+                  !studied
+end if
+
+
+!*******************************************************************************
+!Assemble PETSc vector
+!*******************************************************************************
+call VecAssemblyBegin(ZV_Qobs,ierr)
+call VecAssemblyEnd(ZV_Qobs,ierr)
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_read_Qobs_file
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_read_Vlat_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Vlat_file.F90
new file mode 100644
index 00000000..64d3e30c
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_read_Vlat_file.F90
@@ -0,0 +1,79 @@
+!*******************************************************************************
+!Subroutine - rapid_read_Vlat_file
+!*******************************************************************************
+subroutine rapid_read_Vlat_file
+
+!Purpose:
+!Read Vlat_file from Fortran.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use netcdf
+use rapid_var, only :                                                          &
+                   rank,ierr,                                                  &
+                   IS_nc_status,IS_nc_id_fil_Vlat,IS_nc_id_var_Vlat,           &
+                   IV_nc_start,IV_nc_count,                                    &
+                   IS_riv_bas,IV_riv_loc1,IV_riv_index,ZV_read_riv_tot,ZV_Vlat
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/petsclog.h" 
+!PETSc log
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Read file
+!*******************************************************************************
+if (rank==0) then
+     IS_nc_status=NF90_GET_VAR(IS_nc_id_fil_Vlat,IS_nc_id_var_Vlat,            &
+                               ZV_read_riv_tot,IV_nc_start,IV_nc_count)
+end if
+
+
+!*******************************************************************************
+!Set values in PETSc vector
+!*******************************************************************************
+if (rank==0) then
+     call VecSetValues(ZV_Vlat,IS_riv_bas,IV_riv_loc1,                         &
+                       ZV_read_riv_tot(IV_riv_index),INSERT_VALUES,ierr)
+end if
+
+
+!*******************************************************************************
+!Assemble PETSc vector
+!*******************************************************************************
+call VecAssemblyBegin(ZV_Vlat,ierr)
+call VecAssemblyEnd(ZV_Vlat,ierr)
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_read_Vlat_file
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_read_namelist.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_read_namelist.F90
new file mode 100644
index 00000000..69ac97cd
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_read_namelist.F90
@@ -0,0 +1,38 @@
+!*******************************************************************************
+!Subroutine - rapid_read_namelist
+!*******************************************************************************
+subroutine rapid_read_namelist
+
+!Purpose:
+!This subroutine allows to read the RAPID namelist and hence to run the model
+!multiple times without ever have to recompile.  Some information on the options
+!used is also printed in the stdout.
+!Author: 
+!Cedric H. David, 2011-2015. 
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                     NL_namelist,namelist_file
+
+
+implicit none
+
+
+!*******************************************************************************
+!Read namelist file 
+!*******************************************************************************
+open(88,file=namelist_file,status='old',form='formatted')
+read(88, NL_namelist)
+close(88)
+
+
+!*******************************************************************************
+!Optional prints what was read 
+!*******************************************************************************
+!print *, namelist_file
+
+
+end subroutine rapid_read_namelist
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_routing.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_routing.F90
new file mode 100644
index 00000000..34e860e7
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_routing.F90
@@ -0,0 +1,268 @@
+!*******************************************************************************
+!Subroutine - rapid_routing
+!*******************************************************************************
+subroutine rapid_routing(ZV_C1,ZV_C2,ZV_C3,ZV_Qext,                            &
+                         ZV_QoutinitR,ZV_VinitR,                               &
+                         ZV_QoutR,ZV_QoutbarR,ZV_VR,ZV_VbarR)
+
+!Purpose:
+!Performs flow calculation in each reach of a river network using the Muskingum
+!method (McCarthy 1938).  Also calculates the volume of each reach using a
+!simple first order approximation
+!Author: 
+!Cedric H. David, 2008-2015. 
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use netcdf
+use rapid_var, only :                                                          &
+                   ZS_dtR,IS_R,JS_R,                                           &
+                   ZM_Net,ZM_TC1,                                              &
+                   ZV_b,ZV_babsmax,ZV_bhat,                                    &
+                   ZV_QoutprevR,ZV_VprevR,ZV_QoutRabsmin,ZV_QoutRabsmax,       &
+                   ZV_QoutRhat,                                                &
+                   ZV_VoutR,ZV_Vext,                                           &
+                   ierr,ksp,                                                   &
+                   ZS_one,IS_ksp_iter,IS_ksp_iter_max,                         &
+                   vecscat,ZV_SeqZero,ZV_pointer,rank,                         &
+                   IS_nc_status,IS_nc_id_fil_Qout,IS_nc_id_var_Qout,           &
+                   IV_nc_start,IV_nc_count2,                                   &
+                   IS_riv_bas,JS_riv_bas,IM_index_up,                          &
+                   IS_opt_routing,IV_nbup,IV_riv_index,                        &
+                   BS_opt_influence
+
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+Vec, intent(in)    :: ZV_C1,ZV_C2,ZV_C3,ZV_Qext,                               &
+                      ZV_QoutinitR,ZV_VinitR 
+Vec, intent(out)   :: ZV_QoutR,ZV_QoutbarR
+Vec                :: ZV_VR,ZV_VbarR
+
+PetscInt :: IS_localsize,JS_localsize
+PetscScalar, pointer :: ZV_QoutR_p(:),ZV_QoutprevR_p(:),ZV_QoutinitR_p(:),     &
+                        ZV_QoutbarR_p(:),ZV_Qext_p(:),ZV_C1_p(:),ZV_C2_p(:),   &
+                        ZV_C3_p(:),ZV_b_p(:),                                  &
+                        ZV_babsmax_p(:),ZV_QoutRabsmin_p(:),ZV_QoutRabsmax_p(:)
+
+
+!*******************************************************************************
+!Get local sizes for vectors
+!*******************************************************************************
+call VecGetLocalSize(ZV_QoutR,IS_localsize,ierr)
+
+
+!*******************************************************************************
+!Set mean values to zero initialize QoutprevR with QoutinitR
+!*******************************************************************************
+call VecSet(ZV_QoutbarR,0*ZS_one,ierr)                     !Qoutbar=0 
+!call VecSet(ZV_VbarR,0*ZS_one,ierr)                        !Vbar=0 
+!set the means to zero at beginning of iterations over routing time step
+
+call VecCopy(ZV_QoutinitR,ZV_QoutprevR,ierr)               !QoutprevR=QoutinitR
+!call VecCopy(ZV_VinitR,ZV_VprevR,ierr)                     !VprevR=VinitR
+!set the previous value to the initial value given as input to subroutine
+
+
+!*******************************************************************************
+!Temporal loop 
+!*******************************************************************************
+call VecGetArrayF90(ZV_C1,ZV_C1_p,ierr)
+call VecGetArrayF90(ZV_C2,ZV_C2_p,ierr)
+call VecGetArrayF90(ZV_C3,ZV_C3_p,ierr)
+call VecGetArrayF90(ZV_Qext,ZV_Qext_p,ierr)
+
+do JS_R=1,IS_R
+!-------------------------------------------------------------------------------
+!Update mean
+!-------------------------------------------------------------------------------
+call VecAXPY(ZV_QoutbarR,ZS_one/IS_R,ZV_QoutprevR,ierr) 
+!Qoutbar=Qoutbar+Qoutprev/IS_R
+
+!call VecAXPY(ZV_VbarR,ZS_one/IS_R,ZV_VprevR,ierr)       
+!Vbar=Vbar+Vprev/IS_R
+
+!-------------------------------------------------------------------------------
+!Calculation of the right hand size, b
+!-------------------------------------------------------------------------------
+call MatMult(ZM_Net,ZV_QoutprevR,ZV_b,ierr)                !b2=Net*Qoutprev
+
+call VecGetArrayF90(ZV_b,ZV_b_p,ierr)
+call VecGetArrayF90(ZV_QoutprevR,ZV_QoutprevR_p,ierr)
+
+do JS_localsize=1,IS_localsize
+     ZV_b_p(JS_localsize)=ZV_b_p(JS_localsize)*ZV_C2_p(JS_localsize)           &
+                         +(ZV_C1_p(JS_localsize)+ZV_C2_p(JS_localsize))        &
+                         *ZV_Qext_p(JS_localsize)                              &
+                         +ZV_C3_p(JS_localsize)*ZV_QoutprevR_p(JS_localsize)
+end do
+
+call VecRestoreArrayF90(ZV_QoutprevR,ZV_QoutprevR_p,ierr)
+call VecRestoreArrayF90(ZV_b,ZV_b_p,ierr)
+
+!-------------------------------------------------------------------------------
+!Routing with PETSc using a matrix method
+!-------------------------------------------------------------------------------
+if (IS_opt_routing==1) then
+
+call KSPSolve(ksp,ZV_b,ZV_QoutR,ierr)                      !solves A*Qout=b
+call KSPGetIterationNumber(ksp,IS_ksp_iter,ierr)
+if (IS_ksp_iter>IS_ksp_iter_max) IS_ksp_iter_max=IS_ksp_iter
+
+end if
+
+!-------------------------------------------------------------------------------
+!Routing with Fortran using the traditional Muskingum method
+!-------------------------------------------------------------------------------
+if (IS_opt_routing==2) then
+
+call VecGetArrayF90(ZV_QoutR,ZV_QoutR_p,ierr)
+call VecGetArrayF90(ZV_QoutprevR,ZV_QoutprevR_p,ierr)
+call VecGetArrayF90(ZV_b,ZV_b_p,ierr)
+
+do JS_riv_bas=1,IS_riv_bas
+     ZV_QoutR_p(JS_riv_bas)=ZV_b_p(JS_riv_bas)                                 &
+                            +sum(ZV_C1_p(JS_riv_bas)                           &
+                                  *ZV_QoutR_p(IM_index_up(JS_riv_bas,1:        &
+                                   IV_nbup(IV_riv_index(JS_riv_bas))))) 
+end do
+!Taking into account the knowledge of how many upstream locations exist.
+!Similar to exact preallocation of network matrix
+
+call VecRestoreArrayF90(ZV_QoutR,ZV_QoutR_p,ierr)
+call VecRestoreArrayF90(ZV_QoutprevR,ZV_QoutprevR_p,ierr)
+call VecRestoreArrayF90(ZV_b,ZV_b_p,ierr)
+end if
+
+!-------------------------------------------------------------------------------
+!Routing with PETSc using a matrix method with transboundary matrix
+!-------------------------------------------------------------------------------
+if (IS_opt_routing==3) then
+
+call KSPSolve(ksp,ZV_b,ZV_QoutRhat,ierr)                     !solves A*Qouthat=b
+call KSPGetIterationNumber(ksp,IS_ksp_iter,ierr)
+if (IS_ksp_iter>IS_ksp_iter_max) IS_ksp_iter_max=IS_ksp_iter
+
+call MatMult(ZM_TC1,ZV_QoutRhat,ZV_bhat,ierr)
+call VecAYPX(ZV_bhat,ZS_one,ZV_b,ierr)
+
+call KSPSolve(ksp,ZV_bhat,ZV_QoutR,ierr)                     !solves A*Qout=bhat
+call KSPGetIterationNumber(ksp,IS_ksp_iter,ierr)
+if (IS_ksp_iter>IS_ksp_iter_max) IS_ksp_iter_max=IS_ksp_iter
+
+end if
+
+
+!-------------------------------------------------------------------------------
+!Calculation of babsmax, QoutRabsmin and QoutRabsmax
+!-------------------------------------------------------------------------------
+if (BS_opt_influence) then
+
+call VecGetArrayF90(ZV_b,ZV_b_p,ierr)
+call VecGetArrayF90(ZV_babsmax,ZV_babsmax_p,ierr)
+do JS_localsize=1,IS_localsize
+     if (ZV_babsmax_p(JS_localsize)<=abs(ZV_b_p(JS_localsize))) then
+         ZV_babsmax_p(JS_localsize) =abs(ZV_b_p(JS_localsize))
+     end if
+end do
+call VecRestoreArrayF90(ZV_b,ZV_b_p,ierr)
+call VecRestoreArrayF90(ZV_babsmax,ZV_babsmax_p,ierr)
+
+call VecGetArrayF90(ZV_QoutR,ZV_QoutR_p,ierr)
+call VecGetArrayF90(ZV_QoutRabsmin,ZV_QoutRabsmin_p,ierr)
+call VecGetArrayF90(ZV_QoutRabsmax,ZV_QoutRabsmax_p,ierr)
+do JS_localsize=1,IS_localsize
+     if (ZV_QoutRabsmin_p(JS_localsize)>=abs(ZV_QoutR_p(JS_localsize))) then
+         ZV_QoutRabsmin_p(JS_localsize) =abs(ZV_QoutR_p(JS_localsize))
+     end if
+     if (ZV_QoutRabsmax_p(JS_localsize)<=abs(ZV_QoutR_p(JS_localsize))) then
+         ZV_QoutRabsmax_p(JS_localsize) =abs(ZV_QoutR_p(JS_localsize))
+     end if
+end do
+call VecRestoreArrayF90(ZV_QoutR,ZV_QoutR_p,ierr)
+call VecRestoreArrayF90(ZV_QoutRabsmin,ZV_QoutRabsmin_p,ierr)
+call VecRestoreArrayF90(ZV_QoutRabsmax,ZV_QoutRabsmax_p,ierr)
+
+end if
+
+!-------------------------------------------------------------------------------
+!Calculation of V (this part can be commented to accelerate parameter 
+!estimation in calibration mode)
+!-------------------------------------------------------------------------------
+!call VecCopy(ZV_QoutR,ZV_VoutR,ierr)                      !Vout=Qout
+!call VecScale(ZV_VoutR,ZS_dtR,ierr)                       !Vout=Vout*dt
+!!result Vout=Qout*dt
+!
+!call VecCopy(ZV_Qext,ZV_Vext,ierr)                        !Vext=Qext
+!call VecScale(ZV_Vext,ZS_dtR,ierr)                        !Vext=Vext*dt
+!!result Vext=Qext*dt
+!
+!call MatMult(ZM_Net,ZV_VoutR,ZV_VR,ierr)                  !V=Net*Vout
+!call VecAXPY(ZV_VR,ZS_one,ZV_Vext,ierr)                   !V=V+Vext
+!call VecAXPY(ZV_VR,-ZS_one,ZV_VoutR,ierr)                 !V=V-Vout
+!call VecAXPY(ZV_VR,ZS_one,ZV_VprevR,ierr)                 !V=V+Vprev
+!!result V=Vprev+(Net*Vout+Vext)-Vout
+
+
+!-------------------------------------------------------------------------------
+!Reset previous
+!-------------------------------------------------------------------------------
+call VecCopy(ZV_QoutR,ZV_QoutprevR,ierr)              !Qoutprev=Qout
+!call VecCopy(ZV_VR,ZV_VprevR,ierr)                    !Vprev=V
+!reset previous 
+
+
+!-------------------------------------------------------------------------------
+!optional write outputs
+!-------------------------------------------------------------------------------
+!call VecScatterBegin(vecscat,ZV_QoutR,ZV_SeqZero,                              &
+!                     INSERT_VALUES,SCATTER_FORWARD,ierr)
+!call VecScatterEnd(vecscat,ZV_QoutR,ZV_SeqZero,                                &
+!                        INSERT_VALUES,SCATTER_FORWARD,ierr)
+!call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+!!if (rank==0) write (99,'(10e10.3)') ZV_pointer
+!if (rank==0) IS_nc_status=NF90_PUT_VAR(IS_nc_id_fil_Qout,IS_nc_id_var_Qout,    &
+!                                       ZV_pointer,                             &
+!                     [IV_nc_start(1),(IV_nc_start(2)-1)*IS_R+JS_R],IV_nc_count2)
+!call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+
+
+!-------------------------------------------------------------------------------
+!End temporal loop
+!-------------------------------------------------------------------------------
+end do
+
+call VecRestoreArrayF90(ZV_C1,ZV_C1_p,ierr)
+call VecRestoreArrayF90(ZV_C2,ZV_C2_p,ierr)
+call VecRestoreArrayF90(ZV_C3,ZV_C3_p,ierr)
+call VecRestoreArrayF90(ZV_Qext,ZV_Qext_p,ierr)
+
+
+!*******************************************************************************
+!End
+!*******************************************************************************
+end subroutine rapid_routing
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_routing_param.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_routing_param.F90
new file mode 100644
index 00000000..96ba7fab
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_routing_param.F90
@@ -0,0 +1,100 @@
+!*******************************************************************************
+!Subroutine - rapid_routing_param
+!*******************************************************************************
+subroutine rapid_routing_param(ZV_k,ZV_x,                                      &
+                               ZV_C1,ZV_C2,ZV_C3,ZM_A) 
+
+!Purpose:
+!Calculates the Muskingum method (McCarthy 1938) parameters C1, C2 and C3.  
+!Also calculates the matrix A used for linear system solver. 
+!Author: 
+!Cedric H. David, 2010-2015. 
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only :                                                          &
+                   ZM_Net,ZM_T,ZM_TC1,                                         &
+                   ZV_Cdenom,ZS_dtR,                                           &
+                   ierr,ZS_one,ZV_one,IS_opt_routing
+
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+Vec, intent(in)    :: ZV_k,ZV_x
+Vec, intent(out)   :: ZV_C1,ZV_C2,ZV_C3,ZM_A 
+
+
+!*******************************************************************************
+!Calculation of the Muskingum method constants (C1,C2,C3) and of the matrix A 
+!used in the linear system A*Qout=b
+!*******************************************************************************
+call VecCopy(ZV_x,ZV_Cdenom,ierr)
+call VecScale(ZV_Cdenom,-ZS_one,ierr)
+call VecShift(ZV_Cdenom,ZS_one,ierr)
+call VecPointwiseMult(ZV_Cdenom,ZV_Cdenom,ZV_k,ierr)
+call VecShift(ZV_Cdenom,ZS_dtR/2,ierr)
+!Cdenom=k*(1-x)+dtR/2
+
+call VecPointwiseMult(ZV_C1,ZV_k,ZV_x,ierr)
+call VecScale(ZV_C1,-ZS_one,ierr)
+call VecShift(ZV_C1,ZS_dtR/2,ierr)
+call VecPointwiseDivide(ZV_C1,ZV_C1,ZV_Cdenom,ierr)
+!C1=(-k*x+dtR/2)/Cdenom
+
+call VecPointwiseMult(ZV_C2,ZV_k,ZV_x,ierr)
+call VecShift(ZV_C2,ZS_dtR/2,ierr)
+call VecPointwiseDivide(ZV_C2,ZV_C2,ZV_Cdenom,ierr)
+!C2=(k*x+dtR/2)/Cdenom
+
+call VecCopy(ZV_x,ZV_C3,ierr)
+call VecScale(ZV_C3,-ZS_one,ierr)
+call VecShift(ZV_C3,ZS_one,ierr)
+call VecPointwiseMult(ZV_C3,ZV_C3,ZV_k,ierr)
+call VecShift(ZV_C3,-ZS_dtR/2,ierr)
+call VecPointwiseDivide(ZV_C3,ZV_C3,ZV_Cdenom,ierr)
+!C3=(k*(1-x)-dtR/2)/Cdenom
+!C1, C2 and C3 completed
+
+
+call MatCopy(ZM_Net,ZM_A,DIFFERENT_NONZERO_PATTERN,ierr)   !A=Net
+call MatDiagonalScale(ZM_A,ZV_C1,ZV_one,ierr)              !A=diag(C1)*A
+call MatScale(ZM_A,-ZS_one,ierr)                           !A=-A
+call MatShift(ZM_A,ZS_one,ierr)                            !A=A+1*I
+!Result:A=I-diag(C1)*Net
+
+if (IS_opt_routing==3) then
+call MatCopy(ZM_T,ZM_TC1,DIFFERENT_NONZERO_PATTERN,ierr)        !TC1=T
+call MatDiagonalScale(ZM_TC1,ZV_C1,ZV_one,ierr)            !TC1=diag(C1)*TC1
+!Result:TC1=T*diag(C1)
+end if
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_routing_param
+
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_script.sh b/wrfv2_fire/hydro/Rapid_routing/rapid_script.sh
new file mode 100644
index 00000000..35753daf
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_script.sh
@@ -0,0 +1,11 @@
+FILE=$(date +"%Y-%m-%d_%H-%M-%S_rapid_stdout.txt")
+/usr/bin/time mpiexec                  \
+              -n 1                     \
+              ./rapid                  \
+              -ksp_type richardson     \
+              1>$FILE 2>>$FILE
+
+#FILE is a name created based on the time when the model started running
+#FILE contains stdout from running the model (through 1), but also stderr 
+#(through 2).  The output of the time function is also included because 
+#it is located in located in 2.
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_set_Qext0.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_set_Qext0.F90
new file mode 100644
index 00000000..768fb7a6
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_set_Qext0.F90
@@ -0,0 +1,103 @@
+!*******************************************************************************
+!Subroutine - rapid_set_Qext0
+!*******************************************************************************
+subroutine rapid_set_Qext0
+
+!Purpose:
+!This subroutine is only useful if a dam model is used and its goal is to 
+!properly initialize the flow of water into the dams.
+!The inflow of water ZV_Qin_dam_prev from the river network and from outside of 
+!the river network into the dams is computed based on ZV_QoutbarR and ZV_Qext
+!in the subroutine rapid_get_Qdam.F90. 
+!Therefore, one has to inject the initial value of ZV_Qin_dam_prev (ZV_Qin_dam0) 
+!into either ZV_QoutbarR or ZV_Qext otherwise the initial value will be 
+!overwritten in rapid_get_Qdam.F90. The latter is used here (through ZV_Qdam)
+!since the modifications made on the network matrix make it difficult to use
+!ZV_Qin_dam_prev without creating a new variable.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Declaration of variables
+!*******************************************************************************
+use rapid_var, only:                                                           &
+                   rank,ierr,IS_one,ZS_one,                                    &
+                   ZV_Qdam,ZV_Qext,                                            &
+                   IS_dam_tot,JS_dam_tot,IV_dam_pos 
+
+use rapid_var, only:                                                           &
+                   ZV_Qin_dam_prev,ZV_Qin_dam0,                                &
+                   ZV_Qout_dam_prev,ZV_Qout_dam0
+
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/petsclog.h" 
+!PETSc log
+
+
+!*******************************************************************************
+!Set Qdam to zero, because this is called at the beginning of every phiroutine
+!*******************************************************************************
+call VecSet(ZV_Qdam,0*ZS_one,ierr)                            !Qdam=0
+!call VecView(ZV_Qdam,PETSC_VIEWER_STDOUT_WORLD,ierr)
+
+
+!*******************************************************************************
+!Set values of Qin_dam0 into Qdam to allow proper initialization
+!*******************************************************************************
+if (rank==0) then
+     do JS_dam_tot=1,IS_dam_tot
+
+if (IV_dam_pos(JS_dam_tot)/=0) then
+     call VecSetValues(ZV_Qdam,IS_one,IV_dam_pos(JS_dam_tot)-1,                &
+                       ZV_Qin_dam0(JS_dam_tot),INSERT_VALUES,ierr)
+     !print *, IV_dam_pos(JS_dam_tot)-1, ZV_Qin_dam0(JS_dam_tot)
+end if
+
+     end do
+end if
+
+call VecAssemblyBegin(ZV_Qdam,ierr)
+call VecAssemblyEnd(ZV_Qdam,ierr)      
+!call VecView(ZV_Qdam,PETSC_VIEWER_STDOUT_WORLD,ierr)
+!the values of Qindam0 are set here where the dams are, not downstream of them
+
+
+!*******************************************************************************
+!Copy Qdam into Qext and reset Qdam to zero
+!*******************************************************************************
+call VecCopy(ZV_Qdam,ZV_Qext,ierr)                            !Qext=Qdam
+call VecSet(ZV_Qdam,0*ZS_one,ierr)                            !Qdam=0
+!call VecView(ZV_Qext,PETSC_VIEWER_STDOUT_WORLD,ierr)
+
+
+!*******************************************************************************
+!Initialize Qout_dam_prev again or its values differ with each phiroutine call
+!*******************************************************************************
+if (rank==0) then
+     ZV_Qout_dam_prev=ZV_Qout_dam0
+end if
+
+!*******************************************************************************
+!End
+!*******************************************************************************
+end subroutine rapid_set_Qext0
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_var.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_var.F90
new file mode 100644
index 00000000..e8017c6d
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_var.F90
@@ -0,0 +1,538 @@
+!*******************************************************************************
+!Module - rapid_var
+!*******************************************************************************
+module rapid_var
+
+!Purpose:
+!Module where all the variables are defined. 
+!Author: 
+!Cedric H. David, 2008-2015. 
+
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and Fortran90-specific vectors 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+!#include "finclude/petsclog.h" 
+!Profiling log
+
+#ifndef NO_TAO
+#include "finclude/taosolver.h" 
+!TAO solver
+#endif
+
+
+!*******************************************************************************
+!Declaration of variables - runtime options
+!*******************************************************************************
+logical :: BS_opt_Qinit
+!.false. --> no read initial flow    .true. --> read initial flow
+logical :: BS_opt_Qfinal
+!.false. --> no write final flow     .true. --> write final flow 
+logical :: BS_opt_hum
+!.false. --> no human-induced flows  .true. --> human-induced flows
+logical :: BS_opt_for
+!.false. --> no forcing              .true. --> forcing
+logical :: BS_opt_dam
+!.false. --> no dam model used       .true. --> dam model used
+logical :: BS_opt_influence
+!.false. --> no output influence     .true. --> output influence
+PetscInt :: IS_opt_routing
+!1       --> matrix-based Muskingum  2      --> traditional Muskingum
+!3       --> Transbnd. matrix-based
+PetscInt :: IS_opt_run
+!1       --> regular run             2      --> parameter optimization
+PetscInt :: IS_opt_phi
+!1       --> phi1                    2      --> phi2
+
+
+!! LPR: add the path for coupling file in NAMELIST
+!character(len=120) :: rapid_coupling_file
+!unit 88 - file that contains coupling information for WRF-Hydro
+!*******************************************************************************
+!Declaration of variables - input and output files
+!*******************************************************************************
+character(len=120) :: rapid_connect_file
+!unit 10 - file with connectivity information using RAPID connectivity format
+character(len=120) :: riv_bas_id_file
+!unit 11 - file with all the IDs of the reaches in _riv considered
+character(len=120) :: obs_tot_id_file
+!unit 12 - file with all the IDs of the all reaches with gage measurements
+character(len=120) :: obs_use_id_file
+!unit 13 - file with all the IDs of the reaches used
+character(len=120) :: hum_tot_id_file
+!unit 14 - file with all the IDs of the reaches with human-induced flow added
+character(len=120) :: hum_use_id_file
+!unit 15 - file with all the IDs of the reaches used
+character(len=120) :: for_tot_id_file
+!unit 16 - file with all the IDs where flows can be used as forcing to their 
+!corresponding downstream reach  
+character(len=120) :: for_use_id_file
+!unit 17 - file with all the IDs of the reaches used 
+character(len=120) :: dam_tot_id_file
+!unit 18 - file with all the IDs of the reaches where the dam model runs and 
+!flows to their corresponding downstream reach  
+character(len=120) :: dam_use_id_file
+!unit 19 - file with all the IDs of the reaches used
+
+character(len=120) :: k_file
+!unit 20 - file with values for k (possibly from previous param. estim.)
+character(len=120) :: x_file
+!unit 21 - file with values for x (possibly from previous param. estim.)
+character(len=120) :: kfac_file  
+!unit 22 - file with kfac for all reaches of the domain
+character(len=120) :: xfac_file
+!unit 23 - file with xfac for all reaches of the domain
+
+character(len=120) :: Qinit_file
+!unit 30 - file where initial flowrates can be stored to run the model with them
+character(len=120) :: Qfinal_file
+!unit 31 - file where final flowrates can be stored at the end of model run 
+character(len=120) :: Vlat_file
+
+character(len=120) :: Qobs_file
+!unit 33 - file where the flowrates observations are given
+character(len=120) :: Qfor_file
+!unit 34 - file where forcing flowrates are stored.  Forcing is taken as the
+!flow coming from upstream reach.
+character(len=120) :: Qobsbarrec_file
+!unit 35 - file where the reciprocal (1/xi) of the average obs are stored.
+character(len=120) :: Qhum_file
+!unit 36 - file where human-induced flowrates are stored.  These flows are added 
+!upstream.
+
+character(len=120) :: V_file
+!unit 41 - file where model-calculated volumes are stored
+character(len=120) :: babsmax_file
+!unit 42 - file where the maximum of the absolute values of the right-hand-side
+!are stored
+character(len=120) :: QoutRabsmin_file
+!unit 43 - file where the minimum of the absolute values of the instantaneous 
+!flows are stored 
+character(len=120) :: QoutRabsmax_file
+!unit 44 - file where the maximum of the absolute values of the instantaneous 
+!flows are stored 
+character(len=120) :: Qout_file
+
+
+!*******************************************************************************
+!Declaration of variables - temporal parameters
+!*******************************************************************************
+PetscScalar :: ZS_TauM
+!Duration of main procedure, in seconds
+PetscScalar :: ZS_dtM
+!Time step of main procedure, in seconds
+PetscInt :: IS_M
+!Number of time steps within the main precedure
+PetscInt :: JS_M
+!Index of main procedure 
+
+PetscScalar :: ZS_TauO
+!Duration of optimization procedure, in seconds
+PetscScalar :: ZS_dtO
+!Time step of optimization procedure, in seconds
+PetscInt :: IS_O
+!Number of time steps within the optimization precedure
+PetscInt :: JS_O
+!Index of optimization procedure 
+
+PetscScalar :: ZS_TauR
+!Duration of river routing procedure, in seconds
+PetscScalar :: ZS_dtR  
+!Time step of river routing procedure, in seconds  
+PetscInt :: IS_R
+!Number of time steps within the river routing procedure
+PetscInt :: JS_R
+!Index of river routing procedure
+
+PetscScalar :: ZS_dtF
+!Time step of forcing data, in seconds  
+PetscScalar :: ZS_dtH
+!Time step of human-induced data, in seconds  
+
+PetscInt :: IS_RpO, JS_RpO
+!Number routing procedures needed per optimization time step, and index
+PetscInt :: IS_RpM, JS_RpM
+!Number routing procedures needed per main time step, and index 
+PetscInt :: IS_RpF
+!Number routing procedures needed per forcing time step 
+PetscInt :: IS_RpH
+!Number routing procedures needed per human-induced time step
+
+
+!*******************************************************************************
+!Declaration of variables - River flow variables
+!*******************************************************************************
+PetscInt :: IS_riv_tot,JS_riv_tot,JS_riv_tot2
+!total number of river reaches, corresponds to the size of rapid_connect_file
+PetscInt :: IS_riv_bas,JS_riv_bas,JS_riv_bas2
+!size of the matrix and the vectors in this _riv, corresponds to the number of
+!reaches in the _riv
+PetscInt, dimension(:), allocatable :: IV_riv_tot_id
+!unique IDs of reaches in rapid_connect_file
+PetscInt, dimension(:), allocatable :: IV_down
+!vector of the downstream river reach of each river reach
+PetscInt, dimension(:), allocatable :: IV_nbup
+!vector of the number of direct upstream river reach of each river reach 
+PetscInt :: IS_max_up
+!maximum number of upstream river reaches for each river reach
+PetscInt, dimension(:,:), allocatable :: IM_up
+!matrix with the ID of the upstream river reaches of each river reach
+PetscInt :: JS_up
+!JS_up for the corresponding upstream reaches
+PetscInt :: IS_row,IS_col
+!index of rows and columns used to fill up the network matrix
+PetscInt,dimension (:,:), allocatable :: IM_index_up
+!matrix with the index of the upstream river reaches of each river reach
+!index goes from 1 to IS_riv_bas 
+PetscInt, dimension(:),allocatable :: IV_riv_bas_id
+!unique IDs in riv_bas_id_file, of length IS_riv_bas
+PetscInt, dimension(:), allocatable :: IV_riv_index
+!indexes (Fortran, 1-based) of the reaches in the _riv within the whole network
+!size IS_riv_bas
+PetscInt,dimension(:), allocatable :: IV_riv_loc1
+!vector giving the zero-base index corresponding to the river reaches within 
+!the _riv studied only, to be used in VecSetValues. size IS_riv_bas
+Mat :: ZM_hsh_tot
+!flat matrix with size IS_riv_id_max*ncore that serves a hashtable-like purpose 
+!in which the index over the domain (JS_riv_tot) is stored at the location of 
+!each reach ID. Each row contains the exact same data.
+Mat :: ZM_hsh_bas
+!flat matrix with size IS_riv_id_max*ncore that serves a hashtable-like purpose 
+!in which the index over the basin (JS_riv_bas) is stored at the location of 
+!each reach ID. Each row contains the exact same data.
+PetscInt :: IS_riv_id_max=1000000000
+!Maximum value allowed for the unique integer IDs corresponding to each reach
+
+!*******************************************************************************
+!Declaration of variables - Observation flow variables
+!*******************************************************************************
+PetscInt :: IS_obs_tot, JS_obs_tot
+!total number of reaches that have observations (gaged reaches), corresponds to
+!the number of lines in obs_tot_id_file 
+PetscInt :: IS_obs_use, JS_obs_use
+!Number of gages available in obs_use_id_file
+PetscInt :: IS_obs_bas, JS_obs_bas
+!Number of gages within _riv studied.  Will be calculated based on 
+!obs_tot_id_file, obs_use_id_file and riv_bas_id_file
+PetscInt, dimension(:), allocatable :: IV_obs_tot_id
+!vector where are stored the river ID of each gage available
+PetscInt, dimension(:), allocatable :: IV_obs_use_id
+!vector where are stored the river ID of each gage used in current run
+PetscInt, allocatable, dimension(:) :: IV_obs_index
+!vector where the Fortran 1-based indexes of the gages within the Qobs_file. 
+!Will be allocated size IS_obs_bas
+PetscInt, allocatable, dimension(:) :: IV_obs_loc1
+!vector where the C (0-based) vector indexes of where gages are. This is 
+!within the _riv only, not all domain. Will be used in VecSet.  Will be 
+!allocated size IS_obs_bas
+
+
+!*******************************************************************************
+!Declaration of variables - Human-induced flow variables
+!*******************************************************************************
+PetscInt :: IS_hum_tot, JS_hum_tot
+!total number of reaches where human-induced flow data are available. 
+PetscInt :: IS_hum_use, JS_hum_use
+!total number of reaches where human-induced will be used if in sub_riv
+PetscInt :: IS_hum_bas, JS_hum_bas
+!number of reaches with human-induced flow, within _riv. Calculated on the fly
+!from hum_tot_if_file, hum_use_id_file and riv_bas_id_file
+PetscInt, dimension(:), allocatable :: IV_hum_tot_id
+!IDs of the reaches where human-induced flow data are available
+PetscInt, dimension(:), allocatable :: IV_hum_use_id
+!IDs of the reaches where human-induced flow data will be used if in sub_riv
+PetscInt, dimension(:), allocatable :: IV_hum_bas_id
+!IDs of the reaches where human-indeced flow data to be used is in sub_riv
+PetscInt, allocatable, dimension(:) :: IV_hum_index
+!vector where the Fortran 1-based indexes of the human-induced flow data are 
+!stored. This is of size IS_hum_bas and its elements belong to [1,IS_hum_tot]. 
+PetscInt, allocatable, dimension(:) :: IV_hum_loc1
+!vector where the C (0-based) vector indexes of where the above human-induced 
+!flow data are going to be applied. This is of size IS_hum_bas and its elements 
+!belong to [0,IS_riv_bas-1]. Applied on the river ID itself.
+
+
+!*******************************************************************************
+!Declaration of variables - Forcing flow variables
+!*******************************************************************************
+PetscInt :: IS_for_tot, JS_for_tot
+!total number of reaches where forcing flow data are available. 
+PetscInt :: IS_for_use, JS_for_use
+!total number of reaches where forcing will be used if in sub_riv
+PetscInt :: IS_for_bas, JS_for_bas
+!number of reaches forced by observations, within _riv. Calculated on the fly
+!from for_tot_id_file, for_use_id_file and riv_bas_id_file
+PetscInt, dimension(:), allocatable :: IV_for_tot_id
+!IDs of the reaches where forcing flow data are available
+PetscInt, dimension(:), allocatable :: IV_for_use_id
+!IDs of the reaches where forcing flow data will be used if in sub_riv
+PetscInt, dimension(:), allocatable :: IV_for_bas_id
+!IDs of the reaches where forcing flow data to be used is in sub_riv
+PetscInt, allocatable, dimension(:) :: IV_for_index
+!vector where the Fortran 1-based indexes of the forcing flow data are 
+!available. This is of size IS_for_bas and its elements belong to [1,IS_for_tot] 
+PetscInt, allocatable, dimension(:) :: IV_for_loc2
+!vector where the C (0-based) vector indexes of where the above forcing 
+!flow data are going to be applied. This is of size IS_for_bas and its elements 
+!belong to [0,IS_riv_bas-1]. Applied on the river ID downstream.
+
+
+!*******************************************************************************
+!Declaration of variables - dam model flow variables
+!*******************************************************************************
+PetscInt :: IS_dam_tot, JS_dam_tot
+!total number of reaches where dam model flow data are available. 
+PetscInt :: IS_dam_use, JS_dam_use
+!total number of reaches where dam model will be used if in sub_riv
+PetscInt :: IS_dam_bas, JS_dam_bas
+!number of reaches forced by observations, within _riv. Calculated on the fly
+!from dam_tot_id_file, dam_use_id_file and riv_bas_id_file. 
+PetscInt, dimension(:), allocatable :: IV_dam_tot_id
+!IDs of the reaches where dam model flow data are available
+PetscInt, dimension(:), allocatable :: IV_dam_use_id
+!IDs of the reaches where dam model flow data will be used if in sub_riv
+PetscInt, dimension(:), allocatable :: IV_dam_bas_id
+!IDs of the reaches where dam model flow data to be used is in sub_riv
+PetscInt, allocatable, dimension(:) :: IV_dam_index
+!vector where the Fortran 1-based indexes of the dam model flow data are 
+!available. This is of size IS_dam_bas and its elements belong to [1,IS_dam_tot] 
+PetscInt, allocatable, dimension(:) :: IV_dam_loc2
+!vector where the C (0-based) vector indexes of where the above dam model
+!flow data are going to be applied. This is of size IS_dam_bas and its elements 
+!belong to [0,IS_riv_bas-1]. Applied on the river ID downstream.
+PetscInt, allocatable, dimension(:) :: IV_dam_pos
+!vector where the Fortran 1-based vector indexes of where flows will be given to 
+!the above dam model. This is of size IS_dam_tot and its elements belong to 
+![1,IS_riv_bas] except when a dam ID is outside of basin studied where it is 0. 
+!Applied on the river ID itself.
+
+PetscScalar, allocatable, dimension(:) :: ZV_Qin_dam,ZV_Qin_dam_prev
+PetscScalar, allocatable, dimension(:) :: ZV_Qout_dam,ZV_Qout_dam_prev
+PetscScalar, allocatable, dimension(:) :: ZV_Qin_dam0,ZV_Qout_dam0
+!Fortran vectors where the inflows and outflows for the dam module are saved. 
+!These will be allocated to size IS_dam_tot
+
+
+!*******************************************************************************
+!Declaration of variables - Network matrix variables and routing variables
+!*******************************************************************************
+Mat :: ZM_Net
+!Network matrix
+Mat :: ZM_A
+!Matrix used to solve linear system 
+Mat :: ZM_T
+!Transboundary matrix
+Mat :: ZM_TC1
+!Matrix used as a trick to solve linear system faster
+Logical :: BS_logical
+!Boolean used during network matrix creation to give warnings if connectivity pb
+
+Vec :: ZV_k,ZV_x
+!Muskingum expression constants vectors, k in seconds, x has no dimension
+Vec :: ZV_p, ZV_pnorm,ZV_pfac
+!vector of the problem parameters, p=(k,x).  normalized version and 
+!corresponding factors p=pnorm*pfac
+Vec :: ZV_C1,ZV_C2,ZV_C3,ZV_Cdenom 
+!Muskingum method constants (last is the common denominator, for calculations)
+Vec :: ZV_b,ZV_babsmax,ZV_bhat
+!Used for linear system A*Qout=b
+
+!Input variables (contribution)
+Vec :: ZV_Qext,ZV_Qfor,ZV_Qlat,ZV_Qhum,ZV_Qdam
+!flowrates Qext is the sum of forced and lateral
+Vec :: ZV_Vext,ZV_Vfor,ZV_Vlat 
+!volumes (same as above)
+
+!Main only variables
+Vec :: ZV_QoutM,ZV_QoutinitM,ZV_QoutprevM,ZV_QoutbarM
+Vec :: ZV_VM,ZV_VinitM,ZV_VprevM,ZV_VbarM
+
+!Optimization only variables
+Vec :: ZV_QoutO,ZV_QoutinitO,ZV_QoutprevO,ZV_QoutbarO
+Vec :: ZV_VO,ZV_VinitO,ZV_VprevO,ZV_VbarO
+
+!Routing only variables
+Vec :: ZV_QoutR,ZV_QoutinitR,ZV_QoutprevR,ZV_QoutbarR,ZV_QoutRhat,ZV_QinbarR
+Vec :: ZV_QoutRabsmin,ZV_QoutRabsmax
+Vec :: ZV_VR,ZV_VinitR,ZV_VprevR,ZV_VbarR
+Vec :: ZV_VoutR
+
+
+!*******************************************************************************
+!Declaration of variables - Observation matrix and optimization variables
+!*******************************************************************************
+Mat :: ZM_Obs
+!Observation matrix
+Vec :: ZV_Qobs
+!Observation vector
+PetscScalar :: ZS_norm
+!norm of matrix ZM_Obs, used to calculate the number of gaging stations used
+
+PetscScalar :: ZS_phi,ZS_phitemp
+!cost function
+PetscInt :: IS_Iter
+!number of iterations needed for optimization procedure to end
+Vec :: ZV_temp1,ZV_temp2
+!temporary vectors, used for calculations
+PetscScalar :: ZS_phifac
+PetscInt :: IS_strt_opt
+!first time step at which Vlat data is read during optimization
+
+Vec :: ZV_kfac
+!Vector of size IS_riv_bas a multiplication factor for k for all river reaches
+!in _riv
+Vec :: ZV_Qobsbarrec
+!Vector with the reciprocal (1/xi) of the average observations
+
+PetscScalar :: ZS_knorm, ZS_xnorm
+!constants (k,x) in Muskingum expression, normalized
+PetscScalar :: ZS_knorm_init, ZS_xnorm_init
+!constants (k,x) in Muskingum expression, normalized, initial values for opt.
+PetscScalar, parameter :: ZS_kfac=3600,ZS_xfac=0.1
+!corresponding factors, k in seconds, x has no dimension
+PetscScalar :: ZS_k,ZS_x
+!constants (k,x) in Muskingum expression.  k in seconds, x has no dimension
+
+
+!*******************************************************************************
+!Declaration of variables - routing parameters and initial values 
+!*******************************************************************************
+PetscScalar :: ZS_V0=10000,ZS_Qout0=0
+!values to be used in the intitial state of V and Qout for river routing
+!initial volume for each reach (m^3), initial outflow for each reach (m^3/s)
+
+
+!*******************************************************************************
+!Declaration of variables - PETSc specific objects and variables
+!*******************************************************************************
+PetscErrorCode :: ierr
+!needed for error check of PETSc functions
+KSP :: ksp
+!object used for linear system solver
+PC :: pc
+!preconditioner object
+PetscMPIInt :: rank
+!integer where the number of each processor is stored, 0 will be main processor 
+PetscMPIInt :: ncore
+!integer where the number of cores used is stored 
+VecScatter :: vecscat
+!Allows for scattering and gathering vectors from in parallel environement
+PetscLogEvent :: stage
+!Stage for investigating performance
+
+PetscInt :: IS_ksp_iter, IS_ksp_iter_max
+!integer where the number of iterations in KSP is solved
+PetscInt :: IS_one=1
+!integer of value 1.  to be used in MatSetValues and VecSet. Directly using 
+!the value 1 in the functions crashes PETSc
+PetscScalar :: ZS_one=1
+!Scalars of values 1 and 0, same remark as above
+PetscScalar :: ZS_val
+!Temporary scalar used to store the results of MatGetValues()
+Vec :: ZV_one
+!vector with only ones, useful for creation of matrices here
+Vec :: ZV_SeqZero
+!Sequential vector of size IS_riv_bas, allows for gathering data on zeroth 
+!precessor before writing in file
+
+PetscScalar,dimension(:), allocatable :: ZV_read_riv_tot
+!temp vector that stores information from a 'read', before setting the value
+!in the object, this vector has the size of the total number of reaches
+PetscScalar,dimension(:), allocatable :: ZV_read_obs_tot
+!same as previous, with size IS_obs_tot
+PetscScalar,dimension(:), allocatable :: ZV_read_hum_tot
+!same as previous, with size IS_hum_tot
+PetscScalar,dimension(:), allocatable :: ZV_read_for_tot
+!same as previous, with size IS_for_tot
+PetscScalar,dimension(:), allocatable :: ZV_read_dam_tot
+!same as previous, with size IS_dam_tot
+PetscScalar :: ZS_time1, ZS_time2, ZS_time3
+!to estimate computing time
+
+PetscScalar, pointer :: ZV_pointer(:)
+!used to point to a PETSc vector and to output formatted as needed in a file
+character(len=10) :: temp_char,temp_char2
+!usefull to print variables on output.  write a variable in this character and
+!then use PetscPrintf
+
+PetscInt, dimension(:), allocatable :: IV_nz, IV_dnz, IV_onz
+!number of nonzero elements per row for network matrix.  nz for sequential, dnz 
+!and onz for distributed matrix (diagonal and off-diagonal elements)
+PetscInt :: IS_ownfirst, IS_ownlast
+!Ownership of each processor
+
+
+!*******************************************************************************
+!Declaration of variables - TAO specific objects and variables
+!*******************************************************************************
+#ifndef NO_TAO
+TaoSolver :: tao
+!TAO solver object
+TaoSolverTerminationReason :: reason
+!TAO terminate reason object
+Vec :: ZV_1stIndex, ZV_2ndIndex
+!ZV_1stIndex=[1;0], ZV_2ndIndex=[0,1].  Used with VecDot to extract first and 
+!second indexes of the vector of parameter
+#endif
+
+
+!*******************************************************************************
+!Declaration of variables - netCDF variables
+!*******************************************************************************
+PetscInt :: IS_nc_status
+PetscInt :: IS_nc_id_fil_Vlat,IS_nc_id_fil_Qout
+PetscInt :: IS_nc_id_var_Vlat,IS_nc_id_var_Qout,IS_nc_id_var_comid
+PetscInt :: IS_nc_id_dim_comid,IS_nc_id_dim_time
+PetscInt, parameter :: IS_nc_ndim=2
+PetscInt, dimension(IS_nc_ndim) :: IV_nc_id_dim, IV_nc_start, IV_nc_count,     &
+                                   IV_nc_count2
+
+
+!*******************************************************************************
+!Namelist
+!*******************************************************************************
+namelist /NL_namelist/                                                         &
+                       BS_opt_Qinit,BS_opt_Qfinal,                             &
+                       BS_opt_hum,BS_opt_for,BS_opt_dam,BS_opt_influence,      &
+                       IS_opt_routing,IS_opt_run,IS_opt_phi,                   &
+                       IS_riv_tot,rapid_connect_file,Vlat_file,IS_max_up,      &
+                       iS_riv_bas,riv_bas_id_file,                             &
+                       Qinit_file,Qfinal_file,                                 &
+                       Qhum_file,                                              &
+                       IS_hum_tot,hum_tot_id_file,                             &
+                       IS_hum_use,hum_use_id_file,                             &
+                       IS_for_tot,for_tot_id_file,                             &
+                       Qfor_file,                                              &
+                       IS_for_use,for_use_id_file,                             &
+                       IS_dam_tot,dam_tot_id_file,                             &
+                       IS_dam_use,dam_use_id_file,                             &
+                       babsmax_file,QoutRabsmin_file,QoutRabsmax_file,         &
+                       k_file,x_file,Qout_file,                                &
+                       kfac_file,xfac_file,ZS_knorm_init,ZS_xnorm_init,        &
+                       IS_obs_tot,obs_tot_id_file,IS_obs_use,obs_use_id_file,  &
+                       Qobs_file,Qobsbarrec_file,                              &
+                       ZS_TauM,ZS_dtM,ZS_TauO,ZS_dtO,ZS_TauR,ZS_dtR,           &
+                       ZS_dtF,ZS_dtH,                                          &
+                       ZS_phifac,IS_strt_opt
+ 
+character(len=120) :: namelist_file
+!unit 88 - Namelist
+
+
+end module rapid_var
diff --git a/wrfv2_fire/hydro/Rapid_routing/rapid_write_Qout_file.F90 b/wrfv2_fire/hydro/Rapid_routing/rapid_write_Qout_file.F90
new file mode 100644
index 00000000..4f0a457e
--- /dev/null
+++ b/wrfv2_fire/hydro/Rapid_routing/rapid_write_Qout_file.F90
@@ -0,0 +1,82 @@
+!*******************************************************************************
+!Subroutine - rapid_write_Qout_file
+!*******************************************************************************
+subroutine rapid_write_Qout_file
+
+!Purpose:
+!Write into Qout_file from Fortran/netCDF.
+!Author: 
+!Cedric H. David, 2013-2015.
+
+
+!*******************************************************************************
+!Global variables
+!*******************************************************************************
+use netcdf
+use rapid_var, only :                                                          &
+                   rank,ierr,vecscat,ZV_SeqZero,ZV_pointer,                    &
+                   IS_nc_status,IS_nc_id_fil_Qout,IS_nc_id_var_Qout,           &
+                   IV_nc_start,IV_nc_count2,                                   &
+                   ZV_QoutbarR
+
+implicit none
+
+
+!*******************************************************************************
+!Includes
+!*******************************************************************************
+#include "finclude/petscsys.h"       
+!base PETSc routines
+#include "finclude/petscvec.h"  
+#include "finclude/petscvec.h90"
+!vectors, and vectors in Fortran90 
+#include "finclude/petscmat.h"    
+!matrices
+#include "finclude/petscksp.h"    
+!Krylov subspace methods
+#include "finclude/petscpc.h"     
+!preconditioners
+#include "finclude/petscviewer.h"
+!viewers (allows writing results in file for example)
+#include "finclude/petsclog.h" 
+!PETSc log
+
+
+!*******************************************************************************
+!Intent (in/out), and local variables 
+!*******************************************************************************
+
+
+!*******************************************************************************
+!Gather PETSc vector on processor zero
+!*******************************************************************************
+call VecScatterBegin(vecscat,ZV_QoutbarR,ZV_SeqZero,                           &
+                     INSERT_VALUES,SCATTER_FORWARD,ierr)
+call VecScatterEnd(vecscat,ZV_QoutbarR,ZV_SeqZero,                             &
+                        INSERT_VALUES,SCATTER_FORWARD,ierr)
+
+
+!*******************************************************************************
+!Get array from PETSc vector
+!*******************************************************************************
+if (rank==0) call VecGetArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+
+
+!*******************************************************************************
+!Write data
+!*******************************************************************************
+if (rank==0) IS_nc_status=NF90_PUT_VAR(IS_nc_id_fil_Qout,IS_nc_id_var_Qout,    &
+                                       ZV_pointer,IV_nc_start,IV_nc_count2)
+
+
+!*******************************************************************************
+!Restore array to PETSc vector
+!*******************************************************************************
+if (rank==0) call VecRestoreArrayF90(ZV_SeqZero,ZV_pointer,ierr)
+
+
+!*******************************************************************************
+!End 
+!*******************************************************************************
+
+end subroutine rapid_write_Qout_file
diff --git a/wrfv2_fire/hydro/Routing/Makefile b/wrfv2_fire/hydro/Routing/Makefile
new file mode 100644
index 00000000..b20304ef
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/Makefile
@@ -0,0 +1,99 @@
+# Makefile 
+#
+.SUFFIXES:
+.SUFFIXES: .o .F
+
+include ../macros
+
+OBJS = \
+	module_date_utilities_rt.o \
+	module_UDMAP.o \
+	module_HYDRO_utils.o \
+	module_noah_chan_param_init_rt.o \
+	module_GW_baseflow.o \
+	module_gw_gw2d.o \
+	module_HYDRO_io.o \
+ 	module_RT.o \
+	Noah_distr_routing.o \
+	module_channel_routing.o \
+	module_lsm_forcing.o \
+	module_date_utilities_rt.o
+
+all:	$(OBJS)
+
+#module_RT.o: module_RT.F
+#	@echo ""
+#	$(CPP) $(CPPFLAGS) $(*).F > $(*).f
+#	$(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG)  $(*).f
+#	$(RMD) $(*).f
+#	@echo ""
+#	cp *.mod ../mod
+
+.F.o:
+	@echo "Routing Makefile:"
+	$(CPP) $(CPPFLAGS) -I$(NETCDFINC) $(*).F > $(*).f
+#	$(COMPILER90) -o $(@) $(F90FLAGS) $(MODFLAG) $(*).f
+	$(COMPILER90) -o $(@) $(F90FLAGS) $(LDFLAGS) $(MODFLAG) -I$(NETCDFINC) $(*).f
+#	$(RMD) $(*).f
+	@echo ""
+	ar -r ../lib/libHYDRO.a $(@)
+	cp *.mod ../mod
+
+#
+# Dependencies:
+#
+module_gw_gw2d.o: ../Data_Rec/module_gw_gw2d_data.o module_HYDRO_io.o
+
+ifneq ($(WRF_HYDRO_NUDGING),-DWRF_HYDRO_NUDGING)
+module_HYDRO_io.o:  module_HYDRO_utils.o \
+	            module_date_utilities_rt.o \
+                    ../Data_Rec/module_namelist.o \
+	 	    ../Data_Rec/module_RT_data.o 
+else 
+module_HYDRO_io.o:  module_HYDRO_utils.o \
+	            module_date_utilities_rt.o \
+		    ../nudging/module_date_utils_nudging.o \
+	            ../nudging/module_nudging_io.o \
+                    ../Data_Rec/module_namelist.o \
+	 	    ../Data_Rec/module_RT_data.o 
+endif
+
+module_HYDRO_utils.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o
+
+module_lsm_forcing.o: module_HYDRO_io.o 
+
+ifneq ($(WRF_HYDRO_NUDGING),-DWRF_HYDRO_NUDGING)
+module_RT.o: module_GW_baseflow.o \
+	     module_HYDRO_utils.o \
+             module_HYDRO_io.o \
+             module_noah_chan_param_init_rt.o \
+	     module_UDMAP.o \
+	     ../Data_Rec/module_namelist.o \
+	     ../Data_Rec/module_RT_data.o \
+	     ../Data_Rec/module_gw_gw2d_data.o
+else
+module_RT.o: module_GW_baseflow.o \
+	     module_HYDRO_utils.o \
+             module_HYDRO_io.o \
+             module_noah_chan_param_init_rt.o \
+	     module_UDMAP.o \
+	     ../Data_Rec/module_namelist.o \
+	     ../Data_Rec/module_RT_data.o \
+	     ../Data_Rec/module_gw_gw2d_data.o \
+             ../nudging/module_date_utils_nudging.o \
+             ../nudging/module_nudging_io.o
+endif
+
+module_UDMAP.o: ../Data_Rec/module_namelist.o ../Data_Rec/module_RT_data.o
+
+ifneq ($(WRF_HYDRO_NUDGING),-DWRF_HYDRO_NUDGING)
+module_channel_routing.o: module_UDMAP.o
+else
+module_channel_routing.o: module_UDMAP.o\
+			  ../nudging/module_date_utils_nudging.o \
+		          ../nudging/module_nudging_utils.o \
+          		  ../nudging/module_stream_nudging.o
+endif
+
+clean:	
+	rm -f *.o *.mod *.stb *~ *.f
diff --git a/wrfv2_fire/hydro/Routing/Noah_distr_routing.F b/wrfv2_fire/hydro/Routing/Noah_distr_routing.F
new file mode 100644
index 00000000..07f62414
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/Noah_distr_routing.F
@@ -0,0 +1,3007 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+!DJG ------------------------------------------------
+!DJG   SUBROUTINE RT_PARM
+!DJG ------------------------------------------------
+
+	SUBROUTINE RT_PARM(IX,JY,IXRT,JXRT,VEGTYP,RETDP,OVRGH,  &
+                      AGGFACTR)
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id,&
+               up_id,mpp_land_com_real,MPP_LAND_UB_COM, &
+               MPP_LAND_LR_COM,mpp_land_com_integer 
+#endif
+
+	IMPLICIT NONE
+
+!DJG -------- DECLARATIONS -----------------------
+ 
+	INTEGER, INTENT(IN) :: IX,JY,IXRT,JXRT,AGGFACTR
+
+	INTEGER, INTENT(IN), DIMENSION(IX,JY)	:: VEGTYP
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)	:: RETDP
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)	:: OVRGH
+
+
+!DJG Local Variables
+
+	INTEGER	:: I,J,IXXRT,JYYRT
+        INTEGER :: AGGFACYRT,AGGFACXRT
+
+
+!DJG Assign RETDP and OVRGH based on VEGTYP...
+
+	do J=1,JY
+          do I=1,IX
+
+             do AGGFACYRT=AGGFACTR-1,0,-1
+              do AGGFACXRT=AGGFACTR-1,0,-1
+
+               IXXRT=I*AGGFACTR-AGGFACXRT
+               JYYRT=J*AGGFACTR-AGGFACYRT
+#ifdef MPP_LAND
+       if(left_id.ge.0) IXXRT=IXXRT+1
+       if(down_id.ge.0) JYYRT=JYYRT+1
+#else
+!yw ????
+!       IXXRT=IXXRT+1
+!       JYYRT=JYYRT+1
+#endif
+
+!        if(AGGFACTR .eq. 1) then
+!            IXXRT=I
+!            JYYRT=J
+!        endif
+
+
+
+!DJG Urban, rock, playa, snow/ice...
+	       IF (VEGTYP(I,J).EQ.1.OR.VEGTYP(I,J).EQ.26.OR.   &
+                      VEGTYP(I,J).EQ.26.OR.VEGTYP(I,J).EQ.24) THEN
+                 RETDP(IXXRT,JYYRT)=1.3
+                 OVRGH(IXXRT,JYYRT)=0.1
+!DJG Wetlands and water bodies...
+	       ELSE IF (VEGTYP(I,J).EQ.17.OR.VEGTYP(I,J).EQ.18.OR.  &
+                      VEGTYP(I,J).EQ.19.OR.VEGTYP(I,J).EQ.16) THEN
+                 RETDP(IXXRT,JYYRT)=10.0
+                 OVRGH(IXXRT,JYYRT)=0.2
+!DJG All other natural covers...
+               ELSE 
+                 RETDP(IXXRT,JYYRT)=5.0
+                 OVRGH(IXXRT,JYYRT)=0.2
+               END IF
+
+              end do
+             end do
+
+          end do
+        end do
+#ifdef MPP_LAND
+        call MPP_LAND_COM_REAL(RETDP,IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(OVRGH,IXRT,JXRT,99)
+#endif
+
+!DJG ----------------------------------------------------------------
+  END SUBROUTINE RT_PARM
+!DJG ----------------------------------------------------------------
+
+
+
+
+
+!DJG ------------------------------------------------
+!DJG   SUBROUTINE SUBSFC_RTNG
+!DJG ------------------------------------------------
+
+	SUBROUTINE SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT,    &
+          SOYRT,LATKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT,      &    
+          NSOIL,SMCRT,INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT,    &
+          SMCWLTRT,SO8RT,SO8RT_D, rt_option,SLDPTH,junk4,CWATAVAIL, &
+          SATLYRCHK)
+
+!       use module_mpp_land, only: write_restart_rt_3, write_restart_rt_2, &
+!            my_id
+#ifdef MPP_LAND
+        use module_mpp_land, only: MPP_LAND_COM_REAL, sum_real1, &
+		my_id, io_id, numprocs
+#endif
+	IMPLICIT NONE
+
+!DJG -------- DECLARATIONS ------------------------
+
+	INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL
+
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: SOXRT,junk4
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: SOYRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: LATKSATRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: SOLDEPRT
+
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)   :: ZWATTABLRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)   :: CWATAVAIL
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: SATLYRCHK
+
+
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)   :: QSUBRT
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)   :: QSUBBDRYRT
+
+	REAL, INTENT(IN)                          :: dist(ixrt,jxrt,9)
+	REAL, INTENT(IN)                          :: DT
+	REAL, INTENT(IN), DIMENSION(NSOIL)        :: ZSOIL
+	REAL, INTENT(IN), DIMENSION(NSOIL) 	  :: SLDPTH
+	REAL, INTENT(INOUT)                       :: QSUBBDRYTRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: INFXSUBRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT
+
+	REAL, DIMENSION(IXRT,JXRT)	:: ywtmp
+!DJG Local Variables
+
+	INTEGER	:: I,J,KK
+!djg        INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK
+
+	REAL 	:: GRDAREA
+	REAL	:: SUBFLO
+	REAL	:: WATAVAIL
+
+        INTEGER :: SO8RT_D(IXRT,JXRT,3)
+        REAL :: SO8RT(IXRT,JXRT,8)
+        integer ::  rt_option, index
+
+        INTEGER :: DT_STEPS             !-- number of timestep in routing
+        REAL :: SUBDT                !-- subsurface routing timestep
+        INTEGER :: KRT                  !-- routing counter
+        REAL, DIMENSION(IXRT,JXRT,NSOIL) :: SMCTMP  !--temp store of SMC
+        REAL, DIMENSION(IXRT,JXRT) :: ZWATTABLRTTMP ! temp store of ZWAT
+        REAL, DIMENSION(IXRT,JXRT) :: INFXSUBRTTMP ! temp store of infilx
+!djg        REAL, DIMENSION(IXRT,JXRT) :: CWATAVAIL ! temp specif. of wat avial
+        
+        
+
+!DJG Debug Variables...
+        REAL :: qsubchk,qsubbdrytmp
+        REAL :: junk1,junk2,junk3,junk5,junk6,junk7
+        INTEGER, PARAMETER :: double=8
+        REAL (KIND=double) :: smctot1a,smctot2a
+	INTEGER :: kx,count
+
+#ifdef HYDRO_D
+! ADCHANGE: Water balance variables
+       real   :: smctot1,smctot2
+       real   :: suminfxsrt1,suminfxsrt2
+       real   :: qbdry1,qbdry2
+       real   :: sumqsubrt1, sumqsubrt2
+#endif
+        
+!DJG -----------------------------------------------------------------
+!DJG  SUBSURFACE ROUTING LOOP
+!DJG    - SUBSURFACE ROUTING RUN ON NOAH TIMESTEP
+!DJG    - SUBSURFACE ROUITNG ONLY PERFORMED ON SATURATED LAYERS
+!DJG -----------------------------------------------------------------
+
+#ifdef HYDRO_D
+! ADCHANGE: START Initial water balance variables 
+! ALL VARS in MM
+       suminfxsrt1 = 0.
+       qbdry1 = 0.
+       smctot1 = 0.
+       sumqsubrt1 = 0.
+       do i=1,IXRT
+         do j=1,JXRT
+           suminfxsrt1 = suminfxsrt1 + INFXSUBRT(I,J) / float(IXRT*JXRT)
+           qbdry1 = qbdry1 + QSUBBDRYRT(I,J)/dist(i,j,9)*SUBDT*1000. / float(IXRT*JXRT)
+           sumqsubrt1 = sumqsubrt1 + QSUBRT(I,J)/dist(i,j,9)*SUBDT*1000. / float(IXRT*JXRT)
+           do kk=1,NSOIL
+               smctot1 = smctot1 + SMCRT(I,J,KK)*SLDPTH(KK)*1000. / float(IXRT*JXRT)
+           end do
+         end do
+       end do
+
+#ifdef MPP_LAND
+! not tested
+       CALL sum_real1(suminfxsrt1)
+       CALL sum_real1(qbdry1)
+       CALL sum_real1(sumqsubrt1)
+       CALL sum_real1(smctot1)
+       suminfxsrt1 = suminfxsrt1/float(numprocs)
+       qbdry1 = qbdry1/float(numprocs)
+       sumqsubrt1 = sumqsubrt1/float(numprocs)
+       smctot1 = smctot1/float(numprocs)
+#endif
+! END Initial water balance variables
+#endif
+
+
+        !yw GRDAREA=DXRT*DXRT
+        ! GRDAREA=dist(i,j,9)
+
+
+!DJG debug subsfc...
+         subflo = 0.0
+
+!DJG Set up mass balance checks...
+!         CWATAVAIL = 0.            !-- initialize subsurface watavail
+         SUBDT = DT                !-- initialize the routing timestep to DT
+
+
+!!!! Find saturated layer depth...
+! Loop through domain to determine sat. layers and assign wat tbl depth...
+!    and water available for subsfc routing (CWATAVAIL)...
+!
+!         CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, &
+!                             SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, &
+!                             CWATAVAIL,SLDPTH)
+         
+
+
+
+!DJG debug variable...
+
+!DJG Courant check temp variable setup...
+         ZWATTABLRTTMP = ZWATTABLRT !-- temporary storage of water table level
+
+
+
+
+!!!! Call subsurface routing subroutine...
+#ifdef HYDRO_D
+     print *, "calling subsurface routing subroutine...Opt. ",rt_option
+#endif
+
+
+     if(rt_option .eq. 1) then
+        CALL ROUTE_SUBSURFACE1(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT,  &   
+               LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT, &   
+               SO8RT,SO8RT_D,CWATAVAIL,SUBDT)
+     else 
+        CALL ROUTE_SUBSURFACE2(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT,      &
+               LATKSATRT,SOLDEPRT,IXRT,JXRT,QSUBBDRYRT,QSUBBDRYTRT,     &
+               CWATAVAIL,SUBDT)
+     end if
+
+#ifdef HYDRO_D
+     write(6,*) "finish calling ROUTE_SUBSURFACE ", rt_option
+#endif
+
+
+!!!! Update soil moisture fields with subsurface flow...
+
+!!!! Loop through subsurface routing domain...
+	DO I=1,IXRT
+          DO J=1,JXRT
+
+!!DJG Check for courant condition violation...put limit on qsub
+!!DJG QSUB HAS units of m^3/s SUBFLO has units of m
+          
+! ADCHANGE: Moved this constraint to the ROUTE_SUBSURFACE routines
+           !IF (CWATAVAIL(i,j).le.ABS(qsubrt(i,j))/dist(i,j,9)*SUBDT) THEN
+           !  QSUBRT(i,j) = -1.0*CWATAVAIL(i,j)
+           !  SUBFLO = QSUBRT(i,j)  !Units of qsubrt converted via CWATAVAIL
+           !ELSE
+             SUBFLO=QSUBRT(I,J)/dist(i,j,9)*SUBDT !Convert qsubrt from m^3/s to m
+           !END IF
+
+           WATAVAIL=0.  !Initialize to 0. for every cell...
+
+
+!!DJG Begin loop through soil profile to adjust soil water content
+!!DJG based on subsfc flow (SUBFLO)...
+
+            IF (SUBFLO.GT.0) THEN ! Increase soil moist for +SUBFLO (Inflow)
+
+! Loop through soil layers from bottom to top
+              DO KK=NSOIL,1,-1
+
+
+! Check for saturated layers
+                IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK)) THEN
+                  IF (SMCRT(I,J,KK).GT.SMCMAXRT(I,J,KK)) THEN
+                   print *, "FATAL ERROR: Subsfc acct. SMCMAX exceeded...", &
+                       SMCRT(I,J,KK), SMCMAXRT(I,J,KK),KK,i,j
+                   call hydro_stop("In SUBSFC_RTNG() - SMCMAX exceeded")
+                  ELSE
+                  END IF
+                ELSE
+                  WATAVAIL = (SMCMAXRT(I,J,KK)-SMCRT(I,J,KK))*SLDPTH(KK)
+                  IF (WATAVAIL.GE.SUBFLO) THEN
+                    SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK)
+                    SUBFLO = 0.
+                  ELSE
+                    SUBFLO = SUBFLO - WATAVAIL
+                    SMCRT(I,J,KK) = SMCMAXRT(I,J,KK)
+                  END IF
+                END IF
+
+                 IF (SUBFLO.EQ.0.) EXIT
+!                IF (SUBFLO.EQ.0.) goto 669
+
+              END DO      ! END DO FOR SOIL LAYERS
+
+669           continue
+
+! If all layers sat. add remaining subflo to infilt. excess...                  
+              IF (KK.eq.0.AND.SUBFLO.gt.0.) then
+                 INFXSUBRT(I,J) = INFXSUBRT(I,J) + SUBFLO*1000.    !Units = mm
+                 SUBFLO=0.
+              END IF
+
+!DJG Error trap...
+	       if (subflo.ne.0.) then
+#ifdef HYDRO_D
+                  print *, "Subflo (+) not expired...:",subflo,i,j,kk,SMCRT(i,j,1), &
+                           SMCRT(i,j,2),SMCRT(i,j,3),SMCRT(i,j,4),SMCRT(i,j,5),  &
+                           SMCRT(i,j,6),SMCRT(i,j,7),SMCRT(i,j,8),"SMCMAX",SMCMAXRT(i,j,1)
+#endif
+               end if
+
+ 
+            ELSE IF (SUBFLO.LT.0) THEN    ! Decrease soil moist for -SUBFLO (Drainage)
+
+
+!DJG loop from satlyr back down and subtract out subflo as necess...
+!    now set to SMCREF, 8/24/07
+!DJG and then using unsat cond as opposed to Ksat...
+
+	      DO KK=SATLYRCHK(I,J),NSOIL
+                 WATAVAIL = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK)
+                 IF (WATAVAIL.GE.ABS(SUBFLO)) THEN
+!?yw mod                 IF (WATAVAIL.GE.(ABS(SUBFLO)+0.000001) ) THEN
+                   SMCRT(I,J,KK) = SMCRT(I,J,KK) + SUBFLO/SLDPTH(KK)
+                   SUBFLO=0.
+                 ELSE     ! Since subflo is small on a time-step following is unlikely...
+                   SMCRT(I,J,KK)=SMCREFRT(I,J,KK)
+                   SUBFLO=SUBFLO+WATAVAIL
+                 END IF
+                 IF (SUBFLO.EQ.0.) EXIT
+!                IF (SUBFLO.EQ.0.) goto 668
+
+              END DO  ! END DO FOR SOIL LAYERS
+668        continue
+
+
+!DJG Error trap...
+              if(abs(subflo) .le. 1.E-7 )  subflo = 0.0  !truncate residual to 1E-7 prec.
+
+	       if (subflo.ne.0.) then
+#ifdef HYDRO_D
+                  print *, "Subflo (-) not expired:",i,j,subflo,CWATAVAIL(i,j)
+                  print *, "zwatabl = ", ZWATTABLRT(I,J)
+                  print *, "QSUBRT(I,J)=",QSUBRT(I,J)
+                  print *, "WATAVAIL = ",WATAVAIL, "kk=",kk
+                  print *
+#endif
+               end if
+
+
+
+            END IF  ! end if for +/- SUBFLO soil moisture accounting...
+
+
+
+
+          END DO        ! END DO X dim
+        END DO          ! END DO Y dim
+!!!! End loop through subsurface routing domain...
+
+#ifdef MPP_LAND
+     do i = 1, NSOIL
+        call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99)
+     end DO
+#endif
+
+#ifdef HYDRO_D
+! ADCHANGE: START Final water balance variables
+! ALL VARS in MM
+        suminfxsrt2 = 0.
+        qbdry2 = 0.
+        smctot2 = 0.
+        sumqsubrt2 = 0.
+        do i=1,IXRT
+         do j=1,JXRT
+            suminfxsrt2 = suminfxsrt2 + INFXSUBRT(I,J) / float(IXRT*JXRT)
+            qbdry2 = qbdry2 + QSUBBDRYRT(I,J)/dist(i,j,9)*SUBDT*1000. / float(IXRT*JXRT)
+            sumqsubrt2 = sumqsubrt2 + QSUBRT(I,J)/dist(i,j,9)*SUBDT*1000. / float(IXRT*JXRT)
+            do kk=1,NSOIL
+                smctot2 = smctot2 + SMCRT(I,J,KK)*SLDPTH(KK)*1000. / float(IXRT*JXRT)
+            end do
+         end do
+        end do
+
+#ifdef MPP_LAND
+! not tested
+        CALL sum_real1(suminfxsrt2)
+        CALL sum_real1(qbdry2)
+        CALL sum_real1(sumqsubrt2)
+        CALL sum_real1(smctot2)
+        suminfxsrt2 = suminfxsrt2/float(numprocs)
+        qbdry2 = qbdry2/float(numprocs)
+        sumqsubrt2 = sumqsubrt2/float(numprocs)
+        smctot2 = smctot2/float(numprocs)
+#endif
+
+#ifdef MPP_LAND   
+       if (my_id .eq. IO_id) then
+#endif
+       print *, "SUBSFC Routing Mass Bal: "
+       print *, "WB_SUB!QsubDiff", sumqsubrt2-sumqsubrt1
+       print *, "WB_SUB!Qsub1", sumqsubrt1
+       print *, "WB_SUB!Qsub2", sumqsubrt2
+       print *, "WB_SUB!InfxsDiff", suminfxsrt2-suminfxsrt1
+       print *, "WB_SUB!Infxs1", suminfxsrt1
+       print *, "WB_SUB!Infxs2", suminfxsrt2
+       print *, "WB_SUB!QbdryDiff", qbdry2-qbdry1
+       print *, "WB_SUB!Qbdry1", qbdry1
+       print *, "WB_SUB!Qbdry2", qbdry2
+       print *, "WB_SUB!SMCDiff", smctot2-smctot1
+       print *, "WB_SUB!SMC1", smctot1
+       print *, "WB_SUB!SMC2", smctot2
+       print *, "WB_SUB!Residual", sumqsubrt1 - ( (suminfxsrt2-suminfxsrt1) &
+                       + (smctot2-smctot1) )
+#ifdef MPP_LAND
+       endif
+#endif
+! END Final water balance variables
+#endif
+
+
+!DJG ----------------------------------------------------------------
+  END SUBROUTINE SUBSFC_RTNG 
+!DJG ----------------------------------------------------------------
+
+
+!DJG ------------------------------------------------------------------------
+!DJG  SUBSURFACE FINDZWAT
+!DJG ------------------------------------------------------------------------
+         SUBROUTINE FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, &
+                             SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT,CWATAVAIL,&
+                             SLDPTH)
+
+	IMPLICIT NONE
+
+!DJG -------- DECLARATIONS ------------------------
+
+	INTEGER, INTENT(IN) :: IXRT,JXRT,NSOIL
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCMAXRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCREFRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT,NSOIL) :: SMCWLTRT
+	REAL, INTENT(IN), DIMENSION(NSOIL)        :: ZSOIL
+	REAL, INTENT(IN), DIMENSION(NSOIL)        :: SLDPTH
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)   :: ZWATTABLRT
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)   :: CWATAVAIL
+        INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SATLYRCHK
+       
+!DJG Local Variables
+        INTEGER :: KK,i,j
+
+
+!!!! Find saturated layer depth...
+! Loop through domain to determine sat. layers and assign wat tbl depth...
+
+
+        SATLYRCHK = 0  !set flag for sat. layers
+        CWATAVAIL = 0.  !set wat avail for subsfc rtng = 0.
+
+        DO J=1,JXRT
+          DO I=1,IXRT
+
+! Loop through soil layers from bottom to top
+              DO KK=NSOIL,1,-1
+
+! Check for saturated layers
+! Add additional logical check to ensure water is 'available' for routing,
+!  (i.e. not 'frozen' or otherwise immobile)
+!                IF (SMCRT(I,J,KK).GE.SMCMAXRT(I,J,KK).AND.SMCMAXRT(I,J,KK) &
+!                  .GT.SMCWLTRT(I,J,KK)) THEN
+                IF ( (SMCRT(I,J,KK).GE.SMCREFRT(I,J,KK)).AND.(SMCREFRT(I,J,KK) &
+                  .GT.SMCWLTRT(I,J,KK)) ) THEN
+! Add additional check to ensure saturation from bottom up only...8/8/05
+                  IF((SATLYRCHK(I,J).EQ.KK+1) .OR. (KK.EQ.NSOIL) ) SATLYRCHK(I,J) = KK
+                END IF
+
+              END DO
+
+
+! Designate ZWATTABLRT based on highest sat. layer and
+! Define amount of water avail for subsfc routing on each gridcell (CWATAVAIL)
+!  note: using a 'field capacity' value of SMCREF as lower limit...
+
+              IF (SATLYRCHK(I,J).ne.0) then
+                IF (SATLYRCHK(I,J).ne.1) then  ! soil column is partially sat.
+                  ZWATTABLRT(I,J) = -ZSOIL(SATLYRCHK(I,J)-1)
+!DJG 2/16/2016 fix                  DO KK=SATLYRCHK(I,J),NSOIL
+!old                   CWATAVAIL(I,J) = (SMCRT(I,J,SATLYRCHK(I,J))-&
+!old                                    SMCREFRT(I,J,SATLYRCHK(I,J))) * &
+!old                                    (ZSOIL(SATLYRCHK(I,J)-1)-ZSOIL(NSOIL))
+!DJG 2/16/2016 fix                    CWATAVAIL(I,J) = CWATAVAIL(I,J)+(SMCRT(I,J,KK)- &
+!DJG 2/16/2016 fix                                     SMCREFRT(I,J,KK))*SLDPTH(KK)
+!DJG 2/16/2016 fix                  END DO
+
+
+                ELSE  ! soil column is fully saturated to sfc.
+                  ZWATTABLRT(I,J) = 0.
+!DJG 2/16/2016 fix                  DO KK=SATLYRCHK(I,J),NSOIL
+!DJG 2/16/2016 fix                    CWATAVAIL(I,J) = (SMCRT(I,J,KK)-SMCREFRT(I,J,KK))*SLDPTH(KK)
+!DJG 2/16/2016 fix                  END DO
+                END IF
+!DJG 2/16/2016 fix accumulation of CWATAVAIL...
+                  DO KK=SATLYRCHK(I,J),NSOIL
+                    CWATAVAIL(I,J) = CWATAVAIL(I,J)+(SMCRT(I,J,KK)- &
+                                     SMCREFRT(I,J,KK))*SLDPTH(KK)
+                  END DO
+              ELSE  ! no saturated layers...
+                ZWATTABLRT(I,J) = -ZSOIL(NSOIL)
+                SATLYRCHK(I,J) = NSOIL + 1
+              END IF
+
+
+	   END DO
+         END DO
+
+
+!DJG ----------------------------------------------------------------
+  END SUBROUTINE FINDZWAT 
+!DJG ----------------------------------------------------------------
+
+
+!DJG ----------------------------------------------------------------
+!DJG ----------------------------------------------------------------
+!DJG     SUBROUTINE ROUTE_SUBSURFACE2
+!DJG ----------------------------------------------------------------
+
+          SUBROUTINE ROUTE_SUBSURFACE2(                                 &
+                dist,z,qsub,sox,soy,                                   &
+                latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,CWATAVAIL,   &
+                SUBDT)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!  Subroutine to route subsurface flow through the watershed
+!DJG ----------------------------------------------------------------
+!
+!  Called from: main.f (Noah_router_driver)
+!
+!  Returns: qsub=DQSUB   which in turn becomes SUBFLO in head calc.
+!
+!  Created:    D. Gochis                           3/27/03
+!              Adaptded from Wigmosta, 1994
+!
+!  Modified:   D. Gochis                           1/05/04
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id,&
+               up_id,mpp_land_com_real,MPP_LAND_UB_COM, &
+               MPP_LAND_LR_COM,mpp_land_com_integer
+#endif
+
+        IMPLICIT NONE
+
+
+!! Declare Passed variables
+
+        INTEGER, INTENT(IN) :: XX,YY
+
+!! Declare passed arrays
+
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: z
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: sox
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soy
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep
+        REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY
+        REAL, INTENT(INOUT) :: QSUBDRYT
+        REAL, INTENT(IN) :: SUBDT
+        real, intent(in), dimension(xx,yy,9) :: dist 
+
+!!! Declare Local Variables
+
+        REAL :: dzdx,dzdy,beta,gamma
+        REAL :: qqsub,hh,ksat, gsize
+
+        INTEGER :: i,j
+!!! Initialize variables
+        REAL, PARAMETER :: nexp=1.0      ! local power law exponent
+        qsub = 0.                        ! initialize flux = 0. !DJG 5 May 2014
+
+!yw        soldep = 2.
+        
+
+! Begin Subsurface routing
+
+!!! Loop to route water in x-direction
+        do j=1,YY
+          do i=1,XX
+! check for boundary grid point?
+          if (i.eq.XX) GOTO 998
+          gsize = dist(i,j,3)
+
+          dzdx= (z(i,j) - z(i+1,j))/gsize
+          beta=sox(i,j) + dzdx + 1E-30
+          if (abs(beta) .lt. 1E-20) beta=1E-20
+          if (beta.lt.0) then
+!yw            hh=(1-(z(i+1,j)/soldep(i,j)))**nexp
+            hh=(1-(z(i+1,j)/soldep(i+1,j)))**nexp
+! Change later to use mean Ksat of two cells
+            ksat=latksat(i+1,j)
+          else
+            hh=(1-(z(i,j)/soldep(i,j)))**nexp
+            ksat=latksat(i,j)
+          end if
+
+          if (hh .lt. 0.) then
+            print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), &
+                      soldep(i,j),nexp
+            call hydro_stop("In ROUTE_SUBSURFACE2() - hsub<0 at gridcell")
+          end if
+
+!Err. tan slope          gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta)
+!AD_CHANGE: beta is already a slope so no tan (consistent with ROUTE_SUBSURFACE1) 
+          gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta
+!DJG lacks tan(beta) of original Wigmosta version          gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta
+
+          qqsub = gamma * hh
+          qsub(i,j) = qsub(i,j) + qqsub
+          qsub(i+1,j) = qsub(i+1,j) - qqsub
+
+! Boundary adjustments
+#ifdef MPP_LAND
+          if ((i.eq.1).AND.(beta.lt.0.).and.(left_id.lt.0)) then
+#else
+          if ((i.eq.1).AND.(beta.lt.0.)) then
+#endif
+            qsub(i,j) = qsub(i,j) - qqsub
+            QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub
+            QSUBDRYT = QSUBDRYT - qqsub
+#ifdef MPP_LAND
+          else if ((i.eq.(xx-1)).AND.(beta.gt.0.) &
+              .and.(right_id.lt.0) ) then
+#else
+          else if ((i.eq.(xx-1)).AND.(beta.gt.0.)) then
+#endif
+            qsub(i+1,j) = qsub(i+1,j) + qqsub
+            QSUBDRY(i+1,j) = QSUBDRY(i+1,j) + qqsub
+            QSUBDRYT = QSUBDRYT + qqsub
+          end if
+
+998       continue
+
+!! End loop to route sfc water in x-direction
+          end do
+        end do
+
+#ifdef MPP_LAND
+       call MPP_LAND_LR_COM(qsub,XX,YY,99)
+       call MPP_LAND_LR_COM(QSUBDRY,XX,YY,99)
+#endif
+
+
+!!! Loop to route water in y-direction
+        do j=1,YY
+          do i=1,XX
+! check for boundary grid point?
+          if (j.eq.YY) GOTO 999
+          gsize = dist(i,j,1)
+
+          dzdy= (z(i,j) - z(i,j+1))/gsize
+          beta=soy(i,j) + dzdy + 1E-30
+          if (abs(beta) .lt. 1E-20) beta=1E-20
+          if (beta.lt.0) then
+!yw            hh=(1-(z(i,j+1)/soldep(i,j)))**nexp
+            hh=(1-(z(i,j+1)/soldep(i,j+1)))**nexp
+            ksat=latksat(i,j+1)
+          else
+            hh=(1-(z(i,j)/soldep(i,j)))**nexp
+            ksat=latksat(i,j)
+          end if
+
+          if (hh .lt. 0.) GOTO 999
+
+!Err. tan slope          gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*tan(beta)
+          gamma=-1.*((gsize*ksat*soldep(i,j))/nexp)*beta
+
+          qqsub = gamma * hh
+          qsub(i,j) = qsub(i,j) + qqsub
+          qsub(i,j+1) = qsub(i,j+1) - qqsub
+
+! Boundary adjustments
+
+#ifdef MPP_LAND
+          if ((j.eq.1).AND.(beta.lt.0.).and.(down_id.lt.0)) then
+#else
+          if ((j.eq.1).AND.(beta.lt.0.)) then
+#endif
+            qsub(i,j) = qsub(i,j) - qqsub
+            QSUBDRY(i,j) = QSUBDRY(i,j) - qqsub
+            QSUBDRYT = QSUBDRYT - qqsub
+#ifdef MPP_LAND
+          else if ((j.eq.(yy-1)).AND.(beta.gt.0.)  &
+                .and. (up_id.lt.0) ) then
+#else
+          else if ((j.eq.(yy-1)).AND.(beta.gt.0.)) then
+#endif
+            qsub(i,j+1) = qsub(i,j+1) + qqsub
+            QSUBDRY(i,j+1) = QSUBDRY(i,j+1) + qqsub
+            QSUBDRYT = QSUBDRYT + qqsub
+          end if
+
+999       continue
+
+!! End loop to route sfc water in y-direction
+          end do
+        end do
+
+#ifdef MPP_LAND
+       call MPP_LAND_UB_COM(qsub,XX,YY,99)
+       call MPP_LAND_UB_COM(QSUBDRY,XX,YY,99)
+#endif
+
+        return
+!DJG------------------------------------------------------------
+        end subroutine ROUTE_SUBSURFACE2
+!DJG------------------------------------------------------------
+
+
+
+!DJG ------------------------------------------------
+!DJG   SUBROUTINE OV_RTNG
+!DJG ------------------------------------------------
+
+	SUBROUTINE OV_RTNG(DT,DTRT_TER,IXRT,JXRT,INFXSUBRT,      &
+          SFCHEADSUBRT,DHRT,CH_NETRT,RETDEPRT,OVROUGHRT,      &
+          QSTRMVOLRT,QBDRYRT,QSTRMVOLTRT,QBDRYTRT,SOXRT,     &
+          SOYRT,dist,LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT,  &
+          SO8RT,SO8RT_D,rt_option,q_sfcflx_x,q_sfcflx_y)
+
+!yyww 
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id, &
+              up_id,mpp_land_com_real, my_id, &
+             mpp_land_sync
+#endif
+
+	IMPLICIT NONE
+
+!DJG --------DECLARATIONS----------------------------
+
+	INTEGER, INTENT(IN)			:: IXRT,JXRT
+	REAL, INTENT(IN)			:: DT,DTRT_TER
+
+	INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT
+	INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)	:: INFXSUBRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)	:: SOXRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)	:: SOYRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist 
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)	:: RETDEPRT
+	REAL, INTENT(IN), DIMENSION(IXRT,JXRT)	:: OVROUGHRT
+
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)	:: SFCHEADSUBRT
+	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)	:: DHRT
+
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_INFLORT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QBDRYRT
+	REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: q_sfcflx_x,q_sfcflx_y
+	REAL, INTENT(INOUT)     :: QSTRMVOLTRT,QBDRYTRT,LAKE_INFLOTRT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8)  :: SO8RT
+
+!DJG Local Variables
+
+	INTEGER :: KRT,I,J,ct
+
+	REAL, DIMENSION(IXRT,JXRT)	:: INFXS_FRAC
+	REAL	:: DT_FRAC,SUM_INFXS,sum_head
+        INTEGER SO8RT_D(IXRT,JXRT,3), rt_option
+	
+	
+
+
+!DJG ----------------------------------------------------------------------
+! DJG BEGIN 1-D or 2-D OVERLAND FLOW ROUTING LOOP
+!DJG ---------------------------------------------------------------------
+!DJG  Loop over 'routing time step'
+!DJG  Compute the number of time steps based on NOAH DT and routing DTRT_TER
+
+       DT_FRAC=INT(DT/DTRT_TER)
+
+#ifdef HYDRO_D
+       write(6,*) "OV_RTNG  DT_FRAC, DT, DTRT_TER",DT_FRAC, DT, DTRT_TER
+       write(6,*) "IXRT, JXRT = ",ixrt,jxrt
+#endif
+
+!DJG NOTE: Applying all infiltration excess water at once then routing
+!DJG       Pre-existing SFHEAD gets combined with Precip. in the
+!DJG       calculation of INFXS1 during subroutine SRT.f.
+!DJG debug
+
+
+!DJG Assign all infiltration excess to surface head...
+            SFCHEADSUBRT=INFXSUBRT
+
+!DJG Divide infiltration excess over all routing time-steps
+!	     INFXS_FRAC=INFXSUBRT/(DT/DTRT_TER)
+
+!DJG Set flux accumulation fields to 0. before each loop...
+      q_sfcflx_x = 0.
+      q_sfcflx_y = 0.
+      ct =0
+
+
+!DJG Execute routing time-step loop...
+
+
+      DO KRT=1,DT_FRAC
+
+        DO J=1,JXRT
+          DO I=1,IXRT
+
+!DJG Removed 4_29_05, sfhead now updated in route_overland subroutine...
+!           SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J)
+!!           SFCHEADSUBRT(I,J)=SFCHEADSUBRT(I,J)+DHRT(I,J)+INFXS_FRAC(I,J)
+!           DHRT(I,J)=0.
+
+!DJG ERROR Check...
+
+	   IF (SFCHEADSUBRT(I,J).lt.0.) THEN 
+#ifdef HYDRO_D
+		print *, "ywcheck 2 ERROR!!!: Neg. Surface Head Value at (i,j):",    &
+                    i,j,SFCHEADSUBRT(I,J)
+                print *, "RETDEPRT(I,J) = ",RETDEPRT(I,J), "KRT=",KRT
+                print *, "INFXSUBRT(i,j)=",INFXSUBRT(i,j)
+                print *, "jxrt=",jxrt," ixrt=",ixrt
+#endif
+           END IF
+
+!DJG Remove surface water from channel cells
+!DJG Channel inflo cells specified as nonzeros from CH_NET
+!DJG 9/16/04  Channel Extractions Removed until stream model implemented...
+
+
+
+!yw            IF (CH_NETRT(I,J).ne.-9999) THEN
+           IF (CH_NETRT(I,J).ge.0) THEN
+             ct = ct +1
+
+!DJG Temporary test to up the retention depth of channel grid cells to 'soak' 
+!more water into valleys....set retdep = retdep*100 (=5 mm)
+
+!	     RETDEPRT(I,J) = RETDEPRT(I,J) * 100.0    !DJG TEMP HARDWIRE!!!!
+!	     RETDEPRT(I,J) = 10.0    !DJG TEMP HARDWIRE!!!!
+
+             IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN
+!!               QINFLO(CH_NET(I,J)=QINFLO(CH_NET(I,J)+SFCHEAD(I,J) - RETDEPRT(I,J)
+               QSTRMVOLTRT = QSTRMVOLTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J))
+               QSTRMVOLRT(I,J) = QSTRMVOLRT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J)
+
+             ! if(QSTRMVOLRT(I,J) .gt. 0) then 
+             !     print *, "QSTRVOL GT 0", QSTRMVOLRT(I,J),I,J 
+             !  endif
+
+               SFCHEADSUBRT(I,J) = RETDEPRT(I,J)
+             END IF
+           END IF
+
+!DJG Lake inflow withdrawl from surface head...(4/29/05)
+           
+
+           IF (LAKE_MSKRT(I,J).gt.0) THEN
+             IF (SFCHEADSUBRT(I,J).GT.RETDEPRT(I,J)) THEN
+               LAKE_INFLOTRT = LAKE_INFLOTRT + (SFCHEADSUBRT(I,J) - RETDEPRT(I,J))
+               LAKE_INFLORT(I,J) = LAKE_INFLORT(I,J)+SFCHEADSUBRT(I,J)-RETDEPRT(I,J)
+               SFCHEADSUBRT(I,J) = RETDEPRT(I,J)
+              
+             END IF
+           END IF
+
+
+
+         END DO
+        END DO
+
+!yw check         call MPP_LAND_COM_REAL(QSTRMVOLRT,IXRT,JXRT,99)
+!DJG----------------------------------------------------------------------
+!DJG CALL OVERLAND FLOW ROUTING SUBROUTINE
+!DJG----------------------------------------------------------------------
+
+!DJG Debug...
+
+
+           if(rt_option .eq. 1) then
+              CALL ROUTE_OVERLAND1(DTRT_TER,dist,SFCHEADSUBRT,DHRT,SOXRT,   &
+		SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT,    & 
+                SO8RT,SO8RT_D,q_sfcflx_x,q_sfcflx_y)
+            else
+              CALL ROUTE_OVERLAND2(DTRT_TER,dist,SFCHEADSUBRT,DHRT,SOXRT,   &
+                  SOYRT,RETDEPRT,OVROUGHRT,IXRT,JXRT,QBDRYRT,QBDRYTRT,  &
+                  q_sfcflx_x,q_sfcflx_y)    
+            end if
+             
+        END DO          ! END routing time steps
+
+#ifdef HYDRO_D
+ 	print *, "End of OV_routing call..."
+#endif
+
+!----------------------------------------------------------------------
+! END OVERLAND FLOW ROUTING LOOP
+!     CHANNEL ROUTING TO FOLLOW 
+!----------------------------------------------------------------------
+
+!DJG ----------------------------------------------------------------
+  END SUBROUTINE OV_RTNG 
+!DJG ----------------------------------------------------------------
+
+!DJG     SUBROUTINE ROUTE_OVERLAND1
+!DJG ----------------------------------------------------------------
+
+          SUBROUTINE ROUTE_OVERLAND1(dt,                                &
+     &          gsize,h,qsfc,sox,soy,                                   &
+     &     retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT,SO8RT,SO8RT_D,      &
+     &     q_sfcflx_x,q_sfcflx_y)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!  Subroutine to route excess rainfall over the watershed
+!     using a 2d diffusion routing scheme.
+!
+!  Called from: main.f
+!
+!      Will try to formulate this to be called from NOAH
+!
+!  Returns: qsfc=DQOV   which in turn becomes DH in head calc.
+!
+!  Created:  Adaptded from CASC2D source code
+!  NOTE: dh from original code has been replaced by qsfc
+!        dhh replaced by qqsfc
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id, &
+              up_id,mpp_land_com_real, my_id, mpp_land_com_real8,&
+             mpp_land_sync
+#endif
+
+        IMPLICIT NONE
+
+
+!! Declare Passed variables
+
+        INTEGER, INTENT(IN) :: XX,YY
+        REAL, INTENT(IN) :: dt, gsize(xx,yy,9)
+
+!! Declare passed arrays
+
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: qsfc
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: sox
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soy
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x, q_sfcflx_y
+        REAL, INTENT(INOUT) :: QBDRYT
+        REAL, INTENT(IN), DIMENSION(XX,YY,8) :: SO8RT
+        REAL*8, DIMENSION(XX,YY) :: QBDRY_tmp, DH
+        REAL*8, DIMENSION(XX,YY) :: DH_tmp
+
+!!! Declare Local Variables
+
+        REAL :: dhdx,dhdy,alfax,alfay
+        REAL :: hh53,qqsfc,hh,dt_new,hmax
+        REAL :: sfx,sfy
+        REAL :: tmp_adjust
+
+        INTEGER :: i,j
+        REAL IXX8,IYY8
+        INTEGER  IXX0,JYY0,index, SO8RT_D(XX,YY,3)
+        REAL  tmp_gsize,hsum
+
+!!! Initialize variables
+
+
+
+!!! Begin Routing of Excess Rainfall over the Watershed
+
+        DH=0.
+        DH_tmp=0.
+        QBDRY_tmp =0.
+
+!!! Loop to route water
+        do j=2,YY-1
+          do i=2,XX-1
+          if (h(I,J).GT.retent_dep(I,J)) then 
+             IXX0 = SO8RT_D(i,j,1)
+             JYY0 = SO8RT_D(i,j,2)
+             index = SO8RT_D(i,j,3)
+             tmp_gsize = 1.0/gsize(i,j,index)
+             sfx = so8RT(i,j,index)-(h(IXX0,JYY0)-h(i,j))*0.001*tmp_gsize
+             hmax = h(i,j)*0.001  !Specify max head for mass flux limit...
+             if(sfx .lt. 1E-20) then
+               call GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,so8rt,gsize(i,j,:),sfx,XX,YY)
+             end if
+             if(IXX0 > 0) then  ! do the rest if the lowest grid can be found.
+                 if(sfx .lt. 1E-20) then
+#ifdef HYDRO_D
+                      print*, "Message: sfx reset to 1E-20. sfx =",sfx
+                      print*, "i,j,index,IXX0,JYY0",i,j,index,IXX0,JYY0
+                      print*, "so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index) ", &
+                         so8RT(i,j,index), h(IXX0,JYY0), h(i,j), gsize(i,j,index)
+#endif
+                      sfx = 1E-20
+                 end if
+                 alfax = sqrt(sfx) / dist_rough(i,j) 
+                 hh=(h(i,j)-retent_dep(i,j)) * 0.001
+                 hh53=hh**(5./3.)
+
+! Calculate q-flux...
+                 qqsfc = alfax*hh53*dt * tmp_gsize
+
+!Courant check (simple mass limit on overland flow)...
+                 if (qqsfc.ge.(hmax*dt*tmp_gsize)) qqsfc = hmax*dt*tmp_gsize
+
+! Accumulate directional fluxes on routing subgrid...
+                 if (IXX0.gt.i) then
+                   q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc * &
+                         (1.0 - 0.5 * (ABS(j-JYY0)))
+                 else if (IXX0.lt.i) then
+                   q_sfcflx_x(I,J) = q_sfcflx_x(I,J) - 1.0 * &
+                         qqsfc * (1.0 - 0.5 * (ABS(j-JYY0)))
+                 else
+                   q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + 0.
+                 end if
+                 if (JYY0.gt.j) then
+                   q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc * &
+                          (1.0 - 0.5 * (ABS(i-IXX0)))
+                 elseif (JYY0.lt.j) then
+                   q_sfcflx_y(I,J) = q_sfcflx_y(I,J) - 1.0 * &
+                          qqsfc * (1.0 - 0.5 * (ABS(i-IXX0)))
+                 else
+                   q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + 0.
+                 end if
+
+
+!DJG put adjustment in for (h) due to qqsfc
+
+!yw changed as following:
+                 tmp_adjust=qqsfc*1000
+                 if((h(i,j) - tmp_adjust) <0 )  then
+#ifdef HYDRO_D
+                   print*, "Error Warning: surface head is negative:  ",i,j,ixx0,jyy0, &
+                       h(i,j) - tmp_adjust
+#endif
+                     tmp_adjust = h(i,j)
+                 end if
+ 	         DH(i,j) = DH(i,j)-tmp_adjust
+                 DH_tmp(ixx0,jyy0) = DH_tmp(ixx0,jyy0) + tmp_adjust
+      !yw end change
+                  
+      !DG Boundary adjustments here
+            !DG Constant Flux Condition
+#ifdef MPP_LAND
+      if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. &
+          ((ixx0.eq.1) .and.(left_id  .lt. 0)) .or. &
+          ((jyy0.eq.1) .and.(down_id  .lt. 0)) .or. &
+          ((JYY0.eq.YY).and.(up_id    .lt. 0)) ) then 
+!              QBDRY_tmp(IXX0,JYY0)=QBDRY_tmp(IXX0,JYY0) - qqsfc*1000.
+#else
+                if ((ixx0.eq.XX).or.(ixx0.eq.1).or.(jyy0.eq.1)   &
+                     .or.(JYY0.eq.YY )) then
+!                     QBDRY(IXX0,JYY0)=QBDRY(IXX0,JYY0) - qqsfc*1000.
+#endif
+                     QBDRY_tmp(IXX0,JYY0)=QBDRY_tmp(IXX0,JYY0) - qqsfc*1000.
+                     QBDRYT=QBDRYT - qqsfc
+                     DH_tmp(IXX0,JYY0)= DH_tmp(IXX0,JYY0)-tmp_adjust
+                end if
+             end if
+!! End loop to route sfc water 
+          end if
+          end do
+        end do
+
+#ifdef MPP_LAND
+! use double precision to solve the underflow problem.
+       call MPP_LAND_COM_REAL8(DH_tmp,XX,YY,1)
+       call MPP_LAND_COM_REAL8(QBDRY_tmp,XX,YY,1)
+#endif
+       QBDRY = QBDRY + QBDRY_tmp
+       DH = DH+DH_tmp 
+
+#ifdef MPP_LAND
+       call MPP_LAND_COM_REAL8(DH,XX,YY,99)
+       call MPP_LAND_COM_REAL(QBDRY,XX,YY,99)
+#endif
+
+        H = H + DH
+
+        return
+
+!DJG ----------------------------------------------------------------------
+        end subroutine ROUTE_OVERLAND1
+
+
+!DJG ----------------------------------------------------------------
+        SUBROUTINE GETMAX8DIR(IXX0,JYY0,I,J,H,RETENT_DEP,sox,tmp_gsize,max,XX,YY)
+          implicit none
+          INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY
+          INTEGER, INTENT(IN) :: I,J
+
+          REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY,8),tmp_gsize(9)
+          REAL  max
+          IXX0 = -1
+          max = 0
+          if (h(I,J).LE.retent_dep(I,J)) return
+
+          IXX8 = I
+          JYY8 = J+1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J+1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J-1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY)
+
+          IXX8 = I
+          JYY8 = J-1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J-1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J+1
+          call GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY)
+        RETURN
+        END SUBROUTINE GETMAX8DIR
+
+        SUBROUTINE GET8DIR(IXX8,JYY8,I,J,H,RETENT_DEP,sox   &
+            ,IXX0,JYY0,max,tmp_gsize,XX,YY)
+        implicit none
+        integer,INTENT(INOUT) ::IXX0,JYY0
+        INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY
+        REAL,INTENT(IN) :: H(XX,YY),RETENT_DEP(XX,YY),sox(XX,YY)
+        REAL, INTENT(INOUT) ::max
+        real, INTENT(IN) :: tmp_gsize
+        real :: sfx
+
+             sfx = sox(i,j)-(h(IXX8,JYY8)-h(i,j))*0.001/tmp_gsize
+             if(sfx .le. 0 ) return
+             if(max < sfx ) then
+                   IXX0 = IXX8
+                   JYY0 = JYY8
+                   max = sfx
+             end if
+
+        END SUBROUTINE GET8DIR
+!DJG ----------------------------------------------------------------
+!DJG     SUBROUTINE ROUTE_SUBSURFACE1
+!DJG ----------------------------------------------------------------
+
+          SUBROUTINE ROUTE_SUBSURFACE1(                                 &
+                dist,z,qsub,sox,soy,                                   &
+                latksat,soldep,XX,YY,QSUBDRY,QSUBDRYT,SO8RT,SO8RT_D,    &
+                CWATAVAIL,SUBDT)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!  Subroutine to route subsurface flow through the watershed
+!
+!  Called from: main.f (Noah_router_driver)
+!
+!  Returns: qsub=DQSUB   which in turn becomes SUBFLO in head calc.
+!
+!  Created:    D. Gochis                           3/27/03
+!              Adaptded from Wigmosta, 1994
+!
+!  Modified:   D. Gochis                           1/05/04
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id,&
+           up_id,mpp_land_com_real8,my_id,mpp_land_com_real
+#endif
+
+        IMPLICIT NONE
+
+
+!! Declare Passed variables
+
+        INTEGER, INTENT(IN) :: XX,YY
+
+!! Declare passed arrays
+
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: z
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: sox
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soy
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: latksat
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: CWATAVAIL
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soldep
+        REAL, INTENT(OUT), DIMENSION(XX,YY) :: qsub
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QSUBDRY
+        REAL, INTENT(INOUT) :: QSUBDRYT
+        REAL*8, DIMENSION(XX,YY) :: qsub_tmp,QSUBDRY_tmp
+!yw        INTEGER, INTENT(OUT) :: flag
+        REAL, INTENT(IN) :: dist(xx,yy,9),SUBDT
+
+!!! Declare Local Variables
+
+        REAL :: dzdx,dzdy,beta,gamma
+        REAL :: qqsub,hh,ksat
+
+        REAL :: SO8RT(XX,YY,8)
+        INTEGER :: SO8RT_D(XX,YY,3), rt_option
+        
+
+!!! Initialize variables
+
+        REAL, PARAMETER :: nexp=1.0      ! local power law exponent
+        integer IXX0,JYY0,index,i,j
+        real tmp_gsize
+
+!     temporary set it to be 2. Should be passed in.
+!yw        soldep = 2.
+! Begin Subsurface routing
+
+
+
+!!! Loop to route water in x-direction
+        qsub_tmp = 0.
+        QSUBDRY_tmp = 0.
+
+#ifdef HYDRO_D
+        write(6,*) "call subsurface routing xx= , yy =", yy, xx
+#endif
+
+        do j=2,YY-1
+          do i=2,XX-1
+
+
+        if(i.ge.2.AND.i.le.XX-1.AND.j.ge.2.AND.j.le.YY-1) then !if grdcl chk
+! check for boundary grid point?
+          IXX0 = SO8RT_D(i,j,1)
+          JYY0 = SO8RT_D(i,j,2)
+
+          index = SO8RT_D(i,j,3)
+
+            if(dist(i,j,index) .le. 0) then
+               write(6,*) "FATAL ERROR: dist(i,j,index) is <= zero "   
+               call hydro_stop("In ROUTE_SUBSURFACE1() - dist(i,j,index) is <= zero ")
+            endif
+            if(soldep(i,j) .eq. 0) then
+               call hydro_stop("In ROUTE_SUBSURFACE1() - soldep is = zero")
+            endif
+
+          tmp_gsize = 1.0/dist(i,j,index)
+
+       
+          dzdx= (z(i,j) - z(IXX0,JYY0) )* tmp_gsize
+          beta=so8RT(i,j,index) + dzdx 
+
+          if(beta .lt. 1E-20 ) then   !if-then for direction...
+            call GETSUB8(IXX0,JYY0,I,J,Z,so8rt,dist(i,j,:),beta,XX,YY)
+          end if
+          if(beta .gt. 0) then            !if-then for flux calc 
+              if(beta .lt. 1E-20 ) then
+#ifdef HYDRO_D
+                   print*, "Message: beta need to be reset to 1E-20. beta = ",beta
+#endif
+                   beta = 1E-20
+              end if
+
+! do the rest if the lowest grid can be found.
+              hh=(1-(z(i,j)/soldep(i,j)))**nexp
+              ksat=latksat(i,j)
+
+              if (hh .lt. 0.) then
+                 print *, "hsub<0 at gridcell...", i,j,hh,z(i+1,j),z(i,j), &
+                      soldep(i,j)
+                 call hydro_stop("In ROUTE_SUBSURFACE1() - hsub<0 at gridcell ") 
+              end if
+
+!err. tan slope     gamma=-1.0*((gsize*ksat*soldep(i,j))/nexp)*tan(beta)
+              gamma=-1.0*((dist(i,j,index)*ksat*soldep(i,j))/nexp)*beta
+              qqsub = gamma * hh
+
+! ADCHANGE: Moved this water available constraint from outside qsub calc loop to inside
+!           to better account for adjustments to adjacent cells
+              if( qqsub .le. 0 .and. CWATAVAIL(i,j).lt.ABS(qqsub)/dist(i,j,9)*SUBDT) THEN
+                  qqsub = -1.0*CWATAVAIL(i,j)*dist(i,j,9)/SUBDT
+              end if
+
+              qsub(i,j) = qsub(i,j) + qqsub
+              qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) - qqsub
+
+!!DJG Error Checks...
+              if(qqsub .gt. 0) then
+                    print*, "FATAL ERROR: qqsub should be negative, qqsub =",qqsub,&
+                       "gamma=",gamma,"hh=",hh,"beta=",beta,"dzdx=",dzdx,&
+                       "so8RT=",so8RT(i,j,index),"latksat=",ksat, &
+                       "tan(beta)=",tan(beta),i,j,z(i,j),z(IXX0,JYY0)
+                    print*, "ixx0=",ixx0, "jyy0=",jyy0
+                    print*, "soldep =", soldep(i,j), "nexp=",nexp
+                 call hydro_stop("In ROUTE_SUBSURFACE1() - qqsub should be negative") 
+              end if
+
+
+
+
+! Boundary adjustments
+#ifdef MPP_LAND
+      if( ((ixx0.eq.XX).and.(right_id .lt. 0)) .or. &
+          ((ixx0.eq.1) .and.(left_id  .lt. 0)) .or. &
+          ((jyy0.eq.1) .and.(down_id  .lt. 0)) .or. &
+          ((JYY0.eq.YY).and.(up_id    .lt. 0)) ) then 
+#else
+              if ((ixx0.eq.1).or.(ixx0.eq.xx).or.(jyy0.eq.1).or.(jyy0.eq.yy)) then
+#endif
+                qsub_tmp(ixx0,jyy0) = qsub_tmp(ixx0,jyy0) + qqsub
+                QSUBDRY_tmp(ixx0,jyy0) = QSUBDRY_tmp(ixx0,jyy0) + qqsub
+
+                QSUBDRYT = QSUBDRYT + qqsub
+              end if
+
+998           continue
+
+!! End loop to route sfc water in x-direction
+      end if  !endif for flux calc
+
+          endif   !! Endif for gridcell check...
+
+
+          end do  !endif for i-dim
+!CRNT debug          if(flag.eq.-99) exit !exit loop for courant violation...
+        end do   !endif for j-dim
+
+#ifdef MPP_LAND
+
+       call MPP_LAND_COM_REAL8(qsub_tmp,XX,YY,1)
+       call MPP_LAND_COM_REAL8(QSUBDRY_tmp,XX,YY,1)
+#endif
+       qsub = qsub + qsub_tmp
+       QSUBDRY= QSUBDRY + QSUBDRY_tmp 
+
+!ADNOTE: Moved this check to inside qsub calc loop, so no need for additional loop
+!        do j=2,YY-1
+!          do i=2,XX-1
+!            if(dist(i,j,9) .le. 0) then
+!               call hydro_stop("In ROUTE_SUBSURFACE1() - dist(i,j,9) is <= zero")
+!            endif
+!!DJG Feb 16, 2016...comment out to debug...line is identical to line 255
+!!            if(CWATAVAIL(i,j).lt.ABS(qsub(i,j))/dist(i,j,9)*SUBDT) THEN
+!!              qsub(i,j) = -1.0*CWATAVAIL(i,j)
+!!            end if
+!          end do
+!        end do
+
+#ifdef MPP_LAND
+       call MPP_LAND_COM_REAL(qsub,XX,YY,99)
+       call MPP_LAND_COM_REAL(QSUBDRY,XX,YY,99)
+#endif
+
+
+        return
+!DJG------------------------------------------------------------
+        end subroutine ROUTE_SUBSURFACE1
+!DJG------------------------------------------------------------
+
+!DJG------------------------------------------------------------
+
+
+      SUBROUTINE GETSUB8(IXX0,JYY0,I,J,Z,sox,tmp_gsize,max,XX,YY)
+          implicit none
+          INTEGER:: IXX0,JYY0,IXX8,JYY8, XX, YY
+          INTEGER, INTENT(IN) :: I,J
+
+          REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY,8),tmp_gsize(9)
+          REAL  max
+          max = -1
+
+          IXX8 = I
+          JYY8 = J+1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,1),IXX0,JYY0,max,tmp_gsize(1),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J+1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,2),IXX0,JYY0,max,tmp_gsize(2),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,3),IXX0,JYY0,max,tmp_gsize(3),XX,YY)
+
+          IXX8 = I+1
+          JYY8 = J-1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,4),IXX0,JYY0,max,tmp_gsize(4),XX,YY)
+
+          IXX8 = I
+          JYY8 = J-1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,5),IXX0,JYY0,max,tmp_gsize(5),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J-1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,6),IXX0,JYY0,max,tmp_gsize(6),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,7),IXX0,JYY0,max,tmp_gsize(7),XX,YY)
+
+          IXX8 = I-1
+          JYY8 = J+1
+          call GETSUB8DIR(IXX8,JYY8,I,J,Z,sox(:,:,8),IXX0,JYY0,max,tmp_gsize(8),XX,YY)
+        RETURN
+        END SUBROUTINE GETSUB8
+
+        SUBROUTINE GETSUB8DIR(IXX8,JYY8,I,J,Z,sox,IXX0,JYY0,max,tmp_gsize,XX,YY)
+        implicit none
+        integer,INTENT(INOUT) ::IXX0,JYY0
+        INTEGER, INTENT(IN) :: I,J,IXX8,JYY8,XX,YY
+        REAL,INTENT(IN) :: Z(XX,YY),sox(XX,YY)
+        REAL, INTENT(INOUT) ::max
+        real, INTENT(IN) :: tmp_gsize
+        real :: beta , dzdx
+
+          dzdx= (z(i,j) - z(IXX0,JYY0) )/tmp_gsize
+          beta=sox(i,j) + dzdx 
+          if(max < beta ) then
+                   IXX0 = IXX8
+                   JYY0 = JYY8
+                   max = beta 
+          end if
+
+        END SUBROUTINE GETSUB8DIR
+!DJG ----------------------------------------------------------------------
+
+!DJG     SUBROUTINE ROUTE_OVERLAND2
+!DJG ----------------------------------------------------------------
+
+          SUBROUTINE ROUTE_OVERLAND2 (dt,                               &
+     &          dist,h,qsfc,sox,soy,                                   &
+     &          retent_dep,dist_rough,XX,YY,QBDRY,QBDRYT,               &
+     &          q_sfcflx_x,q_sfcflx_y)
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!  Subroutine to route excess rainfall over the watershed
+!     using a 2d diffusion routing scheme.
+!
+!  Called from: main.f
+!
+!      Will try to formulate this to be called from NOAH
+!
+!  Returns: qsfc=DQOV   which in turn becomes DH in head calc.
+!
+!  Created:  Adaptded from CASC2D source code
+!  NOTE: dh from original code has been replaced by qsfc
+!        dhh replaced by qqsfc
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id,&
+               up_id,mpp_land_com_real,MPP_LAND_UB_COM, &
+               MPP_LAND_LR_COM,mpp_land_com_integer
+#endif
+
+        IMPLICIT NONE
+
+
+!! Declare Passed variables
+
+        real :: gsize
+        INTEGER, INTENT(IN) :: XX,YY
+        REAL, INTENT(IN) :: dt , dist(XX,YY,9)
+
+!! Declare passed arrays
+
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: h
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: qsfc
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: sox
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: soy
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: retent_dep
+        REAL, INTENT(IN), DIMENSION(XX,YY) :: dist_rough
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: QBDRY
+        REAL, INTENT(INOUT), DIMENSION(XX,YY) :: q_sfcflx_x,q_sfcflx_y
+        REAL, INTENT(INOUT) :: QBDRYT
+        REAL  :: DH(XX,YY)
+
+!!! Declare Local Variables
+
+        REAL :: dhdx,dhdy,alfax,alfay
+        REAL :: hh53,qqsfc,hh,dt_new
+        REAL :: sfx,sfy
+        REAL :: tmp_adjust
+
+        INTEGER :: i,j
+
+!!! Initialize variables
+
+
+
+
+!!! Begin Routing of Excess Rainfall over the Watershed
+
+
+        DH = 0
+!!! Loop to route water in x-direction
+        do j=1,YY
+          do i=1,XX
+
+
+! check for boundary gridpoint?
+          if (i.eq.XX) GOTO 998
+           gsize = dist(i,j,3)
+
+
+! check for detention storage?
+          if (h(i,j).lt.retent_dep(i,j).AND.     &
+              h(i+1,j).lt.retent_dep(i+1,j)) GOTO 998
+
+          dhdx = (h(i+1,j)/1000. - h(i,j)/1000.) / gsize  ! gisze-(m),h-(mm)
+
+          sfx = (sox(i,j)-dhdx+1E-30)
+          if (abs(sfx).lt.1E-20) sfx=1E-20
+          alfax = ((abs(sfx))**0.5)/dist_rough(i,j)
+          if (sfx.lt.0.) then
+              hh=(h(i+1,j)-retent_dep(i+1,j))/1000.
+          else
+              hh=(h(i,j)-retent_dep(i,j))/1000.
+          end if
+
+          if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 998
+          if (hh.lt.0.) then
+          GOTO 998
+          end if
+
+          hh53=hh**(5./3.)
+
+
+! Calculate q-flux... (units (m))
+          qqsfc = (sfx/abs(sfx))*alfax*hh53*dt/gsize
+          q_sfcflx_x(I,J) = q_sfcflx_x(I,J) + qqsfc
+
+!DJG put adjustment in for (h) due to qqsfc
+
+!yw changed as following:
+           tmp_adjust=qqsfc*1000
+          if(tmp_adjust .le. 0 ) GOTO 998
+           if((h(i,j) - tmp_adjust) <0 )  then
+#ifdef HYDRO_D
+               print*, "WARNING: surface head is negative:  ",i,j
+#endif
+               tmp_adjust = h(i,j)
+           end if
+           if((h(i+1,j) + tmp_adjust) <0) then 
+#ifdef HYDRO_D
+               print*, "WARNING: surface head is negative: ",i+1,j
+#endif
+               tmp_adjust = -1*h(i+1,j)
+           end if
+ 	   Dh(i,j) = Dh(i,j)-tmp_adjust
+           Dh(i+1,j) = Dh(i+1,j) + tmp_adjust
+!yw end change
+
+
+
+!DG Boundary adjustments here
+!DG Constant Flux Condition
+#ifdef MPP_LAND
+          if ((i.eq.1).AND.(sfx.lt.0).and. & 
+                (left_id .lt. 0) ) then
+#else
+          if ((i.eq.1).AND.(sfx.lt.0)) then
+#endif
+             Dh(i,j) = Dh(i,j) + qqsfc*1000.
+            QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000.
+            QBDRYT=QBDRYT + qqsfc*1000.
+#ifdef MPP_LAND
+          else if ( (i.eq.(XX-1)).AND.(sfx.gt.0) &
+             .and. (right_id .lt. 0) ) then
+#else
+          else if ((i.eq.(XX-1)).AND.(sfx.gt.0)) then
+#endif
+             tmp_adjust = qqsfc*1000.
+             if(h(i+1,j).lt.tmp_adjust) tmp_adjust = h(i+1,j)
+             Dh(i+1,j) = Dh(i+1,j) - tmp_adjust
+!DJG Re-assign h(i+1) = 0.0 when <0.0 (from rounding/truncation error)
+            QBDRY(I+1,J)=QBDRY(I+1,J) - tmp_adjust
+            QBDRYT=QBDRYT - tmp_adjust
+          end if
+
+
+998     continue
+
+!! End loop to route sfc water in x-direction
+          end do
+        end do
+
+        H = H + DH
+#ifdef MPP_LAND
+       call MPP_LAND_LR_COM(H,XX,YY,99)
+       call MPP_LAND_LR_COM(QBDRY,XX,YY,99)
+#endif
+
+
+        DH = 0
+!!!! Loop to route water in y-direction
+        do j=1,YY
+          do i=1,XX
+
+!! check for boundary grid point?
+          if (j.eq.YY) GOTO 999
+           gsize = dist(i,j,1)
+
+
+!! check for detention storage?
+          if (h(i,j).lt.retent_dep(i,j).AND.     & 
+              h(i,j+1).lt.retent_dep(i,j+1)) GOTO 999
+
+          dhdy = (h(i,j+1)/1000. - h(i,j)/1000.) / gsize
+
+          sfy = (soy(i,j)-dhdy+1E-30)
+          if (abs(sfy).lt.1E-20) sfy=1E-20
+          alfay = ((abs(sfy))**0.5)/dist_rough(i,j)
+          if (sfy.lt.0.) then
+              hh=(h(i,j+1)-retent_dep(i,j+1))/1000.
+          else
+              hh=(h(i,j)-retent_dep(i,j))/1000.
+          end if
+
+          if ((retent_dep(i,j).gt.0.).AND.(hh.le.0.)) GOTO 999
+          if (hh.lt.0.) then
+            GOTO 999
+          end if
+
+         hh53=hh**(5./3.)
+
+! Calculate q-flux...
+          qqsfc = (sfy/abs(sfy))*alfay*hh53*dt / gsize
+          q_sfcflx_y(I,J) = q_sfcflx_y(I,J) + qqsfc
+
+
+!DJG put adjustment in for (h) due to qqsfc
+!yw	  h(i,j) = h(i,j)-qqsfc*1000.
+!yw          h(i,j+1) = h(i,j+1) + qqsfc*1000.
+!yw changed as following:
+           tmp_adjust=qqsfc*1000
+          if(tmp_adjust .le. 0 ) GOTO 999
+
+           if((h(i,j) - tmp_adjust) <0 )  then
+#ifdef HYDRO_D
+               print *, "WARNING: surface head is negative:  ",i,j
+#endif
+               tmp_adjust = h(i,j)
+           end if
+           if((h(i,j+1) + tmp_adjust) <0) then
+#ifdef HYDRO_D
+               print *, "WARNING: surface head is negative: ",i,j+1
+#endif
+               tmp_adjust = -1*h(i,j+1)
+           end if
+	  Dh(i,j) = Dh(i,j)-tmp_adjust
+          Dh(i,j+1) = Dh(i,j+1) + tmp_adjust
+!yw end change
+
+!          qsfc(i,j) = qsfc(i,j)-qqsfc
+!          qsfc(i,j+1) = qsfc(i,j+1) + qqsfc
+!!DG Boundary adjustments here
+!!DG Constant Flux Condition
+#ifdef MPP_LAND
+          if ((j.eq.1).AND.(sfy.lt.0)   &
+             .and. (down_id .lt. 0) ) then
+#else
+          if ((j.eq.1).AND.(sfy.lt.0)) then
+#endif
+            Dh(i,j) = Dh(i,j) + qqsfc*1000.
+            QBDRY(I,J)=QBDRY(I,J) + qqsfc*1000.
+            QBDRYT=QBDRYT + qqsfc*1000.
+#ifdef MPP_LAND
+          else if ((j.eq.(YY-1)).AND.(sfy.gt.0) &
+             .and. (up_id .lt. 0) ) then
+#else
+          else if ((j.eq.(YY-1)).AND.(sfy.gt.0)) then
+#endif
+             tmp_adjust = qqsfc*1000.
+             if(h(i,j+1).lt.tmp_adjust) tmp_adjust = h(i,j+1)
+             Dh(i,j+1) = Dh(i,j+1) - tmp_adjust
+!DJG Re-assign h(j+1) = 0.0 when <0.0 (from rounding/truncation error)
+            QBDRY(I,J+1)=QBDRY(I,J+1) - tmp_adjust
+            QBDRYT=QBDRYT - tmp_adjust
+          end if
+
+999     continue
+
+!!!! End loop to route sfc water in y-direction
+          end do
+        end do
+
+        H = H +DH
+#ifdef MPP_LAND
+       call MPP_LAND_UB_COM(H,XX,YY,99)
+       call MPP_LAND_UB_COM(QBDRY,XX,YY,99)
+#endif
+        return
+
+!DJG ----------------------------------------------------------------------
+        end subroutine ROUTE_OVERLAND2
+
+
+
+
+!DJG-----------------------------------------------------------------------
+!DJG SUBROUTINE TER_ADJ_SOL    - Terrain adjustment of incoming solar radiation
+!DJG-----------------------------------------------------------------------
+	SUBROUTINE TER_ADJ_SOL(IX,JX,SO8LD_D,TSLP,SHORT,XLAT,XLONG,olddate,DT)
+
+#ifdef MPP_LAND
+        use module_mpp_land, only:  my_id, io_id, &
+             mpp_land_bcast_int1 
+#endif
+          implicit none
+          integer,INTENT(IN)     :: IX,JX
+          INTEGER,INTENT(in), DIMENSION(IX,JX,3)   :: SO8LD_D
+          real,INTENT(IN), DIMENSION(IX,JX)  :: XLAT,XLONG
+ 	  real,INTENT(IN) :: DT
+          real,INTENT(INOUT), DIMENSION(IX,JX)  :: SHORT
+          character(len=19) :: olddate
+
+! Local Variables...
+          real, dimension(IX,JX) ::TSLP,TAZI
+          real, dimension(IX,JX) ::SOLDN
+	  real :: SOLDEC,DGRD,ITIME2,HRANGLE
+	  real :: BINSH,SOLZANG,SOLAZI,INCADJ
+	  real :: TAZIR,TSLPR,LATR,LONR,SOLDNADJ
+          integer :: JULDAY0,HHTIME0,MMTIME0,YYYY0,MM0,DD0
+          integer :: JULDAY,HHTIME,MMTIME,YYYY,MM,DD
+	  integer :: I,J
+          
+
+!----------------------------------------------------------------------
+!  SPECIFY PARAMETERS and VARIABLES
+!----------------------------------------------------------------------
+
+       JULDAY = 0	
+       SOLDN = SHORT
+       DGRD = 3.14159/180.
+       
+! Set up time variables...
+#ifdef MPP_LAND   
+       if(my_id .eq. IO_id) then
+#endif
+          read(olddate(1:4),"(I4)") YYYY0 ! real-time year (GMT)
+          read(olddate(6:7),"(I2.2)") MM0 ! real-time month (GMT)
+          read(olddate(9:10),"(I2.2)") DD0 ! real-time day (GMT)
+          read(olddate(12:13),"(I2.2)") HHTIME0 ! real-time hour (GMT)
+          read(olddate(15:16),"(I2.2)") MMTIME0 ! real-time minutes (GMT)
+#ifdef MPP_LAND   
+       endif
+       call mpp_land_bcast_int1(YYYY0) 
+       call mpp_land_bcast_int1(MM0) 
+       call mpp_land_bcast_int1(DD0) 
+       call mpp_land_bcast_int1(HHTIME0) 
+       call mpp_land_bcast_int1(MMTIME0) 
+#endif
+
+
+! Set up terrain variables...(returns TSLP&TAZI in radians) 
+	call SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI)
+
+!----------------------------------------------------------------------
+!  BEGIN LOOP THROUGH GRID
+!----------------------------------------------------------------------
+        DO J=1,JX
+          DO I=1,IX
+             YYYY = YYYY0
+             MM  = MM0
+             DD  = DD0
+             HHTIME = HHTIME0
+             MMTIME = MMTIME0
+      	     call GMT2LOCAL(1,1,XLONG(i,j),YYYY,MM,DD,HHTIME,MMTIME,DT)
+             call JULDAY_CALC(YYYY,MM,DD,JULDAY)
+
+! Convert to radians...
+           LATR = XLAT(I,J)   !send solsub local lat in deg
+           LONR = XLONG(I,J)   !send solsub local lon in deg
+           TSLPR = TSLP(I,J)/DGRD !send solsub local slp in deg
+           TAZIR = TAZI(I,J)/DGRD !send solsub local azim in deg
+
+!Call SOLSUB to return terrain adjusted incoming solar radiation...
+! SOLSUB taken from Whiteman and Allwine, 1986, Environ. Software.
+
+          call SOLSUB(LONR,LATR,TAZIR,TSLPR,SOLDN(I,J),YYYY,MM,         &
+               DD,HHTIME,MMTIME,SOLDNADJ,SOLZANG,SOLAZI,INCADJ)
+
+         SOLDN(I,J)=SOLDNADJ
+
+          ENDDO
+        ENDDO
+
+	SHORT = SOLDN
+
+        return
+	end SUBROUTINE TER_ADJ_SOL  
+!DJG-----------------------------------------------------------------------
+!DJG END SUBROUTINE TER_ADJ_SOL
+!DJG-----------------------------------------------------------------------
+
+
+!DJG-----------------------------------------------------------------------
+!DJG SUBROUTINE GMT2LOCAL
+!DJG-----------------------------------------------------------------------
+	subroutine GMT2LOCAL(IX,JX,XLONG,YY,MM,DD,HH,MIN,DT)
+
+       implicit none
+
+!!! Declare Passed Args.
+
+        INTEGER, INTENT(INOUT) :: yy,mm,dd,hh,min
+        INTEGER, INTENT(IN) :: IX,JX
+        REAL,INTENT(IN), DIMENSION(IX,JX)  :: XLONG
+        REAL,INTENT(IN) :: DT
+
+!!! Declare local variables
+
+        integer :: i,j,minflag,hhflag,ddflag,mmflag,yyflag
+        integer :: adj_min,lst_adj_min,lst_adj_hh,adj_hh
+        real, dimension(IX,JX) :: TDIFF
+        real :: tmp
+        integer :: yyinit,mminit,ddinit,hhinit,mininit
+
+!!! Initialize flags
+        hhflag=0
+        ddflag=0
+        mmflag=0
+        yyflag=0
+
+!!! Set up constants...
+        yyinit = yy
+   	mminit = mm
+        ddinit = dd
+        hhinit = hh
+        mininit = min
+
+
+! Loop through data...
+     do j=1,JX
+      do i=1,IX
+
+! Reset yy,mm,dd...
+        yy = yyinit
+	mm = mminit
+        dd = ddinit
+        hh = hhinit
+	min = mininit
+
+!!! Set up adjustments...
+!   - assumes +E , -W  longitude and 0.06667 hr/deg (=24/360)
+       TDIFF(I,J) = XLONG(I,J)*0.06667   ! time offset in hr
+       tmp = TDIFF(I,J)
+       lst_adj_hh = INT(tmp)
+       lst_adj_min = NINT(MOD(int(tmp),1)*60.) + int(DT/2./60.)  ! w/ 1/2 timestep adjustment...
+
+!!! Process Minutes...
+        adj_min = min+lst_adj_min
+        if (adj_min.lt.0) then
+          min=60+adj_min
+          lst_adj_hh = lst_adj_hh - 1
+        else if (adj_min.ge.0.AND.adj_min.lt.60) then
+          min=adj_min
+        else if (adj_min.ge.60) then
+          min=adj_min-60
+          lst_adj_hh = lst_adj_hh + 1
+        end if
+
+!!! Process Hours
+        adj_hh = hh+lst_adj_hh
+	if (adj_hh.lt.0) then
+          hh = 24+adj_hh
+          ddflag=1
+        else if (adj_hh.ge.0.AND.adj_hh.lt.24) then
+          hh=adj_hh
+        else if (adj_hh.ge.24) then
+          hh=adj_hh-24
+          ddflag = 2
+        end if
+
+
+
+!!! Process Days, Months, Years
+! Subtract a day
+        if (ddflag.eq.1) then
+          if (dd.gt.1) then
+            dd=dd-1
+          else
+            if (mm.eq.1) then
+              mm=12
+              yy=yy-1
+            else
+              mm=mm-1
+            end if
+            if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. &
+                (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. &
+                 (mm.eq.12)) then
+              dd=31
+            else
+
+!!! Adjustment for leap years!!!
+                if(mm.eq.2) then
+                  if(MOD(yy,4).eq.0) then
+                    dd=29
+                  else
+                    dd=28
+                  end if
+                end if
+                if(mm.ne.2) dd=30
+            end if
+          end if
+        end if
+
+! Add a day
+        if (ddflag.eq.2) then
+          if ((mm.eq.1).or.(mm.eq.3).or.(mm.eq.5).or. &
+                (mm.eq.7).or.(mm.eq.8).or.(mm.eq.10).or. &
+                 (mm.eq.12)) then
+            if (dd.eq.31) then
+              dd=1
+              if (mm.eq.12) then
+                mm=1
+                yy=yy+1
+              else
+                mm=mm+1
+              end if
+            else
+              dd=dd+1
+            end if
+
+!!! Adjustment for leap years!!!
+          else if (mm.eq.2) then
+            if(MOD(yy,4).eq.0) then
+              if (dd.eq.29) then
+                dd=1
+                mm=3
+              else
+                dd=dd+1
+              end if
+            else
+              if (dd.eq.28) then
+                dd=1
+                mm=3
+              else
+                dd=dd+1
+              end if
+            end if
+          else
+            if (dd.eq.30) then
+              dd=1
+              mm=mm+1
+            else
+              dd=dd+1
+            end if
+          end if
+
+        end if
+
+       end do   !i-loop
+      end do   !j-loop
+
+        return
+        end subroutine
+
+!DJG-----------------------------------------------------------------------
+!DJG END SUBROUTINE GMT2LOCAL
+!DJG-----------------------------------------------------------------------
+
+
+
+!DJG-----------------------------------------------------------------------
+!DJG SUBROUTINE JULDAY_CALC
+!DJG-----------------------------------------------------------------------
+      subroutine JULDAY_CALC(YYYY,MM,DD,JULDAY)
+
+	implicit none
+	integer,intent(in) :: YYYY,MM,DD
+        integer,intent(out) :: JULDAY
+
+        integer :: resid
+        integer julm(13)
+        DATA JULM/0, 31, 59, 90, 120, 151, 181, 212, 243, 273, &
+           304, 334, 365 /
+
+        integer LPjulm(13)
+        DATA LPJULM/0, 31, 60, 91, 121, 152, 182, 213, 244, 274, &
+           305, 335, 366 /
+
+      resid = MOD(YYYY,4) !Set up leap year check...
+
+      if (resid.ne.0) then    !If not a leap year....
+        JULDAY = JULM(MM) + DD
+      else                    !If a leap year...
+        JULDAY = LPJULM(MM) + DD
+      end if
+
+      RETURN
+      END subroutine JULDAY_CALC
+!DJG-----------------------------------------------------------------------
+!DJG END SUBROUTINE JULDAY
+!DJG-----------------------------------------------------------------------
+
+!DJG-----------------------------------------------------------------------
+!DJG SUBROUTINE SLOPE_ASPECT
+!DJG-----------------------------------------------------------------------
+	subroutine SLOPE_ASPECT(IX,JX,SO8LD_D,TAZI)
+
+	implicit none
+        integer, INTENT(IN)		   :: IX,JX
+!	real,INTENT(in),DIMENSION(IX,JX)   :: TSLP  !terrain slope (m/m)
+	real,INTENT(OUT),DIMENSION(IX,JX)   :: TAZI  !terrain aspect (deg)
+
+        INTEGER, DIMENSION(IX,JX,3)   :: SO8LD_D
+	real :: DGRD
+	integer :: i,j
+
+!	TSLP = 0.  !Initialize as flat
+	TAZI = 0.  !Initialize as north facing
+
+! Find steepest descent slope and direction...
+        do j=1,JX
+          do i=1,IX
+!	TSLP(I,J) = TANH(Vmax(i,j)) ! calculate slope in radians...
+
+! Convert steepest slope and aspect to radians...
+        IF (SO8LD_D(i,j,3).eq.1) then
+          TAZI(I,J) = 0.0
+        ELSEIF (SO8LD_D(i,j,3).eq.2) then
+          TAZI(I,J) = 45.0
+        ELSEIF (SO8LD_D(i,j,3).eq.3) then
+          TAZI(I,J) = 90.0
+        ELSEIF (SO8LD_D(i,j,3).eq.4) then
+          TAZI(I,J) = 135.0
+        ELSEIF (SO8LD_D(i,j,3).eq.5) then
+          TAZI(I,J) = 180.0
+        ELSEIF (SO8LD_D(i,j,3).eq.6) then
+          TAZI(I,J) = 225.0
+        ELSEIF (SO8LD_D(i,j,3).eq.7) then
+          TAZI(I,J) = 270.0
+        ELSEIF (SO8LD_D(i,j,3).eq.8) then
+          TAZI(I,J) = 315.0
+	END IF
+
+        DGRD = 3.141593/180.
+	TAZI(I,J) = TAZI(I,J)*DGRD ! convert azimuth to radians...
+
+        END DO
+      END DO
+
+      RETURN
+      END  subroutine SLOPE_ASPECT
+!DJG-----------------------------------------------------------------------
+!DJG END SUBROUTINE SLOPE_ASPECT
+!DJG-----------------------------------------------------------------------
+
+!DJG----------------------------------------------------------------
+!DJG    SUBROUTINE SOLSUB
+!DJG----------------------------------------------------------------
+        SUBROUTINE SOLSUB(LONG,LAT,AZ,IN,SC,YY,MO,IDA,IHR,MM,OUT1, &
+                          OUT2,OUT3,INCADJ)
+
+
+! Notes....
+
+        implicit none
+          logical               :: daily, first
+          integer               :: yy,mo,ida,ihr,mm,d
+          integer,dimension(12) :: nday
+          real                  :: lat,long,longcor,longsun,in,inslo
+          real :: az,sc,out1,out2,out3,cosbeta,dzero,eccent,pi,calint
+          real :: rtod,decmax,omega,onehr,omd,omdzero,rdvecsq,sdec
+          real :: declin,cdec,arg,declon,sr,stdmrdn,b,em,timnoon,azslo
+          real :: slat,clat,caz,saz,sinc,cinc,hinc,h,cosz,extra,extslo
+          real :: t1,z,cosa,a,cosbeta_flat,INCADJ
+          integer :: HHTIME,MMTIME,i,ik
+          real, dimension(4) :: ACOF,BCOF
+
+! Constants
+       daily=.FALSE.
+       ACOF(1) = 0.00839
+       ACOF(2) = -0.05391
+       ACOF(3) = -0.00154
+       ACOF(4) = -0.0022
+       BCOF(1) = -0.12193
+       BCOF(2) = -0.15699
+       BCOF(3) = -0.00657
+       BCOF(4) = -0.00370
+       DZERO = 80.
+       ECCENT = 0.0167
+       PI = 3.14159
+       CALINT = 1.
+       RTOD = PI / 180.
+       DECMAX=(23.+26./60.)*RTOD
+       OMEGA=2*PI/365.
+       ONEHR=15.*RTOD
+
+! Calculate Julian Day...
+       D = 0
+       call JULDAY_CALC(YY,MO,IDA,D)
+
+! Ratio of radius vectors squared...
+       OMD=OMEGA*D
+       OMDZERO=OMEGA*DZERO
+!       RDVECSQ=1./(1.-ECCENT*COS(OMD))**2
+       RDVECSQ = 1.    ! no adjustment for orbital changes when coupled to HRLDAS...
+
+! Declination of sun...
+       LONGSUN=OMEGA*(D-Dzero)+2.*ECCENT*(SIN(OMD)-SIN(OMDZERO))
+       DECLIN=ASIN(SIN(DECMAX)*SIN(LONGSUN))
+       SDEC=SIN(DECLIN)
+       CDEC=COS(DECLIN)
+
+! Check for Polar Day/night...
+       ARG=((PI/2.)-ABS(DECLIN))/RTOD
+       IF(ABS(LAT).GT.ARG) THEN
+         IF((LAT.GT.0..AND.DECLIN.LT.0) .OR.       &
+             (LAT.LT.0..AND.DECLON.GT.0.)) THEN
+               OUT1 = 0.
+               OUT2 = 0.
+               OUT3 = 0.
+               RETURN
+         ENDIF
+         SR=-1.*PI
+       ELSE
+
+! Calculate sunrise hour angle...
+         SR=-1.*ABS(ACOS(-1.*TAN(LAT*RTOD)*TAN(DECLIN)))
+       END IF
+
+! Find standard meridian for site
+       STDMRDN=NINT(LONG/15.)*15.
+       LONGCOR=(LONG-STDMRDN)/15.
+
+! Compute time correction from equation of time...
+       B=2.*PI*(D-.4)/365
+       EM=0.
+       DO I=1,4
+         EM=EM+(BCOF(I)*SIN(I*B)+ACOF(I)*COS(I*B))
+       END DO
+
+! Compute time of solar noon...
+       TIMNOON=12.-EM-LONGCOR
+
+! Set up a few more terms...
+       AZSLO=AZ*RTOD
+       INSLO=IN*RTOD
+       SLAT=SIN(LAT*RTOD)
+       CLAT=COS(LAT*RTOD)
+       CAZ=COS(AZSLO)
+       SAZ=SIN(AZSLO)
+       SINC=SIN(INSLO)
+       CINC=COS(INSLO)
+
+! Begin solar radiation calculations...daily first, else instantaneous...
+       IF (DAILY) THEN   ! compute daily integrated values...(Not used in HRLDAS!)
+         IHR=0
+         MM=0
+         HINC=CALINT*ONEHR/60.
+         IK=(2.*ABS(SR)/HINC)+2.
+         FIRST=.TRUE.
+         OUT1=0.
+         DO I=1,IK
+           H=SR+HINC*FLOAT(I-1)
+           COSZ=SLAT*SDEC+CLAT*CDEC*COS(H)
+           COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)- &
+                SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ &
+                SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC)
+           EXTRA=SC*RDVECSQ*COSZ
+           IF(EXTRA.LE.0.) EXTRA=0.
+           EXTSLO=SC*RDVECSQ*COSBETA
+           IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0.
+           IF(FIRST .AND. EXTSLO.GT.0.) THEN
+             OUT2=(H-HINC)/ONEHR+TIMNOON
+             FIRST = .FALSE.
+           END IF
+           IF(.NOT.FIRST .AND. EXTSLO.LE.0.) OUT3=H/ONEHR+TIMNOON
+           OUT1=EXTSLO+OUT1
+         END DO
+         OUT1=OUT1*CALINT*60./1000000.
+
+       ELSE   ! Compute instantaneous values...(Is used in HRLDAS!)
+
+         T1=FLOAT(IHR)+FLOAT(MM)/60.
+         H=ONEHR*(T1-TIMNOON)
+         COSZ=SLAT*SDEC+CLAT*CDEC*COS(H)
+
+! Assuming HRLDAS forcing already accounts for season, time of day etc,
+! subtract out the component of adjustment that would occur for
+! a flat surface, this should leave only the sloped component remaining
+
+         COSBETA=CDEC*((SLAT*COS(H))*(-1.*CAZ*SINC)-  &
+              SIN(H)*(SAZ*SINC)+(CLAT*COS(H))*CINC)+ &
+              SDEC*(CLAT*(CAZ*SINC)+SLAT*CINC)
+
+         COSBETA_FLAT=CDEC*CLAT*COS(H)+SDEC*SLAT
+
+         INCADJ = COSBETA+(1-COSBETA_FLAT)
+
+         EXTRA=SC*RDVECSQ*COSZ
+         IF(EXTRA.LE.0.) EXTRA=0.
+         EXTSLO=SC*RDVECSQ*INCADJ
+!         IF(EXTRA.LE.0. .OR. EXTSLO.LT.0.) EXTSLO=0.  !remove check for HRLDAS.
+         OUT1=EXTSLO
+         Z=ACOS(COSZ)
+         COSA=(SLAT*COSZ-SDEC)/(CLAT*SIN(Z))
+         IF(COSA.LT.-1.) COSA=-1.
+         IF(COSA.GT.1.) COSA=1.
+         A=ABS(ACOS(COSA))
+         IF(H.LT.0.) A=-A
+         OUT2=Z/RTOD
+         OUT3=A/RTOD+180
+
+       END IF    ! End if for daily vs instantaneous values...
+
+!DJG-----------------------------------------------------------------------
+       RETURN
+       END SUBROUTINE SOLSUB
+!DJG-----------------------------------------------------------------------
+       
+       subroutine seq_land_SO8(SO8LD_D,Vmax,TERR,dx,ix,jx)
+         implicit none
+         integer :: ix,jx,i,j
+         REAL, DIMENSION(IX,JX,8)      :: SO8LD
+         INTEGER, DIMENSION(IX,JX,3)   :: SO8LD_D
+         real,DIMENSION(IX,JX)      :: TERR
+         real                       :: dx(ix,jx,9),Vmax(ix,jx)
+         SO8LD_D = -1
+         do j = 2, jx -1
+            do i = 2, ix -1
+               SO8LD(i,j,1) = (TERR(i,j)-TERR(i,j+1))/dx(i,j,1)
+               SO8LD_D(i,j,1) = i
+               SO8LD_D(i,j,2) = j + 1
+               SO8LD_D(i,j,3) = 1
+               Vmax(i,j) = SO8LD(i,j,1)
+
+               SO8LD(i,j,2) = (TERR(i,j)-TERR(i+1,j+1))/DX(i,j,2)
+               if(SO8LD(i,j,2) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i + 1
+                 SO8LD_D(i,j,2) = j + 1
+                 SO8LD_D(i,j,3) = 2
+                 Vmax(i,j) = SO8LD(i,j,2)
+               end if
+               SO8LD(i,j,3) = (TERR(i,j)-TERR(i+1,j))/DX(i,j,3)
+               if(SO8LD(i,j,3) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i + 1
+                 SO8LD_D(i,j,2) = j
+                 SO8LD_D(i,j,3) = 3
+                 Vmax(i,j) = SO8LD(i,j,3)
+               end if
+               SO8LD(i,j,4) = (TERR(i,j)-TERR(i+1,j-1))/DX(i,j,4)
+               if(SO8LD(i,j,4) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i + 1
+                 SO8LD_D(i,j,2) = j - 1
+                 SO8LD_D(i,j,3) = 4
+                 Vmax(i,j) = SO8LD(i,j,4)
+               end if
+               SO8LD(i,j,5) = (TERR(i,j)-TERR(i,j-1))/DX(i,j,5)
+               if(SO8LD(i,j,5) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i
+                 SO8LD_D(i,j,2) = j - 1
+                 SO8LD_D(i,j,3) = 5
+                 Vmax(i,j) = SO8LD(i,j,5)
+               end if
+               SO8LD(i,j,6) = (TERR(i,j)-TERR(i-1,j-1))/DX(i,j,6)
+               if(SO8LD(i,j,6) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i - 1
+                 SO8LD_D(i,j,2) = j - 1
+                 SO8LD_D(i,j,3) = 6
+                 Vmax(i,j) = SO8LD(i,j,6)
+               end if
+               SO8LD(i,j,7) = (TERR(i,j)-TERR(i-1,j))/DX(i,j,7)
+               if(SO8LD(i,j,7) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i - 1
+                 SO8LD_D(i,j,2) = j
+                 SO8LD_D(i,j,3) = 7
+                 Vmax(i,j) = SO8LD(i,j,7)
+               end if
+               SO8LD(i,j,8) = (TERR(i,j)-TERR(i-1,j+1))/DX(i,j,8)
+               if(SO8LD(i,j,8) .gt. Vmax(i,j) ) then
+                 SO8LD_D(i,j,1) = i - 1
+                 SO8LD_D(i,j,2) = j + 1
+                 SO8LD_D(i,j,3) = 8
+                 Vmax(i,j) = SO8LD(i,j,8)
+               end if
+             enddo
+          enddo
+          Vmax = TANH(Vmax)    
+          return
+          end  subroutine seq_land_SO8
+
+#ifdef MPP_LAND
+       subroutine MPP_seq_land_SO8(SO8LD_D,Vmax,TERRAIN,dx,ix,jx,&
+         global_nx,global_ny)
+
+         use module_mpp_land, only:  my_id, io_id, &
+              write_io_real,decompose_data_int,decompose_data_real
+
+         implicit none
+         integer,intent(in) :: ix,jx,global_nx,global_ny
+         INTEGER, intent(inout),DIMENSION(IX,JX,3)   :: SO8LD_D
+!         real,intent(in), DIMENSION(IX,JX)   :: TERRAIN
+         real,DIMENSION(IX,JX)   :: TERRAIN
+         real,intent(out),dimension(ix,jx) ::  Vmax
+         real,intent(in)                     :: dx(ix,jx,9)
+         real                     :: g_dx(ix,jx,9)
+
+         real,DIMENSION(global_nx,global_ny)      :: g_TERRAIN
+         real,DIMENSION(global_nx,global_ny)      :: g_Vmax
+         integer,DIMENSION(global_nx,global_ny,3)      :: g_SO8LD_D
+         integer :: k
+
+         g_SO8LD_D = 0
+         g_Vmax    = 0
+       
+         do k = 1, 9 
+            call write_IO_real(dx(:,:,k),g_dx(:,:,k)) 
+         end do
+
+         call write_IO_real(TERRAIN,g_TERRAIN)
+         if(my_id .eq. IO_id) then
+            call seq_land_SO8(g_SO8LD_D,g_Vmax,g_TERRAIN,g_dx,global_nx,global_ny)
+         endif
+          call decompose_data_int(g_SO8LD_D(:,:,3),SO8LD_D(:,:,3))
+          call decompose_data_real(g_Vmax,Vmax)
+         return
+         end subroutine MPP_seq_land_SO8
+
+#endif
+
+
+
+      subroutine disaggregateDomain_drv(did)
+           use module_RT_data, only: rt_domain
+           use module_namelist, only: nlst_rt
+           integer :: did
+           call disaggregateDomain( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,&
+             RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT,nlst_rt(did)%AGGFACTRT,RT_DOMAIN(did)%SICE, &
+             RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%SH2OX,RT_DOMAIN(did)%INFXSRT, &
+             rt_domain(did)%dist_lsm(:,:,9),RT_DOMAIN(did)%SMCMAX1,RT_DOMAIN(did)%SMCREF1, &
+             RT_DOMAIN(did)%SMCWLT1,RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%LKSAT,RT_DOMAIN(did)%dist, &
+             RT_DOMAIN(did)%INFXSWGT, RT_DOMAIN(did)%OVROUGHRTFAC,RT_DOMAIN(did)%LKSATFAC, &
+             RT_DOMAIN(did)%CH_NETRT,RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%SMCREFRT,       &
+             RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%SMCMAXRT, RT_DOMAIN(did)%SMCWLTRT,    &
+             RT_DOMAIN(did)%SMCRT, &
+             RT_DOMAIN(did)%OVROUGHRT, RT_DOMAIN(did)%LAKE_MSKRT, &
+             RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%OV_ROUGH,RT_DOMAIN(did)%SLDPTH, &
+	     RT_DOMAIN(did)%soiltypRT, RT_DOMAIN(did)%soiltyp)
+
+      end subroutine disaggregateDomain_drv
+
+      subroutine disaggregateDomain(IX,JX,NSOIL,IXRT,JXRT,AGGFACTRT, &
+                     SICE, SMC,SH2OX, INFXSRT, area_lsm, SMCMAX1,SMCREF1, &
+               SMCWLT1, VEGTYP, LKSAT, dist,INFXSWGT,OVROUGHRTFAC, &
+               LKSATFAC, CH_NETRT,SH2OWGT,SMCREFRT, INFXSUBRT,SMCMAXRT, &
+               SMCWLTRT,SMCRT, OVROUGHRT, LAKE_MSKRT, LKSATRT,OV_ROUGH,  &
+               SLDPTH, soiltypRT, soiltyp                               &
+            )
+#ifdef MPP_LAND
+        use module_mpp_land, only: left_id,down_id,right_id, &
+              up_id,mpp_land_com_real, my_id, io_id, numprocs, &
+             mpp_land_sync,mpp_land_com_integer,mpp_land_max_int1, &
+             sum_real1
+#endif
+     implicit none
+        integer,INTENT(IN) :: IX,JX,NSOIL,IXRT,JXRT,AGGFACTRT
+        real, INTENT(OUT), DIMENSION(IX,JX,NSOIL) :: SICE
+        real, INTENT(IN),  DIMENSION(IX,JX,NSOIL) :: SMC,SH2OX
+        real, INTENT(IN),  DIMENSION(IX,JX) :: INFXSRT, area_lsm, SMCMAX1,SMCREF1, &
+                                               SMCWLT1,  LKSAT
+        integer, INTENT(IN), DIMENSION(IX,JX)      :: VEGTYP, soiltyp
+
+        real,INTENT(IN),DIMENSION(IXRT,JXRT,9)::dist
+        real,INTENT(IN),DIMENSION(IXRT,JXRT)::INFXSWGT,OVROUGHRTFAC, &
+               LKSATFAC
+        integer,INTENT(INOUT), DIMENSION(IXRT,JXRT)     ::CH_NETRT, soiltypRT
+        real,INTENT(IN),DIMENSION(IXRT,JXRT,NSOIL)::SH2OWGT
+        real,INTENT(OUT),DIMENSION(IXRT,JXRT,NSOIL)::SMCREFRT, SMCMAXRT, &
+               SMCWLTRT,SMCRT
+        real,INTENT(OUT),DIMENSION(IXRT,JXRT)::INFXSUBRT
+        real,INTENT(INOUT),DIMENSION(IXRT,JXRT)::OVROUGHRT, LKSATRT
+        integer,INTENT(INOUT), DIMENSION(IXRT,JXRT)  ::LAKE_MSKRT
+                  
+
+        real,INTENT(IN), DIMENSION(NSOIL)      :: SLDPTH
+        REAL    OV_ROUGH(*)
+
+
+
+        integer :: i, j, AGGFACYRT, AGGFACXRT, IXXRT, JYYRT,KRT, KF
+        REAL  ::  LSMVOL,SMCEXCS, WATHOLDCAP
+
+#ifdef HYDRO_D
+! ADCHANGE: Water balance variables
+       integer :: kk
+       real    :: smctot1,smcrttot2
+       real    :: sicetot1
+       real    :: suminfxs1,suminfxsrt2
+#endif
+
+!-------------------------------------
+
+
+
+	SICE=SMC-SH2OX
+        SMCREFRT = 0
+
+!DJG First, Disaggregate a few key fields for routing...
+!DJG Debug...
+#ifdef HYDRO_D
+	print *, "Beginning Disaggregation..."
+#endif
+	
+!DJG Mass balance check for disagg...
+
+#ifdef HYDRO_D
+! ADCHANGE: START Initial water balance variables
+! ALL VARS in MM
+        suminfxs1 = 0.
+        smctot1 = 0.
+        sicetot1 = 0.
+        do i=1,IX
+         do j=1,JX
+            suminfxs1 = suminfxs1 + INFXSRT(I,J) / float(IX*JX)
+            do kk=1,NSOIL
+                smctot1 = smctot1 + SMC(I,J,KK)*SLDPTH(KK)*1000. / float(IX*JX)
+                sicetot1 = sicetot1 + SICE(I,J,KK)*SLDPTH(KK)*1000. / float(IX*JX)
+            end do
+         end do
+        end do
+
+#ifdef MPP_LAND
+! not tested
+        CALL sum_real1(suminfxs1)
+        CALL sum_real1(smctot1)
+        CALL sum_real1(sicetot1)
+        suminfxs1 = suminfxs1/float(numprocs)
+        smctot1 = smctot1/float(numprocs)
+        sicetot1 = sicetot1/float(numprocs)
+#endif
+! END Initial water balance variables
+#endif
+
+!DJG Weighting alg. alteration...(prescribe wghts if time = 1)
+
+
+        do J=1,JX
+          do I=1,IX
+
+!DJG Weighting alg. alteration...
+              LSMVOL=INFXSRT(I,J)*area_lsm(I,J)
+
+
+             do AGGFACYRT=AGGFACTRT-1,0,-1
+              do AGGFACXRT=AGGFACTRT-1,0,-1
+
+               IXXRT=I*AGGFACTRT-AGGFACXRT
+               JYYRT=J*AGGFACTRT-AGGFACYRT
+#ifdef MPP_LAND
+       if(left_id.ge.0) IXXRT=IXXRT+1
+       if(down_id.ge.0) JYYRT=JYYRT+1
+#else
+!yw ????
+!       IXXRT=IXXRT+1
+!       JYYRT=JYYRT+1
+#endif
+!        if(AGGFACTRT .eq. 1) then
+!            IXXRT=I
+!            JYYRT=J
+!        endif
+
+
+!DJG Implement subgrid weighting routine...
+               INFXSUBRT(IXXRT,JYYRT)=LSMVOL*     &
+                   INFXSWGT(IXXRT,JYYRT)/dist(IXXRT,JYYRT,9)
+  
+
+            do KRT=1,NSOIL  !Do for soil profile loop
+               IF(SICE(I,J,KRT).gt.0) then  !...adjust for soil ice
+!DJG Adjust SMCMAX for SICE when subsfc routing...make 3d variable
+                 SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J)-SICE(I,J,KRT)
+                 SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J)-SICE(I,J,KRT)
+                 WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J)
+                 IF (SICE(I,J,KRT).le.WATHOLDCAP)    then
+                        SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J)      
+                 else
+                    if(SICE(I,J,KRT).lt.SMCMAX1(I,J)) &
+                          SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) - &
+                          (SICE(I,J,KRT)-WATHOLDCAP)
+                    if(SICE(I,J,KRT).ge.SMCMAX1(I,J)) SMCWLTRT(IXXRT,JYYRT,KRT) = 0.
+                 end if
+               ELSE
+                 SMCMAXRT(IXXRT,JYYRT,KRT)=SMCMAX1(I,J)
+                 SMCREFRT(IXXRT,JYYRT,KRT)=SMCREF1(I,J)
+                 WATHOLDCAP = SMCMAX1(I,J) - SMCWLT1(I,J)
+                 SMCWLTRT(IXXRT,JYYRT,KRT) = SMCWLT1(I,J) 
+               END IF   !endif adjust for soil ice...
+
+
+!Now Adjust soil moisture
+!DJG Use SH2O instead of SMC for 'liquid' water...
+                 IF(SMCMAXRT(IXXRT,JYYRT,KRT).GT.0) THEN !Check for smcmax data (=0 over water)
+                   SMCRT(IXXRT,JYYRT,KRT)=SH2OX(I,J,KRT)*SH2OWGT(IXXRT,JYYRT,KRT)
+!old                   SMCRT(IXXRT,JYYRT,KRT)=SMC(I,J,KRT)
+                 ELSE
+                   SMCRT(IXXRT,JYYRT,KRT) = 0.001  !will be skipped w/ landmask
+                   SMCMAXRT(IXXRT,JYYRT,KRT) = 0.001
+                 END IF
+!DJG Check/Adjust so that subgrid cells do not exceed saturation...
+                 IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN
+                   SMCEXCS = (SMCRT(IXXRT,JYYRT,KRT) - SMCMAXRT(IXXRT,JYYRT,KRT)) &
+                             * SLDPTH(KRT)*1000.  !Excess soil water in units of (mm)
+                   SMCRT(IXXRT,JYYRT,KRT) = SMCMAXRT(IXXRT,JYYRT,KRT)
+                   DO KF = KRT-1,1, -1  !loop back upward to redistribute excess water from disagg.
+                     SMCRT(IXXRT,JYYRT,KF) = SMCRT(IXXRT,JYYRT,KF) + SMCEXCS/(SLDPTH(KF)*1000.) 
+                     IF (SMCRT(IXXRT,JYYRT,KF).GT.SMCMAXRT(IXXRT,JYYRT,KF)) THEN  !Recheck new lyr sat.
+                       SMCEXCS = (SMCRT(IXXRT,JYYRT,KF) - SMCMAXRT(IXXRT,JYYRT,KF)) &
+                           * SLDPTH(KF)*1000.  !Excess soil water in units of (mm)
+                       SMCRT(IXXRT,JYYRT,KF) = SMCMAXRT(IXXRT,JYYRT,KF)
+                     ELSE  ! Excess soil water expired
+                       SMCEXCS = 0.
+                       EXIT
+                     END IF
+                   END DO
+                   IF (SMCEXCS.GT.0) THEN  !If not expired by sfc then add to Infil. Excess
+                     INFXSUBRT(IXXRT,JYYRT) = INFXSUBRT(IXXRT,JYYRT) + SMCEXCS
+                     SMCEXCS = 0.
+                   END IF
+                 END IF  !End if for soil moisture saturation excess
+
+
+             end do !End do for soil profile loop
+
+
+
+             do KRT=1,NSOIL  !debug loop
+               IF (SMCRT(IXXRT,JYYRT,KRT).GT.SMCMAXRT(IXXRT,JYYRT,KRT)) THEN
+                      print *, "FATAL ERROR: SMCMAX exceeded upon disaggregation3...", ixxrt,jyyrt,krt,&
+                       SMCRT(IXXRT,JYYRT,KRT),SMCMAXRT(IXXRT,JYYRT,KRT)
+                      call hydro_stop("In disaggregateDomain() - SMCMAX exceeded upon disaggregation3")
+               ELSE IF (SMCRT(IXXRT,JYYRT,KRT).LE.0.) THEN
+                       print *, "FATAL ERROR: SMCRT fully depleted upon disaggregation...", ixxrt,jyyrt,krt,&
+                       "SMCRT=",SMCRT(IXXRT,JYYRT,KRT),"SH2OWGT=",SH2OWGT(IXXRT,JYYRT,KRT),&
+                       "SH2O=",SH2OX(I,J,KRT)
+                       print*, "SMC=", SMC(i,j,KRT), "SICE =", sice(i,j,KRT)
+                       print *, "VEGTYP = ", VEGTYP(I,J)
+                       print *, "i,j,krt, nsoil",i,j,krt,nsoil
+! ADCHANGE: If values are close but not exact, end up with a crash. Force values to match.
+                       !IF (SMC(i,j,KRT).EQ.sice(i,j,KRT)) THEN
+                       IF (ABS(SMC(i,j,KRT) - sice(i,j,KRT)) .LE. 0.00001) THEN
+                               print *, "SMC = SICE, soil layer totally frozen, proceeding..."
+			       SMCRT(IXXRT,JYYRT,KRT) = 0.001
+			       sice(i,j,KRT) = SMC(i,j,KRT)
+                       ELSE
+                               call hydro_stop("In disaggregateDomain() - SMCRT depleted")
+                       END IF
+               END IF
+             end do !debug loop
+
+
+
+!DJG map ov roughness as function of land use provided in VEGPARM.TBL...
+! --- added extra check for VEGTYP for 'masked-out' locations...
+! --- out of basin locations (VEGTYP=0) have OVROUGH hardwired to 0.1
+            IF (VEGTYP(I,J).LE.0) then
+              OVROUGHRT(IXXRT,JYYRT) = 0.1     !COWS mask test
+            ELSE
+               OVROUGHRT(IXXRT,JYYRT)=OV_ROUGH(VEGTYP(I,J))*OVROUGHRTFAC(IXXRT,JYYRT)  ! Distributed calibration...1/17/2012
+            END IF
+
+
+
+!DJG 6.12.08 Map lateral hydraulic conductivity and apply distributed scaling
+! ---        factor that will be read in from hires terrain file
+!              LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) 
+!              LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) * LKSATFAC(IXXRT,JYYRT) * &  !Apply scaling factor...
+! ...and scale from max to 0 when SMC decreases from SMCMAX to SMCREF...
+!!DJG error found from KIT,improper scaling       ((SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL)) / &
+!                                    (max(0.,(SMCMAXRT(IXXRT,JYYRT,NSOIL) - SMCRT(IXXRT,JYYRT,NSOIL))) / &
+!                                    (SMCMAXRT(IXXRT,JYYRT,NSOIL)-SMCREFRT(IXXRT,JYYRT,NSOIL)) )
+
+!AD_CHANGE: 
+!New model corrected to scale from 0 at SMCREF to full LKSAT*LKSATFAC at SMCMAX:
+		LKSATRT(IXXRT,JYYRT) = LKSAT(I,J) * LKSATFAC(IXXRT,JYYRT) * &
+				min (1., &     !just in case, make sure scale factor doesn't go over 1
+					( max(0.,(SMCRT(IXXRT,JYYRT,NSOIL) - SMCREFRT(IXXRT,JYYRT,NSOIL))) / &     !becomes 0 if less than SMCREF
+				(SMCMAXRT(IXXRT,JYYRT,NSOIL)-SMCREFRT(IXXRT,JYYRT,NSOIL)) ) )
+
+!DJG set up lake mask...
+!--- modify to make lake mask large here, but not one of the routed lakes!!!
+!--            IF (VEGTYP(I,J).eq.16) then
+               IF (VEGTYP(I,J).eq.16 .and. &
+                        CH_NETRT(IXXRT,JYYRT).le.0) then
+                 !--LAKE_MSKRT(IXXRT,JYYRT) = 1
+!yw                 LAKE_MSKRT(IXXRT,JYYRT) = 9999
+                 LAKE_MSKRT(IXXRT,JYYRT) = -9999
+               end if
+               ! BF disaggregate soiltype information for gw-soil-coupling
+	       ! TODO: move this disaggregation code line to lsm_init section because soiltype is time-invariant
+               soiltypRT(ixxrt,jyyrt) = soiltyp(i,j)
+
+
+              end do
+             end do
+
+          end do
+        end do
+
+#ifdef HYDRO_D
+! ADCHANGE: START Final water balance variables
+! ALL VARS in MM
+        suminfxsrt2 = 0.
+        smcrttot2 = 0.
+        do i=1,IXRT
+          do j=1,JXRT
+            suminfxsrt2 = suminfxsrt2 + INFXSUBRT(I,J) / float(IXRT*JXRT)
+            do kk=1,NSOIL
+                smcrttot2 = smcrttot2 + SMCRT(I,J,KK)*SLDPTH(KK)*1000. / float(IXRT*JXRT)
+            end do
+          end do
+        end do
+
+#ifdef MPP_LAND
+! not tested
+        CALL sum_real1(suminfxsrt2)
+        CALL sum_real1(smcrttot2)
+       suminfxsrt2 = suminfxsrt2/float(numprocs)
+       smcrttot2 = smcrttot2/float(numprocs)
+#endif
+#ifdef MPP_LAND   
+       if(my_id .eq. IO_id) then
+#endif
+        print *, "Disagg Mass Bal: "
+        print *, "WB_DISAG!InfxsDiff", suminfxsrt2-suminfxs1
+        print *, "WB_DISAG!Infxs1", suminfxs1
+        print *, "WB_DISAG!Infxs2", suminfxsrt2
+        print *, "WB_DISAG!SMCDIff", smcrttot2-(smctot1-sicetot1)
+        print *, "WB_DISAG!SMC1", smctot1
+        print *, "WB_DISAG!SICE1", sicetot1
+        print *, "WB_DISAG!SMC2", smcrttot2
+        print *, "WB_DISAG!Residual", (suminfxsrt2-suminfxs1) + &
+                         (smcrttot2-(smctot1-sicetot1))
+#ifdef MPP_LAND
+       endif
+#endif
+! END Final water balance variables
+#endif
+
+#ifdef HYDRO_D
+	print *, "After Disaggregation..."
+#endif
+
+#ifdef MPP_LAND
+        call MPP_LAND_COM_REAL(INFXSUBRT,IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(LKSATRT,IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(OVROUGHRT,IXRT,JXRT,99)
+        call MPP_LAND_COM_INTEGER(LAKE_MSKRT,IXRT,JXRT,99)
+     do i = 1, NSOIL
+        call MPP_LAND_COM_REAL(SMCMAXRT(:,:,i),IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(SMCRT(:,:,i),IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(SMCWLTRT(:,:,i),IXRT,JXRT,99)
+     end DO
+#endif
+
+     end subroutine disaggregateDomain
+
+         subroutine SubsurfaceRouting_drv(did)
+
+             use module_RT_data, only: rt_domain
+             use module_namelist, only: nlst_rt
+             implicit none
+             integer :: did
+             IF (nlst_rt(did)%SUBRTSWCRT.EQ.1) THEN
+                call subsurfaceRouting (RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt , nlst_rt(did)%nsoil, &
+                     RT_DOMAIN(did)%SMCRT,RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCREFRT,&
+                     RT_DOMAIN(did)%SMCWLTRT, RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SLDPTH, & 
+                     nlst_rt(did)%DT,RT_DOMAIN(did)%ZWATTABLRT,RT_DOMAIN(did)%SOXRT,       &
+                     RT_DOMAIN(did)%SOYRT,RT_DOMAIN(did)%LKSATRT, RT_DOMAIN(did)%SOLDEPRT, &
+                     RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%QSUBBDRYTRT, RT_DOMAIN(did)%QSUBBDRYRT,&
+                     RT_DOMAIN(did)%QSUBRT ,nlst_rt(did)%rt_option, RT_DOMAIN(did)%dist, &
+                     RT_DOMAIN(did)%sub_resid,RT_DOMAIN(did)%SO8RT_D, RT_DOMAIN(did)%SO8RT)
+             endif
+
+         end subroutine SubsurfaceRouting_drv
+     
+         subroutine subsurfaceRouting (ixrt, jxrt , nsoil, &
+                  SMCRT,SMCMAXRT,SMCREFRT,SMCWLTRT, &
+                  ZSOIL, SLDPTH, &
+                  DT,ZWATTABLRT,SOXRT,SOYRT,LKSATRT,&
+                  SOLDEPRT,INFXSUBRT,QSUBBDRYTRT, QSUBBDRYRT,&
+                  QSUBRT ,rt_option, dist,sub_resid,SO8RT_D, SO8RT)
+#ifdef MPP_LAND
+        use module_mpp_land, only:  mpp_land_com_real, mpp_land_com_integer
+#endif
+         implicit none
+         integer, INTENT(IN) :: ixrt, jxrt , nsoil, rt_option
+         REAL, INTENT(IN)                          :: DT
+         real,INTENT(IN), DIMENSION(NSOIL)      :: ZSOIL, SLDPTH
+         REAL, INTENT(IN), DIMENSION(IXRT,JXRT)   :: SOXRT,SOYRT,LKSATRT, SOLDEPRT , sub_resid
+         real,INTENT(INOUT), DIMENSION(IXRT,JXRT)::INFXSUBRT
+         real,INTENT(INOUT) :: QSUBBDRYTRT
+         REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)   :: QSUBBDRYRT, QSUBRT
+         REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT,NSOIL) :: SMCRT, SMCWLTRT, SMCMAXRT,SMCREFRT
+
+
+         INTEGER :: SO8RT_D(IXRT,JXRT,3)
+         REAL :: SO8RT(IXRT,JXRT,8)
+         REAL, INTENT(IN)                          :: dist(ixrt,jxrt,9)
+!  -----local array ----------
+         REAL, DIMENSION(IXRT,JXRT)   :: ZWATTABLRT
+         REAL, DIMENSION(IXRT,JXRT)   :: CWATAVAIL
+         INTEGER, DIMENSION(IXRT,JXRT) :: SATLYRCHK
+ 
+
+
+
+         CWATAVAIL = 0.
+         CALL FINDZWAT(IXRT,JXRT,NSOIL,SMCRT,SMCMAXRT,SMCREFRT, &
+                             SMCWLTRT,ZSOIL,SATLYRCHK,ZWATTABLRT, &
+                             CWATAVAIL,SLDPTH)
+#ifdef MPP_LAND
+        call MPP_LAND_COM_REAL(ZWATTABLRT,IXRT,JXRT,99)
+        call MPP_LAND_COM_REAL(CWATAVAIL,IXRT,JXRT,99)
+        call MPP_LAND_COM_INTEGER(SATLYRCHK,IXRT,JXRT,99)
+#endif
+
+
+!DJG Second, Call subsurface routing routine...
+#ifdef HYDRO_D
+	print *, "Beginning SUB_routing..."
+        print *, "Routing method is ",rt_option, " direction."
+#endif
+
+!!!! Find saturated layer depth...
+! Loop through domain to determine sat. layers and assign wat tbl depth...
+!    and water available for subsfc routing (CWATAVAIL)...
+! This subroutine returns: ZWATTABLRT, CWATAVAIL and SATLYRCHK
+
+
+    CALL SUBSFC_RTNG(dist,ZWATTABLRT,QSUBRT,SOXRT,SOYRT,  &
+          LKSATRT,SOLDEPRT,QSUBBDRYRT,QSUBBDRYTRT,NSOIL,SMCRT,     &
+          INFXSUBRT,SMCMAXRT,SMCREFRT,ZSOIL,IXRT,JXRT,DT,SMCWLTRT,SO8RT,    &
+          SO8RT_D, rt_option,SLDPTH,SUB_RESID,CWATAVAIL,SATLYRCHK)
+
+#ifdef HYDRO_D
+    print *, "SUBROUTE routing called and returned..."
+#endif
+
+    end subroutine subsurfaceRouting 
+
+   
+       subroutine OverlandRouting_drv(did)
+             use module_RT_data, only: rt_domain
+             use module_namelist, only: nlst_rt
+             implicit none
+             integer :: did
+             if(nlst_rt(did)%OVRTSWCRT .eq. 1) then
+                 call OverlandRouting (nlst_rt(did)%DT, nlst_rt(did)%DTRT_TER, nlst_rt(did)%rt_option, &
+                          rt_domain(did)%ixrt, rt_domain(did)%jxrt,rt_domain(did)%LAKE_MSKRT, &
+                          rt_domain(did)%INFXSUBRT, rt_domain(did)%RETDEPRT,rt_domain(did)%OVROUGHRT, &
+                          rt_domain(did)%SOXRT, rt_domain(did)%SOYRT, rt_domain(did)%SFCHEADSUBRT,  &
+                          rt_domain(did)%DHRT, rt_domain(did)%CH_NETRT, rt_domain(did)%QSTRMVOLRT, &
+                          rt_domain(did)%LAKE_INFLORT,rt_domain(did)%QBDRYRT, &
+                          rt_domain(did)%QSTRMVOLTRT,rt_domain(did)%QBDRYTRT, rt_domain(did)%LAKE_INFLOTRT,&
+                          rt_domain(did)%q_sfcflx_x,rt_domain(did)%q_sfcflx_y, &
+                          rt_domain(did)%dist, rt_domain(did)%SO8RT, rt_domain(did)%SO8RT_D , &
+                          rt_domain(did)%SMCTOT2,rt_domain(did)%suminfxs1,rt_domain(did)%suminfxsrt, &
+                          rt_domain(did)%smctot1,rt_domain(did)%dsmctot )
+! ADCHANGE: If overland routing is called, INFXSUBRT is moved to SFCHEADSUBRT, so 
+!           zeroing out just in case
+             rt_domain(did)%INFXSUBRT = 0.0
+             endif
+       end subroutine OverlandRouting_drv
+
+
+
+       subroutine OverlandRouting (DT, DTRT_TER, rt_option, ixrt, jxrt,LAKE_MSKRT, &
+                  INFXSUBRT, RETDEPRT,OVROUGHRT,SOXRT, SOYRT, SFCHEADSUBRT,DHRT, &
+                  CH_NETRT, QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, &
+                  QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y, &
+                  dist, SO8RT, SO8RT_D, &
+                  SMCTOT2,suminfxs1,suminfxsrt,smctot1,dsmctot )
+#ifdef MPP_LAND
+        use module_mpp_land, only:  mpp_land_max_int1,  sum_real1, my_id, io_id, numprocs
+#endif
+       implicit none
+
+       REAL, INTENT(IN) :: DT, DTRT_TER
+       integer, INTENT(IN) :: ixrt, jxrt, rt_option
+       INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT
+
+       REAL, INTENT(IN), DIMENSION(IXRT,JXRT)   :: INFXSUBRT,  &
+                 RETDEPRT,OVROUGHRT,SOXRT, SOYRT
+       REAL, INTENT(OUT), DIMENSION(IXRT,JXRT) :: SFCHEADSUBRT,DHRT
+       INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT
+       REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: QSTRMVOLRT,LAKE_INFLORT,QBDRYRT, &
+                QSTRMVOLTRT,QBDRYTRT, LAKE_INFLOTRT, q_sfcflx_x,q_sfcflx_y
+
+       REAL, INTENT(IN), DIMENSION(IXRT,JXRT,9):: dist
+       REAL, INTENT(IN), DIMENSION(IXRT,JXRT,8)  :: SO8RT
+       INTEGER SO8RT_D(IXRT,JXRT,3)
+
+       integer  :: i,j
+      
+
+       real            :: smctot2,smctot1,dsmctot
+       real            :: suminfxsrt,suminfxs1
+! local variable
+       real            :: chan_in1,chan_in2
+       real            :: lake_in1,lake_in2
+       real            :: qbdry1,qbdry2
+       integer :: sfcrt_flag
+
+
+
+!DJG Third, Call Overland Flow Routing Routine...
+#ifdef HYDRO_D
+	print *, "Beginning OV_routing..."
+        print *, "Routing method is ",rt_option, " direction."
+#endif
+
+!DJG debug...OV Routing...
+	suminfxs1=0.
+        chan_in1=0.
+        lake_in1=0.
+        qbdry1=0.
+        do i=1,IXRT
+         do j=1,JXRT
+            suminfxs1=suminfxs1+INFXSUBRT(I,J)/float(IXRT*JXRT)
+            chan_in1=chan_in1+QSTRMVOLRT(I,J)/float(IXRT*JXRT)
+            lake_in1=lake_in1+LAKE_INFLORT(I,J)/float(IXRT*JXRT)
+            qbdry1=qbdry1+QBDRYRT(I,J)/float(IXRT*JXRT)
+         end do
+        end do
+
+#ifdef MPP_LAND
+! not tested
+        CALL sum_real1(suminfxs1)
+        CALL sum_real1(chan_in1)
+        CALL sum_real1(lake_in1)
+        CALL sum_real1(qbdry1)
+        suminfxs1 = suminfxs1/float(numprocs)
+        chan_in1 = chan_in1/float(numprocs)
+        lake_in1 = lake_in1/float(numprocs)
+        qbdry1 = qbdry1/float(numprocs)
+#endif
+
+
+!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(set sfcrt_flag)
+!DJG.7.20.2007 - this check will skip ov rtng when no flow is present...
+        
+        sfcrt_flag = 0
+        
+        do j=1,jxrt
+          do i=1,ixrt
+            if(INFXSUBRT(i,j).gt.RETDEPRT(i,j)) then
+              sfcrt_flag = 1
+              exit
+            end if
+          end do
+          if(sfcrt_flag.eq.1) exit
+        end do   
+
+#ifdef MPP_LAND
+       call mpp_land_max_int1(sfcrt_flag)            
+#endif
+!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(IF)
+
+    if (sfcrt_flag.eq.1) then  !If/then for sfc_rt check...
+#ifdef HYDRO_D
+      write(6,*) "calling OV_RTNG "
+#endif
+      CALL OV_RTNG(DT,DTRT_TER,IXRT,JXRT,INFXSUBRT,SFCHEADSUBRT,DHRT,      &
+        CH_NETRT,RETDEPRT,OVROUGHRT,QSTRMVOLRT,QBDRYRT,              &
+        QSTRMVOLTRT,QBDRYTRT,SOXRT,SOYRT,dist,                       &
+        LAKE_MSKRT,LAKE_INFLORT,LAKE_INFLOTRT,SO8RT,SO8RT_D,rt_option,&
+        q_sfcflx_x,q_sfcflx_y) 
+    else
+      SFCHEADSUBRT = INFXSUBRT
+#ifdef HYDRO_D
+      print *, "No water to route overland..."
+#endif
+    end if  !Endif for sfc_rt check...
+
+!DJG.7.20.2007 - Global check for infxs>retdep & skip if not...(ENDIF)
+
+#ifdef HYDRO_D
+    print *, "OV routing called and returned..."
+#endif
+
+!DJG Debug...OV Routing...
+	suminfxsrt=0.
+        chan_in2=0.
+        lake_in2=0.
+        qbdry2=0.
+        do i=1,IXRT
+         do j=1,JXRT
+            suminfxsrt=suminfxsrt+SFCHEADSUBRT(I,J)/float(IXRT*JXRT)
+            chan_in2=chan_in2+QSTRMVOLRT(I,J)/float(IXRT*JXRT)
+            lake_in2=lake_in2+LAKE_INFLORT(I,J)/float(IXRT*JXRT)
+            qbdry2=qbdry2+QBDRYRT(I,J)/float(IXRT*JXRT)
+         end do
+        end do
+#ifdef MPP_LAND
+! not tested
+        CALL sum_real1(suminfxsrt)
+        CALL sum_real1(chan_in2)
+        CALL sum_real1(lake_in2)
+        CALL sum_real1(qbdry2)
+        suminfxsrt = suminfxsrt/float(numprocs)
+        chan_in2 = chan_in2/float(numprocs)
+        lake_in2 = lake_in2/float(numprocs)
+        qbdry2 = qbdry2/float(numprocs)
+#endif
+
+#ifdef HYDRO_D
+#ifdef MPP_LAND   
+       if(my_id .eq. IO_id) then
+#endif
+	print *, "OV Routing Mass Bal: "
+        print *, "WB_OV!InfxsDiff", suminfxsrt-suminfxs1
+        print *, "WB_OV!Infxs1", suminfxs1
+        print *, "WB_OV!Infxs2", suminfxsrt
+        print *, "WB_OV!ChaninDiff", chan_in2-chan_in1
+        print *, "WB_OV!Chanin1", chan_in1
+        print *, "WB_OV!Chanin2", chan_in2
+        print *, "WB_OV!LakeinDiff", lake_in2-lake_in1
+        print *, "WB_OV!Lakein1", lake_in1
+        print *, "WB_OV!Lakein2", lake_in2
+        print *, "WB_OV!QbdryDiff", qbdry2-qbdry1
+        print *, "WB_OV!Qbdry1", qbdry1
+        print *, "WB_OV!Qbdry2", qbdry2
+        print *, "WB_OV!Residual", (suminfxs1-suminfxsrt)-(chan_in2-chan_in1) &
+                      -(lake_in2-lake_in1)-(qbdry2-qbdry1)
+#ifdef MPP_LAND
+       endif
+#endif
+#endif
+
+
+       end subroutine OverlandRouting
+
+
+      subroutine time_seconds(i3)
+          integer time_array(8)
+          real*8 i3
+          call date_and_time(values=time_array)
+          i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + &
+                time_array(7) + 0.001 * time_array(8)
+          return
+      end subroutine time_seconds
+
diff --git a/wrfv2_fire/hydro/Routing/module_GW_baseflow.F b/wrfv2_fire/hydro/Routing/module_GW_baseflow.F
new file mode 100644
index 00000000..299e15ac
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_GW_baseflow.F
@@ -0,0 +1,528 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+module module_GW_baseflow
+
+#ifdef MPP_LAND
+   use module_mpp_land
+   use MODULE_mpp_GWBUCKET, only: gw_sum_real, gw_write_io_real
+   use MODULE_mpp_ReachLS, only : updatelinkv
+#endif
+   implicit none
+
+#include "rt_include.inc"
+!yw #include "namelist.inc"
+contains
+
+!------------------------------------------------------------------------------
+!DJG   Simple GW Bucket Model 
+!      for NHDPLUS mapping
+!------------------------------------------------------------------------------
+
+   subroutine simp_gw_buck_nhd(ix,jx,ixrt,jxrt,numbasns, AGGFACTRT, DT, INFXSWGT         &
+           , runoff1x_in, runoff2x_in,cellArea,area_lsm    &
+           , c, ex,z_mx,z_gwsubbas_tmp, qout_gwsubbas, qin_gwsubbas,GWBASESWCRT,OVRTSWCRT   &
+           , LNLINKSL, basns_area, nhdBuckMask ) 
+
+   use module_UDMAP, only: LNUMRSL, LUDRSL
+
+   implicit none
+   
+!!!Declarations...
+   integer, intent(in)                               :: ix,jx,ixrt,jxrt
+   integer, intent(in)                               :: numbasns, lnlinksl
+   real, intent(in), dimension(ix,jx)                :: runoff2x_in 
+   real, dimension(ixrt,jxrt)                            :: runoff2x , runoff1x
+   real, intent(in), dimension(ix,jx)                :: runoff1x_in, area_lsm
+   real, intent(in)                                  :: cellArea(ixrt,jxrt),DT
+   real, intent(in),dimension(numbasns)              :: C,ex
+   real, intent(inout),dimension(numbasns)              :: z_mx
+   real, intent(out),dimension(numbasns)             :: qout_gwsubbas
+   real, intent(out),dimension(numbasns)             :: qin_gwsubbas
+   real*8                                            :: z_gwsubbas(numbasns)
+   real                                              :: qout_max, qout_spill, z_gw_spill
+   real, intent(inout),dimension(:)           :: z_gwsubbas_tmp
+   real, intent(in),dimension(ixrt,jxrt)          ::  INFXSWGT
+   integer, intent(in)                               :: GWBASESWCRT
+   integer, intent(in)                               :: OVRTSWCRT
+   real, intent(in), dimension(numbasns)             :: basns_area
+   
+
+   real, dimension(numbasns)                        :: net_perc
+   integer, dimension(numbasns)                        :: nhdBuckMask
+
+   integer                                          :: i,j,bas, k, m, ii,jj
+
+   integer :: AGGFACYRT, AGGFACTRT, AGGFACXRT, IXXRT, JYYRT
+   real*8,  dimension(LNLINKSL) :: LQLateral
+
+
+
+!!!Initialize variables...
+   net_perc = 0.
+   qout_gwsubbas = 0.
+   qin_gwsubbas = 0.
+   z_gwsubbas(1:numbasns) = z_gwsubbas_tmp(1:numbasns)
+
+!Assign local value of runoff2 (drainage) for flux caluclation to buckets...
+
+        do J=1,JX
+        do I=1,IX
+             do AGGFACYRT=AGGFACTRT-1,0,-1
+             do AGGFACXRT=AGGFACTRT-1,0,-1
+               IXXRT=I*AGGFACTRT-AGGFACXRT
+               JYYRT=J*AGGFACTRT-AGGFACYRT
+#ifdef MPP_LAND  
+       if(left_id.ge.0) IXXRT=IXXRT+1
+       if(down_id.ge.0) JYYRT=JYYRT+1
+!              if(AGGFACTRT .eq. 1) then
+!                  IXXRT=I
+!                  JYYRT=J
+!             endif
+#endif
+!DJG Implement subgrid weighting routine...
+               if( (runoff1x_in(i,j) .lt. 0) .or. (runoff1x_in(i,j) .gt. 1000) ) then
+                    runoff1x(IXXRT,JYYRT) = 0
+               else
+                    runoff1x(IXXRT,JYYRT)=runoff1x_in(i,j)*area_lsm(I,J)     &
+                        *INFXSWGT(IXXRT,JYYRT)/cellArea(IXXRT,JYYRT)
+               endif
+
+               if( (runoff2x_in(i,j) .lt. 0) .or. (runoff2x_in(i,j) .gt. 1000) ) then
+                    runoff2x(IXXRT,JYYRT) = 0
+               else
+                  runoff2x(IXXRT,JYYRT)=runoff2x_in(i,j)*area_lsm(I,J)     &
+                      *INFXSWGT(IXXRT,JYYRT)/cellArea(IXXRT,JYYRT)
+               endif
+             enddo
+             enddo
+        enddo
+        enddo
+
+
+       LQLateral = 0
+       do k = 1, LNUMRSL
+              ! get from land grid runoff
+               do m = 1, LUDRSL(k)%ncell 
+                   ii =  LUDRSL(k)%cell_i(m)
+                   jj =  LUDRSL(k)%cell_j(m)
+                   if(ii .gt. 0 .and. jj .gt. 0) then
+                      if(OVRTSWCRT.ne.1) then
+                           LQLateral(k) = LQLateral(k)+runoff1x(ii,jj)*LUDRSL(k)%cellWeight(m)/1000 &
+                               *cellArea(ii,jj)
+                      endif
+                           LQLateral(k) = LQLateral(k)+runoff2x(ii,jj)*LUDRSL(k)%cellWeight(m)/1000 &
+                               *cellArea(ii,jj)
+                   endif
+               end do
+       end do
+
+
+#ifdef MPP_LAND
+       call updateLinkV(LQLateral, net_perc)      ! m^3
+
+#else
+       net_perc = LQLateral        ! m^3
+#endif
+
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!Loop through GW basins to adjust for inflow/outflow
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+
+   DO bas=1,numbasns     ! Loop for GW bucket calcs...
+      if(nhdBuckMask(bas) .eq. 1) then     ! if the basn is masked
+          qin_gwsubbas(bas) = net_perc(bas)             !units (m^3)
+
+!Adjust level of GW depth...(conceptual GW bucket units (mm))
+
+          z_gwsubbas(bas) = z_gwsubbas(bas) + net_perc(bas) / basns_area(bas)   ! m
+    
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Calculate baseflow as a function of GW bucket depth...
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+          if(GWBASESWCRT.eq.1) then  !active exponential bucket... if/then for bucket model discharge type...
+
+!DJG...Estimation of bucket 'overflow' (qout_spill) if/when bucket gets filled...
+               qout_spill = 0.
+               z_gw_spill = 0.
+
+!!DJG...convert z_mx to millimeters...for v2 and later...
+!yw  added by Wei Yu...If block is to accomodate old parameter file...
+!                    if(z_mx(bas) .gt. 5) then
+!                         z_mx(bas) = z_mx(bas) /1000    ! change from mm to meters
+!                    endif
+ 
+
+               if (z_gwsubbas(bas).gt.z_mx(bas)/1000.) then  !If/then for bucket overflow case...
+
+                    z_gw_spill = z_gwsubbas(bas) - z_mx(bas)/1000.    ! meters
+                    z_gwsubbas(bas) = z_mx(bas)/1000.    ! meters
+
+               else
+                      z_gw_spill = 0.
+               end if   ! End if for bucket overflow case...
+
+               qout_spill = z_gw_spill*(basns_area(bas))/DT  !amount spilled from bucket overflow...units (m^3/s)
+
+!DJG...Maximum estimation of bucket outlfow that is limited by total quantity in bucket...
+               qout_max = z_gwsubbas(bas)*(basns_area(bas))/DT   ! (m^3/s)   ! Estimate max bucket disharge limit to total volume in bucket...(m^3/s)
+
+
+! Assume exponential relation between z/zmax and Q...
+!DJG force asymptote to zero to prevent 'overdraft'... 
+               qout_gwsubbas(bas) = C(bas)*(EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas)/1000.)-1) !Exp.model. q_out (m^3/s)
+       
+!DJG...Calculation of max bucket outlfow that is limited by total quantity in bucket...
+               qout_gwsubbas(bas) = MIN(qout_max,qout_gwsubbas(bas))   ! Limit bucket discharge to max. bucket limit   (m^3/s)
+
+          elseif (GWBASESWCRT.eq.2) then  !Pass through/steady-state bucket
+
+! Assuming a steady-state (inflow=outflow) model...
+!DJG convert input and output units to cms...       qout_gwsubbas(bas) = qin_gwsubbas(bas)  !steady-state model...(m^3)
+               qout_gwsubbas(bas) = qin_gwsubbas(bas)/DT  !steady-state model...(m^3/s)
+
+          end if    ! End if for bucket model discharge type....
+
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Adjust level of GW depth in bucket...
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+
+          z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT/( &
+                       basns_area(bas) )   ! units (meters)	
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!Combine calculated bucket discharge and amount spilled from bucket...
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+          qout_gwsubbas(bas) = qout_gwsubbas(bas) + qout_spill   ! units (m^3/s)
+      else
+          qout_gwsubbas(bas) = 0.0
+      endif   ! the basns is masked
+
+
+   END DO                 ! End loop for GW bucket calcs...
+
+   z_gwsubbas_tmp(1:numbasns) = z_gwsubbas(1:numbasns)     ! units (meters)
+
+   return
+
+!------------------------------------------------------------------------------
+   End subroutine simp_gw_buck_nhd
+!------------------------------------------------------------------------------
+!------------------------------------------------------------------------------
+!DJG   Simple GW Bucket Model
+!------------------------------------------------------------------------------
+
+   subroutine simp_gw_buck(ix,jx,ixrt,jxrt,numbasns,gnumbasns,basns_area,basnsInd,gw_strm_msk_lind,&
+                            gwsubbasmsk, runoff1x_in, runoff2x_in, z_gwsubbas_tmp, qin_gwsubbas,&
+                            qout_gwsubbas,qinflowbase,gw_strm_msk,gwbas_pix_ct,dist,DT,&
+                            C,ex,z_mx,GWBASESWCRT,OVRTSWCRT)
+   implicit none
+   
+!!!Declarations...
+   integer, intent(in)                               :: ix,jx,ixrt,jxrt
+   integer, intent(in)                               :: numbasns, gnumbasns
+   integer, intent(in), dimension(ix,jx)             :: gwsubbasmsk
+   real, intent(in), dimension(ix,jx)                :: runoff2x_in 
+   real, dimension(ix,jx)                            :: runoff2x 
+   real, intent(in), dimension(ix,jx)                :: runoff1x_in
+   real, dimension(ix,jx)                            :: runoff1x
+   real, intent(in)                                  :: basns_area(numbasns),dist(ixrt,jxrt,9),DT
+   integer, intent(in)                                  :: basnsInd(numbasns)
+   real, intent(in),dimension(numbasns)              :: C,ex,z_mx
+   real, intent(out),dimension(numbasns)             :: qout_gwsubbas
+   real, intent(out),dimension(numbasns)             :: qin_gwsubbas
+   real*8                                            :: z_gwsubbas(numbasns)
+   real                                              :: qout_max, qout_spill, z_gw_spill
+   real, intent(inout),dimension(numbasns)           :: z_gwsubbas_tmp
+   real, intent(out),dimension(ixrt,jxrt)            :: qinflowbase
+   integer, intent(in),dimension(ixrt,jxrt)          :: gw_strm_msk, gw_strm_msk_lind
+   integer, intent(in)                               :: GWBASESWCRT
+   integer, intent(in)                               :: OVRTSWCRT
+   
+
+   real*8, dimension(numbasns)                      :: sum_perc8,ct_bas8
+   real, dimension(numbasns)                        :: sum_perc
+   real, dimension(numbasns)                        :: net_perc
+
+   real, dimension(numbasns)                        :: ct_bas
+   real, dimension(numbasns)                        :: gwbas_pix_ct
+   integer                                          :: i,j,bas, k
+   character(len=19)				    :: header
+   character(len=1)				    :: jnk
+
+
+!!!Initialize variables...
+   ct_bas8 = 0
+   sum_perc8 = 0.
+   net_perc = 0.
+   qout_gwsubbas = 0.
+   qin_gwsubbas = 0.
+   z_gwsubbas = z_gwsubbas_tmp
+
+!Assign local value of runoff2 (drainage) for flux caluclation to buckets...
+   runoff2x = runoff2x_in
+   runoff1x = runoff1x_in
+
+
+
+
+!!!Calculate aggregated percolation from deep runoff into GW basins...
+   do i=1,ix
+     do j=1,jx
+
+!!DJG 4/15/2015...reset runoff2x, runoff1x, values to 0 where extreme values exist...(<0 or
+!> 1000)
+       if((runoff2x(i,j).lt.0.).OR.(runoff2x(i,j).gt.1000.)) then
+         runoff2x(i,j)=0.
+       end if
+       if((runoff1x(i,j).lt.0.).OR.(runoff1x(i,j).gt.1000.)) then
+         runoff1x(i,j)=0.
+       end if
+
+       do bas=1,numbasns
+         if(gwsubbasmsk(i,j).eq.basnsInd(bas) ) then
+           if(OVRTSWCRT.ne.0) then
+             sum_perc8(bas) = sum_perc8(bas)+runoff2x(i,j)  !Add only drainage to bucket...runoff2x in (mm)
+           else
+             sum_perc8(bas) = sum_perc8(bas)+runoff1x(i,j)+runoff2x(i,j)  !Add sfc water & drainage to bucket...runoff1x and runoff2x in (mm)
+           end if
+           ct_bas8(bas) = ct_bas8(bas) + 1
+         end if
+       end do
+     end do
+   end do
+
+#ifdef MPP_LAND
+    call gw_sum_real(sum_perc8,numbasns,gnumbasns,basnsInd)
+    call gw_sum_real(ct_bas8,numbasns,gnumbasns,basnsInd)
+#endif
+   sum_perc = sum_perc8
+   ct_bas = ct_bas8
+   
+
+
+
+!!!Loop through GW basins to adjust for inflow/outflow
+
+   DO bas=1,numbasns     ! Loop for GW bucket calcs...
+! #ifdef MPP_LAND
+!      if(ct_bas(bas) .gt. 0) then
+! #endif
+
+     net_perc(bas) = sum_perc(bas) / ct_bas(bas)   !units (mm)
+!DJG...old change to cms     qin_gwsubbas(bas) = net_perc(bas)/1000. * ct_bas(bas) * basns_area(bas) !units (m^3)
+     qin_gwsubbas(bas) = net_perc(bas)/1000.* &
+                         ct_bas(bas)*basns_area(bas)/DT    !units (m^3/s)
+
+
+!Adjust level of GW depth...(conceptual GW bucket units (mm))
+!DJG...old change to cms inflow...     z_gwsubbas(bas) = z_gwsubbas(bas) + net_perc(bas) / 1000.0   ! (m)
+
+!DJG...debug    write (6,*) "DJG...before",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas)
+
+     z_gwsubbas(bas) = z_gwsubbas(bas) + qin_gwsubbas(bas)*DT/( &
+                       ct_bas(bas)*basns_area(bas))*1000.   !  units (mm)
+
+
+
+
+
+!Calculate baseflow as a function of GW bucket depth...
+
+     if(GWBASESWCRT.eq.1) then  !active exponential bucket... if/then for bucket model discharge type...
+
+!DJG...Estimation of bucket 'overflow' (qout_spill) if/when bucket gets filled...
+     qout_spill = 0.
+     z_gw_spill = 0.
+     if (z_gwsubbas(bas).gt.z_mx(bas)) then  !If/then for bucket overflow case...
+       z_gw_spill = z_gwsubbas(bas) - z_mx(bas)
+       z_gwsubbas(bas) = z_mx(bas)
+#ifdef HYDRO_D
+       write (6,*) "Bucket spilling...", bas, z_gwsubbas(bas), z_mx(bas), z_gw_spill
+#endif
+     else
+       z_gw_spill = 0.
+     end if   ! End if for bucket overflow case...
+
+     qout_spill = z_gw_spill/1000.*(ct_bas(bas)*basns_area(bas))/DT  !amount spilled from bucket overflow...units (cms)
+
+
+!DJG...Maximum estimation of bucket outlfow that is limited by total quantity in bucket...
+     qout_max = z_gwsubbas(bas)/1000.*(ct_bas(bas)*basns_area(bas))/DT   ! Estimate max bucket disharge limit to total volume in bucket...(m^3/s)
+
+
+! Assume exponential relation between z/zmax and Q...
+!DJG...old...creates non-asymptotic flow...   qout_gwsubbas(bas) = C(bas)*EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas)) !Exp.model. q_out (m^3/s)
+!DJG force asymptote to zero to prevent 'overdraft'... 
+!DJG debug hardwire test...       qout_gwsubbas(bas) = 1*(EXP(7.0*10./100.)-1) !Exp.model. q_out (m^3/s)
+     qout_gwsubbas(bas) = C(bas)*(EXP(ex(bas)*z_gwsubbas(bas)/z_mx(bas))-1) !Exp.model. q_out (m^3/s)
+       
+!DJG...Calculation of max bucket outlfow that is limited by total quantity in bucket...
+     qout_gwsubbas(bas) = MIN(qout_max,qout_gwsubbas(bas))   ! Limit bucket discharge to max. bucket limit
+
+!DJG...debug...     write (6,*) "DJG-exp bucket...during",C(bas),ex(bas),z_gwsubbas(bas),qin_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max, qout_spill
+
+
+
+     elseif (GWBASESWCRT.eq.2) then  !Pass through/steady-state bucket
+
+! Assuming a steady-state (inflow=outflow) model...
+!DJG convert input and output units to cms...       qout_gwsubbas(bas) = qin_gwsubbas(bas)  !steady-state model...(m^3)
+       qout_gwsubbas(bas) = qin_gwsubbas(bas)  !steady-state model...(m^3/s)
+
+!DJG...debug       write (6,*) "DJG-pass through...during",C(bas),ex(bas),qin_gwsubbas(bas), z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_max
+
+     end if    ! End if for bucket model discharge type....
+
+
+
+
+!Adjust level of GW depth...
+!DJG bug adjust output to be mm and correct area bug...       z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT &
+!DJG bug adjust output to be mm and correct area bug...                       / (ct_bas(bas)*basns_area(bas))   !units(m)
+
+     z_gwsubbas(bas) = z_gwsubbas(bas) - qout_gwsubbas(bas)*DT/( &
+                       ct_bas(bas)*basns_area(bas))*1000.   ! units (mm)	
+
+!DJG...Combine calculated bucket discharge and amount spilled from bucket...
+     qout_gwsubbas(bas) = qout_gwsubbas(bas) + qout_spill   ! units (cms)
+
+
+!DJG...debug     write (6,*) "DJG...after",C(bas),ex(bas),z_gwsubbas(bas),z_mx(bas),z_gwsubbas(bas)/z_mx(bas), qout_gwsubbas(bas), qout_spill
+!DJG...debug     write (6,*) "DJG...after...calc",bas,ct_bas(bas),ct_bas(bas)*basns_area(bas),basns_area(bas),DT
+
+
+
+
+! #ifdef MPP_LAND
+!      endif
+! #endif
+   END DO                 ! End loop for GW bucket calcs...
+
+   z_gwsubbas_tmp = z_gwsubbas
+
+
+!!!Distribute basin integrated baseflow to stream pixels as stream 'inflow'...
+
+      qinflowbase = 0.
+
+
+      do i=1,ixrt
+        do j=1,jxrt
+!!!    -simple uniform disaggregation (8.31.06)
+           if (gw_strm_msk_lind(i,j).gt.0) then
+
+             qinflowbase(i,j) = qout_gwsubbas(gw_strm_msk_lind(i,j))*1000.*DT/ &
+                gwbas_pix_ct(gw_strm_msk_lind(i,j))/dist(i,j,9)     ! units (mm) that gets passed into chan routing as stream inflow
+
+           end if
+        end do
+      end do
+
+
+!!!    - weighted redistribution...(need to pass accum weights (slope) in...)
+!        NOT FINISHED just BASIC framework...
+!         do bas=1,numbasns
+!           do k=1,gwbas_pix_ct(bas)
+!             qinflowbase(i,j) = k*slope
+!           end do
+!         end do
+
+        z_gwsubbas = z_gwsubbas_tmp
+
+   return
+
+!------------------------------------------------------------------------------
+   End subroutine simp_gw_buck
+!------------------------------------------------------------------------------
+
+
+
+
+#ifdef MPP_LAND
+   subroutine pix_ct_1(in_gw_strm_msk,ixrt,jxrt,gwbas_pix_ct,numbasns,gnumbasns,basnsInd)
+      USE module_mpp_land
+      implicit none
+      integer ::    i,j,ixrt,jxrt,numbasns, bas, gnumbasns, k
+      integer,dimension(ixrt,jxrt) :: in_gw_strm_msk
+      integer,dimension(global_rt_nx,global_rt_ny) :: gw_strm_msk
+      real,dimension(numbasns) :: gwbas_pix_ct 
+      real,dimension(gnumbasns) :: tmp_gwbas_pix_ct 
+      integer, intent(in), dimension(:) :: basnsInd
+
+      gw_strm_msk = 0
+
+
+      call write_IO_rt_int(in_gw_strm_msk, gw_strm_msk)    
+    
+      call mpp_land_sync() 
+
+      if(my_id .eq. IO_id) then
+!        tmp_gwbas_pix_ct = 0.0
+!         do bas = 1,gnumbasns  
+!         do i=1,global_rt_nx
+!           do j=1,global_rt_ny
+!             if(gw_strm_msk(i,j) .eq. bas) then
+!                tmp_gwbas_pix_ct(bas) = tmp_gwbas_pix_ct(bas) + 1.0
+!             endif
+!           end do
+!         end do
+!         end do
+
+            tmp_gwbas_pix_ct = 0.0
+            do i=1,global_rt_nx
+              do j=1,global_rt_ny
+                if(gw_strm_msk(i,j) .gt. 0) then
+                   bas = gw_strm_msk(i,j)
+                   tmp_gwbas_pix_ct(bas) = tmp_gwbas_pix_ct(bas) + 1.0
+               endif
+              end do
+            end do
+      end if
+
+      call mpp_land_sync() 
+
+      if(gnumbasns .gt. 0) then
+         call mpp_land_bcast_real(gnumbasns,tmp_gwbas_pix_ct)
+      endif
+      do k = 1, numbasns
+         bas = basnsInd(k)
+         gwbas_pix_ct(k) = tmp_gwbas_pix_ct(bas)
+      end do
+
+
+      return
+   end subroutine pix_ct_1
+#endif
+
+
+
+
+
+end module module_GW_baseflow   
diff --git a/wrfv2_fire/hydro/Routing/module_HYDRO_io.F b/wrfv2_fire/hydro/Routing/module_HYDRO_io.F
new file mode 100644
index 00000000..26f44fd1
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_HYDRO_io.F
@@ -0,0 +1,9923 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+module module_HYDRO_io
+#ifdef MPP_LAND
+     use module_mpp_land
+     use module_mpp_reachls,  only: ReachLS_decomp, reachls_wreal, ReachLS_write_io, &
+                                    ReachLS_wInt, reachls_wreal2, TONODE2RSL, gbcastvalue
+     use MODULE_mpp_GWBUCKET, only: gw_write_io_real, gw_write_io_int
+#endif
+   use Module_Date_utilities_rt, only: geth_newdate
+   use module_HYDRO_utils, only: get_dist_ll
+   use module_namelist, only: nlst_rt
+   use module_RT_data, only: rt_domain
+   use module_gw_gw2d_data, only: gw2d   
+   use netcdf 
+
+   implicit none
+#include 
+
+     contains
+
+        integer function get2d_real(var_name,out_buff,ix,jx,fileName, fatalErr)
+          implicit none
+          integer :: ivar, iret,varid,ncid,ix,jx
+          real out_buff(ix,jx)
+          character(len=*), intent(in) :: var_name
+          character(len=*), intent(in) :: fileName
+          logical, optional, intent(in) :: fatalErr
+          logical :: fatalErr_local
+          character(len=256) :: errMsg
+          
+          fatalErr_local = .false.
+          if(present(fatalErr)) fatalErr_local=fatalErr
+
+          get2d_real = -1
+
+          iret = nf_open(trim(fileName), NF_NOWRITE, ncid)
+          if (iret .ne. 0) then
+             errMsg = "get2d_real: failed to open the netcdf file: " // trim(fileName)
+             print*, trim(errMsg)
+             if(fatalErr_local) call hydro_stop(trim(errMsg))
+             out_buff = -9999.
+             return 
+          endif
+
+          ivar = nf_inq_varid(ncid,trim(var_name),  varid)
+          if(ivar .ne. 0) then
+             ivar = nf_inq_varid(ncid,trim(var_name//"_M"),  varid)
+             if(ivar .ne. 0) then
+                errMsg = "get2d_real: failed to find the variables: " //      &
+                         trim(var_name) // ' and ' // trim(var_name//"_M") // &
+                         ' in ' // trim(fileName)
+                write(6,*) errMsg
+                if(fatalErr_local) call hydro_stop(errMsg)
+                return 
+             endif
+          end if
+
+          iret = nf_get_var_real(ncid, varid, out_buff)
+          if(iret .ne. 0) then
+             errMsg = "get2d_real: failed to read the variable: " // &
+                      trim(var_name) // ' or ' // trim(var_name//"_M") // &
+                      ' in ' // trim(fileName)
+             print*,trim(errMsg)
+             if(fatalErr_local) call hydro_stop(trim(errMsg))
+             return
+          endif
+
+          iret = nf_close(ncid)
+          if(iret .ne. 0) then
+             errMsg = "get2d_real: failed to close the file: " // &
+                      trim(fileName)
+             print*,trim(errMsg)
+             if(fatalErr_local) call hydro_stop(trim(errMsg))
+          endif
+
+          get2d_real =  ivar
+      end function get2d_real
+
+     
+     subroutine get2d_lsm_real(var_name,out_buff,ix,jx,fileName)
+         implicit none
+         integer ix,jx, status
+         character (len=*),intent(in) :: var_name, fileName
+         real,dimension(ix,jx):: out_buff
+
+
+#ifdef MPP_LAND
+#ifdef PARALLELIO
+         status = get2d_real(var_name,out_buff,ix,jx,fileName)
+#else
+         real,allocatable, dimension(:,:) :: buff_g
+
+
+#ifdef HYDRO_D
+         write(6,*) "start to read variable ", var_name
+#endif
+         if(my_id .eq. IO_id) then
+            allocate(buff_g (global_nx,global_ny) )
+            status = get2d_real(var_name,buff_g,global_nx,global_ny,fileName)
+         else
+            allocate(buff_g (1,1) )
+         end if
+         call decompose_data_real(buff_g,out_buff)     
+         if(allocated(buff_g)) deallocate(buff_g)
+#endif
+#else         
+         status = get2d_real(var_name,out_buff,ix,jx,fileName)
+#endif
+#ifdef HYDRO_D
+         write(6,*) "finish reading variable ", var_name
+#endif
+     end subroutine get2d_lsm_real
+
+     subroutine get2d_lsm_vegtyp(out_buff,ix,jx,fileName)
+         implicit none
+         integer ix,jx, status,land_cat, iret, dimid,ncid
+         character (len=*),intent(in) :: fileName
+         character (len=256) units 
+         integer,dimension(ix,jx):: out_buff
+         real, dimension(ix,jx) :: xdum
+#ifdef MPP_LAND
+         real,allocatable, dimension(:,:) :: buff_g
+
+
+#ifndef PARALLELIO
+         if(my_id .eq. IO_id) then
+            allocate(buff_g (global_nx,global_ny) )
+         else
+            allocate(buff_g (1,1) )
+         endif
+         if(my_id .eq. IO_id) then
+#endif
+#endif
+                ! Open the NetCDF file.
+              iret = nf_open(fileName, NF_NOWRITE, ncid)
+              if (iret /= 0) then
+                 write(*,'("Problem opening geo_static file: ''", A, "''")') &
+                      trim(fileName)
+                 call hydro_stop("In get2d_lsm_vegtyp() - Problem opening geo_static file")
+              endif
+
+            iret = nf_inq_dimid(ncid, "land_cat", dimid)
+            if (iret /= 0) then
+              call hydro_stop("In get2d_lsm_vegtyp() - nf_inq_dimid:  land_cat problem ")
+             endif
+
+            iret = nf_inq_dimlen(ncid, dimid, land_cat)
+            if (iret /= 0) then
+               call hydro_stop("In get2d_lsm_vegtyp() - nf_inq_dimlen:  land_cat problem")
+            endif
+
+#ifdef MPP_LAND
+#ifndef PARALLELIO
+            call get_landuse_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat)
+         end if
+         call decompose_data_real(buff_g,xdum)     
+         if(allocated(buff_g)) deallocate(buff_g)
+#else
+          call get_landuse_netcdf(ncid, xdum,   units, ix, jx, land_cat)
+#endif
+          iret = nf_close(ncid)
+
+#else         
+          call get_landuse_netcdf(ncid, xdum,   units, ix, jx, land_cat)
+          iret = nf_close(ncid)
+#endif
+         out_buff = nint(xdum)
+     end subroutine get2d_lsm_vegtyp
+
+
+
+     subroutine get_file_dimension(fileName, ix,jx)
+            implicit none
+            character(len=*) fileName
+            integer ncid , iret, ix,jx, dimid
+#ifdef MPP_LAND
+#ifndef PARALLELIO
+            if(my_id .eq. IO_id) then
+#endif
+#endif
+            iret = nf_open(fileName, NF_NOWRITE, ncid)
+            if (iret /= 0) then
+               write(*,'("Problem opening geo_static file: ''", A, "''")') &
+                    trim(fileName)
+               call hydro_stop("In get_file_dimension() - Problem opening geo_static file")
+            endif
+        
+            iret = nf_inq_dimid(ncid, "west_east", dimid)
+        
+            if (iret /= 0) then
+               call hydro_stop("In get_file_dimension() - nf_inq_dimid:  west_east problem")
+            endif
+        
+            iret = nf_inq_dimlen(ncid, dimid, ix)
+            if (iret /= 0) then
+               call hydro_stop("In get_file_dimension() - nf_inq_dimlen:  west_east problem")
+            endif
+        
+            iret = nf_inq_dimid(ncid, "south_north", dimid)
+            if (iret /= 0) then
+               call hydro_stop("In get_file_dimension() - nf_inq_dimid:  south_north problem.")
+            endif
+        
+            iret = nf_inq_dimlen(ncid, dimid, jx)
+            if (iret /= 0) then
+               call hydro_stop("In get_file_dimension() - nf_inq_dimlen:  south_north problem")
+            endif
+            iret = nf_close(ncid)
+#ifdef MPP_LAND
+#ifndef PARALLELIO
+            endif
+            call mpp_land_bcast_int1(ix)
+            call mpp_land_bcast_int1(jx)
+#endif
+#endif
+
+     end subroutine get_file_dimension
+
+     subroutine get2d_lsm_soltyp(out_buff,ix,jx,fileName)
+         implicit none
+         integer ix,jx, status,land_cat, iret, dimid,ncid
+         character (len=*),intent(in) :: fileName
+         character (len=256) units 
+         integer,dimension(ix,jx):: out_buff
+         real, dimension(ix,jx) :: xdum
+#ifdef MPP_LAND
+#ifndef PARALLELIO
+         real,allocatable, dimension(:,:) :: buff_g
+
+
+         if(my_id .eq. IO_id) then
+              allocate(buff_g (global_nx,global_ny) )
+#endif
+#endif
+                ! Open the NetCDF file.
+            iret = nf_open(fileName, NF_NOWRITE, ncid)
+              if (iret /= 0) then
+                 write(*,'("Problem opening geo_static file: ''", A, "''")') &
+                      trim(fileName)
+                 call hydro_stop("In get2d_lsm_soltyp() - problem to open geo_static file.")
+              endif
+
+            iret = nf_inq_dimid(ncid, "soil_cat", dimid)
+            if (iret /= 0) then
+                call hydro_stop("In get2d_lsm_soltyp() - nf_inq_dimid:  soil_cat problem")
+            endif
+
+            iret = nf_inq_dimlen(ncid, dimid, land_cat)
+            if (iret /= 0) then
+               call hydro_stop("In get2d_lsm_soltyp() - nf_inq_dimlen:  soil_cat problem")
+            endif
+
+#ifdef MPP_LAND
+#ifndef PARALLELIO
+            call get_soilcat_netcdf(ncid, buff_g, units, global_nx ,global_ny, land_cat)
+         end if
+         call decompose_data_real(buff_g,xdum)     
+         if(my_id .eq. io_id) then 
+           if(allocated(buff_g)) deallocate(buff_g)
+         endif
+#else
+          call get_soilcat_netcdf(ncid, xdum,   units, ix, jx, land_cat)
+#endif
+          iret = nf_close(ncid)
+#else         
+          call get_soilcat_netcdf(ncid, xdum,   units, ix, jx, land_cat)
+          iret = nf_close(ncid)
+#endif
+          out_buff = nint(xdum)
+     end subroutine get2d_lsm_soltyp
+
+
+  subroutine get_landuse_netcdf(ncid, array, units, idim, jdim, ldim)
+    implicit none
+#include 
+    integer, intent(in) :: ncid
+    integer, intent(in) :: idim, jdim, ldim
+    real, dimension(idim,jdim), intent(out) :: array
+    character(len=256), intent(out) :: units
+    integer :: iret, varid
+    real, dimension(idim,jdim,ldim) :: xtmp
+    integer, dimension(1) :: mp
+    integer :: i, j, l
+    character(len=24), parameter :: name = "LANDUSEF"
+
+    units = ""
+
+    iret = nf_inq_varid(ncid,  trim(name),  varid)
+    if (iret /= 0) then
+       print*, 'name = "', trim(name)//'"'
+       call hydro_stop("In get_landuse_netcdf() - nf_inq_varid problem")
+    endif
+
+    iret = nf_get_var_real(ncid, varid, xtmp)
+    if (iret /= 0) then
+       print*, 'name = "', trim(name)//'"'
+       call hydro_stop("In get_landuse_netcdf() - nf_get_var_real problem")
+    endif
+
+    do i = 1, idim
+       do j = 1, jdim
+          mp = maxloc(xtmp(i,j,:))
+          array(i,j) = mp(1)
+          do l = 1,ldim
+            if(xtmp(i,j,l).lt.0) array(i,j) = -9999.0
+          enddo
+       enddo
+    enddo
+
+  end subroutine get_landuse_netcdf
+
+
+  subroutine get_soilcat_netcdf(ncid, array, units, idim, jdim, ldim)
+    implicit none
+#include 
+
+    integer, intent(in) :: ncid
+    integer, intent(in) :: idim, jdim, ldim
+    real, dimension(idim,jdim), intent(out) :: array
+    character(len=256), intent(out) :: units
+    integer :: iret, varid
+    real, dimension(idim,jdim,ldim) :: xtmp
+    integer, dimension(1) :: mp
+    integer :: i, j, did
+    character(len=24), parameter :: name = "SOILCTOP"
+
+    did = 1
+    units = ""
+
+    iret = nf_inq_varid(ncid,  trim(name),  varid)
+    if (iret /= 0) then
+       print*, 'name = "', trim(name)//'"'
+       call hydro_stop("In get_soilcat_netcdf() - nf_inq_varid problem")
+    endif
+
+    iret = nf_get_var_real(ncid, varid, xtmp)
+    if (iret /= 0) then
+       print*, 'name = "', trim(name)//'"'
+       call hydro_stop("In get_soilcat_netcdf() - nf_get_var_real problem")
+    endif
+
+    do i = 1, idim
+       do j = 1, jdim
+          mp = maxloc(xtmp(i,j,:))
+          array(i,j) = mp(1)
+       enddo
+    enddo
+
+     if(nlst_rt(did)%GWBASESWCRT .ne. 3) then
+        where (array == 14) array = 1   ! DJG remove all 'water' soils...
+     endif
+
+  end subroutine get_soilcat_netcdf
+
+
+subroutine get_greenfrac_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd)
+    implicit none
+#include 
+    integer, intent(in) :: ncid,mm,dd
+    integer, intent(in) :: idim, jdim, ldim
+    real, dimension(idim,jdim) :: array
+    real, dimension(idim,jdim) :: array2
+    real, dimension(idim,jdim) :: diff
+    real, dimension(idim,jdim), intent(out) :: array3
+    character(len=256), intent(out) :: units
+    integer :: iret, varid
+    real, dimension(idim,jdim,ldim) :: xtmp
+    integer, dimension(1) :: mp
+    integer :: i, j, mm2,daytot
+    real :: ddfrac
+    character(len=24), parameter :: name = "GREENFRAC"
+
+    units = "fraction"
+
+    iret = nf_inq_varid(ncid,  trim(name),  varid)
+    if (iret /= 0) then
+       print*, 'name = "', trim(name)//'"'
+       call hydro_stop("In get_greenfrac_netcdf() - nf_inq_varid problem")
+    endif
+
+    iret = nf_get_var_real(ncid, varid, xtmp)
+    if (iret /= 0) then
+       print*, 'name = "', trim(name)//'"'
+       call hydro_stop("In get_greenfrac_netcdf() - nf_get_var_real problem")
+    endif
+
+
+    if (mm.lt.12) then 
+      mm2 = mm+1
+    else
+      mm2 = 1
+    end if
+
+!DJG_DES Set up dates for daily interpolation...
+          if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then
+             daytot = 31
+          else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then 
+             daytot = 30
+          else if (mm.eq.2) then
+             daytot = 28
+          end if
+          ddfrac = float(dd)/float(daytot)
+          if (ddfrac.gt.1.0) ddfrac = 1.0   ! Assumes Feb. 29th change is same as Feb 28th
+
+#ifdef HYDRO_D
+    print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac
+
+#endif
+    do i = 1, idim
+       do j = 1, jdim
+          array(i,j) = xtmp(i,j,mm)   !GREENFRAC in geogrid in units of fraction from month 1
+          array2(i,j) = xtmp(i,j,mm2)   !GREENFRAC in geogrid in units of fraction from month 1
+          diff(i,j) = array2(i,j) - array(i,j)
+          array3(i,j) = array(i,j) + ddfrac * diff(i,j) 
+       enddo
+    enddo
+
+end subroutine get_greenfrac_netcdf
+
+
+
+subroutine get_albedo12m_netcdf(ncid, array3, units, idim, jdim, ldim,mm,dd)
+    implicit none
+#include 
+    integer, intent(in) :: ncid,mm,dd
+    integer, intent(in) :: idim, jdim, ldim
+    real, dimension(idim,jdim) :: array
+    real, dimension(idim,jdim) :: array2
+    real, dimension(idim,jdim) :: diff
+    real, dimension(idim,jdim), intent(out) :: array3
+    character(len=256), intent(out) :: units
+    integer :: iret, varid
+    real, dimension(idim,jdim,ldim) :: xtmp
+    integer, dimension(1) :: mp
+    integer :: i, j, mm2,daytot
+    real :: ddfrac
+    character(len=24), parameter :: name = "ALBEDO12M"
+
+
+    units = "fraction"
+
+    iret = nf_inq_varid(ncid,  trim(name),  varid)
+    if (iret /= 0) then
+       print*, 'name = "', trim(name)//'"'
+       call hydro_stop("In get_albedo12m_netcdf() - nf_inq_varid problem")
+    endif
+
+    iret = nf_get_var_real(ncid, varid, xtmp)
+    if (iret /= 0) then
+       print*, 'name = "', trim(name)//'"'
+       call hydro_stop("In get_albedo12m_netcdf() - nf_get_var_real problem")
+    endif
+
+    if (mm.lt.12) then 
+      mm2 = mm+1
+    else
+      mm2 = 1
+    end if
+
+!DJG_DES Set up dates for daily interpolation...
+          if (mm.eq.1.OR.mm.eq.3.OR.mm.eq.5.OR.mm.eq.7.OR.mm.eq.8.OR.mm.eq.10.OR.mm.eq.12) then
+             daytot = 31
+          else if (mm.eq.4.OR.mm.eq.6.OR.mm.eq.9.OR.mm.eq.11) then 
+             daytot = 30
+          else if (mm.eq.2) then
+             daytot = 28
+          end if
+          ddfrac = float(dd)/float(daytot)
+          if (ddfrac.gt.1.0) ddfrac = 1.0   ! Assumes Feb. 29th change is same as Feb 28th
+
+#ifdef HYDRO_D
+    print *,"DJG_DES Made it past netcdf read...month = ",mm,mm2,dd,daytot,ddfrac
+#endif
+
+    do i = 1, idim
+       do j = 1, jdim
+          array(i,j) = xtmp(i,j,mm) / 100.0   !Convert ALBEDO12M from % to fraction...month 1
+          array2(i,j) = xtmp(i,j,mm2) / 100.0   !Convert ALBEDO12M from % to fraction... month 2
+          diff(i,j) = array2(i,j) - array(i,j)
+          array3(i,j) = array(i,j) + ddfrac * diff(i,j) 
+       enddo
+    enddo
+
+end subroutine get_albedo12m_netcdf
+
+
+
+
+  subroutine get_2d_netcdf(name, ncid, array, units, idim, jdim, &
+       fatal_if_error, ierr)
+    implicit none
+#include 
+    character(len=*), intent(in) :: name
+    integer, intent(in) :: ncid
+    integer, intent(in) :: idim, jdim
+    real, dimension(idim,jdim), intent(out) :: array
+    character(len=256), intent(out) :: units
+    integer :: iret, varid
+    ! .TRUE._IF_ERROR:  an input code value:
+    !      .TRUE. if an error in reading the data should stop the program.
+    !      Otherwise the, IERR error flag is set, but the program continues.
+    logical, intent(in) :: fatal_if_error 
+    integer, intent(out) :: ierr
+
+    units = ""
+
+    iret = nf_inq_varid(ncid,  name,  varid)
+
+    if (iret /= 0) then
+       if (fatal_IF_ERROR) then
+          print*, 'name = "', trim(name)//'"'
+          call hydro_stop("In get_2d_netcdf() - nf_inq_varid problem")
+       else
+          ierr = iret
+          return
+       endif
+    endif
+
+
+    iret = nf_get_var_real(ncid, varid, array)
+    if (iret /= 0) then
+       if (fatal_IF_ERROR) then
+          print*, 'name = "', trim(name)//'"'
+          call hydro_stop("In get_2d_netcdf() - nf_get_var_real problem")
+       else
+          ierr = iret
+          return
+       endif
+    endif
+
+    ierr = 0;
+  end subroutine get_2d_netcdf
+
+
+      subroutine get_2d_netcdf_cows(var_name,ncid,var, &
+            ix,jx,tlevel,fatal_if_error,ierr)
+#include 
+          character(len=*), intent(in) :: var_name
+          integer,intent(in) ::  ncid,ix,jx,tlevel
+          real, intent(out):: var(ix,jx)
+          logical, intent(in) :: fatal_if_error
+          integer ierr, iret
+          integer varid
+          integer start(4),count(4)
+          data count /1,1,1,1/
+          data start /1,1,1,1/
+          count(1) = ix
+          count(2) = jx
+          start(4) = tlevel
+      iret = nf_inq_varid(ncid,  var_name,  varid)
+
+      if (iret /= 0) then
+        if (fatal_IF_ERROR) then
+           call hydro_stop("In get_2d_netcdf_cows() - nf_inq_varid problem")
+        else
+          ierr = iret
+          return
+        endif
+      endif
+      iret = nf_get_vara_real(ncid, varid, start,count,var)
+
+      return
+      end subroutine get_2d_netcdf_cows
+
+!---------------------------------------------------------
+!DJG Subroutinesfor inputting routing fields...
+!DNY   first reads the files to get the size of the 
+!DNY   LINKS arrays
+!DJG   - Currently only hi-res topo is read 
+!DJG   - At a future time, use this routine to input
+!DJG     subgrid land-use classification or routing
+!DJG     parameters 'overland roughness' and 'retention
+!DJG     depth'
+!
+!DJG,DNY - Update this subroutine to read in channel and lake
+!           parameters if activated       11.20.2005
+!---------------------------------------------------------
+
+       SUBROUTINE READ_ROUTEDIM(IXRT,JXRT,route_chan_f,route_link_f, &
+            route_direction_f, NLINKS, &
+            CH_NETLNK, channel_option, geo_finegrid_flnm, NLINKSL, UDMP_OPT)
+
+         implicit none
+#include 
+        INTEGER                                      :: I,J,channel_option,jj
+        INTEGER, INTENT(INOUT)                       :: NLINKS, NLINKSL
+        INTEGER, INTENT(IN)                          :: IXRT,JXRT
+        INTEGER                                      :: CHNID,cnt
+        INTEGER, DIMENSION(IXRT,JXRT)                :: CH_NETRT   !- binary channel mask
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK  !- each node gets unique id
+        INTEGER, DIMENSION(IXRT,JXRT)                :: DIRECTION  !- flow direction
+        INTEGER, DIMENSION(IXRT,JXRT)                :: LAKE_MSKRT
+        REAL, DIMENSION(IXRT,JXRT)                   :: LAT, LON
+        INTEGER, DIMENSION(IXRT,JXRT)                :: CH_LNKRT   !- link routing ID
+        integer, INTENT(IN)                          :: UDMP_OPT                                
+
+!!Dummy read in grids for inverted y-axis
+
+
+        CHARACTER(len=*)         :: route_chan_f, route_link_f,route_direction_f
+        CHARACTER(len=256)       :: geo_finegrid_flnm
+        CHARACTER(len=256)       :: var_name
+
+        ! variables for handling netcdf dimensions
+        integer :: iRet, ncid, dimId
+        logical :: routeLinkNetcdf
+     
+        NLINKS = 0
+        CH_NETRT = -9999
+        CH_NETLNK = -9999
+        
+        NLINKSL   = 0
+        CH_LNKRT  = -9999
+
+
+
+        cnt = 0 
+#ifdef HYDRO_D
+       print *, "Channel Option in Routedim is ", channel_option
+#endif
+
+
+        if (channel_option .eq. 4) return  ! it will run Rapid
+
+
+!-- will always read channel grid       IF(channel_option.eq.3) then  !get maxnodes and links from grid
+
+         var_name = "CHANNELGRID"
+         call readRT2d_int(var_name,CH_NETRT,ixrt,jxrt,&
+                   trim(geo_finegrid_flnm))
+
+
+!-- new link id variable to handle link routing
+         var_name = "LINKID"
+#ifdef MPP_LAND
+#ifdef HYDRO_D
+    write(6,*) "read LINKID for CH_LNKRT from ", trim(geo_finegrid_flnm)
+#endif
+#endif
+!!!! LINKID is used for reach based method.  ?
+     IF(channel_option.ne.3 .and. UDMP_OPT.ne.1) then  !get maxnodes and links from grid
+         call readRT2d_int(var_name,CH_LNKRT,ixrt,jxrt,&
+                   trim(geo_finegrid_flnm), fatalErr=.TRUE.)
+     endif
+
+
+         
+         var_name = "FLOWDIRECTION"
+         call readRT2d_int(var_name,DIRECTION,ixrt,jxrt,&
+                   trim(geo_finegrid_flnm))
+
+!note that this is not used for link routing
+         var_name = "LAKEGRID"
+         call readRT2d_int(var_name,LAKE_MSKRT,ixrt,jxrt,&
+                   trim(geo_finegrid_flnm))
+
+
+        var_name = "LATITUDE"
+        call readRT2d_real(var_name,LAT,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+        var_name = "LONGITUDE"
+        call readRT2d_real(var_name,LON,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+          
+! temp fix for buggy Arc export...
+        do j=1,jxrt
+          do i=1,ixrt
+            if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128
+          end do
+        end do
+
+!DJG inv         do j=jxrt,1,-1
+         do j=1,jxrt
+             do i = 1, ixrt
+!               if (CH_NETRT(i,j) .ge.0.AND.CH_NETRT(i,j).lt.100) then 
+                if (CH_NETRT(i,j) .ge.0) then
+                 NLINKS = NLINKS + 1
+                 if( UDMP_OPT .eq. 1) CH_NETLNK(i,j) = 2
+               endif
+            end do 
+         end do 
+#ifdef HYDRO_D
+         print *, "NLINKS IS ", NLINKS 
+#endif
+     if( UDMP_OPT .eq. 1) then 
+         return
+     endif
+
+!DJG inv         DO j = JXRT,1,-1  !rows
+         DO j = 1,JXRT  !rows
+          DO i = 1 ,IXRT   !colsumns
+           If (CH_NETRT(i, j) .ge. 0) then !get its direction
+            If ((DIRECTION(i, j) .EQ. 64) .AND. (j+1 .LE. JXRT) ) then !North
+               if(CH_NETRT(i,j+1) .ge.0) then 
+                  cnt = cnt + 1
+                  CH_NETLNK(i,j) = cnt
+                endif
+            else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) &
+               .AND. (j + 1 .LE. JXRT) ) then !North East
+                if(CH_NETRT(i+1,j+1) .ge.0) then
+                   cnt = cnt + 1
+                   CH_NETLNK(i,j) = cnt
+                endif
+            else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT)) then !East
+                if(CH_NETRT(i+1,j) .ge. 0) then
+                   cnt = cnt + 1
+                   CH_NETLNK(i,j) = cnt 
+                endif
+            else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) &
+                    .AND. (j - 1 .NE. 0)) then !south east
+                 if(CH_NETRT(i+1,j-1).ge.0) then
+                     cnt = cnt + 1
+                     CH_NETLNK(i,j) = cnt
+                 endif
+            else if ((DIRECTION(i, j) .EQ. 4).AND.(j - 1 .NE. 0)) then !due south
+                 if(CH_NETRT(i,j-1).ge.0) then
+                         cnt = cnt + 1
+                         CH_NETLNK(i,j) = cnt
+                 endif
+            else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) &
+                    .AND. (j - 1 .NE. 0)  ) then !south west
+                if(CH_NETRT(i-1,j-1).ge.0) then
+                     cnt = cnt + 1
+                     CH_NETLNK(i,j) = cnt
+                endif
+            else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0)) then !West
+                 if(CH_NETRT(i-1,j).ge.0) then
+                       cnt = cnt + 1
+                       CH_NETLNK(i,j) = cnt
+                 endif
+            else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) &
+                    .AND. (j + 1 .LE. JXRT) ) then !North West
+                 if(CH_NETRT(i-1,j+1).ge.0) then
+                        cnt = cnt + 1
+                        CH_NETLNK(i,j) = cnt 
+                 endif
+           else 
+#ifdef HYDRO_D
+             write(*,135) "PrPt/LkIn", CH_NETRT(i,j), DIRECTION(i,j), LON(i,j), LAT(i,j),i,j 
+#endif
+135             FORMAT(A9,1X,I3,1X,I3,1X,F10.5,1X,F9.5,1X,I4,1X,I4)
+             if (DIRECTION(i,j) .eq. 0) then
+#ifdef HYDRO_D
+               print *, "Direction i,j ",i,j," of point ", cnt, "is invalid"
+#endif
+             endif
+
+           End If
+         End If !CH_NETRT check for this node
+        END DO
+       END DO 
+#ifdef HYDRO_D
+       print *, "found type 0 nodes", cnt
+#endif
+!Find out if the boundaries are on an edge or flow into a lake
+!DJG inv       DO j = JXRT,1,-1
+       DO j = 1,JXRT
+         DO i = 1 ,IXRT
+          If (CH_NETRT(i, j) .ge. 0) then !get its direction
+
+           If ( (DIRECTION(i, j).EQ. 64) )then 
+              if( j + 1 .GT. JXRT) then           !-- 64's can only flow north
+                 cnt = cnt + 1
+                 CH_NETLNK(i,j) = cnt
+              elseif(CH_NETRT(i,j+1) .lt. 0) then !North
+                 cnt = cnt + 1
+                 CH_NETLNK(i,j) = cnt
+#ifdef HYDRO_D
+                  print *, "Boundary Pour Point N", cnt,CH_NETRT(i,j), i,j
+#endif
+              endif
+           else if ( DIRECTION(i, j) .EQ. 128) then
+               if ((i + 1 .GT. IXRT) .or. (j + 1 .GT. JXRT))  then    !-- 128's can flow out of the North or East edge
+                   cnt = cnt + 1
+                   CH_NETLNK(i,j) = cnt
+                                                                      !   this is due north edge     
+               elseif(CH_NETRT(i + 1, j + 1).lt.0) then !North East
+                   cnt = cnt + 1
+                   CH_NETLNK(i,j) = cnt
+#ifdef HYDRO_D
+              print *, "Boundary Pour Point NE", cnt, CH_NETRT(i,j),i,j
+#endif
+               endif
+           else if (DIRECTION(i, j) .EQ. 1) then 
+                if (i + 1 .GT. IXRT) then      !-- 1's can only flow due east
+                   cnt = cnt + 1
+                   CH_NETLNK(i,j) = cnt
+                elseif(CH_NETRT(i + 1, j) .lt. 0) then !East
+                   cnt = cnt + 1
+                   CH_NETLNK(i,j) = cnt
+#ifdef HYDRO_D
+              print *, "Boundary Pour Point E", cnt,CH_NETRT(i,j), i,j
+#endif
+                endif
+           else if (DIRECTION(i, j) .EQ. 2) then
+               !-- 2's can flow out of east or south edge
+              if( (i + 1 .GT. IXRT) .OR.  (j - 1 .EQ. 0)) then            !-- this is the south edge
+                  cnt = cnt + 1
+                  CH_NETLNK(i,j) = cnt
+              elseif(CH_NETRT(i + 1, j - 1) .lt.0) then !south east
+                  cnt = cnt + 1
+                  CH_NETLNK(i,j) = cnt
+#ifdef HYDRO_D
+                  print *, "Boundary Pour Point SE", cnt,CH_NETRT(i,j), i,j
+#endif
+              endif
+           else if ( DIRECTION(i, j) .EQ. 4) then 
+              if( (j - 1 .EQ. 0))  then            !-- 4's can only flow due south
+                 cnt = cnt + 1
+                 CH_NETLNK(i,j) = cnt
+              elseif (CH_NETRT(i, j - 1) .lt. 0) then !due south
+                 cnt = cnt + 1
+                 CH_NETLNK(i,j) = cnt
+#ifdef HYDRO_D
+                 print *, "Boundary Pour Point S", cnt,CH_NETRT(i,j), i,j
+#endif
+              endif
+           else if ( DIRECTION(i, j) .EQ. 8) then
+          !-- 8's can flow south or west
+              if( (i - 1 .eq. 0) .OR. ( j - 1 .EQ. 0)) then             !-- this is the south edge
+                  cnt = cnt + 1
+                  CH_NETLNK(i,j) = cnt
+              elseif  (CH_NETRT(i - 1, j - 1).lt.0) then !south west
+                  cnt = cnt + 1
+                  CH_NETLNK(i,j) = cnt
+#ifdef HYDRO_D
+                  print *, "Boundary Pour Point SW", cnt,CH_NETRT(i,j), i,j
+#endif
+              endif
+           else if ( DIRECTION(i, j) .EQ. 16) then 
+              if(i - 1 .eq. 0) then              !-- 16's can only flow due west 
+                  cnt = cnt + 1
+                  CH_NETLNK(i,j) = cnt              
+              elseif (CH_NETRT(i - 1, j).lt.0) then !West
+                  cnt = cnt + 1
+                  CH_NETLNK(i,j) = cnt              
+#ifdef HYDRO_D
+              print *, "Boundary Pour Point W", cnt,CH_NETRT(i,j), i,j
+#endif
+              endif
+           else if ( DIRECTION(i, j) .EQ. 32)  then
+              if ( (i - 1 .eq. 0)      &      !-- 32's can flow either west or north
+               .OR.   (j .eq. JXRT))  then         !-- this is the north edge
+                  cnt = cnt + 1
+                  CH_NETLNK(i,j) = cnt
+              elseif (CH_NETRT(i - 1, j + 1).lt.0) then !North West
+                  cnt = cnt + 1
+                  CH_NETLNK(i,j) = cnt
+#ifdef HYDRO_D
+                  print *, "Boundary Pour Point NW", cnt,CH_NETRT(i,j), i,j
+#endif
+              endif
+           endif
+          endif !CH_NETRT check for this node
+         END DO
+       END DO 
+
+#ifdef HYDRO_D
+       print *, "total number of channel elements", cnt
+       print *, "total number of NLINKS          ", NLINKS
+#endif
+
+
+
+      !-- get the number of lakes
+       if (cnt .ne. NLINKS) then 
+         print *, "Apparent error in network topology", cnt, NLINKS
+         print* , "ixrt =", ixrt, "jxrt =", jxrt
+         call hydro_stop("READ_ROUTEDIM")
+       endif
+
+!!-- no longer find the lakes from the 2-d hi res grid
+!DJG inv       do j=jxrt,1,-1
+!       do j=1,jxrt
+!          do i = 1,ixrt
+!           if (LAKE_MSKRT(i,j) .gt. NLAKES) then 
+!             NLAKES = LAKE_MSKRT(i,j)
+!           endif
+!        end do
+!       end do
+!#ifdef HYDRO_D
+!       write(6,*) "finish read_red ..  Total Number of Lakes in Domain = ", NLAKES
+!#endif
+
+
+!-- don't return here--!  return
+
+     END SUBROUTINE READ_ROUTEDIM
+
+!!! This subroutine gets the NLINKSL
+     subroutine get_NLINKSL(NLINKSL, channel_option, route_link_f)
+        implicit none
+        CHARACTER(len=*)         :: route_link_f
+        integer :: NLINKSL, channel_option
+        CHARACTER(len=256)         :: route_link_f_r
+        integer :: lenRouteLinkFR
+        logical :: routeLinkNetcdf
+        CHARACTER(len=256)       :: InputLine
+        if (channel_option.ne.3) then  ! overwrite the NLINKS
+!-IF is now commented above   else  ! get nlinks from the ascii file of links
+#ifdef HYDRO_D
+           write(6,*) "read file to get NLINKSL from", trim(route_link_f)
+           call flush(6)
+#endif
+       !! is RouteLink file netcdf (*.nc) or csv (*.csv)
+           route_link_f_r = adjustr(route_link_f)
+           lenRouteLinkFR = len(route_link_f_r)
+           routeLinkNetcdf = route_link_f_r( (lenRouteLinkFR-2):lenRouteLinkFR) .eq.  '.nc'
+
+           if(routeLinkNetcdf) then
+              NLINKSL = get_netcdf_dim(trim(route_link_f), 'linkDim',  &
+                                   'READ_ROUTEDIM', fatalErr=.true.)
+           else
+              open(unit=17,file=trim(route_link_f),          & !link
+                   form='formatted',status='old')
+
+1011          read(17,*,end= 1999) InputLine
+              NLINKSL = NLINKSL + 1
+              goto 1011
+1999          continue
+              NLINKSL = NLINKSL - 1 !-- first line is a comment 
+              close(17)
+           end if ! routeLinkNetcdf
+
+#ifdef HYDRO_D
+            print *, "Number of Segments or Links on sparse network", NLINKSL
+            write(6,*) "NLINKSL = ", NLINKSL
+            call flush(6)
+#endif
+
+      end if !end-if is now for channel_option just above, not IF from further up
+
+          return
+     end subroutine get_NLINKSL
+
+     subroutine nreadRT2d_real(var_name, inv, ixrt, jxrt, fileName, fatalErr) 
+         implicit none
+         INTEGER :: iret
+         INTEGER, INTENT(IN) :: ixrt,jxrt
+         INTEGER :: i, j, ii,jj
+         CHARACTER(len=*):: var_name,fileName
+         real, INTENT(OUT), dimension(ixrt,jxrt) :: inv
+#ifndef MPP_LAND
+         real, dimension(ixrt,jxrt) :: inv_tmp
+#endif
+         logical, optional, intent(in) :: fatalErr
+         logical :: fatalErr_local
+#ifdef MPP_LAND
+         real, allocatable,dimension(:,:) :: g_inv_tmp, g_inv
+#endif
+         fatalErr_local = .FALSE.
+         if(present(fatalErr)) fatalErr_local=fatalErr
+
+#ifdef MPP_LAND
+         if(my_id .eq. io_id) then
+
+              allocate(g_inv_tmp(global_rt_nx,global_rt_ny))
+              allocate(g_inv(global_rt_nx,global_rt_ny))
+
+
+              g_inv_tmp = -9999.9
+              iret =  get2d_real(var_name,g_inv_tmp,global_rt_nx,global_rt_ny,&
+                     trim(fileName), fatalErr=fatalErr_local)
+              do i=1,global_rt_nx
+                 jj=global_rt_ny
+                 do j=1,global_rt_ny
+                   g_inv(i,j)=g_inv_tmp(i,jj)
+                   jj=global_rt_ny-j
+                 end do
+              end do
+              if(allocated(g_inv_tmp)) deallocate(g_inv_tmp)
+         else
+              allocate(g_inv(1,1))
+         endif 
+         call decompose_RT_real(g_inv,inv,global_rt_nx,global_rt_ny,IXRT,JXRT)
+         if(allocated(g_inv)) deallocate(g_inv)
+#else
+         inv_tmp = -9999.9
+         iret =  get2d_real(var_name,inv_tmp,ixrt,jxrt,&
+                     trim(fileName), fatalErr=fatalErr_local)
+         do i=1,ixrt
+            jj=jxrt
+         do j=1,jxrt
+           inv(i,j)=inv_tmp(i,jj)
+           jj=jxrt-j
+         end do
+        end do
+#endif
+
+        
+     end SUBROUTINE nreadRT2d_real
+
+     subroutine nreadRT2d_int(var_name, inv, ixrt, jxrt, fileName, fatalErr) 
+         implicit none
+         INTEGER, INTENT(IN) :: ixrt,jxrt
+         INTEGER :: i, j, ii,jj, iret
+         CHARACTER(len=*):: var_name,fileName
+         integer, INTENT(OUT), dimension(ixrt,jxrt) :: inv
+         integer, dimension(ixrt,jxrt) :: inv_tmp
+         logical, optional, intent(in) :: fatalErr
+         logical :: fatalErr_local
+#ifdef MPP_LAND
+         integer, allocatable,dimension(:,:) :: g_inv_tmp, g_inv
+#endif
+         fatalErr_local = .FALSE.
+         if(present(fatalErr)) fatalErr_local=fatalErr
+
+#ifdef MPP_LAND
+         if(my_id .eq. io_id) then
+              allocate(g_inv_tmp(global_rt_nx,global_rt_ny))
+              allocate(g_inv(global_rt_nx,global_rt_ny))
+              g_inv_tmp = -9999.9
+              call  get2d_int(var_name,g_inv_tmp,global_rt_nx,global_rt_ny,&
+                     trim(fileName), fatalErr=fatalErr_local)
+              do i=1,global_rt_nx
+                 jj=global_rt_ny
+                do j=1,global_rt_ny
+                  g_inv(i,j)=g_inv_tmp(i,jj)
+                  jj=global_rt_ny-j
+                end do
+              end do
+         else
+              allocate(g_inv_tmp(1,1))
+              allocate(g_inv(1,1))
+         endif
+         call decompose_RT_int(g_inv,inv,global_rt_nx,global_rt_ny,IXRT,JXRT)
+         if(allocated(g_inv_tmp)) deallocate(g_inv_tmp)
+         if(allocated(g_inv)) deallocate(g_inv)
+#else
+         call  get2d_int(var_name,inv_tmp,ixrt,jxrt,&
+                     trim(fileName), fatalErr=fatalErr_local)
+         do i=1,ixrt
+            jj=jxrt
+         do j=1,jxrt
+           inv(i,j)=inv_tmp(i,jj)
+           jj=jxrt-j
+         end do
+        end do
+#endif
+     end SUBROUTINE nreadRT2d_int
+!---------------------------------------------------------
+!DJG -----------------------------------------------------
+
+     subroutine readRT2d_real(var_name, inv, ixrt, jxrt, fileName, fatalErr) 
+         implicit none
+         INTEGER :: iret
+         INTEGER, INTENT(IN) :: ixrt,jxrt
+         INTEGER :: i, j, ii,jj
+         CHARACTER(len=*):: var_name,fileName
+         real, INTENT(OUT), dimension(ixrt,jxrt) :: inv
+         real, dimension(ixrt,jxrt) :: inv_tmp
+         logical, optional, intent(in) :: fatalErr
+         logical :: fatalErr_local
+         fatalErr_local = .FALSE.
+         if(present(fatalErr)) fatalErr_local=fatalErr
+         inv_tmp = -9999.9
+         iret =  get2d_real(var_name,inv_tmp,ixrt,jxrt,&
+                     trim(fileName), fatalErr=fatalErr_local)
+         do i=1,ixrt
+            jj=jxrt
+         do j=1,jxrt
+           inv(i,j)=inv_tmp(i,jj)
+           jj=jxrt-j
+         end do
+        end do
+     end SUBROUTINE readRT2d_real
+
+     subroutine readRT2d_int(var_name, inv, ixrt, jxrt, fileName, fatalErr) 
+         implicit none
+         INTEGER, INTENT(IN) :: ixrt,jxrt
+         INTEGER :: i, j, ii,jj
+         CHARACTER(len=*):: var_name,fileName
+         integer, INTENT(OUT), dimension(ixrt,jxrt) :: inv
+         integer, dimension(ixrt,jxrt) :: inv_tmp
+         logical, optional, intent(in) :: fatalErr
+         logical :: fatalErr_local
+         fatalErr_local = .FALSE.
+         if(present(fatalErr)) fatalErr_local=fatalErr
+         call  get2d_int(var_name,inv_tmp,ixrt,jxrt,&
+                     trim(fileName), fatalErr=fatalErr_local)
+         do i=1,ixrt
+            jj=jxrt
+         do j=1,jxrt
+           inv(i,j)=inv_tmp(i,jj)
+           jj=jxrt-j
+         end do
+        end do
+     end SUBROUTINE readRT2d_int
+
+!---------------------------------------------------------
+!DJG -----------------------------------------------------
+
+#ifdef MPP_LAND
+  subroutine MPP_READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,&
+          gw_strm_msk,numbasns,ch_netrt,AGGFACTRT)
+
+   USE module_mpp_land
+    
+    integer, intent(in)                     :: IX,JX,IXRT,JXRT,AGGFACTRT
+    integer, intent(out)                    :: numbasns
+    integer, intent(out), dimension(IX,JX)  :: GWSUBBASMSK
+    integer, intent(out), dimension(IXRT,JXRT)  :: gw_strm_msk
+    integer, intent(in), dimension(IXRT,JXRT)  :: ch_netrt
+    character(len=256)                      :: gwbasmskfil
+    !integer,dimension(global_nX,global_ny) ::  g_GWSUBBASMSK
+    !yw integer,dimension(global_rt_nx, global_rt_ny) ::  g_gw_strm_msk,g_ch_netrt
+
+    integer,allocatable,dimension(:,:) ::  g_GWSUBBASMSK
+    integer,allocatable,dimension(:, :) ::  g_gw_strm_msk,g_ch_netrt
+    
+     if(my_id .eq. IO_id) then
+          allocate(g_gw_strm_msk(global_rt_nx, global_rt_ny))
+          allocate(g_ch_netrt(global_rt_nx, global_rt_ny))
+          allocate(g_GWSUBBASMSK(global_nX,global_ny))
+     else
+          allocate(g_gw_strm_msk(1,1))
+          allocate(g_ch_netrt(1,1))
+          allocate(g_GWSUBBASMSK(1,1))
+     endif
+
+
+     call write_IO_rt_int(ch_netrt,g_ch_netrt)
+
+     if(my_id .eq. IO_id) then
+       call READ_SIMP_GW(global_nX,global_ny,global_rt_nx,global_rt_ny,&
+             g_GWSUBBASMSK,gwbasmskfil,g_gw_strm_msk,numbasns,&
+             g_ch_netrt,AGGFACTRT) 
+     endif
+     call decompose_data_int(g_GWSUBBASMSK,GWSUBBASMSK)
+     call decompose_RT_int(g_gw_strm_msk,gw_strm_msk,  &
+          global_rt_nx, global_rt_ny,ixrt,jxrt)
+     call mpp_land_bcast_int1(numbasns)
+
+     if(allocated(g_gw_strm_msk))  deallocate(g_gw_strm_msk)
+     if(allocated(g_ch_netrt)) deallocate(g_ch_netrt)
+     if(allocated(g_GWSUBBASMSK))  deallocate(g_GWSUBBASMSK)
+
+  return
+  end subroutine MPP_READ_SIMP_GW
+#endif
+
+!DJG -----------------------------------------------------
+!   SUBROUTINE READ_SIMP_GW
+!DJG -----------------------------------------------------
+
+  subroutine READ_SIMP_GW(IX,JX,IXRT,JXRT,GWSUBBASMSK,gwbasmskfil,&
+          gw_strm_msk,numbasns,ch_netrt,AGGFACTRT)
+    implicit none
+#include 
+
+    integer, intent(in)                     :: IX,JX,IXRT,JXRT,AGGFACTRT
+    integer, intent(in), dimension(IXRT,JXRT)  :: ch_netrt
+    integer, intent(out)                    :: numbasns
+    integer, intent(out), dimension(IX,JX)  :: GWSUBBASMSK
+    integer, intent(out), dimension(IXRT,JXRT)  :: gw_strm_msk
+    character(len=256)                      :: gwbasmskfil
+    integer                                 :: i,j,aggfacxrt,aggfacyrt,ixxrt,jyyrt
+
+    numbasns = 0
+    gw_strm_msk = -9999
+
+!Open files...
+    open(unit=18,file=trim(gwbasmskfil),          &
+            form='formatted',status='old')
+
+!Read in sub-basin mask...
+    do j=jx,1,-1
+          read (18,*) (GWSUBBASMSK(i,j),i=1,ix)
+    end do
+    close(18)
+
+
+!Loop through to count number of basins and assign basin indices to chan grid
+     do J=1,JX
+       do I=1,IX
+
+!Determine max number of basins...(assumes basins are numbered
+!   sequentially from 1 to max number of basins...)
+        if (GWSUBBASMSK(i,j).gt.numbasns) then
+          numbasns = GWSUBBASMSK(i,j)   ! get count of basins...
+        end if
+
+!Assign gw basin index values to channel grid...
+        do AGGFACYRT=AGGFACTRT-1,0,-1
+          do AGGFACXRT=AGGFACTRT-1,0,-1
+
+             IXXRT=I*AGGFACTRT-AGGFACXRT
+             JYYRT=J*AGGFACTRT-AGGFACYRT
+             IF(ch_netrt(IXXRT,JYYRT).ge.0) then  !If channel grid cell
+               gw_strm_msk(IXXRT,JYYRT) = GWSUBBASMSK(i,j)  ! assign coarse grid basn indx to chan grid
+             END IF
+
+           end do !AGGFACXRT
+         end do !AGGFACYRT
+
+      end do   !I-ix
+    end do    !J-jx
+
+#ifdef HYDRO_D
+      write(6,*) "numbasns = ", numbasns
+#endif
+
+    return
+
+!DJG -----------------------------------------------------
+   END SUBROUTINE READ_SIMP_GW
+!DJG -----------------------------------------------------
+
+!Wei Yu
+  subroutine get_gw_strm_msk_lind (ixrt,jxrt,gw_strm_msk,numbasns,basnsInd,gw_strm_msk_lind)
+      implicit none
+      integer, intent(in) :: ixrt,jxrt, numbasns
+      integer, dimension(:,:) :: gw_strm_msk, gw_strm_msk_lind
+      integer, dimension(:) :: basnsInd
+      integer:: i,j,k,bas
+      gw_strm_msk_lind = -999
+      do j = 1, jxrt
+         do i = 1, ixrt
+             if(gw_strm_msk(i,j) .gt. 0) then
+                  do k = 1, numbasns
+                     if(gw_strm_msk(i,j) .eq. basnsInd(k)) then
+                          gw_strm_msk_lind(i,j) = k
+                     endif
+                  end do
+             end if
+         end do 
+      end do 
+         
+  end subroutine get_gw_strm_msk_lind
+
+  subroutine SIMP_GW_IND(ix,jx,GWSUBBASMSK,numbasns,gnumbasns,basnsInd)
+! create an index of basin mask so that it is faster for parallel computation.
+     implicit none
+     integer, intent(in) ::  ix,jx
+     integer, intent(in),dimension(ix,jx) ::  GWSUBBASMSK
+     integer, intent(out):: gnumbasns
+     integer, intent(inout):: numbasns
+     integer, intent(inout),allocatable,dimension(:):: basnsInd
+
+     integer,dimension(numbasns):: tmpbuf
+
+     integer :: i,j,k
+     
+     
+     gnumbasns = numbasns
+     numbasns = 0
+     tmpbuf = -999.
+
+     do j = 1,jx
+        do i = 1, ix
+           if(GWSUBBASMSK(i,j) .gt.0) then
+                tmpbuf(GWSUBBASMSK(i,j)) = GWSUBBASMSK(i,j) 
+           endif
+        end do
+     end do
+     do k = 1, gnumbasns
+         if(tmpbuf(k) .gt. 0) numbasns = numbasns + 1 
+     end do
+
+     allocate(basnsInd(numbasns))
+ 
+     i = 1 
+     do k = 1, gnumbasns
+         if(tmpbuf(k) .gt. 0) then
+             basnsInd(i) = tmpbuf(k)
+             i = i + 1
+         endif
+     end do
+#ifdef HYDRO_D
+     write(6,*) "check numbasns, gnumbasns : ", numbasns, gnumbasns
+#endif
+
+     return
+  end subroutine SIMP_GW_IND
+
+!Wei Yu
+  subroutine read_GWBUCKPARM (numbasns,gnumbasns, basnsInd, &
+                 gw_buck_coeff, gw_buck_exp, z_max, &
+                 z_gwsubbas, bas_id,basns_area)
+! read GWBUCKPARM file
+
+   implicit none
+   integer, intent(in) :: gnumbasns, numbasns
+   integer, intent(in),dimension(numbasns)  :: basnsInd
+   real, intent(out),dimension(numbasns) :: gw_buck_coeff, gw_buck_exp, z_max, &
+                 z_gwsubbas, basns_area
+   integer, intent(out),dimension(numbasns) :: bas_id
+   real, dimension(gnumbasns) :: tmp_buck_coeff, tmp_buck_exp, tmp_z_max, &
+                  tmp_z_gwsubbas,  tmp_basns_area
+   integer, dimension(gnumbasns) :: tmp_bas_id
+   CHARACTER(len=100)                     :: header 
+   CHARACTER(len=1)                       :: jnk
+   integer :: bas,k
+
+#ifdef MPP_LAND
+   if(my_id .eq. IO_id) then
+#endif
+!Read in GW bucket params and Zinit from input file in Run directory...
+#ifndef NCEP_WCOSS
+     OPEN(81, FILE='GWBUCKPARM.TBL',FORM='FORMATTED',STATUS='OLD')
+     read(81,811) header
+#else
+     OPEN(24, FORM='FORMATTED',STATUS='OLD')
+     read(24,811) header
+#endif
+811   FORMAT(A19)
+
+
+#ifndef NCEP_WCOSS
+     do bas = 1,gnumbasns
+
+! commented out the new GWBUCKPARM.TBL used for Caralina domain
+!new        read(81,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , & 
+!new              jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas),jnk,tmp_basns_area(bas)
+!new 812   FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4,A1,F11.3)
+
+!DJG...change bucket units to mm.... 812   FORMAT(I3,A1,F6.4,A1,F6.3,A1,F6.3,A1,F7.4)
+! following is old GWBUCKPARM.TBL
+       read(81,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , & 
+             jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas)
+812   FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4)
+
+     end do
+     close(81)
+#else
+     do bas = 1,gnumbasns
+         read(24,812) tmp_bas_id(bas),jnk,tmp_buck_coeff(bas),jnk,tmp_buck_exp(bas) , & 
+             jnk,tmp_z_max(bas), jnk,tmp_z_gwsubbas(bas)
+812   FORMAT(I8,A1,F6.4,A1,F6.3,A1,F6.2,A1,F7.4)
+
+     end do
+     close(24)
+#endif
+
+#ifdef MPP_LAND
+   endif
+
+   if(gnumbasns .gt. 0 ) then
+      call mpp_land_bcast_real(gnumbasns,tmp_buck_coeff)
+      call mpp_land_bcast_real(gnumbasns,tmp_buck_exp  )
+      call mpp_land_bcast_real(gnumbasns,tmp_z_max   )
+      call mpp_land_bcast_real(gnumbasns,tmp_z_gwsubbas   )
+      call mpp_land_bcast_real(gnumbasns,tmp_basns_area   )
+      call mpp_land_bcast_int(gnumbasns,tmp_bas_id)
+   endif
+#endif
+
+    do k = 1, numbasns
+       bas = basnsInd(k)
+       gw_buck_coeff(k) = tmp_buck_coeff(bas)
+       gw_buck_exp(k) = tmp_buck_exp(bas)
+       z_max(k) = tmp_z_max(bas)
+       z_gwsubbas(k) = tmp_z_gwsubbas(bas)
+       basns_area(k) = tmp_basns_area(bas)
+       bas_id(k) = tmp_bas_id(bas)
+    end do
+  end subroutine read_GWBUCKPARM
+
+
+
+  ! BF read the static input fields needed for the 2D GW scheme
+  subroutine readGW2d(ix, jx, hc, ihead, botelv, por, ltype, ihShift)
+  implicit none
+#include 
+  integer, intent(in) :: ix, jx
+  real, intent(in) :: ihShift
+  integer, dimension(ix,jx), intent(inout)::   ltype
+  real, dimension(ix,jx), intent(inout)   ::   hc, ihead, botelv, por
+
+#ifdef MPP_LAND
+  integer, dimension(:,:), allocatable ::  gLtype
+  real, dimension(:,:), allocatable    ::  gHC, gIHEAD, gBOTELV, gPOR
+#endif
+  integer :: i
+
+  
+#ifdef MPP_LAND
+  if(my_id .eq. IO_id) then
+      allocate(gHC(global_rt_nx, global_rt_ny))
+      allocate(gIHEAD(global_rt_nx, global_rt_ny))
+      allocate(gBOTELV(global_rt_nx, global_rt_ny))
+      allocate(gPOR(global_rt_nx, global_rt_ny))
+      allocate(gLtype(global_rt_nx, global_rt_ny))
+  else
+      allocate(gHC(1, 1))
+      allocate(gIHEAD(1, 1))
+      allocate(gBOTELV(1, 1))
+      allocate(gPOR(1, 1))
+      allocate(gLtype(1, 1))
+  endif
+ 
+#ifndef PARALLELIO 
+  if(my_id .eq. IO_id) then
+#endif
+#ifdef HYDRO_D
+  print*, "2D GW-Scheme selected, retrieving files from gwhires.nc ..."
+#endif
+#endif
+
+
+        ! hydraulic conductivity
+        i = get2d_real("HC", &
+#ifdef MPP_LAND
+#ifndef PARALLELIO 
+                       gHC, global_nx, global_ny,  &
+#else
+                       hc, ix, jx,  &
+#endif
+#else
+                       hc, ix, jx,  &
+#endif
+                       trim("./gwhires.nc"))
+
+        ! initial head
+        i = get2d_real("IHEAD", &
+#ifdef MPP_LAND
+                       gIHEAD, global_nx, global_ny, &
+#else
+                       ihead,  ix, jx, &
+#endif
+                       trim("./gwhires.nc"))
+                       
+        ! aquifer bottom elevation                
+        i = get2d_real("BOTELV", &
+#ifdef MPP_LAND
+#ifndef PARALLELIO 
+                       gBOTELV, global_nx, global_ny, &
+#else
+                       botelv, ix, jx,  &
+#endif
+#else
+                       botelv, ix, jx,  &
+#endif
+                       trim("./gwhires.nc"))
+                       
+	! aquifer porosity
+        i = get2d_real("POR", &
+#ifdef MPP_LAND
+#ifndef PARALLELIO 
+                       gPOR, global_nx, global_ny, &
+#else
+                       por, ix, jx,  &
+#endif
+#else
+                       por, ix, jx,  &
+#endif
+                       trim("./gwhires.nc"))
+
+
+	! groundwater model mask (0 no aquifer, aquifer > 0
+        call get2d_int("LTYPE", &
+#ifdef MPP_LAND
+#ifndef PARALLELIO 
+                       gLtype, global_nx, global_ny, &
+#else
+                       ltype, ix, jx, &
+#endif
+#else
+                       ltype, ix, jx,  &
+#endif
+                       trim("./gwhires.nc"))
+
+ 
+#ifdef MPP_LAND
+#ifndef PARALLELIO 
+       gLtype(1,:) = 2
+       gLtype(:,1) = 2
+       gLtype(global_rt_nx,:) = 2
+       gLtype(:,global_rt_ny) = 2 
+#else
+! BF TODO parallel io for gw ltype
+#endif
+#else
+       ltype(1,:) = 2
+       ltype(:,1) = 2
+       ltype(ix,:)= 2
+       ltype(:,jx)= 2
+#endif
+
+#ifdef MPP_LAND  
+#ifndef PARALLELIO 
+  endif
+     call decompose_rt_int (gLtype, ltype, global_rt_nx, global_rt_ny, ix, jx)
+     call decompose_rt_real(gHC,hc,global_rt_nx, global_rt_ny, ix, jx)
+     call decompose_rt_real(gIHEAD,ihead,global_rt_nx, global_rt_ny, ix, jx)
+     call decompose_rt_real(gBOTELV,botelv,global_rt_nx, global_rt_ny, ix, jx)
+     call decompose_rt_real(gPOR,por,global_rt_nx, global_rt_ny, ix, jx)
+     if(allocated(gLtype)) deallocate(gLtype)
+     if(allocated(gHC)) deallocate(gHC)
+     if(allocated(gIHEAD)) deallocate(gIHEAD)
+     if(allocated(gBOTELV)) deallocate(gBOTELV)
+     if(allocated(gPOR)) deallocate(gPOR)
+#endif
+#endif
+ 
+    
+  ihead = ihead + ihShift
+  
+  where(ltype .eq. 0) 
+   hc = 0.
+!yw   por = 10**21
+   por = 10E21
+  end where
+
+  
+  !bftodo: make filename accessible in namelist
+  return
+  end subroutine readGW2d
+  !BF
+ 
+  subroutine output_rt(igrid, split_output_count, ixrt, jxrt, nsoil, &
+       startdate, date, QSUBRT,ZWATTABLRT,SMCRT,SUB_RESID,       &
+       q_sfcflx_x,q_sfcflx_y,soxrt,soyrt,QSTRMVOLRT,SFCHEADSUBRT, &
+       geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,CHRTOUT_GRID,  &
+       QBDRYRT    &
+#ifdef HYDRO_REALTIME
+       , iocflag &
+#endif
+       )
+
+!output the routing variables over routing grid.
+    implicit none
+#include 
+
+    integer,                                  intent(in) :: igrid
+#ifdef HYDRO_REALTIME
+    integer,                                  intent(in) :: iocflag
+#endif
+    integer,                                  intent(in) :: split_output_count
+    integer,                                  intent(in) :: ixrt,jxrt
+    real,                                     intent(in) :: dt
+    real,                                     intent(in) :: dist(ixrt,jxrt,9)
+    integer,                                  intent(in) :: nsoil
+    integer,                                  intent(in) :: CHRTOUT_GRID
+    character(len=*),                         intent(in) :: startdate
+    character(len=*),                         intent(in) :: date
+    character(len=*),          intent(in)                :: geo_finegrid_flnm
+    real,             dimension(nsoil),       intent(in) :: sldpth
+    real, allocatable, DIMENSION(:,:)                   :: xdumd  !-- decimated variable
+    real*8, allocatable, DIMENSION(:)                   :: xcoord_d
+    real*8, allocatable, DIMENSION(:)                   :: ycoord_d, ycoord
+
+    integer, save :: ncid,ncstatic
+    integer, save :: output_count
+    real,    dimension(nsoil) :: asldpth
+
+    integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n
+    integer :: iret, dimid_soil, i,j,ii,jj
+    character(len=256) :: output_flnm
+    character(len=19)  :: date19
+    character(len=32)  :: convention
+    character(len=34)  :: sec_since_date
+    character(len=34)  :: sec_valid_date
+
+    character(len=30)  :: soilm
+
+    real                                :: long_cm,lat_po,fe,fn, chan_in
+    real, dimension(2)                  :: sp
+
+    real, dimension(ixrt,jxrt) :: xdum,QSUBRT,ZWATTABLRT,SUB_RESID
+    real, dimension(ixrt,jxrt) :: q_sfcflx_x,q_sfcflx_y
+    real, dimension(ixrt,jxrt) :: QSTRMVOLRT
+    real, dimension(ixrt,jxrt) :: SFCHEADSUBRT
+    real, dimension(ixrt,jxrt) :: soxrt,soyrt
+    real, dimension(ixrt,jxrt) :: LATVAL,LONVAL, QBDRYRT
+    real, dimension(ixrt,jxrt,nsoil) :: SMCRT
+
+    character(len=2) :: strTmp
+
+    integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag
+    sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
+    seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1))
+    sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) &
+                  //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC'
+
+    decimation = 1 !-- decimation factor
+#ifdef MPP_LAND
+    ixrtd = int(global_rt_nx/decimation)
+    jxrtd = int(global_rt_ny/decimation)
+#else
+    ixrtd = int(ixrt/decimation)
+    jxrtd = int(jxrt/decimation)
+#endif
+
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+#endif
+       allocate(xdumd(ixrtd,jxrtd))
+       allocate(xcoord_d(ixrtd))
+       allocate(ycoord_d(jxrtd))
+       allocate(ycoord(jxrtd))
+
+       xdumd = -999
+       xcoord_d = -999 
+       ycoord_d = -999
+       ycoord = -999
+#ifdef MPP_LAND
+    else
+       allocate(xdumd(1,1))
+       allocate(xcoord_d(1))
+       allocate(ycoord_d(1))
+       allocate(ycoord(1))
+    endif
+#endif
+    ii = 0
+
+!DJG Dump timeseries for channel inflow accum. for calibration...(8/28/09)
+    chan_in = 0.0
+    do j=1,jxrt
+      do i=1,ixrt
+        chan_in=chan_in+QSTRMVOLRT(I,J)/1000.0*(dist(i,j,9))  !(units m^3)
+      enddo
+    enddo
+#ifdef MPP_LAND
+      call sum_real1(chan_in)
+#endif
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+#endif
+#ifdef NCEP_WCOSS
+       open (unit=54, form='formatted', status='unknown', position='append')
+        write (54,713) chan_in
+       close (54)
+#else
+#ifndef HYDRO_REALTIME
+       open (unit=46,file='qstrmvolrt_accum.txt',form='formatted',&
+             status='unknown',position='append')
+        write (46,713) chan_in
+       close (46)
+#endif
+#endif
+#ifdef MPP_LAND
+    endif
+#endif
+713 FORMAT (F20.7)
+!    return
+!DJG end dump of channel inflow for calibration....
+
+    if (CHRTOUT_GRID.eq.0) return  ! return if hires flag eq 1, if =2 output full grid
+
+    if (output_count == 0) then  
+
+   !-- Open the  finemesh static files to obtain projection information
+#ifdef HYDRO_D
+      write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm)
+#endif
+
+#ifdef MPP_LAND
+   if(my_id .eq. io_id) then
+#endif
+      iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic)
+#ifdef MPP_LAND
+   endif
+   call mpp_land_bcast_int1(iret)
+#endif
+
+      if (iret /= 0) then
+         write(*,'("Problem opening geo_finegrid file: ''", A, "''")') &
+         trim(geo_finegrid_flnm)
+         write(*,*) "HIRES_OUTPUT will not be georeferenced..."
+        hires_flag = 0
+      else
+        hires_flag = 1
+      endif
+
+#ifdef MPP_LAND
+   if(my_id .eq. io_id) then
+#endif
+
+     if(hires_flag.eq.1) then !if/then hires_georef
+      ! Get Latitude (X)
+      iret = NF_INQ_VARID(ncstatic,'x',varid)
+      if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord_d)
+      ! Get Longitude (Y)
+      iret = NF_INQ_VARID(ncstatic,'y',varid)
+      if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord)
+     else
+      ycoord_d = 0.
+      xcoord_d = 0.
+     end if  !endif hires_georef 
+
+     jj = 0
+#ifdef MPP_LAND
+     do j=global_rt_ny,1,-1*decimation
+#else
+     do j=jxrt,1,-1*decimation
+#endif
+        jj = jj+1
+        if (jj<= jxrtd) then
+         ycoord_d(jj) = ycoord(j)
+        endif
+     enddo
+
+       
+#ifndef HYDRO_REALTIME
+     if(hires_flag.eq.1) then !if/then hires_georef
+      ! Get projection information from finegrid netcdf file
+      iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid)
+      if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp)  !-- read it from the static file
+     end if  !endif hires_georef 
+      iret = nf_close(ncstatic)
+#endif
+
+!-- create the fine grid routing file
+       write(output_flnm, '(A12,".RTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+#ifdef HYDRO_D
+       print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       write(6,*) "using normal netcdf file for RTOUT_DOMAIN"
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#else
+       write(6,*) "using large netcdf file for RTOUT_DOMAIN"
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+       if (iret /= 0) then
+         call hydro_stop("In output_rt() - Problem nf_create")
+       endif
+
+       iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times)
+       iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix)  !-- make a decimated grid
+       iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx)
+#ifndef HYDRO_REALTIME
+       iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil)  !-- 3-d soils
+#endif
+
+!--- define variables
+!     !- time definition, timeObs
+	 iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid)
+         iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time')
+         iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date)
+
+#ifndef HYDRO_REALTIME
+       !- x-coordinate in cartesian system
+        iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection')
+        iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate')
+        iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- y-coordinate in cartesian ssystem
+          iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid)
+          iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection')
+          iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate')
+          iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- LATITUDE
+        iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE')
+        iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE')
+        iret = nf_put_att_text(ncid,varid,'units',5,'deg North')
+
+       !- LONGITUDE
+          iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid)
+          iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE')
+          iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE')
+          iret = nf_put_att_text(ncid,varid,'units',5,'deg east')
+
+       !-- z-level is soil
+        iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid)
+        iret = nf_put_att_text(ncid,varid,'units',2,'cm')
+        iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer')
+
+         do n = 1, NSOIL
+             write(strTmp,'(I2)') n
+             iret = nf_def_var(ncid,  "SOIL_M"//trim(strTmp),  NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+         end do
+            iret = nf_put_att_text(ncid,varid,'units',7,'m^3/m^3')
+            iret = nf_put_att_text(ncid,varid,'description',16,'moisture content')
+            iret = nf_put_att_text(ncid,varid,'long_name',26,soilm)
+!           iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z')
+            iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+            iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!      iret = nf_def_var(ncid,"ESNOW2D",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+
+!       iret = nf_def_var(ncid,"QSUBRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+!       iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1')
+!       iret = nf_put_att_text(ncid,varid,'long_name',15,'subsurface flow')
+!       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+!       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+!       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+#endif
+
+#ifdef HYDRO_REALTIME
+	if ( (iocflag .ge. 0) .and. (iocflag .ne. 4) ) then
+#endif
+          iret = nf_def_var(ncid,"zwattablrt",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+          iret = nf_put_att_text(ncid,varid,'units',1,'m')
+          iret = nf_put_att_text(ncid,varid,'long_name',17,'water table depth')
+          iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+          iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+          iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!       iret = nf_def_var(ncid,"Q_SFCFLX_X",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+!       iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1')
+!       iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux x')
+!       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+!       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+!       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!       iret = nf_def_var(ncid,"Q_SFCFLX_Y",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+!       iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1')
+!       iret = nf_put_att_text(ncid,varid,'long_name',14,'surface flux y')
+!       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+!       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+!       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+       iret = nf_def_var(ncid,"sfcheadsubrt",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+#ifdef HYDRO_REALTIME
+        endif
+#endif
+
+#ifndef HYDRO_REALTIME   
+       iret = nf_def_var(ncid,"QSTRMVOLRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',14,'channel inflow')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!      iret = nf_def_var(ncid,"SOXRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+!      iret = nf_put_att_text(ncid,varid,'units',1,'1')
+!      iret = nf_put_att_text(ncid,varid,'long_name',7,'slope x')
+!      iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+!      iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+!      iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!      iret = nf_def_var(ncid,"SOYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+!      iret = nf_put_att_text(ncid,varid,'units',1,'1')
+!      iret = nf_put_att_text(ncid,varid,'long_name',7,'slope 7')
+!      iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+!      iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+!      iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!       iret = nf_def_var(ncid,"SUB_RESID",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+
+       iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',70, &
+          'accumulated value of the boundary flux, + into domain, - out of domain')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!-- place projection information
+     if(hires_flag.eq.1) then !if/then hires_georef
+      iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid)
+      iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic')
+      iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm)
+      iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po)
+      iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe)
+      iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn)
+      iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp)
+     end if   !endif hires_georef
+#endif
+
+!      iret = nf_def_var(ncid,"Date",   NF_CHAR,  2, (/dimid_datelen,dimid_times/),     varid)
+
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(startdate)) = startdate
+      convention(1:32) = "CF-1.0"
+      iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+      iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation)
+
+       ! iret = nf_redef(ncid)
+       iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate))
+       ! iret = nf_enddef(ncid)
+
+      iret = nf_enddef(ncid)
+
+#ifndef HYDRO_REALTIME
+!!-- write latitude and longitude locations
+         iret = nf_inq_varid(ncid,"x", varid)
+         iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array
+
+         iret = nf_inq_varid(ncid,"y", varid)
+         iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array
+#endif
+
+#ifdef MPP_LAND
+    endif
+#endif
+
+iret = nf_inq_varid(ncid,"time", varid)
+iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since)
+
+#ifndef HYDRO_REALTIME
+#ifdef MPP_LAND
+        call write_IO_rt_real(LATVAL,xdumd)
+    if( my_id .eq. io_id) then
+#else
+        xdumd = LATVAL
+#endif
+        iret = nf_inq_varid(ncid,"LATITUDE", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+
+
+#ifdef MPP_LAND
+    endif   !!! end if block of my_id .eq. io_id
+
+        call write_IO_rt_real(LONVAL,xdumd)
+
+    if( my_id .eq. io_id) then
+#else
+        xdumd = LONVAL
+#endif
+        iret = nf_inq_varid(ncid,"LONGITUDE", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+
+#ifdef MPP_LAND
+    endif
+
+    if( my_id .eq. io_id) then
+#endif
+
+
+
+
+
+
+       do n = 1,nsoil
+        if(n == 1) then
+         asldpth(n) = -sldpth(n)
+        else
+         asldpth(n) = asldpth(n-1) - sldpth(n)
+        endif
+       enddo
+
+       iret = nf_inq_varid(ncid,"depth", varid)
+       iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth)
+!yw       iret = nf_close(ncstatic)
+#ifdef MPP_LAND
+    endif  ! end of my_id .eq. io_id
+#endif
+#endif
+
+   endif !!! end of if block output_count == 0
+    output_count = output_count + 1
+
+#ifndef HYDRO_REALTIME
+!-- 3-d soils
+     do n = 1, nsoil
+#ifdef MPP_LAND
+          call write_IO_rt_real(smcrt(:,:,n),xdumd)
+#else
+          xdumd(:,:) = smcrt(:,:,n)
+#endif
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+#endif
+          write(strTmp,'(I2)') n
+          iret = nf_inq_varid(ncid,  "SOIL_M"//trim(strTmp), varid)
+          iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+#ifdef MPP_LAND
+    endif
+#endif
+    enddo !-n soils
+#endif
+
+#ifdef HYDRO_REALTIME
+   if ( (iocflag .ge. 0) .and. (iocflag .ne. 4)  ) then
+#endif
+#ifdef MPP_LAND
+          call write_IO_rt_real(ZWATTABLRT,xdumd)
+#else
+          xdumd(:,:) = ZWATTABLRT(:,:)
+#endif
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+#endif
+        iret = nf_inq_varid(ncid,  "zwattablrt", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+#ifdef MPP_LAND
+     endif
+#endif
+#ifdef HYDRO_REALTIME
+   endif
+#endif
+
+#ifndef HYDRO_REALTIME
+#ifdef MPP_LAND
+          call write_IO_rt_real(QBDRYRT,xdumd)
+#else
+          xdumd(:,:) = QBDRYRT(:,:)
+#endif
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+#endif
+     iret = nf_inq_varid(ncid,  "QBDRYRT", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+#ifdef MPP_LAND
+     endif
+#endif
+
+#ifdef MPP_LAND
+          call write_IO_rt_real(QSTRMVOLRT,xdumd)
+#else
+          xdumd(:,:) = QSTRMVOLRT(:,:)
+#endif
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+#endif
+     iret = nf_inq_varid(ncid,  "QSTRMVOLRT", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+#ifdef MPP_LAND
+     endif
+#endif
+#endif
+ 
+#ifdef HYDRO_REALTIME
+   if ( (iocflag .ge. 0) .and. (iocflag .ne. 4) ) then
+#endif
+#ifdef MPP_LAND
+          call write_IO_rt_real(SFCHEADSUBRT,xdumd)
+#else
+          xdumd(:,:) = SFCHEADSUBRT(:,:)
+#endif
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+#endif
+     iret = nf_inq_varid(ncid,  "sfcheadsubrt", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+#ifdef MPP_LAND
+     endif
+#endif
+#ifdef HYDRO_REALTIME
+   endif
+#endif
+
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+#endif
+
+
+!yw      iret = nf_sync(ncid)
+      if (output_count == split_output_count) then
+        output_count = 0
+        iret = nf_close(ncid)
+      endif
+#ifdef MPP_LAND
+     endif
+     call mpp_land_bcast_int1(output_count)
+#endif
+
+     if(allocated(xdumd))  deallocate(xdumd)
+     if(allocated(xcoord_d))  deallocate(xcoord_d)
+     if(allocated(ycoord_d)) deallocate(ycoord_d)
+     if(allocated(ycoord))  deallocate(ycoord)
+    
+#ifdef HYDRO_D 
+     write(6,*) "end of output_rt" 
+#endif
+
+  end subroutine output_rt
+
+
+!BF output section for gw2d model
+!bftodo: clean up an customize for GW usage
+
+  subroutine output_gw_spinup(igrid, split_output_count, ixrt, jxrt, &
+       startdate, date, HEAD, convgw, excess, &
+       geo_finegrid_flnm,dt,LATVAL,LONVAL,dist,output_gw)
+
+#ifdef MPP_LAND
+       USE module_mpp_land
+#endif
+!output the routing variables over routing grid.
+    implicit none
+#include 
+
+    integer,                                  intent(in) :: igrid
+    integer,                                  intent(in) :: split_output_count
+    integer,                                  intent(in) :: ixrt,jxrt
+    real,                                     intent(in) :: dt
+    real,                                     intent(in) :: dist(ixrt,jxrt,9)
+    integer,                                  intent(in) ::  output_gw
+    character(len=*),                         intent(in) :: startdate
+    character(len=*),                         intent(in) :: date
+    character(len=*),          intent(in)                :: geo_finegrid_flnm
+    real, allocatable, DIMENSION(:,:)                   :: xdumd  !-- decimated variable
+    real*8, allocatable, DIMENSION(:)                   :: xcoord_d, xcoord
+    real*8, allocatable, DIMENSION(:)                   :: ycoord_d, ycoord
+
+    integer, save :: ncid,ncstatic
+    integer, save :: output_count
+
+    integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n
+    integer :: iret, dimid_soil, i,j,ii,jj
+    character(len=256) :: output_flnm
+    character(len=19)  :: date19
+    character(len=32)  :: convention
+    character(len=34)  :: sec_since_date
+    character(len=34)  :: sec_valid_date
+
+    character(len=30)  :: soilm
+
+    real                                :: long_cm,lat_po,fe,fn, chan_in
+    real, dimension(2)                  :: sp
+
+    real, dimension(ixrt,jxrt) :: head, convgw, excess, &
+                                  latval, lonval
+
+    integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag
+    
+#ifdef MPP_LAND
+    real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gExcess                                                  
+    real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval
+#endif
+    
+#ifdef MPP_LAND
+    call MPP_LAND_COM_REAL(convgw, ixrt, jxrt, 99)
+    call write_IO_rt_real(latval,gLatval)
+    call write_IO_rt_real(lonval,gLonval)
+    call write_IO_rt_real(head,gHead)
+    call write_IO_rt_real(convgw,gConvgw)
+    call write_IO_rt_real(excess,gExcess)
+    
+
+   if(my_id.eq.IO_id) then
+     
+
+#endif
+    seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1))
+    sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
+    sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) &
+                  //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC'
+
+    decimation = 1 !-- decimation factor
+#ifdef MPP_LAND
+    ixrtd = int(global_rt_nx/decimation)
+    jxrtd = int(global_rt_ny/decimation)
+#else
+    ixrtd = int(ixrt/decimation)
+    jxrtd = int(jxrt/decimation)
+#endif
+    allocate(xdumd(ixrtd,jxrtd))
+    allocate(xcoord_d(ixrtd))
+    allocate(ycoord_d(jxrtd))
+    allocate(xcoord(ixrtd))
+    allocate(ycoord(jxrtd))
+    ii = 0
+    jj = 0
+
+    if (output_gw.eq.0) return  ! return if hires flag eq 0, if =1 output full grid
+
+    if (output_count == 0) then
+
+   !-- Open the  finemesh static files to obtain projection information
+#ifdef HYDRO_D
+      write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm)
+
+#endif
+      iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic)
+
+      if (iret /= 0) then
+#ifdef HYDRO_D
+         write(*,'("Problem opening geo_finegrid file: ''", A, "''")') &
+         trim(geo_finegrid_flnm)
+         write(*,*) "HIRES_OUTPUT will not be georeferenced..."
+#endif
+        hires_flag = 0
+      else
+        hires_flag = 1
+      endif
+
+     if(hires_flag.eq.1) then !if/then hires_georef
+      ! Get Latitude (X)
+      iret = NF_INQ_VARID(ncstatic,'x',varid)
+      if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord)
+      ! Get Longitude (Y)
+      iret = NF_INQ_VARID(ncstatic,'y',varid)
+      if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord)
+     else
+      xcoord_d = 0.
+      ycoord_d = 0.
+     end if  !endif hires_georef 
+
+     do j=jxrtd,1,-1*decimation
+        jj = jj+1
+        if (jj<= jxrtd) then
+         ycoord_d(jj) = ycoord(j)
+        endif
+     enddo
+
+!yw     do i = 1,ixrt,decimation
+!yw        ii = ii + 1
+!yw        if (ii <= ixrtd) then 
+!yw         xcoord_d(ii) = xcoord(i)
+         xcoord_d = xcoord
+!yw        endif
+!yw     enddo
+       
+
+     if(hires_flag.eq.1) then !if/then hires_georef
+      ! Get projection information from finegrid netcdf file
+      iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid)
+      if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp)  !-- read it from the static file
+     end if  !endif hires_georef 
+      iret = nf_close(ncstatic)
+
+!-- create the fine grid routing file
+       write(output_flnm, '(A12,".GW_SPINUP",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+#ifdef HYDRO_D
+       print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#else
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+
+       if (iret /= 0) then
+         call hydro_stop("In output_gw_spinup() - Problem nf_create")
+       endif
+
+       iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times)
+       iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix)  !-- make a decimated grid
+       iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx)
+
+!--- define variables
+       !- time definition, timeObs
+       iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date)
+
+       !- x-coordinate in cartesian system
+       iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection')
+       iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate')
+       iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- y-coordinate in cartesian ssystem
+       iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection')
+       iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate')
+       iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- LATITUDE
+       iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE')
+       iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE')
+       iret = nf_put_att_text(ncid,varid,'units',5,'deg North')
+
+       !- LONGITUDE
+       iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE')
+       iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE')
+       iret = nf_put_att_text(ncid,varid,'units',5,'deg east')
+
+
+       iret = nf_def_var(ncid,"GwHead",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',1,'m')
+       iret = nf_put_att_text(ncid,varid,'long_name',17,'groundwater head')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+       iret = nf_def_var(ncid,"GwConv",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',12,'groundwater convergence')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+       
+       iret = nf_def_var(ncid,"GwExcess",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',1,'m')
+       iret = nf_put_att_text(ncid,varid,'long_name',17,'surface excess groundwater')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+!-- place projection information
+     if(hires_flag.eq.1) then !if/then hires_georef
+      iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid)
+      iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic')
+      iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm)
+      iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po)
+      iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe)
+      iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn)
+      iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp)
+     end if   !endif hires_georef
+
+!      iret = nf_def_var(ncid,"Date",   NF_CHAR,  2, (/dimid_datelen,dimid_times/),     varid)
+
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(startdate)) = startdate
+      convention(1:32) = "CF-1.0"
+      iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+      iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation)
+
+      iret = nf_enddef(ncid)
+
+!!-- write latitude and longitude locations
+!       xdumd = LATVAL
+        iret = nf_inq_varid(ncid,"x", varid)
+!       iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+	iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array
+
+!       xdumd = LONVAL
+        iret = nf_inq_varid(ncid,"y", varid)
+!       iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+        iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array
+
+#ifdef MPP_LAND
+        xdumd = gLATVAL
+#else  
+        xdumd = LATVAL
+#endif
+        iret = nf_inq_varid(ncid,"LATITUDE", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+
+#ifdef MPP_LAND
+        xdumd = gLONVAL
+#else  
+        xdumd = LONVAL
+#endif
+        iret = nf_inq_varid(ncid,"LONGITUDE", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+
+
+    endif
+
+    output_count = output_count + 1
+
+!!-- time
+        iret = nf_inq_varid(ncid,"time", varid)
+        iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since)
+
+
+#ifdef MPP_LAND
+        xdumd = gHead
+#else  
+        xdumd = head
+#endif
+
+     iret = nf_inq_varid(ncid,  "GwHead", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+
+#ifdef MPP_LAND
+        xdumd = gConvgw
+#else  
+        xdumd = convgw
+#endif
+     iret = nf_inq_varid(ncid,  "GwConv", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+
+     
+#ifdef MPP_LAND
+        xdumd = gExcess
+#else  
+        xdumd = excess
+#endif
+     iret = nf_inq_varid(ncid,  "GwExcess", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+ 
+     
+!!time in seconds since startdate
+
+       iret = nf_redef(ncid)
+       date19(1:len_trim(date)) = date
+       iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate))
+ 
+       iret = nf_enddef(ncid)
+      iret = nf_sync(ncid)
+      if (output_count == split_output_count) then
+        output_count = 0
+        iret = nf_close(ncid)
+      endif
+
+     if(allocated(xdumd))  deallocate(xdumd)
+     if(allocated(xcoord_d)) deallocate(xcoord_d)
+     if(allocated(xcoord)) deallocate(xcoord)
+     if(allocated(ycoord_d)) deallocate(ycoord_d)
+     if(allocated(ycoord)) deallocate(ycoord)
+    
+#ifdef MPP_LAND
+    endif
+#endif
+
+  end subroutine output_gw_spinup
+
+
+subroutine sub_output_gw(igrid, split_output_count, ixrt, jxrt, nsoil, &
+       startdate, date, HEAD, SMCRT, convgw, excess, qsgwrt, qgw_chanrt, &
+       geo_finegrid_flnm,dt,sldpth,LATVAL,LONVAL,dist,output_gw)
+
+#ifdef MPP_LAND
+       USE module_mpp_land
+#endif
+!output the routing variables over routing grid.
+    implicit none
+#include 
+
+    integer,                                  intent(in) :: igrid
+    integer,                                  intent(in) :: split_output_count
+    integer,                                  intent(in) :: ixrt,jxrt
+    real,                                     intent(in) :: dt
+    real,                                     intent(in) :: dist(ixrt,jxrt,9)
+    integer,                                  intent(in) :: nsoil
+    integer,                                  intent(in) ::  output_gw
+    character(len=*),                         intent(in) :: startdate
+    character(len=*),                         intent(in) :: date
+    character(len=*),          intent(in)                :: geo_finegrid_flnm
+    real,             dimension(nsoil),       intent(in) :: sldpth
+    real, allocatable, DIMENSION(:,:)                   :: xdumd  !-- decimated variable
+    real*8, allocatable, DIMENSION(:)                   :: xcoord_d, xcoord
+    real*8, allocatable, DIMENSION(:)                   :: ycoord_d, ycoord
+
+    integer, save :: ncid,ncstatic
+    integer, save :: output_count
+    real,    dimension(nsoil) :: asldpth
+
+    integer :: dimid_ix, dimid_jx, dimid_times, dimid_datelen, varid, n
+    integer :: iret, dimid_soil, i,j,ii,jj
+    character(len=256) :: output_flnm
+    character(len=19)  :: date19
+    character(len=32)  :: convention
+    character(len=34)  :: sec_since_date
+    character(len=34)  :: sec_valid_date
+
+    character(len=30)  :: soilm
+
+    real                                :: long_cm,lat_po,fe,fn, chan_in
+    real, dimension(2)                  :: sp
+
+    real, dimension(ixrt,jxrt) :: head, convgw, excess, &
+                                  qsgwrt, qgw_chanrt, &
+                                  latval, lonval
+    real, dimension(ixrt,jxrt,nsoil) :: SMCRT
+
+    integer :: seconds_since, decimation, ixrtd,jxrtd, hires_flag
+    
+#ifdef MPP_LAND
+    real, dimension(global_rt_nx,global_rt_ny) :: gHead, gConvgw, gqsgwrt, gExcess, &
+                                                  gQgw_chanrt
+    real, dimension(global_rt_nx,global_rt_ny) :: gLatval, gLonval
+    real, dimension(global_rt_nx,global_rt_ny,nsoil) :: gSMCRT
+#endif
+    
+#ifdef MPP_LAND
+    call MPP_LAND_COM_REAL(convgw, ixrt, jxrt, 99)
+    call MPP_LAND_COM_REAL(qsgwrt, ixrt, jxrt, 99)
+    call MPP_LAND_COM_REAL(qgw_chanrt, ixrt, jxrt, 99)
+    call write_IO_rt_real(latval,gLatval)
+    call write_IO_rt_real(lonval,gLonval)
+    call write_IO_rt_real(qsgwrt,gqsgwrt)
+    call write_IO_rt_real(qgw_chanrt,gQgw_chanrt)
+    call write_IO_rt_real(head,gHead)
+    call write_IO_rt_real(convgw,gConvgw)
+    call write_IO_rt_real(excess,gExcess)
+    
+    do i = 1, NSOIL
+     call MPP_LAND_COM_REAL(smcrt(:,:,i), ixrt, jxrt, 99)
+     call write_IO_rt_real(SMCRT(:,:,i),gSMCRT(:,:,i))
+    end do
+
+   if(my_id.eq.IO_id) then
+     
+
+#endif
+    seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1))
+    sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
+    sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) &
+                  //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC'
+
+    decimation = 1 !-- decimation factor
+#ifdef MPP_LAND
+    ixrtd = int(global_rt_nx/decimation)
+    jxrtd = int(global_rt_ny/decimation)
+#else
+    ixrtd = int(ixrt/decimation)
+    jxrtd = int(jxrt/decimation)
+#endif
+    allocate(xdumd(ixrtd,jxrtd))
+    allocate(xcoord_d(ixrtd))
+    allocate(ycoord_d(jxrtd))
+    allocate(xcoord(ixrtd))
+    allocate(ycoord(jxrtd))
+    ii = 0
+    jj = 0
+
+    if (output_gw.eq.0) return  ! return if hires flag eq 0, if =1 output full grid
+
+    if (output_count == 0) then
+
+   !-- Open the  finemesh static files to obtain projection information
+#ifdef HYDRO_D
+      write(*,'("geo_finegrid_flnm: ''", A, "''")') trim(geo_finegrid_flnm)
+
+#endif
+      iret = nf_open(trim(geo_finegrid_flnm), NF_NOWRITE, ncstatic)
+
+      if (iret /= 0) then
+#ifdef HYDRO_D
+         write(*,'("Problem opening geo_finegrid file: ''", A, "''")') &
+         trim(geo_finegrid_flnm)
+         write(*,*) "HIRES_OUTPUT will not be georeferenced..."
+#endif
+        hires_flag = 0
+      else
+        hires_flag = 1
+      endif
+
+     if(hires_flag.eq.1) then !if/then hires_georef
+      ! Get Latitude (X)
+      iret = NF_INQ_VARID(ncstatic,'x',varid)
+      if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, xcoord)
+      ! Get Longitude (Y)
+      iret = NF_INQ_VARID(ncstatic,'y',varid)
+      if(iret .eq. 0) iret = NF_GET_VAR_DOUBLE(ncstatic, varid, ycoord)
+     else
+      xcoord_d = 0.
+      ycoord_d = 0.
+     end if  !endif hires_georef 
+
+     do j=jxrtd,1,-1*decimation
+        jj = jj+1
+        if (jj<= jxrtd) then
+         ycoord_d(jj) = ycoord(j)
+        endif
+     enddo
+
+!yw     do i = 1,ixrt,decimation
+!yw        ii = ii + 1
+!yw        if (ii <= ixrtd) then 
+!yw         xcoord_d(ii) = xcoord(i)
+         xcoord_d = xcoord
+!yw        endif
+!yw     enddo
+       
+
+     if(hires_flag.eq.1) then !if/then hires_georef
+      ! Get projection information from finegrid netcdf file
+      iret = NF_INQ_VARID(ncstatic,'lambert_conformal_conic',varid)
+      if(iret .eq. 0) iret = NF_GET_ATT_REAL(ncstatic, varid, 'longitude_of_central_meridian', long_cm)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'latitude_of_projection_origin', lat_po)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_easting', fe)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'false_northing', fn)  !-- read it from the static file
+      iret = NF_GET_ATT_REAL(ncstatic, varid, 'standard_parallel', sp)  !-- read it from the static file
+     end if  !endif hires_georef 
+      iret = nf_close(ncstatic)
+
+!-- create the fine grid routing file
+       write(output_flnm, '(A12,".GW_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+#ifdef HYDRO_D
+       print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#else
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+
+       if (iret /= 0) then
+         call hydro_stop("In output_gw_spinup() - Problem nf_create")
+       endif
+
+       iret = nf_def_dim(ncid, "time", NF_UNLIMITED, dimid_times)
+       iret = nf_def_dim(ncid, "x", ixrtd, dimid_ix)  !-- make a decimated grid
+       iret = nf_def_dim(ncid, "y", jxrtd, dimid_jx)
+       iret = nf_def_dim(ncid, "depth", nsoil, dimid_soil)  !-- 3-d soils
+
+!--- define variables
+       !- time definition, timeObs
+       iret = nf_def_var(ncid,"time",NF_INT, 1, (/dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date)
+
+       !- x-coordinate in cartesian system
+       iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/dimid_ix/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection')
+       iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate')
+       iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- y-coordinate in cartesian ssystem
+       iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/dimid_jx/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection')
+       iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate')
+       iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- LATITUDE
+       iret = nf_def_var(ncid,"LATITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',8,'LATITUDE')
+       iret = nf_put_att_text(ncid,varid,'standard_name',8,'LATITUDE')
+       iret = nf_put_att_text(ncid,varid,'units',5,'deg North')
+
+       !- LONGITUDE
+       iret = nf_def_var(ncid,"LONGITUDE",NF_FLOAT, 2, (/dimid_ix,dimid_jx/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',9,'LONGITUDE')
+       iret = nf_put_att_text(ncid,varid,'standard_name',9,'LONGITUDE')
+       iret = nf_put_att_text(ncid,varid,'units',5,'deg east')
+
+       !-- z-level is soil
+       iret = nf_def_var(ncid,"depth", NF_FLOAT, 1, (/dimid_soil/),varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'cm')
+       iret = nf_put_att_text(ncid,varid,'long_name',19,'depth of soil layer')
+
+       iret = nf_def_var(ncid,  "SOIL_M",  NF_FLOAT, 4, (/dimid_ix,dimid_jx,dimid_soil,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',6,'kg m-2')
+       iret = nf_put_att_text(ncid,varid,'description',16,'moisture content')
+       iret = nf_put_att_text(ncid,varid,'long_name',26,soilm)
+!      iret = nf_put_att_text(ncid,varid,'coordinates',5,'x y z')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+       iret = nf_def_var(ncid,"HEAD",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',1,'m')
+       iret = nf_put_att_text(ncid,varid,'long_name',17,'groundwater head')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+       iret = nf_def_var(ncid,"CONVGW",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',12,'channel flux')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+       
+       iret = nf_def_var(ncid,"GwExcess",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',1,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',17,'surface excess groundwater')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+       iret = nf_def_var(ncid,"QSGWRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+       iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+
+       iret = nf_def_var(ncid,"QGW_CHANRT",NF_FLOAT, 3, (/dimid_ix,dimid_jx,dimid_times/), varid)
+       iret = nf_put_att_text(ncid,varid,'units',2,'m3 s-1')
+       iret = nf_put_att_text(ncid,varid,'long_name',12,'surface head')
+       iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+       iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+       iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+!-- place projection information
+     if(hires_flag.eq.1) then !if/then hires_georef
+      iret = nf_def_var(ncid,"lambert_conformal_conic",NF_INT,0, 0,varid)
+      iret = nf_put_att_text(ncid,varid,'grid_mapping_name',23,'lambert_conformal_conic')
+      iret = nf_put_att_real(ncid,varid,'longitude_of_central_meridian',NF_FLOAT,1,long_cm)
+      iret = nf_put_att_real(ncid,varid,'latitude_of_projection_origin',NF_FLOAT,1,lat_po)
+      iret = nf_put_att_real(ncid,varid,'false_easting',NF_FLOAT,1,fe)
+      iret = nf_put_att_real(ncid,varid,'false_northing',NF_FLOAT,1,fn)
+      iret = nf_put_att_real(ncid,varid,'standard_parallel',NF_FLOAT,2,sp)
+     end if   !endif hires_georef
+
+!      iret = nf_def_var(ncid,"Date",   NF_CHAR,  2, (/dimid_datelen,dimid_times/),     varid)
+
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(startdate)) = startdate
+      convention(1:32) = "CF-1.0"
+      iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+      iret = nf_put_att_int(ncid,NF_GLOBAL,"output_decimation_factor",NF_INT, 1,decimation)
+
+      iret = nf_enddef(ncid)
+
+!!-- write latitude and longitude locations
+!       xdumd = LATVAL
+        iret = nf_inq_varid(ncid,"x", varid)
+!       iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+	iret = nf_put_vara_double(ncid, varid, (/1/), (/ixrtd/), xcoord_d) !-- 1-d array
+
+!       xdumd = LONVAL
+        iret = nf_inq_varid(ncid,"y", varid)
+!       iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+        iret = nf_put_vara_double(ncid, varid, (/1/), (/jxrtd/), ycoord_d) !-- 1-d array
+
+#ifdef MPP_LAND
+        xdumd = gLATVAL
+#else  
+        xdumd = LATVAL
+#endif
+        iret = nf_inq_varid(ncid,"LATITUDE", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+
+#ifdef MPP_LAND
+        xdumd = gLONVAL
+#else  
+        xdumd = LONVAL
+#endif
+        iret = nf_inq_varid(ncid,"LONGITUDE", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ixrtd,jxrtd/), xdumd)
+
+       do n = 1,nsoil
+        if(n == 1) then
+         asldpth(n) = -sldpth(n)
+        else
+         asldpth(n) = asldpth(n-1) - sldpth(n)
+        endif
+       enddo
+
+       iret = nf_inq_varid(ncid,"depth", varid)
+       iret = nf_put_vara_real(ncid, varid, (/1/), (/nsoil/), asldpth)
+!yw       iret = nf_close(ncstatic)
+
+    endif
+
+    output_count = output_count + 1
+
+!!-- time
+        iret = nf_inq_varid(ncid,"time", varid)
+        iret = nf_put_vara_int(ncid, varid, (/output_count/), (/1/), seconds_since)
+
+!-- 3-d soils
+     do n = 1, nsoil
+#ifdef MPP_LAND
+        xdumd = gSMCRT(:,:,n)
+#else  
+        xdumd = SMCRT(:,:,n)
+#endif
+! !DJG inv      jj = int(jxrt/decimation)
+!       jj = 1
+!       ii = 0
+! !DJG inv      do j = jxrt,1,-decimation
+!        do j = 1,jxrt,decimation
+!        do i = 1,ixrt,decimation
+!         ii = ii + 1  
+!         if(ii <= ixrtd .and. jj <= jxrtd .and. jj >0) then
+!          xdumd(ii,jj) = smcrt(i,j,n)
+!         endif
+!       enddo 
+!        ii = 0
+! !DJG inv       jj = jj -1
+!        jj = jj + 1
+!      enddo
+!       where (vegtyp(:,:) == 16) xdum = -1.E33
+          iret = nf_inq_varid(ncid,  "SOIL_M", varid)
+          iret = nf_put_vara_real(ncid, varid, (/1,1,n,output_count/), (/ixrtd,jxrtd,1,1/), xdumd)
+    enddo !-n soils
+
+#ifdef MPP_LAND
+        xdumd = gHead
+#else  
+        xdumd = head
+#endif
+
+     iret = nf_inq_varid(ncid,  "HEAD", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+
+#ifdef MPP_LAND
+        xdumd = gConvgw
+#else  
+        xdumd = convgw
+#endif
+     iret = nf_inq_varid(ncid,  "CONVGW", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+
+     
+#ifdef MPP_LAND
+        xdumd = gExcess
+#else  
+        xdumd = excess
+#endif
+     iret = nf_inq_varid(ncid,  "GwExcess", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+
+     
+#ifdef MPP_LAND
+        xdumd = gqsgwrt
+#else  
+        xdumd = qsgwrt
+#endif
+
+     iret = nf_inq_varid(ncid,  "QSGWRT", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+     
+#ifdef MPP_LAND
+        xdumd = gQgw_chanrt
+#else  
+        xdumd = qgw_chanrt
+#endif
+
+     iret = nf_inq_varid(ncid,  "QGW_CHANRT", varid)
+     iret = nf_put_vara_real(ncid, varid, (/1,1,output_count/), (/ixrtd,jxrtd,1/), xdumd)
+     
+     
+!!time in seconds since startdate
+
+       iret = nf_redef(ncid)
+       date19(1:len_trim(date)) = date
+       iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate))
+ 
+       iret = nf_enddef(ncid)
+      iret = nf_sync(ncid)
+      if (output_count == split_output_count) then
+        output_count = 0
+        iret = nf_close(ncid)
+      endif
+
+     if(allocated(xdumd)) deallocate(xdumd)
+     if(allocated(xcoord_d)) deallocate(xcoord_d)
+     if(allocated(xcoord)) deallocate(xcoord)
+     if(allocated(ycoord_d)) deallocate(ycoord_d)
+     if(allocated(ycoord)) deallocate(ycoord)
+    
+#ifdef HYDRO_D 
+     write(6,*) "end of output_ge" 
+#endif
+#ifdef MPP_LAND
+    endif
+#endif
+
+  end subroutine sub_output_gw
+
+!NOte: output_chrt is the old version comparing to "output_chrt_bak".
+   subroutine output_chrt(igrid, split_output_count, NLINKS, ORDER,             &
+        startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
+        STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, & 
+        lsmDt                                       &
+#ifdef WRF_HYDRO_NUDGING
+        , nudge                                     &
+#endif
+        , accLndRunOff, accQLateral, accStrmvolrt, accBucket, UDMP_OPT          &
+        )
+     
+     implicit none
+#include 
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid,K,channel_option
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLINKS, NLINKSL
+     real, dimension(:),                  intent(in) :: chlon,chlat
+     real, dimension(:),                  intent(in) :: hlink,zelev
+     integer, dimension(:),               intent(in) :: ORDER
+     integer, dimension(:),               intent(inout) :: STRMFRXSTPTS
+     character(len=15), dimension(:),     intent(inout) :: gages
+     character(len=15),                        intent(in) :: gageMiss
+     real,                                     intent(in) :: lsmDt
+
+     real,                                     intent(in) :: dtrt_ch
+     real, dimension(:,:),                intent(in) :: qlink
+#ifdef WRF_HYDRO_NUDGING
+     real, dimension(:),                  intent(in) :: nudge
+#endif
+     
+     integer, intent(in)  :: UDMP_OPT
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+
+     real, allocatable, DIMENSION(:)            :: chanlat,chanlon
+     real, allocatable, DIMENSION(:)            :: chanlatO,chanlonO
+
+     real, allocatable, DIMENSION(:)            :: elevation
+     real, allocatable, DIMENSION(:)            :: elevationO
+
+     integer, allocatable, DIMENSION(:)         :: station_id
+     integer, allocatable, DIMENSION(:)         :: station_idO
+
+     integer, allocatable, DIMENSION(:)         :: rec_num_of_station
+     integer, allocatable, DIMENSION(:)         :: rec_num_of_stationO
+
+     integer, allocatable, DIMENSION(:)         :: lOrder !- local stream order
+     integer, allocatable, DIMENSION(:)         :: lOrderO !- local stream order
+
+     integer, save  :: output_count
+     integer, save  :: ncid,ncid2
+
+     integer :: stationdim, dimdata, varid, charid, n
+     integer :: obsdim, dimdataO, charidO
+
+     integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output
+     integer :: start_posO, prev_posO, nlk
+
+     integer :: previous_pos  !-- used for the station model
+     character(len=256) :: output_flnm,output_flnm2
+     character(len=19)  :: date19,date19start, hydroTime
+     character(len=34)  :: sec_since_date
+     integer :: seconds_since,nstations,cnt,ObsStation,nobs
+     character(len=32)  :: convention
+     character(len=11),allocatable, DIMENSION(:)  :: stname
+     character(len=15),allocatable, DIMENSION(:)  :: stnameO
+
+    !--- all this for writing the station id string
+     INTEGER   TDIMS, TXLEN
+     PARAMETER (TDIMS=2)    ! number of TX dimensions
+     PARAMETER (TXLEN = 11) ! length of example string
+     INTEGER  TIMEID        ! record dimension id
+     INTEGER  TXID          ! variable ID
+     INTEGER  TXDIMS(TDIMS) ! variable shape
+     INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
+
+     !--  observation point  ids
+     INTEGER   OTDIMS, OTXLEN
+     PARAMETER (OTDIMS=2)    ! number of TX dimensions
+     PARAMETER (OTXLEN = 15) ! length of example string
+     INTEGER  OTIMEID        ! record dimension id
+     INTEGER  OTXID          ! variable ID
+     INTEGER  OTXDIMS(OTDIMS) ! variable shape
+     INTEGER  OTSTART(OTDIMS), OTCOUNT(OTDIMS)
+
+     real, dimension(:), intent(in) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket  
+
+     !! currently, this is the time of the hydro model, it's
+     !! lsm time (olddate) plus one lsm timestep
+     !call geth_newdate(hydroTime, date, nint(lsmDt))
+     hydroTime=date
+
+     seconds_since = int(dtrt_ch)*(K-1)
+
+!    order_to_write = 2  !-- 1 all; 6 fewest
+      nstations = 0  ! total number of channel points to display
+      nobs      = 0  ! number of observation points
+
+     if(channel_option .ne. 3) then
+        nlk = NLINKSL
+     else
+        nlk = NLINKS
+     endif
+
+
+!-- output only the higher oder streamflows  and only observation points
+     do i=1,nlk
+        if(ORDER(i) .ge. order_to_write) nstations = nstations + 1
+        if(channel_option .ne. 3) then
+           if(trim(gages(i)) .ne. trim(gageMiss)) nobs = nobs + 1
+        else 
+           if(STRMFRXSTPTS(i) .ne. -9999) nobs = nobs + 1
+        endif
+     enddo
+
+     if (nobs .eq. 0) then ! let's at least make one obs point
+        nobs = 1
+        if(channel_option .ne. 3) then 
+           !           123456789012345
+           gages(1) = '          dummy'
+        else 
+           STRMFRXSTPTS(1) = 1
+        endif
+     endif
+
+       allocate(chanlat(nstations))
+       allocate(chanlon(nstations))
+       allocate(elevation(nstations))
+       allocate(lOrder(nstations))
+       allocate(stname(nstations))
+       allocate(station_id(nstations))
+       allocate(rec_num_of_station(nstations))
+
+       allocate(chanlatO(nobs))
+       allocate(chanlonO(nobs))
+       allocate(elevationO(nobs))
+       allocate(lOrderO(nobs))
+       allocate(stnameO(nobs))
+       allocate(station_idO(nobs))
+       allocate(rec_num_of_stationO(nobs))
+
+       if(output_count == 0) then 
+!-- have moved sec_since_date from above here..
+        sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
+                  //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
+
+        date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
+                  //startdate(12:13)//':'//startdate(15:16)//':00'
+
+        nstations = 0
+        nobs = 0
+
+        write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+        write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+
+#ifdef HYDRO_D
+        print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#else
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+        if (iret /= 0) then
+           call hydro_stop("In output_chrt() - Problem nf_create points")
+        endif
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm2), NF_CLOBBER, ncid2)
+#else
+       iret = nf_create(trim(output_flnm2), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid2)
+#endif
+        if (iret /= 0) then
+            call hydro_stop("In output_chrt() - Problem nf_create observation")
+        endif
+
+       do i=1,nlk
+        if(ORDER(i) .ge. order_to_write) then 
+         nstations = nstations + 1
+         chanlat(nstations) = chlat(i)
+         chanlon(nstations) = chlon(i)
+         elevation(nstations) = zelev(i)
+         lOrder(nstations) = ORDER(i)
+         station_id(nstations) = i
+         if(STRMFRXSTPTS(nstations) .eq. -9999) then 
+           ObsStation = 0
+         else 
+           ObsStation = 1
+         endif
+         write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation
+        endif
+       enddo 
+
+
+       do i=1,nlk
+          if(channel_option .ne. 3) then
+             if(trim(gages(i)) .ne. trim(gageMiss)) then
+                nobs = nobs + 1
+                chanlatO(nobs) = chlat(i)
+                chanlonO(nobs) = chlon(i)
+                elevationO(nobs) = zelev(i)
+                lOrderO(nobs) = ORDER(i)
+                station_idO(nobs) = i
+                stnameO(nobs) = gages(i)
+             endif
+          else 
+             if(STRMFRXSTPTS(i) .ne. -9999) then 
+                nobs = nobs + 1
+                chanlatO(nobs) = chlat(i)
+                chanlonO(nobs) = chlon(i)
+                elevationO(nobs) = zelev(i)
+                lOrderO(nobs) = ORDER(i)
+                station_idO(nobs) = i
+                write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs)
+#ifdef HYDRO_D
+                !        print *,"stationobservation name",  stnameO(nobs)
+#endif
+             endif
+          endif
+       enddo 
+
+       iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata)  !--for linked list approach
+       iret = nf_def_dim(ncid, "station", nstations, stationdim)
+
+
+
+       iret = nf_def_dim(ncid2, "recNum", NF_UNLIMITED, dimdataO)  !--for linked list approach
+       iret = nf_def_dim(ncid2, "station", nobs, obsdim)
+
+      !- station location definition all,  lat
+        iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',16,'Station latitude')
+        iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north')
+
+      !- station location definition obs,  lat
+        iret = nf_def_var(ncid2,"latitude",NF_FLOAT, 1, (/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation latitude')
+        iret = nf_put_att_text(ncid2,varid,'units',13,'degrees_north')
+
+
+      !- station location definition,  long
+        iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',17,'Station longitude')
+        iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east')
+
+
+      !- station location definition, obs long
+        iret = nf_def_var(ncid2,"longitude",NF_FLOAT, 1, (/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',21,'Observation longitude')
+        iret = nf_put_att_text(ncid2,varid,'units',12,'degrees_east')
+
+
+!     !-- elevation is ZELEV
+        iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',16,'Station altitude')
+        iret = nf_put_att_text(ncid,varid,'units',6,'meters')
+
+
+!     !-- elevation is obs ZELEV
+        iret = nf_def_var(ncid2,"altitude",NF_FLOAT, 1, (/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation altitude')
+        iret = nf_put_att_text(ncid2,varid,'units',6,'meters')
+
+
+!     !--  gage observation
+!       iret = nf_def_var(ncid,"gages",NF_FLOAT, 1, (/stationdim/), varid)
+!       iret = nf_put_att_text(ncid,varid,'long_name',20,'Stream Gage Location')
+!       iret = nf_put_att_text(ncid,varid,'units',4,'none')
+
+!-- parent index
+        iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',36,'index of the station for this record')
+
+        iret = nf_def_var(ncid2,"parent_index",NF_INT,1,(/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',36,'index of the station for this record')
+
+     !-- prevChild
+        iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',57,'record number of the previous record for the same station')
+        iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+
+        iret = nf_def_var(ncid2,"prevChild",NF_INT,1,(/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',57,'record number of the previous record for the same station')
+        iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1)
+
+     !-- lastChild
+        iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',30,'latest report for this station')
+        iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+
+        iret = nf_def_var(ncid2,"lastChild",NF_INT,1,(/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',30,'latest report for this station')
+        iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1)
+
+!     !- flow definition, var
+
+        if(UDMP_OPT .eq. 1) then
+
+           iret = nf_def_var(ncid, "accLndRunOff", NF_FLOAT, 1, (/dimdata/), varid)
+           iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?')
+           iret = nf_put_att_text(ncid,varid,'long_name',28,'ACCUMULATED runoff from land')
+
+           iret = nf_def_var(ncid, "accQLateral", NF_FLOAT, 1, (/dimdata/), varid)
+           iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?')
+           iret = nf_put_att_text(ncid,varid,'long_name',24,'Total ACCUMULATED runoff')
+
+           iret = nf_def_var(ncid, "accStrmvolrt", NF_FLOAT, 1, (/dimdata/), varid)
+           iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?')
+           iret = nf_put_att_text(ncid,varid,'long_name',39,'ACCUMULATED runoff from terrain routing')
+
+           iret = nf_def_var(ncid, "accBucket", NF_FLOAT, 1, (/dimdata/), varid)
+           iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?')
+           iret = nf_put_att_text(ncid,varid,'long_name',32,'ACCUMULATED runoff from gw bucket')
+
+        endif
+
+        iret = nf_def_var(ncid, "streamflow", NF_FLOAT, 1, (/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid,varid,'long_name',10,'River Flow')
+
+        iret = nf_def_var(ncid2, "streamflow", NF_FLOAT, 1, (/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid2,varid,'long_name',10,'River Flow')
+
+#ifdef WRF_HYDRO_NUDGING
+        iret = nf_def_var(ncid, "nudge", NF_FLOAT, 1, (/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid,varid,'long_name',32,'Amount of stream flow alteration')
+
+        iret = nf_def_var(ncid2, "nudge", NF_FLOAT, 1, (/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid2,varid,'long_name',32,'Amount of stream flow alteration')
+#endif
+
+!     !- flow definition, var
+!       iret = nf_def_var(ncid, "pos_streamflow", NF_FLOAT, 1, (/dimdata/), varid)
+!       iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+!       iret = nf_put_att_text(ncid,varid,'long_name',14,'abs streamflow')
+
+!     !- head definition, var
+        iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',5,'meter')
+        iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage')
+
+        iret = nf_def_var(ncid2, "head", NF_FLOAT, 1, (/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'units',5,'meter')
+        iret = nf_put_att_text(ncid2,varid,'long_name',11,'River Stage')
+
+!     !- order definition, var
+        iret = nf_def_var(ncid, "order", NF_INT, 1, (/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',21,'Strahler Stream Order')
+        iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+
+        iret = nf_def_var(ncid2, "order", NF_INT, 1, (/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',21,'Strahler Stream Order')
+        iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+
+     !-- station  id
+     ! define character-position dimension for strings of max length 11
+         iret = NF_DEF_DIM(ncid, "id_len", 11, charid)
+         TXDIMS(1) = charid   ! define char-string variable and position dimension first
+         TXDIMS(2) = stationdim
+         iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid)
+         iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id')
+
+
+         iret = NF_DEF_DIM(ncid2, "id_len", 15, charidO)
+         OTXDIMS(1) = charidO   ! define char-string variable and position dimension first
+         OTXDIMS(2) = obsdim
+         iret = nf_def_var(ncid2,"station_id",NF_CHAR, OTDIMS, OTXDIMS, varid)
+         iret = nf_put_att_text(ncid2,varid,'long_name',14,'Observation id')
+
+
+!     !- time definition, timeObs
+         iret = nf_def_var(ncid,"time_observation",NF_INT, 1, (/dimdata/), varid)
+         iret = nf_put_att_text(ncid,varid,'units',34,sec_since_date)
+         iret = nf_put_att_text(ncid,varid,'long_name',19,'time of observation')
+
+         iret = nf_def_var(ncid2,"time_observation",NF_INT, 1, (/dimdataO/), varid)
+         iret = nf_put_att_text(ncid2,varid,'units',34,sec_since_date)
+         iret = nf_put_att_text(ncid2,varid,'long_name',19,'time of observation')
+
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention)
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention)
+
+         convention(1:32) = "Unidata Observation Dataset v1.0"
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention)
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_start",19, date19start)
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "stationDimension",7, "station")
+         iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+         iret = nf_put_att_int(ncid, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write)
+
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention)
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "cdm_datatype",7, "Station")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_max",4, "90.0")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_min",5, "-90.0")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_max",5, "180.0")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_min",6, "-180.0")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_start",19, date19start)
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "stationDimension",7, "station")
+         iret = nf_put_att_real(ncid2, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+         iret = nf_put_att_int(ncid2, NF_GLOBAL, "stream order output",NF_INT,1,order_to_write)
+
+         iret = nf_enddef(ncid)
+         iret = nf_enddef(ncid2)
+
+        !-- write latitudes
+         iret = nf_inq_varid(ncid,"latitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlat)
+
+         iret = nf_inq_varid(ncid2,"latitude", varid)
+         iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlatO)
+
+        !-- write longitudes
+         iret = nf_inq_varid(ncid,"longitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlon)
+
+         iret = nf_inq_varid(ncid2,"longitude", varid)
+         iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlonO)
+
+        !-- write elevations
+         iret = nf_inq_varid(ncid,"altitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), elevation)
+
+         iret = nf_inq_varid(ncid2,"altitude", varid)
+         iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), elevationO)
+
+      !-- write gage location
+!      iret = nf_inq_varid(ncid,"gages", varid)
+!      iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), STRMFRXSTPTS)
+
+        !-- write number_of_stations, OPTIONAL
+      !!  iret = nf_inq_varid(ncid,"number_stations", varid)
+      !!  iret = nf_put_var_int(ncid, varid, nstations)
+
+        !-- write station id's 
+         do i=1,nstations
+          TSTART(1) = 1
+          TSTART(2) = i
+          TCOUNT(1) = TXLEN
+          TCOUNT(2) = 1
+          iret = nf_inq_varid(ncid,"station_id", varid)
+          iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i))
+         enddo
+
+        !-- write observation id's 
+         do i=1, nobs
+          OTSTART(1) = 1
+          OTSTART(2) = i
+          OTCOUNT(1) = OTXLEN
+          OTCOUNT(2) = 1
+          iret = nf_inq_varid(ncid2,"station_id", varid)
+          iret = nf_put_vara_text(ncid2, varid, OTSTART, OTCOUNT, stnameO(i))
+         enddo
+
+     endif
+
+     output_count = output_count + 1
+
+     open (unit=55, &
+#ifndef NCEP_WCOSS
+     file='frxst_pts_out.txt', &
+#endif
+     status='unknown',position='append')
+
+     cnt=0
+     do i=1,nlk   
+
+       if(ORDER(i) .ge. order_to_write) then 
+         start_pos = (cnt+1)+(nstations*(output_count-1))
+
+         !!--time in seconds since startdate
+          iret = nf_inq_varid(ncid,"time_observation", varid)
+          iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since)
+
+         if(UDMP_OPT .eq. 1) then
+            iret = nf_inq_varid(ncid,"accLndRunOff", varid)
+            iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accLndRunOff(i))
+
+            iret = nf_inq_varid(ncid,"accQLateral", varid)
+            iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accQLateral(i))
+
+            iret = nf_inq_varid(ncid,"accStrmvolrt", varid)
+            iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accStrmvolrt(i))
+
+            iret = nf_inq_varid(ncid,"accBucket", varid)
+            iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accBucket(i))
+         endif
+
+         iret = nf_inq_varid(ncid,"streamflow", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlink(i,1))
+
+#ifdef WRF_HYDRO_NUDGING
+         iret = nf_inq_varid(ncid,"nudge", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), nudge(i))
+#endif
+
+!        iret = nf_inq_varid(ncid,"pos_streamflow", varid)
+!        iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), abs(qlink(i,1)))
+
+         iret = nf_inq_varid(ncid,"head", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), hlink(i))
+
+         iret = nf_inq_varid(ncid,"order", varid)
+         iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), ORDER(i))
+
+         !-- station index.. will repeat for every timesstep
+         iret = nf_inq_varid(ncid,"parent_index", varid)
+         iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt)
+
+          !--record number of previous record for same station
+!obsolete format         prev_pos = cnt+(nstations*(output_count-1))
+         prev_pos = cnt+(nobs*(output_count-2))
+         if(output_count.ne.1) then !-- only write next set of records
+           iret = nf_inq_varid(ncid,"prevChild", varid)
+           iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos)
+         endif
+         cnt=cnt+1  !--indices are 0 based
+         rec_num_of_station(cnt) = start_pos-1  !-- save position for last child, 0-based!!
+
+
+       endif
+    enddo
+!    close(999) 
+
+    !-- output  only observation points
+    cnt=0
+    do i=1,nlk   
+       if(channel_option .ne. 3) then
+          ! jlm this verry repetitiuos, oh well.
+          if(trim(gages(i)) .ne. trim(gageMiss)) then
+
+             start_posO = (cnt+1)+(nobs * (output_count-1))
+             !Write frxst_pts to text file...
+             !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
+118          FORMAT(I8,",",A10,1X,A8,", ",A15,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
+             !write(55,118) seconds_since, date(1:10), date(12:19), &
+#ifndef HYDRO_REALTIME
+             write(55,118) seconds_since, hydroTime(1:10), hydroTime(12:19), &
+                  gages(i), chlon(i), chlat(i),                               &
+                  qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
+#endif
+             !yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3)
+             !yw 117 FORMAT(I8,1X,A10,1X,A8,1x,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3)
+
+             !!--time in seconds since startdate
+             iret = nf_inq_varid(ncid2,"time_observation", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), seconds_since)
+
+             iret = nf_inq_varid(ncid2,"streamflow", varid)
+             iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1))
+
+#ifdef WRF_HYDRO_NUDGING
+             iret = nf_inq_varid(ncid2,"nudge", varid)
+             iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), nudge(i))
+#endif
+
+             iret = nf_inq_varid(ncid2,"head", varid)
+             iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i))
+
+             iret = nf_inq_varid(ncid,"order", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i))
+
+             !-- station index.. will repeat for every timesstep
+             iret = nf_inq_varid(ncid2,"parent_index", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt)
+
+             !--record number of previous record for same station
+             !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
+             prev_posO = cnt+(nobs*(output_count-2))
+             if(output_count.ne.1) then !-- only write next set of records
+                iret = nf_inq_varid(ncid2,"prevChild", varid)
+                iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO)
+
+                !IF block to add -1 to last element of prevChild array to designate end of list...
+                !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
+                !             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
+                !           else
+                !             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO)
+                !           endif
+
+             endif
+             cnt=cnt+1  !--indices are 0 based
+             rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
+          endif
+
+          
+       else !! channel options 3 below
+
+          if(STRMFRXSTPTS(i) .ne. -9999) then 
+             start_posO = (cnt+1)+(nobs * (output_count-1))
+             !Write frxst_pts to text file...
+             !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
+117          FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
+             !write(55,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), &
+             !     qlink(i,1), qlink(i,1)*35.315,hlink(i)
+             ! JLM: makes more sense to output the value in frxstpts incase they have meaning,
+             ! as below, but I'm not going to make this change until I'm working with gridded
+             ! streamflow again.
+             write(55,117) seconds_since, hydroTime(1:10), hydroTime(12:19), &
+                  strmfrxstpts(i), chlon(i), chlat(i),                        &
+                  qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
+
+             !!--time in seconds since startdate
+             iret = nf_inq_varid(ncid2,"time_observation", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), seconds_since)
+
+             iret = nf_inq_varid(ncid2,"streamflow", varid)
+             iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1))
+
+             iret = nf_inq_varid(ncid2,"head", varid)
+             iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i))
+
+             iret = nf_inq_varid(ncid,"order", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i))
+
+             !-- station index.. will repeat for every timesstep
+             iret = nf_inq_varid(ncid2,"parent_index", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt)
+
+             !--record number of previous record for same station
+             !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
+             prev_posO = cnt+(nobs*(output_count-2))
+             if(output_count.ne.1) then !-- only write next set of records
+                iret = nf_inq_varid(ncid2,"prevChild", varid)
+                iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO)
+
+                !IF block to add -1 to last element of prevChild array to designate end of list...
+                !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
+                !             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
+                !           else
+                !             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO)
+                !           endif 
+
+             endif
+             cnt=cnt+1  !--indices are 0 based
+             rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
+          endif
+
+       endif
+
+    enddo
+    close(55) 
+
+      !-- lastChild variable gives the record number of the most recent report for the station
+      iret = nf_inq_varid(ncid,"lastChild", varid)
+      iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), rec_num_of_station)
+
+      !-- lastChild variable gives the record number of the most recent report for the station
+      iret = nf_inq_varid(ncid2,"lastChild", varid)
+      iret = nf_put_vara_int(ncid2, varid, (/1/), (/nobs/), rec_num_of_stationO)
+
+      iret = nf_redef(ncid)
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(date)) = date
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coverage_end", 19, date19)
+
+      iret = nf_redef(ncid2)
+      iret = nf_put_att_text(ncid2, NF_GLOBAL, "time_coverage_end", 19, date19)
+
+      iret = nf_enddef(ncid)
+      iret = nf_sync(ncid)
+
+      iret = nf_enddef(ncid2)
+      iret = nf_sync(ncid2)
+
+      if (output_count == split_output_count) then
+        output_count = 0
+        iret = nf_close(ncid)
+        iret = nf_close(ncid2)
+     endif
+
+     if(allocated(chanlat)) deallocate(chanlat)
+     if(allocated(chanlon)) deallocate(chanlon)
+     if(allocated(elevation)) deallocate(elevation)
+     if(allocated(station_id)) deallocate(station_id)
+     if(allocated(lOrder)) deallocate(lOrder)
+     if(allocated(rec_num_of_station)) deallocate(rec_num_of_station)
+     if(allocated(stname)) deallocate(stname)
+
+     if(allocated(chanlatO)) deallocate(chanlatO)
+     if(allocated(chanlonO)) deallocate(chanlonO)
+     if(allocated(elevationO)) deallocate(elevationO)
+     if(allocated(station_idO)) deallocate(station_idO)
+     if(allocated(lOrderO)) deallocate(lOrderO)
+     if(allocated(rec_num_of_stationO)) deallocate(rec_num_of_stationO)
+     if(allocated(stnameO)) deallocate(stnameO)
+#ifdef HYDRO_D
+     print *, "Exited Subroutine output_chrt"
+#endif
+     close(16)
+
+20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3)
+
+end subroutine output_chrt
+
+!-- output the channel route in an IDV 'station' compatible format
+!Note: This version has pool output performance need to be
+!solved. We renamed it from output_chrt to be output_chrt_bak.
+   subroutine output_chrt_bak(igrid, split_output_count, NLINKS, ORDER,             &
+        startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
+        STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, & 
+        lsmDt                                       &
+#ifdef WRF_HYDRO_NUDGING
+        , nudge                                     &
+#endif
+        , accLndRunOff, accQLateral, accStrmvolrt, accBucket, UDMP_OPT          &
+        )
+     
+     implicit none
+#include 
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid,K,channel_option
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLINKS, NLINKSL
+     real, dimension(:),                  intent(in) :: chlon,chlat
+     real, dimension(:),                  intent(in) :: hlink,zelev
+     integer, dimension(:),               intent(in) :: ORDER
+     integer, dimension(:),               intent(inout) :: STRMFRXSTPTS
+     character(len=15), dimension(:),     intent(inout) :: gages
+     character(len=15),                        intent(in) :: gageMiss
+     real,                                     intent(in) :: lsmDt
+
+     real,                                     intent(in) :: dtrt_ch
+     real, dimension(:,:),                intent(in) :: qlink
+#ifdef WRF_HYDRO_NUDGING
+     real, dimension(:),                  intent(in) :: nudge
+#endif
+     
+     integer, intent(in)  :: UDMP_OPT
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+
+     real, allocatable, DIMENSION(:)            :: chanlat,chanlon
+     real, allocatable, DIMENSION(:)            :: chanlatO,chanlonO
+
+     real, allocatable, DIMENSION(:)            :: elevation
+     real, allocatable, DIMENSION(:)            :: elevationO
+
+     integer, allocatable, DIMENSION(:)         :: station_id
+     integer, allocatable, DIMENSION(:)         :: station_idO
+
+     integer, allocatable, DIMENSION(:)         :: rec_num_of_station
+     integer, allocatable, DIMENSION(:)         :: rec_num_of_stationO
+
+     integer, allocatable, DIMENSION(:)         :: lOrder !- local stream order
+     integer, allocatable, DIMENSION(:)         :: lOrderO !- local stream order
+
+     integer, save  :: output_count
+     integer, save  :: ncid,ncid2
+
+     integer :: stationdim, dimdata, varid, charid, n
+     integer :: obsdim, dimdataO, charidO
+     integer :: timedim, timedim2
+     character(len=34) :: sec_valid_date
+
+     integer :: iret,i, start_pos, prev_pos, order_to_write!-- order_to_write is the lowest stream order to output
+     integer :: start_posO, prev_posO, nlk
+
+     integer :: previous_pos  !-- used for the station model
+     character(len=256) :: output_flnm,output_flnm2
+     character(len=19)  :: date19,date19start, hydroTime
+     character(len=34)  :: sec_since_date
+     integer :: seconds_since,nstations,cnt,ObsStation,nobs
+     character(len=32)  :: convention
+     character(len=11),allocatable, DIMENSION(:)  :: stname
+     character(len=15),allocatable, DIMENSION(:)  :: stnameO
+
+    !--- all this for writing the station id string
+     INTEGER   TDIMS, TXLEN
+     PARAMETER (TDIMS=2)    ! number of TX dimensions
+     PARAMETER (TXLEN = 11) ! length of example string
+     INTEGER  TIMEID        ! record dimension id
+     INTEGER  TXID          ! variable ID
+     INTEGER  TXDIMS(TDIMS) ! variable shape
+     INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
+
+     !--  observation point  ids
+     INTEGER   OTDIMS, OTXLEN
+     PARAMETER (OTDIMS=2)    ! number of TX dimensions
+     PARAMETER (OTXLEN = 15) ! length of example string
+     INTEGER  OTIMEID        ! record dimension id
+     INTEGER  OTXID          ! variable ID
+     INTEGER  OTXDIMS(OTDIMS) ! variable shape
+     INTEGER  OTSTART(OTDIMS), OTCOUNT(OTDIMS)
+
+     real,dimension(:), intent(in) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket  
+
+     !! currently, this is the time of the hydro model, it's
+     !! lsm time (olddate) plus one lsm timestep
+     !call geth_newdate(hydroTime, date, nint(lsmDt))
+     hydroTime=date
+
+     seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1))
+     sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) &
+                   //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC'
+
+!    order_to_write = 2  !-- 1 all; 6 fewest
+      nstations = 0  ! total number of channel points to display
+      nobs      = 0  ! number of observation points
+
+     if(channel_option .ne. 3) then
+        nlk = NLINKSL
+     else
+        nlk = NLINKS
+     endif
+
+
+!-- output only the higher oder streamflows  and only observation points
+     do i=1,nlk
+        if(ORDER(i) .ge. order_to_write) nstations = nstations + 1
+        if(channel_option .ne. 3) then
+           if(trim(gages(i)) .ne. trim(gageMiss)) nobs = nobs + 1
+        else 
+           if(STRMFRXSTPTS(i) .ne. -9999) nobs = nobs + 1
+        endif
+     enddo
+
+     if (nobs .eq. 0) then ! let's at least make one obs point
+        nobs = 1
+        if(channel_option .ne. 3) then 
+           !           123456789012345
+           gages(1) = '          dummy'
+        else 
+           STRMFRXSTPTS(1) = 1
+        endif
+     endif
+
+       allocate(chanlat(nstations))
+       allocate(chanlon(nstations))
+       allocate(elevation(nstations))
+       allocate(lOrder(nstations))
+       allocate(stname(nstations))
+       allocate(station_id(nstations))
+       allocate(rec_num_of_station(nstations))
+
+       allocate(chanlatO(nobs))
+       allocate(chanlonO(nobs))
+       allocate(elevationO(nobs))
+       allocate(lOrderO(nobs))
+       allocate(stnameO(nobs))
+       allocate(station_idO(nobs))
+       allocate(rec_num_of_stationO(nobs))
+
+       if(output_count == 0) then 
+!-- have moved sec_since_date from above here..
+        sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
+                  //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
+
+        date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
+                  //startdate(12:13)//':'//startdate(15:16)//':00'
+
+        nstations = 0
+        nobs = 0
+
+        write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+        write(output_flnm2,'(A12,".CHANOBS_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+
+#ifdef HYDRO_D
+        print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#else
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+        if (iret /= 0) then
+           call hydro_stop("In output_chrt() - Problem nf_create points")
+        endif
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm2), NF_CLOBBER, ncid2)
+#else
+       iret = nf_create(trim(output_flnm2), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid2)
+#endif
+        if (iret /= 0) then
+            call hydro_stop("In output_chrt() - Problem nf_create observation")
+        endif
+
+       do i=1,nlk
+        if(ORDER(i) .ge. order_to_write) then 
+         nstations = nstations + 1
+         chanlat(nstations) = chlat(i)
+         chanlon(nstations) = chlon(i)
+         elevation(nstations) = zelev(i)
+         lOrder(nstations) = ORDER(i)
+         station_id(nstations) = i
+         if(STRMFRXSTPTS(nstations) .eq. -9999) then 
+           ObsStation = 0
+         else 
+           ObsStation = 1
+         endif
+         write(stname(nstations),'(I6,"_",I1,"_S",I1)') nstations,lOrder(nstations),ObsStation
+        endif
+       enddo 
+
+
+       do i=1,nlk
+          if(channel_option .ne. 3) then
+             if(trim(gages(i)) .ne. trim(gageMiss)) then
+                nobs = nobs + 1
+                chanlatO(nobs) = chlat(i)
+                chanlonO(nobs) = chlon(i)
+                elevationO(nobs) = zelev(i)
+                lOrderO(nobs) = ORDER(i)
+                station_idO(nobs) = i
+                stnameO(nobs) = gages(i)
+             endif
+          else 
+             if(STRMFRXSTPTS(i) .ne. -9999) then 
+                nobs = nobs + 1
+                chanlatO(nobs) = chlat(i)
+                chanlonO(nobs) = chlon(i)
+                elevationO(nobs) = zelev(i)
+                lOrderO(nobs) = ORDER(i)
+                station_idO(nobs) = i
+                write(stnameO(nobs),'(I6,"_",I1)') nobs,lOrderO(nobs)
+#ifdef HYDRO_D
+                !        print *,"stationobservation name",  stnameO(nobs)
+#endif
+             endif
+          endif
+       enddo 
+
+       iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata)  !--for linked list approach
+       iret = nf_def_dim(ncid, "station", nstations, stationdim)
+       iret = nf_def_dim(ncid, "time", 1, timedim)
+
+
+       iret = nf_def_dim(ncid2, "recNum", NF_UNLIMITED, dimdataO)  !--for linked list approach
+       iret = nf_def_dim(ncid2, "station", nobs, obsdim)
+       iret = nf_def_dim(ncid2, "time", 1, timedim2)
+
+      !- station location definition all,  lat
+        iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',16,'Station latitude')
+        iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north')
+
+      !- station location definition obs,  lat
+        iret = nf_def_var(ncid2,"latitude",NF_FLOAT, 1, (/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation latitude')
+        iret = nf_put_att_text(ncid2,varid,'units',13,'degrees_north')
+
+
+      !- station location definition,  long
+        iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',17,'Station longitude')
+        iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east')
+
+
+      !- station location definition, obs long
+        iret = nf_def_var(ncid2,"longitude",NF_FLOAT, 1, (/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',21,'Observation longitude')
+        iret = nf_put_att_text(ncid2,varid,'units',12,'degrees_east')
+
+
+!     !-- elevation is ZELEV
+        iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',16,'Station altitude')
+        iret = nf_put_att_text(ncid,varid,'units',6,'meters')
+
+
+!     !-- elevation is obs ZELEV
+        iret = nf_def_var(ncid2,"altitude",NF_FLOAT, 1, (/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',20,'Observation altitude')
+        iret = nf_put_att_text(ncid2,varid,'units',6,'meters')
+
+
+!     !--  gage observation
+!       iret = nf_def_var(ncid,"gages",NF_FLOAT, 1, (/stationdim/), varid)
+!       iret = nf_put_att_text(ncid,varid,'long_name',20,'Stream Gage Location')
+!       iret = nf_put_att_text(ncid,varid,'units',4,'none')
+
+!-- parent index
+        iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',36,'index of the station for this record')
+
+        iret = nf_def_var(ncid2,"parent_index",NF_INT,1,(/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',36,'index of the station for this record')
+
+     !-- prevChild
+        iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',57,'record number of the previous record for the same station')
+!ywtmp        iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+        iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+        iret = nf_def_var(ncid2,"prevChild",NF_INT,1,(/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',57,'record number of the previous record for the same station')
+!ywtmp        iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1)
+        iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1)
+
+     !-- lastChild
+        iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',30,'latest report for this station')
+!ywtmp        iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+        iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+        iret = nf_def_var(ncid2,"lastChild",NF_INT,1,(/obsdim/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',30,'latest report for this station')
+!ywtmp        iret = nf_put_att_int(ncid2,varid,'_FillValue',NF_INT,2,-1)
+        iret = nf_put_att_int(ncid2,varid,'_FillValue',2,-1)
+
+!     !- flow definition, var
+
+        if(UDMP_OPT .eq. 1) then
+           iret = nf_def_var(ncid, "accLndRunOff", NF_FLOAT, 1, (/dimdata/), varid)
+           iret = nf_put_att_text(ncid,varid,'units',13,'unknow')
+           iret = nf_put_att_text(ncid,varid,'long_name',10,'ACCUMULATED runoff from land')
+
+           iret = nf_def_var(ncid, "accQLateral", NF_FLOAT, 1, (/dimdata/), varid)
+           iret = nf_put_att_text(ncid,varid,'units',13,'unknow')
+           iret = nf_put_att_text(ncid,varid,'long_name',10,'Total ACCUMULATED runoff')
+
+           iret = nf_def_var(ncid, "accStrmvolrt", NF_FLOAT, 1, (/dimdata/), varid)
+           iret = nf_put_att_text(ncid,varid,'units',13,'unknow')
+           iret = nf_put_att_text(ncid,varid,'long_name',10,'ACCUMULATED runoff from terrain routing')
+
+           iret = nf_def_var(ncid, "accBucket", NF_FLOAT, 1, (/dimdata/), varid)
+           iret = nf_put_att_text(ncid,varid,'units',13,'unknow')
+           iret = nf_put_att_text(ncid,varid,'long_name',10,'ACCUMULATED runoff from gw bucket')
+        endif
+
+        iret = nf_def_var(ncid, "streamflow", NF_FLOAT, 1, (/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid,varid,'long_name',10,'River Flow')
+
+        iret = nf_def_var(ncid2, "streamflow", NF_FLOAT, 1, (/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid2,varid,'long_name',10,'River Flow')
+
+#ifdef WRF_HYDRO_NUDGING
+        iret = nf_def_var(ncid, "nudge", NF_FLOAT, 1, (/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid,varid,'long_name',32,'Amount of stream flow alteration')
+
+        iret = nf_def_var(ncid2, "nudge", NF_FLOAT, 1, (/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid2,varid,'long_name',32,'Amount of stream flow alteration')
+#endif
+
+!     !- flow definition, var
+!       iret = nf_def_var(ncid, "pos_streamflow", NF_FLOAT, 1, (/dimdata/), varid)
+!       iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+!       iret = nf_put_att_text(ncid,varid,'long_name',14,'abs streamflow')
+
+#ifndef HYDRO_REALTIME 
+!     !- head definition, var
+        iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',5,'meter')
+        iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage')
+
+        iret = nf_def_var(ncid2, "head", NF_FLOAT, 1, (/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'units',5,'meter')
+        iret = nf_put_att_text(ncid2,varid,'long_name',11,'River Stage')
+#endif
+
+!     !- order definition, var
+        iret = nf_def_var(ncid, "order", NF_INT, 1, (/dimdata/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',21,'Strahler Stream Order')
+        iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+        iret = nf_def_var(ncid2, "order", NF_INT, 1, (/dimdataO/), varid)
+        iret = nf_put_att_text(ncid2,varid,'long_name',21,'Strahler Stream Order')
+        iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+     !-- station  id
+     ! define character-position dimension for strings of max length 11
+         iret = NF_DEF_DIM(ncid, "id_len", 11, charid)
+         TXDIMS(1) = charid   ! define char-string variable and position dimension first
+         TXDIMS(2) = stationdim
+         iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid)
+         iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id')
+
+
+         iret = NF_DEF_DIM(ncid2, "id_len", 15, charidO)
+         OTXDIMS(1) = charidO   ! define char-string variable and position dimension first
+         OTXDIMS(2) = obsdim
+         iret = nf_def_var(ncid2,"station_id",NF_CHAR, OTDIMS, OTXDIMS, varid)
+         iret = nf_put_att_text(ncid2,varid,'long_name',14,'Observation id')
+
+
+!     !- time definition, timeObs
+	 iret = nf_def_var(ncid,"time",NF_INT, 1, (/timedim/), varid)
+	 iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date)
+         iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time')
+
+	 iret = nf_def_var(ncid2,"time",NF_INT, 1, (/timedim2/), varid)
+         iret = nf_put_att_text(ncid2,varid,'units',34,sec_valid_date)
+         iret = nf_put_att_text(ncid2,varid,'long_name',17,'valid output time')
+
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention)
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention)
+
+         convention(1:32) = "Unidata Observation Dataset v1.0"
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention)
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station")
+#ifndef HYDRO_REALTIME
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0")
+#endif
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "station_dimension",7, "station")
+         iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+         iret = nf_put_att_int(ncid, NF_GLOBAL, "stream_order_output",NF_INT,1,order_to_write)
+
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "Conventions",32, convention)
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "cdm_datatype",7, "Station")
+#ifndef HYDRO_REALTIME
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_max",4, "90.0")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lat_min",5, "-90.0")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_max",5, "180.0")
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "geospatial_lon_min",6, "-180.0")
+#endif
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+         iret = nf_put_att_text(ncid2, NF_GLOBAL, "station_dimension",7, "station")
+         iret = nf_put_att_real(ncid2, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+         iret = nf_put_att_int(ncid2, NF_GLOBAL, "stream_order_output",NF_INT,1,order_to_write)
+
+         iret = nf_enddef(ncid)
+         iret = nf_enddef(ncid2)
+
+        !-- write latitudes
+         iret = nf_inq_varid(ncid,"latitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlat)
+
+         iret = nf_inq_varid(ncid2,"latitude", varid)
+         iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlatO)
+
+        !-- write longitudes
+         iret = nf_inq_varid(ncid,"longitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chanlon)
+
+         iret = nf_inq_varid(ncid2,"longitude", varid)
+         iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), chanlonO)
+
+        !-- write elevations
+         iret = nf_inq_varid(ncid,"altitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), elevation)
+
+         iret = nf_inq_varid(ncid2,"altitude", varid)
+         iret = nf_put_vara_real(ncid2, varid, (/1/), (/nobs/), elevationO)
+
+      !-- write gage location
+!      iret = nf_inq_varid(ncid,"gages", varid)
+!      iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), STRMFRXSTPTS)
+
+        !-- write number_of_stations, OPTIONAL
+      !!  iret = nf_inq_varid(ncid,"number_stations", varid)
+      !!  iret = nf_put_var_int(ncid, varid, nstations)
+
+        !-- write station id's 
+         do i=1,nstations
+          TSTART(1) = 1
+          TSTART(2) = i
+          TCOUNT(1) = TXLEN
+          TCOUNT(2) = 1
+          iret = nf_inq_varid(ncid,"station_id", varid)
+          iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i))
+         enddo
+
+        !-- write observation id's 
+         do i=1, nobs
+          OTSTART(1) = 1
+          OTSTART(2) = i
+          OTCOUNT(1) = OTXLEN
+          OTCOUNT(2) = 1
+          iret = nf_inq_varid(ncid2,"station_id", varid)
+          iret = nf_put_vara_text(ncid2, varid, OTSTART, OTCOUNT, stnameO(i))
+         enddo
+
+     endif
+
+     output_count = output_count + 1
+
+     open (unit=55, &
+#ifndef NCEP_WCOSS
+     file='frxst_pts_out.txt', &
+#endif
+     status='unknown',position='append')
+
+     cnt=0
+     do i=1,nlk   
+
+       if(ORDER(i) .ge. order_to_write) then 
+         start_pos = (cnt+1)+(nstations*(output_count-1))
+
+         !!--time in seconds since startdate
+          iret = nf_inq_varid(ncid,"time", varid)
+          iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since) 
+
+         if(UDMP_OPT .eq. 1) then
+            iret = nf_inq_varid(ncid,"accLndRunOff", varid)
+            iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accLndRunOff(i))
+
+            iret = nf_inq_varid(ncid,"accQLateral", varid)
+            iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accQLateral(i))
+
+            iret = nf_inq_varid(ncid,"accStrmvolrt", varid)
+            iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accStrmvolrt(i))
+
+            iret = nf_inq_varid(ncid,"accBucket", varid)
+            iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), accBucket(i))
+         endif
+
+         iret = nf_inq_varid(ncid,"streamflow", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlink(i,1))
+
+#ifdef WRF_HYDRO_NUDGING
+         iret = nf_inq_varid(ncid,"nudge", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), nudge(i))
+#endif
+
+!        iret = nf_inq_varid(ncid,"pos_streamflow", varid)
+!        iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), abs(qlink(i,1)))
+
+#ifndef HYDRO_REALTIME
+         iret = nf_inq_varid(ncid,"head", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), hlink(i))
+#endif
+
+         iret = nf_inq_varid(ncid,"order", varid)
+         iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), ORDER(i))
+
+         !-- station index.. will repeat for every timesstep
+         iret = nf_inq_varid(ncid,"parent_index", varid)
+         iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt)
+
+          !--record number of previous record for same station
+!obsolete format         prev_pos = cnt+(nstations*(output_count-1))
+         prev_pos = cnt+(nobs*(output_count-2))
+         if(output_count.ne.1) then !-- only write next set of records
+           iret = nf_inq_varid(ncid,"prevChild", varid)
+           iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos)
+         endif
+         cnt=cnt+1  !--indices are 0 based
+         rec_num_of_station(cnt) = start_pos-1  !-- save position for last child, 0-based!!
+
+
+       endif
+    enddo
+!    close(999) 
+
+    !-- output  only observation points
+    cnt=0
+    do i=1,nlk   
+       if(channel_option .ne. 3) then
+          ! jlm this verry repetitiuos, oh well.
+          if(trim(gages(i)) .ne. trim(gageMiss)) then
+
+             start_posO = (cnt+1)+(nobs * (output_count-1))
+             !Write frxst_pts to text file...
+             !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
+118          FORMAT(I8,",",A10,1X,A8,", ",A15,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
+             !write(55,118) seconds_since, date(1:10), date(12:19), &
+#ifndef HYDRO_REALTIME
+             write(55,118) seconds_since, hydroTime(1:10), hydroTime(12:19), &
+                  gages(i), chlon(i), chlat(i),                               &
+                  qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
+#endif
+             !yw 117 FORMAT(I8,1X,A25,1X,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3)
+             !yw 117 FORMAT(I8,1X,A10,1X,A8,1x,I7,1X,F10.5,1X,F8.5,1X,F9.3,1x,F12.3,1X,F6.3)
+
+             !!--time in seconds since startdate
+             iret = nf_inq_varid(ncid2,"time", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/1/), (/1/), seconds_since)
+
+             iret = nf_inq_varid(ncid2,"streamflow", varid)
+             iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1))
+
+#ifdef WRF_HYDRO_NUDGING
+             iret = nf_inq_varid(ncid2,"nudge", varid)
+             iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), nudge(i))
+#endif
+
+#ifndef HYDRO_REALTIME
+             iret = nf_inq_varid(ncid2,"head", varid)
+             iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i))
+#endif
+
+             iret = nf_inq_varid(ncid,"order", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i))
+
+             !-- station index.. will repeat for every timesstep
+             iret = nf_inq_varid(ncid2,"parent_index", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt)
+
+             !--record number of previous record for same station
+             !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
+             prev_posO = cnt+(nobs*(output_count-2))
+             if(output_count.ne.1) then !-- only write next set of records
+                iret = nf_inq_varid(ncid2,"prevChild", varid)
+                iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO)
+
+                !IF block to add -1 to last element of prevChild array to designate end of list...
+                !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
+                !             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
+                !           else
+                !             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO)
+                !           endif
+
+             endif
+             cnt=cnt+1  !--indices are 0 based
+             rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
+          endif
+
+          
+       else !! channel options 3 below
+
+          if(STRMFRXSTPTS(i) .ne. -9999) then 
+             start_posO = (cnt+1)+(nobs * (output_count-1))
+             !Write frxst_pts to text file...
+             !yw          write(55,117) seconds_since,trim(date),cnt,chlon(i),chlat(i), &
+117          FORMAT(I8,",",A10,1X,A8,",",I7,",",F10.5,",",F8.5,",",F9.3,",",F12.3,",",F6.3)
+             !write(55,117) seconds_since,date(1:10),date(12:19),cnt,chlon(i),chlat(i), &
+             !     qlink(i,1), qlink(i,1)*35.315,hlink(i)
+             ! JLM: makes more sense to output the value in frxstpts incase they have meaning,
+             ! as below, but I'm not going to make this change until I'm working with gridded
+             ! streamflow again.
+             write(55,117) seconds_since, hydroTime(1:10), hydroTime(12:19), &
+                  strmfrxstpts(i), chlon(i), chlat(i),                        &
+                  qlink(i,1), qlink(i,1)*35.314666711511576, hlink(i)
+
+             !!--time in seconds since startdate  
+             iret = nf_inq_varid(ncid2,"time", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/1/), (/1/), seconds_since)
+
+             iret = nf_inq_varid(ncid2,"streamflow", varid)
+             iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), qlink(i,1))
+
+#ifndef HYDRO_REALTIME
+             iret = nf_inq_varid(ncid2,"head", varid)
+             iret = nf_put_vara_real(ncid2, varid, (/start_posO/), (/1/), hlink(i))
+#endif
+
+             iret = nf_inq_varid(ncid,"order", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), ORDER(i))
+
+             !-- station index.. will repeat for every timesstep
+             iret = nf_inq_varid(ncid2,"parent_index", varid)
+             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), cnt)
+
+             !--record number of previous record for same station
+             !obsolete format          prev_posO = cnt+(nobs*(output_count-1))
+             prev_posO = cnt+(nobs*(output_count-2))
+             if(output_count.ne.1) then !-- only write next set of records
+                iret = nf_inq_varid(ncid2,"prevChild", varid)
+                iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO)
+
+                !IF block to add -1 to last element of prevChild array to designate end of list...
+                !           if(cnt+1.eq.nobs.AND.output_count.eq.split_output_count) then
+                !             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), -1)
+                !           else
+                !             iret = nf_put_vara_int(ncid2, varid, (/start_posO/), (/1/), prev_posO)
+                !           endif 
+
+             endif
+             cnt=cnt+1  !--indices are 0 based
+             rec_num_of_stationO(cnt) = start_posO - 1  !-- save position for last child, 0-based!!
+          endif
+
+       endif
+
+    enddo
+    close(55) 
+
+      !-- lastChild variable gives the record number of the most recent report for the station
+      iret = nf_inq_varid(ncid,"lastChild", varid)
+      iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), rec_num_of_station)
+
+      !-- lastChild variable gives the record number of the most recent report for the station
+      iret = nf_inq_varid(ncid2,"lastChild", varid)
+      iret = nf_put_vara_int(ncid2, varid, (/1/), (/nobs/), rec_num_of_stationO)
+
+      iret = nf_redef(ncid)
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(date)) = date
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate))
+
+      iret = nf_redef(ncid2)
+      iret = nf_put_att_text(ncid2, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate))
+
+      iret = nf_enddef(ncid)
+      iret = nf_sync(ncid)
+
+      iret = nf_enddef(ncid2)
+      iret = nf_sync(ncid2)
+
+      if (output_count == split_output_count) then
+        output_count = 0
+        iret = nf_close(ncid)
+        iret = nf_close(ncid2)
+     endif
+
+     if(allocated(chanlat))  deallocate(chanlat)
+     if(allocated(chanlon))  deallocate(chanlon)
+     if(allocated(elevation))  deallocate(elevation)
+     if(allocated(station_id))  deallocate(station_id)
+     if(allocated(lOrder))  deallocate(lOrder)
+     if(allocated(rec_num_of_station))  deallocate(rec_num_of_station)
+     if(allocated(stname))  deallocate(stname)
+
+     if(allocated(chanlatO))  deallocate(chanlatO)
+     if(allocated(chanlonO))  deallocate(chanlonO)
+     if(allocated(elevationO))  deallocate(elevationO)
+     if(allocated(station_idO))  deallocate(station_idO)
+     if(allocated(lOrderO))  deallocate(lOrderO)
+     if(allocated(rec_num_of_stationO))  deallocate(rec_num_of_stationO)
+     if(allocated(stnameO))  deallocate(stnameO)
+#ifdef HYDRO_D
+     print *, "Exited Subroutine output_chrt"
+#endif
+     close(16)
+
+20 format(i8,',',f12.7,',',f10.7,',',f6.2,',',i3)
+
+end subroutine output_chrt_bak
+
+#ifdef MPP_LAND
+!-- output the channel route in an IDV 'station' compatible format
+   subroutine mpp_output_chrt(gnlinks,gnlinksl,map_l2g,igrid,                  &
+        split_output_count, NLINKS, ORDER,                                     &
+        startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch,              &
+        K,STRMFRXSTPTS,order_to_write,NLINKSL,channel_option, gages, gageMiss, &
+        lsmDt                                       &
+#ifdef WRF_HYDRO_NUDGING
+        , nudge                                     &
+#endif
+        , accLndRunOff, accQLateral, accStrmvolrt, accBucket, UDMP_OPT         &
+        )
+
+       USE module_mpp_land
+
+       implicit none
+
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid,K,channel_option,NLINKSL
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLINKS
+     real, dimension(:),               intent(in) :: chlon,chlat
+     real, dimension(:),                  intent(in) :: hlink,zelev
+
+     integer, dimension(:),               intent(in) :: ORDER
+     integer, dimension(:),               intent(inout) :: STRMFRXSTPTS
+     character(len=15), dimension(:),     intent(inout) :: gages
+     character(len=15),                   intent(in) :: gageMiss
+     real,                                intent(in) :: lsmDt
+
+     real,                                     intent(in) :: dtrt_ch
+     real, dimension(:,:),                intent(in) :: qlink
+#ifdef WRF_HYDRO_NUDGING
+     real, dimension(:),                  intent(in) :: nudge
+#endif
+
+     integer, intent(in) :: UDMP_OPT
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+
+      integer  :: gnlinks, map_l2g(nlinks), order_to_write, gnlinksl
+      real, allocatable,dimension(:) :: g_chlon,g_chlat, g_hlink,g_zelev
+#ifdef WRF_HYDRO_NUDGING
+      real, allocatable,dimension(:) :: g_nudge
+#endif
+      integer, allocatable,dimension(:) :: g_order,g_STRMFRXSTPTS
+      real,allocatable,dimension(:,:) :: g_qlink
+      integer  :: gsize
+      character(len=15),allocatable,dimension(:) :: g_gages
+      real,allocatable,dimension(:) :: g_accLndRunOff, g_accQLateral, g_accStrmvolrt, g_accBucket
+      real, dimension(:), intent(in) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket
+
+        gsize = gNLINKS
+        if(gnlinksl .gt. gsize) gsize = gnlinksl
+     if(my_id .eq. io_id ) then
+        allocate(g_chlon(gsize  ))
+        allocate(g_chlat(gsize  ))
+        allocate(g_hlink(gsize  ))
+        allocate(g_zelev(gsize  ))
+        allocate(g_qlink(gsize  ,2))
+#ifdef WRF_HYDRO_NUDGING
+        allocate(g_nudge(gsize))
+#endif
+        allocate(g_order(gsize  ))
+        allocate(g_STRMFRXSTPTS(gsize  ))
+        allocate(g_gages(gsize))
+
+        allocate(g_accLndRunOff(gsize  ))
+        allocate(g_accQLateral(gsize  ))
+        allocate(g_accStrmvolrt(gsize  ))
+        allocate(g_accBucket(gsize  ))
+
+     else
+
+        allocate(g_accLndRunOff(1))
+        allocate(g_accQLateral(1))
+        allocate(g_accStrmvolrt(1))
+        allocate(g_accBucket(1))
+
+        allocate(g_chlon(1))
+        allocate(g_chlat(1))
+        allocate(g_hlink(1))
+        allocate(g_zelev(1))
+        allocate(g_qlink(1,2))
+#ifdef WRF_HYDRO_NUDGING
+        allocate(g_nudge(1))
+#endif
+        allocate(g_order(1))
+        allocate(g_STRMFRXSTPTS(1))
+        allocate(g_gages(1))
+     endif
+
+     call mpp_land_sync()
+
+     if(channel_option .eq. 1 .or. channel_option .eq. 2) then
+        g_qlink = 0
+        g_gages = gageMiss
+        call ReachLS_write_io(qlink(:,1), g_qlink(:,1))
+        call ReachLS_write_io(qlink(:,2), g_qlink(:,2))
+#ifdef WRF_HYDRO_NUDGING
+        g_nudge=0
+        call ReachLS_write_io(nudge,g_nudge)
+#endif
+        call ReachLS_write_io(order, g_order)
+        call ReachLS_write_io(chlon, g_chlon)
+        call ReachLS_write_io(chlat, g_chlat)
+        call ReachLS_write_io(zelev, g_zelev)
+!yw This function does not work correctly for gages
+!yw        call ReachLS_write_io(gages, g_gages)
+        call ReachLS_write_io(STRMFRXSTPTS, g_STRMFRXSTPTS)
+        call ReachLS_write_io(hlink, g_hlink)
+
+        call ReachLS_write_io(accLndRunOff, g_accLndRunOff)
+        call ReachLS_write_io(accQLateral, g_accQLateral)
+        call ReachLS_write_io(accStrmvolrt, g_accStrmvolrt)
+        call ReachLS_write_io(accBucket, g_accBucket)
+
+     else
+        call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1))
+        call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2))
+        call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order)
+        call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon)
+        call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat)
+        call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev)
+        call write_chanel_int(STRMFRXSTPTS,map_l2g,gnlinks,nlinks,g_STRMFRXSTPTS)
+        call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink)
+     endif
+
+
+     if(my_id .eq. IO_id) then
+       call output_chrt(igrid, split_output_count, GNLINKS, g_ORDER,                &
+          startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt_ch,K,     &
+          g_STRMFRXSTPTS,order_to_write,gNLINKSL,channel_option, g_gages, gageMiss, &
+          lsmDt                                                                     &
+#ifdef WRF_HYDRO_NUDGING
+          , g_nudge                                     &
+#endif
+          , g_accLndRunOff, g_accQLateral, g_accStrmvolrt, g_accBucket, UDMP_OPT    &
+          )
+
+    end if
+     call mpp_land_sync()
+    if(allocated(g_order)) deallocate(g_order)
+    if(allocated(g_STRMFRXSTPTS)) deallocate(g_STRMFRXSTPTS)
+    if(allocated(g_chlon)) deallocate(g_chlon)
+    if(allocated(g_chlat)) deallocate(g_chlat)
+    if(allocated(g_hlink)) deallocate(g_hlink)
+    if(allocated(g_zelev)) deallocate(g_zelev)
+    if(allocated(g_qlink)) deallocate(g_qlink)
+    if(allocated(g_gages)) deallocate(g_gages)
+#ifdef WRF_HYDRO_NUDGING
+    if(allocated(g_nudge)) deallocate(g_nudge)
+#endif
+    if(allocated(g_accLndRunOff)) deallocate(g_accLndRunOff)
+    if(allocated(g_accQLateral)) deallocate(g_accQLateral)
+    if(allocated(g_accStrmvolrt)) deallocate(g_accStrmvolrt)
+    if(allocated(g_accBucket)) deallocate(g_accBucket)
+
+end subroutine mpp_output_chrt
+
+!---------  lake netcdf output -----------------------------------------
+!-- output the ilake info an IDV 'station' compatible format -----------
+   subroutine mpp_output_lakes(lake_index,igrid, split_output_count, NLAKES, &
+        startdate, date, latlake, lonlake, elevlake, &
+        qlakei,qlakeo, resht,dtrt_ch,K)
+
+   USE module_mpp_land
+
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid, K
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLAKES
+     real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
+     real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
+     real,                                     intent(in) :: dtrt_ch
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+     integer lake_index(nlakes)
+     
+
+     call write_lake_real(latlake,lake_index,nlakes)
+     call write_lake_real(lonlake,lake_index,nlakes)
+     call write_lake_real(elevlake,lake_index,nlakes)
+     call write_lake_real(resht,lake_index,nlakes)
+     call write_lake_real(qlakei,lake_index,nlakes)
+     call write_lake_real(qlakeo,lake_index,nlakes)
+     if(my_id.eq. IO_id) then
+        call output_lakes(igrid, split_output_count, NLAKES, &
+           startdate, date, latlake, lonlake, elevlake, &
+           qlakei,qlakeo, resht,dtrt_ch,K)
+     end if
+     call mpp_land_sync()
+     return
+     end subroutine mpp_output_lakes
+
+   subroutine mpp_output_lakes2(lake_index,igrid, split_output_count, NLAKES, &
+        startdate, date, latlake, lonlake, elevlake, &
+        qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM)
+
+   USE module_mpp_land
+
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid, K
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLAKES
+     real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
+     real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
+     real,                                     intent(in) :: dtrt_ch
+     integer, dimension(NLAKES),               intent(in) :: LAKEIDM     ! lake id
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+     integer lake_index(nlakes)
+
+     call write_lake_real(latlake,lake_index,nlakes)
+     call write_lake_real(lonlake,lake_index,nlakes)
+     call write_lake_real(elevlake,lake_index,nlakes)
+     call write_lake_real(resht,lake_index,nlakes)
+     call write_lake_real(qlakei,lake_index,nlakes)
+     call write_lake_real(qlakeo,lake_index,nlakes)
+
+     if(my_id.eq. IO_id) then
+        call output_lakes2(igrid, split_output_count, NLAKES, &
+           startdate, date, latlake, lonlake, elevlake, &
+           qlakei,qlakeo, resht,dtrt_ch,K, LAKEIDM)
+     end if
+     call mpp_land_sync()
+     return
+     end subroutine mpp_output_lakes2
+#endif
+
+!----------------------------------- lake netcdf output
+!-- output the ilake info an IDV 'station' compatible format
+   subroutine output_lakes(igrid, split_output_count, NLAKES, &
+        startdate, date, latlake, lonlake, elevlake, &
+        qlakei,qlakeo, resht,dtrt_ch,K)
+
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid, K
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLAKES
+     real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
+     real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
+     real,                                     intent(in) :: dtrt_ch
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+
+     integer, allocatable, DIMENSION(:)                   :: station_id
+     integer, allocatable, DIMENSION(:)                   :: rec_num_of_lake
+
+     integer, save  :: output_count
+     integer, save :: ncid
+
+     integer :: stationdim, dimdata, varid, charid, n
+     integer :: iret,i, start_pos, prev_pos  !-- 
+     integer :: previous_pos        !-- used for the station model
+     character(len=256) :: output_flnm
+     character(len=19)  :: date19, date19start
+     character(len=34)  :: sec_since_date
+     integer :: seconds_since,cnt
+     character(len=32)  :: convention
+     character(len=6),allocatable, DIMENSION(:)  :: stname
+     integer :: timedim
+     character(len=34) :: sec_valid_date
+
+    !--- all this for writing the station id string
+     INTEGER   TDIMS, TXLEN
+     PARAMETER (TDIMS=2)    ! number of TX dimensions
+     PARAMETER (TXLEN = 6) ! length of example string
+     INTEGER  TIMEID        ! record dimension id
+     INTEGER  TXID          ! variable ID
+     INTEGER  TXDIMS(TDIMS) ! variable shape
+     INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
+
+!    sec_since_date = 'seconds since '//date(1:4)//'-'//date(6:7)//'-'//date(9:10)//' '//date(12:13)//':'//date(15:16)//' UTC'
+!    seconds_since = int(dtrt_ch)*output_count
+     seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1))
+     sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) &
+                     //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC'
+
+
+     allocate(station_id(NLAKES))
+     allocate(rec_num_of_lake(NLAKES))
+     allocate(stname(NLAKES))
+
+     if (output_count == 0) then
+
+!-- have moved sec_since_date from above here..
+      sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
+                  //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
+
+      date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
+                  //startdate(12:13)//':'//startdate(15:16)//':00'
+
+      write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+#ifdef HYDRO_D
+      print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#else
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+
+      if (iret /= 0) then
+          call hydro_stop("In output_lakes() - Problem nf_create")
+      endif
+
+      do i=1,NLAKES
+         station_id(i) = i
+         write(stname(i),'(I6)') i
+      enddo 
+
+      iret = nf_def_dim(ncid, "recNum", NF_UNLIMITED, dimdata)  !--for linked list approach
+      iret = nf_def_dim(ncid, "station", nlakes, stationdim)
+      iret = nf_def_dim(ncid, "time", 1, timedim)
+
+#ifndef HYDRO_REALTIME
+      !- station location definition,  lat
+      iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake latitude')
+      iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north')
+
+      !- station location definition,  long
+      iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake longitude')
+      iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east')
+
+!     !-- lake's phyical elevation
+      iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake altitude')
+      iret = nf_put_att_text(ncid,varid,'units',6,'meters')
+#endif
+
+     !-- parent index
+      iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/dimdata/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',33,'index of the lake for this record')
+
+     !-- prevChild
+      iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/dimdata/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',54,'record number of the previous record for the same lake')
+!ywtmp      iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+      iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+     !-- lastChild
+      iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',27,'latest report for this lake')
+!ywtmp      iret = nf_put_att_int(ncid,varid,'_FillValue',NF_INT,2,-1)
+      iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+!     !- water surface elevation
+      iret = nf_def_var(ncid, "elevation", NF_FLOAT, 1, (/dimdata/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',6,'meters')
+      iret = nf_put_att_text(ncid,varid,'long_name',23,'Water Surface Elevation')
+
+!     !- inflow to lake
+      iret = nf_def_var(ncid, "inflow", NF_FLOAT, 1, (/dimdata/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+
+!     !- outflow to lake
+      iret = nf_def_var(ncid, "outflow", NF_FLOAT, 1, (/dimdata/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+
+     !-- station  id
+     ! define character-position dimension for strings of max length 6
+         iret = NF_DEF_DIM(ncid, "id_len", 6, charid)
+         TXDIMS(1) = charid   ! define char-string variable and position dimension first
+         TXDIMS(2) = stationdim
+         iret = nf_def_var(ncid,"station_id",NF_CHAR, TDIMS, TXDIMS, varid)
+         iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id')
+
+!     !- time definition, timeObs
+         iret = nf_def_var(ncid,"time", NF_INT, 1, (/timedim/), varid) 
+         iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date)
+         iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time')
+
+!       date19(1:19) = "0000-00-00_00:00:00"
+!       date19(1:len_trim(startdate)) = startdate
+!       iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention)
+!
+        date19(1:19) = "0000-00-00_00:00:00"
+        date19(1:len_trim(startdate)) = startdate
+        convention(1:32) = "Unidata Observation Dataset v1.0"
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention)
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station")
+#ifndef HYDRO_REALTIME
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0")
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0")
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0")
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0")
+#endif
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "station_dimension",7, "station")
+!!       iret = nf_put_att_text(ncid, NF_GLOBAL, "observation_dimension",6, "recNum")
+!!        iret = nf_put_att_text(ncid, NF_GLOBAL, "time_coordinate",16,"time_observation")
+        iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+        iret = nf_enddef(ncid)
+
+#ifndef HYDRO_REALTIME
+        !-- write latitudes
+        iret = nf_inq_varid(ncid,"latitude", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LATLAKE)
+
+        !-- write longitudes
+        iret = nf_inq_varid(ncid,"longitude", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LONLAKE)
+
+        !-- write physical height of lake
+        iret = nf_inq_varid(ncid,"altitude", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), elevlake)
+#endif
+
+        !-- write station id's 
+         do i=1,nlakes
+          TSTART(1) = 1
+          TSTART(2) = i
+          TCOUNT(1) = TXLEN
+          TCOUNT(2) = 1
+          iret = nf_inq_varid(ncid,"station_id", varid)
+          iret = nf_put_vara_text(ncid, varid, TSTART, TCOUNT, stname(i))
+         enddo
+
+     endif
+
+     iret = nf_inq_varid(ncid,"time", varid)
+     iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since)
+
+     output_count = output_count + 1
+
+     cnt=0
+     do i=1,NLAKES
+
+         start_pos = (cnt+1)+(nlakes*(output_count-1))
+
+         !!--time in seconds since startdate
+         iret = nf_inq_varid(ncid,"time_observation", varid)
+         iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), seconds_since)
+
+         iret = nf_inq_varid(ncid,"elevation", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), resht(i))
+
+         iret = nf_inq_varid(ncid,"inflow", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakei(i))
+
+         iret = nf_inq_varid(ncid,"outflow", varid)
+         iret = nf_put_vara_real(ncid, varid, (/start_pos/), (/1/), qlakeo(i))
+
+         !-- station index.. will repeat for every timesstep
+         iret = nf_inq_varid(ncid,"parent_index", varid)
+         iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), cnt)
+
+          !--record number of previous record for same station
+         prev_pos = cnt+(nlakes*(output_count-1))
+         if(output_count.ne.1) then !-- only write next set of records
+           iret = nf_inq_varid(ncid,"prevChild", varid)
+           iret = nf_put_vara_int(ncid, varid, (/start_pos/), (/1/), prev_pos)
+         endif
+
+         cnt=cnt+1  !--indices are 0 based
+         rec_num_of_lake(cnt) = start_pos-1  !-- save position for last child, 0-based!!
+
+    enddo
+
+      !-- lastChild variable gives the record number of the most recent report for the station
+      iret = nf_inq_varid(ncid,"lastChild", varid)
+      iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake)
+
+     !-- number of children reported for this station, OPTIONAL
+     !--  iret = nf_inq_varid(ncid,"numChildren", varid)
+     !--  iret = nf_put_vara_int(ncid, varid, (/1/), (/nlakes/), rec_num_of_lake)
+
+    iret = nf_redef(ncid)
+    iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate))
+    iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+    iret = nf_enddef(ncid)
+
+    iret = nf_sync(ncid)
+     if (output_count == split_output_count) then
+        output_count = 0
+        iret = nf_close(ncid)
+     endif
+
+     if(allocated(station_id)) deallocate(station_id)
+     if(allocated(rec_num_of_lake)) deallocate(rec_num_of_lake)
+     if(allocated(stname)) deallocate(stname)
+#ifdef HYDRO_D
+     print *, "Exited Subroutine output_lakes"
+#endif
+     close(16)
+
+ end subroutine output_lakes
+
+!----------------------------------- lake netcdf output
+!-- output the lake as regular netcdf file format for better performance than point netcdf file.
+   subroutine output_lakes2(igrid, split_output_count, NLAKES, &
+        startdate, date, latlake, lonlake, elevlake, &
+        qlakei,qlakeo, resht,dtrt_ch,K,LAKEIDM)
+
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid, K
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLAKES
+     real, dimension(NLAKES),                  intent(in) :: latlake,lonlake,elevlake,resht
+     real, dimension(NLAKES),                  intent(in) :: qlakei,qlakeo  !-- inflow and outflow of lake
+     integer, dimension(NLAKES),               intent(in) :: LAKEIDM        !-- LAKE ID
+     real,                                     intent(in) :: dtrt_ch
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+
+
+     integer, save  :: output_count
+     integer, save :: ncid
+
+     integer :: stationdim, varid,  n
+     integer :: iret,i    !-- 
+     character(len=256) :: output_flnm
+     character(len=19)  :: date19, date19start
+     character(len=32)  :: convention
+     integer :: timedim
+     integer :: seconds_since
+     character(len=34) :: sec_valid_date
+     sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) &
+                         //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC'
+
+
+     seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1))
+
+     if (output_count == 0) then
+
+      date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
+                  //startdate(12:13)//':'//startdate(15:16)//':00'
+
+      write(output_flnm, '(A12,".LAKEOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+#ifdef HYDRO_D
+      print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#else
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+
+      if (iret /= 0) then
+          print*, "Problem nf_create" 
+          call hydro_stop("output_lakes") 
+      endif 
+
+      iret = nf_def_dim(ncid, "station", nlakes, stationdim)
+
+      iret = nf_def_dim(ncid, "time", 1, timedim)
+
+#ifndef HYDRO_REALTIME
+      !- station location definition,  lat
+      iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake latitude')
+      iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north')
+#endif
+
+      !- station location definition,  LAKEIDM
+      iret = nf_def_var(ncid,"lake_id",NF_INT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake COMMON ID')
+
+#ifndef HYDRO_REALTIME
+      !- station location definition,  long
+      iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',14,'Lake longitude')
+      iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east')
+
+!     !-- lake's phyical elevation
+      iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',13,'Lake altitude')
+      iret = nf_put_att_text(ncid,varid,'units',6,'meters')
+#endif
+
+!     !- water surface elevation
+      iret = nf_def_var(ncid, "elevation", NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',6,'meters')
+      iret = nf_put_att_text(ncid,varid,'long_name',23,'Water Surface Elevation')
+
+!     !- inflow to lake
+      iret = nf_def_var(ncid, "inflow", NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+
+!     !- outflow to lake
+      iret = nf_def_var(ncid, "outflow", NF_FLOAT, 1, (/stationdim/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+
+      ! Time variable
+      iret = nf_def_var(ncid, "time", NF_INT, 1, (/timeDim/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date)
+      iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time')
+
+        date19(1:19) = "0000-00-00_00:00:00"
+        date19(1:len_trim(startdate)) = startdate
+#ifndef HYDRO_REALTIME
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0")
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0")
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0")
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0")
+#endif
+        iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+        iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+        iret = nf_enddef(ncid)
+
+        iret = nf_inq_varid(ncid,"time", varid)
+        iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since)
+
+#ifndef HYDRO_REALTIME
+        !-- write latitudes
+        iret = nf_inq_varid(ncid,"latitude", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LATLAKE)
+
+        !-- write longitudes
+        iret = nf_inq_varid(ncid,"longitude", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), LONLAKE)
+
+        !-- write physical height of lake
+        iret = nf_inq_varid(ncid,"altitude", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), elevlake)
+#endif
+
+        !-- write elevation  of lake
+        iret = nf_inq_varid(ncid,"elevation", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), resht   )
+
+        !-- write elevation  of inflow
+        iret = nf_inq_varid(ncid,"inflow", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), qlakei  )
+
+        !-- write elevation  of inflow
+        iret = nf_inq_varid(ncid,"outflow", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/NLAKES/), qlakeo  )
+
+        !-- write lake id
+        iret = nf_inq_varid(ncid,"lake_id", varid)
+        iret = nf_put_vara_int(ncid, varid, (/1/), (/NLAKES/), LAKEIDM)
+
+     endif
+
+     output_count = output_count + 1
+
+
+    iret = nf_redef(ncid)
+  
+    iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+    iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate))
+    iret = nf_enddef(ncid)
+
+    iret = nf_sync(ncid)
+     if (output_count == split_output_count) then
+        output_count = 0
+        iret = nf_close(ncid)
+     endif
+
+ end subroutine output_lakes2
+!----------------------------------- lake netcdf output
+
+#ifdef MPP_LAND
+
+!-- output the channel route in an IDV 'grid' compatible format
+   subroutine mpp_output_chrtgrd(igrid, split_output_count, ixrt,jxrt, &
+        NLINKS,CH_NETLNK_in, startdate, date, &
+        qlink, dt, geo_finegrid_flnm, gnlinks,map_l2g,g_ixrt,g_jxrt )
+
+   USE module_mpp_land
+
+     implicit none
+#include 
+     integer g_ixrt,g_jxrt
+     integer,                                  intent(in) :: igrid
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLINKS,ixrt,jxrt
+     real,                                     intent(in) :: dt
+     real, dimension(:,:),                intent(in) :: qlink
+     integer, dimension(IXRT,JXRT),            intent(in) :: CH_NETLNK_in
+     character(len=*),          intent(in)     :: geo_finegrid_flnm
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+
+     integer::  gnlinks , map_l2g(nlinks)
+
+     integer, allocatable,dimension(:,:)         :: CH_NETLNK
+     real, allocatable,dimension(:,:)                :: g_qlink
+
+     if(my_id .eq. io_id) then
+        allocate(CH_NETLNK(g_IXRT,g_JXRT))
+        allocate(g_qlink(gNLINKS,2) )
+     else
+        allocate(CH_NETLNK(1,1))
+        allocate(g_qlink(1,2) )
+     endif
+
+     call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1))
+     call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2))
+
+     call write_IO_rt_int(CH_NETLNK_in, CH_NETLNK)
+
+    if(my_id.eq.IO_id) then
+        call  output_chrtgrd(igrid, split_output_count, g_ixrt,g_jxrt, &
+           GNLINKS, CH_NETLNK, startdate, date, &
+           g_qlink, dt, geo_finegrid_flnm)
+    endif
+    
+     if(allocated(g_qlink)) deallocate(g_qlink)
+     if(allocated(CH_NETLNK)) deallocate(CH_NETLNK)
+     return
+     end subroutine mpp_output_chrtgrd
+#endif
+
+!-- output the channel route in an IDV 'grid' compatible format
+   subroutine output_chrtgrd(igrid, split_output_count, ixrt,jxrt, &
+        NLINKS, CH_NETLNK, startdate, date, &
+        qlink, dt, geo_finegrid_flnm)
+
+     integer,                                  intent(in) :: igrid
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLINKS,ixrt,jxrt
+     real,                                     intent(in) :: dt
+     real, dimension(:,:),                intent(in) :: qlink
+     integer, dimension(IXRT,JXRT),            intent(in) :: CH_NETLNK
+     character(len=*),          intent(in)     :: geo_finegrid_flnm
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+     character(len=32)  :: convention
+     integer,save  :: output_count
+     integer, save :: ncid,ncstatic
+     real, dimension(IXRT,JXRT)          :: tmpflow
+     real, dimension(IXRT)            :: xcoord
+     real, dimension(JXRT)            :: ycoord
+     real                                :: long_cm,lat_po,fe,fn
+     real, dimension(2)                  :: sp
+
+    integer :: varid, n
+    integer :: jxlatdim,ixlondim,timedim !-- dimension ids
+    integer :: timedim2
+    character(len=34) :: sec_valid_date
+
+    integer :: iret,i,j
+    character(len=256) :: output_flnm
+    character(len=19)  :: date19
+    character(len=34)  :: sec_since_date
+ 
+
+    integer :: seconds_since
+
+    seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1))
+    sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) &
+                 //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC'
+
+
+      tmpflow = -9E15
+
+ 
+        write(output_flnm, '(A12,".CHRTOUT_GRID",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+#ifdef HYDRO_D
+        print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+ 
+
+!--- define dimension
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#else
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+
+        if (iret /= 0) then
+            call hydro_stop("In output_chrtgrd() - Problem nf_create ")
+        endif
+
+        iret = nf_def_dim(ncid, "time", NF_UNLIMITED, timedim)
+        iret = nf_def_dim(ncid, "x", ixrt, ixlondim)
+        iret = nf_def_dim(ncid, "y", jxrt, jxlatdim)
+
+!--- define variables
+!     !- time definition, timeObs
+
+       !- x-coordinate in cartesian system
+!yw         iret = nf_def_var(ncid,"x",NF_DOUBLE, 1, (/ixlondim/), varid)
+!yw         iret = nf_put_att_text(ncid,varid,'long_name',26,'x coordinate of projection')
+!yw         iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_x_coordinate')
+!yw         iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+       !- y-coordinate in cartesian ssystem
+!yw         iret = nf_def_var(ncid,"y",NF_DOUBLE, 1, (/jxlatdim/), varid)
+!yw         iret = nf_put_att_text(ncid,varid,'long_name',26,'y coordinate of projection')
+!yw         iret = nf_put_att_text(ncid,varid,'standard_name',23,'projection_y_coordinate')
+!yw         iret = nf_put_att_text(ncid,varid,'units',5,'Meter')
+
+!     !- flow definition, var
+        iret = nf_def_var(ncid,"streamflow",NF_REAL, 3, (/ixlondim,jxlatdim,timedim/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',6,'m3 s-1')
+        iret = nf_put_att_text(ncid,varid,'long_name',15,'water flow rate')
+        iret = nf_put_att_text(ncid,varid,'coordinates',3,'x y')
+        iret = nf_put_att_text(ncid,varid,'grid_mapping',23,'lambert_conformal_conic')
+        iret = nf_put_att_real(ncid,varid,'missing_value',NF_REAL,1,-9E15)
+        iret = nf_def_var(ncid,"index",NF_INT, 2, (/ixlondim,jxlatdim/), varid)
+        iret = nf_def_var(ncid, "time", NF_INT, 1, (/timedim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time')
+        iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date)
+
+
+!-- place prjection information
+
+
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(startdate)) = startdate
+      convention(1:32) = "CF-1.0"
+      iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",6, convention)
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate)) 
+
+      iret = nf_enddef(ncid)
+
+      iret = nf_inq_varid(ncid,"time", varid)
+      iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since)
+
+!!-- write latitude and longitude locations
+
+!DJG inv    do j=jxrt,1,-1
+    do j=1,jxrt
+     do i=1,ixrt
+       if(CH_NETLNK(i,j).GE.0) then
+         tmpflow(i,j) = qlink(CH_NETLNK(i,j),1) 
+       else
+         tmpflow(i,j) = -9E15
+       endif
+     enddo
+    enddo
+
+!!time in seconds since startdate
+    iret = nf_inq_varid(ncid,"index", varid)
+    iret = nf_put_vara_int(ncid, varid, (/1,1/), (/ixrt,jxrt/),CH_NETLNK)
+
+    iret = nf_inq_varid(ncid,"streamflow", varid)
+    iret = nf_put_vara_real(ncid, varid, (/1,1,1/), (/ixrt,jxrt,1/),tmpflow)
+
+        iret = nf_close(ncid)
+
+
+
+ end subroutine output_chrtgrd
+
+
+ subroutine read_chan_forcing( &
+       indir,olddate,startdate,hgrid,&
+       ixrt,jxrt,QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT)
+! This subrouting is going to read channel forcing for
+!  channel only simulations (ie when CHANRTSWCRT = 2)
+
+   implicit none
+#include 
+   ! in variable
+   character(len=*) :: olddate,hgrid,indir,startdate
+   character(len=256) :: filename
+   integer :: ixrt,jxrt
+   real,dimension(ixrt,jxrt):: QSTRMVOLRT_ACC,QINFLOWBASE,QSUBRT
+   ! tmp variable
+   character(len=256) :: inflnm, product
+   integer  :: i,j,mmflag
+   character(len=256) :: units
+   integer :: ierr
+   integer :: ncid
+
+
+!DJG Create filename...
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             olddate(15:16)//".RTOUT_DOMAIN"//hgrid
+#ifdef HYDRO_D
+        print *, "Channel forcing file...",inflnm
+#endif
+
+
+!DJG Open NetCDF file...
+    ierr = nf_open(inflnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+       write(*,'("READFORC_chan Problem opening netcdf file: ''", A, "''")') trim(inflnm)
+       call hydro_stop("In read_chan_forcing() - Problem opening netcdf file")
+    endif
+
+!DJG read data...
+    call get_2d_netcdf("QSTRMVOLRT",  ncid, QSTRMVOLRT_ACC, units, ixrt, jxrt, .TRUE., ierr)
+!DJG TBC    call get_2d_netcdf("T2D", ncid, t,     units, ixrt, jxrt, .TRUE., ierr)
+!DJG TBC    call get_2d_netcdf("T2D", ncid, t,     units, ixrt, jxrt, .TRUE., ierr)
+
+    ierr = nf_close(ncid)
+
+ end subroutine read_chan_forcing
+
+
+
+ subroutine get2d_int(var_name,out_buff,ix,jx,fileName, fatalErr)
+    implicit none
+#include 
+    integer :: iret,varid,ncid,ix,jx
+    integer out_buff(ix,jx)
+    character(len=*), intent(in) :: var_name
+    character(len=*), intent(in) :: fileName
+    logical, optional, intent(in) :: fatalErr
+    logical :: fatalErr_local
+    character(len=256) :: errMsg
+
+    fatalErr_local = .false.
+    if(present(fatalErr)) fatalErr_local=fatalErr
+    
+    iret = nf_open(trim(fileName), NF_NOWRITE, ncid)
+    if (iret .ne. 0) then
+       errMsg = "get2d_int: failed to open the netcdf file: " // trim(fileName)
+       print*, trim(errMsg)
+       if(fatalErr_local) call hydro_stop(trim(errMsg))
+    endif
+    
+    iret = nf_inq_varid(ncid,trim(var_name),  varid)
+    if(iret .ne. 0) then
+       errMsg = "get2d_int: failed to find the variable: " // &
+                 trim(var_name) // ' in ' // trim(fileName)
+       print*, trim(errMsg)
+       if(fatalErr_local) call hydro_stop(errMsg)
+    endif
+    
+    iret = nf_get_var_int(ncid, varid, out_buff)
+    if(iret .ne. 0) then
+       errMsg = "get2d_int: failed to read the variable: " // &
+                trim(var_name) // " in " //trim(fileName)
+       print*,trim(errMsg)
+       if(fatalErr_local) call hydro_stop(trim(errMsg))
+    endif
+    
+    iret = nf_close(ncid)
+    if(iret .ne. 0) then
+       errMsg = "get2d_int: failed to close the file: " // &
+                trim(fileName)
+       print*,trim(errMsg)
+       if(fatalErr_local) call hydro_stop(trim(errMsg))
+    endif
+    
+    return
+  end subroutine get2d_int
+
+
+#ifdef MPP_LAND
+      SUBROUTINE MPP_READ_ROUTEDIM(did,g_IXRT,g_JXRT, GCH_NETLNK,GNLINKS,IXRT,JXRT, &
+            route_chan_f,route_link_f, &
+            route_direction_f, NLINKS, &
+            CH_NETLNK, channel_option, geo_finegrid_flnm, NLINKSL, UDMP_OPT)
+
+         USE module_mpp_land
+
+         implicit none
+#include 
+        INTEGER                                      :: channel_option, did
+        INTEGER                                      :: g_IXRT,g_JXRT
+        INTEGER, INTENT(INOUT)                       :: NLINKS, GNLINKS,NLINKSL
+        INTEGER, INTENT(IN)                          :: IXRT,JXRT
+        INTEGER                                      :: CHNID,cnt
+        INTEGER, DIMENSION(IXRT,JXRT)                :: CH_NETRT   !- binary channel mask
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETLNK  !- each node gets unique id
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: GCH_NETLNK  !- each node gets unique id based on global domain
+        ! INTEGER, DIMENSION(g_IXRT,g_JXRT) :: g_CH_NETLNK  ! temp array
+        INTEGER, allocatable,DIMENSION(:,:) :: g_CH_NETLNK  ! temp array
+        INTEGER, DIMENSION(IXRT,JXRT)                :: DIRECTION  !- flow direction
+        INTEGER, DIMENSION(IXRT,JXRT)                :: LAKE_MSKRT
+        REAL, DIMENSION(IXRT,JXRT)                   :: LAT, LON
+        INTEGER, INTENT(IN)                          :: UDMP_OPT
+        integer:: i,j
+
+        CHARACTER(len=256)       :: route_chan_f, route_link_f,route_direction_f
+        CHARACTER(len=256)       :: geo_finegrid_flnm
+!       CHARACTER(len=*)       :: geo_finegrid_flnm
+
+!       integer, allocatable, dimension(:) :: tmp_int
+        integer :: ywcount
+
+
+
+        if(my_id .eq. IO_id) then
+           allocate(g_CH_NETLNK(g_IXRT,g_JXRT))
+           g_CH_NETLNK = -9999
+           CALL READ_ROUTEDIM(g_IXRT, g_JXRT, route_chan_f, route_link_f, &
+              route_direction_f, GNLINKS, &
+              g_CH_NETLNK, channel_option,geo_finegrid_flnm,NLINKSL, UDMP_OPT)
+           call get_NLINKSL(NLINKSL, channel_option, route_link_f)
+        else
+           allocate(g_CH_NETLNK(1,1))
+        endif
+
+        call mpp_land_bcast_int1(GNLINKS)
+        call mpp_land_bcast_int1(NLINKSL)
+
+
+        call decompose_RT_int(g_CH_NETLNK,GCH_NETLNK,g_IXRT,g_JXRT,ixrt,jxrt)
+        if(allocated(g_CH_NETLNK)) deallocate(g_CH_NETLNK)
+        ywcount = 0 
+        CH_NETLNK = -9999
+        do j = 1, jxrt
+           do i = 1, ixrt
+                  if(GCH_NETLNK(i,j) .gt. 0) then
+                       ywcount = ywcount + 1
+                       CH_NETLNK(i,j) = ywcount
+                  endif
+           end do
+        end do
+        NLINKS = ywcount
+
+
+!ywcheck
+!        CH_NETLNK = GCH_NETLNK
+
+
+        allocate(rt_domain(did)%map_l2g(NLINKS))
+
+        rt_domain(did)%map_l2g = -1
+        do j = 1, jxrt
+           do i = 1, ixrt
+              if(CH_NETLNK(i,j) .gt. 0) then
+                  rt_domain(did)%map_l2g(CH_NETLNK(i,j)) = GCH_NETLNK(i,j)
+              endif
+           end do       
+        end do       
+
+        call mpp_chrt_nlinks_collect(NLINKS)
+        return 
+
+      end SUBROUTINE MPP_READ_ROUTEDIM
+
+
+
+
+#endif
+        
+      SUBROUTINE READ_ROUTING_seq(IXRT,JXRT,ELRT,CH_NETRT,CH_LNKRT,LKSATFAC,route_topo_f,    &
+            route_chan_f, geo_finegrid_flnm,OVROUGHRTFAC,RETDEPRTFAC,channel_option, UDMP_OPT)
+
+
+#include 
+        INTEGER, INTENT(IN) :: IXRT,JXRT
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: ELRT,LKSATFAC
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: CH_NETRT,CH_LNKRT
+!Dummy inverted grids
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: OVROUGHRTFAC
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: RETDEPRTFAC
+
+        integer         :: I,J, iret, jj, channel_option, UDMP_OPT
+        CHARACTER(len=256)        :: var_name
+        CHARACTER(len=*)       :: route_topo_f
+        CHARACTER(len=*)       :: route_chan_f
+        CHARACTER(len=*)       :: geo_finegrid_flnm
+
+        var_name = "TOPOGRAPHY"
+
+        call nreadRT2d_real(var_name,ELRT,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+
+     IF(channel_option .ne. 3 .and. UDMP_OPT .ne. 1) then  !get maxnodes and links from grid
+        var_name = "LINKID"
+        call nreadRT2d_int(var_name,CH_LNKRT,ixrt,jxrt,&
+               trim(geo_finegrid_flnm), fatalErr=.true.)
+     endif
+
+
+       
+#ifdef HYDRO_D
+        write(6,*) "read linkid grid CH_LNKRT ",var_name
+#endif
+
+!!!DY to be fixed ... 6/27/08
+!        var_name = "BED_ELEVATION"
+!        iret = get2d_real(var_name,ELRT,ixrt,jxrt,&
+!                     trim(geo_finegrid_flnm))
+
+        var_name = "CHANNELGRID"
+        call nreadRT2d_int(var_name,CH_NETRT,ixrt,jxrt,&
+               trim(geo_finegrid_flnm))
+
+#ifdef HYDRO_D
+        write(6,*) "read ",var_name
+#endif
+
+        var_name = "LKSATFAC"
+        LKSATFAC = -9999.9
+        call nreadRT2d_real(var_name,LKSATFAC,ixrt,jxrt,&
+               trim(geo_finegrid_flnm))
+
+#ifdef HYDRO_D
+        write(6,*) "read ",var_name
+#endif
+
+           where (LKSATFAC == -9999.9) LKSATFAC = 1000.0  !specify LKSAFAC if no term avail...
+
+
+!1.12.2012...Read in routing calibration factors...
+        var_name = "RETDEPRTFAC"
+        call nreadRT2d_real(var_name,RETDEPRTFAC,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+        where (RETDEPRTFAC < 0.) RETDEPRTFAC = 1.0  ! reset grid to = 1.0 if non-valid value exists
+
+        var_name = "OVROUGHRTFAC"
+        call nreadRT2d_real(var_name,OVROUGHRTFAC,ixrt,jxrt,&
+                     trim(geo_finegrid_flnm))
+        where (OVROUGHRTFAC <= 0.) OVROUGHRTFAC = 1.0 ! reset grid to = 1.0 if non-valid value exists
+
+
+#ifdef HYDRO_D
+        write(6,*) "finish READ_ROUTING_seq"
+#endif
+
+        return
+
+!DJG -----------------------------------------------------
+   END SUBROUTINE READ_ROUTING_seq
+
+!DJG _____________________________
+   subroutine output_lsm(outFile,did)
+
+
+   implicit none
+
+   integer did
+
+   character(len=*) outFile
+
+    integer :: ncid,irt, dimid_ix, dimid_jx,  &
+             dimid_ixrt, dimid_jxrt, varid, &
+             dimid_links, dimid_basns, dimid_soil
+    integer :: iret, n
+    character(len=2) tmpStr 
+
+
+
+#ifdef MPP_LAND
+     if(IO_id.eq.my_id) &
+#endif
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(outFile), NF_CLOBBER, ncid)
+#else
+       iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+
+#ifdef MPP_LAND
+       call mpp_land_bcast_int1(iret)
+#endif
+
+       if (iret /= 0) then
+          call hydro_stop("In output_lsm() - Problem nf_create")
+       endif
+
+
+#ifdef MPP_LAND
+     if(IO_id.eq.my_id) then
+#endif
+#ifdef HYDRO_D
+         write(6,*) "output file ", outFile
+#endif
+! define dimension for variables 
+          iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil)  !-- 3-d soils
+   
+#ifdef MPP_LAND
+          iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx)
+#else
+          iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx)
+#endif
+    
+!define variables
+          do n = 1, nlst_rt(did)%nsoil
+             if( n .lt. 10) then
+                write(tmpStr, '(i1)') n
+             else
+                write(tmpStr, '(i2)') n
+             endif
+             iret = nf_def_var(ncid,"stc"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+             iret = nf_def_var(ncid,"smc"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+             iret = nf_def_var(ncid,"sh2ox"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          end do
+
+          iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+
+          iret = nf_enddef(ncid)
+
+#ifdef MPP_LAND
+    endif
+#endif
+        call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc")
+        call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc")
+        call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
+        call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") 
+        call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" )
+        call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1"  ) 
+        call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt"  ) 
+        call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SFCHEADRT,"sfcheadrt" )
+
+
+#ifdef MPP_LAND
+     if(IO_id.eq.my_id) then
+#endif
+
+        iret = nf_close(ncid)
+#ifdef HYDRO_D
+        write(6,*) "finish writing outFile : ", outFile
+#endif
+
+#ifdef MPP_LAND
+    endif
+#endif
+
+        return
+        end subroutine output_lsm
+
+
+   subroutine RESTART_OUT_nc(outFile,did)
+
+
+   implicit none
+
+   integer did
+   integer :: n
+   character(len=2) :: tmpStr
+   character(len=*) outFile
+
+    integer :: ncid,irt, dimid_ix, dimid_jx,  &
+             dimid_ixrt, dimid_jxrt, varid, &
+             dimid_links, dimid_basns, dimid_soil, dimid_lakes
+    integer :: iret
+
+
+#ifdef MPP_LAND
+     if(IO_id.eq.my_id) &
+#endif
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(outFile), NF_CLOBBER, ncid)
+#ifdef HYDRO_D
+       write(6,*) "yyywww do not use large netcdf file definition. "
+       call flush(6)
+#endif
+#else
+       iret = nf_create(trim(outFile), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#ifdef HYDRO_D
+       write(6,*) "yyywww using large netcdf file definition. "
+       call flush(6)
+#endif
+#endif
+
+
+#ifdef MPP_LAND
+       call mpp_land_bcast_int1(iret)
+#endif
+
+       if (iret /= 0) then
+          call hydro_stop("In RESTART_OUT_nc() - Problem nf_create")
+       endif
+
+#ifdef MPP_LAND
+     if(IO_id.eq.my_id) then
+#endif
+! define dimension for variables 
+          iret = nf_def_dim(ncid, "depth", nlst_rt(did)%nsoil, dimid_soil)  !-- 3-d soils
+   
+#ifdef MPP_LAND
+          iret = nf_def_dim(ncid, "ix", global_nx, dimid_ix)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iy", global_ny, dimid_jx)
+          iret = nf_def_dim(ncid, "ixrt", global_rt_nx , dimid_ixrt)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iyrt", global_rt_ny, dimid_jxrt)
+#else
+          iret = nf_def_dim(ncid, "ix", rt_domain(did)%ix, dimid_ix)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iy", rt_domain(did)%jx, dimid_jx)
+          iret = nf_def_dim(ncid, "ixrt", rt_domain(did)%ixrt , dimid_ixrt)  !-- make a decimated grid
+          iret = nf_def_dim(ncid, "iyrt", rt_domain(did)%jxrt, dimid_jxrt)
+#endif
+
+          if(nlst_rt(did)%channel_option .eq. 3) then
+              iret = nf_def_dim(ncid, "links", rt_domain(did)%gnlinks, dimid_links)
+           else
+              iret = nf_def_dim(ncid, "links", rt_domain(did)%gnlinksl, dimid_links)
+           endif
+           iret = nf_def_dim(ncid, "basns", rt_domain(did)%gnumbasns, dimid_basns)
+           if(rt_domain(did)%nlakes .gt. 0) then
+                  iret = nf_def_dim(ncid, "lakes", rt_domain(did)%nlakes, dimid_lakes)
+           endif
+
+!define variables
+          do n = 1, nlst_rt(did)%nsoil
+             if( n .lt. 10) then
+                write(tmpStr, '(i1)') n
+             else
+                write(tmpStr, '(i2)') n
+             endif
+             iret = nf_def_var(ncid,"stc"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+             iret = nf_def_var(ncid,"smc"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+             iret = nf_def_var(ncid,"sh2ox"//trim(tmpStr),NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          end do
+    
+          iret = nf_def_var(ncid,"smcmax1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"smcref1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"smcwlt1",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"infxsrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"soldrain",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+          iret = nf_def_var(ncid,"sfcheadrt",NF_FLOAT,2,(/dimid_ix,dimid_jx/),varid)
+
+          if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then
+            iret = nf_def_var(ncid,"QBDRYRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+            iret = nf_def_var(ncid,"infxswgt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+            iret = nf_def_var(ncid,"sfcheadsubrt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+          do n = 1, nlst_rt(did)%nsoil
+             if( n .lt. 10) then
+                write(tmpStr, '(i1)') n
+             else
+                write(tmpStr, '(i2)') n
+             endif
+             iret = nf_def_var(ncid,"sh2owgt"//trim(tmpStr),NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+          end do
+            iret = nf_def_var(ncid,"qstrmvolrt",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+            iret = nf_def_var(ncid,"RETDEPRT",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+
+
+
+
+
+
+            if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then
+              iret = nf_def_var(ncid,"hlink",NF_FLOAT,1,(/dimid_links/),varid)
+              iret = nf_def_var(ncid,"qlink1",NF_FLOAT,1,(/dimid_links/),varid)
+              iret = nf_def_var(ncid,"qlink2",NF_FLOAT,1,(/dimid_links/),varid)
+              iret = nf_def_var(ncid,"cvol",NF_FLOAT,1,(/dimid_links/),varid)
+              if(rt_domain(did)%nlakes .gt. 0) then
+                  iret = nf_def_var(ncid,"resht",NF_FLOAT,1,(/dimid_lakes/),varid)
+                  iret = nf_def_var(ncid,"qlakeo",NF_FLOAT,1,(/dimid_lakes/),varid)
+              endif
+              iret = nf_def_var(ncid,"lake_inflort",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+              if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+                     iret = nf_def_var(ncid,"accLndRunOff",NF_FLOAT,1,(/dimid_links/),varid)
+                     iret = nf_def_var(ncid,"accQLateral",NF_FLOAT,1,(/dimid_links/),varid)
+                     iret = nf_def_var(ncid,"accStrmvolrt",NF_FLOAT,1,(/dimid_links/),varid)
+                     iret = nf_def_var(ncid,"accBucket",NF_FLOAT,1,(/dimid_links/),varid)
+              endif
+            end if
+            if(nlst_rt(did)%GWBASESWCRT.EQ.1) then
+
+                 if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+                     iret = nf_def_var(ncid,"z_gwsubbas",NF_FLOAT,1,(/dimid_links/),varid)
+                 else
+                     iret = nf_def_var(ncid,"z_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid)
+                 endif
+
+!yw test bucket model
+!             iret = nf_def_var(ncid,"gwbas_pix_ct",NF_FLOAT,1,(/dimid_basns/),varid)
+!             iret = nf_def_var(ncid,"gw_buck_exp",NF_FLOAT,1,(/dimid_basns/),varid)
+!             iret = nf_def_var(ncid,"z_max",NF_FLOAT,1,(/dimid_basns/),varid)
+!             iret = nf_def_var(ncid,"gw_buck_coeff",NF_FLOAT,1,(/dimid_basns/),varid)
+!             iret = nf_def_var(ncid,"qin_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid)
+!             iret = nf_def_var(ncid,"qinflowbase",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+!             iret = nf_def_var(ncid,"qout_gwsubbas",NF_FLOAT,1,(/dimid_basns/),varid)
+            end if
+            if(nlst_rt(did)%gwBaseSwCRT .eq. 3)then
+            iret = nf_def_var(ncid,"HEAD",NF_FLOAT,2,(/dimid_ixrt,dimid_jxrt/),varid)
+            end if  
+	  end if    
+	      
+!         put global attribute
+          iret = nf_put_att_int(ncid,NF_GLOBAL,"his_out_counts",NF_INT, 1,rt_domain(did)%his_out_counts)
+          iret = nf_put_att_text(ncid,NF_GLOBAL,"Restart_Time",19,nlst_rt(did)%olddate(1:19))
+          iret = nf_put_att_text(ncid,NF_GLOBAL,"Since_Date",19,nlst_rt(did)%sincedate(1:19))
+          iret = nf_put_att_real(ncid,NF_GLOBAL,"DTCT",NF_REAL, 1,nlst_rt(did)%DTCT)
+          iret = nf_enddef(ncid)
+
+#ifdef MPP_LAND
+    endif
+#endif
+        call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc")
+        call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc")
+        call w_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
+
+
+       call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1") 
+       call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1" )
+       call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1"  ) 
+       call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt"  ) 
+       call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain"  ) 
+       call w_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt"  ) 
+
+
+        if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then
+            call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT, "QBDRYRT" )
+            call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT, "infxswgt" )
+            call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT, "SFCHEADSUBRT" )
+            call w_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT, "sh2owgt" )
+            call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT, "qstrmvolrt" )
+            call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT, "RETDEPRT" )
+
+!yw test
+
+
+!yw test
+
+
+            if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then
+              if(nlst_rt(did)%channel_option .eq. 3) then
+                    call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%HLINK,"hlink" &
+#ifdef MPP_LAND
+                            ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
+#endif
+                          )
+              else
+                    call w_rst_crt_reach(ncid,rt_domain(did)%HLINK, "hlink"  &
+#ifdef MPP_LAND
+                            ,rt_domain(did)%gnlinksl&
+#endif
+                          )
+              endif
+
+              if(nlst_rt(did)%channel_option .eq. 3) then
+                     call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,1),"qlink1" &
+#ifdef MPP_LAND
+                        ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
+#endif
+                         )
+              else
+                    call w_rst_crt_reach(ncid,rt_domain(did)%QLINK(:,1), "qlink1"  &
+#ifdef MPP_LAND   
+                            ,rt_domain(did)%gnlinksl &
+#endif
+                          )
+              endif
+
+
+
+              if(nlst_rt(did)%channel_option .eq. 3) then
+                    call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%QLINK(:,2),"qlink2" &
+#ifdef MPP_LAND
+                       ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
+#endif
+                        )
+              else
+                    call w_rst_crt_reach(ncid,rt_domain(did)%QLINK(:,2), "qlink2"  &
+#ifdef MPP_LAND   
+                            ,rt_domain(did)%gnlinksl &
+#endif
+                          )
+                    if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+                        call w_rst_crt_reach(ncid,rt_domain(did)%accLndRunOff, "accLndRunOff"  &
+#ifdef MPP_LAND   
+                                ,rt_domain(did)%gnlinksl &
+#endif
+                              )
+                        call w_rst_crt_reach(ncid,rt_domain(did)%accQLateral, "accQLateral"  &
+#ifdef MPP_LAND   
+                                ,rt_domain(did)%gnlinksl &
+#endif
+                              )
+                        call w_rst_crt_reach(ncid,rt_domain(did)%accStrmvolrt, "accStrmvolrt"  &
+#ifdef MPP_LAND   
+                                ,rt_domain(did)%gnlinksl &
+#endif
+                              )
+                        call w_rst_crt_reach(ncid,rt_domain(did)%accBucket, "accBucket"  &
+#ifdef MPP_LAND   
+                                ,rt_domain(did)%gnlinksl &
+#endif
+                              )
+                    endif   ! end if of UDMP_OPT .eq. 1
+              endif
+
+              
+
+
+              if(nlst_rt(did)%channel_option .eq. 3) then
+                     call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%cvol,"cvol" &
+#ifdef MPP_LAND
+                        ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
+#endif
+                         )
+              else
+                    call w_rst_crt_reach(ncid,rt_domain(did)%cvol, "cvol"  &
+#ifdef MPP_LAND   
+                            ,rt_domain(did)%gnlinksl &
+#endif
+                          )
+              endif
+
+
+!              call w_rst_crt_nc1(ncid,rt_domain(did)%nlinks,rt_domain(did)%resht,"resht" &
+!#ifdef MPP_LAND
+!                 ,rt_domain(did)%map_l2g, rt_domain(did)%gnlinks  &
+!#endif
+!                  )
+
+
+              call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%resht,"resht" &
+#ifdef MPP_LAND
+                 ,rt_domain(did)%lake_index  &
+#endif
+                  )
+
+              call w_rst_crt_nc1_lake(ncid,rt_domain(did)%nlakes,rt_domain(did)%qlakeo,"qlakeo" &
+#ifdef MPP_LAND
+                 ,rt_domain(did)%lake_index  &
+#endif
+                  )
+
+
+              call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort")
+
+            end if
+
+
+            if(nlst_rt(did)%GWBASESWCRT.EQ.1) then
+!              call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,"z_gwsubbas" )
+              if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+
+                    call w_rst_crt_reach(ncid,rt_domain(did)%z_gwsubbas, "z_gwsubbas"  &
+#ifdef MPP_LAND   
+                            ,rt_domain(did)%gnlinksl  &
+#endif
+                          )
+              else
+                  call w_rst_gwbucket_real(ncid,rt_domain(did)%numbasns,rt_domain(did)%gnumbasns, &
+                       rt_domain(did)%basnsInd, rt_domain(did)%z_gwsubbas,"z_gwsubbas" )
+              endif
+!yw test bucket model
+!             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gwbas_pix_ct,"gwbas_pix_ct" )
+!             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_exp,"gw_buck_exp" )
+!             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%z_max,"z_max" )
+!             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%gw_buck_coeff,"gw_buck_coeff" )
+!             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,"qin_gwsubbas" )
+!             call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%qinflowbase,"qinflowbase")
+!             call w_rst_crt_nc1g(ncid,rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,"qout_gwsubbas" )
+            end if
+            if(nlst_rt(did)%GWBASESWCRT.EQ.3) then
+	      call w_rst_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,gw2d(did)%ho, "HEAD" )
+            end if
+        end if  
+
+#ifdef MPP_LAND
+        if(IO_id.eq.my_id) &
+#endif
+        iret = nf_close(ncid)
+
+        return
+        end subroutine RESTART_OUT_nc
+
+#ifdef MPP_LAND
+
+   subroutine RESTART_OUT_bi(outFile,did)
+
+
+   implicit none
+
+   integer did
+
+   character(len=*) outFile
+
+    integer :: iunit
+    integer  :: i0,ie, i, istep, mkdirStatus
+    
+
+    call mpp_land_sync()
+
+    iunit = 81
+ istep = 64
+ i0 = 0
+ ie = istep
+ do i = 0, numprocs,istep 
+   if(my_id .ge. i0 .and. my_id .lt. ie) then
+     open(iunit, file = "restart/"//trim(outFile), form="unformatted",ERR=101, access="sequential")
+          write(iunit,ERR=101) rt_domain(did)%his_out_counts
+!         write(iunit,ERR=101) nlst_rt(did)%olddate(1:19)
+          write(iunit,ERR=101) nlst_rt(did)%sincedate(1:19)
+!         write(iunit,ERR=101) nlst_rt(did)%DTCT 
+          write(iunit,ERR=101) rt_domain(did)%stc
+          write(iunit,ERR=101) rt_domain(did)%smc
+          write(iunit,ERR=101) rt_domain(did)%sh2ox
+          write(iunit,ERR=101) rt_domain(did)%SMCMAX1
+          write(iunit,ERR=101) rt_domain(did)%SMCREF1
+          write(iunit,ERR=101) rt_domain(did)%SMCWLT1
+          write(iunit,ERR=101) rt_domain(did)%INFXSRT
+          write(iunit,ERR=101) rt_domain(did)%soldrain
+          write(iunit,ERR=101) rt_domain(did)%sfcheadrt
+
+          if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then
+                if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then
+                   write(iunit,ERR=101) rt_domain(did)%HLINK
+                   write(iunit,ERR=101) rt_domain(did)%QLINK(:,1)
+                   write(iunit,ERR=101) rt_domain(did)%QLINK(:,2)
+                   write(iunit,ERR=101) rt_domain(did)%cvol
+                   write(iunit,ERR=101) rt_domain(did)%resht
+                   write(iunit,ERR=101) rt_domain(did)%qlakeo
+                   write(iunit,ERR=101) rt_domain(did)%LAKE_INFLORT
+                end if
+                if(nlst_rt(did)%GWBASESWCRT.EQ.1) then
+                     write(iunit,ERR=101) rt_domain(did)%z_gwsubbas
+                end if
+                if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1) then
+                    write(iunit,ERR=101) rt_domain(did)%QBDRYRT
+                    write(iunit,ERR=101) rt_domain(did)%INFXSWGT
+                    write(iunit,ERR=101) rt_domain(did)%SFCHEADSUBRT
+                    write(iunit,ERR=101) rt_domain(did)%SH2OWGT
+                    write(iunit,ERR=101) rt_domain(did)%QSTRMVOLRT
+                    write(iunit,ERR=101) rt_domain(did)%RETDEPRT
+                endif
+          end if  
+
+        close(iunit)
+    endif
+    call mpp_land_sync()
+    i0 = i0 + istep
+    ie = ie + istep
+  end do ! end do of i loop
+
+        return
+101     continue
+        call hydro_stop("FATAL ERROR: failed to output the hydro restart file.")
+        end subroutine RESTART_OUT_bi
+
+   subroutine RESTART_in_bi(inFileTmp,did)
+
+
+   implicit none
+
+   integer did
+
+   character(len=*) inFileTmp
+   character(len=256) inFile
+   character(len=19) str_tmp
+
+    integer :: iunit
+    logical :: fexist
+    integer  :: i0,ie, i, istep
+
+    iunit = 81
+
+             if(my_id .lt. 10) then
+                write(str_tmp,'(I1)') my_id
+             else if(my_id .lt. 100) then
+                write(str_tmp,'(I2)') my_id
+             else if(my_id .lt. 1000) then
+                write(str_tmp,'(I3)') my_id
+             else if(my_id .lt. 10000) then
+                write(str_tmp,'(I4)') my_id
+             else if(my_id .lt. 100000) then
+                write(str_tmp,'(I5)') my_id
+             endif
+
+    inFile = trim(inFileTmp)//"."//str_tmp 
+
+    inquire (file=trim(inFile), exist=fexist)
+    if(.not. fexist) then
+        call hydro_stop("In RESTART_in_bi()- Could not find restart file "//trim(inFile))
+    endif
+
+ istep = 64
+ i0 = 0
+ ie = istep
+ do i = 0, numprocs,istep 
+   if(my_id .ge. i0 .and. my_id .lt. ie) then
+    open(iunit, file = inFile, form="unformatted",ERR=101,access="sequential")
+          read(iunit,ERR=101) rt_domain(did)%his_out_counts
+!         read(iunit,ERR=101) nlst_rt(did)%olddate(1:19)
+          read(iunit,ERR=101) nlst_rt(did)%sincedate(1:19)
+!         read(iunit,ERR=101) nlst_rt(did)%DTCT 
+          read(iunit,ERR=101) rt_domain(did)%stc
+          read(iunit,ERR=101) rt_domain(did)%smc
+          read(iunit,ERR=101) rt_domain(did)%sh2ox
+          read(iunit,ERR=101) rt_domain(did)%SMCMAX1
+          read(iunit,ERR=101) rt_domain(did)%SMCREF1
+          read(iunit,ERR=101) rt_domain(did)%SMCWLT1
+          read(iunit,ERR=101) rt_domain(did)%INFXSRT
+          read(iunit,ERR=101) rt_domain(did)%soldrain
+          read(iunit,ERR=101) rt_domain(did)%sfcheadrt
+          if(nlst_rt(did)%SUBRTSWCRT.EQ.0.and.nlst_rt(did)%OVRTSWCRT.EQ.0) rt_domain(did)%sfcheadrt = 0
+
+          if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then
+                if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then
+                   read(iunit,ERR=101) rt_domain(did)%HLINK
+                   read(iunit,ERR=101) rt_domain(did)%QLINK(:,1)
+                   read(iunit,ERR=101) rt_domain(did)%QLINK(:,2)
+                   read(iunit,ERR=101) rt_domain(did)%cvol
+                   read(iunit,ERR=101) rt_domain(did)%resht
+                   read(iunit,ERR=101) rt_domain(did)%qlakeo
+                   read(iunit,ERR=101) rt_domain(did)%LAKE_INFLORT
+                end if
+                if(nlst_rt(did)%GWBASESWCRT.EQ.1) then
+                     read(iunit,ERR=101) rt_domain(did)%z_gwsubbas
+                end if
+                if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1) then
+                   read(iunit,ERR=101) rt_domain(did)%QBDRYRT
+                   read(iunit,ERR=101) rt_domain(did)%INFXSWGT
+                   read(iunit,ERR=101) rt_domain(did)%SFCHEADSUBRT
+                   read(iunit,ERR=101) rt_domain(did)%SH2OWGT
+                   read(iunit,ERR=101) rt_domain(did)%QSTRMVOLRT
+                   !read(iunit,ERR=101) rt_domain(did)%RETDEPRT
+                endif
+          end if  
+
+        close(iunit)
+    endif
+    call mpp_land_sync()
+    i0 = i0 + istep
+    ie = ie + istep
+  end do ! end do of i loop
+
+        return
+101     continue
+        call hydro_stop("In RESTART_in_bi() - failed to read the hydro restart file "//trim(inFile))
+        end subroutine RESTART_in_bi
+#endif
+
+        subroutine w_rst_rt_nc2(ncid,ix,jx,inVar,varName)
+           implicit none
+           integer:: ncid,ix,jx,varid , iret
+           character(len=*) varName
+           real, dimension(ix,jx):: inVar
+#ifdef MPP_LAND
+           real, allocatable, dimension(:,:) :: varTmp 
+           if(my_id .eq. io_id ) then
+               allocate(varTmp(global_rt_nx, global_rt_ny))
+           else
+               allocate(varTmp(1,1))
+           endif
+           call write_IO_rt_real(inVar,varTmp) 
+           if(my_id .eq. IO_id) then
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_rt_nx,global_rt_ny/),varTmp)
+           endif
+           if(allocated(varTmp))  deallocate(varTmp)
+#else
+           iret = nf_inq_varid(ncid,varName, varid)
+           if(iret .eq. 0) then
+              iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),inVar)
+           else
+              write(6,*) "Error : variable not defined in rst file before write: ", varName
+           endif
+#endif
+           
+           return
+        end subroutine w_rst_rt_nc2
+
+        subroutine w_rst_rt_nc3(ncid,ix,jx,NSOIL,inVar, varName)
+           implicit none
+           integer:: ncid,ix,jx,varid , iret, nsoil
+           character(len=*) varName
+           real,dimension(ix,jx,nsoil):: inVar
+           character(len=2) tmpStr
+           integer k
+#ifdef MPP_LAND
+           real varTmp(global_rt_nx,global_rt_ny)
+           do k = 1, nsoil
+              call write_IO_rt_real(inVar(:,:,k),varTmp(:,:)) 
+              if(my_id .eq. IO_id) then
+                 if( k .lt. 10) then
+                    write(tmpStr, '(i1)') k
+                 else
+                    write(tmpStr, '(i2)') k
+                 endif
+                 iret = nf_inq_varid(ncid,varName//trim(tmpStr), varid)
+                 iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_rt_nx,global_rt_ny/),varTmp)
+              endif
+           end do
+#else
+           do k = 1, nsoil
+                 if( k .lt. 10) then
+                    write(tmpStr, '(i1)') k
+                 else
+                    write(tmpStr, '(i2)') k
+                 endif
+              iret = nf_inq_varid(ncid,varName//trim(tmpStr), varid)
+              iret = nf_put_vara_real(ncid, varid, (/1,1/),(/ix,jx/),inVar(:,:,k)) 
+           end do 
+#endif
+           return
+        end subroutine w_rst_rt_nc3
+
+        subroutine w_rst_nc2(ncid,ix,jx,inVar,varName)
+           implicit none
+           integer:: ncid,ix,jx,varid , iret
+           character(len=*) varName
+           real inVar(ix,jx)
+
+#ifdef MPP_LAND
+           real varTmp(global_nx,global_ny)
+           call write_IO_real(inVar,varTmp) 
+           if(my_id .eq. IO_id) then
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_nx,global_ny/),varTmp)
+           endif
+#else
+           iret = nf_inq_varid(ncid,varName, varid)
+           iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),invar)
+#endif
+           
+           return
+        end subroutine w_rst_nc2
+
+        subroutine w_rst_nc3(ncid,ix,jx,NSOIL,inVar, varName)
+           implicit none
+           integer:: ncid,ix,jx,varid , iret, nsoil
+           character(len=*) varName
+           real inVar(ix,jx,nsoil)
+           integer k
+           character(len=2) tmpStr
+           
+#ifdef MPP_LAND
+           real varTmp(global_nx,global_ny)
+           do k = 1, nsoil
+              call write_IO_real(inVar(:,:,k),varTmp(:,:)) 
+              if(my_id .eq. IO_id) then
+                 if( k .lt. 10) then
+                    write(tmpStr, '(i1)') k
+                 else
+                    write(tmpStr, '(i2)') k
+                 endif
+                iret = nf_inq_varid(ncid,varName//trim(tmpStr), varid)
+                iret = nf_put_vara_real(ncid, varid, (/1,1/), (/global_nx,global_ny/),varTmp)
+              endif
+           end do
+#else
+           do k = 1, nsoil
+                 if( k .lt. 10) then
+                    write(tmpStr, '(i1)') k
+                 else
+                    write(tmpStr, '(i2)') k
+                 endif
+             iret = nf_inq_varid(ncid,varName//trim(tmpStr), varid)
+             iret = nf_put_vara_real(ncid, varid, (/1,1/), (/ix,jx/),inVar(:,:,k))
+           end do 
+#endif
+           return
+        end subroutine w_rst_nc3
+
+        subroutine w_rst_crt_nc1_lake(ncid,n,inVar,varName &
+#ifdef MPP_LAND
+                 ,nodelist     &
+#endif
+                  )
+           implicit none
+           integer:: ncid,n,varid , iret
+           character(len=*) varName
+           real inVar(n)
+#ifdef MPP_LAND
+           integer:: nodelist(n)
+           if(n .eq. 0) return
+
+           call write_lake_real(inVar,nodelist,n)          
+           if(my_id .eq. IO_id) then
+#endif
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar)
+#ifdef MPP_LAND
+           endif
+#endif
+           return
+        end subroutine w_rst_crt_nc1_lake
+
+        subroutine w_rst_crt_reach(ncid,inVar,varName &
+#ifdef MPP_LAND
+                 , gnlinksl&
+#endif
+                  )
+           implicit none
+           integer:: ncid,varid , iret, n   
+           character(len=*) varName
+           real, dimension(:) :: inVar
+    
+#ifdef MPP_LAND
+           integer:: gnlinksl
+           real,allocatable,dimension(:) :: g_var
+           if(my_id .eq. io_id) then
+                allocate(g_var(gnlinksl))
+                g_var  = 0
+           else
+                allocate(g_var(1) )
+           endif
+  
+           call ReachLS_write_io(inVar, g_var)
+           if(my_id .eq. IO_id) then
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1/), (/gnlinksl/),g_var)
+           endif
+           if(allocated(g_var)) deallocate(g_var)
+#else
+           n = size(inVar,1) 
+           iret = nf_inq_varid(ncid,varName, varid)
+           iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar)
+#endif
+           return
+        end subroutine w_rst_crt_reach
+
+        subroutine w_rst_crt_nc1(ncid,n,inVar,varName &
+#ifdef MPP_LAND
+                 ,map_l2g, gnlinks&
+#endif
+                  )
+           implicit none
+           integer:: ncid,n,varid , iret
+           character(len=*) varName
+           real inVar(n)
+#ifdef MPP_LAND
+           integer:: gnlinks, map_l2g(n)
+           real g_var(gnlinks)
+           call write_chanel_real(inVar,map_l2g,gnlinks,n,g_var)          
+           if(my_id .eq. IO_id) then
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1/), (/gnlinks/),g_var)
+#else
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar)
+#endif
+#ifdef MPP_LAND
+           endif
+#endif
+           return
+        end subroutine w_rst_crt_nc1
+
+        subroutine w_rst_crt_nc1g(ncid,n,inVar,varName)
+           implicit none
+           integer:: ncid,n,varid , iret
+           character(len=*) varName
+           real,dimension(:) ::  inVar
+#ifdef MPP_LAND
+           if(my_id .eq. IO_id) then
+#endif
+              iret = nf_inq_varid(ncid,varName, varid)
+              iret = nf_put_vara_real(ncid, varid, (/1/), (/n/),inVar)
+#ifdef MPP_LAND
+           endif
+#endif
+           return
+        end subroutine w_rst_crt_nc1g
+
+   subroutine w_rst_gwbucket_real(ncid,numbasns,gnumbasns, &
+                       basnsInd, inV,vName )
+      implicit none
+      integer :: ncid,numbasns,gnumbasns
+      integer, dimension(:) :: basnsInd
+      real, dimension(:) :: inV 
+      character(len=*) :: vName
+      integer i, j, k
+      real, allocatable,dimension(:) :: buf
+#ifdef MPP_LAND
+      if (my_id .eq. IO_id) then 
+        allocate(buf(gnumbasns))
+      else
+        allocate(buf(1))
+      endif
+      call gw_write_io_real(numbasns,inV,basnsInd,buf)
+#else
+      allocate(buf(gnumbasns))
+      do k = 1, numbasns
+        buf(basnsInd(k)) = inV(k)
+      end do
+#endif
+      call w_rst_crt_nc1g(ncid,gnumbasns,buf,vName)
+      if(allocated(buf)) deallocate(buf)
+   end subroutine w_rst_gwbucket_real
+
+   subroutine read_rst_gwbucket_real(ncid,outV,numbasns,&
+                       gnumbasns,basnsInd, vName)
+      implicit none
+      integer :: ncid,numbasns,gnumbasns
+      integer, dimension(:) :: basnsInd
+      real, dimension(:) :: outV 
+      character(len=*) :: vName
+      integer i, j,k
+      real, dimension(gnumbasns) :: buf
+      call read_rst_crt_nc(ncid,buf,gnumbasns,vName)
+      do k = 1, numbasns
+         outV(k) = buf(basnsInd(k))
+      end do
+   end subroutine read_rst_gwbucket_real
+
+   subroutine RESTART_IN_NC(inFile,did)
+
+   implicit none
+   character(len=*) inFile
+   integer  :: ierr, iret,ncid, did
+
+    integer :: i, j
+
+
+#ifdef MPP_LAND
+     if(IO_id .eq. my_id) then
+#endif
+!open a netcdf file 
+    iret = nf_open(trim(inFile), NF_NOWRITE, ncid)
+#ifdef MPP_LAND
+    endif
+    call mpp_land_bcast_int1(iret)
+#endif
+    if (iret /= 0) then
+       write(*,'("Problem opening file: ''", A, "''")') &
+            trim(inFile)
+       call hydro_stop("In RESTART_IN_NC() - Problem opening file") 
+    endif
+
+#ifdef MPP_LAND
+     if(IO_id .eq. my_id) then
+#endif
+        iret = NF_GET_ATT_INT(ncid, NF_GLOBAL, 'his_out_counts', rt_domain(did)%his_out_counts) 
+        iret = NF_GET_ATT_REAL(ncid, NF_GLOBAL, 'DTCT', nlst_rt(did)%DTCT)
+        iret = nf_get_att_text(ncid,NF_GLOBAL,"Since_Date",nlst_rt(did)%sincedate(1:19))
+        if(iret /= 0) nlst_rt(did)%sincedate = nlst_rt(did)%startdate
+        if(nlst_rt(did)%DTCT .gt. 0) then
+           nlst_rt(did)%DTCT = min(nlst_rt(did)%DTCT, nlst_rt(did)%DTRT_CH)
+        else
+           nlst_rt(did)%DTCT = nlst_rt(did)%DTRT_CH
+        endif
+#ifdef MPP_LAND
+    endif
+    call mpp_land_bcast_int1(rt_domain(did)%out_counts)
+    call mpp_land_bcast_real1(nlst_rt(did)%DTCT)
+#endif
+
+#ifdef HYDRO_D
+     write(6,*) "nlst_rt(did)%nsoil=",nlst_rt(did)%nsoil
+#endif
+
+     if(nlst_rt(did)%rst_typ .eq. 1 ) then 
+        call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%stc,"stc")
+        call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%smc,"smc")
+        call read_rst_nc3(ncid,rt_domain(did)%ix,rt_domain(did)%jx,nlst_rt(did)%nsoil,rt_domain(did)%sh2ox,"sh2ox")
+        call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%INFXSRT,"infxsrt")
+        call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%sfcheadrt,"sfcheadrt")
+        call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%soldrain,"soldrain")
+     endif
+
+!yw check
+ 
+        call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCMAX1,"smcmax1")
+        call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCREF1,"smcref1")
+        call read_rst_nc2(ncid,rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%SMCWLT1,"smcwlt1")
+
+
+        if(nlst_rt(did)%SUBRTSWCRT.EQ.1.OR.nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) then
+            call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%INFXSWGT,"infxswgt")
+            call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%SFCHEADSUBRT,"SFCHEADSUBRT")
+            call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QBDRYRT,"QBDRYRT")
+            call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%QSTRMVOLRT,"qstrmvolrt")
+            !call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%RETDEPRT,"RETDEPRT")
+            call read_rst_rt_nc3(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,nlst_rt(did)%nsoil,rt_domain(did)%SH2OWGT,"sh2owgt")
+
+
+            if(nlst_rt(did)%CHANRTSWCRT.EQ.1) then
+                if(nlst_rt(did)%channel_option .eq. 3) then
+                    call read_rst_crt_stream_nc(ncid,rt_domain(did)%HLINK,rt_domain(did)%NLINKS,"hlink",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g)
+                    call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,1),rt_domain(did)%NLINKS,"qlink1",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g)
+                    call read_rst_crt_stream_nc(ncid,rt_domain(did)%QLINK(:,2),rt_domain(did)%NLINKS,"qlink2",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g)
+                    call read_rst_crt_stream_nc(ncid,rt_domain(did)%CVOL,rt_domain(did)%NLINKS,"cvol",rt_domain(did)%GNLINKS,rt_domain(did)%map_l2g)
+                else
+                    call read_rst_crt_reach_nc(ncid,rt_domain(did)%HLINK,"hlink",rt_domain(did)%GNLINKSL)
+                    call read_rst_crt_reach_nc(ncid,rt_domain(did)%QLINK(:,1),"qlink1",rt_domain(did)%GNLINKSL)
+                    call read_rst_crt_reach_nc(ncid,rt_domain(did)%QLINK(:,2),"qlink2",rt_domain(did)%GNLINKSL)
+                    call read_rst_crt_reach_nc(ncid,rt_domain(did)%CVOL,"cvol",rt_domain(did)%GNLINKSL)
+                    if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+                       ! read in the statistic value
+                       call read_rst_crt_reach_nc(ncid,rt_domain(did)%accLndRunOff,"accLndRunOff",rt_domain(did)%GNLINKSL)
+                       call read_rst_crt_reach_nc(ncid,rt_domain(did)%accQLateral,"accQLateral",rt_domain(did)%GNLINKSL)
+                       call read_rst_crt_reach_nc(ncid,rt_domain(did)%accStrmvolrt,"accStrmvolrt",rt_domain(did)%GNLINKSL)
+                       call read_rst_crt_reach_nc(ncid,rt_domain(did)%accBucket,"accBucket",rt_domain(did)%GNLINKS)
+                    endif
+                endif
+
+              if(rt_domain(did)%NLAKES .gt. 0) then
+                 call read_rst_crt_nc(ncid,rt_domain(did)%RESHT,rt_domain(did)%NLAKES,"resht")
+                 call read_rst_crt_nc(ncid,rt_domain(did)%QLAKEO,rt_domain(did)%NLAKES,"qlakeo")
+              endif
+              call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%LAKE_INFLORT,"lake_inflort")
+
+            end if
+
+            if(nlst_rt(did)%GWBASESWCRT.EQ.1.AND.nlst_rt(did)%GW_RESTART.NE.0 .and. rt_domain(did)%gnumbasns .gt. 0) then
+               if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+                   call read_rst_crt_reach_nc(ncid,rt_domain(did)%z_gwsubbas,"z_gwsubbas",rt_domain(did)%GNLINKSL)
+               else 
+                   call read_rst_gwbucket_real(ncid,rt_domain(did)%z_gwsubbas,rt_domain(did)%numbasns,&
+                       rt_domain(did)%gnumbasns,rt_domain(did)%basnsInd, "z_gwsubbas")
+               endif
+            end if
+            if(nlst_rt(did)%GWBASESWCRT.EQ.3) then
+              call read_rt_nc2(ncid,rt_domain(did)%ixrt,rt_domain(did)%jxrt,gw2d(did)%ho,"HEAD")
+	    end if
+        end if
+
+          if(nlst_rt(did)%rstrt_swc.eq.1) then  !Switch for rest of restart accum vars...
+#ifdef HYDRO_D
+            print *, "1 Resetting RESTART Accumulation Variables to 0...",nlst_rt(did)%rstrt_swc
+#endif
+            rt_domain(did)%INFXSRT=0.
+            rt_domain(did)%LAKE_INFLORT=0.
+            rt_domain(did)%QSTRMVOLRT=0.
+            rt_domain(did)%accLndRunOff = 0.
+            rt_domain(did)%accQLateral = 0.
+            rt_domain(did)%accStrmvolrt = 0.
+            rt_domain(did)%accBucket = 0.
+          end if
+
+      
+#ifdef MPP_LAND
+        if(my_id .eq. IO_id) &
+#endif
+        iret =  nf_close(ncid) 
+#ifdef HYDRO_D
+        write(6,*) "end of RESTART_IN"
+        call flush(6)
+#endif
+
+        return
+        end subroutine RESTART_IN_nc
+
+      subroutine read_rst_nc3(ncid,ix,jx,NSOIL,var,varStr)
+         implicit none 
+         integer ::  ix,jx,nsoil, ireg, ncid, varid, iret
+         real,dimension(ix,jx,nsoil) ::  var
+         character(len=*) :: varStr
+         character(len=2) :: tmpStr
+         integer :: n
+         integer i
+#ifdef MPP_LAND
+         real,dimension(global_nx,global_ny) :: xtmp
+#endif
+
+         do i = 1, nsoil
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) then
+#endif
+                 if( i .lt. 10) then
+                    write(tmpStr, '(i1)') i
+                 else
+                    write(tmpStr, '(i2)') i
+                 endif
+           iret = nf_inq_varid(ncid,  trim(varStr)//trim(tmpStr),  varid)
+#ifdef MPP_LAND
+         endif
+         call mpp_land_bcast_int1(iret)
+#endif
+
+         if (iret /= 0) then
+#ifdef HYDRO_D
+            print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+            return
+         endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr//trim(tmpStr)
+#endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) & 
+            iret = nf_get_var_real(ncid, varid, xtmp)
+
+            call decompose_data_real(xtmp(:,:), var(:,:,i))
+#else
+            iret = nf_get_var_real(ncid, varid, var(:,:,i))
+#endif
+         end do
+
+         return
+      end subroutine read_rst_nc3
+
+      subroutine read_rst_nc2(ncid,ix,jx,var,varStr)
+         implicit none
+         integer ::  ix,jx,ireg, ncid, varid, iret
+         real,dimension(ix,jx) ::  var
+         character(len=*) :: varStr
+#ifdef MPP_LAND
+         real,dimension(global_nx,global_ny) :: xtmp 
+         if(my_id .eq. IO_id) & 
+#endif
+           iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+
+         if (iret /= 0) then
+#ifdef HYDRO_D
+            print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+            return
+         endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) & 
+            iret = nf_get_var_real(ncid, varid, xtmp)
+
+         call decompose_data_real(xtmp, var)
+#else
+            var = 0.0
+            iret = nf_get_var_real(ncid, varid, var)
+#endif
+         return
+      end subroutine read_rst_nc2
+
+      subroutine read_rst_rt_nc3(ncid,ix,jx,NSOIL,var,varStr)
+         implicit none
+         integer ::  ix,jx,nsoil, ireg, ncid, varid, iret
+         real,dimension(ix,jx,nsoil) ::  var
+         character(len=*) :: varStr
+         character(len=2) :: tmpStr
+         integer i
+#ifdef MPP_LAND
+         real,dimension(global_rt_nx,global_rt_ny) :: xtmp
+#endif
+         do i = 1, nsoil
+                 if( i .lt. 10) then
+                    write(tmpStr, '(i1)') i
+                 else
+                    write(tmpStr, '(i2)') i
+                 endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) & 
+#endif
+            iret = nf_inq_varid(ncid,  trim(varStr)//trim(tmpStr),  varid)
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+         if (iret /= 0) then
+#ifdef HYDRO_D
+            print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+            return
+         endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr//trim(tmpStr)
+#endif
+#ifdef MPP_LAND
+         iret = nf_get_var_real(ncid, varid, xtmp)
+            call decompose_RT_real(xtmp(:,:),var(:,:,i),global_rt_nx,global_rt_ny,ix,jx)
+#else
+         iret = nf_get_var_real(ncid, varid, var(:,:,i))
+#endif
+         end do
+         return
+      end subroutine read_rst_rt_nc3
+
+      subroutine read_rst_rt_nc2(ncid,ix,jx,var,varStr)
+         implicit none
+         integer ::  ix,jx,ireg, ncid, varid, iret
+         real,dimension(ix,jx) ::  var
+         character(len=*) :: varStr
+#ifdef MPP_LAND
+         real,dimension(global_rt_nx,global_rt_ny) :: xtmp 
+#endif
+         iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+         if (iret /= 0) then
+#ifdef HYDRO_D
+            print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+            return
+         endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) &   
+             iret = nf_get_var_real(ncid, varid, xtmp)
+         call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx)
+#else
+            iret = nf_get_var_real(ncid, varid, var)
+#endif
+         return
+      end subroutine read_rst_rt_nc2
+
+      subroutine read_rt_nc2(ncid,ix,jx,var,varStr)
+         implicit none
+         integer ::  ix,jx, ncid, varid, iret
+         real,dimension(ix,jx) ::  var
+         character(len=*) :: varStr
+
+#ifdef MPP_LAND
+         real,allocatable, dimension(:,:) :: xtmp
+!yw         real,dimension(global_rt_nx,global_rt_ny) :: xtmp
+         if(my_id .eq. io_id ) then
+             allocate(xtmp(global_rt_nx,global_rt_ny))
+         else
+             allocate(xtmp(1,1))
+         endif
+         xtmp = 0.0
+#endif
+            iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+            if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+               return
+            endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) then
+            iret = nf_get_var_real(ncid, varid, xtmp)
+         endif
+         call decompose_RT_real(xtmp,var,global_rt_nx,global_rt_ny,ix,jx)
+
+         if(allocated(xtmp)) deallocate(xtmp)
+
+#else
+            iret = nf_get_var_real(ncid, varid, var)
+#endif
+         return
+      end subroutine read_rt_nc2
+
+      subroutine read_rst_crt_nc(ncid,var,n,varStr)
+         implicit none
+         integer ::  ireg, ncid, varid, n, iret
+         real,dimension(n) ::  var
+         character(len=*) :: varStr
+        
+         if( n .le. 0)  return
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) & 
+#endif
+            iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+            if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+               return
+            endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) then
+#endif
+            iret = nf_get_var_real(ncid, varid, var)
+#ifdef MPP_LAND
+         endif
+         if(n .gt. 0) then
+             call mpp_land_bcast_real(n,var)
+         endif
+#endif
+         return
+      end subroutine read_rst_crt_nc 
+
+      subroutine read_rst_crt_stream_nc(ncid,var_out,n,varStr,gnlinks,map_l2g)
+         implicit none
+         integer ::  ncid, varid, n, iret, gnlinks
+         integer, intent(in), dimension(:) :: map_l2g
+         character(len=*) :: varStr
+         integer :: l, g
+         real,intent(out) , dimension(:) ::  var_out
+#ifdef MPP_LAND
+         real,dimension(gnlinks) ::  var
+#else
+         real,dimension(n) ::  var
+#endif
+
+
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) & 
+#endif
+            iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+#ifdef MPP_LAND
+         call mpp_land_bcast_int1(iret)
+#endif
+            if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+               return
+            endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) then
+#endif
+            var = 0.0
+            iret = nf_get_var_real(ncid, varid, var)
+#ifdef MPP_LAND
+         endif
+         if(gnlinks .gt. 0) then
+            call mpp_land_bcast_real(gnlinks,var)
+         endif
+        
+         if(n .le. 0) return
+         var_out = 0
+
+         do l = 1, n
+            g = map_l2g(l)
+            var_out(l) = var(g)
+         end do
+#else
+         var_out = var
+#endif
+         return
+      end subroutine read_rst_crt_stream_nc 
+
+      subroutine read_rst_crt_reach_nc(ncid,var_out,varStr,gnlinksl)
+         implicit none
+         integer ::  ncid, varid, n, iret, gnlinksl
+         character(len=*) :: varStr
+         integer :: l, g
+         real, dimension(:) ::  var_out
+
+         real,allocatable,dimension(:) ::  var
+
+         n = size(var_out,1)
+
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) then
+              allocate(var(gnlinksl))
+         else
+              allocate(var(1))
+         endif
+#else
+              allocate(var(n))
+#endif
+         
+
+#ifdef MPP_LAND
+         if(my_id .eq. IO_id) then
+            iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+         endif
+         call mpp_land_bcast_int1(iret)
+         if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+
+              if(allocated(var))  deallocate(var)
+               return
+            endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+         call flush(6)
+#endif
+         if(my_id .eq. IO_id) then
+            var = 0.0
+            iret = nf_get_var_real(ncid, varid, var)
+         endif
+         call ReachLS_decomp(var,   var_out)
+         if(allocated(var)) deallocate(var)
+#else
+            iret = nf_inq_varid(ncid,  trim(varStr),  varid)
+           if (iret /= 0) then
+#ifdef HYDRO_D
+               print*, 'variable not found: name = "', trim(varStr)//'"'
+#endif
+               if(allocated(var)) deallocate(var)
+               return
+            endif
+#ifdef HYDRO_D
+         print*, "read restart variable ", varStr
+#endif   
+         iret = nf_get_var_real(ncid, varid, var_out)
+         if(allocated(var)) deallocate(var)
+#endif
+
+
+         return
+      end subroutine read_rst_crt_reach_nc 
+
+      subroutine hrldas_out()
+      end subroutine hrldas_out
+
+
+       SUBROUTINE READ_CHROUTING1(IXRT,JXRT,fgDEM,CH_NETRT,CH_LNKRT, LAKE_MSKRT, &
+            FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, &
+            NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, &
+            LAKEIDA, HRZAREA, LAKEMAXH,WEIRH,  WEIRC, WEIRL, ORIFICEC, ORIFICEA, &
+            ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, LAKEIDM, LAKEIDX, &
+            route_link_f, &
+            route_lake_f, route_direction_f, route_order_f, &
+            CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, &
+            CHANXI, CHANYJ, CHLAT, CHLON,  &
+            channel_option,LATVAL,LONVAL, &
+            STRMFRXSTPTS,geo_finegrid_flnm , NLINKSL, LINKID, GNLINKSL,UDMP_OPT     &
+#ifdef MPP_LAND
+            ,Link_Location &
+#endif
+            ,gages, gageMiss)
+#ifdef MPP_LAND
+        use module_mpp_land, only:  my_id, io_id
+#endif
+#include 
+        INTEGER, INTENT(IN)                          :: IXRT,JXRT, UDMP_OPT
+        INTEGER                                      :: CHANRTSWCRT, NLINKS, NLAKES, NLINKSL, GNLINKSL
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)       :: fgDEM
+        INTEGER, DIMENSION(IXRT,JXRT)                :: DIRECTION
+        INTEGER, DIMENSION(IXRT,JXRT)                :: GSTRMFRXSTPTS
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT)    :: CH_NETRT, CH_LNKRT
+        INTEGER, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT
+        INTEGER,                DIMENSION(IXRT,JXRT) :: GORDER  !-- gridded stream orderk
+#ifdef MPP_LAND
+        INTEGER,                DIMENSION(IXRT,JXRT) :: Link_Location !-- gridded stream orderk
+        INTEGER :: LNLINKSL
+!yw        INTEGER,                dimension(LNLINKSL) :: LLINKID
+#endif
+        INTEGER                                      :: I,J,K,channel_option
+        REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)      :: LATVAL, LONVAL
+        CHARACTER(len=28)                            :: dir
+!Dummy inverted grids from arc
+
+
+!----DJG,DNY New variables for channel and lake routing
+        CHARACTER(len=155)	 :: header
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: FROM_NODE
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: ZELEV
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: CHLAT,CHLON
+
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: TYPEL
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: TO_NODE,ORDER
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: STRMFRXSTPTS
+
+        INTEGER, INTENT(INOUT)                       :: MAXORDER
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: MUSK, MUSX !muskingum
+        REAL, INTENT(INOUT),  DIMENSION(:,:)    :: QLINK  !channel flow
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: CHANLEN   !channel length
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: MannN, So !mannings N
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: LAKENODE,LINKID   ! identifies which nodes pour into which lakes
+        REAL, INTENT(IN)                             :: dist(ixrt,jxrt,9)
+
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT)    :: CH_NETLNK
+        REAL,  DIMENSION(IXRT,JXRT)                  :: ChSSlpG,BwG,MannNG  !channel properties on Grid
+        REAL,  DIMENSION(IXRT,JXRT)                  :: chanDepth, elrt
+
+
+!-- store the location x,y location of the channel element
+         INTEGER, INTENT(INOUT), DIMENSION(NLINKS)   :: CHANXI, CHANYJ
+
+!--reservoir/lake attributes
+        REAL, INTENT(INOUT),  DIMENSION(:)      :: HRZAREA
+        INTEGER, INTENT(INOUT),  DIMENSION(:)   :: LAKEIDM    !lake id for LAKES_Modeled in the LAKEPARM table (.nc or .tbl)
+
+        REAL, INTENT(INOUT),  DIMENSION(:)           :: LAKEMAXH, WEIRH
+        REAL, INTENT(INOUT),  DIMENSION(:)      :: WEIRC
+        REAL, INTENT(INOUT),  DIMENSION(:)      :: WEIRL
+        REAL, INTENT(INOUT),  DIMENSION(:)      :: ORIFICEC
+        REAL, INTENT(INOUT),  DIMENSION(:)      :: ORIFICEA
+        REAL, INTENT(INOUT),  DIMENSION(:)      :: ORIFICEE
+        REAL, INTENT(INOUT),  DIMENSION(:)      :: LATLAKE,LONLAKE,ELEVLAKE
+        REAL, INTENT(INOUT), DIMENSION(:)       :: ChSSlp, Bw
+
+        INTEGER, INTENT(INOUT),  DIMENSION(:)  :: LAKEIDA !the COM lake id for each link on the full nlinks database
+        INTEGER, INTENT(INOUT),  DIMENSION(:)  :: LAKEIDX !the sequential index of lakes (1 to Nlakes) mapped to COMID
+
+        INTEGER, DIMENSION(NLAKES,NLINKSL)           :: tmpTO      !a variable to hold hold the to of links for Lake Outlet Iding
+        INTEGER, DIMENSION(NLAKES)                   :: LAKELINKID !temporarily store the outlet index for each modeled lake
+
+
+        character(len=15), intent(inout), dimension(nlinks) :: gages  !! need to respect the default values
+        character(len=15), intent(in)                :: gageMiss
+
+        CHARACTER(len=256)                           :: route_link_f
+        CHARACTER(len=256)                           :: route_lake_f
+        CHARACTER(len=256)                           :: route_direction_f
+        CHARACTER(len=256)                           :: route_order_f
+        CHARACTER(len=256)                           :: geo_finegrid_flnm
+        CHARACTER(len=256)                           :: var_name
+
+        INTEGER                                      :: tmp, cnt, ncid, iret, jj,ct
+	INTEGER 			             :: IOstatus, OUTLAKEID
+
+        real                                         :: gc,n
+        integer :: did
+
+        did = 1
+        
+!---------------------------------------------------------
+! End Declarations
+!---------------------------------------------------------
+
+        LAKEIDX  = -999
+        MAXORDER = -9999
+        LAKELINKID = 0
+!initialize GSTRM
+        GSTRMFRXSTPTS = -9999
+
+!yw initialize the array.
+        to_node =   MAXORDER
+        from_node = MAXORDER
+#ifdef MPP_LAND
+        Link_location = MAXORDER
+#endif
+
+#ifdef HYDRO_D
+        print *, "reading routing initialization files..."
+        print *, "route direction", route_direction_f
+        print *, "route order", route_order_f
+        print *, "route linke",route_link_f
+        print *, "route lake",route_lake_f
+#endif
+
+!DJG Edited code here to retrieve data from hires netcdf file....
+
+!!-- read regardless; commented out on 7/21/14
+
+        var_name = "LATITUDE"
+        call nreadRT2d_real  (   &
+             var_name,LATVAL,ixrt,jxrt,trim(geo_finegrid_flnm))
+
+        var_name = "LONGITUDE"
+        call nreadRT2d_real(   &
+             var_name,LONVAL,ixrt,jxrt,trim(geo_finegrid_flnm))
+
+       var_name = "LAKEGRID"
+       call nreadRT2d_int(&
+             var_name,LAKE_MSKRT,ixrt,jxrt,trim(geo_finegrid_flnm))
+
+       var_name = "FLOWDIRECTION"
+       call nreadRT2d_int(& 
+              var_name,DIRECTION,ixrt,jxrt,trim(geo_finegrid_flnm))
+
+       var_name = "STREAMORDER"
+       call nreadRT2d_int(&
+               var_name,GORDER,ixrt,jxrt,trim(geo_finegrid_flnm))
+
+
+       var_name = "frxst_pts"
+       call nreadRT2d_int(&
+             var_name,GSTRMFRXSTPTS,ixrt,jxrt,trim(geo_finegrid_flnm))
+
+!!!Flip y-dimension of highres grids from exported Arc files...
+
+        var_name = "CHAN_DEPTH"
+        call nreadRT2d_real(   &
+             var_name,chanDepth,ixrt,jxrt,trim(geo_finegrid_flnm))
+
+       if(nlst_rt(did)%GWBASESWCRT .eq. 3) then
+             elrt = fgDEM - chanDepth
+       else
+             elrt = fgDEM     !ywtmp
+       endif
+       
+       ct = 0
+     
+! temp fix for buggy Arc export...
+        do j=1,jxrt
+          do i=1,ixrt
+            if(DIRECTION(i,j).eq.-128) DIRECTION(i,j)=128
+          end do
+        end do
+
+
+!- read the grid regardless of routing method
+   cnt = 0 
+   BwG = 0.0
+   ChSSlpG = 0.0
+   MannNG = 0.0
+   TYPEL = 0
+   MannN = 0.0
+   Bw = 0.0
+   ChSSlp = 0.0
+
+        if (UDMP_OPT .eq. 1) goto 299
+
+!DJG inv       DO j = JXRT,1,-1  !rows
+       DO j = 1,JXRT  !rows
+        DO i = 1 ,IXRT   !colsumns
+         If (CH_NETRT(i, j) .ge. 0) then !get its direction and assign its elevation and order
+          If ((DIRECTION(i, j) .EQ. 64) .AND. (j + 1 .LE. JXRT) ) then !North
+             if(CH_NETRT(i,j+1).ge.0) then
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i, j + 1)
+             CHANLEN(cnt) = dist(i,j,1)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+             endif
+          else if ((DIRECTION(i, j) .EQ. 128) .AND. (i + 1 .LE. IXRT) &
+                    .AND. (j + 1 .LE. JXRT)  ) then !North East
+             if(CH_NETRT(i+1,j+1).ge.0) then
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i + 1, j + 1)
+             CHANLEN(cnt) = dist(i,j,2)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+             endif
+          else if ((DIRECTION(i, j) .EQ. 1) .AND. (i + 1 .LE. IXRT) ) then !East
+             if(CH_NETRT(i+1,j).ge.0) then
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i + 1, j)
+             CHANLEN(cnt) = dist(i,j,3)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+             endif
+          else if ((DIRECTION(i, j) .EQ. 2) .AND. (i + 1 .LE. IXRT) &
+                    .AND. (j - 1 .NE. 0)  ) then !south east
+             if(CH_NETRT(i+1,j-1).ge.0) then
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i + 1, j - 1)
+             CHANLEN(cnt) = dist(i,j,4)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+             endif
+          else if ((DIRECTION(i, j) .EQ. 4) .AND. (j - 1 .NE. 0) ) then !due south
+             if(CH_NETRT(i,j-1).ge.0) then
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i, j - 1)
+             CHANLEN(cnt) = dist(i,j,5)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+             endif
+          else if ((DIRECTION(i, j) .EQ. 8) .AND. (i - 1 .GT. 0) &
+               .AND. (j - 1 .NE. 0) ) then !south west
+             if(CH_NETRT(i-1,j-1).ge.0) then
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i,j)
+             TO_NODE(cnt) = CH_NETLNK(i - 1, j - 1)
+             CHANLEN(cnt) = dist(i,j,6)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+             endif
+          else if ((DIRECTION(i, j) .EQ. 16) .AND. (i - 1 .GT. 0) ) then !West
+             if(CH_NETRT(i-1,j).ge.0) then
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             TO_NODE(cnt) = CH_NETLNK(i - 1, j)
+             CHANLEN(cnt) = dist(i,j,7)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+             endif
+          else if ((DIRECTION(i, j) .EQ. 32) .AND. (i - 1 .GT. 0) &
+                    .AND. (j + 1 .LE. JXRT)  ) then !North West
+             if(CH_NETRT(i-1,j+1).ge.0) then
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+             ORDER(cnt) = GORDER(i,j)
+             STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+             ZELEV(cnt) = ELRT(i,j)
+             MannN(cnt) = MannNG(i,j)
+             ChSSlp(cnt) = ChSSlpG(i,j)
+             Bw(cnt) = BwG(i,j)
+             CHLAT(cnt) = LATVAL(i,j)
+             CHLON(cnt) = LONVAL(i,j)
+             FROM_NODE(cnt) = CH_NETLNK(i, j)
+             TO_NODE(cnt) = CH_NETLNK(i - 1, j + 1)
+             CHANLEN(cnt) = dist(i,j,8)
+             CHANXI(cnt) = i
+             CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+             endif
+          else 
+#ifdef HYDRO_D
+!            print *, "NO MATCH", i,j,CH_NETLNK(i,j),DIRECTION(i,j),i + 1,j - 1 !south east
+#endif
+          End If
+
+         End If !CH_NETRT check for this node
+
+        END DO
+       END DO 
+
+#ifdef HYDRO_D
+       print *, "after exiting the channel, this many nodes", cnt
+       write(*,*) " " 
+#endif
+
+
+!Find out if the boundaries are on an edge
+!DJG inv       DO j = JXRT,1,-1
+       DO j = 1,JXRT
+         DO i = 1 ,IXRT
+          If (CH_NETRT(i, j) .ge. 0) then !get its direction
+
+           If (DIRECTION(i, j).EQ. 64) then
+              if( j + 1 .GT. JXRT)  then         !-- 64's can only flow north
+                 goto 101
+              elseif ( CH_NETRT(i,j+1) .lt. 0) then !North
+                 goto 101
+              endif
+              goto 102
+101           continue
+#ifdef MPP_LAND
+                cnt = CH_NETLNK(i,j)
+#else
+                cnt = cnt + 1
+#endif
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if(j+1 .GT. JXRT) then !-- an edge
+               TYPEL(cnt) = 1
+              elseif(LAKE_MSKRT(i,j+1).gt.0) then 
+               TYPEL(cnt) = 2
+               LAKENODE(cnt) = LAKE_MSKRT(i,j+1)
+              else
+               TYPEL(cnt) = 1 
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,1)
+              CHANXI(cnt) = i
+                 CHANYJ(cnt) = j
+#ifdef MPP_LAND
+                Link_Location(i,j) = cnt
+#endif
+#ifdef HYDRO_D
+!                print *, "Pour Point N", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+102           continue
+
+           else if ( DIRECTION(i, j) .EQ. 128) then
+               if ((i + 1 .GT. IXRT)  & !-- 128's can flow out of the North or East edge
+               .OR.  (j + 1 .GT. JXRT))  then !   this is due north edge
+                   goto 201
+               elseif (CH_NETRT(i + 1, j + 1).lt.0) then !North East
+                   goto 201
+               endif
+!#endif
+               goto 202 
+201            continue
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if((i+1 .GT. IXRT) .OR. (j+1 .GT. JXRT))  then ! an edge
+                TYPEL(cnt) = 1
+              elseif(LAKE_MSKRT(i+1,j+1).gt.0) then 
+                TYPEL(cnt) = 2
+                LAKENODE(cnt) = LAKE_MSKRT(i+1,j+1)
+              else
+                TYPEL(cnt) = 1
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,2)  
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+#ifdef HYDRO_D
+!             print *, "Pour Point NE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+202            continue
+
+           else if (DIRECTION(i, j) .EQ. 1) then 
+               if(i + 1 .GT. IXRT) then     !-- 1's can only flow due east
+                  goto 301
+               elseif(CH_NETRT(i + 1, j) .lt. 0) then !East
+                  goto 301
+               endif
+               goto 302
+301            continue
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if(i+1 .GT. IXRT) then  !an edge
+                TYPEL(cnt) = 1
+              elseif(LAKE_MSKRT(i+1,j).gt.0) then 
+                TYPEL(cnt) = 2
+                LAKENODE(cnt) = LAKE_MSKRT(i+1,j)
+              else
+                TYPEL(cnt) = 1
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,3)
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+#ifdef HYDRO_D
+!             print *, "Pour Point E", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+302            continue
+           else if (DIRECTION(i, j) .EQ. 2) then 
+                if((i + 1 .GT. IXRT)    &      !-- 2's can flow out of east or south edge
+                   .OR.  (j - 1 .EQ. 0))   then              !-- this is the south edge
+                   goto 401
+                elseif (CH_NETRT(i + 1, j - 1) .lt.0) then !south east
+                   goto 401
+                endif
+              goto 402
+401            continue
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if((i+1 .GT. IXRT) .OR. (j-1 .EQ. 0)) then !an edge 
+                TYPEL(cnt) = 1
+              elseif(LAKE_MSKRT(i+1,j-1).gt.0) then 
+                TYPEL(cnt) = 2
+                LAKENODE(cnt) = LAKE_MSKRT(i+1,j-1)
+              else
+                TYPEL(cnt) = 1
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,4)
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+#ifdef HYDRO_D
+!             print *, "Pour Point SE", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+402            continue
+
+           else if (DIRECTION(i, j) .EQ. 4)  then
+               if(j - 1 .EQ. 0) then         !-- 4's can only flow due south
+                   goto 501
+               elseif (CH_NETRT(i, j - 1) .lt. 0) then !due south
+                   goto 501
+               endif
+               goto 502
+501            continue
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if(j-1 .EQ. 0) then !- an edge
+                TYPEL(cnt) =1
+              elseif(LAKE_MSKRT(i,j-1).gt.0) then 
+                TYPEL(cnt) = 2
+                LAKENODE(cnt) = LAKE_MSKRT(i,j-1)
+              else
+                TYPEL(cnt) = 1
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,5)
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+#ifdef HYDRO_D
+!             print *, "Pour Point S", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+502            continue
+
+          else if ( DIRECTION(i, j) .EQ. 8) then
+               if( (i - 1 .LE. 0)      &      !-- 8's can flow south or west
+                  .OR.  (j - 1 .EQ. 0)) then        !-- this is the south edge
+                   goto 601
+               elseif (CH_NETRT(i - 1, j - 1).lt.0) then !south west
+                   goto 601
+               endif
+               goto 602
+601            continue
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if( (i-1 .EQ. 0) .OR. (j-1 .EQ. 0) ) then !- an edge
+               TYPEL(cnt) = 1
+              elseif(LAKE_MSKRT(i-1,j-1).gt.0) then 
+                TYPEL(cnt) = 2
+                LAKENODE(cnt) = LAKE_MSKRT(i-1,j-1)
+              else
+                TYPEL(cnt) = 1
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,6) 
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+#ifdef HYDRO_D
+!             print *, "Pour Point SW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+602            continue
+           else if (DIRECTION(i, j) .EQ. 16) then
+               if( i - 1 .LE.0) then                 !16's can only flow due west
+                  goto 701
+               elseif( CH_NETRT(i - 1, j).lt.0) then !West
+                  goto 701
+               endif
+               goto 702
+701            continue
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if(i-1 .EQ. 0) then !-- an edge
+                TYPEL(cnt) = 1
+              elseif(LAKE_MSKRT(i-1,j).gt.0) then 
+                TYPEL(cnt) = 2
+                LAKENODE(cnt) = LAKE_MSKRT(i-1,j)
+              else
+                TYPEL(cnt) = 1
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,7)
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+#ifdef HYDRO_D
+!             print *, "Pour Point W", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+702            continue
+
+           else if ( DIRECTION(i, j) .EQ. 32) then
+               if( (i - 1 .LE. 0)      &      !-- 32's can flow either west or north
+                 .OR.  (j + 1 .GT. JXRT)) then     !-- this is the north edge
+                   goto 801
+               elseif (CH_NETRT(i - 1, j + 1).lt.0) then !North West
+                   goto 801
+               endif
+               goto 802
+801            continue
+#ifdef MPP_LAND
+             cnt = CH_NETLNK(i,j)
+#else
+             cnt = cnt + 1
+#endif
+              ORDER(cnt) = GORDER(i,j)
+              STRMFRXSTPTS(cnt) = GSTRMFRXSTPTS(i,j)
+              ZELEV(cnt) = ELRT(i,j)
+              MannN(cnt) = MannNG(i,j)
+              ChSSlp(cnt) = ChSSlpG(i,j)
+              Bw(cnt) = BwG(i,j)
+              CHLAT(cnt) = LATVAL(i,j)
+              CHLON(cnt) = LONVAL(i,j)
+              if( (i-1 .EQ. 0) .OR. (j+1 .GT. JXRT)) then !-- an edge
+               TYPEL(cnt) = 1
+              elseif(LAKE_MSKRT(i-1,j+1).gt.0) then 
+                TYPEL(cnt) = 2
+                LAKENODE(cnt) = LAKE_MSKRT(i-1,j+1)
+              else
+                TYPEL(cnt) = 1
+              endif
+              FROM_NODE(cnt) = CH_NETLNK(i, j)
+              CHANLEN(cnt) = dist(i,j,8)   
+              CHANXI(cnt) = i
+              CHANYJ(cnt) = j
+#ifdef MPP_LAND
+             Link_Location(i,j) = cnt
+#endif
+#ifdef HYDRO_D
+!             print *, "Pour Point NW", TYPEL(cnt), LAKENODE(cnt), CHANLEN(cnt), cnt
+#endif
+802            continue
+           endif
+          endif !CH_NETRT check for this node
+         END DO
+       END DO 
+
+#ifdef MPP_LAND
+#ifdef HYDRO_D
+     print*, "my_id=",my_id, "cnt = ", cnt 
+#endif
+#endif
+ 
+#ifdef MPP_LAND
+     Link_location = CH_NETLNK
+     call MPP_CHANNEL_COM_INT(Link_location,ixrt,jxrt,TYPEL,NLINKS,99) 
+#endif
+
+! jump to here if UDMP_OPT .eq. 1
+299    continue
+
+!---- read in link routing data if not routing on grid, but on link network
+   IF (channel_option .eq. 3) THEN
+
+#ifdef MPP_LAND
+     if(my_id .eq. IO_id) then
+#endif
+
+        if (NLAKES.gt.0) then !read in only if there are lakes
+           open(unit=79,file='LAKEPARM.TBL', form='formatted',status='old')
+           write(6,*) "before read(79)  header for LAKEPARM.TBL"
+           call flush(6)
+           read(79,*)  header  !-- read the lake file
+        endif
+
+           do i=1, NLAKES
+             read (79,*,err=5101) tmp, HRZAREA(i),LAKEMAXH(i), &
+                WEIRC(i), WEIRL(i), ORIFICEC(i), ORIFICEA(i), ORIFICEE(i),&
+                LATLAKE(i), LONLAKE(i),ELEVLAKE(i), WEIRH(i)
+           enddo
+5101        continue
+           close(79)
+#ifdef MPP_LAND
+     endif
+
+       if(NLAKES .gt. 0) then
+          call mpp_land_bcast_real(NLAKES,HRZAREA)
+          call mpp_land_bcast_real(NLAKES,LAKEMAXH)
+          call mpp_land_bcast_real(NLAKES,WEIRH  )
+          call mpp_land_bcast_real(NLAKES,WEIRC  )
+          call mpp_land_bcast_real(NLAKES,WEIRL  )
+          call mpp_land_bcast_real(NLAKES,ORIFICEC)
+          call mpp_land_bcast_real(NLAKES,ORIFICEA)
+          call mpp_land_bcast_real(NLAKES,ORIFICEE)
+          call mpp_land_bcast_real(NLAKES,LATLAKE )
+          call mpp_land_bcast_real(NLAKES,LONLAKE )
+          call mpp_land_bcast_real(NLAKES,ELEVLAKE)
+       endif
+#endif
+
+!!-- if routing on link network, read those data too
+   ELSEIF ((CHANRTSWCRT.eq.1.or.CHANRTSWCRT.eq.2).AND.channel_option .ne. 3) then ! not routing on grid, read from file ? do we need the channel switch?
+
+        call readLinkSL( GNLINKSL,NLINKSL,route_link_f, route_lake_f,maxorder, &
+                   LINKID, TO_NODE, TYPEL, ORDER , &
+                   QLINK,CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, &
+                   MannN, So, ChSSlp, Bw, LAKEIDA, HRZAREA,  &
+                   LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, &
+                   ORIFICEA, ORIFICEE, gages, gageMiss, &
+                   LAKEIDM,NLAKES, latlake, lonlake)
+
+!--- get the lake configuration here.
+#ifdef MPP_LAND
+      call nhdLakeMap_mpp(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA, GNLINKSL)
+!      call nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA)
+#else
+       call nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA)
+#endif
+
+
+#ifdef MPP_LAND
+       if(NLAKES .gt. 0) then
+!         call mpp_land_bcast_int(NLINKSL,LAKEIDA) 
+!         call mpp_land_bcast_int(NLINKSL,LAKEIDX)
+
+          call mpp_land_bcast_real(NLAKES,HRZAREA)
+          call mpp_land_bcast_int(NLAKES,LAKEIDM)
+          call mpp_land_bcast_real(NLAKES,LAKEMAXH)
+          call mpp_land_bcast_real(NLAKES,WEIRH  )
+          call mpp_land_bcast_real(NLAKES,WEIRC  )
+          call mpp_land_bcast_real(NLAKES,WEIRL  )
+          call mpp_land_bcast_real(NLAKES,ORIFICEC)
+          call mpp_land_bcast_real(NLAKES,ORIFICEA)
+          call mpp_land_bcast_real(NLAKES,ORIFICEE)
+          call mpp_land_bcast_real(NLAKES,LATLAKE )
+          call mpp_land_bcast_real(NLAKES,LONLAKE )
+          call mpp_land_bcast_real(NLAKES,ELEVLAKE)
+       endif
+#endif
+
+    ENDIF   !channel option is 1 or 2 (linked routing)
+
+   RETURN !from READ_CHROUTING1
+
+!DJG -----------------------------------------------------
+   END SUBROUTINE READ_CHROUTING1
+
+   subroutine readLinkSL( GNLINKSL,NLINKSL,route_link_f, route_lake_f, maxorder, &
+                   LINKID, TO_NODE, TYPEL, ORDER , &
+                   QLINK,CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, &
+                   MannN, So, ChSSlp, Bw, LAKEIDA, HRZAREA,  &
+                   LAKEMAXH,WEIRH,  WEIRC, WEIRL, ORIFICEC, &
+                   ORIFICEA, ORIFICEE, gages, gageMiss,& 
+                   LAKEIDM,NLAKES, latlake, lonlake)
+
+        implicit none
+        character(len=*) :: route_link_f,route_lake_f
+        integer  :: GNLINKSL, NLINKSL, tmp_from_node,NLAKES
+
+        INTEGER, INTENT(INOUT)                   :: MAXORDER
+        INTEGER, intent(out), dimension(:) :: LAKEIDA, LINKID, TO_NODE, TYPEL, ORDER 
+
+        real,dimension(:,:)  :: QLINK
+        REAL, intent(out), dimension(:) ::  CHLON, CHLAT, ZELEV, MUSK, MUSX, CHANLEN, &
+                   MannN, So, ChSSlp, Bw, latlake, lonlake
+
+        character(len=15), dimension(:), intent(inout) :: gages
+        character(len=15), intent(in) :: gageMiss
+
+!NLAKES
+        INTEGER, intent(out), dimension(:)  ::  LAKEIDM
+        REAL, intent(out), dimension(:) :: HRZAREA,LAKEMAXH, WEIRC, WEIRL, ORIFICEC,WEIRH, &
+                   ORIFICEA, ORIFICEE
+!end NLAKES
+
+        INTEGER, dimension(GNLINKSL) ::  tmpLAKEIDA, tmpLINKID,  tmpTO_NODE, tmpTYPEL, tmpORDER 
+        character(len=15), dimension(gnlinksl) :: tmpGages
+        CHARACTER(len=155)	 :: header
+        integer :: i
+
+        character(len=256) :: route_link_f_r,route_lake_f_r
+        integer :: lenRouteLinkFR,lenRouteLakeFR ! so the preceeding chan be changed without changing code
+        logical :: routeLinkNetcdf, routeLakeNetcdf
+
+#ifdef MPP_LAND
+        real :: tmpQLINK(GNLINKSL,2)
+        REAL, allocatable, dimension(:) ::  tmpCHLON, tmpCHLAT, tmpZELEV, tmpMUSK, tmpMUSX, tmpCHANLEN, &
+                   tmpMannN, tmpSo, tmpChSSlp, tmpBw
+#endif 
+
+        !! is RouteLink file netcdf (*.nc) or csv (*.csv)
+        route_link_f_r = adjustr(route_link_f)
+        lenRouteLinkFR = len(route_link_f_r)
+        routeLinkNetcdf = route_link_f_r( (lenRouteLinkFR-2):lenRouteLinkFR) .eq. '.nc'
+
+        !! is RouteLake file netcdf (*.nc) or .TBL
+        route_lake_f_r = adjustr(route_lake_f)
+        lenRouteLakeFR = len(route_lake_f_r)
+        routeLakeNetcdf = route_lake_f_r( (lenRouteLakeFR-2):lenRouteLakeFR) .eq. '.nc'
+
+#ifdef MPP_LAND
+       tmpQLINK = 0
+       tmpGages = gageMiss
+ 
+       if(my_id .eq. IO_id) then
+
+          allocate(tmpCHLON(GNLINKSL))
+          allocate(tmpCHLAT(GNLINKSL))
+          allocate(tmpZELEV(GNLINKSL))
+          allocate(tmpMUSK(GNLINKSL))
+          allocate(tmpMUSX(GNLINKSL))
+          allocate(tmpCHANLEN(GNLINKSL))
+          allocate(tmpMannN(GNLINKSL))
+          allocate(tmpSo(GNLINKSL))
+          allocate(tmpChSSlp(GNLINKSL))
+          allocate(tmpBw(GNLINKSL))
+
+          if(routeLinkNetcdf) then
+
+             call read_route_link_netcdf(                                &
+                  route_link_f,                                          &
+                  tmpLINKID,     tmpTO_NODE,   tmpCHLON,                 &
+                  tmpCHLAT,      tmpZELEV,     tmpTYPEL,    tmpORDER,    &
+                  tmpQLINK(:,1), tmpMUSK,      tmpMUSX,     tmpCHANLEN,  &
+                  tmpMannN,      tmpSo,        tmpChSSlp,   tmpBw,       &
+                  tmpGages, tmpLAKEIDA)
+
+          else
+
+             open(unit=17,file=trim(route_link_f),form='formatted',status='old')
+             read(17,*)  header
+#ifdef HYDRO_D
+             print *, "header ", header, "NLINKSL = ", NLINKSL, GNLINKSL
+#endif
+             call flush(6)
+             do i=1,GNLINKSL
+                read (17,*) tmpLINKID(i),   tmp_from_node,   tmpTO_NODE(i), tmpCHLON(i),    &
+                            tmpCHLAT(i),    tmpZELEV(i),     tmpTYPEL(i),   tmpORDER(i),    &
+                            tmpQLINK(i,1),  tmpMUSK(i),      tmpMUSX(i),    tmpCHANLEN(i),  &
+                            tmpMannN(i),    tmpSo(i),        tmpChSSlp(i),  tmpBw(i)
+
+                ! if (So(i).lt.0.005) So(i) = 0.005  !-- impose a minimum slope requireement
+                if (tmpORDER(i) .gt. MAXORDER) MAXORDER = tmpORDER(i)
+             end do
+             close(17)
+          
+          end if  ! routeLinkNetcdf 
+
+          if(routeLakeNetcdf) then
+             call read_route_lake_netcdf(route_lake_f,HRZAREA, &
+                LAKEMAXH, WEIRH, WEIRC,    WEIRL, ORIFICEC,       &
+                ORIFICEA,  ORIFICEE, LAKEIDM, latlake, lonlake)
+          endif
+
+!!- initialize channel  if missing in input
+           do i=1,GNLINKSL
+              if(tmpQLINK(i,1) .le. 1e-3) then
+                 tmpQLINK(i,1) = 20.0 * (1.0/(float(MAXORDER+1) - float(tmpORDER(i))))**3
+                tmpQLINK(i,2) = tmpQLINK(i,1) !## initialize the current flow at each link
+              endif
+           end do
+
+       endif ! my_id .eq. IO_id
+
+        call ReachLS_decomp(tmpLINKID,  LINKID )
+        call ReachLS_decomp(tmpLAKEIDA, LAKEIDA )
+
+        call ReachLS_decomp(tmpTO_NODE, TO_NODE)
+        call ReachLS_decomp(tmpCHLON,    CHLON  )
+        call ReachLS_decomp(tmpCHLAT,    CHLAT  )
+        call ReachLS_decomp(tmpZELEV,    ZELEV  )
+        call ReachLS_decomp(tmpTYPEL,   TYPEL  )
+        call ReachLS_decomp(tmpORDER,   ORDER  )
+        call ReachLS_decomp(tmpQLINK(:,1), QLINK(:,1))
+        call ReachLS_decomp(tmpQLINK(:,2), QLINK(:,2))
+        call ReachLS_decomp(tmpMUSK,    MUSK   )
+        call ReachLS_decomp(tmpMUSX,     MUSX   )
+        call ReachLS_decomp(tmpCHANLEN,  CHANLEN)
+        call ReachLS_decomp(tmpMannN,       MannN  )
+        call ReachLS_decomp(tmpSo,       So     )
+        call ReachLS_decomp(tmpChSSlp,   ChSSlp )
+        call ReachLS_decomp(tmpBw,       Bw     )
+
+
+!       call ReachLS_decomp(tmpHRZAREA,  HRZAREA)
+!       call ReachLS_decomp(tmpLAKEMAXH, LAKEMAXH)
+!       call ReachLS_decomp(tmpWEIRC,    WEIRC  )
+!       call ReachLS_decomp(tmpWEIRL,    WEIRL  )
+!       call ReachLS_decomp(tmpORIFICEC, ORIFICEC)
+!       call ReachLS_decomp(tmpORIFICEA, ORIFICEA)
+!       call ReachLS_decomp(tmpORIFICEE, ORIFICEE)
+
+!yw This function does not work correctly for gages.
+!yw        call ReachLS_decomp(tmpGages,    gages)
+        call mpp_land_bcast_int1(MAXORDER)
+
+        if(NLAKES .gt. 0) then
+           call mpp_land_bcast_real(NLAKES, HRZAREA)
+           call mpp_land_bcast_real(NLAKES, LAKEMAXH)
+           call mpp_land_bcast_real(NLAKES, WEIRH)  
+           call mpp_land_bcast_real(NLAKES, WEIRC)  
+           call mpp_land_bcast_real(NLAKES, WEIRL)  
+           call mpp_land_bcast_real(NLAKES, ORIFICEC)
+           call mpp_land_bcast_real(NLAKES, ORIFICEA)
+           call mpp_land_bcast_real(NLAKES, ORIFICEE)
+           call mpp_land_bcast_int(NLAKES, LAKEIDM)
+        endif
+
+
+        if(my_id .eq. io_id ) then
+           if(allocated(tmpCHLON)) deallocate(tmpCHLON)
+           if(allocated(tmpCHLAT)) deallocate(tmpCHLAT)
+           if(allocated(tmpZELEV)) deallocate(tmpZELEV)
+           if(allocated(tmpMUSK)) deallocate(tmpMUSK)
+           if(allocated(tmpMUSX)) deallocate(tmpMUSX)
+           if(allocated(tmpCHANLEN)) deallocate(tmpCHANLEN)
+           if(allocated(tmpMannN)) deallocate(tmpMannN)
+           if(allocated(tmpSo)) deallocate(tmpSo)
+           if(allocated(tmpChSSlp)) deallocate(tmpChSSlp)
+           if(allocated(tmpBw)) deallocate(tmpBw)
+!, tmpHRZAREA,&
+!                  tmpLAKEMAXH, tmpWEIRC, tmpWEIRL, tmpORIFICEC, &
+!                  tmpORIFICEA,tmpORIFICEE)
+        endif
+
+#else
+       QLINK = 0 
+        if(routeLinkNetcdf) then
+
+          call read_route_link_netcdf(                     &
+                 route_link_f,                              &
+                 LINKID,     TO_NODE, CHLON,                &
+                 CHLAT,      ZELEV,     TYPEL,    ORDER,    &
+                 QLINK(:,1), MUSK,      MUSX,     CHANLEN,  &
+                 MannN,      So,        ChSSlp,   Bw,       &
+                 gages, LAKEIDA)
+           
+        else 
+
+          open(unit=17,file=trim(route_link_f),form='formatted',status='old')
+          read(17,*)  header
+#ifdef HYDRO_D
+          print *, "header ", header, "NLINKSL = ", NLINKSL
+#endif
+          do i=1,NLINKSL
+              read (17,*) LINKID(i), tmp_from_node, TO_NODE(i), CHLON(i),CHLAT(i),ZELEV(i), &
+                   TYPEL(i), ORDER(i), QLINK(i,1), MUSK(i), MUSX(i), CHANLEN(i), &
+                   MannN(i), So(i), ChSSlp(i), Bw(i)
+
+              ! if (So(i).lt.0.005) So(i) = 0.005  !-- impose a minimum slope requireement
+              if (ORDER(i) .gt. MAXORDER) MAXORDER = ORDER(i)
+          end do
+          close(17)
+
+        end if  ! routeLinkNetcdf 
+
+!!- initialize channel according to order if missing in input
+        do i=1,NLINKSL
+            if(QLINK(i,1) .le. 1e-3) then
+              QLINK(i,1) = 20.0 * (1/(float(MAXORDER+1) - float(ORDER(i))))**3
+              QLINK(i,2) = QLINK(i,1) !## initialize the current flow at each link
+            endif
+        end do
+        
+!!================================ 
+!!! need to add the sequential lake read here
+!!=================================
+
+
+#endif
+
+        do i=1,NLINKSL
+!           if(So(i) .lt. 0.001) So(i) = 0.001
+           So(i) = max(So(i), 0.00001)
+        end do
+
+#ifdef HYDRO_D
+       write(6,*) "finish read readLinkSL "
+       call flush(6) 
+
+#endif
+   end subroutine readLinkSL
+
+
+
+
+#ifdef MPP_LAND
+
+!yw continue
+
+       SUBROUTINE MPP_READ_CHROUTING_new(IXRT,JXRT,ELRT,CH_NETRT, CH_LNKRT,LAKE_MSKRT, &
+            FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, &
+            NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, &
+            LAKEIDA,HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, &
+            ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, LAKEIDM, LAKEIDX, &
+            route_link_f, &
+            route_lake_f, route_direction_f, route_order_f, &
+            CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, &
+            CHANXI, CHANYJ, CHLAT, CHLON,  &
+            channel_option,LATVAL,&
+            LONVAL,STRMFRXSTPTS,geo_finegrid_flnm,NLINKSL, LINKID, GNLINKSL,UDMP_OPT,g_ixrt,g_jxrt, &
+            gnlinks,GCH_NETLNK, map_l2g, link_location,yw_mpp_nlinks, &
+            lake_index, nlinks_index, gages, gageMiss)
+        implicit none
+        INTEGER, INTENT(IN)                          :: IXRT,JXRT,g_IXRT,g_JXRT, GNLINKS, UDMP_OPT
+        INTEGER                                      :: CHANRTSWCRT, NLINKS, NLAKES, NLINKSL
+        INTEGER                                      :: I,J,channel_option
+        CHARACTER(len=28)                            :: dir
+
+!----DJG,DNY New variables for channel and lake routing
+        CHARACTER(len=155)	 :: header
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: FROM_NODE
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: ZELEV
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: CHLAT,CHLON
+
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: TYPEL
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: TO_NODE,ORDER
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: STRMFRXSTPTS
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: LAKEIDA  !identifies which links in the domain are id'd as lakes
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: LAKEIDX  ! the integer lake id.
+
+        INTEGER, INTENT(INOUT)                       :: MAXORDER
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: MUSK, MUSX !muskingum
+        REAL, INTENT(INOUT),  DIMENSION(:,:)    :: QLINK  !channel flow
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: CHANLEN   !channel length
+        REAL, INTENT(INOUT),  DIMENSION(NLINKS)      :: MannN, So !mannings N
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: LAKENODE,LINKID  ! identifies which nodes pour into which lakes
+        REAL, INTENT(IN)                             :: dist(ixrt,jxrt,9)
+        INTEGER, INTENT(INOUT),  DIMENSION(NLINKS)   :: map_l2g
+
+!-- store the location x,y location of the channel element
+         INTEGER, INTENT(INOUT), DIMENSION(NLINKS)   :: CHANXI, CHANYJ
+
+!--reservoir/lake attributes
+        INTEGER, INTENT(INOUT),  DIMENSION(NLAKES)   :: LAKEIDM
+        REAL, INTENT(INOUT),  DIMENSION(NLAKES)      :: HRZAREA
+        REAL, INTENT(INOUT),  DIMENSION(NLAKES)      :: LAKEMAXH, WEIRH
+        REAL, INTENT(INOUT),  DIMENSION(NLAKES)      :: WEIRC
+        REAL, INTENT(INOUT),  DIMENSION(NLAKES)      :: WEIRL
+        REAL, INTENT(INOUT),  DIMENSION(NLAKES)      :: ORIFICEC
+        REAL, INTENT(INOUT),  DIMENSION(NLAKES)      :: ORIFICEA
+        REAL, INTENT(INOUT),  DIMENSION(NLAKES)      :: ORIFICEE
+        REAL, INTENT(INOUT),  DIMENSION(NLAKES)      :: LATLAKE,LONLAKE,ELEVLAKE
+        REAL, INTENT(INOUT), DIMENSION(NLINKS)       :: ChSSlp, Bw
+        character(len=15), intent(inout), dimension(nlinks) :: gages
+        character(len=15), intent(in)                :: gageMiss
+
+        CHARACTER(len=256)                           :: route_link_f
+        CHARACTER(len=256)                           :: route_lake_f
+        CHARACTER(len=256)                           :: route_direction_f
+        CHARACTER(len=256)                           :: route_order_f
+        CHARACTER(len=256)                           :: geo_finegrid_flnm
+        CHARACTER(len=256)                           :: var_name
+
+        INTEGER                                      :: tmp, cnt, ncid
+        real                                         :: gc,n
+
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT)    :: CH_NETLNK,GCH_NETLNK
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)       :: ELRT
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT, CH_LNKRT
+        INTEGER, INTENT(OUT), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT, link_location
+        REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)    :: latval,lonval
+        integer :: k
+        INTEGER, DIMENSION(nlinks)            :: node_table, nlinks_index
+        INTEGER, DIMENSION(nlakes)            :: lake_index
+        integer :: yw_mpp_nlinks , l, mpp_nlinks, GNLINKSL
+
+
+
+          call READ_CHROUTING1(IXRT,JXRT,ELRT,CH_NETRT, CH_LNKRT, LAKE_MSKRT, &
+            FROM_NODE, TO_NODE, TYPEL, ORDER, MAXORDER, NLINKS, &
+            NLAKES, MUSK, MUSX, QLINK, CHANLEN, MannN, So, ChSSlp, Bw, &
+            LAKEIDA,HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, &
+            ORIFICEE, LATLAKE, LONLAKE, ELEVLAKE, LAKEIDM, LAKEIDX, &
+            route_link_f, &
+            route_lake_f, route_direction_f, route_order_f, &
+            CHANRTSWCRT,dist, ZELEV, LAKENODE, CH_NETLNK, &
+            CHANXI, CHANYJ, CHLAT, CHLON,  &
+            channel_option,LATVAL,LONVAL, &
+            STRMFRXSTPTS,geo_finegrid_flnm , NLINKSL, LINKID, GNLINKSL,UDMP_OPT  &
+#ifdef MPP_LAND
+           ,Link_Location  &
+#endif
+           ,gages, gageMiss)
+
+      call mpp_land_max_int1(MAXORDER)
+
+      if(MAXORDER .eq. 0)  MAXORDER = -9999
+
+       lake_index = -99
+      if(channel_option .eq. 3) then
+         do j = 1, jxrt
+            do i = 1, ixrt
+              if (LAKE_MSKRT(i,j) .gt. 0) then
+                 lake_index(LAKE_MSKRT(i,j)) = LAKE_MSKRT(i,j)
+              endif
+            enddo
+         enddo
+      endif
+
+  
+      CHANXI = 0
+      CHANYj = 0
+      do j = 1, jxrt
+          do i = 1, ixrt
+             if(CH_NETLNK(i,j) .gt. 0) then
+               CHANXI(CH_NETLNK(i,j)) = i
+               CHANYJ(CH_NETLNK(i,j)) = j
+             endif
+          end do
+      end do
+
+      node_table = 0
+      yw_mpp_nlinks = 0
+      do j = 1, jxrt
+          do i = 1, ixrt
+            if(CH_NETLNK(i,j) .ge. 0) then
+               if( (i.eq.1) .and. (left_id .ge. 0) ) then
+                    continue
+               elseif ( (i.eq. ixrt) .and. (right_id .ge. 0) ) then
+                    continue
+               elseif ( (j.eq. 1) .and. (down_id .ge. 0) ) then
+                    continue
+               elseif ( (j.eq. jxrt) .and. (up_id .ge. 0) ) then
+                    continue
+               else
+                        l = CH_NETLNK(i,j)
+                        ! if(from_node(l) .gt. 0 .and. to_node(l) .gt. 0) then
+                             yw_mpp_nlinks = yw_mpp_nlinks + 1
+                             nlinks_index(yw_mpp_nlinks) = l
+                        ! endif
+               endif
+            endif
+          end do
+      end do
+
+#ifdef HYDRO_D
+       write(6,*) "nlinks=", nlinks, " yw_mpp_nlinks=", yw_mpp_nlinks," nlakes=", nlakes
+       call flush(6)
+#endif
+       if(NLAKES .gt. 0) then
+          call mpp_land_bcast_real(NLAKES,HRZAREA)
+          call mpp_land_bcast_real(NLAKES,LAKEMAXH)
+          call mpp_land_bcast_real(NLAKES,WEIRC)
+          call mpp_land_bcast_real(NLAKES,WEIRC)
+          call mpp_land_bcast_real(NLAKES,WEIRL)
+          call mpp_land_bcast_real(NLAKES,ORIFICEC)
+          call mpp_land_bcast_real(NLAKES,ORIFICEA)
+          call mpp_land_bcast_real(NLAKES,ORIFICEE)
+          call mpp_land_bcast_real(NLAKES,LATLAKE)
+          call mpp_land_bcast_real(NLAKES,LONLAKE)
+          call mpp_land_bcast_real(NLAKES,ELEVLAKE)
+       endif
+
+
+        link_location = CH_NETLNK
+
+        return 
+
+     end SUBROUTINE MPP_READ_CHROUTING_new
+
+#endif
+
+
+#ifdef MPP_LAND
+       subroutine out_day_crt(dayMean,outFile)
+           implicit none
+           integer :: did
+           real ::  dayMean(:)
+           character(len=*) :: outFile
+           integer:: ywflag
+           ywflag = -999
+           did = 1
+           if((nlst_rt(did)%olddate(12:13) .eq. "00") .and. (nlst_rt(did)%olddate(15:16) .eq. "00") ) ywflag = 99
+           call mpp_land_bcast_int1(ywflag)
+           if(ywflag <0) return
+           ! output daily
+           call out_obs_crt(did,dayMean,outFile)
+       end subroutine out_day_crt
+
+       subroutine out_obs_crt(did,dayMean,outFile)
+           implicit none
+           integer did, i, cnt
+           real ::  dayMean(:)
+           character(len=*) :: outFile
+           real,dimension(rt_domain(did)%gnlinks) :: g_dayMean, chlat, chlon
+           integer,dimension(rt_domain(did)%gnlinks) :: STRMFRXSTPTS
+           
+           g_dayMean = -999
+           chlat = -999
+           chlon = -999
+           STRMFRXSTPTS = 0
+
+           call write_chanel_int(RT_DOMAIN(did)%STRMFRXSTPTS,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,STRMFRXSTPTS)
+
+           call write_chanel_real(dayMean,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,g_dayMean)
+
+           call write_chanel_real(RT_DOMAIN(did)%CHLON,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,chlon)
+
+           call write_chanel_real(RT_DOMAIN(did)%CHLAT,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,rt_domain(did)%nlinks,chlat)
+
+
+           open (unit=75,file=outFile,status='unknown',position='append')
+           cnt = 0
+           do i = 1, rt_domain(did)%gnlinks
+              if(STRMFRXSTPTS(i) .gt. 0) then
+                   write(75,114) nlst_rt(did)%olddate(1:4),nlst_rt(did)%olddate(6:7),nlst_rt(did)%olddate(9:10), nlst_rt(did)%olddate(12:13), &
+                         cnt,chlon(i),chlat(i),g_dayMean(i) 
+                   cnt = cnt + 1
+              endif
+           end do
+           close(75)
+114 FORMAT(1x,A4,A2,A2,A2,",",I7,", ",F10.5,",",F10.5,",",F12.3)
+       end subroutine out_obs_crt
+#endif
+       
+    subroutine outPutChanInfo(fromNode,toNode,chlon,chlat)
+        implicit none
+        integer, dimension(:) :: fromNode,toNode
+        real, dimension(:) :: chlat,chlon
+        integer :: iret, nodes, i, ncid, dimid_n, varid
+
+        nodes = size(chlon,1)         
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create("nodeInfor.nc", NF_CLOBBER, ncid)
+#else
+       iret = nf_create("nodeInfor.nc", IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+       iret = nf_def_dim(ncid, "node", nodes, dimid_n)  !-- make a decimated grid
+!  define the varialbes
+       iret = nf_def_var(ncid,"fromNode",NF_INT,1,(/dimid_n/),varid)
+       iret = nf_def_var(ncid,"toNode",NF_INT,1,(/dimid_n/),varid)
+       iret = nf_def_var(ncid,"chlat",NF_FLOAT,1,(/dimid_n/),varid)
+          iret = nf_put_att_text(ncid,varid,'long_name',13,'node latitude')
+       iret = nf_def_var(ncid,"chlon",NF_FLOAT,1,(/dimid_n/),varid)
+          iret = nf_put_att_text(ncid,varid,'long_name',14,'node longitude')
+       iret = nf_enddef(ncid)
+!write to the file
+           iret = nf_inq_varid(ncid,"fromNode", varid)
+           iret = nf_put_vara_int(ncid, varid, (/1/), (/nodes/), fromNode)
+           iret = nf_inq_varid(ncid,"toNode", varid)
+           iret = nf_put_vara_int(ncid, varid, (/1/), (/nodes/), toNode)
+           iret = nf_inq_varid(ncid,"chlat", varid)
+           iret = nf_put_vara_real(ncid, varid, (/1/), (/nodes/), chlat)
+           iret = nf_inq_varid(ncid,"chlon", varid)
+           iret = nf_put_vara_real(ncid, varid, (/1/), (/nodes/), chlon)
+          iret = nf_close(ncid)
+    end subroutine outPutChanInfo
+
+
+!===================================================================================================
+! Program Name: read_route_link_netcdf
+! Author(s)/Contact(s): James L McCreight 
+! Abstract: Read in the "RouteLink.nc" netcdf file specifing the channel topology. 
+! History Log: 
+! 7/17/15 -Created, JLM.
+! Usage:
+! Parameters: 
+! Input Files: netcdf file RouteLink.nc or other name.
+! Output Files: None.
+! Condition codes: Currently incomplete error handling. 
+!
+! If appropriate, descriptive troubleshooting instructions or 
+! likely causes for failures could be mentioned here with the 
+! appropriate error code
+!
+! User controllable options: None. 
+
+subroutine read_route_link_netcdf( route_link_file,                         &
+                                   LINKID,   TO_NODE, CHLON,                &
+                                   CHLAT,    ZELEV,     TYPEL,    ORDER,    &
+                                   QLINK,    MUSK,      MUSX,     CHANLEN,  &
+                                   MannN,    So,        ChSSlp,   Bw,       &
+                                   gages, LAKEIDA                           )
+
+implicit none
+character(len=*),        intent(in)  :: route_link_file
+integer, dimension(:),   intent(out) :: LAKEIDA, LINKID, TO_NODE
+real,    dimension(:),   intent(out) :: CHLON, CHLAT, ZELEV
+integer, dimension(:),   intent(out) :: TYPEL, ORDER 
+real,    dimension(:),   intent(out) :: QLINK
+real,    dimension(:),   intent(out) :: MUSK, MUSX, CHANLEN
+real,    dimension(:),   intent(out) :: MannN,    So,       ChSSlp,   Bw
+character(len=15), dimension(:), intent(inout) :: gages
+
+integer :: iRet, ncid, ii, varid
+logical :: fatal_if_error
+fatal_if_error = .TRUE.  !! was thinking this would be a global variable...could become an input.
+
+#ifdef HYDRO_D
+print*,"start read_route_link_netcdf"
+#endif
+
+iRet = nf90_open(trim(route_link_file), nf90_nowrite, ncid)
+if (iRet /= nf90_noErr) then
+   write(*,'("read_route_link_netcdf: Problem opening: ''", A, "''")') trim(route_link_file)
+   if (fatal_IF_ERROR) call hydro_stop("read_route_link_netcdf: Problem opening file.")
+endif
+
+
+call get_1d_netcdf_int(ncid,  'link',     LINKID,    'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_int(ncid,  'NHDWaterbodyComID',  LAKEIDA, 'read_route_link_netcdf', .FALSE.)
+call get_1d_netcdf_int(ncid,  'to',       TO_NODE,   'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'lon',      CHLON,     'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'lat',      CHLAT,     'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'alt',      ZELEV,     'read_route_link_netcdf', .TRUE.)
+!yw call get_1d_netcdf_int(ncid,  'type',     TYPEL,     'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_int(ncid,  'order',    ORDER,     'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'Qi',       QLINK,     'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'MusK',     MUSK,      'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'MusX',     MUSX,      'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'Length',   CHANLEN,   'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'n',        MannN,     'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'So',       So,        'read_route_link_netcdf', .TRUE.)
+!! impose a minimum as this sometimes fails in the file.
+where(So .lt. 0.00001) So=0.00001
+call get_1d_netcdf_real(ncid, 'ChSlp',    ChSSlp,    'read_route_link_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'BtmWdth',  Bw,        'read_route_link_netcdf', .TRUE.)
+
+! gages is optional, only get it if it's defined in the file.
+iRet = nf90_inq_varid(ncid, 'gages', varid)
+if (iret .eq. nf90_NoErr) then
+   call get_1d_netcdf_text(ncid, 'gages', gages,  'read_route_link_netcdf', .true.)
+end if
+
+iRet = nf90_close(ncId)
+if (iRet /= nf90_noErr) then
+   write(*,'("read_route_link_netcdf: Problem closing: ''", A, "''")') trim(route_link_file)
+   if (fatal_IF_ERROR) call hydro_stop("read_route_link_netcdf: Problem closing file.")
+end if
+
+#ifdef HYDRO_D
+ii = size(LINKID)
+print*,'last index=',ii
+print*, 'CHLON', CHLON(ii), 'CHLAT', CHLAT(ii), 'ZELEV', ZELEV(ii)
+print*,'TYPEL', TYPEL(ii), 'ORDER', ORDER(ii), 'QLINK', QLINK(ii), 'MUSK', MUSK(ii)
+print*, 'MUSX', MUSX(ii), 'CHANLEN', CHANLEN(ii), 'MannN', MannN(ii)
+print*,'So', So(ii), 'ChSSlp', ChSSlp(ii), 'Bw', Bw(ii)
+print*,'gages(ii): ',trim(gages(ii))
+print*,"finish read_route_link_netcdf"
+#endif
+
+end subroutine read_route_link_netcdf
+
+
+!===================================================================================================
+! Program Name: read_route_lake_netcdf
+! Abstract: Read in the "LAKEPARM.nc" netcdf file specifing the channel topology. 
+! History Log: 
+! 7/17/15 -Created, JLM., then used by DNY
+! Usage:
+! Parameters: 
+! Input Files: netcdf file RouteLink.nc or other name.
+! Output Files: None.
+! Condition codes: Currently incomplete error handling. 
+!
+subroutine read_route_lake_netcdf(route_lake_file,                         &
+                                   HRZAREA,  LAKEMAXH, WEIRH,  WEIRC,    WEIRL,    &
+                                   ORIFICEC, ORIFICEA,  ORIFICEE, LAKEIDM, &
+                                   lakelat, lakelon)
+
+implicit none
+character(len=*),        intent(in)  :: route_lake_file
+integer, dimension(:),   intent(out) :: LAKEIDM
+real,    dimension(:),   intent(out) :: HRZAREA,  LAKEMAXH, WEIRC,    WEIRL, WEIRH
+real,    dimension(:),   intent(out) :: ORIFICEC, ORIFICEA, ORIFICEE, lakelat, lakelon
+
+integer :: iRet, ncid, ii, varid
+logical :: fatal_if_error
+fatal_if_error = .TRUE.  !! was thinking this would be a global variable...could become an input.
+
+#ifdef HYDRO_D
+print*,"start read_route_lake_netcdf"
+#endif
+   
+iRet = nf90_open(trim(route_lake_file), nf90_nowrite, ncid)
+if (iRet /= nf90_noErr) then
+   write(*,'("read_route_lake_netcdf: Problem opening: ''", A, "''")') trim(route_lake_file)
+   if (fatal_IF_ERROR) call hydro_stop("read_route_lake_netcdf: Problem opening file.")
+endif
+
+call get_1d_netcdf_int(ncid,  'lake_id',     LAKEIDM,   'read_route_lake_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'LkArea',   HRZAREA,   'read_route_lake_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'LkMxH',    LAKEMAXH,  'read_route_lake_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'WeirH',    WEIRH,     'read_route_lake_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'WeirC',    WEIRC,     'read_route_lake_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'WeirL',    WEIRL,     'read_route_lake_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'OrificeC', ORIFICEC,  'read_route_lake_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'OrificeA', ORIFICEA,  'read_route_lake_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'OrificeE', ORIFICEE,  'read_route_lake_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'lat', lakelat,  'read_route_lake_netcdf', .TRUE.)
+call get_1d_netcdf_real(ncid, 'lon', lakelon,  'read_route_lake_netcdf', .TRUE.)
+
+iRet = nf90_close(ncId)
+if (iRet /= nf90_noErr) then
+   write(*,'("read_route_lake_netcdf: Problem closing: ''", A, "''")') trim(route_lake_file)
+   if (fatal_IF_ERROR) call hydro_stop("read_route_lake_netcdf: Problem closing file.")
+end if
+
+#ifdef HYDRO_D
+ii = size(LAKEIDM)
+print*,'last index=',ii
+print*,'HRZAREA', HRZAREA(ii)
+print*,'LAKEMAXH', LAKEMAXH(ii), 'WEIRC', WEIRC(ii), 'WEIRL', WEIRL(ii)
+print*,'ORIFICEC', ORIFICEC(ii), 'ORIFICEA', ORIFICEA(ii), 'ORIFICEE', ORIFICEE(ii)
+print*,"finish read_route_lake_netcdf"
+#endif
+
+end subroutine read_route_lake_netcdf
+
+!===================================================================================================
+! Program Names: get_1d_netcdf_real, get_1d_netcdf_int, get_1d_netcdf_text
+! Author(s)/Contact(s): James L McCreight 
+! Abstract: Read a variable of real or integer type from an open netcdf file, respectively. 
+! History Log: 
+! 7/17/15 -Created, JLM.
+! Usage:
+! Parameters: See definitions.
+! Input Files: This file is refered to by it's "ncid" obtained from nc_open
+!              prior to calling this routine. 
+! Output Files: None.
+! Condition codes: hydro_stop is passed "get_1d_netcdf".
+!
+! If appropriate, descriptive troubleshooting instructions or 
+! likely causes for failures could be mentioned here with the 
+! appropriate error code
+!
+! User controllable options: None. 
+
+!! could define an interface for these. 
+subroutine get_1d_netcdf_int(ncid, varName, var, callingRoutine, fatal_if_error)
+integer,               intent(in)  :: ncid !! the file identifier
+character(len=*),      intent(in)  :: varName
+integer, dimension(:), intent(out) :: var
+character(len=*),      intent(in)  :: callingRoutine
+logical,               intent(in)  :: fatal_if_error
+integer :: varid, iret
+iRet = nf90_inq_varid(ncid, varName, varid)
+if (iret /= nf90_noErr) then
+   if (fatal_IF_ERROR) then
+      print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName)
+      call hydro_stop("get_1d_netcdf")
+   end if
+end if
+iRet = nf90_get_var(ncid, varid, var)
+if (iRet /= nf90_NoErr) then
+   print*, trim(callingRoutine) // ": get_1d_netcdf_int: values: " // trim(varName)
+   if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_int")
+end if
+end subroutine get_1d_netcdf_int
+
+
+subroutine get_1d_netcdf_real(ncid, varName, var, callingRoutine, fatal_if_error)
+integer,            intent(in)  :: ncid !! the file identifier
+character(len=*),   intent(in)  :: varName
+real, dimension(:), intent(out) :: var
+character(len=*),   intent(in)  :: callingRoutine
+logical,            intent(in)  :: fatal_if_error
+
+integer :: varid, iret
+iRet = nf90_inq_varid(ncid, varName, varid)
+if (iret /= nf90_noErr) then
+   if (fatal_IF_ERROR) then
+      print*, trim(callingRoutine) // ": get_1d_netcdf_real: variable: " // trim(varName)
+      call hydro_stop("get_1d_netcdf")
+   end if
+end if
+iRet = nf90_get_var(ncid, varid, var)
+if (iRet /= nf90_NoErr) then
+   print*, trim(callingRoutine) // ": get_1d_netcdf_real: values: " // trim(varName)
+   if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_real")
+end if
+end subroutine get_1d_netcdf_real
+
+subroutine get_1d_netcdf_text(ncid, varName, var, callingRoutine, fatal_if_error)
+integer,                        intent(in)  :: ncid !! the file identifier
+character(len=*),               intent(in)  :: varName
+character(len=*), dimension(:), intent(out) :: var
+character(len=*),               intent(in)  :: callingRoutine
+logical,                        intent(in)  :: fatal_if_error
+integer :: varId, iRet
+iRet = nf90_inq_varid(ncid, varName, varid)
+if (iret /= nf90_NoErr) then
+   print*, trim(callingRoutine) // ": get_1d_netcdf_text: variable: " // trim(varName)
+   if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text")
+end if
+iRet = nf90_get_var(ncid, varid, var)
+if (iret /= nf90_NoErr) then
+   print*, trim(callingRoutine) // ": get_1d_netcdf_text: values: " // trim(varName)
+   if (fatal_IF_ERROR) call hydro_stop("get_1d_netcdf_text")
+end if
+end subroutine get_1d_netcdf_text
+
+!===================================================================================================
+! Program Names: 
+!   get_netcdf_dim
+! Author(s)/Contact(s): 
+!   James L McCreight 
+! Abstract: 
+!   Get the length of a provided dimension.
+! History Log: 
+!   7/23/15 -Created, JLM.
+! Usage:
+! Parameters: 
+!   file: character, the file to query
+!   dimName: character, the name of the dimension
+!   callingRoutine: character, the name of the calling routine for error messages
+!   fatalErr: Optional, Logical - all errors are fatal, calling hydro_stop()
+! Input Files:  
+!   Specified argument. 
+! Output Files: 
+! Condition codes: 
+!   hydro_stop is called. .
+! User controllable options:
+! Notes: 
+
+function get_netcdf_dim(file, dimName, callingRoutine, fatalErr) 
+implicit none
+integer :: get_netcdf_dim  !! return value
+character(len=*), intent(in)   :: file, dimName, callingRoutine
+integer :: ncId, dimId, iRet
+logical, optional, intent(in) :: fatalErr
+logical :: fatalErr_local
+character(len=256) :: errMsg
+
+fatalErr_local = .false.
+if(present(fatalErr)) fatalErr_local=fatalErr
+
+write(*,'("getting dimension from file: ", A)') trim(file)
+iRet = nf90_open(trim(file), nf90_NOWRITE, ncId)
+if (iret /= nf90_noerr) then
+   write(*,'("Problem opening file: ", A)') trim(file)
+   if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
+endif
+
+iRet = nf90_inq_dimid(ncId, trim(dimName), dimId)
+if (iret /= nf90_noerr) then
+   write(*,'("Problem getting the dimension ID ", A)') &
+        '"' // trim(dimName) // '" in file: ' // trim(file)
+   if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
+endif
+
+iRet = nf90_inquire_dimension(ncId, dimId, len= get_netcdf_dim)
+if (iret /= nf90_noerr) then
+   write(*,'("Problem getting the dimension length of ", A)') &
+        '"' // trim(dimName) // '" in file: ' // trim(file)
+   if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
+endif
+
+iRet = nf90_close(ncId)
+if (iret /= nf90_noerr) then
+   write(*,'("Problem closing file: ", A)') trim(file)
+   if(fatalErr_local) call hydro_stop(trim(callingRoutine) // ': get_netcdf_dim')
+endif
+end function get_netcdf_dim
+
+
+! read the GWBUCET Parm for NHDPlus
+subroutine readBucket_nhd(infile, numbasns, gw_buck_coeff, gw_buck_exp, &
+                z_max, LINKID, nhdBuckMask)
+    implicit none
+    integer :: numbasns
+    integer, dimension(numbasns) :: LINKID
+    real, dimension(numbasns) :: gw_buck_coeff, gw_buck_exp, z_max
+    integer, dimension(numbasns) :: nhdBuckMask
+    character(len=*) :: infile
+!   define temp array
+    integer :: i,j,k, gnid, ncid, varid, ierr, dimid, iret
+    integer, allocatable, dimension(:) :: tmpLinkid
+    real, allocatable, dimension(:) :: tmpCoeff, tmpExp, tmpz_max
+
+!   get gnid
+#ifdef MPP_LAND
+    if(my_id .eq. io_id ) then
+#endif
+       iret = nf_open(trim(infile), NF_NOWRITE, ncid)
+#ifdef MPP_LAND
+       if(iret .ne. 0) then
+           call hydro_stop("Failed to open GWBUCKET Parameter file.")
+       endif
+       iret = nf_inq_dimid(ncid, "BasinDim", dimid)
+       if (iret /= 0) then
+               !print*, "nf_inq_dimid:  BasinDim"
+               call hydro_stop("Failed read GBUCKETPARM - nf_inq_dimid:  BasinDim")
+       endif
+       iret = nf_inq_dimlen(ncid, dimid, gnid)
+    endif
+    call mpp_land_bcast_int1(gnid)
+#endif
+    allocate(tmpLinkid(gnid))
+    allocate(tmpCoeff(gnid))
+    allocate(tmpExp(gnid))
+    allocate(tmpz_max(gnid))
+#ifdef MPP_LAND
+    if(my_id .eq. io_id ) then
+#endif
+!      read the file data.
+          iret = nf_inq_varid(ncid,"Coeff",  varid)
+          if(iret /= 0) then
+               print * , "could not find Coeff from ", infile
+               call hydro_stop("Failed to read BUCKETPARM")
+          endif
+          iret = nf_get_var_real(ncid, varid, tmpCoeff)
+
+          iret = nf_inq_varid(ncid,"Expon",  varid)
+          if(iret /= 0) then
+               print * , "could not find Expon from ", infile
+               call hydro_stop("Failed to read BUCKETPARM")
+          endif
+          iret = nf_get_var_real(ncid, varid, tmpExp)
+
+          iret = nf_inq_varid(ncid,"Zmax",  varid)
+          if(iret /= 0) then
+               print * , "could not find Zmax from ", infile
+               call hydro_stop("Failed to read BUCKETPARM")
+          endif
+          iret = nf_get_var_real(ncid, varid, tmpz_max)
+
+          iret = nf_inq_varid(ncid, "ComID",  varid)
+          if(iret /= 0) then
+               print * , "could not find ComID from ", infile
+               call hydro_stop("Failed to read BUCKETPARM")
+          endif
+          iret = nf_get_var_int(ncid, varid, tmpLinkid)
+#ifdef MPP_LAND
+    endif
+       if(gnid .gt. 0) then
+          call mpp_land_bcast_real_1d(tmpCoeff)
+          call mpp_land_bcast_real_1d(tmpExp)
+          call mpp_land_bcast_real_1d(tmpz_max)
+          call mpp_land_bcast_int(gnid ,tmpLinkid)
+       endif
+#endif
+   
+    nhdBuckMask = -999
+    do k = 1, numbasns
+        do i = 1, gnid
+            if(LINKID(k) .eq. tmpLinkid(i)) then
+               gw_buck_coeff(k) = tmpCoeff(i)
+               gw_buck_exp(k) = tmpExp(i)
+               z_max(k) = tmpz_max(i)
+               nhdBuckMask(k) = 1
+               goto 301 
+            endif
+        end do
+301     continue
+    end do 
+
+    if(allocated(tmpCoeff)) deallocate(tmpCoeff)
+    if(allocated(tmpExp)) deallocate(tmpExp)
+    if(allocated(tmpz_max)) deallocate(tmpz_max)
+    if(allocated(tmpLinkid)) deallocate(tmpLinkid)
+end subroutine readBucket_nhd
+
+!-- output the channel routine for fast output.
+!   subroutine mpp_output_chrt2(gnlinks,gnlinksl,map_l2g,igrid,                  &
+!        split_output_count, NLINKS, ORDER,                                     &
+!        startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch,              &
+!        K,STRMFRXSTPTS,order_to_write,NLINKSL,channel_option, gages, gageMiss, &
+!        lsmDt                                                                  &
+!        )
+
+#ifdef MPP_LAND
+   subroutine mpp_output_chrt2(gnlinks,gnlinksl,map_l2g,igrid,                  &
+        split_output_count, NLINKS, ORDER,                                     &
+        startdate, date, chlon, chlat, hlink,zelev,qlink,dtrt_ch,              &
+        K,NLINKSL,channel_option,linkid  &
+#ifdef WRF_HYDRO_NUDGING
+        , nudge                                     &
+#endif
+        , QLateral, iocflag ,velocity  &
+        , accLndRunOff, accQLateral, accStrmvolrt, accBucket, &
+        UDMP_OPT         &
+	)
+
+       USE module_mpp_land
+
+       implicit none
+
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid,K,NLINKSL
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLINKS
+     real, dimension(:),               intent(in) :: chlon,chlat
+     real, dimension(:),                  intent(in) :: hlink,zelev
+
+     integer, dimension(:),               intent(in) :: ORDER, linkid
+
+     real,                                     intent(in) :: dtrt_ch
+     real, dimension(:,:),                intent(in) :: qlink
+#ifdef WRF_HYDRO_NUDGING
+     real, dimension(:),                  intent(in) :: nudge
+#endif
+     real, dimension(:), intent(in) :: QLateral, velocity
+     integer, intent(in) :: iocflag
+     real, dimension(:), intent(in) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket
+     integer, intent(in) :: UDMP_OPT
+
+     integer :: channel_option
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+
+      integer  :: gnlinks, map_l2g(nlinks),  gnlinksl
+      real, allocatable,dimension(:) :: g_chlon,g_chlat, g_hlink,g_zelev
+#ifdef WRF_HYDRO_NUDGING
+      real, allocatable,dimension(:) :: g_nudge
+#endif
+      integer, allocatable,dimension(:) :: g_order, g_linkid
+      real,allocatable,dimension(:,:) :: g_qlink
+      integer  :: gsize
+      real, allocatable, dimension(:) :: g_accLndRunOff, g_accQLateral, g_accStrmvolrt, g_accBucket
+      real, allocatable, dimension(:) :: g_QLateral, g_velocity
+
+        gsize = gNLINKS
+        if(gnlinksl .gt. gsize) gsize = gnlinksl
+     if(my_id .eq. io_id ) then
+        allocate(g_chlon(gsize  ))
+        allocate(g_chlat(gsize  ))
+        allocate(g_hlink(gsize  ))
+        allocate(g_zelev(gsize  ))
+        allocate(g_qlink(gsize  ,2))
+#ifdef WRF_HYDRO_NUDGING
+        allocate(g_nudge(gsize))
+#endif
+        allocate(g_order(gsize  ))
+        allocate(g_linkid(gsize  ))
+
+        allocate(g_accLndRunOff(gsize  ))
+        allocate(g_accQLateral(gsize  ))
+        allocate(g_accStrmvolrt(gsize  ))
+        allocate(g_accBucket(gsize  ))
+
+        allocate(g_QLateral(gsize  ))
+        allocate(g_velocity(gsize  ))
+
+     else
+
+       allocate(g_accLndRunOff(1))
+       allocate(g_accQLateral(1))
+       allocate(g_accStrmvolrt(1))
+       allocate(g_accBucket(1))
+       allocate(g_QLateral(1))
+       allocate(g_velocity(1))
+
+        allocate(g_chlon(1))
+        allocate(g_chlat(1))
+        allocate(g_hlink(1))
+        allocate(g_zelev(1))
+        allocate(g_qlink(1,2))
+#ifdef WRF_HYDRO_NUDGING
+        allocate(g_nudge(1))
+#endif
+        allocate(g_order(1))
+        allocate(g_linkid(1))
+     endif
+
+     call mpp_land_sync()
+     if(channel_option .eq. 1 .or. channel_option .eq. 2) then
+        g_qlink = 0
+        call ReachLS_write_io(qlink(:,1), g_qlink(:,1))
+        call ReachLS_write_io(qlink(:,2), g_qlink(:,2))
+#ifdef WRF_HYDRO_NUDGING
+        g_nudge=0
+        call ReachLS_write_io(nudge,g_nudge)
+#endif
+        call ReachLS_write_io(order, g_order)
+        call ReachLS_write_io(linkid, g_linkid)
+        call ReachLS_write_io(chlon, g_chlon)
+        call ReachLS_write_io(chlat, g_chlat)
+        call ReachLS_write_io(zelev, g_zelev)
+
+        call ReachLS_write_io(accLndRunOff, g_accLndRunOff)
+        call ReachLS_write_io(accQLateral, g_accQLateral)
+        call ReachLS_write_io(accStrmvolrt, g_accStrmvolrt)
+        call ReachLS_write_io(accBucket, g_accBucket)
+
+        call ReachLS_write_io(QLateral, g_QLateral)
+        call ReachLS_write_io(velocity, g_velocity)
+        call ReachLS_write_io(hlink,g_hlink)
+
+     else
+        call write_chanel_real(qlink(:,1),map_l2g,gnlinks,nlinks,g_qlink(:,1))
+        call write_chanel_real(qlink(:,2),map_l2g,gnlinks,nlinks,g_qlink(:,2))
+        call write_chanel_int(order,map_l2g,gnlinks,nlinks,g_order)
+        call write_chanel_int(linkid,map_l2g,gnlinks,nlinks,g_linkid)
+        call write_chanel_real(chlon,map_l2g,gnlinks,nlinks,g_chlon)
+        call write_chanel_real(chlat,map_l2g,gnlinks,nlinks,g_chlat)
+        call write_chanel_real(zelev,map_l2g,gnlinks,nlinks,g_zelev)
+        call write_chanel_real(hlink,map_l2g,gnlinks,nlinks,g_hlink)
+     endif
+
+
+     if(my_id .eq. IO_id) then
+       call output_chrt2(igrid, split_output_count, GNLINKS, g_ORDER,                &
+          startdate, date, g_chlon, g_chlat, g_hlink,g_zelev,g_qlink,dtrt_ch,K,     &
+          gNLINKSL,channel_option, g_linkid  &
+#ifdef WRF_HYDRO_NUDGING
+          , g_nudge                                     &
+#endif
+          , g_QLateral, iocflag,g_velocity   &
+          , g_accLndRunOff, g_accQLateral, g_accStrmvolrt, g_accBucket, &
+          UDMP_OPT    &
+	  )
+     end if
+     call mpp_land_sync()
+    if(allocated(g_order)) deallocate(g_order)
+    if(allocated(g_chlon)) deallocate(g_chlon)
+    if(allocated(g_chlat)) deallocate(g_chlat)
+    if(allocated(g_hlink)) deallocate(g_hlink)
+    if(allocated(g_zelev)) deallocate(g_zelev)
+    if(allocated(g_qlink)) deallocate(g_qlink)
+    if(allocated(g_linkid)) deallocate(g_linkid)
+#ifdef WRF_HYDRO_NUDGING
+    if(allocated(g_nudge)) deallocate(g_nudge)
+#endif
+    if(allocated(g_QLateral)) deallocate(g_QLateral)
+    if(allocated(g_velocity)) deallocate(g_velocity)
+
+end subroutine mpp_output_chrt2
+
+#endif
+
+
+!subroutine output_chrt2 
+!For realtime output only when CHRTOUT_GRID = 2.
+!   subroutine output_chrt2(igrid, split_output_count, NLINKS, ORDER,             &
+!        startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
+!        STRMFRXSTPTS, order_to_write, NLINKSL, channel_option, gages, gageMiss, & 
+!        lsmDt                                                                   &
+!        )
+   subroutine output_chrt2(igrid, split_output_count, NLINKS, ORDER,             &
+        startdate, date, chlon, chlat, hlink, zelev, qlink, dtrt_ch, K,         &
+        NLINKSL, channel_option ,linkid &
+#ifdef WRF_HYDRO_NUDGING
+        , nudge                                     &
+#endif
+        , QLateral, iocflag, velocity   &
+        , accLndRunOff, accQLateral, accStrmvolrt, accBucket, &
+        UDMP_OPT    &
+        )
+     
+     implicit none
+#include 
+!!output the routing variables over just channel
+     integer,                                  intent(in) :: igrid,K,channel_option
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: NLINKS, NLINKSL
+     real, dimension(:),                  intent(in) :: chlon,chlat
+     real, dimension(:),                  intent(in) :: hlink,zelev
+     integer, dimension(:),               intent(in) :: ORDER
+
+     real,                                     intent(in) :: dtrt_ch
+     real, dimension(:,:),                intent(in) :: qlink
+#ifdef WRF_HYDRO_NUDGING
+     real, dimension(:),                  intent(in) :: nudge
+#endif
+     real, dimension(:), intent(in) :: QLateral, velocity
+     integer, intent(in) :: iocflag
+     real, dimension(nlinks), intent(in) :: accLndRunOff, accQLateral, accStrmvolrt, accBucket    
+     integer, intent(in)  :: UDMP_OPT
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+
+
+
+     integer, allocatable, DIMENSION(:)         :: linkid    
+
+     integer, allocatable, DIMENSION(:)         :: rec_num_of_station
+     integer, allocatable, DIMENSION(:)         :: rec_num_of_stationO
+
+     integer, allocatable, DIMENSION(:)         :: lOrder !- local stream order
+
+     integer, save  :: output_count
+     integer, save  :: ncid
+
+     integer :: stationdim, dimdata, varid, charid, n
+     integer :: timedim
+
+     integer :: iret,i !-- order_to_write is the lowest stream order to output
+     integer :: start_posO, prev_posO, nlk
+
+     integer :: previous_pos  !-- used for the station model
+     character(len=256) :: output_flnm
+     character(len=34)  :: sec_since_date
+     integer :: seconds_since,nstations,cnt,ObsStation
+     character(len=32)  :: convention
+     character(len=11),allocatable, DIMENSION(:)  :: stname
+
+     character(len=34) :: sec_valid_date
+
+    !--- all this for writing the station id string
+     INTEGER   TDIMS, TXLEN
+     PARAMETER (TDIMS=2)    ! number of TX dimensions
+     PARAMETER (TXLEN = 11) ! length of example string
+     INTEGER  TIMEID        ! record dimension id
+     INTEGER  TXID          ! variable ID
+     INTEGER  TXDIMS(TDIMS) ! variable shape
+     INTEGER  TSTART(TDIMS), TCOUNT(TDIMS)
+
+     !--  observation point  ids
+     INTEGER   OTDIMS, OTXLEN
+     PARAMETER (OTDIMS=2)    ! number of TX dimensions
+     PARAMETER (OTXLEN = 15) ! length of example string
+     INTEGER  OTIMEID        ! record dimension id
+     INTEGER  OTXID          ! variable ID
+     INTEGER  OTXDIMS(OTDIMS) ! variable shape
+     INTEGER  OTSTART(OTDIMS), OTCOUNT(OTDIMS)
+     character(len=19)  :: date19, date19start
+
+
+     seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1))
+
+
+     if(channel_option .ne. 3) then
+        nstations = NLINKSL
+     else
+        nstations = NLINKS
+     endif
+
+       if(split_output_count .ne. 1 ) then
+            write(6,*) "WARNING: split_output_count need to be 1 for this output option."
+       endif
+!-- have moved sec_since_date from above here..
+        sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
+                  //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
+
+        date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
+                  //startdate(12:13)//':'//startdate(15:16)//':00'
+
+        seconds_since = int(nlst_rt(1)%dt*(rt_domain(1)%out_counts-1))
+        sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) &
+                      //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC'
+
+        write(output_flnm, '(A12,".CHRTOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+
+#ifdef HYDRO_D
+        print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#else
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+        if (iret /= 0) then
+           print*,  "Problem nf_create points"
+           call hydro_stop("In output_chrt2() - Problem nf_create points.")
+        endif
+
+       iret = nf_def_dim(ncid, "station", nstations, stationdim)
+       iret = nf_def_dim(ncid, "time", 1, timedim)
+
+#ifndef HYDRO_REALTIME
+      !- station location definition all,  lat
+        iret = nf_def_var(ncid,"latitude",NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',16,'Station latitude')
+        iret = nf_put_att_text(ncid,varid,'units',13,'degrees_north')
+
+      !- station location definition,  long
+        iret = nf_def_var(ncid,"longitude",NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',17,'Station longitude')
+        iret = nf_put_att_text(ncid,varid,'units',12,'degrees_east')
+
+!     !-- elevation is ZELEV
+        iret = nf_def_var(ncid,"altitude",NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',16,'Station altitude')
+        iret = nf_put_att_text(ncid,varid,'units',6,'meters')
+
+!-- parent index
+!        iret = nf_def_var(ncid,"parent_index",NF_INT,1,(/stationdim/), varid)
+!        iret = nf_put_att_text(ncid,varid,'long_name',36,'index of the station for this record')
+
+
+     !-- prevChild
+!        iret = nf_def_var(ncid,"prevChild",NF_INT,1,(/stationdim/), varid)
+!        iret = nf_put_att_text(ncid,varid,'long_name',57,'record number of the previous record for the same station')
+        iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+
+     !-- lastChild
+!        iret = nf_def_var(ncid,"lastChild",NF_INT,1,(/stationdim/), varid)
+!        iret = nf_put_att_text(ncid,varid,'long_name',30,'latest report for this station')
+!        iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+#endif
+
+       if(UDMP_OPT .eq. 1) then
+          iret = nf_def_var(ncid, "accLndRunOff", NF_FLOAT, 1, (/stationdim/), varid)
+          iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?')
+          iret = nf_put_att_text(ncid,varid,'long_name',28,'ACCUMULATED runoff from land')
+
+          iret = nf_def_var(ncid, "accQLateral", NF_FLOAT, 1, (/stationdim/), varid)
+          iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?')
+          iret = nf_put_att_text(ncid,varid,'long_name',24,'Total ACCUMULATED runoff')
+
+          iret = nf_def_var(ncid, "accStrmvolrt", NF_FLOAT, 1, (/stationdim/), varid)
+          iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?')
+          iret = nf_put_att_text(ncid,varid,'long_name',39,'ACCUMULATED runoff from terrain routing')
+
+          iret = nf_def_var(ncid, "accBucket", NF_FLOAT, 1, (/stationdim/), varid)
+          iret = nf_put_att_text(ncid,varid,'units',8,'meter^3?')
+          iret = nf_put_att_text(ncid,varid,'long_name',32,'ACCUMULATED runoff from gw bucket')
+       endif
+
+        iret = nf_def_var(ncid,"time",NF_INT, 1, (/timedim/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date)
+        iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time')
+
+        !- flow definition, var
+        iret = nf_def_var(ncid, "streamflow", NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid,varid,'long_name',10,'River Flow')
+
+#ifdef WRF_HYDRO_NUDGING
+        !- nudge definition
+        iret = nf_def_var(ncid, "nudge", NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+        iret = nf_put_att_text(ncid,varid,'long_name',32,'Amount of stream flow alteration')
+#endif
+
+
+!     !- head definition, var
+      if(channel_option .eq. 3) then
+        iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'units',5,'meter')
+        iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage')
+      endif
+!#ifdef HYDRO_REALTIME
+!      if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) ) then
+!	iret = nf_def_var(ncid, "head", NF_FLOAT, 1, (/stationdim/), varid)
+!        iret = nf_put_att_text(ncid,varid,'units',5,'meter')
+!        iret = nf_put_att_text(ncid,varid,'long_name',11,'River Stage')
+!      endif
+!#endif
+
+
+	!-- NEW lateral inflow definition, var
+	if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) ) then
+	        iret = nf_def_var(ncid, "q_lateral", NF_FLOAT, 1, (/stationdim/), varid)
+       		iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+                iret = nf_put_att_text(ncid,varid,'long_name',25,'Runoff into channel reach')
+	endif
+
+        !-- NEW velocity definition, var
+        if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) .and. (iocflag .ne. 4) ) then
+        	iret = nf_def_var(ncid, "velocity", NF_FLOAT, 1, (/stationdim/), varid)
+        	iret = nf_put_att_text(ncid,varid,'units',9,'meter/sec')
+        	iret = nf_put_att_text(ncid,varid,'long_name',14,'River Velocity')
+	endif
+
+#ifndef HYDRO_REALTIME
+!     !- order definition, var
+        iret = nf_def_var(ncid, "order", NF_INT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',21,'Strahler Stream Order')
+        iret = nf_put_att_int(ncid,varid,'_FillValue',2,-1)
+#endif
+
+     !-- station  id
+     ! define character-position dimension for strings of max length 11
+        iret = nf_def_var(ncid, "station_id", NF_INT, 1, (/stationdim/), varid)
+        iret = nf_put_att_text(ncid,varid,'long_name',10,'Station id')
+
+         convention(1:32) = "Unidata Observation Dataset v1.0"
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "Conventions",32, convention)
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "cdm_datatype",7, "Station")
+#ifndef HYDRO_REALTIME
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_max",4, "90.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lat_min",5, "-90.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_max",5, "180.0")
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "geospatial_lon_min",6, "-180.0")
+#endif
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+         iret = nf_put_att_text(ncid, NF_GLOBAL, "station_dimension",7, "station")
+         iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+         iret = nf_put_att_int(ncid, NF_GLOBAL, "stream_order_output",NF_INT,1,1)
+
+
+         iret = nf_enddef(ncid)
+
+         iret = nf_inq_varid(ncid,"time", varid)
+         iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since)
+#ifndef HYDRO_REALTIME        
+        !-- write latitudes
+         iret = nf_inq_varid(ncid,"latitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chlat)
+
+        !-- write longitudes
+         iret = nf_inq_varid(ncid,"longitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chlon)
+
+        !-- write elevations
+         iret = nf_inq_varid(ncid,"altitude", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), zelev)
+
+        !-- write order
+         iret = nf_inq_varid(ncid,"order", varid)
+         iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), ORDER)
+#endif
+
+        !-- write stream flow
+         iret = nf_inq_varid(ncid,"streamflow", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), qlink(:,1))
+
+#ifdef WRF_HYDRO_NUDGING
+        !-- write nudge
+         iret = nf_inq_varid(ncid,"nudge", varid)
+         iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), nudge)
+#endif
+
+	!-- write head
+     	if(channel_option .eq. 3) then
+           iret = nf_inq_varid(ncid,"head", varid)
+           iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), hlink)
+	endif
+!#ifdef HYDRO_REALTIME
+!	if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) ) then
+!	      ! dummy value for now
+!              iret = nf_inq_varid(ncid,"head", varid)
+!              iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), chlon*0.-9999.)
+!        endif
+!#endif
+
+        !-- write lateral inflow
+	if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) ) then
+	        iret = nf_inq_varid(ncid,"q_lateral", varid)
+       		iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), QLateral)
+        endif
+
+        !-- writelvelocity (dummy value for now)
+	if ( (channel_option .ne. 3) .and. (iocflag .ge. 0) .and. (iocflag .ne. 4) ) then
+        	iret = nf_inq_varid(ncid,"velocity", varid)
+         	iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), velocity)
+	endif
+
+         if(UDMP_OPT .eq. 1) then
+
+            iret = nf_inq_varid(ncid,"accLndRunOff", varid)
+            iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), accLndRunOff)
+
+            iret = nf_inq_varid(ncid,"accQLateral", varid)
+            iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), accQLateral)
+
+            iret = nf_inq_varid(ncid,"accStrmvolrt", varid)
+            iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), accStrmvolrt)
+
+            iret = nf_inq_varid(ncid,"accBucket", varid)
+            iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), accBucket)
+
+         endif
+
+
+	!-- write id
+        iret = nf_inq_varid(ncid,"station_id", varid)
+        iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), linkid)
+
+
+
+
+      iret = nf_redef(ncid)
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(date)) = date
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate))
+
+
+      iret = nf_enddef(ncid)
+      iret = nf_sync(ncid)
+
+
+        iret = nf_close(ncid)
+
+#ifdef HYDRO_D
+     print *, "Exited Subroutine output_chrt"
+#endif
+
+
+end subroutine output_chrt2
+
+
+   subroutine output_GW_Diag(did)
+       implicit none
+       integer :: i , did, gnbasns
+
+#ifdef MPP_LAND
+       real, allocatable, dimension(:) :: g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas
+       integer, allocatable, dimension(:) :: g_basnsInd
+       if(my_id .eq. io_id) then
+          if(nlst_rt(did)%GWBASESWCRT.EQ.1) then
+               allocate(g_qin_gwsubbas(rt_domain(did)%gnumbasns))
+               allocate(g_qout_gwsubbas(rt_domain(did)%gnumbasns))
+               allocate(g_z_gwsubbas(rt_domain(did)%gnumbasns))
+               allocate(g_basnsInd(rt_domain(did)%gnumbasns))
+               gnbasns = rt_domain(did)%gnumbasns
+          else
+               allocate(g_qin_gwsubbas(rt_domain(did)%gnlinksl))
+               allocate(g_qout_gwsubbas(rt_domain(did)%gnlinksl))
+               allocate(g_z_gwsubbas(rt_domain(did)%gnlinksl))
+               allocate(g_basnsInd(rt_domain(did)%gnlinksl))
+               gnbasns = rt_domain(did)%gnlinksl 
+          endif
+       endif 
+     
+       if(nlst_rt(did)%channel_option .ne. 3) then
+          call ReachLS_write_io(rt_domain(did)%qin_gwsubbas,g_qin_gwsubbas)
+          call ReachLS_write_io(rt_domain(did)%qout_gwsubbas,g_qout_gwsubbas)
+          call ReachLS_write_io(rt_domain(did)%z_gwsubbas,g_z_gwsubbas)
+          call ReachLS_write_io(rt_domain(did)%linkid,g_basnsInd)
+       else
+          call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%qin_gwsubbas,  &
+                 rt_domain(did)%basnsInd,g_qin_gwsubbas)
+          call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%qout_gwsubbas,  & 
+                 rt_domain(did)%basnsInd,g_qout_gwsubbas)
+          call gw_write_io_real(rt_domain(did)%numbasns,rt_domain(did)%z_gwsubbas,  & 
+                 rt_domain(did)%basnsInd,g_z_gwsubbas)
+          call gw_write_io_int(rt_domain(did)%numbasns,rt_domain(did)%basnsInd,  &
+                 rt_domain(did)%basnsInd,g_basnsInd)
+       endif
+       if(my_id .eq. io_id) then
+!          open (unit=51,file='GW_inflow.txt',form='formatted',&
+!                status='unknown',position='append')
+!          open (unit=52,file='GW_outflow.txt',form='formatted',&
+!                status='unknown',position='append')
+!          open (unit=53,file='GW_zlev.txt',form='formatted',&
+!                status='unknown',position='append')
+!          do i=1,RT_DOMAIN(did)%gnumbasns
+!             write (51,951) i,nlst_rt(did)%olddate,g_qin_gwsubbas(i)
+951        FORMAT(I3,1X,A19,1X,F11.3)
+!            write (52,951) i,nlst_rt(did)%olddate,g_qout_gwsubbas(i)
+!            write (53,951) i,nlst_rt(did)%olddate,g_z_gwsubbas(i)
+!         end do  
+!         close(51)
+!         close(52)
+!         close(53)
+
+          call   output_gw_netcdf( nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, gnbasns, &
+                  trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), &
+                  g_basnsInd,g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas )
+          deallocate(g_qin_gwsubbas, g_qout_gwsubbas, g_z_gwsubbas, g_basnsInd)
+         
+       endif
+# else
+!       open (unit=51,file='GW_inflow.txt',form='formatted',&
+!             status='unknown',position='append')
+!       open (unit=52,file='GW_outflow.txt',form='formatted',&
+!             status='unknown',position='append')
+!       open (unit=53,file='GW_zlev.txt',form='formatted',&
+!             status='unknown',position='append')
+!       do i=1,RT_DOMAIN(did)%numbasns
+!          write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i)
+951        FORMAT(I3,1X,A19,1X,F11.3)
+!          write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i)
+!          write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i)
+!       end do  
+!       close(51)
+!       close(52)
+!       close(53)
+        if(nlst_rt(did)%GWBASESWCRT.EQ.1) then
+          call   output_gw_netcdf( nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, RT_DOMAIN(did)%numbasns, &
+                  trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), &
+                  rt_domain(did)%basnsInd,rt_domain(did)%qin_gwsubbas, &
+                  rt_domain(did)%qout_gwsubbas, rt_domain(did)%z_gwsubbas  )
+        else
+          call   output_gw_netcdf( nlst_rt(did)%igrid, nlst_rt(did)%split_output_count, RT_DOMAIN(did)%nlinksl, &
+                  trim(nlst_rt(did)%sincedate), trim(nlst_rt(did)%olddate), &
+                  rt_domain(did)%linkid,rt_domain(did)%qin_gwsubbas, &
+                  rt_domain(did)%qout_gwsubbas, rt_domain(did)%z_gwsubbas  )
+        endif
+#endif
+    end subroutine output_GW_Diag
+
+
+!----------------------------------- gw netcdf output
+
+   subroutine output_gw_netcdf(igrid, split_output_count, nbasns, &
+        startdate, date, &
+        gw_id_var, gw_in_var, gw_out_var, gw_z_var)
+
+     integer,                                  intent(in) :: igrid
+     integer,                                  intent(in) :: split_output_count
+     integer,                                  intent(in) :: nbasns
+     real, dimension(:),                  intent(in) :: gw_in_var, gw_out_var, gw_z_var
+     integer, dimension(:),               intent(in) :: gw_id_var
+
+     character(len=*),                         intent(in) :: startdate
+     character(len=*),                         intent(in) :: date
+
+
+     integer, save  :: output_count
+     integer, save :: ncid
+
+     integer :: basindim, varid,  n, nstations
+     integer :: iret,i    !-- 
+     character(len=256) :: output_flnm
+     character(len=19)  :: date19, date19start
+     character(len=32)  :: convention
+     integer :: timedim
+     integer :: seconds_since
+     character(len=34)  :: sec_since_date
+     character(len=34)  :: sec_valid_date
+
+     if(split_output_count .ne. 1 ) then
+            write(6,*) "WARNING: split_output_count need to be 1 for this output option."
+     endif
+
+     sec_since_date = 'seconds since '//startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10) &
+                  //' '//startdate(12:13)//':'//startdate(15:16)//' UTC'
+
+     date19start(1:len_trim(startdate)) = startdate(1:4)//'-'//startdate(6:7)//'-'//startdate(9:10)//'_' &
+                  //startdate(12:13)//':'//startdate(15:16)//':00'
+
+     seconds_since = int(nlst_rt(1)%out_dt*60*(rt_domain(1)%out_counts-1))
+     
+     sec_valid_date = 'seconds since '//nlst_rt(1)%startdate(1:4)//'-'//nlst_rt(1)%startdate(6:7)//'-'//nlst_rt(1)%startdate(9:10) &
+                      //' '//nlst_rt(1)%startdate(12:13)//':'//nlst_rt(1)%startdate(15:16)//' UTC'
+
+     write(output_flnm, '(A12,".GWOUT_DOMAIN",I1)') date(1:4)//date(6:7)//date(9:10)//date(12:13)//date(15:16), igrid
+
+#ifdef HYDRO_D
+      print*, 'output_flnm = "'//trim(output_flnm)//'"'
+#endif
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#else
+       iret = nf_create(trim(output_flnm), IOR(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+
+      if (iret /= 0) then
+          print*, "Problem nf_create" 
+          call hydro_stop("output_gw_netcdf") 
+      endif 
+
+!!! Define dimensions
+
+        nstations =nbasns
+
+      iret = nf_def_dim(ncid, "basin", nstations, basindim)
+
+      iret = nf_def_dim(ncid, "time", 1, timedim)
+
+!!! Define variables
+
+
+      !- gw basin ID
+      iret = nf_def_var(ncid,"gwbas_id",NF_INT, 1, (/basindim/), varid)
+      iret = nf_put_att_text(ncid,varid,'long_name',11,'GW basin ID')
+
+      !- gw inflow
+      iret = nf_def_var(ncid, "gw_inflow", NF_FLOAT, 1, (/basindim/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+
+      !- gw outflow
+      iret = nf_def_var(ncid, "gw_outflow", NF_FLOAT, 1, (/basindim/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',13,'meter^3 / sec')
+
+      !- depth in gw bucket
+      iret = nf_def_var(ncid, "gw_zlev", NF_FLOAT, 1, (/basindim/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',2,'mm')
+
+      ! Time variable
+      iret = nf_def_var(ncid, "time", NF_INT, 1, (/timeDim/), varid)
+      iret = nf_put_att_text(ncid,varid,'units',34,sec_valid_date)
+      iret = nf_put_att_text(ncid,varid,'long_name',17,'valid output time')
+
+      date19(1:19) = "0000-00-00_00:00:00"
+      date19(1:len_trim(startdate)) = startdate
+
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "model_initialization_time", 19, trim(nlst_rt(1)%startdate))
+      iret = nf_put_att_text(ncid, NF_GLOBAL, "model_output_valid_time", 19, trim(nlst_rt(1)%olddate))
+      iret = nf_put_att_real(ncid, NF_GLOBAL, "missing_value", NF_FLOAT, 1, -9E15)
+
+      iret = nf_enddef(ncid)
+
+!!! Input variables
+
+        !-- write lake id
+        iret = nf_inq_varid(ncid,"gwbas_id", varid)
+        iret = nf_put_vara_int(ncid, varid, (/1/), (/nstations/), gw_id_var)
+
+        !-- write gw inflow
+        iret = nf_inq_varid(ncid,"gw_inflow", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), gw_in_var  )
+
+        !-- write elevation  of inflow
+        iret = nf_inq_varid(ncid,"gw_outflow", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), gw_out_var  )
+
+        !-- write elevation  of inflow
+        iret = nf_inq_varid(ncid,"gw_zlev", varid)
+        iret = nf_put_vara_real(ncid, varid, (/1/), (/nstations/), gw_z_var  )
+
+        !-- write time variable
+        iret = nf_inq_varid(ncid,"time", varid)
+        iret = nf_put_vara_int(ncid, varid, (/1/), (/1/), seconds_since)
+
+        iret = nf_close(ncid)
+
+    end subroutine output_gw_netcdf
+
+!------------------------------- end gw netcdf output
+
+
+    subroutine read_NSIMLAKES(NLAKES,route_lake_f)
+        integer                     :: NLAKES
+        CHARACTER(len=256)          :: route_lake_f
+
+        character(len=256)          :: route_lake_f_r
+        integer                     :: lenRouteLakeFR, iRet, ncid, dimId
+        logical                     :: routeLakeNetcdf
+
+      !! is RouteLake file netcdf (*.nc) or  from the LAKEPARM.TBL ascii
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+#endif
+      route_lake_f_r = adjustr(route_lake_f)
+      lenRouteLakeFR = len(route_Lake_f_r)
+      routeLakeNetcdf = route_lake_f_r( (lenRouteLakeFR-2):lenRouteLakeFR) .eq. '.nc'
+
+
+      write(6,'("getting NLAKES from: ''", A, "''")') trim(route_lake_f)
+      write(6,*) "routeLakeNetcdf TF Name Len",routeLakeNetcdf, route_lake_f,lenRouteLakeFR
+      call flush(6)
+
+       if(routeLakeNetcdf) then
+          write(6,'("getting NLAKES from: ''", A, "''")') trim(route_lake_f)
+          NLAKES = get_netcdf_dim(trim(route_lake_f), 'nlakes',  &
+                                   'read_NSIMLAKES', fatalErr=.true.)
+        else
+!yw for IOC reach based routing, if netcdf lake file is not set from the hydro.namelist, 
+!    we will assume that no lake will be assimulated. 
+          write(6,*) "No lake nectdf file defined. NLAKES is set to be zero."
+          NLAKES = 0
+      endif 
+#ifdef MPP_LAND
+    endif ! end if block of my_id .eq. io_id
+         call mpp_land_bcast_int1(NLAKES)
+#endif
+
+    end subroutine read_NSIMLAKES
+
+! sequential code: not used.!!!!!!
+    subroutine nhdLakeMap(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, gTO_NODE,LINKID, LAKEIDM, LAKEIDA)
+        !--- get the lake configuration here.
+        implicit none
+        integer, dimension(:),   intent(inout) :: TYPEL, LAKELINKID, LAKEIDX
+        integer, dimension(:),   intent(inout) :: gTO_NODE
+        integer, dimension(:),   intent(inout) :: LINKID, LAKEIDM, LAKEIDA
+        integer, intent(in) :: NLAKES, NLINKSL 
+        integer, dimension(NLINKSL) :: OUTLAKEID
+        integer :: i,j,k, kk
+      
+        TYPEL = -999
+
+!! find the links that flow into lakes (e.g. TYPEL = 3), and update the TO_NODE, so that links flow into the lake reach
+#ifdef MPP_LAND
+     call nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, gTO_NODE,LINKID, LAKEIDM, LAKEIDA,NLINKSL)
+#endif
+
+        OUTLAKEID = gTO_NODE
+        DO i = 1, NLAKES
+          DO j = 1, NLINKSL
+            DO k = 1, NLINKSL
+
+              if( (gTO_NODE(j) .eq. LINKID(k) ) .and. &
+                  (LAKEIDA(k) .lt. 0 .and. LAKEIDA(j) .eq. LAKEIDM(i))) then
+                  TYPEL(j) = 1  !this is the link flowing out of the lake
+                  OUTLAKEID(j) = LAKEIDA(j) ! LINKID(j)
+                  LAKELINKID(i) = j
+!                    write(61,*) gTO_NODE(j),LAKEIDA(j),LAKEIDA(k),LAKELINKID(i) , j
+!                    call flush(61)
+              elseif( (gTO_NODE(j) .eq. LINKID(k)) .and. &
+                  (LAKEIDA(j) .lt. 0 .and. LAKEIDA(k) .gt. 0) .and. &
+                  (LAKEIDA(k) .eq. LAKEIDM(i)) ) then
+                  TYPEL(j) = 3 !type_3 inflow link to lake
+                  OUTLAKEID(j) = LAKEIDM(i)
+              elseif (LAKEIDA(j) .eq. LAKEIDM(i) .and. .not. TYPEL(j) .eq. 1) then
+                  TYPEL(j) = 2 ! internal lake linkd
+              endif
+            END DO
+          END DO
+       END DO
+
+       DO i = 1, NLAKES
+            if(LAKELINKID(i) .gt. 0) then
+                LAKEIDX(LAKELINKID(i)) = i
+            endif
+       ENDDO
+
+ ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link
+       DO i = 1, NLINKSL
+        DO j = 1, NLINKSL
+            if(TYPEL(i) .eq. 3 .and. TYPEL(j) .eq. 1 .and. (OUTLAKEID(j) .eq. OUTLAKEID(i))) then
+              gTO_NODE(i) = LINKID(j)  !   OUTLAKEID(i)
+            endif
+        ENDDO
+       ENDDO
+
+!     do k = 1, NLINKSL
+!         write(60+my_id,*) "k, typel, lakeidx", k, typel(k), lakeidx(k) 
+!         call flush(60+my_id)
+!     end do
+
+!     DO i = 1, NLINKSL
+!        write(61,*) i,LAKEIDX(i), TYPEL(i)
+!     end do
+!     DO i = 1, NLAKES 
+!        write(62,*) i,LAKELINKID(i)
+!        write(63,*) i,LAKEIDM(i)
+!     end do
+!     close(61)
+!     close(62)
+!     close(63)
+!     call hydro_finish()
+
+!   write(60,*) TYPEL
+!   write(63,*) LAKELINKID, LAKEIDX
+!   write(64,*) gTO_NODE
+!   write(61,*) LINKID
+!   write(62,*) LAKEIDM, LAKEIDA
+!   close(60)
+!   close(61)
+!   close(62)
+!   close(63)
+!   close(64)
+!   call hydro_finish()
+
+
+    end subroutine nhdLakeMap
+
+#ifdef MPP_LAND
+    subroutine nhdLakeMap_mpp(NLAKES, NLINKSL, TYPEL, LAKELINKID, LAKEIDX, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL)
+        !--- get the lake configuration here.
+        implicit none
+        integer, dimension(:),   intent(out) :: TYPEL, LAKELINKID, LAKEIDX
+        integer, dimension(:),   intent(inout) :: TO_NODE
+        integer, dimension(:),   intent(in) :: LINKID, LAKEIDA
+        integer, dimension(:),   intent(inout) :: LAKEIDM
+        integer, intent(in) :: NLAKES, NLINKSL ,GNLINKSL
+        integer, dimension(NLINKSL) :: OUTLAKEID
+        integer :: i,size ,j,k, kk, num, maxNum, m, mm
+        integer, allocatable, dimension(:) :: gLINKID, tmpTYPEL, tmpLINKID, ind,  &
+                    tmplakeida, tmpoutlakeid, tmpTO_NODE, gLAKEIDA, gLAKEIDX
+        integer, allocatable, dimension(:,:) :: gtonodeout
+    
+        integer,allocatable, dimension(:) ::  gto, tmpLAKELINKID, gTYPEL, gOUTLAKEID
+
+      integer tmpBuf(GNLINKSL)
+
+      allocate (gto(GNLINKSL))
+
+      if(my_id .eq. io_id) then
+         allocate (tmpLAKELINKID(nlakes) )
+      else
+         allocate (tmpLAKELINKID(1))
+      endif
+
+
+!     prescan the data and remove the LAKEIDM which point to two links.
+#ifdef MPP_LAND
+     call nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL)
+#endif
+
+   
+      call gBcastValue(TO_NODE,gto)   
+      maxNum = 0
+      kk = 0
+      do m = 1, NLINKSL
+          num = 0
+          do k = 1, gnlinksl
+             if(gto(k) .eq. LINKID(m) ) then
+                 kk = kk +1
+                 num = num + 1
+             endif
+          end do
+          if(num .gt. maxNum) maxNum = num
+      end do
+
+      allocate(ind(kk))
+      allocate(gToNodeOut(NLINKSL,maxNum+1))
+      gToNodeOut = -99
+      allocate(tmpTYPEL(kk))
+      allocate(tmpLINKID(kk))
+      allocate(tmpLAKEIDA(kk))
+      allocate(tmpOUTLAKEID(kk))
+      allocate(tmpTO_NODE(kk))
+
+      if(kk .gt. 0) then
+         tmpOUTLAKEID = -999
+         tmpTYPEL = -999
+         tmpTO_NODE = -999
+      endif
+      if(NLINKSL .gt. 0) then
+         OUTLAKEID = -999
+         TYPEL = -999
+      endif
+
+      kk = 0
+      do m = 1, NLINKSL
+         num = 1
+         do k = 1, gnlinksl
+             if(gto(k) .eq. LINKID(m) ) then
+                 kk = kk +1
+                 ind(kk) = k
+                 tmpTO_NODE(kk) = gto(k)
+                 gToNodeOut(m,num+1) = kk
+                 gToNodeOut(m,1) = num
+                 num = num + 1
+             endif
+          end do
+      end do
+      size = kk
+      if(allocated(gto)) deallocate (gto)
+    
+      allocate(gLINKID(gnlinksl))
+      call gBcastValue(LINKID,gLINKID)   
+      do i = 1, size
+            k = ind(i)
+            tmpLINKID(i) = gLINKID(k)
+      enddo
+
+      allocate(gLAKEIDA(gnlinksl))
+      call gBcastValue(LAKEIDA(1:NLINKSL),gLAKEIDA(1:gnlinksl) )   
+      do i = 1, size
+            k = ind(i)
+            tmpLAKEIDA(i) = gLAKEIDA(k)
+      enddo
+      if(allocated(gLAKEIDA)) deallocate(gLAKEIDA)
+
+!yw LAKELINKID = 0
+      tmpLAKELINKID = LAKELINKID
+      tmpOUTLAKEID  = tmpTO_NODE
+      OUTLAKEID(1:NLINKSL)  = TO_NODE(1:NLINKSL)
+
+ !! find the links that flow into lakes (e.g. TYPEL = 3), and update the TO_NODE, so that links flow into the lake reach
+        DO i = 1, NLAKES
+          DO k = 1, NLINKSL
+             do m = 1, gToNodeOut(k,1)
+                 j = gToNodeOut(k,m+1)
+                 if( (tmpTO_NODE(j) .eq. LINKID(k) ) .and. &
+                     (LAKEIDA(k) .lt. 0 .and. tmpLAKEIDA(j) .eq. LAKEIDM(i))) then
+                     tmpTYPEL(j) = 1  !this is the link flowing out of the lake
+                     tmpOUTLAKEID(j) = tmpLAKEIDA(j) !tmpLINKID(j) ! Wei Check
+                     LAKELINKID(i) = ind(j)
+!                    write(61,*) tmpTO_NODE(j),tmpLAKEIDA(j),LAKEIDA(k),LAKELINKID(i) 
+!                    call flush(61)
+                 elseif( (tmpTO_NODE(j) .eq. LINKID(k)) .and. &
+                     (tmpLAKEIDA(j) .lt. 0 .and. LAKEIDA(k) .gt. 0) .and. &
+                     (LAKEIDA(k) .eq. LAKEIDM(i)) ) then
+                     tmpTYPEL(j) = 3 !type_3 inflow link to lake
+                     tmpOUTLAKEID(j) = LAKEIDM(i) !Wei Check
+!                    write(62,*) tmpTO_NODE(j),tmpOUTLAKEID(j),LAKEIDM(i) 
+!                    call flush(62)
+                 elseif (tmpLAKEIDA(j) .eq. LAKEIDM(i) .and. tmpTYPEL(j) .ne. 1) then
+                     tmpTYPEL(j) = 2 ! internal lake linkd
+                     !! print the following to get the list of links which are ignored bc they are internal to lakes.
+                     !print*,'Ndg: tmpLAKEIDA(j):', tmpLAKEIDA(j)
+                 endif
+            END DO
+          END DO
+       END DO
+
+!yw       call sum_int1d(LAKELINKID, NLAKES) 
+       call updateLake_seqInt(LAKELINKID,nlakes,tmpLAKELINKID)
+
+       if(allocated(tmplakelinkid))  deallocate(tmpLAKELINKID)
+
+       if(gNLINKSL .gt. 0) then
+          if(my_id .eq. 0) then
+              allocate(gLAKEIDX(gNLINKSL))
+              gLAKEIDX = -999
+              DO i = 1, NLAKES
+                   if(LAKELINKID(i) .gt. 0) then
+                      gLAKEIDX(LAKELINKID(i)) = i
+                   endif
+              ENDDO
+          else
+              allocate(gLAKEIDX(1))
+          endif
+          call ReachLS_decomp(gLAKEIDX, LAKEIDX)
+          if(allocated(gLAKEIDX)) deallocate(gLAKEIDX)
+       endif
+
+!     do k = 1, size   
+!         write(70+my_id,*) "k, ind(k), typel, lakeidx", k, ind(k),tmpTYPEL(k), lakeidx(ind(k)) 
+!         call flush(70+my_id)
+!     end do
+       
+       call TONODE2RSL(ind,tmpTYPEL,size,gNLINKSL,NLINKSL,TYPEL(1:NLINKSL), -999 )
+       call TONODE2RSL(ind,tmpOUTLAKEID,size,gNLINKSL,NLINKSL,OUTLAKEID(1:NLINKSL), -999 )
+
+
+ ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link
+!yw       DO i = 1, NLINKSL
+!yw 105
+!     DO k = 1, NLINKSL
+!       do m = 1, gToNodeOut(k,1)
+!                i = gToNodeOut(k,m+1)
+!          DO j = 1, NLINKSL
+!             if (tmpTYPEL(i) .eq. 3 .and. TYPEL(j) .eq. 1 .and. (OUTLAKEID(j) .eq. tmpOUTLAKEID(i)) &
+!                  .and. tmpOUTLAKEID(i) .ne. -999) then
+!                    !yw tmpTO_NODE(i) = tmpOUTLAKEID(i)  !Wei Check
+!                    tmpTO_NODE(i) = LINKID(j)  !Wei Check
+!             endif 
+!          END DO
+!        END DO
+!     END DO 
+!     call TONODE2RSL(ind,tmpTO_NODE,size,gNLINKSL,NLINKSL,TO_NODE(1:NLINKSL), -999 )
+
+ ! assign the the inflow nodes to the lank with a new TO_NODE id, which is the outflow link
+      allocate(gTYPEL(gNLINKSL))
+      allocate(gOUTLAKEID(gNLINKSL))
+      call gBcastValue(TYPEL,gTYPEL)   
+      call gBcastValue(OUTLAKEID,gOUTLAKEID)   
+       DO i = 1, NLINKSL
+        DO j = 1, gNLINKSL
+            if(TYPEL(i) .eq. 3 .and. gTYPEL(j) .eq. 1 .and. (gOUTLAKEID(j) .eq. OUTLAKEID(i))) then
+              TO_NODE(i) = gLINKID(j)  !   OUTLAKEID(i)
+            endif
+        ENDDO
+       ENDDO
+      if(allocated(gLINKID)) deallocate(gLINKID)
+      if(allocated(gTYPEL)) deallocate(gTYPEL)
+      if(allocated(gOUTLAKEID)) deallocate(gOUTLAKEID)
+      if(allocated(tmpTYPEL)) deallocate(tmpTYPEL)
+      if(allocated(tmpLINKID)) deallocate(tmpLINKID)
+      if(allocated(tmpTO_NODE)) deallocate(tmpTO_NODE)
+      if(allocated(tmpLAKEIDA)) deallocate(tmpLAKEIDA)
+      if(allocated(tmpOUTLAKEID)) deallocate(tmpOUTLAKEID)
+
+
+!     do k = 1, NLINKSL
+!         write(60+my_id,*) "k, typel, lakeidx", k, typel(k), lakeidx(k) 
+!         call flush(60+my_id)
+!     end do
+      
+
+!     call ReachLS_write_io(TO_NODE(1:NLINKSL), tmpBuf(1:gNLINKSL) )
+!     if(my_id .eq. io_id ) then
+!       write(70,*) tmpBuf(1:gNLINKSL)
+!       call flush(70)
+!     endif
+!     call ReachLS_write_io(TYPEL(1:NLINKSL), tmpBuf(1:gNLINKSL) )
+!     if(my_id .eq. io_id ) then
+!       write(71,*) tmpBuf
+!       call flush(71)
+!     endif
+!     call ReachLS_write_io(LAKEIDX(1:NLINKSL), tmpBuf(1:gNLINKSL))
+!     if(my_id .eq. io_id ) then
+!       write(72,*) tmpBuf
+!       call flush(72)
+!       close(72)
+!     endif
+!     call ReachLS_write_io(OUTLAKEID(1:NLINKSL), tmpBuf(1:gNLINKSL))
+!     if(my_id .eq. io_id ) then
+!       write(73,*) tmpBuf
+!       call flush(73)
+!     endif
+!     call hydro_finish()
+
+!     DO i = 1, NLINKSL
+!        write(61,*) i,LAKEIDX(i), TYPEL(i)
+!     end do
+!     DO i = 1, NLAKES 
+!        write(63,*) i,LAKEIDM(i)
+!        write(62,*) i,LAKELINKID(i)
+!     end do
+!     close(61)
+!     close(62)
+!     close(63)
+
+!   write(60,*) TYPEL
+!   write(63,*) LAKELINKID, LAKEIDX
+!   write(64,*) TO_NODE
+!   write(61,*) LINKID
+!   write(62,*) LAKEIDM, LAKEIDA
+!   close(60)
+!   close(61)
+!   close(62)
+!   close(63)
+!   close(64)
+!   call hydro_finish()
+
+    end subroutine nhdLakeMap_mpp
+
+    subroutine nhdLakeMap_scan(NLAKES, NLINKSL, LAKELINKID, TO_NODE,LINKID, LAKEIDM, LAKEIDA,GNLINKSL)
+        !--- get the lake configuration here.
+        implicit none
+        integer, dimension(NLAKES) :: LAKELINKID
+        integer, dimension(:),   intent(in) :: TO_NODE
+        integer, dimension(:),   intent(in) :: LINKID, LAKEIDA
+        integer, dimension(:),   intent(inout) :: LAKEIDM
+        integer, intent(in) :: NLAKES, NLINKSL ,GNLINKSL
+        integer :: i,size ,j,k, kk, num, maxNum, m, mm
+        integer, allocatable, dimension(:) :: ind,  &
+                    tmplakeida, tmpoutlakeid, tmpTO_NODE, gLAKEIDA
+        integer, allocatable, dimension(:,:) :: gtonodeout
+    
+        integer,allocatable, dimension(:) ::  gto , tmpLAKELINKID, gtoLakeId_g, gtoLakeId
+
+!       integer tmpBuf(GNLINKSL)
+        integer, dimension(nlakes) :: lakemask
+        integer ii
+
+      allocate (gto(GNLINKSL))
+      allocate (gtoLakeId_g(GNLINKSL))
+      allocate (gtoLakeId(NLINKSL))
+      if(my_id .eq. io_id) then
+         allocate(tmpLAKELINKID(nlakes))
+      else
+         allocate(tmpLAKELINKID(1))
+      endif
+
+      gtoLakeId_g=-999
+ 
+      call gBcastValue(TO_NODE,gto)   
+      maxNum = 0
+      kk = 0
+      do m = 1, NLINKSL
+          num = 0
+          do k = 1, gnlinksl
+             if(gto(k) .eq. LINKID(m) ) then
+                 gtoLakeId_g(k) = lakeida(m)
+                 kk = kk +1
+                 num = num + 1
+             endif
+          end do
+          if(num .gt. maxNum) maxNum = num
+      end do
+
+      allocate(ind(kk))
+      allocate(gToNodeOut(NLINKSL,maxNum+1))
+      gToNodeOut = -99
+      allocate(tmpLAKEIDA(kk))
+      allocate(tmpTO_NODE(kk))
+
+
+      kk = 0
+      do m = 1, NLINKSL
+         num = 1
+         do k = 1, gnlinksl
+             if(gto(k) .eq. LINKID(m) ) then
+                 kk = kk +1
+                 ind(kk) = k
+                 tmpTO_NODE(kk) = gto(k)
+                 gToNodeOut(m,num+1) = kk
+                 gToNodeOut(m,1) = num
+                 num = num + 1
+             endif
+          end do
+      end do
+      size = kk
+      if(allocated(gto)) deallocate (gto)
+    
+
+      allocate(gLAKEIDA(gnlinksl))
+      call gBcastValue(LAKEIDA(1:NLINKSL),gLAKEIDA(1:gnlinksl) )   
+      do i = 1, size
+            k = ind(i)
+            tmpLAKEIDA(i) = gLAKEIDA(k)
+      enddo
+      if(allocated(gLAKEIDA)) deallocate(gLAKEIDA)
+
+        tmpLAKELINKID = LAKELINKID
+!       LAKELINKID = 0
+        DO i = 1, NLAKES
+          DO k = 1, NLINKSL
+             do m = 1, gToNodeOut(k,1)
+                 j = gToNodeOut(k,m+1)
+                 if( (tmpTO_NODE(j) .eq. LINKID(k) ) .and. &
+                     (LAKEIDA(k) .lt. 0 .and. tmpLAKEIDA(j) .eq. LAKEIDM(i))) then
+                     if(LAKELINKID(i) .gt. 0) then
+                         LAKELINKID(i) = -999
+#ifdef HYDRO_D
+                         write(6,*) "remove the lake  LAKEIDM(i) ", i, LAKEIDM(i)
+                         call flush(6)
+#endif
+                     endif
+                     if(LAKELINKID(i) .eq. 0) LAKELINKID(i) = ind(j)      
+                 endif
+            END DO
+          END DO
+       END DO
+!yw        call match1dLake(LAKELINKID, NLAKES, -999) 
+
+!yw double check
+      call combine_int1d(gtoLakeId_g,gnlinksl, -999) 
+      call ReachLS_decomp(gtoLakeId_g,gtoLakeId)
+
+       lakemask = 0
+       DO k = 1, NLINKSL
+          if(LAKEIDA(k) .gt. 0) then
+             DO i = 1, NLAKES
+                if(gtoLakeId(k) .eq. LAKEIDM(i) )  then
+                    goto 992
+                endif
+             enddo
+             DO i = 1, NLAKES
+                if(LAKEIDA(k) .eq. LAKEIDM(i) )  then
+                     lakemask(i) = lakemask(i) + 1
+                      goto 992
+                endif
+             enddo
+992          continue
+          endif
+       enddo
+
+       if(allocated(gtoLakeId_g)) deallocate(gtoLakeId_g)
+       if(allocated(gtoLakeId)) deallocate(gtoLakeId)
+       call sum_int1d(lakemask, NLAKES) 
+
+       do i = 1, nlakes
+           if(lakemask(i) .ne. 1) then
+               LAKELINKID(i) = -999
+#ifdef HYDRO_D
+               if(my_id .eq. IO_id) then
+                  write(6,*) "double check remove the lake : ",LAKEIDM(i)
+                  call flush(6)
+               endif
+#endif
+           endif
+       enddo
+
+
+!end double check
+
+
+       call updateLake_seqInt(LAKELINKID,nlakes,tmpLAKELINKID)
+
+!      if(my_id .eq. 0) then
+!          write(65,*) "check LAKEIDM   *****,"
+!          write(65,*) LAKEIDM
+!          call flush(6)
+!      endif
+
+       do k = 1, NLAKES
+           if(LAKELINKID(k) .eq. -999) LAKEIDM(k) = -999
+       end do
+
+!      if(my_id .eq. 0) then
+!          write(65,*) "check LAKEIDM   *****,"
+!          write(65,*) LAKEIDM
+!          call flush(6)
+!      endif
+
+       close(65)
+      if(allocated(tmpTO_NODE)) deallocate(tmpTO_NODE)
+      if(allocated(tmpLAKEIDA)) deallocate(tmpLAKEIDA)
+      if(allocated(tmplakelinkid)) deallocate(tmplakelinkid)
+
+    end subroutine nhdLakeMap_scan
+#endif
+  
+!ADCHANGE: New output lake types routine
+    subroutine output_lake_types( inNLINKS, inLINKID, inTYPEL )
+
+#ifdef MPP_LAND
+    use module_mpp_land
+#endif
+
+    implicit none
+#include 
+
+    integer, dimension(:),  intent(in) :: inLINKID, inTYPEL
+    integer, intent(in) :: inNLINKS
+
+    integer            :: iret
+    integer            :: ncid, varid
+    integer, parameter :: did=1
+    integer            :: linkdim
+    character(len=256), parameter :: output_flnm = "LAKE_TYPES.nc"
+
+    integer, allocatable, dimension(:) :: linkId, typeL
+
+#ifdef MPP_LAND
+
+    if(my_id .eq. io_id) then
+       allocate( linkId(inNLINKS)  )
+       allocate( typeL(inNLINKS)   )
+    else
+       allocate(linkId(1), typeL(1))
+    end if
+
+    call mpp_land_sync()
+    call ReachLS_write_io(inLINKID, linkId)
+    call ReachLS_write_io(inTYPEL, typeL)
+
+#else
+
+    allocate( linkId(inNLINKS) )
+    allocate( typeL(inNLINKS)  )
+
+    linkId    = inLINKID
+    typeL     = inTYPEL
+
+#endif
+
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+#endif
+
+       ! Create the channel connectivity file
+#ifdef HYDRO_D
+       print*,'Lakes: output_flnm = "'//trim(output_flnm)//'"'
+       flush(6)
+#endif
+
+#ifdef WRFIO_NCD_NO_LARGE_FILE_SUPPORT
+       write(6,*) "using normal netcdf file for LAKE TYPES"
+       iret = nf_create(trim(output_flnm), NF_CLOBBER, ncid)
+#else
+       write(6,*) "using large netcdf file for LAKE TYPES"
+       iret = nf_create(trim(output_flnm), ior(NF_CLOBBER,NF_64BIT_OFFSET), ncid)
+#endif
+
+       if (iret /= 0) then
+          print*,"Lakes: Problem nf_create"
+          call hydro_stop("output_lake_types")
+       endif
+
+       iret = nf_def_dim(ncid, "link", inNLINKS, linkdim)
+
+       !-- link  id
+       iret = nf_def_var(ncid, "LINKID", NF_INT, 1, (/linkdim/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',10,'Link ID')
+
+       !- lake reach type, var
+       iret = nf_def_var(ncid, "TYPEL", NF_INT, 1, (/linkdim/), varid)
+       iret = nf_put_att_text(ncid,varid,'long_name',15,'Lake reach type')
+
+       iret = nf_enddef(ncid)
+
+       !-- write id
+       iret = nf_inq_varid(ncid,"LINKID", varid)
+       iret = nf_put_vara_int(ncid, varid, (/1/), (/inNLINKS/), linkId)
+
+       !-- write type
+       iret = nf_inq_varid(ncid,"TYPEL", varid)
+       iret = nf_put_vara_int(ncid, varid, (/1/), (/inNLINKS/), typeL)
+
+       iret = nf_close(ncid)
+
+#ifdef MPP_LAND
+    endif
+#endif
+    if(allocated(linkId)) deallocate(linkId)
+    if(allocated(typeL)) deallocate(typeL)
+
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+#endif
+#ifdef HYDRO_D
+    write(6,*) "end of output_lake_types"
+    flush(6)
+#endif
+#ifdef MPP_LAND
+    endif
+#endif
+
+end subroutine output_lake_types
+
+
+end module module_HYDRO_io
diff --git a/wrfv2_fire/hydro/Routing/module_HYDRO_utils.F b/wrfv2_fire/hydro/Routing/module_HYDRO_utils.F
new file mode 100644
index 00000000..8a1fde3b
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_HYDRO_utils.F
@@ -0,0 +1,417 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+module module_HYDRO_utils
+  use module_RT_data, only: rt_domain
+  use module_namelist, only: nlst_rt
+#ifdef MPP_LAND
+     use module_mpp_land, only: global_nx, global_ny, my_id, IO_id, &
+           decompose_data_real, write_io_real, MPP_LAND_COM_REAL, &
+           write_io_int, mpp_land_bcast_real, global_rt_nx, global_rt_ny, &
+           decompose_rt_real, write_io_rt_real
+     use MODULE_mpp_GWBUCKET, only: gw_decompose_real
+#endif
+
+
+  implicit none
+  logical lr_dist_flag    !land routing distance calculated or not. 
+  
+contains
+
+        integer function get2d_real(var_name,out_buff,ix,jx,fileName)
+          implicit none
+#         include "netcdf.inc"
+          integer :: ivar, iret,varid,ncid,ix,jx
+          real out_buff(ix,jx)
+          character(len=*), intent(in) :: var_name
+          character(len=*), intent(in) :: fileName
+          get2d_real = -1
+
+          iret = nf_open(trim(fileName), NF_NOWRITE, ncid)
+          if (iret .ne. 0) then
+#ifdef HYDRO_D
+            print*,"Failed to open the netcdf file: ",trim(fileName)
+#endif
+            out_buff = -9999.
+            return
+          endif
+          ivar = nf_inq_varid(ncid,trim(var_name),  varid)
+          if(ivar .ne. 0) then
+            ivar = nf_inq_varid(ncid,trim(var_name//"_M"),  varid)
+            if(ivar .ne. 0) then
+#ifdef HYDRO_D
+               write(6,*) "Read Error: could not find ",var_name
+#endif
+                 return
+            endif
+          end if
+          iret = nf_get_var_real(ncid, varid, out_buff)
+          iret = nf_close(ncid)
+          get2d_real =  ivar
+      end function get2d_real
+
+ 
+! this module create the distance dx, dy and diagnoal for routing
+! 8 direction as the slop:
+! 1: i,j+1  
+! 2: i+1, j+1
+! 3: i+1, j
+! 4: i+1, j-1
+! 5: i, j-1
+! 6: i-1, j-1
+! 7: i-1, j
+! 8: i-1, j+1
+   real function get_dy(i,j,v,ix,jx)  
+      ! south north
+       integer :: i,j,ix,jx
+       real,dimension(ix,jx,9) :: v 
+       if( v(i,j,1) .le. 0) then
+          get_dy = v(i,j,5)
+       else if( v(i,j,5) .le. 0) then
+          get_dy = v(i,j,1)
+       else
+          get_dy = (v(i,j,1) + v(i,j,5) ) / 2
+       endif
+       return
+   end function get_dy
+
+   real function get_dx(i,j,v,ix,jx)   
+      ! east-west
+       integer :: i,j, ix,jx
+       real,dimension(ix,jx,9) :: v 
+       if( v(i,j,3) .le. 0) then
+          get_dx = v(i,j,7)
+       else if( v(i,j,7) .le. 0) then
+          get_dx = v(i,j,3)
+       else
+          get_dx = (v(i,j,3) + v(i,j,7) ) / 2
+       endif
+       return
+   end function get_dx
+
+   real function get_ll_d(lat1_in, lat2_in, lon1_in, lon2_in)
+     implicit none
+     real:: lat1, lat2, lon1, lon2
+     real:: lat1_in, lat2_in, lon1_in, lon2_in
+     real::  r, pai, a,c, dlat, dlon, b1,b2
+     pai = 3.14159
+     lat1 = lat1_in * pai/180
+     lat2 = lat2_in * pai/180
+     lon1 = lon1_in * pai/180
+     lon2 = lon2_in * pai/180
+     r = 6378.1*1000
+     dlat = lat2 -lat1
+     dlon = lon2 -lon1
+     a = sin(dlat/2)*sin(dlat/2) + cos(lat1)*cos(lat2)*sin(dlon/2)*sin(dlon/2)
+     b1 = sqrt(a) 
+     b2 = sqrt(1-a)  
+     c = 2.0*atan2(b1,b2)
+     get_ll_d = R*c
+     return 
+
+   end function get_ll_d
+
+   real function get_ll_d_tmp(lat1_in, lat2_in, lon1_in, lon2_in)
+     implicit none
+     real:: lat1, lat2, lon1, lon2
+     real:: lat1_in, lat2_in, lon1_in, lon2_in
+     real::  r, pai
+     pai = 3.14159
+     lat1 = lat1_in * pai/180
+     lat2 = lat2_in * pai/180
+     lon1 = lon1_in * pai/180
+     lon2 = lon2_in * pai/180
+     r = 6371*1000
+     get_ll_d_tmp = acos(sin(lat1)*sin(lat2)+cos(lat1)*cos(lat2)*cos(lon2-lon1))*r
+     return 
+
+   end function get_ll_d_tmp
+
+   subroutine get_rt_dxdy_ll(did)
+!   use the land lat and lon to derive the routing distrt
+      implicit none
+      integer:: did, k
+      integer iret
+!     external get2d_real
+!     real get2d_real
+#ifdef MPP_LAND
+      real, dimension(global_rt_nx,global_rt_ny):: latrt, lonrt
+      real, dimension(global_rt_nx,global_rt_ny,9):: dist
+      if(my_id .eq. IO_id) then
+ ! read the lat and lon. 
+         iret =  get2d_real("LONGITUDE",lonrt,global_rt_nx,global_rt_ny,&
+                     trim(nlst_rt(did)%GEO_FINEGRID_FLNM ))
+         iret =  get2d_real("LATITUDE",latrt,global_rt_nx,global_rt_ny,&
+                     trim(nlst_rt(did)%GEO_FINEGRID_FLNM ))
+         call get_dist_ll(dist,latrt,lonrt,global_rt_nx,global_rt_ny)
+      end if
+     do k = 1 , 9
+        call decompose_RT_real(dist(:,:,k),rt_domain(did)%dist(:,:,k), &
+                global_rt_nx,global_rt_ny,rt_domain(did)%ixrt,rt_domain(did)%jxrt)
+     end do
+#else
+      real, dimension(rt_domain(did)%ixrt,rt_domain(did)%jxrt):: latrt, lonrt
+ ! read the lat and lon. 
+         iret =  get2d_real("LONGITUDE",lonrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt,&
+                     trim(nlst_rt(did)%GEO_FINEGRID_FLNM ))
+         iret =  get2d_real("LATITUDE",latrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt,&
+                     trim(nlst_rt(did)%GEO_FINEGRID_FLNM ))
+         call get_dist_ll(rt_domain(did)%dist,latrt,lonrt,rt_domain(did)%ixrt,rt_domain(did)%jxrt)
+#endif
+
+   end subroutine get_rt_dxdy_ll
+
+!  get dx and dy of lat and lon   
+   subroutine get_dist_ll(dist,lat,lon,ix,jx)
+      implicit none
+      integer:: ix,jx 
+      real, dimension(ix,jx,9):: dist
+      real, dimension(ix,jx):: lat, lon
+      integer:: i,j 
+      real x,y 
+      dist = -1
+      do j = 1, jx
+        do i = 1, ix
+          if(j .lt. jx) dist(i,j,1) = &
+             get_ll_d(lat(i,j), lat(i,j+1), lon(i,j), lon(i,j+1))
+          if(j .lt. jx .and. i .lt. ix) dist(i,j,2) =  &
+             get_ll_d(lat(i,j), lat(i+1,j+1), lon(i,j), lon(i+1,j+1))
+          if(i .lt. ix) dist(i,j,3) = &    
+             get_ll_d(lat(i,j), lat(i+1,j), lon(i,j), lon(i+1,j))
+          if(j .gt. 1 .and. i .lt. ix) dist(i,j,4) = &    
+             get_ll_d(lat(i,j), lat(i+1,j-1), lon(i,j), lon(i+1,j-1))
+          if(j .gt. 1 ) dist(i,j,5) = &   
+             get_ll_d(lat(i,j), lat(i,j-1), lon(i,j), lon(i,j-1))
+          if(j .gt. 1 .and. i .gt. 1) dist(i,j,6) = &   
+             get_ll_d(lat(i,j), lat(i-1,j-1), lon(i,j), lon(i-1,j-1))
+          if(i .gt. 1) dist(i,j,7) = &   
+             get_ll_d(lat(i,j), lat(i-1,j), lon(i,j), lon(i-1,j))
+          if(j .lt. jx .and. i .gt. 1) dist(i,j,8) = &   
+             get_ll_d(lat(i,j), lat(i-1,j+1), lon(i,j), lon(i-1,j+1))
+        end do
+      end do
+      do j = 1, jx 
+        do i = 1, ix
+            if(j.eq.1) then
+               y =  get_ll_d(lat(i,j), lat(i,j+1), lon(i,j), lon(i,j+1))
+            else if(j.eq.jx) then 
+               y =  get_ll_d(lat(i,j-1), lat(i,j), lon(i,j-1), lon(i,j))
+            else
+               y =  get_ll_d(lat(i,j-1), lat(i,j+1), lon(i,j-1), lon(i,j+1))/2.0
+            endif
+
+            if(i.eq.ix) then
+                x =  get_ll_d(lat(i,j), lat(i-1,j), lon(i,j), lon(i-1,j))
+            else if(i.eq.1) then
+                x =  get_ll_d(lat(i,j), lat(i+1,j), lon(i,j), lon(i+1,j))
+            else
+                x =  get_ll_d(lat(i-1,j), lat(i+1,j), lon(i-1,j), lon(i+1,j))/2.0
+            endif
+            dist(i,j,9) = x * y 
+        end do
+      end do
+#ifdef HYDRO_D
+      write(6,*) "finished get_dist_ll"
+#endif
+   end subroutine get_dist_ll
+
+!  get dx and dy of map projected
+   subroutine get_dxdy_mp(dist,ix,jx,dx,dy)
+      implicit none
+      integer:: ix,jx 
+      real :: dx,dy
+      integer:: i,j 
+      real :: v1
+      ! out variable
+      real, dimension(ix,jx,9)::dist
+      dist = -1
+      v1 = sqrt(dx*dx + dy*dy)
+      do j = 1, jx
+        do i = 1, ix
+          if(j .lt. jx) dist(i,j,1) = dy 
+          if(j .lt. jx .and. i .lt. ix) dist(i,j,2) = v1 
+          if(i .lt. ix) dist(i,j,3) = dx 
+          if(j .gt. 1 .and. i .lt. ix) dist(i,j,4) = v1 
+          if(j .gt. 1 ) dist(i,j,5) = dy 
+          if(j .gt. 1 .and. i .gt. 1) dist(i,j,6) = v1 
+          if(i .gt. 1) dist(i,j,7) = dx 
+          if(j .lt. jx .and. i .gt. 1) dist(i,j,8) = v1 
+          dist(i,j,9) = dx * dy
+        end do
+      end do
+#ifdef HYDRO_D
+      write(6,*) "finished get_dxdy_mp "
+#endif
+   end subroutine get_dxdy_mp
+
+   subroutine get_dist_lsm(did)
+     integer did
+#ifdef MPP_LAND
+     integer ix,jx,ixrt,jxrt, k
+     real , dimension(global_nx,global_ny):: latitude,longitude
+     real, dimension(global_nx,global_ny,9):: dist 
+     if(nlst_rt(did)%dxrt0 .lt. 0) then
+           ! lat and lon grid
+          call write_io_real(rt_domain(did)%lat_lsm,latitude) 
+          call write_io_real(rt_domain(did)%lon_lsm,longitude) 
+          if(my_id.eq.IO_id) then
+               call get_dist_ll(dist,latitude,longitude,  &
+                         global_nx,global_ny)
+          endif
+       
+     else
+           ! mapp projected grid.
+          if(my_id.eq.IO_id) then
+              call get_dxdy_mp(dist,global_nx,global_ny, &
+                 nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT,nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT)
+          endif
+     endif
+     do k = 1 , 9
+        call decompose_data_real(dist(:,:,k),rt_domain(did)%dist_lsm(:,:,k))
+     end do
+#else
+     if(nlst_rt(did)%dxrt0 .lt. 0) then
+        ! lat and lon grid
+        call get_dist_ll(rt_domain(did)%dist_lsm,rt_domain(did)%lat_lsm,rt_domain(did)%lon_lsm,  &
+                      rt_domain(did)%ix,rt_domain(did)%jx)
+     else
+        ! mapp projected grid.
+        call get_dxdy_mp(rt_domain(did)%dist_lsm,rt_domain(did)%ix,rt_domain(did)%jx, &
+              nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT,nlst_rt(did)%dxrt0*nlst_rt(did)%AGGFACTRT)
+     endif
+#endif
+
+
+   end subroutine get_dist_lsm
+
+   subroutine get_dist_lrt(did)
+     integer did, k
+
+!     real :: tmp_dist(global_rt_nx, global_rt_ny,9)
+
+! calculate the distance for land routing from the lat /lon of land surface model
+     if(nlst_rt(did)%dxrt0 .lt. 0) then
+        ! using lat and lon grid when channel routing is off
+        call get_rt_dxdy_ll(did)
+     else
+        ! mapp projected grid.
+         call get_dxdy_mp(rt_domain(did)%dist,rt_domain(did)%ixrt,rt_domain(did)%jxrt, &
+              nlst_rt(did)%dxrt0,nlst_rt(did)%dxrt0)
+#ifdef MPP_LAND
+        do k = 1, 9
+           call MPP_LAND_COM_REAL(rt_domain(did)%dist(:,:,k),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+        end do
+#endif
+     endif
+
+
+   end subroutine get_dist_lrt
+
+!   subroutine get_dist_crt(did)
+!      integer did, k
+! calculate the distance from channel routing
+!     if(nlst_rt(did)%dxrt0 .lt. 0) then
+!        ! lat and lon grid
+!        if(rt_domain(did)%dist(1,1,9) .eq. -999)   &
+!           call get_dist_ll(rt_domain(did)%dist,rt_domain(did)%latval,rt_domain(did)%lonval,  &
+!                      rt_domain(did)%ixrt,rt_domain(did)%jxrt)
+!     else
+!        ! mapp projected grid.
+!        if(rt_domain(did)%dist(1,1,9) .eq. -999)   &
+!           call get_dxdy_mp(rt_domain(did)%dist,rt_domain(did)%ixrt,rt_domain(did)%jxrt, &
+!              nlst_rt(did)%dxrt0,nlst_rt(did)%dxrt0)
+!     endif
+!#ifdef MPP_LAND
+!     do k = 1, 9
+!       call MPP_LAND_COM_REAL(rt_domain(did)%dist(:,:,k),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+!     end do
+!#endif
+!   end subroutine get_dist_crt
+   
+   subroutine get_basn_area(did)
+      implicit none
+      integer :: did, ix,jx, k
+      real :: basns_area(rt_domain(did)%gnumbasns)
+#ifdef MPP_LAND
+      integer :: mask(global_nx, global_ny) 
+      real :: dist_lsm(global_nx, global_ny,9) 
+#else
+      integer :: mask(rt_domain(did)%ix, rt_domain(did)%jx)
+      real :: dist_lsm(rt_domain(did)%ix, rt_domain(did)%jx,9) 
+#endif
+#ifdef MPP_LAND
+      ix = global_nx
+      jx = global_ny
+      call write_IO_int(rt_domain(did)%GWSUBBASMSK,mask) 
+      do k = 1,  9
+         call write_IO_real(rt_domain(did)%dist_lsm(:,:,k),dist_lsm(:,:,k)) 
+      end do
+#else
+      ix = rt_domain(did)%ix
+      jx = rt_domain(did)%jx
+      mask = rt_domain(did)%GWSUBBASMSK
+      dist_lsm = rt_domain(did)%dist_lsm
+#endif
+
+#ifdef MPP_LAND
+      if(my_id .eq. IO_id) then
+         call get_area_g(basns_area,mask, rt_domain(did)%gnumbasns,ix,jx,dist_lsm)
+      end if
+!      call mpp_land_bcast_real(rt_domain(did)%numbasns,rt_domain(did)%basns_area)
+
+      call gw_decompose_real(rt_domain(did)%gnumbasns, rt_domain(did)%numbasns, &
+           rt_domain(did)%basnsInd, basns_area,rt_domain(did)%basns_area)
+#else
+      call get_area_g(rt_domain(did)%basns_area,mask, rt_domain(did)%gnumbasns,ix,jx,dist_lsm)
+#endif
+   end subroutine get_basn_area
+
+   subroutine get_area_g(basns_area,GWSUBBASMSK, numbasns,ix,jx,dist)
+      integer :: i,j, n, ix,jx, numbasns
+      integer :: count(numbasns)
+      real :: basns_area(numbasns) , dist(ix,jx,9)
+      integer :: GWSUBBASMSK(ix,jx)
+      basns_area = 0
+      count = 0
+      do  j = 1, jx
+        do  i = 1, ix
+           n = GWSUBBASMSK(i,j)
+           if(n .gt. 0) then
+              basns_area(n) = basns_area(n)+dist(i,j,9)
+              count(n) = count(n) + 1
+           endif
+        end do
+      end do
+      do i = 1, numbasns
+         if(count(i) .gt. 0) then
+             basns_area(i) = basns_area(i) / count(i) 
+         end if
+      end do
+   end subroutine get_area_g
+
+
+   subroutine get_node_area(did)
+       integer :: did
+       call get_area_g(rt_domain(did)%node_area,rt_domain(did)%CH_NETLNK, &
+         rt_domain(did)%NLINKS,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%dist)
+   end subroutine get_node_area
+    
+
+end module module_HYDRO_utils
diff --git a/wrfv2_fire/hydro/Routing/module_RT.F b/wrfv2_fire/hydro/Routing/module_RT.F
new file mode 100644
index 00000000..ab36ef19
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_RT.F
@@ -0,0 +1,1290 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+MODULE module_Routing
+#ifdef MPP_LAND
+   use module_gw_baseflow, only: pix_ct_1
+   use module_HYDRO_io, only: mpp_read_routedim, read_routing_seq, mpp_read_chrouting_new, &
+                              mpp_read_simp_gw 
+   use MODULE_mpp_ReachLS, only: ReachLS_ini, getlocalindx,  getToInd
+   USE module_mpp_land, only : left_id, up_id, right_id, down_id, mpp_land_com_integer, mpp_land_bcast_int, &
+                            updateLake_seq
+   use module_mpp_GWBUCKET, only : collectSizeInd
+#else
+   !yw use module_HYDRO_io, only: read_routedim, read_routing_old, read_chrouting,read_simp_gw
+   use module_HYDRO_io, only: read_routedim, read_routing_seq, read_chrouting1,read_simp_gw, get_nlinksl
+#endif
+   use module_HYDRO_io, only: readgw2d, simp_gw_ind,read_GWBUCKPARM, get_gw_strm_msk_lind, readBucket_nhd, read_NSIMLAKES
+   use module_HYDRO_utils 
+
+   use module_UDMAP, only: LNUMRSL, LUDRSL, UDMP_ini
+   IMPLICIT NONE
+
+#ifdef OUTPUT_CHAN_CONN
+#ifdef MPP_LAND
+   include "mpif.h"  !! JLM: thought I could pick this up from module_mpp_land... but seems not
+#endif
+#endif
+
+CONTAINS
+
+   subroutine rt_allocate(did,ix,jx,ixrt,jxrt,nsoil,CHANRTSWCRT)   
+      use module_RT_data, only: rt_domain
+      implicit none
+      integer ixrt,jxrt, ix,jx,nsoil,NLINKS, CHANRTSWCRT, NLAKES, NLINKSL
+      integer istatus, did, nsizes
+      if(rt_domain(did)%allo_status .eq. 1) return
+      rt_domain(did)%allo_status = 1
+
+      rt_domain(did)%ix = ix
+      rt_domain(did)%jx = jx
+      rt_domain(did)%ixrt = ixrt
+      rt_domain(did)%jxrt = jxrt
+!     ixrt = rt_domain(did)%ixrt
+!     jxrt = rt_domain(did)%jxrt
+      
+!     if( nlst_rt(did)%channel_option .eq. 1  .or. nlst_rt(did)%channel_option .eq. 2 ) then
+!         rt_domain(did)%NLINKS = rt_domain(did)%NLINKSL
+!     endif
+  if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+      if(rt_domain(did)%NLINKS .lt. rt_domain(did)%NLINKSL) then
+          rt_domain(did)%NLINKS = rt_domain(did)%NLINKSL
+      endif
+  endif
+
+      NLINKS = rt_domain(did)%NLINKS
+      NLAKES = rt_domain(did)%NLAKES
+      NLINKSL = rt_domain(did)%NLINKSL
+     
+      if(NLINKSL .gt. NLINKS) then
+         nsizes = nlinksl
+      else
+         nsizes = nlinks
+!           write(6,*) "Fatal Error: NLINKSL .gt. NLINKS .. "
+!           call hydro_stop("not solved, contact WRF-Hydro group. ")
+      endif
+      rt_domain(did)%nlinksize = nsizes
+
+
+      if(rt_domain(did)%NLINKS .eq. 0) NLINKS = 1
+      if(rt_domain(did)%NLAKES .eq. 0) NLAKES = 1
+      if(rt_domain(did)%NLINKSL .eq. 0) NLINKSL = 1
+
+!DJG Allocate routing and disaggregation arrays
+
+#ifdef HYDRO_D
+  write(6,*) "  rt_allocate ***** ixrt,jxrt, nsoil", ixrt,jxrt, nsoil
+#endif
+
+
+  allocate( rt_domain(did)%DSMC   	(NSOIL) )
+  rt_domain(did)%dsmc = 0 
+
+
+  allocate( rt_domain(did)%SMCRTCHK    	(NSOIL) )
+    rt_domain(did)%SMCRTCHK = 0
+
+  allocate( rt_domain(did)%SH2OAGGRT   	(NSOIL) )
+    rt_domain(did)%SH2OAGGRT = 0
+  allocate( rt_domain(did)%STCAGGRT   	(NSOIL) )
+  allocate( rt_domain(did)%SMCAGGRT   	(NSOIL) )
+    rt_domain(did)%STCAGGRT = 0
+  rt_domain(did)%SMCAGGRT = 0
+
+  if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+        allocate ( RT_DOMAIN(did)%landRunOff (ixrt,jxrt) )
+  endif
+  
+
+  allocate( rt_domain(did)%SMCRT   	(IXRT,JXRT,NSOIL) )
+  allocate( rt_domain(did)%soiltypRT   	(IXRT,JXRT) )
+  allocate( rt_domain(did)%ELRT   	(IXRT,JXRT) )
+  allocate( rt_domain(did)%SOXRT  	(IXRT,JXRT) )
+  allocate( rt_domain(did)%SOYRT   	(IXRT,JXRT) )
+  allocate( rt_domain(did)%SO8RT   	(IXRT,JXRT,8) )
+  allocate( rt_domain(did)%SO8RT_D   	(IXRT,JXRT,3) )
+  allocate( rt_domain(did)%OVROUGHRT   (IXRT,JXRT) )
+!  allocate( rt_domain(did)%QSUBBDRYTRT   (IXRT,JXRT) )
+!  rt_domain(did)%QSUBBDRYTRT = 0.0
+
+  allocate( rt_domain(did)%OVROUGHRTFAC   (IXRT,JXRT) )
+  allocate( rt_domain(did)%RETDEPRT    (IXRT,JXRT) )
+  allocate( rt_domain(did)%RETDEPRTFAC    (IXRT,JXRT) )
+  allocate( rt_domain(did)%SFCHEADSUBRT(IXRT,JXRT) )
+  allocate( rt_domain(did)%INFXSUBRT   (IXRT,JXRT) )
+  allocate( rt_domain(did)%INFXSWGT    (IXRT,JXRT) )
+  allocate( rt_domain(did)%LKSATRT     (IXRT,JXRT) )
+  allocate( rt_domain(did)%LKSATFAC    (IXRT,JXRT) )
+  allocate( rt_domain(did)%QSUBRT      (IXRT,JXRT) )
+  allocate( rt_domain(did)%ZWATTABLRT  (IXRT,JXRT) )
+  allocate( rt_domain(did)%QSUBBDRYRT  (IXRT,JXRT) )
+  allocate( rt_domain(did)%SOLDEPRT    (IXRT,JXRT) )
+  allocate( rt_domain(did)%q_sfcflx_x  (IXRT,JXRT) )
+  allocate( rt_domain(did)%q_sfcflx_y  (IXRT,JXRT) )
+  allocate( rt_domain(did)%SMCMAXRT   	(IXRT,JXRT,NSOIL) )
+  allocate( rt_domain(did)%SMCWLTRT   	(IXRT,JXRT,NSOIL) )
+  allocate( rt_domain(did)%SH2OWGT   	(IXRT,JXRT,NSOIL) )
+  allocate( rt_domain(did)%INFXSAGGRT 	(IXRT,JXRT) )
+  allocate( rt_domain(did)%DHRT   	(IXRT,JXRT) )
+  allocate( rt_domain(did)%QSTRMVOLRT  (IXRT,JXRT) )
+
+
+  allocate( rt_domain(did)%QSTRMVOLRT_TS  (IXRT,JXRT) )
+  allocate( rt_domain(did)%QSTRMVOLRT_DUM  (IXRT,JXRT) )
+  allocate( rt_domain(did)%QBDRYRT   	(IXRT,JXRT) )
+
+  allocate( rt_domain(did)%CH_NETRT   	(IXRT,JXRT) )
+
+  allocate( rt_domain(did)%LAKE_MSKRT 	(IXRT,JXRT) )
+  allocate( rt_domain(did)%LAKE_INFLORT(IXRT,JXRT) )
+  allocate( rt_domain(did)%LAKE_INFLORT_TS(IXRT,JXRT) )
+  allocate( rt_domain(did)%LAKE_INFLORT_DUM(IXRT,JXRT) )
+
+  allocate( rt_domain(did)%SUB_RESID (ixrt,jxrt) )
+  allocate( rt_domain(did)%LATVAL (ixrt,jxrt) )
+  allocate( rt_domain(did)%LONVAL (ixrt,jxrt) )
+  allocate( rt_domain(did)%dist (ixrt,jxrt,9) )
+
+! tmp array 
+  allocate( rt_domain(did)%SMCREFRT    	(IXRT,JXRT,NSOIL) )
+!!!! tmp
+
+    rt_domain(did)%dist = -999  
+    rt_domain(did)%SMCRT   	= 0.0                
+    rt_domain(did)%ELRT   	= 0.0                
+    rt_domain(did)%SOXRT  	= 0.0                
+    rt_domain(did)%SOYRT   	= 0.0                
+    rt_domain(did)%SO8RT   	= -999               
+    rt_domain(did)%SO8RT_D   	= 0.0                
+    rt_domain(did)%OVROUGHRT   = 0.0                
+    rt_domain(did)%SFCHEADSUBRT= 0.0                
+    rt_domain(did)%INFXSUBRT   = 0.0                
+    rt_domain(did)%INFXSWGT    = 0.0                
+    rt_domain(did)%LKSATRT     = 0.0                
+    rt_domain(did)%LKSATFAC    = 0.0                
+    rt_domain(did)%QSUBRT      = 0.0                
+    rt_domain(did)%ZWATTABLRT  = 0.0                
+    rt_domain(did)%QSUBBDRYRT  = 0.0                
+    rt_domain(did)%SOLDEPRT    = 0.0                
+    rt_domain(did)%q_sfcflx_x  = 0.0                
+    rt_domain(did)%q_sfcflx_y  = 0.0                
+    rt_domain(did)%SMCMAXRT   	= 0.0                
+    rt_domain(did)%SMCWLTRT   	= 0.0                
+    rt_domain(did)%SH2OWGT           = 0.0
+    rt_domain(did)%INFXSAGGRT 	= 0.0                
+    rt_domain(did)%DHRT   	= 0.0                
+    rt_domain(did)%QSTRMVOLRT  = 0.0
+    rt_domain(did)%QSTRMVOLRT_DUM  = 0.0                
+    rt_domain(did)%QBDRYRT   	= 0.0                
+
+    rt_domain(did)%CH_NETRT   	= 0.0                
+
+    rt_domain(did)%LAKE_MSKRT 	= -9999              
+    rt_domain(did)%LAKE_INFLORT= 0.0                
+    rt_domain(did)%LAKE_INFLORT_DUM= 0.0                
+
+    rt_domain(did)%SUB_RESID = 0.0                
+    rt_domain(did)%LATVAL = 0.0                
+    rt_domain(did)%LONVAL = 0.0
+
+
+    rt_domain(did)%timestep_flag = 1    ! default is cold start
+
+  allocate( rt_domain(did)%CH_LNKRT (IXRT,JXRT) )
+            rt_domain(did)%CH_LNKRT = 0.0
+
+   IF (CHANRTSWCRT.EQ.1 .or. CHANRTSWCRT .eq. 2) THEN  !IF/then for channel routing
+  allocate( rt_domain(did)%CH_NETLNK (IXRT,JXRT) )
+            rt_domain(did)%CH_NETLNK = 0.0           
+
+  allocate( rt_domain(did)%GCH_NETLNK (IXRT,JXRT) )
+            rt_domain(did)%GCH_NETLNK = 0.0           
+
+
+
+!DJG,DNY Allocate channel routing and lake routing arrays
+
+#ifdef MPP_LAND
+     allocate( rt_domain(did)%LAKE_INDEX(NLAKES) )
+     allocate( rt_domain(did)%nlinks_INDEX(nsizes) )
+     allocate( rt_domain(did)%Link_location(ixrt,jxrt))
+#endif
+
+     allocate( rt_domain(did)%CH_LNKRT_SL (IXRT,JXRT) )
+               rt_domain(did)%CH_LNKRT_SL = -99         
+     
+!tmp  if( nlst_rt(did)%channel_option .eq. 1  .or. nlst_rt(did)%channel_option .eq. 3 ) then
+!tmp       NLINKS = rt_domain(did)%NLINKSL
+!tmp       NLAKES = rt_domain(did)%NLINKSL
+!tmp  endif
+
+     allocate( rt_domain(did)%LINKID(nsizes) )
+     allocate( rt_domain(did)%gages(nsizes) )
+     allocate( rt_domain(did)%TO_NODE(nsizes) )
+     allocate( rt_domain(did)%FROM_NODE(nsizes) )
+     allocate( rt_domain(did)%CHLAT(nsizes) )   !-latitutde of channel grid point
+     allocate( rt_domain(did)%CHLON(nsizes) )   !-longitude of channel grid point
+     allocate( rt_domain(did)%ZELEV(nsizes) )
+     allocate( rt_domain(did)%TYPEL(nsizes) )
+     allocate( rt_domain(did)%ORDER(nsizes) )
+     allocate( rt_domain(did)%QLINK(nsizes,2) )
+#ifdef WRF_HYDRO_NUDGING
+     allocate( rt_domain(did)%nudge(nsizes) )
+#endif
+     allocate( rt_domain(did)%MUSK(nsizes) )
+     allocate( rt_domain(did)%MUSX(nsizes) )
+     allocate( rt_domain(did)%CHANLEN(nsizes) )
+     allocate( rt_domain(did)%MannN(nsizes))
+     allocate( rt_domain(did)%So(nsizes) )
+     allocate( rt_domain(did)%ChSSlp(nsizes) )
+     allocate( rt_domain(did)%Bw(nsizes) )
+     allocate( rt_domain(did)%LAKEIDA(nsizes) )
+     allocate( rt_domain(did)%LAKEIDX(nsizes) )
+
+     if(NLAKES .gt. 0) then
+        allocate( rt_domain(did)%LAKEIDM(NLAKES) )
+        allocate( rt_domain(did)%HRZAREA(NLAKES) )
+        allocate( rt_domain(did)%LAKEMAXH(NLAKES) )
+        allocate( rt_domain(did)%WEIRH(NLAKES) )
+        allocate( rt_domain(did)%WEIRC(NLAKES) )
+        allocate( rt_domain(did)%WEIRL(NLAKES) )
+        allocate( rt_domain(did)%ORIFICEC(NLAKES) )
+        allocate( rt_domain(did)%ORIFICEA(NLAKES) )
+        allocate( rt_domain(did)%ORIFICEE(NLAKES) )
+         rt_domain(did)%HRZAREA = 0.0        
+         rt_domain(did)%WEIRH = 0.0        
+         rt_domain(did)%WEIRC = 0.0        
+         rt_domain(did)%WEIRL = 0.0        
+         rt_domain(did)%LAKEMAXH = 0.0        
+         rt_domain(did)%ORIFICEC = 0.0        
+         rt_domain(did)%ORIFICEA = 0.0        
+         rt_domain(did)%ORIFICEE = 0.0        
+     endif
+
+
+!    allocate( rt_domain(did)%LAKEMAXH(nsizes) )
+!    allocate( rt_domain(did)%WEIRC(nsizes) )
+!    allocate( rt_domain(did)%WEIRL(nsizes) )
+!    allocate( rt_domain(did)%ORIFICEC(nsizes) )
+!    allocate( rt_domain(did)%ORIFICEA(nsizes) )
+!    allocate( rt_domain(did)%ORIFICEE(nsizes) )
+
+     if(nsizes .gt. 0) then
+        allocate( rt_domain(did)%accLndRunOff(nsizes) )
+        allocate( rt_domain(did)%accQLateral(nsizes) )
+        allocate( rt_domain(did)%accStrmvolrt(nsizes) )
+        allocate( rt_domain(did)%accBucket(nsizes) )
+        rt_domain(did)%accLndRunOff = 0
+        rt_domain(did)%accQLateral  = 0
+        rt_domain(did)%accStrmvolrt = 0
+        rt_domain(did)%accBucket    = 0
+	allocate( rt_domain(did)%QLateral(nsizes) )
+	rt_domain(did)%QLateral  = 0
+	allocate( rt_domain(did)%velocity(nsizes) )
+	rt_domain(did)%velocity  = 0
+     endif
+
+  if( nlst_rt(did)%channel_option .eq. 1  .or. nlst_rt(did)%channel_option .eq. 2 ) then
+       NLINKS = rt_domain(did)%NLINKS
+       NLAKES = rt_domain(did)%NLAKES 
+  endif
+
+     allocate( rt_domain(did)%LINK(nsizes) )
+     allocate( rt_domain(did)%STRMFRXSTPTS(nsizes) )
+     allocate( rt_domain(did)%CHANXI(nsizes) )
+     allocate( rt_domain(did)%CHANYJ(nsizes) )
+     allocate( rt_domain(did)%CVOL(nsizes) )
+     allocate( rt_domain(did)%LATLAKE(NLAKES) )
+     allocate( rt_domain(did)%LONLAKE(NLAKES) )
+     allocate( rt_domain(did)%ELEVLAKE(NLAKES) )
+     allocate( rt_domain(did)%LAKENODE(nsizes) )
+     allocate( rt_domain(did)%RESHT(NLAKES),STAT=istatus )
+     allocate( rt_domain(did)%QLAKEI(NLAKES),STAT=istatus )
+     allocate( rt_domain(did)%QLAKEO(NLAKES),STAT=istatus )
+
+     allocate( rt_domain(did)%HLINK(nsizes) )  !--used for diffusion only
+
+     allocate( rt_domain(did)%node_area(nsizes) )
+
+!!!! tmp
+      if(nsizes .gt. 0) then
+      rt_domain(did)%LINK = 0.0        
+      rt_domain(did)%gages = rt_domain(did)%gageMiss
+      rt_domain(did)%TO_NODE = 0.0        
+      rt_domain(did)%FROM_NODE = 0        
+      rt_domain(did)%TYPEL = -999       
+      rt_domain(did)%ORDER = 0.0        
+      rt_domain(did)%STRMFRXSTPTS = 0.0        
+      rt_domain(did)%MUSK = 0.0        
+      rt_domain(did)%MUSX = 0.0        
+      rt_domain(did)%CHANXI = 0.0        
+      rt_domain(did)%CHANYJ = 0.0        
+      rt_domain(did)%CHLAT = 0.0         !-latitutde of channel grid point
+      rt_domain(did)%CHLON = 0.0         !-longitude of channel grid point
+      rt_domain(did)%CHANLEN = 0.0        
+      rt_domain(did)%ChSSlp = 0.0        
+      rt_domain(did)%Bw = 0.0        
+      rt_domain(did)%ZELEV = 0.0        
+      rt_domain(did)%CVOL = 0.0        
+      rt_domain(did)%LAKEIDA = 0
+      rt_domain(did)%LAKEIDX = 0
+
+      rt_domain(did)%LATLAKE = 0.0        
+      rt_domain(did)%LONLAKE = 0.0        
+      rt_domain(did)%ELEVLAKE = 0.0        
+      rt_domain(did)%LAKENODE = 0.0        
+      rt_domain(did)%RESHT = 0.0                    
+      rt_domain(did)%QLAKEI = 0.0                     
+      rt_domain(did)%QLAKEO = 0.0                     
+      rt_domain(did)%QLINK = 0        
+#ifdef WRF_HYDRO_NUDGING
+      rt_domain(did)%nudge = 0
+#endif
+
+      rt_domain(did)%HLINK = 0.0        !--used for diffusion only
+      rt_domain(did)%MannN = 0.0        
+      rt_domain(did)%LINKID = 0.0        
+
+
+     rt_domain(did)%So = 0.01
+     endif
+   
+     rt_domain(did)%restQSTRM = .true.
+
+  END IF   !IF/then for channel routing
+
+
+  !DJG Allocate routing and disaggregation arrays
+  allocate(rt_domain(did)%qinflowbase  (IXRT,JXRT) )
+  allocate(rt_domain(did)%gw_strm_msk  (IXRT,JXRT) )
+  allocate(rt_domain(did)%gw_strm_msk_lind  (IXRT,JXRT) )
+
+!!! allocate land surface grid variables
+ allocate( rt_domain(did)%SMC  (IX,JX,NSOIL) )
+ allocate( rt_domain(did)%SICE (IX,JX,NSOIL) )
+! allocate( rt_domain(did)%dist_lsm (ixrt,jxrt,9) )
+! allocate( rt_domain(did)%lat_lsm (ixrt,jxrt) )
+! allocate( rt_domain(did)%lon_lsm (ixrt,jxrt) )
+ allocate( rt_domain(did)%dist_lsm (ix,jx,9) )
+ allocate( rt_domain(did)%lat_lsm (ix,jx) )
+ allocate( rt_domain(did)%lon_lsm (ix,jx) )
+
+! allocate( rt_domain(did)%SICE  (IX,JX,NSOIL) )
+ allocate( rt_domain(did)%SMCMAX1  (IX,JX) )
+  allocate( rt_domain(did)%STC  (IX,JX,NSOIL) )
+  allocate( rt_domain(did)%SH2OX(IX,JX,NSOIL) )
+  allocate( rt_domain(did)%SMCWLT1  (IX,JX) )
+  allocate( rt_domain(did)%SMCREF1  (IX,JX) )
+  allocate( rt_domain(did)%VEGTYP   (IX,JX) )
+  allocate( rt_domain(did)%SOILTYP   (IX,JX) )
+  allocate( rt_domain(did)%GWSUBBASMSK   (IX,JX) )
+  allocate( rt_domain(did)%SLDPTH(NSOIL) )
+  allocate( rt_domain(did)%SO8LD_D   (IX,JX,3) )
+  allocate( rt_domain(did)%SO8LD_Vmax   (IX,JX) )
+  allocate( rt_domain(did)%SFCHEADRT   (IX,JX) )
+  allocate( rt_domain(did)%INFXSRT   (IX,JX) )
+  allocate( rt_domain(did)%TERRAIN   (IX,JX) )
+  allocate( rt_domain(did)%LKSAT   (IX,JX) )
+  allocate( rt_domain(did)%SOLDRAIN   (IX,JX) )
+
+
+  rt_domain(did)%dist_lsm = 0.0 
+
+  rt_domain(did)%qinflowbase = 0.0           
+  rt_domain(did)%gw_strm_msk   = 0         
+  rt_domain(did)%SMC   = 0.25           
+  rt_domain(did)%SICE  = 0.
+! rt_domain(did)%SMCMAX1   = 0.434          
+  rt_domain(did)%SMCMAX1   = 0.0
+   rt_domain(did)%STC   = 282.0          
+   rt_domain(did)%SH2OX = rt_domain(did)%SMC   
+   rt_domain(did)%SMCWLT1   = 0.0            
+   rt_domain(did)%SMCREF1   = 0.0            
+   rt_domain(did)%VEGTYP    = 0            
+   rt_domain(did)%GWSUBBASMSK    = 0              
+   rt_domain(did)%SLDPTH = 0.0           
+   rt_domain(did)%SO8LD_D    = 0.0           
+   rt_domain(did)%SO8LD_Vmax    = 0.0            
+   rt_domain(did)%SFCHEADRT    = 0.0            
+   rt_domain(did)%INFXSRT    = 0.0            
+   rt_domain(did)%TERRAIN    = 0.0            
+   rt_domain(did)%LKSAT    = 0.0            
+   rt_domain(did)%SOLDRAIN    = 0.0            
+
+   rt_domain(did)%out_counts = 0
+   rt_domain(did)%his_out_counts = 0
+   rt_domain(did)%rst_counts = 1
+
+#ifdef HYDRO_D
+  write(6,*) "***** finish rt_allocate "
+#endif
+
+   end subroutine rt_allocate
+
+   subroutine getChanDim(did)
+
+  
+      use module_namelist, only:  nlst_rt 
+      use module_RT_data, only: rt_domain
+      implicit none
+      
+      integer ixrt,jxrt, ix,jx, did, i,j
+      INTEGER, allocatable,dimension(:,:) :: CH_NETLNK, GCH_NETLNK
+!      INTEGER, dimension( rt_domain(did)%ixrt,GCH_NETLNK(ixrt,jxrt)) :: GCH_NETLNK, CH_NETLNK
+
+      real :: Vmax
+     
+      ix = rt_domain(did)%ix 
+      jx = rt_domain(did)%jx 
+      ixrt = rt_domain(did)%ixrt 
+      jxrt = rt_domain(did)%jxrt 
+
+       if(nlst_rt(did)%rtFlag .eq. 0) return
+   
+       allocate(CH_NETLNK(ixrt,jxrt)) 
+       allocate(GCH_NETLNK(ixrt,jxrt)) 
+
+      IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) THEN  !IF/then for channel routing
+#ifdef MPP_LAND
+        CALL MPP_READ_ROUTEDIM(did, rt_domain(did)%g_IXRT,rt_domain(did)%g_JXRT, &
+                               GCH_NETLNK, rt_domain(did)%GNLINKS, &
+#else
+        CALL READ_ROUTEDIM( &
+#endif
+              IXRT, JXRT, nlst_rt(did)%route_chan_f, nlst_rt(did)%route_link_f, &
+              nlst_rt(did)%route_direction_f, &
+              rt_domain(did)%NLINKS, &
+              CH_NETLNK, nlst_rt(did)%channel_option, nlst_rt(did)%geo_finegrid_flnm, &
+              rt_domain(did)%NLINKSL, nlst_rt(did)%udmp_opt )
+#ifndef MPP_LAND
+        call get_NLINKSL(rt_domain(did)%NLINKSL, nlst_rt(did)%channel_option, nlst_rt(did)%route_link_f)
+#endif
+
+
+#ifdef HYDRO_D
+        write(6,*) "before rt_allocate after READ_ROUTEDIM"
+#endif
+
+
+        if(nlst_rt(did)%channel_option .eq. 1 .or. nlst_rt(did)%channel_option .eq. 2) then
+            rt_domain(did)%GNLINKSL = rt_domain(did)%NLINKSL
+
+#ifdef MPP_LAND
+         
+            call ReachLS_ini(rt_domain(did)%GNLINKSL,rt_domain(did)%nlinksl,   & 
+                         rt_domain(did)%linklsS, rt_domain(did)%linklsE )
+#else
+            rt_domain(did)%linklsS = 1
+            rt_domain(did)%linklsE = rt_domain(did)%NLINKSL
+#endif
+        else
+            rt_domain(did)%GNLINKSL = 1
+            rt_domain(did)%NLINKSL = 1
+        endif
+
+#ifndef MPP_LAND
+         GCH_NETLNK = CH_NETLNK
+#endif
+
+      endif
+
+  if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+         call read_NSIMLAKES(rt_domain(did)%NLAKES,nlst_rt(did)%route_lake_f)
+  endif
+
+        call rt_allocate(did,rt_domain(did)%ix,rt_domain(did)%jx,&
+                   rt_domain(did)%ixrt,rt_domain(did)%jxrt, nlst_rt(did)%nsoil,nlst_rt(did)%CHANRTSWCRT)
+
+
+      IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) THEN  !IF/then for channel routing
+        rt_domain(did)%CH_NETLNK = CH_NETLNK
+        rt_domain(did)%GCH_NETLNK = GCH_NETLNK
+      endif
+
+       if(allocated(CH_NETLNK)) deallocate(CH_NETLNK)
+       if(allocated(GCH_NETLNK)) deallocate(GCH_NETLNK)
+
+   end subroutine getChanDim
+
+!===================================================================================================   
+subroutine LandRT_ini(did)
+
+use module_noah_chan_param_init_rt
+use module_namelist, only:  nlst_rt
+use module_RT_data, only: rt_domain
+use module_gw_gw2d_data, only: gw2d
+#ifdef HYDRO_D
+use module_HYDRO_io, only: output_lake_types
+#endif
+
+#ifdef OUTPUT_CHAN_CONN
+use module_nudging_io,        only: output_chan_connectivity
+#endif
+
+implicit none 
+
+integer :: did
+real    :: Vmax
+
+integer :: bas 
+character(len=19)                      :: header
+character(len=1)                       :: jnk
+
+real,  dimension(50)     :: BOTWID,HLINK_INIT,CHAN_SS,CHMann !Channel parms from table
+integer :: i,j,k, ll, count
+ 
+     integer, allocatable, dimension(:) :: tmp_int
+     real, allocatable, dimension(:) :: tmp_real
+     integer, allocatable, dimension(:) :: buf
+     real, allocatable, dimension(:) :: tmpRESHT
+
+#ifdef OUTPUT_CHAN_CONN
+real :: connCalcTimeStart, connCalcTimeEnd
+#endif
+!------------------------------------------------------------------------
+!DJG Routing Processing
+!------------------------------------------------------------------------
+!DJG IF/then to get routing terrain fields if either routing module is 
+!DJG   activated
+
+if(nlst_rt(did)%rtFlag .eq. 0) return
+     
+if (nlst_rt(did)%SUBRTSWCRT  .eq.1 .or. &
+    nlst_rt(did)%OVRTSWCRT   .eq.1 .or. &
+    nlst_rt(did)%GWBASESWCRT .ne. 0) then
+
+#ifdef HYDRO_D
+   print *, "Terrain routing initialization..."
+#endif
+
+   call READ_ROUTING_seq  (  &
+        rt_domain(did)%IXRT,rt_domain(did)%JXRT,rt_domain(did)%ELRT,rt_domain(did)%CH_NETRT, &
+        rt_domain(did)%CH_LNKRT, &
+        rt_domain(did)%LKSATFAC,trim(nlst_rt(did)%route_topo_f),&
+          nlst_rt(did)%route_chan_f,nlst_rt(did)%geo_finegrid_flnm  ,  &
+          rt_domain(did)%OVROUGHRTFAC,rt_domain(did)%RETDEPRTFAC, &
+          nlst_rt(did)%channel_option, nlst_rt(did)%udmp_opt)
+
+   !yw CALL READ_ROUTING_old(rt_domain(did)%IXRT,rt_domain(did)%JXRT,rt_domain(did)%ELRT,rt_domain(did)%CH_NETRT, &
+
+   if (nlst_rt(did)%CHANRTSWCRT.eq.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) then  !IF/then for channel routing
+
+#ifdef MPP_LAND
+          CALL MPP_READ_CHROUTING_new(    &
+#else
+          CALL READ_CHROUTING1(    &
+#endif
+               rt_domain(did)%IXRT,rt_domain(did)%JXRT,rt_domain(did)%ELRT,rt_domain(did)%CH_NETRT, &
+               rt_domain(did)%CH_LNKRT, rt_domain(did)%LAKE_MSKRT, &
+               rt_domain(did)%FROM_NODE, rt_domain(did)%TO_NODE, rt_domain(did)%TYPEL, rt_domain(did)%ORDER, &
+               rt_domain(did)%MAXORDER,rt_domain(did)%NLINKS, &
+               rt_domain(did)%NLAKES, rt_domain(did)%MUSK, rt_domain(did)%MUSX, rt_domain(did)%QLINK,&
+               rt_domain(did)%CHANLEN, rt_domain(did)%MannN, rt_domain(did)%So, rt_domain(did)%ChSSlp, rt_domain(did)%Bw, &
+               rt_domain(did)%LAKEIDA, &
+               rt_domain(did)%HRZAREA, rt_domain(did)%LAKEMAXH, rt_domain(did)%WEIRH, rt_domain(did)%WEIRC, &
+               rt_domain(did)%WEIRL, rt_domain(did)%ORIFICEC, &
+               rt_domain(did)%ORIFICEA,  rt_domain(did)%ORIFICEE, rt_domain(did)%LATLAKE, rt_domain(did)%LONLAKE, &
+               rt_domain(did)%ELEVLAKE, rt_domain(did)%LAKEIDM, rt_domain(did)%LAKEIDX, &
+               nlst_rt(did)%route_link_f,nlst_rt(did)%route_lake_f, &
+               nlst_rt(did)%route_direction_f, nlst_rt(did)%route_order_f, &
+               nlst_rt(did)%CHANRTSWCRT,rt_domain(did)%dist, rt_domain(did)%ZELEV, rt_domain(did)%LAKENODE, rt_domain(did)%CH_NETLNK, &
+               rt_domain(did)%CHANXI, rt_domain(did)%CHANYJ, &
+               rt_domain(did)%CHLAT, rt_domain(did)%CHLON, nlst_rt(did)%channel_option,&
+               rt_domain(did)%latval, rt_domain(did)%lonval,&
+               rt_domain(did)%STRMFRXSTPTS,nlst_rt(did)%geo_finegrid_flnm, rt_domain(did)%NLINKSL, rt_domain(did)%LINKID, rt_domain(did)%GNLINKSL &
+               ,nlst_rt(did)%UDMP_OPT  &
+               
+#ifdef MPP_LAND
+               ,rt_domain(did)%g_IXRT,rt_domain(did)%g_JXRT   &
+               ,rt_domain(did)%gnlinks,rt_domain(did)%GCH_NETLNK, rt_domain(did)%map_l2g &
+               ,rt_domain(did)%link_location, rt_domain(did)%yw_mpp_nlinks,rt_domain(did)%lake_index,rt_domain(did)%nlinks_index &
+#endif
+               ,rt_domain(did)%gages, rt_domain(did)%gageMiss )
+
+!ADCHANGE: Add lake reach output
+#ifdef HYDRO_D
+    if(nlst_rt(did)%UDMP_OPT .eq. 1) then   
+       call output_lake_types( rt_domain(did)%GNLINKSL, rt_domain(did)%LINKID, rt_domain(did)%TYPEL )
+    endif
+#endif
+
+#ifdef OUTPUT_CHAN_CONN      
+#ifdef MPP_LAND
+      connCalcTimeEnd = MPI_Wtime()
+#else
+      call cpu_time(connCalcTimeEnd)
+#endif
+      if (nlst_rt(did)%channel_option .eq. 3) then 
+         call output_chan_connectivity(       &
+              rt_domain(did)%CHLAT,     &   !! Channel grid lat
+              rt_domain(did)%CHLON,     &   !! Channel grid lat
+              rt_domain(did)%CHANLEN,   &   !! The distance between channel grid centers in m.
+              rt_domain(did)%FROM_NODE, &   !! Index of a given cell and ...
+              rt_domain(did)%TO_NODE,   &   !!   ... the index which it flows to.
+              rt_domain(did)%CHANXI,    &   !! Index on fine/routing 
+              rt_domain(did)%CHANYJ,    &   !!   grid of grid cells.
+              rt_domain(did)%TYPEL,     &   !! Link type
+              rt_domain(did)%LAKENODE   &   !! Lake indexing
+              )
+      end if
+      
+      !if(my_id .eq. io_id) &
+      print '("Time to calculate channel connectivity= ",f6.3," seconds.")', &
+           connCalcTimeEnd-connCalcTimeStart        
+      call exit(17)  !! bail if you're just calculating output connectivity.
+#endif 
+! end OUTPUT_CHAN_CONN
+
+
+    if(nlst_rt(did)%UDMP_OPT .eq. 1) then   
+          ! get NHDPLUS mapping function. 
+!          call UDMP_ini(rt_domain(did)%GNLINKSL,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%CH_LNKRT , &
+          call UDMP_ini(rt_domain(did)%GNLINKSL,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%CH_NETRT , &
+              nlst_rt(did)%OVRTSWCRT, nlst_rt(did)%SUBRTSWCRT, rt_domain(did)%dist(:,:,9) )
+#ifdef HYDRO_D
+          write(6,*) "after UDMP_ini "
+          call flush(6)
+#endif
+    endif
+
+    if (nlst_rt(did)%channel_option .eq. 1 .or. nlst_rt(did)%channel_option .eq. 2) then
+#ifdef MPP_LAND
+      if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+           ! NHDPLUS
+           rt_domain(did)%LNLINKSL = LNUMRSL
+           allocate(rt_domain(did)%LLINKID(rt_domain(did)%LNLINKSL))
+           do k = 1,LNUMRSL
+               rt_domain(did)%LLINKID(k) = LUDRSL(k)%myid
+           end do
+      else
+           allocate (buf(rt_domain(did)%GNLINKS) )
+           buf = -99
+           do j = 1, rt_domain(did)%jxrt
+              do i = 1, rt_domain(did)%ixrt
+                 if( .not. ( (i .eq. 1 .and. left_id .ge. 0) .or. (i .eq. rt_domain(did)%ixrt .and. right_id .ge. 0) .or.  &
+                        (j .eq. 1 .and. down_id .ge. 0) .or. (j .eq. rt_domain(did)%jxrt .and. up_id .ge. 0)    )   ) then 
+                    if(rt_domain(did)%CH_LNKRT(i,j) .gt. 0) then
+                       k = rt_domain(did)%CH_LNKRT(i,j)
+                       buf(k) = k
+                    endif
+                 endif
+              end do 
+           end do
+
+           rt_domain(did)%LNLINKSL = 0
+           do k = 1, rt_domain(did)%GNLINKS
+                if(buf(k) .gt. 0) then
+                    rt_domain(did)%LNLINKSL = rt_domain(did)%LNLINKSL + 1
+                endif
+           end do
+   
+#ifdef HYDRO_D
+           write(6,*) "LNLINKSL, NLINKS, GNLINKS =",rt_domain(did)%LNLINKSL,rt_domain(did)%NLINKSL,rt_domain(did)%GNLINKSL
+           call flush(6)
+#endif
+
+           allocate(rt_domain(did)%LLINKID(rt_domain(did)%LNLINKSL))
+   
+           k = 0
+           do i = 1, rt_domain(did)%GNLINKS
+                if(buf(i) .gt. 0) then
+                   k = k + 1
+                   rt_domain(did)%LLINKID(k) = buf(i)
+                endif
+           end do
+
+           if(allocated(buf)) deallocate(buf)
+
+     endif  ! end if block for UDMP_OPT
+      
+           do k = 1, rt_domain(did)%LNLINKSL
+               do j = 1, rt_domain(did)%jxrt
+                  do i = 1, rt_domain(did)%ixrt
+                     if( .not. ( (i .eq. 1 .and. left_id .ge. 0) .or. (i .eq. rt_domain(did)%ixrt .and. right_id .ge. 0) .or.  &
+                            (j .eq. 1 .and. down_id .ge. 0) .or. (j .eq. rt_domain(did)%jxrt .and. up_id .ge. 0)    )   ) then
+                            if(rt_domain(did)%CH_LNKRT(i,j) .eq. rt_domain(did)%LLINKID(k) ) then
+                               rt_domain(did)%CH_LNKRT_SL(i,j) = k   !! mapping
+                            endif
+                     endif
+                  end do 
+               end do
+           end do
+
+            call getLocalIndx(rt_domain(did)%gnlinksl,rt_domain(did)%LINKID, rt_domain(did)%LLINKID)
+
+           call getToInd(rt_domain(did)%LINKID,rt_domain(did)%to_node,rt_domain(did)%toNodeInd,rt_domain(did)%nToInd,rt_domain(did)%gtoNode)
+#else
+        do k = 1, rt_domain(did)%NLINKSL
+            do j = 1, rt_domain(did)%jxrt
+               do i = 1, rt_domain(did)%ixrt
+                         if(rt_domain(did)%CH_LNKRT(i,j) .eq. rt_domain(did)%LINKID(k) ) then
+                            rt_domain(did)%CH_LNKRT_SL(i,j) = k   !! mapping
+                         endif
+               end do 
+            end do
+        end do
+
+#endif
+
+!!$        ! use gage information in RouteLink like strmfrxstpts
+!!$        rt_domain(did)%STRMFRXSTPTS = -9999  !! existing info useless for link-based routing
+!!$        count = 1
+!!$        do ll=1,rt_domain(did)%NLINKSL
+!!$           if(trim(rt_domain(did)%gages(ll)) .ne. trim(rt_domain(did)%gageMiss)) then
+!!$              rt_domain(did)%STRMFRXSTPTS(count) = ll
+!!$              count = count + 1 
+!!$           end if
+!!$        end do
+
+     endif   ! end of channel option if block
+
+    endif
+  END IF
+
+   
+!yw       allocate(tmp_int(rt_domain(did)%GNLINKS))
+!yw       allocate(tmp_real(rt_domain(did)%GNLINKS))
+
+
+
+!DJG Temporary hardwire of RETDEPRT,RETDEP_CHAN
+!DJG    will later make this a function of SOLTYP and VEGTYP
+!            OVROUGHRT(i,j) = 0.01
+
+rt_domain(did)%RETDEPRT = 0.001   ! units (mm)
+rt_domain(did)%RETDEP_CHAN = 0.001
+
+
+!DJG Need to insert call for acquiring routing fields here...
+!DJG     include as a subroutine in module module_Noahlsm_wrfcode_input.F
+!DJG  Calculate terrain slopes 'SOXRT,SOYRT' from subgrid elevation 'ELRT'
+
+
+rt_domain(did)%so8rt = -999
+Vmax = 0.0
+do j=2,rt_domain(did)%JXRT-1
+   do i=2,rt_domain(did)%IXRT-1
+      rt_domain(did)%SOXRT(i,j)=(rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j))/rt_domain(did)%dist(i,j,3)
+      rt_domain(did)%SOYRT(i,j)=(rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i,j+1))/rt_domain(did)%dist(i,j,1)
+      !DJG Introduce reduction in retention depth as a linear function of terrain slope
+      if (nlst_rt(did)%RT_OPTION.eq.2) then
+         if (rt_domain(did)%SOXRT(i,j).gt.rt_domain(did)%SOYRT(i,j)) then
+            Vmax=rt_domain(did)%SOXRT(i,j)
+         else
+            Vmax=rt_domain(did)%SOYRT(i,j)
+         end if
+         
+         if (Vmax.gt.0.1) then
+            rt_domain(did)%RETDEPRT(i,j)=0.
+         else
+            rt_domain(did)%RETDEPFRAC=Vmax/0.1
+            rt_domain(did)%RETDEPRT(i,j)=rt_domain(did)%RETDEPRT(i,j)*(1.-rt_domain(did)%RETDEPFRAC)
+            if (rt_domain(did)%RETDEPRT(i,j).lt.0.) rt_domain(did)%RETDEPRT(i,j)=0.
+         end if
+      end if
+      
+      rt_domain(did)%SO8RT(i,j,1) = &
+           (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i,j+1))/rt_domain(did)%dist(i,j,1)
+      rt_domain(did)%SO8RT_D(i,j,1) = i
+      rt_domain(did)%SO8RT_D(i,j,2) = j + 1 
+      rt_domain(did)%SO8RT_D(i,j,3) = 1 
+      Vmax = rt_domain(did)%SO8RT(i,j,1)
+      
+      rt_domain(did)%SO8RT(i,j,2) = &
+           (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j+1))/rt_domain(did)%dist(i,j,2)  
+      if(rt_domain(did)%SO8RT(i,j,2) .gt. Vmax ) then
+         rt_domain(did)%SO8RT_D(i,j,1) = i + 1
+         rt_domain(did)%SO8RT_D(i,j,2) = j + 1 
+                 rt_domain(did)%SO8RT_D(i,j,3) = 2
+         Vmax = rt_domain(did)%SO8RT(i,j,2)
+      end if
+      
+      rt_domain(did)%SO8RT(i,j,3) = &
+           (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j))/rt_domain(did)%dist(i,j,3)
+      if(rt_domain(did)%SO8RT(i,j,3) .gt. Vmax ) then
+         rt_domain(did)%SO8RT_D(i,j,1) = i + 1
+         rt_domain(did)%SO8RT_D(i,j,2) = j  
+                 rt_domain(did)%SO8RT_D(i,j,3) = 3
+         Vmax = rt_domain(did)%SO8RT(i,j,3)
+      end if
+      
+      rt_domain(did)%SO8RT(i,j,4) = &
+           (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i+1,j-1))/rt_domain(did)%dist(i,j,4)  
+      if(rt_domain(did)%SO8RT(i,j,4) .gt. Vmax ) then
+         rt_domain(did)%SO8RT_D(i,j,1) = i + 1
+         rt_domain(did)%SO8RT_D(i,j,2) = j - 1 
+                 rt_domain(did)%SO8RT_D(i,j,3) = 4
+         Vmax = rt_domain(did)%SO8RT(i,j,4)
+      end if
+      
+      rt_domain(did)%SO8RT(i,j,5) = &
+           (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i,j-1))/rt_domain(did)%dist(i,j,5)
+      if(rt_domain(did)%SO8RT(i,j,5) .gt. Vmax ) then
+         rt_domain(did)%SO8RT_D(i,j,1) = i 
+         rt_domain(did)%SO8RT_D(i,j,2) = j - 1 
+                 rt_domain(did)%SO8RT_D(i,j,3) = 5
+         Vmax = rt_domain(did)%SO8RT(i,j,5)
+      end if
+      
+      rt_domain(did)%SO8RT(i,j,6) = & 
+         (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i-1,j-1))/rt_domain(did)%dist(i,j,6)  
+      if(rt_domain(did)%SO8RT(i,j,6) .gt. Vmax ) then
+         rt_domain(did)%SO8RT_D(i,j,1) = i - 1 
+         rt_domain(did)%SO8RT_D(i,j,2) = j - 1 
+                 rt_domain(did)%SO8RT_D(i,j,3) = 6
+         Vmax = rt_domain(did)%SO8RT(i,j,6)
+      end if
+      
+      rt_domain(did)%SO8RT(i,j,7) = &
+         (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i-1,j))/rt_domain(did)%dist(i,j,7)
+      if(rt_domain(did)%SO8RT(i,j,7) .gt. Vmax ) then
+         rt_domain(did)%SO8RT_D(i,j,1) = i - 1 
+         rt_domain(did)%SO8RT_D(i,j,2) = j  
+                 rt_domain(did)%SO8RT_D(i,j,3) = 7
+         Vmax = rt_domain(did)%SO8RT(i,j,7)
+      end if
+      
+      rt_domain(did)%SO8RT(i,j,8) = &
+         (rt_domain(did)%ELRT(i,j)-rt_domain(did)%ELRT(i-1,j+1))/rt_domain(did)%dist(i,j,8)  
+      if(rt_domain(did)%SO8RT(i,j,8) .gt. Vmax ) then
+         rt_domain(did)%SO8RT_D(i,j,1) = i - 1 
+         rt_domain(did)%SO8RT_D(i,j,2) = j + 1 
+                 rt_domain(did)%SO8RT_D(i,j,3) = 8
+         Vmax = rt_domain(did)%SO8RT(i,j,8)
+      end if
+      
+      !DJG Introduce reduction in retention depth as a linear function of terrain slope
+      if (nlst_rt(did)%RT_OPTION.eq.1) then
+         if (Vmax.gt.0.75) then
+            rt_domain(did)%RETDEPRT(i,j)=0.
+         else
+            rt_domain(did)%RETDEPFRAC=Vmax/0.75
+            rt_domain(did)%RETDEPRT(i,j)=rt_domain(did)%RETDEPRT(i,j)*(1.-rt_domain(did)%RETDEPFRAC)
+            if (rt_domain(did)%RETDEPRT(i,j).lt.0.) rt_domain(did)%RETDEPRT(i,j)=0.
+         end if
+      end if
+      
+      
+   end do
+end do
+
+
+!Apply calibration scaling factors to sfc roughness and retention depth here...
+rt_domain(did)%RETDEPRT = rt_domain(did)%RETDEPRT * rt_domain(did)%RETDEPRTFAC
+rt_domain(did)%OVROUGHRT = rt_domain(did)%OVROUGHRT * rt_domain(did)%OVROUGHRTFAC
+
+
+! calculate the slope for boundary        
+#ifdef MPP_LAND
+if(right_id .lt. 0) rt_domain(did)%SOXRT(rt_domain(did)%IXRT,:)= &
+                       rt_domain(did)%SOXRT(rt_domain(did)%IXRT-1,:)
+if(left_id  .lt. 0) rt_domain(did)%SOXRT(1,:)=rt_domain(did)%SOXRT(2,:)
+if(up_id    .lt. 0) rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT)= &
+                       rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT-1)
+if(down_id  .lt. 0) rt_domain(did)%SOYRT(:,1)=rt_domain(did)%SOYRT(:,2)
+#else
+rt_domain(did)%SOXRT(rt_domain(did)%IXRT,:)=rt_domain(did)%SOXRT(rt_domain(did)%IXRT-1,:)
+rt_domain(did)%SOXRT(1,:)=rt_domain(did)%SOXRT(2,:)
+rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT)=rt_domain(did)%SOYRT(:,rt_domain(did)%JXRT-1)
+rt_domain(did)%SOYRT(:,1)=rt_domain(did)%SOYRT(:,2)
+#endif
+
+#ifdef MPP_LAND
+! communicate the value to 
+call MPP_LAND_COM_REAL(rt_domain(did)%RETDEPRT,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+call MPP_LAND_COM_REAL(rt_domain(did)%SOXRT,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+call MPP_LAND_COM_REAL(rt_domain(did)%SOYRT,rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+do i = 1, 8
+   call MPP_LAND_COM_REAL(rt_domain(did)%SO8RT(:,:,i),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+end do
+do i = 1, 3
+   call MPP_LAND_COM_INTEGER(rt_domain(did)%SO8RT_D(:,:,i),rt_domain(did)%IXRT,rt_domain(did)%JXRT,99)
+end do
+#endif
+
+
+if(nlst_rt(did)%UDMP_OPT .eq. 1) then
+            allocate (rt_domain(did)%qout_gwsubbas (rt_domain(did)%nlinksL))
+            rt_domain(did)%qout_gwsubbas = 0
+   ! use different baseflow for NHDPlus
+     IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN
+            rt_domain(did)%numbasns = rt_domain(did)%NLINKSL
+            RT_DOMAIN(did)%gnumbasns = rt_domain(did)%gNLINKSL
+
+            allocate (rt_domain(did)%z_gwsubbas (rt_domain(did)%numbasns  ))
+            allocate (rt_domain(did)%nhdBuckMask(rt_domain(did)%numbasns  ))  ! default is -999
+
+            allocate (rt_domain(did)%qin_gwsubbas (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%gwbas_pix_ct (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%ct2_bas (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%bas_pcp (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%gw_buck_coeff (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%bas_id (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%gw_buck_exp(rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%z_max (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%basns_area (rt_domain(did)%numbasns))
+
+            rt_domain(did)%qin_gwsubbas = 0
+            rt_domain(did)%z_gwsubbas = 0
+            rt_domain(did)%gwbas_pix_ct = 0
+            rt_domain(did)%bas_pcp = 0
+
+            rt_domain(did)%gw_buck_coeff = 0.04
+            rt_domain(did)%gw_buck_exp  = 0.2
+            rt_domain(did)%z_max = 0.1
+
+!Temporary hardwire...
+      rt_domain(did)%z_gwsubbas = 0.05   ! This gets updated with spun-up GW level in GWBUCKPARM.TBL
+
+            call readBucket_nhd(trim(nlst_rt(did)%GWBUCKPARM_file), rt_domain(did)%numbasns, &
+                 rt_domain(did)%gw_buck_coeff, rt_domain(did)%gw_buck_exp, &
+                 rt_domain(did)%z_max, rt_domain(did)%LINKID(1:rt_domain(did)%numbasns),  &
+                 rt_domain(did)%nhdBuckMask )     
+#ifdef HYDRO_D
+            write(6,*) "finish readBucket_nhd "
+            call flush(6)
+#endif
+     endif
+else
+!---------------------------------------------------------------------
+!DJG  If GW/Baseflow activated...Read in req'd fields...
+!----------------------------------------------------------------------
+if (nlst_rt(did)%GWBASESWCRT.ge.1) then
+   if (nlst_rt(did)%GWBASESWCRT.eq.1.or.nlst_rt(did)%GWBASESWCRT.eq.2) then
+#ifdef HYDRO_D
+      print *, "new Simple GW-Bucket Scheme selected, retrieving files..."
+#endif
+#ifdef MPP_LAND
+      call MPP_READ_SIMP_GW(              &
+#else
+      call READ_SIMP_GW(                  &
+#endif
+              rt_domain(did)%IX,rt_domain(did)%JX,rt_domain(did)%IXRT,&
+              rt_domain(did)%JXRT,rt_domain(did)%GWSUBBASMSK,nlst_rt(did)%gwbasmskfil,&
+              rt_domain(did)%gw_strm_msk,rt_domain(did)%numbasns,rt_domain(did)%ch_netrt,nlst_rt(did)%AGGFACTRT)
+           
+
+            call SIMP_GW_IND(rt_domain(did)%ix,rt_domain(did)%jx,rt_domain(did)%GWSUBBASMSK,  &
+                  rt_domain(did)%numbasns,rt_domain(did)%gnumbasns,rt_domain(did)%basnsInd)
+            
+#ifdef HYDRO_D            
+            write(6,*) "rt_domain(did)%gnumbasns, rt_domain(did)%numbasns, ", rt_domain(did)%gnumbasns , rt_domain(did)%numbasns
+
+#endif
+#ifdef MPP_LAND
+            call collectSizeInd(rt_domain(did)%numbasns)
+#endif
+
+            call get_gw_strm_msk_lind (rt_domain(did)%IXRT, rt_domain(did)%JXRT, rt_domain(did)%gw_strm_msk,&
+                 rt_domain(did)%numbasns,rt_domain(did)%basnsInd,rt_domain(did)%gw_strm_msk_lind)
+
+
+            allocate (rt_domain(did)%qout_gwsubbas (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%qin_gwsubbas (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%z_gwsubbas (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%gwbas_pix_ct (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%ct2_bas (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%bas_pcp (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%gw_buck_coeff (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%bas_id (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%gw_buck_exp(rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%z_max (rt_domain(did)%numbasns))
+            allocate (rt_domain(did)%basns_area (rt_domain(did)%numbasns))
+
+#ifdef HYDRO_D
+      write(6,*)  "end Simple GW-Bucket ..."
+      print *, "Simple GW-Bucket Scheme selected, retrieving files..."
+#endif
+     
+!Temporary hardwire...
+      rt_domain(did)%z_gwsubbas = 1.     ! This gets updated with spun-up GW level in GWBUCKPARM.TBL
+
+
+            call read_GWBUCKPARM(rt_domain(did)%numbasns,rt_domain(did)%gnumbasns, rt_domain(did)%basnsInd, &
+                 rt_domain(did)%gw_buck_coeff, rt_domain(did)%gw_buck_exp, rt_domain(did)%z_max, &
+                 rt_domain(did)%z_gwsubbas, rt_domain(did)%bas_id,rt_domain(did)%basns_area)
+
+
+
+!!! Determine number of stream pixels per GW basin for distribution...
+
+#ifdef MPP_LAND
+         call pix_ct_1(rt_domain(did)%gw_strm_msk,rt_domain(did)%ixrt,rt_domain(did)%jxrt,rt_domain(did)%gwbas_pix_ct,rt_domain(did)%numbasns, &
+                     rt_domain(did)%gnumbasns,rt_domain(did)%basnsInd)
+#else
+         rt_domain(did)%gwbas_pix_ct = 0.
+!         do k = 1, rt_domain(did)%numbasns
+!            bas = rt_domain(did)%basnsInd(k)
+         do i=1,rt_domain(did)%ixrt
+           do j=1,rt_domain(did)%jxrt
+             if (rt_domain(did)%gw_strm_msk(i,j).gt.0) then
+                 bas = rt_domain(did)%gw_strm_msk(i,j)
+                 rt_domain(did)%gwbas_pix_ct(bas) = & 
+                 rt_domain(did)%gwbas_pix_ct(bas)  + 1.0
+             endif
+           end do
+         end do
+!         end do
+#endif
+
+
+#ifdef HYDRO_D
+      print *, "Starting GW basin levels...",rt_domain(did)%z_gwsubbas
+#endif
+      
+      
+   ! BF gw2d model
+   elseif (nlst_rt(did)%GWBASESWCRT.ge.3) then
+      
+      call readGW2d(gw2d(did)%ix, gw2d(did)%jx,     &
+           gw2d(did)%hycond, gw2d(did)%ho, &
+           gw2d(did)%bot, gw2d(did)%poros, &
+           gw2d(did)%ltype, nlst_rt(did)%gwIhShift)
+      
+      gw2d(did)%elev = rt_domain(did)%elrt
+      
+   end if
+   
+end if
+!---------------------------------------------------------------------
+!DJG  End if GW/Baseflow activated...
+!----------------------------------------------------------------------
+endif   !!! end if block for UDMP_OPT .eq. 1 
+
+
+
+!---------------------------------------------------------------------
+!DJG,DNY  If channel routing activated...
+!----------------------------------------------------------------------
+
+if (nlst_rt(did)%CHANRTSWCRT.eq.1 .or. nlst_rt(did)%CHANRTSWCRT .eq. 2) then
+   
+   !---------------------------------------------------------------------
+   !DJG,DNY  Initalize lake and channel heights, this may be overwritten by RESTART
+   !--------------------------------------------------------------------
+   
+   if (nlst_rt(did)%channel_option .eq. 3) then
+#ifdef MPP_LAND
+      call mpp_CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann)  !Read chan parms from table...
+#else
+      call CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann)  !Read chan parms from table...
+#endif
+       end if
+     if (nlst_rt(did)%channel_option .ne. 3) then
+#ifdef MPP_LAND
+        if(my_id .eq. io_id) then
+#endif
+           allocate(tmpRESHT(rt_domain(did)%nlakes))
+           tmpRESHT = rt_domain(did)%RESHT
+#ifdef MPP_LAND
+        endif
+#endif
+        do j=1,rt_domain(did)%NLINKSL
+           do k = 1, rt_domain(did)%NLAKES
+            if(rt_domain(did)%LAKEIDM(k) .eq. rt_domain(did)%LINKID(j)) then
+              if (rt_domain(did)%TYPEL(j) .eq. 1) then !- for sparse network method this is a lake  (type 0 is river)
+                rt_domain(did)%RESHT(k) = rt_domain(did)%LAKEMAXH(k) * 0.935  !-- assumes lake is ~90% MA, should put in Lake Parm
+              endif
+            endif
+           end do
+        end do
+#ifdef MPP_LAND
+        call updateLake_seq(rt_domain(did)%RESHT, rt_domain(did)%NLAKES,tmpRESHT)
+        if(my_id .eq. io_id) then 
+            if(allocated(tmpRESHT)) deallocate(tmpRESHT)
+        endif
+#endif
+
+     else       !-- parameterize according to order of diffusion scheme, or if read from hi res file, use its value
+                !--  put condition within the if/then structure, which will assign a value if something is missing in hi res
+        do j=1,rt_domain(did)%NLINKS
+
+             if (rt_domain(did)%ORDER(j) .eq. 1) then    !-- smallest stream reach
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .eq. 2) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .eq. 3) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .eq. 4) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .eq. 5) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .eq. 6) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             elseif (rt_domain(did)%ORDER(j) .ge. 7) then
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(rt_domain(did)%ORDER(j))
+               endif
+               if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+                rt_domain(did)%MannN(j) = CHMann(rt_domain(did)%ORDER(j))
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(rt_domain(did)%ORDER(j))
+             else   !-- the outlets won't have orders since there's no nodes, so
+                    !-- assign the order 5 values
+
+               if(rt_domain(did)%Bw(j) .eq. 0.0) then 
+                rt_domain(did)%Bw(j) = BOTWID(5)
+               endif
+               if(rt_domain(did)%ChSSlp(j) .eq. 0.0) then  !if id didn't get set from the hi res file, use the  CHANPARAM
+                rt_domain(did)%ChSSlp(j) = CHAN_SS(5)
+               endif
+              if(rt_domain(did)%MannN(j) .eq. 0.0) then 
+               rt_domain(did)%MannN(j) = CHMann(5)
+               endif
+               rt_domain(did)%HLINK(j) = HLINK_INIT(5)
+             endif
+                
+            rt_domain(did)%CVOL(j) = (rt_domain(did)%Bw(j)+ 1/rt_domain(did)%ChSSLP(j)*rt_domain(did)%HLINK(j))*rt_domain(did)%HLINK(j)*rt_domain(did)%CHANLEN(j) !-- initalize channel volume
+        end do
+     endif  !Endif channel option eq 3
+
+           do j=1,rt_domain(did)%NLAKES
+             rt_domain(did)%RESHT(j) = rt_domain(did)%LAKEMAXH(j) * 0.935   !-- lake is 99% full at start
+           end do
+
+end if     ! Endif for channel routing setup
+!-----------------------------------------------------------------------
+
+rt_domain(did)%INFXSWGT = 1./(nlst_rt(did)%AGGFACTRT*nlst_rt(did)%AGGFACTRT)
+rt_domain(did)%SH2OWGT = 1.
+rt_domain(did)%SOLDEPRT = -1.0 * nlst_rt(did)%ZSOIL8(nlst_rt(did)%NSOIL)
+rt_domain(did)%QSUBRT = 0.0
+rt_domain(did)%ZWATTABLRT = 0.0
+rt_domain(did)%QSUBBDRYRT = 0.0
+rt_domain(did)%QSTRMVOLRT = 0.0
+rt_domain(did)%QSTRMVOLRT = 0.0
+rt_domain(did)%QBDRYRT = 0.0
+rt_domain(did)%SFCHEADSUBRT = 0.0
+rt_domain(did)%INFXSUBRT = 0.0
+rt_domain(did)%DHRT = 0.0
+rt_domain(did)%LAKE_INFLORT = 0.0
+!  rt_domain(did)%LAKE_INFLORT_DUM = 0.0
+rt_domain(did)%LAKE_CT = 0
+rt_domain(did)%STRM_CT = 0
+!  rt_domain(did)%QSTRMVOLRT_DUM = 0.0
+rt_domain(did)%SOLDRAIN = 0.0
+rt_domain(did)%qinflowbase = 0.0
+
+!  rt_domain(did)%BASIN_MSK = 1
+! !DJG Initialize mass balance check variables...
+rt_domain(did)%SMC_INIT=0.
+rt_domain(did)%DSMC=0.
+rt_domain(did)%DACRAIN=0.
+rt_domain(did)%DSFCEVP=0.
+rt_domain(did)%DCANEVP=0.
+rt_domain(did)%DEDIR=0.
+rt_domain(did)%DETT=0.
+rt_domain(did)%DEPND=0.
+rt_domain(did)%DESNO=0.
+rt_domain(did)%DSFCRNFF=0.
+rt_domain(did)%DQBDRY=0.
+rt_domain(did)%SUMINFXS1=0.
+
+end subroutine LandRT_ini
+
+       subroutine deriveFromNode(did)
+            implicit none
+            integer :: did
+            integer :: i,j, kk, maxv
+            integer :: tmp(rt_domain(did)%nlinks)
+            tmp = 0
+            maxv = 1
+            do i = 1, rt_domain(did)%nlinks
+                if(rt_domain(did)%to_node(i) .gt. 0) then
+                    kk = rt_domain(did)%to_node(i)
+                    tmp(kk) = tmp(kk) + 1
+                    if(maxv .lt. tmp(kk)) maxv = tmp(kk)
+                end if
+            end do
+            allocate(rt_domain(did)%pnode(rt_domain(did)%nlinks,maxv+1) )
+            rt_domain(did)%maxv_p = maxv+1
+            rt_domain(did)%pnode = -99
+            rt_domain(did)%pnode(:,1) = 1
+            do i = 1, rt_domain(did)%nlinks
+                if(rt_domain(did)%to_node(i) .gt. 0) then
+                    j = rt_domain(did)%to_node(i)
+                    rt_domain(did)%pnode(j,1) = rt_domain(did)%pnode(j,1) + 1
+                    kk = rt_domain(did)%pnode(j,1)
+                    rt_domain(did)%pnode(j,kk) = i
+                end if
+            end do
+
+       end subroutine deriveFromNode
+
+
+
+END MODULE module_Routing
diff --git a/wrfv2_fire/hydro/Routing/module_UDMAP.F b/wrfv2_fire/hydro/Routing/module_UDMAP.F
new file mode 100644
index 00000000..e2983ddb
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_UDMAP.F
@@ -0,0 +1,569 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+! This subrouting includs the data structure and tools used for NHDPlus network mapping.
+module module_UDMAP
+
+use module_namelist, only: nlst_rt
+#ifdef MPP_LAND
+use module_mpp_land, only: my_id, local_startx_rt, local_starty_rt,  &
+         local_endx_rt,local_endy_rt, left_id, right_id, down_id, up_id, mpp_collect_1d_int_mem, &
+         IO_id , numprocs
+use module_mpp_land, only: mpp_land_bcast_int, mpp_land_bcast_real8_1d, mpp_land_bcast_int1
+
+use module_mpp_land, only: sum_int1d, global_rt_nx, global_rt_ny, write_IO_rt_int, MPP_LAND_COM_INTEGER
+
+use MODULE_mpp_ReachLS, only : updatelinkv, ReachLS_write_io, com_write1dInt, &
+               com_decomp1dInt, pack_decomp_int, pack_decomp_real8
+
+#endif
+
+implicit none
+
+#ifndef MPP_LAND
+    integer, parameter :: numprocs=1
+#endif
+
+#include 
+
+type userDefineMapping
+    integer, allocatable, dimension(:) :: grid_i, grid_j
+    real, allocatable, dimension(:) :: weight, nodeArea, cellArea
+    integer :: ngrids
+    integer :: myid
+!   for bucket model definition
+    real, allocatable, dimension(:) :: cellWeight
+    integer, allocatable, dimension(:) :: cell_i, cell_j
+    integer :: ncell
+end type userDefineMapping
+
+TYPE ( userDefineMapping ), allocatable, DIMENSION (:) :: LUDRSL
+
+integer, allocatable, dimension(:) :: bufid
+real*8 , allocatable, dimension(:) :: bufw
+integer :: LNUMRSL  ! number of local links
+integer :: ter_rt_flag
+real*8, allocatable, dimension(:) :: basns_area
+integer :: gnpid, lnsize
+integer, allocatable, dimension(:) :: bufi,bufj
+
+contains
+    subroutine UDMP_ini(nlinksl,ixrt,jxrt,rtmask, OVRTSWCRT, SUBRTSWCRT,cell_area)
+!This is the driver for user defined mapping file funciton application.
+        integer :: ixrt, jxrt, OVRTSWCRT, SUBRTSWCRT, nlinksl
+        integer, intent(in), dimension(ixrt,jxrt):: rtmask
+        integer :: npid    !local variable.
+        real,dimension(:,:) :: cell_area
+        ter_rt_flag = 0
+        if(OVRTSWCRT .eq. 1 .or. SUBRTSWCRT .eq. 1) then
+            ter_rt_flag = 1
+        endif
+        call readUDMP(ixrt,jxrt,npid,nlinksl)
+        call UDMP2LOCAL(npid,ixrt,jxrt,rtmask, ter_rt_flag)
+        call getUDMP_area(cell_area)
+    end subroutine UDMP_ini
+
+    subroutine readUDMP(ixrt,jxrt,npid, nlinksl)
+        implicit none
+        integer :: i,j,Ndata, did, Npid, nlinksl, k, m, kk
+        integer,allocatable,dimension(:) :: g1bufid, gbufid, linkid ,bufidflag, &
+               bufid_tmp, nprocs_map, lnsizes, istart
+        integer :: ix_bufid, ii, ixrt,jxrt
+        integer, allocatable, dimension(:) :: gbufi,gbufj,bufsize
+        real*8 , allocatable, dimension(:) :: gbufw
+        
+        did = 1
+        call get_dimension(trim(nlst_rt(did)%UDMAP_FILE), ndata, npid) 
+
+#ifdef MPP_LAND
+        gnpid = npid
+        allocate (lnsizes(numprocs))
+        if(my_id .eq. io_id) then
+           allocate (istart(numprocs))
+           allocate (nprocs_map(ndata))
+           allocate(gbufi(ndata))
+           allocate(gbufj(ndata))
+           call get1d_int(trim(nlst_rt(did)%UDMAP_FILE),"i_index",gbufi)
+           call get1d_int(trim(nlst_rt(did)%UDMAP_FILE),"j_index",gbufj)
+        endif
+           call get_nprocs_map(ixrt,jxrt,gbufi,gbufj,nprocs_map,ndata)
+
+        if(my_id .eq. io_id) then
+           lnsizes = 0 
+           do i =1 , ndata
+               if(nprocs_map(i) .gt. 0) then
+                  lnsizes(nprocs_map(i)) = lnsizes(nprocs_map(i)) + 1 
+               endif
+           enddo
+        endif
+        call mpp_land_bcast_int(numprocs,lnsizes)
+
+     if(my_id .eq. io_id ) then
+        kk = 0
+        do i = 1, numprocs 
+           kk = kk + lnsizes(i) 
+        end do
+     end if
+
+      if(my_id .eq. IO_id) then
+          ii = 1
+          do i = 1, numprocs
+             istart(i) = ii
+             if(lnsizes(i) .gt. 0) then
+                ii = lnsizes(i) + ii
+             else
+                istart(i) = -999
+             endif
+          end do
+      endif
+
+      if(lnsizes(my_id+1) .gt. 0)  allocate(bufi(lnsizes(my_id+1) ))
+      call pack_decomp_int(gbufi, ndata, nprocs_map, lnsizes, istart,bufi)
+      if(my_id .eq. io_id) then 
+           if(allocated(gbufi))  deallocate(gbufi)
+      endif
+
+      
+      if(lnsizes(my_id+1) .gt. 0) allocate(bufj(lnsizes(my_id+1) ))
+      call pack_decomp_int(gbufj, ndata, nprocs_map, lnsizes, istart,bufj)
+      if(my_id .eq. io_id)  then 
+         if(allocated(gbufj)) deallocate(gbufj)
+      endif
+
+
+! check bufid
+!      check  polyid and linkid
+        allocate(linkid(nlinksl))
+        if(my_id .eq. io_id) then
+            call get1d_int(trim(nlst_rt(did)%route_link_f),"link",linkid)
+            allocate(gbufid(npid))
+            call get1d_int(trim(nlst_rt(did)%UDMAP_FILE),"polyid",gbufid)
+        endif
+#ifdef MPP_LAND
+       if(nlinksl .gt. 0) then
+          call mpp_land_bcast_int(nlinksl,linkid)
+       endif
+       call com_decomp1dInt(gbufid,npid,bufid_tmp,ix_bufid)
+#endif
+       if(ix_bufid .gt. 0) then
+          allocate(bufidflag(ix_bufid))
+          bufidflag = -999
+       endif
+
+       do i = 1, ix_bufid
+          do j = 1, nlinksl
+               if(bufid_tmp(i) .eq. linkid(j)) then
+                  bufidflag(i) = bufid_tmp(i)
+                  goto 102
+               endif
+          end do
+102       continue
+       end do
+
+#ifdef MPP_LAND
+      call com_write1dInt(bufidflag,ix_bufid,gbufid,npid)
+#endif
+      if(ix_bufid .gt. 0) then
+          if(allocated(bufidflag)) deallocate(bufidflag)
+          if(allocated(bufid_tmp)) deallocate(bufid_tmp)
+      endif
+      if(allocated(linkid)) deallocate(linkid)
+      if(my_id .eq. io_id) then
+          allocate(bufsize(npid))
+          allocate(g1bufid(ndata))
+          call get1d_int(trim(nlst_rt(did)%UDMAP_FILE),"overlaps",bufsize)
+          g1bufid = -999
+          i = 1
+          do k = 1, npid
+               do j = 1, bufsize(k)
+                 g1bufid(i) = gbufid(k)
+                 i = i + 1 
+               end do
+          enddo
+          if(allocated(bufsize))  deallocate(bufsize)
+      endif
+
+
+      if(my_id .eq. io_id) then 
+           if(allocated(gbufid)) deallocate(gbufid)
+      endif
+
+
+      if(lnsizes(my_id+1) .gt. 0) allocate(bufid(lnsizes(my_id+1) ))
+      call pack_decomp_int(g1bufid, ndata, nprocs_map, lnsizes, istart,bufid)
+      if(my_id .eq. io_id) then 
+            if(allocated(g1bufid)) deallocate(g1bufid)
+      endif
+
+
+      if(my_id .eq. io_id) then
+          allocate(gbufw(ndata))
+          call get1d_real8(trim(nlst_rt(did)%UDMAP_FILE),"regridweight",gbufw)
+      endif
+      if(lnsizes(my_id+1) .gt. 0) allocate(bufw(lnsizes(my_id+1) ))
+      call pack_decomp_real8(gbufw, ndata, nprocs_map, lnsizes, istart,bufw)
+      if(my_id .eq. io_id) then 
+          if(allocated(gbufw))     deallocate(gbufw)
+      endif
+
+
+        if(my_id .eq. io_id) then
+           if(allocated(nprocs_map)) deallocate (nprocs_map)
+           if(allocated(istart)) deallocate (istart)
+        endif
+        lnsize = lnsizes(my_id + 1)
+        if(allocated(lnsizes)) deallocate(lnsizes)
+#else
+       call hydro_stop("FATAL ERROR in UDMP : sequential not defined.")
+#endif
+
+    end subroutine readUDMP
+
+    subroutine UDMP2LOCAL(npid,ix,jx,rtmask, ter_rt_flag)
+        implicit none
+        integer :: i,j,k, ngrids, ix,jx, starti,startj, endi,endj, ii,jj, npid, kk
+        integer, intent(in), dimension(ix,jx) :: rtmask
+        integer, dimension(lnsize) :: lndflag,gridflag , tmpgridflag
+        integer :: ter_rt_flag, m, c
+
+
+!   find ngrids is 0 so that we need to mapping from subsurface runoff.
+#ifdef MPP_LAND
+        if(left_id .ge. 0) then
+           starti = local_startx_rt  + 1
+        else
+           starti = local_startx_rt 
+        endif
+        if(down_id .ge. 0) then
+           startj = local_starty_rt  + 1
+        else
+           startj = local_starty_rt 
+        endif
+        if(right_id .ge. 0) then
+           endi = local_startx_rt + ix -2
+        else
+           endi = local_startx_rt + ix -1
+        endif
+        if(up_id .ge. 0) then
+           endj = local_starty_rt + jx -2
+        else
+           endj = local_starty_rt + jx -1
+        endif
+#else
+        starti = 1
+        startj = 1
+        endi = ix
+        endj = jx
+#endif
+        gridflag = 0
+        lndflag = 0
+      
+#ifdef MPP_LAND
+        k = 0
+        do i = 1, lnsize
+           if(bufid(i) .gt. 0) then
+                if(bufi(i) .ge. starti .and. bufj(i) .ge. startj .and. &
+                    bufi(i) .le. endi   .and. bufj(i) .le. endj) then
+                    if(k .eq. 0) then
+                       k = 1
+                    else
+                       if(bufid(i) .ne. bufid(i-1)) k = k + 1
+                    endif
+                    lndflag(k) = lndflag(k) + 1
+                    if(ter_rt_flag .eq. 1) then
+                        if(rtmask(bufi(i)-local_startx_rt+1,bufj(i)-local_starty_rt+1) .ge. 0) then
+                             gridflag(k) = gridflag(k) + 1 
+                        endif
+                    endif
+                 endif
+           endif
+        end do
+
+! decide how many mapping land grids on current domain
+!       tmpgridflag = gridflag
+#ifdef MPP_LAND
+!       call mpp_collect_1d_int_mem(npid,tmpgridflag)
+#endif
+
+! decide how many user defined links on current domain
+        kk = k
+        LNUMRSL = 0 
+        do k = 1, lnsize
+           if(lndflag(k) .gt. 0) LNUMRSL = LNUMRSL + 1
+        enddo
+
+
+        if(LNUMRSL .gt. 0) then 
+               allocate(LUDRSL(LNUMRSL))
+               allocate( basns_area(LNUMRSL) )
+        else
+               write(6,*) "Warning: no routing links found."
+               call cleanBuf()
+               return
+        endif
+
+        kk = 0
+        do k = 1, lnsize 
+           if( bufid(k) .ge. 0 ) then
+             if (bufi(k) .ge. starti .and. bufj(k) .ge. startj .and. &
+                    bufi(k) .le. endi   .and. bufj(k) .le. endj ) then
+                 if(kk .eq. 0) then
+                       kk = 1
+                 else
+                       if(bufid(k) .ne. bufid(k-1)) kk = kk + 1
+                 endif
+                 LUDRSL(kk)%myid = bufid(k) 
+                 LUDRSL(kk)%ngrids = -999
+                 if(gridflag(kk) .gt. 0) then
+                   LUDRSL(kk)%ngrids = gridflag(kk)
+                   if(.not. allocated(LUDRSL(kk)%weight) ) then
+                         allocate( LUDRSL(kk)%weight(LUDRSL(kk)%ngrids ))
+                         allocate( LUDRSL(kk)%grid_i(LUDRSL(kk)%ngrids ))
+                         allocate( LUDRSL(kk)%grid_j(LUDRSL(kk)%ngrids ))
+                         allocate( LUDRSL(kk)%nodeArea(LUDRSL(kk)%ngrids ))
+                   endif
+                 endif
+!  define bucket variables
+                 LUDRSL(kk)%ncell = lndflag(kk) 
+                 if(.not. allocated(LUDRSL(kk)%cellweight) ) then
+                     allocate( LUDRSL(kk)%cellweight(LUDRSL(kk)%ncell))
+                     allocate( LUDRSL(kk)%cell_i(LUDRSL(kk)%ncell))
+                     allocate( LUDRSL(kk)%cell_j(LUDRSL(kk)%ncell))
+                     allocate( LUDRSL(kk)%cellArea(LUDRSL(kk)%ncell))
+                 endif
+             endif
+           endif
+        enddo
+
+
+! maping grid_i, grid_j and weight
+        kk = 0
+        m  = 1
+        c  = 1
+        do i = 1, lnsize 
+               if( (bufid(i) .ge. 0)  ) then 
+                   if(bufi(i) .ge. starti .and. bufj(i) .ge. startj .and. &
+                      bufi(i) .le. endi   .and. bufj(i) .le. endj) then
+                      if(kk .eq. 0) then
+                         kk = 1
+                      else
+                         if(bufid(i) .ne. bufid(i-1)) then 
+                             kk = kk + 1
+                             m  = 1
+                             c  = 1
+                         endif
+                      endif
+
+                      if(LUDRSL(kk)%ngrids .gt. 0) then 
+                          if(rtmask(bufi(i)-local_startx_rt+1,bufj(i)-local_starty_rt+1) .ge. 0) then
+                             LUDRSL(kk)%grid_i(m) = bufi(i) - local_startx_rt+1
+                             LUDRSL(kk)%grid_j(m) = bufj(i) - local_starty_rt+1
+                             LUDRSL(kk)%weight(m) = bufw(i) 
+                             m  = m  + 1
+                          endif
+                      endif
+!! begin define bucket variables
+                          LUDRSL(kk)%cell_i(c) = bufi(i) - local_startx_rt+1
+                          LUDRSL(kk)%cell_j(c) = bufj(i) - local_starty_rt+1
+                          LUDRSL(kk)%cellWeight(c) = bufw(i)
+                          c  = c  + 1
+!! end define bucket variables 
+                   endif
+                endif
+        end do
+
+        call cleanBuf()
+
+#else
+        call hydro_stop("FATAL ERROR in UDMP: Sequential not work.")
+#endif
+   
+    end subroutine UDMP2LOCAL
+
+    subroutine cleanBuf()
+        if(allocated(bufi))  deallocate(bufi)
+        if(allocated(bufj))  deallocate(bufj)
+        if(allocated(bufw))  deallocate(bufw)
+        if(allocated(bufid))  deallocate(bufid)
+    end subroutine cleanBuf
+
+     subroutine get_dimension(fileName, ndata,npid)
+            implicit none
+            character(len=*) fileName
+            integer ncid , iret, ndata,npid, dimid
+#ifdef MPP_LAND
+            if(my_id .eq. IO_id) then
+#endif
+               iret = nf_open(fileName, NF_NOWRITE, ncid)
+               if (iret /= 0) then
+                  write(*,'("FATAL ERROR: Problem opening mapping file: ''", A, "''")') &
+                       trim(fileName)
+                  call hydro_stop("In get_dimension() - Problem opening mapping file.")
+               endif
+        
+               iret = nf_inq_dimid(ncid, "polyid", dimid)
+        
+               if (iret /= 0) then
+                  print*, "nf_inq_dimid:  polyid"
+                  call hydro_stop("In get_dimension() - nf_inq_dimid:  polyid")
+               endif
+           
+               iret = nf_inq_dimlen(ncid, dimid, npid)
+           
+               iret = nf_inq_dimid(ncid, "data", dimid)
+               if (iret /= 0) then
+                          print*, "nf_inq_dimid:  data"
+                          call hydro_stop("In get_file_dimension() - nf_inq_dimid:  data")
+               endif
+        
+               iret = nf_inq_dimlen(ncid, dimid, ndata)
+               iret = nf_close(ncid)
+#ifdef MPP_LAND
+            endif
+            call mpp_land_bcast_int1(ndata)
+            call mpp_land_bcast_int1(npid)
+#endif
+            return
+     end subroutine get_dimension
+
+       subroutine get1d_real8(fileName,var_name,out_buff)
+          implicit none
+          integer :: ivar, iret,varid,ncid
+          real*8 out_buff(:)
+          character(len=*), intent(in) :: var_name
+          character(len=*), intent(in) :: fileName
+
+          iret = nf_open(trim(fileName), NF_NOWRITE, ncid)
+          if (iret .ne. 0) then
+            print*,"failed to open the netcdf file: ",trim(fileName)
+            call hydro_stop("In get1d_real8() - failed to open the netcdf file.")
+            return
+          endif
+          ivar = nf_inq_varid(ncid,trim(var_name),  varid)
+          if(ivar .ne. 0) then
+               write(6,*) "Read Variable Error file: ",trim(fileName)
+               write(6,*) "Read Error: could not find ",trim(var_name)
+               call hydro_stop("In get1d_real8() - failed to read netcdf varialbe name. ")
+          end if
+          iret = nf_get_var_double(ncid, varid, out_buff)
+          iret = nf_close(ncid)
+      end subroutine get1d_real8
+
+       subroutine get1d_int(fileName,var_name,out_buff)
+          implicit none
+          integer :: ivar, iret,varid,ncid
+          integer out_buff(:)
+          character(len=*), intent(in) :: var_name
+          character(len=*), intent(in) :: fileName
+
+          iret = nf_open(trim(fileName), NF_NOWRITE, ncid)
+          if (iret .ne. 0) then
+            print*,"FATAL ERROR: Failed to open the netcdf file: ",trim(fileName)
+            call hydro_stop("In get1d_int() -  Failed to open the netcdf file")
+            return
+          endif
+          ivar = nf_inq_varid(ncid,trim(var_name),  varid)
+          if(ivar .ne. 0) then
+               write(6,*) "Read Variable Error file: ",trim(fileName)
+               write(6,*) "Read Error: could not find ",trim(var_name)
+               call hydro_stop("In get1d_int() - failed to read netcdf variable name.")
+          end if
+          iret = nf_get_var_int(ncid, varid, out_buff)
+          iret = nf_close(ncid)
+      end subroutine get1d_int
+
+      subroutine getUDMP_area(cell_area)
+         implicit none
+         integer i,j,k, m
+         real, dimension(:,:) :: cell_area
+         do k  = 1, LNUMRSL
+            if(LUDRSL(k)%ngrids .gt. 0) then
+                do m = 1, LUDRSL(k)%ngrids
+                    LUDRSL(k)%nodeArea(m) = cell_area(LUDRSL(k)%grid_i(m),LUDRSL(k)%grid_j(m)) 
+                enddo
+            endif
+                do m = 1, LUDRSL(k)%ncell
+                    LUDRSL(k)%cellArea(m) = cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) 
+                enddo
+           
+            basns_area(k) = 0 
+            do m = 1, LUDRSL(k)%ncell
+                    basns_area(k) = basns_area(k) + &
+                          cell_area(LUDRSL(k)%cell_i(m),LUDRSL(k)%cell_j(m)) * LUDRSL(k)%cellWeight(m) 
+            enddo
+            
+         end do
+      end subroutine getUDMP_area
+    
+      subroutine get_basn_area_nhd(inOut)
+         implicit none
+         real, dimension(:) :: inOut
+         real, dimension(gnpid) :: buf
+#ifdef MPP_LAND
+         call updateLinkV(basns_area, inOut)
+#else
+         inOut = basns_area
+#endif
+
+      
+      end subroutine get_basn_area_nhd
+
+      subroutine get_nprocs_map(ix,jx,bufi,bufj,nprocs_map,ndata)
+          implicit none
+          integer,dimension(:)  :: bufi, bufj,nprocs_map 
+!          integer, allocatable, dimension(:) ::  lbufi,lbufj, lmap
+          integer  :: ndata, lsize, ix,jx
+          integer, dimension(ix,jx) :: mask
+          integer, allocatable,dimension(:,:) :: gmask
+
+        integer :: i,j,k, starti,startj, endi,endj, ii,jj, npid, kk
+#ifdef MPP_LAND
+           
+          mask = my_id + 1
+          if(my_id .eq. IO_id) allocate(gmask(global_rt_nx, global_rt_ny))
+
+          call MPP_LAND_COM_INTEGER(mask,IX,JX,99)
+          call write_IO_rt_int(mask, gmask) 
+
+          if(my_id .eq. io_id ) then
+             nprocs_map = -999
+             do i = 1, ndata
+                  if( (bufi(i) .gt. 0 .and. bufi(i) .le. global_rt_nx) .and.  &
+                     (bufj(i) .gt. 0 .and. bufj(i) .le. global_rt_ny) ) then
+                     nprocs_map(i) = gmask(bufi(i), bufj(i))
+                     if( gmask(bufi(i), bufj(i)) .lt. 0) then
+                         write(6,*) "mapping error in gmask : ", bufi(i) ,bufj(i)
+                     endif
+                  else
+                      write(6,*) "no mapping for i,j : ", bufi(i) ,bufj(i)
+                  endif
+             end do
+
+             if(allocated(gmask)) deallocate(gmask)
+          endif
+#else
+        call hydro_stop("FATAL ERROR in UDMP: Sequential not work.")
+#endif
+
+
+      end subroutine get_nprocs_map
+
+
+end module module_UDMAP
diff --git a/wrfv2_fire/hydro/Routing/module_channel_routing.F b/wrfv2_fire/hydro/Routing/module_channel_routing.F
new file mode 100644
index 00000000..5c1b2746
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_channel_routing.F
@@ -0,0 +1,2277 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+MODULE module_channel_routing
+#ifdef MPP_LAND
+  USE module_mpp_land
+  use MODULE_mpp_ReachLS, only : updatelinkv,                   & 
+                                 ReachLS_write_io, gbcastvalue, &
+                                 gbcastreal2
+
+#endif
+  IMPLICIT NONE
+
+  contains
+
+! ------------------------------------------------
+!   FUNCTION MUSKING
+! ------------------------------------------------
+	REAL FUNCTION MUSKING(idx,qup,quc,qdp,dt,Km,X)
+
+	IMPLICIT NONE
+
+!--local variables
+        REAL    :: C1, C2, C3
+        REAL    :: Km         !K travel time in hrs in reach
+        REAL    :: X          !weighting factors 0<=X<=0.5 
+        REAL    :: dt         !routing period in hrs
+        REAL    :: avgbf      !average base flow for initial condition
+        REAL    :: qup        !inflow from previous timestep
+        REAL    :: quc        !inflow  of current timestep
+        REAL    :: qdp        !outflow of previous timestep
+        REAL    :: dth        !timestep in hours
+        INTEGER :: idx       ! index
+
+        dth = dt/3600    !hours in timestep
+        C1 = (dth - 2*Km*X)/(2*Km*(1-X)+dth)
+        C2 = (dth+2*Km*X)/(2*Km*(1-X)+dth)
+        C3 = (2*Km*(1-X)-dth)/(2*Km*(1-X)+dth)
+        MUSKING = (C1*quc)+(C2*qup)+(C3*qdp)
+
+! ----------------------------------------------------------------
+  END FUNCTION MUSKING
+! ----------------------------------------------------------------
+
+! ------------------------------------------------
+!   SUBROUTINE LEVELPOOL
+! ------------------------------------------------
+
+SUBROUTINE LEVELPOOL(ln,qi0,qi1,qo1,ql,dt,H,ar,we,maxh,wc,wl,oe,oc,oa)
+
+    !! ----------------------------  argument variables
+    !! All elevations should be relative to a common base (often belev(k))
+
+    real, intent(INOUT) :: H       ! water elevation height (m)
+    real, intent(IN)    :: dt      ! routing period [s]
+    real, intent(IN)    :: qi0     ! inflow at previous timestep (cms)
+    real, intent(IN)    :: qi1     ! inflow at current timestep (cms)
+    real, intent(OUT)   :: qo1     ! outflow at current timestep
+    real, intent(IN)    :: ql      ! lateral inflow
+    real, intent(IN)    :: ar      ! area of reservoir (km^2)
+    real, intent(IN)    :: we      ! bottom of weir elevation
+    real, intent(IN)    :: wc      ! weir coeff.
+    real, intent(IN)    :: wl      ! weir length (m)
+    real, intent(IN)    :: oe      ! orifice elevation
+    real, intent(IN)    :: oc      ! orifice coeff.
+    real, intent(IN)    :: oa      ! orifice area (m^2)
+    real, intent(IN)    :: maxh    ! max depth of reservoir before overtop (m)                     
+    integer, intent(IN) :: ln      ! lake number
+
+    !!DJG Add lake option switch here...move up to namelist in future versions...
+    integer :: LAKE_OPT            ! Lake model option (move to namelist later)
+    real    :: Htmp                ! Temporary assign of incoming lake el. (m)
+
+    !! ----------------------------  local variables
+    real :: sap                    ! local surface area values
+    real :: discharge              ! storage discharge m^3/s
+    real :: tmp1, tmp2
+    real :: dh, dh1, dh2, dh3      ! height function and 3 order RK
+    real :: It, Itdt_3, Itdt_2_3
+    real :: maxWeirDepth           !maximum capacity of weir
+    !! ----------------------------  subroutine body: from chow, mad mays. pg. 252
+    !! -- determine from inflow hydrograph
+
+
+    !!DJG Set hardwire for LAKE_OPT...move specification of this to namelist in
+    !future versions...
+    LAKE_OPT = 2
+    Htmp = H   !temporary set of incoming lake water elevation...
+    
+    
+    !!DJG IF-block for lake model option  1 - outflow=inflow, 2 - Chow et al level
+    !pool, .....
+    if (LAKE_OPT.eq.1) then     ! If-block for simple pass through scheme....
+       
+       qo1 = qi1                 ! Set outflow equal to inflow at current time      
+       H = Htmp                  ! Set new lake water elevation to incoming lake el.
+       
+    else if (LAKE_OPT.eq.2) then   ! If-block for Chow et al level pool scheme
+ 
+    It = qi0
+    Itdt_3   = (qi0 + (qi1 + ql))/3
+    Itdt_2_3 = (qi0 + (qi1 + ql))/3 + Itdt_3
+    maxWeirDepth =  maxh - we   
+
+    !-- determine Q(dh) from elevation-discharge relationship
+    !-- and dh1
+    dh = H - we
+    if (dh .gt. maxWeirDepth) then 
+       dh = maxWeirDepth 
+    endif
+
+    if (dh .gt. 0.0 ) then              !! orifice and overtop discharge
+        tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        tmp2 = wc * wl * (dh ** 2./3.)
+        discharge = tmp1 + tmp2
+
+        if (H .gt. 0.0) then
+          sap = (ar * 1.0E6 ) * (1 + (H - we) / H)
+        else
+          sap  = 0.0
+        endif
+
+    else if ( H .gt. oe ) then     !! only orifice flow,not full
+        discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        sap = ar * 1.0E6
+    else
+        discharge = 0.0
+        sap = ar * 1.0E6
+    endif
+
+    if (sap .gt. 0) then 
+      dh1 = ((It - discharge)/sap)*dt
+    else
+      dh1 = 0.0
+    endif
+
+    !-- determine Q(H + dh1/3) from elevation-discharge relationship
+    !-- dh2
+    dh = (H+dh1/3) - we
+    if (dh .gt. maxWeirDepth) then 
+       dh = maxWeirDepth 
+    endif
+
+    if (dh .gt. 0.0 ) then              !! orifice and overtop discharge
+        tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        tmp2 = wc * wl * (dh ** 2./3.) 
+        discharge = tmp1 + tmp2
+
+        if (H .gt. 0.0) then 
+         sap = (ar * 1.0E6 ) * (1 + (H - we) / H)
+        else
+         sap  = 0.0
+        endif
+
+    else if ( H .gt. oe ) then     !! only orifice flow,not full
+        discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        sap = ar * 1.0E6
+    else
+        discharge = 0.0
+        sap = ar * 1.0E6
+    endif
+
+    if (sap .gt. 0.0) then 
+     dh2 = ((Itdt_3 - discharge)/sap)*dt
+    else
+     dh2 = 0.0
+    endif
+
+    !-- determine Q(H + 2/3 dh2) from elevation-discharge relationship
+    !-- dh3
+    dh = (H + (0.667*dh2)) - we
+    if (dh .gt. maxWeirDepth) then 
+       dh = maxWeirDepth 
+    endif
+
+    if (dh .gt. 0.0 ) then              !! orifice and overtop discharge
+        tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        tmp2 = wc * wl * (dh ** 2./3.) 
+        discharge = tmp1 + tmp2
+
+        if (H .gt. 0.0) then
+         sap = (ar * 1.0E6 ) * (1 + (H - we) / H)
+        else
+         sap = 0.0
+        endif 
+
+    else if ( H .gt. oe ) then     !! only orifice flow,not full
+        discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        sap = ar * 1.0E6
+    else
+        discharge = 0.0
+        sap = ar * 1.0E6
+    endif
+    
+    if (sap .gt. 0.0) then 
+      dh3 = ((Itdt_2_3 - discharge)/sap)*dt
+    else
+      dh3 = 0.0
+    endif
+
+    !-- determine dh and H
+    dh = (dh1/4.) + (0.75*dh3)
+    H = H + dh
+
+    !-- compute final discharge
+    dh = H - we
+    if (dh .gt. maxWeirDepth) then 
+       dh = maxWeirDepth 
+    endif
+    if (dh .gt. 0.0 ) then              !! orifice and overtop discharge
+        tmp1 = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        tmp2 = wc * wl * (dh ** 2./3.)
+        discharge = tmp1 + tmp2
+
+        if (H .gt. 0.0) then 
+         sap = (ar * 1.0E6 ) * (1 + (H - we) / H)
+        else
+         sap = 0.0
+        endif
+
+    else if ( H .gt. oe ) then     !! only orifice flow,not full
+        discharge = oc * oa * sqrt(2 * 9.81 * ( H - oe ) )
+        sap = ar * 1.0E6
+    else
+        discharge = 0.0
+        sap = ar * 1.0E6
+    endif
+
+    if(H .ge. maxh) then  ! overtop condition
+     discharge = qi1
+     H = maxh
+    endif
+
+    qo1  = discharge  ! return the flow rate from reservoir
+
+23 format('botof H dh orf wr Q',f8.4,2x,f8.4,2x,f8.3,2x,f8.3,2x,f8.2)
+24 format('ofonl H dh sap Q ',f8.4,2x,f8.4,2x,f8.0,2x,f8.2)
+
+ 
+     ELSE   ! ELSE for LAKE_OPT....
+     ENDIF  ! ENDIF for LAKE_OPT....
+ 
+  RETURN
+
+! ----------------------------------------------------------------
+  END SUBROUTINE LEVELPOOL
+! ----------------------------------------------------------------
+
+
+! ------------------------------------------------
+!   FUNCTION Diffusive wave
+! ------------------------------------------------
+        REAL FUNCTION DIFFUSION(nod,z1,z20,h1,h2,dx,n, &
+                                Bw, Cs)
+        IMPLICIT NONE
+!-- channel geometry and characteristics
+        REAL    :: Bw         !-bottom width (meters)
+        REAL    :: Cs         !-Channel side slope slope
+        REAL    :: dx         !-channel lngth (m)
+        REAL,intent(in)    :: n          !-mannings coefficient
+        REAL    :: R          !-Hydraulic radius
+        REAL    :: AREA       !- wetted area
+        REAL    :: h1,h2      !-tmp height variables
+        REAL    :: z1,z2      !-z1 is 'from', z2 is 'to' elevations
+        REAL    :: z          !-channel side distance
+        REAL    :: w          !-upstream weight
+        REAL    :: Ku,Kd      !-upstream and downstream conveyance
+        REAL    :: Kf         !-final face conveyance
+        REAL    :: Sf         !-friction slope
+        REAL    :: sgn        !-0 or 1 
+        INTEGER :: nod         !- node
+        REAL ::  z20, dzx
+
+! added by Wei Yu for bad data.
+
+        dzx = (z1 - z20)/dx
+        if(dzx .lt. 0.002) then
+           z2 = z1 - dx*0.002  
+        else
+           z2 = z20
+        endif
+!end 
+
+        if (n.le.0.0.or.Cs.le.0.or.Bw.le.0) then
+         print *, "Error in Diffusion function ->channel coefficients"
+         print *, "nod, n, Cs, Bw", nod, n, Cs, Bw 
+         call hydro_stop("In DIFFUSION() - Error channel coefficients.")
+        endif
+
+!        Sf = ((z1+h1)-(z2+h2))/dx  !-- compute the friction slope
+       !if(z1 .eq. z2) then
+       ! Sf = ((z1-(z2-0.01))+(h1-h2))/dx  !-- compute the friction slope
+       !else
+!         Sf = ((z1-z2)+(h1-h2))/dx  !-- compute the friction slope
+       !endif
+
+!modifieed by Wei Yu for false geography data
+         if(abs(z1-z2) .gt. 1.0E5) then
+#ifdef HYDRO_D
+             print*, "WARNING: huge slope rest to 0 for channel grid.", z1,z2
+#endif
+             Sf = ((h1-h2))/dx  !-- compute the friction slope
+         else
+             Sf = ((z1-z2)+(h1-h2))/dx  !-- compute the friction slope
+         endif
+!end  modfication
+
+        sgn = SGNf(Sf)             !-- establish sign
+
+        w = 0.5*(sgn + 1.)         !-- compute upstream or downstream weighting
+        
+        z = 1/Cs                   !--channel side distance (m)
+        R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z*z)) !-- Hyd Radius
+        AREA = (Bw+z*h1)*h1        !-- Flow area
+        Ku = (1/n)*(R**(2./3.))*AREA     !-- convenyance
+
+        R = ((Bw+z*h2)*h2)/(Bw+2*h2*sqrt(1+z*z)) !-- Hyd Radius
+        AREA = (Bw+z*h2)*h2        !-- Flow area
+        Kd = (1/n)*(R**(2./3.))*AREA     !-- convenyance
+
+        Kf =  (1-w)*Kd + w*Ku      !-- conveyance 
+        DIFFUSION = Kf * sqrt(abs(Sf))*sgn
+
+
+100     format('z1,z2,h1,h2,kf,Dif, Sf, sgn  ',f8.3,2x,f8.3,2x,f8.4,2x,f8.4,2x,f8.3,2x,f8.3,2x,f8.3,2x,f8.0)
+
+  END FUNCTION DIFFUSION
+! ----------------------------------------------------------------
+
+! ------------------------------------------------
+!   FUNCTION MUSKINGUM CUNGE
+! ------------------------------------------------
+        REAL FUNCTION MUSKINGCUNGE(idx,qup, quc, qdp, ql,&
+                                   dt,So,dx,n,Cs,Bw)
+        IMPLICIT NONE
+
+!--local variables
+        REAL    :: C1, C2, C3, C4
+        REAL    :: Km          !K travel time in hrs in reach
+        REAL    :: X          !weighting factors 0<=X<=0.5
+        REAL    :: dt         !routing period in  seconds
+        REAL    :: qup        !flow upstream previous timestep
+        REAL    :: quc        !flow upstream current timestep
+        REAL    :: qdp        !flow downstream previous timestep
+!       REAL    :: qdc        !flow downstream current timestep
+        REAL    :: ql         !lateral inflow through reach (m^3/sec)
+        REAL    :: Ck         ! wave celerity (m/s)
+
+!-- channel geometry and characteristics
+        REAL    :: Bw         ! bottom width (meters)
+        REAL    :: Cs         ! Channel side slope slope
+        REAL    :: So         ! Channel bottom slope %
+        REAL    :: dx         ! channel lngth (m)
+        REAL    :: n          ! mannings coefficient
+        REAL    :: Tw         ! top width at peak flow
+        REAL    :: AREA       ! Cross sectional area m^2
+        REAL    :: Z          ! trapezoid distance (m)
+        REAL    :: R          ! Hydraulic radius
+        REAL    :: WP         ! wetted perimmeter
+        REAL    :: h          ! depth of flow
+        REAL    :: h_0,h_1    ! secant method estimates
+        REAL    :: Qj_0       ! secant method estimates
+        REAL    :: Qj         ! intermediate flow estimate
+        REAL    :: D,D1       ! diffusion coeff
+        REAL    :: dtr        ! required timestep, minutes
+        REAL    :: error
+        REAL    :: hp         !courant, previous height
+        INTEGER :: maxiter    !maximum number of iterations
+
+
+!-- local variables.. needed if channel is sub-divded
+        REAL    :: a,b,c
+        INTEGER :: i,idx     !-- channel segment counter
+
+!yw add
+        goto 101
+        C1   = 0
+        C2   = 0
+        C3   = 0
+        C4   = 0
+        Km   = 0
+        X    = 0        !weighting factors 0<=X<=0.5
+        Ck   = 0
+        Tw   = 0       ! top width at peak flow
+        AREA = 0      ! Cross sectional area m^2
+        Z    = 0         ! trapezoid distance (m)
+        R    = 0         ! Hydraulic radius
+        WP   = 0         ! wetted perimmeter
+         h   = 0        ! depth of flow
+        h_0  = 0
+        h_1  = 0       ! secant method estimates
+        Qj_0 = 0      ! secant method estimates
+        D    = 0
+        D1   = 0        ! diffusion coeff
+        dtr   = 0       ! required timestep, minutes
+        error = 1.0
+        hp    = 0        !courant, previous height
+        maxiter = 0
+        a = 0
+101     continue
+!end yw
+
+        c = 0.52    !-- coefficnets for finding dx/Ckdt
+        b = 1.15
+        
+        if(Cs .eq.0) then 
+         z = 1.0 
+        else 
+         z = 1/Cs              !channel side distance (m)
+        endif
+
+        !qC = quc + ql !current upstream in reach
+
+        if (n .le.0 .or. So .le. 0 .or. z .le. 0 .or. Bw .le. 0) then
+          print*, "Error in channel coefficients -> Muskingum cunge",n,So,z,Bw
+          call hydro_stop("In MUSKINGCUNGE() - Error in channel coefficients")
+        end if
+
+        error   = 1.0
+        maxiter = 0
+        a = 0.0
+
+        if ((quc+ql) .lt. 100) then 
+          b=5 
+        else 
+         b= 20
+        endif
+
+!-------------  Secant Method
+        h    =  (a+b)/2  !- upper interval
+        h_0  = 0.0       !- lower interval
+        Qj_0 = 0.0       !- initial flow of lower interval
+
+        do while ((error .gt. 0.05 .and. maxiter .le. 100 .and. h .gt. 0.01))  
+
+          !----- lower interval  --------------------
+           Tw = Bw + 2*z*h_0                    !--top width of the channel inflow
+           Ck = (sqrt(So)/n)*(5./3.)*(h_0**0.667)   !-- pg 287 Chow, Mdt, Mays
+           if(Ck .gt. 0.0) then
+             Km = dx/Ck                       !-- seconds Muskingum Param
+             if(Km .lt. dt) then           
+               Km = dt
+             endif
+           else 
+             Km = dt
+           endif
+ 
+           if(Tw*So*Ck*dx .eq. 0.0) then 
+             X = 0.25
+           else
+             X = 0.5-(Qj_0/(2*Tw*So*Ck*dx))
+           endif
+  
+           if(X .le. 0.0) then 
+             X = 0.25
+           elseif(X .gt. 0.35) then
+             X = 0.35
+           endif
+  
+           D = (Km*(1 - X) + dt/2)              !--seconds
+            if(D .eq. 0.0) then 
+              print *, "FATAL ERROR: D is 0 in MUSKINGCUNGE", Km, X, dt,D
+              call hydro_stop("In MUSKINGCUNGE() - D is 0.")
+           endif 
+  
+           C1 =  (Km*X + dt/2)/D
+           C2 =  (dt/2 - Km*X)/D
+           C3 =  (Km*(1-X)-dt/2)/D
+           C4 =  (ql*dt)/D                       !-- ql already multipled by the dx length
+
+           if(h_0 .le. 0.0) then 
+             AREA= 0.0
+             WP = 0.0
+           else
+            AREA = (Bw * h_0 + z * (h_0*h_0) )
+            WP   = (Bw * h_0 + z * (h_0*h_0)) / (Bw + 2 * h_0 * sqrt(1+z*z))
+           endif
+           
+           if(WP .le. 0.0) then 
+              Qj_0 =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4)
+           else 
+              Qj_0 =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4) - ((1/n) * AREA * (WP**(2./3.)) * sqrt(So)) !f(x)
+           endif
+           
+           !--upper interval -----------
+           Tw = Bw + 2*z*h                    !--top width of the channel inflow
+           Ck = (sqrt(So)/n)*(5./3.)*(h**0.667)   !-- pg 287 Chow, Mdt, Mays
+           if(Ck .gt. 0.0) then
+             Km = dx/Ck                       !-- seconds Muskingum Param
+             if(Km .lt. dt) then           
+               Km = dt
+             endif
+           else 
+             Km = dt
+           endif
+ 
+           if(Tw*So*Ck*dx .eq. 0.0) then 
+             X = 0.25
+           else
+             X = 0.5-(((C1*qup)+(C2*quc)+(C3*qdp) + C4)/(2*Tw*So*Ck*dx))
+           endif
+  
+           if(X .le. 0.0) then 
+             X = 0.25
+           elseif(X .gt. 0.35) then
+             X = 0.35
+           endif
+  
+           D = (Km*(1 - X) + dt/2)              !--seconds
+            if(D .eq. 0.0) then 
+              print *, "FATAL ERROR: D is 0 in MUSKINGCUNGE", Km, X, dt,D
+              call hydro_stop("In MUSKINGCUNGE() - D is 0.")
+           endif 
+  
+           C1 =  (Km*X + dt/2)/D
+           C2 =  (dt/2 - Km*X)/D
+           C3 =  (Km*(1-X)-dt/2)/D
+           C4 =  (ql*dt)/D                       !-- ql already multipled by the dx length
+
+           if(h .le. 0) then 
+            AREA = 0.0
+            WP   = 0.0
+           else
+            AREA = (Bw * h + z * (h*h) )
+            WP   = (Bw * h + z * (h*h)) / (Bw + 2 * h * sqrt(1+z*z))
+           endif 
+           
+           if(WP .le. 0.0) then 
+             Qj =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4)
+           else
+             Qj =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4) -((1/n) * AREA * (WP**(2./3.)) * sqrt(So))
+           endif
+
+           if(Qj_0-Qj .ne. 0.0) then
+             h_1 = h - ((Qj * (h_0 - h))/(Qj_0 - Qj)) !update h, 3rd estimate
+              if(h_1 .lt. 0.0) then
+                h_1 = h
+              endif
+           else
+             h_1 = h
+           endif
+
+           error = abs((h_1 - h)/h) !error is new estatimate and 2nd estimate
+
+!           if(idx .eq. 626) then 
+!             write(6,*) h_0,h,h_1,error
+!           endif
+
+           h_0  = h 
+           h    = h_1
+           maxiter = maxiter + 1
+
+      end do
+
+      if((maxiter .ge. 100 .and. error .gt. 0.05) .or. h .gt. 100) then 
+
+         print*, "WARNING:"
+         print*, "id,err,iters,h", idx, error, maxiter, h
+         print*, "n,z,B,So,dx,X,dt,Km",n,z,Bw,So,dx,X,dt,Km
+         print*, "qup,quc,qdp,ql", qup,quc,qdp,ql
+         if(h.gt.100) then
+              print*, "FATAL ERROR: Water Elevation Calculation is Diverging"
+              call hydro_stop("In MUSKINGCUNGE() - Water Elevation Calculation is Diverging")
+         endif
+      endif
+
+!      if(idx .eq. 626) then 
+!         write(6,*) ((C1*qup)+(C2*quc)+(C3*qdp) + C4) !-- pg 295 Bedient huber
+!      endif
+
+!     MUSKINGCUNGE =  h 
+!yw      MUSKINGCUNGE =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4) !-- pg 295 Bedient huber
+
+!yw added for test
+
+      if(((C1*qup)+(C2*quc)+(C3*qdp) + C4) .lt. 0.0) then
+         MUSKINGCUNGE =  MAX( ( (C1*qup)+(C2*quc) + C4),((C1*qup)+(C3*qdp) + C4) )
+      else
+          MUSKINGCUNGE =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4) !-- pg 295 Bedient huber
+      endif
+
+
+! ----------------------------------------------------------------
+
+  END FUNCTION MUSKINGCUNGE
+
+
+  SUBROUTINE SUBMUSKINGCUNGE(qdc,vel,idx,qup,quc,qdp,ql,dt,So,dx,n,Cs,Bw)
+
+        IMPLICIT NONE
+
+        REAL, intent(IN)       :: dt         !routing period in  seconds
+        REAL, intent(IN)       :: qup        !flow upstream previous timestep
+        REAL, intent(IN)       :: quc        !flow upstream current timestep
+        REAL, intent(IN)       :: qdp        !flow downstream previous timestep
+        REAL, intent(INOUT)    :: qdc        !flow downstream current timestep
+        REAL, intent(IN)       :: ql         !lateral inflow through reach (m^3/sec)
+        REAL, intent(IN)       :: Bw         ! bottom width (meters)
+        REAL, intent(IN)       :: Cs         ! Channel side slope slope
+        REAL, intent(IN)       :: So         ! Channel bottom slope %
+        REAL, intent(IN)       :: dx         ! channel lngth (m)
+        REAL, intent(IN)       :: n          ! mannings coefficient
+        REAL, intent(INOUT)    :: vel        ! mannings coefficient
+        INTEGER, intent(IN)    :: idx        ! channel id
+
+!--local variables
+        REAL    :: C1, C2, C3, C4
+        REAL    :: Km          !K travel time in hrs in reach
+        REAL    :: X           !weighting factors 0<=X<=0.5
+        REAL    :: Ck          ! wave celerity (m/s)
+
+!-- channel geometry and characteristics
+        REAL    :: Tw         ! top width at peak flow
+        REAL    :: AREA       ! Cross sectional area m^2
+        REAL    :: Z          ! trapezoid distance (m)
+        REAL    :: R          ! Hydraulic radius
+        REAL    :: WP         ! wetted perimmeter
+        REAL    :: h          ! depth of flow
+        REAL    :: h_0,h_1    ! secant method estimates
+        REAL    :: Qj_0       ! secant method estimates
+        REAL    :: Qj         ! intermediate flow estimate
+        REAL    :: D,D1       ! diffusion coeff
+        REAL    :: dtr        ! required timestep, minutes
+        REAL    :: error
+        REAL    :: hp         !courant, previous height
+        INTEGER :: maxiter    !maximum number of iterations
+
+!-- local variables.. needed if channel is sub-divded
+        REAL    :: a,b,c
+        INTEGER :: i          !-- channel segment counter
+
+!yw add
+        goto 101
+        C1   = 0
+        C2   = 0
+        C3   = 0
+        C4   = 0
+        Km   = 0
+        X    = 0        !weighting factors 0<=X<=0.5
+        Ck   = 0
+        Tw   = 0       ! top width at peak flow
+        AREA = 0      ! Cross sectional area m^2
+        Z    = 0         ! trapezoid distance (m)
+        R    = 0         ! Hydraulic radius
+        WP   = 0         ! wetted perimmeter
+         h   = 0        ! depth of flow
+        h_0  = 0
+        h_1  = 0       ! secant method estimates
+        Qj_0 = 0      ! secant method estimates
+        D    = 0
+        D1   = 0        ! diffusion coeff
+        dtr   = 0       ! required timestep, minutes
+        error = 1.0
+        hp    = 0        !courant, previous height
+        maxiter = 0
+        a = 0
+101     continue
+!end yw
+
+        c = 0.52    !-- coefficnets for finding dx/Ckdt
+        b = 1.15
+        
+        if(Cs .eq.0) then 
+         z = 1.0 
+        else 
+         z = 1/Cs              !channel side distance (m)
+        endif
+
+        !qC = quc + ql !current upstream in reach
+
+        if (n .le.0 .or. So .le. 0 .or. z .le. 0 .or. Bw .le. 0) then
+          print*, "Error in channel coefficients -> Muskingum cunge",n,So,z,Bw
+          call hydro_stop("In MUSKINGCUNGE() - Error in channel coefficients")
+        end if
+
+        error   = 1.0
+        maxiter = 0
+        a = 0.0
+
+        if ((quc+ql) .lt. 100) then 
+          b=5 
+        else 
+         b= 20
+        endif
+
+!-------------  Secant Method
+        h    =  (a+b)/2  !- upper interval
+        h_0  = 0.0       !- lower interval
+        Qj_0 = 0.0       !- initial flow of lower interval
+
+        do while ((error .gt. 0.05 .and. maxiter .le. 100 .and. h .gt. 0.01))  
+
+          !----- lower interval  --------------------
+           Tw = Bw + 2*z*h_0                    !--top width of the channel inflow
+           Ck = (sqrt(So)/n)*(5./3.)*(h_0**0.667)   !-- pg 287 Chow, Mdt, Mays
+           if(Ck .gt. 0.0) then
+             Km = dx/Ck                       !-- seconds Muskingum Param
+             if(Km .lt. dt) then           
+               Km = dt
+             endif
+           else 
+             Km = dt
+           endif
+ 
+           if(Tw*So*Ck*dx .eq. 0.0) then 
+             X = 0.25
+           else
+             X = 0.5-(Qj_0/(2*Tw*So*Ck*dx))
+           endif
+  
+           if(X .le. 0.0) then 
+             X = 0.25
+           elseif(X .gt. 0.35) then
+             X = 0.35
+           endif
+  
+           D = (Km*(1 - X) + dt/2)              !--seconds
+            if(D .eq. 0.0) then 
+              print *, "FATAL ERROR: D is 0 in MUSKINGCUNGE", Km, X, dt,D
+              call hydro_stop("In MUSKINGCUNGE() - D is 0.")
+           endif 
+  
+           C1 =  (Km*X + dt/2)/D
+           C2 =  (dt/2 - Km*X)/D
+           C3 =  (Km*(1-X)-dt/2)/D
+           C4 =  (ql*dt)/D                       !-- ql already multipled by the dx length
+
+           if(h_0 .le. 0.0) then 
+             AREA= 0.0
+             WP = 0.0
+           else
+            AREA = (Bw * h_0 + z * (h_0*h_0) )
+            WP   = (Bw * h_0 + z * (h_0*h_0)) / (Bw + 2 * h_0 * sqrt(1+z*z))
+           endif
+           
+           if(WP .le. 0.0) then 
+              Qj_0 =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4)
+           else 
+              Qj_0 =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4) - ((1/n) * AREA * (WP**(2./3.)) * sqrt(So)) !f(x)
+           endif
+           
+           !--upper interval -----------
+           Tw = Bw + 2*z*h                    !--top width of the channel inflow
+           Ck = (sqrt(So)/n)*(5./3.)*(h**0.667)   !-- pg 287 Chow, Mdt, Mays
+           if(Ck .gt. 0.0) then
+             Km = dx/Ck                       !-- seconds Muskingum Param
+             if(Km .lt. dt) then           
+               Km = dt
+             endif
+           else 
+             Km = dt
+           endif
+ 
+           if(Tw*So*Ck*dx .eq. 0.0) then 
+             X = 0.25
+           else
+             X = 0.5-(((C1*qup)+(C2*quc)+(C3*qdp) + C4)/(2*Tw*So*Ck*dx))
+           endif
+  
+           if(X .le. 0.0) then 
+             X = 0.25
+           elseif(X .gt. 0.35) then
+             X = 0.35
+           endif
+  
+           D = (Km*(1 - X) + dt/2)              !--seconds
+            if(D .eq. 0.0) then 
+              print *, "FATAL ERROR: D is 0 in MUSKINGCUNGE", Km, X, dt,D
+              call hydro_stop("In MUSKINGCUNGE() - D is 0.")
+           endif 
+  
+           C1 =  (Km*X + dt/2)/D
+           C2 =  (dt/2 - Km*X)/D
+           C3 =  (Km*(1-X)-dt/2)/D
+           C4 =  (ql*dt)/D                       !-- ql already multipled by the dx length
+
+           if(h .le. 0) then 
+            AREA = 0.0
+            WP   = 0.0
+           else
+            AREA = (Bw * h + z * (h*h) )
+            WP   = (Bw * h + z * (h*h)) / (Bw + 2 * h * sqrt(1+z*z))
+           endif 
+           
+           if(WP .le. 0.0) then 
+             Qj =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4)
+           else
+             Qj =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4) -((1/n) * AREA * (WP**(2./3.)) * sqrt(So))
+           endif
+
+           if(Qj_0-Qj .ne. 0.0) then
+             h_1 = h - ((Qj * (h_0 - h))/(Qj_0 - Qj)) !update h, 3rd estimate
+              if(h_1 .lt. 0.0) then
+                h_1 = h
+              endif
+           else
+             h_1 = h
+           endif
+
+           error = abs((h_1 - h)/h) !error is new estatimate and 2nd estimate
+
+!           if(idx .eq. 626) then 
+!             write(6,*) h_0,h,h_1,error
+!           endif
+
+           h_0  = h 
+           h    = h_1
+           maxiter = maxiter + 1
+
+      end do
+
+      if((maxiter .ge. 100 .and. error .gt. 0.05) .or. h .gt. 100) then 
+
+         print*, "WARNING:"
+         print*, "id,err,iters,h", idx, error, maxiter, h
+         print*, "n,z,B,So,dx,X,dt,Km",n,z,Bw,So,dx,X,dt,Km
+         print*, "qup,quc,qdp,ql", qup,quc,qdp,ql
+         if(h.gt.100) then
+              print*, "FATAL ERROR: Water Elevation Calculation is Diverging"
+              call hydro_stop("In MUSKINGCUNGE() - Water Elevation Calculation is Diverging")
+         endif
+      endif
+
+!yw added for test
+      if(((C1*qup)+(C2*quc)+(C3*qdp) + C4) .lt. 0.0) then
+!       MUSKINGCUNGE =  MAX( ( (C1*qup)+(C2*quc) + C4),((C1*qup)+(C3*qdp) + C4) )
+        qdc = MAX( ( (C1*qup)+(C2*quc) + C4),((C1*qup)+(C3*qdp) + C4) )
+
+      else
+!       MUSKINGCUNGE =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4) !-- pg 295 Bedient huber
+        qdc =  ((C1*qup)+(C2*quc)+(C3*qdp) + C4) !-- pg 295 Bedient huber
+
+      endif
+
+      Tw = Bw + (2*z*h)
+      R = (h*(Bw + Tw) / 2) / (Bw + 2*(((Tw - Bw) / 2)**2 + h**2)**0.5)    
+      vel =  (1./n) * (R **(2./3.)) * sqrt(So)  ! average velocity in m/s
+
+! ----------------------------------------------------------------
+!END FUNCTION MUSKINGCUNGE
+END SUBROUTINE SUBMUSKINGCUNGE
+! ----------------------------------------------------------------
+
+! ------------------------------------------------
+!   FUNCTION KINEMATIC
+! ------------------------------------------------
+	REAL FUNCTION KINEMATIC()
+
+	IMPLICIT NONE
+
+! -------- DECLARATIONS -----------------------
+ 
+!	REAL, INTENT(OUT), DIMENSION(IXRT,JXRT)	:: OVRGH
+
+        KINEMATIC = 1       
+!----------------------------------------------------------------
+  END FUNCTION KINEMATIC
+!----------------------------------------------------------------
+
+
+! ------------------------------------------------
+!   SUBROUTINE drive_CHANNEL
+! ------------------------------------------------
+! ------------------------------------------------
+     Subroutine drive_CHANNEL(latval,lonval,KT, IXRT,JXRT, SUBRTSWCRT, &
+       QSUBRT, LAKEINFLORT, QSTRMVOLRT, TO_NODE, FROM_NODE, &
+       TYPEL, ORDER, MAXORDER, NLINKS, CH_NETLNK, CH_NETRT, CH_LNKRT, &
+       LAKE_MSKRT, DT, DTCT, DTRT_CH,MUSK, MUSX, QLINK, &
+       HLINK, ELRT, CHANLEN, MannN, So, ChSSlp, Bw, &
+       RESHT, HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, &
+       ORIFICEE, ZELEV, CVOL, NLAKES, QLAKEI, QLAKEO, LAKENODE, &
+       dist, QINFLOWBASE, CHANXI, CHANYJ, channel_option, RETDEP_CHAN, &
+       NLINKSL, LINKID, node_area  &
+#ifdef MPP_LAND 
+       , lake_index,link_location,mpp_nlinks,nlinks_index,yw_mpp_nlinks  &
+       , LNLINKSL, LLINKID  &
+       , gtoNode,toNodeInd,nToNodeInd &
+#endif
+       , CH_LNKRT_SL &
+       ,gwBaseSwCRT, gwHead, qgw_chanrt, gwChanCondSw, gwChanCondConstIn, &
+       gwChanCondConstOut)
+
+
+       IMPLICIT NONE
+
+! -------- DECLARATIONS ------------------------
+
+        INTEGER, INTENT(IN) :: IXRT,JXRT,channel_option
+        INTEGER, INTENT(IN) :: NLINKS,NLAKES, NLINKSL
+        integer, INTENT(INOUT) :: KT   ! flag of cold start (1) or continue run.
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: QSUBRT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: QSTRMVOLRT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: LAKEINFLORT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: ELRT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: QINFLOWBASE
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETLNK
+
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_NETRT
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_LNKRT
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_LNKRT_SL
+
+       real , dimension(ixrt,jxrt):: latval,lonval
+
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT
+        INTEGER, INTENT(IN), DIMENSION(NLINKS)    :: ORDER, TYPEL !--link
+        INTEGER, INTENT(IN), DIMENSION(NLINKS)    :: TO_NODE, FROM_NODE
+        INTEGER, INTENT(IN), DIMENSION(NLINKS)    :: CHANXI, CHANYJ
+        REAL,    INTENT(IN), DIMENSION(NLINKS)    :: ZELEV  !--elevation of nodes
+        REAL, INTENT(INOUT), DIMENSION(NLINKS)    :: CVOL
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: MUSK, MUSX
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: CHANLEN
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: So, MannN
+        REAL, INTENT(IN), DIMENSION(NLINKS)       :: ChSSlp,Bw  !--properties of nodes or links
+        REAL                                      :: Km, X
+        REAL , INTENT(INOUT), DIMENSION(:,:) :: QLINK
+        REAL ,  DIMENSION(NLINKS,2) :: tmpQLINK
+        REAL , INTENT(INOUT), DIMENSION(NLINKS)   :: HLINK
+        REAL, INTENT(IN)                          :: DT    !-- model timestep
+        REAL, INTENT(IN)                          :: DTRT_CH  !-- routing timestep
+        REAL, INTENT(INOUT)                       :: DTCT
+        real                                      :: minDTCT !BF minimum routing timestep
+        REAL                                      :: dist(ixrt,jxrt,9)
+        REAL                                      :: RETDEP_CHAN
+        INTEGER, INTENT(IN)                       :: MAXORDER, SUBRTSWCRT, &
+                                                     gwBaseSwCRT, gwChanCondSw
+        real, intent(in)                          :: gwChanCondConstIn, gwChanCondConstOut ! aquifer-channel conductivity constant from namelist                                             
+        REAL , INTENT(IN), DIMENSION(NLINKS)   :: node_area
+
+!DJG GW-chan coupling variables...
+        REAL, DIMENSION(NLINKS)                   :: dzGwChanHead
+        REAL, DIMENSION(NLINKS)                   :: Q_GW_CHAN_FLUX     !DJG !!! Change 'INTENT' to 'OUT' when ready to update groundwater state...
+        REAL, DIMENSION(IXRT,JXRT)                :: ZWATTBLRT          !DJG !!! Match with subsfce/gw routing & Change 'INTENT' to 'INOUT' when ready to update groundwater state...
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: gwHead            !DJG !!! groundwater head from Fersch-2d gw implementation...units (m ASL)
+        REAL, INTENT(INOUT), DIMENSION(IXRT,JXRT) :: qgw_chanrt         !DJG !!! Channel-gw flux as used in Fersch 2d gw implementation...units (m^3/s)...Change 'INTENT' to 'OUT' when ready to update groundwater state...
+         
+
+
+        !-- lake params
+        REAL, INTENT(IN), DIMENSION(NLAKES)       :: HRZAREA  !-- horizontal area (km^2)
+        REAL, INTENT(IN), DIMENSION(NLAKES)       :: LAKEMAXH !-- maximum lake depth  (m^2)
+        REAL, INTENT(IN), DIMENSION(NLAKES)       :: WEIRH    !-- lake depth  (m^2)
+        REAL, INTENT(IN), DIMENSION(NLAKES)       :: WEIRC    !-- weir coefficient
+        REAL, INTENT(IN), DIMENSION(NLAKES)       :: WEIRL    !-- weir length (m)
+        REAL, INTENT(IN), DIMENSION(NLAKES)       :: ORIFICEC !-- orrifice coefficient
+        REAL, INTENT(IN), DIMENSION(NLAKES)       :: ORIFICEA !-- orrifice area (m^2)
+        REAL, INTENT(IN), DIMENSION(NLAKES)       :: ORIFICEE !-- orrifce elevation (m)
+
+        REAL, INTENT(INOUT), DIMENSION(NLAKES)    :: RESHT    !-- reservoir height (m)
+        REAL, INTENT(INOUT), DIMENSION(NLAKES)    :: QLAKEI   !-- lake inflow (cms)
+        REAL,                DIMENSION(NLAKES)    :: QLAKEIP  !-- lake inflow previous timestep (cms)
+        REAL, INTENT(INOUT), DIMENSION(NLAKES)    :: QLAKEO   !-- outflow from lake used in diffusion scheme
+        INTEGER, INTENT(IN), DIMENSION(NLINKS)    :: LAKENODE !-- outflow from lake used in diffusion scheme
+        INTEGER, INTENT(IN), DIMENSION(NLINKS)    :: LINKID   !--  id of channel elements for linked scheme
+        REAL, DIMENSION(NLINKS)                   :: QLateral !--lateral flow
+        REAL, DIMENSION(NLINKS)                   :: QSUM     !--mass bal of node
+        REAL, DIMENSION(NLAKES)                   :: QLLAKE   !-- lateral inflow to lake in diffusion scheme
+
+!-- Local Variables
+        INTEGER                     :: i,j,k,t,m,jj,kk,KRT,node
+        INTEGER                     :: DT_STEPS               !-- number of timestep in routing
+        REAL                        :: Qup,Quc                !--Q upstream Previous, Q Upstream Current, downstream Previous
+        REAL                        :: bo                     !--critical depth, bnd outflow just for testing
+        REAL                        :: AREA,WP                !--wetted area and perimiter for MuskingC. routing
+
+        REAL ,DIMENSION(NLINKS)     :: HLINKTMP,CVOLTMP       !-- temporarily store head values and volume values
+        REAL ,DIMENSION(NLINKS)     :: CD                     !-- critical depth
+        real, DIMENSION(IXRT,JXRT)  :: tmp
+        real, dimension(nlinks)     :: tmp2
+
+#ifdef MPP_LAND
+        integer lake_index(nlakes)
+        integer nlinks_index(nlinks)
+        integer mpp_nlinks, iyw, yw_mpp_nlinks
+        integer link_location(ixrt,jxrt)
+        real     ywtmp(ixrt,jxrt)
+        integer LNLINKSL
+        INTEGER, dimension(LNLINKSL) :: LLINKID
+        real*8,  dimension(LNLINKSL) :: LQLateral
+!        real*4,  dimension(LNLINKSL) :: LQLateral
+        integer, dimension(:) ::  toNodeInd
+        integer, dimension(:,:) ::  gtoNode
+        integer  :: nToNodeInd
+        real, dimension(nToNodeInd,2) :: gQLINK
+#else
+        REAL*8, DIMENSION(NLINKS)                   :: LQLateral !--lateral flow
+#endif
+        integer flag
+
+        integer :: n, kk2, nt, nsteps  ! tmp 
+
+        QLAKEIP = 0
+        HLINKTMP = 0
+        CVOLTMP = 0
+        CD = 0  
+        node = 1
+        QLateral = 0
+        QSUM     = 0
+        QLLAKE   = 0
+
+
+!yw      print *, "DRIVE_channel,option,nlinkl,nlinks!!", channel_option,NLINKSL,NLINKS
+         
+      dzGwChanHead = 0.
+
+   IF(channel_option .ne. 3) then   !--muskingum methods ROUTE ON DT timestep, not DTRT!!
+
+         nsteps = (DT+0.5)/DTRT_CH
+
+#ifdef MPP_LAND
+         LQLateral = 0          !-- initial lateral flow to 0 for this reach
+         DO iyw = 1,yw_MPP_NLINKS
+         jj = nlinks_index(iyw)
+          !--------river grid points, convert depth in mm to rate across reach in m^3/sec
+              if( .not. (  (CHANXI(jj) .eq. 1 .and. left_id .ge. 0) .or. &
+                           (CHANXI(jj) .eq. ixrt .and. right_id .ge. 0) .or. &
+                           (CHANYJ(jj) .eq. 1 .and. down_id .ge. 0) .or. &
+                           (CHANYJ(jj) .eq. jxrt .and. up_id .ge. 0)      &
+                   ) ) then
+                  if (CH_LNKRT_SL(CHANXI(jj),CHANYJ(jj)) .gt. 0) then
+                     k = CH_LNKRT_SL(CHANXI(jj),CHANYJ(jj))
+                     LQLateral(k) = LQLateral(k)+((QSTRMVOLRT(CHANXI(jj),CHANYJ(jj))+QINFLOWBASE(CHANXI(jj),CHANYJ(jj)))/1000 & 
+                            *node_area(jj)/DT)
+                  elseif ( (LAKE_MSKRT(CHANXI(jj),CHANYJ(jj)) .gt. 0)) then !-lake grid
+                      k = LAKE_MSKRT(CHANXI(jj),CHANYJ(jj))
+                      LQLateral(k) = LQLateral(k) +((LAKEINFLORT(CHANXI(jj),CHANYJ(jj))+QINFLOWBASE(CHANXI(jj),CHANYJ(jj)))/1000 &
+                               *node_area(jj)/DT)
+                  endif
+              endif
+         end do  ! jj
+
+
+!   assign LQLATERAL to QLATERAL
+       call updateLinkV(LQLateral, QLateral(1:NLINKSL))
+
+#else
+         LQLateral = 0          !-- initial lateral flow to 0 for this reach
+         do jj = 1, NLINKS
+          !--------river grid points, convert depth in mm to rate across reach in m^3/sec
+
+                  if (CH_LNKRT_SL(CHANXI(jj),CHANYJ(jj)) .gt. 0 ) then
+                     k = CH_LNKRT_SL(CHANXI(jj),CHANYJ(jj))
+                     LQLateral(k) = LQLateral(k)+((QSTRMVOLRT(CHANXI(jj),CHANYJ(jj))+QINFLOWBASE(CHANXI(jj),CHANYJ(jj)))/1000 & 
+                            *node_area(jj)/DT)
+                  elseif ( (LAKE_MSKRT(CHANXI(jj),CHANYJ(jj)) .gt. 0)) then !-lake grid
+                      k = LAKE_MSKRT(CHANXI(jj),CHANYJ(jj))
+                      LQLateral(k) = LQLateral(k) +((LAKEINFLORT(CHANXI(jj),CHANYJ(jj))+QINFLOWBASE(CHANXI(jj),CHANYJ(jj)))/1000 &
+                               *node_area(jj)/DT)
+                  endif   
+
+          end do  ! jj
+          QLateral = LQLateral
+#endif
+
+!       QLateral = QLateral / nsteps
+
+   do nt = 1, nsteps
+
+ 
+!----------  route order 1 reaches which have no upstream inflow
+        do k=1, NLINKSL
+           if (ORDER(k) .eq. 1) then  !-- first order stream has no headflow
+
+
+              if(TYPEL(k) .eq. 1) then    !-- level pool route of reservoir
+                  !CALL LEVELPOOL(1,0.0, 0.0, qd, QLINK(k,2), QLateral(k), &
+                  ! DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), &
+                  ! WEIRC(k), WEIRL(k), ORIFICEE(i), ORIFICEC(k), ORIFICEA(k) )
+              elseif (channel_option .eq. 1) then
+                   Km  = MUSK(k)
+                   X   = MUSX(k)
+                   QLINK(k,2) = MUSKING(k,0.0, QLateral(k), QLINK(k,1), DTRT_CH, Km, X) !--current outflow
+              elseif (channel_option .eq. 2) then !-- upstream is assumed constant initial condition
+
+                 ! HLINK(k) = MUSKINGCUNGE(k,0.0,0.0,QLINK(k,1), &
+                   QLINK(k,2) = MUSKINGCUNGE(k,0.0,0.0,QLINK(k,1), &
+                         QLateral(k), DTRT_CH, So(k), CHANLEN(k), &
+                         MannN(k), ChSSlp(k), Bw(k))
+
+                 ! AREA = (Bw(k) * HLINK(k) + 1/ChSSlp(k) * HLINK(k)**2)
+                 ! WP   = (Bw(k) * HLINK(k) + 1/ChSSlp(k) * HLINK(k)**2) / (Bw(k) + 2 * HLINK(k) * sqrt(1+(1/ChSSlp(k))**2))
+                 ! QLINK(k,2) = 1/MannN(k) * AREA * WP**(2./3.) * sqrt(So(k))
+
+              else
+                  print *, "FATAL ERROR: No channel option selected"
+                  call hydro_stop("In drive_CHANNEL() -No channel option selected ") 
+              endif
+           endif
+        end do
+
+#ifdef MPP_LAND
+       gQLINK = 0
+       call gbcastReal2(toNodeInd,nToNodeInd,QLINK(1:NLINKSL,2), NLINKSL, gQLINK(:,2))
+       call gbcastReal2(toNodeInd,nToNodeInd,QLINK(1:NLINKSL,1), NLINKSL, gQLINK(:,1))
+#endif
+
+      !---------- route other reaches, with upstream inflow
+       tmpQlink = 0
+       do k = 1,NLINKSL
+          if (ORDER(k) .gt. 1 ) then  !-- exclude first order stream 
+             Quc  = 0
+             Qup  = 0
+
+#ifdef MPP_LAND
+!using mapping index
+               do n = 1, gtoNODE(k,1)
+                  m = gtoNODE(k,n+1)
+!yw                  if (LINKID(k) .eq. m) then
+                    Quc = Quc + gQLINK(m,2)  !--accum of upstream inflow of current timestep (2)
+                    Qup = Qup + gQLINK(m,1)  !--accum of upstream inflow of previous timestep (1)
+
+                      !     if(LINKID(k) .eq. 3259 .or. LINKID(k) .eq. 3316 .or. LINKID(k) .eq. 3219) then
+                      !       write(6,*) "id,Uc,Up",LINKID(k),Quc,Qup
+                      !       call flush(6)
+                      !     endif
+
+!yw                  endif
+                end do ! do i
+
+#else
+               do m = 1, NLINKSL
+                  if (LINKID(k) .eq. TO_NODE(m)) then
+                    Quc = Quc + QLINK(m,2)  !--accum of upstream inflow of current timestep (2)
+                    Qup = Qup + QLINK(m,1)  !--accum of upstream inflow of previous timestep (1)
+                  endif
+               end do ! do m
+#endif
+                   
+                if(TYPEL(k) .eq. 1) then   !--link is a reservoir
+
+                   ! CALL LEVELPOOL(1,QLINK(k,1), Qup, QLINK(k,1), QLINK(k,2), &
+                   !  QLateral(k), DT, RESHT(k), HRZAREA(k), LAKEMAXH(k), &
+                   !  WEIRC(k), WEIRL(k),ORIFICEE(k),  ORIFICEC(k), ORIFICEA(k))
+
+                   elseif (channel_option .eq. 1) then  !muskingum routing
+                       Km = MUSK(k)
+                       X = MUSX(k)
+                       tmpQLINK(k,2) = MUSKING(k,Qup,(Quc+QLateral(k)),QLINK(k,1),DTRT_CH,Km,X) !upstream plust lateral inflow 
+                   elseif (channel_option .eq. 2) then ! muskingum cunge
+
+                    !HLINK(k) =   MUSKINGCUNGE(k,Qup, Quc, QLINK(k,1), &
+                    tmpQLINK(k,2) = MUSKINGCUNGE(k,Qup, Quc, QLINK(k,1), &
+                                    QLateral(k), DTRT_CH, So(k),  CHANLEN(k), &
+                                    MannN(k), ChSSlp(k), Bw(k) )
+
+                    ! AREA = (Bw(k) * HLINK(k) + 1/ChSSLP(k) * HLINK(k)**2)
+                    ! WP   = (Bw(k) * HLINK(k) + 1/ChSSLP(k) * HLINK(k)**2) / (Bw(k) + 2 * HLINK(k) * sqrt(1+(1/ChSSLP(k))**2))
+                    ! tmpQLINK(k,2) = ((1/MannN(k)) * AREA * WP**(2./3.) * sqrt(So(k)))
+
+                   else
+                    print *, "FATAL ERROR: no channel option selected"
+                    call hydro_stop("In drive_CHANNEL() - no channel option selected") 
+                   endif
+            endif !!! order(1) .ne. 1
+         end do       !--k links
+
+!yw check
+!        gQLINK = 0.0
+!        call ReachLS_write_io(tmpQLINK(:,2), gQLINK(:,2))
+!        call ReachLS_write_io(tmpQLINK(:,1), gQLINK(:,1))
+!        write(6,*) " io_id = ", io_id
+!        if(my_id .eq. io_id) then
+!            write(71,*) gQLINK(:,1)
+!            call flush(71)
+!            call flush(72)
+!        endif
+
+          do k = 1, NLINKSL
+            if(TYPEL(k) .ne. 1) then
+               QLINK(k,2) = tmpQLINK(k,2)
+            endif
+            QLINK(k,1) = QLINK(k,2)    !assing link flow of current to be previous for next time step
+         end do
+
+!#ifdef MPP_LAND 
+!         call ReachLS_write_io(QLINK(:,2),buf1)
+!         if(my_id .eq. IO_id) write(73,*) buf1
+!#else
+!         write(73,*) QLINK(1:NLINKSL,2)
+!#endif
+
+#ifdef HYDRO_D
+          print *, "END OF ALL REACHES...",KRT,DT_STEPS
+#endif
+
+   end do  ! nsteps
+
+!    END DO !-- krt timestep for muksingumcunge routing
+
+   elseif(channel_option .eq. 3) then   !--- route using the diffusion scheme on nodes not links
+
+#ifdef MPP_LAND
+         call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINK,NLINKS,99)
+         call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOL,NLINKS,99)
+#endif
+
+         KRT = 0                  !-- initialize the time counter
+         minDTCT = 0.01           ! define minimum routing sub-timestep (s), simulation will end with smaller timestep
+         DTCT = min(max(DTCT*2.0, minDTCT),DTRT_CH)
+       
+         HLINKTMP = HLINK         !-- temporary storage of the water elevations (m)
+         CVOLTMP = CVOL           !-- temporary storage of the volume of water in channel (m^3)
+         QLAKEIP = QLAKEI         !-- temporary lake inflow from previous timestep  (cms)
+
+!        call check_channel(77,HLINKTMP,1,nlinks)
+!        call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,ZELEV,NLINKS,99)
+ crnt:    DO                      !-- loop on the courant condition
+         QSUM   = 0              !-- initialize the total flow out of each cell to zero
+         QLAKEI = 0              !-- set the lake inflow as zero
+         QLLAKE = 0              !-- initialize each lake's lateral inflow to zero  
+         DT_STEPS=INT(DT/DTCT)   !-- fix the timestep
+         QLateral = 0. 
+!DJG GW-chan coupling variables...
+         if(gwBaseSwCRT == 3) then
+	  Q_GW_CHAN_FLUX = 0.
+	  qgw_chanrt     = 0.
+         end if
+         
+!         ZWATTBLRT=1.0   !--HARDWIRE, remove this and pass in from subsfc/gw routing routines...
+
+
+!-- vectorize
+!--------------------- 
+#ifdef MPP_LAND
+         DO iyw = 1,yw_MPP_NLINKS
+         i = nlinks_index(iyw)
+#else
+         DO i = 1,NLINKS
+#endif
+          
+           if(node_area(i) .eq. 0) then
+               write(6,*) "FATAL ERROR: node_area(i) is zero. i=", i
+               call hydro_stop("In drive_CHANNEL() - Error node_area") 
+           endif
+
+           
+
+nodeType:if((CH_NETRT(CHANXI(i), CHANYJ(i) ) .eq. 0) .and. &
+              (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .lt.0) ) then !--a reg. node
+              
+gwOption:   if(gwBaseSwCRT == 3) then
+
+             ! determine potential gradient between groundwater head and channel stage
+             ! units in (m)
+             dzGwChanHead(i) = gwHead(CHANXI(i),CHANYJ(i)) - (HLINK(i)+ZELEV(i)) 
+
+             if(gwChanCondSw .eq. 0) then
+	       
+                qgw_chanrt(CHANXI(i),CHANYJ(i)) = 0.
+	        
+             else if(gwChanCondSw .eq. 1 .and. dzGwChanHead(i) > 0) then
+	       
+	       ! channel bed interface, units in (m^3/s), flux into channel...
+	       ! BF todo: consider channel width
+                qgw_chanrt(CHANXI(i),CHANYJ(i)) = gwChanCondConstIn * dzGwChanHead(i) &
+                                                * CHANLEN(i) * 2. 
+
+             else if(gwChanCondSw .eq. 1 .and. dzGwChanHead(i) < 0) then
+	       
+	       ! channel bed interface, units in (m^3/s), flux out of channel...
+	       ! BF todo: consider channel width
+                qgw_chanrt(CHANXI(i),CHANYJ(i)) = max(-0.005, gwChanCondConstOut * dzGwChanHead(i) &
+                                                * CHANLEN(i) * 2.)
+!              else if(gwChanCondSw .eq. 2 .and. dzGwChanHead(i) > 0) then  TBD: exponential dependency
+!              else if(gwChanCondSw .eq. 2 .and. dzGwChanHead(i) > 0) then
+	       
+             else
+	       
+	        qgw_chanrt(CHANXI(i),CHANYJ(i)) = 0.
+	        
+             end if
+             
+             Q_GW_CHAN_FLUX(i) = qgw_chanrt(CHANXI(i),CHANYJ(i))
+!             if ( i .eq. 1001 ) then
+!                print *, Q_GW_CHAN_FLUX(i), dzGwChanHead(i), ELRT(CHANXI(i),CHANYJ(i)), HLINK(i), ZELEV(i)
+!             end if
+!              if ( Q_GW_CHAN_FLUX(i) .lt. 0. ) then   !-- temporary hardwire for only allowing flux into channel...REMOVE later...
+!                 Q_GW_CHAN_FLUX(i) = 0.
+! 	        qgw_chanrt(CHANXI(i),CHANYJ(i)) = 0.
+!              end if
+            
+            else
+	      Q_GW_CHAN_FLUX(i) = 0.
+	    end if gwOption
+
+
+              QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) =  &
+!DJG  awaiting gw-channel exchg...  Q_GW_CHAN_FLUX(i)+& ...obsolete-> ((QSUBRT(CHANXI(i),CHANYJ(i))+&
+                Q_GW_CHAN_FLUX(i)+&
+                ((QSTRMVOLRT(CHANXI(i),CHANYJ(i))+&
+                 QINFLOWBASE(CHANXI(i),CHANYJ(i))) &
+                   /DT_STEPS*node_area(i)/1000/DTCT)
+	if((QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))).lt.0.) .and. (gwChanCondSw == 0)) then
+#ifdef HYDRO_D
+               print*, "i, CHANXI(i),CHANYJ(i) = ", i, CHANXI(i),CHANYJ(i)
+               print *, "NEGATIVE Lat inflow...",QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))), &
+                         QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)), &
+                         QINFLOWBASE(CHANXI(i),CHANYJ(i))
+#endif
+        end if
+            elseif(LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .gt. 0 .and. &
+               (LAKE_MSKRT(CHANXI(i),CHANYJ(i)) .ne. -9999)) then !--a lake node
+              QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) = &
+                 QLLAKE(LAKE_MSKRT(CHANXI(i),CHANYJ(i))) + &
+                 (LAKEINFLORT(CHANXI(i),CHANYJ(i))+ &
+                 QINFLOWBASE(CHANXI(i),CHANYJ(i)) &
+                 /DT_STEPS*node_area(i)/1000/DTCT)
+            elseif(CH_NETRT(CHANXI(i),CHANYJ(i)) .gt. 0) then  !pour out of lake
+                 QLateral(CH_NETLNK(CHANXI(i),CHANYJ(i))) =  &
+                   QLAKEO(CH_NETRT(CHANXI(i),CHANYJ(i)))  !-- previous timestep
+          endif nodeType
+        ENDDO
+
+
+#ifdef MPP_LAND
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLateral,NLINKS,99)
+    if(NLAKES .gt. 0) then
+       call MPP_CHANNEL_COM_REAL(LAKE_MSKRT   ,ixrt,jxrt,QLLAKE,NLAKES,99)
+    endif
+#endif
+
+          !-- compute conveyances, with known depths (just assign to QLINK(,1)
+          !--QLINK(,2) will not be used), QLINK is the flow across the node face
+          !-- units should be m3/second.. consistent with QL (lateral flow)
+
+#ifdef MPP_LAND
+         DO iyw = 1,yw_MPP_NLINKS
+         i = nlinks_index(iyw)
+#else
+           DO i = 1,NLINKS
+#endif
+           if (TYPEL(i) .eq. 0 .AND. HLINKTMP(FROM_NODE(i)) .gt. RETDEP_CHAN) then 
+               if(from_node(i) .ne. to_node(i) .and. (to_node(i) .gt. 0) .and.(from_node(i) .gt. 0) ) &  ! added by Wei Yu
+                   QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), &
+                     HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), &
+                     CHANLEN(i), MannN(i), Bw(i), ChSSlp(i))
+            else !--  we are just computing critical depth for outflow points
+               QLINK(i,1) =0.
+            endif
+          ENDDO
+
+#ifdef MPP_LAND
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99)
+#endif
+ 
+
+          !-- compute total flow across face, into node
+#ifdef MPP_LAND
+         DO iyw = 1,yw_mpp_nlinks
+         i = nlinks_index(iyw)
+#else
+          DO i = 1,NLINKS                                                 !-- inflow to node across each face
+#endif
+           if(TYPEL(i) .eq. 0) then                                       !-- only regular nodes have to attribute
+              QSUM(TO_NODE(i)) = QSUM(TO_NODE(i)) + QLINK(i,1)
+           endif
+          END DO
+
+#ifdef MPP_LAND
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,0)
+#endif
+
+
+
+#ifdef MPP_LAND
+         DO iyw = 1,yw_mpp_nlinks
+         i = nlinks_index(iyw)
+#else
+          DO i = 1,NLINKS                                                 !-- outflow from node across each face
+#endif
+            QSUM(FROM_NODE(i)) = QSUM(FROM_NODE(i)) - QLINK(i,1)
+          END DO
+#ifdef MPP_LAND
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,qsum,NLINKS,99)
+#endif
+
+
+         flag = 99
+
+
+#ifdef MPP_LAND
+         DO iyw = 1,yw_MPP_NLINKS
+             i = nlinks_index(iyw)
+#else
+          DO i = 1, NLINKS                                                !--- compute volume and depth at each node
+#endif
+ 
+           if( TYPEL(i).eq.0 .and. CVOLTMP(i) .ge. 0.001 .and.(CVOLTMP(i)-QSUM(i)*DTCT)/CVOLTMP(i) .le. -0.01 ) then  
+            flag = -99
+#ifdef HYDRO_D
+            write(6,*) "******* start diag ***************"
+            write(6,*) "Unstable at node ",i, "i=",CHANXI(i),"j=",CHANYJ(i)
+            write(6,*) "Unstatble at node ",i, "lat=",latval(CHANXI(i),CHANYJ(i)), "lon=",lonval(CHANXI(i),CHANYJ(i))
+            write(6,*) "TYPEL, CVOLTMP, QSUM, QSUM*DTCT",TYPEL(i), CVOLTMP(i), QSUM(i), QSUM(i)*DTCT
+            write(6,*) "qsubrt, qstrmvolrt,qlink",QSUBRT(CHANXI(i),CHANYJ(i)),QSTRMVOLRT(CHANXI(i),CHANYJ(i)),qlink(i,1),qlink(i,2)
+!              write(6,*) "current nodes, z, h", ZELEV(FROM_NODE(i)),HLINKTMP(FROM_NODE(i))
+!           if(TO_NODE(i) .gt. 0) then
+!              write(6,*) "to nodes, z, h", ZELEV(TO_NODE(i)), HLINKTMP(TO_NODE(i))
+!           else
+!              write(6,*) "no to nodes   "
+!           endif
+               write(6,*) "CHANLEN(i), MannN(i), Bw(i), ChSSlp(i) ", CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)
+            write(6,*) "*******end of  diag ***************"
+#endif
+            
+            goto 999  
+            endif 
+          enddo 
+
+999 continue
+#ifdef MPP_LAND
+        call mpp_same_int1(flag)
+#endif
+
+
+        if(flag < 0  .and. DTCT >0.1)   then   
+             
+             ! call smoth121(HLINK,nlinks,maxv_p,pnode,to_node)
+
+             if(DTCT .gt. minDTCT) then                !-- timestep in seconds
+              DTCT = max(DTCT/2 , minDTCT)             !-- 1/2 timestep
+              KRT = 0                                  !-- restart counter
+              HLINKTMP = HLINK                         !-- set head and vol to start value of timestep
+              CVOLTMP = CVOL
+              CYCLE crnt                               !-- start cycle over with smaller timestep
+             else
+              write(6,*) "Courant error with smallest routing timestep DTCT: ",DTCT
+!              call hydro_stop("drive_CHANNEL")
+              DTCT = 0.1
+              HLINKTMP = HLINK                          !-- set head and volume to start values of timestep
+              CVOLTMP  = CVOL
+              goto 998  
+             end if
+        endif 
+
+998 continue
+
+
+#ifdef MPP_LAND
+         DO iyw = 1,yw_MPP_NLINKS
+            i = nlinks_index(iyw)
+#else
+         DO i = 1, NLINKS                                                !--- compute volume and depth at each node
+#endif
+ 
+            if(TYPEL(i) .eq. 0) then                   !--  regular channel grid point, compute volume
+              CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) )* DTCT
+              if((CVOLTMP(i) .lt. 0) .and. (gwChanCondSw == 0)) then 
+#ifdef HYDRO_D
+                print *, "WARNING! channel volume less than 0:i,CVOL,QSUM,QLat", &
+                               i, CVOLTMP(i),QSUM(i),QLateral(i),HLINK(i)
+#endif
+                CVOLTMP(i) =0 
+              endif
+
+            elseif(TYPEL(i) .eq. 1) then               !-- pour point, critical depth downstream 
+
+              if (QSUM(i)+QLateral(i) .lt. 0) then
+              else
+
+!DJG remove to have const. flux b.c....   CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i))
+                  CD(i) = HLINKTMP(i)  !This is a temp hardwire for flow depth for the pour point...
+               endif
+
+               ! change in volume is inflow, lateral flow, and outflow 
+               !yw DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*DXRT),HLINKTMP(i), &
+                   CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - &
+                       DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), &
+                       CD(i),CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT
+            elseif (TYPEL(i) .eq. 2) then              !--- into a reservoir, assume critical depth
+              if ((QSUM(i)+QLateral(i) .lt. 0) .and. (gwChanCondSw == 0)) then
+#ifdef HYDRO_D
+               print *, i, 'CrtDpth Qsum+QLat into lake< 0',QSUM(i), QLateral(i)
+#endif
+              else
+!DJG remove to have const. flux b.c....    CD(i) =CRITICALDEPTH(i,abs(QSUM(i)+QLateral(i)), Bw(i), 1./ChSSlp(i))
+               CD(i) = HLINKTMP(i)  !This is a temp hardwire for flow depth for the pour point...
+              endif
+ 
+              !-- compute volume in reach (m^3)
+                   CVOLTMP(i) = CVOLTMP(i) + (QSUM(i) + QLateral(i) - &
+                          DIFFUSION(i,ZELEV(i),ZELEV(i)-(So(i)*CHANLEN(i)),HLINKTMP(i), &
+                             CD(i) ,CHANLEN(i), MannN(i), Bw(i), ChSSlp(i)) ) * DTCT
+              !-- compute flow rate into lake from all contributing nodes (cms)
+              QLAKEI(LAKENODE(i)) = QLAKEI(LAKENODE(i)) + QLINK(FROM_NODE(i),1)
+
+            else
+              print *, "FATAL ERROR: This node does not have a type.. error TYPEL =", TYPEL(i)
+              call hydro_stop("In drive_CHANNEL() - error TYPEL") 
+            endif
+           
+           if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow
+            HLINKTMP(i) = HEAD(i, CVOLTMP(i)/CHANLEN(i),Bw(i),1/ChSSlp(i))  !--updated depth 
+           else
+            HLINKTMP(i) = CD(i)  !!!   CRITICALDEPTH(i,QSUM(i)+QLateral(i), Bw(i), 1./ChSSlp(i)) !--critical depth is head
+           endif 
+
+           END DO  !--- done processing all the links
+
+
+#ifdef MPP_LAND
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CVOLTMP,NLINKS,99)
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,CD,NLINKS,99)
+    if(NLAKES .gt. 0) then
+       call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99)
+    endif
+    call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,HLINKTMP,NLINKS,99)
+#endif 
+!   call check_channel(83,CVOLTMP,1,nlinks)
+!   call check_channel(84,CD,1,nlinks)
+!   call check_channel(85,HLINKTMP,1,nlinks)
+!   call check_lake(86,QLAKEI,lake_index,nlakes)
+
+      
+
+
+
+           do i = 1, NLAKES !-- mass balances of lakes
+#ifdef MPP_LAND
+            if(lake_index(i) .gt. 0)  then
+#endif
+              CALL LEVELPOOL(i,QLAKEIP(i), QLAKEI(i), QLAKEO(i), QLLAKE(i), &
+                DTCT, RESHT(i), HRZAREA(i), WEIRH(i), LAKEMAXH(i), WEIRC(i), &
+                WEIRL(i), ORIFICEE(i), ORIFICEC(i), ORIFICEA(i))
+                QLAKEIP(i) = QLAKEI(i)  !-- store total lake inflow for this timestep
+#ifdef MPP_LAND
+            endif
+#endif
+           enddo
+#ifdef MPP_LAND
+    if(NLAKES .gt. 0) then
+       call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLLAKE,NLAKES,99)
+       call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,RESHT,NLAKES,99)
+       call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEO,NLAKES,99)
+       call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEI,NLAKES,99)
+       call MPP_CHANNEL_COM_REAL(LAKE_MSKRT,ixrt,jxrt,QLAKEIP,NLAKES,99)
+    endif
+#endif
+
+
+#ifdef MPP_LAND
+         DO iyw = 1,yw_MPP_NLINKS
+            i = nlinks_index(iyw)
+#else
+         DO i = 1, NLINKS                                                !--- compute volume and depth at each node
+#endif
+            if(TYPEL(i) == 0) then !-- regular channel node, finalize head and flow
+                   QLINK(i,1)=DIFFUSION(i,ZELEV(FROM_NODE(i)),ZELEV(TO_NODE(i)), &
+                      HLINKTMP(FROM_NODE(i)),HLINKTMP(TO_NODE(i)), &
+                      CHANLEN(i), MannN(i), Bw(i), ChSSlp(i))
+            endif
+         enddo
+
+#ifdef MPP_LAND
+          call MPP_CHANNEL_COM_REAL(Link_location,ixrt,jxrt,QLINK(:,1),NLINKS,99)
+#endif
+
+           KRT = KRT + 1                     !-- iterate on the timestep
+           IF(KRT .eq. DT_STEPS) EXIT crnt   !-- up to the maximum time in interval
+
+          END DO crnt  !--- DTCT timestep of DT_STEPS
+ 
+           HLINK = HLINKTMP                 !-- update head based on final solution in timestep
+           CVOL  = CVOLTMP                  !-- update volume
+        else                                !-- no channel option apparently selected
+         print *, "FATAL ERROR: no channel option selected"
+         call hydro_stop("In drive_CHANNEL() - no channel option selected") 
+        endif
+
+#ifdef HYDRO_D
+         write(6,*) "finished call drive_CHANNEL"
+#endif
+
+        if (KT .eq. 1) KT = KT + 1
+         
+
+ END SUBROUTINE drive_CHANNEL
+! ----------------------------------------------------------------
+
+!-=======================================
+     REAL FUNCTION AREAf(AREA,Bw,h,z)
+     REAL :: AREA, Bw, z, h
+       AREAf = (Bw+z*h)*h-AREA       !-- Flow area
+     END FUNCTION AREAf
+
+!-====critical depth function  ==========
+     REAL FUNCTION CDf(Q,Bw,h,z)
+     REAL :: Q, Bw, z, h
+       if(h .le. 0) then
+         print *, "FATAL ERROR: head is zero, will get division by zero error"
+         call hydro_stop("In CDf() - head is zero") 
+       else
+       CDf = (Q/((Bw+z*h)*h))/(sqrt(9.81*(((Bw+z*h)*h)/(Bw+2*z*h))))-1  !--critical depth function
+       endif
+     END FUNCTION CDf
+
+!=======find flow depth in channel with bisection Chapra pg. 131
+    REAL FUNCTION HEAD(idx,AREA,Bw,z)  !-- find the water elevation given wetted area, 
+                                         !--bottom widith and side channel.. index was for debuggin
+     REAL :: Bw,z,AREA,test           
+     REAL :: hl, hu, hr, hrold
+     REAL :: fl, fr,error                !-- function evaluation
+     INTEGER :: maxiter, idx
+
+     error = 1.0
+     maxiter = 0
+     hl = 0.00001   !-- minimum depth is small
+     hu = 30.  !-- assume maximum depth is 30 meters
+
+    if (AREA .lt. 0.00001) then 
+     hr = 0.
+    else
+      do while ((AREAf(AREA,BW,hl,z)*AREAf(AREA,BW,hu,z)).gt.0 .and. maxiter .lt. 100) 
+       !-- allows for larger , smaller heads 
+       if(AREA .lt. 1.) then
+        hl=hl/2
+       else
+        hu = hu * 2
+       endif
+       maxiter = maxiter + 1
+        
+      end do
+
+      maxiter =0
+      hr = 0
+      fl = AREAf(AREA,Bw,hl,z)
+      do while (error .gt. 0.0001 .and. maxiter < 1000)
+        hrold = hr
+        hr = (hl+hu)/2
+        fr =  AREAf(AREA,Bw,hr,z)
+        maxiter = maxiter + 1
+         if (hr .ne. 0) then
+          error = abs((hr - hrold)/hr)
+         endif
+        test = fl * fr
+         if (test.lt.0) then
+           hu = hr
+         elseif (test.gt.0) then
+           hl=hr
+           fl = fr
+         else
+           error = 0.0
+         endif
+      end do
+     endif
+     HEAD = hr
+
+22   format("i,hl,hu,Area",i5,2x,f12.8,2x,f6.3,2x,f6.3,2x,f6.3,2x,f9.1,2x,i5)
+
+    END FUNCTION HEAD
+!=================================
+     REAL FUNCTION MANNING(h1,n,Bw,Cs)
+
+     REAL :: Bw,h1,Cs,n
+     REAL :: z, AREA,R,Kd
+
+     z=1/Cs
+     R = ((Bw+z*h1)*h1)/(Bw+2*h1*sqrt(1+z*z)) !-- Hyd Radius
+     AREA = (Bw+z*h1)*h1        !-- Flow area
+     Kd = (1/n)*(R**(2./3.))*AREA     !-- convenyance
+#ifdef HYDRO_D
+     print *,"head, kd",  h1,Kd
+#endif
+     MANNING = Kd
+     
+     END FUNCTION MANNING
+
+!=======find flow depth in channel with bisection Chapra pg. 131
+     REAL FUNCTION CRITICALDEPTH(lnk,Q,Bw,z)  !-- find the critical depth
+     REAL :: Bw,z,Q,test
+     REAL :: hl, hu, hr, hrold
+     REAL :: fl, fr,error   !-- function evaluation
+     INTEGER :: maxiter
+     INTEGER :: lnk
+
+     error = 1.0
+     maxiter = 0
+     hl = 1e-5   !-- minimum depth is 0.00001 meters
+!    hu = 35.       !-- assume maximum  critical depth 25 m
+     hu = 100.       !-- assume maximum  critical depth 25 m
+
+     if(CDf(Q,BW,hl,z)*CDf(Q,BW,hu,z) .gt. 0) then
+      if(Q .gt. 0.001) then
+#ifdef HYDRO_D
+        print *, "interval won't work to find CD of lnk ", lnk
+        print *, "Q, hl, hu", Q, hl, hu
+        print *, "cd lwr, upr", CDf(Q,BW,hl,z), CDf(Q,BW,hu,z)
+        ! call hydro_stop("In CRITICALDEPTH()") 
+        CRITICALDEPTH = -9999
+        return
+#endif
+      else
+        Q = 0.0
+      endif
+     endif
+
+     hr = 0.
+     fl = CDf(Q,Bw,hl,z)
+
+     if (Q .eq. 0.) then
+       hr = 0.
+     else
+      do while (error .gt. 0.0001 .and. maxiter < 1000)
+        hrold = hr
+        hr = (hl+hu)/2
+        fr =  CDf(Q,Bw,hr,z)
+        maxiter = maxiter + 1
+         if (hr .ne. 0) then
+          error = abs((hr - hrold)/hr)
+         endif
+        test = fl * fr
+         if (test.lt.0) then
+           hu = hr
+         elseif (test.gt.0) then
+           hl=hr
+           fl = fr
+         else
+           error = 0.0
+         endif
+
+       end do
+      endif
+
+     CRITICALDEPTH = hr
+
+     END FUNCTION CRITICALDEPTH
+!================================================
+     REAL FUNCTION SGNf(val)  !-- function to return the sign of a number
+     REAL:: val
+
+     if (val .lt. 0) then
+       SGNf= -1.
+     elseif (val.gt.0) then
+       SGNf= 1.
+     else
+       SGNf= 0.
+     endif
+
+     END FUNCTION SGNf
+!================================================
+
+     REAL FUNCTION fnDX(qp,Tw,So,Ck,dx,dt) !-- find channel sub-length for MK method
+     REAL    :: qp,Tw,So,Ck,dx, dt,test
+     REAL    :: dxl, dxu, dxr, dxrold
+     REAL    :: fl, fr, error
+     REAL    :: X
+     INTEGER :: maxiter
+
+     error = 1.0
+     maxiter =0
+     dxl = dx*0.9  !-- how to choose dxl???
+     dxu = dx
+     dxr=0
+
+     do while (fnDXCDT(qp,Tw,So,Ck,dxl,dt)*fnDXCDT(qp,Tw,So,Ck,dxu,dt) .gt. 0 &
+               .and. dxl .gt. 10)  !-- don't let dxl get too small
+      dxl = dxl/1.1
+     end do
+     
+      
+     fl = fnDXCDT(qp,Tw,So,Ck,dxl,dt)
+     do while (error .gt. 0.0001 .and. maxiter < 1000)
+        dxrold = dxr
+        dxr = (dxl+dxu)/2
+        fr =  fnDXCDT(qp,Tw,So,Ck,dxr,dt)
+        maxiter = maxiter + 1
+         if (dxr .ne. 0) then
+          error = abs((dxr - dxrold)/dxr)
+         endif
+        test = fl * fr
+         if (test.lt.0) then
+           dxu = dxr
+         elseif (test.gt.0) then
+           dxl=dxr
+           fl = fr
+         else
+           error = 0.0
+         endif
+      end do
+     FnDX = dxr
+
+    END FUNCTION fnDX
+!================================================
+     REAL FUNCTION fnDXCDT(qp,Tw,So,Ck,dx,dt) !-- function to help find sub-length for MK method
+     REAL    :: qp,Tw,So,Ck,dx,dt,X
+     REAL    :: c,b  !-- coefficients on dx/cdt log approximation function
+     
+     c = 0.2407
+     b = 1.16065
+     X = 0.5-(qp/(2*Tw*So*Ck*dx))
+     if (X .le.0) then 
+      fnDXCDT = -1 !0.115
+     else
+      fnDXCDT = (dx/(Ck*dt)) - (c*LOG(X)+b)  !-- this function needs to converge to 0
+     endif
+     END FUNCTION fnDXCDT
+! ----------------------------------------------------------------------
+
+    subroutine check_lake(unit,cd,lake_index,nlakes)
+         use module_RT_data, only: rt_domain
+         implicit none 
+         integer :: unit,nlakes,i,lake_index(nlakes)
+         real cd(nlakes)
+#ifdef MPP_LAND
+         call write_lake_real(cd,lake_index,nlakes)
+#endif
+         write(unit,*) cd
+          call flush(unit)
+         return
+    end subroutine check_lake
+
+    subroutine check_channel(unit,cd,did,nlinks)
+         use module_RT_data, only: rt_domain
+#ifdef MPP_LAND
+  USE module_mpp_land
+#endif
+         implicit none 
+         integer :: unit,nlinks,i, did
+         real cd(nlinks)
+#ifdef MPP_LAND
+         real g_cd(rt_domain(did)%gnlinks)
+         call write_chanel_real(cd,rt_domain(did)%map_l2g,rt_domain(did)%gnlinks,nlinks,g_cd)
+         if(my_id .eq. IO_id) then
+            write(unit,*) "rt_domain(did)%gnlinks = ",rt_domain(did)%gnlinks
+           write(unit,*) g_cd
+         endif
+#else
+           write(unit,*) cd
+#endif
+          call flush(unit)
+          close(unit)
+         return
+    end subroutine check_channel
+    subroutine smoth121(var,nlinks,maxv_p,from_node,to_node)
+        implicit none
+        integer,intent(in) ::  nlinks, maxv_p
+        integer, intent(in), dimension(nlinks):: to_node
+        integer, intent(in), dimension(nlinks):: from_node(nlinks,maxv_p)
+        real, intent(inout), dimension(nlinks) :: var
+        real, dimension(nlinks) :: vartmp
+        integer :: i,j  , k, from,to
+        integer :: plen
+              vartmp = 0
+              do i = 1, nlinks
+                 to = to_node(i)
+                 plen = from_node(i,1)
+                 if(plen .gt. 1) then 
+                     do k = 1, plen-1 
+                         from = from_node(i,k+1)
+                         if(to .gt. 0) then
+                            vartmp(i) = vartmp(i)+0.25*(var(from)+2.*var(i)+var(to))
+                         else
+                            vartmp(i) = vartmp(i)+(2.*var(i)+var(from))/3.0
+                         endif
+                     end do
+                     vartmp(i) = vartmp(i) /(plen-1)
+                 else
+                         if(to .gt. 0) then
+                            vartmp(i) = vartmp(i)+(2.*var(i)+var(to)/3.0)
+                         else
+                            vartmp(i) = var(i)
+                         endif
+                 endif
+              end do
+              var = vartmp 
+        return
+    end subroutine smoth121
+
+!   SUBROUTINE drive_CHANNEL for NHDPLUS
+! ------------------------------------------------
+
+     Subroutine drive_CHANNEL_RSL(UDMP_OPT,KT, IXRT,JXRT,  &
+        LAKEINFLORT, QSTRMVOLRT, TO_NODE, FROM_NODE, &
+        TYPEL, ORDER, MAXORDER,   CH_LNKRT, &
+        LAKE_MSKRT, DT, DTCT, DTRT_CH,MUSK, MUSX, QLINK, &
+        CHANLEN, MannN, So, ChSSlp, Bw, &
+        RESHT, HRZAREA, LAKEMAXH, WEIRH, WEIRC, WEIRL, ORIFICEC, ORIFICEA, &
+        ORIFICEE,  CVOL, QLAKEI, QLAKEO, LAKENODE, &
+        QINFLOWBASE, CHANXI, CHANYJ, channel_option,  &
+        nlinks,NLINKSL, LINKID, node_area, qout_gwsubbas, &
+        LAKEIDA, LAKEIDM, NLAKES, LAKEIDX, &
+#ifdef MPP_LAND 
+        nlinks_index,mpp_nlinks,yw_mpp_nlinks, &
+        LNLINKSL, &
+        gtoNode,toNodeInd,nToNodeInd,   &
+#endif
+         CH_LNKRT_SL, landRunOff  & 
+#ifdef WRF_HYDRO_NUDGING
+       , nudge &
+#endif
+
+       ,  accLndRunOff, accQLateral, accStrmvolrt, accBucket   &
+       , QLateral, velocity &
+       ,nsize , OVRTSWCRT, SUBRTSWCRT      )
+
+       use module_UDMAP, only: LNUMRSL, LUDRSL
+
+#ifdef WRF_HYDRO_NUDGING
+       use module_stream_nudging,  only: setup_stream_nudging,  & 
+                                         nudge_term_all,        &
+                                         nudgeWAdvance
+#endif 
+
+
+       IMPLICIT NONE
+
+! -------- DECLARATIONS ------------------------
+
+        INTEGER, INTENT(IN) :: IXRT,JXRT,channel_option, OVRTSWCRT, SUBRTSWCRT
+        INTEGER, INTENT(IN) :: NLAKES, NLINKSL, nlinks
+        integer, INTENT(INOUT) :: KT   ! flag of cold start (1) or continue run.
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: QSTRMVOLRT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: LAKEINFLORT
+        REAL, INTENT(IN), DIMENSION(IXRT,JXRT)    :: QINFLOWBASE
+        real, dimension(ixrt,jxrt) :: landRunOff
+
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_LNKRT
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: CH_LNKRT_SL
+
+        INTEGER, INTENT(IN), DIMENSION(IXRT,JXRT) :: LAKE_MSKRT
+        INTEGER, INTENT(IN), DIMENSION(:)         :: ORDER, TYPEL !--link
+        INTEGER, INTENT(IN), DIMENSION(:)     :: TO_NODE, FROM_NODE
+        INTEGER, INTENT(IN), DIMENSION(:)     :: CHANXI, CHANYJ
+        REAL, INTENT(IN), DIMENSION(:)        :: MUSK, MUSX
+        REAL, INTENT(IN), DIMENSION(:)        :: CHANLEN
+        REAL, INTENT(IN), DIMENSION(:)        :: So, MannN
+        REAL, INTENT(IN), DIMENSION(:)        :: ChSSlp,Bw  !--properties of nodes or links
+        REAL                                      :: Km, X
+        REAL , INTENT(INOUT), DIMENSION(:,:)  :: QLINK
+#ifdef WRF_HYDRO_NUDGING
+        real, intent(out),    dimension(:)    :: nudge
+#endif
+        REAL, DIMENSION(:), intent(out)       :: QLateral, velocity !--lateral flow
+        real, dimension(:), intent(out)       :: accLndRunOff, accQLateral, accStrmvolrt, accBucket 
+
+        REAL ,  DIMENSION(NLINKSL,2) :: tmpQLINK
+        REAL, INTENT(IN)                          :: DT    !-- model timestep
+        REAL, INTENT(IN)                          :: DTRT_CH  !-- routing timestep
+        REAL, INTENT(INOUT)                       :: DTCT
+        real                                      :: minDTCT !BF minimum routing timestep
+        INTEGER, INTENT(IN)                       :: MAXORDER
+        REAL , INTENT(IN), DIMENSION(:)   :: node_area
+
+!DJG GW-chan coupling variables...
+        REAL, DIMENSION(NLINKS)                   :: dzGwChanHead
+        REAL, DIMENSION(NLINKS)                   :: Q_GW_CHAN_FLUX     !DJG !!! Change 'INTENT' to 'OUT' when ready to update groundwater state...
+        REAL, DIMENSION(IXRT,JXRT)                :: ZWATTBLRT          !DJG !!! Match with subsfce/gw routing & Change 'INTENT' to 'INOUT' when ready to update groundwater state...
+
+        !-- lake params
+
+        REAL, INTENT(IN), DIMENSION(:)       :: HRZAREA  !-- horizontal area (km^2)
+        REAL, INTENT(IN), DIMENSION(:)       :: LAKEMAXH !-- maximum lake depth  (m^2)
+        REAL, INTENT(IN), DIMENSION(:)       :: WEIRH    !--  lake depth  (m^2)
+        REAL, INTENT(IN), DIMENSION(:)       :: WEIRC    !-- weir coefficient
+        REAL, INTENT(IN), DIMENSION(:)       :: WEIRL    !-- weir length (m)
+        REAL, INTENT(IN), DIMENSION(:)       :: ORIFICEC !-- orrifice coefficient
+        REAL, INTENT(IN), DIMENSION(:)       :: ORIFICEA !-- orrifice area (m^2)
+        REAL, INTENT(IN), DIMENSION(:)       :: ORIFICEE !-- orrifce elevation (m)
+        INTEGER, INTENT(IN), DIMENSION(:)    :: LAKEIDM  !-- NHDPLUS lakeid for lakes to be modeled
+
+        REAL, INTENT(INOUT), DIMENSION(:)    :: RESHT    !-- reservoir height (m)
+        REAL, INTENT(INOUT), DIMENSION(:)    :: QLAKEI   !-- lake inflow (cms)
+        REAL,                DIMENSION(NLAKES)    :: QLAKEIP  !-- lake inflow previous timestep (cms)
+        REAL, INTENT(INOUT), DIMENSION(NLAKES)    :: QLAKEO   !-- outflow from lake used in diffusion scheme
+
+        INTEGER, INTENT(IN), DIMENSION(:)    :: LAKENODE !-- outflow from lake used in diffusion scheme
+        INTEGER, INTENT(IN), DIMENSION(:)   :: LINKID   !--  id of channel elements for linked scheme
+        INTEGER, INTENT(IN), DIMENSION(:)   :: LAKEIDA  !--  (don't need) NHDPLUS lakeid for all lakes in domain
+        INTEGER, INTENT(IN), DIMENSION(:)   :: LAKEIDX  !--  the sequential index of the lakes id by com id
+
+        REAL, DIMENSION(NLINKS)                   :: QSUM     !--mass bal of node
+        REAL, DIMENSION(NLAKES)                   :: QLLAKE   !-- lateral inflow to lake in diffusion scheme
+        integer :: nsize
+
+!-- Local Variables
+        INTEGER                      :: i,j,k,t,m,jj,ii,lakeid, kk,KRT,node, UDMP_OPT
+        INTEGER                      :: DT_STEPS               !-- number of timestep in routing
+        REAL                         :: Qup,Quc                !--Q upstream Previous, Q Upstream Current, downstream Previous
+        REAL                         :: bo                     !--critical depth, bnd outflow just for testing
+
+        REAL ,DIMENSION(NLINKS)                          :: CD    !-- critical depth
+        real, DIMENSION(IXRT,JXRT)                       :: tmp
+        real, dimension(nlinks)                          :: tmp2
+        REAL, INTENT(INOUT), DIMENSION(:)           :: CVOL
+
+#ifdef MPP_LAND
+        real*8,  dimension(LNLINKSL) :: LQLateral
+        real*8,  dimension(LNLINKSL) :: tmpLQLateral
+        real,  dimension(NLINKSL)    :: tmpQLateral
+        integer nlinks_index(:)
+        integer  iyw, yw_mpp_nlinks, mpp_nlinks
+        real     ywtmp(ixrt,jxrt)
+        integer LNLINKSL
+        integer, dimension(:)         ::  toNodeInd
+        integer, dimension(:,:)       ::  gtoNode
+        integer  :: nToNodeInd
+        real, dimension(nToNodeInd,2) :: gQLINK
+#else
+        real*8,  dimension(NLINKS) :: tmpLQLateral
+        real,  dimension(NLINKSL) :: tmpQLateral
+        real,  dimension(NLINKSL) :: LQLateral
+#endif
+        integer flag
+
+        integer :: n, kk2, nt, nsteps  ! tmp 
+        real, dimension(:) :: qout_gwsubbas
+        real, allocatable,dimension(:) :: tmpQLAKEO, tmpQLAKEI, tmpRESHT
+  
+
+        real, dimension(NLINKS) ::  lcLndRunOff, lcQLateral, lcStrmvolrt, lcBucket  ! local variables
+
+
+
+
+#ifdef MPP_LAND
+        if(my_id .eq. io_id) then
+#endif
+            allocate(tmpQLAKEO(NLAKES))
+            allocate(tmpQLAKEI(NLAKES))
+            allocate(tmpRESHT(NLAKES))
+#ifdef MPP_LAND
+        endif
+#endif
+
+        QLAKEIP = 0
+        CD = 0  
+        node = 1
+        QLateral = 0
+        QSUM     = 0
+        QLLAKE   = 0
+        dzGwChanHead = 0.
+
+#ifdef WRF_HYDRO_NUDGING
+         !! Initialize nudging for the current timestep.
+         !! This establishes the data structure used to solve the nudges. 
+         call setup_stream_nudging(0)  !! always zero b/c at beginning of hydro timestep
+#endif /* WRF_HYDRO_NUDGING */
+
+         nsteps = (DT+0.5)/DTRT_CH
+         LQLateral = 0          !-- initial lateral flow to 0 for this reach
+
+
+        tmpLQLateral = 0
+        tmpQLateral = 0
+
+        ! NHDPLUS maping
+    if(OVRTSWCRT .eq. 0)      then
+        do k = 1, LNUMRSL
+           ! get from land grid runoff
+             do m = 1, LUDRSL(k)%ncell  
+                ii =  LUDRSL(k)%cell_i(m)
+                jj =  LUDRSL(k)%cell_j(m)
+                LQLateral(k) = LQLateral(k)+landRunOff(ii,jj)*LUDRSL(k)%cellweight(m)/1000 & 
+                              *LUDRSL(k)%cellArea(m)/DT
+                tmpLQLateral(k) = tmpLQLateral(k)+landRunOff(ii,jj)*LUDRSL(k)%cellweight(m)/1000 & 
+                              *LUDRSL(k)%cellArea(m)/DT
+             end do
+        end do
+#ifdef MPP_LAND
+        call updateLinkV(tmpLQLateral, tmpQLateral)
+#endif
+        if(NLINKSL .gt. 0) then
+            accLndRunOff(1:NLINKSL) = accLndRunOff(1:NLINKSL) + tmpQLateral(1:NLINKSL) * DT
+        endif
+        tmpLQLateral = 0
+        tmpQLateral = 0
+     endif
+
+     if(OVRTSWCRT .ne. 0 .or. SUBRTSWCRT .ne. 0 ) then
+        do k = 1, LNUMRSL
+              ! get from channel grid
+              do m = 1, LUDRSL(k)%ngrids
+                  ii =  LUDRSL(k)%grid_i(m)
+                  jj =  LUDRSL(k)%grid_j(m)
+                  LQLateral(k) = LQLateral(k) + QSTRMVOLRT(ii,jj)*LUDRSL(k)%weight(m)/1000 & 
+                          *LUDRSL(k)%nodeArea(m)/DT
+                  tmpLQLateral(k) = tmpLQLateral(k) + QSTRMVOLRT(ii,jj)*LUDRSL(k)%weight(m)/1000 & 
+                          *LUDRSL(k)%nodeArea(m)/DT
+              end do
+        end do
+#ifdef MPP_LAND
+        call updateLinkV(tmpLQLateral, tmpQLateral)
+#endif
+        if(NLINKSL .gt. 0) then
+            accStrmvolrt(1:NLINKSL) = accStrmvolrt(1:NLINKSL) + tmpQLateral(1:NLINKSL) * DT
+        endif
+     endif
+
+
+#ifdef MPP_LAND
+       call updateLinkV(LQLateral, QLateral(1:NLINKSL))
+#else
+       call hydro_stop("fatal error: NHDPlus only works for parallel now.")
+       QLateral = LQLateral
+#endif
+
+     if(NLINKSL .gt. 0) then
+        QLateral(1:NLINKSL) = QLateral(1:NLINKSL) + qout_gwsubbas(1:NLINKSL)
+     endif
+
+     ! accQLateral  = accLndRunOff + QLateral * DT 
+     if(NLINKSL .gt. 0) then
+        accQLateral(1:NLINKSL)  = accQLateral(1:NLINKSL) + QLateral(1:NLINKSL) * DT 
+        accBucket(1:NLINKSL) = accBucket(1:NLINKSL) + qout_gwsubbas(1:NLINKSL) * DT
+     endif
+
+!       QLateral = QLateral / nsteps
+
+   do nt = 1, nsteps
+ 
+#ifdef MPP_LAND
+
+       gQLINK = 0
+       call gbcastReal2(toNodeInd,nToNodeInd,QLINK(1:NLINKSL,2), NLINKSL, gQLINK(:,2))
+       call gbcastReal2(toNodeInd,nToNodeInd,QLINK(1:NLINKSL,1), NLINKSL, gQLINK(:,1)) 
+      !---------- route other reaches, with upstream inflow
+#endif
+
+       tmpQlink = 0
+#ifdef MPP_LAND
+       if(my_id .eq. io_id) then
+#endif
+          tmpQLAKEO = QLAKEO
+          tmpQLAKEI = QLAKEI
+          tmpRESHT = RESHT
+#ifdef MPP_LAND
+       endif
+#endif
+
+
+       DO k = 1,NLINKSL
+
+        Quc  = 0
+        Qup  = 0
+
+        !process as standard link or a lake inflow link, or lake outflow link
+        ! link flowing out of lake, accumulate all the inflows with the revised TO_NODEs
+        ! TYPEL = -999 stnd; TYPEL=1 outflow from lake; TYPEL = 3 inflow to a lake
+
+        if(TYPEL(k) .ne. 2) then ! don't process internal lake links only
+
+#ifdef MPP_LAND
+!using mapping index
+           do n = 1, gtoNODE(k,1)
+              m = gtoNODE(k,n+1)
+                if(gQLINK(m,2) .gt. 0)   Quc = Quc + gQLINK(m,2)  !--accum of upstream inflow of current timestep (2)
+                if(gQLINK(m,1) .gt. 0)   Qup = Qup + gQLINK(m,1)  !--accum of upstream inflow of previous timestep (1)
+           end do ! do i
+#else
+           do m = 1, NLINKSL
+
+               if (LINKID(k) .eq. TO_NODE(m)) then
+                 Quc = Quc + QLINK(m,2)  !--accum of upstream inflow of current timestep (2)
+                 Qup = Qup + QLINK(m,1)  !--accum of upstream inflow of previous timestep (1)
+               endif
+           end do ! do m
+#endif
+        endif !note that we won't process type 2 links, since they are internal to a lake
+
+
+!yw ### process each link k,
+!       There is a situation that different k point to the same LAKEIDX
+!        if(TYPEL(k) .eq. 1 .and. LAKEIDX(k) .gt. 0) then   !--link is a reservoir
+        if(TYPEL(k) .eq. 1 ) then   !--link is a reservoir
+             
+             lakeid = LAKEIDX(k)
+           if(lakeid .ge. 0) then
+             CALL LEVELPOOL(lakeid,Qup, Quc, tmpQLINK(k,2), &
+               QLateral(k), DT, RESHT(lakeid), HRZAREA(lakeid), WEIRH(lakeid), LAKEMAXH(lakeid), &
+               WEIRC(lakeid), WEIRL(lakeid),ORIFICEE(lakeid), ORIFICEC(lakeid), ORIFICEA(lakeid))
+             
+               QLAKEO(lakeid)  = tmpQLINK(k,2) !save outflow to lake
+               QLAKEI(lakeid)  = Quc           !save inflow to lake
+           endif
+105  continue
+            
+
+        elseif (channel_option .eq. 1) then  !muskingum routing
+               Km = MUSK(k)
+               X = MUSX(k)
+               tmpQLINK(k,2) = MUSKING(k,Qup,(Quc+QLateral(k)),QLINK(k,1),DTRT_CH,Km,X) !upstream plust lateral inflow 
+
+        elseif (channel_option .eq. 2) then ! muskingum cunge, don't process internal lake nodes TYP=2
+!              tmpQLINK(k,2) = MUSKINGCUNGE(k,Qup, Quc, QLINK(k,1), &
+!                  QLateral(k), DTRT_CH, So(k),  CHANLEN(k), &
+!                  MannN(k), ChSSlp(k), Bw(k) )
+
+              CALL SUBMUSKINGCUNGE(tmpQLINK(k,2),velocity(k), k,Qup, Quc, QLINK(k,1), &
+                   QLateral(k), DTRT_CH, So(k), CHANLEN(k), &
+                   MannN(k), ChSSlp(k), Bw(k) )
+                
+        else
+#ifdef HYDRO_D
+                    print *, " no channel option selected"
+#endif
+                    call hydro_stop("drive_CHANNEL") 
+        endif
+
+       END DO        !--k links
+
+#ifdef MPP_LAND
+       call updateLake_seq(QLAKEO,nlakes,tmpQLAKEO)
+       call updateLake_seq(QLAKEI,nlakes,tmpQLAKEI)
+       call updateLake_seq(RESHT,nlakes,tmpRESHT)
+#endif
+
+       do k = 1, NLINKSL !tmpQLINK?
+          if(TYPEL(k) .ne. 2) then !only the internal lake nodes don't have info.. but need to save QLINK of lake out too
+             QLINK(k,2) = tmpQLINK(k,2)
+          endif
+            QLINK(k,1) = QLINK(k,2)    !assigng link flow of current to be previous for next time step
+       end do
+
+
+#ifdef WRF_HYDRO_NUDGING         
+         if(.not. nudgeWAdvance) call nudge_term_all(qlink, nudge, int(nt*dtrt_ch))
+#endif /* WRF_HYDRO_NUDGING */
+
+
+!#ifdef HYDRO_D
+!          print *, "END OF ALL REACHES...",KRT,DT_STEPS
+!#endif
+
+    end do  ! nsteps
+
+    if (KT .eq. 1) KT = KT + 1
+
+#ifdef MPP_LAND
+    if(my_id .eq. io_id)      then 
+       if(allocated(tmpQLAKEO))  deallocate(tmpQLAKEO)
+       if(allocated(tmpQLAKEI))  deallocate(tmpQLAKEI)
+       if(allocated(tmpRESHT))  deallocate(tmpRESHT)
+    endif
+#endif        
+
+   if (KT .eq. 1) KT = KT + 1
+
+ END SUBROUTINE drive_CHANNEL_RSL
+
+! ----------------------------------------------------------------
+
+END MODULE module_channel_routing
+
+#ifdef MPP_LAND
+ subroutine checkReach(ii,  inVar)
+   use module_mpp_land
+   use module_RT_data, only: rt_domain
+   use MODULE_mpp_ReachLS, only : updatelinkv,                   &
+                                 ReachLS_write_io, gbcastvalue, &
+                                 gbcastreal2
+   implicit none
+   integer :: ii
+   real,dimension(rt_domain(1)%nlinksl) :: inVar
+   real:: g_var(rt_domain(1)%gnlinksl)
+   call ReachLS_write_io(inVar, g_var)
+   if(my_id .eq. io_id) then
+      write(ii,*) g_var
+      call flush(ii)
+   endif
+ end subroutine checkReach
+#endif
diff --git a/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F b/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F
new file mode 100644
index 00000000..1b71ea79
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_date_utilities_rt.F
@@ -0,0 +1,1032 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+module Module_Date_utilities_rt
+contains
+  subroutine geth_newdate (ndate, odate, idt)
+    implicit none
+
+    !  From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and 
+    !  delta-time, compute the new date.
+
+    !  on entry     -  odate  -  the old hdate.
+    !                  idt    -  the change in time
+
+    !  on exit      -  ndate  -  the new hdate.
+
+    integer, intent(in)           :: idt
+    character (len=*), intent(out) :: ndate
+    character (len=*), intent(in)  :: odate
+
+    !  Local Variables
+
+    !  yrold    -  indicates the year associated with "odate"
+    !  moold    -  indicates the month associated with "odate"
+    !  dyold    -  indicates the day associated with "odate"
+    !  hrold    -  indicates the hour associated with "odate"
+    !  miold    -  indicates the minute associated with "odate"
+    !  scold    -  indicates the second associated with "odate"
+
+    !  yrnew    -  indicates the year associated with "ndate"
+    !  monew    -  indicates the month associated with "ndate"
+    !  dynew    -  indicates the day associated with "ndate"
+    !  hrnew    -  indicates the hour associated with "ndate"
+    !  minew    -  indicates the minute associated with "ndate"
+    !  scnew    -  indicates the second associated with "ndate"
+
+    !  mday     -  a list assigning the number of days in each month
+
+    !  i        -  loop counter
+    !  nday     -  the integer number of days represented by "idt"
+    !  nhour    -  the integer number of hours in "idt" after taking out
+    !              all the whole days
+    !  nmin     -  the integer number of minutes in "idt" after taking out
+    !              all the whole days and whole hours.
+    !  nsec     -  the integer number of minutes in "idt" after taking out
+    !              all the whole days, whole hours, and whole minutes.
+
+    integer :: newlen, oldlen
+    integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew
+    integer :: yrold, moold, dyold, hrold, miold, scold, frold
+    integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc
+    logical :: opass
+    character (len=10) :: hfrc
+    character (len=1) :: sp
+    logical :: punct
+    integer :: yrstart, yrend, mostart, moend, dystart, dyend
+    integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart
+    integer :: units
+    integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/)
+
+    ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...."
+    if (odate(5:5) == "-") then
+       punct = .TRUE.
+    else
+       punct = .FALSE.
+    endif
+
+    !  Break down old hdate into parts
+
+    hrold = 0
+    miold = 0
+    scold = 0
+    frold = 0
+    oldlen = LEN(odate)
+    if (punct) then
+       yrstart = 1
+       yrend = 4
+       mostart = 6
+       moend = 7
+       dystart = 9
+       dyend = 10
+       hrstart = 12
+       hrend = 13
+       mistart = 15
+       miend = 16
+       scstart = 18
+       scend = 19
+       frstart = 21
+       select case (oldlen)
+       case (10)
+          ! Days
+          units = 1
+       case (13)
+          ! Hours
+          units = 2
+       case (16)
+          ! Minutes
+          units = 3
+       case (19)
+          ! Seconds
+          units = 4
+       case (21)
+          ! Tenths
+          units = 5
+       case (22)
+          ! Hundredths
+          units = 6
+       case (23)
+          ! Thousandths
+          units = 7
+       case (24)
+          ! Ten thousandths
+          units = 8
+       case default
+          write(*,*) 'ERROR: geth_newdate:  odd length: #'//trim(odate)//'#'
+          call hydro_stop("In geth_newdate() odd length")
+       end select
+
+       if (oldlen.ge.11) then
+          sp = odate(11:11)
+       else
+          sp = ' '
+       end if
+
+    else
+
+       yrstart = 1
+       yrend = 4
+       mostart = 5
+       moend = 6
+       dystart = 7
+       dyend = 8
+       hrstart = 9
+       hrend = 10
+       mistart = 11
+       miend = 12
+       scstart = 13
+       scend = 14
+       frstart = 15
+
+       select case (oldlen)
+       case (8)
+          ! Days
+          units = 1
+       case (10)
+          ! Hours
+          units = 2
+       case (12)
+          ! Minutes
+          units = 3
+       case (14)
+          ! Seconds
+          units = 4
+       case (15)
+          ! Tenths
+          units = 5
+       case (16)
+          ! Hundredths
+          units = 6
+       case (17)
+          ! Thousandths
+          units = 7
+       case (18)
+          ! Ten thousandths
+          units = 8
+       case default
+          write(*,*) 'ERROR: geth_newdate:  odd length: #'//trim(odate)//'#'
+          call hydro_stop("In geth_newdate() - odd length")
+       end select
+    endif
+
+    !  Use internal READ statements to convert the CHARACTER string
+    !  date into INTEGER components.
+
+    read(odate(yrstart:yrend),  '(i4)') yrold
+    read(odate(mostart:moend),  '(i2)') moold
+    read(odate(dystart:dyend), '(i2)') dyold
+    if (units.ge.2) then
+       read(odate(hrstart:hrend),'(i2)') hrold
+       if (units.ge.3) then
+          read(odate(mistart:miend),'(i2)') miold
+          if (units.ge.4) then
+             read(odate(scstart:scend),'(i2)') scold
+             if (units.ge.5) then
+                read(odate(frstart:oldlen),*) frold
+             end if
+          end if
+       end if
+    end if
+
+    !  Set the number of days in February for that year.
+
+    mday(2) = nfeb(yrold)
+
+    !  Check that ODATE makes sense.
+
+    opass = .TRUE.
+
+    !  Check that the month of ODATE makes sense.
+
+    if ((moold.gt.12).or.(moold.lt.1)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Month of ODATE = ', moold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the day of ODATE makes sense.
+
+    if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Day of ODATE = ', dyold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the hour of ODATE makes sense.
+
+    if ((hrold.gt.23).or.(hrold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Hour of ODATE = ', hrold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the minute of ODATE makes sense.
+
+    if ((miold.gt.59).or.(miold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Minute of ODATE = ', miold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the second of ODATE makes sense.
+
+    if ((scold.gt.59).or.(scold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Second of ODATE = ', scold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the fractional part  of ODATE makes sense.
+
+
+    if (.not.opass) then
+#ifdef HYDRO_D
+       write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen
+       call hydro_stop("In geth_newdate() - Crazy ODATE")
+#endif
+    end if
+
+    !  Date Checks are completed.  Continue.
+
+
+    !  Compute the number of days, hours, minutes, and seconds in idt
+
+    if (units.ge.5) then !idt should be in fractions of seconds
+       ifrc = oldlen-(frstart)+1
+       ifrc = 10**ifrc
+       nday   = abs(idt)/(86400*ifrc)
+       nhour  = mod(abs(idt),86400*ifrc)/(3600*ifrc)
+       nmin   = mod(abs(idt),3600*ifrc)/(60*ifrc)
+       nsec   = mod(abs(idt),60*ifrc)/(ifrc)
+       nfrac = mod(abs(idt), ifrc)
+    else if (units.eq.4) then  !idt should be in seconds
+       ifrc = 1
+       nday   = abs(idt)/86400 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),86400)/3600
+       nmin   = mod(abs(idt),3600)/60
+       nsec   = mod(abs(idt),60)
+       nfrac  = 0
+    else if (units.eq.3) then !idt should be in minutes
+       ifrc = 1
+       nday   = abs(idt)/1440 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),1440)/60
+       nmin   = mod(abs(idt),60)
+       nsec   = 0
+       nfrac  = 0
+    else if (units.eq.2) then !idt should be in hours
+       ifrc = 1
+       nday   = abs(idt)/24 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),24)
+       nmin   = 0
+       nsec   = 0
+       nfrac  = 0
+    else if (units.eq.1) then !idt should be in days
+       ifrc = 1
+       nday   = abs(idt)    ! integer number of days in delta-time
+       nhour  = 0
+       nmin   = 0
+       nsec   = 0
+       nfrac  = 0
+    else
+       write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') &
+            oldlen
+       write(*,*) '#'//odate(1:oldlen)//'#'
+       call hydro_stop("In geth_newdate()")
+    end if
+
+    if (idt.ge.0) then
+
+       frnew = frold + nfrac
+       if (frnew.ge.ifrc) then
+          frnew = frnew - ifrc
+          nsec = nsec + 1
+       end if
+
+       scnew = scold + nsec
+       if (scnew .ge. 60) then
+          scnew = scnew - 60
+          nmin  = nmin + 1
+       end if
+
+       minew = miold + nmin
+       if (minew .ge. 60) then
+          minew = minew - 60
+          nhour  = nhour + 1
+       end if
+
+       hrnew = hrold + nhour
+       if (hrnew .ge. 24) then
+          hrnew = hrnew - 24
+          nday  = nday + 1
+       end if
+
+       dynew = dyold
+       monew = moold
+       yrnew = yrold
+       do i = 1, nday
+          dynew = dynew + 1
+          if (dynew.gt.mday(monew)) then
+             dynew = dynew - mday(monew)
+             monew = monew + 1
+             if (monew .gt. 12) then
+                monew = 1
+                yrnew = yrnew + 1
+                ! If the year changes, recompute the number of days in February
+                mday(2) = nfeb(yrnew)
+             end if
+          end if
+       end do
+
+    else if (idt.lt.0) then
+
+       frnew = frold - nfrac
+       if (frnew .lt. 0) then
+          frnew = frnew + ifrc
+          nsec = nsec + 1
+       end if
+
+       scnew = scold - nsec
+       if (scnew .lt. 00) then
+          scnew = scnew + 60
+          nmin  = nmin + 1
+       end if
+
+       minew = miold - nmin
+       if (minew .lt. 00) then
+          minew = minew + 60
+          nhour  = nhour + 1
+       end if
+
+       hrnew = hrold - nhour
+       if (hrnew .lt. 00) then
+          hrnew = hrnew + 24
+          nday  = nday + 1
+       end if
+
+       dynew = dyold
+       monew = moold
+       yrnew = yrold
+       do i = 1, nday
+          dynew = dynew - 1
+          if (dynew.eq.0) then
+             monew = monew - 1
+             if (monew.eq.0) then
+                monew = 12
+                yrnew = yrnew - 1
+                ! If the year changes, recompute the number of days in February
+                mday(2) = nfeb(yrnew)
+             end if
+             dynew = mday(monew)
+          end if
+       end do
+    end if
+
+    !  Now construct the new mdate
+
+    newlen = LEN(ndate)
+
+    if (punct) then
+
+       if (newlen.gt.frstart) then
+          write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew
+          write(hfrc,'(i10)') frnew+1000000000
+          ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10)
+
+       else if (newlen.eq.scend) then
+          write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew
+19        format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2)
+
+       else if (newlen.eq.miend) then
+          write(ndate,16) yrnew, monew, dynew, hrnew, minew
+16        format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2)
+
+       else if (newlen.eq.hrend) then
+          write(ndate,13) yrnew, monew, dynew, hrnew
+13        format(i4,'-',i2.2,'-',i2.2,'_',i2.2)
+
+       else if (newlen.eq.dyend) then
+          write(ndate,10) yrnew, monew, dynew
+10        format(i4,'-',i2.2,'-',i2.2)
+
+       end if
+
+    else
+
+       if (newlen.gt.frstart) then
+          write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew
+          write(hfrc,'(i10)') frnew+1000000000
+          ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10)
+
+       else if (newlen.eq.scend) then
+          write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew
+119       format(i4,i2.2,i2.2,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.miend) then
+          write(ndate,116) yrnew, monew, dynew, hrnew, minew
+116       format(i4,i2.2,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.hrend) then
+          write(ndate,113) yrnew, monew, dynew, hrnew
+113       format(i4,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.dyend) then
+          write(ndate,110) yrnew, monew, dynew
+110       format(i4,i2.2,i2.2)
+
+       end if
+
+    endif
+
+    if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp
+
+  end subroutine geth_newdate
+
+  subroutine geth_idts (newdate, olddate, idt)
+
+    implicit none
+
+    !  From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'), 
+    !  compute the time difference.
+
+    !  on entry     -  newdate  -  the new hdate.
+    !                  olddate  -  the old hdate.
+
+    !  on exit      -  idt    -  the change in time.
+    !                            Units depend on length of date strings.
+
+    character (len=*) , intent(in) :: newdate, olddate
+    integer           , intent(out)   :: idt
+
+
+    !  Local Variables
+
+    !  yrnew    -  indicates the year associated with "ndate"
+    !  yrold    -  indicates the year associated with "odate"
+    !  monew    -  indicates the month associated with "ndate"
+    !  moold    -  indicates the month associated with "odate"
+    !  dynew    -  indicates the day associated with "ndate"
+    !  dyold    -  indicates the day associated with "odate"
+    !  hrnew    -  indicates the hour associated with "ndate"
+    !  hrold    -  indicates the hour associated with "odate"
+    !  minew    -  indicates the minute associated with "ndate"
+    !  miold    -  indicates the minute associated with "odate"
+    !  scnew    -  indicates the second associated with "ndate"
+    !  scold    -  indicates the second associated with "odate"
+    !  i        -  loop counter
+    !  mday     -  a list assigning the number of days in each month
+
+    ! ndate, odate: local values of newdate and olddate
+    character(len=24) :: ndate, odate
+
+    integer :: oldlen, newlen
+    integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew
+    integer :: yrold, moold, dyold, hrold, miold, scold, frold
+    integer :: i, newdys, olddys
+    logical :: npass, opass
+    integer :: timesign
+    integer :: ifrc
+    integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/)
+    logical :: punct
+    integer :: yrstart, yrend, mostart, moend, dystart, dyend
+    integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart
+    integer :: units
+
+    oldlen = len(olddate)
+    newlen = len(newdate)
+    if (newlen.ne.oldlen) then
+       write(*,'("GETH_IDTS: NEWLEN /= OLDLEN: ", A, 3x, A)') newdate(1:newlen), olddate(1:oldlen)
+       call hydro_stop("In geth_idts() - NEWLEN /= OLDLEN")
+    endif
+
+    if (olddate.gt.newdate) then
+       timesign = -1
+
+       ifrc = oldlen
+       oldlen = newlen
+       newlen = ifrc
+
+       ndate = olddate
+       odate = newdate
+    else
+       timesign = 1
+       ndate = newdate
+       odate = olddate
+    end if
+
+    ! Break down old hdate into parts
+
+    ! Determine if olddate is punctuated or not
+    if (odate(5:5) == "-") then
+       punct = .TRUE.
+       if (ndate(5:5) /= "-") then
+          write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') &
+               ndate(1:newlen), odate(1:oldlen)
+          call hydro_stop("In geth_idts() - Dates appear to be different formats")
+       endif
+    else
+       punct = .FALSE.
+       if (ndate(5:5) == "-") then
+          write(*,'("GETH_IDTS: Dates appear to be different formats: ", A, 3x, A)') &
+               ndate(1:newlen), odate(1:oldlen)
+          call hydro_stop("In geth_idts() - Dates appear to be different formats")
+       endif
+    endif
+
+    if (punct) then
+       yrstart = 1
+       yrend = 4
+       mostart = 6
+       moend = 7
+       dystart = 9
+       dyend = 10
+       hrstart = 12
+       hrend = 13
+       mistart = 15
+       miend = 16
+       scstart = 18
+       scend = 19
+       frstart = 21
+       select case (oldlen)
+       case (10)
+          ! Days
+          units = 1
+       case (13)
+          ! Hours
+          units = 2
+       case (16)
+          ! Minutes
+          units = 3
+       case (19)
+          ! Seconds
+          units = 4
+       case (21)
+          ! Tenths
+          units = 5
+       case (22)
+          ! Hundredths
+          units = 6
+       case (23)
+          ! Thousandths
+          units = 7
+       case (24)
+          ! Ten thousandths
+          units = 8
+       case default
+          write(*,*) 'ERROR: geth_idts:  odd length: #'//trim(odate)//'#'
+          call hydro_stop("In geth_idts() - odd length")
+       end select
+    else
+
+       yrstart = 1
+       yrend = 4
+       mostart = 5
+       moend = 6
+       dystart = 7
+       dyend = 8
+       hrstart = 9
+       hrend = 10
+       mistart = 11
+       miend = 12
+       scstart = 13
+       scend = 14
+       frstart = 15
+
+       select case (oldlen)
+       case (8)
+          ! Days
+          units = 1
+       case (10)
+          ! Hours
+          units = 2
+       case (12)
+          ! Minutes
+          units = 3
+       case (14)
+          ! Seconds
+          units = 4
+       case (15)
+          ! Tenths
+          units = 5
+       case (16)
+          ! Hundredths
+          units = 6
+       case (17)
+          ! Thousandths
+          units = 7
+       case (18)
+          ! Ten thousandths
+          units = 8
+       case default
+          write(*,*) 'ERROR: geth_idts:  odd length: #'//trim(odate)//'#'
+          call hydro_stop("In geth_idts() - odd length")
+       end select
+    endif
+
+
+    hrold = 0
+    miold = 0
+    scold = 0
+    frold = 0
+
+    read(odate(yrstart:yrend), '(i4)') yrold
+    read(odate(mostart:moend), '(i2)') moold
+    read(odate(dystart:dyend), '(i2)') dyold
+    if (units.ge.2) then
+       read(odate(hrstart:hrend),'(i2)') hrold
+       if (units.ge.3) then
+          read(odate(mistart:miend),'(i2)') miold
+          if (units.ge.4) then
+             read(odate(scstart:scend),'(i2)') scold
+             if (units.ge.5) then
+                read(odate(frstart:oldlen),*) frold
+             end if
+          end if
+       end if
+    end if
+
+    !  Break down new hdate into parts
+
+    hrnew = 0
+    minew = 0
+    scnew = 0
+    frnew = 0
+
+    read(ndate(yrstart:yrend), '(i4)') yrnew
+    read(ndate(mostart:moend), '(i2)') monew
+    read(ndate(dystart:dyend), '(i2)') dynew
+    if (units.ge.2) then
+       read(ndate(hrstart:hrend),'(i2)') hrnew
+       if (units.ge.3) then
+          read(ndate(mistart:miend),'(i2)') minew
+          if (units.ge.4) then
+             read(ndate(scstart:scend),'(i2)') scnew
+             if (units.ge.5) then
+                read(ndate(frstart:newlen),*) frnew
+             end if
+          end if
+       end if
+    end if
+
+    !  Check that the dates make sense.
+
+    npass = .true.
+    opass = .true.
+
+    !  Check that the month of NDATE makes sense.
+    
+    if ((monew.gt.12).or.(monew.lt.1)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_IDTS:  Month of NDATE = ', monew
+#endif
+       npass = .false.
+    end if
+
+    !  Check that the month of ODATE makes sense.
+
+    if ((moold.gt.12).or.(moold.lt.1)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Month of ODATE = ', moold
+#endif
+       opass = .false.
+    end if
+
+    !  Check that the day of NDATE makes sense.
+
+    if (monew.ne.2) then
+       ! ...... For all months but February
+       if ((dynew.gt.mday(monew)).or.(dynew.lt.1)) then
+#ifdef HYDRO_D
+          print*, 'GETH_IDTS:  Day of NDATE = ', dynew
+#endif
+          npass = .false.
+       end if
+    else if (monew.eq.2) then
+       ! ...... For February
+       if ((dynew > nfeb(yrnew)).or.(dynew < 1)) then
+#ifdef HYDRO_D
+          print*, 'GETH_IDTS:  Day of NDATE = ', dynew
+#endif
+          npass = .false.
+       end if
+    endif
+
+    !  Check that the day of ODATE makes sense.
+
+    if (moold.ne.2) then
+       ! ...... For all months but February
+       if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then
+#ifdef HYDRO_D
+          print*, 'GETH_IDTS:  Day of ODATE = ', dyold
+#endif
+          opass = .false.
+       end if
+    else if (moold.eq.2) then
+       ! ....... For February
+       if ((dyold > nfeb(yrold)).or.(dyold < 1)) then
+#ifdef HYDRO_D
+          print*, 'GETH_IDTS:  Day of ODATE = ', dyold
+#endif
+          opass = .false.
+       end if
+    end if
+
+    !  Check that the hour of NDATE makes sense.
+
+    if ((hrnew.gt.23).or.(hrnew.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Hour of NDATE = ', hrnew
+#endif
+       npass = .false.
+    end if
+
+    !  Check that the hour of ODATE makes sense.
+
+    if ((hrold.gt.23).or.(hrold.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Hour of ODATE = ', hrold
+#endif
+       opass = .false.
+    end if
+
+    !  Check that the minute of NDATE makes sense.
+
+    if ((minew.gt.59).or.(minew.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Minute of NDATE = ', minew
+#endif
+       npass = .false.
+    end if
+
+    !  Check that the minute of ODATE makes sense.
+
+    if ((miold.gt.59).or.(miold.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Minute of ODATE = ', miold
+#endif
+       opass = .false.
+    end if
+
+    !  Check that the second of NDATE makes sense.
+
+    if ((scnew.gt.59).or.(scnew.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  SECOND of NDATE = ', scnew
+#endif
+       npass = .false.
+    end if
+
+    !  Check that the second of ODATE makes sense.
+
+    if ((scold.gt.59).or.(scold.lt.0)) then
+#ifdef HYDRO_D
+       print*, 'GETH_IDTS:  Second of ODATE = ', scold
+#endif
+       opass = .false.
+    end if
+
+    if (.not. npass) then
+       print*, 'Screwy NDATE: ', ndate(1:newlen)
+       call hydro_stop("In geth_idts() - Screwy NDATE ")
+    end if
+
+    if (.not. opass) then
+       print*, 'Screwy ODATE: ', odate(1:oldlen)
+       call hydro_stop("In geth_idts() - Screwy ODATE ")
+    end if
+
+    !  Date Checks are completed.  Continue.
+
+    !  Compute number of days from 1 January ODATE, 00:00:00 until ndate
+    !  Compute number of hours from 1 January ODATE, 00:00:00 until ndate
+    !  Compute number of minutes from 1 January ODATE, 00:00:00 until ndate
+
+    newdys = 0
+    do i = yrold, yrnew - 1
+       newdys = newdys + 337 + nfeb(i)
+    end do
+
+    if (monew .gt. 1) then
+       mday(2) = nfeb(yrnew)
+       do i = 1, monew - 1
+          newdys = newdys + mday(i)
+       end do
+       mday(2) = 28
+    end if
+
+    newdys = newdys + dynew - 1
+
+    !  Compute number of hours from 1 January ODATE, 00:00:00 until odate
+    !  Compute number of minutes from 1 January ODATE, 00:00:00 until odate
+
+    olddys = 0
+
+    if (moold .gt. 1) then
+       mday(2) = nfeb(yrold)
+       do i = 1, moold - 1
+          olddys = olddys + mday(i)
+       end do
+       mday(2) = 28
+    end if
+
+    olddys = olddys + dyold -1
+
+    !  Determine the time difference
+
+    idt = (newdys - olddys)
+    if (units.ge.2) then
+       idt = idt*24 + (hrnew - hrold)
+       if (units.ge.3) then
+          idt = idt*60 + (minew - miold)
+          if (units.ge.4) then
+             idt = idt*60 + (scnew - scold)
+             if (units.ge.5) then
+                ifrc = oldlen-(frstart-1)
+                ifrc = 10**ifrc
+                idt = idt * ifrc + (frnew-frold)
+             endif
+          endif
+       endif
+    endif
+
+    if (timesign .eq. -1) then
+       idt = idt * timesign
+    end if
+
+  end subroutine geth_idts
+
+
+  integer function nfeb(year)
+    !
+    ! Compute the number of days in February for the given year.
+    !
+    implicit none
+    integer, intent(in) :: year ! Four-digit year
+
+    nfeb = 28 ! By default, February has 28 days ...
+    if (mod(year,4).eq.0) then  
+       nfeb = 29  ! But every four years, it has 29 days ...
+       if (mod(year,100).eq.0) then
+          nfeb = 28  ! Except every 100 years, when it has 28 days ...
+          if (mod(year,400).eq.0) then
+             nfeb = 29  ! Except every 400 years, when it has 29 days ...
+             if (mod(year,3600).eq.0) then
+                nfeb = 28  ! Except every 3600 years, when it has 28 days.
+             endif
+          endif
+       endif
+    endif
+  end function nfeb
+
+  integer function nmdays(hdate)
+    !
+    ! Compute the number of days in the month of given date hdate.
+    !
+    implicit none
+    character(len=*), intent(in) :: hdate
+
+    integer :: year, month
+    integer, dimension(12), parameter :: ndays = (/ 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /)
+
+    read(hdate(1:7), '(I4,1x,I2)') year, month
+
+    if (month == 2) then
+       nmdays = nfeb(year)
+    else
+       nmdays = ndays(month)
+    endif
+  end function nmdays
+
+  function monthabbr_to_mm(mon) result(mm)
+    implicit none
+
+    character(len=3), intent(in) :: mon
+
+    integer :: mm
+
+    if (mon == "Jan") then
+       mm = 1
+    elseif (mon == "Feb") then
+       mm = 2
+    elseif (mon == "Mar") then
+       mm = 3
+    elseif (mon == "Apr") then
+       mm = 4
+    elseif (mon == "May") then
+       mm = 5
+    elseif (mon == "Jun") then
+       mm = 6
+    elseif (mon == "Jul") then
+       mm = 7
+    elseif (mon == "Aug") then
+       mm = 8
+    elseif (mon == "Sep") then
+       mm = 9
+    elseif (mon == "Oct") then
+       mm = 10
+    elseif (mon == "Nov") then
+       mm = 11
+    elseif (mon == "Dec") then
+       mm = 12
+    else
+       write(*, '("Function monthabbr_to_mm:  mon = <",A,">")') mon
+       print*,  "Function monthabbr_to_mm:  Unrecognized mon"
+       call hydro_stop("In monthabbr_to_mm() - Unrecognized mon")
+    endif
+  end function monthabbr_to_mm
+
+  subroutine swap_date_format(indate, outdate)
+    implicit none
+    character(len=*), intent(in)  :: indate
+    character(len=*), intent(out) :: outdate
+    integer :: inlen
+
+    inlen = len(indate)
+    if (indate(5:5) == "-") then
+       select case (inlen)
+       case (10)
+          ! YYYY-MM-DD
+          outdate = indate(1:4)//indate(6:7)//indate(9:10)
+       case (13)
+          ! YYYY-MM-DD_HH
+          outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)
+       case (16)
+          ! YYYY-MM-DD_HH:mm
+          outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)
+       case (19)
+          ! YYYY-MM-DD_HH:mm:ss
+          outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//&
+               indate(18:19)
+       case (21,22,23,24)
+          ! YYYY-MM-DD_HH:mm:ss.f[f[f[f]]]
+          outdate = indate(1:4)//indate(6:7)//indate(9:10)//indate(12:13)//indate(15:16)//&
+               indate(18:19)//indate(21:inlen)
+       case default
+          write(*,'("Unrecognized length: <", A,">")') indate
+         call hydro_stop("In swap_date_format() - Unrecognized length")
+       end select
+    else
+       select case (inlen)
+       case (8)
+          ! YYYYMMDD
+          outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)
+       case (10)
+          ! YYYYMMDDHH
+          outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//&
+               indate(9:10)
+       case (12)
+          ! YYYYMMDDHHmm
+          outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//&
+               indate(9:10)//":"//indate(11:12)
+       case (14)
+          ! YYYYMMDDHHmmss
+          outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//&
+               indate(9:10)//":"//indate(11:12)//":"//indate(13:14)
+       case (15,16,17,18)
+          ! YYYYMMDDHHmmssf[f[f[f]]]
+          outdate = indate(1:4)//"-"//indate(5:6)//"-"//indate(7:8)//"_"//&
+               indate(9:10)//":"//indate(11:12)//":"//indate(13:14)//"."//indate(15:inlen)
+       case default
+          write(*,'("Unrecognized length: <", A,">")') indate
+          call hydro_stop("In swap_date_format() - Unrecognized length")
+       end select
+    endif
+
+  end subroutine swap_date_format
+
+  character(len=3) function mm_to_monthabbr(ii) result(mon)
+    implicit none
+    integer, intent(in) :: ii
+    character(len=3), parameter, dimension(12) :: month = (/ &
+         "Jan", "Feb", "Mar", "Apr", "May", "Jun", &
+         "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" /)
+    if (ii > 0 .and. ii < 13 ) then
+       mon = month(ii)
+    else
+!       print*, "mm_to_monthabbr"
+       call hydro_stop("In mm_to_monthabbr() - mm_to_monthabbr")
+    endif
+  end function mm_to_monthabbr
+
+end module Module_Date_utilities_rt
diff --git a/wrfv2_fire/hydro/Routing/module_gw_gw2d.F b/wrfv2_fire/hydro/Routing/module_gw_gw2d.F
new file mode 100644
index 00000000..0ea58070
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_gw_gw2d.F
@@ -0,0 +1,2159 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+!------------------------------------------------------------------------------
+! Benjamin Fersch  2d groundwater model
+!------------------------------------------------------------------------------
+
+
+module module_gw_gw2d
+
+
+#ifdef MPP_LAND
+   use module_mpp_land
+#endif
+   use module_gw_gw2d_data, only: gw2d
+   use module_rt_data, only: rt_domain
+   use module_namelist
+   
+   implicit none
+
+#include "gw_field_include.inc"
+
+
+#ifdef MPP_LAND
+ integer, private :: ierr
+ integer, parameter :: rowshift = 0
+ integer, parameter :: colshift = 1
+#endif
+
+
+ contains
+
+ 
+   subroutine gw2d_ini(did,dt,dx)
+     
+     use module_HYDRO_io, only: output_gw_spinup
+     
+     implicit none
+     integer did
+     real dt,dx
+     integer :: jj, ii, iter, itermax
+
+     
+    
+
+      itermax = nlst_rt(did)%GwPreCycles
+	   gw2d(did)%dx=dx
+           gw2d(did)%dt=dt
+           
+           gw2d(did)%qgw_chanrt = 0.
+           gw2d(did)%qsgwrt = 0.
+           gw2d(did)%qdarcyRT = 0.
+           gw2d(did)%excess = 0.
+           
+           gw2d(did)%compres=0. ! currently not implemented
+           gw2d(did)%istep=0 ! initialize time step
+           ! reset cells with undefined hydraulic conductivity
+           where(gw2d(did)%hycond .eq. 100) gw2d(did)%hycond = 5E-4
+           
+          do iter=1,itermax
+#ifdef HYDRO_D                        
+#ifdef MPP_LAND
+          if(my_id .eq. IO_id) &
+#endif
+          write(6,*) "       GW Pre-cycle", iter, "of", itermax
+#endif
+           call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, &
+             gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, &
+             gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, &
+             gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, gw2d(did)%excess, &
+             gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, &
+             iter)
+	   
+	     gw2d(did)%ho = gw2d(did)%h
+	     
+	  if((nlst_rt(did)%GwPreDiag .and. iter==1) .or. &
+	      nlst_rt(did)%GwPreDiag .and. (mod(iter, nlst_rt(did)%GwPreDiagInterval) .eq. 0) ) then
+           call output_gw_spinup(nlst_rt(did)%igrid, 1000000,                &
+                            RT_DOMAIN(did)%ixrt, RT_DOMAIN(did)%jxrt,   &
+                            nlst_rt(did)%startdate, nlst_rt(did)%olddate, &
+                            gw2d(did)%ho, gw2d(did)%convgw, gw2d(did)%excess,  &
+                            nlst_rt(did)%geo_finegrid_flnm,nlst_rt(did)%DT,     &
+                            RT_DOMAIN(did)%LATVAL,        &
+                            RT_DOMAIN(did)%LONVAL,rt_domain(did)%dist,          &
+                            nlst_rt(did)%output_gw)
+	   end if
+	  
+  
+          end do
+
+   return
+   end subroutine gw2d_ini
+
+   subroutine gw2d_allocate(did, ix, jx, nsoil)
+      
+      implicit none
+      integer ix, jx, nsoil
+      integer istatus, did
+      
+      if(gw2d(did)%allo_status .eq. 1) return
+      gw2d(did)%allo_status = 1
+      
+      gw2d(did)%ix = ix
+      gw2d(did)%jx = jx
+      
+#ifdef MPP_LAND
+      if(down_id == -1)  then !  if south border
+       gw2d(did)%jts = 1 
+      else
+       gw2d(did)%jts = 2
+      endif
+
+      if(up_id == -1)    then !if north border
+        gw2d(did)%jte = jx
+      else
+        gw2d(did)%jte = jx-1
+      endif
+
+      if(left_id == -1)  then !if west border
+        gw2d(did)%its = 1
+      else
+        gw2d(did)%its = 2
+      endif
+
+      if(right_id == -1) then ! if east border
+        gw2d(did)%ite = ix
+      else
+        gw2d(did)%ite = ix-1
+      endif
+
+#else
+      gw2d(did)%its = 1
+      gw2d(did)%ite = ix
+      gw2d(did)%jts = 1
+      gw2d(did)%jte = jx
+#endif
+
+      allocate(gw2d(did)%ltype  (ix,jx))
+      allocate(gw2d(did)%elev   (ix,jx))
+      allocate(gw2d(did)%bot    (ix,jx))
+      allocate(gw2d(did)%hycond (ix,jx))
+      allocate(gw2d(did)%poros  (ix,jx))
+      allocate(gw2d(did)%compres(ix,jx))
+      allocate(gw2d(did)%ho     (ix,jx))
+      allocate(gw2d(did)%h      (ix,jx))
+      allocate(gw2d(did)%convgw (ix,jx))
+      allocate(gw2d(did)%excess (ix,jx))
+
+      allocate(gw2d(did)%qgw_chanrt (ix,jx))
+      
+      
+      ! TODO allocate only if gwSoilCoupling is active
+      allocate(gw2d(did)%qsgwrt   (ix,jx))
+      allocate(gw2d(did)%qsgw     (rt_domain(did)%ix,rt_domain(did)%jx))
+      allocate(gw2d(did)%qdarcyRT (ix,jx))
+
+    end subroutine gw2d_allocate
+
+
+    subroutine gwstep(ix, jx, dx,              &
+		      ltype, elev, bot,        &
+		      hycond, poros, compres,  &
+                      ho, h, convgw, excess,   &
+                      ebot, eocn,              &
+		      dt, istep)
+
+! New (volug): calling routines use change in head, convgw = d(h-ho)/dt.
+
+! Steps ground-water hydrology (head) through one timestep.
+! Modified from Prickett and Lonnquist (1971), basic one-layer aquifer 
+! simulation program, with mods by Zhongbo Yu(1997).
+! Solves S.dh/dt = d/dx(T.dh/dx) + d/dy(T.dh/dy) + "external sources"
+! for a single layer, where h is head, S is storage coeff and T is 
+! transmissivity. 3-D arrays in main program (hycond,poros,h,bot)
+! are 2-D here, since only a single (uppermost) layer is solved.
+! Uses an iterative time-implicit ADI method.
+
+! use module_hms_constants
+
+
+
+      integer, intent(in) :: ix, jx
+
+      integer, intent(in), dimension(ix,jx) ::  ltype     ! land-sfc type  (supp)
+      real,    intent(in), dimension(ix,jx) ::  &
+        elev,           &  ! elev/bathymetry of sfc rel to sl (m) (supp)
+        bot,            &  ! elev. aquifer bottom rel to sl (m)   (supp)
+        hycond,         &  ! hydraulic conductivity (m/s per m/m) (supp)
+        poros,          &  ! porosity (m3/m3)                     (supp)
+        compres,        &  ! compressibility (1/Pa)               (supp)
+        ho                 ! head at start of timestep (m)        (supp)
+
+      real,    intent(inout), dimension(ix,jx) ::  &
+        h,              &  ! head, after ghmcompute (m)           (ret)
+        convgw,         &  ! convergence due to gw flow (m/s)     (ret)
+        excess            
+
+      real, intent(inout) :: ebot, eocn
+     
+
+
+      integer ::  istep !, dt
+      real, intent(in) :: dt, dx
+
+! #endif      
+!       eocn  = mean spurious sink for h_ocn = sealev fix (m/s)(ret)
+!               This equals the total ground-water flow across 
+!               land->ocean boundaries.
+!       ebot  = mean spurious source for "bot" fix (m/s) (returned)
+!       time  = elapsed time from start of run (sec)
+!       dt = timestep length (sec)
+!       istep = timestep counter
+
+! Local arrays:
+
+      real, dimension(ix,jx)   :: sf2    ! storage coefficient (m3 of h2o / bulk m3)
+      real, dimension(ix,jx,2) ::   t    ! transmissivity (m2/s)..1 for N-S,..2 for E-W
+
+#ifdef MPP_LAND
+      real, dimension(:,:), allocatable :: aa, &         ! tridiagonal matrix lower diagonal
+                                           bb, &         ! tridiagonal matrix main diagonal
+                                           cc, &         ! tridiagonal matrix upper diagonal
+                                           dd, &         ! right hand side
+                                           b2, &          
+                                           c2, &          
+                                           rhs, &          
+                                           wk, &           
+                                           hh           
+      real, dimension(:), allocatable ::   xfac, &
+                                           zfac
+#else                                         
+      real, dimension(:), allocatable :: aa, &         ! tridiagonal matrix lower diagonal
+                                         bb, &         ! tridiagonal matrix main diagonal
+                                         cc, &         ! tridiagonal matrix upper diagonal
+                                         dd, &         ! right hand side
+                                         hh            ! solution vector
+#endif
+      real, parameter    :: botinc = 0.01  ! re-wetting increment to fix h < bot
+!     parameter (botinc = 0.  )  ! re-wetting increment to fix h < bot
+                                 ! (m); else no flow into dry cells
+      real, parameter    :: delskip = 0.005 ! av.|dhead| value for iter.skip out(m)
+      integer, parameter :: itermax = 1    ! maximum number of iterations
+      integer, parameter :: itermin = 1    ! minimum number of iterations
+      real, parameter    :: sealev = 1000.     ! sea-level elevation (m)
+
+      integer            :: its, ite, jts, jte, ifs, ife, jfs, jfe, &
+                            xdim, ydim, fxdim, fydim
+                          
+! die müssen noch sortiert, geprüft und aufgeräumt werden
+      integer ::                &
+        iter,                   &
+        j,                      &
+        i,                      &
+        jp,                     &
+        ip,                     &
+        n,                      &
+        ierr,                   &
+        ier,                    &
+        ioffs,                  &
+        joffs
+        
+!       real :: su, sc, shp, bb, aa, cc, w, zz, tareal, dtoa, dtot
+      real ::                   &
+        dy,                     &
+        e,                      &
+        su,                     &
+        sc,                     &
+        shp,                    &
+        w,                      &
+        ha,                     &
+        delcur,                 &
+        dtot,                   &
+        dtoa,                   &
+        darea,                  &
+        tareal,                 &
+        zz
+
+#ifdef MPP_LAND
+      real ::        mpiDelcur, &
+                     gdtot,     &
+                     gdtoa,     &
+                     geocn,     &
+                     gebot
+      integer mpiSize
+#endif
+
+
+
+dy = dx
+darea = dx*dy
+
+! define indexes for parallel execution
+
+#ifdef MPP_LAND
+if(down_id == -1)  then !  if south border
+  jts = 1 
+else
+  jts = 2
+endif
+
+if(up_id == -1)    then !if north border
+  jte = jx
+else
+  jte = jx-1
+endif
+
+if(left_id == -1)  then !if west border
+  its = 1
+else
+  its = 2
+endif
+
+if(right_id == -1) then ! if east border
+  ite = ix
+else
+  ite = ix-1
+endif
+
+#else
+its = 1
+ite = ix
+jts = 1
+jte = jx
+#endif
+
+ifs = 1
+ife = ix
+jfs = 1
+jfe = jx
+
+
+fxdim = ife-ifs+1 
+fydim = jfe-jfs+1
+ xdim = ite-its+1 
+ ydim = jte-jts+1
+
+     
+      call scopy (fxdim*fydim, ho(ifs:ife,jfs:jfe), 1,    &
+                  h(ifs:ife,jfs:jfe), 1)
+
+
+!       Top of iterative loop for (not anymore ADI) solution
+
+      iter = 0
+!~~~~~~~~~~~~~
+   80 continue
+!~~~~~~~~~~~~~
+      iter = iter+1
+
+      
+#ifdef MPP_LAND
+
+       call MPP_LAND_COM_REAL(h, fxdim, fydim, 99)
+
+#endif
+      e    = 0.       ! absolute changes in head (for iteration control)
+!      eocn = 0.       ! accumulated fixes for h = 0 over ocean (diag)
+!      ebot = 0.       ! accumulated fixes for h < bot (diagnostic)
+
+!       Set storage coefficient (sf2)
+   
+   
+
+    tareal = 0.
+      do j=jts,jte
+        do i=its,ite
+
+
+        if(ltype(i,j) .ge. 1) tareal = tareal + darea
+
+!         unconfined water table (h < e): V = poros*(h-b)
+!                                         dV/dh = poros
+!         saturated to surface (h >= e) : V = poros*(e-b) + (h-e)
+!                                         dV/dh = 1
+!         (compressibility is ignored)
+!
+!         su = poros(i,j)*(1.-theta(i,j))    ! old (pre-volug)
+          su = poros(i,j)                    ! new (volug)
+          sc = 1.
+ 
+!           if      (ho(i,j).le.elev(i,j) .and. h(i,j).le.elev(i,j)) then
+            sf2(i,j) = su
+!           else if (ho(i,j).ge.elev(i,j) .and. h(i,j).ge.elev(i,j)) then
+!             sf2(i,j) = sc
+!           else if (ho(i,j).le.elev(i,j) .and. h(i,j).ge.elev(i,j)) then
+!             shp = sf2(i,j) * (h(i,j) - ho(i,j))
+!             sf2(i,j) = shp * sc / (shp - (su-sc)*(elev(i,j)-ho(i,j)))
+!           else if (ho(i,j).ge.elev(i,j) .and. h(i,j).le.elev(i,j)) then
+!             shp = sf2(i,j) * (ho(i,j) - h(i,j))
+!             sf2(i,j) = shp * su / (shp + (su-sc)*(ho(i,j)-elev(i,j)))
+!           endif
+
+        enddo
+      enddo
+
+#ifdef MPP_LAND
+       ! communicate storage coefficient
+       call MPP_LAND_COM_REAL(sf2, fxdim, fydim, 99)
+
+#endif
+
+!==========================
+!       Column calculations
+!==========================
+
+!       Set transmissivities. Use min(h,elev)-bot instead of h-bot,
+!       since if h > elev, thickness of groundwater flow is just
+!       elev-bot. (uses geometric mean)
+
+
+      do j=jts,jte
+        jp = min (j+1,jfe)
+        do i=its,ite
+          ip = min (i+1,ife)
+
+          t(i,j,2) = sqrt( abs(                                           &
+                        hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j))  &
+                       *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j))  &
+                         )    )                                           &
+                   * (0.5*(dy+dy)) & ! in WRF the dx and dy are usually equal
+                   / (0.5*(dx+dx))
+
+          t(i,j,1) = sqrt( abs(                                           &
+                        hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j ))  &
+                       *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp))  &
+                         )    )                                           &
+                   * (0.5*(dx+dx))  &
+                   / (0.5*(dy+dy))
+
+
+        enddo
+      enddo
+
+
+
+
+
+#ifdef MPP_LAND
+      ! communicate transmissivities in x and y direction
+       call MPP_LAND_COM_REAL(t(:,:,1), fxdim, fydim, 99)
+       call MPP_LAND_COM_REAL(t(:,:,2), fxdim, fydim, 99)
+
+       
+       allocate(aa(jts:jte,its:ite))
+       allocate(bb(jts:jte,its:ite))
+       allocate(cc(jts:jte,its:ite))
+       allocate(dd(jts:jte,its:ite))
+       allocate(c2(1:ydim,1:xdim))
+       allocate(b2(1:ydim,1:xdim))
+       allocate(wk(1:ydim,1:xdim))
+       allocate(hh(0:ydim+1,0:xdim+1))
+       allocate(xfac(1:ydim))
+       allocate(zfac(1:ydim))
+#else
+  allocate(aa(jfs:jfe))
+  allocate(bb(jfs:jfe))
+  allocate(cc(jfs:jfe))
+  allocate(dd(jfs:jfe))
+  allocate(hh(jfs:jfe))
+
+!-------------------
+      do i=ifs,ife
+!-------------------
+
+!>>>>>>>>>>>>>>>>>>>>
+        do j=jfs,jfe
+!>>>>>>>>>>>>>>>>>>>>
+#endif
+#ifndef MPP_LAND
+          bb(j) = (sf2(i,j)/dt) * darea
+          dd(j) = ( ho(i,j)*sf2(i,j)/dt ) * darea
+          aa(j) = 0.0
+          cc(j) = 0.0
+
+          if ((j-jfs) /= 0) then 
+           aa(j) = -t(i,j-1,1)
+           bb(j) = bb(j) + t(i,j-1,1)
+	  endif
+
+          if ((j-jfe) /= 0) then
+           cc(j) = -t(i,j,1)
+           bb(j) = bb(j) + t(i,j,1)
+	  endif
+
+          if ((i-ifs) /= 0) then
+           bb(j) = bb(j) + t(i-1,j,2)
+           dd(j) = dd(j) + h(i-1,j)*t(i-1,j,2)
+	  endif
+
+          if ((i-ife) /= 0) then
+           bb(j) = bb(j) + t(i,j,2)
+           dd(j) = dd(j) + h(i+1,j)*t(i,j,2)
+	  endif
+
+!>>>>>>>>>>>>>>>
+	end do
+!>>>>>>>>>>>>>>>
+
+  call trdiagSolve(aa, bb, cc, dd, hh, fydim)
+
+  h(i,:) = hh
+  end do
+  
+deallocate(aa)
+deallocate(bb)
+deallocate(cc)
+deallocate(dd)
+deallocate(hh)
+
+#else
+!-------------------
+      do i=its,ite
+!-------------------
+
+!>>>>>>>>>>>>>>>>>>>>
+        do j=jts,jte
+!>>>>>>>>>>>>>>>>>>>>
+          bb(j,i) = (sf2(i,j)/dt) * darea
+          dd(j,i) = ( ho(i,j)*sf2(i,j)/dt ) * darea
+          aa(j,i) = 0.0
+          cc(j,i) = 0.0
+
+          if (((j-jfs) /= 0)) then 
+           aa(j,i) = -t(i,j-1,1)
+           bb(j,i) = bb(j,i) + t(i,j-1,1)
+	  endif
+
+          if (((j-jfe) /= 0)) then
+           cc(j,i) = -t(i,j,1)
+           bb(j,i) = bb(j,i) + t(i,j,1)
+	  endif
+
+          if (((i-ifs) /= 0)) then
+           bb(j,i) = bb(j,i) + t(i-1,j,2)
+           dd(j,i) = dd(j,i) + h(i-1,j)*t(i-1,j,2)
+	  endif
+
+          if (((i-ife) /= 0)) then
+           bb(j,i) = bb(j,i) + t(i,j,2)
+           dd(j,i) = dd(j,i) + h(i+1,j)*t(i,j,2)
+	  endif
+
+!>>>>>>>>>>>>>>>
+	end do
+!>>>>>>>>>>>>>>>
+
+!-------------
+  end do
+!-------------
+
+    if(np_up_down .gt. 1) then
+        call sub_n_form(xdim, ydim, aa, &
+                        bb, cc, &
+                        dd, &
+                        c2, b2, hh, wk, xfac, zfac, &
+                        p_up_down+1, np_up_down, 2)
+
+	
+	call parysolv1(c2, b2, hh, 1., my_id+1, p_up_down+1, &
+	                xdim, ydim, np_left_right, np_up_down)
+
+    else
+        call sub_tri_solv(xdim,ydim,aa(jts:jte,its:ite), &
+                          bb(jts:jte,its:ite), cc(jts:jte,its:ite), &
+                          dd(jts:jte,its:ite), &
+                          hh, wk,xfac,zfac,2)
+    endif
+
+ioffs = its-1
+joffs = jts-1
+!-------------------
+      do i=its,ite
+!-------------------
+
+!>>>>>>>>>>>>>>>>>>>>
+        do j=jts,jte
+!>>>>>>>>>>>>>>>>>>>>
+
+              h(i,j) = hh(j-joffs,i-ioffs)
+	      
+	 end do
+     end do
+	      
+#endif 
+
+#ifdef MPP_LAND
+
+       call MPP_LAND_COM_REAL(h, fxdim, fydim, 99)
+
+#endif
+
+
+!=======================
+!       Row calculations
+!=======================
+
+!       set transmissivities (same as above)
+
+
+      do j=jts,jte
+        jp = min (j+1,jfe)
+        do i=its,ite
+          ip = min (i+1,ife)
+          t(i,j,2) = sqrt( abs(                                            &
+                        hycond(i, j)*(min(h(i ,j),elev(i ,j))-bot(i ,j))   &
+                       *hycond(ip,j)*(min(h(ip,j),elev(ip,j))-bot(ip,j))   &
+                         )    )                                            &
+                   * (0.5*(dy+dy))                                         &
+                   / (0.5*(dx+dx))
+
+          t(i,j,1) = sqrt( abs(                                            &
+                        hycond(i,j )*(min(h(i,j ),elev(i,j ))-bot(i,j ))   &
+                       *hycond(i,jp)*(min(h(i,jp),elev(i,jp))-bot(i,jp))   &
+                         )    )                                            &
+                   * (0.5*(dx+dx))                                         &
+                   / (0.5*(dy+dy))
+
+
+        enddo
+      enddo
+
+#ifdef MPP_LAND
+      ! communicate transmissivities in x and y direction
+       call MPP_LAND_COM_REAL(t(:,:,1), fxdim, fydim, 99)
+       call MPP_LAND_COM_REAL(t(:,:,2), fxdim, fydim, 99)
+#endif
+
+#ifndef MPP_LAND     
+allocate(aa(ifs:ife))
+allocate(bb(ifs:ife))
+allocate(cc(ifs:ife))
+allocate(dd(ifs:ife))
+allocate(hh(ifs:ife))
+
+
+!-------------------
+      do j=jfs,jfe
+!-------------------
+
+
+!>>>>>>>>>>>>>>>>>>>>
+        do i=ifs,ife
+!>>>>>>>>>>>>>>>>>>>>
+          bb(i) = (sf2(i,j)/dt) * darea
+          dd(i) = ( ho(i,j)*sf2(i,j)/dt ) * darea
+          aa(i) = 0.0
+          cc(i) = 0.0
+
+          if ((j-jfs) /= 0) then
+           bb(i) = bb(i) + t(i,j-1,1)
+           dd(i) = dd(i) + h(i,j-1)*t(i,j-1,1)
+	  endif
+ 
+          if ((j-jfe) /= 0) then
+           dd(i) = dd(i) + h(i,j+1)*t(i,j,1)
+           bb(i) = bb(i) + t(i,j,1)
+	  endif
+
+          if ((i-ifs) /= 0) then
+           bb(i) = bb(i) + t(i-1,j,2)
+           aa(i) = -t(i-1,j,2)
+	  endif
+
+          if ((i-ife) /= 0) then
+           bb(i) = bb(i) + t(i,j,2)
+           cc(i) = -t(i,j,2)
+	  endif
+
+!>>>>>>>>>>>>>>>
+	end do
+!>>>>>>>>>>>>>>>
+
+  call trdiagSolve(aa, bb, cc, dd, hh, fxdim)
+
+  h(:,j) = hh
+  end do
+  
+#else
+!-------------------
+      do i=its,ite
+!-------------------
+
+!>>>>>>>>>>>>>>>>>>>>
+        do j=jts,jte
+!>>>>>>>>>>>>>>>>>>>>
+          bb(j,i) = (sf2(i,j)/dt) * darea
+          dd(j,i) = ( ho(i,j)*sf2(i,j)/dt ) * darea
+          aa(j,i) = 0.0
+          cc(j,i) = 0.0
+
+          if (((j-jfs) /= 0)) then
+           bb(j,i) = bb(j,i) + t(i,j-1,1)
+           dd(j,i) = dd(j,i) + h(i,j-1)*t(i,j-1,1)
+	  endif
+ 
+          if (((j-jfe) /= 0)) then
+           dd(j,i) = dd(j,i) + h(i,j+1)*t(i,j,1)
+           bb(j,i) = bb(j,i) + t(i,j,1)
+	  endif
+
+          if (((i-ifs) /= 0)) then
+           bb(j,i) = bb(j,i) + t(i-1,j,2)
+           aa(j,i) = -t(i-1,j,2)
+	  endif
+
+          if (((i-ife) /= 0)) then
+           bb(j,i) = bb(j,i) + t(i,j,2)
+           cc(j,i) = -t(i,j,2)
+	  endif
+	  
+!>>>>>>>>>>>>>>>
+	end do
+!>>>>>>>>>>>>>>>
+
+!-------------
+end do
+!-------------
+
+    if(np_left_right .gt. 1) then
+
+! 3 c(,)  -- subdiagonal elements of tridiagonal systems
+! 4 a(,)  -- diagonal elements of tridiagonal systems
+! 5 b(,)  -- superdiagonal elements of tridiagonal systems
+! 6 r(,)  -- right-hand side elements of tridiagonal systems
+! 7 c2(,) -- front-leg elements of N-systems
+! 8 b2(,) -- back-leg elements of N-systems
+! 9 r2(,) -- right-hand side elements of N-systems (0:ydim+1,0:xdim+1)
+! 10 wk(,) -- work array with same dimensions as a, b, c, etc.
+
+        call sub_n_form(xdim, ydim, aa, &
+                        bb, cc, &
+                        dd, &
+                        c2, b2, hh, wk, xfac, zfac, &
+                        p_left_right+1, np_left_right, 1)
+	
+        call parxsolv1(c2, b2, hh, 1., my_id+1, p_left_right+1, &
+	                xdim, ydim, np_left_right, np_up_down)
+
+    else
+        call sub_tri_solv(xdim,ydim,aa, &
+                          bb, cc, &
+                          dd, &
+                          hh, wk,xfac,zfac,1)
+    endif
+ioffs = its-1
+joffs = jts-1
+!-------------------
+      do i=its,ite
+!-------------------
+
+!>>>>>>>>>>>>>>>>>>>>
+        do j=jts,jte
+!>>>>>>>>>>>>>>>>>>>>
+
+               h(i,j) = hh(j-joffs,i-ioffs)
+
+      end do
+     end do
+	      
+deallocate(b2)
+deallocate(c2)
+deallocate(wk)
+deallocate(xfac)
+deallocate(zfac)
+#endif 
+deallocate(aa)
+deallocate(bb)
+deallocate(cc)
+deallocate(dd)
+deallocate(hh)
+
+! fix head < bottom of aquifer
+ 
+      do j=jts,jte
+        do i=its,ite
+          if (ltype(i,j).eq.1 .and. h(i,j).le.bot(i,j)+botinc) then
+
+            e = e +  bot(i,j) + botinc - h(i,j)
+!             ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea(i,j)
+            ebot = ebot + (bot(i,j)+botinc-h(i,j))*sf2(i,j)*darea
+
+            h(i,j) = bot(i,j) + botinc
+          endif
+        enddo
+      enddo
+!        maintain head = sea level for ocean (only for adjacent ocean,
+!        rest has hycond=0)
+
+      do j=jts,jte
+        do i=its,ite
+          if (ltype(i,j).eq.2) then
+
+	    eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea
+!             eocn = eocn + (h(i,j)-sealev)*sf2(i,j)*darea(i,j)
+
+!             h(i,j) = sealev (no update of outer boundary cells)
+          endif
+        enddo
+      enddo
+
+!        Loop back for next ADI iteration
+
+!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+      delcur = e/(xdim*ydim)
+
+!       print*, 'delcur before mpi:', delcur
+
+#ifdef MPP_LAND
+
+call mpi_reduce(delcur, mpiDelcur, 1, MPI_REAL, MPI_SUM, 0, HYDRO_COMM_WORLD, ierr)
+call MPI_COMM_SIZE( HYDRO_COMM_WORLD, mpiSize, ierr )
+
+if(my_id .eq. IO_id) delcur = mpiDelcur/mpiSize
+
+call mpi_bcast(delcur, 1, mpi_real, 0, HYDRO_COMM_WORLD, ierr)
+
+#endif
+
+!       if ( (delcur.gt.delskip*dt/86400. .and. iter.lt.itermax)      &
+      if ( (delcur.gt.delskip .and. iter.lt.itermax)      &
+           .or. iter.lt.itermin ) then
+           
+#ifdef HYDRO_D 
+
+#ifdef MPP_LAND
+if(my_id .eq. IO_id)  write(6,*) "Iteration", iter, "of", itermax, "error:", delcur
+#else
+                      write(6,*) "Iteration", iter, "of", itermax, "error:", delcur
+#endif
+
+#endif
+
+      goto 80
+      endif
+      
+#ifdef MPP_LAND
+
+       call MPP_LAND_COM_REAL(h, fxdim, fydim, 99)
+
+#endif
+
+      
+
+!     Compute exfiltration amount and 
+!     convergence rate due to ground water 
+!     flow
+
+      do j=jts,jte
+        do i=its,ite
+	  
+	  if((elev(i,j) - h(i,j)) .lt. 0.) then
+	    excess(i,j) = sf2(i,j)*(h(i,j) - elev(i,j))
+                 h(i,j) = elev(i,j)
+          else 
+	    excess(i,j) = 0.
+	  end if
+	  
+          if(ltype(i,j).eq.1) then
+            convgw(i,j) = sf2(i,j) * (h(i,j)-ho(i,j)) / dt
+          else
+            convgw(i,j) = 0.
+          endif
+        enddo
+      enddo
+
+!      call MPP_LAND_COM_REAL(convgw, fxdim, fydim, 99)
+
+!        Diagnostic water conservation check for this timestep
+
+      dtot = 0.     ! total change in water storage (m3)
+      dtoa = 0.
+
+      do j=jts,jte
+        do i=its,ite
+          if (ltype(i,j).eq.1) then
+
+	    dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea
+            dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea
+
+!             dtot = dtot + sf2(i,j) *(h(i,j)-ho(i,j)) * darea(i,j)
+!             dtoa = dtoa + sf2(i,j) * abs(h(i,j)-ho(i,j)) * darea(i,j)
+          endif
+        enddo
+      enddo
+
+      dtot = (dtot/tareal)/dt   ! convert to m/s, rel to land area
+      dtoa = (dtoa/tareal)/dt
+      eocn = (eocn/tareal)/dt
+      ebot = (ebot/tareal)/dt
+
+      zz = 1.e3 * 86400.                    ! convert printout to mm/day
+#ifdef HYDRO_D
+#ifdef MPP_LAND
+
+      call MPI_REDUCE(dtot,gdtot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr)
+      call MPI_REDUCE(dtoa,gdtoa,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr)
+      call MPI_REDUCE(eocn,geocn,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr)
+      call MPI_REDUCE(ebot,gebot,1, MPI_REAL, MPI_SUM, IO_id, HYDRO_COMM_WORLD, ierr)
+      
+      if(my_id .eq. IO_id) then
+        write (*,900)                         &
+          gdtot*zz, gdtoa*zz, -geocn*zz, gebot*zz,     &
+          (gdtot-(-geocn+gebot))*zz
+       endif
+
+#else
+
+        write (*,900)                         &
+          dtot*zz, dtoa*zz, -eocn*zz, ebot*zz,     &
+          (dtot-(-eocn+ebot))*zz
+#endif
+#endif
+  900 format                                       &
+        (3x,'    dh/dt       |dh/dt|        ocnflx        botfix',&
+            '        ghmerror'  &
+!         /3x,4f9.4,2(9x),e14.4)
+        /3x,5(e14.4))
+      
+      return
+      end subroutine gwstep
+      
+      
+      SUBROUTINE SCOPY (NT, ARR, INCA, BRR, INCB)
+!
+!        Copies array ARR to BRR, incrementing by INCA and INCB
+!        respectively, up to a total length of NT words of ARR.
+!        (Same as Cray SCOPY.)
+!
+      real, DIMENSION(*) :: ARR, BRR
+      integer :: ia, nt, inca, incb, ib
+!
+      IB = 1
+      DO 10 IA=1,NT,INCA
+         BRR(IB) = ARR(IA)
+         IB = IB + INCB
+   10 CONTINUE
+!
+      RETURN
+      END SUBROUTINE SCOPY
+
+      
+subroutine trdiagSolve(a,b,c,rhs,x,n)
+
+      implicit none
+      
+      integer,intent(in) :: n
+      real,dimension(n),intent(in) :: a, b, c, rhs
+      real,dimension(n),intent(out) :: x
+      real,dimension(n) :: cp, dp
+      real :: m
+      integer i
+
+! initialize c-prime and d-prime
+        cp(1) = c(1)/b(1)
+        dp(1) = rhs(1)/b(1)
+! solve for vectors c-prime and d-prime
+         do i = 2,n
+           m = b(i)-cp(i-1)*a(i)
+           cp(i) = c(i)/m
+           dp(i) = (rhs(i)-dp(i-1)*a(i))/m
+         enddo
+! initialize x
+         x(n) = dp(n)
+! solve for x from the vectors c-prime and d-prime
+        do i = n-1, 1, -1
+          x(i) = dp(i)-cp(i)*x(i+1)
+        end do
+      
+
+end subroutine trdiagSolve
+      
+      
+subroutine gwSoilFlux(did)
+
+  
+  implicit none
+  
+  integer, intent(in)	:: did
+  
+  
+  real, dimension(rt_domain(did)%ixrt,rt_domain(did)%jxrt) :: smcrel, ztrans, headChange
+  real :: frac, zres
+  integer :: nsoil, i, j, k  
+  
+  gw2d(did)%qsgwrt = 0.
+  gw2d(did)%qdarcyRT = 0.
+  
+! Step 1, collect data
+
+! relative soil moisture content of lowest soil layer (1 = saturated)
+  nsoil = nlst_rt(did)%nsoil
+  smcrel = RT_DOMAIN(did)%SMCRT(:,:,nsoil) / RT_DOMAIN(did)%SMCMAXRT(:,:,nsoil)
+
+! depth of transition zone from lowest soil layer to groundwater head (in cm)
+! postivie ztrans -> head below LSM soil layer 
+! negative ztrans -> head within LSM soil layers
+  ztrans = (rt_domain(did)%elrt + nlst_rt(did)%zsoil8(nsoil)) - gw2d(did)%ho
+  ztrans = ztrans * 100
+  
+  ! darcyGwSoil not defined for ztran = 0
+  where(ztrans == 0) ztrans = -5
+  
+! Step 2, compute flux either up or down
+
+  do j=gw2d(did)%jts, gw2d(did)%jte
+    do i=gw2d(did)%its, gw2d(did)%ite
+      
+        if((ztrans(i,j) > 0) .and. (rt_domain(did)%soiltypRT(i,j) < 13)) then
+        ! if groundwater head < soil layers
+	  call  darcyGwSoil(ztrans(i,j), smcrel(i,j), rt_domain(did)%soiltypRT(i,j), gw2d(did)%qdarcyRT(i,j))
+	  
+	  gw2d(did)%qsgwrt(i,j) = gw2d(did)%qdarcyRT(i,j)
+	  
+	  ! check and correct for mass balance
+	  if(((gw2d(did)%ho(i,j)-gw2d(did)%bot(i,j)) &
+	    *gw2d(did)%poros(i,j)) < (gw2d(did)%qsgwrt(i,j)*gw2d(did)%dt)) then
+	    
+	        gw2d(did)%qdarcyRT(i,j) = 0.
+	        gw2d(did)%qsgwrt(i,j) = 0.
+	        
+	   end if
+	
+	else if(ztrans(i,j) < 0 .and. (rt_domain(did)%soiltypRT(i,j) < 13)) then
+	! if groundwater head > soil layers
+	  zres = -ztrans(i,j)
+	  do k=nsoil,1,-1
+	     
+	     if(zres >= rt_domain(did)%sldpth(k)*100.) then
+	     ! complete filling of a LSM soil layer if groundwater head > layer top
+	       
+! 	       gw2d(did)%qsgwrt(i,j) = (rt_domain(did)%sldpth(k) &
+! 	                               * (RT_DOMAIN(did)%SMCMAXRT(i,j,k) - RT_DOMAIN(did)%SMCRT(i,j,k)) &
+! 				       + gw2d(did)%qsgwrt(i,j)) / gw2d(did)%dt
+				       
+	       RT_DOMAIN(did)%SMCRT(i,j,k) = RT_DOMAIN(did)%SMCMAXRT(i,j,k)
+	       
+	       zres = zres - rt_domain(did)%sldpth(k)*100.
+	       
+	     else
+	     ! partial filling of a soil layer if not completely below groundwater head
+	     
+	       if(zres > (0.5 * rt_domain(did)%sldpth(k)*100.)) then
+		 
+		 frac = zres / (rt_domain(did)%sldpth(k) * 100.)
+	       
+	       
+! 	          gw2d(did)%qsgwrt(i,j) = (rt_domain(did)%sldpth(k) &
+! 	                                * (RT_DOMAIN(did)%SMCMAXRT(i,j,k) - RT_DOMAIN(did)%SMCRT(i,j,k)) &
+! 					* frac + gw2d(did)%qsgwrt(i,j)) / gw2d(did)%dt
+	       
+	          RT_DOMAIN(did)%SMCRT(i,j,k) = RT_DOMAIN(did)%SMCMAXRT(i,j,k) * frac
+	          
+	       end if
+	       
+	     end if
+	  end do
+	end if
+    end do
+  end do
+
+          ! sign convention
+          ! qsgwrt < 0 -> downward flux
+          ! qsgwrt > 0 -> upward flux
+
+! TOcheck Step 3, adapt groundwater head (assuming not time lag for percolation / capillary rise flow)
+
+! 	   modify gw-head before gwstep call with respect to specific yield of the 
+! 	   aquifer and the computed flux (qsgwrt)
+
+  
+ headChange = (-gw2d(did)%qdarcyRT) * gw2d(did)%dt / gw2d(did)%poros
+ gw2d(did)%ho = gw2d(did)%ho + headChange
+  
+end subroutine gwSoilFlux
+      
+subroutine darcyGwSoil(Z, s, soil, q_darcy)
+
+implicit none
+
+INTEGER, INTENT (IN)  :: soil ! soiltype
+
+REAL :: sig_a, sig_b, sig_c
+
+REAL, DIMENSION(9)    :: k_para
+REAL, INTENT (IN)     :: Z, s
+REAL, INTENT (OUT)    :: q_darcy
+real                  :: beta,alpha,q_cap,b,ks,aep,c,q_grav,y,fac
+
+real, dimension(9,12) :: &
+      k_soil = reshape((/&
+0.0778, 3.9939, 0.2913, 4.0801, 0.1386, 4.0500, -12.10, 0.3950, 1.0560,&
+0.0924, 4.8822, 0.2674, 3.8915, 0.1365, 4.3800, -09.00, 0.4100, 0.9380,&
+0.0367, 4.5259, 0.2446, 4.2849, 0.1208, 4.9000, -21.80, 0.4350, 0.2080,&
+0.0101, 3.6896, 0.2153, 4.2765, 0.0887, 5.3000, -78.60, 0.4850, 0.0432,&
+0.0101, 3.6896, 0.2153, 4.2765, 0.0887, 5.3000, -78.60, 0.4850, 0.0432,&
+0.0169, 2.9936, 0.2858, 4.3738, 0.1026, 5.3900, -47.80, 0.4510, 0.0417,&
+0.0271, 4.4743, 0.2587, 3.9055, 0.0920, 7.1200, -29.90, 0.4200, 0.0378,&
+0.0227, 4.3768, 0.2658, 3.8234, 0.0843, 7.7500, -35.60, 0.4770, 0.0102,&
+0.0127, 6.6836, 0.1725, 3.7512, 0.0703, 8.5200, -63.00, 0.4760, 0.0147,&
+0.0530, 9.2423, 0.1859, 3.3688, 0.0728, 10.400, -15.30, 0.4260, 0.0130,&
+0.0165, 5.3972, 0.2479, 3.5549, 0.0641, 10.400, -49.00, 0.4920, 0.0062,&
+0.0200, 6.0106, 0.2474, 3.4788, 0.0622, 11.400, -40.50, 0.4820, 0.0077/),(/9,12/))
+
+
+
+ k_para  = k_soil(:,soil)
+ sig_a   = 1 - exp( -1 * k_para(1) * Z)
+ sig_b   = k_para(2) * Z**k_para(3)
+ sig_c   = k_para(4) * exp( -1 * Z**k_para(5))
+ y       = sig_a/(1  + exp(sig_b * (s - sig_c))) !solving equation (20) in Boogart et al.
+
+ b   =   k_para(6)
+ ks  =   k_para(9)
+ aep =  -k_para(7)
+
+ c      =  2 * b  + 3
+ q_grav = -1 * ks * s**c
+
+! alp is constant from equation (13) of paper
+beta  = 2 + 3 / b
+alpha = 1 + 1.5 /  (beta - 1)
+q_cap = ks * alpha * (aep / Z)**beta
+
+
+q_darcy = y * q_cap + q_grav ![cm/min]
+
+! limit for exteme gradients with q >> saturated hydraulic conductivity
+! if(q_cap > ks) q_cap = ks
+! if(q_grav < -ks) q_grav = -ks
+
+! if(q_darcy > ks) q_darcy = ks
+! if(q_darcy < ks) q_darcy = -ks
+
+
+fac     = 1./6000.
+q_darcy = q_darcy * fac
+q_cap   = q_cap   * fac
+q_grav  = q_grav  * fac
+
+!returns q_darcy in [m/s]
+
+end subroutine darcyGwSoil
+
+
+
+subroutine aggregateQsgw(did)
+
+ 
+
+  implicit none
+
+   integer, intent(in) :: did
+   integer :: j,i, ixxRT, jyyRT, m,n
+   real :: agg
+
+
+    do j=1,rt_domain(did)%jx
+     do i=1,rt_domain(did)%ix
+
+       agg= 0.
+       
+       do m=nlst_rt(did)%aggfactRT-1,0,-1
+         do n=nlst_rt(did)%aggfactRT-1,0,-1
+
+
+	    ixxRT = i * nlst_rt(did)%aggfactRT-n
+	    jyyRT = j * nlst_rt(did)%aggfactRT-m
+
+           
+#ifdef MPP_LAND
+	    if(left_id.ge.0) ixxRT=ixxRT+1
+	    if(down_id.ge.0) jyyRT=jyyRT+1
+#endif
+             agg = agg + gw2d(did)%qdarcyRT(ixxRT, jyyRT)
+           end do
+         end do
+	
+            gw2d(did)%qsgw(i,j) = agg/(nlst_rt(did)%aggfactRT**2)
+       end do
+     end do
+
+
+
+end subroutine aggregateQsgw
+
+! Parallel tridiagonal solver useful for domain decomposed ADI
+! Author(s): Mike Lambert
+! Year: 1996
+! Institution: Lawrence Livermore National Laboratory
+! Publication: Lambert, Rodrigue, and Hewett, "A parallel DSDADI method
+!                      for solution of the steady state diffusion equation",
+!                      Parallel Computing 23 (1997) 2041-2065
+! Ported to MPI by Benjamin Fersch, Karlsruhe Institute of Technology (2013)
+
+#ifdef MPP_LAND
+      subroutine parysolv1(c,b,r,ct,pid,z_pid, &
+	                    xsps, zsps, xdns, zdns)
+
+      implicit none
+
+      integer, intent(in) :: XSPS, &
+                             ZSPS, &
+                             XDNS, &
+                             ZDNS
+                             
+      real, dimension(ZSPS, XSPS), intent(inout) ::  c, &
+                                                     b
+      real	CLK_PER
+      parameter	(CLK_PER = 6.66666667e-9)
+
+      real, dimension(0:ZSPS+1, 0:XSPS+1), intent(inout) ::  r
+      
+      real, dimension(XSPS,2) :: zn, zntmp
+      
+      real, dimension(XSPS)   :: t1, t2, fac
+
+      real :: clockdt, click
+      real :: ct, ti, tf, dt
+
+      integer :: pid, z_pid
+      integer :: i, j, sndr_pid, msg_type, cnt, ackn
+      integer :: sendReq, recvReq
+      
+      integer	ZN_REC
+      parameter	(ZN_REC = 46)
+
+      integer :: source, dest
+#ifdef TIMING
+      dt = clockdt()
+#endif
+
+      cnt = 2*XSPS
+ 
+      if (z_pid .eq. 1) then
+
+! Load (ZSPS,j)th equations into passing arrays.
+        do 10 j = 1, XSPS
+          zntmp(j,1) = b(ZSPS,j)
+          zntmp(j,2) = r(ZSPS,j)
+   10   continue
+
+        
+#ifdef TIMING
+        ti = click()
+#endif
+
+! ! Send (ZSPS,j)th equations.
+! ! Receive (ZSPS+1,j)th equations.
+
+ call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr)
+ call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr)
+ call MPI_IRECV(   zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(sendReq, mpp_status, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+        do 20 j = 1, XSPS
+! Backward elimination in (ZSPS,j)th equations to get
+! r(ZSPS,j).
+        fac(j) = 1./(1. - b(ZSPS,j)*zn(j,1))
+	r(ZSPS,j) = (r(ZSPS,j)-b(ZSPS,j)*zn(j,2))*fac(j)
+! Forward elimination in (ZSPS+1,j)th equations to get
+! r(ZSPS+1,j).
+        r(ZSPS+1,j) = zn(j,2) - zn(j,1)*r(ZSPS,j)
+! Completion of backward elimination to get remaining unknowns.
+        do 30 i = 1, ZSPS-1
+          r(i,j) = r(i,j) - b(i,j)*r(ZSPS,j)
+   30   continue
+   20   continue
+
+      else if (z_pid .le. ZDNS/2) then
+
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Receive (0,j)th equations.
+
+ call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr)
+ call MPI_IRECV(   zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+! Forward elimination in (j,1)th equations.
+	do 40 j = 1, XSPS
+          fac(j) = 1./(1. - c(1,j)*zn(j,1))
+! Check for singular matrix (debugging only)
+          b(1,j) = b(1,j)*fac(j)
+          r(1,j) = (r(1,j) - c(1,j)*zn(j,2))*fac(j)
+! Forward elimination in (ZSPS,j)th equations.
+          fac(j) = 1./(1. - c(ZSPS,j)*b(1,j))
+! Check for singular matrix (debugging only)
+          b(ZSPS,j) = b(ZSPS,j)*fac(j)
+          r(ZSPS,j) = (r(ZSPS,j)-c(ZSPS,j)*r(1,j))*fac(j)
+! Store (0,j)th equations for later recovery of r(0,j).
+          t1(j) = zn(j,1)
+          t2(j) = zn(j,2)
+! Load (ZSPS,j)th equations into passing arrays.
+          zntmp(j,1) = b(ZSPS,j)
+          zntmp(j,2) = r(ZSPS,j)
+   40   continue
+
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Send (ZSPS,j)th equations.
+! ! Receive (ZSPS+1,j)th equations.
+
+ call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr)
+ call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr)
+ call MPI_IRECV(   zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(sendReq, mpp_status, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+        do 50 j = 1, XSPS
+! Backward elimination in (ZSPS,j)th equations.
+          fac(j) = 1./(1. - b(ZSPS,j)*zn(j,1))
+! Check for singular matrix (debugging only)
+          r(ZSPS,j) = (r(ZSPS,j) - b(ZSPS,j)*zn(j,2))*fac(j)
+! Backward elimination in (ZSPS+1,j)th equations.
+          r(ZSPS+1,j) = zn(j,2) - zn(j,1)*r(ZSPS,j)
+! Backward elimination in (ZSPS,j)th equations.
+          r(1,j) = r(1,j) - b(1,j)*r(ZSPS,j)
+! Load (1,j)th equations into passing arrays.
+          zntmp(j,1) = 0.
+          zntmp(j,2) = r(1,j)
+   50   continue
+
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Send (1,j)th equations.
+
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+ call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr)
+ call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr)
+
+        do 60 j = 1, XSPS
+! Backward elimination in (0,j)th equations.
+	r(0,j) = t2(j) - t1(j)*r(1,j)
+        do 70 i = 2, ZSPS-1
+! Completion of forward and backward elimination to get remaining
+! unknowns.
+          r(i,j) = r(i,j) - b(i,j)*r(ZSPS,j) - c(i,j)*r(1,j)
+   70   continue
+   60   continue
+ 
+ call mpi_wait(sendReq, mpp_status, ierr)
+
+ 
+      else if (z_pid .lt. ZDNS) then
+
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Receive (ZSPS+1,j)th equations.
+
+ call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr)
+ call MPI_IRECV(   zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+	do 80 j = 1, XSPS
+! Backward elimination in (ZSPS,j)th equations.
+          fac(j) = 1./(1. - b(ZSPS,j)*zn(j,1))
+! Check for singular matrix (debugging only)
+          c(ZSPS,j) = c(ZSPS,j)*fac(j)
+          r(ZSPS,j) = (r(ZSPS,j)-b(ZSPS,j)*zn(j,2))*fac(j)
+! Backward elimination in (1,j)th equations.
+          fac(j) = 1./(1. - b(1,j)*c(ZSPS,j))
+! Check for singular matrix (debugging only)
+          c(1,j) = c(1,j)*fac(j)
+          r(1,j) = (r(1,j) - b(1,j)*r(ZSPS,j))*fac(j)
+! Store (ZSPS+1,j)th equations for later recovery of
+! r(ZSPS+1,j).
+          t1(j) = zn(j,1)
+          t2(j) = zn(j,2)
+! Load passing arrays with (1,j)th equations.
+          zntmp(j,1) = c(1,j)
+          zntmp(j,2) = r(1,j)
+   80   continue
+
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Send (1,j)th equations.
+! ! Receive (0,j)th equations.
+
+ call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr)
+ call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr)
+ call MPI_IRECV(   zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(sendReq, mpp_status, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+ 
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+	do 90 j = 1, XSPS
+! Forward elimination in (1,j)th equations
+          fac(j) = 1./(1. - c(1,j)*zn(j,1))
+! Check for singular matrix (debugging only)
+          r(1,j) = (r(1,j) - c(1,j)*zn(j,2))*fac(j)
+! Backward elimination in (0,j)th equations.
+          r(0,j) = zn(j,2) - zn(j,1)*r(1,j)
+! Forward elimination in (ZSPS,j)th equations.
+          r(ZSPS,j) = r(ZSPS,j) - c(ZSPS,j)*r(1,j)
+! Load (ZSPS,j)th equations into passing arrays.
+          zntmp(j,1) = 0.
+          zntmp(j,2) = r(ZSPS,j)
+   90   continue
+
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Send (ZSPS,j)th equations.
+
+ call mpi_cart_shift(cartGridComm, rowshift, 1, source, dest, ierr)
+ call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr)
+
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+        do 100 j = 1, XSPS
+! Forward elimination in (ZSPS+1,j)th equations to get
+! r(ZSPS+1,j).
+	r(ZSPS+1,j) = t2(j) - t1(j)*r(ZSPS,j)
+        do 110 i = 2, ZSPS-1
+! Completion of forward and backward elimination to get remaining unknowns.
+          r(i,j) = r(i,j) - c(i,j)*r(1,j) - b(i,j)*r(ZSPS,j)
+  110   continue
+  100   continue
+  
+ call mpi_wait(sendReq, mpp_status, ierr)
+
+      else
+
+! Load (1,j)th equations into passing arrays.
+	do 120 j = 1, XSPS
+          zntmp(j,1) = c(1,j)
+          zntmp(j,2) = r(1,j)
+  120   continue
+
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Send (1,j)th equations.
+! ! Receive (0,j)th equations.
+
+ call mpi_cart_shift(cartGridComm, rowshift, -1, source, dest, ierr)
+ call MPI_ISEND(zntmp, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, sendReq, ierr)
+ call MPI_IRECV(   zn, cnt, MPI_REAL, dest, ZN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(sendReq, mpp_status, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+ 
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+        do 130 j = 1, XSPS
+! Forward elimination in (1,j)th equations to get r(1,j).
+	fac(j) = 1./(1. - c(1,j)*zn(j,1))
+! Check for singular matrix (debugging only)
+        r(1,j) = (r(1,j) - c(1,j)*zn(j,2))*fac(j)
+! Backward elimination in (0,j)th equations to get remaining unknowns.
+        r(0,j) = zn(j,2) - zn(j,1)*r(1,j)
+	do 140 i = 2, ZSPS
+! Completion of forward elimination to get remaining unknowns.
+          r(i,j) = r(i,j) - c(i,j)*r(1,j)
+  140   continue
+  130   continue
+
+      endif
+
+      return
+      end subroutine
+
+
+! Parallel tridiagonal solver useful for domain decomposed ADI
+! Author(s): Mike Lambert
+! Year: 1996
+! Institution: Lawrence Livermore National Laboratory
+! Publication: Lambert, Rodrigue, and Hewett, "A parallel DSDADI method
+!                      for solution of the steady state diffusion equation",
+!                      Parallel Computing 23 (1997) 2041-2065
+! Ported to MPI by Benjamin Fersch, Karlsruhe Institute of Technology (2013)
+
+      subroutine parxsolv1(c,b,r,ct,pid,x_pid, &
+	                    xsps, zsps, xdns, zdns)
+
+      implicit none
+
+       integer, intent(in) :: XSPS, &
+                              ZSPS, &
+                              XDNS, &
+                              ZDNS
+                              
+      real, dimension(ZSPS, XSPS), intent(inout) ::  c, &
+                                                     b
+                                                     
+
+      real, dimension(0:ZSPS+1, 0:XSPS+1), intent(inout) ::  r
+ 
+      real, dimension(ZSPS,2) :: xn, xntmp
+      
+      integer	XN_REC
+      parameter	(XN_REC = 45)
+
+      real, dimension(ZSPS)   :: t1, t2, fac
+      real :: clockdt, click
+      real :: ct, ti, tf, dt
+
+      integer :: pid, x_pid
+      integer :: i, j, sndr_pid, msg_type, cnt, ackn
+      integer :: sendReq, recvReq
+
+      integer :: source, dest
+
+      
+#ifdef TIMING
+      dt = clockdt()
+#endif
+
+      if (x_pid .eq. 1) then
+
+! Load passing (i,XSPS)th equations into passing arrays.
+        do 10 i = 1, ZSPS
+          xntmp(i,1) = b(i,XSPS)
+          xntmp(i,2) = r(i,XSPS)
+   10   continue
+
+        cnt = 2*ZSPS
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Send (i,XSPS)th equations.
+! ! Receive (i,(XSPS + 1))th equations.
+
+ call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr)
+ call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr)
+ call MPI_IRECV(   xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(sendReq, mpp_status, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+        do 20 i = 1, ZSPS
+! Backward elimination in (i,XSPS)th equations to get
+! r(i,XSPS)
+          fac(i) = 1./(1. - b(i,XSPS)*xn(i,1))
+          r(i,XSPS) = (r(i,XSPS)-b(i,XSPS)*xn(i,2))*fac(i)
+! Forward elimination in (i,XSPS+1)th equations to get
+! r(i,XSPS+1)
+          r(i,XSPS+1) = xn(i,2) - xn(i,1)*r(i,XSPS)
+   20   continue
+
+! Completion of backward elimination to get remaining unknowns.
+        do 30 j = 1, XSPS-1
+        do 30 i = 1, ZSPS
+          r(i,j) = r(i,j) - b(i,j)*r(i,XSPS)
+   30   continue
+
+      else if (x_pid .le. XDNS/2) then
+
+        cnt = 2*ZSPS
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Receive (i,0)th equations.
+
+ call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr)
+ call MPI_IRECV(   xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+! Forward elimination in (i,1)th equations of subdomain.
+	do 40 i = 1, ZSPS
+          fac(i) = 1./(1. - c(i,1)*xn(i,1))
+          b(i,1) = b(i,1)*fac(i)
+          r(i,1) = (r(i,1) - c(i,1)*xn(i,2))*fac(i)
+! Forward elimination in (i,XSPS)th equations of subdomain.
+          fac(i) = 1./(1. - c(i,XSPS)*b(i,1))
+          b(i,XSPS) = b(i,XSPS)*fac(i)
+          r(i,XSPS)=(r(i,XSPS)-c(i,XSPS)*r(i,1))*fac(i)
+! Store (i,0)th equations for later recovery of r(i,0).
+          t1(i) = xn(i,1)
+          t2(i) = xn(i,2)
+! Load (i,XSPS)th equations into passing arrays.
+          xntmp(i,1) = b(i,XSPS)
+          xntmp(i,2) = r(i,XSPS)
+   40   continue
+
+        cnt = 2*ZSPS
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Send (i,XSPS)th equations.
+! ! Receive (i,(XSPS + 1))th equations.
+
+ call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr)
+ call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr)
+ call MPI_IRECV(   xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(sendReq, mpp_status, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+        do 50 i = 1, ZSPS
+! Backward elimination in (i,XSPS)th equations.
+          fac(i) = 1./(1. - b(i,XSPS)*xn(i,1))
+          r(i,XSPS) = (r(i,XSPS) - b(i,XSPS)*xn(i,2))*fac(i)
+! Backward elimination in (i,XSPS+1)th equations.
+          r(i,XSPS+1) = xn(i,2) - xn(i,1)*r(i,XSPS)
+! Backward elimination in (i,1)th equations to get r(i,1).
+          r(i,1) = r(i,1) - b(i,1)*r(i,XSPS)
+! Load (i,1)th equations into passing array.
+          xntmp(i,1) = 0.
+          xntmp(i,2) = r(i,1)
+   50   continue
+
+        cnt = 2*ZSPS
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Send (i,1)th equations.
+
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+ call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr)
+ call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr)
+ 
+        do 60 i = 1, ZSPS
+! Backward elimination in (i,0)th equations.
+          r(i,0) = t2(i) - t1(i)*r(i,1)
+   60   continue
+
+! Completion of forward and backward elimination for solution of
+! unknowns.
+        do 70 j = 2, XSPS-1
+        do 70 i = 1, ZSPS
+          r(i,j) = r(i,j) - b(i,j)*r(i,XSPS) - c(i,j)*r(i,1)
+   70   continue
+
+ call mpi_wait(sendReq, mpp_status, ierr)
+
+      else if (x_pid .lt. XDNS) then 
+
+        cnt = 2*ZSPS
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Receive (i,XSPS+1)th equations.
+
+ call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr)
+ call MPI_IRECV(   xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+        do 80 i = 1, ZSPS
+! Backward elimination in (i,XSPS)th equations.
+          fac(i) = 1./(1. - b(i,XSPS)*xn(i,1))
+          c(i,XSPS) = c(i,XSPS)*fac(i)
+          r(i,XSPS) = (r(i,XSPS) - b(i,XSPS)*xn(i,2))*fac(i)
+! Backward elimination in (i,1)th equations.
+          fac(i) = 1./(1. - b(i,1)*c(i,XSPS))
+          c(i,1) = c(i,1)*fac(i)
+          r(i,1) = (r(i,1) - b(i,1)*r(i,XSPS))*fac(i)
+! Store (i,XSPS+1)th equations for later recovery of r(i,XSPS+1).
+          t1(i) = xn(i,1)
+          t2(i) = xn(i,2)
+! Load passing arrays with (i,1)th equations.
+          xntmp(i,1) = c(i,1)
+          xntmp(i,2) = r(i,1)
+   80   continue
+
+        cnt = 2*ZSPS
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Send (i,1)th equations.
+! ! Receive (i,0)th equations.
+ call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr)
+ call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr)
+ call MPI_IRECV(   xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(sendReq, mpp_status, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+        do 90 i = 1, ZSPS
+! Forward elimination in (i,1)th equations
+          fac(i) = 1./(1. - c(i,1)*xn(i,1))
+          r(i,1) = (r(i,1) - c(i,1)*xn(i,2))*fac(i)
+! Backward elimination in (i,0)th equations.
+          r(i,0) = xn(i,2) - xn(i,1)*r(i,1)
+! Forward elimination in (i,XSPS)th equations.
+          r(i,XSPS) = r(i,XSPS) - c(i,XSPS)*r(i,1)
+! Load (i,XSPS)th equations into passing arrays.
+          xntmp(i,1) = 0.
+          xntmp(i,2) = r(i,XSPS)
+   90   continue
+
+        cnt = 2*ZSPS
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Send (i,XSPS)th equations.
+
+ call mpi_cart_shift(cartGridComm, colshift, 1, source, dest, ierr)
+ call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr)
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+! Forward elimination in (i,XSPS)th equations to get
+! r(i,XSPS+1).	
+        do 100 i = 1, ZSPS
+          r(i,XSPS+1) = t2(i) - t1(i)*r(i,XSPS)
+  100   continue
+
+! Completion of forward and backward elimination to get remaining unknowns.
+        do 110 j = 2, XSPS-1
+	do 110 i = 1, ZSPS
+          r(i,j) = r(i,j) - c(i,j)*r(i,1) - b(i,j)*r(i,XSPS)
+  110   continue
+  
+ call mpi_wait(sendReq, mpp_status, ierr)
+
+      else
+
+! Load (i,1)th equations into passing arrays.
+	do 120 i = 1, ZSPS
+          xntmp(i,1) = c(i,1)
+          xntmp(i,2) = r(i,1)
+  120   continue
+
+        cnt = 2*ZSPS
+#ifdef TIMING
+        ti = click()
+#endif
+! ! Send (i,1)th equations.
+! ! Receive (i,0)th equations.
+
+ call mpi_cart_shift(cartGridComm, colshift, -1, source, dest, ierr)
+ call MPI_ISEND(xntmp, cnt, MPI_REAL, dest, XN_REC, cartGridComm, sendReq, ierr)
+ call MPI_IRECV(   xn, cnt, MPI_REAL, dest, XN_REC, cartGridComm, recvReq, ierr)
+ call mpi_wait(sendReq, mpp_status, ierr)
+ call mpi_wait(recvReq, mpp_status, ierr)
+
+#ifdef TIMING
+        tf = click()
+        call add_dt(ct,tf,ti,dt)
+#endif
+
+	do 130 i = 1, ZSPS
+! Forward elimination in (i,1)th equations to get r(i,1).
+          fac(i) = 1./(1. - c(i,1)*xn(i,1))
+          r(i,1) = (r(i,1) - c(i,1)*xn(i,2))*fac(i)
+! Backward elimination in (i,0)th equations to get r(i,0).
+          r(i,0) = xn(i,2) - xn(i,1)*r(i,1)
+  130   continue
+
+! Completion of forward elimination to get remaining unknowns.
+        do 140 j = 2, XSPS
+        do 140 i = 1, ZSPS
+          r(i,j) = r(i,j) - c(i,j)*r(i,1)
+  140   continue
+
+      endif
+
+      return
+      end subroutine
+
+      
+! Parallel tridiagonal solver useful for domain decomposed ADI
+! Author(s): Mike Lambert
+! Year: 1996
+! Institution: Lawrence Livermore National Laboratory
+! Publication: Lambert, Rodrigue, and Hewett, "A parallel DSDADI method
+!                      for solution of the steady state diffusion equation",
+!                      Parallel Computing 23 (1997) 2041-2065
+
+      subroutine sub_n_form(n_xs,n_zs,c,a,b,r,c2,b2,r2,wk,xfac,zfac, &
+                            dpid,dn_subs,dir)
+
+      implicit none
+
+      integer n_xs,n_zs
+
+!  c(,)  -- subdiagonal elements of tridiagonal systems
+!  a(,)  -- diagonal elements of tridiagonal systems
+!  b(,)  -- superdiagonal elements of tridiagonal systems
+!  r(,)  -- right-hand side elements of tridiagonal systems
+!  c2(,) -- front-leg elements of N-systems
+!  b2(,) -- back-leg elements of N-systems
+!  r2(,) -- right-hand side elements of N-systems
+!  wk(,) -- work array with same dimensions as a, b, c, etc.
+      real c(n_zs,n_xs)
+      real a(n_zs,n_xs)
+      real b(n_zs,n_xs)
+      real r(n_zs,n_xs)
+      real c2(n_zs,n_xs)
+      real b2(n_zs,n_xs)
+      real r2(0:n_zs+1,0:n_xs+1)
+      real wk(n_zs,n_xs)
+      real fac
+      real xfac(n_zs)
+      real zfac(n_xs)
+
+      integer dpid,dn_subs,dir
+      integer i, j, XDIR, ZDIR
+      parameter (XDIR = 1, ZDIR = 2)
+
+      if (dir .eq. XDIR) then
+
+! Forward elimination of subdiagonal elements
+	if (dpid .eq. 1) then
+
+          do 10 i = 1, n_zs
+            xfac(i) = 1./a(i,1)
+            c2(i,1) = 0.
+            r2(i,1) = r(i,1)*xfac(i)
+   10     continue
+
+          do 20 j = 2, n_xs
+	  do 20 i = 1, n_zs
+            wk(i,j-1) = b(i,j-1)*xfac(i)
+            xfac(i) = 1./(a(i,j) - c(i,j)*wk(i,j-1))
+            c2(i,j) = 0.
+            r2(i,j) = (r(i,j) - c(i,j)*r2(i,j-1))*xfac(i)
+   20     continue
+
+	  do 40 i = 1, n_zs
+            b2(i,n_xs) = b(i,n_xs)*xfac(i)
+   40     continue
+
+	else
+
+          do 50 i = 1, n_zs
+            xfac(i) = 1./a(i,1)
+            c2(i,1) = c(i,1)*xfac(i)
+	    wk(i,1) = b(i,1)*xfac(i)
+            r2(i,1) = r(i,1)*xfac(i)
+	    xfac(i) = 1./a(i,2)
+	    c2(i,2) = c(i,2)*xfac(i)
+	    r2(i,2) = r(i,2)*xfac(i)
+   50     continue
+
+          do 60 j = 3, n_xs
+	  do 60 i = 1, n_zs
+            wk(i,j-1) = b(i,j-1)*xfac(i)
+            xfac(i) = 1./(a(i,j) - c(i,j)*wk(i,j-1))
+            c2(i,j) = -c(i,j)*c2(i,j-1)*xfac(i)
+            r2(i,j) = (r(i,j) - c(i,j)*r2(i,j-1))*xfac(i)
+   60     continue
+
+	  do 80 i = 1, n_zs
+            b2(i,n_xs) = b(i,n_xs)*xfac(i)
+   80     continue
+
+	endif
+
+! Backward elimination of superdiagonal elements
+        if (dpid .eq. dn_subs) then
+
+          do 90 j = n_xs-1, 2, -1
+          do 90 i = 1, n_zs
+            c2(i,j) = c2(i,j) - wk(i,j)*c2(i,j+1)
+            b2(i,j) = 0.
+            r2(i,j) = r2(i,j) - wk(i,j)*r2(i,j+1)
+   90     continue
+
+	  do 100 i = 1, n_zs
+            fac = 1./(1. - wk(i,1)*c2(i,2))
+            c2(i,1) = c2(i,1)*fac
+            b2(i,1) = 0.
+            r2(i,1) = (r2(i,1) - wk(i,1)*r2(i,2))*fac
+  100     continue
+
+        else 
+
+          do 110 i = 1, n_zs
+            b2(i,n_xs-1) = wk(i,n_xs-1)
+  110     continue
+
+          do 120 j = n_xs-2, 2, -1
+	  do 120 i = 1, n_zs
+            c2(i,j) = c2(i,j) - wk(i,j)*c2(i,j+1)
+            b2(i,j) = -wk(i,j)*b2(i,j+1)
+            r2(i,j) = r2(i,j) - wk(i,j)*r2(i,j+1)
+  120     continue
+
+! If only 2 points in X-direction, do not execute these statements.
+          if (n_xs .gt. 2) then
+	    do 130 i = 1, n_zs
+              fac = 1./(1. - wk(i,1)*c2(i,2))
+              c2(i,1) = c2(i,1)*fac
+              r2(i,1) = (r2(i,1) - wk(i,1)*r2(i,2))*fac
+              b2(i,1) = -wk(i,1)*b2(i,2)*fac
+  130       continue
+	  endif
+
+        endif
+
+      else if (dir .eq. ZDIR) then
+
+! Forward elimination of subdiagonal elements
+	if (dpid .eq. 1) then
+
+          do 140 j = 1, n_xs
+            zfac(j) = 1./a(1,j)
+            c2(1,j) = 0.
+            r2(1,j) = r(1,j)*zfac(j)
+  140     continue
+
+          do 150 i = 2, n_zs
+          do 150 j = 1, n_xs
+            wk(i-1,j) = b(i-1,j)*zfac(j)
+            zfac(j) = 1./(a(i,j) - c(i,j)*wk(i-1,j))
+            c2(i,j) = 0.
+            r2(i,j) = (r(i,j) - c(i,j)*r2(i-1,j))*zfac(j)
+  150     continue
+
+          do 170 j = 1, n_xs
+            b2(n_zs,j) = b(n_zs,j)*zfac(j)
+  170     continue
+
+        else
+
+          do 180 j = 1, n_xs
+            zfac(j) = 1./a(1,j)
+            c2(1,j) = c(1,j)*zfac(j)
+            wk(1,j) = b(1,j)*zfac(j)
+            r2(1,j) = r(1,j)*zfac(j)
+            zfac(j) = 1./a(2,j)
+            c2(2,j) = c(2,j)*zfac(j)
+            r2(2,j) = r(2,j)*zfac(j)
+  180     continue
+
+          do 190 i = 3, n_zs
+          do 190 j = 1, n_xs
+            wk(i-1,j) = b(i-1,j)*zfac(j)
+            zfac(j) = 1./(a(i,j) - c(i,j)*wk(i-1,j))
+            c2(i,j) = -c(i,j)*c2(i-1,j)*zfac(j)
+            r2(i,j) = (r(i,j) - c(i,j)*r2(i-1,j))*zfac(j)
+  190     continue
+
+          do 210 j = 1, n_xs
+            b2(n_zs,j) = b(n_zs,j)*zfac(j)
+  210     continue
+
+        endif
+
+! Backward elimination of superdiagonal elements
+        if (dpid .eq. dn_subs) then
+
+          do 220 j = 1, n_xs
+          do 220 i = n_zs - 1, 2, -1
+            c2(i,j) = c2(i,j) - wk(i,j)*c2(i+1,j)
+            b2(i,j) = 0.
+            r2(i,j) = r2(i,j) - wk(i,j)*r2(i+1,j)
+  220     continue
+
+	  do 230 j = 1, n_xs
+            fac = 1./(1. - wk(1,j)*c2(2,j))
+            c2(1,j) = c2(1,j)*fac
+            b2(1,j) = 0.
+            r2(1,j) = (r2(1,j) - wk(1,j)*r2(2,j))*fac
+  230     continue
+
+        else
+
+          do 240 j = 1, n_xs
+            b2(n_zs-1,j) = wk(n_zs-1,j)
+  240     continue
+
+          do 250 j = 1, n_xs
+          do 250 i = n_zs - 2, 2, -1
+            c2(i,j) = c2(i,j) - wk(i,j)*c2(i+1,j)
+            b2(i,j) = -wk(i,j)*b2(i+1,j)
+            r2(i,j)  = r2(i,j) - wk(i,j)*r2(i+1,j)
+  250     continue
+
+! If only 2 points in Z-direction, do not execute these statements.
+          if (n_zs .gt. 2) then
+	    do 260 j = 1, n_xs
+	      fac = 1./(1. - wk(1,j)*c2(2,j))
+	      c2(1,j) = c2(1,j)*fac
+	      r2(1,j) = (r2(1,j) - wk(1,j)*r2(2,j))*fac
+              b2(1,j) = -wk(1,j)*b2(2,j)*fac
+  260       continue
+	  endif
+
+        endif
+
+! Announce bad direction specifier (debugging only)
+!     else
+!       write(*,*) 'sub_n_form:  What direction?'
+!       stop
+      endif
+
+      return
+      end subroutine
+#endif
+
+! Tridiagonal solver useful for domain decomposed ADI
+! Author(s): Mike Lambert
+! Year: 1996
+! Institution: Lawrence Livermore National Laboratory
+! Publication: Lambert, Rodrigue, and Hewett, "A parallel DSDADI method
+!                      for solution of the steady state diffusion equation",
+!                      Parallel Computing 23 (1997) 2041-2065
+
+      subroutine sub_tri_solv(n_xs,n_zs,c,a,b,r,x,wk,xfac,zfac,dir)
+
+      implicit none
+
+      integer n_xs,n_zs
+
+!  c(,)  -- subdiagonal elements of tridiagonal systems
+!  a(,)  -- diagonal elements of tridiagonal systems
+!  b(,)  -- superdiagonal elements of tridiagonal systems
+!  r(,)  -- right-hand side elements of tridiagonal systems
+!  x(,)  -- solutions
+!  wk(,) -- work array w/ same dimensions as c, a, b, etc.
+
+      real c(n_zs,n_xs)
+      real a(n_zs,n_xs)
+      real b(n_zs,n_xs)
+      real r(n_zs,n_xs)
+      real x(0:n_zs+1,0:n_xs+1)
+      real wk(n_zs,n_xs)
+      real xfac(n_zs)
+      real zfac(n_xs)
+
+      integer dir
+      integer i,j,XDIR,ZDIR
+
+      parameter (XDIR = 1, ZDIR = 2)
+
+      if (dir .eq. XDIR) then
+
+        do 10 i = 1, n_zs
+! Check for need to pivot (debugging only)
+        xfac(i) = 1./a(i,1)
+        x(i,1)  = r(i,1)*xfac(i)
+   10   continue
+
+! Forward subdiagonal elimination
+        do 20 j = 2, n_xs
+	do 20 i = 1, n_zs
+        wk(i,j-1) = b(i,j-1)*xfac(i)
+        xfac(i) = 1./(a(i,j) - c(i,j)*wk(i,j-1))
+! Check for need to pivot (debugging only)
+        x(i,j) = (r(i,j) - c(i,j)*x(i,j-1))*xfac(i)
+   20   continue
+
+! Backsubstitution
+        do 30 j = n_xs - 1, 1, -1
+	do 30 i = 1, n_zs
+        x(i,j)  = x(i,j) - wk(i,j)*x(i,j+1)
+   30   continue
+
+   
+      else if (dir .eq. ZDIR) then
+
+       do j = 1, n_xs
+! Check for need to pivot (debugging only)
+        zfac(j) = 1./a(1,j)
+        x(1,j)  = r(1,j)*zfac(j)
+       end do
+
+! Forward subdiagonal elimination
+      do j = 1, n_xs
+       do i = 2, n_zs
+        wk(i-1,j) = b(i-1,j)*zfac(j)
+        zfac(j) = 1./(a(i,j) - c(i,j)*wk(i-1,j))
+! Check for need to pivot (debugging only)
+        x(i,j) = (r(i,j) - c(i,j)*x(i-1,j))*zfac(j)
+       end do
+      end do
+
+! Backsubstitution
+      do j = 1, n_xs
+       do i = n_zs - 1, 1, -1
+        x(i,j)  =  x(i,j) - wk(i,j)*x(i+1,j)
+       end do
+      end do
+
+! Announce bad direction specifier (debugging only)
+!     else
+!       write(*,*) 'sub_tri_solv:  What direction?'
+!       stop
+      endif
+
+      return
+      end  subroutine
+      
+      
+end module module_gw_gw2d
diff --git a/wrfv2_fire/hydro/Routing/module_lsm_forcing.F b/wrfv2_fire/hydro/Routing/module_lsm_forcing.F
new file mode 100644
index 00000000..0e23d539
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_lsm_forcing.F
@@ -0,0 +1,3291 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+module module_lsm_forcing
+
+#ifdef MPP_LAND
+    use module_mpp_land
+#endif
+    use module_HYDRO_io, only: get_2d_netcdf, get_soilcat_netcdf, get2d_int
+
+implicit none
+#include 
+    integer :: i_forcing 
+character(len=19) out_date
+
+interface read_hydro_forcing
+#ifdef MPP_LAND
+   !yw module procedure read_hydro_forcing_mpp
+   module procedure read_hydro_forcing_mpp1
+#else
+   module procedure read_hydro_forcing_seq
+#endif
+end interface
+
+Contains
+
+  subroutine READFORC_WRF(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar)
+    
+    implicit none
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    character(len=*),                   intent(in)  :: target_date
+    real,             dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc, lai,fpar
+    integer   tlevel
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid
+
+    tlevel = 1
+ 
+    pcp = 0
+    pcpc = 0
+
+    ! Open the NetCDF file.
+    ierr = nf_open(flnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+       write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm)
+       call hydro_stop("In READFORC_WRF() - Problem opening netcdf file")
+    endif
+
+    call get_2d_netcdf_ruc("T2",     ncid, t,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("Q2",     ncid, q,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("U10",    ncid, u,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("V10",    ncid, v,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("PSFC",   ncid, p,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("GLW",    ncid, lw,    ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("SWDOWN", ncid, sw,    ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("RAINC",  ncid, pcpc,  ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("RAINNC", ncid, pcp,   ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("VEGFRA", ncid, fpar,  ix, jx,tlevel, .true., ierr)
+    if(ierr == 0) then
+        if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar/100.
+    endif
+    call get_2d_netcdf_ruc("LAI", ncid, lai,  ix, jx,tlevel, .true., ierr)
+
+    ierr = nf_close(ncid)
+
+!DJG  Add the convective and non-convective rain components (note: conv. comp=0
+!for cloud resolving runs...) 
+!DJG  Note that for WRF these are accumulated values to be adjusted to rates in
+!driver...
+
+    pcp=pcp+pcpc   ! assumes pcpc=0 for resolved convection...
+
+  end subroutine READFORC_WRF
+
+  subroutine read_hrldas_hdrinfo(geo_static_flnm, ix, jx, land_cat, soil_cat)
+    ! Simply return the dimensions of the grid.
+    implicit none
+    character(len=*),          intent(in)  :: geo_static_flnm
+    integer, intent(out) :: ix, jx, land_cat, soil_cat ! dimensions
+
+    integer :: iret, ncid, dimid
+
+    ! Open the NetCDF file.
+    iret = nf_open(geo_static_flnm, NF_NOWRITE, ncid)
+    if (iret /= 0) then
+       write(*,'("Problem opening geo_static file: ''", A, "''")') &
+            trim(geo_static_flnm)
+       call hydro_stop("In read_hrldas_hdrinfo() - Problem opening geo_static file")
+    endif
+
+    iret = nf_inq_dimid(ncid, "west_east", dimid)
+
+    if (iret /= 0) then
+!       print*, "nf_inq_dimid:  west_east"
+       call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid:  west_east problem")
+    endif
+
+    iret = nf_inq_dimlen(ncid, dimid, ix)
+    if (iret /= 0) then
+!       print*, "nf_inq_dimlen:  west_east"
+       call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen:  west_east problem")
+    endif
+
+    iret = nf_inq_dimid(ncid, "south_north", dimid)
+    if (iret /= 0) then
+!       print*, "nf_inq_dimid:  south_north"
+       call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid:  south_north problem")
+    endif
+
+    iret = nf_inq_dimlen(ncid, dimid, jx)
+    if (iret /= 0) then
+ !      print*, "nf_inq_dimlen:  south_north"
+       call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen:  south_north problem")
+    endif
+
+    iret = nf_inq_dimid(ncid, "land_cat", dimid)
+    if (iret /= 0) then
+ !      print*, "nf_inq_dimid:  land_cat"
+       call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid:  land_cat problem")
+    endif
+
+    iret = nf_inq_dimlen(ncid, dimid, land_cat)
+    if (iret /= 0) then
+       print*, "nf_inq_dimlen:  land_cat"
+       call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen:  land_cat problem")
+    endif
+
+    iret = nf_inq_dimid(ncid, "soil_cat", dimid)
+    if (iret /= 0) then
+ !      print*, "nf_inq_dimid:  soil_cat"
+       call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimid:  soil_cat problem")
+    endif
+
+    iret = nf_inq_dimlen(ncid, dimid, soil_cat)
+    if (iret /= 0) then
+ !      print*, "nf_inq_dimlen:  soil_cat"
+       call hydro_stop("In read_hrldas_hdrinfo() - nf_inq_dimlen:  soil_cat problem")
+    endif
+
+    iret = nf_close(ncid)
+
+  end subroutine read_hrldas_hdrinfo
+
+
+
+  subroutine readland_hrldas(geo_static_flnm,ix,jx,land_cat,soil_cat,vegtyp,soltyp, &
+                  terrain,latitude,longitude,SOLVEG_INITSWC)
+    implicit none
+    character(len=*),          intent(in)  :: geo_static_flnm
+    integer,                   intent(in)  :: ix, jx, land_cat, soil_cat,SOLVEG_INITSWC
+    integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp
+    real,    dimension(ix,jx), intent(out) :: terrain, latitude, longitude
+
+    character(len=256) :: units
+    integer :: ierr,i,j,jj
+    integer :: ncid,varid
+    real, dimension(ix,jx) :: xdum
+    integer, dimension(ix,jx) :: vegtyp_inv, soiltyp_inv,xdum_int
+    integer flag ! flag = 1 from wrfsi, flag =2 from WPS.
+    CHARACTER(len=256)       :: var_name
+
+
+    ! Open the NetCDF file.
+    ierr = nf_open(geo_static_flnm, NF_NOWRITE, ncid)
+
+    if (ierr /= 0) then
+       write(*,'("Problem opening geo_static file: ''", A, "''")') trim(geo_static_flnm)
+       call hydro_stop("In readland_hrldas() - Problem opening geo_static file") 
+    endif
+
+    flag = -99 
+    ierr = nf_inq_varid(ncid,"XLAT", varid)
+    flag = 1
+    if(ierr .ne. 0) then
+        ierr = nf_inq_varid(ncid,"XLAT_M", varid)
+        if(ierr .ne. 0) then
+!            write(6,*) "XLAT not found from wrfstatic file. "
+            call hydro_stop("In readland_hrldas() - XLAT not found from wrfstatic file") 
+        endif
+        flag = 2
+    endif
+
+    ! Get Latitude (lat)
+    if(flag .eq. 1) then
+       call get_2d_netcdf("XLAT", ncid, latitude,  units, ix, jx, .TRUE., ierr)
+    else
+      call get_2d_netcdf("XLAT_M", ncid, latitude,  units, ix, jx, .TRUE., ierr)
+    endif
+
+    ! Get Longitude (lon)
+    if(flag .eq. 1) then 
+        call get_2d_netcdf("XLONG", ncid, longitude, units, ix, jx, .TRUE., ierr)
+    else
+        call get_2d_netcdf("XLONG_M", ncid, longitude, units, ix, jx, .TRUE., ierr)
+    endif
+
+    ! Get Terrain (avg)
+    if(flag .eq. 1) then
+       call get_2d_netcdf("HGT", ncid, terrain,   units, ix, jx, .TRUE., ierr)
+    else
+        call get_2d_netcdf("HGT_M", ncid, terrain,   units, ix, jx, .TRUE., ierr)
+    endif
+
+
+    if (SOLVEG_INITSWC.eq.0) then
+!      ! Get Dominant Land Use categories (use)
+!      call get_landuse_netcdf(ncid, xdum ,   units, ix, jx, land_cat)
+!      vegtyp = nint(xdum)
+
+     var_name = "LU_INDEX"
+         call get2d_int(var_name,xdum_int,ix,jx,&
+               trim(geo_static_flnm))
+         vegtyp = xdum_int
+
+      ! Get Dominant Soil Type categories in the top layer (stl)
+      call get_soilcat_netcdf(ncid, xdum ,   units, ix, jx, soil_cat)
+      soltyp = nint(xdum)
+
+    else if (SOLVEG_INITSWC.eq.1) then
+       var_name = "VEGTYP"
+       call get2d_int(var_name,VEGTYP_inv,ix,jx,&
+              trim(geo_static_flnm))
+
+       var_name = "SOILTYP"
+       call get2d_int(var_name,SOILTYP_inv,ix,jx,&
+              trim(geo_static_flnm))
+       do i=1,ix
+         jj=jx
+         do j=1,jx
+           VEGTYP(i,j)=VEGTYP_inv(i,jj)
+           SOLTYP(i,j)=SOILTYP_inv(i,jj)
+           jj=jx-j
+         end do
+       end do
+
+    endif
+
+
+
+    ! Close the NetCDF file
+    ierr = nf_close(ncid)
+    if (ierr /= 0) then
+       print*, "MODULE_NOAHLSM_HRLDAS_INPUT:  READLAND_HRLDAS:  NF_CLOSE"
+       call hydro_stop("In readland_hrldas() - NF_CLOSE problem")
+    endif
+
+    ! Make sure vegtyp and soltyp are consistent when it comes to water points,
+    ! by setting soil category to water when vegetation category is water, and
+    ! vice-versa.
+    where (vegtyp == 28) vegtyp = 16
+    where (vegtyp == 16) soltyp = 14
+    where (soltyp == 14) vegtyp = 16
+
+!DJG test for deep gw function...
+!    where (soltyp <> 14) soltyp = 1
+
+  end subroutine readland_hrldas
+
+
+      subroutine get_2d_netcdf_ruc(var_name,ncid,var, &
+            ix,jx,tlevel,fatal_if_error,ierr)
+          character(len=*), intent(in) :: var_name
+          integer,intent(in) ::  ncid,ix,jx,tlevel
+          real, intent(out):: var(ix,jx)
+          logical, intent(in) :: fatal_if_error
+          integer dims(4), dim_len(4)
+          integer ierr,iret
+          integer varid
+           integer start(4),count(4)
+           data count /1,1,1,1/
+           data start /1,1,1,1/
+          count(1) = ix
+          count(2) = jx
+          start(4) = tlevel
+      ierr = nf_inq_varid(ncid,  var_name,  varid)
+
+      if (ierr /= 0) then
+        if (fatal_IF_ERROR) then
+           print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_ruc:nf_inq_varid ", trim(var_name)
+           call hydro_stop("In get_2d_netcdf_ruc() - nf_inq_varid problem")
+        else
+          return
+        endif
+      endif
+
+      ierr = nf_get_vara_real(ncid, varid, start,count,var)
+      
+
+      return
+      end subroutine get_2d_netcdf_ruc
+
+
+      subroutine get_2d_netcdf_cows(var_name,ncid,var, &
+            ix,jx,tlevel,fatal_if_error,ierr)
+          character(len=*), intent(in) :: var_name
+          integer,intent(in) ::  ncid,ix,jx,tlevel
+          real, intent(out):: var(ix,jx)
+          logical, intent(in) :: fatal_if_error
+          integer ierr, iret
+          integer varid
+          integer start(4),count(4)
+          data count /1,1,1,1/
+          data start /1,1,1,1/
+          count(1) = ix
+          count(2) = jx
+          start(4) = tlevel
+      iret = nf_inq_varid(ncid,  var_name,  varid)
+
+      if (iret /= 0) then
+        if (fatal_IF_ERROR) then
+           print*, "MODULE_NOAHLSM_HRLDAS_INPUT: get_2d_netcdf_cows:nf_inq_varid"
+           call hydro_stop("In get_2d_netcdf_cows() - nf_inq_varid problem")
+        else
+          ierr = iret
+          return
+        endif
+      endif
+      iret = nf_get_vara_real(ncid, varid, start,count,var)
+
+      return
+      end subroutine get_2d_netcdf_cows
+
+
+
+
+
+  subroutine readinit_hrldas(netcdf_flnm, ix, jx, nsoil, target_date, &
+       smc, stc, sh2o, cmc, t1, weasd, snodep)
+    implicit none
+    character(len=*),                intent(in)  :: netcdf_flnm
+    integer,                         intent(in)  :: ix
+    integer,                         intent(in)  :: jx
+    integer,                         intent(in)  :: nsoil
+    character(len=*),                intent(in)  :: target_date
+    real,    dimension(ix,jx,nsoil), intent(out) :: smc
+    real,    dimension(ix,jx,nsoil), intent(out) :: stc
+    real,    dimension(ix,jx,nsoil), intent(out) :: sh2o
+    real,    dimension(ix,jx),       intent(out) :: cmc
+    real,    dimension(ix,jx),       intent(out) :: t1
+    real,    dimension(ix,jx),       intent(out) :: weasd
+    real,    dimension(ix,jx),       intent(out) :: snodep
+
+    character(len=256) :: units
+    character(len=8) :: name
+    integer :: ix_read, jx_read,i,j
+
+    integer :: ierr, ncid, ierr_snodep
+    integer :: idx
+
+    logical :: found_canwat, found_skintemp, found_weasd, found_stemp, found_smois
+
+    ! Open the NetCDF file.
+    ierr = nf_open(netcdf_flnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+       write(*,'("READINIT Problem opening netcdf file: ''", A, "''")') &
+            trim(netcdf_flnm)
+       call hydro_stop("In readinit_hrldas()- Problem opening netcdf file")
+    endif
+
+    call get_2d_netcdf("CANWAT",     ncid, cmc,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SKINTEMP",   ncid, t1,      units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("WEASD",      ncid, weasd,   units, ix, jx, .TRUE., ierr)
+
+    if (trim(units) == "m") then
+       ! No conversion necessary
+    else if (trim(units) == "mm") then
+       ! convert WEASD from mm to m
+       weasd = weasd * 1.E-3
+    else
+       print*, 'units = "'//trim(units)//'"'
+!       print*, "Unrecognized units on WEASD"
+       call hydro_stop("In readinit_hrldas() - Unrecognized units on WEASD")
+    endif
+
+    call get_2d_netcdf("SNODEP",     ncid, snodep,   units, ix, jx, .FALSE., ierr_snodep)
+    call get_2d_netcdf("STEMP_1",    ncid, stc(:,:,1), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("STEMP_2",    ncid, stc(:,:,2), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("STEMP_3",    ncid, stc(:,:,3), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("STEMP_4",    ncid, stc(:,:,4), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SMOIS_1",    ncid, smc(:,:,1), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SMOIS_2",    ncid, smc(:,:,2), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SMOIS_3",    ncid, smc(:,:,3), units,  ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SMOIS_4",    ncid, smc(:,:,4), units,  ix, jx, .TRUE., ierr)
+
+
+    if (ierr_snodep /= 0) then
+       ! Quick assumption regarding snow depth.
+       snodep = weasd * 10.
+    endif
+
+
+!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation...
+       do i=1,ix
+         do j=1,jx
+           if (WEASD(i,j).lt.0.) WEASD(i,j)=0.0  !set lower bound to correct bi-lin interp err...
+           if (snodep(i,j).lt.0.) snodep(i,j)=0.0  !set lower bound to correct bi-lin interp err...
+         end do
+       end do
+
+
+    sh2o = smc
+
+    ierr = nf_close(ncid)
+  end subroutine readinit_hrldas
+
+
+
+
+  subroutine READFORC_HRLDAS(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    character(len=*),                   intent(in)  :: target_date
+    real,             dimension(ix,jx), intent(out) :: t
+    real,             dimension(ix,jx), intent(out) :: q
+    real,             dimension(ix,jx), intent(out) :: u
+    real,             dimension(ix,jx), intent(out) :: v
+    real,             dimension(ix,jx), intent(out) :: p
+    real,             dimension(ix,jx), intent(out) :: lw
+    real,             dimension(ix,jx), intent(out) :: sw
+    real,             dimension(ix,jx), intent(out) :: pcp
+    real,             dimension(ix,jx), intent(inout) :: lai
+    real,             dimension(ix,jx), intent(inout) :: fpar
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid
+
+    ! Open the NetCDF file.
+    ierr = nf_open(trim(flnm), NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+       write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm)
+       call hydro_stop("In READFORC_HRLDAS() - Problem opening netcdf file")
+    endif
+
+    call get_2d_netcdf("T2D",     ncid, t,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("Q2D",     ncid, q,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("U2D",     ncid, u,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("V2D",     ncid, v,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("PSFC",    ncid, p,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("LWDOWN",  ncid, lw,    units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SWDOWN",  ncid, sw,    units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("RAINRATE",ncid, pcp,   units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("VEGFRA",  ncid, fpar,  units, ix, jx, .FALSE., ierr)
+    if (ierr == 0) then
+      if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000)  fpar = fpar * 1.E-2
+    endif
+    call get_2d_netcdf("LAI",     ncid, lai,   units, ix, jx, .FALSE., ierr)
+
+    ierr = nf_close(ncid)
+
+  end subroutine READFORC_HRLDAS
+
+
+
+  subroutine READFORC_DMIP(flnm,ix,jx,var)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    real,       dimension(ix,jx), intent(out)       :: var
+    character(len=13)                               :: head
+    integer                          :: ncols, nrows, cellsize
+    real                             :: xllc, yllc, no_data
+    integer                          :: i,j
+    character(len=256)                              ::junk
+
+    open (77,file=trim(flnm),form="formatted",status="old")
+
+!    read(77,732) head,ncols
+!    read(77,732) head,nrows
+!732        FORMAT(A13,I4)
+!    read(77,733) head,xllc
+!    read(77,733) head,yllc
+!733        FORMAT(A13,F16.9)
+!    read(77,732) head,cellsize
+!    read(77,732) head,no_data
+
+    read(77,*) junk
+    read(77,*) junk
+    read(77,*) junk
+    read(77,*) junk
+    read(77,*) junk
+    read(77,*) junk
+
+    do j=jx,1,-1
+      read(77,*) (var(I,J),I=1,ix)
+    end do
+    close(77)
+
+  end subroutine READFORC_DMIP
+
+
+
+  subroutine READFORC_MDV(flnm,ix,jx,pcp,mmflag,ierr_flg)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    integer,                            intent(out)  :: ierr_flg
+    integer :: it,jew,zsn
+    real,             dimension(ix,jx), intent(out) :: pcp
+
+    character(len=256) :: units
+    integer :: ierr,i,j,i2,j2,varid
+    integer :: ncid,mmflag
+    real, dimension(ix,jx) :: temp
+
+    mmflag = 0   ! flag for units spec. (0=mm, 1=mm/s)
+
+
+!open NetCDF file...
+        ierr_flg = nf_open(flnm, NF_NOWRITE, ncid)
+        if (ierr_flg /= 0) then
+#ifdef HYDRO_D
+          write(*,'("READFORC_MDV Problem opening netcdf file: ''",A,"''")') &
+                trim(flnm)
+#endif
+           return
+        end if
+
+        ierr = nf_inq_varid(ncid,  "precip",  varid)
+        if(ierr /= 0) ierr_flg = ierr
+        if (ierr /= 0) then
+          ierr = nf_inq_varid(ncid,  "precip_rate",  varid)   !recheck variable name...
+          if (ierr /= 0) then
+#ifdef HYDRO_D
+            write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') &
+                 trim(flnm)
+#endif
+          end if
+          ierr_flg = ierr
+          mmflag = 1
+        end if
+        ierr = nf_get_var_real(ncid, varid, pcp)
+        ierr = nf_close(ncid)
+
+        if (ierr /= 0) then
+#ifdef HYDRO_D
+          write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm)
+#endif
+        end if
+
+  end subroutine READFORC_MDV
+
+
+
+  subroutine READFORC_NAMPCP(flnm,ix,jx,pcp,k,product)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    integer,                            intent(in)  :: k
+    character(len=*),                   intent(in)  :: product
+    integer :: it,jew,zsn
+    parameter(it =  496,jew = 449, zsn = 499)   ! domain 1
+!    parameter(it =  496,jew = 74, zsn = 109)   ! domain 2
+    real,             dimension(it,jew,zsn) :: buf
+    real,             dimension(ix,jx), intent(out) :: pcp
+
+    character(len=256) :: units
+    integer :: ierr,i,j,i2,j2,varid
+    integer :: ncid
+    real, dimension(ix,jx) :: temp
+
+!      varname = trim(product)
+
+!open NetCDF file...
+      if (k.eq.1.) then
+        ierr = nf_open(flnm, NF_NOWRITE, ncid)
+        if (ierr /= 0) then
+          write(*,'("READFORC_NAMPCP1 Problem opening netcdf file: ''",A, "''")') &
+              trim(flnm)
+          call hydro_stop("In READFORC_NAMPCP() - Problem opening netcdf file")
+        end if
+
+        ierr = nf_inq_varid(ncid,  trim(product),  varid)
+        ierr = nf_get_var_real(ncid, varid, buf)
+        ierr = nf_close(ncid)
+
+        if (ierr /= 0) then
+          write(*,'("READFORC_NAMPCP2 Problem reading netcdf file: ''", A,"''")') &
+             trim(flnm)
+          call hydro_stop("In READFORC_NAMPCP() - Problem reading netcdf file")
+        end if
+      endif
+#ifdef HYDRO_D
+      print *, "Data read in...",it,ix,jx,k
+#endif
+
+! Extract single time slice from dataset...
+
+      do i=1,ix
+        do j=1,jx
+          pcp(i,j) = buf(k,i,j)
+        end do
+      end do
+
+!      call get_2d_netcdf_ruc("trmm",ncid, pcp, jx, ix,k, .true., ierr)
+
+  end subroutine READFORC_NAMPCP
+
+
+
+
+  subroutine READFORC_COWS(flnm,ix,jx,target_date, t,q,u,p,lw,sw,pcp,tlevel)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    character(len=*),                   intent(in)  :: target_date
+    real,             dimension(ix,jx), intent(out) :: t
+    real,             dimension(ix,jx), intent(out) :: q
+    real,             dimension(ix,jx), intent(out) :: u
+    real,             dimension(ix,jx) :: v
+    real,             dimension(ix,jx), intent(out) :: p
+    real,             dimension(ix,jx), intent(out) :: lw
+    real,             dimension(ix,jx), intent(out) :: sw
+    real,             dimension(ix,jx), intent(out) :: pcp
+    integer   tlevel
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid
+
+    ! Open the NetCDF file.
+    ierr = nf_open(flnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+       write(*,'("READFORC_COWS Problem opening netcdf file: ''", A, "''")') trim(flnm)
+       call hydro_stop("In READFORC_COWS() - Problem opening netcdf file")
+    endif
+
+    call get_2d_netcdf_cows("TA2",     ncid, t,     ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("QV2",     ncid, q,     ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("WSPD10",  ncid, u,     ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("PRES",    ncid, p,     ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("GLW",     ncid, lw,    ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("RSD",     ncid, sw,    ix, jx,tlevel, .TRUE., ierr)
+    call get_2d_netcdf_cows("RAIN",    ncid, pcp,   ix, jx,tlevel, .TRUE., ierr)
+!yw   call get_2d_netcdf_cows("V2D",     ncid, v,     ix, jx,tlevel, .TRUE., ierr)
+
+    ierr = nf_close(ncid)
+
+  end subroutine READFORC_COWS
+
+
+
+
+  subroutine READFORC_RUC(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp)
+    
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    character(len=*),                   intent(in)  :: target_date
+    real,             dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc
+    integer   tlevel
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid
+
+    tlevel = 1
+
+    ! Open the NetCDF file.
+    ierr = nf_open(flnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+       write(*,'("READFORC_RUC Problem opening netcdf file: ''", A, "''")') trim(flnm)
+       call hydro_stop("In READFORC_RUC() - Problem opening netcdf file")
+    endif
+
+    call get_2d_netcdf_ruc("T2",     ncid, t,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("Q2",     ncid, q,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("U10",    ncid, u,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("V10",    ncid, v,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("PSFC",   ncid, p,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("GLW",    ncid, lw,    ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("SWDOWN", ncid, sw,    ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("RAINC",  ncid, pcpc,  ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("RAINNC", ncid, pcp,   ix, jx,tlevel, .true., ierr)
+
+    ierr = nf_close(ncid)
+    
+
+!DJG  Add the convective and non-convective rain components (note: conv. comp=0
+!for cloud resolving runs...) 
+!DJG  Note that for RUC these are accumulated values to be adjusted to rates in
+!driver...
+
+    pcp=pcp+pcpc   ! assumes pcpc=0 for resolved convection...
+
+  end subroutine READFORC_RUC
+
+
+
+
+  subroutine READSNOW_FORC(flnm,ix,jx,weasd,snodep)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    real,             dimension(ix,jx), intent(out) :: weasd
+    real,             dimension(ix,jx), intent(out) :: snodep
+    real, dimension(ix,jx) :: tmp
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid,i,j
+
+    ! Open the NetCDF file.
+
+    ierr = nf_open(flnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+       write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm)
+       call hydro_stop("In READSNOW_FORC() - Problem opening netcdf file")
+    endif
+
+    call get_2d_netcdf("WEASD",  ncid, tmp,   units, ix, jx, .FALSE., ierr)
+    if (ierr /= 0) then
+         call get_2d_netcdf("SNOW",  ncid, tmp,   units, ix, jx, .FALSE., ierr)
+         if (ierr == 0) then
+            units = "mm"
+            print *, "read WEASD from wrfoutput ...... "
+            weasd = tmp * 1.E-3
+         endif
+    else
+         weasd = tmp
+         if (trim(units) == "m") then
+            ! No conversion necessary
+         else if (trim(units) == "mm") then
+            ! convert WEASD from mm to m
+            weasd = weasd * 1.E-3
+         endif
+    endif
+
+    if (ierr /= 0) then
+       print *, "!!!!! NO WEASD present in input file...initialize to 0."
+    endif
+
+    call get_2d_netcdf("SNODEP",     ncid, tmp,   units, ix, jx, .FALSE., ierr)
+    if (ierr /= 0) then
+       ! Quick assumption regarding snow depth.
+       call get_2d_netcdf("SNOWH",     ncid, tmp,   units, ix, jx, .FALSE., ierr)
+       if(ierr .eq. 0) then
+            print *, "read snow depth from wrfoutput ... " 
+            snodep = tmp
+       endif
+    else
+       snodep = tmp
+    endif
+
+    if (ierr /= 0) then
+       ! Quick assumption regarding snow depth.
+!yw       snodep = weasd * 10.
+       where(snodep .lt. weasd) snodep = weasd*10  !set lower bound to correct bi-lin interp err...
+    endif
+
+!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation...
+       where(snodep .lt. 0) snodep = 0
+       where(weasd .lt. 0) weasd = 0
+    ierr = nf_close(ncid)
+
+  end subroutine READSNOW_FORC
+
+    subroutine get2d_hrldas(inflnm,ix,jx,nsoil,smc,stc,sh2ox,cmc,t1,weasd,snodep)
+          implicit none
+          integer :: iret,varid,ncid,ix,jx,nsoil,ierr
+          real,dimension(ix,jx):: weasd,snodep,cmc,t1
+          real,dimension(ix,jx,nsoil):: smc,stc,sh2ox
+          character(len=*), intent(in) :: inflnm
+          character(len=256)::   units
+          iret = nf_open(trim(inflnm), NF_NOWRITE, ncid)
+          if(iret .ne. 0 )then
+              write(6,*) "Error: failed to open file :",trim(inflnm)
+             call hydro_stop("In get2d_hrldas() - failed to open file")
+          endif
+
+          call get2d_hrldas_real("CMC",     ncid, cmc,     ix, jx)
+          call get2d_hrldas_real("TSKIN",   ncid, t1,      ix, jx)
+          call get2d_hrldas_real("SWE",      ncid, weasd,   ix, jx)
+          call get2d_hrldas_real("SNODEP",     ncid, snodep,   ix, jx)
+
+    call get2d_hrldas_real("SOIL_T_1",    ncid, stc(:,:,1),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_2",    ncid, stc(:,:,2),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_3",    ncid, stc(:,:,3),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_4",    ncid, stc(:,:,4),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_5",    ncid, stc(:,:,5),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_6",    ncid, stc(:,:,6),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_7",    ncid, stc(:,:,7),  ix, jx)
+    call get2d_hrldas_real("SOIL_T_8",    ncid, stc(:,:,8),  ix, jx)
+
+    call get2d_hrldas_real("SOIL_M_1",    ncid, SMC(:,:,1),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_2",    ncid, SMC(:,:,2),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_3",    ncid, SMC(:,:,3),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_4",    ncid, SMC(:,:,4),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_5",    ncid, SMC(:,:,5),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_6",    ncid, SMC(:,:,6),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_7",    ncid, SMC(:,:,7),  ix, jx)
+    call get2d_hrldas_real("SOIL_M_8",    ncid, SMC(:,:,8),  ix, jx)
+
+    call get2d_hrldas_real("SOIL_W_1",    ncid, SH2OX(:,:,1),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_2",    ncid, SH2OX(:,:,2),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_3",    ncid, SH2OX(:,:,3),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_4",    ncid, SH2OX(:,:,4),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_5",    ncid, SH2OX(:,:,5),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_6",    ncid, SH2OX(:,:,6),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_7",    ncid, SH2OX(:,:,7),  ix, jx)
+    call get2d_hrldas_real("SOIL_W_8",    ncid, SH2OX(:,:,8),  ix, jx)
+
+          iret = nf_close(ncid)
+         return
+      end subroutine get2d_hrldas
+
+      subroutine get2d_hrldas_real(var_name,ncid,out_buff,ix,jx)
+          implicit none
+          integer ::iret,varid,ncid,ix,jx
+          real out_buff(ix,jx)
+          character(len=*), intent(in) :: var_name
+          iret = nf_inq_varid(ncid,trim(var_name),  varid)
+          iret = nf_get_var_real(ncid, varid, out_buff)
+         return
+      end subroutine get2d_hrldas_real
+
+    subroutine read_stage4(flnm,IX,JX,pcp)
+        integer IX,JX,ierr,ncid,i,j
+        real pcp(IX,JX),buf(ix,jx)
+        character(len=*),  intent(in)  :: flnm
+        character(len=256) :: units
+
+        ierr = nf_open(flnm, NF_NOWRITE, ncid)
+
+        if(ierr .ne. 0) then
+            call hydro_stop("In read_stage4() - failed to open stage4 file.")
+        endif
+
+        call get_2d_netcdf("RAINRATE",ncid, buf,   units, ix, jx, .TRUE., ierr)
+        ierr = nf_close(ncid)
+        do j = 1, jx
+        do i = 1, ix
+            if(buf(i,j) .lt. 0) then
+                 buf(i,j) = pcp(i,j)
+            end if
+        end do
+        end do
+        pcp = buf
+        return
+    END subroutine read_stage4
+
+
+
+
+ subroutine read_hydro_forcing_seq( &
+       indir,olddate,hgrid, &
+       ix,jx,forc_typ,snow_assim,  & 
+       T2,q2x,u,v,pres,xlong,short,prcp1,&
+       lai,fpar,snodep,dt,k,prcp_old)
+! This subrouting is going to read different forcing.
+   implicit none
+   ! in variable
+   character(len=*) :: olddate,hgrid,indir
+   character(len=256) :: filename
+   integer :: ix,jx,forc_typ,k,snow_assim  ! k is time loop
+   real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,&
+          prcpnew,weasd,snodep,prcp0,prcp2,prcp_old
+   real ::  dt, wrf_dt
+   ! tmp variable
+   character(len=256) :: inflnm, inflnm2, product
+   integer  :: i,j,mmflag,ierr_flg
+   real,dimension(ix,jx):: lai,fpar
+   character(len=4) nwxst_t
+   logical :: fexist
+
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             ".LDASIN_DOMAIN"//hgrid
+
+!!!DJG... Call READFORC_(variable) Subroutine for forcing data...
+!!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!)
+   if(FORC_TYP.eq.1) then
+!!Create forcing data filename...
+        call geth_newdate(out_date,olddate,nint(dt))
+        inflnm = trim(indir)//"/"//&
+             out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//&
+             ".LDASIN_DOMAIN"//hgrid
+
+        inquire (file=trim(inflnm), exist=fexist)
+        if ( .not. fexist ) then
+           print*, "no forcing data found", inflnm
+           call hydro_stop("In read_hydro_forcing_seq")
+        endif
+
+      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+   end if
+
+
+
+
+!!!DJG HRLDAS Forcing with minute format filename (NOTE: precip must be in mm/s!!!)
+   if(FORC_TYP.eq.2) then
+!!Create forcing data filename...
+        call geth_newdate(out_date,olddate,nint(dt))
+        inflnm = trim(indir)//"/"//&
+             out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//&
+             out_date(15:16)//".LDASIN_DOMAIN"//hgrid
+        inquire (file=trim(inflnm), exist=fexist)
+        if ( .not. fexist ) then
+           print*, "no forcing data found", inflnm
+           call hydro_stop("In read_hydro_forcing_seq() - no forcing data found")
+        endif
+      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+   end if
+
+
+
+
+
+!!!DJG WRF Output File Direct Ingest Forcing...
+     if(FORC_TYP.eq.3) then
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+             "wrfout_d0"//hgrid//"_"//&
+             olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//&
+             "_"//olddate(12:13)//":00:00"
+
+        inquire (file=trim(inflnm), exist=fexist)
+        if ( .not. fexist ) then
+           print*, "no forcing data found", inflnm
+           call hydro_stop("In read_hydro_forcing_seq() - no forcing data found")
+        endif
+
+        do i_forcing = 1, int(24*3600/dt)
+           wrf_dt = i_forcing*dt
+           call geth_newdate(out_date,olddate,nint(wrf_dt))
+           inflnm2 = trim(indir)//"/"//&
+             "wrfout_d0"//hgrid//"_"//&
+             out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//&
+             "_"//out_date(12:13)//":00:00"
+           inquire (file=trim(inflnm2), exist=fexist)
+           if (fexist ) goto 991
+        end do
+991     continue
+
+        if(.not. fexist) then
+           write(6,*) "FATAL ERROR: could not find file ",trim(inflnm2)
+           call hydro_stop("In read_hydro_forcing_seq() - could not find file ")
+        endif
+#ifdef HYDRO_D
+           print*, "read WRF forcing data: ", trim(inflnm)
+           print*, "read WRF forcing data: ", trim(inflnm2)
+#endif
+       CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+          PRES,XLONG,SHORT,PRCPnew,lai,fpar)
+       CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+          PRES,XLONG,SHORT,prcp0,lai,fpar)
+        PRCP1=(PRCPnew-prcp0)/wrf_dt   !Adjustment to convert accum to rate...(mm/s)
+
+     end if
+
+!!!DJG CONSTant, idealized forcing...
+     if(FORC_TYP.eq.4) then
+! Impose a fixed diurnal cycle...
+! assumes model timestep is 1 hr
+! assumes K=1 is 12z (Ks or ~ sunrise)
+! First Precip...
+       IF (K.EQ.2) THEN
+       PRCP1 =25.4/3600.0      !units mm/s  (Simulates 1"/hr for first time step...)
+!       PRCP1 =0./3600.0      !units mm/s  (Simulates <1"/hr for first 10 hours...)
+       ELSEIF (K.GT.1) THEN
+!        PRCP1 =0./3600.0      !units mm/s
+!       ELSE
+         PRCP1 = 0.
+       END IF
+!       PRCP1 = 0.
+!       PRCP1 =10./3600.0      !units mm/s
+! Other Met. Vars...
+       T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       Q2X = 0.01
+       U = 1.0
+       V = 1.0
+       PRES = 100000.0
+       XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+
+!      print *, "PCP", PRCP1
+
+    end if
+
+!!!DJG  Idealized Met. w/ Specified Precip. Forcing Data...(Note: input precip units here are in 'mm/hr')
+!   This option uses hard-wired met forcing EXCEPT precipitation which is read in
+!   from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc'
+!
+    if(FORC_TYP.eq.5) then
+! Standard Met. Vars...
+       T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       Q2X = 0.01
+       U = 1.0
+       V = 1.0
+       PRES = 100000.0
+       XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+
+!Get specified precip....
+!!!VIP, dimensions of grid are currently hardwired in input subroutine!!!
+!       product = "trmm"
+!       inflnm = trim(indir)//"/"//"sat_domain1.nc"
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+                olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+                olddate(15:16)//".PRECIP_FORCING.nc"
+        inquire (file=trim(inflnm), exist=fexist)
+        if ( .not. fexist ) then
+           print*, "no specified precipitation data found", inflnm
+           call hydro_stop("In read_hydro_forcing_seq() - no specified precipitation data found")
+        endif
+
+       PRCP1 = 0.
+       PRCP_old = PRCP1
+
+#ifdef HYDRO_D
+      print *, "Opening supplemental precipitation forcing file...",inflnm
+#endif
+       CALL READFORC_MDV(inflnm,IX,JX,   &
+          PRCP2,mmflag,ierr_flg)
+
+!If radar or spec. data is ok use if not, skip to original NARR data...
+      IF (ierr_flg.eq.0) then   ! use spec. precip
+!Convert units if necessary
+        IF (mmflag.eq.0) then    !Convert pcp grid to units of mm/s...
+           PRCP1=PRCP2/DT     !convert from mm to mm/s
+#ifdef HYDRO_D
+           print*, "Supplemental pcp is accumulated pcp/dt. "  
+#endif
+        else
+           PRCP1=PRCP2   !assumes PRCP2 is in mm/s 
+#ifdef HYDRO_D
+           print*, "Supplemental pcp is rate. "  
+#endif
+        END IF  ! Endif mmflag
+      ELSE   ! either stop or default to original forcing data...
+#ifdef HYDRO_D
+        print *,"Current RADAR precip data not found !!! Using previous available file..."
+#endif
+        PRCP1 = PRCP_old
+      END IF  ! Endif ierr_flg
+
+! Loop through data to screen for plausible values
+       do i=1,ix
+         do j=1,jx
+           if (PRCP1(i,j).lt.0.) PRCP1(i,j)= PRCP_old(i,j)
+           if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889  !set max pcp intens = 500 mm/h
+         end do
+       end do
+
+    end if
+
+
+
+
+
+!!!DJG HRLDAS Forcing with hourly format filename with specified precipitation forcing...
+!   This option uses HRLDAS-formatted met forcing EXCEPT precipitation which is read in
+!   from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc'
+
+   if(FORC_TYP.eq.6) then
+
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             ".LDASIN_DOMAIN"//hgrid
+
+        inquire (file=trim(inflnm), exist=fexist)
+
+        if ( .not. fexist ) then
+          do i_forcing = 1, nint(12*3600/dt)
+           call geth_newdate(out_date,olddate,nint(i_forcing*dt))
+           inflnm = trim(indir)//"/"//&
+              olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+              olddate(15:16)//".LDASIN_DOMAIN"//hgrid
+           inquire (file=trim(inflnm), exist=fexist)
+            if(fexist) goto 201
+          end do
+201       continue
+        endif
+
+
+        if ( .not. fexist ) then
+#ifdef HYDRO_D
+           print*, "no ATM forcing data found at this time", inflnm
+#endif
+        else
+#ifdef HYDRO_D
+           print*, "reading forcing data at this time", inflnm
+#endif
+           
+           CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+                PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+           PRCP_old = PRCP1  ! This assigns new precip to last precip as a fallback for missing data...
+        endif
+
+
+!Get specified precip....
+!!!VIP, dimensions of grid are currently hardwired in input subroutine!!!
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+                 olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+                 olddate(15:16)//".PRECIP_FORCING.nc"
+        inquire (file=trim(inflnm), exist=fexist)
+#ifdef HYDRO_D
+        if(fexist) then 
+            print*, "using specified pcp forcing: ",trim(inflnm)
+        else
+            print*, "no specified pcp forcing: ",trim(inflnm)
+        endif
+#endif
+        if ( .not. fexist ) then
+           prcp1 = PRCP_old ! for missing pcp data use analysis/model input 
+        else
+           CALL READFORC_MDV(inflnm,IX,JX,   &
+              PRCP2,mmflag,ierr_flg)
+!If radar or spec. data is ok use if not, skip to original NARR data...
+           if(ierr_flg .ne. 0) then
+#ifdef HYDRO_D
+               print*, "WARNING: pcp reading problem: ", trim(inflnm)
+#endif
+               PRCP1=PRCP_old
+           else
+               PRCP1=PRCP2   !assumes PRCP2 is in mm/s
+               IF (mmflag.eq.0) then    !Convert pcp grid to units of mm/s...
+                PRCP1=PRCP2/DT     !convert from mm to mm/s
+               END IF  ! Endif mmflag
+#ifdef HYDRO_D
+               print*, "replace pcp successfully! ",trim(inflnm)
+#endif
+           endif
+        endif
+
+
+! Loop through data to screen for plausible values
+       where(PRCP1 .lt. 0) PRCP1=PRCP_old
+       where(PRCP1 .gt. 10 ) PRCP1= PRCP_old 
+       do i=1,ix
+         do j=1,jx
+           if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0
+           if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889  !set max pcp intens = 500 mm/h
+         end do
+       end do
+
+   end if
+
+
+!!!! FORC_TYP 7: uses WRF forcing data plus additional pcp forcing.
+
+   if(FORC_TYP.eq.7) then
+
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+             "wrfout_d0"//hgrid//"_"//&
+             olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//&
+             "_"//olddate(12:13)//":00:00"
+
+        inquire (file=trim(inflnm), exist=fexist)
+
+
+        if ( .not. fexist ) then
+#ifdef HYDRO_D
+           print*, "no forcing data found", inflnm
+#endif
+        else
+           do i_forcing = 1, int(24*3600/dt)
+              wrf_dt = i_forcing*dt
+              call geth_newdate(out_date,olddate,nint(wrf_dt))
+              inflnm2 = trim(indir)//"/"//&
+                "wrfout_d0"//hgrid//"_"//&
+                out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//&
+                "_"//out_date(12:13)//":00:00"
+              inquire (file=trim(inflnm2), exist=fexist)
+              if (fexist ) goto 992
+           end do
+992        continue
+
+#ifdef HYDRO_D
+           print*, "read WRF forcing data: ", trim(inflnm)
+           print*, "read WRF forcing data: ", trim(inflnm2)
+#endif
+           CALL READFORC_WRF(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+                   PRES,XLONG,SHORT,PRCPnew,lai,fpar)
+           CALL READFORC_WRF(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+                   PRES,XLONG,SHORT,prcp0,lai,fpar)
+           PRCP1=(PRCPnew-prcp0)/wrf_dt   !Adjustment to convert accum to rate...(mm/s)
+           PRCP_old = PRCP1
+        endif
+
+!Get specified precip....
+!!!VIP, dimensions of grid are currently hardwired in input subroutine!!!
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+                 olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+                 olddate(15:16)//".PRECIP_FORCING.nc"
+        inquire (file=trim(inflnm), exist=fexist)
+#ifdef HYDRO_D
+        if(fexist) then
+            print*, "using specified pcp forcing: ",trim(inflnm)
+        else
+            print*, "no specified pcp forcing: ",trim(inflnm)
+        endif
+#endif
+        if ( .not. fexist ) then
+           prcp1 = PRCP_old ! for missing pcp data use analysis/model input 
+        else
+           CALL READFORC_MDV(inflnm,IX,JX,   &
+              PRCP2,mmflag,ierr_flg)
+!If radar or spec. data is ok use if not, skip to original NARR data...
+           if(ierr_flg .ne. 0) then
+#ifdef HYDRO_D
+               print*, "WARNING: pcp reading problem: ", trim(inflnm)
+#endif
+               PRCP1=PRCP_old
+           else
+               PRCP1=PRCP2   !assumes PRCP2 is in mm/s
+               IF (mmflag.eq.0) then    !Convert pcp grid to units of mm/s...
+#ifdef HYDRO_D
+                 write(6,*) "using supplemental pcp time interval ", DT
+#endif
+                PRCP1=PRCP2/DT     !convert from mm to mm/s
+               else
+#ifdef HYDRO_D
+                 write(6,*) "using supplemental pcp rates "
+#endif
+               END IF  ! Endif mmflag
+#ifdef HYDRO_D
+               print*, "replace pcp successfully! ",trim(inflnm)
+#endif
+           endif
+        endif
+
+
+! Loop through data to screen for plausible values
+       where(PRCP1 .lt. 0) PRCP1=PRCP_old
+       where(PRCP1 .gt. 10 ) PRCP1= PRCP_old ! set maximum to be 500 mm/h
+       where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h
+   end if
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!The other forcing data types below here are obsolete and left for reference...
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!DJG HRLDAS Single Input with Multiple Input Times File Forcing...
+!     if(FORC_TYP.eq.6) then
+!!Create forcing data filename...
+!     if (len_trim(range) == 0) then
+!      inflnm = trim(indir)//"/"//&
+!             startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//&
+!             olddate(15:16)//".LDASIN_DOMAIN"//hgrid//"_multiple"
+!!        "MET_LIS_CRO_2D_SANTEE_LU_1KM."//&
+!!        ".156hrfcst.radar"
+!     else
+!     endif
+!     CALL READFORC_HRLDAS_mult(inflnm,IX,JX,OLDDATE,T2,Q2X,U,   &
+!          PRES,XLONG,SHORT,PRCP1,K)
+!
+!!       IF (K.GT.0.AND.K.LT.10) THEN
+!!         PRCP1 = 10.0/3600.0            ! units mm/s
+!!          PRCP1 = 0.254/3600.0
+!!       ELSE
+!!         PRCP1 = 0.
+!!       END IF
+!      endif
+
+
+
+!!!!!DJG  NARR Met. w/ NARR Precip. Forcing Data...
+!! Assumes standard 3-hrly NARR data has been resampled to NDHMS grid...
+!! Assumes one 3hrly time-step per forcing data file 
+!! Input precip units here are in 'mm' accumulated over 3 hrs...
+!    if(FORC_TYP.eq.7) then  !NARR Met. w/ NARR Precip.
+!!!Create forcing data filename...
+!      if (len_trim(range) == 0) then
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid
+!      else
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid//"."//trim(range)
+!      endif
+!      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+!          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+!      PRCP1=PRCP1/(3.0*3600.0)  ! convert from 3hr accum to mm/s which is what NDHMS expects    
+!    end if  !NARR Met. w/ NARR Precip.
+
+
+
+
+
+
+!!!!DJG  NARR Met. w/ Specified Precip. Forcing Data...
+!    if(FORC_TYP.eq.8) then !NARR Met. w/ Specified Precip.
+!
+!!Check to make sure if Noah time step is 3 hrs as is NARR...
+!
+!        PRCP_old = PRCP1
+!
+!     if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then   !if/then 3 hr check
+!!!Create forcing data filename...
+!      if (len_trim(range) == 0) then
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid
+!!        startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//&
+!!        ".48hrfcst.ncf"
+!      else
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid//"."//trim(range)
+!      endif
+!      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+!          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+!!       PRCP1=PRCP1/(3.0*3600.0)     !NARR 3hrly precip product in mm
+!       PRCP1=PRCP1     !NAM model data in mm/s
+!    end if    !3 hr check
+!
+!
+!!Get spec. precip....
+!! NAM Remote sensing...
+!!!!VIP, dimensions of grid are currently hardwired in input subroutine!!!
+!!       product = "trmm"
+!!       inflnm = trim(indir)//"/"//"sat_domain1.nc"
+!!!       inflnm = trim(indir)//"/"//"sat_domain2.nc"
+!!       PRCP1 = 0.
+!!       CALL READFORC_NAMPCP(inflnm,IX,JX,   &
+!!          PRCP2,K,product)
+!!       ierr_flg = 0
+!!       mmflag = 0
+!!!Convert pcp grid to units of mm/s...
+!!       PRCP1=PRCP1/(3.0*3600.0)     !3hrly precip product
+!
+!!Read from filelist (NAME HE...,others)...
+!!        if (K.eq.1) then
+!!          open(unit=93,file="filelist.txt",form="formatted",status="old")
+!!        end if
+!!        read (93,*) filename
+!!        inflnm = trim(indir)//"/"//trim(filename)
+!!
+!!
+!!Front Range MDV Radar...
+!
+!!         inflnm = "/ptmp/weiyu/rt_2008/radar_obs/"//&
+!!             inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//&
+!!              olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!!              olddate(15:16)//"_radar.nc"
+!!              olddate(15:16)//"_chill.nc"
+!
+!!        inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/Big_Thomp_04/"//&
+!!       inflnm = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//&
+!!             inflnm = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/20080809/"//&
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//&
+!!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!!             olddate(15:16)//"00_Pcp60min.nc"
+!!             olddate(15:16)//"00_Pcp30min.nc"
+!!             olddate(15:16)//"00_30min.nc"
+!             olddate(15:16)//"00_Pcp5min.nc"
+!!              olddate(15:16)//"_chill.nc"
+!
+!!         inflnm = "/d2/hydrolab/HRLDAS/forcing/COWS/"//&
+!!             olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//&
+!!             olddate(15:16)//"00_Pcp5min.nc"
+!!              olddate(15:16)//"00_5.nc"
+!
+!!         inflnm = ""     ! use this for NAM frxst runs with 30 min time-step
+!!
+!
+!
+!!        if (K.le.6) then   ! use for 30min nowcast...
+!!          if (K.eq.1) then
+!!             open(unit=94,file="start_file.txt",form="formatted",status="replace")
+!!!             inflnm2 = "/d2/hydrolab/HRLDAS/forcing/FRNG/RT_2008/radar_obs/"//&
+!!             inflnm2 = "/d3/hydrolab/HRLDAS_forcing/FRNG_research/"//&
+!!             olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//&
+!!             olddate(15:16)//"00_"
+!!             close(94)
+!!             nwxst_t = "5"! calc minutes from timestep and convert to char...
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!          if (K.eq.2) then
+!!             nwxst_t = "10" ! calc minutes from timestep and convert to char...
+!!             open(unit=94,file="start_file.txt",form="formatted",status="old")
+!!             read (94,*) inflnm2
+!!             close(94)
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!          if (K.eq.3) then
+!!             nwxst_t = "15" ! calc minutes from timestep and convert to char...
+!!             open(unit=94,file="start_file.txt",form="formatted",status="old")
+!!             read (94,*) inflnm
+!!             close(94)
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!          if (K.eq.4) then
+!!             nwxst_t = "20" ! calc minutes from timestep and convert to char...
+!!             open(unit=94,file="start_file.txt",form="formatted",status="old")
+!!             read (94,*) inflnm
+!!             close(94)
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!          if (K.eq.5) then
+!!             nwxst_t = "25" ! calc minutes from timestep and convert to char...
+!!             open(unit=94,file="start_file.txt",form="formatted",status="old")
+!!             read (94,*) inflnm
+!!             close(94)
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!          if (K.eq.6) then
+!!             nwxst_t = "30" ! calc minutes from timestep and convert to char...
+!!             open(unit=94,file="start_file.txt",form="formatted",status="old")
+!!             read (94,*) inflnm
+!!             close(94)
+!!             inflnm = trim(inflnm2)//trim(nwxst_t)//".nc"
+!!          end if
+!!        else
+!!          inflnm = ""     ! use this for NAM frxst runs with 30 min time-step
+!!        end if
+!
+!!             olddate(1:4)//olddate(6:7)//olddate(9:10)//"_"//olddate(12:13)//&
+!!             olddate(15:16)//"00_Pcp30minMerge.nc"
+!        
+!       CALL READFORC_MDV(inflnm,IX,JX,   &
+!          PRCP2,mmflag,ierr_flg)
+!
+!!If radar or spec. data is ok use if not, skip to original NARR data...
+!      IF (ierr_flg.eq.0) then   ! use spec. precip
+!         PRCP1=PRCP2   !assumes PRCP2 is in mm/s
+!!Convert units if necessary
+!        IF (mmflag.eq.0) then    !Convert pcp grid to units of mm/s...
+!          PRCP1=PRCP2/DT     !convert from mm to mm/s 
+!        END IF  ! Endif mmflag
+!      ELSE   ! either stop or default to original forcing data...
+!        PRCP1 = PRCP_old
+!      END IF  ! Endif ierr_flg
+!
+!! Loop through data to screen for plausible values
+!       do i=1,ix
+!         do j=1,jx
+!           if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0
+!           if (PRCP1(i,j).gt.0.0555) PRCP1(i,j)=0.0555  !set max pcp intens = 200 mm/h
+!!          PRCP1(i,j) = 0.
+!!          PRCP1(i,j) = 0.02   !override w/ const. precip for gw testing only...
+!         end do
+!       end do
+!
+!!        if (K.eq.1) then  ! quick dump for site specific precip...
+!          open(unit=94,file="Christman_accumpcp.txt",form="formatted",status="new")
+!        end if
+!
+!        
+!    end if  !NARR Met. w/ Specified Precip.
+
+
+
+
+
+!!!!DJG  NLDAS Met. w/ NLDAS Precip. Forcing Data...
+!! Assumes standard hrly NLDAS data has been resampled to NDHMS grid...
+!! Assumes one 1-hrly time-step per forcing data file
+!! Input precip units here are in 'mm' accumulated over 1 hr...
+!    if(FORC_TYP.eq.9) then  !NLDAS Met. w/ NLDAS Precip.
+!!!Create forcing data filename...
+!      if (len_trim(range) == 0) then
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!!Use this for minute forcing...             olddate(15:16)//".LDASIN_DOMAIN"//hgrid
+!             ".LDASIN_DOMAIN"//hgrid
+!      else
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid//"."//trim(range)
+!      endif
+!      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+!          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+!      PRCP1=PRCP1/(1.0*3600.0)  ! convert hourly NLDAS hourly accum pcp to mm/s which is what NDHMS expects
+!    end if  !NLDAS Met. w/ NLDAS Precip.
+
+
+
+
+
+!!!!DJG  NARR Met. w/ DMIP Precip. & Temp. Forcing Data...
+!    if(FORC_TYP.eq.10) then  ! If/Then for DMIP forcing data...
+!!Check to make sure if Noah time step is 3 hrs as is NARR...
+!
+!     if(K.eq.1.OR.(MOD((K-1)*INT(DT),10800)).eq.0) then   !if/then 3 hr check
+!!!Create forcing data filename...
+!      if (len_trim(range) == 0) then
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid
+!!        startdate(1:4)//startdate(6:7)//startdate(9:10)//startdate(12:13)//&
+!!        ".48hrfcst.ncf"
+!      else
+!        inflnm = trim(indir)//"/"//&
+!             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!             ".LDASIN_DOMAIN"//hgrid//"."//trim(range)
+!      endif
+!      CALL READFORC_HRLDAS(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+!          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+!          PRCP1=PRCP1/(3.0*3600.0)  ! convert to mm/s which is what HRLDAS expects    
+!    end if    !3 hr check
+!
+!!Get DMIP Precip...
+!!       inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/PRECIP_HRAP/precip_finished"//"/"//&
+!       inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/PRECIP_HRAP"//"/"//&
+!           "proj.xmrg"//&
+!           olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//&
+!           "z.asc"
+!        PRCP1 = 0.
+!        CALL READFORC_DMIP(inflnm,IX,JX,PRCP1)
+!          PRCP1 = PRCP1 / 100.0    ! Convert from native hundreths of mm to mm
+!!       IF (K.LT.34) THEN
+!!        PRCP1 = 5.0/3600.0            ! units mm/s
+!!!       ELSE
+!!!         PRCP1 = 0.
+!!       END IF
+!
+!!Get DMIP Temp...
+!!       inflnm = "/d3/gochis/HRLDAS/forcing/DMIP_II/TEMP_HRAP/tair_finished"//"/"//&
+!       inflnm = "/d2/hydrolab/HRLDAS/forcing/DMIP_II_AmerR/TEMP_HRAP"//"/"//&
+!           "proj.tair"//&
+!           olddate(6:7)//olddate(9:10)//olddate(1:4)//olddate(12:13)//&
+!           "z.asc"
+!        CALL READFORC_DMIP(inflnm,IX,JX,T2)
+!          T2 = (5./9.)*(T2-32.0) + 273.15         !Convert from deg F to deg K
+!
+!    end if  !End if for DMIP forcing data...
+!
+!
+!
+!! : add reading forcing precipitation data
+!!       ywinflnm = "/ptmp/weiyu/hrldas/v2/st4"//"/"//&
+!!            olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+!!            ".LDASIN_DOMAIN2"
+!!       call read_stage4(ywinflnm,IX,JX,PRCP1)
+!!end yw
+!
+!
+!!!!DJG Check for snow data assimilation...
+
+   if (SNOW_ASSIM .eq. 1) then
+
+! Every 24 hours, update the snow field from analyses.
+     if(forc_typ .ne. 3 .or. forc_typ .ne. 6) then
+         if ( OLDDATE(12:13) == "00") then
+            CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP)
+         endif
+     else
+        CALL READSNOW_FORC(inflnm,IX,JX,WEASD,SNODEP)
+     endif
+
+   end if
+
+#ifdef PRECIP_DOUBLE
+#ifdef HYDRO_D
+   print*,'PRECIP DOUBLE'
+#endif
+   PRCP1 = PRCP1 * 2.0
+#endif 
+
+ end subroutine read_hydro_forcing_seq
+
+
+#ifdef MPP_LAND
+    subroutine mpp_readland_hrldas(geo_static_flnm,&
+          ix,jx,land_cat,soil_cat,& 
+          vegtyp,soltyp,terrain,latitude,longitude,&
+          global_nx,global_ny,SOLVEG_INITSWC)
+    implicit none
+    character(len=*),          intent(in)  :: geo_static_flnm
+    integer,                   intent(in)  :: ix, jx, land_cat, soil_cat, &
+              global_nx,global_ny,SOLVEG_INITSWC
+    integer, dimension(ix,jx), intent(out) :: vegtyp, soltyp
+    real,    dimension(ix,jx), intent(out) :: terrain, latitude, longitude
+    real, dimension(global_nx,global_ny) ::g_terrain, g_latitude, g_longitude
+    integer, dimension(global_nx,global_ny) :: g_vegtyp, g_soltyp
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid,varid
+    real, dimension(ix,jx) :: xdum
+    integer flag ! flag = 1 from wrfsi, flag =2 from WPS.
+     if(my_id.eq.IO_id) then
+        CALL READLAND_HRLDAS(geo_static_flnm,global_nx,  &
+               global_ny,LAND_CAT,SOIL_CAT,      &
+               g_VEGTYP,g_SOLTYP,g_TERRAIN,g_LATITUDE,g_LONGITUDE, SOLVEG_INITSWC)
+     end if
+  ! distribute the data to computation node.
+     call mpp_land_bcast_int1(LAND_CAT)
+     call mpp_land_bcast_int1(SOIL_CAT)
+     call decompose_data_int(g_VEGTYP,VEGTYP)
+     call decompose_data_int(g_SOLTYP,SOLTYP)
+     call decompose_data_real(g_TERRAIN,TERRAIN)
+     call decompose_data_real(g_LATITUDE,LATITUDE)
+     call decompose_data_real(g_LONGITUDE,LONGITUDE)
+      return 
+      end subroutine mpp_readland_hrldas
+
+
+      subroutine MPP_READSNOW_FORC(flnm,ix,jx,OLDDATE,weasd,snodep,&
+                 global_nX, global_ny)
+        implicit none
+
+        character(len=*),                   intent(in)  :: flnm,OLDDATE
+        integer,  intent(in)  :: ix, global_nx,global_ny
+        integer,                            intent(in)  :: jx
+        real,             dimension(ix,jx), intent(out) :: weasd
+        real,             dimension(ix,jx), intent(out) :: snodep
+
+        real,dimension(global_nX, global_ny):: g_weasd, g_snodep
+    
+        character(len=256) :: units
+        integer :: ierr
+        integer :: ncid,i,j
+
+        if(my_id .eq. IO_id) then
+          CALL READSNOW_FORC(trim(flnm),global_nX, global_ny,g_WEASD,g_SNODEP)
+       endif
+       call decompose_data_real(g_WEASD,WEASD)
+       call decompose_data_real(g_SNODEP,SNODEP)
+
+        return 
+        end  subroutine MPP_READSNOW_FORC
+
+      subroutine MPP_DEEPGW_HRLDAS(ix,jx,in_SMCMAX,&
+                 global_nX, global_ny,nsoil,out_SMC,out_SH2OX)
+        implicit none
+
+        integer,  intent(in)  :: ix,global_nx,global_ny
+        integer,  intent(in)  :: jx,nsoil
+        real,             dimension(ix,jx), intent(in) :: in_smcmax
+        real,             dimension(ix,jx,nsoil), intent(out) :: out_smc,out_sh2ox
+
+        real,dimension(global_nX, global_ny,nsoil):: g_smc, g_sh2ox
+        real,dimension(global_nX, global_ny):: g_smcmax
+        integer   :: i,j,k
+       
+
+          call write_IO_real(in_smcmax,g_smcmax)  ! get global grid of smcmax
+
+#ifdef HYDRO_D
+          write (*,*) "In deep GW...", nsoil
+#endif
+
+!loop to overwrite soils to saturation...
+        do i=1,global_nx
+         do j=1,global_ny
+            g_smc(i,j,1:NSOIL) = g_smcmax(i,j)
+            g_sh2ox(i,j,1:NSOIL) = g_smcmax(i,j)
+         end do 
+        end do 
+
+!decompose global grid to parallel tiles...
+       do k=1,nsoil
+        call decompose_data_real(g_smc(:,:,k),out_smc(:,:,k))
+        call decompose_data_real(g_sh2ox(:,:,k),out_sh2ox(:,:,k))
+       end do
+
+        return 
+        end  subroutine MPP_DEEPGW_HRLDAS
+
+
+ subroutine read_hydro_forcing_mpp( &
+       indir,olddate,hgrid, &
+       ix,jx,forc_typ,snow_assim,  & 
+       T2,q2x,u,v,pres,xlong,short,prcp1,&
+       lai,fpar,snodep,dt,k,prcp_old)
+! This subrouting is going to read different forcing.
+
+
+   implicit none
+   ! in variable
+   character(len=*) :: olddate,hgrid,indir
+   character(len=256) :: filename
+   integer :: ix,jx,forc_typ,k,snow_assim  ! k is time loop
+   real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,&
+          prcpnew,lai,fpar,snodep,prcp_old
+   real ::  dt
+   ! tmp variable
+   character(len=256) :: inflnm, product
+   integer  :: i,j,mmflag
+   real,dimension(global_nx,global_ny):: g_T2,g_Q2X,g_U,g_V,g_XLONG, &
+             g_SHORT,g_PRCP1,g_PRES,g_lai,g_snodep,g_prcp_old, g_fpar
+   integer flag 
+   
+
+
+     call write_io_real(T2,g_T2)
+     call write_io_real(Q2X,g_Q2X)
+     call write_io_real(U,g_U)
+     call write_io_real(V,g_V)
+     call write_io_real(XLONG,g_XLONG)
+     call write_io_real(SHORT,g_SHORT)
+     call write_io_real(PRCP1,g_PRCP1)
+     call write_io_real(PRES,g_PRES)
+     call write_io_real(prcp_old,g_PRCP_old)
+
+     call write_io_real(lai,g_lai)
+     call write_io_real(fpar,g_fpar)
+     call write_io_real(snodep,g_snodep)
+
+
+
+   if(my_id .eq. IO_id) then
+      call read_hydro_forcing_seq( &
+        indir,olddate,hgrid,&
+        global_nx,global_ny,forc_typ,snow_assim,  &
+        g_T2,g_q2x,g_u,g_v,g_pres,g_xlong,g_short,g_prcp1,&
+        g_lai,g_fpar,g_snodep,dt,k,g_prcp_old)
+#ifdef HYDRO_D
+     write(6,*) "finish read forcing,olddate ",olddate
+#endif
+   end if
+
+     call decompose_data_real(g_T2,T2)
+     call decompose_data_real(g_Q2X,Q2X)
+     call decompose_data_real(g_U,U)
+     call decompose_data_real(g_V,V)
+     call decompose_data_real(g_XLONG,XLONG)
+     call decompose_data_real(g_SHORT,SHORT)
+     call decompose_data_real(g_PRCP1,PRCP1)
+     call decompose_data_real(g_prcp_old,prcp_old)
+     call decompose_data_real(g_PRES,PRES)
+
+     call decompose_data_real(g_lai,lai)
+     call decompose_data_real(g_fpar,fpar)
+     call decompose_data_real(g_snodep,snodep)
+
+     return
+   end subroutine read_hydro_forcing_mpp
+#endif
+
+  integer function nfeb_yw(year)
+    !
+    ! Compute the number of days in February for the given year.
+    !
+    implicit none
+    integer, intent(in) :: year ! Four-digit year
+
+    nfeb_yw = 28 ! By default, February has 28 days ...
+    if (mod(year,4).eq.0) then
+       nfeb_yw = 29  ! But every four years, it has 29 days ...
+       if (mod(year,100).eq.0) then
+          nfeb_yw = 28  ! Except every 100 years, when it has 28 days ...
+          if (mod(year,400).eq.0) then
+             nfeb_yw = 29  ! Except every 400 years, when it has 29 days ...
+             if (mod(year,3600).eq.0) then
+                nfeb_yw = 28  ! Except every 3600 years, when it has 28 days.
+             endif
+          endif
+       endif
+    endif
+  end function nfeb_yw
+
+  subroutine geth_newdate (ndate, odate, idt)
+    implicit none
+
+    !  From old date ("YYYY-MM-DD HH:MM:SS.ffff" or "YYYYMMDDHHMMSSffff") and 
+    !  delta-time, compute the new date.
+
+    !  on entry     -  odate  -  the old hdate.
+    !                  idt    -  the change in time
+
+    !  on exit      -  ndate  -  the new hdate.
+
+    integer, intent(in)           :: idt
+    character (len=*), intent(out) :: ndate
+    character (len=*), intent(in)  :: odate
+
+    !  Local Variables
+
+    !  yrold    -  indicates the year associated with "odate"
+    !  moold    -  indicates the month associated with "odate"
+    !  dyold    -  indicates the day associated with "odate"
+    !  hrold    -  indicates the hour associated with "odate"
+    !  miold    -  indicates the minute associated with "odate"
+    !  scold    -  indicates the second associated with "odate"
+
+    !  yrnew    -  indicates the year associated with "ndate"
+    !  monew    -  indicates the month associated with "ndate"
+    !  dynew    -  indicates the day associated with "ndate"
+    !  hrnew    -  indicates the hour associated with "ndate"
+    !  minew    -  indicates the minute associated with "ndate"
+    !  scnew    -  indicates the second associated with "ndate"
+
+    !  mday     -  a list assigning the number of days in each month
+
+    !  i        -  loop counter
+    !  nday     -  the integer number of days represented by "idt"
+    !  nhour    -  the integer number of hours in "idt" after taking out
+    !              all the whole days
+    !  nmin     -  the integer number of minutes in "idt" after taking out
+    !              all the whole days and whole hours.
+    !  nsec     -  the integer number of minutes in "idt" after taking out
+    !              all the whole days, whole hours, and whole minutes.
+
+    integer :: newlen, oldlen
+    integer :: yrnew, monew, dynew, hrnew, minew, scnew, frnew
+    integer :: yrold, moold, dyold, hrold, miold, scold, frold
+    integer :: nday, nhour, nmin, nsec, nfrac, i, ifrc
+    logical :: opass
+    character (len=10) :: hfrc
+    character (len=1) :: sp
+    logical :: punct
+    integer :: yrstart, yrend, mostart, moend, dystart, dyend
+    integer :: hrstart, hrend, mistart, miend, scstart, scend, frstart
+    integer :: units
+    integer, dimension(12) :: mday = (/31,28,31,30,31,30,31,31,30,31,30,31/)
+!yw    integer nfeb_yw   
+
+    ! Determine if odate is "YYYY-MM-DD_HH ... " or "YYYYMMDDHH...."
+    if (odate(5:5) == "-") then
+       punct = .TRUE.
+    else
+       punct = .FALSE.
+    endif
+
+    !  Break down old hdate into parts
+
+    hrold = 0
+    miold = 0
+    scold = 0
+    frold = 0
+    oldlen = LEN(odate)
+    if (punct) then
+       yrstart = 1
+       yrend = 4
+       mostart = 6
+       moend = 7
+       dystart = 9
+       dyend = 10
+       hrstart = 12
+       hrend = 13
+       mistart = 15
+       miend = 16
+       scstart = 18
+       scend = 19
+       frstart = 21
+       select case (oldlen)
+       case (10)
+          ! Days
+          units = 1
+       case (13)
+          ! Hours
+          units = 2
+       case (16)
+          ! Minutes
+          units = 3
+       case (19)
+          ! Seconds
+          units = 4
+       case (21)
+          ! Tenths
+          units = 5
+       case (22)
+          ! Hundredths
+          units = 6
+       case (23)
+          ! Thousandths
+          units = 7
+       case (24)
+          ! Ten thousandths
+          units = 8
+       case default
+          write(*,*) 'ERROR: geth_newdate:  odd length: #'//trim(odate)//'#'
+          call hydro_stop("In geth_newdate() - error odd length") 
+       end select
+
+       if (oldlen.ge.11) then
+          sp = odate(11:11)
+       else
+          sp = ' '
+       end if
+
+    else
+
+       yrstart = 1
+       yrend = 4
+       mostart = 5
+       moend = 6
+       dystart = 7
+       dyend = 8
+       hrstart = 9
+       hrend = 10
+       mistart = 11
+       miend = 12
+       scstart = 13
+       scend = 14
+       frstart = 15
+
+       select case (oldlen)
+       case (8)
+          ! Days
+          units = 1
+       case (10)
+          ! Hours
+          units = 2
+       case (12)
+          ! Minutes
+          units = 3
+       case (14)
+          ! Seconds
+          units = 4
+       case (15)
+          ! Tenths
+          units = 5
+       case (16)
+          ! Hundredths
+          units = 6
+       case (17)
+          ! Thousandths
+          units = 7
+       case (18)
+          ! Ten thousandths
+          units = 8
+       case default
+          write(*,*) 'ERROR: geth_newdate:  odd length: #'//trim(odate)//'#'
+           call hydro_stop("In geth_newdate() - error odd length")
+       end select
+    endif
+
+    !  Use internal READ statements to convert the CHARACTER string
+    !  date into INTEGER components.
+
+    read(odate(yrstart:yrend),  '(i4)') yrold
+    read(odate(mostart:moend),  '(i2)') moold
+    read(odate(dystart:dyend), '(i2)') dyold
+    if (units.ge.2) then
+       read(odate(hrstart:hrend),'(i2)') hrold
+       if (units.ge.3) then
+          read(odate(mistart:miend),'(i2)') miold
+          if (units.ge.4) then
+             read(odate(scstart:scend),'(i2)') scold
+             if (units.ge.5) then
+                read(odate(frstart:oldlen),*) frold
+             end if
+          end if
+       end if
+    end if
+
+    !  Set the number of days in February for that year.
+
+    mday(2) = nfeb_yw(yrold)
+
+    !  Check that ODATE makes sense.
+
+    opass = .TRUE.
+
+    !  Check that the month of ODATE makes sense.
+
+    if ((moold.gt.12).or.(moold.lt.1)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Month of ODATE = ', moold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the day of ODATE makes sense.
+
+    if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Day of ODATE = ', dyold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the hour of ODATE makes sense.
+
+    if ((hrold.gt.23).or.(hrold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Hour of ODATE = ', hrold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the minute of ODATE makes sense.
+
+    if ((miold.gt.59).or.(miold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Minute of ODATE = ', miold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the second of ODATE makes sense.
+
+    if ((scold.gt.59).or.(scold.lt.0)) then
+#ifdef HYDRO_D
+       write(*,*) 'GETH_NEWDATE:  Second of ODATE = ', scold
+#endif
+       opass = .FALSE.
+    end if
+
+    !  Check that the fractional part  of ODATE makes sense.
+    if (.not.opass) then
+       write(*,*) 'Crazy ODATE: ', odate(1:oldlen), oldlen
+       call hydro_stop("In geth_newdate")
+    end if
+
+    !  Date Checks are completed.  Continue.
+
+
+    !  Compute the number of days, hours, minutes, and seconds in idt
+
+    if (units.ge.5) then !idt should be in fractions of seconds
+       ifrc = oldlen-(frstart)+1
+       ifrc = 10**ifrc
+       nday   = abs(idt)/(86400*ifrc)
+       nhour  = mod(abs(idt),86400*ifrc)/(3600*ifrc)
+       nmin   = mod(abs(idt),3600*ifrc)/(60*ifrc)
+       nsec   = mod(abs(idt),60*ifrc)/(ifrc)
+       nfrac = mod(abs(idt), ifrc)
+    else if (units.eq.4) then  !idt should be in seconds
+       ifrc = 1
+       nday   = abs(idt)/86400 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),86400)/3600
+       nmin   = mod(abs(idt),3600)/60
+       nsec   = mod(abs(idt),60)
+       nfrac  = 0
+    else if (units.eq.3) then !idt should be in minutes
+       ifrc = 1
+       nday   = abs(idt)/1440 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),1440)/60
+       nmin   = mod(abs(idt),60)
+       nsec   = 0
+       nfrac  = 0
+    else if (units.eq.2) then !idt should be in hours
+       ifrc = 1
+       nday   = abs(idt)/24 ! integer number of days in delta-time
+       nhour  = mod(abs(idt),24)
+       nmin   = 0
+       nsec   = 0
+       nfrac  = 0
+    else if (units.eq.1) then !idt should be in days
+       ifrc = 1
+       nday   = abs(idt)    ! integer number of days in delta-time
+       nhour  = 0
+       nmin   = 0
+       nsec   = 0
+       nfrac  = 0
+    else
+       write(*,'(''GETH_NEWDATE: Strange length for ODATE: '', i3)') &
+            oldlen
+       write(*,*) '#'//odate(1:oldlen)//'#'
+       call hydro_stop("In geth_newdate")
+    end if
+
+    if (idt.ge.0) then
+
+       frnew = frold + nfrac
+       if (frnew.ge.ifrc) then
+          frnew = frnew - ifrc
+          nsec = nsec + 1
+       end if
+
+       scnew = scold + nsec
+       if (scnew .ge. 60) then
+          scnew = scnew - 60
+          nmin  = nmin + 1
+       end if
+
+       minew = miold + nmin
+       if (minew .ge. 60) then
+          minew = minew - 60
+          nhour  = nhour + 1
+       end if
+
+       hrnew = hrold + nhour
+       if (hrnew .ge. 24) then
+          hrnew = hrnew - 24
+          nday  = nday + 1
+       end if
+
+       dynew = dyold
+       monew = moold
+       yrnew = yrold
+       do i = 1, nday
+          dynew = dynew + 1
+          if (dynew.gt.mday(monew)) then
+             dynew = dynew - mday(monew)
+             monew = monew + 1
+             if (monew .gt. 12) then
+                monew = 1
+                yrnew = yrnew + 1
+                ! If the year changes, recompute the number of days in February
+                mday(2) = nfeb_yw(yrnew)
+             end if
+          end if
+       end do
+
+    else if (idt.lt.0) then
+
+       frnew = frold - nfrac
+       if (frnew .lt. 0) then
+          frnew = frnew + ifrc
+          nsec = nsec + 1
+       end if
+
+       scnew = scold - nsec
+       if (scnew .lt. 00) then
+          scnew = scnew + 60
+          nmin  = nmin + 1
+       end if
+
+       minew = miold - nmin
+       if (minew .lt. 00) then
+          minew = minew + 60
+          nhour  = nhour + 1
+       end if
+
+       hrnew = hrold - nhour
+       if (hrnew .lt. 00) then
+          hrnew = hrnew + 24
+          nday  = nday + 1
+       end if
+
+       dynew = dyold
+       monew = moold
+       yrnew = yrold
+       do i = 1, nday
+          dynew = dynew - 1
+          if (dynew.eq.0) then
+             monew = monew - 1
+             if (monew.eq.0) then
+                monew = 12
+                yrnew = yrnew - 1
+                ! If the year changes, recompute the number of days in February
+                mday(2) = nfeb_yw(yrnew)
+             end if
+             dynew = mday(monew)
+          end if
+       end do
+    end if
+
+    !  Now construct the new mdate
+
+    newlen = LEN(ndate)
+
+    if (punct) then
+
+       if (newlen.gt.frstart) then
+          write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew
+          write(hfrc,'(i10)') frnew+1000000000
+          ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10)
+
+       else if (newlen.eq.scend) then
+          write(ndate(1:scend),19) yrnew, monew, dynew, hrnew, minew, scnew
+19        format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2)
+
+       else if (newlen.eq.miend) then
+          write(ndate,16) yrnew, monew, dynew, hrnew, minew
+16        format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2)
+
+       else if (newlen.eq.hrend) then
+          write(ndate,13) yrnew, monew, dynew, hrnew
+13        format(i4,'-',i2.2,'-',i2.2,'_',i2.2)
+
+       else if (newlen.eq.dyend) then
+          write(ndate,10) yrnew, monew, dynew
+10        format(i4,'-',i2.2,'-',i2.2)
+
+       end if
+
+    else
+
+       if (newlen.gt.frstart) then
+          write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew
+          write(hfrc,'(i10)') frnew+1000000000
+          ndate = ndate(1:scend)//'.'//hfrc(31-newlen:10)
+
+       else if (newlen.eq.scend) then
+          write(ndate(1:scend),119) yrnew, monew, dynew, hrnew, minew, scnew
+119       format(i4,i2.2,i2.2,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.miend) then
+          write(ndate,116) yrnew, monew, dynew, hrnew, minew
+116       format(i4,i2.2,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.hrend) then
+          write(ndate,113) yrnew, monew, dynew, hrnew
+113       format(i4,i2.2,i2.2,i2.2)
+
+       else if (newlen.eq.dyend) then
+          write(ndate,110) yrnew, monew, dynew
+110       format(i4,i2.2,i2.2)
+
+       end if
+
+    endif
+
+    if (punct .and. (oldlen.ge.11) .and. (newlen.ge.11)) ndate(11:11) = sp
+
+  end subroutine geth_newdate
+
+
+ subroutine read_hydro_forcing_mpp1( &
+       indir,olddate,hgrid, &
+       ix,jx,forc_typ,snow_assim,  & 
+       T2,q2x,u,v,pres,xlong,short,prcp1,&
+       lai,fpar,snodep,dt,k,prcp_old)
+! This subrouting is going to read different forcing.
+   implicit none
+   ! in variable
+   character(len=*) :: olddate,hgrid,indir
+   character(len=256) :: filename
+   integer :: ix,jx,forc_typ,k,snow_assim  ! k is time loop
+   real,dimension(ix,jx):: T2,q2x,u,v,pres,xlong,short,prcp1,&
+          prcpnew,weasd,snodep,prcp0,prcp2,prcp_old
+   real ::  dt, wrf_dt
+   ! tmp variable
+   character(len=256) :: inflnm, inflnm2, product
+   integer  :: i,j,mmflag,ierr_flg
+   real,dimension(ix,jx):: lai,fpar
+   character(len=4) nwxst_t
+   logical :: fexist
+
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             ".LDASIN_DOMAIN"//hgrid
+
+!!!DJG... Call READFORC_(variable) Subroutine for forcing data...
+!!!DJG HRLDAS Format Forcing with hour format filename (NOTE: precip must be in mm/s!!!)
+   if(FORC_TYP.eq.1) then
+!!Create forcing data filename...
+        call geth_newdate(out_date,olddate,nint(dt))
+        inflnm = trim(indir)//"/"//&
+             out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//&
+             ".LDASIN_DOMAIN"//hgrid
+
+        inquire (file=trim(inflnm), exist=fexist)
+
+#ifdef MPP_LAND
+        call mpp_land_bcast_logical(fexist)
+#endif
+        if ( .not. fexist ) then
+           print*, "no forcing data found", inflnm
+           call hydro_stop("In read_hydro_forcing_mpp1() - no forcing data found")
+        endif
+
+#ifdef HYDRO_D
+          print*, "read forcing data at ", OLDDATE,  trim(inflnm)
+#endif
+      CALL READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+
+       where(PRCP1 .lt. 0) PRCP1= 0  ! set minimum to be 0
+       where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h
+
+   end if
+
+
+
+
+!!!DJG HRLDAS Forcing with minute format filename (NOTE: precip must be in mm/s!!!)
+   if(FORC_TYP.eq.2) then
+!!Create forcing data filename...
+        call geth_newdate(out_date,olddate,nint(dt))
+        inflnm = trim(indir)//"/"//&
+             out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//&
+             out_date(15:16)//".LDASIN_DOMAIN"//hgrid
+        inquire (file=trim(inflnm), exist=fexist)
+#ifdef MPP_LAND
+        call mpp_land_bcast_logical(fexist)
+#endif
+        if ( .not. fexist ) then
+           print*, "no forcing data found", inflnm
+           call hydro_stop("In read_hydro_forcing_mpp1() - no forcing data found")
+        endif
+      CALL READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+          PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+
+       where(PRCP1 .lt. 0) PRCP1= 0  ! set minimum to be 0
+       where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h
+   end if
+
+
+
+
+
+!!!DJG WRF Output File Direct Ingest Forcing...
+     if(FORC_TYP.eq.3) then
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+             "wrfout_d0"//hgrid//"_"//&
+             olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//&
+             "_"//olddate(12:13)//":00:00"
+
+        inquire (file=trim(inflnm), exist=fexist)
+#ifdef MPP_LAND
+        call mpp_land_bcast_logical(fexist)
+#endif
+        if ( .not. fexist ) then
+           print*, "no forcing data found", inflnm
+           call hydro_stop("read_hydro_forcing_seq")
+        endif
+
+        do i_forcing = 1, int(24*3600/dt)
+           wrf_dt = i_forcing*dt
+           call geth_newdate(out_date,olddate,nint(wrf_dt))
+           inflnm2 = trim(indir)//"/"//&
+             "wrfout_d0"//hgrid//"_"//&
+             out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//&
+             "_"//out_date(12:13)//":00:00"
+           inquire (file=trim(inflnm2), exist=fexist)
+#ifdef MPP_LAND
+        call mpp_land_bcast_logical(fexist)
+#endif
+           if (fexist ) goto 991
+        end do
+991     continue
+
+        if(.not. fexist) then
+           write(6,*) "Error: could not find file ",trim(inflnm2)
+           call hydro_stop("In read_hydro_forcing_mpp1() - could not find WRF forcing file")
+        endif
+#ifdef HYDRO_D
+           print*, "read WRF forcing data: ", trim(inflnm)
+           print*, "read WRF forcing data: ", trim(inflnm2)
+#endif
+
+
+       CALL READFORC_WRF_mpp(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+          PRES,XLONG,SHORT,PRCPnew,lai,fpar)
+       CALL READFORC_WRF_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+          PRES,XLONG,SHORT,prcp0,lai,fpar)
+        PRCP1=(PRCPnew-prcp0)/wrf_dt   !Adjustment to convert accum to rate...(mm/s)
+
+     end if
+
+
+
+
+
+!!!DJG CONSTant, idealized forcing...
+     if(FORC_TYP.eq.4) then
+! Impose a fixed diurnal cycle...
+! assumes model timestep is 1 hr
+! assumes K=1 is 12z (Ks or ~ sunrise)
+! First Precip...
+!       IF (K.GE.1 .and. K.LE.2) THEN
+       IF (K.EQ.1) THEN
+        PRCP1 =25.4/3600.0      !units mm/s  (Simulates 1"/hr for first time step...)
+       ELSEIF (K.GT.1) THEN
+         PRCP1 = 0.
+       END IF
+! Other Met. Vars...
+       T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       Q2X = 0.01
+       U = 1.0
+       V = 1.0
+       PRES = 100000.0
+       XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+    end if
+
+
+
+
+
+!!!DJG  Idealized Met. w/ Specified Precip. Forcing Data...(Note: input precip units here are in 'mm/hr')
+!   This option uses hard-wired met forcing EXCEPT precipitation which is read in
+!   from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc'
+!
+    if(FORC_TYP.eq.5) then
+! Standard Met. Vars...
+       T2=290.0 + 3.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       Q2X = 0.01
+       U = 1.0
+       V = 1.0
+       PRES = 100000.0
+       XLONG=400.0 + 25.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+       SHORT=450.0 + 450.0*(cos((2*3.1416*K/24.0)-12.0*2*3.1416/24.0))
+
+!Get specified precip....
+!!!VIP, dimensions of grid are currently hardwired in input subroutine!!!
+!       product = "trmm"
+!       inflnm = trim(indir)//"/"//"sat_domain1.nc"
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+                olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+                olddate(15:16)//".PRECIP_FORCING.nc"
+        inquire (file=trim(inflnm), exist=fexist)
+#ifdef MPP_LAND
+        call mpp_land_bcast_logical(fexist)
+#endif
+        if ( .not. fexist ) then
+           print*, "no specified precipitation data found", inflnm
+           call hydro_stop("In read_hydro_forcing_mpp1() - no specified precipitation data found")
+        endif
+
+       PRCP1 = 0.
+       PRCP_old = PRCP1
+
+#ifdef HYDRO_D
+      print *, "Opening supplemental precipitation forcing file...",inflnm
+#endif
+       CALL READFORC_MDV_mpp(inflnm,IX,JX,   &
+          PRCP2,mmflag,ierr_flg)
+
+!If radar or spec. data is ok use if not, skip to original NARR data...
+      IF (ierr_flg.eq.0) then   ! use spec. precip
+!Convert units if necessary
+        IF (mmflag.eq.0) then    !Convert pcp grid to units of mm/s...
+           PRCP1=PRCP2/DT     !convert from mm to mm/s
+#ifdef HYDRO_D
+           print*, "Supplemental pcp is accumulated pcp/dt. "  
+#endif
+        else
+           PRCP1=PRCP2   !assumes PRCP2 is in mm/s 
+#ifdef HYDRO_D
+           print*, "Supplemental pcp is rate. "  
+#endif
+        END IF  ! Endif mmflag
+      ELSE   ! either stop or default to original forcing data...
+#ifdef HYDRO_D
+        print *,"Current RADAR precip data not found !!! Using previous available file..."
+#endif
+        PRCP1 = PRCP_old
+      END IF  ! Endif ierr_flg
+
+! Loop through data to screen for plausible values
+       do i=1,ix
+         do j=1,jx
+           if (PRCP1(i,j).lt.0.) PRCP1(i,j)= PRCP_old(i,j)
+           if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889  !set max pcp intens = 500 mm/h
+         end do
+       end do
+
+    end if
+
+
+
+
+
+!!!DJG HRLDAS Forcing with hourly format filename with specified precipitation forcing...
+!   This option uses HRLDAS-formatted met forcing EXCEPT precipitation which is read in
+!   from a single, separate input file called 'YYYYMMDDHHMM.PRECIP_FORCING.nc'
+
+   if(FORC_TYP.eq.6) then
+
+!!Create forcing data filename...
+
+#ifdef MPP_LAND
+   if(my_id .eq. io_id) then
+#endif
+     do i_forcing = 1, nint(3600*12/dt)
+        call geth_newdate(out_date,olddate,nint(dt*i_forcing))
+        inflnm = trim(indir)//"/"//&
+             out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//&
+             ".LDASIN_DOMAIN"//hgrid
+
+        inquire (file=trim(inflnm), exist=fexist)
+        if(fexist) goto 101
+     enddo
+101  continue
+#ifdef MPP_LAND
+   endif
+        call mpp_land_bcast_logical(fexist)
+#endif
+
+        if ( .not. fexist ) then
+#ifdef MPP_LAND
+   if(my_id .eq. io_id) then
+#endif
+     do i_forcing = 1, nint(3600*12/dt)
+           call geth_newdate(out_date,olddate,nint(dt*i_forcing))
+           inflnm = trim(indir)//"/"//&
+              out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//&
+              out_date(15:16)//".LDASIN_DOMAIN"//hgrid
+           inquire (file=trim(inflnm), exist=fexist)
+        if(fexist) goto 102
+     end do
+102 continue 
+#ifdef MPP_LAND
+   endif
+        call mpp_land_bcast_logical(fexist)
+#endif
+        endif
+
+
+        if ( .not. fexist ) then
+#ifdef HYDRO_D
+           print*, "no ATM forcing data found at this time", inflnm
+#endif
+        else
+#ifdef HYDRO_D
+           print*, "reading forcing data at this time", inflnm
+#endif
+           
+           CALL READFORC_HRLDAS_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+                PRES,XLONG,SHORT,PRCP1,LAI,FPAR)
+           PRCP_old = PRCP1  ! This assigns new precip to last precip as a fallback for missing data...
+        endif
+
+
+!Get specified precip....
+!!!VIP, dimensions of grid are currently hardwired in input subroutine!!!
+!!Create forcing data filename...
+        call geth_newdate(out_date,olddate,nint(dt))
+        inflnm = trim(indir)//"/"//&
+                 out_date(1:4)//out_date(6:7)//out_date(9:10)//out_date(12:13)//&
+                 out_date(15:16)//".PRECIP_FORCING.nc"
+        inquire (file=trim(inflnm), exist=fexist)
+#ifdef MPP_LAND
+        call mpp_land_bcast_logical(fexist)
+#endif
+#ifdef HYDRO_D
+    if(my_id .eq. io_id) then
+        if(fexist) then 
+            print*, "using specified pcp forcing: ",trim(inflnm)
+        else
+            print*, "no specified pcp forcing: ",trim(inflnm)
+        endif
+    endif
+#endif
+        if ( .not. fexist ) then
+           prcp1 = PRCP_old ! for missing pcp data use analysis/model input 
+        else
+           CALL READFORC_MDV_mpp(inflnm,IX,JX,   &
+              PRCP2,mmflag,ierr_flg)
+!If radar or spec. data is ok use if not, skip to original NARR data...
+           if(ierr_flg .ne. 0) then
+#ifdef HYDRO_D
+               print*, "WARNING: pcp reading problem: ", trim(inflnm)
+#endif
+               PRCP1=PRCP_old
+           else
+               PRCP1=PRCP2   !assumes PRCP2 is in mm/s
+               IF (mmflag.eq.0) then    !Convert pcp grid to units of mm/s...
+                PRCP1=PRCP2/DT     !convert from mm to mm/s
+               END IF  ! Endif mmflag
+#ifdef HYDRO_D
+    if(my_id .eq. io_id) then
+               print*, "replace pcp successfully! ",trim(inflnm)
+    endif
+#endif
+           endif
+        endif
+
+
+! Loop through data to screen for plausible values
+       where(PRCP1 .lt. 0) PRCP1=PRCP_old
+       where(PRCP1 .gt. 10 ) PRCP1= PRCP_old 
+       do i=1,ix
+         do j=1,jx
+           if (PRCP1(i,j).lt.0.) PRCP1(i,j)=0.0
+           if (PRCP1(i,j).gt.0.138889) PRCP1(i,j)=0.138889  !set max pcp intens = 500 mm/h
+         end do
+       end do
+!       write(80,*) prcp1
+
+   end if
+
+
+!!!! FORC_TYP 7: uses WRF forcing data plus additional pcp forcing.
+
+   if(FORC_TYP.eq.7) then
+
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+             "wrfout_d0"//hgrid//"_"//&
+             olddate(1:4)//"-"//olddate(6:7)//"-"//olddate(9:10)//&
+             "_"//olddate(12:13)//":00:00"
+
+        inquire (file=trim(inflnm), exist=fexist)
+#ifdef MPP_LAND
+        call mpp_land_bcast_logical(fexist)
+#endif
+
+
+        if ( .not. fexist ) then
+#ifdef HYDRO_D
+           print*, "no forcing data found", inflnm
+#endif
+        else
+           do i_forcing = 1, int(24*3600/dt)
+              wrf_dt = i_forcing*dt
+              call geth_newdate(out_date,olddate,nint(wrf_dt))
+              inflnm2 = trim(indir)//"/"//&
+                "wrfout_d0"//hgrid//"_"//&
+                out_date(1:4)//"-"//out_date(6:7)//"-"//out_date(9:10)//&
+                "_"//out_date(12:13)//":00:00"
+              inquire (file=trim(inflnm2), exist=fexist)
+#ifdef MPP_LAND
+        call mpp_land_bcast_logical(fexist)
+#endif
+              if (fexist ) goto 992
+           end do
+992        continue
+
+#ifdef HYDRO_D
+           print*, "read WRF forcing data: ", trim(inflnm)
+           print*, "read WRF forcing data: ", trim(inflnm2)
+#endif
+           CALL READFORC_WRF_mpp(inflnm2,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+                   PRES,XLONG,SHORT,PRCPnew,lai,fpar)
+           CALL READFORC_WRF_mpp(inflnm,IX,JX,OLDDATE,T2,Q2X,U,V,   &
+                   PRES,XLONG,SHORT,prcp0,lai,fpar)
+           PRCP1=(PRCPnew-prcp0)/wrf_dt   !Adjustment to convert accum to rate...(mm/s)
+           PRCP_old = PRCP1
+        endif
+
+!Get specified precip....
+!!!VIP, dimensions of grid are currently hardwired in input subroutine!!!
+!!Create forcing data filename...
+        inflnm = trim(indir)//"/"//&
+                 olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+                 olddate(15:16)//".PRECIP_FORCING.nc"
+        inquire (file=trim(inflnm), exist=fexist)
+#ifdef MPP_LAND
+        call mpp_land_bcast_logical(fexist)
+#endif
+#ifdef HYDRO_D
+        if(fexist) then
+            print*, "using specified pcp forcing: ",trim(inflnm)
+        else
+            print*, "no specified pcp forcing: ",trim(inflnm)
+        endif
+#endif
+        if ( .not. fexist ) then
+           prcp1 = PRCP_old ! for missing pcp data use analysis/model input 
+        else
+           CALL READFORC_MDV_mpp(inflnm,IX,JX,   &
+              PRCP2,mmflag,ierr_flg)
+!If radar or spec. data is ok use if not, skip to original NARR data...
+           if(ierr_flg .ne. 0) then
+#ifdef HYDRO_D
+               print*, "WARNING: pcp reading problem: ", trim(inflnm)
+#endif
+               PRCP1=PRCP_old
+           else
+               PRCP1=PRCP2   !assumes PRCP2 is in mm/s
+               IF (mmflag.eq.0) then    !Convert pcp grid to units of mm/s...
+                 write(6,*) "using supplemental pcp time interval ", DT
+                PRCP1=PRCP2/DT     !convert from mm to mm/s
+               else
+                 write(6,*) "using supplemental pcp rates "
+               END IF  ! Endif mmflag
+#ifdef HYDRO_D
+               print*, "replace pcp successfully! ",trim(inflnm)
+#endif
+           endif
+        endif
+
+
+! Loop through data to screen for plausible values
+       where(PRCP1 .lt. 0) PRCP1=PRCP_old
+       where(PRCP1 .gt. 10 ) PRCP1= PRCP_old ! set maximum to be 500 mm/h
+       where(PRCP1 .gt. 0.138889) PRCP1= 0.138889 ! set maximum to be 500 mm/h
+   end if
+
+!!!!DJG Check for snow data assimilation...
+
+   if (SNOW_ASSIM .eq. 1) then
+
+! Every 24 hours, update the snow field from analyses.
+     if(forc_typ .ne. 3 .or. forc_typ .ne. 6) then
+         if ( OLDDATE(12:13) == "00") then
+            CALL READSNOW_FORC_mpp(inflnm,IX,JX,WEASD,SNODEP)
+         endif
+     else
+        CALL READSNOW_FORC_mpp(inflnm,IX,JX,WEASD,SNODEP)
+     endif
+
+   end if
+
+#ifdef PRECIP_DOUBLE
+#ifdef HYDRO_D
+   print*,'PRECIP DOUBLE'
+#endif
+   PRCP1 = PRCP1 * 2.0
+#endif 
+
+ end subroutine read_hydro_forcing_mpp1
+
+  subroutine READFORC_HRLDAS_mpp(flnm,ix,jx,target_date, t,q,u,v,p,lw,sw,pcp,lai,fpar)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    character(len=*),                   intent(in)  :: target_date
+    real,             dimension(ix,jx), intent(out) :: t
+    real,             dimension(ix,jx), intent(out) :: q
+    real,             dimension(ix,jx), intent(out) :: u
+    real,             dimension(ix,jx), intent(out) :: v
+    real,             dimension(ix,jx), intent(out) :: p
+    real,             dimension(ix,jx), intent(out) :: lw
+    real,             dimension(ix,jx), intent(out) :: sw
+    real,             dimension(ix,jx), intent(out) :: pcp
+    real,             dimension(ix,jx), intent(inout) :: lai
+    real,             dimension(ix,jx), intent(inout) :: fpar
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid
+
+    ! Open the NetCDF file.
+#ifdef MPP_LAND
+    real, allocatable, dimension(:,:):: buf2
+    if(my_id .eq. io_id) then
+        allocate(buf2(global_nx,global_ny))
+    else
+        allocate(buf2(1,1))
+    endif
+    if(my_id .eq. io_id) then
+        ierr = nf_open(trim(flnm), NF_NOWRITE, ncid)
+    endif
+    call mpp_land_bcast_int1(ierr)
+    if (ierr /= 0) then
+       write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm)
+       call hydro_stop("In READFORC_HRLDAS_mpp() - Problem opening netcdf file")
+    endif
+
+    if(my_id .eq. io_id ) call get_2d_netcdf("T2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr)
+    call decompose_data_real (buf2,t)
+    if(my_id .eq. io_id ) call get_2d_netcdf("Q2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr)
+    call decompose_data_real (buf2,q)
+    if(my_id .eq. io_id ) call get_2d_netcdf("U2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr)
+    call decompose_data_real (buf2,u)
+    if(my_id .eq. io_id ) call get_2d_netcdf("V2D", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr)
+    call decompose_data_real (buf2,v)
+    if(my_id .eq. io_id ) call get_2d_netcdf("PSFC", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr)
+    call decompose_data_real (buf2,p)
+    if(my_id .eq. io_id ) call get_2d_netcdf("LWDOWN", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr)
+    call decompose_data_real (buf2,lw)
+    if(my_id .eq. io_id ) call get_2d_netcdf("SWDOWN", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr)
+    call decompose_data_real (buf2,sw)
+    if(my_id .eq. io_id ) call get_2d_netcdf("RAINRATE", ncid,buf2, units, global_nx, global_ny, .TRUE., ierr)
+    call decompose_data_real (buf2,pcp)
+    if(my_id .eq. io_id ) then 
+          call get_2d_netcdf("VEGFRA", ncid,buf2, units, global_nx, global_ny, .FALSE., ierr)
+          if (ierr == 0) then
+            if(maxval(buf2) .gt. 10 .and. maxval(buf2) .lt. 10000)  buf2 = buf2 * 1.E-2
+          endif
+    endif
+    call mpp_land_bcast_int1(ierr)
+    if(ierr == 0) call decompose_data_real (buf2,fpar)
+    if(my_id .eq. io_id ) call get_2d_netcdf("LAI",     ncid, buf2,   units, ix, jx, .FALSE., ierr)
+    call mpp_land_bcast_int1(ierr)
+    if(ierr == 0) call decompose_data_real (buf2,lai)
+    
+    deallocate(buf2) 
+#else
+    ierr = nf_open(trim(flnm), NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+       write(*,'("READFORC Problem opening netcdf file: ''", A, "''")') trim(flnm)
+       call hydro_stop("READFORC_HRLDAS")
+    endif
+    call get_2d_netcdf("T2D",     ncid, t,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("Q2D",     ncid, q,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("U2D",     ncid, u,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("V2D",     ncid, v,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("PSFC",    ncid, p,     units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("LWDOWN",  ncid, lw,    units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("SWDOWN",  ncid, sw,    units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("RAINRATE",ncid, pcp,   units, ix, jx, .TRUE., ierr)
+    call get_2d_netcdf("VEGFRA",  ncid, fpar,  units, ix, jx, .FALSE., ierr)
+
+    if (ierr == 0) then
+      if(maxval(fpar) .gt. 10 .and. maxval(fpar) .lt. 10000)  fpar = fpar * 1.E-2
+    endif
+    call get_2d_netcdf("LAI",     ncid, lai,   units, ix, jx, .FALSE., ierr)
+#endif
+
+    ierr = nf_close(ncid)
+
+  end subroutine READFORC_HRLDAS_mpp
+
+  subroutine READFORC_WRF_mpp(flnm,ix,jx,target_date,t,q,u,v,p,lw,sw,pcp,lai,fpar)
+
+    implicit none
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    character(len=*),                   intent(in)  :: target_date
+    real,             dimension(ix,jx) :: t,q,u,v,p,lw,sw,pcp,pcpc, lai,fpar
+    integer   tlevel
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid
+#ifdef MPP_LAND
+    real, allocatable, dimension(:,:) :: buf2
+#endif
+
+    tlevel = 1
+
+    pcpc = 0
+
+#ifdef MPP_LAND
+    if(my_id .eq. io_id) then
+          allocate(buf2(global_nx, global_ny) )
+    else
+          allocate(buf2(1, 1) )
+    endif
+
+    ! Open the NetCDF file.
+   
+    if(my_id .eq. io_id) ierr = nf_open(flnm, NF_NOWRITE, ncid)
+    call mpp_land_bcast_int1(ierr)
+    if (ierr /= 0) then
+       write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm)
+       call hydro_stop("In READFORC_WRF_mpp() - Problem opening netcdf file")
+    endif
+    if(my_id .eq. io_id) call get_2d_netcdf_ruc("T2",     ncid, buf2, global_nx, global_ny,tlevel, .true., ierr)
+    call decompose_data_real (buf2,t)
+    if(my_id .eq. io_id) call get_2d_netcdf_ruc("Q2",     ncid, buf2, global_nx, global_ny,tlevel, .true., ierr)
+    call decompose_data_real (buf2,q)
+    if(my_id .eq. io_id) call get_2d_netcdf_ruc("U10",     ncid, buf2, global_nx, global_ny,tlevel, .true., ierr)
+    call decompose_data_real (buf2,u)
+    if(my_id .eq. io_id) call get_2d_netcdf_ruc("V10",     ncid, buf2, global_nx, global_ny,tlevel, .true., ierr)
+    call decompose_data_real (buf2,v)
+    if(my_id .eq. io_id) call get_2d_netcdf_ruc("PSFC",     ncid, buf2, global_nx, global_ny,tlevel, .true., ierr)
+    call decompose_data_real (buf2,p)
+    if(my_id .eq. io_id) call get_2d_netcdf_ruc("GLW",     ncid, buf2, global_nx, global_ny,tlevel, .true., ierr)
+    call decompose_data_real (buf2,lw)
+    if(my_id .eq. io_id) call get_2d_netcdf_ruc("SWDOWN",     ncid, buf2, global_nx, global_ny,tlevel, .true., ierr)
+    call decompose_data_real (buf2,sw)
+    if(my_id .eq. io_id) call get_2d_netcdf_ruc("RAINC",     ncid, buf2, global_nx, global_ny,tlevel, .true., ierr)
+    call decompose_data_real (buf2,pcpc)
+    if(my_id .eq. io_id) call get_2d_netcdf_ruc("RAINNC",     ncid, buf2, global_nx, global_ny,tlevel, .true., ierr)
+    call decompose_data_real (buf2,pcp)
+    if(my_id .eq. io_id) call get_2d_netcdf_ruc("LAI",     ncid, buf2, global_nx, global_ny,tlevel, .false., ierr)
+    call mpp_land_bcast_int1(ierr)
+    if(ierr == 0) call decompose_data_real (buf2,lai)
+    if(my_id .eq. io_id) then 
+       call get_2d_netcdf_ruc("VEGFRA", ncid, fpar,  ix, jx,tlevel, .true., ierr)
+       if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar/100.
+    endif
+    call mpp_land_bcast_int1(ierr)
+    if(ierr == 0) call decompose_data_real (buf2,fpar)
+    deallocate(buf2)
+#else
+
+    ! Open the NetCDF file.
+    ierr = nf_open(flnm, NF_NOWRITE, ncid)
+    if (ierr /= 0) then
+       write(*,'("READFORC_WRF Problem opening netcdf file: ''", A, "''")') trim(flnm)
+       call hydro_stop("In READFORC_WRF_mpp() - Problem opening netcdf file")
+    endif
+    call get_2d_netcdf_ruc("T2",     ncid, t,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("Q2",     ncid, q,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("U10",    ncid, u,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("V10",    ncid, v,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("PSFC",   ncid, p,     ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("GLW",    ncid, lw,    ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("SWDOWN", ncid, sw,    ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("RAINC",  ncid, pcpc,  ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("RAINNC", ncid, pcp,   ix, jx,tlevel, .true., ierr)
+    call get_2d_netcdf_ruc("VEGFRA", ncid, fpar,  ix, jx,tlevel, .false., ierr)
+    if(ierr == 0) then
+        if(maxval(fpar) .gt. 10 .and. (maxval(fpar) .lt. 10000) ) fpar = fpar/100.
+    endif
+    call get_2d_netcdf_ruc("LAI", ncid, lai,  ix, jx,tlevel, .false., ierr)
+
+#endif
+
+
+    pcp=pcp+pcpc   ! assumes pcpc=0 for resolved convection...
+    ierr = nf_close(ncid)
+
+
+  end subroutine READFORC_WRF_mpp
+
+  subroutine READFORC_MDV_mpp(flnm,ix,jx,pcp,mmflag,ierr_flg)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    integer,                            intent(out)  :: ierr_flg
+    integer :: it,jew,zsn
+    real,             dimension(ix,jx), intent(out) :: pcp
+
+    character(len=256) :: units
+    integer :: ierr,i,j,i2,j2,varid
+    integer :: ncid,mmflag
+    real, dimension(ix,jx) :: temp
+#ifdef MPP_LAND
+    real, allocatable, dimension(:,:) :: buf2
+    if(my_id .eq. io_id) then
+       allocate(buf2(global_nx, global_ny))
+    else
+       allocate(buf2(1,1))
+    endif
+#endif
+
+    mmflag = 0   ! flag for units spec. (0=mm, 1=mm/s)
+
+    
+!open NetCDF file...
+#ifdef MPP_LAND
+      if(my_id .eq. io_id) then
+#endif
+        ierr_flg = nf_open(flnm, NF_NOWRITE, ncid)
+#ifdef MPP_LAND
+      endif
+      call mpp_land_bcast_int1(ierr_flg)
+#endif
+        if (ierr_flg /= 0) then
+          write(*,'("READFORC_MDV Problem opening netcdf file: ''",A,"''")') &
+                trim(flnm)
+#ifdef MPP_LAND
+           deallocate(buf2)
+#endif
+           return
+        end if
+
+#ifdef MPP_LAND
+      if(my_id .eq. io_id) then
+#endif
+        ierr = nf_inq_varid(ncid,  "precip",  varid)
+#ifdef MPP_LAND
+      endif
+      call mpp_land_bcast_int1(ierr)
+#endif
+        if(ierr /= 0) ierr_flg = ierr
+        if (ierr /= 0) then
+#ifdef MPP_LAND
+      if(my_id .eq. io_id) then
+#endif
+          ierr = nf_inq_varid(ncid,  "precip_rate",  varid)   !recheck variable name...
+#ifdef MPP_LAND
+      endif
+      call mpp_land_bcast_int1(ierr)
+#endif
+          if (ierr /= 0) then
+            write(*,'("READFORC_MDV Problem reading precip netcdf file: ''", A,"''")') &
+                 trim(flnm)
+#ifdef MPP_LAND
+              deallocate(buf2)
+#endif
+              return
+          end if
+          ierr_flg = ierr
+          mmflag = 1
+        end if
+#ifdef MPP_LAND
+      if(my_id .eq. io_id) then
+          ierr = nf_get_var_real(ncid, varid, buf2)
+      endif
+      call mpp_land_bcast_int1(ierr)
+      if(ierr ==0) call decompose_data_real (buf2,pcp)
+      deallocate(buf2)
+#else
+        ierr = nf_get_var_real(ncid, varid, pcp)
+#endif
+        if (ierr /= 0) then
+           write(*,'("READFORC_MDV Problem reading netcdf file: ''", A,"''")') trim(flnm)
+        end if
+        ierr = nf_close(ncid)
+
+  end subroutine READFORC_MDV_mpp
+
+  subroutine READSNOW_FORC_mpp(flnm,ix,jx,weasd,snodep)
+    implicit none
+
+    character(len=*),                   intent(in)  :: flnm
+    integer,                            intent(in)  :: ix
+    integer,                            intent(in)  :: jx
+    real,             dimension(ix,jx), intent(out) :: weasd
+    real,             dimension(ix,jx), intent(out) :: snodep
+    real, dimension(ix,jx) :: tmp
+
+    character(len=256) :: units
+    integer :: ierr
+    integer :: ncid,i,j
+#ifdef MPP_LAND
+    real, allocatable, dimension(:,:) :: buf2
+    if(my_id .eq. io_id) then
+       allocate(buf2(global_nx, global_ny))
+    else
+       allocate(buf2(1,1))
+    endif
+#endif
+
+    ! Open the NetCDF file.
+#ifdef MPP_LAND
+      if(my_id .eq. io_id) then
+#endif
+    ierr = nf_open(flnm, NF_NOWRITE, ncid)
+#ifdef MPP_LAND
+      endif
+      call mpp_land_bcast_int1(ierr)
+#endif
+    if (ierr /= 0) then
+       write(*,'("READSNOW Problem opening netcdf file: ''", A, "''")') trim(flnm)
+       call hydro_stop("In READSNOW_FORC_mpp() - Problem opening netcdf file")
+    endif
+
+#ifdef MPP_LAND
+      if(my_id .eq. io_id) then
+          call get_2d_netcdf("WEASD",  ncid, buf2,   units, ix, jx, .FALSE., ierr)
+      endif
+      call mpp_land_bcast_int1(ierr)
+      if(ierr == 0) call decompose_data_real (buf2,tmp)
+#else
+    call get_2d_netcdf("WEASD",  ncid, tmp,   units, ix, jx, .FALSE., ierr)
+#endif
+    if (ierr /= 0) then
+         call get_2d_netcdf("SNOW",  ncid, tmp,   units, ix, jx, .FALSE., ierr)
+         if (ierr == 0) then
+            units = "mm"
+#ifdef HYDRO_D
+            print *, "read WEASD from wrfoutput ...... "
+#endif
+            weasd = tmp * 1.E-3
+         endif
+    else
+         weasd = tmp
+         if (trim(units) == "m") then
+            ! No conversion necessary
+         else if (trim(units) == "mm") then
+            ! convert WEASD from mm to m
+            weasd = weasd * 1.E-3
+         endif
+    endif
+
+    if (ierr /= 0) then
+       print *, "!!!!! NO WEASD present in input file...initialize to 0."
+    endif
+#ifdef MPP_LAND
+      if(my_id .eq. io_id) then
+         call get_2d_netcdf("SNODEP",     ncid, buf2,   units, ix, jx, .FALSE., ierr)
+      endif
+      call mpp_land_bcast_int1(ierr)
+      if(ierr == 0) call decompose_data_real (buf2,tmp)
+#else
+    call get_2d_netcdf("SNODEP",     ncid, tmp,   units, ix, jx, .FALSE., ierr)
+#endif
+    if (ierr /= 0) then
+       ! Quick assumption regarding snow depth.
+
+#ifdef MPP_LAND
+      if(my_id .eq. io_id) then
+         call get_2d_netcdf("SNOWH",     ncid, buf2,   units, ix, jx, .FALSE., ierr)
+      endif
+      call mpp_land_bcast_int1(ierr)
+      if(ierr == 0) call decompose_data_real (buf2,tmp)
+#else
+         call get_2d_netcdf("SNOWH",     ncid, tmp,   units, ix, jx, .FALSE., ierr)
+#endif
+       if(ierr .eq. 0) then
+#ifdef HYDRO_D
+            print *, "read snow depth from wrfoutput ... "
+#endif
+            snodep = tmp
+       endif
+    else
+       snodep = tmp
+    endif
+
+    if (ierr /= 0) then
+       ! Quick assumption regarding snow depth.
+!yw       snodep = weasd * 10.
+       where(snodep .lt. weasd) snodep = weasd*10  !set lower bound to correct bi-lin interp err...
+    endif
+
+!DJG check for erroneous neg WEASD or SNOWD due to offline interpolation...
+       where(snodep .lt. 0) snodep = 0
+       where(weasd .lt. 0) weasd = 0
+    ierr = nf_close(ncid)
+
+  end subroutine READSNOW_FORC_mpp
+
+  subroutine read_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain)
+
+      implicit none
+      logical :: fexist
+      integer :: ix,jx
+      character(len=*) :: olddate,hgrid,indir
+      character(len=19) :: outdate
+      character(len=256) :: inflnm, inflnm2
+      real :: dt
+      real, dimension(ix,jx):: infxsrt,infxsrt2,soldrain,soldrain2
+      integer :: ncid, ierr
+      character(len=256) :: units
+#ifdef MPP_LAND
+      real, dimension(global_nx,global_ny) :: gArr
+#endif
+
+        ! check for file with hours first 
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             ".LDASOUT_DOMAIN"//hgrid
+        inquire (file=trim(inflnm), exist=fexist)
+
+        if(.not. fexist) then
+           ! check for file with minutes
+             inflnm = trim(indir)//"/"//&
+                  olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//olddate(15:16)//&
+                  ".LDASOUT_DOMAIN"//hgrid
+             inquire (file=trim(inflnm), exist=fexist)
+        endif
+        if(.not. fexist) then
+            write(6,*) "Error: input file does not exist. Check ", trim(olddate)
+            call hydro_stop( "LDASOUT input Error")
+        endif
+
+        call geth_newdate(outdate,olddate,nint(dt))
+        ! check file for next date 
+        ! check for file with hours first 
+        inflnm2 = trim(indir)//"/"//&
+             outdate(1:4)//outdate(6:7)//outdate(9:10)//outdate(12:13)//&
+             ".LDASOUT_DOMAIN"//hgrid
+        inquire (file=trim(inflnm2), exist=fexist)
+
+        if(.not. fexist) then
+           ! check for file with minutes
+             inflnm2 = trim(indir)//"/"//&
+                  outdate(1:4)//outdate(6:7)//outdate(9:10)//outdate(12:13)//outdate(15:16)//&
+                  ".LDASOUT_DOMAIN"//hgrid
+             inquire (file=trim(inflnm2), exist=fexist)
+        endif
+        if(.not. fexist) then
+            write(6,*) "FATAL ERROR: input file does not exist. Check ", trim(outdate)
+            call hydro_stop( "LDASOUT input Error")
+        endif
+!       read file1
+#ifdef MPP_LAND
+        if(my_id .eq. io_id) then
+           ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid)
+           call get_2d_netcdf("SFCRNOFF",    ncid, gArr, units,  global_nx, global_ny, .TRUE., ierr)
+        endif
+        call decompose_data_real (gArr,infxsrt)
+        if(my_id .eq. io_id) then
+           call get_2d_netcdf("UGDRNOFF",    ncid, gArr, units, global_nx, global_ny, .TRUE., ierr)
+        endif
+        call decompose_data_real (gArr,soldrain)
+        if(my_id .eq. io_id) then
+            ierr = nf_close(ncid)
+        endif
+#else
+        ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid)
+        call get_2d_netcdf("SFCRNOFF",    ncid, infxsrt, units,  ix, jx, .TRUE., ierr)
+        call get_2d_netcdf("UGDRNOFF",    ncid, soldrain, units,  ix, jx, .TRUE., ierr)
+        ierr = nf_close(ncid)
+#endif
+!       read file2
+#ifdef MPP_LAND
+       if(my_id .eq. io_id) then
+           ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid)
+           call get_2d_netcdf("SFCRNOFF",    ncid, gArr, units,  global_nx, global_ny, .TRUE., ierr)
+        endif
+        call decompose_data_real (gArr,infxsrt2)
+        if(my_id .eq. io_id) then
+           call get_2d_netcdf("UGDRNOFF",    ncid, gArr, units, global_nx, global_ny, .TRUE., ierr)
+        endif
+        call decompose_data_real (gArr,soldrain2)
+        if(my_id .eq. io_id) then
+           ierr = nf_close(ncid)
+        endif
+#else
+        ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid)
+        call get_2d_netcdf("SFCRNOFF",    ncid, infxsrt2, units,  ix, jx, .TRUE., ierr)
+        call get_2d_netcdf("UGDRNOFF",    ncid, soldrain2, units,  ix, jx, .TRUE., ierr)
+        ierr = nf_close(ncid)
+#endif
+
+        infxsrt = infxsrt2 - infxsrt
+        soldrain = soldrain2 - soldrain
+
+   end subroutine read_ldasout
+
+!temporary for Noah model
+
+  subroutine read_ldasout_seq(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain)
+      implicit none
+      logical :: fexist
+      integer :: ix,jx
+      character(len=*) :: olddate,hgrid,indir
+      character(len=19) :: outdate
+      character(len=256) :: inflnm, inflnm2
+      real :: dt
+      real, dimension(ix,jx):: infxsrt,infxsrt2,soldrain,soldrain2
+      integer :: ncid, ierr
+      character(len=256) :: units
+
+        ! check for file with hours first 
+        inflnm = trim(indir)//"/"//&
+             olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//&
+             ".LDASOUT_DOMAIN"//hgrid
+        inquire (file=trim(inflnm), exist=fexist)
+
+        if(.not. fexist) then
+           ! check for file with minutes
+             inflnm = trim(indir)//"/"//&
+                  olddate(1:4)//olddate(6:7)//olddate(9:10)//olddate(12:13)//olddate(15:16)//&
+                  ".LDASOUT_DOMAIN"//hgrid
+             inquire (file=trim(inflnm), exist=fexist)
+        endif
+        if(.not. fexist) then
+            write(6,*) "FATAL ERROR: input file does not exist. Check ", trim(olddate)
+            call hydro_stop( "LDASOUT input Error")
+        endif
+
+        call geth_newdate(outdate,olddate,nint(dt))
+        ! check file for next date 
+        ! check for file with hours first 
+        inflnm2 = trim(indir)//"/"//&
+             outdate(1:4)//outdate(6:7)//outdate(9:10)//outdate(12:13)//&
+             ".LDASOUT_DOMAIN"//hgrid
+        inquire (file=trim(inflnm2), exist=fexist)
+
+        if(.not. fexist) then
+           ! check for file with minutes
+             inflnm2 = trim(indir)//"/"//&
+                  outdate(1:4)//outdate(6:7)//outdate(9:10)//outdate(12:13)//outdate(15:16)//&
+                  ".LDASOUT_DOMAIN"//hgrid
+             inquire (file=trim(inflnm2), exist=fexist)
+        endif
+        if(.not. fexist) then
+            write(6,*) "FATAL ERROR: input file does not exist. Check ", trim(outdate)
+            call hydro_stop( "LDASOUT input Error")
+        endif
+!       read file1
+        ierr = nf_open(trim(inflnm), NF_NOWRITE, ncid)
+        call get_2d_netcdf("SFCRNOFF",    ncid, infxsrt, units,  ix, jx, .TRUE., ierr)
+        call get_2d_netcdf("UGDRNOFF",    ncid, soldrain, units,  ix, jx, .TRUE., ierr)
+        ierr = nf_close(ncid)
+!       read file2
+        ierr = nf_open(trim(inflnm2), NF_NOWRITE, ncid)
+        call get_2d_netcdf("SFCRNOFF",    ncid, infxsrt2, units,  ix, jx, .TRUE., ierr)
+        call get_2d_netcdf("UGDRNOFF",    ncid, soldrain2, units,  ix, jx, .TRUE., ierr)
+        ierr = nf_close(ncid)
+
+        infxsrt = infxsrt2 - infxsrt
+        soldrain = soldrain2 - soldrain
+
+   end subroutine read_ldasout_seq
+end module module_lsm_forcing
+
+     subroutine read_forc_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain)
+      use module_lsm_forcing, only: read_ldasout
+      implicit none
+      integer :: ix,jx
+      character(len=*) :: olddate,hgrid,indir
+      real :: dt
+      real, dimension(ix,jx):: infxsrt,soldrain
+      call read_ldasout(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain)
+    end subroutine read_forc_ldasout
+    
+    subroutine read_forc_ldasout_seq(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain)
+! temporary for Noah model
+      use module_lsm_forcing, only: read_ldasout_seq
+      implicit none
+      integer :: ix,jx
+      character(len=*) :: olddate,hgrid,indir
+      real :: dt
+      real, dimension(ix,jx):: infxsrt,soldrain
+      call read_ldasout_seq(olddate,hgrid, indir, dt,ix,jx,infxsrt,soldrain)
+    end subroutine read_forc_ldasout_seq
+
diff --git a/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F b/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F
new file mode 100644
index 00000000..5e44d1e7
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/module_noah_chan_param_init_rt.F
@@ -0,0 +1,114 @@
+!  Program Name:
+!  Author(s)/Contact(s):
+!  Abstract:
+!  History Log:
+! 
+!  Usage:
+!  Parameters: 
+!  Input Files:
+!        
+!  Output Files:
+!        
+! 
+!  Condition codes:
+!        
+!        If appropriate, descriptive troubleshooting instructions or
+!        likely causes for failures could be mentioned here with the
+!        appropriate error code
+! 
+!  User controllable options: 
+
+MODULE module_noah_chan_param_init_rt
+
+
+CONTAINS
+!
+!-----------------------------------------------------------------
+  SUBROUTINE CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann)
+!-----------------------------------------------------------------
+
+    IMPLICIT NONE
+
+    integer :: IINDEX, CHANCATS
+    integer :: ORDER, IUNIT
+    integer, PARAMETER :: NCHANTYPES=50 
+    real,dimension(NCHANTYPES)    :: BOTWID,HLINK_INIT,CHAN_SS,CHMann
+    character(LEN=11) :: DATATYPE
+
+!-----SPECIFY CHANNEL RELATED CHARACTERISTICS :
+!             ORDER: Strahler Stream Order
+!            BOTWID: Channel Bottom Width (meters)
+!        HLINK_INIT: Initial depth of flow in channel (meters)
+!           CHAN_SS: Channel side slope (assuming trapezoidal channel geom)
+!            CHMann: Channel Manning's N roughness coefficient 
+
+
+!-----READ IN CHANNEL PROPERTIES FROM CHANPARM.TBL :
+    IUNIT = 23
+    OPEN(IUNIT, &
+#ifndef NCEP_WCOSS
+    FILE='CHANPARM.TBL', &
+#endif
+    FORM='FORMATTED',STATUS='OLD')
+    READ (IUNIT,*)
+    READ (IUNIT,2000,END=2002) DATATYPE
+#ifdef HYDRO_D
+    PRINT *, DATATYPE
+#endif
+    READ (IUNIT,*)CHANCATS,IINDEX
+2000 FORMAT (A11)
+
+!-----Read in Channel Parameters as functions of stream order...
+
+    IF(DATATYPE.EQ.'StreamOrder')THEN
+#ifdef HYDRO_D
+       PRINT *, 'CHANNEL DATA SOURCE TYPE = ',DATATYPE,' FOUND',           &
+            CHANCATS,' CATEGORIES'
+#endif
+       DO ORDER=1,CHANCATS
+          READ (IUNIT,*)IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER),   &
+               &     CHMann(ORDER)
+#ifdef HYDRO_D
+          PRINT *, IINDEX,BOTWID(ORDER),HLINK_INIT(ORDER),CHAN_SS(ORDER),   &
+               &     CHMann(ORDER)
+#endif
+       ENDDO
+    ENDIF
+
+
+!-----Read in Channel Parameters as functions of ???other method??? (TBC)...
+
+
+2002 CONTINUE
+
+    CLOSE (IUNIT)
+  END SUBROUTINE CHAN_PARM_INIT
+
+
+
+#ifdef MPP_LAND
+  SUBROUTINE mpp_CHAN_PARM_INIT (BOTWID,HLINK_INIT,CHAN_SS,CHMann)
+    use module_mpp_land, only:  my_id, IO_id,mpp_land_bcast_int1, &
+       mpp_land_bcast_real,mpp_land_bcast_int,mpp_land_bcast_real1
+    implicit none
+    integer :: IINDEX, CHANCATS
+    integer :: ORDER
+    integer, PARAMETER :: NCHANTYPES=50 
+    real,dimension(NCHANTYPES)    :: BOTWID,HLINK_INIT,CHAN_SS,CHMann
+    character(LEN=11) :: DATATYPE
+
+    if(my_id.eq.io_id) then
+       call CHAN_PARM_INIT(BOTWID,HLINK_INIT,CHAN_SS,CHMann)
+    end if
+       call mpp_land_bcast_real(NCHANTYPES,BOTWID)
+       call mpp_land_bcast_real(NCHANTYPES,HLINK_INIT)
+       call mpp_land_bcast_real(NCHANTYPES,CHAN_SS)
+       call mpp_land_bcast_real(NCHANTYPES,CHMann)
+    return 
+    END SUBROUTINE mpp_CHAN_PARM_INIT
+#endif
+!-----------------------------------------------------------------
+!-----------------------------------------------------------------
+
+
+END MODULE module_Noah_chan_param_init_rt
diff --git a/wrfv2_fire/hydro/Routing/rtFunction.F b/wrfv2_fire/hydro/Routing/rtFunction.F
new file mode 100644
index 00000000..9334307f
--- /dev/null
+++ b/wrfv2_fire/hydro/Routing/rtFunction.F
@@ -0,0 +1,222 @@
+      subroutine exeRouting (did)
+         use module_RT_data, only: rt_domain
+         use module_GW_baseflow_data, only: gw2d
+         use module_GW_baseflow, only: simp_gw_buck, gwstep
+         use module_channel_routing, only: drive_channel
+         use module_namelist, only: nlst_rt
+
+#ifdef MPP_LAND  
+         use module_mpp_land 
+#endif
+
+       
+         implicit none
+         integer did, i
+         real, dimension(RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT):: &
+                   QSTRMVOLRT_DUM,LAKE_INFLORT_DUM, &
+                   QSTRMVOLRT_TS, LAKE_INFLORT_TS
+
+         real :: dx
+         integer ii,jj,kk
+
+
+           IF (nlst_rt(did)%SUBRTSWCRT.EQ.1 .or. nlst_rt(did)%OVRTSWCRT.EQ.1 .or. nlst_rt(did)%GWBASESWCRT .ne. 0) THEN
+
+              QSTRMVOLRT_DUM = RT_DOMAIN(did)%QSTRMVOLRT
+              LAKE_INFLORT_DUM = RT_DOMAIN(did)%LAKE_INFLORT
+
+#ifdef HYDRO_D
+               write(6,*) "*****yw******start drive_RT "
+#endif
+
+
+
+!          write(6,*) "yyww RT_DOMAIN(did)%SH2OX(15,1,7)= ", RT_DOMAIN(did)%SH2OX(15,1,7)
+
+         call drive_RT( RT_DOMAIN(did)%IX,RT_DOMAIN(did)%JX,nlst_rt(did)%NSOIL,&
+             RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT,  &
+             RT_DOMAIN(did)%SMC,RT_DOMAIN(did)%STC,RT_DOMAIN(did)%SH2OX, &
+             RT_DOMAIN(did)%INFXSRT,RT_DOMAIN(did)%SFCHEADRT,RT_DOMAIN(did)%SMCMAX1,&
+             RT_DOMAIN(did)%SMCREF1,RT_DOMAIN(did)%LKSAT,  &
+             RT_DOMAIN(did)%SMCWLT1, RT_DOMAIN(did)%SMCRTCHK,RT_DOMAIN(did)%DSMC,&
+             RT_DOMAIN(did)%ZSOIL, RT_DOMAIN(did)%SMCAGGRT,&
+             RT_DOMAIN(did)%STCAGGRT,RT_DOMAIN(did)%SH2OAGGRT, &
+             RT_DOMAIN(did)%SLDPTH,RT_DOMAIN(did)%VEGTYP,RT_DOMAIN(did)%SOLDEPRT,&
+             RT_DOMAIN(did)%INFXSAGGRT,RT_DOMAIN(did)%DHRT,RT_DOMAIN(did)%QSTRMVOLRT, &
+             RT_DOMAIN(did)%QBDRYRT,RT_DOMAIN(did)%LAKE_INFLORT,&
+             RT_DOMAIN(did)%SFCHEADSUBRT,RT_DOMAIN(did)%INFXSWGT,&
+             RT_DOMAIN(did)%LKSATRT, &
+             RT_DOMAIN(did)%INFXSUBRT,RT_DOMAIN(did)%OVROUGHRT,&
+             RT_DOMAIN(did)%QSUBRT,RT_DOMAIN(did)%ZWATTABLRT, &
+             RT_DOMAIN(did)%QSUBBDRYRT,   &
+             RT_DOMAIN(did)%RETDEPRT,RT_DOMAIN(did)%SOXRT,RT_DOMAIN(did)%SOYRT,&
+             RT_DOMAIN(did)%SUB_RESID,RT_DOMAIN(did)%SMCRT,&
+             RT_DOMAIN(did)%SMCMAXRT,RT_DOMAIN(did)%SMCWLTRT, &
+             RT_DOMAIN(did)%SH2OWGT,RT_DOMAIN(did)%LAKE_MSKRT,&
+             RT_DOMAIN(did)%CH_NETRT, RT_DOMAIN(did)%dist, &
+             RT_DOMAIN(did)%LSMVOL,RT_DOMAIN(did)%DSMCTOT, &
+             RT_DOMAIN(did)%SMCTOT1,&
+             RT_DOMAIN(did)%SMCTOT2,RT_DOMAIN(did)%suminfxs1, &
+             RT_DOMAIN(did)%suminfxsrt,RT_DOMAIN(did)%SO8RT, &
+             RT_DOMAIN(did)%SO8RT_D,nlst_rt(did)%AGGFACTRT,  &
+             nlst_rt(did)%SUBRTSWCRT,nlst_rt(did)%OVRTSWCRT, &
+             RT_DOMAIN(did)%LAKE_CT, RT_DOMAIN(did)%STRM_CT,    &
+             nlst_rt(did)%RT_OPTION,RT_DOMAIN(did)%OV_ROUGH, &
+             RT_DOMAIN(did)%INFXSAGG1RT,RT_DOMAIN(did)%SFCHEADAGG1RT,&
+             RT_DOMAIN(did)%SFCHEADAGGRT,&
+             nlst_rt(did)%DTRT, &
+             nlst_rt(did)%DT,RT_DOMAIN(did)%LAKE_INFLOTRT,&
+             RT_DOMAIN(did)%QBDRYTRT,RT_DOMAIN(did)%QSUBBDRYTRT,&
+             RT_DOMAIN(did)%QSTRMVOLTRT,RT_DOMAIN(did)%q_sfcflx_x,&
+             RT_DOMAIN(did)%q_sfcflx_y,RT_DOMAIN(did)%LKSATFAC,&
+             RT_DOMAIN(did)%OVROUGHRTFAC,rt_domain(did)%dist_lsm(:,:,9) )
+
+            QSTRMVOLRT_TS = RT_DOMAIN(did)%QSTRMVOLRT-QSTRMVOLRT_DUM
+            LAKE_INFLORT_TS = RT_DOMAIN(did)%LAKE_INFLORT-LAKE_INFLORT_DUM
+
+#ifdef HYDRO_D
+           write(6,*) "*****yw******end drive_RT "
+#endif
+        end if
+
+
+
+!------------------------------------------------------------------
+!DJG Begin GW/Baseflow Routines
+!-------------------------------------------------------------------
+
+  IF (nlst_rt(did)%GWBASESWCRT.GE.1) THEN     ! Switch to activate/specify GW/Baseflow
+
+!  IF (nlst_rt(did)%GWBASESWCRT.GE.1000) THEN     ! Switch to activate/specify GW/Baseflow
+
+    If (nlst_rt(did)%GWBASESWCRT.EQ.1.OR.nlst_rt(did)%GWBASESWCRT.EQ.2) Then   ! Call simple bucket baseflow scheme
+
+#ifdef HYDRO_D
+           write(6,*) "*****yw******start simp_gw_buck "
+#endif
+
+       call simp_gw_buck(RT_DOMAIN(did)%ix,RT_DOMAIN(did)%jx,RT_DOMAIN(did)%ixrt,&
+             RT_DOMAIN(did)%jxrt,RT_DOMAIN(did)%numbasns,RT_DOMAIN(did)%basns_area,&
+             RT_DOMAIN(did)%gwsubbasmsk, RT_DOMAIN(did)%INFXSRT, &
+             RT_DOMAIN(did)%SOLDRAIN, &
+             RT_DOMAIN(did)%z_gwsubbas,&
+             RT_DOMAIN(did)%qin_gwsubbas,RT_DOMAIN(did)%qout_gwsubbas,&
+             RT_DOMAIN(did)%qinflowbase,&
+             RT_DOMAIN(did)%gw_strm_msk,RT_DOMAIN(did)%gwbas_pix_ct, &
+             RT_DOMAIN(did)%dist,nlst_rt(did)%DT,&
+             RT_DOMAIN(did)%gw_buck_coeff,RT_DOMAIN(did)%gw_buck_exp, &
+             RT_DOMAIN(did)%z_max,&
+             nlst_rt(did)%GWBASESWCRT,nlst_rt(did)%OVRTSWCRT)
+
+
+#ifdef MPP_LAND
+      if(my_id .eq. IO_id) then
+#endif
+
+       open (unit=51,file='GW_inflow.txt',form='formatted',&
+             status='unknown',position='append')
+       open (unit=52,file='GW_outflow.txt',form='formatted',&
+             status='unknown',position='append')
+       open (unit=53,file='GW_zlev.txt',form='formatted',&
+             status='unknown',position='append')
+       do i=1,RT_DOMAIN(did)%numbasns
+          write (51,951) i,nlst_rt(did)%olddate,rt_domain(did)%qin_gwsubbas(i)
+951        FORMAT(I3,1X,A19,1X,F11.3)
+          write (52,951) i,nlst_rt(did)%olddate,rt_domain(did)%qout_gwsubbas(i)
+          write (53,951) i,nlst_rt(did)%olddate,rt_domain(did)%z_gwsubbas(i)
+       end do
+       close(51)
+       close(52)
+       close(53)
+#ifdef MPP_LAND
+     endif
+#endif
+
+#ifdef HYDRO_D 
+           write(6,*) "*****yw******end simp_gw_buck "
+#endif
+
+!!!For parameter setup runs output the percolation for each basin,
+!!!otherwise comment out this output...
+    else if (nlst_rt(did)%GWBASESWCRT .eq. 3) then
+
+#ifdef HYDRO_D
+           write(6,*) "*****bf******start 2d_gw_model "
+#endif
+
+           DX = abs(nlst_rt(did)%DXRT0 * nlst_rt(did)%AGGFACTRT)
+           
+           call gwstep(gw2d(did)%ix, gw2d(did)%jx, gw2d(did)%dx, &
+			gw2d(did)%ltype, gw2d(did)%elev, gw2d(did)%bot, &
+			gw2d(did)%hycond, gw2d(did)%poros, gw2d(did)%compres, &
+			gw2d(did)%ho, gw2d(did)%h, gw2d(did)%convgw, &
+			gw2d(did)%ebot, gw2d(did)%eocn, gw2d(did)%dt, &
+			gw2d(did)%istep)
+           
+           
+! bftodo head postprocessing block 
+! GW-SOIL-CHANNEL interaction section
+	  gw2d(did)%ho = gw2d(did)%h
+
+#ifdef HYDRO_D
+           write(6,*) "*****bf******end 2d_gw_model "
+#endif
+      
+    End if
+
+  END IF    !DJG (End if for RTE SWC activation)
+!------------------------------------------------------------------
+!DJG End GW/Baseflow Routines
+!-------------------------------------------------------------------
+
+!-------------------------------------------------------------------
+!-------------------------------------------------------------------
+!DJG,DNY  Begin Channel and Lake Routing Routines
+!-------------------------------------------------------------------
+  IF (nlst_rt(did)%CHANRTSWCRT.EQ.1 .or. nlst_rt(did)%CHANRTSWCRT.EQ.2) THEN
+ 
+    call drive_CHANNEL(RT_DOMAIN(did)%timestep_flag,RT_DOMAIN(did)%IXRT,RT_DOMAIN(did)%JXRT, &
+       nlst_rt(did)%SUBRTSWCRT, RT_DOMAIN(did)%QSUBRT, &
+       LAKE_INFLORT_TS, QSTRMVOLRT_TS,&
+       RT_DOMAIN(did)%TO_NODE, RT_DOMAIN(did)%FROM_NODE, RT_DOMAIN(did)%TYPEL,&
+       RT_DOMAIN(did)%ORDER, RT_DOMAIN(did)%MAXORDER, RT_DOMAIN(did)%NLINKS,&
+       RT_DOMAIN(did)%CH_NETLNK, RT_DOMAIN(did)%CH_NETRT, &
+       RT_DOMAIN(did)%LAKE_MSKRT, nlst_rt(did)%DT, nlst_rt(did)%DTRT, &
+       RT_DOMAIN(did)%MUSK, RT_DOMAIN(did)%MUSX,  RT_DOMAIN(did)%QLINK, &
+       RT_DOMAIN(did)%HLINK, RT_DOMAIN(did)%ELRT,RT_DOMAIN(did)%CHANLEN,&
+       RT_DOMAIN(did)%MannN,RT_DOMAIN(did)%So, RT_DOMAIN(did)%ChSSlp, &
+       RT_DOMAIN(did)%Bw,&
+       RT_DOMAIN(did)%RESHT, RT_DOMAIN(did)%HRZAREA, RT_DOMAIN(did)%LAKEMAXH,&
+       RT_DOMAIN(did)%WEIRC, RT_DOMAIN(did)%WEIRL, RT_DOMAIN(did)%ORIFICEC, &
+       RT_DOMAIN(did)%ORIFICEA, &
+       RT_DOMAIN(did)%ORIFICEE, RT_DOMAIN(did)%ZELEV, RT_DOMAIN(did)%CVOL, &
+       RT_DOMAIN(did)%NLAKES, RT_DOMAIN(did)%QLAKEI, RT_DOMAIN(did)%QLAKEO,&
+       RT_DOMAIN(did)%LAKENODE, RT_DOMAIN(did)%dist, &
+       RT_DOMAIN(did)%QINFLOWBASE, RT_DOMAIN(did)%CHANXI, &
+       RT_DOMAIN(did)%CHANYJ, nlst_rt(did)%channel_option, &
+       RT_DOMAIN(did)%RETDEP_CHAN &
+       , RT_DOMAIN(did)%node_area &
+#ifdef MPP_LAND
+       ,RT_DOMAIN(did)%lake_index,RT_DOMAIN(did)%link_location,&
+       RT_DOMAIN(did)%mpp_nlinks,RT_DOMAIN(did)%nlinks_index, &
+       RT_DOMAIN(did)%yw_mpp_nlinks  &
+#endif
+       )
+  endif
+
+#ifdef HYDRO_D
+           write(6,*) "*****yw******end drive_CHANNEL "
+#endif
+
+      end subroutine  exeRouting
+
+      subroutine time_seconds(i3)
+          integer time_array(8)
+          real*8 i3
+          call date_and_time(values=time_array)
+          i3 = time_array(4)*24*3600+time_array(5) * 3600 + time_array(6) * 60 + &
+                time_array(7) + 0.001 * time_array(8)
+          return
+      end subroutine time_seconds
+
+
diff --git a/wrfv2_fire/hydro/Run/HYDRO.TBL b/wrfv2_fire/hydro/Run/HYDRO.TBL
new file mode 100644
index 00000000..1d691a08
--- /dev/null
+++ b/wrfv2_fire/hydro/Run/HYDRO.TBL
@@ -0,0 +1,51 @@
+     28 USGS for OV_ROUGH
+   SFC_ROUGH'
+     0.025,    'Urban and Built-Up Land'  
+     0.035,    'Dryland Cropland and Pasture' 
+     0.035,    'Irrigated Cropland and Pasture' 
+     0.055,    'Mixed Dryland/Irrigated Cropland and Pasture' 
+     0.035,    'Cropland/Grassland Mosaic'
+     0.068,    'Cropland/Woodland Mosaic' 
+     0.055,    'Grassland' 
+     0.055,    'Shrubland' 
+     0.055,    'Mixed Shrubland/Grassland' 
+     0.055,    'Savanna' 
+     0.200,    'Deciduous Broadleaf Forest' 
+     0.200,    'Deciduous Needleleaf Forest' 
+     0.200,    'Evergreen Broadleaf Forest'
+     0.200,    'Evergreen Needleleaf Forest'  
+     0.200,    'Mixed Forest' 
+     0.005,    'Water Bodies' 
+     0.070,    'Herbaceous Wetland' 
+     0.070,    'Wooded Wetland' 
+     0.035,    'Barren or Sparsely Vegetated' 
+     0.055,    'Herbaceous Tundra' 
+     0.055,    'Wooded Tundra' 
+     0.055,    'Mixed Tundra' 
+     0.055,    'Bare Ground Tundra' 
+     0.010,    'Snow or Ice' 
+     0.010,    'Playa' 
+     0.100,    'Lava'   
+     0.010,    'White Sand' 
+     0.005,    'Non-Ocean Water Bodies'
+19, for SATDK
+SATDK     MAXSMC    REFSMC   WLTSMC  QTZ    '
+1.07E-6,  0.339,    0.236,   0.010,  0.92, 'SAND'
+1.41E-5,  0.421,    0.383,   0.028,  0.82, 'LOAMY SAND'
+5.23E-6,  0.434,    0.383,   0.047,  0.60, 'SANDY LOAM'
+2.81E-6,  0.476,    0.360,   0.084,  0.25, 'SILT LOAM'
+2.81E-6,  0.476,    0.383,   0.084,  0.10, 'SILT'
+3.38E-6,  0.439,    0.329,   0.066,  0.40, 'LOAM'
+4.45E-6,  0.404,    0.314,   0.067,  0.60, 'SANDY CLAY LOAM'
+2.04E-6,  0.464,    0.387,   0.120,  0.10, 'SILTY CLAY LOAM'
+2.45E-6,  0.465,    0.382,   0.103,  0.35, 'CLAY LOAM'
+7.22E-6,  0.406,    0.338,   0.100,  0.52, 'SANDY CLAY'
+1.34E-6,  0.468,    0.404,   0.126,  0.10, 'SILTY CLAY'
+9.74E-7,  0.468,    0.412,   0.138,  0.25, 'CLAY'
+3.38E-6,  0.439,    0.329,   0.066,  0.05, 'ORGANIC MATERIAL'
+    0.0,  1.0,      0.0,     0.0,    0.60, 'WATER'
+1.75E-5,  0.20,     0.170,   0.006,  0.07, 'BEDROCK'
+1.41E-5,  0.421,    0.283,   0.028,  0.25, 'OTHER(land-ice)'
+9.74E-7,  0.468,    0.454,   0.030,  0.60, 'PLAYA'
+1.41E-4,  0.200,    0.170,   0.006,  0.52, 'LAVA'
+1.07E-6,  0.339,    0.236,    0.01,  0.92, 'WHITE SAND'
diff --git a/wrfv2_fire/hydro/Run/hydro.namelist b/wrfv2_fire/hydro/Run/hydro.namelist
new file mode 100644
index 00000000..376d762a
--- /dev/null
+++ b/wrfv2_fire/hydro/Run/hydro.namelist
@@ -0,0 +1,102 @@
+&HYDRO_nlist
+
+!!!! SYSTEM COUPLING !!!!
+!Specify what is being coupled with WRF-Hydro:  1=HRLDAS (offline Noah-LSM), 2=WRF, 3=NASA/LIS, 4=CLM
+ sys_cpl = 1
+
+
+
+
+!!!! MODEL INPUT DATA FILES !!!
+!Specify land surface model gridded static input data file...(e.g.: "geo_em.d03.nc")
+ GEO_STATIC_FLNM = "./DOMAIN/geo_em.d01.nc.conus_1km"
+
+!Specify the static high-resolution routing terrain input data file...(e.g.: "Fulldom_hires_hydrofile.nc")
+ GEO_FINEGRID_FLNM = "./DOMAIN/Fulldom_hires_netcdf_file_nhd_mask.nc"
+
+!Specify the name of the restart file if starting from restart...comment out with '!' if not...
+!RESTART_FILE  = 'HYDRO_RST.2013-09-11_02:00_DOMAIN3'
+
+
+
+
+!!!! MODEL SETUP AND I/O CONTROL !!!!
+!Specify the domain or nest number identifier...(integer)
+ IGRID = 1
+
+!Specify the restart file write frequency...(minutes, value of -99999 provides monthly restart files)
+!rst_dt = -99999
+ rst_dt = 360   
+
+!Specify the output file write frequency...(minutes)
+ out_dt = 60 ! minutes
+
+!Specify the number of output times to be contained within each output history file...(integer)
+!   SET = 1 WHEN RUNNING CHANNEL ROUTING ONLY/CALIBRATION SIMS!!!
+!   SET = 1 WHEN RUNNING COUPLED TO WRF!!!
+ SPLIT_OUTPUT_COUNT = 1
+
+!Switch to overwrite the restart or initialization of soil variables with values from the routing restart file (=0-no reset, 1-yes reset using routing restart)
+ rst_typ = 1
+
+!Switch to set restart accumulation variables = 0 (0-no reset, 1-yes reset to 0.0)
+ RSTRT_SWC = 0
+
+!Switches to specify if routing restart files are to be read in/output in a flat binary format (=0 no, 1-yes read/write in binary format)
+ rst_bi_in = 1   ! read restart in binary format
+ rst_bi_out = 1  ! output restart in binary format
+
+!Routing output netcdf file control...(=0 no files written, =1 files are written)
+ CHRTOUT_DOMAIN = 1           ! Netcdf and ASCII point timeseries output at all channel points and at user-define points (frxst_pts)
+ CHRTOUT_GRID = 1             ! Netcdf grid of channel streamflow values
+ LSMOUT_DOMAN = 0             ! Netcdf grid of variables passed between LSM and routing components
+ RTOUT_DOMAIN = 1             ! Netcdf grid of terrain routing variables on routing grid
+ output_gw = 0                ! Netcdf grid of groundwater-baseflow bucket information
+ outlake  = 0                 ! Netcdf point timeseries output of lake information
+
+!Specify the minimum stream order to output to netcdf point file...(integer)
+!Note: lower value of stream order produces more output.
+ order_to_write = 1
+
+
+
+
+!!!! PHYSICS OPTIONS AND RELATED SETTINGS !!!!
+!Switch for terrain adjustment of incoming solar radiation: 0=no, 1=yes
+!Note: This option is not yet active in Verion 3.0...
+!      WRF has this capability so be careful not to double apply the correction!!!
+ TERADJ_SOLAR = 0
+
+!Specify the grid spacing of the terrain routing grid...(meters)
+ DXRT = 250
+!Specify the integer multiple between the land model grid and the terrain routing grid...(integer)
+ AGGFACTRT = 4
+!Specify the routing model timestep...(seconds)
+ DTRT = 4
+
+
+!Switch activate saturated subsurface routing...(0=no, 1=yes)
+ SUBRTSWCRT = 1
+
+
+!Switch activate surface overland flow routing...(0=no, 1=yes)
+ OVRTSWCRT = 1
+!Switch to specify channel routing Routing Option: 1=Seepest Descent (D8) 2=CASC2D
+ rt_option    = 1
+
+
+!Switch to activate channel routing option...((0=no, 1=yes)
+ CHANRTSWCRT = 1
+!Switch specify channel routing option: 1=Muskingam-reach, 2=Musk.-Cunge-reach, 3=Diff.Wave-gridded
+ channel_option =3
+!Specify the reach file for reach-based routing options...(Only req'd for channel_options 1&2)
+ route_link_f = ""
+
+
+!Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through)
+ GWBASESWCRT = 0
+!Specify baseflow/bucket model initialization...(0=cold start from table, 1=restart file)
+ GW_RESTART = 0
+!Groundwater/baseflow mask specified on land surface model grid...(Only required if baseflow bucket model is active)
+ gwbasmskfil = ""
+/
diff --git a/wrfv2_fire/hydro/arc/Makefile.Noah b/wrfv2_fire/hydro/arc/Makefile.Noah
new file mode 100644
index 00000000..c0ac9977
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/Makefile.Noah
@@ -0,0 +1,30 @@
+# Makefile 
+all:
+	(rm -f Run/wrf_hydro.exe   )
+	(make -f Makefile.comm BASIC)
+	@if [ -d "LandModel_cpl" ]; then \
+	(cd LandModel_cpl; make) \
+	fi
+	if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \
+		(cd lib;rm -f librapid.a); \
+	fi
+	if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \
+		(cd Rapid_routing; make -f makefile.cpl rapid); \
+	fi
+
+	@if [ -d "LandModel" ]; then \
+	(cd LandModel; make ; rm -f ../../Run/wrf_hydro.exe; mv Run/Noah_hrldas_beta ../../Run/wrf_hydro.exe  ) \
+	fi
+
+clean:
+	@if [ -d "LandModel_cpl" ]; then \
+	(cd LandModel_cpl; make clean) \
+	fi
+	(make -f Makefile.comm clean)
+	@if [ -d "LandModel" ]; then \
+	(cd LandModel; make clean) \
+	fi
+	if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \
+		(cd Rapid_routing; make -f makefile.cpl clean); \
+	fi
+	(rm -f */*.mod */*.o lib/*.a Run/wrf_hydro.exe)
diff --git a/wrfv2_fire/hydro/arc/Makefile.NoahMP b/wrfv2_fire/hydro/arc/Makefile.NoahMP
new file mode 100644
index 00000000..e4b2aa43
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/Makefile.NoahMP
@@ -0,0 +1,30 @@
+# Makefile 
+all:
+	(rm -f Run/wrf_hydro.exe   )
+	(make -f Makefile.comm BASIC)
+	@if [ -d "LandModel_cpl" ]; then \
+	(cd LandModel_cpl; make) \
+	fi
+	if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \
+		(cd lib;rm -f librapid.a); \
+	fi
+	if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \
+		(cd Rapid_routing; make -f makefile.cpl rapid); \
+	fi
+
+	@if [ -d "LandModel" ]; then \
+	(cd LandModel; make ; rm -f ../../Run/wrf_hydro.exe; mv run/hrldas.exe  ../../Run/wrf_hydro.exe  ) \
+	fi
+
+clean:
+	@if [ -d "LandModel_cpl" ]; then \
+	(cd LandModel_cpl; make clean) \
+	fi
+	(make -f Makefile.comm clean)
+	@if [ -d "LandModel" ]; then \
+	(cd LandModel; make clean) \
+	fi
+	if [ $(WRF_HYDRO_RAPID) -eq 1 ]; then \
+		(cd Rapid_routing; make -f makefile.cpl clean); \
+	fi
+	(rm -f */*.mod */*.o lib/*.a Run/wrf_hydro.exe)
diff --git a/wrfv2_fire/hydro/arc/Makefile.mpp b/wrfv2_fire/hydro/arc/Makefile.mpp
new file mode 100644
index 00000000..a494e8df
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/Makefile.mpp
@@ -0,0 +1,17 @@
+# Makefile 
+
+all:
+	(make -f Makefile.comm BASIC)
+
+BASIC:
+	(cd MPP     ; make -f Makefile)
+	(cd Data_Rec     ; make -f Makefile)
+	(cd Routing; make -f Makefile)
+	(cd HYDRO_drv;   make -f Makefile)
+
+clean:
+	(cd Data_Rec; make -f Makefile clean)
+	(cd HYDRO_drv; make -f Makefile clean)
+	(cd MPP; make -f Makefile clean)
+	(cd Routing;    make -f Makefile clean)
+	(rm -f lib/*.a */*.mod */*.o CPL/*/*.o CPL/*/*.mod)
diff --git a/wrfv2_fire/hydro/arc/Makefile.seq b/wrfv2_fire/hydro/arc/Makefile.seq
new file mode 100644
index 00000000..386935ce
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/Makefile.seq
@@ -0,0 +1,36 @@
+# Makefile 
+
+all:
+	(make -f Makefile BASIC)
+
+BASIC:
+	(cd Data_Rec     ; make -f Makefile)
+	(cd Routing; make -f Makefile)
+        ifeq ($(WRF_HYDRO_NUDGING),-DWRF_HYDRO_NUDGING)
+	(cd nudging; make -f Makefile)
+        endif
+	(cd HYDRO_drv;   make -f Makefile)
+
+LIS:
+	(make -f Makefile BASIC)
+	(cd LIS_cpl  ;   make -f Makefile)
+
+CLM:
+	(make -f Makefile BASIC)
+	(cd CLM_cpl  ;   make -f Makefile)
+
+WRF:
+	(make -f Makefile BASIC)
+	(cd WRF_cpl  ;   make -f Makefile)
+
+HYDRO:
+	(make -f Makefile BASIC)
+
+clean:
+	(cd Data_Rec; make -f Makefile clean)
+	(cd HYDRO_drv; make -f Makefile clean)
+        ifeq ($(WRF_HYDRO_NUDGING),-DWRF_HYDRO_NUDGING)
+	(cd nudging; make -f Makefile clean)
+        endif
+	(cd Routing;    make -f Makefile clean)
+	(rm -f lib/*.a */*.mod CPL/*/*.o CPL/*/*.mod)
diff --git a/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r b/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r
new file mode 100644
index 00000000..880e8089
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.mpp.IBM.xlf90_r
@@ -0,0 +1,43 @@
+.IGNORE:
+
+ifeq ($(HYDRO_REALTIME),1)
+HYDRO_REALTIME = -DHYDRO_REALTIME
+else
+HYDRO_REALTIME =
+endif
+
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME)
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(WRF_HYDRO_RAPID),1)
+WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME)
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+RM		=	rm -f 
+RMD		=	rm -f 
+COMPILER90=	mpxlf90_r
+F90FLAGS  =     -O2 -qfree=f90 -c -w -qspill=20000 -qmaxmem=64000
+LDFLAGS  =     -O2 -qfree=f90  -w -qspill=20000 -qmaxmem=64000
+MODFLAG	=	-I./ -I ../MPP -I../../MPP -I ../mod
+LDFLAGS	=	
+CPP	=       cpp
+LIBS 	=	
+CPPFLAGS	= -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+NETCDFINC	=	$(NETCDF_INC) 
+NETCDFLIB	=	-L$(NETCDF_LIB) -lnetcdff -lnetcdf
+
diff --git a/wrfv2_fire/hydro/arc/macros.mpp.gfort b/wrfv2_fire/hydro/arc/macros.mpp.gfort
new file mode 100644
index 00000000..c58e5ce1
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.mpp.gfort
@@ -0,0 +1,46 @@
+.IGNORE:
+
+ifeq ($(SPATIAL_SOIL),1)
+SPATIAL_SOIL = -DSPATIAL_SOIL
+else
+SPATIAL_SOIL = 
+endif
+
+ifeq ($(HYDRO_REALTIME),1)
+HYDRO_REALTIME = -DHYDRO_REALTIME
+else
+HYDRO_REALTIME =
+endif
+
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME)
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(WRF_HYDRO_RAPID),1)
+WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME)
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT =
+endif
+
+RMD		=	rm -f
+COMPILER90=	mpif90  
+F90FLAGS  =       -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 
+MODFLAG	=	-I"./" -I"../../MPP" -I"../MPP" -I"../mod"
+LDFLAGS	=	
+CPP	=       cpp
+CPPFLAGS	=        -P -xassembler-with-cpp -traditional -DMPP_LAND -I"../Data_Rec" $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+LIBS 	=	
+NETCDFINC       =       $(NETCDF_INC)
+NETCDFLIB       =       -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.mpp.ifort b/wrfv2_fire/hydro/arc/macros.mpp.ifort
new file mode 100644
index 00000000..ce3bc096
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.mpp.ifort
@@ -0,0 +1,96 @@
+## If you have multiple mpi biulds on a single machine
+## this example may be relevant to you. 
+## Ex: The hydro-c1 machine has mpi and netcdf built against portland 
+##     fortran in the PATH. However mpi and netcd built against intel 
+##     fortran is also available. Here's how I build WRF HYDRO against 
+##     intel
+##     Below, in this file, I make the changes:
+##       COMPILER90 = $(ifortCompiler90)
+##       LDFLAGS    = $(ifortLdFlags)
+##       NETCDFINC  = $(ifortNetcdfInc)
+##       NETCDFLIB  = -L$(ifortNetcdfLib) -lnetcdff -lnetcdf
+##     In my ~/.bashrc I have
+##       ## WRF HYDRO
+##       export NETCDF=/opt/netcdf
+##       export WRF_HYDRO=1
+##       export HYDRO_D=1
+##       ### manage ifort on hydro
+##       export ifortNetcdfLib="/opt/netcdf-4.3.0+ifort-12.1/lib/"
+##       export ifortNetcdfInc="/opt/netcdf-4.3.0+ifort-12.1/include/"
+##       # RPATH for ifort (pgi is already default so no need)
+##       ifortMpiLib="/opt/openmpi-1.10.0-intel/lib/"
+##       export ifortLdFlags="-Wl,-rpath,${ifortNetcdfLib}:${ifortMpiLib} -L${ifortNetcdfLib} -L${ifortMpiLib}"
+##       export ifortCompiler90='/opt/openmpi-1.10.0-intel/bin/mpif90'
+##       # Aliases for invoking ifort
+##       alias impirun='/opt/openmpi-1.10.0-intel/bin/mpirun'
+##       alias iman='man -M/opt/openmpi+intel/man'
+##       # Bonus: Check your wrf hydro environment - up you to maintain to your needs.
+##       alias henv='printenv | egrep -i "(HYDRO|NUDG|PRECIP|CHAN_CONN|^NETCDF|^LDFLAGS|^ifort)" | egrep -v PWD'
+
+.IGNORE:
+
+ifeq ($(SPATIAL_SOIL),1)
+SPATIAL_SOIL = -DSPATIAL_SOIL
+else
+SPATIAL_SOIL = 
+endif
+
+ifeq ($(HYDRO_REALTIME),1)
+HYDRO_REALTIME = -DHYDRO_REALTIME
+else
+HYDRO_REALTIME =
+endif
+
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME)
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(WRF_HYDRO_RAPID),1)
+WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME)
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+ifeq ($(WRF_HYDRO_NUDGING),1)
+WRF_HYDRO_NUDGING = -DWRF_HYDRO_NUDGING
+else
+WRF_HYDRO_NUDGING = 
+endif
+
+ifeq ($(OUTPUT_CHAN_CONN),1)
+OUTPUT_CHAN_CONN = -DOUTPUT_CHAN_CONN
+else
+OUTPUT_CHAN_CONN = 
+endif
+
+ifeq ($(PRECIP_DOUBLE),1)
+PRECIP_DOUBLE = -DPRECIP_DOUBLE
+else
+PRECIP_DOUBLE = 
+endif
+
+
+RMD	    = rm -f
+COMPILER90  = mpif90
+FORMAT_FREE = -FR
+BYTESWAPIO  = -convert big_endian
+F90FLAGS    = -w -c -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO)
+MODFLAG	    = -I./ -I ../../MPP -I ../MPP -I ../mod
+LDFLAGS	    =
+CPP	    = cpp
+CPPFLAGS    =  -P -traditional -DMPP_LAND -I ../Data_Rec $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) $(WRF_HYDRO_NUDGING) $(OUTPUT_CHAN_CONN) $(PRECIP_DOUBLE)
+LIBS 	    =	
+NETCDFINC   = $(NETCDF_INC)
+NETCDFLIB   = -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.mpp.ifort.luna b/wrfv2_fire/hydro/arc/macros.mpp.ifort.luna
new file mode 100644
index 00000000..24778bc2
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.mpp.ifort.luna
@@ -0,0 +1,96 @@
+## If you have multiple mpi biulds on a single machine
+## this example may be relevant to you. 
+## Ex: The hydro-c1 machine has mpi and netcdf built against portland 
+##     fortran in the PATH. However mpi and netcd built against intel 
+##     fortran is also available. Here's how I build WRF HYDRO against 
+##     intel
+##     Below, in this file, I make the changes:
+##       COMPILER90 = $(ifortCompiler90)
+##       LDFLAGS    = $(ifortLdFlags)
+##       NETCDFINC  = $(ifortNetcdfInc)
+##       NETCDFLIB  = -L$(ifortNetcdfLib) -lnetcdff -lnetcdf
+##     In my ~/.bashrc I have
+##       ## WRF HYDRO
+##       export NETCDF=/opt/netcdf
+##       export WRF_HYDRO=1
+##       export HYDRO_D=1
+##       ### manage ifort on hydro
+##       export ifortNetcdfLib="/opt/netcdf-4.3.0+ifort-12.1/lib/"
+##       export ifortNetcdfInc="/opt/netcdf-4.3.0+ifort-12.1/include/"
+##       # RPATH for ifort (pgi is already default so no need)
+##       ifortMpiLib="/opt/openmpi-1.10.0-intel/lib/"
+##       export ifortLdFlags="-Wl,-rpath,${ifortNetcdfLib}:${ifortMpiLib} -L${ifortNetcdfLib} -L${ifortMpiLib}"
+##       export ifortCompiler90='/opt/openmpi-1.10.0-intel/bin/mpif90'
+##       # Aliases for invoking ifort
+##       alias impirun='/opt/openmpi-1.10.0-intel/bin/mpirun'
+##       alias iman='man -M/opt/openmpi+intel/man'
+##       # Bonus: Check your wrf hydro environment - up you to maintain to your needs.
+##       alias henv='printenv | egrep -i "(HYDRO|NUDG|PRECIP|CHAN_CONN|^NETCDF|^LDFLAGS|^ifort)" | egrep -v PWD'
+
+.IGNORE:
+
+ifeq ($(SPATIAL_SOIL),1)
+SPATIAL_SOIL = -DSPATIAL_SOIL
+else
+SPATIAL_SOIL = 
+endif
+
+ifeq ($(HYDRO_REALTIME),1)
+HYDRO_REALTIME = -DHYDRO_REALTIME
+else
+HYDRO_REALTIME =
+endif
+
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME)
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(WRF_HYDRO_RAPID),1)
+WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME)
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+ifeq ($(WRF_HYDRO_NUDGING),1)
+WRF_HYDRO_NUDGING = -DWRF_HYDRO_NUDGING
+else
+WRF_HYDRO_NUDGING = 
+endif
+
+ifeq ($(OUTPUT_CHAN_CONN),1)
+OUTPUT_CHAN_CONN = -DOUTPUT_CHAN_CONN
+else
+OUTPUT_CHAN_CONN = 
+endif
+
+ifeq ($(PRECIP_DOUBLE),1)
+PRECIP_DOUBLE = -DPRECIP_DOUBLE
+else
+PRECIP_DOUBLE = 
+endif
+
+
+RMD	    = rm -f
+COMPILER90  = ftn
+FORMAT_FREE = -FR
+BYTESWAPIO  = -convert big_endian
+F90FLAGS    = -w -c -ftz -align all -fno-alias -fp-model precise $(FORMAT_FREE) $(BYTESWAPIO)
+MODFLAG	    = -I./ -I ../../MPP -I ../MPP -I ../mod
+LDFLAGS	    =
+CPP	    = cpp
+CPPFLAGS    =  -P -traditional -DMPP_LAND -I ../Data_Rec $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) $(WRF_HYDRO_NUDGING) $(OUTPUT_CHAN_CONN) $(PRECIP_DOUBLE)
+LIBS 	    =	
+NETCDFINC   = $(NETCDF_INC)
+NETCDFLIB   = -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.mpp.linux b/wrfv2_fire/hydro/arc/macros.mpp.linux
new file mode 100644
index 00000000..203bad57
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.mpp.linux
@@ -0,0 +1,67 @@
+.IGNORE:
+
+ifeq ($(SPATIAL_SOIL),1)
+SPATIAL_SOIL = -DSPATIAL_SOIL
+else
+SPATIAL_SOIL = 
+endif
+
+ifeq ($(HYDRO_REALTIME),1)
+HYDRO_REALTIME = -DHYDRO_REALTIME
+else
+HYDRO_REALTIME =
+endif
+
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME)
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(WRF_HYDRO_RAPID),1)
+WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME)
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+ifeq ($(WRF_HYDRO_NUDGING),1)
+WRF_HYDRO_NUDGING = -DWRF_HYDRO_NUDGING
+else
+WRF_HYDRO_NUDGING = 
+endif
+
+ifeq ($(OUTPUT_CHAN_CONN),1)
+OUTPUT_CHAN_CONN = -DOUTPUT_CHAN_CONN
+else
+OUTPUT_CHAN_CONN = 
+endif
+
+ifeq ($(PRECIP_DOUBLE),1)
+PRECIP_DOUBLE = -DPRECIP_DOUBLE
+else
+PRECIP_DOUBLE = 
+endif
+
+
+RM		=	rm -f  
+RMD		=	rm -f    
+COMPILER90=	mpif90
+F90FLAGS  =     -Mfree -c -byteswapio -O2 -Kieee 
+LDFLAGS  =      $(F90FLAGS)
+MODFLAG	=	-I./ -I ../../MPP -I ../MPP -I ../mod 
+LDFLAGS	=	
+CPP	=       cpp
+CPPFLAGS	=        -P -traditional -DMPP_LAND -I../Data_Rec $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) $(WRF_HYDRO_NUDGING) $(OUTPUT_CHAN_CONN) $(PRECIP_DOUBLE)
+LIBS 	=	
+NETCDFINC	=	$(NETCDF_INC) 
+NETCDFLIB	=	-Wl,-rpath,$(NETCDF_LIB) -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r b/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r
new file mode 100644
index 00000000..099daa3b
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.seq.IBM.xlf90_r
@@ -0,0 +1,43 @@
+.IGNORE:
+
+ifeq ($(HYDRO_REALTIME),1)
+HYDRO_REALTIME = -DHYDRO_REALTIME
+else
+HYDRO_REALTIME =
+endif
+
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME)
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(WRF_HYDRO_RAPID),1)
+WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME)
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+
+
+RM		=	rm -f
+RMD		=	rm -f
+COMPILER90=	xlf90_r
+F90FLAGS  =       -c -O2 -qfree=f90 -qmaxmem=819200
+MODFLAG	=	-I./ -I ../../MPP -I ../MPP -I ../mod
+LDFLAGS	=	
+CPP	=       cpp  -P
+CPPFLAGS	=       -I../Data_Rec $(HYDRO_D) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+LIBS 	=	
+NETCDFINC       =       $(NETCDF_INC)
+NETCDFLIB       =       -L$(NETCDF_LIB) -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.seq.gfort b/wrfv2_fire/hydro/arc/macros.seq.gfort
new file mode 100644
index 00000000..dd6bdb3f
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.seq.gfort
@@ -0,0 +1,47 @@
+.IGNORE:
+
+ifeq ($(SPATIAL_SOIL),1)
+SPATIAL_SOIL = -DSPATIAL_SOIL
+else
+SPATIAL_SOIL = 
+endif
+
+ifeq ($(HYDRO_REALTIME),1)
+HYDRO_REALTIME = -DHYDRO_REALTIME
+else
+HYDRO_REALTIME =
+endif
+
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME)
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(WRF_HYDRO_RAPID),1)
+WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME)
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+
+RMD		=	rm -f
+COMPILER90=	gfortran
+F90FLAGS  =       -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 
+MODFLAG	=	-I./ -I../mod
+LDFLAGS	=	
+CPP	=       cpp
+CPPFLAGS	=        -P -xassembler-with-cpp -traditional -I"../Data_Rec" $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT)
+LIBS 	=	
+NETCDFINC       =       $(NETCDF_INC)
+NETCDFLIB       =       -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.seq.ifort b/wrfv2_fire/hydro/arc/macros.seq.ifort
new file mode 100644
index 00000000..7e16c80e
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.seq.ifort
@@ -0,0 +1,60 @@
+.IGNORE:
+
+ifeq ($(SPATIAL_SOIL),1)
+SPATIAL_SOIL = -DSPATIAL_SOIL
+else
+SPATIAL_SOIL = 
+endif
+
+ifeq ($(HYDRO_REALTIME),1)
+HYDRO_REALTIME = -DHYDRO_REALTIME
+else
+HYDRO_REALTIME =
+endif
+
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME)
+else
+WRF_HYDRO = 
+endif
+
+ifeq ($(WRF_HYDRO_RAPID),1)
+WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME)
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO) 
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+ifeq ($(WRF_HYDRO_NUDGING),1)
+WRF_HYDRO_NUDGING = -DWRF_HYDRO_NUDGING
+else
+WRF_HYDRO_NUDGING = 
+endif
+
+ifeq ($(OUTPUT_CHAN_CONN),1)
+OUTPUT_CHAN_CONN = -DOUTPUT_CHAN_CONN
+else
+OUTPUT_CHAN_CONN = 
+endif
+
+RMD		=	rm -f
+COMPILER90=	ifort 
+##F90FLAGS  =       -w -c -ffree-form -ffree-line-length-none -fconvert=big-endian -frecord-marker=4 
+F90FLAGS  =       -w -c -ftz -align all -fno-alias -fp-model precise -FR -convert big_endian
+
+MODFLAG	=	-I./  -I ../mod
+LDFLAGS	=	
+CPP	=       cpp
+CPPFLAGS	=        -P -traditional -I ../Data_Rec $(HYDRO_D) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) $(WRF_HYDRO_NUDGING) $(OUTPUT_CHAN_CONN)
+LIBS 	=	
+NETCDFINC       =       $(NETCDF_INC)
+NETCDFLIB       =       -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/arc/macros.seq.linux b/wrfv2_fire/hydro/arc/macros.seq.linux
new file mode 100644
index 00000000..367e3421
--- /dev/null
+++ b/wrfv2_fire/hydro/arc/macros.seq.linux
@@ -0,0 +1,61 @@
+.IGNORE:
+
+ifeq ($(SPATIAL_SOIL),1)
+SPATIAL_SOIL = -DSPATIAL_SOIL
+else
+SPATIAL_SOIL = 
+endif
+
+ifeq ($(HYDRO_REALTIME),1)
+HYDRO_REALTIME = -DHYDRO_REALTIME
+else
+HYDRO_REALTIME =
+endif
+
+ifeq ($(WRF_HYDRO),1)
+WRF_HYDRO = -DWRF_HYDRO $(HYDRO_REALTIME)
+else
+WRF_HYDRO =
+endif
+
+ifeq ($(WRF_HYDRO_RAPID),1)
+WRF_HYDRO = -DWRF_HYDRO -DWRF_HYDRO_RAPID $(HYDRO_REALTIME)
+endif
+
+ifeq ($(HYDRO_D),1)
+HYDRO_D = -DHYDRO_D $(WRF_HYDRO)
+else
+HYDRO_D =  $(WRF_HYDRO)
+endif
+
+ifeq ($(WRFIO_NCD_LARGE_FILE_SUPPORT),1)
+WRFIO_NCD_LARGE_FILE_SUPPORT = -DWRFIO_NCD_LARGE_FILE_SUPPORT 
+else
+WRFIO_NCD_LARGE_FILE_SUPPORT = 
+endif
+
+ifeq ($(WRF_HYDRO_NUDGING),1)
+WRF_HYDRO_NUDGING = -DWRF_HYDRO_NUDGING
+else
+WRF_HYDRO_NUDGING = 
+endif
+
+ifeq ($(OUTPUT_CHAN_CONN),1)
+OUTPUT_CHAN_CONN = -DOUTPUT_CHAN_CONN
+else
+OUTPUT_CHAN_CONN = 
+endif
+
+
+RMD		=	ls 
+RM		=	rm -f
+COMPILER90=	pgf90 
+F90FLAGS  =     -Mfree -Mfptrap -c -byteswapio -Ktrap=fp -O2 -Kieee
+LDFLAGS  =      $(F90FLAGS)
+MODFLAG	=	-I./ -I ../mod
+LDFLAGS	=	
+CPP	=       cpp
+CPPFLAGS	=        -P -traditional -I ../Data_Rec $(HYDRO_D) $(WRF_HYDRO) $(SPATIAL_SOIL) $(WRFIO_NCD_LARGE_FILE_SUPPORT) $(WRF_HYDRO_NUDGING) $(OUTPUT_CHAN_CONN)
+LIBS 	=	
+NETCDFINC       =       $(NETCDF_INC)
+NETCDFLIB       =       -Wl,-rpath,$(NETCDF_LIB) -L$(NETCDF_LIB) -lnetcdff -lnetcdf
diff --git a/wrfv2_fire/hydro/configure b/wrfv2_fire/hydro/configure
new file mode 100755
index 00000000..a98e9d1c
--- /dev/null
+++ b/wrfv2_fire/hydro/configure
@@ -0,0 +1,113 @@
+#!/usr/bin/perl
+
+  if(! defined($ENV{NETCDF_INC})){
+     if(defined($ENV{NETCDF})) {
+       $tt = `echo "NETCDF_INC = \${NETCDF}/include" > macros.tmp` ; 
+     } else {
+        print"Error: environment variable NETCDF_INC not defined. \n";
+        exit(0);
+     }
+   }
+
+  ${NETCDF_LIB} = $ENV{NETCDF_LIB};
+  if(! defined($ENV{NETCDF_LIB})){
+     if(defined($ENV{NETCDF})) {
+       $tt = `echo "NETCDF_LIB = \${NETCDF}/lib" >> macros.tmp` ; 
+       ${NETCDF_LIB} = $ENV{NETCDF}."/lib";
+     } else {
+       print"Error: environment variable NETCDF_LIB not defined. \n";
+       exit(0);
+     }
+  }
+  
+  if(! -e "${NETCDF_LIB}/libnetcdff.a"){
+    $tt = `echo "NETCDFLIB       =       -L${NETCDF_LIB} -lnetcdf" >> macros.tmp `;
+  }
+
+  if(-e macros) {system (rm -f macros);}
+#  if(-e Makefile) {system "rm -f Makefile" ;}
+
+#  system("cp arc/Makefile ."); 
+
+  if($#ARGV == 0) {
+     $response = shift(@ARGV) ;
+     print("Configure hydro: $response \n");
+  }else {
+     print "Please select from following supported options. \n\n";
+
+     print "   1. Linux PGI compiler sequential \n";
+     print "   2. Linux PGI compiler dmpar \n";
+     print "   3. IBM AIX compiler sequential, xlf90_r\n";
+     print "   4. IBM AIX compiler dmpar \n";
+     print "   5. Linux gfort compiler sequential \n";
+     print "   6. Linux gfort compiler dmpar      \n";
+     print "   7. Linux ifort compiler sequential \n";
+     print "   8. Linux ifort compiler dmpar      \n";
+     print "   9. Linux ifort compiler dmpar (WCOSS Luna)   \n";
+     print "   0. exit only \n";
+
+     printf "\nEnter selection [%d-%d] : ",0,9 ;
+
+     $response =  ;
+     chop($response);
+  }
+
+  use Switch;
+  switch ($response) {
+     case 1 { 
+              # sequential linux 
+              system "cp arc/macros.seq.linux macros"; 
+              system "cp arc/Makefile.seq Makefile.comm"; 
+            }
+
+     case 2 {
+              # mpp linux 
+              system "cp arc/macros.mpp.linux macros"; 
+              system "cp arc/Makefile.mpp Makefile.comm"; 
+            }
+
+     case 3 {
+              # sequential IBM AIX
+              system "cp arc/macros.seq.IBM.xlf90_r macros"; 
+              system "cp arc/Makefile.seq Makefile.comm"; 
+            }
+
+     case 4 {
+              # mpp IBM AIX
+              system "cp arc/macros.mpp.IBM.xlf90_r macros"; 
+              system "cp arc/Makefile.mpp Makefile.comm"; 
+            }
+
+     case 5 {
+              # GFORTRAN only                         
+              system "cp arc/macros.seq.gfort macros"; 
+              system "cp arc/Makefile.seq Makefile.comm"; 
+            }
+
+      case 6 {
+               # GFORTRAN dmpar only                         
+               system "cp arc/macros.mpp.gfort macros"; 
+               system "cp arc/Makefile.mpp Makefile.comm"; 
+             }
+      case 7 {
+               # ifort sequential                            
+               system "cp arc/macros.seq.ifort macros"; 
+               system "cp arc/Makefile.seq Makefile.comm"; 
+             }
+      case 8 {
+               # ifort    dmpar only                         
+               system "cp arc/macros.mpp.ifort macros"; 
+               system "cp arc/Makefile.mpp Makefile.comm"; 
+             }
+      case 9 {
+               # ifort Luna   dmpar only                         
+               system "cp arc/macros.mpp.ifort.luna macros"; 
+               system "cp arc/Makefile.mpp Makefile.comm"; 
+             }
+
+     else   {print "no selection $response\n"; last} 
+  }
+  if(! (-e lib)) {mkdir lib;}
+  if(! (-e mod)) {mkdir mod;}
+  if(-e "macros.tmp")  { system("cat macros macros.tmp > macros.a; rm -f macros.tmp; mv macros.a macros");}
+  # if((-d "LandModel") ) {system "cat macros LandModel/user_build_options.bak  > LandModel/user_build_options";}
diff --git a/wrfv2_fire/hydro/template/HYDRO/HYDRO.TBL b/wrfv2_fire/hydro/template/HYDRO/HYDRO.TBL
new file mode 100644
index 00000000..1de05f57
--- /dev/null
+++ b/wrfv2_fire/hydro/template/HYDRO/HYDRO.TBL
@@ -0,0 +1,50 @@
+     27 USGS for OV_ROUGH
+   SFC_ROUGH'
+     0.025,    'Urban and Built-Up Land'  
+     0.035,    'Dryland Cropland and Pasture' 
+     0.035,    'Irrigated Cropland and Pasture' 
+     0.055,    'Mixed Dryland/Irrigated Cropland and Pasture' 
+     0.035,    'Cropland/Grassland Mosaic'
+     0.068,    'Cropland/Woodland Mosaic' 
+     0.055,    'Grassland' 
+     0.055,    'Shrubland' 
+     0.055,    'Mixed Shrubland/Grassland' 
+     0.055,    'Savanna' 
+     0.200,    'Deciduous Broadleaf Forest' 
+     0.200,    'Deciduous Needleleaf Forest' 
+     0.200,    'Evergreen Broadleaf Forest'
+     0.200,    'Evergreen Needleleaf Forest'  
+     0.200,    'Mixed Forest' 
+     0.005,    'Water Bodies' 
+     0.070,    'Herbaceous Wetland' 
+     0.070,    'Wooded Wetland' 
+     0.035,    'Barren or Sparsely Vegetated' 
+     0.055,    'Herbaceous Tundra' 
+     0.055,    'Wooded Tundra' 
+     0.055,    'Mixed Tundra' 
+     0.055,    'Bare Ground Tundra' 
+     0.010,    'Snow or Ice' 
+     0.010,    'Playa' 
+     0.100,    'Lava'   
+     0.010,    'White Sand' 
+19, for SATDK
+SATDK     MAXSMC    REFSMC   WLTSMC  QTZ    '
+1.07E-6,  0.339,    0.236,   0.010,  0.92, 'SAND'
+1.41E-5,  0.421,    0.383,   0.028,  0.82, 'LOAMY SAND'
+5.23E-6,  0.434,    0.383,   0.047,  0.60, 'SANDY LOAM'
+2.81E-6,  0.476,    0.360,   0.084,  0.25, 'SILT LOAM'
+2.81E-6,  0.476,    0.383,   0.084,  0.10, 'SILT'
+3.38E-6,  0.439,    0.329,   0.066,  0.40, 'LOAM'
+4.45E-6,  0.404,    0.314,   0.067,  0.60, 'SANDY CLAY LOAM'
+2.04E-6,  0.464,    0.387,   0.120,  0.10, 'SILTY CLAY LOAM'
+2.45E-6,  0.465,    0.382,   0.103,  0.35, 'CLAY LOAM'
+7.22E-6,  0.406,    0.338,   0.100,  0.52, 'SANDY CLAY'
+1.34E-6,  0.468,    0.404,   0.126,  0.10, 'SILTY CLAY'
+9.74E-7,  0.468,    0.412,   0.138,  0.25, 'CLAY'
+3.38E-6,  0.439,    0.329,   0.066,  0.05, 'ORGANIC MATERIAL'
+    0.0,  1.0,      0.0,     0.0,    0.60, 'WATER'
+1.41E-4,  0.20,     0.170,   0.006,  0.07, 'BEDROCK'
+1.41E-5,  0.421,    0.283,   0.028,  0.25, 'OTHER(land-ice)'
+9.74E-7,  0.468,    0.454,   0.030,  0.60, 'PLAYA'
+1.41E-4,  0.200,    0.170,   0.006,  0.52, 'LAVA'
+1.07E-6,  0.339,    0.236,    0.01,  0.92, 'WHITE SAND'
diff --git a/wrfv2_fire/hydro/template/HYDRO/hydro.namelist b/wrfv2_fire/hydro/template/HYDRO/hydro.namelist
new file mode 100644
index 00000000..0ac93c57
--- /dev/null
+++ b/wrfv2_fire/hydro/template/HYDRO/hydro.namelist
@@ -0,0 +1,142 @@
+&HYDRO_nlist
+
+!!!! SYSTEM COUPLING !!!!
+!Specify what is being coupled:  1=HRLDAS (offline Noah-LSM), 2=WRF, 3=NASA/LIS, 4=CLM
+ sys_cpl = 1
+
+!!!! MODEL INPUT DATA FILES !!!
+!Specify land surface model gridded input data file...(e.g.: "geo_em.d03.nc")
+ GEO_STATIC_FLNM = "../DOMAIN/geo_em.d03.nc"
+
+!Specify the high-resolution routing terrain input data file...(e.g.: "Fulldom_hires_hydrofile.nc"
+ GEO_FINEGRID_FLNM = "../DOMAIN/Fulldom_hires_netcdf_file.nc"
+
+!Specify the name of the restart file if starting from restart...comment out with '!' if not...
+ RESTART_FILE  = 'HYDRO_RST.2013-09-12_04:00_DOMAIN3'
+
+!!!! MODEL SETUP AND I/O CONTROL !!!!
+!Specify the domain or nest number identifier...(integer)
+ IGRID = 3
+
+!Specify the restart file write frequency...(minutes)
+ rst_dt = 120
+! rst_dt = 1440
+
+!Specify the output file write frequency...(minutes)
+ out_dt = 60 ! minutes
+
+!Specify the number of output times to be contained within each output history file...(integer)
+!   SET = 1 WHEN RUNNING CHANNEL ROUTING ONLY/CALIBRATION SIMS!!!
+!   SET = 1 WHEN RUNNING COUPLED TO WRF!!!
+ SPLIT_OUTPUT_COUNT = 1
+
+! rst_typ = 1 : overwrite the soil variables from routing restart file.
+ rst_typ = 1
+
+!Output netcdf file control
+ CHRTOUT_DOMAIN = 1           ! 0: nooutput. 1: Netcdf point timeseries output at all channel points
+                              ! 2 : for fast output of stream flow variable.
+ CHRTOUT_GRID = 1                ! Netcdf grid of channel streamflow values
+ LSMOUT_DOMAIN = 0              ! Netcdf grid of variables passed between LSM and routing components
+ RTOUT_DOMAIN = 0               ! Netcdf grid of terrain routing variables on routing grid
+ output_gw = 0                 ! Netcdf grid of GW
+ outlake  = 0                  ! Netcdf grid of lake
+                               !0: no output. 1: point netcdf. 2: for fast output.
+
+ rst_bi_in = 1       !0: use netcdf restart file.
+                     !1: use parallel io for reading multiple restart files by each core.
+ rst_bi_out = 1      !0: use netcdf restart file.
+                     !1: use parallel io for output multiple restart files.
+
+
+
+!Restart switch to set restart accumulation variables = 0 (0-no reset, 1-yes reset to 0.0)
+ RSTRT_SWC = 0
+
+!Specify the minimum stream order to output to netcdf point file...(integer)
+!Note: lower value of stream order produces more output.
+ order_to_write = 4
+
+!!!! PHYSICS OPTIONS AND RELATED SETTINGS !!!!
+!Switch for terrain adjustment of incoming solar radiation: 0=no, 1=yes
+!Note: This option is not yet active in Verion 1.0...
+!      WRF has this capability so be careful not to double apply the correction!!!
+ TERADJ_SOLAR = 0
+
+!Specify the number of soil layers (integer) and the depth of the bottom of each layer (meters)...
+! Notes: In Version 1 of WRF-Hydro these must be the same as in the namelist.input file
+!       Future versions will permit this to be different.
+ NSOIL=4
+ ZSOIL8(1) = -0.10
+ ZSOIL8(2) = -0.40
+ ZSOIL8(3) = -1.00
+ ZSOIL8(4) = -2.00
+
+!Specify the grid spacing of the terrain routing grid...(meters)
+ DXRT = 100.0
+
+!Specify the integer multiple between the land model grid and the terrain routing grid...(integer)
+ AGGFACTRT = 10
+
+!Specify the routing model timestep...(seconds)
+ DTRT_CH = 60
+ DTRT_TER = 10
+
+!Switch activate subsurface routing...(0=no, 1=yes)
+ SUBRTSWCRT = 1
+
+!Switch activate surface overland flow routing...(0=no, 1=yes)
+ OVRTSWCRT = 1
+!Sspecify overland flow routing Routing Option: 1=Seepest Descent(D8) 2=CASC2D
+ rt_option    = 1
+
+!Switch to activate channel routing:
+ CHANRTSWCRT = 1
+!Specify channel routing option: 1=Muskingam-reach, 2=Musk.-Cunge-reach, 3=Diff.Wave-gridded, 4=Rapid routing.
+ channel_option = 2
+
+!Specify the reach file for reach-based routing options...
+ ! route_link_f = "../DOMAIN/Route_Link.bak.csv"
+ ! route_link_f = "../DOMAIN/Route_Link.csv"
+ route_link_f = "DOMAIN/Route_Link_2.nc"
+
+! simulated LAKE PARAM files, it will looking for LAKEPARM.TBL if this line has been commented.
+route_lake_f = "../DOMAIN/LAKEPARM.nc"
+
+!Switch to activate baseflow bucket model...(0=none, 1=exp. bucket, 2=pass-through)
+ GWBASESWCRT = 1
+
+!Specify baseflow/bucket model initialization...(0=cold start from table, 1=restart file)
+ GW_RESTART = 1
+
+!Groundwater/baseflow mask specified on land surface model grid...
+!Note: Only required if baseflow bucket model is active
+ gwbasmskfil = "../DOMAIN/gw_basns_geogrid.txt"
+ GWBUCKPARM_file = "DOMAIN/GWBUCKPARM_NHD.nc"
+
+! Realtime IOC run configuration option: 0=diagnostic, 1=analysis, 2=short-range, 3=medium-range, 4=long-range
+iocflag=1
+
+! User defined mapping, such NHDPlus
+!0: deafult none. 1: yes
+UDMP_OPT = 1
+udmap_file = "DOMAIN/spatialweights_geo_em.d02._100m_fixedj.nc"
+
+/
+
+&NUDGING_nlist
+
+nudgingParamFile = "DOMAIN/nudgingParams.nc"
+netwkReExFile    = "DOMAIN/netwkReExFile.nc"
+
+!! Parallel input of nudging timeslice observation files?
+readTimesliceParallel = .TRUE.
+
+! temporalPersistence defaults to true, only runs if necessary params present.
+temporalPersistence   = .FALSE.
+
+! nudgingLastObsFile defaults to '', which will look for nudgingLastObs.YYYY-mm-dd_HH:MM:SS.nc
+!   **AT THE INITALIZATION TIME OF THE RUN**. Set to a missing file to use no restart.
+nudgingLastObsFile   = 'notAFile.junk'
+
+/
diff --git a/wrfv2_fire/hydro/wrf_hydro_config b/wrfv2_fire/hydro/wrf_hydro_config
new file mode 100755
index 00000000..47548324
--- /dev/null
+++ b/wrfv2_fire/hydro/wrf_hydro_config
@@ -0,0 +1,28 @@
+#!/usr/bin/perl
+#input argument: Compiler/System sequential/parallel
+#This is called by WRF configuration only.
+if($#ARGV ne 1) {
+  print("Error: No such configuration for Hydro \n");
+  exit(1);
+}
+         $x = lc(shift(@ARGV));
+         $paropt = lc(shift(@ARGV));
+
+         print("Configure option for Hydro : $x  $paropt \n");  
+          if($x =~ "pgi") {
+              if($paropt eq 'serial') { system("./configure 1");}
+              else {system("./configure 2");}
+          }
+          if($x =~ "aix") {
+              if($paropt eq 'serial') { system("./configure 3");}
+              else {system("./configure 4");}
+          }
+          if($x =~ "gfortran") {
+              if($paropt eq 'serial') { system("./configure 5");}
+              else {system("./configure 6");}
+          }
+          if($x =~ "ifort") {
+              if($paropt eq 'serial') { system("./configure 7");}
+              else {system("./configure 8");}
+          }
+
diff --git a/wrfv2_fire/inc/.gitignore b/wrfv2_fire/inc/.gitignore
new file mode 100644
index 00000000..14f1e0ed
--- /dev/null
+++ b/wrfv2_fire/inc/.gitignore
@@ -0,0 +1,14 @@
+# This is the top-level .gitignore file for the "inc" directory for the WRF  #
+# Model                                                                      #
+#                                                                            #
+# Filenames and wildcards added below will not be tracked by git anywhere in #
+# this directory or any of its subdirectories. Note that these rules will be #
+# supplemented by rules in the top-level .gitignore file                     #
+#                                                                            #
+# Ignored file types should include executables, build-time temporary files, #
+# and other files which should not ever be added to the code repository.     #
+#                                                                            #
+# USE CAUTION WHEN ADDING WILDCARDS, as some builds use different filename   #
+# conventions than others                                                    #
+##############################################################################
+*.inc
diff --git a/wrfv2_fire/inc/version_decl b/wrfv2_fire/inc/version_decl
index a1412807..acf3c4f9 100644
--- a/wrfv2_fire/inc/version_decl
+++ b/wrfv2_fire/inc/version_decl
@@ -1 +1 @@
-   CHARACTER (LEN=10) :: release_version = 'V3.8      '
+   CHARACTER (LEN=10) :: release_version = 'V3.9.1.1  '
diff --git a/wrfv2_fire/main/Makefile b/wrfv2_fire/main/Makefile
index b8074657..3df8ced7 100644
--- a/wrfv2_fire/main/Makefile
+++ b/wrfv2_fire/main/Makefile
@@ -14,7 +14,7 @@ include ../configure.wrf
 
 $(SOLVER)_wrf : wrf.o ../main/module_wrf_top.o
 	$(RANLIB) $(RLFLAGS) $(LIBWRFLIB)
-	$(LD) -o wrf.exe $(LDFLAGS) wrf.o ../main/module_wrf_top.o $(LIBWRFLIB) $(LIB)
+	$(LD) -o wrf.exe $(LDFLAGS) wrf.o ../main/module_wrf_top.o $(LIBWRFLIB) $(LIB) 
 
 $(SOLVER)_wrf_SST_ESMF : wrf_ESMFMod.o wrf_SST_ESMF.o ../main/module_wrf_top.o
 	$(RANLIB) $(RLFLAGS) $(LIBWRFLIB)
diff --git a/wrfv2_fire/main/depend.common b/wrfv2_fire/main/depend.common
index 89edc6c9..8d0aa812 100644
--- a/wrfv2_fire/main/depend.common
+++ b/wrfv2_fire/main/depend.common
@@ -171,7 +171,7 @@ module_progtm.o: module_gfs_machine.o
 module_bl_gfs.o: module_gfs_machine.o \
 		 module_gfs_physcons.o
 
-module_bl_gfs2011.o: module_gfs_machine.o \
+module_bl_gfsedmf.o: module_gfs_machine.o \
 		 module_gfs_physcons.o
 
 module_bl_mynn.o: ../share/module_model_constants.o
@@ -313,10 +313,9 @@ module_gfs_funcphys.o: module_gfs_machine.o \
 module_cu_sas.o: module_gfs_machine.o \
 		 module_gfs_funcphys.o \
 		 module_gfs_physcons.o
-
-module_cu_mesosas.o: module_gfs_machine.o \
-		 module_gfs_funcphys.o \
-		 module_gfs_physcons.o
+module_cu_scalesas.o: module_gfs_machine.o \
+		module_gfs_funcphys.o \
+		module_gfs_physcons.o
 
 module_cu_osas.o: module_gfs_machine.o \
 		 module_gfs_funcphys.o \
@@ -439,6 +438,8 @@ module_sf_clm.o: module_cam_shr_kind_mod.o \
 		 module_cam_shr_const_mod.o \
 		 module_cam_support.o \
 		 module_sf_urban.o \
+		 module_sf_noahlsm.o \
+		 module_ra_gfdleta.o \
 		 ../share/module_date_time.o \
 		 ../frame/module_wrf_error.o  \
 		../frame/module_configure.o
@@ -524,7 +525,7 @@ module_physics_init.o : \
 		module_bl_ysu.o		        \
 		module_bl_mrf.o			\
 		module_bl_gfs.o			\
-		module_bl_gfs2011.o		\
+		module_bl_gfsedmf.o		\
 		module_bl_acm.o			\
 		module_bl_myjpbl.o		\
 		module_bl_qnsepbl.o		\
@@ -542,6 +543,7 @@ module_physics_init.o : \
 		module_cu_gd.o			\
 		module_cu_nsas.o		\
 		module_cu_sas.o			\
+		module_cu_scalesas.o            \
 		module_cu_osas.o		\
 		module_cu_camzm_driver.o        \
 		module_cu_kfcup.o               \
@@ -603,14 +605,21 @@ module_shallowcu_driver.o: \
 		../frame/module_state_description.o \
 		../share/module_model_constants.o
 
+module_cu_gf_wrfdrv.o: \
+		module_cu_gf_deep.o \
+		module_cu_gf_sh.o
+module_cu_gf_sh.o: \
+		module_cu_gf_deep.o
 module_cumulus_driver.o: \
 		module_cu_kf.o \
 		module_cu_g3.o \
+		module_cu_gf_wrfdrv.o \
 		module_cu_kfeta.o \
 		module_cu_bmj.o \
 		module_cu_gd.o \
 		module_cu_nsas.o \
 		module_cu_sas.o \
+		module_cu_scalesas.o \
 		module_cu_osas.o \
 		module_cu_camzm_driver.o \
 		module_cu_tiedtke.o \
@@ -634,7 +643,7 @@ module_pbl_driver.o:  \
                 module_bl_boulac.o \
 		module_bl_camuwpbl_driver.o \
 		module_bl_gfs.o \
-		module_bl_gfs2011.o \
+		module_bl_gfsedmf.o \
 		module_bl_mynn.o \
 		module_bl_fogdes.o \
 		module_bl_gwdo.o \
@@ -721,6 +730,8 @@ module_diagnostics_driver.o: \
 		module_diag_pld.o 			\
 		module_diag_zld.o 			\
 		module_diag_afwa.o 			\
+		module_diag_hailcast.o 			\
+                module_diag_rasm.o                      \
 		../frame/module_comm_dm.o		\
 		../frame/module_state_description.o 	\
 		../frame/module_domain.o 		\
@@ -741,8 +752,6 @@ module_diag_pld.o: \
 module_diag_zld.o: \
 		../share/module_model_constants.o
 
-module_diag_afwa_hail.o:
-
 module_diag_afwa.o: \
 		../frame/module_domain.o 		\
 		../frame/module_dm.o 			\
@@ -750,8 +759,19 @@ module_diag_afwa.o: \
 		../frame/module_configure.o 		\
 		../frame/module_streams.o		\
 		../external/esmf_time_f90/module_utility.o \
-		../share/module_model_constants.o	\
-		module_diag_afwa_hail.o
+		../share/module_model_constants.o
+
+module_diag_hailcast.o: \
+		../frame/module_configure.o 		\
+		../frame/module_domain.o 		\
+		../frame/module_dm.o 			\
+		../frame/module_state_description.o 	\
+		../frame/module_streams.o           	\
+		../external/esmf_time_f90/module_utility.o \
+		../share/module_model_constants.o
+
+module_diag_rasm.o: \
+                module_cam_shr_const_mod.o
 
 module_diag_refl.o: \
 		../frame/module_dm.o			\
@@ -860,11 +880,20 @@ module_ra_aerosol.o :\
 
 # DEPENDENCIES for share
 
+module_trajectory.o: ../frame/module_domain.o \
+		../frame/module_configure.o \
+		../frame/module_dm.o \
+		../frame/module_comm_dm.o \
+		../frame/module_state_description.o \
+		module_model_constants.o \
+		module_date_time.o \
+		module_llxy.o
+
 solve_interface.o: solve_em.int ../frame/module_domain.o ../frame/module_configure.o \
 		../frame/module_timing.o ../frame/module_driver_constants.o \
-		../frame/module_wrf_error.o
+		../frame/module_wrf_error.o module_trajectory.o
 
-start_domain.o: start_domain_em.int wrf_timeseries.o track_driver.o ../frame/module_domain.o ../frame/module_configure.o
+start_domain.o: start_domain_em.int wrf_timeseries.o track_driver.o ../frame/module_domain.o ../frame/module_configure.o ../share/module_llxy.o
 
 module_date_time.o: ../frame/module_wrf_error.o ../frame/module_configure.o \
                 module_model_constants.o
diff --git a/wrfv2_fire/main/module_wrf_top.F b/wrfv2_fire/main/module_wrf_top.F
index d04e3135..27cfc1d9 100644
--- a/wrfv2_fire/main/module_wrf_top.F
+++ b/wrfv2_fire/main/module_wrf_top.F
@@ -184,6 +184,7 @@ SUBROUTINE wrf_init( no_init1 )
 
    CALL set_derived_rconfigs
    CALL check_nml_consistency
+   CALL setup_physics_suite
    CALL set_physics_rconfigs
 
 #ifdef _ACCEL
@@ -596,6 +597,18 @@ SUBROUTINE set_derived_rconfigs
       END IF
 ! #endif
 
+#if (EM_CORE == 1)
+      IF ( model_config_rec % dfi_opt .EQ. DFI_NODFI ) THEN
+        DO i = 1, model_config_rec % max_dom
+           model_config_rec % bl_pbl_physics_dfi(i) = -1
+        ENDDO
+      ELSE
+        DO i = 1, model_config_rec % max_dom
+           model_config_rec % bl_pbl_physics_dfi(i) = model_config_rec % bl_pbl_physics(i)
+        ENDDO
+      END IF
+#endif
+
 #if (DA_CORE == 1)
       IF ( model_config_rec % dyn_opt .EQ. 2 ) THEN
         DO i = 1, model_config_rec % max_dom
diff --git a/wrfv2_fire/main/ndown_em.F b/wrfv2_fire/main/ndown_em.F
index af87151d..c8c3473a 100644
--- a/wrfv2_fire/main/ndown_em.F
+++ b/wrfv2_fire/main/ndown_em.F
@@ -50,13 +50,14 @@ SUBROUTINE init_domain_constants_em_ptr ( parent , nest )
        TYPE(domain), POINTER  :: parent , nest
      END SUBROUTINE init_domain_constants_em_ptr
 
-     SUBROUTINE vertical_interp (nested_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c)
+     SUBROUTINE vertical_interp (nested_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c,c3h,c4h,c3f,c4f)
          USE module_domain
          USE module_configure
          TYPE(domain), POINTER ::  nested_grid
          INTEGER , INTENT (IN) :: k_dim_c
          REAL , INTENT (IN) :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c
          REAL , DIMENSION(k_dim_c) , INTENT (IN) ::  znw_c,znu_c
+         REAL , DIMENSION(k_dim_c) , INTENT (IN) ::  c3h,c4h,c3f,c4f
       END SUBROUTINE vertical_interp
 
 
@@ -136,6 +137,7 @@ END SUBROUTINE vertical_interp
     integer ::  n_ref_m,k_dim_c,k_dim_n
 real :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c
    REAL , DIMENSION(:) , ALLOCATABLE :: znw_c,znu_c
+   REAL , DIMENSION(:) , ALLOCATABLE :: c3h,c4h,c3f,c4f
 !!!!!!!!!!!!!!!!!!!!!!!!!!11
 
    !  Interface block for routine that passes pointers and needs to know that they
@@ -203,6 +205,7 @@ END SUBROUTINE vert_cor
 #endif
 
    CALL check_nml_consistency
+   CALL setup_physics_suite
    CALL set_physics_rconfigs
 
    !  If we are running ndown, and that is WHERE we are now, make sure that we account
@@ -221,6 +224,10 @@ END SUBROUTINE vert_cor
    model_config_rec % e_vert(2) = k_dim_n
    ALLOCATE(znw_c(k_dim_c))
    ALLOCATE(znu_c(k_dim_c))
+   ALLOCATE(c3h(k_dim_c))
+   ALLOCATE(c4h(k_dim_c))
+   ALLOCATE(c3f(k_dim_c))
+   ALLOCATE(c4f(k_dim_c))
    WRITE ( message , FMT = '(A,3I5)' ) 'KDIM_C', k_dim_c , model_config_rec % e_vert(1) , model_config_rec % e_vert(2)
    CALL       wrf_debug (  99,message )
 !!!!!!!!!!!!!!! mousta
@@ -414,6 +421,12 @@ END SUBROUTINE vert_cor
       znw_c(k) = head_grid%znw(k)
       znu_c(k) = head_grid%znu(k)
       enddo
+      do k = 1,k_dim_c
+      c3h(k) = head_grid%c3h(k)
+      c4h(k) = head_grid%c4h(k)
+      c3f(k) = head_grid%c3f(k)
+      c4f(k) = head_grid%c4f(k)
+      enddo
       call vert_cor(head_grid,znw_c,k_dim_c)
       WRITE ( message , * ) 'CFA' ,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,znw_c(1),znu_c(1)
       CALL       wrf_debug (  99,message )
@@ -565,7 +578,7 @@ END SUBROUTINE vert_cor
       CALL med_interp_domain ( head_grid , nested_grid )
       WRITE ( message , * ) 'MOUSTA_L', nested_grid%mu_2(ips,jps) , nested_grid%u_2(ips,kde-2,jps)
       CALL       wrf_debug (  99,message )
-      CALL vertical_interp (nested_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c)
+      CALL vertical_interp (nested_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c,c3h,c4h,c3f,c4f)
       WRITE ( message , * ) 'MOUSTA_V', nested_grid%mu_2(ips,jps) , nested_grid%u_2(ips,kde-2,jps)
       CALL       wrf_debug (  99,message )
       nested_grid%ht_int = nested_grid%ht
@@ -792,25 +805,31 @@ END SUBROUTINE vert_cor
          ! u, theta, h, scalars coupled with my, v coupled with mx
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp1 , nested_grid%u_2                 , &
                        'u' , nested_grid%msfuy , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp1 , nested_grid%v_2                 , &
                        'v' , nested_grid%msfvx , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp1 , nested_grid%t_2                 , &
                        't' , nested_grid%msfty , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp1 , nested_grid%ph_2                , &
                        'h' , nested_grid%msfty , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          DO nvmoist=PARAM_FIRST_SCALAR, num_moist
            CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp1 , nested_grid%moist(ims:ime,kms:kme,jms:jme,nvmoist)    , &
                          't' , nested_grid%msfty , &
+                         nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                          ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
            qbdy3dtemp1_coupled(:,:,:,nvmoist) =  qbdy3dtemp1
          END DO
          DO nvscalar=PARAM_FIRST_SCALAR, num_scalar
            CALL couple ( nested_grid%mu_2 , nested_grid%mub , sbdy3dtemp1 , nested_grid%scalar(ims:ime,kms:kme,jms:jme,nvscalar)    , &
                          't' , nested_grid%msfty , &
+                         nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                          ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
            sbdy3dtemp1_coupled(:,:,:,nvscalar) =  sbdy3dtemp1
          END DO
@@ -906,25 +925,31 @@ END SUBROUTINE vert_cor
          ! u, theta, h, scalars coupled with my, v coupled with mx
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp2 , nested_grid%u_2                 , &
                        'u' , nested_grid%msfuy , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp2 , nested_grid%v_2                 , &
                        'v' , nested_grid%msfvx , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp2 , nested_grid%t_2                 , &
                        't' , nested_grid%msfty , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp2 , nested_grid%ph_2                , &
                        'h' , nested_grid%msfty , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          DO nvmoist=PARAM_FIRST_SCALAR, num_moist
            CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp2 , nested_grid%moist(ims:ime,kms:kme,jms:jme,nvmoist)    , &
                          't' , nested_grid%msfty , &
+                         nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                          ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
            qbdy3dtemp2_coupled(:,:,:,nvmoist) =  qbdy3dtemp2
          END DO
          DO nvscalar=PARAM_FIRST_SCALAR, num_scalar
            CALL couple ( nested_grid%mu_2 , nested_grid%mub , sbdy3dtemp2 , nested_grid%scalar(ims:ime,kms:kme,jms:jme,nvscalar)    , &
                          't' , nested_grid%msfty , &
+                         nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                          ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
            sbdy3dtemp2_coupled(:,:,:,nvscalar) =  sbdy3dtemp2
          END DO
@@ -1191,25 +1216,31 @@ END SUBROUTINE vert_cor
          ! u, theta, h, scalars coupled with my, v coupled with mx
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , ubdy3dtemp2 , nested_grid%u_2                 , &
                        'u' , nested_grid%msfuy , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , vbdy3dtemp2 , nested_grid%v_2                 , &
                        'v' , nested_grid%msfvx , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , tbdy3dtemp2 , nested_grid%t_2                 , &
                        't' , nested_grid%msfty , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( nested_grid%mu_2 , nested_grid%mub , pbdy3dtemp2 , nested_grid%ph_2                , &
                        'h' , nested_grid%msfty , &
+                       nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          DO nvmoist=PARAM_FIRST_SCALAR, num_moist
            CALL couple ( nested_grid%mu_2 , nested_grid%mub , qbdy3dtemp2 , nested_grid%moist(ims:ime,kms:kme,jms:jme,nvmoist)    , &
                          't' , nested_grid%msfty , &
+                         nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                          ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
            qbdy3dtemp2_coupled(:,:,:,nvmoist) = qbdy3dtemp2
          END DO
          DO nvscalar=PARAM_FIRST_SCALAR, num_scalar
            CALL couple ( nested_grid%mu_2 , nested_grid%mub , sbdy3dtemp2 , nested_grid%scalar(ims:ime,kms:kme,jms:jme,nvscalar)    , &
                          't' , nested_grid%msfty , &
+                         nested_grid%c1h, nested_grid%c2h, nested_grid%c1f, nested_grid%c2f, &
                          ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
            sbdy3dtemp2_coupled(:,:,:,nvscalar) = sbdy3dtemp2
          END DO
@@ -1685,7 +1716,7 @@ END SUBROUTINE init_domain_constants_em
 END SUBROUTINE init_domain_constants_em_ptr
 
 
-     SUBROUTINE vertical_interp (parent_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c)
+     SUBROUTINE vertical_interp (parent_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c,k_dim_c,c3h,c4h,c3f,c4f)
          USE module_domain
          USE module_configure
    IMPLICIT NONE
@@ -1693,6 +1724,7 @@ SUBROUTINE vertical_interp (parent_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1
          INTEGER , INTENT (IN) :: k_dim_c
          REAL , INTENT (IN) :: cf1_c,cf2_c,cf3_c,cfn_c,cfn1_c
          REAL , DIMENSION(k_dim_c) , INTENT (IN) ::  znw_c,znu_c
+         REAL , DIMENSION(k_dim_c) , INTENT (IN) ::  c3h,c4h,c3f,c4f
 
        integer :: kde_c , kde_n ,n_refine,ii,kkk
        integer :: i , j, k , itrace
@@ -1740,22 +1772,38 @@ SUBROUTINE vertical_interp (parent_grid,znw_c,znu_c,cf1_c,cf2_c,cf3_c,cfn_c,cfn1
 !        print * , 'p_top_m', p_top_m
 !    parent
          do  k = 1,kde_c
+#if  !( HYBRID_COORD==1 )
          pre_c = mu_m * znw_c(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+         pre_c = mu_m * c3f(k) + c4f(k) + p_top_m
+#endif
          alt_w_c(k) =  -hsca_m * alog(pre_c/p_surf_m)
          enddo
          do  k = 1,kde_c-1
+#if  !( HYBRID_COORD==1 )
          pre_c = mu_m * znu_c(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+         pre_c = mu_m * c3h(k) + c4h(k) + p_top_m
+#endif
          alt_u_c(k+1) =  -hsca_m * alog(pre_c/p_surf_m)
          enddo
          alt_u_c(1) =  alt_w_c(1) 
          alt_u_c(kde_c+1) =  alt_w_c(kde_c) 
 !    nest
          do  k = 1,kde_n
+#if  !( HYBRID_COORD==1 )
          pre_n = mu_m * parent_grid%znw(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+         pre_n = mu_m * parent_grid%c3f(k) + parent_grid%c4f(k) + p_top_m
+#endif
          alt_w_n(k) =  -hsca_m * alog(pre_n/p_surf_m)
          enddo
          do  k = 1,kde_n-1
+#if  !( HYBRID_COORD==1 )
          pre_n = mu_m * parent_grid%znu(k) + p_top_m
+#elif ( HYBRID_COORD==1 )
+         pre_n = mu_m * parent_grid%c3h(k) + parent_grid%c4h(k) + p_top_m
+#endif
          alt_u_n(k+1) =  -hsca_m * alog(pre_n/p_surf_m)
          enddo
          alt_u_n(1) =  alt_w_n(1)
diff --git a/wrfv2_fire/main/real_em.F b/wrfv2_fire/main/real_em.F
index ee4e2a2e..72754317 100644
--- a/wrfv2_fire/main/real_em.F
+++ b/wrfv2_fire/main/real_em.F
@@ -136,6 +136,7 @@ END SUBROUTINE Setup_Timekeeping
    CALL nl_set_use_wps_input ( 1 , REALONLY )
 
    CALL check_nml_consistency
+   CALL setup_physics_suite
    CALL set_physics_rconfigs
 
    CALL nl_get_debug_level ( 1, debug_level )
@@ -833,14 +834,19 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
    
          !  u, theta, h, scalars coupled with my; v coupled with mx
          CALL couple ( grid%mu_2 , grid%mub , ubdy3dtemp1 , grid%u_2                 , 'u' , grid%msfuy , &
+                       grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( grid%mu_2 , grid%mub , vbdy3dtemp1 , grid%v_2                 , 'v' , grid%msfvx , &
+                       grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( grid%mu_2 , grid%mub , tbdy3dtemp1 , grid%t_2                 , 't' , grid%msfty , &
+                       grid%c1h, grid%c2h, grid%c1h, grid%c2h, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( grid%mu_2 , grid%mub , pbdy3dtemp1 , grid%ph_2                , 'h' , grid%msfty , &
+                       grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( grid%mu_2 , grid%mub , qbdy3dtemp1 , grid%moist(:,:,:,P_QV)      , 't' , grid%msfty , &
+                       grid%c1h, grid%c2h, grid%c1h, grid%c2h, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
    
          DO j = jps , MIN(jde-1,jpe)
@@ -851,8 +857,10 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
 
          IF (config_flags%mp_physics.eq.THOMPSONAERO .AND.  config_flags%use_aero_icbc) THEN
             CALL couple ( grid%mu_2 , grid%mub , qn1bdy3dtemp1 , grid%scalar(:,:,:,P_QNWFA)      , 't' , grid%msfty , &
+                       grid%c1h, grid%c2h, grid%c1h, grid%c2h, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
             CALL couple ( grid%mu_2 , grid%mub , qn2bdy3dtemp1 , grid%scalar(:,:,:,P_QNIFA)      , 't' , grid%msfty , &
+                       grid%c1h, grid%c2h, grid%c1h, grid%c2h, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          END IF
 
@@ -980,14 +988,19 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
    
          !  u, theta, h, scalars coupled with my; v coupled with mx
          CALL couple ( grid%mu_2 , grid%mub , ubdy3dtemp2 , grid%u_2                 , 'u' , grid%msfuy , &
+                       grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( grid%mu_2 , grid%mub , vbdy3dtemp2 , grid%v_2                 , 'v' , grid%msfvx , &
+                       grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( grid%mu_2 , grid%mub , tbdy3dtemp2 , grid%t_2                 , 't' , grid%msfty , &
+                       grid%c1h, grid%c2h, grid%c1h, grid%c2h, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( grid%mu_2 , grid%mub , pbdy3dtemp2 , grid%ph_2                , 'h' , grid%msfty , &
+                       grid%c1h, grid%c2h, grid%c1f, grid%c2f, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          CALL couple ( grid%mu_2 , grid%mub , qbdy3dtemp2 , grid%moist(:,:,:,P_QV)      , 't' , grid%msfty , &
+                       grid%c1h, grid%c2h, grid%c1h, grid%c2h, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
    
          DO j = jps , jpe
@@ -998,8 +1011,10 @@ SUBROUTINE assemble_output ( grid , config_flags , loop , time_loop_max )
 
          IF (config_flags%mp_physics.eq.THOMPSONAERO .AND.  config_flags%use_aero_icbc) THEN
             CALL couple ( grid%mu_2 , grid%mub , qn1bdy3dtemp2 , grid%scalar(:,:,:,P_QNWFA)      , 't' , grid%msfty , &
+                       grid%c1h, grid%c2h, grid%c1h, grid%c2h, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
             CALL couple ( grid%mu_2 , grid%mub , qn2bdy3dtemp2 , grid%scalar(:,:,:,P_QNIFA)      , 't' , grid%msfty , &
+                       grid%c1h, grid%c2h, grid%c1h, grid%c2h, &
                        ids, ide, jds, jde, kds, kde, ims, ime, jms, jme, kms, kme, ips, ipe, jps, jpe, kps, kpe )
          END IF
 
diff --git a/wrfv2_fire/phys/Makefile b/wrfv2_fire/phys/Makefile
index c56121ef..a629af7a 100644
--- a/wrfv2_fire/phys/Makefile
+++ b/wrfv2_fire/phys/Makefile
@@ -35,7 +35,7 @@ MODULES = \
 	module_bl_shinhong.o \
 	module_bl_mrf.o \
 	module_bl_gfs.o \
-	module_bl_gfs2011.o \
+        module_bl_gfsedmf.o \
 	module_bl_myjpbl.o \
 	module_bl_qnsepbl.o \
 	module_bl_acm.o \
@@ -61,10 +61,12 @@ MODULES = \
 	module_cu_tiedtke.o\
 	module_cu_ntiedtke.o\
 	module_cu_gd.o \
-	module_cu_gf.o \
+	module_cu_gf_wrfdrv.o \
+	module_cu_gf_deep.o \
+	module_cu_gf_sh.o \
 	module_cu_nsas.o \
 	module_cu_sas.o \
-	module_cu_mesosas.o \
+	module_cu_scalesas.o \
 	module_cu_osas.o \
 	module_cu_kfcup.o \
 	module_mp_radar.o \
@@ -83,6 +85,7 @@ MODULES = \
 	module_ltng_lpi.o \
 	module_mp_gsfcgce.o \
 	module_mp_morr_two_moment.o \
+        module_mp_p3.o \
 	module_mp_milbrandt2mom.o \
 	module_mp_nssl_2mom.o \
 	module_mp_wdm5.o \
@@ -183,9 +186,10 @@ FIRE_MODULES = \
   
 DIAGNOSTIC_MODULES_EM = \
 	module_diag_afwa.o \
-	module_diag_afwa_hail.o \
 	module_diag_cl.o \
+        module_diag_hailcast.o \
 	module_diag_misc.o \
+        module_diag_rasm.o \
 	module_diag_pld.o \
 	module_diag_zld.o
   
diff --git a/wrfv2_fire/phys/module_bl_gfs.F b/wrfv2_fire/phys/module_bl_gfs.F
index 0f15a1b9..2518f1ac 100755
--- a/wrfv2_fire/phys/module_bl_gfs.F
+++ b/wrfv2_fire/phys/module_bl_gfs.F
@@ -22,6 +22,7 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
                   VAR_RIC,                                         &    !Kwon for variable Ric
                   U10,V10,ZNT,MZNT,rc2d,                           &    !Kwon for variable Ric
                   DKU3D,DKT3D,coef_ric_l,coef_ric_s,xland,         &    !Kwon for variable Ric
+                  msang,scurx,scury,iwavecpl,lcurr_sf,                      &
                   pert_pbl, ens_random_seed, ens_pblamp,           &
 #endif
                   ids,ide, jds,jde, kds,kde,                       &
@@ -105,6 +106,8 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
 #endif
 
 #if (HWRF==1)
+      INTEGER , INTENT(IN)          ::  iwavecpl
+      LOGICAL , INTENT(IN)          ::  lcurr_sf
       REAL,  DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::              &
                                         HPBL2D,                         &    !ADDED BY KWON FOR SHALLOW CONV.
                                         EVAP2D,                         &    !ADDED BY KWON FOR SHALLOW CONV.
@@ -115,6 +118,10 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
                                         ZNT                               !ADDED BY KWON FOR VARIABLE Ric
       REAL,  DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(OUT) :: DKU3D,DKT3D  
       REAL,    INTENT(IN) :: VAR_RIC,coef_ric_l,coef_ric_s                   !ADDED BY KWON
+      REAL,  DIMENSION(ims:ime, jms:jme), INTENT(IN) ::                 &
+                                        SCURX,                          &
+                                        SCURY,                          &
+                                        MSANG
       integer,intent(in) :: ens_random_seed
       real,intent(in) :: ens_pblamp
       logical,intent(in) :: pert_pbl
@@ -240,6 +247,9 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
       REAL, PARAMETER:: ALPHA=1.0
 #endif
 
+#if (HWRF == 1)
+      REAL :: UBOT, VBOT, UBOT1, VBOT1
+#endif
       INTEGER, DIMENSION( its:ite ) ::                                  &
                                         KPBL 
 
@@ -285,6 +295,29 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
         XLAND1(i) = XLAND(I,J)
 #endif
 !
+#if (HWRF==1)
+        IF ( XLAND(I,J)  > 1.99 ) THEN
+          IF ( LCURR_SF ) THEN
+            UBOT = U3D(I,KTS,J)-SCURX(I,J)
+            VBOT = V3D(I,KTS,J)-SCURY(I,J)
+          ELSE
+            UBOT = U3D(I,KTS,J)
+            VBOT = V3D(I,KTS,J)
+          ENDIF
+          IF ( IWAVECPL .eq. 1 ) THEN
+            UBOT1 = ( UBOT * COS(MSANG(I,J))  -               &
+                     VBOT * SIN(MSANG(I,J)) )                 &
+                                  * COS(MSANG(I,J))
+            VBOT1 = ( VBOT * COS(MSANG(I,J))  -               &
+                     UBOT * SIN(MSANG(I,J)) )                &
+                                  * COS(MSANG(I,J))
+
+            WSPD(i,j) = SQRT(UBOT1*UBOT1+VBOT1*VBOT1) + 1.E-9
+          ELSE
+            WSPD(i,j) = SQRT(UBOT*UBOT+VBOT*VBOT) + 1.E-9
+          ENDIF
+        ENDIF
+#endif
         STRESS(i)=KARMAN*KARMAN*WSPD(i,j)*WSPD(i,j)/(FMTMP*FMTMP)
         SPD1(i)=WSPD(i,j)
         PRSI(i,kts)=PSFC(i,j)*.001
@@ -302,8 +335,34 @@ SUBROUTINE BL_GFS(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D,     &
           DV(I,K) = 0.
           DU(I,K) = 0.
           TAU(I,K) = 0.
+#if (HWRF==1)
+          IF ( XLAND(I,J) > 1.99  .AND. k == KTS ) THEN
+            IF ( LCURR_SF ) THEN
+              UBOT = U3D(i,k,j) - SCURX(I,J)
+              VBOT = V3D(i,k,j) - SCURY(I,J)
+            ELSE
+              UBOT = U3D(i,k,j)
+              VBOT = V3D(i,k,j)
+            ENDIF
+            IF ( IWAVECPL .eq. 1 ) THEN
+              U1(I,K) = ( UBOT * COS(MSANG(I,J))  -            &
+                          VBOT * SIN(MSANG(I,J)) )             &
+                                  * COS(MSANG(I,J))
+              V1(I,K) = ( VBOT * COS(MSANG(I,J))  -            &
+                          UBOT * SIN(MSANG(I,J)) )             &
+                                  * COS(MSANG(I,J))
+            ELSE
+              U1(I,K) =  UBOT
+              V1(I,K) =  VBOT
+            ENDIF
+          ELSE
+            U1(I,K) = U3D(i,k,j)
+            V1(I,K) = V3D(i,k,j)
+          ENDIF
+#else
           U1(I,K) = U3D(i,k,j)
           V1(I,K) = V3D(i,k,j)
+#endif
           T1(I,K) = T3D(i,k,j)
           Q1(I,K,1) = QV3D(i,k,j)/(1.+QV3D(i,k,j))
           Q1(I,K,2) = QC3D(i,k,j)/(1.+QC3D(i,k,j))
diff --git a/wrfv2_fire/phys/module_bl_gfs2011.F b/wrfv2_fire/phys/module_bl_gfs2011.F
deleted file mode 100755
index a1a481d2..00000000
--- a/wrfv2_fire/phys/module_bl_gfs2011.F
+++ /dev/null
@@ -1,1509 +0,0 @@
-!LWRF:MODEL_LAYER:PHYSICS
-!
-MODULE module_bl_gfs2011
-
-CONTAINS
-
-!-------------------------------------------------------------------          
-   SUBROUTINE BL_GFS2011(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D, &
-                  RUBLTEN,RVBLTEN,RTHBLTEN,                        &
-                  RQVBLTEN,RQCBLTEN,RQIBLTEN,          	           & 
-                  CP,G,ROVCP,R,ROVG,P_QI,P_FIRST_SCALAR,           &
-                  dz8w,z,PSFC,                                     &
-                  UST,PBL,PSIM,PSIH,                               &
-                  HFX,QFX,TSK,GZ1OZ0,WSPD,BR,                      &
-                  DT,KPBL2D,EP1,KARMAN,                            &
-#if (NMM_CORE==1)
-                  DISHEAT,                                         &
-#endif
-                  RTHRATEN,                                        &    !Kwon add RTHRATEN 
-                  HPBL2D, EVAP2D, HEAT2D,                          &    !Kwon add FOR SHAL. CON.
-                  ids,ide, jds,jde, kds,kde,                       &
-                  ims,ime, jms,jme, kms,kme,                       &
-                  its,ite, jts,jte, kts,kte                        )
-!--------------------------------------------------------------------
-      USE MODULE_GFS_MACHINE , ONLY : kind_phys
-!-------------------------------------------------------------------
-      IMPLICIT NONE
-!-------------------------------------------------------------------
-!-- U3D         3D u-velocity interpolated to theta points (m/s)
-!-- V3D         3D v-velocity interpolated to theta points (m/s)
-!-- TH3D	3D potential temperature (K)
-!-- T3D         temperature (K)
-!-- QV3D        3D water vapor mixing ratio (Kg/Kg)
-!-- QC3D        3D cloud mixing ratio (Kg/Kg)
-!-- QI3D        3D ice mixing ratio (Kg/Kg)
-!-- P3D         3D pressure (Pa)
-!-- PI3D	3D exner function (dimensionless)
-!-- rr3D	3D dry air density (kg/m^3)
-!-- RUBLTEN     U tendency due to
-!               PBL parameterization (m/s^2)
-!-- RVBLTEN     V tendency due to
-!               PBL parameterization (m/s^2)
-!-- RTHBLTEN    Theta tendency due to
-!               PBL parameterization (K/s)
-!-- RQVBLTEN    Qv tendency due to
-!               PBL parameterization (kg/kg/s)
-!-- RQCBLTEN    Qc tendency due to
-!               PBL parameterization (kg/kg/s)
-!-- RQIBLTEN    Qi tendency due to
-!               PBL parameterization (kg/kg/s)
-!-- CP          heat capacity at constant pressure for dry air (J/kg/K)
-!-- G           acceleration due to gravity (m/s^2)
-!-- ROVCP       R/CP
-!-- R           gas constant for dry air (J/kg/K)
-!-- ROVG 	R/G
-!-- P_QI	species index for cloud ice
-!-- dz8w	dz between full levels (m)
-!-- z		height above sea level (m)
-!-- PSFC        pressure at the surface (Pa)
-!-- UST		u* in similarity theory (m/s)
-!-- PBL		PBL height (m)
-!-- PSIM        similarity stability function for momentum
-!-- PSIH        similarity stability function for heat
-!-- HFX		upward heat flux at the surface (W/m^2)
-!-- QFX		upward moisture flux at the surface (kg/m^2/s)
-!-- TSK		surface temperature (K)
-!-- GZ1OZ0      log(z/z0) where z0 is roughness length
-!-- WSPD        wind speed at lowest model level (m/s)
-!-- BR          bulk Richardson number in surface layer
-!-- DT		time step (s)
-!-- rvovrd      R_v divided by R_d (dimensionless)
-!-- EP1         constant for virtual temperature (R_v/R_d - 1) (dimensionless)
-!-- KARMAN      Von Karman constant
-!-- ids         start index for i in domain
-!-- ide         end index for i in domain
-!-- jds         start index for j in domain
-!-- jde         end index for j in domain
-!-- kds         start index for k in domain
-!-- kde         end index for k in domain
-!-- ims         start index for i in memory
-!-- ime         end index for i in memory
-!-- jms         start index for j in memory
-!-- jme         end index for j in memory
-!-- kms         start index for k in memory
-!-- kme         end index for k in memory
-!-- its         start index for i in tile
-!-- ite         end index for i in tile
-!-- jts         start index for j in tile
-!-- jte         end index for j in tile
-!-- kts         start index for k in tile
-!-- kte         end index for k in tile
-!-------------------------------------------------------------------
-
-      INTEGER, INTENT(IN) ::            ids,ide, jds,jde, kds,kde,      &
-                                        ims,ime, jms,jme, kms,kme,      &
-                                        its,ite, jts,jte, kts,kte,      &
-                                        P_QI,P_FIRST_SCALAR
-
-#if (NMM_CORE==1)
-      LOGICAL , INTENT(IN)::            DISHEAT                                    !gopal's doing
-#endif
-      REAL,  DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::  RTHRATEN         !Kwon
-      REAL,  DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::              &
-                                        HPBL2D,                         &    !ADDED BY KWON FOR SHALLOW CONV.
-                                        EVAP2D,                         &    !ADDED BY KWON FOR SHALLOW CONV.
-                                        HEAT2D                               !ADDED BY KWON FOR SHALLOW CONV.
-
-      REAL,    INTENT(IN) ::                                            &
-                                        CP,                             &
-                                        DT,                             &
-                                        EP1,                            &
-                                        G,                              &
-                                        KARMAN,                         &
-                                        R,                              & 
-                                        ROVCP,                          &
-                                        ROVG 
-
-      REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::      & 
-                                        DZ8W,                           &
-                                        P3D,                            &
-                                        PI3D,                           &
-                                        QC3D,                           &
-                                        QI3D,                           &
-                                        QV3D,                           &
-                                        T3D,                            &
-                                        TH3D,                           &
-                                        U3D,                            &
-                                        V3D,                            &
-                                        Z   
-
-
-      REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::   &
-                                        RTHBLTEN,                       &
-                                        RQCBLTEN,                       &
-                                        RQIBLTEN,                       &
-                                        RQVBLTEN,                       &
-                                        RUBLTEN,                        &
-                                        RVBLTEN                        
-
-      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
-                                        BR,                             &
-                                        GZ1OZ0,                         &
-                                        HFX,                            &
-                                        PSFC,                           &
-                                        PSIM,                           &
-                                        PSIH,                           &
-                                        QFX,                            &
-                                        TSK
- 
-      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            & 
-                                        PBL,                            &
-                                        UST,                            &
-                                        WSPD
-
-      INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::              &
-                                        KPBL2D                         
-
-
-!--------------------------- LOCAL VARS ------------------------------
-
-
-      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte) ::         &
-                                        DEL,                            &
-                                        DU,                             &
-                                        DV,                             &
-                                        PHIL,                           &
-                                        PRSL,                           &
-                                        PRSLK,                          &
-                                        T1,                             &
-                                        TAU,                            &
-                                        dishx,                          &
-                                        THRATEN,                        & !Kwon
-                                        U1,                             &
-                                        V1
-
-      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte+1) ::       &
-                                        PHII,                           & 
-                                        PRSI
-
-      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte, 3) ::      &
-                                        Q1,                             &
-                                        RTG
-
-      REAL     (kind=kind_phys), DIMENSION(its:ite) ::                  &
-                                        DQSFC,                          &
-                                        DTSFC,                          &
-                                        DUSFC,                          &
-                                        DVSFC,                          &
-                                        EVAP,                           &
-                                        FH,                             &
-                                        FM,                             &
-                                        HEAT,                           &
-                                        HGAMQ,                          &
-                                        HGAMT,                          &
-                                        HPBL,                           &
-                                        PSK,                            &
-                                        QSS,                            &
-                                        RBSOIL,                         &
-                                        RCL,                            &
-                                        SPD1,                           &
-                                        STRESS,                         &
-                                        TSEA
-
-      REAL     (kind=kind_phys) ::                                      &
-                                        CPM,                            &
-                                        cpmikj,                         &
-                                        DELTIM,                         &
-                                        FMTMP,                          &
-                                        RRHOX
-
-      INTEGER, DIMENSION( its:ite ) ::                                  &
-                                        KPBL 
-
-      INTEGER ::                                                        &
-                                        I,                              &
-                                        IM,                             &
-                                        J,                              &
-                                        K,                              &
-                                        KM,                             &
-                                        KTEM,                           &
-                                        KTEP,                           &
-                                        KX,                             &
-                                        L,                              & 
-                                        NTRAC
- 
-   IM=ITE-ITS+1
-   KX=KTE-KTS+1
-   KTEM=KTE-1
-   KTEP=KTE+1
-   NTRAC=2
-   DELTIM=DT
-   IF (P_QI.ge.P_FIRST_SCALAR) NTRAC=3
-
-
-   DO J=jts,jte
-
-      DO i=its,ite
-        RRHOX=(R*T3D(I,KTS,J)*(1.+EP1*QV3D(I,KTS,J)))/PSFC(I,J)
-        CPM=CP*(1.+0.8*QV3D(i,kts,j))
-        FMTMP=GZ1OZ0(i,j)-PSIM(i,j)
-        PSK(i)=(PSFC(i,j)*.00001)**ROVCP
-        FM(i)=FMTMP
-        FH(i)=GZ1OZ0(i,j)-PSIH(i,j)
-        TSEA(i)=TSK(i,j)
-        QSS(i)=QV3D(i,kts,j)               ! not used in moninq so set to qv3d for now
-        HEAT(i)=HFX(i,j)/CPM*RRHOX
-        EVAP(i)=QFX(i,j)*RRHOX
-! Kwon FOR NEW SHALLOW CONVECTION 
-        HEAT2D(i,j)=HFX(i,j)/CPM*RRHOX
-        EVAP2D(i,j)=QFX(i,j)*RRHOX
-!
-        STRESS(i)=KARMAN*KARMAN*WSPD(i,j)*WSPD(i,j)/(FMTMP*FMTMP)
-        SPD1(i)=WSPD(i,j)
-        PRSI(i,kts)=PSFC(i,j)*.001
-        PHII(I,kts)=0.
-        RCL(i)=1.
-        RBSOIL(I)=BR(i,j)
-      ENDDO
-
-      DO k=kts,kte
-        DO i=its,ite 
-          DV(I,K) = 0.
-          DU(I,K) = 0.
-          TAU(I,K) = 0.
-          U1(I,K) = U3D(i,k,j)
-          V1(I,K) = V3D(i,k,j)
-          T1(I,K) = T3D(i,k,j)
-#ifdef NMM_CORE
-          THRATEN(I,K) = RTHRATEN(I,K,J)
-#else
-          THRATEN(I,K) = 0.0
-#endif
-          Q1(I,K,1) = QV3D(i,k,j)/(1.+QV3D(i,k,j))
-          Q1(I,K,2) = QC3D(i,k,j)/(1.+QC3D(i,k,j))
-          PRSL(I,K)=P3D(i,k,j)*.001
-        ENDDO
-      ENDDO
-
-      DO k=kts,kte
-        DO i=its,ite 
-          PRSLK(I,K)=(PRSL(i,k)*.01)**ROVCP
-        ENDDO
-      ENDDO
-
-
-      DO k=kts+1,kte
-        km=k-1
-        DO i=its,ite 
-          DEL(i,km)=PRSL(i,km)/ROVG*dz8w(i,km,j)/T3D(i,km,j)
-          PRSI(i,k)=PRSI(i,km)-DEL(i,km)
-          PHII(I,K)=(Z(i,k,j)-Z(i,kts,j))*G
-          PHIL(I,KM)=0.5*(Z(i,k,j)+Z(i,km,j)-2.*Z(i,kts,j))*G
-        ENDDO
-      ENDDO
-
-      DO i=its,ite 
-        DEL(i,kte)=DEL(i,ktem)
-        PRSI(i,ktep)=PRSI(i,kte)-DEL(i,ktem)
-        PHII(I,KTEP)=PHII(I,KTE)+dz8w(i,kte,j)*G
-        PHIL(I,KTE)=PHII(I,KTE)-PHIL(I,KTEM)+PHII(I,KTE)
-      ENDDO
-
-      IF (P_QI.ge.P_FIRST_SCALAR) THEN
-        DO k=kts,kte
-          DO i=its,ite 
-            Q1(I,K,3) = QI3D(i,k,j)/(1.+QI3D(i,k,j))
-          ENDDO
-        ENDDO
-      ENDIF
-
-      DO l=1,ntrac
-        DO k=kts,kte
-          DO i=its,ite
-            RTG(I,K,L) = 0.
-          ENDDO
-        ENDDO
-      ENDDO
-!
-!  2010 new gfs pbl
-!
-      call moninq(im,im,km,ntrac,dv,du,tau,rtg,                       &
-     &     u1,v1,t1,q1,thraten,                                       &  !kwon
-     &     psk,rbsoil,fm,fh,tsea,qss,heat,evap,stress,spd1,kpbl,      &
-     &     prsi,del,prsl,prslk,phii,phil,rcl,deltim,                  &
-     &     dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq)
-
-!============================================================================
-!    ADD  IN  DISSIPATIVE HEATING .... v*dv. This is Bob's doing
-!============================================================================
-
-#if (NMM_CORE==1)
-
-      IF(DISHEAT)THEN
-       DO k=kts,kte
-         DO i=its,ite
-          dishx(i,k)=u1(i,k)*du(i,k) + v1(i,k)*dv(i,k)
-          cpmikj=CP*(1.+0.8*QV3D(i,k,j))
-          dishx(i,k)=-dishx(i,k)/cpmikj
-!         IF(k==1)WRITE(0,*)'ADDITIONAL DISSIPATIVE HEATING',tau(i,k),dishx(i,k)
-          tau(i,k)=tau(i,k)+dishx(i,k)
-         ENDDO 
-       ENDDO 
-      ENDIF
-#endif
-
-!=============================================================================
-
-
-      DO k=kts,kte
-        DO i=its,ite
-          RVBLTEN(I,K,J)=DV(I,K)
-          RUBLTEN(I,K,J)=DU(I,K)
-          RTHBLTEN(I,K,J)=TAU(I,K)/PI3D(I,K,J)
-          RQVBLTEN(I,K,J)=RTG(I,K,1)/(1.-Q1(I,K,1))**2
-          RQCBLTEN(I,K,J)=RTG(I,K,2)/(1.-Q1(I,K,2))**2
-        ENDDO
-      ENDDO
-
-      IF (P_QI.ge.P_FIRST_SCALAR) THEN
-        DO k=kts,kte
-          DO i=its,ite
-            RQIBLTEN(I,K,J)=RTG(I,K,3)/(1.-Q1(I,K,3))**2
-          ENDDO
-        ENDDO
-      ENDIF
-
-      DO i=its,ite
-        UST(i,j)=SQRT(STRESS(i))
-        WSPD(i,j)=SQRT(U3D(I,KTS,J)*U3D(I,KTS,J)+                       &
-                       V3D(I,KTS,J)*V3D(I,KTS,J))+1.E-9
-        PBL(i,j)=HPBL(i)
-!Kwon For new shallow convection
-        HPBL2D(i,j)=HPBL(i)
-!
-        KPBL2D(i,j)=kpbl(i)
-      ENDDO
-
-    ENDDO
-
-
-   END SUBROUTINE BL_GFS2011
-
-!===================================================================
-   SUBROUTINE gfs2011init(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,       &
-                      RQCBLTEN,RQIBLTEN,P_QI,P_FIRST_SCALAR,       &
-                      restart,                                     &
-                      allowed_to_read,                             &
-                      ids, ide, jds, jde, kds, kde,                &
-                      ims, ime, jms, jme, kms, kme,                &
-                      its, ite, jts, jte, kts, kte                 )
-!-------------------------------------------------------------------          
-   IMPLICIT NONE
-!-------------------------------------------------------------------          
-   LOGICAL , INTENT(IN)          ::  allowed_to_read,restart
-   INTEGER , INTENT(IN)          ::  ids, ide, jds, jde, kds, kde, &
-                                     ims, ime, jms, jme, kms, kme, &
-                                     its, ite, jts, jte, kts, kte
-   INTEGER , INTENT(IN)          ::  P_QI,P_FIRST_SCALAR
-
-   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::         &
-                                                         RUBLTEN, &
-                                                         RVBLTEN, &
-                                                         RTHBLTEN, &
-                                                         RQVBLTEN, &
-                                                         RQCBLTEN, & 
-                                                         RQIBLTEN
-   INTEGER :: i, j, k, itf, jtf, ktf
-
-   jtf=min0(jte,jde-1)
-   ktf=min0(kte,kde-1)
-   itf=min0(ite,ide-1)
-
-   IF(.not.restart)THEN
-     DO j=jts,jtf
-     DO k=kts,ktf
-     DO i=its,itf
-        RUBLTEN(i,k,j)=0.
-        RVBLTEN(i,k,j)=0.
-        RTHBLTEN(i,k,j)=0.
-        RQVBLTEN(i,k,j)=0.
-        RQCBLTEN(i,k,j)=0.
-     ENDDO
-     ENDDO
-     ENDDO
-   ENDIF
-
-   IF (P_QI .ge. P_FIRST_SCALAR .and. .not.restart) THEN
-      DO j=jts,jtf
-      DO k=kts,ktf
-      DO i=its,itf
-         RQIBLTEN(i,k,j)=0.
-      ENDDO
-      ENDDO
-      ENDDO
-   ENDIF
-
-   IF (P_QI .ge. P_FIRST_SCALAR) THEN
-      DO j=jts,jtf
-      DO k=kts,ktf
-      DO i=its,itf
-         RQIBLTEN(i,k,j)=0.
-      ENDDO
-      ENDDO
-      ENDDO
-   ENDIF
-
-
-   END SUBROUTINE gfs2011init
-
-! --------------------------------------------------------------
-!========================================================  2010 NEW GFS PBL
-!FPP$ NOCONCUR R
-!-----------------------------------------------------------------------
-      subroutine moninq(ix,im,km,ntrac,dv,du,tau,rtg,              &
-     &     uo,vo,t1,q1,thraten,                                    &     !kwon
-     &     psk,rbsoil,fm,fh,tsea,qss,heat,evap,stress,spd1,kpbl,   &
-     &     prsi,del,prsl,prslk,phii,phil,rcs,deltim,               &
-     &     dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq)                     !kwon
-!     &     dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt)
-!
-!      use machine     , only : kind_phys
-!      use funcphys , only : fpvs
-!      use physcons, grav => con_g, rd => con_rd, cp => con_cp      &
-!     &,             hvap => con_hvap, fv => con_fvirt
-!
-      USE MODULE_GFS_MACHINE, ONLY : kind_phys                               !kwon
-!      USE MODULE_GFS_FUNCPHYS, ONLY : fpvs                                  !kwon
-      USE MODULE_GFS_PHYSCONS, grav => con_g, rd => con_rd,           &      !kwon
-     &           cp => con_cp,  hvap => con_hvap, fv => con_fvirt            !kwon
-!
-      implicit none
-!
-!     include 'constant.h'
-!
-!
-!     arguments
-!
-      integer ix, im, km, ntrac, kpbl(im), kpblx(im)
-!
-      real(kind=kind_phys) deltim
-      real(kind=kind_phys) dv(im,km),     du(im,km),          &
-     &                     tau(im,km),    rtg(im,km,ntrac),          &
-     &                     uo(ix,km),     vo(ix,km),          &
-     &                     t1(ix,km),     q1(ix,km,ntrac),          &
-     &                     swh(ix,km),    hlw(ix,km),          &
-     &                     xmu(im),          &
-     &                     psk(im),       rbsoil(im),          &
-!    &                     cd(im),        ch(im),          &
-     &                     fm(im),        fh(im),          &
-     &                     tsea(im),      qss(im),          &
-     &                                    spd1(im),          &
-!    &                     dphi(im),      spd1(im),          &
-     &                     prsi(ix,km+1), del(ix,km),          &
-     &                     prsl(ix,km),   prslk(ix,km),    &
-     &                     phii(ix,km+1), phil(ix,km),          &
-     &                     rcs(im),       dusfc(im),          &
-     &                     dvsfc(im),     dtsfc(im),          &
-     &                     dqsfc(im),     hpbl(im),      hpblx(im),          &
-     &                     hgamt(im),     hgamq(im)
-!    &,                    hgamu(im),     hgamv(im),     hgams(im)
-!
-!    locals
-!
-      integer i,iprt,is,iun,k,kk,km1,kmpbl,latd,lond
-      integer lcld(im),icld(im),kcld(im),krad(im)
-      integer kemx(im)
-!
-!     real(kind=kind_phys) betaq(im), betat(im),   betaw(im),
-      real(kind=kind_phys) evap(im),  heat(im),    phih(im),    &
-     &                     phim(im),  rbdn(im),    rbup(im),    &
-     &                     stress(im),beta(im),    &
-     &                     ustar(im), wscale(im),  thermal(im),    &
-     &                     wstar3(im)
-!
-      real(kind=kind_phys) thvx(im,km), thlvx(im,km),thraten(im,km),   & !Kwon
-     &                     qlx(im,km),  thetae(im,km),    &
-     &                     qtx(im,km),  bf(im,km-1),    &
-     &                     u1(im,km),   v1(im,km),    radx(im,km-1),    &
-     &                     govrth(im),  hrad(im),     cteit(im),    &
-!    &                     hradm(im),   radmin(im),   vrad(im),    &
-     &                     radmin(im),  vrad(im),    &
-     &                     zd(im),      zdd(im),      thlvx1(im)
-!
-      real(kind=kind_phys) rdzt(im,km-1),dktx(im,km-1),dkux(im,km-1),    &
-     &                     zi(im,km+1),  zl(im,km),    xkzo(im,km-1),    &
-     &                     dku(im,km-1), dkt(im,km-1),xkzmo(im,km-1),    &
-     &                     cku(im,km-1), ckt(im,km-1),    &
-     &                     al(im,km-1),  ad(im,km),    &
-     &                     au(im,km-1),  a1(im,km),     &
-     &                     a2(im,km*ntrac), theta(im,km)
-!
-!     real(kind=kind_phys) prinv(im), hpbl01(im), rent(im)
-      real(kind=kind_phys) prinv(im), rent(im)
-!
-      logical  pblflg(im), sfcflg(im), scuflg(im), flg(im)
-!
-      real(kind=kind_phys) aphi16,  aphi5,  bvf2,   wfac,    &
-     &                     cfac,    conq,   cont,   conw,    &
-     &                     dk,      dkmax,  dkmin,    &
-     &                     dq1,     dsdz2,  dsdzq,  dsdzt,    &
-     &                     dsdzu,   dsdzv,  sfac,    &
-     &                     dsig,    dt,     dthe1,  dtodsd,    &
-     &                     dtodsu,  dw2,    dw2min, g,    &
-     &                     gamcrq,  gamcrt, gocp,   gor, gravi,    &
-     &                     hol,     hol1,   pfac,   prmax, prmin,    &
-     &                     prnum,   qmin,   tdzmin, qtend, rbcr,    &
-     &                     rbint,   rdt,    rdz,    qlmin,     &
-!    &                     rbint,   rdt,    rdz,    rdzt1,    &
-     &                     ri,      rimin,  rl2,    rlam,  rlamun,    &
-     &                     rone,    rzero,  sfcfrac,sflux,    &
-     &                     shr2,    spdk2,  sri,    &
-     &                     tem,     ti,     ttend,  tvd,    &
-     &                     tvu,     utend,  vk,     vk2,    &
-     &                     vtend,   zfac,   vpert,  cpert,    &
-     &                     rentf1,  rentf2, radfac,    &
-     &                     zfmin,   zk,     tem1,   tem2,    &
-     &                     xkzm,    xkzmu,  xkzminv,    &
-     &                     ptem,    ptem1,  ptem2
-!
-      real(kind=kind_phys) zstblmax,h1,     h2,     qlcr,  actei,    &
-     &                     cldtime, u01,    v01,    delu,  delv
-!
-      parameter(gravi=1.0/grav)
-      parameter(g=grav)
-      parameter(gor=g/rd,gocp=g/cp)
-      parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g)
-      parameter(rlam=30.0,vk=0.4,vk2=vk*vk)
-      parameter(prmin=0.25,prmax=4.)
-      parameter(dw2min=0.0001,dkmin=0.0,dkmax=1000.,rimin=-100.)
-      parameter(rbcr=0.25,wfac=7.0,cfac=6.5,pfac=2.0,sfcfrac=0.1)
-      parameter(qmin=1.e-8,xkzm=1.0,zfmin=1.e-8,aphi5=5.,aphi16=16.)
-      parameter(tdzmin=1.e-3,qlmin=1.e-12,cpert=0.25,sfac=5.4)
-      parameter(h1=0.33333333,h2=0.66666667)
-      parameter(cldtime=500.,xkzmu=3.0,xkzminv=0.3)
-!     parameter(gamcrt=3.,gamcrq=2.e-3,rlamun=150.0)
-      parameter(gamcrt=3.,gamcrq=0.,rlamun=150.0)
-      parameter(rentf1=0.2,rentf2=1.0,radfac=0.85)
-      parameter(iun=84)
-!
-!     parameter (zstblmax = 2500., qlcr=1.0e-5)
-!     parameter (zstblmax = 2500., qlcr=3.0e-5)
-!     parameter (zstblmax = 2500., qlcr=3.5e-5)
-!     parameter (zstblmax = 2500., qlcr=1.0e-4)
-      parameter (zstblmax = 2500., qlcr=3.5e-5)
-!     parameter (actei = 0.23)
-      parameter (actei = 0.7)
-!
-!-----------------------------------------------------------------------
-!
- 601  format(1x,' moninp lat lon step hour ',3i6,f6.1)
- 602      format(1x,'    k','        z','        t','       th',    &
-     &     '      tvh','        q','        u','        v',         &
-     &     '       sp')
- 603      format(1x,i5,8f9.1)
- 604      format(1x,'  sfc',9x,f9.1,18x,f9.1)
- 605      format(1x,'    k      zl    spd2   thekv   the1v'         &
-     &         ,' thermal    rbup')
- 606      format(1x,i5,6f8.2)
- 607      format(1x,' kpbl    hpbl      fm      fh   hgamt',        &
-     &         '   hgamq      ws   ustar      cd      ch')
- 608      format(1x,i5,9f8.2)
- 609      format(1x,' k pr dkt dku ',i5,3f8.2)
- 610      format(1x,' k pr dkt dku ',i5,3f8.2,' l2 ri t2',          &
-     &         ' sr2  ',2f8.2,2e10.2)
-! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
-!     compute preliminary variables
-!
-      if (ix .lt. im) stop
-!
-!     iprt = 0
-!     if(iprt.eq.1) then
-!ccc   latd = 0
-!     lond = 0
-!     else
-!ccc   latd = 0
-!     lond = 0
-!     endif
-!c
-      dt    = 2. * deltim
-      rdt   = 1. / dt
-      km1   = km - 1
-      kmpbl = km / 2
-!
-      do k=1,km
-        do i=1,im
-          zi(i,k) = phii(i,k) * gravi
-          zl(i,k) = phil(i,k) * gravi
-          u1(i,k) = uo(i,k) * rcs(i)
-          v1(i,k) = vo(i,k) * rcs(i)
-        enddo
-      enddo
-      do i=1,im
-         zi(i,km+1) = phii(i,km+1) * gravi
-      enddo
-!c
-      do k = 1,km1
-        do i=1,im
-          rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k))
-        enddo
-      enddo
-!c
-!c  vertical background diffusivity
-!c
-      do k = 1,km1
-        do i=1,im
-          tem1      = 1.0 - prsi(i,k+1) / prsi(i,1)
-          tem1      = tem1 * tem1 * 10.0
-          xkzo(i,k) = xkzm * min(real(1.0,kind=kind_phys), exp(-tem1))
-        enddo
-      enddo
-!c
-!c  vertical background diffusivity for momentum
-!c
-      do k = 1,km1
-        do i=1,im
-          ptem = prsi(i,k+1) / prsi(i,1)
-          if(ptem.ge.0.2) then
-            xkzmo(i,k) = xkzmu
-            ptem1 = prsi(i,k+1)
-          else
-            tem1 = 1.0 - prsi(i,k+1) / ptem1
-            tem1 = tem1 * tem1 * 5.0
-            xkzmo(i,k) = xkzmu * min(real(1.0,kind=kind_phys), exp(-tem1))
-          endif
-        enddo
-      enddo
-!c
-!c  diffusivity in the inversion layer is set to be xkzminv (m^2/s)
-!c
-      do k = 1,kmpbl
-        do i=1,im
-!         if(zi(i,k+1).gt.200..and.zi(i,k+1).lt.zstblmax) then
-          if(zi(i,k+1).gt.250.) then
-            tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k)
-            if(tem1 .gt. 1.e-5) then
-               xkzo(i,k) = min(xkzo(i,k),xkzminv)
-            endif
-          endif
-        enddo
-      enddo
-!c
-      do i = 1,im
-         dusfc(i) = 0.
-         dvsfc(i) = 0.
-         dtsfc(i) = 0.
-         dqsfc(i) = 0.
-         hgamt(i) = 0.
-         hgamq(i) = 0.
-!        hgamu(i) = 0.
-!        hgamv(i) = 0.
-!        hgams(i) = 0.
-         wscale(i)= 0.
-         kpbl(i)  = 1
-         kpblx(i) = 1
-         hpbl(i)  = zi(i,1)
-         hpblx(i) = zi(i,1)
-         pblflg(i)= .true.
-         sfcflg(i)= .true.
-         if(rbsoil(i).gt.0.0) sfcflg(i) = .false.
-         scuflg(i)= .true.
-         if(scuflg(i)) then
-           radmin(i)= 0.
-           cteit(i) = 0.
-           rent(i)  = rentf1
-           hrad(i)  = zi(i,1)
-!          hradm(i) = zi(i,1)
-           krad(i)  = 1
-           icld(i)  = 0
-           lcld(i)  = km1
-           kcld(i)  = km1
-           zd(i)    = 0.
-        endif
-      enddo
-!
-      do k = 1,km
-        do i = 1,im
-          theta(i,k) = t1(i,k) * psk(i) / prslk(i,k)
-          qlx(i,k)   = max(q1(i,k,ntrac),qlmin)
-          qtx(i,k)   = max(q1(i,k,1),qmin)+qlx(i,k)
-          ptem       = qlx(i,k)
-          ptem1      = hvap*max(q1(i,k,1),qmin)/(cp*t1(i,k))
-          thetae(i,k)= theta(i,k)*(1.+ptem1)
-          thvx(i,k)  = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-ptem)
-          ptem2      = theta(i,k)-(hvap/cp)*ptem
-          thlvx(i,k) = ptem2*(1.+fv*qtx(i,k))
-        enddo
-      enddo
-      do k = 1,km1
-        do i = 1,im
-          dku(i,k)  = 0.
-          dkt(i,k)  = 0.
-          dktx(i,k) = 0.
-          dkux(i,k) = 0.
-          cku(i,k)  = 0.
-          ckt(i,k)  = 0.
-          tem       = zi(i,k+1)-zi(i,k)
-!          radx(i,k) = tem*(swh(i,k)*xmu(i)+hlw(i,k))
-          radx(i,k) = tem*thraten(i,k)                   !Kwon
-        enddo
-      enddo
-!c
-      do i=1,im
-         flg(i)  = scuflg(i)
-      enddo
-      do k = 1, km1
-        do i=1,im
-          if(flg(i).and.zl(i,k).ge.zstblmax) then
-             lcld(i)=k
-             flg(i)=.false.
-          endif
-      enddo
-      enddo
-!c
-!c  compute buoyancy flux
-!c
-      do k = 1, km1
-      do i = 1, im
-         bf(i,k) = (thvx(i,k+1)-thvx(i,k))*rdzt(i,k)
-      enddo
-      enddo
-!c
-      do i = 1,im
-        govrth(i) = g/theta(i,1)
-      enddo
-!c
-      do i=1,im
-         beta(i)  = dt / (zi(i,2)-zi(i,1))
-      enddo
-!c
-      do i=1,im
-         ustar(i) = sqrt(stress(i))
-         thermal(i) = thvx(i,1)
-      enddo
-!c
-!c  compute the first guess pbl height
-!c
-      do i=1,im
-         flg(i) = .false.
-         rbup(i) = rbsoil(i)
-      enddo
-      do k = 2, kmpbl
-      do i = 1, im
-        if(.not.flg(i)) then
-          rbdn(i) = rbup(i)
-          spdk2   = max((u1(i,k)**2+v1(i,k)**2),real(1.0,kind=kind_phys))
-          rbup(i) = (thvx(i,k)-thermal(i))*        &
-     &              (g*zl(i,k)/thvx(i,1))/spdk2
-          kpbl(i) = k
-          flg(i)  = rbup(i).gt.rbcr
-        endif
-      enddo
-      enddo
-      do i = 1,im
-         k = kpbl(i)
-         if(rbdn(i).ge.rbcr) then
-           rbint = 0.
-         elseif(rbup(i).le.rbcr) then
-           rbint = 1.
-         else
-           rbint = (rbcr-rbdn(i))/(rbup(i)-rbdn(i))
-         endif
-         hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1))
-         if(hpbl(i).lt.zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1
-         hpblx(i) = hpbl(i)
-         kpblx(i) = kpbl(i)
-      enddo
-!c
-!c     compute similarity parameters 
-!c
-      do i=1,im
-         sflux = heat(i) + evap(i)*fv*theta(i,1)
-         if(sfcflg(i).and.sflux.gt.0.) then
-           hol = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin)
-           hol = min(hol,-zfmin)
-!c
-           hol1 = hol*hpbl(i)/zl(i,1)*sfcfrac
-!          phim(i) = (1.-aphi16*hol1)**(-1./4.)
-!          phih(i) = (1.-aphi16*hol1)**(-1./2.)
-           tem     = 1.0 / (1. - aphi16*hol1)
-           phih(i) = sqrt(tem)
-           phim(i) = sqrt(phih(i))
-           wstar3(i) = govrth(i)*sflux*hpbl(i)
-           tem1      = ustar(i)**3.
-           wscale(i) = (tem1+wfac*vk*wstar3(i)*sfcfrac)**h1
-!          wscale(i) = ustar(i)/phim(i)
-           wscale(i) = min(wscale(i),ustar(i)*aphi16)
-           wscale(i) = max(wscale(i),ustar(i)/aphi5)
-         else
-           pblflg(i)=.false.
-         endif
-      enddo
-!c
-!c compute counter-gradient mixing term for heat and moisture
-!c
-      do i = 1,im
-         if(pblflg(i)) then
-           hgamt(i)  = min(cfac*heat(i)/wscale(i),gamcrt)
-           hgamq(i)  = min(cfac*evap(i)/wscale(i),gamcrq)
-           vpert     = hgamt(i) + hgamq(i)*fv*theta(i,1)
-           vpert     = min(vpert,gamcrt)
-           thermal(i)= thermal(i)+max(vpert,real(0.0,kind=kind_phys))
-           hgamt(i)  = max(hgamt(i),real(0.0,kind=kind_phys))
-           hgamq(i)  = max(hgamq(i),real(0.0,kind=kind_phys))
-         endif
-      enddo
-!c
-!c compute large-scale mixing term for momentum
-!c
-!     do i = 1,im
-!       flg(i) = pblflg(i)
-!       kemx(i)= 1
-!       hpbl01(i)= sfcfrac*hpbl(i)
-!     enddo
-!     do k = 1, kmpbl
-!     do i = 1, im
-!       if(flg(i).and.zl(i,k).gt.hpbl01(i)) then
-!         kemx(i) = k
-!         flg(i)  = .false.
-!       endif
-!     enddo
-!     enddo
-!     do i = 1, im
-!       if(pblflg(i)) then
-!         kk = kpbl(i)
-!         if(kemx(i).le.1) then
-!           ptem  = u1(i,1)/zl(i,1)
-!           ptem1 = v1(i,1)/zl(i,1)
-!           u01   = ptem*hpbl01(i)
-!           v01   = ptem1*hpbl01(i)
-!         else
-!           tem   = zl(i,kemx(i))-zl(i,kemx(i)-1)
-!           ptem  = (u1(i,kemx(i))-u1(i,kemx(i)-1))/tem
-!           ptem1 = (v1(i,kemx(i))-v1(i,kemx(i)-1))/tem
-!           tem1  = hpbl01(i)-zl(i,kemx(i)-1)
-!           u01   = u1(i,kemx(i)-1)+ptem*tem1
-!           v01   = v1(i,kemx(i)-1)+ptem1*tem1
-!         endif
-!         if(kk.gt.kemx(i)) then
-!           delu  = u1(i,kk)-u01
-!           delv  = v1(i,kk)-v01
-!           tem2  = sqrt(delu**2+delv**2)
-!           tem2  = max(tem2,0.1)
-!           ptem2 = -sfac*ustar(i)*ustar(i)*wstar3(i)
-!    1                /(wscale(i)**4.)
-!           hgamu(i) = ptem2*delu/tem2
-!           hgamv(i) = ptem2*delv/tem2
-!           tem  = sqrt(u1(i,kk)**2+v1(i,kk)**2)
-!           tem1 = sqrt(u01**2+v01**2)
-!           ptem = tem - tem1
-!           if(ptem.gt.0.) then
-!             hgams(i)=-sfac*vk*sfcfrac*wstar3(i)/(wscale(i)**3.)
-!           else
-!             hgams(i)=sfac*vk*sfcfrac*wstar3(i)/(wscale(i)**3.)
-!           endif
-!         else
-!           hgams(i) = 0.
-!         endif
-!       endif
-!     enddo
-!c
-!c  enhance the pbl height by considering the thermal excess
-!c
-      do i=1,im
-         flg(i)  = .true.
-         if(pblflg(i)) then
-           flg(i)  = .false.
-           rbup(i) = rbsoil(i)
-         endif
-      enddo
-      do k = 2, kmpbl
-      do i = 1, im
-        if(.not.flg(i)) then
-          rbdn(i) = rbup(i)
-          spdk2   = max((u1(i,k)**2+v1(i,k)**2),real(1.0,kind=kind_phys))
-          rbup(i) = (thvx(i,k)-thermal(i))*        &
-     &              (g*zl(i,k)/thvx(i,1))/spdk2
-          kpbl(i) = k
-          flg(i)  = rbup(i).gt.rbcr
-        endif
-      enddo
-      enddo
-      do i = 1,im
-        if(pblflg(i)) then
-           k = kpbl(i)
-           if(rbdn(i).ge.rbcr) then
-              rbint = 0.
-           elseif(rbup(i).le.rbcr) then
-              rbint = 1.
-           else
-              rbint = (rbcr-rbdn(i))/(rbup(i)-rbdn(i))
-           endif
-           hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1))
-           if(hpbl(i).lt.zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1
-           if(kpbl(i).le.1) pblflg(i) = .false.
-        endif
-      enddo
-!c
-!c  look for stratocumulus
-!c
-      do i = 1, im
-        flg(i)=scuflg(i)
-      enddo
-      do k = kmpbl,1,-1
-      do i = 1, im
-        if(flg(i).and.k.le.lcld(i)) then
-          if(qlx(i,k).ge.qlcr) then
-             kcld(i)=k
-             flg(i)=.false.
-          endif
-        endif
-      enddo
-      enddo
-      do i = 1, im
-        if(scuflg(i).and.kcld(i).eq.km1) scuflg(i)=.false.
-      enddo
-!c
-      do i = 1, im
-        flg(i)=scuflg(i)
-      enddo
-      do k = kmpbl,1,-1
-      do i = 1, im
-        if(flg(i).and.k.le.kcld(i)) then
-          if(qlx(i,k).ge.qlcr) then
-            if(radx(i,k).lt.radmin(i)) then
-              radmin(i)=radx(i,k)
-              krad(i)=k
-            endif
-          else
-            flg(i)=.false.
-          endif
-        endif
-      enddo
-      enddo
-      do i = 1, im
-        if(scuflg(i).and.krad(i).le.1) scuflg(i)=.false.
-        if(scuflg(i).and.radmin(i).ge.0.) scuflg(i)=.false.
-      enddo
-!c
-      do i = 1, im
-        flg(i)=scuflg(i)
-      enddo
-      do k = kmpbl,2,-1
-      do i = 1, im
-        if(flg(i).and.k.le.krad(i)) then
-          if(qlx(i,k).ge.qlcr) then
-            icld(i)=icld(i)+1
-          else
-            flg(i)=.false.
-          endif
-        endif
-      enddo
-      enddo
-      do i = 1, im
-        if(scuflg(i).and.icld(i).lt.1) scuflg(i)=.false.
-      enddo
-!c
-      do i = 1, im
-        if(scuflg(i)) then
-           hrad(i) = zi(i,krad(i)+1)
-!          hradm(i)= zl(i,krad(i))
-        endif
-      enddo
-!c
-      do i = 1, im
-        if(scuflg(i).and.hrad(i).lt.zi(i,2)) scuflg(i)=.false.
-      enddo
-!c
-      do i = 1, im
-        if(scuflg(i)) then
-          k    = krad(i)
-          tem  = zi(i,k+1)-zi(i,k)
-          tem1 = cldtime*radmin(i)/tem
-          thlvx1(i) = thlvx(i,k)+tem1
-!         if(thlvx1(i).gt.thlvx(i,k-1)) scuflg(i)=.false.
-        endif
-      enddo
-!c 
-      do i = 1, im
-         flg(i)=scuflg(i)
-      enddo
-      do k = kmpbl,1,-1
-      do i = 1, im
-        if(flg(i).and.k.le.krad(i))then
-          if(thlvx1(i).le.thlvx(i,k))then
-             tem=zi(i,k+1)-zi(i,k)
-             zd(i)=zd(i)+tem
-          else
-             flg(i)=.false.
-          endif
-        endif
-      enddo
-      enddo
-      do i = 1, im
-        if(scuflg(i))then
-          kk = max(1, krad(i)+1-icld(i))
-          zdd(i) = hrad(i)-zi(i,kk)
-        endif
-      enddo
-      do i = 1, im
-        if(scuflg(i))then
-          zd(i) = max(zd(i),zdd(i))
-          zd(i) = min(zd(i),hrad(i))
-          tem   = govrth(i)*zd(i)*(-radmin(i))
-          vrad(i)= tem**h1
-        endif
-      enddo
-!c
-!c     compute inverse Prandtl number
-!c
-      do i = 1, im
-        if(pblflg(i)) then
-          tem = phih(i)/phim(i)+cfac*vk*sfcfrac
-!         prinv(i) = (1.0-hgams(i))/tem
-          prinv(i) = 1.0 / tem
-          prinv(i) = min(prinv(i),prmax)
-          prinv(i) = max(prinv(i),prmin)
-        endif
-      enddo
-!c
-!c     compute diffusion coefficients below pbl
-!c
-      do k = 1, kmpbl
-      do i=1,im
-         if(pblflg(i).and.k.lt.kpbl(i)) then
-!           zfac = max((1.-(zi(i,k+1)-zl(i,1))/
-!    1             (hpbl(i)-zl(i,1))), zfmin)
-            zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin)
-            tem = wscale(i)*vk*zi(i,k+1)*zfac**pfac
-!           dku(i,k) = xkzo(i,k)+wscale(i)*vk*zi(i,k+1)
-!    1                 *zfac**pfac
-            dku(i,k) = xkzmo(i,k) + tem
-            dkt(i,k) = xkzo(i,k) + tem * prinv(i)
-            dku(i,k) = min(dku(i,k),dkmax)
-!           dku(i,k) = max(dku(i,k),xkzmo(i,k))
-            dkt(i,k) = min(dkt(i,k),dkmax)
-!           dkt(i,k) = max(dkt(i,k),xkzo(i,k))
-            dktx(i,k)= dkt(i,k)
-            dkux(i,k)= dku(i,k)
-         endif
-      enddo
-      enddo
-!c
-!c compute diffusion coefficients based on local scheme
-!c
-      do i = 1, im
-        if(.not.pblflg(i)) then
-          kpbl(i) = 1
-        endif
-      enddo
-      do k = 1, km1
-         do i=1,im
-            if(k.ge.kpbl(i)) then
-               rdz  = rdzt(i,k)
-               ti   = 2./(t1(i,k)+t1(i,k+1))
-               dw2  = (u1(i,k)-u1(i,k+1))**2        &
-     &               +(v1(i,k)-v1(i,k+1))**2
-               shr2 = max(dw2,dw2min)*rdz*rdz
-               bvf2 = g*bf(i,k)*ti
-               ri   = max(bvf2/shr2,rimin)
-               zk   = vk*zi(i,k+1)
-               if(ri.lt.0.) then ! unstable regime
-                  rl2      = zk*rlamun/(rlamun+zk)
-                  dk       = rl2*rl2*sqrt(shr2)
-                  sri      = sqrt(-ri)
-                  dku(i,k) = xkzmo(i,k) + dk*(1+8.*(-ri)/(1+1.746*sri))
-                  dkt(i,k) = xkzo(i,k) + dk*(1+8.*(-ri)/(1+1.286*sri))
-               else             ! stable regime
-                  rl2      = zk*rlam/(rlam+zk)
-!!                tem      = rlam * sqrt(0.01*prsi(i,k))
-!!                rl2      = zk*tem/(tem+zk)
-                  dk       = rl2*rl2*sqrt(shr2)
-                  tem1     = dk/(1+5.*ri)**2
-                  if(k.ge.kpblx(i)) then
-                    prnum = 1.0 + 2.1*ri
-                    prnum = min(prnum,prmax)
-                  else
-                    prnum = 1.0
-                  endif
-                  dkt(i,k) = xkzo(i,k) + tem1
-                  dku(i,k) = xkzmo(i,k) + tem1 * prnum
-               endif
-!c
-               dku(i,k) = min(dku(i,k),dkmax)
-!              dku(i,k) = max(dku(i,k),xkzmo(i,k))
-               dkt(i,k) = min(dkt(i,k),dkmax)
-!              dkt(i,k) = max(dkt(i,k),xkzo(i,k))
-!c
-            endif
-!c
-         enddo
-      enddo
-!c
-!c  compute diffusion coefficients for cloud-top driven diffusion
-!c  if the condition for cloud-top instability is met,
-!c    increase entrainment flux at cloud top
-!c
-      do i = 1, im
-        if(scuflg(i)) then
-           k = krad(i)
-           tem = thetae(i,k) - thetae(i,k+1)
-           tem1 = qtx(i,k) - qtx(i,k+1)
-           if (tem.gt.0..and.tem1.gt.0.) then
-             cteit(i)= cp*tem/(hvap*tem1)
-             if(cteit(i).gt.actei) rent(i) = rentf2
-           endif
-        endif
-      enddo
-      do i = 1, im
-        if(scuflg(i)) then
-           k = krad(i)
-           tem1  = max(bf(i,k),tdzmin)
-           ckt(i,k) = -rent(i)*radmin(i)/tem1
-           cku(i,k) = ckt(i,k)
-        endif
-      enddo
-!c
-      do k = 1, kmpbl
-         do i=1,im
-            if(scuflg(i).and.k.lt.krad(i)) then
-               tem1=hrad(i)-zd(i)
-               tem2=zi(i,k+1)-tem1
-               if(tem2.gt.0.) then
-                  ptem= tem2/zd(i)
-                  if(ptem.ge.1.) ptem= 1.
-                  ptem= tem2*ptem*sqrt(1.-ptem)
-                  ckt(i,k) = radfac*vk*vrad(i)*ptem
-                  cku(i,k) = 0.75*ckt(i,k)
-                  ckt(i,k) = max(ckt(i,k),dkmin)
-                  ckt(i,k) = min(ckt(i,k),dkmax)
-                  cku(i,k) = max(cku(i,k),dkmin)
-                  cku(i,k) = min(cku(i,k),dkmax)
-               endif
-            endif
-         enddo
-      enddo
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-      do k = 1, kmpbl
-        do i=1,im
-          if(scuflg(i)) then
-             dkt(i,k) = dkt(i,k)+ckt(i,k)
-             dku(i,k) = dku(i,k)+cku(i,k)
-             dkt(i,k) = min(dkt(i,k),dkmax)
-             dku(i,k) = min(dku(i,k),dkmax)
-          endif
-        enddo
-      enddo
-!c
-!c     compute tridiagonal matrix elements for heat and moisture
-!c
-      do i=1,im
-         ad(i,1) = 1.
-         a1(i,1) = t1(i,1)   + beta(i) * heat(i)
-         a2(i,1) = q1(i,1,1) + beta(i) * evap(i)
-      enddo
-      if(ntrac.ge.2) then
-        do k = 2, ntrac
-          is = (k-1) * km
-          do i = 1, im
-            a2(i,1+is) = q1(i,1,k)
-          enddo
-        enddo
-      endif
-!c
-      do k = 1,km1
-        do i = 1,im
-          dtodsd = dt/del(i,k)
-          dtodsu = dt/del(i,k+1)
-          dsig   = prsl(i,k)-prsl(i,k+1)
-!         rdz    = rdzt(i,k)*2./(t1(i,k)+t1(i,k+1))
-          rdz    = rdzt(i,k)
-          tem1   = dsig * dkt(i,k) * rdz
-          if(pblflg(i).and.k.lt.kpbl(i)) then
-!            dsdzt = dsig*dkt(i,k)*rdz*(gocp-hgamt(i)/hpbl(i))
-!            dsdzq = dsig*dkt(i,k)*rdz*(-hgamq(i)/hpbl(i))
-             ptem1 = dsig * dktx(i,k) * rdz
-             tem   = 1.0 / hpbl(i)
-             dsdzt = tem1 * gocp - ptem1*hgamt(i)*tem
-             dsdzq = ptem1 * (-hgamq(i)*tem)
-             a2(i,k)   = a2(i,k)+dtodsd*dsdzq
-             a2(i,k+1) = q1(i,k+1,1)-dtodsu*dsdzq
-          else
-!            dsdzt = dsig*dkt(i,k)*rdz*(gocp)
-             dsdzt = tem1 * gocp
-             a2(i,k+1) = q1(i,k+1,1)
-          endif
-!         dsdz2 = dsig*dkt(i,k)*rdz*rdz
-          dsdz2     = tem1 * rdz
-          au(i,k)   = -dtodsd*dsdz2
-          al(i,k)   = -dtodsu*dsdz2
-          ad(i,k)   = ad(i,k)-au(i,k)
-          ad(i,k+1) = 1.-al(i,k)
-          a1(i,k)   = a1(i,k)+dtodsd*dsdzt
-          a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt
-        enddo
-      enddo
-      if(ntrac.ge.2) then
-        do kk = 2, ntrac
-          is = (kk-1) * km
-          do k = 1, km1
-            do i = 1, im
-              a2(i,k+1+is) = q1(i,k+1,kk)
-            enddo
-          enddo
-        enddo
-      endif
-!c
-!c     solve tridiagonal problem for heat and moisture
-!c
-      call tridin(im,km,ntrac,al,ad,au,a1,a2,au,a1,a2)
-!c
-!c     recover tendencies of heat and moisture
-!c
-      do  k = 1,km
-         do i = 1,im
-            ttend      = (a1(i,k)-t1(i,k))*rdt
-            qtend      = (a2(i,k)-q1(i,k,1))*rdt
-            tau(i,k)   = tau(i,k)+ttend
-            rtg(i,k,1) = rtg(i,k,1)+qtend
-            dtsfc(i)   = dtsfc(i)+cont*del(i,k)*ttend
-            dqsfc(i)   = dqsfc(i)+conq*del(i,k)*qtend
-         enddo
-      enddo
-      if(ntrac.ge.2) then
-        do kk = 2, ntrac
-          is = (kk-1) * km
-          do k = 1, km 
-            do i = 1, im
-              qtend = (a2(i,k+is)-q1(i,k,kk))*rdt
-              rtg(i,k,kk) = rtg(i,k,kk)+qtend
-            enddo
-          enddo
-        enddo
-      endif
-!c
-!c     compute tridiagonal matrix elements for momentum
-!c
-      do i=1,im
-         ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i)
-         a1(i,1) = u1(i,1)
-         a2(i,1) = v1(i,1)
-      enddo
-!c
-      do k = 1,km1
-        do i=1,im
-          dtodsd = dt/del(i,k)
-          dtodsu = dt/del(i,k+1)
-          dsig   = prsl(i,k)-prsl(i,k+1)
-          rdz    = rdzt(i,k)
-          tem1   = dsig*dku(i,k)*rdz
-!         if(pblflg(i).and.k.lt.kpbl(i))then
-!           ptem1 = dsig*dkux(i,k)*rdz
-!           dsdzu = ptem1*(-hgamu(i)/hpbl(i))
-!           dsdzv = ptem1*(-hgamv(i)/hpbl(i))
-!           a1(i,k)   = a1(i,k)+dtodsd*dsdzu
-!           a1(i,k+1) = u1(i,k+1)-dtodsu*dsdzu
-!           a2(i,k)   = a2(i,k)+dtodsd*dsdzv
-!           a2(i,k+1) = v1(i,k+1)-dtodsu*dsdzv
-!         else
-            a1(i,k+1) = u1(i,k+1)
-            a2(i,k+1) = v1(i,k+1)
-!         endif
-!         dsdz2     = dsig*dku(i,k)*rdz*rdz
-          dsdz2     = tem1*rdz
-          au(i,k)   = -dtodsd*dsdz2
-          al(i,k)   = -dtodsu*dsdz2
-          ad(i,k)   = ad(i,k)-au(i,k)
-          ad(i,k+1) = 1.-al(i,k)
-        enddo
-      enddo
-!c
-!c     solve tridiagonal problem for momentum
-!c
-      call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2)
-!c
-!c     recover tendencies of momentum
-!c
-      do k = 1,km
-         do i = 1,im
-            ptem = 1./rcs(i) 
-            utend = (a1(i,k)-u1(i,k))*rdt
-            vtend = (a2(i,k)-v1(i,k))*rdt
-            du(i,k)  = du(i,k)+utend*ptem
-            dv(i,k)  = dv(i,k)+vtend*ptem
-            dusfc(i) = dusfc(i)+conw*del(i,k)*utend
-            dvsfc(i) = dvsfc(i)+conw*del(i,k)*vtend
-         enddo
-      enddo
-!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!c  pbl height for diagnostic purpose
-!c
-      do i = 1, im
-         hpbl(i) = hpblx(i)
-         kpbl(i) = kpblx(i)
-      enddo
-!c
-!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      return
-      end subroutine moninq
-!FPP$ NOCONCUR R
-!-----------------------------------------------------------------------
-      SUBROUTINE TRIDI2(L,N,CL,CM,CU,R1,R2,AU,A1,A2)
-!sela %INCLUDE DBTRIDI2;
-!
-      USE MODULE_GFS_MACHINE, ONLY : kind_phys
-      implicit none
-      integer             k,n,l,i
-      real(kind=kind_phys) fk
-!
-      real(kind=kind_phys) CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N), &
-     &          AU(L,N-1),A1(L,N),A2(L,N)
-!-----------------------------------------------------------------------
-      DO I=1,L
-        FK      = 1./CM(I,1)
-        AU(I,1) = FK*CU(I,1)
-        A1(I,1) = FK*R1(I,1)
-        A2(I,1) = FK*R2(I,1)
-      ENDDO
-      DO K=2,N-1
-        DO I=1,L
-          FK      = 1./(CM(I,K)-CL(I,K)*AU(I,K-1))
-          AU(I,K) = FK*CU(I,K)
-          A1(I,K) = FK*(R1(I,K)-CL(I,K)*A1(I,K-1))
-          A2(I,K) = FK*(R2(I,K)-CL(I,K)*A2(I,K-1))
-        ENDDO
-      ENDDO
-      DO I=1,L
-        FK      = 1./(CM(I,N)-CL(I,N)*AU(I,N-1))
-        A1(I,N) = FK*(R1(I,N)-CL(I,N)*A1(I,N-1))
-        A2(I,N) = FK*(R2(I,N)-CL(I,N)*A2(I,N-1))
-      ENDDO
-      DO K=N-1,1,-1
-        DO I=1,L
-          A1(I,K) = A1(I,K)-AU(I,K)*A1(I,K+1)
-          A2(I,K) = A2(I,K)-AU(I,K)*A2(I,K+1)
-        ENDDO
-      ENDDO
-!-----------------------------------------------------------------------
-      RETURN
-      END SUBROUTINE TRIDI2
-!FPP$ NOCONCUR R
-!-----------------------------------------------------------------------
-      SUBROUTINE TRIDIN(L,N,nt,CL,CM,CU,R1,R2,AU,A1,A2)
-!sela %INCLUDE DBTRIDI2;
-!
-      USE MODULE_GFS_MACHINE, ONLY : kind_phys
-      implicit none
-      integer             is,k,kk,n,nt,l,i
-      real(kind=kind_phys) fk(L)
-!
-      real(kind=kind_phys) CL(L,2:N), CM(L,N), CU(L,N-1),               &
-     &                     R1(L,N),   R2(L,N*nt),                       &
-     &                     AU(L,N-1), A1(L,N), A2(L,N*nt),              &
-     &                     FKK(L,2:N-1)
-!-----------------------------------------------------------------------
-      DO I=1,L
-        FK(I)   = 1./CM(I,1)
-        AU(I,1) = FK(I)*CU(I,1)
-        A1(I,1) = FK(I)*R1(I,1)
-      ENDDO
-      do k = 1, nt
-        is = (k-1) * n
-        do i = 1, l
-          a2(i,1+is) = fk(I) * r2(i,1+is)
-        enddo
-      enddo
-      DO K=2,N-1
-        DO I=1,L
-          FKK(I,K) = 1./(CM(I,K)-CL(I,K)*AU(I,K-1))
-          AU(I,K)  = FKK(I,K)*CU(I,K)
-          A1(I,K)  = FKK(I,K)*(R1(I,K)-CL(I,K)*A1(I,K-1))
-        ENDDO
-      ENDDO
-      do kk = 1, nt
-        is = (kk-1) * n
-        DO K=2,N-1
-          DO I=1,L
-            A2(I,K+is) = FKK(I,K)*(R2(I,K+is)-CL(I,K)*A2(I,K+is-1))
-          ENDDO
-        ENDDO
-      ENDDO
-      DO I=1,L
-        FK(I)   = 1./(CM(I,N)-CL(I,N)*AU(I,N-1))
-        A1(I,N) = FK(I)*(R1(I,N)-CL(I,N)*A1(I,N-1))
-      ENDDO
-      do k = 1, nt
-        is = (k-1) * n
-        do i = 1, l
-          A2(I,N+is) = FK(I)*(R2(I,N+is)-CL(I,N)*A2(I,N+is-1))
-        enddo
-      enddo
-      DO K=N-1,1,-1
-        DO I=1,L
-          A1(I,K) = A1(I,K) - AU(I,K)*A1(I,K+1)
-        ENDDO
-      ENDDO
-      do kk = 1, nt
-        is = (kk-1) * n
-        DO K=n-1,1,-1
-          DO I=1,L
-            A2(I,K+is) = A2(I,K+is) - AU(I,K)*A2(I,K+is+1)
-          ENDDO
-        ENDDO
-      ENDDO
-!-----------------------------------------------------------------------
-      RETURN
-      END SUBROUTINE TRIDIN
-      SUBROUTINE TRIDIT(L,N,nt,CL,CM,CU,RT,AU,AT)
-!sela %INCLUDE DBTRIDI2;
-!
-      USE MODULE_GFS_MACHINE, ONLY : kind_phys
-      implicit none
-      integer             is,k,kk,n,nt,l,i
-      real(kind=kind_phys) fk(L)
-!
-      real(kind=kind_phys) CL(L,2:N), CM(L,N), CU(L,N-1),               &
-     &                     RT(L,N*nt),                                  &
-     &                     AU(L,N-1), AT(L,N*nt),                       &
-     &                     FKK(L,2:N-1)                  
-!-----------------------------------------------------------------------
-      DO I=1,L
-        FK(I)   = 1./CM(I,1)
-        AU(I,1) = FK(I)*CU(I,1)
-      ENDDO
-      do k = 1, nt
-        is = (k-1) * n
-        do i = 1, l
-          at(i,1+is) = fk(I) * rt(i,1+is)
-        enddo
-      enddo
-      DO K=2,N-1
-        DO I=1,L
-          FKK(I,K) = 1./(CM(I,K)-CL(I,K)*AU(I,K-1))
-          AU(I,K)  = FKK(I,K)*CU(I,K)
-        ENDDO
-      ENDDO
-      do kk = 1, nt
-        is = (kk-1) * n
-        DO K=2,N-1
-          DO I=1,L
-            AT(I,K+is) = FKK(I,K)*(RT(I,K+is)-CL(I,K)*AT(I,K+is-1))
-          ENDDO
-        ENDDO
-      ENDDO
-      DO I=1,L
-        FK(I)   = 1./(CM(I,N)-CL(I,N)*AU(I,N-1))
-      ENDDO
-      do k = 1, nt
-        is = (k-1) * n
-        do i = 1, l
-          AT(I,N+is) = FK(I)*(RT(I,N+is)-CL(I,N)*AT(I,N+is-1))
-        enddo
-      enddo
-      do kk = 1, nt
-        is = (kk-1) * n
-        DO K=n-1,1,-1
-          DO I=1,L
-            AT(I,K+is) = AT(I,K+is) - AU(I,K)*AT(I,K+is+1)
-          ENDDO
-        ENDDO
-      ENDDO
-!-----------------------------------------------------------------------
-      RETURN
-      END SUBROUTINE TRIDIT
-                                                                                 
-!-----------------------------------------------------------------------
-
-      END MODULE module_bl_gfs2011
diff --git a/wrfv2_fire/phys/module_bl_gfsedmf.F b/wrfv2_fire/phys/module_bl_gfsedmf.F
new file mode 100755
index 00000000..3c9cf2c1
--- /dev/null
+++ b/wrfv2_fire/phys/module_bl_gfsedmf.F
@@ -0,0 +1,2216 @@
+!LWRF:MODEL_LAYER:PHYSICS
+!
+MODULE module_bl_gfsedmf
+
+#if (HWRF==1)
+
+CONTAINS
+
+!-------------------------------------------------------------------          
+   SUBROUTINE BL_GFSEDMF(U3D,V3D,TH3D,T3D,QV3D,QC3D,QI3D,P3D,PI3D, &
+                  RUBLTEN,RVBLTEN,RTHBLTEN,                        &
+                  RQVBLTEN,RQCBLTEN,RQIBLTEN,          	           & 
+                  CP,G,ROVCP,R,ROVG,P_QI,P_FIRST_SCALAR,           &
+                  dz8w,z,PSFC,                                     &
+                  UST,PBL,PSIM,PSIH,                               &
+                  HFX,QFX,TSK,GZ1OZ0,WSPD,BR,                      &
+                  DT,KPBL2D,EP1,KARMAN,                            &
+                  DISHEAT,                                         &
+                  RTHRATEN,                                        &    !Kwon add RTHRATEN 
+                  HPBL2D, EVAP2D, HEAT2D,                          &    !Kwon add FOR SHAL. CON.
+
+                  U10,V10,ZNT,                                    &
+                  DKU3D,DKT3D,                                    & 
+                  VAR_RIC,coef_ric_l,coef_ric_s,alpha,xland,        &
+                  ids,ide, jds,jde, kds,kde,                       &
+                  ims,ime, jms,jme, kms,kme,                       &
+                  its,ite, jts,jte, kts,kte                        )
+!--------------------------------------------------------------------
+      USE MODULE_GFS_MACHINE , ONLY : kind_phys
+!      USE MODULE_GFS_FUNCPHYS, only : fpvs
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+!-- U3D         3D u-velocity interpolated to theta points (m/s)
+!-- V3D         3D v-velocity interpolated to theta points (m/s)
+!-- TH3D	3D potential temperature (K)
+!-- T3D         temperature (K)
+!-- QV3D        3D water vapor mixing ratio (Kg/Kg)
+!-- QC3D        3D cloud mixing ratio (Kg/Kg)
+!-- QI3D        3D ice mixing ratio (Kg/Kg)
+!-- P3D         3D pressure (Pa)
+!-- PI3D	3D exner function (dimensionless)
+!-- rr3D	3D dry air density (kg/m^3)
+!-- RUBLTEN     U tendency due to
+!               PBL parameterization (m/s^2)
+!-- RVBLTEN     V tendency due to
+!               PBL parameterization (m/s^2)
+!-- RTHBLTEN    Theta tendency due to
+!               PBL parameterization (K/s)
+!-- RQVBLTEN    Qv tendency due to
+!               PBL parameterization (kg/kg/s)
+!-- RQCBLTEN    Qc tendency due to
+!               PBL parameterization (kg/kg/s)
+!-- RQIBLTEN    Qi tendency due to
+!               PBL parameterization (kg/kg/s)
+!-- CP          heat capacity at constant pressure for dry air (J/kg/K)
+!-- G           acceleration due to gravity (m/s^2)
+!-- ROVCP       R/CP
+!-- R           gas constant for dry air (J/kg/K)
+!-- ROVG 	R/G
+!-- P_QI	species index for cloud ice
+!-- dz8w	dz between full levels (m)
+!-- z		height above sea level (m)
+!-- PSFC        pressure at the surface (Pa)
+!-- UST		u* in similarity theory (m/s)
+!-- PBL		PBL height (m)
+!-- PSIM        similarity stability function for momentum
+!-- PSIH        similarity stability function for heat
+!-- HFX		upward heat flux at the surface (W/m^2)
+!-- QFX		upward moisture flux at the surface (kg/m^2/s)
+!-- TSK		surface temperature (K)
+!-- GZ1OZ0      log(z/z0) where z0 is roughness length
+!-- WSPD        wind speed at lowest model level (m/s)
+!-- BR          bulk Richardson number in surface layer
+!-- DT		time step (s)
+!-- rvovrd      R_v divided by R_d (dimensionless)
+!-- EP1         constant for virtual temperature (R_v/R_d - 1) (dimensionless)
+!-- KARMAN      Von Karman constant
+!-- ids         start index for i in domain
+!-- ide         end index for i in domain
+!-- jds         start index for j in domain
+!-- jde         end index for j in domain
+!-- kds         start index for k in domain
+!-- kde         end index for k in domain
+!-- ims         start index for i in memory
+!-- ime         end index for i in memory
+!-- jms         start index for j in memory
+!-- jme         end index for j in memory
+!-- kms         start index for k in memory
+!-- kme         end index for k in memory
+!-- its         start index for i in tile
+!-- ite         end index for i in tile
+!-- jts         start index for j in tile
+!-- jte         end index for j in tile
+!-- kts         start index for k in tile
+!-- kte         end index for k in tile
+!-------------------------------------------------------------------
+
+      INTEGER, INTENT(IN) ::            ids,ide, jds,jde, kds,kde,      &
+                                        ims,ime, jms,jme, kms,kme,      &
+                                        its,ite, jts,jte, kts,kte,      &
+                                        P_QI,P_FIRST_SCALAR
+
+#if (NMM_CORE==1)
+      LOGICAL , INTENT(IN)::            DISHEAT                                    !gopal's doing
+#endif
+      REAL,  DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::  RTHRATEN         !Kwon
+      REAL,  DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::              &
+                                        HPBL2D,                         &    !ADDED BY KWON FOR SHALLOW CONV.
+                                        EVAP2D,                         &    !ADDED BY KWON FOR SHALLOW CONV.
+                                        HEAT2D                               !ADDED BY KWON FOR SHALLOW CONV.
+
+
+!wang
+       REAL,  DIMENSION(ims:ime, jms:jme), INTENT(IN) ::              &
+                                         U10,                         &
+                                         V10,                   &
+                                         ZNT, xland
+
+       REAL,  DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(OUT) :: DKU3D,DKT3D
+!wang
+
+      REAL,    INTENT(IN) ::                                            &
+                                        CP,                             &
+                                        DT,                             &
+                                        EP1,                            &
+                                        G,                              &
+                                        KARMAN,                         &
+                                        R,                              & 
+                                        ROVCP,                          &
+                                        ROVG 
+
+      REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::      & 
+                                        DZ8W,                           &
+                                        P3D,                            &
+                                        PI3D,                           &
+                                        QC3D,                           &
+                                        QI3D,                           &
+                                        QV3D,                           &
+                                        T3D,                            &
+                                        TH3D,                           &
+                                        U3D,                            &
+                                        V3D,                            &
+                                        Z   
+
+
+      REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::   &
+                                        RTHBLTEN,                       &
+                                        RQCBLTEN,                       &
+                                        RQIBLTEN,                       &
+                                        RQVBLTEN,                       &
+                                        RUBLTEN,                        &
+                                        RVBLTEN                        
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
+                                        BR,                             &
+                                        GZ1OZ0,                         &
+                                        HFX,                            &
+                                        PSFC,                           &
+                                        PSIM,                           &
+                                        PSIH,                           &
+                                        QFX,                            &
+                                        TSK
+ 
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            & 
+                                        PBL,                            &
+                                        UST,                            &
+                                        WSPD
+
+      INTEGER, DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::              &
+                                        KPBL2D                         
+
+
+!--------------------------- LOCAL VARS ------------------------------
+
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte) ::         &
+                                        DEL,                            &
+                                        DU,                             &
+                                        DV,                             &
+                                        PHIL,                           &
+                                        PRSL,                           &
+                                        PRSLK,                          &
+                                        T1,                             &
+                                        TAU,                            &
+                                        dishx,                          &
+                                        THRATEN,                        & !Kwon
+                                        U1,                             &
+                                        V1
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte-1) ::DKU,DKT
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte+1) ::       &
+                                        PHII,                           & 
+                                        PRSI
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte, 3) ::      &
+                                        Q1,                             &
+                                        RTG
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite) ::                  &
+                                        DQSFC,                          &
+                                        DTSFC,                          &
+                                        DUSFC,                          &
+                                        DVSFC,                          &
+                                        EVAP,                           &
+                                        FH,                             &
+                                        FM,                             &
+                                        HEAT,                           &
+                                        HGAMQ,                          &
+                                        HGAMT,                          &
+                                        HPBL,                           &
+                                        PSK,                            &
+                                        QSS,                            &
+                                        RBSOIL,                         &
+                                        RCL,                            &
+                                        SPD1,                           &
+                                        STRESS,                         &
+                                        TSEA,      &
+                                        zorl,u10m,v10m,zol, xland1
+
+      REAL     (kind=kind_phys) ::                                      &
+                                        CPM,                            &
+                                        cpmikj,                         &
+                                        DELTIM,                         &
+                                        FMTMP,                          &
+                                        RRHOX
+
+      INTEGER, DIMENSION( its:ite ) ::                                  &
+                                        KPBL , kinver
+
+      INTEGER ::                                                        &
+                                        I,                              &
+                                        IM,                             &
+                                        J,                              &
+                                        K,                              &
+                                        KM,                             &
+                                        KTEM,                           &
+                                        KTEP,                           &
+                                        KX,                             &
+                                        L,                              & 
+                                        NTRAC, ntcw
+
+      real(kind=kind_phys)xkzm_m, xkzm_h, xkzm_s   !! wang, background diff 
+      real :: VAR_RIC,coef_ric_l,coef_ric_s,alpha
+      logical lprnt
+      integer ipr
+
+ 
+   IM=ITE-ITS+1
+   KX=KTE-KTS+1
+   KTEM=KTE-1
+   KTEP=KTE+1
+   NTRAC=2
+   DELTIM=DT
+
+   xkzm_m=1.0
+   xkzm_h=1.0
+   xkzm_s=1.0   
+   lprnt=.false.
+   ipr=1
+   ntcw=2
+
+!    write(0,*)'in gfsedmf PBL'
+
+   IF (P_QI.ge.P_FIRST_SCALAR) NTRAC=3
+
+ !! note 2015,08-19, if we consider rain water, then ntrac=4, and set q1(i,k,4)=QR
+ !! here, we do not consider rain water
+
+   DO J=jts,jte
+
+      DO i=its,ite
+        RRHOX=(R*T3D(I,KTS,J)*(1.+EP1*QV3D(I,KTS,J)))/PSFC(I,J)
+        CPM=CP*(1.+0.8*QV3D(i,kts,j))
+        FMTMP=GZ1OZ0(i,j)-PSIM(i,j)
+        PSK(i)=(PSFC(i,j)*.00001)**ROVCP
+        FM(i)=FMTMP
+        FH(i)=GZ1OZ0(i,j)-PSIH(i,j)
+        TSEA(i)=TSK(i,j)
+        QSS(i)=QV3D(i,kts,j)               ! not used in moninq so set to qv3d for now
+        HEAT(i)=HFX(i,j)/CPM*RRHOX
+        EVAP(i)=QFX(i,j)*RRHOX
+! Kwon FOR NEW SHALLOW CONVECTION 
+        HEAT2D(i,j)=HFX(i,j)/CPM*RRHOX
+        EVAP2D(i,j)=QFX(i,j)*RRHOX
+!
+        STRESS(i)=KARMAN*KARMAN*WSPD(i,j)*WSPD(i,j)/(FMTMP*FMTMP)
+        SPD1(i)=WSPD(i,j)
+        PRSI(i,kts)=PSFC(i,j)*.001
+        PHII(I,kts)=0.
+        RCL(i)=1.
+        RBSOIL(I)=BR(i,j)
+        zorl(i)=znt(i,j) * 100.0  ! m to cm
+        u10m(i)=u10(i,j)
+        v10m(i)=v10(i,j)
+        xland1(i)=xland(i,j)
+        kinver(i)=kx
+      ENDDO
+
+      DO k=kts,kte
+        DO i=its,ite 
+          DV(I,K) = 0.
+          DU(I,K) = 0.
+          TAU(I,K) = 0.
+          U1(I,K) = U3D(i,k,j)
+          V1(I,K) = V3D(i,k,j)
+          T1(I,K) = T3D(i,k,j)
+#ifdef NMM_CORE
+          THRATEN(I,K) = RTHRATEN(I,K,J)  !! * 0.0  !!! test , removing additional diffusion
+#else
+          THRATEN(I,K) = 0.0
+#endif
+          Q1(I,K,1) = QV3D(i,k,j)/(1.+QV3D(i,k,j))
+          Q1(I,K,2) = QC3D(i,k,j)/(1.+QC3D(i,k,j))
+          PRSL(I,K)=P3D(i,k,j)*.001
+        ENDDO
+      ENDDO
+
+      DO k=kts,kte
+        DO i=its,ite 
+          PRSLK(I,K)=(PRSL(i,k)*.01)**ROVCP
+        ENDDO
+      ENDDO
+
+
+      DO k=kts+1,kte
+        km=k-1
+        DO i=its,ite 
+          DEL(i,km)=PRSL(i,km)/ROVG*dz8w(i,km,j)/T3D(i,km,j)
+          PRSI(i,k)=PRSI(i,km)-DEL(i,km)
+          PHII(I,K)=(Z(i,k,j)-Z(i,kts,j))*G
+          PHIL(I,KM)=0.5*(Z(i,k,j)+Z(i,km,j)-2.*Z(i,kts,j))*G
+        ENDDO
+      ENDDO
+
+      DO i=its,ite 
+        DEL(i,kte)=DEL(i,ktem)
+        PRSI(i,ktep)=PRSI(i,kte)-DEL(i,ktem)
+        PHII(I,KTEP)=PHII(I,KTE)+dz8w(i,kte,j)*G
+        PHIL(I,KTE)=PHII(I,KTE)-PHIL(I,KTEM)+PHII(I,KTE)
+      ENDDO
+
+      IF (P_QI.ge.P_FIRST_SCALAR) THEN
+        DO k=kts,kte
+          DO i=its,ite 
+            Q1(I,K,3) = QI3D(i,k,j)/(1.+QI3D(i,k,j))
+          ENDDO
+        ENDDO
+      ENDIF
+
+      DO l=1,ntrac
+        DO k=kts,kte
+          DO i=its,ite
+            RTG(I,K,L) = 0.
+          ENDDO
+        ENDDO
+      ENDDO
+!
+!  2010 new gfs pbl
+!
+!      call moninq(im,im,km,ntrac,dv,du,tau,rtg,                       &
+!     &     u1,v1,t1,q1,thraten,                                       &  !kwon
+!     &     psk,rbsoil,fm,fh,tsea,qss,heat,evap,stress,spd1,kpbl,      &
+!     &     prsi,del,prsl,prslk,phii,phil,rcl,deltim,                  &
+!     &     dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq)
+
+
+      call moninedmf(im,im,kx,ntrac,ntcw,dv,du,tau,rtg,        &
+!     &   u1,v1,t1,q1,swh,hlw,xmu,                             &
+     &   u1,v1,t1,q1,thraten,                                  &
+     &   psk,rbsoil,zorl,u10m,v10m,fm,fh,                      &
+     &   tsea,qss,heat,evap,stress,spd1,kpbl,                  &
+     &   prsi,del,prsl,prslk,phii,phil,deltim,disheat,         &  
+     &   dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt,dku,     &
+     &   kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr,zol,            &
+     &   VAR_RIC,coef_ric_l,coef_ric_s,alpha,xland1)
+
+
+!============================================================================
+!    ADD  IN  DISSIPATIVE HEATING .... v*dv. This is Bob's doing
+!============================================================================
+
+!#if (NMM_CORE==1)
+!!! already considered in edmfpbl
+!!      IF(DISHEAT)THEN
+!!       DO k=kts,kte
+!!         DO i=its,ite
+!!          dishx(i,k)=u1(i,k)*du(i,k) + v1(i,k)*dv(i,k)
+!!          cpmikj=CP*(1.+0.8*QV3D(i,k,j))
+!!          dishx(i,k)=-dishx(i,k)/cpmikj
+!         IF(k==1)WRITE(0,*)'ADDITIONAL DISSIPATIVE HEATING',tau(i,k),dishx(i,k)
+!!          tau(i,k)=tau(i,k)+dishx(i,k)
+!!         ENDDO 
+!!       ENDDO 
+!!      ENDIF
+!#endif
+
+!=============================================================================
+
+
+      DO k=kts,kte
+        DO i=its,ite
+          RVBLTEN(I,K,J)=DV(I,K)
+          RUBLTEN(I,K,J)=DU(I,K)
+          RTHBLTEN(I,K,J)=TAU(I,K)/PI3D(I,K,J)
+          RQVBLTEN(I,K,J)=RTG(I,K,1)/(1.-Q1(I,K,1))**2
+          RQCBLTEN(I,K,J)=RTG(I,K,2)/(1.-Q1(I,K,2))**2
+        ENDDO
+      ENDDO
+
+      IF (P_QI.ge.P_FIRST_SCALAR) THEN
+        DO k=kts,kte
+          DO i=its,ite
+            RQIBLTEN(I,K,J)=RTG(I,K,3)/(1.-Q1(I,K,3))**2
+          ENDDO
+        ENDDO
+      ENDIF
+
+      DO i=its,ite
+        UST(i,j)=SQRT(STRESS(i))
+        WSPD(i,j)=SQRT(U3D(I,KTS,J)*U3D(I,KTS,J)+                       &
+                       V3D(I,KTS,J)*V3D(I,KTS,J))+1.E-9
+        PBL(i,j)=HPBL(i)
+!Kwon For new shallow convection
+        HPBL2D(i,j)=HPBL(i)
+!
+        KPBL2D(i,j)=kpbl(i)
+      ENDDO
+
+#if (HWRF==1)
+     DO i=its,ite
+     DO k=kts,kte
+      DKU3D(I,J,K) = 0.
+      DKT3D(I,J,K) = 0.
+     ENDDO
+     ENDDO
+
+     DO i=its,ite
+     DO k=kts,kte-1
+      DKU3D(I,J,K) = DKU(I,K)
+      DKT3D(I,J,K) = DKT(I,K)
+     ENDDO
+
+     ENDDO
+#endif
+
+
+    ENDDO
+
+
+   END SUBROUTINE BL_GFSEDMF
+
+!===================================================================
+   SUBROUTINE gfsedmfinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,       &
+                      RQCBLTEN,RQIBLTEN,P_QI,P_FIRST_SCALAR,       &
+                      restart,                                     &
+                      allowed_to_read,                             &
+                      ids, ide, jds, jde, kds, kde,                &
+                      ims, ime, jms, jme, kms, kme,                &
+                      its, ite, jts, jte, kts, kte                 )
+!-------------------------------------------------------------------          
+   IMPLICIT NONE
+!-------------------------------------------------------------------          
+   LOGICAL , INTENT(IN)          ::  allowed_to_read,restart
+   INTEGER , INTENT(IN)          ::  ids, ide, jds, jde, kds, kde, &
+                                     ims, ime, jms, jme, kms, kme, &
+                                     its, ite, jts, jte, kts, kte
+   INTEGER , INTENT(IN)          ::  P_QI,P_FIRST_SCALAR
+
+   REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::         &
+                                                         RUBLTEN, &
+                                                         RVBLTEN, &
+                                                         RTHBLTEN, &
+                                                         RQVBLTEN, &
+                                                         RQCBLTEN, & 
+                                                         RQIBLTEN
+   INTEGER :: i, j, k, itf, jtf, ktf
+
+   jtf=min0(jte,jde-1)
+   ktf=min0(kte,kde-1)
+   itf=min0(ite,ide-1)
+
+   IF(.not.restart)THEN
+     DO j=jts,jtf
+     DO k=kts,ktf
+     DO i=its,itf
+        RUBLTEN(i,k,j)=0.
+        RVBLTEN(i,k,j)=0.
+        RTHBLTEN(i,k,j)=0.
+        RQVBLTEN(i,k,j)=0.
+        RQCBLTEN(i,k,j)=0.
+     ENDDO
+     ENDDO
+     ENDDO
+   ENDIF
+
+   IF (P_QI .ge. P_FIRST_SCALAR .and. .not.restart) THEN
+      DO j=jts,jtf
+      DO k=kts,ktf
+      DO i=its,itf
+         RQIBLTEN(i,k,j)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+   ENDIF
+
+   IF (P_QI .ge. P_FIRST_SCALAR) THEN
+      DO j=jts,jtf
+      DO k=kts,ktf
+      DO i=its,itf
+         RQIBLTEN(i,k,j)=0.
+      ENDDO
+      ENDDO
+      ENDDO
+   ENDIF
+
+
+   END SUBROUTINE gfsedmfinit
+
+!----------------------------------------------------------------------
+
+!!!!!  ==========================================================  !!!!!
+! subroutine 'moninedmf' computes subgrid vertical mixing by turbulence
+! 
+! for the convective boundary layer, the scheme adopts eddy-diffusion
+!  mass-flux (edmf) parameterization (siebesma et al., 2007) to take into 
+!  account nonlocal transport by large eddies. to reduce the tropical wind rmse, 
+!  a hybrid scheme is used, in which the edmf scheme is used only for strongly 
+!  unstable pbl while the current operational vertical diffusion scheme is called 
+!  for the weakly unstable pbl.  
+!
+      subroutine moninedmf(ix,im,km,ntrac,ntcw,dv,du,tau,rtg,           &
+!     &   u1,v1,t1,q1,swh,hlw,xmu,                                      &
+     &   u1,v1,t1,q1,thraten,                                           &
+     &   psk,rbsoil,zorl,u10m,v10m,fm,fh,                               &
+     &   tsea,qss,heat,evap,stress,spd1,kpbl,                           &
+     &   prsi,del,prsl,prslk,phii,phil,delt,dspheat,                    &
+     &   dusfc,dvsfc,dtsfc,dqsfc,hpbl,hgamt,hgamq,dkt,dku,              &
+     &   kinver,xkzm_m,xkzm_h,xkzm_s,lprnt,ipr,zol,                     &
+     &   VAR_RIC,coef_ric_l,coef_ric_s,alpha,xland1)
+!
+      USE MODULE_GFS_MACHINE, only : kind_phys
+!      USE MODULE_GFS_FUNCPHYS, only : fpvs
+      USE MODULE_GFS_PHYSCONS, grav => con_g, rd => con_rd, cp => con_cp &
+     &,             hvap => con_hvap, fv => con_fvirt
+      implicit none
+!
+!     arguments
+!
+      logical lprnt
+      integer ipr
+      integer ix, im, km, ntrac, ntcw, kpbl(im), kinver(im)
+!
+      real(kind=kind_phys) delt, xkzm_m, xkzm_h, xkzm_s
+      real(kind=kind_phys) dv(im,km),     du(im,km),                 &
+     &                     tau(im,km),    rtg(im,km,ntrac),          &
+     &                     u1(ix,km),     v1(ix,km),                 &
+     &                     t1(ix,km),     q1(ix,km,ntrac),           &
+     &                     swh(ix,km),    hlw(ix,km),                &
+     &                     xmu(im),       psk(im),                   &
+     &                     rbsoil(im),    zorl(im),                  &
+     &                     u10m(im),      v10m(im),                  &
+     &                     fm(im),        fh(im),                    & 
+     &                     tsea(im),      qss(im),                   &
+     &                                    spd1(im),                  &
+     &                     prsi(ix,km+1), del(ix,km),                &
+     &                     prsl(ix,km),   prslk(ix,km),              &
+     &                     phii(ix,km+1), phil(ix,km),               &
+     &                     dusfc(im),     dvsfc(im),                 &
+     &                     dtsfc(im),     dqsfc(im),                 &
+     &                     hpbl(im),      hpblx(im),                 &
+     &                     hgamt(im),     hgamq(im)
+!
+      logical dspheat
+!          flag for tke dissipative heating
+!
+!    locals
+!
+      integer i,iprt,is,iun,k,kk,km1,kmpbl,latd,lond
+      integer lcld(im),icld(im),kcld(im),krad(im)
+      integer kx1(im), kpblx(im)
+!
+!     real(kind=kind_phys) betaq(im), betat(im),   betaw(im),
+      real(kind=kind_phys) evap(im),  heat(im),    phih(im),           &
+     &                     phim(im),  rbdn(im),    rbup(im),           &
+     &                     stress(im),beta(im),    sflux(im),          &
+     &                     z0(im),    crb(im),     wstar(im),          &
+     &                     zol(im),   ustmin(im),  ustar(im),          &
+     &                     thermal(im),wscale(im), wscaleu(im)
+!
+      real(kind=kind_phys) theta(im,km),thvx(im,km),  thlvx(im,km),    &
+     &                     thraten(im,km),                             & ! wang
+     &                     qlx(im,km),  thetae(im,km),                 &
+     &                     qtx(im,km),  bf(im,km-1),  diss(im,km),     &
+     &                     radx(im,km-1),                              &
+     &                     govrth(im),  hrad(im),                      &
+!    &                     hradm(im),   radmin(im),   vrad(im),        &
+     &                     radmin(im),  vrad(im),                      &
+     &                     zd(im),      zdd(im),      thlvx1(im)       
+!
+      real(kind=kind_phys) rdzt(im,km-1),dktx(im,km-1),                &
+     &                     zi(im,km+1),  zl(im,km),    xkzo(im,km-1),  &
+     &                     dku(im,km-1), dkt(im,km-1), xkzmo(im,km-1), &
+     &                     cku(im,km-1), ckt(im,km-1),                 &
+     &                     ti(im,km-1),  shr2(im,km-1),                &
+     &                     al(im,km-1),  ad(im,km),                    &  
+     &                     au(im,km-1),  a1(im,km),                    &
+     &                     a2(im,km*ntrac)
+
+
+!
+      real(kind=kind_phys) tcko(im,km),  qcko(im,km,ntrac),            &
+     &                     ucko(im,km),  vcko(im,km),  xmf(im,km)
+!
+      real(kind=kind_phys) prinv(im), rent(im)
+!
+      logical  pblflg(im), sfcflg(im), scuflg(im), flg(im)
+      logical  ublflg(im), pcnvflg(im)
+!
+!  pcnvflg: true for convective(strongly unstable) pbl
+!  ublflg: true for unstable but not convective(strongly unstable) pbl
+!
+      real(kind=kind_phys) aphi16,  aphi5,  bvf2,   wfac,            &
+     &                     cfac,    conq,   cont,   conw,            &
+     &                     dk,      dkmax,  dkmin,                   &
+     &                     dq1,     dsdz2,  dsdzq,  dsdzt,           &
+     &                     dsdzu,   dsdzv,                           &
+     &                     dsig,    dt2,    dthe1,  dtodsd,          &
+     &                     dtodsu,  dw2,    dw2min, g,               &
+     &                     gamcrq,  gamcrt, gocp,                    &
+     &                     gravi,   f0,                              &
+     &                     prnum,   prmax,  prmin,  pfac,  crbcon,   &
+     &                     qmin,    tdzmin, qtend,  crbmin,crbmax,   &
+     &                     rbint,   rdt,    rdz,    qlmin,           &
+     &                     ri,      rimin,  rl2,    rlam,  rlamun,   &
+     &                     rone,    rzero,  sfcfrac,                 &
+     &                     spdk2,   sri,    zol1,   zolcr, zolcru,   &
+     &                     robn,    ttend,                           &
+     &                     utend,   vk,     vk2,                     &
+     &                     ust3,    wst3,                            &    
+     &                     vtend,   zfac,   vpert,  cteit,           &
+     &                     rentf1,  rentf2, radfac,                  & 
+     &                     zfmin,   zk,     tem,    tem1,  tem2,     &
+     &                     xkzm,    xkzmu,  xkzminv,                 &
+     &                     ptem,    ptem1,  ptem2, tx1(im), tx2(im)  
+!
+      real(kind=kind_phys) zstblmax,h1,     h2,     qlcr,  actei,   &
+     &                     cldtime
+
+!! for aplha
+     real(kind=kind_phys) WSPM(IM,KM-1), xland1(IM)
+     integer kLOC ! RGF
+     real :: xDKU, ALPHA    ! RGF
+     real :: VAR_RIC,coef_ric_l,coef_ric_s
+     
+     logical:: outp
+     integer :: stype, useshape
+     real :: smax,ashape,sz2h, sksfc,skmax,ashape1,skminusk0, hmax
+
+!!
+
+!cc
+      parameter(gravi=1.0/grav)
+      parameter(g=grav)
+      parameter(gocp=g/cp)
+      parameter(cont=cp/g,conq=hvap/g,conw=1.0/g)               ! for del in pa
+!     parameter(cont=1000.*cp/g,conq=1000.*hvap/g,conw=1000./g) ! for del in kpa
+      parameter(rlam=30.0,vk=0.4,vk2=vk*vk)
+      parameter(prmin=0.25,prmax=4.,zolcr=0.2,zolcru=-0.5)
+      parameter(dw2min=0.0001,dkmin=0.0,dkmax=1000.,rimin=-100.)
+      parameter(crbcon=0.25,crbmin=0.15,crbmax=0.35)
+      parameter(wfac=7.0,cfac=6.5,pfac=2.0,sfcfrac=0.1)
+!     parameter(qmin=1.e-8,xkzm=1.0,zfmin=1.e-8,aphi5=5.,aphi16=16.)
+      parameter(qmin=1.e-8,         zfmin=1.e-8,aphi5=5.,aphi16=16.)
+      parameter(tdzmin=1.e-3,qlmin=1.e-12,f0=1.e-4)
+      parameter(h1=0.33333333,h2=0.66666667)
+      parameter(cldtime=500.,xkzminv=0.3)
+!     parameter(cldtime=500.,xkzmu=3.0,xkzminv=0.3)
+!     parameter(gamcrt=3.,gamcrq=2.e-3,rlamun=150.0)
+      parameter(gamcrt=3.,gamcrq=0.,rlamun=150.0)
+      parameter(rentf1=0.2,rentf2=1.0,radfac=0.85)
+      parameter(iun=84)
+!
+!     parameter (zstblmax = 2500., qlcr=1.0e-5)
+!     parameter (zstblmax = 2500., qlcr=3.0e-5)
+!     parameter (zstblmax = 2500., qlcr=3.5e-5)
+!     parameter (zstblmax = 2500., qlcr=1.0e-4)
+      parameter (zstblmax = 2500., qlcr=3.5e-5)
+!     parameter (actei = 0.23)
+      parameter (actei = 0.7)
+
+
+! Weiguo Wang added, height-dependent ALPHA
+!       smax=0.148
+!       stype=1
+      useshape=2 !0-- no change, origincal ALPHA adjustment,1-- shape1, 2-- shape2(adjust above sfc)
+  !     useshape=1 
+!c
+!c-----------------------------------------------------------------------
+!c
+!c-----------------------------------------------------------------------
+!c
+ 601  format(1x,' moninp lat lon step hour ',3i6,f6.1)
+ 602      format(1x,'    k','        z','        t','       th',   &
+     &     '      tvh','        q','        u','        v',        &
+     &     '       sp')
+ 603      format(1x,i5,8f9.1)
+ 604      format(1x,'  sfc',9x,f9.1,18x,f9.1)
+ 605      format(1x,'    k      zl    spd2   thekv   the1v'        &
+     &         ,' thermal    rbup')
+ 606      format(1x,i5,6f8.2)
+ 607      format(1x,' kpbl    hpbl      fm      fh   hgamt',       &
+     &         '   hgamq      ws   ustar      cd      ch')
+ 608      format(1x,i5,9f8.2)
+ 609      format(1x,' k pr dkt dku ',i5,3f8.2)
+ 610      format(1x,' k pr dkt dku ',i5,3f8.2,' l2 ri t2',         &
+     &         ' sr2  ',2f8.2,2e10.2)
+! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+!     compute preliminary variables
+!
+      if (ix .lt. im) stop
+!
+!     iprt = 0
+!     if(iprt.eq.1) then
+!cc   latd = 0
+!     lond = 0
+!     else
+!cc   latd = 0
+!     lond = 0
+!     endif
+!
+      dt2   = delt
+      rdt   = 1. / dt2
+      km1   = km - 1
+      kmpbl = km / 2
+!
+      do k=1,km
+        do i=1,im
+          zi(i,k) = phii(i,k) * gravi
+          zl(i,k) = phil(i,k) * gravi
+        enddo
+      enddo
+      do i=1,im
+         zi(i,km+1) = phii(i,km+1) * gravi
+      enddo
+!
+      do k = 1,km1
+        do i=1,im
+          rdzt(i,k) = 1.0 / (zl(i,k+1) - zl(i,k))
+        enddo
+      enddo
+!
+      do i=1,im
+        kx1(i) = 1
+        tx1(i) = 1.0 / prsi(i,1)
+        tx2(i) = tx1(i)
+      enddo
+      do k = 1,km1
+        do i=1,im
+          xkzo(i,k)  = 0.0
+          xkzmo(i,k) = 0.0
+          if (k < kinver(i)) then
+!                                  vertical background diffusivity
+            ptem      = prsi(i,k+1) * tx1(i)
+            tem1      = 1.0 - ptem
+            tem1      = tem1 * tem1 * 10.0
+            xkzo(i,k) = xkzm_h * min(1.0, exp(-tem1))
+
+!                                  vertical background diffusivity for momentum
+            if (ptem >= xkzm_s) then
+              xkzmo(i,k) = xkzm_m
+              kx1(i)     = k + 1
+            else
+              if (k == kx1(i) .and. k > 1) tx2(i) = 1.0 / prsi(i,k)
+              tem1 = 1.0 - prsi(i,k+1) * tx2(i)
+              tem1 = tem1 * tem1 * 5.0
+              xkzmo(i,k) = xkzm_m * min(1.0, exp(-tem1))
+            endif
+          endif
+        enddo
+      enddo
+!     if (lprnt) then
+!       print *,' xkzo=',(xkzo(ipr,k),k=1,km1)
+!       print *,' xkzmo=',(xkzmo(ipr,k),k=1,km1)
+!     endif
+!
+!  diffusivity in the inversion layer is set to be xkzminv (m^2/s)
+!
+      do k = 1,kmpbl
+        do i=1,im
+!         if(zi(i,k+1) > 200..and.zi(i,k+1) < zstblmax) then
+          if(zi(i,k+1) > 250.) then
+            tem1 = (t1(i,k+1)-t1(i,k)) * rdzt(i,k)
+            if(tem1 > 1.e-5) then
+               xkzo(i,k)  = min(xkzo(i,k),xkzminv)
+            endif
+          endif
+        enddo
+      enddo
+!
+      do i = 1,im
+         z0(i)    = 0.01 * zorl(i)
+         dusfc(i) = 0.
+         dvsfc(i) = 0.
+         dtsfc(i) = 0.
+         dqsfc(i) = 0.
+         wscale(i)= 0.
+         wscaleu(i)= 0.
+         kpbl(i)  = 1
+         hpbl(i)  = zi(i,1)
+         hpblx(i) = zi(i,1)
+         pblflg(i)= .true.
+         sfcflg(i)= .true.
+         if(rbsoil(i) > 0.) sfcflg(i) = .false.
+         ublflg(i)= .false.
+         pcnvflg(i)= .false.
+         scuflg(i)= .true.
+         if(scuflg(i)) then
+           radmin(i)= 0.
+           rent(i)  = rentf1
+           hrad(i)  = zi(i,1)
+!          hradm(i) = zi(i,1)
+           krad(i)  = 1
+           icld(i)  = 0
+           lcld(i)  = km1
+           kcld(i)  = km1
+           zd(i)    = 0.
+        endif
+      enddo
+!
+      do k = 1,km
+        do i = 1,im
+          theta(i,k) = t1(i,k) * psk(i) / prslk(i,k)
+          qlx(i,k)   = max(q1(i,k,ntcw),qlmin)
+          qtx(i,k)   = max(q1(i,k,1),qmin)+qlx(i,k)
+          ptem       = qlx(i,k)
+          ptem1      = hvap*max(q1(i,k,1),qmin)/(cp*t1(i,k))
+          thetae(i,k)= theta(i,k)*(1.+ptem1)
+          thvx(i,k)  = theta(i,k)*(1.+fv*max(q1(i,k,1),qmin)-ptem)
+          ptem2      = theta(i,k)-(hvap/cp)*ptem
+          thlvx(i,k) = ptem2*(1.+fv*qtx(i,k))
+        enddo
+      enddo
+      do k = 1,km1
+        do i = 1,im
+          dku(i,k)  = 0.
+          dkt(i,k)  = 0.
+          dktx(i,k) = 0.
+          cku(i,k)  = 0.
+          ckt(i,k)  = 0.
+          tem       = zi(i,k+1)-zi(i,k)
+!          radx(i,k) = tem*(swh(i,k)*xmu(i)+hlw(i,k))
+          radx(i,k) = tem*thraten(i,k)
+        enddo
+      enddo
+!
+      do i=1,im
+         flg(i)  = scuflg(i)
+      enddo
+      do k = 1, km1
+        do i=1,im
+          if(flg(i).and.zl(i,k) >= zstblmax) then
+             lcld(i)=k
+             flg(i)=.false.
+          endif
+      enddo
+      enddo
+!
+!  compute virtual potential temp gradient (bf) and winshear square
+!
+      do k = 1, km1
+      do i = 1, im
+         rdz  = rdzt(i,k)
+         bf(i,k) = (thvx(i,k+1)-thvx(i,k))*rdz
+         ti(i,k) = 2./(t1(i,k)+t1(i,k+1))
+         dw2  = (u1(i,k)-u1(i,k+1))**2                        &
+     &        + (v1(i,k)-v1(i,k+1))**2
+         shr2(i,k) = max(dw2,dw2min)*rdz*rdz
+      enddo
+      enddo
+!
+      do i = 1,im
+        govrth(i) = g/theta(i,1)
+      enddo
+!
+      do i=1,im
+         beta(i)  = dt2 / (zi(i,2)-zi(i,1))
+      enddo
+!
+      do i=1,im
+         ustar(i) = sqrt(stress(i))
+      enddo
+!
+      do i = 1,im
+         sflux(i)  = heat(i) + evap(i)*fv*theta(i,1)
+         if(.not.sfcflg(i) .or. sflux(i) <= 0.) pblflg(i)=.false.
+      enddo
+!
+!  compute the pbl height
+!
+      do i=1,im
+         flg(i) = .false.
+         rbup(i) = rbsoil(i)
+!
+!!         if(pblflg(i)) then
+!!           thermal(i) = thvx(i,1)
+!!           crb(i) = crbcon
+!!         else
+!!           thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin))
+!!           tem = sqrt(u10m(i)**2+v10m(i)**2)
+!!           tem = max(tem, 1.)
+!!           robn = tem / (f0 * z0(i))
+!!           tem1 = 1.e-7 * robn
+!!           crb(i) = 0.16 * (tem1 ** (-0.18))
+!!           crb(i) = max(min(crb(i), crbmax), crbmin)
+!!         endif
+!
+! use variable Ri for all conditions
+         if(pblflg(i)) then
+           thermal(i) = thvx(i,1)
+         else
+           thermal(i) = tsea(i)*(1.+fv*max(q1(i,1,1),qmin))
+         endif
+           tem = sqrt(u10m(i)**2+v10m(i)**2)
+           tem = max(tem, 1.)
+           robn = tem / (f0 * z0(i))
+           tem1 = 1.e-7 * robn
+!           crb(i) = 0.16 * (tem1 ** (-0.18))
+          crb(i) = crbcon
+        IF(var_ric.eq.1.) THEN
+         IF(xland1(i).eq.1)  crb(I) = coef_ric_l*(tem1)**(-0.18)
+         IF(xland1(i).eq.2)  crb(I) = coef_ric_s*(tem1)**(-0.18)
+        ENDIF
+           crb(i) = max(min(crb(i), crbmax), crbmin)
+      enddo
+
+         outp=.false.
+         if(outp) then
+          write(*,*)'var_ric,coef_ric_l,coef_ric_s,alpha'
+          write(*,*)var_ric,coef_ric_l,coef_ric_s,alpha
+          outp=.false.
+         endif
+      do k = 1, kmpbl
+      do i = 1, im
+        if(.not.flg(i)) then
+          rbdn(i) = rbup(i)
+          spdk2   = max((u1(i,k)**2+v1(i,k)**2),1.)
+          rbup(i) = (thvx(i,k)-thermal(i))*                        &
+     &              (g*zl(i,k)/thvx(i,1))/spdk2
+          kpbl(i) = k
+          flg(i)  = rbup(i) > crb(i)
+        endif
+      enddo
+      enddo
+      do i = 1,im
+        if(kpbl(i) > 1) then
+          k = kpbl(i)
+          if(rbdn(i) >= crb(i)) then
+            rbint = 0.
+          elseif(rbup(i) <= crb(i)) then
+            rbint = 1.
+          else
+            rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i))
+          endif
+          hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1))
+          if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1
+        else
+          hpbl(i) = zl(i,1)
+          kpbl(i) = 1
+        endif
+        kpblx(i) = kpbl(i)
+        hpblx(i) = hpbl(i)
+      enddo
+!
+!  compute similarity parameters 
+!
+      do i=1,im
+         zol(i) = max(rbsoil(i)*fm(i)*fm(i)/fh(i),rimin)
+         if(sfcflg(i)) then
+           zol(i) = min(zol(i),-zfmin)
+         else
+           zol(i) = max(zol(i),zfmin)
+         endif
+         zol1 = zol(i)*sfcfrac*hpbl(i)/zl(i,1)
+         if(sfcflg(i)) then
+!          phim(i) = (1.-aphi16*zol1)**(-1./4.)
+!          phih(i) = (1.-aphi16*zol1)**(-1./2.)
+           tem     = 1.0 / (1. - aphi16*zol1)
+           phih(i) = sqrt(tem)
+           phim(i) = sqrt(phih(i))
+         else
+           phim(i) = 1. + aphi5*zol1
+           phih(i) = phim(i)
+         endif
+         wscale(i) = ustar(i)/phim(i)
+         ustmin(i) = ustar(i)/aphi5
+         wscale(i) = max(wscale(i),ustmin(i))
+      enddo
+      do i=1,im
+        if(pblflg(i)) then
+          if(zol(i) < zolcru .and. kpbl(i) > 1) then
+            pcnvflg(i) = .true.
+          else
+            ublflg(i) = .true.
+          endif
+          wst3 = govrth(i)*sflux(i)*hpbl(i)
+          wstar(i)= wst3**h1
+          ust3 = ustar(i)**3.
+          wscaleu(i) = (ust3+wfac*vk*wst3*sfcfrac)**h1
+          wscaleu(i) = max(wscaleu(i),ustmin(i))
+        endif
+      enddo
+!
+! compute counter-gradient mixing term for heat and moisture
+!
+      do i = 1,im
+         if(ublflg(i)) then
+           hgamt(i)  = min(cfac*heat(i)/wscaleu(i),gamcrt)
+           hgamq(i)  = min(cfac*evap(i)/wscaleu(i),gamcrq)
+           vpert     = hgamt(i) + hgamq(i)*fv*theta(i,1)
+           vpert     = min(vpert,gamcrt)
+           thermal(i)= thermal(i)+max(vpert,0.)
+           hgamt(i)  = max(hgamt(i),0.0)
+           hgamq(i)  = max(hgamq(i),0.0)
+         endif
+      enddo
+!
+!  enhance the pbl height by considering the thermal excess
+!
+      do i=1,im
+         flg(i)  = .true.
+         if(ublflg(i)) then
+           flg(i)  = .false.
+           rbup(i) = rbsoil(i)
+         endif
+      enddo
+      do k = 2, kmpbl
+      do i = 1, im
+        if(.not.flg(i)) then
+          rbdn(i) = rbup(i)
+          spdk2   = max((u1(i,k)**2+v1(i,k)**2),1.)
+          rbup(i) = (thvx(i,k)-thermal(i))*                       &
+     &              (g*zl(i,k)/thvx(i,1))/spdk2
+          kpbl(i) = k
+          flg(i)  = rbup(i) > crb(i)
+        endif
+      enddo
+      enddo
+      do i = 1,im
+        if(ublflg(i)) then
+           k = kpbl(i)
+           if(rbdn(i) >= crb(i)) then
+              rbint = 0.
+           elseif(rbup(i) <= crb(i)) then
+              rbint = 1.
+           else
+              rbint = (crb(i)-rbdn(i))/(rbup(i)-rbdn(i))
+           endif
+           hpbl(i) = zl(i,k-1) + rbint*(zl(i,k)-zl(i,k-1))
+           if(hpbl(i) < zi(i,kpbl(i))) kpbl(i) = kpbl(i) - 1
+           if(kpbl(i) <= 1) then
+              ublflg(i) = .false.
+              pblflg(i) = .false.
+           endif
+        endif
+      enddo
+!
+!  look for stratocumulus
+!
+      do i = 1, im
+        flg(i)=scuflg(i)
+      enddo
+      do k = kmpbl,1,-1
+      do i = 1, im
+        if(flg(i) .and. k <= lcld(i)) then
+          if(qlx(i,k).ge.qlcr) then
+             kcld(i)=k
+             flg(i)=.false.
+          endif
+        endif
+      enddo
+      enddo
+      do i = 1, im
+        if(scuflg(i) .and. kcld(i)==km1) scuflg(i)=.false.
+      enddo
+!
+      do i = 1, im
+        flg(i)=scuflg(i)
+      enddo
+      do k = kmpbl,1,-1
+      do i = 1, im
+        if(flg(i) .and. k <= kcld(i)) then
+          if(qlx(i,k) >= qlcr) then
+            if(radx(i,k) < radmin(i)) then
+              radmin(i)=radx(i,k)
+              krad(i)=k
+            endif
+          else
+            flg(i)=.false.
+          endif
+        endif
+      enddo
+      enddo
+      do i = 1, im
+        if(scuflg(i) .and. krad(i) <= 1) scuflg(i)=.false.
+        if(scuflg(i) .and. radmin(i)>=0.) scuflg(i)=.false.
+      enddo
+!
+      do i = 1, im
+        flg(i)=scuflg(i)
+      enddo
+      do k = kmpbl,2,-1
+      do i = 1, im
+        if(flg(i) .and. k <= krad(i)) then
+          if(qlx(i,k) >= qlcr) then
+            icld(i)=icld(i)+1
+          else
+            flg(i)=.false.
+          endif
+        endif
+      enddo
+      enddo
+      do i = 1, im
+        if(scuflg(i) .and. icld(i) < 1) scuflg(i)=.false.
+      enddo
+!
+      do i = 1, im
+        if(scuflg(i)) then
+           hrad(i) = zi(i,krad(i)+1)
+!          hradm(i)= zl(i,krad(i))
+        endif
+      enddo
+!
+      do i = 1, im
+        if(scuflg(i) .and. hrad(i) thlvx(i,k-1)) scuflg(i)=.false.
+        endif
+      enddo
+! 
+      do i = 1, im
+         flg(i)=scuflg(i)
+      enddo
+      do k = kmpbl,1,-1
+      do i = 1, im
+        if(flg(i) .and. k <= krad(i))then
+          if(thlvx1(i) <= thlvx(i,k))then
+             tem=zi(i,k+1)-zi(i,k)
+             zd(i)=zd(i)+tem
+          else
+             flg(i)=.false.
+          endif
+        endif
+      enddo
+      enddo
+      do i = 1, im
+        if(scuflg(i))then
+          kk = max(1, krad(i)+1-icld(i))
+          zdd(i) = hrad(i)-zi(i,kk)
+        endif
+      enddo
+      do i = 1, im
+        if(scuflg(i))then
+          zd(i) = max(zd(i),zdd(i))
+          zd(i) = min(zd(i),hrad(i))
+          tem   = govrth(i)*zd(i)*(-radmin(i))
+          vrad(i)= tem**h1
+        endif
+      enddo
+!
+!     compute inverse prandtl number
+!
+      do i = 1, im
+        if(ublflg(i)) then
+          tem = phih(i)/phim(i)+cfac*vk*sfcfrac
+        else
+          tem = phih(i)/phim(i)
+        endif
+        prinv(i) =  1.0 / tem
+        prinv(i) = min(prinv(i),prmax)
+        prinv(i) = max(prinv(i),prmin)
+      enddo
+      do i = 1, im
+        if(zol(i) > zolcr) then
+          kpbl(i) = 1
+        endif
+      enddo
+
+!!! 20150915 WeiguoWang added alpha and wind-dependent modification of K by RGF
+#if (HWRF==1)
+! -------------------------------------------------------------------------------------
+! begin RGF modifications
+! this is version MOD05
+
+
+! RGF determine wspd at roughly 500 m above surface, or as close as possible,
+! reuse SPDK2
+!  zi(i,k) is AGL, right?  May not matter if applied only to water grid points
+      if(ALPHA.lt.0)then
+
+       DO I=1,IM
+         SPDK2 = 0.
+         WSPM(i,1) = 0.
+         DO K = 1, KMPBL ! kmpbl is like a max possible pbl height
+          if(zi(i,k).le.500.and.zi(i,k+1).gt.500.)then ! find level bracketing 500 m
+           SPDK2 = SQRT(U1(i,k)*U1(i,k)+V1(i,k)*V1(i,k)) ! wspd near 500 m
+           WSPM(i,1) = SPDK2/0.6  ! now the Km limit for 500 m.  just store in K=1
+            !wang test , limit Kmax<100
+           !  WSPM(i,1)=amin1(SPDK2/0.6, 100.0)
+            !
+           WSPM(i,2) = float(k)  ! height of level at gridpoint i. store in K=2
+!           if(i.eq.25) print *,' IK ',i,k,' ZI ',zi(i,k), ' WSPM1 ',wspm(i,1),'
+!           KMPBL ',kmpbl,' KPBL ',kpbl(i)
+          endif
+         ENDDO
+       ENDDO ! i
+
+      endif ! ALPHA < 0
+#endif
+
+
+
+!
+!     compute diffusion coefficients below pbl
+!
+      do i=1,im
+      do k = 1, kmpbl
+         if(k < kpbl(i)) then
+!           zfac = max((1.-(zi(i,k+1)-zl(i,1))/
+!    1             (hpbl(i)-zl(i,1))), zfmin)
+            zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin)
+         !   tem = zi(i,k+1) * (zfac**pfac) 
+            tem = zi(i,k+1) * (zfac**pfac) * ABS(ALPHA)
+
+!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W
+             if(useshape .ge. 1) then
+                sz2h=(ZI(I,K+1)-ZL(I,1))/(HPBL(I)-ZL(I,1))
+                sz2h=max(sz2h,zfmin)
+                sz2h=min(sz2h,1.0)
+                    zfac=(1.0-sz2h)**pfac
+!                    smax=0.148  !! max value of this shape function
+                     smax=0.148  !! max value of this shape function
+                     hmax=0.333  !! roughly height if max K
+                     skmax=hmax*(1.0-hmax)**pfac
+                     sksfc=min(ZI(I,2)/HPBL(I),0.05)  ! surface layer top, 0.05H or ZI(2) (Zi(1)=0)
+                     sksfc=sksfc*(1-sksfc)**pfac
+
+                zfac=max(zfac,zfmin)
+                ashape=max(ABS(ALPHA),0.2)  ! should not be smaller than 0.2, otherwise too much adjustment(?)
+                if(useshape ==1) then 
+                 ashape=( 1.0 - ((sz2h*zfac/smax)**0.25) *( 1.0 - ashape )  )
+                 tem = zi(i,k+1) * (zfac) * ashape
+                endif
+
+                if (useshape == 2) then   !only adjus K that is > K_surface_top
+                  ashape1=1.0
+                 if (skmax > sksfc)  ashape1=(skmax*ashape-sksfc)/(skmax-sksfc)
+                  skminusk0=ZI(I,K+1)*zfac - HPBL(i)*sksfc
+                   tem = zi(i,k+1) * (zfac) ! no adjustment
+                  if (skminusk0 > 0) then   ! only adjust K which is > surface top K
+                   tem = skminusk0*ashape1 + HPBL(i)*sksfc
+                  endif
+                endif
+             endif  ! endif useshape>1
+!!!! END OF CHAGES , WANG W
+
+!!If alpha >= 0, this is the only modification of K
+! if alpha = -1, the above provides the first guess for DKU, based on assumption
+! alpha = +1
+!               (other values of alpha < 0 can also be applied)
+! if alpha > 0, the above applies the alpha suppression factor and we are
+! finished
+
+            if(pblflg(i)) then
+              tem1 = vk * wscaleu(i) * tem
+!             dku(i,k) = xkzmo(i,k) + tem1
+!             dkt(i,k) = xkzo(i,k)  + tem1 * prinv(i)
+              dku(i,k) = tem1
+              dkt(i,k) = tem1 * prinv(i)
+            else
+              tem1 = vk * wscale(i) * tem
+!             dku(i,k) = xkzmo(i,k) + tem1
+!             dkt(i,k) = xkzo(i,k)  + tem1 * prinv(i)
+              dku(i,k) = tem1
+              dkt(i,k) = tem1 * prinv(i)
+            endif
+            dku(i,k) = min(dku(i,k),dkmax)
+            dku(i,k) = max(dku(i,k),xkzmo(i,k))
+            dkt(i,k) = min(dkt(i,k),dkmax)
+            dkt(i,k) = max(dkt(i,k),xkzo(i,k))
+            dktx(i,k)= dkt(i,k)
+         endif
+      enddo     !K loop
+
+#if (HWRF==1)
+! possible modification of first guess DKU, under certain conditions
+! (1) this applies only to columns over water
+
+        IF(xland1(i).eq.2)then ! sea only
+
+! (2) alpha test
+! if alpha < 0, find alpha for each column and do the loop again
+! if alpha > 0, we are finished
+
+
+        if(alpha.lt.0)then      ! variable alpha test
+
+! k-level of layer around 500 m
+            kLOC = INT(WSPM(i,2))
+!            print *,' kLOC ',kLOC,' KPBL ',KPBL(I)
+
+! (3) only do  this IF KPBL(I) >= kLOC.  Otherwise, we are finished, with DKU as
+! if alpha = +1
+
+          if(KPBL(I).gt.kLOC)then
+
+            xDKU = DKU(i,kLOC)     ! Km at k-level
+! (4) DKU check.
+! WSPM(i,1) is the KM cap for the 500-m level.
+!  if DKU at 500-m level < WSPM(i,1), do not limit Km ANYWHERE.  Alpha =
+!  abs(alpha).  No need to recalc.
+!  if DKU at 500-m level > WSPM(i,1), then alpha = WSPM(i,1)/xDKU for entire
+!  column
+            if(xDKU.ge.WSPM(i,1)) then ! ONLY if DKU at 500-m exceeds cap, otherwise already done
+
+            WSPM(i,3) = WSPM(i,1)/xDKU  ! ratio of cap to Km at k-level, store in WSPM(i,3)
+            !WSPM(i,4) = amin1(WSPM(I,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed
+            WSPM(i,4) = min(WSPM(I,3),1.0) ! this is new column alpha. cap at 1. ! should never be needed
+ !! recalculate K capped by WSPM(i,1)           
+      do k = 1, kmpbl
+         if(k < kpbl(i)) then
+!           zfac = max((1.-(zi(i,k+1)-zl(i,1))/
+!    1             (hpbl(i)-zl(i,1))), zfmin)
+            zfac = max((1.-zi(i,k+1)/hpbl(i)), zfmin)
+         !   tem = zi(i,k+1) * (zfac**pfac) 
+            tem = zi(i,k+1) * (zfac**pfac) * WSPM(i,4)
+
+!!! wang use different K shape, options!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!!!! CHANGES FOR HEIGHT-DEPENDENT K ADJUSTMENT, WANG W
+             if(useshape .ge. 1) then
+                sz2h=(ZI(I,K+1)-ZL(I,1))/(HPBL(I)-ZL(I,1))
+                sz2h=max(sz2h,zfmin)
+                sz2h=min(sz2h,1.0)
+                    zfac=(1.0-sz2h)**pfac
+                     smax=0.148  !! max value of this shape function
+                     hmax=0.333  !! roughly height if max K
+                     skmax=hmax*(1.0-hmax)**pfac
+                     sksfc=min(ZI(I,2)/HPBL(I),0.05)  ! surface layer top, 0.05H or ZI(2) (Zi(1)=0)
+                     sksfc=sksfc*(1-sksfc)**pfac
+
+                zfac=max(zfac,zfmin)
+                ashape=max(WSPM(i,4),0.2)  !! adjustment coef should not smaller than 0.2
+                if(useshape ==1) then 
+                 ashape=( 1.0 - ((sz2h*zfac/smax)**0.25) *( 1.0 - ashape )  )
+                 tem = zi(i,k+1) * (zfac) * ashape
+!                 if(k ==5) write(0,*)'min alf, height-depend alf',WSPM(i,4),ashape
+                endif  ! endif useshape=1
+
+                if (useshape == 2) then   !only adjus K that is > K_surface_top
+                  ashape1=1.0
+                 if (skmax > sksfc)  ashape1=(skmax*ashape-sksfc)/(skmax-sksfc)
+
+                  skminusk0=ZI(I,K+1)*zfac - HPBL(i)*sksfc
+                 tem = zi(i,k+1) * (zfac) ! no adjustment
+!             if(k ==5) write(0,*)'before, dku,ashape,ashpe1',tem*wscaleu(i)*vk,ashape,ashape1
+                  if (skminusk0 > 0) then   ! only adjust K which is > surface top K
+                   tem = skminusk0*ashape1 + HPBL(i)*sksfc
+                  endif
+!            if(k ==5) write(0,*)'after, dku,k_sfc,skmax,sksfc,zi(2),hpbl',tem*wscaleu(i)*vk,WSCALEU(I)*VK*HPBL(i)*sksfc, skmax,sksfc,ZI(I,2),HPBL(I)
+
+                endif  ! endif useshape=2
+             endif  ! endif useshape>1
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+            if(pblflg(i)) then
+              tem1 = vk * wscaleu(i) * tem
+!             dku(i,k) = xkzmo(i,k) + tem1
+!             dkt(i,k) = xkzo(i,k)  + tem1 * prinv(i)
+              dku(i,k) = tem1
+              dkt(i,k) = tem1 * prinv(i)
+            else
+              tem1 = vk * wscale(i) * tem
+!             dku(i,k) = xkzmo(i,k) + tem1
+!             dkt(i,k) = xkzo(i,k)  + tem1 * prinv(i)
+              dku(i,k) = tem1
+              dkt(i,k) = tem1 * prinv(i)
+            endif
+            dku(i,k) = min(dku(i,k),dkmax)
+            dku(i,k) = max(dku(i,k),xkzmo(i,k))
+            dkt(i,k) = min(dkt(i,k),dkmax)
+            dkt(i,k) = max(dkt(i,k),xkzo(i,k))
+            dktx(i,k)= dkt(i,k)
+         endif
+      enddo     !K loop
+            endif ! xDKU.ge.WSPM(i,1)
+          endif ! KPBL(I).ge.kLOC
+         endif ! alpha < 0
+         endif ! xland1 = 2
+
+#endif
+      enddo     ! I loop
+
+
+!
+! compute diffusion coefficients based on local scheme above pbl
+!
+      do k = 1, km1
+         do i=1,im
+            if(k >= kpbl(i)) then
+               bvf2 = g*bf(i,k)*ti(i,k)
+               ri   = max(bvf2/shr2(i,k),rimin)
+               zk   = vk*zi(i,k+1)
+               if(ri < 0.) then ! unstable regime
+                  rl2      = zk*rlamun/(rlamun+zk)
+                  dk       = rl2*rl2*sqrt(shr2(i,k))
+                  sri      = sqrt(-ri)
+!                 dku(i,k) = xkzmo(i,k) + dk*(1+8.*(-ri)/(1+1.746*sri))
+!                 dkt(i,k) = xkzo(i,k)  + dk*(1+8.*(-ri)/(1+1.286*sri))
+                  dku(i,k) = dk*(1+8.*(-ri)/(1+1.746*sri))
+                  dkt(i,k) = dk*(1+8.*(-ri)/(1+1.286*sri))
+               else             ! stable regime
+                  rl2      = zk*rlam/(rlam+zk)
+!!                tem      = rlam * sqrt(0.01*prsi(i,k))
+!!                rl2      = zk*tem/(tem+zk)
+                  dk       = rl2*rl2*sqrt(shr2(i,k))
+                  tem1     = dk/(1+5.*ri)**2
+!
+                  if(k >= kpblx(i)) then
+                    prnum = 1.0 + 2.1*ri
+                    prnum = min(prnum,prmax)
+                  else
+                    prnum = 1.0
+                  endif
+!                 dku(i,k) = xkzmo(i,k) + tem1 * prnum
+!                 dkt(i,k) = xkzo(i,k)  + tem1
+                  dku(i,k) = tem1 * prnum
+                  dkt(i,k) = tem1
+               endif
+!
+               dku(i,k) = min(dku(i,k),dkmax)
+               dku(i,k) = max(dku(i,k),xkzmo(i,k))
+               dkt(i,k) = min(dkt(i,k),dkmax)
+               dkt(i,k) = max(dkt(i,k),xkzo(i,k))
+!
+            endif
+!
+         enddo
+      enddo
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  compute components for mass flux mixing by large thermals
+!
+      do k = 1, km
+        do i = 1, im
+          if(pcnvflg(i)) then
+            tcko(i,k) = t1(i,k)
+            ucko(i,k) = u1(i,k)
+            vcko(i,k) = v1(i,k)
+            xmf(i,k) = 0.
+          endif
+        enddo
+      enddo
+      do kk = 1, ntrac
+      do k = 1, km
+        do i = 1, im
+          if(pcnvflg(i)) then
+            qcko(i,k,kk) = q1(i,k,kk)
+          endif
+        enddo
+      enddo
+      enddo
+!
+      call mfpbl(im,ix,km,ntrac,dt2,pcnvflg,                  &
+     &       zl,zi,thvx,q1,t1,u1,v1,hpbl,kpbl,                &
+     &       sflux,ustar,wstar,xmf,tcko,qcko,ucko,vcko)
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!  compute diffusion coefficients for cloud-top driven diffusion
+!  if the condition for cloud-top instability is met,
+!    increase entrainment flux at cloud top
+!
+      do i = 1, im
+        if(scuflg(i)) then
+           k = krad(i)
+           tem = thetae(i,k) - thetae(i,k+1)
+           tem1 = qtx(i,k) - qtx(i,k+1)
+           if (tem > 0. .and. tem1 > 0.) then
+             cteit= cp*tem/(hvap*tem1)
+             if(cteit > actei) rent(i) = rentf2
+           endif
+        endif
+      enddo
+      do i = 1, im
+        if(scuflg(i)) then
+           k = krad(i)
+           tem1  = max(bf(i,k),tdzmin)
+           ckt(i,k) = -rent(i)*radmin(i)/tem1
+           cku(i,k) = ckt(i,k)
+        endif
+      enddo
+!
+      do k = 1, kmpbl
+         do i=1,im
+            if(scuflg(i) .and. k < krad(i)) then
+               tem1=hrad(i)-zd(i)
+               tem2=zi(i,k+1)-tem1
+               if(tem2 > 0.) then
+                  ptem= tem2/zd(i)
+                  if(ptem.ge.1.) ptem= 1.
+                  ptem= tem2*ptem*sqrt(1.-ptem)
+                  ckt(i,k) = radfac*vk*vrad(i)*ptem
+                  cku(i,k) = 0.75*ckt(i,k)
+                  ckt(i,k) = max(ckt(i,k),dkmin)
+                  ckt(i,k) = min(ckt(i,k),dkmax)
+                  cku(i,k) = max(cku(i,k),dkmin)
+                  cku(i,k) = min(cku(i,k),dkmax)
+               endif
+            endif
+         enddo
+      enddo
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+      do k = 1, kmpbl
+        do i=1,im
+          if(scuflg(i)) then
+            ! dkt(i,k) = dkt(i,k)+ckt(i,k)
+            ! dku(i,k) = dku(i,k)+cku(i,k)
+         !! if K needs to be adjusted by alpha, then no need to add this term
+            if(alpha == 1.0)  dkt(i,k) = dkt(i,k)+ckt(i,k)
+            if(alpha == 1.0)  dku(i,k) = dku(i,k)+cku(i,k)
+             dkt(i,k) = min(dkt(i,k),dkmax)
+             dku(i,k) = min(dku(i,k),dkmax)
+          endif
+        enddo
+      enddo
+!
+!     compute tridiagonal matrix elements for heat and moisture
+!
+      do i=1,im
+         ad(i,1) = 1.
+         a1(i,1) = t1(i,1)   + beta(i) * heat(i)
+         a2(i,1) = q1(i,1,1) + beta(i) * evap(i)
+      enddo
+
+      if(ntrac >= 2) then
+        do k = 2, ntrac
+          is = (k-1) * km
+          do i = 1, im
+            a2(i,1+is) = q1(i,1,k)
+          enddo
+        enddo
+      endif
+!
+      do k = 1,km1
+        do i = 1,im
+          dtodsd = dt2/del(i,k)
+          dtodsu = dt2/del(i,k+1)
+          dsig   = prsl(i,k)-prsl(i,k+1)
+          rdz    = rdzt(i,k)
+          tem1   = dsig * dkt(i,k) * rdz
+          dsdz2     = tem1 * rdz
+          au(i,k)   = -dtodsd*dsdz2
+          al(i,k)   = -dtodsu*dsdz2
+!
+          if(pcnvflg(i) .and. k < kpbl(i)) then
+             tem2      = dsig * rdz
+             ptem      = 0.5 * tem2 * xmf(i,k)
+             ptem1     = dtodsd * ptem
+             ptem2     = dtodsu * ptem
+             ad(i,k)   = ad(i,k)-au(i,k)-ptem1
+             ad(i,k+1) = 1.-al(i,k)+ptem2
+             au(i,k)   = au(i,k)-ptem1
+             al(i,k)   = al(i,k)+ptem2
+             ptem      = tcko(i,k) + tcko(i,k+1)
+             dsdzt     = tem1 * gocp
+             a1(i,k)   = a1(i,k)+dtodsd*dsdzt-ptem1*ptem
+             a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt+ptem2*ptem
+             ptem      = qcko(i,k,1) + qcko(i,k+1,1)
+             a2(i,k)   = a2(i,k) - ptem1 * ptem
+             a2(i,k+1) = q1(i,k+1,1) + ptem2 * ptem
+          elseif(ublflg(i) .and. k < kpbl(i)) then
+             ptem1 = dsig * dktx(i,k) * rdz
+             tem   = 1.0 / hpbl(i)
+             dsdzt = tem1 * gocp - ptem1 * hgamt(i) * tem
+             dsdzq = - ptem1 * hgamq(i) * tem
+             ad(i,k)   = ad(i,k)-au(i,k)
+             ad(i,k+1) = 1.-al(i,k)
+             a1(i,k)   = a1(i,k)+dtodsd*dsdzt
+             a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt
+             a2(i,k)   = a2(i,k)+dtodsd*dsdzq
+             a2(i,k+1) = q1(i,k+1,1)-dtodsu*dsdzq
+          else
+             ad(i,k)   = ad(i,k)-au(i,k)
+             ad(i,k+1) = 1.-al(i,k)
+             dsdzt     = tem1 * gocp
+             a1(i,k)   = a1(i,k)+dtodsd*dsdzt
+             a1(i,k+1) = t1(i,k+1)-dtodsu*dsdzt
+             a2(i,k+1) = q1(i,k+1,1)
+          endif
+!
+        enddo
+      enddo
+!
+      if(ntrac >= 2) then
+        do kk = 2, ntrac
+          is = (kk-1) * km
+          do k = 1, km1
+            do i = 1, im
+              if(pcnvflg(i) .and. k < kpbl(i)) then
+                dtodsd = dt2/del(i,k)
+                dtodsu = dt2/del(i,k+1)
+                dsig  = prsl(i,k)-prsl(i,k+1)
+                tem   = dsig * rdzt(i,k)
+                ptem  = 0.5 * tem * xmf(i,k)
+                ptem1 = dtodsd * ptem
+                ptem2 = dtodsu * ptem
+                tem1  = qcko(i,k,kk) + qcko(i,k+1,kk)
+                a2(i,k+is) = a2(i,k+is) - ptem1*tem1
+                a2(i,k+1+is)= q1(i,k+1,kk) + ptem2*tem1
+              else
+                a2(i,k+1+is) = q1(i,k+1,kk)
+              endif
+            enddo
+          enddo
+        enddo
+      endif
+!
+!     solve tridiagonal problem for heat and moisture
+!
+      call tridin(im,km,ntrac,al,ad,au,a1,a2,au,a1,a2)
+
+!
+!     recover tendencies of heat and moisture
+!
+      do  k = 1,km
+         do i = 1,im
+            ttend      = (a1(i,k)-t1(i,k)) * rdt
+            qtend      = (a2(i,k)-q1(i,k,1))*rdt
+            tau(i,k)   = tau(i,k)+ttend
+            rtg(i,k,1) = rtg(i,k,1)+qtend
+            dtsfc(i)   = dtsfc(i)+cont*del(i,k)*ttend
+            dqsfc(i)   = dqsfc(i)+conq*del(i,k)*qtend
+         enddo
+      enddo
+      if(ntrac >= 2) then
+        do kk = 2, ntrac
+          is = (kk-1) * km
+          do k = 1, km 
+            do i = 1, im
+              qtend = (a2(i,k+is)-q1(i,k,kk))*rdt
+              rtg(i,k,kk) = rtg(i,k,kk)+qtend
+            enddo
+          enddo
+        enddo
+      endif
+!
+!   compute tke dissipation rate
+!
+      if(dspheat) then
+!
+      do k = 1,km1
+        do i = 1,im
+          diss(i,k) = dku(i,k)*shr2(i,k)-g*ti(i,k)*dkt(i,k)*bf(i,k)
+!         diss(i,k) = dku(i,k)*shr2(i,k)
+        enddo
+      enddo
+!
+!     add dissipative heating at the first model layer
+!
+      do i = 1,im
+         tem   = govrth(i)*sflux(i)
+         tem1  = tem + stress(i)*spd1(i)/zl(i,1)
+         tem2  = 0.5 * (tem1+diss(i,1)) 
+         tem2  = max(tem2, 0.)
+         ttend = tem2 / cp
+!         tau(i,1) = tau(i,1)+0.5*ttend
+         tau(i,1) = tau(i,1)+0.7*ttend
+      enddo
+!
+!     add dissipative heating above the first model layer
+!
+      do k = 2,km1
+        do i = 1,im
+          tem = 0.5 * (diss(i,k-1)+diss(i,k))
+          tem  = max(tem, 0.)
+          ttend = tem / cp
+!          tau(i,k) = tau(i,k) + 0.5*ttend
+          tau(i,k) = tau(i,k) + 0.7*ttend
+        enddo
+      enddo
+!
+      endif
+!
+!     compute tridiagonal matrix elements for momentum
+!
+      do i=1,im
+         ad(i,1) = 1.0 + beta(i) * stress(i) / spd1(i)
+         a1(i,1) = u1(i,1)
+         a2(i,1) = v1(i,1)
+      enddo
+!
+      do k = 1,km1
+        do i=1,im
+          dtodsd  = dt2/del(i,k)
+          dtodsu  = dt2/del(i,k+1)
+          dsig    = prsl(i,k)-prsl(i,k+1)
+          rdz     = rdzt(i,k)
+          tem1    = dsig*dku(i,k)*rdz
+          dsdz2   = tem1 * rdz
+          au(i,k) = -dtodsd*dsdz2
+          al(i,k) = -dtodsu*dsdz2
+!
+          if(pcnvflg(i) .and. k < kpbl(i)) then
+             tem2      = dsig * rdz
+             ptem      = 0.5 * tem2 * xmf(i,k)
+             ptem1     = dtodsd * ptem
+             ptem2     = dtodsu * ptem
+             ad(i,k)   = ad(i,k)-au(i,k)-ptem1
+             ad(i,k+1) = 1.-al(i,k)+ptem2
+             au(i,k)   = au(i,k)-ptem1
+             al(i,k)   = al(i,k)+ptem2
+             ptem      = ucko(i,k) + ucko(i,k+1)
+             a1(i,k)   = a1(i,k) - ptem1 * ptem
+             a1(i,k+1) = u1(i,k+1) + ptem2 * ptem
+             ptem      = vcko(i,k) + vcko(i,k+1)
+             a2(i,k)   = a2(i,k) - ptem1 * ptem
+             a2(i,k+1) = v1(i,k+1) + ptem2 * ptem
+          else
+             ad(i,k)   = ad(i,k)-au(i,k)
+             ad(i,k+1) = 1.-al(i,k)
+             a1(i,k+1) = u1(i,k+1)
+             a2(i,k+1) = v1(i,k+1)
+          endif
+!
+        enddo
+      enddo
+!
+!     solve tridiagonal problem for momentum
+!
+      call tridi2(im,km,al,ad,au,a1,a2,au,a1,a2)
+!
+!     recover tendencies of momentum
+!
+      do k = 1,km
+         do i = 1,im
+            utend = (a1(i,k)-u1(i,k))*rdt
+            vtend = (a2(i,k)-v1(i,k))*rdt
+            du(i,k)  = du(i,k)  + utend
+            dv(i,k)  = dv(i,k)  + vtend
+            dusfc(i) = dusfc(i) + conw*del(i,k)*utend
+            dvsfc(i) = dvsfc(i) + conw*del(i,k)*vtend
+!
+!  for dissipative heating for ecmwf model
+!
+!           tem1 = 0.5*(a1(i,k)+u1(i,k))
+!           tem2 = 0.5*(a2(i,k)+v1(i,k))
+!           diss(i,k) = -(tem1*utend+tem2*vtend)
+!           diss(i,k) = max(diss(i,k),0.)
+!           ttend = diss(i,k) / cp
+!           tau(i,k) = tau(i,k) + ttend
+!
+         enddo
+      enddo
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+      do i = 1, im
+         hpbl(i) = hpblx(i)
+         kpbl(i) = kpblx(i)
+      enddo
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      return
+      end subroutine moninedmf
+!c-----------------------------------------------------------------------
+      subroutine tridi2(l,n,cl,cm,cu,r1,r2,au,a1,a2)
+!cc
+      USE MODULE_GFS_MACHINE, only : kind_phys
+      implicit none
+      integer             k,n,l,i
+      real(kind=kind_phys) fk
+!cc
+      real(kind=kind_phys) cl(l,2:n),cm(l,n),cu(l,n-1),r1(l,n),r2(l,n), &
+     &          au(l,n-1),a1(l,n),a2(l,n)
+!c-----------------------------------------------------------------------
+      do i=1,l
+        fk      = 1./cm(i,1)
+        au(i,1) = fk*cu(i,1)
+        a1(i,1) = fk*r1(i,1)
+        a2(i,1) = fk*r2(i,1)
+      enddo
+      do k=2,n-1
+        do i=1,l
+          fk      = 1./(cm(i,k)-cl(i,k)*au(i,k-1))
+          au(i,k) = fk*cu(i,k)
+          a1(i,k) = fk*(r1(i,k)-cl(i,k)*a1(i,k-1))
+          a2(i,k) = fk*(r2(i,k)-cl(i,k)*a2(i,k-1))
+        enddo
+      enddo
+      do i=1,l
+        fk      = 1./(cm(i,n)-cl(i,n)*au(i,n-1))
+        a1(i,n) = fk*(r1(i,n)-cl(i,n)*a1(i,n-1))
+        a2(i,n) = fk*(r2(i,n)-cl(i,n)*a2(i,n-1))
+      enddo
+      do k=n-1,1,-1
+        do i=1,l
+          a1(i,k) = a1(i,k)-au(i,k)*a1(i,k+1)
+          a2(i,k) = a2(i,k)-au(i,k)*a2(i,k+1)
+        enddo
+      enddo
+!-----------------------------------------------------------------------
+      return
+      end subroutine tridi2
+!-----------------------------------------------------------------------
+      subroutine tridin(l,n,nt,cl,cm,cu,r1,r2,au,a1,a2)
+!!
+      USE MODULE_GFS_MACHINE     , only : kind_phys
+      implicit none
+      integer             is,k,kk,n,nt,l,i
+      real(kind=kind_phys) fk(l)
+!!
+      real(kind=kind_phys) cl(l,2:n), cm(l,n), cu(l,n-1),     &
+     &                     r1(l,n),   r2(l,n*nt),             &
+     &                     au(l,n-1), a1(l,n), a2(l,n*nt),    &  
+     &                     fkk(l,2:n-1)
+!-----------------------------------------------------------------------
+      do i=1,l
+        fk(i)   = 1./cm(i,1)
+        au(i,1) = fk(i)*cu(i,1)
+        a1(i,1) = fk(i)*r1(i,1)
+      enddo
+      do k = 1, nt
+        is = (k-1) * n
+        do i = 1, l
+          a2(i,1+is) = fk(i) * r2(i,1+is)
+        enddo
+      enddo
+      do k=2,n-1
+        do i=1,l
+          fkk(i,k) = 1./(cm(i,k)-cl(i,k)*au(i,k-1))
+          au(i,k)  = fkk(i,k)*cu(i,k)
+          a1(i,k)  = fkk(i,k)*(r1(i,k)-cl(i,k)*a1(i,k-1))
+        enddo
+      enddo
+      do kk = 1, nt
+        is = (kk-1) * n
+        do k=2,n-1
+          do i=1,l
+            a2(i,k+is) = fkk(i,k)*(r2(i,k+is)-cl(i,k)*a2(i,k+is-1))
+          enddo
+        enddo
+      enddo
+      do i=1,l
+        fk(i)   = 1./(cm(i,n)-cl(i,n)*au(i,n-1))
+        a1(i,n) = fk(i)*(r1(i,n)-cl(i,n)*a1(i,n-1))
+      enddo
+      do k = 1, nt
+        is = (k-1) * n
+        do i = 1, l
+          a2(i,n+is) = fk(i)*(r2(i,n+is)-cl(i,n)*a2(i,n+is-1))
+        enddo
+      enddo
+      do k=n-1,1,-1
+        do i=1,l
+          a1(i,k) = a1(i,k) - au(i,k)*a1(i,k+1)
+        enddo
+      enddo
+      do kk = 1, nt
+        is = (kk-1) * n
+        do k=n-1,1,-1
+          do i=1,l
+            a2(i,k+is) = a2(i,k+is) - au(i,k)*a2(i,k+is+1)
+          enddo
+        enddo
+      enddo
+!-----------------------------------------------------------------------
+      return
+      end subroutine tridin
+!----------------------------------------------------------------------
+
+!!!!!  ==========================================================  !!!!!
+! subroutine 'mfpbl' computes mass-flux components, called by 
+!  subroutine 'moninedmf'.
+!
+      subroutine mfpbl(im,ix,km,ntrac,delt,cnvflg,          &
+     &   zl,zm,thvx,q1,t1,u1,v1,hpbl,kpbl,                  &
+     &   sflx,ustar,wstar,xmf,tcko,qcko,ucko,vcko)
+!
+      USE MODULE_GFS_MACHINE, only : kind_phys
+      USE MODULE_GFS_PHYSCONS, grav => con_g, cp => con_cp
+!
+      implicit none
+!
+      integer              im, ix, km, ntrac
+!    &,                    me
+      integer              kpbl(im)
+      logical              cnvflg(im)
+      real(kind=kind_phys) delt
+      real(kind=kind_phys) q1(ix,km,ntrac), t1(ix,km),             &
+     &                     u1(ix,km),  v1(ix,km),                  &
+     &                     thvx(im,km),                            &
+     &                     zl(im,km),  zm(im,km+1),                &
+     &                     hpbl(im),   sflx(im),    ustar(im),     &
+     &                     wstar(im),  xmf(im,km),                 &
+     &                     tcko(im,km),qcko(im,km,ntrac),          & 
+     &                     ucko(im,km),vcko(im,km)                 
+!
+!c  local variables and arrays
+!
+      integer   i, j, k, n, kmpbl
+!
+      real(kind=kind_phys) dt2,     dz,      ce0,                 &
+     &                     h1,      factor,  gocp,                &
+     &                     g,       c1,      d1,                  &
+     &                     b1,      f1,      bb1,     bb2,        & 
+     &                     alp,     a1,      qmin,    zfmin,      &
+     &                     xmmx,    rbint,   tau,                 &
+!    &                     rbint,   tau,                          &
+     &                     tem,     tem1,    tem2,                &
+     &                     ptem,    ptem1,   ptem2,               &  
+     &                     pgcon
+!
+      real(kind=kind_phys) sigw1(im),   usws3(im),  xlamax(im),   &
+     &                     rbdn(im),    rbup(im),   delz(im)
+!
+      real(kind=kind_phys) wu2(im,km),     xlamue(im,km),         &
+     &                     thvu(im,km),    zi(im,km),             &
+     &                     buo(im,km)
+!
+      logical totflg, flg(im)
+!
+!c  physical parameters
+      parameter(g=grav)
+      parameter(gocp=g/cp)
+!     parameter(ce0=0.37,qmin=1.e-8,alp=1.0,pgcon=0.55)
+      parameter(ce0=0.38,qmin=1.e-8,alp=1.0,pgcon=0.55)
+      parameter(a1=0.08,b1=0.5,f1=0.15,c1=0.3,d1=2.58,tau=500.)
+      parameter(zfmin=1.e-8,h1=0.33333333)
+!
+!c-----------------------------------------------------------------------
+!
+!************************************************************************
+!
+      kmpbl = km/2 + 1
+      dt2 = delt
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+      do k = 1, km
+        do i=1,im
+          if (cnvflg(i)) then
+            zi(i,k) = zm(i,k+1)
+          endif
+        enddo
+      enddo
+!
+      do i=1,im
+        if(cnvflg(i)) then 
+          k = kpbl(i) / 2
+          k = max(k, 1) 
+          delz(i) = zl(i,k+1) - zl(i,k)
+          xlamax(i) = ce0 / delz(i)
+        endif
+      enddo
+      do k = 1, kmpbl
+        do i=1,im
+          if(cnvflg(i)) then
+            if(k < kpbl(i)) then
+              ptem = 1./(zi(i,k)+delz(i))
+              tem = max((hpbl(i)-zi(i,k)+delz(i)) ,delz(i))
+              ptem1 = 1./tem
+              xlamue(i,k) = ce0 * (ptem+ptem1)
+            else
+              xlamue(i,k) = xlamax(i)
+            endif
+          endif
+        enddo
+      enddo
+!
+!  compute thermal excess
+!
+      do i=1,im
+        if(cnvflg(i)) then
+          tem = zl(i,1)/hpbl(i)
+          usws3(i) = (ustar(i)/wstar(i))**3.
+          tem1 = usws3(i) + 0.6*tem
+          tem2 = max((1.-tem), zfmin)
+          ptem = (tem1**h1) * sqrt(tem2)
+          sigw1(i) = 1.3 * ptem * wstar(i)
+          ptem1 = alp * sflx(i) / sigw1(i)
+          thvu(i,1) = thvx(i,1) + ptem1
+          buo(i,1) = g * (thvu(i,1)/thvx(i,1)-1.)
+        endif
+      enddo
+!
+!  compute potential temperature and buoyancy for updraft air parcel
+!
+      do k = 2, kmpbl
+        do i=1,im
+          if(cnvflg(i)) then
+            dz = zl(i,k) - zl(i,k-1)
+            tem = xlamue(i,k-1) * dz
+            ptem = 2. + tem
+            ptem1 = (2. - tem) / ptem
+            tem1 = tem  * (thvx(i,k)+thvx(i,k-1)) / ptem
+            thvu(i,k) = ptem1 * thvu(i,k-1) + tem1
+            buo(i,k) = g * (thvu(i,k)/thvx(i,k)-1.)
+          endif
+        enddo
+      enddo
+!
+!  compute updraft velocity square(wu2)
+!
+!     tem = 1.-2.*f1
+!     bb1 = 2. * b1 / tem
+!     bb2 = 2. / tem
+!  from soares et al. (2004,qjrms)
+!     bb1 = 2.
+!     bb2 = 4.
+!
+!  from bretherton et al. (2004, mwr)
+!     bb1 = 4.
+!     bb2 = 2.
+!
+!  from our tuning
+      bb1 = 1.8
+      bb2 = 3.5 
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+!
+!         tem = zi(i,1)/hpbl(i)
+!         tem1 = usws3(i) + 0.6*tem
+!         tem2 = max((1.-tem), zfmin)
+!         ptem = (tem1**h1) * sqrt(tem2)
+!         ptem1 = 1.3 * ptem * wstar(i)
+!         wu2(i,1) = d1*d1*ptem1*ptem1
+!
+          dz   = zi(i,1)
+          tem  = 0.5*bb1*xlamue(i,1)*dz
+          tem1 = bb2 * buo(i,1) * dz
+          ptem1 = 1. + tem
+          wu2(i,1) = tem1 / ptem1
+!
+        endif
+      enddo
+      do k = 2, kmpbl
+        do i = 1, im
+          if(cnvflg(i)) then
+            dz    = zi(i,k) - zi(i,k-1)
+            tem  = 0.25*bb1*(xlamue(i,k)+xlamue(i,k-1))*dz
+            tem1 = bb2 * buo(i,k) * dz
+            ptem = (1. - tem) * wu2(i,k-1)
+            ptem1 = 1. + tem
+            wu2(i,k) = (ptem + tem1) / ptem1
+          endif
+        enddo
+      enddo
+!
+!  update pbl height as the height where updraft velocity vanishes
+!
+      do i=1,im
+         flg(i)  = .true.
+         if(cnvflg(i)) then
+           flg(i)  = .false.
+           rbup(i) = wu2(i,1)
+         endif
+      enddo
+      do k = 2, kmpbl
+      do i = 1, im
+        if(.not.flg(i)) then
+          rbdn(i) = rbup(i)
+          rbup(i) = wu2(i,k)
+          kpbl(i) = k
+          flg(i)  = rbup(i).le.0.
+        endif
+      enddo
+      enddo
+      do i = 1,im
+        if(cnvflg(i)) then
+           k = kpbl(i)
+           if(rbdn(i) <= 0.) then
+              rbint = 0.
+           elseif(rbup(i) >= 0.) then
+              rbint = 1.
+           else
+              rbint = rbdn(i)/(rbdn(i)-rbup(i))
+           endif
+           hpbl(i) = zi(i,k-1) + rbint*(zi(i,k)-zi(i,k-1))
+        endif
+      enddo
+!c
+      do i=1,im
+        if(cnvflg(i)) then
+          k = kpbl(i) / 2
+          k = max(k, 1)
+          delz(i) = zl(i,k+1) - zl(i,k)
+          xlamax(i) = ce0 / delz(i)
+        endif
+      enddo
+!
+!  update entrainment rate
+!
+!     do k = 1, kmpbl
+!       do i=1,im
+!         if(cnvflg(i)) then
+!           if(k < kpbl(i)) then
+!             tem = tau * sqrt(wu2(i,k))
+!             tem1 = 1. / tem
+!             ptem = ce0 / zi(i,k)
+!             xlamue(i,k) = max(tem1, ptem)
+!           else
+!             xlamue(i,k) = xlamax(i)
+!           endif
+!         endif
+!       enddo
+!     enddo
+!
+      do k = 1, kmpbl
+        do i=1,im
+          if(cnvflg(i)) then
+            if(k < kpbl(i)) then
+              ptem = 1./(zi(i,k)+delz(i))
+              tem = max((hpbl(i)-zi(i,k)+delz(i)) ,delz(i))
+              ptem1 = 1./tem
+              xlamue(i,k) = ce0 * (ptem+ptem1)
+            else
+              xlamue(i,k) = xlamax(i)
+            endif
+          endif
+        enddo
+      enddo
+!
+!  updraft mass flux as a function of sigmaw
+!   (0.3*sigmaw[square root of vertical turbulence variance])
+!
+!     do k = 1, kmpbl
+!       do i=1,im
+!         if(cnvflg(i) .and. k < kpbl(i)) then
+!           tem = zi(i,k)/hpbl(i)
+!           tem1 = usws3(i) + 0.6*tem
+!           tem2 = max((1.-tem), zfmin)
+!           ptem = (tem1**h1) * sqrt(tem2)
+!           ptem1 = 1.3 * ptem * wstar(i)
+!           xmf(i,k) = c1 * ptem1
+!         endif
+!       enddo
+!     enddo
+!
+!  updraft mass flux as a function of updraft velocity profile
+!
+      do k = 1, kmpbl
+        do i = 1, im
+          if (cnvflg(i) .and. k < kpbl(i)) then
+             xmf(i,k) = a1 * sqrt(wu2(i,k))
+             dz   = zl(i,k+1) - zl(i,k)
+             xmmx = dz / dt2
+             xmf(i,k) = min(xmf(i,k),xmmx)
+          endif
+        enddo
+      enddo
+!c
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c  compute updraft property
+!c
+      do k = 2, kmpbl
+        do i = 1, im
+          if (cnvflg(i) .and. k <= kpbl(i)) then
+             dz   = zl(i,k) - zl(i,k-1)
+             tem  = 0.5 * xlamue(i,k-1) * dz
+             factor = 1. + tem
+             ptem = tem + pgcon
+             ptem1= tem - pgcon
+!
+             tcko(i,k) = ((1.-tem)*tcko(i,k-1)+tem*               &
+     &                    (t1(i,k)+t1(i,k-1))-gocp*dz)/factor
+             ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*u1(i,k)       & 
+     &                    +ptem1*u1(i,k-1))/factor                 
+             vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*v1(i,k)       &
+     &                    +ptem1*v1(i,k-1))/factor
+          endif
+        enddo
+      enddo
+      do n = 1, ntrac
+      do k = 2, kmpbl
+        do i = 1, im
+          if (cnvflg(i) .and. k <= kpbl(i)) then
+             dz   = zl(i,k) - zl(i,k-1)
+             tem  = 0.5 * xlamue(i,k-1) * dz
+             factor = 1. + tem
+ 
+             qcko(i,k,n) = ((1.-tem)*qcko(i,k-1,n)+tem*           &
+     &                    (q1(i,k,n)+q1(i,k-1,n)))/factor
+          endif
+        enddo
+      enddo
+      enddo
+!
+      return
+      end subroutine mfpbl
+!----------------------------------------------------------------------
+#endif
+      END MODULE module_bl_gfsedmf
diff --git a/wrfv2_fire/phys/module_bl_gwdo.F b/wrfv2_fire/phys/module_bl_gwdo.F
index 51fa9b01..4cae1d39 100644
--- a/wrfv2_fire/phys/module_bl_gwdo.F
+++ b/wrfv2_fire/phys/module_bl_gwdo.F
@@ -10,7 +10,7 @@ subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z,                           &
                   rublten,rvblten,                                             &
                   dtaux3d,dtauy3d,dusfcg,dvsfcg,                               &
                   var2d,oc12d,oa2d1,oa2d2,oa2d3,oa2d4,ol2d1,ol2d2,ol2d3,ol2d4, &
-                  znu,znw,mut,p_top,                                           &
+                  znu,znw,p_top,                                               &
                   cp,g,rd,rv,ep1,pi,                                           &
                   dt,dx,kpbl2d,itimestep,                                      &
                   ids,ide, jds,jde, kds,kde,                                   &
@@ -96,9 +96,6 @@ subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z,                           &
                                                                         oc12d, &
                                                       oa2d1,oa2d2,oa2d3,oa2d4, &
                                                       ol2d1,ol2d2,ol2d3,ol2d4
-  real,     dimension( ims:ime, jms:jme )                                    , &
-            optional                                                         , &
-            intent(in  )   ::                                             mut
 !
   real,     dimension( kms:kme )                                             , &
             optional                                                         , &
@@ -121,22 +118,12 @@ subroutine gwdo(u3d,v3d,t3d,qv3d,p3d,p3di,pi3d,z,                           &
    enddo
 !
    do j = jts,jte
-      if(present(mut))then
-! For ARW we will replace p and p8w with dry hydrostatic pressure
-        do k = kts,kte+1
-          do i = its,ite
-             if(k.le.kte)pdh(i,k) = mut(i,j)*znu(k) + p_top
-             pdhi(i,k) = mut(i,j)*znw(k) + p_top
-          enddo
-        enddo
-      else
-        do k = kts,kte+1
-          do i = its,ite
-             if(k.le.kte)pdh(i,k) = p3d(i,k,j)
-             pdhi(i,k) = p3di(i,k,j)
-          enddo
+      do k = kts,kte+1
+        do i = its,ite
+           if(k.le.kte)pdh(i,k) = p3d(i,k,j)
+           pdhi(i,k) = p3di(i,k,j)
         enddo
-      endif
+      enddo
 !
       do k = kts,kte
         do i = its,ite
diff --git a/wrfv2_fire/phys/module_bl_mfshconvpbl.F b/wrfv2_fire/phys/module_bl_mfshconvpbl.F
index dbaad069..a4f80ad1 100644
--- a/wrfv2_fire/phys/module_bl_mfshconvpbl.F
+++ b/wrfv2_fire/phys/module_bl_mfshconvpbl.F
@@ -1388,7 +1388,7 @@ SUBROUTINE COMPUTE_UPDRAFT(OMIXUV,PZZ,PDZZ,KK,              &
 
 
 ! Computation or initialisation of updraft characteristics at the KK level
-! thetal_up,rt_up,thetaV_up, w²,Buoyancy term and mass flux (PEMF)
+! thetal_up,rt_up,thetaV_up, w-squared,Buoyancy term and mass flux (PEMF)
 
 ! 03/2009
 !PTHL_UP(:,KK)= ZTHLM_F(:,KK)+(PSFTH(:)/SQRT(ZTKEM_F(:,KK)))*XALP_PERT
diff --git a/wrfv2_fire/phys/module_bl_mynn.F b/wrfv2_fire/phys/module_bl_mynn.F
index 56fde672..afb8b301 100644
--- a/wrfv2_fire/phys/module_bl_mynn.F
+++ b/wrfv2_fire/phys/module_bl_mynn.F
@@ -51,7 +51,13 @@
 !                WRF_CHEM = 1, thanks to Wayne Angevine.
 !            Added scale-aware mixing length, following Junshi Ito's work
 !                Ito et al. (2015, BLM).
-!
+! 8. v3.9.0  Improvement to the mass-flux scheme (dynamic number of plumes,
+!                better plume/cloud depth, significant speed up, better cloud
+!                fraction). 
+!            Added Stochastic Parameter Perturbation (SPP) implementation.
+!            Many miscellaneous tweaks to the mixing lengths and stratus
+!                component of the subgrid clouds.
+! 
 ! For changes 1, 3, and 6, see "JOE's mods" below:
 !-------------------------------------------------------------------
 
@@ -141,6 +147,9 @@ MODULE module_bl_mynn
   REAL, PARAMETER :: scaleaware=1.
 
 
+  !Temporary switch to deactivate the mixing of chemical species (already done when WRF_CHEM = 1)
+  INTEGER, PARAMETER :: bl_mynn_mixchem = 0
+
 ! JAYMES-
 ! Constants used for empirical calculations of saturation
 ! vapor pressures (in function "esat") and saturation mixing ratios
@@ -326,15 +335,17 @@ MODULE module_bl_mynn
 !     # As to dtl, ...gh, see subroutine mym_turbulence.
 !
 !-------------------------------------------------------------------
-  SUBROUTINE  mym_initialize ( kts,kte,&
-       &            dz, zw,  &
-       &            u, v, thl, qw, &
-!       &            ust, rmo, pmz, phh, flt, flq,&
-       &            zi, theta, sh,&
-       &            ust, rmo, el,&
+  SUBROUTINE  mym_initialize (                                & 
+       &            kts,kte,                                  &
+       &            dz, zw,                                   &
+       &            u, v, thl, qw,                            &
+!       &            ust, rmo, pmz, phh, flt, flq,             &
+       &            zi, theta, sh,                            &
+       &            ust, rmo, el,                             &
        &            Qke, Tsq, Qsq, Cov, Psig_bl, cldfra_bl1D, &
-       &            bl_mynn_mixlength, &
-       &            edmf_a1,edmf_qc1,bl_mynn_edmf)
+       &            bl_mynn_mixlength,                        &
+       &            edmf_a1,edmf_qc1,bl_mynn_edmf,            &
+       &            spp_pbl,rstoch_col)
 !
 !-------------------------------------------------------------------
     
@@ -357,6 +368,9 @@ SUBROUTINE  mym_initialize ( kts,kte,&
     REAL :: zi
     REAL, DIMENSION(kts:kte) :: theta
 
+    REAL, DIMENSION(kts:kte) :: rstoch_col
+    INTEGER ::spp_pbl
+
 !   **  At first ql, vt and vq are set to zero.  **
     DO k = kts,kte
        ql(k) = 0.0
@@ -396,16 +410,18 @@ SUBROUTINE  mym_initialize ( kts,kte,&
 !
     DO l = 1,lmax
 !
-       CALL mym_length ( kts,kte,&
-            &            dz, zw, &
-            &            rmo, flt, flq, &
-            &            vt, vq, &
-            &            qke, &
-            &            dtv, &
-            &            el, &
-            &            zi,theta,&
+       CALL mym_length (                     &
+            &            kts,kte,            &
+            &            dz, zw,             &
+            &            rmo, flt, flq,      &
+            &            vt, vq,             &
+            &            qke,                &
+            &            dtv,                &
+            &            el,                 &
+            &            zi,theta,           &
             &            qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,&
-            &            edmf_a1,edmf_qc1,bl_mynn_edmf)
+            &            edmf_a1,edmf_qc1,bl_mynn_edmf,&
+            &            spp_pbl,rstoch_col)
 !
        DO k = kts+1,kte
           elq = el(k)*qkw(k)
@@ -597,16 +613,18 @@ END SUBROUTINE mym_level2
 !     NOTE: the mixing lengths are meant to be calculated at the full-
 !           sigmal levels (or interfaces beween the model layers).
 !
-  SUBROUTINE  mym_length ( kts,kte,&
-    &            dz, zw, &
-    &            rmo, flt, flq, &
-    &            vt, vq, &
-    &            qke, &
-    &            dtv, &
-    &            el, &
-    &            zi,theta,&       !JOE-BouLac mod
+  SUBROUTINE  mym_length (                     & 
+    &            kts,kte,                      &
+    &            dz, zw,                       &
+    &            rmo, flt, flq,                &
+    &            vt, vq,                       &
+    &            qke,                          &
+    &            dtv,                          &
+    &            el,                           &
+    &            zi,theta,                     &
     &            qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength,&
-    &            edmf_a1,edmf_qc1,bl_mynn_edmf)
+    &            edmf_a1,edmf_qc1,bl_mynn_edmf,&
+    &            spp_pbl,rstoch_col)
     
 !-------------------------------------------------------------------
 
@@ -652,8 +670,11 @@ SUBROUTINE  mym_length ( kts,kte,&
 
 
     INTEGER :: i,j,k
-    REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,elb,elb_cloud,els,els1,elf, &
-            & el_stab,el_unstab,el_mf,el_stab_mf,elb_mf
+    REAL :: afk,abk,zwk,zwk1,dzk,qdz,vflx,bv,tau_cloud,elb,els,els1,elf, &
+            & el_stab,el_unstab,el_mf,el_stab_mf,elb_mf,PBLH_PLUS_ENT
+
+    INTEGER, INTENT(IN)   :: spp_pbl
+    REAL, DIMENSION(kts:kte), INTENT(in)   :: rstoch_col
 
     IF ( bl_mynn_mixlength .EQ. 0 ) THEN
        cns  = 2.7
@@ -670,19 +691,19 @@ SUBROUTINE  mym_length ( kts,kte,&
        alp4 = 20.
        alp5 = 0.4
     ELSEIF ( bl_mynn_mixlength .GE. 2 ) THEN
-       cns  = 2.7
+       cns  = 3.5
        alp1 = 0.23
-       alp2 = 0.3
+       alp2 = 0.25
        alp3 = 3.0
        alp4 = 10.
-       alp5 = 0.4
+       alp5 = 0.3
     ENDIF
 
 !    tv0 = 0.61*tref
 !    gtr = 9.81/tref
 !
-!JOE-added to impose limits on the height integration for elt as well 
-!    as the transition layer depth
+!   Impose limits on the height integration for elt as well 
+!   as the transition layer depth
     IF ( bl_mynn_mixlength .EQ. 0 ) THEN
        zi2=10000.  !originally integrated to model top, not just 10 km.
     ELSE
@@ -694,7 +715,6 @@ SUBROUTINE  mym_length ( kts,kte,&
 
     qtke(kts)=MAX(qke(kts)/2.,0.01) !tke at full sigma levels
     thetaw(kts)=theta(kts)          !theta at full-sigma levels
-!JOE-end
     qkw(kts) = SQRT(MAX(qke(kts),1.0e-10))
 
     DO k = kts+1,kte
@@ -709,13 +729,17 @@ SUBROUTINE  mym_length ( kts,kte,&
     vsc = 1.0e-5
 !
 !   **  Strictly, zwk*h(i,j) -> ( zwk*h(i,j)+z0 )  **
-!JOE-Lt mod: only integrate to top of PBL (+ transition/entrainment
-!   layer), since TKE aloft is not relevant. Make WHILE loop, so it
-!   exits after looping through the boundary layer.
+!   Only integrate to top of PBL (+ transition/entrainment layer),
+!   since TKE aloft is not relevant. 
 !
-     k = kts+1
-     zwk = zw(k)
-     DO WHILE (zwk .LE. (zi2+h1))
+    IF ( bl_mynn_mixlength .EQ. 2 ) THEN
+       PBLH_PLUS_ENT = MAX(zi, 100.)
+    ELSE
+       PBLH_PLUS_ENT = zi2+h1
+    ENDIF
+    k = kts+1
+    zwk = zw(k)
+    DO WHILE (zwk .LE. PBLH_PLUS_ENT)
        dzk = 0.5*( dz(k)+dz(k-1) )
        qdz = MAX( qkw(k)-qmin, 0.03 )*dzk
              elt = elt +qdz*zwk
@@ -724,7 +748,7 @@ SUBROUTINE  mym_length ( kts,kte,&
        zwk = zw(k)
     END DO
 !
-    elt =  alp1*elt/vsc
+    elt =  MAX(alp1*elt/vsc, 10.)
     vflx = ( vt(kts)+1.0 )*flt +( vq(kts)+tv0 )*flq
     vsc = ( gtr*elt*MAX( vflx, 0.0 ) )**(1.0/3.0)
 !
@@ -762,11 +786,6 @@ SUBROUTINE  mym_length ( kts,kte,&
            elb_mf = alp2*qkw(k) / bv &
                 &       *( 1.0 + alp3/alp2*&
                 &SQRT( vsc/( bv*elt ) ) )
-           tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(flt,1.0e-4))**(1.0/3.0)), 100.),300.)
-           !minimize influence of surface heat flux on tau far away from the PBLH.
-           wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
-           tau_cloud = tau_cloud*(1.-wt) + 100.*wt        
-           elb_cloud = MIN(tau_cloud*SQRT(MIN(qtke(k),16.)), zwk)
            elb = MIN(alp2*qkw(k)/bv, zwk)
            elf = elb
            IF (zwk > zi .AND. elf > 500.) THEN
@@ -774,8 +793,6 @@ SUBROUTINE  mym_length ( kts,kte,&
              CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0)
              elf = alp5*elBLavg0
            ENDIF
-           elb = elb*(1.-cldfra_bl1D(k)) + elb_cloud*cldfra_bl1D(k)
-           elf = elf*(1.-cldfra_bl1D(k)) + elb_cloud*cldfra_bl1D(k)
 
          END IF 
 
@@ -797,20 +814,20 @@ SUBROUTINE  mym_length ( kts,kte,&
            ! by zi, and zero is replaced by 1.0e-4 to
            ! prevent division by zero.
 
-           tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(flt,1.0e-4))**(1.0/3.0)),200.),300.)
+           tau_cloud = MIN(MAX(0.5*zi/((gtr*zi*MAX(flt,1.0e-4))**(1.0/3.0)),10.),100.)
            !minimize influence of surface heat flux on tau far away from the PBLH.
            wt=.5*TANH((zwk - (zi2+h1))/h2) + .5
-           tau_cloud = tau_cloud*(1.-wt) + 100.*wt
-           elb_cloud = MIN(tau_cloud*SQRT(MIN(qtke(k),20.)), zwk)
-           elb = elb_cloud
-           elf = elb_cloud
+           tau_cloud = tau_cloud*(1.-wt) + 50.*wt
+
+           elb = MIN(tau_cloud*SQRT(MIN(qtke(k),20.)), zwk)
+           elf = elb
            elb_mf = elb
            IF (zwk > zi .AND. elf > 500.) THEN
              ! COMPUTE BouLac mixing length for dry conditions in free atmosphere
              CALL boulac_length0(k,kts,kte,zw,dz,qtke,thetaw,elBLmin0,elBLavg0)
-             elf = alp5*elBLavg0*(1.-cldfra_bl1D(k)) + elb_cloud*cldfra_bl1D(k)
+             elf = alp5*elBLavg0*(1.-cldfra_bl1D(k)) + elf*cldfra_bl1D(k)
            END IF
-           elf = elf*(1.-cldfra_bl1D(k)) + elb_cloud*cldfra_bl1D(k)
+           elf = elf*(1.-cldfra_bl1D(k)) + elb*cldfra_bl1D(k)
 
          END IF
        END IF
@@ -819,15 +836,8 @@ SUBROUTINE  mym_length ( kts,kte,&
 
 !   **  Length scale in the surface layer  **
        IF ( rmo .GT. 0.0 ) THEN
-         IF ( bl_mynn_mixlength .LE. 1 ) THEN
-           els  = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax ))
-           els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax ))
-         ELSE
-           els  = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax ))
-           els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax ))
-           !els  = vk*zwk/(1.0+cns*MIN( zwk1*rmo, zmax ))
-           !els1 = vk*z_m/(1.0+cns*MIN( zwk1*rmo, zmax ))
-         ENDIF
+          els  = vk*zwk/(1.0+cns*MIN( zwk*rmo, zmax ))
+          els1 = vk*z_m/(1.0+cns*MIN( zwk*rmo, zmax ))
        ELSE
           els  =  vk*zwk*( 1.0 - alp4* zwk*rmo )**0.2
           els1 =  vk*z_m*( 1.0 - alp4* zwk*rmo )**0.2
@@ -851,24 +861,17 @@ SUBROUTINE  mym_length ( kts,kte,&
 
        !JAYMES- el_stab & el_unstab blending begin ( bl_mynn_mixlength opt)
        ELSE IF ( bl_mynn_mixlength .GE. 2 ) THEN
-          hs = MAX(MIN(0.2*zi,200.),50.) ! bounded:  50 m < hs < 200 m
-          !z_m = MAX(0.,zwk - zwk1)
-          wt2 = 1.-(MIN(z_m,hs)/hs)
-
-          el_stab = els*wt2 + elb*(1.-wt2)
-          el_stab_mf = els*wt2 + elb_mf*(1.-wt2)
-
           el_unstab = els/(1. + (els1/elt))
 
+          el_stab    = MIN(el_unstab, elb) 
+          el_stab_mf = MIN(el_unstab, elb_mf)
+
           IF (bl_mynn_edmf > 0 .AND. edmf_a1(kts)>0.0) THEN
-             !Force unstable mixing length to be used in the lower PBL and
-             !blended unstable-mf length scale in the upper PBL when the mass-flux
-             !scheme is active.
-              !wt2=.5*TANH((zwk - (0.5*zi))/(0.25*zi)) + .5
-              !el(k) = el_unstab*wt2 + MIN(el_stab_mf,el_unstab)*(1.-wt2)
-              el(k) = MIN(el_stab_mf,el_unstab)
+             !Force version of buiyncay mixing length with the enhancement factor to be used 
+             !when the mass-flux scheme is active.
+              el(k) = el_stab_mf
           ELSE
-              el(k) = MIN(el_stab,el_unstab)
+              el(k) = el_stab
           ENDIF
           el(k) = el(k)*(1.-wt) + elf*wt
        END IF
@@ -877,14 +880,22 @@ SUBROUTINE  mym_length ( kts,kte,&
          el(k) = el(k)*Psig_bl
        END IF
 
-       !IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN
+!      Stochastic perturbations of turbulent mixing length
+       if (spp_pbl==1) then
+          if (k.lt.25) then
+             el(k)= el(k) + el(k)* rstoch_col(k) * 1.5 * MAX(exp(-MAX(zwk-3000.,0.0)/2000.),0.01)
+          endif
+       endif
+
+
+       IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN
          IF (el(k) > 1000.) THEN
-           WRITE ( mynn_message , FMT='(A,F7.0,I5,5F7.0)' ) &
-           ' MYNN; mym_length; LARGE el,k,elb_cloud,elb,elt,elf,tau:'&
-                                , el(k),k,elb_cloud,elb,elt,elf,tau_cloud
+           WRITE ( mynn_message , FMT='(A,F7.0,I5,4F7.0)' ) &
+           ' MYNN; mym_length; LARGE el,k,elb,elt,elf,tau:'&
+                                , el(k),k,elb,elt,elf,tau_cloud
            CALL wrf_debug ( 0 , mynn_message )
          ENDIF
-       !ENDIF
+       ENDIF
 
     END DO
 !
@@ -1241,21 +1252,23 @@ END SUBROUTINE boulac_length
 !     # dtl, dqw, dtv, gm and gh are allowed to share storage units with
 !       dfm, dfh, dfq, tcd and qcd, respectively, for saving memory.
 !
-  SUBROUTINE  mym_turbulence ( kts,kte,&
-    &            levflag, &
-    &            dz, zw, &
-    &            u, v, thl, ql, qw, &
-    &            qke, tsq, qsq, cov, &
-    &            vt, vq,&
-    &            rmo, flt, flq, &
-    &            zi,theta,&
-    &            sh,&
-    &            El,&
-    &            Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc &
-    &		 ,qWT1D,qSHEAR1D,qBUOY1D,qDISS1D &
-    &            ,bl_mynn_tkebudget &
-    &            ,Psig_bl,Psig_shcu,cldfra_bl1D,bl_mynn_mixlength,&
-    &            edmf_a1,edmf_qc1,bl_mynn_edmf)
+  SUBROUTINE  mym_turbulence (                                &
+    &            kts,kte,                                     &
+    &            levflag,                                     &
+    &            dz, zw,                                      &
+    &            u, v, thl, ql, qw,                           &
+    &            qke, tsq, qsq, cov,                          &
+    &            vt, vq,                                      &
+    &            rmo, flt, flq,                               &
+    &            zi,theta,                                    &
+    &            sh,                                          &
+    &            El,                                          &
+    &            Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, &
+    &		 qWT1D,qSHEAR1D,qBUOY1D,qDISS1D,              &
+    &            bl_mynn_tkebudget,                           &
+    &            Psig_bl,Psig_shcu,cldfra_bl1D,bl_mynn_mixlength,&
+    &            edmf_a1,edmf_qc1,bl_mynn_edmf,&
+    &            spp_pbl,rstoch_col)
 
 !-------------------------------------------------------------------
 !
@@ -1297,6 +1310,13 @@ SUBROUTINE  mym_turbulence ( kts,kte,&
     DOUBLE PRECISION  q2sq, t2sq, r2sq, c2sq, elsq, gmel, ghel
     DOUBLE PRECISION  q3sq, t3sq, r3sq, c3sq, dlsq, qdiv
     DOUBLE PRECISION  e1, e2, e3, e4, enum, eden, wden
+
+!   Stochastic
+    INTEGER,  INTENT(IN)                          ::    spp_pbl
+    REAL, DIMENSION(KTS:KTE)                      ::    rstoch_col
+    REAL :: prlimit
+
+
 !
 !    tv0 = 0.61*tref
 !    gtr = 9.81/tref
@@ -1316,16 +1336,18 @@ SUBROUTINE  mym_turbulence ( kts,kte,&
     &            ql, vt, vq, &
     &            dtl, dqw, dtv, gm, gh, sm, sh )
 !
-    CALL mym_length (kts,kte, &
-    &            dz, zw, &
-    &            rmo, flt, flq, &
-    &            vt, vq, &
-    &            qke, &
-    &            dtv, &
-    &            el, &
-    &            zi,theta,&
+    CALL mym_length (                           &
+    &            kts,kte,                       &
+    &            dz, zw,                        &
+    &            rmo, flt, flq,                 &
+    &            vt, vq,                        &
+    &            qke,                           &
+    &            dtv,                           &
+    &            el,                            &
+    &            zi,theta,                      &
     &            qkw,Psig_bl,cldfra_bl1D,bl_mynn_mixlength, &
-    &            edmf_a1,edmf_qc1,bl_mynn_edmf)
+    &            edmf_a1,edmf_qc1,bl_mynn_edmf, &
+    &            spp_pbl,rstoch_col)
 !
 
     DO k = kts+1,kte
@@ -1428,12 +1450,6 @@ SUBROUTINE  mym_turbulence ( kts,kte,&
           sh(k) = q3sq*(a2/a2den)*( e2+3.0*c1*e5c*gmel )/eden
        END IF !end Helfand & Labraga check
 
-       !JOE-TEST: try forcing some small ED mixing within the MF plume
-       !IF (bl_mynn_edmf > 0 .AND. edmf_a1(k)>0.01) THEN
-       !   sh(k) = MAX(sh(k),0.05)
-       !   sm(k) = MAX(sm(k),0.05)
-       !ENDIF
-
        !JOE: Level 2.5 debug prints
        ! HL88 , lev2.5 criteria from eqs. 3.17, 3.19, & 3.20
        IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN
@@ -1617,6 +1633,14 @@ SUBROUTINE  mym_turbulence ( kts,kte,&
           gamq = 0.0
           gamv = 0.0
        END IF
+!
+!      Add stochastic perturbation of prandtl number limit
+       if (spp_pbl==1) then
+          prlimit = MIN(MAX(1.,2.5 + 5.0*rstoch_col(k)), 10.)
+          IF(sm(k) > sh(k)*Prlimit) THEN
+             sm(k) = sh(k)*Prlimit
+          ENDIF
+       ENDIF
 !
        elq = el(k)*qkw(k)
        elh = elq*qdiv
@@ -2061,11 +2085,10 @@ SUBROUTINE  mym_condensation (kts,kte,  &
     &            thl, qw,                 &
     &            p,exner,                 &
     &            tsq, qsq, cov,           &
-    &            Sh, el, bl_mynn_cloudpdf,& !JOE - cloud PDF testing
-    &            qc_bl1D, cldfra_bl1D,    & !JOE - subgrid BL clouds
-    &            PBLH1,HFX1,              & !JOE - for subgrid BL clouds
-    &            edmf_qc1,                &
-    &            Vt, Vq)
+    &            Sh, el, bl_mynn_cloudpdf,&
+    &            qc_bl1D, cldfra_bl1D,    &
+    &            PBLH1,HFX1,              &
+    &            Vt, Vq, th, sgm)
 
 !-------------------------------------------------------------------
 
@@ -2073,20 +2096,16 @@ SUBROUTINE  mym_condensation (kts,kte,  &
     REAL, INTENT(IN)      :: dx,PBLH1,HFX1
     REAL, DIMENSION(kts:kte), INTENT(IN) :: dz
     REAL, DIMENSION(kts:kte), INTENT(IN) :: p,exner, thl, qw, &
-         &tsq, qsq, cov, edmf_qc1
+         &tsq, qsq, cov, th
 
-    REAL, DIMENSION(kts:kte), INTENT(OUT) :: vt,vq
+    REAL, DIMENSION(kts:kte), INTENT(INOUT) :: vt,vq,sgm
 
-    REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,sgm,ql,q1,cld,RH
+    REAL, DIMENSION(kts:kte) :: qmq,alp,a,bet,b,ql,q1,cld,RH
     REAL, DIMENSION(kts:kte), INTENT(OUT) :: qc_bl1D,cldfra_bl1D
     DOUBLE PRECISION :: t3sq, r3sq, c3sq
 
-! WA TEST 8/6/15 save incoming qc and cldfra (from EDMF?)
- !   REAL, DIMENSION(kts:kte) :: qc_prev,cldfra_prev
-!
-
     REAL :: p2a,qsl,esat,qsat,tlk,qsat_tl,dqsl,cld0,q1k,eq1,qll,&
-         &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,fng,qww,alpha,beta,bb,ls,wt
+         &q2p,pt,rac,qt,t,xl,rsl,cpm,cdhdz,Fng,qww,alpha,beta,bb,ls_min,ls,wt
     INTEGER :: i,j,k
 
     REAL :: erf
@@ -2096,13 +2115,35 @@ SUBROUTINE  mym_condensation (kts,kte,  &
     REAL, DIMENSION(kts:kte), INTENT(IN) :: Sh,el
 
     !JOE: variables for BL clouds
-    REAL::zagl,cld9,damp,edown,RHcrit,RHmean,RHsum,RHnum,Hshcu,PBLH2
+    REAL::zagl,cld9,damp,edown,RHcrit,RHmean,RHsum,RHnum,Hshcu,PBLH2,ql_limit
     REAL, PARAMETER :: Hfac = 3.0     !cloud depth factor for HFX (m^3/W)
     REAL, PARAMETER :: HFXmin = 50.0  !min W/m^2 for BL clouds
-    REAL            :: RH_00L, RH_00O, phi_dz
+    REAL            :: RH_00L, RH_00O, phi_dz, lfac
     REAL, PARAMETER :: cdz = 2.0
     REAL, PARAMETER :: mdz = 1.5
 
+    !JAYMES:  variables for tropopause-height estimation
+    REAL            :: theta1, theta2, ht1, ht2
+    INTEGER         :: k_tropo
+
+! First, obtain an estimate for the tropopause height (k), using the method employed in the
+! Thompson subgrid-cloud scheme.  This height will be a consideration later when determining 
+! the "final" subgrid-cloud properties.
+! JAYMES:  added 3 Nov 2016, adapted from G. Thompson
+
+      DO k = kte-3, kts, -1
+         theta1 = th(k)
+         theta2 = th(k+2)
+         ht1 = 44307.692 * (1.0 - (p(k)/101325.)**0.190)
+         ht2 = 44307.692 * (1.0 - (p(k+2)/101325.)**0.190)
+         if ( (((theta2-theta1)/(ht2-ht1)) .lt. 10./1500. ) .AND.       &
+     &                       (ht1.lt.19000.) .and. (ht1.gt.4000.) ) then 
+            goto 86
+         endif
+      ENDDO
+ 86   continue
+      k_tropo = MAX(kts+2, k+2)
+
 ! WA TEST 8/6/15 save incoming qc and cldfra (from EDMF?)
  !   qc_prev = qc_bl1D
  !   cldfra_prev = cldfra_bl1D
@@ -2110,8 +2151,7 @@ SUBROUTINE  mym_condensation (kts,kte,  &
     zagl = 0.
 ! Note: kte needs to be larger than kts, i.e., kte >= kts+1.
     DO k = kts,kte-1
-       p2a = exner(k)
-       t  = thl(k)*p2a
+       t  = th(k)*exner(k)
 
 !x      if ( ct .gt. 0.0 ) then
 !       a  =  17.27
@@ -2136,6 +2176,8 @@ SUBROUTINE  mym_condensation (kts,kte,  &
        bet(k) = dqsl*p2a
 
        IF (bl_mynn_cloudpdf == 0) THEN
+          !NOTE: negative bl_mynn_cloudpdf will zero-out the stratus subgrid clouds
+          !      at the end of this subroutine. 
           !Sommeria and Deardorff (1977) scheme, as implemented
           !in Nakanishi and Niino (2009), Appendix B
           t3sq = MAX( tsq(k), 0.0 )
@@ -2153,7 +2195,7 @@ SUBROUTINE  mym_condensation (kts,kte,  &
           !CLOUD FRACTION. rr2 = 1/SQRT(2) = 0.707
           cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) )
 
-       ELSE IF (bl_mynn_cloudpdf == 1) THEN
+       ELSE IF (bl_mynn_cloudpdf == 1 .OR. bl_mynn_cloudpdf == -1) THEN
           !ALTERNATIVE FORM (Nakanishi & Niino 2004 BLM, eq. B6, and 
           !Kuwano-Yoshida et al. 2010 QJRMS, eq. 7):
           if (k .eq. kts) then 
@@ -2170,7 +2212,7 @@ SUBROUTINE  mym_condensation (kts,kte,  &
           q1(k)   = qmq(k) / sgm(k)
           cld(k) = 0.5*( 1.0+erf( q1(k)*rr2 ) )
 
-       ELSE IF (bl_mynn_cloudpdf >= 2) THEN
+       ELSE IF (bl_mynn_cloudpdf == 2 .OR. bl_mynn_cloudpdf == -2) THEN
           !Diagnostic statistical scheme of Chaboureau and Bechtold (2002), JAS
           !JAYMES- this added 27 Apr 2015
           xl = xl_blend(t)                    ! obtain latent heat
@@ -2207,16 +2249,26 @@ SUBROUTINE  mym_condensation (kts,kte,  &
                                                 ! in CB02
 
           zagl = zagl + dz(k)
-          !ls = MIN(MAX(zagl,25.),300.)
-          ls = MIN(el(k),300.)
-                  ! CB02 use 900 m as a (constant) free-atmosphere length scale. 
-                  ! The form above was selected based on HRRR tests.
+          ls_min = MIN(MAX(zagl,25.),300.) ! Let this be the minimum possible length scale:
+                                       !   25 m < ls_min(=zagl) < 300 m
+          lfac=MIN(4.25+dx/4000.,6.)   ! A dx-dependent multiplier for the master length scale:
+                                       !   lfac(750 m) = 4.4
+                                       !   lfac(3 km)  = 5.0
+                                       !   lfac(13 km) = 6.0
 
-          sgm(k) = MAX(1.e-10, 0.2*ls*SQRT(MAX(0., & ! Eq. 9 in CB02:
+          ls = MAX(MIN(lfac*el(k),900.),ls_min)  ! Bounded:  ls_min < ls < 900 m
+                  ! Note: CB02 use 900 m as a constant free-atmosphere length scale. 
+
+                  ! Above 300 m AGL, ls_min remains 300 m.  For dx = 3 km, the 
+                  ! MYNN master length scale (el) must exceed 60 m before ls
+                  ! becomes responsive to el, otherwise ls = ls_min = 300 m.
+
+          sgm(k) = MAX(1.e-10, 0.225*ls*SQRT(MAX(0., & ! Eq. 9 in CB02:
                   & (a(k)*dqw/dzk)**2              & ! < 1st term in brackets,
                   & -2*a(k)*b(k)*cdhdz*dqw/dzk     & ! < 2nd term,
                   & +b(k)**2 * cdhdz**2)))           ! < 3rd term
-                  ! Per CB02, 0.2 is chosen as a constant.
+                  ! CB02 use a multiplier of 0.2, but 0.225 is chosen
+                  ! based on tests
 
           q1(k) = qmq(k) / sgm(k)  ! Q1, the normalized saturation
 
@@ -2233,54 +2285,21 @@ SUBROUTINE  mym_condensation (kts,kte,  &
     PBLH2=MAX(10.,PBLH1)
 
     DO k = kts,kte-1
+         t    = th(k)*exner(k)
+         q1k  = q1(k)
+         zagl = zagl + dz(k)
+         !q1=0.
+         !cld(k)=0.
 
-      IF (edmf_qc1(k) > 1.e-9) THEN
-         !RETAIN CLDFRA & QC_BL FROM MASS-FLUX SCHEME, but compute vt & vq
-         q1k = -0.7
-         fng = -1.5*q1k
-
-         xl    = xl_blend(t)
-         q2p  = xlvcp/exner(k)
-         pt = thl(k) +q2p*edmf_qc1(k) ! potential temp
-         bb = b(k)*t/pt ! bb is "b" in BCMT95.  Their "b" differs from
-                        ! "b" in CB02 (i.e., b(k) above) by a factor
-                        ! of T/theta.  Strictly, b(k) above is formulated in
-                        ! terms of sat. mixing ratio, but bb in BCMT95 is
-                        ! cast in terms of sat. specific humidity.  The
-                        ! conversion is neglected here.
-         qww   = 1.+0.61*qw(k)
-         alpha = 0.61*pt
-         p2a   = exner(k)
-         t     = thl(k)*p2a
-         beta  = pt*xl/(t*cp) - 1.61*pt
-
-         vt(k) = (1.-cldfra_bl1D(k))*qww   + cldfra_bl1D(k)*(qww   - beta*bb  *(1.+fng)) - 1.
-         vq(k) = (1.-cldfra_bl1D(k))*alpha + cldfra_bl1D(k)*(alpha + beta*a(k)*(1.+fng)) - tv0
-         ! These equations were derived by Jaymes, using BCMT95, Eq. B5,
-         ! in order to recast the BC02/BCMT95 buoyancy flux in terms of
-         ! vt and vq (i.e., beta-theta and beta-q in NN09, Eq. B8).
-         ! The "-1" and "-tv0" terms are included for consistency with
-         ! the legacy vt and vq formulations (above).
+         IF ( bl_mynn_cloudpdf <= 1 .AND. bl_mynn_cloudpdf >= -1) THEN
 
-      ELSE
+              !COMPUTE MEAN RH IN PBL (NOT PRESSURE WEIGHTED).
+              IF (zagl < PBLH2 .AND. PBLH2 > 400.) THEN
+                 RHsum=RHsum+RH(k)
+                 RHnum=RHnum+1.0
+                 RHmean=RHsum/RHnum
+              ENDIF
 
-         q1k  = q1(k)
-         zagl = zagl + dz(k)
-         !COMPUTE MEAN RH IN PBL (NOT PRESSURE WEIGHTED).
-         IF (zagl < PBLH2 .AND. PBLH2 > 400.) THEN
-            RHsum=RHsum+RH(k)
-            RHnum=RHnum+1.0
-            RHmean=RHsum/RHnum
-         ENDIF
-!         IF (cld(k) < 0. .OR. cld(k) > 1.) THEN
-!            PRINT*,"MYM_CONDENSATION, k=",k," cld=",cld(k)
-!            PRINT*," r3sq=",r3sq," t3sq=",t3sq," c3sq=",c3sq
-!         ENDIF
-!         q1=0.
-!         cld(k)=0.
-
-         IF ( bl_mynn_cloudpdf <= 1 ) THEN
-       
               RHcrit = 1. - 0.35*(1.0 - (MAX(250.- MAX(HFX1,HFXmin),0.0)/200.)**2)
               if(HFX1 > HFXmin)then
                  cld9=MIN(MAX(0., (rh(k)-RHcrit)/(1.1-RHcrit)), 1.)**2
@@ -2299,8 +2318,8 @@ SUBROUTINE  mym_condensation (kts,kte,  &
               elseif (zagl >= PBLH2+Hshcu)then
                  damp=MIN(1.0,exp(-ABS((zagl-(PBLH2+Hshcu))/500.)))
               endif
-       !       cldfra_bl1D(k)=cld9*damp
-             cldfra_bl1D(k)=cld(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value
+              cldfra_bl1D(k)=cld9*damp
+              !cldfra_bl1D(k)=cld(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value
        
               !use alternate cloud fraction to estimate qc for use in BL clouds-radiation
               eq1  = rrp*EXP( -0.5*q1k*q1k )
@@ -2308,8 +2327,8 @@ SUBROUTINE  mym_condensation (kts,kte,  &
               !ESTIMATED LIQUID WATER CONTENT (UNNORMALIZED)
               ql (k) = alp(k)*sgm(k)*qll
               if(cldfra_bl1D(k)>0.01 .and. ql(k)<1.E-6)ql(k)=1.E-6
-       !         qc_bl1D(k)=ql(k)*damp
-             qc_bl1D(k)=ql(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value
+              qc_bl1D(k)=ql(k)*damp
+              !qc_bl1D(k)=ql(k) ! JAYMES: use this form to retain the Sommeria-Deardorff value
        
               !now recompute estimated lwc for PBL scheme's use
               !qll IS THE NORMALIZED LIQUID WATER CONTENT (Sommeria and
@@ -2332,7 +2351,7 @@ SUBROUTINE  mym_condensation (kts,kte,  &
               vt(k) =      qt-1.0 -rac*bet(k)
               vq(k) = p608*pt-tv0 +rac
        
-         ELSE IF ( bl_mynn_cloudpdf == 2 ) THEN
+         ELSE IF ( bl_mynn_cloudpdf == 2 .OR.  bl_mynn_cloudpdf == -2) THEN
          ! JAYMES- this option added 8 May 2015
          ! The cloud water formulations are taken from CB02, Eq. 8.
          ! "fng" represents the non-Gaussian contribution to the liquid
@@ -2346,54 +2365,78 @@ SUBROUTINE  mym_condensation (kts,kte,  &
               ELSE
                 ql (k) = sgm(k)*(EXP(-1.) + 0.66*q1k + 0.086*q1k**2)
               ENDIF
+  
+              !Next, adjust our initial estimates of cldfra and ql based
+              !on tropopause-height and PBLH considerations
+              !JAYMES:  added 4 Nov 2016
+              if ((cld(k) .gt. 0.) .or. (ql(k) .gt. 0.))  then
+                 if (k .le. k_tropo) then
+                   !At and below tropopause: impose an upper limit on ql; assume that
+                   !a maximum of 0.5 percent supersaturation in water vapor can be
+                   !available for cloud production
+                    ql_limit = 0.005 * qsat_blend( th(k)*exner(k), p(k) )
+                    ql(k) = MIN( ql(k), ql_limit )
+                 else
+                   !Above tropopause:  eliminate subgrid clouds from CB scheme
+                    cld(k) = 0.
+                    ql(k) = 0.
+                 endif 
+              endif
        
-              !buoyancy-flux-related calculations follow
-              IF (q1k < -2.) THEN
-                fng = 1.-q1k
-              ELSE IF (q1k > 0.) THEN
-                fng = 0.
-              ELSE
-                fng = -1.5*q1k
-              ENDIF
-       
+              !Buoyancy-flux-related calculations follow...
+              ! "Fng" represents the non-Gaussian transport factor
+              ! (non-dimensional) from from Bechtold et al. 1995 
+              ! (hereafter BCMT95), section 3(c).  Their suggested 
+              ! forms for Fng (from their Eq. 20) are:
+              !IF (q1k < -2.) THEN
+              !  Fng = 2.-q1k
+              !ELSE IF (q1k > 0.) THEN
+              !  Fng = 1.
+              !ELSE
+              !  Fng = 1.-1.5*q1k
+              !ENDIF
+              ! For purposes of the buoyancy flux in stratus, we will use Fng = 1
+              Fng = 1.
+
               xl    = xl_blend(t)
-              q2p  = xlvcp/exner(k)
-              pt = thl(k) +q2p*ql(k) ! potential temp
-              bb = b(k)*t/pt ! bb is "b" in BCMT95.  Their "b" differs from 
-                             ! "b" in CB02 (i.e., b(k) above) by a factor 
-                             ! of T/theta.  Strictly, b(k) above is formulated in
-                             ! terms of sat. mixing ratio, but bb in BCMT95 is
-                             ! cast in terms of sat. specific humidity.  The
-                             ! conversion is neglected here. 
+              bb = b(k)*t/th(k) ! bb is "b" in BCMT95.  Their "b" differs from
+                                ! "b" in CB02 (i.e., b(k) above) by a factor
+                                ! of T/theta.  Strictly, b(k) above is formulated in
+                                ! terms of sat. mixing ratio, but bb in BCMT95 is
+                                ! cast in terms of sat. specific humidity.  The
+                                ! conversion is neglected here.
               qww   = 1.+0.61*qw(k)
-              alpha = 0.61*pt
-              p2a   = exner(k)
-              t     = thl(k)*p2a
-              beta  = pt*xl/(t*cp) - 1.61*pt
-       
-              vt(k) = (1.-cld(k))*qww   + cld(k)*(qww   - beta*bb  *(1.+fng)) - 1.
-              vq(k) = (1.-cld(k))*alpha + cld(k)*(alpha + beta*a(k)*(1.+fng)) - tv0
-              ! These equations were derived by Jaymes, using BCMT95, Eq. B5, 
-              ! in order to recast the BC02/BCMT95 buoyancy flux in terms of
-              ! vt and vq (i.e., beta-theta and beta-q in NN09, Eq. B8).  
-              ! The "-1" and "-tv0" terms are included for consistency with 
+              alpha = 0.61*th(k)
+              beta  = (th(k)/t)*(xl/cp) - 1.61*th(k)
+
+              vt(k) = qww   - cld(k)*beta*bb*Fng   - 1.
+              vq(k) = alpha + cld(k)*beta*a(k)*Fng - tv0
+              ! vt and vq correspond to beta-theta and beta-q, respectively,
+              ! in NN09, Eq. B8.  They also correspond to the bracketed
+              ! expressions in BCMT95, Eq. 15, since (s*ql/sigma^2) = cldfra*Fng
+              ! The "-1" and "-tv0" terms are included for consistency with
               ! the legacy vt and vq formulations (above).
-       
+
+              ! increase the cloud fraction estimate below PBLH+1km
+              if (zagl .lt. PBLH2+1000.) cld(k) = MIN( 1., 1.8*cld(k) )
               !return a cloud condensate and cloud fraction for icloud_bl option:
               cldfra_bl1D(k) = cld(k)
               qc_bl1D(k) = ql(k)
        
          ENDIF !end cloudPDF option
 
-       ENDIF !end MF check
-
-       !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother,
-       ! add limit to qc_bl and cldfra_bl:
-       IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6
-       IF (CLDFRA_BL1D(k) < 1E-2)THEN
-          CLDFRA_BL1D(k)=0.
-          QC_BL1D(k)=0.
-       ENDIF
+         !FOR TESTING PURPOSES ONLY, ISOLATE ON THE MASS-CLOUDS.
+         IF (bl_mynn_cloudpdf .LT. 0) THEN
+              cldfra_bl1D(k) = 0.0
+              qc_bl1D(k) = 0.0
+         ENDIF
+         !To avoid FPE in radiation driver, when these two quantities are multiplied by eachother,
+         ! add limit to qc_bl and cldfra_bl:
+         IF (QC_BL1D(k) < 1E-6 .AND. ABS(CLDFRA_BL1D(k)) > 0.01) QC_BL1D(k)= 1E-6
+         IF (CLDFRA_BL1D(k) < 1E-2)THEN
+            CLDFRA_BL1D(k)=0.
+            QC_BL1D(k)=0.
+         ENDIF
 
     END DO
 !
@@ -2430,7 +2473,7 @@ SUBROUTINE mynn_tendencies(kts,kte,      &
        &bl_mynn_cloudmix,                  &
        &bl_mynn_mixqt,                     &
        &bl_mynn_edmf,                      &
-       &bl_mynn_edmf_mom                   )
+       &bl_mynn_edmf_mom                  )
 
 !-------------------------------------------------------------------
     INTEGER, INTENT(in) :: kts,kte
@@ -2485,27 +2528,22 @@ SUBROUTINE mynn_tendencies(kts,kte,      &
     ! Note that s_awu and s_awv already come in as 0.0 if bl_mynn_edmf_mom == 0, so
     ! we only need to zero-out the MF diffusivity term
     maxdfh=maxval(dfh(1:15))
-    mindfh=maxdfh*0.02
+    mindfh=maxdfh*0.01
     DO k=kts,kte
        dtz(k)=delt/dz(k)
-       !dfhc(k)=dfh(k)
-       !dfmc(k)=dfm(k)
        IF (dfm(k) > dfh(k)) THEN 
          !in stable regime only, limit Prandtl number to < 2 within clouds
          IF (qc(k) > 1.e-6 .OR. &
              qi(k) > 1.e-6 .OR. &
              cldfra_bl1D(k) > 0.05 ) THEN
-             !dfhc(k)= MAX(dfh(k),dfm(k)*0.5)
              dfh(k)= MAX(dfh(k),dfm(k)*0.5)
          ENDIF
        ENDIF
        !add small minimum Km & Kh in MF updrafts for edmf2
        IF(bl_mynn_edmf==2 .AND. k > 1 .AND. s_aw(k)>0.0) THEN
-          !dfhc(k)=MAX(mindfh,dfhc(k))
-          !dfmc(k)=MAX(mindfh,dfmc(k))
-          dfh(k)=MAX(mindfh,dfh(k))
-          dfm(k)=MAX(mindfh,dfm(k))
-        ENDIF
+           dfh(k)=MAX(mindfh,dfh(k))
+           dfm(k)=MAX(mindfh,dfm(k))
+       ENDIF
     ENDDO
 
 !!============================================
@@ -2517,7 +2555,7 @@ SUBROUTINE mynn_tendencies(kts,kte,      &
     a(1)=0.
     b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff
     c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff
-    d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)
+    d(1)=u(k) + dtz(k)*uoce*ust**2/wspd - dtz(k)*s_awu(k+1)*onoff
 
 !!    a(1)=0.
 !!    b(1)=1.+dtz(k)*dfm(k+1)
@@ -2529,7 +2567,7 @@ SUBROUTINE mynn_tendencies(kts,kte,      &
        a(kk)=-dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff
        b(kk)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff
        c(kk)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff
-       d(kk)=u(k) + dtz(k)*(s_awu(k)-s_awu(k+1))
+       d(kk)=u(k) + dtz(k)*(s_awu(k)-s_awu(k+1))*onoff
     ENDDO
 
 !! no flux at the top
@@ -2566,7 +2604,7 @@ SUBROUTINE mynn_tendencies(kts,kte,      &
     b(1)=1. + dtz(k)*(dfm(k+1)+ust**2/wspd) - 0.5*dtz(k)*s_aw(k+1)*onoff
     c(1)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff
 !    d(1)=v(k)
-    d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)
+    d(1)=v(k) + dtz(k)*voce*ust**2/wspd - dtz(k)*s_awv(k+1)*onoff
 
 !!    a(1)=0.
 !!    b(1)=1.+dtz(k)*dfm(k+1)
@@ -2578,7 +2616,7 @@ SUBROUTINE mynn_tendencies(kts,kte,      &
        a(kk)=-dtz(k)*dfm(k) + 0.5*dtz(k)*s_aw(k)*onoff
        b(kk)=1. + dtz(k)*(dfm(k)+dfm(k+1)) + 0.5*dtz(k)*(s_aw(k)-s_aw(k+1))*onoff
        c(kk)=-dtz(k)*dfm(k+1) - 0.5*dtz(k)*s_aw(k+1)*onoff
-       d(kk)=v(k) + dtz(k)*(s_awv(k)-s_awv(k+1))
+       d(kk)=v(k) + dtz(k)*(s_awv(k)-s_awv(k+1))*onoff
     ENDDO
 
 !! no flux at the top
@@ -2900,7 +2938,7 @@ SUBROUTINE mynn_tendencies(kts,kte,      &
     DO k=kts,kte
 
        IF (bl_mynn_mixqt > 0) THEN
-         t  = thl(k)*exner(k)
+         t  = th(k)*exner(k)
          !SATURATED VAPOR PRESSURE
          esat=esat_blend(t)
          !SATURATED SPECIFIC HUMIDITY
@@ -2988,20 +3026,20 @@ SUBROUTINE mynn_tendencies(kts,kte,      &
        ! THETA TENDENCY
        !===================
        IF (FLAG_QI) THEN
-         !Dth(k)=(thl(k) + xlvcp/exner(k)*sqc(k) &
-         !  &            + xlscp/exner(k)*sqi(k) &
-         !  &            - th(k))/delt
+         Dth(k)=(thl(k) + xlvcp/exner(k)*sqc(k) &
+           &            + xlscp/exner(k)*sqi(k) &
+           &            - th(k))/delt
          !Use form from Tripoli and Cotton (1981) with their
          !suggested min temperature to improve accuracy:
-         Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k)  &
-           &               + xlscp/MAX(tk(k),TKmin)*sqi2(k)) &
-           &               - th(k))/delt
+         !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k)  &
+         !  &               + xlscp/MAX(tk(k),TKmin)*sqi2(k)) &
+         !  &               - th(k))/delt
        ELSE
-         !Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt
+         Dth(k)=(thl(k)+xlvcp/exner(k)*sqc2(k) - th(k))/delt
          !Use form from Tripoli and Cotton (1981) with their
          !suggested min temperature to improve accuracy.
-         Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k))  &
-         &               - th(k))/delt
+         !Dth(k)=(thl(k)*(1.+ xlvcp/MAX(tk(k),TKmin)*sqc2(k))  &
+         !&               - th(k))/delt
        ENDIF
 
     ENDDO
@@ -3069,7 +3107,7 @@ SUBROUTINE mynn_mix_chem(kts,kte,      &
        b(1)=1.+dtz(k)*dfh(k+1)
        c(1)=-dtz(k)*dfh(k+1)
        ! d(1)=sqv(k) + dtz(k)*flqv + qcd(k)*delt
-       d(1)=chem1(k,ic) + dtz(k) * -vd1(ic)*chem1(1,ic)
+       d(1)=chem1(k,ic) + dtz(k) * (-1.0) * vd1(ic) * chem1(1,ic)
 
        DO k=kts+1,kte-1
           kk=k-kts+1
@@ -3163,7 +3201,7 @@ SUBROUTINE tridiag(n,a,b,c,d)
   END SUBROUTINE tridiag
 
 ! ==================================================================
-  SUBROUTINE mynn_bl_driver(&
+  SUBROUTINE mynn_bl_driver(            &
        &initflag,grav_settling,         &
        &delt,dz,dx,znt,                 &
        &u,v,w,th,qv,qc,qi,qni,qnc,      &
@@ -3181,23 +3219,24 @@ SUBROUTINE mynn_bl_driver(&
        &Tsq,Qsq,Cov,                    &
        &RUBLTEN,RVBLTEN,RTHBLTEN,       &
        &RQVBLTEN,RQCBLTEN,RQIBLTEN,     &
-       &RQNIBLTEN,                      & !RQNCBLTEN, &
+       &RQNIBLTEN,                      &
        &exch_h,exch_m,                  &
        &Pblh,kpbl,                      & 
        &el_pbl,                         &
        &dqke,qWT,qSHEAR,qBUOY,qDISS,    & !JOE-TKE BUDGET
        &wstar,delta,                    & !JOE-added for grims
-       &bl_mynn_tkebudget,              & !JOE-TKE BUDGET
-       &bl_mynn_cloudpdf,Sh3D,          & !JOE-cloudPDF testing
-       &bl_mynn_mixlength,              & !JAYMES- mixing length options
-       &icloud_bl,qc_bl,cldfra_bl,      & !JOE-subgrid bl clouds
-       &bl_mynn_edmf,                   & !JOE- edmf
+       &bl_mynn_tkebudget,              &
+       &bl_mynn_cloudpdf,Sh3D,          &
+       &bl_mynn_mixlength,              &
+       &icloud_bl,qc_bl,cldfra_bl,      &
+       &bl_mynn_edmf,                   &
        &bl_mynn_edmf_mom,bl_mynn_edmf_tke, &
-       &bl_mynn_edmf_part,              & !JOE- edmf
-       &bl_mynn_cloudmix,bl_mynn_mixqt, & !JOE- cloud mixing methods
+       &bl_mynn_edmf_part,              &
+       &bl_mynn_cloudmix,bl_mynn_mixqt, &
        &edmf_a,edmf_w,edmf_qt,          &
        &edmf_thl,edmf_ent,edmf_qc,      &
-      &FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC &
+       &spp_pbl,pattern_spp_pbl,        &
+       &FLAG_QI,FLAG_QNI,FLAG_QC,FLAG_QNC &
        &,IDS,IDE,JDS,JDE,KDS,KDE        &
        &,IMS,IME,JMS,JME,KMS,KME        &
        &,ITS,ITE,JTS,JTE,KTS,KTE)
@@ -3265,7 +3304,7 @@ SUBROUTINE mynn_bl_driver(&
 
     INTEGER,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: & 
          &KPBL
-    
+
     REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: &
          &el_pbl
 
@@ -3279,12 +3318,13 @@ SUBROUTINE mynn_bl_driver(&
 
     REAL, DIMENSION(IMS:IME,KMS:KME,JMS:JME), INTENT(inout) :: &
          &qc_bl,cldfra_bl
-    REAL, DIMENSION(KTS:KTE) :: qc_bl1D,cldfra_bl1D
+    REAL, DIMENSION(KTS:KTE) :: qc_bl1D,cldfra_bl1D,&
+                            qc_bl1D_old,cldfra_bl1D_old
 
 ! WA 7/29/15 Mix chemical arrays
 #if (WRF_CHEM == 1)
     INTEGER, INTENT(IN   )   ::   nchem, kdvel, ndvel, num_vert_mix
-    REAL,    DIMENSION( ims:ime, kts:kte, jms:jme, nchem ), INTENT(INOUT) :: chem3d
+    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme, nchem ), INTENT(INOUT) :: chem3d
     REAL,    DIMENSION( ims:ime, kdvel, jms:jme, ndvel ), INTENT(IN) :: vd3d
     REAL,    DIMENSION( kts:kte, nchem ) :: chem1
     REAL,    DIMENSION( kts:kte+1, nchem ) :: s_awchem1
@@ -3296,7 +3336,8 @@ SUBROUTINE mynn_bl_driver(&
     INTEGER :: ITF,JTF,KTF, IMD,JMD
     INTEGER :: i,j,k
     REAL, DIMENSION(KTS:KTE) :: thl,tl,sqv,sqc,sqi,sqw,&
-         &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, Vt, Vq
+         &El, Dfm, Dfh, Dfq, Tcd, Qcd, Pdk, Pdt, Pdq, Pdc, &
+         &Vt, Vq, sgm
 
     REAL, DIMENSION(KTS:KTE) :: thetav,sh,u1,v1,w1,p1,ex1,dz1,th1,tk1,rho1,&
            & qke1,tsq1,qsq1,cov1,qv1,qi1,qc1,du1,dv1,dth1,dqv1,dqc1,dqi1, &
@@ -3311,7 +3352,7 @@ SUBROUTINE mynn_bl_driver(&
 
     REAL, DIMENSION(KTS:KTE+1) :: zw
     REAL :: cpm,sqcg,flt,flq,flqv,flqc,pmz,phh,exnerg,zet,& 
-              &afk,abk
+              &afk,abk,ts_decay,th_sfc
 
 !JOE-add GRIMS parameters & variables
    real,parameter    ::  d1 = 0.02, d2 = 0.05, d3 = 0.001
@@ -3320,6 +3361,12 @@ SUBROUTINE mynn_bl_driver(&
 !JOE-end GRIMS
     INTEGER, SAVE :: levflag
 
+! Stochastic fields 
+     INTEGER,  INTENT(IN)                                               ::spp_pbl
+     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN),OPTIONAL  ::pattern_spp_pbl
+     REAL, DIMENSION(KTS:KTE)                         ::    rstoch_col
+
+
     IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN
         WRITE ( mynn_message , FMT='(A)' ) &
            'in MYNN driver; at beginning'
@@ -3339,7 +3386,7 @@ SUBROUTINE mynn_bl_driver(&
 
     IF (bl_mynn_edmf > 0) THEN
       ! setup random seed
-      call init_random_seed
+      !call init_random_seed
 
       edmf_a(its:ite,kts:kte,jts:jte)=0.
       edmf_w(its:ite,kts:kte,jts:jte)=0.
@@ -3362,8 +3409,13 @@ SUBROUTINE mynn_bl_driver(&
        !dqnc1(kts:kte)=0.0
        qc_bl1D(kts:kte)=0.0
        cldfra_bl1D(kts:kte)=0.0
+       qc_bl1D_old(kts:kte)=0.0
+       cldfra_bl1D_old(kts:kte)=0.0
        edmf_a1(kts:kte)=0.0
        edmf_qc1(kts:kte)=0.0
+       sgm(kts:kte)=0.0
+       vt(kts:kte)=0.0
+       vq(kts:kte)=0.0
 
        DO j=JTS,JTF
           DO i=ITS,ITF
@@ -3381,19 +3433,19 @@ SUBROUTINE mynn_bl_driver(&
                 IF (PRESENT(qi) .AND. FLAG_QI ) THEN
                    sqi(k)=qi(i,k,j)/(1.+qi(i,k,j))
                    sqw(k)=sqv(k)+sqc(k)+sqi(k)
-                   !thl(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc(k) &
-                   !    &           - xlscp/exner(i,k,j)*sqi(k)
+                   thl(k)=th(i,k,j)- xlvcp/exner(i,k,j)*sqc(k) &
+                       &           - xlscp/exner(i,k,j)*sqi(k)
                    !Use form from Tripoli and Cotton (1981) with their
                    !suggested min temperature to improve accuracy.
-                   thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &
-                       &               - xlscp/MAX(tk1(k),TKmin)*sqi(k))
+                   !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &
+                   !    &               - xlscp/MAX(tk1(k),TKmin)*sqi(k))
                 ELSE
                    sqi(k)=0.0
                    sqw(k)=sqv(k)+sqc(k)
-                   !thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k)
+                   thl(k)=th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k)
                    !Use form from Tripoli and Cotton (1981) with their 
                    !suggested min temperature to improve accuracy.      
-                   thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k))
+                   !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k))
                 ENDIF
 
                 IF (k==kts) THEN
@@ -3412,6 +3464,12 @@ SUBROUTINE mynn_bl_driver(&
                 tsq1(k)=tsq(i,k,j)
                 qsq1(k)=qsq(i,k,j)
                 cov1(k)=cov(i,k,j)
+                if (spp_pbl==1) then
+                    rstoch_col(k)=pattern_spp_pbl(i,k,j)
+                else
+                    rstoch_col(k)=0.0
+                endif
+
 
                 IF ( bl_mynn_tkebudget == 1) THEN
                    !TKE BUDGET VARIABLES
@@ -3435,14 +3493,16 @@ SUBROUTINE mynn_bl_driver(&
                 Psig_shcu(i,j)=1.0
              ENDIF
 
-             CALL mym_initialize ( kts,kte,    &
+             CALL mym_initialize (             & 
+                  &kts,kte,                    &
                   &dz1, zw, u1, v1, thl, sqv,  &
                   &PBLH(i,j), th1, sh,         &
                   &ust(i,j), rmol(i,j),        &
                   &el, Qke1, Tsq1, Qsq1, Cov1, &
                   &Psig_bl(i,j), cldfra_bl1D,  &
                   &bl_mynn_mixlength,          &
-                  &edmf_a1,edmf_qc1,bl_mynn_edmf )
+                  &edmf_a1,edmf_qc1,bl_mynn_edmf,&
+                  &spp_pbl,rstoch_col )
 
              !UPDATE 3D VARIABLES
              DO k=KTS,KTE !KTF
@@ -3497,6 +3557,8 @@ SUBROUTINE mynn_bl_driver(&
              qc1(k)= qc(i,k,j)
              sqv(k)= qv(i,k,j)/(1.+qv(i,k,j))
              sqc(k)= qc(i,k,j)/(1.+qc(i,k,j))
+             IF(icloud_bl > 0)cldfra_bl1D_old(k)=cldfra_bl(i,k,j)
+             IF(icloud_bl > 0)qc_bl1D_old(k)=qc_bl(i,k,j)
              dqc1(k)=0.0
              dqi1(k)=0.0
              dqni1(k)=0.0
@@ -3505,20 +3567,20 @@ SUBROUTINE mynn_bl_driver(&
                 qi1(k)= qi(i,k,j)
                 sqi(k)= qi(i,k,j)/(1.+qi(i,k,j))
                 sqw(k)= sqv(k)+sqc(k)+sqi(k)
-                !thl(k)= th(i,k,j) - xlvcp/exner(i,k,j)*sqc(k) &
-                !     &            - xlscp/exner(i,k,j)*sqi(k)
+                thl(k)= th(i,k,j) - xlvcp/exner(i,k,j)*sqc(k) &
+                     &            - xlscp/exner(i,k,j)*sqi(k)
                 !Use form from Tripoli and Cotton (1981) with their
                 !suggested min temperature to improve accuracy.    
-                thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &
-                    &               - xlscp/MAX(tk1(k),TKmin)*sqi(k))
+                !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k) &
+                !    &               - xlscp/MAX(tk1(k),TKmin)*sqi(k))
              ELSE
                 qi1(k)=0.0
                 sqi(k)=0.0
                 sqw(k)= sqv(k)+sqc(k)
-                !thl(k)= th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k)
+                thl(k)= th(i,k,j)-xlvcp/exner(i,k,j)*sqc(k)
                 !Use form from Tripoli and Cotton (1981) with their
                 !suggested min temperature to improve accuracy.    
-                thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k))
+                !thl(k)=th(i,k,j)*(1.- xlvcp/MAX(tk1(k),TKmin)*sqc(k))
              ENDIF
 
              IF (PRESENT(qni) .AND. FLAG_QNI ) THEN
@@ -3542,6 +3604,13 @@ SUBROUTINE mynn_bl_driver(&
              tsq1(k)=tsq(i,k,j)
              qsq1(k)=qsq(i,k,j)
              cov1(k)=cov(i,k,j)
+             if (spp_pbl==1) then
+                rstoch_col(k)=pattern_spp_pbl(i,k,j)
+             else
+                rstoch_col(k)=0.0
+             endif
+
+
              !edmf
              edmf_a1(k)=0.0
              edmf_qc1(k)=0.0
@@ -3585,7 +3654,7 @@ SUBROUTINE mynn_bl_driver(&
           s_awv1(kte+1)=0.
           s_awqke1(kte+1)=0.
 #if (WRF_CHEM == 1)
-          DO ic = 1,ndvel
+          DO ic = 1,nchem
             s_awchem1(kte+1,ic)=0.
           ENDDO
 #endif
@@ -3619,6 +3688,7 @@ SUBROUTINE mynn_bl_driver(&
             & -vdfg(i,j)*(sqc(kts) - sqcg )
           flqv = qfx(i,j)/rho(i,kts,j)
           flqc = -vdfg(i,j)*(sqc(kts) - sqcg )
+          th_sfc = ts(i,j)/ex1(kts)
 
           zet = 0.5*dz(i,kts,j)*rmol(i,j)
           if ( zet >= 0.0 ) then
@@ -3642,15 +3712,26 @@ SUBROUTINE mynn_bl_driver(&
           delta(i,j) = min(d1*pblh(i,j) + d2*wm2/delb, 100.)
           !-- End GRIMS-----------------------------------------
 
+          CALL  mym_condensation ( kts,kte,      &
+               &dx,dz1,thl,sqw,p1,ex1,           &
+               &tsq1, qsq1, cov1,                &
+               &Sh,el,bl_mynn_cloudpdf,          &
+               &qc_bl1D,cldfra_bl1D,             &
+               &PBLH(i,j),HFX(i,j),              &
+               &Vt, Vq, th1, sgm )
+
           IF (bl_mynn_edmf == 1) THEN
             !PRINT*,"Calling StEM Mass-Flux: i= ",i," j=",j
-            CALL StEM_mf(kts,kte,delt,zw,p1,      &
+            CALL StEM_mf(                         &
+               &kts,kte,delt,zw,dz1,p1,           &
                &bl_mynn_edmf_mom,                 &
                &bl_mynn_edmf_tke,                 &
                &u1,v1,w1,th1,thl,thetav,tk1,      &
                &sqw,sqv,sqc,qke1,                 &
+               &ex1,Vt,Vq,sgm,                    &
                &ust(i,j),flt,flq,flqv,flqc,       &
-               &PBLH(i,j),DX,xland(i,j),          &
+               &PBLH(i,j),KPBL(i,j),DX,           &
+               &xland(i,j),th_sfc,                &
             ! now outputs - tendencies
             ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf &
             ! outputs - updraft properties
@@ -3660,13 +3741,18 @@ SUBROUTINE mynn_bl_driver(&
                & s_aw1,s_awthl1,s_awqt1,          &
                & s_awqv1,s_awqc1,s_awu1,s_awv1,   &
                & s_awqke1,                        &
+#if (WRF_CHEM == 1)
+               & nchem,chem1,s_awchem1,           &
+#endif
                & qc_bl1D,cldfra_bl1D,             &
                & FLAG_QI,FLAG_QC,                 &
-               & Psig_shcu(i,j)                   &
+               & Psig_shcu(i,j),                  &
+               & spp_pbl,rstoch_col               &
             )
 
           ELSEIF (bl_mynn_edmf == 2) THEN
-            CALL temf_mf(kts,kte,delt,zw,p1,ex1,  &
+            CALL temf_mf(                         &
+               &kts,kte,delt,zw,p1,ex1,           &
                &u1,v1,w1,th1,thl,thetav,          &
                &sqw,sqv,sqc,qke1,                 &
                &ust(i,j),flt,flq,flqv,flqc,       &
@@ -3685,20 +3771,13 @@ SUBROUTINE mynn_bl_driver(&
                & qc_bl1D,cldfra_bl1D              &
                &,FLAG_QI,FLAG_QC                  &
                &,Psig_shcu(i,j)                   &
+               &,spp_pbl,rstoch_col               &
+               &,i,j,ids,ide,jds,jde              &
              )
           ENDIF
 
-
-          CALL  mym_condensation ( kts,kte,      &
-               &dx,dz1,thl,sqw,p1,ex1,           &
-               &tsq1, qsq1, cov1,                &
-               &Sh,el,bl_mynn_cloudpdf,          & !JOE-cloud PDF testing (Kuwano-Yoshida et al. 2010)
-               &qc_bl1D,cldfra_bl1D,             & !JOE-subgrid BL clouds
-               &PBLH(i,j),HFX(i,j),              & !JOE-subgrid BL clouds
-               &edmf_qc1,                        &
-               &Vt, Vq)
-
-          CALL mym_turbulence ( kts,kte,levflag, &
+          CALL mym_turbulence (                  & 
+               &kts,kte,levflag,                 &
                &dz1, zw, u1, v1, thl, sqc, sqw,  &
                &qke1, tsq1, qsq1, cov1,          &
                &vt, vq,                          &
@@ -3712,53 +3791,9 @@ SUBROUTINE mynn_bl_driver(&
                &bl_mynn_tkebudget,               &
                &Psig_bl(i,j),Psig_shcu(i,j),     &     
                &cldfra_bl1D,bl_mynn_mixlength,   &
-               &edmf_a1,edmf_qc1,bl_mynn_edmf)
-
-!          IF (bl_mynn_edmf == 1) THEN
-!            !PRINT*,"Calling StEM Mass-Flux: i= ",i," j=",j
-!            CALL StEM_mf(kts,kte,delt,zw,p1,      &
-!               &bl_mynn_edmf_mom,                 &
-!               &bl_mynn_edmf_tke,                 &
-!               &u1,v1,w1,th1,thl,thetav,tk1,      &
-!               &sqw,sqv,sqc,qke1,                 &
-!               &ust(i,j),flt,flq,flqv,flqc,       &
-!               &PBLH(i,j),DX,xland(i,j),          &
-!            ! now outputs - tendencies
-!            ! &,dth1mf,dqv1mf,dqc1mf,du1mf,dv1mf & 
-!            ! outputs - updraft properties
-!               & edmf_a1,edmf_w1,edmf_qt1,        &
-!               & edmf_thl1,edmf_ent1,edmf_qc1,    &
-!            ! for the solver 
-!               & s_aw1,s_awthl1,s_awqt1,          &
-!               & s_awqv1,s_awqc1,s_awu1,s_awv1,   &
-!               & s_awqke1,                        &
-!               & qc_bl1D,cldfra_bl1D,             &
-!               & FLAG_QI,FLAG_QC,                 &
-!               & Psig_shcu(i,j)                   &
-!            )
-!
-!          ELSEIF (bl_mynn_edmf == 2) THEN
-!            CALL temf_mf(kts,kte,delt,zw,p1,ex1,  &
-!               &u1,v1,w1,th1,thl,thetav,          &
-!               &sqw,sqv,sqc,qke1,                 &
-!               &ust(i,j),flt,flq,flqv,flqc,       &
-!               &hfx(i,j),qfx(i,j),ts(i,j),        &
-!               &pblh(i,j),rho1,dfh,dx,znt(i,j),ep_2,   &
-!            ! outputs - updraft properties
-!               & edmf_a1,edmf_w1,edmf_qt1,        &
-!               & edmf_thl1,edmf_ent1,edmf_qc1,    &
-!            ! for the solver
-!               & s_aw1,s_awthl1,s_awqt1,          &
-!               & s_awqv1,s_awqc1,                 &
-!               & s_awu1,s_awv1,s_awqke1,          &
-!#if (WRF_CHEM == 1)
-!               & nchem,chem1,s_awchem1,           &
-!#endif
-!               & qc_bl1D,cldfra_bl1D              &
-!               &,FLAG_QI,FLAG_QC                  &
-!               &,Psig_shcu(i,j)                   &
-!             )
-!          ENDIF
+               &edmf_a1,edmf_qc1,bl_mynn_edmf,   &
+               &spp_pbl,rstoch_col)
+
 
 !          IF (bl_mynn_edmf > 0) THEN
 !            !DEBUG
@@ -3815,6 +3850,7 @@ SUBROUTINE mynn_bl_driver(&
                &bl_mynn_edmf_mom)
 
 #if (WRF_CHEM == 1)
+    IF (bl_mynn_mixchem == 1) THEN
           CALL mynn_mix_chem(kts,kte,          &
                levflag,grav_settling,           &
                delt, dz1,                       &
@@ -3831,6 +3867,7 @@ SUBROUTINE mynn_bl_driver(&
                ! mass flux components
                & s_awchem1,                      &
                &bl_mynn_cloudmix)
+    ENDIF
 #endif
 
 !
@@ -3870,10 +3907,43 @@ SUBROUTINE mynn_bl_driver(&
                !IF (PRESENT(qnc) .AND. FLAG_QNC) RQNCBLTEN(i,k,j)=0.
                IF (PRESENT(qni) .AND. FLAG_QNI) RQNIBLTEN(i,k,j)=0.
              ENDIF
+
              IF(icloud_bl > 0)THEN
                !make BL clouds scale aware - may already be done in mym_condensation
                qc_bl(i,k,j)=qc_bl1D(k) !*Psig_shcu(i,j)
                cldfra_bl(i,k,j)=cldfra_bl1D(k) !*Psig_shcu(i,j)
+
+               !DIAGNOSTIC-DECAY FOR SUBGRID-SCALE CLOUDS
+               IF (CLDFRA_BL(i,k,j) > cldfra_bl1D_old(k)) THEN
+                  !KEEP UPDATED CLOUD FRACTION & MIXING RATIO
+               ELSE
+                  !DECAY TIMESCALE FOR CALM CONDITION IS THE EDDY TURNOVER TIMESCALE, BUT FOR
+                  !WINDY CONDITIONS, IT IS THE ADVECTIVE TIMESCALE. USE THE MINIMUM OF THE TWO.
+                  ts_decay = MIN( 1800., 3.*dx/MAX(SQRT(u1(k)**2 + v1(k)**2), 1.0) )
+                  cldfra_bl(i,k,j)= MAX(cldfra_bl1D(k), cldfra_bl1D_old(k)-(0.25*delt/ts_decay))
+                  IF (cldfra_bl(i,k,j) > 0.1) THEN
+                     IF (QC_BL(i,k,j) < 1E-5)QC_BL(i,k,j)= MAX(qc_bl1D_old(k), 1E-5)
+                  ELSE
+                     CLDFRA_BL(i,k,j)= 0.
+                     QC_BL(i,k,j)    = 0.
+                  ENDIF
+               ENDIF
+
+               !Stochastic perturbations to cldfra_bl and qc_bl
+               if (spp_pbl==1) then
+                   cldfra_bl(i,k,j)= cldfra_bl(i,k,j)*(1.0-rstoch_col(k))
+                  IF ((cldfra_bl(i,k,j) > 1.0) .or. (cldfra_bl(i,k,j) < 0.0)) then
+                     cldfra_bl(i,k,j)=MAX(MIN(cldfra_bl(i,k,j),1.0),0.0)
+                  ENDIF
+               ENDIF
+
+               !Reapply checks on cldfra_bl and qc_bl to avoid FPEs in radiation driver
+               ! when these two quantities are multiplied by eachother (they may have changed
+               ! in the MF scheme:
+               IF (icloud_bl > 0) THEN
+                 IF (QC_BL(i,k,j) < 1E-6 .AND. ABS(CLDFRA_BL(i,k,j)) > 0.1)QC_BL(i,k,j)= 1E-6
+                 IF (CLDFRA_BL(i,k,j) < 1E-2)CLDFRA_BL(i,k,j)= 0.
+               ENDIF
              ENDIF
              el_pbl(i,k,j)=el(k)
              qke(i,k,j)=qke1(k)
@@ -3898,33 +3968,22 @@ SUBROUTINE mynn_bl_driver(&
                edmf_thl(i,k,j)=edmf_thl1(k)
                edmf_ent(i,k,j)=edmf_ent1(k)
                edmf_qc(i,k,j)=edmf_qc1(k)
-               !Reapply checks on cldfra_bl and qc_bl to avoid FPEs in radiation driver
-               ! when these two quantities are multiplied by eachother (they may have changed 
-               ! in the MF scheme:
-               IF (QC_BL(i,k,j) < 1E-6 .AND. ABS(CLDFRA_BL(i,k,j)) > 0.1)QC_BL(i,k,j)= 1E-6
-               IF (CLDFRA_BL(i,k,j) < 1E-2)CLDFRA_BL(i,k,j)= 0.
              ENDIF
 
              !***  Begin debug prints
              IF ( wrf_at_debug_level(3000) ) THEN
-               IF ( sh(k) < 0. .OR. sh(k)> 200. .OR. &
-                 & qke(i,k,j) < -1. .OR. qke(i,k,j)> 200. .OR. &
-                 & el_pbl(i,k,j) < 0. .OR. el_pbl(i,k,j)> 2000. .OR. &
-                 & ABS(vt(k)) > 0.8 .OR. ABS(vq(k)) > 3000. .OR. &
-                 & exch_m(i,k,j) < 0. .OR. exch_m(i,k,j)> 2000. .OR. &
-                 & vdfg(i,j) < 0. .OR. vdfg(i,j)>5. .OR. &
-                 & ABS(HFX(i,j))>1000. .OR. ABS(QFX(i,j))>.001) THEN
-                  PRINT*,"**SUSPICIOUS VALUES AT: k=",k," sh=",sh(k)
-                  PRINT*," sqw=",sqw(k)," thl=",thl(k)," k_m=",exch_m(i,k,j)
-                  PRINT*," xland=",xland(i,j)," rmol=",rmol(i,j)," ust=",ust(i,j)
-                  PRINT*," qke=",qke(i,k,j)," el=",el_pbl(i,k,j)," tsq=",tsq(i,k,j)
-                  PRINT*," PBLH=",PBLH(i,j)," u=",u(i,k,j)," v=",v(i,k,j)
-                  PRINT*," vq=",vq(k)," vt=",vt(k)," vdfg=",vdfg(i,j)
-                  PRINT*," hfx=",HFX(i,j)," qfx=",QFX(i,j)
-               ENDIF
+               IF ( sh(k) < 0. .OR. sh(k)> 200.)print*,"**SUSPICIOUS VALUES AT: i,j,k=",i,j,k," sh=",sh(k)
+               IF ( qke(i,k,j) < -1. .OR. qke(i,k,j)> 200.)print*,"**SUSPICIOUS VALUES AT: i,j,k=",i,j,k," qke=",qke(i,k,j)
+               IF ( el_pbl(i,k,j) < 0. .OR. el_pbl(i,k,j)> 2000.)print*,"**SUSPICIOUS VALUES AT: i,j,k=",i,j,k," el_pbl=",el_pbl(i,k,j)
+               IF ( ABS(vt(k)) > 0.8 )print*,"**SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vt=",vt(k)
+               IF ( ABS(vq(k)) > 6000.)print*,"**SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vq=",vq(k) 
+               IF ( exch_m(i,k,j) < 0. .OR. exch_m(i,k,j)> 2000.)print*,"**SUSPICIOUS VALUES AT: i,j,k=",i,j,k," exxch_m=",exch_m(i,k,j)
+               IF ( vdfg(i,j) < 0. .OR. vdfg(i,j)>5. )print*,"**SUSPICIOUS VALUES AT: i,j,k=",i,j,k," vdfg=",vdfg(i,j)
+               IF ( ABS(QFX(i,j))>.001)print*, "**SUSPICIOUS VALUES AT: i,j=",i,j," QFX=",QFX(i,j)
+               IF ( ABS(HFX(i,j))>1000.)print*, "**SUSPICIOUS VALUES AT: i,j=",i,j," HFX=",HFX(i,j)
                IF (icloud_bl > 0) then
                   IF( cldfra_bl(i,k,j) < 0.0 .OR. cldfra_bl(i,k,j)> 1.)THEN
-                  PRINT*,"CLDFRA_BL=",cldfra_bl(i,k,j)," qc_bl=",QC_BL(i,k,j)
+                  PRINT*,"**SUSPICIOUS VALUES: CLDFRA_BL=",cldfra_bl(i,k,j)," qc_bl=",QC_BL(i,k,j)
                   ENDIF
                ENDIF
              ENDIF
@@ -4052,8 +4111,8 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi)
     !LOCAL VARS
     REAL ::  PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv
     REAL :: delt_thv   !delta theta-v; dependent on land/sea point
-    REAL, PARAMETER :: sbl_lim  = 400. !200. !upper limit of stable BL height (m).
-    REAL, PARAMETER :: sbl_damp = 800.!400. !transition length for blending (m).
+    REAL, PARAMETER :: sbl_lim  = 250. !200. !upper limit of stable BL height (m).
+    REAL, PARAMETER :: sbl_damp = 500. !400. !transition length for blending (m).
     INTEGER :: I,J,K,kthv,ktke,kzi,kzi2
 
     !ADD KPBL (kzi) for coupling to some Cu schemes, initialize at k=2                                  
@@ -4061,7 +4120,7 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi)
     kzi = 2
     kzi2= 2
 
-    !FIND MAX TKE AND MIN THETAV IN THE LOWEST 500 M
+    !FIND MAX TKE AND MIN THETAV IN THE LOWEST 250 M
     k = kts+1
     kthv = 1
     ktke = 1
@@ -4135,10 +4194,10 @@ SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea,kzi)
 
     !With TKE advection turned on, the TKE-based PBLH can be very large 
     !in grid points with convective precipitation (> 8 km!),
-    !so an artificial limit is imposed to not let PBLH_TKE xceed 4km.
+    !so an artificial limit is imposed to not let PBLH_TKE exceed the
+    !theta_v-based PBL height +/- 500 m.
     !This has no impact on 98-99% of the domain, but is the simplest patch
     !that adequately addresses these extremely large PBLHs.
-    !PBLH_TKE = MIN(PBLH_TKE,4000.)
     PBLH_TKE = MIN(PBLH_TKE,zi+500.)
     PBLH_TKE = MAX(PBLH_TKE,MAX(zi-500.,10.))
 
@@ -4165,13 +4224,15 @@ END SUBROUTINE GET_PBLH
 !  4) some extra limits for numerical stability
 ! This scheme remains under development, so consider it experimental code. 
 !
-  SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
+  SUBROUTINE StEM_mf(                       &
+                 & kts,kte,dt,zw,dz,p,      &
                  & momentum_opt,            &
                  & tke_opt,                 &
                  & u,v,w,th,thl,thv,tk,     &
                  & qt,qv,qc,qke,            &
+                 & exner,vt,vq,sgm,         &
                  & ust,flt,flq,flqv,flqc,   &
-                 & pblh,DX,landsea,         &
+                 & pblh,kpbl,DX,landsea,ts, &
             ! outputs - tendencies
             !  &dth,dqv,dqc,du,dv,&
             ! outputs - updraft properties   
@@ -4182,25 +4243,37 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
                  & s_aw,s_awthl,s_awqt,     &
                  & s_awqv,s_awqc,           &
                  & s_awu,s_awv,s_awqke,     &
+#if (WRF_CHEM == 1)
+                 & nchem,chem,s_awchem,      &
+#endif
             ! in/outputs - subgrid scale clouds
                  & qc_bl1d,cldfra_bl1d,     &
             ! inputs - flags for moist arrays
                  &F_QC,F_QI,                &
-                 &Psig_shcu) 
+                 &Psig_shcu,                &
+            ! unputs for stochastic perturbations
+                 &spp_pbl,rstoch_col) 
 
+! Stochastic  
+     INTEGER,  INTENT(IN)          :: spp_pbl
+     REAL, DIMENSION(KTS:KTE)      :: rstoch_col
   ! inputs:
-     INTEGER, INTENT(IN) :: KTS,KTE,momentum_opt,tke_opt
-     REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,THV,P,qke
+     INTEGER, INTENT(IN) :: KTS,KTE,momentum_opt,tke_opt,kpbl
+     REAL,DIMENSION(KTS:KTE), INTENT(IN) :: U,V,W,TH,THL,TK,QT,QV,QC,&
+                                            THV,P,qke,exner,dz
      REAL,DIMENSION(KTS:KTE+1), INTENT(IN) :: ZW  !height at full-sigma
-     REAL, INTENT(IN) :: DT,UST,FLT,FLQ,FLQV,FLQC,PBLH,DX,Psig_shcu,landsea
+     REAL, INTENT(IN) :: DT,UST,FLT,FLQ,FLQV,FLQC,PBLH,&
+                         DX,Psig_shcu,landsea,ts
      LOGICAL, OPTIONAL :: F_QC,F_QI
 
   ! outputs - tendencies
   !   REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: DTH,DQV,DQC,DU,DV
   ! outputs - updraft properties
      REAL,DIMENSION(KTS:KTE), INTENT(OUT) :: edmf_a,edmf_w,        &
-                 & edmf_qt,edmf_thl, edmf_ent,edmf_qc
-
+                      & edmf_qt,edmf_thl, edmf_ent,edmf_qc
+  ! output
+     INTEGER :: nup2,ktop
+     REAL    :: maxmf
   ! outputs - variables needed for solver
      REAL,DIMENSION(KTS:KTE+1) :: s_aw,      & !sum ai*wis_awphi
                                s_awthl,      & !sum ai*wi*phii
@@ -4224,7 +4297,7 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
   ! internal variables
      INTEGER :: K,I,k50
      REAL :: fltv,wstar,qstar,thstar,sigmaW,sigmaQT,sigmaTH,z0,    &
-             pwmin,pwmax,wmin,wmax,wlv,wtv,Psig_w,maxw
+             pwmin,pwmax,wmin,wmax,wlv,wtv,Psig_w,maxw,maxqc,wpbl
      REAL :: B,QTn,THLn,THVn,QCn,Un,Vn,QKEn,Wn2,EntEXP,EntW
 
   ! w parameters
@@ -4239,6 +4312,26 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
          & L0=100.,&
          & ENT0=0.1
 
+  ! Implement ideas from Neggers (2016, JAMES):
+     REAL, PARAMETER :: Atot = 0.1  !0125! Maximum total fractional area of all updrafts
+     REAL, PARAMETER :: lmax = 1000.! diameter of largest plume
+     REAL, PARAMETER :: dl   = 100. ! diff size of each plume - the differential multiplied by the integrand
+     REAL, PARAMETER :: dcut = 1.0  ! max diameter of plume to parameterize relative to dx (km)
+     REAL ::  d            != -2.3 to -1.7  ;=-1.9 in Neggers paper; power law exponent for number density (N=Cl^d).
+          ! Note that changing d to -2.0 makes each size plume equally contribute to the total coverage of all plumes.
+          ! Note that changing d to -1.7 doubles the area coverage of the largest plumes relative to the smallest plumes.
+     REAL :: cn,c,l,n,an2,hux,maxwidth,wspd_pbl,cloud_base,width_flx
+
+#if (WRF_CHEM == 1)
+     INTEGER, INTENT(IN) :: nchem
+     REAL,DIMENSION(kts:kte, nchem) :: chem
+     REAL,DIMENSION(kts:kte+1, nchem) :: s_awchem
+     REAL,DIMENSION(nchem) :: chemn
+     REAL,DIMENSION(KTS:KTE+1,1:NUP, nchem) :: UPCHEM
+     INTEGER :: ic
+     REAL,DIMENSION(KTS:KTE+1, nchem) :: edmf_chem
+#endif
+
   !JOE: add declaration of ERF
    REAL :: ERF
 
@@ -4252,11 +4345,17 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
    REAL :: satvp,rhgrid,h2oliq
    LOGICAL :: superadiabatic
 
-  ! VARIABLES FOR CHABOUREAU-BECHTOLD
-   REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,diffqt
+  ! VARIABLES FOR CHABOUREAU-BECHTOLD CLOUD FRACTION
+   REAL,DIMENSION(KTS:KTE), INTENT(INOUT) :: vt, vq, sgm
+   REAL :: sigq,xl,tlk,qsat_tl,rsl,cpm,a,qmq,mf_cf,diffqt,&
+           Fng,qww,alpha,beta,bb,f,pt,t,q2p,b9
 
    ! WA TEST 11/9/15 for consistent reduction of updraft params
-   REAL :: csigma,flt2,flq2,fltv2
+   REAL :: csigma,acfac
+
+   !JOE- plume overshoot
+   INTEGER :: overshoot
+   REAL :: bvf, Frz
 
 ! check the inputs
 !     print *,'dt',dt
@@ -4270,6 +4369,7 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
 !     print *,'flq',flq
 !     print *,'pblh',pblh
 
+! Initialize individual updraft properties
   UPW=0.
   UPTHL=0.
   UPTHV=0.
@@ -4280,17 +4380,53 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
   UPQC=0.
   UPQV=0.
   UPQKE=0.
-  ENT=0.
+#if (WRF_CHEM == 1)
+  UPCHEM(KTS:KTE+1,1:NUP,1:nchem)=0.0
+#endif
+  ENT=0.001
+! Initialize mean updraft properties
+  edmf_a  =0.
+  edmf_w  =0.
+  edmf_qt =0.
+  edmf_thl=0.
+  edmf_ent=0.
+  edmf_qc =0.
+#if (WRF_CHEM == 1)
+  edmf_chem(kts:kte+1,1:nchem) = 0.0
+#endif
+! Initialize the variables needed for implicit solver
+  s_aw=0.
+  s_awthl=0.
+  s_awqt=0.
+  s_awqv=0.
+  s_awqc=0.
+  s_awu=0.
+  s_awv=0.
+  s_awqke=0.
+#if (WRF_CHEM == 1)
+  s_awchem(kts:kte+1,1:nchem) = 0.0
+#endif
+
 
   !taper off MF scheme when significant resolved-scale motions are present
   !This function needs to be asymetric...
   k      = 1
   maxw   = 0.0
+  cloud_base  = 9000.0
   DO WHILE (ZW(k) < pblh + 500.)
-     maxw = MAX(maxw,ABS(W(k)))
-     !JOE-find highest k-level below 50m AGL                                                                                    
+     wpbl = w(k)
+     IF(w(k) < 0.)wpbl = 2.*w(k)
+     maxw = MAX(maxw,ABS(wpbl))
+
+     !Find highest k-level below 50m AGL
      IF(ZW(k)<=50.)k50=k
-     k = k+1
+
+     !Search for cloud base
+     IF(qc(k)>1E-5 .AND. cloud_base == 9000.0)THEN
+       cloud_base = 0.5*(ZW(k)+ZW(k+1))
+     ENDIF
+
+     k = k + 1
   ENDDO
   !print*," maxw before manipulation=", maxw
   maxw = MAX(0.,maxw - 0.5)         ! do nothing for small w, but
@@ -4298,67 +4434,123 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
   Psig_w = MIN(Psig_w, Psig_shcu)
   !print*," maxw=", maxw," Psig_w=",Psig_w," Psig_shcu=",Psig_shcu
 
-  flt2 = flt !*0.0 !reserve some for ED or set to zero to remove excess
-  flq2 = flq !*0.0 !reserve some for ED or set to zero to remove excess
   fltv = flt + svp1*flq
-  fltv2 = flt2 + svp1*flq2
   !PRINT*," fltv=",fltv," zi=",pblh 
 
   !Completely shut off MF scheme for strong resolved-scale vertical velocities.
-  IF(Psig_w == 0.0 .and. fltv > 0.0) fltv = -1.*fltv 
+  IF(Psig_w == 0.0 .and. fltv > 0.0) fltv = -1.*fltv
 
-! if surface buoyancy is positive we do integration otherwise not, and make sure that 
+! if surface buoyancy is positive we do integration, otherwise not, and make sure that 
 ! PBLH > twice the height of the surface layer (set at z0 = 50m)
 ! Also, ensure that it is at least slightly superadiabatic up through 50 m
   superadiabatic = .false.
+  IF((landsea-1.5).GE.0)THEN
+     hux = -0.002   ! WATER  ! dT/dz must be < - 0.2 K per 100 m.
+  ELSE
+     hux = -0.005  ! LAND    ! dT/dz must be < - 0.5 K per 100 m.
+  ENDIF
   DO k=1,MAX(1,k50-1)
-    IF (th(k+1)-th(k) < 0.) THEN
-       superadiabatic = .true.
+    IF (k == 1) then
+      IF ((th(k)-ts)/(0.5*dz(k)) < hux) THEN
+        superadiabatic = .true.
+      ELSE
+        superadiabatic = .false.
+        exit
+      ENDIF
     ELSE
-       superadiabatic = .false.
-       exit
+      IF ((th(k)-th(k-1))/(0.5*(dz(k)+dz(k-1))) < hux) THEN
+        superadiabatic = .true.
+      ELSE
+        superadiabatic = .false.
+        exit
+      ENDIF
     ENDIF
   ENDDO
 
-  IF ( fltv > 0.002 .AND. PBLH > 100. .AND. superadiabatic) then
+  ! Determine the numer of updrafts/plumes in the grid column:
+  ! Some of these criteria may be a little redundant but useful for bullet-proofing.
+  !   (1) largest plume = 0.75 * dx.
+  !   (2) Apply a scale-break, assuming no plumes with diameter larger than PBLH can exist.
+  !   (3) max plume size beneath clouds deck approx = 0.5 * cloud_base.
+  !   (4) add shear-dependent limit, when plume model breaks down.
+  !   (5) land-only limit to reduce plume sizes in weakly forced conditions
+  ! Criteria (1)
+  NUP2 = max(1,min(NUP,INT(dx*dcut/dl)))
+  ! Criteria (2) and (4)
+  wspd_pbl=SQRT(MAX(u(kpbl)**2 + v(kpbl)**2, 0.01))
+  maxwidth = 0.9*PBLH - MIN(15.*MAX(wspd_pbl - 7.5, 0.), 0.3*PBLH)
+  ! Criteria (3)
+  maxwidth = MIN(maxwidth,0.5*cloud_base)
+  ! Criteria (5)
+  IF((landsea-1.5).LT.0)THEN
+    IF (cloud_base .LT. 2000.) THEN
+      width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.120)/0.03) + .5),1000.), 0.)
+    ELSE
+      width_flx = MAX(MIN(1000.*(0.6*tanh((flt - 0.085)/0.04) + .5),1000.), 0.)
+    ENDIF
+    maxwidth = MIN(maxwidth,width_flx)
+  ENDIF
+  ! Convert maxwidth to number of plumes
+  NUP2 = MIN(MAX(INT((maxwidth - MOD(maxwidth,100.))/100), 0), NUP2)
+
+  !Initialize values:
+  ktop = 0
+  maxmf= 0.0
+
+  IF ( fltv > 0.002 .AND. NUP2 .GE. 1 .AND. superadiabatic) then
     !PRINT*," Conditions met to run mass-flux scheme",fltv,pblh
+
+    ! Find coef C for number size density N
+    cn = 0.
+    d=-1.9  !set d to value suggested by Neggers 2015 (JAMES).
+    !d=-1.9 + .2*tanh((fltv - 0.05)/0.15) 
+    do I=1,NUP2
+       l  = dl*I                            ! diameter of plume
+       cn = cn + l**d * (l*l)/(dx*dx) * dl  ! sum fractional area of each plume
+    enddo
+    C = Atot/cn   !Normalize C according to the defined total fraction (Atot)
+
+    ! Find the portion of the total fraction (Atot) of each plume size:
+    An2 = 0.
+    do I=1,NUP2
+       l  = dl*I                            ! diameter of plume
+       N = C*l**d                           ! number density of plume n
+       UPA(1,I) = N*l*l/(dx*dx) * dl        ! fractional area of plume n
+       ! Make updraft area (UPA) a function of the buoyancy flux
+!       acfac = .5*tanh((fltv - 0.05)/0.2) + .5
+       acfac = .5*tanh((fltv - 0.07)/0.09) + .5 
+       UPA(1,I)=UPA(1,I)*acfac
+       An2 = An2 + UPA(1,I)                 ! total fractional area of all plumes
+       !print*," plume size=",l,"; area=",An,"; total=",An2
+    end do
+
     ! get entrainment coefficient
     ! get dz/L0
-    ENTf(kts:kte,1:Nup)=0.1
-    ENTi(kts:kte,1:Nup)=0.1
-    do i=1,Nup
-      do k=kts+1,kte
-        ENTf(k,i)=(ZW(k)-ZW(k-1))/L0    ! input into Poisson
-        ENTf(k,i)=MIN(ENTf(k,i),9.9) !JOE: test avoiding FPE
-        ENTf(k,i)=MAX(ENTf(k,i),0.05) !JOE: test avoiding FPE
-      enddo
-    enddo
+    !ENTf(kts:kte,1:Nup)=0.1
+    !ENTi(kts:kte,1:Nup)=0.1
+    !ENT(kts:kte,1:Nup)=0.001
+    !do i=1,Nup2
+    !  do k=kts+1,kte
+    !    ENTf(k,i)=(ZW(k)-ZW(k-1))/L0    ! input into Poisson
+    !    ENTf(k,i)=MIN(ENTf(k,i),9.9) !JOE: test avoiding FPE
+    !    ENTf(k,i)=MAX(ENTf(k,i),0.05) !JOE: test avoiding FPE
+    !  enddo
+    !enddo
     ! get Poisson P(dz/L0)
-    call Poisson(1,Nup,kts+1,kte,ENTf,ENTi)
+    !call Poisson(1,Nup2,kts+1,kte,ENTf,ENTi)
     ! entrainent: Ent=Ent0/dz*P(dz/L0)             
-    do i=1,Nup   
-      do k=kts+1,kte
-        ENT(k,i)=real(ENTi(k,i))*Ent0/(ZW(k)-ZW(k-1))  !eq (13) in Suselj et al. (2013, jas)
-        ! WA TEST 11/12/15 Add some small deterministic background entrainment
-        ENT(k,i) = max(ENT(k,i),0.0002)
-        ! JOE - increase updraft entrainment near surface
-        ENT(k,i) = max(ENT(k,i),0.3/ZW(k))
-      enddo
-    enddo
 
-!    print *,'Entrainment:',ENT   
-       
     ! set initial conditions for updrafts
     z0=50.
-    pwmin=0.5
-    pwmax=2.0 !1.5  ! was 3.0
+    pwmin=0.1       ! was 0.5
+    pwmax=0.5       ! was 3.0
 
     wstar=max(1.E-2,(g/thv(1)*fltv*pblh)**(1./3.))
-    qstar=flq2/wstar
-    thstar=flt2/wstar
+    qstar=max(flq,1.0E-5)/wstar
+    thstar=flt/wstar
 
     IF((landsea-1.5).GE.0)THEN
-       csigma = 0.0    ! WATER
+       csigma = 1.34   ! WATER
     ELSE
        csigma = 1.34   ! LAND
     ENDIF
@@ -4369,21 +4561,22 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
     wmin=sigmaW*pwmin
     wmax=sigmaW*pwmax
 
+    !recompute acfac for plume excess
+    acfac = .5*tanh((fltv - 0.08)/0.07) + .5
+
     !SPECIFY SURFACE UPDRAFT PROPERTIES
-    DO I=1,NUP
-       wlv=wmin+(wmax-wmin)/NUP*(i-1)
-       wtv=wmin+(wmax-wmin)/NUP*i
+    DO I=1,NUP2
+       wlv=wmin+(wmax-wmin)/NUP2*(i-1)
+       wtv=wmin+(wmax-wmin)/NUP2*i
 
        !SURFACE UPDRAFT VERTICAL VELOCITY
-       UPW(1,I)=0.5*(wlv+wtv)
+       !UPW(1,I)=0.5*(wlv+wtv)
+       UPW(1,I)=wmin + REAL(i)/REAL(NUP)*(wmax-wmin)
        !IF (UPW(1,I) > 0.5*ZW(2)/dt) UPW(1,I) = 0.5*ZW(2)/dt
 
        !SURFACE UPDRAFT AREA
        !UPA(1,I)=0.5*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.5*ERF(wlv/(sqrt(2.)*sigmaW))
-       !UPA(1,I)=0.4*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.4*ERF(wlv/(sqrt(2.)*sigmaW))  !19.6
-       !UPA(1,I)=0.3*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.3*ERF(wlv/(sqrt(2.)*sigmaW))  !14.6
        !UPA(1,I)=0.25*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.25*ERF(wlv/(sqrt(2.)*sigmaW))  !12.0
-       UPA(1,I)=0.2*ERF(wtv/(sqrt(2.)*sigmaW)) - 0.2*ERF(wlv/(sqrt(2.)*sigmaW))   !9.6
 
        UPU(1,I)=U(1)
        UPV(1,I)=V(1)
@@ -4392,18 +4585,24 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
        !UPTHV(1,I)=THV(1)+0.58*UPW(1,I)*sigmaTH/sigmaW
        !Alternatively, initialize parcel over lowest 50m
        UPQT(1,I) = 0.
+       UPTHV(1,I)= 0.
        UPTHL(1,I)= 0.
        k50=1 !for now, keep at lowest model layer...
        DO k=1,k50
-         UPQT(1,I) = UPQT(1,I) +QT(k) +0.58*UPW(1,I)*sigmaQT/sigmaW !*EXP(-ZW(k)/100.)
-         UPTHV(1,I)= UPTHV(1,I)+THV(k)+0.58*UPW(1,I)*sigmaTH/sigmaW !*EXP(-ZW(k)/100.)
-         !UPQT(1,I) = UPQT(1,I) +QT(k) +1.*UPW(1,I)*sigmaQT/sigmaW
-         !UPTHV(1,I)= UPTHV(1,I)+THV(k)+1.*UPW(1,I)*sigmaTH/sigmaW
+         UPQT(1,I) = UPQT(1,I) +QT(k) +0.58*UPW(1,I)*sigmaQT/sigmaW *acfac
+         UPTHV(1,I)= UPTHV(1,I)+THV(k)+0.58*UPW(1,I)*sigmaTH/sigmaW *acfac
+         UPTHL(1,I)= UPTHL(1,I)+THL(k)+0.58*UPW(1,I)*sigmaTH/sigmaW *acfac
        ENDDO
        UPQT(1,I) = UPQT(1,I)/REAL(k50)
        UPTHV(1,I)= UPTHV(1,I)/REAL(k50)
-       UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I))
+!was       UPTHL(1,I)= UPTHV(1,I)/(1.+svp1*UPQT(1,I))  !assume no saturated parcel at surface
+       UPTHL(1,I)= UPTHL(1,I)/REAL(k50)             ! now, if the lowest layer is saturated, it will be counted for.
        UPQKE(1,I)= QKE(1)
+#if (WRF_CHEM == 1)
+       do ic = 1,nchem
+          UPCHEM(1,I,ic)= CHEM(1,ic)
+       enddo
+#endif
 
 !       !DEBUG
 !       IF (UPA(1,I)<0. .OR. UPA(1,I)>0.5 .OR. wstar<0. .OR. wstar>4.0 .OR. &
@@ -4412,26 +4611,53 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
 !          PRINT*," wstar=",wstar," qstar=",qstar
 !          PRINT*," thstar=",thstar," sigmaW=",sigmaW
 !       ENDIF
+
     ENDDO
 
   !QCn = 0.
   ! do integration  updraft
-    DO I=1,NUP
+    DO I=1,NUP2
        QCn = 0.
+       overshoot = 0
+       l  = dl*I                            ! diameter of plume
        DO k=KTS+1,KTE
 
-          !JOE - increase background entrainment within clouds
-          !if(QCn > 1.e-8)ENT(k,i) = max(ENT(k,i),0.0004)
-          !JOE - use constant ent in dry plumes in the PBL
-          IF(QCn < 1.e-8 .AND. ZW(k) < pblh) ENT(k,i) = max(0.0009,0.3/ZW(k))
-
-          EntExp=exp(-ENT(K,I)*(ZW(k)-ZW(k-1)))
+          !w-dependency for entrainment a la Tian and Kuang (2016)
+          ENT(k,i) = 0.75/(MIN(MAX(UPW(K-1,I),0.75),1.25)*l)
+          !Entrainment from Negggers (2015, JAMES)
+          !ENT(k,i) = 0.02*l**-0.35 - 0.0009
+          !JOE - implement minimum background entrainment 
+          ENT(k,i) = max(ENT(k,i),0.0006)
+          ENT(k,i) = max(ENT(k,i),0.05/ZW(k))
+          !JOE - increase entrainment for plumes extending very high.
+          IF(ZW(k) >= pblh+1000.) ENT(k,i) =ENT(k,i) + (ZW(k)-(pblh+1000.)) * 5.0E-6
+          IF(UPW(K-1,I) > 1.5) ENT(k,i) = ENT(k,i) + 0.004*(UPW(K-1,I) - 1.5)
+          ENT(k,i) = min(ENT(k,i),0.9/(ZW(k)-ZW(k-1)))
+
+          ! Linear entrainment:
+          EntExp= ENT(K,I)*(ZW(k)-ZW(k-1))
+          QTn =UPQT(k-1,I) *(1.-EntExp) + QT(k-1)*EntExp
+          THLn=UPTHL(k-1,I)*(1.-EntExp) + THL(k-1)*EntExp
+          Un  =UPU(k-1,I)  *(1.-EntExp) + U(k-1)*EntExp
+          Vn  =UPV(k-1,I)  *(1.-EntExp) + V(k-1)*EntExp
+          QKEn=UPQKE(k-1,I)*(1.-EntExp) + QKE(k-1)*EntExp
+
+          ! Exponential Entrainment:
+          !EntExp= exp(-ENT(K,I)*(ZW(k)-ZW(k-1)))
+          !QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp
+          !THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp
+          !Un  =U(K)  *(1-EntExp)+UPU(K-1,I)*EntExp
+          !Vn  =V(K)  *(1-EntExp)+UPV(K-1,I)*EntExp
+          !QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp
 
-          QTn =QT(K) *(1-EntExp)+UPQT(K-1,I)*EntExp
-          THLn=THL(K)*(1-EntExp)+UPTHL(K-1,I)*EntExp
-          Un  =U(K)  *(1-EntExp)+UPU(K-1,I)*EntExp
-          Vn  =V(K)  *(1-EntExp)+UPV(K-1,I)*EntExp
-          QKEn=QKE(k)*(1-EntExp)+UPQKE(K-1,I)*EntExp
+#if (WRF_CHEM == 1)
+          do ic = 1,nchem
+             ! Exponential Entrainment:
+             !chemn(ic) = chem(k,ic)*(1-EntExp)+UPCHEM(K-1,I,ic)*EntExp
+             ! Linear entrainment:
+             chemn(ic)=UPCHEM(k-1,I,ic)*(1.-EntExp) + chem(k-1,ic)*EntExp
+         enddo
+#endif
 
           ! get thvn,qcn
           call condensation_edmf(QTn,THLn,(P(K)+P(K-1))/2.,ZW(k),THVn,QCn)
@@ -4440,13 +4666,33 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
 
           EntW=exp(-2.*(Wb+Wc*ENT(K,I))*(ZW(k)-ZW(k-1)))
           Wn2=UPW(K-1,I)**2*EntW + (1.-EntW)*0.5*Wa*B/(Wb+Wc*ENT(K,I))
+          Wn2=MAX(Wn2,0.0)
+
+          !Allow strongly forced plumes to overshoot if KE is sufficient
+          IF (fltv > 0.05 .AND. Wn2 <= 0 .AND. overshoot == 0) THEN
+             overshoot = 1
+             IF ( THV(k)-THV(k-1) .GT. 0.0 ) THEN
+                bvf = SQRT( gtr*(THV(k)-THV(k-1))/(0.5*(dz(k)+dz(k-1))) )
+                !vertical Froude number
+                Frz = UPW(K-1,I)/(bvf*0.5*(dz(k)+dz(k-1)))
+                IF ( Frz >= 0.5 ) Wn2 =  MIN(Frz,1.0)*(UPW(K-1,I)**2) 
+             ENDIF
+          ELSEIF (fltv > 0.05 .AND. overshoot == 1) THEN
+             !Do not let overshooting parcel go more than 1 layer up
+             Wn2 = 0.0
+          ENDIF
 
-          Wn2=Wn2*EXP(-MAX(ZW(k)-(pblh+3000.),0.0)/1000.)
-          IF(ZW(k) >= pblh+4000.)Wn2=0.
+          !Limit very tall plumes
+          Wn2=Wn2*EXP(-MAX(ZW(k)-(pblh+1500.),0.0)/1000.)
+          IF(ZW(k) >= pblh+3000.)Wn2=0.
+ 
+          !JOE- minimize the plume penetratration in stratocu-topped PBL
+          IF (fltv < 0.06) THEN
+             IF(ZW(k) >= pblh-200. .AND. qc(k) > 1e-5 .AND. I > 2) Wn2=0.
+          ENDIF
 
           IF (Wn2 > 0.) THEN
              UPW(K,I)=sqrt(Wn2)
-             !IF (UPW(K,I) > 0.5*(ZW(K)-ZW(K-1))/dt) UPW(K,I) = 0.5*(ZW(K)-ZW(K-1))/dt
              UPTHV(K,I)=THVn
              UPTHL(K,I)=THLn
              UPQT(K,I)=QTn
@@ -4455,91 +4701,96 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
              UPV(K,I)=Vn
              UPQKE(K,I)=QKEn
              UPA(K,I)=UPA(K-1,I)
+#if (WRF_CHEM == 1)
+             do ic = 1,nchem
+                UPCHEM(k,I,ic) = chemn(ic)
+             enddo
+#endif
+             ktop = MAX(ktop,k)
           ELSE
              exit
           END IF
        ENDDO
-    ENDDO  
-       
-  END IF 
+    ENDDO
+  ELSE
+    !At least one of the conditions was not met for activating the MF scheme.
+    NUP2=0. 
+  END IF !end criteria for mass-flux scheme
+
+  ktop=MIN(ktop,KTE-1)  !  Just to be safe...
 !        
 !  get updraft properties, for saving
 !
-  edmf_a  =0.
-  edmf_w  =0.
-  edmf_qt =0.
-  edmf_thl=0.
-  edmf_ent=0.
-  edmf_qc =0.
+  IF(nup2 > 0) THEN
 
-  ! writing updraft properties in their variable
-  ! all variables, except Areas are now multipled by the area  
-  ! to confirm with WRF grid setup we do not save the first and the last row   
-
-  DO k=KTS,KTE-1
-    DO I=1,NUP
-       edmf_a(K)=edmf_a(K)+UPA(K+1,I)
-       edmf_w(K)=edmf_w(K)+UPA(K+1,I)*UPW(K+1,I)
-       edmf_qt(K)=edmf_qt(K)+UPA(K+1,I)*UPQT(K+1,I)
-       edmf_thl(K)=edmf_thl(K)+UPA(K+1,I)*UPTHL(K+1,I)
-       edmf_ent(K)=edmf_ent(K)+UPA(K+1,I)*ENT(K+1,I)
-       edmf_qc(K)=edmf_qc(K)+UPA(K+1,I)*UPQC(K+1,I)
-    ENDDO 
-
-    IF (edmf_a(k)>0.) THEN
-       edmf_w(k)=edmf_w(k)/edmf_a(k)*Psig_w
-       edmf_qt(k)=edmf_qt(k)/edmf_a(k)*Psig_w
-       edmf_thl(k)=edmf_thl(k)/edmf_a(k)*Psig_w
-       edmf_ent(k)=edmf_ent(k)/edmf_a(k)*Psig_w
-       edmf_qc(k)=edmf_qc(k)/edmf_a(k)*Psig_w
-    ENDIF
-  ENDDO
+    DO k=KTS,ktop !KTE-1
+      DO I=1,NUP2
+        edmf_a(K)=edmf_a(K)+UPA(K+1,I)
+        edmf_w(K)=edmf_w(K)+UPA(K+1,I)*UPW(K+1,I)
+        edmf_qt(K)=edmf_qt(K)+UPA(K+1,I)*UPQT(K+1,I)
+        edmf_thl(K)=edmf_thl(K)+UPA(K+1,I)*UPTHL(K+1,I)
+        edmf_ent(K)=edmf_ent(K)+UPA(K+1,I)*ENT(K+1,I)
+        edmf_qc(K)=edmf_qc(K)+UPA(K+1,I)*UPQC(K+1,I)
+#if (WRF_CHEM == 1)
+        do ic = 1,nchem
+          edmf_chem(k,ic) = edmf_chem(k,ic) + UPA(K+1,I)*UPCHEM(k,I,ic)
+        enddo
+#endif
+      ENDDO 
+
+      IF (edmf_a(k)>0.) THEN
+        edmf_w(k)=edmf_w(k)/edmf_a(k)
+        edmf_qt(k)=edmf_qt(k)/edmf_a(k)
+        edmf_thl(k)=edmf_thl(k)/edmf_a(k)
+        edmf_ent(k)=edmf_ent(k)/edmf_a(k)
+        edmf_qc(k)=edmf_qc(k)/edmf_a(k)
+#if (WRF_CHEM == 1)
+        do ic = 1,nchem
+          edmf_chem(k,ic) = edmf_chem(k,ic)/edmf_a(k)
+        enddo
+#endif
+        edmf_a(k)=edmf_a(k)*Psig_w
 
-  !
-  ! computing variables needed for implicit solver
-  !
-  s_aw=0.
-  s_awthl=0.
-  s_awqt=0.
-  s_awqv=0.
-  s_awqc=0.
-  s_awu=0.
-  s_awv=0.
-  s_awqke=0.
+        !FIND MAXIMUM MASS-FLUX IN THE COLUMN:
+        IF(edmf_a(k)*edmf_w(k) > maxmf) maxmf = edmf_a(k)*edmf_w(k)
+      ENDIF
+    ENDDO
 
-  DO k=KTS,KTE+1
-     DO I=1,NUP
-       s_aw(k)   = s_aw(K)    + UPA(K,I)*UPW(K,I)*Psig_w
-       s_awthl(k)= s_awthl(K) + UPA(K,i)*UPW(K,I)*UPTHL(K,I)*Psig_w
-       s_awqt(k) = s_awqt(K)  + UPA(K,i)*UPW(K,I)*UPQT(K,I)*Psig_w
-       s_awqc(k) = s_awqc(K)  + UPA(K,i)*UPW(K,I)*UPQC(K,I)*Psig_w
-       IF (momentum_opt > 0) THEN
-         s_awu(k)  = s_awu(K)   + UPA(K,i)*UPW(K,I)*UPU(K,I)*Psig_w
-         s_awv(k)  = s_awv(K)   + UPA(K,i)*UPW(K,I)*UPV(K,I)*Psig_w
-       ENDIF
-       IF (tke_opt > 0) THEN
-         s_awqke(k)= s_awqke(K) + UPA(K,i)*UPW(K,I)*UPQKE(K,I)*Psig_w
-       ENDIF
-     ENDDO
-     s_awqv(k) = s_awqt(k)  - s_awqc(k)
-  ENDDO
+    DO k=KTS,ktop !KTE
+      DO I=1,NUP2
+        s_aw(k)   = s_aw(K)    + UPA(K,I)*UPW(K,I)*Psig_w * (1.0+rstoch_col(k))
+        s_awthl(k)= s_awthl(K) + UPA(K,i)*UPW(K,I)*UPTHL(K,I)*Psig_w * (1.0+rstoch_col(k))
+        s_awqt(k) = s_awqt(K)  + UPA(K,i)*UPW(K,I)*UPQT(K,I)*Psig_w * (1.0+rstoch_col(k))
+        s_awqc(k) = s_awqc(K)  + UPA(K,i)*UPW(K,I)*UPQC(K,I)*Psig_w * (1.0+rstoch_col(k))
+        IF (momentum_opt > 0) THEN
+          s_awu(k)  = s_awu(K)   + UPA(K,i)*UPW(K,I)*UPU(K,I)*Psig_w * (1.0+rstoch_col(k))
+          s_awv(k)  = s_awv(K)   + UPA(K,i)*UPW(K,I)*UPV(K,I)*Psig_w * (1.0+rstoch_col(k))
+        ENDIF
+        IF (tke_opt > 0) THEN
+          s_awqke(k)= s_awqke(K) + UPA(K,i)*UPW(K,I)*UPQKE(K,I)*Psig_w * (1.0+rstoch_col(k))
+        ENDIF
+#if (WRF_CHEM == 1)
+        do ic = 1,nchem
+          s_awchem(k,ic) = s_awchem(k,ic) + UPA(K,i)*UPW(K,I)*UPCHEM(K,I,ic)*Psig_w * (1.0+rstoch_col(k))
+        enddo
+#endif
+      ENDDO
+      s_awqv(k) = s_awqt(k)  - s_awqc(k)
+    ENDDO
 
-!JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined above.
-!     Here, a shallow-cu component is added (or max is used).  
-   DO K=KTS,KTE
-!     qc_bl1d(k)=0.
-!     cldfra_bl1d(k)=0.
+!JOE: ADD CLDFRA_bl1d, qc_bl1d. Note that they have already been defined in
+!     mym_condensation. Here, a shallow-cu component is added.  
+     DO K=KTS,ktop !KTE
 
-      IF (cldfra_opt == 0) THEN
+       IF (cldfra_opt == 0) THEN
          IF(edmf_qc(k)>0.0)THEN
-            !Chaboureau and Bechtold (2005, JGR)
-            diffqt=edmf_qt(k)-qt(k)
-            if(ABS(diffqt) < 1.0E-6)diffqt = 1.0E-6
-            !sigq = MAX(edmf_a(k)*(1.-edmf_a(k))*diffqt**2 , 1.0e-8)
-            sigq = MAX(edmf_a(k)*diffqt**2 , 1.0e-8)
-            sigq = sqrt(sigq)
-
-            xl = xl_blend(tk(k))                ! obtain blended heat capacity
+            satvp = 3.80*exp(17.27*(th(k)-273.)/ &
+                   (th(k)-36.))/(.01*p(k))
+            rhgrid = max(.01,MIN( 1., qv(k) /satvp))
+
+            !COMPUTE CLDFRA & QC_BL FROM MASS-FLUX SCHEME and recompute vt & vq
+
+            xl = xl_blend(tk(k))                ! obtain blended heat capacity 
             tlk = thl(k)*(p(k)/p1000mb)**rcp    ! recover liquid temp (tl) from thl
             qsat_tl = qsat_blend(tlk,p(k))      ! get saturation water vapor mixing ratio
                                                 !   at tl and p
@@ -4547,6 +4798,32 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
                                                 ! CB02, Eqn. 4
             cpm = cp + qt(k)*cpv                ! CB02, sec. 2, para. 1
             a   = 1./(1. + xl*rsl/cpm)          ! CB02 variable "a"
+            b9  = a*rsl                         ! CB02 variable "b" 
+
+            q2p  = xlvcp/exner(k)
+            pt = thl(k) +q2p*edmf_qc(k) ! potential temp
+            bb = b9*tk(k)/pt ! bb is "b9" in BCMT95.  Their "b9" differs from
+                           ! "b9" in CB02 by a factor
+                           ! of T/theta.  Strictly, b9 above is formulated in
+                           ! terms of sat. mixing ratio, but bb in BCMT95 is
+                           ! cast in terms of sat. specific humidity.  The
+                           ! conversion is neglected here.
+            qww   = 1.+0.61*qt(k)
+            alpha = 0.61*pt
+            t     = th(k)*exner(k)
+            beta  = pt*xl/(t*cp) - 1.61*pt
+            !Buoyancy flux terms have been moved to the end of this section...
+
+            !Now calculate convective component of the cloud fraction:
+            if (a > 0.0) then
+               f = MIN(1.0/a, 4.0)              ! f is vertical profile scaling function (CB2005)
+            else
+               f = 1.0
+            endif
+            sigq = 6.E-3 * edmf_a(k) * edmf_w(k) * f ! convective component of sigma (CB2005)
+            !sigq = MAX(sigq, 1.0E-4)         
+            sigq = SQRT(sigq**2 + sgm(k)**2)    ! combined conv + stratus components
+
             qmq = a * (qt(k) - qsat_tl)         ! saturation deficit/excess;
                                                 !   the numerator of Q1
             mf_cf = min(max(0.5 + 0.36 * atan(1.55*(qmq/sigq)),0.01),1.0)
@@ -4556,39 +4833,64 @@ SUBROUTINE StEM_mf(kts,kte,dt,zw,p,       &
             !   print*,"  CB: sigq=",sigq," qmq=",qmq," tlk=",tlk
             !   print*,"  CB: mf_cf=",mf_cf," cldfra_bl=",cldfra_bl1d(k)," edmf_a=",edmf_a(k)
             !ENDIF
-            IF (mf_cf > edmf_a(k)) THEN
-               cldfra_bl1d(k) = mf_cf
-               qc_bl1d(k) = edmf_qc(k)*edmf_a(k)/mf_cf
+            IF (rhgrid >= .93) THEN
+               !IN high RH, defer to stratus component if > convective component
+               cldfra_bl1d(k) = MAX(mf_cf, cldfra_bl1d(k))
+               IF (cldfra_bl1d(k) > edmf_a(k)) THEN
+                  qc_bl1d(k) = edmf_qc(k)*edmf_a(k)/cldfra_bl1d(k)
+               ELSE
+                 cldfra_bl1d(k)=edmf_a(k)
+                 qc_bl1d(k) = edmf_qc(k)
+               ENDIF
             ELSE
-               cldfra_bl1d(k)=edmf_a(k) !MAX(mf_cf,edmf_a(k))
-               qc_bl1d(k) = edmf_qc(k)  !MAX(qc_bl1d(k), edmf_qc(k))
+               IF (mf_cf > edmf_a(k)) THEN
+                  cldfra_bl1d(k) = mf_cf
+                  qc_bl1d(k) = edmf_qc(k)*edmf_a(k)/mf_cf
+               ELSE
+                  cldfra_bl1d(k)=edmf_a(k)
+                  qc_bl1d(k) = edmf_qc(k)
+               ENDIF
             ENDIF
-         ENDIF
-      ELSEIF(cldfra_opt == 1) THEN
-         !Randall and Xu
-         qc_bl1d(k) = MAX(qc_bl1d(k), edmf_qc(k))
-         if(F_qc .and. .not. F_qi)then
-           satvp = 3.80*exp(17.27*(th(k)-273.)/ &
+            !Now recalculate the terms for the buoyancy flux for mass-flux clouds:
+            !See mym_condensation for details on these formulations.  The
+            !cloud-fraction bounding was added to improve cloud retention,
+            !following RAP and HRRR testing.
+              Fng = 2.05 ! the non-Gaussian transport factor (assumed constant)
+            vt(k) = qww   - MIN(0.3,cldfra_bl1D(k))*beta*bb*Fng - 1.
+            vq(k) = alpha + MIN(0.3,cldfra_bl1D(k))*beta*a*Fng  - tv0
+          ENDIF
+        ELSEIF(cldfra_opt == 1) THEN
+          !Randall and Xu
+          qc_bl1d(k) = MAX(qc_bl1d(k), edmf_qc(k))
+          if(F_qc .and. .not. F_qi)then
+            satvp = 3.80*exp(17.27*(th(k)-273.)/ &
                    (th(k)-36.))/(.01*p(k))
-           rhgrid = max(.1,MIN( .95, qv(k) /satvp))
-           h2oliq=1000.*qc_bl1d(k)
-           satvp=1000.*satvp
-           cldfra_bl1d(k)=(1.-exp(-coef_alph*h2oliq/&
+            rhgrid = max(.1,MIN( .95, qv(k) /satvp))
+            h2oliq=1000.*qc_bl1d(k)
+            satvp=1000.*satvp
+            cldfra_bl1d(k)=(1.-exp(-coef_alph*h2oliq/&
                    ((1.-rhgrid)*satvp)**coef_gamm))*(rhgrid**coef_p)
-           cldfra_bl1d(k)=max(0.0,MIN(1.,cldfra_bl1d(k)))
-         elseif(F_qc .and. F_qi)then
-           satvp = 3.80*exp(17.27*(th(k)-273.)/ &
+            cldfra_bl1d(k)=max(0.0,MIN(1.,cldfra_bl1d(k)))
+          elseif(F_qc .and. F_qi)then
+            satvp = 3.80*exp(17.27*(th(k)-273.)/ &
                    (th(k)-36.))/(.01*p(k))
-           rhgrid = max(.1,MIN( .95, qv(k) /satvp))
-           h2oliq=1000.*qc_bl1d(k)
-           satvp=1000.*satvp
-           cldfra_bl1d(k)=(1.-exp(-coef_alph*h2oliq/&
+            rhgrid = max(.1,MIN( .95, qv(k) /satvp))
+            h2oliq=1000.*qc_bl1d(k)
+            satvp=1000.*satvp
+            cldfra_bl1d(k)=(1.-exp(-coef_alph*h2oliq/&
                     ((1.-rhgrid)*satvp)**coef_gamm))*(rhgrid**coef_p)
-           cldfra_bl1d(k)=max(0.0,MIN(1.,cldfra_bl1d(k)))
-         endif
-      ENDIF
-   ENDDO
+            cldfra_bl1d(k)=max(0.0,MIN(1.,cldfra_bl1d(k)))
+          endif
+        ENDIF
+      ENDDO
 
+    ENDIF  !end nup2 > 0
+
+    !modify output (negative: dry plume, positive: moist plume)
+    IF (ktop > 0) THEN
+      maxqc = maxval(edmf_qc(1:ktop)) 
+      IF ( maxqc < 1.E-8) maxmf = -1.0*maxmf
+    ENDIF
        
 !       
 ! debugging   
@@ -5047,11 +5349,12 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC)
 !
 ! zero or one condensation for edmf: calculates THV and QC
 !
-real,intent(in) :: QT,THL,P,zagl
-real,intent(out):: THV,QC
+real,intent(in)   :: QT,THL,P,zagl
+real,intent(out)  :: THV
+real,intent(inout):: QC
 
 integer :: niter,i
-real :: diff,exn,t,qs,qcold
+real :: diff,exn,t,th,qs,qcold
 
 ! constants used from module_model_constants.F
 ! p1000mb
@@ -5064,20 +5367,19 @@ subroutine condensation_edmf(QT,THL,P,zagl,THV,QC)
 ! number of iterations
   niter=50
 ! minimum difference
-  diff=1.e-4
+  diff=2.e-5
 
   EXN=(P/p1000mb)**rcp
-  QC=0.
-
+  !QC=0.  !better first guess QC is incoming from lower level, do not set to zero
   do i=1,NITER
-     T=EXN*(THL+xlv/cp*QC)
+     T=EXN*THL + xlv/cp*QC        
      QS=qsat_blend(T,P)
      QCOLD=QC
-     QC=max(0.5*QC + 0.5*(QT-QS),0.)
+     QC=0.5*QC + 0.5*MAX((QT-QS),0.)
      if (abs(QC-QCOLD) cldfra_bl1d
 !    au -> moist_a
 
-  SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
+  SUBROUTINE temf_mf(                        &
+                 & kts,kte,dt,zw,p,pi1d,     &
                  & u,v,w,th,thl,thv,qt,qv,qc,&
                  & qke,ust,flt,flq,flqv,flqc,&
                  & hfx,qfx,tsk,              &
@@ -5279,12 +5591,6 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
             ! outputs - updraft properties
                  & edmf_a,edmf_w,edmf_qt,    &
                  & edmf_thl,edmf_ent,edmf_qc,&
-!                 & dry_a,moist_a,           &
-!                 & dry_w,moist_w,           &
-!                 & dry_qt,moist_qt,         &
-!                 & dry_thl,moist_thl,       &
-!                 & dry_ent,moist_ent,       &
-!                 & moist_qc,                &
             ! outputs - variables needed for solver
                  & s_aw,s_awthl,s_awqt,      &
                  & s_awqv,s_awqc,            &
@@ -5295,10 +5601,15 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
             ! in/outputs - subgrid scale clouds
                  & qc_bl1d,cldfra_bl1d,      &
             ! inputs - flags for moist arrays
-                 &F_QC,F_QI,psig)
+                 &F_QC,F_QI,psig,            &
+                 &spp_pbl,rstoch_col,        &
+                 &ii,jj,ids,ide,jds,jde)
 
+  ! Stochastic
+     INTEGER, INTENT(IN)   :: spp_pbl
+     REAL, DIMENSION(kts:kte), INTENT(in)   :: rstoch_col 
   ! inputs:
-     INTEGER, INTENT(IN) :: kts,kte
+     INTEGER, INTENT(IN) :: kts,kte,ii,jj,ids,ide,jds,jde
      REAL,DIMENSION(kts:kte), INTENT(IN) :: u,v,w,th,thl,qt,qv,qc,thv,p,pi1d
      REAL,DIMENSION(kts:kte), INTENT(IN) :: qke
      REAL,DIMENSION(kts:kte+1), INTENT(IN) :: zw  !height at full-sigma
@@ -5371,7 +5682,7 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
    real, dimension( kts:kte, Nupd) :: dUUPDdz, dVUPDdz, dTEUPDdz
    real, dimension( kts:kte, Nupd) :: TUPD, rstUPD, rUPD, rlUPD, qstUPD
    real, dimension( kts:kte, Nupd) :: MUPD, wUPD, qtUPD, thlUPD, qcUPD
-   real, dimension( kts:kte, Nupd) :: aUPD, cldfraUPD
+   real, dimension( kts:kte, Nupd) :: aUPD, cldfraUPD, aUPDt
    real, dimension( kts:kte) :: N2, S, Ri, beta, ftau, fth, ratio
    real, dimension( kts:kte) :: TKE, TE2
    real, dimension( kts:kte) :: ustrtilde, linv, leps
@@ -5385,6 +5696,8 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
    real Cepsmf    ! Prefactor for entrainment rate
    real red_fact  ! for reducing MF components
    real, dimension( kts:kte) :: edmf_u, edmf_v, edmf_qke ! Same format as registry vars, but not passed out
+   integer:: bdy_dist,taper_dist
+   real:: taper
 
 #if (WRF_CHEM == 1)
    real,dimension( kts:kte+1, nchem, Nupd) :: chemUPD, dchemUPDdz
@@ -5555,6 +5868,13 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
 
       if ( hfx > 0.) then
          wstr = (g * h0 / thetav(2) * hfx/(rho(1)*cp) ) ** (1./3.)
+         bdy_dist = min( min((ii-ids),(ide-ii)) , min((jj-jds),(jde-jj)) )
+         taper_dist = 5
+         ! JSK - linearly taper w-star near lateral boundaries (within 5 grid columns)
+         if (bdy_dist .LE. taper_dist) then
+            taper = max(0., min( 1., real(bdy_dist) / real(taper_dist) ) )
+            wstr  = wstr * taper
+         end if
       else
          wstr = 0.
       end if
@@ -5582,9 +5902,12 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
             CALL wrf_debug ( 0 , mynn_message )
          ENDIF
 
-         Cepsmf = 2. / max(200.,h0)
+         !Cepsmf = 2. / max(200.,h0)
+         Cepsmf = 1.0 / max(200.,h0) ! WA TEST reduce entrainment 
          ! Cepsmf = max(Cepsmf,0.002)
-         Cepsmf = max(Cepsmf,0.0015)  ! WA TEST reduce max entrainment
+         ! Cepsmf = max(Cepsmf,0.0015)  ! WA TEST reduce max entrainment
+         ! Cepsmf = max(Cepsmf,0.0005)  ! WA TEST reduce min entrainment
+         Cepsmf = max(Cepsmf,0.0010)  ! WA TEST reduce min entrainment
 
          do nu = 1,Nupd
             do k = kts,kte
@@ -5592,8 +5915,9 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
                ! epsilon and delta are defined on mass grid (half levels)
                ! epsmf(k,nu) = Cepsmf * (1+0.2*(floor(nu - Nupd/2.))) ! WA for three updrafts
                ! epsmf(k,nu) = Cepsmf * (1+0.05*(floor(nu - Nupd/2.))) ! WA for ten updrafts
-               !epsmf(k,nu) = Cepsmf * (1+0.0625*(floor(nu - Nupd/2.))) ! WA for eight updrafts
-               epsmf(k,nu) = Cepsmf * (1+0.03*(floor(nu - Nupd/2.))) ! WA for eight updrafts, less spread
+               ! epsmf(k,nu) = Cepsmf * (1+0.0625*(floor(nu - Nupd/2.))) ! WA for eight updrafts
+               ! epsmf(k,nu) = Cepsmf * (1+0.03*(floor(nu - Nupd/2.))) ! WA for eight updrafts, less spread
+               epsmf(k,nu) = Cepsmf * (1+0.25*(nu-1)) ! WA for eight updrafts, much more eps for some plumes, per Neggers 2015 fig. 15 
             end do
             !print *,"In TEMF_MF Cepsmf, epsmf = ", Cepsmf, epsmf(1,:)
             !IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN
@@ -5799,11 +6123,12 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
 
             ! Calculate lateral detrainment rate for cloud layer
             ! WA 8/5/15 constant detrainment
-            deltmf(1,nu) = Cepsmf
-            do k = 2,kte-1
-               deltmf(k,nu) = deltmf(k-1,nu)
-            end do
-            deltmf(kte,nu) = Cepsmf
+            ! deltmf(1,nu) = Cepsmf
+            ! do k = 2,kte-1
+            !    deltmf(k,nu) = deltmf(k-1,nu)
+            ! end do
+            ! deltmf(kte,nu) = Cepsmf
+            deltmf(:,nu) = epsmf(:,nu)  ! WA TEST delt = eps everywhere 
 
             ! Calculate mass flux (defined on turbulence levels)
             mf_temfx(1,nu) = CM * wstr / Nupd
@@ -5813,6 +6138,8 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
             do kt = 2,kte-1
                dMdz(kt,nu) = (epsmf(kt,nu) - deltmf(kt,nu)) * mf_temfx(kt-1,nu) * dzt(kt)
                mf_temfx(kt,nu) = mf_temfx(kt-1,nu) + dMdz(kt,nu)
+               ! WA TEST 6/14/16 don't allow <0
+               mf_temfx(kt,nu) = max(mf_temfx(kt,nu),0.0)
                IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN
                   IF ( mf_temfx(kt,nu)>=0.2/NUPD ) THEN
                      WRITE ( mynn_message , FMT='(A,2I3)' ) &
@@ -5827,8 +6154,12 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
             ! Calculate cloud fraction (on mass levels)
             ! WA eventually replace this with the same saturation calculation
             ! used in the MYNN code above for consistency.
+            ! WA TEST 6/14/16 make sure aUPD(1) is reasonable
+            aUPD(1,nu) = 0.06 / Nupd
             do k = 2,kte
-               if (wUPD(k-1,nu) >= 1.0e-15 .AND. wUPD(k,nu) >= 1.0e-15) then
+               ! WA TEST 6/14/16 increase epsilon in test
+               ! if (wUPD(k-1,nu) >= 1.0e-15 .AND. wUPD(k,nu) >= 1.0e-15) then
+               if (wUPD(k-1,nu) >= 1.0e-5 .AND. wUPD(k,nu) >= 1.0e-5) then
                   aUPD(k,nu) = ((mf_temfx(k-1,nu)+mf_temfx(k,nu))/2.0) / &
                          ((wUPD(k-1,nu)+wUPD(k,nu))/2.0)  ! WA average before divide, is that best?
                else
@@ -5882,23 +6213,25 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
             enddo
 #endif
             do nu = 1,Nupd
-               edmf_a(k) = edmf_a(k) + aUPD(k,nu)
-               edmf_w(k) = edmf_w(k) + aUPD(k,nu)*wUPD(k,nu)
-               edmf_thl(k) = edmf_thl(k) + aUPD(k,nu)*thlUPD(k,nu)
-            ! print *,"k,nu,aUPD,thlUPD,edmf_thl = ", k,nu,aUPD(k,nu),thlUPD(k,nu),edmf_thl(k)
-               edmf_qt(k) = edmf_qt(k) + aUPD(k,nu)*qtUPD(k,nu)
-               edmf_qc(k) = edmf_qc(k) + aUPD(k,nu)*qlUPD(k,nu)
-               edmf_u(k) = edmf_u(k) + aUPD(k,nu)*UUPD(k,nu)
-               edmf_v(k) = edmf_v(k) + aUPD(k,nu)*VUPD(k,nu)
-               edmf_qke(k) = edmf_qke(k) + aUPD(k,nu)*TEUPD(k,nu)
-               edmf_ent(k) = edmf_ent(k) + aUPD(k,nu)*epsmf(k,nu)
-               !cldfra_bl1d(k) = cldfra_bl1d(k) + cldfraUPD(k,nu)
-               cldfra_sum = cldfra_sum + cldfraUPD(k,nu)
+               ! WA 7/5/16 put area on turbulence levels for consistency
+               aUPDt(k,nu) = mf_temfx(k,nu) / wUPD(k,nu)
+               if (aUPDt(k,nu) >= 1.0e-3 .AND. wUPD(k,nu) >= 1.0e-5) then
+                  edmf_a(k) = edmf_a(k) + aUPDt(k,nu)
+                  edmf_w(k) = edmf_w(k) + aUPDt(k,nu)*wUPD(k,nu)
+                  edmf_thl(k) = edmf_thl(k) + aUPDt(k,nu)*thlUPD(k,nu)
+                  edmf_qt(k) = edmf_qt(k) + aUPDt(k,nu)*qtUPD(k,nu)
+                  edmf_qc(k) = edmf_qc(k) + aUPDt(k,nu)*qlUPD(k,nu)
+                  edmf_u(k) = edmf_u(k) + aUPDt(k,nu)*UUPD(k,nu)
+                  edmf_v(k) = edmf_v(k) + aUPDt(k,nu)*VUPD(k,nu)
+                  edmf_qke(k) = edmf_qke(k) + aUPDt(k,nu)*TEUPD(k,nu)
+                  edmf_ent(k) = edmf_ent(k) + aUPDt(k,nu)*epsmf(k,nu)
+                  cldfra_sum = cldfra_sum + cldfraUPD(k,nu)
 #if (WRF_CHEM == 1)
-               do ic = 1,nchem
-                  edmf_chem(k,ic) = edmf_chem(k,ic) + aUPD(k,nu)*chemUPD(k,ic,nu)
-               enddo
+                  do ic = 1,nchem
+                     edmf_chem(k,ic) = edmf_chem(k,ic) + aUPDt(k,nu)*chemUPD(k,ic,nu)
+                  enddo
 #endif
+               end if
             end do
 
             IF ( wrf_at_debug_level(MYNN_DBG_LVL) ) THEN
@@ -5910,7 +6243,9 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
             !   print *,"In TEMF_MF thlUPD(2,:) = ", thlUPD(2,:)
             ENDIF
 
-            if (edmf_a(k)>0.) then
+            ! WA TEST 6/14/16 don't divide by very small updrafts
+            !if (edmf_a(k)>0.) then
+            if (edmf_a(k)>1.e-3) then
                edmf_w(k)=edmf_w(k)/edmf_a(k)
                edmf_qt(k)=edmf_qt(k)/edmf_a(k)
                edmf_thl(k)=edmf_thl(k)/edmf_a(k)
@@ -5947,28 +6282,25 @@ SUBROUTINE temf_mf(kts,kte,dt,zw,p,pi1d,   &
          ! Computing variables needed for solver
 
          do k=kts,kte  ! do these in loop above
-            s_aw(k)   = edmf_a(k)*edmf_w(k)*psig_w
-            s_awthl(k)= edmf_a(k)*edmf_w(k)*edmf_thl(k)*psig_w
-            s_awqt(k) = edmf_a(k)*edmf_w(k)*edmf_qt(k)*psig_w
-            s_awqc(k) = edmf_a(k)*edmf_w(k)*edmf_qc(k)*psig_w
+            ! WA TEST 6/14/16 don't use very small updrafts to be consistent
+            ! with block above
+            if (edmf_a(k)>1.0e-3) then
+            s_aw(k)   = edmf_a(k)*edmf_w(k)*psig_w * (1.0+rstoch_col(k))
+            s_awthl(k)= edmf_a(k)*edmf_w(k)*edmf_thl(k)*psig_w * (1.0+rstoch_col(k)) 
+            s_awqt(k) = edmf_a(k)*edmf_w(k)*edmf_qt(k)*psig_w * (1.0+rstoch_col(k))
+            s_awqc(k) = edmf_a(k)*edmf_w(k)*edmf_qc(k)*psig_w * (1.0+rstoch_col(k))
             s_awqv(k) = s_awqt(k) - s_awqc(k)
-            s_awu(k)  = edmf_a(k)*edmf_w(k)*edmf_u(k)*psig_w
-            s_awv(k)  = edmf_a(k)*edmf_w(k)*edmf_v(k)*psig_w
-            s_awqke(k) = edmf_a(k)*edmf_w(k)*edmf_qke(k)*psig_w
+            s_awu(k)  = edmf_a(k)*edmf_w(k)*edmf_u(k)*psig_w * (1.0+rstoch_col(k)) 
+            s_awv(k)  = edmf_a(k)*edmf_w(k)*edmf_v(k)*psig_w * (1.0+rstoch_col(k))
+            s_awqke(k) = edmf_a(k)*edmf_w(k)*edmf_qke(k)*psig_w * (1.0+rstoch_col(k))
 #if (WRF_CHEM == 1)
             do ic = 1,nchem
-               s_awchem(k,ic) = edmf_w(k)*edmf_chem(k,ic)*psig_w
+               s_awchem(k,ic) = edmf_w(k)*edmf_chem(k,ic)*psig_w * (1.0+rstoch_col(k))
             enddo
 #endif
-            !now reduce diagnostic output arrays by psig
-             edmf_w(k)=edmf_w(k)*psig_w
-             edmf_qt(k)=edmf_qt(k)*psig_w
-             edmf_thl(k)=edmf_thl(k)*psig_w
-             edmf_ent(k)=edmf_ent(k)*psig_w
-             edmf_qc(k)=edmf_qc(k)*psig_w
-             edmf_u(k)=edmf_u(k)*psig_w
-             edmf_v(k)=edmf_v(k)*psig_w
-             edmf_qke(k)=edmf_qke(k)*psig_w
+            endif
+            !now reduce diagnostic output array by psig
+             edmf_a(k)=edmf_a(k)*psig_w 
          enddo
 
       ! end if   ! is_convective
diff --git a/wrfv2_fire/phys/module_bl_shinhong.F b/wrfv2_fire/phys/module_bl_shinhong.F
index dc5cd5c5..ddae4717 100644
--- a/wrfv2_fire/phys/module_bl_shinhong.F
+++ b/wrfv2_fire/phys/module_bl_shinhong.F
@@ -11,7 +11,7 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,          &
                   rqvblten,rqcblten,rqiblten,flag_qi,                          &
                   cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv,                    &
                   dz8w,psfc,                                                   &
-                  znu,znw,mut,p_top,                                           &
+                  znu,znw,p_top,                                               &
                   znt,ust,hpbl,psim,psih,                                      &
                   xland,hfx,qfx,wspd,br,                                       &
                   dt,kpbl2d,                                                   &
@@ -66,7 +66,6 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,          &
 !-- psfc        pressure at the surface (pa)
 !-- znu         eta values on half (mass) levels  
 !-- znw         eta values on full (w) levels
-!-- mut         mass in column (pa)
 !-- p_top       pressure top of the model (pa)
 !-- znt         roughness length (m)
 !-- ust	        u* in similarity theory (m/s)
@@ -177,8 +176,6 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,          &
    real,     dimension( ims:ime, jms:jme )                                   , &
              intent(inout), optional    ::                             regime
 !
-   real,     dimension( ims:ime, jms:jme )                                   , &
-             intent(in   ), optional    ::                                mut
    real,     dimension( ims:ime, jms:jme )                                   , &
              intent(in   ), optional    ::                              ctopo, &
                                                                        ctopo2
@@ -205,24 +202,12 @@ subroutine shinhong(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,          &
    qv2d(its:ite,:) = 0.0
 !
    do j = jts,jte
-     if(present(mut))then
-!
-! For ARW we will replace p and p8w with dry hydrostatic pressure
-!
-       do k = kts,kte+1
-         do i = its,ite
-           if(k.le.kte)pdh(i,k) = mut(i,j)*znu(k) + p_top
-           pdhi(i,k) = mut(i,j)*znw(k) + p_top
-         enddo
-       enddo
-     else
-       do k = kts,kte+1
-         do i = its,ite
-           if(k.le.kte)pdh(i,k) = p3d(i,k,j)
-           pdhi(i,k) = p3di(i,k,j)
-         enddo
+     do k = kts,kte+1
+       do i = its,ite
+         if(k.le.kte)pdh(i,k) = p3d(i,k,j)
+         pdhi(i,k) = p3di(i,k,j)
        enddo
-     endif
+     enddo
      do k = kts,kte
        do i = its,ite
          qv2d(i,k) = qv3d(i,k,j)
diff --git a/wrfv2_fire/phys/module_bl_temf.F b/wrfv2_fire/phys/module_bl_temf.F
index a0ead6a5..09f3d644 100644
--- a/wrfv2_fire/phys/module_bl_temf.F
+++ b/wrfv2_fire/phys/module_bl_temf.F
@@ -13,7 +13,7 @@ subroutine temfpbl(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,rho,      &
                   rqvblten,rqcblten,rqiblten,flag_qi,                          &
                   g,cp,rcp,r_d,r_v,cpv,                                   &
                   z,xlv,psfc,                                          &
-                  mut,p_top,                                           &
+                  p_top,                                               &
                   znt,ht,ust,zol,hol,hpbl,psim,psih,                         &
                   xland,hfx,qfx,tsk,qsfc,gz1oz0,wspd,br,                    &
                   dt,dtmin,kpbl2d,                                             &
@@ -200,10 +200,6 @@ subroutine temfpbl(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,rho,      &
 !   real,     dimension( ims:ime, kms:kme, jms:jme ), &
 !             optional                              , &
 !             intent(inout)   ::      rqiblten
-!
-   real,     dimension( ims:ime, jms:jme )                                   , &
-             optional                                                        , &
-             intent(in   )   ::      mut
 !
    real,     optional, intent(in   )   ::  p_top
 !
diff --git a/wrfv2_fire/phys/module_bl_ysu.F b/wrfv2_fire/phys/module_bl_ysu.F
index 639049ed..127bed3b 100644
--- a/wrfv2_fire/phys/module_bl_ysu.F
+++ b/wrfv2_fire/phys/module_bl_ysu.F
@@ -17,7 +17,7 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,               &
                   rqvblten,rqcblten,rqiblten,flag_qi,                          &
                   cp,g,rovcp,rd,rovg,ep1,ep2,karman,xlv,rv,                    &
                   dz8w,psfc,                                                   &
-                  znu,znw,mut,p_top,                                           &
+                  znu,znw,p_top,                                               &
                   znt,ust,hpbl,psim,psih,                                      &
                   xland,hfx,qfx,wspd,br,                                       &
                   dt,kpbl2d,                                                   &
@@ -192,9 +192,6 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,               &
              intent(in   )   ::                                           znu, &
                                                                           znw
 !
-   real,     dimension( ims:ime, jms:jme )                                   , &
-             optional                                                        , &
-             intent(in   )   ::                                           mut
 !
    real,     optional, intent(in   )   ::                               p_top
 !
@@ -217,24 +214,12 @@ subroutine ysu(u3d,v3d,th3d,t3d,qv3d,qc3d,qi3d,p3d,p3di,pi3d,               &
    qv2d(its:ite,:) = 0.0
 !
    do j = jts,jte
-     if(present(mut))then
-!
-! For ARW we will replace p and p8w with dry hydrostatic pressure
-!
-        do k = kts,kte+1
-          do i = its,ite
-             if(k.le.kte)pdh(i,k) = mut(i,j)*znu(k) + p_top
-             pdhi(i,k) = mut(i,j)*znw(k) + p_top
-          enddo
-        enddo
-      else
-        do k = kts,kte+1
-          do i = its,ite
-            if(k.le.kte)pdh(i,k) = p3d(i,k,j)
-            pdhi(i,k) = p3di(i,k,j)
-          enddo
+      do k = kts,kte+1
+        do i = its,ite
+          if(k.le.kte)pdh(i,k) = p3d(i,k,j)
+          pdhi(i,k) = p3di(i,k,j)
         enddo
-      endif
+      enddo
       do k = kts,kte
         do i = its,ite
           qv2d(i,k) = qv3d(i,k,j)
@@ -348,10 +333,10 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d,                               &
 !              revised thermal, shin et al. mon. wea. rev. , songyou hong, aug 2011
 !              ==> reduce the thermal strength when z1 < 0.1 h
 !              revised prandtl number for free convection, dudhia, mar 2012
-!              ==> pr0 = 1 + bke (=0.272) when newtral, kh is reduced
+!              ==> pr0 = 1 + bke (=0.272) when neutral, kh is reduced
 !              minimum kzo = 0.01, lo = min (30m,delz), hong, mar 2012
 !              ==> weaker mixing when stable, and les resolution in vertical
-!              gz1oz0 is removed, and phim phih are ln(z1/z0)-phim,h, hong, mar 2012
+!              gz1oz0 is removed, and psim psih are ln(z1/z0)-psim,h, hong, mar 2012
 !              ==> consider thermal z0 when differs from mechanical z0
 !              a bug fix in wscale computation in stable bl, sukanta basu, jun 2012
 !              ==> wscale becomes small with height, and less mixing in stable bl
@@ -542,7 +527,15 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d,                               &
    real    ::  prnumfac,bfx0,hfx0,qfx0,delb,dux,dvx,                           &
                dsdzu,dsdzv,wm3,dthx,dqx,wspd10,ross,tem1,dsig,tvcon,conpr,     &
                prfac,prfac2,phim8z,radsum,tmp1,templ,rvls,temps,ent_eff,    &
-               rcldb,bruptmp,radflux
+               rcldb,bruptmp,radflux,vconvlim,vconvnew,fluxc,vconvc,vconv
+!topo-corr
+   real,    dimension( ims:ime, kms:kme )    ::                          fric, &
+                                                                       tke_ysu,&
+                                                                        el_ysu,&
+                                                                     shear_ysu,&
+                                                                     buoy_ysu
+   real,    dimension( ims:ime )             ::                       pblh_ysu,&
+                                                                      vconvfx
 !
 !-------------------------------------------------------------------------------
 !
@@ -1304,18 +1297,62 @@ subroutine ysu2d(j,ux,vx,tx,qx,p2d,p2di,pi2d,                               &
      enddo
    enddo
 !
-   do i = its,ite
 ! paj: ctopo=1 if topo_wind=0 (default)
-! mchen add this line to make sure NMM can still work with YSU PBL
-     if(present(ctopo)) then
-       ad(i,1) = 1.+ctopo(i)*ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2         &
-        *(wspd1(i)/wspd(i))**2
-     else
-       ad(i,1) = 1.+ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2                  &
+!raquel---paj tke code (could be replaced with shin-hong tke in future
+   do i = its,ite
+      do k= kts, kte-1
+        shear_ysu(i,k)=xkzm(i,k)*((-hgamu(i)/hpbl(i)+(ux(i,k+1)-ux(i,k))/dza(i,k+1))*(ux(i,k+1)-ux(i,k))/dza(i,k+1) &
+        + (-hgamv(i)/hpbl(i)+(vx(i,k+1)-vx(i,k))/dza(i,k+1))*(vx(i,k+1)-vx(i,k))/dza(i,k+1))
+         buoy_ysu(i,k)=xkzh(i,k)*g*(1.0/thx(i,k))*(-hgamt(i)/hpbl(i)+(thx(i,k+1)-thx(i,k))/dza(i,k+1))
+
+       zk = karman*zq(i,k+1)
+ !over pbl
+       if (k.ge.kpbl(i)) then
+        rlamdz = min(max(0.1*dza(i,k+1),rlam),300.)
+        rlamdz = min(dza(i,k+1),rlamdz)
+       else
+ !in pbl
+        rlamdz = 150.0
+       endif
+       el_ysu(i,k) = zk*rlamdz/(rlamdz+zk)
+       tke_ysu(i,k)=16.6*el_ysu(i,k)*(shear_ysu(i,k)-buoy_ysu(i,k))
+ !q2 when q3 positive
+       if(tke_ysu(i,k).le.0) then
+        tke_ysu(i,k)=0.0
+       else
+        tke_ysu(i,k)=(tke_ysu(i,k))**0.66
+       endif
+      enddo
+ !Hybrid pblh of MYNN
+ !tke is q2
+      CALL GET_PBLH(KTS,KTE,pblh_ysu(i),thvx(i,kts:kte),&
+      &    tke_ysu(i,kts:kte),zq(i,kts:kte+1),dzq(i,kts:kte),xland(i))
+
+!--- end of paj tke
+! compute vconv
+!      Use Beljaars over land
+        if (xland(i).lt.1.5) then
+        fluxc = max(sflux(i),0.0)
+        vconvc=1.
+        VCONV = vconvc*(g/thvx(i,1)*pblh_ysu(i)*fluxc)**.33
+        else
+! for water there is no topo effect so vconv not needed
+        VCONV = 0.
+        endif
+        vconvfx(i) = vconv
+!raquel
+!ctopo stability correction
+      fric(i,1)=ust(i)**2/wspd1(i)*rhox(i)*g/del(i,1)*dt2         &
         *(wspd1(i)/wspd(i))**2
-     endif
-     f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i)
-     f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*g/del(i,1)*dt2/wspd1(i)
+      if(present(ctopo)) then
+        vconvnew=0.9*vconvfx(i)+1.5*(max((pblh_ysu(i)-500)/1000.0,0.0))
+        vconvlim = min(vconvnew,1.0)
+        ad(i,1) = 1.+fric(i,1)*vconvlim+ctopo(i)*fric(i,1)*(1-vconvlim)
+      else
+       ad(i,1) = 1.+fric(i,1)
+      endif
+     f1(i,1) = ux(i,1)+uox(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2
+     f2(i,1) = vx(i,1)+vox(i)*ust(i)**2*rhox(i)*g/del(i,1)*dt2/wspd1(i)*(wspd1(i)/wspd(i))**2
    enddo
 !
    do k = kts,kte-1
@@ -1610,5 +1647,117 @@ subroutine ysuinit(rublten,rvblten,rthblten,rqvblten,                       &
 !
    end subroutine ysuinit
 !-------------------------------------------------------------------------------
+! ==================================================================
+
+      SUBROUTINE GET_PBLH(KTS,KTE,zi,thetav1D,qke1D,zw1D,dz1D,landsea)
+! Copied from MYNN PBL
+
+      !---------------------------------------------------------------
+      !             NOTES ON THE PBLH FORMULATION
+      !
+      !The 1.5-theta-increase method defines PBL heights as the level at
+      !which the potential temperature first exceeds the minimum potential
+      !temperature within the boundary layer by 1.5 K. When applied to
+      !observed temperatures, this method has been shown to produce PBL-
+      !height estimates that are unbiased relative to profiler-based
+      !estimates (Nielsen-Gammon et al. 2008). However, their study did not
+      !include LLJs. Banta and Pichugina (2008) show that a TKE-based
+      !threshold is a good estimate of the PBL height in LLJs. Therefore,
+      !a hybrid definition is implemented that uses both methods, weighting
+      !the TKE-method more during stable conditions (PBLH < 400 m).
+      !A variable tke threshold (TKEeps) is used since no hard-wired
+      !value could be found to work best in all conditions.
+      !---------------------------------------------------------------
+
+      INTEGER,INTENT(IN) :: KTS,KTE
+      REAL, INTENT(OUT) :: zi
+      REAL, INTENT(IN) :: landsea
+      REAL, DIMENSION(KTS:KTE), INTENT(IN) :: thetav1D, qke1D, dz1D
+      REAL, DIMENSION(KTS:KTE+1), INTENT(IN) :: zw1D
+      !LOCAL VARS
+      REAL ::  PBLH_TKE,qtke,qtkem1,wt,maxqke,TKEeps,minthv
+      REAL :: delt_thv   !delta theta-v; dependent on land/sea point
+      REAL, PARAMETER :: sbl_lim  = 200. !Theta-v PBL lower limit of trust (m).
+      REAL, PARAMETER :: sbl_damp = 400. !Damping range for averaging with TKE-based PBLH (m).
+      INTEGER :: I,J,K,kthv,ktke
+
+      !FIND MAX TKE AND MIN THETAV IN THE LOWEST 500 M
+      k = kts+1
+      kthv = 1
+      ktke = 1
+      maxqke = 0.
+      minthv = 9.E9
+
+      DO WHILE (zw1D(k) .LE. 500.)
+        qtke  =MAX(Qke1D(k),0.)   ! maximum QKE
+         IF (maxqke < qtke) then
+            maxqke = qtke
+            ktke = k
+         ENDIF
+         IF (minthv > thetav1D(k)) then
+             minthv = thetav1D(k)
+             kthv = k
+         ENDIF
+         k = k+1
+      ENDDO
+      !TKEeps = maxtke/20. = maxqke/40.
+      TKEeps = maxqke/40.
+      TKEeps = MAX(TKEeps,0.025)
+      TKEeps = MIN(TKEeps,0.25)
+
+      !FIND THETAV-BASED PBLH (BEST FOR DAYTIME).
+      zi=0.
+      k = kthv+1
+      IF((landsea-1.5).GE.0)THEN
+      ! WATER
+          delt_thv = 0.75
+      ELSE
+      ! LAND
+          delt_thv = 1.5
+      ENDIF
+
+      zi=0.
+      k = kthv+1
+      DO WHILE (zi .EQ. 0.)
+         IF (thetav1D(k) .GE. (minthv + delt_thv))THEN
+            zi = zw1D(k) - dz1D(k-1)* &
+              & MIN((thetav1D(k)-(minthv + delt_thv))/MAX(thetav1D(k)-thetav1D(k-1),1E-6),1.0)
+        ENDIF
+        k = k+1
+         IF (k .EQ. kte-1) zi = zw1D(kts+1) !EXIT SAFEGUARD
+      ENDDO
+
+      !print*,"IN GET_PBLH:",thsfc,zi
+      !FOR STABLE BOUNDARY LAYERS, USE TKE METHOD TO COMPLEMENT THE
+      !THETAV-BASED DEFINITION (WHEN THE THETA-V BASED PBLH IS BELOW ~0.5 KM).
+      !THE TANH WEIGHTING FUNCTION WILL MAKE THE TKE-BASED DEFINITION NEGLIGIBLE
+      !WHEN THE THETA-V-BASED DEFINITION IS ABOVE ~1 KM.
+      !FIND TKE-BASED PBLH (BEST FOR NOCTURNAL/STABLE CONDITIONS).
+
+      PBLH_TKE=0.
+      k = ktke+1
+     DO WHILE (PBLH_TKE .EQ. 0.)
+        !QKE CAN BE NEGATIVE (IF CKmod == 0)... MAKE TKE NON-NEGATIVE.
+         qtke  =MAX(Qke1D(k)/2.,0.)      ! maximum TKE
+         qtkem1=MAX(Qke1D(k-1)/2.,0.)
+         IF (qtke .LE. TKEeps) THEN
+               PBLH_TKE = zw1D(k) - dz1D(k-1)* &
+               & MIN((TKEeps-qtke)/MAX(qtkem1-qtke, 1E-6), 1.0)
+             !IN CASE OF NEAR ZERO TKE, SET PBLH = LOWEST LEVEL.
+             PBLH_TKE = MAX(PBLH_TKE,zw1D(kts+1))
+             !print *,"PBLH_TKE:",i,j,PBLH_TKE, Qke1D(k)/2., zw1D(kts+1)
+         ENDIF
+         k = k+1
+         IF (k .EQ. kte-1) PBLH_TKE = zw1D(kts+1) !EXIT SAFEGUARD
+      ENDDO
+
+    !BLEND THE TWO PBLH TYPES HERE:
+
+      wt=.5*TANH((zi - sbl_lim)/sbl_damp) + .5
+      zi=PBLH_TKE*(1.-wt) + zi*wt
+
+   END SUBROUTINE GET_PBLH
+! ==================================================================
+
 end module module_bl_ysu
 !-------------------------------------------------------------------------------
diff --git a/wrfv2_fire/phys/module_cu_camzm_driver.F b/wrfv2_fire/phys/module_cu_camzm_driver.F
index 82b32904..9bda99cd 100644
--- a/wrfv2_fire/phys/module_cu_camzm_driver.F
+++ b/wrfv2_fire/phys/module_cu_camzm_driver.F
@@ -580,7 +580,7 @@ SUBROUTINE camzm_driver(                                      &
            preccdzm(i,j)   = prec(1)       !Rain rate from just deep
            precz(i,j)      = prec(1)       !Rain rate for total convection (just deep right now)
            pratec(i,j)     = prec(1)*1e3   !Rain rate used in WRF for accumulation (mm/s)
-           raincv(i,j)     = pratec(i,j)*cudts !Rain amount for time step returned back to WRF   !PMA
+           raincv(i,j)     = pratec(i,j)*dt !Rain amount for dynamic time step returned back to WRF   !wig: fixed wrong timestep usage 3-Jun-2016
         end do
 
         !BSINGH - storing quantities at interfaces
diff --git a/wrfv2_fire/phys/module_cu_g3.F b/wrfv2_fire/phys/module_cu_g3.F
index cf614c24..87a933dd 100644
--- a/wrfv2_fire/phys/module_cu_g3.F
+++ b/wrfv2_fire/phys/module_cu_g3.F
@@ -3122,7 +3122,8 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
        pcrit,acrit,acritt
 
      integer :: nall2,ixxx,irandom
-     integer,  dimension (12) :: seed
+     integer, allocatable :: seed(:)
+     integer              :: seed_size
 
 
       DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,    &
@@ -3133,6 +3134,9 @@ SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2
       DATA ACRITT/.203,.515,.521,.566,.625,.665,.659,.688,             &
                   .743,.813,.886,.947,1.138,1.377,1.896/
 !
+       call random_seed(size=seed_size)      ! Get size of seed array.
+       allocate(seed(1:seed_size))           ! Allocate according to returned size
+
        seed=0
        seed(2)=j
        seed(3)=ktau
diff --git a/wrfv2_fire/phys/module_cu_gf.F b/wrfv2_fire/phys/module_cu_gf.F
deleted file mode 100644
index a17d498f..00000000
--- a/wrfv2_fire/phys/module_cu_gf.F
+++ /dev/null
@@ -1,4900 +0,0 @@
-!WRF:MODEL_LAYER:PHYSICS
-!
-
-MODULE module_cu_gf
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!     This convective parameterization is build to attempt     !
-!     a smooth transition to cloud resolving scales as proposed!
-!     by Arakawa et al (2011, ACP). It currently does not use  !
-!     subsidencespreading as in G3. Difference and details     !
-!     will be described in a forthcoming paper by              !
-!     Grell and Freitas (2013). The parameterization also      !
-!     offers options to couple with aerosols. Both, the smooth !
-!     transition part as well as the aerosol coupling are      !
-!     experimental. While the smooth transition part is turned !
-!     on, nd has been tested dow to a resolution of about 3km  !
-!     the aerosol coupling is turned off.                      !
-!     More clean-up as well as a direct coupling to chemistry  !
-!     will follow for V3.5.1                                   !
-!                                                              !
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-CONTAINS
-
-!-------------------------------------------------------------
-   SUBROUTINE GFDRV(                                            &
-               DT,itimestep,DX                                  &
-              ,rho,RAINCV,PRATEC                                &
-              ,U,V,t,W,q,p,pi                                   &
-              ,dz8w,p8w,XLV,CP,G,r_v                            &
-              ,htop,hbot,ktop_deep                              &
-              ,CU_ACT_FLAG,warm_rain                            &
-              ,APR_GR,APR_W,APR_MC,APR_ST,APR_AS                &
-              ,APR_CAPMA,APR_CAPME,APR_CAPMI                    &
-              ,MASS_FLUX,HT,hfx,qfx,XLAND,gsw,edt_out     &
-              ,GDC,GDC2 ,kpbl,k22_shallow,kbcon_shallow         &
-              ,ktop_shallow,xmb_shallow                         &
-              ,cugd_tten,cugd_qvten ,cugd_qcten                 &
-              ,cugd_ttens,cugd_qvtens,cugd_avedx,imomentum      &
-              ,ichoice    &
-              ,ishallow_g3,ids,ide, jds,jde, kds,kde            &
-              ,ims,ime, jms,jme, kms,kme                        &
-              ,its,ite, jts,jte, kts,kte                        &
-              ,periodic_x,periodic_y                            &
-              ,RQVCUTEN,RQCCUTEN,RQICUTEN                       &
-              ,RQVFTEN,RTHFTEN,RTHCUTEN,RTHRATEN                &
-              ,rqvblten,rthblten                                &
-              ,F_QV    ,F_QC    ,F_QR    ,F_QI    ,F_QS         &
-#if ( WRF_DFI_RADAR == 1 )
-                 ! Optional CAP suppress option
-              ,do_capsuppress,cap_suppress_loc                  &
-#endif                                 
-                                                                )
-!-------------------------------------------------------------
-   IMPLICIT NONE
-! autoconv, 1=old c0, 2=berry c0
-      integer, parameter :: autoconv=1
-!aeroevap, 1=old,2=?, 3=average
-      integer, parameter :: aeroevap=1
-      integer, parameter :: training=0
-      integer, parameter :: use_excess=0
-      integer, parameter :: use_excess_sh=0
-      integer, parameter :: maxiens=1
-      integer, parameter :: maxens=1
-      integer, parameter :: maxens2=1
-      integer, parameter :: maxens3=16
-      integer, parameter :: ensdim=16
-      real, parameter :: ccnclean=250.
-      real, parameter :: aodccn=0.1
-      real, parameter :: beta=0.02
-!-------------------------------------------------------------
-   INTEGER,      INTENT(IN   ) ::                               &
-                                  ids,ide, jds,jde, kds,kde,    & 
-                                  ims,ime, jms,jme, kms,kme,    & 
-                                  its,ite, jts,jte, kts,kte
-   LOGICAL periodic_x,periodic_y
-               integer, parameter  :: ens4_spread = 3 ! max(3,cugd_avedx)
-               integer, parameter  :: ens4=ens4_spread*ens4_spread
-
-   integer, intent (in   )              :: ichoice
-  
-   INTEGER,      INTENT(IN   ) :: ITIMESTEP,cugd_avedx, &
-                                  ishallow_g3,imomentum
-   LOGICAL,      INTENT(IN   ) :: warm_rain
-
-   REAL,         INTENT(IN   ) :: XLV, R_v
-   REAL,         INTENT(IN   ) :: CP,G
-
-   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
-          INTENT(IN   ) ::                                      &
-                                                          U,    &
-                                                          V,    &
-                                                          W,    &
-                                                         pi,    &
-                                                          t,    &
-                                                          q,    &
-                                                          p,    &
-                                                       dz8w,    &
-                                                       p8w,    &
-                                                        rho
-   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
-          OPTIONAL                                         ,    &
-          INTENT(INOUT   ) ::                                   &
-               GDC,GDC2
-
-   REAL, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: hfx,qfx,GSW,HT,XLAND
-   INTEGER, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: KPBL
-   INTEGER, DIMENSION( ims:ime , jms:jme ),INTENT(INOUT) :: k22_shallow, &
-                 kbcon_shallow,ktop_shallow
-!
-   REAL, INTENT(IN   ) :: DT, DX
-!
-
-   REAL, DIMENSION( ims:ime , jms:jme ),                        &
-         INTENT(INOUT) ::           pratec,RAINCV, MASS_FLUX,   &
-                          APR_GR,APR_W,APR_MC,APR_ST,APR_AS,    &
-                         edt_out,APR_CAPMA,APR_CAPME,APR_CAPMI, &
-                         htop,hbot,xmb_shallow
-!+lxz
-!  REAL, DIMENSION( ims:ime , jms:jme ) :: & !, INTENT(INOUT) ::       &
-!        HTOP,     &! highest model layer penetrated by cumulus since last reset in radiation_driver
-!        HBOT       ! lowest  model layer penetrated by cumulus since last reset in radiation_driver
-!                   ! HBOT>HTOP follow physics leveling convention
-
-   LOGICAL, DIMENSION( ims:ime , jms:jme ),                     &
-         INTENT(INOUT) ::                       CU_ACT_FLAG
-
-!
-! Optionals
-!
-   INTEGER, DIMENSION( ims:ime,         jms:jme ),              &
-         OPTIONAL,                                              &
-         INTENT(  OUT) ::                           ktop_deep
-
-   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
-         OPTIONAL,                                              &
-         INTENT(INOUT) ::                           RTHFTEN,    &
-                            cugd_tten,cugd_qvten,cugd_qcten,    &
-                            cugd_ttens,cugd_qvtens,             &
-                                                    RQVFTEN
-
-   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
-         OPTIONAL,                                              &
-         INTENT(INOUT) ::                                       &
-                                                   RTHCUTEN,    &
-                                                   RQVCUTEN,    &
-                                                   RQVBLTEN,    &
-                                                   RTHBLTEN,    &
-                                                   RTHRATEN,    &
-                                                   RQCCUTEN,    &
-                                                   RQICUTEN
-!
-! Flags relating to the optional tendency arrays declared above
-! Models that carry the optional tendencies will provdide the
-! optional arguments at compile time; these flags all the model
-! to determine at run-time whether a particular tracer is in
-! use or not.
-!
-   LOGICAL, OPTIONAL ::                                      &
-                                                   F_QV      &
-                                                  ,F_QC      &
-                                                  ,F_QR      &
-                                                  ,F_QI      &
-                                                  ,F_QS
-
-
-#if ( WRF_DFI_RADAR == 1 )
-!
-!  option of cap suppress: 
-!        do_capsuppress = 1   do
-!        do_capsuppress = other   don't
-!
-!
-   INTEGER,      INTENT(IN   ) ,OPTIONAL   :: do_capsuppress
-   REAL, DIMENSION( ims:ime, jms:jme ),INTENT(IN   ),OPTIONAL  :: cap_suppress_loc
-   REAL, DIMENSION( its:ite ) :: cap_suppress_j
-#endif
-
-
-! LOCAL VARS
-     real,    dimension(its:ite,jts:jte,1:ensdim) ::      &
-        xf_ens,pr_ens
-     real,    dimension ( its:ite , jts:jte , 1:ensdim) ::      &
-        massflni,xfi_ens,pri_ens
-   REAL, DIMENSION( its:ite , jts:jte ) ::            MASSI_FLX,    &
-                          APRi_GR,APRi_W,APRi_MC,APRi_ST,APRi_AS,    &
-                         edti_out,APRi_CAPMA,APRi_CAPME,APRi_CAPMI,gswi
-     real,    dimension (its:ite,kts:kte) ::                    &
-        SUBT,SUBQ,OUTT,OUTQ,OUTQC,phh,subm,cupclw,cupclws,dhdt,         &
-        outts,outqs,outqcs
-     real,    dimension (its:ite)         ::                    &
-        ztexec,zqexec,pret, ter11, aa0, fp,xlandi
-!+lxz
-     integer, dimension (its:ite) ::                            &
-        ierr,ierrs,kbcon, ktop,kpbli,k22s,kbcons,ktops
-!.lxz
-     integer, dimension (its:ite,jts:jte) ::                    &
-        iact_old_gr
-     integer :: iens,ibeg,iend,jbeg,jend,n,nn,ens4n
-     integer :: ibegh,iendh,jbegh,jendh
-     integer :: ibegc,iendc,jbegc,jendc
-   real rho_dryar,temp
-   real :: PTEN,PQEN,PAPH,ZRHO,PAHFS,PQHFL,ZKHVFL,ZWS,PGEOH
-
-
-!
-! basic environmental input includes moisture convergence (mconv)
-! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off
-! convection for this call only and at that particular gridpoint
-!
-     real,    dimension (its:ite,kts:kte) ::                    &
-        zo,T2d,q2d,PO,P2d,US,VS,rhoi,tn,qo,tshall,qshall
-     real,    dimension (its:ite,kts:kte,1:ens4) ::                    &
-        omeg
-     real, dimension (its:ite)            ::                    &
-        ccn,Z1,PSUR,AAEQ,cuten,umean,vmean,pmean,xmbs
-     real, dimension (its:ite,1:ens4)     ::                    &
-        mconv
-
-   INTEGER :: i,j,k,ICLDCK,ipr,jpr
-   REAL    :: tcrit,tscl_KF,dp,dq,sub_spread,subcenter
-   INTEGER :: itf,jtf,ktf,iss,jss,nbegin,nend
-   INTEGER :: high_resolution
-   REAL    :: rkbcon,rktop        !-lxz
-   character*50 :: ierrc(its:ite)
-   character*50 :: ierrcs(its:ite)
-! ruc variable
-     real, dimension (its:ite)            ::  tkm
-
-  ! A. Betts for shallow convection: suggestion for the KF timescale < DELTAX  / 25 m/s
-   tscl_kf=dx/25.
-   ccn(its:ite)=1500.
-  !
-!   write(0,*)'ishallow = ',ishallow_g3
-   high_resolution=0
-   subcenter=0.
-   iens=1
-   ipr=0 !639
-   jpr=0 !141
-   IF ( periodic_x ) THEN
-      ibeg=max(its,ids)
-      iend=min(ite,ide-1)
-      ibegc=max(its,ids)
-      iendc=min(ite,ide-1)
-   ELSE
-      ibeg=max(its,ids)
-      iend=min(ite,ide-1)
-      ibegc=max(its,ids+4)
-      iendc=min(ite,ide-5)
-   END IF
-   IF ( periodic_y ) THEN
-      jbeg=max(jts,jds)
-      jend=min(jte,jde-1)
-      jbegc=max(jts,jds)
-      jendc=min(jte,jde-1)
-   ELSE
-      jbeg=max(jts,jds)
-      jend=min(jte,jde-1)
-      jbegc=max(jts,jds+4)
-      jendc=min(jte,jde-5)
-   END IF
-   do j=jts,jte
-   do i=its,ite
-     k22_shallow(i,j)=0
-     kbcon_shallow(i,j)=0
-     ktop_shallow(i,j)=0
-     xmb_shallow(i,j)=0
-   enddo
-   enddo
-   tcrit=258.
-
-   itf=MIN(ite,ide-1)
-   ktf=MIN(kte,kde-1)
-   jtf=MIN(jte,jde-1)
-!                                                                      
-     DO 100 J = jts,jtf  
-     DO n= 1,ensdim
-     DO I= its,itf
-       xfi_ens(i,j,n)=0.
-       pri_ens(i,j,n)=0.
-     ENDDO
-     ENDDO
-     DO I= its,itf
-        ierrc(i)=" "
-        ierrcs(i)=" "
-        ierr(i)=0
-        ierrs(i)=0
-        kbcon(i)=0
-        ktop(i)=0
-        tkm(i)=0.
-        xmbs(i)=0.
-        k22s(i)=0
-        kbcons(i)=0
-        ktops(i)=0
-        HBOT(I,J)  =REAL(KTE)
-        HTOP(I,J)  =REAL(KTS)
-        iact_old_gr(i,j)=0
-        mass_flux(i,j)=0.
-        massi_flx(i,j)=0.
-        raincv(i,j)=0.
-        pratec (i,j)=0.
-        edt_out(i,j)=0.
-        edti_out(i,j)=0.
-        gswi(i,j)=gsw(i,j)
-        xlandi(i)=xland(i,j)
-        APRi_GR(i,j)=apr_gr(i,j)
-        APRi_w(i,j)=apr_w(i,j)
-        APRi_mc(i,j)=apr_mc(i,j)
-        APRi_st(i,j)=apr_st(i,j)
-        APRi_as(i,j)=apr_as(i,j)
-        APRi_capma(i,j)=apr_capma(i,j)
-        APRi_capme(i,j)=apr_capme(i,j)
-        APRi_capmi(i,j)=apr_capmi(i,j)
-        CU_ACT_FLAG(i,j) = .true.
-     ENDDO
-     do k=kts,kte
-     DO I= its,itf
-       cugd_tten(i,k,j)=0.
-       cugd_ttens(i,k,j)=0.
-       cugd_qvten(i,k,j)=0.
-       cugd_qvtens(i,k,j)=0.
-       cugd_qcten(i,k,j)=0.
-     ENDDO
-     ENDDO
-     DO n=1,ens4
-     DO I= its,itf
-        mconv(i,n)=0.
-     ENDDO
-     do k=kts,kte
-     DO I= its,itf
-         omeg(i,k,n)=0.
-     ENDDO
-     ENDDO
-     ENDDO
-     DO k=1,ensdim
-     DO I= its,itf
-        massflni(i,j,k)=0.
-     ENDDO
-     ENDDO
-     !  put hydrostatic pressure on half levels
-     DO K=kts,ktf
-     DO I=ITS,ITF
-         phh(i,k) = p(i,k,j)
-     ENDDO
-     ENDDO
-
-!ipr= 33 !78
-!jpr= 17 !110
-     DO I=ITS,ITF
-         PSUR(I)=p8w(I,1,J)*.01
-!        PSUR(I)=p(I,1,J)*.01
-         TER11(I)=max(0.,HT(i,j))
-         ZTEXEC(i) = 0.
-         ZQEXEC(i) = 0.
-         aaeq(i)=0.
-         pret(i)=0.
-         umean(i)=0.
-         vmean(i)=0.
-         pmean(i)=0.
-         kpbli(i)=kpbl(i,j)
-         zo(i,kts)=ter11(i)+.5*dz8w(i,1,j)
-         DO K=kts+1,ktf
-         zo(i,k)=zo(i,k-1)+.5*(dz8w(i,k-1,j)+dz8w(i,k,j))
-         enddo
-     ENDDO
-!    if(j.eq.jpr .and. (ipr.gt.its .and. ipr.lt.itf))write(0,*)psur(ipr),ter11(ipr),kpbli(ipr)
-     DO K=kts,ktf
-     DO I=ITS,ITF
-         po(i,k)=phh(i,k)*.01
-         subm(i,k)=0.
-         P2d(I,K)=PO(i,k)
-         rhoi(i,k)=rho(i,k,j)
-         US(I,K) =u(i,k,j)
-         VS(I,K) =v(i,k,j)
-         T2d(I,K)=t(i,k,j)
-         q2d(I,K)=q(i,k,j)
-         IF(Q2d(I,K).LT.1.E-08)Q2d(I,K)=1.E-08
-         SUBT(I,K)=0.
-         SUBQ(I,K)=0.
-         OUTT(I,K)=0.
-         OUTQ(I,K)=0.
-         OUTQC(I,K)=0.
-         OUTQCs(I,K)=0.
-         OUTTS(I,K)=0.
-         OUTQS(I,K)=0.
-         TN(I,K)=t2d(i,k)+(RTHFTEN(i,k,j)+RTHRATEN(i,k,j)+RTHBLTEN(i,k,j)) &
-                          *pi(i,k,j)*dt
-         QO(I,K)=q2d(i,k)+(RQVFTEN(i,k,j)+RQVBLTEN(i,k,j))*dt
-         TSHALL(I,K)=t2d(i,k)+RTHBLTEN(i,k,j)*pi(i,k,j)*dt
-         DHDT(I,K)=cp*RTHBLTEN(i,k,j)*pi(i,k,j)+ XLV*RQVBLTEN(i,k,j)
-         QSHALL(I,K)=q2d(i,k)+RQVBLTEN(i,k,j)*dt
-         IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K)
-         IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08
-         cupclws(i,k) = 0.
-     ENDDO
-     ENDDO
-     if(use_excess.gt.0 .or. use_excess_sh.gt.0)then
-     DO I=ITS,ITF
-       ZRHO  = 100.*psur(i)/(287.04*(t2d(i,1)*(1.+0.608*q2d(i,1))))
-       !- LE and H fluxes 
-       PAHFS=-hfx(i,j) 
-       PQHFL=-qfx(i,j)/xlv 
-
-       !- buoyancy flux (H+LE)
-       ZKHVFL= (PAHFS/1004.64+0.608*t2d(i,1)*PQHFL)/ZRHO
-       !- height of the 1st level
-       PGEOH = zo(i,1)-ht(i,j) 
-       !-convective-scale velocity w*
-       ZWS = max(0.,0.001-1.5*0.41*ZKHVFL*PGEOH/T2D(i,1))
-
-       if(ZWS > TINY(PGEOH)) then
-         !-convective-scale velocity w*
-         ZWS = 1.2*ZWS**.3333
-         !- temperature excess 
-         ZTEXEC(i)     = MAX(-1.5*PAHFS/(ZRHO*ZWS*1004.64),0.0)
-         !- moisture  excess
-         ZQEXEC(i)     = MAX(-1.5*PQHFL/(ZRHO*ZWS),0.)
-       endif
-     ENDDO
-     endif  ! use_excess
-     DO K=kts,ktf
-     DO I=ITS,ITF
-         omeg(I,K,:)= -g*rho(i,k,j)*w(i,k,j)
-     enddo
-     enddo
-     do k=  kts+1,ktf-1
-     DO I = its,itf
-         if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then
-            dp=-.5*(p2d(i,k+1)-p2d(i,k-1))
-            umean(i)=umean(i)+us(i,k)*dp
-            vmean(i)=vmean(i)+vs(i,k)*dp
-            pmean(i)=pmean(i)+dp
-         endif
-     enddo
-     enddo
-      do n=1,ens4
-      DO K=kts,ktf-1
-      DO I = its,itf
-        dq=(q2d(i,k+1)-q2d(i,k))
-        mconv(i,n)=mconv(i,n)+omeg(i,k,n)*dq/g
-      enddo
-      ENDDO
-      ENDDO
-      do n=1,ens4
-      DO I = its,itf
-        if(mconv(i,n).lt.0.)mconv(i,n)=0.
-      ENDDO
-      ENDDO
-!
-!---- CALL CUMULUS PARAMETERIZATION
-!
-#if ( WRF_DFI_RADAR == 1 )
-      if(do_capsuppress == 1 ) then
-        DO I= its,itf
-            cap_suppress_j(i)=cap_suppress_loc(i,j)
-        ENDDO
-      endif
-#endif
-      CALL CUP_gf(zo,outqc,j,AAEQ,T2d,Q2d,TER11,subm,TN,QO,PO,PRET,&
-           P2d,OUTT,OUTQ,DT,itimestep,PSUR,US,VS,tcrit,iens, &
-           ztexec,zqexec,ccn,ccnclean,rhoi,dx,mconv,omeg,  &
-           maxiens,maxens,maxens2,maxens3,ensdim,                 &
-           APRi_GR,APRi_W,APRi_MC,APRi_ST,APRi_AS,                &
-           APRi_CAPMA,APRi_CAPME,APRi_CAPMI,kbcon,ktop,cupclw,    &
-           xfi_ens,pri_ens,XLANDi,gswi,subt,subq,        &
-           xlv,r_v,cp,g,ichoice,ipr,jpr,ierrc,ens4,    &
-           beta,autoconv,aeroevap,itf,jtf,ktf,training, &
-#if ( WRF_DFI_RADAR == 1 )
-           do_capsuppress,cap_suppress_j,                         &             
-#endif
-           use_excess,its,ite, jts,jte, kts,kte                               &
-                                                             )
-
-      CALL neg_check(j,subt,subq,dt,q2d,outq,outt,outqc,pret,its,ite,kts,kte,itf,ktf)
-       if(ishallow_g3 == 1 )then
-
-
-!
-! this turns off shallow convection when deep convection is active
-!
-!      do i=its,ite
-!       if(pret(i).gt.0.)then
-!           ierrs(i)=1
-!           aaeq(i)=-100.
-!       endif
-!      enddo
-   call CUP_gf_sh(xmbs,zo,OUTQCs,J,AAEQ,T2D,Q2D,TER11,                    &
-              Tshall,Qshall,P2d,PRET,P2d,OUTTS,OUTQS,DT,itimestep,PSUR,US,VS,    &
-              TCRIT,ztexec,zqexec,ccn,ccnclean,rhoi,dx,dhdt, &
-              kpbli,kbcons,ktops,cupclws,k22s,         &   !-lxz
-              xlandi,gswi,tscl_kf,               &
-              xlv,r_v,cp,g,ichoice,0,0,ierrs,ierrcs,         &
-              autoconv,itf,jtf,ktf,               &
-              use_excess_sh,its,ite, jts,jte, kts,kte &
-                                                              )
-        endif
-
-
-
-            if(j.lt.jbegc.or.j.gt.jendc)go to 100
-             if(ishallow_g3.eq.1)then
-               DO I=ibegc,iendc
-                 xmb_shallow(i,j)=xmbs(i)
-                 k22_shallow(i,j)=k22s(i)
-                 kbcon_shallow(i,j)=kbcons(i)
-                 ktop_shallow(i,j)=ktops(i)
-                 ktop_deep(i,j) = ktop(i)
-               ENDDO
-            endif
-            DO I=ibegc,iendc
-              cuten(i)=0.
-              if(pret(i).gt.0.)then
-                 cuten(i)=1.
-!                raincv(i,j)=pret(i)*dt
-              endif
-            ENDDO
-            DO I=ibegc,iendc
-            DO K=kts,ktf
-               RTHCUTEN(I,K,J)=(outts(i,k)+(subt(i,k)+outt(i,k))*cuten(i))/pi(i,k,j)
-               RQVCUTEN(I,K,J)=outqs(i,k)+(subq(i,k)+outq(i,k))*cuten(i)
-            ENDDO
-            ENDDO
-            DO I=ibegc,iendc
-              if(pret(i).gt.0.)then
-                 raincv(i,j)=pret(i)*dt
-                 pratec(i,j)=pret(i)
-                 rkbcon = kte+kts - kbcon(i)
-                 rktop  = kte+kts -  ktop(i)
-                 if (ktop(i)  > HTOP(i,j)) HTOP(i,j) = ktop(i)+.001
-                 if (kbcon(i) < HBOT(i,j)) HBOT(i,j) = kbcon(i)+.001
-              endif
-            ENDDO
-            DO n= 1,ensdim
-            DO I= ibegc,iendc
-              xf_ens(i,j,n)=xfi_ens(i,j,n)
-              pr_ens(i,j,n)=pri_ens(i,j,n)
-            ENDDO
-            ENDDO
-            DO I= ibegc,iendc
-               APR_GR(i,j)=apri_gr(i,j)
-               APR_w(i,j)=apri_w(i,j)
-               APR_mc(i,j)=apri_mc(i,j)
-               APR_st(i,j)=apri_st(i,j)
-               APR_as(i,j)=apri_as(i,j)
-               APR_capma(i,j)=apri_capma(i,j)
-               APR_capme(i,j)=apri_capme(i,j)
-               APR_capmi(i,j)=apri_capmi(i,j)
-               mass_flux(i,j)=massi_flx(i,j)
-               edt_out(i,j)=edti_out(i,j)
-            ENDDO
-            IF(PRESENT(RQCCUTEN)) THEN
-              IF ( F_QC ) THEN
-                DO K=kts,ktf
-                DO I=ibegc,iendc
-                   RQCCUTEN(I,K,J)=outqcs(i,k)+outqc(I,K)*cuten(i)
-                   IF ( PRESENT( GDC ) ) GDC(I,K,J)=cupclws(i,k)+CUPCLW(I,K)*cuten(i)
-                   IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=0.
-                ENDDO
-                ENDDO
-              ENDIF
-            ENDIF
-
-!......     QSTEN STORES GRAUPEL TENDENCY IF IT EXISTS, OTHERISE SNOW (V2)     
-
-            IF(PRESENT(RQICUTEN).AND.PRESENT(RQCCUTEN))THEN
-              IF (F_QI) THEN
-                DO K=kts,ktf
-                  DO I=ibegc,iendc
-                   if(t2d(i,k).lt.258.)then
-                      RQICUTEN(I,K,J)=outqcs(i,k)+outqc(I,K)*cuten(i)
-                      RQCCUTEN(I,K,J)=0.
-                      IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=cupclws(i,k)+CUPCLW(I,K)*cuten(i)
-                   else
-                      RQICUTEN(I,K,J)=0.
-                      RQCCUTEN(I,K,J)=outqcs(i,k)+outqc(I,K)*cuten(i)
-                      IF ( PRESENT( GDC ) ) GDC(I,K,J)=cupclws(i,k)+CUPCLW(I,K)*cuten(i)
-                   endif
-                ENDDO
-                ENDDO
-              ENDIF
-            ENDIF
-
- 100    continue
-
-   END SUBROUTINE GFDRV
-
-
-   SUBROUTINE CUP_gf(zo,OUTQC,J,AAEQ,T,Q,Z1,sub_mas,                    &
-              TN,QO,PO,PRE,P,OUTT,OUTQ,DTIME,ktau,PSUR,US,VS,    &
-              TCRIT,iens,                                        &
-              ztexec,zqexec,ccn,ccnclean,rho,dx,mconv,                               &
-              omeg,maxiens,                          &
-              maxens,maxens2,maxens3,ensdim,                           &
-              APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                       &
-              APR_CAPMA,APR_CAPME,APR_CAPMI,kbcon,ktop,cupclw,         &   !-lxz
-              xf_ens,pr_ens,xland,gsw,subt,subq,               &
-              xl,rv,cp,g,ichoice,ipr,jpr,ierrc,ens4,         &
-              beta,autoconv,aeroevap,itf,jtf,ktf,training,               &
-#if ( WRF_DFI_RADAR == 1 )
-              do_capsuppress,cap_suppress_j,                         &             
-#endif
-              use_excess,its,ite, jts,jte, kts,kte                                &
-                                                )
-
-   IMPLICIT NONE
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        autoconv,aeroevap,itf,jtf,ktf,ktau,training,use_excess,        &
-        its,ite, jts,jte, kts,kte,ipr,jpr,ens4
-     integer, intent (in   )              ::                           &
-        j,ensdim,maxiens,maxens,maxens2,maxens3,ichoice,iens
-  !
-  ! 
-  !
-     real,    dimension (its:ite,jts:jte,1:ensdim)                     &
-        ,intent (inout)                   ::                           &
-        xf_ens,pr_ens
-     real,    dimension (its:ite,jts:jte)                              &
-        ,intent (inout )                  ::                           &
-               APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA,     &
-               APR_CAPME,APR_CAPMI
-    real, dimension( its:ite , jts:jte )                               &
-          :: weight_GR,weight_W,weight_MC,weight_ST,weight_AS
-     real,    dimension (its:ite,jts:jte)                              &
-        ,intent (in   )                   ::                           &
-               gsw
-
-#if ( WRF_DFI_RADAR == 1 )
-    INTEGER,      INTENT(IN   ) ,OPTIONAL   :: do_capsuppress
-    REAL, DIMENSION( its:ite ) :: cap_suppress_j
-#endif
-
-  ! outtem = output temp tendency (per s)
-  ! outq   = output q tendency (per s)
-  ! outqc  = output qc tendency (per s)
-  ! pre    = output precip
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (inout  )                   ::                           &
-        OUTT,OUTQ,OUTQC,subt,subq,sub_mas,cupclw
-     real,    dimension (its:ite)                                      &
-        ,intent (out  )                   ::                           &
-        pre
-     integer,    dimension (its:ite)                                   &
-        ,intent (out  )                   ::                           &
-        kbcon,ktop
-!    integer,    dimension (its:ite)                                   &
-!       ,intent (in  )                   ::                           &
-!       kpbl
-  !
-  ! basic environmental input includes moisture convergence (mconv)
-  ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off
-  ! convection for this call only and at that particular gridpoint
-  !
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-        rho,T,PO,P,US,VS,tn
-     real,    dimension (its:ite,kts:kte,1:ens4)                       &
-        ,intent (inout   )                   ::                           &
-        omeg
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (inout)                   ::                           &
-         Q,QO
-     real, dimension (its:ite)                                         &
-        ,intent (in   )                   ::                           &
-        ztexec,zqexec,ccn,Z1,PSUR,AAEQ,xland
-     real, dimension (its:ite,1:ens4)                                         &
-        ,intent (in   )                   ::                           &
-        mconv
-
-       
-       real                                                            &
-        ,intent (in   )                   ::                           &
-        beta,dx,ccnclean,dtime,tcrit,xl,cp,rv,g
-
-
-!
-!  local ensemble dependent variables in this routine
-!
-     real,    dimension (its:ite,1:maxens)  ::                         &
-        xaa0_ens
-     real,    dimension (1:maxens)  ::                                 &
-        mbdt_ens
-     real,    dimension (1:maxens2) ::                                 &
-        edt_ens
-     real,    dimension (its:ite,1:maxens2) ::                         &
-        edtc
-     real,    dimension (its:ite,kts:kte,1:maxens2) ::                 &
-        dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens,subt_ens,subq_ens
-!
-!
-!
-!***************** the following are your basic environmental
-!                  variables. They carry a "_cup" if they are
-!                  on model cloud levels (staggered). They carry
-!                  an "o"-ending (z becomes zo), if they are the forced
-!                  variables. They are preceded by x (z becomes xz)
-!                  to indicate modification by some typ of cloud
-!
-  ! z           = heights of model levels
-  ! q           = environmental mixing ratio
-  ! qes         = environmental saturation mixing ratio
-  ! t           = environmental temp
-  ! p           = environmental pressure
-  ! he          = environmental moist static energy
-  ! hes         = environmental saturation moist static energy
-  ! z_cup       = heights of model cloud levels
-  ! q_cup       = environmental q on model cloud levels
-  ! qes_cup     = saturation q on model cloud levels
-  ! t_cup       = temperature (Kelvin) on model cloud levels
-  ! p_cup       = environmental pressure
-  ! he_cup = moist static energy on model cloud levels
-  ! hes_cup = saturation moist static energy on model cloud levels
-  ! gamma_cup = gamma on model cloud levels
-!
-!
-  ! hcd = moist static energy in downdraft
-  ! zd normalized downdraft mass flux
-  ! dby = buoancy term
-  ! entr = entrainment rate
-  ! zd   = downdraft normalized mass flux
-  ! entr= entrainment rate
-  ! hcd = h in model cloud
-  ! bu = buoancy term
-  ! zd = normalized downdraft mass flux
-  ! gamma_cup = gamma on model cloud levels
-  ! qcd = cloud q (including liquid water) after entrainment
-  ! qrch = saturation q in cloud
-  ! pwd = evaporate at that level
-  ! pwev = total normalized integrated evaoprate (I2)
-  ! entr= entrainment rate
-  ! z1 = terrain elevation
-  ! entr = downdraft entrainment rate
-  ! jmin = downdraft originating level
-  ! kdet = level above ground where downdraft start detraining
-  ! psur        = surface pressure
-  ! z1          = terrain elevation
-  ! pr_ens = precipitation ensemble
-  ! xf_ens = mass flux ensembles
-  ! massfln = downdraft mass flux ensembles used in next timestep
-  ! omeg = omega from large scale model
-  ! mconv = moisture convergence from large scale model
-  ! zd      = downdraft normalized mass flux
-  ! zu      = updraft normalized mass flux
-  ! dir     = "storm motion"
-  ! mbdt    = arbitrary numerical parameter
-  ! dtime   = dt over which forcing is applied
-  ! iact_gr_old = flag to tell where convection was active
-  ! kbcon       = LFC of parcel from k22
-  ! k22         = updraft originating level
-  ! icoic       = flag if only want one closure (usually set to zero!)
-  ! dby = buoancy term
-  ! ktop = cloud top (output)
-  ! xmb    = total base mass flux
-  ! hc = cloud moist static energy
-  ! hkb = moist static energy at originating level
-
-     real,    dimension (its:ite,kts:kte) ::                           &
-        entr_rate_2d,mentrd_rate_2d,he,hes,qes,z,                      &
-        heo,heso,qeso,zo,                                              &
-        xhe,xhes,xqes,xz,xt,xq,                                        &
-
-        qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,      &
-        qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,     &
-        tn_cup,                                                        &
-        xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup,xp_cup,xgamma_cup,     &
-        xt_cup,                                                        &
-
-        xlamue,dby,qc,qrcd,pwd,pw,hcd,qcd,dbyd,hc,qrc,zu,zd,clw_all,   &
-        dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco,zuo,zdo,      &
-        xdby,xqc,xqrcd,xpwd,xpw,xhcd,xqcd,xhc,xqrc,xzu,xzd,            &
-
-  ! cd  = detrainment function for updraft
-  ! cdd = detrainment function for downdraft
-  ! dellat = change of temperature per unit mass flux of cloud ensemble
-  ! dellaq = change of q per unit mass flux of cloud ensemble
-  ! dellaqc = change of qc per unit mass flux of cloud ensemble
-
-        cd,cdd,DELLAH,DELLAQ,DELLAT,DELLAQC,dsubt,dsubh,dsubq
-
-  ! aa0 cloud work function for downdraft
-  ! edt = epsilon
-  ! aa0     = cloud work function without forcing effects
-  ! aa1     = cloud work function with forcing effects
-  ! xaa0    = cloud work function with cloud effects (ensemble dependent)
-  ! edt     = epsilon
-
-     real,    dimension (its:ite) ::                                   &
-       edt,edto,edtx,AA1,AA0,XAA0,HKB,                          &
-       HKBO,XHKB,QKB,QKBO,                                    &
-       XMB,XPWAV,XPWEV,PWAV,PWEV,PWAVO,                                &
-       PWEVO,BU,BUD,BUO,cap_max,xland1,                                    &
-       cap_max_increment,closure_n,psum,psumh,sig,zuhe
-     real,    dimension (its:ite,1:ens4) ::                                   &
-        axx
-     integer,    dimension (its:ite) ::                                &
-       kzdown,KDET,K22,KB,JMIN,kstabi,kstabm,K22x,        &   !-lxz
-       KBCONx,KBx,KTOPx,ierr,ierr2,ierr3,KBMAX
-
-     integer                              ::                           &
-       nall,iedt,nens,nens3,ki,I,K,KK,iresult
-     real                                 ::                           &
-      day,dz,dzo,mbdt,entr_rate,radius,entrd_rate,mentrd_rate,  &
-      zcutdown,edtmax,edtmin,depth_min,zkbmax,z_detr,zktop,      &
-      massfld,dh,cap_maxs,trash,frh,xlamdd
-      real detdo1,detdo2,entdo,dp,subin,detdo,entup,                &
-      detup,subdown,entdoj,entupk,detupk,totmas
-      real :: power_entr,zustart,zufinal,dzm1,dzp1
-
-
-     integer :: k1,k2,kbegzu,kfinalzu,kstart,jmini,levadj
-     logical :: keep_going
-     real xff_shal(9),blqe,xkshal
-     character*50 :: ierrc(its:ite)
-     real,    dimension (its:ite,kts:kte) ::                           &
-       up_massentr,up_massdetr,dd_massentr,dd_massdetr                 &
-      ,up_massentro,up_massdetro,dd_massentro,dd_massdetro
-     real,    dimension (kts:kte) :: smth
-
-      levadj=5
-      power_entr=2. ! 1.2
-      zustart=.1
-      zufinal=1.
-      day=86400.
-      do i=its,itf
-        closure_n(i)=16.
-        xland1(i)=1.
-        if(xland(i).gt.1.5)xland1(i)=0.
-        cap_max_increment(i)=25.
-        ierrc(i)=" "
-!       cap_max_increment(i)=1.
-      enddo
-!
-!--- specify entrainmentrate and detrainmentrate
-!--- highly tuneable !
-!
-      entr_rate=7.e-5
-      radius=.1/entr_rate
-      frh=3.14*(radius*radius)/dx/dx
-      if(frh .gt. 0.7)then
-         frh=.7
-         radius=sqrt(frh*dx*dx/3.14)
-         entr_rate=.2/radius
-      endif
-      do i=its,itf
-         sig(i)=(1.-frh)**2
-      enddo
-!      sig(:)=1.
-
-!
-!--- entrainment of mass
-!
-      mentrd_rate=entr_rate ! 0.
-      xlamdd=mentrd_rate
-!
-!--- initial detrainmentrates
-!
-      do k=kts,ktf
-      do i=its,itf
-        z(i,k)=zo(i,k)
-        xz(i,k)=zo(i,k)
-        cupclw(i,k)=0.
-        cd(i,k)=1.*entr_rate
-        cdd(i,k)=xlamdd
-        hcdo(i,k)=0.
-        qrcdo(i,k)=0.
-        dellaqc(i,k)=0.
-      enddo
-      enddo
-!
-!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft
-!    base mass flux
-!
-      edtmax=1.
-      edtmin=.1
-!
-!--- minimum depth (m), clouds must have
-!
-      depth_min=1000.   ! gg 500
-!
-!--- maximum depth (mb) of capping 
-!--- inversion (larger cap = no convection)
-!
-      cap_maxs=75.
-      DO i=its,itf
-        kbmax(i)=1
-        aa0(i)=0.
-        aa1(i)=0.
-        edt(i)=0.
-        kstabm(i)=ktf-1
-        IERR(i)=0
-        IERR2(i)=0
-        IERR3(i)=0
-      enddo
-      do i=its,itf
-          cap_max(i)=cap_maxs
-        iresult=0
-
-      enddo
-!
-!--- max height(m) above ground where updraft air can originate
-!
-      zkbmax=4000.
-!
-!--- height(m) above which no downdrafts are allowed to originate
-!
-      zcutdown=3000.
-!
-!--- depth(m) over which downdraft detrains all its mass
-!
-      z_detr=1250.   !1000
-!
-      do nens=1,maxens
-         mbdt_ens(nens)=(float(nens)-3.)*dtime*1.e-3+dtime*5.E-03
-      enddo
-      do nens=1,maxens2
-         edt_ens(nens)=.95-float(nens)*.01
-      enddo
-!
-!--- environmental conditions, FIRST HEIGHTS
-!
-      do i=its,itf
-         if(ierr(i).ne.20)then
-            do k=1,maxens*maxens2*maxens3
-               xf_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0.
-               pr_ens(i,j,(iens-1)*maxens*maxens2*maxens3+k)=0.
-            enddo
-         endif
-      enddo
-!
-!--- calculate moist static energy, heights, qes
-!
-      call cup_env(z,qes,he,hes,t,q,p,z1, &
-           psur,ierr,tcrit,-1,xl,cp,   &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, &
-           psur,ierr,tcrit,-1,xl,cp,   &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-
-!
-!--- environmental values on cloud levels
-!
-      call cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup,he_cup, &
-           hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, &
-           ierr,z1,xl,rv,cp,          &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, &
-           heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur,  &
-           ierr,z1,xl,rv,cp,          &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      do i=its,itf
-        if(ierr(i).eq.0)then
-        if(aaeq(i).lt.-0.1)then
-           ierr(i)=20
-        endif
-!
-      do k=kts,ktf
-        if(zo_cup(i,k).gt.zkbmax+z1(i))then
-          kbmax(i)=k
-          go to 25
-        endif
-      enddo
- 25   continue
-!
-!--- level where detrainment for downdraft starts
-!
-      do k=kts,ktf
-        if(zo_cup(i,k).gt.z_detr+z1(i))then
-          kdet(i)=k
-          go to 26
-        endif
-      enddo
- 26   continue
-!
-      endif
-      enddo
-
-!
-!
-!
-!------- DETERMINE LEVEL WITH HIGHEST MOIST STATIC ENERGY CONTENT - K22
-!
-      CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22,ierr, &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-       DO 36 i=its,itf
-         IF(ierr(I).eq.0)THEN
-           frh=q_cup(i,k22(i))/qes_cup(i,k22(i))
-           IF(omeg(i,k22(i),1).lt.0. .and. frh.ge.0.99 .and. sig(i).lt.0.091)ierr(i)=1200
-           IF(K22(I).GE.KBMAX(i))THEN
-             ierr(i)=2
-             ierrc(i)="could not find k22"
-           ENDIF
-         ENDIF
- 36   CONTINUE
-!
-!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
-!
-      do i=its,itf
-       IF(ierr(I).eq.0)THEN
-         if(use_excess == 2) then
-             k1=max(1,k22(i)-1)
-             k2=k22(i)+1
-             hkb(i) =he_cup(i,k22(i)) ! sum(he_cup(i,k1:k2))/float(k2-k1+1)+xl*zqexec(i)+cp*ztexec(i)
-             hkbo(i)=sum(heo_cup(i,k1:k2))/float(k2-k1+1)+xl*zqexec(i)+cp*ztexec(i)
-        else if(use_excess <= 1)then
-         hkb(i)=he_cup(i,k22(i)) ! +float(use_excess)*(xl*zqexec(i)+cp*ztexec(i))
-         hkbo(i)=heo_cup(i,k22(i))+float(use_excess)*(xl*zqexec(i)+cp*ztexec(i))
-        endif  ! excess
-       endif ! ierr
-      enddo
-
-
-      call cup_kbcon(ierrc,cap_max_increment,1,k22,kbcon,heo_cup,heso_cup, &
-           hkbo,ierr,kbmax,po_cup,cap_max, &
-           xl,cp,ztexec,zqexec,use_excess,       &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-!
-!--- increase detrainment in stable layers
-!
-      CALL cup_minimi(HEso_cup,Kbcon,kstabm,kstabi,ierr,  &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      DO i=its,itf
-         IF(ierr(I).eq.0)THEN
-         do k=k22(i),kbcon(i)
-         frh=q_cup(i,k)/qes_cup(i,k)
-         if(omeg(i,k,1).lt.-1.e-6 .and. frh.ge.0.99 .and. sig(i).lt.0.091)ierr(i)=1200
-         enddo
-         endif
-      enddo
-!
-! the following section insures a smooth normalized mass flux profile. See Grell
-! and Freitas (2013) for a description
-!
-      DO i=its,itf
-         IF(ierr(I).eq.0)THEN
-            do k=kts,ktf
-               frh = min(qo_cup(i,k)/qeso_cup(i,k),1.)
-               entr_rate_2d(i,k)=entr_rate*(1.3-frh)
-            enddo
-            zuhe(i)=zustart
-            kstart=1
-            frh=(zufinal-zustart)/((float(kbcon(i)*kbcon(i)))-(float(kstart*kstart)))
-            dh=zuhe(i)-frh*(float(kstart*kstart))
-            do k=kstart,kbcon(i)-1
-             dz=z_cup(i,k+1)-z_cup(i,k)
-!            cd(i,k)=entr_rate_2d(i,kbcon(i))
-             if(p_cup(i,k).gt. p_cup(i,kstabi(i)))cd(i,k)=1.e-6
-             entr_rate_2d(i,k)=((frh*(float((k+1)*(k+1)))+dh)/zuhe(i)-1.+cd(i,k)*dz)/dz
-             zuhe(i)=zuhe(i)+entr_rate_2d(i,k)*dz*zuhe(i)-cd(i,k)*dz*zuhe(i)
-            enddo
-            kbegzu=kstabi(i)+4
-            kbegzu=min(kbegzu,ktf-1)
-            kfinalzu=kbegzu+1
-            do k=kts,ktf
-               cd(i,k)=entr_rate_2d(i,kbcon(i))
-            enddo
-               do k=kbcon(i),kbegzu
-                cd(i,k)=entr_rate_2d(i,kbcon(i))
-                if(p_cup(i,k).gt. p_cup(i,kstabi(i)))cd(i,k)=1.e-6
-                dz=z_cup(i,k+1)-z_cup(i,k)
-                zuhe(i)=zuhe(i)+entr_rate_2d(i,k)*dz*zuhe(i)-cd(i,k)*dz*zuhe(i)
-               enddo
-         do k=kstabi(i),ktf-2
-          if((hkb(i)-hes_cup(i,k)).lt.0)then
-              kfinalzu=k-3
-              go to 411
-          endif
-         enddo
-411      continue
-             kfinalzu=max(kfinalzu,kbegzu+1)
-             kfinalzu=min(kfinalzu,ktf-1)
-            frh=-(0.2-zuhe(i))/((float(kfinalzu*kfinalzu))-(float(kbegzu*kbegzu)))
-            dh=zuhe(i)+frh*(float(kbegzu*kbegzu))
-               do k=kbegzu+1,kfinalzu
-                 dz=z_cup(i,k+1)-z_cup(i,k)
-                 cd(i,k)=-((-frh*(float((k+1)*(k+1)))+dh)/zuhe(i)-1.-entr_rate_2d(i,k)*dz)/dz
-                 zuhe(i)=zuhe(i)+entr_rate_2d(i,k)*dz*zuhe(i)-cd(i,k)*dz*zuhe(i)
-               enddo
-               do k=kfinalzu+1,ktf
-                   cd(i,k)=entr_rate_2d(i,k)
-               enddo
-               do k=kts+1,ktf-2
-                 dzm1=z_cup(i,k)-z_cup(i,k-1)
-                 dz=z_cup(i,k+1)-z_cup(i,k)
-                 dzp1=z_cup(i,k+2)-z_cup(i,k+1)
-                 smth(k)=.25*(dzm1*cd(i,k-1)+2.*dz*cd(i,k)+dzp1*cd(i,k+1))
-               enddo
-               do k=kts+1,ktf-2
-                 dzm1=z_cup(i,k)-z_cup(i,k-1)
-                 dz=z_cup(i,k+1)-z_cup(i,k)
-                 dzp1=z_cup(i,k+2)-z_cup(i,k+1)
-                 cd(i,k)=smth(k)/dz ! (.25*(dzm1+2.*dz+dzp1))
-               enddo
-
-            smth(:)=0.
-            do k=2,ktf-2
-                 dzm1=z_cup(i,k)-z_cup(i,k-1)
-                 dz=z_cup(i,k+1)-z_cup(i,k)
-                 dzp1=z_cup(i,k+2)-z_cup(i,k+1)
-              smth(k)=.25*(dzm1*entr_rate_2d(i,k-1)+2.*dz*entr_rate_2d(i,k)+dzp1*entr_rate_2d(i,k+1))
-            enddo
-            do k=2,ktf-2 
-                 dz=z_cup(i,k+1)-z_cup(i,k)
-              entr_rate_2d(i,k)=smth(k)/dz
-            enddo
-            zuhe(i)=zustart
-            do k=2,kbegzu 
-              dz=z_cup(i,k+1)-z_cup(i,k)
-              frh=zuhe(i)
-              zuhe(i)=zuhe(i)+entr_rate_2d(i,k)*dz*zuhe(i)-cd(i,k)*dz*zuhe(i)
-            enddo
-         ENDIF
-       enddo
-
-!
-! calculate mass entrainment and detrainment
-!
-      do k=kts,ktf
-      do i=its,itf
-         hc(i,k)=0.
-         DBY(I,K)=0.
-         hco(i,k)=0.
-         DBYo(I,K)=0.
-      enddo
-      enddo
-      do i=its,itf
-       IF(ierr(I).eq.0)THEN
-         do k=1,kbcon(i)-1
-            hc(i,k)=hkb(i)
-            hco(i,k)=hkbo(i)
-         enddo
-         k=kbcon(i)
-         hc(i,k)=hkb(i)
-         DBY(I,Kbcon(i))=Hkb(I)-HES_cup(I,K)
-         hco(i,k)=hkbo(i)
-         DBYo(I,Kbcon(i))=Hkbo(I)-HESo_cup(I,K)
-       endif ! ierr
-      enddo
-!
-!
-      do i=its,itf
-         if(ierr(i).eq.0)then
-         zu(i,1)=zustart
-         zuo(i,1)=zustart
-!    mass entrainment and detrinament is defined on model levels
-         do k=2,ktf-1
-          dz=zo_cup(i,k)-zo_cup(i,k-1)
-          up_massentro(i,k-1)=entr_rate_2d(i,k-1)*dz*zuo(i,k-1)
-          up_massdetro(i,k-1)=cd(i,k-1)*dz*zuo(i,k-1)
-          zuo(i,k)=zuo(i,k-1)+up_massentro(i,k-1)-up_massdetro(i,k-1)
-          if(zuo(i,k).lt.0.05)then
-             zuo(i,k)=.05
-             up_massdetro(i,k-1)=zuo(i,k-1)-.05  + up_massentro(i,k-1)
-             cd(i,k-1)=up_massdetro(i,k-1)/dz/zuo(i,k-1)
-          endif
-          zu(i,k)=zuo(i,k)
-          up_massentr(i,k-1)=up_massentro(i,k-1)
-          up_massdetr(i,k-1)=up_massdetro(i,k-1)
-         enddo
-         do k=kbcon(i)+1,ktf-1
-          hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ &
-                         up_massentr(i,k-1)*he(i,k-1))   /            &
-                         (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
-          dby(i,k)=hc(i,k)-hes_cup(i,k)
-          hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ &
-                         up_massentro(i,k-1)*heo(i,k-1))   /            &
-                         (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1))
-          dbyo(i,k)=hco(i,k)-heso_cup(i,k)
-         enddo
-         do k=kbcon(i)+1,ktf
-          if(dbyo(i,k).lt.0)then
-              ktop(i)=k-1
-              go to 41
-          endif
-         enddo
-41       continue
-         if(ktop(i).lt.kbcon(i)+2)ierr(i)=5
-         do k=ktop(i)+1,ktf
-           HC(i,K)=hes_cup(i,k)
-           HCo(i,K)=heso_cup(i,k)
-           DBY(I,K)=0.
-           DBYo(I,K)=0.
-           zu(i,k)=0.
-           zuo(i,k)=0.
-           cd(i,k)=0.
-           entr_rate_2d(i,k)=0.
-           up_massentr(i,k)=0.
-           up_massdetr(i,k)=0.
-           up_massentro(i,k)=0.
-           up_massdetro(i,k)=0.
-         enddo
-      endif
-      enddo
-!
-      DO 37 i=its,itf
-         kzdown(i)=0
-         if(ierr(i).eq.0)then
-            zktop=(zo_cup(i,ktop(i))-z1(i))*.6
-            zktop=min(zktop+z1(i),zcutdown+z1(i))
-            do k=kts,ktf
-              if(zo_cup(i,k).gt.zktop)then
-                 kzdown(i)=k
-                 go to 37
-              endif
-              enddo
-         endif
- 37   CONTINUE
-!
-!--- DOWNDRAFT ORIGINATING LEVEL - JMIN
-!
-      call cup_minimi(HEso_cup,K22,kzdown,JMIN,ierr, &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      DO 100 i=its,itf
-         IF(ierr(I).eq.0)THEN
-!
-!--- check whether it would have buoyancy, if there where
-!--- no entrainment/detrainment
-!
-         jmini = jmin(i)
-         keep_going = .TRUE.
-         do while ( keep_going )
-           keep_going = .FALSE.
-           if ( jmini - 1 .lt. kdet(i)   ) kdet(i) = jmini-1
-           if ( jmini     .ge. ktop(i)-1 ) jmini = ktop(i) - 2
-           ki = jmini
-           hcdo(i,ki)=heso_cup(i,ki)
-           DZ=Zo_cup(i,Ki+1)-Zo_cup(i,Ki)
-           dh=0.
-           do k=ki-1,1,-1
-             hcdo(i,k)=heso_cup(i,jmini)
-             DZ=Zo_cup(i,K+1)-Zo_cup(i,K)
-             dh=dh+dz*(HCDo(i,K)-heso_cup(i,k))
-             if(dh.gt.0.)then
-               jmini=jmini-1
-               if ( jmini .gt. 5 ) then
-                 keep_going = .TRUE.
-               else
-                 ierr(i) = 9
-                 ierrc(i) = "could not find jmini9"
-                 exit
-               endif
-             endif
-           enddo
-         enddo
-         jmin(i) = jmini 
-         if ( jmini .le. 5 ) then
-           ierr(i)=4
-           ierrc(i) = "could not find jmini4"
-         endif
-       ENDIF
-100   continue
-!
-! - Must have at least depth_min m between cloud convective base
-!     and cloud top.
-!
-      do i=its,itf
-         IF(ierr(I).eq.0)THEN
-            IF(-zo_cup(I,KBCON(I))+zo_cup(I,KTOP(I)).LT.depth_min)then
-               ierr(i)=6
-               ierrc(i)="cloud depth very shallow"
-            endif
-         endif
-      enddo
-
-!
-!--- normalized downdraft mass flux profile,also work on bottom detrainment
-!--- in this routine
-!
-      do k=kts,ktf
-      do i=its,itf
-       zd(i,k)=0.
-       zdo(i,k)=0.
-       cdd(i,k)=0.
-       dd_massentr(i,k)=0.
-       dd_massdetr(i,k)=0.
-       dd_massentro(i,k)=0.
-       dd_massdetro(i,k)=0.
-       hcdo(i,k)=heso_cup(i,k)
-       dbydo(i,k)=0.
-      enddo
-      enddo
-      do i=its,itf
-          bud(i)=0.
-          IF(ierr(I).eq.0)then
-            mentrd_rate_2d(i,:)=mentrd_rate
-            cdd(i,1:jmin(i))=xlamdd
-            cdd(i,jmin(i))=0.
-! start from dd origin
-            zd(i,jmin(i))=0.2
-            zdo(i,jmin(i))=0.2
-            frh=(zdo(i,jmin(i))-1.)/(-float((jmin(i)-levadj)*(jmin(i)-levadj)) &
-                                    +float(jmin(i)*jmin(i)))
-            dh=zdo(i,jmin(i))-frh*float(jmin(i)*jmin(i))
-            zuhe(i)=zdo(i,jmin(i))
-            do ki=jmin(i)-1,jmin(i)-levadj,-1
-             cdd(i,ki)=0.
-             dz=z_cup(i,ki+1)-z_cup(i,ki)
-             mentrd_rate_2d(i,ki)=((frh*float(ki*ki)+dh)/zuhe(i)-1.)/dz
-             zuhe(i)=zuhe(i)+mentrd_rate_2d(i,ki)*dz*zuhe(i)
-            enddo
-! now we know the max zd, for detrainment we will go back to beta at level 1
-            kstart=max(kbcon(i),kdet(i))-1
-            kstart=min(jmin(i)-levadj,kstart)
-            kstart=max(2,kstart)
-            if(kstart.lt.jmin(i)-levadj-1)then
-              do ki=jmin(i)-levadj-1,kstart,-1
-                dz=z_cup(i,ki+1)-z_cup(i,ki)
-                mentrd_rate_2d(i,ki)=mentrd_rate
-                cdd(i,ki)=xlamdd
-                zuhe(i)=zuhe(i)-cdd(i,ki)*dz*zuhe(i)+mentrd_rate_2d(i,ki)*dz*zuhe(i)
-              enddo
-            endif
-            frh=(zuhe(i)-beta)/(float(kstart*kstart)-1.)
-            dh=beta-frh
-            mentrd_rate_2d(i,kstart)=0.
-            do ki=kstart+1,1,-1
-             mentrd_rate_2d(i,ki)=0.
-             dz=z_cup(i,ki+1)-z_cup(i,ki)
-             cdd(i,ki)=max(0.,(1.-(frh*float(ki*ki)+dh)/zuhe(i))/dz)
-             zuhe(i)=zuhe(i)-cdd(i,ki)*dz*zuhe(i)
-!            if(i.eq.ipr.and.j.eq.jpr)write(0,*)'low cd ',ki,zuhe(i),cdd(i,ki)
-            enddo
-
-! now that we have entrainment and detrainment rates, 
-! calculate downdraft mass terms
-!
-            do ki=jmin(i)-1,1,-1
-               mentrd_rate=mentrd_rate_2d(i,ki)
-               dzo=zo_cup(i,ki+1)-zo_cup(i,ki)
-               dd_massentro(i,ki)=mentrd_rate*dzo*zdo(i,ki+1)
-               dd_massdetro(i,ki)=cdd(i,ki)*dzo*zdo(i,ki+1)
-               zdo(i,ki)=zdo(i,ki+1)+dd_massentro(i,ki)-dd_massdetro(i,ki)
-            enddo
-! downdraft moist static energy + moisture budget
-            dbydo(i,jmin(i))=hcdo(i,jmin(i))-heso_cup(i,jmin(i))
-            bud(i)=dbydo(i,jmin(i))*(zo_cup(i,jmin(i)+1)-zo_cup(i,jmin(i)))
-            do ki=jmin(i)-1,1,-1
-             dzo=zo_cup(i,ki+1)-zo_cup(i,ki)
-             hcdo(i,ki)=(hcdo(i,ki+1)*zdo(i,ki+1)                       &
-                         -.5*dd_massdetro(i,ki)*hcdo(i,ki+1)+ &
-                        dd_massentro(i,ki)*heo(i,ki))   /            &
-                        (zdo(i,ki+1)-.5*dd_massdetro(i,ki)+dd_massentro(i,ki))
-             dbydo(i,ki)=hcdo(i,ki)-heso_cup(i,ki)
-!            if(i.eq.ipr.and.j.eq.jpr)write(0,*)'ki,bud = ',ki,bud(i),hcdo(i,ki)
-             bud(i)=bud(i)+dbydo(i,ki)*dzo
-            enddo
-          endif
-
-        if(bud(i).gt.0)then
-          ierr(i)=7
-          ierrc(i)='downdraft is not negatively buoyant '
-        endif
-      enddo
-!
-!--- calculate moisture properties of downdraft
-!
-      call cup_dd_moisture_new(ierrc,zdo,hcdo,heso_cup,qcdo,qeso_cup, &
-           pwdo,qo_cup,zo_cup,dd_massentro,dd_massdetro,jmin,ierr,gammao_cup, &
-           pwevo,bu,qrcdo,qo,heo,tn_cup,1,xl, &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-!
-!--- calculate moisture properties of updraft
-!
-      call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo, &
-           ccnclean,p_cup,kbcon,ktop,cd,dbyo,clw_all, &
-           t_cup,qo,GAMMAo_cup,zuo,qeso_cup,k22,qo_cup,xl,        &
-           ZQEXEC,use_excess,ccn,rho,up_massentr,up_massdetr,psum,psumh,&
-           autoconv,aeroevap,1,itf,jtf,ktf,j,ipr,jpr, &
-           its,ite, jts,jte, kts,kte)
-      do k=kts,ktf
-      do i=its,itf
-         cupclw(i,k)=qrco(i,k)
-      enddo
-      enddo
-!
-!--- calculate workfunctions for updrafts
-!
-      call cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, &
-           kbcon,ktop,ierr,           &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      call cup_up_aa0(aa1,zo,zuo,dbyo,GAMMAo_CUP,tn_cup, &
-           kbcon,ktop,ierr,           &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      do i=its,itf
-         if(ierr(i).eq.0)then
-           if(aa1(i).eq.0.)then
-               ierr(i)=17
-               ierrc(i)="cloud work function zero"
-           endif
-         endif
-      enddo
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-
-       do i=1,ens4
-       axx(:,i)=aa1(:)
-       enddo
-
-!
-!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
-!
-      call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo, &
-           pwo,ccn,pwevo,edtmax,edtmin,maxens2,edtc,psum,psumh, &
-           ccnclean,rho,aeroevap,itf,jtf,ktf,j,ipr,jpr, &
-           its,ite, jts,jte, kts,kte)
-      do 250 iedt=1,maxens2
-        do i=its,itf
-         if(ierr(i).eq.0)then
-         edt(i)=edtc(i,iedt)
-         edto(i)=edtc(i,iedt)
-         edtx(i)=edtc(i,iedt)
-         if(maxens2.eq.3)then
-            edt(i)=edtc(i,3)
-            edto(i)=edtc(i,3)
-            edtx(i)=edtc(i,3)
-         endif
-         endif
-        enddo
-        do k=kts,ktf
-        do i=its,itf
-           subt_ens(i,k,iedt)=0.
-           subq_ens(i,k,iedt)=0.
-           dellat_ens(i,k,iedt)=0.
-           dellaq_ens(i,k,iedt)=0.
-           dellaqc_ens(i,k,iedt)=0.
-           pwo_ens(i,k,iedt)=0.
-        enddo
-        enddo
-!
-!
-!--- change per unit mass that a model cloud would modify the environment
-!
-!--- 1. in bottom layer
-!
-      do k=kts,ktf
-      do i=its,itf
-        dellah(i,k)=0.
-        dsubt(i,k)=0.
-        dsubh(i,k)=0.
-        dellaq(i,k)=0.
-        dsubq(i,k)=0.
-      enddo
-      enddo
-!
-!----------------------------------------------  cloud level ktop
-!
-!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!
-!----------------------------------------------  cloud level k+2
-!
-!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1
-!
-!----------------------------------------------  cloud level k+1
-!
-!- - - - - - - - - - - - - - - - - - - - - - - - model level k
-!
-!----------------------------------------------  cloud level k
-!
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!
-!----------------------------------------------  cloud level 3
-!
-!- - - - - - - - - - - - - - - - - - - - - - - - model level 2
-!
-!----------------------------------------------  cloud level 2
-!
-!- - - - - - - - - - - - - - - - - - - - - - - - model level 1
-
-      do i=its,itf
-        if(ierr(i).eq.0)then
-         dp=100.*(po_cup(i,1)-po_cup(i,2))
-         dellah(i,1)=(edto(i)*zdo(i,2)*hcdo(i,2)   &
-                     -edto(i)*zdo(i,2)*heo_cup(i,2))*g/dp
-         dellaq(i,1)=(edto(i)*zdo(i,2)*qrcdo(i,2)   &
-                     -edto(i)*zdo(i,2)*qo_cup(i,2))*g/dp
-         dsubt(i,1)=0.
-         dsubq(i,1)=0.
-
-         do k=kts+1,ktop(i)
-! these three are only used at or near mass detrainment and/or entrainment levels
-            entupk=0.
-            detupk=0.
-            entdoj=0.
-! detrainment and entrainment for fowndrafts
-            detdo=edto(i)*dd_massdetro(i,k)
-            entdo=edto(i)*dd_massentro(i,k)
-! entrainment/detrainment for updraft
-            entup=up_massentro(i,k)
-            detup=up_massdetro(i,k)
-! subsidence by downdrafts only
-            subin=-zdo(i,k+1)*edto(i)
-            subdown=-zdo(i,k)*edto(i)
-!
-!         SPECIAL LEVELS
-!
-            if(k.eq.jmin(i))then
-               entdoj=edto(i)*zdo(i,k)
-            endif
-            if(k.eq.ktop(i))then
-               detupk=zuo(i,ktop(i))
-               subin=0.
-               subdown=0.
-               detdo=0.
-               entdo=0.
-               entup=0.
-               detup=0.
-            endif
-            totmas=subin-subdown+detup-entup-entdo+ &
-             detdo-entupk-entdoj+detupk+zuo(i,k+1)-zuo(i,k)
-!               print *,'*********************',k,totmas
-!              write(0,123)k,subin+zuo(i,k+1),subdown-zuo(i,k),detup,entup, &
-!                          detdo,entdo,entupk,detupk
-!             write(8,*)'totmas = ',k,totmas
-            if(abs(totmas).gt.1.e-6)then
-               write(0,*)'*********************',i,j,k,totmas
-               write(0,123)k,subin,subdown,detup,entup, &
-                           detdo,entdo,entupk,detupk
-123     formAT(1X,i2,8E12.4)
-!        call wrf_error_fatal ( 'totmas .gt.1.e-6' )
-            endif
-            dp=100.*(po_cup(i,k)-po_cup(i,k+1))
-            dellah(i,k)=(detup*.5*(HCo(i,K+1)+HCo(i,K)) &
-                    +detdo*.5*(HCDo(i,K+1)+HCDo(i,K)) &
-                    -entup*heo(i,k) &
-                    -entdo*heo(i,k) &
-                    +subin*heo_cup(i,k+1) &
-                    -subdown*heo_cup(i,k) &
-                    +detupk*(hco(i,ktop(i))-heo_cup(i,ktop(i)))    &
-                    -entupk*heo_cup(i,k22(i)) &
-                    -entdoj*heo_cup(i,jmin(i)) &
-                     )*g/dp
-            dellaq(i,k)=(detup*.5*(qco(i,K+1)+qco(i,K)-qrco(i,k+1)-qrco(i,k)) &
-                    +detdo*.5*(qrcdo(i,K+1)+qrcdo(i,K)) &
-                    -entup*qo(i,k) &
-                    -entdo*qo(i,k) &
-                    +subin*qo_cup(i,k+1) &
-                    -subdown*qo_cup(i,k) &
-                    +detupk*(qco(i,ktop(i))-qrco(i,ktop(i))-qo_cup(i,ktop(i)))    &
-                    -entupk*qo_cup(i,k22(i)) &
-                    -entdoj*qo_cup(i,jmin(i)) &
-                     )*g/dp
-!
-! updraft subsidence only
-!
-           if(k.lt.ktop(i))then
-             dsubt(i,k)=(zuo(i,k+1)*heo_cup(i,k+1) &
-                    -zuo(i,k)*heo_cup(i,k))*g/dp
-             dsubq(i,k)=(zuo(i,k+1)*qo_cup(i,k+1) &
-                    -zuo(i,k)*qo_cup(i,k))*g/dp
-           endif
-!
-       enddo   ! k
-
-        endif
-      enddo
-!
-!-- take out cloud liquid water for detrainment
-!
-      do k=kts,ktf-1
-      do i=its,itf
-       dellaqc(i,k)=0.
-       if(ierr(i).eq.0)then
-         if(k.eq.ktop(i)-0)dellaqc(i,k)= &
-                      .01*zuo(i,ktop(i))*qrco(i,ktop(i))* &
-                      9.81/(po_cup(i,k)-po_cup(i,k+1))
-         if(k.lt.ktop(i).and.k.gt.kbcon(i))then
-           dz=zo_cup(i,k+1)-zo_cup(i,k)
-           dellaqc(i,k)=.01*9.81*up_massdetro(i,k)*.5*(qrco(i,k)+qrco(i,k+1))/ &
-                        (po_cup(i,k)-po_cup(i,k+1))
-         endif
-         dellaqc(i,k)=max(0.,dellaqc(i,k))
-       endif
-      enddo
-      enddo
-!
-!--- using dellas, calculate changed environmental profiles
-!
-      mbdt=mbdt_ens(1)
-      do i=its,itf
-      xaa0_ens(i,:)=0.
-      enddo
-
-      do k=kts,ktf
-      do i=its,itf
-         dellat(i,k)=0.
-         if(ierr(i).eq.0)then
-!           if(i.eq.ipr.and.j.eq.jpr.and.k.eq.kts)write(0,*)'mbdt = ',mbdt,mbdt_ens,dtime
-            dsubh(i,k)=dsubt(i,k)
-            XHE(I,K)=(dsubt(i,k)+DELLAH(I,K))*MBDT+HEO(I,K)
-            XQ(I,K)=(dsubq(i,k)+DELLAQ(I,K)+dellaqc(i,k))*MBDT+QO(I,K)
-            DELLAT(I,K)=(1./cp)*(DELLAH(I,K)-xl*DELLAQ(I,K))
-            dSUBT(I,K)=(1./cp)*(dsubt(i,k)-xl*dsubq(i,k))
-            XT(I,K)= (DELLAT(I,K)+dsubt(i,k)-dellaqc(i,k)*xl/cp)*MBDT+TN(I,K)
-            IF(XQ(I,K).LE.0.)XQ(I,K)=1.E-08
-         ENDIF
-      enddo
-      enddo
-      do i=its,itf
-      if(ierr(i).eq.0)then
-      xhkb(i)=hkbo(i)+(dsubh(i,k22(i))+DELLAH(I,K22(i)))*MBDT
-      XHE(I,ktf)=HEO(I,ktf)
-      XQ(I,ktf)=QO(I,ktf)
-      XT(I,ktf)=TN(I,ktf)
-      IF(XQ(I,ktf).LE.0.)XQ(I,ktf)=1.E-08
-      endif
-      enddo
-!
-!--- calculate moist static energy, heights, qes
-!
-      call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, &
-           psur,ierr,tcrit,-1,xl,cp,   &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-!
-!--- environmental values on cloud levels
-!
-      call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, &
-           xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur,   &
-           ierr,z1,xl,rv,cp,          &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-!
-!
-!**************************** static control
-!
-!--- moist static energy inside cloud
-!
-!     do i=its,itf
-!       if(ierr(i).eq.0)then
-!         xhkb(i)=xhe(i,k22(i))
-!       endif
-!     enddo
-      do k=kts,ktf
-      do i=its,itf
-         xhc(i,k)=0.
-         xDBY(I,K)=0.
-      enddo
-      enddo
-      do i=its,itf
-        if(ierr(i).eq.0)then
-!        if(use_excess == 2) then
-!            k1=max(1,k22(i)-1)
-!            k2=max(1,min(kbcon(i)-1,k22(i)+1))
-!            k1=1
-!            k2=k22(i)+1
-!            xhkb(i) =sum(xhe_cup(i,k1:k2))/float(k2-k1+1)+xl*zqexec(i)+cp*ztexec(i)
-!        else if(use_excess <= 1) then
-!            xhkb(i)=xhe_cup(i,k22(i))+float(use_excess)*(xl*zqexec(i)+cp*ztexec(i))
-
-!        endif
-         do k=1,kbcon(i)-1
-            xhc(i,k)=xhkb(i)
-         enddo
-         k=kbcon(i)
-         xhc(i,k)=xhkb(i)
-         xDBY(I,Kbcon(i))=xHkb(I)-xHES_cup(I,K)
-        endif !ierr
-      enddo
-!
-!
-      do i=its,itf
-      if(ierr(i).eq.0)then
-      xzu(i,:)=zuo(i,:)
-      do k=kbcon(i)+1,ktop(i)
-       xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1)+ &
-                         up_massentro(i,k-1)*xhe(i,k-1))   /            &
-                         (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1))
-       xdby(i,k)=xhc(i,k)-xhes_cup(i,k)
-      enddo
-      do k=ktop(i)+1,ktf
-           xHC(i,K)=xhes_cup(i,k)
-           xDBY(I,K)=0.
-           xzu(i,k)=0.
-      enddo
-      endif
-      enddo
-
-!
-!--- workfunctions for updraft
-!
-      call cup_up_aa0(xaa0,xz,xzu,xdby,GAMMA_CUP,xt_cup, &
-           kbcon,ktop,ierr,           &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      do 200 nens=1,maxens
-      do i=its,itf 
-         if(ierr(i).eq.0)then
-           xaa0_ens(i,nens)=xaa0(i)
-           nall=(iens-1)*maxens3*maxens*maxens2 &
-                +(iedt-1)*maxens*maxens3 &
-                +(nens-1)*maxens3
-           do k=kts,ktf
-              if(k.le.ktop(i))then
-                 do nens3=1,maxens3
-                 if(nens3.eq.7)then
-!--- b=0
-                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)  &
-!                                +edto(i)*pwdo(i,k)             &
-                                    +pwo(i,k) 
-!--- b=beta
-                 else if(nens3.eq.8)then
-                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
-                                    pwo(i,k)
-!--- b=beta/2
-                 else if(nens3.eq.9)then
-                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)  &
-!                                +.5*edto(i)*pwdo(i,k)          &
-                                 +  pwo(i,k)
-                 else
-                 pr_ens(i,j,nall+nens3)=pr_ens(i,j,nall+nens3)+ &
-                                    pwo(i,k) ! +edto(i)*pwdo(i,k)
-                 endif
-                 enddo
-              endif
-           enddo
-         if(pr_ens(i,j,nall+7).lt.1.e-6)then
-            ierr(i)=18
-            ierrc(i)="total normalized condensate too small"
-!           if(i.eq.ipr.and.j.eq.jpr)write(0,*)ierr(i),ierrc(i)
-            do nens3=1,maxens3
-               pr_ens(i,j,nall+nens3)=0.
-            enddo
-         endif
-         do nens3=1,maxens3
-           if(pr_ens(i,j,nall+nens3).lt.1.e-4)then
-            pr_ens(i,j,nall+nens3)=0.
-           endif
-         enddo
-         endif
-!     if(i.eq.ipr.and.j.eq.jpr)write(0,*)'ierrc = ',ierr(i),ierrc(i)
-      enddo
- 200  continue
-!
-!--- LARGE SCALE FORCING
-!
-!
-!------- CHECK wether aa0 should have been zero, assuming this 
-!        ensemble is chosen
-!
-!
-      do i=its,itf
-         ierr2(i)=ierr(i)
-         ierr3(i)=ierr(i)
-         k22x(i)=k22(i)
-      enddo
-       if(maxens.gt.0)then
-!     CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22x,ierr, &
-!          itf,jtf,ktf, &
-!          its,ite, jts,jte, kts,kte)
-      call cup_kbcon(ierrc,cap_max_increment,2,k22x,kbconx,heo_cup, &
-           heso_cup,hkbo,ierr2,kbmax,po_cup,cap_max, &
-           xl,cp,ztexec,zqexec,use_excess,       &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      call cup_kbcon(ierrc,cap_max_increment,3,k22x,kbconx,heo_cup, &
-           heso_cup,hkbo,ierr3,kbmax,po_cup,cap_max, &
-           xl,cp,ztexec,zqexec,use_excess,       &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      endif
-!
-!--- calculate cloud base mass flux
-!
-
-      call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt_ens,dtime,   &
-           ierr,ierr2,ierr3,xf_ens,j,'deeps',axx,                 &
-           maxens,iens,iedt,maxens2,maxens3,mconv,            &
-           po_cup,ktop,omeg,zdo,k22,zuo,pr_ens,edto,kbcon,    &
-           ensdim,ichoice,     &
-           ipr,jpr,itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte,ens4,ktau)
-!
-      do k=kts,ktf
-      do i=its,itf
-        if(ierr(i).eq.0)then
-           subt_ens(i,k,iedt)=dsubt(i,k)
-           subq_ens(i,k,iedt)=dsubq(i,k)
-           dellat_ens(i,k,iedt)=dellat(i,k)
-           dellaq_ens(i,k,iedt)=dellaq(i,k)
-           dellaqc_ens(i,k,iedt)=dellaqc(i,k)
-           pwo_ens(i,k,iedt)=pwo(i,k)+edt(i)*pwdo(i,k)
-        else 
-           subt_ens(i,k,iedt)=0.
-           subq_ens(i,k,iedt)=0.
-           dellat_ens(i,k,iedt)=0.
-           dellaq_ens(i,k,iedt)=0.
-           dellaqc_ens(i,k,iedt)=0.
-           pwo_ens(i,k,iedt)=0.
-        endif
-      enddo
-      enddo
- 250  continue
-!
-!--- FEEDBACK
-!
-       call cup_output_ens_3d(xf_ens,ierr,dellat_ens,dellaq_ens, &
-            dellaqc_ens,subt_ens,subq_ens,subt,subq,outt,     &
-            outq,outqc,zuo,sub_mas,pre,pwo_ens,xmb,ktop,      &
-            j,'deep',maxens2,maxens,iens,ierr2,ierr3,         &
-            pr_ens,maxens3,ensdim,                    &
-            sig,APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                &
-            APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1,   &
-            weight_GR,weight_W,weight_MC,weight_ST,weight_AS,training, &
-            ipr,jpr,itf,jtf,ktf,                        &
-            its,ite, jts,jte, kts,kte  )
-      k=1
-      do i=its,itf
-          if(ierr(i).eq.0) PRE(I)=MAX(PRE(I),0.)
-      enddo
-!
-!---------------------------done------------------------------
-!
-
-   END SUBROUTINE CUP_gf
-
-
-   SUBROUTINE cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, &
-              pw,ccn,pwev,edtmax,edtmin,maxens2,edtc,psum2,psumh, &
-              ccnclean,rho,aeroevap,itf,jtf,ktf,j,ipr,jpr,          &
-              its,ite, jts,jte, kts,kte                     )
-
-   IMPLICIT NONE
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        j,ipr,jpr,aeroevap,itf,jtf,ktf,           &
-        its,ite, jts,jte, kts,kte
-     integer, intent (in   )              ::                           &
-        maxens2
-  !
-  ! ierr error value, maybe modified in this routine
-  !
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-        rho,us,vs,z,p,pw
-     real,    dimension (its:ite,1:maxens2)                            &
-        ,intent (out  )                   ::                           &
-        edtc
-     real,    dimension (its:ite)                                      &
-        ,intent (out  )                   ::                           &
-        edt
-     real,    dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        pwav,pwev,ccn,psum2,psumh
-     real                                                              &
-        ,intent (in   )                   ::                           &
-        ccnclean,edtmax,edtmin
-     integer, dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        ktop,kbcon
-     integer, dimension (its:ite)                                      &
-        ,intent (inout)                   ::                           &
-        ierr
-!
-!  local variables in this routine
-!
-
-     integer i,k,kk
-     real    einc,pef,pefb,prezk,zkbc
-     real,    dimension (its:ite)         ::                           &
-      vshear,sdp,vws
-     real :: prop_c,pefc,aeroadd,alpha3,beta3,rhoc
-     prop_c=8. !10.386
-     alpha3 = 1.9
-     beta3  = -1.13
-     pefc=0.
-
-!
-!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
-!
-! */ calculate an average wind shear over the depth of the cloud
-!
-       do i=its,itf
-        edt(i)=0.
-        vws(i)=0.
-        sdp(i)=0.
-        vshear(i)=0.
-       enddo
-       do k=1,maxens2
-       do i=its,itf
-        edtc(i,k)=0.
-       enddo
-       enddo
-       do kk = kts,ktf-1
-         do 62 i=its,itf
-          IF(ierr(i).ne.0)GO TO 62
-          if (kk .le. min0(ktop(i),ktf) .and. kk .ge. kbcon(i)) then
-             vws(i) = vws(i)+ &
-              (abs((us(i,kk+1)-us(i,kk))/(z(i,kk+1)-z(i,kk))) &
-          +   abs((vs(i,kk+1)-vs(i,kk))/(z(i,kk+1)-z(i,kk)))) * &
-              (p(i,kk) - p(i,kk+1))
-            sdp(i) = sdp(i) + p(i,kk) - p(i,kk+1)
-          endif
-          if (kk .eq. ktf-1)vshear(i) = 1.e3 * vws(i) / sdp(i)
-   62   continue
-       end do
-      do i=its,itf
-         IF(ierr(i).eq.0)then
-            pef=(1.591-.639*VSHEAR(I)+.0953*(VSHEAR(I)**2) &
-               -.00496*(VSHEAR(I)**3))
-            if(pef.gt.0.9)pef=0.9
-            if(pef.lt.0.1)pef=0.1
-!
-!--- cloud base precip efficiency
-!
-            zkbc=z(i,kbcon(i))*3.281e-3
-            prezk=.02
-            if(zkbc.gt.3.)then
-               prezk=.96729352+zkbc*(-.70034167+zkbc*(.162179896+zkbc &
-               *(- 1.2569798E-2+zkbc*(4.2772E-4-zkbc*5.44E-6))))
-            endif
-            if(zkbc.gt.25)then
-               prezk=2.4
-            endif
-            pefb=1./(1.+prezk)
-            if(pefb.gt.0.9)pefb=0.9
-            if(pefb.lt.0.1)pefb=0.1
-            EDT(I)=1.-.5*(pefb+pef)
-            if(aeroevap.gt.1)then
-               aeroadd=(ccnclean**beta3)*((psumh(i))**(alpha3-1)) !*1.e6
-!              if(i.eq.ipr.and.j.eq.jpr)write(0,*)'edt',ccnclean,psumh(i),aeroadd
-!              prop_c=.9/aeroadd
-               prop_c=.5*(pefb+pef)/aeroadd
-               aeroadd=(ccn(i)**beta3)*((psum2(i))**(alpha3-1)) !*1.e6
-!              if(i.eq.ipr.and.j.eq.jpr)write(0,*)'edt',ccn(i),psum2(i),aeroadd,prop_c
-               aeroadd=prop_c*aeroadd
-               pefc=aeroadd
-               if(pefc.gt.0.9)pefc=0.9
-               if(pefc.lt.0.1)pefc=0.1
-               EDT(I)=1.-pefc
-               if(aeroevap.eq.2)EDT(I)=1.-.25*(pefb+pef+2.*pefc)
-            endif
-
-
-!--- edt here is 1-precipeff!
-            einc=.2*edt(i)
-            do k=1,maxens2
-                edtc(i,k)=edt(i)+float(k-2)*einc
-            enddo
-         endif
-      enddo
-      do i=its,itf
-         IF(ierr(i).eq.0)then
-            do k=1,maxens2
-               EDTC(I,K)=-EDTC(I,K)*PWAV(I)/PWEV(I)
-               IF(EDTC(I,K).GT.edtmax)EDTC(I,K)=edtmax
-               IF(EDTC(I,K).LT.edtmin)EDTC(I,K)=edtmin
-            enddo
-         endif
-      enddo
-
-   END SUBROUTINE cup_dd_edt
-
-
-   SUBROUTINE cup_dd_moisture_new(ierrc,zd,hcd,hes_cup,qcd,qes_cup,    &
-              pwd,q_cup,z_cup,dd_massentr,dd_massdetr,jmin,ierr,            &
-              gamma_cup,pwev,bu,qrcd,                        &
-              q,he,t_cup,iloop,xl,           &
-              itf,jtf,ktf,                     &
-              its,ite, jts,jte, kts,kte                     )
-
-   IMPLICIT NONE
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-                                  itf,jtf,ktf,           &
-                                  its,ite, jts,jte, kts,kte
-  ! cdd= detrainment function 
-  ! q = environmental q on model levels
-  ! q_cup = environmental q on model cloud levels
-  ! qes_cup = saturation q on model cloud levels
-  ! hes_cup = saturation h on model cloud levels
-  ! hcd = h in model cloud
-  ! bu = buoancy term
-  ! zd = normalized downdraft mass flux
-  ! gamma_cup = gamma on model cloud levels
-  ! mentr_rate = entrainment rate
-  ! qcd = cloud q (including liquid water) after entrainment
-  ! qrch = saturation q in cloud
-  ! pwd = evaporate at that level
-  ! pwev = total normalized integrated evaoprate (I2)
-  ! entr= entrainment rate 
-  !
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-        zd,t_cup,hes_cup,hcd,qes_cup,q_cup,z_cup,                      &
-        dd_massentr,dd_massdetr,gamma_cup,q,he 
-     real                                                              &
-        ,intent (in   )                   ::                           &
-        xl
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        iloop
-     integer, dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        jmin
-     integer, dimension (its:ite)                                      &
-        ,intent (inout)                   ::                           &
-        ierr
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (out  )                   ::                           &
-        qcd,qrcd,pwd
-     real,    dimension (its:ite)                                      &
-        ,intent (out  )                   ::                           &
-        pwev,bu
-     character*50 :: ierrc(its:ite)
-!
-!  local variables in this routine
-!
-
-     integer                              ::                           &
-        i,k,ki
-     real                                 ::                           &
-        dh,dz,dqeva
-
-      do i=its,itf
-         bu(i)=0.
-         pwev(i)=0.
-      enddo
-      do k=kts,ktf
-      do i=its,itf
-         qcd(i,k)=0.
-         qrcd(i,k)=0.
-         pwd(i,k)=0.
-      enddo
-      enddo
-!
-!
-!
-      do 100 i=its,itf
-      IF(ierr(I).eq.0)then
-      k=jmin(i)
-      DZ=Z_cup(i,K+1)-Z_cup(i,K)
-      qcd(i,k)=q_cup(i,k)
-      DH=HCD(I,k)-HES_cup(I,K)
-      if(dh.lt.0)then
-        QRCD(I,K)=(qes_cup(i,k)+(1./XL)*(GAMMA_cup(i,k) &
-                  /(1.+GAMMA_cup(i,k)))*DH)
-        else
-          qrcd(i,k)=qes_cup(i,k)
-        endif
-      pwd(i,jmin(i))=zd(i,jmin(i))*min(0.,qcd(i,k)-qrcd(i,k))
-      qcd(i,k)=qrcd(i,k)
-      pwev(i)=pwev(i)+pwd(i,jmin(i))
-!
-      bu(i)=dz*dh
-      do ki=jmin(i)-1,1,-1
-         DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki)
-         qcd(i,ki)=(qcd(i,ki+1)*zd(i,ki+1)                          &
-                  -.5*dd_massdetr(i,ki)*qcd(i,ki+1)+ &
-                  dd_massentr(i,ki)*q(i,ki))   /            &
-                  (zd(i,ki+1)-.5*dd_massdetr(i,ki)+dd_massentr(i,ki))
-!        write(0,*)'qcd in dd_moi = ',qcd(i,ki)
-
-!
-!--- to be negatively buoyant, hcd should be smaller than hes!
-!--- ideally, dh should be negative till dd hits ground, but that is not always
-!--- the case
-!
-         DH=HCD(I,ki)-HES_cup(I,Ki)
-         bu(i)=bu(i)+dz*dh
-         QRCD(I,Ki)=qes_cup(i,ki)+(1./XL)*(GAMMA_cup(i,ki) &
-                  /(1.+GAMMA_cup(i,ki)))*DH
-         dqeva=qcd(i,ki)-qrcd(i,ki)
-         if(dqeva.gt.0.)then
-          dqeva=0.
-          qrcd(i,ki)=qcd(i,ki)
-         endif
-         pwd(i,ki)=zd(i,ki)*dqeva
-         qcd(i,ki)=qrcd(i,ki)
-         pwev(i)=pwev(i)+pwd(i,ki)
-!        if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then
-!         print *,'in cup_dd_moi ', hcd(i,ki),HES_cup(I,Ki),dh,dqeva
-!        endif
-      enddo
-!
-!--- end loop over i
-       if(pwev(I).eq.0.and.iloop.eq.1)then
-!        print *,'problem with buoy in cup_dd_moisture',i
-         ierr(i)=7
-         ierrc(i)="problem with buoy in cup_dd_moisture"
-       endif
-       if(BU(I).GE.0.and.iloop.eq.1)then
-!        print *,'problem with buoy in cup_dd_moisture',i
-         ierr(i)=7
-         ierrc(i)="problem2 with buoy in cup_dd_moisture"
-       endif
-      endif
-100    continue
-
-   END SUBROUTINE cup_dd_moisture_new
-
-   SUBROUTINE cup_env(z,qes,he,hes,t,q,p,z1,                 &
-              psur,ierr,tcrit,itest,xl,cp,                   &
-              itf,jtf,ktf,                     &
-              its,ite, jts,jte, kts,kte                     )
-
-   IMPLICIT NONE
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        itf,jtf,ktf,           &
-        its,ite, jts,jte, kts,kte
-  !
-  ! ierr error value, maybe modified in this routine
-  ! q           = environmental mixing ratio
-  ! qes         = environmental saturation mixing ratio
-  ! t           = environmental temp
-  ! tv          = environmental virtual temp
-  ! p           = environmental pressure
-  ! z           = environmental heights
-  ! he          = environmental moist static energy
-  ! hes         = environmental saturation moist static energy
-  ! psur        = surface pressure
-  ! z1          = terrain elevation
-  ! 
-  !
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-        p,t,q
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (out  )                   ::                           &
-        he,hes,qes
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (inout)                   ::                           &
-        z
-     real,    dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        psur,z1
-     real                                                              &
-        ,intent (in   )                   ::                           &
-        xl,cp
-     integer, dimension (its:ite)                                      &
-        ,intent (inout)                   ::                           &
-        ierr
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        itest
-!
-!  local variables in this routine
-!
-
-     integer                              ::                           &
-       i,k,iph
-      real, dimension (1:2) :: AE,BE,HT
-      real, dimension (its:ite,kts:kte) :: tv
-      real :: tcrit,e,tvbar
-!      real, external :: satvap
-!      real :: satvap
-
-
-      HT(1)=XL/CP
-      HT(2)=2.834E6/CP
-      BE(1)=.622*HT(1)/.286
-      AE(1)=BE(1)/273.+ALOG(610.71)
-      BE(2)=.622*HT(2)/.286
-      AE(2)=BE(2)/273.+ALOG(610.71)
-!      print *, 'TCRIT = ', tcrit,its,ite
-      DO k=kts,ktf
-      do i=its,itf
-        if(ierr(i).eq.0)then
-!Csgb - IPH is for phase, dependent on TCRIT (water or ice)
-        IPH=1
-        IF(T(I,K).LE.TCRIT)IPH=2
-!       print *, 'AE(IPH),BE(IPH) = ',AE(IPH),BE(IPH),AE(IPH)-BE(IPH),T(i,k),i,k
-!       E=EXP(AE(IPH)-BE(IPH)/T(I,K))
-!       print *, 'P, E = ', P(I,K), E
-!       QES(I,K)=.622*E/(100.*P(I,K)-E)
-        e=satvap(t(i,k))
-        qes(i,k)=0.622*e/max(1.e-8,(p(i,k)-e))
-        IF(QES(I,K).LE.1.E-08)QES(I,K)=1.E-08
-        IF(QES(I,K).LT.Q(I,K))QES(I,K)=Q(I,K)
-!       IF(Q(I,K).GT.QES(I,K))Q(I,K)=QES(I,K)
-        TV(I,K)=T(I,K)+.608*Q(I,K)*T(I,K)
-        endif
-      enddo
-      enddo
-!
-!--- z's are calculated with changed h's and q's and t's
-!--- if itest=2
-!
-      if(itest.eq.1 .or. itest.eq.0)then
-         do i=its,itf
-           if(ierr(i).eq.0)then
-             Z(I,1)=max(0.,Z1(I))-(ALOG(P(I,1))- &
-                 ALOG(PSUR(I)))*287.*TV(I,1)/9.81
-           endif
-         enddo
-
-! --- calculate heights
-         DO K=kts+1,ktf
-         do i=its,itf
-           if(ierr(i).eq.0)then
-              TVBAR=.5*TV(I,K)+.5*TV(I,K-1)
-              Z(I,K)=Z(I,K-1)-(ALOG(P(I,K))- &
-               ALOG(P(I,K-1)))*287.*TVBAR/9.81
-           endif
-         enddo
-         enddo
-      else if(itest.eq.2)then
-         do k=kts,ktf
-         do i=its,itf
-           if(ierr(i).eq.0)then
-             z(i,k)=(he(i,k)-1004.*t(i,k)-2.5e6*q(i,k))/9.81
-             z(i,k)=max(1.e-3,z(i,k))
-           endif
-         enddo
-         enddo
-      else if(itest.eq.-1)then
-      endif
-!
-!--- calculate moist static energy - HE
-!    saturated moist static energy - HES
-!
-       DO k=kts,ktf
-       do i=its,itf
-         if(ierr(i).eq.0)then
-         if(itest.le.0)HE(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*Q(I,K)
-         HES(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*QES(I,K)
-         IF(HE(I,K).GE.HES(I,K))HE(I,K)=HES(I,K)
-         endif
-      enddo
-      enddo
-
-   END SUBROUTINE cup_env
-
-
-   SUBROUTINE cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup,   &
-              he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, &
-              ierr,z1,xl,rv,cp,                                &
-              itf,jtf,ktf,                       &
-              its,ite, jts,jte, kts,kte                       )
-
-   IMPLICIT NONE
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        itf,jtf,ktf,           &
-        its,ite, jts,jte, kts,kte
-  !
-  ! ierr error value, maybe modified in this routine
-  ! q           = environmental mixing ratio
-  ! q_cup       = environmental mixing ratio on cloud levels
-  ! qes         = environmental saturation mixing ratio
-  ! qes_cup     = environmental saturation mixing ratio on cloud levels
-  ! t           = environmental temp
-  ! t_cup       = environmental temp on cloud levels
-  ! p           = environmental pressure
-  ! p_cup       = environmental pressure on cloud levels
-  ! z           = environmental heights
-  ! z_cup       = environmental heights on cloud levels
-  ! he          = environmental moist static energy
-  ! he_cup      = environmental moist static energy on cloud levels
-  ! hes         = environmental saturation moist static energy
-  ! hes_cup     = environmental saturation moist static energy on cloud levels
-  ! gamma_cup   = gamma on cloud levels
-  ! psur        = surface pressure
-  ! z1          = terrain elevation
-  ! 
-  !
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-        qes,q,he,hes,z,p,t
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (out  )                   ::                           &
-        qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup
-     real,    dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        psur,z1
-     real                                                              &
-        ,intent (in   )                   ::                           &
-        xl,rv,cp
-     integer, dimension (its:ite)                                      &
-        ,intent (inout)                   ::                           &
-        ierr
-!
-!  local variables in this routine
-!
-
-     integer                              ::                           &
-       i,k
-
-
-      do k=kts,ktf
-      do i=its,itf
-        qes_cup(i,k)=0.
-        q_cup(i,k)=0.
-        hes_cup(i,k)=0.
-        he_cup(i,k)=0.
-        z_cup(i,k)=0.
-        p_cup(i,k)=0.
-        t_cup(i,k)=0.
-        gamma_cup(i,k)=0.
-      enddo
-      enddo
-      do k=kts+1,ktf
-      do i=its,itf
-        if(ierr(i).eq.0)then
-        qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k))
-        q_cup(i,k)=.5*(q(i,k-1)+q(i,k))
-        hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k))
-        he_cup(i,k)=.5*(he(i,k-1)+he(i,k))
-        if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k)
-        z_cup(i,k)=.5*(z(i,k-1)+z(i,k))
-        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)=(xl/cp)*(xl/(rv*t_cup(i,k) &
-                       *t_cup(i,k)))*qes_cup(i,k)
-        endif
-      enddo
-      enddo
-      do i=its,itf
-        if(ierr(i).eq.0)then
-        qes_cup(i,1)=qes(i,1)
-        q_cup(i,1)=q(i,1)
-!       hes_cup(i,1)=hes(i,1)
-!       he_cup(i,1)=he(i,1)
-        hes_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*qes(i,1)
-        he_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*q(i,1)
-        z_cup(i,1)=.5*(z(i,1)+z1(i))
-        p_cup(i,1)=.5*(p(i,1)+psur(i))
-        z_cup(i,1)=z1(i)
-        p_cup(i,1)=psur(i)
-        t_cup(i,1)=t(i,1)
-        gamma_cup(i,1)=xl/cp*(xl/(rv*t_cup(i,1) &
-                       *t_cup(i,1)))*qes_cup(i,1)
-        endif
-      enddo
-
-   END SUBROUTINE cup_env_clev
-
-
-   SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,&
-              xf_ens,j,name,axx,maxens,iens,iedt,maxens2,maxens3,mconv,    &
-              p_cup,ktop,omeg,zd,k22,zu,pr_ens,edt,kbcon,      &
-              ensdim,icoic,            &
-              ipr,jpr,itf,jtf,ktf,               &
-              its,ite, jts,jte, kts,kte,ens4,ktau                )
-
-   IMPLICIT NONE
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        ipr,jpr,itf,jtf,ktf,           &
-        its,ite, jts,jte, kts,kte,ens4,ktau
-     integer, intent (in   )              ::                           &
-        j,ensdim,maxens,iens,iedt,maxens2,maxens3
-  !
-  ! ierr error value, maybe modified in this routine
-  ! pr_ens = precipitation ensemble
-  ! xf_ens = mass flux ensembles
-  ! massfln = downdraft mass flux ensembles used in next timestep
-  ! omeg = omega from large scale model
-  ! mconv = moisture convergence from large scale model
-  ! zd      = downdraft normalized mass flux
-  ! zu      = updraft normalized mass flux
-  ! aa0     = cloud work function without forcing effects
-  ! aa1     = cloud work function with forcing effects
-  ! xaa0    = cloud work function with cloud effects (ensemble dependent)
-  ! edt     = epsilon
-  ! dir     = "storm motion"
-  ! mbdt    = arbitrary numerical parameter
-  ! dtime   = dt over which forcing is applied
-  ! iact_gr_old = flag to tell where convection was active
-  ! kbcon       = LFC of parcel from k22
-  ! k22         = updraft originating level
-  ! icoic       = flag if only want one closure (usually set to zero!)
-  ! name        = deep or shallow convection flag
-  !
-     real,    dimension (its:ite,jts:jte,1:ensdim)                     &
-        ,intent (inout)                   ::                           &
-        pr_ens
-     real,    dimension (its:ite,jts:jte,1:ensdim)                     &
-        ,intent (out  )                   ::                           &
-        xf_ens
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-        zd,zu,p_cup
-     real,    dimension (its:ite,kts:kte,1:ens4)                              &
-        ,intent (in   )                   ::                           &
-        omeg
-     real,    dimension (its:ite,1:maxens)                             &
-        ,intent (in   )                   ::                           &
-        xaa0
-     real,    dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        aa1,edt,xland
-     real,    dimension (its:ite,1:ens4)                                      &
-        ,intent (in   )                   ::                           &
-        mconv,axx
-     real,    dimension (its:ite)                                      &
-        ,intent (inout)                   ::                           &
-        aa0,closure_n
-     real,    dimension (1:maxens)                                     &
-        ,intent (in   )                   ::                           &
-        mbdt
-     real                                                              &
-        ,intent (in   )                   ::                           &
-        dtime
-     integer, dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        k22,kbcon,ktop
-     integer, dimension (its:ite)                                      &
-        ,intent (inout)                   ::                           &
-        ierr,ierr2,ierr3
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        icoic
-      character *(*), intent (in)         ::                           &
-       name
-!
-!  local variables in this routine
-!
-
-     real,    dimension (1:maxens3)       ::                           &
-       xff_ens3
-     real,    dimension (1:maxens)        ::                           &
-       xk
-     integer                              ::                           &
-       i,k,nall,n,ne,nens,nens3,iresult,iresultd,iresulte,mkxcrt,kclim
-     parameter (mkxcrt=15)
-     real                                 ::                           &
-       fens4,a1,massfld,a_ave,xff0,xff00,xxx,xomg,aclim1,aclim2,aclim3,aclim4
-     real,    dimension(1:mkxcrt)         ::                           &
-       pcrit,acrit,acritt
-
-     integer :: nall2,ixxx,irandom
-     integer,  dimension (8) :: seed
-     real, dimension (its:ite) :: ens_adj
-
-
-      DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,    &
-                 350.,300.,250.,200.,150./
-      DATA ACRIT/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216,       &
-                 .3151,.3677,.41,.5255,.7663,1.1686,1.6851/
-!  GDAS DERIVED ACRIT
-      DATA ACRITT/.203,.515,.521,.566,.625,.665,.659,.688,             &
-                  .743,.813,.886,.947,1.138,1.377,1.896/
-
-!
-       ens_adj=1.
-       seed=0
-       do i=its,itf
-        if(ierr(i).eq.0)then
-          seed(1)=int(aa0(i))
-          seed(2)=int(aa1(i))
-          exit
-        endif
-       enddo
-
-       nens=0
-       irandom=0
-       fens4=float(ens4)
-
-!--- LARGE SCALE FORCING
-!
-       DO 100 i=its,itf
-          if(name.eq.'deeps'.and.ierr(i).gt.995)then
-           aa0(i)=0.
-           ierr(i)=0
-          endif
-          IF(ierr(i).eq.0)then
-          ens_adj(i)=1.
-          if(ierr2(i).gt.0.and.ierr3(i).eq.0)ens_adj(i)=0. ! 2./3.
-          if(ierr2(i).gt.0.and.ierr3(i).gt.0)ens_adj(i)=0.
-!
-!---
-!
-             if(name.eq.'deeps')then
-!
-                a_ave=0.
-                do ne=1,ens4
-                  a_ave=a_ave+axx(i,ne)
-!               if(i.eq.ipr.and.j.eq.jpr)write(0,*)'in forcing, a_ave,axx(i,ne) = ',a_ave,axx(i,ne),maxens,xland(i)
-                enddo
-                a_ave=max(0.,a_ave/fens4)
-                a_ave=min(a_ave,aa1(i))
-                a_ave=max(0.,a_ave)
-                do ne=1,16
-                  xff_ens3(ne)=0.
-                enddo
-                xff0= (AA1(I)-AA0(I))/DTIME
-                xff_ens3(1)=max(0.,(AA1(I)-AA0(I))/dtime)
-                xff_ens3(2)=max(0.,(a_ave-AA0(I))/dtime)
-
-!               if(i.eq.ipr.and.j.eq.jpr)write(0,*)AA1(I),AA0(I),xff_ens3(1),xff_ens3(2),dtime
-                if(irandom.eq.1)then
-                   call random_number (xxx)
-                   ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8)))
-                   xff_ens3(3)=max(0.,(axx(i,ixxx)-AA0(I))/dtime)
-                   call random_number (xxx)
-                   ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8)))
-                   xff_ens3(13)=max(0.,(axx(i,ixxx)-AA0(I))/dtime)
-                else
-                   xff_ens3(3)=max(0.,(AA1(I)-AA0(I))/dtime)
-                   xff_ens3(13)=max(0.,(AA1(I)-AA0(I))/dtime)
-                endif
-!   
-!--- more original Arakawa-Schubert (climatologic value of aa0)
-!
-!
-!--- omeg is in bar/s, mconv done with omeg in Pa/s
-!     more like Brown (1979), or Frank-Cohen (199?)
-!
-                xff_ens3(14)=0.
-                do ne=1,ens4
-                  xff_ens3(14)=xff_ens3(14)-omeg(i,k22(i),ne)/(fens4*9.81)
-                enddo
-                if(xff_ens3(14).lt.0.)xff_ens3(14)=0.
-                xff_ens3(5)=0.
-                do ne=1,ens4
-                  xff_ens3(5)=xff_ens3(5)-omeg(i,kbcon(i),ne)/(fens4*9.81)
-                enddo
-                if(xff_ens3(5).lt.0.)xff_ens3(5)=0.
-!  
-! minimum below kbcon
-!
-                   xff_ens3(4)=-omeg(i,2,1)/9.81
-                   do k=2,kbcon(i)-1
-                   do ne=1,ens4
-                     xomg=-omeg(i,k,ne)/9.81
-                     if(xomg.lt.xff_ens3(4))xff_ens3(4)=xomg
-                   enddo
-                   enddo
-                   if(xff_ens3(4).lt.0.)xff_ens3(4)=0.
-!
-! max below kbcon
-                   xff_ens3(6)=-omeg(i,2,1)/9.81
-                   do k=2,kbcon(i)-1
-                   do ne=1,ens4
-                     xomg=-omeg(i,k,ne)/9.81
-                     if(xomg.gt.xff_ens3(6))xff_ens3(6)=xomg
-                   enddo
-                   enddo
-                   if(xff_ens3(6).lt.0.)xff_ens3(6)=0.
-                   xff_ens3(5)=xff_ens3(6)
-                   xff_ens3(4)=xff_ens3(6)
-!               if(i.eq.ipr.and.j.eq.jpr)write(0,*)xff_ens3(4),xff_ens3(5)
-!
-!--- more like Krishnamurti et al.; pick max and average values
-!
-                xff_ens3(7)=mconv(i,1)
-                xff_ens3(8)=mconv(i,1)
-                xff_ens3(9)=mconv(i,1)
-                if(ens4.gt.1)then
-                   do ne=2,ens4
-                      if (mconv(i,ne).gt.xff_ens3(7))xff_ens3(7)=mconv(i,ne)
-                   enddo
-                   do ne=2,ens4
-                      if (mconv(i,ne).lt.xff_ens3(8))xff_ens3(8)=mconv(i,ne)
-                   enddo
-                   do ne=2,ens4
-                      xff_ens3(9)=xff_ens3(9)+mconv(i,ne)
-                   enddo
-                   xff_ens3(9)=xff_ens3(9)/fens4
-                endif
-!               if(i.eq.ipr.and.j.eq.jpr)write(0,*)xff_ens3(7),xff_ens3(8)
-!
-                if(irandom.eq.1)then
-                   call random_number (xxx)
-                   ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8)))
-                   xff_ens3(15)=mconv(i,ixxx)
-                else
-                   xff_ens3(15)=mconv(i,1)
-                endif
-!
-!--- more like Fritsch Chappel or Kain Fritsch (plus triggers)
-!
-                xff_ens3(10)=AA0(i)/(60.*20.)
-                xff_ens3(11)=AA0(I)/(60.*20.)
-                xff_ens3(16)=AA0(I)/(60.*20.)
-                if(irandom.eq.1)then
-                   call random_number (xxx)
-                   ixxx=min(ens4,max(1,int(fens4*xxx+1.e-8)))
-                   xff_ens3(12)=AA0(I)/(60.*20.)
-                else
-                   xff_ens3(12)=AA0(I)/(60.*20.)
-                endif
-!  
-!--- more original Arakawa-Schubert (climatologic value of aa0)
-!
-!gtest
-                if(icoic.eq.0)then
-                if(xff0.lt.0.)then
-                     xff_ens3(1)=0.
-                     xff_ens3(2)=0.
-                     xff_ens3(3)=0.
-                     xff_ens3(13)=0.
-                     xff_ens3(10)=0.
-                     xff_ens3(11)=0.
-                     xff_ens3(12)=0.
-                endif
-                  if(xff0.lt.0 .and. xland(i).lt.0.1)then
-                     xff_ens3(:)=0.
-                  endif
-                endif
-
-!                  if(i.eq.ipr.and.j.eq.jpr)write(0,*)'xff_ens = ',i,j,ipr,jpr,xff_ens3
-
-
-                do nens=1,maxens
-                   XK(nens)=(XAA0(I,nens)-AA1(I))/MBDT(1)
-!                  if(i.eq.ipr.and.j.eq.jpr)write(0,*)'xks = ',xk(nens),XAA0(I,nens),AA1(I),mbdt
-                   if(xk(nens).le.0.and.xk(nens).gt.-1.e-2) &
-                           xk(nens)=-1.e-2
-                   if(xk(nens).gt.0.and.xk(nens).lt.1.e-2) &
-                           xk(nens)=1.e-2
-                enddo
-!
-!--- add up all ensembles
-!
-                do 350 ne=1,maxens
-!
-!--- for every xk, we have maxens3 xffs
-!--- iens is from outermost ensemble (most expensive!
-!
-!--- iedt (maxens2 belongs to it)
-!--- is from second, next outermost, not so expensive
-!
-!--- so, for every outermost loop, we have maxens*maxens2*3
-!--- ensembles!!! nall would be 0, if everything is on first
-!--- loop index, then ne would start counting, then iedt, then iens....
-!
-                   iresult=0
-                   iresultd=0
-                   iresulte=0
-                   nall=(iens-1)*maxens3*maxens*maxens2 &
-                        +(iedt-1)*maxens*maxens3 &
-                        +(ne-1)*maxens3
-!                 if(i.eq.ipr.and.j.eq.jpr)write(0,*)'maxens',ne,nall,iens,maxens3,maxens,maxens2,iedt
-!
-! over water, enfor!e small cap for some of the closures
-!
-                if(maxens.gt.0 .and. xland(i).lt.0.1)then
-                 if(ierr2(i).gt.0.or.ierr3(i).gt.0)then
-                      xff_ens3(1) =ens_adj(i)*xff_ens3(1)
-                      xff_ens3(2) =ens_adj(i)*xff_ens3(2)
-                      xff_ens3(3) =ens_adj(i)*xff_ens3(3)
-                      xff_ens3(13) =ens_adj(i)*xff_ens3(13)
-                      xff_ens3(10) =ens_adj(i)*xff_ens3(10)
-                      xff_ens3(11) =ens_adj(i)*xff_ens3(11)
-                      xff_ens3(12) =ens_adj(i)*xff_ens3(12)
-                      xff_ens3(16) =ens_adj(i)*xff_ens3(16)
-                      xff_ens3(7) =ens_adj(i)*xff_ens3(7)
-                      xff_ens3(8) =ens_adj(i)*xff_ens3(8)
-                      xff_ens3(9) =ens_adj(i)*xff_ens3(9)
-                      xff_ens3(15) =ens_adj(i)*xff_ens3(15)
-!                     xff_ens3(7) =0.
-!                     xff_ens3(8) =0.
-!                     xff_ens3(9) =0.
-                 endif
-                endif
-!
-! end water treatment
-!
-!
-!--- check for upwind convection
-!                  iresult=0
-                   massfld=0.
-
-                   IF(XK(ne).lt.0.and.xff0.gt.0.)iresultd=1
-                   iresulte=max(iresult,iresultd)
-                   iresulte=1
-                   if(iresulte.eq.1)then
-!
-!--- special treatment for stability closures
-!
-!                      if(i.eq.ipr.and.j.eq.jpr)write(0,*)'xffs = ',xff_ens3(1:16)
-
-                      if(xff0.ge.0.)then
-                         if(xff_ens3(1).gt.0)xf_ens(i,j,nall+1)=max(0.,-xff_ens3(1)/xk(ne))
-                         if(xff_ens3(2).gt.0)xf_ens(i,j,nall+2)=max(0.,-xff_ens3(2)/xk(ne))
-                         if(xff_ens3(3).gt.0)xf_ens(i,j,nall+3)=max(0.,-xff_ens3(3)/xk(ne))
-                         if(xff_ens3(13).gt.0)xf_ens(i,j,nall+13)=max(0.,-xff_ens3(13)/xk(ne))
-!                      if(i.eq.ipr.and.j.eq.jpr)write(0,*)'xf_ens(nall+1) ',i,j,nall,xf_ens(i,j,nall+1)
-                      endif
-!
-!--- if iresult.eq.1, following independent of xff0
-!
-                         xf_ens(i,j,nall+4)=max(0.,xff_ens3(4))
-                         xf_ens(i,j,nall+5)=max(0.,xff_ens3(5))
-                         xf_ens(i,j,nall+6)=max(0.,xff_ens3(6))
-                         xf_ens(i,j,nall+14)=max(0.,xff_ens3(14))
-                         a1=max(1.e-3,pr_ens(i,j,nall+7))
-                         xf_ens(i,j,nall+7)=max(0.,xff_ens3(7)/a1)
-!                      if(i.eq.ipr.and.j.eq.jpr)write(0,*)'a1 = ',xff_ens3(7),a1,xf_ens(i,j,nall+7)
-                         a1=max(1.e-3,pr_ens(i,j,nall+8))
-                         xf_ens(i,j,nall+8)=max(0.,xff_ens3(8)/a1)
-                         a1=max(1.e-3,pr_ens(i,j,nall+9))
-                         xf_ens(i,j,nall+9)=max(0.,xff_ens3(9)/a1)
-                         a1=max(1.e-3,pr_ens(i,j,nall+15))
-                         xf_ens(i,j,nall+15)=max(0.,xff_ens3(15)/a1)
-                         if(XK(ne).lt.0.)then
-                            xf_ens(i,j,nall+10)=max(0.,-xff_ens3(10)/xk(ne))
-                            xf_ens(i,j,nall+11)=max(0.,-xff_ens3(11)/xk(ne))
-                            xf_ens(i,j,nall+12)=max(0.,-xff_ens3(12)/xk(ne))
-                            xf_ens(i,j,nall+16)=max(0.,-xff_ens3(16)/xk(ne))
-                         endif
-                      if(icoic.ge.1)then
-                      closure_n(i)=0.
-                      xf_ens(i,j,nall+1)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+2)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+3)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+4)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+5)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+6)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+7)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+8)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+9)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+10)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+11)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+12)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+13)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+14)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+15)=xf_ens(i,j,nall+icoic)
-                      xf_ens(i,j,nall+16)=xf_ens(i,j,nall+icoic)
-                      endif
-!
-! 16 is a randon pick from the oher 15
-!
-                if(irandom.eq.1)then
-                   call random_number (xxx)
-                   ixxx=min(15,max(1,int(15.*xxx+1.e-8)))
-                   xf_ens(i,j,nall+16)=xf_ens(i,j,nall+ixxx)
-!               else
-!                  xf_ens(i,j,nall+16)=xf_ens(i,j,nall+1)
-                endif
-!
-!
-!--- do some more on the caps!!! ne=1 for 175, ne=2 for 100,....
-!
-!     do not care for caps here for closure groups 1 and 5,
-!     they are fine, do not turn them off here
-!
-!!!!    NOT USED FOR "NORMAL" APPLICATION (maxens=1)
-!
-                if(maxens.gt.1)then
-                if(ne.eq.2.and.ierr2(i).gt.0)then
-                      xf_ens(i,j,nall+1) =0.
-                      xf_ens(i,j,nall+2) =0.
-                      xf_ens(i,j,nall+3) =0.
-                      xf_ens(i,j,nall+4) =0.
-                      xf_ens(i,j,nall+5) =0.
-                      xf_ens(i,j,nall+6) =0.
-                      xf_ens(i,j,nall+7) =0.
-                      xf_ens(i,j,nall+8) =0.
-                      xf_ens(i,j,nall+9) =0.
-                      xf_ens(i,j,nall+10)=0.
-                      xf_ens(i,j,nall+11)=0.
-                      xf_ens(i,j,nall+12)=0.
-                      xf_ens(i,j,nall+13)=0.
-                      xf_ens(i,j,nall+14)=0.
-                      xf_ens(i,j,nall+15)=0.
-                      xf_ens(i,j,nall+16)=0.
-                endif
-                if(ne.eq.3.and.ierr3(i).gt.0)then
-                      xf_ens(i,j,nall+1) =0.
-                      xf_ens(i,j,nall+2) =0.
-                      xf_ens(i,j,nall+3) =0.
-                      xf_ens(i,j,nall+4) =0.
-                      xf_ens(i,j,nall+5) =0.
-                      xf_ens(i,j,nall+6) =0.
-                      xf_ens(i,j,nall+7) =0.
-                      xf_ens(i,j,nall+8) =0.
-                      xf_ens(i,j,nall+9) =0.
-                      xf_ens(i,j,nall+10)=0.
-                      xf_ens(i,j,nall+11)=0.
-                      xf_ens(i,j,nall+12)=0.
-                      xf_ens(i,j,nall+13)=0.
-                      xf_ens(i,j,nall+14)=0.
-                      xf_ens(i,j,nall+15)=0.
-                      xf_ens(i,j,nall+16)=0.
-                endif
-                endif
-
-                   endif
- 350            continue
-                if(maxens.gt.1)then
-! ne=1, cap=175
-!
-                   nall=(iens-1)*maxens3*maxens*maxens2 &
-                        +(iedt-1)*maxens*maxens3
-! ne=2, cap=100
-!
-                   nall2=(iens-1)*maxens3*maxens*maxens2 &
-                        +(iedt-1)*maxens*maxens3 &
-                        +(2-1)*maxens3
-                      xf_ens(i,j,nall+4) = xf_ens(i,j,nall2+4)
-                      xf_ens(i,j,nall+5) =xf_ens(i,j,nall2+5)
-                      xf_ens(i,j,nall+6) =xf_ens(i,j,nall2+6)
-                      xf_ens(i,j,nall+14) =xf_ens(i,j,nall2+14)
-                      xf_ens(i,j,nall+7) =xf_ens(i,j,nall2+7)
-                      xf_ens(i,j,nall+8) =xf_ens(i,j,nall2+8)
-                      xf_ens(i,j,nall+9) =xf_ens(i,j,nall2+9)
-                      xf_ens(i,j,nall+15) =xf_ens(i,j,nall2+15)
-                      xf_ens(i,j,nall+10)=xf_ens(i,j,nall2+10)
-                      xf_ens(i,j,nall+11)=xf_ens(i,j,nall2+11)
-                      xf_ens(i,j,nall+12)=xf_ens(i,j,nall2+12)
-!                     if(i.eq.ipr.and.j.eq.jpr)write(0,*)'should not be here'
-                   endif
-!         if(i.eq.ipr.and.j.eq.jpr)write(0,*)'xff_ens3=',xff_ens3
-                go to 100
-             endif
-          elseif(ierr(i).ne.20.and.ierr(i).ne.0)then
-             do n=1,ensdim
-               xf_ens(i,j,n)=0.
-             enddo
-          endif
-!         if(i.eq.ipr.and.j.eq.jpr)write(0,*)'xff_ens3=',xff_ens3
- 100   continue
-
-   END SUBROUTINE cup_forcing_ens_3d
-
-
-   SUBROUTINE cup_kbcon(ierrc,cap_inc,iloop,k22,kbcon,he_cup,hes_cup, &
-              hkb,ierr,kbmax,p_cup,cap_max,                         &
-              xl,cp,ztexec,zqexec,use_excess,       &
-              itf,jtf,ktf,                        &
-              its,ite, jts,jte, kts,kte                        )
-
-   IMPLICIT NONE
-!
-
-   ! only local wrf dimensions are need as of now in this routine
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        use_excess,itf,jtf,ktf,           &
-        its,ite, jts,jte, kts,kte
-  ! 
-  ! 
-  ! 
-  ! ierr error value, maybe modified in this routine
-  !
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-        he_cup,hes_cup,p_cup
-     real,    dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        ztexec,zqexec,cap_max,cap_inc
-     real,intent (in   )                  ::                           &
-        xl,cp
-     real,    dimension (its:ite)                                      &
-        ,intent (inout   )                   ::                           &
-        hkb
-     integer, dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        kbmax
-     integer, dimension (its:ite)                                      &
-        ,intent (inout)                   ::                           &
-        kbcon,k22,ierr
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        iloop
-     character*50 :: ierrc(its:ite)
-!
-!  local variables in this routine
-!
-
-     integer                              ::                           &
-        i,k,k1,k2
-     real                                 ::                           &
-        pbcdif,plus,hetest
-!
-!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
-!
-       DO 27 i=its,itf
-      kbcon(i)=1
-      IF(ierr(I).ne.0)GO TO 27
-      KBCON(I)=K22(I)+1
-      if(iloop.eq.5)KBCON(I)=K22(I)
-      GO TO 32
- 31   CONTINUE
-      KBCON(I)=KBCON(I)+1
-      IF(KBCON(I).GT.KBMAX(i)+2)THEN
-         if(iloop.ne.4)then
-                ierr(i)=3
-                ierrc(i)="could not find reasonable kbcon in cup_kbcon"
-         endif
-        GO TO 27
-      ENDIF
- 32   CONTINUE
-      hetest=hkb(i) ! HE_cup(I,K22(I))
-      if(iloop.eq.5)then
-       hetest=HKB(I)
-!      do k=1,k22(i)
-!        hetest=max(hetest,he_cup(i,k))
-!      enddo
-      endif
-      IF(HETEST.LT.HES_cup(I,KBCON(I)))then
-!       write(0,*)'htest',k22(i),kbcon(i),HETEST,-P_cup(I,KBCON(I))+P_cup(I,K22(I))
-        GO TO 31
-      endif
-
-!     cloud base pressure and max moist static energy pressure
-!     i.e., the depth (in mb) of the layer of negative buoyancy
-      if(KBCON(I)-K22(I).eq.1)go to 27
-      if(iloop.eq.5 .and. (KBCON(I)-K22(I)).eq.0)go to 27
-      PBCDIF=-P_cup(I,KBCON(I))+P_cup(I,K22(I))
-      plus=max(25.,cap_max(i)-float(iloop-1)*cap_inc(i))
-      if(iloop.eq.4)plus=cap_max(i)
-!
-! for shallow convection, if cap_max is greater than 25, it is the pressure at pbltop
-      if(iloop.eq.5)plus=25.
-      if(iloop.eq.5.and.cap_max(i).gt.25)pbcdif=-P_cup(I,KBCON(I))+cap_max(i)
-      IF(PBCDIF.GT.plus)THEN
-!       write(0,*)'htest',k22(i),kbcon(i),plus,-P_cup(I,KBCON(I))+P_cup(I,K22(I))
-        K22(I)=K22(I)+1
-        KBCON(I)=K22(I)+1
-         if(use_excess == 2) then
-             k1=max(1,k22(i)-1)
-             k2=max(1,min(kbcon(i)-1,k22(i)+1))  !kbcon(i)-1
-             k2=k22(i)+1
-             hkb(i)=sum(he_cup(i,k1:k2))/float(k2-k1+1)+(xl*zqexec(i)+cp*ztexec(i))/float(k2-k1+1)
-        else if(use_excess <= 1)then
-             hkb(i)=he_cup(i,k22(i))+float(use_excess)*(xl*zqexec(i)+cp*ztexec(i))
-        endif  ! excess
-
-        if(iloop.eq.5)KBCON(I)=K22(I)
-        IF(KBCON(I).GT.KBMAX(i)+2)THEN
-         if(iloop.ne.4)then
-                ierr(i)=3
-                ierrc(i)="could not find reasonable kbcon in cup_kbcon"
-         endif
-        GO TO 27
-      ENDIF
-        GO TO 32
-      ENDIF
- 27   CONTINUE
-
-   END SUBROUTINE cup_kbcon
-
-
-   SUBROUTINE cup_ktop(ierrc,ilo,dby,kbcon,ktop,ierr,              &
-              itf,jtf,ktf,                     &
-              its,ite, jts,jte, kts,kte                     )
-
-   IMPLICIT NONE
-!
-!  on input
-!
-
-   ! only local wrf dimensions are need as of now in this routine
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        itf,jtf,ktf,           &
-        its,ite, jts,jte, kts,kte
-  ! dby = buoancy term
-  ! ktop = cloud top (output)
-  ! ilo  = flag
-  ! ierr error value, maybe modified in this routine
-  !
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (inout)                   ::                           &
-        dby
-     integer, dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        kbcon
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        ilo
-     integer, dimension (its:ite)                                      &
-        ,intent (out  )                   ::                           &
-        ktop
-     integer, dimension (its:ite)                                      &
-        ,intent (inout)                   ::                           &
-        ierr
-     character*50 :: ierrc(its:ite)
-!
-!  local variables in this routine
-!
-
-     integer                              ::                           &
-        i,k
-!
-        DO 42 i=its,itf
-        ktop(i)=1
-         IF(ierr(I).EQ.0)then
-          DO 40 K=KBCON(I)+1,ktf-1
-            IF(DBY(I,K).LE.0.)THEN
-                KTOP(I)=K-1
-                GO TO 41
-             ENDIF
-  40      CONTINUE
-          if(ilo.eq.1)ierr(i)=5
-          if(ilo.eq.1)ierrc(i)="problem with defining ktop"
-!         if(ilo.eq.2)ierr(i)=998
-          GO TO 42
-  41     CONTINUE
-         do k=ktop(i)+1,ktf
-           dby(i,k)=0.
-         enddo
-         if(kbcon(i).eq.ktop(i))then
-            ierr(i)=55
-            ierrc(i)="kbcon == ktop "
-         endif
-         endif
-  42     CONTINUE
-
-   END SUBROUTINE cup_ktop
-
-
-   SUBROUTINE cup_MAXIMI(ARRAY,KS,KE,MAXX,ierr,              &
-              itf,jtf,ktf,                     &
-              its,ite, jts,jte, kts,kte                     )
-
-   IMPLICIT NONE
-!
-!  on input
-!
-
-   ! only local wrf dimensions are need as of now in this routine
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-         itf,jtf,ktf,                                    &
-         its,ite, jts,jte, kts,kte
-  ! array input array
-  ! x output array with return values
-  ! kt output array of levels
-  ! ks,kend  check-range
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-         array
-     integer, dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-         ierr,ke
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-         ks
-     integer, dimension (its:ite)                                      &
-        ,intent (out  )                   ::                           &
-         maxx
-     real,    dimension (its:ite)         ::                           &
-         x
-     real                                 ::                           &
-         xar
-     integer                              ::                           &
-         i,k
-
-       DO 200 i=its,itf
-       MAXX(I)=KS
-       if(ierr(i).eq.0)then
-      X(I)=ARRAY(I,KS)
-!
-       DO 100 K=KS,KE(i)
-         XAR=ARRAY(I,K)
-         IF(XAR.GE.X(I)) THEN
-            X(I)=XAR
-            MAXX(I)=K
-         ENDIF
- 100  CONTINUE
-      endif
- 200  CONTINUE
-
-   END SUBROUTINE cup_MAXIMI
-
-
-   SUBROUTINE cup_minimi(ARRAY,KS,KEND,KT,ierr,              &
-              itf,jtf,ktf,                     &
-              its,ite, jts,jte, kts,kte                     )
-
-   IMPLICIT NONE
-!
-!  on input
-!
-
-   ! only local wrf dimensions are need as of now in this routine
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-         itf,jtf,ktf,                                    &
-         its,ite, jts,jte, kts,kte
-  ! array input array
-  ! x output array with return values
-  ! kt output array of levels
-  ! ks,kend  check-range
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-         array
-     integer, dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-         ierr,ks,kend
-     integer, dimension (its:ite)                                      &
-        ,intent (out  )                   ::                           &
-         kt
-     real,    dimension (its:ite)         ::                           &
-         x
-     integer                              ::                           &
-         i,k,kstop
-
-       DO 200 i=its,itf
-      KT(I)=KS(I)
-      if(ierr(i).eq.0)then
-      X(I)=ARRAY(I,KS(I))
-       KSTOP=MAX(KS(I)+1,KEND(I))
-!
-       DO 100 K=KS(I)+1,KSTOP
-         IF(ARRAY(I,K).LT.X(I)) THEN
-              X(I)=ARRAY(I,K)
-              KT(I)=K
-         ENDIF
- 100  CONTINUE
-      endif
- 200  CONTINUE
-
-   END SUBROUTINE cup_MINIMI
-
-
-   SUBROUTINE cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup,       &
-              kbcon,ktop,ierr,                               &
-              itf,jtf,ktf,                     &
-              its,ite, jts,jte, kts,kte                     )
-
-   IMPLICIT NONE
-!
-!  on input
-!
-
-   ! only local wrf dimensions are need as of now in this routine
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        itf,jtf,ktf,                                     &
-        its,ite, jts,jte, kts,kte
-  ! aa0 cloud work function
-  ! gamma_cup = gamma on model cloud levels
-  ! t_cup = temperature (Kelvin) on model cloud levels
-  ! dby = buoancy term
-  ! zu= normalized updraft mass flux
-  ! z = heights of model levels 
-  ! ierr error value, maybe modified in this routine
-  !
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-        z,zu,gamma_cup,t_cup,dby
-     integer, dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        kbcon,ktop
-!
-! input and output
-!
-
-
-     integer, dimension (its:ite)                                      &
-        ,intent (inout)                   ::                           &
-        ierr
-     real,    dimension (its:ite)                                      &
-        ,intent (out  )                   ::                           &
-        aa0
-!
-!  local variables in this routine
-!
-
-     integer                              ::                           &
-        i,k
-     real                                 ::                           &
-        dz,da
-!
-        do i=its,itf
-         aa0(i)=0.
-        enddo
-        DO 100 k=kts+1,ktf
-        DO 100 i=its,itf
-         IF(ierr(i).ne.0)GO TO 100
-         IF(K.LE.KBCON(I))GO TO 100
-         IF(K.Gt.KTOP(I))GO TO 100
-         DZ=Z(I,K)-Z(I,K-1)
-         da=zu(i,k)*DZ*(9.81/(1004.*( &
-                (T_cup(I,K)))))*DBY(I,K-1)/ &
-             (1.+GAMMA_CUP(I,K))
-         IF(K.eq.KTOP(I).and.da.le.0.)go to 100
-         AA0(I)=AA0(I)+da
-         if(aa0(i).lt.0.)aa0(i)=0.
-100     continue
-
-   END SUBROUTINE cup_up_aa0
-
-!====================================================================
-   SUBROUTINE g3init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,           &
-                        MASS_FLUX,cp,restart,                       &
-                        P_QC,P_QI,P_FIRST_SCALAR,                   &
-                        RTHFTEN, RQVFTEN,                           &
-                        APR_GR,APR_W,APR_MC,APR_ST,APR_AS,          &
-                        APR_CAPMA,APR_CAPME,APR_CAPMI,              &
-                        cugd_tten,cugd_ttens,cugd_qvten,            &
-                        cugd_qvtens,cugd_qcten,                     &
-                        allowed_to_read,                            &
-                        ids, ide, jds, jde, kds, kde,               &
-                        ims, ime, jms, jme, kms, kme,               &
-                        its, ite, jts, jte, kts, kte               )
-!--------------------------------------------------------------------   
-   IMPLICIT NONE
-!--------------------------------------------------------------------
-   LOGICAL , INTENT(IN)           ::  restart,allowed_to_read
-   INTEGER , INTENT(IN)           ::  ids, ide, jds, jde, kds, kde, &
-                                      ims, ime, jms, jme, kms, kme, &
-                                      its, ite, jts, jte, kts, kte
-   INTEGER , INTENT(IN)           ::  P_FIRST_SCALAR, P_QI, P_QC
-   REAL,     INTENT(IN)           ::  cp
-
-   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
-                                                          CUGD_TTEN,         &
-                                                          CUGD_TTENS,        &
-                                                          CUGD_QVTEN,        &
-                                                          CUGD_QVTENS,       &
-                                                          CUGD_QCTEN
-   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
-                                                          RTHCUTEN, &
-                                                          RQVCUTEN, &
-                                                          RQCCUTEN, &
-                                                          RQICUTEN   
-
-   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
-                                                          RTHFTEN,  &
-                                                          RQVFTEN
-
-   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) ::        &
-                                APR_GR,APR_W,APR_MC,APR_ST,APR_AS,  &
-                                APR_CAPMA,APR_CAPME,APR_CAPMI,      &
-                                MASS_FLUX
-
-   INTEGER :: i, j, k, itf, jtf, ktf
- 
-   jtf=min0(jte,jde-1)
-   ktf=min0(kte,kde-1)
-   itf=min0(ite,ide-1)
- 
-   IF(.not.restart)THEN
-     DO j=jts,jte
-     DO k=kts,kte
-     DO i=its,ite
-        RTHCUTEN(i,k,j)=0.
-        RQVCUTEN(i,k,j)=0.
-     ENDDO
-     ENDDO
-     ENDDO
-     DO j=jts,jte
-     DO k=kts,kte
-     DO i=its,ite
-       cugd_tten(i,k,j)=0.
-       cugd_ttens(i,k,j)=0.
-       cugd_qvten(i,k,j)=0.
-       cugd_qvtens(i,k,j)=0.
-     ENDDO
-     ENDDO
-     ENDDO
-
-     DO j=jts,jtf
-     DO k=kts,ktf
-     DO i=its,itf
-        RTHFTEN(i,k,j)=0.
-        RQVFTEN(i,k,j)=0.
-     ENDDO
-     ENDDO
-     ENDDO
-
-     IF (P_QC .ge. P_FIRST_SCALAR) THEN
-        DO j=jts,jtf
-        DO k=kts,ktf
-        DO i=its,itf
-           RQCCUTEN(i,k,j)=0.
-           cugd_qcten(i,k,j)=0.
-        ENDDO
-        ENDDO
-        ENDDO
-     ENDIF
-
-     IF (P_QI .ge. P_FIRST_SCALAR) THEN
-        DO j=jts,jtf
-        DO k=kts,ktf
-        DO i=its,itf
-           RQICUTEN(i,k,j)=0.
-        ENDDO
-        ENDDO
-        ENDDO
-     ENDIF
-
-     DO j=jts,jtf
-     DO i=its,itf
-        mass_flux(i,j)=0.
-     ENDDO
-     ENDDO
-
-     DO j=jts,jtf
-     DO i=its,itf
-        APR_GR(i,j)=0.
-        APR_ST(i,j)=0.
-        APR_W(i,j)=0.
-        APR_MC(i,j)=0.
-        APR_AS(i,j)=0.
-        APR_CAPMA(i,j)=0.
-        APR_CAPME(i,j)=0.
-        APR_CAPMI(i,j)=0.
-     ENDDO
-     ENDDO
-
-   ENDIF
-
-   END SUBROUTINE g3init
-
-   SUBROUTINE neg_check(j,subt,subq,dt,q,outq,outt,outqc,pret,its,ite,kts,kte,itf,ktf)
-
-   INTEGER,      INTENT(IN   ) ::            j,its,ite,kts,kte,itf,ktf
-
-     real, dimension (its:ite,kts:kte  )                    ,                 &
-      intent(inout   ) ::                                                     &
-       outq,outt,outqc,subt,subq
-     real, dimension (its:ite,kts:kte  )                    ,                 &
-      intent(inout   ) ::                                                     &
-       q
-     real, dimension (its:ite  )                            ,                 &
-      intent(inout   ) ::                                                     &
-       pret
-     real                                                                     &
-        ,intent (in  )                   ::                                   &
-        dt
-     real :: thresh,qmem,qmemf,qmem2,qtest,qmem1
-!
-! first do check on vertical heating rate
-!
-      thresh=300.01
-      do i=its,itf
-      qmemf=1.
-      qmem=0.
-      do k=kts,ktf
-         qmem=(subt(i,k)+outt(i,k))*86400.
-         if(qmem.gt.2.*thresh)then
-           qmem2=2.*thresh/qmem
-           qmemf=min(qmemf,qmem2)
-!
-!
-!          print *,'1',' adjusted massflux by factor ',i,j,k,qmem,qmem2,qmemf,dt
-         endif
-         if(qmem.lt.-thresh)then
-           qmem2=-thresh/qmem
-           qmemf=min(qmemf,qmem2)
-!
-!
-!          print *,'2',' adjusted massflux by factor ',i,j,k,qmem,qmem2,qmemf,dt
-         endif
-      enddo
-!     if(qmemf.lt.1)then
-!          write(0,*)'1',' adjusted massflux by factor ',i,j,qmemf
-!     endif
-      do k=kts,ktf
-         subq(i,k)=subq(i,k)*qmemf
-         subt(i,k)=subt(i,k)*qmemf
-         outq(i,k)=outq(i,k)*qmemf
-         outt(i,k)=outt(i,k)*qmemf
-         outqc(i,k)=outqc(i,k)*qmemf
-      enddo
-      pret(i)=pret(i)*qmemf 
-      enddo
-!
-! check whether routine produces negative q's. This can happen, since 
-! tendencies are calculated based on forced q's. This should have no
-! influence on conservation properties, it scales linear through all
-! tendencies
-!
-      thresh=1.e-10
-      do i=its,itf
-      qmemf=1.
-      do k=kts,ktf-1
-         qmem=subq(i,k)+outq(i,k)
-         if(abs(qmem).gt.0.)then
-         qtest=q(i,k)+(subq(i,k)+outq(i,k))*dt
-         if(qtest.lt.thresh)then
-!
-! qmem2 would be the maximum allowable tendency
-!
-           qmem1=outq(i,k)+subq(i,k)
-           qmem2=(thresh-q(i,k))/dt
-           qmemf=min(qmemf,qmem2/qmem1)
-           qmemf=max(0.,qmemf)
-!          write(0,*)'4 adjusted tendencies ',i,k,qmem,qmem2,qmemf
-!          write(0,*)'4 adjusted tendencies ',i,j,k,q(i,k),qmem1,qmemf
-         endif
-         endif
-      enddo
-!     if(qmemf.lt.1.)write(0,*)'4 adjusted tendencies ',i,j,qmemf
-      do k=kts,ktf
-         subq(i,k)=subq(i,k)*qmemf
-         subt(i,k)=subt(i,k)*qmemf
-         outq(i,k)=outq(i,k)*qmemf
-         outt(i,k)=outt(i,k)*qmemf
-         outqc(i,k)=outqc(i,k)*qmemf
-      enddo
-      pret(i)=pret(i)*qmemf 
-      enddo
-
-   END SUBROUTINE neg_check
-
-
-   SUBROUTINE cup_output_ens_3d(xf_ens,ierr,dellat,dellaq,dellaqc,  &
-              subt_ens,subq_ens,subt,subq,outtem,outq,outqc,     &
-              zu,sub_mas,pre,pw,xmb,ktop,                 &
-              j,name,nx,nx2,iens,ierr2,ierr3,pr_ens,             &
-              maxens3,ensdim,                            &
-              sig,APR_GR,APR_W,APR_MC,APR_ST,APR_AS,                 &
-              APR_CAPMA,APR_CAPME,APR_CAPMI,closure_n,xland1,    &
-              weight_GR,weight_W,weight_MC,weight_ST,weight_AS,training,  &
-	      ipr,jpr,itf,jtf,ktf, &
-              its,ite, jts,jte, kts,kte)
-
-   IMPLICIT NONE
-!
-!  on input
-!
-
-   ! only local wrf dimensions are need as of now in this routine
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        ipr,jpr,itf,jtf,ktf,     &
-        its,ite, jts,jte, kts,kte
-     integer, intent (in   )              ::                           &
-        j,ensdim,nx,nx2,iens,maxens3,training
-  ! xf_ens = ensemble mass fluxes
-  ! pr_ens = precipitation ensembles
-  ! dellat = change of temperature per unit mass flux of cloud ensemble
-  ! dellaq = change of q per unit mass flux of cloud ensemble
-  ! dellaqc = change of qc per unit mass flux of cloud ensemble
-  ! outtem = output temp tendency (per s)
-  ! outq   = output q tendency (per s)
-  ! outqc  = output qc tendency (per s)
-  ! pre    = output precip
-  ! xmb    = total base mass flux
-  ! xfac1  = correction factor
-  ! pw = pw -epsilon*pd (ensemble dependent)
-  ! ierr error value, maybe modified in this routine
-  !
-     real,    dimension (its:ite,jts:jte,1:ensdim)                     &
-        ,intent (inout)                   ::                           &
-       xf_ens,pr_ens
-!srf ------
-!    real,    dimension (its:ite,jts:jte)                              &
-     real,    dimension (its:ite,jts:jte)                              &
-         ,intent (inout)                   ::                          &
-               APR_GR,APR_W,APR_MC,APR_ST,APR_AS,APR_CAPMA,            &
-               APR_CAPME,APR_CAPMI 
-     real, dimension( its:ite , jts:jte )                      &
-         ,intent(in) :: weight_gr,weight_w,weight_mc,weight_st,weight_as
-!-srf---
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (out  )                   ::                           &
-        outtem,outq,outqc,subt,subq,sub_mas
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in  )                   ::                           &
-        zu
-     real,   dimension (its:ite)                                      &
-         ,intent (in  )                   ::                           &
-        sig
-     real,    dimension (its:ite)                                      &
-        ,intent (out  )                   ::                           &
-        pre,xmb
-     real,    dimension (its:ite)                                      &
-        ,intent (inout  )                   ::                           &
-        closure_n,xland1
-     real,    dimension (its:ite,kts:kte,1:nx)                     &
-        ,intent (in   )                   ::                           &
-       subt_ens,subq_ens,dellat,dellaqc,dellaq,pw
-     integer, dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        ktop
-     integer, dimension (its:ite)                                      &
-        ,intent (inout)                   ::                           &
-        ierr,ierr2,ierr3
-!
-!  local variables in this routine
-!
-
-     integer                              ::                           &
-        i,k,n,ncount
-     real                                 ::                           &
-        outtes,ddtes,dtt,dtq,dtqc,dtpw,prerate,clos_wei,xmbhelp
-     real                                 ::                           &
-        dtts,dtqs
-     real,    dimension (its:ite)         ::                           &
-       xfac1,xfac2
-     real,    dimension (its:ite)::                           &
-       xmb_ske,xmb_ave,xmb_std,xmb_cur,xmbweight
-     real,    dimension (its:ite)::                           &
-       pr_ske,pr_ave,pr_std,pr_cur
-     real,    dimension (its:ite,jts:jte)::                           &
-               pr_gr,pr_w,pr_mc,pr_st,pr_as,pr_capma,     &
-               pr_capme,pr_capmi
-     real, dimension (5) :: weight,wm,wm1,wm2,wm3
-     real, dimension (its:ite,5) :: xmb_w
-
-!
-      character *(*), intent (in)        ::                           &
-       name
-
-!
-     weight(1) = -999.  !this will turn off weights
-     wm(1)=-999.
-
-!
-!
-      DO k=kts,ktf
-      do i=its,itf
-        outtem(i,k)=0.
-        outq(i,k)=0.
-        outqc(i,k)=0.
-        subt(i,k)=0.
-        subq(i,k)=0.
-        sub_mas(i,k)=0.
-      enddo
-      enddo
-      do i=its,itf
-        pre(i)=0.
-        xmb(i)=0.
-         xfac1(i)=0.
-         xfac2(i)=0.
-        xmbweight(i)=1.
-      enddo
-      do i=its,itf
-        IF(ierr(i).eq.0)then
-        do n=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3
-           if(pr_ens(i,j,n).le.0.)then
-!            if(i.eq.ipr.and.j.eq.jpr)write(0,*)'pr_ens',n,pr_ens(i,j,n),xf_ens(i,j,n)
-             xf_ens(i,j,n)=0.
-           endif
-        enddo
-        endif
-      enddo
-!
-       xmb_w=0.
-!
-!-- now do feedback
-!
-      ddtes=100.
-      do i=its,itf
-        if(ierr(i).eq.0)then
-         k=0
-         xmb_ave(i)=0.
-         do n=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3
-          k=k+1
-          xmb_ave(i)=xmb_ave(i)+xf_ens(i,j,n)
-         enddo
-         xmb_ave(i)=xmb_ave(i)/float(k)
-         if(xmb_ave(i).le.0.)then
-              ierr(i)=13
-              xmb_ave(i)=0.
-         endif
-         xmb(i)=sig(i)*xmb_ave(i)
-! --- Now use proper count of how many closures were actually
-!       used in cup_forcing_ens (including screening of some
-!       closures over water) to properly normalize xmb
-           clos_wei=16./max(1.,closure_n(i))
-
-           if(xmb(i).eq.0.)then
-              ierr(i)=19
-           endif
-           if(xmb(i).gt.100.)then
-              ierr(i)=19
-           endif
-           xfac1(i)=xmb(i)
-           xfac2(i)=xmb(i)
-
-        endif
-      ENDDO
-      DO k=kts,ktf
-      do i=its,itf
-            dtt =0.
-            dtts=0.
-            dtq =0.
-            dtqs=0.
-            dtqc=0.
-            dtpw=0.
-        IF(ierr(i).eq.0.and.k.le.ktop(i))then
-           do n=1,nx
-              dtt =dtt  + dellat  (i,k,n)
-              dtts=dtts + subt_ens(i,k,n)
-              dtq =dtq  + dellaq  (i,k,n)
-              dtqs=dtqs + subq_ens(i,k,n)
-              dtqc=dtqc + dellaqc (i,k,n)
-              dtpw=dtpw + pw      (i,k,n)
-           enddo
-           OUTTEM(I,K)= XMB(I)* dtt /float(nx)
-           SUBT  (I,K)= XMB(I)* dtts/float(nx)
-           OUTQ  (I,K)= XMB(I)* dtq /float(nx)
-           SUBQ  (I,K)= XMB(I)* dtqs/float(nx)
-           OUTQC (I,K)= XMB(I)* dtqc/float(nx)
-	   PRE(I)=PRE(I)+XMB(I)*dtpw/float(nx)
-           sub_mas(i,k)=zu(i,k)*xmb(i)
-!          xf_ens(i,j,:)=sig(i)*xf_ens(i,j,:)*dtpw/float(nx)
-        endif
-       enddo
-      enddo
-
-      do i=its,itf
-        if(ierr(i).eq.0)then
-        do k=(iens-1)*nx*nx2*maxens3+1,iens*nx*nx2*maxens3
-          xf_ens(i,j,k)=sig(i)*xf_ens(i,j,k)*xfac1(i)
-        enddo
-        endif
-      ENDDO
-
-!srf-fix for preci
-      do i=its,itf
-        if(ierr(i).ne. 0)then
-            apr_w (i,j)=0.0
-	    apr_st(i,j)=0.0
-	    apr_gr(i,j)=0.0
-	    apr_mc(i,j)=0.0
-	    apr_as(i,j)=0.0
-        endif
-      ENDDO
-!srf
-   END SUBROUTINE cup_output_ens_3d
-!-------------------------------------------------------
-   SUBROUTINE cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav,     &
-              ccnclean,p_cup,kbcon,ktop,cd,dby,clw_all,&
-              t_cup,q,GAMMA_cup,zu,qes_cup,k22,qe_cup,xl,         &
-              ZQEXEC,use_excess,ccn,rho, &
-              up_massentr,up_massdetr,psum,psumh,                 &
-              autoconv,aeroevap,itest,itf,jtf,ktf,j,ipr,jpr,                &
-              its,ite, jts,jte, kts,kte                     )
-
-   IMPLICIT NONE
-  real, parameter :: BDISPM = 0.366       !Berry--size dispersion (maritime)
-  REAL, PARAMETER :: BDISPC = 0.146       !Berry--size dispersion (continental)
-!
-!  on input
-!
-
-   ! only local wrf dimensions are need as of now in this routine
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-                                  use_excess,itest,autoconv,aeroevap,itf,jtf,ktf,           &
-                                  its,ite, jts,jte,j,ipr,jpr, kts,kte
-  ! cd= detrainment function 
-  ! q = environmental q on model levels
-  ! qe_cup = environmental q on model cloud levels
-  ! qes_cup = saturation q on model cloud levels
-  ! dby = buoancy term
-  ! cd= detrainment function 
-  ! zu = normalized updraft mass flux
-  ! gamma_cup = gamma on model cloud levels
-  !
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-        t_cup,p_cup,rho,q,zu,gamma_cup,qe_cup,                         &
-        up_massentr,up_massdetr,dby,qes_cup,z_cup,cd
-     real,    dimension (its:ite)                              &
-        ,intent (in   )                   ::                           &
-        zqexec
-  ! entr= entrainment rate 
-     real                                                              &
-        ,intent (in   )                   ::                           &
-        ccnclean,xl
-     integer, dimension (its:ite)                                      &
-        ,intent (in   )                   ::                           &
-        kbcon,ktop,k22
-!
-! input and output
-!
-
-   ! ierr error value, maybe modified in this routine
-
-     integer, dimension (its:ite)                                      &
-        ,intent (inout)                   ::                           &
-        ierr
-      character *(*), intent (in)        ::                           &
-       name
-   ! qc = cloud q (including liquid water) after entrainment
-   ! qrch = saturation q in cloud
-   ! qrc = liquid water content in cloud after rainout
-   ! pw = condensate that will fall out at that level
-   ! pwav = totan normalized integrated condensate (I1)
-   ! c0 = conversion rate (cloud to rain)
-
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (out  )                   ::                           &
-        qc,qrc,pw,clw_all
-     real,    dimension (its:ite,kts:kte) ::                           &
-        qch,qrcb,pwh,clw_allh
-     real,    dimension (its:ite)         ::                           &
-        pwavh
-     real,    dimension (its:ite)                                      &
-        ,intent (out  )                   ::                           &
-        pwav,psum,psumh
-     real,    dimension (its:ite)                                      &
-        ,intent (in  )                   ::                           &
-        ccn
-!
-!  local variables in this routine
-!
-
-     integer                              ::                           &
-        iounit,iprop,iall,i,k,k1,k2
-     real                                 ::                           &
-        prop_ave,qrcb_h,bdsp,dp,g,rhoc,dh,qrch,c0,dz,radius,berryc0,q1,berryc
-     real,    dimension (kts:kte)         ::                           &
-        prop_b
-!
-        prop_b(kts:kte)=0
-        iall=0
-        c0=.002
-        g=9.81
-        bdsp=BDISPM
-!
-!--- no precip for small clouds
-!
-        if(name.eq.'shallow')c0=0.
-        do i=its,itf
-          pwav(i)=0.
-          pwavh(i)=0.
-          psum(i)=0.
-          psumh(i)=0.
-        enddo
-        do k=kts,ktf
-        do i=its,itf
-          pw(i,k)=0.
-          pwh(i,k)=0.
-          qc(i,k)=0.
-          if(ierr(i).eq.0)qc(i,k)=qes_cup(i,k)
-          if(ierr(i).eq.0)qch(i,k)=qes_cup(i,k)
-          clw_all(i,k)=0.
-          clw_allh(i,k)=0.
-          qrc(i,k)=0.
-          qrcb(i,k)=0.
-        enddo
-        enddo
-      if(use_excess < 2 ) then
-      do i=its,itf
-      if(ierr(i).eq.0.)then
-      do k=2,kbcon(i)-1
-        DZ=Z_cup(i,K)-Z_cup(i,K-1)
-        qc(i,k)=qe_cup(i,k22(i))+float(use_excess)*zqexec(i)
-        qch(i,k)=qe_cup(i,k22(i))+float(use_excess)*zqexec(i)
-        if(qc(i,k).gt.qes_cup(i,kbcon(i)-1))then
-            pw(i,k)=zu(i,k)*(qc(i,k)-qes_cup(i,kbcon(i)-1))
-            qc(i,k)=qes_cup(i,kbcon(i)-1)
-            qch(i,k)=qes_cup(i,kbcon(i)-1)
-            PWAV(I)=PWAV(I)+PW(I,K)
-            Psum(I)=Psum(I)+pw(I,K)*dz
-        endif
-      enddo
-      endif
-      enddo
-      else if(use_excess == 2) then
-        do i=its,itf
-         if(ierr(i).eq.0.)then
-             k1=max(1,k22(i)-1)
-             k2=k22(i)+1
-          do k=2,kbcon(i)-1
-             DZ=Z_cup(i,K)-Z_cup(i,K-1)
-             qc (i,k)=sum(qe_cup(i,k1:k2))/float(k2-k1+1) +zqexec(i)
-             qch(i,k)=sum(qe_cup(i,k1:k2))/float(k2-k1+1) +zqexec(i)
-             if(qc(i,k).gt.qes_cup(i,kbcon(i)-1))then
-                 pw(i,k)=zu(i,k)*(qc(i,k)-qes_cup(i,kbcon(i)-1))
-                 qc(i,k)=qes_cup(i,kbcon(i)-1)
-                 qch(i,k)=qes_cup(i,kbcon(i)-1)
-                 PWAV(I)=PWAV(I)+PW(I,K)
-                 Psum(I)=Psum(I)+pw(I,K)*dz
-             endif
-          enddo !k
-         endif  !ierr
-        enddo !i
-      endif  ! use_excess
-
-        DO 100 k=kts+1,ktf
-        DO 100 i=its,itf
-         IF(ierr(i).ne.0)GO TO 100
-         IF(K.Lt.KBCON(I))GO TO 100
-         IF(K.Gt.KTOP(I))GO TO 100
-         rhoc=.5*(rho(i,k)+rho(i,k-1))
-         DZ=Z_cup(i,K)-Z_cup(i,K-1)
-         DP=p_cup(i,K)-p_cup(i,K-1)
-!
-!--- saturation  in cloud, this is what is allowed to be in it
-!
-         QRCH=QES_cup(I,K)+(1./XL)*(GAMMA_cup(i,k) &
-              /(1.+GAMMA_cup(i,k)))*DBY(I,K)
-!
-!------    1. steady state plume equation, for what could
-!------       be in cloud without condensation
-!
-!
-       qc(i,k)=   (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ &
-                         up_massentr(i,k-1)*q(i,k-1))   /            &
-                         (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
-       qch(i,k)= (qch(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*qch(i,k-1)+ &
-                         up_massentr(i,k-1)*q(i,k-1))   /            &
-                         (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
-
-        if(qc(i,k).le.qrch)qc(i,k)=qrch
-        if(qch(i,k).le.qrch)qch(i,k)=qrch
-!
-!------- Total condensed water before rainout
-!
-        clw_all(i,k)=QC(I,K)-QRCH
-        QRC(I,K)=(QC(I,K)-QRCH) ! /(1.+C0*DZ*zu(i,k))
-        clw_allh(i,k)=QCH(I,K)-QRCH
-        QRCB(I,K)=(QCH(I,K)-QRCH) ! /(1.+C0*DZ*zu(i,k))
-    IF(autoconv.eq.2) then
-
-
-! 
-! normalized berry
-!
-! first calculate for average conditions, used in cup_dd_edt!
-! this will also determine proportionality constant prop_b, which, if applied,
-! would give the same results as c0 under these conditions
-!
-         q1=1.e3*rhoc*qrcb(i,k)  ! g/m^3 ! g[h2o]/cm^3
-         berryc0=q1*q1/(60.0*(5.0 + 0.0366*CCNclean/ &
-                ( q1 * BDSP)  ) ) !/(
-!     if(i.eq.ipr.and.j.eq.jpr)write(0,*)'cupm',k,rhoc,rho(i,k)
-!         qrcb_h=qrcb(i,k)/(1.+c0*dz)
-         qrcb_h=((QCH(I,K)-QRCH)*zu(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ &
-                   (zu(i,k)+.5*up_massdetr(i,k-1)+c0*dz*zu(i,k))
-         prop_b(k)=c0*qrcb_h*zu(i,k)/(1.e-3*berryc0)
-         pwh(i,k)=1.e-3*berryc0*dz*prop_b(k) ! 2.
-         berryc=qrcb(i,k)
-         qrcb(i,k)=((QCh(I,K)-QRCH)*zu(i,k)-pwh(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ &
-                   (zu(i,k)+.5*up_massdetr(i,k-1))
-!        QRCb(I,K) = qrcb(i,k) - pwh(i,k)
-         if(qrcb(i,k).lt.0.)then
-           berryc0=(qrcb(i,k-1)*(.5*up_massdetr(i,k-1))-(QCh(I,K)-QRCH)*zu(i,k))/zu(i,k)*1.e-3*dz*prop_b(k)
-           pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k)
-           qrcb(i,k)=0.
-         endif
-!     if(i.eq.ipr.and.j.eq.jpr)write(0,*)'cupm',zu(i,k),pwh(i,k),dz,qrch,qrcb(i,k),clw_allh(i,k)
-      QCh(I,K)=QRCb(I,K)+qrch
-      PWAVH(I)=PWAVH(I)+pwh(I,K)
-      Psumh(I)=Psumh(I)+clw_allh(I,K)*zu(i,k) *dz
-!
-! then the real berry
-!
-          q1=1.e3*rhoc*qrc(i,k)  ! g/m^3 ! g[h2o]/cm^3
-          berryc0=q1*q1/(60.0*(5.0 + 0.0366*CCN(i)/ &
-                ( q1 * BDSP)  ) ) !/(
-          berryc0=1.e-3*berryc0*dz*prop_b(k) ! 2.
-          berryc=qrc(i,k)
-          qrc(i,k)=((QC(I,K)-QRCH)*zu(i,k)-zu(i,k)*berryc0-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/ &
-                   (zu(i,k)+.5*up_massdetr(i,k-1))
-          if(qrc(i,k).lt.0.)then
-            berryc0=((QC(I,K)-QRCH)*zu(i,k)-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/zu(i,k)
-            qrc(i,k)=0.
-          endif
-          pw(i,k)=berryc0*zu(i,k)
-          QC(I,K)=QRC(I,K)+qrch
-!
-!  if not running with berry at all, do the following
-!
-       ELSE       !c0=.002
-         qrc(i,k)=((QC(I,K)-QRCH)*zu(i,k)-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/ &
-                   (zu(i,k)+.5*up_massdetr(i,k-1)+c0*dz*zu(i,k))
-         PW(i,k)=c0*dz*QRC(I,K)*zu(i,k)
-         if(qrc(i,k).lt.0)then
-           qrc(i,k)=0.
-           pw(i,k)=0.
-         endif
-!
-!
-        if(iall.eq.1)then
-          qrc(i,k)=0.
-          pw(i,k)=(QC(I,K)-QRCH)*zu(i,k)
-          if(pw(i,k).lt.0.)pw(i,k)=0.
-        endif
-        QC(I,K)=QRC(I,K)+qrch
-      endif !autoconv
-!
-!--- integrated normalized ondensate
-!
-         PWAV(I)=PWAV(I)+PW(I,K)
-         Psum(I)=Psum(I)+clw_all(I,K)*zu(i,k) *dz
- 100     CONTINUE
-       prop_ave=0.
-       iprop=0
-       do k=kts,kte
-        prop_ave=prop_ave+prop_b(k)
-        if(prop_b(k).gt.0)iprop=iprop+1
-       enddo
-       iprop=max(iprop,1)
-!      write(11,*)'prop_ave = ',prop_ave/float(iprop)
-!      print *,'pwav = ',pwav(1)
-
-   END SUBROUTINE cup_up_moisture
-!====================================================================
-   SUBROUTINE gdinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,           &
-                        MASS_FLUX,cp,restart,                       &
-                        P_QC,P_QI,P_FIRST_SCALAR,                   &
-                        RTHFTEN, RQVFTEN,                           &
-                        APR_GR,APR_W,APR_MC,APR_ST,APR_AS,          &
-                        APR_CAPMA,APR_CAPME,APR_CAPMI,              &
-                        allowed_to_read,                            &
-                        ids, ide, jds, jde, kds, kde,               &
-                        ims, ime, jms, jme, kms, kme,               &
-                        its, ite, jts, jte, kts, kte               )
-!--------------------------------------------------------------------   
-   IMPLICIT NONE
-!--------------------------------------------------------------------
-   LOGICAL , INTENT(IN)           ::  restart,allowed_to_read
-   INTEGER , INTENT(IN)           ::  ids, ide, jds, jde, kds, kde, &
-                                      ims, ime, jms, jme, kms, kme, &
-                                      its, ite, jts, jte, kts, kte
-   INTEGER , INTENT(IN)           ::  P_FIRST_SCALAR, P_QI, P_QC
-   REAL,     INTENT(IN)           ::  cp
-
-   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
-                                                          RTHCUTEN, &
-                                                          RQVCUTEN, &
-                                                          RQCCUTEN, &
-                                                          RQICUTEN   
-
-   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
-                                                          RTHFTEN,  &
-                                                          RQVFTEN
-
-   REAL,     DIMENSION( ims:ime , jms:jme ) , INTENT(OUT) ::        &
-                                APR_GR,APR_W,APR_MC,APR_ST,APR_AS,  &
-                                APR_CAPMA,APR_CAPME,APR_CAPMI,      &
-                                MASS_FLUX
-
-   IF(.not.restart)THEN
-        RTHCUTEN=0.
-        RQVCUTEN=0.
-        RTHFTEN=0.
-        RQVFTEN=0.
-
-     IF (P_QC .ge. P_FIRST_SCALAR) THEN
-           RQCCUTEN=0.
-     ENDIF
-
-     IF (P_QI .ge. P_FIRST_SCALAR) THEN
-           RQICUTEN=0.
-     ENDIF
-
-        mass_flux=0.
-
-   ENDIF
-        APR_GR=0.
-        APR_ST=0.
-        APR_W=0.
-        APR_MC=0.
-        APR_AS=0.
-        APR_CAPMA=0.
-        APR_CAPME=0.
-        APR_CAPMI=0.
-
-   END SUBROUTINE gdinit
-
-
-!--------------------------------------------------------------------
-
-      real function satvap(temp2)
-      implicit none
-      real :: temp2, temp, toot, toto, eilog, tsot,  &
-     &        ewlog, ewlog2, ewlog3, ewlog4
-      temp = temp2-273.155
-      if (temp.lt.-20.) then   !!!! ice saturation
-        toot = 273.16 / temp2
-        toto = 1 / toot
-        eilog = -9.09718 * (toot - 1) - 3.56654 * (log(toot) / &
-     &    log(10.)) + .876793 * (1 - toto) + (log(6.1071) / log(10.))
-        satvap = 10 ** eilog
-      else
-        tsot = 373.16 / temp2
-        ewlog = -7.90298 * (tsot - 1) + 5.02808 * &
-     &             (log(tsot) / log(10.))
-        ewlog2 = ewlog - 1.3816e-07 * &
-     &             (10 ** (11.344 * (1 - (1 / tsot))) - 1)
-        ewlog3 = ewlog2 + .0081328 * &
-     &             (10 ** (-3.49149 * (tsot - 1)) - 1)
-        ewlog4 = ewlog3 + (log(1013.246) / log(10.))
-        satvap = 10 ** ewlog4
-      end if
-      return
-      end function
-   SUBROUTINE CUP_gf_sh(xmb_out,zo,OUTQC,J,AAEQ,T,Q,Z1,                    &
-              TN,QO,PO,PRE,P,OUTT,OUTQ,DTIME,ktau,PSUR,US,VS,    &
-              TCRIT,                                        &
-              ztexec,zqexec,ccn,ccnclean,rho,dx,dhdt,                               &
-              kpbl,kbcon,ktop,cupclws,k22,         &   !-lxz
-              xland,gsw,tscl_kf,              &
-              xl,rv,cp,g,ichoice,ipr,jpr,ierr,ierrc,         &
-              autoconv,itf,jtf,ktf,               &
-              use_excess,its,ite, jts,jte, kts,kte                                &
-                                                )
-
-   IMPLICIT NONE
-
-     integer                                                           &
-        ,intent (in   )                   ::                           &
-        autoconv,itf,jtf,ktf,ktau,use_excess,        &
-        its,ite, jts,jte, kts,kte,ipr,jpr
-     integer, intent (in   )              ::                           &
-        j,ichoice
-  !
-  ! 
-  !
-     real,    dimension (its:ite,jts:jte)                              &
-        ,intent (in   )                   ::                           &
-               gsw
-  ! outtem = output temp tendency (per s)
-  ! outq   = output q tendency (per s)
-  ! outqc  = output qc tendency (per s)
-  ! pre    = output precip
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (inout  )                   ::                           &
-        cupclws,OUTT,OUTQ,OUTQC
-     real,    dimension (its:ite)                                      &
-        ,intent (out  )                   ::                           &
-        pre,xmb_out
-     integer,    dimension (its:ite)                                   &
-        ,intent (out  )                   ::                           &
-        kbcon,ktop,k22
-     integer,    dimension (its:ite)                                   &
-        ,intent (in  )                   ::                           &
-        kpbl
-  !
-  ! basic environmental input includes moisture convergence (mconv)
-  ! omega (omeg), windspeed (us,vs), and a flag (aaeq) to turn off
-  ! convection for this call only and at that particular gridpoint
-  !
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (in   )                   ::                           &
-        rho,T,PO,P,US,VS,tn,dhdt
-     real,    dimension (its:ite,kts:kte)                              &
-        ,intent (inout)                   ::                           &
-         Q,QO
-     real, dimension (its:ite)                                         &
-        ,intent (in   )                   ::                           &
-        ztexec,zqexec,ccn,Z1,PSUR,AAEQ,xland
-       
-       real                                                            &
-        ,intent (in   )                   ::                           &
-        tscl_kf,dx,ccnclean,dtime,tcrit,xl,cp,rv,g
-
-
-!
-!
-!***************** the following are your basic environmental
-!                  variables. They carry a "_cup" if they are
-!                  on model cloud levels (staggered). They carry
-!                  an "o"-ending (z becomes zo), if they are the forced
-!                  variables. They are preceded by x (z becomes xz)
-!                  to indicate modification by some typ of cloud
-!
-  ! z           = heights of model levels
-  ! q           = environmental mixing ratio
-  ! qes         = environmental saturation mixing ratio
-  ! t           = environmental temp
-  ! p           = environmental pressure
-  ! he          = environmental moist static energy
-  ! hes         = environmental saturation moist static energy
-  ! z_cup       = heights of model cloud levels
-  ! q_cup       = environmental q on model cloud levels
-  ! qes_cup     = saturation q on model cloud levels
-  ! t_cup       = temperature (Kelvin) on model cloud levels
-  ! p_cup       = environmental pressure
-  ! he_cup = moist static energy on model cloud levels
-  ! hes_cup = saturation moist static energy on model cloud levels
-  ! gamma_cup = gamma on model cloud levels
-!
-!
-  ! hcd = moist static energy in downdraft
-  ! zd normalized downdraft mass flux
-  ! dby = buoancy term
-  ! entr = entrainment rate
-  ! zd   = downdraft normalized mass flux
-  ! entr= entrainment rate
-  ! hcd = h in model cloud
-  ! bu = buoancy term
-  ! zd = normalized downdraft mass flux
-  ! gamma_cup = gamma on model cloud levels
-  ! qcd = cloud q (including liquid water) after entrainment
-  ! qrch = saturation q in cloud
-  ! pwd = evaporate at that level
-  ! pwev = total normalized integrated evaoprate (I2)
-  ! entr= entrainment rate
-  ! z1 = terrain elevation
-  ! entr = downdraft entrainment rate
-  ! jmin = downdraft originating level
-  ! kdet = level above ground where downdraft start detraining
-  ! psur        = surface pressure
-  ! z1          = terrain elevation
-  ! pr_ens = precipitation ensemble
-  ! xf_ens = mass flux ensembles
-  ! massfln = downdraft mass flux ensembles used in next timestep
-  ! omeg = omega from large scale model
-  ! mconv = moisture convergence from large scale model
-  ! zd      = downdraft normalized mass flux
-  ! zu      = updraft normalized mass flux
-  ! dir     = "storm motion"
-  ! mbdt    = arbitrary numerical parameter
-  ! dtime   = dt over which forcing is applied
-  ! iact_gr_old = flag to tell where convection was active
-  ! kbcon       = LFC of parcel from k22
-  ! k22         = updraft originating level
-  ! icoic       = flag if only want one closure (usually set to zero!)
-  ! dby = buoancy term
-  ! ktop = cloud top (output)
-  ! xmb    = total base mass flux
-  ! hc = cloud moist static energy
-  ! hkb = moist static energy at originating level
-
-     real,    dimension (its:ite,kts:kte) ::                           &
-        entr_rate_2d,mentrd_rate_2d,he,hes,qes,z,                      &
-        heo,heso,qeso,zo,                                              &
-        xhe,xhes,xqes,xz,xt,xq,                                        &
-
-        qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,      &
-        qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,     &
-        tn_cup,                                                        &
-        xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup,xp_cup,xgamma_cup,     &
-        xt_cup,                                                        &
-
-        xlamue,dby,qc,qrcd,pwd,pw,hcd,qcd,dbyd,hc,qrc,zu,zd,clw_all,   &
-        dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco,zuo,zdo,      &
-        xdby,xqc,xqrcd,xpwd,xpw,xhcd,xqcd,xhc,xqrc,xzu,xzd,            &
-
-  ! cd  = detrainment function for updraft
-  ! cdd = detrainment function for downdraft
-  ! dellat = change of temperature per unit mass flux of cloud ensemble
-  ! dellaq = change of q per unit mass flux of cloud ensemble
-  ! dellaqc = change of qc per unit mass flux of cloud ensemble
-
-        cd,cdd,DELLAH,DELLAQ,DELLAT,DELLAQC,dsubt,dsubh,dsubq,subt,subq
-
-  ! aa0 cloud work function for downdraft
-  ! edt = epsilon
-  ! aa0     = cloud work function without forcing effects
-  ! aa1     = cloud work function with forcing effects
-  ! xaa0    = cloud work function with cloud effects (ensemble dependent)
-  ! edt     = epsilon
-
-     real,    dimension (its:ite) ::                                   &
-       edt,edto,edtx,AA1,AA0,XAA0,HKB,                          &
-       HKBO,XHKB,QKB,QKBO,                                    &
-       xmbmax,XMB,XPWAV,XPWEV,PWAV,PWEV,PWAVO,                                &
-       PWEVO,BU,BUD,BUO,cap_max,xland1,                                    &
-       cap_max_increment,closure_n,psum,psumh,sig,zuhe
-     integer,    dimension (its:ite) ::                                &
-       kzdown,KDET,KB,JMIN,kstabi,kstabm,K22x,        &   !-lxz
-       KBCONx,KBx,KTOPx,ierr,ierr2,ierr3,KBMAX
-
-     integer                              ::                           &
-       nall,iedt,nens,nens3,ki,I,K,KK,iresult
-     real                                 ::                           &
-      day,dz,dzo,mbdt,entr_rate,radius,entrd_rate,mentrd_rate,  &
-      zcutdown,edtmax,edtmin,depth_min,zkbmax,z_detr,zktop,      &
-      massfld,dh,cap_maxs,trash,frh,xlamdd,fsum
-      
-      real detdo1,detdo2,entdo,dp,subin,detdo,entup,                &
-      detup,subdown,entdoj,entupk,detupk,totmas
-      real :: power_entr,zustart,zufinal,dzm1,dzp1
-
-
-     integer :: tun_lim,jprnt,k1,k2,kbegzu,kfinalzu,kstart,jmini,levadj
-     logical :: keep_going
-     real xff_shal(9),blqe,xkshal
-     character*50 :: ierrc(its:ite)
-     real,    dimension (its:ite,kts:kte) ::                           &
-       up_massentr,up_massdetr,dd_massentr,dd_massdetr                 &
-      ,up_massentro,up_massdetro,dd_massentro,dd_massdetro
-     real,    dimension (kts:kte) :: smth
-      zustart=.1
-      zufinal=1.
-      levadj=4
-      power_entr=2.
-      day=86400.
-      do i=its,itf
-        xmb_out(i)=0.
-        xland1(i)=1.
-        if(xland(i).gt.1.5)xland1(i)=0.
-        cap_max_increment(i)=25.
-        ierrc(i)=" "
-      enddo
-!
-!--- initial entrainment rate (these may be changed later on in the
-!--- program
-!
-      entr_rate =.2/200.
-      tun_lim=7
-      
-!
-!--- initial detrainmentrates
-!
-      do k=kts,ktf
-      do i=its,itf
-        up_massentro(i,k)=0.
-        up_massdetro(i,k)=0.
-        z(i,k)=zo(i,k)
-        xz(i,k)=zo(i,k)
-        qrco(i,k)=0.
-        cd(i,k)=1.*entr_rate
-        dellaqc(i,k)=0.
-      enddo
-      enddo
-!
-!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft
-!
-!--- minimum depth (m), clouds must have
-!
-      depth_min=50.
-!
-!--- maximum depth (mb) of capping 
-!--- inversion (larger cap = no convection)
-!
-      cap_maxs=25.
-      DO i=its,itf
-        kbmax(i)=1
-        aa0(i)=0.
-        aa1(i)=0.
-      enddo
-      do i=its,itf
-          cap_max(i)=cap_maxs
-        iresult=0
-      enddo
-!
-!--- max height(m) above ground where updraft air can originate
-!
-      zkbmax=4000.
-!
-!--- calculate moist static energy, heights, qes
-!
-      call cup_env(z,qes,he,hes,t,q,p,z1, &
-           psur,ierr,tcrit,-1,xl,cp,   &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, &
-           psur,ierr,tcrit,-1,xl,cp,   &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-
-!
-!--- environmental values on cloud levels
-!
-      call cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup,he_cup, &
-           hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, &
-           ierr,z1,xl,rv,cp,          &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, &
-           heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur,  &
-           ierr,z1,xl,rv,cp,          &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      do i=its,itf
-        if(ierr(i).eq.0)then
-        if(aaeq(i).lt.-0.1)then
-           ierr(i)=20
-        endif
-!
-      do k=kts,ktf
-        if(zo_cup(i,k).gt.zkbmax+z1(i))then
-          kbmax(i)=k
-          go to 25
-        endif
-      enddo
- 25   continue
-!
-      kbmax(i)=min(kbmax(i),ktf-4)
-      endif
-      enddo
-
-!
-!
-!
-!------- DETERMINE LEVEL WITH HIGHEST MOIST STATIC ENERGY CONTENT - K22
-!
-      CALL cup_MAXIMI(HEO_CUP,3,KBMAX,K22,ierr, &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-       DO 36 i=its,itf
-         if(kpbl(i).gt.5)cap_max(i)=po_cup(i,kpbl(i))
-         IF(ierr(I).eq.0.)THEN
-         IF(K22(I).GT.KBMAX(i))then
-           ierr(i)=2
-           ierrc(i)="could not find k22"
-         endif
-            if(kpbl(i).gt.5)then
-               k22(i)=kpbl(i)
-               ierr(i)=0
-               ierrc(i)="reset to zero becausof kpbl"
-             endif
-         else
-             ierrc(i)="why here? "
-         endif
-!      if(j.eq.jpr .and. i.eq.ipr)write(0,*)'initial k22 = ',k22(ipr),kpbl(i)
- 36   CONTINUE
-!
-!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
-!
-
-      do i=its,itf
-       IF(ierr(I).eq.0.)THEN
-         if(use_excess == 2) then
-             k1=max(1,k22(i)-1)
-             k2=k22(i)+1
-             hkb(i) =sum(he_cup(i,k1:k2))/float(k2-k1+1)+xl*zqexec(i)+cp*ztexec(i)
-             hkbo(i)=sum(heo_cup(i,k1:k2))/float(k2-k1+1)+xl*zqexec(i)+cp*ztexec(i)
-             qkbo(i)=sum(qo_cup(i,k1:k2))/float(k2-k1+1)+xl*zqexec(i)
-!            write(0,*)sum(heo_cup(i,k1:k2))/float(k2-k1+1),heo_cup(i,k1),heo(i,k1:k2)
-        else if(use_excess <= 1) then
-             hkb(i)=he_cup(i,k22(i))+float(use_excess)*(xl*zqexec(i)+cp*ztexec(i))
-             hkbo(i)=heo_cup(i,k22(i))+float(use_excess)*(xl*zqexec(i)+cp*ztexec(i))
-             qkbo(i)=qo_cup(i,k22(i))+float(use_excess)*(xl*zqexec(i))
-        endif  ! excess
-         do k=1,k22(i)
-            hkb(i)=max(hkb(i),he_cup(i,k))
-            hkbo(i)=max(hkbo(i),heo_cup(i,k))
-            qkbo(i)=max(qkbo(i),qo_cup(i,k))
-         enddo
-       endif ! ierr
-      enddo
-      call cup_kbcon(ierrc,cap_max_increment,5,k22,kbcon,heo_cup,heso_cup, &
-           hkbo,ierr,kbmax,po_cup,cap_max, &
-           xl,cp,ztexec,zqexec,use_excess,       &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-!
-!--- increase detrainment in stable layers
-!
-      DO 887 i=its,itf
-         IF(ierr(I).eq.0.)THEN
-            if(kbcon(i).gt.ktf-4)then
-                ierr(i)=231
-                go to 887
-            endif
-            do k=kts,ktf
-               frh = min(qo_cup(i,k)/qeso_cup(i,k),1.)
-               entr_rate_2d(i,k)=entr_rate*(1.3-frh)
-               cd(i,k)=entr_rate_2d(i,k)
-            enddo
-            zuhe(i)=zustart
-            kstart=1
-            frh=(zufinal-zustart)/((float(kbcon(i))**power_entr)-(float(kstart)**power_entr))
-            dh=zuhe(i)-frh*(float(kstart)**power_entr)
-            do k=kstart,kbcon(i)-1
-             dz=z_cup(i,k+1)-z_cup(i,k)
-             cd(i,k)=0.
-             entr_rate_2d(i,k)=((frh*(float((k+1))**power_entr)+dh)/zuhe(i)-1.+cd(i,k)*dz)/dz
-             zuhe(i)=zuhe(i)+entr_rate_2d(i,k)*dz*zuhe(i)-cd(i,k)*dz*zuhe(i)
-!            if(i.eq.ipr.and.j.eq.jpr)write(0,*)'entr = ',k,entr_rate_2d(i,k),dh,frh,zuhe(i),dz
-            enddo
-            frh=-(0.1-zuhe(i))/((float(kbcon(i)+tun_lim)**power_entr)-(float(kbcon(i)-1)**power_entr))
-            dh=zuhe(i)+frh*(float(kbcon(i))**power_entr)
-               do k=kbcon(i),kbcon(i)+tun_lim
-                 dz=z_cup(i,k+1)-z_cup(i,k)
-                 cd(i,k)=-((-frh*(float((k+1))**power_entr)+dh)/zuhe(i)-1.-entr_rate_2d(i,k)*dz)/dz
-                 zuhe(i)=zuhe(i)+entr_rate_2d(i,k)*dz*zuhe(i)-cd(i,k)*dz*zuhe(i)
-!            if(i.eq.ipr.and.j.eq.jpr)write(0,*)'entr = ',k,entr_rate_2d(i,k),cd(i,k),zuhe(i)
-               enddo
-               do k=kbcon(i)+tun_lim+1,ktf
-                entr_rate_2d(i,k)=0.
-                cd(i,k)=0.
-               enddo
-
-
-        ENDIF
- 887  enddo
-!
-! calculate mass entrainment and detrainment
-!
-      do k=kts,ktf
-      do i=its,itf
-         hc(i,k)=0.
-         DBY(I,K)=0.
-         hco(i,k)=0.
-         DBYo(I,K)=0.
-      enddo
-      enddo
-      do i=its,itf
-       IF(ierr(I).eq.0.)THEN
-         do k=1,kbcon(i)-1
-            hc(i,k)=hkb(i)
-            hco(i,k)=hkbo(i)
-            qco(i,k)=qkbo(i)
-         enddo
-         k=kbcon(i)
-         hc(i,k)=hkb(i)
-         qco(i,k)=qkbo(i)
-         DBY(I,Kbcon(i))=Hkb(I)-HES_cup(I,K)
-         hco(i,k)=hkbo(i)
-         DBYo(I,Kbcon(i))=Hkbo(I)-HESo_cup(I,K)
-         trash=QESo_cup(I,K)+(1./XL)*(GAMMAo_cup(i,k) &
-              /(1.+GAMMAo_cup(i,k)))*DBYo(I,K)
-         qrco(i,k)=max(0.,qco(i,k)-trash)
-       endif ! ierr
-      enddo
-!
-!
-      do 42 i=its,itf
-         if(ierr(i).eq.0)then
-         zu(i,1)=zustart
-         zuo(i,1)=zustart
-!    mass entrainment and detrinament is defined on model levels
-         do k=2,ktf-1 !kbcon(i)+4 ! ktf-1
-          dz=zo_cup(i,k)-zo_cup(i,k-1)
-          up_massentro(i,k-1)=entr_rate_2d(i,k-1)*dz*zuo(i,k-1)
-          up_massdetro(i,k-1)=cd(i,k-1)*dz*zuo(i,k-1)
-          zuo(i,k)=zuo(i,k-1)+up_massentro(i,k-1)-up_massdetro(i,k-1)
-          if(zuo(i,k).lt.0.05)then
-             zuo(i,k)=.05
-             up_massdetro(i,k-1)=zuo(i,k-1)-.05  + up_massentro(i,k-1)
-             cd(i,k-1)=up_massdetro(i,k-1)/dz/zuo(i,k-1)
-          endif
-          zu(i,k)=zuo(i,k)
-          up_massentr(i,k-1)=up_massentro(i,k-1)
-          up_massdetr(i,k-1)=up_massdetro(i,k-1)
-!          zu(i,k)=max(0.01,zu(i,k-1)+up_massentr(i,k-1)-up_massdetr(i,k-1))
-         enddo
-         do k=kbcon(i)+1,ktf-1
-          hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ &
-                         up_massentr(i,k-1)*he(i,k-1))   /            &
-                         (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
-          dby(i,k)=hc(i,k)-hes_cup(i,k)
-          hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ &
-                         up_massentro(i,k-1)*heo(i,k-1))   /            &
-                         (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1))
-          dbyo(i,k)=hco(i,k)-heso_cup(i,k)
-         enddo
-         do k=kbcon(i)+1,ktf
-          if(dbyo(i,k).lt.0)then
-              ktop(i)=k-1
-              go to 41
-          endif
-         enddo
-41       continue
-         if(ktop(i).lt.kbcon(i)+1)then
-            ierr(i)=5
-            ierrc(i)='ktop is less than kbcon+1'
-             go to 42
-         endif
-         if(ktop(i).gt.ktf-2)then
-             ierr(i)=5
-             ierrc(i)="ktop is larger than ktf-2"
-             go to 42
-         endif
-         do k=kbcon(i)+1,ktop(i)
-          trash=QESo_cup(I,K)+(1./XL)*(GAMMAo_cup(i,k) &
-              /(1.+GAMMAo_cup(i,k)))*DBYo(I,K)
-          qco(i,k)=   (qco(i,k-1)*zuo(i,k-1)-.5*up_massdetr(i,k-1)* qco(i,k-1)+ &
-                         up_massentr(i,k-1)*qo(i,k-1))   /            &
-                         (zuo(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
-          qrco(i,k)=max(0.,qco(i,k)-trash)
-          cupclws(i,k)=qrco(i,k)*.5
-         enddo
-         do k=ktop(i)+1,ktf
-           HC(i,K)=hes_cup(i,k)
-           HCo(i,K)=heso_cup(i,k)
-           DBY(I,K)=0.
-           DBYo(I,K)=0.
-           zu(i,k)=0.
-           zuo(i,k)=0.
-           cd(i,k)=0.
-           entr_rate_2d(i,k)=0.
-           up_massentr(i,k)=0.
-           up_massdetr(i,k)=0.
-           up_massentro(i,k)=0.
-           up_massdetro(i,k)=0.
-         enddo
-!        if(i.eq.ipr.and.j.eq.jpr)then
-!           write(0,*)'hcnew = '
-!           do k=1,ktf
-!             write(0,*)k,hco(i,k),dbyo(i,k)
-!           enddo
-!        endif
-      endif
-42    continue
-!     enddo
-!
-!--- calculate workfunctions for updrafts
-!
-      call cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, &
-           kbcon,ktop,ierr,           &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      call cup_up_aa0(aa1,zo,zuo,dbyo,GAMMAo_CUP,tn_cup, &
-           kbcon,ktop,ierr,           &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-      do i=its,itf
-         if(ierr(i).eq.0)then
-           if(aa1(i).eq.0.)then
-               ierr(i)=17
-               ierrc(i)="cloud work function zero"
-           endif
-         endif
-      enddo
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-!
-!--- change per unit mass that a model cloud would modify the environment
-!
-!--- 1. in bottom layer
-!
-      do k=kts,ktf
-      do i=its,itf
-        dellah(i,k)=0.
-        dsubt(i,k)=0.
-        dsubh(i,k)=0.
-        dellaq(i,k)=0.
-        dsubq(i,k)=0.
-      enddo
-      enddo
-!
-!----------------------------------------------  cloud level ktop
-!
-!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!
-!----------------------------------------------  cloud level k+2
-!
-!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1
-!
-!----------------------------------------------  cloud level k+1
-!
-!- - - - - - - - - - - - - - - - - - - - - - - - model level k
-!
-!----------------------------------------------  cloud level k
-!
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!      .               .                 .
-!
-!----------------------------------------------  cloud level 3
-!
-!- - - - - - - - - - - - - - - - - - - - - - - - model level 2
-!
-!----------------------------------------------  cloud level 2
-!
-!- - - - - - - - - - - - - - - - - - - - - - - - model level 1
-
-      do i=its,itf
-        if(ierr(i).eq.0)then
-         dp=100.*(po_cup(i,1)-po_cup(i,2))
-             dsubt(i,1)=0. 
-             dsubq(i,1)=0. 
-         do k=kts+1,ktop(i)
-               subin=0.
-               subdown=0.
-! these three are only used at or near mass detrainment and/or entrainment levels
-            entupk=0.
-            detupk=0.
-! entrainment/detrainment for updraft
-            entup=up_massentro(i,k)
-            detup=up_massdetro(i,k)
-!
-!         SPECIAL LEVELS
-!
-            if(k.eq.ktop(i))then
-               detupk=zuo(i,ktop(i))
-               subin=0.
-               subdown=0.
-               entup=0.
-               detup=0.
-            endif
-            totmas=subin-subdown+detup-entup  &
-             -entupk+detupk+zuo(i,k+1)-zuo(i,k)
-!               print *,'*********************',k,totmas
-!              write(0,123)k,subin+zuo(i,k+1),subdown-zuo(i,k),detup,entup, &
-!                          detdo,entdo,entupk,detupk
-!             write(8,*)'totmas = ',k,totmas
-            if(abs(totmas).gt.1.e-6)then
-               write(0,*)'*********************',i,j,k,totmas
-               print *,jmin(i),k22(i),kbcon(i),ktop(i)
-               write(0,123)k,subin,subdown,detup,entup, &
-                           entupk,detupk,zuo(i,k+1),zuo(i,k)
-123     formAT(1X,i2,10E12.4)
-!        call wrf_error_fatal ( 'totmas .gt.1.e-6' )
-            endif
-            dp=100.*(po_cup(i,k)-po_cup(i,k+1))
-            dellah(i,k)=(detup*.5*(HCo(i,K+1)+HCo(i,K)) &
-                    -entup*heo(i,k) &
-                    +subin*heo_cup(i,k+1) &
-                    -subdown*heo_cup(i,k) &
-                    +detupk*(hco(i,ktop(i))-heo_cup(i,ktop(i)))    &
-                    -entupk*heo_cup(i,k22(i)) &
-                     )*g/dp
-            dellaq(i,k)=(detup*.5*(qco(i,K+1)+qco(i,K)-qrco(i,k+1)-qrco(i,k)) &
-                    -entup*qo(i,k) &
-                    +subin*qo_cup(i,k+1) &
-                    -subdown*qo_cup(i,k) &
-                    +detupk*(qco(i,ktop(i))-qrco(i,ktop(i))-qo_cup(i,ktop(i)))    &
-                    -entupk*qo_cup(i,k22(i)) &
-                     )*g/dp
-          
-!
-! updraft subsidence only
-!
-           if(k.lt.ktop(i))then
-             dsubt(i,k)=(zuo(i,k+1)*heo_cup(i,k+1) &
-                    -zuo(i,k)*heo_cup(i,k))*g/dp
-             dsubq(i,k)=(zuo(i,k+1)*qo_cup(i,k+1) &
-                    -zuo(i,k)*qo_cup(i,k))*g/dp
-!          if(i.eq.ipr.and.j.eq.jpr)then
-!           write(0,*)'dq3',k,zuo(i,k+1)*heo_cup(i,k+1),zuo(i,k)*heo_cup(i,k)
-!          endif
-           endif
-!
-       enddo   ! k
-
-        endif
-      enddo
-!
-!-- take out cloud liquid water for detrainment
-!
-      do k=kts,ktf-1
-      do i=its,itf
-       dellaqc(i,k)=0.
-       if(ierr(i).eq.0)then
-         if(k.eq.ktop(i)-0)dellaqc(i,k)= &
-                      .01*zuo(i,ktop(i))*qrco(i,ktop(i))* &
-                      9.81/(po_cup(i,k)-po_cup(i,k+1))
-         if(k.lt.ktop(i).and.k.gt.kbcon(i))then
-           dz=zo_cup(i,k+1)-zo_cup(i,k)
-           dellaqc(i,k)=.01*9.81*up_massdetro(i,k)*.5*(qrco(i,k)+qrco(i,k+1))/ &
-                        (po_cup(i,k)-po_cup(i,k+1))
-         endif
-         if(dellaqc(i,k).lt.0)write(0,*)'neg della',i,j,k,ktop(i),qrco(i,k), &
-              qrco(i,k+1),up_massdetro(i,k),zuo(i,ktop(i))
-         dellaqc(i,k)=max(0.,dellaqc(i,k))
-       endif
-      enddo
-      enddo
-!
-!--- using dellas, calculate changed environmental profiles
-!
-      mbdt=3.e-4
-
-      do k=kts,ktf
-      do i=its,itf
-         dellat(i,k)=0.
-         if(ierr(i).eq.0)then
-            dsubh(i,k)=dsubt(i,k)
-            dellaq(i,k)=dellaq(i,k)+dellaqc(i,k)
-            dellaqc(i,k)=0.
-            XHE(I,K)=(dsubt(i,k)+DELLAH(I,K))*MBDT+HEO(I,K)
-            XQ(I,K)=(dsubq(i,k)+DELLAQ(I,K))*MBDT+QO(I,K)
-            DELLAT(I,K)=(1./cp)*(DELLAH(I,K)-xl*DELLAQ(I,K))
-            dSUBT(I,K)=(1./cp)*(dsubt(i,k)-xl*dsubq(i,k))
-            XT(I,K)= (DELLAT(I,K)+dsubt(i,k))*MBDT+TN(I,K)
-            IF(XQ(I,K).LE.0.)XQ(I,K)=1.E-08
-         ENDIF
-      enddo
-      enddo
-      do i=its,itf
-      if(ierr(i).eq.0)then
-      xhkb(i)=hkbo(i)+(dsubh(i,k22(i))+DELLAH(I,K22(i)))*MBDT
-      XHE(I,ktf)=HEO(I,ktf)
-      XQ(I,ktf)=QO(I,ktf)
-      XT(I,ktf)=TN(I,ktf)
-      IF(XQ(I,ktf).LE.0.)XQ(I,ktf)=1.E-08
-      endif
-      enddo
-!
-!--- calculate moist static energy, heights, qes
-!
-      call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, &
-           psur,ierr,tcrit,-1,xl,cp,   &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-!
-!--- environmental values on cloud levels
-!
-      call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, &
-           xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur,   &
-           ierr,z1,xl,rv,cp,          &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-!
-!
-!**************************** static control
-!
-!--- moist static energy inside cloud
-!
-!     do i=its,itf
-!       if(ierr(i).eq.0)then
-!         xhkb(i)=xhe(i,k22(i))
-!       endif
-!     enddo
-      do k=kts,ktf
-      do i=its,itf
-         xhc(i,k)=0.
-         xDBY(I,K)=0.
-      enddo
-      enddo
-      do i=its,itf
-        if(ierr(i).eq.0)then
-!        if(use_excess == 2) then
-!            k1=max(1,k22(i)-1)
-!            k2=k22(i)+1
-!            xhkb(i) =sum(xhe_cup(i,k1:k2))/float(k2-k1+1)+xl*zqexec(i)+cp*ztexec(i)
-!        else if(use_excess <= 1) then
-!            xhkb(i)=xhe_cup(i,k22(i))+float(use_excess)*(xl*zqexec(i)+cp*ztexec(i))
-!        endif
-
-         do k=1,kbcon(i)-1
-            xhc(i,k)=xhkb(i)
-         enddo
-          k=kbcon(i)
-          xhc(i,k)=xhkb(i)
-          xDBY(I,Kbcon(i))=xHkb(I)-xHES_cup(I,K)
-        endif !ierr
-      enddo
-!
-!
-      do i=its,itf
-      if(ierr(i).eq.0)then
-      xzu(i,:)=zuo(i,:)
-      do k=kbcon(i)+1,ktop(i)
-       xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1)+ &
-                         up_massentro(i,k-1)*xhe(i,k-1))   /            &
-                         (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1))
-       xdby(i,k)=xhc(i,k)-xhes_cup(i,k)
-      enddo
-      do k=ktop(i)+1,ktf
-           xHC(i,K)=xhes_cup(i,k)
-           xDBY(I,K)=0.
-           xzu(i,k)=0.
-      enddo
-      endif
-      enddo
-
-!
-!--- workfunctions for updraft
-!
-      call cup_up_aa0(xaa0,xz,xzu,xdby,GAMMA_CUP,xt_cup, &
-           kbcon,ktop,ierr,           &
-           itf,jtf,ktf, &
-           its,ite, jts,jte, kts,kte)
-!
-! now for shallow forcing
-!
-       do i=its,itf
-        xmb(i)=0.
-        xff_shal(1:9)=0.
-        if(ierr(i).eq.0)then
-          xmbmax(i)=0.1  
-          xkshal=(xaa0(i)-aa1(i))/mbdt
-          if(xkshal.ge.0.)xkshal=+1.e6
-          if(xkshal.gt.-1.e-4 .and. xkshal.lt.0.)xkshal=-1.e-4
-          xff_shal(1)=max(0.,-(aa1(i)-aa0(i))/(xkshal*dtime))
-          xff_shal(1)=min(xmbmax(i),xff_shal(1))
-          xff_shal(2)=max(0.,-(aa1(i)-aa0(i))/(xkshal*dtime))
-          xff_shal(2)=min(xmbmax(i),xff_shal(2))
-          xff_shal(3)=max(0.,-(aa1(i)-aa0(i))/(xkshal*dtime))
-          xff_shal(3)=min(xmbmax(i),xff_shal(3))
-          if(aa1(i).le.0)then
-           xff_shal(1)=0.
-           xff_shal(2)=0.
-           xff_shal(3)=0.
-          endif
-          if(aa1(i)-aa0(i).le.0.)then
-           xff_shal(1)=0.
-           xff_shal(2)=0.
-           xff_shal(3)=0.
-          endif
-! boundary layer QE (from Saulo Freitas)
-          blqe=0.
-          trash=0.
-          if(k22(i).lt.kpbl(i)+1)then
-             do k=1,kbcon(i)-1
-                blqe=blqe+100.*dhdt(i,k)*(po_cup(i,k)-po_cup(i,k+1))/g
-             enddo
-             trash=max((hc(i,kbcon(i))-he_cup(i,kbcon(i))),1.e1)
-             xff_shal(7)=max(0.,blqe/trash)
-             xff_shal(7)=min(xmbmax(i),xff_shal(7))
-          else
-             xff_shal(7)=0.
-          endif
-          if(xkshal.lt.-1.1e-04)then ! .and.  &
-!            ((aa1(i)-aa0(i).gt.0.) .or. (xff_shal(7).gt.0)))then
-          xff_shal(4)=max(0.,-aa0(i)/(xkshal*tscl_KF))
-          xff_shal(4)=min(xmbmax(i),xff_shal(4))
-          xff_shal(5)=xff_shal(4)
-          xff_shal(6)=xff_shal(4)
-          else
-           xff_shal(4)=0.
-           xff_shal(5)=0.
-           xff_shal(6)=0.
-          endif
-!         write(0,888)'i0=',i,j,kpbl(i),blqe,xff_shal(7)
-!888       format(a3,3(1x,i3),2e12.4)
-          xff_shal(8)= xff_shal(7)
-          xff_shal(9)= xff_shal(7)
-          fsum=0.
-          do k=1,9
-           xmb(i)=xmb(i)+xff_shal(k)
-           fsum=fsum+1.
-          enddo
-          xmb(i)=min(xmbmax(i),xmb(i)/fsum)
-!         if(i.eq.ipr.and.j.eq.jpr)write(0,*)',ierr,xffs',ierr(i),xff_shal(1:9),xmb(i),xmbmax(i)
-          if(xmb(i).eq.0.)ierr(i)=22
-          if(xmb(i).eq.0.)ierrc(i)="22"
-          if(xmb(i).lt.0.)then
-             ierr(i)=21
-             ierrc(i)="21"
-!            write(0,*)'neg xmb,i,j,xmb for shallow = ',i,j,k22(i),ierr(i)
-          endif
-        endif
-        if(ierr(i).ne.0)then
-           k22(i)=0
-           kbcon(i)=0
-           ktop(i)=0
-           xmb(i)=0
-           do k=kts,ktf
-              outt(i,k)=0.
-              outq(i,k)=0.
-              outqc(i,k)=0.
-           enddo
-        else if(ierr(i).eq.0)then
-!
-! got the mass flux, sanity check, first for heating rates
-!
-          trash=0.
-!         kmaxx=0
-          do k=2,ktop(i)
-           trash=max(trash,86400.*(dsubt(i,k)+dellat(i,k))*xmb(i))
-          enddo
-          if(trash.gt.100.)then
-             xmb(i)=xmb(i)*100./trash
-          endif
-          trash=0.
-          do k=2,ktop(i)
-           trash=min(trash,86400.*(dsubt(i,k)+dellat(i,k))*xmb(i))
-          enddo
-          if(trash.lt.-100.)then
-              xmb(i)=-xmb(i)*100./trash
-          endif
-!
-! sanity check on moisture tendencies: do not allow anything that may allow neg
-! tendencies
-!
-          do k=2,ktop(i)
-           trash=q(i,k)+(dsubq(i,k)+dellaq(i,k))*xmb(i)*dtime
-          if(trash.lt.1.e-12)then
-! max allowable tendency over tendency that would lead to too small mix ratios
-!
-            trash=(1.e-12 -q(i,k))/((dsubq(i,k)+dellaq(i,k))*dtime)
-            xmb(i)=(1.e-12 -q(i,k))/((dsubq(i,k)+dellaq(i,k))*dtime)
-          endif
-          enddo
-          xmb_out(i)=xmb(i)
-! 
-! final tendencies
-!
-          do k=2,ktop(i)
-           outt(i,k)=(dsubt(i,k)+dellat(i,k))*xmb(i)
-           outq(i,k)=(dsubq(i,k)+dellaq(i,k))*xmb(i)
-          enddo
-        endif
-       enddo
-!      
-! done shallow
-!--------------------------done------------------------------
-!
-
-   END SUBROUTINE CUP_gf_sh
-END MODULE module_cu_gf
diff --git a/wrfv2_fire/phys/module_cu_gf_deep.F b/wrfv2_fire/phys/module_cu_gf_deep.F
new file mode 100644
index 00000000..4de8cb85
--- /dev/null
+++ b/wrfv2_fire/phys/module_cu_gf_deep.F
@@ -0,0 +1,4351 @@
+MODULE module_cu_gf_deep
+     real, parameter::g=9.81
+     real, parameter:: cp=1004.
+     real, parameter:: xlv=2.5e6
+     real, parameter::r_v=461.
+     real, parameter :: tcrit=258.
+! tuning constant for cloudwater/ice detrainment
+     real, parameter:: c1=.001 ! .0005
+! parameter to turn on or off evaporation of rainwater as done in SAS
+     integer, parameter :: irainevap=0
+! max allowed fractional coverage (frh_thresh)
+     real, parameter::frh_thresh = .9
+! rh threshold. if fractional coverage ~ frh_thres, do not use cupa any further
+     real, parameter::rh_thresh = .97
+! tuning constant for J. Brown closure (Ichoice = 4,5,6)
+     real, parameter::betajb=1.5
+! tuning for shallow and mid convection. EC uses 1.5
+     integer, parameter:: use_excess=1
+     real, parameter :: fluxtune=1.5
+! flag to turn off or modify mom transport by downdrafts
+     real, parameter :: pgcd = 1.
+!
+! aerosol awareness, do not user yet!
+!
+     integer, parameter :: autoconv=1
+     integer, parameter :: aeroevap=1
+     real, parameter :: ccnclean=250.
+! still 16 ensembles for clousres
+     integer, parameter:: maxens3=16
+
+
+contains
+
+
+   SUBROUTINE CUP_gf(        &          
+               itf,ktf,its,ite, kts,kte  &
+
+              ,dicycle       &  ! diurnal cycle flag
+              ,ichoice       &  ! choice of closure, use "0" for ensemble average
+              ,ipr           &  ! this flag can be used for debugging prints
+              ,ccn           &  ! not well tested yet
+              ,DTIME         &
+              ,imid          &  ! flag to turn on mid level convection
+
+              ,kpbl          &  ! level of boundary layer height
+              ,dhdt          &  ! boundary layer forcing (one closure for shallow)
+              ,xland         &  ! land mask
+
+              ,zo            &  ! heights above surface
+              ,forcing       &  ! only diagnostic
+              ,T             &  ! T before forcing
+              ,Q             &  ! Q before forcing
+              ,Z1            &  ! terrain
+              ,Tn            &  ! T including forcing
+              ,QO            &  ! Q including forcing
+              ,PO            &  ! pressure (mb)
+              ,PSUR          &  ! surface pressure (mb)
+              ,US            &  ! u on mass points
+              ,VS            &  ! v on mass points
+              ,rho           &  ! density
+              ,hfx           &  ! W/M2, positive upward
+              ,qfx           &  ! W/M2, positive upward
+              ,dx            &  ! dx is grid point dependent here
+              ,mconv         &  ! integrated vertical advection of moisture
+              ,omeg          &  ! omega (Pa/s)
+
+              ,csum          &  ! used to implement memory, set to zero if not avail
+              ,cnvwt         &  ! GFS needs this
+              ,zuo           &  ! nomalized updraft mass flux
+              ,zdo           &  ! nomalized downdraft mass flux
+              ,edto          &
+              ,xmb_out       &  !the xmb's may be needed for dicycle
+              ,xmbm_in       &
+              ,xmbs_in       &
+              ,pre           &
+              ,outu          &  ! momentum tendencies at mass points
+              ,outv          &
+              ,outt          &  ! temperature tendencies
+              ,outq          &  ! q tendencies
+              ,outqc         &  ! ql/qice tendencies
+              ,kbcon         &
+              ,ktop          &
+              ,cupclw        &  ! used for direct coupling to radiation, but with tuning factors
+              ,ierr          &  ! ierr flags are error flags, used for debugging
+              ,ierrc         &
+!    the following should be set to zero if not available
+              ,rand_mom      &  ! for stochastics mom, if temporal and spatial patterns exist
+              ,rand_vmas     &  ! for stochastics vertmass, if temporal and spatial patterns exist
+              ,rand_clos     &  ! for stochastics closures, if temporal and spatial patterns exist
+              ,nranflag      &  ! flag to what you want perturbed
+                                ! 1 = momentum transport 
+                                ! 2 = normalized vertical mass flux profile
+                                ! 3 = closures
+                                ! more is possible, talk to developer or
+                                ! implement yourself. pattern is expected to be
+                                ! betwee -1 and +1
+#if ( WRF_DFI_RADAR == 1 )
+              ,do_capsuppress,cap_suppress_j    &             
+#endif
+              ,k22                              &
+              ,jmin)
+
+   IMPLICIT NONE
+
+     integer                                                &
+        ,intent (in   )                   ::                &
+        nranflag,itf,ktf,its,ite, kts,kte,ipr,imid
+     integer, intent (in   )              ::                &
+        ichoice
+     real,  dimension (its:ite,4)                           &
+        ,intent (in  )                   ::  rand_clos
+     real,  dimension (its:ite)                             &
+        ,intent (in  )                   ::  rand_mom,rand_vmas
+
+#if ( WRF_DFI_RADAR == 1 )
+!
+!  option of cap suppress:
+!        do_capsuppress = 1   do
+!        do_capsuppress = other   don't
+!
+!
+   INTEGER,      INTENT(IN   ) ,OPTIONAL   :: do_capsuppress
+   REAL, DIMENSION( its:ite ) :: cap_suppress_j
+#endif
+  !
+  ! 
+  !
+      real,    dimension (its:ite,1:maxens3) :: xf_ens,pr_ens
+  ! outtem = output temp tendency (per s)
+  ! outq   = output q tendency (per s)
+  ! outqc  = output qc tendency (per s)
+  ! pre    = output precip
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout  )                   ::                         &
+        cnvwt,outu,outv,OUTT,OUTQ,OUTQC,cupclw
+     real,    dimension (its:ite)                                      &
+        ,intent (inout  )                   ::                         &
+        pre,xmb_out
+     real,    dimension (its:ite)                                      &
+        ,intent (in  )                   ::                            &
+        hfx,qfx,xmbm_in,xmbs_in
+     integer,    dimension (its:ite)                                   &
+        ,intent (inout  )                ::                            &
+        kbcon,ktop
+     integer,    dimension (its:ite)                                   &
+        ,intent (in  )                   ::                            &
+        kpbl
+  !
+  ! basic environmental input includes moisture convergence (mconv)
+  ! omega (omeg), windspeed (us,vs), and a flag (ierr) to turn off
+  ! convection for this call only and at that particular gridpoint
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        dhdt,rho,T,PO,US,VS,tn
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout   )                ::                           &
+        omeg
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout)                   ::                           &
+         Q,QO,zuo,zdo
+     real, dimension (its:ite)                                         &
+        ,intent (in   )                   ::                           &
+        dx,ccn,Z1,PSUR,xland
+     real, dimension (its:ite)                                         &
+        ,intent (inout   )                ::                           &
+        mconv
+
+       
+       real                                                            &
+        ,intent (in   )                   ::                           &
+        dtime
+
+
+!
+!  local ensemble dependent variables in this routine
+!
+     real,    dimension (its:ite,1)  ::                                &
+        xaa0_ens
+     real,    dimension (its:ite,1)  ::                                &
+        edtc
+     real,    dimension (its:ite,kts:kte,1) ::                         &
+        dellat_ens,dellaqc_ens,dellaq_ens,pwo_ens
+!
+!
+!
+!***************** the following are your basic environmental
+!                  variables. They carry a "_cup" if they are
+!                  on model cloud levels (staggered). They carry
+!                  an "o"-ending (z becomes zo), if they are the forced
+!                  variables. They are preceded by x (z becomes xz)
+!                  to indicate modification by some typ of cloud
+!
+  ! z           = heights of model levels
+  ! q           = environmental mixing ratio
+  ! qes         = environmental saturation mixing ratio
+  ! t           = environmental temp
+  ! p           = environmental pressure
+  ! he          = environmental moist static energy
+  ! hes         = environmental saturation moist static energy
+  ! z_cup       = heights of model cloud levels
+  ! q_cup       = environmental q on model cloud levels
+  ! qes_cup     = saturation q on model cloud levels
+  ! t_cup       = temperature (Kelvin) on model cloud levels
+  ! p_cup       = environmental pressure
+  ! he_cup = moist static energy on model cloud levels
+  ! hes_cup = saturation moist static energy on model cloud levels
+  ! gamma_cup = gamma on model cloud levels
+!
+!
+  ! hcd = moist static energy in downdraft
+  ! zd normalized downdraft mass flux
+  ! dby = buoancy term
+  ! entr = entrainment rate
+  ! zd   = downdraft normalized mass flux
+  ! entr= entrainment rate
+  ! hcd = h in model cloud
+  ! bu = buoancy term
+  ! zd = normalized downdraft mass flux
+  ! gamma_cup = gamma on model cloud levels
+  ! qcd = cloud q (including liquid water) after entrainment
+  ! qrch = saturation q in cloud
+  ! pwd = evaporate at that level
+  ! pwev = total normalized integrated evaoprate (I2)
+  ! entr= entrainment rate
+  ! z1 = terrain elevation
+  ! entr = downdraft entrainment rate
+  ! jmin = downdraft originating level
+  ! kdet = level above ground where downdraft start detraining
+  ! psur        = surface pressure
+  ! z1          = terrain elevation
+  ! pr_ens = precipitation ensemble
+  ! xf_ens = mass flux ensembles
+  ! omeg = omega from large scale model
+  ! mconv = moisture convergence from large scale model
+  ! zd      = downdraft normalized mass flux
+  ! zu      = updraft normalized mass flux
+  ! dir     = "storm motion"
+  ! mbdt    = arbitrary numerical parameter
+  ! dtime   = dt over which forcing is applied
+  ! kbcon       = LFC of parcel from k22
+  ! k22         = updraft originating level
+  ! ichoice       = flag if only want one closure (usually set to zero!)
+  ! dby = buoancy term
+  ! ktop = cloud top (output)
+  ! xmb    = total base mass flux
+  ! hc = cloud moist static energy
+  ! hkb = moist static energy at originating level
+
+     real,    dimension (its:ite,kts:kte) ::                            &
+        entr_rate_2d,mentrd_rate_2d,he,hes,qes,z, heo,heso,qeso,zo,     &                    
+        xhe,xhes,xqes,xz,xt,xq,qes_cup,q_cup,he_cup,hes_cup,z_cup,      &
+        p_cup,gamma_cup,t_cup, qeso_cup,qo_cup,heo_cup,heso_cup,        &
+        zo_cup,po_cup,gammao_cup,tn_cup,                                &    
+        xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup,                        &
+        xt_cup, dby,hc,zu,clw_all,                                      &
+        dbyo,qco,qrcdo,pwdo,pwo,hcdo,qcdo,dbydo,hco,qrco,               &
+        dbyt,xdby,xhc,xzu,                                                   &
+
+  ! cd  = detrainment function for updraft
+  ! cdd = detrainment function for downdraft
+  ! dellat = change of temperature per unit mass flux of cloud ensemble
+  ! dellaq = change of q per unit mass flux of cloud ensemble
+  ! dellaqc = change of qc per unit mass flux of cloud ensemble
+
+        cd,cdd,DELLAH,DELLAQ,DELLAT,DELLAQC,                            &
+        u_cup,v_cup,uc,vc,ucd,vcd,dellu,dellv
+
+  ! aa0 cloud work function for downdraft
+  ! edt = epsilon
+  ! aa0     = cloud work function without forcing effects
+  ! aa1     = cloud work function with forcing effects
+  ! xaa0    = cloud work function with cloud effects (ensemble dependent)
+  ! edt     = epsilon
+
+     real,    dimension (its:ite) ::                                     &
+       edt,edto,AA1,AA0,XAA0,HKB,                                        &
+       HKBO,XHKB,                                                        &
+       XMB,PWAVO,                                                        &
+       PWEVO,BU,BUD,cap_max,                                             &
+       cap_max_increment,closure_n,psum,psumh,sig,sigd
+     real,    dimension (its:ite) ::                                     &
+        axx,edtmax,edtmin,entr_rate
+     integer,    dimension (its:ite) ::                                  &
+       kzdown,KDET,K22,JMIN,kstabi,kstabm,K22x,xland1,                   &  
+       ktopdby,KBCONx,ierr2,ierr3,KBMAX
+
+     integer,  dimension (its:ite), intent(inout) :: ierr
+     integer,  dimension (its:ite), intent(in) :: csum
+     integer                              ::                             &
+       iloop,nens3,ki,kk,I,K
+     real                                 ::                             &
+      dz,dzo,mbdt,radius,                                                &
+      zcutdown,depth_min,zkbmax,z_detr,zktop,                            &
+      dh,cap_maxs,trash,trash2,frh,sig_thresh
+     real entdo,dp,subin,detdo,entup,                                    &
+      detup,subdown,entdoj,entupk,detupk,totmas
+
+     real, dimension (its:ite) :: lambau,flux_tun,zws,ztexec,zqexec
+
+     integer :: jprnt,jmini,start_k22
+     logical :: keep_going,flg(its:ite)
+     
+     character*50 :: ierrc(its:ite)
+     real,    dimension (its:ite,kts:kte) ::                              &
+       up_massentr,up_massdetr,c1d                                        &
+      ,up_massentro,up_massdetro,dd_massentro,dd_massdetro
+     real,    dimension (its:ite,kts:kte) ::                              &
+       up_massentru,up_massdetru,dd_massentru,dd_massdetru
+     real buo_flux,pgcon,pgc,blqe
+    
+     real :: xff_mid(its:ite,2)
+     integer :: iversion=1
+     real :: denom,h_entr,umean,t_star,dq
+     integer, intent(IN) :: DICYCLE
+     real,    dimension (its:ite) :: aa1_bl,hkbo_bl,tau_bl,tau_ecmwf,wmean
+     real, dimension (its:ite,kts:kte) :: tn_bl, qo_bl, qeso_bl, heo_bl, heso_bl             &
+                                              ,qeso_cup_bl,qo_cup_bl, heo_cup_bl,heso_cup_bl &
+                                              ,gammao_cup_bl,tn_cup_bl,hco_bl,DBYo_bl
+     real, dimension(its:ite) :: xf_dicycle
+     real, intent(inout), dimension(its:ite,10) :: forcing
+     integer :: pmin_lev(its:ite),start_level(its:ite),ktopkeep(its:ite)
+     real,    dimension (its:ite,kts:kte) :: dtempdz
+     integer, dimension (its:ite,kts:kte) ::  k_inv_layers 
+ 
+! rainevap from sas
+     real zuh2(40)
+     real, dimension (its:ite) :: rntot,delqev,delq2,qevap,rn,qcond
+     real :: rain,t1,q1,elocp,evef,el2orc,evfact,evfactl,g_rain,e_dn,c_up
+     real :: pgeoh,dts,fp,fpi,pmin,x_add,beta,beta_u
+     real :: cbeg,cmid,cend,const_a,const_b,const_c
+      flux_tun(:)=fluxtune
+!      if(imid.eq.1)flux_tun(:)=fluxtune+.5
+      pmin=150.
+      if(imid.eq.1)pmin=75.
+      ktopdby(:)=0
+      elocp=xlv/cp
+      el2orc=xlv*xlv/(r_v*cp)
+      evfact=.3
+      evfactl=.3
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!proportionality constant to estimate pressure gradient of updraft (Zhang and Wu, 2003, JAS
+!
+! ECMWF
+       pgcon=0.
+       lambau(:)=2.
+! here random must be between -1 and 1
+       if(nranflag == 1)then
+           lambau(:)=1.5+rand_mom(:)
+       endif
+! SAS
+!     lambau=0.
+!     pgcon=-.55
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      ztexec(:)     = 0.
+      zqexec(:)     = 0.
+      zws(:)        = 0.
+
+      do i=its,itf
+         !- buoyancy flux (H+LE)
+         buo_flux= (hfx(i)/cp+0.608*t(i,1)*qfx(i)/xlv)/rho(i,1)
+         pgeoh = zo(i,2)*g
+         !-convective-scale velocity w*
+         zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,2)*g/t(i,1))
+         if(zws(i) > TINY(pgeoh)) then
+            !-convective-scale velocity w*
+            zws(i) = 1.2*zws(i)**.3333
+            !- temperature excess 
+            ztexec(i)     = MAX(flux_tun(i)*hfx(i)/(rho(i,1)*zws(i)*cp),0.0)
+            !- moisture  excess
+            zqexec(i)     = MAX(flux_tun(i)*qfx(i)/xlv/(rho(i,1)*zws(i)),0.)
+         endif
+         !- zws for shallow convection closure (Grant 2001)
+         !- height of the pbl
+         zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,kpbl(i))*g/t(i,kpbl(i)))
+         zws(i) = 1.2*zws(i)**.3333
+         zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct
+      enddo
+!     cap_maxs=225.
+!     if(imid.eq.1)cap_maxs=150.
+      cap_maxs=75. ! 150.
+!     if(imid.eq.1)cap_maxs=100.
+      do i=its,itf
+        edto(i)=0.
+        closure_n(i)=16.
+        xmb_out(i)=0.
+        cap_max(i)=cap_maxs
+        cap_max_increment(i)=20.
+        if(imid.eq.1)cap_max_increment(i)=10.
+!
+! for water or ice
+!
+        xland1(i)=int(xland(i)+.0001) ! 1.
+        if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then
+            xland1(i)=0
+!            if(imid.eq.0)cap_max(i)=cap_maxs-25.
+!            if(imid.eq.1)cap_max(i)=cap_maxs-50.
+            cap_max_increment(i)=20.
+        else
+            if(ztexec(i).gt.0.)cap_max(i)=cap_max(i)+25.
+            if(ztexec(i).lt.0.)cap_max(i)=cap_max(i)-25.
+        endif
+        ierrc(i)=" "
+!       cap_max_increment(i)=1.
+      enddo
+      if(use_excess == 0 )then
+       ztexec(:)=0
+       zqexec(:)=0
+      endif
+#if ( WRF_DFI_RADAR == 1 )
+  if(do_capsuppress == 1) then
+      do i=its,itf
+          cap_max(i)=cap_maxs
+          if (abs(cap_suppress_j(i) - 1.0 ) < 0.1 ) then
+             cap_max(i)=cap_maxs+75.
+          elseif (abs(cap_suppress_j(i) - 0.0 ) < 0.1 ) then
+             cap_max(i)=10.0
+          endif
+      enddo
+  endif
+#endif
+
+!
+!--- initial entrainment rate (these may be changed later on in the
+!--- program
+!
+      start_level(:)=kte
+      do i=its,ite
+         c1d(i,:)= 0. !c1 ! 0. ! c1 ! max(.003,c1+float(csum(i))*.0001)
+         entr_rate(i)=7.e-5 - min(20.,float(csum(i))) * 3.e-6
+         if(xland1(i) == 0)entr_rate(i)=7.e-5
+         if(imid.eq.1)entr_rate(i)=1.e-4
+!         if(imid.eq.1)c1d(i,:)=c1
+         radius=.2/entr_rate(i)
+         frh=min(1.,3.14*radius*radius/dx(i)/dx(i))
+         if(frh > frh_thresh)then
+            frh=frh_thresh
+            radius=sqrt(frh*dx(i)*dx(i)/3.14)
+            entr_rate(i)=.2/radius
+         endif
+         sig(i)=(1.-frh)**2
+      enddo
+      sig_thresh = (1.-frh_thresh)**2
+
+      
+!
+!--- entrainment of mass
+!
+!
+!--- initial detrainmentrates
+!
+      do k=kts,ktf
+      do i=its,itf
+        cnvwt(i,k)=0.
+        zuo(i,k)=0.
+        zdo(i,k)=0.
+        z(i,k)=zo(i,k)
+        xz(i,k)=zo(i,k)
+        cupclw(i,k)=0.
+        cd(i,k)=1.e-9 ! 1.*entr_rate
+!        if(imid.eq.1)cd(i,k)=entr_rate(i)
+        cdd(i,k)=1.e-9
+        hcdo(i,k)=0.
+        qrcdo(i,k)=0.
+        dellaqc(i,k)=0.
+      enddo
+      enddo
+!
+!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft
+!    base mass flux
+!
+      edtmax(:)=1.
+      if(imid.eq.1)edtmax(:)=.15
+      edtmin(:)=.1
+      if(imid.eq.1)edtmin(:)=.05
+!
+!--- minimum depth (m), clouds must have
+!
+      depth_min=1000.
+      if(imid.eq.1)depth_min=500.
+!
+!--- maximum depth (mb) of capping 
+!--- inversion (larger cap = no convection)
+!
+      DO i=its,itf
+!        if(imid.eq.0)then
+!          edtmax(i)=max(0.5,.8-float(csum(i))*.015) !.3)
+!          if(xland1(i) == 1 )edtmax(i)=max(0.7,1.-float(csum(i))*.015) !.3)
+!        endif
+        kbmax(i)=1
+        aa0(i)=0.
+        aa1(i)=0.
+        edt(i)=0.
+        kstabm(i)=ktf-1
+        IERR2(i)=0
+        IERR3(i)=0
+        x_add=0.
+      enddo
+!     do i=its,itf
+!         cap_max(i)=cap_maxs
+!         cap_max3(i)=25.
+
+!     enddo
+!
+!--- max height(m) above ground where updraft air can originate
+!
+      zkbmax=4000.
+      if(imid.eq.1)zkbmax=2000.
+!
+!--- height(m) above which no downdrafts are allowed to originate
+!
+      zcutdown=4000.
+!
+!--- depth(m) over which downdraft detrains all its mass
+!
+      z_detr=1000.
+!     if(imid.eq.1)z_detr=800.
+!
+
+!
+!--- environmental conditions, FIRST HEIGHTS
+!
+      do i=its,itf
+            do k=1,maxens3
+               xf_ens(i,k)=0.
+               pr_ens(i,k)=0.
+            enddo
+      enddo
+
+!
+!--- calculate moist static energy, heights, qes
+!
+      call cup_env(z,qes,he,hes,t,q,po,z1,                         &
+           psur,ierr,tcrit,-1,                                     &
+           itf,ktf,                                                &
+           its,ite, kts,kte)
+      call cup_env(zo,qeso,heo,heso,tn,qo,po,z1,                   &
+           psur,ierr,tcrit,-1,                                     &
+           itf,ktf,                                                &
+           its,ite, kts,kte)
+
+!
+!--- environmental values on cloud levels
+!
+      call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup,  &
+           hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur,               &
+           ierr,z1,                                                &
+           itf,ktf,                                                &
+           its,ite, kts,kte)
+      call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, &
+           heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur,  &
+           ierr,z1,                                                &
+           itf,ktf,                                                &
+           its,ite, kts,kte)
+      do i=its,itf
+        if(ierr(i).eq.0)then
+          if(kpbl(i).gt.5 .and. imid.eq.1)cap_max(i)=po_cup(i,kpbl(i))
+          u_cup(i,kts)=us(i,kts)
+          v_cup(i,kts)=vs(i,kts)
+          do k=kts+1,ktf
+           u_cup(i,k)=.5*(us(i,k-1)+us(i,k))
+           v_cup(i,k)=.5*(vs(i,k-1)+vs(i,k))
+          enddo
+        endif
+      enddo
+      do i=its,itf
+        if(ierr(i).eq.0)then
+        do k=kts,ktf
+          if(zo_cup(i,k).gt.zkbmax+z1(i))then
+            kbmax(i)=k
+            go to 25
+          endif
+        enddo
+ 25     continue
+!
+!--- level where detrainment for downdraft starts
+!
+        do k=kts,ktf
+          if(zo_cup(i,k).gt.z_detr+z1(i))then
+            kdet(i)=k
+            go to 26
+          endif
+        enddo
+ 26     continue
+!
+        endif
+      enddo
+!
+!
+!
+!------- DETERMINE LEVEL WITH HIGHEST MOIST STATIC ENERGY CONTENT - K22
+!
+      start_k22=2
+       DO 36 i=its,itf
+         IF(ierr(I).eq.0)THEN
+            k22(i)=maxloc(HEO_CUP(i,start_k22:kbmax(i)+2),1)+start_k22-1
+            if(K22(I).GE.KBMAX(i))then
+             ierr(i)=2
+             ierrc(i)="could not find k22"
+             ktop(i)=0
+             k22(i)=0
+             kbcon(i)=0
+           endif
+         endif
+ 36   CONTINUE
+!
+!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
+!
+
+      do i=its,itf
+       IF(ierr(I).eq.0)THEN
+         x_add = xlv*zqexec(i)+cp*ztexec(i)
+         call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add)
+         call get_cloud_bc(kte,heo_cup (i,1:kte),hkbo (i),k22(i),x_add)
+       endif ! ierr
+      enddo
+      jprnt=0
+      iloop=1
+      if(imid.eq.1)iloop=5
+      call cup_kbcon(ierrc,cap_max_increment,iloop,k22,kbcon,heo_cup,heso_cup,  &
+           hkbo,ierr,kbmax,po_cup,cap_max,                                      &
+           ztexec,zqexec,                                                       &
+           jprnt,itf,ktf,                                                       &
+           its,ite, kts,kte,                                                    &
+           z_cup,entr_rate,heo,imid)
+!
+!--- increase detrainment in stable layers
+!
+      CALL cup_minimi(HEso_cup,Kbcon,kstabm,kstabi,ierr,                        &
+           itf,ktf,                                                             &
+           its,ite, kts,kte)
+      DO i=its,itf
+         IF(ierr(I) == 0)THEN
+           frh = min(qo_cup(i,kbcon(i))/qeso_cup(i,kbcon(i)),1.)
+           if(frh >= rh_thresh .and. sig(i) <= sig_thresh )then
+             ierr(i)=231
+             cycle
+           endif
+!
+!    never go too low...
+!
+!           if(imid.eq.0 .and. xland1(i).eq.0)x_add=150.
+           x_add=0.
+           do k=kbcon(i)+1,ktf
+             if(po(i,kbcon(i))-po(i,k) > pmin+x_add)then
+                pmin_lev(i)=k
+                exit
+             endif
+           enddo
+!
+! initial conditions for updraft
+!
+            start_level(i)=k22(i)
+            x_add = xlv*zqexec(i)+cp*ztexec(i)
+            call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add)
+         endif
+      enddo
+!
+!--- get inversion layers for mid level cloud tops
+!
+      if(imid.eq.1)then
+      call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers, &
+                               kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte)
+      endif
+      DO i=its,itf
+         if(kstabi(i).lt.kbcon(i))then
+           kbcon(i)=1
+           ierr(i)=42
+         endif
+         do k=kts,ktf
+            entr_rate_2d(i,k)=entr_rate(i)
+         enddo
+         IF(ierr(I).eq.0)THEN
+!         if(imid.eq.0 .and. pmin_lev(i).lt.kbcon(i)+3)pmin_lev(i)=kbcon(i)+3
+            kbcon(i)=max(2,kbcon(i))
+            do k=kts,ktf
+               frh = min(qo_cup(i,k)/qeso_cup(i,k),1.)
+               entr_rate_2d(i,k)=entr_rate(i) *(1.3-frh)
+            enddo
+            if(imid.eq.1)then
+                if(k_inv_layers(i,2).gt.0 .and.   &
+                  (po_cup(i,k22(i))-po_cup(i,k_inv_layers(i,2))).lt.500.)then
+
+                 ktop(i)=min(kstabi(i),k_inv_layers(i,2))
+                 ktopdby(i)=ktop(i)
+               else
+                 do k=kbcon(i)+1,ktf
+                  if((po_cup(i,k22(i))-po_cup(i,k)).gt.500.)then
+                    ktop(i)=k
+                    ktopdby(i)=ktop(i)
+                    exit
+                  endif
+                 enddo
+               endif ! k_inv_lay
+            endif
+
+          endif
+      ENDDO
+!
+!-- get normalized mass flux, entrainment and detrainmentrates for updraft
+!
+      i=0
+      !- for mid level clouds we do not allow clouds taller than where stability
+      !- changes
+      if(imid.eq.1)then
+          call rates_up_pdf(rand_vmas,ipr,'mid',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, &
+                            xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopdby,csum,pmin_lev)
+      else
+          call rates_up_pdf(rand_vmas,ipr,'deep',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, &
+                            xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kbcon,ktopdby,csum,pmin_lev)
+      endif
+!
+!
+!
+      do i=its,itf
+       if(ierr(i).eq.0)then
+
+         if(k22(i).gt.1)then
+            do k=1,k22(i) -1
+              zuo(i,k)=0.
+              zu (i,k)=0.
+              xzu(i,k)=0.
+            enddo
+         endif
+         do k=k22(i),ktop(i)
+          xzu(i,k)= zuo(i,k)
+          zu (i,k)= zuo(i,k)
+         enddo
+         do k=ktop(i)+1,kte
+           zuo(i,k)=0.
+           zu (i,k)=0.
+           xzu(i,k)=0.
+         enddo
+        endif
+      enddo
+!
+! calculate mass entrainment and detrainment
+!
+      CALL get_lateral_massflux(itf,ktf, its,ite, kts,kte                                &
+                                ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d                    &
+                                ,up_massentro, up_massdetro ,up_massentr, up_massdetr    &
+                                ,'deep',kbcon,k22,up_massentru,up_massdetru,lambau)
+
+
+!
+!   NOTE: Ktop here already includes overshooting, ktopdby is without
+!   overshooting
+!
+      do k=kts,ktf
+       do i=its,itf
+         uc  (i,k)=0.
+         vc  (i,k)=0.
+         hc  (i,k)=0.
+         dby (i,k)=0.
+         hco (i,k)=0.
+         dbyo(i,k)=0.
+       enddo
+      enddo
+      do i=its,itf
+       IF(ierr(I).eq.0)THEN
+         do k=1,start_level(i)
+            uc(i,k)=u_cup(i,k)
+            vc(i,k)=v_cup(i,k)
+         enddo
+         do k=1,start_level(i)-1
+            hc (i,k)=he_cup(i,k)
+            hco(i,k)=heo_cup(i,k)
+         enddo
+         k=start_level(i)
+         hc (i,k)=hkb(i)
+         hco(i,k)=hkbo(i)
+       ENDIF 
+      enddo
+
+      DO i=its,itf
+
+       ktopkeep(i)=0
+       dbyt(i,:)=0.
+       if(ierr(i) /= 0) cycle                 
+       ktopkeep(i)=ktop(i)
+       DO k=start_level(i) +1,ktop(i)  !mass cons option
+         
+          denom=zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1)
+          if(denom.lt.1.e-8)then
+           ierr(i)=51
+           exit
+          endif
+
+          hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+                 &
+                                          up_massentr(i,k-1)*he(i,k-1))   /             &
+                            (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
+          uc(i,k)=(uc(i,k-1)*zu(i,k-1)-.5*up_massdetru(i,k-1)*uc(i,k-1)+                &
+                                          up_massentru(i,k-1)*us(i,k-1)                 &
+                            -pgcon*.5*(zu(i,k)+zu(i,k-1))*(u_cup(i,k)-u_cup(i,k-1))) /  &
+                           (zu(i,k-1)-.5*up_massdetru(i,k-1)+up_massentru(i,k-1))
+          vc(i,k)=(vc(i,k-1)*zu(i,k-1)-.5*up_massdetru(i,k-1)*vc(i,k-1)+                &
+                                          up_massentru(i,k-1)*vs(i,k-1)                 &
+                         -pgcon*.5*(zu(i,k)+zu(i,k-1))*(v_cup(i,k)-v_cup(i,k-1))) /     &
+                         (zu(i,k-1)-.5*up_massdetru(i,k-1)+up_massentru(i,k-1))
+          dby(i,k)=hc(i,k)-hes_cup(i,k)
+          hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+            &
+                                             up_massentro(i,k-1)*heo(i,k-1))   /        &
+                         (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1))
+          dbyo(i,k)=hco(i,k)-heso_cup(i,k)
+          DZ=Zo_cup(i,K+1)-Zo_cup(i,K)
+          dbyt(i,k)=dbyt(i,k-1)+dbyo(i,k)*dz
+       ENDDO
+! for now no overshooting (only very little)
+       kk=maxloc(dbyt(i,:),1)
+       ki=maxloc(zuo(i,:),1)
+!       if(ipr .eq.1)write(16,*)'cupgf2',kk,ki
+!       if(kk.lt.ki+3)then
+!         ierr(i)=423
+!       endif
+!
+        do k=ktop(i)-1,kbcon(i),-1
+           if(dbyo(i,k).gt.0.)then
+              ktopkeep(i)=k+1
+              exit
+           endif
+        enddo
+        ktop(I)=ktopkeep(i)
+        if(ierr(i).eq.0)ktop(I)=ktopkeep(i)
+      ENDDO
+41    continue
+      DO i=its,itf
+       if(ierr(i) /= 0) cycle                 
+       do k=ktop(i)+1,ktf
+           HC(i,K)=hes_cup(i,k)
+           UC(i,K)=u_cup(i,k)
+           VC(i,K)=v_cup(i,k)
+           HCo(i,K)=heso_cup(i,k)
+           DBY(I,K)=0.
+           DBYo(I,K)=0.
+           zu(i,k)=0.
+           zuo(i,k)=0.
+           cd(i,k)=0.
+           entr_rate_2d(i,k)=0.
+           up_massentr(i,k)=0.
+           up_massdetr(i,k)=0.
+           up_massentro(i,k)=0.
+           up_massdetro(i,k)=0.
+       enddo
+      ENDDO
+!
+      DO i=its,itf
+        if(ierr(i)/=0)cycle
+        if(ktop(i).lt.kbcon(i)+2)then
+              ierr(i)=5
+              ierrc(i)='ktop too small deep'
+              ktop(i)=0
+        endif
+      ENDDO
+      DO 37 i=its,itf
+         kzdown(i)=0
+         if(ierr(i).eq.0)then
+            zktop=(zo_cup(i,ktop(i))-z1(i))*.6
+            if(imid.eq.1)zktop=(zo_cup(i,ktop(i))-z1(i))*.4
+            zktop=min(zktop+z1(i),zcutdown+z1(i))
+            do k=kts,ktf
+              if(zo_cup(i,k).gt.zktop)then
+                 kzdown(i)=k
+                 kzdown(i)=min(kzdown(i),kstabi(i)-1)  !
+                 go to 37
+              endif
+              enddo
+         endif
+ 37   CONTINUE
+!
+!--- DOWNDRAFT ORIGINATING LEVEL - JMIN
+!
+      call cup_minimi(HEso_cup,K22,kzdown,JMIN,ierr, &
+           itf,ktf, &
+           its,ite, kts,kte)
+      DO 100 i=its,itf
+         IF(ierr(I).eq.0)THEN
+!
+!--- check whether it would have buoyancy, if there where
+!--- no entrainment/detrainment
+!
+         jmini = jmin(i)
+         keep_going = .TRUE.
+         do while ( keep_going )
+           keep_going = .FALSE.
+           if ( jmini - 1 .lt. kdet(i)   ) kdet(i) = jmini-1
+           if ( jmini     .ge. ktop(i)-1 ) jmini = ktop(i) - 2
+           ki = jmini
+           hcdo(i,ki)=heso_cup(i,ki)
+           DZ=Zo_cup(i,Ki+1)-Zo_cup(i,Ki)
+           dh=0.
+           do k=ki-1,1,-1
+             hcdo(i,k)=heso_cup(i,jmini)
+             DZ=Zo_cup(i,K+1)-Zo_cup(i,K)
+             dh=dh+dz*(HCDo(i,K)-heso_cup(i,k))
+             if(dh.gt.0.)then
+               jmini=jmini-1
+               if ( jmini .gt. 5 ) then
+                 keep_going = .TRUE.
+               else
+                 ierr(i) = 9
+                 ierrc(i) = "could not find jmini9"
+                 exit
+               endif
+             endif
+           enddo
+         enddo
+         jmin(i) = jmini 
+         if ( jmini .le. 5 ) then
+           ierr(i)=4
+           ierrc(i) = "could not find jmini4"
+         endif
+       ENDIF
+100   continue
+!
+! - Must have at least depth_min m between cloud convective base
+!     and cloud top.
+!
+      do i=its,itf
+         IF(ierr(I).eq.0)THEN
+            if ( jmin(i) - 1 .lt. kdet(i)   ) kdet(i) = jmin(i)-1
+            IF(-zo_cup(I,KBCON(I))+zo_cup(I,KTOP(I)).LT.depth_min)then
+               ierr(i)=6
+               ierrc(i)="cloud depth very shallow"
+            endif
+         endif
+      enddo
+
+!
+!--- normalized downdraft mass flux profile,also work on bottom detrainment
+!--- in this routine
+!
+      do k=kts,ktf
+      do i=its,itf
+       zdo(i,k)=0.
+       cdd(i,k)=0.
+       dd_massentro(i,k)=0.
+       dd_massdetro(i,k)=0.
+       dd_massentru(i,k)=0.
+       dd_massdetru(i,k)=0.
+       hcdo(i,k)=heso_cup(i,k)
+       ucd(i,k)=u_cup(i,k)
+       vcd(i,k)=v_cup(i,k)
+       dbydo(i,k)=0.
+       mentrd_rate_2d(i,k)=entr_rate(i)
+      enddo
+      enddo
+      do i=its,itf
+        beta=max(.02,.05-float(csum(i))*.0015)  !.02
+!        beta=max(.05,.08-float(csum(i))*.0015)  !.02
+        if(imid.eq.0 .and. xland1(i) == 0)then
+!             beta=.01
+              edtmax(i)=max(0.1,.4-float(csum(i))*.015) !.3)
+        endif
+        if(imid.eq.1)beta=.02
+        bud(i)=0.
+        IF(ierr(I).eq.0)then
+        cdd(i,1:jmin(i))=1.e-9
+        cdd(i,jmin(i))=0.
+        dd_massdetro(i,:)=0.
+        dd_massentro(i,:)=0.
+        call get_zu_zd_pdf_fim(0,po_cup(i,:),rand_vmas(i),0.,ipr,xland1(i),zuh2,"DOWN",ierr(i),kdet(i),jmin(i),zdo(i,:),kts,kte,ktf,beta,kpbl(i),csum(i),pmin_lev(i))
+        if(zdo(i,jmin(i)) .lt.1.e-8)then
+          zdo(i,jmin(i))=0.
+          jmin(i)=jmin(i)-1
+          if(zdo(i,jmin(i)) .lt.1.e-8)then
+             ierr(i)=876
+             cycle
+          endif
+        endif
+        
+        do ki=jmin(i)  ,maxloc(zdo(i,:),1),-1
+          !=> from jmin to maximum value zd -> change entrainment
+          dzo=zo_cup(i,ki+1)-zo_cup(i,ki)
+          dd_massdetro(i,ki)=cdd(i,ki)*dzo*zdo(i,ki+1)
+          dd_massentro(i,ki)=zdo(i,ki)-zdo(i,ki+1)+dd_massdetro(i,ki)
+          if(dd_massentro(i,ki).lt.0.)then
+             dd_massentro(i,ki)=0.
+             dd_massdetro(i,ki)=zdo(i,ki+1)-zdo(i,ki)
+             if(zdo(i,ki+1).gt.0.)cdd(i,ki)=dd_massdetro(i,ki)/(dzo*zdo(i,ki+1))
+          endif
+          if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1))
+        enddo
+        mentrd_rate_2d(i,1)=0.
+        do ki=maxloc(zdo(i,:),1)-1,1,-1
+          !=> from maximum value zd to surface -> change detrainment
+          dzo=zo_cup(i,ki+1)-zo_cup(i,ki)
+          dd_massentro(i,ki)=mentrd_rate_2d(i,ki)*dzo*zdo(i,ki+1)
+          dd_massdetro(i,ki) = zdo(i,ki+1)+dd_massentro(i,ki)-zdo(i,ki)
+          if(dd_massdetro(i,ki).lt.0.)then
+            dd_massdetro(i,ki)=0.
+            dd_massentro(i,ki)=zdo(i,ki)-zdo(i,ki+1)
+            if(zdo(i,ki+1).gt.0.)mentrd_rate_2d(i,ki)=dd_massentro(i,ki)/(dzo*zdo(i,ki+1))
+          endif
+          if(zdo(i,ki+1).gt.0.)cdd(i,ki)= dd_massdetro(i,ki)/(dzo*zdo(i,ki+1))
+        enddo
+         cbeg=po_cup(i,kbcon(i)) !850.
+         cend=min(po_cup(i,ktop(i)),400.)
+         cmid=.5*(cbeg+cend) !600.
+         const_b=c1/((cmid*cmid-cbeg*cbeg)*(cbeg-cend)/(cend*cend-cbeg*cbeg)+cmid-cbeg)
+         const_a=const_b*(cbeg-cend)/(cend*cend-cbeg*cbeg)
+         const_c=-const_a*cbeg*cbeg-const_b*cbeg
+         do k=kbcon(i)+1,ktop(i)-1
+           c1d(i,k)=const_a*po_cup(i,k)*po_cup(i,k)+const_b*po_cup(i,k)+const_c
+           c1d(i,k)=max(0.,c1d(i,k))
+           c1d(i,k)=c1
+         enddo
+         if(imid.eq.1)c1d(i,:)=0.
+!        do k=1,jmin(i)
+!         c1d(i,k)=0.
+!        enddo
+!         c1d(i,jmin(i)-2)=c1/40.
+!         if(imid.eq.1)c1d(i,jmin(i)-2)=c1/20.
+!        do k=jmin(i)-1,ktop(i)
+!          dz=zo_cup(i,ktop(i))-zo_cup(i,jmin(i))
+!          c1d(i,k)=c1d(i,k-1)+c1*(zo_cup(i,k+1)-zo_cup(i,k))/dz
+!          c1d(i,k)=max(0.,c1d(i,k))
+!          c1d(i,k)=min(.002,c1d(i,k))
+!        enddo
+
+
+! downdraft moist static energy + moisture budget
+          do k=2,jmin(i)+1
+           dd_massentru(i,k-1)=dd_massentro(i,k-1)+lambau(i)*dd_massdetro(i,k-1)
+           dd_massdetru(i,k-1)=dd_massdetro(i,k-1)+lambau(i)*dd_massdetro(i,k-1)
+          enddo
+            dbydo(i,jmin(i))=hcdo(i,jmin(i))-heso_cup(i,jmin(i))
+            bud(i)=dbydo(i,jmin(i))*(zo_cup(i,jmin(i)+1)-zo_cup(i,jmin(i)))
+            do ki=jmin(i)  ,1,-1
+             dzo=zo_cup(i,ki+1)-zo_cup(i,ki)
+             h_entr=.5*(heo(i,ki)+.5*(hco(i,ki)+hco(i,ki+1)))
+             ucd(i,ki)=(ucd(i,ki+1)*zdo(i,ki+1)                                   &
+                         -.5*dd_massdetru(i,ki)*ucd(i,ki+1)+                      &
+                        dd_massentru(i,ki)*us(i,ki)                               &
+                        -pgcon*zdo(i,ki+1)*(us(i,ki+1)-us(i,ki)))   /             &
+                        (zdo(i,ki+1)-.5*dd_massdetru(i,ki)+dd_massentru(i,ki))
+             vcd(i,ki)=(vcd(i,ki+1)*zdo(i,ki+1)                                   &
+                         -.5*dd_massdetru(i,ki)*vcd(i,ki+1)+                      &
+                        dd_massentru(i,ki)*vs(i,ki)                               &
+                        -pgcon*zdo(i,ki+1)*(vs(i,ki+1)-vs(i,ki)))   /             &
+                        (zdo(i,ki+1)-.5*dd_massdetru(i,ki)+dd_massentru(i,ki))
+             hcdo(i,ki)=(hcdo(i,ki+1)*zdo(i,ki+1)                                 &
+                         -.5*dd_massdetro(i,ki)*hcdo(i,ki+1)+                     &
+                        dd_massentro(i,ki)*h_entr)   /                            &
+                        (zdo(i,ki+1)-.5*dd_massdetro(i,ki)+dd_massentro(i,ki))
+             dbydo(i,ki)=hcdo(i,ki)-heso_cup(i,ki)
+             bud(i)=bud(i)+dbydo(i,ki)*dzo
+            enddo
+          endif
+
+        if(bud(i).gt.0)then
+          ierr(i)=7
+          ierrc(i)='downdraft is not negatively buoyant '
+        endif
+      enddo
+!
+!--- calculate moisture properties of downdraft
+!
+      call cup_dd_moisture(ierrc,zdo,hcdo,heso_cup,qcdo,qeso_cup,                &
+           pwdo,qo_cup,zo_cup,dd_massentro,dd_massdetro,jmin,ierr,gammao_cup,    &
+           pwevo,bu,qrcdo,qo,heo,1,                                              &
+           itf,ktf,                                                              &
+           its,ite, kts,kte)
+!
+!--- calculate moisture properties of updraft
+!
+      if(imid.eq.1)then
+        call cup_up_moisture('mid',ierr,zo_cup,qco,qrco,pwo,pwavo,               &
+             p_cup,kbcon,ktop,dbyo,clw_all,xland1,                               &
+             qo,GAMMAo_cup,zuo,qeso_cup,k22,qo_cup,                              &
+             ZQEXEC,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh,       &
+             1,itf,ktf,                                                          &
+             its,ite, kts,kte)
+      else
+         call cup_up_moisture('deep',ierr,zo_cup,qco,qrco,pwo,pwavo,             &
+             p_cup,kbcon,ktop,dbyo,clw_all,xland1,                               &
+             qo,GAMMAo_cup,zuo,qeso_cup,k22,qo_cup,                              &
+             ZQEXEC,ccn,rho,c1d,tn_cup,up_massentr,up_massdetr,psum,psumh,       &
+             1,itf,ktf,                                                          &
+             its,ite, kts,kte)
+      endif
+      do i=its,itf
+       if(ierr(i).eq.0)then
+        do k=kts+1,ktop(i)
+          dp=100.*(po_cup(i,1)-po_cup(i,2))
+          cupclw(i,k)=qrco(i,k)        ! my mod
+          cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp
+        enddo
+       endif
+      enddo
+!
+!--- calculate workfunctions for updrafts
+!
+      call cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup,                              &
+           kbcon,ktop,ierr,                                                      &
+           itf,ktf,                                                              &
+           its,ite, kts,kte)
+      call cup_up_aa0(aa1,zo,zuo,dbyo,GAMMAo_CUP,tn_cup,                         &
+           kbcon,ktop,ierr,                                                      &
+           itf,ktf,                                                              &
+           its,ite, kts,kte)
+      do i=its,itf
+         if(ierr(i).eq.0)then
+           if(aa1(i).eq.0.)then
+               ierr(i)=17
+               ierrc(i)="cloud work function zero"
+           endif
+         endif
+      enddo
+!
+!--- diurnal cycle closure 
+!
+      !--- AA1 from boundary layer (bl) processes only
+      aa1_bl      (:) = 0.0
+      xf_dicycle   (:) = 0.0
+      tau_ecmwf    (:) = 0.
+      !- way to calculate the fraction of cape consumed by shallow convection
+      iversion=1 ! ecmwf  
+      !iversion=0 ! orig    
+      !
+      ! Betchold et al 2008 time-scale of cape removal
+!
+! wmean is of no meaning over land....
+! still working on replacing it over water
+!
+      DO i=its,itf
+            if(ierr(i).eq.0)then
+                !- mean vertical velocity 
+                wmean(i) = 7.0 ! m/s ! in the future change for Wmean == integral( W dz) / cloud_depth
+                if(imid.eq.1)wmean(i) = 3.0
+                !- time-scale cape removal from  Betchold et al. 2008
+                tau_ecmwf(i)=( zo_cup(i,ktopdby(i))- zo_cup(i,kbcon(i)) ) / wmean(i) 
+                tau_ecmwf(i)= tau_ecmwf(i) * (1.0061 + 1.23E-2 * (dx(i)/1000.))! dx(i) must be in meters 
+            endif
+      enddo
+      tau_bl(:)     = 0.
+      !
+      IF(dicycle == 1) then
+        DO i=its,itf
+            
+            if(ierr(i).eq.0)then
+                if(xland1(i) ==  0 ) then
+                  !- over water
+                  umean= 2.0+sqrt(2.0*(US(i,1)**2+VS(i,1)**2+US(i,kbcon(i))**2+VS(i,kbcon(i))**2))
+                  tau_bl(i) = (zo_cup(i,kbcon(i))- z1(i)) /umean        
+                else
+                  !- over land
+                  tau_bl(i) =( zo_cup(i,ktopdby(i))- zo_cup(i,kbcon(i)) ) / wmean(i)
+                endif
+
+            endif
+        ENDDO
+
+        if(iversion == 1) then 
+        !-- version ecmwf
+        t_star=4.  !original =1
+
+           !-- calculate pcape from BL forcing only
+            call cup_up_aa1bl(aa1_bl,t,tn,q,qo,dtime,                            &
+                              zo_cup,zuo,dbyo_bl,GAMMAo_CUP_bl,tn_cup_bl,        &
+                              kbcon,ktop,ierr,                                   &
+                              itf,ktf,its,ite, kts,kte)
+
+            DO i=its,itf
+
+            if(ierr(i).eq.0)then
+
+               !- only for convection rooting in the PBL
+               if(zo_cup(i,kbcon(i))-z1(i) > zo(i,kpbl(i)+1)) then 
+                  aa1_bl(i) = 0.0
+               else
+               !- multiply aa1_bl the " time-scale" - tau_bl
+                  aa1_bl(i) = max(0.,aa1_bl(i)/t_star* tau_bl(i))
+               endif 
+            endif
+            ENDDO
+            
+        else
+        
+          !- version for real cloud-work function
+          
+          !-get the profiles modified only by bl tendencies
+          DO i=its,itf
+           tn_bl(i,:)=0.;qo_bl(i,:)=0.
+           if ( ierr(i) == 0 )then
+            !below kbcon -> modify profiles
+            tn_bl(i,1:kbcon(i)) = tn(i,1:kbcon(i))
+            qo_bl(i,1:kbcon(i)) = qo(i,1:kbcon(i))
+                 !above kbcon -> keep environment profiles
+            tn_bl(i,kbcon(i)+1:ktf) = t(i,kbcon(i)+1:ktf)
+            qo_bl(i,kbcon(i)+1:ktf) = q(i,kbcon(i)+1:ktf)
+           endif 
+          ENDDO
+          !--- calculate moist static energy, heights, qes, ... only by bl tendencies
+          call cup_env(zo,qeso_bl,heo_bl,heso_bl,tn_bl,qo_bl,po,z1,                              &
+                     psur,ierr,tcrit,-1,                                                         &
+                     itf,ktf, its,ite, kts,kte)
+          !--- environmental values on cloud levels only by bl tendencies
+          call cup_env_clev(tn_bl,qeso_bl,qo_bl,heo_bl,heso_bl,zo,po,qeso_cup_bl,qo_cup_bl,      &
+                              heo_cup_bl,heso_cup_bl,zo_cup,po_cup,gammao_cup_bl,tn_cup_bl,psur, &
+                              ierr,z1,                                                           &
+                              itf,ktf,its,ite, kts,kte)
+          DO i=its,itf
+            IF(ierr(I).eq.0)THEN
+               hkbo_bl(i)=heo_cup_bl(i,k22(i)) 
+            endif ! ierr
+          ENDDO
+          DO k=kts,ktf
+           do i=its,itf
+             hco_bl (i,k)=0.
+             DBYo_bl(i,k)=0.
+           enddo
+          ENDDO
+          DO i=its,itf
+            IF(ierr(I).eq.0)THEN
+             do k=1,kbcon(i)-1
+              hco_bl(i,k)=hkbo_bl(i)
+             enddo
+             k=kbcon(i)
+             hco_bl (i,k)=hkbo_bl(i)
+             DBYo_bl(i,k)=Hkbo_bl(i) - HESo_cup_bl(i,k)
+            ENDIF
+          ENDDO
+!          
+!          
+          DO i=its,itf
+            if(ierr(i).eq.0)then
+               do k=kbcon(i)+1,ktop(i)
+                    hco_bl(i,k)=(hco_bl(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco_bl(i,k-1)+ &
+                               up_massentro(i,k-1)*heo_bl(i,k-1))   /                           &
+                               (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1))
+                    dbyo_bl(i,k)=hco_bl(i,k)-heso_cup_bl(i,k)
+               enddo
+               do k=ktop(i)+1,ktf
+                  hco_bl (i,k)=heso_cup_bl(i,k)
+                  dbyo_bl(i,k)=0.0
+               enddo
+            endif
+          ENDDO
+        
+          !--- calculate workfunctions for updrafts
+          call cup_up_aa0(aa1_bl,zo,zuo,dbyo_bl,GAMMAo_CUP_bl,tn_cup_bl,        &
+                        kbcon,ktop,ierr,                                        &
+                        itf,ktf,its,ite, kts,kte)
+
+          DO i=its,itf
+            
+            if(ierr(i).eq.0)then
+                !- get the increment on AA0 due the BL processes
+                aa1_bl(i) = aa1_bl(i) - aa0(i)
+                !- only for convection rooting in the PBL
+                !if(zo_cup(i,kbcon(i))-z1(i) > 500.0) then !- instead 500 -> zo_cup(kpbl(i))
+                !   aa1_bl(i) = 0.0
+                !else
+                !   !- multiply aa1_bl the "normalized time-scale" - tau_bl/ model_timestep
+                   aa1_bl(i) = aa1_bl(i)* tau_bl(i)/ dtime
+                !endif 
+                print*,'aa0,aa1bl=',aa0(i),aa1_bl(i),aa0(i)-aa1_bl(i),tau_bl(i)!,dtime,xland(i)     
+            endif
+           ENDDO
+        ENDIF
+     ENDIF  ! version of implementation
+
+
+       axx(:)=aa1(:)
+
+!
+!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
+!
+      call cup_dd_edt(ierr,us,vs,zo,ktop,kbcon,edt,po,pwavo,  &
+           pwo,ccn,pwevo,edtmax,edtmin,edtc,psum,psumh,       &
+           rho,aeroevap,itf,ktf,                              &
+           its,ite, kts,kte)
+        do i=its,itf
+         if(ierr(i).eq.0)then
+            edto(i)=edtc(i,1)
+         endif
+        enddo
+        do k=kts,ktf
+        do i=its,itf
+           dellat_ens (i,k,1)=0.
+           dellaq_ens (i,k,1)=0.
+           dellaqc_ens(i,k,1)=0.
+           pwo_ens    (i,k,1)=0.
+        enddo
+        enddo
+!
+!--- change per unit mass that a model cloud would modify the environment
+!
+!--- 1. in bottom layer
+!
+      do k=kts,kte
+      do i=its,itf
+        dellu  (i,k)=0.
+        dellv  (i,k)=0.
+        dellah (i,k)=0.
+        dellat (i,k)=0.
+        dellaq (i,k)=0.
+        dellaqc(i,k)=0.
+      enddo
+      enddo
+!
+!----------------------------------------------  cloud level ktop
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!
+!----------------------------------------------  cloud level k+2
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1
+!
+!----------------------------------------------  cloud level k+1
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - model level k
+!
+!----------------------------------------------  cloud level k
+!
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!
+!----------------------------------------------  cloud level 3
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - model level 2
+!
+!----------------------------------------------  cloud level 2
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - model level 1
+
+      do i=its,itf
+        if(ierr(i).eq.0)then
+         dp=100.*(po_cup(i,1)-po_cup(i,2))
+         dellu(i,1)=pgcd*(edto(i)*zdo(i,2)*ucd(i,2)   &
+                         -edto(i)*zdo(i,2)*u_cup(i,2))*g/dp
+         dellv(i,1)=pgcd*(edto(i)*zdo(i,2)*vcd(i,2)   &
+                         -edto(i)*zdo(i,2)*v_cup(i,2))*g/dp
+
+         do k=kts+1,ktop(i)
+            ! these three are only used at or near mass detrainment and/or entrainment levels
+            pgc=pgcon
+            entupk=0.
+            if(k == k22(i)-1) entupk=zuo(i,k+1)
+            detupk=0.
+            entdoj=0.
+            ! detrainment and entrainment for fowndrafts
+            detdo=edto(i)*dd_massdetro(i,k)
+            entdo=edto(i)*dd_massentro(i,k)
+            ! entrainment/detrainment for updraft
+            entup=up_massentro(i,k)
+            detup=up_massdetro(i,k)
+            ! subsidence by downdrafts only
+            subin=-zdo(i,k+1)*edto(i)
+            subdown=-zdo(i,k)*edto(i)
+            !         SPECIAL LEVELS
+            if(k.eq.ktop(i))then
+               detupk=zuo(i,ktop(i))
+               subin=0.
+               subdown=0.
+               detdo=0.
+               entdo=0.
+               entup=0.
+               detup=0.
+            endif
+            totmas=subin-subdown+detup-entup-entdo+ &
+                   detdo-entupk-entdoj+detupk+zuo(i,k+1)-zuo(i,k)
+            if(abs(totmas).gt.1.e-6)then
+               write(0,123)'totmas=',k22(i),kbcon(i),k,entup,detup,zuo(i,k+1),zuo(i,k),detdo,entdo
+123     formAT(a7,1X,3i3,2E12.4,2(1x,f5.2),2e12.4)
+            endif
+            dp=100.*(po_cup(i,k)-po_cup(i,k+1))
+             pgc=pgcon
+            if(k.ge.ktop(i))pgc=0.
+
+             dellu(i,k) =-(zuo(i,k+1)*(uc (i,k+1)-u_cup(i,k+1) ) -                               &
+                            zuo(i,k  )*(uc (i,k  )-u_cup(i,k  ) ) )*g/dp                         &
+                          +(zdo(i,k+1)*(ucd(i,k+1)-u_cup(i,k+1) ) -                              &
+                            zdo(i,k  )*(ucd(i,k  )-u_cup(i,k  ) ) )*g/dp*edto(i)*pgcd
+             dellv(i,k) =-(zuo(i,k+1)*(vc (i,k+1)-v_cup(i,k+1) ) -                               &
+                            zuo(i,k  )*(vc (i,k  )-v_cup(i,k  ) ) )*g/dp                         &
+                         +(zdo(i,k+1)*(vcd(i,k+1)-v_cup(i,k+1) ) -                               &
+                            zdo(i,k  )*(vcd(i,k  )-v_cup(i,k  ) ) )*g/dp*edto(i)*pgcd
+ 
+       enddo   ! k
+
+      endif
+    enddo
+
+
+    do i=its,itf
+        !trash  = 0.0
+        !trash2 = 0.0
+        if(ierr(i).eq.0)then
+
+         dp=100.*(po_cup(i,1)-po_cup(i,2))
+
+         dellah(i,1)=(edto(i)*zdo(i,2)*hcdo(i,2)          &
+                     -edto(i)*zdo(i,2)*heo_cup(i,2))*g/dp
+
+         dellaq (i,1)=(edto(i)*zdo(i,2)*qcdo(i,2)         &
+                      -edto(i)*zdo(i,2)*qo_cup(i,2))*g/dp
+        
+         G_rain=  0.5*(pwo (i,1)+pwo (i,2))*g/dp
+         E_dn  = -0.5*(pwdo(i,1)+pwdo(i,2))*g/dp*edto(i)  ! pwdo < 0 and E_dn must > 0
+         dellaq(i,1) = dellaq(i,1)+ E_dn-G_rain
+         
+         !--- conservation check
+         !- water mass balance
+         !trash = trash  + (dellaq(i,1)+dellaqc(i,1)+G_rain-E_dn)*dp/g          
+         !- H  budget
+         !trash2 = trash2+ (dellah(i,1))*dp/g
+         
+
+         do k=kts+1,ktop(i)
+            dp=100.*(po_cup(i,k)-po_cup(i,k+1))
+            ! these three are only used at or near mass detrainment and/or entrainment levels
+
+            dellah(i,k) =-(zuo(i,k+1)*(hco (i,k+1)-heo_cup(i,k+1) ) -                 &
+                           zuo(i,k  )*(hco (i,k  )-heo_cup(i,k  ) ) )*g/dp            &
+                         +(zdo(i,k+1)*(hcdo(i,k+1)-heo_cup(i,k+1) ) -                 &
+                           zdo(i,k  )*(hcdo(i,k  )-heo_cup(i,k  ) ) )*g/dp*edto(i)
+                        
+
+            !- check H conservation 
+            ! trash2 = trash2+ (dellah(i,k))*dp/g
+        
+        
+            !-- take out cloud liquid water for detrainment
+            detup=up_massdetro(i,k)
+            dz=zo_cup(i,k)-zo_cup(i,k-1)
+            if(k.lt.ktop(i)) dellaqc(i,k) = zuo(i,k)*c1d(i,k)*qrco(i,k)*dz/dp*g 
+!             dellaqc(i,k)=  detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp
+            if(k.eq.ktop(i))dellaqc(i,k)= detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp
+            !---
+            G_rain=  0.5*(pwo (i,k)+pwo (i,k+1))*g/dp
+            E_dn  = -0.5*(pwdo(i,k)+pwdo(i,k+1))*g/dp*edto(i) ! pwdo < 0 and E_dn must > 0
+            !-- condensation source term = detrained + flux divergence of
+            !-- cloud liquid water (qrco) + converted to rain
+        
+            C_up = dellaqc(i,k)+(zuo(i,k+1)* qrco(i,k+1) -                           &
+                                zuo(i,k  )* qrco(i,k  )  )*g/dp + G_rain
+!            C_up = dellaqc(i,k)+ G_rain
+            !-- water vapor budget
+            !-- = flux divergence z*(Q_c - Q_env)_up_and_down                        &
+            !--   - condensation term + evaporation
+            dellaq(i,k) =-(zuo(i,k+1)*(qco (i,k+1)-qo_cup(i,k+1) ) -                 &
+                           zuo(i,k  )*(qco (i,k  )-qo_cup(i,k  ) ) )*g/dp            &
+                         +(zdo(i,k+1)*(qcdo(i,k+1)-qo_cup(i,k+1) ) -                 &
+                           zdo(i,k  )*(qcdo(i,k  )-qo_cup(i,k  ) ) )*g/dp*edto(i)    &
+                         - C_up + E_dn
+            !- check water conservation liq+condensed (including rainfall)
+            ! trash= trash+ (dellaq(i,k)+dellaqc(i,k)+ G_rain-E_dn)*dp/g
+
+         enddo   ! k
+        endif
+
+      enddo
+444   format(1x,i2,1x,7e12.4) !,1x,f7.2,2x,e13.5)
+!
+!--- using dellas, calculate changed environmental profiles
+!
+      mbdt=.1
+      do i=its,itf
+      xaa0_ens(i,1)=0.
+      enddo
+
+      do i=its,itf
+         if(ierr(i).eq.0)then
+           do k=kts,ktf
+            XHE(I,K)=DELLAH(I,K)*MBDT+HEO(I,K)
+!            XQ(I,K)=max(1.e-16,(dellaqc(i,k)+DELLAQ(I,K))*MBDT+QO(I,K))
+            XQ(I,K)=max(1.e-16,DELLAQ(I,K)*MBDT+QO(I,K))
+            DELLAT(I,K)=(1./cp)*(DELLAH(I,K)-xlv*DELLAQ(I,K))
+!            XT(I,K)= (DELLAT(I,K)-xlv/cp*dellaqc(i,k))*MBDT+TN(I,K)
+            XT(I,K)= DELLAT(I,K)*MBDT+TN(I,K)
+            xt(i,k)=max(190.,xt(i,k))
+           enddo
+         ENDIF
+      enddo
+      do i=its,itf
+      if(ierr(i).eq.0)then
+      XHE(I,ktf)=HEO(I,ktf)
+      XQ(I,ktf)=QO(I,ktf)
+      XT(I,ktf)=TN(I,ktf)
+      endif
+      enddo
+!
+!--- calculate moist static energy, heights, qes
+!
+      call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1,                   &
+           psur,ierr,tcrit,-1,                                     &
+           itf,ktf,                                                &
+           its,ite, kts,kte)
+!
+!--- environmental values on cloud levels
+!
+      call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, &
+           xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur,   &
+           ierr,z1,                                                &
+           itf,ktf,                                                &
+           its,ite, kts,kte)
+!
+!
+!**************************** static control
+!
+!--- moist static energy inside cloud
+!
+      do k=kts,ktf
+      do i=its,itf
+         xhc(i,k)=0.
+         xDBY(I,K)=0.
+      enddo
+      enddo
+      do i=its,itf
+        if(ierr(i).eq.0)then
+         x_add = xlv*zqexec(i)+cp*ztexec(i)
+         call get_cloud_bc(kte,xhe_cup (i,1:kte),xhkb (i),k22(i),x_add)
+         do k=1,start_level(i)-1
+            xhc(i,k)=xhe_cup(i,k)
+         enddo
+         k=start_level(i)
+         xhc(i,k)=xhkb(i)
+        endif !ierr
+      enddo
+!
+!
+      do i=its,itf
+       if(ierr(i).eq.0)then
+        do k=start_level(i)  +1,ktop(i)
+         xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1)  + &
+                                            up_massentro(i,k-1)*xhe(i,k-1)) / &
+                             (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1))
+         xdby(i,k)=xhc(i,k)-xhes_cup(i,k)
+        enddo
+        do k=ktop(i)+1,ktf
+           xHC (i,K)=xhes_cup(i,k)
+           xDBY(I,K)=0.
+        enddo
+       endif
+      enddo
+
+!
+!--- workfunctions for updraft
+!
+      call cup_up_aa0(xaa0,xz,xzu,xdby,GAMMA_CUP,xt_cup, &
+           kbcon,ktop,ierr,                              &
+           itf,ktf,                                      &
+           its,ite, kts,kte)
+      do i=its,itf 
+         if(ierr(i).eq.0)then
+           xaa0_ens(i,1)=xaa0(i)
+           do k=kts,ktop(i)
+                 do nens3=1,maxens3
+                 if(nens3.eq.7)then
+!--- b=0
+                 pr_ens(i,nens3)=pr_ens(i,nens3)  &
+                                    +pwo(i,k)+edto(i)*pwdo(i,k) 
+!--- b=beta
+                 else if(nens3.eq.8)then
+                 pr_ens(i,nens3)=pr_ens(i,nens3)+ &
+                                    pwo(i,k)+edto(i)*pwdo(i,k)
+!--- b=beta/2
+                 else if(nens3.eq.9)then
+                 pr_ens(i,nens3)=pr_ens(i,nens3)  &
+                                 +  pwo(i,k)+edto(i)*pwdo(i,k)
+                 else
+                 pr_ens(i,nens3)=pr_ens(i,nens3)+ &
+                                    pwo(i,k) +edto(i)*pwdo(i,k)
+                 endif
+                 enddo
+           enddo
+         if(pr_ens(i,7).lt.1.e-6)then
+            ierr(i)=18
+            ierrc(i)="total normalized condensate too small"
+            do nens3=1,maxens3
+               pr_ens(i,nens3)=0.
+            enddo
+         endif
+         do nens3=1,maxens3
+           if(pr_ens(i,nens3).lt.1.e-5)then
+            pr_ens(i,nens3)=0.
+           endif
+         enddo
+         endif
+      enddo
+ 200  continue
+!
+!--- LARGE SCALE FORCING
+!
+!
+!------- CHECK wether aa0 should have been zero, assuming this 
+!        ensemble is chosen
+!
+!
+      do i=its,itf
+         ierr2(i)=ierr(i)
+         ierr3(i)=ierr(i)
+         k22x(i)=k22(i)
+      enddo
+        CALL cup_MAXIMI(HEO_CUP,2,KBMAX,K22x,ierr,                        &
+             itf,ktf,                                                     &
+             its,ite, kts,kte)
+        iloop=2
+        call cup_kbcon(ierrc,cap_max_increment,iloop,k22x,kbconx,heo_cup, &
+             heso_cup,hkbo,ierr2,kbmax,po_cup,cap_max,                    &
+             ztexec,zqexec,                                               &
+             0,itf,ktf,                                                   &
+             its,ite, kts,kte,                                            &
+             z_cup,entr_rate,heo,imid)
+        iloop=3
+        call cup_kbcon(ierrc,cap_max_increment,iloop,k22x,kbconx,heo_cup, &
+             heso_cup,hkbo,ierr3,kbmax,po_cup,cap_max,                    &
+             ztexec,zqexec,                                               &
+             0,itf,ktf,                                                   &
+             its,ite, kts,kte,                                            &
+             z_cup,entr_rate,heo,imid)
+!
+!--- calculate cloud base mass flux
+!
+
+      DO I = its,itf
+        mconv(i) = 0
+        if(ierr(i)/=0)cycle
+        DO K=1,ktop(i)
+          dq=(qo_cup(i,k+1)-qo_cup(i,k))
+          mconv(i)=mconv(i)+omeg(i,k)*dq/g
+        ENDDO
+      ENDDO
+      call cup_forcing_ens_3d(closure_n,xland1,aa0,aa1,xaa0_ens,mbdt,dtime, &
+           ierr,ierr2,ierr3,xf_ens,axx,forcing,                             &
+           maxens3,mconv,rand_clos,                                         &
+           po_cup,ktop,omeg,zdo,k22,zuo,pr_ens,edto,kbcon,                  &
+           ichoice,                                                         &
+           imid,ipr,itf,ktf,                                                &
+           its,ite, kts,kte,                                                &
+           dicycle,tau_ecmwf,aa1_bl,xf_dicycle)
+!
+      do k=kts,ktf
+      do i=its,itf
+        if(ierr(i).eq.0)then
+           dellat_ens (i,k,1)=dellat(i,k)
+           dellaq_ens (i,k,1)=dellaq(i,k)
+           dellaqc_ens(i,k,1)=dellaqc(i,k)
+           pwo_ens    (i,k,1)=pwo(i,k) !+edto(i)*pwdo(i,k)
+        else 
+           dellat_ens (i,k,1)=0.
+           dellaq_ens (i,k,1)=0.
+           dellaqc_ens(i,k,1)=0.
+           pwo_ens    (i,k,1)=0.
+        endif
+      enddo
+      enddo
+ 250  continue
+!
+!--- FEEDBACK
+!
+       if(imid.eq.1 .and. ichoice .le.2)then
+         do i=its,itf
+          !-boundary layer QE 
+          xff_mid(i,1)=0.
+          xff_mid(i,2)=0.
+          if(ierr(i).eq.0)then
+            blqe=0.
+            trash=0.
+            if(k22(i).lt.kpbl(i)+1)then
+               do k=1,kpbl(i)
+                  blqe=blqe+100.*dhdt(i,k)*(po_cup(i,k)-po_cup(i,k+1))/g
+               enddo
+               trash=max((hco(i,kbcon(i))-heo_cup(i,kbcon(i))),1.e1)
+               xff_mid(i,1)=max(0.,blqe/trash)
+               xff_mid(i,1)=min(0.1,xff_mid(i,1))
+             endif
+             xff_mid(i,2)=min(0.1,.03*zws(i))
+          endif
+         enddo
+       endif
+       call cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat_ens,dellaq_ens, &
+            dellaqc_ens,outt,                                            &
+            outq,outqc,zuo,pre,pwo_ens,xmb,ktop,                         &
+            edto,pwdo,'deep',ierr2,ierr3,                                          &
+            po_cup,pr_ens,maxens3,                                              &
+            sig,closure_n,xland1,xmbm_in,xmbs_in,                        &
+            ichoice,imid,ipr,itf,ktf,                                    &
+            its,ite, kts,kte,                                            &
+            dicycle,xf_dicycle )
+      k=1
+      do i=its,itf
+          if(ierr(i).eq.0 .and.pre(i).gt.0.) then
+             PRE(I)=MAX(PRE(I),0.)
+             xmb_out(i)=xmb(i)
+             do k=kts,ktop(i)
+               outu(i,k)=dellu(i,k)*xmb(i)
+               outv(i,k)=dellv(i,k)*xmb(i)
+             enddo
+          elseif(ierr(i).ne.0 .or. pre(i).eq.0.)then
+             ktop(i)=0
+             do k=kts,kte
+               outt(i,k)=0.
+               outq(i,k)=0.
+               outqc(i,k)=0.
+               outu(i,k)=0.
+               outv(i,k)=0.
+             enddo
+          endif
+      enddo
+! rain evaporation as in SAS
+!
+      if(irainevap.eq.1)then
+      do i = its,itf
+       rntot(i) = 0.
+       delqev(i) = 0.
+       delq2(i) = 0.
+       rn(i)    = 0.
+       rntot(i)    = 0.
+       rain=0.
+       if(ierr(i).eq.0)then
+         do k = ktop(i), 1, -1
+              rain =  pwo(i,k) + edto(i) * pwdo(i,k)
+              rntot(i) = rntot(i) + rain * xmb(i)* .001 * dtime
+         enddo
+       endif
+      enddo
+      do i = its,itf
+         qevap(i) = 0.
+         flg(i) = .true.
+         if(ierr(i).eq.0)then
+         evef = edt(i) * evfact
+         if(xland(i).gt.0.5 .and. xland(i).lt.1.5) evef=edt(i) * evfactl
+         do k = ktop(i), 1, -1
+              rain =  pwo(i,k) + edto(i) * pwdo(i,k)
+              rn(i) = rn(i) + rain * xmb(i) * .001 * dtime
+              if(flg(i))then
+              q1=qo(i,k)+(outq(i,k))*dtime
+              t1=tn(i,k)+(outt(i,k))*dtime
+              qcond(i) = evef * (q1 - qeso(i,k))            &
+     &                 / (1. + el2orc * qeso(i,k) / t1**2)
+              dp = -100.*(p_cup(i,k+1)-p_cup(i,k))
+              if(rn(i).gt.0. .and. qcond(i).lt.0.) then
+                qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dtime*rn(i))))
+                qevap(i) = min(qevap(i), rn(i)*1000.*g/dp)
+                delq2(i) = delqev(i) + .001 * qevap(i) * dp / g
+              endif
+              if(rn(i).gt.0..and.qcond(i).lt.0..and. &
+     &           delq2(i).gt.rntot(i)) then
+                qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp
+                flg(i) = .false.
+              endif
+              if(rn(i).gt.0..and.qevap(i).gt.0.) then
+                outq(i,k) = outq(i,k) + qevap(i)/dtime
+                outt(i,k) = outt(i,k) - elocp * qevap(i)/dtime
+                rn(i) = max(0.,rn(i) - .001 * qevap(i) * dp / g)
+                pre(i) = pre(i) - qevap(i) * dp /g/dtime
+                PRE(I)=MAX(PRE(I),0.)
+                delqev(i) = delqev(i) + .001*dp*qevap(i)/g
+              endif
+          endif
+        enddo
+!       pre(i)=1000.*rn(i)/dtime
+      endif
+      enddo
+      endif
+!
+! since kinetic energy is being dissipated, add heating accordingly (from ECMWF)
+!
+      do i=its,itf
+          if(ierr(i).eq.0) then
+             dts=0.
+             fpi=0.
+             do k=kts,ktop(i)
+                dp=(po_cup(i,k)-po_cup(i,k+1))*100.
+!total KE dissiptaion estimate
+                dts= dts -(outu(i,k)*us(i,k)+outv(i,k)*vs(i,k))*dp/g
+! fpi needed for calcualtion of conversion to pot. energyintegrated 
+                fpi = fpi  +sqrt(outu(i,k)*outu(i,k) + outv(i,k)*outv(i,k))*dp
+             enddo
+             if(fpi.gt.0.)then
+                do k=kts,ktop(i)
+                   fp= sqrt((outu(i,k)*outu(i,k)+outv(i,k)*outv(i,k)))/fpi
+                   outt(i,k)=outt(i,k)+fp*dts*g/cp
+                enddo
+             endif
+          endif
+      enddo
+
+
+!
+!---------------------------done------------------------------
+!
+
+   END SUBROUTINE CUP_gf
+
+
+   SUBROUTINE cup_dd_edt(ierr,us,vs,z,ktop,kbcon,edt,p,pwav, &
+              pw,ccn,pwev,edtmax,edtmin,edtc,psum2,psumh,    &
+              rho,aeroevap,itf,ktf,                          &
+              its,ite, kts,kte                     )
+
+   IMPLICIT NONE
+
+     integer                                                 &
+        ,intent (in   )                   ::                 &
+        aeroevap,itf,ktf,                                    &
+        its,ite, kts,kte
+  !
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                    &
+        ,intent (in   )                   ::                 &
+        rho,us,vs,z,p,pw
+     real,    dimension (its:ite,1)                          &
+        ,intent (out  )                   ::                 &
+        edtc
+     real,    dimension (its:ite)                            &
+        ,intent (out  )                   ::                 &
+        edt
+     real,    dimension (its:ite)                            &
+        ,intent (in   )                   ::                 &
+        pwav,pwev,ccn,psum2,psumh,edtmax,edtmin
+     integer, dimension (its:ite)                            &
+        ,intent (in   )                   ::                 &
+        ktop,kbcon
+     integer, dimension (its:ite)                            &
+        ,intent (inout)                   ::                 &
+        ierr
+!
+!  local variables in this routine
+!
+
+     integer i,k,kk
+     real    einc,pef,pefb,prezk,zkbc
+     real,    dimension (its:ite)         ::                 &
+      vshear,sdp,vws
+     real :: prop_c,pefc,aeroadd,alpha3,beta3
+     prop_c=8. !10.386
+     alpha3 = 1.9
+     beta3  = -1.13
+     pefc=0.
+
+!
+!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
+!
+! */ calculate an average wind shear over the depth of the cloud
+!
+       do i=its,itf
+        edt(i)=0.
+        vws(i)=0.
+        sdp(i)=0.
+        vshear(i)=0.
+       enddo
+       do i=its,itf
+        edtc(i,1)=0.
+       enddo
+       do kk = kts,ktf-1
+         do 62 i=its,itf
+          IF(ierr(i).ne.0)GO TO 62
+          if (kk .le. min0(ktop(i),ktf) .and. kk .ge. kbcon(i)) then
+             vws(i) = vws(i)+                                        &
+              (abs((us(i,kk+1)-us(i,kk))/(z(i,kk+1)-z(i,kk)))        &
+          +   abs((vs(i,kk+1)-vs(i,kk))/(z(i,kk+1)-z(i,kk)))) *      &
+              (p(i,kk) - p(i,kk+1))
+            sdp(i) = sdp(i) + p(i,kk) - p(i,kk+1)
+          endif
+          if (kk .eq. ktf-1)vshear(i) = 1.e3 * vws(i) / sdp(i)
+   62   continue
+       end do
+      do i=its,itf
+         IF(ierr(i).eq.0)then
+            pef=(1.591-.639*VSHEAR(I)+.0953*(VSHEAR(I)**2)            &
+               -.00496*(VSHEAR(I)**3))
+            if(pef.gt.0.9)pef=0.9
+            if(pef.lt.0.1)pef=0.1
+!
+!--- cloud base precip efficiency
+!
+            zkbc=z(i,kbcon(i))*3.281e-3
+            prezk=.02
+            if(zkbc.gt.3.)then
+               prezk=.96729352+zkbc*(-.70034167+zkbc*(.162179896+zkbc &
+               *(- 1.2569798E-2+zkbc*(4.2772E-4-zkbc*5.44E-6))))
+            endif
+            if(zkbc.gt.25)then
+               prezk=2.4
+            endif
+            pefb=1./(1.+prezk)
+            if(pefb.gt.0.9)pefb=0.9
+            if(pefb.lt.0.1)pefb=0.1
+            EDT(I)=1.-.5*(pefb+pef)
+            if(aeroevap.gt.1)then
+               aeroadd=(ccnclean**beta3)*((psumh(i))**(alpha3-1)) !*1.e6
+!              prop_c=.9/aeroadd
+               prop_c=.5*(pefb+pef)/aeroadd
+               aeroadd=(ccn(i)**beta3)*((psum2(i))**(alpha3-1)) !*1.e6
+               aeroadd=prop_c*aeroadd
+               pefc=aeroadd
+               if(pefc.gt.0.9)pefc=0.9
+               if(pefc.lt.0.1)pefc=0.1
+               EDT(I)=1.-pefc
+               if(aeroevap.eq.2)EDT(I)=1.-.25*(pefb+pef+2.*pefc)
+            endif
+
+
+!--- edt here is 1-precipeff!
+            einc=.2*edt(i)
+            edtc(i,1)=edt(i)-einc
+         endif
+      enddo
+      do i=its,itf
+         IF(ierr(i).eq.0)then
+               EDTC(I,1)=-EDTC(I,1)*pwav(I)/PWEV(I)
+               IF(EDTC(I,1).GT.edtmax(i))EDTC(I,1)=edtmax(i)
+               IF(EDTC(I,1).LT.edtmin(i))EDTC(I,1)=edtmin(i)
+         endif
+      enddo
+
+   END SUBROUTINE cup_dd_edt
+
+
+   SUBROUTINE cup_dd_moisture(ierrc,zd,hcd,hes_cup,qcd,qes_cup,  &
+              pwd,q_cup,z_cup,dd_massentr,dd_massdetr,jmin,ierr, &
+              gamma_cup,pwev,bu,qrcd,                            &
+              q,he,iloop,                                        &
+              itf,ktf,                                           &
+              its,ite, kts,kte                     )
+
+   IMPLICIT NONE
+
+     integer                                                     &
+        ,intent (in   )                   ::                     &
+                                  itf,ktf,                       &
+                                  its,ite, kts,kte
+  ! cdd= detrainment function 
+  ! q = environmental q on model levels
+  ! q_cup = environmental q on model cloud levels
+  ! qes_cup = saturation q on model cloud levels
+  ! hes_cup = saturation h on model cloud levels
+  ! hcd = h in model cloud
+  ! bu = buoancy term
+  ! zd = normalized downdraft mass flux
+  ! gamma_cup = gamma on model cloud levels
+  ! mentr_rate = entrainment rate
+  ! qcd = cloud q (including liquid water) after entrainment
+  ! qrch = saturation q in cloud
+  ! pwd = evaporate at that level
+  ! pwev = total normalized integrated evaoprate (I2)
+  ! entr= entrainment rate 
+  !
+     real,    dimension (its:ite,kts:kte)               &
+        ,intent (in   )                   ::            &
+        zd,hes_cup,hcd,qes_cup,q_cup,z_cup,             &
+        dd_massentr,dd_massdetr,gamma_cup,q,he 
+     integer                                            &
+        ,intent (in   )                   ::            &
+        iloop
+     integer, dimension (its:ite)                       &
+        ,intent (in   )                   ::            &
+        jmin
+     integer, dimension (its:ite)                       &
+        ,intent (inout)                   ::            &
+        ierr
+     real,    dimension (its:ite,kts:kte)&
+        ,intent (out  )                   ::            &
+        qcd,qrcd,pwd
+     real,    dimension (its:ite)&
+        ,intent (out  )                   ::            &
+        pwev,bu
+     character*50 :: ierrc(its:ite)
+!
+!  local variables in this routine
+!
+
+     integer                              ::            &
+        i,k,ki
+     real                                 ::            &
+        denom,dh,dz,dqeva
+
+      do i=its,itf
+         bu(i)=0.
+         pwev(i)=0.
+      enddo
+      do k=kts,ktf
+      do i=its,itf
+         qcd(i,k)=0.
+         qrcd(i,k)=0.
+         pwd(i,k)=0.
+      enddo
+      enddo
+!
+!
+!
+      do 100 i=its,itf
+      IF(ierr(I).eq.0)then
+      k=jmin(i)
+      DZ=Z_cup(i,K+1)-Z_cup(i,K)
+      qcd(i,k)=q_cup(i,k)
+      DH=HCD(I,k)-HES_cup(I,K)
+      if(dh.lt.0)then
+        QRCD(I,K)=(qes_cup(i,k)+(1./XLV)*(GAMMA_cup(i,k) &
+                  /(1.+GAMMA_cup(i,k)))*DH)
+        else
+          qrcd(i,k)=qes_cup(i,k)
+        endif
+      pwd(i,jmin(i))=zd(i,jmin(i))*min(0.,qcd(i,k)-qrcd(i,k))
+      qcd(i,k)=qrcd(i,k)
+      pwev(i)=pwev(i)+pwd(i,jmin(i)) ! *dz
+!
+      bu(i)=dz*dh
+      do ki=jmin(i)-1,1,-1
+         DZ=Z_cup(i,Ki+1)-Z_cup(i,Ki)
+!        QCD(i,Ki)=(qCD(i,Ki+1)*(1.-.5*CDD(i,Ki+1)*DZ) &
+!                 +entr*DZ*q(i,Ki) &
+!                )/(1.+entr*DZ-.5*CDD(i,Ki+1)*DZ)
+!        dz=qcd(i,ki)
+!print*,"i=",i," k=",ki," qcd(i,ki+1)=",qcd(i,ki+1)
+!print*,"zd=",zd(i,ki+1)," dd_ma=",dd_massdetr(i,ki)," q=",q(i,ki)
+!JOE-added check for non-zero denominator:
+         denom=zd(i,ki+1)-.5*dd_massdetr(i,ki)+dd_massentr(i,ki)
+         if(denom.lt.1.e-8)then
+            ierr(i)=51
+            exit
+         endif
+         qcd(i,ki)=(qcd(i,ki+1)*zd(i,ki+1)                    &
+                  -.5*dd_massdetr(i,ki)*qcd(i,ki+1)+          &
+                  dd_massentr(i,ki)*q(i,ki))   /              &
+                  (zd(i,ki+1)-.5*dd_massdetr(i,ki)+dd_massentr(i,ki))
+!
+!--- to be negatively buoyant, hcd should be smaller than hes!
+!--- ideally, dh should be negative till dd hits ground, but that is not always
+!--- the case
+!
+         DH=HCD(I,ki)-HES_cup(I,Ki)
+         bu(i)=bu(i)+dz*dh
+         QRCD(I,Ki)=qes_cup(i,ki)+(1./XLV)*(GAMMA_cup(i,ki)   &
+                  /(1.+GAMMA_cup(i,ki)))*DH
+         dqeva=qcd(i,ki)-qrcd(i,ki)
+         if(dqeva.gt.0.)then
+          dqeva=0.
+          qrcd(i,ki)=qcd(i,ki)
+         endif
+         pwd(i,ki)=zd(i,ki)*dqeva
+         qcd(i,ki)=qrcd(i,ki)
+         pwev(i)=pwev(i)+pwd(i,ki) ! *dz
+!        if(iloop.eq.1.and.i.eq.102.and.j.eq.62)then
+!         print *,'in cup_dd_moi ', hcd(i,ki),HES_cup(I,Ki),dh,dqeva
+!        endif
+      enddo
+!
+!--- end loop over i
+       if( (pwev(i).eq.0.) .and. (iloop.eq.1))then
+!        print *,'problem with buoy in cup_dd_moisture',i
+         ierr(i)=7
+         ierrc(i)="problem with buoy in cup_dd_moisture"
+       endif
+       if(BU(I).GE.0.and.iloop.eq.1)then
+!        print *,'problem with buoy in cup_dd_moisture',i
+         ierr(i)=7
+         ierrc(i)="problem2 with buoy in cup_dd_moisture"
+       endif
+      endif
+100    continue
+
+   END SUBROUTINE cup_dd_moisture
+
+   SUBROUTINE cup_env(z,qes,he,hes,t,q,p,z1,                &
+              psur,ierr,tcrit,itest,                        &
+              itf,ktf,                                      &
+              its,ite, kts,kte                     )
+
+   IMPLICIT NONE
+
+     integer                                                &
+        ,intent (in   )                   ::                &
+        itf,ktf,                                            &
+        its,ite, kts,kte
+  !
+  ! ierr error value, maybe modified in this routine
+  ! q           = environmental mixing ratio
+  ! qes         = environmental saturation mixing ratio
+  ! t           = environmental temp
+  ! tv          = environmental virtual temp
+  ! p           = environmental pressure
+  ! z           = environmental heights
+  ! he          = environmental moist static energy
+  ! hes         = environmental saturation moist static energy
+  ! psur        = surface pressure
+  ! z1          = terrain elevation
+  ! 
+  !
+     real,    dimension (its:ite,kts:kte)                &
+        ,intent (in   )                   ::             &
+        p,t,q
+     real,    dimension (its:ite,kts:kte)                &
+        ,intent (out  )                   ::             &
+        he,hes,qes
+     real,    dimension (its:ite,kts:kte)                &
+        ,intent (inout)                   ::             &
+        z
+     real,    dimension (its:ite)                        &
+        ,intent (in   )                   ::             &
+        psur,z1
+     integer, dimension (its:ite)                        &
+        ,intent (inout)                   ::             &
+        ierr
+     integer                                             &
+        ,intent (in   )                   ::             &
+        itest
+!
+!  local variables in this routine
+!
+
+     integer                              ::             &
+       i,k
+!     real, dimension (1:2) :: AE,BE,HT
+      real, dimension (its:ite,kts:kte) :: tv
+      real :: tcrit,e,tvbar
+!     real, external :: satvap
+!     real :: satvap
+
+
+!      HT(1)=XLV/CP
+!      HT(2)=2.834E6/CP
+!      BE(1)=.622*HT(1)/.286
+!      AE(1)=BE(1)/273.+ALOG(610.71)
+!      BE(2)=.622*HT(2)/.286
+!      AE(2)=BE(2)/273.+ALOG(610.71)
+      do k=kts,ktf
+      do i=its,itf
+        if(ierr(i).eq.0)then
+!Csgb - IPH is for phase, dependent on TCRIT (water or ice)
+!       IPH=1
+!       IF(T(I,K).LE.TCRIT)IPH=2
+!       print *, 'AE(IPH),BE(IPH) = ',AE(IPH),BE(IPH),AE(IPH)-BE(IPH),T(i,k),i,k
+!       E=EXP(AE(IPH)-BE(IPH)/T(I,K))
+!       print *, 'P, E = ', P(I,K), E
+!       QES(I,K)=.622*E/(100.*P(I,K)-E)
+        e=satvap(t(i,k))
+        qes(i,k)=0.622*e/max(1.e-8,(p(i,k)-e))
+        IF(QES(I,K).LE.1.E-16)QES(I,K)=1.E-16
+        IF(QES(I,K).LT.Q(I,K))QES(I,K)=Q(I,K)
+!       IF(Q(I,K).GT.QES(I,K))Q(I,K)=QES(I,K)
+        TV(I,K)=T(I,K)+.608*Q(I,K)*T(I,K)
+        endif
+      enddo
+      enddo
+!
+!--- z's are calculated with changed h's and q's and t's
+!--- if itest=2
+!
+      if(itest.eq.1 .or. itest.eq.0)then
+         do i=its,itf
+           if(ierr(i).eq.0)then
+             Z(I,1)=max(0.,Z1(I))-(ALOG(P(I,1))- &
+                 ALOG(PSUR(I)))*287.*TV(I,1)/9.81
+           endif
+         enddo
+
+! --- calculate heights
+         DO K=kts+1,ktf
+         do i=its,itf
+           if(ierr(i).eq.0)then
+              TVBAR=.5*TV(I,K)+.5*TV(I,K-1)
+              Z(I,K)=Z(I,K-1)-(ALOG(P(I,K))- &
+               ALOG(P(I,K-1)))*287.*TVBAR/9.81
+           endif
+         enddo
+         enddo
+      else if(itest.eq.2)then
+         do k=kts,ktf
+         do i=its,itf
+           if(ierr(i).eq.0)then
+             z(i,k)=(he(i,k)-1004.*t(i,k)-2.5e6*q(i,k))/9.81
+             z(i,k)=max(1.e-3,z(i,k))
+           endif
+         enddo
+         enddo
+      else if(itest.eq.-1)then
+      endif
+!
+!--- calculate moist static energy - HE
+!    saturated moist static energy - HES
+!
+       DO k=kts,ktf
+       do i=its,itf
+         if(ierr(i).eq.0)then
+         if(itest.le.0)HE(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*Q(I,K)
+         HES(I,K)=9.81*Z(I,K)+1004.*T(I,K)+2.5E06*QES(I,K)
+         IF(HE(I,K).GE.HES(I,K))HE(I,K)=HES(I,K)
+         endif
+      enddo
+      enddo
+
+   END SUBROUTINE cup_env
+
+
+   SUBROUTINE cup_env_clev(t,qes,q,he,hes,z,p,qes_cup,q_cup,        &
+              he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur,      &
+              ierr,z1,                                              &
+              itf,ktf,                                              &
+              its,ite, kts,kte                       )
+
+   IMPLICIT NONE
+
+     integer                                                        &
+        ,intent (in   )                   ::                        &
+        itf,ktf,                                                    &
+        its,ite, kts,kte
+  !
+  ! ierr error value, maybe modified in this routine
+  ! q           = environmental mixing ratio
+  ! q_cup       = environmental mixing ratio on cloud levels
+  ! qes         = environmental saturation mixing ratio
+  ! qes_cup     = environmental saturation mixing ratio on cloud levels
+  ! t           = environmental temp
+  ! t_cup       = environmental temp on cloud levels
+  ! p           = environmental pressure
+  ! p_cup       = environmental pressure on cloud levels
+  ! z           = environmental heights
+  ! z_cup       = environmental heights on cloud levels
+  ! he          = environmental moist static energy
+  ! he_cup      = environmental moist static energy on cloud levels
+  ! hes         = environmental saturation moist static energy
+  ! hes_cup     = environmental saturation moist static energy on cloud levels
+  ! gamma_cup   = gamma on cloud levels
+  ! psur        = surface pressure
+  ! z1          = terrain elevation
+  ! 
+  !
+     real,    dimension (its:ite,kts:kte)                        &
+        ,intent (in   )                   ::                     &
+        qes,q,he,hes,z,p,t
+     real,    dimension (its:ite,kts:kte)                        &
+        ,intent (out  )                   ::                     &
+        qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup
+     real,    dimension (its:ite)                                &
+        ,intent (in   )                   ::                     &
+        psur,z1
+     integer, dimension (its:ite)                                &
+        ,intent (inout)                   ::                     &
+        ierr
+!
+!  local variables in this routine
+!
+
+     integer                              ::                     &
+       i,k
+
+
+      do k=kts,ktf
+      do i=its,itf
+        qes_cup(i,k)=0.
+        q_cup(i,k)=0.
+        hes_cup(i,k)=0.
+        he_cup(i,k)=0.
+        z_cup(i,k)=0.
+        p_cup(i,k)=0.
+        t_cup(i,k)=0.
+        gamma_cup(i,k)=0.
+      enddo
+      enddo
+      do k=kts+1,ktf
+      do i=its,itf
+        if(ierr(i).eq.0)then
+        qes_cup(i,k)=.5*(qes(i,k-1)+qes(i,k))
+        q_cup(i,k)=.5*(q(i,k-1)+q(i,k))
+        hes_cup(i,k)=.5*(hes(i,k-1)+hes(i,k))
+        he_cup(i,k)=.5*(he(i,k-1)+he(i,k))
+        if(he_cup(i,k).gt.hes_cup(i,k))he_cup(i,k)=hes_cup(i,k)
+        z_cup(i,k)=.5*(z(i,k-1)+z(i,k))
+        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)=(xlv/cp)*(xlv/(r_v*t_cup(i,k) &
+                       *t_cup(i,k)))*qes_cup(i,k)
+        endif
+      enddo
+      enddo
+      do i=its,itf
+        if(ierr(i).eq.0)then
+        qes_cup(i,1)=qes(i,1)
+        q_cup(i,1)=q(i,1)
+!       hes_cup(i,1)=hes(i,1)
+!       he_cup(i,1)=he(i,1)
+        hes_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*qes(i,1)
+        he_cup(i,1)=9.81*z1(i)+1004.*t(i,1)+2.5e6*q(i,1)
+        z_cup(i,1)=.5*(z(i,1)+z1(i))
+        p_cup(i,1)=.5*(p(i,1)+psur(i))
+        z_cup(i,1)=z1(i)
+        p_cup(i,1)=psur(i)
+        t_cup(i,1)=t(i,1)
+        gamma_cup(i,1)=xlv/cp*(xlv/(r_v*t_cup(i,1) &
+                       *t_cup(i,1)))*qes_cup(i,1)
+        endif
+      enddo
+
+   END SUBROUTINE cup_env_clev
+
+   SUBROUTINE cup_forcing_ens_3d(closure_n,xland,aa0,aa1,xaa0,mbdt,dtime,ierr,ierr2,ierr3,&
+              xf_ens,axx,forcing,maxens3,mconv,rand_clos,             &
+              p_cup,ktop,omeg,zd,k22,zu,pr_ens,edt,kbcon,             &
+              ichoice,                                                &
+              imid,ipr,itf,ktf,                                       &
+              its,ite, kts,kte,                                       &
+              dicycle,tau_ecmwf,aa1_bl,xf_dicycle  )
+
+   IMPLICIT NONE
+
+     integer                                                          &
+        ,intent (in   )                   ::                          &
+        imid,ipr,itf,ktf,                                             &
+        its,ite, kts,kte
+     integer, intent (in   )              ::                          &
+        maxens3
+  !
+  ! ierr error value, maybe modified in this routine
+  ! pr_ens = precipitation ensemble
+  ! xf_ens = mass flux ensembles
+  ! massfln = downdraft mass flux ensembles used in next timestep
+  ! omeg = omega from large scale model
+  ! mconv = moisture convergence from large scale model
+  ! zd      = downdraft normalized mass flux
+  ! zu      = updraft normalized mass flux
+  ! aa0     = cloud work function without forcing effects
+  ! aa1     = cloud work function with forcing effects
+  ! xaa0    = cloud work function with cloud effects (ensemble dependent)
+  ! edt     = epsilon
+  ! dir     = "storm motion"
+  ! mbdt    = arbitrary numerical parameter
+  ! dtime   = dt over which forcing is applied
+  ! iact_gr_old = flag to tell where convection was active
+  ! kbcon       = LFC of parcel from k22
+  ! k22         = updraft originating level
+  ! ichoice       = flag if only want one closure (usually set to zero!)
+  !
+     real,    dimension (its:ite,1:maxens3)                            &
+        ,intent (inout)                   ::                           &
+        pr_ens
+     real,    dimension (its:ite,1:maxens3)                            &
+        ,intent (inout  )                 ::                           &
+        xf_ens
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        zd,zu,p_cup
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        omeg
+     real,    dimension (its:ite,1)                                    &
+        ,intent (in   )                   ::                           &
+        xaa0
+     real,    dimension (its:ite,4)                                    &
+        ,intent (in   )                   ::                           &
+       rand_clos 
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        aa1,edt
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        mconv,axx
+     real,    dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        aa0,closure_n
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        mbdt
+     real                                                              &
+        ,intent (in   )                   ::                           &
+        dtime
+     integer, dimension (its:ite)                                      &
+        ,intent (inout   )                ::                           &
+        k22,kbcon,ktop
+     integer, dimension (its:ite)                                      &
+        ,intent (in      )                ::                           &
+        xland
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr,ierr2,ierr3
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        ichoice
+      integer, intent(IN) :: DICYCLE
+      real,    intent(IN)   , dimension (its:ite) :: aa1_bl,tau_ecmwf
+      real,    intent(INOUT), dimension (its:ite) :: xf_dicycle
+      real,    intent(INOUT), dimension (its:ite,10) :: forcing
+      !- local var
+      real  :: xff_dicycle
+!
+!  local variables in this routine
+!
+
+     real,    dimension (1:maxens3)       ::                           &
+       xff_ens3
+     real,    dimension (1)               ::                           &
+       xk
+     integer                              ::                           &
+       kk,i,k,n,ne
+!     integer, parameter :: mkxcrt=15
+!     real,    dimension(1:mkxcrt)        ::                           &
+!       pcrit,acrit,acritt
+     integer, dimension (its:ite)         :: kloc
+     real                                 ::                           &
+       a1,a_ave,xff0,xomg!,aclim1,aclim2,aclim3,aclim4
+
+     real, dimension (its:ite) :: ens_adj
+
+
+
+!
+       ens_adj(:)=1.
+       xff_dicycle = 0.
+
+!--- LARGE SCALE FORCING
+!
+       DO 100 i=its,itf
+          kloc(i)=1
+          IF(ierr(i).eq.0)then
+           kloc(i)=maxloc(zu(i,:),1)
+           ens_adj(i)=1.
+!ss --- comment out adjustment over ocean
+!ss           if(ierr2(i).gt.0.and.ierr3(i).eq.0)ens_adj(i)=0.666 ! 2./3.
+!ss           if(ierr2(i).gt.0.and.ierr3(i).gt.0)ens_adj(i)=0.333
+!
+             a_ave=0.
+             a_ave=axx(i)
+             a_ave=max(0.,a_ave)
+             a_ave=min(a_ave,aa1(i))
+             a_ave=max(0.,a_ave)
+             xff_ens3(:)=0.
+             xff0= (AA1(I)-AA0(I))/DTIME
+             xff_ens3(1)=max(0.,(AA1(I)-AA0(I))/dtime)
+             xff_ens3(2)=max(0.,(AA1(I)-AA0(I))/dtime)
+             xff_ens3(3)=max(0.,(AA1(I)-AA0(I))/dtime)
+             xff_ens3(16)=max(0.,(AA1(I)-AA0(I))/dtime)
+             forcing(i,1)=xff_ens3(2)
+!   
+!--- omeg is in bar/s, mconv done with omeg in Pa/s
+!     more like Brown (1979), or Frank-Cohen (199?)
+!  
+! average aaround kbcon
+!
+             xomg=0.
+             kk=0
+             xff_ens3(4)=0.
+             xff_ens3(5)=0.
+             xff_ens3(6)=0.
+             do k=kbcon(i)-1,kbcon(i)+1
+                     if(zu(i,k).gt.0.)then
+                       xomg=xomg-omeg(i,k)/9.81/max(0.5,(1.-edt(i)*zd(i,k)/zu(i,k)))
+                       kk=kk+1
+                     endif
+             enddo
+             if(kk.gt.0)xff_ens3(4)=xomg/float(kk)
+            
+!
+! max below kbcon
+!             xff_ens3(6)=-omeg(i,k22(i))/9.81
+!             do k=k22(i),kbcon(i)
+!                     xomg=-omeg(i,k)/9.81
+!                     if(xomg.gt.xff_ens3(6))xff_ens3(6)=xomg
+!             enddo
+!
+!             if(zu(i,kbcon(i)) > 0)xff_ens3(6)=betajb*xff_ens3(6)/zu(i,kbcon(i))
+             xff_ens3(4)=betajb*xff_ens3(4)
+             xff_ens3(5)=xff_ens3(4)
+             xff_ens3(6)=xff_ens3(4)
+             if(xff_ens3(4).lt.0.)xff_ens3(4)=0.
+             if(xff_ens3(5).lt.0.)xff_ens3(5)=0.
+             if(xff_ens3(6).lt.0.)xff_ens3(6)=0.
+             xff_ens3(14)=betajb*xff_ens3(4)
+             forcing(i,2)=xff_ens3(4)
+!
+!--- more like Krishnamurti et al.; pick max and average values
+!
+              xff_ens3(7)= mconv(i)/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i))))
+              xff_ens3(8)= mconv(i)/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i))))
+              xff_ens3(9)= mconv(i)/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i))))
+              xff_ens3(15)=mconv(i)/max(0.5,(1.-edt(i)*zd(i,kbcon(i))/zu(i,kloc(i))))
+             forcing(i,3)=xff_ens3(8)
+!
+!--- more like Fritsch Chappel or Kain Fritsch (plus triggers)
+!
+             xff_ens3(10)=AA1(i)/tau_ecmwf(i)
+             xff_ens3(11)=AA1(I)/tau_ecmwf(i)
+             xff_ens3(12)=AA1(I)/tau_ecmwf(i)
+             xff_ens3(13)=(AA1(i))/tau_ecmwf(i) !(60.*15.) !tau_ecmwf(i)
+!             forcing(i,4)=xff_ens3(10)
+!- more like Bechtold et al. (JAS 2014)
+             if(dicycle == 1) xff_dicycle = max(0.,AA1_BL(i)/tau_ecmwf(i)) !(60.*30.) !tau_ecmwf(i)
+!gtest
+             if(ichoice.eq.0)then
+                if(xff0.lt.0.)then
+                     xff_ens3(1)=0.
+                     xff_ens3(2)=0.
+                     xff_ens3(3)=0.
+                     xff_ens3(10)=0.
+                     xff_ens3(11)=0.
+                     xff_ens3(12)=0.
+                     xff_ens3(13)= 0.
+                     xff_ens3(16)= 0.
+                     closure_n(i)=12.
+!                     xff_dicycle = 0.
+                endif  !xff0
+             endif ! ichoice
+
+             XK(1)=(XAA0(I,1)-AA1(I))/MBDT
+             forcing(i,4)=aa0(i)
+             forcing(i,5)=aa1(i)
+             forcing(i,6)=xaa0(i,1)
+             forcing(i,7)=xk(1)
+             if(xk(1).le.0.and.xk(1).gt.-.01*mbdt) &
+                           xk(1)=-.01*mbdt
+             if(xk(1).gt.0.and.xk(1).lt.1.e-2)     &
+                           xk(1)=1.e-2
+             !   enddo
+!
+!--- add up all ensembles
+!
+!
+! over water, enfor!e small cap for some of the closures
+!
+              if(xland(i).lt.0.1)then
+                 if(ierr2(i).gt.0.or.ierr3(i).gt.0)then
+                      xff_ens3(1) =ens_adj(i)*xff_ens3(1)
+                      xff_ens3(2) =ens_adj(i)*xff_ens3(2)
+                      xff_ens3(3) =ens_adj(i)*xff_ens3(3)
+                      xff_ens3(4) =ens_adj(i)*xff_ens3(4)
+                      xff_ens3(5) =ens_adj(i)*xff_ens3(5)
+                      xff_ens3(6) =ens_adj(i)*xff_ens3(6)
+                      xff_ens3(7) =ens_adj(i)*xff_ens3(7)
+                      xff_ens3(8) =ens_adj(i)*xff_ens3(8)
+                      xff_ens3(9) =ens_adj(i)*xff_ens3(9)
+                      xff_ens3(10) =ens_adj(i)*xff_ens3(10)
+                      xff_ens3(11) =ens_adj(i)*xff_ens3(11)
+                      xff_ens3(12) =ens_adj(i)*xff_ens3(12)
+                      xff_ens3(13) =ens_adj(i)*xff_ens3(13)
+                      xff_ens3(14) =ens_adj(i)*xff_ens3(14)
+                      xff_ens3(15) =ens_adj(i)*xff_ens3(15)
+                      xff_ens3(16) =ens_adj(i)*xff_ens3(16)
+                      !srf
+                       xff_dicycle = ens_adj(i)*xff_dicycle
+                      !srf end
+!                      xff_ens3(7) =0.
+!                      xff_ens3(8) =0.
+!                      xff_ens3(9) =0.
+                 endif ! ierr2
+              endif ! xland
+!
+! end water treatment
+!
+!
+
+!
+!--- special treatment for stability closures
+!
+              if(XK(1).lt.0.)then
+                 if(xff_ens3(1).gt.0)xf_ens(i,1)=max(0.,-xff_ens3(1)/xk(1))
+                 if(xff_ens3(2).gt.0)xf_ens(i,2)=max(0.,-xff_ens3(2)/xk(1))
+                 if(xff_ens3(3).gt.0)xf_ens(i,3)=max(0.,-xff_ens3(3)/xk(1))
+                 if(xff_ens3(16).gt.0)xf_ens(i,16)=max(0.,-xff_ens3(16)/xk(1))
+                 xf_ens(i,1)= xf_ens(i,1)+xf_ens(i,1)*rand_clos(i,1)
+                 xf_ens(i,2)= xf_ens(i,2)+xf_ens(i,2)*rand_clos(i,1)
+                 xf_ens(i,3)= xf_ens(i,3)+xf_ens(i,3)*rand_clos(i,1)
+                 xf_ens(i,16)=xf_ens(i,16)+xf_ens(i,16)*rand_clos(i,1)
+              else
+                 xff_ens3(1)= 0
+                 xff_ens3(2)= 0
+                 xff_ens3(3)= 0
+                 xff_ens3(16)=0
+              endif
+!
+!--- if iresult.eq.1, following independent of xff0
+!
+              xf_ens(i,4)=max(0.,xff_ens3(4))
+              xf_ens(i,5)=max(0.,xff_ens3(5))
+              xf_ens(i,6)=max(0.,xff_ens3(6))
+              xf_ens(i,14)=max(0.,xff_ens3(14))
+              a1=max(1.e-5,pr_ens(i,7))
+              xf_ens(i,7)=max(0.,xff_ens3(7)/a1)
+              a1=max(1.e-5,pr_ens(i,8))
+              xf_ens(i,8)=max(0.,xff_ens3(8)/a1)
+!              forcing(i,7)=xf_ens(i,8)
+              a1=max(1.e-5,pr_ens(i,9))
+              xf_ens(i,9)=max(0.,xff_ens3(9)/a1)
+              a1=max(1.e-3,pr_ens(i,15))
+              xf_ens(i,15)=max(0.,xff_ens3(15)/a1)
+              xf_ens(i,4)=xf_ens(i,4)+xf_ens(i,4)*rand_clos(i,2)
+              xf_ens(i,5)=xf_ens(i,5)+xf_ens(i,5)*rand_clos(i,2)
+              xf_ens(i,6)=xf_ens(i,6)+xf_ens(i,6)*rand_clos(i,2)
+              xf_ens(i,14)=xf_ens(i,14)+xf_ens(i,14)*rand_clos(i,2)
+              xf_ens(i,7)=xf_ens(i,7)+xf_ens(i,7)*rand_clos(i,3)
+              xf_ens(i,8)=xf_ens(i,8)+xf_ens(i,8)*rand_clos(i,3)
+              xf_ens(i,9)=xf_ens(i,9)+xf_ens(i,9)*rand_clos(i,3)
+              xf_ens(i,15)=xf_ens(i,15)+xf_ens(i,15)*rand_clos(i,3)
+              if(XK(1).lt.0.)then
+                 xf_ens(i,10)=max(0.,-xff_ens3(10)/xk(1))
+                 xf_ens(i,11)=max(0.,-xff_ens3(11)/xk(1))
+                 xf_ens(i,12)=max(0.,-xff_ens3(12)/xk(1))
+                 xf_ens(i,13)=max(0.,-xff_ens3(13)/xk(1))
+                 xf_ens(i,10)=xf_ens(i,10)+xf_ens(i,10)*rand_clos(i,4)
+                 xf_ens(i,11)=xf_ens(i,11)+xf_ens(i,11)*rand_clos(i,4)
+                 xf_ens(i,12)=xf_ens(i,12)+xf_ens(i,12)*rand_clos(i,4)
+                 xf_ens(i,13)=xf_ens(i,13)+xf_ens(i,13)*rand_clos(i,4)
+                 forcing(i,8)=xf_ens(i,11)
+              else
+                 xf_ens(i,10)=0.
+                 xf_ens(i,11)=0.
+                 xf_ens(i,12)=0.
+                 xf_ens(i,13)=0.
+                 forcing(i,8)=0.
+              endif
+!srf-begin
+              if(XK(1).lt.0.)then
+                 xf_dicycle(i)      =  max(0.,-xff_dicycle /xk(1))
+!                forcing(i,9)=xf_dicycle(i)
+              else
+                 xf_dicycle(i)      = 0.
+              endif
+!srf-end
+              if(ichoice.ge.1)then
+!                 closure_n(i)=0.
+                 xf_ens(i,1)=xf_ens(i,ichoice)
+                 xf_ens(i,2)=xf_ens(i,ichoice)
+                 xf_ens(i,3)=xf_ens(i,ichoice)
+                 xf_ens(i,4)=xf_ens(i,ichoice)
+                 xf_ens(i,5)=xf_ens(i,ichoice)
+                 xf_ens(i,6)=xf_ens(i,ichoice)
+                 xf_ens(i,7)=xf_ens(i,ichoice)
+                 xf_ens(i,8)=xf_ens(i,ichoice)
+                 xf_ens(i,9)=xf_ens(i,ichoice)
+                 xf_ens(i,10)=xf_ens(i,ichoice)
+                 xf_ens(i,11)=xf_ens(i,ichoice)
+                 xf_ens(i,12)=xf_ens(i,ichoice)
+                 xf_ens(i,13)=xf_ens(i,ichoice)
+                 xf_ens(i,14)=xf_ens(i,ichoice)
+                 xf_ens(i,15)=xf_ens(i,ichoice)
+                 xf_ens(i,16)=xf_ens(i,ichoice)
+              endif
+          elseif(ierr(i).ne.20.and.ierr(i).ne.0)then
+              do n=1,maxens3
+                 xf_ens(i,n)=0.
+                 xf_dicycle(i) = 0.
+             enddo
+          endif ! ierror
+ 100   continue
+
+   END SUBROUTINE cup_forcing_ens_3d
+
+   SUBROUTINE cup_kbcon(ierrc,cap_inc,iloop_in,k22,kbcon,he_cup,hes_cup, &
+              hkb,ierr,kbmax,p_cup,cap_max,                              &
+              ztexec,zqexec,                                             &
+              jprnt,itf,ktf,                                             &
+              its,ite, kts,kte,                                          &
+              z_cup,entr_rate,heo,imid                        )
+
+   IMPLICIT NONE
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        jprnt,itf,ktf,imid,                                            &
+        its,ite, kts,kte
+  ! 
+  ! 
+  ! 
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        he_cup,hes_cup,p_cup
+     real,    dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        entr_rate,ztexec,zqexec,cap_inc,cap_max
+     real,    dimension (its:ite)                                      &
+        ,intent (inout   )                   ::                        &
+        hkb !,cap_max
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbmax
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        kbcon,k22,ierr
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        iloop_in
+     character*50 :: ierrc(its:ite)
+     real, dimension (its:ite,kts:kte),intent (in) :: z_cup,heo
+     integer, dimension (its:ite)      ::     iloop,start_level
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k
+     real                                 ::                           &
+        x_add,pbcdif,plus,hetest,dz
+     real, dimension (its:ite,kts:kte) ::hcot
+!
+!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
+!
+      iloop(:)=iloop_in
+       DO 27 i=its,itf
+      kbcon(i)=1
+!
+! reset iloop for mid level convection
+      if(cap_max(i).gt.200 .and. imid.eq.1)iloop(i)=5
+!
+      IF(ierr(I).ne.0)GO TO 27
+      start_level(i)=k22(i)
+      KBCON(I)=K22(I)+1
+      if(iloop(i).eq.5)KBCON(I)=K22(I)
+!      if(iloop_in.eq.5)start_level(i)=kbcon(i)
+       !== including entrainment for hetest
+        hcot(i,1:start_level(i)) = HKB(I)
+        do k=start_level(i)+1,KBMAX(i)+3
+           dz=z_cup(i,k)-z_cup(i,k-1)
+           hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1)   &
+                         + entr_rate(i)*dz*heo(i,k-1)       )/ &
+                      (1.+0.5*entr_rate(i)*dz)
+        enddo
+       !==
+
+      GO TO 32
+ 31   CONTINUE
+      KBCON(I)=KBCON(I)+1
+      IF(KBCON(I).GT.KBMAX(i)+2)THEN
+         if(iloop(i).ne.4)then
+                ierr(i)=3
+                ierrc(i)="could not find reasonable kbcon in cup_kbcon"
+         endif
+        GO TO 27
+      ENDIF
+ 32   CONTINUE
+      hetest=hcot(i,kbcon(i)) !hkb(i) ! HE_cup(I,K22(I))
+      IF(HETEST.LT.HES_cup(I,KBCON(I)))then
+        GO TO 31
+      endif
+
+!     cloud base pressure and max moist static energy pressure
+!     i.e., the depth (in mb) of the layer of negative buoyancy
+      if(KBCON(I)-K22(I).eq.1)go to 27
+      if(iloop(i).eq.5 .and. (KBCON(I)-K22(I)).le.2)go to 27
+      PBCDIF=-P_cup(I,KBCON(I))+P_cup(I,K22(I))
+      plus=max(25.,cap_max(i)-float(iloop(i)-1)*cap_inc(i))
+      if(iloop(i).eq.4)plus=cap_max(i)
+!
+! for shallow convection, if cap_max is greater than 25, it is the pressure at pbltop
+      if(iloop(i).eq.5)plus=150.
+        if(iloop(i).eq.5.and.cap_max(i).gt.200)pbcdif=-P_cup(I,KBCON(I))+cap_max(i)
+      IF(PBCDIF.le.plus)THEN
+        Go To 27
+      ElseIF(PBCDIF.GT.plus)THEN
+        K22(I)=K22(I)+1
+        KBCON(I)=K22(I)+1
+!==     since k22 has be changed, HKB has to be re-calculated
+        x_add = xlv*zqexec(i)+cp*ztexec(i)
+        call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add)
+
+        start_level(i)=k22(i)
+!        if(iloop_in.eq.5)start_level(i)=kbcon(i)
+        hcot(i,1:start_level(i)) = hkb(I)
+        do k=start_level(i)+1,KBMAX(i)+3
+           dz=z_cup(i,k)-z_cup(i,k-1)
+
+           hcot(i,k)= ( (1.-0.5*entr_rate(i)*dz)*hcot(i,k-1)   &
+                         + entr_rate(i)*dz*heo(i,k-1)       )/ &
+                      (1.+0.5*entr_rate(i)*dz)
+        enddo
+       !==
+
+        if(iloop(i).eq.5)KBCON(I)=K22(I)
+        IF(KBCON(I).GT.KBMAX(i)+2)THEN
+            if(iloop(i).ne.4)then
+                ierr(i)=3
+                ierrc(i)="could not find reasonable kbcon in cup_kbcon"
+            endif
+            GO TO 27
+        ENDIF
+        GO TO 32
+      ENDIF
+ 27   CONTINUE
+
+   END SUBROUTINE cup_kbcon
+
+
+   SUBROUTINE cup_MAXIMI(ARRAY,KS,KE,MAXX,ierr,              &
+              itf,ktf,                                       &
+              its,ite, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+         itf,ktf,                                                      &
+         its,ite, kts,kte
+  ! array input array
+  ! x output array with return values
+  ! kt output array of levels
+  ! ks,kend  check-range
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+         array
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+         ierr,ke
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+         ks
+     integer, dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+         maxx
+     real,    dimension (its:ite)         ::                           &
+         x
+     real                                 ::                           &
+         xar
+     integer                              ::                           &
+         i,k
+
+       DO 200 i=its,itf
+       MAXX(I)=KS
+       if(ierr(i).eq.0)then
+      X(I)=ARRAY(I,KS)
+!
+       DO 100 K=KS,KE(i)
+         XAR=ARRAY(I,K)
+         IF(XAR.GE.X(I)) THEN
+            X(I)=XAR
+            MAXX(I)=K
+         ENDIF
+ 100  CONTINUE
+      endif
+ 200  CONTINUE
+
+   END SUBROUTINE cup_MAXIMI
+
+
+   SUBROUTINE cup_minimi(ARRAY,KS,KEND,KT,ierr,              &
+              itf,ktf,                                       &
+              its,ite, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                 &
+        ,intent (in   )                   ::                 &
+         itf,ktf,                                            &
+         its,ite, kts,kte
+  ! array input array
+  ! x output array with return values
+  ! kt output array of levels
+  ! ks,kend  check-range
+     real,    dimension (its:ite,kts:kte)                    &
+        ,intent (in   )                   ::                 &
+         array
+     integer, dimension (its:ite)                            &
+        ,intent (in   )                   ::                 &
+         ierr,ks,kend
+     integer, dimension (its:ite)                            &
+        ,intent (out  )                   ::                 &
+         kt
+     real,    dimension (its:ite)         ::                 &
+         x
+     integer                              ::                 &
+         i,k,kstop
+
+       DO 200 i=its,itf
+      KT(I)=KS(I)
+      if(ierr(i).eq.0)then
+      X(I)=ARRAY(I,KS(I))
+       KSTOP=MAX(KS(I)+1,KEND(I))
+!
+       DO 100 K=KS(I)+1,KSTOP
+         IF(ARRAY(I,K).LT.X(I)) THEN
+              X(I)=ARRAY(I,K)
+              KT(I)=K
+         ENDIF
+ 100  CONTINUE
+      endif
+ 200  CONTINUE
+
+   END SUBROUTINE cup_MINIMI
+
+
+   SUBROUTINE cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup,       &
+              kbcon,ktop,ierr,                               &
+              itf,ktf,                                       &
+              its,ite, kts,kte                     )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                 &
+        ,intent (in   )                   ::                 &
+        itf,ktf,                                             &
+        its,ite, kts,kte
+  ! aa0 cloud work function
+  ! gamma_cup = gamma on model cloud levels
+  ! t_cup = temperature (Kelvin) on model cloud levels
+  ! dby = buoancy term
+  ! zu= normalized updraft mass flux
+  ! z = heights of model levels 
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                     &
+        ,intent (in   )                   ::                  &
+        z,zu,gamma_cup,t_cup,dby
+     integer, dimension (its:ite)                             &
+        ,intent (in   )                   ::                  &
+        kbcon,ktop
+!
+! input and output
+!
+
+
+     integer, dimension (its:ite)                             &
+        ,intent (inout)                   ::                  &
+        ierr
+     real,    dimension (its:ite)                             &
+        ,intent (out  )                   ::                  &
+        aa0
+!
+!  local variables in this routine
+!
+
+     integer                              ::                  &
+        i,k
+     real                                 ::                  &
+        dz,da
+!
+        do i=its,itf
+         aa0(i)=0.
+        enddo
+        DO 100 k=kts+1,ktf
+        DO 100 i=its,itf
+         IF(ierr(i).ne.0)GO TO 100
+         IF(K.LT.KBCON(I))GO TO 100
+         IF(K.Gt.KTOP(I))GO TO 100
+         DZ=Z(I,K)-Z(I,K-1)
+         da=zu(i,k)*DZ*(9.81/(1004.*( &
+                (T_cup(I,K)))))*DBY(I,K-1)/ &
+             (1.+GAMMA_CUP(I,K))
+!         IF(K.eq.KTOP(I).and.da.le.0.)go to 100
+         AA0(I)=AA0(I)+max(0.,da)
+         if(aa0(i).lt.0.)aa0(i)=0.
+100     continue
+
+   END SUBROUTINE cup_up_aa0
+
+!====================================================================
+   SUBROUTINE neg_check(name,j,dt,q,outq,outt,outu,outv,                      &
+                                    outqc,pret,its,ite,kts,kte,itf,ktf)
+
+   INTEGER,      INTENT(IN   ) ::            j,its,ite,kts,kte,itf,ktf
+
+     real, dimension (its:ite,kts:kte  )                    ,                 &
+      intent(inout   ) ::                                                     &
+       outq,outt,outqc,outu,outv
+     real, dimension (its:ite,kts:kte  )                    ,                 &
+      intent(inout   ) ::                                                     &
+       q
+     real, dimension (its:ite  )                            ,                 &
+      intent(inout   ) ::                                                     &
+       pret
+      character *(*), intent (in)         ::                                  &
+       name
+     real                                                                     &
+        ,intent (in  )                   ::                                   &
+        dt
+     real :: names,scalef,thresh,qmem,qmemf,qmem2,qtest,qmem1
+     integer :: icheck
+!
+! first do check on vertical heating rate
+!
+      thresh=300.01
+!      thresh=200.01        !ss
+!      thresh=250.01
+      names=1.
+      if(name == 'shallow')then
+        thresh=148.01
+        names=2.
+      endif
+      scalef=86400.
+      do i=its,itf
+      icheck=0
+      qmemf=1.
+      qmem=0.
+      do k=kts,ktf
+         qmem=(outt(i,k))*86400.
+         if(qmem.gt.thresh)then
+           qmem2=thresh/qmem
+           qmemf=min(qmemf,qmem2)
+      icheck=1
+!
+!
+!          print *,'1',' adjusted massflux by factor ',i,j,k,qmem,qmem2,qmemf,dt
+         endif
+         if(qmem.lt.-.5*thresh*names)then
+           qmem2=-.5*names*thresh/qmem
+           qmemf=min(qmemf,qmem2)
+      icheck=2
+!
+!
+         endif
+      enddo
+      do k=kts,ktf
+         outq(i,k)=outq(i,k)*qmemf
+         outt(i,k)=outt(i,k)*qmemf
+         outu(i,k)=outu(i,k)*qmemf
+         outv(i,k)=outv(i,k)*qmemf
+         outqc(i,k)=outqc(i,k)*qmemf
+      enddo
+      pret(i)=pret(i)*qmemf 
+      enddo
+      return
+!
+! check whether routine produces negative q's. This can happen, since 
+! tendencies are calculated based on forced q's. This should have no
+! influence on conservation properties, it scales linear through all
+! tendencies
+!
+!      return
+!      write(14,*)'return'
+      thresh=1.e-16
+      do i=its,itf
+      qmemf=1.
+      do k=kts,ktf-1
+         qmem=outq(i,k)
+         if(abs(qmem).gt.0. .and. q(i,k).gt.1.e-6)then
+         qtest=q(i,k)+(outq(i,k))*dt
+         if(qtest.lt.thresh)then
+!
+! qmem2 would be the maximum allowable tendency
+!
+           qmem1=abs(outq(i,k))
+           qmem2=abs((thresh-q(i,k))/dt)
+           qmemf=min(qmemf,qmem2/qmem1)
+           qmemf=max(0.,qmemf)
+         endif
+         endif
+      enddo
+      do k=kts,ktf
+         outq(i,k)=outq(i,k)*qmemf
+         outt(i,k)=outt(i,k)*qmemf
+         outu(i,k)=outu(i,k)*qmemf
+         outv(i,k)=outv(i,k)*qmemf
+         outqc(i,k)=outqc(i,k)*qmemf
+      enddo
+      pret(i)=pret(i)*qmemf 
+      enddo
+
+   END SUBROUTINE neg_check
+
+
+   SUBROUTINE cup_output_ens_3d(xff_mid,xf_ens,ierr,dellat,dellaq,dellaqc,  &
+              outtem,outq,outqc,                                            &
+              zu,pre,pw,xmb,ktop,                                           &
+              edt,pwd,name,ierr2,ierr3,p_cup,pr_ens,                        &
+              maxens3,                                                      &
+              sig,closure_n,xland1,xmbm_in,xmbs_in,                         &
+              ichoice,imid,ipr,itf,ktf,                                     &
+              its,ite, kts,kte,                                             &
+              dicycle,xf_dicycle )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        ichoice,imid,ipr,itf,ktf,                                      &
+        its,ite, kts,kte
+     integer, intent (in   )              ::                           &
+        maxens3
+  ! xf_ens = ensemble mass fluxes
+  ! pr_ens = precipitation ensembles
+  ! dellat = change of temperature per unit mass flux of cloud ensemble
+  ! dellaq = change of q per unit mass flux of cloud ensemble
+  ! dellaqc = change of qc per unit mass flux of cloud ensemble
+  ! outtem = output temp tendency (per s)
+  ! outq   = output q tendency (per s)
+  ! outqc  = output qc tendency (per s)
+  ! pre    = output precip
+  ! xmb    = total base mass flux
+  ! xfac1  = correction factor
+  ! pw = pw -epsilon*pd (ensemble dependent)
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,1:maxens3)                            &
+        ,intent (inout)                   ::                           &
+       xf_ens,pr_ens
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout  )                 ::                           &
+        outtem,outq,outqc
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in  )                    ::                           &
+        zu,pwd,p_cup
+     real,   dimension (its:ite)                                       &
+         ,intent (in  )                   ::                           &
+        sig,xmbm_in,xmbs_in,edt
+     real,   dimension (its:ite,2)                                     &
+         ,intent (in  )                   ::                           &
+        xff_mid
+     real,    dimension (its:ite)                                      &
+        ,intent (inout  )                 ::                           &
+        pre,xmb
+     real,    dimension (its:ite)                                      &
+        ,intent (inout  )                 ::                           &
+        closure_n
+     real,    dimension (its:ite,kts:kte,1)                            &
+        ,intent (in   )                   ::                           &
+       dellat,dellaqc,dellaq,pw
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        ktop,xland1
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr,ierr2,ierr3
+     integer, intent(IN) :: DICYCLE
+     real,    intent(IN), dimension (its:ite) :: xf_dicycle
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k,n
+     real                                 ::                           &
+        clos_wei,dtt,dp,dtq,dtqc,dtpw,dtpwd
+     real,    dimension (its:ite)         ::                           &
+       xmb_ave,pwtot
+!
+      character *(*), intent (in)         ::                           &
+       name
+
+!
+      DO k=kts,kte
+      do i=its,ite
+        outtem (i,k)=0.
+        outq   (i,k)=0.
+        outqc  (i,k)=0.
+      enddo
+      enddo
+      do i=its,itf
+        pre(i)=0.
+        xmb(i)=0.
+      enddo
+      do i=its,itf
+        IF(ierr(i).eq.0)then
+        do n=1,maxens3
+           if(pr_ens(i,n).le.0.)then
+             xf_ens(i,n)=0.
+           endif
+        enddo
+        endif
+      enddo
+!
+!--- calculate ensemble average mass fluxes
+!
+       
+!
+!-- now do feedback
+!
+!!!!! DEEP Convection !!!!!!!!!!
+      if(imid.eq.0)then
+      do i=its,itf
+        if(ierr(i).eq.0)then
+         k=0
+         xmb_ave(i)=0.
+         do n=1,maxens3
+          k=k+1
+          xmb_ave(i)=xmb_ave(i)+xf_ens(i,n)
+         enddo
+         xmb_ave(i)=xmb_ave(i)/float(k)
+         !srf begin
+         if(dicycle == 2 )then
+            xmb_ave(i)=xmb_ave(i)-max(0.,xmbm_in(i),xmbs_in(i))
+            xmb_ave(i)=max(0.,xmb_ave(i))
+         else if (dicycle == 1) then
+            xmb_ave(i)=min(xmb_ave(i),xmb_ave(i) - xf_dicycle(i))
+            xmb_ave(i)=max(0.,xmb_ave(i))
+         endif
+! --- Now use proper count of how many closures were actually
+!       used in cup_forcing_ens (including screening of some
+!       closures over water) to properly normalize xmb
+           clos_wei=16./max(1.,closure_n(i))
+         xmb_ave(i)=min(xmb_ave(i),100.)
+         xmb(i)=clos_wei*sig(i)*xmb_ave(i)
+
+           if(xmb(i) < 1.e-16)then
+              ierr(i)=19
+           endif
+!           xfac1(i)=xmb(i)
+!           xfac2(i)=xmb(i)
+
+        endif
+      ENDDO
+!!!!! NOT SO DEEP Convection !!!!!!!!!!
+      else  ! imid == 1
+         do i=its,itf
+         xmb_ave(i)=0.
+         IF(ierr(i).eq.0)then
+! ! first get xmb_ves, depend on ichoicee
+!
+           if(ichoice.eq.1 .or. ichoice.eq.2)then
+              xmb_ave(i)=sig(i)*xff_mid(i,ichoice)
+           else if(ichoice.gt.2)then
+              k=0
+              do n=1,maxens3
+                    k=k+1
+                    xmb_ave(i)=xmb_ave(i)+xf_ens(i,n)
+              enddo
+              xmb_ave(i)=xmb_ave(i)/float(k)
+           else if(ichoice == 0)then
+              xmb_ave(i)=.5*sig(i)*(xff_mid(i,1)+xff_mid(i,2))
+           endif   ! ichoice gt.2
+! which dicycle method
+           if(dicycle == 2 )then
+              xmb(i)=max(0.,xmb_ave(i)-xmbs_in(i))
+           else if (dicycle == 1) then
+              xmb(i)=min(xmb_ave(i),xmb_ave(i) - xf_dicycle(i))
+              xmb(i)=max(0.,xmb_ave(i))
+           else if (dicycle == 0) then
+              xmb(i)=max(0.,xmb_ave(i))
+           endif   ! dicycle=1,2
+         endif     ! ierr >0
+         enddo     ! i
+      endif        ! imid=1
+
+      do i=its,itf
+        pwtot(i)=0.
+        IF(ierr(i).eq.0)then
+            DO k=kts,ktop(i)
+              pwtot(i)=pwtot(i)+pw(i,k,1)
+            enddo
+            DO k=kts,ktop(i)
+            dp=100.*(p_cup(i,k)-p_cup(i,k+1))/g
+            dtt =dellat  (i,k,1)
+            dtq =dellaq  (i,k,1)
+! necessary to drive downdraft
+            dtpwd=-pwd(i,k)*edt(i)
+! take from dellaqc first
+            dtqc=dellaqc (i,k,1)*dp - dtpwd
+! if this is negative, it needs to come from rain
+           if(dtqc < 0.)then
+             dtpwd=dtpwd-dellaqc(i,k,1)*dp
+             dtqc=0.
+! if this is positive, can come from clw detrainment
+           else
+             dtpwd=0.
+             dtqc=dtqc/dp
+           endif
+           OUTTEM(I,K)= XMB(I)* dtt
+           OUTQ  (I,K)= XMB(I)* dtq
+           OUTQC (I,K)= XMB(I)* dtqc
+           xf_ens(i,:)=sig(i)*xf_ens(i,:)
+! what is evaporated
+           PRE(I)=PRE(I)-XMB(I)*dtpwd
+          enddo
+          PRE(I)=-PRE(I)+XMB(I)*pwtot(i)
+        endif
+      enddo
+
+
+   END SUBROUTINE cup_output_ens_3d
+!-------------------------------------------------------
+   SUBROUTINE cup_up_moisture(name,ierr,z_cup,qc,qrc,pw,pwav,     &
+              p_cup,kbcon,ktop,dby,clw_all,xland1,                &
+              q,GAMMA_cup,zu,qes_cup,k22,qe_cup,                  &
+              ZQEXEC,ccn,rho,c1d,t,                               &
+              up_massentr,up_massdetr,psum,psumh,                 &
+              itest,itf,ktf,                                      &
+              its,ite, kts,kte                     )
+
+   IMPLICIT NONE
+  real, parameter :: BDISPM = 0.366       !Berry--size dispersion (martime)
+  REAL, PARAMETER :: BDISPC = 0.146       !Berry--size dispersion (continental)
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                      &
+        ,intent (in   )                   ::                      &
+                                  itest,itf,ktf,                  &
+                                  its,ite, kts,kte
+  ! cd= detrainment function 
+  ! q = environmental q on model levels
+  ! qe_cup = environmental q on model cloud levels
+  ! qes_cup = saturation q on model cloud levels
+  ! dby = buoancy term
+  ! cd= detrainment function 
+  ! zu = normalized updraft mass flux
+  ! gamma_cup = gamma on model cloud levels
+  !
+     real,    dimension (its:ite,kts:kte)                         &
+        ,intent (in   )                   ::                      &
+        p_cup,rho,q,zu,gamma_cup,qe_cup,                          &
+        up_massentr,up_massdetr,dby,qes_cup,z_cup
+     real,    dimension (its:ite)                                 &
+        ,intent (in   )                   ::                      &
+        zqexec
+  ! entr= entrainment rate 
+     integer, dimension (its:ite)                                 &
+        ,intent (in   )                   ::                      &
+        kbcon,ktop,k22,xland1
+!
+! input and output
+!
+
+   ! ierr error value, maybe modified in this routine
+
+     integer, dimension (its:ite)                                  &
+        ,intent (inout)                   ::                       &
+        ierr
+      character *(*), intent (in)         ::                       &
+       name
+   ! qc = cloud q (including liquid water) after entrainment
+   ! qrch = saturation q in cloud
+   ! qrc = liquid water content in cloud after rainout
+   ! pw = condensate that will fall out at that level
+   ! pwav = totan normalized integrated condensate (I1)
+   ! c0 = conversion rate (cloud to rain)
+
+     real,    dimension (its:ite,kts:kte)                          &
+        ,intent (out  )                   ::                       &
+        qc,qrc,pw,clw_all
+     real,    dimension (its:ite,kts:kte) ::                       &
+        qch,qrcb,pwh,clw_allh,c1d,t
+     real,    dimension (its:ite)         ::                       &
+        pwavh
+     real,    dimension (its:ite)                                  &
+        ,intent (out  )                   ::                       &
+        pwav,psum,psumh
+     real,    dimension (its:ite)                                  &
+        ,intent (in  )                    ::                       &
+        ccn
+!
+!  local variables in this routine
+!
+
+     integer                              ::                       &
+        iprop,iall,i,k
+     integer :: start_level(its:ite)
+     real                                 ::                       &
+        prop_ave,qrcb_h,bdsp,dp,rhoc,qrch,qaver,                   &
+        c0,dz,berryc0,q1,berryc
+     real                                 ::                       &
+        denom
+     real,    dimension (kts:kte)         ::                       &
+        prop_b
+!
+        prop_b(kts:kte)=0
+        iall=0
+        c0=.002
+        bdsp=BDISPM
+!
+!--- no precip for small clouds
+!
+!        if(name.eq.'shallow')then
+!            c0=0.002
+!        endif
+        do i=its,itf
+          pwav(i)=0.
+          pwavh(i)=0.
+          psum(i)=0.
+          psumh(i)=0.
+        enddo
+        do k=kts,ktf
+        do i=its,itf
+          pw(i,k)=0.
+          pwh(i,k)=0.
+          qc(i,k)=0.
+          if(ierr(i).eq.0)qc(i,k)=qe_cup(i,k)
+          if(ierr(i).eq.0)qch(i,k)=qe_cup(i,k)
+          clw_all(i,k)=0.
+          clw_allh(i,k)=0.
+          qrc(i,k)=0.
+          qrcb(i,k)=0.
+        enddo
+        enddo
+      do i=its,itf
+      if(ierr(i).eq.0)then
+         start_level=k22(i)
+         call get_cloud_bc(kte,qe_cup (i,1:kte),qaver,k22(i))
+         qaver = qaver 
+         k=start_level(i)
+         qc (i,k)= qaver 
+         qch (i,k)= qaver
+         do k=1,start_level(i)-1
+           qc (i,k)= qe_cup(i,k)
+           qch (i,k)= qe_cup(i,k)
+         enddo
+!
+!  initialize below originating air
+!
+      endif
+      enddo
+
+       DO 100 i=its,itf
+        c0=.004
+         IF(ierr(i).eq.0)then
+
+! below LFC, but maybe above LCL
+!
+!            if(name == "deep" )then
+            DO k=k22(i)+1,kbcon(i)
+              qc(i,k)=   (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ &
+                         up_massentr(i,k-1)*q(i,k-1))   /                       &
+                         (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
+!              QRCH=QES_cup(I,K)
+               QRCH=QES_cup(I,K)+(1./XLV)*(GAMMA_cup(i,k)                       &
+                 /(1.+GAMMA_cup(i,k)))*DBY(I,K)
+              if(k.lt.kbcon(i))qrch=qc(i,k)
+              if(qc(i,k).gt.qrch)then
+                DZ=Z_cup(i,K)-Z_cup(i,K-1)
+                QRC(I,K)=(QC(I,K)-QRCH)/(1.+c0*DZ)
+                PW(i,k)=c0*dz*QRC(I,K)*zu(i,k)
+                qc(i,k)=qrch+qrc(i,k)
+                clw_all(i,k)=qrc(i,k)
+              endif
+            enddo
+ !           endif
+!
+!now do the rest
+!
+            DO k=kbcon(i)+1,ktop(i)
+               c0=.004
+               if(t(i,k).lt.270.)c0=.002
+               denom=zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1)
+               if(denom.lt.1.e-8)then
+                     ierr(i)=51
+                exit
+               endif
+
+   
+               rhoc=.5*(rho(i,k)+rho(i,k-1))
+               DZ=Z_cup(i,K)-Z_cup(i,K-1)
+               DP=p_cup(i,K)-p_cup(i,K-1)
+!
+!--- saturation  in cloud, this is what is allowed to be in it
+!
+               QRCH=QES_cup(I,K)+(1./XLV)*(GAMMA_cup(i,k)                       &
+                 /(1.+GAMMA_cup(i,k)))*DBY(I,K)
+!
+!------    1. steady state plume equation, for what could
+!------       be in cloud without condensation
+!
+!
+               qc(i,k)=   (qc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)* qc(i,k-1)+ &
+                         up_massentr(i,k-1)*q(i,k-1))   /                        &
+                         (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
+               qch(i,k)= (qch(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*qch(i,k-1)+ &
+                         up_massentr(i,k-1)*q(i,k-1))   /                        &
+                         (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
+
+               if(qc(i,k).le.qrch)then
+                 qc(i,k)=qrch
+               endif
+               if(qch(i,k).le.qrch)then
+                 qch(i,k)=qrch
+               endif
+!
+!------- Total condensed water before rainout
+!
+               clw_all(i,k)=max(0.,QC(I,K)-QRCH)
+               QRC(I,K)=max(0.,(QC(I,K)-QRCH)) ! /(1.+C0*DZ*zu(i,k))
+               clw_allh(i,k)=max(0.,QCH(I,K)-QRCH)
+               QRCB(I,K)=max(0.,(QCH(I,K)-QRCH)) ! /(1.+C0*DZ*zu(i,k))
+               IF(autoconv.eq.2) then
+
+
+! 
+! normalized berry
+!
+! first calculate for average conditions, used in cup_dd_edt!
+! this will also determine proportionality constant prop_b, which, if applied,
+! would give the same results as c0 under these conditions
+!
+                 q1=1.e3*rhoc*qrcb(i,k)  ! g/m^3 ! g[h2o]/cm^3
+                 berryc0=q1*q1/(60.0*(5.0 + 0.0366*CCNclean/                           &
+                    ( q1 * BDSP)  ) ) !/(
+                 qrcb_h=((QCH(I,K)-QRCH)*zu(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ &
+                   (zu(i,k)+.5*up_massdetr(i,k-1)+c0*dz*zu(i,k))
+                 prop_b(k)=c0*qrcb_h*zu(i,k)/(1.e-3*berryc0)
+                 pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k) ! 2.
+                 berryc=qrcb(i,k)
+                 qrcb(i,k)=((QCh(I,K)-QRCH)*zu(i,k)-pwh(i,k)-qrcb(i,k-1)*(.5*up_massdetr(i,k-1)))/ &
+                       (zu(i,k)+.5*up_massdetr(i,k-1))
+                 if(qrcb(i,k).lt.0.)then
+                   berryc0=(qrcb(i,k-1)*(.5*up_massdetr(i,k-1))-(QCh(I,K)-QRCH)*zu(i,k))/zu(i,k)*1.e-3*dz*prop_b(k)
+                   pwh(i,k)=zu(i,k)*1.e-3*berryc0*dz*prop_b(k)
+                   qrcb(i,k)=0.
+                 endif
+                 QCh(I,K)=QRCb(I,K)+qrch
+                 PWAVH(I)=PWAVH(I)+pwh(I,K)
+                 Psumh(I)=Psumh(I)+clw_allh(I,K)*zu(i,k) *dz
+        !
+! then the real berry
+!
+                 q1=1.e3*rhoc*qrc(i,k)  ! g/m^3 ! g[h2o]/cm^3
+                 berryc0=q1*q1/(60.0*(5.0 + 0.0366*CCN(i)/                                             &
+                    ( q1 * BDSP)  ) ) !/(
+                 berryc0=1.e-3*berryc0*dz*prop_b(k) ! 2.
+                 berryc=qrc(i,k)
+                 qrc(i,k)=((QC(I,K)-QRCH)*zu(i,k)-zu(i,k)*berryc0-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/ &
+                       (zu(i,k)+.5*up_massdetr(i,k-1))
+                 if(qrc(i,k).lt.0.)then
+                    berryc0=((QC(I,K)-QRCH)*zu(i,k)-qrc(i,k-1)*(.5*up_massdetr(i,k-1)))/zu(i,k)
+                    qrc(i,k)=0.
+                 endif
+                 pw(i,k)=berryc0*zu(i,k)
+                 QC(I,K)=QRC(I,K)+qrch
+!
+!  if not running with berry at all, do the following
+!
+               ELSE       !c0=.002
+                 if(iall.eq.1)then
+                   qrc(i,k)=0.
+                   pw(i,k)=(QC(I,K)-QRCH)*zu(i,k)
+                   if(pw(i,k).lt.0.)pw(i,k)=0.
+                 else
+                   QRC(I,K)=(QC(I,K)-QRCH)/(1.+(c1d(i,k)+C0)*DZ)
+                   PW(i,k)=c0*dz*QRC(I,K)*zu(i,k)
+                   if(qrc(i,k).lt.0)then
+                     qrc(i,k)=0.
+                     pw(i,k)=0.
+                   endif
+                 endif
+                 QC(I,K)=QRC(I,K)+qrch
+               endif !autoconv
+               PWAV(I)=PWAV(I)+PW(I,K)
+               Psum(I)=Psum(I)+clw_all(I,K)*zu(i,k) *dz
+            enddo ! k=kbcon,ktop
+! do not include liquid/ice in qc
+       do k=k22(i)+1,ktop(i)
+           qc(i,k)=qc(i,k)-qrc(i,k)
+       enddo
+      endif ! ierr
+!
+!--- integrated normalized ondensate
+!
+ 100     CONTINUE
+       prop_ave=0.
+       iprop=0
+       do k=kts,kte
+        prop_ave=prop_ave+prop_b(k)
+        if(prop_b(k).gt.0)iprop=iprop+1
+       enddo
+       iprop=max(iprop,1)
+
+ END SUBROUTINE cup_up_moisture
+
+!--------------------------------------------------------------------
+
+ REAL FUNCTION satvap(temp2)
+      implicit none
+      real :: temp2, temp, toot, toto, eilog, tsot,            &
+     &        ewlog, ewlog2, ewlog3, ewlog4
+      temp = temp2-273.155
+      if (temp.lt.-20.) then   !!!! ice saturation
+        toot = 273.16 / temp2
+        toto = 1 / toot
+        eilog = -9.09718 * (toot - 1) - 3.56654 * (log(toot) / &
+     &    log(10.)) + .876793 * (1 - toto) + (log(6.1071) / log(10.))
+        satvap = 10 ** eilog
+      else
+        tsot = 373.16 / temp2
+        ewlog = -7.90298 * (tsot - 1) + 5.02808 *              &
+     &             (log(tsot) / log(10.))
+        ewlog2 = ewlog - 1.3816e-07 *                          &
+     &             (10 ** (11.344 * (1 - (1 / tsot))) - 1)
+        ewlog3 = ewlog2 + .0081328 *                           &
+     &             (10 ** (-3.49149 * (tsot - 1)) - 1)
+        ewlog4 = ewlog3 + (log(1013.246) / log(10.))
+        satvap = 10 ** ewlog4
+      end if
+ END FUNCTION
+!--------------------------------------------------------------------
+ SUBROUTINE get_cloud_bc(mzp,array,x_aver,k22,add)
+    implicit none
+    integer, intent(in)     :: mzp,k22
+    real   , intent(in)     :: array(mzp)
+    real   , optional , intent(in)  :: add
+    real   , intent(out)    :: x_aver
+    integer :: i,local_order_aver,order_aver
+
+    !-- dimension of the average
+    !-- a) to pick the value at k22 level, instead of a average between
+    !--    k22-order_aver, ..., k22-1, k22 set order_aver=1)
+    !-- b) to average between 1 and k22 => set order_aver = k22
+    order_aver = 3 !=> average between k22, k22-1 and k22-2
+
+    local_order_aver=min(k22,order_aver)
+
+    x_aver=0.
+    do i = 1,local_order_aver
+      x_aver = x_aver + array(k22-i+1)
+    enddo
+      x_aver = x_aver/float(local_order_aver)
+    if(present(add)) x_aver = x_aver + add
+
+ end SUBROUTINE get_cloud_bc
+ !========================================================================================
+
+
+ SUBROUTINE rates_up_pdf(rand_vmas,ipr,name,ktop,ierr,p_cup,entr_rate_2d,hkbo,heo,heso_cup,z_cup, &
+               xland,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopdby,csum,pmin_lev)
+     implicit none
+     character *(*), intent (in)       :: name
+     integer, intent(in) :: ipr,its,ite,itf,kts,kte,ktf
+     real, dimension (its:ite,kts:kte),intent (inout) :: entr_rate_2d,zuo
+     real, dimension (its:ite,kts:kte),intent (in) ::p_cup, heo,heso_cup,z_cup
+     real, dimension (its:ite),intent (in) :: hkbo,rand_vmas
+     integer, dimension (its:ite),intent (in) :: kstabi,k22,kpbl,csum,xland,pmin_lev
+     integer, dimension (its:ite),intent (inout) :: kbcon,ierr,ktop,ktopdby
+     !-local vars
+     real, dimension (its:ite,kts:kte) :: hcot
+     real :: beta_u,dz,dbythresh,dzh2,zustart,zubeg,massent,massdetr
+     real :: dby(kts:kte),dbm(kts:kte),zux(kts:kte)
+     real zuh2(40),zh2(40)
+     integer :: kklev,i,kk,kbegin,k,kfinalzu
+     integer, dimension (its:ite) :: start_level 
+     !
+     zustart=.1
+     dbythresh= 1. !.0.95 ! 0.85, 0.6
+     if(name == 'shallow' .or. name == 'mid') dbythresh=1.
+     dby(:)=0.
+
+     DO i=its,itf
+      zux(:)=0.
+      beta_u=max(.1,.2-float(csum(i))*.01)
+      zuo(i,:)=0.
+      dby(:)=0.
+      dbm(:)=0.
+      kbcon(i)=max(kbcon(i),2)
+      if(ierr(i).eq.0)then
+       start_level(i)=k22(i)
+       zuo(i,start_level(i))=zustart
+        zux(start_level(i))=zustart
+        do k=start_level(i)+1,kbcon(i)
+          dz=z_cup(i,k)-z_cup(i,k-1)
+          massent=dz*entr_rate_2d(i,k-1)*zuo(i,k-1)
+          massdetr=dz*1.e-9*zuo(i,k-1)
+          zuo(i,k)=zuo(i,k-1)+massent-massdetr
+          zux(k)=zuo(i,k)
+        enddo
+       zubeg=zustart !zuo(i,kbcon(i))
+       if(name .eq. 'deep')then
+        ktop(i)=0
+        hcot(i,start_level(i))=hkbo(i)
+        dz=z_cup(i,start_level(i))-z_cup(i,start_level(i)-1)
+        do k=start_level(i)+1,ktf-2
+           dz=z_cup(i,k)-z_cup(i,k-1)
+
+           hcot(i,k)=( (1.-0.5*entr_rate_2d(i,k-1)*dz)*hcot(i,k-1) &
+                      + entr_rate_2d(i,k-1)*dz*heo(i,k-1))/        &
+                      (1.+0.5*entr_rate_2d(i,k-1)*dz)
+           if(k >= kbcon(i)) dby(k)=dby(k-1)+(hcot(i,k)-heso_cup(i,k))*dz
+           if(k >= kbcon(i)) dbm(k)=hcot(i,k)-heso_cup(i,k)
+        enddo
+        ktopdby(i)=maxloc(dby(:),1)
+        kklev=maxloc(dbm(:),1)
+        do k=maxloc(dby(:),1)+1,ktf-2
+          if(dby(k).lt.dbythresh*maxval(dby))then
+              kfinalzu=k  - 1
+              ktop(i)=kfinalzu
+              go to 412
+          endif
+        enddo
+        kfinalzu=ktf-2
+        ktop(i)=kfinalzu
+412     continue
+!
+! at least overshoot by one level
+!
+!        kfinalzu=min(max(kfinalzu,ktopdby(i)+1),ktopdby(i)+2)
+!        ktop(i)=kfinalzu
+        if(kfinalzu.le.kbcon(i)+2)then
+              ierr(i)=41
+              ktop(i)= 0
+        else
+!           call get_zu_zd_pdf_fim(ipr,xland(i),zuh2,"UP",ierr(i),start_level(i),             &
+!           call get_zu_zd_pdf_fim(rand_vmas(i),zubeg,ipr,xland(i),zuh2,"UP",ierr(i),kbcon(i), &
+!            kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kpbl(i),csum(i),pmin_lev(i))
+           call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"UP",ierr(i),k22(i), &
+            kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kstabi(i),csum(i),pmin_lev(i))
+        endif
+      endif ! end deep
+      if ( name == 'mid' ) then
+       if(ktop(i) <= kbcon(i)+2)then
+              ierr(i)=41
+              ktop(i)= 0
+       else
+           kfinalzu=ktop(i)
+           ktopdby(i)=ktop(i)+1
+          call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"MID",ierr(i),k22(i),kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kbcon(i),csum(i),pmin_lev(i))
+!           kbegin=0
+!           dzh2=(z_cup(i,ktop(i))-z_cup(i,k22(i)))/40.
+!           zh2(1)=z_cup(i,k22(i))
+!           if(zuh2(1).gt.0.1 .and. kbegin.eq.0)kbegin=1
+!           do k=2,40
+!             zh2(k)=zh2(k-1)+dzh2
+!             if(zuh2(k).gt.0.1 .and. kbegin.eq.0)kbegin=k
+!           enddo
+!           zuo(i,k22(i))=zuh2(kbegin)
+!           do k=k22(i)+1,kfinalzu+1
+!             do kk=kbegin,39
+!             if(z_cup(i,k).gt.zh2(kk) .and.  z_cup(i,k).le.zh2(kk+1)) then
+!                 zuo(i,k)=zuh2(kk)
+!                 exit
+!              endif
+!             enddo
+!           enddo
+!           if(zuo(i,ktop(i)).lt.1.e-4)ktop(i)=ktop(i)-1
+       endif
+      endif ! mid
+      if ( name == 'shallow' ) then
+       if(ktop(i) <= kbcon(i)+2)then
+           ierr(i)=41
+           ktop(i)= 0
+       else
+           kfinalzu=ktop(i)
+           ktopdby(i)=ktop(i)
+           call get_zu_zd_pdf_fim(kklev,p_cup(i,:),rand_vmas(i),zubeg,ipr,xland(i),zuh2,"SH2",ierr(i),k22(i), &
+             kfinalzu,zuo(i,kts:kte),kts,kte,ktf,beta_u,kpbl(i),csum(i),pmin_lev(i))
+
+         endif
+         endif ! shal
+      ENDIF ! ierr
+     ENDDO
+
+  END SUBROUTINE rates_up_pdf
+!-------------------------------------------------------------------------
+ SUBROUTINE get_zu_zd_pdf_fim(kklev,p,rand_vmas,zubeg,ipr,xland,zuh2,draft,ierr,kb,kt,zu,kts,kte,ktf,max_mass,kpbli,csum,pmin_lev)
+
+ implicit none
+ integer, intent(in) ::ipr,xland,kb,kklev,kt,kts,kte,ktf,kpbli,csum,pmin_lev
+ real, intent(in) ::max_mass,zubeg
+ real, intent(inout) :: zu(kts:kte)
+ real, intent(in) :: p(kts:kte)
+ real  :: zuh(kts:kte),zuh2(1:40)
+ integer, intent(inout) :: ierr
+ character*(*), intent(in) ::draft
+
+ !- local var
+ integer :: kk,k,kb_adj,kpbli_adj
+ real    :: krmax,beta, alpha,kratio,tunning,FZU,rand_vmas,lev_start
+ !- kb cannot be at 1st level
+
+ !-- fill zu with zeros
+ zu=0.0
+ zuh=0.0
+   kb_adj=max(kb,2)
+ IF(draft == "UP") then
+   lev_start=min(.9,.4+csum*.013)
+   kb_adj=max(kb,2)
+   tunning=p(kt)+(p(kpbli)-p(kt))*lev_start
+   tunning =min(0.9, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6
+   tunning =max(0.2, tunning)
+   beta    = 1.3 !2.5 ! max(2.5,2./tunning)
+   alpha= (tunning*(beta -2.)+1.)/(1.-tunning)
+#if ( ! defined NO_GAMMA_SUPPORT )
+   fzu = gamma(alpha + beta)/(gamma(alpha)*gamma(beta))
+#else
+   call wrf_error_fatal ('compiler does not support 2008 gamma intrinsic')
+#endif
+  do k=kb_adj,min(kte,kt)
+      kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1)
+      zu(k) = zubeg+FZU*kratio**(alpha-1.0) * (1.0-kratio)**(beta-1.0)
+   enddo
+
+   if(maxval(zu(kts:min(ktf,kt+1))).gt.0.)  &
+      zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1)))
+     do k=maxloc(zu(:),1),1,-1
+       if(zu(k).lt.1.e-6)then
+         kb_adj=k+1
+         exit
+       endif
+     enddo
+     kb_adj=max(2,kb_adj)
+     do k=kts,kb_adj-1
+       zu(k)=0.
+     enddo
+
+ ELSEIF(draft == "SH2") then
+   tunning =min(0.8, (p(kpbli)-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6
+   tunning =max(0.2, tunning)
+   beta    = 2.5 !2.5 ! max(2.5,2./tunning)
+   alpha= (tunning*(beta -2.)+1.)/(1.-tunning)
+#if ( ! defined NO_GAMMA_SUPPORT )
+   fzu = gamma(alpha + beta)/(gamma(alpha)*gamma(beta))
+#endif
+  do k=kb_adj,min(kte,kt)
+      kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1)
+      zu(k) = zubeg+FZU*kratio**(alpha-1.0) * (1.0-kratio)**(beta-1.0)
+   enddo
+   if(maxval(zu(kts:min(ktf,kt+1))).gt.0.)  &
+      zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1)))
+     do k=maxloc(zu(:),1),1,-1
+       if(zu(k).lt.1.e-6)then
+         kb_adj=k+1
+         exit
+       endif
+     enddo
+
+ ELSEIF(draft == "SH3") then
+  tunning = 0.6
+  beta    =2.2/tunning
+  alpha   = tunning*beta
+   beta    = 3.5 ! max(2.5,2./tunning)
+   alpha   = beta -2. ! +1 !max(1.1,tunning*beta-abs(1.5-tunning)*5.)
+  fzu=1.
+  do k=1,40
+      kratio= float(k)/float(40)
+      zuh2(k) = zubeg+FZU*kratio**(alpha-1.0) * (1.0-kratio)**(beta-1.0)
+   enddo
+   if(maxval(zuh2(1:40)).gt.0.)  &
+      zuh2(:)= zuh2(:)/ maxval(zuh2(1:40))
+ ELSEIF(draft == "MID") then
+   kb_adj=max(kb,2)
+   tunning=p(kt)+(p(kb_adj)-p(kt))*.9 !*.33
+   tunning =min(0.9, (tunning-p(kb_adj))/(p(kt)-p(kb_adj))) !=.6
+   tunning =max(0.2, tunning)
+   beta    = 1.3 !2.5 ! max(2.5,2./tunning)
+   alpha= (tunning*(beta -2.)+1.)/(1.-tunning)
+#if ( ! defined NO_GAMMA_SUPPORT )
+   fzu = gamma(alpha + beta)/(gamma(alpha)*gamma(beta))
+#endif
+  do k=kb_adj,min(kte,kt)
+      kratio= (p(k)-p(kb_adj))/(p(kt)-p(kb_adj)) !float(k)/float(kt+1)
+      zu(k) = zubeg+FZU*kratio**(alpha-1.0) * (1.0-kratio)**(beta-1.0)
+   enddo
+   if(maxval(zu(kts:min(ktf,kt+1))).gt.0.)  &
+      zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/maxval(zu(kts:min(ktf,kt+1)))
+     do k=maxloc(zu(:),1),1,-1
+       if(zu(k).lt.1.e-6)then
+         kb_adj=k+1
+         exit
+       endif
+     enddo
+     kb_adj=max(2,kb_adj)
+     do k=kts,kb_adj-1
+       zu(k)=0.
+     enddo
+
+ ELSEIF(draft == "DOWN" .or. draft == "DOWNM") then
+
+  ! tunning = 0.8
+  ! beta    = 3.0/tunning
+!  tunning = 0.8
+!  beta    =2.0/tunning
+!  alpha   = tunning*beta
+!  fzu=1.
+!  zuh(:)=0.
+   tunning=p(kb)
+   tunning =min(0.9, (tunning-p(1))/(p(kt)-p(1))) !=.6
+   tunning =max(0.2, tunning)
+   beta    = 4. !2.5 ! max(2.5,2./tunning)
+   alpha= (tunning*(beta -2.)+1.)/(1.-tunning)
+#if ( ! defined NO_GAMMA_SUPPORT )
+   fzu = gamma(alpha + beta)/(gamma(alpha)*gamma(beta))
+#endif
+  zu(:)=0.
+  do k=2,min(kt,ktf)
+      kratio= (p(k)-p(1))/(p(kt)-p(1))
+      zu(k) = FZU*kratio**(alpha-1.0) * (1.0-kratio)**(beta-1.0)
+   enddo
+!   if(maxloc(zuh(:),1).ge.kpbli)then
+!      do k=maxloc(zuh(:),1),1,-1
+!         kk=kpbli+k-maxloc(zuh(:),1)
+!         if(kk.gt.1)zu(kk)=zuh(k)
+!      enddo
+!      do k=maxloc(zuh(:),1)+1,kt
+!         kk=kpbli+k-maxloc(zuh(:),1)
+!         if(kk.le.kt)zu(kk)=zuh(k)
+!      enddo
+!   else
+!      do k=2,kt ! maxloc(zuh(:),1)
+!        zu(k)=zuh(k-1)
+!      enddo
+!   endif
+    fzu=maxval(zu(kts:min(ktf,kt+1)))
+   if(fzu.gt.0.)  &
+      zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/fzu
+!    if(zu(2).gt.max_mass)fzu=max_mass/zu(2) ! max(0.,zu(2)-max_mass)
+!     do k=2,kt+1
+!       zu(k)=fzu*zu(k)
+!     enddo
+     zu(1)=0.
+
+
+  ENDIF
+  !- normalize ZU
+  !  if(maxval(zu(kts:min(ktf,kt+1))).gt.0.)  &
+  !     zu(kts:min(ktf,kt+1))= zu(kts:min(ktf,kt+1))/ maxval(zu(kts:min(ktf,kt+1)))
+  END SUBROUTINE get_zu_zd_pdf_fim
+
+!-------------------------------------------------------------------------
+  SUBROUTINE cup_up_aa1bl(aa0,t,tn,q,qo,dtime,  &
+              z,zu,dby,gamma_cup,t_cup,         &
+              kbcon,ktop,ierr,                  &
+              itf,ktf,                          &
+              its,ite, kts,kte         )
+
+   IMPLICIT NONE
+!
+!  on input
+!
+
+   ! only local wrf dimensions are need as of now in this routine
+
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,ktf,                                                       &
+        its,ite, kts,kte
+  ! aa0 cloud work function
+  ! gamma_cup = gamma on model cloud levels
+  ! t_cup = temperature (Kelvin) on model cloud levels
+  ! dby = buoancy term
+  ! zu= normalized updraft mass flux
+  ! z = heights of model levels 
+  ! ierr error value, maybe modified in this routine
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        z,zu,gamma_cup,t_cup,dby,t,tn,q,qo
+     integer, dimension (its:ite)                                      &
+        ,intent (in   )                   ::                           &
+        kbcon,ktop
+     real, intent(in) :: dtime
+!
+! input and output
+!
+
+
+     integer, dimension (its:ite)                                      &
+        ,intent (inout)                   ::                           &
+        ierr
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        aa0
+!
+!  local variables in this routine
+!
+
+     integer                              ::                           &
+        i,k
+     real                                 ::                           &
+        dz,dA
+!
+        DO i=its,itf
+         AA0(I)=0.
+        ENDDO
+        DO 100 k=kts+1,ktf
+        DO 100 i=its,itf
+         IF(ierr(i).ne.0 )GO TO 100
+         IF(k.gt.KBCON(i))GO TO 100
+
+         DZ=Z(I,K)-Z(I,K-1)
+         !print*,"dz=",i,k,z(i,k),Z(I,K-1),dz         
+         !da=zu(i,k)*DZ*(9.81/(1004.*( &
+         !        (T_cup(I,K)))))*DBY(I,K-1)/ &
+         !     (1.+GAMMA_CUP(I,K))
+         ! IF(K.eq.KTOP(I).and.da.le.0.)go to 100
+
+         dA=  DZ*9.81*( tn(i,k)-t(i,k) + 0.608*(qo(i,k)-q(i,k)))/dtime
+         AA0(I)=AA0(I)+dA
+100     CONTINUE
+
+ END SUBROUTINE cup_up_aa1bl
+!---------------------------------------------------------------------- 
+ SUBROUTINE get_inversion_layers(ierr,p_cup,t_cup,z_cup,qo_cup,qeso_cup,k_inv_layers,&           
+                     kstart,kend,dtempdz,itf,ktf,its,ite, kts,kte)
+                                    
+        IMPLICIT NONE
+        integer                      ,intent (in ) :: itf,ktf,its,ite,kts,kte
+        integer, dimension (its:ite) ,intent (in ) :: ierr,kstart,kend
+        integer, dimension (its:ite) :: kend_p3
+                    
+        real,    dimension (its:ite,kts:kte), intent (in ) :: p_cup,t_cup,z_cup,qo_cup,qeso_cup                            
+        real,    dimension (its:ite,kts:kte), intent (out) :: dtempdz                    
+        integer, dimension (its:ite,kts:kte), intent (out) :: k_inv_layers
+        !-local vars
+        real   :: dp,l_mid,l_shal,first_deriv(kts:kte),sec_deriv(kts:kte)
+        integer:: ken,kadd,kj,i,k,ilev,kk,ix,k800,k550,mid,shal
+        !
+        !-initialize k_inv_layers as undef
+        l_mid=300.
+        l_shal=100.
+        k_inv_layers(:,:) = 1
+         do i = its,itf
+           if(ierr(i) == 0)then
+           kend_p3(i)=kend(i)+3
+           DO k = kts+1,kend_p3(i)+4
+            !-  get the 1st der
+            first_deriv(k)= (t_cup(i,k+1)-t_cup(i,k-1))/(z_cup(i,k+1)-z_cup(i,k-1))        
+            dtempdz(i,k)=first_deriv(k)
+               enddo
+           DO k = kts+2,kend_p3(i)+3
+            !  get the 2nd der
+            sec_deriv(k)= (first_deriv(k+1)-first_deriv(k-1))/(z_cup(i,k+1)-z_cup(i,k-1))        
+            sec_deriv(k)= abs(sec_deriv(k))        
+           enddo
+        
+         ilev=max(kts+2,kstart(i)+1)
+         ix=1
+         k=ilev
+         DO WHILE (ilev < kend_p3(i)) !(z_cup(i,ilev)<15000.)
+           do kk=k,kend_p3(i)+2 !k,ktf-2
+             
+             if(sec_deriv(kk) <        sec_deriv(kk+1) .and.  &
+                sec_deriv(kk) < sec_deriv(kk-1)        ) then
+              k_inv_layers(i,ix)=kk
+              ix=min(5,ix+1)
+              ilev=kk+1
+              exit   
+             endif
+              ilev=kk+1
+               enddo
+           k=ilev
+         ENDDO         
+        !- 2nd criteria
+         kadd=0
+         ken=maxloc(k_inv_layers(i,:),1)
+         do k=1,ken
+           kk=k_inv_layers(i,k+kadd)
+           if(kk.eq.1)exit
+
+           if( dtempdz(i,kk) < dtempdz(i,kk-1) .and. &
+               dtempdz(i,kk) < dtempdz(i,kk+1) ) then ! the layer is not a local maximum
+               kadd=kadd+1
+                do kj = k,ken
+               if(k_inv_layers(i,kj+kadd).gt.1)k_inv_layers(i,kj) = k_inv_layers(i,kj+kadd)
+               if(k_inv_layers(i,kj+kadd).eq.1)k_inv_layers(i,kj) = 1
+                enddo
+           endif
+         ENDDO
+        endif
+        ENDDO
+100 format(1x,16i3)        
+        !- find the locations of inversions around 800 and 550 hPa
+        sec_deriv(:)=1.e9
+        do i = its,itf
+         if(ierr(i) /= 0) cycle
+
+         !- now find the closest layers of 800 and 550 hPa.         
+         do k=1,maxloc(k_inv_layers(i,:),1) !kts,kte !kstart(i),kend(i) !kts,kte
+           dp=p_cup(i,k_inv_layers(i,k))-p_cup(i,kstart(i))
+           sec_deriv(k)=abs(dp)-l_shal
+         enddo
+         k800=minloc(abs(sec_deriv),1)
+        sec_deriv(:)=1.e9
+
+         do k=1,maxloc(k_inv_layers(i,:),1) !kts,kte !kstart(i),kend(i) !kts,kte
+           dp=p_cup(i,k_inv_layers(i,k))-p_cup(i,kstart(i))
+           sec_deriv(k)=abs(dp)-l_mid
+         enddo
+         k550=minloc(abs(sec_deriv),1)
+         !-save k800 and k550 in k_inv_layers array
+         shal=1
+         mid=2
+         k_inv_layers(i,shal)=k_inv_layers(i,k800) ! this is for shallow convection
+         k_inv_layers(i,mid )=k_inv_layers(i,k550) ! this is for mid/congestus convection
+         k_inv_layers(i,mid+1:kte)=-1
+        ENDDO
+
+        
+ END SUBROUTINE get_inversion_layers
+!-----------------------------------------------------------------------------------
+ FUNCTION DERIV3(xx, xi, yi, ni, m)
+    !============================================================================*/
+    ! Evaluate first- or second-order derivatives 
+    ! using three-point Lagrange interpolation 
+    ! written by: Alex Godunov (October 2009)
+    ! input ...
+    ! xx    - the abscissa at which the interpolation is to be evaluated
+    ! xi()  - the arrays of data abscissas
+    ! yi()  - the arrays of data ordinates
+    ! ni - size of the arrays xi() and yi()
+    ! m  - order of a derivative (1 or 2)
+    ! output ...
+    ! deriv3  - interpolated value
+    !============================================================================*/
+    
+    implicit none
+    integer, parameter :: n=3
+    integer ni, m,i, j, k, ix
+    real:: deriv3, xx
+    real:: xi(ni), yi(ni), x(n), f(n)
+
+    ! exit if too high-order derivative was needed,
+    if (m > 2) then
+      deriv3 = 0.0
+      return
+    end if
+
+    ! if x is ouside the xi(1)-xi(ni) interval set deriv3=0.0
+    if (xx < xi(1) .or. xx > xi(ni)) then
+      deriv3 = 0.0
+      stop "problems with finding the 2nd derivative"
+    end if
+
+    ! a binary (bisectional) search to find i so that xi(i-1) < x < xi(i)
+    i = 1
+    j = ni
+    do while (j > i+1)
+      k = (i+j)/2
+      if (xx < xi(k)) then
+        j = k
+      else
+        i = k
+      end if
+    end do
+
+    ! shift i that will correspond to n-th order of interpolation
+    ! the search point will be in the middle in x_i, x_i+1, x_i+2 ...
+      i = i + 1 - n/2
+
+    ! check boundaries: if i is ouside of the range [1, ... n] -> shift i
+    if (i < 1) i=1
+    if (i + n > ni) i=ni-n+1
+
+    !  old output to test i
+    !  write(*,100) xx, i
+    !  100 format (f10.5, I5)
+
+    ! just wanted to use index i
+    ix = i
+    ! initialization of f(n) and x(n)
+    do i=1,n
+      f(i) = yi(ix+i-1)
+      x(i) = xi(ix+i-1)
+    end do
+
+    ! calculate the first-order derivative using Lagrange interpolation
+    if (m == 1) then
+        deriv3 =          (2.0*xx - (x(2)+x(3)))*f(1)/((x(1)-x(2))*(x(1)-x(3)))
+        deriv3 = deriv3 + (2.0*xx - (x(1)+x(3)))*f(2)/((x(2)-x(1))*(x(2)-x(3)))
+        deriv3 = deriv3 + (2.0*xx - (x(1)+x(2)))*f(3)/((x(3)-x(1))*(x(3)-x(2)))
+    ! calculate the second-order derivative using Lagrange interpolation
+      else
+        deriv3 =          2.0*f(1)/((x(1)-x(2))*(x(1)-x(3)))
+        deriv3 = deriv3 + 2.0*f(2)/((x(2)-x(1))*(x(2)-x(3)))
+        deriv3 = deriv3 + 2.0*f(3)/((x(3)-x(1))*(x(3)-x(2)))
+    end if
+ END FUNCTION DERIV3
+!=============================================================================================
+  SUBROUTINE get_lateral_massflux(itf,ktf, its,ite, kts,kte                             &
+                                  ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d                 &
+                                  ,up_massentro, up_massdetro ,up_massentr, up_massdetr &
+                                  ,draft,kbcon,k22,up_massentru,up_massdetru,lambau)
+
+     Implicit none
+     character *(*), intent (in) :: draft
+     integer, intent(in):: itf,ktf, its,ite, kts,kte
+     integer, intent(in)   , dimension(its:ite)         :: ierr,ktop,kbcon,k22
+     real,    intent(in),  OPTIONAL , dimension(its:ite):: lambau
+     real,    intent(in)   , dimension(its:ite,kts:kte) :: zo_cup,zuo
+     real,    intent(inout), dimension(its:ite,kts:kte) :: cd,entr_rate_2d   
+     real,    intent(  out), dimension(its:ite,kts:kte) :: up_massentro, up_massdetro  &
+                                                          ,up_massentr,  up_massdetr
+     real,    intent(  out), dimension(its:ite,kts:kte),  OPTIONAL ::                  &
+                                                          up_massentru,up_massdetru
+     !-- local vars
+     Integer :: i,k, incr1,incr2
+     REAL :: dz,trash,trash2
+     
+     do k=kts,kte
+      do i=its,ite
+         up_massentro(i,k)=0.
+         up_massdetro(i,k)=0.
+         up_massentr (i,k)=0.
+         up_massdetr (i,k)=0.
+      enddo
+     enddo
+     if(present(up_massentru) .and. present(up_massdetru))then
+       do k=kts,kte
+        do i=its,ite
+          up_massentru(i,k)=0.
+          up_massdetru(i,k)=0.
+        enddo
+       enddo
+     endif
+     DO i=its,itf
+       if(ierr(i).eq.0)then
+         
+          do k=max(2,k22(i)+1),maxloc(zuo(i,:),1)
+           !=> below maximum value zu -> change entrainment
+           dz=zo_cup(i,k)-zo_cup(i,k-1)
+        
+           up_massdetro(i,k-1)=cd(i,k-1)*dz*zuo(i,k-1)
+           up_massentro(i,k-1)=zuo(i,k)-zuo(i,k-1)+up_massdetro(i,k-1)
+           if(up_massentro(i,k-1).lt.0.)then
+              up_massentro(i,k-1)=0.
+              up_massdetro(i,k-1)=zuo(i,k-1)-zuo(i,k)
+              if(zuo(i,k-1).gt.0.)cd(i,k-1)=up_massdetro(i,k-1)/(dz*zuo(i,k-1))
+           endif
+           if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1))
+         enddo
+         do k=maxloc(zuo(i,:),1)+1,ktop(i)
+           !=> above maximum value zu -> change detrainment
+           dz=zo_cup(i,k)-zo_cup(i,k-1)
+           up_massentro(i,k-1)=entr_rate_2d(i,k-1)*dz*zuo(i,k-1)
+           up_massdetro(i,k-1)=zuo(i,k-1)+up_massentro(i,k-1)-zuo(i,k)
+           if(up_massdetro(i,k-1).lt.0.)then
+              up_massdetro(i,k-1)=0.
+              up_massentro(i,k-1)=zuo(i,k)-zuo(i,k-1)
+              if(zuo(i,k-1).gt.0.)entr_rate_2d(i,k-1)=(up_massentro(i,k-1))/(dz*zuo(i,k-1))
+           endif
+        
+           if(zuo(i,k-1).gt.0.)cd(i,k-1)=up_massdetro(i,k-1)/(dz*zuo(i,k-1))
+         enddo
+         up_massdetro(i,ktop(i))=zuo(i,ktop(i))
+         up_massentro(i,ktop(i))=0.
+         do k=ktop(i)+1,ktf
+           cd(i,k)=0.
+           entr_rate_2d(i,k)=0.
+           up_massentro(i,k)=0.
+           up_massdetro(i,k)=0.
+         enddo
+         do k=2,ktf-1
+           up_massentr (i,k-1)=up_massentro(i,k-1)
+           up_massdetr (i,k-1)=up_massdetro(i,k-1)
+         enddo         
+         if(present(up_massentru) .and. present(up_massdetru))then
+          do k=2,ktf-1
+           up_massentru(i,k-1)=up_massentro(i,k-1)+lambau(i)*up_massdetro(i,k-1)
+           up_massdetru(i,k-1)=up_massdetro(i,k-1)+lambau(i)*up_massdetro(i,k-1)
+          enddo
+         endif
+
+         trash=0.
+         trash2=0.
+         do k=k22(i)+1,ktop(i)
+             trash2=trash2+entr_rate_2d(i,k)
+         enddo
+         do k=k22(i)+1,kbcon(i)
+            trash=trash+entr_rate_2d(i,k)
+         enddo
+  
+       endif
+    ENDDO
+ END SUBROUTINE get_lateral_massflux
+!==============================================================================
+!---------------------------------------------------------------------- 
+  SUBROUTINE gfinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,            &
+                        RUCUTEN,RVCUTEN,                            &
+                        restart,                                    &
+                        P_QC,P_QI,P_FIRST_SCALAR,                   &
+                        RTHFTEN, RQVFTEN,                           &
+                        allowed_to_read,                            &
+                        ids, ide, jds, jde, kds, kde,               &
+                        ims, ime, jms, jme, kms, kme,               &
+                        its, ite, jts, jte, kts, kte               )
+!--------------------------------------------------------------------   
+   IMPLICIT NONE
+!--------------------------------------------------------------------
+   LOGICAL , INTENT(IN)           ::  restart,allowed_to_read
+   INTEGER , INTENT(IN)           ::  ids, ide, jds, jde, kds, kde, &
+                                      ims, ime, jms, jme, kms, kme, &
+                                      its, ite, jts, jte, kts, kte
+   INTEGER , INTENT(IN)           ::  P_FIRST_SCALAR, P_QI, P_QC
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
+                                                          RTHCUTEN,          &
+                                                          RQVCUTEN,          &
+                                                          RQCCUTEN,          &
+                                                          RQICUTEN
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
+                                                          RUCUTEN,           &
+                                                          RVCUTEN
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::       &
+                                                          RTHFTEN,           &
+                                                          RQVFTEN
+
+   INTEGER :: i, j, k, itf, jtf, ktf
+   jtf=min0(jte,jde-1)
+   ktf=min0(kte,kde-1)
+   itf=min0(ite,ide-1)
+
+   IF(.not.restart)THEN
+     DO j=jts,jte
+     DO k=kts,kte
+     DO i=its,ite
+        RTHCUTEN(i,k,j)=0.
+        RQVCUTEN(i,k,j)=0.
+        RUCUTEN(i,k,j)=0.
+        RVCUTEN(i,k,j)=0.
+     ENDDO
+     ENDDO
+     ENDDO
+
+
+     DO j=jts,jtf
+     DO k=kts,ktf
+     DO i=its,itf
+        RTHFTEN(i,k,j)=0.
+        RQVFTEN(i,k,j)=0.
+     ENDDO
+     ENDDO
+     ENDDO
+
+     IF (P_QC .ge. P_FIRST_SCALAR) THEN
+        DO j=jts,jtf
+        DO k=kts,ktf
+        DO i=its,itf
+           RQCCUTEN(i,k,j)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+     ENDIF
+
+     IF (P_QI .ge. P_FIRST_SCALAR) THEN
+        DO j=jts,jtf
+        DO k=kts,ktf
+        DO i=its,itf
+           RQICUTEN(i,k,j)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+     ENDIF
+
+   ENDIF
+
+   END SUBROUTINE gfinit
+END MODULE module_cu_gf_deep
diff --git a/wrfv2_fire/phys/module_cu_gf_sh.F b/wrfv2_fire/phys/module_cu_gf_sh.F
new file mode 100644
index 00000000..800a968c
--- /dev/null
+++ b/wrfv2_fire/phys/module_cu_gf_sh.F
@@ -0,0 +1,846 @@
+! module cup_gf_sh will call shallow convection as described in Grell and
+! Freitas (2016). Input variables are:
+!    zo               Height at model levels
+!    t,tn             Temperature without and with forcing at model levels
+!    q,qo             mixing ratio without and with forcing at model levels
+!    po               pressure at model levels (mb)
+!    psur             surface pressure (mb)
+!    z1               surface height
+!    dhdt             forcing for boundary layer equilibrium   
+!    hfx,qfx          in w/m2 (positive, if upward from sfc)
+!    kpbl             level of boundaty layer height
+!    xland            land mask (1. for land)
+!    ichoice          which closure to choose 
+!                     1: old g
+!                     2: zws
+!                     3: dhdt
+!                     0: average
+!    tcrit            parameter for water/ice conversion (258)
+!
+!!!!!!!!!!!! Variables that are diagnostic
+!
+!    zuo               normalized mass flux profile
+!    xmb_out           base mass flux
+!    kbcon             convective cloud base
+!    ktop              cloud top
+!    k22               level of updraft originating air
+!    ierr              error flag
+!    ierrc             error description
+!
+!!!!!!!!!!!! Variables that are on output
+!    outt               temperature tendency (K/s)
+!    outq               mixing ratio tendency (kg/kg/s)
+!    outqc              cloud water/ice tendency (kg/kg/s)
+!    pre                precip rate (mm/s)
+!    cupclw             incloud mixing ratio of cloudwater/ice (for radiation)
+!                       this needs heavy tuning factors, since cloud fraction is
+!                       not included (kg/kg)
+!    cnvwt              required for GFS physics
+!
+!    itf,ktf,its,ite, kts,kte are dimensions
+!    ztexec,zqexec    excess temperature and moisture for updraft
+MODULE module_cu_gf_sh
+    real, parameter:: c1_shal=0.! .0005
+    real, parameter:: g  =9.81
+    real, parameter:: cp =1004.
+    real, parameter:: xlv=2.5e6
+    real, parameter:: r_v=461.
+    real, parameter:: c0_shal=.001
+    real, parameter:: fluxtune=1.5
+
+
+contains
+  SUBROUTINE CUP_gf_sh (                                              &
+! input variables, must be supplied
+                         zo,T,Q,Z1,TN,QO,PO,PSUR,dhdt,kpbl,rho,     &
+                         hfx,qfx,xland,ichoice,tcrit,dtime, &
+! input variables. Ierr should be initialized to zero or larger than zero for
+! turning off shallow convection for grid points
+                         zuo,xmb_out,kbcon,ktop,k22,ierr,ierrc,    &
+! output tendencies
+                         OUTT,OUTQ,OUTQC,cnvwt,pre,cupclw,             &
+! dimesnional variables
+                         itf,ktf,its,ite, kts,kte,ipr)
+!
+! this module needs some subroutines from gf_deep
+!
+  use module_cu_gf_deep,only:cup_env,cup_env_clev,get_cloud_bc,cup_minimi,  &
+                      get_inversion_layers,rates_up_pdf,get_cloud_bc,     &
+                      cup_up_aa0,cup_kbcon,get_lateral_massflux
+     implicit none
+     integer                                                           &
+        ,intent (in   )                   ::                           &
+        itf,ktf,        &
+        its,ite, kts,kte,ipr
+     logical :: MAKE_CALC_FOR_XK = .true.
+     integer, intent (in   )              ::                           &
+        ichoice
+  !
+  ! 
+  !
+  ! outtem = output temp tendency (per s)
+  ! outq   = output q tendency (per s)
+  ! outqc  = output qc tendency (per s)
+  ! pre    = output precip
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout  )                   ::                           &
+        cnvwt,OUTT,OUTQ,OUTQC,cupclw,zuo
+     real,    dimension (its:ite)                                      &
+        ,intent (out  )                   ::                           &
+        xmb_out
+     integer,    dimension (its:ite)                                   &
+        ,intent (inout  )                   ::                           &
+        ierr
+     integer,    dimension (its:ite)                                   &
+        ,intent (out  )                   ::                           &
+        kbcon,ktop,k22
+     integer,    dimension (its:ite)                                   &
+        ,intent (in  )                   ::                           &
+        kpbl
+  !
+  ! basic environmental input includes a flag (ierr) to turn off
+  ! convection for this call only and at that particular gridpoint
+  !
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (in   )                   ::                           &
+        T,PO,tn,dhdt,rho
+     real,    dimension (its:ite,kts:kte)                              &
+        ,intent (inout)                   ::                           &
+         Q,QO
+     real, dimension (its:ite)                                         &
+        ,intent (in   )                   ::                           &
+        xland,Z1,PSUR,hfx,qfx
+       
+       real                                                            &
+        ,intent (in   )                   ::                           &
+        dtime,tcrit
+  !
+  !***************** the following are your basic environmental
+  !                  variables. They carry a "_cup" if they are
+  !                  on model cloud levels (staggered). They carry
+  !                  an "o"-ending (z becomes zo), if they are the forced
+  !                  variables. 
+  !
+  ! z           = heights of model levels
+  ! q           = environmental mixing ratio
+  ! qes         = environmental saturation mixing ratio
+  ! t           = environmental temp
+  ! p           = environmental pressure
+  ! he          = environmental moist static energy
+  ! hes         = environmental saturation moist static energy
+  ! z_cup       = heights of model cloud levels
+  ! q_cup       = environmental q on model cloud levels
+  ! qes_cup     = saturation q on model cloud levels
+  ! t_cup       = temperature (Kelvin) on model cloud levels
+  ! p_cup       = environmental pressure
+  ! he_cup = moist static energy on model cloud levels
+  ! hes_cup = saturation moist static energy on model cloud levels
+  ! gamma_cup = gamma on model cloud levels
+  ! dby = buoancy term
+  ! entr = entrainment rate
+  ! bu = buoancy term
+  ! gamma_cup = gamma on model cloud levels
+  ! qrch = saturation q in cloud
+  ! pwev = total normalized integrated evaoprate (I2)
+  ! z1 = terrain elevation
+  ! psur        = surface pressure
+  ! zu      = updraft normalized mass flux
+  ! kbcon       = LFC of parcel from k22
+  ! k22         = updraft originating level
+  ! ichoice       = flag if only want one closure (usually set to zero!)
+  ! dby = buoancy term
+  ! ktop = cloud top (output)
+  ! xmb    = total base mass flux
+  ! hc = cloud moist static energy
+  ! hkb = moist static energy at originating level
+
+     real,    dimension (its:ite,kts:kte) ::                           &
+        entr_rate_2d,he,hes,qes,z,                      &
+        heo,heso,qeso,zo,                                              &
+        xhe,xhes,xqes,xz,xt,xq,                                        &
+        qes_cup,q_cup,he_cup,hes_cup,z_cup,p_cup,gamma_cup,t_cup,      &
+        qeso_cup,qo_cup,heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,     &
+        tn_cup,                                                        &
+        xqes_cup,xq_cup,xhe_cup,xhes_cup,xz_cup,     &
+        xt_cup,dby,hc,zu,   &
+        dbyo,qco,pwo,hco,qrco,     &
+        dbyt,xdby,xhc,xzu,            &
+
+  ! cd  = detrainment function for updraft
+  ! dellat = change of temperature per unit mass flux of cloud ensemble
+  ! dellaq = change of q per unit mass flux of cloud ensemble
+  ! dellaqc = change of qc per unit mass flux of cloud ensemble
+
+        cd,DELLAH,DELLAQ,DELLAT,DELLAQC
+
+  ! aa0 cloud work function for downdraft
+  ! aa0     = cloud work function without forcing effects
+  ! aa1     = cloud work function with forcing effects
+  ! xaa0    = cloud work function with cloud effects (ensemble dependent)
+
+     real,    dimension (its:ite) ::                                   &
+       zws,ztexec,zqexec,pre,AA1,AA0,XAA0,HKB,                          &
+       flux_tun,HKBO,XHKB,                                    &
+       rand_vmas,xmbmax,XMB,                         &
+       cap_max,entr_rate,                                    &
+       cap_max_increment
+     integer,    dimension (its:ite) ::                                &
+       kstabi,xland1,KBMAX,ktopx
+
+     integer                              ::                           &
+       I,K,ki
+     real                                 ::                           &
+      dz,mbdt,zkbmax,      &
+      cap_maxs,trash,trash2,frh
+      
+      real buo_flux,pgeoh,dp,entup,detup,totmas
+
+     real xff_shal(3),blqe,xkshal
+     character*50 :: ierrc(its:ite)
+     real,    dimension (its:ite,kts:kte) ::                           &
+       up_massentr,up_massdetr,up_massentro,up_massdetro
+     real :: C_up,x_add,qaver
+     real,    dimension (its:ite,kts:kte) :: dtempdz
+     integer, dimension (its:ite,kts:kte) ::  k_inv_layers 
+     integer, dimension (its:ite) ::  start_level
+     start_level(:)=0
+     rand_vmas(:)=0.
+     flux_tun=fluxtune
+      do i=its,itf
+        xland1(i)=int(xland(i)+.001) ! 1.
+        ktopx(i)=0
+        if(xland(i).gt.1.5 .or. xland(i).lt.0.5)then
+            xland1(i)=0
+!            ierr(i)=100
+        endif
+        pre(i)=0.
+        xmb_out(i)=0.
+        cap_max_increment(i)=25.
+        ierrc(i)=" "
+        entr_rate(i) = 9.e-5 ! 1.75e-3 ! 1.2e-3 ! .2/50.
+      enddo
+!
+!--- initial entrainment rate (these may be changed later on in the
+!--- program
+!
+      
+!
+!--- initial detrainmentrates
+!
+      do k=kts,ktf
+      do i=its,itf
+        up_massentro(i,k)=0.
+        up_massdetro(i,k)=0.
+        z(i,k)=zo(i,k)
+        xz(i,k)=zo(i,k)
+        qrco(i,k)=0.
+        pwo(i,k)=0.
+        cd(i,k)=1.*entr_rate(i)
+        dellaqc(i,k)=0.
+        cupclw(i,k)=0.
+      enddo
+      enddo
+!
+!--- max/min allowed value for epsilon (ratio downdraft base mass flux/updraft
+!
+!--- minimum depth (m), clouds must have
+!
+!
+!--- maximum depth (mb) of capping 
+!--- inversion (larger cap = no convection)
+!
+      cap_maxs=125.
+      DO i=its,itf
+        kbmax(i)=1
+        aa0(i)=0.
+        aa1(i)=0.
+      enddo
+      do i=its,itf
+          cap_max(i)=cap_maxs
+          ztexec(i)  = 0.
+          zqexec(i)  = 0.
+          zws(i)     = 0.
+      enddo
+      do i=its,itf
+         !- buoyancy flux (H+LE)
+         buo_flux= (hfx(i)/cp+0.608*t(i,1)*qfx(i)/xlv)/rho(i,1)
+         pgeoh = zo(i,2)*g
+         !-convective-scale velocity w*
+         zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,2)*g/t(i,1))
+         if(zws(i) > TINY(pgeoh)) then
+          !-convective-scale velocity w*
+          zws(i) = 1.2*zws(i)**.3333
+          !- temperature excess 
+          ztexec(i)     = MAX(flux_tun(i)*hfx(i)/(rho(i,1)*zws(i)*cp),0.0)
+          !- moisture  excess
+          zqexec(i)     = MAX(flux_tun(i)*qfx(i)/xlv/(rho(i,1)*zws(i)),0.)
+         endif
+       !- zws for shallow convection closure (Grant 2001)
+       !- height of the pbl
+       zws(i) = max(0.,flux_tun(i)*0.41*buo_flux*zo(i,kpbl(i))*g/t(i,kpbl(i)))
+       zws(i) = 1.2*zws(i)**.3333
+       zws(i) = zws(i)*rho(i,kpbl(i)) !check if zrho is correct
+
+      enddo
+
+!
+!--- max height(m) above ground where updraft air can originate
+!
+      zkbmax=3000.
+!
+!--- calculate moist static energy, heights, qes
+!
+      call cup_env(z,qes,he,hes,t,q,po,z1, &
+           psur,ierr,tcrit,-1,   &
+           itf,ktf, &
+           its,ite, kts,kte)
+      call cup_env(zo,qeso,heo,heso,tn,qo,po,z1, &
+           psur,ierr,tcrit,-1,   &
+           itf,ktf, &
+           its,ite, kts,kte)
+
+!
+!--- environmental values on cloud levels
+!
+      call cup_env_clev(t,qes,q,he,hes,z,po,qes_cup,q_cup,he_cup, &
+           hes_cup,z_cup,p_cup,gamma_cup,t_cup,psur, &
+           ierr,z1,          &
+           itf,ktf, &
+           its,ite, kts,kte)
+      call cup_env_clev(tn,qeso,qo,heo,heso,zo,po,qeso_cup,qo_cup, &
+           heo_cup,heso_cup,zo_cup,po_cup,gammao_cup,tn_cup,psur,  &
+           ierr,z1,          &
+           itf,ktf, &
+           its,ite, kts,kte)
+      do i=its,itf
+        if(ierr(i).eq.0)then
+!
+      do k=kts,ktf
+        if(zo_cup(i,k).gt.zkbmax+z1(i))then
+          kbmax(i)=k
+          go to 25
+        endif
+      enddo
+ 25   continue
+!
+      kbmax(i)=min(kbmax(i),ktf/2)
+      endif
+      enddo
+
+!
+!
+!
+!------- DETERMINE LEVEL WITH HIGHEST MOIST STATIC ENERGY CONTENT - K22
+!
+       DO 36 i=its,itf
+         if(kpbl(i).gt.3)cap_max(i)=po_cup(i,kpbl(i))
+         IF(ierr(I) == 0)THEN
+          k22(i)=maxloc(HEO_CUP(i,2:kbmax(i)),1)
+          k22(i)=max(2,k22(i))
+          IF(K22(I).GT.KBMAX(i))then
+           ierr(i)=2
+           ierrc(i)="could not find k22"
+           ktop(i)=0
+           k22(i)=0
+           kbcon(i)=0
+         endif
+         endif
+ 36   CONTINUE
+!
+!--- DETERMINE THE LEVEL OF CONVECTIVE CLOUD BASE  - KBCON
+!
+      do i=its,itf
+       if(ierr(I).eq.0)then
+             x_add = xlv*zqexec(i)+cp*ztexec(i)
+             call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add)
+             call get_cloud_bc(kte,heo_cup(i,1:kte),hkbo(i),k22(i),x_add)
+       endif ! ierr
+      enddo
+
+!JOE-Georg and Saulo's new idea:
+      do i=its,itf
+      do k=kts,ktf
+          dbyo(i,k)= 0. !hkbo(i)-heso_cup(i,k)
+      enddo
+      enddo
+
+      call cup_kbcon(ierrc,cap_max_increment,5,k22,kbcon,heo_cup,heso_cup, &
+           hkbo,ierr,kbmax,po_cup,cap_max, &
+           ztexec,zqexec, &
+           0,itf,ktf, &
+           its,ite, kts,kte, &
+           z_cup,entr_rate,heo,0)
+!--- get inversion layers for cloud tops
+      call cup_minimi(HEso_cup,Kbcon,kbmax,kstabi,ierr,  &
+           itf,ktf, &
+           its,ite, kts,kte)
+!
+      call get_inversion_layers(ierr,p_cup,t_cup,z_cup,q_cup,qes_cup,k_inv_layers,&
+                           kbcon,kstabi,dtempdz,itf,ktf,its,ite, kts,kte)
+!
+!
+      DO i=its,itf
+         entr_rate_2d(i,:)=entr_rate(i)
+         IF(ierr(I) == 0)THEN
+            start_level(i)=k22(i)
+            x_add = xlv*zqexec(i)+cp*ztexec(i)
+            call get_cloud_bc(kte,he_cup (i,1:kte),hkb (i),k22(i),x_add)
+            if(kbcon(i).gt.ktf-4)then
+                ierr(i)=231
+            endif
+            do k=kts,ktf
+               frh = 2.*min(qo_cup(i,k)/qeso_cup(i,k),1.)
+               entr_rate_2d(i,k)=entr_rate(i)*(2.3-frh)
+               cd(i,k)=entr_rate_2d(i,k)
+            enddo
+!
+! first estimate for shallow convection
+!
+            ktop(i)=1
+!            if(k_inv_layers(i,1).gt.0)then
+!!               ktop(i)=min(k_inv_layers(i,1),k_inv_layers(i,2))
+            if(k_inv_layers(i,1).gt.0 .and.   &
+               (po_cup(i,kbcon(i))-po_cup(i,k_inv_layers(i,1))).lt.200.)then
+               ktop(i)=k_inv_layers(i,1)
+            else
+               do k=kbcon(i)+1,ktf
+                  if((po_cup(i,kbcon(i))-po_cup(i,k)).gt.200.)then
+                    ktop(i)=k
+                    exit
+                  endif
+               enddo
+            endif
+         endif
+      enddo
+! get normalized mass flux profile
+      call rates_up_pdf(rand_vmas,ipr,'shallow',ktop,ierr,po_cup,entr_rate_2d,hkbo,heo,heso_cup,zo_cup, &
+           xland1,kstabi,k22,kbcon,its,ite,itf,kts,kte,ktf,zuo,kpbl,ktopx,ktopx,kbcon)
+      do i=its,itf
+        if(ierr(i).eq.0)then
+!           do k=maxloc(zuo(i,:),1),1,-1 ! ktop(i)-1,1,-1
+!             if(zuo(i,k).lt.1.e-6)then
+!               k22(i)=k+1
+!               start_level(i)=k22(i)
+!               exit
+!             endif
+!           enddo
+           if(k22(i).gt.1)then
+             do k=1,k22(i)-1
+              zuo(i,k)=0.
+              zu (i,k)=0.
+              xzu(i,k)=0.
+             enddo
+           endif
+           do k=maxloc(zuo(i,:),1),ktop(i)
+             if(zuo(i,k).lt.1.e-6)then
+               ktop(i)=k-1
+               exit
+             endif
+           enddo
+           do k=k22(i),ktop(i)
+             xzu(i,k)= zuo(i,k)
+              zu(i,k)= zuo(i,k)
+           enddo
+           do k=ktop(i)+1,ktf
+             zuo(i,k)=0.
+             zu (i,k)=0.
+             xzu(i,k)=0.
+           enddo
+           k22(i)=max(2,k22(i))
+        endif
+      enddo
+!
+! calculate mass entrainment and detrainment
+!
+      CALL get_lateral_massflux(itf,ktf, its,ite, kts,kte &
+                                ,ierr,ktop,zo_cup,zuo,cd,entr_rate_2d        &
+                                ,up_massentro, up_massdetro ,up_massentr, up_massdetr &
+                                ,'shallow',kbcon,k22)
+
+      do k=kts,ktf
+      do i=its,itf
+         hc(i,k)=0.
+         qco(i,k)=0.
+         qrco(i,k)=0.
+         DBY(I,K)=0.
+         hco(i,k)=0.
+         DBYo(I,K)=0.
+      enddo
+      enddo
+      do i=its,itf
+       IF(ierr(I) /= 0) cycle
+         do k=1,start_level(i)-1
+            hc(i,k)=he_cup(i,k)
+            hco(i,k)=heo_cup(i,k)
+         enddo
+         k=start_level(i)
+         hc(i,k)=hkb(i)
+         hco(i,k)=hkbo(i)
+      enddo
+!
+!
+      do 42 i=its,itf
+        dbyt(i,:)=0.
+        IF(ierr(I) /= 0) cycle
+         do k=start_level(i)+1,ktop(i)
+          hc(i,k)=(hc(i,k-1)*zu(i,k-1)-.5*up_massdetr(i,k-1)*hc(i,k-1)+ &
+                         up_massentr(i,k-1)*he(i,k-1))   /            &
+                         (zu(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
+          dby(i,k)=max(0.,hc(i,k)-hes_cup(i,k))
+          hco(i,k)=(hco(i,k-1)*zuo(i,k-1)-.5*up_massdetro(i,k-1)*hco(i,k-1)+ &
+                         up_massentro(i,k-1)*heo(i,k-1))   /            &
+                         (zuo(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1))
+          dbyo(i,k)=hco(i,k)-heso_cup(i,k)
+          DZ=Zo_cup(i,K+1)-Zo_cup(i,K)
+          dbyt(i,k)=dbyt(i,k-1)+dbyo(i,k)*dz
+         enddo
+       ki=maxloc(dbyt(i,:),1)
+       if(ktop(i).gt.ki+1)then
+         ktop(i)=ki+1
+         zuo(i,ktop(i)+1:ktf)=0.
+         zu(i,ktop(i)+1:ktf)=0.
+         cd(i,ktop(i)+1:ktf)=0.
+         up_massdetro(i,ktop(i))=zuo(i,ktop(i))
+!         up_massentro(i,ktop(i))=0.
+         up_massentro(i,ktop(i):ktf)=0.
+         up_massdetro(i,ktop(i)+1:ktf)=0.
+         entr_rate_2d(i,ktop(i)+1:ktf)=0.
+
+!         ierr(i)=423
+       endif
+
+         if(ktop(i).lt.kbcon(i)+1)then
+            ierr(i)=5
+            ierrc(i)='ktop is less than kbcon+1'
+             go to 42
+         endif
+         if(ktop(i).gt.ktf-2)then
+             ierr(i)=5
+             ierrc(i)="ktop is larger than ktf-2"
+             go to 42
+         endif
+!
+         call get_cloud_bc(kte,qo_cup (i,1:kte),qaver,k22(i))
+         qaver = qaver + zqexec(i)
+         do k=1,start_level(i)-1
+           qco (i,k)= qo_cup(i,k)
+         enddo
+         k=start_level(i)
+         qco (i,k)= qaver 
+!
+         do k=start_level(i)+1,ktop(i)
+          trash=QESo_cup(I,K)+(1./XLV)*(GAMMAo_cup(i,k) &
+                /(1.+GAMMAo_cup(i,k)))*DBYo(I,K)
+          !- total water liq+vapour
+          trash2  = qco(i,k-1) ! +qrco(i,k-1)
+          qco (i,k)=   (trash2* ( zuo(i,k-1)-0.5*up_massdetr(i,k-1)) + &
+                       up_massentr(i,k-1)*qo(i,k-1))   /            &
+                       (zuo(i,k-1)-.5*up_massdetr(i,k-1)+up_massentr(i,k-1))
+
+          if(qco(i,k)>=trash ) then 
+              DZ=Z_cup(i,K)-Z_cup(i,K-1)
+              ! cloud liquid water
+              qrco(i,k)= (qco(i,k)-trash)/(1.+(c0_shal+c1_shal)*dz)
+!              qrco(i,k)= (qco(i,k)-trash)/(1.+c0_shal*dz)
+              pwo(i,k)=c0_shal*dz*qrco(i,k)*zuo(i,k)
+              ! cloud water vapor 
+              qco (i,k)= trash+qrco(i,k)
+        
+          else
+              qrco(i,k)= 0.0
+          endif 
+          cupclw(i,k)=qrco(i,k)
+         enddo
+         trash=0.
+         trash2=0.
+         do k=k22(i)+1,ktop(i)
+          dp=100.*(po_cup(i,k)-po_cup(i,k+1))
+          cnvwt(i,k)=zuo(i,k)*cupclw(i,k)*g/dp
+          trash2=trash2+entr_rate_2d(i,k)
+          qco(i,k)=qco(i,k)-qrco(i,k)
+         enddo
+         do k=k22(i)+1,max(kbcon(i),k22(i)+1)
+          trash=trash+entr_rate_2d(i,k)
+         enddo
+         do k=ktop(i)+1,ktf-1
+           hc  (i,k)=hes_cup (i,k)
+           hco (i,k)=heso_cup(i,k)
+           qco (i,k)=qeso_cup(i,k)
+           qrco(i,k)=0.
+           dby (i,k)=0.
+           dbyo(i,k)=0.
+           zu  (i,k)=0.
+           xzu (i,k)=0.
+           zuo (i,k)=0.
+         enddo
+ 42 continue
+!
+!--- calculate workfunctions for updrafts
+!
+      IF(MAKE_CALC_FOR_XK) THEN
+        call cup_up_aa0(aa0,z,zu,dby,GAMMA_CUP,t_cup, &
+            kbcon,ktop,ierr,           &
+            itf,ktf, its,ite, kts,kte)
+        call cup_up_aa0(aa1,zo,zuo,dbyo,GAMMAo_CUP,tn_cup, &
+            kbcon,ktop,ierr,           &
+            itf,ktf, its,ite, kts,kte)
+        do i=its,itf
+          if(ierr(i) == 0)then
+           if(aa1(i) <= 0.)then
+               ierr(i)=17
+               ierrc(i)="cloud work function zero"
+           endif
+         endif
+       enddo
+      ENDIF
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+!
+!--- change per unit mass that a model cloud would modify the environment
+!
+!--- 1. in bottom layer
+!
+      do k=kts,kte
+       do i=its,itf
+        dellah(i,k)=0.
+        dellaq(i,k)=0.
+       enddo
+      enddo
+!
+!----------------------------------------------  cloud level ktop
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - model level ktop-1
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!
+!----------------------------------------------  cloud level k+2
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - model level k+1
+!
+!----------------------------------------------  cloud level k+1
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - model level k
+!
+!----------------------------------------------  cloud level k
+!
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!      .               .                 .
+!
+!----------------------------------------------  cloud level 3
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - model level 2
+!
+!----------------------------------------------  cloud level 2
+!
+!- - - - - - - - - - - - - - - - - - - - - - - - model level 1
+      trash2=0.
+      do i=its,itf
+        if(ierr(i).eq.0)then
+         do k=k22(i),ktop(i)
+            ! entrainment/detrainment for updraft
+            entup=up_massentro(i,k)
+            detup=up_massdetro(i,k)
+            totmas=detup-entup+zuo(i,k+1)-zuo(i,k)
+            if(abs(totmas).gt.1.e-6)then
+               write(0,*)'*********************',i,k,totmas
+               write(0,*)k22(i),kbcon(i),ktop(i)
+            endif
+            dp=100.*(po_cup(i,k)-po_cup(i,k+1))
+            dellah(i,k) =-(zuo(i,k+1)*(hco(i,k+1)-heo_cup(i,k+1) )-     &
+                           zuo(i,k  )*(hco(i,k  )-heo_cup(i,k  ) ))*g/dp
+
+            !-- take out cloud liquid water for detrainment
+            dz=zo_cup(i,k+1)-zo_cup(i,k)
+            if(k.lt.ktop(i))then
+             dellaqc(i,k)= zuo(i,k)*c1_shal*qrco(i,k)*dz/dp*g !  detup*0.5*(qrco(i,k+1)+qrco(i,k)) *g/dp
+            else
+             dellaqc(i,k)=   detup*qrco(i,k) *g/dp
+            endif
+
+            !-- condensation source term = detrained + flux divergence of 
+            !-- cloud liquid water (qrco)
+            C_up = dellaqc(i,k)+(zuo(i,k+1)* qrco(i,k+1) -       &
+                                  zuo(i,k  )* qrco(i,k  )  )*g/dp
+!            C_up = dellaqc(i,k)
+            !-- water vapor budget (flux divergence of Q_up-Q_env - condensation
+            !term)
+            dellaq(i,k) =-(zuo(i,k+1)*(qco(i,k+1)-qo_cup(i,k+1) ) -      &
+                           zuo(i,k  )*(qco(i,k  )-qo_cup(i,k  ) ) )*g/dp &
+                           - C_up - 0.5*(pwo (i,k)+pwo (i,k+1))*g/dp
+          enddo
+        endif
+      enddo
+
+!
+!--- using dellas, calculate changed environmental profiles
+!
+      mbdt=.5 !3.e-4
+
+      do k=kts,ktf
+       do i=its,itf
+         dellat(i,k)=0.
+         if(ierr(i)/=0)cycle
+         xhe(i,k)=dellah(i,k)*mbdt+heo(i,k)
+         xq (i,k)=max(1.e-16,(dellaq(i,k)+dellaqc(i,k))*mbdt+qo(i,k))
+         dellat(i,k)=(1./cp)*(dellah(i,k)-xlv*(dellaq(i,k)))
+         xt (i,k)= (-dellaqc(i,k)*xlv/cp+dellat(i,k))*mbdt+tn(i,k)
+         xt (i,k)=  max(190.,xt(i,k))
+         
+       enddo
+      enddo
+      do i=its,itf
+       if(ierr(i).eq.0)then
+!        xhkb(i)=hkbo(i)+(dellah(i,k22(i)))*mbdt
+        xhe(i,ktf)=heo(i,ktf)
+        xq(i,ktf)=qo(i,ktf)
+        xt(i,ktf)=tn(i,ktf)
+       endif
+      enddo
+!
+!
+     IF(MAKE_CALC_FOR_XK) THEN
+!
+!--- calculate moist static energy, heights, qes
+!
+      call cup_env(xz,xqes,xhe,xhes,xt,xq,po,z1, &
+           psur,ierr,tcrit,-1,   &
+           itf,ktf, &
+           its,ite, kts,kte)
+!
+!--- environmental values on cloud levels
+!
+      call cup_env_clev(xt,xqes,xq,xhe,xhes,xz,po,xqes_cup,xq_cup, &
+           xhe_cup,xhes_cup,xz_cup,po_cup,gamma_cup,xt_cup,psur,   &
+           ierr,z1,          &
+           itf,ktf, &
+           its,ite, kts,kte)
+!
+!
+!**************************** static control
+      do k=kts,ktf
+      do i=its,itf
+         xhc(i,k)=0.
+         xDBY(I,K)=0.
+      enddo
+      enddo
+      do i=its,itf
+        if(ierr(i).eq.0)then
+         x_add = xlv*zqexec(i)+cp*ztexec(i)
+         call get_cloud_bc(kte,xhe_cup (i,1:kte),xhkb (i),k22(i),x_add)
+         do k=1,start_level(i)-1
+            xhc(i,k)=xhe_cup(i,k)
+         enddo
+         k=start_level(i)
+         xhc(i,k)=xhkb(i)
+        endif !ierr
+      enddo
+!
+!
+      do i=its,itf
+       if(ierr(i).eq.0)then
+        xzu(i,1:ktf)=zuo(i,1:ktf)	
+        do k=start_level(i)+1,ktop(i)
+         xhc(i,k)=(xhc(i,k-1)*xzu(i,k-1)-.5*up_massdetro(i,k-1)*xhc(i,k-1)+ &
+                          up_massentro(i,k-1)*xhe(i,k-1))   /            &
+                          (xzu(i,k-1)-.5*up_massdetro(i,k-1)+up_massentro(i,k-1))
+         xdby(i,k)=xhc(i,k)-xhes_cup(i,k)
+        enddo
+        do k=ktop(i)+1,ktf
+           xHC (i,K)=xhes_cup(i,k)
+           xDBY(I,K)=0.
+           xzu (i,k)=0.
+        enddo
+       endif
+      enddo
+
+!
+!--- workfunctions for updraft
+!
+      call cup_up_aa0(xaa0,xz,xzu,xdby,GAMMA_CUP,xt_cup, &
+           kbcon,ktop,ierr,           &
+           itf,ktf, &
+           its,ite, kts,kte)
+!
+     ENDIF
+!
+!
+! now for shallow forcing
+!
+       do i=its,itf
+        xmb(i)=0.
+        xff_shal(1:3)=0.
+        if(ierr(i).eq.0)then
+          xmbmax(i)=1.0  
+!         xmbmax(i)=100.*(p(i,kbcon(i))-p(i,kbcon(i)+1))/(g*dtime)
+!
+!-stabilization closure
+          xkshal=(xaa0(i)-aa1(i))/mbdt
+             if(xkshal.le.0.and.xkshal.gt.-.01*mbdt) &
+                           xkshal=-.01*mbdt
+             if(xkshal.gt.0.and.xkshal.lt.1.e-2) &
+                           xkshal=1.e-2
+
+          xff_shal(1)=max(0.,-(aa1(i)-aa0(i))/(xkshal*dtime))
+!
+!- closure from Grant (2001)
+          xff_shal(2)=.03*zws(i)
+!- boundary layer QE closure
+          blqe=0.
+          trash=0.
+          do k=1,kpbl(i)
+                blqe=blqe+100.*dhdt(i,k)*(po_cup(i,k)-po_cup(i,k+1))/g
+          enddo
+          trash=max((hc(i,kbcon(i))-he_cup(i,kbcon(i))),1.e1)
+          xff_shal(3)=max(0.,blqe/trash)
+          xff_shal(3)=min(xmbmax(i),xff_shal(3))
+!- average 
+          xmb(i)=(xff_shal(1)+xff_shal(2)+xff_shal(3))/3.
+          xmb(i)=min(xmbmax(i),xmb(i))
+          if(ichoice > 0)xmb(i)=min(xmbmax(i),xff_shal(ichoice))
+          if(xmb(i) <= 0.)then
+             ierr(i)=21
+             ierrc(i)="21"
+          endif
+        endif
+        if(ierr(i).ne.0)then
+           k22  (i)=0
+           kbcon(i)=0
+           ktop (i)=0
+           xmb  (i)=0.
+           outt (i,:)=0.
+           outq (i,:)=0.
+           outqc(i,:)=0.
+        else if(ierr(i).eq.0)then
+          xmb_out(i)=xmb(i)
+! 
+! final tendencies
+!
+          pre(i)=0.
+          do k=2,ktop(i)
+           outt (i,k)= dellat (i,k)*xmb(i)
+           outq (i,k)= dellaq (i,k)*xmb(i)
+           outqc(i,k)= dellaqc(i,k)*xmb(i)
+           pre  (i)  = pre(i)+pwo(i,k)*xmb(i)
+          enddo
+        endif
+       enddo
+!      
+! done shallow
+!--------------------------done------------------------------
+!
+
+   END SUBROUTINE CUP_gf_sh
+END MODULE module_cu_gf_sh
diff --git a/wrfv2_fire/phys/module_cu_gf_wrfdrv.F b/wrfv2_fire/phys/module_cu_gf_wrfdrv.F
new file mode 100644
index 00000000..c55a1099
--- /dev/null
+++ b/wrfv2_fire/phys/module_cu_gf_wrfdrv.F
@@ -0,0 +1,733 @@
+!WRF:MODEL_LAYER:PHYSICS
+!
+
+MODULE module_cu_gf_wrfdrv
+use module_gfs_physcons, g => con_g,                           &
+                         cp => con_cp,                         &
+                         xlv => con_hvap,                      &
+                         r_v => con_rv
+use module_cu_gf_deep, only: cup_gf,neg_check,autoconv,aeroevap
+use module_cu_gf_sh, only: cup_gf_sh
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!     This convective parameterization is build to attempt     !
+!     a smooth transition to cloud resolving scales as proposed!
+!     by Arakawa et al (2011, ACP). It currently does not use  !
+!     subsidencespreading as in G3. Difference and details     !
+!     will be described in a forthcoming paper by              !
+!     Grell and Freitas (2013). The parameterization also      !
+!     offers options to couple with aerosols. Both, the smooth !
+!     transition part as well as the aerosol coupling are      !
+!     experimental. While the smooth transition part is turned !
+!     on, nd has been tested dow to a resolution of about 3km  !
+!     the aerosol coupling is turned off.                      !
+!     More clean-up as well as a direct coupling to chemistry  !
+!     will follow for V3.5.1                                   !
+!                                                              !
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+!Isidora J. stochastic parameter perturbation added to closures
+!02/29/2016
+!
+CONTAINS
+
+!-------------------------------------------------------------
+   SUBROUTINE GFDRV(spp_conv,pattern_spp_conv,field_conv,       &
+               DT,DX                                            &
+              ,rho,RAINCV,PRATEC                                &
+              ,U,V,t,W,q,p,pi                                   &
+              ,dz8w,p8w                                         &
+              ,htop,hbot,ktop_deep                              &
+              ,HT,hfx,qfx,XLAND                                 &
+              ,GDC,GDC2 ,kpbl,k22_shallow,kbcon_shallow         &
+              ,ktop_shallow,xmb_shallow                         &
+              ,ichoice,ishallow_g3                              &
+              ,ids,ide, jds,jde, kds,kde                        &
+              ,ims,ime, jms,jme, kms,kme                        &
+              ,its,ite, jts,jte, kts,kte                        &
+              ,periodic_x,periodic_y                            &
+              ,RQVCUTEN,RQCCUTEN,RQICUTEN                       &
+              ,RQVFTEN,RTHFTEN,RTHCUTEN,RTHRATEN                &
+              ,rqvblten,rthblten                                &
+              ,dudt_phy,dvdt_phy                                &
+#if ( WRF_DFI_RADAR == 1 )
+                 ! Optional CAP suppress option
+              ,do_capsuppress,cap_suppress_loc                  &
+#endif                                 
+                                                                )
+!-------------------------------------------------------------
+   IMPLICIT NONE
+      integer, parameter :: ideep=1
+      integer, parameter :: imid_gf=0
+      integer, parameter :: ichoicem=0  ! 0 1 2 8 11 GG
+      integer, parameter :: ichoice_s=0 ! 0 1 2 3
+      integer, parameter :: dicycle=1 !- diurnal cycle flag
+      integer, parameter :: dicycle_m=0 !- diurnal cycle flag
+      real, parameter :: aodccn=0.1
+!-------------------------------------------------------------
+   INTEGER,      INTENT(IN   ) ::                               &
+                                  ids,ide, jds,jde, kds,kde,    & 
+                                  ims,ime, jms,jme, kms,kme,    & 
+                                  its,ite, jts,jte, kts,kte
+   LOGICAL periodic_x,periodic_y
+   integer, intent (in   )              :: ichoice
+  
+   INTEGER,      INTENT(IN   ) :: ishallow_g3
+
+   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
+          INTENT(IN   ) ::                                      &
+                                                          U,    &
+                                                          V,    &
+                                                          W,    &
+                                                         pi,    &
+                                                          t,    &
+                                                          q,    &
+                                                          p,    &
+                                                       dz8w,    &
+                                                       p8w,    &
+                                                        rho
+   REAL,  DIMENSION( ims:ime , kms:kme , jms:jme )         ,    &
+          OPTIONAL                                         ,    &
+          INTENT(INOUT   ) ::                                   &
+               GDC,GDC2
+
+   REAL, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: hfx,qfx,HT,XLAND
+   INTEGER, DIMENSION( ims:ime , jms:jme ),INTENT(IN) :: KPBL
+   INTEGER, DIMENSION( ims:ime , jms:jme ),                     &
+            OPTIONAL                      ,                     &
+            INTENT(INOUT) :: k22_shallow,kbcon_shallow,ktop_shallow
+   REAL, DIMENSION( ims:ime, jms:jme ),INTENT(INOUT  ),         &
+            OPTIONAL  :: xmb_shallow
+
+   REAL, INTENT(IN   ) :: DT, DX
+!
+
+   REAL, DIMENSION( ims:ime , jms:jme ),                        &
+         INTENT(INOUT) ::           pratec,RAINCV,htop,hbot
+!+lxz
+!  REAL, DIMENSION( ims:ime , jms:jme ) :: & !, INTENT(INOUT) ::       &
+!        HTOP,     &! highest model layer penetrated by cumulus since last reset in radiation_driver
+!        HBOT       ! lowest  model layer penetrated by cumulus since last reset in radiation_driver
+!                   ! HBOT>HTOP follow physics leveling convention
+
+   INTEGER, DIMENSION( ims:ime,         jms:jme ),              &
+         OPTIONAL,                                              &
+         INTENT(  OUT) ::                           ktop_deep
+
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         OPTIONAL,                                              &
+         INTENT(INOUT) ::                           RTHFTEN,    &
+                                                    RQVFTEN
+
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         OPTIONAL,                                              &
+         INTENT(INOUT) ::                                       &
+                                                   RTHCUTEN,    &
+                                                   RQVCUTEN,    &
+                                                   RQVBLTEN,    &
+                                                   RTHBLTEN,    &
+                                                   RTHRATEN,    &
+                                                   RQCCUTEN,    &
+                                                   RQICUTEN
+   REAL, DIMENSION( ims:ime , kms:kme , jms:jme ),              &
+         OPTIONAL,                                              &
+         INTENT(INOUT) ::                          DUDT_PHY,    &
+                                                   DVDT_PHY
+!  Stochastic
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),OPTIONAL  ::pattern_spp_conv,field_conv
+   REAL, DIMENSION( its:ite, 4 )                 ::   rstochcol !,fieldcol_conv
+! Stochastiv required by GF
+   REAL,  DIMENSION( its:ite )   :: rand_mom,rand_vmas
+   REAL,  DIMENSION( its:ite,4 ) :: rand_clos
+
+!
+! Flags relating to the optional tendency arrays declared above
+! Models that carry the optional tendencies will provdide the
+! optional arguments at compile time; these flags all the model
+! to determine at run-time whether a particular tracer is in
+! use or not.
+!
+
+   INTEGER                                 :: spp_conv
+
+#if ( WRF_DFI_RADAR == 1 )
+!
+!  option of cap suppress: 
+!        do_capsuppress = 1   do
+!        do_capsuppress = other   don't
+!
+!
+   INTEGER,      INTENT(IN   ) ,OPTIONAL   :: do_capsuppress
+   REAL, DIMENSION( ims:ime, jms:jme ),INTENT(IN   ),OPTIONAL  :: cap_suppress_loc
+   REAL, DIMENSION( its:ite ) :: cap_suppress_j
+#endif
+! LOCAL VARS
+     real,    dimension (its:ite,kts:kte) ::                    &
+        dhdt
+     real,    dimension (its:ite,kts:kte) ::                    &
+        OUTT,OUTQ,OUTQC,cupclw,outu,outv,cnvwt
+     real,    dimension (its:ite,kts:kte) ::                    &
+        OUTTs,OUTQs,OUTQCs,cupclws,outus,outvs,cnvwts
+     real,    dimension (its:ite,kts:kte) ::                    &
+        OUTTm,OUTQm,OUTQCm,cupclwm,outum,outvm,cnvwtm
+     real,    dimension (its:ite)         ::                    &
+        pret, prets,pretm,ter11, aa0, xlandi
+     real,    dimension (its:ite)         ::                    &
+        hfxi,qfxi,dxi
+!+lxz
+     integer, dimension (its:ite) ::                            &
+        ierr,ierrs,ierrm
+     integer, dimension (its:ite) ::                            &
+        kbcon, kbcons, kbconm,                                  &
+        ktop, ktops, ktopm,                                     &
+        kpbli, k22, k22s, k22m
+!.lxz
+     integer :: ibegc,iendc,jbegc,jendc
+
+     integer, dimension (its:ite)         :: jmin,jminm
+
+!
+! basic environmental input includes moisture convergence (mconv)
+! omega (omeg), windspeed (us,vs)
+!
+     real,    dimension (its:ite,kts:kte) ::                    &
+        zo,T2d,q2d,PO,P2d,US,VS,rhoi,tn,qo,tshall,qshall
+! output from cup routines, can be used for diagnostics
+     real,    dimension (its:ite,kts:kte) ::                    &
+        zus,zum,zu,zdm,zd
+     real,    dimension (its:ite,kts:kte) ::                    &
+        omeg
+     real, dimension (its:ite)            ::                    &
+        ccn,Z1,PSUR,cuten,cutens,cutenm,                        &
+        umean,vmean,pmean,xmb,xmbs,                             &
+        xmbm,xmb_out,tau_ecmwf_out,xmb_dumm
+     real, dimension (its:ite)     ::                    &
+        edt,edtm,mconv
+
+   INTEGER :: i,j,k,ICLDCK,ipr,jpr,n
+   REAL    :: tcrit,dp,dq
+   INTEGER :: itf,jtf,ktf,iss,jss,nbegin,nend
+   REAL    :: rkbcon,rktop        !-lxz
+   character*50 :: ierrc(its:ite)
+   character*50 :: ierrcs(its:ite)
+   character*50 :: ierrcm(its:ite)
+
+     real,    dimension (its:ite,kts:kte) :: hco,hcdo,zdo
+     real,    dimension (its:ite,10)         :: forcing,forcing2
+
+     integer, dimension (its:ite) :: cactiv
+     real,    dimension (its:ite,kts:kte) ::  qcheck
+
+
+
+   tcrit=258.
+   ipr=0 !639
+   jpr=0 !141
+   rand_mom(:)    = 0.
+   rand_vmas(:)   = 0.
+   rand_clos(:,:) = 0.
+
+   IF ( periodic_x ) THEN
+      ibegc=max(its,ids)
+      iendc=min(ite,ide-1)
+   ELSE
+      ibegc=max(its,ids+4)
+      iendc=min(ite,ide-5)
+   END IF
+   IF ( periodic_y ) THEN
+      jbegc=max(jts,jds)
+      jendc=min(jte,jde-1)
+   ELSE
+      jbegc=max(jts,jds+4)
+      jendc=min(jte,jde-5)
+   END IF
+   IF(PRESENT(k22_shallow)) THEN
+   do j=jts,jte
+   do i=its,ite
+     k22_shallow(i,j)=0
+     kbcon_shallow(i,j)=0
+     ktop_shallow(i,j)=0
+     xmb_shallow(i,j)=0
+   enddo
+   enddo
+   endif
+   rstochcol=0.0
+   itf=MIN(ite,ide-1)
+   ktf=MIN(kte,kde-1)
+   jtf=MIN(jte,jde-1)
+!                                                                      
+     DO J = jts,jte
+     DO I= its,ite
+     do k=kts,kte
+       rthcuten(i,k,j)=0.
+       rqvcuten(i,k,j)=0.
+       IF(PRESENT(RQCCUTEN))rqccuten(i,k,j)=0.
+       IF(PRESENT(RQICUTEN))rqicuten(i,k,j)=0.
+       DUDT_PHY(I,K,J)=0.
+       DVDT_PHY(I,K,J)=0.
+     enddo
+     enddo
+     enddo
+
+     DO 100 J = jts,jtf  
+
+     DO I= its,itf
+! Stochastic
+        if (spp_conv==1) then
+        do n=1,4
+        rstochcol(i,n)= pattern_spp_conv(i,n,j)
+        if (pattern_spp_conv(i,n,j) .le. -1.0) then
+          rstochcol(i,n)= -1.0
+        endif
+        if (pattern_spp_conv(i,n,j) .ge.  1.0) then
+          rstochcol(i,n)=  1.0
+        endif
+        enddo
+        endif
+        ierrc(i)=" "
+        ierrcs(i)=" "
+        ierrcm(i)=" "
+        ierr(i)=0
+        ierrs(i)=0
+        ierrm(i)=0
+
+        cuten(i)=0.
+        cutenm(i)=0.
+        cutens(i)=1.
+        if(ishallow_g3.eq.0)cutens(i)=0.
+
+        kbcon(i)=0
+        kbcons(i)=0
+        kbconm(i)=0
+        ktop(i)=0
+        ktops(i)=0
+        ktopm(i)=0
+        xmb(i)=0.
+        xmbs(i)=0.
+        xmbm(i)=0.
+        xmb_out(i)=0.
+        xmb_dumm(i)=0.
+
+        k22(i)=0
+        k22s(i)=0
+        k22m(i)=0
+
+        HBOT(I,J)  =REAL(KTE)
+        HTOP(I,J)  =REAL(KTS)
+        raincv(i,j)=0.
+        pratec (i,j)=0.
+        xlandi(i)=xland(i,j)
+        hfxi(i)=hfx(i,j)
+        qfxi(i)=qfx(i,j)
+
+        cactiv(i) = 0
+        jmin(i) = 0
+        jminm(i) = 0
+        forcing(i,:)=0.
+        forcing2(i,:)=0.
+        tau_ecmwf_out(i) = 0.
+
+        pret(i)=0.
+        prets(i) = 0.
+        pretm(i) = 0.
+
+        mconv(i)=0.
+        ccn(i)=150.
+
+     ENDDO
+     DO I= its,itf
+        mconv(i)=0.
+     ENDDO
+     do k=kts,kte
+     DO I= its,itf
+         omeg(i,k)=0.
+     ENDDO
+     ENDDO
+
+!ipr= 33 !78
+!jpr= 17 !110
+     DO I=ITS,ITF
+         dxi(i)=dx
+         PSUR(I)=p8w(I,1,J)*.01
+!        PSUR(I)=p(I,1,J)*.01
+         TER11(I)=max(0.,HT(i,j))
+! positive upward !!
+         hfxi(i)=hfx(i,j)
+         qfxi(i)=qfx(i,j)
+         pret(i)=0.
+         umean(i)=0.
+         vmean(i)=0.
+         pmean(i)=0.
+         kpbli(i)=kpbl(i,j)
+         zo(i,kts)=ter11(i)+.5*dz8w(i,1,j)
+         DO K=kts+1,ktf
+         zo(i,k)=zo(i,k-1)+.5*(dz8w(i,k-1,j)+dz8w(i,k,j))
+         enddo
+     ENDDO
+!    if(j.eq.jpr .and. (ipr.gt.its .and. ipr.lt.itf))write(0,*)psur(ipr),ter11(ipr),kpbli(ipr)
+     DO K=kts,ktf
+     DO I=ITS,ITF
+         po(i,k)=p(i,k,j)*.01
+         P2d(I,K)=PO(i,k)
+         rhoi(i,k)=rho(i,k,j)
+         US(I,K) =u(i,k,j)
+         VS(I,K) =v(i,k,j)
+         T2d(I,K)=t(i,k,j)
+         q2d(I,K)=q(i,k,j)
+         IF(Q2d(I,K).LT.1.E-08)Q2d(I,K)=1.E-08
+         TN(I,K)=t2d(i,k)+(RTHFTEN(i,k,j)+RTHRATEN(i,k,j)+RTHBLTEN(i,k,j)) &
+                          *pi(i,k,j)*dt
+         QO(I,K)=q2d(i,k)+(RQVFTEN(i,k,j)+RQVBLTEN(i,k,j))*dt
+         TSHALL(I,K)=t2d(i,k)+RTHBLTEN(i,k,j)*pi(i,k,j)*dt
+         DHDT(I,K)=cp*RTHBLTEN(i,k,j)*pi(i,k,j)+ XLV*RQVBLTEN(i,k,j)
+         QSHALL(I,K)=q2d(i,k)+RQVBLTEN(i,k,j)*dt
+         IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K)
+         IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08
+         OUTT(I,K)=0.
+         OUTu(I,K)=0.
+         OUTv(I,K)=0.
+         OUTQ(I,K)=0.
+         OUTQC(I,K)=0.
+         OUTTm(I,K)=0.
+         OUTum(I,K)=0.
+         OUTvm(I,K)=0.
+         OUTQm(I,K)=0.
+         OUTQCm(I,K)=0.
+         OUTTs(I,K)=0.
+         OUTus(I,K)=0.
+         OUTvs(I,K)=0.
+         OUTQs(I,K)=0.
+         OUTQCs(I,K)=0.
+         cupclws(i,k) = 0.
+         cupclw(i,k) = 0.
+         cupclwm(i,k) = 0.
+         qcheck(i,k) = 0.
+     ENDDO
+     ENDDO
+#if (NMM_CORE==1)
+! for NMM, tendencies have already been added to T,Q, and total tendencies
+! are stored in *FTEN variables
+     DO K=kts,ktf
+     DO I=ITS,ITF
+         TN(I,K)=t2d(i,k) + RTHFTEN(i,k,j)*pi(i,k,j)*dt
+         QO(I,K)=q2d(i,k) + RQVFTEN(i,k,j)*dt
+         IF(TN(I,K).LT.200.)TN(I,K)=T2d(I,K)
+         IF(QO(I,K).LT.1.E-08)QO(I,K)=1.E-08
+     ENDDO
+     ENDDO
+#endif
+! for EM_CORE, tendencies have not yet been added to T,Q, and *FTEN variables
+! contain advective forcing only
+     DO K=kts,ktf
+     DO I=ITS,ITF
+         omeg(I,K)= -g*rho(i,k,j)*w(i,k,j)
+     enddo
+     enddo
+     do k=  kts+1,ktf-1
+     DO I = its,itf
+         if((p2d(i,1)-p2d(i,k)).gt.150.and.p2d(i,k).gt.300)then
+            dp=-.5*(p2d(i,k+1)-p2d(i,k-1))
+            umean(i)=umean(i)+us(i,k)*dp
+            vmean(i)=vmean(i)+vs(i,k)*dp
+            pmean(i)=pmean(i)+dp
+         endif
+     enddo
+     enddo
+      DO K=kts,ktf-1
+      DO I = its,itf
+        dq=(q2d(i,k+1)-q2d(i,k))
+        mconv(i)=mconv(i)+omeg(i,k)*dq/g
+      enddo
+      ENDDO
+      DO I = its,itf
+        if(mconv(i).lt.0.)mconv(i)=0.
+      ENDDO
+!
+!---- CALL CUMULUS PARAMETERIZATION
+!
+#if ( WRF_DFI_RADAR == 1 )
+      if(do_capsuppress == 1 ) then
+        DO I= its,itf
+            cap_suppress_j(i)=cap_suppress_loc(i,j)
+        ENDDO
+      endif
+#endif
+
+       if(ishallow_g3 == 1 )then
+
+          call CUP_gf_sh (                                              &
+! input variables, must be supplied
+              zo,t2d,q2d,ter11,tshall,qshall,p2d,psur,dhdt,kpbli,      &
+              rhoi,hfxi,qfxi,xlandi,ichoice_s,tcrit,dt,                  &
+! input variables. Ierr should be initialized to zero or larger than zero for
+! turning off shallow convection for grid points
+              zus,xmbs,kbcons,ktops,k22s,ierrs,ierrcs,    &
+! output tendencies
+              outts,outqs,outqcs,cnvwt,prets,cupclws,             &
+! dimesnional variables
+              itf,ktf,its,ite, kts,kte,ipr)
+          do i=its,itf
+           if(xmbs(i).le.0.)cutens(i)=0.
+          enddo
+          CALL neg_check('shallow',ipr,dt,q2d,outqs,outts,outus,outvs,   &
+                                 outqcs,prets,its,ite,kts,kte,itf,ktf)
+
+        endif
+! Mid-level convection
+
+   if(imid_gf == 1)then
+
+      call cup_gf(        &
+               itf,ktf,its,ite, kts,kte  &
+
+              ,dicycle_m       &
+              ,ichoicem       &
+              ,ipr           &
+              ,ccn           &
+              ,dt         &
+              ,imid_gf          &
+
+              ,kpbli         &
+              ,dhdt          &
+              ,xlandi        &
+
+              ,zo            &
+              ,forcing2      &
+              ,t2d           &
+              ,q2d           &
+              ,ter11         &
+              ,tshall        &
+              ,qshall        &
+              ,p2d          &
+              ,psur          &
+              ,us            &
+              ,vs            &
+              ,rhoi          &
+              ,hfxi          &
+              ,qfxi          &
+              ,dxi            &
+              ,mconv         &
+              ,omeg          &
+
+              ,cactiv        &
+              ,cnvwtm        &
+              ,zum           &
+              ,zdm           &
+              ,edtm          &
+              ,xmbm          &
+              ,xmb_dumm      &
+              ,xmbs          &
+              ,pretm         &
+              ,outum         &
+              ,outvm         &
+              ,outtm         &
+              ,outqm         &
+              ,outqcm        &
+              ,kbconm        &
+              ,ktopm         &
+              ,cupclwm       &
+              ,ierrm         &
+              ,ierrcm        &
+!    the following should be set to zero if not available
+              ,rand_mom      & ! for stochastics mom, if temporal and spatial patterns exist
+              ,rand_vmas     & ! for stochastics vertmass, if temporal and spatial patterns exist
+              ,rand_clos     & ! for stochastics closures, if temporal and spatial patterns exist
+              ,0             & ! flag to what you want perturbed
+                               ! 1 = momentum transport 
+                               ! 2 = normalized vertical mass flux profile
+                               ! 3 = closures
+                               ! more is possible, talk to developer or
+                               ! implement yourself. pattern is expected to be
+                               ! betwee -1 and +1
+#if ( WRF_DFI_RADAR == 1 )
+              ,do_capsuppress,cap_suppress_j &
+#endif
+              ,k22m          &
+              ,jminm)
+
+            DO I=its,itf
+            DO K=kts,ktf
+              qcheck(i,k)=q2d(i,k) +outqs(i,k)*dt
+            enddo
+            enddo
+      CALL neg_check('mid',ipr,dt,qcheck,outqm,outtm,outum,outvm,   &
+                     outqcm,pretm,its,ite,kts,kte,itf,ktf)
+    endif
+
+#if ( WRF_DFI_RADAR == 1 )
+      if(do_capsuppress == 1 ) then
+        DO I= its,itf
+            cap_suppress_j(i)=cap_suppress_loc(i,j)
+        ENDDO
+      endif
+#endif
+   if(ideep.eq.1)then
+      call cup_gf(        &
+               itf,ktf,its,ite, kts,kte  &
+
+              ,dicycle       &
+              ,ichoice       &
+              ,ipr           &
+              ,ccn           &
+              ,dt            &
+              ,0             &
+
+              ,kpbli         &
+              ,dhdt          &
+              ,xlandi        &
+
+              ,zo            &
+              ,forcing       &
+              ,t2d           &
+              ,q2d           &
+              ,ter11         &
+              ,tn            &
+              ,qo            &
+              ,p2d           &
+              ,psur          &
+              ,us            &
+              ,vs            &
+              ,rhoi          &
+              ,hfxi          &
+              ,qfxi          &
+              ,dxi            &
+              ,mconv         &
+              ,omeg          &
+
+              ,cactiv       &
+              ,cnvwt        &
+              ,zu           &
+              ,zd           &
+              ,edt          &
+              ,xmb          &
+              ,xmbm         &
+              ,xmbs         &
+              ,pret         &
+              ,outu         &
+              ,outv         &
+              ,outt         &
+              ,outq         &
+              ,outqc        &
+              ,kbcon        &
+              ,ktop         &
+              ,cupclw       &
+              ,ierr         &
+              ,ierrc        &
+!    the following should be set to zero if not available
+              ,rand_mom      & ! for stochastics mom, if temporal and spatial patterns exist
+              ,rand_vmas     & ! for stochastics vertmass, if temporal and spatial patterns exist
+              ,rand_clos     & ! for stochastics closures, if temporal and spatial patterns exist
+              ,0             & ! flag to what you want perturbed
+                               ! 1 = momentum transport 
+                               ! 2 = normalized vertical mass flux profile
+                               ! 3 = closures
+                               ! more is possible, talk to developer or
+                               ! implement yourself. pattern is expected to be
+                               ! betwee -1 and +1
+#if ( WRF_DFI_RADAR == 1 )
+              ,do_capsuppress,cap_suppress_j &
+#endif
+              ,k22          &
+              ,jmin)
+        jpr=0
+        ipr=0
+            DO I=its,itf
+            DO K=kts,ktf
+              qcheck(i,k)=q2d(i,k) +(outqs(i,k)+outqm(i,k))*dt
+            enddo
+            enddo
+      CALL neg_check('deep',ipr,dt,qcheck,outq,outt,outu,outv,   &
+                                         outqc,pret,its,ite,kts,kte,itf,ktf)
+!
+      endif
+            if(j.lt.jbegc.or.j.gt.jendc)go to 100
+        IF(PRESENT(k22_shallow)) THEN
+             if(ishallow_g3.eq.1)then
+               DO I=ibegc,iendc
+                 xmb_shallow(i,j)=xmbs(i)
+                 k22_shallow(i,j)=k22s(i)
+                 kbcon_shallow(i,j)=kbcons(i)
+                 ktop_shallow(i,j)=ktops(i)
+                 ktop_deep(i,j) = ktop(i)
+               ENDDO
+            endif
+         ENDIF
+            DO I=ibegc,iendc
+              cuten(i)=0.
+              ktop_deep(i,j) = ktop(i)
+              if(pret(i).gt.0.)then
+                 cuten(i)=1.
+              else
+                 cuten(i)=0.
+                 kbcon(i)=0
+                 ktop(i)=0
+              endif
+              if(pretm(i).gt.0.)then
+                 cutenm(i)=1.
+              else
+                 cutenm(i)=0.
+                 kbconm(i)=0
+                 ktopm(i)=0
+              endif
+
+            ENDDO
+            DO I=ibegc,iendc
+            DO K=kts,ktf
+               RTHCUTEN(I,K,J)= (cutens(i)*outts(i,k)+ &
+                                 cutenm(i)*outtm(i,k)+ &
+                                 cuten(i)* outt(i,k)  )/pi(i,k,j)
+               RQVCUTEN(I,K,J)= cuten(i)*outq(i,k)   + &
+                                cutens(i)*outqs(i,k)+  &
+                                cutenm(i)*outqm(i,k)
+               DUDT_PHY(I,K,J)=outum(i,k)*cutenm(i)+outu(i,k)*cuten(i)
+               DVDT_PHY(I,K,J)=outvm(i,k)*cutenm(i)+outv(i,k)*cuten(i)
+            ENDDO
+            ENDDO
+
+            DO I=ibegc,iendc
+              if(pret(i).gt.0. .or. pretm(i).gt.0. .or. prets(i).gt.0.)then
+                 pratec(i,j)=cuten(i)*pret(i)+cutenm(i)*pretm(i)+cutens(i)*prets(i)
+                 raincv(i,j)=pratec(i,j)*dt
+                 rkbcon = kte+kts - kbcon(i)
+                 rktop  = kte+kts -  ktop(i)
+                 if (ktop(i)  > HTOP(i,j)) HTOP(i,j) = ktop(i)+.001
+                 if (kbcon(i) < HBOT(i,j)) HBOT(i,j) = kbcon(i)+.001
+              endif
+            ENDDO
+
+            IF(PRESENT(RQCCUTEN)) THEN
+                DO K=kts,ktf
+                DO I=ibegc,iendc
+                   RQCCUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i)
+                   IF ( PRESENT( GDC ) ) GDC(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i)
+                   IF ( PRESENT( GDC2 ) ) GDC2(I,K,J)=0.
+                ENDDO
+                ENDDO
+            ENDIF
+
+            IF(PRESENT(RQICUTEN).AND.PRESENT(RQCCUTEN))THEN
+                DO K=kts,ktf
+                  DO I=ibegc,iendc
+                   if(t2d(i,k).lt.258.)then
+                      RQICUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i)
+                      RQCCUTEN(I,K,J)=0.
+                      IF ( PRESENT( GDC2 ) ) THEN
+                        GDC2(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i)
+                        GDC(I,K,J) = 0.
+                      ENDIF
+                   else
+                      RQICUTEN(I,K,J)=0.
+                      RQCCUTEN(I,K,J)=outqcm(i,k)+outqcs(i,k)+outqc(I,K)*cuten(i)
+                      IF ( PRESENT( GDC ) ) THEN
+                        GDC(I,K,J)=cupclwm(i,k)+cupclws(i,k)+CUPCLW(I,K)*cuten(i)
+                        GDC2(I,K,J) = 0.
+                      ENDIF
+                   endif
+                ENDDO
+                ENDDO
+            ENDIF
+ 100    continue
+
+   END SUBROUTINE GFDRV
+END MODULE MODULE_CU_GF_WRFDRV
diff --git a/wrfv2_fire/phys/module_cu_mesosas.F b/wrfv2_fire/phys/module_cu_mesosas.F
deleted file mode 100644
index 087d5302..00000000
--- a/wrfv2_fire/phys/module_cu_mesosas.F
+++ /dev/null
@@ -1,7780 +0,0 @@
-!!
-MODULE module_cu_mesosas 
-
-CONTAINS
-
-!-----------------------------------------------------------------
-      SUBROUTINE CU_MESO_SAS(DT,ITIMESTEP,STEPCU,                   &
-                 RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,               &
-                 RUCUTEN,RVCUTEN,                                   & 
-                 RAINCV,PRATEC,HTOP,HBOT,                           &
-                 U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D,           &
-                 DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG,                   &
-                 P_QC,                                              & 
-                 MOMMIX, & ! gopal's doing
-                 PGCON,sas_mass_flux,                               &
-                 shalconv,shal_pgcon,                               &
-                 HPBL2D,EVAP2D,HEAT2D,                              & !Kwon for shallow convection
-                 P_QI,P_FIRST_SCALAR,                               & 
-                 ids,ide, jds,jde, kds,kde,                         &
-                 ims,ime, jms,jme, kms,kme,                         &
-                 its,ite, jts,jte, kts,kte                          )
-
-!-------------------------------------------------------------------
-      USE MODULE_GFS_MACHINE , ONLY : kind_phys
-      USE MODULE_GFS_FUNCPHYS , ONLY : gfuncphys
-      USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP  &
-     &,             RV => con_RV, FV => con_fvirt, T0C => con_T0C       &
-     &,             CVAP => con_CVAP, CLIQ => con_CLIQ                  & 
-     &,             EPS => con_eps, EPSM1 => con_epsm1                  &
-     &,             ROVCP => con_rocp, RD => con_rd
-!-------------------------------------------------------------------
-      IMPLICIT NONE
-!-------------------------------------------------------------------
-!-- U3D         3D u-velocity interpolated to theta points (m/s)
-!-- V3D         3D v-velocity interpolated to theta points (m/s)
-!-- TH3D	3D potential temperature (K)
-!-- T3D         temperature (K)
-!-- QV3D        3D water vapor mixing ratio (Kg/Kg)
-!-- QC3D        3D cloud mixing ratio (Kg/Kg)
-!-- QI3D        3D ice mixing ratio (Kg/Kg)
-!-- P8w         3D pressure at full levels (Pa)
-!-- Pcps        3D pressure (Pa)
-!-- PI3D	3D exner function (dimensionless)
-!-- rr3D	3D dry air density (kg/m^3)
-!-- RUBLTEN     U tendency due to
-!               PBL parameterization (m/s^2)
-!-- RVBLTEN     V tendency due to
-!               PBL parameterization (m/s^2)
-!-- RTHBLTEN    Theta tendency due to
-!               PBL parameterization (K/s)
-!-- RQVBLTEN    Qv tendency due to
-!               PBL parameterization (kg/kg/s)
-!-- RQCBLTEN    Qc tendency due to
-!               PBL parameterization (kg/kg/s)
-!-- RQIBLTEN    Qi tendency due to
-!               PBL parameterization (kg/kg/s)
-!
-!-- MOMMIX      MOMENTUM MIXING COEFFICIENT (can be set in the namelist)
-!-- RUCUTEN     U tendency due to Cumulus Momentum Mixing (gopal's doing for SAS)
-!-- RVCUTEN     V tendency due to Cumulus Momentum Mixing (gopal's doing for SAS)
-!
-!-- CP          heat capacity at constant pressure for dry air (J/kg/K)
-!-- GRAV        acceleration due to gravity (m/s^2)
-!-- ROVCP       R/CP
-!-- RD          gas constant for dry air (J/kg/K)
-!-- ROVG 	R/G
-!-- P_QI	species index for cloud ice
-!-- dz8w	dz between full levels (m)
-!-- z		height above sea level (m)
-!-- PSFC        pressure at the surface (Pa)
-!-- UST		u* in similarity theory (m/s)
-!-- PBL		PBL height (m)
-!-- PSIM        similarity stability function for momentum
-!-- PSIH        similarity stability function for heat
-!-- HFX		upward heat flux at the surface (W/m^2)
-!-- QFX		upward moisture flux at the surface (kg/m^2/s)
-!-- TSK		surface temperature (K)
-!-- GZ1OZ0      log(z/z0) where z0 is roughness length
-!-- WSPD        wind speed at lowest model level (m/s)
-!-- BR          bulk Richardson number in surface layer
-!-- DT		time step (s)
-!-- rvovrd      R_v divided by R_d (dimensionless)
-!-- EP1         constant for virtual temperature (R_v/R_d - 1) (dimensionless)
-!-- KARMAN      Von Karman constant
-!-- ids         start index for i in domain
-!-- ide         end index for i in domain
-!-- jds         start index for j in domain
-!-- jde         end index for j in domain
-!-- kds         start index for k in domain
-!-- kde         end index for k in domain
-!-- ims         start index for i in memory
-!-- ime         end index for i in memory
-!-- jms         start index for j in memory
-!-- jme         end index for j in memory
-!-- kms         start index for k in memory
-!-- kme         end index for k in memory
-!-- its         start index for i in tile
-!-- ite         end index for i in tile
-!-- jts         start index for j in tile
-!-- jte         end index for j in tile
-!-- kts         start index for k in tile
-!-- kte         end index for k in tile
-!-------------------------------------------------------------------
-
-      INTEGER ::                        ICLDCK
-
-      INTEGER, INTENT(IN) ::            ids,ide, jds,jde, kds,kde,      &
-                                        ims,ime, jms,jme, kms,kme,      &
-                                        its,ite, jts,jte, kts,kte,      &
-                                        ITIMESTEP,                      &     !NSTD
-                                        P_FIRST_SCALAR,                 &
-                                        P_QC,                           &
-                                        P_QI,                           &
-                                        STEPCU
-
-      REAL,    INTENT(IN) ::                                            &
-                                        DT
-
-      REAL, OPTIONAL, INTENT(IN) :: PGCON,sas_mass_flux,shal_pgcon
-      INTEGER, OPTIONAL, INTENT(IN) :: shalconv
-      REAL(kind=kind_phys)       :: PGCON_USE,SHAL_PGCON_USE,massf
-      INTEGER :: shalconv_use
-      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::      &
-                                        RQCCUTEN,                       &
-                                        RQICUTEN,                       &
-                                        RQVCUTEN,                       &
-                                        RTHCUTEN
-      REAL, DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(INOUT) ::      &
-                                        RUCUTEN,                        &  
-                                        RVCUTEN                             
-      REAL, OPTIONAL,   INTENT(IN) ::    MOMMIX
-
-      REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL,                   &
-                         INTENT(IN) :: HPBL2D,EVAP2D,HEAT2D                !Kwon for sha
-
-      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
-                                        XLAND
-
-      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            &
-                                        RAINCV, PRATEC
-
-      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::              &
-                                        HBOT,                           &
-                                        HTOP
-
-      LOGICAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) ::             &
-                                        CU_ACT_FLAG
-
-
-      REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::      &
-                                        DZ8W,                           &
-                                        P8w,                            &
-                                        Pcps,                           &
-                                        PI3D,                           &
-                                        QC3D,                           &
-                                        QI3D,                           &
-                                        QV3D,                           &
-                                        RHO3D,                          &
-                                        T3D,                            &
-                                        U3D,                            &
-                                        V3D,                            &
-                                        W
-
-!--------------------------- LOCAL VARS ------------------------------
-
-      REAL,    DIMENSION(ims:ime, jms:jme) ::                           &
-                                        PSFC
-
-      REAL,    DIMENSION(its:ite, jts:jte) ::                           &
-                                        RAINCV1, PRATEC1
-      REAL,    DIMENSION(its:ite, jts:jte) ::                           &
-                                        RAINCV2, PRATEC2
-
-      REAL     (kind=kind_phys) ::                                      &
-                                        DELT,                           &
-                                        DPSHC,                          &
-                                        RDELT,                          &
-                                        RSEED
-
-      REAL     (kind=kind_phys), DIMENSION(its:ite) ::                  &
-                                        CLDWRK,                         &
-                                        PS,                             &
-                                        RCS,                            &
-                                        RN,                             &
-                                        SLIMSK,                         &
-                                        HPBL,EVAP,HEAT                     !Kwon for shallow convection
-
-      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte+1) ::       &
-                                        PRSI                            
-
-      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte) ::         &
-                                        DEL,                            &
-                                        DOT,                            &
-                                        PHIL,                           &
-                                        PRSL,                           &
-                                        PRSLK,                          &
-                                        Q1,                             & 
-                                        T1,                             & 
-                                        U1,                             & 
-                                        V1,                             & 
-                                        ZI,                             & 
-                                        ZL 
-
-      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte, 2) ::      &
-                                        QL 
-
-      INTEGER, DIMENSION(its:ite) ::                                    &
-                                        KBOT,                           &
-                                        KTOP,                           &
-                                        KCNV
-
-      INTEGER ::                                                        &
-                                        I,                              &
-                                        IGPVS,                          &
-                                        IM,                             &
-                                        J,                              &
-                                        JCAP,                           &
-                                        K,                              &
-                                        KM,                             &
-                                        KP,                             &
-                                        KX,                             &
-                                        NCLOUD 
-
-      DATA IGPVS/0/
-
-!-----------------------------------------------------------------------
-!
-
-      if(present(shalconv)) then
-         shalconv_use=shalconv
-      else
-#if (NMM_CORE==1)
-         shalconv_use=0
-#else
-#if (EM_CORE==1)
-         shalconv_use=1
-#else
-         shalconv_use=0
-#endif
-#endif
-      endif
-
-      if(present(pgcon)) then
-         pgcon_use  = pgcon
-      else
-!        pgcon_use  = 0.7     ! Gregory et al. (1997, QJRMS)
-         pgcon_use  = 0.55    ! Zhang & Wu (2003,JAS), used in GFS (25km res spectral)
-!        pgcon_use  = 0.2     ! HWRF, for model tuning purposes
-!        pgcon_use  = 0.3     ! GFDL, or so I am told
-
-         ! For those attempting to tune pgcon:
-
-         ! The value of 0.55 comes from an observational study of
-         ! synoptic-scale deep convection and 0.7 came from an
-         ! incorrect fit to the same data.  That value is likely
-         ! correct for deep convection at gridscales near that of GFS,
-         ! but is questionable in shallow convection, or for scales
-         ! much finer than synoptic scales.
-
-         ! Then again, the assumptions of SAS break down when the
-         ! gridscale is near the convection scale anyway.  In a large
-         ! storm such as a hurricane, there is often no environment to
-         ! detrain into since adjancent gridsquares are also undergoing
-         ! active convection.  Each gridsquare will no longer have many
-         ! updrafts and downdrafts.  At sub-convective timescales, you
-         ! will find unstable columns for many (say, 5 second length)
-         ! timesteps in a real atmosphere during a convection cell's
-         ! lifetime, so forcing it to be neutrally stable is unphysical.
-
-         ! Hence, in scales near the convection scale (cells have
-         ! ~0.5-4km diameter in hurricanes), this parameter is more of a
-         ! tuning parameter to get a scheme that is inappropriate for
-         ! that resolution to do a reasonable job.
-
-         ! Your mileage might vary.
-
-         ! - Sam Trahan
-      endif
-
-      if(present(sas_mass_flux)) then
-         massf=sas_mass_flux
-         ! Use this to reduce the fluxes added by SAS to prevent
-         ! computational instability as a result of large fluxes.
-      else
-         massf=9e9 ! large number to disable check
-      endif
-
-      if(present(shal_pgcon)) then
-         if(shal_pgcon>=0) then
-            shal_pgcon_use  = shal_pgcon
-         else
-            ! shal_pgcon<0 means use deep pgcon
-            shal_pgcon_use  = pgcon_use
-         endif
-      else
-         ! Default: Same as deep convection pgcon
-         shal_pgcon_use  = pgcon_use
-         ! Read the warning above though.  It may be advisable for
-         ! these to be different.  
-      endif
-
-      DO J=JTS,JTE
-         DO I=ITS,ITE
-            CU_ACT_FLAG(I,J)=.TRUE.
-         ENDDO
-      ENDDO
- 
-      IM=ITE-ITS+1
-      KX=KTE-KTS+1
-      JCAP=126
-      DPSHC=30_kind_phys
-      DELT=DT*STEPCU
-      RDELT=1./DELT
-      NCLOUD=1
-
-
-   DO J=jms,jme
-     DO I=ims,ime
-       PSFC(i,j)=P8w(i,kms,j)
-     ENDDO
-   ENDDO
-
-   if(igpvs.eq.0) CALL GFUNCPHYS
-   igpvs=1
-
-!-------------  J LOOP (OUTER) --------------------------------------------------
-
-   big_outer_j_loop: DO J=jts,jte
-
-! --------------- compute zi and zl -----------------------------------------
-      DO i=its,ite
-        ZI(I,KTS)=0.0
-      ENDDO
-
-      DO k=kts+1,kte
-        KM=K-1
-        DO i=its,ite
-          ZI(I,K)=ZI(I,KM)+dz8w(i,km,j)
-        ENDDO
-      ENDDO
-
-      DO k=kts+1,kte
-        KM=K-1
-        DO i=its,ite
-          ZL(I,KM)=(ZI(I,K)+ZI(I,KM))*0.5
-        ENDDO
-      ENDDO
-
-      DO i=its,ite
-        ZL(I,KTE)=2.*ZI(I,KTE)-ZL(I,KTE-1)
-      ENDDO
-
-! --------------- end compute zi and zl -------------------------------------
-
-      DO i=its,ite
-        PS(i)=PSFC(i,j)*.001
-        RCS(i)=1.
-        SLIMSK(i)=ABS(XLAND(i,j)-2.)
-      ENDDO
-
-#if (NMM_CORE == 1)
-      if(shalconv_use==1) then
-      DO i=its,ite
-         HPBL(I) = HPBL2D(I,J)          !kwon for shallow convection
-         EVAP(I) = EVAP2D(I,J)          !kwon for shallow convection
-         HEAT(I) = HEAT2D(I,J)          !kwon for shallow convection
-      ENDDO
-      endif
-#endif
-
-      DO i=its,ite
-        PRSI(i,kts)=PS(i)
-      ENDDO
-
-      DO k=kts,kte
-        kp=k+1
-        DO i=its,ite
-          PRSL(I,K)=Pcps(i,k,j)*.001
-          PHIL(I,K)=ZL(I,K)*GRAV
-          DOT(i,k)=-5.0E-4*GRAV*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j))
-        ENDDO
-      ENDDO
-
-      DO k=kts,kte
-        DO i=its,ite
-          DEL(i,k)=PRSL(i,k)*GRAV/RD*dz8w(i,k,j)/T3D(i,k,j)
-          U1(i,k)=U3D(i,k,j)
-          V1(i,k)=V3D(i,k,j)
-          Q1(i,k)=QV3D(i,k,j)/(1.+QV3D(i,k,j))
-          T1(i,k)=T3D(i,k,j)
-          QL(i,k,1)=QI3D(i,k,j)/(1.+QI3D(i,k,j))
-          QL(i,k,2)=QC3D(i,k,j)/(1.+QC3D(i,k,j))
-          PRSLK(I,K)=(PRSL(i,k)*.01)**ROVCP
-        ENDDO
-      ENDDO
-
-      DO k=kts+1,kte+1
-        km=k-1
-        DO i=its,ite
-          PRSI(i,k)=PRSI(i,km)-del(i,km) 
-        ENDDO
-      ENDDO
-
-!      CALL SASCNVN(IM,IM,KX,JCAP,DELT,DEL,PRSL,PS,PHIL,                  &
-!                  QL,Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,                    &
-!                  KTOP,KCNV,SLIMSK,DOT,NCLOUD,PGCON_USE,massf)
-      CALL SASCNVN_H(IM,IM,KX,JCAP,DELT,DEL,PRSL,PS,PHIL,               &
-                    QL,Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,                  &
-              KTOP,KCNV,SLIMSK,DOT,NCLOUD,PGCON_USE,massf)
-!
-      do i=its,ite
-        RAINCV1(I,J)=RN(I)*1000./STEPCU
-        PRATEC1(I,J)=RN(I)*1000./(STEPCU * DT)
-      enddo
-!
-      do i=its,ite
-        RAINCV2(I,J)=0.
-        PRATEC2(I,J)=0.
-      enddo
-!
-
-      if_shallow_conv: if(shalconv_use==1) then
-#if (NMM_CORE == 1)
-         ! NMM calls the new shallow convection developed by J Han
-         ! (Added to WRF by Y.Kwon)
-        call shalcnv(im,im,kx,jcap,delt,del,prsl,ps,phil,ql,        &
-     &               q1,t1,u1,v1,rcs,rn,kbot,ktop,kcnv,slimsk,      &
-     &               dot,ncloud,hpbl,heat,evap,shal_pgcon_use)
-!
-      DO I=ITS,ITE
-        RAINCV2(I,J)=RN(I)*1000./STEPCU
-        PRATEC2(I,J)=RN(I)*1000./(STEPCU * DT)
-      ENDDO
-!
-#else
-#if (EM_CORE == 1)
-        ! NOTE: ARW should be able to call the new shalcnv here, but
-        ! they need to add the three new variables, so I'm leaving the
-        ! old shallow convection call here - Sam Trahan
-        CALL OLD_ARW_SHALCV(IM,IM,KX,DELT,DEL,PRSI,PRSL,PRSLK,KCNV,Q1,T1,DPSHC)
-#else
-        ! Shallow convection is untested for other cores.
-#endif
-#endif
-     endif if_shallow_conv
-
-        DO I=ITS,ITE
-        RAINCV(I,J)= RAINCV1(I,J) + RAINCV2(I,J)
-        PRATEC(I,J)= PRATEC1(I,J) + PRATEC2(I,J)
-        HBOT(I,J)=KBOT(I)
-        HTOP(I,J)=KTOP(I)
-      ENDDO
-
-      DO K=KTS,KTE
-        DO I=ITS,ITE
-          RTHCUTEN(I,K,J)=(T1(I,K)-T3D(I,K,J))/PI3D(I,K,J)*RDELT
-          RQVCUTEN(I,K,J)=(Q1(I,K)/(1.-q1(i,k))-QV3D(I,K,J))*RDELT
-        ENDDO
-      ENDDO
-
-!===============================================================================
-!     ADD MOMENTUM MIXING TERM AS TENDENCIES. This is gopal's doing for SAS
-!     MOMMIX is the reduction factor set to 0.7 by default. Because NMM has 
-!     divergence damping term, a reducion factor for cumulum mixing may be
-!     required otherwise storms were too weak.
-!===============================================================================
-!
-#if (NMM_CORE == 1)
-      DO K=KTS,KTE
-        DO I=ITS,ITE
-!         RUCUTEN(I,J,K)=MOMMIX*(U1(I,K)-U3D(I,K,J))*RDELT
-!         RVCUTEN(I,J,K)=MOMMIX*(V1(I,K)-V3D(I,K,J))*RDELT
-         RUCUTEN(I,J,K)=(U1(I,K)-U3D(I,K,J))*RDELT
-         RVCUTEN(I,J,K)=(V1(I,K)-V3D(I,K,J))*RDELT
-        ENDDO
-      ENDDO
-#endif
-
-
-      IF(P_QC .ge. P_FIRST_SCALAR)THEN
-        DO K=KTS,KTE
-          DO I=ITS,ITE
-            RQCCUTEN(I,K,J)=(QL(I,K,2)/(1.-ql(i,k,2))-QC3D(I,K,J))*RDELT
-          ENDDO
-        ENDDO
-      ENDIF
-
-      IF(P_QI .ge. P_FIRST_SCALAR)THEN
-        DO K=KTS,KTE
-          DO I=ITS,ITE
-            RQICUTEN(I,K,J)=(QL(I,K,1)/(1.-ql(i,k,1))-QI3D(I,K,J))*RDELT
-          ENDDO
-        ENDDO
-      ENDIF
-
-   ENDDO big_outer_j_loop    ! Outer most J loop
-
-   END SUBROUTINE CU_MESO_SAS
-
-!====================================================================
-   SUBROUTINE msasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,          &
-                      RUCUTEN,RVCUTEN,                              &   
-                      RESTART,P_QC,P_QI,P_FIRST_SCALAR,             &
-                      allowed_to_read,                              &
-                      ids, ide, jds, jde, kds, kde,                 &
-                      ims, ime, jms, jme, kms, kme,                 &
-                      its, ite, jts, jte, kts, kte                  )
-!--------------------------------------------------------------------
-   IMPLICIT NONE
-!--------------------------------------------------------------------
-   LOGICAL , INTENT(IN)           ::  allowed_to_read,restart
-   INTEGER , INTENT(IN)           ::  ids, ide, jds, jde, kds, kde, &
-                                      ims, ime, jms, jme, kms, kme, &
-                                      its, ite, jts, jte, kts, kte
-   INTEGER , INTENT(IN)           ::  P_FIRST_SCALAR, P_QI, P_QC
-
-   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::  &
-                                                              RTHCUTEN, &
-                                                              RQVCUTEN, &
-                                                              RQCCUTEN, &
-                                                              RQICUTEN
-   REAL,     DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(OUT) ::  &
-                                                              RUCUTEN,  & ! gopal's doing for SAS
-                                                              RVCUTEN   
-
-   INTEGER :: i, j, k, itf, jtf, ktf
-
-   jtf=min0(jte,jde-1)
-   ktf=min0(kte,kde-1)
-   itf=min0(ite,ide-1)
-
-#if ( HWRF == 1 )
-!zhang's doing
-   IF(.not.restart .or. .not.allowed_to_read)THEN
-!end of zhang's doing
-#else
-   IF(.not.restart)THEN
-#endif
-     DO j=jts,jtf
-     DO k=kts,ktf
-     DO i=its,itf
-       RTHCUTEN(i,k,j)=0.
-       RQVCUTEN(i,k,j)=0.
-       RUCUTEN(i,j,k)=0.   
-       RVCUTEN(i,j,k)=0.    
-     ENDDO
-     ENDDO
-     ENDDO
-
-     IF (P_QC .ge. P_FIRST_SCALAR) THEN
-        DO j=jts,jtf
-        DO k=kts,ktf
-        DO i=its,itf
-           RQCCUTEN(i,k,j)=0.
-        ENDDO
-        ENDDO
-        ENDDO
-     ENDIF
-
-     IF (P_QI .ge. P_FIRST_SCALAR) THEN
-        DO j=jts,jtf
-        DO k=kts,ktf
-        DO i=its,itf
-           RQICUTEN(i,k,j)=0.
-        ENDDO
-        ENDDO
-        ENDDO
-     ENDIF
-   ENDIF
-
-      END SUBROUTINE msasinit
-
-! ------------------------------------------------------------------------
-
-      SUBROUTINE SASCNV(IM,IX,KM,JCAP,DELT,DEL,PRSL,PS,PHIL,QL,         &
-!     SUBROUTINE SASCNV(IM,IX,KM,JCAP,DLT,DEL,PRSL,PHIL,QL,             &
-     &       Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,KTOP,KUO,SLIMSK,            &
-     &       DOT,XKT2,ncloud)
-!  for cloud water version
-!     parameter(ncloud=0)
-!     SUBROUTINE SASCNV(KM,JCAP,DELT,DEL,SL,SLK,PS,QL,
-!    &       Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,KTOP,KUO,SLIMSK,
-!    &       DOT,xkt2,ncloud)
-!
-      USE MODULE_GFS_MACHINE , ONLY : kind_phys
-      USE MODULE_GFS_FUNCPHYS ,ONLY : fpvs
-      USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP &
-     &,             RV => con_RV, FV => con_fvirt, T0C => con_T0C       &
-     &,             CVAP => con_CVAP, CLIQ => con_CLIQ                  &
-     &,             EPS => con_eps, EPSM1 => con_epsm1
-
-      implicit none
-!
-!     include 'constant.h'
-!
-      integer            IM, IX,  KM, JCAP, ncloud,                     &
-     &                   KBOT(IM), KTOP(IM), KUO(IM), J
-      real(kind=kind_phys) DELT
-      real(kind=kind_phys) PS(IM),      DEL(IX,KM),  PRSL(IX,KM),       &
-!     real(kind=kind_phys)              DEL(IX,KM),  PRSL(IX,KM),
-     &                     QL(IX,KM,2), Q1(IX,KM),   T1(IX,KM),         &
-     &                     U1(IX,KM),   V1(IX,KM),   RCS(IM),           &
-     &                     CLDWRK(IM),  RN(IM),      SLIMSK(IM),        &
-     &                     DOT(IX,KM),  XKT2(IM),    PHIL(IX,KM)
-!
-      integer              I, INDX, jmn, k, knumb, latd, lond, km1
-!
-      real(kind=kind_phys) adw,     alpha,   alphal,  alphas,           &
-     &                     aup,     beta,    betal,   betas,            &
-     &                     c0,      cpoel,   dellat,  delta,            &
-     &                     desdt,   deta,    detad,   dg,               &
-     &                     dh,      dhh,     dlnsig,  dp,               &
-     &                     dq,      dqsdp,   dqsdt,   dt,               &
-     &                     dt2,     dtmax,   dtmin,   dv1,              &
-     &                     dv1q,    dv2,     dv2q,    dv1u,             &
-     &                     dv1v,    dv2u,    dv2v,    dv3u,             &
-     &                     dv3v,    dv3,     dv3q,    dvq1,             &
-     &                     dz,      dz1,     e1,      edtmax,           &
-     &                     edtmaxl, edtmaxs, el2orc,  elocp,            &
-     &                     es,      etah,                               &
-     &                     evef,    evfact,  evfactl, fact1,            &
-     &                     fact2,   factor,  fjcap,   fkm,              &
-     &                     fuv,     g,       gamma,   onemf,            &
-     &                     onemfu,  pdetrn,  pdpdwn,  pprime,           &
-     &                     qc,      qlk,     qrch,    qs,               &
-     &                     rain,    rfact,   shear,   tem1,             &
-     &                     tem2,    terr,    val,     val1,             &
-     &                     val2,    w1,      w1l,     w1s,              &
-     &                     w2,      w2l,     w2s,     w3,               &
-     &                     w3l,     w3s,     w4,      w4l,              & 
-     &                     w4s,     xdby,    xpw,     xpwd,             & 
-     &                     xqc,     xqrch,   xlambu,  mbdt,             &
-     &                     tem
-!
-!
-      integer              JMIN(IM), KB(IM), KBCON(IM), KBDTR(IM),      & 
-     &                     KT2(IM),  KTCON(IM), LMIN(IM),               &
-     &                     kbm(IM),  kbmax(IM), kmax(IM)
-!
-      real(kind=kind_phys) AA1(IM),     ACRT(IM),   ACRTFCT(IM),        & 
-     &                     DELHBAR(IM), DELQ(IM),   DELQ2(IM),          &
-     &                     DELQBAR(IM), DELQEV(IM), DELTBAR(IM),        &
-     &                     DELTV(IM),   DTCONV(IM), EDT(IM),            &
-     &                     EDTO(IM),    EDTX(IM),   FLD(IM),            &
-     &                     HCDO(IM),    HKBO(IM),   HMAX(IM),           &
-     &                     HMIN(IM),    HSBAR(IM),  UCDO(IM),           &
-     &                     UKBO(IM),    VCDO(IM),   VKBO(IM),           &
-     &                     PBCDIF(IM),  PDOT(IM),   PO(IM,KM),          &
-     &                                  PWAVO(IM),  PWEVO(IM),          &
-!    &                     PSFC(IM),    PWAVO(IM),  PWEVO(IM),          &
-     &                     QCDO(IM),    QCOND(IM),  QEVAP(IM),          &
-     &                     QKBO(IM),    RNTOT(IM),  VSHEAR(IM),         &
-     &                     XAA0(IM),    XHCD(IM),   XHKB(IM),           & 
-     &                     XK(IM),      XLAMB(IM),  XLAMD(IM),          &
-     &                     XMB(IM),     XMBMAX(IM), XPWAV(IM),          &
-     &                     XPWEV(IM),   XQCD(IM),   XQKB(IM)
-!
-!  PHYSICAL PARAMETERS
-      PARAMETER(G=grav)
-      PARAMETER(CPOEL=CP/HVAP,ELOCP=HVAP/CP,                            &
-     &          EL2ORC=HVAP*HVAP/(RV*CP))
-      PARAMETER(TERR=0.,C0=.002,DELTA=fv)
-      PARAMETER(FACT1=(CVAP-CLIQ)/RV,FACT2=HVAP/RV-FACT1*T0C)
-!  LOCAL VARIABLES AND ARRAYS
-      real(kind=kind_phys) PFLD(IM,KM),    TO(IM,KM),     QO(IM,KM),    &
-     &                     UO(IM,KM),      VO(IM,KM),     QESO(IM,KM)
-!  cloud water
-      real(kind=kind_phys) QLKO_KTCON(IM), DELLAL(IM),    TVO(IM,KM),   &
-     &                     DBYO(IM,KM),    ZO(IM,KM),     SUMZ(IM,KM),  &
-     &                     SUMH(IM,KM),    HEO(IM,KM),    HESO(IM,KM),  &
-     &                     QRCD(IM,KM),    DELLAH(IM,KM), DELLAQ(IM,KM),&
-     &                     DELLAU(IM,KM),  DELLAV(IM,KM), HCKO(IM,KM),  &
-     &                     UCKO(IM,KM),    VCKO(IM,KM),   QCKO(IM,KM),  &
-     &                     ETA(IM,KM),     ETAU(IM,KM),   ETAD(IM,KM),  &
-     &                     QRCDO(IM,KM),   PWO(IM,KM),    PWDO(IM,KM),  &
-     &                     RHBAR(IM),      TX1(IM)
-!
-      LOGICAL TOTFLG, CNVFLG(IM), DWNFLG(IM), DWNFLG2(IM), FLG(IM)
-!
-      real(kind=kind_phys) PCRIT(15), ACRITT(15), ACRIT(15)
-!     SAVE PCRIT, ACRITT
-      DATA PCRIT/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,     &
-     &           350.,300.,250.,200.,150./
-      DATA ACRITT/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216,       &
-     &           .3151,.3677,.41,.5255,.7663,1.1686,1.6851/
-!  GDAS DERIVED ACRIT
-!     DATA ACRITT/.203,.515,.521,.566,.625,.665,.659,.688,              & 
-!    &            .743,.813,.886,.947,1.138,1.377,1.896/
-!
-      real(kind=kind_phys) TF, TCR, TCRF, RZERO, RONE
-      parameter (TF=233.16, TCR=263.16, TCRF=1.0/(TCR-TF))
-      parameter (RZERO=0.0,RONE=1.0)
-!-----------------------------------------------------------------------
-!
-      km1 = km - 1
-!  INITIALIZE ARRAYS
-!
-      DO I=1,IM
-        RN(I)=0.
-        KBOT(I)=KM+1
-        KTOP(I)=0
-        KUO(I)=0
-        CNVFLG(I) = .TRUE.
-        DTCONV(I) = 3600.
-        CLDWRK(I) = 0.
-        PDOT(I) = 0.
-        KT2(I) = 0
-        QLKO_KTCON(I) = 0.
-        DELLAL(I) = 0.
-      ENDDO
-!!
-      DO K = 1, 15
-        ACRIT(K) = ACRITT(K) * (975. - PCRIT(K))
-      ENDDO
-      DT2 = DELT
-!cmr  dtmin = max(dt2,1200.)
-      val   =         1200.
-      dtmin = max(dt2, val )
-!cmr  dtmax = max(dt2,3600.)
-      val   =         3600.
-      dtmax = max(dt2, val )
-!  MODEL TUNABLE PARAMETERS ARE ALL HERE
-      MBDT    = 10.
-      EDTMAXl = .3
-      EDTMAXs = .3
-      ALPHAl  = .5
-      ALPHAs  = .5
-      BETAl   = .15
-      betas   = .15
-      BETAl   = .05
-      betas   = .05
-!     change for hurricane model
-        BETAl = .5
-        betas = .5
-!     EVEF    = 0.07
-      evfact  = 0.3
-      evfactl = 0.3
-!     change for hurricane model
-         evfact = 0.6
-         evfactl = .6
-#if ( EM_CORE == 1 )
-!  HAWAII TEST - ZCX
-      ALPHAl  = .5
-      ALPHAs  = .75
-      BETAl   = .05
-      betas   = .05
-      evfact  = 0.5
-      evfactl = 0.5
-#endif
-      PDPDWN  = 0.
-      PDETRN  = 200.
-      xlambu  = 1.e-4
-      fjcap   = (float(jcap) / 126.) ** 2
-!cmr  fjcap   = max(fjcap,1.)
-      val     =           1.
-      fjcap   = max(fjcap,val)
-      fkm     = (float(km) / 28.) ** 2
-!cmr  fkm     = max(fkm,1.)
-      fkm     = max(fkm,val)
-      W1l     = -8.E-3 
-      W2l     = -4.E-2
-      W3l     = -5.E-3 
-      W4l     = -5.E-4
-      W1s     = -2.E-4
-      W2s     = -2.E-3
-      W3s     = -1.E-3
-      W4s     = -2.E-5
-!CCCC IF(IM.EQ.384) THEN
-        LATD  = 92
-        lond  = 189
-!CCCC ELSEIF(IM.EQ.768) THEN
-!CCCC   LATD = 80
-!CCCC ELSE
-!CCCC   LATD = 0
-!CCCC ENDIF
-!
-!  DEFINE TOP LAYER FOR SEARCH OF THE DOWNDRAFT ORIGINATING LAYER
-!  AND THE MAXIMUM THETAE FOR UPDRAFT
-!
-      DO I=1,IM
-        KBMAX(I) = KM
-        KBM(I)   = KM
-        KMAX(I)  = KM
-        TX1(I)   = 1.0 / PS(I)
-      ENDDO
-!     
-      DO K = 1, KM
-        DO I=1,IM
-          IF (prSL(I,K)*tx1(I) .GT. 0.45) KBMAX(I) = K + 1
-          IF (prSL(I,K)*tx1(I) .GT. 0.70) KBM(I)   = K + 1
-          IF (prSL(I,K)*tx1(I) .GT. 0.04) KMAX(I)  = MIN(KM,K + 1)
-        ENDDO
-      ENDDO
-      DO I=1,IM
-        KBMAX(I) = MIN(KBMAX(I),KMAX(I))
-        KBM(I)   = MIN(KBM(I),KMAX(I))
-      ENDDO
-!
-!   CONVERT SURFACE PRESSURE TO MB FROM CB
-!
-!!
-      DO K = 1, KM
-        DO I=1,IM
-          if (K .le. kmax(i)) then
-            PFLD(I,k) = PRSL(I,K) * 10.0
-            PWO(I,k)  = 0.
-            PWDO(I,k) = 0.
-            TO(I,k)   = T1(I,k)
-            QO(I,k)   = Q1(I,k)
-            UO(I,k)   = U1(I,k)
-            VO(I,k)   = V1(I,k)
-            DBYO(I,k) = 0.
-            SUMZ(I,k) = 0.
-            SUMH(I,k) = 0.
-          endif
-        ENDDO
-      ENDDO
-
-!
-!  COLUMN VARIABLES
-!  P IS PRESSURE OF THE LAYER (MB)
-!  T IS TEMPERATURE AT T-DT (K)..TN
-!  Q IS MIXING RATIO AT T-DT (KG/KG)..QN
-!  TO IS TEMPERATURE AT T+DT (K)... THIS IS AFTER ADVECTION AND TURBULAN
-!  QO IS MIXING RATIO AT T+DT (KG/KG)..Q1
-!
-      DO K = 1, KM
-        DO I=1,IM
-          if (k .le. kmax(i)) then
-         !jfe        QESO(I,k) = 10. * FPVS(T1(I,k))
-         !
-            QESO(I,k) = 0.01 * fpvs(T1(I,K))      ! fpvs is in Pa
-         !
-            QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k) + EPSM1*QESO(I,k))
-         !cmr        QESO(I,k) = MAX(QESO(I,k),1.E-8)
-            val1      =             1.E-8
-            QESO(I,k) = MAX(QESO(I,k), val1)
-         !cmr        QO(I,k)   = max(QO(I,k),1.e-10)
-            val2      =           1.e-10
-            QO(I,k)   = max(QO(I,k), val2 )
-         !           QO(I,k)   = MIN(QO(I,k),QESO(I,k))
-            TVO(I,k)  = TO(I,k) + DELTA * TO(I,k) * QO(I,k)
-          endif
-        ENDDO
-      ENDDO
-
-!
-!  HYDROSTATIC HEIGHT ASSUME ZERO TERR
-!
-      DO K = 1, KM
-        DO I=1,IM
-          ZO(I,k) = PHIL(I,k) / G
-        ENDDO
-      ENDDO
-!  COMPUTE MOIST STATIC ENERGY
-      DO K = 1, KM
-        DO I=1,IM
-          if (K .le. kmax(i)) then
-!           tem       = G * ZO(I,k) + CP * TO(I,k)
-            tem       = PHIL(I,k) + CP * TO(I,k)
-            HEO(I,k)  = tem  + HVAP * QO(I,k)
-            HESO(I,k) = tem  + HVAP * QESO(I,k)
-!           HEO(I,k)  = MIN(HEO(I,k),HESO(I,k))
-          endif
-        ENDDO
-      ENDDO
-!
-!  DETERMINE LEVEL WITH LARGEST MOIST STATIC ENERGY
-!  THIS IS THE LEVEL WHERE UPDRAFT STARTS
-!
-      DO I=1,IM
-        HMAX(I) = HEO(I,1)
-        KB(I) = 1
-      ENDDO
-!!
-      DO K = 2, KM
-        DO I=1,IM
-          if (k .le. kbm(i)) then
-            IF(HEO(I,k).GT.HMAX(I).AND.CNVFLG(I)) THEN
-              KB(I)   = K
-              HMAX(I) = HEO(I,k)
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!     DO K = 1, KMAX - 1
-!         TOL(k) = .5 * (TO(I,k) + TO(I,k+1))
-!         QOL(k) = .5 * (QO(I,k) + QO(I,k+1))
-!         QESOL(I,k) = .5 * (QESO(I,k) + QESO(I,k+1))
-!         HEOL(I,k) = .5 * (HEO(I,k) + HEO(I,k+1))
-!         HESOL(I,k) = .5 * (HESO(I,k) + HESO(I,k+1))
-!     ENDDO
-      DO K = 1, KM1
-        DO I=1,IM
-          if (k .le. kmax(i)-1) then
-            DZ      = .5 * (ZO(I,k+1) - ZO(I,k))
-            DP      = .5 * (PFLD(I,k+1) - PFLD(I,k))
-!jfe        ES      = 10. * FPVS(TO(I,k+1))
-!
-            ES      = 0.01 * fpvs(TO(I,K+1))      ! fpvs is in Pa
-!
-            PPRIME  = PFLD(I,k+1) + EPSM1 * ES
-            QS      = EPS * ES / PPRIME
-            DQSDP   = - QS / PPRIME
-            DESDT   = ES * (FACT1 / TO(I,k+1) + FACT2 / (TO(I,k+1)**2))
-            DQSDT   = QS * PFLD(I,k+1) * DESDT / (ES * PPRIME)
-            GAMMA   = EL2ORC * QESO(I,k+1) / (TO(I,k+1)**2)
-            DT      = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA))
-            DQ      = DQSDT * DT + DQSDP * DP
-            TO(I,k) = TO(I,k+1) + DT
-            QO(I,k) = QO(I,k+1) + DQ
-            PO(I,k) = .5 * (PFLD(I,k) + PFLD(I,k+1))
-          endif
-        ENDDO
-      ENDDO
-!
-      DO K = 1, KM1
-        DO I=1,IM
-          if (k .le. kmax(I)-1) then
-!jfe        QESO(I,k) = 10. * FPVS(TO(I,k))
-!
-            QESO(I,k) = 0.01 * fpvs(TO(I,K))      ! fpvs is in Pa
-!
-            QESO(I,k) = EPS * QESO(I,k) / (PO(I,k) + EPSM1*QESO(I,k))
-!cmr        QESO(I,k) = MAX(QESO(I,k),1.E-8)
-            val1      =             1.E-8
-            QESO(I,k) = MAX(QESO(I,k), val1)
-!cmr        QO(I,k)   = max(QO(I,k),1.e-10)
-            val2      =           1.e-10
-            QO(I,k)   = max(QO(I,k), val2 )
-!           QO(I,k)   = MIN(QO(I,k),QESO(I,k))
-            HEO(I,k)  = .5 * G * (ZO(I,k) + ZO(I,k+1)) +                &
-     &                  CP * TO(I,k) + HVAP * QO(I,k)
-            HESO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) +                & 
-     &                  CP * TO(I,k) + HVAP * QESO(I,k)
-            UO(I,k)   = .5 * (UO(I,k) + UO(I,k+1))
-            VO(I,k)   = .5 * (VO(I,k) + VO(I,k+1))
-          endif
-        ENDDO
-      ENDDO
-!     k = kmax
-!       HEO(I,k) = HEO(I,k)
-!       hesol(k) = HESO(I,k)
-!      IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
-!        PRINT *, '   HEO ='
-!        PRINT 6001, (HEO(I,K),K=1,KMAX)
-!        PRINT *, '   HESO ='
-!        PRINT 6001, (HESO(I,K),K=1,KMAX)
-!        PRINT *, '   TO ='
-!        PRINT 6002, (TO(I,K)-273.16,K=1,KMAX)
-!        PRINT *, '   QO ='
-!        PRINT 6003, (QO(I,K),K=1,KMAX)
-!        PRINT *, '   QSO ='
-!        PRINT 6003, (QESO(I,K),K=1,KMAX)
-!      ENDIF
-!
-!  LOOK FOR CONVECTIVE CLOUD BASE AS THE LEVEL OF FREE CONVECTION
-!
-      DO I=1,IM
-        IF(CNVFLG(I)) THEN
-          INDX    = KB(I)
-          HKBO(I) = HEO(I,INDX)
-          QKBO(I) = QO(I,INDX)
-          UKBO(I) = UO(I,INDX)
-          VKBO(I) = VO(I,INDX)
-        ENDIF
-        FLG(I)    = CNVFLG(I)
-        KBCON(I)  = KMAX(I)
-      ENDDO
-!!
-      DO K = 1, KM
-        DO I=1,IM
-          if (k .le. kbmax(i)) then
-            IF(FLG(I).AND.K.GT.KB(I)) THEN
-              HSBAR(I)   = HESO(I,k)
-              IF(HKBO(I).GT.HSBAR(I)) THEN
-                FLG(I)   = .FALSE.
-                KBCON(I) = K
-              ENDIF
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-      DO I=1,IM
-        IF(CNVFLG(I)) THEN
-          PBCDIF(I) = -PFLD(I,KBCON(I)) + PFLD(I,KB(I))
-          PDOT(I)   = 10.* DOT(I,KBCON(I))
-          IF(PBCDIF(I).GT.150.)    CNVFLG(I) = .FALSE.
-          IF(KBCON(I).EQ.KMAX(I))  CNVFLG(I) = .FALSE.
-        ENDIF
-      ENDDO
-!!
-      TOTFLG = .TRUE.
-      DO I=1,IM
-        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
-      ENDDO
-      IF(TOTFLG) RETURN
-!  FOUND LFC, CAN DEFINE REST OF VARIABLES
- 6001 FORMAT(2X,-2P10F12.2)
- 6002 FORMAT(2X,10F12.2)
- 6003 FORMAT(2X,3P10F12.2)
-
-!
-!  DETERMINE ENTRAINMENT RATE BETWEEN KB AND KBCON
-!
-      DO I = 1, IM
-        alpha = alphas
-        if(SLIMSK(I).eq.1.) alpha = alphal
-        IF(CNVFLG(I)) THEN
-          IF(KB(I).EQ.1) THEN
-            DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1)) - ZO(I,1)
-          ELSE
-            DZ = .5 * (ZO(I,KBCON(I)) + ZO(I,KBCON(I)-1))               &
-     &         - .5 * (ZO(I,KB(I)) + ZO(I,KB(I)-1))
-          ENDIF
-          IF(KBCON(I).NE.KB(I)) THEN
-!cmr        XLAMB(I) = -ALOG(ALPHA) / DZ
-            XLAMB(I) = - LOG(ALPHA) / DZ
-          ELSE
-            XLAMB(I) = 0.
-          ENDIF
-        ENDIF
-      ENDDO
-!  DETERMINE UPDRAFT MASS FLUX
-      DO K = 1, KM
-        DO I = 1, IM
-          if (k .le. kmax(i) .and. CNVFLG(I)) then
-            ETA(I,k)  = 1.
-            ETAU(I,k) = 1.
-          ENDIF
-        ENDDO
-      ENDDO
-      DO K = KM1, 2, -1
-        DO I = 1, IM
-          if (k .le. kbmax(i)) then
-            IF(CNVFLG(I).AND.K.LT.KBCON(I).AND.K.GE.KB(I)) THEN
-              DZ        = .5 * (ZO(I,k+1) - ZO(I,k-1))
-              ETA(I,k)  = ETA(I,k+1) * EXP(-XLAMB(I) * DZ)
-              ETAU(I,k) = ETA(I,k)
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-      DO I = 1, IM
-        IF(CNVFLG(I).AND.KB(I).EQ.1.AND.KBCON(I).GT.1) THEN
-          DZ = .5 * (ZO(I,2) - ZO(I,1))
-          ETA(I,1) = ETA(I,2) * EXP(-XLAMB(I) * DZ)
-          ETAU(I,1) = ETA(I,1)
-        ENDIF
-      ENDDO
-!
-!  WORK UP UPDRAFT CLOUD PROPERTIES
-!
-      DO I = 1, IM
-        IF(CNVFLG(I)) THEN
-          INDX         = KB(I)
-          HCKO(I,INDX) = HKBO(I)
-          QCKO(I,INDX) = QKBO(I)
-          UCKO(I,INDX) = UKBO(I)
-          VCKO(I,INDX) = VKBO(I)
-          PWAVO(I)     = 0.
-        ENDIF
-      ENDDO
-!
-!  CLOUD PROPERTY BELOW CLOUD BASE IS MODIFIED BY THE ENTRAINMENT PROCES
-!
-      DO K = 2, KM1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-            IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN
-              FACTOR = ETA(I,k-1) / ETA(I,k)
-              ONEMF = 1. - FACTOR
-              HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF *                &
-     &                    .5 * (HEO(I,k) + HEO(I,k+1))
-              UCKO(I,k) = FACTOR * UCKO(I,k-1) + ONEMF *                & 
-     &                    .5 * (UO(I,k) + UO(I,k+1))
-              VCKO(I,k) = FACTOR * VCKO(I,k-1) + ONEMF *                &
-     &                    .5 * (VO(I,k) + VO(I,k+1))
-              DBYO(I,k) = HCKO(I,k) - HESO(I,k)
-            ENDIF
-            IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN
-              HCKO(I,k) = HCKO(I,k-1)
-              UCKO(I,k) = UCKO(I,k-1)
-              VCKO(I,k) = VCKO(I,k-1)
-              DBYO(I,k) = HCKO(I,k) - HESO(I,k)
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!  DETERMINE CLOUD TOP
-      DO I = 1, IM
-        FLG(I) = CNVFLG(I)
-        KTCON(I) = 1
-      ENDDO
-!     DO K = 2, KMAX
-!       KK = KMAX - K + 1
-!         IF(DBYO(I,kK).GE.0..AND.FLG(I).AND.KK.GT.KBCON(I)) THEN
-!           KTCON(I) = KK + 1
-!           FLG(I) = .FALSE.
-!         ENDIF
-!     ENDDO
-      DO K = 2, KM
-        DO I = 1, IM
-          if (k .le. kmax(i)) then
-            IF(DBYO(I,k).LT.0..AND.FLG(I).AND.K.GT.KBCON(I)) THEN
-              KTCON(I) = K
-              FLG(I) = .FALSE.
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-      DO I = 1, IM
-        IF(CNVFLG(I).AND.(PFLD(I,KBCON(I)) - PFLD(I,KTCON(I))).LT.150.) &
-     &  CNVFLG(I) = .FALSE.
-      ENDDO
-      TOTFLG = .TRUE.
-      DO I = 1, IM
-        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
-      ENDDO
-      IF(TOTFLG) RETURN
-!
-!  SEARCH FOR DOWNDRAFT ORIGINATING LEVEL ABOVE THETA-E MINIMUM
-!
-      DO I = 1, IM
-        HMIN(I) = HEO(I,KBCON(I))
-        LMIN(I) = KBMAX(I)
-        JMIN(I) = KBMAX(I)
-      ENDDO
-      DO I = 1, IM
-        DO K = KBCON(I), KBMAX(I)
-          IF(HEO(I,k).LT.HMIN(I).AND.CNVFLG(I)) THEN
-            LMIN(I) = K + 1
-            HMIN(I) = HEO(I,k)
-          ENDIF
-        ENDDO
-      ENDDO
-!
-!  Make sure that JMIN(I) is within the cloud
-!
-      DO I = 1, IM
-        IF(CNVFLG(I)) THEN
-          JMIN(I) = MIN(LMIN(I),KTCON(I)-1)
-          XMBMAX(I) = .1
-          JMIN(I) = MAX(JMIN(I),KBCON(I)+1)
-        ENDIF
-      ENDDO
-!
-!  ENTRAINING CLOUD
-!
-      do k = 2, km1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-            if(CNVFLG(I).and.k.gt.JMIN(I).and.k.le.KTCON(I)) THEN
-              SUMZ(I,k) = SUMZ(I,k-1) + .5 * (ZO(I,k+1) - ZO(I,k-1))
-              SUMH(I,k) = SUMH(I,k-1) + .5 * (ZO(I,k+1) - ZO(I,k-1))    &
-     &                  * HEO(I,k)
-            ENDIF
-          endif
-        enddo
-      enddo
-!!
-      DO I = 1, IM
-        IF(CNVFLG(I)) THEN
-!         call random_number(XKT2)
-!         call srand(fhour)
-!         XKT2(I) = rand()
-          KT2(I) = nint(XKT2(I)*float(KTCON(I)-JMIN(I))-.5)+JMIN(I)+1
-!         KT2(I) = nint(sqrt(XKT2(I))*float(KTCON(I)-JMIN(I))-.5) + JMIN(I) + 1
-!         KT2(I) = nint(ranf() *float(KTCON(I)-JMIN(I))-.5) + JMIN(I) + 1
-          tem1 = (HCKO(I,JMIN(I)) - HESO(I,KT2(I)))
-          tem2 = (SUMZ(I,KT2(I)) * HESO(I,KT2(I)) - SUMH(I,KT2(I)))
-          if (abs(tem2) .gt. 0.000001) THEN
-            XLAMB(I) = tem1 / tem2
-          else
-            CNVFLG(I) = .false.
-          ENDIF
-!         XLAMB(I) = (HCKO(I,JMIN(I)) - HESO(I,KT2(I)))
-!    &          / (SUMZ(I,KT2(I)) * HESO(I,KT2(I)) - SUMH(I,KT2(I)))
-          XLAMB(I) = max(XLAMB(I),RZERO)
-          XLAMB(I) = min(XLAMB(I),2.3/SUMZ(I,KT2(I)))
-        ENDIF
-      ENDDO
-!!
-      DO I = 1, IM
-       DWNFLG(I)  = CNVFLG(I)
-       DWNFLG2(I) = CNVFLG(I)
-       IF(CNVFLG(I)) THEN
-        if(KT2(I).ge.KTCON(I)) DWNFLG(I) = .false.
-      if(XLAMB(I).le.1.e-30.or.HCKO(I,JMIN(I))-HESO(I,KT2(I)).le.1.e-30)&
-     &  DWNFLG(I) = .false.
-        do k = JMIN(I), KT2(I)
-          if(DWNFLG(I).and.HEO(I,k).gt.HESO(I,KT2(I))) DWNFLG(I)=.false.
-        enddo
-!       IF(CNVFLG(I).AND.(PFLD(KBCON(I))-PFLD(KTCON(I))).GT.PDETRN)
-!    &     DWNFLG(I)=.FALSE.
-        IF(CNVFLG(I).AND.(PFLD(I,KBCON(I))-PFLD(I,KTCON(I))).LT.PDPDWN) &
-     &     DWNFLG2(I)=.FALSE.
-       ENDIF
-      ENDDO
-!!
-      DO K = 2, KM1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-            IF(DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KT2(I)) THEN
-              DZ        = .5 * (ZO(I,k+1) - ZO(I,k-1))
-!             ETA(I,k)  = ETA(I,k-1) * EXP( XLAMB(I) * DZ)
-!  to simplify matter, we will take the linear approach here
-!
-              ETA(I,k)  = ETA(I,k-1) * (1. + XLAMB(I) * dz)
-              ETAU(I,k) = ETAU(I,k-1) * (1. + (XLAMB(I)+xlambu) * dz)
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!!
-      DO K = 2, KM1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-!           IF(.NOT.DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KT2(I)) THEN
-            IF(.NOT.DWNFLG(I).AND.K.GT.JMIN(I).AND.K.LE.KTCON(I)) THEN
-              DZ        = .5 * (ZO(I,k+1) - ZO(I,k-1))
-              ETAU(I,k) = ETAU(I,k-1) * (1. + xlambu * dz)
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!      IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
-!        PRINT *, ' LMIN(I), KT2(I)=', LMIN(I), KT2(I)
-!        PRINT *, ' KBOT, KTOP, JMIN(I) =', KBCON(I), KTCON(I), JMIN(I)
-!      ENDIF
-!     IF(LAT.EQ.LATD.AND.lon.eq.lond) THEN
-!       print *, ' xlamb =', xlamb
-!       print *, ' eta =', (eta(k),k=1,KT2(I))
-!       print *, ' ETAU =', (ETAU(I,k),k=1,KT2(I))
-!       print *, ' HCKO =', (HCKO(I,k),k=1,KT2(I))
-!       print *, ' SUMZ =', (SUMZ(I,k),k=1,KT2(I))
-!       print *, ' SUMH =', (SUMH(I,k),k=1,KT2(I))
-!     ENDIF
-      DO I = 1, IM
-        if(DWNFLG(I)) THEN
-          KTCON(I) = KT2(I)
-        ENDIF
-      ENDDO
-!
-!  CLOUD PROPERTY ABOVE CLOUD Base IS MODIFIED BY THE DETRAINMENT PROCESS
-!
-      DO K = 2, KM1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-!jfe
-            IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN
-!jfe      IF(K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN
-              FACTOR    = ETA(I,k-1) / ETA(I,k)
-              ONEMF     = 1. - FACTOR
-              fuv       = ETAU(I,k-1) / ETAU(I,k)
-              onemfu    = 1. - fuv
-              HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF *                &
-     &                    .5 * (HEO(I,k) + HEO(I,k+1))
-              UCKO(I,k) = fuv * UCKO(I,k-1) + ONEMFu *                  &
-     &                    .5 * (UO(I,k) + UO(I,k+1))
-              VCKO(I,k) = fuv * VCKO(I,k-1) + ONEMFu *                  &
-     &                    .5 * (VO(I,k) + VO(I,k+1))
-              DBYO(I,k) = HCKO(I,k) - HESO(I,k)
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!      IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
-!        PRINT *, ' UCKO=', (UCKO(I,k),k=KBCON(I)+1,KTCON(I))
-!        PRINT *, ' uenv=', (.5*(UO(I,k)+UO(I,k-1)),k=KBCON(I)+1,KTCON(I))
-!      ENDIF
-      DO I = 1, IM
-        if(CNVFLG(I).and.DWNFLG2(I).and.JMIN(I).le.KBCON(I))            &
-     &     THEN
-          CNVFLG(I) = .false.
-          DWNFLG(I) = .false.
-          DWNFLG2(I) = .false.
-        ENDIF
-      ENDDO
-!!
-      TOTFLG = .TRUE.
-      DO I = 1, IM
-        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
-      ENDDO
-      IF(TOTFLG) RETURN
-!!
-!
-!  COMPUTE CLOUD MOISTURE PROPERTY AND PRECIPITATION
-!
-      DO I = 1, IM
-          AA1(I) = 0.
-          RHBAR(I) = 0.
-      ENDDO
-      DO K = 1, KM
-        DO I = 1, IM
-          if (k .le. kmax(i)) then
-            IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN
-              DZ = .5 * (ZO(I,k+1) - ZO(I,k-1))
-              DZ1 = (ZO(I,k) - ZO(I,k-1))
-              GAMMA = EL2ORC * QESO(I,k) / (TO(I,k)**2)
-              QRCH = QESO(I,k)                                          &
-     &             + GAMMA * DBYO(I,k) / (HVAP * (1. + GAMMA))
-              FACTOR = ETA(I,k-1) / ETA(I,k)
-              ONEMF = 1. - FACTOR
-              QCKO(I,k) = FACTOR * QCKO(I,k-1) + ONEMF *                &
-     &                    .5 * (QO(I,k) + QO(I,k+1))
-              DQ = ETA(I,k) * QCKO(I,k) - ETA(I,k) * QRCH
-              RHBAR(I) = RHBAR(I) + QO(I,k) / QESO(I,k)
-!
-!  BELOW LFC CHECK IF THERE IS EXCESS MOISTURE TO RELEASE LATENT HEAT
-!
-              IF(DQ.GT.0.) THEN
-                ETAH = .5 * (ETA(I,k) + ETA(I,k-1))
-                QLK = DQ / (ETA(I,k) + ETAH * C0 * DZ)
-                AA1(I) = AA1(I) - DZ1 * G * QLK
-                QC = QLK + QRCH
-                PWO(I,k) = ETAH * C0 * DZ * QLK
-                QCKO(I,k) = QC
-                PWAVO(I) = PWAVO(I) + PWO(I,k)
-              ENDIF
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-      DO I = 1, IM
-        RHBAR(I) = RHBAR(I) / float(KTCON(I) - KB(I) - 1)
-      ENDDO
-!
-!  this section is ready for cloud water
-!
-      if(ncloud.gt.0) THEN
-!
-!  compute liquid and vapor separation at cloud top
-!
-      DO I = 1, IM
-        k = KTCON(I)
-        IF(CNVFLG(I)) THEN
-          GAMMA = EL2ORC * QESO(I,K) / (TO(I,K)**2)
-          QRCH = QESO(I,K)                                              &
-     &         + GAMMA * DBYO(I,K) / (HVAP * (1. + GAMMA))
-          DQ = QCKO(I,K-1) - QRCH
-!
-!  CHECK IF THERE IS EXCESS MOISTURE TO RELEASE LATENT HEAT
-!
-          IF(DQ.GT.0.) THEN
-            QLKO_KTCON(I) = dq
-            QCKO(I,K-1) = QRCH
-          ENDIF
-        ENDIF
-      ENDDO
-      ENDIF
-!
-!  CALCULATE CLOUD WORK FUNCTION AT T+DT
-!
-      DO K = 1, KM
-        DO I = 1, IM
-          if (k .le. kmax(i)) then
-            IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN
-              DZ1 = ZO(I,k) - ZO(I,k-1)
-              GAMMA = EL2ORC * QESO(I,k-1) / (TO(I,k-1)**2)
-              RFACT =  1. + DELTA * CP * GAMMA                          &
-     &                 * TO(I,k-1) / HVAP
-              AA1(I) = AA1(I) +                                         &
-     &                 DZ1 * (G / (CP * TO(I,k-1)))                     &
-     &                 * DBYO(I,k-1) / (1. + GAMMA)                     &
-     &                 * RFACT
-              val = 0.
-              AA1(I)=AA1(I)+                                            &
-     &                 DZ1 * G * DELTA *                                &
-!cmr &                 MAX( 0.,(QESO(I,k-1) - QO(I,k-1)))               & 
-     &                 MAX(val,(QESO(I,k-1) - QO(I,k-1)))
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-      DO I = 1, IM
-        IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG(I)  = .FALSE.
-        IF(CNVFLG(I).AND.AA1(I).LE.0.) DWNFLG2(I) = .FALSE.
-        IF(CNVFLG(I).AND.AA1(I).LE.0.) CNVFLG(I)  = .FALSE.
-      ENDDO
-!!
-      TOTFLG = .TRUE.
-      DO I = 1, IM
-        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
-      ENDDO
-      IF(TOTFLG) RETURN
-!!
-!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
-!cccc   PRINT *, ' AA1(I) BEFORE DWNDRFT =', AA1(I)
-!cccc ENDIF
-!
-!------- DOWNDRAFT CALCULATIONS
-!
-!
-!--- DETERMINE DOWNDRAFT STRENGTH IN TERMS OF WINDSHEAR
-!
-      DO I = 1, IM
-        IF(CNVFLG(I)) THEN
-          VSHEAR(I) = 0.
-        ENDIF
-      ENDDO
-      DO K = 1, KM
-        DO I = 1, IM
-          if (k .le. kmax(i)) then
-            IF(K.GE.KB(I).AND.K.LE.KTCON(I).AND.CNVFLG(I)) THEN
-              shear=rcs(I) * sqrt((UO(I,k+1)-UO(I,k)) ** 2              &
-     &                          + (VO(I,k+1)-VO(I,k)) ** 2)
-              VSHEAR(I) = VSHEAR(I) + SHEAR
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-      DO I = 1, IM
-        EDT(I) = 0.
-        IF(CNVFLG(I)) THEN
-          KNUMB = KTCON(I) - KB(I) + 1
-          KNUMB = MAX(KNUMB,1)
-          VSHEAR(I) = 1.E3 * VSHEAR(I) / (ZO(I,KTCON(I))-ZO(I,KB(I)))
-          E1=1.591-.639*VSHEAR(I)                                       &
-     &       +.0953*(VSHEAR(I)**2)-.00496*(VSHEAR(I)**3)
-          EDT(I)=1.-E1
-!cmr      EDT(I) = MIN(EDT(I),.9)
-          val =         .9
-          EDT(I) = MIN(EDT(I),val)
-!cmr      EDT(I) = MAX(EDT(I),.0)
-          val =         .0
-          EDT(I) = MAX(EDT(I),val)
-          EDTO(I)=EDT(I)
-          EDTX(I)=EDT(I)
-        ENDIF
-      ENDDO
-!  DETERMINE DETRAINMENT RATE BETWEEN 1 AND KBDTR
-      DO I = 1, IM
-        KBDTR(I) = KBCON(I)
-        beta = betas
-        if(SLIMSK(I).eq.1.) beta = betal
-        IF(CNVFLG(I)) THEN
-          KBDTR(I) = KBCON(I)
-          KBDTR(I) = MAX(KBDTR(I),1)
-          XLAMD(I) = 0.
-          IF(KBDTR(I).GT.1) THEN
-            DZ = .5 * ZO(I,KBDTR(I)) + .5 * ZO(I,KBDTR(I)-1)            &
-     &         - ZO(I,1)
-            XLAMD(I) =  LOG(BETA) / DZ
-          ENDIF
-        ENDIF
-      ENDDO
-!  DETERMINE DOWNDRAFT MASS FLUX
-      DO K = 1, KM
-        DO I = 1, IM
-          IF(k .le. kmax(i)) then
-            IF(CNVFLG(I)) THEN
-              ETAD(I,k) = 1.
-            ENDIF
-            QRCDO(I,k) = 0.
-          endif
-        ENDDO
-      ENDDO
-      DO K = KM1, 2, -1
-        DO I = 1, IM
-          if (k .le. kbmax(i)) then
-            IF(CNVFLG(I).AND.K.LT.KBDTR(I)) THEN
-              DZ        = .5 * (ZO(I,k+1) - ZO(I,k-1))
-              ETAD(I,k) = ETAD(I,k+1) * EXP(XLAMD(I) * DZ)
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-      K = 1
-      DO I = 1, IM
-        IF(CNVFLG(I).AND.KBDTR(I).GT.1) THEN
-          DZ = .5 * (ZO(I,2) - ZO(I,1))
-          ETAD(I,k) = ETAD(I,k+1) * EXP(XLAMD(I) * DZ)
-        ENDIF
-      ENDDO
-!
-!--- DOWNDRAFT MOISTURE PROPERTIES
-!
-      DO I = 1, IM
-        PWEVO(I) = 0.
-        FLG(I) = CNVFLG(I)
-      ENDDO
-      DO I = 1, IM
-        IF(CNVFLG(I)) THEN
-          JMN = JMIN(I)
-          HCDO(I) = HEO(I,JMN)
-          QCDO(I) = QO(I,JMN)
-          QRCDO(I,JMN) = QESO(I,JMN)
-          UCDO(I) = UO(I,JMN)
-          VCDO(I) = VO(I,JMN)
-        ENDIF
-      ENDDO
-      DO K = KM1, 1, -1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-            IF(CNVFLG(I).AND.K.LT.JMIN(I)) THEN
-              DQ = QESO(I,k)
-              DT = TO(I,k)
-              GAMMA      = EL2ORC * DQ / DT**2
-              DH         = HCDO(I) - HESO(I,k)
-              QRCDO(I,k) = DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH
-              DETAD      = ETAD(I,k+1) - ETAD(I,k)
-              PWDO(I,k)  = ETAD(I,k+1) * QCDO(I) -                      &
-     &                     ETAD(I,k) * QRCDO(I,k)
-              PWDO(I,k)  = PWDO(I,k) - DETAD *                          &
-     &                    .5 * (QRCDO(I,k) + QRCDO(I,k+1))
-              QCDO(I)    = QRCDO(I,k)
-              PWEVO(I)   = PWEVO(I) + PWDO(I,k)
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!     IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG(I)) THEN
-!       PRINT *, ' PWAVO(I), PWEVO(I) =', PWAVO(I), PWEVO(I)
-!     ENDIF
-!
-!--- FINAL DOWNDRAFT STRENGTH DEPENDENT ON PRECIP
-!--- EFFICIENCY (EDT), NORMALIZED CONDENSATE (PWAV), AND
-!--- EVAPORATE (PWEV)
-!
-      DO I = 1, IM
-        edtmax = edtmaxl
-        if(SLIMSK(I).eq.0.) edtmax = edtmaxs
-        IF(DWNFLG2(I)) THEN
-          IF(PWEVO(I).LT.0.) THEN
-            EDTO(I) = -EDTO(I) * PWAVO(I) / PWEVO(I)
-            EDTO(I) = MIN(EDTO(I),EDTMAX)
-          ELSE
-            EDTO(I) = 0.
-          ENDIF
-        ELSE
-          EDTO(I) = 0.
-        ENDIF
-      ENDDO
-!
-!
-!--- DOWNDRAFT CLOUDWORK FUNCTIONS
-!
-!
-      DO K = KM1, 1, -1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-            IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN
-              GAMMA = EL2ORC * QESO(I,k+1) / TO(I,k+1)**2
-              DHH=HCDO(I)
-              DT=TO(I,k+1)
-              DG=GAMMA
-              DH=HESO(I,k+1)
-              DZ=-1.*(ZO(I,k+1)-ZO(I,k))
-              AA1(I)=AA1(I)+EDTO(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG))   &
-     &               *(1.+DELTA*CP*DG*DT/HVAP)
-              val=0.
-              AA1(I)=AA1(I)+EDTO(I)*                                    & 
-!cmr &        DZ*G*DELTA*MAX( 0.,(QESO(I,k+1)-QO(I,k+1)))               &
-     &        DZ*G*DELTA*MAX(val,(QESO(I,k+1)-QO(I,k+1)))
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG2(I)) THEN
-!cccc   PRINT *, '  AA1(I) AFTER DWNDRFT =', AA1(I)
-!cccc ENDIF
-      DO I = 1, IM
-        IF(AA1(I).LE.0.) CNVFLG(I)  = .FALSE.
-        IF(AA1(I).LE.0.) DWNFLG(I)  = .FALSE.
-        IF(AA1(I).LE.0.) DWNFLG2(I) = .FALSE.
-      ENDDO
-!!
-      TOTFLG = .TRUE.
-      DO I = 1, IM
-        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
-      ENDDO
-      IF(TOTFLG) RETURN
-!!
-!
-!
-!--- WHAT WOULD THE CHANGE BE, THAT A CLOUD WITH UNIT MASS
-!--- WILL DO TO THE ENVIRONMENT?
-!
-      DO K = 1, KM
-        DO I = 1, IM
-          IF(k .le. kmax(i) .and. CNVFLG(I)) THEN
-            DELLAH(I,k) = 0.
-            DELLAQ(I,k) = 0.
-            DELLAU(I,k) = 0.
-            DELLAV(I,k) = 0.
-          ENDIF
-        ENDDO
-      ENDDO
-      DO I = 1, IM
-        IF(CNVFLG(I)) THEN
-          DP = 1000. * DEL(I,1)
-          DELLAH(I,1) = EDTO(I) * ETAD(I,1) * (HCDO(I)                  &
-     &                - HEO(I,1)) * G / DP
-          DELLAQ(I,1) = EDTO(I) * ETAD(I,1) * (QCDO(I)                  &
-     &                - QO(I,1)) * G / DP
-          DELLAU(I,1) = EDTO(I) * ETAD(I,1) * (UCDO(I)                  &
-     &                - UO(I,1)) * G / DP
-          DELLAV(I,1) = EDTO(I) * ETAD(I,1) * (VCDO(I)                  &
-     &                - VO(I,1)) * G / DP
-        ENDIF
-      ENDDO
-!
-!--- CHANGED DUE TO SUBSIDENCE AND ENTRAINMENT
-!
-      DO K = 2, KM1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-            IF(CNVFLG(I).AND.K.LT.KTCON(I)) THEN
-              AUP = 1.
-              IF(K.LE.KB(I)) AUP = 0.
-              ADW = 1.
-              IF(K.GT.JMIN(I)) ADW = 0.
-              DV1= HEO(I,k)
-              DV2 = .5 * (HEO(I,k) + HEO(I,k+1))
-              DV3= HEO(I,k-1)
-              DV1Q= QO(I,k)
-              DV2Q = .5 * (QO(I,k) + QO(I,k+1))
-              DV3Q= QO(I,k-1)
-              DV1U= UO(I,k)
-              DV2U = .5 * (UO(I,k) + UO(I,k+1))
-              DV3U= UO(I,k-1)
-              DV1V= VO(I,k)
-              DV2V = .5 * (VO(I,k) + VO(I,k+1))
-              DV3V= VO(I,k-1)
-              DP = 1000. * DEL(I,K)
-              DZ = .5 * (ZO(I,k+1) - ZO(I,k-1))
-              DETA = ETA(I,k) - ETA(I,k-1)
-              DETAD = ETAD(I,k) - ETAD(I,k-1)
-              DELLAH(I,k) = DELLAH(I,k) +                               &
-     &            ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1   &
-     &        - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3   &
-     &                    - AUP * DETA * DV2                            &
-     &                    + ADW * EDTO(I) * DETAD * HCDO(I)) * G / DP
-              DELLAQ(I,k) = DELLAQ(I,k) +                               &
-     &            ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1Q  &
-     &        - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3Q  &
-     &                    - AUP * DETA * DV2Q                           &
-     &       +ADW*EDTO(I)*DETAD*.5*(QRCDO(I,k)+QRCDO(I,k-1))) * G / DP
-              DELLAU(I,k) = DELLAU(I,k) +                               &
-     &            ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1U  &
-     &        - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3U  &
-     &                     - AUP * DETA * DV2U                          &
-     &                    + ADW * EDTO(I) * DETAD * UCDO(I)             & 
-     &                    ) * G / DP
-              DELLAV(I,k) = DELLAV(I,k) +                               &
-     &            ((AUP * ETA(I,k) - ADW * EDTO(I) * ETAD(I,k)) * DV1V  &
-     &        - (AUP * ETA(I,k-1) - ADW * EDTO(I) * ETAD(I,k-1))* DV3V  &
-     &                     - AUP * DETA * DV2V                          &
-     &                    + ADW * EDTO(I) * DETAD * VCDO(I)             &
-     &                    ) * G / DP
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!
-!------- CLOUD TOP
-!
-      DO I = 1, IM
-        IF(CNVFLG(I)) THEN
-          INDX = KTCON(I)
-          DP = 1000. * DEL(I,INDX)
-          DV1 = HEO(I,INDX-1)
-          DELLAH(I,INDX) = ETA(I,INDX-1) *                              &
-     &                     (HCKO(I,INDX-1) - DV1) * G / DP
-          DVQ1 = QO(I,INDX-1) 
-          DELLAQ(I,INDX) = ETA(I,INDX-1) *                              &
-     &                     (QCKO(I,INDX-1) - DVQ1) * G / DP
-          DV1U = UO(I,INDX-1)
-          DELLAU(I,INDX) = ETA(I,INDX-1) *                              &
-     &                     (UCKO(I,INDX-1) - DV1U) * G / DP
-          DV1V = VO(I,INDX-1)
-          DELLAV(I,INDX) = ETA(I,INDX-1) *                              &
-     &                     (VCKO(I,INDX-1) - DV1V) * G / DP
-!
-!  cloud water
-!
-          DELLAL(I) = ETA(I,INDX-1) * QLKO_KTCON(I) * g / dp
-        ENDIF
-      ENDDO
-!
-!------- FINAL CHANGED VARIABLE PER UNIT MASS FLUX
-!
-      DO K = 1, KM
-        DO I = 1, IM
-          if (k .le. kmax(i)) then
-            IF(CNVFLG(I).and.k.gt.KTCON(I)) THEN
-              QO(I,k) = Q1(I,k)
-              TO(I,k) = T1(I,k)
-              UO(I,k) = U1(I,k)
-              VO(I,k) = V1(I,k)
-            ENDIF
-            IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN
-              QO(I,k) = DELLAQ(I,k) * MBDT + Q1(I,k)
-              DELLAT = (DELLAH(I,k) - HVAP * DELLAQ(I,k)) / CP
-              TO(I,k) = DELLAT * MBDT + T1(I,k)
-!cmr          QO(I,k) = max(QO(I,k),1.e-10)
-              val   =           1.e-10
-              QO(I,k) = max(QO(I,k), val  )
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!--- THE ABOVE CHANGED ENVIRONMENT IS NOW USED TO CALULATE THE
-!--- EFFECT THE ARBITRARY CLOUD (WITH UNIT MASS FLUX)
-!--- WOULD HAVE ON THE STABILITY,
-!--- WHICH THEN IS USED TO CALCULATE THE REAL MASS FLUX,
-!--- NECESSARY TO KEEP THIS CHANGE IN BALANCE WITH THE LARGE-SCALE
-!--- DESTABILIZATION.
-!
-!--- ENVIRONMENTAL CONDITIONS AGAIN, FIRST HEIGHTS
-!
-      DO K = 1, KM
-        DO I = 1, IM
-          IF(k .le. kmax(i) .and. CNVFLG(I)) THEN
-!jfe        QESO(I,k) = 10. * FPVS(TO(I,k))
-!
-            QESO(I,k) = 0.01 * fpvs(TO(I,K))      ! fpvs is in Pa
-!
-            QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k)+EPSM1*QESO(I,k))
-!cmr        QESO(I,k) = MAX(QESO(I,k),1.E-8)
-            val       =             1.E-8
-            QESO(I,k) = MAX(QESO(I,k), val )
-            TVO(I,k)  = TO(I,k) + DELTA * TO(I,k) * QO(I,k)
-          ENDIF
-        ENDDO
-      ENDDO
-      DO I = 1, IM
-        IF(CNVFLG(I)) THEN
-          XAA0(I) = 0.
-          XPWAV(I) = 0.
-        ENDIF
-      ENDDO
-!
-!  HYDROSTATIC HEIGHT ASSUME ZERO TERR
-!
-!     DO I = 1, IM
-!       IF(CNVFLG(I)) THEN
-!         DLNSIG =  LOG(PRSL(I,1)/PS(I))
-!         ZO(I,1) = TERR - DLNSIG * RD / G * TVO(I,1)
-!       ENDIF
-!     ENDDO
-!     DO K = 2, KM
-!       DO I = 1, IM
-!         IF(k .le. kmax(i) .and. CNVFLG(I)) THEN
-!           DLNSIG =  LOG(PRSL(I,K) / PRSL(I,K-1))
-!           ZO(I,k) = ZO(I,k-1) - DLNSIG * RD / G
-!    &             * .5 * (TVO(I,k) + TVO(I,k-1))
-!         ENDIF
-!       ENDDO
-!     ENDDO
-!
-!--- MOIST STATIC ENERGY
-!
-      DO K = 1, KM1
-        DO I = 1, IM
-          IF(k .le. kmax(i)-1 .and. CNVFLG(I)) THEN
-            DZ = .5 * (ZO(I,k+1) - ZO(I,k))
-            DP = .5 * (PFLD(I,k+1) - PFLD(I,k))
-!jfe        ES = 10. * FPVS(TO(I,k+1))
-!
-            ES = 0.01 * fpvs(TO(I,K+1))      ! fpvs is in Pa
-!
-            PPRIME = PFLD(I,k+1) + EPSM1 * ES
-            QS = EPS * ES / PPRIME
-            DQSDP = - QS / PPRIME
-            DESDT = ES * (FACT1 / TO(I,k+1) + FACT2 / (TO(I,k+1)**2))
-            DQSDT = QS * PFLD(I,k+1) * DESDT / (ES * PPRIME)
-            GAMMA = EL2ORC * QESO(I,k+1) / (TO(I,k+1)**2)
-            DT = (G * DZ + HVAP * DQSDP * DP) / (CP * (1. + GAMMA))
-            DQ = DQSDT * DT + DQSDP * DP
-            TO(I,k) = TO(I,k+1) + DT
-            QO(I,k) = QO(I,k+1) + DQ
-            PO(I,k) = .5 * (PFLD(I,k) + PFLD(I,k+1))
-          ENDIF
-        ENDDO
-      ENDDO
-      DO K = 1, KM1
-        DO I = 1, IM
-          IF(k .le. kmax(i)-1 .and. CNVFLG(I)) THEN
-!jfe        QESO(I,k) = 10. * FPVS(TO(I,k))
-!
-            QESO(I,k) = 0.01 * fpvs(TO(I,K))      ! fpvs is in Pa
-!
-            QESO(I,k) = EPS * QESO(I,k) / (PO(I,k) + EPSM1 * QESO(I,k))
-!cmr        QESO(I,k) = MAX(QESO(I,k),1.E-8)
-            val1      =             1.E-8
-            QESO(I,k) = MAX(QESO(I,k), val1)
-!cmr        QO(I,k)   = max(QO(I,k),1.e-10)
-            val2      =           1.e-10
-            QO(I,k)   = max(QO(I,k), val2 )
-!           QO(I,k)   = MIN(QO(I,k),QESO(I,k))
-            HEO(I,k)   = .5 * G * (ZO(I,k) + ZO(I,k+1)) +               &
-     &                    CP * TO(I,k) + HVAP * QO(I,k)
-            HESO(I,k) = .5 * G * (ZO(I,k) + ZO(I,k+1)) +                &
-     &                  CP * TO(I,k) + HVAP * QESO(I,k)
-          ENDIF
-        ENDDO
-      ENDDO
-      DO I = 1, IM
-        k = kmax(i)
-        IF(CNVFLG(I)) THEN
-          HEO(I,k) = G * ZO(I,k) + CP * TO(I,k) + HVAP * QO(I,k)
-          HESO(I,k) = G * ZO(I,k) + CP * TO(I,k) + HVAP * QESO(I,k)
-!         HEO(I,k) = MIN(HEO(I,k),HESO(I,k))
-        ENDIF
-      ENDDO
-      DO I = 1, IM
-        IF(CNVFLG(I)) THEN
-          INDX = KB(I)
-          XHKB(I) = HEO(I,INDX)
-          XQKB(I) = QO(I,INDX)
-          HCKO(I,INDX) = XHKB(I)
-          QCKO(I,INDX) = XQKB(I)
-        ENDIF
-      ENDDO
-!
-!
-!**************************** STATIC CONTROL
-!
-!
-!------- MOISTURE AND CLOUD WORK FUNCTIONS
-!
-      DO K = 2, KM1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-!           IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KBCON(I)) THEN
-            IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LE.KTCON(I)) THEN
-              FACTOR = ETA(I,k-1) / ETA(I,k)
-              ONEMF = 1. - FACTOR
-              HCKO(I,k) = FACTOR * HCKO(I,k-1) + ONEMF *                &
-     &                    .5 * (HEO(I,k) + HEO(I,k+1))
-            ENDIF
-!           IF(CNVFLG(I).AND.K.GT.KBCON(I)) THEN
-!             HEO(I,k) = HEO(I,k-1)
-!           ENDIF
-          endif
-        ENDDO
-      ENDDO
-      DO K = 2, KM1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-            IF(CNVFLG(I).AND.K.GT.KB(I).AND.K.LT.KTCON(I)) THEN
-              DZ = .5 * (ZO(I,k+1) - ZO(I,k-1))
-              GAMMA = EL2ORC * QESO(I,k) / (TO(I,k)**2)
-              XDBY = HCKO(I,k) - HESO(I,k)
-!cmr          XDBY = MAX(XDBY,0.)
-              val  =          0.
-              XDBY = MAX(XDBY,val)
-              XQRCH = QESO(I,k)                                         &
-     &              + GAMMA * XDBY / (HVAP * (1. + GAMMA))
-              FACTOR = ETA(I,k-1) / ETA(I,k)
-              ONEMF = 1. - FACTOR
-              QCKO(I,k) = FACTOR * QCKO(I,k-1) + ONEMF *                &
-     &                    .5 * (QO(I,k) + QO(I,k+1))
-              DQ = ETA(I,k) * QCKO(I,k) - ETA(I,k) * XQRCH
-              IF(DQ.GT.0.) THEN
-                ETAH = .5 * (ETA(I,k) + ETA(I,k-1))
-                QLK = DQ / (ETA(I,k) + ETAH * C0 * DZ)
-                XAA0(I) = XAA0(I) - (ZO(I,k) - ZO(I,k-1)) * G * QLK
-                XQC = QLK + XQRCH
-                XPW = ETAH * C0 * DZ * QLK
-                QCKO(I,k) = XQC
-                XPWAV(I) = XPWAV(I) + XPW
-              ENDIF
-            ENDIF
-!           IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LT.KTCON(I)) THEN
-            IF(CNVFLG(I).AND.K.GT.KBCON(I).AND.K.LE.KTCON(I)) THEN
-              DZ1 = ZO(I,k) - ZO(I,k-1)
-              GAMMA = EL2ORC * QESO(I,k-1) / (TO(I,k-1)**2)
-              RFACT =  1. + DELTA * CP * GAMMA                          &
-     &                 * TO(I,k-1) / HVAP
-              XDBY = HCKO(I,k-1) - HESO(I,k-1)
-              XAA0(I) = XAA0(I)                                         & 
-     &                + DZ1 * (G / (CP * TO(I,k-1)))                    &
-     &                * XDBY / (1. + GAMMA)                             &
-     &                * RFACT
-              val=0.
-              XAA0(I)=XAA0(I)+                                          &
-     &                 DZ1 * G * DELTA *                                &
-!cmr &                 MAX( 0.,(QESO(I,k-1) - QO(I,k-1)))               & 
-     &                 MAX(val,(QESO(I,k-1) - QO(I,k-1)))
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
-!cccc   PRINT *, ' XAA BEFORE DWNDRFT =', XAA0(I)
-!cccc ENDIF
-!
-!------- DOWNDRAFT CALCULATIONS
-!
-!
-!--- DOWNDRAFT MOISTURE PROPERTIES
-!
-      DO I = 1, IM
-        XPWEV(I) = 0.
-      ENDDO
-      DO I = 1, IM
-        IF(DWNFLG2(I)) THEN
-          JMN = JMIN(I)
-          XHCD(I) = HEO(I,JMN)
-          XQCD(I) = QO(I,JMN)
-          QRCD(I,JMN) = QESO(I,JMN)
-        ENDIF
-      ENDDO
-      DO K = KM1, 1, -1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-            IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN
-              DQ = QESO(I,k)
-              DT = TO(I,k)
-              GAMMA    = EL2ORC * DQ / DT**2
-              DH       = XHCD(I) - HESO(I,k)
-              QRCD(I,k)=DQ+(1./HVAP)*(GAMMA/(1.+GAMMA))*DH
-              DETAD    = ETAD(I,k+1) - ETAD(I,k)
-              XPWD     = ETAD(I,k+1) * QRCD(I,k+1) -                    &
-     &                   ETAD(I,k) * QRCD(I,k)
-              XPWD     = XPWD - DETAD *                                 & 
-     &                 .5 * (QRCD(I,k) + QRCD(I,k+1))
-              XPWEV(I) = XPWEV(I) + XPWD
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!
-      DO I = 1, IM
-        edtmax = edtmaxl
-        if(SLIMSK(I).eq.0.) edtmax = edtmaxs
-        IF(DWNFLG2(I)) THEN
-          IF(XPWEV(I).GE.0.) THEN
-            EDTX(I) = 0.
-          ELSE
-            EDTX(I) = -EDTX(I) * XPWAV(I) / XPWEV(I)
-            EDTX(I) = MIN(EDTX(I),EDTMAX)
-          ENDIF
-        ELSE
-          EDTX(I) = 0.
-        ENDIF
-      ENDDO
-!
-!
-!
-!--- DOWNDRAFT CLOUDWORK FUNCTIONS
-!
-!
-      DO K = KM1, 1, -1
-        DO I = 1, IM
-          if (k .le. kmax(i)-1) then
-            IF(DWNFLG2(I).AND.K.LT.JMIN(I)) THEN
-              GAMMA = EL2ORC * QESO(I,k+1) / TO(I,k+1)**2
-              DHH=XHCD(I)
-              DT= TO(I,k+1)
-              DG= GAMMA
-              DH= HESO(I,k+1)
-              DZ=-1.*(ZO(I,k+1)-ZO(I,k))
-              XAA0(I)=XAA0(I)+EDTX(I)*DZ*(G/(CP*DT))*((DHH-DH)/(1.+DG)) &
-     &                *(1.+DELTA*CP*DG*DT/HVAP)
-              val=0.
-              XAA0(I)=XAA0(I)+EDTX(I)*                                  &
-!cmr &        DZ*G*DELTA*MAX( 0.,(QESO(I,k+1)-QO(I,k+1)))               &
-     &        DZ*G*DELTA*MAX(val,(QESO(I,k+1)-QO(I,k+1)))
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!cccc IF(LAT.EQ.LATD.AND.lon.eq.lond.and.DWNFLG2(I)) THEN
-!cccc   PRINT *, '  XAA AFTER DWNDRFT =', XAA0(I)
-!cccc ENDIF
-!
-!  CALCULATE CRITICAL CLOUD WORK FUNCTION
-!
-      DO I = 1, IM
-        ACRT(I) = 0.
-        IF(CNVFLG(I)) THEN
-!       IF(CNVFLG(I).AND.SLIMSK(I).NE.1.) THEN
-          IF(PFLD(I,KTCON(I)).LT.PCRIT(15))THEN
-            ACRT(I)=ACRIT(15)*(975.-PFLD(I,KTCON(I)))                   &    
-     &              /(975.-PCRIT(15))
-          ELSE IF(PFLD(I,KTCON(I)).GT.PCRIT(1))THEN
-            ACRT(I)=ACRIT(1)
-          ELSE
-!cmr        K = IFIX((850. - PFLD(I,KTCON(I)))/50.) + 2
-            K =  int((850. - PFLD(I,KTCON(I)))/50.) + 2
-            K = MIN(K,15)
-            K = MAX(K,2)
-            ACRT(I)=ACRIT(K)+(ACRIT(K-1)-ACRIT(K))*                     &
-     &           (PFLD(I,KTCON(I))-PCRIT(K))/(PCRIT(K-1)-PCRIT(K))
-           ENDIF
-!        ELSE
-!          ACRT(I) = .5 * (PFLD(I,KBCON(I)) - PFLD(I,KTCON(I)))
-         ENDIF
-      ENDDO
-      DO I = 1, IM
-        ACRTFCT(I) = 1.
-        IF(CNVFLG(I)) THEN
-          if(SLIMSK(I).eq.1.) THEN
-            w1 = w1l
-            w2 = w2l
-            w3 = w3l
-            w4 = w4l
-          else
-            w1 = w1s
-            w2 = w2s
-            w3 = w3s
-            w4 = w4s
-          ENDIF
-!C       IF(CNVFLG(I).AND.SLIMSK(I).EQ.1.) THEN
-!         ACRTFCT(I) = PDOT(I) / W3
-!
-!  modify critical cloud workfunction by cloud base vertical velocity
-!
-          IF(PDOT(I).LE.W4) THEN
-            ACRTFCT(I) = (PDOT(I) - W4) / (W3 - W4)
-          ELSEIF(PDOT(I).GE.-W4) THEN
-            ACRTFCT(I) = - (PDOT(I) + W4) / (W4 - W3)
-          ELSE
-            ACRTFCT(I) = 0.
-          ENDIF
-!cmr      ACRTFCT(I) = MAX(ACRTFCT(I),-1.)
-          val1    =             -1.
-          ACRTFCT(I) = MAX(ACRTFCT(I),val1)
-!cmr      ACRTFCT(I) = MIN(ACRTFCT(I),1.)
-          val2    =             1.
-          ACRTFCT(I) = MIN(ACRTFCT(I),val2)
-          ACRTFCT(I) = 1. - ACRTFCT(I)
-!
-!  modify ACRTFCT(I) by colume mean rh if RHBAR(I) is greater than 80 percent
-!
-!         if(RHBAR(I).ge..8) THEN
-!           ACRTFCT(I) = ACRTFCT(I) * (.9 - min(RHBAR(I),.9)) * 10.
-!         ENDIF
-!
-!  modify adjustment time scale by cloud base vertical velocity
-!
-          DTCONV(I) = DT2 + max((1800. - DT2),RZERO) *                  &
-     &                (PDOT(I) - W2) / (W1 - W2)
-!         DTCONV(I) = MAX(DTCONV(I), DT2)
-!         DTCONV(I) = 1800. * (PDOT(I) - w2) / (w1 - w2)
-          DTCONV(I) = max(DTCONV(I),dtmin)
-          DTCONV(I) = min(DTCONV(I),dtmax)
-
-        ENDIF
-      ENDDO
-!
-!--- LARGE SCALE FORCING
-!
-      DO I= 1, IM
-        FLG(I) = CNVFLG(I)
-        IF(CNVFLG(I)) THEN
-!         F = AA1(I) / DTCONV(I)
-          FLD(I) = (AA1(I) - ACRT(I) * ACRTFCT(I)) / DTCONV(I)
-          IF(FLD(I).LE.0.) FLG(I) = .FALSE.
-        ENDIF
-        CNVFLG(I) = FLG(I)
-        IF(CNVFLG(I)) THEN
-!         XAA0(I) = MAX(XAA0(I),0.)
-          XK(I) = (XAA0(I) - AA1(I)) / MBDT
-          IF(XK(I).GE.0.) FLG(I) = .FALSE.
-        ENDIF
-!
-!--- KERNEL, CLOUD BASE MASS FLUX
-!
-        CNVFLG(I) = FLG(I)
-        IF(CNVFLG(I)) THEN
-          XMB(I) = -FLD(I) / XK(I)
-          XMB(I) = MIN(XMB(I),XMBMAX(I))
-        ENDIF
-      ENDDO
-!      IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I)) THEN
-!        print *, ' RHBAR(I), ACRTFCT(I) =', RHBAR(I), ACRTFCT(I)
-!        PRINT *, '  A1, XA =', AA1(I), XAA0(I)
-!        PRINT *, ' XMB(I), ACRT =', XMB(I), ACRT
-!      ENDIF
-      TOTFLG = .TRUE.
-      DO I = 1, IM
-        TOTFLG = TOTFLG .AND. (.NOT. CNVFLG(I))
-      ENDDO
-      IF(TOTFLG) RETURN
-!
-!  restore t0 and QO to t1 and q1 in case convection stops
-!
-      do k = 1, km
-        DO I = 1, IM
-          if (k .le. kmax(i)) then
-            TO(I,k) = T1(I,k)
-            QO(I,k) = Q1(I,k)
-!jfe        QESO(I,k) = 10. * FPVS(T1(I,k))
-!
-            QESO(I,k) = 0.01 * fpvs(T1(I,K))      ! fpvs is in Pa
-!
-            QESO(I,k) = EPS * QESO(I,k) / (PFLD(I,k) + EPSM1*QESO(I,k))
-!cmr        QESO(I,k) = MAX(QESO(I,k),1.E-8)
-            val     =             1.E-8
-            QESO(I,k) = MAX(QESO(I,k), val )
-          endif
-        enddo
-      enddo
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!
-!--- FEEDBACK: SIMPLY THE CHANGES FROM THE CLOUD WITH UNIT MASS FLUX
-!---           MULTIPLIED BY  THE MASS FLUX NECESSARY TO KEEP THE
-!---           EQUILIBRIUM WITH THE LARGER-SCALE.
-!
-      DO I = 1, IM
-        DELHBAR(I) = 0.
-        DELQBAR(I) = 0.
-        DELTBAR(I) = 0.
-        QCOND(I) = 0.
-      ENDDO
-      DO K = 1, KM
-        DO I = 1, IM
-          if (k .le. kmax(i)) then
-            IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN
-              AUP = 1.
-              IF(K.Le.KB(I)) AUP = 0.
-              ADW = 1.
-              IF(K.GT.JMIN(I)) ADW = 0.
-              DELLAT = (DELLAH(I,k) - HVAP * DELLAQ(I,k)) / CP
-              T1(I,k) = T1(I,k) + DELLAT * XMB(I) * DT2
-              Q1(I,k) = Q1(I,k) + DELLAQ(I,k) * XMB(I) * DT2
-              U1(I,k) = U1(I,k) + DELLAU(I,k) * XMB(I) * DT2
-              V1(I,k) = V1(I,k) + DELLAV(I,k) * XMB(I) * DT2
-              DP = 1000. * DEL(I,K)
-              DELHBAR(I) = DELHBAR(I) + DELLAH(I,k)*XMB(I)*DP/G
-              DELQBAR(I) = DELQBAR(I) + DELLAQ(I,k)*XMB(I)*DP/G
-              DELTBAR(I) = DELTBAR(I) + DELLAT*XMB(I)*DP/G
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-      DO K = 1, KM
-        DO I = 1, IM
-          if (k .le. kmax(i)) then
-            IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN
-!jfe          QESO(I,k) = 10. * FPVS(T1(I,k))
-!
-              QESO(I,k) = 0.01 * fpvs(T1(I,K))      ! fpvs is in Pa
-!
-              QESO(I,k) = EPS * QESO(I,k)/(PFLD(I,k) + EPSM1*QESO(I,k))
-!cmr          QESO(I,k) = MAX(QESO(I,k),1.E-8)
-              val     =             1.E-8
-              QESO(I,k) = MAX(QESO(I,k), val )
-!
-!  cloud water
-!
-              if(ncloud.gt.0.and.CNVFLG(I).and.k.eq.KTCON(I)) THEN
-                tem  = DELLAL(I) * XMB(I) * dt2
-                tem1 = MAX(RZERO, MIN(RONE, (TCR-t1(I,K))*TCRF))
-                if (QL(I,k,2) .gt. -999.0) then
-                  QL(I,k,1) = QL(I,k,1) + tem * tem1            ! Ice
-                  QL(I,k,2) = QL(I,k,2) + tem *(1.0-tem1)       ! Water
-                else
-                  tem2      = QL(I,k,1) + tem
-                  QL(I,k,1) = tem2 * tem1                       ! Ice
-                  QL(I,k,2) = tem2 - QL(I,k,1)                  ! Water
-                endif
-!               QL(I,k) = QL(I,k) + DELLAL(I) * XMB(I) * dt2
-                dp = 1000. * del(i,k)
-                DELLAL(I) = DELLAL(I) * XMB(I) * dp / g
-              ENDIF
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!     IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I) ) THEN
-!       PRINT *, ' DELHBAR, DELQBAR, DELTBAR ='
-!       PRINT *, DELHBAR, HVAP*DELQBAR, CP*DELTBAR
-!       PRINT *, '   DELLBAR ='
-!       PRINT 6003,  HVAP*DELLbar
-!       PRINT *, '   DELLAQ ='
-!       PRINT 6003, (HVAP*DELLAQ(I,k)*XMB(I),K=1,KMAX)
-!       PRINT *, '   DELLAT ='
-!       PRINT 6003, (DELLAH(i,k)*XMB(I)-HVAP*DELLAQ(I,k)*XMB(I),         &
-!    &               K=1,KMAX)
-!     ENDIF
-      DO I = 1, IM
-        RNTOT(I) = 0.
-        DELQEV(I) = 0.
-        DELQ2(I) = 0.
-        FLG(I) = CNVFLG(I)
-      ENDDO
-      DO K = KM, 1, -1
-        DO I = 1, IM
-          if (k .le. kmax(i)) then
-            IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN
-              AUP = 1.
-              IF(K.Le.KB(I)) AUP = 0.
-              ADW = 1.
-              IF(K.GT.JMIN(I)) ADW = 0.
-              rain =  AUP * PWO(I,k) + ADW * EDTO(I) * PWDO(I,k)
-              RNTOT(I) = RNTOT(I) + rain * XMB(I) * .001 * dt2
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-      DO K = KM, 1, -1
-        DO I = 1, IM
-          if (k .le. kmax(i)) then
-            DELTV(I) = 0.
-            DELQ(I) = 0.
-            QEVAP(I) = 0.
-            IF(CNVFLG(I).AND.K.LE.KTCON(I)) THEN
-              AUP = 1.
-              IF(K.Le.KB(I)) AUP = 0.
-              ADW = 1.
-              IF(K.GT.JMIN(I)) ADW = 0.
-              rain =  AUP * PWO(I,k) + ADW * EDTO(I) * PWDO(I,k)
-              RN(I) = RN(I) + rain * XMB(I) * .001 * dt2
-            ENDIF
-            IF(FLG(I).AND.K.LE.KTCON(I)) THEN
-              evef = EDT(I) * evfact
-              if(SLIMSK(I).eq.1.) evef=EDT(I) * evfactl
-!             if(SLIMSK(I).eq.1.) evef=.07
-!             if(SLIMSK(I).ne.1.) evef = 0.
-              QCOND(I) = EVEF * (Q1(I,k) - QESO(I,k))                   &
-     &                 / (1. + EL2ORC * QESO(I,k) / T1(I,k)**2)
-              DP = 1000. * DEL(I,K)
-              IF(RN(I).GT.0..AND.QCOND(I).LT.0.) THEN
-                QEVAP(I) = -QCOND(I) * (1.-EXP(-.32*SQRT(DT2*RN(I))))
-                QEVAP(I) = MIN(QEVAP(I), RN(I)*1000.*G/DP)
-                DELQ2(I) = DELQEV(I) + .001 * QEVAP(I) * dp / g
-              ENDIF
-              if(RN(I).gt.0..and.QCOND(I).LT.0..and.                    &
-     &           DELQ2(I).gt.RNTOT(I)) THEN
-                QEVAP(I) = 1000.* g * (RNTOT(I) - DELQEV(I)) / dp
-                FLG(I) = .false.
-              ENDIF
-              IF(RN(I).GT.0..AND.QEVAP(I).gt.0.) THEN
-                Q1(I,k) = Q1(I,k) + QEVAP(I)
-                T1(I,k) = T1(I,k) - ELOCP * QEVAP(I)
-                RN(I) = RN(I) - .001 * QEVAP(I) * DP / G
-                DELTV(I) = - ELOCP*QEVAP(I)/DT2
-                DELQ(I) =  + QEVAP(I)/DT2
-                DELQEV(I) = DELQEV(I) + .001*dp*QEVAP(I)/g
-              ENDIF
-              DELLAQ(I,k) = DELLAQ(I,k) + DELQ(I) / XMB(I)
-              DELQBAR(I) = DELQBAR(I) + DELQ(I)*DP/G
-              DELTBAR(I) = DELTBAR(I) + DELTV(I)*DP/G
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!      IF(LAT.EQ.LATD.AND.lon.eq.lond.and.CNVFLG(I) ) THEN
-!        PRINT *, '   DELLAH ='
-!        PRINT 6003, (DELLAH(k)*XMB(I),K=1,KMAX)
-!        PRINT *, '   DELLAQ ='
-!        PRINT 6003, (HVAP*DELLAQ(I,k)*XMB(I),K=1,KMAX)
-!        PRINT *, ' DELHBAR, DELQBAR, DELTBAR ='
-!        PRINT *, DELHBAR, HVAP*DELQBAR, CP*DELTBAR
-!        PRINT *, ' PRECIP =', HVAP*RN(I)*1000./DT2
-!CCCC   PRINT *, '   DELLBAR ='
-!CCCC   PRINT *,  HVAP*DELLbar
-!      ENDIF
-!
-!  PRECIPITATION RATE CONVERTED TO ACTUAL PRECIP
-!  IN UNIT OF M INSTEAD OF KG
-!
-      DO I = 1, IM
-        IF(CNVFLG(I)) THEN
-!
-!  IN THE EVENT OF UPPER LEVEL RAIN EVAPORATION AND LOWER LEVEL DOWNDRAF
-!    MOISTENING, RN CAN BECOME NEGATIVE, IN THIS CASE, WE BACK OUT OF TH
-!    HEATING AND THE MOISTENING
-!
-          if(RN(I).lt.0..and..not.FLG(I)) RN(I) = 0.
-          IF(RN(I).LE.0.) THEN
-            RN(I) = 0.
-          ELSE
-            KTOP(I) = KTCON(I)
-            KBOT(I) = KBCON(I)
-            KUO(I) = 1
-            CLDWRK(I) = AA1(I)
-          ENDIF
-        ENDIF
-      ENDDO
-      DO K = 1, KM
-        DO I = 1, IM
-          if (k .le. kmax(i)) then
-            IF(CNVFLG(I).AND.RN(I).LE.0.) THEN
-              T1(I,k) = TO(I,k)
-              Q1(I,k) = QO(I,k)
-            ENDIF
-          endif
-        ENDDO
-      ENDDO
-!!
-      RETURN
-   END SUBROUTINE SASCNV
-
-! ------------------------------------------------------------------------
-
-      SUBROUTINE OLD_ARW_SHALCV(IM,IX,KM,DT,DEL,PRSI,PRSL,PRSLK,KUO,Q,T,DPSHC)
-!
-      USE MODULE_GFS_MACHINE , ONLY : kind_phys
-      USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP &
-     &,             RD => con_RD
-
-      implicit none
-!
-!     include 'constant.h'
-!
-      integer              IM, IX, KM, KUO(IM)
-      real(kind=kind_phys) DEL(IX,KM),   PRSI(IX,KM+1), PRSL(IX,KM),    &
-     &                     PRSLK(IX,KM),                                &
-     &                     Q(IX,KM),     T(IX,KM),      DT, DPSHC
-!
-!     Locals
-!
-      real(kind=kind_phys) ck,    cpdt,   dmse,   dsdz1, dsdz2,         &
-     &                     dsig,  dtodsl, dtodsu, eldq,  g,             &
-     &                     gocp,  rtdls
-!
-      integer              k,k1,k2,kliftl,kliftu,kt,N2,I,iku,ik1,ik,ii
-      integer              INDEX2(IM), KLCL(IM), KBOT(IM), KTOP(IM),kk  &
-     &,                    KTOPM(IM)
-!!
-!  PHYSICAL PARAMETERS
-      PARAMETER(G=GRAV, GOCP=G/CP)
-!  BOUNDS OF PARCEL ORIGIN
-      PARAMETER(KLIFTL=2,KLIFTU=2)
-      LOGICAL   LSHC(IM)
-      real(kind=kind_phys) Q2(IM*KM),     T2(IM*KM),                    &
-     &                     PRSL2(IM*KM),  PRSLK2(IM*KM),                &
-     &                     AL(IM*(KM-1)), AD(IM*KM), AU(IM*(KM-1))
-!-----------------------------------------------------------------------
-!  COMPRESS FIELDS TO POINTS WITH NO DEEP CONVECTION
-!  AND MOIST STATIC INSTABILITY.
-      DO I=1,IM
-        LSHC(I)=.FALSE.
-      ENDDO
-      DO K=1,KM-1
-        DO I=1,IM
-          IF(KUO(I).EQ.0) THEN
-            ELDQ    = HVAP*(Q(I,K)-Q(I,K+1))
-            CPDT    = CP*(T(I,K)-T(I,K+1))
-            RTDLS   = (PRSL(I,K)-PRSL(I,K+1)) /                         &
-     &                 PRSI(I,K+1)*RD*0.5*(T(I,K)+T(I,K+1))
-            DMSE    = ELDQ+CPDT-RTDLS
-            LSHC(I) = LSHC(I).OR.DMSE.GT.0.
-          ENDIF
-        ENDDO
-      ENDDO
-      N2 = 0
-      DO I=1,IM
-        IF(LSHC(I)) THEN
-          N2         = N2 + 1
-          INDEX2(N2) = I
-        ENDIF
-      ENDDO
-      IF(N2.EQ.0) RETURN
-      DO K=1,KM
-        KK = (K-1)*N2
-        DO I=1,N2
-          IK         = KK + I
-          ii         = index2(i)
-          Q2(IK)     = Q(II,K)
-          T2(IK)     = T(II,K)
-          PRSL2(IK)  = PRSL(II,K)
-          PRSLK2(IK) = PRSLK(II,K)
-        ENDDO
-      ENDDO
-      do i=1,N2
-        ktopm(i) = KM
-      enddo
-      do k=2,KM
-        do i=1,N2
-          ii = index2(i)
-          if (prsi(ii,1)-prsi(ii,k) .le. dpshc) ktopm(i) = k
-        enddo
-      enddo
-
-!-----------------------------------------------------------------------
-!  COMPUTE MOIST ADIABAT AND DETERMINE LIMITS OF SHALLOW CONVECTION.
-!  CHECK FOR MOIST STATIC INSTABILITY AGAIN WITHIN CLOUD.
-      CALL MSTADBT3(N2,KM-1,KLIFTL,KLIFTU,PRSL2,PRSLK2,T2,Q2,           &
-     &            KLCL,KBOT,KTOP,AL,AU)
-      DO I=1,N2
-        KBOT(I) = min(KLCL(I)-1, ktopm(i)-1)
-        KTOP(I) = min(KTOP(I)+1, ktopm(i))
-        LSHC(I) = .FALSE.
-      ENDDO
-      DO K=1,KM-1
-        KK = (K-1)*N2
-        DO I=1,N2
-          IF(K.GE.KBOT(I).AND.K.LT.KTOP(I)) THEN
-            IK      = KK + I
-            IKU     = IK + N2
-            ELDQ    = HVAP * (Q2(IK)-Q2(IKU))
-            CPDT    = CP   * (T2(IK)-T2(IKU))
-            RTDLS   = (PRSL2(IK)-PRSL2(IKU)) /                          &
-     &                 PRSI(index2(i),K+1)*RD*0.5*(T2(IK)+T2(IKU))
-            DMSE    = ELDQ + CPDT - RTDLS
-            LSHC(I) = LSHC(I).OR.DMSE.GT.0.
-            AU(IK)  = G/RTDLS
-          ENDIF
-        ENDDO
-      ENDDO
-      K1=KM+1
-      K2=0
-      DO I=1,N2
-        IF(.NOT.LSHC(I)) THEN
-          KBOT(I) = KM+1
-          KTOP(I) = 0
-        ENDIF
-        K1 = MIN(K1,KBOT(I))
-        K2 = MAX(K2,KTOP(I))
-      ENDDO
-      KT = K2-K1+1
-      IF(KT.LT.2) RETURN
-!-----------------------------------------------------------------------
-!  SET EDDY VISCOSITY COEFFICIENT CKU AT SIGMA INTERFACES.
-!  COMPUTE DIAGONALS AND RHS FOR TRIDIAGONAL MATRIX SOLVER.
-!  EXPAND FINAL FIELDS.
-      KK = (K1-1) * N2
-      DO I=1,N2
-        IK     = KK + I
-        AD(IK) = 1.
-      ENDDO
-!
-!     DTODSU=DT/DEL(K1)
-      DO K=K1,K2-1
-!       DTODSL=DTODSU
-!       DTODSU=   DT/DEL(K+1)
-!       DSIG=SL(K)-SL(K+1)
-        KK = (K-1) * N2
-        DO I=1,N2
-          ii     = index2(i)
-          DTODSL = DT/DEL(II,K)
-          DTODSU = DT/DEL(II,K+1)
-          DSIG   = PRSL(II,K) - PRSL(II,K+1)
-          IK     = KK + I
-          IKU    = IK + N2
-          IF(K.EQ.KBOT(I)) THEN
-            CK=1.5
-          ELSEIF(K.EQ.KTOP(I)-1) THEN
-            CK=1.
-          ELSEIF(K.EQ.KTOP(I)-2) THEN
-            CK=3.
-          ELSEIF(K.GT.KBOT(I).AND.K.LT.KTOP(I)-2) THEN
-            CK=5.
-          ELSE
-            CK=0.
-          ENDIF
-          DSDZ1   = CK*DSIG*AU(IK)*GOCP
-          DSDZ2   = CK*DSIG*AU(IK)*AU(IK)
-          AU(IK)  = -DTODSL*DSDZ2
-          AL(IK)  = -DTODSU*DSDZ2
-          AD(IK)  = AD(IK)-AU(IK)
-          AD(IKU) = 1.-AL(IK)
-          T2(IK)  = T2(IK)+DTODSL*DSDZ1
-          T2(IKU) = T2(IKU)-DTODSU*DSDZ1
-        ENDDO
-      ENDDO
-      IK1=(K1-1)*N2+1
-      CALL TRIDI2T3(N2,KT,AL(IK1),AD(IK1),AU(IK1),Q2(IK1),T2(IK1),      &
-     &                                  AU(IK1),Q2(IK1),T2(IK1))
-      DO K=K1,K2
-        KK = (K-1)*N2
-        DO I=1,N2
-          IK = KK + I
-          Q(INDEX2(I),K) = Q2(IK)
-          T(INDEX2(I),K) = T2(IK)
-        ENDDO
-      ENDDO
-!-----------------------------------------------------------------------
-      RETURN
-      END SUBROUTINE OLD_ARW_SHALCV
-
-!-----------------------------------------------------------------------
-      SUBROUTINE TRIDI2T3(L,N,CL,CM,CU,R1,R2,AU,A1,A2)
-!yt      INCLUDE DBTRIDI2;
-!!
-      USE MODULE_GFS_MACHINE , ONLY : kind_phys
-      implicit none
-      integer             k,n,l,i
-      real(kind=kind_phys) fk
-!!
-      real(kind=kind_phys)                                              &
-     &          CL(L,2:N),CM(L,N),CU(L,N-1),R1(L,N),R2(L,N),            &
-     &          AU(L,N-1),A1(L,N),A2(L,N)
-!-----------------------------------------------------------------------
-      DO I=1,L
-        FK=1./CM(I,1)
-        AU(I,1)=FK*CU(I,1)
-        A1(I,1)=FK*R1(I,1)
-        A2(I,1)=FK*R2(I,1)
-      ENDDO
-      DO K=2,N-1
-        DO I=1,L
-          FK=1./(CM(I,K)-CL(I,K)*AU(I,K-1))
-          AU(I,K)=FK*CU(I,K)
-          A1(I,K)=FK*(R1(I,K)-CL(I,K)*A1(I,K-1))
-          A2(I,K)=FK*(R2(I,K)-CL(I,K)*A2(I,K-1))
-        ENDDO
-      ENDDO
-      DO I=1,L
-        FK=1./(CM(I,N)-CL(I,N)*AU(I,N-1))
-        A1(I,N)=FK*(R1(I,N)-CL(I,N)*A1(I,N-1))
-        A2(I,N)=FK*(R2(I,N)-CL(I,N)*A2(I,N-1))
-      ENDDO
-      DO K=N-1,1,-1
-        DO I=1,L
-          A1(I,K)=A1(I,K)-AU(I,K)*A1(I,K+1)
-          A2(I,K)=A2(I,K)-AU(I,K)*A2(I,K+1)
-        ENDDO
-      ENDDO
-!-----------------------------------------------------------------------
-      RETURN
-      END SUBROUTINE TRIDI2T3
-!-----------------------------------------------------------------------
-
-      SUBROUTINE MSTADBT3(IM,KM,K1,K2,PRSL,PRSLK,TENV,QENV,             &
-     &                  KLCL,KBOT,KTOP,TCLD,QCLD)
-!yt      INCLUDE DBMSTADB;
-!!
-      USE MODULE_GFS_MACHINE, ONLY : kind_phys
-      USE MODULE_GFS_FUNCPHYS, ONLY : FTDP, FTHE, FTLCL, STMA
-      USE MODULE_GFS_PHYSCONS, EPS => con_eps, EPSM1 => con_epsm1, FV => con_FVirt
-
-      implicit none
-!!
-!     include 'constant.h'
-!!
-      integer              k,k1,k2,km,i,im
-      real(kind=kind_phys) pv,qma,slklcl,tdpd,thelcl,tlcl
-      real(kind=kind_phys) tma,tvcld,tvenv
-!!
-      real(kind=kind_phys) PRSL(IM,KM), PRSLK(IM,KM), TENV(IM,KM),      &
-     &                     QENV(IM,KM), TCLD(IM,KM),  QCLD(IM,KM)
-      INTEGER              KLCL(IM),    KBOT(IM),      KTOP(IM)
-!  LOCAL ARRAYS
-      real(kind=kind_phys) SLKMA(IM), THEMA(IM)
-!-----------------------------------------------------------------------
-!  DETERMINE WARMEST POTENTIAL WET-BULB TEMPERATURE BETWEEN K1 AND K2.
-!  COMPUTE ITS LIFTING CONDENSATION LEVEL.
-!
-      DO I=1,IM
-        SLKMA(I) = 0.
-        THEMA(I) = 0.
-      ENDDO
-      DO K=K1,K2
-        DO I=1,IM
-          PV   = 1000.0 * PRSL(I,K)*QENV(I,K)/(EPS-EPSM1*QENV(I,K))
-          TDPD = TENV(I,K)-FTDP(PV)
-          IF(TDPD.GT.0.) THEN
-            TLCL   = FTLCL(TENV(I,K),TDPD)
-            SLKLCL = PRSLK(I,K)*TLCL/TENV(I,K)
-          ELSE
-            TLCL   = TENV(I,K)
-            SLKLCL = PRSLK(I,K)
-          ENDIF
-          THELCL=FTHE(TLCL,SLKLCL)
-          IF(THELCL.GT.THEMA(I)) THEN
-            SLKMA(I) = SLKLCL
-            THEMA(I) = THELCL
-          ENDIF
-        ENDDO
-      ENDDO
-!-----------------------------------------------------------------------
-!  SET CLOUD TEMPERATURES AND HUMIDITIES WHEREVER THE PARCEL LIFTED UP
-!  THE MOIST ADIABAT IS BUOYANT WITH RESPECT TO THE ENVIRONMENT.
-      DO I=1,IM
-        KLCL(I)=KM+1
-        KBOT(I)=KM+1
-        KTOP(I)=0
-      ENDDO
-      DO K=1,KM
-        DO I=1,IM
-          TCLD(I,K)=0.
-          QCLD(I,K)=0.
-        ENDDO
-      ENDDO
-      DO K=K1,KM
-        DO I=1,IM
-          IF(PRSLK(I,K).LE.SLKMA(I)) THEN
-            KLCL(I)=MIN(KLCL(I),K)
-            CALL STMA(THEMA(I),PRSLK(I,K),TMA,QMA)
-!           TMA=FTMA(THEMA(I),PRSLK(I,K),QMA)
-            TVCLD=TMA*(1.+FV*QMA)
-            TVENV=TENV(I,K)*(1.+FV*QENV(I,K))
-            IF(TVCLD.GT.TVENV) THEN
-              KBOT(I)=MIN(KBOT(I),K)
-              KTOP(I)=MAX(KTOP(I),K)
-              TCLD(I,K)=TMA-TENV(I,K)
-              QCLD(I,K)=QMA-QENV(I,K)
-            ENDIF
-          ENDIF
-        ENDDO
-      ENDDO
-!-----------------------------------------------------------------------
-      RETURN
-      END SUBROUTINE MSTADBT3
-
-      subroutine sascnvn(im,ix,km,jcap,delt,del,prsl,ps,phil,ql,   & 
-     &     q1,t1,u1,v1,rcs,cldwrk,rn,kbot,ktop,kcnv,slimsk,        &
-     &     dot,ncloud,pgcon,sas_mass_flux)                         
-!     &     dot,ncloud,ud_mf,dd_mf,dt_mf)                         
-!    &     dot,ncloud,ud_mf,dd_mf,dt_mf,me)
-!
-!      use machine , only : kind_phys
-!      use funcphys , only : fpvs
-!      use physcons, grav => con_g, cp => con_cp, hvap => con_hvap  &
-      USE MODULE_GFS_MACHINE, ONLY : kind_phys
-      USE MODULE_GFS_FUNCPHYS, ONLY : fpvs
-      USE MODULE_GFS_PHYSCONS, grav => con_g, cp => con_cp         &
-     &,             hvap => con_hvap                               &
-     &,             rv => con_rv, fv => con_fvirt, t0c => con_t0c  &
-     &,             cvap => con_cvap, cliq => con_cliq             &
-     &,             eps => con_eps, epsm1 => con_epsm1
-      implicit none
-!
-      integer            im, ix,  km, jcap, ncloud,                &
-     &                   kbot(im), ktop(im), kcnv(im) 
-!    &,                  me
-      real(kind=kind_phys) delt,sas_mass_flux
-      real(kind=kind_phys) ps(im),     del(ix,km),  prsl(ix,km),   &
-     &                     ql(ix,km,2),q1(ix,km),   t1(ix,km),     &
-     &                     u1(ix,km),  v1(ix,km),   rcs(im),       &
-     &                     cldwrk(im), rn(im),      slimsk(im),    &
-     &                     dot(ix,km), phil(ix,km)
-! hchuang code change mass flux output
-!     &,                    ud_mf(im,km),dd_mf(im,km),dt_mf(im,km)
-!
-      integer              i, j, indx, jmn, k, kk, latd, lond, km1
-!
-      real(kind=kind_phys) clam, cxlamu, xlamde, xlamdd
-! 
-      real(kind=kind_phys) adw,     aup,     aafac,                &
-     &                     beta,    betal,   betas,                &
-     &                     c0,      cpoel,   dellat,  delta,       &
-     &                     desdt,   deta,    detad,   dg,          &
-     &                     dh,      dhh,     dlnsig,  dp,          &
-     &                     dq,      dqsdp,   dqsdt,   dt,          &
-     &                     dt2,     dtmax,   dtmin,   dv1h,        &
-     &                     dv1q,    dv2h,    dv2q,    dv1u,        &
-     &                     dv1v,    dv2u,    dv2v,    dv3q,        &
-     &                     dv3h,    dv3u,    dv3v,                 &
-     &                     dz,      dz1,     e1,      edtmax,      &
-     &                     edtmaxl, edtmaxs, el2orc,  elocp,       &
-     &                     es,      etah,    cthk,    dthk,        &
-     &                     evef,    evfact,  evfactl, fact1,       &
-     &                     fact2,   factor,  fjcap,   fkm,         &
-     &                     g,       gamma,   pprime,               &
-     &                     qlk,     qrch,    qs,      c1,          &
-     &                     rain,    rfact,   shear,   tem1,        &
-     &                     tem2,    terr,    val,     val1,        &
-     &                     val2,    w1,      w1l,     w1s,         &
-     &                     w2,      w2l,     w2s,     w3,          &
-     &                     w3l,     w3s,     w4,      w4l,         &
-     &                     w4s,     xdby,    xpw,     xpwd,        &
-     &                     xqrch,   mbdt,    tem,                  &
-     &                     ptem,    ptem1
-!
-      real(kind=kind_phys), intent(in) :: pgcon
-
-      integer              kb(im), kbcon(im), kbcon1(im),          &
-     &                     ktcon(im), ktcon1(im),                  &
-     &                     jmin(im), lmin(im), kbmax(im),          &
-     &                     kbm(im), kmax(im)
-!
-      real(kind=kind_phys) aa1(im),     acrt(im),   acrtfct(im),   &
-     &                     delhbar(im), delq(im),   delq2(im),     &
-     &                     delqbar(im), delqev(im), deltbar(im),   &
-     &                     deltv(im),   dtconv(im), edt(im),       &
-     &                     edto(im),    edtx(im),   fld(im),       &
-     &                     hcdo(im,km), hmax(im),   hmin(im),      &
-     &                     ucdo(im,km), vcdo(im,km),aa2(im),       &
-     &                     pbcdif(im),  pdot(im),   po(im,km),     &
-     &                     pwavo(im),   pwevo(im),  xlamud(im),    &
-     &                     qcdo(im,km), qcond(im),  qevap(im),     &
-     &                     rntot(im),   vshear(im), xaa0(im),      &
-     &                     xk(im),      xlamd(im),                 &
-     &                     xmb(im),     xmbmax(im), xpwav(im),     &
-     &                     xpwev(im),   delubar(im),delvbar(im)
-!cj
-      real(kind=kind_phys) cincr, cincrmax, cincrmin
-      real(kind=kind_phys) xmbmx1
-!cj
-!c  physical parameters
-      parameter(g=grav)
-      parameter(cpoel=cp/hvap,elocp=hvap/cp,                       &
-     &          el2orc=hvap*hvap/(rv*cp))
-      parameter(terr=0.,c0=.002,c1=.002,delta=fv)
-      parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c)
-      parameter(cthk=150.,cincrmax=180.,cincrmin=120.,dthk=25.)
-!c  local variables and arrays
-      real(kind=kind_phys) pfld(im,km),to(im,km), qo(im,km),       &
-     &                     uo(im,km),  vo(im,km), qeso(im,km)
-!c  cloud water
-      real(kind=kind_phys)qlko_ktcon(im),dellal(im,km),tvo(im,km), &
-     &                dbyo(im,km), zo(im,km),    xlamue(im,km),    &
-     &                fent1(im,km),fent2(im,km), frh(im,km),       &
-     &                heo(im,km),  heso(im,km),                    &
-     &                qrcd(im,km), dellah(im,km), dellaq(im,km),   &
-     &                dellau(im,km),dellav(im,km), hcko(im,km),    &
-     &                ucko(im,km), vcko(im,km),   qcko(im,km),     &
-     &                eta(im,km),  etad(im,km),   zi(im,km),       &
-     &                qrcdo(im,km),pwo(im,km),    pwdo(im,km),     &
-     &                tx1(im),     sumx(im)
-!    &,               rhbar(im)
-!
-      logical totflg, cnvflg(im), flg(im)
-!
-      real(kind=kind_phys) pcrit(15), acritt(15), acrit(15)
-!     save pcrit, acritt
-      data pcrit/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,&
-     &           350.,300.,250.,200.,150./
-      data acritt/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216,  &
-     &           .3151,.3677,.41,.5255,.7663,1.1686,1.6851/
-!c  gdas derived acrit
-!c     data acritt/.203,.515,.521,.566,.625,.665,.659,.688,
-!c    &            .743,.813,.886,.947,1.138,1.377,1.896/
-      real(kind=kind_phys) tf, tcr, tcrf
-      parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf))
-!
-!c-----------------------------------------------------------------------
-!
-
-      km1 = km - 1
-!c
-!c  initialize arrays
-!c
-      do i=1,im
-        kcnv(i)=0
-        cnvflg(i) = .true.
-        rn(i)=0.
-        kbot(i)=km+1
-        ktop(i)=0
-        kbcon(i)=km
-        ktcon(i)=1
-        dtconv(i) = 3600.
-        cldwrk(i) = 0.
-        pdot(i) = 0.
-        pbcdif(i)= 0.
-        lmin(i) = 1
-        jmin(i) = 1
-        qlko_ktcon(i) = 0.
-        edt(i)  = 0.
-        edto(i) = 0.
-        edtx(i) = 0.
-        acrt(i) = 0.
-        acrtfct(i) = 1.
-        aa1(i)  = 0.
-        aa2(i)  = 0.
-        xaa0(i) = 0.
-        pwavo(i)= 0.
-        pwevo(i)= 0.
-        xpwav(i)= 0.
-        xpwev(i)= 0.
-        vshear(i) = 0.
-      enddo
-! hchuang code change
-!      do k = 1, km
-!        do i = 1, im
-!          ud_mf(i,k) = 0.
-!          dd_mf(i,k) = 0.
-!          dt_mf(i,k) = 0.
-!        enddo
-!      enddo
-!c
-      do k = 1, 15
-        acrit(k) = acritt(k) * (975. - pcrit(k))
-      enddo
-      dt2 = delt
-      val   =         1200.
-      dtmin = max(dt2, val )
-      val   =         3600.
-      dtmax = max(dt2, val )
-!c  model tunable parameters are all here
-      mbdt    = 10.
-      edtmaxl = .3
-      edtmaxs = .3
-      clam    = .1
-      aafac   = .1
-!     betal   = .15
-!     betas   = .15
-      betal   = .05
-      betas   = .05
-!c     evef    = 0.07
-      evfact  = 0.3
-      evfactl = 0.3
-#if ( EM_CORE == 1 )
-!  HAWAII TEST - ZCX
-      BETAl   = .05
-      betas   = .05
-      evfact  = 0.5
-      evfactl = 0.5
-#endif
-!
-      cxlamu  = 1.0e-4
-      xlamde  = 1.0e-4
-      xlamdd  = 1.0e-4
-!
-      fjcap   = (float(jcap) / 126.) ** 2
-      val     =           1.
-      fjcap   = max(fjcap,val)
-      fkm     = (float(km) / 28.) ** 2
-      fkm     = max(fkm,val)
-      w1l     = -8.e-3 
-      w2l     = -4.e-2
-      w3l     = -5.e-3 
-      w4l     = -5.e-4
-      w1s     = -2.e-4
-      w2s     = -2.e-3
-      w3s     = -1.e-3
-      w4s     = -2.e-5
-!c
-!c  define top layer for search of the downdraft originating layer
-!c  and the maximum thetae for updraft
-!c
-      do i=1,im
-        kbmax(i) = km
-        kbm(i)   = km
-        kmax(i)  = km
-        tx1(i)   = 1.0 / ps(i)
-      enddo
-!     
-      do k = 1, km
-        do i=1,im
-          IF (prSL(I,K)*tx1(I) .GT. 0.04) KMAX(I)  = MIN(KM,K + 1)
-!2011bugfix          if (prsl(i,k)*tx1(i) .gt. 0.04) kmax(i)  = k + 1
-          if (prsl(i,k)*tx1(i) .gt. 0.45) kbmax(i) = k + 1
-          if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i)   = k + 1
-        enddo
-      enddo
-      do i=1,im
-        kbmax(i) = min(kbmax(i),kmax(i))
-        kbm(i)   = min(kbm(i),kmax(i))
-      enddo
-!c
-!c  hydrostatic height assume zero terr and initially assume
-!c    updraft entrainment rate as an inverse function of height 
-!c
-      do k = 1, km
-        do i=1,im
-          zo(i,k) = phil(i,k) / g
-        enddo
-      enddo
-      do k = 1, km1
-        do i=1,im
-          zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1))
-          xlamue(i,k) = clam / zi(i,k)
-        enddo
-      enddo
-!c
-!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!c   convert surface pressure to mb from cb
-!c
-      do k = 1, km
-        do i = 1, im
-          if (k .le. kmax(i)) then
-            pfld(i,k) = prsl(i,k) * 10.0
-            eta(i,k)  = 1.
-            fent1(i,k)= 1.
-            fent2(i,k)= 1.
-            frh(i,k)  = 0.
-            hcko(i,k) = 0.
-            qcko(i,k) = 0.
-            ucko(i,k) = 0.
-            vcko(i,k) = 0.
-            etad(i,k) = 1.
-            hcdo(i,k) = 0.
-            qcdo(i,k) = 0.
-            ucdo(i,k) = 0.
-            vcdo(i,k) = 0.
-            qrcd(i,k) = 0.
-            qrcdo(i,k)= 0.
-            dbyo(i,k) = 0.
-            pwo(i,k)  = 0.
-            pwdo(i,k) = 0.
-            dellal(i,k) = 0.
-            to(i,k)   = t1(i,k)
-            qo(i,k)   = q1(i,k)
-            uo(i,k)   = u1(i,k) * rcs(i)
-            vo(i,k)   = v1(i,k) * rcs(i)
-          endif
-        enddo
-      enddo
-!c
-!c  column variables
-!c  p is pressure of the layer (mb)
-!c  t is temperature at t-dt (k)..tn
-!c  q is mixing ratio at t-dt (kg/kg)..qn
-!c  to is temperature at t+dt (k)... this is after advection and turbulan
-!c  qo is mixing ratio at t+dt (kg/kg)..q1
-!c
-      do k = 1, km
-        do i=1,im
-          if (k .le. kmax(i)) then
-            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
-            val1      =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val1)
-            val2      =           1.e-10
-            qo(i,k)   = max(qo(i,k), val2 )
-!           qo(i,k)   = min(qo(i,k),qeso(i,k))
-!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
-          endif
-        enddo
-      enddo
-!c
-!c  compute moist static energy
-!c
-      do k = 1, km
-        do i=1,im
-          if (k .le. kmax(i)) then
-!           tem       = g * zo(i,k) + cp * to(i,k)
-            tem       = phil(i,k) + cp * to(i,k)
-            heo(i,k)  = tem  + hvap * qo(i,k)
-            heso(i,k) = tem  + hvap * qeso(i,k)
-!c           heo(i,k)  = min(heo(i,k),heso(i,k))
-          endif
-        enddo
-      enddo
-!c
-!c  determine level with largest moist static energy
-!c  this is the level where updraft starts
-!c
-      do i=1,im
-        hmax(i) = heo(i,1)
-        kb(i)   = 1
-      enddo
-      do k = 2, km
-        do i=1,im
-          if (k .le. kbm(i)) then
-            if(heo(i,k).gt.hmax(i)) then
-              kb(i)   = k
-              hmax(i) = heo(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!c
-      do k = 1, km1
-        do i=1,im
-          if (k .le. kmax(i)-1) then
-            dz      = .5 * (zo(i,k+1) - zo(i,k))
-            dp      = .5 * (pfld(i,k+1) - pfld(i,k))
-            es      = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
-            pprime  = pfld(i,k+1) + epsm1 * es
-            qs      = eps * es / pprime
-            dqsdp   = - qs / pprime
-            desdt   = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
-            dqsdt   = qs * pfld(i,k+1) * desdt / (es * pprime)
-            gamma   = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
-            dt      = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
-            dq      = dqsdt * dt + dqsdp * dp
-            to(i,k) = to(i,k+1) + dt
-            qo(i,k) = qo(i,k+1) + dq
-            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
-          endif
-        enddo
-      enddo
-!
-      do k = 1, km1
-        do i=1,im
-          if (k .le. kmax(i)-1) then
-            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k))
-            val1      =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val1)
-            val2      =           1.e-10
-            qo(i,k)   = max(qo(i,k), val2 )
-!           qo(i,k)   = min(qo(i,k),qeso(i,k))
-            val1      = 1.0
-            frh(i,k)  = 1. - min(qo(i,k)/qeso(i,k), val1)
-            heo(i,k)  = .5 * g * (zo(i,k) + zo(i,k+1)) +      &
-     &                  cp * to(i,k) + hvap * qo(i,k)
-            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +      &
-     &                  cp * to(i,k) + hvap * qeso(i,k)
-            uo(i,k)   = .5 * (uo(i,k) + uo(i,k+1))
-            vo(i,k)   = .5 * (vo(i,k) + vo(i,k+1))
-          endif
-        enddo
-      enddo
-!c
-!c  look for the level of free convection as cloud base
-!c
-      do i=1,im
-        flg(i)   = .true.
-        kbcon(i) = kmax(i)
-      enddo
-      do k = 1, km1
-        do i=1,im
-          if (flg(i).and.k.le.kbmax(i)) then
-            if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then
-              kbcon(i) = k
-              flg(i)   = .false.
-            endif
-          endif
-        enddo
-      enddo
-!c
-      do i=1,im
-        if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false.
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  determine critical convective inhibition
-!c  as a function of vertical velocity at cloud base.
-!c
-      do i=1,im
-        if(cnvflg(i)) then
-          pdot(i)  = 10.* dot(i,kbcon(i))
-        endif
-      enddo
-      do i=1,im
-        if(cnvflg(i)) then
-          if(slimsk(i).eq.1.) then
-            w1 = w1l
-            w2 = w2l
-            w3 = w3l
-            w4 = w4l
-          else
-            w1 = w1s
-            w2 = w2s
-            w3 = w3s
-            w4 = w4s
-          endif
-          if(pdot(i).le.w4) then
-            tem = (pdot(i) - w4) / (w3 - w4)
-          elseif(pdot(i).ge.-w4) then
-            tem = - (pdot(i) + w4) / (w4 - w3)
-          else
-            tem = 0.
-          endif
-          val1    =             -1.
-          tem = max(tem,val1)
-          val2    =             1.
-          tem = min(tem,val2)
-          tem = 1. - tem
-          tem1= .5*(cincrmax-cincrmin)
-          cincr = cincrmax - tem * tem1
-          pbcdif(i) = pfld(i,kb(i)) - pfld(i,kbcon(i))
-          if(pbcdif(i).gt.cincr) then
-             cnvflg(i) = .false.
-          endif
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  assume that updraft entrainment rate above cloud base is
-!c    same as that at cloud base
-!c
-      do k = 2, km1
-        do i=1,im
-          if(cnvflg(i).and.                            &
-     &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
-              xlamue(i,k) = xlamue(i,kbcon(i))
-          endif
-        enddo
-      enddo
-!c
-!c  assume the detrainment rate for the updrafts to be same as
-!c  the entrainment rate at cloud base
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          xlamud(i) = xlamue(i,kbcon(i))
-        endif
-      enddo
-!c
-!c  functions rapidly decreasing with height, mimicking a cloud ensemble
-!c    (Bechtold et al., 2008)
-!c
-      do k = 2, km1
-        do i=1,im
-          if(cnvflg(i).and.                          &
-     &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
-              tem = qeso(i,k)/qeso(i,kbcon(i))
-              fent1(i,k) = tem**2
-              fent2(i,k) = tem**3
-          endif
-        enddo
-      enddo
-!c
-!c  final entrainment rate as the sum of turbulent part and organized entrainment
-!c    depending on the environmental relative humidity
-!c    (Bechtold et al., 2008)
-!c
-      do k = 2, km1
-        do i=1,im
-          if(cnvflg(i).and.                         &
-     &      (k.ge.kbcon(i).and.k.lt.kmax(i))) then
-              tem = cxlamu * frh(i,k) * fent2(i,k)
-              xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem
-          endif
-        enddo
-      enddo
-!c
-!c  determine updraft mass flux for the subcloud layers
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.lt.kbcon(i).and.k.ge.kb(i)) then
-              dz       = zi(i,k+1) - zi(i,k)
-              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i)
-              eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c  compute mass flux above cloud base
-!c
-      do k = 2, km1
-        do i = 1, im
-         if(cnvflg(i))then
-           if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
-              dz       = zi(i,k) - zi(i,k-1)
-              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i)
-              eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
-           endif
-         endif
-        enddo
-      enddo
-!c
-!c  compute updraft cloud properties
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          indx         = kb(i)
-          hcko(i,indx) = heo(i,indx)
-          ucko(i,indx) = uo(i,indx)
-          vcko(i,indx) = vo(i,indx)
-          pwavo(i)     = 0.
-        endif
-      enddo
-!c
-!c  cloud property is modified by the entrainment process
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.kmax(i)) then
-              dz   = zi(i,k) - zi(i,k-1)
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              ptem = 0.5 * tem + pgcon
-              ptem1= 0.5 * tem - pgcon
-              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*     &
-     &                     (heo(i,k)+heo(i,k-1)))/factor
-              ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k) &
-     &                     +ptem1*uo(i,k-1))/factor
-              vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k) &
-     &                     +ptem1*vo(i,k-1))/factor
-              dbyo(i,k) = hcko(i,k) - heso(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c   taking account into convection inhibition due to existence of
-!c    dry layers below cloud base
-!c
-      do i=1,im
-        flg(i) = cnvflg(i)
-        kbcon1(i) = kmax(i)
-      enddo
-      do k = 2, km1
-      do i=1,im
-        if (flg(i).and.k.lt.kmax(i)) then
-          if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
-            kbcon1(i) = k
-            flg(i)    = .false.
-          endif
-        endif
-      enddo
-      enddo
-      do i=1,im
-        if(cnvflg(i)) then
-          if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false.
-        endif
-      enddo
-      do i=1,im
-        if(cnvflg(i)) then
-          tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i))
-          if(tem.gt.dthk) then
-             cnvflg(i) = .false.
-          endif
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i = 1, im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  determine first guess cloud top as the level of zero buoyancy
-!c
-      do i = 1, im
-        flg(i) = cnvflg(i)
-        ktcon(i) = 1
-      enddo
-      do k = 2, km1
-      do i = 1, im
-        if (flg(i).and.k .lt. kmax(i)) then
-          if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then
-             ktcon(i) = k
-             flg(i)   = .false.
-          endif
-        endif
-      enddo
-      enddo
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          tem = pfld(i,kbcon(i))-pfld(i,ktcon(i))
-          if(tem.lt.cthk) cnvflg(i) = .false.
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i = 1, im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  search for downdraft originating level above theta-e minimum
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-           hmin(i) = heo(i,kbcon1(i))
-           lmin(i) = kbmax(i)
-           jmin(i) = kbmax(i)
-        endif
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kbmax(i)) then
-            if(k.gt.kbcon1(i).and.heo(i,k).lt.hmin(i)) then
-               lmin(i) = k + 1
-               hmin(i) = heo(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c  make sure that jmin(i) is within the cloud
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          jmin(i) = min(lmin(i),ktcon(i)-1)
-          jmin(i) = max(jmin(i),kbcon1(i)+1)
-          if(jmin(i).ge.ktcon(i)) cnvflg(i) = .false.
-        endif
-      enddo
-!c
-!c  specify upper limit of mass flux at cloud base
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-!         xmbmax(i) = .1
-!
-          k = kbcon(i)
-          dp = 1000. * del(i,k)
-          xmbmax(i) = dp / (g * dt2)
-          xmbmax(i) = min(sas_mass_flux,xmbmax(i))
-!
-!         tem = dp / (g * dt2)
-!         xmbmax(i) = min(tem, xmbmax(i))
-        endif
-      enddo
-!c
-!c  compute cloud moisture property and precipitation
-!c
-      do i = 1, im
-        if (cnvflg(i)) then
-          aa1(i) = 0.
-          qcko(i,kb(i)) = qo(i,kb(i))
-!         rhbar(i) = 0.
-        endif
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
-              dz    = zi(i,k) - zi(i,k-1)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrch = qeso(i,k)                             &
-     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
-!cj
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*  &
-     &                     (qo(i,k)+qo(i,k-1)))/factor
-!cj
-              dq = eta(i,k) * (qcko(i,k) - qrch)
-!c
-!             rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k)
-!c
-!c  check if there is excess moisture to release latent heat
-!c
-              if(k.ge.kbcon(i).and.dq.gt.0.) then
-                etah = .5 * (eta(i,k) + eta(i,k-1))
-                if(ncloud.gt.0..and.k.gt.jmin(i)) then
-                  dp = 1000. * del(i,k)
-                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
-                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
-                else
-                  qlk = dq / (eta(i,k) + etah * c0 * dz)
-                endif
-                aa1(i) = aa1(i) - dz * g * qlk
-                qcko(i,k) = qlk + qrch
-                pwo(i,k) = etah * c0 * dz * qlk
-                pwavo(i) = pwavo(i) + pwo(i,k)
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!c
-!     do i = 1, im
-!       if(cnvflg(i)) then
-!         indx = ktcon(i) - kb(i) - 1
-!         rhbar(i) = rhbar(i) / float(indx)
-!       endif
-!     enddo
-!c
-!c  calculate cloud work function
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
-              dz1 = zo(i,k+1) - zo(i,k)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              rfact =  1. + delta * cp * gamma            &
-     &                 * to(i,k) / hvap
-              aa1(i) = aa1(i) +                           &
-     &                 dz1 * (g / (cp * to(i,k)))         &
-     &                 * dbyo(i,k) / (1. + gamma)         &
-     &                 * rfact
-              val = 0.
-              aa1(i)=aa1(i)+                              &
-     &                 dz1 * g * delta *                  &
-     &                 max(val,(qeso(i,k) - qo(i,k)))
-            endif
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  estimate the onvective overshooting as the level 
-!c    where the [aafac * cloud work function] becomes zero,
-!c    which is the final cloud top
-!c
-      do i = 1, im
-        if (cnvflg(i)) then
-          aa2(i) = aafac * aa1(i)
-        endif
-      enddo
-!c
-      do i = 1, im
-        flg(i) = cnvflg(i)
-        ktcon1(i) = kmax(i) - 1
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (flg(i)) then
-            if(k.ge.ktcon(i).and.k.lt.kmax(i)) then
-              dz1 = zo(i,k+1) - zo(i,k)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              rfact =  1. + delta * cp * gamma          &
-     &                 * to(i,k) / hvap
-              aa2(i) = aa2(i) +                         &
-     &                 dz1 * (g / (cp * to(i,k)))       &
-     &                 * dbyo(i,k) / (1. + gamma)       &
-     &                 * rfact
-              if(aa2(i).lt.0.) then
-                ktcon1(i) = k
-                flg(i) = .false.
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c  compute cloud moisture property, detraining cloud water 
-!c    and precipitation in overshooting layers 
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
-              dz    = zi(i,k) - zi(i,k-1)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrch = qeso(i,k)                              &
-     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
-!cj
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*   &
-     &                     (qo(i,k)+qo(i,k-1)))/factor
-!cj
-              dq = eta(i,k) * (qcko(i,k) - qrch)
-!c
-!c  check if there is excess moisture to release latent heat
-!c
-              if(dq.gt.0.) then
-                etah = .5 * (eta(i,k) + eta(i,k-1))
-                if(ncloud.gt.0.) then
-                  dp = 1000. * del(i,k)
-                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
-                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
-                else
-                  qlk = dq / (eta(i,k) + etah * c0 * dz)
-                endif
-                qcko(i,k) = qlk + qrch
-                pwo(i,k) = etah * c0 * dz * qlk
-                pwavo(i) = pwavo(i) + pwo(i,k)
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c exchange ktcon with ktcon1
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          kk = ktcon(i)
-          ktcon(i) = ktcon1(i)
-          ktcon1(i) = kk
-        endif
-      enddo
-!c
-!c  this section is ready for cloud water
-!c
-      if(ncloud.gt.0) then
-!c
-!c  compute liquid and vapor separation at cloud top
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          k = ktcon(i) - 1
-          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-          qrch = qeso(i,k)                              &
-     &         + gamma * dbyo(i,k) / (hvap * (1. + gamma))
-          dq = qcko(i,k) - qrch
-!c
-!c  check if there is excess moisture to release latent heat
-!c
-          if(dq.gt.0.) then
-            qlko_ktcon(i) = dq
-            qcko(i,k) = qrch
-          endif
-        endif
-      enddo
-      endif
-!c
-!ccccc if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then
-!ccccc   print *, ' aa1(i) before dwndrft =', aa1(i)
-!ccccc endif
-!c
-!c------- downdraft calculations
-!c
-!c--- compute precipitation efficiency in terms of windshear
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          vshear(i) = 0.
-        endif
-      enddo
-      do k = 2, km
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.le.ktcon(i)) then
-              shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2      &
-     &                  + (vo(i,k)-vo(i,k-1)) ** 2)
-              vshear(i) = vshear(i) + shear
-            endif
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvflg(i)) then
-          vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
-          e1=1.591-.639*vshear(i)                       &
-     &       +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
-          edt(i)=1.-e1
-          val =         .9
-          edt(i) = min(edt(i),val)
-          val =         .0
-          edt(i) = max(edt(i),val)
-          edto(i)=edt(i)
-          edtx(i)=edt(i)
-        endif
-      enddo
-!c
-!c  determine detrainment rate between 1 and kbcon
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          sumx(i) = 0.
-        endif
-      enddo
-      do k = 1, km1
-      do i = 1, im
-        if(cnvflg(i).and.k.ge.1.and.k.lt.kbcon(i)) then
-          dz = zi(i,k+1) - zi(i,k)
-          sumx(i) = sumx(i) + dz
-        endif
-      enddo
-      enddo
-      do i = 1, im
-        beta = betas
-        if(slimsk(i).eq.1.) beta = betal
-        if(cnvflg(i)) then
-          dz  = (sumx(i)+zi(i,1))/float(kbcon(i))
-          tem = 1./float(kbcon(i))
-          xlamd(i) = (1.-beta**tem)/dz
-        endif
-      enddo
-!c
-!c  determine downdraft mass flux
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kmax(i)-1) then
-           if(k.lt.jmin(i).and.k.ge.kbcon(i)) then
-              dz        = zi(i,k+1) - zi(i,k)
-              ptem      = xlamdd - xlamde
-              etad(i,k) = etad(i,k+1) * (1. - ptem * dz)
-           else if(k.lt.kbcon(i)) then
-              dz        = zi(i,k+1) - zi(i,k)
-              ptem      = xlamd(i) + xlamdd - xlamde
-              etad(i,k) = etad(i,k+1) * (1. - ptem * dz)
-           endif
-          endif
-        enddo
-      enddo
-!c
-!c--- downdraft moisture properties
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          jmn = jmin(i)
-          hcdo(i,jmn) = heo(i,jmn)
-          qcdo(i,jmn) = qo(i,jmn)
-          qrcdo(i,jmn)= qeso(i,jmn)
-          ucdo(i,jmn) = uo(i,jmn)
-          vcdo(i,jmn) = vo(i,jmn)
-          pwevo(i) = 0.
-        endif
-      enddo
-!cj
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvflg(i) .and. k.lt.jmin(i)) then
-              dz = zi(i,k+1) - zi(i,k)
-              if(k.ge.kbcon(i)) then
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * xlamdd * dz
-              else
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
-              endif
-              factor = 1. + tem - tem1
-              ptem = 0.5 * tem - pgcon
-              ptem1= 0.5 * tem + pgcon
-              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*       &
-     &                     (heo(i,k)+heo(i,k+1)))/factor
-              ucdo(i,k) = ((1.-tem1)*ucdo(i,k+1)+ptem*uo(i,k+1) &
-     &                     +ptem1*uo(i,k))/factor
-              vcdo(i,k) = ((1.-tem1)*vcdo(i,k+1)+ptem*vo(i,k+1) &
-     &                     +ptem1*vo(i,k))/factor
-              dbyo(i,k) = hcdo(i,k) - heso(i,k)
-          endif
-        enddo
-      enddo
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvflg(i).and.k.lt.jmin(i)) then
-              gamma      = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrcdo(i,k) = qeso(i,k)+                          &
-     &                (1./hvap)*(gamma/(1.+gamma))*dbyo(i,k)
-!             detad      = etad(i,k+1) - etad(i,k)
-!cj
-              dz = zi(i,k+1) - zi(i,k)
-              if(k.ge.kbcon(i)) then
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * xlamdd * dz
-              else
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
-              endif
-              factor = 1. + tem - tem1
-              qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5*     &
-     &                     (qo(i,k)+qo(i,k+1)))/factor
-!cj
-!             pwdo(i,k)  = etad(i,k+1) * qcdo(i,k+1) -
-!    &                     etad(i,k) * qrcdo(i,k)
-!             pwdo(i,k)  = pwdo(i,k) - detad *
-!    &                    .5 * (qrcdo(i,k) + qrcdo(i,k+1))
-!cj
-              pwdo(i,k)  = etad(i,k+1) * (qcdo(i,k) - qrcdo(i,k))
-              qcdo(i,k)  = qrcdo(i,k)
-              pwevo(i)   = pwevo(i) + pwdo(i,k)
-          endif
-        enddo
-      enddo
-!c
-!c--- final downdraft strength dependent on precip
-!c--- efficiency (edt), normalized condensate (pwav), and
-!c--- evaporate (pwev)
-!c
-      do i = 1, im
-        edtmax = edtmaxl
-        if(slimsk(i).eq.0.) edtmax = edtmaxs
-        if(cnvflg(i)) then
-          if(pwevo(i).lt.0.) then
-            edto(i) = -edto(i) * pwavo(i) / pwevo(i)
-            edto(i) = min(edto(i),edtmax)
-          else
-            edto(i) = 0.
-          endif
-        endif
-      enddo
-!c
-!c--- downdraft cloudwork functions
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvflg(i) .and. k .lt. jmin(i)) then
-              gamma = el2orc * qeso(i,k) / to(i,k)**2
-              dhh=hcdo(i,k)
-              dt=to(i,k)
-              dg=gamma
-              dh=heso(i,k)
-              dz=-1.*(zo(i,k+1)-zo(i,k))
-              aa1(i)=aa1(i)+edto(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg)) &
-     &               *(1.+delta*cp*dg*dt/hvap)
-              val=0.
-              aa1(i)=aa1(i)+edto(i)*                    &
-     &        dz*g*delta*max(val,(qeso(i,k)-qo(i,k)))
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvflg(i).and.aa1(i).le.0.) then
-           cnvflg(i) = .false.
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c--- what would the change be, that a cloud with unit mass
-!c--- will do to the environment?
-!c
-      do k = 1, km
-        do i = 1, im
-          if(cnvflg(i) .and. k .le. kmax(i)) then
-            dellah(i,k) = 0.
-            dellaq(i,k) = 0.
-            dellau(i,k) = 0.
-            dellav(i,k) = 0.
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvflg(i)) then
-          dp = 1000. * del(i,1)
-          dellah(i,1) = edto(i) * etad(i,1) * (hcdo(i,1)     &
-     &                   - heo(i,1)) * g / dp
-          dellaq(i,1) = edto(i) * etad(i,1) * (qcdo(i,1)     &
-     &                   - qo(i,1)) * g / dp
-          dellau(i,1) = edto(i) * etad(i,1) * (ucdo(i,1)     &
-     &                   - uo(i,1)) * g / dp
-          dellav(i,1) = edto(i) * etad(i,1) * (vcdo(i,1)     &
-     &                   - vo(i,1)) * g / dp
-        endif
-      enddo
-!c
-!c--- changed due to subsidence and entrainment
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i).and.k.lt.ktcon(i)) then
-              aup = 1.
-              if(k.le.kb(i)) aup = 0.
-              adw = 1.
-              if(k.gt.jmin(i)) adw = 0.
-              dp = 1000. * del(i,k)
-              dz = zi(i,k) - zi(i,k-1)
-!c
-              dv1h = heo(i,k)
-              dv2h = .5 * (heo(i,k) + heo(i,k-1))
-              dv3h = heo(i,k-1)
-              dv1q = qo(i,k)
-              dv2q = .5 * (qo(i,k) + qo(i,k-1))
-              dv3q = qo(i,k-1)
-              dv1u = uo(i,k)
-              dv2u = .5 * (uo(i,k) + uo(i,k-1))
-              dv3u = uo(i,k-1)
-              dv1v = vo(i,k)
-              dv2v = .5 * (vo(i,k) + vo(i,k-1))
-              dv3v = vo(i,k-1)
-!c
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1))
-              tem1 = xlamud(i)
-!c
-              if(k.le.kbcon(i)) then
-                ptem  = xlamde
-                ptem1 = xlamd(i)+xlamdd
-              else
-                ptem  = xlamde
-                ptem1 = xlamdd
-              endif
-!cj
-              dellah(i,k) = dellah(i,k) +                           &
-     &     ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1h               &
-     &    - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3h           &
-     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2h*dz &
-     &    +  aup*tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz      &
-     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1)) &
-     &         *dz) *g/dp
-!cj
-              dellaq(i,k) = dellaq(i,k) +                             &
-     &     ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1q                 &
-     &    - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3q             &
-     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2q*dz   &
-     &    +  aup*tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz        &
-     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qrcdo(i,k-1)) &
-     &         *dz) *g/dp
-!23456789012345678901234567890123456789012345678901234567890123456789012
-!cj
-              dellau(i,k) = dellau(i,k) +                             &
-     &     ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1u                 &
-     &    - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3u             &
-     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2u*dz   &
-     &    +  aup*tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz        &
-     &    + adw*edto(i)*ptem1*etad(i,k)*.5*(ucdo(i,k)+ucdo(i,k-1))*dz &
-     &    -  pgcon*(aup*eta(i,k-1)-adw*edto(i)*etad(i,k))*(dv1u-dv3u) &
-     &         ) *g/dp
-!cj
-              dellav(i,k) = dellav(i,k) +                             &
-     &     ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1v                 &
-     &    - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3v             &
-     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2v*dz   &
-     &    +  aup*tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz        &
-     &    + adw*edto(i)*ptem1*etad(i,k)*.5*(vcdo(i,k)+vcdo(i,k-1))*dz &
-     &    -  pgcon*(aup*eta(i,k-1)-adw*edto(i)*etad(i,k))*(dv1v-dv3v) &
-     &         ) *g/dp
-!cj
-          endif
-        enddo
-      enddo
-!c
-!c------- cloud top
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          indx = ktcon(i)
-          dp = 1000. * del(i,indx)
-          dv1h = heo(i,indx-1)
-          dellah(i,indx) = eta(i,indx-1) *                    &
-     &                     (hcko(i,indx-1) - dv1h) * g / dp
-          dv1q = qo(i,indx-1)
-          dellaq(i,indx) = eta(i,indx-1) *                    &
-     &                     (qcko(i,indx-1) - dv1q) * g / dp
-          dv1u = uo(i,indx-1)
-          dellau(i,indx) = eta(i,indx-1) *                    &
-     &                     (ucko(i,indx-1) - dv1u) * g / dp
-          dv1v = vo(i,indx-1)
-          dellav(i,indx) = eta(i,indx-1) *                    &
-     &                     (vcko(i,indx-1) - dv1v) * g / dp
-!c
-!c  cloud water
-!c
-          dellal(i,indx) = eta(i,indx-1) *                    &
-     &                     qlko_ktcon(i) * g / dp
-        endif
-      enddo
-!c
-!c------- final changed variable per unit mass flux
-!c
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i).and.k .le. kmax(i)) then
-            if(k.gt.ktcon(i)) then
-              qo(i,k) = q1(i,k)
-              to(i,k) = t1(i,k)
-            endif
-            if(k.le.ktcon(i)) then
-              qo(i,k) = dellaq(i,k) * mbdt + q1(i,k)
-              dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp
-              to(i,k) = dellat * mbdt + t1(i,k)
-              val   =           1.e-10
-              qo(i,k) = max(qo(i,k), val  )
-            endif
-          endif
-        enddo
-      enddo
-!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!c
-!c--- the above changed environment is now used to calulate the
-!c--- effect the arbitrary cloud (with unit mass flux)
-!c--- would have on the stability,
-!c--- which then is used to calculate the real mass flux,
-!c--- necessary to keep this change in balance with the large-scale
-!c--- destabilization.
-!c
-!c--- environmental conditions again, first heights
-!c
-      do k = 1, km
-        do i = 1, im
-          if(cnvflg(i) .and. k .le. kmax(i)) then
-            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k)+epsm1*qeso(i,k))
-            val       =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val )
-!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
-          endif
-        enddo
-      enddo
-!c
-!c--- moist static energy
-!c
-      do k = 1, km1
-        do i = 1, im
-          if(cnvflg(i) .and. k .le. kmax(i)-1) then
-            dz = .5 * (zo(i,k+1) - zo(i,k))
-            dp = .5 * (pfld(i,k+1) - pfld(i,k))
-            es = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
-            pprime = pfld(i,k+1) + epsm1 * es
-            qs = eps * es / pprime
-            dqsdp = - qs / pprime
-            desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
-            dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime)
-            gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
-            dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
-            dq = dqsdt * dt + dqsdp * dp
-            to(i,k) = to(i,k+1) + dt
-            qo(i,k) = qo(i,k+1) + dq
-            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
-          endif
-        enddo
-      enddo
-      do k = 1, km1
-        do i = 1, im
-          if(cnvflg(i) .and. k .le. kmax(i)-1) then
-            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1 * qeso(i,k))
-            val1      =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val1)
-            val2      =           1.e-10
-            qo(i,k)   = max(qo(i,k), val2 )
-!           qo(i,k)   = min(qo(i,k),qeso(i,k))
-            heo(i,k)   = .5 * g * (zo(i,k) + zo(i,k+1)) +     &
-     &                    cp * to(i,k) + hvap * qo(i,k)
-            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +      &
-     &                  cp * to(i,k) + hvap * qeso(i,k)
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvflg(i)) then
-          k = kmax(i)
-          heo(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qo(i,k)
-          heso(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qeso(i,k)
-!c         heo(i,k) = min(heo(i,k),heso(i,k))
-        endif
-      enddo
-!c
-!c**************************** static control
-!c
-!c------- moisture and cloud work functions
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          xaa0(i) = 0.
-          xpwav(i) = 0.
-        endif
-      enddo
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          indx = kb(i)
-          hcko(i,indx) = heo(i,indx)
-          qcko(i,indx) = qo(i,indx)
-        endif
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.le.ktcon(i)) then
-              dz = zi(i,k) - zi(i,k-1)
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*    &
-     &                     (heo(i,k)+heo(i,k-1)))/factor
-            endif
-          endif
-        enddo
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
-              dz = zi(i,k) - zi(i,k-1)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              xdby = hcko(i,k) - heso(i,k)
-              xqrch = qeso(i,k)                             &
-     &              + gamma * xdby / (hvap * (1. + gamma))
-!cj
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*   &
-     &                     (qo(i,k)+qo(i,k-1)))/factor
-!cj
-              dq = eta(i,k) * (qcko(i,k) - xqrch)
-!c
-              if(k.ge.kbcon(i).and.dq.gt.0.) then
-                etah = .5 * (eta(i,k) + eta(i,k-1))
-                if(ncloud.gt.0..and.k.gt.jmin(i)) then
-                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
-                else
-                  qlk = dq / (eta(i,k) + etah * c0 * dz)
-                endif
-                if(k.lt.ktcon1(i)) then
-                  xaa0(i) = xaa0(i) - dz * g * qlk
-                endif
-                qcko(i,k) = qlk + xqrch
-                xpw = etah * c0 * dz * qlk
-                xpwav(i) = xpwav(i) + xpw
-              endif
-            endif
-            if(k.ge.kbcon(i).and.k.lt.ktcon1(i)) then
-              dz1 = zo(i,k+1) - zo(i,k)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              rfact =  1. + delta * cp * gamma          &
-     &                 * to(i,k) / hvap
-              xaa0(i) = xaa0(i)                         &
-     &                + dz1 * (g / (cp * to(i,k)))      &
-     &                * xdby / (1. + gamma)             &
-     &                * rfact
-              val=0.
-              xaa0(i)=xaa0(i)+                          &
-     &                 dz1 * g * delta *                &
-     &                 max(val,(qeso(i,k) - qo(i,k)))
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c------- downdraft calculations
-!c
-!c--- downdraft moisture properties
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          jmn = jmin(i)
-          hcdo(i,jmn) = heo(i,jmn)
-          qcdo(i,jmn) = qo(i,jmn)
-          qrcd(i,jmn) = qeso(i,jmn)
-          xpwev(i) = 0.
-        endif
-      enddo
-!cj
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvflg(i) .and. k.lt.jmin(i)) then
-              dz = zi(i,k+1) - zi(i,k)
-              if(k.ge.kbcon(i)) then
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * xlamdd * dz
-              else
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
-              endif
-              factor = 1. + tem - tem1
-              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*      &
-     &                     (heo(i,k)+heo(i,k+1)))/factor
-          endif
-        enddo
-      enddo
-!cj
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvflg(i) .and. k .lt. jmin(i)) then
-              dq = qeso(i,k)
-              dt = to(i,k)
-              gamma    = el2orc * dq / dt**2
-              dh       = hcdo(i,k) - heso(i,k)
-              qrcd(i,k)=dq+(1./hvap)*(gamma/(1.+gamma))*dh
-!             detad    = etad(i,k+1) - etad(i,k)
-!cj
-              dz = zi(i,k+1) - zi(i,k)
-              if(k.ge.kbcon(i)) then
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * xlamdd * dz
-              else
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
-              endif
-              factor = 1. + tem - tem1
-              qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5*     &
-     &                     (qo(i,k)+qo(i,k+1)))/factor
-!cj
-!             xpwd     = etad(i,k+1) * qcdo(i,k+1) -
-!    &                   etad(i,k) * qrcd(i,k)
-!             xpwd     = xpwd - detad *
-!    &                 .5 * (qrcd(i,k) + qrcd(i,k+1))
-!cj
-              xpwd     = etad(i,k+1) * (qcdo(i,k) - qrcd(i,k))
-              qcdo(i,k)= qrcd(i,k)
-              xpwev(i) = xpwev(i) + xpwd
-          endif
-        enddo
-      enddo
-!c
-      do i = 1, im
-        edtmax = edtmaxl
-        if(slimsk(i).eq.0.) edtmax = edtmaxs
-        if(cnvflg(i)) then
-          if(xpwev(i).ge.0.) then
-            edtx(i) = 0.
-          else
-            edtx(i) = -edtx(i) * xpwav(i) / xpwev(i)
-            edtx(i) = min(edtx(i),edtmax)
-          endif
-        endif
-      enddo
-!c
-!c
-!c--- downdraft cloudwork functions
-!c
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvflg(i) .and. k.lt.jmin(i)) then
-              gamma = el2orc * qeso(i,k) / to(i,k)**2
-              dhh=hcdo(i,k)
-              dt= to(i,k)
-              dg= gamma
-              dh= heso(i,k)
-              dz=-1.*(zo(i,k+1)-zo(i,k))
-              xaa0(i)=xaa0(i)+edtx(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg)) &
-     &                *(1.+delta*cp*dg*dt/hvap)
-              val=0.
-              xaa0(i)=xaa0(i)+edtx(i)*                         &
-     &        dz*g*delta*max(val,(qeso(i,k)-qo(i,k)))
-          endif
-        enddo
-      enddo
-!c
-!c  calculate critical cloud work function
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          if(pfld(i,ktcon(i)).lt.pcrit(15))then
-            acrt(i)=acrit(15)*(975.-pfld(i,ktcon(i)))          &
-     &              /(975.-pcrit(15))
-          else if(pfld(i,ktcon(i)).gt.pcrit(1))then
-            acrt(i)=acrit(1)
-          else
-            k =  int((850. - pfld(i,ktcon(i)))/50.) + 2
-            k = min(k,15)
-            k = max(k,2)
-            acrt(i)=acrit(k)+(acrit(k-1)-acrit(k))*            &
-     &           (pfld(i,ktcon(i))-pcrit(k))/(pcrit(k-1)-pcrit(k))
-          endif
-        endif
-      enddo
-      do i = 1, im
-        if(cnvflg(i)) then
-          if(slimsk(i).eq.1.) then
-            w1 = w1l
-            w2 = w2l
-            w3 = w3l
-            w4 = w4l
-          else
-            w1 = w1s
-            w2 = w2s
-            w3 = w3s
-            w4 = w4s
-          endif
-!c
-!c  modify critical cloud workfunction by cloud base vertical velocity
-!c
-          if(pdot(i).le.w4) then
-            acrtfct(i) = (pdot(i) - w4) / (w3 - w4)
-          elseif(pdot(i).ge.-w4) then
-            acrtfct(i) = - (pdot(i) + w4) / (w4 - w3)
-          else
-            acrtfct(i) = 0.
-          endif
-          val1    =             -1.
-          acrtfct(i) = max(acrtfct(i),val1)
-          val2    =             1.
-          acrtfct(i) = min(acrtfct(i),val2)
-          acrtfct(i) = 1. - acrtfct(i)
-!c
-!c  modify acrtfct(i) by colume mean rh if rhbar(i) is greater than 80 percent
-!c
-!c         if(rhbar(i).ge..8) then
-!c           acrtfct(i) = acrtfct(i) * (.9 - min(rhbar(i),.9)) * 10.
-!c         endif
-!c
-!c  modify adjustment time scale by cloud base vertical velocity
-!c
-          val1=0.
-          dtconv(i) = dt2 + max((1800. - dt2),val1) *         &
-     &                (pdot(i) - w2) / (w1 - w2)
-!c         dtconv(i) = max(dtconv(i), dt2)
-!c         dtconv(i) = 1800. * (pdot(i) - w2) / (w1 - w2)
-          dtconv(i) = max(dtconv(i),dtmin)
-          dtconv(i) = min(dtconv(i),dtmax)
-!c
-        endif
-      enddo
-!c
-!c--- large scale forcing
-!c
-      xmbmx1=-1.e20
-      do i= 1, im
-        if(cnvflg(i)) then
-          fld(i)=(aa1(i)-acrt(i)* acrtfct(i))/dtconv(i)
-          if(fld(i).le.0.) cnvflg(i) = .false.
-        endif
-        if(cnvflg(i)) then
-!c         xaa0(i) = max(xaa0(i),0.)
-          xk(i) = (xaa0(i) - aa1(i)) / mbdt
-          if(xk(i).ge.0.) cnvflg(i) = .false.
-        endif
-!c
-!c--- kernel, cloud base mass flux
-!c
-        if(cnvflg(i)) then
-          xmb(i) = -fld(i) / xk(i)
-          xmb(i) = min(xmb(i),xmbmax(i))
-          xmbmx1=max(xmbmx1,xmb(i))
-        endif
-      enddo
-!      if(xmbmx1.gt.0.4)print*,'qingfu test xmbmx1=',xmbmx1
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  restore to,qo,uo,vo to t1,q1,u1,v1 in case convection stops
-!c
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            to(i,k) = t1(i,k)
-            qo(i,k) = q1(i,k)
-            uo(i,k) = u1(i,k)
-            vo(i,k) = v1(i,k)
-            qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
-            val     =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val )
-          endif
-        enddo
-      enddo
-!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!c
-!c--- feedback: simply the changes from the cloud with unit mass flux
-!c---           multiplied by  the mass flux necessary to keep the
-!c---           equilibrium with the larger-scale.
-!c
-      do i = 1, im
-        delhbar(i) = 0.
-        delqbar(i) = 0.
-        deltbar(i) = 0.
-        delubar(i) = 0.
-        delvbar(i) = 0.
-        qcond(i) = 0.
-      enddo
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            if(k.le.ktcon(i)) then
-              dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp
-              t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2
-              q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2
-              tem = 1./rcs(i)
-              u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem
-              v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem
-              dp = 1000. * del(i,k)
-              delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g
-              delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g
-              deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g
-              delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g
-              delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g
-            endif
-          endif
-        enddo
-      enddo
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            if(k.le.ktcon(i)) then
-              qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
-              qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k))
-              val     =             1.e-8
-              qeso(i,k) = max(qeso(i,k), val )
-            endif
-          endif
-        enddo
-      enddo
-!c
-      do i = 1, im
-        rntot(i) = 0.
-        delqev(i) = 0.
-        delq2(i) = 0.
-        flg(i) = cnvflg(i)
-      enddo
-      do k = km, 1, -1
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            if(k.lt.ktcon(i)) then
-              aup = 1.
-              if(k.le.kb(i)) aup = 0.
-              adw = 1.
-              if(k.ge.jmin(i)) adw = 0.
-              rain =  aup * pwo(i,k) + adw * edto(i) * pwdo(i,k)
-              rntot(i) = rntot(i) + rain * xmb(i) * .001 * dt2
-            endif
-          endif
-        enddo
-      enddo
-      do k = km, 1, -1
-        do i = 1, im
-          if (k .le. kmax(i)) then
-            deltv(i) = 0.
-            delq(i) = 0.
-            qevap(i) = 0.
-            if(cnvflg(i).and.k.lt.ktcon(i)) then
-              aup = 1.
-              if(k.le.kb(i)) aup = 0.
-              adw = 1.
-              if(k.ge.jmin(i)) adw = 0.
-              rain =  aup * pwo(i,k) + adw * edto(i) * pwdo(i,k)
-              rn(i) = rn(i) + rain * xmb(i) * .001 * dt2
-            endif
-            if(flg(i).and.k.lt.ktcon(i)) then
-              evef = edt(i) * evfact
-              if(slimsk(i).eq.1.) evef=edt(i) * evfactl
-!             if(slimsk(i).eq.1.) evef=.07
-!c             if(slimsk(i).ne.1.) evef = 0.
-              qcond(i) = evef * (q1(i,k) - qeso(i,k))     &
-     &                 / (1. + el2orc * qeso(i,k) / t1(i,k)**2)
-              dp = 1000. * del(i,k)
-              if(rn(i).gt.0..and.qcond(i).lt.0.) then
-                qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i))))
-                qevap(i) = min(qevap(i), rn(i)*1000.*g/dp)
-                delq2(i) = delqev(i) + .001 * qevap(i) * dp / g
-              endif
-              if(rn(i).gt.0..and.qcond(i).lt.0..and.      &
-     &           delq2(i).gt.rntot(i)) then
-                qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp
-                flg(i) = .false.
-              endif
-              if(rn(i).gt.0..and.qevap(i).gt.0.) then
-                q1(i,k) = q1(i,k) + qevap(i)
-                t1(i,k) = t1(i,k) - elocp * qevap(i)
-                rn(i) = rn(i) - .001 * qevap(i) * dp / g
-                deltv(i) = - elocp*qevap(i)/dt2
-                delq(i) =  + qevap(i)/dt2
-                delqev(i) = delqev(i) + .001*dp*qevap(i)/g
-              endif
-              dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i)
-              delqbar(i) = delqbar(i) + delq(i)*dp/g
-              deltbar(i) = deltbar(i) + deltv(i)*dp/g
-            endif
-          endif
-        enddo
-      enddo
-!cj
-!     do i = 1, im
-!     if(me.eq.31.and.cnvflg(i)) then
-!     if(cnvflg(i)) then
-!       print *, ' deep delhbar, delqbar, deltbar = ',
-!    &             delhbar(i),hvap*delqbar(i),cp*deltbar(i)
-!       print *, ' deep delubar, delvbar = ',delubar(i),delvbar(i)
-!       print *, ' precip =', hvap*rn(i)*1000./dt2
-!       print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i))
-!     endif
-!     enddo
-!c
-!c  precipitation rate converted to actual precip
-!c  in unit of m instead of kg
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-!c
-!c  in the event of upper level rain evaporation and lower level downdraft
-!c    moistening, rn can become negative, in this case, we back out of the
-!c    heating and the moistening
-!c
-          if(rn(i).lt.0..and..not.flg(i)) rn(i) = 0.
-          if(rn(i).le.0.) then
-            rn(i) = 0.
-          else
-            ktop(i) = ktcon(i)
-            kbot(i) = kbcon(i)
-            kcnv(i) = 1
-            cldwrk(i) = aa1(i)
-          endif
-        endif
-      enddo
-!c
-!c  cloud water
-!c
-      if (ncloud.gt.0) then
-!
-      val1=1.0
-      val2=0.0
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i) .and. rn(i).gt.0.) then
-            if (k.gt.kb(i).and.k.le.ktcon(i)) then
-              tem  = dellal(i,k) * xmb(i) * dt2
-              tem1 = max(val2, min(val1, (tcr-t1(i,k))*tcrf))
-              if (ql(i,k,2) .gt. -999.0) then
-                ql(i,k,1) = ql(i,k,1) + tem * tem1            ! ice
-                ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1)       ! water
-              else
-                ql(i,k,1) = ql(i,k,1) + tem
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!
-      endif
-!c
-      do k = 1, km
-        do i = 1, im
-          if(cnvflg(i).and.rn(i).le.0.) then
-            if (k .le. kmax(i)) then
-              t1(i,k) = to(i,k)
-              q1(i,k) = qo(i,k)
-              u1(i,k) = uo(i,k)
-              v1(i,k) = vo(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!
-! hchuang code change
-!
-!      do k = 1, km
-!        do i = 1, im
-!          if(cnvflg(i).and.rn(i).gt.0.) then
-!            if(k.ge.kb(i) .and. k.lt.ktop(i)) then
-!              ud_mf(i,k) = eta(i,k) * xmb(i) * dt2
-!            endif
-!          endif
-!        enddo
-!      enddo
-!      do i = 1, im
-!        if(cnvflg(i).and.rn(i).gt.0.) then
-!           k = ktop(i)-1
-!           dt_mf(i,k) = ud_mf(i,k)
-!        endif
-!      enddo
-!      do k = 1, km
-!        do i = 1, im
-!          if(cnvflg(i).and.rn(i).gt.0.) then
-!            if(k.ge.1 .and. k.le.jmin(i)) then
-!              dd_mf(i,k) = edto(i) * etad(i,k) * xmb(i) * dt2
-!            endif
-!          endif
-!        enddo
-!      enddo
-!!
-      return
-      end subroutine sascnvn      
-
-      subroutine shalcnv(im,ix,km,jcap,delt,del,prsl,ps,phil,ql,   &
-     &     q1,t1,u1,v1,rcs,rn,kbot,ktop,kcnv,slimsk,               &
-     &     dot,ncloud,hpbl,heat,evap,pgcon)
-!
-      use MODULE_GFS_machine , only : kind_phys
-      use MODULE_GFS_funcphys , only : fpvs
-      use MODULE_GFS_physcons, grav => con_g, cp => con_cp, hvap => con_hvap         &
-     &,             rv => con_rv, fv => con_fvirt, t0c => con_t0c         &
-     &,             rd => con_rd, cvap => con_cvap, cliq => con_cliq      &
-     &,             eps => con_eps, epsm1 => con_epsm1
-      implicit none
-!
-      integer            im, ix,  km, jcap, ncloud,                       &
-     &                   kbot(im), ktop(im), kcnv(im)                   
-      real(kind=kind_phys) delt
-      real(kind=kind_phys) ps(im),     del(ix,km),  prsl(ix,km),          &
-     &                     ql(ix,km,2),q1(ix,km),   t1(ix,km),            &
-     &                     u1(ix,km),  v1(ix,km),   rcs(im),              &
-     &                     rn(im),     slimsk(im),                        &
-     &                     dot(ix,km), phil(ix,km), hpbl(im),             &
-     &                     heat(im),   evap(im)                           
-!     &,                    ud_mf(im,km),dt_mf(im,km)
-
-      real  ud_mf(im,km),dt_mf(im,km)
-!
-      integer              i,j,indx, jmn, k, kk, latd, lond, km1
-      integer              kpbl(im)
-!
-      real(kind=kind_phys) c0,      cpoel,   dellat,  delta,        &
-     &                     desdt,   deta,    detad,   dg,           &
-     &                     dh,      dhh,     dlnsig,  dp,           &
-     &                     dq,      dqsdp,   dqsdt,   dt,           &
-     &                     dt2,     dtmax,   dtmin,   dv1h,         &
-     &                     dv1q,    dv2h,    dv2q,    dv1u,         &
-     &                     dv1v,    dv2u,    dv2v,    dv3q,         &
-     &                     dv3h,    dv3u,    dv3v,    clam,         &
-     &                     dz,      dz1,     e1,                    &
-     &                     el2orc,  elocp,   aafac,   cthk,         &
-     &                     es,      etah,    h1,      dthk,         &
-     &                     evef,    evfact,  evfactl, fact1,        &
-     &                     fact2,   factor,  fjcap,                 &
-     &                     g,       gamma,   pprime,  betaw,        &
-     &                     qlk,     qrch,    qs,      c1,           &
-     &                     rain,    rfact,   shear,   tem1,         &
-     &                     tem2,    terr,    val,     val1,         &
-     &                     val2,    w1,      w1l,     w1s,          &
-     &                     w2,      w2l,     w2s,     w3,           &
-     &                     w3l,     w3s,     w4,      w4l,          &
-     &                     w4s,     tem,     ptem,    ptem1,        &
-     &                     pgcon
-!
-      integer              kb(im), kbcon(im), kbcon1(im),           &
-     &                     ktcon(im), ktcon1(im),                   &
-     &                     kbm(im), kmax(im)
-!
-      real(kind=kind_phys) aa1(im),                                 &
-     &                     delhbar(im), delq(im),   delq2(im),      &
-     &                     delqbar(im), delqev(im), deltbar(im),    &
-     &                     deltv(im),   edt(im),                    &
-     &                     wstar(im),   sflx(im),                   &
-     &                     pdot(im),    po(im,km),                  &
-     &                     qcond(im),   qevap(im),  hmax(im),       &
-     &                     rntot(im),   vshear(im),                 &
-     &                     xlamud(im),  xmb(im),    xmbmax(im),     &
-     &                     delubar(im), delvbar(im)
-!c
-      real(kind=kind_phys) cincr, cincrmax, cincrmin
-!cc
-!c  physical parameters
-      parameter(g=grav)
-      parameter(cpoel=cp/hvap,elocp=hvap/cp,                            &
-     &          el2orc=hvap*hvap/(rv*cp))
-      parameter(terr=0.,c0=.002,c1=5.e-4,delta=fv)
-      parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c)
-      parameter(cthk=50.,cincrmax=180.,cincrmin=120.,dthk=25.)
-      parameter(h1=0.33333333)
-!c  local variables and arrays
-      real(kind=kind_phys) pfld(im,km),    to(im,km),     qo(im,km),    &
-     &                     uo(im,km),      vo(im,km),     qeso(im,km)
-!c  cloud water
-      real(kind=kind_phys) qlko_ktcon(im), dellal(im,km),                   &
-     &                     dbyo(im,km),    zo(im,km),     xlamue(im,km),    &
-     &                     heo(im,km),     heso(im,km),                     &
-     &                     dellah(im,km),  dellaq(im,km),                   &
-     &                     dellau(im,km),  dellav(im,km), hcko(im,km),      &
-     &                     ucko(im,km),    vcko(im,km),   qcko(im,km),      &
-     &                     eta(im,km),     zi(im,km),     pwo(im,km),       &
-     &                     tx1(im)
-!
-      logical totflg, cnvflg(im), flg(im)
-!
-      real(kind=kind_phys) tf, tcr, tcrf
-      parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf))
-!
-!c-----------------------------------------------------------------------
-!
-      km1 = km - 1
-!c
-!c  compute surface buoyancy flux
-!c
-      do i=1,im
-        sflx(i) = heat(i)+fv*t1(i,1)*evap(i)
-      enddo
-!c
-!c  initialize arrays
-!c
-      do i=1,im
-        cnvflg(i) = .true.
-        if(kcnv(i).eq.1) cnvflg(i) = .false.
-        if(sflx(i).le.0.) cnvflg(i) = .false.
-        if(cnvflg(i)) then
-          kbot(i)=km+1
-          ktop(i)=0
-        endif
-        rn(i)=0.
-        kbcon(i)=km
-        ktcon(i)=1
-        kb(i)=km
-        pdot(i) = 0.
-        qlko_ktcon(i) = 0.
-        edt(i)  = 0.
-        aa1(i)  = 0.
-        vshear(i) = 0.
-      enddo
-! hchuang code change
-      do k = 1, km
-        do i = 1, im
-          ud_mf(i,k) = 0.
-          dt_mf(i,k) = 0.
-        enddo
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-      dt2   = delt
-      val   =         1200.
-      dtmin = max(dt2, val )
-      val   =         3600.
-      dtmax = max(dt2, val )
-!c  model tunable parameters are all here
-      clam    = .3
-      aafac   = .1
-      betaw   = .03
-!c     evef    = 0.07
-      evfact  = 0.3
-      evfactl = 0.3
-!
-      fjcap   = (float(jcap) / 126.) ** 2
-      val     =           1.
-      fjcap   = max(fjcap,val)
-      w1l     = -8.e-3 
-      w2l     = -4.e-2
-      w3l     = -5.e-3 
-      w4l     = -5.e-4
-      w1s     = -2.e-4
-      w2s     = -2.e-3
-      w3s     = -1.e-3
-      w4s     = -2.e-5
-!c
-!c  define top layer for search of the downdraft originating layer
-!c  and the maximum thetae for updraft
-!c
-      do i=1,im
-        kbm(i)   = km
-        kmax(i)  = km
-        tx1(i)   = 1.0 / ps(i)
-      enddo
-!     
-      do k = 1, km
-        do i=1,im
-          if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i)   = k + 1
-          if (prsl(i,k)*tx1(i) .gt. 0.60) kmax(i)  = k + 1
-        enddo
-      enddo
-      do i=1,im
-        kbm(i)   = min(kbm(i),kmax(i))
-      enddo
-!c
-!!c  hydrostatic height assume zero terr and compute
-!c  updraft entrainment rate as an inverse function of height
-!c
-      do k = 1, km
-        do i=1,im
-          zo(i,k) = phil(i,k) / g
-        enddo
-      enddo
-      do k = 1, km1
-        do i=1,im
-          zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1))
-          xlamue(i,k) = clam / zi(i,k)
-        enddo
-      enddo
-      do i=1,im
-        xlamue(i,km) = xlamue(i,km1)
-      enddo
-!c
-!c  pbl height
-!c
-      do i=1,im
-        flg(i) = cnvflg(i)
-        kpbl(i)= 1
-      enddo
-      do k = 2, km1
-        do i=1,im
-          if (flg(i).and.zo(i,k).le.hpbl(i)) then
-            kpbl(i) = k
-          else
-            flg(i) = .false.
-          endif
-        enddo
-      enddo
-      do i=1,im
-        kpbl(i)= min(kpbl(i),kbm(i))
-      enddo
-!c
-!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!c   convert surface pressure to mb from cb
-!c
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            pfld(i,k) = prsl(i,k) * 10.0
-            eta(i,k)  = 1.
-            hcko(i,k) = 0.
-            qcko(i,k) = 0.
-            ucko(i,k) = 0.
-            vcko(i,k) = 0.
-            dbyo(i,k) = 0.
-            pwo(i,k)  = 0.
-            dellal(i,k) = 0.
-            to(i,k)   = t1(i,k)
-            qo(i,k)   = q1(i,k)
-            uo(i,k)   = u1(i,k) * rcs(i)
-            vo(i,k)   = v1(i,k) * rcs(i)
-          endif
-        enddo
-      enddo
-!c
-!c  column variables
-!c  p is pressure of the layer (mb)
-!c  t is temperature at t-dt (k)..tn
-!c  q is mixing ratio at t-dt (kg/kg)..qn
-!c  to is temperature at t+dt (k)... this is after advection and turbulan
-!c  qo is mixing ratio at t+dt (kg/kg)..q1
-!c
-      do k = 1, km
-        do i=1,im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
-            val1      =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val1)
-            val2      =           1.e-10
-            qo(i,k)   = max(qo(i,k), val2 )
-!           qo(i,k)   = min(qo(i,k),qeso(i,k))
-!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
-          endif
-        enddo
-      enddo
-!c
-!c  compute moist static energy
-!c
-      do k = 1, km
-        do i=1,im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-!           tem       = g * zo(i,k) + cp * to(i,k)
-            tem       = phil(i,k) + cp * to(i,k)
-            heo(i,k)  = tem  + hvap * qo(i,k)
-            heso(i,k) = tem  + hvap * qeso(i,k)
-!c           heo(i,k)  = min(heo(i,k),heso(i,k))
-          endif
-        enddo
-      enddo
-!c
-!c  determine level with largest moist static energy within pbl
-!c  this is the level where updraft starts
-!c
-      do i=1,im
-         if (cnvflg(i)) then
-            hmax(i) = heo(i,1)
-            kb(i) = 1
-         endif
-      enddo
-      do k = 2, km
-        do i=1,im
-          if (cnvflg(i).and.k.le.kpbl(i)) then
-            if(heo(i,k).gt.hmax(i)) then
-              kb(i)   = k
-              hmax(i) = heo(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!c
-      do k = 1, km1
-        do i=1,im
-          if (cnvflg(i) .and. k .le. kmax(i)-1) then
-            dz      = .5 * (zo(i,k+1) - zo(i,k))
-            dp      = .5 * (pfld(i,k+1) - pfld(i,k))
-            es      = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
-            pprime  = pfld(i,k+1) + epsm1 * es
-            qs      = eps * es / pprime
-            dqsdp   = - qs / pprime
-            desdt   = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
-            dqsdt   = qs * pfld(i,k+1) * desdt / (es * pprime)
-            gamma   = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
-            dt      = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
-            dq      = dqsdt * dt + dqsdp * dp
-            to(i,k) = to(i,k+1) + dt
-            qo(i,k) = qo(i,k+1) + dq
-            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
-          endif
-        enddo
-      enddo
-!
-      do k = 1, km1
-        do i=1,im
-          if (cnvflg(i) .and. k .le. kmax(i)-1) then
-            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k))
-            val1      =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val1)
-            val2      =           1.e-10
-            qo(i,k)   = max(qo(i,k), val2 )
-!           qo(i,k)   = min(qo(i,k),qeso(i,k))
-            heo(i,k)  = .5 * g * (zo(i,k) + zo(i,k+1)) +                  &
-     &                  cp * to(i,k) + hvap * qo(i,k)
-            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +                  &
-     &                  cp * to(i,k) + hvap * qeso(i,k)
-            uo(i,k)   = .5 * (uo(i,k) + uo(i,k+1))
-            vo(i,k)   = .5 * (vo(i,k) + vo(i,k+1))
-          endif
-        enddo
-      enddo
-!c
-!c  look for the level of free convection as cloud base
-!c
-      do i=1,im
-        flg(i)   = cnvflg(i)
-        if(flg(i)) kbcon(i) = kmax(i)
-      enddo
-      do k = 2, km1
-        do i=1,im
-          if (flg(i).and.k.lt.kbm(i)) then
-            if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then
-              kbcon(i) = k
-              flg(i)   = .false.
-            endif
-          endif
-        enddo
-      enddo
-!c
-      do i=1,im
-        if(cnvflg(i)) then
-          if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false.
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  determine critical convective inhibition
-!c  as a function of vertical velocity at cloud base.
-!c
-      do i=1,im
-        if(cnvflg(i)) then
-          pdot(i)  = 10.* dot(i,kbcon(i))
-        endif
-      enddo
-      do i=1,im
-        if(cnvflg(i)) then
-          if(slimsk(i).eq.1.) then
-            w1 = w1l
-            w2 = w2l
-            w3 = w3l
-            w4 = w4l
-          else
-            w1 = w1s
-            w2 = w2s
-            w3 = w3s
-            w4 = w4s
-          endif
-          if(pdot(i).le.w4) then
-            ptem = (pdot(i) - w4) / (w3 - w4)
-          elseif(pdot(i).ge.-w4) then
-            ptem = - (pdot(i) + w4) / (w4 - w3)
-          else
-            ptem = 0.
-          endif
-          val1    =             -1.
-          ptem = max(ptem,val1)
-          val2    =             1.
-          ptem = min(ptem,val2)
-          ptem = 1. - ptem
-          ptem1= .5*(cincrmax-cincrmin)
-          cincr = cincrmax - ptem * ptem1
-          tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i))
-          if(tem1.gt.cincr) then
-             cnvflg(i) = .false.
-          endif
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  assume the detrainment rate for the updrafts to be same as 
-!c  the entrainment rate at cloud base
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          xlamud(i) = xlamue(i,kbcon(i))
-        endif
-      enddo
-!c
-!c  determine updraft mass flux for the subcloud layers
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.lt.kbcon(i).and.k.ge.kb(i)) then
-              dz       = zi(i,k+1) - zi(i,k)
-              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i)
-              eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c  compute mass flux above cloud base
-!c
-      do k = 2, km1
-        do i = 1, im
-         if(cnvflg(i))then
-           if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
-              dz       = zi(i,k) - zi(i,k-1)
-              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i)
-              eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
-           endif
-         endif
-        enddo
-      enddo
-!c
-!c  compute updraft cloud property
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          indx         = kb(i)
-          hcko(i,indx) = heo(i,indx)
-          ucko(i,indx) = uo(i,indx)
-          vcko(i,indx) = vo(i,indx)
-        endif
-      enddo
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.kmax(i)) then
-              dz   = zi(i,k) - zi(i,k-1)
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              ptem = 0.5 * tem + pgcon
-              ptem1= 0.5 * tem - pgcon
-              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*                        &
-     &                     (heo(i,k)+heo(i,k-1)))/factor
-              ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k)                    &
-     &                     +ptem1*uo(i,k-1))/factor
-              vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k)                    &
-     &                     +ptem1*vo(i,k-1))/factor
-              dbyo(i,k) = hcko(i,k) - heso(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c   taking account into convection inhibition due to existence of
-!c    dry layers below cloud base
-!c
-      do i=1,im
-        flg(i) = cnvflg(i)
-        kbcon1(i) = kmax(i)
-      enddo
-      do k = 2, km1
-      do i=1,im
-        if (flg(i).and.k.lt.kbm(i)) then
-          if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
-            kbcon1(i) = k
-            flg(i)    = .false.
-          endif
-        endif
-      enddo
-      enddo
-      do i=1,im
-        if(cnvflg(i)) then
-          if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false.
-        endif
-      enddo
-      do i=1,im
-        if(cnvflg(i)) then
-          tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i))
-          if(tem.gt.dthk) then
-             cnvflg(i) = .false.
-          endif
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i = 1, im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  determine first guess cloud top as the level of zero buoyancy
-!c    limited to the level of sigma=0.7
-!c
-      do i = 1, im
-        flg(i) = cnvflg(i)
-        if(flg(i)) ktcon(i) = kbm(i)
-      enddo
-      do k = 2, km1
-      do i=1,im
-        if (flg(i).and.k .lt. kbm(i)) then
-          if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then
-             ktcon(i) = k
-             flg(i)   = .false.
-          endif
-        endif
-      enddo
-      enddo
-!c
-!c  turn off shallow convection if cloud top is less than pbl top
-!c
-     do i=1,im
-       if(cnvflg(i)) then
-         kk = kpbl(i)+1
-         if(ktcon(i).le.kk) cnvflg(i) = .false.
-       endif
-     enddo
-! c
-! c  turn off shallow convection if cloud depth is less than
-! c    a threshold value (cthk)
-! c
-       do i = 1, im
-         if(cnvflg(i)) then
-           tem = pfld(i,kbcon(i))-pfld(i,ktcon(i))
-           if(tem.lt.cthk) cnvflg(i) = .false.
-         endif
-       enddo
-!!
-     totflg = .true.
-     do i = 1, im
-       totflg = totflg .and. (.not. cnvflg(i))
-     enddo
-     if(totflg) return
-!!
-!c
-!c  specify upper limit of mass flux at cloud base
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-!         xmbmax(i) = .1
-!
-          k = kbcon(i)
-          dp = 1000. * del(i,k)
-          xmbmax(i) = dp / (g * dt2)
-!
-!         tem = dp / (g * dt2)
-!         xmbmax(i) = min(tem, xmbmax(i))
-        endif
-      enddo
-!c
-!c  compute cloud moisture property and precipitation
-!c
-      do i = 1, im
-        if (cnvflg(i)) then
-          aa1(i) = 0.
-          qcko(i,kb(i)) = qo(i,kb(i))
-        endif
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
-              dz    = zi(i,k) - zi(i,k-1)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrch = qeso(i,k)                                      &
-     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
-!cj
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*           &
-     &                     (qo(i,k)+qo(i,k-1)))/factor
-!cj
-              dq = eta(i,k) * (qcko(i,k) - qrch)
-!c
-!             rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k)
-!c
-!c  below lfc check if there is excess moisture to release latent heat
-!c
-              if(k.ge.kbcon(i).and.dq.gt.0.) then
-                etah = .5 * (eta(i,k) + eta(i,k-1))
-                if(ncloud.gt.0.) then
-                  dp = 1000. * del(i,k)
-                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
-                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
-                else
-                  qlk = dq / (eta(i,k) + etah * c0 * dz)
-                endif
-                aa1(i) = aa1(i) - dz * g * qlk
-                qcko(i,k)= qlk + qrch
-                pwo(i,k) = etah * c0 * dz * qlk
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c  calculate cloud work function
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
-              dz1 = zo(i,k+1) - zo(i,k)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              rfact =  1. + delta * cp * gamma                 &
-     &                 * to(i,k) / hvap
-              aa1(i) = aa1(i) +                                &
-     &                 dz1 * (g / (cp * to(i,k)))              &
-     &                 * dbyo(i,k) / (1. + gamma)              &
-     &                 * rfact
-              val = 0.
-              aa1(i)=aa1(i)+                                   &
-     &                 dz1 * g * delta *                       &
-     &                 max(val,(qeso(i,k) - qo(i,k)))
-            endif
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  estimate the onvective overshooting as the level
-!c    where the [aafac * cloud work function] becomes zero,
-!c    which is the final cloud top
-!c    limited to the level of sigma=0.7
-!c
-      do i = 1, im
-        if (cnvflg(i)) then
-          aa1(i) = aafac * aa1(i)
-        endif
-      enddo
-!c
-      do i = 1, im
-        flg(i) = cnvflg(i)
-        ktcon1(i) = kbm(i)
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (flg(i)) then
-            if(k.ge.ktcon(i).and.k.lt.kbm(i)) then
-              dz1 = zo(i,k+1) - zo(i,k)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              rfact =  1. + delta * cp * gamma                            &
-     &                 * to(i,k) / hvap
-              aa1(i) = aa1(i) +                                           &
-     &                 dz1 * (g / (cp * to(i,k)))                         &
-     &                 * dbyo(i,k) / (1. + gamma)                         &
-     &                 * rfact
-              if(aa1(i).lt.0.) then
-                ktcon1(i) = k
-                flg(i) = .false.
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c  compute cloud moisture property, detraining cloud water
-!c    and precipitation in overshooting layers
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
-              dz    = zi(i,k) - zi(i,k-1)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrch = qeso(i,k)                                            &
-     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
-!cj
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                  &
-     &                     (qo(i,k)+qo(i,k-1)))/factor
-!cj
-              dq = eta(i,k) * (qcko(i,k) - qrch)
-!c
-!c  check if there is excess moisture to release latent heat
-!c
-              if(dq.gt.0.) then
-                etah = .5 * (eta(i,k) + eta(i,k-1))
-                if(ncloud.gt.0.) then
-                  dp = 1000. * del(i,k)
-                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
-                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
-                else
-                  qlk = dq / (eta(i,k) + etah * c0 * dz)
-                endif
-                qcko(i,k) = qlk + qrch
-                pwo(i,k) = etah * c0 * dz * qlk
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c exchange ktcon with ktcon1
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          kk = ktcon(i)
-          ktcon(i) = ktcon1(i)
-          ktcon1(i) = kk
-        endif
-      enddo
-!c
-!c  this section is ready for cloud water
-!c
-      if(ncloud.gt.0) then
-!c
-!c  compute liquid and vapor separation at cloud top
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          k = ktcon(i) - 1
-          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-          qrch = qeso(i,k)                                             &
-     &         + gamma * dbyo(i,k) / (hvap * (1. + gamma))
-          dq = qcko(i,k) - qrch
-!c
-!c  check if there is excess moisture to release latent heat
-!c
-          if(dq.gt.0.) then
-            qlko_ktcon(i) = dq
-            qcko(i,k) = qrch
-          endif
-        endif
-      enddo
-      endif
-!!c
-!c--- compute precipitation efficiency in terms of windshear
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          vshear(i) = 0.
-        endif
-      enddo
-      do k = 2, km
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.le.ktcon(i)) then
-              shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2                       &
-     &                  + (vo(i,k)-vo(i,k-1)) ** 2)
-              vshear(i) = vshear(i) + shear
-            endif
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvflg(i)) then
-          vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
-          e1=1.591-.639*vshear(i)                                               &
-     &       +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
-          edt(i)=1.-e1
-          val =         .9
-          edt(i) = min(edt(i),val)
-          val =         .0
-          edt(i) = max(edt(i),val)
-        endif
-      enddo
-!c
-!c--- what would the change be, that a cloud with unit mass
-!c--- will do to the environment?
-!c
-      do k = 1, km
-        do i = 1, im
-          if(cnvflg(i) .and. k .le. kmax(i)) then
-            dellah(i,k) = 0.
-            dellaq(i,k) = 0.
-            dellau(i,k) = 0.
-            dellav(i,k) = 0.
-          endif
-        enddo
-      enddo
-!c
-!c--- changed due to subsidence and entrainment
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
-              dp = 1000. * del(i,k)
-              dz = zi(i,k) - zi(i,k-1)
-!c
-              dv1h = heo(i,k)
-              dv2h = .5 * (heo(i,k) + heo(i,k-1))
-              dv3h = heo(i,k-1)
-              dv1q = qo(i,k)
-              dv2q = .5 * (qo(i,k) + qo(i,k-1))
-              dv3q = qo(i,k-1)
-              dv1u = uo(i,k)
-              dv2u = .5 * (uo(i,k) + uo(i,k-1))
-              dv3u = uo(i,k-1)
-              dv1v = vo(i,k)
-              dv2v = .5 * (vo(i,k) + vo(i,k-1))
-              dv3v = vo(i,k-1)
-!c
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1))
-              tem1 = xlamud(i)
-!cj
-              dellah(i,k) = dellah(i,k) +                        &
-     &     ( eta(i,k)*dv1h - eta(i,k-1)*dv3h                     &
-     &    -  tem*eta(i,k-1)*dv2h*dz                              &
-     &    +  tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz       &
-     &         ) *g/dp
-!cj
-              dellaq(i,k) = dellaq(i,k) +                        &
-     &     ( eta(i,k)*dv1q - eta(i,k-1)*dv3q                     &
-     &    -  tem*eta(i,k-1)*dv2q*dz                              &
-     &    +  tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz       &
-     &         ) *g/dp
-!cj
-              dellau(i,k) = dellau(i,k) +                        &
-     &     ( eta(i,k)*dv1u - eta(i,k-1)*dv3u                     &
-     &    -  tem*eta(i,k-1)*dv2u*dz                              &
-     &    +  tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz       &
-     &    -  pgcon*eta(i,k-1)*(dv1u-dv3u)                        &
-     &         ) *g/dp
-!cj
-              dellav(i,k) = dellav(i,k) +                        &
-     &     ( eta(i,k)*dv1v - eta(i,k-1)*dv3v                     &
-     &    -  tem*eta(i,k-1)*dv2v*dz                              &
-     &    +  tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz       &
-     &    -  pgcon*eta(i,k-1)*(dv1v-dv3v)                        &
-     &         ) *g/dp
-!cj
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c------- cloud top
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          indx = ktcon(i)
-          dp = 1000. * del(i,indx)
-          dv1h = heo(i,indx-1)
-          dellah(i,indx) = eta(i,indx-1) *                      &
-     &                     (hcko(i,indx-1) - dv1h) * g / dp
-          dv1q = qo(i,indx-1)
-          dellaq(i,indx) = eta(i,indx-1) *                      &
-     &                     (qcko(i,indx-1) - dv1q) * g / dp
-          dv1u = uo(i,indx-1)
-          dellau(i,indx) = eta(i,indx-1) *                      &
-     &                     (ucko(i,indx-1) - dv1u) * g / dp
-          dv1v = vo(i,indx-1)
-          dellav(i,indx) = eta(i,indx-1) *                      &
-     &                     (vcko(i,indx-1) - dv1v) * g / dp
-!c
-!c  cloud water
-!c
-          dellal(i,indx) = eta(i,indx-1) *                      &
-     &                     qlko_ktcon(i) * g / dp
-        endif
-      enddo
-!c
-!c  mass flux at cloud base for shallow convection
-!c  (Grant, 2001)
-!c
-      do i= 1, im
-        if(cnvflg(i)) then
-          k = kbcon(i)
-!         ptem = g*sflx(i)*zi(i,k)/t1(i,1)
-          ptem = g*sflx(i)*hpbl(i)/t1(i,1)
-          wstar(i) = ptem**h1
-          tem = po(i,k)*100. / (rd*t1(i,k))
-          xmb(i) = betaw*tem*wstar(i)
-          xmb(i) = min(xmb(i),xmbmax(i))
-        endif
-      enddo
-!c
-!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!c
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
-            val     =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val )
-          endif
-        enddo
-      enddo
-!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!c
-      do i = 1, im
-        delhbar(i) = 0.
-        delqbar(i) = 0.
-        deltbar(i) = 0.
-        delubar(i) = 0.
-        delvbar(i) = 0.
-        qcond(i) = 0.
-      enddo
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.le.ktcon(i)) then
-              dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp
-              t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2
-              q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2
-              tem = 1./rcs(i)
-              u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem
-              v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem
-              dp = 1000. * del(i,k)
-              delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g
-              delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g
-              deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g
-              delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g
-              delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g
-            endif
-          endif
-        enddo
-      enddo
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.le.ktcon(i)) then
-              qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
-              qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k))
-              val     =             1.e-8
-              qeso(i,k) = max(qeso(i,k), val )
-            endif
-          endif
-        enddo
-      enddo
-!c
-      do i = 1, im
-        rntot(i) = 0.
-        delqev(i) = 0.
-        delq2(i) = 0.
-        flg(i) = cnvflg(i)
-      enddo
-      do k = km, 1, -1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.lt.ktcon(i).and.k.gt.kb(i)) then
-              rntot(i) = rntot(i) + pwo(i,k) * xmb(i) * .001 * dt2
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c evaporating rain
-!c
-      do k = km, 1, -1
-        do i = 1, im
-          if (k .le. kmax(i)) then
-            deltv(i) = 0.
-            delq(i) = 0.
-            qevap(i) = 0.
-            if(cnvflg(i)) then
-              if(k.lt.ktcon(i).and.k.gt.kb(i)) then
-                rn(i) = rn(i) + pwo(i,k) * xmb(i) * .001 * dt2
-              endif
-            endif
-            if(flg(i).and.k.lt.ktcon(i)) then
-              evef = edt(i) * evfact
-              if(slimsk(i).eq.1.) evef=edt(i) * evfactl
-!             if(slimsk(i).eq.1.) evef=.07
-!c             if(slimsk(i).ne.1.) evef = 0.
-              qcond(i) = evef * (q1(i,k) - qeso(i,k))                            &
-     &                 / (1. + el2orc * qeso(i,k) / t1(i,k)**2)
-              dp = 1000. * del(i,k)
-              if(rn(i).gt.0..and.qcond(i).lt.0.) then
-                qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i))))
-                qevap(i) = min(qevap(i), rn(i)*1000.*g/dp)
-                delq2(i) = delqev(i) + .001 * qevap(i) * dp / g
-              endif
-              if(rn(i).gt.0..and.qcond(i).lt.0..and.                            &
-     &           delq2(i).gt.rntot(i)) then
-                qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp
-                flg(i) = .false.
-              endif
-              if(rn(i).gt.0..and.qevap(i).gt.0.) then
-                tem  = .001 * dp / g
-                tem1 = qevap(i) * tem
-                if(tem1.gt.rn(i)) then
-                  qevap(i) = rn(i) / tem
-                  rn(i) = 0.
-                else
-                  rn(i) = rn(i) - tem1
-                endif
-                q1(i,k) = q1(i,k) + qevap(i)
-                t1(i,k) = t1(i,k) - elocp * qevap(i)
-                deltv(i) = - elocp*qevap(i)/dt2
-                delq(i) =  + qevap(i)/dt2
-                delqev(i) = delqev(i) + .001*dp*qevap(i)/g
-              endif
-              dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i)
-              delqbar(i) = delqbar(i) + delq(i)*dp/g
-              deltbar(i) = deltbar(i) + deltv(i)*dp/g
-            endif
-          endif
-        enddo
-      enddo
-!cj
-!     do i = 1, im
-!     if(me.eq.31.and.cnvflg(i)) then
-!     if(cnvflg(i)) then
-!       print *, ' shallow delhbar, delqbar, deltbar = ',
-!    &             delhbar(i),hvap*delqbar(i),cp*deltbar(i)
-!       print *, ' shallow delubar, delvbar = ',delubar(i),delvbar(i)
-!       print *, ' precip =', hvap*rn(i)*1000./dt2
-!       print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i))
-!     endif
-!     enddo
-!cj
-      do i = 1, im
-        if(cnvflg(i)) then
-          if(rn(i).lt.0..or..not.flg(i)) rn(i) = 0.
-          ktop(i) = ktcon(i)
-          kbot(i) = kbcon(i)
-          kcnv(i) = 0
-        endif
-      enddo
-!c
-!c  cloud water
-!c
-      if (ncloud.gt.0) then
-!
-      val1 = 1.0
-      val2 = 0.
-      do k = 1, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if (k.gt.kb(i).and.k.le.ktcon(i)) then
-              tem  = dellal(i,k) * xmb(i) * dt2
-!             tem1 = max(0.0,  min(1.0,  (tcr-t1(i,k))*tcrf))
-              tem1 = max(val2, min(val1, (tcr-t1(i,k))*tcrf))
-              if (ql(i,k,2) .gt. -999.0) then
-                ql(i,k,1) = ql(i,k,1) + tem * tem1            ! ice
-                ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1)       ! water
-              else
-                ql(i,k,1) = ql(i,k,1) + tem
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!
-      endif
-!
-! hchuang code change
-!
-      do k = 1, km
-        do i = 1, im
-          if(cnvflg(i)) then
-            if(k.ge.kb(i) .and. k.lt.ktop(i)) then
-              ud_mf(i,k) = eta(i,k) * xmb(i) * dt2
-            endif
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvflg(i)) then
-           k = ktop(i)-1
-           dt_mf(i,k) = ud_mf(i,k)
-        endif
-      enddo
-!!
-      return
-    end subroutine shalcnv
-
-      subroutine sascnvn_h(im,ix,km,jcap,delt,del,prsl,ps,phil,ql, &
-     &     q1,t1,u1,v1,rcs,cldwrk,rn,kbot,ktop,kcnv,slimsk,        &
-     &     dot,ncloud,pgcon,sas_mass_flux)
-!     &     dot,ncloud,pgcon,sas_mass_flux,sigma,jqfliu)
-!     &     dot,ncloud,sigma,pgcon,sas_mass_flux)
-!    &     dot,ncloud,ud_mf,dd_mf,dt_mf,me)
-!
-! Version 20120809
-!  Modified on 20120803 to add dbyod, include definition of heotd to jmin level, and fix bug
-!   on the calculation of qotd
-!  Modified on 20120807 to fix bug in the dhdt calculation
-!
-!  Adding in consistency with the pwo, pwdo so rain is consistent with heating and drying
-!  after the tilda terms are computed.
-!
-!  20120822
-!   Turns off SAS when sigma is greater than .9
-!   Correct cloud top cloud water detrainment
-!
-!      use machine , only : kind_phys
-!      use funcphys , only : fpvs
-!      use physcons, grav => con_g, cp => con_cp, hvap => con_hvap  &
-      USE MODULE_GFS_MACHINE, ONLY : kind_phys
-      USE MODULE_GFS_FUNCPHYS, ONLY : fpvs
-      USE MODULE_GFS_PHYSCONS, grav => con_g, cp => con_cp         &
-     &,             hvap => con_hvap                               &
-     &,             rv => con_rv, fv => con_fvirt, t0c => con_t0c  &
-     &,             cvap => con_cvap, cliq => con_cliq             &
-     &,             eps => con_eps, epsm1 => con_epsm1             &
-     &,             rd => con_rd
-      implicit none
-!
-      integer            im, ix,  km, jcap, ncloud,                &
-     &                   kbot(im), ktop(im), kcnv(im),jqfliu
-!    &,                  me
-      real(kind=kind_phys) delt, sas_mass_flux
-      real(kind=kind_phys) ps(im),     del(ix,km),  prsl(ix,km),   &
-     &                     ql(ix,km,2),q1(ix,km),   t1(ix,km),     &
-     &                     u1(ix,km),  v1(ix,km),   rcs(im),       &
-     &                     cldwrk(im), rn(im),      slimsk(im),    &
-     &                     dot(ix,km), phil(ix,km)                 &
-! hchuang code change mass flux output
-     &,                    ud_mf(im,km),dd_mf(im,km),dt_mf(im,km)
-!
-      integer              i, j, indx, jmn, k, kk, latd, lond, km1
-!
-      real(kind=kind_phys) clam, cxlamu, xlamde, xlamdd
-!
-      real(kind=kind_phys) adw,     aup,     aafac,                &
-     &                     beta,    betal,   betas,                &
-     &                     c0,      cpoel,   dellat,  delta,       &
-     &                     desdt,   deta,    detad,   dg,          &
-     &                     dh,      dhh,     dlnsig,  dp,          &
-     &                     dq,      dqsdp,   dqsdt,   dt,          &
-     &                     dt2,     dtmax,   dtmin,   dv1h,        &
-     &                     dv1q,    dv2h,    dv2q,    dv1u,        &
-     &                     dv1v,    dv2u,    dv2v,    dv3q,        &
-     &                     dv3h,    dv3u,    dv3v,                 &
-     &                     dv1hd,   dv1qd,   dv2hd,   dv2qd,       &
-     &                     dv1ud,   dv1vd,   dv2ud,   dv2vd,       &
-     &                     dv3hd,   dv3qd,   dv3ud,   dv3vd,       &
-     &                     dz,      dz1,     e1,      edtmax,      &
-     &                     edtmaxl, edtmaxs, el2orc,  elocp,       &
-     &                     es,      etah,    cthk,    dthk,        &
-     &                     evef,    evfact,  evfactl, fact1,       &
-     &                     fact2,   factor,  fjcap,   fkm,         &
-     &                     g,       gamma,   pprime,               &
-     &                     qlk,     qrch,    qs,      c1,          &
-     &                     rain,    rfact,   shear,   tem1,        &
-     &                     tem2,    terr,    val,     val1,        &
-     &                     val2,    w1,      w1l,     w1s,         &
-     &                     w2,      w2l,     w2s,     w3,          &
-     &                     w3l,     w3s,     w4,      w4l,         &
-     &                     w4s,     xdby,    xpw,     xpwd,        &
-     &                     xqrch,   armb,    ardt,    mbdt,        &
-     &                     delhz,   delqz,   deluz,   delvz,       &
-     &                     tem,     ptem,    ptem1
-!
-      real(kind=kind_phys), intent(in) :: pgcon
-!
-      integer              kb(im), kbcon(im), kbcon1(im),          &
-     &                     ktcon(im), ktcon1(im),                  &
-     &                     jmin(im), lmin(im), kbmax(im),          &
-     &                     kbm(im), kmax(im)
-!
-      real(kind=kind_phys) aa1(im),     acrt(im),   acrtfct(im),   &
-     &                     delhbar(im), delq(im),   delq2(im),     &
-     &                     delqbar(im), delqev(im), deltbar(im),   &
-     &                     deltv(im),   dtconv(im), edt(im),       &
-     &                     edto(im),    edtx(im),   fld(im),       &
-     &                     hcdo(im,km), hmax(im),   hmin(im),      &
-     &                     ucdo(im,km), vcdo(im,km),aa2(im),       &
-     &                     pbcdif(im),  pdot(im),   po(im,km),     &
-     &                     pwavo(im),   pwevo(im),  xlamud(im),    &
-     &                     qcdo(im,km), qcond(im),  qevap(im),     &
-     &                     rntot(im),   vshear(im), xaa0(im),      &
-     &                     xk(im),      xlamd(im),                 &
-     &                     xmb(im),     xmbmax(im), xpwav(im),     &
-     &                     xpwev(im),   delubar(im),delvbar(im)
-!cj
-      real(kind=kind_phys) cincr, cincrmax, cincrmin
-!cj
-!c  physical parameters
-      parameter(g=grav)
-      parameter(cpoel=cp/hvap,elocp=hvap/cp,                       &
-     &          el2orc=hvap*hvap/(rv*cp))
-      parameter(terr=0.,c0=.002,c1=.002,delta=fv)
-      parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c)
-      parameter(cthk=150.,cincrmax=180.,cincrmin=120.,dthk=25.)
-! Qingfu modified
-!      parameter(cthk=150.,cincrmax=160.,cincrmin=100.,dthk=25.)
-!c  local variables and arrays
-      real(kind=kind_phys) pfld(im,km),to(im,km), qo(im,km),       &
-     &                     uo(im,km),  vo(im,km), qeso(im,km)
-!c  cloud water
-      real(kind=kind_phys)qlko_ktcon(im),dellal(im,km),tvo(im,km), &
-     &                dbyo(im,km),  zo(im,km),     xlamue(im,km),  &
-     &                fent1(im,km), fent2(im,km),  frh(im,km),     &
-     &                heo(im,km),   heso(im,km),   doto(im,km-1),  &
-!c  heotu and qeotu are the environmental mean h and q for updraft
-!c  heotd and qeotd are the environmental mean h and q for downdraft
-     &                heotu(im,km), qotu(im,km),   uotu(im,km),    &
-     &                votu(im,km),  heotd(im,km),  qotd(im,km),    &
-     &                uotd(im,km),  votd(im,km),                   &
-     &                delhx(im,km), delqx(im,km),                  &
-     &                delux(im,km), delvx(im,km),                  &
-     &                qrcd(im,km),  dellah(im,km), dellaq(im,km),  &
-     &                dellau(im,km),dellav(im,km), hcko(im,km),    &
-     &                ucko(im,km),  vcko(im,km),   qcko(im,km),    &
-     &                eta(im,km),   etad(im,km),   zi(im,km),      &
-     &                qrcdo(im,km), pwo(im,km),    pwdo(im,km),    &
-     &                wc(im),       wbar(im),                      &
-     &                sigma(im),    sigi1(im),     sigi2(im),      &
-     &                tx1(im),      sumx(im),      dbyod(im,km)
-!    &,               rhbar(im)
-!
-      logical totflg, cnvflg(im), cnvdflg(im), flg(im)
-!
-      real(kind=kind_phys) pcrit(15), acritt(15), acrit(15)
-!     save pcrit, acritt
-      data pcrit/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,  &
-     &           350.,300.,250.,200.,150./
-      data acritt/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216,    &
-     &           .3151,.3677,.41,.5255,.7663,1.1686,1.6851/
-!c  gdas derived acrit
-!c     data acritt/.203,.515,.521,.566,.625,.665,.659,.688,
-!c    &            .743,.813,.886,.947,1.138,1.377,1.896/
-      real(kind=kind_phys) tf, tcr, tcrf
-      parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf))
-
-      real    sigma_sum
-!
-!c-----------------------------------------------------------------------
-!
-      km1 = km - 1
-!c
-!c  initialize arrays
-!c
-      do i=1,im
-        kcnv(i)=0
-        cnvflg(i) = .true.
-        rn(i)=0.
-        kbot(i)=km+1
-        ktop(i)=0
-        kbcon(i)=km
-        ktcon(i)=1
-        dtconv(i) = 3600.
-        cldwrk(i) = 0.
-        pdot(i) = 0.
-        pbcdif(i)= 0.
-        lmin(i) = 1
-        jmin(i) = 1
-        qlko_ktcon(i) = 0.
-        edt(i)  = 0.
-        edto(i) = 0.
-        edtx(i) = 0.
-        acrt(i) = 0.
-        acrtfct(i) = 1.
-        aa1(i)  = 0.
-        aa2(i)  = 0.
-        xaa0(i) = 0.
-        pwavo(i)= 0.
-        pwevo(i)= 0.
-        xpwav(i)= 0.
-        xpwev(i)= 0.
-        vshear(i) = 0.
-        wc(i) = 0.
-        wbar(i) = 0.
-        xmb(i) = 0.
-      enddo
-! hchuang code change
-      do k = 1, km
-        do i = 1, im
-          ud_mf(i,k) = 0.
-          dd_mf(i,k) = 0.
-          dt_mf(i,k) = 0.
-        enddo
-      enddo
-!c
-      do k = 1, 15
-        acrit(k) = acritt(k) * (975. - pcrit(k))
-      enddo
-      dt2 = delt
-      val   =         1200.
-      dtmin = max(dt2, val )
-      val   =         3600.
-      dtmax = max(dt2, val )
-!c  model tunable parameters are all here
-!      mbdt    = 10.
-      armb    = 1.             ! arbitrary cloud base mass flux
-      ardt    = 10.            ! arbitrary time step
-      mbdt    = armb * ardt
-      mbdt    = min(mbdt, dt2)
-      edtmaxl = .3
-      edtmaxs = .3
-      clam    = .1
-      aafac   = .1
-!     betal   = .15
-!     betas   = .15
-      betal   = .05
-      betas   = .05
-!c     evef    = 0.07
-      evfact  = 0.3
-      evfactl = 0.3
-!
-      cxlamu  = 1.0e-4
-      xlamde  = 1.0e-4
-      xlamdd  = 1.0e-4
-!
-      fjcap   = (float(jcap) / 126.) ** 2
-      val     =           1.
-      fjcap   = max(fjcap,val)
-      fkm     = (float(km) / 28.) ** 2
-      fkm     = max(fkm,val)
-      w1l     = -8.e-3
-      w2l     = -4.e-2
-      w3l     = -5.e-3
-      w4l     = -5.e-4
-      w1s     = -2.e-4
-      w2s     = -2.e-3
-      w3s     = -1.e-3
-      w4s     = -2.e-5
-!c
-!c  define top layer for search of the downdraft originating layer
-!c  and the maximum thetae for updraft
-!c
-      do i=1,im
-        kbmax(i) = km
-        kbm(i)   = km
-        kmax(i)  = km
-        tx1(i)   = 1.0 / ps(i)
-      enddo
-!
-      do k = 1, km1
-        do i=1,im
-          if (prsl(i,k)*tx1(i) .gt. 0.04) kmax(i)  = k + 1
-          if (prsl(i,k)*tx1(i) .gt. 0.45) kbmax(i) = k + 1
-          if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i)   = k + 1
-        enddo
-      enddo
-      do i=1,im
-        kbmax(i) = min(kbmax(i),kmax(i))
-        kbm(i)   = min(kbm(i),kmax(i))
-        kmax(i) = min(km,kmax(i))
-      enddo
-!c
-!c  hydrostatic height assume zero terr and initially assume
-!c    updraft entrainment rate as an inverse function of height
-!c
-      do k = 1, km
-        do i=1,im
-          zo(i,k) = phil(i,k) / g
-        enddo
-      enddo
-      do k = 1, km1
-        do i=1,im
-          zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1))
-          xlamue(i,k) = clam / zi(i,k)
-        enddo
-      enddo
-!c
-!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!c   convert surface pressure to mb from cb
-!c
-      do k = 1, km
-        do i = 1, im
-          if (k .le. kmax(i)) then
-            pfld(i,k) = prsl(i,k) * 10.0
-            eta(i,k)  = 1.
-            fent1(i,k)= 1.
-            fent2(i,k)= 1.
-            frh(i,k)  = 0.
-            hcko(i,k) = 0.
-            qcko(i,k) = 0.
-            ucko(i,k) = 0.
-            vcko(i,k) = 0.
-            etad(i,k) = 1.
-            hcdo(i,k) = 0.
-            qcdo(i,k) = 0.
-            ucdo(i,k) = 0.
-            vcdo(i,k) = 0.
-            qrcd(i,k) = 0.
-            qrcdo(i,k)= 0.
-            dbyo(i,k) = 0.
-            dbyod(i,k) = 0.
-            pwo(i,k)  = 0.
-            pwdo(i,k) = 0.
-            dellal(i,k) = 0.
-            to(i,k)   = t1(i,k)
-            qo(i,k)   = q1(i,k)
-            uo(i,k)   = u1(i,k) * rcs(i)
-            vo(i,k)   = v1(i,k) * rcs(i)
-            delhx(i,k) = 0.
-            delqx(i,k) = 0.
-            delux(i,k) = 0.
-            delvx(i,k) = 0.
-          endif
-        enddo
-      enddo
-!c
-!c  column variables
-!c  p is pressure of the layer (mb)
-!c  t is temperature at t-dt (k)..tn
-!c  q is mixing ratio at t-dt (kg/kg)..qn
-!c  to is temperature at t+dt (k)... this is after advection and turbulan
-!c  qo is mixing ratio at t+dt (kg/kg)..q1
-!c
-      do k = 1, km
-        do i=1,im
-          if (k .le. kmax(i)) then
-            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
-            val1      =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val1)
-            val2      =           1.e-10
-            qo(i,k)   = max(qo(i,k), val2 )
-!           qo(i,k)   = min(qo(i,k),qeso(i,k))
-!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
-          endif
-        enddo
-      enddo
-!c
-!c  compute moist static energy
-!c
-      do k = 1, km
-        do i=1,im
-          if (k .le. kmax(i)) then
-!           tem       = g * zo(i,k) + cp * to(i,k)
-            tem       = phil(i,k) + cp * to(i,k)
-            heo(i,k)  = tem  + hvap * qo(i,k)
-            heso(i,k) = tem  + hvap * qeso(i,k)
-!c           heo(i,k)  = min(heo(i,k),heso(i,k))
-          endif
-        enddo
-      enddo
-!c
-!c  determine level with largest moist static energy
-!c  this is the level where updraft starts
-!c
-      do i=1,im
-        hmax(i) = heo(i,1)
-        kb(i)   = 1
-      enddo
-      do k = 2, km
-        do i=1,im
-          if (k .le. kbm(i)) then
-            if(heo(i,k).gt.hmax(i)) then
-              kb(i)   = k
-              hmax(i) = heo(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!c
-      do k = 1, km1
-        do i=1,im
-          if (k .le. kmax(i)-1) then
-            dz      = .5 * (zo(i,k+1) - zo(i,k))
-            dp      = .5 * (pfld(i,k+1) - pfld(i,k))
-            es      = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
-            pprime  = pfld(i,k+1) + epsm1 * es
-            qs      = eps * es / pprime
-            dqsdp   = - qs / pprime
-            desdt   = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
-            dqsdt   = qs * pfld(i,k+1) * desdt / (es * pprime)
-            gamma   = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
-            dt      = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
-            dq      = dqsdt * dt + dqsdp * dp
-            to(i,k) = to(i,k+1) + dt
-            qo(i,k) = qo(i,k+1) + dq
-            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
-          endif
-        enddo
-      enddo
-!
-      do k = 1, km1
-        do i=1,im
-          if (k .le. kmax(i)-1) then
-            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k))
-            val1      =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val1)
-            val2      =           1.e-10
-            qo(i,k)   = max(qo(i,k), val2 )
-!           qo(i,k)   = min(qo(i,k),qeso(i,k))
-            val1      = 1.
-            frh(i,k)  = 1. - min(qo(i,k)/qeso(i,k), val1)
-            heo(i,k)  = .5 * g * (zo(i,k) + zo(i,k+1)) +            &
-     &                  cp * to(i,k) + hvap * qo(i,k)
-            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +            &
-     &                  cp * to(i,k) + hvap * qeso(i,k)
-            uo(i,k)   = .5 * (uo(i,k) + uo(i,k+1))
-            vo(i,k)   = .5 * (vo(i,k) + vo(i,k+1))
-            doto(i,k) = 1000. * dot(i,k+1)          ! pa/s
-          endif
-        enddo
-      enddo
-!c
-!c  initialize environmental property as grid mean value
-!c
-      do k = 1, km
-        do i=1,im
-          if (k .le. kmax(i)) then
-            heotu(i,k) = heo(i,k)
-            qotu(i,k) = qo(i,k)
-            uotu(i,k) = uo(i,k)
-            votu(i,k) = vo(i,k)
-            heotd(i,k) = heo(i,k)
-            qotd(i,k) = qo(i,k)
-            uotd(i,k) = uo(i,k)
-            votd(i,k) = vo(i,k)
-          endif
-        enddo
-      enddo
-!c
-!c  look for the level of free convection as cloud base
-!c
-      do i=1,im
-        flg(i)   = .true.
-        kbcon(i) = kmax(i)
-      enddo
-      do k = 1, km1
-        do i=1,im
-          if (flg(i).and.k.le.kbmax(i)) then
-            if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then
-              kbcon(i) = k
-              flg(i)   = .false.
-            endif
-          endif
-        enddo
-      enddo
-!c
-      do i=1,im
-        if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false.
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  determine critical convective inhibition
-!c  as a function of vertical velocity at cloud base.
-!c
-      do i=1,im
-        if(cnvflg(i)) then
-          pdot(i)  = 10.* dot(i,kbcon(i))
-        endif
-      enddo
-      do i=1,im
-        if(cnvflg(i)) then
-          if(slimsk(i).eq.1.) then
-            w1 = w1l
-            w2 = w2l
-            w3 = w3l
-            w4 = w4l
-          else
-            w1 = w1s
-            w2 = w2s
-            w3 = w3s
-            w4 = w4s
-          endif
-          if(pdot(i).le.w4) then
-            tem = (pdot(i) - w4) / (w3 - w4)
-          elseif(pdot(i).ge.-w4) then
-            tem = - (pdot(i) + w4) / (w4 - w3)
-          else
-            tem = 0.
-          endif
-          val1    =             -1.
-          tem = max(tem,val1)
-          val2    =             1.
-          tem = min(tem,val2)
-          tem = 1. - tem
-          tem1= .5*(cincrmax-cincrmin)
-          cincr = cincrmax - tem * tem1
-          pbcdif(i) = pfld(i,kb(i)) - pfld(i,kbcon(i))
-          if(pbcdif(i).gt.cincr) then
-             cnvflg(i) = .false.
-          endif
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  assume that updraft entrainment rate above cloud base is
-!c    same as that at cloud base
-!c
-      do k = 2, km1
-        do i=1,im
-          if(cnvflg(i).and.                                 &
-     &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
-              xlamue(i,k) = xlamue(i,kbcon(i))
-          endif
-        enddo
-      enddo
-!c
-!c  assume the detrainment rate for the updrafts to be same as
-!c  the entrainment rate at cloud base
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          xlamud(i) = xlamue(i,kbcon(i))
-        endif
-      enddo
-!c
-!c  functions rapidly decreasing with height, mimicking a cloud ensemble
-!c    (Bechtold et al., 2008)
-!c
-      val1=1.0
-      do k = 2, km1
-        do i=1,im
-          if(cnvflg(i).and.                                &
-     &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
-!              tem = qeso(i,k)/qeso(i,kbcon(i))
-              tem = min(val1,qeso(i,k)/qeso(i,kbcon(i)))
-              fent1(i,k) = tem**2
-              fent2(i,k) = tem**3
-          endif
-        enddo
-      enddo
-!c
-!c  final entrainment rate as the sum of turbulent part and organized entrainment
-!c    depending on the environmental relative humidity
-!c    (Bechtold et al., 2008)
-!c
-      do k = 2, km1
-        do i=1,im
-          if(cnvflg(i).and.                                &
-     &      (k.ge.kbcon(i).and.k.lt.kmax(i))) then
-              tem = cxlamu * frh(i,k) * fent2(i,k)
-              xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem
-          endif
-        enddo
-      enddo
-!c
-!c  determine updraft mass flux for the subcloud layers
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.lt.kbcon(i).and.k.ge.kb(i)) then
-              dz       = zi(i,k+1) - zi(i,k)
-              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i)
-              eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c  compute mass flux above cloud base
-!c
-      do k = 2, km1
-        do i = 1, im
-         if(cnvflg(i))then
-           if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
-              dz       = zi(i,k) - zi(i,k-1)
-              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i)
-              eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
-           endif
-         endif
-        enddo
-      enddo
-!c
-!c  compute updraft cloud properties
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          indx         = kb(i)
-          hcko(i,indx) = heo(i,indx)
-          ucko(i,indx) = uo(i,indx)
-          vcko(i,indx) = vo(i,indx)
-          pwavo(i)     = 0.
-        endif
-      enddo
-!c
-!c  cloud property is modified by the entrainment process
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.kmax(i)) then
-              dz   = zi(i,k) - zi(i,k-1)
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              ptem = 0.5 * tem + pgcon
-              ptem1= 0.5 * tem - pgcon
-              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*       &
-     &                     (heo(i,k)+heo(i,k-1)))/factor
-              ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uo(i,k)   &
-     &                     +ptem1*uo(i,k-1))/factor
-              vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*vo(i,k)   &
-     &                     +ptem1*vo(i,k-1))/factor
-              dbyo(i,k) = hcko(i,k) - heso(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c   taking account into convection inhibition due to existence of
-!c    dry layers below cloud base
-!c
-      do i=1,im
-        flg(i) = cnvflg(i)
-        kbcon1(i) = kmax(i)
-      enddo
-      do k = 2, km1
-      do i=1,im
-        if (flg(i).and.k.lt.kmax(i)) then
-          if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
-            kbcon1(i) = k
-            flg(i)    = .false.
-          endif
-        endif
-      enddo
-      enddo
-      do i=1,im
-        if(cnvflg(i)) then
-          if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false.
-        endif
-      enddo
-      do i=1,im
-        if(cnvflg(i)) then
-          tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i))
-          if(tem.gt.dthk) then
-             cnvflg(i) = .false.
-          endif
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i = 1, im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  determine first guess cloud top as the level of zero buoyancy
-!c
-      do i = 1, im
-        flg(i) = cnvflg(i)
-        ktcon(i) = 1
-      enddo
-      do k = 2, km1
-      do i = 1, im
-        if (flg(i).and.k .lt. kmax(i)) then
-          if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then
-             ktcon(i) = k
-             flg(i)   = .false.
-          endif
-        endif
-      enddo
-      enddo
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          tem = pfld(i,kbcon(i))-pfld(i,ktcon(i))
-          if(tem.lt.cthk) cnvflg(i) = .false.
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i = 1, im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  search for downdraft originating level above theta-e minimum
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-           hmin(i) = heo(i,kbcon1(i))
-           lmin(i) = kbmax(i)
-           jmin(i) = kbmax(i)
-        endif
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kbmax(i)) then
-            if(k.gt.kbcon1(i).and.heo(i,k).lt.hmin(i)) then
-               lmin(i) = k + 1
-               hmin(i) = heo(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c  make sure that jmin(i) is within the cloud
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          jmin(i) = min(lmin(i),ktcon(i)-1)
-          jmin(i) = max(jmin(i),kbcon1(i)+1)
-          if(jmin(i).ge.ktcon(i)) cnvflg(i) = .false.
-        endif
-      enddo
-!c
-!c  specify upper limit of mass flux at cloud base
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-!         xmbmax(i) = .1
-!
-          k = kbcon(i)
-          dp = 1000. * del(i,k)
-          xmbmax(i) = dp / (g * dt2)
-          xmbmax(i) = min(sas_mass_flux,xmbmax(i))
-!
-!         tem = dp / (g * dt2)
-!         xmbmax(i) = min(tem, xmbmax(i))
-        endif
-      enddo
-!c
-!c  compute cloud moisture property and precipitation
-!c
-      do i = 1, im
-        if (cnvflg(i)) then
-          aa1(i) = 0.
-          indx = kb(i)
-          qcko(i,indx) = qo(i,indx)
-          qcko(i,1) = qcko(i,indx)
-!         rhbar(i) = 0.
-        endif
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
-              dz    = zi(i,k) - zi(i,k-1)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrch = qeso(i,k)                                  &
-     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
-!cj
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*       &
-     &                     (qo(i,k)+qo(i,k-1)))/factor
-!cj
-              dq = eta(i,k) * (qcko(i,k) - qrch)
-!c
-!             rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k)
-!c
-!c  check if there is excess moisture to release latent heat
-!c
-              if(k.ge.kbcon(i).and.dq.gt.0.) then
-                etah = .5 * (eta(i,k) + eta(i,k-1))
-                if(ncloud.gt.0.and.k.gt.jmin(i)) then
-                  dp = 1000. * del(i,k)
-                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
-                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
-                else
-                  qlk = dq / (eta(i,k) + etah * c0 * dz)
-                endif
-                aa1(i) = aa1(i) - dz * g * qlk
-                qcko(i,k) = qlk + qrch
-                pwo(i,k) = etah * c0 * dz * qlk
-                pwavo(i) = pwavo(i) + pwo(i,k)
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!c
-!     do i = 1, im
-!       if(cnvflg(i)) then
-!         indx = ktcon(i) - kb(i) - 1
-!         rhbar(i) = rhbar(i) / float(indx)
-!       endif
-!     enddo
-!c
-!c  calculate cloud work function
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
-              dz1 = zo(i,k+1) - zo(i,k)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              rfact =  1. + delta * cp * gamma                &
-     &                 * to(i,k) / hvap
-              aa1(i) = aa1(i) +                               &
-     &                 dz1 * (g / (cp * to(i,k)))             &
-     &                 * dbyo(i,k) / (1. + gamma)             &
-     &                 * rfact
-              val = 0.
-              aa1(i)=aa1(i)+                                  &
-     &                 dz1 * g * delta *                      &
-     &                 max(val,(qeso(i,k) - qo(i,k)))
-            endif
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  calculate the updraft area sigma as a function of the updraft speed wc=sqrt(2*aa1 + wbar**2 (at cloud base))
-!c  and the area mean vertical wind speed wbar = -omega / (rho * g)
-!c
-!c  po is in the unit of mb and dot in the unit of cb/sec
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
-              tem = po(i,k) / (rd * to(i,k) * (1. + delta * qo(i,k)))
-              tem1 = - 10. * dot(i,k) / (tem * g)
-              wbar(i) = max(wbar(i),tem1)
-            endif
-          endif
-        enddo
-      enddo
-!
-!
-!c   cloud base updraft speed is added here. For the time being, we use the same wbar as above. This guarantee that
-!c   the calculated sigma never exceeds one.
-!
-      do i = 1, im
-        if(cnvflg(i)) then
-!          k = kbcon(i)
-!          tem = po(i,k) / (rd * to(i,k) * (1. + delta * qo(i,k)))
-!          tem1 = - 10. * dot(i,k) / (tem * g)
-!          wc(i) = sqrt(tem1*tem1+2.*aa1(i))
-          wc(i) = sqrt(wbar(i) * wbar(i) + 2. * aa1(i))
-        endif
-      enddo
-      sigma_sum=0.
-      val1=0.09
-!      val1=0.0
-      do i = 1, im
-        if(cnvflg(i).and.wc(i).gt.0.) then
-!
-!  Scale sigma assuming magnitude of w_tilda to be .1 w_c
-!
-          sigma(i) = .91 * wbar(i) / (wc(i) + 1.E-20) + .09
-!          sigma(i) = wbar(i) / (wc(i) + 1.E-20)
-          sigma(i) = max(sigma(i),val1)
-          if(sigma(i).gt.0.5.and.wbar(i).lt.10.)sigma(i)=0.5
-          if(sigma(i).gt.0.9) then
-            sigma(i)=0.9
-            cnvflg(i)=.false.
-          end if
-        endif
-        if(sigma_sum.lt.sigma(i))sigma_sum=sigma(i)
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  turn off downdraft if sigma is larger than 0.5
-!c
-      do i = 1, im
-        cnvdflg(i) = cnvflg(i)
-        if(cnvflg(i).and.sigma(i).gt.0.5) then
-          cnvdflg(i) = .false.
-        endif
-      enddo
-!c
-!c  estimate the onvective overshooting as the level
-!c    where the [aafac * cloud work function] becomes zero,
-!c    which is the final cloud top
-!c
-      do i = 1, im
-        if (cnvflg(i)) then
-          aa2(i) = aafac * aa1(i)
-        endif
-      enddo
-!c
-      do i = 1, im
-        flg(i) = cnvflg(i)
-        ktcon1(i) = kmax(i) - 1
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (flg(i)) then
-            if(k.ge.ktcon(i).and.k.lt.kmax(i)) then
-              dz1 = zo(i,k+1) - zo(i,k)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              rfact =  1. + delta * cp * gamma           &
-     &                 * to(i,k) / hvap
-              aa2(i) = aa2(i) +                          &
-     &                 dz1 * (g / (cp * to(i,k)))        &
-     &                 * dbyo(i,k) / (1. + gamma)        &
-     &                 * rfact
-              if(aa2(i).lt.0.) then
-                ktcon1(i) = k
-                flg(i) = .false.
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c  compute cloud moisture property, detraining cloud water
-!c    and precipitation in overshooting layers
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
-              dz    = zi(i,k) - zi(i,k-1)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrch = qeso(i,k)                               &
-     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
-!cj
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*    &
-     &                     (qo(i,k)+qo(i,k-1)))/factor
-!cj
-              dq = eta(i,k) * (qcko(i,k) - qrch)
-!c
-!c  check if there is excess moisture to release latent heat
-!c
-              if(dq.gt.0.) then
-                etah = .5 * (eta(i,k) + eta(i,k-1))
-                if(ncloud.gt.0) then
-                  dp = 1000. * del(i,k)
-                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
-                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
-                else
-                  qlk = dq / (eta(i,k) + etah * c0 * dz)
-                endif
-                qcko(i,k) = qlk + qrch
-                pwo(i,k) = etah * c0 * dz * qlk
-                pwavo(i) = pwavo(i) + pwo(i,k)
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c exchange ktcon with ktcon1
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          kk = ktcon(i)
-          ktcon(i) = ktcon1(i)
-          ktcon1(i) = kk
-        endif
-      enddo
-!c
-!c  this section is ready for cloud water
-!c
-      if(ncloud.gt.0) then
-!c
-!c  compute liquid and vapor separation at cloud top
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          k = ktcon(i) - 1
-          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-          qrch = qeso(i,k)                               &
-     &         + gamma * dbyo(i,k) / (hvap * (1. + gamma))
-          dq = qcko(i,k) - qrch
-!c
-!c  check if there is excess moisture to release latent heat
-!c
-          if(dq.gt.0.) then
-            qlko_ktcon(i) = dq
-            qcko(i,k) = qrch
-          endif
-        endif
-      enddo
-      endif
-!c
-!ccccc if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then
-!ccccc   print *, ' aa1(i) before dwndrft =', aa1(i)
-!ccccc endif
-!c
-!c------- downdraft calculations
-!c
-!c--- compute precipitation efficiency in terms of windshear
-!c
-      do i = 1, im
-        if(cnvdflg(i)) then
-          vshear(i) = 0.
-        endif
-      enddo
-      do k = 2, km
-        do i = 1, im
-          if (cnvdflg(i)) then
-            if(k.gt.kb(i).and.k.le.ktcon(i)) then
-              shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2      &
-     &                  + (vo(i,k)-vo(i,k-1)) ** 2)
-              vshear(i) = vshear(i) + shear
-            endif
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvdflg(i)) then
-          vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
-          e1=1.591-.639*vshear(i)                       &
-     &       +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
-          edt(i)=1.-e1
-          val =         .9
-          edt(i) = min(edt(i),val)
-          val =         .0
-          edt(i) = max(edt(i),val)
-          edto(i)=edt(i)
-          edtx(i)=edt(i)
-        endif
-      enddo
-!c
-!c  determine detrainment rate between 1 and kbcon
-!c
-      do i = 1, im
-        if(cnvdflg(i)) then
-          sumx(i) = 0.
-        endif
-      enddo
-      do k = 1, km1
-      do i = 1, im
-        if(cnvdflg(i).and.k.ge.1.and.k.lt.kbcon(i)) then
-          dz = zi(i,k+1) - zi(i,k)
-          sumx(i) = sumx(i) + dz
-        endif
-      enddo
-      enddo
-      do i = 1, im
-        beta = betas
-        if(slimsk(i).eq.1.) beta = betal
-        if(cnvdflg(i)) then
-          dz  = (sumx(i)+zi(i,1))/float(kbcon(i))
-          tem = 1./float(kbcon(i))
-          xlamd(i) = (1.-beta**tem)/dz
-        endif
-      enddo
-!c
-!c  determine downdraft mass flux
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvdflg(i) .and. k .le. kmax(i)-1) then
-           if(k.lt.jmin(i).and.k.ge.kbcon(i)) then
-              dz        = zi(i,k+1) - zi(i,k)
-              ptem      = xlamdd - xlamde
-              etad(i,k) = etad(i,k+1) * (1. - ptem * dz)
-           else if(k.lt.kbcon(i)) then
-              dz        = zi(i,k+1) - zi(i,k)
-              ptem      = xlamd(i) + xlamdd - xlamde
-              etad(i,k) = etad(i,k+1) * (1. - ptem * dz)
-           endif
-          endif
-        enddo
-      enddo
-!c
-!c--- downdraft moisture properties
-!c
-      do i = 1, im
-        if(cnvdflg(i)) then
-          jmn = jmin(i)
-          hcdo(i,jmn) = heo(i,jmn)
-          qcdo(i,jmn) = qo(i,jmn)
-          qrcdo(i,jmn)= qeso(i,jmn)
-          ucdo(i,jmn) = uo(i,jmn)
-          vcdo(i,jmn) = vo(i,jmn)
-          pwevo(i) = 0.
-        endif
-      enddo
-!cj
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvdflg(i) .and. k.lt.jmin(i)) then
-              dz = zi(i,k+1) - zi(i,k)
-              if(k.ge.kbcon(i)) then
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * xlamdd * dz
-              else
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
-              endif
-              factor = 1. + tem - tem1
-              ptem = 0.5 * tem - pgcon
-              ptem1= 0.5 * tem + pgcon
-              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*        &
-     &                     (heo(i,k)+heo(i,k+1)))/factor
-              ucdo(i,k) = ((1.-tem1)*ucdo(i,k+1)+ptem*uo(i,k+1)  &
-     &                     +ptem1*uo(i,k))/factor
-              vcdo(i,k) = ((1.-tem1)*vcdo(i,k+1)+ptem*vo(i,k+1)  &
-     &                     +ptem1*vo(i,k))/factor
-              dbyod(i,k) = hcdo(i,k) - heso(i,k)
-          endif
-        enddo
-      enddo
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvdflg(i).and.k.lt.jmin(i)) then
-              gamma      = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrcdo(i,k) = qeso(i,k)+                            &
-     &                (1./hvap)*(gamma/(1.+gamma))*dbyod(i,k)
-!             detad      = etad(i,k+1) - etad(i,k)
-!cj
-              dz = zi(i,k+1) - zi(i,k)
-              if(k.ge.kbcon(i)) then
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * xlamdd * dz
-              else
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
-              endif
-              factor = 1. + tem - tem1
-              qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5*        &
-     &                     (qo(i,k)+qo(i,k+1)))/factor
-!cj
-!             pwdo(i,k)  = etad(i,k+1) * qcdo(i,k+1) -
-!    &                     etad(i,k) * qrcdo(i,k)
-!             pwdo(i,k)  = pwdo(i,k) - detad *
-!    &                    .5 * (qrcdo(i,k) + qrcdo(i,k+1))
-!cj
-              pwdo(i,k)  = etad(i,k+1) * (qcdo(i,k) - qrcdo(i,k))
-              qcdo(i,k)  = qrcdo(i,k)
-              pwevo(i)   = pwevo(i) + pwdo(i,k)
-          endif
-        enddo
-      enddo
-!c
-!c--- final downdraft strength dependent on precip
-!c--- efficiency (edt), normalized condensate (pwav), and
-!c--- evaporate (pwev)
-!c
-      do i = 1, im
-        edtmax = edtmaxl
-        if(slimsk(i).eq.0.) edtmax = edtmaxs
-        if(cnvdflg(i)) then
-          if(pwevo(i).lt.0.) then
-            edto(i) = -edto(i) * pwavo(i) / pwevo(i)
-            edto(i) = min(edto(i),edtmax)
-          else
-            edto(i) = 0.
-          endif
-        endif
-      enddo
-!c
-!c--- downdraft cloudwork functions
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvdflg(i) .and. k .lt. jmin(i)) then
-              gamma = el2orc * qeso(i,k) / to(i,k)**2
-              dhh=hcdo(i,k)
-              dt=to(i,k)
-              dg=gamma
-              dh=heso(i,k)
-              dz=-1.*(zo(i,k+1)-zo(i,k))
-              aa1(i)=aa1(i)+edto(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg))  &
-     &               *(1.+delta*cp*dg*dt/hvap)
-              val=0.
-              aa1(i)=aa1(i)+edto(i)*                                   &
-     &        dz*g*delta*max(val,(qeso(i,k)-qo(i,k)))
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvdflg(i).and.aa1(i).le.0.) then
-           cnvdflg(i) = .false.
-           cnvflg(i) = .false.
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  calculate environmental values of heo, qo, uo, and vo
-!c
-!c   updraft
-      sigma_sum=0.
-      do i = 1, im
-        if(cnvflg(i)) then
-           tem = 1. - sigma(i)
-           sigi1(i) = 1. / tem
-           sigi2(i) = sigma(i) / tem
-           if(sigma_sum.lt.sigi1(i))sigma_sum=sigi1(i)
-        endif
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
-              heotu(i,k)=sigi1(i)*heo(i,k)-sigi2(i)*hcko(i,k)
-              qotu(i,k) =sigi1(i)*qo(i,k) -sigi2(i)*qcko(i,k)
-              uotu(i,k) =sigi1(i)*uo(i,k) -sigi2(i)*ucko(i,k)
-              votu(i,k) =sigi1(i)*vo(i,k) -sigi2(i)*vcko(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!c   downdraft
-      do i = 1, im
-        if(cnvdflg(i)) then
-           tem = 1. - edto(i)*sigma(i)
-           sigi1(i) = 1. / tem
-           sigi2(i) = edto(i)*sigma(i) / tem
-        endif
-      enddo
-      do k = 1, km1
-        do i = 1, im
-          if (cnvdflg(i)) then
-!
-!   we need to define heotd at jmin level
-!
-            if(k.le.jmin(i)) then
-!            if(k.lt.jmin(i)) then
-              heotd(i,k)=sigi1(i)*heo(i,k)-sigi2(i)*hcdo(i,k)
-              qotd(i,k) =sigi1(i)*qo(i,k) -sigi2(i)*qcdo(i,k)
-              uotd(i,k) =sigi1(i)*uo(i,k) -sigi2(i)*ucdo(i,k)
-              votd(i,k) =sigi1(i)*vo(i,k) -sigi2(i)*vcdo(i,k)
-            endif
-          endif
-        enddo
-      enddo
-
-!      GO TO 659
-! 
-! Do iteration to the cloud property using the environmental properties now
-!
-!c
-!c  compute updraft cloud properties
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          indx         = kb(i)
-          hcko(i,indx) = heo(i,indx)
-          ucko(i,indx) = uo(i,indx)
-          vcko(i,indx) = vo(i,indx)
-          pwavo(i)     = 0.
-        endif
-      enddo
-!c
-!c  cloud property is modified by the entrainment process
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.kmax(i)) then
-              dz   = zi(i,k) - zi(i,k-1)
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              ptem = 0.5 * tem + pgcon
-              ptem1= 0.5 * tem - pgcon
-              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*       &
-     &                     (heotu(i,k)+heotu(i,k-1)))/factor
-              ucko(i,k) = ((1.-tem1)*ucko(i,k-1)+ptem*uotu(i,k)   &
-     &                     +ptem1*uotu(i,k-1))/factor
-              vcko(i,k) = ((1.-tem1)*vcko(i,k-1)+ptem*votu(i,k)   &
-     &                     +ptem1*votu(i,k-1))/factor
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c  compute cloud moisture property and precipitation
-!c
-      do i = 1, im
-        if (cnvflg(i)) then
-          indx = kb(i)
-          qcko(i,indx) = qo(i,indx)
-          qcko(i,1) = qcko(i,indx)
-          pwavo(i) = 0.
-        endif
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
-              dz    = zi(i,k) - zi(i,k-1)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrch = qeso(i,k)                                  &
-     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
-!cj
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*       &
-     &                     (qotu(i,k)+qotu(i,k-1)))/factor
-!cj
-              dq = eta(i,k) * (qcko(i,k) - qrch)
-!c
-!c
-!c  check if there is excess moisture to release latent heat
-!c
-              if(k.ge.kbcon(i).and.dq.gt.0.) then
-                etah = .5 * (eta(i,k) + eta(i,k-1))
-                if(ncloud.gt.0.and.k.gt.jmin(i)) then
-                  dp = 1000. * del(i,k)
-                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
-                  dellal(i,k) = etah * c1 * dz * qlk * g / dp
-                else
-                  qlk = dq / (eta(i,k) + etah * c0 * dz)
-                endif
-                qcko(i,k) = qlk + qrch
-                pwo(i,k) = etah * c0 * dz * qlk
-                pwavo(i) = pwavo(i) + pwo(i,k)
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c  this section is ready for cloud water
-!c
-      if(ncloud.gt.0) then
-!c
-!c  compute liquid and vapor separation at cloud top
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          k = ktcon(i) - 1
-          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-          qrch = qeso(i,k)                               &
-     &         + gamma * dbyo(i,k) / (hvap * (1. + gamma))
-          dq = qcko(i,k) - qrch
-!c
-!c  check if there is excess moisture to release latent heat
-!c
-          if(dq.gt.0.) then
-            qlko_ktcon(i) = dq
-            qcko(i,k) = qrch
-          endif
-        endif
-      enddo
-      endif
-!c
-!c--- downdraft moisture properties
-!c
-      do i = 1, im
-        if(cnvdflg(i)) then
-          jmn = jmin(i)
-          hcdo(i,jmn) = heo(i,jmn)
-          qcdo(i,jmn) = qo(i,jmn)
-          qrcdo(i,jmn)= qeso(i,jmn)
-          ucdo(i,jmn) = uo(i,jmn)
-          vcdo(i,jmn) = vo(i,jmn)
-          pwevo(i) = 0.
-        endif
-      enddo
-!cj
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvdflg(i) .and. k.lt.jmin(i)) then
-              dz = zi(i,k+1) - zi(i,k)
-              if(k.ge.kbcon(i)) then
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * xlamdd * dz
-              else
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
-              endif
-              factor = 1. + tem - tem1
-              ptem = 0.5 * tem - pgcon
-              ptem1= 0.5 * tem + pgcon
-              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*        &
-     &                     (heotd(i,k)+heotd(i,k+1)))/factor
-              ucdo(i,k) = ((1.-tem1)*ucdo(i,k+1)+ptem*uotd(i,k+1)  &
-     &                     +ptem1*uotd(i,k))/factor
-              vcdo(i,k) = ((1.-tem1)*vcdo(i,k+1)+ptem*votd(i,k+1)  &
-     &                     +ptem1*votd(i,k))/factor
-          endif
-        enddo
-      enddo
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvdflg(i).and.k.lt.jmin(i)) then
-              gamma      = el2orc * qeso(i,k) / (to(i,k)**2)
-              qrcdo(i,k) = qeso(i,k)+                            &
-     &                (1./hvap)*(gamma/(1.+gamma))*dbyod(i,k)
-!             detad      = etad(i,k+1) - etad(i,k)
-!cj
-              dz = zi(i,k+1) - zi(i,k)
-              if(k.ge.kbcon(i)) then
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * xlamdd * dz
-              else
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
-              endif
-              factor = 1. + tem - tem1
-              qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5*        &
-     &                     (qotd(i,k)+qotd(i,k+1)))/factor
-              pwdo(i,k)  = etad(i,k+1) * (qcdo(i,k) - qrcdo(i,k))
-              qcdo(i,k)  = qrcdo(i,k)
-              pwevo(i)   = pwevo(i) + pwdo(i,k)
-          endif
-        enddo
-      enddo
-
- 659  continue
-
-!c
-!c--- what would the change be, that a cloud with unit mass
-!c--- will do to the environment?
-!c
-      do k = 1, km
-        do i = 1, im
-          if(cnvflg(i) .and. k .le. kmax(i)) then
-            dellah(i,k) = 0.
-            dellaq(i,k) = 0.
-            dellau(i,k) = 0.
-            dellav(i,k) = 0.
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvdflg(i)) then
-          dp = 1000. * del(i,1)
-          dellah(i,1) = edto(i) * etad(i,1) * (hcdo(i,1)          &
-     &                   - heotd(i,1)) * g / dp
-!
-          dellaq(i,1) = edto(i) * etad(i,1) * (qcdo(i,1)          &
-     &                   - qotd(i,1)) * g / dp
-!
-          dellau(i,1) = edto(i) * etad(i,1) * (ucdo(i,1)          &
-     &                   - uotd(i,1)) * g / dp
-!
-          dellav(i,1) = edto(i) * etad(i,1) * (vcdo(i,1)          &
-     &                   - votd(i,1)) * g / dp
-        endif
-      enddo
-!c
-!c--- changed due to subsidence and entrainment
-!c
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i).and.k.lt.ktcon(i)) then
-              aup = 1.
-              if(k.le.kb(i)) aup = 0.
-              adw = 1.
-              if(k.gt.jmin(i).or..not.cnvdflg(i)) adw = 0.
-              dp = 1000. * del(i,k)
-              dz = zi(i,k) - zi(i,k-1)
-!c
-              dv1h = heotu(i,k)
-              dv2h = .5 * (heotu(i,k) + heotu(i,k-1))
-              dv3h = heotu(i,k-1)
-              dv1q = qotu(i,k)
-              dv2q = .5 * (qotu(i,k) + qotu(i,k-1))
-              dv3q = qotu(i,k-1)
-              dv1u = uotu(i,k)
-              dv2u = .5 * (uotu(i,k) + uotu(i,k-1))
-              dv3u = uotu(i,k-1)
-              dv1v = votu(i,k)
-              dv2v = .5 * (votu(i,k) + votu(i,k-1))
-              dv3v = votu(i,k-1)
-!c
-              dv1hd = heotd(i,k)
-              dv2hd = .5 * (heotd(i,k) + heotd(i,k-1))
-              dv3hd = heotd(i,k-1)
-              dv1qd = qotd(i,k)
-              dv2qd = .5 * (qotd(i,k) + qotd(i,k-1))
-              dv3qd = qotd(i,k-1)
-              dv1ud = uotd(i,k)
-              dv2ud = .5 * (uotd(i,k) + uotd(i,k-1))
-              dv3ud = uotd(i,k-1)
-              dv1vd = votd(i,k)
-              dv2vd = .5 * (votd(i,k) + votd(i,k-1))
-              dv3vd = votd(i,k-1)
-!c
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1))
-              tem1 = xlamud(i)
-!c
-              if(k.le.kbcon(i)) then
-                ptem  = xlamde
-                ptem1 = xlamd(i)+xlamdd
-              else
-                ptem  = xlamde
-                ptem1 = xlamdd
-              endif
-!cj
-              dellah(i,k) = dellah(i,k) +                               &
-     &     (aup*(eta(i,k)*heotu(i,k)-eta(i,k-1)*heotu(i,k-1))           &
-     &    - adw*edto(i)*(etad(i,k)*heotd(i,k)-etad(i,k-1)*heotd(i,k-1)) &
-!     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2h*dz     &
-     &    - (aup*tem*eta(i,k-1))*dv2h*dz-(adw*edto(i)*ptem*etad(i,k))*dv2hd*dz     &
-     &    +  aup*tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz          &
-     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1))*dz  &
-     &         ) *g/dp
-
-!
-!c delhx = -(g/dp) * (rho * wbar) * del(htilda-hbar) 
-!c rho * g * wbar is replaced by -omega_bar which is doto in Pa/sec
-!c dp is in Pa
-!
-              delhx(i,k) = ( aup*(doto(i,k)*(heotu(i,k)-heo(i,k))           &
-     &                          - doto(i,k-1)*(heotu(i,k-1)-heo(i,k-1)))     &
-     &                     ) / dp
-!cj
-              dellaq(i,k) = dellaq(i,k) +                               &
-     &     (aup*(eta(i,k)*qotu(i,k)-eta(i,k-1)*qotu(i,k-1))             &
-     &    - adw*edto(i)*(etad(i,k)*qotd(i,k)-etad(i,k-1)*qotd(i,k-1))   &
-     &    - (aup*tem*eta(i,k-1))*dv2q*dz-(adw*edto(i)*ptem*etad(i,k))*dv2qd*dz     &
-     &    +  aup*tem1*eta(i,k-1)*.5*(qcko(i,k)+qcko(i,k-1))*dz          &
-     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qrcdo(i,k-1))*dz  &
-     &         ) *g/dp
-!
-
-              delqx(i,k) = ( aup*(doto(i,k)*(qotu(i,k)-qo(i,k))            &
-     &                          - doto(i,k-1)*(qotu(i,k-1)-qo(i,k-1)))       &
-     &                     ) / dp
-!cj
-              dellau(i,k) = dellau(i,k) +                               &
-     &     (aup*(eta(i,k)*uotu(i,k)-eta(i,k-1)*uotu(i,k-1))             &
-     &    - adw*edto(i)*(etad(i,k)*uotd(i,k)-etad(i,k-1)*uotd(i,k-1))   &
-     &    - (aup*tem*eta(i,k-1))*dv2u*dz-(adw*edto(i)*ptem*etad(i,k))*dv2ud*dz     &
-     &    +  aup*tem1*eta(i,k-1)*.5*(ucko(i,k)+ucko(i,k-1))*dz          &
-     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(ucdo(i,k)+ucdo(i,k-1))*dz  &
-     &    -  pgcon*(aup*eta(i,k-1)*(dv1u-dv3u)-adw*edto(i)*etad(i,k)*(dv1ud-dv3ud))   &
-     &         ) *g/dp
-!
-              delux(i,k) = ( aup*(doto(i,k)*(uotu(i,k)-uo(i,k))            &
-     &                          - doto(i,k-1)*(uotu(i,k-1)-uo(i,k-1)))       &
-     &                     ) / dp
-!cj
-              dellav(i,k) = dellav(i,k) +                               &
-     &     (aup*(eta(i,k)*votu(i,k)-eta(i,k-1)*votu(i,k-1))             &
-     &    - adw*edto(i)*(etad(i,k)*votd(i,k)-etad(i,k-1)*votd(i,k-1))   &
-     &    - (aup*tem*eta(i,k-1))*dv2v*dz-(adw*edto(i)*ptem*etad(i,k))*dv2vd*dz     &
-     &    +  aup*tem1*eta(i,k-1)*.5*(vcko(i,k)+vcko(i,k-1))*dz          &
-     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(vcdo(i,k)+vcdo(i,k-1))*dz  &
-     &    -  pgcon*(aup*eta(i,k-1)*(dv1v-dv3v)-adw*edto(i)*etad(i,k)*(dv1vd-dv3vd))   &
-     &         ) *g/dp
-!
-
-              delvx(i,k) = ( aup*(doto(i,k)*(votu(i,k)-vo(i,k))            &
-     &                          - doto(i,k-1)*(votu(i,k-1)-vo(i,k-1)))       &
-     &                     ) / dp
-!          if(abs(delvx(i,k)).gt.1.0)print*,'qingfu test999=',        &
-!              i,k,delvx(i,k),aup,adw,doto(i,k),(votu(i,k)-vo(i,k))      &
-!              ,(votu(i,k-1)-vo(i,k-1)),dp
-
-!cj
-          endif
-        enddo
-      enddo
-!c
-!c------- cloud top
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          indx = ktcon(i)
-          dp = 1000. * del(i,indx)
-          dv1h = heo(i,indx-1)
-          dellah(i,indx) = eta(i,indx-1) *                              &
-     &              (hcko(i,indx-1) - heotu(i,indx-1)) * g / dp
-!          delhx(i,indx) = doto(i,indx-1)*dv1h / dp
-          delhx(i,indx) = doto(i,indx-1)*(dv1h-heotu(i,indx-1)) / dp
-!
-          dv1q = qo(i,indx-1)
-          dellaq(i,indx) = eta(i,indx-1) *                              &
-     &              (qcko(i,indx-1) - qotu(i,indx-1)) * g / dp
-!          delqx(i,indx) = doto(i,indx-1)*dv1q / dp
-          delqx(i,indx) = doto(i,indx-1)*(dv1q-qotu(i,indx-1)) / dp
-!
-          dv1u = uo(i,indx-1)
-          dellau(i,indx) = eta(i,indx-1) *                              &
-     &              (ucko(i,indx-1) - uotu(i,indx-1)) * g / dp
-!          delux(i,indx) = doto(i,indx-1)*dv1u / dp
-          delux(i,indx) = doto(i,indx-1)*(dv1u-uotu(i,indx-1)) / dp
-!
-          dv1v = vo(i,indx-1)
-          dellav(i,indx) = eta(i,indx-1) *                              &
-     &              (vcko(i,indx-1) - votu(i,indx-1)) * g / dp
-!          delvx(i,indx) = doto(i,indx-1)*dv1v / dp
-          delvx(i,indx) = doto(i,indx-1)*(dv1v-votu(i,indx-1)) / dp
-!          if(abs(delvx(i,indx)).gt.5.0)print*,'qingfu test888=',      &
-!              i,indx,delvx(i,indx),doto(i,indx-1),dv1v,votu(i,indx-1),dp
-!c
-!c  cloud water
-!c
-          dellal(i,indx) = eta(i,indx-1) *                              &
-     &                     qlko_ktcon(i) * g / dp
-        endif
-      enddo
-!c
-!c------- final changed variable per unit mass flux
-!c
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i).and.k .le. kmax(i)) then
-            if(k.gt.ktcon(i)) then
-              qo(i,k) = q1(i,k)
-              to(i,k) = t1(i,k)
-            endif
-            if(k.le.ktcon(i)) then
-!
-!c   We need to scale the w-bar contribution (delhx and delqx) by rho * wc
-!c   po is in mb but rho (tem) is now in standard unit, wc is in m/sec
-!c   tem1 is wbar in m/sec, doto is in pa/sec
-!
-              tem = po(i,k) / (rd * to(i,k) * (1. + delta * qo(i,k))) * 100.
-              tem1 = -doto(i,k) / (tem * g)
-              tem1 = tem1 / (wc(i) + 1.E-20)
-              tem1 = max(tem1,real(0.,kind=kind_phys))
-              tem1 = min(tem1,real(1.,kind=kind_phys))
-!              delqz = dellaq(i,k)* (1.-tem1) *mbdt / (1. - sigma)
-!     &              + delqx(i,k)*ardt / ((1. - sigma(i)) * tem * wc(i))
-              delqz = dellaq(i,k) * mbdt
-              qo(i,k) = q1(i,k) + delqz
-!              delhz = dellah(i,k)* (1.-tem1) *mbdt / (1. - sigma)
-!     &              + delhx(i,k)*ardt / ((1. - sigma(i)) * tem * wc(i))
-              delhz = dellah(i,k) * mbdt
-              dellat = (delhz - hvap * delqz) / cp
-              to(i,k) = t1(i,k) + dellat
-              val   =           1.e-10
-              qo(i,k) = max(qo(i,k), val  )
-            endif
-          endif
-        enddo
-      enddo
-!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!c
-!c--- the above changed environment is now used to calulate the
-!c--- effect the arbitrary cloud (with unit mass flux)
-!c--- would have on the stability,
-!c--- which then is used to calculate the real mass flux,
-!c--- necessary to keep this change in balance with the large-scale
-!c--- destabilization.
-!c
-!c--- environmental conditions again, first heights
-!c
-      do k = 1, km
-        do i = 1, im
-          if(cnvflg(i) .and. k .le. kmax(i)) then
-            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k)+epsm1*qeso(i,k))
-            val       =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val )
-!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
-          endif
-        enddo
-      enddo
-!c
-!c--- moist static energy
-!c
-      do k = 1, km1
-        do i = 1, im
-          if(cnvflg(i) .and. k .le. kmax(i)-1) then
-            dz = .5 * (zo(i,k+1) - zo(i,k))
-            dp = .5 * (pfld(i,k+1) - pfld(i,k))
-            es = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
-            pprime = pfld(i,k+1) + epsm1 * es
-            qs = eps * es / pprime
-            dqsdp = - qs / pprime
-            desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
-            dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime)
-            gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
-            dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
-            dq = dqsdt * dt + dqsdp * dp
-            to(i,k) = to(i,k+1) + dt
-            qo(i,k) = qo(i,k+1) + dq
-            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
-          endif
-        enddo
-      enddo
-      do k = 1, km1
-        do i = 1, im
-          if(cnvflg(i) .and. k .le. kmax(i)-1) then
-            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1 * qeso(i,k))
-            val1      =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val1)
-            val2      =           1.e-10
-            qo(i,k)   = max(qo(i,k), val2 )
-!           qo(i,k)   = min(qo(i,k),qeso(i,k))
-            heo(i,k)   = .5 * g * (zo(i,k) + zo(i,k+1)) +           &
-     &                    cp * to(i,k) + hvap * qo(i,k)
-            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +            &
-     &                  cp * to(i,k) + hvap * qeso(i,k)
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvflg(i)) then
-          k = kmax(i)
-          heo(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qo(i,k)
-          heso(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qeso(i,k)
-!c         heo(i,k) = min(heo(i,k),heso(i,k))
-        endif
-      enddo
-!c
-!c**************************** static control
-!c
-!c------- moisture and cloud work functions
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          xaa0(i) = 0.
-          xpwav(i) = 0.
-        endif
-      enddo
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          indx = kb(i)
-          hcko(i,indx) = heo(i,indx)
-          qcko(i,indx) = qo(i,indx)
-        endif
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.le.ktcon(i)) then
-              dz = zi(i,k) - zi(i,k-1)
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*          &
-     &                     (heo(i,k)+heo(i,k-1)))/factor
-            endif
-          endif
-        enddo
-      enddo
-      do k = 2, km1
-        do i = 1, im
-          if (cnvflg(i)) then
-            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
-              dz = zi(i,k) - zi(i,k-1)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              xdby = hcko(i,k) - heso(i,k)
-              xqrch = qeso(i,k)                                    &
-     &              + gamma * xdby / (hvap * (1. + gamma))
-!cj
-              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
-              tem1 = 0.5 * xlamud(i) * dz
-              factor = 1. + tem - tem1
-              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*          &
-     &                     (qo(i,k)+qo(i,k-1)))/factor
-!cj
-              dq = eta(i,k) * (qcko(i,k) - xqrch)
-!c
-              if(k.ge.kbcon(i).and.dq.gt.0.) then
-                etah = .5 * (eta(i,k) + eta(i,k-1))
-                if(ncloud.gt.0.and.k.gt.jmin(i)) then
-                  qlk = dq / (eta(i,k) + etah * (c0 + c1) * dz)
-                else
-                  qlk = dq / (eta(i,k) + etah * c0 * dz)
-                endif
-                if(k.lt.ktcon1(i)) then
-                  xaa0(i) = xaa0(i) - dz * g * qlk
-                endif
-                qcko(i,k) = qlk + xqrch
-                xpw = etah * c0 * dz * qlk
-                xpwav(i) = xpwav(i) + xpw
-              endif
-            endif
-            if(k.ge.kbcon(i).and.k.lt.ktcon1(i)) then
-              dz1 = zo(i,k+1) - zo(i,k)
-              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
-              rfact =  1. + delta * cp * gamma                    &
-     &                 * to(i,k) / hvap
-              xaa0(i) = xaa0(i)                                   &
-     &                + dz1 * (g / (cp * to(i,k)))                &
-     &                * xdby / (1. + gamma)                       &
-     &                * rfact
-              val=0.
-              xaa0(i)=xaa0(i)+                                    &
-     &                 dz1 * g * delta *                          &
-     &                 max(val,(qeso(i,k) - qo(i,k)))
-            endif
-          endif
-        enddo
-      enddo
-!c
-!c------- downdraft calculations
-!c
-!c--- downdraft moisture properties
-!c
-      do i = 1, im
-        if(cnvdflg(i)) then
-          jmn = jmin(i)
-          hcdo(i,jmn) = heo(i,jmn)
-          qcdo(i,jmn) = qo(i,jmn)
-          qrcd(i,jmn) = qeso(i,jmn)
-          xpwev(i) = 0.
-        endif
-      enddo
-!cj
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvdflg(i) .and. k.lt.jmin(i)) then
-              dz = zi(i,k+1) - zi(i,k)
-              if(k.ge.kbcon(i)) then
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * xlamdd * dz
-              else
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
-              endif
-              factor = 1. + tem - tem1
-              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*        &
-     &                     (heo(i,k)+heo(i,k+1)))/factor
-          endif
-        enddo
-      enddo
-!cj
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvdflg(i) .and. k .lt. jmin(i)) then
-              dq = qeso(i,k)
-              dt = to(i,k)
-              gamma    = el2orc * dq / dt**2
-              dh       = hcdo(i,k) - heso(i,k)
-              qrcd(i,k)=dq+(1./hvap)*(gamma/(1.+gamma))*dh
-!             detad    = etad(i,k+1) - etad(i,k)
-!cj
-              dz = zi(i,k+1) - zi(i,k)
-              if(k.ge.kbcon(i)) then
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * xlamdd * dz
-              else
-                 tem  = xlamde * dz
-                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
-              endif
-              factor = 1. + tem - tem1
-              qcdo(i,k) = ((1.-tem1)*qcdo(i,k+1)+tem*0.5*        &
-     &                     (qo(i,k)+qo(i,k+1)))/factor
-!cj
-!             xpwd     = etad(i,k+1) * qcdo(i,k+1) -
-!    &                   etad(i,k) * qrcd(i,k)
-!             xpwd     = xpwd - detad *
-!    &                 .5 * (qrcd(i,k) + qrcd(i,k+1))
-!cj
-              xpwd     = etad(i,k+1) * (qcdo(i,k) - qrcd(i,k))
-              qcdo(i,k)= qrcd(i,k)
-              xpwev(i) = xpwev(i) + xpwd
-          endif
-        enddo
-      enddo
-!c
-      do i = 1, im
-        edtmax = edtmaxl
-        if(slimsk(i).eq.0.) edtmax = edtmaxs
-        if(cnvdflg(i)) then
-          if(xpwev(i).ge.0.) then
-            edtx(i) = 0.
-          else
-            edtx(i) = -edtx(i) * xpwav(i) / xpwev(i)
-            edtx(i) = min(edtx(i),edtmax)
-          endif
-        endif
-      enddo
-!c
-!c
-!c--- downdraft cloudwork functions
-!c
-!c
-      do k = km1, 1, -1
-        do i = 1, im
-          if (cnvdflg(i) .and. k.lt.jmin(i)) then
-              gamma = el2orc * qeso(i,k) / to(i,k)**2
-              dhh=hcdo(i,k)
-              dt= to(i,k)
-              dg= gamma
-              dh= heso(i,k)
-              dz=-1.*(zo(i,k+1)-zo(i,k))
-              xaa0(i)=xaa0(i)+edtx(i)*dz*(g/(cp*dt))*((dhh-dh)/(1.+dg))  &
-     &                *(1.+delta*cp*dg*dt/hvap)
-              val=0.
-              xaa0(i)=xaa0(i)+edtx(i)*                             &
-     &        dz*g*delta*max(val,(qeso(i,k)-qo(i,k)))
-          endif
-        enddo
-      enddo
-!c
-!c  calculate critical cloud work function
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-          if(pfld(i,ktcon(i)).lt.pcrit(15))then
-            acrt(i)=acrit(15)*(975.-pfld(i,ktcon(i)))              &
-     &              /(975.-pcrit(15))
-          else if(pfld(i,ktcon(i)).gt.pcrit(1))then
-            acrt(i)=acrit(1)
-          else
-            k =  int((850. - pfld(i,ktcon(i)))/50.) + 2
-            k = min(k,15)
-            k = max(k,2)
-            acrt(i)=acrit(k)+(acrit(k-1)-acrit(k))*                &
-     &           (pfld(i,ktcon(i))-pcrit(k))/(pcrit(k-1)-pcrit(k))
-          endif
-        endif
-      enddo
-      do i = 1, im
-        if(cnvflg(i)) then
-          if(slimsk(i).eq.1.) then
-            w1 = w1l
-            w2 = w2l
-            w3 = w3l
-            w4 = w4l
-          else
-            w1 = w1s
-            w2 = w2s
-            w3 = w3s
-            w4 = w4s
-          endif
-!c
-!c  modify critical cloud workfunction by cloud base vertical velocity
-!c
-          if(pdot(i).le.w4) then
-            acrtfct(i) = (pdot(i) - w4) / (w3 - w4)
-          elseif(pdot(i).ge.-w4) then
-            acrtfct(i) = - (pdot(i) + w4) / (w4 - w3)
-          else
-            acrtfct(i) = 0.
-          endif
-          val1    =             -1.
-          acrtfct(i) = max(acrtfct(i),val1)
-          val2    =             1.
-          acrtfct(i) = min(acrtfct(i),val2)
-          acrtfct(i) = 1. - acrtfct(i)
-!c
-!c  modify acrtfct(i) by colume mean rh if rhbar(i) is greater than 80 percent
-!c
-!c         if(rhbar(i).ge..8) then
-!c           acrtfct(i) = acrtfct(i) * (.9 - min(rhbar(i),.9)) * 10.
-!c         endif
-!c
-!c  modify adjustment time scale by cloud base vertical velocity
-!c
-          val1=0.0
-          dtconv(i) = dt2 + max((1800. - dt2),val1) *             &
-     &                (pdot(i) - w2) / (w1 - w2)
-!c         dtconv(i) = max(dtconv(i), dt2)
-!c         dtconv(i) = 1800. * (pdot(i) - w2) / (w1 - w2)
-          dtconv(i) = max(dtconv(i),dtmin)
-          dtconv(i) = min(dtconv(i),dtmax)
-!c
-        endif
-      enddo
-!c
-!c--- large scale forcing
-!c
-      do i= 1, im
-        if(cnvflg(i)) then
-          fld(i)=(aa1(i)-acrt(i)* acrtfct(i))/dtconv(i)
-          if(fld(i).le.0.) cnvflg(i) = .false.
-        endif
-        if(cnvflg(i)) then
-!c         xaa0(i) = max(xaa0(i),0.)
-          xk(i) = (xaa0(i) - aa1(i)) / mbdt
-          if(xk(i).ge.0.) cnvflg(i) = .false.
-        endif
-!c
-!c--- kernel, cloud base mass flux
-!c
-        if(cnvflg(i)) then
-          xmb(i) = -fld(i) / xk(i)
-          xmb(i) = min(xmb(i),xmbmax(i))
-        endif
-      enddo
-!!
-      totflg = .true.
-      do i=1,im
-        totflg = totflg .and. (.not. cnvflg(i))
-      enddo
-      if(totflg) return
-!!
-!c
-!c  restore to,qo,uo,vo to t1,q1,u1,v1 in case convection stops
-!c
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            to(i,k) = t1(i,k)
-            qo(i,k) = q1(i,k)
-            uo(i,k) = u1(i,k)
-            vo(i,k) = v1(i,k)
-            qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
-            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
-            val     =             1.e-8
-            qeso(i,k) = max(qeso(i,k), val )
-          endif
-        enddo
-      enddo
-!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!c
-!c--- feedback: simply the changes from the cloud with unit mass flux
-!c---           multiplied by  the mass flux necessary to keep the
-!c---           equilibrium with the larger-scale.
-!c
-      do i = 1, im
-        delhbar(i) = 0.
-        delqbar(i) = 0.
-        deltbar(i) = 0.
-        delubar(i) = 0.
-        delvbar(i) = 0.
-        qcond(i) = 0.
-      enddo
-!c
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            if(k.le.ktcon(i)) then
-              delhz = dellah(i,k)*xmb(i) + delhx(i,k)
-              delqz = dellaq(i,k)*xmb(i) + delqx(i,k)
-              deluz = dellau(i,k)*xmb(i) + delux(i,k)
-              delvz = dellav(i,k)*xmb(i) + delvx(i,k)
-              dellat = (delhz - hvap * delqz) / cp
-              t1(i,k) = t1(i,k) + dellat * dt2
-              q1(i,k) = q1(i,k) + delqz * dt2
-              tem = 1./rcs(i)
-              u1(i,k) = u1(i,k) + deluz * dt2 * tem
-              v1(i,k) = v1(i,k) + delvz * dt2 * tem
-              dp = 1000. * del(i,k)
-              delhbar(i) = delhbar(i) + delhz * dp / g
-              delqbar(i) = delqbar(i) + delqz * dp / g
-              deltbar(i) = deltbar(i) + dellat * dp / g
-              delubar(i) = delubar(i) + deluz * dp / g
-              delvbar(i) = delvbar(i) + delvz * dp / g
-            endif
-          endif
-        enddo
-      enddo
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            if(k.le.ktcon(i)) then
-              qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
-              qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k))
-              val     =             1.e-8
-              qeso(i,k) = max(qeso(i,k), val )
-            endif
-          endif
-        enddo
-      enddo
-!c
-      do i = 1, im
-        rntot(i) = 0.
-        delqev(i) = 0.
-        delq2(i) = 0.
-        flg(i) = cnvflg(i)
-      enddo
-      do k = km, 1, -1
-        do i = 1, im
-          if (cnvflg(i) .and. k .le. kmax(i)) then
-            if(k.lt.ktcon(i)) then
-              aup = 1.
-              if(k.le.kb(i)) aup = 0.
-              adw = 1.
-              if(k.ge.jmin(i).or..not.cnvdflg(i)) adw = 0.
-              rain =  aup * pwo(i,k) + adw * edto(i) * pwdo(i,k)
-              rntot(i) = rntot(i) + rain * xmb(i) * .001 * dt2
-            endif
-          endif
-        enddo
-      enddo
-      do k = km, 1, -1
-        do i = 1, im
-          if (k .le. kmax(i)) then
-            deltv(i) = 0.
-            delq(i) = 0.
-            qevap(i) = 0.
-            if(cnvflg(i).and.k.lt.ktcon(i)) then
-              aup = 1.
-              if(k.le.kb(i)) aup = 0.
-              adw = 1.
-              if(k.ge.jmin(i).or..not.cnvdflg(i)) adw = 0.
-              rain =  aup * pwo(i,k) + adw * edto(i) * pwdo(i,k)
-              rn(i) = rn(i) + rain * xmb(i) * .001 * dt2
-            endif
-            if(flg(i).and.k.lt.ktcon(i)) then
-              evef = edt(i) * evfact
-              if(slimsk(i).eq.1.) evef=edt(i) * evfactl
-!             if(slimsk(i).eq.1.) evef=.07
-!c             if(slimsk(i).ne.1.) evef = 0.
-              qcond(i) = evef * (q1(i,k) - qeso(i,k))                &
-     &                 / (1. + el2orc * qeso(i,k) / t1(i,k)**2)
-              dp = 1000. * del(i,k)
-              if(rn(i).gt.0..and.qcond(i).lt.0.) then
-                qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i))))
-                qevap(i) = min(qevap(i), rn(i)*1000.*g/dp)
-                delq2(i) = delqev(i) + .001 * qevap(i) * dp / g
-              endif
-              if(rn(i).gt.0..and.qcond(i).lt.0..and.                 &
-     &           delq2(i).gt.rntot(i)) then
-                qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp
-                flg(i) = .false.
-              endif
-              if(rn(i).gt.0..and.qevap(i).gt.0.) then
-                q1(i,k) = q1(i,k) + qevap(i)
-                t1(i,k) = t1(i,k) - elocp * qevap(i)
-                rn(i) = rn(i) - .001 * qevap(i) * dp / g
-                deltv(i) = - elocp*qevap(i)/dt2
-                delq(i) =  + qevap(i)/dt2
-                delqev(i) = delqev(i) + .001*dp*qevap(i)/g
-              endif
-              dellaq(i,k) = dellaq(i,k) + delq(i) / xmb(i)
-              delqbar(i) = delqbar(i) + delq(i)*dp/g
-              deltbar(i) = deltbar(i) + deltv(i)*dp/g
-            endif
-          endif
-        enddo
-      enddo
-!cj
-!     do i = 1, im
-!     if(me.eq.31.and.cnvflg(i)) then
-!     if(cnvflg(i)) then
-!       print *, ' deep delhbar, delqbar, deltbar = ',
-!    &             delhbar(i),hvap*delqbar(i),cp*deltbar(i)
-!       print *, ' deep delubar, delvbar = ',delubar(i),delvbar(i)
-!       print *, ' precip =', hvap*rn(i)*1000./dt2
-!       print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i))
-!     endif
-!     enddo
-!c
-!c  precipitation rate converted to actual precip
-!c  in unit of m instead of kg
-!c
-      do i = 1, im
-        if(cnvflg(i)) then
-!c
-!c  in the event of upper level rain evaporation and lower level downdraft
-!c    moistening, rn can become negative, in this case, we back out of the
-!c    heating and the moistening
-!c
-          if(rn(i).lt.0..and..not.flg(i)) rn(i) = 0.
-          if(rn(i).le.0.) then
-            rn(i) = 0.
-          else
-            ktop(i) = ktcon(i)
-            kbot(i) = kbcon(i)
-            kcnv(i) = 1
-            cldwrk(i) = aa1(i)
-          endif
-        endif
-      enddo
-!c
-!c  cloud water
-!c
-      if (ncloud.gt.0) then
-!
-      val1=0.0
-      val2=1.0
-      do k = 1, km
-        do i = 1, im
-          if (cnvflg(i) .and. rn(i).gt.0.) then
-            if (k.gt.kb(i).and.k.le.ktcon(i)) then
-              tem  = dellal(i,k) * xmb(i) * dt2
-              tem1 = max(val1, min(val2, (tcr-t1(i,k))*tcrf))
-              if (ql(i,k,2) .gt. -999.0) then
-                ql(i,k,1) = ql(i,k,1) + tem * tem1            ! ice
-                ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1)       ! water
-              else
-                ql(i,k,1) = ql(i,k,1) + tem
-              endif
-            endif
-          endif
-        enddo
-      enddo
-!
-      endif
-!c
-      do k = 1, km
-        do i = 1, im
-          if(cnvflg(i).and.rn(i).le.0.) then
-            if (k .le. kmax(i)) then
-              t1(i,k) = to(i,k)
-              q1(i,k) = qo(i,k)
-              u1(i,k) = uo(i,k)
-              v1(i,k) = vo(i,k)
-            endif
-          endif
-        enddo
-      enddo
-!
-! hchuang code change
-!
-      do k = 1, km
-        do i = 1, im
-          if(cnvflg(i).and.rn(i).gt.0.) then
-            if(k.ge.kb(i) .and. k.lt.ktop(i)) then
-              ud_mf(i,k) = eta(i,k) * xmb(i) * dt2
-            endif
-          endif
-        enddo
-      enddo
-      do i = 1, im
-        if(cnvflg(i).and.rn(i).gt.0.) then
-           k = ktop(i)-1
-           dt_mf(i,k) = ud_mf(i,k)
-        endif
-      enddo
-      do k = 1, km
-        do i = 1, im
-          if(cnvflg(i).and.rn(i).gt.0.) then
-            if(k.ge.1 .and. k.le.jmin(i)) then
-              dd_mf(i,k) = edto(i) * etad(i,k) * xmb(i) * dt2
-            endif
-          endif
-        enddo
-      enddo
-!!
-
-      sigma_sum=0.
-      do I=1,im
-         sigma_sum=sigma_sum+abs(sigma(I))
-      end do
-!      if(sigma_sum.gt.0.1)then
-!        print*,'qliu test sigma_c='
-!        write(*,333)sigma
-!      end if
-!333   format(1x,'inside sascnvn_h sigma_c=',9F10.3)
-
-      return
-      end subroutine sascnvn_h
-
-      END MODULE module_cu_mesosas
-
diff --git a/wrfv2_fire/phys/module_cu_nsas.F b/wrfv2_fire/phys/module_cu_nsas.F
index 2b4d4324..2000d968 100644
--- a/wrfv2_fire/phys/module_cu_nsas.F
+++ b/wrfv2_fire/phys/module_cu_nsas.F
@@ -210,9 +210,9 @@ subroutine cu_nsas(dt,dx,p3di,p3d,pi3d,qc3d,qi3d,rho3d,itimestep,stepcu,    &
 !
 ! NCEP SAS 
 !
-     call nsas2d(delt=dt,delx=dx,del=del(its,kts),                             &
+     call nsas2d(delt=delt,delx=dx,del=del(its,kts),                           &
               prsl=prsll(its,kts),prsi=prsii(its,kts),prslk=pi3d(ims,kms,j),   &
-              zl=zll(its,kts),zi=zii(its,kts),                                 &
+              zl=zll(its,kts),                                                 &
               ncloud=ncloud,qc2=qc2(its,kts),qi2=qi2(its,kts),                 &
               q1=q1(its,kts),t1=t1(its,kts),rain=rain(its),                    &
               kbot=kbot(its),ktop=ktop(its),                                   &
@@ -235,9 +235,9 @@ subroutine cu_nsas(dt,dx,p3di,p3d,pi3d,qc3d,qi3d,rho3d,itimestep,stepcu,    &
 !
 ! NCEP SCV
 !
-     call nscv2d(delt=dt,del=del(its,kts),prsl=prsll(its,kts),                 &
+     call nscv2d(delt=delt,del=del(its,kts),prsl=prsll(its,kts),               &
               prsi=prsii(its,kts),prslk=pi3d(ims,kms,j),zl=zll(its,kts),       &
-              zi=zii(its,kts),ncloud=ncloud,qc2=qc2(its,kts),qi2=qi2(its,kts), &
+              ncloud=ncloud,qc2=qc2(its,kts),qi2=qi2(its,kts),                 &
               q1=q1(its,kts),t1=t1(its,kts),rain=rain(its),                    &
               kbot=kbot(its),ktop=ktop(its),                                   &
               icps=icps(its),                                                  &
@@ -310,7 +310,7 @@ end subroutine cu_nsas
 !-------------------------------------------------------------------------------
 ! NCEP SAS (Deep Convection Scheme)
 !-------------------------------------------------------------------------------
-   subroutine nsas2d(delt,delx,del,prsl,prsi,prslk,zl,zi,                      &
+   subroutine nsas2d(delt,delx,del,prsl,prsi,prslk,zl,                         &
             ncloud,                                                            & 
             qc2,qi2,                                                           & 
             q1,t1,rain,kbot,ktop,                                              &
@@ -352,7 +352,7 @@ subroutine nsas2d(delt,delx,del,prsl,prsi,prslk,zl,zi,                      &
 !   14-01-09  song-you hong    dx dependent trigger, closure, and mass flux
 !
 !
-! usage:    call phys_cps_sas(delt,delx,del,prsl,prsi,prslk,prsik,zl,zi,       &
+! usage:    call phys_cps_sas(delt,delx,del,prsl,prsi,prslk,prsik,zl,          &
 !                             q2,q1,t1,u1,v1,rcs,slimsk,dot,cldwrk,rain,       &
 !                             jcap,ncloud,lat,kbot,ktop,icps,                  &
 !                             ids,ide, jds,jde, kds,kde,                       &
@@ -440,7 +440,7 @@ subroutine nsas2d(delt,delx,del,prsl,prsi,prslk,zl,zi,                      &
    real            ::  del(its:ite,kts:kte),                                   &
                        prsl(its:ite,kts:kte),prslk(ims:ime,kms:kme),           &
                        prsi(its:ite,kts:kte+1),                                &
-                       zl(its:ite,kts:kte),zi(its:ite,kts:kte+1),              &
+                       zl(its:ite,kts:kte),                                    &
                        q1(its:ite,kts:kte),t1(its:ite,kts:kte),                &
                        u1(its:ite,kts:kte),v1(its:ite,kts:kte),                &
                        dot(its:ite,kts:kte)
@@ -456,6 +456,7 @@ subroutine nsas2d(delt,delx,del,prsl,prsi,prslk,zl,zi,                      &
 !
    integer         ::  i,k,kmax,kbmax,kbm,jmn,indx,indp,kts1,kte1,kmax1,kk
    real            ::  p(its:ite,kts:kte),pdot(its:ite),acrtfct(its:ite)
+   real            ::  zi(its:ite,kts:kte+1)
    real            ::  uo(its:ite,kts:kte),vo(its:ite,kts:kte)
    real            ::  to(its:ite,kts:kte),qo(its:ite,kts:kte)
    real            ::  hcko(its:ite,kts:kte)
@@ -816,6 +817,12 @@ subroutine nsas2d(delt,delx,del,prsl,prsi,prslk,zl,zi,                      &
      totflg = totflg .and. (.not. cnvflg(i))
    enddo
    if(totflg) return
+!
+   do k = kts1,kte
+     do i = its,ite
+       zi(i,k) = 0.5*(zl(i,k-1)+zl(i,k))
+     enddo
+   enddo
 !
    do k = kts,kte1
      do i = its,ite
@@ -2182,7 +2189,7 @@ end subroutine nsasinit
 !-------------------------------------------------------------------------------
 ! NCEP SCV (Shallow Convection Scheme)
 !-------------------------------------------------------------------------------
-   subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
+   subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,                              &
                  ncloud,qc2,qi2,q1,t1,rain,kbot,ktop,                          &
                  icps,                                                         &
                  slimsk,dot,u1,v1,                                             &
@@ -2431,6 +2438,12 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !
 !  hydrostatic height assume zero terr and compute
 !  updraft entrainment rate as an inverse function of height
+!
+   do k = kts+1,kte
+     do i = its,ite
+       zi(i,k) = 0.5*(zl(i,k-1)+zl(i,k))
+     enddo
+   enddo
 !
    do k = kts,km1
      do i = its,ite
@@ -2674,7 +2687,7 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
      do i = its,ite
        if (cnvflg(i)) then
          if(k.lt.kbcon(i).and.k.ge.kb(i)) then
-           dz       = zi(i,k+1) - zi(i,k)
+           dz       = zi(i,k+2) - zi(i,k+1)
            ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i)
            eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
          endif
@@ -2688,7 +2701,7 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
      do i = its,ite
        if(cnvflg(i))then
          if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
-           dz       = zi(i,k) - zi(i,k-1)
+           dz       = zi(i,k+1) - zi(i,k)
            ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i)
            eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
          endif
@@ -2711,7 +2724,7 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
      do i = its,ite
        if (cnvflg(i)) then
          if(k.gt.kb(i).and.k.lt.kmax(i)) then
-           dz   = zi(i,k) - zi(i,k-1)
+           dz   = zi(i,k+1) - zi(i,k)
            tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
            tem1 = 0.5 * xlamud(i) * dz
            factor = 1. + tem - tem1
@@ -2811,7 +2824,7 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
      do i = its,ite
        if (cnvflg(i)) then
          if(k.gt.kb(i).and.k.lt.ktcon(i)) then
-           dz    = zi(i,k) - zi(i,k-1)
+           dz    = zi(i,k+1) - zi(i,k)
            gamma = el2orc * qeso(i,k) / (to(i,k)**2)
            qrch = qeso(i,k) + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
            tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
@@ -2913,7 +2926,7 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
      do i = its,ite
        if (cnvflg(i)) then
          if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
-           dz    = zi(i,k) - zi(i,k-1)
+           dz    = zi(i,k+1) - zi(i,k)
            gamma = el2orc * qeso(i,k) / (to(i,k)**2)
            qrch = qeso(i,k)                                                    &
                 + gamma * dbyo(i,k) / (hvap_ * (1. + gamma))
@@ -2999,7 +3012,7 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
 !
    do i = its,ite
      if(cnvflg(i)) then
-       vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
+       vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i)+1)-zi(i,kb(i)+1))
        e1=1.591-.639*vshear(i)                                                 &
              +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
        edt(i)=1.-e1
@@ -3031,7 +3044,7 @@ subroutine nscv2d(delt,del,prsl,prsi,prslk,zl,zi,                           &
        if (cnvflg(i)) then
          if(k.gt.kb(i).and.k.lt.ktcon(i)) then
            dp = 1000. * del(i,k)
-           dz = zi(i,k) - zi(i,k-1)
+           dz = zi(i,k+1) - zi(i,k)
 !
            dv1h = heo(i,k)
            dv2h = .5 * (heo(i,k) + heo(i,k-1))
diff --git a/wrfv2_fire/phys/module_cu_ntiedtke.F b/wrfv2_fire/phys/module_cu_ntiedtke.F
index f6f59ea2..03ebf6dc 100644
--- a/wrfv2_fire/phys/module_cu_ntiedtke.F
+++ b/wrfv2_fire/phys/module_cu_ntiedtke.F
@@ -7,12 +7,12 @@
 !    j.morcrette                    1992
 !--------------------------------------------    
 !    modifications
-!    C. zhang & Yuqing Wang         2011-2014
+!    C. zhang & Yuqing Wang         2011-2017
 !
 !   modified from IPRC IRAM - yuqing wang, university of hawaii
 !               & ICTP REGCM4.4
 !
-!   this scheme is experimental. There are many updates to the old Tiedtke scheme (cu_physics=6)
+!   The current version is stable.  There are many updates to the old Tiedtke scheme (cu_physics=6)
 !   update notes:
 !        the new Tiedtke scheme is similar to the Tiedtke scheme used in REGCM4 and ECMWF cy40r1.
 !        the major differences to the old Tiedtke (cu_physics=6) scheme are,
@@ -29,21 +29,33 @@
 !   other refenrence: tiedtke (1989, mwr, 117, 1779-1800)
 !                     IFS documentation - cy33r1, cy37r2, cy38r1, cy40r1
 !
+!===========================================================
+!  Note for climate simulation of Tropical Cyclones
+!  This version of Tiedtke scheme was tested with YSU PBL scheme, RRTMG radation
+!  schemes, and WSM6 microphysics schemes, at horizontal resolution around 20 km
+!  Set: momtrans = 2. 
+!       pgcoef   = 0.7 to 1.0 is good depends on the basin 
+!       nonequil = .false.
+!===========================================================
+!  Note for the diurnal simulation of precipitaton
+!  When nonequil = .true., the CAPE is relaxed toward to a value from PBL
+!  It can improve the diurnal precipitation over land. 
+!===========================================================
 !###########################################################
 
 module module_cu_ntiedtke
 
 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
      use module_model_constants, only:rd=>r_d, rv=>r_v, &
-   &       cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, g              
+   &       cpd=>cp, alv=>xlv, als=>xls, alf=>xlf, t13=>Prandtl, g              
 
      implicit none
      real,private :: rcpd,vtmpc1,tmelt,                &
              c1es,c2es,c3les,c3ies,c4les,c4ies,c5les,c5ies,zrg
 
      real,private :: r5alvcp,r5alscp,ralvdcp,ralsdcp,ralfdcp,rtwat,rtber,rtice 
-     real,private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon
-     integer,private :: momtrans,p950,p650
+     real,private :: entrdd,cmfcmax,cmfcmin,cmfdeps,zdnoprc,cprcon,pgcoef
+     integer,private :: momtrans
 
      parameter(         &
       rcpd=1.0/cpd,     &
@@ -98,12 +110,25 @@ module module_cu_ntiedtke
 !     -------
 !
 !     momtrans: momentum transport method
+!     ( 1 = IFS40r1 method; 2 = new method )
 !
       parameter(momtrans = 2 )
 !     -------
 !
+!     coefficient for pressure gradient intensity
+!     (0.7 - 1.0 is recommended in this vesion of Tiedtke scheme) 
+      parameter(pgcoef=0.7)
+!     -------
+!
+      logical :: nonequil
+!     nonequil: representing equilibrium and nonequilibrium convection
+!     ( .false. [equilibrium: removing all CAPE]; .true. [nonequilibrium: relaxing CAPE toward CAPE from PBL]. 
+!       Ref. Bechtold et al. 2014 JAS )
+! 
+      parameter(nonequil = .true. )
+!
 !--------------------
-!     switches for deep, mid, shallow convections, downdraft, and momemtum transport
+!     switches for deep, mid, shallow convections, downdraft, and momentum transport
 !     ------------------
       logical :: lmfpen,lmfmid,lmfscv,lmfdd,lmfdudv
       parameter(lmfpen=.true.,lmfmid=.true.,lmfscv=.true.,lmfdd=.true.,lmfdudv=.true.)
@@ -254,7 +279,7 @@ subroutine cu_ntiedtke(                                    &
                                         rcs,                            &
                                         rn,                             &
                                         evap,                           &
-                                        heatflux                       
+                                        heatflux
       integer  , dimension(its:ite) ::  slimsk
 
 
@@ -295,7 +320,7 @@ subroutine cu_ntiedtke(                                    &
                                         kx1
 
 !-------other local variables----
-      integer                      :: zz
+      integer                      :: zz, pp
 !-----------------------------------------------------------------------
 !
 !
@@ -348,8 +373,9 @@ subroutine cu_ntiedtke(                                    &
         enddo
       enddo
 
+      pp = 0
       do k=kts,kte
-        zz = kte+1-k
+        zz = kte-pp
         do i=its,ite
           u1(i,zz)=u3d(i,k,j)
           v1(i,zz)=v3d(i,k,j)
@@ -368,14 +394,17 @@ subroutine cu_ntiedtke(                                    &
           ghtl(i,zz)=zl(i,k)
           prsl(i,zz) = pcps(i,k,j)
         enddo
+        pp = pp + 1
       enddo
 
+      pp = 0
       do k=kts,kte+1
-        zz = kte+2-k
+        zz = kte+1-pp
         do i=its,ite
           ghti(i,zz) = zi(i,k)
           prsi(i,zz) = p8w(i,k,j) 
         enddo
+        pp = pp + 1
       enddo
 !
       do i=its,ite
@@ -392,34 +421,40 @@ subroutine cu_ntiedtke(                                    &
          pratec(i,j)=rn(i)/(stepcu * dt)
       enddo
 
+      pp = 0
       do k=kts,kte
-        zz = kte+1-k
+        zz = kte-pp
         do i=its,ite
           rthcuten(i,k,j)=(t1(i,zz)-t3d(i,k,j))/pi3d(i,k,j)*rdelt
           rqvcuten(i,k,j)=(q1(i,zz)-qv3d(i,k,j))*rdelt
           rucuten(i,k,j) =(u1(i,zz)-u3d(i,k,j))*rdelt
           rvcuten(i,k,j) =(v1(i,zz)-v3d(i,k,j))*rdelt
         enddo
+        pp = pp + 1
       enddo
 
       if(present(rqccuten))then
         if ( f_qc ) then
+          pp = 0
           do k=kts,kte
-            zz = kte+1-k
+            zz = kte-pp
             do i=its,ite
               rqccuten(i,k,j)=(q2(i,zz)-qc3d(i,k,j))*rdelt
             enddo
+            pp = pp + 1
           enddo
         endif
       endif
 
       if(present(rqicuten))then
         if ( f_qi ) then
+          pp = 0
           do k=kts,kte
-            zz = kte+1-k
+            zz = kte-pp
             do i=its,ite
               rqicuten(i,k,j)=(q3(i,zz)-qi3d(i,k,j))*rdelt
             enddo
+            pp = pp + 1
           enddo
         endif
       endif
@@ -769,17 +804,6 @@ subroutine cumastrn  &
       zcons=1./(g*ztmst)
       zcons2=3./(g*ztmst)
 
-      zlon = real(klon)
-      do jk = klev , 1 , -1
-        pmean(jk) = sum(pap(:,jk))/zlon
-      end do
-      p950 = klev-2
-      p650 = klev-2  
-      do jk = klev , 3 , -1
-        if ( pmean(jk)/pmean(klev)*1.013250e5 >  950.e2 ) p950 = jk
-        if ( pmean(jk)/pmean(klev)*1.013250e5 >  650.e2 ) p650 = jk
-      end do
-      p950 = min(klev-2,p950)
 !--------------------------------------------------------------
 !*    2.    initialize values at vertical grid points in 'cuini'
 !--------------------------------------------------------------
@@ -819,8 +843,10 @@ subroutine cumastrn  &
          if(jk.ge.kcbot(jl) .and. ldcum(jl)) then
             zdhpbl(jl)=zdhpbl(jl)+(alv*pqte(jl,jk)+cpd*ptte(jl,jk))&
      &                 *(paph(jl,jk+1)-paph(jl,jk))
-            wspeed = sqrt(puen(jl,jk)**2 + pven(jl,jk)**2) 
-            upbl(jl) = upbl(jl) + wspeed*(paph(jl,jk+1)-paph(jl,jk))
+            if(lndj(jl) .eq. 0) then
+              wspeed = sqrt(puen(jl,jk)**2 + pven(jl,jk)**2) 
+              upbl(jl) = upbl(jl) + wspeed*(paph(jl,jk+1)-paph(jl,jk))
+            end if
          end if
        end do
        end do
@@ -938,13 +964,14 @@ subroutine cumastrn  &
         zcape2(jl)=0.0
         zmfub1(jl)=zmfub(jl)
     
-        upbl(jl) = max(2.,upbl(jl)/(paph(jl,klev+1)-paph(jl,ikb)))
         ztauc(jl)  = (zgeoh(jl,ikt)-zgeoh(jl,ikb)) / &
                    ((2.+ min(15.0,wup(jl)))*g)
-        if(lndj(jl) .eq. 1) then 
-          ztaubl(jl) = ztauc(jl)
+        if(lndj(jl) .eq. 0) then 
+          upbl(jl) = 2.+ upbl(jl)/(paph(jl,klev+1)-paph(jl,ikb))
+          ztaubl(jl) = (zgeoh(jl,ikb)-zgeoh(jl,klev+1))/(g*upbl(jl))
+          ztaubl(jl) = min(300., ztaubl(jl))
         else
-          ztaubl(jl) = (zgeoh(jl,ikb)-zgeoh(jl,klev+1))*zrg/upbl(jl)
+          ztaubl(jl) = ztauc(jl)
         end if
       end if    
       end do
@@ -964,12 +991,11 @@ subroutine cumastrn  &
         end if
 
         if ( llo1 .and. jk >= kcbot(jl) ) then
-          ikb = kcbot(jl)
-          if(paph(jl,klev+1)-paph(jl,ikb) <= 50.e2) then
-            zdp = paph(jl,jk+1)-paph(jl,jk)
-            zcape2(jl) = zcape2(jl) + ztaubl(jl)* &
-                      (ptte(jl,jk)+vtmpc1*pten(jl,jk)*pqte(jl,jk))*zdp 
-          end if
+        if((paph(jl,klev+1)-paph(jl,kdpl(jl)))<50.e2) then
+          zdp = paph(jl,jk+1)-paph(jl,jk)
+          zcape2(jl) = zcape2(jl) + ztaubl(jl)* &
+                     ((1.+vtmpc1*pqen(jl,jk))*ptte(jl,jk)+vtmpc1*pten(jl,jk)*pqte(jl,jk))*zdp 
+        end if
         end if
       end do
       end do
@@ -980,10 +1006,14 @@ subroutine cumastrn  &
            ikt = kctop(jl)
            ztau = ztauc(jl) * (1.+1.33e-5*dx)
            ztau = max(ztmst,ztau)
-           ztau = max(720.,ztau)
+           ztau = max(360.,ztau)
            ztau = min(10800.,ztau)
-           zcape2(jl)= max(0.,zcape2(jl))
-           zcape(jl) = max(0.,min(zcape1(jl)-zcape2(jl),5000.))
+           if(nonequil) then
+             zcape2(jl)= max(0.,zcape2(jl))
+             zcape(jl) = max(0.,min(zcape1(jl)-zcape2(jl),5000.))
+           else
+             zcape(jl) = max(0.,min(zcape1(jl),5000.))
+           end if
            zheat(jl) = max(1.e-4,zheat(jl))
            zmfub1(jl) = (zcape(jl)*zmfub(jl))/(zheat(jl)*ztau)
            zmfub1(jl) = max(zmfub1(jl),0.001)
@@ -1133,10 +1163,91 @@ subroutine cumastrn  &
      &  ,  zdmfup,   zdmfdp,   zdpmel,   zlglac                   &             
      &  ,  prain,    pmfdde_rate, pmflxr, pmflxs )     
 
-      do jl=1,klon
-        prsfc(jl) = pmflxr(jl,klev+1)
-        pssfc(jl) = pmflxs(jl,klev+1)
+! some adjustments needed
+    do jl=1,klon
+      zmfs(jl) = 1.
+      zmfuub(jl)=0.
+    end do
+    do jk = 2 , klev
+      do jl = 1,klon
+        if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then
+          zmfmax = pmfu(jl,jk)*0.98
+          if ( pmfd(jl,jk)+zmfmax+1.e-15 < 0. ) then
+            zmfs(jl) = min(zmfs(jl),-zmfmax/pmfd(jl,jk))
+          end if
+        end if
+      end do
+    end do
+
+    do jk = 2 , klev
+      do jl = 1 , klon
+        if ( zmfs(jl) < 1. .and. jk >= idtop(jl)-1 ) then
+          pmfd(jl,jk) = pmfd(jl,jk)*zmfs(jl)
+          zmfds(jl,jk) = zmfds(jl,jk)*zmfs(jl)
+          zmfdq(jl,jk) = zmfdq(jl,jk)*zmfs(jl)
+          pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk)*zmfs(jl)
+          zmfuub(jl) = zmfuub(jl) - (1.-zmfs(jl))*zdmfdp(jl,jk)
+          pmflxr(jl,jk+1) = pmflxr(jl,jk+1) + zmfuub(jl)
+          zdmfdp(jl,jk) = zdmfdp(jl,jk)*zmfs(jl)
+        end if
+      end do
+    end do
+
+    do jk = 2 , klev - 1
+      do jl = 1, klon
+        if ( loddraf(jl) .and. jk >= idtop(jl)-1 ) then
+          zerate = -pmfd(jl,jk) + pmfd(jl,jk-1) + pmfdde_rate(jl,jk)
+          if ( zerate < 0. ) then
+            pmfdde_rate(jl,jk) = pmfdde_rate(jl,jk) - zerate
+          end if
+        end if
+        if ( ldcum(jl) .and. jk >= kctop(jl)-1 ) then
+          zerate = pmfu(jl,jk) - pmfu(jl,jk+1) + pmfude_rate(jl,jk)
+          if ( zerate < 0. ) then
+            pmfude_rate(jl,jk) = pmfude_rate(jl,jk) - zerate
+          end if
+          zdmfup(jl,jk) = pmflxr(jl,jk+1) + pmflxs(jl,jk+1) - &
+                          pmflxr(jl,jk) - pmflxs(jl,jk)
+          zdmfdp(jl,jk) = 0.
+        end if
       end do
+    end do
+
+! avoid negative humidities at ddraught top
+    do jl = 1,klon
+      if ( loddraf(jl) ) then
+        jk = idtop(jl)
+        ik = min(jk+1,klev)
+        if ( zmfdq(jl,jk) < 0.3*zmfdq(jl,ik) ) then
+            zmfdq(jl,jk) = 0.3*zmfdq(jl,ik)
+        end if
+      end if
+    end do
+
+! avoid negative humidities near cloud top because gradient of precip flux
+! and detrainment / liquid water flux are too large
+    do jk = 2 , klev
+      do jl = 1, klon
+        if ( ldcum(jl) .and. jk >= kctop(jl)-1 .and. jk < kcbot(jl) ) then
+          zdz = ztmst*g/(paph(jl,jk+1)-paph(jl,jk))
+          zmfa = zmfuq(jl,jk+1) + zmfdq(jl,jk+1) - &
+                 zmfuq(jl,jk) - zmfdq(jl,jk) + &
+                 zmful(jl,jk+1) - zmful(jl,jk) + zdmfup(jl,jk)
+          zmfa = (zmfa-plude(jl,jk))*zdz
+          if ( pqen(jl,jk)+zmfa < 0. ) then
+            plude(jl,jk) = plude(jl,jk) + 2.*(pqen(jl,jk)+zmfa)/zdz
+          end if
+          if ( plude(jl,jk) < 0. ) plude(jl,jk) = 0.
+        end if
+        if ( .not. ldcum(jl) ) pmfude_rate(jl,jk) = 0.
+        if ( abs(pmfd(jl,jk-1)) < 1.0e-20 ) pmfdde_rate(jl,jk) = 0.
+      end do
+    end do
+
+    do jl=1,klon
+      prsfc(jl) = pmflxr(jl,klev+1)
+      pssfc(jl) = pmflxs(jl,klev+1)
+    end do
 
 !----------------------------------------------------------------
 !*    8.0      update tendencies for t and q in subroutine cudtdq
@@ -1175,15 +1286,10 @@ subroutine cumastrn  &
               zvu(jl,jk) = (zvu(jl,ik)*pmfu(jl,ik) + &
                 zerate*pven(jl,jk)-zderate*zvu(jl,ik))*zmfa
             else
-              if(ktype(jl) == 1 .or. ktype(jl) == 3) then
-                pgf_u   =  -0.7*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+&
+              pgf_u = -pgcoef*0.5*(pmfu(jl,ik)*(puen(jl,ik)-puen(jl,jk))+&
                                    pmfu(jl,jk)*(puen(jl,jk)-puen(jl,jk-1)))
-                pgf_v   =  -0.7*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+&
+              pgf_v = -pgcoef*0.5*(pmfu(jl,ik)*(pven(jl,ik)-pven(jl,jk))+&
                                    pmfu(jl,jk)*(pven(jl,jk)-pven(jl,jk-1)))
-              else
-                pgf_u   = 0.
-                pgf_v   = 0.
-              end if
               zerate = pmfu(jl,jk) - pmfu(jl,ik) + pmfude_rate(jl,jk)
               zderate = pmfude_rate(jl,jk)
               zmfa = 1./max(cmfcmin,pmfu(jl,jk))
@@ -1528,17 +1634,15 @@ subroutine cutypen &
       real     fscale,crirh1,pp
       real     atop1,atop2,abot
       real     tmix,zmix,qmix,pmix
-      real     zlglac,dp,t13
+      real     zlglac,dp
       integer  nk,is,ikb,ikt
 
       real     zqsu,zcor,zdp,zesdp,zalfaw,zfacw,zfaci,zfac,zdsdp,zdqsdt,zdtdp
       real     zpdifftop, zpdiffbot
-      integer  zcbase(klon)
+      integer  zcbase(klon), itoppacel(klon)
       integer  jl,jk,ik,icall,levels
       logical  needreset, lldcum(klon)
 !--------------------------------------------------------------
-      t13 = 1.0/3.0
-!
       do jl=1,klon
         kcbot(jl)=klev
         kctop(jl)=klev
@@ -1581,9 +1685,9 @@ subroutine cutypen &
 ! define the variables at the first level      
       if(jk .eq. klevm1) then
       do jl=1,klon
-        rho=paph(jl,klev+1)/ &
+        rho=pap(jl,klev)/ &
      &         (rd*(pten(jl,klev)*(1.+vtmpc1*pqen(jl,klev))))
-        part1 = 1.5*0.4*(pgeoh(jl,klev)-pgeoh(jl,klev+1))/ &
+        part1 = 1.5*0.4*pgeo(jl,klev)/ &
      &              (rho*pten(jl,klev))
         part2 = -hfx(jl)*rcpd-vtmpc1*pten(jl,klev)*qfx(jl)
         root  = 0.001-part1*part2
@@ -1617,7 +1721,7 @@ subroutine cutypen &
 ! the next levels, we use the variables at the first level as initial values
       do jl=1,klon
       if(loflag(jl)) then
-        eta(jl) = 0.55/((pgeoh(jl,jk)-pgeoh(jl,klev+1))*zrg)+1.0e-4
+        eta(jl) = 0.8/(pgeo(jl,jk)*zrg)+2.e-4
         dz(jl)  = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
         coef(jl)= 0.5*eta(jl)*dz(jl)
         dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk)
@@ -1694,10 +1798,12 @@ subroutine cutypen &
             else
               lldcum(jl) = .false.
             end if
-          else if(plu(jl,jk) .gt. 0.)then
+          else 
+            if(plu(jl,jk) .gt. 0.)then
               klab(jl,jk)=2
-          else
+            else
               klab(jl,jk)=1
+            end if
           end if
         end if
       end do
@@ -1749,7 +1855,13 @@ subroutine cutypen &
         deepflag(jl) = .false.
       end do
 
-      do levels=klevm1-1,p650,-1 ! loop starts
+      do jk=klev,1,-1
+       do jl=1,klon
+         if((paph(jl,klev+1)-paph(jl,jk)) .lt. 350.e2) itoppacel(jl) = jk
+       end do
+      end do
+
+      do levels=klevm1-1,klev/2+1,-1 ! loop starts
         do jk=1,klev
           do jl=1,klon
              plu(jl,jk)=0.0  ! parcel liquid water
@@ -1772,7 +1884,7 @@ subroutine cutypen &
            zqold(jl)    = 0.
            lldcum(jl)   = .false.
            resetflag(jl)= .false.
-           loflag(jl)   = .not. deepflag(jl)
+           loflag(jl)   = (.not. deepflag(jl)) .and. (levels.ge.itoppacel(jl))
         end do
 
 ! start the inner loop to search the deep convection points
@@ -1834,10 +1946,10 @@ subroutine cutypen &
              dz(jl)  = (pgeoh(jl,jk)-pgeoh(jl,jk+1))*zrg
              coef(jl)= 0.5*eta(jl)*dz(jl)
              dhen(jl,jk) = pgeoh(jl,jk) + cpd*ptenh(jl,jk)
-             dh(jl,jk) = 0.5*coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))&
-     &                  +(1.-coef(jl))*dh(jl,jk+1)
-             pqu(jl,jk) =0.5*coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))&
-     &                  +(1.-coef(jl))*pqu(jl,jk+1)
+             dh(jl,jk) = (coef(jl)*(dhen(jl,jk+1)+dhen(jl,jk))&
+     &              +(1.-coef(jl))*dh(jl,jk+1))/(1.+coef(jl))
+             pqu(jl,jk) =(coef(jl)*(pqenh(jl,jk+1)+pqenh(jl,jk))&
+     &              +(1.-coef(jl))*pqu(jl,jk+1))/(1.+coef(jl))
              ptu(jl,jk) = (dh(jl,jk)-pgeoh(jl,jk))*rcpd
              zqold(jl) = pqu(jl,jk)
              zph(jl)=paph(jl,jk)
@@ -1907,10 +2019,12 @@ subroutine cutypen &
             else
               lldcum(jl) = .false.
             end if
-          else if(plu(jl,jk) .gt. 0.)then
+          else 
+            if(plu(jl,jk) .gt. 0.)then
               klab(jl,jk)=2
-          else
+            else
               klab(jl,jk)=1
+            end if
           end if
         end if
       end do
@@ -2350,7 +2464,7 @@ subroutine cuascn &
                 plude(jl,jk) = plu(jl,jk+1)*zdmfde(jl)
                 pmfu(jl,jk) = pmfu(jl,jk+1) + zdmfen(jl) - zdmfde(jl)
               end if
-              if ( zbuo(jl,jk) > 0.  ) then
+              if ( zbuo(jl,jk) > -0.2  ) then
                 ikb = kcbot(jl)
                 zoentr(jl) = 1.75e-3*(0.3-(min(1.,pqen(jl,jk-1) /    &
                   pqsen(jl,jk-1))-1.))*(pgeoh(jl,jk-1)-pgeoh(jl,jk)) * &
@@ -2793,11 +2907,10 @@ subroutine cuddrafn                                 &
       logical  llo1
 ! local variables
       integer  jl,jk
-      integer  is,ik,icall,ike, itopde
+      integer  is,ik,icall,ike, itopde(klon)
       real     zentr,zdz,zzentr,zseen,zqeen,zsdde,zqdde,zdmfdp
       real     zmfdsk,zmfdqk,zbuo,zrain,zbuoyz,zmfduk,zmfdvk
                                                                 
-      itopde=p950          
 !----------------------------------------------------------------------   
 !     1.           calculate moist descent for cumulus downdraft by       
 !                     (a) calculating entrainment/detrainment rates,      
@@ -2809,90 +2922,117 @@ subroutine cuddrafn                                 &
 !                     (c) checking for negative buoyancy and              
 !                         specifying final t,q,u,v and downward fluxes    
 !                    -------------------------------------------------    
-      do jl=1,klon
-        zdmfen(jl)=0.
+      do jl=1,klon                                                   
+        zoentr(jl)=0.                                                     
+        zbuoy(jl)=0.                                                      
+        zdmfen(jl)=0.                                                     
         zdmfde(jl)=0.
-      enddo
+      enddo 
 
-      do jk=1,klev
+      do jk=klev,1,-1
        do jl=1,klon
          pmfdde_rate(jl,jk) = 0.
+         if((paph(jl,klev+1)-paph(jl,jk)).lt. 60.e2) itopde(jl) = jk
        end do
-      end do
-
-      do jk=3,klev
-      is=0
-      do jl=1,klon
-      zph(jl)=paph(jl,jk)
-      llo2(jl)=lddraf(jl).and.pmfd(jl,jk-1).lt.0.
-      if(llo2(jl)) then
-         is=is+1
-      endif
-      end do
-
-      if(is.eq.0) cycle
-      do jl=1,klon
-      if(llo2(jl)) then
-         zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg
-         zdmfen(jl)=zentr
-         zdmfde(jl)=zentr
-      end if
-      end do
-
-      if(jk.gt.itopde) then
-         do jl=1,klon
-         if(llo2(jl)) then
+      end do                                                              
+                                                                 
+      do jk=3,klev                                                        
+        is=0                                                              
+        do jl=1,klon                                                 
+          zph(jl)=paph(jl,jk)                                             
+          llo2(jl)=lddraf(jl).and.pmfd(jl,jk-1).lt.0.                     
+          if(llo2(jl)) then                                               
+            is=is+1                                                       
+          endif                                                           
+        enddo                                                             
+        if(is.eq.0) cycle                                                 
+                                                                          
+        do jl=1,klon                                                 
+          if(llo2(jl)) then    
+            zentr = entrdd*pmfd(jl,jk-1)*(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg
+            zdmfen(jl)=zentr                                              
+            zdmfde(jl)=zentr                                              
+          endif                                                           
+        enddo 
+                                                            
+        do jl=1,klon
+          if(llo2(jl)) then
+          if(jk.gt.itopde(jl)) then
             zdmfen(jl)=0.
-            zdmfde(jl)=pmfd(jl,itopde)*      &
-            (paph(jl,jk)-paph(jl,jk-1))/     &
-            (paph(jl,klev+1)-paph(jl,itopde))
-         end if
-         end do
-      end if
+            zdmfde(jl)=pmfd(jl,itopde(jl))*                    &
+     &       (paph(jl,jk)-paph(jl,jk-1))/                  &
+     &       (paph(jl,klev+1)-paph(jl,itopde(jl)))
+          endif
+          endif
+        enddo
 
-      do jl=1,klon
-         if(llo2(jl)) then
-            pmfd(jl,jk)=pmfd(jl,jk-1)+zdmfen(jl)-zdmfde(jl)
-            zseen=(cpd*ptenh(jl,jk-1)+pgeoh(jl,jk-1))*zdmfen(jl)
-            zqeen=pqenh(jl,jk-1)*zdmfen(jl)
-            zsdde=(cpd*ptd(jl,jk-1)+pgeoh(jl,jk-1))*zdmfde(jl)
-            zqdde=pqd(jl,jk-1)*zdmfde(jl)
-            zmfdsk=pmfds(jl,jk-1)+zseen-zsdde
-            zmfdqk=pmfdq(jl,jk-1)+zqeen-zqdde
-            pqd(jl,jk)=zmfdqk*(1./min(-cmfcmin,pmfd(jl,jk)))
-            ptd(jl,jk)=(zmfdsk*(1./min(-cmfcmin,pmfd(jl,jk)))- &
-                       pgeoh(jl,jk))*rcpd
-            ptd(jl,jk)=min(400.,ptd(jl,jk))
-            ptd(jl,jk)=max(100.,ptd(jl,jk))
-            zcond(jl)=pqd(jl,jk)
-         end if
-      end do
+        do jl=1,klon
+          if(llo2(jl)) then
+          if(jk.le.itopde(jl)) then
+            zdz=-(pgeoh(jl,jk-1)-pgeoh(jl,jk))*zrg
+            zzentr=zoentr(jl)*zdz*pmfd(jl,jk-1)
+            zdmfen(jl)=zdmfen(jl)+zzentr
+            zdmfen(jl)=max(zdmfen(jl),0.3*pmfd(jl,jk-1))
+            zdmfen(jl)=max(zdmfen(jl),-0.75*pmfu(jl,jk)-   &
+   &         (pmfd(jl,jk-1)-zdmfde(jl)))
+            zdmfen(jl)=min(zdmfen(jl),0.)
+          endif
+          endif
+        enddo
 
-      ik=jk
-      icall=2
-      call cuadjtqn(klon,klev,ik,zph,ptd,pqd,llo2,icall)
-      do jl=1,klon
-         if(llo2(jl)) then
+        do jl=1,klon                                                 
+          if(llo2(jl)) then                                               
+            pmfd(jl,jk)=pmfd(jl,jk-1)+zdmfen(jl)-zdmfde(jl)
+            zseen=(cpd*ptenh(jl,jk-1)+pgeoh(jl,jk-1))*zdmfen(jl)         
+            zqeen=pqenh(jl,jk-1)*zdmfen(jl)                               
+            zsdde=(cpd*ptd(jl,jk-1)+pgeoh(jl,jk-1))*zdmfde(jl)           
+            zqdde=pqd(jl,jk-1)*zdmfde(jl)                                 
+            zmfdsk=pmfds(jl,jk-1)+zseen-zsdde                             
+            zmfdqk=pmfdq(jl,jk-1)+zqeen-zqdde                             
+            pqd(jl,jk)=zmfdqk*(1./min(-cmfcmin,pmfd(jl,jk)))              
+            ptd(jl,jk)=(zmfdsk*(1./min(-cmfcmin,pmfd(jl,jk)))-&            
+     &                  pgeoh(jl,jk))*rcpd                                
+            ptd(jl,jk)=min(400.,ptd(jl,jk))                               
+            ptd(jl,jk)=max(100.,ptd(jl,jk))                               
+            zcond(jl)=pqd(jl,jk)                                          
+          endif                                                           
+        enddo                                                             
+                                                                          
+        ik=jk                                                             
+        icall=2                                                           
+        call cuadjtqn(klon, klev, ik, zph, ptd, pqd, llo2, icall )                
+                                                                          
+        do jl=1,klon                                                 
+          if(llo2(jl)) then                                               
             zcond(jl)=zcond(jl)-pqd(jl,jk)
-            zbuo=ptd(jl,jk)*(1.+vtmpc1*pqd(jl,jk))- &
-                 ptenh(jl,jk)*(1.+vtmpc1*pqenh(jl,jk))
-            if(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then
-              zrain=prfl(jl)/pmfu(jl,jk)
+            zbuo=ptd(jl,jk)*(1.+vtmpc1  *pqd(jl,jk))-          &             
+     &      ptenh(jl,jk)*(1.+vtmpc1  *pqenh(jl,jk))                         
+            if(prfl(jl).gt.0..and.pmfu(jl,jk).gt.0.) then                 
+              zrain=prfl(jl)/pmfu(jl,jk)                                  
               zbuo=zbuo-ptd(jl,jk)*zrain
+            endif                                                         
+            if(zbuo.ge.0 .or. prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then    
+              pmfd(jl,jk)=0.
+              zbuo=0.                                              
             endif
-            if(zbuo.ge.0..or.prfl(jl).le.(pmfd(jl,jk)*zcond(jl))) then
-               pmfd(jl,jk)=0.
-            end if
-            pmfds(jl,jk)=(cpd*ptd(jl,jk)+pgeoh(jl,jk))*pmfd(jl,jk)
-            pmfdq(jl,jk)=pqd(jl,jk)*pmfd(jl,jk)
-            zdmfdp=-pmfd(jl,jk)*zcond(jl)
-            pdmfdp(jl,jk-1)=zdmfdp
-            prfl(jl)=prfl(jl)+zdmfdp
+            pmfds(jl,jk)=(cpd*ptd(jl,jk)+pgeoh(jl,jk))*pmfd(jl,jk)       
+            pmfdq(jl,jk)=pqd(jl,jk)*pmfd(jl,jk)                           
+            zdmfdp=-pmfd(jl,jk)*zcond(jl)                                 
+            pdmfdp(jl,jk-1)=zdmfdp                                        
+            prfl(jl)=prfl(jl)+zdmfdp                                      
+                                                                          
+! compute organized entrainment for use at next level                     
+            zbuoyz=zbuo/ptenh(jl,jk)                                      
+            zbuoyz=min(zbuoyz,0.0)                                        
+            zdz=-(pgeo(jl,jk-1)-pgeo(jl,jk))
+            zbuoy(jl)=zbuoy(jl)+zbuoyz*zdz
+            zoentr(jl)=g*zbuoyz*0.5/(1.+zbuoy(jl)) 
             pmfdde_rate(jl,jk) = -zdmfde(jl)
-          end if                                                           
-        end do
+          endif                                                           
+        enddo
                                                              
-      end do                                                               
+      enddo                                                               
+                                                                          
       return                                                              
       end subroutine cuddrafn
 !---------------------------------------------------------
@@ -3249,8 +3389,6 @@ subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, &
 ! local variables
     integer  jk , ik , jl
     real     zalv , zzp
-    real     zmfus(klon,klev) , zmfuq(klon,klev) 
-    real     zmfds(klon,klev) , zmfdq(klon,klev)
     real     zdtdt(klon,klev) , zdqdt(klon,klev) , zdp(klon,klev)
     !*    1.0          SETUP AND INITIALIZATIONS
     ! -------------------------
@@ -3258,10 +3396,6 @@ subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, &
       do jl = 1, klon
         if ( ldcum(jl) ) then
           zdp(jl,jk) = g/(paph(jl,jk+1)-paph(jl,jk))
-          zmfus(jl,jk) = pmfus(jl,jk)
-          zmfds(jl,jk) = pmfds(jl,jk)
-          zmfuq(jl,jk) = pmfuq(jl,jk)
-          zmfdq(jl,jk) = pmfdq(jl,jk)
         end if
       end do
     end do
@@ -3274,11 +3408,11 @@ subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, &
           if ( ldcum(jl) ) then
             zalv = foelhm(pten(jl,jk))
             zdtdt(jl,jk) = zdp(jl,jk)*rcpd * &
-              (zmfus(jl,jk+1)-zmfus(jl,jk)+zmfds(jl,jk+1) - &
-               zmfds(jl,jk)+alf*plglac(jl,jk)-alf*pdpmel(jl,jk) - &
+              (pmfus(jl,jk+1)-pmfus(jl,jk)+pmfds(jl,jk+1) - &
+               pmfds(jl,jk)+alf*plglac(jl,jk)-alf*pdpmel(jl,jk) - &
                zalv*(pmful(jl,jk+1)-pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk)))
-            zdqdt(jl,jk) = zdp(jl,jk)*(zmfuq(jl,jk+1) - &
-              zmfuq(jl,jk)+zmfdq(jl,jk+1)-zmfdq(jl,jk)+pmful(jl,jk+1) - &
+            zdqdt(jl,jk) = zdp(jl,jk)*(pmfuq(jl,jk+1) - &
+              pmfuq(jl,jk)+pmfdq(jl,jk+1)-pmfdq(jl,jk)+pmful(jl,jk+1) - &
               pmful(jl,jk)-plude(jl,jk)-pdmfup(jl,jk)-pdmfdp(jl,jk))
           end if
         end do
@@ -3287,10 +3421,10 @@ subroutine cudtdqn(klon,klev,ktopm2,kctop,kdtop,ldcum, &
           if ( ldcum(jl) ) then
             zalv = foelhm(pten(jl,jk))
             zdtdt(jl,jk) = -zdp(jl,jk)*rcpd * &
-              (zmfus(jl,jk)+zmfds(jl,jk)+alf*pdpmel(jl,jk) - &
-               zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)))
-            zdqdt(jl,jk) = -zdp(jl,jk)*(zmfuq(jl,jk) + &
-              zmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)))
+              (pmfus(jl,jk)+pmfds(jl,jk)+alf*pdpmel(jl,jk) - &
+               zalv*(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)+plude(jl,jk)))
+            zdqdt(jl,jk) = -zdp(jl,jk)*(pmfuq(jl,jk) + plude(jl,jk) + &
+              pmfdq(jl,jk)+(pmful(jl,jk)+pdmfup(jl,jk)+pdmfdp(jl,jk)))
           end if
         end do
       end if
diff --git a/wrfv2_fire/phys/module_cu_scalesas.F b/wrfv2_fire/phys/module_cu_scalesas.F
new file mode 100755
index 00000000..f90e96be
--- /dev/null
+++ b/wrfv2_fire/phys/module_cu_scalesas.F
@@ -0,0 +1,4476 @@
+!!
+!! LOG
+!!  2015-12-10  Weiguo Wang  added gfs scale-aware SAS scheme to HWRF
+
+MODULE module_cu_scalesas 
+
+CONTAINS
+
+!-----------------------------------------------------------------
+      SUBROUTINE CU_SCALESAS(DT,ITIMESTEP,STEPCU,                        &
+                 RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,               &
+                 RUCUTEN,RVCUTEN,                                   & 
+                 RAINCV,PRATEC,HTOP,HBOT,                           &
+                 U3D,V3D,W,T3D,QV3D,QC3D,QI3D,PI3D,RHO3D,           &
+                 DZ8W,PCPS,P8W,XLAND,CU_ACT_FLAG,                   &
+                 P_QC,                                              & 
+                 MOMMIX, & ! gopal's doing
+                 PGCON,sas_mass_flux,                               &
+                 shalconv,shal_pgcon,                               &
+                 HPBL2D,EVAP2D,HEAT2D,                              & !Kwon for shallow convection
+                 P_QI,P_FIRST_SCALAR,                               & 
+                 DX2D, DY,                                          & ! Wang W for scale-aware cnv
+                 SCALEFUN, SCALEFUN1,                               & !cnv scale functions
+                 SIGMU,SIGMU1,                                      &
+                 ids,ide, jds,jde, kds,kde,                         &
+                 ims,ime, jms,jme, kms,kme,                         &
+                 its,ite, jts,jte, kts,kte                          )
+
+!-------------------------------------------------------------------
+      USE MODULE_GFS_MACHINE , ONLY : kind_phys
+      USE MODULE_GFS_FUNCPHYS , ONLY : gfuncphys
+      USE MODULE_GFS_PHYSCONS, grav => con_g, CP => con_CP, HVAP => con_HVAP  &
+     &,             RV => con_RV, FV => con_fvirt, T0C => con_T0C       &
+     &,             CVAP => con_CVAP, CLIQ => con_CLIQ                  & 
+     &,             EPS => con_eps, EPSM1 => con_epsm1                  &
+     &,             ROVCP => con_rocp, RD => con_rd
+!-------------------------------------------------------------------
+      IMPLICIT NONE
+!-------------------------------------------------------------------
+!-- U3D         3D u-velocity interpolated to theta points (m/s)
+!-- V3D         3D v-velocity interpolated to theta points (m/s)
+!-- TH3D	3D potential temperature (K)
+!-- T3D         temperature (K)
+!-- QV3D        3D water vapor mixing ratio (Kg/Kg)
+!-- QC3D        3D cloud mixing ratio (Kg/Kg)
+!-- QI3D        3D ice mixing ratio (Kg/Kg)
+!-- P8w         3D pressure at full levels (Pa)
+!-- Pcps        3D pressure (Pa)
+!-- PI3D	3D exner function (dimensionless)
+!-- rr3D	3D dry air density (kg/m^3)
+!-- RUBLTEN     U tendency due to
+!               PBL parameterization (m/s^2)
+!-- RVBLTEN     V tendency due to
+!               PBL parameterization (m/s^2)
+!-- RTHBLTEN    Theta tendency due to
+!               PBL parameterization (K/s)
+!-- RQVBLTEN    Qv tendency due to
+!               PBL parameterization (kg/kg/s)
+!-- RQCBLTEN    Qc tendency due to
+!               PBL parameterization (kg/kg/s)
+!-- RQIBLTEN    Qi tendency due to
+!               PBL parameterization (kg/kg/s)
+!
+!-- MOMMIX      MOMENTUM MIXING COEFFICIENT (can be set in the namelist)
+!-- RUCUTEN     U tendency due to Cumulus Momentum Mixing (gopal's doing for SAS)
+!-- RVCUTEN     V tendency due to Cumulus Momentum Mixing (gopal's doing for SAS)
+!
+!-- CP          heat capacity at constant pressure for dry air (J/kg/K)
+!-- GRAV        acceleration due to gravity (m/s^2)
+!-- ROVCP       R/CP
+!-- RD          gas constant for dry air (J/kg/K)
+!-- ROVG 	R/G
+!-- P_QI	species index for cloud ice
+!-- dz8w	dz between full levels (m)
+!-- z		height above sea level (m)
+!-- PSFC        pressure at the surface (Pa)
+!-- UST		u* in similarity theory (m/s)
+!-- PBL		PBL height (m)
+!-- PSIM        similarity stability function for momentum
+!-- PSIH        similarity stability function for heat
+!-- HFX		upward heat flux at the surface (W/m^2)
+!-- QFX		upward moisture flux at the surface (kg/m^2/s)
+!-- TSK		surface temperature (K)
+!-- GZ1OZ0      log(z/z0) where z0 is roughness length
+!-- WSPD        wind speed at lowest model level (m/s)
+!-- BR          bulk Richardson number in surface layer
+!-- DT		time step (s)
+!-- rvovrd      R_v divided by R_d (dimensionless)
+!-- EP1         constant for virtual temperature (R_v/R_d - 1) (dimensionless)
+!-- KARMAN      Von Karman constant
+!-- ids         start index for i in domain
+!-- ide         end index for i in domain
+!-- jds         start index for j in domain
+!-- jde         end index for j in domain
+!-- kds         start index for k in domain
+!-- kde         end index for k in domain
+!-- ims         start index for i in memory
+!-- ime         end index for i in memory
+!-- jms         start index for j in memory
+!-- jme         end index for j in memory
+!-- kms         start index for k in memory
+!-- kme         end index for k in memory
+!-- its         start index for i in tile
+!-- ite         end index for i in tile
+!-- jts         start index for j in tile
+!-- jte         end index for j in tile
+!-- kts         start index for k in tile
+!-- kte         end index for k in tile
+!-------------------------------------------------------------------
+
+      INTEGER ::                        ICLDCK
+
+      INTEGER, INTENT(IN) ::            ids,ide, jds,jde, kds,kde,      &
+                                        ims,ime, jms,jme, kms,kme,      &
+                                        its,ite, jts,jte, kts,kte,      &
+                                        ITIMESTEP,                      &     !NSTD
+                                        P_FIRST_SCALAR,                 &
+                                        P_QC,                           &
+                                        P_QI,                           &
+                                        STEPCU
+
+      REAL,    INTENT(IN) ::                                            &
+                                        DT
+
+!wang
+      REAL,    INTENT(IN) ::            DY 
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(IN) :: DX2D
+      REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(OUT) :: SCALEFUN,SCALEFUN1, & !updaft area fraction for deep and shallow cnv
+                                                     SIGMU, SIGMU1      !updaft area fraction for      deep and shallow cnv
+
+!wang
+
+      REAL, OPTIONAL, INTENT(IN) :: PGCON,sas_mass_flux,shal_pgcon
+      INTEGER, OPTIONAL, INTENT(IN) :: shalconv
+      REAL(kind=kind_phys)       :: PGCON_USE,SHAL_PGCON_USE,massf
+      INTEGER :: shalconv_use
+      REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(INOUT) ::      &
+                                        RQCCUTEN,                       &
+                                        RQICUTEN,                       &
+                                        RQVCUTEN,                       &
+                                        RTHCUTEN
+      REAL, DIMENSION(ims:ime, jms:jme, kms:kme), INTENT(INOUT) ::      &
+                                        RUCUTEN,                        &  
+                                        RVCUTEN                             
+      REAL, OPTIONAL,   INTENT(IN) ::    MOMMIX
+
+      REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL,                   &
+                         INTENT(IN) :: HPBL2D,EVAP2D,HEAT2D                !Kwon for sha
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
+                                        XLAND
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            &
+                                        RAINCV, PRATEC
+
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(OUT) ::              &
+                                        HBOT,                           &
+                                        HTOP
+
+      LOGICAL, DIMENSION(IMS:IME,JMS:JME), INTENT(INOUT) ::             &
+                                        CU_ACT_FLAG
+
+
+      REAL,    DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN) ::      &
+                                        DZ8W,                           &
+                                        P8w,                            &
+                                        Pcps,                           &
+                                        PI3D,                           &
+                                        QC3D,                           &
+                                        QI3D,                           &
+                                        QV3D,                           &
+                                        RHO3D,                          &
+                                        T3D,                            &
+                                        U3D,                            &
+                                        V3D,                            &
+                                        W
+
+!--------------------------- LOCAL VARS ------------------------------
+
+      REAL,    DIMENSION(ims:ime, jms:jme) ::                           &
+                                        PSFC
+
+      REAL,    DIMENSION(its:ite, jts:jte) ::                           &
+                                        RAINCV1, PRATEC1
+      REAL,    DIMENSION(its:ite, jts:jte) ::                           &
+                                        RAINCV2, PRATEC2
+
+      REAL     (kind=kind_phys) ::                                      &
+                                        DELT,                           &
+                                        DPSHC,                          &
+                                        RDELT,                          &
+                                        RSEED
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite) ::                  &
+                                        CLDWRK,                         &
+                                        PS,                             &
+                                        RCS,                            &
+                                        RN,                             &
+                                        SLIMSK,                         &
+                                        HPBL,EVAP,HEAT                     !Kwon for shallow convection
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite) :: garea             ! grid box area in m^2, 
+                                                                         ! Wang scale-aware cnv
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite) :: SCALEFUN_out,SCALEFUN1_out,&  !updraft area fraction for deep and shallow cnv 
+                                                      SIGMU_out,SIGMU1_out  !updraft area fraction for deep and shallow cnv
+
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte+1) ::       &
+                                        PRSI                            
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte) ::         &
+                                        DEL,                            &
+                                        DOT,                            &
+                                        PHIL,                           &
+                                        PRSL,                           &
+                                        PRSLK,                          &
+                                        Q1,                             & 
+                                        T1,                             & 
+                                        U1,                             & 
+                                        V1,                             & 
+                                        ZI,                             & 
+                                        ZL 
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte) ::         &
+                                        cnvw,cnvc,ud_mf,dd_mf,dt_mf        ! Wang, *_mf not useful for HWRF. it is for transport
+
+      REAL     (kind=kind_phys), DIMENSION(its:ite, kts:kte, 2) ::      &
+                                        QL 
+
+      INTEGER, DIMENSION(its:ite) ::                                    &
+                                        KBOT,                           &
+                                        KTOP,                           &
+                                        KCNV
+
+      INTEGER ::                                                        &
+                                        I,                              &
+                                        IGPVS,                          &
+                                        IM,                             &
+                                        J,                              &
+                                        JCAP,                           &
+                                        K,                              &
+                                        KM,                             &
+                                        KP,                             &
+                                        KX,                             &
+                                        NCLOUD 
+
+      DATA IGPVS/0/
+
+!-----------------------------------------------------------------------
+!
+  !     write(0,*)' in scale-aware sas'
+
+
+      if(present(shalconv)) then
+         shalconv_use=shalconv
+      else
+#if (NMM_CORE==1)
+         shalconv_use=0
+#else
+#if (EM_CORE==1)
+         shalconv_use=1
+#else
+         shalconv_use=0
+#endif
+#endif
+      endif
+
+      if(present(pgcon)) then
+         pgcon_use  = pgcon
+      else
+!        pgcon_use  = 0.7     ! Gregory et al. (1997, QJRMS)
+         pgcon_use  = 0.55    ! Zhang & Wu (2003,JAS), used in GFS (25km res spectral)
+!        pgcon_use  = 0.2     ! HWRF, for model tuning purposes
+!        pgcon_use  = 0.3     ! GFDL, or so I am told
+
+         ! For those attempting to tune pgcon:
+
+         ! The value of 0.55 comes from an observational study of
+         ! synoptic-scale deep convection and 0.7 came from an
+         ! incorrect fit to the same data.  That value is likely
+         ! correct for deep convection at gridscales near that of GFS,
+         ! but is questionable in shallow convection, or for scales
+         ! much finer than synoptic scales.
+
+         ! Then again, the assumptions of SAS break down when the
+         ! gridscale is near the convection scale anyway.  In a large
+         ! storm such as a hurricane, there is often no environment to
+         ! detrain into since adjancent gridsquares are also undergoing
+         ! active convection.  Each gridsquare will no longer have many
+         ! updrafts and downdrafts.  At sub-convective timescales, you
+         ! will find unstable columns for many (say, 5 second length)
+         ! timesteps in a real atmosphere during a convection cell's
+         ! lifetime, so forcing it to be neutrally stable is unphysical.
+
+         ! Hence, in scales near the convection scale (cells have
+         ! ~0.5-4km diameter in hurricanes), this parameter is more of a
+         ! tuning parameter to get a scheme that is inappropriate for
+         ! that resolution to do a reasonable job.
+
+         ! Your mileage might vary.
+
+         ! - Sam Trahan
+      endif
+
+      if(present(sas_mass_flux)) then
+         massf=sas_mass_flux
+         ! Use this to reduce the fluxes added by SAS to prevent
+         ! computational instability as a result of large fluxes.
+      else
+         massf=9e9 ! large number to disable check
+      endif
+
+      if(present(shal_pgcon)) then
+         if(shal_pgcon>=0) then
+            shal_pgcon_use  = shal_pgcon
+         else
+            ! shal_pgcon<0 means use deep pgcon
+            shal_pgcon_use  = pgcon_use
+         endif
+      else
+         ! Default: Same as deep convection pgcon
+         shal_pgcon_use  = pgcon_use
+         ! Read the warning above though.  It may be advisable for
+         ! these to be different.  
+      endif
+
+      DO J=JTS,JTE
+         DO I=ITS,ITE
+            CU_ACT_FLAG(I,J)=.TRUE.
+         ENDDO
+      ENDDO
+ 
+      IM=ITE-ITS+1
+      KX=KTE-KTS+1
+      JCAP=126
+      DPSHC=30_kind_phys
+      DELT=DT*STEPCU
+      RDELT=1./DELT
+      NCLOUD=1
+
+
+   DO J=jms,jme
+     DO I=ims,ime
+       PSFC(i,j)=P8w(i,kms,j)
+     ENDDO
+   ENDDO
+
+   if(igpvs.eq.0) CALL GFUNCPHYS
+   igpvs=1
+
+!-------------  J LOOP (OUTER) --------------------------------------------------
+
+   big_outer_j_loop: DO J=jts,jte
+
+! --------------- compute zi and zl -----------------------------------------
+      DO i=its,ite
+        ZI(I,KTS)=0.0
+      ENDDO
+
+      DO k=kts+1,kte
+        KM=K-1
+        DO i=its,ite
+          ZI(I,K)=ZI(I,KM)+dz8w(i,km,j)
+        ENDDO
+      ENDDO
+
+      DO k=kts+1,kte
+        KM=K-1
+        DO i=its,ite
+          ZL(I,KM)=(ZI(I,K)+ZI(I,KM))*0.5
+        ENDDO
+      ENDDO
+
+      DO i=its,ite
+        ZL(I,KTE)=2.*ZI(I,KTE)-ZL(I,KTE-1)
+      ENDDO
+
+! --------------- end compute zi and zl -------------------------------------
+
+      DO i=its,ite
+        !!PS(i)=PSFC(i,j)*.001
+        PS(i)=PSFC(i,j)      ! wang, in Pa
+        RCS(i)=1.
+        SLIMSK(i)=ABS(XLAND(i,j)-2.)
+
+        garea(I)=DX2D(i,j)*DY*2.0         !wang,  grid box area in m^2
+        KCNV(I)=0                         !wang, initialize KCNV
+      ENDDO
+
+#if (NMM_CORE == 1)
+      if(shalconv_use==1) then
+      DO i=its,ite
+         HPBL(I) = HPBL2D(I,J)          !kwon for shallow convection
+         EVAP(I) = EVAP2D(I,J)          !kwon for shallow convection
+         HEAT(I) = HEAT2D(I,J)          !kwon for shallow convection
+      ENDDO
+      endif
+#endif
+
+      DO i=its,ite
+        PRSI(i,kts)=PS(i)
+      ENDDO
+
+      DO k=kts,kte
+        kp=k+1
+        DO i=its,ite
+          !PRSL(I,K)=Pcps(i,k,j)*.001
+          PRSL(I,K)=Pcps(i,k,j)          !wang in Pa
+          PHIL(I,K)=ZL(I,K)*GRAV
+          !DOT(i,k)=-5.0E-4*GRAV*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j))
+          DOT(i,k)=-0.5*GRAV*rho3d(i,k,j)*(w(i,k,j)+w(i,kp,j)) !wang in Pa
+        ENDDO
+      ENDDO
+
+      DO k=kts,kte
+        DO i=its,ite
+          DEL(i,k)=PRSL(i,k)*GRAV/RD*dz8w(i,k,j)/T3D(i,k,j)
+          U1(i,k)=U3D(i,k,j)
+          V1(i,k)=V3D(i,k,j)
+          Q1(i,k)=QV3D(i,k,j)/(1.+QV3D(i,k,j))
+          T1(i,k)=T3D(i,k,j)
+          QL(i,k,1)=QI3D(i,k,j)/(1.+QI3D(i,k,j))
+          QL(i,k,2)=QC3D(i,k,j)/(1.+QC3D(i,k,j))
+          !PRSLK(I,K)=(PRSL(i,k)*.01)**ROVCP
+          PRSLK(I,K)=(PRSL(i,k)*1.0e-5)**ROVCP   ! prsl in Pa
+        ENDDO
+      ENDDO
+
+      DO k=kts+1,kte+1
+        km=k-1
+        DO i=its,ite
+          PRSI(i,k)=PRSI(i,km)-del(i,km) 
+        ENDDO
+      ENDDO
+
+       !    write(0,*)'dx2d=',dx2d(its,jts:jts+5)
+       !    write(0,*)'dy=',dy
+       !    write(0,*)'ps=',ps(its)
+       !    write(0,*)'del=',del(its,kts:kts+5)
+       !    write(0,*)'prsl=',prsl(its,kts:kts+5)
+       !    write(0,*)'dot=',dot(its,kts:kts+5)
+
+!      CALL SASCNVN(IM,IM,KX,JCAP,DELT,DEL,PRSL,PS,PHIL,                  &
+!                  QL,Q1,T1,U1,V1,RCS,CLDWRK,RN,KBOT,                    &
+!                  KTOP,KCNV,SLIMSK,DOT,NCLOUD,PGCON_USE,massf)
+       !! call scale-aware deep cnv,  
+       !! added 2015-12-10 W Wang
+       !! Note: ps, prsl,del are in Pa. dot in pa/s
+          
+        CALL scale_sascnvn(IM,IM,KX,JCAP,DELT,DEL,PRSL,PS,PHIL,QL,     &   
+            q1,t1,u1,v1,cldwrk,rn,kbot,ktop,kcnv,nint(slimsk),garea,       &
+            dot,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc,SIGMU_out,SCALEFUN_out)
+!
+
+      do i=its,ite
+        RAINCV1(I,J)=RN(I)*1000./STEPCU
+        PRATEC1(I,J)=RN(I)*1000./(STEPCU * DT)
+      enddo
+!
+      do i=its,ite
+        RAINCV2(I,J)=0.
+        PRATEC2(I,J)=0.
+      enddo
+!
+!
+      if_shallow_conv: if(shalconv_use==1) then
+#if (NMM_CORE == 1)
+         ! NMM calls the new shallow convection developed by J Han
+         ! (Added to WRF by Y.Kwon)
+!        call shalcnv(im,im,kx,jcap,delt,del,prsl,ps,phil,ql,        &
+!     &               q1,t1,u1,v1,rcs,rn,kbot,ktop,kcnv,slimsk,      &
+!     &               dot,ncloud,hpbl,heat,evap,shal_pgcon_use)
+
+       !! call scale-aware shallow cnv,  
+       !! added 2015-12-10 W Wang
+        call scale_shalcnv(im,im,kx,delt,del,prsl,ps,phil,ql,       &
+     &     q1,t1,u1,v1,rn,kbot,ktop,kcnv,nint(slimsk),garea,             &
+     &     dot,ncloud,hpbl,heat,evap,ud_mf,dt_mf,cnvw,cnvc,SIGMU1_out,SCALEFUN1_out)
+!
+      DO I=ITS,ITE
+        RAINCV2(I,J)=RN(I)*1000./STEPCU
+        PRATEC2(I,J)=RN(I)*1000./(STEPCU * DT)
+      ENDDO
+!
+#else
+#if (EM_CORE == 1)
+        ! NOTE: ARW should be able to call the new shalcnv here, but
+        ! they need to add the three new variables, so I'm leaving the
+        ! old shallow convection call here - Sam Trahan
+       
+      !!wang removed  CALL OLD_ARW_SHALCV(IM,IM,KX,DELT,DEL,PRSI,PRSL,PRSLK,KCNV,Q1,T1,DPSHC)
+#else
+        ! Shallow convection is untested for other cores.
+#endif
+#endif
+     endif if_shallow_conv
+
+!! output updraft area fractions for deep and shallow cnv
+      do i=its,ite
+        SCALEFUN(I,J)=SCALEFUN_OUT(i)
+        SCALEFUN1(I,J)=SCALEFUN1_OUT(i)
+        SIGMU(I,J)=SIGMU_OUT(i)
+        SIGMU1(I,J)=SIGMU1_OUT(i)
+      enddo
+
+
+        DO I=ITS,ITE
+        RAINCV(I,J)= RAINCV1(I,J) + RAINCV2(I,J)
+        PRATEC(I,J)= PRATEC1(I,J) + PRATEC2(I,J)
+        HBOT(I,J)=KBOT(I)
+        HTOP(I,J)=KTOP(I)
+      ENDDO
+
+      DO K=KTS,KTE
+        DO I=ITS,ITE
+          RTHCUTEN(I,K,J)=(T1(I,K)-T3D(I,K,J))/PI3D(I,K,J)*RDELT
+          RQVCUTEN(I,K,J)=(Q1(I,K)/(1.-q1(i,k))-QV3D(I,K,J))*RDELT
+        ENDDO
+      ENDDO
+
+!===============================================================================
+!     ADD MOMENTUM MIXING TERM AS TENDENCIES. This is gopal's doing for SAS
+!     MOMMIX is the reduction factor set to 0.7 by default. Because NMM has 
+!     divergence damping term, a reducion factor for cumulum mixing may be
+!     required otherwise storms were too weak.
+!===============================================================================
+!
+#if (NMM_CORE == 1)
+      DO K=KTS,KTE
+        DO I=ITS,ITE
+!         RUCUTEN(I,J,K)=MOMMIX*(U1(I,K)-U3D(I,K,J))*RDELT
+!         RVCUTEN(I,J,K)=MOMMIX*(V1(I,K)-V3D(I,K,J))*RDELT
+         RUCUTEN(I,J,K)=(U1(I,K)-U3D(I,K,J))*RDELT
+         RVCUTEN(I,J,K)=(V1(I,K)-V3D(I,K,J))*RDELT
+        ENDDO
+      ENDDO
+#endif
+
+
+      IF(P_QC .ge. P_FIRST_SCALAR)THEN
+        DO K=KTS,KTE
+          DO I=ITS,ITE
+            RQCCUTEN(I,K,J)=(QL(I,K,2)/(1.-ql(i,k,2))-QC3D(I,K,J))*RDELT
+          ENDDO
+        ENDDO
+      ENDIF
+
+      IF(P_QI .ge. P_FIRST_SCALAR)THEN
+        DO K=KTS,KTE
+          DO I=ITS,ITE
+            RQICUTEN(I,K,J)=(QL(I,K,1)/(1.-ql(i,k,1))-QI3D(I,K,J))*RDELT
+          ENDDO
+        ENDDO
+      ENDIF
+
+   ENDDO big_outer_j_loop    ! Outer most J loop
+
+   END SUBROUTINE CU_SCALESAS
+
+!====================================================================
+   SUBROUTINE scalesasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,          &
+                      RUCUTEN,RVCUTEN,                              &   
+                      RESTART,P_QC,P_QI,P_FIRST_SCALAR,             &
+                      allowed_to_read,                              &
+                      ids, ide, jds, jde, kds, kde,                 &
+                      ims, ime, jms, jme, kms, kme,                 &
+                      its, ite, jts, jte, kts, kte                  )
+!--------------------------------------------------------------------
+   IMPLICIT NONE
+!--------------------------------------------------------------------
+   LOGICAL , INTENT(IN)           ::  allowed_to_read,restart
+   INTEGER , INTENT(IN)           ::  ids, ide, jds, jde, kds, kde, &
+                                      ims, ime, jms, jme, kms, kme, &
+                                      its, ite, jts, jte, kts, kte
+   INTEGER , INTENT(IN)           ::  P_FIRST_SCALAR, P_QI, P_QC
+
+   REAL,     DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) ::  &
+                                                              RTHCUTEN, &
+                                                              RQVCUTEN, &
+                                                              RQCCUTEN, &
+                                                              RQICUTEN
+   REAL,     DIMENSION( ims:ime , jms:jme , kms:kme ) , INTENT(OUT) ::  &
+                                                              RUCUTEN,  & ! gopal's doing for SAS
+                                                              RVCUTEN   
+
+   INTEGER :: i, j, k, itf, jtf, ktf
+
+   jtf=min0(jte,jde-1)
+   ktf=min0(kte,kde-1)
+   itf=min0(ite,ide-1)
+
+#ifdef HWRF
+!zhang's doing
+   IF(.not.restart .or. .not.allowed_to_read)THEN
+!end of zhang's doing
+#else
+   IF(.not.restart)THEN
+#endif
+     DO j=jts,jtf
+     DO k=kts,ktf
+     DO i=its,itf
+       RTHCUTEN(i,k,j)=0.
+       RQVCUTEN(i,k,j)=0.
+       RUCUTEN(i,j,k)=0.   
+       RVCUTEN(i,j,k)=0.    
+     ENDDO
+     ENDDO
+     ENDDO
+
+     IF (P_QC .ge. P_FIRST_SCALAR) THEN
+        DO j=jts,jtf
+        DO k=kts,ktf
+        DO i=its,itf
+           RQCCUTEN(i,k,j)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+     ENDIF
+
+     IF (P_QI .ge. P_FIRST_SCALAR) THEN
+        DO j=jts,jtf
+        DO k=kts,ktf
+        DO i=its,itf
+           RQICUTEN(i,k,j)=0.
+        ENDDO
+        ENDDO
+        ENDDO
+     ENDIF
+   ENDIF
+
+      END SUBROUTINE scalesasinit
+
+!-----------------------------------------------------------------------
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!!! scale aware SAS 
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      subroutine scale_sascnvn(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql,  &
+     &     q1,t1,u1,v1,cldwrk,rn,kbot,ktop,kcnv,islimsk,garea,             &
+!     &     dot,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc, tmpout9)
+     &     dot,ncloud,ud_mf,dd_mf,dt_mf,cnvw,cnvc, sigmuout,scaldfunc)
+!    &     q1,t1,u1,v1,rcs,cldwrk,rn,kbot,ktop,kcnv,islimsk,
+!    &     dot,ncloud,ud_mf,dd_mf,dt_mf,me)
+!
+!      use machine , only : kind_phys
+!      use funcphys , only : fpvs
+!      use physcons, grav => con_g, cp => con_cp, hvap => con_hvap
+       USE MODULE_GFS_MACHINE, ONLY : kind_phys
+       USE MODULE_GFS_FUNCPHYS, ONLY : fpvs
+       USE MODULE_GFS_PHYSCONS, grav => con_g, cp => con_cp         &
+     &  ,            hvap => con_hvap                               &
+     &,             rv => con_rv, fv => con_fvirt, t0c => con_t0c    &
+     &,             rd => con_rd, cvap => con_cvap, cliq => con_cliq &
+     &,             eps => con_eps, epsm1 => con_epsm1 
+      implicit none
+!
+      integer            im, ix,  km, jcap, ncloud,                 &
+     &                   kbot(im), ktop(im), kcnv(im) 
+!    &,                  me
+      real(kind=kind_phys) delt
+      real(kind=kind_phys) psp(im),    delp(ix,km), prslp(ix,km)
+      real(kind=kind_phys) ps(im),     del(ix,km),  prsl(ix,km),       &
+     &                     ql(ix,km,2),q1(ix,km),   t1(ix,km),         & 
+     &                     u1(ix,km),  v1(ix,km),                      &
+!    &                     u1(ix,km),  v1(ix,km),   rcs(im),
+     &                     cldwrk(im), rn(im),      garea(im),         &   
+     &                     dot(ix,km), phil(ix,km),                    &
+     &                     cnvw(ix,km),cnvc(ix,km),                    &
+! hchuang code change mass flux output
+     &                     ud_mf(im,km),dd_mf(im,km),dt_mf(im,km)
+!
+      integer              i, indx, jmn, k, kk, km1, n
+      integer, dimension(im), intent(in) :: islimsk
+!     integer              latd,lond
+!
+      real(kind=kind_phys) clam,    cxlamu,  cxlamd,                   &
+     &                     xlamde,  xlamdd,                            &
+     &                     crtlamu, crtlamd
+! 
+!     real(kind=kind_phys) detad
+      real(kind=kind_phys) adw,     aup,     aafac,                    &
+     &                     beta,    betal,   betas,                    &
+     &                     c0l,     c0s,     d0,                       &
+     &                     c1l,     c1s,     asolfac,                  &
+     &                     dellat,  delta,   desdt,   dg,              &
+     &                     dh,      dhh,     dp,                       &
+     &                     dq,      dqsdp,   dqsdt,   dt,              &
+     &                     dt2,     dtmax,   dtmin,                    &
+     &                     dv1h,    dv2h,    dv3h,                     &
+     &                     dv1q,    dv2q,    dv3q,                     &
+     &                     dz,      dz1,     e1,      edtmax,          &
+     &                     edtmaxl, edtmaxs, el2orc,  elocp,           &
+     &                     es,      etah,    cthk,    dthk,            &
+     &                     evef,    evfact,  evfactl, fact1,           &
+     &                     fact2,   factor,  fjcap,   fkm,             &
+     &                     g,       gamma,   pprime,  cm,              &
+     &                     qlk,     qrch,    qs,                       &
+     &                     rain,    rfact,   shear,                    &
+     &                     val,     val1,    val2,                     &
+     &                     w1,      w1l,     w1s,     w2,              &
+     &                     w2l,     w2s,     w3,      w3l,             &
+     &                     w3s,     w4,      w4l,     w4s,             & 
+     &                     xdby,    xpw,     xpwd,                     &
+!    &                     xqrch,   mbdt,    tem,
+     &                     xqrch,   tem,     tem1,    tem2,            &
+     &                     ptem,    ptem1,   ptem2,                    &
+     &                     pgcon
+!
+      integer              kb(im), kbcon(im), kbcon1(im),              &
+     &                     ktcon(im), ktcon1(im), ktconn(im),          &
+     &                     jmin(im), lmin(im), kbmax(im),              &
+     &                     kbm(im), kmax(im)
+!
+      real(kind=kind_phys) aa1(im),     acrt(im),   acrtfct(im),       &
+     &                     delhbar(im), delq(im),   delq2(im),         &
+     &                     delqbar(im), delqev(im), deltbar(im),       &
+     &                     deltv(im),   dtconv(im), edt(im),           &
+     &                     edto(im),    edtx(im),   fld(im),           &
+     &                     hcdo(im,km), hmax(im),   hmin(im),          &
+     &                     ucdo(im,km), vcdo(im,km),aa2(im),           &
+     &                     pdot(im),    po(im,km),                     &
+     &                     pwavo(im),   pwevo(im),  mbdt(im),          &
+     &                     qcdo(im,km), qcond(im),  qevap(im),         &
+     &                     rntot(im),   vshear(im), xaa0(im),          &
+     &                     xk(im),      xlamd(im),  cina(im),          &
+     &                     xmb(im),     xmbmax(im), xpwav(im),         &
+     &                     xpwev(im),   delubar(im),delvbar(im)
+!
+      real(kind=kind_phys) c0(im),      c1(im)
+!cj
+      real(kind=kind_phys) cinpcr,  cinpcrmx,  cinpcrmn,              &
+     &                     cinacr,  cinacrmx,  cinacrmn
+!cj
+!  parameters for updraft core fraction calculation
+      real(kind=kind_phys) fs0,  fp1
+      real(kind=kind_phys) gfudarea
+      integer itsig
+!
+!  parameters for updraft velocity calculation
+      real(kind=kind_phys) bet1,    cd1,     f1,      gam1,           &
+     &                     bb1,     bb2,     wucb,                    &    
+     &                     tfac
+!
+!c  physical parameters
+      parameter(g=grav,asolfac=0.89)
+      parameter(elocp=hvap/cp,el2orc=hvap*hvap/(rv*cp))
+!     parameter(c0l=.0015,c0s=.002,c1l=.0015,c1s=.002,d0=.07)
+      !parameter(c0s=.002,c1s=.002,d0=.07)
+      parameter(c0s=.002,c1s=.002,d0=.01)
+      parameter(c0l=c0s*asolfac,c1l=c1s*asolfac)
+      parameter(cm=1.0,delta=fv)
+      parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c)
+      parameter(cthk=150.,dthk=25.)
+      parameter(cinpcrmx=180.,cinpcrmn=120.)
+      parameter(cinacrmx=-120.,cinacrmn=-120.)
+      parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5)
+      parameter(tfac=1.0)
+      parameter(itsig=7,gfudarea=25632653.0)
+!c  local variables and arrays
+      real(kind=kind_phys) pfld(im,km),    to(im,km),     qo(im,km),   &
+     &                     uo(im,km),      vo(im,km),     qeso(im,km)
+!  for updraft velocity calculation
+      real(kind=kind_phys) wu2(im,km),     buo(im,km),    drag(im,km)
+      real(kind=kind_phys) wc(im),         wcxmb(im)
+      real(kind=kind_phys) wbar(im),       xmbeta(im)
+      real(kind=kind_phys) scaldfunc(im),  awlam(im),  xlamx(im),       &
+     &                     sigmaw(im),     sigmagf(im) ,   sigmagfm(im) 
+
+!! tmpout
+      real(kind=kind_phys) tmpout9(im), sigmuout(im)
+
+!
+!c  cloud water
+!     real(kind=kind_phys) tvo(im,km)
+      real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km),    &
+     &                     dbyo(im,km),    zo(im,km),                    &
+     &                     xlamue(im,km),  xlamud(im,km),                &
+     &                     fent1(im,km),   fent2(im,km),  frh(im,km),    &
+     &                     heo(im,km),     heso(im,km),                  &
+     &                     qrcd(im,km),    dellah(im,km), dellaq(im,km), &
+     &                     dellau(im,km),  dellav(im,km), hcko(im,km),   &
+     &                     ucko(im,km),    vcko(im,km),   qcko(im,km),   & 
+     &                     eta(im,km),     etad(im,km),   zi(im,km),     &
+     &                     qrcko(im,km),   qrcdo(im,km),                  &
+     &                     pwo(im,km),     pwdo(im,km),   c0t(im,km),    &
+     &                     tx1(im),        sumx(im),      cnvwt(im,km)
+!    &,                    rhbar(im)
+!
+      logical totflg, cnvflg(im), flg(im)
+!
+      real(kind=kind_phys) pcrit(15), acritt(15), acrit(15)
+!     save pcrit, acritt
+      data pcrit/850.,800.,750.,700.,650.,600.,550.,500.,450.,400.,      &
+     &           350.,300.,250.,200.,150./
+      data acritt/.0633,.0445,.0553,.0664,.075,.1082,.1521,.2216,        &
+     &           .3151,.3677,.41,.5255,.7663,1.1686,1.6851/
+!c  gdas derived acrit
+!c     data acritt/.203,.515,.521,.566,.625,.665,.659,.688,
+!c    &            .743,.813,.886,.947,1.138,1.377,1.896/
+      real(kind=kind_phys) tf, tcr, tcrf
+      parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf))
+!
+!c-----------------------------------------------------------------------
+!
+!************************************************************************
+!     convert input Pa terms to Cb terms  -- Moorthi
+      ps   = psp   * 0.001
+      prsl = prslp * 0.001
+      del  = delp  * 0.001
+!************************************************************************
+!
+!
+      km1 = km - 1
+!c
+!c  initialize arrays
+!c
+      do i=1,im
+        cnvflg(i) = .true.
+        rn(i)=0.
+        mbdt(i)=10.
+        kbot(i)=km+1
+        ktop(i)=0
+        kbcon(i)=km
+        ktcon(i)=1
+        ktconn(i)=1
+        dtconv(i) = 3600.
+        cldwrk(i) = 0.
+        pdot(i) = 0.
+        lmin(i) = 1
+        jmin(i) = 1
+        qlko_ktcon(i) = 0.
+        edt(i)  = 0.
+        edto(i) = 0.
+        edtx(i) = 0.
+        acrt(i) = 0.
+        acrtfct(i) = 1.
+        aa1(i)  = 0.
+        aa2(i)  = 0.
+        xaa0(i) = 0.
+        cina(i) = 0.
+        pwavo(i)= 0.
+        pwevo(i)= 0.
+        xpwav(i)= 0.
+        xpwev(i)= 0.
+        vshear(i) = 0.
+
+         scaldfunc(i)=-1.0   ! initialized wang
+          sigmaw(i)=-1.0
+          sigmagf(i)=-1.0
+          sigmagfm(i)=-1.0
+          tmpout9(i)=-1.0
+          sigmuout(i)=-1.0
+      enddo
+!
+      do i=1,im
+        if(islimsk(i) == 1) then
+           c0(i) = c0l
+           c1(i) = c1l
+        else
+           c0(i) = c0s
+           c1(i) = c1s
+        endif
+      enddo
+      do k = 1, km
+        do i = 1, im
+          if(t1(i,k).gt.273.16) then
+            c0t(i,k) = c0(i)
+          else
+            tem = d0 * (t1(i,k) - 273.16)
+            tem1 = exp(tem)
+            c0t(i,k) = c0(i) * tem1
+          endif
+        enddo
+      enddo
+!
+      do k = 1, km
+        do i = 1, im
+          cnvw(i,k) = 0.
+          cnvc(i,k) = 0.
+        enddo
+      enddo
+! hchuang code change
+      do k = 1, km
+        do i = 1, im
+          ud_mf(i,k) = 0.
+          dd_mf(i,k) = 0.
+          dt_mf(i,k) = 0.
+        enddo
+      enddo
+!c
+      do k = 1, 15
+        acrit(k) = acritt(k) * (975. - pcrit(k))
+      enddo
+      dt2 = delt
+      val   =         1200.
+      dtmin = max(dt2, val )
+      val   =         5400.
+      dtmax = max(dt2, val )
+!c  model tunable parameters are all here
+      edtmaxl = .3
+      edtmaxs = .3
+      clam    = .1
+      aafac   = .1
+!     betal   = .15
+!     betas   = .15
+      betal   = .05
+      betas   = .05
+!c     evef    = 0.07
+      evfact  = 0.3
+      evfactl = 0.3
+!
+      crtlamu = 1.0e-4
+      crtlamd = 1.0e-4
+!
+      !cxlamu  = 1.0e-4
+      cxlamu  = 1.0e-3   ! 2015-12-15
+      cxlamd  = 1.0e-4
+      xlamde  = 1.0e-4
+      xlamdd  = 1.0e-4
+!
+!     pgcon   = 0.7     ! Gregory et al. (1997, QJRMS)
+      pgcon   = 0.55    ! Zhang & Wu (2003,JAS)
+      fjcap   = (float(jcap) / 126.) ** 2
+      val     =           1.
+      fjcap   = max(fjcap,val)
+      fkm     = (float(km) / 28.) ** 2
+      fkm     = max(fkm,val)
+      w1l     = -8.e-3 
+      w2l     = -4.e-2
+      w3l     = -5.e-3 
+      w4l     = -5.e-4
+      w1s     = -2.e-4
+      w2s     = -2.e-3
+      w3s     = -1.e-3
+      w4s     = -2.e-5
+!c
+!c  define top layer for search of the downdraft originating layer
+!c  and the maximum thetae for updraft
+!c
+      do i=1,im
+        kbmax(i) = km
+        kbm(i)   = km
+        kmax(i)  = km
+        tx1(i)   = 1.0 / ps(i)
+      enddo
+!     
+      do k = 1, km
+        do i=1,im
+          if (prsl(i,k)*tx1(i) .gt. 0.04) kmax(i)  = k + 1
+          if (prsl(i,k)*tx1(i) .gt. 0.45) kbmax(i) = k + 1
+          if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i)   = k + 1
+        enddo
+      enddo
+      do i=1,im
+        kmax(i)  = min(km,kmax(i))
+        kbmax(i) = min(kbmax(i),kmax(i))
+        kbm(i)   = min(kbm(i),kmax(i))
+      enddo
+!c
+!c  hydrostatic height assume zero terr and initially assume
+!c    updraft entrainment rate as an inverse function of height 
+!c
+      do k = 1, km
+        do i=1,im
+          zo(i,k) = phil(i,k) / g
+        enddo
+      enddo
+      do k = 1, km1
+        do i=1,im
+          zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1))
+          xlamue(i,k) = clam / zi(i,k)
+!          xlamue(i,k) = max(xlamue(i,k), crtlamu)
+        enddo
+      enddo
+!c
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c   convert surface pressure to mb from cb
+!c
+      do k = 1, km
+        do i = 1, im
+          if (k .le. kmax(i)) then
+            pfld(i,k) = prsl(i,k) * 10.0
+            eta(i,k)  = 1.
+            fent1(i,k)= 1.
+            fent2(i,k)= 1.
+            frh(i,k)  = 0.
+            hcko(i,k) = 0.
+            qcko(i,k) = 0.
+            qrcko(i,k)= 0.
+            ucko(i,k) = 0.
+            vcko(i,k) = 0.
+            etad(i,k) = 1.
+            hcdo(i,k) = 0.
+            qcdo(i,k) = 0.
+            ucdo(i,k) = 0.
+            vcdo(i,k) = 0.
+            qrcd(i,k) = 0.
+            qrcdo(i,k)= 0.
+            dbyo(i,k) = 0.
+            pwo(i,k)  = 0.
+            pwdo(i,k) = 0.
+            dellal(i,k) = 0.
+            to(i,k)   = t1(i,k)
+            qo(i,k)   = q1(i,k)
+            uo(i,k)   = u1(i,k)
+            vo(i,k)   = v1(i,k)
+!           uo(i,k)   = u1(i,k) * rcs(i)
+!           vo(i,k)   = v1(i,k) * rcs(i)
+            wu2(i,k)  = 0.
+            buo(i,k)  = 0.
+            drag(i,k) = 0.
+            cnvwt(i,k)= 0.
+          endif
+        enddo
+      enddo
+!c
+!c  column variables
+!c  p is pressure of the layer (mb)
+!c  t is temperature at t-dt (k)..tn
+!c  q is mixing ratio at t-dt (kg/kg)..qn
+!c  to is temperature at t+dt (k)... this is after advection and turbulan
+!c  qo is mixing ratio at t+dt (kg/kg)..q1
+!c
+      do k = 1, km
+        do i=1,im
+          if (k .le. kmax(i)) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c  compute moist static energy
+!c
+      do k = 1, km
+        do i=1,im
+          if (k .le. kmax(i)) then
+!           tem       = g * zo(i,k) + cp * to(i,k)
+            tem       = phil(i,k) + cp * to(i,k)
+            heo(i,k)  = tem  + hvap * qo(i,k)
+            heso(i,k) = tem  + hvap * qeso(i,k)
+!c           heo(i,k)  = min(heo(i,k),heso(i,k))
+          endif
+        enddo
+      enddo
+!c
+!c  determine level with largest moist static energy
+!c  this is the level where updraft starts
+!c
+      do i=1,im
+        hmax(i) = heo(i,1)
+        kb(i)   = 1
+      enddo
+      do k = 2, km
+        do i=1,im
+          if (k .le. kbm(i)) then
+            if(heo(i,k).gt.hmax(i)) then
+              kb(i)   = k
+              hmax(i) = heo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do k = 1, km1
+        do i=1,im
+          if (k .le. kmax(i)-1) then
+            dz      = .5 * (zo(i,k+1) - zo(i,k))
+            dp      = .5 * (pfld(i,k+1) - pfld(i,k))
+            es      = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
+            pprime  = pfld(i,k+1) + epsm1 * es
+            qs      = eps * es / pprime
+            dqsdp   = - qs / pprime
+            desdt   = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+            dqsdt   = qs * pfld(i,k+1) * desdt / (es * pprime)
+            gamma   = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
+            dt      = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
+            dq      = dqsdt * dt + dqsdp * dp
+            to(i,k) = to(i,k+1) + dt
+            qo(i,k) = qo(i,k+1) + dq
+            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
+          endif
+        enddo
+      enddo
+!
+      do k = 1, km1
+        do i=1,im
+          if (k .le. kmax(i)-1) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+            frh(i,k)  = 1. - min(qo(i,k)/qeso(i,k), 1._kind_phys)        
+            heo(i,k)  = .5 * g * (zo(i,k) + zo(i,k+1)) +    &
+     &                  cp * to(i,k) + hvap * qo(i,k)
+            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +    &
+     &                  cp * to(i,k) + hvap * qeso(i,k)
+            uo(i,k)   = .5 * (uo(i,k) + uo(i,k+1))
+            vo(i,k)   = .5 * (vo(i,k) + vo(i,k+1))
+          endif
+        enddo
+      enddo
+!c
+!c  look for the level of free convection as cloud base
+!c
+      do i=1,im
+        flg(i)   = .true.
+        kbcon(i) = kmax(i)
+      enddo
+      do k = 1, km1
+        do i=1,im
+          if (flg(i).and.k.le.kbmax(i)) then
+            if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then
+              kbcon(i) = k
+              flg(i)   = .false.
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do i=1,im
+        if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false.
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+      do i=1,im
+        if(cnvflg(i)) then
+!         pdot(i)  = 10.* dot(i,kbcon(i))
+          pdot(i)  = 0.01 * dot(i,kbcon(i)) ! Now dot is in Pa/s
+        endif
+      enddo
+!c
+!c   turn off convection if pressure depth between parcel source level
+!c      and cloud base is larger than a critical value, cinpcr
+!c
+      do i=1,im
+        if(cnvflg(i)) then
+          if(islimsk(i) == 1) then
+            w1 = w1l
+            w2 = w2l
+            w3 = w3l
+            w4 = w4l
+          else
+            w1 = w1s
+            w2 = w2s
+            w3 = w3s
+            w4 = w4s
+          endif
+          if(pdot(i).le.w4) then
+            tem = (pdot(i) - w4) / (w3 - w4)
+          elseif(pdot(i).ge.-w4) then
+            tem = - (pdot(i) + w4) / (w4 - w3)
+          else
+            tem = 0.
+          endif
+          val1    =            -1.
+          tem = max(tem,val1)
+          val2    =             1.
+          tem = min(tem,val2)
+          ptem = 1. - tem
+          ptem1= .5*(cinpcrmx-cinpcrmn)
+          cinpcr = cinpcrmx - ptem * ptem1
+          tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i))
+          if(tem1.gt.cinpcr) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  assume that updraft entrainment rate above cloud base is
+!c    same as that at cloud base
+!c
+!     do k = 2, km1
+!       do i=1,im
+!         if(cnvflg(i).and.
+!    &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
+!             xlamue(i,k) = xlamue(i,kbcon(i))
+!         endif
+!       enddo
+!     enddo
+
+       do i=1,im
+         if(cnvflg(i)) then
+           xlamx(i) = xlamue(i,kbcon(i))
+         endif
+       enddo
+       do k = 2, km1
+         do i=1,im
+           if(cnvflg(i).and.    &
+     &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
+               xlamue(i,k) = xlamx(i)
+           endif
+         enddo
+       enddo
+
+
+!c
+!c  specify a background (turbulent) detrainment rate for the updrafts
+!c
+      do k = 1, km1
+        do i=1,im
+          if(cnvflg(i).and.k.lt.kmax(i)) then
+!           xlamud(i,k) = xlamue(i,kbcon(i))
+!            xlamud(i,k) = crtlamd
+            xlamud(i,k) = xlamx(i)
+          endif
+        enddo
+      enddo
+!c
+!c  functions rapidly decreasing with height, mimicking a cloud ensemble
+!c    (Bechtold et al., 2008)
+!c
+      do k = 2, km1
+        do i=1,im
+          if(cnvflg(i).and.                                              &
+     &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
+              tem = qeso(i,k)/qeso(i,kbcon(i))
+              fent1(i,k) = tem**2
+              fent2(i,k) = tem**3
+          endif
+        enddo
+      enddo
+!c
+!c  final entrainment and detrainment rates as the sum of turbulent part and
+!c    organized entrainment depending on the environmental relative humidity
+!c    (Bechtold et al., 2008)
+!c
+      do k = 2, km1
+        do i=1,im
+          if(cnvflg(i).and.                                             &
+     &      (k.gt.kbcon(i).and.k.lt.kmax(i))) then
+              tem = cxlamu * frh(i,k) * fent2(i,k)
+              xlamue(i,k) = xlamue(i,k)*fent1(i,k) + tem
+!             tem1 = cxlamd * frh(i,k)
+!             xlamud(i,k) = xlamud(i,k) + tem1
+          endif
+        enddo
+      enddo
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+!c  determine updraft mass flux for the subcloud layers
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.lt.kbcon(i).and.k.ge.kb(i)) then
+              dz       = zi(i,k+1) - zi(i,k)
+              tem      = 0.5*(xlamud(i,k)+xlamud(i,k+1))
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-tem
+              eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  compute mass flux above cloud base
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+      enddo
+      do k = 2, km1
+        do i = 1, im
+         if(flg(i))then
+           if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
+              dz       = zi(i,k) - zi(i,k-1)
+              tem      = 0.5*(xlamud(i,k)+xlamud(i,k-1))
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-tem
+              eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
+              if(eta(i,k).le.0.) then
+                kmax(i) = k
+                ktconn(i) = k
+                flg(i)   = .false.
+              endif
+           endif
+         endif
+        enddo
+      enddo
+!c
+!c  compute updraft cloud properties
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx         = kb(i)
+          hcko(i,indx) = heo(i,indx)
+          ucko(i,indx) = uo(i,indx)
+          vcko(i,indx) = vo(i,indx)
+          pwavo(i)     = 0.
+        endif
+      enddo
+!c
+!c  cloud property is modified by the entrainment process
+!c
+!  cm is an enhancement factor in entrainment rates for momentum
+!
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.kmax(i)) then
+              dz   = zi(i,k) - zi(i,k-1)
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz
+              factor = 1. + tem - tem1
+              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*             &
+     &                     (heo(i,k)+heo(i,k-1)))/factor
+              dbyo(i,k) = hcko(i,k) - heso(i,k)
+!
+              tem  = 0.5 * cm * tem
+              factor = 1. + tem
+              ptem = tem + pgcon
+              ptem1= tem - pgcon
+              ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*uo(i,k)           &
+     &                     +ptem1*uo(i,k-1))/factor
+              vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*vo(i,k)           &
+     &                     +ptem1*vo(i,k-1))/factor
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c   taking account into convection inhibition due to existence of
+!c    dry layers below cloud base
+!c
+      do i=1,im
+        flg(i) = cnvflg(i)
+        kbcon1(i) = kmax(i)
+      enddo
+      do k = 2, km1
+      do i=1,im
+        if (flg(i).and.k.lt.kmax(i)) then
+          if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
+            kbcon1(i) = k
+            flg(i)    = .false.
+          endif
+        endif
+      enddo
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false.
+        endif
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i))
+          if(tem.gt.dthk) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i = 1, im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  calculate convective inhibition
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.kbcon1(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma                         &
+     &                 * to(i,k) / hvap
+              cina(i) = cina(i) +                                      &
+!    &                 dz1 * eta(i,k) * (g / (cp * to(i,k)))
+     &                 dz1 * (g / (cp * to(i,k)))                      &
+     &                 * dbyo(i,k) / (1. + gamma)                      &
+     &                 * rfact
+              val = 0.
+              cina(i) = cina(i) +                                      &
+!    &                 dz1 * eta(i,k) * g * delta *
+     &                 dz1 * g * delta *                               &
+     &                 max(val,(qeso(i,k) - qo(i,k)))
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+!
+!         if(islimsk(i) == 1) then
+!           w1 = w1l
+!           w2 = w2l
+!           w3 = w3l
+!           w4 = w4l
+!         else
+!           w1 = w1s
+!           w2 = w2s
+!           w3 = w3s
+!           w4 = w4s
+!         endif
+!         if(pdot(i).le.w4) then
+!           tem = (pdot(i) - w4) / (w3 - w4)
+!         elseif(pdot(i).ge.-w4) then
+!           tem = - (pdot(i) + w4) / (w4 - w3)
+!         else
+!           tem = 0.
+!         endif
+!
+!         val1    =            -1.
+!         tem = max(tem,val1)
+!         val2    =             1.
+!         tem = min(tem,val2)
+!         tem = 1. - tem
+!         tem1= .5*(cinacrmx-cinacrmn)
+!         cinacr = cinacrmx - tem * tem1
+!
+          cinacr = cinacrmx
+          if(cina(i).lt.cinacr) cnvflg(i) = .false.
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  determine first guess cloud top as the level of zero buoyancy
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+        ktcon(i) = 1
+      enddo
+      do k = 2, km1
+      do i = 1, im
+        if (flg(i).and.k .lt. kmax(i)) then
+          if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then
+             ktcon(i) = k
+             flg(i)   = .false.
+          endif
+        endif
+      enddo
+      enddo
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          if(ktcon(i).eq.1 .and. ktconn(i).gt.1) then
+             ktcon(i) = ktconn(i)
+          endif
+          tem = pfld(i,kbcon(i))-pfld(i,ktcon(i))
+          if(tem.lt.cthk) cnvflg(i) = .false.
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i = 1, im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  search for downdraft originating level above theta-e minimum
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+           hmin(i) = heo(i,kbcon1(i))
+           lmin(i) = kbmax(i)
+           jmin(i) = kbmax(i)
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kbmax(i)) then
+            if(k.gt.kbcon1(i).and.heo(i,k).lt.hmin(i)) then
+               lmin(i) = k + 1
+               hmin(i) = heo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  make sure that jmin(i) is within the cloud
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          jmin(i) = min(lmin(i),ktcon(i)-1)
+          jmin(i) = max(jmin(i),kbcon1(i)+1)
+          if(jmin(i).ge.ktcon(i)) cnvflg(i) = .false.
+        endif
+      enddo
+!c
+!c  specify upper limit of mass flux at cloud base
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+!         xmbmax(i) = .1
+!
+          k = kbcon(i)
+          dp = 1000. * del(i,k)
+          xmbmax(i) = dp / (g * dt2)
+          mbdt(i) = 0.1 * dp / g
+!
+!         tem = dp / (g * dt2)
+!         xmbmax(i) = min(tem, xmbmax(i))
+        endif
+      enddo
+!c
+!c  compute cloud moisture property and precipitation
+!c
+      do i = 1, im
+        if (cnvflg(i)) then
+!         aa1(i) = 0.
+          qcko(i,kb(i)) = qo(i,kb(i))
+          qrcko(i,kb(i)) = qo(i,kb(i))
+!         rhbar(i) = 0.
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                                              &
+     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                   &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+              qrcko(i,k) = qcko(i,k)
+!cj
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!c
+!             rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k)
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+              if(k.ge.kbcon(i).and.dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0.and.k.gt.jmin(i)) then
+                  dp = 1000. * del(i,k)
+                  ptem = c0t(i,k) + c1(i)
+                  qlk = dq / (eta(i,k) + etah * ptem * dz)
+                  dellal(i,k) = etah * c1(i) * dz * qlk * g / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz)
+                endif
+!               aa1(i) = aa1(i) - dz * g * qlk * etah
+!               aa1(i) = aa1(i) - dz * g * qlk
+                buo(i,k) = buo(i,k) - g * qlk
+                qcko(i,k) = qlk + qrch
+                pwo(i,k) = etah * c0t(i,k) * dz * qlk
+                pwavo(i) = pwavo(i) + pwo(i,k)
+!               cnvwt(i,k) = (etah*qlk + pwo(i,k)) * g / dp
+                cnvwt(i,k) = etah * qlk * g / dp
+              endif
+!
+!  compute buoyancy and drag for updraft velocity
+!
+              if(k.ge.kbcon(i)) then
+                rfact =  1. + delta * cp * gamma                       &
+     &                   * to(i,k) / hvap
+                buo(i,k) = buo(i,k) + (g / (cp * to(i,k)))             &
+     &                   * dbyo(i,k) / (1. + gamma)                    &
+     &                   * rfact
+                val = 0.
+                buo(i,k) = buo(i,k) + g * delta *                      &
+     &                     max(val,(qeso(i,k) - qo(i,k)))
+                drag(i,k) = max(xlamue(i,k),xlamud(i,k))
+              endif
+!
+            endif
+          endif
+        enddo
+      enddo
+!c
+!     do i = 1, im
+!       if(cnvflg(i)) then
+!         indx = ktcon(i) - kb(i) - 1
+!         rhbar(i) = rhbar(i) / float(indx)
+!       endif
+!     enddo
+!c
+!c  calculate cloud work function
+!c
+!     do k = 2, km1
+!       do i = 1, im
+!         if (cnvflg(i)) then
+!           if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+!             dz1 = zo(i,k+1) - zo(i,k)
+!             gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+!             rfact =  1. + delta * cp * gamma
+!    &                 * to(i,k) / hvap
+!             aa1(i) = aa1(i) +
+!!   &                 dz1 * eta(i,k) * (g / (cp * to(i,k)))
+!    &                 dz1 * (g / (cp * to(i,k)))
+!    &                 * dbyo(i,k) / (1. + gamma)
+!    &                 * rfact
+!             val = 0.
+!             aa1(i) = aa1(i) +
+!!   &                 dz1 * eta(i,k) * g * delta *
+!    &                 dz1 * g * delta *
+!    &                 max(val,(qeso(i,k) - qo(i,k)))
+!           endif
+!         endif
+!       enddo
+!     enddo
+!
+!  calculate cloud work function
+!
+      do i = 1, im
+        if (cnvflg(i)) then
+          aa1(i) = 0.
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.ge.kbcon(i) .and. k.lt.ktcon(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+!             aa1(i) = aa1(i) + buo(i,k) * dz1 * eta(i,k)
+              aa1(i) = aa1(i) + buo(i,k) * dz1
+            endif
+          endif
+        enddo
+      enddo
+!
+      do i = 1, im
+        if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  estimate the onvective overshooting as the level 
+!c    where the [aafac * cloud work function] becomes zero,
+!c    which is the final cloud top
+!c
+      do i = 1, im
+        if (cnvflg(i)) then
+          aa2(i) = aafac * aa1(i)
+        endif
+      enddo
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+        ktcon1(i) = kmax(i)
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (flg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.kmax(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma                          &
+     &                 * to(i,k) / hvap
+              aa2(i) = aa2(i) +                                         &
+!    &                 dz1 * eta(i,k) * (g / (cp * to(i,k)))
+     &                 dz1 * (g / (cp * to(i,k)))                       &
+     &                 * dbyo(i,k) / (1. + gamma)                       &
+     &                 * rfact
+!             val = 0.
+!             aa2(i) = aa2(i) +
+!!   &                 dz1 * eta(i,k) * g * delta *
+!    &                 dz1 * g * delta *
+!    &                 max(val,(qeso(i,k) - qo(i,k)))
+              if(aa2(i).lt.0.) then
+                ktcon1(i) = k
+                flg(i) = .false.
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  compute cloud moisture property, detraining cloud water 
+!c    and precipitation in overshooting layers 
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                                      &
+     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*            &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+              qrcko(i,k) = qcko(i,k)
+!cj
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+              if(dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0) then
+                  dp = 1000. * del(i,k)
+                  ptem = c0t(i,k) + c1(i)
+                  qlk = dq / (eta(i,k) + etah * ptem * dz)
+                  dellal(i,k) = etah * c1(i) * dz * qlk * g / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz)
+                endif
+                qcko(i,k) = qlk + qrch
+                pwo(i,k) = etah * c0t(i,k) * dz * qlk
+                pwavo(i) = pwavo(i) + pwo(i,k)
+!               cnvwt(i,k) = (etah*qlk + pwo(i,k)) * g / dp
+                cnvwt(i,k) = etah * qlk * g / dp
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+!  compute updraft velocity square(wu2)
+!
+      bb1 = 2. * (1.+bet1*cd1)
+      bb2 = 2. / (f1*(1.+gam1))
+!
+!     bb1 = 12.0
+!     bb2 = 0.67
+!
+      do i = 1, im
+        if (cnvflg(i)) then
+          k = kbcon1(i)
+          tem = po(i,k) / (rd * to(i,k))
+          wucb = -0.01 * dot(i,k) / (tem * g)
+          if(wucb.gt.0.) then
+            wu2(i,k) = wucb * wucb
+          else
+            wu2(i,k) = 0.
+          endif
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kbcon1(i) .and. k.lt.ktcon(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              tem  = 0.25 * bb1 * (drag(i,k)+drag(i,k-1)) * dz
+              tem1 = 0.5 * bb2 * (buo(i,k)+buo(i,k-1)) * dz
+              ptem = (1. - tem) * wu2(i,k-1)
+              ptem1 = 1. + tem
+              wu2(i,k) = (ptem + tem1) / ptem1
+              wu2(i,k) = max(wu2(i,k), 0._kind_phys)
+            endif
+          endif
+        enddo
+      enddo
+!
+!  compute updraft velocity averaged over the whole cumulus
+!
+      do i = 1, im
+        wc(i) = 0.
+        sumx(i) = 0.
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k > kbcon1(i) .and. k < ktcon(i)) then
+              dz = zi(i,k) - zi(i,k-1)
+              tem = 0.5 * (sqrt(wu2(i,k)) + sqrt(wu2(i,k-1)))
+              wc(i) = wc(i) + tem * dz
+              sumx(i) = sumx(i) + dz
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          if(sumx(i) == 0.) then
+             cnvflg(i)=.false.
+          else
+             wc(i) = wc(i) / sumx(i)
+          endif
+          val = 1.e-4
+          if (wc(i) < val) cnvflg(i)=.false.
+        endif
+      enddo
+!c
+!c exchange ktcon with ktcon1
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          kk = ktcon(i)
+          ktcon(i) = ktcon1(i)
+          ktcon1(i) = kk
+        endif
+      enddo
+!c
+!c  this section is ready for cloud water
+!c
+      if(ncloud.gt.0) then
+!c
+!c  compute liquid and vapor separation at cloud top
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          k = ktcon(i) - 1
+          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+          qrch = qeso(i,k)                                           &
+     &         + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+          dq = qcko(i,k) - qrch
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+          if(dq.gt.0.) then
+            qlko_ktcon(i) = dq
+            qcko(i,k) = qrch
+          endif
+        endif
+      enddo
+      endif
+!c
+!ccccc if(lat.eq.latd.and.lon.eq.lond.and.cnvflg(i)) then
+!ccccc   print *, ' aa1(i) before dwndrft =', aa1(i)
+!ccccc endif
+!c
+!c------- downdraft calculations
+!c
+!c--- compute precipitation efficiency in terms of windshear
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          vshear(i) = 0.
+        endif
+      enddo
+      do k = 2, km
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2                    &
+     &                  + (vo(i,k)-vo(i,k-1)) ** 2)
+              vshear(i) = vshear(i) + shear
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
+          e1=1.591-.639*vshear(i)                                     &
+     &       +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
+          edt(i)=1.-e1
+          val =         .9
+          edt(i) = min(edt(i),val)
+          val =         .0
+          edt(i) = max(edt(i),val)
+          edto(i)=edt(i)
+          edtx(i)=edt(i)
+        endif
+      enddo
+!c
+!c  determine detrainment rate between 1 and kbcon
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          sumx(i) = 0.
+        endif
+      enddo
+      do k = 1, km1
+      do i = 1, im
+        if(cnvflg(i).and.k.ge.1.and.k.lt.kbcon(i)) then
+          dz = zi(i,k+1) - zi(i,k)
+          sumx(i) = sumx(i) + dz
+        endif
+      enddo
+      enddo
+      do i = 1, im
+        beta = betas
+        if(islimsk(i) == 1) beta = betal
+        if(cnvflg(i)) then
+          dz  = (sumx(i)+zi(i,1))/float(kbcon(i))
+          tem = 1./float(kbcon(i))
+          xlamd(i) = (1.-beta**tem)/dz
+        endif
+      enddo
+!c
+!c  determine downdraft mass flux
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)-1) then
+           if(k.lt.jmin(i).and.k.ge.kbcon(i)) then
+              dz        = zi(i,k+1) - zi(i,k)
+              ptem      = xlamdd - xlamde
+              etad(i,k) = etad(i,k+1) * (1. - ptem * dz)
+           else if(k.lt.kbcon(i)) then
+              dz        = zi(i,k+1) - zi(i,k)
+              ptem      = xlamd(i) + xlamdd - xlamde
+              etad(i,k) = etad(i,k+1) * (1. - ptem * dz)
+           endif
+          endif
+        enddo
+      enddo
+!c
+!c--- downdraft moisture properties
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          jmn = jmin(i)
+          hcdo(i,jmn) = heo(i,jmn)
+          qcdo(i,jmn) = qo(i,jmn)
+          qrcdo(i,jmn)= qo(i,jmn)
+          ucdo(i,jmn) = uo(i,jmn)
+          vcdo(i,jmn) = vo(i,jmn)
+          pwevo(i) = 0.
+        endif
+      enddo
+!cj
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k.lt.jmin(i)) then
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*            &
+     &                     (heo(i,k)+heo(i,k+1)))/factor
+              dbyo(i,k) = hcdo(i,k) - heso(i,k)
+!
+              tem  = 0.5 * cm * tem
+              factor = 1. + tem
+              ptem = tem - pgcon
+              ptem1= tem + pgcon
+              ucdo(i,k) = ((1.-tem)*ucdo(i,k+1)+ptem*uo(i,k+1)        &
+     &                     +ptem1*uo(i,k))/factor
+              vcdo(i,k) = ((1.-tem)*vcdo(i,k+1)+ptem*vo(i,k+1)        &
+     &                     +ptem1*vo(i,k))/factor
+          endif
+        enddo
+      enddo
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i).and.k.lt.jmin(i)) then
+              gamma      = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrcdo(i,k) = qeso(i,k)+                                 &
+     &                (1./hvap)*(gamma/(1.+gamma))*dbyo(i,k)
+!             detad      = etad(i,k+1) - etad(i,k)
+!cj
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              qcdo(i,k) = ((1.-tem1)*qrcdo(i,k+1)+tem*0.5*           &
+     &                     (qo(i,k)+qo(i,k+1)))/factor
+!cj
+!             pwdo(i,k)  = etad(i,k+1) * qcdo(i,k+1) -
+!    &                     etad(i,k) * qrcdo(i,k)
+!             pwdo(i,k)  = pwdo(i,k) - detad *
+!    &                    .5 * (qrcdo(i,k) + qrcdo(i,k+1))
+!cj
+              pwdo(i,k)  = etad(i,k) * (qcdo(i,k) - qrcdo(i,k))
+              pwevo(i)   = pwevo(i) + pwdo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c--- final downdraft strength dependent on precip
+!c--- efficiency (edt), normalized condensate (pwav), and
+!c--- evaporate (pwev)
+!c
+      do i = 1, im
+        edtmax = edtmaxl
+        if(islimsk(i) == 0) edtmax = edtmaxs
+        if(cnvflg(i)) then
+          if(pwevo(i).lt.0.) then
+            edto(i) = -edto(i) * pwavo(i) / pwevo(i)
+            edto(i) = min(edto(i),edtmax)
+          else
+            edto(i) = 0.
+          endif
+        endif
+      enddo
+!c
+!c--- downdraft cloudwork functions
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k .lt. jmin(i)) then
+              gamma = el2orc * qeso(i,k) / to(i,k)**2
+              dhh=hcdo(i,k)
+              dt=to(i,k)
+              dg=gamma
+              dh=heso(i,k)
+              dz=-1.*(zo(i,k+1)-zo(i,k))
+!             aa1(i)=aa1(i)+edto(i)*dz*etad(i,k)
+              aa1(i)=aa1(i)+edto(i)*dz                                 &
+     &               *(g/(cp*dt))*((dhh-dh)/(1.+dg))                   &
+     &               *(1.+delta*cp*dg*dt/hvap)
+              val=0.
+!             aa1(i)=aa1(i)+edto(i)*dz*etad(i,k)
+              aa1(i)=aa1(i)+edto(i)*dz                                 &
+     &               *g*delta*max(val,(qeso(i,k)-qo(i,k)))
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i).and.aa1(i).le.0.) then
+           cnvflg(i) = .false.
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c--- what would the change be, that a cloud with unit mass
+!c--- will do to the environment?
+!c
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)) then
+            dellah(i,k) = 0.
+            dellaq(i,k) = 0.
+            dellau(i,k) = 0.
+            dellav(i,k) = 0.
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          dp = 1000. * del(i,1)
+          dellah(i,1) = edto(i) * etad(i,1) * (hcdo(i,1)               &
+     &                   - heo(i,1)) * g / dp
+          dellaq(i,1) = edto(i) * etad(i,1) * (qrcdo(i,1)              &
+     &                   - qo(i,1)) * g / dp
+          dellau(i,1) = edto(i) * etad(i,1) * (ucdo(i,1)               &
+     &                   - uo(i,1)) * g / dp
+          dellav(i,1) = edto(i) * etad(i,1) * (vcdo(i,1)               &
+     &                   - vo(i,1)) * g / dp
+        endif
+      enddo
+!c
+!c--- changed due to subsidence and entrainment
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i).and.k.lt.ktcon(i)) then
+              aup = 1.
+              if(k.le.kb(i)) aup = 0.
+              adw = 1.
+              if(k.gt.jmin(i)) adw = 0.
+              dp = 1000. * del(i,k)
+              dz = zi(i,k) - zi(i,k-1)
+!c
+              dv1h = heo(i,k)
+              dv2h = .5 * (heo(i,k) + heo(i,k-1))
+              dv3h = heo(i,k-1)
+              dv1q = qo(i,k)
+              dv2q = .5 * (qo(i,k) + qo(i,k-1))
+              dv3q = qo(i,k-1)
+!c
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1))
+              tem1 = 0.5 * (xlamud(i,k)+xlamud(i,k-1))
+!c
+              if(k.le.kbcon(i)) then
+                ptem  = xlamde
+                ptem1 = xlamd(i)+xlamdd
+              else
+                ptem  = xlamde
+                ptem1 = xlamdd
+              endif
+!cj
+              dellah(i,k) = dellah(i,k) +                                &
+     &     ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1h                    &
+     &    - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3h                 &
+     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2h*dz       &
+     &    +  aup*tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz            &
+     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(hcdo(i,k)+hcdo(i,k-1))*dz    &
+     &         ) *g/dp
+!cj
+              dellaq(i,k) = dellaq(i,k) +                                 &
+     &     ((aup*eta(i,k)-adw*edto(i)*etad(i,k))*dv1q                     &
+     &    - (aup*eta(i,k-1)-adw*edto(i)*etad(i,k-1))*dv3q                 &
+     &    - (aup*tem*eta(i,k-1)+adw*edto(i)*ptem*etad(i,k))*dv2q*dz       &
+     &    +  aup*tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz           &
+     &    +  adw*edto(i)*ptem1*etad(i,k)*.5*(qrcdo(i,k)+qcdo(i,k-1))*dz   &
+     &         ) *g/dp
+!cj
+              tem1=eta(i,k)*(uo(i,k)-ucko(i,k))
+              tem2=eta(i,k-1)*(uo(i,k-1)-ucko(i,k-1))
+              ptem1=etad(i,k)*(uo(i,k)-ucdo(i,k))
+              ptem2=etad(i,k-1)*(uo(i,k-1)-ucdo(i,k-1))
+              dellau(i,k) = dellau(i,k) +                                &
+     &           (aup*(tem1-tem2)-adw*edto(i)*(ptem1-ptem2))*g/dp
+!cj
+              tem1=eta(i,k)*(vo(i,k)-vcko(i,k))
+              tem2=eta(i,k-1)*(vo(i,k-1)-vcko(i,k-1))
+              ptem1=etad(i,k)*(vo(i,k)-vcdo(i,k))
+              ptem2=etad(i,k-1)*(vo(i,k-1)-vcdo(i,k-1))
+              dellav(i,k) = dellav(i,k) +                                &
+     &           (aup*(tem1-tem2)-adw*edto(i)*(ptem1-ptem2))*g/dp
+!cj
+          endif
+        enddo
+      enddo
+!c
+!c------- cloud top
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx = ktcon(i)
+          dp = 1000. * del(i,indx)
+          dv1h = heo(i,indx-1)
+          dellah(i,indx) = eta(i,indx-1) *                               &
+     &                     (hcko(i,indx-1) - dv1h) * g / dp
+          dv1q = qo(i,indx-1)
+          dellaq(i,indx) = eta(i,indx-1) *                                &
+     &                     (qcko(i,indx-1) - dv1q) * g / dp
+          dellau(i,indx) = eta(i,indx-1) *                                &
+     &             (ucko(i,indx-1) - uo(i,indx-1)) * g / dp
+          dellav(i,indx) = eta(i,indx-1) *                                &
+     &             (vcko(i,indx-1) - vo(i,indx-1)) * g / dp
+!c
+!c  cloud water
+!c
+          dellal(i,indx) = eta(i,indx-1) *                                &
+     &                     qlko_ktcon(i) * g / dp
+        endif
+      enddo
+!c
+!c------- final changed variable per unit mass flux
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i).and.k .le. kmax(i)) then
+            if(k.gt.ktcon(i)) then
+              qo(i,k) = q1(i,k)
+              to(i,k) = t1(i,k)
+            endif
+            if(k.le.ktcon(i)) then
+              qo(i,k) = dellaq(i,k) * mbdt(i) + q1(i,k)
+              dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp
+              to(i,k) = dellat * mbdt(i) + t1(i,k)
+              val   =           1.e-10
+              qo(i,k) = max(qo(i,k), val  )
+            endif
+          endif
+        enddo
+      enddo
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+!c--- the above changed environment is now used to calulate the
+!c--- effect the arbitrary cloud (with unit mass flux)
+!c--- would have on the stability,
+!c--- which then is used to calculate the real mass flux,
+!c--- necessary to keep this change in balance with the large-scale
+!c--- destabilization.
+!c
+!c--- environmental conditions again, first heights
+!c
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k)+epsm1*qeso(i,k))
+            val       =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val )
+!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c--- moist static energy
+!c
+      do k = 1, km1
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)-1) then
+            dz = .5 * (zo(i,k+1) - zo(i,k))
+            dp = .5 * (pfld(i,k+1) - pfld(i,k))
+            es = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
+            pprime = pfld(i,k+1) + epsm1 * es
+            qs = eps * es / pprime
+            dqsdp = - qs / pprime
+            desdt = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+            dqsdt = qs * pfld(i,k+1) * desdt / (es * pprime)
+            gamma = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
+            dt = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
+            dq = dqsdt * dt + dqsdp * dp
+            to(i,k) = to(i,k+1) + dt
+            qo(i,k) = qo(i,k+1) + dq
+            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
+          endif
+        enddo
+      enddo
+      do k = 1, km1
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)-1) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1 * qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+            heo(i,k)   = .5 * g * (zo(i,k) + zo(i,k+1)) +               &
+     &                    cp * to(i,k) + hvap * qo(i,k)
+            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +                &
+     &                  cp * to(i,k) + hvap * qeso(i,k)
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          k = kmax(i)
+          heo(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qo(i,k)
+          heso(i,k) = g * zo(i,k) + cp * to(i,k) + hvap * qeso(i,k)
+!c         heo(i,k) = min(heo(i,k),heso(i,k))
+        endif
+      enddo
+!c
+!c**************************** static control
+!c
+!c------- moisture and cloud work functions
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          xaa0(i) = 0.
+          xpwav(i) = 0.
+        endif
+      enddo
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx = kb(i)
+          hcko(i,indx) = heo(i,indx)
+          qcko(i,indx) = qo(i,indx)
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              dz = zi(i,k) - zi(i,k-1)
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz
+              factor = 1. + tem - tem1
+              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*               &
+     &                     (heo(i,k)+heo(i,k-1)))/factor
+            endif
+          endif
+        enddo
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dz = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              xdby = hcko(i,k) - heso(i,k)
+              xqrch = qeso(i,k)                                        &
+     &              + gamma * xdby / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.25 * (xlamud(i,k)+xlamud(i,k-1)) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*               &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+!cj
+              dq = eta(i,k) * (qcko(i,k) - xqrch)
+!c
+              if(k.ge.kbcon(i).and.dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0.and.k.gt.jmin(i)) then
+                  ptem = c0t(i,k) + c1(i)
+                  qlk = dq / (eta(i,k) + etah * ptem * dz)
+                else
+                  qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz)
+                endif
+                if(k.lt.ktcon1(i)) then
+!                 xaa0(i) = xaa0(i) - dz * g * qlk * etah
+                  xaa0(i) = xaa0(i) - dz * g * qlk
+                endif
+                qcko(i,k) = qlk + xqrch
+                xpw = etah * c0t(i,k) * dz * qlk
+                xpwav(i) = xpwav(i) + xpw
+              endif
+            endif
+            if(k.ge.kbcon(i).and.k.lt.ktcon1(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma                         &
+     &                 * to(i,k) / hvap
+              xaa0(i) = xaa0(i)                                         &
+!    &                + dz1 * eta(i,k) * (g / (cp * to(i,k)))
+     &                + dz1 * (g / (cp * to(i,k)))                      &
+     &                * xdby / (1. + gamma)                             &
+     &                * rfact
+              val=0.
+              xaa0(i) = xaa0(i) +                                       &
+!    &                 dz1 * eta(i,k) * g * delta *
+     &                 dz1 * g * delta *                                &
+     &                 max(val,(qeso(i,k) - qo(i,k)))
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c------- downdraft calculations
+!c
+!c--- downdraft moisture properties
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          jmn = jmin(i)
+          hcdo(i,jmn) = heo(i,jmn)
+          qcdo(i,jmn) = qo(i,jmn)
+          qrcd(i,jmn) = qo(i,jmn)
+          xpwev(i) = 0.
+        endif
+      enddo
+!cj
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k.lt.jmin(i)) then
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              hcdo(i,k) = ((1.-tem1)*hcdo(i,k+1)+tem*0.5*                &
+     &                     (heo(i,k)+heo(i,k+1)))/factor
+          endif
+        enddo
+      enddo
+!cj
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k .lt. jmin(i)) then
+              dq = qeso(i,k)
+              dt = to(i,k)
+              gamma    = el2orc * dq / dt**2
+              dh       = hcdo(i,k) - heso(i,k)
+              qrcd(i,k)=dq+(1./hvap)*(gamma/(1.+gamma))*dh
+!             detad    = etad(i,k+1) - etad(i,k)
+!cj
+              dz = zi(i,k+1) - zi(i,k)
+              if(k.ge.kbcon(i)) then
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * xlamdd * dz
+              else
+                 tem  = xlamde * dz
+                 tem1 = 0.5 * (xlamd(i)+xlamdd) * dz
+              endif
+              factor = 1. + tem - tem1
+              qcdo(i,k) = ((1.-tem1)*qrcd(i,k+1)+tem*0.5*             &
+     &                     (qo(i,k)+qo(i,k+1)))/factor
+!cj
+!             xpwd     = etad(i,k+1) * qcdo(i,k+1) -
+!    &                   etad(i,k) * qrcd(i,k)
+!             xpwd     = xpwd - detad *
+!    &                 .5 * (qrcd(i,k) + qrcd(i,k+1))
+!cj
+              xpwd     = etad(i,k) * (qcdo(i,k) - qrcd(i,k))
+              xpwev(i) = xpwev(i) + xpwd
+          endif
+        enddo
+      enddo
+!c
+      do i = 1, im
+        edtmax = edtmaxl
+        if(islimsk(i) == 0) edtmax = edtmaxs
+        if(cnvflg(i)) then
+          if(xpwev(i).ge.0.) then
+            edtx(i) = 0.
+          else
+            edtx(i) = -edtx(i) * xpwav(i) / xpwev(i)
+            edtx(i) = min(edtx(i),edtmax)
+          endif
+        endif
+      enddo
+!c
+!c
+!c--- downdraft cloudwork functions
+!c
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k.lt.jmin(i)) then
+              gamma = el2orc * qeso(i,k) / to(i,k)**2
+              dhh=hcdo(i,k)
+              dt= to(i,k)
+              dg= gamma
+              dh= heso(i,k)
+              dz=-1.*(zo(i,k+1)-zo(i,k))
+!             xaa0(i)=xaa0(i)+edtx(i)*dz*etad(i,k)
+              xaa0(i)=xaa0(i)+edtx(i)*dz                                    &
+     &                *(g/(cp*dt))*((dhh-dh)/(1.+dg))                       &
+     &                *(1.+delta*cp*dg*dt/hvap)
+              val=0.
+!             xaa0(i)=xaa0(i)+edtx(i)*dz*etad(i,k)
+              xaa0(i)=xaa0(i)+edtx(i)*dz                                       &
+     &                *g*delta*max(val,(qeso(i,k)-qo(i,k)))
+          endif
+        enddo
+      enddo
+!c
+!c  calculate critical cloud work function
+!c
+!     do i = 1, im
+!       if(cnvflg(i)) then
+!         if(pfld(i,ktcon(i)).lt.pcrit(15))then
+!           acrt(i)=acrit(15)*(975.-pfld(i,ktcon(i)))
+!    &              /(975.-pcrit(15))
+!         else if(pfld(i,ktcon(i)).gt.pcrit(1))then
+!           acrt(i)=acrit(1)
+!         else
+!           k =  int((850. - pfld(i,ktcon(i)))/50.) + 2
+!           k = min(k,15)
+!           k = max(k,2)
+!           acrt(i)=acrit(k)+(acrit(k-1)-acrit(k))*
+!    &           (pfld(i,ktcon(i))-pcrit(k))/(pcrit(k-1)-pcrit(k))
+!         endif
+!       endif
+!     enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+!         if(islimsk(i) == 1) then
+!           w1 = w1l
+!           w2 = w2l
+!           w3 = w3l
+!           w4 = w4l
+!         else
+!           w1 = w1s
+!           w2 = w2s
+!           w3 = w3s
+!           w4 = w4s
+!         endif
+!c
+!c  modify critical cloud workfunction by cloud base vertical velocity
+!c
+!         if(pdot(i).le.w4) then
+!           acrtfct(i) = (pdot(i) - w4) / (w3 - w4)
+!         elseif(pdot(i).ge.-w4) then
+!           acrtfct(i) = - (pdot(i) + w4) / (w4 - w3)
+!         else
+!           acrtfct(i) = 0.
+!         endif
+!         val1    =            -1.
+!         acrtfct(i) = max(acrtfct(i),val1)
+!         val2    =             1.
+!         acrtfct(i) = min(acrtfct(i),val2)
+!         acrtfct(i) = 1. - acrtfct(i)
+!c
+!c  modify acrtfct(i) by colume mean rh if rhbar(i) is greater than 80 percent
+!c
+!c         if(rhbar(i).ge..8) then
+!c           acrtfct(i) = acrtfct(i) * (.9 - min(rhbar(i),.9)) * 10.
+!c         endif
+!c
+!c  modify adjustment time scale by cloud base vertical velocity
+!c
+!         dtconv(i) = dt2 + max((1800. - dt2),0.) *
+!    &                (pdot(i) - w2) / (w1 - w2)
+!c         dtconv(i) = max(dtconv(i), dt2)
+!c         dtconv(i) = 1800. * (pdot(i) - w2) / (w1 - w2)
+!
+          tem = zi(i,ktcon1(i)) - zi(i,kbcon1(i))
+!!        tem = zi(i,ktcon(i)) - zi(i,kb(i))
+          dtconv(i) = tfac * tem / wc(i)
+          dtconv(i) = max(dtconv(i),dtmin)
+          dtconv(i) = min(dtconv(i),dtmax)
+!         dtconv(i) = max(1800., dt2)
+!c
+        endif
+      enddo
+!c
+!c--- large scale forcing
+!c
+      do i= 1, im
+        if(cnvflg(i)) then
+!         fld(i)=(aa1(i)-acrt(i)* acrtfct(i))/dtconv(i)
+          fld(i)=aa1(i)/dtconv(i)
+          if(fld(i).le.0.) cnvflg(i) = .false.
+        endif
+        if(cnvflg(i)) then
+!c         xaa0(i) = max(xaa0(i),0.)
+          xk(i) = (xaa0(i) - aa1(i)) / mbdt(i)
+          if(xk(i).ge.0.) cnvflg(i) = .false.
+        endif
+!c
+!c--- kernel, cloud base mass flux
+!c
+        if(cnvflg(i)) then
+          xmb(i) = -fld(i) / xk(i)
+!         xmb(i) = min(xmb(i),xmbmax(i))
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!
+!--- compute updraft fraction based on Arakawa & Wu (2013)
+!    using values at cloud base
+!
+!  grid-scale vertical velocity at cloud base
+!
+      ptem = -0.01 * rd / g 
+      do i = 1, im
+        wbar(i) = 0.
+        if (cnvflg(i)) then
+          k = kbcon(i)
+          tem  = dot(i,k) * to(i,k) / po(i,k)
+          wbar(i) = ptem * tem 
+        endif
+      enddo
+!
+!  estimate updraft velocity at cloud base using cloud base mass flux
+!
+      ptem = 0.01 * rd  
+      do i = 1, im
+        wcxmb(i) = 0.
+        if (cnvflg(i)) then
+          k = kbcon(i)
+          tem  = xmb(i) * ptem * to(i,k)  /  po(i,k)
+          wcxmb(i) = tem / 0.1
+!         wcxmb(i) = tem / 0.03
+        endif
+      enddo
+!
+!  compute updraft fraction
+!
+      ptem = 0.01 * rd
+      do i = 1, im
+        xmbeta(i) = 0.
+        if (cnvflg(i)) then
+          k = kbcon(i)
+          tem  = to(i,k) / po(i,k)
+          xmbeta(i) = xmb(i) * ptem * tem
+        endif
+      enddo
+      do i = 1, im
+        if (cnvflg(i)) then
+          tem = wcxmb(i) - wbar(i)
+          val = 1.e-8
+          tem = max(tem, val)
+          awlam(i) = xmbeta(i) / tem
+!         awlam(i) = min(awlam(i), 100.)
+        endif
+      enddo
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+          sigmaw(i) = .001
+          flg(i) = .true.
+        endif
+      enddo
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+          do n = 1, itsig
+            if(flg(i)) then
+              ptem = sigmaw(i)
+              tem = 1. - ptem
+              fs0 = awlam(i) * (tem**3.) - ptem
+              fp1 = -3. * awlam(i) * (tem**2.) - 1.
+              fp1 = min(fp1, -1.e-3_kind_phys)
+              sigmaw(i) = ptem - fs0 / fp1
+              tem1 = abs(sigmaw(i) - ptem)
+              if(tem1 < .01) then
+                flg(i)   = .false.
+              endif
+            endif
+          enddo
+          sigmaw(i) = max(sigmaw(i), 0.001_kind_phys)
+          sigmaw(i) = min(sigmaw(i), 0.999_kind_phys)
+        endif
+      enddo
+!
+!--- compute updraft fraction based on Grell & Freitas (2014)
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+          sigmagf(i) = gfudarea / garea(i)
+          sigmagf(i) = max(sigmagf(i), 0.001_kind_phys)
+          sigmagf(i) = min(sigmagf(i), 0.7_kind_phys)
+        endif
+      enddo
+
+!--- modified Grell & Freitas' (2014) updraft fraction which uses
+!     actual entrainment rate at cloud base
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+!          k = kbcon(i)
+!          tem = 0.2 / max(xlamue(i,k), 3.e-5)
+          tem = min(max(xlamx(i), 7.e-5_kind_phys), 3.e-4_kind_phys)
+             tmpout9(i)=tem
+          tem = 0.2 / tem
+          tem1 = 3.14 * tem * tem
+          sigmagfm(i) = tem1 / garea(i)
+          sigmagfm(i) = max(sigmagfm(i), 0.001_kind_phys)
+          sigmagfm(i) = min(sigmagfm(i), 0.999_kind_phys)
+
+        endif
+      enddo
+!
+
+!
+!--- compute scale-aware function based on Arakawa & Wu (2013)
+!  using combination of updraft fractions from both 
+!   Arakawa & Wu (2013) and Grell & Freitas (2014)
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+          tem = 0.001 * sqrt(garea(i))
+          if (tem < 25.) then
+!           scaldfunc(i) = (1.-sigmaw(i)) * (1.-sigmaw(i))   ! Arakawa & Wu (2013)
+!           scaldfunc(i) = (1.-sigmagf(i)) * (1.-sigmagf(i)) ! Grell & Freitas (2014)
+            scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) ! modified Grell & Freitas(2014)
+       
+!            scaldfunc(i) = (1.-sigmaw(i)) * (1.-sigmagf(i))  ! AW & GF
+            scaldfunc(i) = max(min(scaldfunc(i), 1.0_kind_phys), 0._kind_phys)
+             sigmuout(i)=sigmagfm(i)
+          else
+            scaldfunc(i) = 1.0
+          endif
+          xmb(i) = xmb(i) * scaldfunc(i)
+          xmb(i) = min(xmb(i),xmbmax(i))
+        endif
+      enddo
+!c
+!c  restore to,qo,uo,vo to t1,q1,u1,v1 in case convection stops
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            to(i,k) = t1(i,k)
+            qo(i,k) = q1(i,k)
+            uo(i,k) = u1(i,k)
+            vo(i,k) = v1(i,k)
+            qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
+            val     =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val )
+          endif
+        enddo
+      enddo
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+!c--- feedback: simply the changes from the cloud with unit mass flux
+!c---           multiplied by  the mass flux necessary to keep the
+!c---           equilibrium with the larger-scale.
+!c
+      do i = 1, im
+        delhbar(i) = 0.
+        delqbar(i) = 0.
+        deltbar(i) = 0.
+        delubar(i) = 0.
+        delvbar(i) = 0.
+        qcond(i) = 0.
+      enddo
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            if(k.le.ktcon(i)) then
+              dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp
+              t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2
+              q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2
+!             tem = 1./rcs(i)
+!             u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem
+!             v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem
+              u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2
+              v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2
+              dp = 1000. * del(i,k)
+              delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g
+              delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g
+              deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g
+              delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g
+              delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g
+            endif
+          endif
+        enddo
+      enddo
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            if(k.le.ktcon(i)) then
+              qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
+              qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k))
+              val     =             1.e-8
+              qeso(i,k) = max(qeso(i,k), val )
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do i = 1, im
+        rntot(i) = 0.
+        delqev(i) = 0.
+        delq2(i) = 0.
+        flg(i) = cnvflg(i)
+      enddo
+      do k = km, 1, -1
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            if(k.lt.ktcon(i)) then
+              aup = 1.
+              if(k.le.kb(i)) aup = 0.
+              adw = 1.
+              if(k.ge.jmin(i)) adw = 0.
+              rain =  aup * pwo(i,k) + adw * edto(i) * pwdo(i,k)
+              rntot(i) = rntot(i) + rain * xmb(i) * .001 * dt2
+            endif
+          endif
+        enddo
+      enddo
+      do k = km, 1, -1
+        do i = 1, im
+          if (k .le. kmax(i)) then
+            deltv(i) = 0.
+            delq(i) = 0.
+            qevap(i) = 0.
+            if(cnvflg(i).and.k.lt.ktcon(i)) then
+              aup = 1.
+              if(k.le.kb(i)) aup = 0.
+              adw = 1.
+              if(k.ge.jmin(i)) adw = 0.
+              rain =  aup * pwo(i,k) + adw * edto(i) * pwdo(i,k)
+              rn(i) = rn(i) + rain * xmb(i) * .001 * dt2
+            endif
+            if(flg(i).and.k.lt.ktcon(i)) then
+              evef = edt(i) * evfact
+              if(islimsk(i) == 1) evef=edt(i) * evfactl
+!             if(islimsk(i) == 1) evef=.07
+!c             if(islimsk(i) == 1) evef = 0.
+              qcond(i) = evef * (q1(i,k) - qeso(i,k))                   &
+     &                 / (1. + el2orc * qeso(i,k) / t1(i,k)**2)
+              dp = 1000. * del(i,k)
+              if(rn(i).gt.0..and.qcond(i).lt.0.) then
+                qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i))))
+                qevap(i) = min(qevap(i), rn(i)*1000.*g/dp)
+                delq2(i) = delqev(i) + .001 * qevap(i) * dp / g
+              endif
+              if(rn(i).gt.0..and.qcond(i).lt.0..and.                      &
+     &           delq2(i).gt.rntot(i)) then
+                qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp
+                flg(i) = .false.
+              endif
+              if(rn(i).gt.0..and.qevap(i).gt.0.) then
+                q1(i,k) = q1(i,k) + qevap(i)
+                t1(i,k) = t1(i,k) - elocp * qevap(i)
+                rn(i) = rn(i) - .001 * qevap(i) * dp / g
+                deltv(i) = - elocp*qevap(i)/dt2
+                delq(i) =  + qevap(i)/dt2
+                delqev(i) = delqev(i) + .001*dp*qevap(i)/g
+              endif
+              delqbar(i) = delqbar(i) + delq(i)*dp/g
+              deltbar(i) = deltbar(i) + deltv(i)*dp/g
+            endif
+          endif
+        enddo
+      enddo
+!cj
+!     do i = 1, im
+!     if(me.eq.31.and.cnvflg(i)) then
+!     if(cnvflg(i)) then
+!       print *, ' deep delhbar, delqbar, deltbar = ',
+!    &             delhbar(i),hvap*delqbar(i),cp*deltbar(i)
+!       print *, ' deep delubar, delvbar = ',delubar(i),delvbar(i)
+!       print *, ' precip =', hvap*rn(i)*1000./dt2
+!       print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i))
+!     endif
+!     enddo
+!c
+!c  precipitation rate converted to actual precip
+!c  in unit of m instead of kg
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+!c
+!c  in the event of upper level rain evaporation and lower level downdraft
+!c    moistening, rn can become negative, in this case, we back out of the
+!c    heating and the moistening
+!c
+          if(rn(i).lt.0..and..not.flg(i)) rn(i) = 0.
+          if(rn(i).le.0.) then
+            rn(i) = 0.
+          else
+            ktop(i) = ktcon(i)
+            kbot(i) = kbcon(i)
+            kcnv(i) = 1
+            cldwrk(i) = aa1(i)
+          endif
+        endif
+      enddo
+!c
+!c  convective cloud water
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. rn(i).gt.0.) then
+            if (k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+              cnvw(i,k) = cnvwt(i,k) * xmb(i) * dt2
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  convective cloud cover
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. rn(i).gt.0.) then
+            if (k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+              cnvc(i,k) = 0.04 * log(1. + 675. * eta(i,k) * xmb(i)) 
+              cnvc(i,k) = min(cnvc(i,k), 0.6_kind_phys)
+              cnvc(i,k) = max(cnvc(i,k), 0.0_kind_phys)
+            endif
+          endif
+        enddo
+      enddo
+
+!c
+!c  cloud water
+!c
+      if (ncloud.gt.0) then
+!
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. rn(i).gt.0.) then
+!            if (k.gt.kb(i).and.k.le.ktcon(i)) then
+             if (k.ge.kbcon(i).and.k.le.ktcon(i)) then
+              tem  = dellal(i,k) * xmb(i) * dt2
+              tem1 = max(0.0_kind_phys, min(1.0_kind_phys, (tcr-t1(i,k))*tcrf))
+              if (ql(i,k,2) .gt. -999.0) then
+                ql(i,k,1) = ql(i,k,1) + tem * tem1            ! ice
+                ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1)       ! water
+              else
+                ql(i,k,1) = ql(i,k,1) + tem
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+      endif
+!c
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i).and.rn(i).le.0.) then
+            if (k .le. kmax(i)) then
+              t1(i,k) = to(i,k)
+              q1(i,k) = qo(i,k)
+              u1(i,k) = uo(i,k)
+              v1(i,k) = vo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!
+! hchuang code change
+!
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i).and.rn(i).gt.0.) then
+            if(k.ge.kb(i) .and. k.lt.ktop(i)) then
+              ud_mf(i,k) = eta(i,k) * xmb(i) * dt2
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i).and.rn(i).gt.0.) then
+           k = ktop(i)-1
+           dt_mf(i,k) = ud_mf(i,k)
+        endif
+      enddo
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i).and.rn(i).gt.0.) then
+            if(k.ge.1 .and. k.le.jmin(i)) then
+              dd_mf(i,k) = edto(i) * etad(i,k) * xmb(i) * dt2
+            endif
+          endif
+        enddo
+      enddo
+!!
+      return
+      end subroutine scale_sascnvn
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!! scale aware shallow sas
+
+!     subroutine shalcnv(im,ix,km,jcap,delt,delp,prslp,psp,phil,ql,
+      subroutine scale_shalcnv(im,ix,km,delt,delp,prslp,psp,phil,ql,      &
+     &     q1,t1,u1,v1,rn,kbot,ktop,kcnv,islimsk,garea,                   &
+     &     dot,ncloud,hpbl,heat,evap,ud_mf,dt_mf,cnvw,cnvc, sigmuout,scaldfunc)
+!     &     dot,ncloud,hpbl,heat,evap,ud_mf,dt_mf,cnvw,cnvc, sigmagfm)
+!    &     q1,t1,u1,v1,rcs,rn,kbot,ktop,kcnv,islimsk,
+!    &     dot,ncloud,hpbl,heat,evap,ud_mf,dt_mf,me)
+!
+
+      use MODULE_GFS_machine , only : kind_phys
+      use MODULE_GFS_funcphys , only : fpvs
+      use MODULE_GFS_physcons, grav => con_g, cp => con_cp, hvap => con_hvap   & 
+!      use machine , only : kind_phys
+!      use funcphys , only : fpvs
+!      use physcons, grav => con_g, cp => con_cp, hvap => con_hvap
+     &,             rv => con_rv, fv => con_fvirt, t0c => con_t0c              &
+     &,             rd => con_rd, cvap => con_cvap, cliq => con_cliq           &
+     &,             eps => con_eps, epsm1 => con_epsm1
+      implicit none
+!
+!     integer            im, ix,  km, jcap, ncloud,
+      integer            im, ix,  km, ncloud,                              &
+     &                   kbot(im), ktop(im), kcnv(im) 
+!    &,                  me
+      real(kind=kind_phys) delt
+      real(kind=kind_phys) psp(im),    delp(ix,km), prslp(ix,km)
+      real(kind=kind_phys) ps(im),     del(ix,km),  prsl(ix,km),              &
+     &                     ql(ix,km,2),q1(ix,km),   t1(ix,km),                &
+     &                     u1(ix,km),  v1(ix,km),                             &
+!    &                     u1(ix,km),  v1(ix,km),   rcs(im),
+     &                     rn(im),     garea(im),                             &
+     &                     dot(ix,km), phil(ix,km), hpbl(im),                 &
+     &                     heat(im),   evap(im),    cnvw(ix,km),              &
+     &                     cnvc(ix,km)                                        &
+! hchuang code change mass flux output
+     &,                    ud_mf(im,km),dt_mf(im,km)
+!
+      integer              i,j,indx, k, kk, km1, n
+      integer              kpbl(im)
+      integer, dimension(im), intent(in) :: islimsk
+!
+      real(kind=kind_phys) dellat,  delta,                            &
+     &                     c0l,     c0s,     d0,                      &
+     &                     c1l,     c1s,     asolfac,                 &
+     &                     desdt,   dp,                               &
+     &                     dq,      dqsdp,   dqsdt,   dt,             &
+     &                     dt2,     dv1h,    dv2h,    dv3h,           &
+     &                     dv1q,    dv2q,    dv3q,                    &
+     &                     dz,      dz1,     e1,      clam,           &
+     &                     el2orc,  elocp,   aafac,   cm,              &
+     &                     es,      etah,    h1,                      &
+     &                     evef,    evfact,  evfactl, fact1,          &
+!    &                     fact2,   factor,  fjcap,   dthk,
+     &                     fact2,   factor,  dthk,                     &
+     &                     g,       gamma,   pprime,  betaw,            &
+     &                     qlk,     qrch,    qs,                      &
+     &                     rfact,   shear,                            &
+     &                     val,     val1,    val2,    wfac,             &
+     &                     w1,      w1l,     w1s,     w2,               &
+     &                     w2l,     w2s,     w3,      w3l,                &
+     &                     w3s,     w4,      w4l,     w4s,             &
+     &                     tem,     tem1,    tem2,                     &
+     &                     ptem,    ptem1,                             &
+     &                     pgcon
+!
+      integer              kb(im), kbcon(im), kbcon1(im),             &
+     &                     ktcon(im), ktcon1(im), ktconn(im),         &
+     &                     kbm(im), kmax(im)
+!
+      real(kind=kind_phys) aa1(im),     cina(im),                     &
+     &                     delhbar(im), delq(im),   delq2(im),        &
+     &                     delqbar(im), delqev(im), deltbar(im),      &
+     &                     deltv(im),   edt(im),                      &
+     &                     wstar(im),   sflx(im),                     &
+     &                     pdot(im),    po(im,km),                         &
+     &                     qcond(im),   qevap(im),  hmax(im),         &
+     &                     rntot(im),   vshear(im),                   &
+     &                     xlamud(im),  xmb(im),    xmbmax(im),       &
+     &                     delubar(im), delvbar(im)
+!
+      real(kind=kind_phys) c0(im),      c1(im)
+!c
+      real(kind=kind_phys) crtlamd
+!
+      real(kind=kind_phys) cinpcr,  cinpcrmx,  cinpcrmn,              &
+     &                     cinacr,  cinacrmx,  cinacrmn
+!  parameters for updraft core fraction calculation
+      real(kind=kind_phys) fs0,  fp1
+      real(kind=kind_phys) gfudarea
+      integer itsig
+!
+!  parameters for updraft velocity calculation
+      real(kind=kind_phys) bet1,    cd1,     f1,      gam1,          &
+     &                     bb1,     bb2,     wucb
+!cc
+!c  physical parameters
+      parameter(g=grav,asolfac=0.89)
+      parameter(elocp=hvap/cp,                                       &
+     &          el2orc=hvap*hvap/(rv*cp))
+!     parameter(c0l=0.00178,c0s=0.002,c1l=3.5e-4,c1s=5.e-4,d0=.07)
+      !parameter(c0s=0.002,c1s=5.e-4,d0=.07)
+      parameter(c0s=0.002,c1s=5.e-4,d0=.01)
+      parameter(c0l=c0s*asolfac,c1l=c1s*asolfac)
+      parameter(cm=1.0,delta=fv)
+      parameter(fact1=(cvap-cliq)/rv,fact2=hvap/rv-fact1*t0c)
+      parameter(wfac=-150.,dthk=25.)
+      parameter(cinpcrmx=180.,cinpcrmn=120.)
+      parameter(cinacrmx=-120.,cinacrmn=-120.)
+      parameter(crtlamd=3.e-4)
+      parameter(bet1=1.875,cd1=.506,f1=2.0,gam1=.5)
+      parameter(betaw=.03)
+      parameter(itsig=7,gfudarea=25632653.0)
+      parameter(h1=0.33333333)
+!c  local variables and arrays
+      real(kind=kind_phys) pfld(im,km),    to(im,km),     qo(im,km),   &
+     &                     uo(im,km),      vo(im,km),     qeso(im,km)
+!  for updraft velocity calculation
+!     real(kind=kind_phys) wu2(im,km),     buo(im,km),    drag(im,km)
+      real(kind=kind_phys) buo(im,km)
+!     real(kind=kind_phys) wc(im),         wcxmb(im)
+      real(kind=kind_phys) wcxmb(im)
+      real(kind=kind_phys) wbar(im),       xmbeta(im)
+      real(kind=kind_phys) scaldfunc(im),  awlam(im),                  &
+     &                     sigmaw(im),     sigmagf(im), sigmagfm(im)
+      real(kind=kind_phys) sigmuout(im)   ! output sigm_u,
+!
+!c  cloud water
+!     real(kind=kind_phys) qlko_ktcon(im), dellal(im,km), tvo(im,km),
+      real(kind=kind_phys) qlko_ktcon(im), dellal(im,km),                &
+     &                     dbyo(im,km),    zo(im,km),     xlamue(im,km), &
+     &                     heo(im,km),     heso(im,km),                  &
+     &                     dellah(im,km),  dellaq(im,km),                &
+     &                     dellau(im,km),  dellav(im,km), hcko(im,km),   &
+     &                     ucko(im,km),    vcko(im,km),   qcko(im,km),   &
+     &                     qrcko(im,km),   eta(im,km),                   &
+     &                     zi(im,km),      pwo(im,km),    c0t(im,km),    &
+!    &                     sumx(im),       tx1(im),       cnvwt(im,km)
+     &                     tx1(im),        cnvwt(im,km)
+!
+      logical totflg, cnvflg(im), flg(im)
+!
+      real(kind=kind_phys) tf, tcr, tcrf
+      parameter (tf=233.16, tcr=263.16, tcrf=1.0/(tcr-tf))
+!
+!c-----------------------------------------------------------------------
+!
+!************************************************************************
+!     convert input Pa terms to Cb terms  -- Moorthi
+      ps   = psp   * 0.001
+      prsl = prslp * 0.001
+      del  = delp  * 0.001
+!************************************************************************
+!
+      km1 = km - 1
+!c
+!c  compute surface buoyancy flux
+!c
+      do i=1,im
+        sflx(i) = heat(i)+fv*t1(i,1)*evap(i)
+      enddo
+!c
+!c  initialize arrays
+!c
+      do i=1,im
+        cnvflg(i) = .true.
+        if(kcnv(i).eq.1) cnvflg(i) = .false.
+        if(sflx(i).le.0.) cnvflg(i) = .false.
+        if(cnvflg(i)) then
+          kbot(i)=km+1
+          ktop(i)=0
+        endif
+        rn(i)=0.
+        kbcon(i)=km
+        ktcon(i)=1
+        ktconn(i)=1
+        kb(i)=km
+        pdot(i) = 0.
+        qlko_ktcon(i) = 0.
+        edt(i)  = 0.
+        aa1(i)  = 0.
+        cina(i) = 0.
+        vshear(i) = 0.
+          scaldfunc(i)=-1.0  ! wang initialized
+          sigmaw(i)=-1.0
+          sigmagf(i)=-1.0
+          sigmagfm(i)=-1.0
+           sigmuout(i)=-1.0
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+      do i=1,im
+        if(islimsk(i) == 1) then
+           c0(i) = c0l
+           c1(i) = c1l
+        else
+           c0(i) = c0s
+           c1(i) = c1s
+        endif
+      enddo
+!
+      do k = 1, km
+        do i = 1, im
+          if(t1(i,k).gt.273.16) then
+            c0t(i,k) = c0(i)
+          else
+            tem = d0 * (t1(i,k) - 273.16)
+            tem1 = exp(tem)
+            c0t(i,k) = c0(i) * tem1
+          endif
+        enddo
+      enddo
+!
+      do k = 1, km
+        do i = 1, im
+          cnvw(i,k) = 0.
+          cnvc(i,k) = 0.
+        enddo
+      enddo
+! hchuang code change
+      do k = 1, km
+        do i = 1, im
+          ud_mf(i,k) = 0.
+          dt_mf(i,k) = 0.
+        enddo
+      enddo
+!c
+      dt2   = delt
+!
+!c  model tunable parameters are all here
+      clam    = .3
+      aafac   = .1
+!c     evef    = 0.07
+      evfact  = 0.3
+      evfactl = 0.3
+!
+!     pgcon   = 0.7     ! Gregory et al. (1997, QJRMS)
+      pgcon   = 0.55    ! Zhang & Wu (2003,JAS)
+!     fjcap   = (float(jcap) / 126.) ** 2
+!     val     =           1.
+!     fjcap   = max(fjcap,val)
+      w1l     = -8.e-3 
+      w2l     = -4.e-2
+      w3l     = -5.e-3 
+      w4l     = -5.e-4
+      w1s     = -2.e-4
+      w2s     = -2.e-3
+      w3s     = -1.e-3
+      w4s     = -2.e-5
+!c
+!c  define top layer for search of the downdraft originating layer
+!c  and the maximum thetae for updraft
+!c
+      do i=1,im
+        kbm(i)   = km
+        kmax(i)  = km
+        tx1(i)   = 1.0 / ps(i)
+      enddo
+!     
+      do k = 1, km
+        do i=1,im
+          if (prsl(i,k)*tx1(i) .gt. 0.70) kbm(i)   = k + 1
+          if (prsl(i,k)*tx1(i) .gt. 0.60) kmax(i)  = k + 1
+        enddo
+      enddo
+      do i=1,im
+        kbm(i)   = min(kbm(i),kmax(i))
+      enddo
+!c
+!c  hydrostatic height assume zero terr and compute
+!c  updraft entrainment rate as an inverse function of height
+!c
+      do k = 1, km
+        do i=1,im
+          zo(i,k) = phil(i,k) / g
+        enddo
+      enddo
+      do k = 1, km1
+        do i=1,im
+          zi(i,k) = 0.5*(zo(i,k)+zo(i,k+1))
+          xlamue(i,k) = clam / zi(i,k)
+        enddo
+      enddo
+      do i=1,im
+        xlamue(i,km) = xlamue(i,km1)
+      enddo
+!c
+!c  pbl height
+!c
+      do i=1,im
+        flg(i) = cnvflg(i)
+        kpbl(i)= 1
+      enddo
+      do k = 2, km1
+        do i=1,im
+          if (flg(i).and.zo(i,k).le.hpbl(i)) then
+            kpbl(i) = k
+          else
+            flg(i) = .false.
+          endif
+        enddo
+      enddo
+      do i=1,im
+        kpbl(i)= min(kpbl(i),kbm(i))
+      enddo
+!c
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c   convert surface pressure to mb from cb
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            pfld(i,k) = prsl(i,k) * 10.0
+            eta(i,k)  = 1.
+            hcko(i,k) = 0.
+            qcko(i,k) = 0.
+            qrcko(i,k)= 0.
+            ucko(i,k) = 0.
+            vcko(i,k) = 0.
+            dbyo(i,k) = 0.
+            pwo(i,k)  = 0.
+            dellal(i,k) = 0.
+            to(i,k)   = t1(i,k)
+            qo(i,k)   = q1(i,k)
+            uo(i,k)   = u1(i,k)
+            vo(i,k)   = v1(i,k)
+!           uo(i,k)   = u1(i,k) * rcs(i)
+!           vo(i,k)   = v1(i,k) * rcs(i)
+!           wu2(i,k)  = 0.
+            buo(i,k)  = 0.
+!           drag(i,k) = 0.
+            cnvwt(i,k) = 0.
+          endif
+        enddo
+      enddo
+!c
+!c  column variables
+!c  p is pressure of the layer (mb)
+!c  t is temperature at t-dt (k)..tn
+!c  q is mixing ratio at t-dt (kg/kg)..qn
+!c  to is temperature at t+dt (k)... this is after advection and turbulan
+!c  qo is mixing ratio at t+dt (kg/kg)..q1
+!c
+      do k = 1, km
+        do i=1,im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+!           tvo(i,k)  = to(i,k) + delta * to(i,k) * qo(i,k)
+          endif
+        enddo
+      enddo
+!c
+!c  compute moist static energy
+!c
+      do k = 1, km
+        do i=1,im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+!           tem       = g * zo(i,k) + cp * to(i,k)
+            tem       = phil(i,k) + cp * to(i,k)
+            heo(i,k)  = tem  + hvap * qo(i,k)
+            heso(i,k) = tem  + hvap * qeso(i,k)
+!c           heo(i,k)  = min(heo(i,k),heso(i,k))
+          endif
+        enddo
+      enddo
+!c
+!c  determine level with largest moist static energy within pbl
+!c  this is the level where updraft starts
+!c
+      do i=1,im
+         if (cnvflg(i)) then
+            hmax(i) = heo(i,1)
+            kb(i) = 1
+         endif
+      enddo
+      do k = 2, km
+        do i=1,im
+          if (cnvflg(i).and.k.le.kpbl(i)) then
+            if(heo(i,k).gt.hmax(i)) then
+              kb(i)   = k
+              hmax(i) = heo(i,k)
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do k = 1, km1
+        do i=1,im
+          if (cnvflg(i) .and. k .le. kmax(i)-1) then
+            dz      = .5 * (zo(i,k+1) - zo(i,k))
+            dp      = .5 * (pfld(i,k+1) - pfld(i,k))
+            es      = 0.01 * fpvs(to(i,k+1))      ! fpvs is in pa
+            pprime  = pfld(i,k+1) + epsm1 * es
+            qs      = eps * es / pprime
+            dqsdp   = - qs / pprime
+            desdt   = es * (fact1 / to(i,k+1) + fact2 / (to(i,k+1)**2))
+            dqsdt   = qs * pfld(i,k+1) * desdt / (es * pprime)
+            gamma   = el2orc * qeso(i,k+1) / (to(i,k+1)**2)
+            dt      = (g * dz + hvap * dqsdp * dp) / (cp * (1. + gamma))
+            dq      = dqsdt * dt + dqsdp * dp
+            to(i,k) = to(i,k+1) + dt
+            qo(i,k) = qo(i,k+1) + dq
+            po(i,k) = .5 * (pfld(i,k) + pfld(i,k+1))
+          endif
+        enddo
+      enddo
+!
+      do k = 1, km1
+        do i=1,im
+          if (cnvflg(i) .and. k .le. kmax(i)-1) then
+            qeso(i,k) = 0.01 * fpvs(to(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (po(i,k) + epsm1*qeso(i,k))
+            val1      =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val1)
+            val2      =           1.e-10
+            qo(i,k)   = max(qo(i,k), val2 )
+!           qo(i,k)   = min(qo(i,k),qeso(i,k))
+            heo(i,k)  = .5 * g * (zo(i,k) + zo(i,k+1)) +                &
+     &                  cp * to(i,k) + hvap * qo(i,k)
+            heso(i,k) = .5 * g * (zo(i,k) + zo(i,k+1)) +                &
+     &                  cp * to(i,k) + hvap * qeso(i,k)
+            uo(i,k)   = .5 * (uo(i,k) + uo(i,k+1))
+            vo(i,k)   = .5 * (vo(i,k) + vo(i,k+1))
+          endif
+        enddo
+      enddo
+!c
+!c  look for the level of free convection as cloud base
+!c
+      do i=1,im
+        flg(i)   = cnvflg(i)
+        if(flg(i)) kbcon(i) = kmax(i)
+      enddo
+      do k = 2, km1
+        do i=1,im
+          if (flg(i).and.k.lt.kbm(i)) then
+            if(k.gt.kb(i).and.heo(i,kb(i)).gt.heso(i,k)) then
+              kbcon(i) = k
+              flg(i)   = .false.
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do i=1,im
+        if(cnvflg(i)) then
+          if(kbcon(i).eq.kmax(i)) cnvflg(i) = .false.
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+      do i=1,im
+        if(cnvflg(i)) then
+!         pdot(i)  = 10.* dot(i,kbcon(i))
+          pdot(i)  = 0.01 * dot(i,kbcon(i)) ! Now dot is in Pa/s
+        endif
+      enddo
+!c
+!c   turn off convection if pressure depth between parcel source level
+!c      and cloud base is larger than a critical value, cinpcr
+!c
+      do i=1,im
+        if(cnvflg(i)) then
+          if(islimsk(i) == 1) then
+            w1 = w1l
+            w2 = w2l
+            w3 = w3l
+            w4 = w4l
+          else
+            w1 = w1s
+            w2 = w2s
+            w3 = w3s
+            w4 = w4s
+          endif
+          if(pdot(i).le.w4) then
+            tem = (pdot(i) - w4) / (w3 - w4)
+          elseif(pdot(i).ge.-w4) then
+            tem = - (pdot(i) + w4) / (w4 - w3)
+          else
+            tem = 0.
+          endif
+          val1    =            -1.
+          tem = max(tem,val1)
+          val2    =             1.
+          tem = min(tem,val2)
+          ptem = 1. - tem
+          ptem1= .5*(cinpcrmx-cinpcrmn)
+          cinpcr = cinpcrmx - ptem * ptem1
+          tem1 = pfld(i,kb(i)) - pfld(i,kbcon(i))
+          if(tem1.gt.cinpcr) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  specify the detrainment rate for the updrafts
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          xlamud(i) = xlamue(i,kbcon(i))
+!         xlamud(i) = xlamue(i,kbcon(i))
+!          xlamud(i) = crtlamd
+        endif
+      enddo
+!c
+!c  determine updraft mass flux for the subcloud layers
+!c
+      do k = km1, 1, -1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.lt.kbcon(i).and.k.ge.kb(i)) then
+              dz       = zi(i,k+1) - zi(i,k)
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k+1))-xlamud(i)
+              eta(i,k) = eta(i,k+1) / (1. + ptem * dz)
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  compute mass flux above cloud base
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+      enddo
+      do k = 2, km1
+        do i = 1, im
+         if(flg(i))then
+           if(k.gt.kbcon(i).and.k.lt.kmax(i)) then
+              dz       = zi(i,k) - zi(i,k-1)
+              ptem     = 0.5*(xlamue(i,k)+xlamue(i,k-1))-xlamud(i)
+              eta(i,k) = eta(i,k-1) * (1 + ptem * dz)
+              if(eta(i,k).le.0.) then
+                kmax(i) = k
+                ktconn(i) = k
+                kbm(i) = min(kbm(i),kmax(i))
+                flg(i) = .false.
+              endif
+           endif
+         endif
+        enddo
+      enddo
+!c
+!c  compute updraft cloud property
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx         = kb(i)
+          hcko(i,indx) = heo(i,indx)
+          ucko(i,indx) = uo(i,indx)
+          vcko(i,indx) = vo(i,indx)
+        endif
+      enddo
+!c
+!  cm is an enhancement factor in entrainment rates for momentum
+!
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.kmax(i)) then
+              dz   = zi(i,k) - zi(i,k-1)
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              hcko(i,k) = ((1.-tem1)*hcko(i,k-1)+tem*0.5*            &
+     &                     (heo(i,k)+heo(i,k-1)))/factor
+              dbyo(i,k) = hcko(i,k) - heso(i,k)
+!
+              tem  = 0.5 * cm * tem
+              factor = 1. + tem
+              ptem = tem + pgcon
+              ptem1= tem - pgcon
+              ucko(i,k) = ((1.-tem)*ucko(i,k-1)+ptem*uo(i,k)           &
+     &                     +ptem1*uo(i,k-1))/factor
+              vcko(i,k) = ((1.-tem)*vcko(i,k-1)+ptem*vo(i,k)           &
+     &                     +ptem1*vo(i,k-1))/factor
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c   taking account into convection inhibition due to existence of
+!c    dry layers below cloud base
+!c
+      do i=1,im
+        flg(i) = cnvflg(i)
+        kbcon1(i) = kmax(i)
+      enddo
+      do k = 2, km1
+      do i=1,im
+        if (flg(i).and.k.lt.kbm(i)) then
+          if(k.ge.kbcon(i).and.dbyo(i,k).gt.0.) then
+            kbcon1(i) = k
+            flg(i)    = .false.
+          endif
+        endif
+      enddo
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          if(kbcon1(i).eq.kmax(i)) cnvflg(i) = .false.
+        endif
+      enddo
+      do i=1,im
+        if(cnvflg(i)) then
+          tem = pfld(i,kbcon(i)) - pfld(i,kbcon1(i))
+          if(tem.gt.dthk) then
+             cnvflg(i) = .false.
+          endif
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i = 1, im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  calculate convective inhibition
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.kbcon1(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma                         &
+     &                 * to(i,k) / hvap
+              cina(i) = cina(i) +                                      &
+!    &                 dz1 * eta(i,k) * (g / (cp * to(i,k)))
+     &                 dz1 * (g / (cp * to(i,k)))                      &
+     &                 * dbyo(i,k) / (1. + gamma)                      &
+     &                 * rfact
+              val = 0.
+              cina(i) = cina(i) +                                        &
+!    &                 dz1 * eta(i,k) * g * delta *
+     &                 dz1 * g * delta *                                  &
+     &                 max(val,(qeso(i,k) - qo(i,k)))
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+!
+!         if(islimsk(i) == 1) then
+!           w1 = w1l
+!           w2 = w2l
+!           w3 = w3l
+!           w4 = w4l
+!         else
+!           w1 = w1s
+!           w2 = w2s
+!           w3 = w3s
+!           w4 = w4s
+!         endif
+!         if(pdot(i).le.w4) then
+!           tem = (pdot(i) - w4) / (w3 - w4)
+!         elseif(pdot(i).ge.-w4) then
+!           tem = - (pdot(i) + w4) / (w4 - w3)
+!         else
+!           tem = 0.
+!         endif
+!
+!         val1    =            -1.
+!         tem = max(tem,val1)
+!         val2    =             1.
+!         tem = min(tem,val2)
+!         tem = 1. - tem
+!         tem1= .5*(cinacrmx-cinacrmn)
+!         cinacr = cinacrmx - tem * tem1
+!
+          cinacr = cinacrmx
+          if(cina(i).lt.cinacr) cnvflg(i) = .false.
+        endif
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  determine first guess cloud top as the level of zero buoyancy
+!c    limited to the level of P/Ps=0.7
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+        if(flg(i)) ktcon(i) = kbm(i)
+      enddo
+      do k = 2, km1
+      do i=1,im
+        if (flg(i).and.k .lt. kbm(i)) then
+          if(k.gt.kbcon1(i).and.dbyo(i,k).lt.0.) then
+             ktcon(i) = k
+             flg(i)   = .false.
+          endif
+        endif
+      enddo
+      enddo
+!c
+!c  turn off shallow convection if cloud top is less than pbl top
+!c
+!     do i=1,im
+!       if(cnvflg(i)) then
+!         kk = kpbl(i)+1
+!         if(ktcon(i).le.kk) cnvflg(i) = .false.
+!       endif
+!     enddo
+!!
+!     totflg = .true.
+!     do i = 1, im
+!       totflg = totflg .and. (.not. cnvflg(i))
+!     enddo
+!     if(totflg) return
+!!
+!c
+!c  specify upper limit of mass flux at cloud base
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+!         xmbmax(i) = .1
+!
+          k = kbcon(i)
+          dp = 1000. * del(i,k)
+          xmbmax(i) = dp / (g * dt2)
+!
+!         tem = dp / (g * dt2)
+!         xmbmax(i) = min(tem, xmbmax(i))
+        endif
+      enddo
+!c
+!c  compute cloud moisture property and precipitation
+!c
+      do i = 1, im
+        if (cnvflg(i)) then
+          aa1(i) = 0.
+          qcko(i,kb(i)) = qo(i,kb(i))
+          qrcko(i,kb(i)) = qo(i,kb(i))
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                                               &
+     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*                    &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+              qrcko(i,k) = qcko(i,k)
+!cj
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!c
+!             rhbar(i) = rhbar(i) + qo(i,k) / qeso(i,k)
+!c
+!c  below lfc check if there is excess moisture to release latent heat
+!c
+              if(k.ge.kbcon(i).and.dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0) then
+                  dp = 1000. * del(i,k)
+                  ptem = c0t(i,k) + c1(i)
+                  qlk = dq / (eta(i,k) + etah * ptem * dz)
+                  dellal(i,k) = etah * c1(i) * dz * qlk * g / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz)
+                endif
+                buo(i,k) = buo(i,k) - g * qlk
+                qcko(i,k)= qlk + qrch
+                pwo(i,k) = etah * c0t(i,k) * dz * qlk
+                cnvwt(i,k) = etah * qlk * g / dp
+              endif
+!
+!  compute buoyancy and drag for updraft velocity
+!
+              if(k >= kbcon(i)) then
+                rfact =  1. + delta * cp * gamma                      &
+     &                   * to(i,k) / hvap
+                buo(i,k) = buo(i,k) + (g / (cp * to(i,k)))              &
+     &                   * dbyo(i,k) / (1. + gamma)                    &
+     &                   * rfact
+                val = 0.
+                buo(i,k) = buo(i,k) + g * delta *                     &
+     &                     max(val,(qeso(i,k) - qo(i,k)))
+!               drag(i,k) = max(xlamue(i,k),xlamud(i))
+              endif
+!
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  calculate cloud work function
+!c
+!     do k = 2, km1
+!       do i = 1, im
+!         if (cnvflg(i)) then
+!           if(k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+!             dz1 = zo(i,k+1) - zo(i,k)
+!             gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+!             rfact =  1. + delta * cp * gamma
+!    &                 * to(i,k) / hvap
+!             aa1(i) = aa1(i) +
+!!   &                 dz1 * eta(i,k) * (g / (cp * to(i,k)))
+!    &                 dz1 * (g / (cp * to(i,k)))
+!    &                 * dbyo(i,k) / (1. + gamma)
+!    &                 * rfact
+!             val = 0.
+!             aa1(i) = aa1(i) +
+!!   &                 dz1 * eta(i,k) * g * delta *
+!    &                 dz1 * g * delta *
+!    &                 max(val,(qeso(i,k) - qo(i,k)))
+!           endif
+!         endif
+!       enddo
+!     enddo
+!     do i = 1, im
+!       if(cnvflg(i).and.aa1(i).le.0.) cnvflg(i) = .false.
+!     enddo
+!
+!  calculate cloud work function
+!
+      do i = 1, im
+        if (cnvflg(i)) then
+          aa1(i) = 0.
+        endif
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k >= kbcon(i) .and. k < ktcon(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              aa1(i) = aa1(i) + buo(i,k) * dz1
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i) .and. aa1(i) <= 0.) cnvflg(i) = .false.
+      enddo
+!!
+      totflg = .true.
+      do i=1,im
+        totflg = totflg .and. (.not. cnvflg(i))
+      enddo
+      if(totflg) return
+!!
+!c
+!c  estimate the onvective overshooting as the level
+!c    where the [aafac * cloud work function] becomes zero,
+!c    which is the final cloud top
+!c    limited to the level of P/Ps=0.7
+!c
+      do i = 1, im
+        if (cnvflg(i)) then
+          aa1(i) = aafac * aa1(i)
+        endif
+      enddo
+!c
+      do i = 1, im
+        flg(i) = cnvflg(i)
+        ktcon1(i) = kbm(i)
+      enddo
+      do k = 2, km1
+        do i = 1, im
+          if (flg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.kbm(i)) then
+              dz1 = zo(i,k+1) - zo(i,k)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              rfact =  1. + delta * cp * gamma                     &
+     &                 * to(i,k) / hvap
+              aa1(i) = aa1(i) +                                     &
+!    &                 dz1 * eta(i,k) * (g / (cp * to(i,k)))
+     &                 dz1 * (g / (cp * to(i,k)))                   &
+     &                 * dbyo(i,k) / (1. + gamma)                   &
+     &                 * rfact
+!             val = 0.
+!             aa1(i) = aa1(i) +
+!!   &                 dz1 * eta(i,k) * g * delta *
+!    &                 dz1 * g * delta *
+!    &                 max(val,(qeso(i,k) - qo(i,k)))
+              if(aa1(i).lt.0.) then
+                ktcon1(i) = k
+                flg(i) = .false.
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c  compute cloud moisture property, detraining cloud water
+!c    and precipitation in overshooting layers
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.ge.ktcon(i).and.k.lt.ktcon1(i)) then
+              dz    = zi(i,k) - zi(i,k-1)
+              gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+              qrch = qeso(i,k)                                          &
+     &             + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+!cj
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1)) * dz
+              tem1 = 0.5 * xlamud(i) * dz
+              factor = 1. + tem - tem1
+              qcko(i,k) = ((1.-tem1)*qcko(i,k-1)+tem*0.5*               &
+     &                     (qo(i,k)+qo(i,k-1)))/factor
+              qrcko(i,k) = qcko(i,k)
+!cj
+              dq = eta(i,k) * (qcko(i,k) - qrch)
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+              if(dq.gt.0.) then
+                etah = .5 * (eta(i,k) + eta(i,k-1))
+                if(ncloud.gt.0) then
+                  dp = 1000. * del(i,k)
+                  ptem = c0t(i,k) + c1(i)
+                  qlk = dq / (eta(i,k) + etah * ptem * dz)
+                  dellal(i,k) = etah * c1(i) * dz * qlk * g / dp
+                else
+                  qlk = dq / (eta(i,k) + etah * c0t(i,k) * dz)
+                endif
+                qcko(i,k) = qlk + qrch
+                pwo(i,k) = etah * c0t(i,k) * dz * qlk
+                cnvwt(i,k) = etah * qlk * g / dp
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+!  compute updraft velocity square(wu2)
+!
+!     bb1 = 2. * (1.+bet1*cd1)
+!     bb2 = 2. / (f1*(1.+gam1))
+!
+!!    bb1 = 12.0
+!!    bb2 = 0.67
+!
+!     do i = 1, im
+!       if (cnvflg(i)) then
+!         k = kbcon1(i)
+!         tem = po(i,k) / (rd * to(i,k))
+!         wucb = -0.01 * dot(i,k) / (tem * g)
+!         if(wucb > 0.) then
+!           wu2(i,k) = wucb * wucb
+!         else
+!           wu2(i,k) = 0.
+!         endif
+!       endif
+!     enddo
+!     do k = 2, km1
+!       do i = 1, im
+!         if (cnvflg(i)) then
+!           if(k > kbcon1(i) .and. k < ktcon(i)) then
+!             dz    = zi(i,k) - zi(i,k-1)
+!             tem  = 0.25 * bb1 * (drag(i,k)+drag(i,k-1)) * dz
+!             tem1 = 0.5 * bb2 * (buo(i,k)+buo(i,k-1)) * dz
+!             ptem = (1. - tem) * wu2(i,k-1)
+!             ptem1 = 1. + tem
+!             wu2(i,k) = (ptem + tem1) / ptem1
+!             wu2(i,k) = max(wu2(i,k), 0.)
+!           endif
+!         endif
+!       enddo
+!     enddo
+!
+!  compute updraft velocity averaged over the whole cumulus
+!
+!     do i = 1, im
+!       wc(i) = 0.
+!       sumx(i) = 0.
+!     enddo
+!     do k = 2, km1
+!       do i = 1, im
+!         if (cnvflg(i)) then
+!           if(k > kbcon1(i) .and. k < ktcon(i)) then
+!             dz = zi(i,k) - zi(i,k-1)
+!             tem = 0.5 * (sqrt(wu2(i,k)) + sqrt(wu2(i,k-1)))
+!             wc(i) = wc(i) + tem * dz
+!             sumx(i) = sumx(i) + dz
+!           endif
+!         endif
+!       enddo
+!     enddo
+!     do i = 1, im
+!       if(cnvflg(i)) then
+!         if(sumx(i) == 0.) then
+!            cnvflg(i)=.false.
+!         else
+!            wc(i) = wc(i) / sumx(i)
+!         endif
+!         val = 1.e-4
+!         if (wc(i) < val) cnvflg(i)=.false.
+!       endif
+!     enddo
+!c
+!c exchange ktcon with ktcon1
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          kk = ktcon(i)
+          ktcon(i) = ktcon1(i)
+          ktcon1(i) = kk
+        endif
+      enddo
+!c
+!c  this section is ready for cloud water
+!c
+      if(ncloud.gt.0) then
+!c
+!c  compute liquid and vapor separation at cloud top
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          k = ktcon(i) - 1
+          gamma = el2orc * qeso(i,k) / (to(i,k)**2)
+          qrch = qeso(i,k)                                         &
+     &         + gamma * dbyo(i,k) / (hvap * (1. + gamma))
+          dq = qcko(i,k) - qrch
+!c
+!c  check if there is excess moisture to release latent heat
+!c
+          if(dq.gt.0.) then
+            qlko_ktcon(i) = dq
+            qcko(i,k) = qrch
+          endif
+        endif
+      enddo
+      endif
+!c
+!c--- compute precipitation efficiency in terms of windshear
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          vshear(i) = 0.
+        endif
+      enddo
+      do k = 2, km
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              shear= sqrt((uo(i,k)-uo(i,k-1)) ** 2                     &
+     &                  + (vo(i,k)-vo(i,k-1)) ** 2)
+              vshear(i) = vshear(i) + shear
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+          vshear(i) = 1.e3 * vshear(i) / (zi(i,ktcon(i))-zi(i,kb(i)))
+          e1=1.591-.639*vshear(i)                                     &
+     &       +.0953*(vshear(i)**2)-.00496*(vshear(i)**3)
+          edt(i)=1.-e1
+          val =         .9
+          edt(i) = min(edt(i),val)
+          val =         .0
+          edt(i) = max(edt(i),val)
+        endif
+      enddo
+!c
+!c--- what would the change be, that a cloud with unit mass
+!c--- will do to the environment?
+!c
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i) .and. k .le. kmax(i)) then
+            dellah(i,k) = 0.
+            dellaq(i,k) = 0.
+            dellau(i,k) = 0.
+            dellav(i,k) = 0.
+          endif
+        enddo
+      enddo
+!c
+!c--- changed due to subsidence and entrainment
+!c
+      do k = 2, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.lt.ktcon(i)) then
+              dp = 1000. * del(i,k)
+              dz = zi(i,k) - zi(i,k-1)
+!c
+              dv1h = heo(i,k)
+              dv2h = .5 * (heo(i,k) + heo(i,k-1))
+              dv3h = heo(i,k-1)
+              dv1q = qo(i,k)
+              dv2q = .5 * (qo(i,k) + qo(i,k-1))
+              dv3q = qo(i,k-1)
+!c
+              tem  = 0.5 * (xlamue(i,k)+xlamue(i,k-1))
+              tem1 = xlamud(i)
+!cj
+              dellah(i,k) = dellah(i,k) +                      &
+     &     ( eta(i,k)*dv1h - eta(i,k-1)*dv3h                   &
+     &    -  tem*eta(i,k-1)*dv2h*dz                             &
+     &    +  tem1*eta(i,k-1)*.5*(hcko(i,k)+hcko(i,k-1))*dz      &
+     &         ) *g/dp
+!cj
+              dellaq(i,k) = dellaq(i,k) +                       &
+     &     ( eta(i,k)*dv1q - eta(i,k-1)*dv3q                    &
+     &    -  tem*eta(i,k-1)*dv2q*dz                               &
+     &    +  tem1*eta(i,k-1)*.5*(qrcko(i,k)+qcko(i,k-1))*dz        &
+     &         ) *g/dp
+!cj
+              tem1=eta(i,k)*(uo(i,k)-ucko(i,k))
+              tem2=eta(i,k-1)*(uo(i,k-1)-ucko(i,k-1))
+              dellau(i,k) = dellau(i,k) + (tem1-tem2) * g/dp
+!cj
+              tem1=eta(i,k)*(vo(i,k)-vcko(i,k))
+              tem2=eta(i,k-1)*(vo(i,k-1)-vcko(i,k-1))
+              dellav(i,k) = dellav(i,k) + (tem1-tem2) * g/dp
+!cj
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c------- cloud top
+!c
+      do i = 1, im
+        if(cnvflg(i)) then
+          indx = ktcon(i)
+          dp = 1000. * del(i,indx)
+          dv1h = heo(i,indx-1)
+          dellah(i,indx) = eta(i,indx-1) *                         &
+     &                     (hcko(i,indx-1) - dv1h) * g / dp
+          dv1q = qo(i,indx-1)
+          dellaq(i,indx) = eta(i,indx-1) *                         &
+     &                     (qcko(i,indx-1) - dv1q) * g / dp
+          dellau(i,indx) = eta(i,indx-1) *                          &
+     &             (ucko(i,indx-1) - uo(i,indx-1)) * g / dp
+          dellav(i,indx) = eta(i,indx-1) *                          &
+     &             (vcko(i,indx-1) - vo(i,indx-1)) * g / dp
+!c
+!c  cloud water
+!c
+          dellal(i,indx) = eta(i,indx-1) *                         &
+     &                     qlko_ktcon(i) * g / dp
+        endif
+      enddo
+!c
+!c  mass flux at cloud base for shallow convection
+!c  (Grant, 2001)
+!c
+      do i= 1, im
+        if(cnvflg(i)) then
+          k = kbcon(i)
+!         ptem = g*sflx(i)*zi(i,k)/t1(i,1)
+          ptem = g*sflx(i)*hpbl(i)/t1(i,1)
+          wstar(i) = ptem**h1
+          tem = po(i,k)*100. / (rd*to(i,k))
+          xmb(i) = betaw*tem*wstar(i)
+        endif
+      enddo
+!
+!--- compute updraft fraction based on Arakawa & Wu (2013)
+!    using values at cloud base
+!
+!  grid-scale vertical velocity at cloud base
+!
+      ptem = -0.01 * rd / g
+      do i = 1, im
+        wbar(i) = 0.
+        if (cnvflg(i)) then
+          k = kbcon(i)
+          tem  = dot(i,k) * to(i,k) / po(i,k)
+          wbar(i) = ptem * tem
+        endif
+      enddo
+!
+!  estimate updraft velocity at cloud base using cloud base mass flux
+!
+      ptem = 0.01 * rd
+      do i = 1, im
+        wcxmb(i) = 0.
+        if (cnvflg(i)) then
+          k = kbcon(i)
+          tem  = xmb(i) * ptem * to(i,k)  /  po(i,k)
+          wcxmb(i) = tem / 0.1
+!         wcxmb(i) = tem / 0.03
+        endif
+      enddo
+!
+!  compute updraft fraction
+!
+      ptem = 0.01 * rd
+      do i = 1, im
+        xmbeta(i) = 0.
+        if (cnvflg(i)) then
+          k = kbcon(i)
+          tem  = to(i,k) / po(i,k)
+          xmbeta(i) = xmb(i) * ptem * tem
+        endif
+      enddo
+      do i = 1, im
+        if (cnvflg(i)) then
+          tem = wcxmb(i) - wbar(i)
+          val = 1.e-8
+          tem = max(tem, val)
+          awlam(i) = xmbeta(i) / tem
+!         awlam(i) = min(awlam(i), 100.)
+        endif
+      enddo
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+          sigmaw(i) = .001
+          flg(i) = .true.
+        endif
+      enddo
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+          do n = 1, itsig
+            if(flg(i)) then
+              ptem = sigmaw(i)
+              tem = 1. - ptem
+              fs0 = awlam(i) * (tem**3.) - ptem
+              fp1 = -3. * awlam(i) * (tem**2.) - 1.
+              fp1 = min(fp1, -1.e-3_kind_phys)
+              sigmaw(i) = ptem - fs0 / fp1
+              tem1 = abs(sigmaw(i) - ptem)
+              if(tem1 < .01) then
+                flg(i)   = .false.
+              endif
+            endif
+          enddo
+          sigmaw(i) = max(sigmaw(i), 0.001_kind_phys)
+          sigmaw(i) = min(sigmaw(i), 0.999_kind_phys)
+        endif
+      enddo
+!
+!--- compute updraft fraction based on Grell & Freitas (2014)
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+          sigmagf(i) = gfudarea / garea(i)
+          sigmagf(i) = max(sigmagf(i), 0.001_kind_phys)
+          sigmagf(i) = min(sigmagf(i), 0.7_kind_phys)
+        endif
+      enddo
+
+!--- modified Grell & Freitas' (2014) updraft fraction which uses
+!     actual entrainment rate at cloud base
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+!          k = kbcon(i)
+!          tem = 0.2 / max(xlamue(i,k), 3.e-5)
+           tem = min(max(xlamue(i,kbcon(i)), 2.e-4_kind_phys), 6.e-4_kind_phys)
+           tem = 0.2 / tem
+
+          tem1 = 3.14 * tem * tem
+          sigmagfm(i) = tem1 / garea(i)
+          sigmagfm(i) = max(sigmagfm(i), 0.001_kind_phys)
+          sigmagfm(i) = min(sigmagfm(i), 0.999_kind_phys)
+        endif
+      enddo
+
+
+!
+!--- compute scale-aware function based on Arakawa & Wu (2013)
+!  using combination of updraft fractions from both
+!   Arakawa & Wu (2013) and Grell & Freitas (2014)
+!
+!
+      do i = 1, im
+        if(cnvflg(i)) then
+          tem = 0.001 * sqrt(garea(i))
+          if (tem < 25.) then
+!           scaldfunc(i) = (1.-sigmaw(i)) * (1.-sigmaw(i))   ! Arakawa & Wu (2013)
+!           scaldfunc(i) = (1.-sigmagf(i)) * (1.-sigmagf(i)) ! Grell & Freitas (2014)
+            scaldfunc(i) = (1.-sigmagfm(i)) * (1.-sigmagfm(i)) ! modified Grell & Freitas(2014)
+!            scaldfunc(i) = (1.-sigmaw(i)) * (1.-sigmagf(i))  ! AW & GF
+            scaldfunc(i) = max(min(scaldfunc(i), 1.0_kind_phys), 0._kind_phys)
+             sigmuout(i) = sigmagfm(i)
+          else
+            scaldfunc(i) = 1.0
+          endif
+          xmb(i) = xmb(i) * scaldfunc(i)
+          xmb(i) = min(xmb(i),xmbmax(i))
+        endif
+      enddo
+!c
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i) .and. k .le. kmax(i)) then
+            qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
+            qeso(i,k) = eps * qeso(i,k) / (pfld(i,k) + epsm1*qeso(i,k))
+            val     =             1.e-8
+            qeso(i,k) = max(qeso(i,k), val )
+          endif
+        enddo
+      enddo
+!c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!c
+      do i = 1, im
+        delhbar(i) = 0.
+        delqbar(i) = 0.
+        deltbar(i) = 0.
+        delubar(i) = 0.
+        delvbar(i) = 0.
+        qcond(i) = 0.
+      enddo
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              dellat = (dellah(i,k) - hvap * dellaq(i,k)) / cp
+              t1(i,k) = t1(i,k) + dellat * xmb(i) * dt2
+              q1(i,k) = q1(i,k) + dellaq(i,k) * xmb(i) * dt2
+!             tem = 1./rcs(i)
+!             u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2 * tem
+!             v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2 * tem
+              u1(i,k) = u1(i,k) + dellau(i,k) * xmb(i) * dt2
+              v1(i,k) = v1(i,k) + dellav(i,k) * xmb(i) * dt2
+              dp = 1000. * del(i,k)
+              delhbar(i) = delhbar(i) + dellah(i,k)*xmb(i)*dp/g
+              delqbar(i) = delqbar(i) + dellaq(i,k)*xmb(i)*dp/g
+              deltbar(i) = deltbar(i) + dellat*xmb(i)*dp/g
+              delubar(i) = delubar(i) + dellau(i,k)*xmb(i)*dp/g
+              delvbar(i) = delvbar(i) + dellav(i,k)*xmb(i)*dp/g
+            endif
+          endif
+        enddo
+      enddo
+!
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.gt.kb(i).and.k.le.ktcon(i)) then
+              qeso(i,k) = 0.01 * fpvs(t1(i,k))      ! fpvs is in pa
+              qeso(i,k) = eps * qeso(i,k)/(pfld(i,k) + epsm1*qeso(i,k))
+              val     =             1.e-8
+              qeso(i,k) = max(qeso(i,k), val )
+            endif
+          endif
+        enddo
+      enddo
+!c
+      do i = 1, im
+        rntot(i) = 0.
+        delqev(i) = 0.
+        delq2(i) = 0.
+        flg(i) = cnvflg(i)
+      enddo
+      do k = km, 1, -1
+        do i = 1, im
+          if (cnvflg(i)) then
+            if(k.lt.ktcon(i).and.k.gt.kb(i)) then
+              rntot(i) = rntot(i) + pwo(i,k) * xmb(i) * .001 * dt2
+            endif
+          endif
+        enddo
+      enddo
+!c
+!c evaporating rain
+!c
+      do k = km, 1, -1
+        do i = 1, im
+          if (k .le. kmax(i)) then
+            deltv(i) = 0.
+            delq(i) = 0.
+            qevap(i) = 0.
+            if(cnvflg(i)) then
+              if(k.lt.ktcon(i).and.k.gt.kb(i)) then
+                rn(i) = rn(i) + pwo(i,k) * xmb(i) * .001 * dt2
+              endif
+            endif
+            if(flg(i).and.k.lt.ktcon(i)) then
+              evef = edt(i) * evfact
+              if(islimsk(i) == 1) evef=edt(i) * evfactl
+!             if(islimsk(i) == 1) evef=.07
+!c             if(islimsk(i) == 1) evef = 0.
+              qcond(i) = evef * (q1(i,k) - qeso(i,k))                    &
+     &                 / (1. + el2orc * qeso(i,k) / t1(i,k)**2)
+              dp = 1000. * del(i,k)
+              if(rn(i).gt.0..and.qcond(i).lt.0.) then
+                qevap(i) = -qcond(i) * (1.-exp(-.32*sqrt(dt2*rn(i))))
+                qevap(i) = min(qevap(i), rn(i)*1000.*g/dp)
+                delq2(i) = delqev(i) + .001 * qevap(i) * dp / g
+              endif
+              if(rn(i).gt.0..and.qcond(i).lt.0..and.                          &
+     &           delq2(i).gt.rntot(i)) then
+                qevap(i) = 1000.* g * (rntot(i) - delqev(i)) / dp
+                flg(i) = .false.
+              endif
+              if(rn(i).gt.0..and.qevap(i).gt.0.) then
+                tem  = .001 * dp / g
+                tem1 = qevap(i) * tem
+                if(tem1.gt.rn(i)) then
+                  qevap(i) = rn(i) / tem
+                  rn(i) = 0.
+                else
+                  rn(i) = rn(i) - tem1
+                endif
+                q1(i,k) = q1(i,k) + qevap(i)
+                t1(i,k) = t1(i,k) - elocp * qevap(i)
+                deltv(i) = - elocp*qevap(i)/dt2
+                delq(i) =  + qevap(i)/dt2
+                delqev(i) = delqev(i) + .001*dp*qevap(i)/g
+              endif
+              delqbar(i) = delqbar(i) + delq(i)*dp/g
+              deltbar(i) = deltbar(i) + deltv(i)*dp/g
+            endif
+          endif
+        enddo
+      enddo
+!cj
+!     do i = 1, im
+!     if(me.eq.31.and.cnvflg(i)) then
+!     if(cnvflg(i)) then
+!       print *, ' shallow delhbar, delqbar, deltbar = ',
+!    &             delhbar(i),hvap*delqbar(i),cp*deltbar(i)
+!       print *, ' shallow delubar, delvbar = ',delubar(i),delvbar(i)
+!       print *, ' precip =', hvap*rn(i)*1000./dt2
+!       print*,'pdif= ',pfld(i,kbcon(i))-pfld(i,ktcon(i))
+!     endif
+!     enddo
+!cj
+      do i = 1, im
+        if(cnvflg(i)) then
+          if(rn(i).lt.0..or..not.flg(i)) rn(i) = 0.
+          ktop(i) = ktcon(i)
+          kbot(i) = kbcon(i)
+          kcnv(i) = 2
+        endif
+      enddo
+!c
+!c  convective cloud water
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i)) then
+            if (k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+              cnvw(i,k) = cnvwt(i,k) * xmb(i) * dt2
+            endif
+          endif
+        enddo
+      enddo
+
+!c
+!c  convective cloud cover
+!c
+      do k = 1, km
+        do i = 1, im
+          if (cnvflg(i)) then
+            if (k.ge.kbcon(i).and.k.lt.ktcon(i)) then
+              cnvc(i,k) = 0.04 * log(1. + 675. * eta(i,k) * xmb(i))
+              cnvc(i,k) = min(cnvc(i,k), 0.2_kind_phys)
+              cnvc(i,k) = max(cnvc(i,k), 0.0_kind_phys)
+            endif
+          endif
+        enddo
+      enddo
+
+!c
+!c  cloud water
+!c
+      if (ncloud.gt.0) then
+!
+      do k = 1, km1
+        do i = 1, im
+          if (cnvflg(i)) then
+!            if (k.gt.kb(i).and.k.le.ktcon(i)) then
+            if (k.ge.kbcon(i).and.k.le.ktcon(i)) then
+              tem  = dellal(i,k) * xmb(i) * dt2
+              tem1 = max(0.0_kind_phys, min(1.0_kind_phys, (tcr-t1(i,k))*tcrf))
+              if (ql(i,k,2) .gt. -999.0) then
+                ql(i,k,1) = ql(i,k,1) + tem * tem1            ! ice
+                ql(i,k,2) = ql(i,k,2) + tem *(1.0-tem1)       ! water
+              else
+                ql(i,k,1) = ql(i,k,1) + tem
+              endif
+            endif
+          endif
+        enddo
+      enddo
+!
+      endif
+!
+! hchuang code change
+!
+      do k = 1, km
+        do i = 1, im
+          if(cnvflg(i)) then
+            if(k.ge.kb(i) .and. k.lt.ktop(i)) then
+              ud_mf(i,k) = eta(i,k) * xmb(i) * dt2
+            endif
+          endif
+        enddo
+      enddo
+      do i = 1, im
+        if(cnvflg(i)) then
+           k = ktop(i)-1
+           dt_mf(i,k) = ud_mf(i,k)
+        endif
+      enddo
+!!
+      return
+      end subroutine scale_shalcnv
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      END MODULE module_cu_scalesas
+
diff --git a/wrfv2_fire/phys/module_cumulus_driver.F b/wrfv2_fire/phys/module_cumulus_driver.F
index cfec8fb6..ef13b274 100644
--- a/wrfv2_fire/phys/module_cumulus_driver.F
+++ b/wrfv2_fire/phys/module_cumulus_driver.F
@@ -98,6 +98,10 @@ SUBROUTINE cumulus_driver(grid                                     &
                      ,ens_sasamp                                      &
                      ,shalconv,shal_pgcon                             &
                      ,HPBL2D,EVAP2D,HEAT2D                            &     !Kwon for SAS2010 shallow convection
+                     ,DX2D, DYNMM                                     & ! For scale-aware SAS
+                     ,SCALEFUN,SCALEFUN1                              & !    scale functions 
+                     ,SIGMU,SIGMU1                                    & !    updraft fraction
+
                  ! Optional arguments for NSAS scheme
                      ,mp_physics                                      &
                  ! Optional moisture and other tendencies
@@ -129,7 +133,9 @@ SUBROUTINE cumulus_driver(grid                                     &
                                           ,G3SCHEME,GFSCHEME          &
                                           ,P_QC,P_QI,Param_FIRST_SCALAR &
                                           ,CAMZMSCHEME, SASSCHEME     &
-                                          ,OSASSCHEME,MESO_SAS        &  !Kwon
+                                          ,OSASSCHEME                 &  
+                                          ,SCALESASSCHEME             &  ! scale-sware sas
+
                                           ,NSASSCHEME                 &
 #if (EM_CORE == 1)
                                           ,MSKFSCHEME                 &
@@ -157,14 +163,15 @@ SUBROUTINE cumulus_driver(grid                                     &
    USE module_cu_mskf   , ONLY : mskf_cps
 #endif
    USE module_cu_gd     , ONLY : grelldrv
-   USE module_cu_gf     , ONLY : gfdrv
+   USE module_cu_gf_wrfdrv     , ONLY : gfdrv
    USE module_cu_g3     , ONLY : g3drv,conv_grell_spread3d
    USE module_cu_sas    , ONLY : cu_sas
+   USE module_cu_scalesas    , ONLY : cu_scalesas
+
 #if (EM_CORE == 1)
    USE module_cu_kfcup  , ONLY : KF_CUP_CPS !wig, 3-Aug-2006 !BSINGH - For WRFCuP scheme 
 #endif
    USE module_cu_osas   , ONLY : cu_osas
-   USE module_cu_mesosas, ONLY : cu_meso_sas
    USE module_cu_camzm_driver, ONLY : camzm_driver
    USE module_cu_tiedtke, ONLY : cu_tiedtke
    USE module_cu_ntiedtke,ONLY : cu_ntiedtke
@@ -276,8 +283,8 @@ SUBROUTINE cumulus_driver(grid                                     &
 !-- RTHRATEN      radiative temp forcing for Grell-Devenyi scheme
 !-- RTHBLTEN      PBL temp forcing for Grell-Devenyi scheme
 !-- RQVBLTEN      PBL moisture forcing for Grell-Devenyi scheme
-!-- RTHFTEN
-!-- RQVFTEN
+!-- RTHFTEN       Advective tendency for theta
+!-- RQVFTEN       Advective tendency for vapor
 !-- MASS_FLUX
 !-- XF_ENS
 !-- PR_ENS
@@ -502,6 +509,14 @@ SUBROUTINE cumulus_driver(grid                                     &
 !
    REAL, OPTIONAL,  INTENT(INOUT) :: mommix
 
+
+   REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL,               &    
+                    INTENT(IN) ::  DX2D                           ! For scale-aware SAS
+   REAL, OPTIONAL,  INTENT(IN) ::  DYNMM                          ! For scale-aware SAS  
+   REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL,INTENT(INOUT) :: &
+                                   SCALEFUN,SCALEFUN1,SIGMU,SIGMU1    
+
+
    REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL,               &    !Kwon for sas2010 shallow convection
                     INTENT(INOUT) ::  HPBL2D, EVAP2D, HEAT2D
 !
@@ -636,6 +651,15 @@ SUBROUTINE cumulus_driver(grid                                     &
                                                      ,f_qg
    LOGICAL, INTENT(IN), OPTIONAL ::                   f_flux
 
+!beka - random pattern  arrays, if not existing, set to zero
+!
+!     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(INOUT),OPTIONAL :: &
+!           pattern_spp_conv,field_conv
+!     INTEGER, OPTIONAL :: spp_conv
+     REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) :: &
+           pattern_spp_conv,field_conv
+     INTEGER  :: spp_conv
+
 #if ( WRF_DFI_RADAR == 1 )
 !
 !  option of cap suppress: 
@@ -655,6 +679,10 @@ SUBROUTINE cumulus_driver(grid                                     &
 
 
 !-----------------------------------------------------------------
+    pattern_spp_conv=0.
+    field_conv=0.
+    spp_conv=0
+
 
    l_flux=.FALSE.
    if (present(f_flux)) l_flux=f_flux
@@ -766,7 +794,7 @@ SUBROUTINE cumulus_driver(grid                                     &
    END IF
 
 #if  ( EM_CORE == 1 )
-      if(cu_physics .eq. 5 .or. cu_physics .eq. 16) then
+      if(cu_physics == G3SCHEME .or. cu_physics == NTIEDTKESCHEME) then
       !$OMP PARALLEL DO   &
       !$OMP PRIVATE ( ij,i,j,k,its,ite,jts,jte )
 
@@ -1025,14 +1053,14 @@ SUBROUTINE cumulus_driver(grid                                     &
                ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme &
                ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte &
                                                                 )
-     CASE (MESO_SAS)                  !Kwon
+     CASE (SCALESASSCHEME)   ! 2015-12-11 added to call scale-aware SAS
 
           IF ( adapt_step_flag_pass ) THEN
-            WRITE( wrf_err_message , * ) 'The meso SAS cumulus option will not work properly with an adaptive time step'
+            WRITE( wrf_err_message , * ) 'The SCALE-AWARE SAS cumulus option will not work properly with an adaptive time step'
             CALL wrf_error_fatal ( wrf_err_message )
           END IF
-          CALL wrf_debug(100,'in cu_mesosas')
-          CALL CU_MESO_SAS(                                          &
+          CALL wrf_debug(100,'in cu_scalesas')
+          CALL CU_SCALESAS(                                     &
                 DT=dt,ITIMESTEP=itimestep,STEPCU=STEPCU         &
                ,RTHCUTEN=RTHCUTEN,RQVCUTEN=RQVCUTEN             &
                ,RQCCUTEN=RQCCUTEN,RQICUTEN=RQICUTEN             &
@@ -1049,6 +1077,9 @@ SUBROUTINE cumulus_driver(grid                                     &
                ,shalconv=shalconv,shal_pgcon=shal_pgcon         &
                ,hpbl2d=hpbl2d,evap2d=evap2d,heat2d=heat2d       &
                ,P_QI=p_qi,P_FIRST_SCALAR=param_first_scalar     &
+               ,DX2D=dx2d,DY=dynmm                              & ! 2 new 
+               ,SCALEFUN=SCALEFUN,SCALEFUN1=SCALEFUN1           & ! CNV scale functions
+               ,SIGMU=SIGMU,SIGMU1=SIGMU1                       & ! CNV updraft fractions
                ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde &
                ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme &
                ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte &
@@ -1153,37 +1184,27 @@ SUBROUTINE cumulus_driver(grid                                     &
             ENDDO
          endif
 #endif
-          CALL GFDRV(                                           &
-                DT=dt, ITIMESTEP=itimestep, DX=dx               &
-               ,U=u,V=v,T=t,W=w ,RHO=rho                        &
-               ,P=p,PI=pi,Q=qv_curr,RAINCV=raincv               &
-               ,DZ8W=dz8w ,P8W=p8w,XLV=xlv,CP=cp,G=g,R_V=r_v    &
-               ,APR_GR=apr_gr,APR_W=apr_w,APR_MC=apr_mc         &
-               ,APR_ST=apr_st,APR_AS=apr_as,PRATEC=tmppratec    &
-               ,APR_CAPMA=apr_capma,APR_CAPME=apr_capme         &
-               ,APR_CAPMI=apr_capmi,MASS_FLUX=mass_flux         &
-               ,HT=ht,qfx=qfx,hfx=hfx                           &
-               ,xland=xland,gsw=gsw,edt_out=edt_out             &
+
+         CALL GFDRV(spp_conv,pattern_spp_conv,field_conv,       &
+                DT=dt,DX=dx                                     &
+               ,RHO=rho,RAINCV=raincv,PRATEC=tmppratec          &
+               ,U=u,V=v,T=t,W=w,Q=qv_curr,P=p,PI=pi             &
+               ,DZ8W=dz8w ,P8W=p8w                              &
+               ,htop=htop,hbot=hbot,ktop_deep=ktop_deep         &
+               ,HT=ht,hfx=hfx,qfx=qfx,xland=xland               &
                ,GDC=gd_cloud,GDC2=gd_cloud2,kpbl=kpbl           &
                ,k22_shallow=k22_shallow                         &
                ,kbcon_shallow=kbcon_shallow                     &
                ,ktop_shallow=ktop_shallow                       &
-               ,ktop_deep=ktop_deep                             &
                ,xmb_shallow=xmb_shallow                         &
-               ,cugd_tten=cugd_tten,cugd_qvten=cugd_qvten       &
-               ,cugd_ttens=cugd_ttens,cugd_qvtens=cugd_qvtens   &
-               ,cugd_qcten=cugd_qcten,cugd_avedx=cugd_avedx     &
-               ,imomentum=imomentum,ishallow_g3=ishallow        &
-               ,ichoice=clos_choice                             &
-               ,htop=htop,hbot=hbot                             &
-               ,CU_ACT_FLAG=CU_ACT_FLAG,warm_rain=warm_rain     &
+               ,ichoice=clos_choice,ishallow_g3=ishallow        &
                ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde &
                ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme &
 !              ,IPS=ips,IPE=ipe,JPS=jps,JPE=jpe,KPS=kps,KPE=kpe &
                ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte &
                ,PERIODIC_X=periodic_x,PERIODIC_Y=periodic_y     &
               ! optionals
-#if (NMM_CORE == 1 )
+#if (NMM_CORE == 1 ) 
                ,RTHCUTEN=RTHCUTEN ,RTHFTEN=forcet               &
                ,RTHRATEN=RTHRATEN                               &
                ,RQICUTEN=RQICUTEN ,RQVFTEN=forceq               &
@@ -1194,13 +1215,12 @@ SUBROUTINE cumulus_driver(grid                                     &
                ,rqvblten=rqvblten,rthblten=rthblten             &
 #endif
                ,RQVCUTEN=RQVCUTEN,RQCCUTEN=RQCCUTEN             &
-               ,F_QV=f_qv,F_QC=f_qc,F_QR=f_qr                   &
-               ,F_QI=f_qi,F_QS=f_qs                             &
+               ,dudt_phy=rucuten, dvdt_phy=rvcuten              &
 #if ( WRF_DFI_RADAR == 1 )
                  ! Optional CAP suppress option
-              ,do_capsuppress=do_capsuppress                    &
-              ,cap_suppress_loc=cap_suppress_loc                &
-#endif                                 
+               ,do_capsuppress=do_capsuppress                   &
+               ,cap_suppress_loc=cap_suppress_loc               &
+#endif 
                                                                 )
      CASE (CAMZMSCHEME)
           IF (PRESENT(z_at_w) .AND. PRESENT(mavail)                 &
diff --git a/wrfv2_fire/phys/module_diag_afwa.F b/wrfv2_fire/phys/module_diag_afwa.F
index 6856ba4f..11fee1dd 100644
--- a/wrfv2_fire/phys/module_diag_afwa.F
+++ b/wrfv2_fire/phys/module_diag_afwa.F
@@ -1769,7 +1769,6 @@ SUBROUTINE afwa_diagnostics_driver (   grid , config_flags     &
 #ifdef DM_PARALLEL
     USE module_dm, ONLY: wrf_dm_sum_real, wrf_dm_maxval
 #endif
-    USE module_diag_afwa_hail
 
     IMPLICIT NONE
 
@@ -1835,7 +1834,7 @@ SUBROUTINE afwa_diagnostics_driver (   grid , config_flags     &
                                               ,           llws  &
                                               ,         pwater
 
-    LOGICAL :: do_buoy_calc, do_hailcast_calc
+    LOGICAL :: do_buoy_calc
     REAL :: zlfc_msl, dum1, dum2, dum3, wind_vel, wind_blend
     REAL :: prate_mm_per_hr, factor
     REAL :: u1km, v1km, ublend, vblend, u2000, v2000, us, vs
@@ -2110,13 +2109,6 @@ SUBROUTINE afwa_diagnostics_driver (   grid , config_flags     &
             grid%midrh_min_old(i,j) = grid%midrh_min(i,j) ! Save old midrh_min
             grid%midrh_min(i,j) = 999.
             grid%afwa_hail(i,j) = 0.
-            IF ( config_flags % afwa_hailcast_opt == 1 ) THEN
-              grid%afwa_hail_new1(i,j) = 0.
-              grid%afwa_hail_new2(i,j) = 0.
-              grid%afwa_hail_new3(i,j) = 0.
-              grid%afwa_hail_new4(i,j) = 0.
-              grid%afwa_hail_new5(i,j) = 0.
-            ENDIF
           ENDDO
         ENDDO
       ENDIF  ! is_after_history_dump
@@ -2127,12 +2119,6 @@ SUBROUTINE afwa_diagnostics_driver (   grid , config_flags     &
         do_buoy_calc = .false.
       ENDIF
 
-      IF ( config_flags % afwa_hailcast_opt == 1 ) THEN
-        do_hailcast_calc = .true.
-      ELSE
-        do_hailcast_calc = .false.
-      ENDIF
-
       !-->RAS
       ! We need to do some neighboring gridpoint comparisons in this next function;
       ! set these values so we don't go off the edges of the domain.  Updraft
@@ -2162,11 +2148,6 @@ SUBROUTINE afwa_diagnostics_driver (   grid , config_flags     &
                              , grid % midrh_min_old             &
                              , grid % midrh_min                 &
                              , grid % afwa_hail                 &
-                             , grid % afwa_hail_new1            &
-                             , grid % afwa_hail_new2            &
-                             , grid % afwa_hail_new3            &
-                             , grid % afwa_hail_new4            &
-                             , grid % afwa_hail_new5            &
                              , grid % afwa_cape                 &
                              , grid % afwa_cin                  &
 !                             , grid % afwa_cape_mu              &
@@ -2185,8 +2166,6 @@ SUBROUTINE afwa_diagnostics_driver (   grid , config_flags     &
                              , grid % t2                        &
                              , grid % z                         &
                              , grid % ht                        &
-                             , grid % wup_mask                  &
-                             , grid % wdur                      &
                              , grid % tornado_mask              &
                              , grid % tornado_dur               &
                              , grid % dt                        &
@@ -2203,7 +2182,6 @@ SUBROUTINE afwa_diagnostics_driver (   grid , config_flags     &
                              , dz8w                             &
                              , rh                               &
                              , do_buoy_calc                     &
-                             , do_hailcast_calc                 &
                              , ims, ime, jms, jme, kms, kme     &
                              , its, ite, jts, jte               &
                              , k_start, k_end                   &
@@ -2284,28 +2262,6 @@ SUBROUTINE afwa_diagnostics_driver (   grid , config_flags     &
         ENDDO
       ENDDO
  
-      ! Calculate the mean and standard deviation of the hail diameter
-      ! distribution over different embryo sizes
-      ! ----------------------------------------
-      IF ( config_flags % afwa_hailcast_opt == 1 ) THEN
-        DO j = jms, jme
-          DO i = ims, ime
-            !mean
-            grid%afwa_hail_newmean(i,j)=(grid%afwa_hail_new1(i,j)+&
-               grid%afwa_hail_new2(i,j) +grid%afwa_hail_new3(i,j)+&
-               grid%afwa_hail_new4(i,j) +grid%afwa_hail_new5(i,j))/5.
-            !sample standard deviation
-            grid%afwa_hail_newstd(i,j) = SQRT( ( &
-            (grid%afwa_hail_new1(i,j)-grid%afwa_hail_newmean(i,j))**2.+&
-            (grid%afwa_hail_new2(i,j)-grid%afwa_hail_newmean(i,j))**2.+&
-            (grid%afwa_hail_new3(i,j)-grid%afwa_hail_newmean(i,j))**2.+&
-            (grid%afwa_hail_new4(i,j)-grid%afwa_hail_newmean(i,j))**2.+&
-            (grid%afwa_hail_new5(i,j)-grid%afwa_hail_newmean(i,j))**2.)&
-            / 4.0)
-          ENDDO
-        ENDDO
-      ENDIF
-
       ! Calculate buoyancy parameters.
       ! ------------------------------
       IF ( config_flags % afwa_buoy_opt == 1 ) THEN
@@ -2643,11 +2599,6 @@ SUBROUTINE severe_wx_diagnostics ( wspd10max                  &
                              , midrh_min_old                    &
                              , midrh_min                        &
                              , afwa_hail                        &
-                             , afwa_hail_new1                   &
-                             , afwa_hail_new2                   &
-                             , afwa_hail_new3                   &
-                             , afwa_hail_new4                   &
-                             , afwa_hail_new5                   &
                              , cape                             &
                              , cin                              &
 !                             , cape_mu                          &
@@ -2666,8 +2617,6 @@ SUBROUTINE severe_wx_diagnostics ( wspd10max                  &
                              , t2                               &
                              , z                                &
                              , ht                               &
-                             , wup_mask                         &
-                             , wdur                             &
                              , tornado_mask                     &
                              , tornado_dur                      &
                              , dt                               &
@@ -2684,13 +2633,11 @@ SUBROUTINE severe_wx_diagnostics ( wspd10max                  &
                              , dz8w                             &
                              , rh                               &
                              , do_buoy_calc                     &
-                             , do_hailcast_calc                 &
                              , ims, ime, jms, jme, kms, kme     &
                              , its, ite, jts, jte               &
                              , k_start, k_end                   &
                              , j_start, j_end, i_start, i_end   )
 
-    USE module_diag_afwa_hail
 
     INTEGER, INTENT(IN) :: its, ite, jts, jte, k_start, k_end   &
                          , ims, ime, jms, jme, kms, kme         &
@@ -2733,15 +2680,8 @@ SUBROUTINE severe_wx_diagnostics ( wspd10max                  &
                                               ,      tcoli_max  &
                                               ,      midrh_min  &
                                               ,      afwa_hail  &
-                                              , afwa_hail_new1  &
-                                              , afwa_hail_new2  &
-                                              , afwa_hail_new3  &
-                                              , afwa_hail_new4  &
-                                              , afwa_hail_new5  &
                                               ,   afwa_tornado  &
                                               ,   grpl_flx_max  &
-                                              ,       wup_mask  &
-                                              ,           wdur  &
                                               ,   tornado_mask  &
                                               ,    tornado_dur 
 
@@ -2762,8 +2702,7 @@ SUBROUTINE severe_wx_diagnostics ( wspd10max                  &
                                               ,           lidx
 
     REAL, INTENT(IN) ::                                     dt
-    LOGICAL, INTENT(IN) ::                        do_buoy_calc  &
-                                           ,  do_hailcast_calc
+    LOGICAL, INTENT(IN) ::                        do_buoy_calc
 
     ! Local
     ! -----
@@ -2776,11 +2715,8 @@ SUBROUTINE severe_wx_diagnostics ( wspd10max                  &
     INTEGER :: nz, ostat
     REAL, DIMENSION( ims:ime, jms:jme ) ::                w_up  &
                                               ,           w_dn  &
-                                              ,  wup_mask_prev  &
-                                              ,      wdur_prev  &
                                            , tornado_mask_prev  &
                                            ,  tornado_dur_prev
-    REAL :: dhail1,dhail2,dhail3,dhail4,dhail5
     REAL :: time_factor, time_factor_prev
     LOGICAL :: is_target_level
 
@@ -2858,107 +2794,6 @@ SUBROUTINE severe_wx_diagnostics ( wspd10max                  &
       ENDDO
     ENDDO
 
-    ! Hailcast calculation.  Please note: this is VERY
-    ! expensive, and needs to be optimized in the future to
-    ! reduce its expense. Currently, on domains with plenty
-    ! of convection, we have seen timesteps increase upwards
-    ! of 300%.  Also, because it is not calculated at every
-    ! grid point, only where there is an updraft, this can 
-    ! lead to very unpredictable run time behavior.  Until
-    ! we are able to speed it up significantly (either by 
-    ! modifications to the algorithm, or by calling it less
-    ! frequently) we are not running this in production at
-    ! AFWA and are turning it off by default.  To run hailcast
-    ! please use afwa_hailcast_opt=1 in the namelist. GAC2014
-    ! --------------------------------------------------------
-    IF ( do_hailcast_calc ) THEN
-
-      ! --> RAS
-      ! Make a copy of the updraft duration, mask variables
-      ! ---------------------------------------------------
-      wdur_prev(:,:) = wdur(:,:)
-      wup_mask_prev(:,:) = wup_mask(:,:)
-
-      ! Determine updraft mask (where updraft greater than some threshold)
-      ! ---------------------------------------------------
-      DO j = jts, jte
-        DO i = its, ite
-          wup_mask(i,j) = 0
-          wdur(i,j) = 0
-
-          DO k = k_start, k_end
-            IF ( w_2(i,k,j) .ge. 10. ) THEN
-                wup_mask(i,j) = 1
-            ENDIF
-          ENDDO
-        ENDDO
-      ENDDO
-
-      ! Determine updraft duration; make sure not to call point outside the domain
-      ! ---------------------------------------------------
-      DO j = j_start, j_end
-        DO i = i_start, i_end
-
-          ! Determine updraft duration using updraft masks
-          ! ---------------------------------------------------
-          IF ( (wup_mask(i,j).eq.1) .OR.                 &
-             (MAXVAL(wup_mask_prev(i-1:i+1,j-1:j+1)).eq.1) ) THEN
-             wdur(i,j) = MAXVAL(wdur_prev(i-1:i+1,j-1:j+1)) + dt
-          ENDIF
-        ENDDO
-      ENDDO
-
-
-      ! Hail diameter in millimeters (HAILCAST)
-      ! ---------------------------------------------------
-      nz = k_end - k_start
-      DO j = jts, jte
-        DO i = its, ite
-
-          ! Only call hailstone driver if updraft has been
-          ! around longer than 15 min
-          ! ----------------------------------------------
-          IF (wdur(i,j) .gt. 900) THEN
-            CALL hailstone_driver ( t_phy(i,kms:kme,j), &
-                                z(i,kms:kme,j),     &
-                                ht(i,       j),     &
-                                p(i,kms:kme,j),     &
-                                rho(i,kms:kme,j),   &
-                                qv(i,kms:kme,j),    &
-                                qi(i,kms:kme,j),    &
-                                qc(i,kms:kme,j),    &
-                                qr(i,kms:kme,j),    &
-                                qs(i,kms:kme,j),    &
-                                qg(i,kms:kme,j),    &
-                                ng(i,kms:kme,j),    &
-                                w_2(i,kms:kme,j),   &
-                                wdur(i,j),          &
-                                nz,                 &
-                                dhail1, dhail2,     &
-                                dhail3, dhail4,     &
-                                dhail5              )
-            IF (dhail1 .gt. afwa_hail_new1(i,j)) THEN
-                afwa_hail_new1(i,j) = dhail1
-            ENDIF
-            IF (dhail2 .gt. afwa_hail_new2(i,j)) THEN
-                afwa_hail_new2(i,j) = dhail2
-            ENDIF
-            IF (dhail3 .gt. afwa_hail_new3(i,j)) THEN
-                afwa_hail_new3(i,j) = dhail3
-            ENDIF
-            IF (dhail4 .gt. afwa_hail_new4(i,j)) THEN
-                afwa_hail_new4(i,j) = dhail4
-            ENDIF
-            IF (dhail5 .gt. afwa_hail_new5(i,j)) THEN
-                afwa_hail_new5(i,j) = dhail5
-            ENDIF
-          ENDIF
-        ENDDO
-      ENDDO
-      ! <-- RAS
-
-    ENDIF  !~ End if do_hailcast_calc
-
     ! Lightning (total column-integrated cloud ice)
     ! Note this formula is basically stolen from the VIL calculation.
     ! ---------------------------------------------------------------
diff --git a/wrfv2_fire/phys/module_diag_afwa_hail.F b/wrfv2_fire/phys/module_diag_afwa_hail.F
deleted file mode 100644
index b67688e4..00000000
--- a/wrfv2_fire/phys/module_diag_afwa_hail.F
+++ /dev/null
@@ -1,852 +0,0 @@
-MODULE module_diag_afwa_hail
-
-CONTAINS
-
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-!!!!
-!!!! Hailstone driver, adapted from hailstone subroutine in HAILCAST
-!!!!  Driver designed to be called from the severe_wx_diagnostics 
-!!!!   subroutine within module_afwa_dignostics.F in WRF.
-!!!!  Inputs:
-!!!!    1-d (nz)
-!!!!     TCA          temperature (K) 
-!!!!     h1d          height above sea level (m) 
-!!!!     PA           total pressure (Pa)
-!!!!     rho1d        density (kg/m3)
-!!!!     RA           vapor mixing ratio (kg/kg)
-!!!!     qi1d         cloud ice mixing ratio (kg/kg)
-!!!!     qc1d         cloud water mixing ratio (kg/kg)
-!!!!     qr1d         rain water mixing ratio (kg/kg)
-!!!!     qg1d         graupel mixing ratio (kg/kg)
-!!!!     qs1d         snow mixing ratio (kg/kg)
-!!!!     VUU          updraft speed at each level (m/s)
-!!!!    Float
-!!!!     ht         terrain height (m)
-!!!!     wdur       duration of any updraft > 10 m/s within 1 surrounding 
-!!!!                 gridpoint 
-!!!!     nz         number of vertical levels
-!!!!    Integer
-!!!!     graupel_opt   microphysics scheme flag (includes afwa_hail_opt info)
-!!!!
-!!!!  Output:
-!!!!     dhail      hail diameter in mm 
-!!!!                1st-5th rank-ordered hail diameters returned
-!!!!
-!!!!  13 Aug 2013 .................................Becky Selin AER/AFWA
-!!!!     adapted from hailstone subroutine in SPC's HAILCAST
-!!!!  18 Mar 2014 .................................Becky Selin AER/AFWA
-!!!!     added variable rime layer density, per Ziegler et al. (1983)
-!!!!     marked by comments RAS13.5.1
-!!!!  4 Jun 2014 ..................................Becky Selin AER/AFWA
-!!!!     removed initial embryo size dependency on microphysic scheme
-!!!!     marked by comments RAS13.7
-!!!!  5 Jun 2014 ..................................Becky Selin AER/AFWA
-!!!!     used smaller initial embryo sizes
-!!!!     marked by comments RAS13.7.2
-!!!!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  SUBROUTINE hailstone_driver ( TCA, h1d, ht, PA, rho1d,&
-                                RA, qi1d,qc1d,qr1d,qs1d,qg1d,ng1d,  &
-                                VUU, wdur,                          &
-                                nz,dhail1,dhail2,dhail3,dhail4,     &
-                                dhail5                             )
-      
-    IMPLICIT NONE
-    INTEGER, INTENT(IN) :: nz
-  
-    REAL, DIMENSION( nz ),             &
-         INTENT(IN   ) ::                                  TCA  & ! temperature (K)
-                                              ,          rho1d  &
-                                              ,            h1d  &
-                                              ,             PA  & ! pressure (Pa)
-                                              ,             RA  & ! vapor mixing ratio (kg/kg)
-                                              ,            VUU  & ! updraft speed (m/s)
-                                              , qi1d,qc1d,qr1d  &
-                                              , qs1d,qg1d,ng1d  
-
-    REAL, INTENT(IN   ) ::                                  ht  &
-                                              ,           wdur 
-
-    !Output: 1st-5th rank-ordered hail diameters returned
-    REAL, INTENT(INOUT) ::                              dhail1 & ! hail diameter (mm);
-                                              ,         dhail2 &
-                                              ,         dhail3 &
-                                              ,         dhail4 &
-                                              ,         dhail5
-    !Local variables
-    REAL ZBAS, TBAS, WBASP     ! height, temp, pressure of cloud base
-    REAL RBAS                  ! mix ratio of cloud base
-    REAL cwitot                ! total cloud water, ice mix ratio
-    INTEGER KBAS               ! k of cloud base
-    REAL ZFZL, TFZL, WFZLP     ! height, temp, pressure of embryo start point
-    REAL RFZL                  ! mix ratio of embryo start point
-    INTEGER KFZL               ! k of embryo start point
-    INTEGER nofroze            ! keeps track if hailstone has ever been frozen
-    INTEGER ITIME              ! updraft duration (sec)
-    REAL TAU                   ! upper time limit of simulation (sec)
-    REAL g                     ! gravity (m/s)
-    REAL r_d                   ! constant
-    !hailstone parameters
-    REAL*8 DD, D               ! hail diameter (m)
-    REAL VT                    ! terminal velocity (m/s)
-    REAL V                     ! actual stone velocity (m/s)
-    REAL TS                    ! hailstone temperature (K)
-    REAL FW                    ! fraction of stone that is liquid
-    REAL DENSE                 ! hailstone density (kg/m3)
-    INTEGER ITYPE              ! wet (2) or dry (1) growth regime
-    !1-d column arrays of updraft parameters
-    REAL, DIMENSION( nz ) ::  &
-      RIA, &                   ! frozen content mix ratio (kg/kg)
-      RWA                      ! liquid content mix ratio (kg/kg)
-    !in-cloud updraft parameters at location of hailstone
-    REAL P                     ! in-cloud pressure (Pa)
-    REAL RS                    ! in-cloud saturation mixing ratio 
-    REAL RI, RW                ! ice, liquid water mix. ratio (kg/kg)
-    REAL XI, XW                ! ice, liquid water conc. (kg/m3 air)
-    REAL PC                    ! in-cloud fraction of frozen water
-    REAL TC                    ! in-cloud temperature (K)
-    REAL VU                    ! in-cloud updraft speed (m/s)
-    REAL DENSA                 ! in-cloud updraft density (kg/m3)
-    REAL Z                     ! height of hailstone (m)
-    REAL DELRW                 ! diff in sat vap. dens. between hail and air (kg/m3)
-    REAL d02,d05,d10,d15,d20   ! 5 initial embryo sizes
-    REAL, DIMENSION(5) :: dhails     !hail diameters with the 1st-15th %ile of graupel dsd 
-                                     !used as initial hail embryo size
-    !mean sub-cloud layer variables
-    REAL TLAYER,RLAYER,PLAYER  ! mean sub-cloud temp, mix ratio, pres
-    REAL TSUM,RSUM,PSUM        ! sub-cloud layer T, R, P sums
-    REAL LDEPTH                ! layer depth
-    !internal function variables
-    REAL GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DI
-    REAL dum
-      
-    REAL sec, secdel           ! time step, increment in seconds
-    INTEGER i, j, k, IFOUT, ind(1)
-    CHARACTER*256 :: message
-
-    ! Increasing internal time step from 1 to 5 seconds does not appear
-    ! to hinder the final output but does cut down on the processing
-    ! load by quite a bit according to RAS. -GAC 20150311
-    !secdel = 1.0 !0.2
-    secdel = 5.0
-    g=9.81
-    r_d = 287.
-            
-!   Upper limit of simulation in seconds
-    TAU = 3600.
-      
-!   Initialize diameters to 0.
-    DO i=1,5
-       dhails(i) = 0.
-    ENDDO
-    ITIME = INT(wdur)
- 
-    !Determine where graupel is available above the freezing level.  
-    !This is where we'll start our hail embryo on its journey.  
-    !Also find the cloud base for end-of-algorithm purposes.
-    KBAS=nz
-    KFZL=nz
-    DO k=1,nz
-         cwitot = qi1d(k) + qc1d(k)
-         RIA(k) = qi1d(k) + qs1d(k) + qg1d(k)
-         RWA(k) = qc1d(k) + qr1d(k)
-         IF ((RIA(k) .ge. 0.0001) .and. (TCA(k).lt.273.15) .and. &
-             (k .lt. KFZL)) THEN
-            KFZL = k
-         ENDIF
-         IF ((cwitot .ge. 1.E-12) .and. (k .lt. KBAS)) THEN
-            KBAS = k
-         ENDIF
-    ENDDO
-    !QC - our embryo can't start below the cloud base.
-    IF (KFZL .lt. KBAS) THEN
-       KFZL = KBAS
-    ENDIF
-
-    !Pull heights, etc. of these levels out of 1-d arrays.
-    ZFZL = h1d(KFZL)
-    TFZL = TCA(KFZL)
-    WFZLP = PA(KFZL)
-    RFZL = RA(KFZL)
-    ZBAS = h1d(KBAS)
-    TBAS = TCA(KBAS)
-    WBASP = PA(KBAS)
-    RBAS = RA(KBAS)
-
-
-    !-->RAS13.7
-    !!!!!!!!!!!!!!!! 0. INITIAL EMBRYO SIZE  !!!!!!!!!!!!!!!!!!!!!
-    !!!      SET CONSTANT RANGE OF INITIAL EMBRYO SIZES        !!!
-    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-    d02 = 1.E-5  !RAS13.7.2 smaller init embryo sizes
-    d05 = 2.E-5  !RAS13.7.2 smaller init embryo sizes
-    d10 = 3.E-5  !RAS13.7.2 smaller init embryo sizes
-    d15 = 4.E-5  !RAS13.7.2 smaller init embryo sizes
-    d20 = 5.E-5  !RAS13.7.2 smaller init embryo sizes
-    !<--RAS13.7
-
-    !Run each initial embryo size perturbation
-    DO i=1,5
-      SELECT CASE (i)   
-        CASE (1)
-        !Initial hail embryo diameter in m, at cloud base
-        DD = d02
-        CASE (2)
-        DD = d05
-        CASE (3)  
-        DD = d10
-        CASE (4)
-        DD = d15
-        CASE (5)
-        DD = d20
-      END SELECT
-
-      !Begin hail simulation time (seconds)
-      sec = 60
- 
-      !Set initial values for parameters at freezing level
-      P = WFZLP
-      RS = RFZL
-      TC = TFZL
-      VU = VUU(KFZL)  
-      Z = ZFZL - ht
-      LDEPTH = Z
-      DENSA = rho1d(KFZL)
-
-      !Set initial hailstone parameters
-      nofroze=1 !Set test for embryo: 0 for never been frozen; 1 frozen
-      TS = TC
-      D = DD   !hailstone diameter in m
-      FW = 0.0
-      DENSE = 500.  !kg/m3  !RAS13.5.1
-
-      !Start time loop.
-      DO WHILE (sec .lt. TAU)
-         sec = sec + secdel
-         
-         !!!!!!!!!!!!!!!!!!  1. CALCULATE PARAMETERS  !!!!!!!!!!!!!!!!!
-         !!!              CALCULATE UPDRAFT PROPERTIES              !!!
-         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-         !Intepolate vertical velocity to our new pressure level
-         CALL INTERP(VUU,VU,P,IFOUT,PA,nz)
-         
-         !Outside pressure levels?  If so, exit loop
-         IF (IFOUT.EQ.1) GOTO 100
-         
-         !If simulation time past updraft duration, set updraft
-         ! speed to zero
-         IF (sec .gt. ITIME) VU = 0
-         
-         !Calculate terminal velocity of the hailstone 
-         ! (use previous values)
-         CALL TERMINL(DENSA,DENSE,D,VT,TC)
-         
-         !Actual velocity of hailstone (upwards positive)
-         V = VU - VT
-         
-         !Use hydrostatic eq'n to calc height of next level
-         P = P - DENSA*g*V*secdel
-         Z = Z + V*secdel
-
-         !Interpolate cloud temp, qvapor at new p-level
-         CALL INTERP(TCA,TC,P,IFOUT,PA,nz)
-         CALL INTERP(RA,RS,P,IFOUT,PA,nz)
-         
-         !New density of in-cloud air
-         DENSA=P/(r_d*(1.+0.609*RS/(1.+RS))*TC)
-         
-         !Interpolate liquid, frozen water mix ratio at new level
-         CALL INTERP(RIA,RI,P,IFOUT,PA,nz)
-         CALL INTERP(RWA,RW,P,IFOUT,PA,nz)
-         XI = RI * DENSA
-         XW = RW * DENSA
-         IF( (XW+XI).GT.0) THEN
-           PC = XI / (XW+XI)
-         ELSE
-           PC = 1.
-         ENDIF
-         !IF(TC.GT.253.15)PC=0.
-         
-         !!!!!!!!!!!!!!!!!!  2. TEST FOR WET/DRY GROWTH !!!!!!!!!!!!!!!
-         !!!  WET GROWTH - STONE'S SFC >0; DRY GROWTH SFC < 0       !!!
-         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-         !FREEZE THE HAIL EMBRYO AT -8 DEGC, define emb
-         IF (TS.GE.264.15 .AND. TC.GE.264.15 .AND. NOFROZE.EQ.0) THEN
-           IF (TC.LE.265.15) THEN !!! DRY GROWTH 
-             FW=0.  !set fraction of water in stone to 0.
-             TS=TC 
-             ITYPE=1 
-             NOFROZE=1 
-           ELSE  !!! WET GROWTH 
-             FW=1.               
-             TS=TC 
-             ITYPE=2 
-             NOFROZE=0 
-           ENDIF 
-         ELSE
-           IF (TS.LT.273.155) THEN !!! DRY GROWTH 
-             FW=0.
-             ITYPE=1
-           ELSE !!! WET GROWTH
-             TS=273.155
-             ITYPE=2
-           ENDIF
-         ENDIF
-
-        ! DENSITY OF HAILSTONE - DEPENDS ON FW
-        ! ONLY WATER=1 GM/L=1000KG/M3; ONLY ICE  =0.9 GM/L 
-        !DENSE=(FW*0.1+0.9) * 1000.  !KG/M3 !RAS13.5.1-density calc inside MASSAGR
- 
-        ! SATURATION VAPOUR DENSITY DIFFERENCE BETWTEEN STONE AND CLOUD
-        CALL VAPORCLOSE(DELRW,PC,TS,TC,ITYPE)
-      
-        
-        !!!!!!!!!!!!!!!!!!  3. STONE'S MASS GROWTH !!!!!!!!!!!!!!!!!!!!
-        CALL MASSAGR(D,GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DI, &
-                 TC,TS,P,DENSE,FW,VT,XW,XI,secdel,ITYPE) !RAS13.5.1
-         
-
-        !!!!!!!!!!!!!!!!!!  4. HEAT BUDGET OF HAILSTONE !!!!!!!!!!!!!!!
-        CALL HEATBUD(TS,FW,TC,VT,DELRW,D,DENSA,GM1,DGM,DGMW,  &
-                     DGMI,GMW,GMI,DI,secdel,ITYPE,P)
-
- 
-        !!!!! 5. TEST DIAMETER OF STONE AND HEIGHT ABOVE GROUND !!!!!!!
-        !!!  TEST IF DIAMETER OF STONE IS GREATER THAN 9 MM LIMIT, IF SO  
-        !!!  BREAK UP 
-        IF(D.GT.0.009) THEN   
-           CALL BREAKUP(DENSE,D,GM,FW)
-        ENDIF
-        
-        !!! Has stone reached below cloud base?
-        !IF (Z .LE. 0) GOTO 200
-        IF (Z .LE. ZBAS) GOTO 200
-        
-      ENDDO  !end cloud lifetime loop
-
-100   CONTINUE !outside pressure levels in model
-200   CONTINUE !stone reached surface
-
-      !!!!!!!!!!!!!!!!!! 6. MELT STONE BELOW CLOUD !!!!!!!!!!!!!!!!!!!!
-      !Did the stone shoot out the top of the storm? 
-      !Then let's assume it's lost in the murky "outside storm" world.
-      IF (P.lt.PA(nz)) THEN
-         !print *, '  shot off top!'
-         D=0.0
-      !Is the stone entirely water? Then set D=0 and exit.
-      ELSE IF(ABS(FW - 1.0).LT.0.001) THEN
-         !print *, '  stone entirely water!'
-         D=0.0
-      ELSE IF (Z.GT.0) THEN
-         !If still frozen, then use melt routine to melt below cloud
-         ! based on mean below-cloud conditions.
-        
-         !Calculate mean sub-cloud layer conditions
-         TSUM = 0.
-         RSUM = 0.
-         PSUM = 0.
-         DO k=1,KBAS
-            TSUM = TSUM + TCA(k)
-            PSUM = PSUM + PA(k)
-            RSUM = RSUM + RA(k)
-         ENDDO
-         TLAYER = TSUM / KBAS
-         PLAYER = PSUM / KBAS
-         RLAYER = RSUM / KBAS
-           
-         CALL MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT)
-      ENDIF !end check for melting call
-      
-      !assign hail size in mm for output
-      dhails(i) = D * 1000
-
-    ENDDO  !end embryo size loop
-  
-    !! Size-sort hail diameters for function output !!
-    DO j=1,4
-      DO k=j+1,5
-         IF (dhails(j).lt.dhails(k)) THEN
-            dum = dhails(j)
-            dhails(j) = dhails(k)
-            dhails(k) = dum
-         ENDIF
-      ENDDO
-    ENDDO
-    
-    dhail1 = dhails(1)
-    dhail2 = dhails(2)
-    dhail3 = dhails(3)
-    dhail4 = dhails(4)
-    dhail5 = dhails(5)
-  
-  END SUBROUTINE hailstone_driver
-
-
-
-  SUBROUTINE INTERP(AA,A,P,IFOUT,PA,ITEL)
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  !!!!
-  !!!! INTERP: to linearly interpolate values of A at level P
-  !!!!   between two levels of AA (at levels PA)
-  !!!!
-  !!!! INPUT: AA    1D array of variable
-  !!!!        PA    1D array of pressure
-  !!!!        P     new pressure level we want to calculate A at
-  !!!!        IFOUT set to 0 if P outside range of PA
-  !!!!        ITEL  number of vertical levels
-  !!!! OUTPUT: A    variable at pressure level P
-  !!!!
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      IMPLICIT NONE
-      
-      REAL A, P
-      REAL, DIMENSION( ITEL) :: AA, PA
-      INTEGER ITEL, IFOUT
-      !local variables
-      INTEGER I
-      REAL PDIFF, VDIFF, RDIFF, VERH, ADIFF
-      
-      IFOUT=1
-      
-      DO I=1,ITEL-1
-        IF (P.LE.PA(I) .AND. P.GT.PA(I+1)) THEN
-          !Calculate ratio between vdiff and pdiff
-          PDIFF = PA(I)-PA(I+1)
-          VDIFF = PA(I)-P
-          VERH = VDIFF/PDIFF     
-          
-          !Calculate the difference between the 2 A values
-          RDIFF = AA(I+1) - AA(I)
-          
-          !Calculate new value
-          A = AA(I) + RDIFF*VERH
-          
-          !End loop
-          IFOUT=0
-          EXIT
-        ENDIF
-      ENDDO
-      
-  END SUBROUTINE INTERP
-      
-
-  SUBROUTINE TERMINL(DENSA,DENSE,D,VT,TC)
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  !!!!
-  !!!! INTERP: Calculate terminal velocity of the hailstone
-  !!!!
-  !!!! INPUT: DENSA  density of updraft air (kg/m3)
-  !!!!        DENSE  density of hailstone
-  !!!!        D      diameter of hailstone (m)
-  !!!!        TC     updraft temperature (K)
-  !!!! OUTPUT:VT     hailstone terminal velocity (m/s)
-  !!!!
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      IMPLICIT NONE
-      
-      REAL*8 D
-      REAL DENSA, DENSE, TC, VT
-      REAL GMASS, GX, RE, W, Y
-      REAL, PARAMETER :: PI = 3.141592654, G = 9.78956
-      REAL ANU
-      
-      !Mass of stone in kg
-      GMASS = (DENSE * PI * (D**3.)) / 6.
-      
-      !Dynamic viscosity
-      ANU = (0.00001718)*(273.16+120.)/(TC+120.)*(TC/273.16)**(1.5)
-      
-      !CALC THE BEST NUMBER, X AND REYNOLDS NUMBER, RE 
-      GX=(8.0*GMASS*G*DENSA)/(PI*(ANU*ANU))
-      RE=(GX/0.6)**0.5
-
-      !SELECT APPROPRIATE EQUATIONS FOR TERMINAL VELOCITY DEPENDING ON 
-      !THE BEST NUMBER
-      IF (GX.LT.550) THEN
-        W=LOG10(GX)
-        Y= -1.7095 + 1.33438*W - 0.11591*(W**2.0)      
-        RE=10**Y
-        VT=ANU*RE/(D*DENSA)
-      ELSE IF (GX.GE.550.AND.GX.LT.1800) THEN
-        W=LOG10(GX)
-        Y= -1.81391 + 1.34671*W - 0.12427*(W**2.0) + 0.0063*(W**3.0)
-        RE=10**Y
-        VT=ANU*RE/(D*DENSA)
-      ELSE IF (GX.GE.1800.AND.GX.LT.3.45E08) THEN
-        RE=0.4487*(GX**0.5536)
-        VT=ANU*RE/(D*DENSA)
-      ELSE 
-        RE=(GX/0.6)**0.5
-        VT=ANU*RE/(D*DENSA)
-      ENDIF
-      
-  END SUBROUTINE TERMINL   
-   
-   
-  SUBROUTINE VAPORCLOSE(DELRW,PC,TS,TC,ITYPE)
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  !!!  VAPORCLOSE: CALC THE DIFFERENCE IN SATURATION VAPOUR DENSITY 
-  !!!  BETWEEN THAT OVER THE HAILSTONE'S SURFACE AND THE IN-CLOUD 
-  !!!  AIR, DEPENDS ON THE WATER/ICE RATIO OF THE UPDRAFT, 
-  !!!  AND IF THE STONE IS IN WET OR DRY GROWTH REGIME
-  !!!
-  !!!  INPUT:  PC    fraction of updraft water that is frozen
-  !!!          TS    temperature of hailstone (K)
-  !!!          TC    temperature of updraft air (K)
-  !!!          ITYPE wet (2) or dry (1) growth regime
-  !!!  OUTPUT: DELRW difference in sat vap. dens. between hail and air
-  !!!          (kg/m3)
-  !!!
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-      IMPLICIT NONE
-      REAL DELRW, PC, TS, TC
-      INTEGER ITYPE
-      !local variables
-      REAL RV, ALV, ALS, RATIO
-      DATA RV/461.48/,ALV/2500000./,ALS/2836050./ 
-      REAL ESAT, RHOKOR, ESATW, RHOOMGW, ESATI, RHOOMGI, RHOOMG
-
-      !!!  FOR HAILSTONE:  FIRST TEST IF STONE IS IN WET OR DRY GROWTH
-      RATIO = 1./273.16
-      IF(ITYPE.EQ.2) THEN !!WET GROWTH
-        ESAT=611.*EXP(ALV/RV*(RATIO-1./TS))
-      ELSE  !!DRY GROWTH
-        ESAT=611.*EXP(ALS/RV*(RATIO-1./TS))
-      ENDIF
-      RHOKOR=ESAT/(RV*TS)
-      
-      !!!  NOW FOR THE AMBIENT/IN-CLOUD CONDITIONS 
-      ESATW=611.*EXP(ALV/RV*(RATIO-1./TC))
-      RHOOMGW=ESATW/(RV*TC)
-      ESATI=611.*EXP(ALS/RV*(RATIO-1./TC))
-      RHOOMGI=ESATI/(RV*TC)
-      RHOOMG=PC*(RHOOMGI-RHOOMGW)+RHOOMGW
-
-      !!!  CALC THE DIFFERENCE(KG/M3): <0 FOR CONDENSATION, 
-      !!!  >0 FOR EVAPORATION
-      DELRW=(RHOKOR-RHOOMG) 
-  END SUBROUTINE VAPORCLOSE
-     
-      
-
-  SUBROUTINE MASSAGR(D,GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DI,      &
-                 TC,TS,P,DENSE,FW,VT,XW,XI,SEKDEL,ITYPE)  !RAS13.5.1
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  !!! CALC THE STONE'S INCREASE IN MASS 
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-            
-      IMPLICIT NONE
-      REAL*8 D
-      REAL GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DI,  &
-                 TC,TS,P,DENSE,FW,VT,XW,XI,SEKDEL
-      INTEGER ITYPE !RAS13.5.1
-      !local variables
-      REAL PI, D0, GMW2, GMI2, EW, EI
-      !-->RAS13.5.1
-      REAL DENSEL !DENSITY OF NEW LAYER (KG M-3)
-      REAL DC !MEAN CLOUD DROPLET DIAMETER (MICRONS, 1E-6M)
-      REAL VOLL, VOLT !VOLUME OF NEW LAYER, TOTAL (M3)
-      !<--RAS13.5.1
-      PI=3.141592654
-
-      !!!  CALCULATE THE DIFFUSIVITY DI (m2/s)
-      D0=0.226*1.E-4  ! change to m2/s, not cm2/s
-      DI=D0*(TC/273.16)**1.81*(100000./P)
-  
-      !!!  COLLECTION EFFICIENCY FOR WATER AND ICE 
-      EW=1.0
-      
-      !!!   IF TS WARMER THAN -5C THEN ACCRETE ALL THE ICE (EI=1.0) 
-      !!!   OTHERWISE EI=0.21      
-      IF(TS.GE.268.15)THEN
-        EI=1.00
-      ELSE
-        EI=0.21
-      ENDIF
-
-      !!!  CALC HAILSTONE'S MASS (GM), MASS OF WATER (GMW) AND THE  
-      !!!  MASS OF ICE IN THE STONE (GMI)
-      GM=PI/6.*(D**3.)*DENSE
-      GMW=FW*GM
-      GMI=GM-GMW
-
-      !!!  STORE THE MASS
-      GM1=GM
-
-      !-->RAS13.5.1
-      !!!!!! ORIGINAL HAILCAST MASS GROWTH CALCULATIONS !!!!!!!!!!!!!!!
-      !!!!!!  STONE'S MASS GROWTH 
-      !!!!!!  CALCULATE THE NEW DIAMETER
-      !!!D=D+SEKDEL*0.5*VT/DENSE*(XW*EW+XI*EI)
-      !!!!!!  CALCULATE THE INCREASE IN MASS DUE INTERCEPTED CLD WATER
-      !!!GMW2=GMW+SEKDEL*(PI/4.*D**2.*VT*XW*EW)
-      !!!DGMW=GMW2-GMW 
-      !!!GMW=GMW2
-      !!!!!!  CALCULATE THE INCREASE IN MASS DUE INTERCEPTED CLOUD ICE
-      !!!GMI2=GMI+SEKDEL*(PI/4.*D**2.*VT*XI*EI)
-      !!!DGMI=GMI2-GMI 
-      !!!GMI=GMI2
-      !!!!!!  CALCULATE THE TOTAL MASS CHANGE 
-      !!!DGM=DGMW+DGMI 
-      !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      
-      !!! NEW MASS GROWTH CALCULATIONS WITH VARIABLE RIME 
-      !!! LAYER DENSITY BASED ON ZIEGLER ET AL. (1983)
-      
-      !!! CALCULATE INCREASE IN MASS DUE INTERCEPTED CLD WATER, USE
-      !!! ORIGINAL DIAMETER
-      GMW2=GMW+SEKDEL*(PI/4.*D**2.*VT*XW*EW)
-      DGMW=GMW2-GMW 
-      GMW=GMW2
-      !!!  CALCULATE THE INCREASE IN MASS DUE INTERCEPTED CLOUD ICE
-      GMI2=GMI+SEKDEL*(PI/4.*D**2.*VT*XI*EI)
-      DGMI=GMI2-GMI 
-      GMI=GMI2
-      !!!  CALCULATE THE TOTAL MASS CHANGE 
-      DGM=DGMW+DGMI 
-      !!! CALCULATE DENSITY OF NEW LAYER, DEPENDS ON FW AND ITYPE
-      IF (ITYPE.EQ.1) THEN !DRY GROWTH
-          !MEAN CLOUD DROPLET RADIUS, ASSUME CLOUD DROPLET CONC OF 3E8 M-3 (300 CM-3)
-          DC = (0.74*XW / (PI*1000.*3.E8))**0.33333333 * 1.E6 !MICRONS
-          !RIME LAYER DENSITY, MACKLIN FORM
-          DENSEL = 0.11*(DC*VT / (273.15-TS))**0.76 !G CM-3
-          DENSEL = DENSEL * 1000. !KG M-3
-          !BOUND POSSIBLE DENSITIES
-          IF (DENSEL.LT.100) DENSEL=100
-          IF (DENSEL.GT.900) DENSEL=900
-      ELSE !WET GROWTH
-          DENSEL = 900.  !KG M-3
-      ENDIF
-      !!!VOLUME OF NEW LAYER
-      VOLL = DGM / DENSEL
-      !!!NEW TOTAL VOLUME, DENSITY, DIAMETER
-      VOLT = VOLL + GM/DENSE
-      !VOLT = VOLL + (0.16666667*3.14159*D**3.)
-      DENSE = (GM+DGM) / VOLT
-      D=D+SEKDEL*0.5*VT/DENSE*(XW*EW+XI*EI)      
-      !<--RAS13.5.1
-
-  END SUBROUTINE MASSAGR
-
-
-
-  SUBROUTINE HEATBUD(TS,FW,TC,VT,DELRW,D,DENSA,GM1,DGM,DGMW,       &
-                     DGMI,GMW,GMI,DI,SEKDEL,ITYPE,P)
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  !!! CALCULATE HAILSTONE'S HEAT BUDGET 
-  !!! See Rasmussen and Heymsfield 1987; JAS
-  !!! The commented lines in here were not using SI units
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      
-      IMPLICIT NONE
-      REAL*8 D
-      REAL TS,FW,TC,VT,DELRW,DENSA,GM1,DGM,DGMW,  &
-                    DGMI,GMW,GMI,DI,SEKDEL,P
-      INTEGER ITYPE
-      
-      REAL RV, RD, G, PI, ALF, ALV, ALS, CI, CW, AK, ANU
-      REAL H, E, RE, AH, AE, TCC, TSC
-      DATA RV/461.48/,RD/287.04/,G/9.78956/
-      DATA PI/3.141592654/
-      DATA ALF/3.50E5/ !latent heat of freezing J/kg /79.7/
-      DATA ALV/2.5E6/  !latent heat of vaporization J/kg /597.3/
-      DATA ALS/2.85E6/ !latent heat of sublimation J/kg /677.0/
-      DATA CI/2093/    !J/(kg*K); 0.5 cal/(g*K)
-      DATA CW/4187/    !J/(kg*K); 1. cal/(g*K)
-      
-      !!!  CALCULATE THE CONSTANTS 
-      !AK=(5.8+0.0184*(TC-273.155))*1.E-5  !thermal conductivity - cal/(cm*sec*K)
-      AK=(5.8+0.0184*(TC-273.155))*1.E-3*4.187  !thermal conductivity - J/(m*sec*K)
-      !dynamic viscosity kg/(m*s)
-      ANU=1.717E-5*(393.0/(TC+120.0))*(TC/273.155)**1.5
-
-      !!!  CALCULATE THE REYNOLDS NUMBER - unitless
-      RE=D*VT*DENSA/ANU
-      !H=(0.71)**(0.333333333)*(RE**0.50) !ventilation coefficient heat (fh)
-      !E=(0.60)**(0.333333333)*(RE**0.50) !ventilation coefficient vapor (fv)
-      H=(1.46E-5/DI)**(0.333333333)*(RE**0.50) !ventilation coefficient heat (fh)
-      E=(1.46E-5/AK)**(0.333333333)*(RE**0.50) !ventilation coefficient vapor (fv)
-      !print *, 'HEATBUD function: '
-      !print *, '  ITYPE: ', ITYPE
-
-      !!!   SELECT APPROPRIATE VALUES OF AH AND AE ACCORDING TO RE
-      IF(RE.LT.6000.0)THEN
-         AH=0.78+0.308*H
-         AE=0.78+0.308*E
-      ELSEIF(RE.GE.6000.0.AND.RE.LT.20000.0)THEN
-         AH=0.76*H
-         AE=0.76*E
-      ELSEIF(RE.GE.20000.0) THEN
-         AH=(0.57+9.0E-6*RE)*H
-         AE=(0.57+9.0E-6*RE)*E
-      ENDIF
-
-      !!!  FOR DRY GROWTH FW=0, CALCULATE NEW TS, ITIPE=1 
-      !!!  FOR WET GROWTH TS=0, CALCULATE NEW FW, ITIPE=2
-
-      TCC = TC - 273.15
-      TSC = TS - 273.15
-      IF(ITYPE.EQ.1) THEN
-      !!!  DRY GROWTH; CALC NEW TEMP OF THE STONE 
-         !TS=TS-TS*DGM/GM1+SEKDEL/(GM1*CI)*                &
-         !   (2.*PI*D*(AH*AK*(TC-TS)-AE*ALS*DI*DELRW)+     &
-         !   DGMW/SEKDEL*(ALF+CW*TC)+DGMI/SEKDEL*CI*TC)
-         TS=TS-(TS-273.15)*DGM/GM1+SEKDEL/(GM1*CI)*                &
-            (2.*PI*D*(AH*AK*(TC-TS)-AE*ALS*DI*DELRW)+     &
-            DGMW/SEKDEL*(ALF+CW*TCC)+DGMI/SEKDEL*CI*TCC)
-      ELSE IF (ITYPE.EQ.2) THEN
-      !!!  WET GROWTH; CALC NEW FW
-         !FW=FW-FW*DGM/GM1+SEKDEL/(GM1*ALF)*               &
-         !   (PI*D*(AH*AK*TC-AE*ALV*DI*DELRW)+          &
-         !   DGMW/SEKDEL*(ALF+CW*TC)+DGMI/SEKDEL*CI*TC)
-         FW=FW-FW*DGM/GM1+SEKDEL/(GM1*ALF)*               &
-            (2.*PI*D*(AH*AK*TCC-AE*ALV*DI*DELRW)+          &
-            DGMW/SEKDEL*(ALF+CW*TCC)+DGMI/SEKDEL*CI*TCC)
-      ENDIF
-
-      IF(FW.GT.1.)FW=1.
-      IF(FW.LT.0.)FW=0.
-  END SUBROUTINE HEATBUD
-
-
-  
-  SUBROUTINE BREAKUP(DENSE,D,GM,FW)
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  !!!  TEST IF AMOUNT OF WATER ON SURFACE EXCEEDS CRTICAL LIMIT- 
-  !!!  IF SO INVOKE SHEDDING SCHEME 
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-
-      IMPLICIT NONE
-      REAL*8 D
-      REAL DENSE, GM, FW
-      !local variables
-      REAL WATER, GMI, CRIT, WAT, PI
-      DATA PI/3.141592654/
-
-      WATER=FW*GM
-      GMI=GM-WATER
-
-      ! CALC CRTICAL MASS CAPABLE OF BEING "SUPPORTED" ON THE STONE'S 
-      ! SURFACE 
-      CRIT=0.268+0.1389*GMI 
-      IF (WATER.GT.CRIT)THEN
-         WAT=WATER-CRIT
-         GM=GM-WAT
-         FW=(CRIT)/GM
-       
-         IF(FW.GT.1.0) FW=1.0
-         IF(FW.LT.0.0) FW=0.0
-
-         ! RECALCULATE DENSITY AND DIAMETER AFTER SHEDDING 
-         DENSE=(FW*(0.1)+0.9) * 1000.
-         D=(6.*GM/(PI*DENSE))**(0.333333333)
-      ENDIF
-  END SUBROUTINE BREAKUP
-  
-  
-  SUBROUTINE MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT)
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-  !!!  This is a spherical hail melting estimate based on the Goyer 
-  !!!  et al. (1969) eqn (3).  The depth of the warm layer, estimated 
-  !!!  terminal velocity, and mean temperature of the warm layer are 
-  !!!  used.  DRB.  11/17/2003.
-  !!!
-  !!!  INPUT:  TLAYER   mean sub-cloud layer temperature (K)
-  !!!          PLAYER   mean sub-cloud layer pressure (Pa)
-  !!!          RLAYER   mean sub-cloud layer mixing ratio (kg/kg)
-  !!!          VT       terminal velocity of stone (m/s)
-  !!!  OUTPUT: D        diameter (m)
-  !!!          
-  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-      IMPLICIT NONE
-
-      REAL*8 D
-      REAL TLAYER, PLAYER, RLAYER, LDEPTH, VT
-      REAL eenv, delta, ewet, de, der, wetold, wetbulb, wetbulbk
-      REAL tdclayer, tclayer, eps, b, hplayer
-      REAL*8 a
-      REAL sd, lt, ka, lf, lv, t0, dv, pi, rv, rhoice, &
-           tres, re, delt, esenv, rhosenv, essfc, rhosfc, dsig, &
-           dmdt, mass, massorg, newmass, gamma, r, rho
-      INTEGER wcnt
-      
-      !Convert temp to Celsius, calculate dewpoint in celsius
-      tclayer = TLAYER - 273.155
-      a = 2.53E11
-      b = 5.42E3
-      tdclayer = b / LOG(a*eps / (rlayer*player))
-      hplayer = player / 100.
-      
-      !Calculate partial vapor pressure
-      eps = 0.622
-      eenv = (player*rlayer) / (rlayer+eps)
-      eenv = eenv / 100.  !convert to mb
-      
-      !Estimate wet bulb temperature (C)
-      gamma = 6.6E-4*player
-      delta = (4098.0*eenv)/((tdclayer+237.7)*(tdclayer+237.7))
-      wetbulb = ((gamma*tclayer)+(delta*tdclayer))/(gamma+delta)
-      
-      !Iterate to get exact wet bulb
-      wcnt = 0
-      DO WHILE (wcnt .lt. 11)
-        ewet = 6.108*(exp((17.27*wetbulb)/(237.3 + wetbulb))) 
-        de = (0.0006355*hplayer*(tclayer-wetbulb))-(ewet-eenv)
-        der= (ewet*(.0091379024 - (6106.396/(273.155+wetbulb)**2))) &
-             - (0.0006355*hplayer)
-        wetold = wetbulb
-        wetbulb = wetbulb - de/der
-        wcnt = wcnt + 1
-        IF ((abs(wetbulb-wetold)/wetbulb.gt.0.0001)) THEN
-           EXIT
-        ENDIF
-      ENDDO
-      
-      wetbulbk = wetbulb + 273.155  !convert to K
-      ka = .02 ! thermal conductivity of air
-      lf = 3.34e5 ! latent heat of melting/fusion
-      lv = 2.5e6  ! latent heat of vaporization
-      t0 = 273.155 ! temp of ice/water melting interface
-      dv = 0.25e-4 ! diffusivity of water vapor (m2/s)
-      pi = 3.1415927
-      rv = 1004. - 287. ! gas constant for water vapor
-      rhoice = 917.0 ! density of ice (kg/m**3)
-      r = D/2. ! radius of stone (m)
-      
-      !Compute residence time in warm layer
-      tres = LDEPTH / VT
-        
-      !Calculate dmdt based on eqn (3) of Goyer et al. (1969)
-      !Reynolds number...from pg 317 of Atmo Physics (Salby 1996)
-      !Just use the density of air at 850 mb...close enough.
-      rho = 85000./(287.*TLAYER)
-      re = rho*r*VT*.01/1.7e-5
-      
-      !Temperature difference between environment and hailstone surface
-      delt = wetbulb !- 0.0 !assume stone surface is at 0C
-                            !wetbulb is in Celsius
-
-      !Difference in vapor density of air stream and equil vapor
-      !density at the sfc of the hailstone
-      esenv = 610.8*(exp((17.27*wetbulb)/  &
-               (237.3 + wetbulb))) ! es environment in Pa
-      rhosenv = esenv/(rv*wetbulbk)
-      essfc = 610.8*(exp((17.27*(t0-273.155))/  &
-               (237.3 + (t0-273.155)))) ! es environment in Pa
-      rhosfc = essfc/(rv*t0)
-      dsig = rhosenv - rhosfc
-
-      !Calculate new mass growth
-      dmdt = (-1.7*pi*r*(re**0.5)/lf)*((ka*delt)+((lv-lf)*dv*dsig))
-      IF (dmdt.gt.0.) dmdt = 0
-      mass = dmdt*tres
-      
-      !Find the new hailstone diameter
-      massorg = 1.33333333*pi*r*r*r*rhoice
-      newmass = massorg + mass
-      if (newmass.lt.0.0) newmass = 0.0
-      D = 2.*(0.75*newmass/(pi*rhoice))**0.333333333
-  END SUBROUTINE MELT
-
-END MODULE module_diag_afwa_hail
diff --git a/wrfv2_fire/phys/module_diag_hailcast.F b/wrfv2_fire/phys/module_diag_hailcast.F
new file mode 100644
index 00000000..f7291ecc
--- /dev/null
+++ b/wrfv2_fire/phys/module_diag_hailcast.F
@@ -0,0 +1,1347 @@
+#if (NMM_CORE == 1)
+MODULE module_diag_hailcast
+CONTAINS
+   SUBROUTINE diag_hailcast_stub
+   END SUBROUTINE diag_hailcast_stub
+END MODULE module_diag_hailcast
+#else
+
+MODULE module_diag_hailcast
+
+CONTAINS
+
+  SUBROUTINE hailcast_diagnostic_driver (   grid , config_flags     &
+                             , moist                             &
+                             , rho  &
+                             , ids, ide, jds, jde, kds, kde      &
+                             , ims, ime, jms, jme, kms, kme      &
+                             , ips, ipe, jps, jpe, kps, kpe      &
+                             , its, ite, jts, jte                &
+                             , k_start, k_end               )
+
+    USE module_domain, ONLY : domain , domain_clock_get
+    USE module_configure, ONLY : grid_config_rec_type, model_config_rec
+    USE module_state_description
+    USE module_model_constants
+    USE module_utility
+    USE module_streams, ONLY: history_alarm, auxhist2_alarm
+#ifdef DM_PARALLEL
+    USE module_dm, ONLY: wrf_dm_sum_real, wrf_dm_maxval
+#endif
+
+    IMPLICIT NONE
+
+    TYPE ( domain ), INTENT(INOUT) :: grid
+    TYPE ( grid_config_rec_type ), INTENT(IN) :: config_flags
+
+    INTEGER, INTENT(IN) :: ids, ide, jds, jde, kds, kde,        &
+                           ims, ime, jms, jme, kms, kme,        &
+                           ips, ipe, jps, jpe, kps, kpe
+    INTEGER             :: k_start , k_end, its, ite, jts, jte
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme , num_moist),    &
+         INTENT(IN   ) ::                                moist
+
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),               &
+         INTENT(IN   ) ::                                 rho
+
+    ! Local
+    
+    CHARACTER*512 :: message
+    CHARACTER*256 :: timestr 
+    INTEGER :: i,j,k,nz
+    INTEGER :: i_start, i_end, j_start, j_end
+    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ) ::      qr  &
+                                              ,          qs  &
+                                              ,          qg  &
+                                              ,          qv  &
+                                              ,          qc  &
+                                              ,          qi  &
+                                              ,        ptot 
+    REAL, DIMENSION( ims:ime, jms:jme ) ::       wup_mask_prev  &
+                                              ,      wdur_prev  
+    REAL :: dhail1,dhail2,dhail3,dhail4,dhail5
+    
+    ! Timing
+    
+    TYPE(WRFU_Time) :: hist_time, aux2_time, CurrTime, StartTime
+    TYPE(WRFU_TimeInterval) :: dtint, histint, aux2int
+    LOGICAL :: is_after_history_dump, is_output_timestep, is_first_timestep
+
+    ! Chirp the routine name for debugging purposes
+    write ( message, * ) 'inside hailcast_diagnostics_driver'
+    CALL wrf_debug( 100 , message )
+
+    ! Get timing info 
+    ! Want to know if when the last history output was
+    ! Check history and auxhist2 alarms to check last ring time and how often
+    ! they are set to ring
+    
+    CALL WRFU_ALARMGET( grid%alarms( HISTORY_ALARM ), prevringtime=hist_time, &
+         ringinterval=histint)
+    CALL WRFU_ALARMGET( grid%alarms( AUXHIST2_ALARM ), prevringtime=aux2_time, &
+         ringinterval=aux2int)
+
+    ! Get domain clock
+   
+    CALL domain_clock_get ( grid, current_time=CurrTime, &
+         simulationStartTime=StartTime, &            
+         current_timestr=timestr, time_step=dtint )
+
+    ! Set some booleans for use later
+    ! Following uses an overloaded .lt.
+  
+    is_after_history_dump = ( Currtime .lt. hist_time + dtint )
+
+    ! Following uses an overloaded .ge.
+ 
+    is_output_timestep = (Currtime .ge. hist_time + histint - dtint .or. &
+                         Currtime .ge. aux2_time + aux2int - dtint )
+    write ( message, * ) 'is output timestep? ', is_output_timestep
+    CALL wrf_debug( 100 , message )
+
+    ! Following uses an overloaded .eq.
+
+    is_first_timestep = ( Currtime .eq. StartTime + dtint )
+        
+    ! 3-D arrays for moisture variables
+
+    DO i=ims, ime
+      DO k=kms, kme
+        DO j=jms, jme
+          qv(i,k,j) = moist(i,k,j,P_QV)
+          qr(i,k,j) = moist(i,k,j,P_QR)
+          qs(i,k,j) = moist(i,k,j,P_QS)
+          qg(i,k,j) = moist(i,k,j,P_QG)
+          qc(i,k,j) = moist(i,k,j,P_QC)
+          qi(i,k,j) = moist(i,k,j,P_QI)
+        ENDDO
+      ENDDO
+    ENDDO
+
+    ! Total pressure
+
+    DO i=ims, ime
+      DO k=kms, kme
+        DO j=jms, jme
+          ptot(i,k,j)=grid%pb(i,k,j)+grid%p(i,k,j)
+        ENDDO
+      ENDDO
+    ENDDO
+
+    ! After each history dump, reset max/min value arrays
+
+    IF ( is_after_history_dump ) THEN
+      DO j = jms, jme
+        DO i = ims, ime
+           grid%hailcast_dhail1(i,j) = 0.
+           grid%hailcast_dhail2(i,j) = 0.
+           grid%hailcast_dhail3(i,j) = 0.
+           grid%hailcast_dhail4(i,j) = 0.
+           grid%hailcast_dhail5(i,j) = 0.
+        ENDDO
+      ENDDO
+    ENDIF  ! is_after_history_dump
+
+
+    ! We need to do some neighboring gridpoint comparisons for the updraft
+    ! duration calculations; set i,j start and end values so we don't go off 
+    ! the edges of the domain.  Updraft duration on domain edges will always be 0.
+
+    i_start = its
+    i_end   = ite
+    j_start = jts
+    j_end   = jte
+
+    IF ( config_flags%open_xs .OR. config_flags%specified .OR. &
+         config_flags%nested) i_start = MAX( ids+1, its )
+    IF ( config_flags%open_xe .OR. config_flags%specified .OR. &
+         config_flags%nested) i_end   = MIN( ide-1, ite )
+    IF ( config_flags%open_ys .OR. config_flags%specified .OR. &
+         config_flags%nested) j_start = MAX( jds+1, jts )
+    IF ( config_flags%open_ye .OR. config_flags%specified .OR. &
+         config_flags%nested) j_end   = MIN( jde-1, jte )
+    IF ( config_flags%periodic_x ) i_start = its
+    IF ( config_flags%periodic_x ) i_end = ite
+    
+
+    ! Make a copy of the updraft duration, mask variables
+
+    wdur_prev(:,:) = grid%hailcast_wdur(:,:)
+    wup_mask_prev(:,:) = grid%hailcast_wup_mask(:,:)
+
+    ! Determine updraft mask (where updraft greater than some threshold)
+
+    DO j = jts, jte
+      DO i = its, ite
+        grid%hailcast_wup_mask(i,j) = 0
+        grid%hailcast_wdur(i,j) = 0
+
+        DO k = k_start, k_end
+          IF ( grid%w_2(i,k,j) .ge. 10. ) THEN
+              grid%hailcast_wup_mask(i,j) = 1
+          ENDIF
+        ENDDO
+      ENDDO
+    ENDDO
+
+    ! Determine updraft duration; make sure not to call point outside the domain
+
+    DO j = j_start, j_end
+      DO i = i_start, i_end
+
+        ! Determine updraft duration using updraft masks
+
+        IF ( (grid%hailcast_wup_mask(i,j).eq.1) .OR.                 &
+           (MAXVAL(wup_mask_prev(i-1:i+1,j-1:j+1)).eq.1) ) THEN
+             grid%hailcast_wdur(i,j) =                                 &
+                  MAXVAL(wdur_prev(i-1:i+1,j-1:j+1)) + grid%dt
+        ENDIF
+      ENDDO
+    ENDDO
+
+
+    ! Hail diameter in millimeters (HAILCAST)
+
+    nz = k_end - k_start
+    DO j = jts, jte
+      DO i = its, ite
+
+        ! Only call hailstone driver if updraft has been
+        ! around longer than 15 min
+
+        IF (grid%hailcast_wdur(i,j) .gt. 900) THEN
+          CALL hailstone_driver ( grid%t_phy(i,kms:kme,j), &
+                                  grid%z(i,kms:kme,j),     &
+                                  grid%ht(i,       j),     &
+                                  ptot(i,kms:kme,j),     &
+                                  rho(i,kms:kme,j),   &
+                                  qv(i,kms:kme,j),    &
+                                  qi(i,kms:kme,j),    &
+                                  qc(i,kms:kme,j),    &
+                                  qr(i,kms:kme,j),    &
+                                  qs(i,kms:kme,j),    &
+                                  qg(i,kms:kme,j),    &
+                                  grid%w_2(i,kms:kme,j),   &
+                                  grid%hailcast_wdur(i,j),          &
+                                  nz,                 &
+                                  dhail1, dhail2,     &
+                                  dhail3, dhail4,     &
+                                  dhail5              )
+          IF (dhail1 .gt. grid%hailcast_dhail1(i,j)) THEN
+              grid%hailcast_dhail1(i,j) = dhail1
+          ENDIF
+          IF (dhail2 .gt. grid%hailcast_dhail2(i,j)) THEN
+              grid%hailcast_dhail2(i,j) = dhail2
+          ENDIF
+          IF (dhail3 .gt. grid%hailcast_dhail3(i,j)) THEN
+              grid%hailcast_dhail3(i,j) = dhail3
+          ENDIF
+          IF (dhail4 .gt. grid%hailcast_dhail4(i,j)) THEN
+              grid%hailcast_dhail4(i,j) = dhail4
+          ENDIF
+          IF (dhail5 .gt. grid%hailcast_dhail5(i,j)) THEN
+              grid%hailcast_dhail5(i,j) = dhail5
+          ENDIF
+        ENDIF
+      ENDDO
+    ENDDO
+
+    ! Calculate the mean and standard deviation of the hail diameter
+    ! distribution over different embryo sizes
+
+    DO j = jms, jme
+      DO i = ims, ime
+        !mean
+        grid%hailcast_diam_mean(i,j)=(grid%hailcast_dhail1(i,j)+&
+             grid%hailcast_dhail2(i,j) +grid%hailcast_dhail3(i,j)+&
+             grid%hailcast_dhail4(i,j) +grid%hailcast_dhail5(i,j))/5.
+        !sample standard deviation
+        grid%hailcast_diam_std(i,j) = SQRT( ( &
+          (grid%hailcast_dhail1(i,j)-grid%hailcast_diam_mean(i,j))**2.+&
+          (grid%hailcast_dhail2(i,j)-grid%hailcast_diam_mean(i,j))**2.+&
+          (grid%hailcast_dhail3(i,j)-grid%hailcast_diam_mean(i,j))**2.+&
+          (grid%hailcast_dhail4(i,j)-grid%hailcast_diam_mean(i,j))**2.+&
+          (grid%hailcast_dhail5(i,j)-grid%hailcast_diam_mean(i,j))**2.)&
+          / 4.0)
+      ENDDO
+    ENDDO
+
+  END SUBROUTINE hailcast_diagnostic_driver
+
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+!
+! Hailstone driver, adapted from hailstone subroutine in HAILCAST
+!  Inputs:
+!    1-d (nz)
+!     TCA          temperature (K) 
+!     h1d          height above sea level (m) 
+!     PA           total pressure (Pa)
+!     rho1d        density (kg/m3)
+!     RA           vapor mixing ratio (kg/kg)
+!     qi1d         cloud ice mixing ratio (kg/kg)
+!     qc1d         cloud water mixing ratio (kg/kg)
+!     qr1d         rain water mixing ratio (kg/kg)
+!     qg1d         graupel mixing ratio (kg/kg)
+!     qs1d         snow mixing ratio (kg/kg)
+!     VUU          updraft speed at each level (m/s)
+!    Float
+!     ht         terrain height (m)
+!     wdur       duration of any updraft > 10 m/s within 1 surrounding 
+!                 gridpoint 
+!    Integer
+!     nz         number of vertical levels
+!
+!  Output:
+!     dhail      hail diameter in mm 
+!                1st-5th rank-ordered hail diameters returned
+!
+!  13 Aug 2013 .................................Becky Adams-Selin AER
+!     adapted from hailstone subroutine in SPC's HAILCAST
+!  18 Mar 2014 .................................Becky Adams-Selin AER
+!     added variable rime layer density, per Ziegler et al. (1983)
+!  4 Jun 2014 ..................................Becky Adams-Selin AER
+!     removed initial embryo size dependency on microphysic scheme
+!  5 Jun 2014 ..................................Becky Adams-Selin AER
+!     used smaller initial embryo sizes
+!  25 Jun 2015..................................Becky Adams-Selin AER
+!     Significant revamping.  Fixed units bug in HEATBUD that caused
+!     hailstone temperature instabilities.  Similar issue fixed in BREAKUP
+!     subroutine.  Removed graupel from ice content.  Changed initial
+!     embryo size and location to better match literature.  Added
+!     enhanced melting when hailstone collides with liquid water
+!     in regions above freezing.  Final diameter returned is ice diameter
+!     only. Added hailstone temperature averaging over previous timesteps 
+!     to decrease initial temperature instability at small embyro diameters.  
+!  3 Sep 2015...................................Becky Adams-Selin AER
+!    Insert embryos at -13C; interpret pressure and other variables to
+!    that exact temperature level.
+! 16 Nov 2015...................................Becky Adams-Selin AER
+!     Hailstone travels horizontally through updraft instead of being
+!     locked in the center.
+!    
+! See Adams-Selin and Ziegler 2016, MWR for further documentation.
+!
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  SUBROUTINE hailstone_driver ( TCA, h1d, ht, PA, rho1d,&
+                                RA, qi1d,qc1d,qr1d,qs1d,qg1d,   &
+                                VUU, wdur,                          &
+                                nz,dhail1,dhail2,dhail3,dhail4,     &
+                                dhail5                             )
+    IMPLICIT NONE
+    INTEGER, INTENT(IN ) :: nz
+
+    REAL, DIMENSION( nz ),             &
+         INTENT(IN   ) ::                                  TCA  & ! temperature (K)
+                                              ,          rho1d  &
+                                              ,            h1d  &
+                                              ,             PA  & ! pressure (Pa)
+                                              ,             RA  & ! vapor mixing ratio (kg/kg)
+                                              ,            VUU  & ! updraft speed (m/s)
+                                              , qi1d,qc1d,qr1d  &
+                                              , qs1d,qg1d
+
+    REAL, INTENT(IN   ) ::                                  ht  &
+                                              ,           wdur
+    
+    !Output: 1st-5th rank-ordered hail diameters returned
+    REAL, INTENT(INOUT) ::                              dhail1 & ! hail diameter (mm);
+                                              ,         dhail2 &
+                                              ,         dhail3 &
+                                              ,         dhail4 &
+                                              ,         dhail5
+    !Local variables
+    REAL ZBAS, TBAS, WBASP     ! height, temp, pressure of cloud base
+    REAL RBAS                  ! mix ratio of cloud base
+    REAL cwitot                ! total cloud water, ice mix ratio
+    INTEGER KBAS               ! k of cloud base
+    REAL tk_embryo             ! temperature at which initial embryo is inserted
+    REAL ZFZL, TFZL, WFZLP     ! height, temp, pressure of embryo start point
+    REAL RFZL                  ! mix ratio of embryo start point
+    REAL VUFZL, DENSAFZL       ! updraft speed, density of embryo start point
+    INTEGER KFZL               ! k of embryo start point
+    INTEGER nofroze            ! keeps track if hailstone has ever been frozen
+    INTEGER CLOUDON            ! use to zero out cloud water, ice once past updraft duration
+    REAL RTIME                 ! real updraft duration (sec)
+    REAL TAU, TAU_1, TAU_2     ! upper time limit of simulation (sec)
+    REAL delTAU                ! difference between TAU_2 and TAU_1 (sec)
+    REAL g                     ! gravity (m/s)
+    REAL r_d                   ! constant
+    !hailstone parameters
+    REAL*8 DD, D, D_ICE        ! hail diameter (m)
+    REAL VT                    ! terminal velocity (m/s)
+    REAL V                     ! actual stone velocity (m/s)
+    REAL TS                    ! hailstone temperature (K)
+    !HAILSTONE temperature differencing
+    REAL TSm1, TSm2            ! hailstone temperature at previous 3 timesteps
+    REAL FW                    ! fraction of stone that is liquid
+    REAL WATER                 ! mass of stone that is liquid
+    REAL CRIT                  ! critical water mass allowed on stone surface
+    REAL DENSE                 ! hailstone density (kg/m3)
+    INTEGER ITYPE              ! wet (2) or dry (1) growth regime
+    !1-d column arrays of updraft parameters
+    REAL, DIMENSION( nz ) ::  &
+      RIA, &                   ! frozen content mix ratio (kg/kg)
+      RWA, &                   ! liquid content mix ratio (kg/kg)
+      VUU_pert                 ! perturbed updraft profile (m/s)
+    !in-cloud updraft parameters at location of hailstone
+    REAL P                     ! in-cloud pressure (Pa)
+    REAL RS                    ! in-cloud saturation mixing ratio 
+    REAL RI, RW                ! ice, liquid water mix. ratio (kg/kg)
+    REAL XI, XW                ! ice, liquid water content (kg/m3 air)
+    REAL PC                    ! in-cloud fraction of frozen water
+    REAL TC                    ! in-cloud temperature (K)
+    REAL VU                    ! in-cloud updraft speed (m/s)
+    REAL VUMAX                 ! in-cloud updraft speed read from WRF (max allowed)
+    REAL VUCORE                ! perturbed in-cloud updraft speed
+    REAL DENSA                 ! in-cloud updraft density (kg/m3)
+    REAL Z                     ! height of hailstone (m)
+    REAL DELRW                 ! diff in sat vap. dens. between hail and air (kg/m3)
+    !variables to determine graupel size distribution
+    REAL, DIMENSION(600) :: gd       !graupel diameter
+    REAL, DIMENSION(600) :: ng_d     !number of graupel particles of that diameter
+    REAL, DIMENSION(600) :: sum_ng_d !cumulative summation of # graupel particles of diam. D or less
+    REAL lambdag                     !slope of the graupel size distribution
+    REAL n0g                         !graupel distribution intercept
+    REAL deng                        !graupel density
+    REAL xslw1,ygra1,zans1           !Thompson graupel size dist parameters
+    REAL pile                        !desired percentile
+    REAL d02,d05,d10,d15,d20 !2,5,10,15,20th %ile graupel dsd diameters
+    REAL n02,n05,n10,n15,n20 !#rank of each of the %iles
+    REAL, DIMENSION(5) :: dhails     !hail diameters with the 1st-15th %ile of graupel dsd 
+                                     !used as initial hail embryo size
+    !mean sub-cloud layer variables
+    REAL TLAYER,RLAYER,PLAYER  ! mean sub-cloud temp, mix ratio, pres
+    REAL TSUM,RSUM,PSUM        ! sub-cloud layer T, R, P sums
+    REAL LDEPTH                ! layer depth
+    !internal function variables
+    REAL GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DGMV,DI,ANU,RE,AE
+    REAL dum
+      
+    REAL sec, secdel           ! time step, increment in seconds
+    INTEGER i, j, k, IFOUT, ind(1)
+    CHARACTER*256 :: message
+
+
+    !secdel = 0.05
+    secdel = 5.0
+    g=9.81
+    r_d = 287.
+            
+!   Upper limit of simulation in seconds
+    TAU = 7200.    !simulation ends
+
+    !Set initial updraft strength - reduce to simulate the embryo hovering
+    ! around the edges of the updraft, as in Heymsfield and Musil (1982)
+    DO i=1,nz
+       VUU_pert(i) = VUU(i) * 1.
+    ENDDO
+
+      
+!   Initialize diameters to 0.
+    DO i=1,5
+       dhails(i) = 0.
+    ENDDO
+
+!   Cap updraft lifetime at 2000 sec.
+    IF (wdur .GT. 2000) THEN
+        RTIME  = 2000.
+    ELSE
+        RTIME = wdur
+    ENDIF
+
+ 
+    !Sum frozen and liquid condensate.
+    !Also find the cloud base for end-of-algorithm purposes.
+    KBAS=nz
+    !KFZL=nz
+    DO k=1,nz
+         cwitot = qi1d(k) + qc1d(k)
+         !No longer include graupel in in-cloud ice amounts
+         !RIA(k) = qi1d(k) + qs1d(k) + qg1d(k)
+         RIA(k) = qi1d(k) + qs1d(k)
+         !RWA(k) = qc1d(k) + qr1d(k)
+         RWA(k) = qc1d(k)
+         !IF ((RIA(k) .ge. 0.0001) .and. (TCA(k).lt.260.155) .and. &
+         !    (k .lt. KFZL)) THEN
+         !   KFZL = k
+         !ENDIF
+         IF ((cwitot .ge. 1.E-12) .and. (k .lt. KBAS)) THEN
+            KBAS = k
+         ENDIF
+    ENDDO
+    !QC - our embryo can't start below the cloud base.
+    !IF (KFZL .lt. KBAS) THEN
+    !   KFZL = KBAS
+    !ENDIF
+
+    !Pull heights, etc. of these levels out of 1-d arrays.
+    !ZFZL = h1d(KFZL)
+    !TFZL = TCA(KFZL)
+    !WFZLP = PA(KFZL)
+    !RFZL = RA(KFZL)
+    ZBAS = h1d(KBAS)
+    TBAS = TCA(KBAS)
+    WBASP = PA(KBAS)
+    RBAS = RA(KBAS)
+    
+    !Insert initial embryo at -13C
+    tk_embryo = 260.155
+    TFZL = tk_embryo
+    CALL INTERPP(PA, WFZLP, TCA, tk_embryo, IFOUT, nz)
+    CALL INTERP(h1d, ZFZL, WFZLP, IFOUT, PA, nz)
+    CALL INTERP(RA,  RFZL, WFZLP, IFOUT, PA, nz)
+    CALL INTERP(VUU_pert, VUFZL, WFZLP, IFOUT, PA, nz)
+    CALL INTERP(rho1d, DENSAFZL, WFZLP, IFOUT, PA, nz)
+
+    !!!!!!!!!!!!!!!! 0. INITIAL EMBRYO SIZE  !!!!!!!!!!!!!!!!!!!!!
+    !      SET CONSTANT RANGE OF INITIAL EMBRYO SIZES            !
+    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+    ! See Adams-Selin and Ziegler 2016 MWR for explanation of why
+    ! these sizes were picked.
+    d02 = 9.E-4
+    d05 = 2.E-3
+    d10 = 5.E-3
+    d15 = 7.5E-3
+    d20 = 1.E-2    
+
+    !Run each initial embryo size perturbation
+    DO i=1,5
+      SELECT CASE (i)   
+        CASE (1)
+        !Initial hail embryo diameter in m, at cloud base
+        DD = d02
+        CASE (2)
+        DD = d05
+        CASE (3)  
+        DD = d10
+        CASE (4)
+        DD = d15
+        CASE (5)
+        DD = d20
+      END SELECT
+
+      !Begin hail simulation time (seconds)
+      sec = 0.
+ 
+      !Set initial values for parameters at freezing level
+      P = WFZLP
+      RS = RFZL
+      TC = TFZL
+      VU = VUFZL  
+      Z = ZFZL - ht
+      LDEPTH = Z
+      DENSA = DENSAFZL
+
+      !Set initial hailstone parameters
+      nofroze=1 !Set test for embryo: 0 for never been frozen; 1 frozen
+      TS = TC
+      TSm1 = TS
+      TSm2 = TS      
+      D = DD   !hailstone diameter in m
+      FW = 0.0
+      DENSE = 500.  !kg/m3  
+      ITYPE=1.  !Assume starts in dry growth.
+      CLOUDON=1  !we'll eventually turn cloud "off" once updraft past time limit
+
+      !Start time loop.
+      DO WHILE (sec .lt. TAU)
+         sec = sec + secdel
+         
+         !!!!!!!!!!!!!!!!!!  1. CALCULATE PARAMETERS  !!!!!!!!!!!!!!!!!
+         !              CALCULATE UPDRAFT PROPERTIES                  !
+         !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+         !Intepolate vertical velocity to our new pressure level
+         CALL INTERP(VUU_pert,VUMAX,P,IFOUT,PA,nz)
+         !print *, 'INTERP VU: ', VU, P
+         
+         !Outside pressure levels?  If so, exit loop
+         IF (IFOUT.EQ.1) GOTO 100
+                  
+         !Sine wave multiplier on updraft strength
+         IF (SEC .GT. 0.0 .AND. SEC .LT. RTIME) THEN
+            VUCORE = VUMAX * SIN( (3.14159 * SEC)/(RTIME) )
+            VU = VUCORE
+      
+         ELSEIF (SEC .GE. RTIME) THEN
+            VU = 0.0
+            CLOUDON = 0
+         ENDIF
+         
+         !Calculate terminal velocity of the hailstone 
+         ! (use previous values)
+         CALL TERMINL(DENSA,DENSE,D,VT,TC)
+         
+         !Actual velocity of hailstone (upwards positive)
+         V = VU - VT
+         
+         !Use hydrostatic eq'n to calc height of next level
+         P = P - DENSA*g*V*secdel
+         Z = Z + V*secdel
+
+         !Interpolate cloud temp, qvapor at new p-level
+         CALL INTERP(TCA,TC,P,IFOUT,PA,nz)
+         CALL INTERP(RA,RS,P,IFOUT,PA,nz)
+         
+         !New density of in-cloud air
+         DENSA=P/(r_d*(1.+0.609*RS/(1.+RS))*TC)
+         
+         !Interpolate liquid, frozen water mix ratio at new level
+         CALL INTERP(RIA,RI,P,IFOUT,PA,nz)
+         CALL INTERP(RWA,RW,P,IFOUT,PA,nz)
+         XI = RI * DENSA * CLOUDON
+         XW = RW * DENSA * CLOUDON
+         IF( (XW+XI).GT.0) THEN
+           PC = XI / (XW+XI)
+         ELSE
+           PC = 1.
+         ENDIF
+         
+         
+        !!!!!!!!!!!!!!!!!!  2. TEST FOR WET/DRY GROWTH !!!!!!!!!!!!!!!
+        !  WET GROWTH - STONE'S SFC >0; DRY GROWTH SFC < 0           ! 
+        !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+        !MOVED TEST INSIDE HEATBUD - JUST ASSIGN AFTER TS/FW CALC
+
+        ! DENSITY OF HAILSTONE - DEPENDS ON FW
+        ! ONLY WATER=1 GM/L=1000KG/M3; ONLY ICE  =0.9 GM/L 
+        !DENSE=(FW*0.1+0.9) * 1000.  !KG/M3 !RAS-density calc inside MASSAGR
+ 
+        ! SATURATION VAPOUR DENSITY DIFFERENCE BETWTEEN STONE AND CLOUD
+        CALL VAPORCLOSE(DELRW,PC,TS,TC,ITYPE)
+      
+        
+        !!!!!!!!!!!!!!!!!!  3. STONE'S MASS GROWTH !!!!!!!!!!!!!!!!!!!!
+        CALL MASSAGR(D,GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DGMV,DI,ANU,RE,AE,&
+                 TC,TS,P,DENSE,DENSA,FW,VT,XW,XI,secdel,ITYPE,DELRW) 
+
+
+        !!!!!!!!!!!!!!!!!!  4. HEAT BUDGET OF HAILSTONE !!!!!!!!!!!!!!!
+        CALL HEATBUD(TS,TSm1,TSm2,FW,TC,VT,DELRW,D,DENSA,GM1,GM,DGM,DGMW,  & 
+                     DGMV,DGMI,GMW,GMI,DI,ANU,RE,AE,secdel,ITYPE,P)
+
+ 
+        !!!!! 5. TEST DIAMETER OF STONE AND HEIGHT ABOVE GROUND !!!!!!!
+        !  TEST IF DIAMETER OF STONE IS GREATER THAN 9 MM LIMIT, IF SO  
+        !  BREAK UP 
+        !IF(D.GT.0.009) THEN   
+        !   CALL BREAKUP(DENSE,D,GM,FW)
+        !ENDIF
+        WATER=FW*GM  !KG
+        ! CRTICAL MASS CAPABLE OF BEING "SUPPORTED" ON THE STONE'S SURFACE 
+        CRIT = 1.0E-10
+        IF (WATER.GT.CRIT)THEN
+           CALL BREAKUP(DENSE,D,GM,FW)
+        ENDIF
+        
+        ! Has stone reached below cloud base?
+        !IF (Z .LE. 0) GOTO 200
+        IF (Z .LE. ZBAS) GOTO 200
+
+        !calculate ice-only diameter size
+        D_ICE = ( (6*GM*(1.-FW)) / (3.141592654*DENSE) )**0.33333333 
+
+        !Has the stone entirely melted and it's below the freezing level?  
+        IF ((D_ICE .LT. 1.E-8) .AND. (TC.GT.273.155)) GOTO 300
+
+        !move values to previous timestep value
+        TSm1 = TS
+        TSm2 = TSm1
+        
+      ENDDO  !end cloud lifetime loop
+
+100   CONTINUE !outside pressure levels in model
+200   CONTINUE !stone reached surface
+300   CONTINUE !stone has entirely melted and is below freezing level
+
+      !!!!!!!!!!!!!!!!!! 6. MELT STONE BELOW CLOUD !!!!!!!!!!!!!!!!!!!!
+      !Did the stone shoot out the top of the storm? 
+      !Then let's assume it's lost in the murky "outside storm" world.
+      IF (P.lt.PA(nz)) THEN
+         D=0.0
+      !Is the stone entirely water? Then set D=0 and exit.
+      ELSE IF(ABS(FW - 1.0).LT.0.001) THEN
+         D=0.0
+      ELSE IF (Z.GT.0) THEN
+         !If still frozen, then use melt routine to melt below cloud
+         ! based on mean below-cloud conditions.
+        
+         !Calculate mean sub-cloud layer conditions
+         TSUM = 0.
+         RSUM = 0.
+         PSUM = 0.
+         DO k=1,KBAS
+            TSUM = TSUM + TCA(k)
+            PSUM = PSUM + PA(k)
+            RSUM = RSUM + RA(k)
+         ENDDO
+         TLAYER = TSUM / KBAS
+         PLAYER = PSUM / KBAS
+         RLAYER = RSUM / KBAS
+         
+         !MELT is expecting a hailstone of only ice.  At the surface
+         !we're only interested in the actual ice diameter of the hailstone,
+         !so let's shed any excess water now.
+         D_ICE = ( (6*GM*(1.-FW)) / (3.141592654*DENSE) )**0.33333333 
+         D = D_ICE  
+         CALL MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT)
+
+      ENDIF !end check for melting call
+      
+      !assign hail size in mm for output
+      dhails(i) = D * 1000
+
+    ENDDO  !end embryo size loop
+  
+    !! Size-sort hail diameters for function output !!
+    DO j=1,4
+     DO k=j+1,5
+         IF (dhails(j).lt.dhails(k)) THEN
+            dum = dhails(j)
+            dhails(j) = dhails(k)
+            dhails(k) = dum
+         ENDIF
+      ENDDO
+    ENDDO
+    
+    dhail1 = dhails(1)
+    dhail2 = dhails(2)
+    dhail3 = dhails(3)
+    dhail4 = dhails(4)
+    dhail5 = dhails(5)
+ 
+  END SUBROUTINE hailstone_driver
+
+
+  SUBROUTINE INTERPP(PA,PVAL,TA,TVAL,IFOUT,ITEL)
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !
+  ! INTERP: to linearly interpolate value of pval at temperature tval
+  !   between two levels of pressure array pa and temperatures ta
+  !
+  ! INPUT: PA    1D array of pressure, to be interpolated
+  !        TA    1D array of temperature
+  !        TVAL  temperature value at which we want to calculate pressure
+  !        IFOUT set to 0 if TVAL outside range of TA
+  !        ITEL  number of vertical levels
+  ! OUTPUT: PVAL interpolated pressure variable at temperature tval
+  !
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      IMPLICIT NONE
+      
+      REAL PVAL, TVAL
+      REAL, DIMENSION( ITEL) :: TA, PA
+      INTEGER ITEL, IFOUT
+      !local variables
+      INTEGER I
+      REAL FRACT
+      
+      IFOUT=1
+      
+      DO I=1,ITEL-1
+         IF ( (TVAL .LT. TA(I) .AND. TVAL .GE. TA(I+1)) .or.  &   ! dT/dz < 0
+              (TVAL .GT. TA(I) .AND. TVAL .LE. TA(I+1)) ) THEN    ! dT/dz > 0
+
+            FRACT = (TA(I) - TVAL) / (TA(I) - TA(I+1))
+            !.... compute the pressure value pval at temperature tval
+            PVAL = ((1.0 - FRACT) * PA(I)) + (FRACT * PA(I+1))
+          
+            !End loop
+            IFOUT=0
+            EXIT
+         ENDIF
+      ENDDO
+      
+  END SUBROUTINE INTERPP
+
+
+
+  SUBROUTINE INTERP(AA,A,P,IFOUT,PA,ITEL)
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !
+  ! INTERP: to linearly interpolate values of A at level P
+  !   between two levels of AA (at levels PA)
+  !
+  ! INPUT: AA    1D array of variable
+  !        PA    1D array of pressure
+  !        P     new pressure level we want to calculate A at
+  !        IFOUT set to 0 if P outside range of PA
+  !        ITEL  number of vertical levels
+  ! OUTPUT: A    variable at pressure level P
+  !
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      IMPLICIT NONE
+      
+      REAL A, P
+      REAL, DIMENSION( ITEL) :: AA, PA
+      INTEGER ITEL, IFOUT
+      !local variables
+      INTEGER I
+      REAL PDIFF, VDIFF, RDIFF, VERH, ADIFF
+      
+      IFOUT=1
+      
+      DO I=1,ITEL-1
+        IF (P.LE.PA(I) .AND. P.GT.PA(I+1)) THEN
+          !Calculate ratio between vdiff and pdiff
+          PDIFF = PA(I)-PA(I+1)
+          VDIFF = PA(I)-P
+          VERH = VDIFF/PDIFF     
+          
+          !Calculate the difference between the 2 A values
+          RDIFF = AA(I+1) - AA(I)
+          
+          !Calculate new value
+          A = AA(I) + RDIFF*VERH
+          
+          !End loop
+          IFOUT=0
+          EXIT
+        ENDIF
+      ENDDO
+      
+  END SUBROUTINE INTERP
+      
+
+  SUBROUTINE TERMINL(DENSA,DENSE,D,VT,TC)
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !
+  ! INTERP: Calculate terminal velocity of the hailstone
+  !
+  ! INPUT: DENSA  density of updraft air (kg/m3)
+  !        DENSE  density of hailstone
+  !        D      diameter of hailstone (m)
+  !        TC     updraft temperature (K)
+  ! OUTPUT:VT     hailstone terminal velocity (m/s)
+  !
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      IMPLICIT NONE
+      
+      REAL*8 D
+      REAL DENSA, DENSE, TC, VT
+      REAL GMASS, GX, RE, W, Y
+      REAL, PARAMETER :: PI = 3.141592654, G = 9.78956
+      REAL ANU
+      
+      !Mass of stone in kg
+      GMASS = (DENSE * PI * (D**3.)) / 6.
+      
+      !Dynamic viscosity
+      ANU = (0.00001718)*(273.155+120.)/(TC+120.)*(TC/273.155)**(1.5)
+      
+      !CALC THE BEST NUMBER, X AND REYNOLDS NUMBER, RE 
+      GX=(8.0*GMASS*G*DENSA)/(PI*(ANU*ANU))
+      RE=(GX/0.6)**0.5
+
+      !SELECT APPROPRIATE EQUATIONS FOR TERMINAL VELOCITY DEPENDING ON 
+      !THE BEST NUMBER
+      IF (GX.LT.550) THEN
+        W=LOG10(GX)
+        Y= -1.7095 + 1.33438*W - 0.11591*(W**2.0)      
+        RE=10**Y
+        VT=ANU*RE/(D*DENSA)
+      ELSE IF (GX.GE.550.AND.GX.LT.1800) THEN
+        W=LOG10(GX)
+        Y= -1.81391 + 1.34671*W - 0.12427*(W**2.0) + 0.0063*(W**3.0)
+        RE=10**Y
+        VT=ANU*RE/(D*DENSA)
+      ELSE IF (GX.GE.1800.AND.GX.LT.3.45E08) THEN
+        RE=0.4487*(GX**0.5536)
+        VT=ANU*RE/(D*DENSA)
+      ELSE 
+        RE=(GX/0.6)**0.5
+        VT=ANU*RE/(D*DENSA)
+      ENDIF
+      
+  END SUBROUTINE TERMINL   
+
+   
+   
+  SUBROUTINE VAPORCLOSE(DELRW,PC,TS,TC,ITYPE)
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !  VAPORCLOSE: CALC THE DIFFERENCE IN SATURATION VAPOUR DENSITY 
+  !  BETWEEN THAT OVER THE HAILSTONE'S SURFACE AND THE IN-CLOUD 
+  !  AIR, DEPENDS ON THE WATER/ICE RATIO OF THE UPDRAFT, 
+  !  AND IF THE STONE IS IN WET OR DRY GROWTH REGIME
+  !
+  !  INPUT:  PC    fraction of updraft water that is frozen
+  !          TS    temperature of hailstone (K)
+  !          TC    temperature of updraft air (K)
+  !          ITYPE wet (2) or dry (1) growth regime
+  !  OUTPUT: DELRW difference in sat vap. dens. between hail and air
+  !          (kg/m3)
+  !
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      IMPLICIT NONE
+      REAL DELRW, PC, TS, TC
+      INTEGER ITYPE
+      !local variables
+      REAL RV, ALV, ALS, RATIO
+      DATA RV/461.48/,ALV/2500000./,ALS/2836050./ 
+      REAL ESAT, RHOKOR, ESATW, RHOOMGW, ESATI, RHOOMGI, RHOOMG
+
+      !  FOR HAILSTONE:  FIRST TEST IF STONE IS IN WET OR DRY GROWTH
+      RATIO = 1./273.155
+      IF(ITYPE.EQ.2) THEN !!WET GROWTH
+        ESAT=611.*EXP(ALV/RV*(RATIO-1./TS))
+      ELSE  !!DRY GROWTH
+        ESAT=611.*EXP(ALS/RV*(RATIO-1./TS))
+      ENDIF
+      RHOKOR=ESAT/(RV*TS)
+      
+      !  NOW FOR THE AMBIENT/IN-CLOUD CONDITIONS 
+      ESATW=611.*EXP(ALV/RV*(RATIO-1./TC))
+      RHOOMGW=ESATW/(RV*TC)
+      ESATI=611.*EXP(ALS/RV*(RATIO-1./TC))
+      RHOOMGI=ESATI/(RV*TC)
+      !RHOOMG=PC*(RHOOMGI-RHOOMGW)+RHOOMGW
+      RHOOMG = RHOOMGI  !done as in hailtraj.f
+
+      !  CALC THE DIFFERENCE(KG/M3): <0 FOR CONDENSATION, 
+      !  >0 FOR EVAPORATION
+      DELRW=(RHOKOR-RHOOMG) 
+
+  END SUBROUTINE VAPORCLOSE
+     
+      
+
+  SUBROUTINE MASSAGR(D,GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DGMV,DI,ANU,RE,AE,& 
+                 TC,TS,P,DENSE,DENSA,FW,VT,XW,XI,SEKDEL,ITYPE,DELRW) 
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ! CALC THE STONE'S INCREASE IN MASS 
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+            
+      IMPLICIT NONE
+      REAL*8 D
+      REAL GM,GM1,GMW,GMI,DGM,DGMW,DGMI,DI,ANU,RE,AE,  &
+                 TC,TS,P,DENSE,DENSA,FW,VT,XW,XI,SEKDEL,DELRW
+      INTEGER ITYPE 
+      !local variables
+      REAL PI, D0, GMW2, GMI2, EW, EI,DGMV
+      REAL DENSEL, DENSELI, DENSELW 
+      REAL DC !MEAN CLOUD DROPLET DIAMETER (MICRONS, 1E-6M)
+      REAL VOLL, VOLT !VOLUME OF NEW LAYER, TOTAL (M3)
+      REAL VOL1, DGMW_NOSOAK, SOAK, SOAKM
+      REAL DENSAC, E
+      PI=3.141592654
+
+      !  CALCULATE THE DIFFUSIVITY DI (m2/s)
+      D0=0.226*1.E-4  ! change to m2/s, not cm2/s
+      DI=D0*(TC/273.155)**1.81*(100000./P)
+  
+      !  COLLECTION EFFICIENCY FOR WATER AND ICE 
+      !EW=1.0      
+      !   IF TS WARMER THAN -5C THEN ACCRETE ALL THE ICE (EI=1.0) 
+      !   OTHERWISE EI=0.21      
+      !IF(TS.GE.268.15)THEN
+      !  EI=1.00
+      !ELSE
+      !  EI=0.21
+      !ENDIF
+
+      !  COLLECTION EFFICIENCY FOR WATER AND ICE 
+      EW=1.0      
+      !  Linear function for ice accretion efficiency
+      IF (TC .GE. 273.155) THEN
+         EI=1.00
+      ELSE IF (TC.GE.233.155) THEN
+         EI= 1.0 - ( (273.155 - TS) / 40. )
+      ELSE  !cooler than -40C
+         EI = 0.0
+      ENDIF
+
+      !  CALCULATE THE VENTILATION COEFFICIENT - NEEDED FOR GROWTH FROM VAPOR
+      !The coefficients in the ventilation coefficient equations have been 
+      !experimentally derived, and are expecting cal-C-g units.  Do some conversions.
+      DENSAC = DENSA * (1.E3) * (1.E-6)
+      !dynamic viscosity 
+      ANU=1.717E-4*(393.0/(TC+120.0))*(TC/273.155)**1.5
+      !  CALCULATE THE REYNOLDS NUMBER - unitless
+      RE=D*VT*DENSAC/ANU   
+      E=(0.60)**(0.333333333)*(RE**0.50) !ventilation coefficient vapor (fv)
+      !   SELECT APPROPRIATE VALUES OF AE ACCORDING TO RE
+      IF(RE.LT.6000.0)THEN
+         AE=0.78+0.308*E
+      ELSEIF(RE.GE.6000.0.AND.RE.LT.20000.0)THEN
+         AE=0.76*E
+      ELSEIF(RE.GE.20000.0) THEN
+         AE=(0.57+9.0E-6*RE)*E
+      ENDIF
+
+
+      !  CALC HAILSTONE'S MASS (GM), MASS OF WATER (GMW) AND THE  
+      !  MASS OF ICE IN THE STONE (GMI)
+      GM=PI/6.*(D**3.)*DENSE
+      GMW=FW*GM
+      GMI=GM-GMW
+  
+      !  STORE THE MASS
+      GM1=GM
+      
+      ! NEW MASS GROWTH CALCULATIONS WITH VARIABLE RIME 
+      ! LAYER DENSITY BASED ON ZIEGLER ET AL. (1983)
+      
+      ! CALCULATE INCREASE IN MASS DUE INTERCEPTED CLD WATER, USE
+      ! ORIGINAL DIAMETER
+      GMW2=GMW+SEKDEL*(PI/4.*D**2.*VT*XW*EW)
+      DGMW=GMW2-GMW 
+      GMW=GMW2
+
+      !  CALCULATE THE INCREASE IN MASS DUE INTERCEPTED CLOUD ICE
+      GMI2=GMI+SEKDEL*(PI/4.*D**2.*VT*XI*EI)
+      DGMI=GMI2-GMI 
+      GMI=GMI2
+  
+      ! CALCULATE INCREASE IN MASS DUE TO SUBLIMATION/CONDENSATION OF 
+      ! WATER VAPOR
+      DGMV = SEKDEL*2*PI*D*AE*DI*DELRW
+      IF (DGMV .LT. 0) DGMV=0
+
+      !  CALCULATE THE TOTAL MASS CHANGE 
+      DGM=DGMW+DGMI+DGMV
+      ! CALCULATE DENSITY OF NEW LAYER, DEPENDS ON FW AND ITYPE
+      IF (ITYPE.EQ.1) THEN !DRY GROWTH
+          !If hailstone encountered supercooled water, calculate new layer density 
+          ! using Macklin form
+          IF ((DGMW.GT.0).OR.(DGMV.GT.0)) THEN
+             !MEAN CLOUD DROPLET RADIUS, ASSUME CLOUD DROPLET CONC OF 3E8 M-3 (300 CM-3)
+             DC = (0.74*XW / (3.14159*1000.*3.E8))**0.33333333 * 1.E6 !MICRONS
+             !RIME LAYER DENSITY, MACKLIN FORM
+             DENSELW = 0.11*(DC*VT / (273.16-TS))**0.76 !G CM-3
+             DENSELW = DENSELW * 1000. !KG M-3
+             !BOUND POSSIBLE DENSITIES
+             IF (DENSELW.LT.100) DENSELW=100
+             IF (DENSELW.GT.900) DENSELW=900
+          ENDIF
+          IF (DGMI.GT.0) THEN
+             !Ice collection main source of growth, so set new density layer
+             ! to value calculated from Thompson et al. 2008 snow-diameter relation
+             !Mean cloud ice/snow radius, assume concentration of 1E3 M-3
+             ! Chose 1E3 because median cloud ice concentration in 
+             ! look up table in Thompson mp code in WRF
+             DI = (0.74*XI / (3.14159*1000.*1.E3))**0.33333333 !M
+             DENSELI = 0.13 / DI  !kg m-3
+             IF (DENSELI .LT. 100) THEN
+                 DENSELI = 100.
+             ENDIF
+             IF (DENSELI .GT. 900) THEN
+                 DENSELI = 900.
+             ENDIF
+          ENDIF
+          
+          !All liquid water contributes to growth, none is soaked into center.
+          DGMW_NOSOAK = DGMW  !All liquid water contributes to growth,
+                              ! none of it is soaked into center.
+
+      ELSE !WET GROWTH
+          !Collected liquid water can soak into the stone before freezing,
+          ! increasing mass and density but leaving volume constant.
+          !Volume of current drop, before growth 
+          VOL1 = GM/DENSE
+          !Difference b/w mass of stone if density is 900 kg/m3, and
+          ! current mass
+          SOAK = 900*VOL1 - GM
+          !Liquid mass available
+          SOAKM = DGMW
+          !Soak up as much liquid as we can, up to a density of 900 kg/m3
+          IF (SOAKM.GT.SOAK) SOAKM=SOAK
+          GM = GM+SOAKM  !Mass of current drop, plus soaking
+          !New density of current drop, including soaking but before growth
+          DENSE = GM/VOL1 
+          !Mass increment of liquid water growth that doesn't
+          ! include the liquid water we just soaked into the stone.
+          DGMW_NOSOAK = DGMW - SOAKM
+          
+          !Whatever growth does occur has high density
+          DENSELW = 900.  !KG M-3
+          DENSELI = 900.
+         
+      ENDIF
+
+      !VOLUME OF NEW LAYER
+      !VOLL = (DGM) / DENSEL
+      !VOLL = (DGMI+DGMV+DGMW_NOSOAK) / DENSEL
+      !VOLL = (DGMI) / DENSELI + (DGMW_NOSOAK+DGMV) / DENSELW
+      IF (DGMI.LE.0) THEN
+         VOLL = (DGMW_NOSOAK+DGMV) / DENSELW
+      ELSE IF (DGMW.LE.0) THEN
+         VOLL = (DGMI) / DENSELI
+      ELSE
+         VOLL = (DGMI) / DENSELI + (DGMW_NOSOAK+DGMV) / DENSELW
+      ENDIF
+
+      !NEW TOTAL VOLUME, DENSITY, DIAMETER
+      VOLT = VOLL + GM/DENSE
+      !DENSE = (GM+DGM) / VOLT
+      DENSE = (GM+DGMI+DGMV+DGMW_NOSOAK) / VOLT
+      !D=D+SEKDEL*0.5*VT/DENSE*(XW*EW+XI*EI)      
+      GM = GM+DGMI+DGMW_NOSOAK+DGMV
+      D = ( (6*GM) / (PI*DENSE) )**0.33333333 
+
+  END SUBROUTINE MASSAGR
+
+
+
+  SUBROUTINE HEATBUD(TS,TSm1,TSm2,FW,TC,VT,DELRW,D,DENSA,GM1,GM,DGM,DGMW,     &
+                     DGMV,DGMI,GMW,GMI,DI,ANU,RE,AE,SEKDEL,ITYPE,P)
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  ! CALCULATE HAILSTONE'S HEAT BUDGET 
+  ! See Rasmussen and Heymsfield 1987; JAS
+  ! Original Hailcast's variable units
+  ! TS - Celsius
+  ! FW - unitless, between 0 and 1
+  ! TC - Celsius
+  ! VT - m/s
+  ! D  - m
+  ! DELRW - g/cm3 (per comment)
+  ! DENSA - g/cm3 (per comment)
+  ! GM1, DMG, DGMW, DGMV, DGMI, GMW, GMI - should all be kg
+  ! DI - cm2 / sec
+  ! P  - hPa
+  ! Original HAILCAST HEATBUD subroutine uses c-g-s units, so do some conversions
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      IMPLICIT NONE
+      REAL*8 D
+      REAL TS,TSm1,TSm2,FW,TC,VT,DELRW,DENSA,GM1,GM,DGM,DGMW,DGMV,  &
+                    DGMI,GMW,GMI,DI,ANU,RE,AE,SEKDEL,P
+      INTEGER ITYPE
+      
+      REAL RV, RD, G, PI, ALF, ALV, ALS, CI, CW, AK
+      REAL H, AH, TCC, TSC, DELRWC, DENSAC, TDIFF
+      REAL DMLT
+      REAL TSCm1, TSCm2
+      DATA RV/461.48/,RD/287.04/,G/9.78956/
+      DATA PI/3.141592654/,ALF/79.7/,ALV/597.3/
+      DATA ALS/677.0/,CI/0.5/,CW/1./
+      
+      !Convert values to non-SI units here
+      TSC = TS - 273.155
+      TSCm1 = TSm1 - 273.155
+      TSCm2 = TSm2 - 273.155
+      TCC = TC - 273.155
+      DELRWC = DELRW * (1.E3) * (1.E-6)
+      DENSAC = DENSA * (1.E3) * (1.E-6)
+      !DI still in cm2/sec
+
+
+      !  CALCULATE THE CONSTANTS 
+      AK=(5.8+0.0184*TCC)*1.E-5  !thermal conductivity - cal/(cm*sec*K)
+      !dynamic viscosity - calculated in MASSAGR
+      !ANU=1.717E-4*(393.0/(TC+120.0))*(TC/273.155)**1.5
+
+      !  CALCULATE THE REYNOLDS NUMBER - unitless
+      !RE=D*VT*DENSAC/ANU  - calculated in MASSAGR  
+      
+      H=(0.71)**(0.333333333)*(RE**0.50) !ventilation coefficient heat (fh)
+      !E=(0.60)**(0.333333333)*(RE**0.50) !ventilation coefficient vapor (fv)
+
+      !   SELECT APPROPRIATE VALUES OF AH AND AE ACCORDING TO RE
+      IF(RE.LT.6000.0)THEN
+         AH=0.78+0.308*H
+         !AE=0.78+0.308*E
+      ELSEIF(RE.GE.6000.0.AND.RE.LT.20000.0)THEN
+         AH=0.76*H
+         !AE=0.76*E
+      ELSEIF(RE.GE.20000.0) THEN
+         AH=(0.57+9.0E-6*RE)*H
+         !AE=(0.57+9.0E-6*RE)*E  calculated in MASSAGR
+      ENDIF
+
+      !  FOR DRY GROWTH FW=0, CALCULATE NEW TS, ITIPE=1 
+      !  FOR WET GROWTH TS=0, CALCULATE NEW FW, ITIPE=2
+
+
+      IF(ITYPE.EQ.1) THEN
+      !  DRY GROWTH; CALC NEW TEMP OF THE STONE 
+         !Original Hailcast algorithm (no time differencing)
+         !TSC=TSC-TSC*DGM/GM1+SEKDEL/(GM1*CI)*                &
+         !   (2.*PI*D*(AH*AK*(TCC-TSC)-AE*ALS*DI*DELRWC)+     &
+         !   DGMW/SEKDEL*(ALF+CW*TCC)+DGMI/SEKDEL*CI*TCC)
+         TSC=0.6*(TSC-TSC*DGM/GM1+SEKDEL/(GM1*CI)*                &
+            (2.*PI*D*(AH*AK*(TCC-TSC)-AE*ALS*DI*DELRWC)+     &
+            DGMW/SEKDEL*(ALF+CW*TCC)+DGMI/SEKDEL*CI*TCC)) + &
+            0.2*TSCm1 + 0.2*TSCm2
+         
+         TS = TSC+273.155
+         IF (TS.GE.273.155) THEN 
+            TS=273.155
+            TDIFF = ABS(TS-273.155)
+         ENDIF
+         TDIFF = ABS(TS-273.155)         
+         IF (TDIFF.LE.1.E-6) ITYPE=2  !NOW IN WET GROWTH
+     
+      ELSE IF (ITYPE.EQ.2) THEN
+      !  WET GROWTH; CALC NEW FW          
+         
+         IF (TCC.LT.0.) THEN
+            !Original Hailcast algorithm
+            FW=FW-FW*DGM/GM1+SEKDEL/(GM1*ALF)*               &
+                (2.*PI*D*(AH*AK*TCC-AE*ALV*DI*DELRWC)+          &
+                DGMW/SEKDEL*(ALF+CW*TCC)+DGMI/SEKDEL*CI*TCC)
+         ELSE
+            !Calculate decrease in ice mass due to melting
+            DMLT = (2.*PI*D*AH*AK*TCC + 2.*PI*D*AE*ALV*DI*DELRWC + &
+                    DGMW/SEKDEL*CW*TCC) / ALF
+            FW = (FW*GM + DMLT) / GM
+         ENDIF
+         
+         IF(FW.GT.1.)FW=1.
+         IF(FW.LT.0.)FW=0.
+
+         !IF ALL OUR ACCRETED WATER WAS FROZEN, WE ARE BACK IN DRY GROWTH
+         IF(FW.LE.1.E-6) THEN
+            ITYPE=1  
+         ENDIF
+         
+      ENDIF
+
+  END SUBROUTINE HEATBUD
+
+
+  
+  SUBROUTINE BREAKUP(DENSE,D,GM,FW)
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !  INVOKE SHEDDING SCHEME 
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+      IMPLICIT NONE
+      REAL*8 D
+      REAL DENSE, GM, FW
+      !local variables
+      REAL WATER, GMI, CRIT, WAT, PI
+      DATA PI/3.141592654/
+
+      WATER=FW*GM  !KG
+      !GMI=(GM-WATER) !KG
+
+      ! CALC CRTICAL MASS CAPABLE OF BEING "SUPPORTED" ON THE STONE'S 
+      ! SURFACE 
+      !CRIT=0.268+0.1389*GMI 
+      !CRIT=0.268*1.E-3 + 0.1389*1.E-3*GMI  !mass now in kg instead of g
+      CRIT = 1.0E-10
+
+      !IF (WATER.GT.CRIT)THEN - test now occurs outside function
+         WAT=WATER-CRIT
+         GM=GM-WAT
+         FW=(CRIT)/GM
+       
+         IF(FW.GT.1.0) FW=1.0
+         IF(FW.LT.0.0) FW=0.0
+
+         ! RECALCULATE DIAMETER AFTER SHEDDING 
+         ! Assume density remains the same
+         !DENSE=(FW*(0.1)+0.9) * 1000.  
+         D=(6.*GM/(PI*DENSE))**(0.333333333)
+      !ENDIF
+  END SUBROUTINE BREAKUP
+  
+  
+  SUBROUTINE MELT(D,TLAYER,PLAYER,RLAYER,LDEPTH,VT)
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+  !  This is a spherical hail melting estimate based on the Goyer 
+  !  et al. (1969) eqn (3).  The depth of the warm layer, estimated 
+  !  terminal velocity, and mean temperature of the warm layer are 
+  !  used.  DRB.  11/17/2003.
+  !
+  !  INPUT:  TLAYER   mean sub-cloud layer temperature (K)
+  !          PLAYER   mean sub-cloud layer pressure (Pa)
+  !          RLAYER   mean sub-cloud layer mixing ratio (kg/kg)
+  !          VT       terminal velocity of stone (m/s)
+  !  OUTPUT: D        diameter (m)
+  !          
+  !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+      IMPLICIT NONE
+
+      REAL*8 D
+      REAL TLAYER, PLAYER, RLAYER, LDEPTH, VT
+      REAL eenv, delta, ewet, de, der, wetold, wetbulb, wetbulbk
+      REAL tdclayer, tclayer, eps, b, hplayer
+      REAL*8 a
+      REAL sd, lt, ka, lf, lv, t0, dv, pi, rv, rhoice, &
+           tres, re, delt, esenv, rhosenv, essfc, rhosfc, dsig, &
+           dmdt, mass, massorg, newmass, gamma, r, rho
+      INTEGER wcnt
+      
+      !Convert temp to Celsius, calculate dewpoint in celsius
+      tclayer = TLAYER - 273.155
+      a = 2.53E11
+      b = 5.42E3
+      tdclayer = b / LOG(a*eps / (rlayer*player))
+      hplayer = player / 100.
+      
+      !Calculate partial vapor pressure
+      eps = 0.622
+      eenv = (player*rlayer) / (rlayer+eps)
+      eenv = eenv / 100.  !convert to mb
+      
+      !Estimate wet bulb temperature (C)
+      gamma = 6.6E-4*player
+      delta = (4098.0*eenv)/((tdclayer+237.7)*(tdclayer+237.7))
+      wetbulb = ((gamma*tclayer)+(delta*tdclayer))/(gamma+delta)
+      
+      !Iterate to get exact wet bulb
+      wcnt = 0
+      DO WHILE (wcnt .lt. 11)
+        ewet = 6.108*(exp((17.27*wetbulb)/(237.3 + wetbulb))) 
+        de = (0.0006355*hplayer*(tclayer-wetbulb))-(ewet-eenv)
+        der= (ewet*(.0091379024 - (6106.396/(273.155+wetbulb)**2))) &
+             - (0.0006355*hplayer)
+        wetold = wetbulb
+        wetbulb = wetbulb - de/der
+        wcnt = wcnt + 1
+        IF ((abs(wetbulb-wetold)/wetbulb.gt.0.0001)) THEN
+           EXIT
+        ENDIF
+      ENDDO
+      
+      wetbulbk = wetbulb + 273.155  !convert to K
+      ka = .02 ! thermal conductivity of air
+      lf = 3.34e5 ! latent heat of melting/fusion
+      lv = 2.5e6  ! latent heat of vaporization
+      t0 = 273.155 ! temp of ice/water melting interface
+      dv = 0.25e-4 ! diffusivity of water vapor (m2/s)
+      pi = 3.1415927
+      rv = 1004. - 287. ! gas constant for water vapor
+      rhoice = 917.0 ! density of ice (kg/m**3)
+      r = D/2. ! radius of stone (m)
+      
+      !Compute residence time in warm layer
+      tres = LDEPTH / VT
+        
+      !Calculate dmdt based on eqn (3) of Goyer et al. (1969)
+      !Reynolds number...from pg 317 of Atmo Physics (Salby 1996)
+      !Just use the density of air at 850 mb...close enough.
+      rho = 85000./(287.*TLAYER)
+      re = rho*r*VT*.01/1.7e-5
+      
+      !Temperature difference between environment and hailstone surface
+      delt = wetbulb !- 0.0 !assume stone surface is at 0C
+                            !wetbulb is in Celsius
+
+      !Difference in vapor density of air stream and equil vapor
+      !density at the sfc of the hailstone
+      esenv = 610.8*(exp((17.27*wetbulb)/  &
+               (237.3 + wetbulb))) ! es environment in Pa
+      rhosenv = esenv/(rv*wetbulbk)
+      essfc = 610.8*(exp((17.27*(t0-273.155))/  &
+               (237.3 + (t0-273.155)))) ! es environment in Pa
+      rhosfc = essfc/(rv*t0)
+      dsig = rhosenv - rhosfc
+
+      !Calculate new mass growth
+      dmdt = (-1.7*pi*r*(re**0.5)/lf)*((ka*delt)+((lv-lf)*dv*dsig))
+      IF (dmdt.gt.0.) dmdt = 0
+      mass = dmdt*tres
+      
+      !Find the new hailstone diameter
+      massorg = 1.33333333*pi*r*r*r*rhoice
+      newmass = massorg + mass
+      if (newmass.lt.0.0) newmass = 0.0
+      D = 2.*(0.75*newmass/(pi*rhoice))**0.333333333
+  END SUBROUTINE MELT
+
+  
+END MODULE module_diag_hailcast
+
+#endif
diff --git a/wrfv2_fire/phys/module_diag_misc.F b/wrfv2_fire/phys/module_diag_misc.F
index b006c143..3a86ac7b 100644
--- a/wrfv2_fire/phys/module_diag_misc.F
+++ b/wrfv2_fire/phys/module_diag_misc.F
@@ -199,7 +199,6 @@ SUBROUTINE diagnostic_output_calc(                                 &
 
    INTEGER :: i,j,k,its,ite,jts,jte,ij
    INTEGER :: idp,jdp,irc,jrc,irnc,jrnc,isnh,jsnh
-   INTEGER :: prfreq
 
    REAL              :: no_points
    REAL              :: dpsdt_sum, dmudt_sum, dardt_sum, drcdt_sum, drndt_sum
@@ -1009,15 +1008,6 @@ SUBROUTINE diagnostic_output_calc(                                 &
 
    IF ( xtime .ne. 0. ) THEN
 
-    if(diag_print.eq.1) then
-       prfreq = dt
-!      prfreq = max(2,int(dt/60.))   ! in min
-    else
-       prfreq=10                   ! in min
-    endif
-   
-    IF (MOD(nint(dt),prfreq) == 0) THEN
-
 ! COMPUTE THE NUMBER OF MASS GRID POINTS
    no_points = float((ide-ids)*(jde-jds))
 
@@ -1165,7 +1155,6 @@ SUBROUTINE diagnostic_output_calc(                                 &
    ENDIF
 #endif
 
-    ENDIF        ! print frequency
    ENDIF
 
 ! save values at this time step
diff --git a/wrfv2_fire/phys/module_diag_rasm.F b/wrfv2_fire/phys/module_diag_rasm.F
new file mode 100644
index 00000000..655d72a7
--- /dev/null
+++ b/wrfv2_fire/phys/module_diag_rasm.F
@@ -0,0 +1,1242 @@
+#if (NMM_CORE == 1)
+MODULE module_diag_rasm
+CONTAINS
+   SUBROUTINE diag_rasm_stub
+   END SUBROUTINE diag_rasm_stub
+END MODULE module_diag_rasm
+#else
+
+!WRF:MEDIATION_LAYER:PHYSICS
+
+MODULE module_diag_rasm
+!----------------------------------------------------------------------
+! RASM Climate Diagnostics - Jose Renteria, Amy Solomon, Mark Seefeldt 
+! -October 2016
+! -handling of diagnostics controlled through namelist parameters
+!----------------------------------------------------------------------
+
+CONTAINS
+
+  SUBROUTINE mean_output_calc(                    &
+        is_restart, currentTime                   &
+       ,stats_interval, output_freq, run_days     &
+       ,dt, xtime                                 &
+       ,psfc, psfc_mean, tsk, tsk_mean            &
+       ,pmsl_mean, t2, t2_mean                    &
+       ,t, p, pb, moist, ht                       & ! vars for pmsl calc
+       ,th2, th2_mean, q2, q2_mean                &
+       ,u10, u10_mean, v10, v10_mean              &
+       ,hfx, hfx_mean, lh, lh_mean                &
+       ,swdnb, swdnb_mean, glw, glw_mean          & 
+       ,lwupb, lwupb_mean, swupb, swupb_mean      &
+       ,swupt, swupt_mean, swdnt, swdnt_mean      &
+       ,lwupt, lwupt_mean, lwdnt, lwdnt_mean      &
+       ,avgoutalarm, avgOutDateStr   &
+       ,nsteps                                    &
+       ,ids, ide, jds, jde, kds, kde              &
+       ,ims, ime, jms, jme, kms, kme              &
+       ,ips, ipe, jps, jpe, kps, kpe              & ! patch  dims
+       ,i_start, i_end, j_start, j_end            &
+       ,num_tiles                                 &
+       )
+    !----------------------------------------------------------------------
+
+    ! USES:
+    USE module_utility
+    USE module_streams
+    USE module_domain, ONLY : domain_clock_get
+
+    IMPLICIT NONE
+    !======================================================================
+    ! Definitions
+    !-----------
+    !-- DT            time step (second)
+    !-- XTIME         forecast time
+    !-- ims           start index for i in memory
+    !-- ime           end index for i in memory
+    !-- jms           start index for j in memory
+    !-- jme           end index for j in memory    
+    !-- i_start       start indices for i in tile
+    !-- i_end         end indices for i in tile
+    !-- j_start       start indices for j in tile
+    !-- j_end         end indices for j in tile
+    !-- num_tiles     number of tiles
+    !
+    !======================================================================
+
+    INTEGER, INTENT(IN)                       :: ims, ime, jms, jme, kms, kme
+    INTEGER, INTENT(IN)                       :: ids, ide, jds, jde, kds, kde
+    INTEGER, INTENT(IN)                       :: ips, ipe, jps, jpe, kps, kpe
+    INTEGER, INTENT(IN)                       :: num_tiles
+    INTEGER, INTENT(IN)                       :: stats_interval
+    INTEGER, INTENT(IN)                       :: output_freq            ! interval type
+    INTEGER, INTENT(IN)                       :: run_days
+    INTEGER, DIMENSION(num_tiles), INTENT(IN) :: i_start, i_end, j_start, j_end
+    TYPE(WRFU_Time), INTENT(IN)               :: currentTime
+    TYPE(WRFU_Alarm), INTENT(INOUT)           :: avgOutAlarm
+    INTEGER, INTENT(INOUT)                    :: nsteps                 ! number of step accumulated
+    CHARACTER(*), INTENT(INOUT)               :: avgOutDateStr
+
+    INTEGER, PARAMETER :: NONE = 0
+    INTEGER, PARAMETER :: SECS = 1
+    INTEGER, PARAMETER :: MINS = 2
+    INTEGER, PARAMETER :: HRS  = 3
+    INTEGER, PARAMETER :: DAYS = 4
+    INTEGER, PARAMETER :: MONTHLY = 5
+
+    REAL, INTENT(IN)                                  :: dt, xtime
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  :: ht
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  :: psfc, tsk, t2, th2, q2 
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  :: u10, v10
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  :: hfx, lh
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  :: swdnb, glw, lwupb, swupb
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  :: swupt, swdnt, lwupt, lwdnt
+    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(IN) :: t, p, pb, moist
+    
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: psfc_mean, tsk_mean 
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: pmsl_mean, t2_mean
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: th2_mean, q2_mean
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: u10_mean, v10_mean
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: hfx_mean, lh_mean 
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: swdnb_mean, glw_mean
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: lwupb_mean, swupb_mean
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: swupt_mean, swdnt_mean
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: lwupt_mean, lwdnt_mean   
+
+    ! LOCAL  VAR
+    INTEGER     :: i, j, ij
+    REAL        :: value
+    LOGICAL     :: is_restart
+    INTEGER     :: rc
+
+    LOGICAL     :: is_reset               ! reset averages
+    LOGICAL     :: compute_avg            ! compute averages
+
+    INTEGER            :: mean_interval   ! interval (s) of mean calculations
+    
+    ! DEBUG LOCAL  VAR
+    CHARACTER (LEN=1024)  :: message
+   
+    IF ( output_freq .eq. MONTHLY) THEN  
+      mean_interval = (run_days + 1) * 24 * 60 * 60
+      WRITE(message, *) "RASM Diagnostics: Set average output to MONTHLY_INTERVAL ... "
+      CALL wrf_debug(200, message) 
+    ELSE IF (output_freq .eq. DAYS ) THEN
+      mean_interval = stats_interval  * 24 * 60 * 60
+      WRITE(message, *) "RASM Diagnostics: Set average output to DAYS  ... mean_interval (secs) =", mean_interval
+      CALL wrf_debug(200, message)   
+    ELSE IF (output_freq .eq. HRS ) THEN    
+      mean_interval =  stats_interval * 60 * 60
+      WRITE(message, *) "RASM Diagnostics: Set average output to HRS  ... mean_interval (secs) =", mean_interval
+      CALL wrf_debug(200, message)  
+    ELSE IF (output_freq .eq. MINS ) THEN    
+      mean_interval = stats_interval * 60
+      WRITE(message, *) "RASM Diagnostics: Set average output to MINS  ... mean_interval (secs) =", mean_interval
+      CALL wrf_debug(200, message)   
+    ELSE IF (output_freq .eq. SECS ) THEN 
+      mean_interval = stats_interval
+      WRITE(message, *) "RASM Diagnostics: Set average output to SECS  ... mean_interval (secs) =", mean_interval
+      CALL wrf_debug(200, message)    
+    ELSE
+      !WRITE (wrf_err_message , * )"RASM Diagnostics:: ERROR -- error -- ERROR -- error : NO valid interval provided in namelist.input, please provided"
+      !CALL wrf_error_fatal ( TRIM(wrf_err_message) )  
+    END IF
+ 
+    CALL getResetState(currentTime, xtime, dt, mean_interval, output_freq, is_reset)
+
+    IF (is_reset) THEN
+       DO ij = 1 , num_tiles
+          DO j = j_start(ij), j_end(ij)
+             DO i = i_start(ij), i_end(ij)
+                psfc_mean(i,j)=0.0
+                tsk_mean(i,j)=0.0
+                pmsl_mean(i,j)=0.0
+                t2_mean(i,j)=0.0
+                th2_mean(i,j)=0.0
+                q2_mean(i,j)=0.0
+                u10_mean(i,j)=0.0
+                v10_mean(i,j)=0.0
+                hfx_mean(i,j)=0.0
+                lh_mean(i,j)=0.0
+                swdnb_mean(i,j)=0.0
+                glw_mean(i,j)=0.0
+                lwupb_mean(i,j)=0.0
+                swupb_mean(i,j)=0.0
+                swupt_mean(i,j)=0.0
+                swdnt_mean(i,j)=0.0
+                lwupt_mean(i,j)=0.0
+                lwdnt_mean(i,j)=0.0
+             ENDDO
+          ENDDO
+       ENDDO
+
+       ! restart step count 
+       nsteps = 0.0
+
+       WRITE(message, *) "RASM Statistics: RESET accumaltions and means ..................... nsteps=", nsteps
+       CALL wrf_debug(200, message)
+
+    ENDIF
+    
+    nsteps = nsteps+1.0
+
+    WRITE(message, *) "RASM Statistics: Start accumulate .........................................................."
+    CALL wrf_debug(200, message)
+    WRITE(message, *) "RASM Statistics: nsteps=",nsteps, "time_step=", (xtime+dt/60.)*60./dt, "xtime=", xtime
+    CALL wrf_debug(200, message)  
+
+    ! Surface Pressure
+    CALL var_accum_2d(psfc,ime-ims+1,jme-jms+1,psfc_mean)
+    
+    ! Surface Skin Temperature
+    CALL var_accum_2d(tsk,ime-ims+1,jme-jms+1,tsk_mean)
+    
+    ! PMSL 
+    CALL PMSL_accum_01(ims, ime, jms, jme, kms, kme,    &
+                       ide, jde, ips, ipe, jps, jpe,    &
+                       t, p, pb, moist, ht, psfc, pmsl_mean)
+
+    ! Temperature at 2M
+    CALL var_accum_2d(t2,ime-ims+1,jme-jms+1,t2_mean)
+    
+    ! Potential Temperature at 2M
+    CALL var_accum_2d(th2,ime-ims+1,jme-jms+1,th2_mean)
+    
+    ! Water Vapor Mixing Ratio at 2M
+    CALL var_accum_2d(q2,ime-ims+1,jme-jms+1,q2_mean)
+    
+    ! U-component of Wind at 10M
+    CALL var_accum_2d(u10,ime-ims+1,jme-jms+1,u10_mean)
+
+    ! V-component of Wind at 10M
+    CALL var_accum_2d(v10,ime-ims+1,jme-jms+1,v10_mean)
+
+    ! SENSIBLE HEAT FLUX AT THE SURFACE
+    CALL var_accum_2d(hfx,ime-ims+1,jme-jms+1,hfx_mean)
+
+    ! LATENT HEAT FLUX AT THE SURFACE
+    CALL var_accum_2d(lh,ime-ims+1,jme-jms+1,lh_mean)
+
+    ! INCOMING SOLAR AT SURFACE (SHORTWAVE DOWN)
+    CALL var_accum_2d(swdnb,ime-ims+1,jme-jms+1,swdnb_mean)
+
+    ! INCOMING LONGWAVE AT SURFACE (LONGWAVE DOWN)
+    CALL var_accum_2d(glw,ime-ims+1,jme-jms+1,glw_mean)
+
+    ! OUTGOING LONGWAVE AT SURFACE (LONGWAVE FLUX UP)
+    CALL var_accum_2d(lwupb,ime-ims+1,jme-jms+1,lwupb_mean)
+
+    ! REFLECTIVE SHORTWAVE AT SURFACE 
+    CALL var_accum_2d(swupb,ime-ims+1,jme-jms+1,swupb_mean)
+
+    ! SWUPT - UPWELLING SHORTWAVE FLUX AT TOP
+    CALL var_accum_2d(swupt,ime-ims+1,jme-jms+1,swupt_mean)
+
+    ! SWDNT - DOWNWELLING SHORTWAVE FLUX AT TOP
+    CALL var_accum_2d(swdnt,ime-ims+1,jme-jms+1,swdnt_mean)
+
+    ! LWUPT - UPWELLING LONGWAVE FLUX AT TOP
+    CALL var_accum_2d(lwupt,ime-ims+1,jme-jms+1,lwupt_mean)
+
+    ! LWDNT - DOWNWELLING LONGWAVE FLUX AT TOP
+    CALL var_accum_2d(lwdnt,ime-ims+1,jme-jms+1,lwdnt_mean)
+
+    CALL getAvgState(currentTime, xtime, dt, mean_interval, output_freq, compute_avg, avgOutDateStr)
+    IF (compute_avg) THEN
+       psfc_mean=psfc_mean/nsteps
+       tsk_mean=tsk_mean/nsteps
+       pmsl_mean=pmsl_mean/nsteps
+       t2_mean=t2_mean/nsteps
+       th2_mean=th2_mean/nsteps
+       q2_mean=q2_mean/nsteps
+       u10_mean=u10_mean/nsteps
+       v10_mean=v10_mean/nsteps
+       hfx_mean=hfx_mean/nsteps
+       lh_mean=lh_mean/nsteps
+       swdnb_mean=swdnb_mean/nsteps
+       glw_mean=glw_mean/nsteps
+       lwupb_mean=lwupb_mean/nsteps
+       swupb_mean=swupb_mean/nsteps
+       swupt_mean=swupt_mean/nsteps
+       swdnt_mean=swdnt_mean/nsteps
+       lwupt_mean=lwupt_mean/nsteps
+       lwdnt_mean=lwdnt_mean/nsteps
+      
+       if ( output_freq .EQ. MONTHLY) then
+             WRITE(message, *) "RASM Statistics: MONTHLY_INTERVAL turn ON ALARM to generate output ........................"
+             CALL wrf_debug(200, message)
+       endif
+
+       CALL WRFU_AlarmRingerOn (avgOutAlarm, rc=rc)
+      
+       WRITE(message, *) "RASM Statistics: Mean computed .........................................................."
+       CALL wrf_debug(200, message)
+
+    END IF
+
+  END SUBROUTINE mean_output_calc
+
+  ! RASM: Diurnal
+  SUBROUTINE diurnalcycle_output_calc(            &
+        is_restart, currentTime                   &
+       ,dt, xtime                                 &
+       ,psfc, psfc_dtmp, tsk, tsk_dtmp            &
+       ,t2, t2_dtmp                               &
+       ,t, p, pb, moist                           & ! vars for pmsl calc
+       ,th2, th2_dtmp, q2, q2_dtmp                &
+       ,u10, u10_dtmp, v10, v10_dtmp              &
+       ,hfx, hfx_dtmp, lh, lh_dtmp                &
+       ,swdnb, swdnb_dtmp, glw, glw_dtmp          & 
+       ,lwupb, lwupb_dtmp, swupb, swupb_dtmp      &
+       ,swupt, swupt_dtmp, swdnt, swdnt_dtmp      &
+       ,lwupt, lwupt_dtmp, lwdnt, lwdnt_dtmp      &
+       ,avgoutalarm                  &
+       ,diurnOutDateStr, avg_nsteps               &
+       ,diurnal_nsteps                            &
+       ,psfc_diurn, tsk_diurn, t2_diurn           &
+       ,th2_diurn, q2_diurn, u10_diurn, v10_diurn &
+       ,hfx_diurn, lh_diurn                       &
+       ,swdnb_diurn, glw_diurn                    &
+       ,lwupb_diurn, swupb_diurn                  &
+       ,swupt_diurn, swdnt_diurn                  &
+       ,lwupt_diurn, lwdnt_diurn                  &
+       ,ids, ide, jds, jde, kds, kde              &
+       ,ims, ime, jms, jme, kms, kme              &
+       ,ips, ipe, jps, jpe, kps, kpe              & ! patch  dims
+       ,i_start, i_end, j_start, j_end            &
+       ,num_tiles         )
+
+    !----------------------------------------------------------------------
+    ! USES:
+    USE module_utility
+    USE module_domain, ONLY : domain_clock_get
+
+    IMPLICIT NONE
+    !======================================================================
+    ! Definitions
+    !-----------
+    !-- DT            time step (second)
+    !-- XTIME         forecast time
+    !-- ims           start index for i in memory
+    !-- ime           end index for i in memory
+    !-- jms           start index for j in memory
+    !-- jme           end index for j in memory    
+    !-- i_start       start indices for i in tile
+    !-- i_end         end indices for i in tile
+    !-- j_start       start indices for j in tile
+    !-- j_end         end indices for j in tile
+    !-- num_tiles     number of tiles
+    !
+    !======================================================================
+
+    INTEGER, INTENT(IN)                       :: ims, ime, jms, jme, kms, kme
+    INTEGER, INTENT(IN)                       :: ids, ide, jds, jde, kds, kde
+    INTEGER, INTENT(IN)                       :: ips, ipe, jps, jpe, kps, kpe
+   
+    INTEGER, INTENT(IN)                       :: num_tiles
+    INTEGER, DIMENSION(num_tiles), INTENT(IN) :: i_start, i_end, j_start, j_end
+    TYPE(WRFU_Time), INTENT(IN)               :: currentTime
+    TYPE(WRFU_Alarm), INTENT(INOUT)           :: avgOutAlarm
+    INTEGER, INTENT(INOUT)                    :: avg_nsteps             ! number of avg steps accumulated
+    INTEGER, INTENT(INOUT)                    :: diurnal_nsteps         ! number of diurnal steps accumulated
+    CHARACTER(*), INTENT(INOUT)               :: diurnOutDateStr
+
+    INTEGER, PARAMETER :: NONE = 0
+    INTEGER, PARAMETER :: SECS = 1
+    INTEGER, PARAMETER :: MINS = 2
+    INTEGER, PARAMETER :: HRS  = 3
+    INTEGER, PARAMETER :: DAYS = 4
+    INTEGER, PARAMETER :: MONTHLY = 5
+    INTEGER, PARAMETER :: NUM_DIURN_CYCLES = 8
+    INTEGER, PARAMETER :: DIURNAL_3HR      = 10800   ! three hour period in seconds
+
+    REAL, INTENT(IN)                                  :: dt, xtime
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  :: psfc, tsk, t2, th2, q2 
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  :: u10, v10
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  :: hfx, lh
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  :: swdnb, glw, lwupb, swupb
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(IN)  :: swupt, swdnt, lwupt, lwdnt
+    REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(IN) :: t, p, pb, moist
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: psfc_dtmp, tsk_dtmp 
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: t2_dtmp
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: th2_dtmp, q2_dtmp
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: u10_dtmp, v10_dtmp
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: hfx_dtmp, lh_dtmp 
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: swdnb_dtmp, glw_dtmp
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: lwupb_dtmp, swupb_dtmp
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: swupt_dtmp, swdnt_dtmp
+    REAL, DIMENSION( ims:ime , jms:jme ), INTENT(OUT) :: lwupt_dtmp, lwdnt_dtmp   
+   
+    REAL, DIMENSION( ims:ime, 1:NUM_DIURN_CYCLES, jms:jme ), INTENT(OUT) :: psfc_diurn, tsk_diurn
+    REAL, DIMENSION( ims:ime, 1:NUM_DIURN_CYCLES, jms:jme ), INTENT(OUT) :: t2_diurn    
+    REAL, DIMENSION( ims:ime, 1:NUM_DIURN_CYCLES, jms:jme ), INTENT(OUT) :: th2_diurn, q2_diurn
+    REAL, DIMENSION( ims:ime, 1:NUM_DIURN_CYCLES, jms:jme ), INTENT(OUT) :: u10_diurn, v10_diurn
+    REAL, DIMENSION( ims:ime, 1:NUM_DIURN_CYCLES, jms:jme ), INTENT(OUT) :: hfx_diurn, lh_diurn 
+    REAL, DIMENSION( ims:ime, 1:NUM_DIURN_CYCLES, jms:jme ), INTENT(OUT) :: swdnb_diurn, glw_diurn 
+    REAL, DIMENSION( ims:ime, 1:NUM_DIURN_CYCLES, jms:jme ), INTENT(OUT) :: lwupb_diurn, swupb_diurn 
+    REAL, DIMENSION( ims:ime, 1:NUM_DIURN_CYCLES, jms:jme ), INTENT(OUT) :: swupt_diurn, swdnt_diurn 
+    REAL, DIMENSION( ims:ime, 1:NUM_DIURN_CYCLES, jms:jme ), INTENT(OUT) :: lwupt_diurn, lwdnt_diurn 
+
+    ! LOCAL  VAR
+    INTEGER     :: i, j, k, ij
+    REAL        :: value
+    LOGICAL     :: is_restart
+    INTEGER     :: rc
+    INTEGER     :: current_diurn_cycle
+    INTEGER     :: diurnal_output_freq    ! diurnal interval type
+    INTEGER     :: mean_output_freq       ! mean interval type
+    INTEGER     :: mean_interval          ! mean interval
+    LOGICAL     :: is_avg_reset           ! reset averages
+    LOGICAL     :: is_diurnal_reset       ! reset dirurnal cycle
+    LOGICAL     :: compute_avg            ! compute averages
+    LOGICAL     :: compute_diurnalcycle   ! compute dirurnal cycle
+
+    ! DEBUG LOCAL  VAR
+    CHARACTER (LEN=1024)  :: message
+    CHARACTER (LEN=1024)  :: EmptyStr
+    LOGICAL               :: diurn_test
+    INTEGER               :: diurn_interval 
+   
+    ! initialize frequencies and intervals
+    mean_interval = DIURNAL_3HR
+    mean_output_freq = HRS
+    diurn_interval = 2 * 24 * 60 * 60 ! dummy variable only used when testing
+    diurnal_output_freq = MONTHLY
+    EmptyStr =""                      ! empty string used for processing 
+
+    ! intitialize 2 day test 
+    diurn_test = .false.       
+    ! if testing generate daily instead of monthy     
+    if (diurn_test) then
+       diurnal_output_freq = DAYS
+    else
+       diurnal_output_freq = MONTHLY
+    endif
+
+    ! get the average state
+    CALL getResetState(currentTime, xtime, dt, mean_interval, mean_output_freq, is_avg_reset)
+    IF (is_avg_reset) THEN
+       DO ij = 1 , num_tiles
+          DO j = j_start(ij), j_end(ij)
+             DO i = i_start(ij), i_end(ij)
+                psfc_dtmp(i,j)=0.0
+                tsk_dtmp(i,j)=0.0
+                t2_dtmp(i,j)=0.0
+                th2_dtmp(i,j)=0.0
+                q2_dtmp(i,j)=0.0
+                u10_dtmp(i,j)=0.0
+                v10_dtmp(i,j)=0.0
+                hfx_dtmp(i,j)=0.0
+                lh_dtmp(i,j)=0.0
+                swdnb_dtmp(i,j)=0.0
+                glw_dtmp(i,j)=0.0
+                lwupb_dtmp(i,j)=0.0
+                swupb_dtmp(i,j)=0.0
+                swupt_dtmp(i,j)=0.0
+                swdnt_dtmp(i,j)=0.0
+                lwupt_dtmp(i,j)=0.0
+                lwdnt_dtmp(i,j)=0.0
+             ENDDO
+          ENDDO
+       ENDDO
+
+       ! restart step count 
+       avg_nsteps = 0.0
+
+       WRITE(message, *) "RASM Statistics: RESET accumaltions and means ..................... avg_nsteps=", avg_nsteps
+       CALL wrf_debug(200, message)
+
+    ENDIF
+
+    ! get the diurnal state
+    CALL getResetState(currentTime, xtime, dt, diurn_interval, diurnal_output_freq, is_diurnal_reset)
+    IF (is_diurnal_reset) THEN
+       DO ij = 1 , num_tiles
+          DO k = 1 , NUM_DIURN_CYCLES
+             DO j = j_start(ij), j_end(ij)
+                DO i = i_start(ij), i_end(ij)
+                   psfc_diurn(i,k,j)=0.0
+                   tsk_diurn(i,k,j)=0.0
+                   t2_diurn(i,k,j)=0.0
+                   th2_diurn(i,k,j)=0.0
+                   q2_diurn(i,k,j)=0.0
+                   u10_diurn(i,k,j)=0.0
+                   v10_diurn(i,k,j)=0.0
+                   hfx_diurn(i,k,j)=0.0
+                   lh_diurn(i,k,j)=0.0
+                   swdnb_diurn(i,k,j)=0.0
+                   glw_diurn(i,k,j)=0.0
+                   lwupb_diurn(i,k,j)=0.0
+                   swupb_diurn(i,k,j)=0.0
+                   swupt_diurn(i,k,j)=0.0
+                   swdnt_diurn(i,k,j)=0.0
+                   lwupt_diurn(i,k,j)=0.0
+                   lwdnt_diurn(i,k,j)=0.0
+                ENDDO
+             ENDDO
+          ENDDO
+       ENDDO
+
+       ! restart step count 
+       diurnal_nsteps = 0.0
+
+       WRITE(message, *) "RASM Statistics: RESET Diurnal means ..................... diurnal_nsteps=", diurnal_nsteps
+       CALL wrf_debug(200, message)
+
+    ENDIF
+    
+    avg_nsteps = avg_nsteps+1.0
+
+    ! Surface Pressure
+    CALL var_accum_2d(psfc,ime-ims+1,jme-jms+1,psfc_dtmp)
+    
+    ! Surface Skin Temperature
+    CALL var_accum_2d(tsk,ime-ims+1,jme-jms+1,tsk_dtmp)
+    
+    ! Temperature at 2M
+    CALL var_accum_2d(t2,ime-ims+1,jme-jms+1,t2_dtmp)
+
+    ! Potential Temperature at 2M
+    CALL var_accum_2d(th2,ime-ims+1,jme-jms+1,th2_dtmp)
+
+    ! WATER VAPOR MIXING RATIO AT 2M
+    CALL var_accum_2d(q2,ime-ims+1,jme-jms+1,q2_dtmp)
+
+    ! U-COMPONENT OF WIND AT 10M
+    CALL var_accum_2d(u10,ime-ims+1,jme-jms+1,u10_dtmp)
+
+    ! V-COMPONENT OF WIND AT 10M
+    CALL var_accum_2d(v10,ime-ims+1,jme-jms+1,v10_dtmp)
+
+    ! SENSIBLE HEAT FLUX AT THE SURFACE
+    CALL var_accum_2d(hfx,ime-ims+1,jme-jms+1,hfx_dtmp)
+
+    ! LATENT HEAT FLUX AT THE SURFACE
+    CALL var_accum_2d(lh,ime-ims+1,jme-jms+1,lh_dtmp)
+
+    ! DOWNWARD SHORT WAVE FLUX AT GROUND SURFACE
+    CALL var_accum_2d(swdnb,ime-ims+1,jme-jms+1,swdnb_dtmp)
+
+    ! DOWNWARD LONG WAVE FLUX AT GROUND SURFACE
+    CALL var_accum_2d(glw,ime-ims+1,jme-jms+1,glw_dtmp)
+
+    ! UPWELLING LONGWAVE FLUX AT BOTTOM
+    CALL var_accum_2d(lwupb,ime-ims+1,jme-jms+1,lwupb_dtmp)
+
+    ! UPWELLING SHORTWAVE FLUX AT BOTTOM 
+    CALL var_accum_2d(swupb,ime-ims+1,jme-jms+1,swupb_dtmp)
+
+    ! UPWELLING SHORTWAVE FLUX AT TOP 
+    CALL var_accum_2d(swupt,ime-ims+1,jme-jms+1,swupt_dtmp)
+
+    ! DOWNWELLING SHORTWAVE FLUX AT TOP
+    CALL var_accum_2d(swdnt,ime-ims+1,jme-jms+1,swdnt_dtmp)
+
+    ! UPWELLING LONGWAVE FLUX AT TOP 
+    CALL var_accum_2d(lwupt,ime-ims+1,jme-jms+1,lwupt_dtmp)
+
+    ! DOWNWELLING LONGWAVE FLUX AT TOP
+    CALL var_accum_2d(lwdnt,ime-ims+1,jme-jms+1,lwdnt_dtmp)
+
+    ! get average state
+    CALL getAvgState(currentTime, xtime, dt, mean_interval, mean_output_freq, compute_avg, EmptyStr)
+    IF (compute_avg) THEN
+       psfc_dtmp=psfc_dtmp/avg_nsteps
+       tsk_dtmp=tsk_dtmp/avg_nsteps
+       t2_dtmp=t2_dtmp/avg_nsteps
+       th2_dtmp=th2_dtmp/avg_nsteps
+       q2_dtmp=q2_dtmp/avg_nsteps
+       u10_dtmp=u10_dtmp/avg_nsteps
+       v10_dtmp=v10_dtmp/avg_nsteps
+       hfx_dtmp=hfx_dtmp/avg_nsteps
+       lh_dtmp=lh_dtmp/avg_nsteps
+       swdnb_dtmp=swdnb_dtmp/avg_nsteps
+       glw_dtmp=glw_dtmp/avg_nsteps
+       lwupb_dtmp=lwupb_dtmp/avg_nsteps
+       swupb_dtmp=swupb_dtmp/avg_nsteps
+       swupt_dtmp=swupt_dtmp/avg_nsteps
+       swdnt_dtmp=swdnt_dtmp/avg_nsteps
+       lwupt_dtmp=lwupt_dtmp/avg_nsteps
+       lwdnt_dtmp=lwdnt_dtmp/avg_nsteps
+       
+       CALL get_diurn_cycle(currentTime, xtime, dt, current_diurn_cycle)
+       ! accummulate averages, increment counter by one
+       CALL var_accum_diurnal(psfc_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, psfc_diurn) 
+       CALL var_accum_diurnal(tsk_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, tsk_diurn)
+       CALL var_accum_diurnal(t2_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, t2_diurn)
+       CALL var_accum_diurnal(th2_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, th2_diurn)
+       CALL var_accum_diurnal(q2_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, q2_diurn)
+       CALL var_accum_diurnal(u10_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, u10_diurn)
+       CALL var_accum_diurnal(v10_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, v10_diurn)
+       CALL var_accum_diurnal(hfx_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, hfx_diurn) 
+       CALL var_accum_diurnal(lh_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, lh_diurn) 
+       CALL var_accum_diurnal(swdnb_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, swdnb_diurn) 
+       CALL var_accum_diurnal(glw_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, glw_diurn) 
+       CALL var_accum_diurnal(lwupb_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, lwupb_diurn) 
+       CALL var_accum_diurnal(swupb_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, swupb_diurn) 
+       CALL var_accum_diurnal(swupt_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, swupt_diurn) 
+       CALL var_accum_diurnal(swdnt_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, swdnt_diurn) 
+       CALL var_accum_diurnal(lwupt_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, lwupt_diurn) 
+       CALL var_accum_diurnal(lwdnt_dtmp, ime-ims+1,  NUM_DIURN_CYCLES, jme-jms+1, current_diurn_cycle, lwdnt_diurn) 
+       
+       ! increment diurnal count once a day, assuming 3hr cycles 
+       if (current_diurn_cycle .eq. 8) then
+          diurnal_nsteps = diurnal_nsteps + 1.0
+       endif
+
+    END IF
+
+    ! get Diurnal average state
+    CALL getDiurnalState(currentTime, xtime, dt, diurn_interval, diurnal_output_freq, compute_diurnalcycle, diurnOutDateStr)
+    IF (compute_diurnalcycle) THEN
+       psfc_diurn=psfc_diurn/diurnal_nsteps
+       tsk_diurn=tsk_diurn/diurnal_nsteps
+       t2_diurn=t2_diurn/diurnal_nsteps
+       th2_diurn=th2_diurn/diurnal_nsteps
+       q2_diurn=q2_diurn/diurnal_nsteps
+       u10_diurn=u10_diurn/diurnal_nsteps
+       v10_diurn=v10_diurn/diurnal_nsteps
+       hfx_diurn=hfx_diurn/diurnal_nsteps
+       lh_diurn=lh_diurn/diurnal_nsteps
+       swdnb_diurn=swdnb_diurn/diurnal_nsteps
+       glw_diurn=glw_diurn/diurnal_nsteps
+       lwupb_diurn=lwupb_diurn/diurnal_nsteps
+       swupb_diurn=swupb_diurn/diurnal_nsteps
+       swupt_diurn=swupt_diurn/diurnal_nsteps
+       swdnt_diurn=swdnt_diurn/diurnal_nsteps
+       lwupt_diurn=lwupt_diurn/diurnal_nsteps
+       lwdnt_diurn=lwdnt_diurn/diurnal_nsteps
+
+       CALL WRFU_AlarmRingerOn (avgOutAlarm, rc=rc)
+      
+       WRITE(message, *) "RASM Statistics: Diurnal Mean Cycle computed .........................................................."
+       CALL wrf_debug(200, message)
+
+    END IF
+
+  END SUBROUTINE diurnalcycle_output_calc
+
+  SUBROUTINE var_accum_diurnal(var, dx, dz, dy, current_cycle, var_accum) 
+    ! Subroutine accumulates diurnal variable
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                   :: dx, dz, dy, current_cycle
+    REAL, DIMENSION(dx,dy), INTENT(IN)         :: var
+    REAL, DIMENSION(dx, dz, dy), INTENT(INOUT) :: var_accum
+ 
+    !local
+    INTEGER :: k, i, j
+ 
+    k = current_cycle ! current cycle
+    DO j=1,dy
+       DO i=1,dx
+          var_accum(i, k, j) = var_accum(i, k, j) + var(i,j)
+       ENDDO
+    ENDDO
+
+  END SUBROUTINE var_accum_diurnal
+
+  SUBROUTINE var_accum_2d(var, dx, dy, var_accum) 
+    ! Subroutine accumulates 2D variable
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN)                   :: dx, dy
+    REAL, DIMENSION(dx,dy), INTENT(IN)    :: var
+    REAL, DIMENSION(dx,dy), INTENT(INOUT) :: var_accum
+    
+    var_accum = var_accum + var 
+
+  END SUBROUTINE var_accum_2d
+
+  SUBROUTINE var_accum_3d_01(ims, ime, jms, jme, kms, kme,    &
+                             ide, jde, ips, ipe, jps, jpe,    &
+                             var, var_accum) 
+    ! Subroutine accumulates 3D variable at lowest level resulting in 2D output
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
+    INTEGER, INTENT(IN) :: ide, jde, ips, ipe, jps, jpe
+
+    REAL, DIMENSION(  ims:ime , kms:kme, jms:jme ), INTENT(IN):: var
+    REAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: var_accum
+    
+    !local
+    INTEGER              :: k, i, j, j_end, i_end
+    CHARACTER (LEN=1024) :: message
+
+    j_end = jpe
+    i_end = ipe
+    if(j_end.eq.jde) j_end=j_end-1
+    if(i_end.eq.ide) i_end=i_end-1
+
+    k=1 ! lowest level 
+    DO j=jps, j_end            
+       DO i=ips, i_end
+          var_accum(i,j) = var_accum(i,j) + var(i,k,j)
+       ENDDO
+    ENDDO
+ 
+  END SUBROUTINE var_accum_3d_01
+
+  SUBROUTINE shum_accum_01(ims, ime, jms, jme, kms, kme,    &
+                           ide, jde, ips, ipe, jps, jpe,    &
+                           moist, var_accum) 
+    ! Subroutine accumulates specific humidity at lowest level resulting in 2D output
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
+    INTEGER, INTENT(IN) :: ide, jde, ips, ipe, jps, jpe
+
+    REAL, DIMENSION(  ims:ime , kms:kme, jms:jme ), INTENT(IN):: moist
+    REAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: var_accum
+
+    !local
+    REAL :: tmp_shum
+    INTEGER              :: k, i, j, j_end, i_end
+    CHARACTER (LEN=1024) :: message
+
+    j_end = jpe
+    i_end = ipe
+    if(j_end.eq.jde) j_end=j_end-1
+    if(i_end.eq.ide) i_end=i_end-1
+
+    k=1 ! lowest level 
+    DO j=jps, j_end            
+       DO i=ips, i_end
+          if( moist(i,k,j) .gt. 0 ) then
+             tmp_shum = moist(i,k,j) / (1+moist(i,k,j)) 
+          else
+             tmp_shum = 0.0
+          endif
+          var_accum(i,j) = var_accum(i,j) + tmp_shum
+       ENDDO
+    ENDDO
+ 
+  END SUBROUTINE shum_accum_01
+
+  SUBROUTINE T_accum_01( ims, ime, jms, jme, kms, kme,    &
+                         ide, jde, ips, ipe, jps, jpe,    &
+                         t, p, pb, t_accum) 
+    ! Subroutine accumulates Temperature at lowest level resulting in 2D output
+   
+    USE module_model_constants, only: t0,p0
+    USE shr_const_mod
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
+    INTEGER, INTENT(IN) :: ide, jde, ips, ipe, jps, jpe
+
+    REAL, DIMENSION(  ims:ime , kms:kme, jms:jme ), INTENT(IN):: t, p, pb
+    REAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: t_accum
+
+    ! local
+    REAL     :: t_tmp, cp, rd
+    INTEGER              :: k, i, j, j_end, i_end
+    CHARACTER (LEN=1024) :: message
+
+    rd=SHR_CONST_RDAIR
+    cp=SHR_CONST_CPDAIR
+
+    j_end = jpe
+    i_end = ipe
+    if(j_end.eq.jde) j_end=j_end-1
+    if(i_end.eq.ide) i_end=i_end-1
+
+    k=1 ! lowest level 
+    DO j=jps, j_end            
+       DO i=ips, i_end
+          ! calulate surface tempature at lowest level
+          t_tmp = (t(i,k,j) + t0) * (((p(i,k,j) + pb(i,k,j))/p0) ** (rd/cp))
+          ! accumulate surface tempature at lowest level
+          t_accum(i,j) = t_accum(i,j) + t_tmp
+       ENDDO
+    ENDDO
+
+  END SUBROUTINE T_accum_01
+
+
+  SUBROUTINE PMSL_accum_01( ims, ime, jms, jme, kms, kme,    &
+                            ide, jde, ips, ipe, jps, jpe,    &
+                            t, p, pb, moist, ht, psfc, pmsl_accum)
+    ! Subroutine calculates and accumulates PMSL resulting in 2D output
+   
+    USE module_model_constants, only: t0,p0
+    USE shr_const_mod
+
+    IMPLICIT NONE
+
+    INTEGER, INTENT(IN) :: ims, ime, jms, jme, kms, kme
+    INTEGER, INTENT(IN) :: ide, jde, ips, ipe, jps, jpe
+
+    REAL, DIMENSION(  ims:ime , kms:kme, jms:jme ), INTENT(IN):: t, p, pb, moist
+    REAL, DIMENSION(  ims:ime , jms:jme ), INTENT(IN):: ht, psfc
+    REAL, DIMENSION(ims:ime , jms:jme), INTENT(INOUT) :: pmsl_accum
+
+    ! local
+    REAL     :: t_tmp, tmp_pmsl, z, tv, g, cp, rd, xlapse
+    REAL     :: alpha, tstar, tt0, alph, beta, psfc_tmp, p_tmp
+    INTEGER              :: k, i, j, j_end, i_end
+    CHARACTER (LEN=1024) :: message
+
+    xlapse = 6.5D-3
+    rd=SHR_CONST_RDAIR
+    g=SHR_CONST_G
+    cp=SHR_CONST_CPDAIR
+
+    j_end = jpe
+    i_end = ipe
+    if(j_end.eq.jde) j_end=j_end-1
+    if(i_end.eq.ide) i_end=i_end-1
+
+    k=1 ! lowest level 
+    do j=jps, j_end            
+       do i=ips, i_end
+
+             ! calulate surface tempature at lowest level
+             t_tmp = (t(i,k,j) + t0) * (((p(i,k,j) + pb(i,k,j))/p0) ** (rd/cp))
+                  
+             ! calculate virtual temperature at lowest model level
+             tv = t_tmp * (1 + moist(i,k,j) * 0.61)
+
+             ! Calculate geopotential at surface in m2 s-2
+             z = ht(i,j) * g ! terrain height in m
+
+             alpha = rd * xlapse/g ! 0.1903, no units
+
+             ! Get surface pressure in Pa
+             psfc_tmp = psfc(i,j)
+
+             ! Calculate pressure in WRF at lowest model level in Pa
+             p_tmp = (p(i,k,j) + pb(i,k,j))
+
+             ! Use surface pressure for PMSL if we are at sea level.
+             if ( abs(z/g) < 1.0E-4 )then
+                tmp_pmsl = psfc_tmp
+                ! Othewise, calculate based on ECMWF method
+             else
+                tstar = tv * (1.0 + alpha * (psfc_tmp/p_tmp-1.0)) 
+                tt0 = tstar + xlapse*z/g
+
+                if ( tstar <= 290.5 .and. tt0 > 290.5 ) then     
+                   alph = rd/z * (290.5 - tstar)  
+                else if (tstar > 290.5  .and. tt0 > 290.5) then  
+                   alph = 0.0
+                   tstar = 0.5 * (290.5 + tstar)  
+                else  
+                   alph=alpha  
+                   if (tstar < 255.0) then  
+                      tstar = 0.5 * (255.0 + tstar)             
+                   endif
+                endif
+                beta = z/(rd*tstar)
+                tmp_pmsl = psfc_tmp * exp( beta*(1.0 - alph * beta/2.0 + ((alph*beta)**2)/3.0))
+             end if
+
+             ! accumulate pmsl at lowest level
+             pmsl_accum(i,j) = pmsl_accum(i,j) +  tmp_pmsl
+         
+          ENDDO
+       ENDDO
+
+  END SUBROUTINE PMSL_accum_01
+
+
+  SUBROUTINE getResetState(currentTime, xtime, dt, mean_interval, output_freq, is_reset)
+    ! Subroutine DESCRIPTION:
+    ! Determine if data stats are to be reset at the current time step
+    ! True implies that stats are reinitialized
+
+    ! USES:
+    USE module_utility
+    !USE ESMF_Mod
+
+    IMPLICIT NONE
+
+    TYPE(WRFU_Time), INTENT(IN)   :: currentTime
+    INTEGER, INTENT(IN)           :: mean_interval
+    REAL, INTENT(IN)              :: dt, xtime 
+    INTEGER, INTENT(IN)           :: output_freq
+    LOGICAL, INTENT(INOUT)        :: is_reset
+
+    INTEGER, PARAMETER :: NONE = 0
+    INTEGER, PARAMETER :: SECS = 1
+    INTEGER, PARAMETER :: MINS = 2
+    INTEGER, PARAMETER :: HRS  = 3
+    INTEGER, PARAMETER :: DAYS = 4
+    INTEGER, PARAMETER :: MONTHLY = 5
+   
+    ! LOCAL VARIABLES:
+    TYPE(WRFU_TimeInterval) :: off
+    TYPE(WRFU_Time)         :: prevTime
+ 
+    integer :: yr         !nstep year
+    integer :: mon        !nstep months (1 -> 12)   
+    integer :: prevMon    !nstep-1 months (1 -> 12)
+    integer :: day        !nstep days (1 -> 31)
+    integer :: dtime
+
+    CHARACTER (LEN=10) ::str_yr
+    CHARACTER (LEN=10) ::str_mon
+    CHARACTER (LEN=10) ::str_day
+    CHARACTER (LEN=80) ::filedate
+
+    CHARACTER (LEN=1024) :: message
+
+    dtime = INT (dt)
+
+    ! Determine if time to reset data stats
+    is_reset = .false.
+
+    if (output_freq .eq. MONTHLY) then
+       ! get date for current time_step
+       call WRFU_TimeGet( currentTime, mm=mon)   
+
+       ! get date for previous time_step
+       call WRFU_TimeIntervalSet( off, s=dtime)
+       prevTime = currentTime - off
+       call WRFU_TimeGet( prevTime, mm=prevMon)
+
+       if ( (mon-prevMon) /= 0) then
+          is_reset = .true.
+
+          WRITE(message, *) "RASM Statistics: MONTHLY_INTERVAL RESET condition met (return TRUE) "
+          CALL wrf_debug(200, message) 
+       endif
+    else
+       if ( MOD(NINT(xtime*60./dt),NINT(mean_interval/dt)) == 0 ) then
+          is_reset = .true.
+   
+          WRITE(message, *) "RASM Statistics: STATIC_INTERVAL RESET condition met (return TRUE) "
+          CALL wrf_debug(200, message) 
+       endif
+    endif
+
+  END SUBROUTINE getResetState
+
+  SUBROUTINE getAvgState(currentTime, xtime, dt, mean_interval, output_freq, compute_avg, OutDateStr)
+    ! Subroutine DESCRIPTION:
+    ! Determine if data averages are to be calculated at the current time step
+    ! True implies calculate avergaes
+
+   ! USES:
+    USE module_utility
+    !USE ESMF_Mod
+
+    IMPLICIT NONE
+
+    TYPE(WRFU_Time), INTENT(IN)   :: currentTime
+    INTEGER, INTENT(IN)           :: mean_interval
+    REAL, INTENT(IN)              :: dt, xtime 
+    INTEGER, INTENT(IN)           :: output_freq
+    LOGICAL, INTENT(INOUT)        :: compute_avg
+    CHARACTER(*), INTENT(INOUT)   :: OutDateStr
+
+    ! LOCAL VARIABLES:
+    TYPE(WRFU_TimeInterval) :: off
+    TYPE(WRFU_Time)         :: nextTime
+    TYPE(WRFU_Time)         :: prevTime
+
+    INTEGER, PARAMETER :: NONE = 0
+    INTEGER, PARAMETER :: SECS = 1
+    INTEGER, PARAMETER :: MINS = 2
+    INTEGER, PARAMETER :: HRS  = 3
+    INTEGER, PARAMETER :: DAYS = 4
+    INTEGER, PARAMETER :: MONTHLY = 5
+ 
+    integer :: yr         !nstep year
+    integer :: mon        !nstep months (1 -> 12)
+    integer :: nextMon    !nstep+1 months (1 -> 12)
+    integer :: prevMon    !nstep-1 months (1 -> 12)
+    integer :: day        !nstep days (1 -> 31)
+    integer :: hr         !nstep hrs
+    integer :: min        !nstep mins 
+    integer :: sec        !nstep secs
+    integer :: totalsec   !nstep total secs
+    integer :: dtime
+
+    CHARACTER (LEN=10) ::str_yr
+    CHARACTER (LEN=10) ::str_mon
+    CHARACTER (LEN=10) ::str_day
+    CHARACTER (LEN=10) ::str_sec
+    CHARACTER (LEN=80) ::filedate
+
+    CHARACTER (LEN=1024) :: message
+
+    dtime = INT (dt)
+
+    ! Determine if time to average data 
+    compute_avg = .false.
+    if ( output_freq .EQ. MONTHLY) then
+
+       ! get date for current time_step 
+       call WRFU_TimeGet( currentTime, mm=mon)   
+
+       ! get date for next time_step
+       call WRFU_TimeIntervalSet( off, s=dtime)
+       nextTime = currentTime + off
+       call WRFU_TimeGet( nextTime, mm=nextMon)
+
+       if ( (nextMon-mon) /= 0)  then
+          compute_avg = .true.
+
+          WRITE(message, *) "RASM Statistics: MONTHLY_INTERVAL AVG condition met (return TRUE) "
+          CALL wrf_debug(200, message) 
+       endif
+
+    else
+       if ((MOD(NINT((xtime+dt/60.)*60./dt),NINT(mean_interval/dt)) == 0)) then
+          compute_avg = .true.
+   
+          WRITE(message, *) "RASM Statistics: STATIC_INTERVAL AVG condition met (return TRUE) "
+          CALL wrf_debug(200, message) 
+       endif
+    endif
+
+    ! generate date used for hourly, min and sec averages
+    if (compute_avg) then
+       IF ( (output_freq .ne. MONTHLY)  .and. (output_freq .ne. DAYS)) THEN
+  
+          ! get date for next time_step
+          call WRFU_TimeIntervalSet( off, s=dtime)
+          nextTime = currentTime + off
+          call WRFU_TimeGet( nextTime, yy=yr, mm=mon, dd=day, h=hr, m=min, s=sec)   
+
+          WRITE(str_yr, '(I4.4)')  yr
+          WRITE(str_mon, '(I2.2)')  mon
+          WRITE(str_day, '(I2.2)')  day
+          totalsec = (hr * 60 * 60) + (min * 60) + sec 
+          WRITE(str_sec, '(I5.5)')  totalsec
+          filedate = trim(str_yr)//"-"//trim(str_mon)//"-"//trim(str_day)//"-"//trim(str_sec) 
+          OutDateStr = filedate
+
+          WRITE(message, *) "RASM Statistics:  STATIC_INTERVAL AVG condition met ......... avgOutDateStr:", trim(OutDateStr)
+          CALL wrf_debug(200, message)
+
+       ELSE IF ( output_freq .eq. MONTHLY ) THEN
+          ! get avg date 
+          call WRFU_TimeIntervalSet( off, s=dtime)
+          nextTime = currentTime + off
+          call WRFU_TimeGet( nextTime, yy=yr, mm=mon)  
+          IF (mon .eq. 1) THEN
+             mon = 12
+             yr = yr - 1
+          ELSE
+             mon = mon - 1
+          ENDIF
+          WRITE(str_yr, '(I4.4)')  yr
+          WRITE(str_mon, '(I2.2)')  mon
+          filedate = trim(str_yr)//"-"//trim(str_mon)
+          OutDateStr = filedate
+   
+          WRITE(message, *) "RASM Statistics:  AVG condition met ......... avgOutDateStr:", trim(OutDateStr)
+          CALL wrf_debug(200, message) 
+          
+       ELSE IF (output_freq .eq. DAYS ) THEN
+          ! get avg date 
+          call WRFU_TimeIntervalSet( off, s=mean_interval-dtime)
+          prevTime = currentTime - off
+          call WRFU_TimeGet( prevTime, yy=yr, mm=mon, dd=day)   
+          WRITE(str_yr, '(I4.4)')  yr
+          WRITE(str_mon, '(I2.2)')  mon
+          WRITE(str_day, '(I2.2)')  day
+          filedate = trim(str_yr)//"-"//trim(str_mon)//"-"//trim(str_day)
+          OutDateStr = filedate
+          
+          WRITE(message, *) "RASM Statistics:  AVG condition met ......... avgOutDateStr:", trim(OutDateStr)
+          CALL wrf_debug(200, message) 
+       ENDIF
+    endif
+
+  END SUBROUTINE getAvgState
+
+  SUBROUTINE getDiurnalState(currentTime, xtime, dt, diurn_interval, output_freq, compute_diurn, OutDateStr)
+    ! Subroutine DESCRIPTION:
+    ! Determine if data diurnal averages are to be calculated at the current time step
+    ! True implies that diurnal averages are to be calculated 
+
+   ! USES:
+    USE module_utility
+    !USE ESMF_Mod
+
+    IMPLICIT NONE
+
+    TYPE(WRFU_Time), INTENT(IN)   :: currentTime
+    REAL, INTENT(IN)              :: dt, xtime 
+    INTEGER, INTENT(IN)           :: output_freq
+    integer, INTENT(IN)           :: diurn_interval
+    LOGICAL, INTENT(INOUT)        :: compute_diurn
+    CHARACTER(*), INTENT(INOUT)   :: OutDateStr
+
+    INTEGER, PARAMETER :: NONE = 0
+    INTEGER, PARAMETER :: SECS = 1
+    INTEGER, PARAMETER :: MINS = 2
+    INTEGER, PARAMETER :: HRS  = 3
+    INTEGER, PARAMETER :: DAYS = 4
+    INTEGER, PARAMETER :: MONTHLY = 5
+
+    ! LOCAL VARIABLES:
+    TYPE(WRFU_TimeInterval) :: off
+    TYPE(WRFU_Time)         :: nextTime
+    TYPE(WRFU_Time)         :: prevTime
+ 
+    integer :: yr         !nstep year
+    integer :: mon        !nstep months (1 -> 12)
+    integer :: nextMon    !nstep+1 months (1 -> 12)
+    integer :: dtime
+    
+
+    CHARACTER (LEN=10) ::str_yr
+    CHARACTER (LEN=10) ::str_mon
+    CHARACTER (LEN=80) ::filedate
+
+    CHARACTER (LEN=1024) :: message
+   
+    integer :: mean_interval
+    CHARACTER (LEN=10) ::str_day
+    integer :: day        !nstep days (1 -> 31)
+
+    dtime = INT (dt)
+
+    ! Determine if time to average data 
+    compute_diurn = .false.
+   
+    if ( output_freq .EQ. MONTHLY) then
+       ! get date for current time_step 
+       call WRFU_TimeGet( currentTime, mm=mon)   
+
+       ! get date for next time_step
+       call WRFU_TimeIntervalSet( off, s=dtime)
+       nextTime = currentTime + off
+       call WRFU_TimeGet( nextTime, mm=nextMon)
+       
+       if ( (nextMon-mon) /= 0)  then
+          compute_diurn = .true.
+
+          WRITE(message, *) "RASM Statistics: Diurnal AVG condition met (return TRUE) "
+          CALL wrf_debug(200, message) 
+       endif
+    else
+       if ((MOD(NINT((xtime+dt/60.)*60./dt),NINT(diurn_interval/dt)) == 0)) then
+          compute_diurn = .true.
+   
+          WRITE(message, *) "RASM Statistics: Diurnal AVG condition met DAILY TEST (return TRUE) "
+          CALL wrf_debug(200, message) 
+       endif
+    endif
+
+    ! generate date used for hourly, min and sec averages
+    if (compute_diurn) then
+
+       if ( output_freq .EQ. MONTHLY) then
+          ! get date 
+          call WRFU_TimeIntervalSet( off, s=dtime)
+          nextTime = currentTime + off
+          call WRFU_TimeGet( nextTime, yy=yr, mm=mon)  
+          IF (mon .eq. 1) THEN
+             mon = 12
+             yr = yr - 1
+          ELSE
+             mon = mon - 1
+          ENDIF
+          WRITE(str_yr, '(I4.4)')  yr
+          WRITE(str_mon, '(I2.2)')  mon
+          filedate = trim(str_yr)//"-"//trim(str_mon)
+          OutDateStr = filedate
+   
+          WRITE(message, *) "RASM Statistics:  Diurnal ACG condition met ......... avgOutDateStr:", trim(OutDateStr)
+          CALL wrf_debug(200, message) 
+       else
+          ! get avg date 
+          call WRFU_TimeIntervalSet( off, s=diurn_interval-dtime)
+          prevTime = currentTime - off
+          call WRFU_TimeGet( prevTime, yy=yr, mm=mon, dd=day)   
+          WRITE(str_yr, '(I4.4)')  yr
+          WRITE(str_mon, '(I2.2)')  mon
+          WRITE(str_day, '(I2.2)')  day
+          filedate = trim(str_yr)//"-"//trim(str_mon)//"-"//trim(str_day)
+          OutDateStr = filedate
+          
+          WRITE(message, *) "RASM Statistics:  Diurnal AVG condition met DAILY TEST......... avgOutDateStr:", trim(OutDateStr)
+          CALL wrf_debug(200, message) 
+       endif
+    endif
+
+  END SUBROUTINE getDiurnalState
+
+  SUBROUTINE  get_diurn_cycle(currentTime, xtime, dt, diurn_cycle)
+    ! Subroutine DESCRIPTION:
+    ! Get the current diurnal cycle
+
+    ! USES:
+    USE module_utility
+    !USE ESMF_Mod
+
+    IMPLICIT NONE
+
+    TYPE(WRFU_Time), INTENT(IN)   :: currentTime
+    REAL, INTENT(IN)              :: dt, xtime 
+    INTEGER, INTENT(INOUT)        :: diurn_cycle
+
+    INTEGER, PARAMETER :: NONE = 0
+    INTEGER, PARAMETER :: SECS = 1
+    INTEGER, PARAMETER :: MINS = 2
+    INTEGER, PARAMETER :: HRS  = 3
+    INTEGER, PARAMETER :: DAYS = 4
+    INTEGER, PARAMETER :: MONTHLY = 5
+
+    ! LOCAL VARIABLES:
+    TYPE(WRFU_TimeInterval) :: off
+    TYPE(WRFU_Time)         :: nextTime
+    TYPE(WRFU_Time)         :: prevTime
+ 
+    integer :: yr         !nstep year
+    integer :: mon        !nstep months (1 -> 12)
+    integer :: day        !nstep days (1 -> 31)
+    integer :: hr         !nstep hrs
+    integer :: dtime
+
+
+    CHARACTER (LEN=1024) :: message
+
+    dtime = INT (dt)
+    diurn_cycle = -1
+
+    ! get date for next time_step
+    call WRFU_TimeIntervalSet( off, s=dtime)
+    nextTime = currentTime + off
+    call WRFU_TimeGet( nextTime, yy=yr, mm=mon, dd=day, h=hr)   
+  
+    ! This is a 3hr cycle, therfore it the diurn_cycle 
+    ! hr should be either (0,3,6,9,12,15,18 or 21)
+    if (hr .eq. 3) then
+       diurn_cycle = 1
+    else if (hr .eq. 6) then
+       diurn_cycle = 2
+    else if (hr .eq. 9) then
+       diurn_cycle = 3
+    else if (hr .eq. 12) then
+       diurn_cycle = 4
+    else if (hr .eq. 15) then
+       diurn_cycle = 5
+    else if (hr .eq. 18) then
+       diurn_cycle = 6
+    else if (hr .eq. 21) then
+       diurn_cycle = 7
+    else if (hr .eq. 0) then
+       diurn_cycle = 8
+    else
+       WRITE (message, * )"RASM Statistics:: DIURNAL ERROR -- error -- ERROR -- error : Did not find valid diurnal cycle"
+       CALL wrf_debug(0, message) 
+       WRITE (message, * )"RASM Statistics:: DIURNAL ERROR -- Valid diurnal cycles (0,3,6,9,12,15,18 or 21) ... reported ",  diurn_cycle
+       CALL wrf_error_fatal ( TRIM(message) )  
+    endif
+
+  END SUBROUTINE  get_diurn_cycle
+
+END MODULE module_diag_rasm
+#endif
diff --git a/wrfv2_fire/phys/module_diagnostics_driver.F b/wrfv2_fire/phys/module_diagnostics_driver.F
index 8fd04caf..cea4ff64 100644
--- a/wrfv2_fire/phys/module_diagnostics_driver.F
+++ b/wrfv2_fire/phys/module_diagnostics_driver.F
@@ -54,7 +54,7 @@ SUBROUTINE diagnostics_driver ( grid, config_flags,                  &
       !  This gives us the type definition for grid (domain) and some clock information.
 
 !     USE module_domain, ONLY : domain, domain_clock_get, get_ijk_from_subgrid
-      USE module_domain, ONLY : domain ,domain_get_current_time
+      USE module_domain, ONLY : domain, domain_clock_get, domain_get_current_time
 
       !  All of the information from the namelist is in config_flags.  The
       !  type declaration for this puppy must be available.  While each domain
@@ -63,6 +63,8 @@ SUBROUTINE diagnostics_driver ( grid, config_flags,                  &
       USE module_configure, ONLY : grid_config_rec_type, &
                                    model_config_rec
 
+      USE module_streams
+      USE module_utility, ONLY : WRFU_Time 
 
       !=============================================================
       !  USE Association for the Diagnostic Packages
@@ -74,7 +76,8 @@ SUBROUTINE diagnostics_driver ( grid, config_flags,                  &
       USE module_diag_pld, ONLY : pld
       USE module_diag_zld, ONLY : zld
       USE module_diag_afwa, ONLY : afwa_diagnostics_driver
-
+      USE module_diag_rasm, ONLY : mean_output_calc, diurnalcycle_output_calc
+      USE module_diag_hailcast, ONLY : hailcast_diagnostic_driver
 
       IMPLICIT NONE
 
@@ -164,6 +167,9 @@ SUBROUTINE diagnostics_driver ( grid, config_flags,                  &
 
       INTEGER :: k_start, k_end
 
+      ! Current time associated with current simulation step (RASM_DIAGS)
+
+      TYPE(WRFU_Time) :: currentTime
 
       !=============================================================
       !  Start of executable code
@@ -219,6 +225,33 @@ SUBROUTINE diagnostics_driver ( grid, config_flags,                  &
       END IF LIGHTNING
 
 
+      !WRF-HAILCAST diagnostic - hail size prediction
+      HAILCAST: IF ( config_flags%hailcast_opt /= 0 ) THEN
+
+      IF ( ( config_flags%history_interval == 0 ) ) THEN
+            WRITE (diag_message , * ) &
+            "HAILCAST Error : No 'history_interval' defined in namelist"
+            CALL wrf_error_fatal ( diag_message )
+        END IF
+
+        !$OMP PARALLEL DO   &
+        !$OMP PRIVATE ( ij )
+        DO ij = 1 , grid%num_tiles
+
+           CALL wrf_debug ( 100 ,                                             &
+             '--> CALL DIAGNOSTICS PACKAGE: HAILCAST_DIAGNOSTIC_DRIVER' )
+
+           CALL hailcast_diagnostic_driver (    grid , config_flags           &
+                         ,moist, grid%rho                                     &
+                         ,ids, ide, jds, jde, kds, kde                        &
+                         ,ims, ime, jms, jme, kms, kme                        &
+                         ,ips, ipe, jps, jpe, kps, kpe                        &
+                         ,ITS=grid%i_start(ij),ITE=grid%i_end(ij)             &
+                         ,JTS=grid%j_start(ij),JTE=grid%j_end(ij)             &
+                         ,K_START=k_start,K_END=k_end                         )
+        END DO
+        !$OMP END PARALLEL DO
+      END IF HAILCAST
 
 
       !  Mostly surface values, precip, column integrated quantities.
@@ -962,6 +995,124 @@ SUBROUTINE diagnostics_driver ( grid, config_flags,                  &
 
 
 
+      !  RASM Climate Diagnostics - mean output
+
+      RASM_DIAGS_MEAN : IF ( config_flags%mean_diag == 1 ) THEN
+
+         !IF ( ( config_flags%auxhist3_interval == 0 ) ) THEN
+         !   WRITE (diag_message , * ) &
+         !   "CLWRF: ERROR -- error -- ERROR -- error : NO 'auxhist3_interval' has been defined in 'namelist.input'"
+         !   CALL wrf_error_fatal ( diag_message )
+         !END IF
+
+         CALL wrf_debug ( 100 , '--> CALL DIAGNOSTICS PACKAGE: RASM DIAGNOSTICS - MEAN' )
+
+         CALL domain_clock_get ( grid, current_time=currentTime)
+
+         CALL mean_output_calc(                                               &
+                        is_restart=config_flags%restart                       &
+                       ,CURRENTTIME=currentTime                               &
+                       ,stats_interval=config_flags%mean_interval             &
+                       ,output_freq=config_flags%mean_freq                    &
+                       ,run_days=config_flags%run_days                        &
+                       ,DT=grid%dt, XTIME=grid%xtime                          &
+                       ,PSFC=grid%psfc, PSFC_MEAN=grid%psfc_mean              &
+                       ,TSK=grid%tsk, TSK_MEAN=grid%tsk_mean                  &
+                       ,PMSL_MEAN=grid%pmsl_mean                              &
+                       ,T2=grid%t2, T2_MEAN=grid%t2_mean                      &
+                       ,T=grid%t_2, P=grid%p, PB=grid%pb                      &
+                       ,MOIST=grid%moist(:,:,:,P_QV), HT=grid%ht              &
+                       ,TH2=grid%th2, TH2_MEAN=grid%th2_mean                  &
+                       ,Q2=grid%q2, Q2_MEAN=grid%q2_mean                      &
+                       ,U10=grid%u10, U10_MEAN=grid%u10_mean                  &
+                       ,V10=grid%v10, V10_MEAN=grid%v10_mean                  &           
+                       ,HFX=grid%hfx, HFX_MEAN=grid%hfx_mean                  &
+                       ,LH=grid%lh, LH_MEAN=grid%lh_mean                      &
+                       ,SWDNB=grid%swdnb, SWDNB_MEAN=grid%swdnb_mean          &
+                       ,GLW=grid%glw , GLW_MEAN=grid%glw_mean                 &
+                       ,LWUPB=grid%lwupb, LWUPB_MEAN=grid%lwupb_mean          &
+                       ,SWUPB=grid%swupb, SWUPB_MEAN=grid%swupb_mean          &
+                       ,SWUPT=grid%swupt, SWUPT_MEAN=grid%swupt_mean          &
+                       ,SWDNT=grid%swdnt, SWDNT_MEAN=grid%swdnt_mean          &
+                       ,LWUPT=grid%lwupt, LWUPT_MEAN=grid%lwupt_mean          &
+                       ,LWDNT=grid%lwdnt, LWDNT_MEAN=grid%lwdnt_mean          &
+                       ,AVGOUTALARM=grid%alarms(AUXHIST5_ALARM)               &
+                       ,AVGOUTDATESTR=grid%OUTDATE_MEAN                       &
+                       ,NSTEPS=grid%NSTEPS_MEAN                               &
+         ! Dimension arguments
+                       ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde     &
+                       ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme     &
+                       ,IPS=ips,IPE=ipe, JPS=jps,JPE=jpe, KPS=kps,KPE=kpe     &
+                       ,I_START=grid%i_start,I_END=min(grid%i_end, ide-1)     &
+                       ,J_START=grid%j_start,J_END=min(grid%j_end, jde-1)     &
+                       ,NUM_TILES=grid%num_tiles                              &
+                                                                      )
+      END IF RASM_DIAGS_MEAN
+
+
+
+
+      !  RASM Climate Diagnostics - diurnal output
+
+      RASM_DIAGS_DIURNAL : IF ( config_flags%diurnal_diag == 1 ) THEN
+
+         !IF ( ( config_flags%auxhist3_interval == 0 ) ) THEN
+         !   WRITE (diag_message , * ) &
+         !   "CLWRF: ERROR -- error -- ERROR -- error : NO 'auxhist3_interval' has been defined in 'namelist.input'"
+         !   CALL wrf_error_fatal ( diag_message )
+         !END IF
+
+         CALL wrf_debug ( 100 , '--> CALL DIAGNOSTICS PACKAGE: RASM DIAGNOSTICS - DIURNAL' )
+
+         CALL domain_clock_get ( grid, current_time=currentTime)
+
+         CALL diurnalcycle_output_calc(                                       &
+            is_restart=config_flags%restart                                   &
+           ,CURRENTTIME=currentTime                                           &
+           ,DT=grid%dt, XTIME=grid%xtime                                      &
+           ,PSFC=grid%psfc, PSFC_DTMP=grid%psfc_dtmp                          &
+           ,TSK=grid%tsk, TSK_DTMP=grid%tsk_dtmp                              &
+           ,T2=grid%t2, T2_DTMP=grid%t2_dtmp                                  &
+           ,T=grid%t_2, P=grid%p, PB=grid%pb, MOIST=grid%moist(:,:,:,P_QV)    &
+           ,TH2=grid%th2, TH2_DTMP=grid%th2_dtmp                              &
+           ,Q2=grid%q2, Q2_DTMP=grid%q2_dtmp                                  &
+           ,U10=grid%u10, U10_DTMP=grid%u10_dtmp                              &
+           ,V10=grid%v10, V10_DTMP=grid%v10_dtmp                              &
+           ,HFX=grid%hfx, HFX_DTMP=grid%hfx_dtmp                              &
+           ,LH=grid%lh, LH_DTMP=grid%lh_dtmp                                  &
+           ,SWDNB=grid%swdnb, SWDNB_DTMP=grid%swdnb_dtmp                      &
+           ,GLW=grid%glw, GLW_DTMP=grid%glw_dtmp                              &
+           ,LWUPB=grid%lwupb, LWUPB_DTMP=grid%lwupb_dtmp                      &
+           ,SWUPB=grid%swupb, SWUPB_DTMP=grid%swupb_dtmp                      &
+           ,SWUPT=grid%swupt, SWUPT_DTMP=grid%swupt_dtmp                      &
+           ,SWDNT=grid%swdnt, SWDNT_DTMP=grid%swdnt_dtmp                      &
+           ,LWUPT=grid%lwupt, LWUPT_DTMP=grid%lwupt_dtmp                      &
+           ,LWDNT=grid%lwdnt, LWDNT_DTMP=grid%lwdnt_dtmp                      &
+           ,AVGOUTALARM=grid%alarms(AUXHIST6_ALARM)                           &
+           ,DIURNOUTDATESTR=grid%OUTDATE_DIURN                                &
+           ,AVG_NSTEPS=grid%NSTEPSMEAN_DIURN                                  &
+           ,DIURNAL_NSTEPS=grid%NSTEPS_DIURN                                  &
+           ,PSFC_DIURN=grid%PSFC_DIURN                                        &
+           ,TSK_DIURN=grid%TSK_DIURN, T2_DIURN=grid%T2_DIURN                  &
+           ,TH2_DIURN=grid%TH2_DIURN, Q2_DIURN=grid%Q2_DIURN                  &
+           ,U10_DIURN=grid%U10_DIURN, V10_DIURN=grid%V10_DIURN                &
+           ,HFX_DIURN=grid%HFX_DIURN, LH_DIURN=grid%LH_DIURN                  &
+           ,SWDNB_DIURN=grid%SWDNB_DIURN, GLW_DIURN=grid%GLW_DIURN            &
+           ,LWUPB_DIURN=grid%LWUPB_DIURN, SWUPB_DIURN=grid%SWUPB_DIURN        &
+           ,SWUPT_DIURN=grid%SWUPT_DIURN, SWDNT_DIURN=grid%SWDNT_DIURN        &
+           ,LWUPT_DIURN=grid%LWUPT_DIURN, LWDNT_DIURN=grid%LWDNT_DIURN        &
+         ! Dimension arguments
+           ,IDS=ids, IDE=ide, JDS=jds, JDE=jde, KDS=kds, KDE=kde              &
+           ,IMS=ims, IME=ime, JMS=jms, JME=jme, KMS=kms, KME=kme              & 
+           ,IPS=ips, IPE=ipe, JPS=jps, JPE=jpe, KPS=kps, KPE=kpe              &         
+           ,I_START=grid%i_start, I_END=min(grid%i_end, ide-1)                &
+           ,J_START=grid%j_start, J_END=min(grid%j_end, jde-1)                &
+           ,NUM_TILES=grid%num_tiles                                          &
+                                                                   )
+      END IF RASM_DIAGS_DIURNAL
+
+
+
 
    END SUBROUTINE diagnostics_driver
 
diff --git a/wrfv2_fire/phys/module_fdda_psufddagd.F b/wrfv2_fire/phys/module_fdda_psufddagd.F
index 67df3491..6a64a62a 100644
--- a/wrfv2_fire/phys/module_fdda_psufddagd.F
+++ b/wrfv2_fire/phys/module_fdda_psufddagd.F
@@ -1258,7 +1258,7 @@ SUBROUTINE sfddagd(itimestep,dx,dt,xtime,  &
      !BPR END
                           ( val_analysis - qv3d(i,k,j) )
      if(k.eq.1) then
-         SDA_QFX = RQVNDGDTEN(i,k,j)
+         SDA_QFX(i,j) = RQVNDGDTEN(i,k,j)
      else
          RQVNDGDTEN(i,k,j) = 0.0
      end if
diff --git a/wrfv2_fire/phys/module_fddaobs_driver.F b/wrfv2_fire/phys/module_fddaobs_driver.F
index 46a79b91..8a91c8dc 100644
--- a/wrfv2_fire/phys/module_fddaobs_driver.F
+++ b/wrfv2_fire/phys/module_fddaobs_driver.F
@@ -53,7 +53,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart,         &
 #endif
                max_obs, nobs_ndg_vars,                           &
                nobs_err_flds, nstat, varobs, errf, dx,           &
-               KPBL, HT, mut, muu, muv,                          &
+               KPBL, HT, mut, muu, muv, c1h, c2h,                &
                msftx, msfty, msfux, msfuy, msfvx, msfvy, p_phy, t_tendf, t0,             &
                ub, vb, tb, qvb, pbase, ptop, pp, phb, ph,        &
                uratx, vratx, tratx, ru_tendf, rv_tendf,          &
@@ -144,6 +144,9 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart,         &
   REAL, INTENT(IN) :: msfvx( ims:ime , jms:jme )  ! Map scale on v-grid
   REAL, INTENT(IN) :: msfvy( ims:ime , jms:jme )  ! Map scale on v-grid
 
+  REAL, INTENT(IN) :: c1h( kms:kme )   ! Hybrid coordinate, weighting function
+  REAL, INTENT(IN) :: c2h( kms:kme )   ! Hybrid coordinate, weighting function
+
   REAL, INTENT(IN) :: p_phy( ims:ime, kms:kme, jms:jme )
   REAL, INTENT(INOUT) :: t_tendf( ims:ime, kms:kme, jms:jme )
   REAL, INTENT(IN) :: t0
@@ -350,7 +353,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart,         &
 !         write(6,*) 'calling nudob: IVAR=3, J = ',j
           CALL nudob(J, 3, t_tendf(ims,kms,j),                       &
                   inest, restart, ktau, fdob%ktaur, xtime,           &
-                  mut(ims,j), msftx(ims,j), msfty(ims,j),            &
+                  mut(ims,j), c1h, c2h, msftx(ims,j), msfty(ims,j),  &
                   nobs_ndg_vars, nobs_err_flds, max_obs, maxdom,     &
                   npfi, ionf, rinxy, fdob%window,                    &
                   fdob%nudge_t_pbl,                                  &
@@ -383,7 +386,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart,         &
 !         write(6,*) 'calling nudob: IVAR=4, J = ',j
           CALL nudob(J, 4, moist_tend(ims,kms,j),                    &
                   inest, restart, ktau, fdob%ktaur, xtime,           &
-                  mut(ims,j), msftx(ims,j), msfty(ims,j),            &
+                  mut(ims,j), c1h, c2h, msftx(ims,j), msfty(ims,j),  &
                   nobs_ndg_vars, nobs_err_flds, max_obs, maxdom,     &
                   npfi, ionf, rinxy, fdob%window,                    &
                   fdob%nudge_q_pbl,                                  &
@@ -417,7 +420,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart,         &
 !         write(6,*) 'calling nudob: IVAR=1, J = ',j
         CALL nudob(J, 1, ru_tendf(ims,kms,j),                        &
                 inest, restart, ktau, fdob%ktaur, xtime,             &
-                muu(ims,j), msfux(ims,j), msfuy(ims,j),              &
+                muu(ims,j), c1h, c2h, msfux(ims,j), msfuy(ims,j),    &
                 nobs_ndg_vars, nobs_err_flds, max_obs, maxdom,       &
                 npfi, ionf, rinxy, fdob%window,                      &
                 fdob%nudge_uv_pbl,                                   &
@@ -447,7 +450,7 @@ SUBROUTINE fddaobs_driver( inest, domid, parid, restart,         &
 !       write(6,*) 'calling nudob: IVAR=2, J = ',j
         CALL nudob(J, 2, rv_tendf(ims,kms,j),                        &
                 inest, restart, ktau, fdob%ktaur, xtime,             &
-                muv(ims,j), msfvx(ims,j), msfvy(ims,j),              &
+                muv(ims,j), c1h, c2h, msfvx(ims,j), msfvy(ims,j),    &
                 nobs_ndg_vars, nobs_err_flds, max_obs, maxdom,       &
                 npfi, ionf, rinxy, fdob%window,                      &
                 fdob%nudge_uv_pbl,                                   &
diff --git a/wrfv2_fire/phys/module_fddaobs_rtfdda.F b/wrfv2_fire/phys/module_fddaobs_rtfdda.F
index b7ffd364..c0475ae2 100644
--- a/wrfv2_fire/phys/module_fddaobs_rtfdda.F
+++ b/wrfv2_fire/phys/module_fddaobs_rtfdda.F
@@ -1,3 +1,8 @@
+#if ( HYBRID_COORD==1 )
+#define MU(...) (c1h(k)*XXPCXX(__VA_ARGS__)+c2h(k))
+#define XXPCXX(...) MU(__VA_ARGS__)
+#endif
+
 !WRF:MODEL_LAYER:PHYSICS
 !
 MODULE module_fddaobs_rtfdda
@@ -1519,7 +1524,8 @@ END FUNCTION TILE_MASK
 
 !-----------------------------------------------------------------------
   SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
-                       xtime, mu, msfx, msfy, nndgv, nerrf, niobf, maxdom,   &
+                       xtime, mu, c1h, c2h, msfx, msfy,               &
+                       nndgv, nerrf, niobf, maxdom,                   &
                        npfi, ionf, rinxy, twindo,                     &
                        nudge_pbl,                                     &
                        sfcfact, sfcfacr,                              &
@@ -1645,7 +1651,9 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
   REAL, INTENT(IN)     :: pbase( ims:ime, kms:kme )  ! Base pressure.
   REAL, INTENT(IN)     :: ptop
   REAL, INTENT(IN)     :: pp( ims:ime, kms:kme ) ! Pressure perturbation (Pa)
-  REAL, INTENT(IN)     :: mu(ims:ime)   ! Air mass on u, v, or mass-grid
+  REAL, INTENT(IN) , DIMENSION(ims:ime)    :: mu   ! Air mass on u, v, or mass-grid
+  REAL, INTENT(IN) , DIMENSION(kms:kme)    :: c1h  ! Hybrid coordinate weight
+  REAL, INTENT(IN) , DIMENSION(kms:kme)    :: c2h  ! Hybrid coordinate weight
   REAL, INTENT(IN)     :: msfx(ims:ime)  ! Map scale (only used for vars u & v)
   REAL, INTENT(IN)     :: msfy(ims:ime)  ! Map scale (only used for vars u & v)
   INTEGER, intent(in)  :: iswind        ! Nudge flag for wind
@@ -2699,7 +2707,7 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
 !            scratch = GITQ*MU(I)*W2EOWT*TFACI*ISTQ*GFACTOR
 !            write(6,*) 'ATEN calc: k = ',k
 !            write(6,*) 'T before: aten = ',aten(i,k),' scr = ',scratch
-!            write(6,*) 'GITQ = ',gitq,' MU = ',mu(i),                  &
+!            write(6,*) 'GITQ = ',gitq,' MU = ',MU(i),                  &
 !                       ' W2EOWT = ',w2eowt
 !            write(6,*) ' TFACI = ',tfaci,' ISTQ = ',istq,              &
 !                       ' GFACTOR = ',gfactor
@@ -2709,7 +2717,7 @@ SUBROUTINE nudob(j, ivar, aten, inest, ifrest, ktau, ktaur,         &
 !            scratch = GITQ*MU(I)*W2EOWT*TFACI*ISTQ*GFACTOR
 !            write(6,*) 'ATEN calc: k = ',k
 !            write(6,*) 'Q before: aten = ',aten(i,k),' scr = ',scratch
-!            write(6,*) 'GITQ = ',gitq,' MU = ',mu(i),
+!            write(6,*) 'GITQ = ',gitq,' MU = ',MU(i),
 !     $                 ' W2EOWT = ',w2eowt
 !            write(6,*) ' TFACI = ',tfaci,' ISTQ = ',istq,
 !     $                 ' GFACTOR = ',gfactor
diff --git a/wrfv2_fire/phys/module_fr_fire_atm.F b/wrfv2_fire/phys/module_fr_fire_atm.F
index 97a715cd..47cba70b 100644
--- a/wrfv2_fire/phys/module_fr_fire_atm.F
+++ b/wrfv2_fire/phys/module_fr_fire_atm.F
@@ -1,3 +1,8 @@
+#if ( HYBRID_COORD==1 )
+#  define mu(...) (c1h(k)*XXPCXX(__VA_ARGS__)+c2h(k))
+#  define XXPCXX(...) mu(__VA_ARGS__)
+#endif
+
 !WRF:MEDIATION_LAYER:FIRE_MODEL
 ! Routines dealing with the atmosphere
 
@@ -14,7 +19,7 @@ SUBROUTINE fire_tendency( &
     its,ite, kts,kte, jts,jte,   &
     grnhfx,grnqfx,canhfx,canqfx, & ! heat fluxes summed up to  atm grid 
     alfg,alfc,z1can,             & ! coeffients, properties, geometry 
-    zs,z_at_w,dz8w,mu,rho,       &
+    zs,z_at_w,dz8w,mu,c1h,c2h,rho, &
     rthfrten,rqvfrten)             ! theta and Qv tendencies 
 
 ! This routine is atmospheric physics 
@@ -36,6 +41,7 @@ SUBROUTINE fire_tendency( &
    REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: canhfx,canqfx  ! W/m^2
    REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs  ! topography (m abv sealvl)
    REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: mu  ! dry air mass (Pa)
+   REAL, INTENT(in), DIMENSION( kms:kme         ) :: c1h, c2h ! Hybrid coordinate weights
 
    REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: z_at_w ! m abv sealvl
    REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: dz8w   ! dz across w-lvl
diff --git a/wrfv2_fire/phys/module_fr_fire_driver_wrf.F b/wrfv2_fire/phys/module_fr_fire_driver_wrf.F
index 56ebcff1..ff5471ef 100644
--- a/wrfv2_fire/phys/module_fr_fire_driver_wrf.F
+++ b/wrfv2_fire/phys/module_fr_fire_driver_wrf.F
@@ -128,7 +128,7 @@ subroutine fire_driver_em_step (grid , config_flags               &
             its,ite, kts,kte, jts,jte,      & ! 
             grid%grnhfx,grid%grnqfx,grid%canhfx,grid%canqfx,        & ! fluxes on atm grid 
             config_flags%fire_ext_grnd,config_flags%fire_ext_crwn,config_flags%fire_crwn_hgt,                &
-            grid%ht,z_at_w,dz8w,grid%mut,rho,          &
+            grid%ht,z_at_w,dz8w,grid%mut,grid%c1h,grid%c2h,rho,          &
             grid%rthfrten,grid%rqvfrten)                ! out
 
      enddo
diff --git a/wrfv2_fire/phys/module_gocart_seasalt.F b/wrfv2_fire/phys/module_gocart_seasalt.F
index a565c20b..333873dd 100644
--- a/wrfv2_fire/phys/module_gocart_seasalt.F
+++ b/wrfv2_fire/phys/module_gocart_seasalt.F
@@ -61,7 +61,7 @@ subroutine gocart_seasalt_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u_p
   do j=jts,jte
   do i=its,ite
 !
-! donṫ do dust over water!!!
+! don't do dust over water!!!
 !
      if(xland(i,j).gt.1.5)then
      ilwi(1,1)=0
@@ -72,7 +72,7 @@ subroutine gocart_seasalt_driver(ktau,dt,config_flags,julday,alt,t_phy,moist,u_p
      w10m(1,1)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
      airmas(1,1)=-(p8w(i,kts+1,j)-p8w(i,kts,j))*dx*dx/g
 !
-! we donṫ trust the u10,v10 values, is model layers are very thin near surface
+! we don't trust the u10,v10 values, is model layers are very thin near surface
 !
      if(dz8w(i,kts,j).lt.12.)w10m=sqrt(u_phy(i,kts,j)*u_phy(i,kts,j)+v_phy(i,kts,j)*v_phy(i,kts,j))
 !
diff --git a/wrfv2_fire/phys/module_ltng_cpmpr92z.F b/wrfv2_fire/phys/module_ltng_cpmpr92z.F
index ce64fbe8..f93f55c3 100644
--- a/wrfv2_fire/phys/module_ltng_cpmpr92z.F
+++ b/wrfv2_fire/phys/module_ltng_cpmpr92z.F
@@ -4,7 +4,7 @@
 ! for models using convective parameterization. Assume use of sub-grid LNB.
 !
 ! Price, C., and D. Rind (1992), A Simple Lightning Parameterization for Calculating
-!   Global Lightning Distributions, J. Geophys. Res., 97(D9), 9919–9933, doi:10.1029/92JD00719.
+!   Global Lightning Distributions, J. Geophys. Res., 97(D9), 9919-9933, doi:10.1029/92JD00719.
 !
 ! Wong, J., M. Barth, and D. Noone (2012), Evaluating a Lightning Parameterization
 !   at Resolutions with Partially-Resolved Convection, GMDD, in preparation.
diff --git a/wrfv2_fire/phys/module_ltng_crmpr92.F b/wrfv2_fire/phys/module_ltng_crmpr92.F
index 83ffafdb..eea8f2b3 100644
--- a/wrfv2_fire/phys/module_ltng_crmpr92.F
+++ b/wrfv2_fire/phys/module_ltng_crmpr92.F
@@ -4,7 +4,7 @@
 ! for resolutions permitting resolved deep convection.
 !
 ! Price, C., and D. Rind (1992), A Simple Lightning Parameterization for Calculating
-!   Global Lightning Distributions, J. Geophys. Res., 97(D9), 9919–9933, doi:10.1029/92JD00719.
+!   Global Lightning Distributions, J. Geophys. Res., 97(D9), 9919-9933, doi:10.1029/92JD00719.
 !
 ! Wong, J., M. Barth, and D. Noone (2012), Evaluating a Lightning Parameterization
 !   at Resolutions with Partially-Resolved Convection, GMDD, in preparation.
@@ -230,8 +230,8 @@ END SUBROUTINE ltng_crmpr92z
 !
 ! Price and Rind 1993 base on cold cloud depth (CCD)
 !
-! Price, C. and D. Rind (1993), What determines the cloudâ€toâ€ground lightning
-! fraction in thunderstorms?, Geophys. Res. Lett., 20(6), 463–466, doi:10.1029/93GL00226.
+! Price, C. and D. Rind (1993), What determines the cloud-to-ground lightning
+! fraction in thunderstorms?, Geophys. Res. Lett., 20(6), 463-466, doi:10.1029/93GL00226.
 !
 ! Valid range of CCD is set to 5.5-14 km. Beyond this range CCD is assumed
 ! to be 5.5 or 14 for continuity.
diff --git a/wrfv2_fire/phys/module_ltng_iccg.F b/wrfv2_fire/phys/module_ltng_iccg.F
index 9a924c73..d038f4a0 100644
--- a/wrfv2_fire/phys/module_ltng_iccg.F
+++ b/wrfv2_fire/phys/module_ltng_iccg.F
@@ -82,8 +82,8 @@ END SUBROUTINE iccg_user_prescribed
 !
 ! Boccippio et al 2001 NLDN/OTD 1995-1999 CONUS climatology
 !
-! Boccippio, D. et al. 2001: Combined Satellite- and Surface-Based Estimation of the Intracloud–Cloud-to-Ground
-! Lightning Ratio over the Continental United States. Mon. Wea. Rev., 129, 108–122.
+! Boccippio, D. et al. 2001: Combined Satellite- and Surface-Based Estimation of the Intracloud-Cloud-to-Ground
+! Lightning Ratio over the Continental United States. Mon. Wea. Rev., 129, 108-122.
 ! doi: http://dx.doi.org/10.1175/1520-0493(2001)129<0108:CSASBE>2.0.CO;2
 !
 ! Areas outside U.S. uses user prescribed ratio defined by iccg_prescribed_num
@@ -170,8 +170,8 @@ END SUBROUTINE iccg_boccippio
 !
 ! Price and Rind 1993 base on cold cloud depth (CCD)
 !
-! Price, C. and D. Rind (1993), What determines the cloudâ€toâ€ground lightning
-! fraction in thunderstorms?, Geophys. Res. Lett., 20(6), 463–466, doi:10.1029/93GL00226.
+! Price, C. and D. Rind (1993), What determines the cloud-to-ground lightning
+! fraction in thunderstorms?, Geophys. Res. Lett., 20(6), 463-466, doi:10.1029/93GL00226.
 !
 ! Valid range of CCD is set to 5.5-14 km. Beyond this range CCD is assumed
 ! to be 5.5 or 14 for continuity.
@@ -194,7 +194,7 @@ SUBROUTINE iccg_pr93( &
 ! Inputs
  INTEGER, DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) :: kLNB
  REAL,                                            INTENT(IN   ) :: cldtop_adjustment
- REAL,    DIMENSION( ims:ims, kms:kme, jms:jme ), INTENT(IN   ) :: t, z
+ REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) :: t, z
 
 ! Order dependent args for domain, mem, and tile dims
  INTEGER, INTENT(IN   )    ::       ids,ide, jds,jde, kds,kde
diff --git a/wrfv2_fire/phys/module_microphysics_driver.F b/wrfv2_fire/phys/module_microphysics_driver.F
index 081d6fec..7aa54e97 100644
--- a/wrfv2_fire/phys/module_microphysics_driver.F
+++ b/wrfv2_fire/phys/module_microphysics_driver.F
@@ -47,6 +47,7 @@ SUBROUTINE microphysics_driver(                                          &
                       ,qnwfa_curr,qnifa_curr                             & ! for water/ice-friendly aerosols
                       ,f_qnwfa,f_qnifa                                   & ! for water/ice-friendly aerosols
                       ,qvolg_curr,qvolh_curr                             &
+                      ,qir_curr,qib_curr                                 & ! for P3
                       ,effr_curr,ice_effr_curr,tot_effr_curr             &
                        ,qic_effr_curr,qip_effr_curr,qid_effr_curr        &             
                       ,f_qv,f_qc,f_qr,f_qi,f_qs,f_qg,f_qndrop,f_qni      &
@@ -55,9 +56,11 @@ SUBROUTINE microphysics_driver(                                          &
                       ,f_qvolg,f_qvolh                                   &
                       ,f_qic,f_qip,f_qid &
                       ,f_qnic,f_qnip,f_qnid &
+                      ,f_qir,f_qib                                       & ! for P3
                       ,f_effr,f_ice_effr,f_tot_effr                      &
                       ,f_qic_effr,f_qip_effr,f_qid_effr                  &                 
-                      ,qrcuten, qscuten, qicuten, mu                     &
+                      ,cu_used                                           &
+                      ,qrcuten, qscuten, qicuten, qccuten                &
                       ,qt_curr,f_qt                                      &
                       ,mp_restart_state,tbpvs_state,tbpvs0_state         & ! for etampnew or fer_mp_hires
                       ,hail,ice2                                         & ! for mp_gsfcgce
@@ -73,6 +76,9 @@ SUBROUTINE microphysics_driver(                                          &
 #endif
                       ,qnwfa2d                                           & ! for water/ice-friendly aerosols
                       ,refl_10cm                                         & ! HM, 9/22/09, add for refl
+                      ,vmi3d                                             & ! for P3 
+                      ,di3d                                              & ! for P3 
+                      ,rhopo3d                                           & ! for P3 
 ! YLIN
 ! Added the RI_CURR array to the call
                       ,ri_curr                                           &
@@ -99,14 +105,14 @@ SUBROUTINE microphysics_driver(                                          &
                     ,WSM6SCHEME, ETAMPNEW, FER_MP_HIRES, etamp_HWRF,THOMPSON, THOMPSONAERO, MORR_TWO_MOMENT     &
                     ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN, NSSL_2MOMG  &
                     ,NSSL_1MOM,NSSL_1MOMLFO, FER_MP_HIRES_ADVECT &
-                    ,MILBRANDT2MOM !,MILBRANDT3MOM 
+                    ,MILBRANDT2MOM, P3_1CATEGORY, P3_1CATEGORY_NC !,MILBRANDT3MOM 
 #else
    USE module_state_description, ONLY :                                  &
                      KESSLERSCHEME, LINSCHEME, SBU_YLINSCHEME, WSM3SCHEME, WSM5SCHEME    &
                     ,WSM6SCHEME, ETAMPNEW, FER_MP_HIRES, THOMPSON, THOMPSONAERO, FAST_KHAIN_LYNN, MORR_TWO_MOMENT     &
                     ,GSFCGCESCHEME, WDM5SCHEME, WDM6SCHEME, NSSL_2MOM, NSSL_2MOMCCN, NSSL_2MOMG  &
                     ,NSSL_1MOM,NSSL_1MOMLFO, FER_MP_HIRES_ADVECT & ! ,NSSL_3MOM       &
-                    ,MILBRANDT2MOM , CAMMGMPSCHEME,FULL_KHAIN_LYNN  !,MILBRANDT3MOM
+                    ,MILBRANDT2MOM , CAMMGMPSCHEME,FULL_KHAIN_LYNN, P3_1CATEGORY, P3_1CATEGORY_NC !,MILBRANDT3MOM
 #endif
 
 #ifdef DM_PARALLEL
@@ -139,6 +145,7 @@ SUBROUTINE microphysics_driver(                                          &
    USE module_mp_fast_sbm
    USE module_mp_gsfcgce
    USE module_mp_morr_two_moment
+   USE module_mp_p3
    USE module_mp_wdm5
    USE module_mp_wdm6
    USE module_mp_milbrandt2mom
@@ -445,6 +452,7 @@ SUBROUTINE microphysics_driver(                                          &
 ! Optional
 !
    REAL, OPTIONAL, DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(OUT) :: refl_10cm
+   REAL, OPTIONAL, DIMENSION( ims:ime , kms:kme, jms:jme ) , INTENT(OUT) :: vmi3d,di3d,rhopo3d ! for P3
 
    LOGICAL,  OPTIONAL,   INTENT(IN   )    :: channel_switch
    REAL, OPTIONAL,  INTENT(INOUT   ) :: naer  ! aerosol number concentration (/kg)
@@ -460,6 +468,7 @@ SUBROUTINE microphysics_driver(                                          &
                  ,qic_curr,qip_curr,qid_curr &
                  ,qnic_curr,qnip_curr,qnid_curr &
                  ,qzr_curr,qzi_curr,qzs_curr,qzg_curr,qzh_curr    &
+                 ,qir_curr,qib_curr                               & ! for P3
                  ,effr_curr,ice_effr_curr,tot_effr_curr           &
                  ,qic_effr_curr,qip_effr_curr,qid_effr_curr           &
                   ,kext_ql,kext_qs,kext_qg          &
@@ -474,16 +483,14 @@ SUBROUTINE microphysics_driver(                                          &
 
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
          OPTIONAL,                                                &
-         INTENT(IN) :: qrcuten, qscuten, qicuten
+         INTENT(IN) :: qrcuten, qscuten, qicuten, qccuten
+   INTEGER, INTENT(IN), optional ::     cu_used
 #if ( WRF_CHEM == 1 )
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
          INTENT(INOUT) :: rainprod, evapprod
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
          INTENT(INOUT) :: qv_b4mp, qc_b4mp, qi_b4mp, qs_b4mp
 #endif
-   REAL, DIMENSION( ims:ime, jms:jme ),                           &
-         OPTIONAL,                                                &
-         INTENT(IN) :: mu
 ! YLIN
 ! Added RI_CURR similar to microphysics fields above
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
@@ -525,6 +532,7 @@ SUBROUTINE microphysics_driver(                                          &
                       ,f_qnic,f_qnip,f_qnid                                  &
                        ,f_qzi,f_qzs,f_qzg,f_qzh,f_qvolg,f_qvolh              &
                        ,f_qrimef                                             &
+                       ,f_qir,f_qib                                          & ! for P3
                        ,f_qnwfa, f_qnifa                         ! Added by G. Thompson
 
 
@@ -858,7 +866,14 @@ SUBROUTINE microphysics_driver(                                          &
                  ,REFL_10CM=refl_10cm                 &  ! added for radar reflectivity
                  ,diagflag=diagflag                   &  ! added for radar reflectivity
                  ,do_radar_ref=do_radar_ref           &  ! added for radar reflectivity
-                 ,RAINNC=rainnc)
+                 ,RAINNC=rainnc                       &
+                 ,RAINNCV=rainncv                     &
+                 ,SNOWNC=snownc                       &
+                 ,SNOWNCV=snowncv                     &
+                 ,GRAUPELNC=graupelnc                 &
+                 ,GRAUPELNCV=graupelncv               &
+                 ,SR=sr                               &
+                                         )
 
 !
        CASE (FULL_KHAIN_LYNN)
@@ -917,7 +932,16 @@ SUBROUTINE microphysics_driver(                                          &
                  ,REFL_10CM=refl_10cm                 &  ! added for radar reflectivity
                  ,diagflag=diagflag                   &  ! added for radar reflectivity
                  ,do_radar_ref=do_radar_ref           &  ! added for radar reflectivity
-                 ,RAINNC=rainnc)
+                 ,RAINNC=rainnc                       &
+                 ,RAINNCV=rainncv                     &
+                 ,SNOWNC=snownc                       &
+                 ,SNOWNCV=snowncv                     &
+                 ,GRAUPELNC=graupelnc                 &
+                 ,GRAUPELNCV=graupelncv               &
+                 ,HAILNC=hailnc                       &
+                 ,HAILNCV=hailncv                     &
+                 ,SR=sr                               &
+                                                      )
 #endif
 
 !
@@ -930,7 +954,7 @@ SUBROUTINE microphysics_driver(                                          &
          PRESENT (QR_CURR) .AND. PRESENT (QI_CURR) .AND. &
          PRESENT (QNS_CURR) .AND. PRESENT (QNI_CURR).AND. &
          PRESENT (QNR_CURR) .AND. PRESENT (QNG_CURR).AND. &
-         PRESENT (MU) .AND. PRESENT (QSCUTEN).AND. &
+         PRESENT (QSCUTEN).AND. &
          PRESENT (QRCUTEN) .AND. PRESENT (QICUTEN).AND. &
          PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. &
          PRESENT ( W      )  ) THEN
@@ -967,7 +991,6 @@ SUBROUTINE microphysics_driver(                                          &
                     ,qrcuten=qrcuten                     &  ! hm
                     ,qscuten=qscuten                     &  ! hm
                     ,qicuten=qicuten                     &  ! hm
-                    ,mu=mu                          &  ! hm
                     ,F_QNDROP=f_qndrop                   &  ! hm for wrf-chem
                  ,QNDROP=qndrop_curr                     &  ! hm for wrf-chem
                  ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
@@ -983,6 +1006,105 @@ SUBROUTINE microphysics_driver(                                          &
            Call wrf_error_fatal( 'arguments not present for calling morrison two moment')
         ENDIF
 
+#if (EM_CORE==1)
+    CASE (P3_1CATEGORY)
+         CALL wrf_debug(100, 'microphysics_driver: calling p3 one category')
+!         IF (PRESENT (QV_CURR) .AND. PRESENT (QC_CURR) .AND. &
+!             PRESENT (QR_CURR) .AND. PRESENT (QI_CURR) .AND. &
+!         PRESENT (QNG_CURR) .AND. &
+!         PRESENT (QNC_CURR) .AND. PRESENT (QNI_CURR).AND. &
+!         PRESENT (QNR_CURR) .AND. &
+!         PRESENT (QSCUTEN).AND. &
+!         PRESENT (QRCUTEN) .AND. PRESENT (QICUTEN).AND. &
+!         PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. &
+!         PRESENT (Z      ) .AND.PRESENT ( W      )  ) THEN
+
+         CALL mp_p3_wrapper_wrf(                         &
+                     ITIMESTEP=itimestep,                &
+                     TH_3d=th,                            &
+                     QV_3d=qv_curr,                       &
+                     QC_3d=qc_curr,                       &
+                     QR_3d=qr_curr,                       &
+                     QNR_3d=qnr_curr,                     &
+                     QI1_3d=qi_curr,                     &
+                     QIR1_3d=qir_curr,                    &
+                     QNI1_3d=qni_curr,                   &
+                     QIB1_3d=qib_curr,                 &
+                     th_old_3d=th_old,                 &
+                     qv_old_3d=qv_old,                 &
+                     PII=pi_phy,                         &
+                     P=p,                                &
+                     DT=dt,                           &
+                     DZ=dz8w,                            &
+                     W=w                                 &
+                    ,RAINNC=RAINNC                       &
+                    ,RAINNCV=RAINNCV                     &
+                    ,SR=SR                               &
+                    ,SNOWNC=SNOWNC                       &
+                    ,SNOWNCV=SNOWNCV                     &
+                    ,N_ICECAT=1                     &
+                 ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
+                 ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
+                 ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
+                 ,diag_zdbz_3d=refl_10cm,                                 &
+                     diag_effc_3d=re_cloud,                    &
+                     diag_effi_3d=re_ice                       &
+                 ,diag_vmi_3d=vmi3d                                       &
+                 ,diag_di_3d=di3d                                         &
+                 ,diag_rhopo_3d=rhopo3d                                   &
+                                                                    )
+!        ELSE
+!           Call wrf_error_fatal( 'arguments not present for calling p3 one category')
+!        ENDIF
+
+    CASE (P3_1CATEGORY_NC)
+         CALL wrf_debug(100, 'microphysics_driver: calling p3 one category')
+!         IF (PRESENT (QV_CURR) .AND. PRESENT (QC_CURR) .AND. &
+!             PRESENT (QR_CURR) .AND. PRESENT (QI_CURR) .AND. &
+!         PRESENT (QNG_CURR) .AND. &
+!         PRESENT (QNC_CURR) .AND. PRESENT (QNI_CURR).AND. &
+!         PRESENT (QNR_CURR) .AND. &
+!         PRESENT (QSCUTEN).AND. &
+!         PRESENT (QRCUTEN) .AND. PRESENT (QICUTEN).AND. &
+!         PRESENT (RAINNC ) .AND. PRESENT (RAINNCV) .AND. &
+!         PRESENT (Z      ) .AND.PRESENT ( W      )  ) THEN
+
+         CALL mp_p3_wrapper_wrf(                         &
+                     ITIMESTEP=itimestep,                &
+                     TH_3d=th,                            &
+                     QV_3d=qv_curr,                       &
+                     QC_3d=qc_curr,                       &
+                     QR_3d=qr_curr,                       &
+                     QNR_3d=qnr_curr,                     &
+                     QI1_3d=qi_curr,                     &
+                     QIR1_3d=qir_curr,                    &
+                     QNI1_3d=qni_curr,                   &
+                     QIB1_3d=qib_curr,                 &
+                     th_old_3d=th_old,                 &
+                     qv_old_3d=qv_old,                 &
+                     nc_3d=qnc_curr,                   &
+                     PII=pi_phy,                         &
+                     P=p,                                &
+                     DT=dt,                           &
+                     DZ=dz8w,                            &
+                     W=w                                 &
+                    ,RAINNC=RAINNC                       &
+                    ,RAINNCV=RAINNCV                     &
+                    ,SR=SR                               &
+                    ,SNOWNC=SNOWNC                       &
+                    ,SNOWNCV=SNOWNCV                     &
+                    ,N_ICECAT=1                     &
+                 ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
+                 ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
+                 ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
+                 ,diag_zdbz_3d=refl_10cm,                                 &
+                     diag_effc_3d=re_cloud,                    &
+                     diag_effi_3d=re_ice                       &
+                 ,diag_vmi_3d=vmi3d                                       &
+                 ,diag_di_3d=di3d                                         &
+                 ,diag_rhopo_3d=rhopo3d                                   &
+                                                                    )
+#endif
 
     CASE (MILBRANDT2MOM)
          CALL wrf_debug(100, 'microphysics_driver: calling milbrandt2mom')
@@ -1119,12 +1241,12 @@ SUBROUTINE microphysics_driver(                                          &
                      QS=qs_curr,                         &
                      QH=qg_curr,                         &
                      QHL=qh_curr,                        &
-                     CCW=qnc_curr,                       &
-                     CRW=qnr_curr,                       &
-                     CCI=qni_curr,                       &
-                     CSW=qns_curr,                       &
-                     CHW=qng_curr,                       &
-                     CHL=qnh_curr,                       &
+!                     CCW=qnc_curr,                       &
+!                     CRW=qnr_curr,                       &
+!                     CCI=qni_curr,                       &
+!                     CSW=qns_curr,                       &
+!                     CHW=qng_curr,                       &
+!                     CHL=qnh_curr,                       &
                      VHW=qvolg_curr,                     &
                      PII=pi_phy,                         &
                      P=p,                                &
@@ -1260,6 +1382,11 @@ SUBROUTINE microphysics_driver(                                          &
 #endif
                      nssl_progn=nssl_progn,              &
                      diagflag = diagflag,                &
+                     cu_used=cu_used,                    &
+                     qrcuten=qrcuten,                    &  ! hm
+                     qscuten=qscuten,                    &  ! hm
+                     qicuten=qicuten,                    &  ! hm
+                     qccuten=qccuten,                    &  ! hm
                      re_cloud=re_cloud,                  &
                      re_ice=re_ice,                      &
                      re_snow=re_snow,                    &
@@ -1330,6 +1457,11 @@ SUBROUTINE microphysics_driver(                                          &
 #endif
                      nssl_progn=nssl_progn,              &
                       diagflag = diagflag,               &
+                     cu_used=cu_used,                    &
+                     qrcuten=qrcuten,                    &  ! hm
+                     qscuten=qscuten,                    &  ! hm
+                     qicuten=qicuten,                    &  ! hm
+                     qccuten=qccuten,                    &  ! hm
                      re_cloud=re_cloud,                  &
                      re_ice=re_ice,                      &
                      re_snow=re_snow,                    &
@@ -1407,6 +1539,11 @@ SUBROUTINE microphysics_driver(                                          &
 #endif
                      nssl_progn=nssl_progn,              &
                      diagflag = diagflag,                &
+                     cu_used=cu_used,                    &
+                     qrcuten=qrcuten,                    &  ! hm
+                     qscuten=qscuten,                    &  ! hm
+                     qicuten=qicuten,                    &  ! hm
+                     qccuten=qccuten,                    &  ! hm
                      re_cloud=re_cloud,                  &
                      re_ice=re_ice,                      &
                      re_snow=re_snow,                    &
@@ -1664,6 +1801,9 @@ SUBROUTINE microphysics_driver(                                          &
                  ,IDS=ids,IDE=ide, JDS=jds,JDE=jde, KDS=kds,KDE=kde &
                  ,IMS=ims,IME=ime, JMS=jms,JME=jme, KMS=kms,KME=kme &
                  ,ITS=its,ITE=ite, JTS=jts,JTE=jte, KTS=kts,KTE=kte &
+#ifdef WRF_CHEM
+                 ,EVAPPROD=evapprod,RAINPROD=rainprod               &
+#endif
                                                                     )
              ELSE
                 CALL wrf_error_fatal ( 'arguments not present for calling wsm6' )
diff --git a/wrfv2_fire/phys/module_mp_fast_sbm.F b/wrfv2_fire/phys/module_mp_fast_sbm.F
index cbcd6d30..264ca13b 100644
--- a/wrfv2_fire/phys/module_mp_fast_sbm.F
+++ b/wrfv2_fire/phys/module_mp_fast_sbm.F
@@ -15,7 +15,6 @@ MODULE module_mp_fast_sbm
 !-----------------------------------------------------------------------
 ! BARRY
       INTEGER,PRIVATE,PARAMETER :: REMSAT = 0
-!     LOGICAL, PRIVATE,PARAMETER : : ICEPROCS=.FALSE.,BULKNUC=.TRUE.  
       INTEGER, PRIVATE,PARAMETER :: IBREAKUP=1
       INTEGER, PRIVATE,PARAMETER :: p_ff1i01=2, p_ff1i33=34,p_ff5i01=35,p_ff5i33=67,p_ff6i01=68,&
      & p_ff6i33=100,p_ff8i01=101,p_ff8i33=133
@@ -174,7 +173,7 @@ SUBROUTINE FAST_SBM (w,u,v,th_old,                                &
      &                      ims,ime, jms,jme, kms,kme,		        &
      &                      its,ite, jts,jte, kts,kte,                  &
      &                      refl_10cm, diagflag, do_radar_ref,      & ! GT added for reflectivity calcs
-     &                      RAINNC                             )
+     &                      RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,SR )
 !-----------------------------------------------------------------------
       IMPLICIT NONE
 !-----------------------------------------------------------------------
@@ -227,7 +226,7 @@ SUBROUTINE FAST_SBM (w,u,v,th_old,                                &
       REAL, INTENT(INOUT),  DIMENSION(ims:ime, kms:kme, jms:jme)::      &
      &                      th_phy
       REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
-     &                                                   RAINNC
+     &      RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,SR
 !     REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
 !     REAL,                 DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
 !    &              LIQUEXP,ICEEXP,SNOWEXP,GRAUEXP,HAILEXP
@@ -1271,11 +1270,17 @@ SUBROUTINE FAST_SBM (w,u,v,th_old,                                &
       DO j = jts,jte
       DO i = its,ite
        krr=0
+       RAINNCV(I,J)=0.
+       SNOWNCV(I,J)=0.
+       GRAUPELNCV(I,J)=0.
        DO KR=p_ff1i01,p_ff1i33
         krr=krr+1
         DELTAW=VR1(KRR)
         RAINNC(I,J)=RAINNC(I,J) &
      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
+        RAINNCV(I,J)= RAINNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
      &           chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
        END DO
        KRR=0
@@ -1284,6 +1289,15 @@ SUBROUTINE FAST_SBM (w,u,v,th_old,                                &
         DELTAW=VR3(KRR)
         RAINNC(I,J)=RAINNC(I,J) &
      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
+        RAINNCV(I,J)=RAINNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
+        SNOWNC(I,J)=SNOWNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
+        SNOWNCV(I,J)= SNOWNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
      &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
        END DO
        KRR=0
@@ -1292,6 +1306,15 @@ SUBROUTINE FAST_SBM (w,u,v,th_old,                                &
         DELTAW=VR4(KRR)
         RAINNC(I,J)=RAINNC(I,J) &
      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
+        RAINNCV(I,J)=RAINNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
+        GRAUPELNC(I,J)=GRAUPELNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
+        GRAUPELNCV(I,J)= GRAUPELNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
      &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
        END DO
       do k=kts,kte
@@ -1319,6 +1342,7 @@ SUBROUTINE FAST_SBM (w,u,v,th_old,                                &
           enddo
          endif
          ENDIF
+         SR(I,J) = (SNOWNCV(I,J)+GRAUPELNCV(I,J))/(RAINNCV(I,J)+1.e-12)
 
 !     print*, i,j,rainnc(i,j)
       END DO
diff --git a/wrfv2_fire/phys/module_mp_full_sbm.F b/wrfv2_fire/phys/module_mp_full_sbm.F
index b31dc849..a491a15f 100644
--- a/wrfv2_fire/phys/module_mp_full_sbm.F
+++ b/wrfv2_fire/phys/module_mp_full_sbm.F
@@ -15,7 +15,6 @@ MODULE module_mp_full_sbm
 !-----------------------------------------------------------------------
 ! BARRY
       INTEGER,PRIVATE,PARAMETER :: REMSAT = 0
-!     LOGICAL, PRIVATE,PARAMETER : : ICEPROCS=.FALSE.,BULKNUC=.TRUE.  
       INTEGER, PRIVATE,PARAMETER :: IBREAKUP=1
       LOGICAL, PRIVATE,PARAMETER :: CONSERV=.TRUE.
 ! SET ONE = TRUE
@@ -205,7 +204,7 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
      &                      ims,ime, jms,jme, kms,kme,		        &
      &                      its,ite, jts,jte, kts,kte,                  &
      &                      refl_10cm, diagflag, do_radar_ref,      & ! MO added for reflectivity calcs
-     &                      RAINNC                             )
+     &                      RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,HAILNC,HAILNCV,SR )
 !-----------------------------------------------------------------------
       IMPLICIT NONE
 !-----------------------------------------------------------------------
@@ -289,7 +288,7 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
       REAL, INTENT(INOUT),  DIMENSION(ims:ime, kms:kme, jms:jme)::      &
      &                      th_phy
       REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
-     &                                                   RAINNC
+     &     RAINNC,RAINNCV,SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,HAILNC,HAILNCV,SR
 !     REAL, INTENT(INOUT),  DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
 !     REAL,                 DIMENSION(ims:ime,jms:jme), OPTIONAL ::     &
 !    &              LIQUEXP,ICEEXP,SNOWEXP,GRAUEXP,HAILEXP
@@ -886,7 +885,7 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
  !        IF (QQA.LE.0)print*,'tta = ',tta
  !        IF (QQA.LE.0)print*,'tt = ',tt
  !        IF (QQA.LE.0)print*,'qq = ',qq
- !        IF (QQA.LE.0)QQA=1.D-10
+          IF (QQA.LE.0)QQA=1.D-10
          ES1N=AA1_MY*DEXP(-BB1_MY/TT)
          ES2N=AA2_MY*DEXP(-BB2_MY/TT)
          EW1N=QQ*PP/(0.622+0.378*QQ)
@@ -919,7 +918,9 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
           DIV2=DIV2+DELDIV2
           END IF
 !959       format (' ',i3,1x,f7.1,1x,f6.1,1x,f6.4,1x,f6.2,1x,f6.3)
-          IF (DIV1.GT.DIV2.AND.TT.LE.265)THEN
+!         IF (DIV1.GT.DIV2.AND.TT.LE.265)THEN
+! Jin-Fang Yin
+          IF ((DIV1 - DIV2) .GE. 1.0*10e-24 .AND.TT.LE.265)THEN
 !          print*,'div1 > div2',div1,div2
 !          print*,'delsup1, delsup2 = ',delsup1,delsup2
 !          print*,'del1in, del2in = ',del1in,del2in
@@ -1033,7 +1034,7 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
 ! Avoid Diffusional Growth
 !         IF (T_OLD(I,K,J).GE.237)THEN     
 ! Same temperature range as above.
-!         IF (T_OLD(I,K,J).GT.233)THEN
+          IF (T_OLD(I,K,J).GT.233)THEN
           IF(ISYM1.EQ.1.AND.((TT-273.15).GT.-0.187.OR. &
      &     (ISYM2.EQ.0.AND. &
      &     ISYM3.EQ.0.AND.ISYM4.EQ.0.AND.ISYM5.EQ.0)))THEN
@@ -1078,7 +1079,7 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
      &      ,ISYM1,ISYM2,ISYM3,ISYM4,ISYM5)
           END IF
           END IF
-!         END IF
+          END IF
              IF (IKL.EQ.NCOND)CALL COAL_BOTT_NEW(FF1R,FF2R,FF3R, &
      &       FF4R,FF5R,TT,QQ,PP,rhocgs(I,K,J),dt_coll,TCRIT,TTCOAL)
          END DO
@@ -1675,11 +1676,18 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
       DO j = jts,jte
       DO i = its,ite
        krr=0
+       RAINNCV(I,J)=0.
+       SNOWNCV(I,J)=0.
+       GRAUPELNCV(I,J)=0.
+       HAILNCV(I,J)=0.
        DO KR=p_ff1i01,p_ff1i33
         krr=krr+1
         DELTAW=VR1(KRR)
         RAINNC(I,J)=RAINNC(I,J) &
      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
+        RAINNCV(I,J)= RAINNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
      &           chem_new(I,1,J,KR)*XL(KRR)*XL(KRR)
        END DO
        KRR=0
@@ -1688,6 +1696,15 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
         DELTAW=VR3(KRR)
         RAINNC(I,J)=RAINNC(I,J) &
      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
+        RAINNCV(I,J)=RAINNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
+        SNOWNC(I,J)=SNOWNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
+        SNOWNCV(I,J)= SNOWNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
      &           chem_new(I,1,J,KR)*XS(KRR)*XS(KRR)
        END DO
        KRR=0
@@ -1696,6 +1713,15 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
         DELTAW=VR4(KRR)
         RAINNC(I,J)=RAINNC(I,J) &
      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
+        RAINNCV(I,J)=RAINNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
+        GRAUPELNC(I,J)=GRAUPELNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
+        GRAUPELNCV(I,J)=  GRAUPELNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
      &           chem_new(I,1,J,KR)*XG(KRR)*XG(KRR)
        END DO
        KRR=0
@@ -1704,6 +1730,15 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
         DELTAW=VR2(KRR,1)
         RAINNC(I,J)=RAINNC(I,J) &
      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
+        RAINNCV(I,J)=RAINNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
+        SNOWNC(I,J)=SNOWNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
+        SNOWNCV(I,J)=SNOWNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
      &           chem_new(I,1,J,KR)*XI(KRR,1)*XI(KRR,1)
        END DO
        KRR=0
@@ -1712,6 +1747,15 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
         DELTAW=VR2(KRR,2)
         RAINNC(I,J)=RAINNC(I,J) &
      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
+        RAINNCV(I,J)=RAINNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
+        SNOWNC(I,J)=SNOWNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
+        SNOWNCV(I,J)=SNOWNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
      &           chem_new(I,1,J,KR)*XI(KRR,2)*XI(KRR,2)
        END DO
        KRR=0
@@ -1720,6 +1764,15 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
         DELTAW=VR2(KRR,3)
         RAINNC(I,J)=RAINNC(I,J) &
      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
+        RAINNCV(I,J)=RAINNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
+        SNOWNC(I,J)=SNOWNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
+        SNOWNCV(I,J)=SNOWNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
      &           chem_new(I,1,J,KR)*XI(KRR,3)*XI(KRR,3)
        END DO
        KRR=0
@@ -1728,6 +1781,15 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
         DELTAW=VR5(KRR)
         RAINNC(I,J)=RAINNC(I,J) &
      &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
+        RAINNCV(I,J)=RAINNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
+        HAILNC(I,J)=HAILNC(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
+     &           chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
+        HAILNCV(I,J)= HAILNCV(I,J) &
+     &  +10*(3./RO1BL(KRR))*COL*DT*DELTAW* &
      &           chem_new(I,1,J,KR)*XH(KRR)*XH(KRR)
        END DO
 !     print*, i,j,rainnc(i,j)
@@ -1758,6 +1820,7 @@ SUBROUTINE SBM (w,u,v,th_old,                                &
           enddo
          endif
          ENDIF
+         SR(I,J) = (SNOWNCV(I,J)+GRAUPELNCV(I,J)+HAILNCV(I,J))/(RAINNCV(I,J)+1.e-12)
 
       END DO
       END DO
diff --git a/wrfv2_fire/phys/module_mp_morr_two_moment.F b/wrfv2_fire/phys/module_mp_morr_two_moment.F
index dd56351a..e8cd594b 100644
--- a/wrfv2_fire/phys/module_mp_morr_two_moment.F
+++ b/wrfv2_fire/phys/module_mp_morr_two_moment.F
@@ -72,11 +72,15 @@
 !    from the calculation of PSMLT and PGMLT
 ! 2) redundant initialization of PSMLT (non answer-changing)
 
+! CHANGES FOR WRFV3.8.1
+! 1) changes and cleanup of code comments
+! 2) correction to universal gas constant (very small change)
+
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 ! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING
 ! RATIOS AND NUMBER CONCENTRATIONS OF FIVE HYDROMETEOR SPECIES:
-! CLOUD DROPLETS, CLOUD (SMALL) ICE, RAIN, SNOW, AND GRAUPEL.
+! CLOUD DROPLETS, CLOUD (SMALL) ICE, RAIN, SNOW, AND GRAUPEL/HAIL.
 
 MODULE MODULE_MP_MORR_TWO_MOMENT
    USE     module_wrf_error
@@ -92,13 +96,13 @@ MODULE MODULE_MP_MORR_TWO_MOMENT
    IMPLICIT NONE
 
    REAL, PARAMETER :: PI = 3.1415926535897932384626434
-   REAL, PARAMETER :: SQRTPI = 0.9189385332046727417803297
+   REAL, PARAMETER :: xxx = 0.9189385332046727417803297
 
    PUBLIC  ::  MP_MORR_TWO_MOMENT
    PUBLIC  ::  POLYSVP
 
    PRIVATE :: GAMMA, DERF1
-   PRIVATE :: PI, SQRTPI
+   PRIVATE :: PI, xxx
    PRIVATE :: MORR_TWO_MOMENT_MICRO
 
 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -143,7 +147,7 @@ MODULE MODULE_MP_MORR_TWO_MOMENT
 !             LOCAL SUB-GRID AND/OR GRID-SCALE VERTICAL VELOCITY 
 !             AT THE GRID POINT
 
-! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0)
+! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0) IN NON-WRF-CHEM VERSION OF CODE
 
      INTEGER, PRIVATE ::  IBASE
 
@@ -151,6 +155,8 @@ MODULE MODULE_MP_MORR_TWO_MOMENT
 ! ISUB = 0, INCLUDE SUB-GRID W (RECOMMENDED FOR LOWER RESOLUTION)
 ! ISUB = 1, EXCLUDE SUB-GRID W, ONLY USE GRID-SCALE W
 
+! NOTE: ONLY USED FOR PREDICTED DROPLET CONCENTRATION (INUM = 0) IN NON-WRF-CHEM VERSION OF CODE
+
      INTEGER, PRIVATE ::  ISUB      
 
 ! SWITCH FOR GRAUPEL/NO GRAUPEL
@@ -422,6 +428,10 @@ SUBROUTINE MORR_TWO_MOMENT_INIT(hail_opt) ! RAS
          LAMMAXG = 1./20.E-6
          LAMMING = 1./2000.E-6
 
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! note: these parameters only used by the non-wrf-chem version of the 
+!       scheme with predicted droplet number
+
 ! CCN SPECTRA FOR IACT = 1
 
 ! MARITIME
@@ -446,7 +456,9 @@ SUBROUTINE MORR_TWO_MOMENT_INIT(hail_opt) ! RAS
          RHOA = 1777.
          MAP = 0.132
          MA = 0.0284
-         RR = 8.3187
+! hm fix 6/23/16
+!         RR = 8.3187
+         RR = 8.3145
          BACT = VI*OSM*EPSM*MW*RHOA/(MAP*RHOW)
 
 ! AEROSOL SIZE DISTRIBUTION PARAMETERS CURRENTLY SET FOR MPACE 
@@ -466,6 +478,7 @@ SUBROUTINE MORR_TWO_MOMENT_INIT(hail_opt) ! RAS
          NANEW2 = 1.8E6
          F12 = 0.5*EXP(2.5*(LOG(SIG2))**2)
          F22 = 1.+0.25*LOG(SIG2)
+!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 ! CONSTANTS FOR EFFICIENCY
 
@@ -553,7 +566,7 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP,                       &
                 RAINNC, RAINNCV, SR,                    &
 		SNOWNC,SNOWNCV,GRAUPELNC,GRAUPELNCV,    & ! hm added 7/13/13
                 refl_10cm, diagflag, do_radar_ref,      & ! GT added for reflectivity calcs
-                qrcuten, qscuten, qicuten, mu           & ! hm added
+                qrcuten, qscuten, qicuten               & ! hm added
                ,F_QNDROP, qndrop                        & ! hm added, wrf-chem 
                ,IDS,IDE, JDS,JDE, KDS,KDE               & ! domain dims
                ,IMS,IME, JMS,JME, KMS,KME               & ! memory dims
@@ -686,8 +699,6 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP,                       &
 
    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), INTENT(IN):: &
       qrcuten, qscuten, qicuten
-   REAL, DIMENSION(ims:ime, jms:jme), INTENT(IN):: &
-      mu
 
   LOGICAL, INTENT(IN), OPTIONAL ::                F_QNDROP  ! wrf-chem
   LOGICAL :: flag_qndrop  ! wrf-chem
@@ -775,10 +786,10 @@ SUBROUTINE MP_MORR_TWO_MOMENT(ITIMESTEP,                       &
           DZ1D(k)       = DZ(i,k,j)
           W1D(k)        = W(i,k,j)
           WVAR1D(k)     = WVAR(i,k,j)
-! add cumulus tendencies, decouple from mu
-          qrcu1d(k)     = qrcuten(i,k,j)/mu(i,j)
-          qscu1d(k)     = qscuten(i,k,j)/mu(i,j)
-          qicu1d(k)     = qicuten(i,k,j)/mu(i,j)
+! add cumulus tendencies, already decoupled
+          qrcu1d(k)     = qrcuten(i,k,j)
+          qscu1d(k)     = qscuten(i,k,j)
+          qicu1d(k)     = qicuten(i,k,j)
       end do  !jdf added this
 ! below for wrf-chem
    IF (flag_qndrop .AND. PRESENT( qndrop )) THEN
@@ -921,12 +932,11 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
 
 !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 ! THIS PROGRAM IS THE MAIN TWO-MOMENT MICROPHYSICS SUBROUTINE DESCRIBED BY
-! MORRISON ET AL. 2005 JAS; MORRISON AND PINTO 2005 JAS.
-! ADDITIONAL CHANGES ARE DESCRIBED IN DETAIL BY MORRISON, THOMPSON, TATARSKII (MWR, SUBMITTED)
+! MORRISON ET AL. 2005 JAS AND MORRISON ET AL. 2009 MWR
 
 ! THIS SCHEME IS A BULK DOUBLE-MOMENT SCHEME THAT PREDICTS MIXING
 ! RATIOS AND NUMBER CONCENTRATIONS OF FIVE HYDROMETEOR SPECIES:
-! CLOUD DROPLETS, CLOUD (SMALL) ICE, RAIN, SNOW, AND GRAUPEL.
+! CLOUD DROPLETS, CLOUD (SMALL) ICE, RAIN, SNOW, AND GRAUPEL/HAIL.
 
 ! CODE STRUCTURE: MAIN SUBROUTINE IS 'MORR_TWO_MOMENT'. ALSO INCLUDED IN THIS FILE IS
 ! 'FUNCTION POLYSVP', 'FUNCTION DERF1', AND
@@ -3288,7 +3298,7 @@ SUBROUTINE MORR_TWO_MOMENT_MICRO(QC3DTEN,QI3DTEN,QNI3DTEN,QR3DTEN,         &
 #if (WRF_CHEM == 1)
          evapprod(k) = - PRE(K) - EPRDS(K) - EPRDG(K) 
          rainprod(k) = PRA(K) + PRC(K) + PSACWS(K) + PSACWG(K) + PGSACW(K) & 
-                       + PRAI(K) + PRCI(K) + PRACI(K) + PRACIS(K) + &
+                       + PRAI(K) + PRCI(K) + PRACI(K) + PRACIS(K)  &
                        + PRDS(K) + PRDG(K)
 #endif
 
@@ -4316,7 +4326,7 @@ REAL FUNCTION GAMMA(X)
           DO I=1,6
             SUM=SUM/YSQ+C(I)
           END DO
-          SUM=SUM/Y-Y+SQRTPI
+          SUM=SUM/Y-Y+xxx
           SUM=SUM+(Y-HALF)*LOG(Y)
           RES=EXP(SUM)
         ELSE
diff --git a/wrfv2_fire/phys/module_mp_nssl_2mom.F b/wrfv2_fire/phys/module_mp_nssl_2mom.F
index e9d25034..fafd4eec 100644
--- a/wrfv2_fire/phys/module_mp_nssl_2mom.F
+++ b/wrfv2_fire/phys/module_mp_nssl_2mom.F
@@ -1,5 +1,7 @@
 !WRF:MODEL_LAYER:PHYSICS
 
+! prepocessed on "Nov 18 2016" at "14:51:08"
+
 
 
 
@@ -30,6 +32,10 @@
 ! Mansell, E. R., C. L. Ziegler, and E. C. Bruning, 2010: Simulated electrification of a small 
 !   thunderstorm with two-moment bulk microphysics. J. Atmos. Sci., 67, 171-194, doi:10. 1175/2009JAS2965.1.
 !
+!  Mansell, E. R. and C. L. Ziegler, 2013: Aerosol effects on simulated storm electrification and 
+!     precipitation in a two-moment bulk microphysics model. J. Atmos. Sci., 70 (7), 2032-2050, 
+!     doi:10.1175/JAS-D-12-0264.1.
+!
 ! Ziegler, C. L., 1985: Retrieval of thermal and microphysical variables in observed convective storms. 
 !    Part I: Model development and preliminary testing. J. Atmos. Sci., 42, 1487-1509.
 !
@@ -56,6 +62,16 @@
 !
 ! Note: Some parameters below apply to unreleased features.
 !
+! WRF 3.9 updates:
+!
+!   2-moment scheme now creates number concentration tendencies from cumulus scheme mass mixing ratio rates
+!   Renamed internal gamma function routine from 'gamma' to 'gamma_sp' to avoid name conflicts
+!   Restored older settings that allow snow aggregation starting at T > -25C
+!   Adjusted Meyers number of activated nuclei by the local air density to compensate for using data at surface
+!   Minor updates to rain-ice crystal and hail-rain collection efficiencies
+!
+!   Reduced minimum mean snow diameter from 100 microns to 10 microns
+!
 ! WRF 3.8 updates:
 !   Fixed issue with reflectivity conservation for graupel melting into rain. Rain number concentrations were too low,
 !       resulting in excessive reflectivity of a couple dBZ
@@ -88,12 +104,12 @@ MODULE module_mp_nssl_2mom
   
   public nssl_2mom_driver
   public nssl_2mom_init
-  private gamma,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis
+  private gamma_sp,gamxinf,GAML02, GAML02d300, GAML02d500, fqvs, fqis
   private gamma_dp, gamxinfdp
   private delbk, delabk
   private gammadp
   
-  logical, public :: cleardiag = .false.
+  logical, private :: cleardiag = .false.
   PRIVATE
 
 #ifdef WRF_CHEM
@@ -118,7 +134,6 @@ MODULE module_mp_nssl_2mom
 ! Params for dbz:
   integer  :: iuseferrier = 1  ! =1: use dry graupel only from Ferrier 1994; = 0: Use Smith (wet graupel)
   integer  :: idbzci      = 0
- ! new version  integer  :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase)
   integer  :: iusewetgraupel = 1 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase)
                                  ! =2 turn on for graupel density less than 300. only 
   integer  :: iusewethail = 0 ! =1 to turn on use of QHW for graupel reflectivity (only for ZVDM -- mixedphase)
@@ -148,6 +163,15 @@ MODULE module_mp_nssl_2mom
   real   , private :: auttim         = 300.      ! 10-ice rain delay time
   real   , private :: qcwmntim       = 1.0e-5    ! 10-ice rain delay min qc for time accrual
 
+#if (NMM_CORE == 1)
+! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true
+      logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state
+#else
+      logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state
+#endif
+  logical :: restoreccn = .false. ! whether or not to nudge CCN back to base state (qccn) (only applies if CCNA is NOT predicted)
+  real    :: ccntimeconst = 600.  ! time constant for CCN restore (either for CCNA or when restoreccn = true)
+
 
 ! sedimentation flags
 ! itfall -> 0 = 1st order fallout (other options removed)
@@ -211,6 +235,7 @@ MODULE module_mp_nssl_2mom
   integer, private :: issfilt = 0     ! flag to turn on filtering of supersaturation field
   integer, private :: irenuc = 2      ! =1 to always allow renucleation of droplets within the cloud
                                       ! =2 renucleation following Twomey/Cohard&Pinty
+                                      ! =7 New renucleation that requires prediction of the number of activated nuclei
                              ! i.e., not only at cloud base
   integer, private :: irenuc3d = 0      ! =1 to include horizontal gradient in renucleation of droplets within the cloud
   real    :: renucfrac = 0.0 ! = 0 : cnuc = cwccn
@@ -233,11 +258,13 @@ MODULE module_mp_nssl_2mom
   integer, private :: icfn = 2                ! contact freezing: 0 = off; 1 = hack (ok for single moment); 2 = full Cotton/Meyers version
   integer, private :: ihrn = 0            ! Hobbs-Rangno ice multiplication (Ferrier, 1994; use in 10-ice only)
   integer, private :: ibfc = 1            ! Flag to use Bigg freezing on droplets (0 = off (uses alternate freezing), 1 = on)
+  integer, private :: iremoveqwfrz = 1    ! Whether to remove (=1) or not (=0) the newly-frozen cloud droplets (ibfc=1) from the CWC used for charge separation
   integer, private :: iacr = 2            ! Flag for drop contact freezing with crytals
                                  ! (0=off; 1=drops > 500micron diameter; 2 = > 300micron)
   integer, private :: ibfr = 2            ! Flag for Bigg freezing conversion of freezing drops to graupel
                                  ! (1=min graupel size is vr1mm; 2=use min size of dfrz, 5= as for 2 and apply dbz conservation)
   integer, private :: ibiggopt = 2        ! 1 = old Bigg; 2 = experimental Bigg (only for imurain = 1, however)
+  integer :: ibiggsmallrain = 0  ! 1 = When rain is too small, freeze none to graupel and send all to snow (experimental)
   integer, private :: iacrsize = 5        ! assumed min size of drops freezing by capture
                                  !  1: > 500 micron diam
                                  !  2: > 300 micron
@@ -250,6 +277,7 @@ MODULE module_mp_nssl_2mom
   real   , private :: splintermass = 6.88e-13
   real   , private :: cfnfac = 0.1        ! Hack factor that goes with icfn=1
   integer, private :: iscni = 4           ! default option for ice crystal aggregation/conversion to snow
+  real   , private :: fscni = 1.0         ! factor for calculating cscni
   logical, private :: imeyers5 = .false.  ! .false.=off, true=on for Meyers ice nucleation for temp > -5 C
   real   , private :: dmincw = 15.0e-6    ! minimum droplet diameter for collection for iehw=3
   integer, private :: iehw = 1            ! 0 -> ehw=ehw0; 1 -> old ehw; 2 -> test ehw with Mason table data
@@ -283,13 +311,14 @@ MODULE module_mp_nssl_2mom
   real   , private :: eii0hl = 0.2 ,eii1hl = 0.0  ! hail-crystal coll. eff. parameters: eii0hl*exp(eii1hl*min(temcg(mgs),0.0))
                                      ! set eii1hl = 0 to get a constant value of eii0hl
   real   , private :: eri0 = 0.1   ! rain efficiency to collect ice crystals
+  real   , private :: eri_cimin = 10.e-6      ! minimum ice crystal diameter for collection by rain
   real   , private :: esi0 = 0.1              ! linear factor in snow-ice collection efficiency
   real   , private :: ehs0 = 0.1, ehs1 = 0.1  ! graupel-snow coll. eff. parameters: ehs0*exp(ehs1*min(temcg(mgs),0.0))
                                      ! set ehs1 = 0 to get a constant value of ehs0
   real   , private :: ess0 = 0.5, ess1 = 0.05 ! snow aggregation coefficients: ess0*exp(ess1*min(temcg(mgs),0.0))
                                      ! set ess1 = 0 to get a constant value of ess0
-  real   , private :: esstem1 = -10.  ! lower temperature where snow aggregation turns on
-  real   , private :: esstem2 = -07.  ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2
+  real   , private :: esstem1 = -25.  ! lower temperature where snow aggregation turns on
+  real   , private :: esstem2 = -20.  ! higher temperature for linear ramp of ess from zero at esstem1 to formula value at esstem2
   real   , private :: ehsfrac = 1.0           ! multiplier for graupel collection efficiency in wet growth
   real   , private :: ehimin = 0.0 ! Minimum collection efficiency (graupel - ice crystal)
   real   , private :: ehimax = 1.0 ! Maximum collection efficiency (graupel - ice crystal)
@@ -334,6 +363,7 @@ MODULE module_mp_nssl_2mom
 
 
   integer, private :: nsplinter = 0  ! number of ice splinters per freezing drop, if negative, then per resulting graupel particle
+  real,    private :: lawson_splinter_fac = 2.5e-11  ! constant in Lawson et al. (2015, JAS) for ice particle production from freezing drops
   integer, private :: isnwfrac = 0   ! 0= no snow fragmentation; 1 = turn on snow fragmentation (Schuur, 2000)
 
 !  integer, private :: denscale = 1  ! 1=scale num. conc. and charge by air density for advection, 0=turn off for comparison
@@ -346,6 +376,10 @@ MODULE module_mp_nssl_2mom
   real   , private :: sheddiam   = 8.0e-03  ! minimum diameter of graupel before shedding occurs
   real    :: sheddiamlg = 10.0e-03  ! diameter of hail to use fwmlarge
   real    :: sheddiam0  = 20.0e-03  ! diameter of hail at which all water is shed
+  
+  integer :: ifwmhopt = 1 ! option for calculating maximum liquid fraction when fwmh and/or fwmhl is set to -1
+                          ! 1 = maximum based on size of maximum mass diameter
+                          ! 2 = integrate over spectrum for maximum liquid (experimental)
 
   real   , private :: fwms = 0.5 ! maximum liquid water fraction on snow
   real   , private :: fwmh = 0.5 ! maximum liquid water fraction on graupel
@@ -397,9 +431,13 @@ MODULE module_mp_nssl_2mom
   integer :: ivhmltsoak = 1   ! 0=off, 1=on : flag to simulate soaking (graupel/hail) during melting 
                          ! when liquid fraction is not predicted
   integer, private :: ioldlimiter = 0 ! test switch for new(=0) or old(=1) size limiter at the end of GS for 3-moment categories
-  integer, private  :: isnowfall = 2   ! Option for choosing between snow fall speed parameters
+  integer, private :: isnowfall = 2   ! Option for choosing between snow fall speed parameters
                          ! 1 = original Zrnic et al. (Mansell et al. 2010)
                          ! 2 = Ferrier 1994 (results in slower fall speeds)
+
+  integer, private :: isnowdens = 1   ! Option for choosing between snow density options
+                             ! 1 = constant of 100 kg m^-3
+                             ! 2 = Option based on Cox
   
   integer, private  :: ibiggsnow   = 3 ! 1 = switch conversion over to snow for small frozen drops from Bigg freezing
                                        ! 2 = switch conversion over to snow for small frozen drops from rain-ice interaction
@@ -418,6 +456,7 @@ MODULE module_mp_nssl_2mom
   integer, private :: ibinhlmlr = 0  ! =1 use incomplete gammas to determine melting from larger and smaller sizes of hail, and appropriate shed drop sizes 
                             ! =2 to test melting by temporary bins
   
+  integer :: iqvsopt = 0 ! =0 use old default for tabqvs; =1 use Bolton formulation (Rogers and Yau)
 
   integer, parameter :: icespheres = 0 ! turn ice spheres (frozen droplets) on (1) or off (0). NOT COMPLETE IN WRF/ARPS/CM1 CODE!
   integer, parameter :: lqmx = 30
@@ -657,7 +696,7 @@ MODULE module_mp_nssl_2mom
       real     :: xvdmx = -1.0 ! 3.0e-3
       real     :: xvrmx
       parameter( xvrmn=0.523599*(80.e-6)**3, xvrmx0=0.523599*(6.e-3)**3 ) !( was 4.1887e-9 )  ! mks
-      parameter( xvsmn=0.523599*(0.1e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 )  ! mks
+      parameter( xvsmn=0.523599*(0.01e-3)**3, xvsmx=0.523599*(10.e-3)**3 ) !( was 4.1887e-9 )  ! mks
       parameter( xvfmn=0.523599*(0.1e-3)**3, xvfmx=0.523599*(10.e-3)**3 )  ! mks xvfmx = (pi/6)*(10mm)**3
       parameter( xvgmn=0.523599*(0.1e-3)**3, xvgmx=0.523599*(10.e-3)**3 )  ! mks xvfmx = (pi/6)*(10mm)**3
       parameter( xvhmn0=0.523599*(0.3e-3)**3, xvhmx0=0.523599*(20.e-3)**3 )  ! mks xvfmx = (pi/6)*(10mm)**3
@@ -685,6 +724,9 @@ MODULE module_mp_nssl_2mom
       real, parameter :: cbi = 7.66
       real, parameter :: cbw = 35.86
 
+      real, parameter :: cbwbolton = 29.65 ! constants for Bolton formulation
+      real, parameter :: cawbolton = 17.67
+
       real, parameter :: tfr = 273.15, tfrh = 233.15
 
       real, parameter :: cp = 1004.0, rd = 287.04
@@ -803,12 +845,20 @@ SUBROUTINE nssl_2mom_init(  &
         lh = lh + 1
         lhl = lhl + 1
       ENDIF
-      IF ( ihvol == -1 ) THEN
-        lhab = lhab - 1  ! turns off hail -- option for single moment, only!!
+      IF ( ihvol <= -1 .or. ihvol == 2 ) THEN
+        IF ( ihvol == -1 .or. ihvol == -2 ) THEN
+        lhab = lhab - 1  ! turns off hail
         lhl = 0
         ehw0 = 0.75
         iehw = 2
         dfrz = Max( dfrz, 0.5e-3 )
+        ENDIF
+        IF ( ihvol == -2 .or. ihvol == 2 ) THEN ! ice crystals are turned off
+         ! a value of -3 means to turn off ice crystals but turn on hail
+          renucfrac = 1.0
+          ffrzs = 1.0
+          ! idoci = 0 ! try this later
+        ENDIF
       ENDIF
 
 !      IF ( ipelec > 0 ) idonic = .true.
@@ -819,9 +869,15 @@ SUBROUTINE nssl_2mom_init(  &
 
       do l = 1,nqsat
       temq = 163.15 + (l-1)*fqsat
+      IF ( iqvsopt == 0 ) THEN
       tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw))
       dtabqvs(l) = ((-caw*(-273.15 + temq))/(temq - cbw)**2 + &
      &                 caw/(temq - cbw))*tabqvs(l)
+      ELSE
+      tabqvs(l) = exp(caw*(temq-273.15)/(temq-cbw))
+      dtabqvs(l) = ((-cawbolton*(-273.15 + temq))/(temq - cbwbolton)**2 + &
+     &                 cawbolton/(temq - cbwbolton))*tabqvs(l)
+      ENDIF
       tabqis(l) = exp(cai*(temq-273.15)/(temq-cbi))
       dtabqis(l) = ((-cai*(-273.15 + temq))/(temq - cbi)**2 + &
      &                 cai/(temq - cbi))*tabqis(l)
@@ -844,7 +900,7 @@ SUBROUTINE nssl_2mom_init(  &
 !      bx(lh) = 0.6
 
       IF ( lhl .gt. 1 ) THEN
-        IF ( icdx == 6 ) THEN
+        IF ( icdxhl == 6 ) THEN
           bx(lhl) = 0.593 ! Milbrandt and Morrison (2013) for density of 750.
           ax(lhl) = 179.36
         ELSEIF (icdxhl > 0 ) THEN
@@ -873,7 +929,7 @@ SUBROUTINE nssl_2mom_init(  &
       
       DO j = 0,nqiacralpha
       alp = float(j)*dqiacralpha
-      y = gamma(1.+alp)
+      y = gamma_sp(1.+alp)
       DO i = 1,nqiacrratio
         ratio = float(i)*dqiacrratio
         x = gamxinf( 1.+alp, ratio )
@@ -884,8 +940,8 @@ SUBROUTINE nssl_2mom_init(  &
         gamxinflu(i,j,1,1) = x/y
         gamxinflu(i,j,2,1) = gamxinf( 2.0+alp, ratio )/y
         gamxinflu(i,j,3,1) = gamxinf( 2.5+alp+0.5*bxh, ratio )/y
-        gamxinflu(i,j,5,1) = (gamma(5.0+alp) - gamxinf( 5.0+alp, ratio ))/y
-        gamxinflu(i,j,6,1) = (gamma(5.5+alp+0.5*bxh) - gamxinf( 5.5+alp+0.5*bxh, ratio ))/y
+        gamxinflu(i,j,5,1) = (gamma_sp(5.0+alp) - gamxinf( 5.0+alp, ratio ))/y
+        gamxinflu(i,j,6,1) = (gamma_sp(5.5+alp+0.5*bxh) - gamxinf( 5.5+alp+0.5*bxh, ratio ))/y
         gamxinflu(i,j,9,1) = gamxinf( 1.0+alp, ratio )/y
         gamxinflu(i,j,10,1)= gamxinf( 4.0+alp, ratio )/y
        
@@ -894,24 +950,24 @@ SUBROUTINE nssl_2mom_init(  &
         gamxinflu(i,j,2,2) = gamxinflu(i,j,2,1)
         gamxinflu(i,j,3,2) = gamxinf( 2.5+alp+0.5*bxhl, ratio )/y
         gamxinflu(i,j,5,2) = gamxinflu(i,j,5,1)
-        gamxinflu(i,j,6,2) = (gamma(5.5+alp+0.5*bxhl) - gamxinf( 5.5+alp+0.5*bxhl, ratio ))/y
+        gamxinflu(i,j,6,2) = (gamma_sp(5.5+alp+0.5*bxhl) - gamxinf( 5.5+alp+0.5*bxhl, ratio ))/y
         gamxinflu(i,j,9,2) = gamxinflu(i,j,9,1)
         gamxinflu(i,j,10,2)= gamxinflu(i,j,10,1)
 
       IF ( alp > 1.1 ) THEN
 !       gamxinflu(i,j,7,1) = gamxinf( alp - 1., ratio )/y
-       gamxinflu(i,j,7,1) = (gamma(alp - 1.) - gamxinf( alp - 1., ratio ))/y 
+       gamxinflu(i,j,7,1) = (gamma_sp(alp - 1.) - gamxinf( alp - 1., ratio ))/y
 !       gamxinflu(i,j,8,1) = gamxinf( alp - 0.5 + 0.5*bxh, ratio )/y
-       gamxinflu(i,j,8,1) = (gamma(alp - 0.5 + 0.5*bxh) - gamxinf( alp - 0.5 + 0.5*bxh, ratio ))/y
+       gamxinflu(i,j,8,1) = (gamma_sp(alp - 0.5 + 0.5*bxh) - gamxinf( alp - 0.5 + 0.5*bxh, ratio ))/y
 !       gamxinflu(i,j,8,2) = gamxinf( alp - 0.5 + 0.5*bxhl, ratio )/y
-       gamxinflu(i,j,8,2) = (gamma(alp - 0.5 + 0.5*bxhl) - gamxinf( alp - 0.5 + 0.5*bxhl, ratio ))/y
+       gamxinflu(i,j,8,2) = (gamma_sp(alp - 0.5 + 0.5*bxhl) - gamxinf( alp - 0.5 + 0.5*bxhl, ratio ))/y
       ELSE
 !       gamxinflu(i,j,7,1) = gamxinf( .1, ratio )/y
-       gamxinflu(i,j,7,1) = (gamma(0.1) - gamxinf( 0.1, ratio ) )/y
+       gamxinflu(i,j,7,1) = (gamma_sp(0.1) - gamxinf( 0.1, ratio ) )/y
 !       gamxinflu(i,j,8,1) = gamxinf( 1.1 - 0.5 + 0.5*bxh, ratio )/y
 !       gamxinflu(i,j,8,2) = gamxinf( 1.1 - 0.5 + 0.5*bxhl, ratio )/y
-       gamxinflu(i,j,8,1) = (gamma(1.1 - 0.5 + 0.5*bxh) - gamxinf( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y
-       gamxinflu(i,j,8,2) = (gamma(1.1 - 0.5 + 0.5*bxhl) - gamxinf( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y
+       gamxinflu(i,j,8,1) = (gamma_sp(1.1 - 0.5 + 0.5*bxh) - gamxinf( 1.1 - 0.5 + 0.5*bxh, ratio ) )/y
+       gamxinflu(i,j,8,2) = (gamma_sp(1.1 - 0.5 + 0.5*bxhl) - gamxinf( 1.1 - 0.5 + 0.5*bxhl, ratio ) )/y
       ENDIF
         
         gamxinflu(i,j,7,2) = gamxinflu(i,j,7,1)
@@ -922,8 +978,8 @@ SUBROUTINE nssl_2mom_init(  &
 
       DO j = 0,nqiacralpha
       alp = float(j)*dqiacralpha
-      y = gamma(4.+alp)
-      y7 = gamma(7.+alp)
+      y = gamma_sp(4.+alp)
+      y7 = gamma_sp(7.+alp)
       DO i = 1,nqiacrratio
         ratio = float(i)*dqiacrratio
         x = gamxinf( 4.+alp, ratio )
@@ -940,7 +996,7 @@ SUBROUTINE nssl_2mom_init(  &
       qiacrratio(0,:) = 1.0
 
 
-      isub = Min( 0, ihvol) ! is -1 or 0
+      isub = Min( 0, Max(-1,ihvol) ) ! is -1 or 0
 
       lccn = 0
       lccna = 0
@@ -988,7 +1044,7 @@ SUBROUTINE nssl_2mom_init(  &
       lvh = lhab+8 + isub ! 16 + isub ! isub adjusts to 15 if hail is off
       ltmp = lvh
       denscale(lccn:lvh) = 1
-      IF ( ihvol == 1 ) THEN
+      IF ( ihvol >= 1 ) THEN
        lvhl = ltmp+1
        ltmp = lvhl
        denscale(lvhl) = 1
@@ -1026,7 +1082,7 @@ SUBROUTINE nssl_2mom_init(  &
       ENDIF
       ltmp = lvh
       denscale(lccn:lvh) = 1
-      IF ( ihvol == 1 ) THEN
+      IF ( ihvol >= 1 ) THEN
        lvhl = ltmp+1
        ltmp = lvhl
        denscale(lvhl) = 1
@@ -1103,18 +1159,18 @@ SUBROUTINE nssl_2mom_init(  &
 
 
 
-      xnu(lc) = 0.0
+      xnu(lc) = cnu
       xmu(lc) = 1.
       
       IF ( imurain == 3 ) THEN
-        xnu(lr) = -0.8
+        xnu(lr) = rnu
         xmu(lr) = 1.
       ELSEIF ( imurain == 1 ) THEN
         xnu(lr) = (alphar - 2.0)/3.0
         xmu(lr) = 1./3.
       ENDIF
 
-      xnu(li) = 0.0
+      xnu(li) = cinu
       xmu(li) = 1.
 
       IF ( lis >= 1 ) THEN
@@ -1128,18 +1184,20 @@ SUBROUTINE nssl_2mom_init(  &
       dnu(lr) = 3.*xnu(lr) + 2. ! alphar
       dmu(lr) = 3.*xmu(lr)
 
-      dnu(ls) = -0.4 ! alphas
-      dmu(ls) = 3.
-
-      xnu(ls) = -0.8
+      xnu(ls) = snu
       xmu(ls) = 1.
 
+      dnu(ls) = 3.*xnu(ls) + 2.  ! -0.4 ! alphas
+      dmu(ls) = 3.*xmu(ls)
+
+
       dnu(lh) = alphah
       dmu(lh) = dmuh
 
       xnu(lh) = (dnu(lh) - 2.)/3.
       xmu(lh) = dmuh/3.
 
+
       IF ( imurain == 3 ) THEN ! rain is gamma of volume
       rz =  ((4. + alphah)*(5. + alphah)*(6. + alphah)*(1. + xnu(lr)))/ & 
      &  ((1 + alphah)*(2 + alphah)*(3 + alphah)*(2. + xnu(lr)))
@@ -1173,7 +1231,7 @@ SUBROUTINE nssl_2mom_init(  &
         ibinhlmlr = 0
       ENDIF
 
-      IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhmlr == 0 ) ) THEN 
+      IF ( ipconc > 5 .and. (ibinhmlr == 0 .and. ibinhlmlr == 0 ) ) THEN
         imltshddmr = Min(1, imltshddmr)
       ENDIF
 
@@ -1320,21 +1378,21 @@ SUBROUTINE nssl_2mom_init(  &
       ventr = 1.
       IF ( imurain == 3 ) THEN
 !       IF ( izwisventr == 1 ) THEN
-        ventr = Gamma(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma(rnu + 1.)) ! Ziegler 1985
+        ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985
 !       ELSE
-        ventrn =  Gamma(rnu + 1.5 + br/6.)/(Gamma(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ! adapted from Wisner et al. 1972; for second term in rwvent
-!        ventr = Gamma(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma(rnu + 1.)) ! Ziegler 1985, still use for first term in rwvent
-!        ventr  = Gamma(rnu + 4./3.)/Gamma(rnu + 1.) 
+        ventrn =  Gamma_sp(rnu + 1.5 + br/6.)/(Gamma_sp(rnu + 1.)*(rnu + 1.)**((1.+br)/6. + 1./3.) ) ! adapted from Wisner et al. 1972; for second term in rwvent
+!        ventr = Gamma_sp(rnu + 4./3.)/((rnu + 1.)**(1./3.)*Gamma_sp(rnu + 1.)) ! Ziegler 1985, still use for first term in rwvent
+!        ventr  = Gamma_sp(rnu + 4./3.)/Gamma_sp(rnu + 1.)
 !       ENDIF
       ELSE ! imurain == 1
 !       IF ( iferwisventr == 1 ) THEN
-        ventr = Gamma(2. + alphar)  ! Ferrier 1994
+        ventr = Gamma_sp(2. + alphar)  ! Ferrier 1994
 !       ELSEIF ( iferwisventr == 2 ) THEN
-        ventrn =  Gamma(alphar + 2.5 + br/2.)/Gamma(alphar + 1.) ! adapted from Wisner et al. 1972
+        ventrn =  Gamma_sp(alphar + 2.5 + br/2.)/Gamma_sp(alphar + 1.) ! adapted from Wisner et al. 1972
 !       ENDIF
       ENDIF
-      ventc   = Gamma(cnu + 4./3.)/(cnu + 1.)**(1./3.)/Gamma(cnu + 1.)
-      c1sw = Gamma(snu + 4./3.)*(snu + 1.0)**(-1./3.)/gamma(snu + 1.0) 
+      ventc   = Gamma_sp(cnu + 4./3.)/(cnu + 1.)**(1./3.)/Gamma_sp(cnu + 1.)
+      c1sw = Gamma_sp(snu + 4./3.)*(snu + 1.0)**(-1./3.)/gamma_sp(snu + 1.0)
 
   ! set threshold mixing ratios
 
@@ -1364,7 +1422,7 @@ SUBROUTINE nssl_2mom_init(  &
 ! if k (cck) is changed!
       ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
       ccne0 = ccnefac*1.e6*(1.e-6)**(2./(2.+cck))
-      write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp
+!      write(0,*) 'cwccn, cck, ccne = ',cwccn,cck,ccne,ccnefac,cnexp
       IF ( cwccn .lt. 0.0 ) THEN
       cwccn = Abs(cwccn)
       ccwmx = 50.e9 ! cwccn
@@ -1400,19 +1458,19 @@ SUBROUTINE nssl_2mom_init(  &
         ENDDO
       ENDDO
 
-        gf4br = gamma(4.0+br)
-        gf4ds = gamma(4.0+ds)
-        gf4p5 = gamma(4.0+0.5)
-        gfcinu1 = gamma(cinu + 1.0)
-        gfcinu1p47 = gamma(cinu + 1.47167)
-        gfcinu2p47 = gamma(cinu + 2.47167)
+        gf4br = gamma_sp(4.0+br)
+        gf4ds = gamma_sp(4.0+ds)
+        gf4p5 = gamma_sp(4.0+0.5)
+        gfcinu1 = gamma_sp(cinu + 1.0)
+        gfcinu1p47 = gamma_sp(cinu + 1.47167)
+        gfcinu2p47 = gamma_sp(cinu + 2.47167)
 
-        gsnow1 = gamma(snu + 1.0)
-        gsnow53 = gamma(snu + 5./3.)
-        gsnow73 = gamma(snu + 7./3.)
+        gsnow1 = gamma_sp(snu + 1.0)
+        gsnow53 = gamma_sp(snu + 5./3.)
+        gsnow73 = gamma_sp(snu + 7./3.)
 
-        IF ( lh  .gt. 1 ) cwchtmp0 = 6.0/pi*gamma( (xnu(lh) + 1.)/xmu(lh) )/gamma( (xnu(lh) + 2.)/xmu(lh) )
-        IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma( (xnu(lhl) + 1)/xmu(lhl) )/gamma( (xnu(lhl) + 2)/xmu(lhl) )
+        IF ( lh  .gt. 1 ) cwchtmp0 = 6.0/pi*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) )
+        IF ( lhl .gt. 1 ) cwchltmp0 = 6.0/pi*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) )
 
 
       iexy(:,:)=0; ! sets to zero the ones Imight have forgotten
@@ -1473,16 +1531,14 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
 ! 20130903 acd_mb_washout start
                               rainprod, evapprod,                                       & ! wrf-chem 
 ! 20130903 acd_mb_washout end
+                              cu_used, qrcuten, qscuten, qicuten, qccuten,              & ! hm added
                               ids,ide, jds,jde, kds,kde,                                &  ! domain dims
                               ims,ime, jms,jme, kms,kme,                                &  ! memory dims
                               its,ite, jts,jte, kts,kte)                                   ! tile dims
 
 
-
       implicit none
 
-      integer :: mytask = 0
-
  !Subroutine arguments:
 
       integer, intent(in)::                                                             &
@@ -1490,11 +1546,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
                             ims,ime, jms,jme, kms,kme,                                   &
                             its,ite, jts,jte, kts,kte
       real, dimension(ims:ime, kms:kme, jms:jme), intent(inout)::                        &
-                            qv,qc,qr,qi,qs,qh,th
+                            qv,qc,qr,qs,qh,th
       real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout)::                        &
                               zrw, zhw, zhl,                                            &
                               qsw, qhw, qhlw,                                           &
-                            qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl
+                            qi,qhl,ccw,crw,cci,csw,chw,chl,vhw,vhl
       real, dimension(ims:ime, kms:kme, jms:jme), optional, intent(inout):: dbz, vzf, cn
       real, dimension(ims:ime, jms:jme), optional, intent(inout):: compdbz
       real, dimension(ims:ime, jms:jme), optional, intent(inout):: rscghis_2d
@@ -1548,13 +1604,19 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
 ! 20130903 acd_ck_washout end
    REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional,INTENT(INOUT)::  rainprod, evapprod
 
+! qrcuten, rain tendency from parameterized cumulus convection
+! qscuten, snow tendency from parameterized cumulus convection
+! qicuten, cloud ice tendency from parameterized cumulus convection
+   REAL, DIMENSION(ims:ime, kms:kme, jms:jme), optional, INTENT(IN):: qrcuten, qscuten, qicuten, qccuten
+   INTEGER, optional, intent(in) :: cu_used
+
 !
 ! local variables
 !
      real, dimension(its:ite, 1, kts:kte) :: elec2 ! ez = elecsave slab
 !     real, dimension(its:ite, 1, kts:kte,2) :: scion2 ! 1=- , 2=+
-     real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d
-     real, dimension(its:ite, 1, kts:kte, na) :: an
+     real, dimension(its:ite, kts:kte) :: rainprod2d, evapprod2d,tke2d,qrcuten2d, qscuten2d, qicuten2d,qccuten2d
+     real, dimension(its:ite, 1, kts:kte, na) :: an, ancuten
      real, dimension(its:ite, 1, kts:kte, nxtra) :: axtra
      real, dimension(its:ite, 1, kts:kte) :: t0,t1,t2,t3,t4,t5,t6,t7,t8,t9
      real, dimension(its:ite, 1, kts:kte) :: dn1,t00,t77,ssat,pn,wn,dz2d,dz2dinv,dbz2d,vzf2d
@@ -1577,28 +1639,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
       real, parameter :: cnin2a = 12.96
       real, parameter :: cnin2b = 0.639
 
-#if (NMM_CORE == 1)
-! NMM WRF core does not have special boundary conditions for CCN, therefore set invertccn to true
-      logical, parameter :: invertccn = .true. ! =true for base state of ccn=0, =false for ccn initialized in the base state
-#else
-      logical, parameter :: invertccn = .false. ! =true for base state of ccn=0, =false for ccn initialized in the base state
-#endif
-
       real :: tmp,dv
 
       double precision :: dt1,dt2
       double precision :: timesed,timesed1,timesed2,timesed3, timegs, timenucond, timedbz,zmaxsed
       double precision :: timevtcalc,timesetvt
       
-#ifdef MPI
-
-#if defined(MPI) 
-      integer, parameter :: ntot = 50
-      double precision  mpitotindp(ntot), mpitotoutdp(ntot)
-      INTEGER :: mpi_error_code = 1
-#endif
-#endif
-
 
 ! -------------------------------------------------------------------
 
@@ -1639,6 +1685,10 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
      ny = 1         ! set up as 2D slabs
      nz = kte-kts+1
      
+     IF ( .not. present( cn ) ) THEN
+       renucfrac = 1.0
+     ENDIF
+     
 ! set up CCN array and some other static local values
      IF ( itimestep == 1 .and. .not. invertccn .and.  present( cn ) ) THEN
      ! this is not needed for WRF 3.8 and later because it is done in physics_init, 
@@ -1653,6 +1703,18 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
         ENDDO
       ENDIF
      ENDIF
+
+     IF ( itimestep == 1 .and. invertccn .and.  present( cn ) ) THEN
+     ! this is not needed for WRF 3.8 and later because it is done in physics_init,
+     ! but kept for backwards compatibility with earlier versions
+        DO jy = jts,jte
+         DO kz = kts,kte
+          DO ix = its,ite
+            cn(ix,kz,jy) = 0.0
+          ENDDO
+         ENDDO
+        ENDDO
+      ENDIF
      
       IF ( invertccn .and.  present( cn ) ) THEN ! hack for WRF to convert activated ccn to unactivated, then don't have to 
                                               ! worry about initial and boundary conditions - they are zero
@@ -1714,6 +1776,12 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
 
 !     write(0,*) 'N2M: jy loop 1, lhl,na = ',lhl,na,present(qhl)
 
+          qrcuten2d(its:ite,kts:kte) = 0.0
+          qscuten2d(its:ite,kts:kte) = 0.0
+          qicuten2d(its:ite,kts:kte) = 0.0
+          qccuten2d(its:ite,kts:kte) = 0.0
+          ancuten(its:ite,1,kts:kte,:) = 0.0
+
      DO jy = jts,jye
      
      xfall(:,:,:) = 0.0
@@ -1732,7 +1800,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
           an(ix,1,kz,lv)   = qv(ix,kz,jy)
           an(ix,1,kz,lc)   = qc(ix,kz,jy)
           an(ix,1,kz,lr)   = qr(ix,kz,jy)
-          an(ix,1,kz,li)   = qi(ix,kz,jy)
+          IF ( present( qi ) ) THEN
+            an(ix,1,kz,li)   = qi(ix,kz,jy)
+          ELSE
+            an(ix,1,kz,li) = 0.0
+          ENDIF
           an(ix,1,kz,ls)   = qs(ix,kz,jy)
           an(ix,1,kz,lh)   = qh(ix,kz,jy)
           IF ( lhl > 1 ) an(ix,1,kz,lhl)  = qhl(ix,kz,jy)
@@ -1749,7 +1821,11 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
             an(ix,1,kz,lnc)  = constccw
           ENDIF
           an(ix,1,kz,lnr)  = crw(ix,kz,jy)
-          an(ix,1,kz,lni)  = cci(ix,kz,jy)
+          IF ( present( cci ) ) THEN
+            an(ix,1,kz,lni)  = cci(ix,kz,jy)
+          ELSE
+            an(ix,1,kz,lni) = 0.0
+          ENDIF
           an(ix,1,kz,lns)  = csw(ix,kz,jy)
           an(ix,1,kz,lnh)  = chw(ix,kz,jy)
           IF ( lhl > 1 ) an(ix,1,kz,lnhl) = chl(ix,kz,jy)
@@ -1802,7 +1878,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
 
       if ( t0(ix,1,kz).le.268.15 ) then
 
-       dp1 = cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) )
+       dp1 = dn1(ix,1,kz)/rho00*cnin20*exp( Min( 57.0 ,(cnin2a*(ssival-1.0)-cnin2b) ) )
        t7(ix,1,kz) = Min(dp1, 1.0d30)
       end if
 
@@ -1819,7 +1895,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
       ssifac = ssifac**cnin1a
       end if
       end if
-      t7(ix,1,kz) = cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1)
+      t7(ix,1,kz) = dn(ix,1,kz)/rho00*cnin10*ssifac*exp(-(t0(ix,1,kz)-tfr)*bta1)
       end if
       ENDIF
 
@@ -1882,6 +1958,43 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
        IF ( itimestep == 1 .and. ipconc > 0 ) THEN
          call calcnfromq(nx,ny,nz,an,na,nor,nor,dn1)
        ENDIF
+
+      IF ( present(cu_used) .and.         &
+           ( present( qrcuten ) .or. present( qscuten ) .or.  &
+             present( qicuten ) .or. present( qccuten ) ) ) THEN
+
+       IF ( cu_used == 1 ) THEN
+       DO kz = kts,kte
+        DO ix = its,ite
+!         IF ( present( qrcuten ) ) qrcuten2d(ix,kz)   = qrcuten(ix,kz,jy)
+!         IF ( present( qscuten ) ) qscuten2d(ix,kz)   = qscuten(ix,kz,jy)
+!         IF ( present( qicuten ) ) qicuten2d(ix,kz)   = qicuten(ix,kz,jy)
+!         IF ( present( qccuten ) ) qccuten2d(ix,kz)   = qccuten(ix,kz,jy)
+
+         IF ( present( qrcuten ) ) ancuten(ix,1,kz,lr) = dtp*qrcuten(ix,kz,jy)
+         IF ( present( qscuten ) ) ancuten(ix,1,kz,ls) = dtp*qscuten(ix,kz,jy)
+         IF ( present( qicuten ) ) ancuten(ix,1,kz,li) = dtp*qicuten(ix,kz,jy)
+         IF ( present( qccuten ) ) ancuten(ix,1,kz,lc) = dtp*qccuten(ix,kz,jy)
+         
+        ENDDO
+       ENDDO
+       
+         call calcnfromcuten(nx,ny,nz,ancuten,an,na,nor,nor,dn1)
+
+!      DO kz = kts,kte
+!       DO ix = its,ite
+!           an(ix,1,kz,lnr)  = an(ix,1,kz,lnr) + ancuten(ix,1,kz,lnr)
+!           an(ix,1,kz,lns)  = an(ix,1,kz,lns) + ancuten(ix,1,kz,lns)
+!           an(ix,1,kz,lni)  = an(ix,1,kz,lni) + ancuten(ix,1,kz,lni)
+!           an(ix,1,kz,lnc)  = an(ix,1,kz,lnc) + ancuten(ix,1,kz,lnc)
+!       ENDDO
+!      ENDDO
+       
+       ENDIF
+       
+      ENDIF
+
+
       call sediment1d(dtp,nx,ny,nz,an,na,nor,nor,xfall,dn1,dz2d,dz2dinv, &
      &                    t0,t7,infdo,jy,its,jts &
      &   ,timesed1,timesed2,timesed3,zmaxsed,timesetvt)
@@ -2015,7 +2128,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
 ! Following Greg Thompson, calculation for effective radii. Used by RRTMG LW/SW schemes if enabled in module_physics_init.F
       IF ( present( has_reqc ).and. present( has_reqi ) .and. present( has_reqs ) .and.  &
            present( re_cloud ).and. present( re_ice ) .and. present( re_snow ) ) THEN
-       IF ( has_reqc.ne.0 .and. has_reqi.ne.0 .and. has_reqs.ne.0) THEN
+       IF ( has_reqc.ne.0 .or. has_reqi.ne.0 .or. has_reqs.ne.0) THEN
          DO kz = kts,kte
           DO ix = its,ite
              re_cloud(ix,kz,jy)  = 2.51E-6
@@ -2038,6 +2151,8 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
              re_cloud(ix,kz,jy) = MAX(2.51E-6, MIN(t1(ix,1,kz), 50.E-6))
              re_ice(ix,kz,jy)   = MAX(10.01E-6, MIN(t2(ix,1,kz), 125.E-6))
              re_snow(ix,kz,jy)  = MAX(25.E-6, MIN(t3(ix,1,kz), 999.E-6))
+             ! check for case where snow needs to be treated as cloud ice (for rrtmg radiation)
+             IF ( .not. present(qi) ) re_snow(ix,kz,jy)  = MAX(10.E-6, MIN(t3(ix,1,kz), 125.E-6))
           ENDDO
          ENDDO
        
@@ -2069,7 +2184,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
          qv(ix,kz,jy)  = an(ix,1,kz,lv)
          qc(ix,kz,jy)  = an(ix,1,kz,lc)
          qr(ix,kz,jy)  = an(ix,1,kz,lr)
-         qi(ix,kz,jy)  = an(ix,1,kz,li)
+         IF ( present(qi) ) qi(ix,kz,jy)  = an(ix,1,kz,li)
          qs(ix,kz,jy)  = an(ix,1,kz,ls)
          qh(ix,kz,jy)  = an(ix,1,kz,lh)
          IF ( lhl > 1 ) qhl(ix,kz,jy) = an(ix,1,kz,lhl)
@@ -2080,7 +2195,7 @@ SUBROUTINE nssl_2mom_driver(qv, qc, qr, qi, qs, qh, qhl, ccw, crw, cci, csw, chw
 
           ccw(ix,kz,jy) = an(ix,1,kz,lnc)
           crw(ix,kz,jy) = an(ix,1,kz,lnr)
-          cci(ix,kz,jy) = an(ix,1,kz,lni)
+          IF ( present( cci ) ) cci(ix,kz,jy) = an(ix,1,kz,lni)
           csw(ix,kz,jy) = an(ix,1,kz,lns)
           chw(ix,kz,jy) = an(ix,1,kz,lnh)
           IF ( lhl > 1 ) chl(ix,kz,jy) = an(ix,1,kz,lnhl)
@@ -2123,7 +2238,7 @@ END SUBROUTINE nssl_2mom_driver
 ! #####################################################################
 ! #####################################################################
 
-      REAL FUNCTION GAMMA(xx)
+      REAL FUNCTION GAMMA_SP(xx)
 
       implicit none
       real xx
@@ -2155,10 +2270,10 @@ REAL FUNCTION GAMMA(xx)
         y = y + 1.0d0
         ser = ser + cof(j)/y
       END DO
-      gamma = Exp(tmp + log(stp*ser/x))
+      gamma_sp = Exp(tmp + log(stp*ser/x))
 
       RETURN
-      END FUNCTION GAMMA
+      END FUNCTION GAMMA_SP
 
 ! #####################################################################
 
@@ -2189,7 +2304,7 @@ real function GAMXINF(A1,X1)
         ENDIF
         IF (X.EQ.0.0) THEN
            GIN=0.0
-           GIM = GAMMA(A1)
+           GIM = GAMMA_SP(A1)
         ELSE IF (X.LE.1.0+A) THEN
            S=1.0D0/A
            R=S
@@ -2199,7 +2314,7 @@ real function GAMXINF(A1,X1)
               IF (DABS(R/S).LT.1.0D-15) GO TO 15
 10         CONTINUE
 15         GIN=DEXP(XAM)*S
-           ga = GAMMA(A1)
+           ga = GAMMA_SP(A1)
            GIM=GA-GIN
         ELSE IF (X.GT.1.0+A) THEN
            T0=0.0D0
@@ -2207,7 +2322,7 @@ real function GAMXINF(A1,X1)
               T0=(K-A)/(1.0D0+K/(X+T0))
 20         CONTINUE
            GIM=DEXP(XAM)/(X+T0)
-!           GA = GAMMA(A1)
+!           GA = GAMMA_SP(A1)
 !           GIN=GA-GIM
         ENDIF
         
@@ -2225,7 +2340,7 @@ double precision function GAMXINFDP(A1,X1)
 !       Input :  a   --- Parameter ( a < 170 )
 !                x   --- Argument 
 !       Output:  GIM --- Gamma(a,x) t=x,Infinity
-!       Routine called: GAMMA for computing â(x)
+!       Routine called: GAMMA for computing Ahat(x)
 !       ===================================================
 
 !        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
@@ -2495,8 +2610,9 @@ SUBROUTINE GAMMADP(X,GA)
            IF (X.GT.0.0D0) THEN
               GA=1.0D0
               M1=X-1
-              DO 10 K=2,M1
-10               GA=GA*K
+              DO K=2,M1
+                GA=GA*K
+              ENDDO
            ELSE
               GA=1.0D+300
            ENDIF
@@ -2505,8 +2621,9 @@ SUBROUTINE GAMMADP(X,GA)
               Z=DABS(X)
               M=INT(Z)
               R=1.0D0
-              DO 15 K=1,M
-15               R=R*(Z-K)
+              DO K=1,M
+                 R=R*(Z-K)
+              ENDDO
               Z=Z-M
            ELSE
               Z=X
@@ -2524,8 +2641,9 @@ SUBROUTINE GAMMADP(X,GA)
      &          -.36968D-11, .51D-12,                          &
      &          -.206D-13, -.54D-14, .14D-14, .1D-15/
            GR=G(26)
-           DO 20 K=25,1,-1
-20            GR=GR*Z+G(K)
+           DO K=25,1,-1
+             GR=GR*Z+G(K)
+           ENDDO
            GA=1.0D0/(GR*Z)
            IF (DABS(X).GT.1.0D0) THEN
               GA=GA*R
@@ -2557,7 +2675,7 @@ Function delbk(bb,nu,mu,k)
 !
 
       implicit none
-      real delbk, gamma
+      real delbk
       real nu, mu, bb
       integer k
       
@@ -2581,8 +2699,8 @@ Function delbk(bb,nu,mu,k)
         x3 = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
       
 !      delbk =  &
-!     &  ((Gamma((1.0 + nu)/mu)/Gamma((2.0 + nu)/mu))**(2.0*bb + k)* &
-!     &    Gamma((1.0 + 2.0*bb + k + nu)/mu))/Gamma((1.0 + nu)/mu)
+!     &  ((Gamma_sp((1.0 + nu)/mu)/Gamma_sp((2.0 + nu)/mu))**(2.0*bb + k)* &
+!     &    Gamma_sp((1.0 + 2.0*bb + k + nu)/mu))/Gamma_sp((1.0 + nu)/mu)
 
       delbk =  &
      &  ((x1/x2)**(2.0*bb + k)* &
@@ -2599,7 +2717,7 @@ END  Function delbk
       Function delabk(ba,bb,nua,nub,mua,mub,k)
       
       implicit none
-      real delabk, gamma
+      real delabk
       real nua, mua, ba
       integer k
       real nub, mub, bb
@@ -2617,7 +2735,7 @@ Function delabk(ba,bb,nua,nub,mua,mub,k)
           STOP
         ENDIF
         g1pnua = gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami
-!        write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma((1. + nua)/mua)
+!        write(91,*) 'delabk: g1pnua,gamma = ',g1pnua,Gamma_sp((1. + nua)/mua)
 
         tmp = ((2. + nua)/mua)
         i = Int(dgami*(tmp))
@@ -2842,6 +2960,7 @@ subroutine sediment1d(dtp,nx,ny,nz,an,na,nor,norz,xfall,dn,dz3d,dz3dinv, &
 
 ! loop over each species and do sedimentation for all moments
      DO il = lc,lhab
+       IF ( ido(il) == 0 ) CYCLE
 
 !       IF ( .not. hasmass(ix,il) ) CYCLE
 
@@ -3539,6 +3658,7 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn)
       real, parameter :: zrfac = 1./(pi*xdnr*xn0r)
       real, parameter :: zsfac = 1./(pi*xdns*xn0s)
       real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0))
+      real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3    ! mks   (100 micron diam solid sphere approx)
 
       real xv,xdn
       integer :: ndbz, nmwgt, nnwgt, nwlessthanz
@@ -3577,6 +3697,14 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn)
            ENDIF
          ENDIF
 
+   !  Cloud ice
+         
+         IF ( lni > 1 ) THEN
+           IF ( an(ix,jy,kz,lni) <= 0.1*cxmin .and. an(ix,jy,kz,li) > qxmin(li) ) THEN
+             an(ix,jy,kz,lni) = an(ix,jy,kz,li)/xims
+           ENDIF
+         ENDIF
+
    !  rain
          
          IF ( lnr > 1 ) THEN
@@ -3665,6 +3793,202 @@ subroutine calcnfromq(nx,ny,nz,an,na,nor,norz,dn)
       
       END subroutine calcnfromq
 
+! ##############################################################################
+! ##############################################################################
+!
+!  Subroutine to calculate number concentrations from convection parameterization rates that have only mixing ratio.
+!  N will be in #/kg, NOT #/m^3, since sedimentation is done next.
+!
+
+!
+! 10.27.2015: Added hail calculation
+!
+      subroutine calcnfromcuten(nx,ny,nz,an,anold,na,nor,norz,dn)
+
+      
+      implicit none
+
+      integer nx,ny,nz,nor,norz,na,ngt,jgs,ixcol
+
+      real an(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)  ! scalars (q, N, Z) from CUTEN arrays
+      real anold(-nor+1:nx+nor,-nor+1:ny+nor,-norz+1:nz+norz,na)  ! scalars (q, N, Z)
+
+      real dn(nx,nz+1)  ! air density
+      
+      integer ixe,kze
+      real    alpha
+      real    qmin
+      real    xvmn,xvmx
+      integer ipconc
+      integer lvol ! index for volume
+      integer infall
+      
+      
+      integer ix,jy,kz
+      double precision vr,q,nrx,rd,g1h,g1hl,g1r,g1s,zx,chw,z,znew,zt,zxt,n1,laminv1
+      double precision :: zr, zs, zh, dninv
+      real, parameter :: xn0s = 3.0e6, xn0r = 8.0e6, xn0h = 4.0e4, xn0hl = 4.0e4
+      real, parameter :: xdnr = 1000., xdns = 100. ,xdnh = 700.0, xdnhl = 900.0
+      real, parameter :: zhlfac = 1./(pi*xdnhl*xn0hl)
+      real, parameter :: zhfac = 1./(pi*xdnh*xn0h)
+      real, parameter :: zrfac = 1./(pi*xdnr*xn0r)
+      real, parameter :: zsfac = 1./(pi*xdns*xn0s)
+      real, parameter :: g0 = (6.0)*(5.0)*(4.0)/((3.0)*(2.0)*(1.0))
+      real, parameter :: xims=900.*0.523599*(2.*50.e-6)**3    ! mks   (100 micron diam solid sphere approx)
+      real, parameter :: xcms=1000.*0.523599*(2.*7.5e-6)**3    ! mks   (100 micron diam solid sphere approx)
+
+      real :: xmass,xv,xdn
+      integer :: ndbz, nmwgt, nnwgt, nwlessthanz
+
+! ------------------------------------------------------------------
+      
+      
+      jy = 1
+      
+      
+         g1h = (6.0 + alphah)*(5.0 + alphah)*(4.0 + alphah)/  &
+     &        ((3.0 + alphah)*(2.0 + alphah)*(1.0 + alphah))
+
+         g1hl = (6.0 + alphahl)*(5.0 + alphahl)*(4.0 + alphahl)/  &
+     &        ((3.0 + alphahl)*(2.0 + alphahl)*(1.0 + alphahl))
+     
+         IF ( imurain == 3 ) THEN
+         g1r = (rnu+2.0)/(rnu+1.0)
+         ELSE ! imurain == 1
+         g1r = (6.0 + alphar)*(5.0 + alphar)*(4.0 + alphar)/  &
+     &        ((3.0 + alphar)*(2.0 + alphar)*(1.0 + alphar))
+         ENDIF
+
+         g1s = (snu+2.0)/(snu+1.0)
+      
+      DO kz = 1,nz
+       DO ix = 1,nx ! ixcol
+
+         dninv = 1./dn(ix,kz)
+         
+   !  Cloud droplets
+         
+         IF ( lnc > 1 ) THEN
+!           IF ( an(ix,jy,kz,lnc) <= 0.1*cxmin .and. an(ix,jy,kz,lc) > qxmin(lc) ) THEN
+           IF ( an(ix,jy,kz,lnc) > qxmin(lc) ) THEN
+             anold(ix,jy,kz,lnc) = anold(ix,jy,kz,lnc) + an(ix,jy,kz,lc)/xcms
+           ENDIF
+         ENDIF
+
+   !  Cloud ice
+         
+         IF ( lni > 1 ) THEN
+           IF ( an(ix,jy,kz,lni) > qxmin(li) ) THEN
+             anold(ix,jy,kz,lni) = anold(ix,jy,kz,lni) + an(ix,jy,kz,li)/xims
+           ENDIF
+         ENDIF
+
+   !  rain
+         
+         IF ( lnr > 1 ) THEN
+           IF ( an(ix,jy,kz,lr) > qxmin(lr) ) THEN ! adding rain mass from CU scheme
+
+            IF ( .true. .or. (anold(ix,jy,kz,lr) - an(ix,jy,kz,lr)) < qxmin(lr) .or. anold(ix,jy,kz,lnr) < cxmin ) THEN 
+
+             q = an(ix,jy,kz,lr)
+             
+             laminv1 = (dn(ix,kz) * q * zrfac)**(0.25)  ! inverse of slope
+             
+             n1 = laminv1*xn0r  ! number concentration for inv. exponential single moment input
+             
+             nrx =  n1*g1r/g0   ! number concentration for different shape parameter
+
+             anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + nrx ! *dninv ! convert to number mixing ratio
+
+            ELSE
+             ! assume mean particle mass of pre-existing snow
+                xmass = anold(ix,jy,kz,lr)/anold(ix,jy,kz,lnr)
+                anold(ix,jy,kz,lnr) = anold(ix,jy,kz,lnr) + an(ix,jy,kz,lr)/xmass
+            ENDIF
+             
+           ENDIF
+         ENDIF
+
+  ! snow
+         IF ( lns > 1 ) THEN
+           IF ( an(ix,jy,kz,ls) > qxmin(ls) ) THEN ! adding snow mass from CU scheme
+
+             IF ( .true. .or. (anold(ix,jy,kz,ls) - an(ix,jy,kz,ls)) < qxmin(ls) .or. anold(ix,jy,kz,lns) < cxmin ) THEN 
+             
+             ! assume that there was no snow before this
+             
+             q = an(ix,jy,kz,ls)
+             
+             laminv1 = (dn(ix,kz) * q * zsfac)**(0.25)  ! inverse of slope
+             
+             n1 = laminv1*xn0s  ! number concentration for inv. exponential single moment input
+             
+             nrx =  n1*g1s/g0   ! number concentration for different shape parameter
+
+             anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + nrx ! *dninv ! convert to number mixing ratio
+             
+             ELSE
+             ! assume mean particle mass of pre-existing snow
+                xmass = anold(ix,jy,kz,ls)/anold(ix,jy,kz,lns)
+                anold(ix,jy,kz,lns) = anold(ix,jy,kz,lns) + an(ix,jy,kz,ls)/xmass
+             ENDIF
+             
+           ENDIF
+         ENDIF
+         
+    ! graupel
+
+!         IF ( lnh > 1 ) THEN
+!           IF ( an(ix,jy,kz,lnh) <= 0.1*cxmin .and. an(ix,jy,kz,lh) > qxmin(lh) ) THEN
+!             IF ( lvh > 1 ) THEN
+!               IF ( an(ix,jy,kz,lvh) <= 0.0 ) THEN
+!                 an(ix,jy,kz,lvh) = an(ix,jy,kz,lh)/xdnh
+!               ENDIF
+!             ENDIF
+!
+!             q = an(ix,jy,kz,lh)
+!             
+!             laminv1 = (dn(ix,kz) * q * zhfac)**(0.25)  ! inverse of slope
+!             
+!             n1 = laminv1*xn0h  ! number concentration for inv. exponential single moment input
+!             
+!             nrx =  n1*g1h/g0   ! number concentration for different shape parameter
+!
+!             an(ix,jy,kz,lnh) = nrx ! *dninv ! convert to number mixing ratio
+!
+!           ENDIF
+!         ENDIF
+!
+!    ! hail
+!
+!         IF ( lnhl > 1 .and. lhl > 1 ) THEN
+!           IF ( an(ix,jy,kz,lnhl) <= 0.1*cxmin .and. an(ix,jy,kz,lhl) > qxmin(lhl) ) THEN
+!             IF ( lvhl > 1 ) THEN
+!               IF ( an(ix,jy,kz,lvhl) <= 0.0 ) THEN
+!                 an(ix,jy,kz,lvhl) = an(ix,jy,kz,lhl)/xdnhl
+!               ENDIF
+!             ENDIF
+!
+!             q = an(ix,jy,kz,lhl)
+!             
+!             laminv1 = (dn(ix,kz) * q * zhlfac)**(0.25)  ! inverse of slope
+!             
+!             n1 = laminv1*xn0hl  ! number concentration for inv. exponential single moment input
+!             
+!             nrx =  n1*g1hl/g0   ! number concentration for different shape parameter
+!
+!             an(ix,jy,kz,lnhl) = nrx ! *dninv ! convert to number mixing ratio
+!
+!           ENDIF
+!         ENDIF
+ 
+      ENDDO ! ix
+      ENDDO ! kz
+      
+      RETURN
+      
+      END subroutine calcnfromcuten
+
 ! #####################################################################
 ! #####################################################################
 
@@ -3751,16 +4075,16 @@ SUBROUTINE calc_eff_radius    &
        pb(:) = 0.0
        pinit(:) = 0.0
 
-     gamc1 = Gamma(2. + cnu)
+     gamc1 = Gamma_sp(2. + cnu)
      gamc2 = 1. ! Gamma[1 + alphac]
-     gami1 = Gamma(2. + cinu)
+     gami1 = Gamma_sp(2. + cinu)
      gami2 = 1. ! Gamma[1 + alphac]
-     gams1 = Gamma(2. + cinu)
-     gams2 = Gamma(1. + snu)
+     gams1 = Gamma_sp(2. + cinu)
+     gams2 = Gamma_sp(1. + snu)
 
-     factor_c = (1. + cnu)*Gamma(1. + cnu)/Gamma(5./3. + cnu)
-     factor_i = (1. + cinu)*Gamma(1. + cinu)/Gamma(5./3. + cinu)
-     factor_s = (1. + snu)*Gamma(1. + snu)/Gamma(5./3. + snu)
+     factor_c = (1. + cnu)*Gamma_sp(1. + cnu)/Gamma_sp(5./3. + cnu)
+     factor_i = (1. + cinu)*Gamma_sp(1. + cinu)/Gamma_sp(5./3. + cinu)
+     factor_s = (1. + snu)*Gamma_sp(1. + snu)/Gamma_sp(5./3. + snu)
 
 !
 !     jy = 1 ! working on a 2d slab
@@ -4014,6 +4338,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
 
       
       
+      real swmasmx, dtmp
       real cd
       real cwc0 ! ,cwc1
       real :: cwch(ngscnt), cwchl(ngscnt)
@@ -4102,14 +4427,14 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
           IF ( dmuh == 1.0 ) THEN
             cwchtmp = ((3. + dnu(lh))*(2. + dnu(lh))*(1.0 + dnu(lh)))**(-1./3.)
           ELSE
-            cwchtmp = 6.0*pii*gamma( (xnu(lh) + 1.)/xmu(lh) )/gamma( (xnu(lh) + 2.)/xmu(lh) )
+            cwchtmp = 6.0*pii*gamma_sp( (xnu(lh) + 1.)/xmu(lh) )/gamma_sp( (xnu(lh) + 2.)/xmu(lh) )
           ENDIF
         ENDIF
         IF ( lhl .gt. 1 ) THEN
           IF ( dmuhl == 1.0 ) THEN
             cwchltmp = ((3. + dnu(lhl))*(2. + dnu(lhl))*(1.0 + dnu(lhl)))**(-1./3.)
           ELSE
-            cwchltmp = 6.0*pii*gamma( (xnu(lhl) + 1)/xmu(lhl) )/gamma( (xnu(lhl) + 2)/xmu(lhl) )
+            cwchltmp = 6.0*pii*gamma_sp( (xnu(lhl) + 1)/xmu(lhl) )/gamma_sp( (xnu(lhl) + 2)/xmu(lhl) )
           ENDIF
         ENDIF
 
@@ -4125,7 +4450,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
               cwch(mgs) = ((3. + alpha(mgs,lh))*(2. + alpha(mgs,lh))*(1.0 + alpha(mgs,lh)))**(-1./3.)
              ELSE
              xnutmp = (alpha(mgs,lh) - 2.0)/3.0
-             cwch(mgs) =  6.0*pii*gamma( (xnutmp + 1.)/xmu(lh) )/gamma( (xnutmp + 2.)/xmu(lh) )
+             cwch(mgs) =  6.0*pii*gamma_sp( (xnutmp + 1.)/xmu(lh) )/gamma_sp( (xnutmp + 2.)/xmu(lh) )
             ENDIF
            ELSE
              cwch(mgs) = cwchtmp
@@ -4137,7 +4462,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
               cwchl(mgs) = ((3. + alpha(mgs,lhl))*(2. + alpha(mgs,lhl))*(1.0 + alpha(mgs,lhl)))**(-1./3.)
              ELSE
              xnutmp = (alpha(mgs,lhl) - 2.0)/3.0
-             cwchl(mgs) = 6.0*pii*gamma( (xnutmp + 1)/xmu(lhl) )/gamma( (xnutmp + 2)/xmu(lhl) )
+             cwchl(mgs) = 6.0*pii*gamma_sp( (xnutmp + 1)/xmu(lhl) )/gamma_sp( (xnutmp + 2)/xmu(lhl) )
             ENDIF
            ELSE
              cwchl(mgs) = cwchltmp
@@ -4440,14 +4765,46 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
       if ( qx(mgs,ls) .gt. qxmin(ls) ) then
       if ( ipconc .ge. 4 ) then ! 
 
-        xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls)))
+!        xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls)))
 !      parameter( xvmn(lr)=2.8866e-13, xvmx(lr)=4.1887e-9 )  ! mks
-        xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls)
+!        xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls)
 
-        IF ( xv(mgs,ls) .lt. xvmn(ls) .or. xv(mgs,ls) .gt. xvmx(ls) ) THEN
-          xv(mgs,ls) = Min( xvmx(ls), Max( xvmn(ls),xv(mgs,ls) ) )
+        xmas(mgs,ls) =  rho0(mgs)*qx(mgs,ls)/(Max(1.0e-9,cx(mgs,ls)))
+
+        IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship
+        
+          xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) )
+          xdn(mgs,ls) = Max( 100.0, xdn(mgs,ls) )  ! limit snow to 100. to keep other equations in line
+          
+          IF ( xdn(mgs,ls) <= 900. ) THEN
+             dtmp = Sqrt( xmas(mgs,ls)/0.069 ) ! diameter (meters) of mean mass particle using Cox 1998 relation (m = p d^2)
+             xv(mgs,ls) = 28.8887*xmas(mgs,ls)**(3./2.)
+          ELSE ! at small sizes, assume ice spheres
+             xdn(mgs,ls) = 900.
+             xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls)))
+             dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
+          ENDIF
+          
+        ELSE ! leave xdn(ls) at default value
+             xv(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xdn(mgs,ls)*Max(1.0e-9,cx(mgs,ls)))
+             dtmp = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
+        ENDIF
+
+        xdia(mgs,ls,1) = dtmp ! (xv(mgs,ls)*cwc0*6.0)**(1./3.)
+
+        IF ( xv(mgs,ls) .lt. xvmn(ls) .and. isnowdens == 1) THEN
+          xv(mgs,ls) = Max( xvmn(ls),xv(mgs,ls) )
           xmas(mgs,ls) = xv(mgs,ls)*xdn(mgs,ls)
           cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls))
+          xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
+        ENDIF
+
+        IF ( xv(mgs,ls) .gt. xvmx(ls)*Max(1.,100./Min(100.,xdn(mgs,ls))) ) THEN
+          xv(mgs,ls) = Min( xvmx(ls), Max( xvmn(ls),xv(mgs,ls) ) )
+          xmas(mgs,ls) = 0.106214*xv(mgs,ls)**(2./3.)
+          cx(mgs,ls) = rho0(mgs)*qx(mgs,ls)/(xmas(mgs,ls))
+          xdn(mgs,ls) = 0.0346159*Sqrt(cx(mgs,ls)/(qx(mgs,ls)*rho0(mgs)) )
+          xdia(mgs,ls,1) = Sqrt( xmas(mgs,ls)/0.069 ) 
         ENDIF
 
         xdia(mgs,ls,1) = (xv(mgs,ls)*cwc0*6.0)**(1./3.)
@@ -4464,6 +4821,11 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
       xdia(mgs,ls,1) = 1.e-9
       xdia(mgs,ls,3) = 1.e-9
       cx(mgs,ls) = 0.0
+      
+       IF ( isnowdens == 2 ) THEN ! Set values according to Cox relationship
+         xdn(mgs,ls) = 90.
+       ENDIF
+
       end if
       xdia(mgs,ls,2) = xdia(mgs,ls,1)**2
 !      swdia3(mgs) = xdia(mgs,ls,2)*xdia(mgs,ls,1)
@@ -4649,27 +5011,27 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
         IF ( infdo .ge. 1 .and. rssflg == 1) THEN ! number-weighted; DTD: added size-sorting flag
         vtxbar(mgs,lr,2) = rhovt(mgs)*                             &
      &     (((1. + rnux)/vr)**(-1.333333)*                         &
-     &    (0.0911229*((1. + rnux)/vr)**1.333333*Gamma(1. + rnux) + &
-     &      (5430.3131*(1. + rnux)*Gamma(4./3. + rnux))/           &
+     &    (0.0911229*((1. + rnux)/vr)**1.333333*Gamma_sp(1. + rnux) + &
+     &      (5430.3131*(1. + rnux)*Gamma_sp(4./3. + rnux))/           &
      &       vr - 1.0732802e6*((1. + rnux)/vr)**0.6666667*         &
-     &       Gamma(1.666667 + rnux) +                              &
+     &       Gamma_sp(1.666667 + rnux) +                              &
      &      8.584110982429507e7*((1. + rnux)/vr)**(1./3.)*         &
-     &       Gamma(2. + rnux) -                                    &
-     &      2.3303765697228556e9*Gamma(7./3. + rnux)))/            &
-     &  Gamma(1. + rnux)
+     &       Gamma_sp(2. + rnux) -                                    &
+     &      2.3303765697228556e9*Gamma_sp(7./3. + rnux)))/            &
+     &  Gamma_sp(1. + rnux)
         ENDIF
 
 !  mass-weighted
        vtxbar(mgs,lr,1)  = rhovt(mgs)*                                                 &
-     &   (0.0911229*(1 + rnux)**1.3333333333333333*Gamma(2. + rnux) +                  &
+     &   (0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(2. + rnux) +                  &
      &    5430.313059683277*(1 + rnux)*vr**0.3333333333333333*                         &
-     &     Gamma(2.333333333333333 + rnux) -                                           &
+     &     Gamma_sp(2.333333333333333 + rnux) -                                           &
      &    1.0732802065650471e6*(1 + rnux)**0.6666666666666666*vr**0.6666666666666666*  &
-     &     Gamma(2.6666666666666667 + rnux) +                                          &
-     &    8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma(3 + rnux) -      &
+     &     Gamma_sp(2.6666666666666667 + rnux) +                                          &
+     &    8.584110982429507e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(3 + rnux) -      &
      &    2.3303765697228556e9*vr**1.3333333333333333*                                 &
-     &     Gamma(3.333333333333333 + rnux))/                                           &
-     &  ((1 + rnux)**2.333333333333333*Gamma(1 + rnux)) 
+     &     Gamma_sp(3.333333333333333 + rnux))/                                           &
+     &  ((1 + rnux)**2.333333333333333*Gamma_sp(1 + rnux)) 
      
         IF(infdo .ge. 1 .and. rssflg == 0) THEN ! No size-sorting, set N-weighted fall speed to mass-weighted
           vtxbar(mgs,lr,2) = vtxbar(mgs,lr,1)
@@ -4677,15 +5039,15 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
       
         IF ( infdo .ge. 2 .and. rssflg == 1) THEN ! Z-weighted fall speed
         vtxbar(mgs,lr,3)  =   rhovt(mgs)*                                          &
-     &  ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma(3. + rnux) +  &
+     &  ((1. + rnux)*(0.0911229*(1 + rnux)**1.3333333333333333*Gamma_sp(3. + rnux) +  &
      &      5430.313059683277*(1 + rnux)*vr**0.3333333333333333*                   &
-     &       Gamma(3.3333333333333335 + rnux) -                                    &
+     &       Gamma_sp(3.3333333333333335 + rnux) -                                    &
      &      1.0732802065650471e6*(1 + rnux)**0.6666666666666666*                   &
-     &       vr**0.6666666666666666*Gamma(3.6666666666666665 + rnux) +             &
-     &      8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*Gamma(4. + rnux) - &
+     &       vr**0.6666666666666666*Gamma_sp(3.6666666666666665 + rnux) +             &
+     &      8.5841109824295e7*(1 + rnux)**0.3333333333333333*vr*Gamma_sp(4. + rnux) - &
      &      2.3303765697228556e9*vr**1.3333333333333333*                           &
-     &       Gamma(4.333333333333333 + rnux)))/                                    &
-     &  ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma(1 + rnux))
+     &       Gamma_sp(4.333333333333333 + rnux)))/                                    &
+     &  ((1 + rnux)**3.3333333333333335*(2 + rnux)*Gamma_sp(1 + rnux))
         
 !         write(0,*) 'setvt: mgs,lzr,infdo = ',mgs,lzr,infdo
 !         write(0,*) 'vt1,2,3 = ',vtxbar(mgs,lr,1),vtxbar(mgs,lr,2),vtxbar(mgs,lr,3)
@@ -4733,7 +5095,11 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
            vtxbar(mgs,ls,1) = 5.72462*rhovt(mgs)*(xv(mgs,ls))**(1./12.)
           ELSEIF ( isnowfall == 2 ) THEN
           ! Ferrier:
-            vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14)
+            IF ( isnowdens == 1 ) THEN
+              vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls))**(0.14)
+            ELSE
+              vtxbar(mgs,ls,1) = 11.9495*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14) 
+            ENDIF
           ENDIF
           
           IF(sssflg == 1) THEN
@@ -4741,7 +5107,11 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
               vtxbar(mgs,ls,2) = 4.04091*rhovt(mgs)*(xv(mgs,ls))**(1./12.)
             ELSEIF ( isnowfall == 2 ) THEN
             ! Ferrier:
-              vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14) ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1)
+              IF ( isnowdens == 1 ) THEN
+                vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls))**(0.14)  ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1)
+              ELSE
+                vtxbar(mgs,ls,2) = 7.02909*rhovt(mgs)*(xv(mgs,ls)*xdn(mgs,ls)/100.)**(0.14)  ! bug fix 11/15/2015: was rewriting to mass fall speed vtxbar(mgs,ls,1)
+              ENDIF
             ENDIF
           ELSE
             vtxbar(mgs,ls,2) = vtxbar(mgs,ls,1)
@@ -4839,7 +5209,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
           vtxbar(mgs,lh,1) =  rhovt(mgs)*ax(lh)*(xdia(mgs,lh,1)**bx(lh)*x)/y          
         ENDIF
 
-!     &    Gamma(4.0 + dnu(lh) + 0.6))/Gamma(4. + dnu(lh))
+!     &    Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh))
       ENDIF
 
       IF ( lwsm6 .and. ipconc == 0 ) THEN
@@ -4929,7 +5299,7 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
          vtxbar(mgs,lhl,1) =  rhovt(mgs)*(ax(lhl)*xdia(mgs,lhl,1)**bx(lhl)*x)/y
         ENDIF
         
-!     &    Gamma(4.0 + dnu(lh) + 0.6))/Gamma(4. + dnu(lh))
+!     &    Gamma_sp(4.0 + dnu(lh) + 0.6))/Gamma_sp(4. + dnu(lh))
       ENDIF
 
 
@@ -5069,9 +5439,9 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
                   IF ( infdo .ge. 2 ) THEN ! Z-weighted
                    vtxbar(mgs,il,3) = rhovt(mgs)*                 &
      &                (aax*(1.0/xdia(mgs,il,1) )**(- bbx)*  &
-     &                 Gamma(7.0 + alpha(mgs,il) + bbx))/Gamma(7. + alpha(mgs,il))
+     &                 Gamma_sp(7.0 + alpha(mgs,il) + bbx))/Gamma_sp(7. + alpha(mgs,il))
 !     &                (aax*(1.0/xdia(mgs,il,1) )**(- bx(il))*  &
-!     &                 Gamma(7.0 + alpha(mgs,il) + bx(il)))/Gamma(7. + alpha(mgs,il))
+!     &                 Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il))
                   ENDIF
 
       if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt3'
@@ -5084,21 +5454,21 @@ SUBROUTINE setvtz(ngscnt,qx,qxmin,qxw,cx,rho0,rhovt,xdia,cno,cnostmp, &
                  IF ( infdo .ge. 2 ) THEN ! Z-weighted
                   vtxbar(mgs,il,3) = rhovt(mgs)*                 &
      &              (aax*(1.0/xdia(mgs,il,1) )**(- bbx)*  &
-     &               Gamma(7.0 + alpha(mgs,il) + bbx))/Gamma(7. + alpha(mgs,il))
+     &               Gamma_sp(7.0 + alpha(mgs,il) + bbx))/Gamma_sp(7. + alpha(mgs,il))
 !     &              (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))*  &
-!     &               Gamma(7.0 + alpha(mgs,il) + bx(il)))/Gamma(7. + alpha(mgs,il))
+!     &               Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il))
                   ENDIF
 
       if ( ndebug1 .gt. 0 ) write(0,*) 'SETVTZ: Set hail vt4'
 
                  ENDIF ! }
-!     &             Gamma(1.0 + dnu(il) + 0.6)/Gamma(1. + dnu(il))
+!     &             Gamma_sp(1.0 + dnu(il) + 0.6)/Gamma_sp(1. + dnu(il))
                ENDIF ! }
 
 !              IF ( infdo .ge. 2 ) THEN ! Z-weighted
 !               vtxbar(mgs,il,3) = rhovt(mgs)*                 &
 !     &            (ax(il)*(1.0/xdia(mgs,il,1) )**(- bx(il))*  &
-!     &             Gamma(7.0 + alpha(mgs,il) + bx(il)))/Gamma(7. + alpha(mgs,il))
+!     &             Gamma_sp(7.0 + alpha(mgs,il) + bx(il)))/Gamma_sp(7. + alpha(mgs,il))
 !              ENDIF
 
 !               IF ( lhl .gt. 1 .and. il .eq. lhl ) THEN
@@ -5386,9 +5756,7 @@ subroutine ziegfall1d(nx,ny,nz,nor,norz,na,dtp,jgs,ixcol, &
         kgs(ngscnt) = kz
         if ( ngscnt .eq. ngs ) goto 1100
         end if
-!#ifndef MPI
         end do !!ix
-!#endif
         nxmpb = 1
        end do !! kz
 
@@ -6308,7 +6676,8 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
                     ! p = 0.106214 for m = p v^(2/3)
                  dnsnow = 0.346159*sqrt(an(ix,jy,kz,lns)/(an(ix,jy,kz,ls)*db(ix,jy,kz)) )
                  IF ( .true. .or. dnsnow < 900. ) THEN
-                  gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/    &
+                  gtmp(ix,kz) = 1.e18*323.3226* 0.106214**2*(ksq*an(ix,jy,kz,ls) + &
+     &             (1.-ksq)*qxw)*an(ix,jy,kz,ls)*db(ix,jy,kz)**2*gsnow73/         &
      &                   (an(ix,jy,kz,lns)*(917.)**2* gsnow1*(1.0+snu)**(4./3.))
                  ELSE ! otherwise small enough to assume ice spheres?
                   gtmp(ix,kz) = (36./pi**2) * 1.e18*(snu+2.)*( 0.224*(an(ix,jy,kz,ls)+qxw1) + 0.776*qxw)*(an(ix,jy,kz,ls)+qxw1)/ &
@@ -6322,7 +6691,7 @@ subroutine radardd02(nx,ny,nz,nor,na,an,temk,         &
 !             gtmp(ix,kz) = Max( 1.0*gtmp(ix,kz), 750.0*(tmp)**1.98)
              dtmps = gtmp(ix,kz)
              dtmp(ix,kz) = dtmp(ix,kz) + gtmp(ix,kz)
-            ELSE
+            ELSE ! }{ single-moment snow:
              gtmp(ix,kz) = dads*an(ix,jy,kz,ls)**(0.25)
              
              IF ( gtmp(ix,kz) .gt. 0.0 ) THEN !{
@@ -6732,7 +7101,7 @@ SUBROUTINE NUCOND    &
       integer kgsp(ngs),kgsm(ngs)
       integer nsvcnt
       
-      integer ix,kz,i,n, kp1
+      integer ix,kz,i,n, kp1, km1
       integer :: jy, jgs
       integer ixb,ixe,jyb,jye,kzb,kze
     
@@ -6757,7 +7126,7 @@ SUBROUTINE NUCOND    &
       integer ifilt   ! =1 to filter ssat, =0 to set ssfilt=ssat
       parameter ( ifilt = 0 ) 
       real temp1,temp2 ! ,ssold
-      real ssmax(ngs)       ! maximum SS experienced by a parcel
+      real :: ssmax(ngs) = 0.0       ! maximum SS experienced by a parcel
       real ssmx
       real dnnet,dqnet
 !      real cnu,rnu,snu,cinu
@@ -6790,6 +7159,7 @@ SUBROUTINE NUCOND    &
       real qv1m,qvs1m,ss1m,ssi1m,qis1m
       real cwmastmp 
       real  dcloud,dcloud2 ! ,as, bs
+      real dcrit
       real cn(ngs) 
 
       integer ltemq
@@ -6799,6 +7169,7 @@ SUBROUTINE NUCOND    &
       real  es(ngs) ! ss(ngs),
 !      real  eis(ngs)
       real ssf(ngs),ssfkp1(ngs),ssfkm1(ngs),ssat0(ngs)
+      real, parameter :: ssfcut = 4.0
       real ssfjp1(ngs),ssfjm1(ngs)
       real ssfip1(ngs),ssfim1(ngs)
 
@@ -6863,6 +7234,8 @@ SUBROUTINE NUCOND    &
 
 
       logical zerocx(lc:lqmx)
+      
+      logical :: lprint
 
       integer, parameter :: iunit = 0
       
@@ -6954,7 +7327,6 @@ SUBROUTINE NUCOND    &
 
       ixb = nxmpb
       ixe = itile
-!      if (ixbeg .le. nxmpb .and. ixend .gt. nxmpb) ixb = nxmpb
 
       do kz = kzb,kze
       do ix = nxmpb,nxi
@@ -7110,6 +7482,7 @@ SUBROUTINE NUCOND    &
         cx(mgs,lc) = Max(an(igs(mgs),jy,kgs(mgs),lnc), 0.0)
         cwnccn(mgs) = cwccn*rho0(mgs)/rho00
         cn(mgs) = 0.0
+        IF ( lss > 1 ) ssmax(mgs) = an(igs(mgs),jy,kgs(mgs),lss)
         IF ( lccn .gt. 1 ) THEN
           ccnc(mgs) = an(igs(mgs),jy,kgs(mgs),lccn)
         ELSE
@@ -7134,7 +7507,20 @@ SUBROUTINE NUCOND    &
 
 !        cnuc(1:ngscnt) = cwccn*rho0(mgs)/rho00*(1. - renucfrac) + ccnc(1:ngscnt)*renucfrac
        DO mgs = 1,ngscnt
+        IF ( irenuc /= 6 ) THEN
         cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + ccnc(mgs)*renucfrac
+        ELSE
+        cnuc(mgs) = Max(ccnc(mgs),cwnccn(mgs))*(1. - renucfrac) + Max(0.0,ccnc(mgs) - ccna(mgs))*renucfrac
+        ENDIF
+        IF ( renucfrac >= 0.999 ) THEN
+          IF ( temg(mgs) < 265. ) THEN
+            IF ( qx(mgs,lc) > 10.*qxmin(lc) .and. w(igs(mgs),jgs,kgs(mgs)) > 2.0 ) THEN
+             cnuc(mgs) = 0.0 !  Min(cnuc(mgs), 0.5*cx(mgs,lc) ) ! Hack to reduce nucleation at low temp in updraft when ccn are not predicted
+            ELSE
+             cnuc(mgs) = 0.1*cnuc(mgs)
+            ENDIF
+          ENDIF
+        ENDIF
        ENDDO
 
 !  Set density
@@ -7394,8 +7780,10 @@ SUBROUTINE NUCOND    &
               del = tmp - dgam*i
               y = (gmoi(i) + (gmoi(i+1) - gmoi(i))*del*dgami)/g1palp ! ratio of gamma functions
 
-         vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr)
-         vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr))
+!         vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK
+!         vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr))  ! Actually OK
+         vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula)
+         vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr))
         
         
         rwvent(mgs) =    &
@@ -7491,7 +7879,12 @@ SUBROUTINE NUCOND    &
             dtemp = -0.5*e1*f1*(dqv + dqvr)
 !          write(0,*) 'RK2c dqv1 = ',dqv
 ! calculate midpoint values:
-           ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5)
+     !      ltemq1m = ltemq1 + Nint(dtemp*fqsat + 0.5)
+
+         ! 7.6.2016: Test full calc of ltemq
+           ltemq1m = (temp1+dtemp-163.15)*fqsati+1.5
+           ltemq1m = Min( nqsat, Max(1,ltemq1m) )
+
            IF ( ltemq1m .lt. 1 .or. ltemq1m .gt. nqsat ) THEN
              write(0,*) 'STOP in nucond line 1192 '
              write(0,*) ' ltemq1m,icond = ',ltemq1m,icond
@@ -7529,7 +7922,13 @@ SUBROUTINE NUCOND    &
 
 !          write(0,*) 'RK2a dqv1m = ',dqv
           dtemp = -e1*f1*(dqv + dqvr)
-          ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5)
+          
+         ! ltemq1 = ltemq1 + Nint(dtemp*fqsat + 0.5)
+
+         ! 7.6.2016: Test full calc of ltemq
+           ltemq1 = (temp1+dtemp-163.15)*fqsati+1.5
+           ltemq1 = Min( nqsat, Max(1,ltemq1) )
+
            IF ( ltemq1 .lt. 1 .or. ltemq1 .gt. nqsat ) THEN
              write(0,*) 'STOP in nucond line 1230 '
              write(0,*) ' ltemq1m,icond = ',ltemq1m,icond
@@ -7561,6 +7960,8 @@ SUBROUTINE NUCOND    &
 
         dcloud = dqc ! qx(mgs,lv) - qv1
         thetap(mgs) = thetap(mgs) + e1*(DCLOUD + dqr)
+
+
         IF ( eqtset > 2 ) THEN
            pipert(mgs) = pipert(mgs) + felvpi(mgs)*(DCLOUD + dqr)
         ENDIF
@@ -7677,7 +8078,7 @@ SUBROUTINE NUCOND    &
 !         ccnc(mgs) = 0.0
        ENDIF
 !      cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
-      ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+      IF ( irenuc <= 2 ) ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
       ccna(mgs) = ccna(mgs) + cn(mgs)
       ENDIF
 
@@ -7725,7 +8126,7 @@ SUBROUTINE NUCOND    &
       r2dzm=0.50/dz3d(igs(mgs),jy,kgs(mgs))
       IF ( irenuc >= 0 .and. .not. flag_qndrop) THEN ! turn off nucleation when flag_qndrop (using WRF-CHEM for activation)
 
-      IF ( irenuc /= 2 ) THEN !{
+      IF ( irenuc < 2 ) THEN !{
 
         IF ( kzend == nzend ) THEN
           t0p3 = t0(igs(mgs),jgs,Min(kze,kgs(mgs)+3))
@@ -7751,7 +8152,7 @@ SUBROUTINE NUCOND    &
 ! otherwise check for cloud base condition with updraft:
 !
         ELSEIF( kzbeg-1+kgs(mgs) .GT. 1 .AND. kzbeg-1+kgs(mgs) .LT. nzend-1 &
-!        IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 &
+!        IF( kgs(mgs) .GT. 1 .AND. kgs(mgs) .LT. NZ-1 & !)
      &  .and. ssf(mgs) .gt. 0.0  .and. wvel(mgs) .gt. 0.0 &
      &  .and. ssfkp1(mgs) .gt. 0.0   &
      &  .AND. ssfkm1(mgs) .le. 0.0 .and. wvelkm1(mgs) .gt. 0.0 &
@@ -7804,11 +8205,137 @@ SUBROUTINE NUCOND    &
        cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
        
        ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+
+      ELSEIF ( irenuc == 7 ) THEN !} { 
+
+      ! simple Twomey scheme but limit activation to try to do most activation near cloud base, but keep some CCN available for renuclation
+!      if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR:  Cloud reNucleation, wvel = ',wvel(mgs)
+       cn(mgs) = 0.0
+!       IF ( ccna(mgs) < 0.7*cnuc(mgs) .and. ccnc(mgs) > 0.69*cnuc(mgs) - ccna(mgs)) THEN ! here, assume we are near cloud base and use Twomey formulation
+       IF ( ccna(mgs) < 0.9*cnuc(mgs) ) THEN ! { here, assume we are near cloud base and use Twomey formulation
+         CN(mgs) =  Min( 0.91*cnuc(mgs), CCNE0*cnuc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp )! *Min(1.0,1./dtp) ! 0.3465
+!         IF ( cn(mgs) + ccna(mgs) > 0.71*cnuc ) THEN
+         ! prevent this branch from activating more than 70% of CCN
+           CN(mgs) = Min( CN(mgs), Max(0.0, (0.9*cnuc(mgs) - ccna(mgs) )) )
+!           CN(mgs) = Min( CN(mgs), Max(0.0, 0.71*ccnc(mgs) - ccna(mgs) ) )
+           
+       ELSE ! }{
+        ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007.
+
+         temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
+!          t0(ix,jy,kz) = temp1
+          ltemq = Int( (temp1-163.15)/fqsat+1.5 )
+         ltemq = Min( nqsat, Max(1,ltemq) )
+
+        !  c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq)
+          c1= pqs(mgs)*tabqvs(ltemq)
+
+          ssf(mgs) = 0.0
+          IF ( c1 > 0. ) THEN
+            ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0)  ! from "new" values
+          ENDIF
+
+!          IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN
+          IF ( ssf(mgs) <= 1.0 ) THEN
+          CN(mgs) =   cnuc(mgs)*Min(1.0, Max(0.0,ssf(mgs))**cck ) ! 
+          ELSE
+          CN(mgs) =   cnuc(mgs)*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) !           
+!          write(0,*) 'iren7: ssf,ssmx = ',ssf(mgs),ssmax(mgs),cn(mgs),ccna(mgs),cnuc(mgs)
+!          write(0,*) 'c1,qv = ',c1,qx(mgs,lv),temp1,ltemq
+          ENDIF
+          
+
+!        CN(mgs) = Min( Min(0.1,ssf(mgs)-1.)*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from
+!        CN(mgs) = Min( Min(0.5*cx(mgs,lc), Min(0.1,ssf(mgs)/100.)*cnuc(mgs)), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from
+        CN(mgs) = Min(0.01*cnuc(mgs), Max( 0.0, CN(mgs) - ccna(mgs) ) ) ! this was from
+
+       ENDIF ! }
+!      ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
+!!!       CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
+               ! Philips, Donner et al. 2007, but results in too much limitation of
+               ! nucleation
+!       CN(mgs) = Min(cn(mgs), ccnc(mgs))
+!       cn(mgs) = Min(cn(mgs), 0.5*dqc/cwmasn) ! limit the nucleation mass to half of the condensation mass
+       
+       IF ( cn(mgs) > 0.0 ) THEN
+       cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+       
+       ! create some small droplets at minimum size (CP 2000), although it adds very little liquid
+       
+       dcrit = 2.0*2.5e-7
+       
+       dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs)
+        qx(mgs,lc) = qx(mgs,lc) + DCLOUD
+        thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
+        qwvp(mgs) = qwvp(mgs) - DCLOUD
+  !      ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+        ENDIF
+
+      ELSEIF ( irenuc == 8 ) THEN !} { 
+      ! simple Twomey scheme
+!      if (ndebug .gt. 0) write(0,*) 'ICEZVD_DR:  Cloud reNucleation, wvel = ',wvel(mgs)
+       
+       cn(mgs) = 0.0
+       
+       IF ( ccnc(mgs) > 0. ) THEN
+       CN(mgs) =   CCNE0*ccnc(mgs)**(2./(2.+cck))*Max(0.0,wvel(mgs))**cnexp ! *Min(1.0,1./dtp) ! 0.3465
+!      ccne = ccnefac*1.e6*(1.e-6*Abs(cwccn))**(2./(2.+cck))
+!!!       CN(mgs) = Max( 0.0, CN(mgs) - ccna(mgs) ) ! this was from
+               ! Philips, Donner et al. 2007, but results in too much limitation of
+               ! nucleation
+       CN(mgs) = Min(cn(mgs), ccnc(mgs))
+       
+       ELSEIF ( cx(mgs,lc) < 0.01e9 ) THEN
+
+        ! if a large fraction of CCN have been activated, then assume we are in the cloud interior and use local SSw as in Phillips et al. 2007.
+
+         temp1 = (theta0(mgs)+thetap(mgs))*pk(mgs) ! t77(ix,jy,kz)
+!          t0(ix,jy,kz) = temp1
+          ltemq = Int( (temp1-163.15)/fqsat+1.5 )
+         ltemq = Min( nqsat, Max(1,ltemq) )
+
+        !  c1 = t00(igs(mgs),jy,kgs(mgs))*tabqvs(ltemq)
+          c1= pqs(mgs)*tabqvs(ltemq)
+
+          ssf(mgs) = 0.0
+          IF ( c1 > 0. ) THEN
+            ssf(mgs) = 100.*(qx(mgs,lv)/c1 - 1.0)  ! from "new" values
+          ENDIF
+
+!          IF ( ssf(mgs) <= 1.0 .or. cnuc(mgs) > ccna(mgs) ) THEN
+          IF ( ssf(mgs) <= 1.0 ) THEN
+          CN(mgs) = 0.0
+          ELSE
+!          CN(mgs) = 0.01e9*rho0(mgs)/rho00*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc)
+           CN(mgs) = 0.01e9*Min(2.0, Max(0.0,0.03*(ssf(mgs)-1.0)+1.)**cck ) - cx(mgs,lc)
+          ENDIF
+       
+       ENDIF
+
+       IF ( cn(mgs) > 0.0 ) THEN
+       cx(mgs,lc) = cx(mgs,lc) + cn(mgs)
+       
+       ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
        
+       ! create some small droplets at minimum size (CP 2000), although it adds very little liquid
+       
+       dcrit = 2.0*2.5e-7
+       
+       dcloud = 1000.*dcrit**3*Pi/6.*cn(mgs)
+        qx(mgs,lc) = qx(mgs,lc) + DCLOUD
+        thetap(mgs) = thetap(mgs) + felvcp(mgs)*DCLOUD/(pi0(mgs))
+        qwvp(mgs) = qwvp(mgs) - DCLOUD
+  !      ccnc(mgs) = Max(0.0, ccnc(mgs) - cn(mgs))
+        ENDIF
+       
+
+
       ENDIF ! }
 
       ccna(mgs) = ccna(mgs) + cn(mgs)
 
+
+
       ENDIF ! irenuc >= 0 .and. .not. flag_qndrop
 
       IF( cx(mgs,lc) .GT. 0. .AND. qx(mgs,lc) .LE. qxmin(lc)) cx(mgs,lc)=0.
@@ -7957,9 +8484,13 @@ SUBROUTINE NUCOND    &
 
        IF (  ipconc .ge. 2 ) THEN
         an(igs(mgs),jy,kgs(mgs),lnc) = Max(cx(mgs,lc) , 0.0)
+        IF ( lss > 1 ) an(igs(mgs),jy,kgs(mgs),lss) = Max( 0.0, ssmax(mgs) )
         IF ( lccn .gt. 1 ) THEN
           an(igs(mgs),jy,kgs(mgs),lccn) = Max(0.0,  ccnc(mgs) )
         ENDIF
+        IF ( lccna .gt. 1 ) THEN
+          an(igs(mgs),jy,kgs(mgs),lccna) = Max(0.0, ccna(mgs) )
+        ENDIF
        ENDIF
        IF (  ipconc .ge. 3 .and. rcond == 2 ) THEN
         an(igs(mgs),jy,kgs(mgs),lnr) = Max(cx(mgs,lr) , 0.0)
@@ -8011,6 +8542,8 @@ SUBROUTINE NUCOND    &
 !      do jy = 1,1
       do ix = 1,nxi
       
+      t0(ix,jy,kz) = an(ix,jy,kz,lt)*t77(ix,jy,kz)
+      
       zerocx(:) = .false.
       DO il = lc,lhab
        IF ( iresetmoments == 1 .or. iresetmoments == il ) THEN
@@ -8306,16 +8839,30 @@ SUBROUTINE NUCOND    &
 !
 !  for qis
 !
-      IF ( lis > 1 ) THEN
+      IF ( lis > 1 ) THEN ! {
       IF ( an(ix,jy,kz,lis) .le. frac*qxmin(lis) .or. zerocx(lis)   & ! .or.  an(ix,jy,kz,lni) .lt. 0.1
-     &    ) THEN
+     &    ) THEN ! { {
       an(ix,jy,kz,lv) = an(ix,jy,kz,lv) + an(ix,jy,kz,lis)
       an(ix,jy,kz,lis)= 0.0
        IF ( ipconc .ge. 1 ) THEN
          an(ix,jy,kz,lnis) = 0.0
        ENDIF
-      ENDIF
-      ENDIF
+      
+      ELSEIF ( icespheres >= 2 ) THEN ! } {
+       km1 = Max(1, kz-1)
+       IF ( 0.5*( w(ix,jy,kz) + w(ix,jy,kz+1)) < -1.0 .or.    &
+     &      (icespheres == 3 .and. ( t0(ix,jy,kz) < 232.15 .or. an(ix,jy,kz,lc) < qxmin(lc) ) ) .or. &
+     &      (icespheres == 5 .and. ( t0(ix,jy,kz) < 232.15 .or. ( an(ix,jy,kz,lc) < qxmin(lc) .and. an(ix,jy,km1,lc) < qxmin(lc)  )) ) .or. &
+     &      (icespheres == 4 .and. ( t0(ix,jy,kz) < 235.15 )) ) THEN ! transfer to regular ice crystals in downdraft or at low temp
+         an(ix,jy,kz,li) = an(ix,jy,kz,li) + an(ix,jy,kz,lis)
+         an(ix,jy,kz,lni) = an(ix,jy,kz,lni) + an(ix,jy,kz,lnis)
+         an(ix,jy,kz,lis)= 0.0
+         an(ix,jy,kz,lnis)= 0.0
+         
+       ENDIF
+       
+      ENDIF ! } }
+      ENDIF ! }
 
 !
 !  for qcw
@@ -8331,6 +8878,20 @@ SUBROUTINE NUCOND    &
      &       an(ix,jy,kz,lccn) + Max(0.0,an(ix,jy,kz,lnc))
         ENDIF
          an(ix,jy,kz,lnc) = 0.0
+         
+         IF ( lccna > 0  ) THEN ! apply exponential decay to activated CCN to restore to environmental value
+           tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls)  
+           
+           IF ( an(ix,jy,kz,lccna) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccna) = an(ix,jy,kz,lccna)*Exp(-dtp/ccntimeconst)
+
+         ELSEIF ( lccn > 1 .and. restoreccn ) THEN
+           ! in this case, we are treating the ccn field as ccna
+           tmp = an(ix,jy,kz,li) + an(ix,jy,kz,ls)  
+           
+           IF ( an(ix,jy,kz,lccn) > 1. .and. tmp < qxmin(li) ) an(ix,jy,kz,lccn) =  &
+                    dn(ix,jy,kz)*qccn - Max(0.0 , dn(ix,jy,kz)*qccn - an(ix,jy,kz,lccn))*Exp(-dtp/ccntimeconst)
+         
+         ENDIF
 
        ENDIF
 
@@ -8355,46 +8916,7 @@ END SUBROUTINE NUCOND
 ! #####################################################################
 
 
-!
-! Things to do:
-!
-!  Test using exponential formulation for rain fall speed.  If there is little change
-!  from the quadratic, it would be less complicated to use.
-!
-!  Contact nucleation needs to be fixed up to be similar to Cotton et al. 1986 and Meyers et al 1992.
-!
-! The following are done?
-!
-!  Fix Rain evaporation for gamma function (ipconc >= 3)
-!
-!  convert cloud ice to snow as in Ferrier 1994 (change only mass in cloud ice),
-!    then can try turning off direct conversion from cloud ice to graupel and rimed ice
-!
-!  look at an iterative check on overdepletion;  need to be careful with two-moment
-!
-!  check ice supersaturation in two-moment.  Getting enough deposition, or need 
-!      to do sat adj. when cloud droplets are all gone?
-!
-!  
-!
-! new comment
-!
-! Fix use of gt for SWM IN FALLOUT ROUTINES
-!
-!  How to remove hl for ipconc=5?  Need to preprocess?
-!
-!   When the charging rates are moved to a subroutine, need to move the
-!   call to be after the wet growth calculations -- or at least the 
-!   splashing stuff.  Think about this....
-!
-!  Think about what to do with cracif
-!
-!    Replace qv0 with qx(mgs,lv)? No. qv0 is base val
-!
-! Need to look at limiting supersaturation to 1 or so by nucleation/condensation
-!
-!  put in temperature-dependent function for homogeneous freezing
-!
+
 !c--------------------------------------------------------------------------
 !
 !
@@ -8707,7 +9229,7 @@ subroutine nssl_2mom_gs   &
       real ac1,bc, taus, c1,d1,e1,f1,p380,tmp,tmp1,tmp2,tmp3,tmp4,tmp5 ! , sstdy, super
       real ratio, delx, dely
       real dbigg,volt
-      real chgtmp,fac
+      real chgtmp,fac,mixedphasefac
       real x,y,y2,del,r,rtmp,alpr
       double precision :: vent1,vent2
       real g1palp,g4palp
@@ -8771,7 +9293,7 @@ subroutine nssl_2mom_gs   &
 !
 !  misc
 !
-      real ni,nr,d0
+      real ni,nis,nr,d0
       real dqvcnd(ngs),dqwv(ngs),dqcw(ngs),dqci(ngs)
       real tempc(ngs)
       real temg(ngs),temcg(ngs),theta(ngs),qvap(ngs) 
@@ -8786,10 +9308,10 @@ subroutine nssl_2mom_gs   &
       real cimasn,cimasx,ccimx
       real pid4
       real cs,ds,gf7,gf6,gf5,gf4,gf3,gf2,gf1
+      real gcnup1,gcnup2
       real gf73rds, gf83rds
       real gamice73fac, gamsnow73fac
       real gf43rds, gf53rds
-      real gamma
       real aradcw,bradcw,cradcw,dradcw,cwrad,rwrad,rwradmn
       parameter ( rwradmn = 50.e-6 )
       real dh0
@@ -8865,13 +9387,15 @@ subroutine nssl_2mom_gs   &
       real massfacshr, massfacmlr
       
       real :: qhgt8mm ! ice mass greater than 8mm
+      real :: qhwgt8mm ! ice + max water mass greater than 8mm
       real :: qhgt10mm ! mass greater than 10mm
       real :: qhgt20mm ! mass greater than 20mm
-      real :: fwmhtmp 
-      real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.)
-      real, parameter :: srasheym = 0.1389
+      real :: fwmhtmp
+      real, parameter :: fwmhtmptem = -15. ! temperature at which fwmhtmp fully switches to liquid water only being on large particles
+      real, parameter :: d1t = (6.0 * 0.268e-3/(917.* pi))**(1./3.) ! d1t is the diameter of the ice sphere with the mass of an 8mm spherical drop
+      real, parameter :: srasheym = 0.1389 ! slope fraction from Rasmussen and Heymsfield 
 !
-      real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs)
+      real swvent(ngs),hwvent(ngs),rwvent(ngs),hlvent(ngs),hwventy(ngs),hlventy(ngs),rwventz(ngs)
       integer, parameter :: ndiam = 10
       integer :: numdiam
       real hwvent0(ndiam+3),hlvent0 ! 0 to d1
@@ -9010,22 +9534,33 @@ subroutine nssl_2mom_gs   &
 !  ice - ice interactions
 !
       real qsaci(ngs)
+      real qsacis(ngs)
       real qhaci(ngs)
       real qhacs(ngs)
 
+      real :: qhacis(ngs) = 0.0
+      real :: chacis(ngs) = 0.0
+      real :: chacis0(ngs) = 0.0
+
       real :: csaci0(ngs) ! collision rate only
       real :: chaci0(ngs) ! collision rate only
       real :: chacs0(ngs) ! collision rate only
       real :: chlaci0(ngs) ! = 0.0
+      real :: chlacis(ngs) = 0.0
+      real :: chlacis0(ngs) = 0.0
       real :: chlacs0(ngs) ! = 0.0
 
       real :: qsaci0(ngs) ! collision rate only
+      real :: qsacis0(ngs) ! collision rate only
       real :: qhaci0(ngs) ! collision rate only
+      real :: qhacis0(ngs) ! collision rate only
       real :: qhacs0(ngs) ! collision rate only
       real :: qhlaci0(ngs) ! = 0.0
+      real :: qhlacis0(ngs) ! = 0.0
       real :: qhlacs0(ngs) ! = 0.0
 
       real :: qhlaci(ngs) ! = 0.0
+      real :: qhlacis(ngs) ! = 0.0
       real :: qhlacs(ngs) ! = 0.0
 !
 !  conversions
@@ -9150,13 +9685,13 @@ subroutine nssl_2mom_gs   &
       real err(ngs),esr(ngs),eglr(ngs),eghr(ngs),efr(ngs)
       real ehxr(ngs),ehlr(ngs),egmr(ngs) 
       real eri(ngs),esi(ngs),egli(ngs),eghi(ngs),efi(ngs)
-      real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs) 
+      real ehxi(ngs),ehli(ngs),egmi(ngs),ehi(ngs),ehis(ngs),ehlis(ngs)
       real ers(ngs),ess(ngs),egls(ngs),eghs(ngs),efs(ngs),ehs(ngs)
       real ehscnv(ngs)
       real ehxs(ngs),ehls(ngs),egms(ngs),egmip(ngs) 
 
-      real ehsclsn(ngs),ehiclsn(ngs)
-      real ehlsclsn(ngs),ehliclsn(ngs)
+      real ehsclsn(ngs),ehiclsn(ngs),ehisclsn(ngs)
+      real ehlsclsn(ngs),ehliclsn(ngs),ehlisclsn(ngs)
       real esiclsn(ngs)
 
       real :: ehs_collsn = 0.5, ehi_collsn = 1.0
@@ -9319,6 +9854,7 @@ subroutine nssl_2mom_gs   &
       real qeps
       real dyi2,dzi2,cp608,bta1,cnit,dragh,dnz00,pii
       real qccrit,gf4br,gf4ds,gf4p5, gf3ds, gf1ds,gr
+      real gf1palp(ngs) ! for storing Gamma[1.0 + alphar]
 
       
       real xdn0(lc:lhab)
@@ -9513,8 +10049,11 @@ subroutine nssl_2mom_gs   &
       gf73rds = 1.190639349 ! gamma(7./3.)
       gf83rds = 1.504575488 ! gamma(8./3.)
       
-      gamice73fac =  (gamma(7./3. + cinu))**3/ (gamma(1. + cinu)**3 * (1. + cinu)**4)
-      gamsnow73fac =  (gamma(7./3. + snu))**3/ (gamma(1. + snu)**3 * (1. + snu)**4)
+      gamice73fac =  (Gamma_sp(7./3. + cinu))**3/ (Gamma_sp(1. + cinu)**3 * (1. + cinu)**4)
+      gamsnow73fac =  (Gamma_sp(7./3. + snu))**3/ (Gamma_sp(1. + snu)**3 * (1. + snu)**4)
+      
+      gcnup1 = Gamma_sp(cnu + 1.)
+      gcnup2 = Gamma_sp(cnu + 2.)
 !
 !  constants
 !
@@ -9582,6 +10121,9 @@ subroutine nssl_2mom_gs   &
       mltdiam(ndiam+2) = mltdiam2 ! 19.0e-3
       mltdiam(ndiam+3) = mltdiam3 !100.0e-3
 
+      kzb = 1
+      kze = ktile
+!      if (kzend .eq. nzend) kze = kzend-kzbeg+1-kstag
 
 !
 !  cw constants in mks units
@@ -9638,7 +10180,7 @@ subroutine nssl_2mom_gs   &
 !      t8(:,:,:) = 0
       
       IF ( ipconc < 2 ) THEN ! Make a copy of cloud droplet mixing ratio to use for homogeneous freezing
-        DO kz = 1,nz
+        DO kz = 1,kze
          DO ix = 1,itile
            t9(ix,jy,kz) = an(ix,jy,kz,lc)
          ENDDO
@@ -9661,7 +10203,7 @@ subroutine nssl_2mom_gs   &
       do 1000 inumgs = 1,numgs
       ngscnt = 0
       
-      do kz = nzmpb,nz
+      do kz = nzmpb,kze
       do ix = nxmpb,itile
 
       pqs(1) = t00(ix,jy,kz)
@@ -9864,6 +10406,7 @@ subroutine nssl_2mom_gs   &
       
       ventrx(:) = ventr
       ventrxn(:) = ventrn
+      gf1palp(:) = gamma_sp(1.0 + alphar)
 
 !
 !  set concentrations
@@ -10153,6 +10696,11 @@ subroutine nssl_2mom_gs   &
            ENDIF
            xdn(mgs,lh) = Min( dnmx, Max( xdnmn(lh), rho0(mgs)*qx(mgs,lh)/vx(mgs,lh) ) )
            vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh)
+         
+         ELSEIF ( vx(mgs,lh) == 0.0 .and. qx(mgs,lh) .gt. qxmin(lh) ) THEN ! if volume is zero, need to initialize the default value
+
+           vx(mgs,lh) = rho0(mgs)*qx(mgs,lh)/xdn(mgs,lh)
+         
          ENDIF
         ENDIF
 
@@ -10170,6 +10718,11 @@ subroutine nssl_2mom_gs   &
 
              xdn(mgs,lhl) = Min( dnmx, Max( xdnmn(lhl), rho0(mgs)*qx(mgs,lhl)/vx(mgs,lhl) ) )
              vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
+         
+           ELSEIF ( vx(mgs,lhl) == 0.0 .and. qx(mgs,lhl) .gt. qxmin(lhl) ) THEN ! if volume is zero, need to initialize the default value
+
+             vx(mgs,lhl) = rho0(mgs)*qx(mgs,lhl)/xdn(mgs,lhl)
+         
            ENDIF
           ENDIF
 
@@ -10347,10 +10900,13 @@ subroutine nssl_2mom_gs   &
 !
 !
       if( ndebug .ge. 0 ) THEN
-!mpi!        write(iunit,*) 'Set depletion max/min1'
+!mpi!        write(0,*) 'Set depletion max/min1'
       endif
       do mgs = 1,ngscnt
       qvimxd(mgs) = 0.70*(qx(mgs,lv)-qis(mgs))/dtp ! depletion by all vap. dep to ice.
+      
+      IF ( qx(mgs,lc) < qxmin(lc) ) qvimxd(mgs) = 0.99*(qx(mgs,lv)-qis(mgs))/dtp ! this makes virtually no difference whatsoever, but what the heck
+      
       qvimxd(mgs) = max(qvimxd(mgs), 0.0)
 !      qimxd(mgs)  = 0.20*qx(mgs,li)/dtp
 !      qcmxd(mgs)  = 0.20*qx(mgs,lc)/dtp
@@ -10497,7 +11053,9 @@ subroutine nssl_2mom_gs   &
       eri(mgs) = 0.0
       esi(mgs) = 0.0
       ehi(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn
+      ehis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehi*ehiclsn
       ehli(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn
+      ehlis(mgs) = 0.0 ! used as sticking efficiency, so collection efficiency is ehli*ehliclsn
 !      ehxi(mgs) = 0.0
 !
       ers(mgs) = 0.0
@@ -10581,6 +11139,8 @@ subroutine nssl_2mom_gs   &
 !
       eiw(mgs) = 0.0
       if ( qx(mgs,li).gt.qxmin(li) .and. qx(mgs,lc).gt.qxmin(lc) ) then
+      
+      
       if (xdia(mgs,lc,1).gt.15.0e-06 .and. xdia(mgs,li,1).gt.30.0e-06) then
 ! erm 5/10/2007 test following change:
 !      if (xdia(mgs,lc,1).gt.12.0e-06 .and. xdia(mgs,li,1).gt.50.0e-06) then
@@ -10662,14 +11222,14 @@ subroutine nssl_2mom_gs   &
 !     <  (cradcw + cwrad*(dradcw)))), 1.0)
 !         ENDIF
 !       if ( xdia(mgs,li,1) .lt. 10.e-6 ) eri(mgs)=0.0
-       if ( xdia(mgs,li,3) .lt. 40.e-6 ) eri(mgs)=0.0
+       if ( xdia(mgs,li,3) .lt. eri_cimin ) eri(mgs)=0.0
       end if
 !
 !
 !  Snow aggregates: Collection (cxc) efficiencies
 !
 ! Modified by ERM with a linear function for small droplets and large
-! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997, which
+! snow agg. based numerical data from Wang and Ji (1992) in P&K 1997 (Fig. 14-13), which
 ! allows collection of very small droplets, albeit at low efficiency.  But slow
 ! fall speeds of snow make up for the efficiency.
 !
@@ -10701,12 +11261,26 @@ subroutine nssl_2mom_gs   &
         ess(mgs) = 0.0
 !        ess(mgs)=0.1*exp(0.1*min(temcg(mgs),0.0))
 !        ess(mgs)=min(0.1,ess(mgs))
+      
       ELSE
+      
+        fac = Abs(ess0)
+        IF ( .true. .and. ess0 < 0.0 ) THEN
+!         IF ( wvel(mgs) > 2.0 .or. wvel(mgs) < -0.5 .or. ssi(mgs) < 1.0 ) THEN
+         IF ( wvel(mgs) > 2.0 ) THEN
+          ! assume convective cell or downdraft
+           fac = 0.0
+         ELSEIF ( wvel(mgs) > 1.0 ) THEN ! transition to stratiform range of values
+           fac = Max(0.0, 2.0 - wvel(mgs))*fac
+         ENDIF
+        ENDIF
+        
         IF ( temcg(mgs) > esstem1 .and. temcg(mgs) < esstem2 ) THEN  ! only nonzero for T > -25
-        ess(mgs) = ess0*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/5. ! linear ramp up from zero at -25 to value at -20
+          ess(mgs) = fac*Exp(ess1*(esstem2) )*(temcg(mgs) - esstem1)/(esstem2 - esstem1) ! linear ramp up from zero at esstem1 to value at esstem2
         ELSEIF ( temcg(mgs) >= esstem2 ) THEN
-        ess(mgs) = ess0*Exp(ess1*Min( temcg(mgs), 0.0 ) )
+          ess(mgs) = fac*Exp(ess1*Min( temcg(mgs), 0.0 ) )
         ENDIF
+        
       ENDIF
       end if
 !
@@ -10801,7 +11375,8 @@ subroutine nssl_2mom_gs   &
 !     &     .and. temg(mgs) .lt. tfr    &
      &                               ) then
 !      ehr(mgs) = Exp(-(40.e-6)**3/xv(mgs,lr))*Exp(-40.e-6/xdia(mgs,lh,1))
-      ehr(mgs) = 1.0
+!      ehr(mgs) = 1.0
+       ehr(mgs) = Exp(-(40.e-6)/xdia(mgs,lr,3))*Exp(-40.e-6/xdia(mgs,lh,3))
        ehr(mgs) = Min( ehr0, ehr(mgs) )
       end if
 !
@@ -10823,6 +11398,7 @@ subroutine nssl_2mom_gs   &
 !          ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0., xdn(mgs,lh) - xdnmn(lh)*1.2)/xdnmn(lh)  ) ! shut off qhacs as graupel goes to lowest density
           ehs(mgs) = ehscnv(mgs)*Min(1.0, Max(0.0,xdn(mgs,lh) - 300.)/300.  ) ! shut off qhacs as graupel goes to low density
           ehs(mgs) = Min(ehs(mgs),ehsmax)
+          IF ( qx(mgs,lc) < qxmin(lc) ) ehs(mgs) = 0.0
         end if
       ENDIF
 !
@@ -10833,6 +11409,15 @@ subroutine nssl_2mom_gs   &
       if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehi(mgs) = 0.0
       end if
 
+      IF ( lis > 1 ) THEN
+      if ( qx(mgs,lh).gt.qxmin(lh) .and. qx(mgs,lis).gt.qxmin(lis) ) then
+      ehisclsn(mgs) = ehi_collsn
+      ehis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
+      ehis(mgs) = Min( ehimax, Max( ehis(mgs), ehimin ) )
+      if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehis(mgs) = 0.0
+      end if
+      ENDIF
+
 
 !
 !
@@ -10918,6 +11503,15 @@ subroutine nssl_2mom_gs   &
       if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehli(mgs) = 0.0
       end if
 
+      IF ( lis > 1 ) THEN
+      if ( qx(mgs,lhl).gt.qxmin(lhl) .and. qx(mgs,lis).gt.qxmin(lis) ) then
+      ehlisclsn(mgs) = ehli_collsn
+      ehlis(mgs)=eii0*exp(eii1*min(temcg(mgs),0.0))
+      ehlis(mgs) = Min( ehimax, Max( ehlis(mgs), ehimin ) )
+      if ( temg(mgs) .gt. 273.15 .or. ( qx(mgs,lc) < qxmin(lc)) ) ehlis(mgs) = 0.0
+      end if
+      ENDIF
+
 
       ENDIF ! lhl .gt. 1
 
@@ -11353,6 +11947,26 @@ subroutine nssl_2mom_gs   &
        ENDIF
       ENDIF
       end do   
+
+
+      IF ( lis > 1 .and. ipconc >= 5 ) THEN
+      do mgs = 1,ngscnt
+      qhacis(mgs) = 0.0
+      qhacis0(mgs) = 0.0
+      IF ( ehis(mgs) .gt. 0.0 ) THEN
+
+       vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 +    &
+     &            0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) )
+
+          qhacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*qx(mgs,lis)*vt*   &
+     &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
+     &            dab1lh(mgs,lis,lh)*xdia(mgs,lh,3)*xdia(mgs,lis,3) +    &
+     &            da1(li)*xdia(mgs,lis,3)**2 ) 
+          qhacis(mgs) = Min( ehis(mgs)*qhacis0(mgs), qxmxd(mgs,lis) )
+      ENDIF
+      end do
+      ENDIF
+
 !
 !
       do mgs = 1,ngscnt
@@ -11802,7 +12416,14 @@ subroutine nssl_2mom_gs   &
 !      end if
 
       IF ( ipconc .ge. 1 ) THEN
-        IF ( nsplinter .ge. 0 ) THEN
+        IF ( nsplinter .ge. 1000 ) THEN
+        ! Lawson et al. 2015 JAS
+         ! ave. diam of freezing drops in microns
+           IF ( qiacr(mgs)*dtp > qxmin(lh) .and. ciacr(mgs) > 1.e-3 ) THEN
+             tmpdiam = 1.e6*( 6.*qiacr(mgs)/(1000.*pi*ciacr(mgs) ) )**(1./3.) ! avg. diameter of newly frozen drops in microns
+             csplinter(mgs) = lawson_splinter_fac*tmpdiam**4*ciacr(mgs)
+           ENDIF
+        ELSEIF ( nsplinter .ge. 0 ) THEN
           csplinter(mgs) = nsplinter*ciacr(mgs)
         ELSE
           csplinter(mgs) = -nsplinter*ciacrf(mgs)
@@ -11852,9 +12473,8 @@ subroutine nssl_2mom_gs   &
       do mgs = 1,ngscnt
       ciacw(mgs) = 0.0
       IF ( eiw(mgs) .gt. 0.0 ) THEN
-
         ciacw(mgs) = qiacw(mgs)*rho0(mgs)/xmas(mgs,lc)
-      ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs))
+        ciacw(mgs) = min(ciacw(mgs),ccmxd(mgs))
       ENDIF
       end do
 
@@ -11940,7 +12560,7 @@ subroutine nssl_2mom_gs   &
         ENDIF
         ENDIF
 
-!      cracw(mgs) = min(cracw(mgs),ccmxd(mgs))
+!      cracw(mgs) = min(cracw(mgs),cxmxd(mgs,lc)) 
       end do
       end if
 !
@@ -12016,6 +12636,26 @@ subroutine nssl_2mom_gs   &
        ENDIF
       end do
       end if
+
+
+      chacis(:) = 0.0
+      if ( lis > 1 .and. ipconc .ge. 5 .or. ipelec .ge. 1 ) then
+      do mgs = 1,ngscnt
+      IF ( ehis(mgs) .gt. 0.0 .or. ( ehisclsn(mgs) > 0.0 .and. ipelec > 0 )) THEN
+
+       vt = Sqrt((vtxbar(mgs,lh,1)-vtxbar(mgs,lis,1))**2 +    &
+     &            0.04*vtxbar(mgs,lh,1)*vtxbar(mgs,lis,1) )
+
+          chacis0(mgs) = 0.25*pi*ehisclsn(mgs)*cx(mgs,lh)*cx(mgs,lis)*vt*   &
+     &         (  da0lh(mgs)*xdia(mgs,lh,3)**2 +     &
+     &            dab0lh(mgs,lis,lh)*xdia(mgs,lh,3)*xdia(mgs,lis,3) +    &
+     &            da0(lis)*xdia(mgs,lis,3)**2 )
+
+
+        chacis(mgs) = min(ehis(mgs)*chacis0(mgs),cxmxd(mgs,lis))
+       ENDIF
+      end do
+      end if
 !
 !
       if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22nn'
@@ -12120,6 +12760,30 @@ subroutine nssl_2mom_gs   &
        ENDIF
       end do
       end if
+
+
+      IF ( lis > 1 .and. ipconc .ge. 5) THEN
+      
+      if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22kk'
+      chlacis(:) = 0.0
+      chlacis0(:) = 0.0
+       do mgs = 1,ngscnt
+      IF ( lhl .gt. 1 .and. ( ehlis(mgs) .gt. 0.0 .or. (ipelec > 0 .and. ehlisclsn(mgs) > 0.0) )  ) THEN
+
+       vt = Sqrt((vtxbar(mgs,lhl,1)-vtxbar(mgs,lis,1))**2 +    &
+     &            0.04*vtxbar(mgs,lhl,1)*vtxbar(mgs,lis,1) )
+
+          chlacis0(mgs) = 0.25*pi*ehlisclsn(mgs)*cx(mgs,lhl)*cx(mgs,lis)*vt*   &
+     &         (  da0lhl(mgs)*xdia(mgs,lhl,3)**2 +     &
+     &            dab0(lhl,lis)*xdia(mgs,lhl,3)*xdia(mgs,lis,3) +    &
+     &            da0(lis)*xdia(mgs,lis,3)**2 )
+
+
+        chlacis(mgs) = min(ehlis(mgs)*chlacis0(mgs),cxmxd(mgs,lis))
+       ENDIF
+      end do
+      ENDIF
+
 !
 !
       if (ndebug .gt. 0 ) write(0,*) 'ICEZVD_GS: conc 22jj'
@@ -12371,7 +13035,7 @@ subroutine nssl_2mom_gs   &
          ! integrate from Bigg diameter (for given supercooling Ts) to infinity
            
            volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 !  Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 
-                                               ! for mean temperature for freezing: -ln (V) = a*Ts - b
+                                               ! for mean temperature for freezing: -ln (V) = a*Ts - b, where a = 6.9/6.8, or approx a = 1.0, and b = 16.2
                                                ! volt is given in cm**3, so convert to m**3
            dbigg = (6./pi* volt )**(1./3.) 
            
@@ -12405,11 +13069,31 @@ subroutine nssl_2mom_gs   &
            qrfrzf(mgs) = qrfrz(mgs)
            
            
-           IF ( dbigg < Max(dfrz,dhmn) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals
+            IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 2.*xvmn(lr) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN
+             ! rain drops are so small that they can't be pushed smaller, so put into snow (or cloud ice, depending on ifrzs)
+              crfrzf(mgs) = 0.0
+              qrfrzf(mgs) = 0.0
+              crfrzs(mgs) = crfrz(mgs)
+              qrfrzs(mgs) = qrfrz(mgs)
+
+              IF ( lzr > 1 ) THEN
+                zrfrzs(mgs) = zrfrz(mgs)
+                zrfrzf(mgs) = 0.
+              ENDIF
+           ELSEIF ( dbigg < Max(dfrz,dhmn) .and. ( ibiggsnow == 1 .or. ibiggsnow == 3 ) ) THEN ! { convert some to snow or ice crystals
             ! temporarily store qrfrz and crfrz in snow terms and caclulate new crfrzf, qrfrzf, and zrfrzf. Leave crfrz etc. alone!
+            
             crfrzs(mgs) = crfrz(mgs)
             qrfrzs(mgs) = qrfrz(mgs)
             
+            IF ( ibiggsmallrain > 0 .and. xv(mgs,lr) < 1.2*xvmn(lr) ) THEN
+             ! rain drops are so small that they can't be pushed smaller, so put into snow (or cloud ice, depending on ifrzs)
+            crfrzf(mgs) = 0.0
+            qrfrzf(mgs) = 0.0
+
+             
+            ELSE !{
+            
            ! recalculate using dhmn for ratio
            ratio = Min( maxratiolu, Max(dfrz,dhmn)/xdia(mgs,lr,1) )
            
@@ -12442,11 +13126,10 @@ subroutine nssl_2mom_gs   &
             crfrzs(mgs) = crfrzs(mgs) - crfrzf(mgs)
             qrfrzs(mgs) = qrfrzs(mgs) - qrfrzf(mgs)
 
-           
+            ENDIF ! }
            ELSE
             crfrzs(mgs) = 0.0
             qrfrzs(mgs) = 0.0
-            zrfrzs(mgs) = 0.0
            ENDIF ! }
            
            IF ( (qrfrz(mgs))*dtp > qx(mgs,lr) ) THEN
@@ -12457,10 +13140,6 @@ subroutine nssl_2mom_gs   &
              crfrz(mgs) = fac*crfrz(mgs)
              crfrzs(mgs) = fac*crfrzs(mgs)
              crfrzf(mgs) = fac*crfrzf(mgs)
-             IF ( lzr > 1 ) THEN
-               zrfrz(mgs) = fac*zrfrz(mgs)
-               zrfrzf(mgs) = fac*zrfrzf(mgs)
-             ENDIF
            ENDIF
 !           IF ( (crfrzs(mgs) + crfrz(mgs))*dtp > cx(mgs,lr) ) THEN
 !             fac = ( crfrzs(mgs) + crfrz(mgs) )*dtp/cx(mgs,lr)
@@ -12574,7 +13253,15 @@ subroutine nssl_2mom_gs   &
 
         
         IF ( nsplinter .ne. 0 ) THEN
-          IF ( nsplinter .gt. 0 ) THEN
+          IF ( nsplinter .ge. 1000 ) THEN
+           ! Lawson et al. 2015 JAS
+           ! ave. diam of freezing drops in microns
+            tmp = 0
+            IF ( qrfrz(mgs)*dtp > qxmin(lh) .and. crfrz(mgs) > 1.e-3 ) THEN
+              tmpdiam = 1.e6*( 6.*qrfrz(mgs)/(1000.*pi*crfrz(mgs) ))**(1./3.)  ! avg. diameter of newly frozen drops in microns
+              tmp = lawson_splinter_fac*tmpdiam**4*crfrz(mgs)
+            ENDIF
+          ELSEIF ( nsplinter .gt. 0 ) THEN
             tmp = nsplinter*crfrz(mgs)
           ELSE
             tmp = -nsplinter*crfrzf(mgs)
@@ -12615,7 +13302,7 @@ subroutine nssl_2mom_gs   &
       cwfrzc(mgs) = 0.0
       qwfrzp(mgs) = 0.0
       cwfrzp(mgs) = 0.0
-      IF ( ibfc .ge. 1 .and. temg(mgs) < 268.15 ) THEN
+      IF ( ibfc .ge. 1 .and. ibfc /= 3 .and. temg(mgs) < 268.15 ) THEN
 !      if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. 1.  .and.   &
 !     &     .not. (ipconc .ge. 2 .and. xdia(mgs,lc,1) .lt. 10.e-6) ) then
       if ( qx(mgs,lc) .gt. qxmin(lc) .and. cx(mgs,lc) .gt. cxmin ) THEN
@@ -12633,6 +13320,7 @@ subroutine nssl_2mom_gs   &
                                                ! volt is given in cm**3, so factor of 1.e-6 to convert to m**3
 !           dbigg = (6./pi* volt )**(1./3.) 
 
+         IF ( .true. .and. cnu == 0.0 ) THEN
          cwfrz(mgs) = cx(mgs,lc)*Exp(-volt/xv(mgs,lc))/dtp ! number of droplets with volume greater than volt
 !turn off limit so that all can freeze at low temp
 !!!       cwfrz(mgs) = Min(cwfrz(mgs),ccmxd(mgs))
@@ -12641,6 +13329,14 @@ subroutine nssl_2mom_gs   &
 !         cwfrz(mgs) = cx(mgs,lc)*qwfrz(mgs)/qx(mgs,lc) ! reset number frozen to same fraction as mass. This makes 
                                                        ! sure that cwfrz and qwfrz are consistent and prevents 
                                                        ! spurious creation of ice crystals.
+          ELSE
+            ratio = (1. + cnu)*volt/xv(mgs,lc)
+            cwfrz(mgs) = cx(mgs,lc)*Gamxinf(1.+cnu, ratio)/(dtp*gcnup1)
+          
+            qwfrz(mgs) = cx(mgs,lc)*xdn0(lc)*rhoinv(mgs)*Gamxinf(2.+cnu, ratio)/(dtp*gcnup2)
+          
+          ENDIF
+
 !         IF ( temg(mgs) < tfrh - 3 ) THEN
 !          cwfrz(mgs) = cx(mgs,lc)
 !          qwfrz(mgs) = qx(mgs,lc)
@@ -12962,6 +13658,8 @@ subroutine nssl_2mom_gs   &
 
         IF ( iferwisventr == 1 ) THEN
 
+  ! Ferrier fall speed in the ventillation term [uses fx(lr) ]
+  
         alpr = Min(alpharmax,alpha(mgs,lr) )
 
         x =  1. + alpha(mgs,lr)
@@ -12971,8 +13669,10 @@ subroutine nssl_2mom_gs   &
          y = ventrxn(mgs)
         ENDIF
 
-         vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr)
-         vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr))
+!         vent1 = dble(xdia(mgs,lr,1))**(-2. - alpr) ! Actually OK
+!         vent2 = dble(1./xdia(mgs,lr,1) + 0.5*fx(lr))**dble(2.5+alpr+0.5*bx(lr))  ! Actually OK
+         vent1 = dble(xdia(mgs,lr,1))**(0.5 + 0.5*bx(lr)) ! 2016.2.26 Changed for consistency with derivation (recast formula -- should be equivalent)
+         vent2 = dble(1. + 0.5*fx(lr)*xdia(mgs,lr,1))**dble(2.5+alpr+0.5*bx(lr))
         
         
         rwvent(mgs) =    &
@@ -12980,6 +13680,7 @@ subroutine nssl_2mom_gs   &
      &    0.308*fvent(mgs)*y*   &
      &            Sqrt(ax(lr)*rhovt(mgs))*(vent1/vent2)
        
+
         ELSEIF ( iferwisventr == 2 ) THEN
           
 !  Following Wisner et al. (1972) but using gamma of volume. Note that Ferrier's rain fall speed does not integrate with gamma of volume, so using Vr = ar*d^br
@@ -12990,6 +13691,7 @@ subroutine nssl_2mom_gs   &
      &   *Sqrt((ar*rhovt(mgs)))   &
      &    *(xdia(mgs,lr,1)**((1.0+br)/2.0)) )
 
+
           
           ENDIF ! iferwisventr
           
@@ -13311,6 +14013,7 @@ subroutine nssl_2mom_gs   &
          csmlr(mgs)  = (cx(mgs,ls)/(qx(mgs,ls)))*qsmlr(mgs)
         ENDIF
 
+
 !        IF ( xdia(mgs,lh,1) .gt. 1.e-6 .and. Abs(qhmlr(mgs)) .ge. qxmin(lh) ) THEN
 !          chmlr(mgs) = rho0(mgs)*qhmlr(mgs)/(pi*xdn(mgs,lh)*xdia(mgs,lh,1)**3)  ! out of hail
 !          chmlr(mgs) = Max( chmlr(mgs), -chmxd(mgs) )
@@ -13614,7 +14317,8 @@ subroutine nssl_2mom_gs   &
 !            ELSE
 !              qscni(mgs) = 0.1*qidpv(mgs)
 !            ENDIF
-            cscni(mgs) = 0.5*Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvsmn,xmas(mgs,li)))
+            cscni(mgs) = fscni*qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvmn(ls),xmas(mgs,li))
+!            cscni(mgs) = fscni*Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/Max(xdn(mgs,ls)*xvmn(ls),xmas(mgs,li)))
 !            cscni(mgs) = Min(cimxd(mgs),qscni(mgs)*rho0(mgs)/xmas(mgs,li) )
 !            IF ( xdia(mgs,ls,3) .le. 200.e-6 ) THEN
               cscnis(mgs) = cscni(mgs)
@@ -13646,7 +14350,7 @@ subroutine nssl_2mom_gs   &
       ELSEIF ( ipconc < 4 ) THEN ! LFO
            IF ( lwsm6 ) THEN
              qimax = rhoinv(mgs)*roqimax
-             qscni(mgs) = Min(0.9*qx(mgs,li), Max( 0., (qx(mgs,li) - qimax)*dtpinv ) )
+             qscni(mgs) = Min(0.90*qx(mgs,li), Max( 0.0, (qx(mgs,li) - qimax)*dtpinv ) )
            ELSE
              qscni(mgs) = 0.001*eii(mgs)*max((qx(mgs,li)-1.e-3),0.0)
              qscni(mgs) = min(qscni(mgs),qxmxd(mgs,li))
@@ -13976,7 +14680,7 @@ subroutine nssl_2mom_gs   &
 !  hail
 !
 !      if ( lhl .gt. 1 .and. qhlshr(mgs) .lt. 0.0 ) then
-      if ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) then
+      if ( lhl > 1 .and. ( wetgrowthhl(mgs) .or. (mixedphase .and. fhlw(mgs) .gt. 0.05 .and. temg(mgs) .gt. 243.15) ) ) then
 !      if ( wetgrowthhl(mgs) ) then
        
 
@@ -14334,13 +15038,14 @@ subroutine nssl_2mom_gs   &
         ELSEIF ( iglcnvs .ge. 2  ) THEN  ! treat like ice crystals, i.e., check for rime density (ERM)
 
           IF ( temg(mgs) .lt. 273.0 .and. ( qsacw(mgs) - qsdpv(mgs) .gt. 0.0 .or. &
-              ( iglcnvs >= 3 .and. qsacw(mgs) > 2.*qxmin(lh) .and. gamsnow73fac*xmas(mgs,ls) > xdnmn(lh)*xvmn(lh)  ) ) ) THEN
+              ( iglcnvs >= 3 .and. qsacw(mgs) > 2.*qxmin(lh) .and. gamsnow73fac*xmas(mgs,ls) > xdnmn(lh)*xvmn(lh)  ) ) ) THEN !{
 
 
         tmp = rimc1*(-((0.5)*(1.e+06)*xdia(mgs,lc,1))   &
      &                *((0.60)*vtxbar(mgs,ls,1))   &
      &                /(temg(mgs)-273.15))**(rimc2)
-        tmp = Min( Max( rimc3, tmp ), 900.0 )
+!        tmp = Min( Max( rimc3, tmp ), 900.0 )
+        tmp = Min( tmp , 900.0 )
 
         !  Assume that half the volume of the embryo is rime with density 'tmp'
         !  m = rhoi*(V/2) + rhorime*(V/2) = (rhoi + rhorime)*V/2
@@ -14348,7 +15053,7 @@ subroutine nssl_2mom_gs   &
 
 !        write(0,*)  'rime dens = ',tmp
 
-        IF ( iglcnvs == 2 ) THEN
+        IF ( iglcnvs == 2 ) THEN !{
         IF ( tmp .ge. 200.0  ) THEN
           r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) )
 !          r = Max( r, 400. )
@@ -14365,18 +15070,19 @@ subroutine nssl_2mom_gs   &
          ! convert to particles with the mass of the mass-weighted diameter
       !  massofmwr = gamice73fac*xmas(mgs,li)
         
-        IF ( tmp .ge. xdnmn(lh)  ) THEN
+        IF ( tmp > xdnmn(lh) ) THEN
           r = Max( 0.5*(xdn(mgs,ls) + tmp), xdnmn(lh) )
 !          r = Max( r, 400. )
           qhcns(mgs) = 0.5*qsacw(mgs)
           chcns(mgs) = qhcns(mgs)/(gamsnow73fac*xmas(mgs,ls))
+          chcns(mgs) = Min( chcns(mgs), cx(mgs,ls)*qhcns(mgs)/qx(mgs,ls))
           chcnsh(mgs) = Min(chcns(mgs), rho0(mgs)*qhcns(mgs)/(r*xvmn(lh)) )
           vhcns(mgs) = rho0(mgs)*qhcns(mgs)/r
         ENDIF
 
-        ENDIF
+        ENDIF !}
 
-      ENDIF
+      ENDIF !}
 
         ENDIF
 
@@ -14540,7 +15246,12 @@ subroutine nssl_2mom_gs   &
 !
 !  Ziegler et al. 1986 Hallett-Mossop process.  VSTAR = 7.23e-15 (vol of 12micron radius)
 !
-         ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc))
+         IF ( .true. .and. cnu == 0.0 ) THEN
+           ex1 = (1./250.)*Exp(-7.23e-15/xv(mgs,lc))
+         ELSE
+            ratio = (1. + cnu)*(7.23e-15)/xv(mgs,lc)
+            ex1 = (1./250.)*Gamxinf(1.+cnu, ratio)/(gcnup1)
+         ENDIF
        IF ( itype2 .le. 2 ) THEN
          ft = Max(0.0,Min(1.0,-0.11*temcg(mgs)**2 - 1.1*temcg(mgs)-1.7))
        ELSE
@@ -14959,15 +15670,19 @@ subroutine nssl_2mom_gs   &
 !      IF ( ipconc .ge. 1 ) THEN
 
       IF ( warmonly < 0.5 ) THEN
+      IF ( ffrzs < 1.0 ) THEN
       do mgs = 1,ngscnt
       pccii(mgs) =   &
-     &   il5(mgs)*cicint(mgs)*(1. - ffrzs)   &
+     &   il5(mgs)*cicint(mgs)  &
      &  +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs)   &
-     &  +cicichr(mgs))*(1. - ffrzs)   &
+     &  +cicichr(mgs))   &
      &  +chmul1(mgs)   &
      &  +chlmul1(mgs)    &
      &  + csplinter(mgs) + csplinter2(mgs)   &
      &  +csmul(mgs)
+     
+       pccii(mgs) = pccii(mgs)*(1.0 - ffrzs)
+       
 !     >  + nsplinter*(crfrzf(mgs) + crfrz(mgs))
       pccid(mgs) =   &
      &   il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs)   &
@@ -14982,6 +15697,7 @@ subroutine nssl_2mom_gs   &
       
 
       end do
+      ENDIF ! ffrzs
       ELSEIF ( warmonly < 0.8 ) THEN
       do mgs = 1,ngscnt
       
@@ -14990,13 +15706,15 @@ subroutine nssl_2mom_gs   &
 !      qicicnt(mgs) = 0.0
       
       pccii(mgs) =   &
-     &   il5(mgs)*cicint(mgs)*(1. - ffrzs)   &
+     &   il5(mgs)*cicint(mgs)   &
      &  +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs)   &
-     &  +cicichr(mgs))*(1. - ffrzs)   &
+     &  +cicichr(mgs))   &
      &  +chmul1(mgs)   &
      &  +chlmul1(mgs)    &
      &  + csplinter(mgs) + csplinter2(mgs)   &
      &  +csmul(mgs)
+     
+       pccii(mgs) = pccii(mgs)*(1. - ffrzs)
       pccid(mgs) =   &
 !     &   il5(mgs)*(-cscni(mgs) - cscnvi(mgs) & ! - cwaci(mgs)   &
 !     &  -craci(mgs)    &
@@ -15077,7 +15795,7 @@ subroutine nssl_2mom_gs   &
         chacw(mgs)   = frac*chacw(mgs)
         cautn(mgs)   = frac*cautn(mgs)
        
-        pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))
+        pccii(mgs) = pccii(mgs) - (1.-frac)*il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs))*(1. - ffrzs)
         IF ( lhl .gt. 1 ) chlacw(mgs)   = frac*chlacw(mgs)
 
 !       STOP
@@ -15181,12 +15899,24 @@ subroutine nssl_2mom_gs   &
       do mgs = 1,ngscnt
       pcswi(mgs) =   &
      &   il5(mgs)*(cscnis(mgs) + cscnvis(mgs) )    &
-     &  + il5(mgs)*cicint(mgs)*ffrzs                &
-     &  + ifrzs*crfrzs(mgs) &
-     &  + ifrzs*ciacrs(mgs) &
-     &  +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs)   &
-     &  +cicichr(mgs))*ffrzs   &
      &  + cscnh(mgs)
+      
+      IF (  ffrzs > 0.0 ) THEN
+       pcswi(mgs) =  pcswi(mgs) + ffrzs* (  &
+     &   il5(mgs)*cicint(mgs)   &
+     &  +il5(mgs)*(cwfrzc(mgs)+cwctfzc(mgs)   &
+     &  +cicichr(mgs))  &
+     &  +chmul1(mgs)   &
+     &  +chlmul1(mgs)    &
+     &  + csplinter(mgs) + csplinter2(mgs)   &
+     &  +csmul(mgs) )
+      ENDIF
+
+      
+      IF ( ess0 < 0.0 ) THEN
+         csacs(mgs) = Max(0.0, csacs(mgs) - (ifrzs)*(crfrzs(mgs) + ciacrs(mgs)))
+      ENDIF
+      
       pcswd(mgs) = &
 !     :  cracs(mgs)     &
      &  -chacs(mgs) - chlacs(mgs)   &
@@ -15215,10 +15945,15 @@ subroutine nssl_2mom_gs   &
       ENDIF
 
 
+      
       pccii(mgs) =  pccii(mgs) &
      &  + (1. - ifrzs)*crfrzs(mgs) &
      &  + (1. - ifrzs)*ciacrs(mgs)
 
+      pcswi(mgs) =  pcswi(mgs) &
+     &  + (ifrzs)*crfrzs(mgs) &
+     &  + (ifrzs)*ciacrs(mgs)
+
       end do
 
       ENDIF
@@ -15409,13 +16144,13 @@ subroutine nssl_2mom_gs   &
       IF ( warmonly < 0.5 ) THEN
       pqcwd(mgs) =    &
      &  il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs))   &
-     &  -il5(mgs)*(qicichr(mgs))   &
+     &  -il5(mgs)*(qiihr(mgs))   &
      &  -qracw(mgs) -qsacw(mgs) -qrcnw(mgs) -qhacw(mgs) - qhlacw(mgs)  !&
 !     &  -il5(mgs)*(qwfrzp(mgs))
       ELSEIF ( warmonly < 0.8 ) THEN
       pqcwd(mgs) =    &
      &  il5(mgs)*(-qiacw(mgs)-qwfrz(mgs)-qwctfz(mgs))   &
-     &  -il5(mgs)*(qicichr(mgs))   &
+     &  -il5(mgs)*(qiihr(mgs))   &
      &  -qracw(mgs) -qrcnw(mgs) -qhacw(mgs) -qhlacw(mgs)
       ELSE
       pqcwd(mgs) =    &
@@ -15459,17 +16194,21 @@ subroutine nssl_2mom_gs   &
       IF ( warmonly < 0.5 ) THEN
 
       do mgs = 1,ngscnt
+      IF ( ffrzs < 1.0 ) THEN
       pqcii(mgs) =     &
-     &   il5(mgs)*qicicnt(mgs)*(1. - ffrzs)    &
-     &  +il5(mgs)*qidpv(mgs)    &
-     &  +il5(mgs)*qiacw(mgs)   & 
-     &  +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs))*(1. - ffrzs)   &
-     &  +il5(mgs)*(qicichr(mgs))*(1. - ffrzs)   &
+     &   il5(mgs)*qicicnt(mgs)    &
+     &  +il5(mgs)*(qwfrzc(mgs)+qwctfzc(mgs))   &
+     &  +il5(mgs)*(qicichr(mgs))  &
      &  +qsmul(mgs)               &
      &  +qhmul1(mgs) + qhlmul1(mgs)   &
      & + qsplinter(mgs) + qsplinter2(mgs)
 !     > + cimas0*nsplinter*(crfrzf(mgs) + crfrz(mgs))/rho0(mgs)
-
+      ENDIF
+       
+       pqcii(mgs) = pqcii(mgs)*(1.0 - ffrzs) &
+     &  +il5(mgs)*qidpv(mgs)    &
+     &  +il5(mgs)*qiacw(mgs)
+       
       pqcid(mgs) =     &
      &   il5(mgs)*(-qscni(mgs) - qscnvi(mgs)    & ! -qwaci(mgs)    &
      &  -qraci(mgs)    &
@@ -15642,7 +16381,10 @@ subroutine nssl_2mom_gs   &
      &   + il5(mgs)*qicicnt(mgs)*ffrzs        &
      &   + il3(mgs)*(qiacrf(mgs)+qracif(mgs)) &
      &   + Max(0.0, qscev(mgs))   &
-     &   + qsacw(mgs) + qscnh(mgs)
+     &   + qsacw(mgs) + qscnh(mgs) &
+     &  + ffrzs*(qsmul(mgs)               &
+     &  +qhmul1(mgs) + qhlmul1(mgs)   &
+     & + qsplinter(mgs) + qsplinter2(mgs))
       pqswd(mgs) =    &
 !     >  -qfacs(mgs) ! -qwacs(mgs)   &
      &  -qracs(mgs)*(1-il2(mgs)) -qhacs(mgs) - qhlacs(mgs)   &
@@ -15932,7 +16674,8 @@ subroutine nssl_2mom_gs   &
      &  + (  il5(mgs)*qhldpv(mgs)   &
 !     &  +    Max(0.0, qhlcev(mgs))   &
 !     &     + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lhl) )   & ! xdn0(ls) )   &
-     &     + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) )   &  ! yes, this is 'lh' on purpose
+!     &     + qhlacs(mgs) + qhlaci(mgs) )/xdnmn(lh) )   &  ! yes, this is 'lh' on purpose
+     &     + qhlacs(mgs) + qhlaci(mgs) )/500. )   &  ! changed to 500 instead of min graupel density to keep hail density from dropping too much
      &  +   rho0(mgs)*Max(0.0, qhlcev(mgs))/1000.   &
      &  + vhlcnhl(mgs) + (1.0-ifrzg)*(viacrf(mgs) + vrfrzf(mgs))  & 
      &  + vhlacr(mgs) + vhlacw(mgs) + vhlfzhl(mgs) ! qhlacw(mgs)/rimdn(mgs,lhl)
@@ -16174,7 +16917,7 @@ subroutine nssl_2mom_gs   &
       write(iunit,*)       'pqswd = ', pqswd(mgs)
       write(iunit,*)   -qracs(mgs)*(1-il2(mgs)) , qhacs(mgs) , qhlacs(mgs)   
       write(iunit,*)   -qhcns(mgs)   
-      write(iunit,*)   +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs)        !null at this point when wet snow included
+      write(iunit,*)   +(1-il5(mgs))*qsmlr(mgs) , qsshr(mgs)
       write(iunit,*)   (qssbv(mgs))   
       write(iunit,*)   Min(0.0, qscev(mgs))  
       write(iunit,*)   -qsmul(mgs)
@@ -16279,7 +17022,7 @@ subroutine nssl_2mom_gs   &
      &   il5(mgs)*(   &
      &  + qsdpv(mgs) + qhdpv(mgs)   &
      &  + qhldpv(mgs)    &
-     &  + qidpv(mgs)  )   &
+     &  + qidpv(mgs)  )  & 
      &  +il5(mgs)*(qiint(mgs))
       ELSEIF ( warmonly < 0.8 ) THEN
       pfrz(mgs) =    &
@@ -16509,11 +17252,16 @@ subroutine nssl_2mom_gs   &
       
 !      if( ( temg(mgs) .lt. thnuc + 2. .or. (ibfc == 2 .and. temg(mgs) < thnuc + 10. ) ) .and.    &
 !     &  qx(mgs,lc) .gt. qxmin(lc) .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2 )) then
-      if( temg(mgs) .lt. thnuc + 0. .and.    &
-     &  qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then
-
-      IF ( ibfc /= 2 .or. ipconc < 2 ) THEN
-      frac = Max( 0.25, Min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) )
+! commented for test (12/01/2015):
+!      if( temg(mgs) .lt. thnuc + 0. .and.    &
+!     &  qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 )) then
+      if( ( ( temg(mgs) .lt. thnuc + 0.) .or. (temg(mgs) .lt. thnuc + 2. .and. ibfc >= 3) ) .and.    &
+     &  qx(mgs,lc) .gt. 0.0 .and. (ipconc < 2 .or. ibfc == 0 .or. ibfc == 2)) then
+
+      IF ( ibfc >= 3 ) THEN
+        frac = Max( 0.25, Min( 1., ((thnuc + 2.) - temg(mgs) )/4.0 ) )
+      ELSEIF ( ibfc /= 2 .or. ipconc < 2 ) THEN
+        frac = Max( 0.25, Min( 1., ((thnuc + 1.) - temg(mgs) )/4.0 ) )
       ELSE
           volt = exp( 16.2 + 1.0*temcg(mgs) )* 1.0e-6 !  Ts == -temcg ; volt comes from the fit in Fig. 1 in Bigg 1953 
                                                ! for mean temperature for freezing: -ln (V) = a*Ts - b
@@ -16529,7 +17277,11 @@ subroutine nssl_2mom_gs   &
       ENDIF
       qtmp = frac*qx(mgs,lc)
 
-      qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc)
+      IF ( ibfc == 4 .and. lis >= 1 ) THEN
+        qx(mgs,lis) = qx(mgs,lis) + qtmp
+      ELSE
+        qx(mgs,li) = qx(mgs,li) + qtmp ! qx(mgs,lc)
+      ENDIF
       pfrz(mgs) = pfrz(mgs) + qtmp/dtp
       ptem(mgs) =  ptem(mgs) +   &
      &  (1./pi0(mgs))*   &
@@ -16545,7 +17297,11 @@ subroutine nssl_2mom_gs   &
       IF ( ipconc .ge. 2 ) THEN
         ctmp = frac*cx(mgs,lc)
 !        cx(mgs,li) = cx(mgs,li) + cx(mgs,lc)
-        cx(mgs,li) = cx(mgs,li) + ctmp
+        IF ( ibfc == 4 .and. lis >= 1 ) THEN
+          cx(mgs,lis) = cx(mgs,lis) + ctmp
+        ELSE
+          cx(mgs,li) = cx(mgs,li) + ctmp
+        ENDIF
       ELSE ! (ipconc .lt. 2 )
         ctmp = 0.0
         IF ( t9(igs(mgs),jgs,kgs(mgs)-1) .gt. qx(mgs,lc) ) THEN
@@ -16937,7 +17693,7 @@ subroutine nssl_2mom_gs   &
 
 !        write(0,*) 'limiter loop: il,ipc,lz: ',il,ipc(il),lz(il),ipconc
 
-       IF ( ipconc .ge. ipc(il) ) THEN ! {
+       IF ( ipconc .ge. ipc(il) .and. ido(il) > 0 ) THEN ! {
 
          IF (  ipconc .ge. 4 .and. ipc(il) .ge. 1 ) THEN ! {
 
diff --git a/wrfv2_fire/phys/module_mp_p3.F b/wrfv2_fire/phys/module_mp_p3.F
new file mode 100644
index 00000000..f000e65a
--- /dev/null
+++ b/wrfv2_fire/phys/module_mp_p3.F
@@ -0,0 +1,5164 @@
+!__________________________________________________________________________________________
+! This module contains the Predicted Particle Property (P3) bulk microphysics scheme.      !
+!                                                                                          !
+! This code was originally written by H. Morrison,  MMM Division, NCAR (Dec 2012).         !
+! Modification were made by J. Milbrandt, RPN, Environment Canada (July 2014).             !
+!                                                                                          !
+! Two configurations of the P3 scheme are currently available:                             !
+!  1) specified droplet number (i.e. 1-moment cloud water)                                 !
+!  2) predicted droplet number (i.e. 2-moment cloud water).                                !
+!  The  2-moment cloud version is based on a specified aerosol distribution and            !
+!  does not include a subgrid-scale vertical velocity for droplet activation. Hence,       !
+!  this version should only be used for high-resolution simulations that resolve           !
+!  vertical motion driving droplet activation.                                             !
+!                                                                                          !
+! For details see: Morrison and Milbrandt (2015) [J. Atmos. Sci., 72, 287-311]             !
+!                  Milbrandt and Morrison (2016) [J. Atmos. Sci., 73, 975-995]             !
+!                                                                                          !
+! For questions or bug reports, please contact:                                            !
+!    Hugh Morrison   (morrison@ucar.edu), or                                               !
+!    Jason Milbrandt (jason.milbrandt@canada.ca)                                           !
+!__________________________________________________________________________________________!
+!                                                                                          !
+! Version:       2.4.7                                                                     !
+! Last updated:  2017-06-28                                                                !
+!__________________________________________________________________________________________!
+
+ MODULE MODULE_MP_P3   !WRF
+!MODULE MP_P3          !GEM
+
+ implicit none
+
+ public  :: mp_p3_wrapper_wrf,mp_p3_wrapper_gem,p3_main,polysvp1
+
+ private :: gamma,derf,find_lookupTable_indices_1a,find_lookupTable_indices_1b,          &
+            find_lookupTable_indices_2,find_lookupTable_indices_3,get_cloud_dsd,         &
+            get_rain_dsd,calc_bulkRhoRime,impose_max_total_Ni,check_values,qv_sat
+
+! ice microphysics lookup table array dimensions
+ integer, private, parameter :: isize        = 50
+ integer, private, parameter :: iisize       = 25
+ integer, private, parameter :: zsize        = 20  ! size of mom6 array in lookup_table (for future 3-moment)
+ integer, private, parameter :: densize      =  5
+ integer, private, parameter :: rimsize      =  4
+ integer, private, parameter :: rcollsize    = 30
+ integer, private, parameter :: tabsize      = 12  ! number of quantities used from lookup table
+ integer, private, parameter :: colltabsize  =  2  ! number of ice-rain collection  quantities used from lookup table
+ integer, private, parameter :: collitabsize =  2  ! number of ice-ice collection  quantities used from lookup table
+
+ real, private, parameter    :: real_rcollsize = real(rcollsize)
+
+ real, private, dimension(densize,rimsize,isize,tabsize) :: itab   !ice lookup table values
+
+!ice lookup table values for ice-rain collision/collection
+ double precision, private, dimension(densize,rimsize,isize,rcollsize,colltabsize)    :: itabcoll
+! separated into itabcolli1 and itabcolli2, due to max of 7 dimensional arrays on some FORTRAN compilers
+ double precision, private, dimension(iisize,rimsize,densize,iisize,rimsize,densize) :: itabcolli1
+ double precision, private, dimension(iisize,rimsize,densize,iisize,rimsize,densize) :: itabcolli2
+
+! integer switch for warm rain autoconversion/accretion schemes
+ integer, private :: iparam
+
+! droplet spectral shape parameter for mass spectra, used for Seifert and Beheng (2001)
+! warm rain autoconversion/accretion option only (iparam = 1)
+ real, private, dimension(16) :: dnu
+
+! lookup table values for rain shape parameter mu_r
+ real, private, dimension(150) :: mu_r_table
+
+! lookup table values for rain number- and mass-weighted fallspeeds and ventilation parameters
+ real, private, dimension(300,10) :: vn_table,vm_table,revap_table
+
+ ! physical and mathematical constants
+ real, private  :: rhosur,rhosui,ar,br,f1r,f2r,ecr,rhow,kr,kc,bimm,aimm,rin,mi0,nccnst,  &
+                   eci,eri,bcn,cpw,e0,cons1,cons2,cons3,cons4,cons5,cons6,cons7,         &
+                   inv_rhow,qsmall,nsmall,bsmall,zsmall,cp,g,rd,rv,ep_2,inv_cp,mw,osm,   &
+                   vi,epsm,rhoa,map,ma,rr,bact,inv_rm1,inv_rm2,sig1,nanew1,f11,f21,sig2, &
+                   nanew2,f12,f22,pi,thrd,sxth,piov3,piov6,diff_nucthrs,rho_rimeMin,     &
+                   rho_rimeMax,inv_rho_rimeMax,max_total_Ni,dbrk,nmltratio,clbfact_sub,  &
+                   clbfact_dep
+
+ contains
+
+!==================================================================================================!
+
+! The approach to locating the lookupTable files(s) from s/r 'p3_init' is different in WRF and GEM
+! in this version of P3.  Comment/uncomment the following code appropriate depending on the model.
+
+!--- FOR WRF (v3.9/v3.9.1): ---
+
+ SUBROUTINE p3_init(lookup_file_1,lookup_file_2,nCat)
+
+!------------------------------------------------------------------------------------------!
+! This subroutine initializes all physical constants and parameters needed by the P3       !
+! scheme.  The subroutine 'P3_INIT' must be called at the first model time step from there !
+! wrapper subroutine, prior to first call to the main scheme subroutine, 'P3_MAIN'.        !
+!------------------------------------------------------------------------------------------!
+
+ implicit none
+
+! Passed arguments:
+ character*(*), intent(in) :: lookup_file_1    !lookup table for main processes
+ character*(*), intent(in) :: lookup_file_2    !lookup table for ice category interactions
+ integer, intent(in)       :: nCat             !number of free ice categories
+
+! Local variables/parameters:
+ integer :: i,j,k,ii,jj,kk,jjj,jjj2,jjjj,jjjj2
+ real    :: lamr,mu_r,lamold,dum,initlamr
+ real    :: dm,dum1,dum2,dum3,dum4,dum5,dum6
+ real    :: dd,amg,vt,dia,vn,vm
+!
+!--- FOR GEM (RPNPHY_6.0): ---
+! ! !
+! ! !  SUBROUTINE p3_init(lookup_file_dir,nCat)
+! ! !
+! ! ! !------------------------------------------------------------------------------------------!
+! ! ! ! This subroutine initializes all physical constants and parameters needed by the P3       !
+! ! ! ! scheme.  The subroutine 'P3_INIT' must be called at the first model time step from there !
+! ! ! ! wrapper subroutine, prior to first call to the main scheme subroutine, 'P3_MAIN'.        !
+! ! ! !------------------------------------------------------------------------------------------!
+! ! !
+! ! !   implicit none
+! ! !
+! ! ! ! Passed arguments:
+! ! !  character*(*), intent(in) :: lookup_file_dir  ! directory of the lookup tables to be read in
+! ! !  integer,       intent(in) :: nCat             ! number of free ice categories
+! ! !
+! ! !  character(len=16), parameter :: TABLE_VERSION  = '02'
+! ! !  character(len=16), parameter :: TABLE_BASENAME = 'p3_lookup_table'
+! ! !
+! ! ! ! Local variables/parameters:
+! ! !  character(len=1024) :: lookup_file_1    !lookup table for ice category interactions
+! ! !  character(len=1024) :: lookup_file_2    !lookup table for ice category interactions
+! ! !  integer :: i,j,k,ii,jj,kk,jjj,jjj2,jjjj,jjjj2
+! ! !  real    :: lamr,mu_r,lamold,dum,initlamr
+! ! !  real    :: dm,dum1,dum2,dum3,dum4,dum5,dum6
+! ! !  real    :: dd,amg,vt,dia,vn,vm
+! ! !
+! ! !  !------------------------------------------------------------------------------------------!
+! ! !
+! ! ! lookup_file_1 = trim(lookup_file_dir)//'/'//trim(TABLE_BASENAME)//'-1_v'//trim(TABLE_VERSION)//'.dat'
+! ! ! lookup_file_2 = trim(lookup_file_dir)//'/'//trim(TABLE_BASENAME)//'-2_v'//trim(TABLE_VERSION)//'.dat'
+! ! !
+! ! ! !-- override for local path/filenames:
+! ! ! ! lookup_file_1 =  '/data/ords/armn/armngr8/storage_model/p3_lookup_tables/p3_lookup_table_1.dat-v2.3.2'
+! ! ! ! lookup_file_2 =  '/data/ords/armn/armngr8/storage_model/p3_lookup_tables/p3_lookup_table_2.dat-v2.3.2'
+! ! ! !==
+!===
+
+ !------------------------------------------------------------------------------------------!
+
+! mathematical/optimization constants
+ pi    = 3.14159265
+ thrd  = 1./3.
+ sxth  = 1./6.
+ piov3 = pi*thrd
+ piov6 = pi*sxth
+
+! maximum total ice concentration (sum of all categories)
+ max_total_Ni = 500.e+3  !(m)
+
+! switch for warm-rain parameterization
+! = 1 Seifert and Beheng 2001
+! = 2 Beheng 1994
+! = 3 Khairoutdinov and Kogan 2000
+ iparam = 3
+
+! droplet concentration (m-3)
+ nccnst = 400.e+6
+
+! parameters for Seifert and Beheng (2001) autoconversion/accretion
+ kc     = 9.44e+9
+ kr     = 5.78e+3
+
+! physical constants
+ cp     = 1005.
+ inv_cp = 1./cp
+ g      = 9.816
+ rd     = 287.15
+ rv     = 461.51
+ ep_2   = 0.622
+ rhosur = 100000./(rd*273.15)
+ rhosui = 60000./(rd*253.15)
+ ar     = 841.99667
+ br     = 0.8
+ f1r    = 0.78
+ f2r    = 0.32
+ ecr    = 1.
+ rhow   = 997.
+ cpw    = 4218.
+ inv_rhow = 1.e-3  !inverse of (max.) density of liquid water
+
+! limits for rime density [kg m-3]
+ rho_rimeMin     =  50.
+ rho_rimeMax     = 900.
+ inv_rho_rimeMax = 1./rho_rimeMax
+
+! minium allowable prognostic variables
+ qsmall = 1.e-14
+ nsmall = 1.e-16
+ bsmall = qsmall*inv_rho_rimeMax
+!zsmall = 1.e-35
+
+! Bigg (1953)
+!bimm   = 100.
+!aimm   = 0.66
+! Barklie and Gokhale (1959)
+ bimm   = 2.
+ aimm   = 0.65
+ rin    = 0.1e-6
+ mi0    = 4.*piov3*900.*1.e-18
+
+ eci    = 0.5
+ eri    = 1.
+ bcn    = 2.
+
+! mean size for soft lambda_r limiter [microns]
+ dbrk   = 600.e-6
+! ratio of rain number produced to ice number loss from melting
+ nmltratio = 0.2
+
+! saturation pressure at T = 0 C
+ e0    = polysvp1(273.15,0)
+
+ cons1 = piov6*rhow
+ cons2 = 4.*piov3*rhow
+ cons3 = 1./(cons2*(25.e-6)**3)
+ cons4 = 1./(dbrk**3*pi*rhow)
+ cons5 = piov6*bimm
+ cons6 = piov6**2*rhow*bimm
+ cons7 = 4.*piov3*rhow*(1.e-6)**3
+
+! aerosol/droplet activation parameters
+ mw     = 0.018
+ osm    = 1.
+ vi     = 3.
+ epsm   = 0.9
+ rhoa   = 1777.
+ map    = 0.132
+ ma     = 0.0284
+ rr     = 8.3187
+ bact   = vi*osm*epsm*mw*rhoa/(map*rhow)
+! inv_bact = (map*rhow)/(vi*osm*epsm*mw*rhoa)    *** to replace /bact **
+
+! mode 1
+ inv_rm1 = 2.e+7           ! inverse aerosol mean size (m-1)
+ sig1    = 2.0             ! aerosol standard deviation
+ nanew1  = 300.e6          ! aerosol number mixing ratio (kg-1)
+ f11     = 0.5*exp(2.5*(log(sig1))**2)
+ f21     = 1. + 0.25*log(sig1)
+
+! note: currently only set for a single mode, droplet activation code needs to
+!       be modified to include the second mode
+! mode 2
+ inv_rm2 = 7.6923076e+5    ! inverse aerosol mean size (m-1)
+ sig2    = 2.5             ! aerosol standard deviation
+ nanew2  = 0.              ! aerosol number mixing ratio (kg-1)
+ f12     = 0.5*exp(2.5*(log(sig2))**2)
+ f22     = 1. + 0.25*log(sig2)
+
+! parameters for droplet mass spectral shape, used by Seifert and Beheng (2001)
+! warm rain scheme only (iparam = 1)
+ dnu(1)  =  0.
+ dnu(2)  = -0.557
+ dnu(3)  = -0.430
+ dnu(4)  = -0.307
+ dnu(5)  = -0.186
+ dnu(6)  = -0.067
+ dnu(7)  =  0.050
+ dnu(8)  =  0.167
+ dnu(9)  =  0.282
+ dnu(10) =  0.397
+ dnu(11) =  0.512
+ dnu(12) =  0.626
+ dnu(13) =  0.739
+ dnu(14) =  0.853
+ dnu(15) =  0.966
+ dnu(16) =  0.966
+
+! calibration factors for ice deposition and sublimation
+!   These are adjustable ad hoc factors used to increase or decrease deposition and/or
+!   sublimation rates.  The representation of the ice capacitances are highly simplified
+!   and the appropriate values in the diffusional growth equation are uncertain.
+ clbfact_dep = 1.
+ clbfact_sub = 1.
+
+!------------------------------------------------------------------------------------------!
+! read in ice microphysics table
+
+ print*
+ print*, ' P3 microphysics, version: 2.4.7'
+ print*, '   P3_INIT (READING/CREATING LOOK-UP TABLES) ...'
+!print*, '   Reading lookup-table 1 ...'
+
+ open(unit=10,file=lookup_file_1, status='old')
+
+ do jj = 1,densize
+    do ii = 1,rimsize
+       do i = 1,isize
+          read(10,*) dum,dum,dum,dum,itab(jj,ii,i,1),itab(jj,ii,i,2),           &
+               itab(jj,ii,i,3),itab(jj,ii,i,4),itab(jj,ii,i,5),                 &
+               itab(jj,ii,i,6),itab(jj,ii,i,7),itab(jj,ii,i,8),dum,             &
+               itab(jj,ii,i,9),itab(jj,ii,i,10),itab(jj,ii,i,11),               &
+               itab(jj,ii,i,12)
+        enddo
+! read in table for ice-rain collection
+       do i = 1,isize
+          do j = 1,rcollsize
+             read(10,*) dum,dum,dum,dum,dum,itabcoll(jj,ii,i,j,1),              &
+              itabcoll(jj,ii,i,j,2),dum
+              itabcoll(jj,ii,i,j,1) = dlog10(itabcoll(jj,ii,i,j,1))
+              itabcoll(jj,ii,i,j,2) = dlog10(itabcoll(jj,ii,i,j,2))
+          enddo
+       enddo
+    enddo
+ enddo
+
+! hm add fix to prevent end-of-file error in nested runs, 3/28/14
+ close(10)
+
+! read in ice-ice collision lookup table
+
+!------------------------------------------------------------------------------------------!
+
+!                   *** used for multicategory only ***
+
+ if (nCat>1) then
+
+   !print*, '   Reading lookup-table 2 ...'
+
+    open(unit=10,file=lookup_file_2,status='old')
+
+    do i = 1,iisize
+       do jjj = 1,rimsize
+          do jjjj = 1,densize
+             do ii = 1,iisize
+                do jjj2 = 1,rimsize
+                   do jjjj2 = 1,densize
+                      read(10,*) dum,dum,dum,dum,dum,dum,dum,                      &
+                      itabcolli1(i,jjj,jjjj,ii,jjj2,jjjj2),                        &
+                      itabcolli2(i,jjj,jjjj,ii,jjj2,jjjj2)
+                   enddo
+                enddo
+             enddo
+          enddo
+       enddo
+    enddo
+
+    close(unit=10)
+
+ else ! for single cat
+
+    itabcolli1 = 0.
+    itabcolli2 = 0.
+
+ endif
+
+!------------------------------------------------------------------------------------------!
+
+! Generate lookup table for rain shape parameter mu_r
+! this is very fast so it can be generated at the start of each run
+! make a 150x1 1D lookup table, this is done in parameter
+! space of a scaled mean size proportional qr/Nr -- initlamr
+
+!print*, '   Generating rain lookup-table ...'
+
+ do i = 1,150              ! loop over lookup table values
+    initlamr = 1./((real(i)*2.)*1.e-6 + 250.e-6)
+
+! iterate to get mu_r
+! mu_r-lambda relationship is from Cao et al. (2008), eq. (7)
+
+! start with first guess, mu_r = 0
+
+    mu_r = 0.
+
+    do ii=1,50
+       lamr = initlamr*((mu_r+3.)*(mu_r+2.)*(mu_r+1.)/6.)**thrd
+
+! new estimate for mu_r based on lambda
+! set max lambda in formula for mu_r to 20 mm-1, so Cao et al.
+! formula is not extrapolated beyond Cao et al. data range
+       dum  = min(20.,lamr*1.e-3)
+       mu_r = max(0.,-0.0201*dum**2+0.902*dum-1.718)
+
+! if lambda is converged within 0.1%, then exit loop
+       if (ii.ge.2) then
+          if (abs((lamold-lamr)/lamr).lt.0.001) goto 111
+       end if
+
+       lamold = lamr
+
+    enddo
+
+111 continue
+
+! assign lookup table values
+    mu_r_table(i) = mu_r
+
+ enddo
+
+!.......................................................................
+! Generate lookup table for rain fallspeed and ventilation parameters
+! the lookup table is two dimensional as a function of number-weighted mean size
+! proportional to qr/Nr and shape parameter mu_r
+
+ mu_r_loop: do ii = 1,10   !** change 10 to 9, since range of mu_r is 0-8  CONFIRM
+!mu_r_loop: do ii = 1,9   !** change 10 to 9, since range of mu_r is 0-8
+
+    mu_r = real(ii-1)  ! values of mu
+
+! loop over number-weighted mean size
+    meansize_loop: do jj = 1,300
+
+       if (jj.le.20) then
+          dm = (real(jj)*10.-5.)*1.e-6      ! mean size [m]
+       elseif (jj.gt.20) then
+          dm = (real(jj-20)*30.+195.)*1.e-6 ! mean size [m]
+       endif
+
+       lamr = (mu_r+1)/dm
+
+! do numerical integration over PSD
+
+       dum1 = 0. ! numerator,   number-weighted fallspeed
+       dum2 = 0. ! denominator, number-weighted fallspeed
+       dum3 = 0. ! numerator,   mass-weighted fallspeed
+       dum4 = 0. ! denominator, mass-weighted fallspeed
+       dum5 = 0. ! term for ventilation factor in evap
+       dd   = 2.
+
+! loop over PSD to numerically integrate number and mass-weighted mean fallspeeds
+       do kk = 1,10000
+
+          dia = (real(kk)*dd-dd*0.5)*1.e-6  ! size bin [m]
+          amg = piov6*997.*dia**3           ! mass [kg]
+          amg = amg*1000.                   ! convert [kg] to [g]
+
+         !get fallspeed as a function of size [m s-1]
+          if (dia*1.e+6.le.134.43)      then
+            vt = 4.5795e+3*amg**(2.*thrd)
+          elseif (dia*1.e+6.lt.1511.64) then
+            vt = 4.962e+1*amg**thrd
+          elseif (dia*1.e+6.lt.3477.84) then
+            vt = 1.732e+1*amg**sxth
+          else
+            vt = 9.17
+          endif
+
+         !note: factor of 4.*mu_r is non-answer changing and only needed to
+         !      prevent underflow/overflow errors, same with 3.*mu_r for dum5
+          dum1 = dum1 + vt*10.**(mu_r*alog10(dia)+4.*mu_r)*exp(-lamr*dia)*dd*1.e-6
+          dum2 = dum2 + 10.**(mu_r*alog10(dia)+4.*mu_r)*exp(-lamr*dia)*dd*1.e-6
+          dum3 = dum3 + vt*10.**((mu_r+3.)*alog10(dia)+4.*mu_r)*exp(-lamr*dia)*dd*1.e-6
+          dum4 = dum4 + 10.**((mu_r+3.)*alog10(dia)+4.*mu_r)*exp(-lamr*dia)*dd*1.e-6
+          dum5 = dum5 + (vt*dia)**0.5*10.**((mu_r+1.)*alog10(dia)+3.*mu_r)*exp(-lamr*dia)*dd*1.e-6
+
+       enddo ! kk-loop (over PSD)
+
+       dum2 = max(dum2, 1.e-30)  !to prevent divide-by-zero below
+       dum4 = max(dum4, 1.e-30)  !to prevent divide-by-zero below
+       dum5 = max(dum5, 1.e-30)  !to prevent log10-of-zero below
+
+       vn_table(jj,ii)    = dum1/dum2
+       vm_table(jj,ii)    = dum3/dum4
+       revap_table(jj,ii) = 10.**(alog10(dum5)+(mu_r+1.)*alog10(lamr)-(3.*mu_r))
+
+    enddo meansize_loop
+
+ enddo mu_r_loop
+
+!.......................................................................
+
+ print*, '   P3_INIT DONE.'
+ print*
+
+END SUBROUTINE P3_INIT
+
+
+!==================================================================================================!
+
+
+!-- note:  If not running in WRF, one can uncomment the following lines and comment the
+!          code for s/r mp_p3_wrapper_wrf
+!
+! ! ! SUBROUTINE mp_p3_wrapper_wrf
+! ! ! END SUBROUTINE mp_p3_wrapper_wrf
+!==
+
+
+ SUBROUTINE mp_p3_wrapper_wrf(th_3d,qv_3d,qc_3d,qr_3d,qnr_3d,                            &
+                              th_old_3d,qv_old_3d,                                       &
+                              pii,p,dz,w,dt,itimestep,                                   &
+                              rainnc,rainncv,sr,snownc,snowncv,n_iceCat,                 &
+                              ids, ide, jds, jde, kds, kde ,                             &
+                              ims, ime, jms, jme, kms, kme ,                             &
+                              its, ite, jts, jte, kts, kte ,                             &
+                              diag_zdbz_3d,diag_effc_3d,diag_effi_3d,                    &
+                              diag_vmi_3d,diag_di_3d,diag_rhopo_3d,                      &
+                              qi1_3d,qni1_3d,qir1_3d,qib1_3d,                            &
+                              qi2_3d,qni2_3d,qir2_3d,qib2_3d,nc_3d)
+
+  !------------------------------------------------------------------------------------------!
+  ! This subroutine is the main WRF interface with the P3 microphysics scheme.  It takes     !
+  ! 3D variables form the driving model and passes 2D slabs (i,k) to the main microphysics   !
+  ! subroutine ('P3_MAIN') over a j-loop.  For each slab, 'P3_MAIN' updates the prognostic   !
+  ! variables (hydrometeor variables, potential temperature, and water vapor).  The wrapper  !
+  ! also updates the accumulated precipitation arrays and then passes back them, the         !
+  ! updated 3D fields, and some diagnostic fields to the driver model.                       !
+  !                                                                                          !
+  ! This version of the WRF wrapper works with WRFV3.8.                                      !
+  !------------------------------------------------------------------------------------------!
+
+  !--- input:
+
+  ! pii       --> Exner function (nondimensional pressure) (currently not used!)
+  ! p         --> pressure (pa)
+  ! dz        --> height difference across vertical levels (m)
+  ! w         --> vertical air velocity (m/s)
+  ! dt        --> time step (s)
+  ! itimestep --> integer time step counter
+  ! n_iceCat  --> number of ice-phase categories
+
+
+  !--- input/output:
+
+  ! th_3d     --> theta (K)
+  ! qv_3d     --> vapor mass mixing ratio (kg/kg)
+  ! qc_3d     --> cloud water mass mixing ratio (kg/kg)
+  ! qr_3d     --> rain mass mixing ratio (kg/kg)
+  ! qnr_3d    --> rain number mixing ratio (#/kg)
+  ! qi1_3d    --> total ice mixing ratio (kg/kg)
+  ! qni1_3d   --> ice number mixing ratio (#/kg)
+  ! qir1_3d   --> rime ice mass mixing ratio (kg/kg)
+  ! qib1_3d   --> ice rime volume mixing ratio (m^-3 kg^-1)
+
+  !--- output:
+
+  ! rainnc        --> accumulated surface precip (mm)
+  ! rainncv       --> one time step accumulated surface precip (mm)
+  ! sr            --> ice to liquid surface precip ratio
+  ! snownc        --> accumulated surface ice precip (mm)
+  ! snowncv       --> one time step accumulated surface ice precip (mm)
+  ! ids...kte     --> integer domain/tile bounds
+  ! diag_zdbz_3d  --> reflectivity (dBZ)
+  ! diag_effc_3d  --> cloud droplet effective radius (m)
+  ! diag_effi_3d  --> ice effective radius (m)
+  ! diag_vmi_3d   --> mean mass weighted ice fallspeed (m/s)
+  ! diag_di_3d    --> mean mass weighted ice size (m)
+  ! diag_rhopo_3d --> mean mass weighted ice density (kg/m3)
+
+  implicit none
+
+  !--- arguments:
+
+   integer, intent(in)            ::  ids, ide, jds, jde, kds, kde ,                      &
+                                      ims, ime, jms, jme, kms, kme ,                      &
+                                      its, ite, jts, jte, kts, kte
+   real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: th_3d,qv_3d,qc_3d,qr_3d,   &
+                   qnr_3d,diag_zdbz_3d,diag_effc_3d,diag_effi_3d,diag_vmi_3d,diag_di_3d,  &
+                   diag_rhopo_3d,th_old_3d,qv_old_3d
+   real, dimension(ims:ime, kms:kme, jms:jme), intent(inout):: qi1_3d,qni1_3d,qir1_3d,    &
+                                                               qib1_3d
+   real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: qi2_3d,qni2_3d, &
+                                                                          qir2_3d,qib2_3d
+   real, dimension(ims:ime, kms:kme, jms:jme), intent(inout), optional :: nc_3d
+
+   real, dimension(ims:ime, kms:kme, jms:jme), intent(in) :: pii,p,dz,w
+   real, dimension(ims:ime, jms:jme), intent(inout) :: RAINNC,RAINNCV,SR,SNOWNC,SNOWNCV
+   real, intent(in)    :: dt
+   integer, intent(in) :: itimestep
+   integer, intent(in) :: n_iceCat
+   logical :: log_predictNc
+
+   !--- local variables/parameters:
+
+   real, dimension(ims:ime, kms:kme) ::nc,ssat
+
+   ! note: hard-wired for one ice category
+   real, dimension(ims:ime, kms:kme, 1) :: qitot,qirim,nitot,birim,diag_di,diag_vmi,       &
+                                          diag_rhopo,diag_effi
+
+   real, dimension(its:ite) :: pcprt_liq,pcprt_sol
+   real                     :: dum1,dum2
+   integer                  :: i,k,j
+   integer, parameter       :: n_diag_ss = 3        ! number of user-defined diagnostic fields
+   logical, parameter       :: nk_bottom = .false.  !.F. --> nk at model top (as in WRF)
+
+   real, dimension(ims:ime, kms:kme, n_diag_ss) :: diag_ss
+
+!   allocate (qitot(ims:ime, kms:kme,n_iceCat))      ! ice mixing ratio, mass (total)   [kg kg-1]
+!   allocate (qirim(ims:ime, kms:kme,n_iceCat))      ! ice mixing ratio, mass (rime)    [kg kg-1]
+!   allocate (nitot(ims:ime, kms:kme,n_iceCat))      ! ice mixing ratio, number         [# kg-1]
+!   allocate (birim(ims:ime, kms:kme,n_iceCat))      ! ice mixing ratio, volume         [m3 kg-1]
+!   allocate (diag_di(ims:ime, kms:kme,n_iceCat))    ! mean-mass ice diameter           [m]
+!   allocate (diag_vmi(ims:ime, kms:kme,n_iceCat))   ! fall speed (mass-weighted), ice  [m s-1]
+!   allocate (diag_rhopo(ims:ime, kms:kme,n_iceCat)) ! bulk density, ice                [kg m-3]
+!   allocate (diag_effi(ims:ime, kms:kme,n_iceCat))  ! effective radius, ice            [m]
+!   allocate (diag_ss(ims:ime, kms:kme,n_diag_ss))   ! user-defined diagnostic fields
+
+   !------------------------------------------------------------------------------------------!
+
+   log_predictNc=.false.
+   if (present(nc_3d)) log_predictNc = .true.
+
+   do j = jts,jte      ! j loop (north-south)
+
+      if (log_predictNc) then
+         nc(its:ite,kts:kte)=nc_3d(its:ite,kts:kte,j)
+     ! if Nc is specified then set nc array to zero
+      else
+         nc=0.
+      endif
+
+     ! note: code for prediction of ssat not currently avaiable, set 2D array to 0
+      ssat=0.
+
+    !contruct full ice arrays from individual category arrays:
+!      qitot(its:ite,kts:kte,1) = qi1_3d(its:ite,kts:kte,j)
+!      qirim(its:ite,kts:kte,1) = qir1_3d(its:ite,kts:kte,j)
+!      nitot(its:ite,kts:kte,1) = qni1_3d(its:ite,kts:kte,j)
+!      birim(its:ite,kts:kte,1) = qib1_3d(its:ite,kts:kte,j)
+
+  !    if (n_iceCat .ge. 2) then
+  !       qitot(:,:,2) = qi2_3d(:,:,j)
+  !       qirim(:,:,2) = qir2_3d(:,:,j)
+  !       nitot(:,:,2) = qni2_3d(:,:,j)
+  !       birim(:,:,2) = qib2_3d(:,:,j)
+  !      if (n_iceCat .ge. 3) then
+  !         qitot(:,:,3) = qi33d(:,:,j)
+  !         qirim(:,:,3) = qg33d(:,:,j)
+  !         nitot(:,:,3) = qni33d(:,:,j)
+  !         birim(:,:,3) = qvolg33d(:,:,j)
+  !         if (n_iceCat == 4) then
+  !            qitot(:,:,4) = qi43d(:,:,j)
+  !            qirim(:,:,4) = qg43d(:,:,j)
+  !            nitot(:,:,4) = qni43d(:,:,j)
+  !            birim(:,:,4) = qvolg43d(:,:,j)
+  !         endif
+  !      endif
+  !    endif
+
+      call P3_MAIN(qc_3d(its:ite,kts:kte,j),nc(its:ite,kts:kte),                                       &
+              qr_3d(its:ite,kts:kte,j),qnr_3d(its:ite,kts:kte,j),                                      &
+              th_old_3d(its:ite,kts:kte,j),th_3d(its:ite,kts:kte,j),qv_old_3d(its:ite,kts:kte,j),      &
+              qv_3d(its:ite,kts:kte,j),dt,qi1_3d(its:ite,kts:kte,j),                                   &
+              qir1_3d(its:ite,kts:kte,j),qni1_3d(its:ite,kts:kte,j),                                   &
+              qib1_3d(its:ite,kts:kte,j),ssat(its:ite,kts:kte),                                        &
+              W(its:ite,kts:kte,j),P(its:ite,kts:kte,j),                                               &
+              DZ(its:ite,kts:kte,j),itimestep,pcprt_liq,pcprt_sol,its,ite,kts,kte,nk_bottom,n_iceCat,  &
+              diag_zdbz_3d(its:ite,kts:kte,j),diag_effc_3d(its:ite,kts:kte,j),                         &
+              diag_effi_3d(its:ite,kts:kte,j),n_diag_ss,diag_ss(its:ite,kts:kte,1:n_diag_ss),          &
+              log_predictNc)
+
+     !surface precipitation output:
+      dum1 = 1000.*dt
+      RAINNC(its:ite,j)  = RAINNC(its:ite,j) + pcprt_liq(:)*dum1  ! conversion from m/s to mm/time step
+      RAINNCV(its:ite,j) = pcprt_liq(:)*dum1                      ! conversion from m/s to mm/time step
+      SNOWNC(its:ite,j)  = SNOWNC(its:ite,j) + pcprt_sol(:)*dum1  ! conversion from m/s to mm/time step
+      SNOWNCV(its:ite,j) = pcprt_sol(:)*dum1                      ! conversion from m/s to mm/time step
+      SR(its:ite,j)      = pcprt_sol(:)/(pcprt_liq(:)+1.E-12)     ! solid-to-liquid ratio
+
+    !convert nc array from 2D to 3D if Nc is predicted
+      if (log_predictNc) then
+         nc_3d(its:ite,kts:kte,j)=nc(its:ite,kts:kte)
+      endif
+
+    !set background effective radii (i.e. with no explicit condensate) to prescribed values:
+    !  where (qc_3d(:,:,j) < 1.e-14) diag_effc_3d(:,:,j) = 10.e-6
+    !  where (qitot < 1.e-14) diag_effi = 25.e-6
+
+    !decompose full ice arrays into individual category arrays:
+!      qi1_3d(its:ite,kts:kte,j)  = qitot(its:ite,kts:kte,1)
+!      qir1_3d(its:ite,kts:kte,j) = qirim(its:ite,kts:kte,1)
+!      qni1_3d(its:ite,kts:kte,j) = nitot(its:ite,kts:kte,1)
+!      qib1_3d(its:ite,kts:kte,j) = birim(its:ite,kts:kte,1)
+
+    !diagnostic fields for output:
+!      if (n_iceCat .eq. 1) then
+         diag_vmi_3d(its:ite,kts:kte,j)   = diag_ss(its:ite,kts:kte,1)
+         diag_di_3d(its:ite,kts:kte,j)    = diag_ss(its:ite,kts:kte,2)
+         diag_rhopo_3d(its:ite,kts:kte,j) = diag_ss(its:ite,kts:kte,3)
+!      endif
+
+    !decompose full ice arrays into individual category arrays:
+!      qi1_3d(:,:,j)  = qitot(:,:,1)
+!      qir1_3d(:,:,j) = qirim(:,:,1)
+!      qni1_3d(:,:,j) = nitot(:,:,1)
+!      qib1_3d(:,:,j) = birim(:,:,1)
+
+!      if (n_iceCat .eq. 1) then
+!         diag_vmi_3d(:,:,j)   = diag_vmi(:,:,1)
+!         diag_di_3d(:,:,j)    = diag_di(:,:,1)
+!         diag_rhopo_3d(:,:,j) = diag_rhopo(:,:,1)
+!         diag_effi_3d(:,:,j)  = diag_effi(:,:,1)
+!      endif
+
+ !     if (n_iceCat .ge. 2) then
+
+ !        qi2_3d(:,:,j)  = qitot(:,:,2)
+ !        qir2_3d(:,:,j) = qirim(:,:,2)
+ !        qni2_3d(:,:,j) = nitot(:,:,2)
+ !        qib2_3d(:,:,j) = birim(:,:,2)
+
+ !        do i=its,ite
+ !           do k=kts,kte
+ !
+ !        ! for output fallspeed, size, and density, use mass-weighting of categories
+ !     ! ****NOTE: this is only for two categories, needs to be modified for more than 2
+ !           if ((qitot(i,k,1)+qitot(i,k,2)).ge.qsmall) then
+ !              diag_vmi_3d(i,k,j) = (diag_vmi(i,k,1)*qitot(i,k,1)+diag_vmi(i,k,2)*qitot(i,k,2))/(qitot(i,k,1)+qitot(i,k,2))
+ !              diag_di_3d(i,k,j) = (diag_di(i,k,1)*qitot(i,k,1)+diag_di(i,k,2)*qitot(i,k,2))/(qitot(i,k,1)+qitot(i,k,2))
+ !              diag_rhopo_3d(i,k,j) = (diag_rhopo(i,k,1)*qitot(i,k,1)+diag_rhopo(i,k,2)*qitot(i,k,2))/(qitot(i,k,1)+qitot(i,k,2))
+ !           else  ! set to default values of 0 if ice is not present
+ !              diag_vmi_3d(i,k,j) = 0.
+ !              diag_di_3d(i,k,j) = 0.
+ !              diag_rhopo_3d(i,k,j) = 0.
+ !           end if
+ !
+ !           ! for the combined effective radius, we need to approriately weight by mass and projected area
+ !           if (qitot(i,k,1).ge.qsmall) then
+ !              dum1=qitot(i,k,1)/diag_effi(i,k,1)
+ !           else
+ !              dum1=0.
+ !           end if
+ !           if (qitot(i,k,2).ge.qsmall) then
+ !              dum2=qitot(i,k,2)/diag_effi(i,k,2)
+ !           else
+ !              dum2=0.
+ !           end if
+ !           diag_effi_3d(i,k,j)=25.e-6  ! set to default 25 microns
+ !           if (qitot(i,k,1).ge.qsmall.or.qitot(i,k,2).ge.qsmall) then
+ !              diag_effi_3d(i,k,j)=(qitot(i,k,1)+qitot(i,k,2))/(dum1+dum2)
+ !           end if
+ !
+ !           end do
+ !        end do
+ !
+ !        if (n_iceCat .ge. 3) then
+ !
+ !           qi33d(:,:,j)    = qitot(:,:,3)
+ !           qg33d(:,:,j)    = qirim(:,:,3)
+ !           qni33d(:,:,j)   = nitot(:,:,3)
+ !           qvolg33d(:,:,j) = birim(:,:,3)
+ !
+ !           if (n_iceCat == 4) then
+ !              qi43d(:,:,j)    = qitot(:,:,4)
+ !              qg43d(:,:,j)    = qirim(:,:,4)
+ !              qni43d(:,:,j)   = nitot(:,:,4)
+ !              qvolg43d(:,:,j) = birim(:,:,4)
+ !           endif
+ !
+ !        endif   !if n_iceCat.ge.3
+
+ !     endif  !if n_iceCat.ge.2
+
+   enddo ! j loop
+
+ !  deallocate (qitot,qirim,nitot,birim,diag_di,diag_vmi,diag_rhopo,diag_effi,diag_ss)
+
+   END SUBROUTINE mp_p3_wrapper_wrf
+
+!==================================================================================================!
+
+!-- note: to compile with WRF or kin_1d, comment full subroutine and uncomment the following:
+!         (since mp_p3_wrapper_gem contains some GEM-specific code)
+
+  SUBROUTINE mp_p3_wrapper_gem
+  END SUBROUTINE mp_p3_wrapper_gem
+!==
+
+! ! !  SUBROUTINE mp_p3_wrapper_gem(qvap_m,qvap,temp_m,temp,dt,ww,psfc,sigma,kount,trnch,ni,nk, &
+! ! !                               prt_liq,prt_sol,diag_Zet,diag_Zec,diag_effc,qc,nc,qr,nr,    &
+! ! !                               n_iceCat,n_diag_ss,diag_ss,                                 &
+! ! !                               qitot_1,qirim_1,nitot_1,birim_1,diag_effi_1,                &
+! ! !                               qitot_2,qirim_2,nitot_2,birim_2,diag_effi_2,                &
+! ! !                               qitot_3,qirim_3,nitot_3,birim_3,diag_effi_3,                &
+! ! !                               qitot_4,qirim_4,nitot_4,birim_4,diag_effi_4)
+! ! !
+! ! ! !------------------------------------------------------------------------------------------!
+! ! ! ! This wrapper subroutine is the main GEM interface with the P3 microphysics scheme.  It   !
+! ! ! ! prepares some necessary fields (converts temperature to potential temperature, etc.),    !
+! ! ! ! passes 2D slabs (i,k) to the main microphysics subroutine ('P3_MAIN') -- which updates   !
+! ! ! ! the prognostic variables (hydrometeor variables, temperature, and water vapor) and       !
+! ! ! ! computes various diagnostics fields (precipitation rates, reflectivity, etc.) -- and     !
+! ! ! ! finally converts the updated potential temperature to temperature.                       !
+! ! ! !------------------------------------------------------------------------------------------!
+! ! !
+! ! !  implicit none
+! ! !
+! ! ! !----- input/ouput arguments:  ------------------------------------------------------------!
+! ! !
+! ! !  integer, intent(in)                    :: ni                    ! number of columns in slab           -
+! ! !  integer, intent(in)                    :: nk                    ! number of vertical levels           -
+! ! !  integer, intent(in)                    :: n_iceCat              ! number of ice categories            -
+! ! !  integer, intent(in)                    :: kount                 ! time step counter                   -
+! ! !  integer, intent(in)                    :: trnch                 ! number of slice                     -
+! ! !  integer, intent(in)                    :: n_diag_ss             ! number of diagnostic fields
+! ! !  real, intent(in)                       :: dt                    ! model time step                     s
+! ! !  real, intent(inout), dimension(ni,nk)  :: qc                    ! cloud mixing ratio, mass            kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk)  :: nc                    ! cloud mixing ratio, number          #  kg-1
+! ! !  real, intent(inout), dimension(ni,nk)  :: qr                    ! rain  mixing ratio, mass            kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk)  :: nr                    ! rain  mixing ratio, number          #  kg-1
+! ! !  real, intent(inout), dimension(ni,nk)  :: qitot_1               ! ice   mixing ratio, mass (total)    kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk)  :: qirim_1               ! ice   mixing ratio, mass (rime)     kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk)  :: nitot_1               ! ice   mixing ratio, number          #  kg-1
+! ! !  real, intent(inout), dimension(ni,nk)  :: birim_1               ! ice   mixing ratio, volume          m3 kg-1
+! ! !  real, intent(out),   dimension(ni,nk)  :: diag_effi_1           ! ice   effective radius, (cat 1)     m
+! ! !
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: qitot_2     ! ice   mixing ratio, mass (total)    kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: qirim_2     ! ice   mixing ratio, mass (rime)     kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: nitot_2     ! ice   mixing ratio, number          #  kg-1
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: birim_2     ! ice   mixing ratio, volume          m3 kg-1
+! ! !  real, intent(out),   dimension(ni,nk), optional  :: diag_effi_2 ! ice   effective radius, (cat 2)     m
+! ! !
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: qitot_3     ! ice   mixing ratio, mass (total)    kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: qirim_3     ! ice   mixing ratio, mass (rime)     kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: nitot_3     ! ice   mixing ratio, number          #  kg-1
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: birim_3     ! ice   mixing ratio, volume          m3 kg-1
+! ! !  real, intent(out),   dimension(ni,nk), optional  :: diag_effi_3 ! ice   effective radius,  (cat 3)     m
+! ! !
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: qitot_4     ! ice   mixing ratio, mass (total)    kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: qirim_4     ! ice   mixing ratio, mass (rime)     kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: nitot_4     ! ice   mixing ratio, number          #  kg-1
+! ! !  real, intent(inout), dimension(ni,nk), optional  :: birim_4     ! ice   mixing ratio, volume          m3 kg-1
+! ! !  real, intent(out),   dimension(ni,nk), optional  :: diag_effi_4 ! ice   effective radius, (cat 4)     m
+! ! !
+! ! !  real, intent(inout), dimension(ni,nk)  :: qvap_m                ! vapor mixing ratio (previous time) kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk)  :: qvap                  ! vapor mixing ratio, mass           kg kg-1
+! ! !  real, intent(inout), dimension(ni,nk)  :: temp_m                ! temperature (previous time step)    K
+! ! !  real, intent(inout), dimension(ni,nk)  :: temp                  ! temperature                         K
+! ! !  real, intent(in),    dimension(ni)     :: psfc                  ! surface air pressure                Pa
+! ! !  real, intent(in),    dimension(ni,nk)  :: sigma                 ! sigma = p(k,:)/psfc(:)
+! ! !  real, intent(in),    dimension(ni,nk)  :: ww                    ! vertical motion                     m s-1
+! ! !  real, intent(out),   dimension(ni)     :: prt_liq               ! precipitation rate, liquid          m s-1
+! ! !  real, intent(out),   dimension(ni)     :: prt_sol               ! precipitation rate, solid           m s-1
+! ! !  real, intent(out),   dimension(ni,nk)  :: diag_Zet              ! equivalent reflectivity, 3D         dBZ
+! ! !  real, intent(out),   dimension(ni)     :: diag_Zec              ! equivalent reflectivity, col-max    dBZ
+! ! !  real, intent(out),   dimension(ni,nk)  :: diag_effc             ! effective radius, cloud             m
+! ! !  real, intent(out),   dimension(ni,nk,n_diag_ss) :: diag_ss      ! user-defined diagnostic fields
+! ! !
+! ! ! !----------------------------------------------------------------------------------------!
+! ! !
+! ! ! !----- local variables and parameters:
+! ! !  real, dimension(ni,nk,n_iceCat)  :: qitot      ! ice mixing ratio, mass (total)          kg kg-1
+! ! !  real, dimension(ni,nk,n_iceCat)  :: qirim      ! ice mixing ratio, mass (rime)           kg kg-1
+! ! !  real, dimension(ni,nk,n_iceCat)  :: nitot      ! ice mixing ratio, number                #  kg-1
+! ! !  real, dimension(ni,nk,n_iceCat)  :: birim      ! ice mixing ratio, volume                m3 kg-1
+! ! !  real, dimension(ni,nk,n_iceCat)  :: diag_effi  ! effective radius, ice                   m
+! ! !
+! ! !  real, dimension(ni,nk)  :: theta_m             ! potential temperature (previous step)   K
+! ! !  real, dimension(ni,nk)  :: theta               ! potential temperature                   K
+! ! !  real, dimension(ni,nk)  :: pres                ! pressure                                Pa
+! ! !  real, dimension(ni,nk)  :: rho_air             ! air density                             kg m-3
+! ! !  real, dimension(ni,nk)  :: DP                  ! difference in pressure between levels   Pa
+! ! !  real, dimension(ni,nk)  :: DZ                  ! difference in height between levels     m
+! ! !  real, dimension(ni,nk)  :: ssat                ! supersaturation
+! ! !  logical, parameter      :: nk_BOTTOM = .true.  ! .true. for nk at bottom (GEM)
+! ! !  integer                 :: i,k,ktop,kbot,kdir,i_strt,k_strt
+! ! !
+! ! !  logical, parameter      :: log_predictNc = .true.   !temporary; to be put as GEM namelist
+! ! ! !----------------------------------------------------------------------------------------!
+! ! !
+! ! !    include "thermoconsts.inc"
+! ! !
+! ! !    i_strt = 1  ! beginning index of slab
+! ! !    k_strt = 1  ! beginning index of column
+! ! !
+! ! !   !for nk_bottom = .true. :
+! ! !    ktop  = 1   ! k index of top level
+! ! !    kbot  = nk  ! k index of bottom level
+! ! !    kdir  = -1  ! direction of vertical leveling for 1=bottom, nk=top
+! ! !
+! ! !  ! note: code for prediction of ssat not currently avaiable, thus array is to 0
+! ! !    ssat = 0.
+! ! !
+! ! !   !air pressure:
+! ! !    do k = kbot,ktop,kdir
+! ! !       pres(:,k)= psfc(:)*sigma(:,k)
+! ! !    enddo
+! ! !
+! ! !   !air density:
+! ! !    rho_air  = pres/(RGASD*temp)
+! ! !
+! ! !   !pressure difference between levels:
+! ! !    DP(:,kbot) = psfc(:)-pres(:,kbot)
+! ! !    do k = kbot+kdir,ktop,kdir
+! ! !       DP(:,k) = pres(:,k-kdir)-pres(:,k)
+! ! !    enddo
+! ! !
+! ! !   !thickness of layers for sedimentation calculation: (in height coordiates)
+! ! !    DZ = DP/(rho_air*GRAV)
+! ! !
+! ! !   !convert to potential temperature:
+! ! !    theta_m = temp_m*(1.e+5/pres)**0.286
+! ! !    theta = temp*(1.e+5/pres)**0.286
+! ! !
+! ! !   !contruct full ice arrays from individual category arrays:
+! ! !    qitot(:,:,1) = qitot_1(:,:)
+! ! !    qirim(:,:,1) = qirim_1(:,:)
+! ! !    nitot(:,:,1) = nitot_1(:,:)
+! ! !    birim(:,:,1) = birim_1(:,:)
+! ! !
+! ! !    if (n_iceCat >= 2) then
+! ! !       qitot(:,:,2) = qitot_2(:,:)
+! ! !       qirim(:,:,2) = qirim_2(:,:)
+! ! !       nitot(:,:,2) = nitot_2(:,:)
+! ! !       birim(:,:,2) = birim_2(:,:)
+! ! !
+! ! !       if (n_iceCat >= 3) then
+! ! !          qitot(:,:,3) = qitot_3(:,:)
+! ! !          qirim(:,:,3) = qirim_3(:,:)
+! ! !          nitot(:,:,3) = nitot_3(:,:)
+! ! !          birim(:,:,3) = birim_3(:,:)
+! ! !
+! ! !          if (n_iceCat == 4) then
+! ! !             qitot(:,:,4) = qitot_4(:,:)
+! ! !             qirim(:,:,4) = qirim_4(:,:)
+! ! !             nitot(:,:,4) = nitot_4(:,:)
+! ! !             birim(:,:,4) = birim_4(:,:)
+! ! !          endif
+! ! !       endif
+! ! !    endif
+! ! !
+! ! !    call p3_main(qc,nc,qr,nr,theta_m,theta,qvap_m,qvap,dt,qitot,qirim,nitot,birim,ssat,ww,  &
+! ! !                 pres,DZ,kount,prt_liq,prt_sol,i_strt,ni,k_strt,nk,nk_bottom,n_iceCat,      &
+! ! !                 diag_Zet,diag_effc,diag_effi,n_diag_ss,diag_ss,log_predictNc)
+! ! !
+! ! !   !decompose full ice arrays back into individual category arrays:
+! ! !    qitot_1(:,:) = qitot(:,:,1)
+! ! !    qirim_1(:,:) = qirim(:,:,1)
+! ! !    nitot_1(:,:) = nitot(:,:,1)
+! ! !    birim_1(:,:) = birim(:,:,1)
+! ! !    diag_effi_1(:,:) = diag_effi(:,:,1)
+! ! !
+! ! !    if (n_iceCat >= 2) then
+! ! !       qitot_2(:,:) = qitot(:,:,2)
+! ! !       qirim_2(:,:) = qirim(:,:,2)
+! ! !       nitot_2(:,:) = nitot(:,:,2)
+! ! !       birim_2(:,:) = birim(:,:,2)
+! ! !       diag_effi_2(:,:) = diag_effi(:,:,2)
+! ! !
+! ! !       if (n_iceCat >= 3) then
+! ! !          qitot_3(:,:) = qitot(:,:,3)
+! ! !          qirim_3(:,:) = qirim(:,:,3)
+! ! !          nitot_3(:,:) = nitot(:,:,3)
+! ! !          birim_3(:,:) = birim(:,:,3)
+! ! !          diag_effi_3(:,:) = diag_effi(:,:,3)
+! ! !
+! ! !          if (n_iceCat == 4) then
+! ! !             qitot_4(:,:) = qitot(:,:,4)
+! ! !             qirim_4(:,:) = qirim(:,:,4)
+! ! !             nitot_4(:,:) = nitot(:,:,4)
+! ! !             birim_4(:,:) = birim(:,:,4)
+! ! !             diag_effi_4(:,:) = diag_effi(:,:,4)
+! ! !          endif
+! ! !       endif
+! ! !    endif
+! ! !
+! ! !   !convert back to temperature:
+! ! !    temp = theta*(pres*1.e-5)**0.286
+! ! !
+! ! !   !convert precip rates from volume flux (m s-1) to mass flux (kg m-3 s-1):
+! ! !   ! (since they are computed back to liq-eqv volume flux in s/r 'ccdiagnostics.F90')
+! ! !    prt_liq = prt_liq*1000.
+! ! !    prt_sol = prt_sol*1000.
+! ! !
+! ! !   !compute composite (column-maximum) reflectivity:
+! ! !    do i = 1,ni
+! ! !       diag_Zec(i) = maxval(diag_Zet(i,:))
+! ! !    enddo
+! ! !
+! ! !  END SUBROUTINE mp_p3_wrapper_gem
+
+!==========================================================================================!
+
+ SUBROUTINE P3_MAIN(qc,nc,qr,nr,th_old,th,qv_old,qv,dt,qitot,qirim,nitot,birim,ssat,uzpl,   &
+                    pres,dzq,it,pcprt_liq,pcprt_sol,its,ite,kts,kte,nk_bottom,nCat,diag_ze, &
+                    diag_effc,diag_effi,n_diag_ss,diag_ss,log_predictNc)
+
+!----------------------------------------------------------------------------------------!
+!                                                                                        !
+! This is the main subroutine for the P3 microphysics scheme.  It is called from the     !
+! wrapper subroutine ('MP_P3_WRAPPER') and is passed i,k slabs of all prognostic         !
+! variables -- hydrometeor fields, potential temperature, and water vapor mixing ratio.  !
+! Microphysical process rates are computed first.  These tendencies are then used to     !
+! computed updated values of the prognostic variables.  The hydrometeor variables are    !
+! then updated further due to sedimentation.                                             !
+!                                                                                        !
+! Several diagnostic values are also computed and returned to the wrapper subroutine,    !
+! including precipitation rates.                                                         !
+!                                                                                        !
+!----------------------------------------------------------------------------------------!
+
+ implicit none
+
+!----- Input/ouput arguments:  ----------------------------------------------------------!
+
+ real, intent(inout), dimension(its:ite,kts:kte)      :: qc         ! cloud, mass mixing ratio         kg kg-1
+! note: Nc may be specified or predicted (set by log_predictNc)
+ real, intent(inout), dimension(its:ite,kts:kte)      :: nc         ! cloud, number mixing ratio       #  kg-1
+ real, intent(inout), dimension(its:ite,kts:kte)      :: qr         ! rain, mass mixing ratio          kg kg-1
+ real, intent(inout), dimension(its:ite,kts:kte)      :: nr         ! rain, number mixing ratio        #  kg-1
+ real, intent(inout), dimension(its:ite,kts:kte,nCat) :: qitot      ! ice, total mass mixing ratio     kg kg-1
+ real, intent(inout), dimension(its:ite,kts:kte,nCat) :: qirim      ! ice, rime mass mixing ratio      kg kg-1
+ real, intent(inout), dimension(its:ite,kts:kte,nCat) :: nitot      ! ice, total number mixing ratio   #  kg-1
+ real, intent(inout), dimension(its:ite,kts:kte,nCat) :: birim      ! ice, rime volume mixing ratio    m3 kg-1
+ real, intent(inout), dimension(its:ite,kts:kte)      :: ssat       ! supersaturation (i.e., qv-qvs)   kg kg-1
+
+ real, intent(inout), dimension(its:ite,kts:kte)      :: qv         ! water vapor mixing ratio         kg kg-1
+ real, intent(inout), dimension(its:ite,kts:kte)      :: th         ! potential temperature            K
+!- WRF:
+ real, intent(inout), dimension(its:ite,kts:kte)      :: th_old     ! beginning of time step value of theta K
+ real, intent(inout), dimension(its:ite,kts:kte)      :: qv_old     ! beginning of time step value of qv    kg kg-1
+!- GEM:
+!real, intent(in),    dimension(its:ite,kts:kte)      :: th_old     ! beginning of time step value of theta K
+!real, intent(in),    dimension(its:ite,kts:kte)      :: qv_old     ! beginning of time step value of qv    kg kg-1
+!=
+ real, intent(in),    dimension(its:ite,kts:kte)      :: uzpl       ! vertical air velocity            m s-1
+ real, intent(in),    dimension(its:ite,kts:kte)      :: pres       ! pressure                         Pa
+ real, intent(in),    dimension(its:ite,kts:kte)      :: dzq        ! vertical grid spacing            m
+ real, intent(in)                                     :: dt         ! model time step                  s
+
+ real, intent(out),   dimension(its:ite)              :: pcprt_liq  ! precipitation rate, liquid       m s-1
+ real, intent(out),   dimension(its:ite)              :: pcprt_sol  ! precipitation rate, solid        m s-1
+ real, intent(out),   dimension(its:ite,kts:kte)      :: diag_ze    ! equivalent reflectivity          dBZ
+ real, intent(out),   dimension(its:ite,kts:kte)      :: diag_effc  ! effective radius, cloud          m
+ real, intent(out),   dimension(its:ite,kts:kte,nCat) :: diag_effi  ! effective radius, ice            m
+ real, intent(out),   dimension(its:ite,kts:kte,n_diag_ss)  :: diag_ss ! user-defined diagnostic fields
+
+ integer, intent(in)                                  :: its,ite    ! array bounds (horizontal)
+ integer, intent(in)                                  :: kts,kte    ! array bounds (vertical)
+ integer, intent(in)                                  :: it         ! time step counter NOTE: starts at 1 for first time step
+ integer, intent(in)                                  :: nCat       ! number of ice-phase categories
+ integer, intent(in)                                  :: n_diag_ss  ! number of diagnostic fields
+
+ logical, intent(in)                                  :: nk_bottom     ! .F. -> nk at top (WRF) / .T. -> nk at bottom (GEM)
+ logical, intent(in)                                  :: log_predictNc ! .T. (.F.) for prediction (specification) of Nc
+
+!----- Local variables and parameters:  -------------------------------------------------!
+
+ real, dimension(its:ite,kts:kte) :: mu_r  ! shape parameter of rain
+ real, dimension(its:ite,kts:kte) :: t     ! temperature at the beginning of the microhpysics step [K]
+ real, dimension(its:ite,kts:kte) :: t_old ! temperature at the beginning of the model time step [K]
+
+! 2D size distribution and fallspeed parameters:
+
+ real, dimension(its:ite,kts:kte) :: lamc
+ real, dimension(its:ite,kts:kte) :: lamr
+ real, dimension(its:ite,kts:kte) :: n0c
+ real, dimension(its:ite,kts:kte) :: logn0r
+ real, dimension(its:ite,kts:kte) :: mu_c
+!real, dimension(its:ite,kts:kte) :: diag_effr   (currently not used)
+ real, dimension(its:ite,kts:kte) :: nu
+ real, dimension(its:ite,kts:kte) :: cdist
+ real, dimension(its:ite,kts:kte) :: cdist1
+ real, dimension(its:ite,kts:kte) :: cdistr
+ real, dimension(its:ite,kts:kte) :: Vt_nc
+ real, dimension(its:ite,kts:kte) :: Vt_qc
+ real, dimension(its:ite,kts:kte) :: Vt_nr
+ real, dimension(its:ite,kts:kte) :: Vt_qr
+ real, dimension(its:ite,kts:kte) :: Vt_qit
+ real, dimension(its:ite,kts:kte) :: Vt_nit
+!real, dimension(its:ite,kts:kte) :: Vt_zit
+
+! liquid-phase microphysical process rates:
+!  (all Q process rates in kg kg-1 s-1)
+!  (all N process rates in # kg-1)
+
+ real :: qrcon   ! rain condensation
+ real :: qcacc   ! cloud droplet accretion by rain
+ real :: qcaut   ! cloud droplet autoconversion to rain
+ real :: ncacc   ! change in cloud droplet number from accretion by rain
+ real :: ncautc  ! change in cloud droplet number from autoconversion
+ real :: ncslf   ! change in cloud droplet number from self-collection
+ real :: nrslf   ! change in rain number from self-collection
+ real :: ncnuc   ! change in cloud droplet number from activation of CCN
+ real :: qccon   ! cloud droplet condensation
+ real :: qcnuc   ! activation of cloud droplets from CCN
+ real :: qrevp   ! rain evaporation
+ real :: qcevp   ! cloud droplet evaporation
+ real :: nrevp   ! change in rain number from evaporation
+ real :: ncautr  ! change in rain number from autoconversion of cloud water
+
+! ice-phase microphysical process rates:
+!  (all Q process rates in kg kg-1 s-1)
+!  (all N process rates in # kg-1)
+
+ real, dimension(nCat) :: qccol     ! collection of cloud water by ice
+ real, dimension(nCat) :: qwgrth    ! wet growth rate
+ real, dimension(nCat) :: qidep     ! vapor deposition
+ real, dimension(nCat) :: qrcol     ! collection rain mass by ice
+ real, dimension(nCat) :: qinuc     ! deposition/condensation freezing nuc
+ real, dimension(nCat) :: nccol     ! change in cloud droplet number from collection by ice
+ real, dimension(nCat) :: nrcol     ! change in rain number from collection by ice
+ real, dimension(nCat) :: ninuc     ! change in ice number from deposition/cond-freezing nucleation
+ real, dimension(nCat) :: qisub     ! sublimation of ice
+ real, dimension(nCat) :: qimlt     ! melting of ice
+ real, dimension(nCat) :: nimlt     ! melting of ice
+ real, dimension(nCat) :: nisub     ! change in ice number from sublimation
+ real, dimension(nCat) :: nislf     ! change in ice number from collection within a category
+ real, dimension(nCat) :: qchetc    ! contact freezing droplets
+ real, dimension(nCat) :: qcheti    ! immersion freezing droplets
+ real, dimension(nCat) :: qrhetc    ! contact freezing rain
+ real, dimension(nCat) :: qrheti    ! immersion freezing rain
+ real, dimension(nCat) :: nchetc    ! contact freezing droplets
+ real, dimension(nCat) :: ncheti    ! immersion freezing droplets
+ real, dimension(nCat) :: nrhetc    ! contact freezing rain
+ real, dimension(nCat) :: nrheti    ! immersion freezing rain
+ real, dimension(nCat) :: nrshdr    ! source for rain number from collision of rain/ice above freezing and shedding
+ real, dimension(nCat) :: qcshd     ! source for rain mass due to cloud water/ice collision above freezing and shedding or wet growth and shedding
+ real, dimension(nCat) :: qcmul     ! change in q, ice multiplication from rime-splitnering of cloud water (not included in the paper)
+ real, dimension(nCat) :: qrmul     ! change in q, ice multiplication from rime-splitnering of rain (not included in the paper)
+ real, dimension(nCat) :: nimul     ! change in Ni, ice multiplication from rime-splintering (not included in the paper)
+ real, dimension(nCat) :: ncshdc    ! source for rain number due to cloud water/ice collision above freezing  and shedding (combined with NRSHD in the paper)
+ real, dimension(nCat) :: rhorime_c ! density of rime (from cloud)
+ real, dimension(nCat) :: rhorime_r ! density of rime (from rain)
+
+ real, dimension(nCat,nCat) :: nicol ! change of N due to ice-ice collision between categories
+ real, dimension(nCat,nCat) :: qicol ! change of q due to ice-ice collision between categories
+
+ real, dimension(its:ite,kts:kte,nCat) :: diag_vmi,diag_di,diag_rhopo !collected locally, but passed out through diag_ss
+
+ logical, dimension(nCat)   :: log_wetgrowth
+
+ real, dimension(nCat) :: Eii_fact,epsi
+ real :: eii ! temperature dependent aggregation efficiency
+
+ real, dimension(its:ite,kts:kte,nCat) :: diam_ice
+
+ real, dimension(its:ite,kts:kte)      :: inv_dzq,inv_rho,ze_ice,ze_rain,prec,rho,       &
+            rhofacr,rhofaci,acn,xxls,xxlv,xlf,qvs,qvi,sup,supi,ss,vtrmi1,vtrnitot,       &
+            tmparr1
+
+ real, dimension(kts:kte) :: dum_qit,dum_qr,dum_nit,dum_qir,dum_bir,dum_zit,dum_nr,      &
+            dum_qc,dum_nc,V_qr,V_qit,V_nit,V_nr,V_qc,V_nc,V_zit,flux_qr,flux_qit,        &
+            flux_nit,flux_nr,flux_qir,flux_bir,flux_zit,flux_qc,flux_nc,tend_qc,tend_qr, &
+            tend_nr,tend_qit,tend_qir,tend_bir,tend_nit,tend_nc !,tend_zit
+
+ real    :: lammax,lammin,mu,dv,sc,dqsdt,ab,kap,epsr,epsc,xx,aaa,epsilon,sigvl,epsi_tot, &
+            aact,alpha,gamm,gg,psi,eta1,eta2,sm1,sm2,smax,uu1,uu2,dum,dum0,dum1,dum2,    &
+            dumqv,dumqvs,dums,dumqc,ratio,qsat0,udiff,dum3,dum4,dum5,dum6,lamold,rdumii, &
+            rdumjj,dqsidt,abi,dumqvi,dap,nacnt,rhop,v_impact,ri,iTc,D_c,D_r,dumlr,tmp1,  &
+            tmp2,tmp3,inv_nstep,inv_dum,inv_dum3,odt,oxx,oabi,zero,test,test2,test3,     &
+            onstep,fluxdiv_qr,fluxdiv_qit,fluxdiv_nit,fluxdiv_qir,fluxdiv_bir,           &
+            fluxdiv_zit,fluxdiv_qc,fluxdiv_nc,fluxdiv_nr,rgvm,D_new,Q_nuc,N_nuc,         &
+            deltaD_init,dum1c,dum4c,dum5c,dumt,qcon_satadj,qdep_satadj,sources,sinks,    &
+            drhop,timeScaleFactor
+
+ integer :: dumi,i,k,kk,ii,jj,iice,iice_dest,j,dumk,dumj,dumii,dumjj,dumzz,n,nstep,      &
+            tmpint1,tmpint2,ktop,kbot,kdir,qcindex,qrindex,qiindex,dumic,dumiic,dumjjc,  &
+            catcoll
+ logical :: log_nucleationPossible,log_hydrometeorsPresent,log_predictSsat,log_tmp1,     &
+            log_exitlevel,log_hmossopOn,log_qcpresent,log_qrpresent,log_qipresent,       &
+            log_ni_add
+
+! quantities related to process rates/parameters, interpolated from lookup tables:
+
+ real    :: f1pr01   ! number-weighted fallspeed
+ real    :: f1pr02   ! mass-weighted fallspeed
+ real    :: f1pr03   ! ice collection within a category
+ real    :: f1pr04   ! collection of cloud water by ice
+ real    :: f1pr05   ! melting
+ real    :: f1pr06   ! effective radius
+ real    :: f1pr07   ! collection of rain number by ice
+ real    :: f1pr08   ! collection of rain mass by ice
+ real    :: f1pr09   ! minimum ice number (lambda limiter)
+ real    :: f1pr10   ! maximum ice number (lambda limiter)
+ real    :: f1pr11   ! not used
+ real    :: f1pr12   ! not used
+ real    :: f1pr13   ! reflectivity
+ real    :: f1pr14   ! melting (ventilation term)
+ real    :: f1pr15   ! mass-weighted mean diameter
+ real    :: f1pr16   ! mass-weighted mean particle density
+ real    :: f1pr17   ! ice-ice category collection change in number
+ real    :: f1pr18   ! ice-ice category collection change in mass
+
+ !--These will be added as namelist parameters in the future
+ logical, parameter :: debug_ON     = .false.  !.true. to switch on debugging checks/traps throughout code
+ logical, parameter :: debug_ABORT  = .false.  !.true. will result in forced abort in s/r 'check_values'
+ !==
+
+!-----------------------------------------------------------------------------------!
+!  End of variables/parameters declarations
+!-----------------------------------------------------------------------------------!
+
+!-----------------------------------------------------------------------------------!
+! Note, the array 'diag_ss(ni,nk,n_diag_ss)' provides a placeholder to output 3D diagnostic fields.
+! The entire array array is inialized to zero (below).  Code can be added to store desired fields
+! by simply adding the appropriate assignment statements.  For example, if one wishs to output the
+! rain condensation and evaporation rates, simply add assignments in the appropriate locations.
+!  e.g.:
+!
+!   diag_ss(i,k,1) = qrcon
+!   diag_ss(i,k,2) = qrevp
+!
+! The fields will automatically be passed to the driving model.  In GEM, these arrays can be
+! output by adding 'SS01' and 'SS02' to the model output list.
+!-----------------------------------------------------------------------------------!
+
+
+ !direction of vertical leveling:
+ if (nk_bottom) then
+   !GEM / kin_1d:
+    ktop = kts        !k of top level
+    kbot = kte        !k of bottom level
+    kdir = -1         !(k: 1=top, nk=bottom)
+ else
+   !WRF / kin_2d:
+    ktop = kte        !k of top level
+    kbot = kts        !k of bottom level
+    kdir = 1          !(k: 1=bottom, nk=top)
+ endif
+
+
+! Determine threshold size difference [m] as a function of nCat
+! (used for destination category upon ice initiation)
+! note -- this code could be moved to 'p3_init'
+ select case (nCat)
+    case (1)
+       deltaD_init = 999.    !not used if n_iceCat=1 (but should be defined)
+    case (2)
+       deltaD_init = 500.e-6
+    case (3)
+       deltaD_init = 400.e-6
+    case (4)
+       deltaD_init = 235.e-6
+    case (5)
+       deltaD_init = 175.e-6
+    case (6:)
+       deltaD_init = 150.e-6
+ end select
+
+! deltaD_init = 250.e-6   !for testing
+! deltaD_init = dummy_in   !temporary; passed in from cld1d
+
+! Note:  Code for prediction of supersaturation is available in current version.
+!        In the future 'log_predictSsat' will be a user-defined namelist key.
+ log_predictSsat = .false.
+
+ log_hmossopOn   = (nCat.gt.1)      !default: off for nCat=1, off for nCat>1
+!log_hmossopOn   = .true.           !switch to have Hallet-Mossop ON
+!log_hmossopOn   = .false.          !switch to have Hallet-Mossop OFF
+
+ inv_dzq    = 1./dzq  ! inverse of thickness of layers
+ odt        = 1./dt   ! inverse model time step
+
+! Compute time scale factor over which to apply soft rain lambda limiter
+! note: '1./max(30.,dt)' = '1.*min(1./30., 1./dt)'
+ timeScaleFactor = min(1./120., odt)
+
+ pcprt_liq  = 0.
+ pcprt_sol  = 0.
+ prec       = 0.
+ mu_r       = 0.
+ diag_ze    = -99.
+ diam_ice   = 0.
+ ze_ice     = 1.e-22
+ ze_rain    = 1.e-22
+ diag_effc  = 10.e-6 ! default value
+!diag_effr  = 25.e-6 ! default value
+ diag_effi  = 25.e-6 ! default value
+ diag_vmi   = 0.
+ diag_di    = 0.
+ diag_rhopo = 0.
+ diag_ss    = 0.
+ rhorime_c  = 400.
+!rhorime_r  = 400.
+
+ tmparr1 = (pres*1.e-5)**(rd*inv_cp)
+ t       = th    *tmparr1    !compute temperature from theta (value at beginning of microphysics step)
+ t_old   = th_old*tmparr1    !compute temperature from theta (value at beginning of model time step)
+ qv      = max(qv,0.)        !clip water vapor to prevent negative values passed in (beginning of microphysics)
+!==
+!-----------------------------------------------------------------------------------!
+ i_loop_main: do i = its,ite  ! main i-loop (around the entire scheme)
+
+    if (debug_ON) call check_values(qv,T,qc,qr,nr,qitot,qirim,nitot,birim,i,it,.false.,debug_ABORT,100)
+
+    log_hydrometeorsPresent = .false.
+    log_nucleationPossible  = .false.
+
+    k_loop_1: do k = kbot,ktop,kdir
+
+!-- To be deleted (moved to above)
+! !      !calculate old temperature from old value of theta
+! !        t_old(i,k) = th_old(i,k)*(pres(i,k)*1.e-5)**(rd*inv_cp)
+! !      !calculate current temperature from current theta
+! !        t(i,k) = th(i,k)*(pres(i,k)*1.e-5)**(rd*inv_cp)
+!==
+
+     !calculate some time-varying atmospheric variables
+       rho(i,k)     = pres(i,k)/(rd*t(i,k))
+       inv_rho(i,k) = 1./rho(i,k)
+       xxlv(i,k)    = 3.1484e6-2370.*t(i,k)
+       xxls(i,k)    = xxlv(i,k)+0.3337e6
+       xlf(i,k)     = xxls(i,k)-xxlv(i,k)
+       qvs(i,k)     = qv_sat(t_old(i,k),pres(i,k),0)
+       qvi(i,k)     = qv_sat(t_old(i,k),pres(i,k),1)
+
+      ! if supersaturation is not predicted or during the first time step, then diagnose from qv and T (qvs)
+       if (.not.(log_predictSsat).or.it.eq.1) then
+          ssat(i,k)    = qv_old(i,k)-qvs(i,k)
+          sup(i,k)     = qv_old(i,k)/qvs(i,k)-1.
+          supi(i,k)    = qv_old(i,k)/qvi(i,k)-1.
+      ! if supersaturation is predicted then diagnose sup and supi from ssat
+       else if ((log_predictSsat).and.it.gt.1) then
+          sup(i,k)     = ssat(i,k)/qvs(i,k)
+          supi(i,k)    = (ssat(i,k)+qvs(i,k)-qvi(i,k))/qvi(i,k)
+       endif
+
+       rhofacr(i,k) = (rhosur*inv_rho(i,k))**0.54
+       rhofaci(i,k) = (rhosui*inv_rho(i,k))**0.54
+       dum          = 1.496e-6*t(i,k)**1.5/(t(i,k)+120.)  ! this is mu
+       acn(i,k)     = g*rhow/(18.*dum)  ! 'a' parameter for droplet fallspeed (Stokes' law)
+
+      !specify cloud droplet number (for 1-moment version)
+       if (.not.(log_predictNc)) then
+          nc(i,k) = nccnst*inv_rho(i,k)
+       endif
+
+       if ((t(i,k).lt.273.15 .and. supi(i,k).ge.-0.05) .or.                              &
+           (t(i,k).ge.273.15 .and. sup(i,k).ge.-0.05 )) log_nucleationPossible = .true.
+
+    !--- apply mass clipping if dry and mass is sufficiently small
+    !    (implying all mass is expected to evaporate/sublimate in one time step)
+
+       if (qc(i,k).lt.qsmall .or. (qc(i,k).lt.1.e-8 .and. sup(i,k).lt.-0.1)) then
+          qv(i,k) = qv(i,k) + qc(i,k)
+          th(i,k) = th(i,k) - th(i,k)/t(i,k)*qc(i,k)*xxlv(i,k)*inv_cp
+          qc(i,k) = 0.
+          nc(i,k) = 0.
+       else
+          log_hydrometeorsPresent = .true.    ! updated further down
+       endif
+
+       if (qr(i,k).lt.qsmall .or. (qr(i,k).lt.1.e-8 .and. sup(i,k).lt.-0.1)) then
+          qv(i,k) = qv(i,k) + qr(i,k)
+          th(i,k) = th(i,k) - th(i,k)/t(i,k)*qr(i,k)*xxlv(i,k)*inv_cp
+          qr(i,k) = 0.
+          nr(i,k) = 0.
+       else
+          log_hydrometeorsPresent = .true.    ! updated further down
+       endif
+
+       do iice = 1,nCat
+          if (qitot(i,k,iice).lt.qsmall .or. (qitot(i,k,iice).lt.1.e-8 .and.             &
+           supi(i,k).lt.-0.1)) then
+             qv(i,k) = qv(i,k) + qitot(i,k,iice)
+             th(i,k) = th(i,k) - th(i,k)/t(i,k)*qitot(i,k,iice)*xxls(i,k)*inv_cp
+             qitot(i,k,iice) = 0.
+             nitot(i,k,iice) = 0.
+             qirim(i,k,iice) = 0.
+             birim(i,k,iice) = 0.
+          else
+             log_hydrometeorsPresent = .true.    ! final update
+          endif
+
+          if (qitot(i,k,iice).ge.qsmall .and. qitot(i,k,iice).lt.1.e-8 .and.             &
+           t(i,k).ge.273.15) then
+             qr(i,k) = qr(i,k) + qitot(i,k,iice)
+             th(i,k) = th(i,k) - th(i,k)/t(i,k)*qitot(i,k,iice)*xlf(i,k)*inv_cp
+             qitot(i,k,iice) = 0.
+             nitot(i,k,iice) = 0.
+             qirim(i,k,iice) = 0.
+             birim(i,k,iice) = 0.
+          endif
+
+       enddo  !iice-loop
+
+    !===
+
+    enddo k_loop_1
+
+    if (debug_ON) then
+       tmparr1(i,:) = th(i,:)*(pres(i,:)*1.e-5)**(rd*inv_cp)
+       call check_values(qv,tmparr1,qc,qr,nr,qitot,qirim,nitot,birim,i,it,.true.,debug_ABORT,200)
+    endif
+
+   !jump to end of i-loop if log_nucleationPossible=.false.  (i.e. skip everything)
+    if (.not. (log_nucleationPossible .or. log_hydrometeorsPresent)) goto 333
+
+    log_hydrometeorsPresent = .false.   ! reset value; used again below
+
+!------------------------------------------------------------------------------------------!
+!   main k-loop (for processes):
+    k_loop_main: do k = kbot,ktop,kdir
+
+     ! if relatively dry and no hydrometeors at this level, skip to end of k-loop (i.e. skip this level)
+       log_exitlevel = .true.
+       if (qc(i,k).ge.qsmall .or. qr(i,k).ge.qsmall) log_exitlevel = .false.
+       do iice = 1,nCat
+          if (qitot(i,k,iice).ge.qsmall) log_exitlevel = .false.
+       enddo
+       if (log_exitlevel .and.                                                           &
+          ((t(i,k).lt.273.15 .and. supi(i,k).lt.-0.05) .or.                              &
+           (t(i,k).ge.273.15 .and. sup(i,k) .lt.-0.05))) goto 555   !i.e. skip all process rates
+
+    ! initialize warm-phase process rates
+       qcacc   = 0.;     qrevp   = 0.;     qccon   = 0.
+       qcaut   = 0.;     qcevp   = 0.;     qrcon   = 0.
+       ncacc   = 0.;     ncnuc   = 0.;     ncslf   = 0.
+       ncautc  = 0.;     qcnuc   = 0.;     nrslf   = 0.
+       nrevp   = 0.;     ncautr  = 0.
+
+    ! initialize ice-phase  process rates
+       qchetc  = 0.;     qisub   = 0.;     nrshdr  = 0.
+       qcheti  = 0.;     qrcol   = 0.;     qcshd   = 0.
+       qrhetc  = 0.;     qimlt   = 0.;     qccol   = 0.
+       qrheti  = 0.;     qinuc   = 0.;     nimlt   = 0.
+       nchetc  = 0.;     nccol   = 0.;     ncshdc  = 0.
+       ncheti  = 0.;     nrcol   = 0.;     nislf   = 0.
+       nrhetc  = 0.;     ninuc   = 0.;     qidep   = 0.
+       nrheti  = 0.;     nisub   = 0.;     qwgrth  = 0.
+       qcmul   = 0.;     qrmul   = 0.;     nimul   = 0.
+       qicol   = 0.;     nicol   = 0.
+
+       log_wetgrowth = .false.
+
+!----------------------------------------------------------------------
+       predict_supersaturation: if (log_predictSsat) then
+
+      ! Adjust cloud water and thermodynamics to prognostic supersaturation
+      ! following the method in Grabowski and Morrison (2008).
+      ! Note that the effects of vertical motion are assumed to dominate the
+      ! production term for supersaturation, and the effects are sub-grid
+      ! scale mixing and radiation are not explicitly included.
+
+          dqsdt   = xxlv(i,k)*qvs(i,k)/(rv*t(i,k)*t(i,k))
+          ab      = 1. + dqsdt*xxlv(i,k)*inv_cp
+          epsilon = (qv(i,k)-qvs(i,k)-ssat(i,k))/ab
+          epsilon = max(epsilon,-qc(i,k))   ! limit adjustment to available water
+        ! don't adjust upward if subsaturated
+        ! otherwise this could result in positive adjustment
+        ! (spurious generation ofcloud water) in subsaturated conditions
+          if (ssat(i,k).lt.0.) epsilon = min(0.,epsilon)
+
+        ! now do the adjustment
+          if (abs(epsilon).ge.1.e-15) then
+             qc(i,k)   = qc(i,k)+epsilon
+             qv(i,k)   = qv(i,k)-epsilon
+             th(i,k)   = th(i,k)+epsilon*th(i,k)/t(i,k)*xxlv(i,k)*inv_cp
+            ! recalculate variables if there was adjustment
+             t(i,k)    = th(i,k)*(1.e-5*pres(i,k))**(rd*inv_cp)
+             qvs(i,k)  = qv_sat(t(i,k),pres(i,k),0)
+             qvi(i,k)  = qv_sat(t(i,k),pres(i,k),1)
+             sup(i,k)  = qv(i,k)/qvs(i,k)-1.
+             supi(i,k) = qv(i,k)/qvi(i,k)-1.
+             ssat(i,k) = qv(i,k)-qvs(i,k)
+          endif
+
+       endif predict_supersaturation
+!----------------------------------------------------------------------
+
+! skip micro process calculations except nucleation/acvtivation if there no hydrometeors are present
+       log_exitlevel = .true.
+       if (qc(i,k).ge.qsmall .or. qr(i,k).ge.qsmall) log_exitlevel = .false.
+       do iice = 1,nCat
+          if (qitot(i,k,iice).ge.qsmall) log_exitlevel=.false.
+       enddo
+       if (log_exitlevel) goto 444   !i.e. skip to nucleation
+
+        !time/space varying physical variables
+       mu     = 1.496e-6*t(i,k)**1.5/(t(i,k)+120.)
+       dv     = 8.794e-5*t(i,k)**1.81/pres(i,k)
+       sc     = mu/(rho(i,k)*dv)
+       dum    = 1./(rv*t(i,k)**2)
+       dqsdt  = xxlv(i,k)*qvs(i,k)*dum
+       dqsidt = xxls(i,k)*qvi(i,k)*dum
+       ab     = 1.+dqsdt*xxlv(i,k)*inv_cp
+       abi    = 1.+dqsidt*xxls(i,k)*inv_cp
+       kap    = 1.414e+3*mu
+      ! very simple temperature dependent aggregation efficiency
+       if (t(i,k).lt.253.15) then
+          eii=0.1
+       else if (t(i,k).ge.253.15.and.t(i,k).lt.268.15) then
+          eii=0.1+(t(i,k)-253.15)/15.*0.9  ! linear ramp from 0.1 to 1 between 253.15 and 268.15 K
+       else if (t(i,k).ge.268.15) then
+          eii=1.
+       end if
+
+       call get_cloud_dsd(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu,lamc(i,k),      &
+                          lammin,lammax,k,cdist(i,k),cdist1(i,k),tmpint1,log_tmp1)
+
+       call get_rain_dsd(qr(i,k),nr(i,k),mu_r(i,k),rdumii,dumii,lamr(i,k),mu_r_table,    &
+                         cdistr(i,k),logn0r(i,k),log_tmp1,tmpint1,tmpint2)
+       !note: log_tmp1,tmpint1,tmpint2 are not used in this section
+
+     ! initialize inverse supersaturation relaxation timescale for combined ice categories
+       epsi_tot = 0.
+
+       call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k))
+
+       iice_loop1: do iice = 1,nCat
+
+          if (qitot(i,k,iice).ge.qsmall) then
+
+            !impose lower limits to prevent taking log of # < 0
+             nitot(i,k,iice) = max(nitot(i,k,iice),nsmall)
+             nr(i,k)         = max(nr(i,k),nsmall)
+
+            !compute mean-mass ice diameters (estimated; rigorous approach to be implemented later)
+             dum2 = 500. !ice density
+             diam_ice(i,k,iice) = ((qitot(i,k,iice)*6.)/(nitot(i,k,iice)*dum2*pi))**thrd
+
+             call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),birim(i,k,iice),rhop)
+
+           ! if (.not. tripleMoment_on) zitot(i,k,iice) = diag_mom6(qitot(i,k,iice),nitot(i,k,iice),rho(i,k))
+             call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumzz,dum1,dum4,          &
+                                   dum5,dum6,isize,rimsize,densize,zsize,                &
+                                   qitot(i,k,iice),nitot(i,k,iice),qirim(i,k,iice),      &
+                                   999.,rhop)
+                                  !qirim(i,k,iice),zitot(i,k,iice),rhop)
+             call find_lookupTable_indices_1b(dumj,dum3,rcollsize,qr(i,k),nr(i,k))
+
+          ! call to lookup table interpolation subroutines to get process rates
+             call access_lookup_table(dumjj,dumii,dumi, 2,dum1,dum4,dum5,f1pr02)
+             call access_lookup_table(dumjj,dumii,dumi, 3,dum1,dum4,dum5,f1pr03)
+             call access_lookup_table(dumjj,dumii,dumi, 4,dum1,dum4,dum5,f1pr04)
+             call access_lookup_table(dumjj,dumii,dumi, 5,dum1,dum4,dum5,f1pr05)
+             call access_lookup_table(dumjj,dumii,dumi, 7,dum1,dum4,dum5,f1pr09)
+             call access_lookup_table(dumjj,dumii,dumi, 8,dum1,dum4,dum5,f1pr10)
+             call access_lookup_table(dumjj,dumii,dumi,10,dum1,dum4,dum5,f1pr14)
+
+          ! ice-rain collection processes
+             if (qr(i,k).ge.qsmall) then
+                call access_lookup_table_coll(dumjj,dumii,dumj,dumi,1,dum1,    &
+                                              dum3,dum4,dum5,f1pr07)
+                call access_lookup_table_coll(dumjj,dumii,dumj,dumi,2,dum1,    &
+                                              dum3,dum4,dum5,f1pr08)
+             else
+                f1pr07 = 0.
+                f1pr08 = 0.
+             endif
+
+          ! adjust Ni if needed to make sure mean size is in bounds (i.e. apply lambda limiters)
+          ! note that the Nmax and Nmin are normalized and thus need to be multiplied by existing N
+             nitot(i,k,iice) = min(nitot(i,k,iice),f1pr09*nitot(i,k,iice))
+             nitot(i,k,iice) = max(nitot(i,k,iice),f1pr10*nitot(i,k,iice))
+
+
+          ! Determine additional collection efficiency factor to be applied to ice-ice collection.
+          ! The computed values of qicol and nicol are multipiled by Eii_fact to gradually shut off collection
+          ! if the ice in iice is highly rimed.
+             if (qirim(i,k,iice)>0.) then
+                tmp1 = qirim(i,k,iice)/qitot(i,k,iice)   !rime mass fraction
+                if (tmp1.lt.0.6) then
+                   Eii_fact(iice)=1.
+                else if (tmp1.ge.0.6.and.tmp1.lt.0.9) then
+          ! linear ramp from 1 to 0 for Fr between 0.6 and 0.9
+                   Eii_fact(iice) = 1.-(tmp1-0.6)/0.3
+                else if (tmp1.ge.0.9) then
+                   Eii_fact(iice) = 0.
+                endif
+             else
+                Eii_fact(iice) = 1.
+             endif
+
+          endif   ! qitot > qsmall
+
+!----------------------------------------------------------------------
+! Begin calculations of microphysical processes
+
+!......................................................................
+! ice processes
+!......................................................................
+
+!.......................
+! collection of droplets
+
+! here we multiply rates by air density, air density fallspeed correction
+! factor, and collection efficiency since these parameters are not
+! included in lookup table calculations
+! for T < 273.15, assume collected cloud water is instantly frozen
+! note 'f1pr' values are normalized, so we need to multiply by N
+
+          if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).le.273.15) then
+             qccol(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)
+             nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)
+          endif
+
+! for T > 273.15, assume cloud water is collected and shed as rain drops
+
+          if (qitot(i,k,iice).ge.qsmall .and. qc(i,k).ge.qsmall .and. t(i,k).gt.273.15) then
+          ! sink for cloud water mass and number, note qcshed is source for rain mass
+             qcshd(iice) = rhofaci(i,k)*f1pr04*qc(i,k)*eci*rho(i,k)*nitot(i,k,iice)
+             nccol(iice) = rhofaci(i,k)*f1pr04*nc(i,k)*eci*rho(i,k)*nitot(i,k,iice)
+          ! source for rain number, assume 1 mm drops are shed
+             ncshdc(iice) = qcshd(iice)*1.923e+6
+          endif
+
+!....................
+! collection of rain
+
+     ! here we multiply rates by air density, air density fallspeed correction
+     ! factor, collection efficiency, and n0r since these parameters are not
+     ! included in lookup table calculations
+
+     ! for T < 273.15, assume all collected rain mass freezes
+     ! note this is a sink for rain mass and number and a source
+     ! for ice mass
+
+     ! note 'f1pr' values are normalized, so we need to multiply by N
+
+          if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).le.273.15) then
+           ! qrcol(iice)=f1pr08*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)
+           ! nrcol(iice)=f1pr07*logn0r(i,k)*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)
+           ! note: f1pr08 and logn0r are already calculated as log_10
+             qrcol(iice) = 10.**(f1pr08+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)
+             nrcol(iice) = 10.**(f1pr07+logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)
+       endif
+
+     ! for T > 273.15, assume collected rain number is shed as
+     ! 1 mm drops
+     ! note that melting of ice number is scaled to the loss
+     ! rate of ice mass due to melting
+     ! collection of rain above freezing does not impact total rain mass
+
+          if (qitot(i,k,iice).ge.qsmall .and. qr(i,k).ge.qsmall .and. t(i,k).gt.273.15) then
+           ! rain number sink due to collection
+             nrcol(iice)  = 10.**(f1pr07 + logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)
+           ! rain number source due to shedding = collected rain mass/mass of 1 mm drop
+             dum    = 10.**(f1pr08 + logn0r(i,k))*rho(i,k)*rhofaci(i,k)*eri*nitot(i,k,iice)
+     ! for now neglect shedding of ice collecting rain above freezing, since snow is
+     ! not expected to shed in these conditions (though more hevaily rimed ice would be
+     ! expected to lead to shedding)
+     !             nrshdr(iice) = dum*1.923e+6   ! 1./5.2e-7, 5.2e-7 is the mass of a 1 mm raindrop
+          endif
+
+
+!...................................
+! collection between ice categories
+
+          iceice_interaction1:  if (iice.ge.2) then
+!         iceice_interaction1:  if (.false.) then       !test, to suppress ice-ice interaction
+
+             qitot_notsmall: if (qitot(i,k,iice).ge.qsmall) then
+                catcoll_loop: do catcoll = 1,iice-1
+                   qitotcatcoll_notsmall: if (qitot(i,k,catcoll).ge.qsmall) then
+
+                  ! first, calculate collection of catcoll category by iice category
+
+                    ! if (.not. tripleMoment_on) zitot(i,k,iice) = diag_mom6(qitot(i,k,iice),nitot(i,k,iice),rho(i,k))
+
+                      call find_lookupTable_indices_2(dumi,dumii,dumjj,dumic,dumiic,   &
+                                 dumjjc,dum1,dum4,dum5,dum1c,dum4c,dum5c,              &
+                                 iisize,rimsize,densize,                               &
+                                 qitot(i,k,iice),qitot(i,k,catcoll),nitot(i,k,iice),        &
+                                 nitot(i,k,catcoll),qirim(i,k,iice),qirim(i,k,catcoll),     &
+                                 birim(i,k,iice),birim(i,k,catcoll))
+
+                      call access_lookup_table_colli(dumjjc,dumiic,dumic,dumjj,dumii,dumj,  &
+                                 dumi,1,dum1c,dum4c,dum5c,dum1,dum4,dum5,f1pr17)
+                      call access_lookup_table_colli(dumjjc,dumiic,dumic,dumjj,dumii,dumj,  &
+                                 dumi,2,dum1c,dum4c,dum5c,dum1,dum4,dum5,f1pr18)
+
+                    ! note: need to multiply by air density, air density fallspeed correction factor,
+                    !       and N of the collectee and collector categories for process rates nicol and qicol,
+                    !       first index is the collectee, second is the collector
+                      nicol(catcoll,iice) = f1pr17*rhofaci(i,k)*rhofaci(i,k)*rho(i,k)*     &
+                                            nitot(i,k,catcoll)*nitot(i,k,iice)
+                      qicol(catcoll,iice) = f1pr18*rhofaci(i,k)*rhofaci(i,k)*rho(i,k)*     &
+                                            nitot(i,k,catcoll)*nitot(i,k,iice)
+
+                      nicol(catcoll,iice) = eii*Eii_fact(iice)*nicol(catcoll,iice)
+                      qicol(catcoll,iice) = eii*Eii_fact(iice)*qicol(catcoll,iice)
+                      nicol(catcoll,iice) = min(nicol(catcoll,iice), nitot(i,k,catcoll)*odt)
+                      qicol(catcoll,iice) = min(qicol(catcoll,iice), qitot(i,k,catcoll)*odt)
+                  ! second, calculate collection of iice category by catcoll category
+
+                    ! if (.not. tripleMoment_on) zitot(i,k,iice) = diag_mom6(qitot(i,k,iice),nitot(i,k,iice),rho(i,k))
+
+                    !needed to force consistency between qirim(catcoll) and birim(catcoll) (not for rhop)
+                      call calc_bulkRhoRime(qitot(i,k,catcoll),qirim(i,k,catcoll),birim(i,k,catcoll),rhop)
+
+                      call find_lookupTable_indices_2(dumi,dumii,dumjj,dumic,dumiic,  &
+                                 dumjjc,dum1,dum4,dum5,dum1c,dum4c,dum5c,             &
+                                 iisize,rimsize,densize,                              &
+                                 qitot(i,k,catcoll),qitot(i,k,iice),nitot(i,k,catcoll),    &
+                                 nitot(i,k,iice),qirim(i,k,catcoll),qirim(i,k,iice),       &
+                                 birim(i,k,catcoll),birim(i,k,iice))
+
+                      call access_lookup_table_colli(dumjjc,dumiic,dumic,dumjj,dumii,dumj, &
+                                 dumi,1,dum1c,dum4c,dum5c,dum1,dum4,dum5,f1pr17)
+
+                      call access_lookup_table_colli(dumjjc,dumiic,dumic,dumjj,dumii,dumj, &
+                                 dumi,2,dum1c,dum4c,dum5c,dum1,dum4,dum5,f1pr18)
+
+                      nicol(iice,catcoll) = f1pr17*rhofaci(i,k)*rhofaci(i,k)*rho(i,k)*     &
+                                            nitot(i,k,iice)*nitot(i,k,catcoll)
+                      qicol(iice,catcoll) = f1pr18*rhofaci(i,k)*rhofaci(i,k)*rho(i,k)*     &
+                                            nitot(i,k,iice)*nitot(i,k,catcoll)
+                     ! note: Eii_fact applied to the collector category
+                      nicol(iice,catcoll) = eii*Eii_fact(catcoll)*nicol(iice,catcoll)
+                      qicol(iice,catcoll) = eii*Eii_fact(catcoll)*qicol(iice,catcoll)
+                      nicol(iice,catcoll) = min(nicol(iice,catcoll),nitot(i,k,iice)*odt)
+                      qicol(iice,catcoll) = min(qicol(iice,catcoll),qitot(i,k,iice)*odt)
+
+                   endif qitotcatcoll_notsmall
+                enddo catcoll_loop
+             endif qitot_notsmall
+
+          endif iceice_interaction1
+
+
+!.............................................
+! self-collection of ice (in a given category)
+
+    ! here we multiply rates by collection efficiency, air density,
+    ! and air density correction factor since these are not included
+    ! in the lookup table calculations
+    ! note 'f1pr' values are normalized, so we need to multiply by N
+
+          if (qitot(i,k,iice).ge.qsmall) then
+             nislf(iice) = f1pr03*rho(i,k)*eii*Eii_fact(iice)*rhofaci(i,k)*nitot(i,k,iice)
+          endif
+
+
+!............................................................
+! melting
+
+    ! need to add back accelerated melting due to collection of ice mass by rain (pracsw1)
+    ! note 'f1pr' values are normalized, so we need to multiply by N
+
+          if (qitot(i,k,iice).ge.qsmall .and. t(i,k).gt.273.15) then
+             qsat0 = 0.622*e0/(pres(i,k)-e0)
+          !  dum=cpw/xlf(i,k)*(t(i,k)-273.15)*(pracsw1+qcshd(iice))
+          ! currently enhanced melting from collision is neglected
+          ! dum=cpw/xlf(i,k)*(t(i,k)-273.15)*(pracsw1)
+             dum = 0.
+          ! qimlt(iice)=(f1pr05+f1pr14*sc**0.3333*(rhofaci(i,k)*rho(i,k)/mu)**0.5)* &
+          !       (t(i,k)-273.15)*2.*pi*kap/xlf(i,k)+dum
+          ! include RH dependence
+             qimlt(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*((t(i,k)-   &
+                          273.15)*kap-rho(i,k)*xxlv(i,k)*dv*(qsat0-qv(i,k)))*2.*pi/xlf(i,k)+     &
+                          dum)*nitot(i,k,iice)
+             qimlt(iice) = max(qimlt(iice),0.)
+!             qimlt(iice) = min(qimlt(iice),qitot(i,k,iice)*odt)
+             nimlt(iice) = qimlt(iice)*(nitot(i,k,iice)/qitot(i,k,iice))
+          endif
+
+!............................................................
+! calculate wet growth
+
+    ! similar to Musil (1970), JAS
+    ! note 'f1pr' values are normalized, so we need to multiply by N
+
+          if (qitot(i,k,iice).ge.qsmall .and. qc(i,k)+qr(i,k).ge.1.e-6 .and. t(i,k).lt.273.15) then
+
+             qsat0  = 0.622*e0/(pres(i,k)-e0)
+             qwgrth(iice) = ((f1pr05 + f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*       &
+                       2.*pi*(rho(i,k)*xxlv(i,k)*dv*(qsat0-qv(i,k))-(t(i,k)-273.15)*           &
+                       kap)/(xlf(i,k)+cpw*(t(i,k)-273.15)))*nitot(i,k,iice)
+             qwgrth(iice) = max(qwgrth(iice),0.)
+         !calculate shedding for wet growth
+             dum    = max(0.,(qccol(iice)+qrcol(iice))-qwgrth(iice))
+             if (dum.ge.1.e-10) then
+                nrshdr(iice) = nrshdr(iice) + dum*1.923e+6   ! 1/5.2e-7, 5.2e-7 is the mass of a 1 mm raindrop
+                if ((qccol(iice)+qrcol(iice)).ge.1.e-10) then
+                   dum1  = 1./(qccol(iice)+qrcol(iice))
+                   qcshd(iice) = qcshd(iice) + dum*qccol(iice)*dum1
+                   qccol(iice) = qccol(iice) - dum*qccol(iice)*dum1
+                   qrcol(iice) = qrcol(iice) - dum*qrcol(iice)*dum1
+               endif
+             ! densify due to wet growth
+               log_wetgrowth(iice) = .true.
+             endif
+
+          endif
+
+
+!-----------------------------
+! calcualte total inverse ice relaxation timescale combined for all ice categories
+! note 'f1pr' values are normalized, so we need to multiply by N
+          if (qitot(i,k,iice).ge.qsmall .and. t(i,k).lt.273.15) then
+             epsi(iice) = ((f1pr05+f1pr14*sc**thrd*(rhofaci(i,k)*rho(i,k)/mu)**0.5)*2.*pi* &
+                          rho(i,k)*dv)*nitot(i,k,iice)
+             epsi_tot   = epsi_tot + epsi(iice)
+          else
+             epsi(iice) = 0.
+          endif
+
+
+!.........................
+! calculate rime density
+
+!     FUTURE:  Add source term for birim (=qccol/rhorime_c) so that all process rates calculations
+!              are done together, before conservation.
+
+     ! NOTE: Tc (ambient) is assumed for the surface temperature.  Technically,
+     ! we should diagose graupel surface temperature from heat balance equation.
+     ! (but the ambient temperature is a reasonable approximation; tests show
+     ! very little sensitivity to different assumed values, Milbrandt and Morrison 2012).
+
+      ! Compute rime density: (based on parameterization of Cober and List, 1993 [JAS])
+      ! for simplicty use mass-weighted ice and droplet/rain fallspeeds
+
+        ! if (qitot(i,k,iice).ge.qsmall .and. t(i,k).lt.273.15) then
+        !  NOTE:  condition applicable for cloud only; modify when rain is added back
+          if (qccol(iice).ge.qsmall .and. t(i,k).lt.273.15) then
+
+           ! get mass-weighted mean ice fallspeed
+             vtrmi1(i,k) = f1pr02*rhofaci(i,k)
+             iTc   = 1./min(-0.001,t(i,k)-273.15)
+
+          ! cloud:
+             if (qc(i,k).ge.qsmall) then
+              ! droplet fall speed
+              ! (use Stokes' formulation (thus use analytic solution)
+                Vt_qc(i,k) = acn(i,k)*gamma(4.+bcn+mu_c(i,k))/(lamc(i,k)**bcn*gamma(mu_c(i,k)+4.))
+              ! use mass-weighted mean size
+                D_c = (mu_c(i,k)+4.)/lamc(i,k)
+                V_impact  = abs(vtrmi1(i,k)-Vt_qc(i,k))
+                Ri        = -(0.5e+6*D_c)*V_impact*iTc
+!               Ri        = max(1.,min(Ri,8.))
+                Ri        = max(1.,min(Ri,12.))
+                if (Ri.le.8.) then
+                   rhorime_c(iice)  = (0.051 + 0.114*Ri - 0.0055*Ri**2)*1000.
+                else
+                ! for Ri > 8 assume a linear fit between 8 and 12,
+                ! rhorime = 900 kg m-3 at Ri = 12
+                ! this is somewhat ad-hoc but allows a smoother transition
+                ! in rime density up to wet growth
+                   rhorime_c(iice)  = 611.+72.25*(Ri-8.)
+                endif
+
+             endif    !if qc>qsmall
+
+          ! rain:
+            ! assume rime density for rain collecting ice is 900 kg/m3
+!            if (qr(i,k).ge.qsmall) then
+!               D_r = (mu_r(i,k)+1.)/lamr(i,k)
+!               V_impact  = abs(vtrmi1(i,k)-Vt_qr(i,k))
+!               Ri        = -(0.5e+6*D_r)*V_impact*iTc
+!               Ri        = max(1.,min(Ri,8.))
+!               rhorime_r(iice)  = (0.051 + 0.114*Ri - 0.0055*Ri*Ri)*1000.
+!            else
+!               rhorime_r(iice) = 400.
+!            endif
+
+          else
+             rhorime_c(iice) = 400.
+!             rhorime_r(iice) = 400.
+          endif ! qi > qsmall and T < 273.15
+
+    !--------------------
+       enddo iice_loop1
+    !--------------------
+
+!............................................................
+! contact and immersion freezing droplets
+
+! contact freezing currently turned off
+!         dum=7.37*t(i,k)/(288.*10.*pres(i,k))/100.
+!         dap=4.*pi*1.38e-23*t(i,k)*(1.+dum/rin)/ &
+!                (6.*pi*rin*mu)
+!         nacnt=exp(-2.80+0.262*(273.15-t(i,k)))*1000.
+
+       if (qc(i,k).ge.qsmall .and. t(i,k).le.269.15) then
+!         qchetc(iice) = pi*pi/3.*Dap*Nacnt*rhow*cdist1(i,k)*gamma(mu_c(i,k)+5.)/lamc(i,k)**4
+!         nchetc(iice) = 2.*pi*Dap*Nacnt*cdist1(i,k)*gamma(mu_c(i,k)+2.)/lamc(i,k)
+! for future: calculate gamma(mu_c+4) in one place since its used multiple times
+          dum    = (1./lamc(i,k))**3
+!         qcheti(iice_dest) = cons6*cdist1(i,k)*gamma(7.+pgam(i,k))*exp(aimm*(273.15-t(i,k)))*dum**2
+!         ncheti(iice_dest) = cons5*cdist1(i,k)*gamma(pgam(i,k)+4.)*exp(aimm*(273.15-t(i,k)))*dum
+          Q_nuc = cons6*cdist1(i,k)*gamma(7.+mu_c(i,k))*exp(aimm*(273.15-t(i,k)))*dum**2
+          N_nuc = cons5*cdist1(i,k)*gamma(mu_c(i,k)+4.)*exp(aimm*(273.15-t(i,k)))*dum
+         !--determine destination ice-phase category:
+          dum1      = 900.     !density of new ice
+          D_new     = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd
+          call icecat_destination(qitot(i,k,:),diam_ice(i,k,:),D_new,deltaD_init,      &
+                                  log_ni_add,iice_dest)
+         !==
+          qcheti(iice_dest) = Q_nuc
+          if (log_ni_add) ncheti(iice_dest) = N_nuc
+       endif
+
+
+!............................................................
+! immersion freezing of rain
+! for future: get rid of log statements below for rain freezing
+
+       if (qr(i,k).ge.qsmall.and.t(i,k).le.269.15) then
+          Q_nuc = cons6*exp(log(cdistr(i,k))+log(gamma(7.+mu_r(i,k)))-6.*log(lamr(i,k)))* &
+                  exp(aimm*(273.15-T(i,k)))
+          N_nuc = cons5*exp(log(cdistr(i,k))+log(gamma(mu_r(i,k)+4.))-3.*log(lamr(i,k)))* &
+                  exp(aimm*(273.15-T(i,k)))
+         !--determine destination ice-phase category:
+          dum1      = 900.     !density of new ice
+          D_new     = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd
+          call icecat_destination(qitot(i,k,:),diam_ice(i,k,:),D_new,deltaD_init,        &
+                               log_ni_add,iice_dest)
+         !==
+          qrheti(iice_dest) = Q_nuc
+          if (log_ni_add) nrheti(iice_dest) = N_nuc
+       endif
+
+
+!......................................
+! rime splintering (Hallet-Mossop 1974)
+
+       rimesplintering_on:  if (log_hmossopOn) then
+
+        ! determine destination ice-phase category
+          D_new = 10.e-6 !assumes ice crystals from rime splintering are tiny
+          call icecat_destination(qitot(i,k,:),diam_ice(i,k,:),D_new,deltaD_init,        &
+                                  log_ni_add,iice_dest)
+
+          iice_loop_HM:  do iice = 1,nCat
+
+             if (qitot(i,k,iice).ge.qsmall.and. (qccol(iice).gt.0. .or.                  &
+              qrcol(iice).gt.0.)) then
+
+                if (t(i,k).gt.270.15) then
+                   dum = 0.
+                elseif (t(i,k).le.270.15 .and. t(i,k).gt.268.15) then
+                   dum = (270.15-t(i,k))*0.5
+                elseif (t(i,k).le.268.15 .and. t(i,k).ge.265.15) then
+                   dum = (t(i,k)-265.15)*thrd
+                elseif (t(i,k).lt.265.15) then
+                   dum = 0.
+                endif
+
+                !rime splintering from riming of cloud droplets
+!                dum1 = 35.e+4*qccol(iice)*dum*1000. ! 1000 is to convert kg to g
+!                dum2 = dum1*piov6*900.*(10.e-6)**3  ! assume 10 micron splinters
+!                qccol(iice) = qccol(iice)-dum2 ! subtract splintering from rime mass transfer
+!                if (qccol(iice) .lt. 0.) then
+!                   dum2 = qccol(iice)
+!                   qccol(iice) = 0.
+!                endif
+!                qcmul(iice_dest) = qcmul(iice_dest)+dum2
+!                if (log_ni_add) then
+!                nimul(iice_dest) = nimul(iice_dest)+dum2/(piov6*900.*(10.e-6)**3)
+!                end if
+
+               !rime splintering from riming of raindrops
+                dum1 = 35.e+4*qrcol(iice)*dum*1000. ! 1000 is to convert kg to g
+                dum2 = dum1*piov6*900.*(10.e-6)**3  ! assume 10 micron splinters
+                qrcol(iice) = qrcol(iice)-dum2      ! subtract splintering from rime mass transfer
+                if (qrcol(iice) .lt. 0.) then
+                   dum2 = qrcol(iice)
+                   qrcol(iice) = 0.
+                endif
+
+                qrmul(iice_dest) = qrmul(iice_dest) + dum2
+                if (log_ni_add) nimul(iice_dest) = nimul(iice_dest) + dum2/(piov6*900.*(10.e-6)**3)
+
+             endif
+
+          enddo iice_loop_HM
+
+       endif rimesplintering_on
+
+
+!................................................
+! condensation/evaporation/deposition/sublimation
+!   (use semi-analytic formulation)
+
+     ! calculate rain evaporation including ventilation
+       if (qr(i,k).ge.qsmall) then
+          call find_lookupTable_indices_3(dumii,dumjj,dum1,rdumii,rdumjj,inv_dum3,mu_r(i,k),lamr(i,k))
+         !interpolate value at mu_r
+          dum1 = revap_table(dumii,dumjj)+(rdumii-real(dumii))*inv_dum3*                   &
+                 (revap_table(dumii+1,dumjj)-revap_table(dumii,dumjj))
+         !interoplate value at mu_r+1
+          dum2 = revap_table(dumii,dumjj+1)+(rdumii-real(dumii))*inv_dum3*                 &
+                 (revap_table(dumii+1,dumjj+1)-revap_table(dumii,dumjj+1))
+         !final interpolation
+          dum  = dum1+(rdumjj-real(dumjj))*(dum2-dum1)
+
+          epsr = 2.*pi*cdistr(i,k)*rho(i,k)*dv*(f1r*gamma(mu_r(i,k)+2.)/(lamr(i,k))+f2r*   &
+                 (rho(i,k)/mu)**0.5*sc**thrd*dum)
+       else
+          epsr = 0.
+       endif
+
+       if (qc(i,k).ge.qsmall) then
+          epsc = 2.*pi*rho(i,k)*dv*cdist(i,k)
+       else
+          epsc = 0.
+       endif
+   !===
+
+       if (t(i,k).lt.273.15) then
+          oabi = 1./abi
+          xx   = epsc + epsr + epsi_tot*(1.+xxls(i,k)*inv_cp*dqsdt)*oabi
+       else
+          xx   = epsc + epsr
+       endif
+
+       dumqvi = qvi(i,k)   !no modification due to latent heating
+!----
+! !      ! modify due to latent heating from riming rate
+! !      !   - currently this is done by simple linear interpolation
+! !      !     between conditions for dry and wet growth --> in wet growth it is assumed
+! !      !     that particle surface temperature is at 0 C and saturation vapor pressure
+! !      !     is that with respect to liquid. This simple treatment could be improved in the future.
+! !        if (qwgrth(iice).ge.1.e-20) then
+! !           dum = (qccol(iice)+qrcol(iice))/qwgrth(iice)
+! !        else
+! !           dum = 0.
+! !        endif
+! !        dumqvi = qvi(i,k) + dum*(qvs(i,k)-qvi(i,k))
+! !        dumqvi = min(qvs(i,k),dumqvi)
+!====
+
+
+! 'A' term including ice (Bergeron process)
+! note: qv and T tendencies due to mixing and radiation are
+! currently neglected --> assumed to be much smaller than cooling
+! due to vertical motion which IS included
+
+! set equivalent vertical velocity consistent with dT/dt
+! since -g/cp*dum = dT/dt therefore dum = -cp/g*dT/dt
+! note this formulation for dT/dt is not exact since pressure
+! may change and t and t_old were both diagnosed using the current pressure
+! errors from this assumption are small
+       dum = -cp/g*(t(i,k)-t_old(i,k))/dt
+
+!       dum = qvs(i,k)*rho(i,k)*g*uzpl(i,k)/max(1.e-3,(pres(i,k)-polysvp1(t(i,k),0)))
+
+       if (t(i,k).lt.273.15) then
+          aaa = (qv(i,k)-qv_old(i,k))/dt - dqsdt*(-dum*g*inv_cp)-(qvs(i,k)-dumqvi)*(1.+xxls(i,k)*      &
+                inv_cp*dqsdt)*oabi*epsi_tot
+       else
+          aaa = (qv(i,k)-qv_old(i,k))/dt - dqsdt*(-dum*g*inv_cp)
+       endif
+
+       xx  = max(1.e-20,xx)   ! set lower bound on xx to prevent division by zero
+       oxx = 1./xx
+
+       if (qc(i,k).ge.qsmall) &
+          qccon = (aaa*epsc*oxx+(ssat(i,k)-aaa*oxx)*odt*epsc*oxx*(1.-dexp(-dble(xx*dt))))/ab
+       if (qr(i,k).ge.qsmall) &
+          qrcon = (aaa*epsr*oxx+(ssat(i,k)-aaa*oxx)*odt*epsr*oxx*(1.-dexp(-dble(xx*dt))))/ab
+
+     !for very small water contents, evaporate instantly
+       if (sup(i,k).lt.-0.001 .and. qc(i,k).lt.1.e-12)  qccon = -qc(i,k)*odt
+       if (sup(i,k).lt.-0.001 .and. qr(i,k).lt.1.e-12)  qrcon = -qr(i,k)*odt
+
+       if (qccon.lt.0.) then
+          qcevp = -qccon
+!          qcevp = min(qcevp,qc(i,k)*odt)
+          qccon = 0.
+       endif
+
+       if (qrcon.lt.0.) then
+          qrevp = -qrcon
+!          qrevp = min(qrevp,qr(i,k)*odt)
+          nrevp = qrevp*(nr(i,k)/qr(i,k))
+         !nrevp = nrevp*exp(-0.2*mu_r(i,k))  !add mu dependence [Seifert (2008), neglecting size dependence]
+          qrcon = 0.
+       endif
+
+      !limit total condensation/evaporation to saturation adjustment
+!       dumt   = th(i,k)*(pres(i,k)*1.e-5)**(rd*inv_cp)
+       dumqvs = qv_sat(t(i,k),pres(i,k),0)
+       qcon_satadj  = (qv(i,k)-dumqvs)/(1.+xxlv(i,k)**2*dumqvs/(cp*rv*t(i,k)**2))*odt
+       if (qccon+qrcon.gt.0.) then
+          ratio = max(0.,qcon_satadj)/(qccon+qrcon)
+          ratio = min(1.,ratio)
+          qccon = qccon*ratio
+          qrcon = qrcon*ratio
+       elseif (qcevp+qrevp.gt.0.) then
+          ratio = max(0.,-qcon_satadj)/(qcevp+qrevp)
+          ratio = min(1.,ratio)
+          qcevp = qcevp*ratio
+          qrevp = qrevp*ratio
+       endif
+
+       iice_loop_depsub:  do iice = 1,nCat
+
+          if (qitot(i,k,iice).ge.qsmall.and.t(i,k).lt.273.15) then
+             qidep(iice) = (aaa*epsi(iice)*oxx+(ssat(i,k)-aaa*oxx)*odt*epsi(iice)*oxx*   &
+                           (1.-dexp(-dble(xx*dt))))*oabi+(qvs(i,k)-dumqvi)*epsi(iice)*oabi
+          endif
+
+         !for very small ice contents in dry air, sublimate all ice instantly
+          if (supi(i,k).lt.-0.001 .and. qitot(i,k,iice).lt.1.e-12) &
+             qidep(iice) = -qitot(i,k,iice)*odt
+
+          if (qidep(iice).lt.0.) then
+           !note: limit to saturation adjustment (for dep and subl) is applied later
+             qisub(iice) = -qidep(iice)
+             qisub(iice) = qisub(iice)*clbfact_sub
+             qisub(iice) = min(qisub(iice), qitot(i,k,iice)*dt)
+             nisub(iice) = qisub(iice)*(nitot(i,k,iice)/qitot(i,k,iice))
+             qidep(iice) = 0.
+          else
+             qidep(iice) = qidep(iice)*clbfact_dep
+          endif
+
+       enddo iice_loop_depsub
+
+444   continue
+
+
+!................................................................
+! deposition/condensation-freezing nucleation
+! allow ice nucleation if < -15 C and > 5% ice supersaturation
+
+      if (t(i,k).lt.258.15 .and. supi(i,k).ge.0.05) then
+
+!        dum = exp(-0.639+0.1296*100.*supi(i,k))*1000.*inv_rho(i,k)  !Meyers et al. (1992)
+         dum = 0.005*exp(0.304*(273.15-t(i,k)))*1000.*inv_rho(i,k)   !Cooper (1986)
+         dum = min(dum,100.e3*inv_rho(i,k))
+         N_nuc = max(0.,(dum-sum(nitot(i,k,:)))*odt)
+
+         if (N_nuc.ge.1.e-20) then
+            Q_nuc = max(0.,(dum-sum(nitot(i,k,:)))*mi0*odt)
+            !--determine destination ice-phase category:
+            dum1      = 900.     !density of new ice
+            D_new     = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd
+            call icecat_destination(qitot(i,k,:),diam_ice(i,k,:),D_new,deltaD_init,    &
+                                    log_ni_add,iice_dest)
+            !==
+            qinuc(iice_dest) = Q_nuc
+            if (log_ni_add) ninuc(iice_dest) = N_nuc
+         endif
+
+      endif
+
+
+!.................................................................
+! droplet activation
+
+! for specified Nc, make sure droplets are present if conditions are supersaturated
+! note that this is also applied at the first time step
+! this is not applied at the first time step, since saturation adjustment is applied at the first step
+
+          if (.not.(log_predictNc).and.sup(i,k).gt.1.e-6.and.it.gt.1) then
+             dum   = nccnst*inv_rho(i,k)*cons7-qc(i,k)
+             dum   = max(0.,dum)
+             dumqvs = qv_sat(t(i,k),pres(i,k),0)
+             dqsdt = xxlv(i,k)*dumqvs/(rv*t(i,k)*t(i,k))
+             ab    = 1. + dqsdt*xxlv(i,k)*inv_cp
+             dum   = min(dum,(qv(i,k)-dumqvs)/ab)  ! limit overdepletion of supersaturation
+             qcnuc = dum*odt
+          endif
+
+          if (log_predictNc) then
+
+! for predicted Nc, calculate activation explicitly from supersaturation
+! note that this is also applied at the first time step
+! note that this is also applied at the first time step
+
+             if (sup(i,k).gt.1.e-6) then
+                dum1  = 1./bact**0.5
+                sigvl = 0.0761 - 1.55e-4*(t(i,k)-273.15)
+                aact  = 2.*mw/(rhow*rr*t(i,k))*sigvl
+                sm1   = 2.*dum1*(aact*thrd*inv_rm1)**1.5
+                sm2   = 2.*dum1*(aact*thrd*inv_rm2)**1.5
+                uu1   = 2.*log(sm1/sup(i,k))/(4.242*log(sig1))
+                uu2   = 2.*log(sm2/sup(i,k))/(4.242*log(sig2))
+                dum1  = nanew1*0.5*(1.-derf(uu1)) ! activated number in kg-1 mode 1
+                dum2  = nanew2*0.5*(1.-derf(uu2)) ! activated number in kg-1 mode 2
+              ! make sure this value is not greater than total number of aerosol
+                dum2  = min((nanew1+nanew2),dum1+dum2)
+                dum2  = (dum2-nc(i,k))*odt
+                dum2  = max(0.,dum2)
+                ncnuc = dum2
+              ! don't include mass increase from droplet activation during first time step
+              ! since this is already accounted for by saturation adjustment below
+                if (it.eq.1) then
+                   qcnuc = 0.
+                else
+                   qcnuc = ncnuc*cons7
+                endif
+             endif
+
+          endif
+
+!................................................................
+! saturation adjustment to get initial cloud water
+
+! This is only called once at the beginning of the simulation
+! to remove any supersaturation in the intial conditions
+
+       if (it.eq.1) then
+          dumt   = th(i,k)*(pres(i,k)*1.e-5)**(rd*inv_cp)
+          dumqv  = qv(i,k)
+          dumqvs = qv_sat(dumt,pres(i,k),0)
+          dums   = dumqv-dumqvs
+          qccon  = dums/(1.+xxlv(i,k)**2*dumqvs/(cp*rv*dumt**2))*odt
+          qccon  = max(0.,qccon)
+          if (qccon.le.1.e-7) qccon = 0.
+       endif
+
+!................
+! autoconversion
+
+       qc_not_small: if (qc(i,k).ge.1.e-8) then
+
+          if (iparam.eq.1) then
+
+            !Seifert and Beheng (2001)
+             dum   = 1.-qc(i,k)/(qc(i,k)+qr(i,k))
+             dum1  = 600.*dum**0.68*(1.-dum**0.68)**3
+           ! qcaut = kc/(20.*2.6e-7)*(nu(i,k)+2.)*(nu(i,k)+4.)/(nu(i,k)+1.)**2*         &
+           !         (rho(i,k)*qc(i,k)/1000.)**4/(rho(i,k)*nc(i,k)/1.e+6)**2*(1.+       &
+           !         dum1/(1.-dum)**2)*1000.*inv_rho(i,k)
+           ! ncautc = qcaut*2./2.6e-7*1000.
+             qcaut =  kc*1.9230769e-5*(nu(i,k)+2.)*(nu(i,k)+4.)/(nu(i,k)+1.)**2*        &
+                      (rho(i,k)*qc(i,k)*1.e-3)**4/(rho(i,k)*nc(i,k)*1.e-6)**2*(1.+      &
+                      dum1/(1.-dum)**2)*1000.*inv_rho(i,k)
+             ncautc = qcaut*7.6923076e+9
+
+          elseif (iparam.eq.2) then
+
+            !Beheng (1994)
+             if (nc(i,k)*rho(i,k)*1.e-6 .lt. 100.) then
+                qcaut = 6.e+28*inv_rho(i,k)*mu_c(i,k)**(-1.7)*(1.e-6*rho(i,k)*          &
+                        nc(i,k))**(-3.3)*(1.e-3*rho(i,k)*qc(i,k))**4.7
+             else
+               !2D interpolation of tabled logarithmic values
+                dum   = 41.46 + (nc(i,k)*1.e-6*rho(i,k)-100.)*(37.53-41.46)*5.e-3
+                dum1  = 39.36 + (nc(i,k)*1.e-6*rho(i,k)-100.)*(30.72-39.36)*5.e-3
+                qcaut = dum+(mu_c(i,k)-5.)*(dum1-dum)*0.1
+              ! 1000/rho is for conversion from g cm-3/s to kg/kg
+                qcaut = exp(qcaut)*(1.e-3*rho(i,k)*qc(i,k))**4.7*1000.*inv_rho(i,k)
+             endif
+             ncautc = 7.7e+9*qcaut
+
+          elseif (iparam.eq.3) then
+
+           !Khroutdinov and Kogan (2000)
+             dum   = qc(i,k)
+             qcaut = 1350.*dum**2.47*(nc(i,k)*1.e-6*rho(i,k))**(-1.79)
+            ! note: ncautr is change in Nr; ncautc is change in Nc
+             ncautr = qcaut*cons3
+             ncautc = qcaut*nc(i,k)/qc(i,k)
+
+          endif
+
+          if (qcaut .eq.0.) ncautc = 0.
+          if (ncautc.eq.0.) qcaut  = 0.
+!          qcaut = min(qcaut, qc(i,k)*odt)
+
+       endif qc_not_small
+
+!............................
+! self-collection of droplets
+
+       if (qc(i,k).ge.qsmall) then
+
+          if (iparam.eq.1) then
+           !Seifert and Beheng (2001)
+             ncslf = -kc*(1.e-3*rho(i,k)*qc(i,k))**2*(nu(i,k)+2.)/(nu(i,k)+1.)*         &
+                     1.e+6*inv_rho(i,k)+ncautc
+          elseif (iparam.eq.2) then
+           !Beheng (994)
+             ncslf = -5.5e+16*inv_rho(i,k)*mu_c(i,k)**(-0.63)*(1.e-3*rho(i,k)*qc(i,k))**2
+          elseif (iparam.eq.3) then
+            !Khroutdinov and Kogan (2000)
+             ncslf = 0.
+          endif
+
+       endif
+
+!............................
+! accretion of cloud by rain
+
+       if (qr(i,k).ge.qsmall .and. qc(i,k).ge.qsmall) then
+
+          if (iparam.eq.1) then
+           !Seifert and Beheng (2001)
+             dum   = 1.-qc(i,k)/(qc(i,k)+qr(i,k))
+             dum1  = (dum/(dum+5.e-4))**4
+             qcacc = kr*rho(i,k)*0.001*qc(i,k)*qr(i,k)*dum1
+             ncacc = qcacc*rho(i,k)*0.001*(nc(i,k)*rho(i,k)*1.e-6)/(qc(i,k)*rho(i,k)*   &
+                     0.001)*1.e+6*inv_rho(i,k)
+          elseif (iparam.eq.2) then
+           !Beheng (994)
+             qcacc = 6.*rho(i,k)*(qc(i,k)*qr(i,k))
+             ncacc = qcacc*rho(i,k)*1.e-3*(nc(i,k)*rho(i,k)*1.e-6)/(qc(i,k)*rho(i,k)*1.e-3)* &
+                     1.e+6*inv_rho(i,k)
+          elseif (iparam.eq.3) then
+            !Khroutdinov and Kogan (2000)
+             qcacc = 67.*(qc(i,k)*qr(i,k))**1.15
+             ncacc = qcacc*nc(i,k)/qc(i,k)
+          endif
+
+          if (qcacc.eq.0.) ncacc = 0.
+          if (ncacc.eq.0.) qcacc = 0.
+!          qcacc = min(qcacc, qc(i,k)*odt)
+
+       endif
+
+!.....................................
+! self-collection and breakup of rain
+! (breakup following modified Verlinde and Cotton scheme)
+
+       if (qr(i,k).ge.qsmall) then
+
+        ! include breakup
+          dum1 = 280.e-6
+
+        ! use mass-mean diameter (do this by using
+        ! the old version of lambda w/o mu dependence)
+        ! note there should be a factor of 6^(1/3), but we
+        ! want to keep breakup threshold consistent so 'dum'
+        ! is expressed in terms of lambda rather than mass-mean D
+
+          dum2 = (qr(i,k)/(pi*rhow*nr(i,k)))**thrd
+          if (dum2.lt.dum1) then
+             dum = 1.
+          else if (dum2.ge.dum1) then
+             dum = 2.-exp(2300.*(dum2-dum1))
+          endif
+
+          if (iparam.eq.1.) then
+             nrslf = dum*kr*1.e-3*qr(i,k)*nr(i,k)*rho(i,k)
+          elseif (iparam.eq.2 .or. iparam.eq.3) then
+             nrslf = dum*5.78*nr(i,k)*qr(i,k)*rho(i,k)
+          endif
+
+       endif
+
+
+!.................................................................
+! conservation of water
+!.................................................................
+
+! The microphysical process rates are computed above, based on the environmental conditions.
+! The rates are adjusted here (where necessary) such that the sum of the sinks of mass cannot
+! be greater than the sum of the sources, thereby resulting in overdepletion.
+
+   !-- Limit ice process rates to prevent overdepletion of sources such that
+   !   the subsequent adjustments are done with maximum possible rates for the
+   !   time step.  (note: the same is done for all other process rates immediately
+   !   after calculations; most ice rates are adjusted here since they must be done
+   !   simultaneously (outside of iice-loops) to distribute reduction proportionally
+   !   amongst categories.
+
+       dumqvi = qv_sat(t(i,k),pres(i,k),1)
+       qdep_satadj = (qv(i,k)-dumqvi)/(1.+xxls(i,k)**2*dumqvi/(cp*rv*t(i,k)**2))*odt
+       qidep  = qidep*min(1.,max(0., qdep_satadj)/max(sum(qidep), 1.e-20))
+       qisub  = qisub*min(1.,max(0.,-qdep_satadj)/max(sum(qisub), 1.e-20))
+      !qchetc = qchetc*min(1.,qc(i,k)*odt/max(sum(qchetc),1.e-20))  !currently not used
+      !qrhetc = qrhetc*min(1.,qr(i,k)*odt/max(sum(qrhetc),1.e-20))  !currently not used
+   !==
+
+! vapor -- not needed, since all sinks already have limits imposed and the sum, therefore,
+!          cannot possibly overdeplete qv
+
+! cloud
+       sinks   = (qcaut+qcacc+sum(qccol)+qcevp+sum(qchetc)+sum(qcheti)+sum(qcshd))*dt
+       sources = qc(i,k) + (qccon+qcnuc)*dt
+       if (sinks.gt.sources .and. sinks.ge.1.e-20) then
+          ratio  = sources/sinks
+          qcaut  = qcaut*ratio
+          qcacc  = qcacc*ratio
+          qcevp  = qcevp*ratio
+          qccol  = qccol*ratio
+          qcheti = qcheti*ratio
+          qcshd  = qcshd*ratio
+         !qchetc = qchetc*ratio
+       endif
+
+! rain
+       sinks   = (qrevp+sum(qrcol)+sum(qrhetc)+sum(qrheti)+sum(qrmul))*dt
+       sources = qr(i,k) + (qrcon+qcaut+qcacc+sum(qimlt)+sum(qcshd))*dt
+       if (sinks.gt.sources .and. sinks.ge.1.e-20) then
+          ratio  = sources/sinks
+          qrevp  = qrevp*ratio
+          qrcol  = qrcol*ratio
+          qrheti = qrheti*ratio
+          qrmul  = qrmul*ratio
+         !qrhetc = qrhetc*ratio
+       endif
+
+! ice
+       do iice = 1,nCat
+          sinks   = (qisub(iice)+qimlt(iice))*dt
+          sources = qitot(i,k,iice) + (qidep(iice)+qinuc(iice)+qrcol(iice)+qccol(iice)+  &
+                    qrhetc(iice)+qrheti(iice)+qchetc(iice)+qcheti(iice)+qrmul(iice))*dt
+          do catcoll = 1,nCat
+            !category interaction leading to source for iice category
+             sources = sources + qicol(catcoll,iice)*dt
+            !category interaction leading to sink for iice category
+             sinks = sinks + qicol(iice,catcoll)*dt
+          enddo
+          if (sinks.gt.sources .and. sinks.ge.1.e-20) then
+             ratio = sources/sinks
+             qisub(iice) = qisub(iice)*ratio
+             qimlt(iice) = qimlt(iice)*ratio
+             do catcoll = 1,nCat
+                qicol(iice,catcoll) = qicol(iice,catcoll)*ratio
+             enddo
+          endif
+      enddo  !iice-loop
+
+
+!---------------------------------------------------------------------------------
+! update prognostic microphysics and thermodynamics variables
+!---------------------------------------------------------------------------------
+
+   !-- ice-phase dependent processes:
+       iice_loop2: do iice = 1,nCat
+
+          qc(i,k) = qc(i,k) + (-qchetc(iice)-qcheti(iice)-qccol(iice)-qcshd(iice))*dt
+          if (log_predictNc) then
+             nc(i,k) = nc(i,k) + (-nccol(iice)-nchetc(iice)-ncheti(iice))*dt
+          endif
+
+          qr(i,k) = qr(i,k) + (-qrcol(iice)+qimlt(iice)-qrhetc(iice)-qrheti(iice)+            &
+                    qcshd(iice)-qrmul(iice))*dt
+        ! apply factor to source for rain number from melting of ice, (ad-hoc
+        ! but accounts for rapid evaporation of small melting ice particles)
+          nr(i,k) = nr(i,k) + (-nrcol(iice)-nrhetc(iice)-nrheti(iice)+nmltratio*nimlt(iice)+  &
+                    nrshdr(iice)+ncshdc(iice))*dt
+
+          if (qitot(i,k,iice).ge.qsmall) then
+         ! add sink terms, assume density stays constant for sink terms
+             birim(i,k,iice) = birim(i,k,iice) - ((qisub(iice)+qimlt(iice))/qitot(i,k,iice))* &
+                               dt*birim(i,k,iice)
+             qirim(i,k,iice) = qirim(i,k,iice) - ((qisub(iice)+qimlt(iice))*qirim(i,k,iice)/  &
+                               qitot(i,k,iice))*dt
+             qitot(i,k,iice) = qitot(i,k,iice) - (qisub(iice)+qimlt(iice))*dt
+          endif
+
+          dum             = (qrcol(iice)+qccol(iice)+qrhetc(iice)+qrheti(iice)+          &
+                            qchetc(iice)+qcheti(iice)+qrmul(iice))*dt
+          qitot(i,k,iice) = qitot(i,k,iice) + (qidep(iice)+qinuc(iice))*dt + dum
+          qirim(i,k,iice) = qirim(i,k,iice) + dum
+          birim(i,k,iice) = birim(i,k,iice) + (qrcol(iice)*inv_rho_rimeMax+qccol(iice)/  &
+                            rhorime_c(iice)+(qrhetc(iice)+qrheti(iice)+qchetc(iice)+     &
+                            qcheti(iice)+qrmul(iice))*inv_rho_rimeMax)*dt
+          nitot(i,k,iice) = nitot(i,k,iice) + (ninuc(iice)-nimlt(iice)-nisub(iice)-      &
+                            nislf(iice)+nrhetc(iice)+nrheti(iice)+nchetc(iice)+          &
+                            ncheti(iice)+nimul(iice))*dt
+
+          interactions_loop: do catcoll = 1,nCat
+        ! add ice-ice category interaction collection tendencies
+        ! note: nicol is a sink for the collectee category, but NOT a source for collector
+
+             qitot(i,k,catcoll) = qitot(i,k,catcoll) - qicol(catcoll,iice)*dt
+             nitot(i,k,catcoll) = nitot(i,k,catcoll) - nicol(catcoll,iice)*dt
+             qitot(i,k,iice)    = qitot(i,k,iice)    + qicol(catcoll,iice)*dt
+             ! now modify rime mass and density, assume collection does not modify rime mass
+             ! fraction or density of the collectee, consistent with the assumption that
+             ! these are constant over the PSD
+             if (qitot(i,k,catcoll).ge.qsmall) then
+              !source for collector category
+                qirim(i,k,iice) = qirim(i,k,iice)+qicol(catcoll,iice)*dt*                &
+                                  qirim(i,k,catcoll)/qitot(i,k,catcoll)
+                birim(i,k,iice) = birim(i,k,iice)+qicol(catcoll,iice)*dt*                &
+                                  birim(i,k,catcoll)/qitot(i,k,catcoll)
+              !sink for collectee category
+                qirim(i,k,catcoll) = qirim(i,k,catcoll)-qicol(catcoll,iice)*dt*          &
+                                     qirim(i,k,catcoll)/qitot(i,k,catcoll)
+                birim(i,k,catcoll) = birim(i,k,catcoll)-qicol(catcoll,iice)*dt*          &
+                                     birim(i,k,catcoll)/qitot(i,k,catcoll)
+             endif
+
+          enddo interactions_loop ! catcoll loop
+
+
+          if (qirim(i,k,iice).lt.0.) then
+             qirim(i,k,iice) = 0.
+             birim(i,k,iice) = 0.
+          endif
+
+        ! densify under wet growth
+        ! -- to be removed post-v2.1.  Densification automatically happens
+        !    during wet growth due to parameterized rime density --
+          if (log_wetgrowth(iice)) then
+             qirim(i,k,iice) = qitot(i,k,iice)
+             birim(i,k,iice) = qirim(i,k,iice)*inv_rho_rimeMax
+          endif
+
+        ! densify in above freezing conditions and melting
+        ! -- future work --
+        !   Ideally, this will be treated with the predicted liquid fraction in ice.
+        !   Alternatively, it can be simplified by tending qirim -- qitot
+        !   and birim such that rho_rim (qirim/birim) --> rho_liq during melting.
+        ! ==
+
+          qv(i,k) = qv(i,k) + (-qidep(iice)+qisub(iice)-qinuc(iice))*dt
+
+          th(i,k) = th(i,k) + th(i,k)/t(i,k)*((qidep(iice)-qisub(iice)+qinuc(iice))*     &
+                              xxls(i,k)*inv_cp +(qrcol(iice)+qccol(iice)+qchetc(iice)+   &
+                              qcheti(iice)+qrhetc(iice)+qrheti(iice)-qimlt(iice))*       &
+                              xlf(i,k)*inv_cp)*dt
+
+       enddo iice_loop2
+   !==
+
+   !-- warm-phase only processes:
+       qc(i,k) = qc(i,k) + (-qcacc-qcaut+qcnuc+qccon-qcevp)*dt
+       qr(i,k) = qr(i,k) + (qcacc+qcaut+qrcon-qrevp)*dt
+
+       if (log_predictNc) then
+          nc(i,k) = nc(i,k) + (-ncacc-ncautc+ncslf+ncnuc)*dt
+       else
+          nc(i,k) = nccnst*inv_rho(i,k)
+       endif
+       if (iparam.eq.1 .or. iparam.eq.2) then
+          nr(i,k) = nr(i,k) + (0.5*ncautc-nrslf-nrevp)*dt
+       else
+          nr(i,k) = nr(i,k) + (ncautr-nrslf-nrevp)*dt
+       endif
+
+       qv(i,k) = qv(i,k) + (-qcnuc-qccon-qrcon+qcevp+qrevp)*dt
+       th(i,k) = th(i,k) + th(i,k)/t(i,k)*((qcnuc+qccon+qrcon-qcevp-qrevp)*xxlv(i,k)*    &
+                 inv_cp)*dt
+   !==
+
+     ! clipping for small hydrometeor values
+       if (qc(i,k).lt.qsmall) then
+          qv(i,k) = qv(i,k) + qc(i,k)
+          th(i,k) = th(i,k) - th(i,k)/t(i,k)*qc(i,k)*xxlv(i,k)*inv_cp
+          qc(i,k) = 0.
+          nc(i,k) = 0.
+       else
+          log_hydrometeorsPresent = .true.
+       endif
+
+       if (qr(i,k).lt.qsmall) then
+          qv(i,k) = qv(i,k) + qr(i,k)
+          th(i,k) = th(i,k) - th(i,k)/t(i,k)*qr(i,k)*xxlv(i,k)*inv_cp
+          qr(i,k) = 0.
+          nr(i,k) = 0.
+       else
+          log_hydrometeorsPresent = .true.
+       endif
+
+       do iice = 1,nCat
+          if (qitot(i,k,iice).lt.qsmall) then
+             qv(i,k) = qv(i,k) + qitot(i,k,iice)
+             th(i,k) = th(i,k) - th(i,k)/t(i,k)*qitot(i,k,iice)*xxls(i,k)*inv_cp
+             qitot(i,k,iice) = 0.
+             nitot(i,k,iice) = 0.
+             qirim(i,k,iice) = 0.
+             birim(i,k,iice) = 0.
+          else
+             log_hydrometeorsPresent = .true.
+          endif
+       enddo !iice-loop
+
+       call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k))
+
+!---------------------------------------------------------------------------------
+
+555    continue
+
+    enddo k_loop_main
+
+    if (debug_ON) then
+       tmparr1(i,:) = th(i,:)*(pres(i,:)*1.e-5)**(rd*inv_cp)
+       call check_values(qv,tmparr1,qc,qr,nr,qitot,qirim,nitot,birim,i,it,.true.,debug_ABORT,300)
+    endif
+
+    if (.not. log_hydrometeorsPresent) goto 333
+
+!------------------------------------------------------------------------------------------!
+! End of main microphysical processes section
+!==========================================================================================!
+
+
+!==========================================================================================!
+! Sedimentation:
+
+!------------------------------------------------------------------------------------------!
+! Cloud sedimentation:
+
+! initialize logicals for presence of hydrometeor species to .false.
+    log_qcpresent = .false.
+
+    do k = ktop,kbot,-kdir
+
+       inv_dzq(i,k) = 1./dzq(i,k)
+
+! calculate Q- and N-weighted fallspeeds and find highest k level that hydrometeor is present
+
+       call get_cloud_dsd(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu,lamc(i,k), &
+                          lammin,lammax,k,tmp1,tmp2,qcindex,log_qcpresent)
+
+! droplet fall speed
+! all droplets in smallest category fallspeed; thus, analytic solution can be used
+
+       if (qc(i,k).ge.qsmall) then
+          dum = 1./lamc(i,k)**bcn
+          if (log_predictNc) then
+             Vt_nc(i,k) =  acn(i,k)*gamma(1.+bcn+mu_c(i,k))*dum/(gamma(mu_c(i,k)+1.))
+          endif
+          Vt_qc(i,k) = acn(i,k)*gamma(4.+bcn+mu_c(i,k))*dum/(gamma(mu_c(i,k)+4.))
+       else
+          if (log_predictNc) then
+             Vt_nc(i,k) = 0.
+          endif
+          Vt_qc(i,k) = 0.
+       endif
+
+    enddo ! k-loop
+
+    if (log_qcpresent) then
+
+! sedimentation of mass
+
+       nstep = 1
+       do k = qcindex+kdir,kbot,-kdir
+
+         !- weighted fall speed arrays used for sedimentation calculations
+         !  (assigned below to highest non-zero level value at lower levels with Vt_x=0)
+          V_qc(K)  = Vt_qc(i,k)
+
+          if (kdir.eq.1) then
+             if (k.le.qcindex-kdir) then
+                if (V_qc(k).lt.1.E-10) then
+                   V_qc(k) = V_qc(k+kdir)
+                endif
+             endif
+          elseif (kdir.eq.-1) then
+             if (k.ge.qcindex-kdir) then
+                if (V_qc(k).lt.1.e-10) then
+                   V_qc(k) = V_qc(k+kdir)
+                endif
+             endif
+          endif
+
+! calculate number of split time steps
+          rgvm       = V_qc(k)
+          nstep      = max(int(rgvm*dt*inv_dzq(i,k)+1.),nstep)
+          dum_qc(k)  = qc(i,k)*rho(i,k)
+          tend_qc(K) = 0.
+
+       enddo ! k-loop
+
+       inv_nstep = 1./real(nstep)
+
+       if (nstep.ge.100) then
+          print*,'CLOUD nstep LARGE:',i,nstep
+          stop
+       endif
+
+! calculate sedimentation using first-order upwind method
+       tmp1 = 0.
+       do n = 1,nstep
+
+          do k = kbot,qcindex,kdir
+             flux_qc(k) = V_qc(k)*dum_qc(k)
+          enddo
+          tmp1 = tmp1 + flux_qc(kbot)  !sum flux_ at lowest level for averaging over sub-stepping
+
+! top level with hydrometeor present
+          k = qcindex
+          fluxdiv_qc = flux_qc(k)*inv_dzq(i,k)
+          tend_qc(k) = tend_qc(k)-fluxdiv_qc*inv_nstep*inv_rho(i,k)
+          dum_qc(k)  = dum_qc(k)-fluxdiv_qc*dt*inv_nstep
+
+! loop from sceond to top level of hydrometeor to surface
+          do k = qcindex-kdir,kbot,-kdir
+             fluxdiv_qc = (flux_qc(k+kdir)-flux_qc(K))*inv_dzq(i,k)
+             tend_qc(k) = tend_qc(k)+fluxdiv_qc*inv_nstep*inv_rho(i,k)
+             dum_qc(k)  = dum_qc(k)+fluxdiv_qc*dt*inv_nstep
+          enddo ! k loop
+
+       enddo ! nstep-loop
+
+       do k = kbot,qcindex,kdir
+          qc(i,k) = qc(i,k)+tend_qc(k)*dt
+       enddo
+
+! compute cloud contribution to liquid precipitation rate at surface
+       tmp1 = tmp1*inv_nstep           !flux_ at surface, averaged over sub-step
+       pcprt_liq(i) = tmp1*inv_rhow    !convert flux_ (kg m-2 s-1) to pcp rate (m s-1)
+
+!.......................................................................................
+! sedimentation of number
+
+       if (log_predictNc) then
+
+       nstep = 1
+       do k = qcindex+kdir,kbot,-kdir
+
+         !- weighted fall speed arrays used for sedimentation calculations
+         !  (assigned below to highest non-zero level value at lower levels with Vt_x=0)
+          V_nc(K) = Vt_nc(i,k)
+
+          if (kdir.eq.1) then
+             if (k.le.qcindex-kdir) then
+                if (V_nc(k).lt.1.E-10) then
+                   V_nc(k) = V_nc(k+kdir)
+                endif
+             endif
+          elseif (kdir.eq.-1) then
+             if (k.ge.qcindex-kdir) then
+                if (V_nc(k).lt.1.e-10) then
+                   V_nc(k) = V_nc(k+kdir)
+                endif
+             endif
+          endif
+
+! calculate number of split time steps
+          rgvm       = V_nc(k)
+          nstep      = max(int(rgvm*dt*inv_dzq(i,k)+1.),nstep)
+          dum_nc(k)  = nc(i,k)*rho(i,k)
+          tend_nc(K) = 0.
+
+       enddo ! k-loop
+
+       inv_nstep = 1./real(nstep)
+
+       if (nstep.ge.100) then
+          print*,'CLOUD nstep LARGE:',i,nstep
+          stop
+       endif
+
+! calculate sedimentation using first-order upwind method
+       do n = 1,nstep
+
+          do k = kbot,qcindex,kdir
+             flux_nc(k) = V_nc(k)*dum_nc(k)
+          enddo
+
+! top level with hydrometeor present
+          k = qcindex
+          fluxdiv_nc = flux_nc(k)*inv_dzq(i,k)
+          tend_nc(k) = tend_nc(k)-fluxdiv_nc*inv_nstep*inv_rho(i,k)
+          dum_nc(k)  = dum_nc(k)-fluxdiv_nc*dt*inv_nstep
+
+! loop from sceond to top level of hydrometeor to surface
+          do k = qcindex-kdir,kbot,-kdir
+
+             fluxdiv_nc = (flux_nc(k+kdir)-flux_nc(K))*inv_dzq(i,k)
+             tend_nc(k) = tend_nc(k)+fluxdiv_nc*inv_nstep*inv_rho(i,k)
+             dum_nc(k)  = dum_nc(k)+fluxdiv_nc*dt*inv_nstep
+
+          enddo ! k loop
+
+       enddo ! nstep-loop
+
+       do k = kbot,qcindex,kdir
+          nc(i,k) = nc(i,k)+tend_nc(k)*dt
+       enddo
+
+    endif ! log_predictNc
+
+    endif ! log_qcpresent
+
+
+!------------------------------------------------------------------------------------------!
+! Rain sedimentation:
+
+    log_qrpresent = .false.
+
+    do k = ktop,kbot,-kdir
+
+       call get_rain_dsd(qr(i,k),nr(i,k),mu_r(i,k),rdumii,dumii,lamr(i,k),mu_r_table,    &
+                         tmp1,tmp2,log_qrpresent,qrindex,k)
+       !note: tmp1,tmp2 are not used in this section
+
+       if (qr(i,k).ge.qsmall) then
+
+       ! read in fall mass- and number-weighted fall speeds from lookup table
+          call find_lookupTable_indices_3(dumii,dumjj,dum1,rdumii,rdumjj,inv_dum3,       &
+                                          mu_r(i,k),lamr(i,k))
+
+     ! number-weighted fall speed:
+       !at mu_r:
+          dum1 = vn_table(dumii,dumjj)+(rdumii-real(dumii))*inv_dum3*                    &
+                 (vn_table(dumii+1,dumjj)-vn_table(dumii,dumjj))
+       !at mu_r+1:
+          dum2 = vn_table(dumii,dumjj+1)+(rdumii-real(dumii))*                           &
+                 inv_dum3*(vn_table(dumii+1,dumjj+1)-vn_table(dumii,dumjj+1))
+       !interpolated:
+          Vt_nr(i,k) = dum1+(rdumjj-real(dumjj))*(dum2-dum1)
+          Vt_nr(i,k) = Vt_nr(i,k)*rhofacr(i,k)
+
+      ! mass-weighted fall speed:
+       !at mu_r:
+          dum1 = vm_table(dumii,dumjj)+(rdumii-real(dumii))*inv_dum3*                    &
+                 (vm_table(dumii+1,dumjj)-vm_table(dumii,dumjj))
+       !at mu_r+1:
+          dum2 = vm_table(dumii,dumjj+1)+(rdumii-real(dumii))*inv_dum3*                  &
+                 (vm_table(dumii+1,dumjj+1)-vm_table(dumii,dumjj+1))
+
+       !interpolated:
+          Vt_qr(i,k) = dum1 + (rdumjj-real(dumjj))*(dum2-dum1)
+          Vt_qr(i,k) = Vt_qr(i,k)*rhofacr(i,k)
+
+       else
+
+          Vt_nr(i,k) = 0.
+          Vt_qr(i,k) = 0.
+
+       endif
+
+    enddo ! k-loop
+
+    if (log_qrpresent) then
+
+       nstep = 1
+
+       do k = qrindex+kdir,kbot,-kdir
+
+         !- weighted fall speed arrays used for sedimentation calculations
+         !  (assigned below to highest non-zero level value at lower levels with Vt_x=0)
+          V_qr(k) = Vt_qr(i,k)
+          V_nr(k) = Vt_nr(i,k)
+
+          if (kdir.eq.1) then
+             if (k.le.qrindex-kdir) then
+                if (V_qr(k).lt.1.e-10) then
+                   V_qr(k) = V_qr(k+kdir)
+                endif
+                if (V_nr(k).lt.1.e-10) then
+                   V_nr(k) = V_nr(k+kdir)
+                endif
+             endif
+          elseif (kdir.eq.-1) then
+             if (k.ge.qrindex-kdir) then
+                if (V_qr(k).lt.1.e-10) then
+                   V_qr(k) = V_qr(k+kdir)
+                endif
+                if (V_nr(k).lt.1.e-10) then
+                   V_nr(k) = V_nr(k+kdir)
+                endif
+             endif
+          endif
+
+       ! calculate number of split time steps
+          rgvm       = max(V_qr(k),V_nr(k))
+          nstep      = max(int(rgvm*dt*inv_dzq(i,k)+1.),nstep)
+          dum_qr(k)  = qr(i,k)*rho(i,k)
+          dum_nr(k)  = nr(i,k)*rho(i,k)
+          tend_qr(k) = 0.
+          tend_nr(k) = 0.
+
+       enddo ! k-loop
+
+       inv_nstep = 1./real(nstep)
+
+       if (nstep .ge. 100) then
+          print*,'RAIN nstep LARGE:',i,nstep
+          stop
+       endif
+
+!--test:  explicitly calculate pcp rate:
+! pcprt_liq(i) = qr(i,kbot)*rho(i,kbot)*Vt_qr(i,kbot)*1.e-3  !m s-1
+!==
+
+! calculate sedimentation using first-order upwind method
+       tmp1 = 0.
+       do n = 1,nstep
+
+          do k = kbot,qrindex,kdir
+             flux_qr(k) = V_qr(k)*dum_qr(k)
+             flux_nr(k) = V_nr(k)*dum_nr(k)
+          enddo
+          tmp1 = tmp1 + flux_qr(kbot)  !sum flux_ at lowest level for averaging over sub-stepping
+
+! top level with hydrometeor present
+          k          = qrindex
+          fluxdiv_qr = flux_qr(k)*inv_dzq(i,k)
+          fluxdiv_nr = flux_nr(k)*inv_dzq(i,k)
+          tend_qr(k) = tend_qr(k) - fluxdiv_qr*inv_nstep*inv_rho(i,k)
+          tend_nr(k) = tend_nr(k) - fluxdiv_nr*inv_nstep*inv_rho(i,k)
+          dum_qr(k)  = dum_qr(k)  - fluxdiv_qr*dt*inv_nstep
+          dum_nr(k)  = dum_nr(k)  - fluxdiv_nr*dt*inv_nstep
+
+! loop from second to top level of hydrometeor to surface
+          do k = qrindex-kdir,kbot,-kdir
+             fluxdiv_qr = (flux_qr(k+kdir) - flux_qr(K))*inv_dzq(i,k)
+             fluxdiv_nr = (flux_nr(k+kdir) - flux_nr(K))*inv_dzq(i,k)
+             tend_qr(k) = tend_qr(k) + fluxdiv_qr*inv_nstep*inv_rho(i,k)
+             tend_nr(k) = tend_nr(k) + fluxdiv_nr*inv_nstep*inv_rho(i,k)
+             dum_qr(k)  = dum_qr(k)  + fluxdiv_qr*dt*inv_nstep
+             dum_nr(k)  = dum_nr(k)  + fluxdiv_nr*dt*inv_nstep
+          enddo ! k loop
+
+       enddo ! nstep loop
+
+! update prognostic variables with sedimentation tendencies
+       do k = kbot,qrindex,kdir
+          qr(i,k) = qr(i,k) + tend_qr(k)*dt
+          nr(i,k) = nr(i,k) + tend_nr(k)*dt
+       enddo
+
+! add rain component of liquid precipitation rate at surface
+       tmp1 = tmp1*inv_nstep               !flux_ at surface, averaged over sub-step
+       tmp1 = tmp1*inv_rhow                !convert flux_ (kg m-2 s-1) to pcp rate (m s-1)
+
+       pcprt_liq(i) = pcprt_liq(i) + tmp1  !add pcp rate from cloud and rain
+
+    endif ! log_qrpresent
+
+
+!------------------------------------------------------------------------------------------!
+! Ice sedimentation:
+
+    iice_loop_sedi_ice:  do iice = 1,nCat
+
+       log_qipresent = .false.  !note: this applies to ice category 'iice' only
+
+       do k = ktop,kbot,-kdir
+
+! get ice fallspeed for updated variables
+          qitot_not_small: if (qitot(i,k,iice).ge.qsmall) then
+
+            !impose lower limits to prevent taking log of # < 0
+             nitot(i,k,iice) = max(nitot(i,k,iice),nsmall)
+
+             call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),birim(i,k,iice),rhop)
+
+           ! if (.not. tripleMoment_on) zitot(i,k,iice) = diag_mom6(qitot(i,k,iice),nitot(i,k,iice),rho(i,k))
+             call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumzz,dum1,dum4,dum5,     &
+                                       dum6,isize,rimsize,densize,zsize,qitot(i,k,iice), &
+                                       nitot(i,k,iice),qirim(i,k,iice),999.,rhop)
+                                      !nitot(i,k,iice),qirim(i,k,iice),zitot(i,k,iice),rhop)
+
+             call access_lookup_table(dumjj,dumii,dumi, 1,dum1,dum4,dum5,f1pr01)
+             call access_lookup_table(dumjj,dumii,dumi, 2,dum1,dum4,dum5,f1pr02)
+             call access_lookup_table(dumjj,dumii,dumi, 7,dum1,dum4,dum5,f1pr09)
+             call access_lookup_table(dumjj,dumii,dumi, 8,dum1,dum4,dum5,f1pr10)
+!-- future (3-moment ice)
+!            call access_lookup_table(dumzz,dumjj,dumii,dumi, 1,dum1,dum4,dum5,dum6,f1pr01)
+!            call access_lookup_table(dumzz,dumjj,dumii,dumi, 2,dum1,dum4,dum5,dum6,f1pr02)
+!            call access_lookup_table(dumzz,dumjj,dumii,dumi, 7,dum1,dum4,dum5,dum6,f1pr09)
+!            call access_lookup_table(dumzz,dumjj,dumii,dumi, 8,dum1,dum4,dum5,dum6,f1pr10)
+!            call access_lookup_table(dumzz,dumjj,dumii,dumi,13,dum1,dum4,dum5,dum6,f1pr19)   !mom6-weighted V
+!            call access_lookup_table(dumzz,dumjj,dumii,dumi,14,dum1,dum4,dum5,dum6,f1pr020)   !z_max
+!            call access_lookup_table(dumzz,dumjj,dumii,dumi,15,dum1,dum4,dum5,dum6,f1pr021)   !z_min
+!==
+
+          ! impose mean ice size bounds (i.e. apply lambda limiters)
+          ! note that the Nmax and Nmin are normalized and thus need to be multiplied by existing N
+             nitot(i,k,iice) = min(nitot(i,k,iice),f1pr09*nitot(i,k,iice))
+             nitot(i,k,iice) = max(nitot(i,k,iice),f1pr10*nitot(i,k,iice))
+
+! adjust Zi if needed to make sure mu_i is in bounds
+!            zitot(i,k,iice) = min(zitot(i,k,iice),f1pr020)
+!            zitot(i,k,iice) = max(zitot(i,k,iice),f1pr021)
+
+             if (.not. log_qipresent) then
+                qiindex = k
+             endif
+             log_qipresent = .true.
+
+             Vt_nit(i,k) = f1pr01*rhofaci(i,k)     !number-weighted    fall speed (with density factor)
+             Vt_qit(i,k) = f1pr02*rhofaci(i,k)     !mass-weighted  fall speed (with density factor)
+          !  Vt_zit(i,k) = f1pr19*rhofaci(i,k)     !moment6-weighted fall speed (with density factor)
+             diag_vmi(i,k,iice) = f1pr02           !output fallspeed, w/o density correction
+
+          else
+
+             Vt_nit(i,k) = 0.
+             Vt_qit(i,k) = 0.
+           ! Vt_zit(i,k) = 0.
+
+          endif qitot_not_small
+
+       enddo ! k-loop
+
+       qipresent: if (log_qipresent) then
+
+          nstep = 1
+
+          do k = qiindex+kdir,kbot,-kdir
+
+            !- weighted fall speed arrays used for sedimentation calculations
+            !  (assigned below to highest non-zero level value at lower levels with Vt_x=0)
+             V_qit(k) = Vt_qit(i,k)
+             V_nit(k) = Vt_nit(i,k)
+          !  V_zit(k) = Vt_zit(i,k)
+
+            !--fill in fall speeds levels below lowest level with hydrometeors
+             if (kdir.eq.1) then
+                if (k.le.qiindex-kdir) then
+                   if (V_qit(k).lt.1.e-10)  V_qit(k) = V_qit(k+kdir)
+                   if (V_nit(k).lt.1.e-10)  V_nit(k) = V_nit(k+kdir)
+                 ! if (V_zit(k).lt.1.e-10)  V_zit(k) = V_zit(k+kdir)
+                endif
+             elseif (kdir.eq.-1) then
+                if (k.ge.qiindex-kdir) then
+                   if (V_qit(k).lt.1.e-10)  V_qit(k) = V_qit(k+kdir)
+                   if (V_nit(k).lt.1.e-10)  V_nit(k) = V_nit(k+kdir)
+                 ! if (V_zit(k).lt.1.e-10)  V_zit(k) = V_zit(k+kdir)
+                endif
+             endif ! kdir
+            !==
+
+! calculate number of split time steps
+             rgvm        = max(V_qit(k),V_nit(k))
+!            rgvm        = max(V_zit(k),max(V_qit(k),V_nit(k)))
+             nstep       = max(int(rgvm*dt*inv_dzq(i,k)+1.),nstep)
+             dum_qit(k)  = qitot(i,k,iice)*rho(i,k)
+             dum_qir(k)  = qirim(i,k,iice)*rho(i,k)
+             dum_bir(k)  = birim(i,k,iice)*rho(i,k)
+             dum_nit(k)  = nitot(i,k,iice)*rho(i,k)
+!            dum_zit(k)  = zitot(i,k,iice)*rho(i,k)
+             tend_qit(k) = 0.
+             tend_qir(k) = 0.
+             tend_bir(k) = 0.
+             tend_nit(k) = 0.
+!            tend_zit(k) = 0.
+
+          enddo ! k loop
+
+          inv_nstep = 1./real(nstep)
+
+          if (nstep.ge.200) then
+             print*,'ICE nstep LARGE:',i,nstep
+             if (nstep.ge.500) stop
+          endif
+
+! calculate sedimentation using first-order upwind method
+          tmp1 = 0.
+          do n = 1,nstep
+
+             do k = kbot,qiindex,kdir
+                flux_qit(k) = V_qit(k)*dum_qit(k)
+                flux_nit(k) = V_nit(k)*dum_nit(k)
+                flux_qir(k) = V_qit(k)*dum_qir(k)
+                flux_bir(k) = V_qit(k)*dum_bir(k)
+!               flux_zit(k) = V_zit(k)*dum_zit(k)
+             enddo
+            tmp1 = tmp1 + flux_qit(kbot)  !sum flux_ at lowest level for averaging over sub-stepping
+
+! top level with hydrometeor present
+             k = qiindex
+             fluxdiv_qit = flux_qit(k)*inv_dzq(i,k)
+             fluxdiv_qir = flux_qir(k)*inv_dzq(i,k)
+             fluxdiv_bir = flux_bir(k)*inv_dzq(i,k)
+             fluxdiv_nit = flux_nit(k)*inv_dzq(i,k)
+!            fluxdiv_zit = flux_zit(k)*inv_dzq(i,k)
+
+             tend_qit(k) = tend_qit(k) - fluxdiv_qit*inv_nstep*inv_rho(i,k)
+             tend_qir(k) = tend_qir(k) - fluxdiv_qir*inv_nstep*inv_rho(i,k)
+             tend_bir(k) = tend_bir(k) - fluxdiv_bir*inv_nstep*inv_rho(i,k)
+             tend_nit(k) = tend_nit(k) - fluxdiv_nit*inv_nstep*inv_rho(i,k)
+!            tend_zit(k) = tend_zit(k) - fluxdiv_zit*inv_nstep*inv_rho(i,k)
+
+             dum_qit(k) = dum_qit(k) - fluxdiv_qit*dt*inv_nstep
+             dum_qir(k) = dum_qir(k) - fluxdiv_qir*dt*inv_nstep
+             dum_bir(k) = dum_bir(k) - fluxdiv_bir*dt*inv_nstep
+             dum_nit(k) = dum_nit(k) - fluxdiv_nit*dt*inv_nstep
+!            dum_zit(k) = dum_zit(k) - fluxdiv_zit*dt*inv_nstep
+
+! loop from sceond to top level of hydrometeor to surface
+             do k = qiindex-kdir,kbot,-kdir
+                fluxdiv_qit = (flux_qit(k+kdir) - flux_qit(k))*inv_dzq(i,k)
+                fluxdiv_qir = (flux_qir(k+kdir) - flux_qir(k))*inv_dzq(i,k)
+                fluxdiv_bir = (flux_bir(k+kdir) - flux_bir(k))*inv_dzq(i,k)
+                fluxdiv_nit = (flux_nit(k+kdir) - flux_nit(k))*inv_dzq(i,k)
+!               fluxdiv_zit = (flux_zit(k+kdir) - flux_zit(k))*inv_dzq(i,k)
+
+                tend_qit(k) = tend_qit(k) + fluxdiv_qit*inv_nstep*inv_rho(i,k)
+                tend_qir(k) = tend_qir(k) + fluxdiv_qir*inv_nstep*inv_rho(i,k)
+                tend_bir(k) = tend_bir(k) + fluxdiv_bir*inv_nstep*inv_rho(i,k)
+                tend_nit(k) = tend_nit(k) + fluxdiv_nit*inv_nstep*inv_rho(i,k)
+!               tend_zit(k) = tend_zit(k) + fluxdiv_zit*inv_nstep*inv_rho(i,k)
+
+                dum_qit(k) = dum_qit(k) + fluxdiv_qit*dt*inv_nstep
+                dum_qir(k) = dum_qir(k) + fluxdiv_qir*dt*inv_nstep
+                dum_bir(k) = dum_bir(k) + fluxdiv_bir*dt*inv_nstep
+                dum_nit(k) = dum_nit(k) + fluxdiv_nit*dt*inv_nstep
+ !              dum_zit(k) = dum_nit(k) + fluxdiv_nit*dt*inv_nstep
+             enddo ! k loop
+
+          enddo ! nstep loop
+
+! update prognostic variables with sedimentation tendencies
+          do k = kbot,qiindex,kdir
+             qitot(i,k,iice) = qitot(i,k,iice) + tend_qit(k)*dt
+             qirim(i,k,iice) = qirim(i,k,iice) + tend_qir(k)*dt
+             birim(i,k,iice) = birim(i,k,iice) + tend_bir(k)*dt
+             nitot(i,k,iice) = nitot(i,k,iice) + tend_nit(k)*dt
+!            zitot(i,k,iice) = zitot(i,k,iice) + tend_zit(k)*dt
+          enddo
+
+! add contirubtion from iice to solid precipitation rate at surface
+          tmp1 = tmp1*inv_nstep   !flux_ at surface, averaged over sub-step
+          tmp1 = tmp1*inv_rhow    !convert flux_ (kg m-2 s-1) to pcp rate (m s-1), liquid-equivalent
+          pcprt_sol(i) = pcprt_sol(i) + tmp1  !add pcp rate from
+
+       endif qipresent
+
+    enddo iice_loop_sedi_ice  !iice-loop
+
+!  if (debug_ON) call check_values(qv,T,qc,qr,nr,qitot,qirim,nitot,birim,i,it,.true.,debug_ABORT,600)
+
+!------------------------------------------------------------------------------------------!
+! End of sedimentation section
+!==========================================================================================!
+
+!.......................................
+! homogeneous freezing of cloud and rain
+
+    k_loop_fz:  do k = kbot,ktop,kdir
+
+    ! compute mean-mass ice diameters (estimated; rigorous approach to be implemented later)
+       diam_ice(i,k,:) = 0.
+       do iice = 1,nCat
+          if (qitot(i,k,iice).ge.qsmall) then
+             dum1 = max(nitot(i,k,iice),nsmall)
+             dum2 = 500. !ice density
+             diam_ice(i,k,iice) = ((qitot(i,k,iice)*6.)/(dum1*dum2*pi))**thrd
+          endif
+       enddo  !iice loop
+
+       if (qc(i,k).ge.qsmall .and. t(i,k).lt.233.15) then
+          Q_nuc = qc(i,k)
+          N_nuc = max(nc(i,k),nsmall)
+         !--determine destination ice-phase category:
+          dum1   = 900.     !density of new ice
+          D_new  = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd
+          call icecat_destination(qitot(i,k,:),diam_ice(i,k,:),D_new,deltaD_init,       &
+                                  log_ni_add,iice_dest)
+         !==
+          qirim(i,k,iice_dest) = qirim(i,k,iice_dest) + Q_nuc
+          qitot(i,k,iice_dest) = qitot(i,k,iice_dest) + Q_nuc
+          birim(i,k,iice_dest) = birim(i,k,iice_dest) + Q_nuc*inv_rho_rimeMax
+          nitot(i,k,iice_dest) = nitot(i,k,iice_dest) + N_nuc
+          th(i,k) = th(i,k) + th(i,k)/t(i,k)*Q_nuc*xlf(i,k)*inv_cp
+          qc(i,k) = 0.  != qc(i,k) - Q_nuc
+          nc(i,k) = 0.  != nc(i,k) - N_nuc
+       endif
+
+       if (qr(i,k).ge.qsmall .and. t(i,k).lt.233.15) then
+          Q_nuc = qr(i,k)
+          N_nuc = max(nr(i,k),nsmall)
+         !--determine destination ice-phase category:
+          dum1  = 900.     !density of new ice
+          D_new = ((Q_nuc*6.)/(pi*dum1*N_nuc))**thrd
+          call icecat_destination(qitot(i,k,:),diam_ice(i,k,:),D_new,deltaD_init,       &
+                                  log_ni_add,iice_dest)
+         !==
+          qirim(i,k,iice_dest) = qirim(i,k,iice_dest) + Q_nuc
+          qitot(i,k,iice_dest) = qitot(i,k,iice_dest) + Q_nuc
+          birim(i,k,iice_dest) = birim(i,k,iice_dest) + Q_nuc*inv_rho_rimeMax
+          nitot(i,k,iice_dest) = nitot(i,k,iice_dest) + N_nuc
+          th(i,k) = th(i,k) + th(i,k)/t(i,k)*Q_nuc*xlf(i,k)*inv_cp
+          qr(i,k) = 0.  ! = qr(i,k) - Q_nuc
+          nr(i,k) = 0.  ! = nr(i,k) - N_nuc
+       endif
+
+    enddo k_loop_fz
+
+!  if (debug_ON) call check_values(qv,T,qc,qr,nr,qitot,qirim,nitot,birim,i,it,.true.,debug_ABORT,700)
+
+!...................................................
+! final checks to ensure consistency of mass/number
+! and compute diagnostic fields for output
+
+    k_loop_final_diagnostics:  do k = kbot,ktop,kdir
+
+    ! cloud:
+       if (qc(i,k).ge.qsmall) then
+          call get_cloud_dsd(qc(i,k),nc(i,k),mu_c(i,k),rho(i,k),nu(i,k),dnu,lamc(i,k),   &
+                             lammin,lammax,k,tmp1,tmp2,tmpint1,log_tmp1)
+          diag_effc(i,k) = 0.5*(mu_c(i,k)+3.)/lamc(i,k)
+       else
+          qv(i,k) = qv(i,k)+qc(i,k)
+          th(i,k) = th(i,k)-th(i,k)/t(i,k)*qc(i,k)*xxlv(i,k)*inv_cp
+          qc(i,k) = 0.
+          nc(i,k) = 0.
+       endif
+
+    ! rain:
+       if (qr(i,k).ge.qsmall) then
+          call get_rain_dsd(qr(i,k),nr(i,k),mu_r(i,k),rdumii,dumii,lamr(i,k),mu_r_table, &
+                            tmp1,tmp2,log_tmp1,tmpint1,tmpint2)
+         ! hm, turn off soft lambda limiter
+         ! impose size limits for rain with 'soft' lambda limiter
+         ! (adjusts over a set timescale rather than within one timestep)
+         ! dum2 = (qr(i,k)/(pi*rhow*nr(i,k)))**thrd
+         ! if (dum2.gt.dbrk) then
+         !    dum   = qr(i,k)*cons4
+         !   !dum1  = (dum-nr(i,k))/max(60.,dt)  !time scale for adjustment is 60 s
+         !    dum1  = (dum-nr(i,k))*timeScaleFactor
+         !     nr(i,k) = nr(i,k)+dum1*dt
+         ! endif
+
+         !diag_effr(i,k) = 0.5*(mu_r(i,k)+3.)/lamr(i,k)    (currently not used)
+        ! ze_rain(i,k) = n0r(i,k)*720./lamr(i,k)**3/lamr(i,k)**3/lamr(i,k)
+          ! non-exponential rain:
+          ze_rain(i,k) = nr(i,k)*(mu_r(i,k)+6.)*(mu_r(i,k)+5.)*(mu_r(i,k)+4.)*           &
+                        (mu_r(i,k)+3.)*(mu_r(i,k)+2.)*(mu_r(i,k)+1.)/lamr(i,k)**6
+          ze_rain(i,k) = max(ze_rain(i,k),1.e-22)
+       else
+          qv(i,k) = qv(i,k)+qr(i,k)
+          th(i,k) = th(i,k)-th(i,k)/t(i,k)*qr(i,k)*xxlv(i,k)*inv_cp
+          qr(i,k) = 0.
+          nr(i,k) = 0.
+       endif
+
+    ! ice:
+
+       call impose_max_total_Ni(nitot(i,k,:),max_total_Ni,inv_rho(i,k))
+
+       iice_loop_final_diagnostics:  do iice = 1,nCat
+
+          qi_not_small:  if (qitot(i,k,iice).ge.qsmall) then
+
+            !impose lower limits to prevent taking log of # < 0
+             nitot(i,k,iice) = max(nitot(i,k,iice),nsmall)
+             nr(i,k)         = max(nr(i,k),nsmall)
+
+             call calc_bulkRhoRime(qitot(i,k,iice),qirim(i,k,iice),birim(i,k,iice),rhop)
+
+           ! if (.not. tripleMoment_on) zitot(i,k,iice) = diag_mom6(qitot(i,k,iice),nitot(i,k,iice),rho(i,k))
+             call find_lookupTable_indices_1a(dumi,dumjj,dumii,dumzz,dum1,dum4,          &
+                                              dum5,dum6,isize,rimsize,densize,zsize,     &
+                                              qitot(i,k,iice),nitot(i,k,iice),           &
+                                              qirim(i,k,iice),999.,rhop)
+                                             !qirim(i,k,iice),zitot(i,k,iice),rhop)
+
+             call access_lookup_table(dumjj,dumii,dumi, 6,dum1,dum4,dum5,f1pr06)
+             call access_lookup_table(dumjj,dumii,dumi, 7,dum1,dum4,dum5,f1pr09)
+             call access_lookup_table(dumjj,dumii,dumi, 8,dum1,dum4,dum5,f1pr10)
+             call access_lookup_table(dumjj,dumii,dumi, 9,dum1,dum4,dum5,f1pr13)
+             call access_lookup_table(dumjj,dumii,dumi,11,dum1,dum4,dum5,f1pr15)
+             call access_lookup_table(dumjj,dumii,dumi,12,dum1,dum4,dum5,f1pr16)
+
+          ! impose mean ice size bounds (i.e. apply lambda limiters)
+          ! note that the Nmax and Nmin are normalized and thus need to be multiplied by existing N
+             nitot(i,k,iice) = min(nitot(i,k,iice),f1pr09*nitot(i,k,iice))
+             nitot(i,k,iice) = max(nitot(i,k,iice),f1pr10*nitot(i,k,iice))
+
+  !--this should already be done in s/r 'calc_bulkRhoRime'
+             if (qirim(i,k,iice).lt.qsmall) then
+                qirim(i,k,iice) = 0.
+                birim(i,k,iice) = 0.
+             endif
+  !==
+
+  ! note that reflectivity from lookup table is normalized, so we need to multiply by N
+             diag_effi(i,k,iice)  = f1pr06 ! units are in m
+             diag_di(i,k,iice)    = f1pr15
+             diag_rhopo(i,k,iice) = f1pr16
+          ! note factor of air density below is to convert from m^6/kg to m^6/m^3
+             ze_ice(i,k) = ze_ice(i,k) + 0.1892*f1pr13*nitot(i,k,iice)*rho(i,k)   ! sum contribution from each ice category (note: 0.1892 = 0.176/0.93)
+             ze_ice(i,k) = max(ze_ice(i,k),1.e-22)
+
+          else
+
+             qv(i,k) = qv(i,k) + qitot(i,k,iice)
+             th(i,k) = th(i,k) - th(i,k)/t(i,k)*qitot(i,k,iice)*xxls(i,k)*inv_cp
+             qitot(i,k,iice) = 0.
+             nitot(i,k,iice) = 0.
+             qirim(i,k,iice) = 0.
+             birim(i,k,iice) = 0.
+             diag_di(i,k,iice) = 0.
+
+          endif qi_not_small
+
+       enddo iice_loop_final_diagnostics
+
+     ! sum ze components and convert to dBZ
+       diag_ze(i,k) = 10.*log10((ze_rain(i,k) + ze_ice(i,k))*1.d+18)
+
+     ! if qr is very small then set Nr to 0 (needs to be done here after call
+     ! to ice lookup table because a minimum Nr of nsmall will be set otherwise even if qr=0)
+       if (qr(i,k).lt.qsmall) then
+          nr(i,k) = 0.
+       endif
+
+    enddo k_loop_final_diagnostics
+
+!   if (debug_ON) call check_values(qv,T,qc,qr,nr,qitot,qirim,nitot,birim,i,it,.true.,debug_ABORT,800)
+
+!..............................................
+! merge ice categories with similar properties
+
+!   note:  this should be relocated to above, such that the diagnostic
+!          ice properties are computed after merging
+
+    multicat:  if (nCat.gt.1) then
+!   multicat:  if (.FALSE.) then       ! **** TEST
+
+       do k = kbot,ktop,kdir
+          do iice = nCat,2,-1
+
+           ! simility condition (similar mean sizes; similar bulk densities)
+             if (abs(diag_di(i,k,iice)-diag_di(i,k,iice-1)).le.150.e-6   .and.           &
+                 abs(diag_rhopo(i,k,iice)-diag_rhopo(i,k,iice-1)).le.100.) then
+
+                qitot(i,k,iice-1) = qitot(i,k,iice-1) + qitot(i,k,iice)
+                nitot(i,k,iice-1) = nitot(i,k,iice-1) + nitot(i,k,iice)
+                qirim(i,k,iice-1) = qirim(i,k,iice-1) + qirim(i,k,iice)
+                birim(i,k,iice-1) = birim(i,k,iice-1) + birim(i,k,iice)
+             !  zitot(i,k,iice-1) = zitot(i,k,iice-1) + zitot(i,k,iice)
+
+                qitot(i,k,iice) = 0.
+                nitot(i,k,iice) = 0.
+                qirim(i,k,iice) = 0.
+                birim(i,k,iice) = 0.
+             !  zitot(i,k,iice) = 0.
+
+             endif
+
+          enddo !iice loop
+       enddo !k loop
+
+    endif multicat
+
+!....................................................................
+
+333 continue
+
+    if (log_predictSsat) then
+   ! recalculate supersaturation from T and qv
+       do k = kbot,ktop,kdir
+          t(i,k) = th(i,k)*(1.e-5*pres(i,k))**(rd*inv_cp)
+          dum    = qv_sat(t(i,k),pres(i,k),0)
+          ssat(i,k) = qv(i,k)-dum
+       enddo
+    endif
+
+    if (debug_ON) then
+       tmparr1(i,:) = th(i,:)*(pres(i,:)*1.e-5)**(rd*inv_cp)
+       call check_values(qv,tmparr1,qc,qr,nr,qitot,qirim,nitot,birim,i,it,.true.,debug_ABORT,900)
+    endif
+
+!.....................................................
+
+ enddo i_loop_main
+
+!-- for WRF:
+!
+! Diagnostics (for default WRF, ice category 1 only):
+  diag_ss(:,:,1) = diag_vmi(:,:,1)     ! mass-weighted Vi (w/o rhoa corr) m s-1
+  diag_ss(:,:,2) = diag_di(:,:,1)      ! mean size of ice                 m
+  diag_ss(:,:,3) = diag_rhopo(:,:,1)   ! bulk ice density                 kg m-3
+
+!   Save end of microphysics values of theta and qv as old values for next time step
+!   note:  This is commented out for GEM, which already has these values available
+!          from the beginning of the model time step (TT_moins and HU_moins) when
+!          s/r 'p3_wrapper_gem' is called (from s/r 'condensation').
+  th_old = th
+  qv_old = qv
+!
+!==
+
+! end of main microphysics routine
+
+!.....................................................................................
+!--
+! output only
+!      do i = its,ite
+!       do k = kbot,ktop,kdir
+!     !calculate temperature from theta
+!       t(i,k) = th(i,k)*(pres(i,k)*1.e-5)**(rd*inv_cp)
+!     !calculate some time-varying atmospheric variables
+!       qvs(i,k) = qv_sat(t(i,k),pres(i,k),0)
+!       if (qc(i,k).gt.1.e-5) then
+!          write(6,'(a10,2i5,5e15.5)')'after',i,k,qc(i,k),qr(i,k),nc(i,k),qv(i,k)/qvs(i,k),uzpl(i,k)
+!       end if
+!       end do
+!      enddo !i-loop
+!   !saturation ratio at end of microphysics step:
+!    do i = its,ite
+!     do k = kbot,ktop,kdir
+!        dum1     = th(i,k)*(pres(i,k)*1.e-5)**(rd*inv_cp)   !i.e. t(i,k)
+!        qvs(i,k) = qv_sat(dumt,pres(i,k),0)
+!        diag_ss(i,k,2) = qv(i,k)/qvs(i,k)
+!     enddo
+!    enddo !i-loop
+!==
+
+!.....................................................................................
+
+ return
+
+ END SUBROUTINE p3_main
+
+!==========================================================================================!
+
+ SUBROUTINE access_lookup_table(dumjj,dumii,dumi,index,dum1,dum4,dum5,proc)
+
+ implicit none
+
+ real    :: dum1,dum4,dum5,proc,dproc1,dproc2,iproc1,gproc1,tmp1,tmp2
+ integer :: dumjj,dumii,dumi,index
+
+! get value at current density index
+
+! first interpolate for current rimed fraction index
+
+   iproc1 = itab(dumjj,dumii,dumi,index)+(dum1-real(dumi))*(itab(dumjj,dumii,       &
+            dumi+1,index)-itab(dumjj,dumii,dumi,index))
+
+! linearly interpolate to get process rates for rimed fraction index + 1
+
+   gproc1 = itab(dumjj,dumii+1,dumi,index)+(dum1-real(dumi))*(itab(dumjj,dumii+1,   &
+          dumi+1,index)-itab(dumjj,dumii+1,dumi,index))
+
+   tmp1   = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
+
+! get value at density index + 1
+
+! first interpolate for current rimed fraction index
+
+   iproc1 = itab(dumjj+1,dumii,dumi,index)+(dum1-real(dumi))*(itab(dumjj+1,dumii,   &
+            dumi+1,index)-itab(dumjj+1,dumii,dumi,index))
+
+! linearly interpolate to get process rates for rimed fraction index + 1
+
+   gproc1 = itab(dumjj+1,dumii+1,dumi,index)+(dum1-real(dumi))*(itab(dumjj+1,       &
+            dumii+1,dumi+1,index)-itab(dumjj+1,dumii+1,dumi,index))
+
+   tmp2   = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
+
+! get final process rate
+   proc   = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
+
+END SUBROUTINE access_lookup_table
+
+!------------------------------------------------------------------------------------------!
+SUBROUTINE access_lookup_table_coll(dumjj,dumii,dumj,dumi,index,dum1,dum3,          &
+                                    dum4,dum5,proc)
+
+ implicit none
+
+ real    :: dum1,dum3,dum4,dum5,proc,dproc1,dproc2,iproc1,gproc1,tmp1,tmp2,dproc11, &
+            dproc12,dproc21,dproc22
+ integer :: dumjj,dumii,dumj,dumi,index
+
+
+! This subroutine interpolates lookup table values for rain/ice collection processes
+
+! current density index
+
+! current rime fraction index
+  dproc1  = itabcoll(dumjj,dumii,dumi,dumj,index)+(dum1-real(dumi))*                &
+             (itabcoll(dumjj,dumii,dumi+1,dumj,index)-itabcoll(dumjj,dumii,dumi,    &
+             dumj,index))
+
+   dproc2  = itabcoll(dumjj,dumii,dumi,dumj+1,index)+(dum1-real(dumi))*             &
+             (itabcoll(dumjj,dumii,dumi+1,dumj+1,index)-itabcoll(dumjj,dumii,dumi,  &
+             dumj+1,index))
+
+   iproc1  = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
+
+! rime fraction index + 1
+
+   dproc1  = itabcoll(dumjj,dumii+1,dumi,dumj,index)+(dum1-real(dumi))*             &
+             (itabcoll(dumjj,dumii+1,dumi+1,dumj,index)-itabcoll(dumjj,dumii+1,     &
+                 dumi,dumj,index))
+
+   dproc2  = itabcoll(dumjj,dumii+1,dumi,dumj+1,index)+(dum1-real(dumi))*           &
+             (itabcoll(dumjj,dumii+1,dumi+1,dumj+1,index)-itabcoll(dumjj,dumii+1,   &
+             dumi,dumj+1,index))
+
+   gproc1  = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
+   tmp1    = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
+
+! density index + 1
+
+! current rime fraction index
+
+   dproc1  = itabcoll(dumjj+1,dumii,dumi,dumj,index)+(dum1-real(dumi))*             &
+             (itabcoll(dumjj+1,dumii,dumi+1,dumj,index)-itabcoll(dumjj+1,dumii,     &
+                 dumi,dumj,index))
+
+   dproc2  = itabcoll(dumjj+1,dumii,dumi,dumj+1,index)+(dum1-real(dumi))*           &
+             (itabcoll(dumjj+1,dumii,dumi+1,dumj+1,index)-itabcoll(dumjj+1,dumii,   &
+             dumi,dumj+1,index))
+
+   iproc1  = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
+
+! rime fraction index + 1
+
+   dproc1  = itabcoll(dumjj+1,dumii+1,dumi,dumj,index)+(dum1-real(dumi))*           &
+             (itabcoll(dumjj+1,dumii+1,dumi+1,dumj,index)-itabcoll(dumjj+1,dumii+1, &
+             dumi,dumj,index))
+
+   dproc2  = itabcoll(dumjj+1,dumii+1,dumi,dumj+1,index)+(dum1-real(dumi))*         &
+             (itabcoll(dumjj+1,dumii+1,dumi+1,dumj+1,index)-itabcoll(dumjj+1,       &
+                 dumii+1,dumi,dumj+1,index))
+
+   gproc1  = dproc1+(dum3-real(dumj))*(dproc2-dproc1)
+   tmp2    = iproc1+(dum4-real(dumii))*(gproc1-iproc1)
+
+! interpolate over density to get final values
+   proc    = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
+
+ END SUBROUTINE access_lookup_table_coll
+
+!------------------------------------------------------------------------------------------!
+
+ SUBROUTINE access_lookup_table_colli(dumjjc,dumiic,dumic,dumjj,dumii,dumj,dumi,     &
+                                     index,dum1c,dum4c,dum5c,dum1,dum4,dum5,proc)
+
+ implicit none
+
+ real    :: dum1,dum3,dum4,dum5,dum1c,dum4c,dum5c,proc,dproc1,dproc2,iproc1,iproc2, &
+            gproc1,gproc2,rproc1,rproc2,tmp1,tmp2,dproc11,dproc12
+ integer :: dumjj,dumii,dumj,dumi,index,dumjjc,dumiic,dumic
+
+
+! This subroutine interpolates lookup table values for rain/ice collection processes
+
+! current density index collectee category
+
+! current rime fraction index for collectee category
+
+! current density index collector category
+
+! current rime fraction index for collector category
+
+  if (index.eq.1) then
+
+   dproc11 = itabcolli1(dumic,dumiic,dumjjc,dumi,dumii,dumjj)+(dum1c-real(dumic))*    &
+             (itabcolli1(dumic+1,dumiic,dumjjc,dumi,dumii,dumjj)-                     &
+             itabcolli1(dumic,dumiic,dumjjc,dumi,dumii,dumjj))
+
+   dproc12 = itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj)+(dum1c-real(dumic))*  &
+             (itabcolli1(dumic+1,dumiic,dumjjc,dumi+1,dumii,dumjj)-                   &
+             itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj))
+
+!   dproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj)+(dum1c-real(dumic))*  &
+             (itabcolli1(dumic+1,dumiic,dumjjc,dumi,dumii+1,dumjj)-                   &
+             itabcolli1(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj))
+
+   dproc12 = itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))*&
+             (itabcolli1(dumic+1,dumiic,dumjjc,dumi+1,dumii+1,dumjj)-                 &
+             itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp1    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+! collector density index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic,dumjjc,dumi,dumii,dumjj+1)+(dum1c-real(dumic))*  &
+             (itabcolli1(dumic+1,dumiic,dumjjc,dumi,dumii,dumjj+1)-                   &
+             itabcolli1(dumic,dumiic,dumjjc,dumi,dumii,dumjj+1))
+
+   dproc12 = itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))*&
+             (itabcolli1(dumic+1,dumiic,dumjjc,dumi+1,dumii,dumjj+1)-                 &
+             itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj+1))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))*&
+             (itabcolli1(dumic+1,dumiic,dumjjc,dumi,dumii+1,dumjj+1)-                 &
+             itabcolli1(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj+1))
+
+   dproc12 = itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp2    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+   gproc1    = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
+
+!.......................................................................................................
+! collectee rime fraction + 1
+
+   dproc11 = itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj)+(dum1c-real(dumic))*   &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi,dumii,dumjj)-                    &
+             itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj))
+
+   dproc12 = itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi+1,dumii,dumjj)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj)+(dum1c-real(dumic))*  &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi,dumii+1,dumjj)-                   &
+             itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj))
+
+   dproc12 = itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp1    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+! collector density index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi,dumii,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj+1))
+
+   dproc12 = itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1))
+
+   dproc12 = itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp2    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+   gproc2  = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
+
+   rproc1  = gproc1+(dum4c-real(dumiic))*(gproc2-gproc1)
+
+!............................................................................................................
+! collectee density index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj)+(dum1c-real(dumic))*  &
+             (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi,dumii,dumjj)-                   &
+             itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj))
+
+   dproc12 = itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi+1,dumii,dumjj)-                  &
+             itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi,dumii+1,dumjj)-                  &
+             itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj))
+
+   dproc12 = itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj)-                  &
+             itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp1    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+! collector density index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj+1)+(dum1c-real(dumic))*  &
+             (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi,dumii,dumjj+1)-                   &
+             itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj+1))
+
+   dproc12 = itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1))
+
+   dproc12 = itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp2    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+   gproc1    = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
+
+!.......................................................................................................
+! collectee rime fraction + 1
+
+   dproc11 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj)+(dum1c-real(dumic))*  &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi,dumii,dumjj)-                   &
+             itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj))
+
+   dproc12 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj))
+
+   dproc12 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp1    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+! collector density index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1))
+
+   dproc12 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1))
+
+   dproc12 = itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli1(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1)-                  &
+             itabcolli1(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp2    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+   gproc2  = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
+
+   rproc2  = gproc1+(dum4c-real(dumiic))*(gproc2-gproc1)
+
+!..........................................................................................
+! final process rate interpolation over collectee density
+
+   proc    = rproc1+(dum5c-real(dumjjc))*(rproc2-rproc1)
+
+ else if (index.eq.2) then
+
+   dproc11 = itabcolli2(dumic,dumiic,dumjjc,dumi,dumii,dumjj)+(dum1c-real(dumic))*    &
+             (itabcolli2(dumic+1,dumiic,dumjjc,dumi,dumii,dumjj)-                     &
+             itabcolli2(dumic,dumiic,dumjjc,dumi,dumii,dumjj))
+
+   dproc12 = itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj)+(dum1c-real(dumic))*  &
+             (itabcolli2(dumic+1,dumiic,dumjjc,dumi+1,dumii,dumjj)-                   &
+             itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj)+(dum1c-real(dumic))*  &
+             (itabcolli2(dumic+1,dumiic,dumjjc,dumi,dumii+1,dumjj)-                   &
+             itabcolli2(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj))
+
+   dproc12 = itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic,dumjjc,dumi+1,dumii+1,dumjj)-                  &
+             itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp1    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+! collector density index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic,dumjjc,dumi,dumii,dumjj+1)+(dum1c-real(dumic))*  &
+             (itabcolli2(dumic+1,dumiic,dumjjc,dumi,dumii,dumjj+1)-                   &
+             itabcolli2(dumic,dumiic,dumjjc,dumi,dumii,dumjj+1))
+
+   dproc12 = itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic,dumjjc,dumi+1,dumii,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii,dumjj+1))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic,dumjjc,dumi,dumii+1,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic,dumjjc,dumi,dumii+1,dumjj+1))
+
+   dproc12 = itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic,dumjjc,dumi+1,dumii+1,dumjj+1))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp2    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+   gproc1    = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
+
+!.......................................................................................................
+! collectee rime fraction + 1
+
+   dproc11 = itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi,dumii,dumjj)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj))
+
+   dproc12 = itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi+1,dumii,dumjj)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj)+(dum1c-real(dumic))*  &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi,dumii+1,dumjj)-                   &
+             itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj))
+
+   dproc12 = itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp1    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+! collector density index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi,dumii,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii,dumjj+1))
+
+   dproc12 = itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii,dumjj+1))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc,dumi,dumii+1,dumjj+1))
+
+   dproc12 = itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc,dumi+1,dumii+1,dumjj+1))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp2    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+   gproc2  = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
+
+   rproc1  = gproc1+(dum4c-real(dumiic))*(gproc2-gproc1)
+
+!............................................................................................................
+! collectee density index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj)+(dum1c-real(dumic))*  &
+             (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi,dumii,dumjj)-                   &
+             itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj))
+
+   dproc12 = itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi+1,dumii,dumjj)-                  &
+             itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi,dumii+1,dumjj)-                  &
+             itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj))
+
+   dproc12 = itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj)-                  &
+             itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp1    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+! collector density index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi,dumii,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii,dumjj+1))
+
+   dproc12 = itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii,dumjj+1))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic,dumjjc+1,dumi,dumii+1,dumjj+1))
+
+   dproc12 = itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic,dumjjc+1,dumi+1,dumii+1,dumjj+1))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp2    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+   gproc1    = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
+
+!.......................................................................................................
+! collectee rime fraction + 1
+
+   dproc11 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi,dumii,dumjj)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj))
+
+   dproc12 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj))
+
+   dproc12 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp1    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+! collector density index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii,dumjj+1))
+
+   dproc12 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii,dumjj+1))
+
+   iproc1  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+! collector rime fraction index + 1
+
+   dproc11 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc+1,dumi,dumii+1,dumjj+1))
+
+   dproc12 = itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1)+(dum1c-real(dumic))* &
+             (itabcolli2(dumic+1,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1)-                  &
+             itabcolli2(dumic,dumiic+1,dumjjc+1,dumi+1,dumii+1,dumjj+1))
+
+   iproc2  = dproc11+(dum1-real(dumi))*(dproc12-dproc11)
+
+   tmp2    = iproc1+(dum4-real(dumii))*(iproc2-iproc1)
+
+   gproc2  = tmp1+(dum5-real(dumjj))*(tmp2-tmp1)
+
+   rproc2  = gproc1+(dum4c-real(dumiic))*(gproc2-gproc1)
+
+!..........................................................................................
+! final process rate interpolation over collectee density
+
+   proc    = rproc1+(dum5c-real(dumjjc))*(rproc2-rproc1)
+
+ endif ! index =1 or 2
+
+ END SUBROUTINE access_lookup_table_colli
+
+!==========================================================================================!
+
+ real function polysvp1(T,i_type)
+
+!-------------------------------------------
+!  COMPUTE SATURATION VAPOR PRESSURE
+!  POLYSVP1 RETURNED IN UNITS OF PA.
+!  T IS INPUT IN UNITS OF K.
+!  i_type REFERS TO SATURATION WITH RESPECT TO LIQUID (0) OR ICE (1)
+!-------------------------------------------
+
+      implicit none
+
+      real    :: DUM,T
+      integer :: i_type
+
+! REPLACE GOFF-GRATCH WITH FASTER FORMULATION FROM FLATAU ET AL. 1992, TABLE 4 (RIGHT-HAND COLUMN)
+
+! ice
+      real a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i
+      data a0i,a1i,a2i,a3i,a4i,a5i,a6i,a7i,a8i /&
+        6.11147274, 0.503160820, 0.188439774e-1, &
+        0.420895665e-3, 0.615021634e-5,0.602588177e-7, &
+        0.385852041e-9, 0.146898966e-11, 0.252751365e-14/
+
+! liquid
+      real a0,a1,a2,a3,a4,a5,a6,a7,a8
+
+! V1.7
+      data a0,a1,a2,a3,a4,a5,a6,a7,a8 /&
+        6.11239921, 0.443987641, 0.142986287e-1, &
+        0.264847430e-3, 0.302950461e-5, 0.206739458e-7, &
+        0.640689451e-10,-0.952447341e-13,-0.976195544e-15/
+      real dt
+
+!-------------------------------------------
+
+      if (i_type.EQ.1 .and. T.lt.273.15) then
+! ICE
+
+!       Flatau formulation:
+         dt       = max(-80.,t-273.16)
+         polysvp1 = a0i + dt*(a1i+dt*(a2i+dt*(a3i+dt*(a4i+dt*(a5i+dt*(a6i+dt*(a7i+       &
+                    a8i*dt)))))))
+         polysvp1 = polysvp1*100.
+
+!       Goff-Gratch formulation:
+!        POLYSVP1 = 10.**(-9.09718*(273.16/T-1.)-3.56654*                 &
+!          log10(273.16/T)+0.876793*(1.-T/273.16)+                        &
+!          log10(6.1071))*100.
+
+
+      elseif (i_type.EQ.0 .or. T.ge.273.15) then
+! LIQUID
+
+!       Flatau formulation:
+         dt       = max(-80.,t-273.16)
+         polysvp1 = a0 + dt*(a1+dt*(a2+dt*(a3+dt*(a4+dt*(a5+dt*(a6+dt*(a7+a8*dt)))))))
+         polysvp1 = polysvp1*100.
+
+!       Goff-Gratch formulation:
+!        POLYSVP1 = 10.**(-7.90298*(373.16/T-1.)+                         &
+!             5.02808*log10(373.16/T)-                                    &
+!             1.3816E-7*(10**(11.344*(1.-T/373.16))-1.)+                  &
+!             8.1328E-3*(10**(-3.49149*(373.16/T-1.))-1.)+                &
+!             log10(1013.246))*100.
+
+         endif
+
+
+ end function polysvp1
+
+!------------------------------------------------------------------------------------------!
+
+ real function gamma(X)
+!----------------------------------------------------------------------
+! THIS ROUTINE CALCULATES THE gamma FUNCTION FOR A REAL ARGUMENT X.
+!   COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1.
+!   THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE gamma
+!   FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS.  COEFFICIENTS
+!   FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED.
+!   THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2.
+!   THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE
+!   COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE
+!   MACHINE-DEPENDENT CONSTANTS.
+!----------------------------------------------------------------------
+!
+! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
+!
+! BETA   - RADIX FOR THE FLOATING-POINT REPRESENTATION
+! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS
+! XBIG   - THE LARGEST ARGUMENT FOR WHICH gamma(X) IS REPRESENTABLE
+!          IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION
+!                  gamma(XBIG) = BETA**MAXEXP
+! XINF   - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER;
+!          APPROXIMATELY BETA**MAXEXP
+! EPS    - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
+!          1.0+EPS .GT. 1.0
+! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
+!          1/XMININ IS MACHINE REPRESENTABLE
+!
+!     APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE:
+!
+!                            BETA       MAXEXP        XBIG
+!
+! CRAY-1         (S.P.)        2         8191        966.961
+! CYBER 180/855
+!   UNDER NOS    (S.P.)        2         1070        177.803
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (S.P.)        2          128        35.040
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (D.P.)        2         1024        171.624
+! IBM 3033       (D.P.)       16           63        57.574
+! VAX D-FORMAT   (D.P.)        2          127        34.844
+! VAX G-FORMAT   (D.P.)        2         1023        171.489
+!
+!                            XINF         EPS        XMININ
+!
+! CRAY-1         (S.P.)   5.45E+2465   7.11E-15    1.84E-2466
+! CYBER 180/855
+!   UNDER NOS    (S.P.)   1.26E+322    3.55E-15    3.14E-294
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (S.P.)   3.40E+38     1.19E-7     1.18E-38
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (D.P.)   1.79D+308    2.22D-16    2.23D-308
+! IBM 3033       (D.P.)   7.23D+75     2.22D-16    1.39D-76
+! VAX D-FORMAT   (D.P.)   1.70D+38     1.39D-17    5.88D-39
+! VAX G-FORMAT   (D.P.)   8.98D+307    1.11D-16    1.12D-308
+!
+!----------------------------------------------------------------------
+!
+! ERROR RETURNS
+!
+!  THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR
+!     WHEN OVERFLOW WOULD OCCUR.  THE COMPUTATION IS BELIEVED
+!     TO BE FREE OF UNDERFLOW AND OVERFLOW.
+!
+!
+!  INTRINSIC FUNCTIONS REQUIRED ARE:
+!
+!     INT, DBLE, EXP, log, REAL, SIN
+!
+!
+! REFERENCES:  AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL
+!              FUNCTIONS   W. J. CODY, LECTURE NOTES IN MATHEMATICS,
+!              506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON
+!              (ED.), SPRINGER VERLAG, BERLIN, 1976.
+!
+!              COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND
+!              SONS, NEW YORK, 1968.
+!
+!  LATEST MODIFICATION: OCTOBER 12, 1989
+!
+!  AUTHORS: W. J. CODY AND L. STOLTZ
+!           APPLIED MATHEMATICS DIVISION
+!           ARGONNE NATIONAL LABORATORY
+!           ARGONNE, IL 60439
+!
+!----------------------------------------------------------------------
+      implicit none
+      integer :: I,N
+      logical :: l_parity
+      real ::                                                       &
+          CONV,EPS,FACT,HALF,ONE,res,sum,TWELVE,                    &
+          TWO,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
+      real, dimension(7) :: C
+      real, dimension(8) :: P
+      real, dimension(8) :: Q
+      real, parameter    :: constant1 = 0.9189385332046727417803297
+
+!----------------------------------------------------------------------
+!  MATHEMATICAL CONSTANTS
+!----------------------------------------------------------------------
+      data ONE,HALF,TWELVE,TWO,ZERO/1.0E0,0.5E0,12.0E0,2.0E0,0.0E0/
+!----------------------------------------------------------------------
+!  MACHINE DEPENDENT PARAMETERS
+!----------------------------------------------------------------------
+      data XBIG,XMININ,EPS/35.040E0,1.18E-38,1.19E-7/,XINF/3.4E38/
+!----------------------------------------------------------------------
+!  NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
+!     APPROXIMATION OVER (1,2).
+!----------------------------------------------------------------------
+      data P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1,  &
+             -3.79804256470945635097577E+2,6.29331155312818442661052E+2,  &
+             8.66966202790413211295064E+2,-3.14512729688483675254357E+4,  &
+             -3.61444134186911729807069E+4,6.64561438202405440627855E+4/
+      data Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2,  &
+             -1.01515636749021914166146E+3,-3.10777167157231109440444E+3, &
+              2.25381184209801510330112E+4,4.75584627752788110767815E+3,  &
+            -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/
+!----------------------------------------------------------------------
+!  COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF).
+!----------------------------------------------------------------------
+      data C/-1.910444077728E-03,8.4171387781295E-04,                      &
+           -5.952379913043012E-04,7.93650793500350248E-04,                 &
+           -2.777777777777681622553E-03,8.333333333333333331554247E-02,    &
+            5.7083835261E-03/
+!----------------------------------------------------------------------
+!  STATEMENT FUNCTIONS FOR CONVERSION BETWEEN INTEGER AND FLOAT
+!----------------------------------------------------------------------
+      CONV(I) = REAL(I)
+      l_parity=.FALSE.
+      FACT=ONE
+      N=0
+      Y=X
+      if (Y.LE.ZERO) then
+!----------------------------------------------------------------------
+!  ARGUMENT IS NEGATIVE
+!----------------------------------------------------------------------
+        Y=-X
+        Y1=AINT(Y)
+        res=Y-Y1
+        if (res.NE.ZERO) then
+          if(Y1.NE.AINT(Y1*HALF)*TWO)l_parity=.TRUE.
+          FACT=-PI/SIN(PI*res)
+          Y=Y+ONE
+        else
+          res=XINF
+          goto 900
+        endif
+      endif
+!----------------------------------------------------------------------
+!  ARGUMENT IS POSITIVE
+!----------------------------------------------------------------------
+      if (Y.LT.EPS) then
+!----------------------------------------------------------------------
+!  ARGUMENT .LT. EPS
+!----------------------------------------------------------------------
+        if (Y.GE.XMININ) then
+          res=ONE/Y
+        else
+          res=XINF
+          goto 900
+        endif
+      elseif (Y.LT.TWELVE) then
+        Y1=Y
+        if (Y.LT.ONE) then
+!----------------------------------------------------------------------
+!  0.0 .LT. ARGUMENT .LT. 1.0
+!----------------------------------------------------------------------
+          Z=Y
+          Y=Y+ONE
+        else
+!----------------------------------------------------------------------
+!  1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY
+!----------------------------------------------------------------------
+          N=INT(Y)-1
+          Y=Y-CONV(N)
+          Z=Y-ONE
+        endif
+!----------------------------------------------------------------------
+!  EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0
+!----------------------------------------------------------------------
+        XNUM=ZERO
+        XDEN=ONE
+        do I=1,8
+          XNUM=(XNUM+P(I))*Z
+          XDEN=XDEN*Z+Q(I)
+        enddo
+        res=XNUM/XDEN+ONE
+        if (Y1.LT.Y) then
+!----------------------------------------------------------------------
+!  ADJUST RESULT FOR CASE  0.0 .LT. ARGUMENT .LT. 1.0
+!----------------------------------------------------------------------
+          res=res/Y1
+        elseif (Y1.GT.Y) then
+!----------------------------------------------------------------------
+!  ADJUST RESULT FOR CASE  2.0 .LT. ARGUMENT .LT. 12.0
+!----------------------------------------------------------------------
+          do I=1,N
+            res=res*Y
+            Y=Y+ONE
+          enddo
+        endif
+      else
+!----------------------------------------------------------------------
+!  EVALUATE FOR ARGUMENT .GE. 12.0,
+!----------------------------------------------------------------------
+        if (Y.LE.XBIG) then
+          YSQ=Y*Y
+          sum=C(7)
+          do I=1,6
+            sum=sum/YSQ+C(I)
+          enddo
+          sum=sum/Y-Y+constant1
+          sum=sum+(Y-HALF)*log(Y)
+          res=exp(sum)
+        else
+          res=XINF
+          goto 900
+        endif
+      endif
+!----------------------------------------------------------------------
+!  FINAL ADJUSTMENTS AND RETURN
+!----------------------------------------------------------------------
+      if (l_parity)res=-res
+      if (FACT.NE.ONE)res=FACT/res
+  900 gamma=res
+      return
+! ---------- LAST LINE OF gamma ----------
+
+ end function gamma
+
+!------------------------------------------------------------------------------------------!
+
+ real function DERF(X)
+
+ implicit none
+
+ real :: X
+ real, dimension(0 : 64) :: A, B
+ real :: W,T,Y
+ integer :: K,I
+      data A/                                                 &
+         0.00000000005958930743E0, -0.00000000113739022964E0, &
+         0.00000001466005199839E0, -0.00000016350354461960E0, &
+         0.00000164610044809620E0, -0.00001492559551950604E0, &
+         0.00012055331122299265E0, -0.00085483269811296660E0, &
+         0.00522397762482322257E0, -0.02686617064507733420E0, &
+         0.11283791670954881569E0, -0.37612638903183748117E0, &
+         1.12837916709551257377E0,                            &
+         0.00000000002372510631E0, -0.00000000045493253732E0, &
+         0.00000000590362766598E0, -0.00000006642090827576E0, &
+         0.00000067595634268133E0, -0.00000621188515924000E0, &
+         0.00005103883009709690E0, -0.00037015410692956173E0, &
+         0.00233307631218880978E0, -0.01254988477182192210E0, &
+         0.05657061146827041994E0, -0.21379664776456006580E0, &
+         0.84270079294971486929E0,                            &
+         0.00000000000949905026E0, -0.00000000018310229805E0, &
+         0.00000000239463074000E0, -0.00000002721444369609E0, &
+         0.00000028045522331686E0, -0.00000261830022482897E0, &
+         0.00002195455056768781E0, -0.00016358986921372656E0, &
+         0.00107052153564110318E0, -0.00608284718113590151E0, &
+         0.02986978465246258244E0, -0.13055593046562267625E0, &
+         0.67493323603965504676E0,                            &
+         0.00000000000382722073E0, -0.00000000007421598602E0, &
+         0.00000000097930574080E0, -0.00000001126008898854E0, &
+         0.00000011775134830784E0, -0.00000111992758382650E0, &
+         0.00000962023443095201E0, -0.00007404402135070773E0, &
+         0.00050689993654144881E0, -0.00307553051439272889E0, &
+         0.01668977892553165586E0, -0.08548534594781312114E0, &
+         0.56909076642393639985E0,                            &
+         0.00000000000155296588E0, -0.00000000003032205868E0, &
+         0.00000000040424830707E0, -0.00000000471135111493E0, &
+         0.00000005011915876293E0, -0.00000048722516178974E0, &
+         0.00000430683284629395E0, -0.00003445026145385764E0, &
+         0.00024879276133931664E0, -0.00162940941748079288E0, &
+         0.00988786373932350462E0, -0.05962426839442303805E0, &
+         0.49766113250947636708E0 /
+      data (B(I), I = 0, 12) /                                 &
+         -0.00000000029734388465E0,  0.00000000269776334046E0, &
+         -0.00000000640788827665E0, -0.00000001667820132100E0, &
+         -0.00000021854388148686E0,  0.00000266246030457984E0, &
+          0.00001612722157047886E0, -0.00025616361025506629E0, &
+          0.00015380842432375365E0,  0.00815533022524927908E0, &
+         -0.01402283663896319337E0, -0.19746892495383021487E0, &
+          0.71511720328842845913E0 /
+      data (B(I), I = 13, 25) /                                &
+         -0.00000000001951073787E0, -0.00000000032302692214E0, &
+          0.00000000522461866919E0,  0.00000000342940918551E0, &
+         -0.00000035772874310272E0,  0.00000019999935792654E0, &
+          0.00002687044575042908E0, -0.00011843240273775776E0, &
+         -0.00080991728956032271E0,  0.00661062970502241174E0, &
+          0.00909530922354827295E0, -0.20160072778491013140E0, &
+          0.51169696718727644908E0 /
+      data (B(I), I = 26, 38) /                                &
+         0.00000000003147682272E0, -0.00000000048465972408E0,  &
+         0.00000000063675740242E0,  0.00000003377623323271E0,  &
+        -0.00000015451139637086E0, -0.00000203340624738438E0,  &
+         0.00001947204525295057E0,  0.00002854147231653228E0,  &
+        -0.00101565063152200272E0,  0.00271187003520095655E0,  &
+         0.02328095035422810727E0, -0.16725021123116877197E0,  &
+         0.32490054966649436974E0 /
+      data (B(I), I = 39, 51) /                                &
+         0.00000000002319363370E0, -0.00000000006303206648E0,  &
+        -0.00000000264888267434E0,  0.00000002050708040581E0,  &
+         0.00000011371857327578E0, -0.00000211211337219663E0,  &
+         0.00000368797328322935E0,  0.00009823686253424796E0,  &
+        -0.00065860243990455368E0, -0.00075285814895230877E0,  &
+         0.02585434424202960464E0, -0.11637092784486193258E0,  &
+         0.18267336775296612024E0 /
+      data (B(I), I = 52, 64) /                                &
+        -0.00000000000367789363E0,  0.00000000020876046746E0,  &
+        -0.00000000193319027226E0, -0.00000000435953392472E0,  &
+         0.00000018006992266137E0, -0.00000078441223763969E0,  &
+        -0.00000675407647949153E0,  0.00008428418334440096E0,  &
+        -0.00017604388937031815E0, -0.00239729611435071610E0,  &
+         0.02064129023876022970E0, -0.06905562880005864105E0,  &
+         0.09084526782065478489E0 /
+      W = ABS(X)
+      if (W .LT. 2.2D0) then
+          T = W * W
+          K = INT(T)
+          T = T - K
+          K = K * 13
+          Y = ((((((((((((A(K) * T + A(K + 1)) * T +              &
+              A(K + 2)) * T + A(K + 3)) * T + A(K + 4)) * T +     &
+              A(K + 5)) * T + A(K + 6)) * T + A(K + 7)) * T +     &
+              A(K + 8)) * T + A(K + 9)) * T + A(K + 10)) * T +    &
+              A(K + 11)) * T + A(K + 12)) * W
+      elseif (W .LT. 6.9D0) then
+          K = INT(W)
+          T = W - K
+          K = 13 * (K - 2)
+          Y = (((((((((((B(K) * T + B(K + 1)) * T +               &
+              B(K + 2)) * T + B(K + 3)) * T + B(K + 4)) * T +     &
+              B(K + 5)) * T + B(K + 6)) * T + B(K + 7)) * T +     &
+              B(K + 8)) * T + B(K + 9)) * T + B(K + 10)) * T +    &
+              B(K + 11)) * T + B(K + 12)
+          Y = Y * Y
+          Y = Y * Y
+          Y = Y * Y
+          Y = 1 - Y * Y
+      else
+          Y = 1
+      endif
+      if (X .LT. 0) Y = -Y
+      DERF = Y
+
+ end function DERF
+
+!------------------------------------------------------------------------------------------!
+
+ logical function isnan(arg1)
+       real,intent(in) :: arg1
+       isnan=( arg1  .ne. arg1 )
+       return
+ end function isnan
+
+!------------------------------------------------------------------------------------------!
+
+!==========================================================================================!
+ subroutine icecat_destination(Qi,Di,D_nuc,deltaD_init,log_ni_add,iice_dest)
+
+ !--------------------------------------------------------------------------------------!
+ ! Returns the index of the destination ice category into which new ice is nucleated.
+ !
+ ! New ice will be nucleated into the category in which the existing ice is
+ ! closest in size to the ice being nucleated.  The exception is that if the
+ ! size difference between the nucleated ice and existing ice exceeds a threshold
+ ! value for all categories, then ice is initiated into a new category.
+ !
+ ! D_nuc        = mean diameter of new particles being added to a category
+ ! D(i)         = mean diameter of particles in category i
+ ! diff(i)      = |D(i) - D_nuc|
+ ! deltaD_init  = threshold size difference to consider a new (empty) category
+ ! mindiff      = minimum of all diff(i) (for non-empty categories)
+ !
+ ! POSSIBLE CASES                      DESTINATION CATEGORY
+ !---------------                      --------------------
+ ! case 1:  all empty                  category 1
+ ! case 2:  all full                   category with smallest diff
+ ! case 3:  partly full
+ !  case 3a:  mindiff <  diff_thrs     category with smallest diff
+ !  case 3b:  mindiff >= diff_thrs     first empty category
+ !--------------------------------------------------------------------------------------!
+
+ implicit none
+
+! arguments:
+ real, intent(in), dimension(:) :: Qi,Di
+ real, intent(in)               :: D_nuc,deltaD_init
+ integer, intent(out)           :: iice_dest
+ logical, intent(out)           :: log_ni_add
+
+! local variables:
+ logical                        :: all_full,all_empty
+ integer                        :: i_firstEmptyCategory,iice,i_mindiff,n_cat
+ real                           :: mindiff,diff
+ real, parameter                :: qsmall_loc = 1.e-14
+
+ !--------------------------------------------------------------------------------------!
+
+ n_cat      = size(Qi)
+ log_ni_add = .true.
+ iice_dest  = -99
+
+!-- test:
+! iice_dest = 1
+! return
+!==
+
+ if (sum(Qi(:))nsmall or Q>qsmall.and.NT_low .and. T(i,k)=0. .and. Qv(i,k)= x_low .and. Qc(i,k) < Q_high .and.                          &
+! !                 Nc(i,k) >= x_low .and. QN(i,k) < Q_high .and.                          &  ! (for prog Nc)
+!                   Qr(i,k) >= x_low .and. Qr(i,k) < Q_high .and.                          &
+!                   Nr(i,k) >= x_lOw .and. Nr(i,k) < N_high)) then
+!            write(6,'(a48,4i5,4e15.6)') '** WARNING IN P3_MAIN -- src,i,k,step,Qc,Qr,Nr: ', &
+!               source_ind,i,k,timestepcount,Qc(i,k),Qr(i,k),Nr(i,k)
+!            badvalue_found = .true.
+!         endif
+!        do iice = 1,ncat
+!-- for strict testing:
+!            if (.not.(Qitot(i,k,iice) >= x_low .and. Qitot(i,k,iice) < Q_high .and.       &
+!                      Qirim(i,k,iice) >= x_low .and. Qirim(i,k,iice) < Q_high .and.       &
+!                      Nitot(i,k,iice) >= x_low .and. Nitot(i,k,iice) < N_high .and.       &
+!                      Birim(i,k,iice) >= x_low .and. Birim(i,k,iice) < B_high)) then
+!-- for "relaxed" testing (specifically, to avoid trapping understandable Qi-Ni values after microphysics source/sink section:
+!            if (.not.(Qitot(i,k,iice) >= x_low .and. Qitot(i,k,iice) < Q_high .and.       &
+!                      Qirim(i,k,iice) >= x_low .and. Qirim(i,k,iice) < Q_high .and.       &
+!                      Nitot(i,k,iice) >= x_low .and. Nitot(i,k,iice) < N_high .and.       &
+!                      Birim(i,k,iice) >= x_low .and. Birim(i,k,iice) < B_high) .and.      &
+!                .not.(Qitot(i,k,iice)<1.e-4 .and. Nitot(i,k,iice)<0.)      ) then
+! !==
+!               write(6,'(a68,5i5,4e15.6)') '** WARNING IN P3_MAIN -- src,i,k,step,iice,Qitot,Qirim,Nitot,Birim: ',  &
+!                  source_ind,i,k,timestepcount,iice,Qitot(i,k,iice),Qirim(i,k,iice),Nitot(i,k,iice),Birim(i,k,iice)
+!               badvalue_found = .true.
+!            endif
+!        enddo
+!        if (badvalue_found) trap = .true.
+
+
+      ! check consistency amongst moments
+! ! !       if (check_consistency) then
+! !         if (.false.) then
+! ! !-- future; prog Nc
+! ! !          if ((Qc(i,k)>qsmall.and.Nc(i,k)nsmall)) then
+! ! !             print*,'** WARNING IN MICRO **'
+! ! !             print*, '** src,i,k,Qc,Nc: ',source_ind,i,k,Qc(i,k),Nc(i,k)
+! ! !             trap = .true.
+! ! !           endif
+! ! !==
+! !            if ((Qr(i,k)>qsmall.and.Nr(i,k)nsmall)) then
+! !               print*,'** WARNING IN P3_MAIN **'
+! !               print*, '** src,i,k,Qr,Nr: ',source_ind,i,k,Qr(i,k),Nr(i,k)
+! !               trap = .true.
+! !            endif
+! !            do iice = 1,ncat
+! !               if ( (Qitot(i,k,iice)>qsmall.and.Nitot(i,k,iice)nsmall)) then
+! !                  print*,'** WARNING IN P3_MAIN **'
+! !                  print*, '** src,i,k,iice,Qitot,Nitot: ',source_ind,i,k,iice,            &
+! !                   Qitot(i,k,iice),Nitot(i,k,iice)
+! !                  trap = .true.
+! !               endif
+! !               if ( (Qirim(i,k,iice)>qsmall.and.Birim(i,k,iice)bsmall)) then
+! !                  print*, '** src,i,k,iice,Qirim,Birim: ',source_ind,i,k,iice,            &
+! !                   Qirim(i,k,iice),Birim(i,k,iice)
+! !                  trap = .true.
+! !               endif
+! !            enddo
+! !         endif !if (check_consistency)
+
+  enddo k_loop
+
+  if (trap .and. force_abort) then
+     print*
+     print*,'** DEBUG TRAP IN P3_MAIN, s/r CHECK_VALUES -- source: ',source_ind
+     print*
+     if (source_ind/=100) stop
+  endif
+
+ end subroutine check_values
+!===========================================================================================
+
+ END MODULE MODULE_MP_P3   !WRF
+!END MODULE MP_P3          !GEM
diff --git a/wrfv2_fire/phys/module_mp_thompson.F b/wrfv2_fire/phys/module_mp_thompson.F
index f8c124ea..775726a5 100644
--- a/wrfv2_fire/phys/module_mp_thompson.F
+++ b/wrfv2_fire/phys/module_mp_thompson.F
@@ -36,7 +36,7 @@
 !.. Remaining values should probably be left alone.
 !..
 !..Author: Greg Thompson, NCAR-RAL, gthompsn@ucar.edu, 303-497-2805
-!..Last modified: 09 Nov 2015   Aerosol additions to v3.5.1 code 9/2013
+!..Last modified: 04 Aug 2017   Aerosol additions to v3.5.1 code 9/2013
 !..                 Cloud fraction additions 11/2014 part of pre-v3.7
 !+---+-----------------------------------------------------------------+
 !wrft:model_layer:physics
@@ -139,7 +139,7 @@ MODULE module_mp_thompson
 
 !..Capacitance of sphere and plates/aggregates: D**3, D**2
       REAL, PARAMETER, PRIVATE:: C_cube = 0.5
-      REAL, PARAMETER, PRIVATE:: C_sqrd = 0.3
+      REAL, PARAMETER, PRIVATE:: C_sqrd = 0.15
 
 !..Collection efficiencies.  Rain/snow/graupel collection of cloud
 !.. droplets use variables (Ef_rw, Ef_sw, Ef_gw respectively) and
@@ -1598,6 +1598,18 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
       enddo
 #endif
 
+!..Bug fix (2016Jun15), prevent use of uninitialized value(s) of snow moments.
+      do k = kts, kte
+         smo0(k) = 0.
+         smo1(k) = 0.
+         smo2(k) = 0.
+         smob(k) = 0.
+         smoc(k) = 0.
+         smod(k) = 0.
+         smoe(k) = 0.
+         smof(k) = 0.
+      enddo
+
 !+---+-----------------------------------------------------------------+
 !..Put column of data into local arrays.
 !+---+-----------------------------------------------------------------+
@@ -1637,6 +1649,10 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
             no_micro = .false.
             ri(k) = qi1d(k)*rho(k)
             ni(k) = MAX(R2, ni1d(k)*rho(k))
+            if (ni(k).le. R2) then
+               lami = cie(2)/25.E-6
+               ni(k) = MIN(499.D3, cig(1)*oig2*ri(k)/am_i*lami**bm_i)
+            endif
             L_qi(k) = .true.
             lami = (am_i*cig(2)*oig1*ni(k)/ri(k))**obmi
             ilami = 1./lami
@@ -1660,6 +1676,11 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
             no_micro = .false.
             rr(k) = qr1d(k)*rho(k)
             nr(k) = MAX(R2, nr1d(k)*rho(k))
+            if (nr(k).le. R2) then
+               mvd_r(k) = 1.0E-3
+               lamr = (3.0 + mu_r + 0.672) / mvd_r(k)
+               nr(k) = crg(2)*org3*rr(k)*lamr**bm_r / am_r
+            endif
             L_qr(k) = .true.
             lamr = (am_r*crg(3)*org2*nr(k)/rr(k))**obmr
             mvd_r(k) = (3.0 + mu_r + 0.672) / lamr
@@ -1846,8 +1867,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
 !..Calculate y-intercept, slope values for graupel.
 !+---+-----------------------------------------------------------------+
       N0_min = gonv_max
+      k_0 = kts
+      do k = kte, kts, -1
+         if (temp(k).ge.270.65) k_0 = MAX(k_0, k)
+      enddo
       do k = kte, kts, -1
-         if (temp(k).lt.270.65 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then
+         if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then
             xslw1 = 4.01 + alog10(mvd_r(k))
          else
             xslw1 = 0.01
@@ -1887,9 +1912,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
          if (L_qr(k) .and. mvd_r(k).gt. D0r) then
 !-GT      Ef_rr = 1.0
 !-GT      if (mvd_r(k) .gt. 1500.0E-6) then
-             Ef_rr = 2.0 - EXP(2300.0*(mvd_r(k)-1600.0E-6))
+             Ef_rr = 1.0 - EXP(2300.0*(mvd_r(k)-1950.0E-6))
 !-GT      endif
-          pnr_rcr(k) = Ef_rr * 0.5*nr(k)*rr(k)
+          pnr_rcr(k) = Ef_rr * 2.0*nr(k)*rr(k)
          endif
 
          mvd_c(k) = D0c
@@ -2293,7 +2318,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
 !..Deposition nucleation of dust/mineral from DeMott et al (2010)
 !.. we may need to relax the temperature and ssati constraints.
           if ( (ssati(k).ge. 0.25) .or. (ssatw(k).gt. eps &
-                                .and. temp(k).lt.261.15) ) then
+                                .and. temp(k).lt.253.15) ) then
            if (dustyIce .AND. is_aerosol_aware) then
             xnc = iceDeMott(tempc,qv(k),qvs(k),qvsi(k),rho(k),nifa(k))
            else
@@ -2356,7 +2381,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
 !..Deposition/sublimation of snow/graupel follows Srivastava & Coen
 !.. (1992).
           if (L_qs(k)) then
-           C_snow = C_sqrd + (tempc+15.)*(C_cube-C_sqrd)/(-30.+15.)
+           C_snow = C_sqrd + (tempc+1.5)*(C_cube-C_sqrd)/(-30.+1.5)
            C_snow = MAX(C_sqrd, MIN(C_snow, C_cube))
            prs_sde(k) = C_snow*t1_subl*diffu(k)*ssati(k)*rvs &
                         * (t1_qs_sd*smo1(k) &
@@ -2423,14 +2448,14 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
           endif
 
 !..A portion of rimed snow converts to graupel but some remains snow.
-!.. Interp from 5 to 75% as riming factor increases from 5.0 to 30.0
-!.. 0.028 came from (.75-.05)/(30.-5.).  This remains ad-hoc and should
+!.. Interp from 15 to 95% as riming factor increases from 2.0 to 30.0
+!.. 0.028 came from (.95-.15)/(30.-2.).  This remains ad-hoc and should
 !.. be revisited.
-          if (prs_scw(k).gt.5.0*prs_sde(k) .and. &
+          if (prs_scw(k).gt.2.0*prs_sde(k) .and. &
                          prs_sde(k).gt.eps) then
            r_frac = MIN(30.0D0, prs_scw(k)/prs_sde(k))
-           g_frac = MIN(0.75, 0.05 + (r_frac-5.)*.028)
-           vts_boost(k) = MIN(1.5, 1.1 + (r_frac-5.)*.016)
+           g_frac = MIN(0.95, 0.15 + (r_frac-2.)*.028)
+           vts_boost(k) = MIN(1.5, 1.1 + (r_frac-2.)*.016)
            prg_scw(k) = g_frac*prs_scw(k)
            prs_scw(k) = (1. - g_frac)*prs_scw(k)
           endif
@@ -2445,9 +2470,9 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
            prr_sml(k) = prr_sml(k) + 4218.*olfus*tempc &
                                    * (prr_rcs(k)+prs_scw(k))
            prr_sml(k) = MIN(DBLE(rs(k)*odts), MAX(0.D0, prr_sml(k)))
-           pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.75*tempc)      ! RAIN2M
+           pnr_sml(k) = smo0(k)/rs(k)*prr_sml(k) * 10.0**(-0.25*tempc)      ! RAIN2M
            pnr_sml(k) = MIN(DBLE(smo0(k)*odts), pnr_sml(k))
-           if (tempc.gt.3.5 .or. rs(k).lt.0.005E-3) pnr_sml(k)=0.0
+!          if (tempc.gt.3.5 .or. rs(k).lt.0.005E-3) pnr_sml(k)=0.0
 
            if (ssati(k).lt. 0.) then
             prs_sde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
@@ -2465,8 +2490,8 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
 !-GT                               * (prr_rcg(k)+prg_gcw(k))
            prr_gml(k) = MIN(DBLE(rg(k)*odts), MAX(0.D0, prr_gml(k)))
            pnr_gml(k) = N0_g(k)*cgg(2)*ilamg(k)**cge(2) / rg(k)         &   ! RAIN2M
-                      * prr_gml(k) * 10.0**(-0.25*tempc)
-           if (tempc.gt.7.5 .or. rg(k).lt.0.005E-3) pnr_gml(k)=0.0
+                      * prr_gml(k) * 10.0**(-0.5*tempc)
+!          if (tempc.gt.7.5 .or. rg(k).lt.0.005E-3) pnr_gml(k)=0.0
 
            if (ssati(k).lt. 0.) then
             prg_gde(k) = C_cube*t1_subl*diffu(k)*ssati(k)*rvs &
@@ -2502,7 +2527,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
 !.. supersat again.
          sump = pri_inu(k) + pri_ide(k) + prs_ide(k) &
               + prs_sde(k) + prg_gde(k) + pri_iha(k)
-         rate_max = (qv(k)-qvsi(k))*odts*0.999
+         rate_max = (qv(k)-qvsi(k))*rho(k)*odts*0.999
          if ( (sump.gt. eps .and. sump.gt. rate_max) .or. &
               (sump.lt. -eps .and. sump.lt. rate_max) ) then
           ratio = rate_max/sump
@@ -2666,7 +2691,7 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
                       * orho
 
 !..Cloud ice mass/number balance; keep mass-wt mean size between
-!.. 20 and 300 microns.  Also no more than 250 xtals per liter.
+!.. 5 and 300 microns.  Also no more than 500 xtals per liter.
          xri=MAX(R1,(qi1d(k) + qiten(k)*dtsave)*rho(k))
          xni=MAX(R2,(ni1d(k) + niten(k)*dtsave)*rho(k))
          if (xri.gt. R1) then
@@ -2852,6 +2877,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
 !.. intercepts/slopes of graupel and rain.
 !+---+-----------------------------------------------------------------+
       if (.not. iiwarm) then
+      do k = kts, kte
+         smo2(k) = 0.
+         smob(k) = 0.
+         smoc(k) = 0.
+         smod(k) = 0.
+      enddo
       do k = kts, kte
          if (.not. L_qs(k)) CYCLE
          tc0 = MIN(-0.1, temp(k)-273.15)
@@ -2907,8 +2938,12 @@ subroutine mp_thompson (qv1d, qc1d, qi1d, qr1d, qs1d, qg1d, ni1d, &
 !..Calculate y-intercept, slope values for graupel.
 !+---+-----------------------------------------------------------------+
       N0_min = gonv_max
+      k_0 = kts
       do k = kte, kts, -1
-         if (temp(k).lt.270.65 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then
+         if (temp(k).ge.270.65) k_0 = MAX(k_0, k)
+      enddo
+      do k = kte, kts, -1
+         if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then
             xslw1 = 4.01 + alog10(mvd_r(k))
          else
             xslw1 = 0.01
@@ -4123,7 +4158,7 @@ subroutine freezeH2O
                do n2 = nbr, 1, -1
                   N_r(n2) = N0_r*Dr(n2)**mu_r*DEXP(-lamr*Dr(n2))*dtr(n2)
                   vol = massr(n2)*orho_w
-                  prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp)
+                  prob = MAX(0.0D0, 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp))
                   if (massr(n2) .lt. xm0g) then
                      sumn1 = sumn1 + prob*N_r(n2)
                      sum1 = sum1 + prob*N_r(n2)*massr(n2)
@@ -4149,7 +4184,7 @@ subroutine freezeH2O
                sumn2 = 0.0d0
                do n = nbc, 1, -1
                   vol = massc(n)*orho_w
-                  prob = 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp)
+                  prob = MAX(0.0D0, 1.0D0 - DEXP(-120.0D0*vol*5.2D-4 * Texp))
                   N_c(n) = N0_c*Dc(n)**nu_c*EXP(-lamc*Dc(n))*dtc(n)
                   sumn2 = MIN(t_Nc(j), sumn2 + prob*N_c(n))
                   sum1 = sum1 + prob*N_c(n)*massc(n)
@@ -4788,6 +4823,7 @@ REAL FUNCTION RSLF(P,T)
 
 !      ESL=612.2*EXP(17.67*X/(T-29.65))
       ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
+      ESL=MIN(ESL, P*0.15)        ! Even with P=1050mb and T=55C, the sat. vap. pres only contributes to ~15% of total pres.
       RSLF=.622*ESL/(P-ESL)
 
 !    ALTERNATIVE
@@ -4820,6 +4856,7 @@ REAL FUNCTION RSIF(P,T)
 
       X=MAX(-80.,T-273.16)
       ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8)))))))
+      ESI=MIN(ESI, P*0.15)
       RSIF=.622*ESI/(P-ESI)
 
 !    ALTERNATIVE
@@ -4858,43 +4895,43 @@ real function iceDeMott(tempc, qv, qvs, qvsi, rho, nifa)
 !+---+
 
       xni = 0.0
-      satw = qv/qvs
-      sati = qv/qvsi
-      siw = qvs/qvsi
-      p_x = -1.0261+(3.1656e-3*tempc)+(5.3938e-4*(tempc*tempc))         &
-                 +  (8.2584e-6*(tempc*tempc*tempc))
-      si0x = 1.+(10.**p_x)
-      if (sati.ge.si0x .and. satw.lt.0.985) then
-         dtt = delta_p (tempc, T0x, T0x+delT, 1., hdm)
-         dsi = delta_p (sati, Si0x, Si0x+delSi, 0., 1.)
-         dsw = delta_p (satw, Sw0x, 1., 0., 1.)
-         fc = dtt*dsi*0.5
-         hx = min(fc+((1.-fc)*dsw), 1.)
-         ntilde = p_c1*p_gam*((exp(12.96*(sati-1.1)))**0.3) / p_rho_c
-         if (tempc .le. y1p) then
-            n_in = ntilde
-         elseif (tempc .ge. y2p) then
-            n_in = p_psi*p_c1*exp(12.96*(sati-1.)-0.639)
-         else
-            if (tempc .le. -30.) then
-               nmax = p_c1*p_gam*(exp(12.96*(siw-1.1)))**0.3/p_rho_c
-            else
-               nmax = p_psi*p_c1*exp(12.96*(siw-1.)-0.639)
-            endif
-            ntilde = MIN(ntilde, nmax)
-            nhat = MIN(p_psi*p_c1*exp(12.96*(sati-1.)-0.639), nmax)
-            dab = delta_p (tempc, y1p, y2p, aap, bbp)
-            n_in = MIN(nhat*(ntilde/nhat)**dab, nmax)
-         endif
-         mux = hx*p_alpha*n_in*rho
-         xni = mux*((6700.*nifa)-200.)/((6700.*5.E5)-200.)
-      elseif (satw.ge.0.985 .and. tempc.gt.HGFR-273.15) then
+!     satw = qv/qvs
+!     sati = qv/qvsi
+!     siw = qvs/qvsi
+!     p_x = -1.0261+(3.1656e-3*tempc)+(5.3938e-4*(tempc*tempc))         &
+!                +  (8.2584e-6*(tempc*tempc*tempc))
+!     si0x = 1.+(10.**p_x)
+!     if (sati.ge.si0x .and. satw.lt.0.985) then
+!        dtt = delta_p (tempc, T0x, T0x+delT, 1., hdm)
+!        dsi = delta_p (sati, Si0x, Si0x+delSi, 0., 1.)
+!        dsw = delta_p (satw, Sw0x, 1., 0., 1.)
+!        fc = dtt*dsi*0.5
+!        hx = min(fc+((1.-fc)*dsw), 1.)
+!        ntilde = p_c1*p_gam*((exp(12.96*(sati-1.1)))**0.3) / p_rho_c
+!        if (tempc .le. y1p) then
+!           n_in = ntilde
+!        elseif (tempc .ge. y2p) then
+!           n_in = p_psi*p_c1*exp(12.96*(sati-1.)-0.639)
+!        else
+!           if (tempc .le. -30.) then
+!              nmax = p_c1*p_gam*(exp(12.96*(siw-1.1)))**0.3/p_rho_c
+!           else
+!              nmax = p_psi*p_c1*exp(12.96*(siw-1.)-0.639)
+!           endif
+!           ntilde = MIN(ntilde, nmax)
+!           nhat = MIN(p_psi*p_c1*exp(12.96*(sati-1.)-0.639), nmax)
+!           dab = delta_p (tempc, y1p, y2p, aap, bbp)
+!           n_in = MIN(nhat*(ntilde/nhat)**dab, nmax)
+!        endif
+!        mux = hx*p_alpha*n_in*rho
+!        xni = mux*((6700.*nifa)-200.)/((6700.*5.E5)-200.)
+!     elseif (satw.ge.0.985 .and. tempc.gt.HGFR-273.15) then
          nifa_cc = nifa*RHO_NOT0*1.E-6/rho
-         xni  = 3.*nifa_cc**(1.25)*exp((0.46*(-tempc))-11.6)             !  [DeMott, 2015]
-!        xni = (5.94e-5*(-tempc)**3.33)                                 &
-!                   * (nifa_cc**((-0.0264*(tempc))+0.0033))
+!        xni  = 3.*nifa_cc**(1.25)*exp((0.46*(-tempc))-11.6)              !  [DeMott, 2015]
+         xni = (5.94e-5*(-tempc)**3.33)                                 & !  [DeMott, 2010]
+                    * (nifa_cc**((-0.0264*(tempc))+0.0033))
          xni = xni*rho/RHO_NOT0 * 1000.
-      endif
+!     endif
 
       iceDeMott = MAX(0., xni)
 
@@ -4922,7 +4959,7 @@ real function iceKoop(temp, qv, qvs, naero, dt)
      &           - (26924.0*delta_aw*delta_aw)                          &
      &           + (29180.0*delta_aw*delta_aw*delta_aw)
       log_J_rate = MIN(20.0, log_J_rate)
-      J_rate     = 0.01*(10.**log_J_rate)                                ! cm-3 s-1
+      J_rate     = 10.**log_J_rate                                       ! cm-3 s-1
       prob_h     = MIN(1.-exp(-J_rate*ar_volume*DT), 1.)
       if (prob_h .gt. 0.) then
          xni     = MIN(prob_h*naero, 1000.E3)
@@ -5230,8 +5267,12 @@ subroutine calc_refl10cm (qv1d, qc1d, qr1d, nr1d, qs1d, qg1d,     &
 !+---+-----------------------------------------------------------------+
 
       N0_min = gonv_max
+      k_0 = kts
+      do k = kte, kts, -1
+         if (temp(k).ge.270.65) k_0 = MAX(k_0, k)
+      enddo
       do k = kte, kts, -1
-         if (temp(k).lt.270.65 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then
+         if (k.gt.k_0 .and. L_qr(k) .and. mvd_r(k).gt.100.E-6) then
             xslw1 = 4.01 + alog10(mvd_r(k))
          else
             xslw1 = 0.01
diff --git a/wrfv2_fire/phys/module_mp_wdm5.F b/wrfv2_fire/phys/module_mp_wdm5.F
index 4e0c2df0..ee1d84f3 100644
--- a/wrfv2_fire/phys/module_mp_wdm5.F
+++ b/wrfv2_fire/phys/module_mp_wdm5.F
@@ -883,7 +883,11 @@ SUBROUTINE wdm52D(t, q, qci, qrs, ncr, den, p, delz             &
             snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000.+snow(i)
           endif
         endif 
-        if(fallsum.gt.0.)sr(i)= tstepsnow(i)/(rainncv(i)+1.e-12)
+        IF ( PRESENT (snowncv) ) THEN
+          if(fallsum.gt.0.) sr(i) = snowncv(i)/(rainncv(i)+1.e-12)
+        ELSE
+          if(fallsum.gt.0.)sr(i)= tstepsnow(i)/(rainncv(i)+1.e-12)
+        ENDIF
       enddo
 !
 !---------------------------------------------------------------
diff --git a/wrfv2_fire/phys/module_mp_wdm6.F b/wrfv2_fire/phys/module_mp_wdm6.F
index 1563681e..757b3354 100644
--- a/wrfv2_fire/phys/module_mp_wdm6.F
+++ b/wrfv2_fire/phys/module_mp_wdm6.F
@@ -908,8 +908,11 @@ SUBROUTINE wdm62D(t, q, qci, qrs, ncr, den, p, delz             &
             graupel(i) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i)
           ENDIF
         ENDIF
-        if(fallsum.gt.0.) sr(i) = (tstepsnow(i) + tstepgraup(i))               &
-                                  /(rainncv(i)+1.e-12)
+        IF ( PRESENT (snowncv)) THEN
+          if(fallsum.gt.0.)sr(i)=(snowncv(i) + graupelncv(i))/(rainncv(i)+1.e-12)
+        ELSE
+          if(fallsum.gt.0.)sr(i)=(tstepsnow(i) + tstepgraup(i))/(rainncv(i)+1.e-12)
+        ENDIF
       enddo
 !
 !---------------------------------------------------------------
@@ -1501,7 +1504,7 @@ SUBROUTINE wdm62D(t, q, qci, qrs, ncr, den, p, delz             &
 !
 !----------------------------------------------------------------
 !     check mass conservation of generation terms and feedback to the
-!     large scale
+!     large scale
 !
       do k = kts, kte
         do i = its, ite
diff --git a/wrfv2_fire/phys/module_mp_wsm3.F b/wrfv2_fire/phys/module_mp_wsm3.F
index c7ee838c..1d38089b 100644
--- a/wrfv2_fire/phys/module_mp_wsm3.F
+++ b/wrfv2_fire/phys/module_mp_wsm3.F
@@ -616,8 +616,11 @@ SUBROUTINE wsm32D(t, q                                                       &
           snow(i) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i)
         ENDIF
         endif
-!       if(fallsum.gt.0.) sr(i) = snowncv(i)/(rainncv(i)+1.e-12)
-        if(fallsum.gt.0.) sr(i) = tstepsnow(i)/(rainncv(i)+1.e-12)
+        IF ( PRESENT (snowncv) ) THEN
+          if(fallsum.gt.0.) sr(i) = snowncv(i)/(rainncv(i)+1.e-12)
+        ELSE
+          if(fallsum.gt.0.) sr(i) = tstepsnow(i)/(rainncv(i)+1.e-12)
+        ENDIF
       enddo
 !
 !----------------------------------------------------------------
diff --git a/wrfv2_fire/phys/module_mp_wsm5.F b/wrfv2_fire/phys/module_mp_wsm5.F
index 7612ed3c..c10dbe19 100644
--- a/wrfv2_fire/phys/module_mp_wsm5.F
+++ b/wrfv2_fire/phys/module_mp_wsm5.F
@@ -773,8 +773,11 @@ SUBROUTINE wsm52D(t, q                                          &
           snow(i,lat) = fallsum_qsi*delz(i,kts)/denr*dtcld*1000. + snow(i,lat)
         ENDIF
         endif
-!       if(fallsum.gt.0.)sr(i)=snowncv(i,lat)/(rainncv(i)+1.e-12)
-        if(fallsum.gt.0.)sr(i)=tstepsnow(i)/(rainncv(i)+1.e-12)
+        IF ( PRESENT (snowncv) ) THEN
+          if(fallsum.gt.0.)sr(i)=snowncv(i,lat)/(rainncv(i)+1.e-12)
+        ELSE
+          if(fallsum.gt.0.)sr(i)=tstepsnow(i)/(rainncv(i)+1.e-12)
+        ENDIF
       enddo
 !
 !---------------------------------------------------------------
diff --git a/wrfv2_fire/phys/module_mp_wsm6.F b/wrfv2_fire/phys/module_mp_wsm6.F
index e136f42d..5c228941 100644
--- a/wrfv2_fire/phys/module_mp_wsm6.F
+++ b/wrfv2_fire/phys/module_mp_wsm6.F
@@ -76,6 +76,9 @@ SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg                        &
                  ,ids,ide, jds,jde, kds,kde                        &
                  ,ims,ime, jms,jme, kms,kme                        &
                  ,its,ite, jts,jte, kts,kte                        &
+#ifdef WRF_CHEM
+                 ,evapprod, rainprod                               &
+#endif
                                                                    )
 !-------------------------------------------------------------------
   IMPLICIT NONE
@@ -141,6 +144,17 @@ SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg                        &
   REAL, DIMENSION( ims:ime , jms:jme ), OPTIONAL,                 &
         INTENT(INOUT) ::                                 graupel, &
                                                       graupelncv
+
+#ifdef WRF_CHEM
+  REAL, DIMENSION( ims:ime , kms:kme, jms:jme ), INTENT(INOUT) :: &
+                                                      rainprod,   &
+                                                      evapprod
+! local variable
+  REAL, DIMENSION( its:ite , kts:kte )                 ::         &
+                                                      rainprod2d, &
+                                                      evapprod2d
+#endif
+
 ! LOCAL VAR
   REAL, DIMENSION( its:ite , kts:kte ) ::   t
   REAL, DIMENSION( its:ite , kts:kte, 2 ) ::   qci
@@ -186,6 +200,9 @@ SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg                        &
                     ,its,ite, jts,jte, kts,kte                     &
                     ,snow,snowncv                                  &
                     ,graupel,graupelncv                            &
+#ifdef WRF_CHEM
+                   ,rainprod2d, evapprod2d                        &
+#endif
                                                                    )
          DO K=kts,kte
          DO I=its,ite
@@ -243,7 +260,14 @@ SUBROUTINE wsm6(th, q, qc, qr, qi, qs, qg                        &
           enddo   
         endif     ! has_reqc, etc...
 !+---+-----------------------------------------------------------------+
-
+#ifdef WRF_CHEM
+        do i=its,ite
+          do k=kts,kte
+            rainprod(i,k,j) = rainprod2d(i,k)
+            evapprod(i,k,j) = evapprod2d(i,k)
+          enddo
+        enddo
+#endif
       ENDDO
   END SUBROUTINE wsm6
 !===================================================================
@@ -262,6 +286,9 @@ SUBROUTINE wsm62D(t, q                                          &
                    ,its,ite, jts,jte, kts,kte                     &
                    ,snow,snowncv                                  &
                    ,graupel,graupelncv                            &
+#ifdef WRF_CHEM
+                   ,rainprod2d, evapprod2d                        &
+#endif
                                                                   )
 !-------------------------------------------------------------------
   IMPLICIT NONE
@@ -353,6 +380,13 @@ SUBROUTINE wsm62D(t, q                                          &
   REAL, DIMENSION( ims:ime, jms:jme ), OPTIONAL,                  &
         INTENT(INOUT) ::                                 graupel, &
                                                       graupelncv
+
+#ifdef WRF_CHEM
+  REAL, DIMENSION( its:ite , kts:kte ), INTENT(INOUT)  ::         &
+                                                      rainprod2d, &
+                                                      evapprod2d
+#endif
+
 ! LOCAL VAR
   REAL, DIMENSION( its:ite , kts:kte , 3) ::                      &
                                                               rh, &
@@ -791,8 +825,11 @@ SUBROUTINE wsm62D(t, q                                          &
           graupel(i,lat) = fallsum_qg*delz(i,kts)/denr*dtcld*1000. + graupel(i,lat)
         ENDIF
         endif
-!       if(fallsum.gt.0.)sr(i)=(snowncv(i,lat) + graupelncv(i,lat))/(rainncv(i)+1.e-12)
-        if(fallsum.gt.0.)sr(i)=(tstepsnow(i) + tstepgraup(i))/(rainncv(i)+1.e-12)
+        IF ( PRESENT (snowncv)) THEN
+          if(fallsum.gt.0.)sr(i)=(snowncv(i,lat) + graupelncv(i,lat))/(rainncv(i)+1.e-12)
+        ELSE
+          if(fallsum.gt.0.)sr(i)=(tstepsnow(i) + tstepgraup(i))/(rainncv(i)+1.e-12)
+        ENDIF
       enddo
 !
 !---------------------------------------------------------------
@@ -1457,6 +1494,12 @@ SUBROUTINE wsm62D(t, q                                          &
         enddo
       enddo
       enddo                  ! big loops
+
+#ifdef WRF_CHEM
+      rainprod2d = praut+pracw+praci+psaci+pgaci+psacw+pgacw+paacw+psaut
+      evapprod2d = -(prevp+psevp+pgevp+psdep+pgdep)
+#endif
+
   END SUBROUTINE wsm62d
 ! ...................................................................
       REAL FUNCTION rgmma(x)
diff --git a/wrfv2_fire/phys/module_pbl_driver.F b/wrfv2_fire/phys/module_pbl_driver.F
index 05f53a61..4f5de094 100644
--- a/wrfv2_fire/phys/module_pbl_driver.F
+++ b/wrfv2_fire/phys/module_pbl_driver.F
@@ -12,6 +12,7 @@ SUBROUTINE pbl_driver(                                          &
                  ,rublten,rvblten,rthblten                         &
                  ,tsk,xland,znt                                    &
 #if (HWRF==1)
+                 ,msang,scurx,scury,iwavecpl,lcurr_sf              &
                  ,mznt                                             &
 #endif
                  ,ht                                               &   
@@ -41,16 +42,17 @@ SUBROUTINE pbl_driver(                                          &
                  ,qke,Sh3d                                         &
                  ,qke_adv,bl_mynn_tkeadvect                        & !ACF for QKE advection
                  ,tsq,qsq,cov,rmol,ch,qcg,grav_settling            & 
-                 ,dqke,qWT,qSHEAR,qBUOY,qDISS,bl_mynn_tkebudget    & ! JOE - MYNN TKE budget
-                 ,bl_mynn_cloudpdf                                 & ! JOE - cloud PDF tests
-                 ,bl_mynn_mixlength                                & ! JAYMES
-                 ,icloud_bl,qc_bl,cldfra_bl                        & ! JOE-subgrid bl clouds
+                 ,dqke,qWT,qSHEAR,qBUOY,qDISS,bl_mynn_tkebudget    &
+                 ,bl_mynn_cloudpdf                                 &
+                 ,bl_mynn_mixlength                                &
+                 ,icloud_bl,qc_bl,cldfra_bl                        &
                  ,bl_mynn_edmf,bl_mynn_edmf_mom,bl_mynn_edmf_tke   &
-                 ,bl_mynn_edmf_part                                & !JOE- MYNN edmf
-                 ,bl_mynn_cloudmix,bl_mynn_mixqt                   & !JOE- MYNN cloud methods
-                 ,edmf_a,edmf_w,edmf_thl                           & !JOE- MYNN edmf
-                 ,edmf_qt,edmf_ent,edmf_qc                         & !JOE- MYNN edmf
-                 ,vdfg                                             & ! Katata- fog deposition
+                 ,bl_mynn_edmf_part                                &
+                 ,bl_mynn_cloudmix,bl_mynn_mixqt                   &
+                 ,edmf_a,edmf_w,edmf_thl                           &
+                 ,edmf_qt,edmf_ent,edmf_qc                         &
+                 ,vdfg                                             &
+                 ,spp_pbl,pattern_spp_pbl                          &
 #if (NMM_CORE==1)
                  ,DISHEAT                                          &
                  ,HPBL2D, EVAP2D, HEAT2D, RC2D                     &   !Kwon FOR SHAL. CON.
@@ -139,7 +141,7 @@ SUBROUTINE pbl_driver(                                          &
    USE module_state_description, ONLY :                            &
                    YSUSCHEME,MRFSCHEME,GFSSCHEME,MYJPBLSCHEME,ACMPBLSCHEME &
                    , QNSEPBLSCHEME, p_qi,param_first_scalar &
-                   , TEMFPBLSCHEME, GFS2011SCHEME                         &
+                   , TEMFPBLSCHEME, GFSEDMFSCHEME           &
                    , CAMUWPBLSCHEME                                       &
                    , FITCHSCHEME, SHINHONGSCHEME                          &
                    , GBMPBLSCHEME, MYJSFCSCHEME
@@ -155,7 +157,9 @@ SUBROUTINE pbl_driver(                                          &
    USE module_bl_shinhong
    USE module_bl_mrf
    USE module_bl_gfs
-   USE module_bl_gfs2011, only: bl_gfs2011
+#if (HWRF==1)
+   USE module_bl_gfsedmf, only: bl_gfsedmf
+#endif
    USE module_bl_acm
    USE module_bl_gwdo
    USE module_bl_myjurb
@@ -383,6 +387,10 @@ SUBROUTINE pbl_driver(                                          &
 !
    LOGICAL,      INTENT(IN   )    ::   warm_rain
    LOGICAL,      INTENT(IN   )    ::   is_CAMMGMP_used !BSINGH:01/31/2013: Added for CAMUWPBL
+#if (HWRF==1)
+   INTEGER,      INTENT(IN   )    ::   iwavecpl
+   LOGICAL,      INTENT(IN   )    ::   lcurr_sf
+#endif
 #if (NMM_CORE==1)
    LOGICAL,      INTENT(IN   )    ::   DISHEAT ! (for HWRF)
    REAL, DIMENSION( ims:ime , jms:jme ),                         &
@@ -475,6 +483,13 @@ SUBROUTINE pbl_driver(                                          &
                                                               BR, &
                                                                F, &
                                                          CHKLOWQ
+#if (HWRF==1)
+   REAL,       DIMENSION( ims:ime , jms:jme ),                    &
+               INTENT(IN   )    ::                         SCURX, &
+                                                           SCURY, &
+                                                           MSANG
+#endif
+
 !
    REAL,       DIMENSION( ims:ime, jms:jme )                    , &
                INTENT(INOUT)    ::                           TSK, &
@@ -578,6 +593,10 @@ SUBROUTINE pbl_driver(                                          &
    REAL,       DIMENSION( ims:ime , jms:jme ),                    &
                INTENT(IN)    :: XICE, SNOW, LH
 
+   ! Stochastic parameter perturbations
+   INTEGER,    INTENT(IN), OPTIONAL              ::             spp_pbl
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(IN),OPTIONAL ::pattern_spp_pbl
+
 ! Bep changes: variable added for urban
    real, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) ::FRC_URB2D   ! URBAN Landuse fraction
    REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::a_u_bep        ! Implicit component for the momemtum in X-direction
@@ -1098,7 +1117,7 @@ SUBROUTINE pbl_driver(                                          &
               ,FLAG_QI=flag_qi                                      &
               ,g=g,cp=cp,rcp=rcp,r_d=r_d,r_v=r_v,cpv=cpv                    &
               ,Z=z,XLV=XLV,PSFC=PSFC               &
-              ,MUT=mut,P_TOP=p_top                  &
+              ,P_TOP=p_top                                          &
               ,ZNT=znt,HT=ht,UST=ust,ZOL=zol,HOL=hol,HPBL=pblh      &
               ,PSIM=psim,PSIH=psih,XLAND=xland                      &
               ,HFX=hfx,QFX=qfx,TSK=tskold,QSFC=qsfc,GZ1OZ0=gz1oz0   &
@@ -1142,7 +1161,7 @@ SUBROUTINE pbl_driver(                                          &
               ,FLAG_QI=flag_qi                                      &
               ,CP=cp,G=g,ROVCP=rcp,RD=r_D,ROVG=rovg                 &
               ,DZ8W=dz8w,XLV=XLV,RV=r_v,PSFC=PSFC                   &
-              ,ZNU=znu,ZNW=znw,MUT=mut,P_TOP=p_top                  &
+              ,ZNU=znu,ZNW=znw,P_TOP=p_top                          &
               ,ZNT=znt,UST=ust,HPBL=pblh                            &
               ,PSIM=fm,PSIH=fhh,XLAND=xland                         &
               ,HFX=hfx,QFX=qfx                                      &
@@ -1219,7 +1238,7 @@ SUBROUTINE pbl_driver(                                          &
               ,FLAG_QI=flag_qi                                      &
               ,CP=cp,G=g,ROVCP=rcp,RD=r_D,ROVG=rovg                 &
               ,DZ8W=dz8w,XLV=XLV,RV=r_v,PSFC=PSFC                   &
-              ,ZNU=znu,ZNW=znw,MUT=mut,P_TOP=p_top                  &
+              ,ZNU=znu,ZNW=znw,P_TOP=p_top                          &
               ,ZNT=znt,UST=ust,HPBL=pblh                            &
               ,PSIM=fm,PSIH=fhh,XLAND=xland                         &
               ,HFX=hfx,QFX=qfx                                      &
@@ -1337,6 +1356,7 @@ SUBROUTINE pbl_driver(                                          &
               ,U10=U10,V10=V10,ZNT=ZNT,MZNT=MZNT,RC2D=RC2D          &   !Kwon for variable Ric
               ,DKU3D=DKU3D,DKT3D=DKT3D                              &
               ,coef_ric_l=coef_ric_l,coef_ric_s=coef_ric_s,xland=xland    &
+              ,MSANG=MSANG,SCURX=SCURX,SCURY=SCURY,IWAVECPL=IWAVECPL,LCURR_SF=LCURR_SF &
               ,pert_pbl=pert_pbl                                    &
               ,ens_random_seed=ens_random_seed                      &
               ,ens_pblamp=ens_pblamp                                &
@@ -1361,13 +1381,13 @@ SUBROUTINE pbl_driver(                                          &
                CALL wrf_error_fatal('Lack arguments to call GFS pbl')
            ENDIF
 
-#if (NMM_CORE==1)
-      CASE (GFS2011SCHEME)
+#if (HWRF==1)
+      CASE (GFSEDMFSCHEME)
            IF ( PRESENT( qv_curr )  .AND. PRESENT( qc_curr )  .AND. &
                 PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. &
                                                         .TRUE.  ) THEN
              CALL wrf_debug(100,'in GFS')
-             CALL bl_gfs2011(                                       &
+             CALL bl_gfsedmf(                                       &
                U3D=u_phytmp,V3D=v_phytmp                            &
               ,TH3D=th_phy,T3D=t_phy                                &
               ,QV3D=qv_curr,QC3D=qc_curr,QI3D=qi_curr               &
@@ -1376,17 +1396,21 @@ SUBROUTINE pbl_driver(                                          &
               ,RQVBLTEN=rqvblten,RQCBLTEN=rqcblten                  &
               ,RQIBLTEN=rqiblten                                    &
               ,CP=cp,G=g,ROVCP=rcp,R=r_d,ROVG=rovg                  &
+              ,P_QI=p_qi,P_FIRST_SCALAR=param_first_scalar          &
               ,DZ8W=dz8w,z=z,PSFC=psfc                              &
               ,UST=ust,PBL=pblh,PSIM=psim,PSIH=psih                 &
               ,HFX=hfx,QFX=qfx,TSK=tskold,GZ1OZ0=gz1oz0             &
               ,WSPD=wspd,BR=br                                      &
               ,DT=dtbl,KPBL2D=kpbl,EP1=ep_1,KARMAN=karman           &
-#if (NMM_CORE==1)
               ,DISHEAT=DISHEAT                                      &
-#endif
               ,RTHRATEN=RTHRATEN                    &
-              ,HPBL2D=HPBL2D, EVAP2D=EVAP2D, HEAT2D=HEAT2D          &   !Kwon add FOR SHAL. CON.
-              ,P_QI=p_qi,P_FIRST_SCALAR=param_first_scalar          &
+              ,HPBL2D=HPBL2D, EVAP2D=EVAP2D, HEAT2D=HEAT2D          &
+              ,U10=u10,V10=v10,ZNT=mznt                             &
+              ,DKU3D=dku3d,DKT3D=dkt3d                             &
+              ,VAR_RIC=VAR_RIC                                      &
+              ,coef_ric_l=coef_ric_l,coef_ric_s=coef_ric_s          &
+              ,ALPHA=gfs_alpha                                      &
+              ,xland=xland                                          &
               ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde      &
               ,IMS=ims,IME=ime,JMS=jms,JME=jme,KMS=kms,KME=kme      &
               ,ITS=its,ITE=ite,JTS=jts,JTE=jte,KTS=kts,KTE=kte      &
@@ -1403,10 +1427,9 @@ SUBROUTINE pbl_driver(                                          &
                   PRESENT( rqvblten ) ,                             &
                   PRESENT( rqcblten )
                CALL wrf_debug(0,message)
-               CALL wrf_error_fatal('Lack arguments to call GFS pbl')
+               CALL wrf_error_fatal('Lack arguments to call GFS edmf pbl')
            ENDIF
 #endif
-
       CASE (MYJPBLSCHEME)
            IF ( PRESENT( qv_curr )  .AND. PRESENT( qc_curr )  .AND. &
                 PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. &
@@ -1600,8 +1623,7 @@ SUBROUTINE pbl_driver(                                          &
            IF ( PRESENT( qv_curr )  .AND. PRESENT( qc_curr )  .AND. &
                 PRESENT( rqvblten ) .AND. PRESENT( rqcblten ) .AND. &
                 PRESENT( qi_curr ) .AND. PRESENT( rqiblten ) .AND.  &
-                PRESENT( rqniblten ) .AND. & !PRESENT( rqncblten ) .AND. &
-                PRESENT( qni_curr ) .AND. & !PRESENT( qnc_curr ) .AND. &
+                PRESENT( rqniblten ) .AND. PRESENT( qni_curr ) .AND.&
                 PRESENT(qke) .AND. PRESENT(tsq) .AND.               &
                 PRESENT(qsq) .AND. PRESENT(cov) .AND.               &
                 PRESENT(rmol) .AND.                                 &
@@ -1651,8 +1673,8 @@ SUBROUTINE pbl_driver(                                          &
                    &,bl_mynn_tkebudget=bl_mynn_tkebudget                 &
                    &,bl_mynn_cloudpdf=bl_mynn_cloudpdf                   &
                    &,bl_mynn_mixlength=bl_mynn_mixlength                 &
-                   &,icloud_bl=icloud_bl,qc_bl=qc_bl                   & !JOE-subgrid bl clouds
-                   &,cldfra_bl=cldfra_bl                                 & !JOE-subgrid bl clouds
+                   &,icloud_bl=icloud_bl,qc_bl=qc_bl                     &
+                   &,cldfra_bl=cldfra_bl                                 &
                    &,bl_mynn_edmf=bl_mynn_edmf                           &
                    &,bl_mynn_edmf_mom=bl_mynn_edmf_mom                   &
                    &,bl_mynn_edmf_tke=bl_mynn_edmf_tke                   &
@@ -1661,6 +1683,7 @@ SUBROUTINE pbl_driver(                                          &
                    &,bl_mynn_mixqt=bl_mynn_mixqt                         &
                    &,edmf_a=edmf_a,edmf_w=edmf_w,edmf_qt=edmf_qt         &
                    &,edmf_thl=edmf_thl,edmf_ent=edmf_ent,edmf_qc=edmf_qc &
+                   &,spp_pbl=spp_pbl,pattern_spp_pbl=pattern_spp_pbl     &
                    &,FLAG_QI=flag_qi,FLAG_QNI=flag_qni                   &
                    &,FLAG_QC=flag_qc,FLAG_QNC=flag_qnc                   &
                    ,IDS=ids,IDE=ide,JDS=jds,JDE=jde,KDS=kds,KDE=kde      &
@@ -1673,12 +1696,10 @@ SUBROUTINE pbl_driver(                                          &
                  'qv_curr, '//                                      &
                  'qc_curr, '//                                      &
                  'qi_curr, '//                                      &
-!                 'qnc_curr, '//                                     &
                  'qni_curr, '//                                     &
                  'rqvblten, '//                                     &
                  'rqcblten, '//                                     &
                  'rqiblten, '//                                     &
-!                 'rqncblten, '//                                    &
                  'rqniblten, '//                                    &
                  'qke, '//                                          &
                  'tsq, '//                                          &
@@ -1695,12 +1716,10 @@ SUBROUTINE pbl_driver(                                          &
                   PRESENT( qv_curr ) ,                              &
                   PRESENT( qc_curr ) ,                              &
                   PRESENT( qi_curr ) ,                              &
-!                  PRESENT( qnc_curr ) ,                             &
                   PRESENT( qni_curr ) ,                             &
                   PRESENT( rqvblten ) ,                             &
                   PRESENT( rqcblten ) ,                             &
                   PRESENT( rqiblten ) ,                             &
-!                  PRESENT( rqncblten ) ,                            &
                   PRESENT( rqniblten ) ,                            &
                   PRESENT( qke      ) ,                             &
                   PRESENT( tsq      ) ,                             &
@@ -1892,7 +1911,7 @@ SUBROUTINE pbl_driver(                                          &
               ,VAR2D=var2d,OC12D=oc12d     &
               ,OA2D1=oa1,OA2D2=oa2,OA2D3=oa3,OA2D4=oa4  &
               ,OL2D1=ol1,OL2D2=ol2,OL2D3=ol3,OL2D4=ol4  &
-              ,ZNU=znu,ZNW=znw,MUT=mut,P_TOP=p_top                  &
+              ,ZNU=znu,ZNW=znw,P_TOP=p_top                &
               ,CP=cp,G=g,RD=r_d                           &
               ,RV=r_v,EP1=ep_1,PI=3.141592653                        &
               ,DT=dtbl,DX=dx,KPBL2D=kpbl,ITIMESTEP=itimestep      &
diff --git a/wrfv2_fire/phys/module_physics_addtendc.F b/wrfv2_fire/phys/module_physics_addtendc.F
index ef36494e..85cc014d 100644
--- a/wrfv2_fire/phys/module_physics_addtendc.F
+++ b/wrfv2_fire/phys/module_physics_addtendc.F
@@ -1268,7 +1268,7 @@ SUBROUTINE phy_cu_ten(config_flags,rk_step,n_moist,n_scalar,     &
 
        ENDIF
 
-   CASE (SASSCHEME,OSASSCHEME,MESO_SAS)
+   CASE (SASSCHEME,OSASSCHEME,SCALESASSCHEME)
         CALL add_a2a(rt_tendf,RTHCUTEN,config_flags,             &
                 ids,ide, jds, jde, kds, kde,                     &
                 ims, ime, jms, jme, kms, kme,                    &
diff --git a/wrfv2_fire/phys/module_physics_init.F b/wrfv2_fire/phys/module_physics_init.F
index 2e924584..e84d73e6 100644
--- a/wrfv2_fire/phys/module_physics_init.F
+++ b/wrfv2_fire/phys/module_physics_init.F
@@ -101,11 +101,13 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf,     &
                          WSLAKEXY, ZWTXY, WAXY, WTXY, LFMASSXY, RTMASSXY, & ! Optional Noah-MP
                          STMASSXY, WOODXY, STBLCPXY, FASTCPXY,            & ! Optional Noah-MP
                          GRAINXY, GDDXY,                                  & ! Optional Noah-MP
+                         croptype, cropcat,                      &           ! Noah-MP Crop model
                          XSAIXY, LAI,                                     & ! Optional Noah-MP
                          T2MVXY, T2MBXY, CHSTARXY ,                       & ! Optional Noah-MP
                          SMOISEQ  ,SMCWTDXY ,RECHXY, DEEPRECHXY, AREAXY,  & ! Optional Noah-MP 
                          WTDDT , STEPWTD ,QRFSXY ,QSPRINGSXY ,QSLATXY,    & ! Optional Noah-MP
                          FDEPTHXY, RIVERBEDXY, EQZWT, RIVERCONDXY, PEXPXY, & ! Optional Noah-MP
+                         rechclim  ,                                       & ! Optional Noah-MP
                          msftx, msfty,                           &           ! Optional Noah-MP
 !                        num_roof_layers,num_wall_layers,        & !Optional urban
 !                        num_road_layers,                        & !Optional urban
@@ -477,8 +479,11 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf,     &
    REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: FDEPTHXY
    REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: RIVERBEDXY
    REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: EQZWT
-   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: RIVERCONDXY
-   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: PEXPXY
+   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme) :: RIVERCONDXY
+   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme) :: PEXPXY
+   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: rechclim
+   INTEGER, OPTIONAL, DIMENSION(ims:ime,  jms:jme), INTENT(OUT) :: CROPCAT
+   REAL,    OPTIONAL, DIMENSION(ims:ime,5,jms:jme), INTENT(IN ) :: CROPTYPE
 
 !   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),  OPTIONAL,  INTENT(INOUT ) ::   qnn_curr
 
@@ -790,11 +795,20 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf,     &
          config_flags%mp_physics  .eq. WSM5SCHEME .or.      & ! syb+
          config_flags%mp_physics  .eq. WSM6SCHEME .or.      & ! syb+
          config_flags%mp_physics  .eq. WDM5SCHEME .or.      & ! syb+
-         config_flags%mp_physics  .eq. WDM6SCHEME ) ) then    ! syb+
+         config_flags%mp_physics  .eq. WDM6SCHEME .or.      &
+         config_flags%mp_physics  .eq. P3_1CATEGORY .or.    &
+         config_flags%mp_physics  .eq. P3_1CATEGORY_NC    ) ) then    ! P3
       has_reqc = 1
       has_reqi = 1
       has_reqs = 1
    endif
+
+! for P3, to ensure correct coupling with predicted effective radii
+   if (config_flags%mp_physics .eq. P3_1CATEGORY .or.       &
+       config_flags%mp_physics .eq. P3_1CATEGORY_NC       ) then
+      has_reqs = 0
+   end if
+
    ENDIF
 
 !-- should be from the namelist
@@ -1118,11 +1132,13 @@ SUBROUTINE phy_init ( id, config_flags, DT, restart, zfull, zhalf,     &
                 CHXY, FWETXY, SNEQVOXY, ALBOLDXY, QSNOWXY,      &
                 WSLAKEXY, ZWTXY, WAXY, WTXY, LFMASSXY, RTMASSXY,&
                 STMASSXY, WOODXY, STBLCPXY, FASTCPXY,           &
-                GRAINXY, GDDXY,                                 &
+                GRAINXY, GDDXY,                                 & ! Noah-MP Crop model
+                croptype, cropcat,                              & ! Noah-MP Crop model
                 XSAIXY, LAI,                                    &
                 SMOISEQ, SMCWTDXY, RECHXY, DEEPRECHXY, AREAXY,  &
                 WTDDT, STEPWTD, QRFSXY ,QSPRINGSXY ,QSLATXY,   &
                 FDEPTHXY, RIVERBEDXY, EQZWT, RIVERCONDXY, PEXPXY, & 
+                rechclim  ,                                     &
                 ISICE,                                 &
                 T2MVXY,T2MBXY,CHSTARXY ,                        &
                 allowed_to_read , iopt_run ,                    &
@@ -2029,11 +2045,13 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN,  &
                 CHXY, FWETXY, SNEQVOXY, ALBOLDXY, QSNOWXY,      &
                 WSLAKEXY, ZWTXY, WAXY, WTXY, LFMASSXY, RTMASSXY,&
                 STMASSXY, WOODXY, STBLCPXY, FASTCPXY,           &
-                GRAINXY, GDDXY,                                 &
+                GRAINXY, GDDXY,                                 & ! Noah-MP Crop model
+                croptype, cropcat,                              & ! Noah-MP Crop model
                 XSAIXY, LAI,                                    &
                 SMOISEQ, SMCWTDXY, RECHXY, DEEPRECHXY, AREAXY,  &
                 WTDDT, STEPWTD,QRFSXY ,QSPRINGSXY ,QSLATXY,     &
                 FDEPTHXY, RIVERBEDXY, EQZWT, RIVERCONDXY, PEXPXY, & 
+                rechclim  ,                                     &
                 ISICE,                                 &
                 T2MVXY, T2MBXY ,CHSTARXY,                       &
                 allowed_to_read, iopt_run ,                     &
@@ -2146,13 +2164,16 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN,  &
    USE module_bl_shinhong
    USE module_bl_mrf
    USE module_bl_gfs
-   USE module_bl_gfs2011, only : gfs2011init
+#if (HWRF==1)
+   USE module_bl_gfsedmf, only : gfsedmfinit
+#endif
    USE module_bl_acm
    USE module_sf_myjsfc
    USE module_sf_qnsesfc
    USE module_sf_noahdrv
    USE module_sf_noahlsm, only : LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL
    USE module_sf_noahmpdrv
+   USE noahmp_tables, ONLY: LOW_DENSITY_RESIDENTIAL_TABLE, HIGH_DENSITY_RESIDENTIAL_TABLE, HIGH_INTENSITY_INDUSTRIAL_TABLE
 #ifdef WRF_USE_CLM
    USE module_sf_clm, only : clminit
 #endif
@@ -2322,10 +2343,13 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN,  &
    REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme) :: QSLATXY
    REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme) :: AREAXY
    REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: FDEPTHXY
-   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: RIVERBEDXY
-   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: EQZWT
-   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: RIVERCONDXY
-   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: PEXPXY
+   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme) :: RIVERBEDXY
+   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme) :: EQZWT
+   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme) :: RIVERCONDXY
+   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme) :: PEXPXY
+   REAL,    OPTIONAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) :: rechclim
+   INTEGER, OPTIONAL, DIMENSION(ims:ime,  jms:jme), INTENT(OUT) :: CROPCAT
+   REAL,    OPTIONAL, DIMENSION(ims:ime,5,jms:jme), INTENT(IN ) :: CROPTYPE
    INTEGER, OPTIONAL, INTENT(IN)  ::  ISICE
    INTEGER , OPTIONAL,  INTENT(OUT) :: STEPWTD
    REAL , OPTIONAL, INTENT(IN) :: WTDDT
@@ -2807,19 +2831,62 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN,  &
                      wtxy     ,tsnoxy   ,zsnsoxy  ,snicexy  ,snliqxy  ,lfmassxy ,rtmassxy , &
                      stmassxy ,woodxy   ,stblcpxy ,fastcpxy ,xsaixy   ,lai      ,           &
                      grainxy  ,gddxy    ,                                                   &
+                     croptype ,cropcat  ,                      &
                      t2mvxy   ,t2mbxy   ,chstarxy ,            &
                      num_soil_layers, restart,                 &
                      allowed_to_read, iopt_run ,               &
+                     sf_urban_physics,                         &  ! urban scheme
                      ids,ide, jds,jde, kds,kde,                &
                      ims,ime, jms,jme, kms,kme,                &
                      its,ite, jts,jte, kts,kte                 &
 #if (EM_CORE == 1)
                      ,smoiseq  ,smcwtdxy ,rechxy   ,deeprechxy, areaxy ,dx, dy, msftx, msfty,&
                      wtddt    ,stepwtd  ,dt  ,qrfsxy ,qspringsxy  ,qslatxy,                  &
-                     fdepthxy ,ht       ,riverbedxy ,eqzwt ,rivercondxy ,pexpxy              &
+                     fdepthxy ,ht       ,riverbedxy ,eqzwt ,rivercondxy ,pexpxy,              &
+                     rechclim                  &
 #endif
                      )
 
+          IF ((SF_URBAN_PHYSICS.eq.1).OR.(SF_URBAN_PHYSICS.EQ.2).OR.(SF_URBAN_PHYSICS.EQ.3)) THEN
+             IF ( PRESENT( FRC_URB2D ) .AND. PRESENT( UTYPE_URB2D )) THEN
+                CALL urban_param_init(DZR,DZB,DZG,num_soil_layers,                   & !urban
+                                sf_urban_physics)
+                CALL urban_var_init(ISURBAN,TSK,TSLB,TMN,IVGTYP,               & !urban
+                              ims,ime,jms,jme,kms,kme,num_soil_layers,         & !urban
+                              LOW_DENSITY_RESIDENTIAL_TABLE,                   &
+		              HIGH_DENSITY_RESIDENTIAL_TABLE,                  &
+		              HIGH_INTENSITY_INDUSTRIAL_TABLE,                 &
+                              restart,sf_urban_physics,                        & !urban
+                              XXXR_URB2D,XXXB_URB2D,XXXG_URB2D,XXXC_URB2D,     & !urban
+                              TR_URB2D,TB_URB2D,TG_URB2D,TC_URB2D,QC_URB2D,    & !urban
+                              TRL_URB3D,TBL_URB3D,TGL_URB3D,                   & !urban
+                              SH_URB2D,LH_URB2D,G_URB2D,RN_URB2D, TS_URB2D,    & !urban
+                              num_urban_layers,                                & !urban
+                              num_urban_hi,                                    & !urban
+                              TRB_URB4D,TW1_URB4D,TW2_URB4D,TGB_URB4D,         & !urban
+                              TLEV_URB3D,QLEV_URB3D,                           & !urban
+                              TW1LEV_URB3D,TW2LEV_URB3D,                       & !urban
+                              TGLEV_URB3D,TFLEV_URB3D,                         & !urban
+                              SF_AC_URB3D,LF_AC_URB3D,CM_AC_URB3D,             & !urban
+                              SFVENT_URB3D,LFVENT_URB3D,                       & !urban
+                              SFWIN1_URB3D,SFWIN2_URB3D,                       & !urban
+                              SFW1_URB3D,SFW2_URB3D,SFR_URB3D,SFG_URB3D,       & !urban
+                              LP_URB2D,HI_URB2D,LB_URB2D,                      & !urban
+                              HGT_URB2D,MH_URB2D,STDH_URB2D,                   & !urban
+                              LF_URB2D,                                        & !urban
+                              CMCR_URB2D,TGR_URB2D,TGRL_URB3D,SMR_URB3D,       & !urban
+                              DRELR_URB2D,DRELB_URB2D,DRELG_URB2D,             & !urban
+                              FLXHUMR_URB2D, FLXHUMB_URB2D, FLXHUMG_URB2D,     & !urban
+                              A_U_BEP,A_V_BEP,A_T_BEP,A_Q_BEP,                 & !multi-layer urban
+                              A_E_BEP,B_U_BEP,B_V_BEP,                         & !multi-layer urban
+                              B_T_BEP,B_Q_BEP,B_E_BEP,DLG_BEP,                 & !multi-layer urban
+                              DL_U_BEP,SF_BEP,VL_BEP,                          & !multi-layer urban
+                              FRC_URB2D, UTYPE_URB2D)                            !urban
+             ELSE
+                CALL wrf_error_fatal ( 'arguments not present for calling urban model' )
+             ENDIF
+          ENDIF
+
       CASE (RUCLSMSCHEME)
 !          if(isfc .ne. 2)CALL wrf_error_fatal &
 !           ( 'module_physics_init: use myjsfc and myjpbl scheme for this lsm option' )
@@ -3038,13 +3105,13 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN,  &
                         ids, ide, jds, jde, kds, kde,         &
                         ims, ime, jms, jme, kms, kme,         &
                         its, ite, jts, jte, kts, kte          )
-#if (NMM_CORE == 1)
-      CASE (GFS2011SCHEME)
+#if (HWRF == 1)
+      CASE (GFSEDMFSCHEME)
            if(isfc .ne. 2)CALL wrf_error_fatal &
             ( 'module_physics_init: use myjsfc scheme for this pbl option' )
            IF ((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.EQ.3)) CALL wrf_error_fatal &
             ( 'module_physics_init: use myj (option 2) or boulac (option 8) with BEP/BEM urban scheme' )
-           CALL gfs2011init(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,&
+           CALL gfsedmfinit(RUBLTEN,RVBLTEN,RTHBLTEN,RQVBLTEN,&
                         RQCBLTEN,RQIBLTEN,P_QI,               &
                         PARAM_FIRST_SCALAR,                   &
                         restart,                              &
@@ -3052,6 +3119,7 @@ SUBROUTINE bl_init(STEPBL,BLDT,DT,RUBLTEN,RVBLTEN,RTHBLTEN,  &
                         ids, ide, jds, jde, kds, kde,         &
                         ims, ime, jms, jme, kms, kme,         &
                         its, ite, jts, jte, kts, kte          )
+
 #endif
       CASE (MYJPBLSCHEME)
            if(isfc .ne. 2)CALL wrf_error_fatal &
@@ -3220,7 +3288,7 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN,  &
    USE module_cu_gd,  ONLY : GDINIT
    USE module_cu_g3,  ONLY : G3INIT
    USE module_cu_sas
-   USE module_cu_mesosas
+   USE module_cu_scalesas
    USE module_cu_osas
    USE module_cu_camzm_driver, ONLY : zm_conv_init
    USE module_cu_nsas
@@ -3394,6 +3462,15 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN,  &
                       ims, ime, jms, jme, kms, kme,               &
                       its, ite, jts, jte, kts, kte                )
 
+     CASE (SCALESASSCHEME)
+          CALL scalesasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,  &
+                      RUCUTEN,RVCUTEN,                            &   
+                      restart,P_QC,P_QI,PARAM_FIRST_SCALAR,       &
+                      allowed_to_read ,                           &
+                      ids, ide, jds, jde, kds, kde,               &
+                      ims, ime, jms, jme, kms, kme,               &
+                      its, ite, jts, jte, kts, kte                )
+
 #if ( EM_CORE == 1 )
           !BSINGH - For WRFCuP Scheme
     CASE (KFCUPSCHEME)  !wig: 18-Sep-2006
@@ -3412,15 +3489,6 @@ SUBROUTINE cu_init(DX,STEPCU,CUDT,DT,RUCUTEN,RVCUTEN,RTHCUTEN,  &
     !BSINGH - ENDS
 #endif
 
-     CASE (MESO_SAS)   !Kwon
-          CALL msasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,       &
-                      RUCUTEN,RVCUTEN,                            &   ! gopal's doing for SAS
-                      restart,P_QC,P_QI,PARAM_FIRST_SCALAR,       &
-                      allowed_to_read ,                           &
-                      ids, ide, jds, jde, kds, kde,               &
-                      ims, ime, jms, jme, kms, kme,               &
-                      its, ite, jts, jte, kts, kte                )
-
      CASE (OSASSCHEME)
           CALL osasinit(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQICUTEN,      &
                       RUCUTEN,RVCUTEN,                            &   ! gopal's doing for SAS
@@ -3526,6 +3594,17 @@ SUBROUTINE shcu_init(STEPCU,CUDT,DT,RUSHTEN,RVSHTEN,RTHSHTEN,   &
    STEPCU = nint(CUDT*60./DT)
    STEPCU = max(STEPCU,1)
 
+!-- initialization
+
+   IF(start_of_simulation)THEN
+     DO j=jts,jtf
+     DO i=its,itf
+        RAINC(i,j)=0.
+        RAINCV(i,j)=0.
+     ENDDO
+     ENDDO
+   ENDIF
+
 !-- independent shallow convection schemes
    shcu_select: SELECT CASE(config_flags%shcu_physics)
 
@@ -3586,6 +3665,7 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain,
    USE module_mp_full_sbm
    USE module_mp_fast_sbm
    USE module_mp_morr_two_moment
+   USE module_mp_p3
    USE module_mp_milbrandt2mom
 !  USE module_mp_milbrandt3mom
    USE module_mp_wdm5
@@ -3733,6 +3813,10 @@ SUBROUTINE mp_init(RAINNC,SNOWNC,GRAUPELNC,config_flags,restart,warm_rain,
 
      CASE (MORR_TWO_MOMENT)
          CALL morr_two_moment_init( config_flags%hail_opt )
+     CASE (P3_1CATEGORY)
+         CALL p3_init('./p3_lookup_table_1.dat','./p3_lookup_table_2.dat',1)
+     CASE (P3_1CATEGORY_NC)
+         CALL p3_init('./p3_lookup_table_1.dat','./p3_lookup_table_2.dat',1)
      CASE (MILBRANDT2MOM)
          CALL milbrandt2mom_init
 !      CASE (MILBRANDT3MOM)
diff --git a/wrfv2_fire/phys/module_ra_cam.F b/wrfv2_fire/phys/module_ra_cam.F
index 3bd9b8ca..96af706c 100644
--- a/wrfv2_fire/phys/module_ra_cam.F
+++ b/wrfv2_fire/phys/module_ra_cam.F
@@ -577,16 +577,16 @@ subroutine camrad(RTHRATENLW,RTHRATENSW,                           &
      IF ( F_QI .and. F_QC .and. F_QS ) THEN
       q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
       q(ii,kk,ixcldice) = max(0.,(qi3d(i,k,j)+qs3d(i,k,j))/(1.+qv3d(i,k,j)))
+     ELSE IF ( F_QC .and. F_QI ) THEN
+! For Ferrier (note fixed after V3.8.1 for hires window Ferrier)
+      q(ii,kk,ixcldice) = max(0.,qi3d(i,k,j)/(1.+qv3d(i,k,j)))
+      q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
      ELSE IF ( F_QC .and. F_QR ) THEN
 ! Warm rain or simple ice
       q(ii,kk,ixcldliq) = 0.
       q(ii,kk,ixcldice) = 0.
       if(t_phy(i,k,j).gt.273.15)q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
       if(t_phy(i,k,j).le.273.15)q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j)))
-     ELSE IF ( F_QC .and. F_QS ) THEN
-! For Ferrier (note that currently Ferrier has QI, so this section will not be used)
-      q(ii,kk,ixcldice) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j))*f_ice_phy(i,k,j))
-      q(ii,kk,ixcldliq) = max(0.,qc3d(i,k,j)/(1.+qv3d(i,k,j))*(1.-f_ice_phy(i,k,j))*(1.-f_rain_phy(i,k,j)))
      ELSE
       q(ii,kk,ixcldliq) = 0.
       q(ii,kk,ixcldice) = 0.
diff --git a/wrfv2_fire/phys/module_ra_cam_support.F b/wrfv2_fire/phys/module_ra_cam_support.F
index a2964830..839fb7f5 100644
--- a/wrfv2_fire/phys/module_ra_cam_support.F
+++ b/wrfv2_fire/phys/module_ra_cam_support.F
@@ -3551,10 +3551,17 @@ subroutine oznini(ozmixm,pin,levsiz,num_months,XLAT,                &
 #if ( defined( DM_PARALLEL ) && ( ! defined( STUBMPI ) ) )
      endif if_master
      call wrf_debug(1,"Broadcast ozone to other ranks.")
+# if ( RWORDSIZE == DWORDSIZE )
+     call MPI_Bcast(ozmixin,size(ozmixin),MPI_DOUBLE_PRECISION,0,local_communicator,ierr)
+     call MPI_Bcast(pin,size(pin),MPI_DOUBLE_PRECISION,0,local_communicator,ierr)
+     plev=pin
+     call MPI_Bcast(lat_ozone,size(lat_ozone),MPI_DOUBLE_PRECISION,0,local_communicator,ierr)
+# else
      call MPI_Bcast(ozmixin,size(ozmixin),MPI_REAL,0,local_communicator,ierr)
      call MPI_Bcast(pin,size(pin),MPI_REAL,0,local_communicator,ierr)
      plev=pin
      call MPI_Bcast(lat_ozone,size(lat_ozone),MPI_REAL,0,local_communicator,ierr)
+# endif
 #endif
    else ! already read in ozone data
     ! Make sure, first:
diff --git a/wrfv2_fire/phys/module_ra_flg.F b/wrfv2_fire/phys/module_ra_flg.F
index 3d2fd484..bf96d40c 100644
--- a/wrfv2_fire/phys/module_ra_flg.F
+++ b/wrfv2_fire/phys/module_ra_flg.F
@@ -11341,7 +11341,7 @@ subroutine qki ( nv,nv1,coefki, fkg,pp,pt,ph,po )
       i1 = 1
       do i = 1, nv1
 ! -test
-        if (pt(i).gt.320.) then
+        if (pt(i).gt.345.) then
           pt(i) = 345.
         endif
         if (pt(i).lt.180.) then
diff --git a/wrfv2_fire/phys/module_ra_goddard.F b/wrfv2_fire/phys/module_ra_goddard.F
index d771ac72..a7fbb26e 100644
--- a/wrfv2_fire/phys/module_ra_goddard.F
+++ b/wrfv2_fire/phys/module_ra_goddard.F
@@ -3866,12 +3866,20 @@ subroutine sw_ir (m,np,wh,dp, &
         1.334,  5.623,  31.62,  177.8,  1000.0/
 !-----water vapor k-distribution function,
 !     the sum of hk is 0.52926. unit: fraction (table 2)
+!      data hk/ &
+!       .20673,.08236,.01074,  .03497,.01157,.00360, &
+!       .03011,.01133,.00411,  .02260,.01143,.00421, &
+!       .01336,.01240,.00389,  .00696,.01258,.00326, &
+!       .00441,.01381,.00499,  .00115,.00650,.00465, &
+!       .00026,.00244,.00245,  .00000,.00094,.00145/
+!added by ucsd, 2016/03, to account for water vapor continuum absorption based on data from Table 1 in Tarasova and Fomin (2000)
       data hk/ &
-       .20673,.08236,.01074,  .03497,.01157,.00360, &
-       .03011,.01133,.00411,  .02260,.01143,.00421, &
-       .01336,.01240,.00389,  .00696,.01258,.00326, &
-       .00441,.01381,.00499,  .00115,.00650,.00465, &
-       .00026,.00244,.00245,  .00000,.00094,.00145/
+       .19310,.06924,.00310,  .05716,.01960,.00637, &
+       .02088,.00795,.00526,  .02407,.01716,.00641, &
+       .01402,.01118,.00542,  .00582,.01377,.00312, &
+       .00246,.02008,.00368,  .00163,.00265,.00346, &
+       .00101,.00282,.00555,  .00041,.00092,.00098/
+
 !-----ry is the extinction coefficient for rayleigh scattering.
 !     unit: /mb (table 3)
       data ry /.0000156, .0000018, .000000/
diff --git a/wrfv2_fire/phys/module_ra_rrtmg_lw.F b/wrfv2_fire/phys/module_ra_rrtmg_lw.F
index 85f28d57..a3ac1a07 100644
--- a/wrfv2_fire/phys/module_ra_rrtmg_lw.F
+++ b/wrfv2_fire/phys/module_ra_rrtmg_lw.F
@@ -12018,10 +12018,6 @@ SUBROUTINE RRTMG_LWRAD(                                        &
 !Mukul change the flags here with reference to the new effective cloud/ice/snow radius
          IF (ICLOUD .ne. 0) THEN
             IF ( has_reqc .ne. 0) THEN
-               IF ( wrf_dm_on_monitor() ) THEN
-                 WRITE(message,*)'RRTMG: pre-computed cloud droplet effective radius found, setting inflglw=3'
-                 call wrf_debug(150, message)
-               ENDIF
                inflglw = 3
                DO K=kts,kte
                   recloud1D(ncol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
@@ -12040,10 +12036,6 @@ SUBROUTINE RRTMG_LWRAD(                                        &
             ENDIF
 
             IF ( has_reqi .ne. 0) THEN
-               IF ( wrf_dm_on_monitor() ) THEN
-                 WRITE(message,*)'RRTMG: pre-computed cloud ice effective radius found, setting inflglw=4 and iceflglw=4'
-                 call wrf_debug(150, message)
-               ENDIF
                inflglw  = 4
                iceflglw = 4
                DO K=kts,kte
@@ -12083,10 +12075,6 @@ SUBROUTINE RRTMG_LWRAD(                                        &
             ENDIF
 
             IF ( has_reqs .ne. 0) THEN
-               IF ( wrf_dm_on_monitor() ) THEN
-                 WRITE(message,*)'RRTMG: pre-computed snow effective radius found, setting inflglw=5 and iceflglw=5'
-                 call wrf_debug(150, message)
-               ENDIF
                inflglw  = 5
                iceflglw = 5
                DO K=kts,kte
@@ -12097,6 +12085,20 @@ SUBROUTINE RRTMG_LWRAD(                                        &
                   resnow1D(ncol,K) = 10.0
                ENDDO
             ENDIF
+
+! special case for P3 microphysics
+! put ice into snow category for optics, then set ice to zero
+            IF (has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
+               inflglw  = 5
+               iceflglw = 5
+               DO K=kts,kte
+                  resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
+                  QS1D(K)=QI3D(I,K,J)
+                  QI1D(K)=0.
+                  reice1D(ncol,K)=10.
+               END DO
+            END IF
+
          ENDIF
 
 ! Layer indexing goes bottom to top here for all fields.
@@ -12603,10 +12605,11 @@ SUBROUTINE RRTMG_LWRAD(                                        &
 
          if (present(lwupt)) then 
 ! Output up and down toa fluxes for total and clear sky
-            lwupt(i,j)     = uflx(1,kte+2)
-            lwuptc(i,j)    = uflxc(1,kte+2)
-            lwdnt(i,j)     = dflx(1,kte+2)
-            lwdntc(i,j)    = dflxc(1,kte+2)
+! nlayers+1 represents value at 0 mb
+            lwupt(i,j)     = uflx(1,nlayers+1)
+            lwuptc(i,j)    = uflxc(1,nlayers+1)
+            lwdnt(i,j)     = dflx(1,nlayers+1)
+            lwdntc(i,j)    = dflxc(1,nlayers+1)
 ! Output up and down surface fluxes for total and clear sky
             lwupb(i,j)     = uflx(1,1)
             lwupbc(i,j)    = uflxc(1,1)
diff --git a/wrfv2_fire/phys/module_ra_rrtmg_lwf.F b/wrfv2_fire/phys/module_ra_rrtmg_lwf.F
index d1e9607c..3e53400f 100644
--- a/wrfv2_fire/phys/module_ra_rrtmg_lwf.F
+++ b/wrfv2_fire/phys/module_ra_rrtmg_lwf.F
@@ -15826,11 +15826,6 @@ SUBROUTINE RRTMG_LWRAD_FAST(                                &
 !Mukul change the flags here with reference to the new effective cloud/ice/snow radius
          IF (ICLOUD .ne. 0) THEN
             IF ( has_reqc .ne. 0) THEN
-               IF ( wrf_dm_on_monitor() ) THEN
-                 WRITE(message,*)'RRTMG: pre-computed cloud droplet effective '// &
-                                 'radius found, setting inflglw=3'
-                 call wrf_debug(150, message)
-               ENDIF
                inflglw = 3
                DO K=kts,kte
                   recloud1D(icol,K) = MAX(2.5, re_cloud(I,K,J)*1.E6)
@@ -15849,10 +15844,6 @@ SUBROUTINE RRTMG_LWRAD_FAST(                                &
             ENDIF
 
             IF ( has_reqi .ne. 0) THEN
-               IF ( wrf_dm_on_monitor() ) THEN
-                 WRITE(message,*)'RRTMG: pre-computed cloud ice effective radius found, setting inflglw=4 and iceflglw=4'
-                 call wrf_debug(150, message)
-               ENDIF
                inflglw  = 4
                iceflglw = 4
                DO K=kts,kte
@@ -15873,10 +15864,6 @@ SUBROUTINE RRTMG_LWRAD_FAST(                                &
             ENDIF
 
             IF ( has_reqs .ne. 0) THEN
-               IF ( wrf_dm_on_monitor() ) THEN
-                 WRITE(message,*)'RRTMG: pre-computed snow effective radius found, setting inflglw=5 and iceflglw=5'
-                 call wrf_debug(150, message)
-               ENDIF
                inflglw  = 5
                iceflglw = 5
                DO K=kts,kte
@@ -15887,6 +15874,20 @@ SUBROUTINE RRTMG_LWRAD_FAST(                                &
                   resnow1D(icol,K) = 10.0
                ENDDO
             ENDIF
+
+! special case for P3 microphysics
+! put ice into snow category for optics, then set ice to zero
+            IF (has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
+               inflglw  = 5
+               iceflglw = 5
+               DO K=kts,kte
+                  resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
+                  QS1D(K)=QI3D(I,K,J)
+                  QI1D(K)=0.
+                  reice1D(ncol,K)=10.
+               END DO
+            END IF
+
          ENDIF
 
 ! Layer indexing goes bottom to top here for all fields.
@@ -16404,10 +16405,10 @@ SUBROUTINE RRTMG_LWRAD_FAST(                                &
 
          if (present(lwupt)) then 
 ! Output up and down toa fluxes for total and clear sky
-            lwupt(i,j)     = uflx(icol,kte+2)
-            lwuptc(i,j)    = uflxc(icol,kte+2)
-            lwdnt(i,j)     = dflx(icol,kte+2)
-            lwdntc(i,j)    = dflxc(icol,kte+2)
+            lwupt(i,j)     = uflx(icol,nlayers+1)
+            lwuptc(i,j)    = uflxc(icol,nlayers+1)
+            lwdnt(i,j)     = dflx(icol,nlayers+1)
+            lwdntc(i,j)    = dflxc(icol,nlayers+1)
 ! Output up and down surface fluxes for total and clear sky
             lwupb(i,j)     = uflx(icol,1)
             lwupbc(i,j)    = uflxc(icol,1)
diff --git a/wrfv2_fire/phys/module_ra_rrtmg_sw.F b/wrfv2_fire/phys/module_ra_rrtmg_sw.F
index 847e8a8c..70f0c73c 100644
--- a/wrfv2_fire/phys/module_ra_rrtmg_sw.F
+++ b/wrfv2_fire/phys/module_ra_rrtmg_sw.F
@@ -10501,6 +10501,21 @@ SUBROUTINE RRTMG_SWRAD(                                        &
 #endif
                ENDDO
             ENDIF
+
+! special case for P3 microphysics
+! put ice into snow category for optics, then set ice to zero
+            IF ( has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
+               inflgsw  = 5
+               iceflgsw = 5
+               DO K=kts,kte
+                  resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
+                  QS1D(K)=QI3D(I,K,J)
+                  QI1D(K)=0.
+                  reice1D(ncol,K)=10.
+               END DO
+
+            END IF
+
          ENDIF
 
 ! Set cosine of solar zenith angle
diff --git a/wrfv2_fire/phys/module_ra_rrtmg_swf.F b/wrfv2_fire/phys/module_ra_rrtmg_swf.F
index 24207004..2fae689b 100644
--- a/wrfv2_fire/phys/module_ra_rrtmg_swf.F
+++ b/wrfv2_fire/phys/module_ra_rrtmg_swf.F
@@ -11880,6 +11880,21 @@ SUBROUTINE RRTMG_SWRAD_FAST(                                &
                   resnow1D(icol,K) = 10.
                ENDDO
             ENDIF
+
+! special case for P3 microphysics
+! put ice into snow category for optics, then set ice to zero
+            IF ( has_reqs .eq. 0 .and. has_reqi .ne. 0 .and. has_reqc .ne. 0) THEN
+               inflgsw  = 5
+               iceflgsw = 5
+               DO K=kts,kte
+                  resnow1D(ncol,K) = MAX(10., re_ice(I,K,J)*1.E6)
+                  QS1D(K)=QI3D(I,K,J)
+                  QI1D(K)=0.
+                  reice1D(ncol,K)=10.
+               END DO
+
+            END IF
+
          ENDIF
 
 ! Set cosine of solar zenith angle
@@ -12290,16 +12305,16 @@ SUBROUTINE RRTMG_SWRAD_FAST(                                &
          end do
          if( slope < 0. ) then
             write(msg,'("ERROR: Negative total optical depth of ",f8.2,&
-             " at point i,j,nb=",3i5)') slope,i,j,nb
+           & " at point i,j,nb=",3i5)') slope,i,j,nb
             call wrf_error_fatal(msg)
          else if( slope > 6. ) then
             call wrf_message("-------------------------")
             write(msg,'("WARNING: Large total sw optical depth of ",f8.2,&
-             " at point i,j,nb=",3i5)') slope,i,j,nb
+           & " at point i,j,nb=",3i5)') slope,i,j,nb
             call wrf_message(msg)
 
             call wrf_message("Diagnostics 1: k, tauaer300, tauaer400,&
-               tauaer600, tauaer999, tauaer")
+             & tauaer600, tauaer999, tauaer")
             do k=kts,kte
                write(msg,'(i4,5f8.2)') k, tauaer300(i,k,j), tauaer400(i,k,j), &
                     tauaer600(i,k,j), tauaer999(i,k,j),tauaer(icol,k,nb)
@@ -12310,7 +12325,7 @@ SUBROUTINE RRTMG_SWRAD_FAST(                                &
             end do
 
             call wrf_message("Diagnostics 2: k, gaer300, gaer400, gaer600,&
-               gaer999")
+             & gaer999")
             do k=kts,kte
                write(msg,'(i4,4f8.2)') k, gaer300(i,k,j), gaer400(i,k,j), &
                     gaer600(i,k,j), gaer999(i,k,j)
@@ -12318,7 +12333,7 @@ SUBROUTINE RRTMG_SWRAD_FAST(                                &
             end do
 
             call wrf_message("Diagnostics 3: k, waer300, waer400, waer600,&
-               waer999")
+             & waer999")
             do k=kts,kte
                write(msg,'(i4,4f8.2)') k, waer300(i,k,j), waer400(i,k,j), &
                     waer600(i,k,j), waer999(i,k,j)
diff --git a/wrfv2_fire/phys/module_radiation_driver.F b/wrfv2_fire/phys/module_radiation_driver.F
index ee894062..6fec3181 100644
--- a/wrfv2_fire/phys/module_radiation_driver.F
+++ b/wrfv2_fire/phys/module_radiation_driver.F
@@ -678,7 +678,6 @@ SUBROUTINE radiation_driver (                                  &
 
    REAL , OPTIONAL, INTENT(INOUT) ::    radtacttime ! Storing the time in s when radiation is called next
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                  &
-         OPTIONAL,                                                &
          INTENT(INOUT)  ::                       o3rad
 
    ! vert nesting
@@ -1120,7 +1119,7 @@ SUBROUTINE radiation_driver (                                  &
 
      IF ( ICLOUD == 1 ) THEN
 
-     IF ( F_QC .AND. F_QI ) THEN
+     IF ( F_QC .OR. F_QI ) THEN
 ! Call to cloud fraction routine based on Randall 1994 (Hong Pan 1998)
 
         CALL wrf_debug (1, 'CALL cldfra1')
@@ -1157,6 +1156,7 @@ SUBROUTINE radiation_driver (                                  &
            DO j = jts,jte
            DO i = its,ite
            DO k = kts,kte
+              IF (qc(i,k,j) < 1.E-6 .AND. qi(i,k,j) < 1.E-6 .AND. CLDFRA_BL(i,k,j)>0.001) THEN
                !Partition the BL clouds into water & ice according to a linear
                !approximation of Hobbs et al. (1974). This allows us to only use
                !one 3D array for both cloud water & ice.
@@ -1166,6 +1166,7 @@ SUBROUTINE radiation_driver (                                  &
                CLDFRA(i,k,j)=MAX(0.0,MIN(1.0,CLDFRA(i,k,j)))
                qc(i,k,j)=qc(i,k,j) + QC_BL(i,k,j)*(MIN(1., MAX(0., (t(i,k,j)-254.)/15.)))*CLDFRA_BL(i,k,j)
                qi(i,k,j)=qi(i,k,j) + QC_BL(i,k,j)*(1. - MIN(1., MAX(0., (t(i,k,j)-254.)/15.)))*CLDFRA_BL(i,k,j)
+              ENDIF
            ENDDO
            ENDDO
            ENDDO
@@ -1192,7 +1193,7 @@ SUBROUTINE radiation_driver (                                  &
  
      ELSE IF ( ICLOUD == 2 ) THEN
 
-     IF ( F_QC .AND. F_QI ) THEN
+     IF ( F_QC .OR. F_QI ) THEN
        CALL wrf_debug (1, 'CALL cldfra2')
        CALL cal_cldfra2(CLDFRA,qc,qi,F_QC,F_QI,              &
                        ids,ide, jds,jde, kds,kde,            &
@@ -1229,15 +1230,9 @@ SUBROUTINE radiation_driver (                                  &
 
      END IF
 
-! ww: Interpolating climatological ozone and aerosol to model time and levels
+!     Interpolating climatological ozone and aerosol to model time and levels
 !     Adapted from camrad code
-     IF ( PRESENT( O3RAD ) ) THEN
-        call wrf_debug(1,'Have o3rad')
-#if (EM_CORE==1)
-     IF ( o3input .EQ. 2 .AND. id .EQ. 1 ) THEN
-#else
      IF ( o3input .EQ. 2 ) THEN
-#endif
 !       ! Find the current month (adapted from Cavallo)
 !       CALL cam_time_interp( ozmixm, pin, levsiz, date_str, &
 !                             ids , ide , jds , jde , kds , kde , &
@@ -1256,7 +1251,6 @@ SUBROUTINE radiation_driver (                                  &
                               ims , ime , jms , jme , kms , kme ,     &
                               its , ite , jts , jte , kts , kte )
      ENDIF
-     ENDIF
 
      IF ( PRESENT( AEROD ) ) THEN
      IF ( aer_opt .EQ. 1 .AND. id .EQ. 1 ) THEN
@@ -1284,9 +1278,12 @@ SUBROUTINE radiation_driver (                                  &
                     !Find whether to overwrite cldfra or not (ONLY if ICLOUD == 1)
                     compute_cldfra_cup = .true. 
                     if (icloud == 1 ) then
-                       compute_cldfra_cup = .false.     
+                       compute_cldfra_cup = .false.  !-- LK Berg, 4/26/17     
                        if(cldfra1_flag(i,k,j) == 1 .and. shall(i,j) .gt. 1) then
                           CLDFRA(i,k,j)=0.
+                       elseif(cldfra1_flag(i,k,j) == 1 .and. shall(i,j) .le. 1) then
+                          CLDFRA(i,k,j)=0.
+                          compute_cldfra_cup = .true.    ! No resolved clouds, but check of shallow clouds.  -- LK Berg, 4/26/17
                        elseif(cldfra1_flag(i,k,j) == 2 .and. shall(i,j) .gt. 1) then
                           CLDFRA(i,k,j)=1.
                        elseif(cldfra1_flag(i,k,j) == 3) then
@@ -1302,7 +1299,7 @@ SUBROUTINE radiation_driver (                                  &
                           cldfra_cup(i,k,j) = 0.0
                        end if
                     endif
-                    if( shall(i,j) == 1 .and. k >= cubot(i,j)  .and. k <= cutop(i,j)  ) then  ! 1=Shallow Cu
+                    if( shall(i,j) <= 1 .and. k >= cubot(i,j)  .and. k <= cutop(i,j)  ) then  ! 1=Shallow Cu  -- Changed to use for both deep and shallow  -- LK Berg 4/26/17
                        ! Begin: wig, 4-Feb-2008
                        !
                        ! Override the cloud condensate values if shallow convection triggered.
@@ -1310,8 +1307,8 @@ SUBROUTINE radiation_driver (                                  &
                        ! observations from CHAPS (Oklahoma area) and Florida (Blyth et al. 2005)
                        ! or the predicted value if it is greater.
 
-                       cldfra_cup_mod = cldfra_cup(i,k,j)* 1.0e-3*(1+qv(i,k,j))!modified cloud fraction
-                       qc(i,k,j) = max( 1.0e-3*cldfra_cup_mod, qc(i,k,j) )!DE+LB 2012-Feb
+                       cldfra_cup_mod = cldfra_cup(i,k,j) * 1.0e-3 !modified cloud fraction, assume QCLOUD is 1 g/kg -- LK Berg 4/26/17                       
+                       qc(i,k,j) = max(cldfra_cup_mod, qc(i,k,j) )!DE+LB 2012-Feb
 
                        ! Override the cloud fraction values calculated above if shallow
                        ! convection triggered. For shallow convection, use a representative
@@ -1400,9 +1397,9 @@ SUBROUTINE radiation_driver (                                  &
              CALL wrf_debug (100, 'CALL gfdllw')
 
              IF ( PRESENT(F_QV) .AND. PRESENT(F_QC) .AND.                     &
-                  PRESENT(F_QS) .AND. PRESENT(qs)   .AND.                     &
+                  PRESENT(F_QI) .AND. (PRESENT(qi) .OR. PRESENT(qs))  .AND.                     &
                   PRESENT(qv)   .AND. PRESENT(qc)   ) THEN
-               IF ( F_QV .AND. F_QC .AND. F_QS) THEN
+               IF ( F_QV .AND. F_QC .AND. (F_QI .OR. F_QS)) THEN
                  gfdl_lw  = .true.
                  CALL ETARA(                                        &
                   DT=dt,XLAND=xland                                 &
@@ -2078,9 +2075,9 @@ SUBROUTINE radiation_driver (                                  &
              CALL wrf_debug (100, 'CALL gfdlsw')
 
              IF ( PRESENT(F_QV) .AND. PRESENT(F_QC) .AND.                     &
-                  PRESENT(F_QS) .AND. PRESENT(qs)   .AND.                     &
-                  PRESENT(qv)   .AND. PRESENT(qc) ) THEN
-               IF ( F_QV .AND. F_QC .AND. F_QS ) THEN
+                  PRESENT(F_QI) .AND. (PRESENT(qi) .OR. PRESENT(qs))  .AND.                     &
+                  PRESENT(qv)   .AND. PRESENT(qc)   ) THEN
+               IF ( F_QV .AND. F_QC .AND. (F_QI .OR. F_QS)) THEN
                  gfdl_sw = .true.
                  CALL ETARA(                                        &
                   DT=dt,XLAND=xland                                 &
@@ -2766,12 +2763,12 @@ subroutine interp_sw_radiation(ims,ime,jms,jme,its,ite,jts,jte,  &
          do i=its,ite
             ! sza interpolation of surface fluxes
             if ((coszen_ref(i,j).gt.coszen_min) .and. (coszen_loc(i,j).gt.coszen_min)) then
-               if ((bb(i,j).eq.-0.5).or.(bb(i,j).eq.2.5)) then
+               if ((bb(i,j).eq.-0.5).or.(bb(i,j).eq.2.5).or.(bb(i,j).eq.0.0)) then
                   swddir(i,j) =(coszen_loc(i,j)/coszen_ref(i,j))*swddir_ref(i,j)
                else
                   swddir(i,j) =Bx(i,j)*(coszen_loc(i,j)**bb(i,j))
                end if
-               if ((gg(i,j).eq.-0.5).or.(gg(i,j).eq.2.5)) then
+               if ((gg(i,j).eq.-0.5).or.(gg(i,j).eq.2.5).or.(gg(i,j).eq.0.0)) then
                   swdown(i,j) =(coszen_loc(i,j)/coszen_ref(i,j))*swdown_ref(i,j)
                else
                   swdown(i,j) =Gx(i,j)*(coszen_loc(i,j)**gg(i,j))
@@ -3001,6 +2998,16 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS,                    &
             ENDIF
          ENDIF
 
+! for P3, mp option 50 or 51
+         IF ( F_QI .and. F_QC .and. .not. F_QS) THEN
+            QCLD = QI(i,k,j)+QC(i,k,j)
+            IF (QCLD .LT. QCLDMIN) THEN
+               weight = 0.
+            ELSE
+               weight = (QI(i,k,j)) / QCLD
+            ENDIF
+         ENDIF
+
 ! mji - For MP options 1 and 3, (qc only)
 !  For MP=1, qc = liquid, for MP=3, qc = liquid or ice depending on temperature
          IF ( F_QC .and. .not. F_QI .and. .not. F_QS ) THEN
@@ -3107,6 +3114,7 @@ SUBROUTINE cal_cldfra1(CLDFRA, QV, QC, QI, QS,                    &
 
    END SUBROUTINE cal_cldfra1
 
+
 !+---+-----------------------------------------------------------------+
 !..Cloud fraction scheme by G. Thompson (NCAR-RAL), not intended for
 !.. combining with any cumulus or shallow cumulus parameterization
@@ -3124,6 +3132,7 @@ END SUBROUTINE cal_cldfra1
 
       SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs,                    &
      &                 p,t,rho, XLAND, gridkm,                          &
+!    &                 rand_perturb_on, kme_stoch, rand_pert,           &
      &                 ids,ide, jds,jde, kds,kde,                       &
      &                 ims,ime, jms,jme, kms,kme,                       &
      &                 its,ite, jts,jte, kts,kte)
@@ -3133,21 +3142,24 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs,                    &
 !
       INTEGER, INTENT(IN):: ids,ide, jds,jde, kds,kde,                  &
      &                      ims,ime, jms,jme, kms,kme,                  &
+!    &                      kme_stoch,                                  &
      &                      its,ite, jts,jte, kts,kte
 
+!     INTEGER, INTENT(IN):: rand_perturb_on
       REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(IN):: qv,p,t,rho
       REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT):: qc,qi,qs
+!     REAL, DIMENSION(ims:ime,kms:kme_stoch,jms:jme), INTENT(IN):: rand_pert
       REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN):: XLAND
 
       REAL, DIMENSION(ims:ime,kms:kme,jms:jme), INTENT(INOUT):: cldfra
       REAL, INTENT(IN):: gridkm
 
 !..Local vars.
-      REAL:: RH_00L, RH_00O, RH_00, RHI_max
+      REAL:: RH_00L, RH_00O, RH_00, RHI_max, entrmnt
       REAL, DIMENSION(ims:ime,kms:kme,jms:jme):: qvsat
       INTEGER:: i,j,k
-      REAL:: TK, TC, qvsi, qvsw, RHUM
-      REAL, DIMENSION(kms:kme):: qvs1d, cfr1d, T1d,                     &
+      REAL:: TK, TC, qvsi, qvsw, RHUM, xx, yy
+      REAL, DIMENSION(kts:kte):: qvs1d, cfr1d, T1d,                     &
      &                           P1d, R1d, qc1d, qi1d, qs1d
 
       character*512 dbg_msg
@@ -3161,20 +3173,19 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs,                    &
 !.. to get near 100% RH as grid spacing moves toward 1.0km, but higher
 !.. RH over ocean required as compared to over land.
 
-      RH_00L = 0.839 + SQRT(1./(50.0+gridkm*gridkm*gridkm*0.5))
-      RH_00O = 0.879 + SQRT(1./(100.0+gridkm*gridkm))
+      RH_00L = 0.7  + SQRT(1./(25.0+gridkm*gridkm*gridkm))
+      RH_00O = 0.81 + SQRT(1./(50.0+gridkm*gridkm*gridkm))
 
       DO j = jts,jte
       DO k = kts,kte
       DO i = its,ite
-         RHI_max = 0.0
+
          CLDFRA(I,K,J) = 0.0
 
-         if (qc(i,k,j)+qi(i,k,j) .gt. 1.E-8) then
+         if (qc(i,k,j).gt.1.E-6 .or. qi(i,k,j).ge.1.E-7 .or. qs(i,k,j).gt.1.E-5) then
             CLDFRA(I,K,J) = 1.0
             qvsat(i,k,j) = qv(i,k,j)
          else
-
             TK   = t(i,k,j)
             TC   = TK - 273.16
 
@@ -3183,12 +3194,12 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs,                    &
 
             if (tc .ge. -12.0) then
                qvsat(i,k,j) = qvsw
-            elseif (tc .lt. -30.0) then
+            elseif (tc .lt. -20.0) then
                qvsat(i,k,j) = qvsi
             else
-               qvsat(i,k,j) = qvsw - (qvsw-qvsi)*(-12.0-tc)/(-12.0+30.)
+               qvsat(i,k,j) = qvsw - (qvsw-qvsi)*(-12.0-tc)/(-12.0+20.)
             endif
-            RHUM = qv(i,k,j)/qvsat(i,k,j)
+            RHUM = MAX(0.01, MIN(qv(i,k,j)/qvsat(i,k,j), 0.9999))
 
             IF ((XLAND(I,J)-1.5).GT.0.) THEN                             !--- Ocean
                RH_00 = RH_00O
@@ -3199,13 +3210,11 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs,                    &
             if (tc .ge. -12.0) then
                RHUM = MIN(0.999, RHUM)
                CLDFRA(I,K,J) = MAX(0.0, 1.0-SQRT((1.0-RHUM)/(1.-RH_00)))
-            elseif (tc.lt.-12..and.tc.gt.-70. .and. RHUM.gt.RH_00O) then
-               RHI_max = MAX(RHUM+1.E-6, qvsw/qvsi)
-               CLDFRA(I,K,J) = MAX(0., ((RH_00O-RHUM)/(RH_00O-RHI_max)) &
-     &                                *((RH_00O-RHUM)/(RH_00O-RHI_max)))
+            elseif (tc.lt.-12..and.tc.gt.-70. .and. RHUM.gt.RH_00L) then
+               RHUM = MAX(0.01, MIN(qv(i,k,j)/qvsat(i,k,j), 1.0 - 1.E-6))
+               CLDFRA(I,K,J) = MAX(0., 1.0-SQRT((1.0-RHUM)/(1.0-RH_00L)))
             endif
-
-            CLDFRA(I,K,J) = MAX(0.0, MIN(CLDFRA(I,K,J), 0.95))
+            CLDFRA(I,K,J) = MIN(0.90, CLDFRA(I,K,J))
 
          endif
       ENDDO
@@ -3221,6 +3230,13 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs,                    &
 !        else
 !           debug_flag = .false.
 !        endif
+
+!        if (rand_perturb_on .eq. 1) then
+!           entrmnt = MAX(0.01, MIN(0.99, 0.5 + rand_pert(i,1,j)*0.5))
+!        else
+            entrmnt = 0.5
+!        endif
+
          DO k = kts,kte
             qvs1d(k) = qvsat(i,k,j)
             cfr1d(k) = cldfra(i,k,j)
@@ -3236,7 +3252,7 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs,                    &
 !       WRITE (dbg_msg,*) 'DEBUG-GT: finding cloud layers at point  (', i, ', ', j, ')'
 !       CALL wrf_debug (150, dbg_msg)
 !     endif
-         call find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d,             &
+         call find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt,    &
      &                         debug_flag, qc1d, qi1d, qs1d, kts,kte)
 
          DO k = kts,kte
@@ -3247,6 +3263,7 @@ SUBROUTINE cal_cldfra3(CLDFRA, qv, qc, qi, qs,                    &
       ENDDO
       ENDDO
 
+
       END SUBROUTINE cal_cldfra3
 
 !+---+-----------------------------------------------------------------+
@@ -3254,13 +3271,14 @@ END SUBROUTINE cal_cldfra3
 !.. a reasonable value of LWP or IWP that might be contained in that depth,
 !.. unless existing LWC/IWC is already there.
 
-      SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d,          &
+      SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d, entrmnt, &
      &                            debugfl, qc1d, qi1d, qs1d, kts,kte)
 !
       IMPLICIT NONE
 !
       INTEGER, INTENT(IN):: kts, kte
       LOGICAL, INTENT(IN):: debugfl
+      REAL, INTENT(IN):: entrmnt
       REAL, DIMENSION(kts:kte), INTENT(IN):: qvs1d,T1d,P1d,R1d
       REAL, DIMENSION(kts:kte), INTENT(INOUT):: cfr1d
       REAL, DIMENSION(kts:kte), INTENT(INOUT):: qc1d, qi1d, qs1d
@@ -3278,8 +3296,8 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d,          &
       k_m40C = 0
       DO k = kte, kts, -1
          theta(k) = T1d(k)*((100000.0/P1d(k))**(287.05/1004.))
-         if (T1d(k)-273.16 .gt. -40.0) k_m40C = MAX(k_m40C, k)
-         if (T1d(k)-273.16 .gt. -12.0) k_m12C = MAX(k_m12C, k)
+         if (T1d(k)-273.16 .gt. -40.0 .and. P1d(k).gt.7000.0) k_m40C = MAX(k_m40C, k)
+         if (T1d(k)-273.16 .gt. -12.0 .and. P1d(k).gt.10000.0) k_m12C = MAX(k_m12C, k)
       ENDDO
       if (k_m40C .le. kts) k_m40C = kts
       if (k_m12C .le. kts) k_m12C = kts
@@ -3336,7 +3354,7 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d,          &
       DO k = kbot, k_m12C
          if ( (theta(k)-theta(k-1)) .gt. 0.05E-3*dz(k)) EXIT
       ENDDO
-      kbot = MAX(kts+1, k-1)
+      kbot = MAX(kts+1, k-2)
       DO k = kts, kbot
          if (cfr1d(k).gt.0.0 .and. cfr1d(k).lt.0.999) cfr1d(k) = 0.
       ENDDO
@@ -3374,8 +3392,11 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d,          &
 !       CALL wrf_debug (150, dbg_msg)
 !     endif
             call adjust_cloudIce(cfr1d, qi1d, qs1d, qvs1d, T1d,R1d,dz,  &
-     &                           k_cldb,k_cldt,kts,kte)
+     &                           entrmnt, k_cldb,k_cldt,kts,kte)
             k = k_cldb
+         else
+            if (cfr1d(k_cldb).gt.0.and.qi1d(k_cldb).lt.1.E-6)           &
+     &               qi1d(k_cldb)=1.E-5*cfr1d(k_cldb)
          endif
          k = k - 1
       ENDDO
@@ -3383,7 +3404,7 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d,          &
 
       k_cldb = k_tropo
       in_cloud = .false.
-      k = k_m12C
+      k = k_m12C + 2
       DO WHILE (.not. in_cloud .AND. k.gt.kbot)
          k_cldt = 0
          if (cfr1d(k).ge.0.01) then
@@ -3407,8 +3428,11 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d,          &
 !       CALL wrf_debug (150, dbg_msg)
 !     endif
             call adjust_cloudH2O(cfr1d, qc1d, qvs1d, T1d,R1d,dz,        &
-     &                           k_cldb,k_cldt,kts,kte)
+     &                           entrmnt, k_cldb,k_cldt,kts,kte)
             k = k_cldb
+         else
+            if (cfr1d(k_cldb).gt.0.and.qc1d(k_cldb).lt.1.E-6)           &
+     &               qc1d(k_cldb)=1.E-5*cfr1d(k_cldb)
          endif
          k = k - 1
       ENDDO
@@ -3433,38 +3457,48 @@ SUBROUTINE find_cloudLayers(qvs1d, cfr1d, T1d, P1d, R1d,          &
 !       enddo
 !     endif
 
+
       END SUBROUTINE find_cloudLayers
 
 !+---+-----------------------------------------------------------------+
 
-      SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs, T,Rho,dz, k1,k2,kts,kte)
+      SUBROUTINE adjust_cloudIce(cfr,qi,qs,qvs, T,Rho,dz, entr, k1,k2,kts,kte)
 !
       IMPLICIT NONE
 !
       INTEGER, INTENT(IN):: k1,k2, kts,kte
+      REAL, INTENT(IN):: entr
       REAL, DIMENSION(kts:kte), INTENT(IN):: cfr, qvs, T, Rho, dz
       REAL, DIMENSION(kts:kte), INTENT(INOUT):: qi, qs
-      REAL:: iwp, xiwp, max_iwp, tdz, this_iwp, iwp_exists
-      INTEGER:: k
-      REAL, PARAMETER:: entr=0.35
-
-      max_iwp = ABS(qvs(k2-1)-qvs(k2))*Rho(k2-1)*dz(k2-1)
+      REAL:: iwc, max_iwc, tdz, this_iwc, this_dz, iwp_exists
+      INTEGER:: k, kmid
 
       tdz = 0.
-      iwp = 0.
-      iwp_exists = 0.
       do k = k1, k2
          tdz = tdz + dz(k)
-         iwp = iwp + MAX(0., (qvs(k-1)-qvs(k))*Rho(k)*dz(k))
+      enddo
+      kmid = NINT(0.5*(k1+k2))
+      max_iwc = ABS(qvs(k2-1)-qvs(k1))
+!     print*, ' max_iwc = ', max_iwc, ' over DZ=',tdz
+
+      iwp_exists = 0.
+      do k = k1, k2
          iwp_exists = iwp_exists + (qi(k)+qs(k))*Rho(k)*dz(k)
       enddo
-      if (iwp_exists .gt. 1.0) RETURN
-      max_iwp = MAX(max_iwp*(1.-entr), MIN(1.0, iwp*(1.0-entr)))
 
+      this_dz = 0.0
       do k = k1, k2
-         this_iwp = max_iwp*dz(k)/tdz
+         if (k.eq.k1) then
+            this_dz = this_dz + 0.5*dz(k)
+         else
+            this_dz = this_dz + dz(k)
+         endif
+         this_iwc = max_iwc*this_dz/tdz
+         iwc = MAX(1.E-6, this_iwc*(1.-entr))
          if (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).ge.203.16) then
-            qi(k) = qi(k) + cfr(k)*cfr(k)*this_iwp/Rho(k)/dz(k)
+            qi(k) = qi(k) + 0.1*cfr(k)*iwc
+         elseif (qi(k).lt.1.E-5.and.cfr(k).ge.0.99.and.T(k).ge.203.16) then
+            qi(k) = qi(k) + 0.01*iwc
          endif
       enddo
 
@@ -3472,43 +3506,49 @@ END SUBROUTINE adjust_cloudIce
 
 !+---+-----------------------------------------------------------------+
 
-      SUBROUTINE adjust_cloudH2O(cfr, qc, qvs, T,Rho,dz, k1,k2,kts,kte)
+      SUBROUTINE adjust_cloudH2O(cfr, qc, qvs, T,Rho,dz, entr, k1,k2,kts,kte)
 !
       IMPLICIT NONE
 !
       INTEGER, INTENT(IN):: k1,k2, kts,kte
+      REAL, INTENT(IN):: entr
       REAL, DIMENSION(kts:kte):: cfr, qc, qvs, T, Rho, dz
-      REAL:: lwp, xlwp, max_lwp, tdz, this_lwp, lwp_exists
-      INTEGER:: k
-      REAL, PARAMETER:: entr=0.35
-
-      max_lwp = ABS(qvs(k2-1)-qvs(k2))*Rho(k2-1)*dz(k2-1)
+      REAL:: lwc, max_lwc, tdz, this_lwc, this_dz, lwp_exists
+      INTEGER:: k, kmid
 
       tdz = 0.
-      lwp = 0.
-      lwp_exists = 0.
       do k = k1, k2
          tdz = tdz + dz(k)
-         lwp = lwp + MAX(0., (qvs(k-1)-qvs(k))*Rho(k)*dz(k))
+      enddo
+      kmid = NINT(0.5*(k1+k2))
+      max_lwc = ABS(qvs(k2-1)-qvs(k1))
+!     print*, ' max_lwc = ', max_lwc, ' over DZ=',tdz
+
+      lwp_exists = 0.
+      do k = k1, k2
          lwp_exists = lwp_exists + qc(k)*Rho(k)*dz(k)
       enddo
-      if (lwp_exists .gt. 1.0) RETURN
-      max_lwp = MAX(max_lwp*(1.-entr), MIN(1.0, lwp*(1.0-entr)))
 
+      this_dz = 0.0
       do k = k1, k2
-         this_lwp = max_lwp*dz(k)/tdz
-         if (cfr(k).gt.0.95.and.qc(k).lt.1.E-7.and.T(k).lt.253.16) then
-            qc(k) = qc(k) + 0.05*this_lwp/Rho(k)/dz(k)
-         elseif (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).lt.273.16.and.T(k).ge.253.16) then
-            qc(k) = qc(k) + cfr(k)*this_lwp/Rho(k)/dz(k)
-         elseif (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).le.298.16.and.T(k).ge.273.16) then
-            qc(k) = qc(k) + cfr(k)*cfr(k)*this_lwp/Rho(k)/dz(k)
+         if (k.eq.k1) then
+            this_dz = this_dz + 0.5*dz(k)
+         else
+            this_dz = this_dz + dz(k)
+         endif
+         this_lwc = max_lwc*this_dz/tdz
+         lwc = MAX(1.E-6, this_lwc*(1.-entr))
+         if (cfr(k).gt.0.01.and.cfr(k).lt.0.99.and.T(k).lt.298.16.and.T(k).ge.253.16) then
+            qc(k) = qc(k) + cfr(k)*cfr(k)*lwc
+         elseif (cfr(k).ge.0.99.and.qc(k).lt.1.E-5.and.T(k).lt.298.16.and.T(k).ge.253.16) then
+            qc(k) = qc(k) + 0.1*lwc
          endif
       enddo
 
       END SUBROUTINE adjust_cloudH2O
 
 !+---+-----------------------------------------------------------------+
+
 !..Do not alter any grid-explicitly resolved hydrometeors, rather only
 !.. the supposed amounts due to the cloud fraction scheme.
 
@@ -3523,20 +3563,15 @@ SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte,k_tropo)
       INTEGER:: k
 
       lwp = 0.
-      do k = kts, k_tropo
-         if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then
-            lwp = lwp + qc(k)*Rho(k)*dz(k)
-         endif
-      enddo
-
       iwp = 0.
       do k = kts, k_tropo
-         if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then
+         if (cfr(k).gt.0.0) then
+            lwp = lwp + qc(k)*Rho(k)*dz(k)
             iwp = iwp + qi(k)*Rho(k)*dz(k)
          endif
       enddo
 
-      if (lwp .gt. 1.0) then
+      if (lwp .gt. 1.5) then
          xfac = 1./lwp
          do k = kts, k_tropo
             if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then
@@ -3545,7 +3580,7 @@ SUBROUTINE adjust_cloudFinal(cfr, qc, qi, Rho,dz, kts,kte,k_tropo)
          enddo
       endif
 
-      if (iwp .gt. 1.0) then
+      if (iwp .gt. 1.5) then
          xfac = 1./iwp
          do k = kts, k_tropo
             if (cfr(k).gt.0.01 .and. cfr(k).lt.0.99) then
@@ -4485,10 +4520,11 @@ SUBROUTINE gt_aod(p_phy,DZ8W,t_phy,qvapor, nwfa,nifa, taod5503d,  &
 
       REAL, DIMENSION(its:ite,kts:kte,jts:jte):: AOD_wfa, AOD_ifa
       REAL:: RH, a_RH,b_RH, rh_d,rh_f, rhoa,qvsat, unit_bext1,unit_bext3
+      REAL:: ntemp
       INTEGER :: i, k, j, RH_idx, RH_idx1, RH_idx2, t_idx
       INTEGER, PARAMETER:: rind=8
       REAL, DIMENSION(rind), PARAMETER:: rh_arr =                       &
-     &                      (/10., 60., 70., 80., 85., 90., 95., 100./)
+     &                      (/10., 60., 70., 80., 85., 90., 95., 99.8/)
       REAL, DIMENSION(rind,4,2) :: lookup_tabl                           ! RH, temp, water-friendly, ice-friendly
 
       lookup_tabl(1,1,1) =  5.73936E-15  
@@ -4578,7 +4614,7 @@ SUBROUTINE gt_aod(p_phy,DZ8W,t_phy,qvapor, nwfa,nifa, taod5503d,  &
                rhoa = p_phy(i,k,j)/(287.*t_phy(i,k,j))
                t_idx = MAX(1, MIN(nint(10.999-0.0333*t_phy(i,k,j)),4))
                qvsat = rslf(p_phy(i,k,j),t_phy(i,k,j))
-               RH = MIN(97., MAX(10.1, qvapor(i,k,j)/qvsat*100.))
+               RH = MIN(98., MAX(10.1, qvapor(i,k,j)/qvsat*100.))
 
                !..Get the index for the RH array element
 
@@ -4621,8 +4657,11 @@ SUBROUTINE gt_aod(p_phy,DZ8W,t_phy,qvapor, nwfa,nifa, taod5503d,  &
 
                !..RH fraction to be used
 
-               rh_f = MAX(0., MIN( (rh-rh_arr(rh_idx1))                 &
-     &                         /(rh_arr(rh_idx2)-rh_arr(rh_idx1)), 1.0))
+               rh_f = MAX(0., MIN(1.0, (rh/(100-rh)-rh_arr(rh_idx1)     &
+     &                                  /(100-rh_arr(rh_idx1)))         &
+     &                        /(rh_arr(rh_idx2)/(100-rh_arr(rh_idx2))   &
+     &                        -rh_arr(rh_idx1)/(100-rh_arr(rh_idx1))) ))
+
       
                unit_bext1 = lookup_tabl(RH_idx1,t_idx,1)                &
      &                    + (lookup_tabl(RH_idx2,t_idx,1)               &
@@ -4631,8 +4670,11 @@ SUBROUTINE gt_aod(p_phy,DZ8W,t_phy,qvapor, nwfa,nifa, taod5503d,  &
      &                    + (lookup_tabl(RH_idx2,t_idx,2)               &
      &                    - lookup_tabl(RH_idx1,t_idx,2))*rh_f
 
-               AOD_wfa(i,k,j) = unit_bext1*nwfa(i,k,j)*dz8w(i,k,j)*rhoa
-               AOD_ifa(i,k,j) = unit_bext3*nifa(i,k,j)*dz8w(i,k,j)*rhoa
+               ntemp = MAX(1., MIN(99999.E6, nwfa(i,k,j)))
+               AOD_wfa(i,k,j) = unit_bext1*ntemp*dz8w(i,k,j)*rhoa
+
+               ntemp = MAX(0.01, MIN(9999.E6, nifa(i,k,j)))
+               AOD_ifa(i,k,j) = unit_bext3*ntemp*dz8w(i,k,j)*rhoa
 
             END DO
          END DO
diff --git a/wrfv2_fire/phys/module_sf_bem.F b/wrfv2_fire/phys/module_sf_bem.F
index d9600846..7666b7b2 100644
--- a/wrfv2_fire/phys/module_sf_bem.F
+++ b/wrfv2_fire/phys/module_sf_bem.F
@@ -174,8 +174,8 @@ subroutine BEM(nzcanm,nlev,nhourday,dt,bw,bl,dzlev,            &
         real consump(nzcanm)            !Consumption for the a.c. in each floor [W]
 	real hsvent(nzcanm)		!sensible heat generated by natural ventilation [W]
 	real hlvent(nzcanm)		!latent heat generated by natural ventilation [W] 
-        real gsrof                      !heat flux flowing inside the roof [W/m²]
-        real gswal(4,nzcanm)             !heat flux flowing inside the floors [W/m²]
+        real gsrof                      !heat flux flowing inside the roof [W/m^2]
+        real gswal(4,nzcanm)             !heat flux flowing inside the floors [W/m^2]
 
 ! Local:
 ! -----
@@ -986,7 +986,7 @@ subroutine hsinsflux(swsurf,swwin,tin,tw,hsins)
 	real hsins	!internal sensible heat flux [W/m2]
 !Local
 !-----
-	real hc		!heat conduction coefficient [W/°C.m2]
+	real hc		!heat conduction coefficient [W/C.m2]
 !--------------------------------------------------------------------
 
 	if (swsurf.eq.2) then	!vertical surface
@@ -1054,7 +1054,7 @@ subroutine int_rsrad(albwin,albwal,pwin,rswal,&
             enddo
 
 !We suppose that the radiation is spread isotropically within the
-!room when it passes through the windows, so the flux [W/m²] in every 
+!room when it passes through the windows, so the flux [W/m^2] in every 
 !wall is:
 
             surtotwal=0.
@@ -1662,7 +1662,7 @@ subroutine phiequ(nhourday,hsesf,hsequip,hsequ)
 	
 !Output
 !------
-	real hsequ    !sensible heat gain from equipment [Wm¯2]
+	real hsequ    !sensible heat gain from equipment [W/m^2]
 
 !---------------------------------------------------------------------	
 
diff --git a/wrfv2_fire/phys/module_sf_bep.F b/wrfv2_fire/phys/module_sf_bep.F
index df40e00c..d059e0fc 100644
--- a/wrfv2_fire/phys/module_sf_bep.F
+++ b/wrfv2_fire/phys/module_sf_bep.F
@@ -3191,11 +3191,11 @@ subroutine upward_rad(ndu,nzu,ws,bs,sigma,pb,ss,                     &
       real rlw(2*ndm,nz_um)         ! Long wave radiation at the walls for a given canyon direction [W/m2]
       real rsg(ndm)                   ! Short wave radiation at the canyon for a given canyon direction [W/m2]
       real rlg(ndm)                   ! Long wave radiation at the ground for a given canyon direction [W/m2]
-      real rs                        ! Short wave radiation at the horizontal surface from the sun [W/m²]  
-      real sfw(2*ndm,nz_um)      ! Sensible heat flux from walls [W/m²]
-      real sfg(ndm)              ! Sensible heat flux from ground (road) [W/m²]
-      real sfr(ndm,nz_um)      ! Sensible heat flux from roofs [W/m²]                      
-      real rld                        ! Long wave radiation from the sky [W/m²]
+      real rs                        ! Short wave radiation at the horizontal surface from the sun [W/m2]  
+      real sfw(2*ndm,nz_um)      ! Sensible heat flux from walls [W/m2]
+      real sfg(ndm)              ! Sensible heat flux from ground (road) [W/m2]
+      real sfr(ndm,nz_um)      ! Sensible heat flux from roofs [W/m2]                      
+      real rld                        ! Long wave radiation from the sky [W/m2]
       real albg_u                    ! albedo of the ground/street
       real albw_u                    ! albedo of the walls
       real albr_u                    ! albedo of the roof 
diff --git a/wrfv2_fire/phys/module_sf_bep_bem.F b/wrfv2_fire/phys/module_sf_bep_bem.F
index e5f15187..fb2d6c2a 100644
--- a/wrfv2_fire/phys/module_sf_bep_bem.F
+++ b/wrfv2_fire/phys/module_sf_bep_bem.F
@@ -402,7 +402,7 @@ subroutine BEP_BEM(FRC_URB2D,UTYPE_URB2D,itimestep,dz8w,dt,u_phy,v_phy,      &
 ! 261-304
 !
 ! F. Salamanca and A. Martilli, 2009: 'A new Building Energy Model coupled 
-! with an Urban Canopy Parameterization for urban climate simulations—part II. 
+! with an Urban Canopy Parameterization for urban climate simulations-part II. 
 ! Validation with one dimension off-line simulations'. Theor Appl Climatol
 ! DOI 10.1007/s00704-009-0143-8 
 !------------------------------------------------------------------------
@@ -1250,12 +1250,12 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0,   &
       real alaf(nf_u+1)     ! Floor thermal diffusivity at each wall layers [W/m K]     
       real alagb(ngb_u+1)   ! Ground thermal diffusivity below the building at each wall layer [W/m K] 
 
-      real sfrb(ndm,nbui_max)        ! Sensible heat flux from roofs [W/m²]
-      real gfrb(ndm,nbui_max)        ! Heat flux flowing inside the roofs [W/m²]
-      real sfwb1D(2*ndm,nz_um)    !Sensible heat flux from the walls [W/m²] 
-      real sfwin(2*ndm,nz_um,nbui_max)!Sensible heat flux from windows [W/m²]
-      real sfwinb1D(2*ndm,nz_um)  !Sensible heat flux from windows [W/m²]
-      real gfwb1D(2*ndm,nz_um)    !Heat flux flowing inside the walls [W/m²]
+      real sfrb(ndm,nbui_max)        ! Sensible heat flux from roofs [W/m2]
+      real gfrb(ndm,nbui_max)        ! Heat flux flowing inside the roofs [W/m2]
+      real sfwb1D(2*ndm,nz_um)    !Sensible heat flux from the walls [W/m2] 
+      real sfwin(2*ndm,nz_um,nbui_max)!Sensible heat flux from windows [W/m2]
+      real sfwinb1D(2*ndm,nz_um)  !Sensible heat flux from windows [W/m2]
+      real gfwb1D(2*ndm,nz_um)    !Heat flux flowing inside the walls [W/m2]
 
       real qlev(nz_um,nbui_max)      !specific humidity [kg/kg]
       real qlevb1D(nz_um)         !specific humidity [kg/kg] 
@@ -1359,7 +1359,7 @@ subroutine BEP1D(iurb,kms,kme,kts,kte,z,dt,ua,va,pt,da,pr,pt0,   &
        gfrb=0.     !Heat flux flowing inside the roof
        sfwb1D=0.   !Sensible heat flux from walls
        sfwinb1D=0. !Sensible heat flux from windows
-       gfwb1D=0.   !Heat flux flowing inside the walls[W/m²]
+       gfwb1D=0.   !Heat flux flowing inside the walls[W/m2]
 
 
        twb1D=0.    !Wall temperature
@@ -4198,11 +4198,11 @@ subroutine upward_rad(ndu,nzu,ws,bs,sigma,pb,ss,                &
       real rlw(2*ndm,nz_um)         ! Long wave radiation at the walls for a given canyon direction [W/m2]
       real rsg(ndm)                   ! Short wave radiation at the canyon for a given canyon direction [W/m2]
       real rlg(ndm)                   ! Long wave radiation at the ground for a given canyon direction [W/m2]
-      real rs                        ! Short wave radiation at the horizontal surface from the sun [W/m²]  
-      real sfw(2*ndm,nz_um)      ! Sensible heat flux from walls [W/m²]
-      real sfg(ndm)              ! Sensible heat flux from ground (road) [W/m²]
-      real sfr(ndm,nz_um)      ! Sensible heat flux from roofs [W/m²]                      
-      real rld                        ! Long wave radiation from the sky [W/m²]
+      real rs                        ! Short wave radiation at the horizontal surface from the sun [W/m2]  
+      real sfw(2*ndm,nz_um)      ! Sensible heat flux from walls [W/m2]
+      real sfg(ndm)              ! Sensible heat flux from ground (road) [W/m2]
+      real sfr(ndm,nz_um)      ! Sensible heat flux from roofs [W/m2]                      
+      real rld                        ! Long wave radiation from the sky [W/m2]
       real albg_u                    ! albedo of the ground/street
       real albw_u                    ! albedo of the walls
       real albr_u                    ! albedo of the roof 
@@ -4229,7 +4229,7 @@ subroutine upward_rad(ndu,nzu,ws,bs,sigma,pb,ss,                &
       real twlev(2*ndm,nz_um)   !Averaged Temperature of the windows 
       real pwin                 !Coverage area fraction of the windows
       real gflwin               !Heat stored for the windows
-      real sfwind(2*ndm,nz_um)  !Sensible heat flux from windows [W/m²]
+      real sfwind(2*ndm,nz_um)  !Sensible heat flux from windows [W/m2]
 
 !OUTPUT/INPUT
       real rs_abs  ! absrobed solar radiationfor this street direction
diff --git a/wrfv2_fire/phys/module_sf_exchcoef.F b/wrfv2_fire/phys/module_sf_exchcoef.F
index 5b07b59e..a9fc155b 100755
--- a/wrfv2_fire/phys/module_sf_exchcoef.F
+++ b/wrfv2_fire/phys/module_sf_exchcoef.F
@@ -220,5 +220,89 @@ SUBROUTINE znot_t_v2(uu,znott)
   END SUBROUTINE znot_t_v2
 
 
+   SUBROUTINE znot_wind10m(w10m,znott,znotm,icoef_sf)
+   IMPLICIT NONE
+
+! w10m(m/s)   :   10-m wind speed
+! znott(meter):   Roughness scale for temperature/moisture, zt
+! znotm(meter):   Roughness scale for momentum, z0
+! Author      :  Weiguo Wang on 02/24/2016
+!            convert from icoef=0,1,2 to have 10m level cd, ch match obs
+     REAL, INTENT(IN) :: w10m
+     INTEGER, INTENT(IN) :: icoef_sf
+     REAL, INTENT(OUT):: znott, znotm
+
+     real :: zm,zt,windmks, zlev,z10, tmp, zlevt, aaa, zm1,zt1
+        zlev=20.0
+        zlevt=10.0
+        z10=10.0
+            windmks=w10m
+            if (windmks > 85.0) windmks=85.0
+            if (windmks < 1.0) windmks=1.0
+            if ( icoef_sf .EQ. 1) then
+              call  znot_m_v1(windmks,zm1)
+              call  znot_t_v1(windmks,zt1)
+
+            else if ( icoef_sf .EQ. 0 ) then
+              call  znot_m_v0(windmks,zm1)
+              call  znot_t_v0(windmks,zt1)
+
+            else  if( icoef_sf .EQ. 2 ) then
+              call  znot_m_v1(windmks,zm1)
+              call  znot_t_v2(windmks,zt1)
+
+            else  if( icoef_sf .EQ. 3 ) then
+              call  znot_m_v1(windmks,zm)
+              call  znot_t_v2(windmks,zt)
+!! adjust a little to match obs at 10m, cd is reduced
+            tmp=0.4*0.4/(alog(zlev/zm))**2   ! cd at zlev
+            zm1=z10/exp( sqrt(0.4*0.4/(tmp*0.95-0.0002)) ) 
+!ch
+            tmp=0.4*0.4/(alog(zlevt/zm)*alog(zlevt/zt))  ! ch at zlev using old formula
+            zt1=z10/exp( 0.4*0.4/( 0.95*tmp*alog(z10/zm1) )  )
+
+            else if( icoef_sf .EQ. 4 ) then
+
+              call  znot_m_v1(windmks,zm)
+              call  znot_t_v2(windmks,zt)
+!!  for wind<20, cd similar to icoef=2 at 10m, then reduced 
+             tmp=0.4*0.4/(alog(10.0/zm))**2   ! cd at zlev
+             aaa=0.75
+            if (windmks < 20) then
+              aaa=0.99
+            elseif(windmks < 45.0) then
+              aaa=0.99+(windmks-20)*(0.75-0.99)/(45.0-20.0)
+            endif
+            zm1=z10/exp( sqrt(0.4*0.4/(tmp*aaa)) )  
+!ch
+          tmp=0.4*0.4/(alog(zlevt/zm)*alog(zlevt/zt))  ! ch at zlev using old formula
+            zt1=z10/exp( 0.4*0.4/( 0.95*tmp*alog(z10/zm1) )  )
+
+            else if( icoef_sf .EQ. 5 ) then
+
+              call  znot_m_v1(windmks,zm)
+              call  znot_t_v2(windmks,zt)
+!!  for wind<20, cd similar to icoef=2 at 10m, then reduced
+             tmp=0.4*0.4/(alog(10.0/zm))**2   ! cd at zlev
+             aaa=0.80
+            if (windmks < 20) then
+              aaa=1.0
+            elseif(windmks < 45.0) then
+              aaa=1.0+(windmks-20)*(0.80-1.0)/(45.0-20.0)
+            endif
+            zm1=z10/exp( sqrt(0.4*0.4/(tmp*aaa)) )
+!ch
+          tmp=0.4*0.4/(alog(zlevt/zm)*alog(zlevt/zt))  ! ch at zlev using old formula
+            zt1=z10/exp( 0.4*0.4/( 1.0*tmp*alog(z10/zm1) )  )
+
+           else
+             write(0,*)'stop, icoef_sf must be one of 0,1,2,3, 4, 5'
+             stop
+          endif
+          znott=zt1
+          znotm=zm1
+
+  end subroutine znot_wind10m
+
 END MODULE module_sf_exchcoef
 
diff --git a/wrfv2_fire/phys/module_sf_gfdl.F b/wrfv2_fire/phys/module_sf_gfdl.F
index 23888282..a66a9135 100755
--- a/wrfv2_fire/phys/module_sf_gfdl.F
+++ b/wrfv2_fire/phys/module_sf_gfdl.F
@@ -16,9 +16,9 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
                      UST,PSIM,PSIH,                             &   
                      XLAND,HFX,QFX,TAUX,TAUY,LH,GSW,GLW,TSK,FLHC,FLQC,    & ! gopal's doing for Ocean coupling
                      QGH,QSFC,U10,V10,                          &
-                     ICOEF_SF, LCURR_SF,                        & 
+                     ICOEF_SF,IWAVECPL,LCURR_SF,CHARN,MSANG,SCURX, SCURY,&
                      pert_Cd, ens_random_seed, ens_Cdamp,       &
-                     GZ1OZ0,WSPD,BR,ISFFLX,                     &
+                     GZ1OZ0,WSPD,BR,ZKMAX, ISFFLX,              &
                      EP1,EP2,KARMAN,NTSFLG,SFENTH,              &
                      Cd_out,Ch_out,                             &
                      ids,ide, jds,jde, kds,kde,                 &
@@ -94,6 +94,7 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
                                         its,ite, jts,jte, kts,kte,      &
                                         ISFFLX,NUM_SOIL_LAYERS,NTSFLG
       INTEGER, INTENT(IN) ::            ICOEF_SF
+      INTEGER, INTENT(IN) ::            IWAVECPL
       LOGICAL, INTENT(IN) ::            LCURR_SF
       logical,intent(in)  :: pert_Cd 
       integer,intent(in)  :: ens_random_seed
@@ -124,9 +125,15 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
                                         GLW,                            &
                                         GSW,                            &
                                         XLAND                           
+      REAL,    DIMENSION(ims:ime, jms:jme), INTENT(IN) ::               &
+                                        CHARN,                          &
+                                        MSANG,                          &
+                                        SCURX,                          &
+                                        SCURY
       REAL,    DIMENSION(ims:ime, jms:jme), INTENT(INOUT) ::            & 
                                         TSK,                            &
                                         BR,                             &
+                                        ZKMAX,                          &
                                         CHS,                            &
                                         Cd_out,                         &
                                         Ch_out,                         &
@@ -220,10 +227,11 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
                                         tstrc,                          &
                                         zoc,                            &
                                         mzoc,                           &  !ADDED BY KWON FOR momentum Zo
+                                        tzot,                           &  !Wang
                                         wetc,                           &
                                         slwdc,                          &
                                         rib,                            &
-                                        zkmax,                          &
+!!!                                        zkmax,                          &
                                         tkmax,                          &
                                         fxmx,                           &
                                         fxmy,                           &
@@ -233,7 +241,11 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
                                         xxfh,                           &
                                         xxfh2,                          &
                                         wind10,                         &
-                                        tjloc
+                                        tjloc,                          &
+                                        alpha,                          &
+                                        gamma,                          &
+                                        xcur,                           &
+                                        ycur
 
       INTEGER ::                                                        &
                                         I,                              &
@@ -244,6 +256,7 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
                                         K,                              &
                                         KM
 
+      real :: tmp9,zhalf  ! wang, height of the first half level
 
         DATA MAXSMC/0.339, 0.421, 0.434, 0.476, 0.476, 0.439,  &
                     0.404, 0.464, 0.465, 0.406, 0.468, 0.468,  &
@@ -269,7 +282,7 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
    KM=KTE-KTS+1
 
    WRITE(message,*)'WITHIN THE GFDL SCHEME, NTSFLG=1 FOR GFDL SLAB  2010 UPGRADS',NTSFLG
-   call wrf_debug(1,message)
+   call wrf_debug(2,message)
 
 !!     write(0,*)'icoef_sf,lcurr_sf=',icoef_sf,lcurr_sf
 
@@ -308,6 +321,7 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
         vpc(kts,i)=v3D(i,kts,j) * 100.
         Z0RL(I) = ZNT(i,j)*100.
         zoc(i)=ZNT(i,j)*100.
+        cdm(i) = Cd_out(i,j)
          if(XLAND(i,j).gt.1.99)  zoc(i)=- zoc(i)
 !        Z0RL(I) = z00(i,j)*100.
 !       slwdc... GFDL downward net flux in units of cal/(cm**2/min)
@@ -315,7 +329,31 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
         slwdc(i)=gsw(i,j)+glw(i,j)
         slwdc(i)=0.239*60.*slwdc(i)*1.e-4
          tjloc(i)=float(j)
-        
+        alpha(i) = charn(i,j)
+        gamma(i) = msang(i,j)
+        xcur(i) = scurx(i,j)
+        ycur(i) = scury(i,j)
+
+
+ !Wang, calulate height of the first half level
+ !      use previous u10 v10 to compute wind10, input to MFLUX to compute z0
+          wind10(i)=sqrt(u10(i,j)*u10(i,j)+v10(i,j)*v10(i,j))
+        !first time step, u10 and v10 may be zero
+           zhalf=0.0
+          if (wind10(i) <= 1.0e-10 .or. wind10(i) > 150.0) then
+!           write(0,*)'maybe first timestep'
+           zhalf = -R*tpc(kts,i)*alog(pkmax(i)/pspc(i))/grav
+           wind10(i)=sqrt(u1(i)*u1(i)+v1(i)*v1(i))*alog(10.0/znt(i,j))/alog(zhalf/znt(i,j))
+          endif
+           wind10(i)=wind10(i)*100.0   !! m/s to cm/s
+           zhalf = -R*tpc(kts,i)*alog(pkmax(i)/pspc(i))/grav
+!         if (i == (its+ite)/2 .and. j == (jts+jte)/2 ) then
+!         write(0,*)'before call mflux,zh,w10,u10,v10,WIND1,znt'
+!         write(0,*)zhalf,wind10(i),u10(i,j),v10(i,j),sqrt(u1(i)**2+v1(i)**2),znt(i,j)
+!         write(0,*)'uselog', sqrt(u1(i)*u1(i)+v1(i)*v1(i))*alog(10.0/znt(i,j))/alog(zhalf/znt(i,j))
+!         endif
+        !
+
       ENDDO
 
       DO i=its,ite
@@ -339,13 +377,14 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
 
      CALL MFLUX2(  fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,   &    !mzoc for momentum Zo KWON
                    pspc,pkmax,wetc,slwdc,tjloc,                &
-                   icoef_sf,lcurr_sf,                          &
+                   icoef_sf,iwavecpl,lcurr_sf,alpha,gamma,xcur,ycur,           &
                    pert_Cd, ens_random_seed, ens_Cdamp,        &
                    upc,vpc,tpc,rpc,dt,J,wind10,xxfh2,ntsflg,SFENTH,   &
+                   tzot,   &  ! tzot , zot for thermal z0 Wang
                    ids,ide, jds,jde, kds,kde,                  &
                    ims,ime, jms,jme, kms,kme,                  &
                    its,ite, jts,jte, kts,kte                   )
-
+!!!        if(j == (jts+jte)/2)   write(0,*)'after call mflux,w10',wind10( (its+ite)/2  )
 !     if(j==2)then
 !       write(0,*)'--------------------------------------------'
 !       write(0,*) 'fxh, fxe, fxmx, fxmy, cdm, xxfh zoc,tstrc'
@@ -407,10 +446,10 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
 !       br     =0.0001*zfull(i,kmax)*dthv/
 !    &          (gmks*theta(i,kmax)*wspd     *wspd     )
 !       zkmax    = rgas*tpc(kmax,i)*qqlog(kmax)*og
-        zkmax(i) = -R*tpc(kts,i)*alog(pkmax(i)/pspc(i))/grav
+        zkmax(i,j) = -R*tpc(kts,i)*alog(pkmax(i)/pspc(i))/grav
 !------------------------------------------------------------------------
 
-        gz1oz0(i,j)=alog(zkmax(i)/znt(i,j))
+        gz1oz0(i,j)=alog(zkmax(i,j)/znt(i,j))
         ustar   (i)= 0.01*sqrt(cdm(i)*   &
                    (upc(kts,i)*upc(kts,i) + vpc(kts,i)*vpc(kts,i)))
 !       convert from g/(cm*cm*sec) to kg/(m*m*sec)
@@ -430,6 +469,20 @@ SUBROUTINE SF_GFDL(U3D,V3D,T3D,QV3D,P3D,                     &
         cm(i)      = cdm(i)
         Cd_out(i,j) = cm(i)
         Ch_out(i,j) = ch(i)
+
+!!! convert cd, ch to values at 10m, for output
+         if ( wind10(i) .ge. 0.1 ) then
+           cd_out(i,j)=cm(i)* (wspd(i,j)/(0.01*wind10(i)) )**2
+           tmp9=0.01*abs(tzot(i))
+           ch_out(i,j)=ch(i)*(wspd(i,j)/(0.01*wind10(i)) ) * &
+                     (alog(zkmax(i,j)/tmp9)/alog(10.0/tmp9))
+!           if(j == (jts+jte)/2 .and. i == (its+ite)/2 ) then
+!            write(0,*)'cm,cd10=',cm(i),cd_out(i,j)
+!            write(0,*)'ch,ch10=',ch(i),ch_out(i,j)
+!            write(0,*)'w/w10,zkmax(i),tzot=',wspd(i,j)/(0.01*wind10(i)),zkmax(i,j),tmp9
+!           endif
+         endif
+!!!
         U10(i,j)=U10M(i)
         V10(i,j)=V10M(i)
         BR(i,j)=rib(i)
@@ -547,9 +600,10 @@ END SUBROUTINE SF_GFDL
 !-------------------------------------------------------------------
        SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mzoc KWON
                           pspc,pkmax,wetc,slwdc,tjloc,                    &
-                          icoef_sf,lcurr_sf,                              &
+                          icoef_sf,iwavecpl,lcurr_sf,alpha,gamma,xcur,ycur,                &
                           pert_Cd, ens_random_seed, ens_Cdamp,            &
                           upc,vpc,tpc,rpc,dt,jfix,wind10,xxfh2,ntsflg,sfenth,    &
+                           tzot, &
                           ids,ide, jds,jde, kds,kde,                      &
                           ims,ime, jms,jme, kms,kme,                      &
                           its,ite, jts,jte, kts,kte                       )
@@ -595,6 +649,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
       integer,intent(in)  :: its,ite, jts,jte, kts,kte
       integer,intent(in)  :: jfix,ntsflg
       integer,intent(in)  :: icoef_sf
+      integer,intent(in)  :: iwavecpl
       logical,intent(in)  :: lcurr_sf
       logical,intent(in)  :: pert_Cd 
       integer,intent(in)  :: ens_random_seed
@@ -604,7 +659,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
       real, intent (out), dimension (ims :ime ) :: fxe
       real, intent (out), dimension (ims :ime ) :: fxmx
       real, intent (out), dimension (ims :ime ) :: fxmy
-      real, intent (out), dimension (ims :ime ) :: cdm
+      real, intent (inout), dimension (ims :ime ) :: cdm
 !      real, intent (out), dimension (ims :ime ) :: cdm2
       real, intent (out), dimension (ims :ime ) :: rib
       real, intent (out), dimension (ims :ime ) :: xxfh
@@ -612,6 +667,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
       real, intent (out), dimension (ims :ime ) :: wind10
 
       real, intent ( inout), dimension (ims :ime ) :: zoc,mzoc    !KWON
+      real, intent ( inout), dimension (ims :ime ) :: tzot        !WANG
       real, intent ( inout), dimension (ims :ime ) :: tstrc
 
       real, intent ( in)                        :: dt
@@ -621,6 +677,8 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
       real, intent ( in), dimension (ims :ime ) :: wetc
       real, intent ( in), dimension (ims :ime ) :: slwdc
       real, intent ( in), dimension (ims :ime ) :: tjloc
+      real, intent ( in), dimension (ims :ime ) :: alpha, gamma
+      real, intent ( in), dimension (ims :ime ) :: xcur, ycur
 
       real, intent ( in), dimension (kms:kme, ims :ime ) :: upc
       real, intent ( in), dimension (kms:kme, ims :ime ) :: vpc
@@ -696,6 +754,8 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
       real, dimension(1   :ime) :: vrts
       real, dimension(1   :ime) :: wind
       real, dimension(1   :ime) :: windp
+      real, dimension(1   :ime) :: wind10p  !WANG, 10m wind previous step
+      real, dimension(1   :ime) :: uvs1
 !     real, dimension(1   :ime) :: xxfh
       real, dimension(1   :ime) :: xxfm
       real, dimension(1   :ime) :: xxsh
@@ -724,6 +784,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
       real :: cor1,cor2,szetho,zal2gh,cons_p000001,cons_7,vis,ustar,restar,rat
       real :: wndm,ckg
       real :: windmks,znott,znotm
+      real :: ubot, vbot
       integer:: i,j,ii,iq,nnest,icnt,ngd,ip
 
 !-----------------------------------------------------------------------
@@ -740,6 +801,8 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
       real, dimension (74) :: table1
       real, dimension (80) :: tab22
 
+      character(len=255) :: message
+
       equivalence (tab(1),tab11(1))
       equivalence (tab(102),tab22(1))
       equivalence (tab(182),tab3(1))
@@ -828,7 +891,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
       real,parameter :: g     = 980.6
       real,parameter :: rgas  = 2.87e6
       real,parameter :: og    = 1./g
-      character*255 :: message
+      integer :: ntstep = 0
 !
 #if HWRF==1
       real*8 :: gasdev,ran1          !zhang
@@ -861,8 +924,8 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
        cor2 = 720.
 ! KWON : remove the artificial increase of 10m wind speed over 60kts
 !        which comes from GFDL hurricane model
-!        cor1 = 0.
-!        cor2 = 0.
+        cor1 = 0.
+        cor2 = 0.
 !
 
       do i = its,ite
@@ -870,8 +933,33 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
         z2 (i) =  200.
         pss(i) = pspc(i)
         tstar(i) = tstrc(i)
-        ukmax(i) = upc(1,i)
-        vkmax(i) = vpc(1,i)
+
+        if ( lcurr_sf .and. zoc(i) .le. 0.0 ) then
+          ubot = upc(1,i)  - xcur(i) * 100.0
+          vbot = vpc(1,i)  - ycur(i) * 100.0
+!          ubot = upc(1,i)
+!          vbot = vpc(1,i)
+        else
+          ubot = upc(1,i)
+          vbot = vpc(1,i)
+        endif
+        uvs1(i)= amax1( SQRT(ubot*ubot +    &
+                             vbot*vbot), 100.0)
+        if ( iwavecpl .eq. 1 .and. zoc(i) .le. 0.0 ) then
+          ukmax(i) = ( ubot * cos(gamma(i))  -          &
+                      vbot * sin(gamma(i)) )            &
+                                  * cos(gamma(i))
+          vkmax(i) = ( vbot * cos(gamma(i))  -          &
+                      ubot * sin(gamma(i)) )            &
+                                  * cos(gamma(i))
+
+        else
+          ukmax(i) = ubot
+          vkmax(i) = vbot
+        endif
+
+!       ukmax(i) = upc(1,i)
+!        vkmax(i) = vpc(1,i)
         tkmax(i) = tpc(1,i)
         rkmax(i) = rpc(1,i)
       enddo
@@ -883,7 +971,14 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
       do i = its,ite
         windp(i) = SQRT(ukmax(i)*ukmax(i) + vkmax(i)*vkmax(i))
         wind (i) = amax1(windp(i),100.)
-        if (zoc(i) .LT. amask) zoc(i) = -0.0185*0.001*wind(i)*wind(i)*og
+
+!! use wind10 previous step
+         wind10p(i) = wind10(i)  !! cm/s
+        wind10p(i) = amax1(wind10p(i),100.)
+!!
+
+!        if (zoc(i) .LT. amask) zoc(i) = -0.0185*0.001*wind(i)*wind(i)*og
+        if (zoc(i) .LT. amask) zoc(i) = -0.0185*0.001*wind10p(i)*wind10p(i)*og
         if (zoc(i) .GT. 0.0) then
           ecof(i) = wetc(i)
           land(i) = 1.0
@@ -891,28 +986,45 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
         else
           ecof(i) = wetc(i)
           land(i) = 0.0
-          windmks=wind(i)*.01
-          if ( icoef_sf .EQ. 1) then
-             call  znot_m_v1(windmks,znotm)
-             call  znot_t_v1(windmks,znott)
-          else if ( icoef_sf .EQ. 0 ) then
-             call  znot_m_v0(windmks,znotm)
-             call  znot_t_v0(windmks,znott)
+          !windmks=wind(i)*.01
+          windmks=wind10p(i)*.01
+          if ( iwavecpl .eq. 1 ) then
+            if (  ntstep == 0 ) then
+              call  znot_m_v1(windmks,znotm)
+              zoc(i)  = -100.*znotm
+            endif
+            call  znot_t_v2(windmks,znott)
+            zot(i) =  -100* znott
           else
-             call  znot_m_v1(windmks,znotm)
-             call  znot_t_v2(windmks,znott)
+!            if ( icoef_sf .EQ. 1) then
+!              call  znot_m_v1(windmks,znotm)
+!              call  znot_t_v1(windmks,znott)
+!            else if ( icoef_sf .EQ. 0 ) then
+!              call  znot_m_v0(windmks,znotm)
+!              call  znot_t_v0(windmks,znott)
+!            else
+!              call  znot_m_v1(windmks,znotm)
+!              call  znot_t_v2(windmks,znott)
+!            endif
+            call znot_wind10m(windmks,znott,znotm,icoef_sf)
+
+            zoc(i)  = -100.*znotm
+            zot(i) =  -100* znott
           endif
-          zoc(i)  = -100.*znotm
-          zot(i) =  -100* znott
         endif
 
+!          if(i == (its+ite)/2 .and. j == (jts+jte)/2) then
+!            write(0,*)'wind10p(i),windp(i),windmks,zoc(i),zot, land'
+!            write(0,*)wind10p(i),windp(i),windmks,zoc(i),zot(i),land(i)
+!          endif
+
 
 !------------------------------------------------------------------------
 !     where necessary modify zo values over ocean.
 !------------------------------------------------------------------------
 !
       mzoc(i) = zoc(i)                !FOR SAVE MOMENTUM Zo
-
+      tzot(i) = zot(i)                 !output wang
       enddo
 
 !------------------------------------------------------------------------
@@ -1153,6 +1265,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
       go to 130
 
 110   continue
+
       write(6,120)
 120   format(2X, ' NON-CONVERGENCE FOR STABLE ZETA IN ROW ')
 !     call MPI_CLOSE(1,routine)
@@ -1211,7 +1324,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
 
 !!!   if (ngd .EQ. nNEST) then
         do i = 1,ip
-         wind10(istb(i)) = sf10(i)*wind(istb(i))/sfm(i)
+         wind10(istb(i)) = sf10(i)*uvs1(istb(i))/sfm(i)
          wind10(istb(i)) = wind10(istb(i)) * 1.944
            if(wind10(istb(i)) .GT. 6000.0) then
        wind10(istb(i))=wind10(istb(i))+wind10(istb(i))*cor1 &
@@ -1335,8 +1448,9 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
             uq        = (ugz - ugzm(i))/(uzeta(i) - uzetam(i))
             uzetam(i) = uzeta(i)
             if(uq .EQ. 1) then
-             write(0,*)'NCO ERROR DIVIDE BY ZERO IN MFLUX2 (UNSTABLE CASE)' 
-             write(0,*)'uq is 1 ',ux2,ugz,ugzm(i),uzeta(i),uzetam(i) 
+             call wrf_message('NCO ERROR DIVIDE BY ZERO IN MFLUX2 (UNSTABLE CASE)')
+             write(message,*)'uq is 1 ',ux2,ugz,ugzm(i),uzeta(i),uzetam(i) 
+             call wrf_message(message)
             endif
             uzeta (i) = (ugz - uzeta(i)*uq)/(1.0 - uq)
             ugzm  (i) = ugz
@@ -1355,7 +1469,8 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
       go to 250
 
 230   continue
-      write(6,240)
+      write(message,240)
+      call wrf_message(message)
 240   format(2X, ' NON-CONVERGENCE FOR UNSTABLE ZETA IN ROW ')
 !     call MPI_CLOSE(1,routine)
 
@@ -1409,7 +1524,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
 
 !!!   if (ngd .EQ. nNEST) then
         do i = 1,iq
-          wind10(iutb(i)) = uf10(i)*wind(iutb(i))/ufm(i)
+          wind10(iutb(i)) = uf10(i)*uvs1(iutb(i))/ufm(i)
           wind10(iutb(i)) = wind10(iutb(i)) * 1.944
            if(wind10(iutb(i)) .GT. 6000.0) then
          wind10(iutb(i))=wind10(iutb(i))+wind10(iutb(i))*cor1 &
@@ -1575,12 +1690,14 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
 
       do i = 1,ip
         if (ifz(i) .EQ. 1) then
-        write(6, 340) tsp(i), i, j
+        write(message, 340) tsp(i), i, j
 340   format(2X, ' NON-CONVERGENCE OF T* PREDICTED (T*,I,J) = ', E14.8, &
             2I5)
+        call wrf_message(message)
 
-        write(6,345) indx(i), j, tstar(indx(i)), tsp(i), ip
+        write(message,345) indx(i), j, tstar(indx(i)), tsp(i), ip
 345   format(2X, ' I, J, OLD T*, NEW T*, NPTS ', 2I5, 2E14.8, I5)
+        call wrf_message(message)
 
 !       write(6,350) reflect, sigt4, shfx, alevp, delten, diffot
 350   format(2X, ' REFLECT, SIGT4, SHFX, ALEVP, DELTEN, DIFFOT ', &
@@ -1601,6 +1718,20 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
 
 370   continue
       do i = its,ite
+!!!
+        if ( iwavecpl .eq. 1 .and. zoc(i) .le. 0.0 ) then
+          windmks = wind(i) * 0.01
+          ustar = windmks / xxfm(i)
+          !Check if Charnock parameter ratio is received in a proper range.
+          if ( alpha(i) .ge. 0.2 .and. alpha(i) .le. 5. ) then
+            call  znot_m_v1(windmks,znotm)
+            znotm = znotm*alpha(i)
+          else
+            call  znot_m_v1(windmks,znotm)
+          endif
+          zoc(i)  = -100.*znotm
+        endif
+!!!!
         fxh(i) = bq1(i)*(theta(i) - tsg(i))
         fxe(i) = ecof(i)*bq1(i)*(rkmax(i) - rstso(i))
         if (fxe(i) .GT. 0.0) fxe(i) = 0.0
@@ -1620,7 +1751,7 @@ SUBROUTINE MFLUX2( fxh,fxe,fxmx,fxmy,cdm,rib,xxfh,zoc,mzoc,tstrc,       &    !mz
 #endif
 
       enddo
-
+      ntstep = ntstep + 1
       return
       end subroutine MFLUX2
 
diff --git a/wrfv2_fire/phys/module_sf_mynn.F b/wrfv2_fire/phys/module_sf_mynn.F
old mode 100644
new mode 100755
index 2fb643f4..91708f92
--- a/wrfv2_fire/phys/module_sf_mynn.F
+++ b/wrfv2_fire/phys/module_sf_mynn.F
@@ -5,7 +5,7 @@ MODULE module_sf_mynn
 
 !-------------------------------------------------------------------
 !Modifications implemented by Joseph Olson NOAA/GSD/AMB - CU/CIRES
-!for WRFv3.4, v3.4.1, v3.5.1, v3.6, and v3.7.1:
+!for WRFv3.4, v3.4.1, v3.5.1, v3.6, v3.7.1, and v3.9:
 !
 !   BOTH LAND AND WATER:
 !1) Calculation of stability parameter (z/L) taken from Li et al. (2010 BLM)
@@ -45,6 +45,9 @@ MODULE module_sf_mynn
 !   2) added a more elaborate diagnostic for u10 & V10 for high vertical resolution
 !      model configurations.
 !
+! New for v3.9:
+!   - option for stochastic parameter perturbations (SPP) 
+!
 !NOTE: This code was primarily tested in combination with the RUC LSM.
 !      Performance with the Noah (or other) LSM is relatively unknown.
 !-------------------------------------------------------------------
@@ -83,7 +86,8 @@ SUBROUTINE mynn_sf_init_driver(allowed_to_read)
   END SUBROUTINE mynn_sf_init_driver
 
 !-------------------------------------------------------------------
-   SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
+   SUBROUTINE SFCLAY_mynn(                                         &
+                     U3D,V3D,T3D,QV3D,P3D,dz8w,                    &
                      CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM,    &
                      ZNT,UST,PBLH,MAVAIL,ZOL,MOL,REGIME,PSIM,PSIH, &
                      XLAND,HFX,QFX,LH,TSK,FLHC,FLQC,QGH,QSFC,RMOL, &
@@ -93,9 +97,7 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
                      KARMAN,itimestep,ch,th3d,pi3d,qc3d,rho3d,     &
                      tsq,qsq,cov,sh3d,el_pbl,qcg,                  &
                      icloud_bl,qc_bl,cldfra_bl,                    &
-!JOE-add output
-!                     z0zt_ratio,BulkRi,wstar,qstar,resist,logres,  &
-!JOE-end 
+                     spp_pbl,pattern_spp_pbl,                      &
                      ids,ide, jds,jde, kds,kde,                    &
                      ims,ime, jms,jme, kms,kme,                    &
                      its,ite, jts,jte, kts,kte,                    &
@@ -218,6 +220,8 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
       INTEGER,  OPTIONAL,  INTENT(IN)   ::     ISFTCFLX, IZ0TLND,&
                                                 bl_mynn_cloudpdf,&
                                                 icloud_bl
+      INTEGER,  INTENT(IN),OPTIONAL    ::    spp_pbl
+
 !===================================
 ! 3D VARIABLES
 !===================================
@@ -232,6 +236,7 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
 
       REAL,     DIMENSION( ims:ime, kms:kme, jms:jme ) ::   qc_bl, &
                                                         cldfra_bl
+      REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN),OPTIONAL ::pattern_spp_pbl
 !===================================
 ! 2D VARIABLES
 !===================================
@@ -289,11 +294,13 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
                                                            dz8w1d, & !level 1 height
                                                            dz2w1d    !level 2 height
 
+      REAL,     DIMENSION( its:ite ) ::                  rstoch1D
+
       ! VARIABLE FOR PASSING TO MYM_CONDENSATION
       REAL,     DIMENSION(kts:kts+1 ) :: dummy1,dummy2,dummy3,dummy4, &
                                          dummy5,dummy6,dummy7,dummy8, &
                                          dummy9,dummy10,dummy11,      &
-                                         dummy12,dummy13
+                                         dummy12,dummy13,dummy14
 
       REAL,     DIMENSION( its:ite ) ::  vt1,vq1
       REAL,     DIMENSION(kts:kts+1) ::  thl, qw, vt, vq
@@ -320,6 +327,11 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
            P1D(i) =P3D(i,kts,j)
            T1D(i) =T3D(i,kts,j)
            RHO1D(i)=RHO3D(i,kts,j)
+           if (spp_pbl==1) then
+               rstoch1D(i)=pattern_spp_pbl(i,kts,j)
+           else
+               rstoch1D(i)=0.0
+           endif
         ENDDO
 
         IF (itimestep==1) THEN
@@ -347,6 +359,7 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
                 dummy8(k)=cov(i,k,j)
                 dummy9(k)=Sh3d(i,k,j)
                 dummy10(k)=el_pbl(i,k,j)
+                dummy14(k)=th3d(i,k,j)
                 if(icloud_bl > 0) then
                   dummy11(k)=qc_bl(i,k,j)
                   dummy12(k)=cldfra_bl(i,k,j)
@@ -354,7 +367,7 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
                   dummy11(k)=0.0
                   dummy12(k)=0.0
                 endif
-                dummy13(k)=0.0
+                dummy13(k)=0.0     !sgm
               ENDDO
 
               ! NOTE: The last grid number is kts+1 instead of kte.
@@ -365,8 +378,8 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
                    &            dummy10,bl_mynn_cloudpdf,&
                    &            dummy11,dummy12,        &
                    &            PBLH(i,j),HFX(i,j),     &
-                   &            dummy13,                &
-                   &            vt(kts:kts+1), vq(kts:kts+1))
+                   &            vt(kts:kts+1), vq(kts:kts+1), &
+                   &            dummy14,dummy13)
 
 !              ! NOTE: The last grid number is kts+1 instead of kte.
 !              CALL mym_condensation (kts,kts+1, dx,     &
@@ -384,13 +397,15 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
 !                   &            qc_bl2D(i,kts:kts+1),   & !JOE-subgrid BL clouds
 !                   &           cldfra_bl2D(i,kts:kts+1),& !JOE-subgrid BL clouds
 !                   &            PBLH(i,j),HFX(i,j),     & !JOE-subgrid BL clouds
-!                   &            vt(kts:kts+1), vq(kts:kts+1))
+!                   &            vt(kts:kts+1), vq(kts:kts+1), &
+ !                  &            th,sgm)
               vt1(i) = vt(kts)
               vq1(i) = vq(kts)
            ENDDO
         ENDIF
 
-        CALL SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,    &
+        CALL SFCLAY1D_mynn(                                        &
+                J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,               &
                 U1D2,V1D2,dz2w1d,                                  &
                 CP,G,ROVCP,R,XLV,PSFCPA(ims,j),CHS(ims,j),CHS2(ims,j),&
                 CQS2(ims,j),CPM(ims,j),PBLH(ims,j), RMOL(ims,j),   &
@@ -408,6 +423,7 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
                 z0zt_ratio(ims,j),wstar(ims,j),                    &
                 qstar(ims,j),resist(ims,j),logres(ims,j),          &
 !JOE-end
+                spp_pbl,rstoch1D,                                  &
                 ids,ide, jds,jde, kds,kde,                         &
                 ims,ime, jms,jme, kms,kme,                         &
                 its,ite, jts,jte, kts,kte                          &
@@ -421,7 +437,8 @@ SUBROUTINE SFCLAY_mynn(U3D,V3D,T3D,QV3D,P3D,dz8w,               &
     END SUBROUTINE SFCLAY_MYNN
 
 !-------------------------------------------------------------------
-   SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
+   SUBROUTINE SFCLAY1D_mynn(                                       &
+                     J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,          &
                      U1D2,V1D2,dz2w1d,                             &
                      CP,G,ROVCP,R,XLV,PSFCPA,CHS,CHS2,CQS2,CPM,    &
                      PBLH,RMOL,ZNT,UST,MAVAIL,ZOL,MOL,REGIME,      &
@@ -434,6 +451,7 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
 !JOE-additional output
                      zratio,wstar,qstar,resist,logres,             &
 !JOE-end
+                     spp_pbl,rstoch1D,                             &
                      ids,ide, jds,jde, kds,kde,                    &
                      ims,ime, jms,jme, kms,kme,                    &
                      its,ite, jts,jte, kts,kte                     &
@@ -461,6 +479,7 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
 !-----------------------------
       INTEGER,  INTENT(IN) :: ISFFLX
       INTEGER,  OPTIONAL,  INTENT(IN )   ::     ISFTCFLX, IZ0TLND
+      INTEGER,    INTENT(IN)             ::     spp_pbl
 
 !-----------------------------
 ! 1D ARRAYS
@@ -496,6 +515,7 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
                                                              WSPD, &
                                                                BR, &
                                                         PSIM,PSIH
+      REAL,     DIMENSION( its:ite ), INTENT(IN)   ::     rstoch1D
 
       ! DIAGNOSTIC OUTPUT
       REAL,     DIMENSION( ims:ime ), INTENT(OUT)   ::    U10,V10, &
@@ -525,6 +545,7 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
       PSIH10,PSIM10, &    !M-O stability functions at z=10 m
               WSPDI, & 
             z_t,z_q, &    !thermal & moisture roughness lengths
+           ZNTstoch, &
              GOVRTH, &    !g/theta
                THGB, &    !theta at ground
               THVGB, &    !theta-v at ground
@@ -536,7 +557,7 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
             GZ10OZt, &    !LOG((10.+z_t(i))/z_t(i))
              GZ1OZt       !LOG((ZA(I)+z_t(i))/z_t(i))
 
-      INTEGER ::  N,I,K,L,NZOL,NK,NZOL2,NZOL10, ITER
+      INTEGER ::  N,I,K,L,NZOL,NK,NZOL2,NZOL10, ITER, yesno
       INTEGER, PARAMETER :: ITMAX=1
 
       REAL    ::  PL,THCON,TVCON,E1
@@ -743,11 +764,18 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
              ENDIF
           ENDIF
 
+          ! add stochastic perturbaction of ZNT
+          if (spp_pbl==1) then
+             ZNTstoch(I)  = MAX(ZNT(I) + 1.5 * ZNT(I) * rstoch1D(i), 1e-6)
+          else
+             ZNTstoch(I)  = ZNT(I)
+          endif
+
           !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING NEW ZNT
           ! AHW: Garrattt formula: Calculate roughness Reynolds number
           !      Kinematic viscosity of air (linear approx to
           !      temp dependence at sea level)
-          restar=MAX(ust(i)*ZNT(i)/visc, 0.1)
+          restar=MAX(ust(i)*ZNTstoch(i)/visc, 0.1)
 
           !--------------------------------------
           !CALCULATE z_t and z_q
@@ -758,82 +786,89 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
                    CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc)
                 ELSE
                    !presumably, this will be published soon, but hasn't yet
-                   CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc)
+                   CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl)
                 ENDIF
              ELSEIF ( ISFTCFLX .EQ. 1 ) THEN
                 IF (COARE_OPT .EQ. 3.0) THEN
                    CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc)
                 ELSE
-                   CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc)
+                   CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl)
                 ENDIF
              ELSEIF ( ISFTCFLX .EQ. 2 ) THEN
-                CALL garratt_1992(z_t(i),z_q(i),ZNT(i),restar,XLAND(I))
+                CALL garratt_1992(z_t(i),z_q(i),ZNTstoch(i),restar,XLAND(I))
              ELSEIF ( ISFTCFLX .EQ. 3 ) THEN
                 IF (COARE_OPT .EQ. 3.0) THEN
                    CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc)
                 ELSE
-                   CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc)
+                   CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl)
                 ENDIF
              ELSEIF ( ISFTCFLX .EQ. 4 ) THEN
-                CALL zilitinkevich_1995(ZNT(i),z_t(i),z_q(i),restar,&
-                                   UST(I),KARMAN,XLAND(I),IZ0TLND)
+                CALL zilitinkevich_1995(ZNTstoch(i),z_t(i),z_q(i),restar,&
+                                   UST(I),KARMAN,XLAND(I),IZ0TLND,spp_pbl,rstoch1D(i))
              ENDIF
           ELSE
              !DEFAULT TO COARE 3.0/3.5
              IF (COARE_OPT .EQ. 3.0) THEN
                 CALL fairall_etal_2003(z_t(i),z_q(i),restar,UST(i),visc)
              ELSE
-                CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc)
+                CALL fairall_etal_2014(z_t(i),z_q(i),restar,UST(i),visc,rstoch1D(i),spp_pbl)
              ENDIF
           ENDIF
  
        ELSE
 
+          ! add stochastic perturbaction of ZNT
+          if (spp_pbl==1) then
+             ZNTstoch(I)  = MAX(ZNT(I) + 1.5 * ZNT(I) * rstoch1D(i), 1e-6)
+          else
+             ZNTstoch(I)  = ZNT(I)
+          endif
+
           !--------------------------------------
           ! LAND
           !--------------------------------------
           !COMPUTE ROUGHNESS REYNOLDS NUMBER (restar) USING DEFAULT ZNT
-          restar=MAX(ust(i)*ZNT(i)/visc, 0.1)
+          restar=MAX(ust(i)*ZNTstoch(i)/visc, 0.1)
 
           !--------------------------------------
           !GET z_t and z_q
           !--------------------------------------
           !CHECK FOR SNOW/ICE POINTS OVER LAND
-          !IF ( ZNT(i) .LE. SNOWZ0  .AND.  TSK(I) .LE. 273.15 ) THEN
+          !IF ( ZNTSTOCH(i) .LE. SNOWZ0  .AND.  TSK(I) .LE. 273.15 ) THEN
           IF ( SNOWH(i) .GE. 0.1) THEN
-             CALL Andreas_2002(ZNT(i),visc,ust(i),z_t(i),z_q(i))
+             CALL Andreas_2002(ZNTSTOCH(i),visc,ust(i),z_t(i),z_q(i))
           ELSE
              IF ( PRESENT(IZ0TLND) ) THEN
                 IF ( IZ0TLND .LE. 1 .OR. IZ0TLND .EQ. 4) THEN
                    !IF IZ0TLND==4, THEN PSIQ WILL BE RECALCULATED USING
                    !PAN ET AL (1994), but PSIT FROM ZILI WILL BE USED.
-                   CALL zilitinkevich_1995(ZNT(i),z_t(i),z_q(i),restar,&
-                                  UST(I),KARMAN,XLAND(I),IZ0TLND)
+                   CALL zilitinkevich_1995(ZNTSTOCH(i),z_t(i),z_q(i),restar,&
+                                  UST(I),KARMAN,XLAND(I),IZ0TLND,spp_pbl,rstoch1D(i))
                 ELSEIF ( IZ0TLND .EQ. 2 ) THEN
-                   CALL Yang_2008(ZNT(i),z_t(i),z_q(i),UST(i),MOL(I),&
+                   CALL Yang_2008(ZNTSTOCH(i),z_t(i),z_q(i),UST(i),MOL(I),&
                                   qstar(I),restar,visc,XLAND(I))
                 ELSEIF ( IZ0TLND .EQ. 3 ) THEN
                    !Original MYNN in WRF-ARW used this form:
-                   CALL garratt_1992(z_t(i),z_q(i),ZNT(i),restar,XLAND(I))
+                   CALL garratt_1992(z_t(i),z_q(i),ZNTSTOCH(i),restar,XLAND(I))
                 ENDIF
              ELSE
                 !DEFAULT TO ZILITINKEVICH
-                CALL zilitinkevich_1995(ZNT(i),z_t(i),z_q(i),restar,&
-                                        UST(I),KARMAN,XLAND(I),0)
+                CALL zilitinkevich_1995(ZNTSTOCH(i),z_t(i),z_q(i),restar,&
+                                        UST(I),KARMAN,XLAND(I),0,spp_pbl,rstoch1D(i))
              ENDIF
           ENDIF
 
        ENDIF
-       zratio(i)=znt(i)/z_t(i)
+       zratio(i)=zntstoch(i)/z_t(i)
 
        !ADD RESISTANCE (SOMEWHAT FOLLOWING JIMENEZ ET AL. (2012)) TO PROTECT AGAINST
        !EXCESSIVE FLUXES WHEN USING A LOW FIRST MODEL LEVEL (ZA < 10 m).        
-       !Formerly: GZ1OZ0(I)= LOG(ZA(I)/ZNT(I))
-       GZ1OZ0(I)= LOG((ZA(I)+ZNT(I))/ZNT(I))
+       !Formerly: GZ1OZ0(I)= LOG(ZA(I)/ZNTstoch(I))
+       GZ1OZ0(I)= LOG((ZA(I)+ZNTstoch(I))/ZNTstoch(I))
        GZ1OZt(I)= LOG((ZA(I)+z_t(i))/z_t(i))           
-       GZ2OZ0(I)= LOG((2.0+ZNT(I))/ZNT(I))                                        
+       GZ2OZ0(I)= LOG((2.0+ZNTstoch(I))/ZNTstoch(I))                                        
        GZ2OZt(I)= LOG((2.0+z_t(i))/z_t(i))                                        
-       GZ10OZ0(I)=LOG((10.+ZNT(I))/ZNT(I)) 
+       GZ10OZ0(I)=LOG((10.+ZNTstoch(I))/ZNTstoch(I)) 
        GZ10OZt(I)=LOG((10.+z_t(i))/z_t(i)) 
 
      !--------------------------------------------------------------------      
@@ -867,9 +902,9 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
         ENDIF
 
         !COMPUTE z/L
-        !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I))
+        !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I))
 !        IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN
-           CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I))
+           CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I))
 !        ELSE
 !           ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I),0.001)**2)
 !           ZOL(I)=MAX(ZOL(I),0.0)
@@ -882,13 +917,13 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
            !CALL PSI_Suselj_Sood_2010(PSIM(I),PSIH(I),ZOL(I))
            !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I))
            !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I))
-           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I))
+           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I))
         ELSE
            ! LAND  
            !CALL PSI_Beljaars_Holtslag_1991(PSIM(I),PSIH(I),ZOL(I))
            !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I))
            !CALL PSI_Zilitinkevich_Esau_2007(PSIM(I),PSIH(I),ZOL(I))
-           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I))
+           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I))
         ENDIF              
 
         ! LOWER LIMIT ON PSI IN STABLE CONDITIONS
@@ -929,9 +964,9 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
         REGIME(I)=4.
 
         !COMPUTE z/L
-        !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I))
+        !CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I))
         IF (ITER .EQ. 1 .AND. itimestep .LE. 1) THEN
-           CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNT(I),zratio(I))
+           CALL Li_etal_2010(ZOL(I),BR(I),ZA(I)/ZNTstoch(I),zratio(I))
         ELSE
            ZOL(I)=ZA(I)*KARMAN*G*MOL(I)/(TH1D(I)*MAX(UST(I),0.001)**2)
            ZOL(I)=MAX(ZOL(I),-9.999)
@@ -957,14 +992,14 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
         IF((XLAND(I)-1.5).GE.0)THEN                                            
            ! WATER
            !CALL PSI_Suselj_Sood_2010(PSIM(I),PSIH(I),ZOL(I))
-           !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I))
+           !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNTstoch(I), ZA(I))
            !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I))
-           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I))
+           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I))
         ELSE           
            ! LAND  
-           !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNT(I), ZA(I))
+           !CALL PSI_Hogstrom_1996(PSIM(I),PSIH(I),ZOL(I), z_t(I), ZNTstoch(I), ZA(I))
            !CALL PSI_Businger_1971(PSIM(I),PSIH(I),ZOL(I))
-           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNT(I),ZA(I))
+           CALL PSI_DyerHicks(PSIM(I),PSIH(I),ZOL(I),z_t(I),ZNTstoch(I),ZA(I))
         ENDIF              
 
 !!!!!JOE-test:avoid using psi tables in entirety
@@ -997,8 +1032,8 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
      !-----COMPUTE THE FRICTIONAL VELOCITY:                                           
      !------------------------------------------------------------
      !     ZA(1982) EQS(2.60),(2.61).                                                 
-      GZ1OZ0(I) =LOG((ZA(I)+ZNT(I))/ZNT(I))
-      GZ10OZ0(I)=LOG((10.+ZNT(I))/ZNT(I)) 
+      GZ1OZ0(I) =LOG((ZA(I)+ZNTstoch(I))/ZNTstoch(I))
+      GZ10OZ0(I)=LOG((10.+ZNTstoch(I))/ZNTstoch(I)) 
       PSIX=GZ1OZ0(I)-PSIM(I)
       PSIX10=GZ10OZ0(I)-PSIM10(I)
       ! TO PREVENT OSCILLATIONS AVERAGE WITH OLD VALUE 
@@ -1069,8 +1104,8 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
             U10(I)=U1D2(I)
             V10(I)=V1D2(I)
          else
-            U10(I)=U1D(I)*log(10./ZNT(I))/log(ZA(I)/ZNT(I))
-            V10(I)=V1D(I)*log(10./ZNT(I))/log(ZA(I)/ZNT(I))
+            U10(I)=U1D(I)*log(10./ZNTstoch(I))/log(ZA(I)/ZNTstoch(I))
+            V10(I)=V1D(I)*log(10./ZNTstoch(I))/log(ZA(I)/ZNTstoch(I))
          endif
       elseif(ZA(i) .gt. 7.0 .and. ZA(i) .lt. 13.0) then
          !moderate vertical resolution
@@ -1115,9 +1150,9 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
          !  write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I)," Tstar:",MOL(I)
          !  write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I)," DTHV:",THV1D(I)-THVGB(I)
          !  write(*,1003)"CPM:",CPM(I)," RHO1D:",RHO1D(I)," L:",ZOL(I)/ZA(I)," DTH:",TH1D(I)-THGB(I)
-         !  write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNT(I)," Zt:",z_t(I)," za:",za(I)
+         !  write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNTstoch(I)," Zt:",z_t(I)," za:",za(I)
          !  write(*,1005)"Re:",restar," MAVAIL:",MAVAIL(I)," QSFC(I):",QSFC(I)," QVSH(I):",QVSH(I)
-         !  print*,"VISC=",VISC," Z0:",ZNT(I)," T1D(i):",T1D(i)
+         !  print*,"VISC=",VISC," Z0:",ZNTstoch(I)," T1D(i):",T1D(i)
          !  write(*,*)"============================================="
          !ENDIF
       ENDIF
@@ -1242,30 +1277,58 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
    ENDIF !end ISFFLX option
 
    IF ( wrf_at_debug_level(3000) ) THEN
-   IF (HFX(I) > 1200. .OR. HFX(I) < -500. .OR. &
-      &LH(I)  > 1200. .OR. LH(I)  < -500. .OR. &
-      &UST(I) < 0.0 .OR. UST(I) > 4.0 .OR. &
-      &WSTAR(I)<0.0 .OR. WSTAR(I) > 6.0 .OR. &
-      &RHO1D(I)<0.0 .OR. RHO1D(I) > 1.6 .OR. &
-      &QSFC(I)*1000. <0.0 .OR. QSFC(I)*1000. >38. .OR. &
-      &PBLH(I)>6000.) THEN
-      print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",&
-            ITER-ITMAX," ITERATIONS",I,J
-      write(*,1000)"HFX: ",HFX(I)," LH:",LH(I)," CH:",CH(I),&
-            " PBLH:",PBLH(I)
-      write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I),&
-            " Tstar:",MOL(I)
-      write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I),&
-            " DTHV:",THV1D(I)-THVGB(I)
-      write(*,1003)"CPM:",CPM(I)," RHO1D:",RHO1D(I)," L:",&
-            ZOL(I)/ZA(I)," DTH:",TH1D(I)-THGB(I)
-      write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNT(I)," Zt:",z_t(I),&
-            " za:",za(I)
-      write(*,1005)"Re:",restar," MAVAIL:",MAVAIL(I)," QSFC(I):",&
-            QSFC(I)," QVSH(I):",QVSH(I)
-      print*,"PSIX=",PSIX," Z0:",ZNT(I)," T1D(i):",T1D(i)
-      write(*,*)"============================================="
-   ENDIF
+      yesno = 0
+      IF (HFX(I) > 1200. .OR. HFX(I) < -500.)THEN
+            print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",&
+            ITER-ITMAX," ITERATIONS",I,J, "HFX: ",HFX(I)
+            yesno = 1
+      ENDIF
+      IF (LH(I)  > 1200. .OR. LH(I)  < -500.)THEN
+            print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",&
+            ITER-ITMAX," ITERATIONS",I,J, "LH: ",LH(I)
+            yesno = 1
+      ENDIF
+      IF (UST(I) < 0.0 .OR. UST(I) > 4.0 )THEN
+            print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",&                                                                     
+            ITER-ITMAX," ITERATIONS",I,J, "UST: ",UST(I)
+            yesno = 1
+      ENDIF
+      IF (WSTAR(I)<0.0 .OR. WSTAR(I) > 6.0)THEN
+            print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",&
+            ITER-ITMAX," ITERATIONS",I,J, "WSTAR: ",WSTAR(I)
+            yesno = 1
+      ENDIF
+      IF (RHO1D(I)<0.0 .OR. RHO1D(I) > 1.6 )THEN
+            print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",&
+            ITER-ITMAX," ITERATIONS",I,J, "rho: ",RHO1D(I)
+            yesno = 1
+      ENDIF
+      IF (QSFC(I)*1000. <0.0 .OR. QSFC(I)*1000. >40.)THEN
+            print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",&
+            ITER-ITMAX," ITERATIONS",I,J, "QSFC: ",QSFC(I)
+            yesno = 1
+      ENDIF
+      IF (PBLH(I)<0. .OR. PBLH(I)>6000.)THEN
+            print*,"SUSPICIOUS VALUES IN MYNN SFCLAYER",&                                                              
+            ITER-ITMAX," ITERATIONS",I,J, "PBLH: ",PBLH(I)
+            yesno = 1
+      ENDIF
+
+      IF (yesno == 1) THEN
+        print*," OTHER INFO:"
+        write(*,1001)"REGIME:",REGIME(I)," z/L:",ZOL(I)," U*:",UST(I),&
+              " Tstar:",MOL(I)
+        write(*,1002)"PSIM:",PSIM(I)," PSIH:",PSIH(I)," W*:",WSTAR(I),&
+              " DTHV:",THV1D(I)-THVGB(I)
+        write(*,1003)"CPM:",CPM(I)," RHO1D:",RHO1D(I)," L:",&
+              ZOL(I)/ZA(I)," DTH:",TH1D(I)-THGB(I)
+        write(*,1004)"Z0/Zt:",zratio(I)," Z0:",ZNTstoch(I)," Zt:",z_t(I),&
+              " za:",za(I)
+        write(*,1005)"Re:",restar," MAVAIL:",MAVAIL(I)," QSFC(I):",&
+              QSFC(I)," QVSH(I):",QVSH(I)
+        print*,"PSIX=",PSIX," Z0:",ZNTstoch(I)," T1D(i):",T1D(i)
+        write(*,*)"============================================="
+      ENDIF
    ENDIF
 
  ENDDO !end i-loop
@@ -1273,7 +1336,7 @@ SUBROUTINE SFCLAY1D_mynn(J,U1D,V1D,T1D,QV1D,P1D,dz8w1d,rho1d,   &
 END SUBROUTINE SFCLAY1D_mynn
 !-------------------------------------------------------------------          
    SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,&
-       & landsea,IZ0TLND2)
+       & landsea,IZ0TLND2,spp_pbl,rstoch)
 
        ! This subroutine returns the thermal and moisture roughness lengths
        ! from Zilitinkevich (1995) and Zilitinkevich et al. (2001) over
@@ -1291,6 +1354,9 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,&
        REAL :: CZIL  !=0.100 in Chen et al. (1997)
                      !=0.075 in Zilitinkevich (1995)
                      !=0.500 in Lemone et al. (2008)
+       INTEGER,  INTENT(IN)  ::    spp_pbl
+       REAL,     INTENT(IN)  ::    rstoch
+
 
        IF (landsea-1.5 .GT. 0) THEN    !WATER
 
@@ -1327,7 +1393,17 @@ SUBROUTINE zilitinkevich_1995(Z_0,Zt,Zq,restar,ustar,KARMAN,&
           Zq = Z_0*EXP(-KARMAN*CZIL*SQRT(restar))
           Zq = MIN( Zq, Z_0/2.)
 
-          !Zq = Zt
+! perturb thermal and moisture roughness lenth by +/-50%
+! uses same perturbation pattern for perturbing cloud fraction 
+! and turbulent mixing length (module_sf_mynn.F), but 
+! twice the amplitude; 
+! multiplication with -1.0 anticorrelates patterns
+          if (spp_pbl==1) then
+             Zt = Zt + Zt * 2.0 * rstoch
+             Zt = MAX(Zt, 0.001)
+             Zq = Zt
+          endif
+
        ENDIF
                    
        return
@@ -1553,7 +1629,7 @@ SUBROUTINE fairall_etal_2003(Zt,Zq,Ren,ustar,visc)
 
     END SUBROUTINE fairall_etal_2003
 !--------------------------------------------------------------------
-    SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc)
+    SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc,rstoch,spp_pbl)
 
     !This formulation for thermal and moisture roughness length (Zt and Zq)
     !as a function of the roughness Reynolds number (Ren) comes from the
@@ -1562,15 +1638,21 @@ SUBROUTINE fairall_etal_2014(Zt,Zq,Ren,ustar,visc)
     !This is for use over water only.
 
        IMPLICIT NONE
-       REAL, INTENT(IN)  :: Ren,ustar,visc
+       REAL, INTENT(IN)  :: Ren,ustar,visc,rstoch
+       INTEGER, INTENT(IN):: spp_pbl
        REAL, INTENT(OUT) :: Zt,Zq
 
        !Zt = (5.5e-5)*(Ren**(-0.60))
        Zt = MIN(1.6E-4, 5.8E-5/(Ren**0.72))
        Zq = Zt
 
-       Zt = MAX(Zt,2.0e-9)
-       Zq = MAX(Zt,2.0e-9)
+       IF (spp_pbl ==1) THEN
+          Zt = MAX(Zt + Zt*2.0*rstoch,2.0e-9)
+          Zq = MAX(Zt + Zt*2.0*rstoch,2.0e-9)
+       ELSE
+          Zt = MAX(Zt,2.0e-9)
+          Zq = MAX(Zt,2.0e-9)
+       ENDIF
 
        return
 
diff --git a/wrfv2_fire/phys/module_sf_noahdrv.F b/wrfv2_fire/phys/module_sf_noahdrv.F
index 9b80b265..afa65dbb 100644
--- a/wrfv2_fire/phys/module_sf_noahdrv.F
+++ b/wrfv2_fire/phys/module_sf_noahdrv.F
@@ -648,6 +648,8 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK,                      &
    HFX_PHY = 0.0   ! initialize
    QFX_PHY = 0.0
    XQNORM  = 0.0
+   XSDA_HFX = 0.0
+   XSDA_QFX = 0.0
 !
 !  END FASDAS
 !
@@ -831,9 +833,12 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK,                      &
           ! Land-ice or land points use the usual deep-soil temperature.
           TBOT=TMN(I,J)
 
+          IF(ISURBAN.EQ.1) THEN
+! assumes these only need to be set for USGS land data
           IF(VEGTYP.EQ.25) SHDFAC=0.0000
           IF(VEGTYP.EQ.26) SHDFAC=0.0000
           IF(VEGTYP.EQ.27) SHDFAC=0.0000
+          ENDIF
           IF(SOILTYP.EQ.14.AND.XICE(I,J).EQ.0.)THEN
 #if 0
          IF(IPRINT)PRINT*,' SOIL TYPE FOUND TO BE WATER AT A LAND-POINT'
@@ -1045,6 +1050,21 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK,                      &
           SMC(NS) = 1.0
           SMAV(NS) = 1.0
        ENDDO
+!
+!  FASDAS
+!
+       IF( fasdas == 1 ) THEN
+
+         DZQ = DZ8W(I,1,J)
+         XSDA_HFX= SDA_HFX(I,J)*RHO(I,1,J)*CPM(I,J)*DZQ  ! W/m^2
+         XSDA_QFX= 0.0          ! Kg/m2/s of water
+         XQNORM = 0.0
+
+       ENDIF
+!
+!  END FASDAS
+!
+
        CALL SFLX_GLACIAL(I,J,ISICE,FFROZP,DT,ZLVL,NSOIL,SLDPTH,   &    !C
             &    LWDN,SOLNET,SFCPRS,PRCP,SFCTMP,Q2K,              &    !F
             &    TH2,Q2SAT,DQSDT2,                                &    !I
@@ -1254,14 +1274,14 @@ SUBROUTINE lsm(DZ8W,QV3D,P8W3D,T3D,TSK,                      &
 !
 !
 !      Limits to avoid dividing by small number
-            if (CHS(I,J) < 1.0E-04) then
-               CHS(I,J)  = 1.0E-04
+            if (CHS(I,J) < 1.0E-02) then
+               CHS(I,J)  = 1.0E-02
             endif
-            if (CHS2(I,J) < 1.0E-04) then
-               CHS2(I,J)  = 1.0E-04
+            if (CHS2(I,J) < 1.0E-02) then
+               CHS2(I,J)  = 1.0E-02
             endif
-            if (CQS2(I,J) < 1.0E-04) then
-               CQS2(I,J)  = 1.0E-04
+            if (CQS2(I,J) < 1.0E-02) then
+               CQS2(I,J)  = 1.0E-02
             endif
 !
             CHS_URB  = CHS(I,J)
@@ -2839,6 +2859,8 @@ SUBROUTINE lsm_mosaic(DZ8W,QV3D,P8W3D,T3D,TSK,                      &
    HFX_PHY = 0.0   ! initialize
    QFX_PHY = 0.0
    XQNORM  = 0.0
+   XSDA_HFX = 0.0
+   XSDA_QFX = 0.0
 !
 !  END FASDAS
 !
diff --git a/wrfv2_fire/phys/module_sf_noahlsm.F b/wrfv2_fire/phys/module_sf_noahlsm.F
index 38bf19ed..f003fd6c 100644
--- a/wrfv2_fire/phys/module_sf_noahlsm.F
+++ b/wrfv2_fire/phys/module_sf_noahlsm.F
@@ -3254,7 +3254,9 @@ SUBROUTINE SNOPAC (ETP,ETA,PRCP,PRCPF,SNOWNG,SMC,SMCMAX,SMCWLT,   &
 ! ABOVE FREEZING BLOCK
 ! ----------------------------------------------------------------------
       ELSE
-         T1 = TFREEZ * SNCOVR ** SNOEXP + T12 * (1.0- SNCOVR ** SNOEXP)
+!     From V3.9 original code (commented) replaced to allow complete melting of small snow amounts
+!        T1 = TFREEZ * SNCOVR ** SNOEXP + T12 * (1.0- SNCOVR ** SNOEXP)
+         T1 = TFREEZ * max(0.01,SNCOVR ** SNOEXP) + T12 * (1.0- max(0.01,SNCOVR ** SNOEXP))
          BETA = 1.0
 
 ! ----------------------------------------------------------------------
diff --git a/wrfv2_fire/phys/module_sf_noahmp_groundwater.F b/wrfv2_fire/phys/module_sf_noahmp_groundwater.F
index d7afc5f6..79edf303 100644
--- a/wrfv2_fire/phys/module_sf_noahmp_groundwater.F
+++ b/wrfv2_fire/phys/module_sf_noahmp_groundwater.F
@@ -137,7 +137,7 @@ SUBROUTINE WTABLE_mmf_noahmp (NSOIL     ,XLAND    ,XICE    ,XICE_THRESHOLD  ,ISI
 
             BEXP   = BEXP_TABLE   (ISLTYP(I,J))
             DKSAT  = DKSAT_TABLE  (ISLTYP(I,J))
-            PSISAT = PSISAT_TABLE (ISLTYP(I,J))
+            PSISAT = -1.0*PSISAT_TABLE (ISLTYP(I,J))
             SMCMAX = SMCMAX_TABLE (ISLTYP(I,J))
             SMCWLT = SMCWLT_TABLE (ISLTYP(I,J))
 
@@ -230,8 +230,7 @@ SUBROUTINE LATERALFLOW  (ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA &
   DATA KLATFACTOR /2.,3.,4.,10.,10.,12.,14.,20.,24.,28.,40.,48.,2.,0.,10.,0.,20.,2.,2./
 
   REAL,    PARAMETER :: PI = 3.14159265 
-! REAL,    PARAMETER :: FANGLE = SQRT(TAN(PI/8.))/(2.*SQRT(2.))
-  REAL,    PARAMETER :: FANGLE = 0.45508986056   ! f95 does not permit real intrinsics in init expressions
+  REAL,    PARAMETER :: FANGLE = 0.22754493   ! = 0.5*sqrt(0.5*tan(pi/8))
 
 itsh=max(its-1,ids)
 iteh=min(ite+1,ide-1)
diff --git a/wrfv2_fire/phys/module_sf_noahmpdrv.F b/wrfv2_fire/phys/module_sf_noahmpdrv.F
index 5e32d55d..1cb95d20 100644
--- a/wrfv2_fire/phys/module_sf_noahmpdrv.F
+++ b/wrfv2_fire/phys/module_sf_noahmpdrv.F
@@ -9,13 +9,14 @@ MODULE module_sf_noahmpdrv
 !
 CONTAINS
 !
-  SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN : Time/Space-related
+  SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,XLAT,XLONG, & ! IN : Time/Space-related
                   DZ8W,       DT,       DZS,    NSOIL,       DX,            & ! IN : Model configuration 
 	        IVGTYP,   ISLTYP,    VEGFRA,   VEGMAX,      TMN,            & ! IN : Vegetation/Soil characteristics
-		 XLAND,     XICE,XICE_THRES,                                & ! IN : Vegetation/Soil characteristics
+		 XLAND,     XICE,XICE_THRES,  CROPCAT,                      & ! IN : Vegetation/Soil characteristics
+	       PLANTING,  HARVEST,SEASON_GDD,                               &
                  IDVEG, IOPT_CRS,  IOPT_BTR, IOPT_RUN, IOPT_SFC, IOPT_FRZ,  & ! IN : User options
               IOPT_INF, IOPT_RAD,  IOPT_ALB, IOPT_SNF,IOPT_TBOT, IOPT_STC,  & ! IN : User options
-              IOPT_GLA, IOPT_RSF,   IZ0TLND,                                & ! IN : User options
+              IOPT_GLA, IOPT_RSF,   IZ0TLND, SF_URBAN_PHYSICS,              & ! IN : User options
                    T3D,     QV3D,     U_PHY,    V_PHY,   SWDOWN,      GLW,  & ! IN : Forcing
 		 P8W3D,PRECIP_IN,        SR,                                & ! IN : Forcing
                    TSK,      HFX,      QFX,        LH,   GRDFLX,    SMSTAV, & ! IN/OUT LSM eqv
@@ -28,7 +29,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
                QSNOWXY, WSLAKEXY,    ZWTXY,      WAXY,     WTXY,    TSNOXY, & ! IN/OUT Noah MP only
 	       ZSNSOXY,  SNICEXY,  SNLIQXY,  LFMASSXY, RTMASSXY,  STMASSXY, & ! IN/OUT Noah MP only
 	        WOODXY, STBLCPXY, FASTCPXY,    XLAIXY,   XSAIXY,   TAUSSXY, & ! IN/OUT Noah MP only
-	       SMOISEQ, SMCWTDXY,DEEPRECHXY,   RECHXY,  GRAINXY,    GDDXY,  & ! IN/OUT Noah MP only
+	       SMOISEQ, SMCWTDXY,DEEPRECHXY,   RECHXY,  GRAINXY,    GDDXY,PGSXY,  & ! IN/OUT Noah MP only
 	        T2MVXY,   T2MBXY,    Q2MVXY,   Q2MBXY,                      & ! OUT Noah MP only
 	        TRADXY,    NEEXY,    GPPXY,     NPPXY,   FVEGXY,   RUNSFXY, & ! OUT Noah MP only
 	       RUNSBXY,   ECANXY,   EDIRXY,   ETRANXY,    FSAXY,    FIRAXY, & ! OUT Noah MP only
@@ -51,7 +52,10 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     USE MODULE_SF_NOAHMPLSM
 !    USE MODULE_SF_NOAHMPLSM, only: noahmp_options, NOAHMP_SFLX, noahmp_parameters
     USE module_sf_noahmp_glacier
-    USE NOAHMP_TABLES, ONLY: ISICE_TABLE, CO2_TABLE, O2_TABLE
+    USE NOAHMP_TABLES, ONLY: ISICE_TABLE, CO2_TABLE, O2_TABLE, DEFAULT_CROP_TABLE, ISCROP_TABLE, ISURBAN_TABLE, NATURAL_TABLE, &
+                             LOW_DENSITY_RESIDENTIAL_TABLE, HIGH_DENSITY_RESIDENTIAL_TABLE, HIGH_INTENSITY_INDUSTRIAL_TABLE
+    USE module_sf_urban,    only: IRI_SCHEME
+    USE module_ra_gfdleta,  only: cal_mon_day
 !----------------------------------------------------------------
     IMPLICIT NONE
 !----------------------------------------------------------------
@@ -62,7 +66,8 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     INTEGER,                                         INTENT(IN   ) ::  YR        ! 4-digit year
     REAL,                                            INTENT(IN   ) ::  JULIAN    ! Julian day
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  COSZIN    ! cosine zenith angle
-    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  XLATIN    ! latitude [rad]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  XLAT      ! latitude [rad]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  XLONG     ! latitude [rad]
     REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::  DZ8W      ! thickness of atmo layers [m]
     REAL,                                            INTENT(IN   ) ::  DT        ! timestep [s]
     REAL,    DIMENSION(1:nsoil),                     INTENT(IN   ) ::  DZS       ! thickness of soil layers [m]
@@ -91,6 +96,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     INTEGER,                                         INTENT(IN   ) ::  IOPT_GLA  ! glacier option (1->phase change; 2->simple)
     INTEGER,                                         INTENT(IN   ) ::  IOPT_RSF  ! surface resistance (1->Sakaguchi/Zeng; 2->Seller; 3->mod Sellers; 4->1+snow)
     INTEGER,                                         INTENT(IN   ) ::  IZ0TLND   ! option of Chen adjustment of Czil (not used)
+    INTEGER,                                         INTENT(IN   ) ::  sf_urban_physics   ! urban physics option
     REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::  T3D       ! 3D atmospheric temperature valid at mid-levels [K]
     REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::  QV3D      ! 3D water vapor mixing ratio [kg/kg_dry]
     REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::  U_PHY     ! 3D U wind component [m/s]
@@ -108,6 +114,16 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ), OPTIONAL ::  MP_SNOW   ! snow precipitation entering land model [mm]       ! MB/AN : v3.7
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ), OPTIONAL ::  MP_GRAUP  ! graupel precipitation entering land model [mm]    ! MB/AN : v3.7
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ), OPTIONAL ::  MP_HAIL   ! hail precipitation entering land model [mm]       ! MB/AN : v3.7
+
+! Crop Model
+    INTEGER, DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  CROPCAT   ! crop catagory
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  PLANTING  ! planting date
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  HARVEST   ! harvest date
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  SEASON_GDD! growing season GDD
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  GRAINXY   ! mass of grain XING [g/m2]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  GDDXY     ! growing degree days XING (based on 10C) 
+ INTEGER,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  PGSXY
+
 #ifdef WRF_HYDRO
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  sfcheadrt,INFXSRT,soldrain   ! for WRF-Hydro
 #endif
@@ -177,8 +193,6 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  RTMASSXY  ! mass of fine roots [g/m2]
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  STMASSXY  ! stem mass [g/m2]
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  WOODXY    ! mass of wood (incl. woody roots) [g/m2]
-    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  GRAINXY   ! mass of grain XING [g/m2]
-    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  GDDXY     ! growing degree days XING (based on 10C) 
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  STBLCPXY  ! stable carbon in deep soil [g/m2]
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  FASTCPXY  ! short-lived carbon, shallow soil [g/m2]
     REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  XLAIXY    ! leaf area index
@@ -249,6 +263,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     REAL                                :: Z_ML         ! model height [m]
     INTEGER                             :: VEGTYP       ! vegetation type
     INTEGER                             :: SOILTYP      ! soil type
+    INTEGER                             :: CROPTYPE     ! crop type
     REAL                                :: FVEG         ! vegetation fraction [-]
     REAL                                :: FVGMAX       ! annual max vegetation fraction []
     REAL                                :: TBOT         ! deep soil temperature [K]
@@ -314,7 +329,8 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     REAL                                :: STMASS       ! stem mass [g/m2]
     REAL                                :: WOOD         ! mass of wood (incl. woody roots) [g/m2]
     REAL                                :: GRAIN        ! mass of grain XING [g/m2]
-    REAL                                :: GDD        ! mass of grain XING[g/m2]
+    REAL                                :: GDD          ! mass of grain XING[g/m2]
+    INTEGER                             :: PGS          !stem respiration [g/m2/s]
     REAL                                :: STBLCP       ! stable carbon in deep soil [g/m2]
     REAL                                :: FASTCP       ! short-lived carbon, shallow soil [g/m2]
     REAL                                :: PLAI         ! leaf area index
@@ -407,6 +423,8 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
     INTEGER                             :: SOILCOLOR          ! soil color index
     INTEGER                             :: IST          ! surface type 1-soil; 2-lake
     INTEGER                             :: YEARLEN
+    REAL                                :: SOLAR_TIME
+    INTEGER                             :: JMONTH, JDAY
 
     INTEGER, PARAMETER                  :: NSNOW = 3    ! number of snow layers fixed to 3
     REAL, PARAMETER                     :: undefined_value = -1.E36
@@ -483,7 +501,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
 ! IN only
 
        COSZ   = COSZIN  (I,J)                         ! cos zenith angle []
-       LAT    = XLATIN  (I,J)                         ! latitude [rad]
+       LAT    = XLAT  (I,J)                           ! latitude [rad]
        Z_ML   = 0.5*DZ8W(I,1,J)                       ! DZ8W: thickness of full levels; ZLVL forcing height [m]
        VEGTYP = IVGTYP(I,J)                           ! vegetation type
        SOILTYP= ISLTYP(I,J)                           ! soil type
@@ -501,6 +519,15 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
        PSFC   = P8W3D(I,1,J)                          ! surface pressure defined a full levels [Pa]
        PRCP   = PRECIP_IN (I,J) / DT                  ! timestep total precip rate (glacier) [mm/s]! MB: v3.7
 
+       CROPTYPE = 0
+       IF (IDVEG == 10 .AND. VEGTYP == ISCROP_TABLE) CROPTYPE = DEFAULT_CROP_TABLE ! default croptype is generic dynamic vegetation crop
+       IF (IDVEG == 10 .AND. CROPCAT(I,J) > 0) THEN
+         CROPTYPE = CROPCAT(I,J)                      ! crop type
+	 VEGTYP = ISCROP_TABLE
+         FVGMAX = 0.95
+	 FVEG   = 0.95
+       END IF
+
        IF (PRESENT(MP_RAINC) .AND. PRESENT(MP_RAINNC) .AND. PRESENT(MP_SHCV) .AND. &
            PRESENT(MP_SNOW)  .AND. PRESENT(MP_GRAUP)  .AND. PRESENT(MP_HAIL)   ) THEN
 
@@ -560,8 +587,6 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
        RTMASS                = RTMASSXY(I,J)                ! root mass
        STMASS                = STMASSXY(I,J)                ! stem mass
        WOOD                  = WOODXY  (I,J)                ! mass of wood (incl. woody roots) [g/m2]
-       GRAIN                 = GRAINXY (I,J)                ! mass of grain XING [g/m2]
-       GDD                   = GDDXY (I,J)                  ! growing degree days XING
        STBLCP                = STBLCPXY(I,J)                ! stable carbon pool
        FASTCP                = FASTCPXY(I,J)                ! fast carbon pool
        PLAI                  = XLAIXY  (I,J)                ! leaf area index [-] (no snow effects)
@@ -582,6 +607,18 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
           SOILTYP = 7
        ENDIF
 
+       IF( IVGTYP(I,J) == ISURBAN_TABLE                  .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL_TABLE .or. &
+           IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL_TABLE .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL_TABLE ) THEN
+
+         IF(SF_URBAN_PHYSICS == 0 ) THEN
+           VEGTYP = ISURBAN_TABLE
+         ELSE
+           VEGTYP = NATURAL_TABLE  ! set urban vegetation type based on table natural
+           FVGMAX = 0.96 
+         ENDIF
+
+       ENDIF
+
 ! placeholders for 3D soil
 !       parameters%bexp   = BEXP_3D  (I,1:NSOIL,J) ! C-H B exponent
 !       parameters%smcdry = SMCDRY_3D(I,1:NSOIL,J) ! Soil Moisture Limit: Dry
@@ -595,7 +632,40 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
 !       parameters%refdk  = REFDK_2D (I,J)         ! Reference Soil Conductivity
 !       parameters%refkdt = REFKDT_2D(I,J)         ! Soil Infiltration Parameter
 
-       CALL TRANSFER_MP_PARAMETERS(VEGTYP,SOILTYP,SLOPETYP,SOILCOLOR,parameters)
+       CALL TRANSFER_MP_PARAMETERS(VEGTYP,SOILTYP,SLOPETYP,SOILCOLOR,CROPTYPE,parameters)
+       
+       GRAIN = GRAINXY (I,J)                ! mass of grain XING [g/m2]
+       GDD   = GDDXY (I,J)                  ! growing degree days XING
+       PGS   = PGSXY (I,J)                  ! growing degree days XING
+
+       if(idveg == 10 .and. croptype > 0) then
+         parameters%PLTDAY = PLANTING(I,J)
+	 parameters%HSDAY  = HARVEST (I,J)
+	 parameters%GDDS1  = SEASON_GDD(I,J) / 1770.0 * parameters%GDDS1
+	 parameters%GDDS2  = SEASON_GDD(I,J) / 1770.0 * parameters%GDDS2
+	 parameters%GDDS3  = SEASON_GDD(I,J) / 1770.0 * parameters%GDDS3
+	 parameters%GDDS4  = SEASON_GDD(I,J) / 1770.0 * parameters%GDDS4
+	 parameters%GDDS5  = SEASON_GDD(I,J) / 1770.0 * parameters%GDDS5
+       end if
+
+!=== hydrological processes for vegetation in urban model ===
+!=== irrigate vegetaion only in urban area, MAY-SEP, 9-11pm
+
+       IF( IVGTYP(I,J) == ISURBAN_TABLE                  .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL_TABLE .or. &
+           IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL_TABLE .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL_TABLE ) THEN
+
+         IF(SF_URBAN_PHYSICS > 0 .AND. IRI_SCHEME == 1 ) THEN
+	     SOLAR_TIME = (JULIAN - INT(JULIAN))*24 + XLONG(I,J)/15.0
+	     IF(SOLAR_TIME < 0.) SOLAR_TIME = SOLAR_TIME + 24.
+             CALL CAL_MON_DAY(INT(JULIAN),YR,JMONTH,JDAY)
+             IF (SOLAR_TIME >= 21. .AND. SOLAR_TIME <= 23. .AND. JMONTH >= 5 .AND. JMONTH <= 9) THEN
+                SMC(1) = max(SMC(1),parameters%SMCREF(1))
+                SMC(2) = max(SMC(2),parameters%SMCREF(2))
+             ENDIF
+         ENDIF
+
+       ENDIF
+
 ! Initialized local
 
        FICEOLD = 0.0
@@ -644,7 +714,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
          TAH    = undefined_value
          FWET   = undefined_value 
          WSLAKE = undefined_value 
-         ZWT    = undefined_value 
+!         ZWT    = undefined_value 
          WA     = undefined_value 
          WT     = undefined_value 
          LFMASS = undefined_value 
@@ -702,7 +772,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
          CALL NOAHMP_SFLX (parameters, &
             I       , J       , LAT     , YEARLEN , JULIAN  , COSZ    , & ! IN : Time/Space-related
             DT      , DX      , DZ8W1D  , NSOIL   , ZSOIL   , NSNOW   , & ! IN : Model configuration 
-            FVEG    , FVGMAX  , VEGTYP  , ICE     , IST     ,           & ! IN : Vegetation/Soil characteristics
+            FVEG    , FVGMAX  , VEGTYP  , ICE     , IST     , CROPTYPE, & ! IN : Vegetation/Soil characteristics
             SMCEQ   ,                                                   & ! IN : Vegetation/Soil characteristics
             T_ML    , P_ML    , PSFC    , U_ML    , V_ML    , Q_ML    , & ! IN : Forcing
             QC      , SWDN    , LWDN    ,                               & ! IN : Forcing
@@ -715,7 +785,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
             ZWT     , WA      , WT      , WSLAKE  , LFMASS  , RTMASS  , & ! IN/OUT : 
             STMASS  , WOOD    , STBLCP  , FASTCP  , PLAI    , PSAI    , & ! IN/OUT : 
             CM      , CH      , TAUSS   ,                               & ! IN/OUT : 
-            GRAIN   , GDD     ,                                         & ! IN/OUT 
+            GRAIN   , GDD     , PGS     ,                               & ! IN/OUT 
             SMCWTD  ,DEEPRECH , RECH    ,                               & ! IN/OUT :
             Z0WRF   ,                                                   &
             FSA     , FSR     , FIRA    , FSH     , SSOIL   , FCEV    , & ! OUT : 
@@ -796,8 +866,6 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
              RTMASSXY (I,J)                = RTMASS
              STMASSXY (I,J)                = STMASS
              WOODXY   (I,J)                = WOOD
-             GRAINXY  (I,J)                = GRAIN !GRAIN XING
-             GDDXY    (I,J)                = GDD   !XING 
              STBLCPXY (I,J)                = STBLCP
              FASTCPXY (I,J)                = FASTCP
              XLAIXY   (I,J)                = PLAI
@@ -856,6 +924,10 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
              DEEPRECHXY(I,J)               = DEEPRECHXY(I,J) + DEEPRECH
              SMCWTDXY(I,J)                 = SMCWTD
 
+             GRAINXY  (I,J) = GRAIN !GRAIN XING
+             GDDXY    (I,J) = GDD   !XING 
+	     PGSXY    (I,J) = PGS
+
           ENDIF                                                         ! endif of land-sea test
 
       ENDDO ILOOP                                                       ! of I loop
@@ -865,7 +937,7 @@ SUBROUTINE noahmplsm(ITIMESTEP,        YR,   JULIAN,   COSZIN,   XLATIN,  & ! IN
   END SUBROUTINE noahmplsm
 !------------------------------------------------------
 
-SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,parameters)
+SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,CROPTYPE,parameters)
 
   USE NOAHMP_TABLES
   USE MODULE_SF_NOAHMPLSM
@@ -876,6 +948,7 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,parameter
   INTEGER, INTENT(IN)    :: SOILTYPE
   INTEGER, INTENT(IN)    :: SLOPETYPE
   INTEGER, INTENT(IN)    :: SOILCOLOR
+  INTEGER, INTENT(IN)    :: CROPTYPE
     
   type (noahmp_parameters), intent(inout) :: parameters
     
@@ -887,6 +960,7 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,parameter
   parameters%ISWATER   =   ISWATER_TABLE
   parameters%ISBARREN  =  ISBARREN_TABLE
   parameters%ISICE     =     ISICE_TABLE
+  parameters%ISCROP    =    ISCROP_TABLE
   parameters%EBLFOREST = EBLFOREST_TABLE
 
   parameters%URBAN_FLAG = .FALSE.
@@ -970,44 +1044,46 @@ SUBROUTINE TRANSFER_MP_PARAMETERS(VEGTYPE,SOILTYPE,SLOPETYPE,SOILCOLOR,parameter
 ! Transfer crop parameters
 !------------------------------------------------------------------------------------------!
 
-   parameters%PLTDAY    =    PLTDAY_TABLE(1)    ! Planting date
-   parameters%HSDAY     =     HSDAY_TABLE(1)    ! Harvest date
-   parameters%PLANTPOP  =  PLANTPOP_TABLE(1)    ! Plant density [per ha] - used?
-   parameters%IRRI      =      IRRI_TABLE(1)    ! Irrigation strategy 0= non-irrigation 1=irrigation (no water-stress)
-   parameters%GDDTBASE  =  GDDTBASE_TABLE(1)    ! Base temperature for GDD accumulation [C]
-   parameters%GDDTCUT   =   GDDTCUT_TABLE(1)    ! Upper temperature for GDD accumulation [C]
-   parameters%GDDS1     =     GDDS1_TABLE(1)    ! GDD from seeding to emergence
-   parameters%GDDS2     =     GDDS2_TABLE(1)    ! GDD from seeding to initial vegetative 
-   parameters%GDDS3     =     GDDS3_TABLE(1)    ! GDD from seeding to post vegetative 
-   parameters%GDDS4     =     GDDS4_TABLE(1)    ! GDD from seeding to intial reproductive
-   parameters%GDDS5     =     GDDS5_TABLE(1)    ! GDD from seeding to pysical maturity 
-   parameters%C3C4      =      C3C4_TABLE(1)    ! photosynthetic pathway:  1. = c3 2. = c4
-   parameters%AREF      =      AREF_TABLE(1)    ! reference maximum CO2 assimulation rate 
-   parameters%PSNRF     =     PSNRF_TABLE(1)    ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds)
-   parameters%I2PAR     =     I2PAR_TABLE(1)    ! Fraction of incoming solar radiation to photosynthetically active radiation
-   parameters%TASSIM0   =   TASSIM0_TABLE(1)    ! Minimum temperature for CO2 assimulation [C]
-   parameters%TASSIM1   =   TASSIM1_TABLE(1)    ! CO2 assimulation linearly increasing until temperature reaches T1 [C]
-   parameters%TASSIM2   =   TASSIM2_TABLE(1)    ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C]
-   parameters%K         =         K_TABLE(1)    ! light extinction coefficient
-   parameters%EPSI      =      EPSI_TABLE(1)    ! initial light use efficiency
-   parameters%Q10MR     =     Q10MR_TABLE(1)    ! q10 for maintainance respiration
-   parameters%FOLN_MX   =   FOLN_MX_TABLE(1)    ! foliage nitrogen concentration when f(n)=1 (%)
-   parameters%LEFREEZ   =   LEFREEZ_TABLE(1)    ! characteristic T for leaf freezing [K]
-   parameters%DILE_FC   =   DILE_FC_TABLE(1,:)  ! coeficient for temperature leaf stress death [1/s]
-   parameters%DILE_FW   =   DILE_FW_TABLE(1,:)  ! coeficient for water leaf stress death [1/s]
-   parameters%FRA_GR    =    FRA_GR_TABLE(1)    ! fraction of growth respiration
-   parameters%LF_OVRC   =   LF_OVRC_TABLE(1,:)  ! fraction of leaf turnover  [1/s]
-   parameters%ST_OVRC   =   ST_OVRC_TABLE(1,:)  ! fraction of stem turnover  [1/s]
-   parameters%RT_OVRC   =   RT_OVRC_TABLE(1,:)  ! fraction of root tunrover  [1/s]
-   parameters%LFMR25    =    LFMR25_TABLE(1)    ! leaf maintenance respiration at 25C [umol CO2/m**2  /s]
-   parameters%STMR25    =    STMR25_TABLE(1)    ! stem maintenance respiration at 25C [umol CO2/kg bio/s]
-   parameters%RTMR25    =    RTMR25_TABLE(1)    ! root maintenance respiration at 25C [umol CO2/kg bio/s]
-   parameters%GRAINMR25 = GRAINMR25_TABLE(1)    ! grain maintenance respiration at 25C [umol CO2/kg bio/s]
-   parameters%LFPT      =      LFPT_TABLE(1,:)  ! fraction of carbohydrate flux to leaf
-   parameters%STPT      =      STPT_TABLE(1,:)  ! fraction of carbohydrate flux to stem
-   parameters%RTPT      =      RTPT_TABLE(1,:)  ! fraction of carbohydrate flux to root
-   parameters%GRAINPT   =   GRAINPT_TABLE(1,:)  ! fraction of carbohydrate flux to grain
-   parameters%BIO2LAI   =   BIO2LAI_TABLE(1)    ! leaf are per living leaf biomass [m^2/kg]
+  IF(CROPTYPE > 0) THEN
+   parameters%PLTDAY    =    PLTDAY_TABLE(CROPTYPE)    ! Planting date
+   parameters%HSDAY     =     HSDAY_TABLE(CROPTYPE)    ! Harvest date
+   parameters%PLANTPOP  =  PLANTPOP_TABLE(CROPTYPE)    ! Plant density [per ha] - used?
+   parameters%IRRI      =      IRRI_TABLE(CROPTYPE)    ! Irrigation strategy 0= non-irrigation 1=irrigation (no water-stress)
+   parameters%GDDTBASE  =  GDDTBASE_TABLE(CROPTYPE)    ! Base temperature for GDD accumulation [C]
+   parameters%GDDTCUT   =   GDDTCUT_TABLE(CROPTYPE)    ! Upper temperature for GDD accumulation [C]
+   parameters%GDDS1     =     GDDS1_TABLE(CROPTYPE)    ! GDD from seeding to emergence
+   parameters%GDDS2     =     GDDS2_TABLE(CROPTYPE)    ! GDD from seeding to initial vegetative 
+   parameters%GDDS3     =     GDDS3_TABLE(CROPTYPE)    ! GDD from seeding to post vegetative 
+   parameters%GDDS4     =     GDDS4_TABLE(CROPTYPE)    ! GDD from seeding to intial reproductive
+   parameters%GDDS5     =     GDDS5_TABLE(CROPTYPE)    ! GDD from seeding to pysical maturity 
+   parameters%C3C4      =      C3C4_TABLE(CROPTYPE)    ! photosynthetic pathway:  1. = c3 2. = c4
+   parameters%AREF      =      AREF_TABLE(CROPTYPE)    ! reference maximum CO2 assimulation rate 
+   parameters%PSNRF     =     PSNRF_TABLE(CROPTYPE)    ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds)
+   parameters%I2PAR     =     I2PAR_TABLE(CROPTYPE)    ! Fraction of incoming solar radiation to photosynthetically active radiation
+   parameters%TASSIM0   =   TASSIM0_TABLE(CROPTYPE)    ! Minimum temperature for CO2 assimulation [C]
+   parameters%TASSIM1   =   TASSIM1_TABLE(CROPTYPE)    ! CO2 assimulation linearly increasing until temperature reaches T1 [C]
+   parameters%TASSIM2   =   TASSIM2_TABLE(CROPTYPE)    ! CO2 assmilation rate remain at Aref until temperature reaches T2 [C]
+   parameters%K         =         K_TABLE(CROPTYPE)    ! light extinction coefficient
+   parameters%EPSI      =      EPSI_TABLE(CROPTYPE)    ! initial light use efficiency
+   parameters%Q10MR     =     Q10MR_TABLE(CROPTYPE)    ! q10 for maintainance respiration
+   parameters%FOLN_MX   =   FOLN_MX_TABLE(CROPTYPE)    ! foliage nitrogen concentration when f(n)=1 (%)
+   parameters%LEFREEZ   =   LEFREEZ_TABLE(CROPTYPE)    ! characteristic T for leaf freezing [K]
+   parameters%DILE_FC   =   DILE_FC_TABLE(CROPTYPE,:)  ! coeficient for temperature leaf stress death [1/s]
+   parameters%DILE_FW   =   DILE_FW_TABLE(CROPTYPE,:)  ! coeficient for water leaf stress death [1/s]
+   parameters%FRA_GR    =    FRA_GR_TABLE(CROPTYPE)    ! fraction of growth respiration
+   parameters%LF_OVRC   =   LF_OVRC_TABLE(CROPTYPE,:)  ! fraction of leaf turnover  [1/s]
+   parameters%ST_OVRC   =   ST_OVRC_TABLE(CROPTYPE,:)  ! fraction of stem turnover  [1/s]
+   parameters%RT_OVRC   =   RT_OVRC_TABLE(CROPTYPE,:)  ! fraction of root tunrover  [1/s]
+   parameters%LFMR25    =    LFMR25_TABLE(CROPTYPE)    ! leaf maintenance respiration at 25C [umol CO2/m**2  /s]
+   parameters%STMR25    =    STMR25_TABLE(CROPTYPE)    ! stem maintenance respiration at 25C [umol CO2/kg bio/s]
+   parameters%RTMR25    =    RTMR25_TABLE(CROPTYPE)    ! root maintenance respiration at 25C [umol CO2/kg bio/s]
+   parameters%GRAINMR25 = GRAINMR25_TABLE(CROPTYPE)    ! grain maintenance respiration at 25C [umol CO2/kg bio/s]
+   parameters%LFPT      =      LFPT_TABLE(CROPTYPE,:)  ! fraction of carbohydrate flux to leaf
+   parameters%STPT      =      STPT_TABLE(CROPTYPE,:)  ! fraction of carbohydrate flux to stem
+   parameters%RTPT      =      RTPT_TABLE(CROPTYPE,:)  ! fraction of carbohydrate flux to root
+   parameters%GRAINPT   =   GRAINPT_TABLE(CROPTYPE,:)  ! fraction of carbohydrate flux to grain
+   parameters%BIO2LAI   =   BIO2LAI_TABLE(CROPTYPE)    ! leaf are per living leaf biomass [m^2/kg]
+  END IF
 
 !------------------------------------------------------------------------------------------!
 ! Transfer global parameters
@@ -1075,17 +1151,20 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, &
        wtxy     ,tsnoxy   ,zsnsoxy  ,snicexy  ,snliqxy  ,lfmassxy ,rtmassxy , &
        stmassxy ,woodxy   ,stblcpxy ,fastcpxy ,xsaixy   ,lai      ,           &
        grainxy  ,gddxy    ,                                                   &
+       croptype ,cropcat  ,                      &
 !jref:start
        t2mvxy   ,t2mbxy   ,chstarxy,            &
 !jref:end       
        NSOIL, restart,                 &
        allowed_to_read , iopt_run,                         &
+       sf_urban_physics,                         &  ! urban scheme
        ids,ide, jds,jde, kds,kde,                &
        ims,ime, jms,jme, kms,kme,                &
        its,ite, jts,jte, kts,kte,                &
        smoiseq  ,smcwtdxy ,rechxy   ,deeprechxy, areaxy, dx, dy, msftx, msfty,&     ! Optional groundwater
        wtddt    ,stepwtd  ,dt       ,qrfsxy     ,qspringsxy  , qslatxy    ,  &      ! Optional groundwater
-       fdepthxy ,ht     ,riverbedxy ,eqzwt     ,rivercondxy ,pexpxy            )    ! Optional groundwater
+       fdepthxy ,ht     ,riverbedxy ,eqzwt     ,rivercondxy ,pexpxy       ,  &      ! Optional groundwater
+       rechclim                                                             )    ! Optional groundwater
 
   USE NOAHMP_TABLES
 
@@ -1101,6 +1180,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, &
 
     LOGICAL, INTENT(IN)       ::     restart,                    &
          &                           allowed_to_read
+    INTEGER, INTENT(IN)       ::     sf_urban_physics                              ! urban, by yizhou
 
     REAL,    DIMENSION( NSOIL), INTENT(IN)    ::     DZS  ! Thickness of the soil layers [m]
     REAL,    INTENT(IN) , OPTIONAL ::     DX, DY
@@ -1158,6 +1238,9 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, &
     REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: xsaixy      !stem area index
     REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) :: lai         !leaf area index
 
+    INTEGER, DIMENSION(ims:ime,  jms:jme), INTENT(OUT) :: cropcat
+    REAL   , DIMENSION(ims:ime,5,jms:jme), INTENT(IN ) :: croptype
+
 ! IOPT_RUN = 5 option
 
     REAL, DIMENSION(ims:ime,1:nsoil,jms:jme), INTENT(INOUT) , OPTIONAL :: smoiseq !equilibrium soil moisture content [m3m-3]
@@ -1170,10 +1253,11 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, &
     REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: areaxy      !grid cell area [m2]
     REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: FDEPTHXY    !efolding depth for transmissivity (m)
     REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: HT          !terrain height (m)
-    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: RIVERBEDXY  !riverbed depth (m)
-    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: EQZWT       !equilibrium water table depth (m)
-    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: RIVERCONDXY !river conductance
-    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: PEXPXY      !factor for river conductance
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: RIVERBEDXY  !riverbed depth (m)
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT) , OPTIONAL :: EQZWT       !equilibrium water table depth (m)
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT), OPTIONAL :: RIVERCONDXY !river conductance
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(INOUT), OPTIONAL :: PEXPXY      !factor for river conductance
+    REAL, DIMENSION(ims:ime,jms:jme), INTENT(IN) , OPTIONAL :: rechclim
 
     INTEGER,  INTENT(OUT) , OPTIONAL :: STEPWTD
     REAL, INTENT(IN) , OPTIONAL :: DT, WTDDT
@@ -1207,6 +1291,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, &
     call read_mp_soil_parameters()
     call read_mp_rad_parameters()
     call read_mp_global_parameters()
+    call read_mp_crop_parameters()
 
     IF( .NOT. restart ) THEN
 
@@ -1286,7 +1371,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, &
 	      
               BEXP   =   BEXP_TABLE(ISLTYP(I,J))
               SMCMAX = SMCMAX_TABLE(ISLTYP(I,J))
-              PSISAT = PSISAT_TABLE(ISLTYP(I,J))
+              PSISAT = -1.0*PSISAT_TABLE(ISLTYP(I,J))
 
               DO NS=1, NSOIL
 	        IF ( SMOIS(I,NS,J) > SMCMAX )  SMOIS(I,NS,J) = SMCMAX
@@ -1353,7 +1438,8 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, &
              endif
 
            IF(IVGTYP(I,J) == ISBARREN_TABLE .OR. IVGTYP(I,J) == ISICE_TABLE .OR. &
-	      IVGTYP(I,J) == ISURBAN_TABLE  .OR. IVGTYP(I,J) == ISWATER_TABLE ) THEN
+	      ( SF_URBAN_PHYSICS == 0 .AND. IVGTYP(I,J) == ISURBAN_TABLE )  .OR. &
+	      IVGTYP(I,J) == ISWATER_TABLE ) THEN
 	     
 	     lai        (I,J) = 0.0
              xsaixy     (I,J) = 0.0
@@ -1363,6 +1449,9 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, &
              woodxy     (I,J) = 0.0
              stblcpxy   (I,J) = 0.0
              fastcpxy   (I,J) = 0.0
+             grainxy    (I,J) = 1E-10
+             gddxy      (I,J) = 0
+	     cropcat    (I,J) = 0
 
 	   ELSE
 	     
@@ -1376,8 +1465,39 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, &
              woodxy     (I,J) = 500.0                          ! in the table or read from initialization
              stblcpxy   (I,J) = 1000.0                         !
              fastcpxy   (I,J) = 1000.0                         !
-             grainxy    (I,J) = 1E-10         ! add by XING
-             gddxy      (I,J) = 0          ! add by XING
+             grainxy    (I,J) = 1E-10
+             gddxy      (I,J) = 0    
+	     cropcat    (i,j) = default_crop_table
+
+	     if(croptype(i,5,j) >= 0.5) then
+               rtmassxy(i,j) = 0.0
+               woodxy  (i,j) = 0.0                    
+
+	       if(    croptype(i,1,j) > croptype(i,2,j) .and. &
+		      croptype(i,1,j) > croptype(i,3,j) .and. &
+		      croptype(i,1,j) > croptype(i,4,j) ) then   ! choose corn
+
+		   cropcat (i,j) = 1
+                   lfmassxy(i,j) =    lai(i,j)/0.035
+                   stmassxy(i,j) = xsaixy(i,j)/0.003
+
+	       elseif(croptype(i,2,j) > croptype(i,1,j) .and. &
+		      croptype(i,2,j) > croptype(i,3,j) .and. &
+		      croptype(i,2,j) > croptype(i,4,j) ) then   ! choose soybean
+
+		   cropcat (i,j) = 2
+                   lfmassxy(i,j) =    lai(i,j)/0.015
+                   stmassxy(i,j) = xsaixy(i,j)/0.003
+
+	       else
+
+		   cropcat (i,j) = default_crop_table
+                   lfmassxy(i,j) =    lai(i,j)/0.035
+                   stmassxy(i,j) = xsaixy(i,j)/0.003
+
+	       end if
+
+	     end if
 
 	   END IF
 
@@ -1420,7 +1540,8 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, &
             PRESENT(riverbedxy)  .AND. &
             PRESENT(eqzwt)       .AND. &
             PRESENT(rivercondxy) .AND. &
-            PRESENT(pexpxy)            ) THEN
+            PRESENT(pexpxy)      .AND. &
+            PRESENT(rechclim)    ) THEN
 
              STEPWTD = nint(WTDDT*60./DT)
              STEPWTD = max(STEPWTD,1)
@@ -1429,6 +1550,7 @@ SUBROUTINE NOAHMP_INIT ( MMINLU, SNOW , SNOWH , CANWAT , ISLTYP ,   IVGTYP, &
       &       nsoil, zsoil , dzs  ,isltyp, ivgtyp,wtddt , &
       &       fdepthxy, ht, riverbedxy, eqzwt, rivercondxy, pexpxy , areaxy, zwtxy,   &
       &       smois,sh2o, smoiseq, smcwtdxy, deeprechxy, rechxy, qslatxy, qrfsxy, qspringsxy, &
+      &       rechclim  ,                                   &
       &       ids,ide, jds,jde, kds,kde,                    &
       &       ims,ime, jms,jme, kms,kme,                    &
       &       its,ite, jts,jte, kts,kte                     )
@@ -1552,6 +1674,7 @@ SUBROUTINE GROUNDWATER_INIT (   &
             &            FDEPTH, TOPO, RIVERBED, EQWTD, RIVERCOND, PEXP , AREA ,WTD ,  &
             &            SMOIS,SH2O, SMOISEQ, SMCWTDXY, DEEPRECHXY, RECHXY ,  &
             &            QSLATXY, QRFSXY, QSPRINGSXY,                  &
+            &            rechclim  ,                                   &
             &            ids,ide, jds,jde, kds,kde,                    &
             &            ims,ime, jms,jme, kms,kme,                    &
             &            its,ite, jts,jte, kts,kte                     )
@@ -1572,8 +1695,10 @@ SUBROUTINE GROUNDWATER_INIT (   &
     REAL,   INTENT(IN)                               ::     WTDDT
     REAL,    INTENT(IN), DIMENSION(1:NSOIL)          :: ZSOIL,DZS
     INTEGER, INTENT(IN), DIMENSION(ims:ime, jms:jme) :: ISLTYP, IVGTYP
-    REAL,    INTENT(IN), DIMENSION(ims:ime, jms:jme) :: FDEPTH, TOPO, RIVERBED, EQWTD, RIVERCOND, PEXP , AREA
-    REAL,    INTENT(INOUT), DIMENSION(ims:ime, jms:jme) :: WTD
+    REAL,    INTENT(IN), DIMENSION(ims:ime, jms:jme) :: FDEPTH, TOPO , AREA
+    REAL,    INTENT(IN), DIMENSION(ims:ime, jms:jme) :: rechclim 
+    REAL,    INTENT(OUT), DIMENSION(ims:ime, jms:jme) :: RIVERCOND
+    REAL,    INTENT(INOUT), DIMENSION(ims:ime, jms:jme) :: WTD, RIVERBED, EQWTD, PEXP
     REAL,     DIMENSION( ims:ime , 1:nsoil, jms:jme ), &
          &    INTENT(INOUT)   ::                          SMOIS, &
          &                                                 SH2O, &
@@ -1586,10 +1711,10 @@ SUBROUTINE GROUNDWATER_INIT (   &
                                                            QRFSXY, &
                                                            QSPRINGSXY  
 ! local
-    INTEGER  :: I,J,K,ITER,itf,jtf
+    INTEGER  :: I,J,K,ITER,itf,jtf, NITER, NCOUNT
     REAL :: BEXP,SMCMAX,PSISAT,SMCWLT,DWSAT,DKSAT
     REAL :: FRLIQ,SMCEQDEEP
-    REAL :: DELTAT,RCOND
+    REAL :: DELTAT,RCOND,TOTWATER
     REAL :: AA,BBB,CC,DD,DX,FUNC,DFUNC,DDZ,EXPON,SMC,FLUX
     REAL, DIMENSION(1:NSOIL) :: SMCEQ
     REAL,      DIMENSION( ims:ime, jms:jme )    :: QLAT, QRF
@@ -1599,9 +1724,6 @@ SUBROUTINE GROUNDWATER_INIT (   &
        itf=min0(ite,ide-1)
        jtf=min0(jte,jde-1)
 
-!first compute lateral flow and flow to rivers to initialize deep soil moisture
-
-    DELTAT = WTDDT * 60. !timestep in seconds for this calculation
 
     WHERE(IVGTYP.NE.ISWATER_TABLE.AND.IVGTYP.NE.ISICE_TABLE)
          LANDMASK=1
@@ -1609,15 +1731,93 @@ SUBROUTINE GROUNDWATER_INIT (   &
          LANDMASK=-1
     ENDWHERE
     
+    PEXP = 1.0
+
+    DELTAT=365.*24*3600. !1 year
+
+!readjust the raw aggregated water table from hires, so that it is better compatible with topography
+
+ DO NITER=1,500
+
+    NCOUNT=0
+
 !Calculate lateral flow
 
     QLAT = 0.
-CALL LATERALFLOW(ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA       &
+    CALL LATERALFLOW(ISLTYP,EQWTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA       &
                         ,ids,ide,jds,jde,kds,kde                      & 
                         ,ims,ime,jms,jme,kms,kme                      &
                         ,its,ite,jts,jte,kts,kte                      )
-                        
 
+    DO J=jts,jtf
+       DO I=its,itf
+          IF(LANDMASK(I,J).GT.0)THEN
+            IF(QLAT(i,j).GT.1.e-2)THEN
+                 NCOUNT=NCOUNT+1
+                 EQWTD(i,j)=min(EQWTD(i,j)+0.25,0.)
+            ENDIF
+          ENDIF
+        ENDDO
+     ENDDO
+
+   IF(NCOUNT.EQ.0)EXIT
+
+ ENDDO
+
+!after adjusting, where qlat > 1cm/year now wtd is at the surface.
+!it may still happen that qlat + rech > 0 and eqwtd-rbed <0. There the wtd can
+!rise to the surface (poor drainage) but the et will then increase.
+
+
+!now, calculate rcond:
+
+    DO J=jts,jtf
+       DO I=its,itf
+
+        DDZ = EQWTD(I,J)- ( RIVERBED(I,J)-TOPO(I,J) )
+!dont allow riverbed above water table
+        IF(DDZ.LT.0.)then
+               RIVERBED(I,J)=TOPO(I,J)+EQWTD(I,J)
+               DDZ=0.
+        ENDIF
+
+
+        TOTWATER = AREA(I,J)*(QLAT(I,J)+RECHCLIM(I,J)*0.001)/DELTAT
+
+        IF (TOTWATER.GT.0) THEN
+              RIVERCOND(I,J) = TOTWATER / MAX(DDZ,0.05)
+        ELSE
+              RIVERCOND(I,J)=0.01
+!and make riverbed  equal to eqwtd, otherwise qrf might be too big...
+              RIVERBED(I,J)=TOPO(I,J)+EQWTD(I,J)
+        ENDIF
+
+
+       ENDDO
+    ENDDO
+
+!make riverbed to be height down from the surface instead of above sea level
+
+    RIVERBED = min( RIVERBED-TOPO, 0.)
+
+!now inititalize wtd
+
+    WTD = EQWTD
+
+
+!now recompute lateral flow and flow to rivers to initialize deep soil moisture
+
+    DELTAT = WTDDT * 60. !timestep in seconds for this calculation
+
+
+!recalculate lateral flow
+
+    QLAT = 0.
+    CALL LATERALFLOW(ISLTYP,WTD,QLAT,FDEPTH,TOPO,LANDMASK,DELTAT,AREA       &
+                        ,ids,ide,jds,jde,kds,kde                      & 
+                        ,ims,ime,jms,jme,kms,kme                      &
+                        ,its,ite,jts,jte,kts,kte                      )
+                        
 !compute flux from grounwater to rivers in the cell
 
     DO J=jts,jtf
@@ -1787,6 +1987,737 @@ SUBROUTINE EQSMOISTURE(NSOIL  ,  ZSOIL , SMCMAX , SMCWLT, DWSAT , DKSAT ,BEXP ,
 END  SUBROUTINE EQSMOISTURE
 !
 !------------------------------------------------------------------------------------------
+  SUBROUTINE noahmp_urban(sf_urban_physics,   NSOIL,         IVGTYP,  ITIMESTEP,            & ! IN : Model configuration 
+                                 DT,     COSZ_URB2D,     XLAT_URB2D,                        & ! IN : Time/Space-related
+                                T3D,           QV3D,          U_PHY,      V_PHY,   SWDOWN,  & ! IN : Forcing
+		                GLW,          P8W3D,         RAINBL,       DZ8W,      ZNT,  & ! IN : Forcing
+                                TSK,            HFX,            QFX,         LH,   GRDFLX,  & ! IN/OUT : LSM 
+		             ALBEDO,          EMISS,           QSFC,                        & ! IN/OUT : LSM 
+                            ids,ide,        jds,jde,        kds,kde,                        &
+                            ims,ime,        jms,jme,        kms,kme,                        &
+                            its,ite,        jts,jte,        kts,kte,                        &
+                         cmr_sfcdif,     chr_sfcdif,     cmc_sfcdif,                        &
+	                 chc_sfcdif,    cmgr_sfcdif,    chgr_sfcdif,                        &
+                           tr_urb2d,       tb_urb2d,       tg_urb2d,                        & !H urban
+	                   tc_urb2d,       qc_urb2d,       uc_urb2d,                        & !H urban
+                         xxxr_urb2d,     xxxb_urb2d,     xxxg_urb2d, xxxc_urb2d,            & !H urban
+                          trl_urb3d,      tbl_urb3d,      tgl_urb3d,                        & !H urban
+                           sh_urb2d,       lh_urb2d,        g_urb2d,   rn_urb2d,  ts_urb2d, & !H urban
+                         psim_urb2d,     psih_urb2d,      u10_urb2d,  v10_urb2d,            & !O urban
+                       GZ1OZ0_urb2d,     AKMS_URB2D,                                        & !O urban
+                          th2_urb2d,       q2_urb2d,      ust_urb2d,                        & !O urban
+                         declin_urb,      omg_urb2d,                                        & !I urban
+                    num_roof_layers,num_wall_layers,num_road_layers,                        & !I urban
+                                dzr,            dzb,            dzg,                        & !I urban
+                         cmcr_urb2d,      tgr_urb2d,     tgrl_urb3d,  smr_urb3d,            & !H urban
+                        drelr_urb2d,    drelb_urb2d,    drelg_urb2d,                        & !H urban
+                      flxhumr_urb2d,  flxhumb_urb2d,  flxhumg_urb2d,                        & !H urban
+                             julian,          julyr,                                        & !H urban
+                          frc_urb2d,    utype_urb2d,                                        & !I urban
+                                chs,           chs2,           cqs2,                        & !H
+                   num_urban_layers,                                                        & !I multi-layer urban
+                       num_urban_hi,                                                        & !I multi-layer urban
+                          trb_urb4d,      tw1_urb4d,      tw2_urb4d,  tgb_urb4d,            & !H multi-layer urban
+                         tlev_urb3d,     qlev_urb3d,                                        & !H multi-layer urban
+                       tw1lev_urb3d,   tw2lev_urb3d,                                        & !H multi-layer urban
+                        tglev_urb3d,    tflev_urb3d,                                        & !H multi-layer urban
+                        sf_ac_urb3d,    lf_ac_urb3d,    cm_ac_urb3d,                        & !H multi-layer urban
+                       sfvent_urb3d,   lfvent_urb3d,                                        & !H multi-layer urban
+                       sfwin1_urb3d,   sfwin2_urb3d,                                        & !H multi-layer urban
+                         sfw1_urb3d,     sfw2_urb3d,      sfr_urb3d,  sfg_urb3d,            & !H multi-layer urban
+                           lp_urb2d,       hi_urb2d,       lb_urb2d,  hgt_urb2d,            & !H multi-layer urban
+                           mh_urb2d,     stdh_urb2d,       lf_urb2d,                        & !SLUCM
+                             th_phy,            rho,          p_phy,        ust,            & !I multi-layer urban
+                                gmt,         julday,          xlong,       xlat,            & !I multi-layer urban
+                            a_u_bep,        a_v_bep,        a_t_bep,    a_q_bep,            & !O multi-layer urban
+                            a_e_bep,        b_u_bep,        b_v_bep,                        & !O multi-layer urban
+                            b_t_bep,        b_q_bep,        b_e_bep,    dlg_bep,            & !O multi-layer urban
+                           dl_u_bep,         sf_bep,         vl_bep                         & !O multi-layer urban
+                 )
+
+  USE module_sf_urban,    only: urban
+  USE module_sf_bep,      only: bep
+  USE module_sf_bep_bem,  only: bep_bem
+  USE module_ra_gfdleta,  only: cal_mon_day
+  USE NOAHMP_TABLES, ONLY: ISURBAN_TABLE
+  USE module_model_constants, only: KARMAN, CP, XLV
+!----------------------------------------------------------------
+    IMPLICIT NONE
+!----------------------------------------------------------------
+
+    INTEGER,                                         INTENT(IN   ) ::  sf_urban_physics   ! urban physics option
+    INTEGER,                                         INTENT(IN   ) ::  NSOIL     ! number of soil layers
+    INTEGER, DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  IVGTYP    ! vegetation type
+    INTEGER,                                         INTENT(IN   ) ::  ITIMESTEP ! timestep number
+    REAL,                                            INTENT(IN   ) ::  DT        ! timestep [s]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  COSZ_URB2D
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  XLAT_URB2D
+    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::  T3D       ! 3D atmospheric temperature valid at mid-levels [K]
+    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::  QV3D      ! 3D water vapor mixing ratio [kg/kg_dry]
+    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::  U_PHY     ! 3D U wind component [m/s]
+    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::  V_PHY     ! 3D V wind component [m/s]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  SWDOWN    ! solar down at surface [W m-2]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  GLW       ! longwave down at surface [W m-2]
+    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::  P8W3D     ! 3D pressure, valid at interface [Pa]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(IN   ) ::  RAINBL    ! total input precipitation [mm]
+    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) ::  DZ8W      ! thickness of atmo layers [m]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  ZNT       ! combined z0 sent to coupled model
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  TSK       ! surface radiative temperature [K]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  HFX       ! sensible heat flux [W m-2]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  QFX       ! latent heat flux [kg s-1 m-2]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  LH        ! latent heat flux [W m-2]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  GRDFLX    ! ground/snow heat flux [W m-2]
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  ALBEDO    ! total grid albedo []
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  EMISS     ! surface bulk emissivity
+    REAL,    DIMENSION( ims:ime,          jms:jme ), INTENT(INOUT) ::  QSFC      ! bulk surface mixing ratio
+
+    INTEGER,  INTENT(IN   )   ::     ids,ide, jds,jde, kds,kde,  &  ! d -> domain
+         &                           ims,ime, jms,jme, kms,kme,  &  ! m -> memory
+         &                           its,ite, jts,jte, kts,kte      ! t -> tile
+
+! input variables surface_driver --> lsm
+
+     INTEGER,                                                INTENT(IN   ) :: num_roof_layers
+     INTEGER,                                                INTENT(IN   ) :: num_wall_layers
+     INTEGER,                                                INTENT(IN   ) :: num_road_layers
+
+     INTEGER,        DIMENSION( ims:ime, jms:jme ),          INTENT(IN   ) :: UTYPE_URB2D
+     REAL,           DIMENSION( ims:ime, jms:jme ),          INTENT(IN   ) :: FRC_URB2D
+
+     REAL, OPTIONAL, DIMENSION(1:num_roof_layers),           INTENT(IN   ) :: DZR
+     REAL, OPTIONAL, DIMENSION(1:num_wall_layers),           INTENT(IN   ) :: DZB
+     REAL, OPTIONAL, DIMENSION(1:num_road_layers),           INTENT(IN   ) :: DZG
+     REAL, OPTIONAL,                                         INTENT(IN   ) :: DECLIN_URB
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),          INTENT(IN   ) :: OMG_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) :: TH_PHY
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) :: P_PHY
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN   ) :: RHO
+
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),          INTENT(INOUT) :: UST
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),          INTENT(INOUT) :: CHS, CHS2, CQS2
+
+     INTEGER,  INTENT(IN   )   ::  julian, julyr                  !urban
+
+! local variables lsm --> urban
+
+     INTEGER :: UTYPE_URB ! urban type [urban=1, suburban=2, rural=3]
+     REAL    :: TA_URB       ! potential temp at 1st atmospheric level [K]
+     REAL    :: QA_URB       ! mixing ratio at 1st atmospheric level  [kg/kg]
+     REAL    :: UA_URB       ! wind speed at 1st atmospheric level    [m/s]
+     REAL    :: U1_URB       ! u at 1st atmospheric level             [m/s]
+     REAL    :: V1_URB       ! v at 1st atmospheric level             [m/s]
+     REAL    :: SSG_URB      ! downward total short wave radiation    [W/m/m]
+     REAL    :: LLG_URB      ! downward long wave radiation           [W/m/m]
+     REAL    :: RAIN_URB     ! precipitation                          [mm/h]
+     REAL    :: RHOO_URB     ! air density                            [kg/m^3]
+     REAL    :: ZA_URB       ! first atmospheric level                [m]
+     REAL    :: DELT_URB     ! time step                              [s]
+     REAL    :: SSGD_URB     ! downward direct short wave radiation   [W/m/m]
+     REAL    :: SSGQ_URB     ! downward diffuse short wave radiation  [W/m/m]
+     REAL    :: XLAT_URB     ! latitude                               [deg]
+     REAL    :: COSZ_URB     ! cosz
+     REAL    :: OMG_URB      ! hour angle
+     REAL    :: ZNT_URB      ! roughness length                       [m]
+     REAL    :: TR_URB
+     REAL    :: TB_URB
+     REAL    :: TG_URB
+     REAL    :: TC_URB
+     REAL    :: QC_URB
+     REAL    :: UC_URB
+     REAL    :: XXXR_URB
+     REAL    :: XXXB_URB
+     REAL    :: XXXG_URB
+     REAL    :: XXXC_URB
+     REAL, DIMENSION(1:num_roof_layers) :: TRL_URB  ! roof layer temp [K]
+     REAL, DIMENSION(1:num_wall_layers) :: TBL_URB  ! wall layer temp [K]
+     REAL, DIMENSION(1:num_road_layers) :: TGL_URB  ! road layer temp [K]
+     LOGICAL  :: LSOLAR_URB
+
+!===hydrological variable for single layer UCM===
+
+     INTEGER :: jmonth, jday
+     REAL    :: DRELR_URB
+     REAL    :: DRELB_URB
+     REAL    :: DRELG_URB
+     REAL    :: FLXHUMR_URB
+     REAL    :: FLXHUMB_URB
+     REAL    :: FLXHUMG_URB
+     REAL    :: CMCR_URB
+     REAL    :: TGR_URB
+
+     REAL, DIMENSION(1:num_roof_layers) :: SMR_URB  ! green roof layer moisture
+     REAL, DIMENSION(1:num_roof_layers) :: TGRL_URB ! green roof layer temp [K]
+
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                    INTENT(INOUT) :: DRELR_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                    INTENT(INOUT) :: DRELB_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                    INTENT(INOUT) :: DRELG_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                    INTENT(INOUT) :: FLXHUMR_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                    INTENT(INOUT) :: FLXHUMB_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                    INTENT(INOUT) :: FLXHUMG_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                    INTENT(INOUT) :: CMCR_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                    INTENT(INOUT) :: TGR_URB2D
+
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TGRL_URB3D
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: SMR_URB3D
+
+
+! state variable surface_driver <--> lsm <--> urban
+
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TR_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TB_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TG_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TC_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: QC_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: UC_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXR_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXB_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXG_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: XXXC_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: SH_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: LH_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: G_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: RN_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(INOUT) :: TS_URB2D
+
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_roof_layers, jms:jme ), INTENT(INOUT) :: TRL_URB3D
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_wall_layers, jms:jme ), INTENT(INOUT) :: TBL_URB3D
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_road_layers, jms:jme ), INTENT(INOUT) :: TGL_URB3D
+
+! output variable lsm --> surface_driver
+
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIM_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: PSIH_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: GZ1OZ0_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: U10_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: V10_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: TH2_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: Q2_URB2D
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: AKMS_URB2D
+     REAL,           DIMENSION( ims:ime, jms:jme ), INTENT(OUT) :: UST_URB2D
+
+
+! output variables urban --> lsm
+
+     REAL :: TS_URB           ! surface radiative temperature    [K]
+     REAL :: QS_URB           ! surface humidity                 [-]
+     REAL :: SH_URB           ! sensible heat flux               [W/m/m]
+     REAL :: LH_URB           ! latent heat flux                 [W/m/m]
+     REAL :: LH_KINEMATIC_URB ! latent heat flux, kinetic  [kg/m/m/s]
+     REAL :: SW_URB           ! upward short wave radiation flux [W/m/m]
+     REAL :: ALB_URB          ! time-varying albedo            [fraction]
+     REAL :: LW_URB           ! upward long wave radiation flux  [W/m/m]
+     REAL :: G_URB            ! heat flux into the ground        [W/m/m]
+     REAL :: RN_URB           ! net radiation                    [W/m/m]
+     REAL :: PSIM_URB         ! shear f for momentum             [-]
+     REAL :: PSIH_URB         ! shear f for heat                 [-]
+     REAL :: GZ1OZ0_URB       ! shear f for heat                 [-]
+     REAL :: U10_URB          ! wind u component at 10 m         [m/s]
+     REAL :: V10_URB          ! wind v component at 10 m         [m/s]
+     REAL :: TH2_URB          ! potential temperature at 2 m     [K]
+     REAL :: Q2_URB           ! humidity at 2 m                  [-]
+     REAL :: CHS_URB
+     REAL :: CHS2_URB
+     REAL :: UST_URB
+
+! NUDAPT Parameters urban --> lam
+
+     REAL :: mh_urb
+     REAL :: stdh_urb
+     REAL :: lp_urb
+     REAL :: hgt_urb
+     REAL, DIMENSION(4) :: lf_urb
+
+! Local variables
+
+     INTEGER :: I,J,K
+     REAL :: Q1
+
+! Noah UA changes
+
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(INOUT) :: CMR_SFCDIF
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(INOUT) :: CHR_SFCDIF
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(INOUT) :: CMGR_SFCDIF
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(INOUT) :: CHGR_SFCDIF
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(INOUT) :: CMC_SFCDIF
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(INOUT) :: CHC_SFCDIF
+
+! Variables for multi-layer UCM
+
+     REAL, OPTIONAL,                                                    INTENT(IN   ) :: GMT
+     INTEGER, OPTIONAL,                                                 INTENT(IN   ) :: JULDAY
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(IN   ) :: XLAT, XLONG
+     INTEGER,                                                           INTENT(IN   ) :: NUM_URBAN_LAYERS
+     INTEGER,                                                           INTENT(IN   ) :: NUM_URBAN_HI
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_hi, jms:jme ),     INTENT(IN   ) :: hi_urb2d
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(IN   ) :: lp_urb2d
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(IN   ) :: lb_urb2d
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(IN   ) :: hgt_urb2d
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(IN   ) :: mh_urb2d
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(IN   ) :: stdh_urb2d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 4, jms:jme ),                  INTENT(IN   ) :: lf_urb2d
+
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: trb_urb4d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1_urb4d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2_urb4d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tgb_urb4d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tlev_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: qlev_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw1lev_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tw2lev_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tglev_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: tflev_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(INOUT) :: lf_ac_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(INOUT) :: sf_ac_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(INOUT) :: cm_ac_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(INOUT) :: sfvent_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, jms:jme ),                     INTENT(INOUT) :: lfvent_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin1_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfwin2_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw1_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfw2_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfr_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, 1:num_urban_layers, jms:jme ), INTENT(INOUT) :: sfg_urb3d
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: a_u_bep   !Implicit momemtum component X-direction
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: a_v_bep   !Implicit momemtum component Y-direction
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: a_t_bep   !Implicit component pot. temperature
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: a_q_bep   !Implicit momemtum component X-direction
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: a_e_bep   !Implicit component TKE
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: b_u_bep   !Explicit momentum component X-direction
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: b_v_bep   !Explicit momentum component Y-direction
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: b_t_bep   !Explicit component pot. temperature
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: b_q_bep   !Implicit momemtum component Y-direction
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: b_e_bep   !Explicit component TKE
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: vl_bep    !Fraction air volume in grid cell
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: dlg_bep   !Height above ground
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: sf_bep    !Fraction air at the face of grid cell
+     REAL, OPTIONAL, DIMENSION( ims:ime, kms:kme, jms:jme ),            INTENT(INOUT) :: dl_u_bep  !Length scale
+
+! Local variables for multi-layer UCM
+
+     REAL,    DIMENSION( its:ite, jts:jte) :: HFX_RURAL,GRDFLX_RURAL          ! ,LH_RURAL,RN_RURAL
+     REAL,    DIMENSION( its:ite, jts:jte) :: QFX_RURAL                       ! ,QSFC_RURAL,UMOM_RURAL,VMOM_RURAL
+     REAL,    DIMENSION( its:ite, jts:jte) :: ALB_RURAL,EMISS_RURAL,TSK_RURAL ! ,UST_RURAL
+     REAL,    DIMENSION( its:ite, jts:jte) :: HFX_URB,UMOM_URB,VMOM_URB
+     REAL,    DIMENSION( its:ite, jts:jte) :: QFX_URB
+     REAL,    DIMENSION( its:ite, jts:jte) :: EMISS_URB
+     REAL,    DIMENSION( its:ite, jts:jte) :: RL_UP_URB
+     REAL,    DIMENSION( its:ite, jts:jte) :: RS_ABS_URB
+     REAL,    DIMENSION( its:ite, jts:jte) :: GRDFLX_URB
+
+     REAL :: SIGMA_SB,RL_UP_RURAL,RL_UP_TOT,RS_ABS_TOT,UMOM,VMOM
+     REAL :: r1,r2,r3
+     REAL :: CMR_URB, CHR_URB, CMC_URB, CHC_URB, CMGR_URB, CHGR_URB
+     REAL :: frc_urb,lb_urb
+     REAL :: check
+
+    character(len=80) :: message
+
+    DO J=JTS,JTE
+    DO I=ITS,ITE
+      HFX_RURAL(I,J)                = HFX(I,J)
+      QFX_RURAL(I,J)                = QFX(I,J)
+      GRDFLX_RURAL(I,J)             = GRDFLX(I,J)
+      EMISS_RURAL(I,J)              = EMISS(I,J)
+      TSK_RURAL(I,J)                = TSK(I,J)
+      ALB_RURAL(I,J)                = ALBEDO(I,J)
+    END DO
+    END DO
+
+IF (SF_URBAN_PHYSICS == 1 ) THEN         ! Beginning of UCM CALL if block
+
+!--------------------------------------
+! URBAN CANOPY MODEL START
+!--------------------------------------
+
+JLOOP : DO J = jts, jte
+
+ILOOP : DO I = its, ite
+
+
+  IF( IVGTYP(I,J) == ISURBAN_TABLE .or. IVGTYP(I,J) == 31 .or. &
+      IVGTYP(I,J) == 32 .or. IVGTYP(I,J) == 33 ) THEN
+
+    UTYPE_URB = UTYPE_URB2D(I,J) !urban type (low, high or industrial)
+
+    TA_URB    = T3D(I,1,J)                                ! [K]            
+    QA_URB    = QV3D(I,1,J)/(1.0+QV3D(I,1,J))             ! [kg/kg]       
+    UA_URB    = SQRT(U_PHY(I,1,J)**2.+V_PHY(I,1,J)**2.)
+    U1_URB    = U_PHY(I,1,J)
+    V1_URB    = V_PHY(I,1,J)
+    IF(UA_URB < 1.) UA_URB=1.                             ! [m/s]
+    SSG_URB   = SWDOWN(I,J)                               ! [W/m/m]      
+    SSGD_URB  = 0.8*SWDOWN(I,J)                           ! [W/m/m]     
+    SSGQ_URB  = SSG_URB-SSGD_URB                          ! [W/m/m]
+    LLG_URB   = GLW(I,J)                                  ! [W/m/m]
+    RAIN_URB  = RAINBL(I,J)                               ! [mm]       
+    RHOO_URB  = (P8W3D(I,KTS+1,J)+P8W3D(I,KTS,J))*0.5 / (287.04 * TA_URB * (1.0+ 0.61 * QA_URB)) ![kg/m/m/m] 
+    ZA_URB    = 0.5*DZ8W(I,1,J)                           ! [m]         
+    DELT_URB  = DT                                        ! [sec]
+    XLAT_URB  = XLAT_URB2D(I,J)                           ! [deg]
+    COSZ_URB  = COSZ_URB2D(I,J) 
+    OMG_URB   = OMG_URB2D(I,J)
+    ZNT_URB   = ZNT(I,J)
+
+    LSOLAR_URB = .FALSE.
+
+    TR_URB = TR_URB2D(I,J)
+    TB_URB = TB_URB2D(I,J)
+    TG_URB = TG_URB2D(I,J)
+    TC_URB = TC_URB2D(I,J)
+    QC_URB = QC_URB2D(I,J)
+    UC_URB = UC_URB2D(I,J)
+
+    TGR_URB     = TGR_URB2D(I,J)
+    CMCR_URB    = CMCR_URB2D(I,J)
+    FLXHUMR_URB = FLXHUMR_URB2D(I,J)
+    FLXHUMB_URB = FLXHUMB_URB2D(I,J)
+    FLXHUMG_URB = FLXHUMG_URB2D(I,J)
+    DRELR_URB   = DRELR_URB2D(I,J)
+    DRELB_URB   = DRELB_URB2D(I,J)
+    DRELG_URB   = DRELG_URB2D(I,J)
+
+    DO K = 1,num_roof_layers
+      TRL_URB(K) = TRL_URB3D(I,K,J)
+      SMR_URB(K) = SMR_URB3D(I,K,J)
+      TGRL_URB(K)= TGRL_URB3D(I,K,J)
+    END DO
+
+    DO K = 1,num_wall_layers
+      TBL_URB(K) = TBL_URB3D(I,K,J)
+    END DO
+
+    DO K = 1,num_road_layers
+      TGL_URB(K) = TGL_URB3D(I,K,J)
+    END DO
+
+    XXXR_URB = XXXR_URB2D(I,J)
+    XXXB_URB = XXXB_URB2D(I,J)
+    XXXG_URB = XXXG_URB2D(I,J)
+    XXXC_URB = XXXC_URB2D(I,J)
+
+! Limits to avoid dividing by small number
+    IF (CHS(I,J) < 1.0E-02) THEN
+      CHS(I,J)  = 1.0E-02
+    ENDIF
+    IF (CHS2(I,J) < 1.0E-02) THEN
+      CHS2(I,J)  = 1.0E-02
+    ENDIF
+    IF (CQS2(I,J) < 1.0E-02) THEN
+      CQS2(I,J)  = 1.0E-02
+    ENDIF
+
+    CHS_URB  = CHS(I,J)
+    CHS2(I,J)= CQS2(I,J)      
+    CHS2_URB = CHS2(I,J)
+    IF (PRESENT(CMR_SFCDIF)) THEN
+      CMR_URB = CMR_SFCDIF(I,J)
+      CHR_URB = CHR_SFCDIF(I,J)
+      CMGR_URB = CMGR_SFCDIF(I,J)
+      CHGR_URB = CHGR_SFCDIF(I,J)
+      CMC_URB = CMC_SFCDIF(I,J)
+      CHC_URB = CHC_SFCDIF(I,J)
+    ENDIF
+
+! NUDAPT for SLUCM
+
+    MH_URB   = MH_URB2D(I,J)
+    STDH_URB = STDH_URB2D(I,J)
+    LP_URB   = LP_URB2D(I,J)
+    HGT_URB  = HGT_URB2D(I,J)
+    LF_URB   = 0.0
+    DO K = 1,4
+      LF_URB(K) = LF_URB2D(I,K,J)
+    ENDDO
+    FRC_URB  = FRC_URB2D(I,J)
+    LB_URB   = LB_URB2D(I,J)
+    CHECK    = 0
+    IF (I.EQ.73.AND.J.EQ.125)THEN
+      CHECK = 1
+    END IF
+
+! Call urban
+
+    CALL cal_mon_day(julian,julyr,jmonth,jday)
+    CALL urban(LSOLAR_URB,                                                             & ! I
+          num_roof_layers, num_wall_layers, num_road_layers,                           & ! C
+                DZR,        DZB,        DZG, & ! C
+          UTYPE_URB,     TA_URB,     QA_URB,     UA_URB,   U1_URB,  V1_URB, SSG_URB,   & ! I
+           SSGD_URB,   SSGQ_URB,    LLG_URB,   RAIN_URB, RHOO_URB,                     & ! I
+             ZA_URB, DECLIN_URB,   COSZ_URB,    OMG_URB,                               & ! I
+           XLAT_URB,   DELT_URB,    ZNT_URB,                                           & ! I
+            CHS_URB,   CHS2_URB,                                                       & ! I
+             TR_URB,     TB_URB,     TG_URB,     TC_URB,   QC_URB,   UC_URB,           & ! H
+            TRL_URB,    TBL_URB,    TGL_URB,                                           & ! H
+           XXXR_URB,   XXXB_URB,   XXXG_URB,   XXXC_URB,                               & ! H
+             TS_URB,     QS_URB,     SH_URB,     LH_URB, LH_KINEMATIC_URB,             & ! O
+             SW_URB,    ALB_URB,     LW_URB,      G_URB,   RN_URB, PSIM_URB, PSIH_URB, & ! O
+         GZ1OZ0_URB,                                                                   & !O
+            CMR_URB,    CHR_URB,    CMC_URB,    CHC_URB,                               &
+            U10_URB,    V10_URB,    TH2_URB,     Q2_URB,                               & ! O
+            UST_URB,     mh_urb,   stdh_urb,     lf_urb,   lp_urb,                     & ! 0
+            hgt_urb,    frc_urb,     lb_urb,      check, CMCR_URB,TGR_URB,             & ! H
+           TGRL_URB,    SMR_URB,   CMGR_URB,   CHGR_URB,   jmonth,                     & ! H
+          DRELR_URB,  DRELB_URB,                                                       & ! H
+          DRELG_URB,FLXHUMR_URB,FLXHUMB_URB,FLXHUMG_URB )
+
+    TS_URB2D(I,J) = TS_URB
+
+    ALBEDO(I,J)   = FRC_URB2D(I,J) * ALB_URB + (1-FRC_URB2D(I,J)) * ALBEDO(I,J)        ![-]      
+    HFX(I,J)      = FRC_URB2D(I,J) * SH_URB  + (1-FRC_URB2D(I,J)) * HFX(I,J)           ![W/m/m] 
+    QFX(I,J)      = FRC_URB2D(I,J) * LH_KINEMATIC_URB &
+                       + (1-FRC_URB2D(I,J))* QFX(I,J)                                  ![kg/m/m/s] 
+    LH(I,J)       = FRC_URB2D(I,J) * LH_URB  + (1-FRC_URB2D(I,J)) * LH(I,J)            ![W/m/m]   
+    GRDFLX(I,J)   = FRC_URB2D(I,J) * (G_URB) + (1-FRC_URB2D(I,J)) * GRDFLX(I,J)        ![W/m/m]  
+    TSK(I,J)      = FRC_URB2D(I,J) * TS_URB  + (1-FRC_URB2D(I,J)) * TSK(I,J)           ![K]    
+!    Q1            = QSFC(I,J)/(1.0+QSFC(I,J))                                         
+!    Q1            = FRC_URB2D(I,J) * QS_URB  + (1-FRC_URB2D(I,J)) * Q1                 ![-]
+
+! Convert QSFC back to mixing ratio
+
+!    QSFC(I,J)     = Q1/(1.0-Q1)
+                   QSFC(I,J)= FRC_URB2D(I,J)*QS_URB+(1-FRC_URB2D(I,J))*QSFC(I,J)               !!   QSFC(I,J)=QSFC1D
+    UST(I,J)      = FRC_URB2D(I,J) * UST_URB + (1-FRC_URB2D(I,J)) * UST(I,J)     ![m/s]
+
+! Renew Urban State Variables
+
+    TR_URB2D(I,J) = TR_URB
+    TB_URB2D(I,J) = TB_URB
+    TG_URB2D(I,J) = TG_URB
+    TC_URB2D(I,J) = TC_URB
+    QC_URB2D(I,J) = QC_URB
+    UC_URB2D(I,J) = UC_URB
+
+    TGR_URB2D(I,J)     = TGR_URB
+    CMCR_URB2D(I,J)    = CMCR_URB
+    FLXHUMR_URB2D(I,J) = FLXHUMR_URB
+    FLXHUMB_URB2D(I,J) = FLXHUMB_URB
+    FLXHUMG_URB2D(I,J) = FLXHUMG_URB
+    DRELR_URB2D(I,J)   = DRELR_URB
+    DRELB_URB2D(I,J)   = DRELB_URB
+    DRELG_URB2D(I,J)   = DRELG_URB
+
+    DO K = 1,num_roof_layers
+      TRL_URB3D(I,K,J) = TRL_URB(K)
+      SMR_URB3D(I,K,J) = SMR_URB(K)
+      TGRL_URB3D(I,K,J)= TGRL_URB(K)
+    END DO
+    DO K = 1,num_wall_layers
+      TBL_URB3D(I,K,J) = TBL_URB(K)
+    END DO
+    DO K = 1,num_road_layers
+      TGL_URB3D(I,K,J) = TGL_URB(K)
+    END DO
+
+    XXXR_URB2D(I,J)    = XXXR_URB
+    XXXB_URB2D(I,J)    = XXXB_URB
+    XXXG_URB2D(I,J)    = XXXG_URB
+    XXXC_URB2D(I,J)    = XXXC_URB
+
+    SH_URB2D(I,J)      = SH_URB
+    LH_URB2D(I,J)      = LH_URB
+    G_URB2D(I,J)       = G_URB         
+    RN_URB2D(I,J)      = RN_URB
+    PSIM_URB2D(I,J)    = PSIM_URB
+    PSIH_URB2D(I,J)    = PSIH_URB
+    GZ1OZ0_URB2D(I,J)  = GZ1OZ0_URB
+    U10_URB2D(I,J)     = U10_URB
+    V10_URB2D(I,J)     = V10_URB
+    TH2_URB2D(I,J)     = TH2_URB
+    Q2_URB2D(I,J)      = Q2_URB
+    UST_URB2D(I,J)     = UST_URB
+    AKMS_URB2D(I,J)    = KARMAN * UST_URB2D(I,J)/(GZ1OZ0_URB2D(I,J)-PSIM_URB2D(I,J))
+    IF (PRESENT(CMR_SFCDIF)) THEN
+      CMR_SFCDIF(I,J)  = CMR_URB
+      CHR_SFCDIF(I,J)  = CHR_URB
+      CMGR_SFCDIF(I,J) = CMGR_URB
+      CHGR_SFCDIF(I,J) = CHGR_URB
+      CMC_SFCDIF(I,J)  = CMC_URB
+      CHC_SFCDIF(I,J)  = CHC_URB
+    ENDIF
+
+  ENDIF                                 ! urban land used type block
+
+ENDDO ILOOP                             ! of I loop
+ENDDO JLOOP                             ! of J loop
+
+ENDIF                                   ! sf_urban_physics = 1 block
+
+!--------------------------------------
+! URBAN CANOPY MODEL END
+!--------------------------------------
+
+!--------------------------------------
+! URBAN BEP and BEM MODEL BEGIN
+!--------------------------------------
+
+IF (SF_URBAN_PHYSICS == 2) THEN
+
+DO J=JTS,JTE
+DO I=ITS,ITE
+
+  EMISS_URB(I,J)       = 0.
+  RL_UP_URB(I,J)       = 0.
+  RS_ABS_URB(I,J)      = 0.
+  GRDFLX_URB(I,J)      = 0.
+  B_Q_BEP(I,KTS:KTE,J) = 0.
+
+END DO
+END DO
+
+  CALL BEP(frc_urb2d,  utype_urb2d, itimestep,       dz8w,         &
+                  dt,        u_phy,     v_phy,                     &
+              th_phy,          rho,     p_phy,     swdown,    glw, &
+                 gmt,       julday,     xlong,       xlat,         &
+          declin_urb,   cosz_urb2d, omg_urb2d,                     &
+    num_urban_layers, num_urban_hi,                                &
+           trb_urb4d,    tw1_urb4d, tw2_urb4d,  tgb_urb4d,         &
+          sfw1_urb3d,   sfw2_urb3d, sfr_urb3d,  sfg_urb3d,         &
+            lp_urb2d,     hi_urb2d,  lb_urb2d,  hgt_urb2d,         &
+             a_u_bep,      a_v_bep,   a_t_bep,                     &
+             a_e_bep,      b_u_bep,   b_v_bep,                     &
+             b_t_bep,      b_e_bep,   b_q_bep,    dlg_bep,         &
+            dl_u_bep,       sf_bep,    vl_bep,                     &
+           rl_up_urb,   rs_abs_urb, emiss_urb, grdflx_urb,         &
+         ids,ide, jds,jde, kds,kde,                                &
+         ims,ime, jms,jme, kms,kme,                                &
+         its,ite, jts,jte, kts,kte )
+
+ENDIF ! SF_URBAN_PHYSICS == 2
+
+IF (SF_URBAN_PHYSICS == 3) THEN
+
+DO J=JTS,JTE
+DO I=ITS,ITE
+
+  EMISS_URB(I,J)       = 0.
+  RL_UP_URB(I,J)       = 0.
+  RS_ABS_URB(I,J)      = 0.
+  GRDFLX_URB(I,J)      = 0.
+  B_Q_BEP(I,KTS:KTE,J) = 0.
+
+END DO
+END DO
+
+  CALL BEP_BEM( frc_urb2d,  utype_urb2d,    itimestep,         dz8w,       &
+                       dt,        u_phy,        v_phy,                     &
+                   th_phy,          rho,        p_phy,       swdown,  glw, &
+                      gmt,       julday,        xlong,         xlat,       &
+               declin_urb,   cosz_urb2d,    omg_urb2d,                     &
+         num_urban_layers, num_urban_hi,                                   &
+                trb_urb4d,    tw1_urb4d,    tw2_urb4d,    tgb_urb4d,       &
+               tlev_urb3d,   qlev_urb3d, tw1lev_urb3d, tw2lev_urb3d,       &
+              tglev_urb3d,  tflev_urb3d,  sf_ac_urb3d,  lf_ac_urb3d,       &
+              cm_ac_urb3d, sfvent_urb3d, lfvent_urb3d,                     &
+             sfwin1_urb3d, sfwin2_urb3d,                                   &
+               sfw1_urb3d,   sfw2_urb3d,    sfr_urb3d,    sfg_urb3d,       &
+                 lp_urb2d,     hi_urb2d,     lb_urb2d,    hgt_urb2d,       &
+                  a_u_bep,      a_v_bep,      a_t_bep,                     &
+                  a_e_bep,      b_u_bep,      b_v_bep,                     &
+                  b_t_bep,      b_e_bep,      b_q_bep,      dlg_bep,       &
+                 dl_u_bep,       sf_bep,       vl_bep,                     &
+                rl_up_urb,   rs_abs_urb,    emiss_urb,   grdflx_urb, qv3d, &
+             ids,ide, jds,jde, kds,kde,                                    &
+             ims,ime, jms,jme, kms,kme,                                    &
+             its,ite, jts,jte, kts,kte )
+
+ENDIF ! SF_URBAN_PHYSICS == 3
+
+IF((SF_URBAN_PHYSICS == 2).OR.(SF_URBAN_PHYSICS == 3))THEN 
+
+  sigma_sb=5.67e-08
+  do j = jts, jte
+  do i = its, ite
+    UMOM_URB(I,J)     = 0.
+    VMOM_URB(I,J)     = 0.
+    HFX_URB(I,J)      = 0.
+    QFX_URB(I,J)      = 0.
+
+    do k=kts,kte
+      a_u_bep(i,k,j) = a_u_bep(i,k,j)*frc_urb2d(i,j)
+      a_v_bep(i,k,j) = a_v_bep(i,k,j)*frc_urb2d(i,j)
+      a_t_bep(i,k,j) = a_t_bep(i,k,j)*frc_urb2d(i,j)
+      a_q_bep(i,k,j) = 0.
+      a_e_bep(i,k,j) = 0.
+      b_u_bep(i,k,j) = b_u_bep(i,k,j)*frc_urb2d(i,j)
+      b_v_bep(i,k,j) = b_v_bep(i,k,j)*frc_urb2d(i,j)
+      b_t_bep(i,k,j) = b_t_bep(i,k,j)*frc_urb2d(i,j)
+      b_q_bep(i,k,j) = b_q_bep(i,k,j)*frc_urb2d(i,j)
+      b_e_bep(i,k,j) = b_e_bep(i,k,j)*frc_urb2d(i,j)
+      HFX_URB(I,J)   = HFX_URB(I,J) + B_T_BEP(I,K,J)*RHO(I,K,J)*CP*DZ8W(I,K,J)*VL_BEP(I,K,J)
+      QFX_URB(I,J)   = QFX_URB(I,J) + B_Q_BEP(I,K,J)*DZ8W(I,K,J)*VL_BEP(I,K,J)
+      UMOM_URB(I,J)  = UMOM_URB(I,J)+ (A_U_BEP(I,K,J)*U_PHY(I,K,J)+B_U_BEP(I,K,J))*DZ8W(I,K,J)*VL_BEP(I,K,J)
+      VMOM_URB(I,J)  = VMOM_URB(I,J)+ (A_V_BEP(I,K,J)*V_PHY(I,K,J)+B_V_BEP(I,K,J))*DZ8W(I,K,J)*VL_BEP(I,K,J)
+      vl_bep(i,k,j)  = (1.-frc_urb2d(i,j)) + vl_bep(i,k,j)*frc_urb2d(i,j)
+      sf_bep(i,k,j)  = (1.-frc_urb2d(i,j)) + sf_bep(i,k,j)*frc_urb2d(i,j)
+    end do
+
+    a_u_bep(i,1,j)   = (1.-frc_urb2d(i,j))*(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/   &
+                          ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+a_u_bep(i,1,j)
+
+    a_v_bep(i,1,j)   = (1.-frc_urb2d(i,j))*(-ust(I,J)*ust(I,J))/dz8w(i,1,j)/   &
+                          ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+a_v_bep(i,1,j)
+
+    b_t_bep(i,1,j)   = (1.-frc_urb2d(i,j))*hfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)/CP+ & 
+                           b_t_bep(i,1,j)
+
+    b_q_bep(i,1,j)   = (1.-frc_urb2d(i,j))*qfx_rural(i,j)/dz8w(i,1,j)/rho(i,1,j)+b_q_bep(i,1,j)
+
+    umom             = (1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*u_phy(i,1,j)/               &
+                         ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+umom_urb(i,j)
+
+    vmom             = (1.-frc_urb2d(i,j))*ust(i,j)*ust(i,j)*v_phy(i,1,j)/               &
+                         ((u_phy(i,1,j)**2+v_phy(i,1,j)**2.)**.5)+vmom_urb(i,j)
+    sf_bep(i,1,j)    = 1.
+
+! using the emissivity and the total longwave upward radiation estimate the averaged skin temperature
+
+  IF (FRC_URB2D(I,J).GT.0.) THEN
+    rl_up_rural   = -emiss_rural(i,j)*sigma_sb*(tsk_rural(i,j)**4.)-(1.-emiss_rural(i,j))*glw(i,j)
+    rl_up_tot     = (1.-frc_urb2d(i,j))*rl_up_rural     + frc_urb2d(i,j)*rl_up_urb(i,j)
+    emiss(i,j)    = (1.-frc_urb2d(i,j))*emiss_rural(i,j)+ frc_urb2d(i,j)*emiss_urb(i,j)
+    ts_urb2d(i,j) = (max(0.,(-rl_up_urb(i,j)-(1.-emiss_urb(i,j))*glw(i,j))/emiss_urb(i,j)/sigma_sb))**0.25
+    tsk(i,j)      = (max(0., (-1.*rl_up_tot-(1.-emiss(i,j))*glw(i,j) )/emiss(i,j)/sigma_sb))**.25
+    rs_abs_tot    = (1.-frc_urb2d(i,j))*swdown(i,j)*(1.-albedo(i,j))+frc_urb2d(i,j)*rs_abs_urb(i,j)
+
+    if(swdown(i,j) > 0.)then
+      albedo(i,j) = 1.-rs_abs_tot/swdown(i,j)
+    else
+      albedo(i,j) = alb_rural(i,j)
+    endif
+
+! rename *_urb to sh_urb2d,lh_urb2d,g_urb2d,rn_urb2d
+
+    grdflx(i,j)   = (1.-frc_urb2d(i,j))*grdflx_rural(i,j)+ frc_urb2d(i,j)*grdflx_urb(i,j)
+    qfx(i,j)      = (1.-frc_urb2d(i,j))*qfx_rural(i,j)   + qfx_urb(i,j)
+    lh(i,j)       = qfx(i,j)*xlv
+    hfx(i,j)      = hfx_urb(i,j)                         + (1-frc_urb2d(i,j))*hfx_rural(i,j)      ![W/m/m]
+    sh_urb2d(i,j) = hfx_urb(i,j)/frc_urb2d(i,j)
+    lh_urb2d(i,j) = qfx_urb(i,j)*xlv
+    g_urb2d(i,j)  = grdflx_urb(i,j)
+    rn_urb2d(i,j) = rs_abs_urb(i,j)+emiss_urb(i,j)*glw(i,j)-rl_up_urb(i,j)
+    ust(i,j)      = (umom**2.+vmom**2.)**.25
+
+  ELSE
+
+    sh_urb2d(i,j)    = 0.
+    lh_urb2d(i,j)    = 0.
+    g_urb2d(i,j)     = 0.
+    rn_urb2d(i,j)    = 0.
+
+  ENDIF
+
+  enddo ! jloop
+  enddo ! iloop
+
+ENDIF ! SF_URBAN_PHYSICS == 2 or 3
+
+!--------------------------------------
+! URBAN BEP and BEM MODEL END
+!--------------------------------------
+
+
+END SUBROUTINE noahmp_urban
+
 !------------------------------------------------------------------------------------------
 !
 END MODULE module_sf_noahmpdrv
diff --git a/wrfv2_fire/phys/module_sf_noahmplsm.F b/wrfv2_fire/phys/module_sf_noahmplsm.F
index e97f257f..32a8cd97 100644
--- a/wrfv2_fire/phys/module_sf_noahmplsm.F
+++ b/wrfv2_fire/phys/module_sf_noahmplsm.F
@@ -74,6 +74,7 @@ MODULE MODULE_SF_NOAHMPLSM
                       !   7 -> off (use input LAI; use FVEG = SHDFAC from input)
                       !   8 -> off (use input LAI; calculate FVEG)
                       !   9 -> off (use input LAI; use maximum vegetation fraction)
+                      !  10 -> crop model on (use maximum vegetation fraction)
 
   INTEGER :: OPT_CRS  ! options for canopy stomatal resistance
                       ! **1 -> Ball-Berry
@@ -171,6 +172,7 @@ MODULE MODULE_SF_NOAHMPLSM
     INTEGER :: ISWATER
     INTEGER :: ISBARREN
     INTEGER :: ISICE
+    INTEGER :: ISCROP
     INTEGER :: EBLFOREST
 
     REAL :: CH2OP              !maximum intercepted h2o per unit lai+sai (mm)
@@ -335,7 +337,7 @@ MODULE MODULE_SF_NOAHMPLSM
   SUBROUTINE NOAHMP_SFLX (parameters, &
                    ILOC    , JLOC    , LAT     , YEARLEN , JULIAN  , COSZ    , & ! IN : Time/Space-related
                    DT      , DX      , DZ8W    , NSOIL   , ZSOIL   , NSNOW   , & ! IN : Model configuration 
-                   SHDFAC  , SHDMAX  , VEGTYP  , ICE     , IST     ,           & ! IN : Vegetation/Soil characteristics
+                   SHDFAC  , SHDMAX  , VEGTYP  , ICE     , IST     , CROPTYPE, & ! IN : Vegetation/Soil characteristics
                    SMCEQ   ,                                                   & ! IN : Vegetation/Soil characteristics
                    SFCTMP  , SFCPRS  , PSFC    , UU      , VV      , Q2      , & ! IN : Forcing
                    QC      , SOLDN   , LWDN    ,                               & ! IN : Forcing
@@ -348,7 +350,7 @@ SUBROUTINE NOAHMP_SFLX (parameters, &
                    ZWT     , WA      , WT      , WSLAKE  , LFMASS  , RTMASS  , & ! IN/OUT : 
                    STMASS  , WOOD    , STBLCP  , FASTCP  , LAI     , SAI     , & ! IN/OUT : 
                    CM      , CH      , TAUSS   ,                               & ! IN/OUT : 
-                   GRAIN   , GDD     ,                                         & ! IN/OUT 
+                   GRAIN   , GDD     , PGS     ,                               & ! IN/OUT 
                    SMCWTD  ,DEEPRECH , RECH    ,                               & ! IN/OUT :
 		   Z0WRF   , &
                    FSA     , FSR     , FIRA    , FSH     , SSOIL   , FCEV    , & ! OUT : 
@@ -378,6 +380,7 @@ SUBROUTINE NOAHMP_SFLX (parameters, &
   INTEGER                        , INTENT(IN)    :: ICE    !ice (ice = 1)
   INTEGER                        , INTENT(IN)    :: IST    !surface type 1->soil; 2->lake
   INTEGER                        , INTENT(IN)    :: VEGTYP !vegetation type 
+  INTEGER                        , INTENT(IN)    :: CROPTYPE !crop type 
   INTEGER                        , INTENT(IN)    :: NSNOW  !maximum no. of snow layers        
   INTEGER                        , INTENT(IN)    :: NSOIL  !no. of soil layers        
   INTEGER                        , INTENT(IN)    :: ILOC   !grid index
@@ -583,6 +586,7 @@ SUBROUTINE NOAHMP_SFLX (parameters, &
   REAL                        , INTENT(INOUT)    :: SAI    !stem area index [-]
   REAL                        , INTENT(INOUT)    :: GRAIN  !grain mass [g/m2]
   REAL                        , INTENT(INOUT)    :: GDD    !growing degree days
+  INTEGER                     , INTENT(INOUT)    :: PGS    !plant growing stage [-]
 
 ! outputs
   REAL                          , INTENT(OUT)    :: NEE    !net ecosys exchange (g/m2/s CO2)
@@ -657,8 +661,8 @@ SUBROUTINE NOAHMP_SFLX (parameters, &
 
 ! vegetation phenology
 
-     CALL PHENOLOGY (parameters,VEGTYP , SNOWH  , TV     , LAT   , YEARLEN , JULIAN , & !in
-                     LAI    , SAI    , TROOT  , ELAI    , ESAI   ,IGS)
+     CALL PHENOLOGY (parameters,VEGTYP ,croptype, SNOWH  , TV     , LAT   , YEARLEN , JULIAN , & !in
+                     LAI    , SAI    , TROOT  , ELAI    , ESAI   ,IGS, PGS)
 
 !input GVF should be consistent with LAI
      IF(DVEG == 1 .or. DVEG == 6 .or. DVEG == 7) THEN
@@ -745,7 +749,7 @@ SUBROUTINE NOAHMP_SFLX (parameters, &
 
 ! compute carbon budgets (carbon storages and co2 & bvoc fluxes)
 
-   IF (DVEG == 2 .OR. DVEG == 5 .OR. DVEG == 6) THEN
+   IF (DVEG == 2 .OR. DVEG == 5 .OR. DVEG == 6 .OR. (DVEG == 10 .and. CROPTYPE == 0)) THEN
     CALL CARBON (parameters,NSNOW  ,NSOIL  ,VEGTYP ,DT     ,ZSOIL  , & !in
                  DZSNSO ,STC    ,SMC    ,TV     ,TG     ,PSN    , & !in
                  FOLN   ,BTRAN  ,APAR   ,FVEG   ,IGS    , & !in
@@ -755,13 +759,13 @@ SUBROUTINE NOAHMP_SFLX (parameters, &
                  TOTLB  ,LAI    ,SAI    )                   !out
    END IF
 
-   IF (DVEG == 6) THEN !XING
+   IF (DVEG == 10 .and. CROPTYPE > 0) THEN
     CALL CARBON_CROP (parameters,NSNOW  ,NSOIL  ,VEGTYP ,DT     ,ZSOIL  ,JULIAN , & !in 
                          DZSNSO ,STC    ,SMC    ,TV     ,PSN    ,FOLN   ,BTRAN  , & !in
 			 SOLDN  ,T2M    ,                                         & !in
                          LFMASS ,RTMASS ,STMASS ,WOOD   ,STBLCP ,FASTCP ,GRAIN  , & !inout
 			 LAI    ,SAI    ,GDD    ,                                 & !inout
-                         GPP    ,NPP    ,NEE    ,AUTORS ,HETERS ,TOTSC  ,TOTLB    ) !out
+                         GPP    ,NPP    ,NEE    ,AUTORS ,HETERS ,TOTSC  ,TOTLB, PGS    ) !out
    END IF
    
 
@@ -778,7 +782,7 @@ SUBROUTINE NOAHMP_SFLX (parameters, &
 ! urban - jref
     QFX = ETRAN + ECAN + EDIR
     IF ( parameters%urban_flag ) THEN
-       QSFC = (QFX/RHOAIR*CH) + QAIR
+       QSFC = QFX/(RHOAIR*CH) + QAIR
        Q2B = QSFC
     END IF
 
@@ -944,8 +948,8 @@ END SUBROUTINE ATM
 
 !== begin phenology ================================================================================
 
-  SUBROUTINE PHENOLOGY (parameters,VEGTYP , SNOWH  , TV     , LAT   , YEARLEN , JULIAN , & !in
-                        LAI    , SAI    , TROOT  , ELAI    , ESAI   , IGS)
+  SUBROUTINE PHENOLOGY (parameters,VEGTYP ,croptype, SNOWH  , TV     , LAT   , YEARLEN , JULIAN , & !in
+                        LAI    , SAI    , TROOT  , ELAI    , ESAI   , IGS, PGS)
 
 ! --------------------------------------------------------------------------------------------------
 ! vegetation phenology considering vegeation canopy being buries by snow and evolution in time
@@ -955,6 +959,7 @@ SUBROUTINE PHENOLOGY (parameters,VEGTYP , SNOWH  , TV     , LAT   , YEARLEN , JU
 ! inputs
   type (noahmp_parameters), intent(in) :: parameters
   INTEGER                , INTENT(IN   ) :: VEGTYP !vegetation type 
+  INTEGER                , INTENT(IN   ) :: CROPTYPE !vegetation type 
   REAL                   , INTENT(IN   ) :: SNOWH  !snow height [m]
   REAL                   , INTENT(IN   ) :: TV     !vegetation temperature (k)
   REAL                   , INTENT(IN   ) :: LAT    !latitude (radians)
@@ -968,6 +973,7 @@ SUBROUTINE PHENOLOGY (parameters,VEGTYP , SNOWH  , TV     , LAT   , YEARLEN , JU
   REAL                   , INTENT(OUT  ) :: ELAI   !leaf area index, after burying by snow
   REAL                   , INTENT(OUT  ) :: ESAI   !stem area index, after burying by snow
   REAL                   , INTENT(OUT  ) :: IGS    !growing season index (0=off, 1=on)
+  INTEGER                , INTENT(IN   ) :: PGS    !plant growing stage
 
 ! locals
 
@@ -1010,8 +1016,8 @@ SUBROUTINE PHENOLOGY (parameters,VEGTYP , SNOWH  , TV     , LAT   , YEARLEN , JU
     IF (LAI < 0.05) SAI = 0.0  ! if LAI below minimum, make sure SAI = 0
   ENDIF
 
-  IF (SAI < 0.05 .and. DVEG /= 10) SAI = 0.0                  ! MB: SAI CHECK, change to 0.05 v3.6
-  IF (LAI < 0.05 .OR. SAI == 0.0 .and. DVEG /= 10) LAI = 0.0  ! MB: LAI CHECK
+  IF (SAI < 0.05 .and. CROPTYPE == 0) SAI = 0.0                    ! MB: SAI CHECK, change to 0.05 v3.6
+  IF ((LAI < 0.05 .OR. SAI == 0.0) .and. CROPTYPE == 0) LAI = 0.0  ! MB: LAI CHECK
 
   IF ( ( VEGTYP == parameters%iswater ) .OR. ( VEGTYP == parameters%ISBARREN ) .OR. &
        ( VEGTYP == parameters%ISICE   ) .or. ( parameters%urban_flag ) ) THEN
@@ -1031,10 +1037,10 @@ SUBROUTINE PHENOLOGY (parameters,VEGTYP , SNOWH  , TV     , LAT   , YEARLEN , JU
 
      ELAI =  LAI*(1.-FB)
      ESAI =  SAI*(1.-FB)
-     IF (ESAI < 0.05 .and. DVEG /= 10) ESAI = 0.0                   ! MB: ESAI CHECK, change to 0.05 v3.6
-     IF (ELAI < 0.05 .OR. ESAI == 0.0 .and. DVEG /= 10) ELAI = 0.0  ! MB: LAI CHECK
+     IF (ESAI < 0.05 .and. CROPTYPE == 0) ESAI = 0.0                   ! MB: ESAI CHECK, change to 0.05 v3.6
+     IF ((ELAI < 0.05 .OR. ESAI == 0.0) .and. CROPTYPE == 0) ELAI = 0.0  ! MB: LAI CHECK
 
-     IF (TV .GT. parameters%TMIN) THEN
+     IF ((TV .GT. parameters%TMIN .and. CROPTYPE == 0).or.(PGS > 2 .and. PGS < 7 .and. CROPTYPE > 0)) THEN
          IGS = 1.
      ELSE
          IGS = 0.
@@ -1697,7 +1703,7 @@ SUBROUTINE ENERGY (parameters,ICE    ,VEGTYP ,IST    ,NSNOW  ,NSOIL  , & !in
 
   REAL, PARAMETER                   :: MPE    = 1.E-6
   REAL, PARAMETER                   :: PSIWLT = -150.  !metric potential for wilting point (m)
-  REAL, PARAMETER                   :: Z0     = 0.01   ! Bare-soil roughness length (m) (i.e., under the canopy)
+  REAL, PARAMETER                   :: Z0     = 0.002  ! Bare-soil roughness length (m) (i.e., under the canopy)
 
 ! ---------------------------------------------------------------------------------------------------
 ! initialize fluxes from veg. fraction
@@ -2281,7 +2287,8 @@ SUBROUTINE TDFCND (parameters, ISOIL, DF, SMC, SH2O)
     THKS = (THKQTZ ** parameters%QUARTZ(ISOIL))* (THKO ** (1. - parameters%QUARTZ(ISOIL)))
 
 ! UNFROZEN VOLUME FOR SATURATION (POROSITY*XUNFROZ)
-    XUNFROZ = SH2O / SMC
+    XUNFROZ = 1.0                       ! Prevent divide by zero (suggested by D. Mocko)
+    IF(SMC > 0.) XUNFROZ = SH2O / SMC
 ! SATURATED THERMAL CONDUCTIVITY
     XU = XUNFROZ * parameters%SMCMAX(ISOIL)
 
@@ -3472,6 +3479,7 @@ SUBROUTINE VEGE_FLUX(parameters,NSNOW   ,NSOIL   ,ISNOW   ,VEGTYP  ,VEG     , &
         MOZ    = 0.
         MOZSGN = 0
         MOZOLD = 0.
+        FH2    = 0.
         HG     = 0.
         H      = 0.
         QFX    = 0.
@@ -3924,6 +3932,7 @@ SUBROUTINE BARE_FLUX (parameters,NSNOW   ,NSOIL   ,ISNOW   ,DT      ,SAG     , &
         MOZ    = 0.
         MOZSGN = 0
         MOZOLD = 0.
+        FH2    = 0.
         H      = 0.
         QFX    = 0.
         FV     = 0.1
@@ -4467,6 +4476,8 @@ SUBROUTINE SFCDIF2(parameters,ITER   ,Z0     ,THZ0   ,THLM   ,SFCSPD , & !in
        ELSE
           ZETALU = MIN (ZETALU,ZTMAX)
           ZETALT = MIN (ZETALT,ZTMAX)
+          ZETAU  = MIN (ZETAU,ZTMAX/(ZSLU/ZU))   ! Barlage: add limit on ZETAU/ZETAT
+          ZETAT  = MIN (ZETAT,ZTMAX/(ZSLT/ZT))   ! Barlage: prevent SIMM/SIMH < 0
           PSMZ = PSPMS (ZETAU)
           SIMM = PSPMS (ZETALU) - PSMZ + RLOGU
           PSHZ = PSPHS (ZETAT)
@@ -4503,10 +4514,12 @@ SUBROUTINE SFCDIF2(parameters,ITER   ,Z0     ,THZ0   ,THLM   ,SFCSPD , & !in
 !-----------------------------------------------------------------------
        RLOGT = log (ZSLT / ZT)
        USTARK = USTAR * VKRM
+       IF(SIMM < 1.e-6) SIMM = 1.e-6        ! Limit stability function
        AKMS = MAX (USTARK / SIMM,CXCH)
 !-----------------------------------------------------------------------
 ! IF STATEMENTS TO AVOID TANGENT LINEAR PROBLEMS NEAR ZERO
 !-----------------------------------------------------------------------
+       IF(SIMH < 1.e-6) SIMH = 1.e-6        ! Limit stability function
        AKHS = MAX (USTARK / SIMH,CXCH)
 
        IF (BTGH * AKHS * DTHV .ne. 0.0) THEN
@@ -6787,6 +6800,7 @@ SUBROUTINE SOILWATER (parameters,NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
   REAL                                    :: XS     !
   REAL                                    :: WATMIN !
   REAL                                    :: QDRAIN_SAVE !
+  REAL                                    :: RUNSRF_SAVE !
   REAL                                    :: EPORE  !effective porosity [m3/m3]
   REAL, DIMENSION(1:NSOIL)                :: FCR    !impermeable fraction due to frozen soil
   INTEGER                                 :: NITER  !iteration times soil moisture (-)
@@ -6893,19 +6907,26 @@ SUBROUTINE SOILWATER (parameters,NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
 
     NITER = 1
 
-    IF(OPT_INF == 1) THEN    !OPT_INF =2 may cause water imbalance
+!    IF(OPT_INF == 1) THEN    !OPT_INF =2 may cause water imbalance
        NITER = 3
        IF (PDDUM*DT>DZSNSO(1)*parameters%SMCMAX(1) ) THEN
           NITER = NITER*2
        END IF
-    END IF                 
+!    END IF                 
 
     DTFINE  = DT / NITER
 
 ! solve soil moisture
 
     QDRAIN_SAVE = 0.0
+    RUNSRF_SAVE = 0.0
     DO ITER = 1, NITER
+       IF(QINSUR > 0. .and. OPT_RUN == 3) THEN
+          CALL INFIL (parameters,NSOIL  ,DTFINE     ,ZSOIL  ,SH2O   ,SICE   , & !in
+                      SICEMAX,QINSUR ,                         & !in
+                      PDDUM  ,RUNSRF )                           !out
+       END IF
+
        CALL SRT   (parameters,NSOIL  ,ZSOIL  ,DTFINE ,PDDUM  ,ETRANI , & !in
                    QSEVA  ,SH2O   ,SMC    ,ZWT    ,FCR    , & !in
                    SICEMAX,FCRMAX ,ILOC   ,JLOC   ,SMCWTD ,         & !in
@@ -6919,9 +6940,11 @@ SUBROUTINE SOILWATER (parameters,NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
                    WPLUS)                                     !out
        RSAT =  RSAT + WPLUS
        QDRAIN_SAVE = QDRAIN_SAVE + QDRAIN
+       RUNSRF_SAVE = RUNSRF_SAVE + RUNSRF
     END DO
 
     QDRAIN = QDRAIN_SAVE/NITER
+    RUNSRF = RUNSRF_SAVE/NITER
 
     RUNSRF = RUNSRF * 1000. + RSAT * 1000./DT  ! m/s -> mm/s
     QDRAIN = QDRAIN * 1000.
@@ -7377,6 +7400,22 @@ SUBROUTINE SSTEP (parameters,NSOIL  ,NSNOW  ,DT     ,ZSOIL  ,DZSNSO , & !in
     WPLUS        = MAX((SH2O(1)-EPORE), 0.0) * DZSNSO(1) 
     SH2O(1)      = MIN(EPORE,SH2O(1))
 
+   IF(WPLUS > 0.0) THEN
+    SH2O(2)      = SH2O(2) + WPLUS/DZSNSO(2)
+    DO K = 2,NSOIL-1
+      EPORE        = MAX ( 1.E-4 , ( parameters%SMCMAX(K) - SICE(K) ) )
+      WPLUS        = MAX((SH2O(K)-EPORE), 0.0) * DZSNSO(K)
+      SH2O(K)      = MIN(EPORE,SH2O(K))
+      SH2O(K+1)    = SH2O(K+1) + WPLUS/DZSNSO(K+1)
+    END DO
+
+    EPORE        = MAX ( 1.E-4 , ( parameters%SMCMAX(NSOIL) - SICE(NSOIL) ) )
+    WPLUS        = MAX((SH2O(NSOIL)-EPORE), 0.0) * DZSNSO(NSOIL) 
+    SH2O(NSOIL)  = MIN(EPORE,SH2O(NSOIL))
+   END IF
+   
+    SMC = SH2O + SICE
+
   END SUBROUTINE SSTEP
 
 !== begin wdfcnd1 ==================================================================================
@@ -7438,25 +7477,27 @@ SUBROUTINE WDFCND2 (parameters,WDF,WCND,SMC,SICE,ISOIL)
 
 ! local
     REAL :: EXPON
-    REAL :: FACTR
+    REAL :: FACTR1,FACTR2
     REAL :: VKWGT
 ! ----------------------------------------------------------------------
 
 ! soil water diffusivity
 
-    FACTR = MAX(0.01, SMC/parameters%SMCMAX(ISOIL))
+    FACTR1 = 0.05/parameters%SMCMAX(ISOIL)
+    FACTR2 = MAX(0.01, SMC/parameters%SMCMAX(ISOIL))
+    FACTR1 = MIN(FACTR1,FACTR2)
     EXPON = parameters%BEXP(ISOIL) + 2.0
-    WDF   = parameters%DWSAT(ISOIL) * FACTR ** EXPON
+    WDF   = parameters%DWSAT(ISOIL) * FACTR2 ** EXPON
 
     IF (SICE > 0.0) THEN
     VKWGT = 1./ (1. + (500.* SICE)**3.)
-    WDF   = VKWGT * WDF + (1.-VKWGT)*parameters%DWSAT(ISOIL)*(0.2/parameters%SMCMAX(ISOIL))**EXPON
+    WDF   = VKWGT * WDF + (1.-VKWGT)*parameters%DWSAT(ISOIL)*(FACTR1)**EXPON
     END IF
 
 ! hydraulic conductivity
 
     EXPON = 2.0*parameters%BEXP(ISOIL) + 3.0
-    WCND  = parameters%DKSAT(ISOIL) * FACTR ** EXPON
+    WCND  = parameters%DKSAT(ISOIL) * FACTR2 ** EXPON
 
   END SUBROUTINE WDFCND2
 
@@ -8073,10 +8114,10 @@ SUBROUTINE CO2FLUX (parameters,NSNOW  ,NSOIL  ,VEGTYP ,IGS    ,DT     , & !in
 
 !  fraction of carbon into wood versus root
 
-     IF(WOOD.GT.0) THEN
+     IF(WOOD > 1.e-6) THEN
         WOODF = (1.-EXP(-BF*(parameters%WRRAT*RTMASS/WOOD))/BF)*parameters%WDPOOL
      ELSE
-        WOODF = 0.
+        WOODF = parameters%WDPOOL
      ENDIF
 
      ROOTPT = NONLEF*(1.-WOODF)
@@ -8182,7 +8223,7 @@ SUBROUTINE CARBON_CROP (parameters,NSNOW  ,NSOIL  ,VEGTYP ,DT     ,ZSOIL  ,JULIA
                             SOLDN  ,T2M    ,                                         & !in
                             LFMASS ,RTMASS ,STMASS ,WOOD   ,STBLCP ,FASTCP ,GRAIN  , & !inout
 			    XLAI   ,XSAI   ,GDD    ,                                 & !inout
-                            GPP    ,NPP    ,NEE    ,AUTORS ,HETERS ,TOTSC  ,TOTLB    ) !out
+                            GPP    ,NPP    ,NEE    ,AUTORS ,HETERS ,TOTSC  ,TOTLB, PGS    ) !out
 ! ------------------------------------------------------------------------------------------
 ! Initial crop version created by Xing Liu
 ! Initial crop version added by Barlage v3.8
@@ -8238,7 +8279,7 @@ SUBROUTINE CARBON_CROP (parameters,NSNOW  ,NSOIL  ,VEGTYP ,DT     ,ZSOIL  ,JULIA
   REAL    :: WSTRES    !water stress coeficient [-]  (1. for wilting )
   INTEGER :: IPA       !Planting index
   INTEGER :: IHA       !Havestindex(0=on,1=off)
-  INTEGER :: PGS       !Plant growth stage
+  INTEGER, INTENT(OUT) :: PGS       !Plant growth stage
 
   REAL    :: PSNCROP 
 
@@ -8393,6 +8434,8 @@ SUBROUTINE CO2FLUX_CROP (parameters,
   REAL                   :: STMSMN
   REAL                   :: SAPM     !stem area per unit mass (m2/g)
   REAL                   :: DIEST
+  REAL                   :: STCONVERT   !stem to grain conversion [g/m2/s]
+  REAL                   :: RTCONVERT   !root to grain conversion [g/m2/s]
 ! -------------------------- constants -------------------------------
   REAL                   :: BF       !parameter for present wood allocation [-]
   REAL                   :: RSWOODC  !wood respiration coeficient [1/s]
@@ -8419,24 +8462,24 @@ SUBROUTINE CO2FLUX_CROP (parameters,
     BF      = 0.90          !original was 0.90   ! carbon to roots
     WSTRC   = 100.0
     LAIMIN  = 0.05
-    XSAMIN  = 0.01
+    XSAMIN  = 0.05
 
     SAPM    = 3.*0.001      ! m2/kg -->m2/g
-    LFMSMN  = laimin/0.15
+    LFMSMN  = laimin/0.035
     STMSMN  = xsamin/sapm
 ! ---------------------------------------------------------------------------------
 
 ! carbon assimilation
 ! 1 mole -> 12 g carbon or 44 g CO2 or 30 g CH20
 
-     CARBFX     = PSN*12.e-6*IPA   !umol co2 /m2/ s -> g/m2/s C
-     CBHYDRAFX  = PSN*30.e-6*IPA
+     CARBFX     = PSN*12.e-6!*IPA   !umol co2 /m2/ s -> g/m2/s C
+     CBHYDRAFX  = PSN*30.e-6!*IPA
 
 ! mainteinance respiration
      FNF     = MIN( FOLN/MAX(1.E-06,parameters%FOLN_MX), 1.0 )
      TF      = parameters%Q10MR**( (TV-298.16)/10. )
      RESP    = parameters%LFMR25 * TF * FNF * XLAI  * (1.-WSTRES)  ! umol/m2/s
-     RSLEAF  = MIN(LFMASS/DT,RESP*30.e-6)                       ! g/m2/s
+     RSLEAF  = MIN((LFMASS-LFMSMN)/DT,RESP*30.e-6)                       ! g/m2/s
      RSROOT  = parameters%RTMR25*(RTMASS*1E-3)*TF * 30.e-6         ! g/m2/s
      RSSTEM  = parameters%STMR25*(STMASS*1E-3)*TF * 30.e-6         ! g/m2/s
      RSGRAIN = parameters%GRAINMR25*(GRAIN*1E-3)*TF * 30.e-6       ! g/m2/s
@@ -8462,19 +8505,25 @@ SUBROUTINE CO2FLUX_CROP (parameters,
 
 
      ADDNPPLF    = MAX(0.,parameters%LFPT(PGS)*CBHYDRAFX - GRLEAF-RSLEAF)
+     ADDNPPLF    = parameters%LFPT(PGS)*CBHYDRAFX - GRLEAF-RSLEAF
      ADDNPPST    = MAX(0.,parameters%STPT(PGS)*CBHYDRAFX - GRSTEM-RSSTEM)
+     ADDNPPST    = parameters%STPT(PGS)*CBHYDRAFX - GRSTEM-RSSTEM
     
 
 ! avoid reducing leaf mass below its minimum value but conserve mass
 
      LFDEL = (LFMASS - LFMSMN)/DT
      STDEL = (STMASS - STMSMN)/DT
+     LFTOVR  = MIN(LFTOVR,LFDEL+ADDNPPLF)
+     STTOVR  = MIN(STTOVR,STDEL+ADDNPPST)
      DIELF = MIN(DIELF,LFDEL+ADDNPPLF-LFTOVR)
 
 ! net primary productivities
 
      NPPL   = MAX(ADDNPPLF,-LFDEL)
+     NPPL   = ADDNPPLF
      NPPS   = MAX(ADDNPPST,-STDEL)
+     NPPS   = ADDNPPST
      NPPR   = parameters%RTPT(PGS)*CBHYDRAFX - RSROOT - GRROOT
      NPPG  =  parameters%GRAINPT(PGS)*CBHYDRAFX - RSGRAIN - GRGRAIN
 
@@ -8487,10 +8536,14 @@ SUBROUTINE CO2FLUX_CROP (parameters,
 
      GPP = CBHYDRAFX* 0.4 !!g/m2/s C  0.4=12/30, CH20 to C
 
+     STCONVERT = 0.0
+     RTCONVERT = 0.0
      IF(PGS==6) THEN
-       STMASS = STMASS - STMASS*(0.00005)
-       RTMASS = RTMASS - RTMASS*(0.0005)
-       GRAIN  = GRAIN + STMASS*(0.00005) + RTMASS*(0.0005) 
+       STCONVERT = STMASS*(0.00005*DT/3600.0)
+       STMASS = STMASS - STCONVERT
+       RTCONVERT = RTMASS*(0.0005*DT/3600.0)
+       RTMASS = RTMASS - RTCONVERT
+       GRAIN  = GRAIN + STCONVERT + RTCONVERT
      END IF
     
      IF(RTMASS.LT.0.0) THEN
@@ -8504,11 +8557,11 @@ SUBROUTINE CO2FLUX_CROP (parameters,
 
  ! soil carbon budgets
 
-     IF(PGS == 1 .OR. PGS == 2 .OR. PGS == 8) THEN
-       FASTCP=1000
-     ELSE
+!     IF(PGS == 1 .OR. PGS == 2 .OR. PGS == 8) THEN
+!       FASTCP=1000
+!     ELSE
        FASTCP = FASTCP + (RTTOVR+LFTOVR+STTOVR+DIELF)*DT 
-     END IF
+!     END IF
      FST = 2.0**( (STC-283.16)/10. )
      FSW = WROOT / (0.20+WROOT) * 0.23 / (0.23+WROOT)
      RSSOIL = FSW * FST * parameters%MRP* MAX(0.,FASTCP*1.E-3)*12.E-6
@@ -8544,23 +8597,20 @@ SUBROUTINE CO2FLUX_CROP (parameters,
 
    
 !After harversting
-     IF(PGS == 8 ) THEN
-       LFMASS = 0.62
-       STMASS = 0
-       TOTLB  = 0
-       GPP    = 0
-       NPP    = 0
-       GRAIN  = 0
-       AUTORS = 0
-       NEE    = 0
-     END IF
+!     IF(PGS == 8 ) THEN
+!       LFMASS = 0.62
+!       STMASS = 0
+!       GRAIN  = 0
+!     END IF
 
-    IF(PGS == 1 .OR. PGS == 2 .OR. PGS == 8) THEN
+!    IF(PGS == 1 .OR. PGS == 2 .OR. PGS == 8) THEN
+    IF(PGS == 8 .and. (GRAIN > 0. .or. LFMASS > 0 .or. STMASS > 0 .or. RTMASS > 0)) THEN
      XLAI   = 0.05
      XSAI   = 0.05
      LFMASS = LFMSMN
      STMASS = STMSMN
      RTMASS = 0
+     GRAIN  = 0
     END IF 
     
 END SUBROUTINE CO2FLUX_CROP
@@ -8642,6 +8692,8 @@ SUBROUTINE GROWING_GDD (parameters,                         & !in
    ! GDDS3 = GDDSK+170
    ! GDDS3 = 170
 
+   PGS = 1                         ! MB: set PGS = 1 (for initialization during growing season when no GDD)
+
    IF(GDDDAY > 0.0) PGS = 2
 
    IF(GDDDAY >= parameters%GDDS1)  PGS = 3
@@ -8901,7 +8953,9 @@ MODULE NOAHMP_TABLES
     INTEGER :: ISWATER_TABLE
     INTEGER :: ISBARREN_TABLE
     INTEGER :: ISICE_TABLE
+    INTEGER :: ISCROP_TABLE
     INTEGER :: EBLFOREST_TABLE
+    INTEGER :: NATURAL_TABLE
     INTEGER :: LOW_DENSITY_RESIDENTIAL_TABLE
     INTEGER :: HIGH_DENSITY_RESIDENTIAL_TABLE
     INTEGER :: HIGH_INTENSITY_INDUSTRIAL_TABLE
@@ -9010,6 +9064,7 @@ MODULE NOAHMP_TABLES
 
 ! MPTABLE.TBL crop parameters
 
+ INTEGER :: DEFAULT_CROP_TABLE          ! Default crop index
  INTEGER :: PLTDAY_TABLE(NCROP)         ! Planting date
  INTEGER :: HSDAY_TABLE(NCROP)          ! Harvest date
     REAL :: PLANTPOP_TABLE(NCROP)       ! Plant density [per ha] - used?
@@ -9070,7 +9125,9 @@ subroutine read_mp_veg_parameters(DATASET_IDENTIFIER)
     INTEGER :: ISWATER
     INTEGER :: ISBARREN
     INTEGER :: ISICE
+    INTEGER :: ISCROP
     INTEGER :: EBLFOREST
+    INTEGER :: NATURAL
     INTEGER :: LOW_DENSITY_RESIDENTIAL
     INTEGER :: HIGH_DENSITY_RESIDENTIAL
     INTEGER :: HIGH_INTENSITY_INDUSTRIAL
@@ -9087,7 +9144,7 @@ subroutine read_mp_veg_parameters(DATASET_IDENTIFIER)
 		     SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5
 			     
     NAMELIST / noahmp_usgs_veg_categories / VEG_DATASET_DESCRIPTION, NVEG
-    NAMELIST / noahmp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, EBLFOREST, &
+    NAMELIST / noahmp_usgs_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, &
          LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL, &
          CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, &
          LTOVRC,  DILEFC,  DILEFW,  RMF25 ,  SLA   ,  FRAGR ,  TMIN  ,  VCMX25,  TDLEF ,  BP, MP, QE25, RMS25, RMR25, ARM, &
@@ -9097,7 +9154,7 @@ subroutine read_mp_veg_parameters(DATASET_IDENTIFIER)
          RHOL_VIS, RHOL_NIR, RHOS_VIS, RHOS_NIR, TAUL_VIS, TAUL_NIR, TAUS_VIS, TAUS_NIR, SLAREA, EPS1, EPS2, EPS3, EPS4, EPS5
 	 
     NAMELIST / noahmp_modis_veg_categories / VEG_DATASET_DESCRIPTION, NVEG
-    NAMELIST / noahmp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, EBLFOREST, &
+    NAMELIST / noahmp_modis_parameters / ISURBAN, ISWATER, ISBARREN, ISICE, ISCROP, EBLFOREST, NATURAL, &
          LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL, &
          CH2OP, DLEAF, Z0MVT, HVT, HVB, DEN, RC, MFSNO, XL, CWPVT, C3PSN, KC25, AKC, KO25, AKO, AVCMX, AQE, &
          LTOVRC,  DILEFC,  DILEFW,  RMF25 ,  SLA   ,  FRAGR ,  TMIN  ,  VCMX25,  TDLEF ,  BP, MP, QE25, RMS25, RMR25, ARM, &
@@ -9159,7 +9216,9 @@ subroutine read_mp_veg_parameters(DATASET_IDENTIFIER)
     ISWATER_TABLE      = -99999
     ISBARREN_TABLE     = -99999
     ISICE_TABLE        = -99999
+    ISCROP_TABLE       = -99999
     EBLFOREST_TABLE    = -99999
+    NATURAL_TABLE      = -99999
     LOW_DENSITY_RESIDENTIAL_TABLE   = -99999
     HIGH_DENSITY_RESIDENTIAL_TABLE  = -99999
     HIGH_INTENSITY_INDUSTRIAL_TABLE = -99999
@@ -9190,7 +9249,9 @@ subroutine read_mp_veg_parameters(DATASET_IDENTIFIER)
                       ISWATER_TABLE   = ISWATER
                      ISBARREN_TABLE   = ISBARREN
                         ISICE_TABLE   = ISICE
+                       ISCROP_TABLE   = ISCROP
                     EBLFOREST_TABLE   = EBLFOREST
+                      NATURAL_TABLE   = NATURAL
       LOW_DENSITY_RESIDENTIAL_TABLE   = LOW_DENSITY_RESIDENTIAL
      HIGH_DENSITY_RESIDENTIAL_TABLE   = HIGH_DENSITY_RESIDENTIAL
     HIGH_INTENSITY_INDUSTRIAL_TABLE   = HIGH_INTENSITY_INDUSTRIAL
@@ -9466,6 +9527,7 @@ subroutine read_mp_crop_parameters()
     implicit none
     integer :: ierr
 
+ INTEGER                   :: DEFAULT_CROP
  INTEGER, DIMENSION(NCROP) :: PLTDAY
  INTEGER, DIMENSION(NCROP) :: HSDAY
     REAL, DIMENSION(NCROP) :: PLANTPOP
@@ -9506,7 +9568,7 @@ subroutine read_mp_crop_parameters()
     REAL, DIMENSION(NCROP) :: BIO2LAI
 
 
-    NAMELIST / noahmp_crop_parameters /     PLTDAY,     HSDAY,  PLANTPOP,      IRRI,  GDDTBASE,   GDDTCUT,     GDDS1,     GDDS2, &
+    NAMELIST / noahmp_crop_parameters /DEFAULT_CROP,   PLTDAY,     HSDAY,  PLANTPOP,      IRRI,  GDDTBASE,   GDDTCUT,     GDDS1,     GDDS2, &
                                              GDDS3,     GDDS4,     GDDS5,      C3C4,      AREF,     PSNRF,     I2PAR,   TASSIM0, &
                                            TASSIM1,   TASSIM2,         K,      EPSI,     Q10MR,   FOLN_MX,   LEFREEZ,            &
                                         DILE_FC_S1,DILE_FC_S2,DILE_FC_S3,DILE_FC_S4,DILE_FC_S5,DILE_FC_S6,DILE_FC_S7,DILE_FC_S8, &
@@ -9524,6 +9586,7 @@ subroutine read_mp_crop_parameters()
 
 
     ! Initialize our variables to bad values, so that if the namelist read fails, we come to a screeching halt as soon as we try to use anything.
+ DEFAULT_CROP_TABLE     = -99999
        PLTDAY_TABLE     = -99999
         HSDAY_TABLE     = -99999
      PLANTPOP_TABLE     = -1.E36
@@ -9570,12 +9633,13 @@ subroutine read_mp_crop_parameters()
        write(*,'("Cannot find file MPTABLE.TBL")')
        write(*,'("STOP")')
        write(*,'("*******************************************************************")')
-       call wrf_error_fatal("STOP in Noah-MP read_mp_rad_parameters")
+       call wrf_error_fatal("STOP in Noah-MP read_mp_crop_parameters")
     endif
 
     read(15,noahmp_crop_parameters)
     close(15)
 
+ DEFAULT_CROP_TABLE      = DEFAULT_CROP
        PLTDAY_TABLE      = PLTDAY
         HSDAY_TABLE      = HSDAY
      PLANTPOP_TABLE      = PLANTPOP
diff --git a/wrfv2_fire/phys/module_sf_oml.F b/wrfv2_fire/phys/module_sf_oml.F
index 5a7b66cf..df60a4d5 100644
--- a/wrfv2_fire/phys/module_sf_oml.F
+++ b/wrfv2_fire/phys/module_sf_oml.F
@@ -216,6 +216,16 @@ SUBROUTINE omlinit(oml_hml0, tsk,                           &
           TMOML(I,J)=TSK(I,J)-5.
         ENDDO
         ENDDO
+     ELSE IF (oml_hml0 .eq. 0.) THEN
+! initializing with climatological mixed layer depth only
+        DO J=jts,jtf
+        DO I=its,itf
+          HML(I,J)=H0ML(I,J)
+          HUML(I,J)=0.
+          HVML(I,J)=0.
+          TMOML(I,J)=TSK(I,J)-5.
+        ENDDO
+        ENDDO
      ELSE
         WRITE(message,*)'Initializing OML with real HML0, h(1,1) = ', h0ml(1,1)
         CALL wrf_debug (0, TRIM(message))
diff --git a/wrfv2_fire/phys/module_sf_pxsfclay.F b/wrfv2_fire/phys/module_sf_pxsfclay.F
old mode 100755
new mode 100644
index 81c2bc60..e5966e3b
--- a/wrfv2_fire/phys/module_sf_pxsfclay.F
+++ b/wrfv2_fire/phys/module_sf_pxsfclay.F
@@ -474,22 +474,13 @@ SUBROUTINE PXSFCLAY1D(J,US,VS,T1D,THETA1,QV1D,P1D,dz8w1d,                &
         RBW    = 4.503/UST(I)                                       
         CHS(I) = 1./(RA(I) + RBH)
         CQS    = 1./(RA(I) + RBW)
-        MOL(I) = DTG * CHS(I) / UST(I)                       ! This is really TST
-!        TSTV     = (THETAV1(I) - TH0(I)) * CHS(I) / UST(I) 
-           TMPVTCON  = 1.0 + EP1 * QV1D(i)                             ! COnversion factor for virtual temperature
-!           TST    = -hfx(i)/(rhox(i)*cp*ust(i))   
-           TST = DTG * CHS(I)/UST(i)
-           QST    = -QFX(i) / (UST(i)*rhox(i))
-           IF (itimestep.eq.1) THEN
-             TSTV  = (THETAV1(I) - TH0(I)) * CHS(I) / UST(I) 
-           ELSE
-             TSTV  = TST*TMPVTCON + THETAV1(i)*EP1*QST
-           ENDIF
-
+        MOL(I) = DTG * CHS(I) / UST(I)
+        TMPVTCON  = 1.0 + EP1 * QV1D(i)
+        TST = DTG * CHS(I)/UST(i)
+        TSTV  = (THETAV1(I) - TH0(I)) * CHS(I) / UST(I) 
         IF (ABS(TSTV) .LT. 1.E-5)  TSTV = 1.E-5 
-        MOLENGTH(I) = THETAV1(I) * UST(I) * UST(I) / (KARMAN *             &
-                        G * TSTV)
-!
+        MOLENGTH(I) = THETAV1(I) * UST(I) * UST(I) / (KARMAN * G * TSTV)
+
 !       ---Compute 2m surface exchange coefficients for heat and moisture
         XMOL = MOLENGTH(I)
         IF(MOLENGTH(I).GT.0.0) XMOL = AMAX1(MOLENGTH(I),2.0)       
diff --git a/wrfv2_fire/phys/module_sf_ruclsm.F b/wrfv2_fire/phys/module_sf_ruclsm.F
index 9334a1b6..c4157325 100644
--- a/wrfv2_fire/phys/module_sf_ruclsm.F
+++ b/wrfv2_fire/phys/module_sf_ruclsm.F
@@ -3,6 +3,18 @@
 !
 MODULE module_sf_ruclsm
 
+! Notes for perturbations of soil properties (Judith Berner)
+! Perturbations are applied in subroutine soilprob to array hydro;
+! soilprop is called from subroutine SFCTMP which is called from subroutine LSMRUC;
+! subroutine LSMRUC had two new 3D fields: pattern_spp_lsm (in) and field_sf(inout);
+!    their vertical dimension is number of atmospheric levels (kms:kme) - (suboptimal, but easiest hack)
+!    field_sf is used to pass perturbed fields of hydrop up to model (and output) driver;
+! in argument list to SFCTMP the arrays are passed as pattern_spp_lsm(i,1:nzs,j), and exist henceforth as
+! column arrays;
+! in the subroutines below SFCTMP (SNOW and SNOWSOIL) the fields are called rstochcol,fieldcol_sf
+! to reflect their dimension rstochcol (1:nzs)
+
+
   USE module_model_constants
   USE module_wrf_error
 
@@ -14,7 +26,6 @@ MODULE module_sf_ruclsm
         real, dimension(1:NLUS) ::  SNUPTBL, RSTBL, RGLTBL, HSTBL, LAITBL,         &
                                     ALBTBL, Z0TBL, LEMITBL, PCTBL, SHDTBL, MAXALB
         REAL ::   TOPT_DATA,CMCMAX_DATA,CFACTR_DATA,RSMAX_DATA
-
 ! SOIL PARAMETERS
         INTEGER :: SLCATS
         INTEGER, PARAMETER :: NSLTYPE=30
@@ -36,7 +47,10 @@ MODULE module_sf_ruclsm
 CONTAINS
 
 !-----------------------------------------------------------------
-    SUBROUTINE LSMRUC(                                           &
+    SUBROUTINE LSMRUC(spp_lsm,                                   &
+#if (EM_CORE==1)
+                   pattern_spp_lsm,field_sf,                     &
+#endif
                    DT,KTAU,NSL,                                  &
 #if (EM_CORE==1)
                    lakemodel,lakemask,                           &
@@ -56,7 +70,7 @@ SUBROUTINE LSMRUC(                                           &
                    CP,ROVCP,G0,LV,STBOLT,                        &
                    SOILMOIS,SH2O,SMAVAIL,SMMAX,                  &
                    TSO,SOILT,HFX,QFX,LH,                         &
-                   SFCRUNOFF,UDRUNOFF,SFCEXC,                    &
+                   SFCRUNOFF,UDRUNOFF,ACRUNOFF,SFCEXC,           &
                    SFCEVP,GRDFLX,SNOWFALLAC,ACSNOW,SNOM,         &
                    SMFR3D,KEEPFR3DFLAG,                          &
                    myj,shdmin,shdmax,rdlai2d,                    &
@@ -121,6 +135,7 @@ SUBROUTINE LSMRUC(                                           &
 !-- LH          upward latent heat flux (W/m^2)
 !   SFCRUNOFF - ground surface runoff [mm]
 !   UDRUNOFF - underground runoff [mm]
+!   ACRUNOFF - run-total surface runoff [mm]
 !   SFCEVP - total evaporation in [kg/m^2]
 !   GRDFLX - soil heat flux (W/m^2: negative, if downward from surface)
 !   SNOWFALLAC - run-total snowfall accumulation [mm]   
@@ -146,12 +161,19 @@ SUBROUTINE LSMRUC(                                           &
 
    REAL,       INTENT(IN   )    ::     DT
    LOGICAL,    INTENT(IN   )    ::     myj,frpcpn
+   INTEGER,    INTENT(IN   )    ::     spp_lsm
    INTEGER,    INTENT(IN   )    ::     NLCAT, NSCAT, mosaic_lu, mosaic_soil
    INTEGER,    INTENT(IN   )    ::     ktau, nsl, isice, iswater, &
                                        ims,ime, jms,jme, kms,kme, &
                                        ids,ide, jds,jde, kds,kde, &
                                        its,ite, jts,jte, kts,kte
 
+#if (EM_CORE==1)
+   REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ),OPTIONAL::    pattern_spp_lsm
+   REAL,    DIMENSION( ims:ime, kms:kme, jms:jme ),OPTIONAL::    field_sf
+#endif
+   REAL,    DIMENSION( ims:ime, 1  :nsl, jms:jme )         ::    field_sf_loc
+
    REAL,    DIMENSION( ims:ime, kms:kme, jms:jme )            , &
             INTENT(IN   )    ::                           QV3D, &
                                                           QC3D, &
@@ -229,6 +251,7 @@ SUBROUTINE LSMRUC(                                           &
                                                          SFCEVP, &
                                                       SFCRUNOFF, &
                                                        UDRUNOFF, &
+                                                       ACRUNOFF, &
                                                          GRDFLX, &
                                                          ACSNOW, &
                                                            SNOM, &
@@ -360,7 +383,7 @@ SUBROUTINE LSMRUC(                                           &
    REAL      ::  cq,r61,r273,arp,brp,x,evs,eis
    REAL      ::  cropsm
 
-   REAL      ::  meltfactor, ac,as
+   REAL      ::  meltfactor, ac,as, wb
    INTEGER   ::  NROOT
    INTEGER   ::  ILAND,ISOIL,IFOREST
  
@@ -368,11 +391,27 @@ SUBROUTINE LSMRUC(                                           &
    INTEGER   ::  k1,l,k2,kp,km
    CHARACTER (LEN=132) :: message
 
-!-----------------------------------------------------------------
+   REAL,DIMENSION(ims:ime,1:nsl,jms:jme) :: rstoch 
 
+!-----------------------------------------------------------------
          NZS=NSL
          NDDZS=2*(nzs-2)
 
+         rstoch=0.0
+         field_sf_loc=0.0
+!beka added
+#if (EM_CORE==1)
+       if (spp_lsm==1) then
+         do J=jts,jte
+           do i=its,ite
+             do k=1,nsl
+               rstoch(i,k,j) = pattern_spp_lsm(i,k,j)
+               field_sf_loc(i,k,j)=field_sf(i,k,j)
+             enddo
+           enddo
+         enddo 
+       endif  
+#endif
 !---- table TBQ is for resolution of balance equation in VILKA
         CQ=173.15-.05
         R273=1./273.15
@@ -425,7 +464,7 @@ SUBROUTINE LSMRUC(                                           &
            soilt1(i,j) = tso(i,1,j)
             ENDIF
         ENDIF
-           tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273.
+           tsnav(i,j) =0.5*(soilt(i,j)+tso(i,1,j))-273.15
            qcg  (i,j) =0.
            patmb=P8w(i,kms,j)*1.e-2
            QSG  (i,j) = QSN(SOILT(i,j),TBQ)/PATMB
@@ -440,7 +479,6 @@ SUBROUTINE LSMRUC(                                           &
            qsfc(i,j) = qvg(i,j)/(1.+qvg(i,j))
            SMELT(i,j) = 0.
            SNOM (i,j) = 0.
-           ACSNOW(i,j) = 0.
            SNOWFALLAC(i,j) = 0.
            PRECIPFR(i,j) = 0.
            RHOSNF(i,j) = -1.e3 ! non-zero flag
@@ -452,6 +490,7 @@ SUBROUTINE LSMRUC(                                           &
            RUNOFF2(i,j) = 0.
            SFCRUNOFF(i,j) = 0.
            UDRUNOFF(i,j) = 0.
+           ACRUNOFF(i,j) = 0.
            emissl (i,j) = 0.
            budget(i,j) = 0.
            acbudget(i,j) = 0.
@@ -508,7 +547,6 @@ SUBROUTINE LSMRUC(                                           &
       print *, 'LSMRUC, I,J,xland, QFX,HFX from SFCLAY',i,j,xland(i,j), &
                   qfx(i,j),hfx(i,j)
       print *, ' GSW, GLW =',gsw(i,j),glw(i,j)
-      print *, 'SNHEI=',snhei
       print *, 'SOILT, TSO start of time step =',soilt(i,j),(tso(i,k,j),k=1,nsl)
       print *, 'SOILMOIS start of time step =',(soilmois(i,k,j),k=1,nsl)
       print *, 'SMFROZEN start of time step =',(smfr3d(i,k,j),k=1,nsl)
@@ -699,7 +737,9 @@ SUBROUTINE LSMRUC(                                           &
     ENDIF
 
         CN=CFACTR_DATA   ! exponent
-        SAT=max(1.e-4,(min(0.75,(CMCMAX_DATA * LAI(I,J) * 0.01*VEGFRA(I,J))))) ! canopy water saturated
+!        SAT=max(1.e-5,(min(5.e-4,(CMCMAX_DATA * (1.-exp(-0.5*lai(i,j))) * 0.01*VEGFRA(I,J))))) ! canopy water saturated
+        SAT = 5.e-4  ! units [m]
+!  if(i==666.and.j==282)  print *,'second 666,282 - sat',sat
 
 !-- definition of number of soil levels in the rooting zone
 !     IF(iforest(ivgtyp(i,j)).ne.1) THEN
@@ -763,7 +803,6 @@ SUBROUTINE LSMRUC(                                           &
              SNOWC(I,J)=0.0
            LMAVAIL(I,J)=1.0
 ! accumulated water equivalent of frozen precipitation over water [mm]
-           acsnow(i,j)=acsnow(i,j)+precipfr(i,j)
 
            ILAND=iswater
 !           ILAND=16
@@ -844,7 +883,6 @@ SUBROUTINE LSMRUC(                                           &
            enddo
 
               LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/(REF-QMIN)))
-!              LMAVAIL(I,J)=max(0.00001,min(1.,soilmois(i,1,j)/dqm))
 !              LMAVAIL(I,J)=max(0.00001,min(1.,soilm1d(1)/dqm))
 
 #if ( NMM_CORE == 1 )
@@ -874,8 +912,13 @@ SUBROUTINE LSMRUC(                                           &
                     (zsmain(nzs)-zshalf(nzs))
 
         canwatold(i,j) = canwatr
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+      print *,'before SFCTMP, spp_lsm, rstoch, field_sf_loc',      &
+      i,j,spp_lsm,(rstoch(i,k,j),k=1,nzs),(field_sf_loc(i,k,j),k=1,nzs)
+    ENDIF
 !-----------------------------------------------------------------
-         CALL SFCTMP (dt,ktau,conflx,i,j,                        &
+         CALL SFCTMP (spp_lsm,rstoch(i,:,j),field_sf_loc(i,:,j), & 
+                dt,ktau,conflx,i,j,                              &
 !--- input variables
                 nzs,nddzs,nroot,meltfactor,                      &   !added meltfactor
                 iland,isoil,xland(i,j),ivgtyp(i,j),isltyp(i,j),  &
@@ -904,7 +947,7 @@ SUBROUTINE LSMRUC(                                           &
                 SNOH(I,J),SNFLX(I,J),SNOM(I,J),SNOWFALLAC(I,J),  &
                 ACSNOW(I,J),edir(I,J),ec(I,J),ett(I,J),qfx(I,J), &
                 lh(I,J),hfx(I,J),sflx(I,J),sublim(I,J),          &
-                evapl(I,J),prcpl(I,J),budget(i,j),runoff1(i,j), &
+                evapl(I,J),prcpl(I,J),budget(i,j),runoff1(i,j),  &
                 runoff2(I,J),soilice,soiliqw,infiltrp,smf(i,j))
 !-----------------------------------------------------------------
 
@@ -951,6 +994,15 @@ SUBROUTINE LSMRUC(                                           &
         enddo
     ENDIF
 
+! Fill in field_sf to pass perturbed field of hydraulic cond. up to model driver and output
+#if (EM_CORE==1)
+       if (spp_lsm==1) then
+         do k=1,nsl
+           field_sf(i,k,j)=field_sf_loc(i,k,j)
+         enddo
+       endif
+#endif
+
 !***  DIAGNOSTICS
 !--- available and maximum soil moisture content in the soil
 !--- domain
@@ -973,6 +1025,7 @@ SUBROUTINE LSMRUC(                                           &
 !--- Convert the water unit into mm
         SFCRUNOFF(I,J) = SFCRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0
         UDRUNOFF (I,J) = UDRUNOFF(I,J)+RUNOFF2(I,J)*DT*1000.0
+        ACRUNOFF(I,J)  = ACRUNOFF(I,J)+RUNOFF1(I,J)*DT*1000.0
         SMAVAIL  (I,J) = SMAVAIL(I,J) * 1000.
         SMMAX    (I,J) = SMMAX(I,J) * 1000.
         smtotold (I,J) = smtotold(I,J) * 1000.
@@ -1073,15 +1126,14 @@ SUBROUTINE LSMRUC(                                           &
 
        ac=max(0.,canwat(i,j)-canwatold(i,j))
        as=max(0.,snwe-snowold(i,j))
-       runoff2(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source
+       wb =rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source
                       -qfx(i,j)*dt &
-!                      -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 &
-                      -runoff1(i,j)*dt*1.e3 &
+                      -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 &
                       -ac-as - (smavail(i,j)-smtotold(i,j))
 
        waterbudget(i,j)=rainbl(i,j)+smelt(i,j)*dt*1.e3 & ! source
                       -qfx(i,j)*dt &
-                      -runoff1(i,j)*dt*1.e3-runoff2(i,j) &
+                      -runoff1(i,j)*dt*1.e3-runoff2(i,j)*dt*1.e3 &
                       -ac-as - (smavail(i,j)-smtotold(i,j))
 
 
@@ -1127,7 +1179,8 @@ END SUBROUTINE LSMRUC
 
 
 
-   SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
+   SUBROUTINE SFCTMP (spp_lsm,rstochcol,fieldcol_sf,             &
+                delt,ktau,conflx,i,j,                            &
 !--- input variables
                 nzs,nddzs,nroot,meltfactor,                      &
                 ILAND,ISOIL,XLAND,IVGTYP,ISLTYP,PRCPMS,          &
@@ -1151,7 +1204,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
                 tsnav,dew,qvg,qsg,qcg,                           &
                 SMELT,SNOH,SNFLX,SNOM,SNOWFALLAC,ACSNOW,         &
                 edir1,ec1,ett1,eeta,qfx,hfx,s,sublim,            &
-                evapl,prcpl,fltot,runoff1,runoff2,soilice,             &
+                evapl,prcpl,fltot,runoff1,runoff2,soilice,       &
                 soiliqw,infiltr,smf)
 !-----------------------------------------------------------------
        IMPLICIT NONE
@@ -1222,6 +1275,9 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
                                                          ZSHALF, &
                                                          DTDZS2 
 
+   REAL,     DIMENSION(1:NZS), INTENT(IN)  ::          rstochcol
+   REAL,     DIMENSION(1:NZS), INTENT(INOUT) ::     fieldcol_sf
+
 
    REAL,     DIMENSION(1:NDDZS), INTENT(IN)  ::           DTDZS
 
@@ -1242,6 +1298,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
           
 
    INTEGER, INTENT(INOUT)    ::                     ILAND,ISOIL
+   INTEGER                   ::                     ILANDs
 
 !-------- 2-d variables
    REAL                                                        , &
@@ -1324,6 +1381,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
    REAL,  INTENT(INOUT)                     ::              RSM, &  
                                                       SNWEPRINT, &
                                                      SNHEIPRINT
+   INTEGER,   INTENT(IN)                    ::     spp_lsm     
 !--- Local variables
 
    INTEGER ::  K,ILNB
@@ -1337,8 +1395,9 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
    REAL    ::  rhonewgr,rhonewice
 
    REAL    ::  RNET,GSWNEW,GSWIN,EMISSN,ZNTSN,EMISS_snowfree
-   REAL    ::  VEGFRAC, snow_mosaic, snfr
-   real    ::  cice, albice, albsn, drip, dripsn, dripnosn
+   REAL    ::  VEGFRAC, snow_mosaic, snfr, vgfr
+   real    ::  cice, albice, albsn, drip, dripsn, dripliq
+   real    ::  interw, intersn, infwater, intwratio
 
 !-----------------------------------------------------------------
         integer,   parameter      ::      ilsnow=99 
@@ -1359,10 +1418,21 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
         RSM=0.
         DD1=0.
         INFILTR=0.
+! Jul 2016 -  Avissar and Pielke (1989)
+! This formulation depending on LAI defines relative contribution of the vegetation to
+! the total heat fluxes between surface and atmosphere.
+! With VEGFRA=100% and LAI=3, VEGFRAC=0.86 meaning that vegetation contributes
+! only 86% of the total surface fluxes.
+!        VGFR=0.01*VEGFRA ! % --> fraction
+!        VEGFRAC=2.*lai*vgfr/(1.+2.*lai*vgfr)
         VEGFRAC=0.01*VEGFRA
+        drip = 0.
         dripsn = 0.
-        dripnosn = 0.
+        dripliq = 0.
         smf = 0.
+        interw=0.
+        intersn=0.
+        infwater=0.
 
 !---initialize local arrays for sea ice
           do k=1,nzs
@@ -1412,7 +1482,8 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
         BSN=delt/3600.*c1sn*exp(0.08*min(0.,tsnav)-c2sn*rhosn*1.e-3)
        if(bsn*snwe*100..lt.1.e-4) goto 777
         XSN=rhosn*(exp(bsn*snwe*100.)-1.)/(bsn*snwe*100.)
-        rhosn=MIN(MAX(62.5,XSN),890.)
+        rhosn=MIN(MAX(76.9,XSN),500.)
+!        rhosn=MIN(MAX(62.5,XSN),890.)
 !        rhosn=MIN(MAX(100.,XSN),400.)
 !        rhosn=MIN(MAX(50.,XSN),400.)
  777   continue
@@ -1424,7 +1495,6 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
 
            newsn=newsnms*delt
 !---- ACSNOW - run-total snowfall water [mm]
-           acsnow=acsnow+newsn*1.e3
 
        IF(NEWSN.GT.0.) THEN
 !       IF(NEWSN.GE.1.E-8) THEN
@@ -1433,6 +1503,8 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
       print *, 'THERE IS NEW SNOW, newsn', newsn
     ENDIF
 
+        newsnowratio = min(1.,newsn/(snwe+newsn))
+
 !*** Calculate fresh snow density (t > -15C, else MIN value)
 !*** Eq. 10 from Koren et al. (1999)
 !--- old formulation from Koren (1999)
@@ -1470,10 +1542,10 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
 !         rhosn=MIN(MAX(50.,XSN),400.)
 
 !Update snow on the ground
-         snwe=snwe+newsn
-         newsnowratio = min(1.,newsn/snwe)
-         snhei=snwe*rhowater/rhosn
-         NEWSN=NEWSN*rhowater/rhonewsn
+!         snwe=snwe+newsn
+!         newsnowratio = min(1.,newsn/snwe)
+!         snhei=snwe*rhowater/rhosn
+!         NEWSN=NEWSN*rhowater/rhonewsn
        ENDIF ! end NEWSN > 0.
 
        IF(PRCPMS.NE.0.) THEN
@@ -1487,19 +1559,72 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
            RAINF=1.
        ENDIF
 
-! Update water intercepted by the canopy
-      drip = 0.
-      IF (vegfrac.GT.0.01) THEN
-          dd1=CST+(DELT*PRCPMS+NEWSN*RHOnewSN*1.E-3)*vegfrac
-          CST=DD1
+        drip = 0.
+        intwratio=0.
+     if(vegfrac > 0.01) then
+! compute intercepted precipitation - Eq. 1 Lawrence et al.,
+! J. of Hydrometeorology, 2006, CLM.
+         interw=0.25*DELT*PRCPMS*(1.-exp(-0.5*lai))*vegfrac
+         intersn=0.25*NEWSN*(1.-exp(-0.5*lai))*vegfrac
+!original - next 2 lines
+!         interw=DELT*PRCPMS*vegfrac
+!         intersn=NEWSN*vegfrac
+         infwater=PRCPMS - interw/delt
+    if((interw+intersn) > 0.) then
+       intwratio=interw/(interw+intersn)
+    endif
+
+! Update water/snow intercepted by the canopy
+         dd1=CST + interw + intersn
+         CST=DD1
+!  if(i==666.and.j==282)  print *,'666,282 - cst,sat,interw,intersn',cst,sat,interw,intersn
         IF(CST.GT.SAT) THEN
           CST=SAT
           DRIP=DD1-SAT
         ENDIF
-      ELSE
-          CST=0.
-          DRIP=0.
-      ENDIF
+     else
+         CST=0.
+         DRIP=0.
+         interw=0.
+         intersn=0.
+         infwater=PRCPMS
+     endif ! vegfrac > 0.01
+
+! SNHEI_CRIT is a threshold for fractional snow
+         SNHEI_CRIT=0.01601*1.e3/rhosn
+         SNHEI_CRIT_newsn=0.0005*1.e3/rhosn
+! snowfrac from the previous time step
+         SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT))
+        if(snowfrac < 0.75) snow_mosaic = 1.
+
+       IF(NEWSN.GT.0.) THEN
+!Update snow on the ground
+         snwe=max(0.,snwe+newsn-intersn)
+!      if(drip > 0.) then
+!       if (snow_mosaic==1.) then
+!         dripsn = drip*snowfrac
+!         dripnosn=drip*(1.-snowfrac)
+!         snwe=snwe+dripsn
+!       else
+!         snwe=snwe+drip
+!       endif
+!      endif
+! Add drip to snow on the ground
+      if(drip > 0.) then
+       if (snow_mosaic==1.) then
+         dripliq=drip*intwratio
+         dripsn = drip - dripliq
+         snwe=snwe+dripsn
+         infwater=infwater+dripliq
+         dripliq=0.
+         dripsn = 0.
+       else
+         snwe=snwe+drip
+       endif
+      endif
+         snhei=snwe*rhowater/rhosn
+         NEWSN=NEWSN*rhowater/rhonewsn
+       ENDIF
 
    IF(SNHEI.GT.0.0) THEN
 !-- SNOW on the ground
@@ -1507,23 +1632,18 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
          ILAND=ISICE
 !24nov15 - based on field exp on Pleasant View soccer fields
 !    if(meltfactor > 1.5) then ! all veg. types, except forests
-! SNHEI_CRIT is a threshold for fractional snow
-!         SNHEI_CRIT=0.01*1.e3/rhosn
-         SNHEI_CRIT=0.01601*1.e3/rhosn
+!         SNHEI_CRIT=0.01601*1.e3/rhosn
 ! Petzold - 1 cm of fresh snow overwrites effects from old snow.
 ! Need to test SNHEI_CRIT_newsn=0.01
 !         SNHEI_CRIT_newsn=0.01
-         SNHEI_CRIT_newsn=0.0005*1.e3/rhosn
 !    else  ! forests
-!24nov15
 !         SNHEI_CRIT=0.02*1.e3/rhosn
 !         SNHEI_CRIT_newsn=0.001*1.e3/rhosn
 !    endif
 
-!         SNOWFRAC=MIN(1.,SNHEI/SNHEI_CRIT)
          SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT))
-!24nov15 - SNOWFRAC for urban category < 0.5 
-      if(ivgtyp == urban) snowfrac=min(0.7,snowfrac)
+!24nov15 - SNOWFRAC for urban category < 0.75 
+      if(ivgtyp == urban) snowfrac=min(0.75,snowfrac)
 !      if(meltfactor > 1.5) then
 !         if(isltyp > 9 .and. isltyp < 13) then
 !24nov15 clay soil types - SNOFRAC < 0.9
@@ -1535,10 +1655,9 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
 !      endif
 
 !         SNOWFRAC=MIN(1.,SNHEI/(2.*SNHEI_CRIT))
-       if(snowfrac < 0.3 .and. tabs > 275.) then
-! turn on snow "mosaic" when snowfrac < 0.3
-         snow_mosaic = 1. 
-       endif
+!       elseif(snowfrac < 0.3 .and. tabs > 275.) then
+
+       if(snowfrac < 0.75) snow_mosaic = 1.
 
        if(newsn > 0. ) SNOWFRACnewsn=MIN(1.,SNHEI/SNHEI_CRIT_newsn)
 
@@ -1558,11 +1677,13 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
 !-- land-use types with higher roughness (forests, urban).
 !5mar12      IF(znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland)
 !      IF(newsn==0. .and. znt.lt.0.2 .and. snowfrac.gt.0.99) znt=z0tbl(iland)
-      IF(newsn.eq.0. .and. znt.lt.0.2 .and. IVGTYP.ne.isice) then
-         if( snhei .gt. 2.*SNHEI_CRIT .and. snhei .le. 4.*SNHEI_CRIT)then
+      IF(newsn.eq.0. .and. znt.le.0.2 .and. IVGTYP.ne.isice) then
+         if( snhei .le. 2.*ZNT)then
            znt=0.55*znt+0.45*z0tbl(iland)
-         elseif(snhei > 4.*SNHEI_CRIT) then
+         elseif( snhei .gt. 2.*ZNT .and. snhei .le. 4.*ZNT)then
            znt=0.2*znt+0.8*z0tbl(iland)
+         elseif(snhei > 4.*ZNT) then
+           znt=z0tbl(iland)
          endif
        ENDIF
 
@@ -1680,14 +1801,15 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
           smelt=0.
           runoff1s=0.
           runoff2s=0.
+       
+          ilands = ivgtyp
 
-           dripnosn=drip*(1.-snowfrac)
-         CALL SOIL(                                             &
+         CALL SOIL(spp_lsm,rstochcol,fieldcol_sf,               &
 !--- input variables
-            i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
-            PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,           &
-            EMISS_snowfree,RNET,QKMS,TKMS,PC,csts,dripnosn,     &
-            rho,vegfrac,lai,  &
+            i,j,ilands,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
+            PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,gswin,     &
+            EMISS_snowfree,RNET,QKMS,TKMS,PC,csts,dripliq,      &
+            infwater,rho,vegfrac,lai,myj,                       &
 !--- soil fixed fields 
             QWRTZ,rhocs,dqm,qmin,ref,wilt,                      &
             psis,bclh,ksat,sat,cn,                              &
@@ -1732,7 +1854,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
 !--- input variables
             i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
             PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,           &
-            0.98,RNET,QKMS,TKMS,rho,                            &
+            0.98,RNET,QKMS,TKMS,rho,myj,                        &
 !--- sea ice parameters
             tice,rhosice,capice,thdifice,                       &
             zsmain,zshalf,DTDZS,DTDZS2,tbq,                     &
@@ -1742,7 +1864,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
             ts1ds,dews,soilts,qvgs,qsgs,qcgs,                   &
             eetas,qfxs,hfxs,ss,evapls,prcpls,fltots             &
                                                                 )
-           edir1 = eeta
+           edir1 = eeta*1.e-3
            ec1 = 0.
            ett1 = 0.
            runoff1 = prcpms
@@ -1792,19 +1914,17 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
       if (SEAICE .LT. 0.5) then
 ! LAND
            if(snow_mosaic==1.)then
-              dripsn = drip*snowfrac
               snfr=1.
            else
-              dripsn = drip
               snfr=snowfrac
            endif
-         CALL SNOWSOIL (                                        & !--- input variables
+         CALL SNOWSOIL (spp_lsm,rstochcol,fieldcol_sf,     & !--- input variables
             i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot,         &
             meltfactor,rhonewsn,SNHEI_CRIT,                     &  ! new
             ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr,           &
             RHOSN,PATM,QVATM,QCATM,                             &
-            GLW,GSWnew,EMISS,RNET,IVGTYP,                       &
-            QKMS,TKMS,PC,CST,dripsn,                            &
+            GLW,GSWnew,GSWin,EMISS,RNET,IVGTYP,                 &
+            QKMS,TKMS,PC,CST,dripsn,infwater,                   &
             RHO,VEGFRAC,ALB,ZNT,lai,                            &
             MYJ,                                                &
 !--- soil fixed fields
@@ -1834,7 +1954,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
             ILAND,PRCPMS,RAINF,NEWSN,snhei,SNWE,snfr,           &    
             RHOSN,PATM,QVATM,QCATM,                             &    
             GLW,GSWnew,EMISS,RNET,                              &    
-            QKMS,TKMS,RHO,                                      &    
+            QKMS,TKMS,RHO,myj,                                  &    
 !--- sea ice parameters
             ALB,ZNT,                                            &
             tice,rhosice,capice,thdifice,                       &    
@@ -1847,7 +1967,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
             SMELT,SNOH,SNFLX,SNOM,eeta,                         &    
             qfx,hfx,s,sublim,prcpl,fltot                        &    
                                                                 )    
-           edir1 = eeta
+           edir1 = eeta*1.e-3
            ec1 = 0.
            ett1 = 0.
            runoff1 = smelt
@@ -2007,11 +2127,12 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
 
        if(SEAICE .LT. 0.5) then
 !  LAND
-         CALL SOIL(                                             &
+         CALL SOIL(spp_lsm,rstochcol,fieldcol_sf,               &
 !--- input variables
             i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
-            PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,           &
-            EMISS,RNET,QKMS,TKMS,PC,cst,drip,rho,vegfrac,lai,   &
+            PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,GSWin,     &
+            EMISS,RNET,QKMS,TKMS,PC,cst,drip,infwater,          &
+            rho,vegfrac,lai,myj,                                &
 !--- soil fixed fields 
             QWRTZ,rhocs,dqm,qmin,ref,wilt,                      &
             psis,bclh,ksat,sat,cn,                              &
@@ -2037,7 +2158,7 @@ SUBROUTINE SFCTMP (delt,ktau,conflx,i,j,                      &
 !--- input variables
             i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
             PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSWnew,           &
-            EMISS,RNET,QKMS,TKMS,rho,                           &
+            EMISS,RNET,QKMS,TKMS,rho,myj,                       &
 !--- sea ice parameters
             tice,rhosice,capice,thdifice,                       &
             zsmain,zshalf,DTDZS,DTDZS2,tbq,                     &
@@ -2075,7 +2196,7 @@ END SUBROUTINE SFCTMP
 
        FUNCTION QSN(TN,T)
 !****************************************************************
-   REAL,     DIMENSION(1:4001),  INTENT(IN   )   ::  T
+   REAL,     DIMENSION(1:5001),  INTENT(IN   )   ::  T
    REAL,     INTENT(IN  )   ::  TN
 
       REAL    QSN, R,R1,R2
@@ -2086,9 +2207,9 @@ FUNCTION QSN(TN,T)
        IF(I.GE.1) goto 10
        I=1
        R=1.
-  10   IF(I.LE.4000) GOTO 20
-       I=4000
-       R=4001.
+  10   IF(I.LE.5000) GOTO 20
+       I=5000
+       R=5001.
   20   R1=T(I)
        R2=R-I
        QSN=(T(I+1)-R1)*R2 + R1
@@ -2100,12 +2221,13 @@ END FUNCTION QSN
 !------------------------------------------------------------------------
 
 
-        SUBROUTINE SOIL (                                    &
+        SUBROUTINE SOIL (spp_lsm,rstochcol, fieldcol_sf,     &
 !--- input variables
             i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,&
             PRCPMS,RAINF,PATM,QVATM,QCATM,                   &
-            GLW,GSW,EMISS,RNET,                              &
-            QKMS,TKMS,PC,cst,drip,rho,vegfrac,lai,           &
+            GLW,GSW,GSWin,EMISS,RNET,                        &
+            QKMS,TKMS,PC,cst,drip,infwater,rho,vegfrac,lai,  &
+            myj,                                             &
 !--- soil fixed fields
             QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat,    &
             sat,cn,zsmain,zshalf,DTDZS,DTDZS2,tbq,           &
@@ -2116,7 +2238,7 @@ SUBROUTINE SOIL (                                    &
             soilmois,tso,smfrkeep,keepfr,                    &
             dew,soilt,qvg,qsg,qcg,                           &
             edir1,ec1,ett1,eeta,qfx,hfx,s,evapl,             &
-            prcpl,fltot,runoff1,runoff2,mavail,soilice,            &
+            prcpl,fltot,runoff1,runoff2,mavail,soilice,      &
             soiliqw,infiltrp,smf)
 
 !*************************************************************
@@ -2185,6 +2307,7 @@ SUBROUTINE SOIL (                                    &
                                  nddzs                    !nddzs=2*(nzs-2)
    INTEGER,  INTENT(IN   )   ::  i,j,iland,isoil
    REAL,     INTENT(IN   )   ::  DELT,CONFLX
+   LOGICAL,  INTENT(IN   )   ::  myj
 !--- 3-D Atmospheric variables
    REAL,                                                         &
             INTENT(IN   )    ::                            PATM, &
@@ -2194,11 +2317,13 @@ SUBROUTINE SOIL (                                    &
    REAL,                                                         &
             INTENT(IN   )    ::                             GLW, &
                                                             GSW, &
+                                                          GSWin, &
                                                           EMISS, &
                                                             RHO, &
                                                              PC, &
                                                         VEGFRAC, &
                                                             lai, &
+                                                       infwater, &
                                                            QKMS, &
                                                            TKMS
 
@@ -2239,6 +2364,10 @@ SUBROUTINE SOIL (                                    &
                                                        SOILMOIS, &
                                                        SMFRKEEP
 
+   REAL,     DIMENSION(1:NZS), INTENT(IN)  ::          rstochcol
+   REAL,     DIMENSION(1:NZS), INTENT(INOUT) ::     fieldcol_sf
+
+
    REAL,     DIMENSION( 1:nzs )                                , &
              INTENT(INOUT)   ::                          KEEPFR
 
@@ -2267,6 +2396,7 @@ SUBROUTINE SOIL (                                    &
                                                           SOILT
 
 !-------- 1-d variables
+   INTEGER                   , INTENT(IN)  ::      spp_lsm   
    REAL,     DIMENSION(1:NZS), INTENT(OUT)  ::          SOILICE, &
                                                         SOILIQW
 
@@ -2287,6 +2417,7 @@ SUBROUTINE SOIL (                                    &
                                    fwsat,lwsat,told,smold
 
    REAL                        ::  soiltold,smf
+   REAL    :: soilres, alfa, fex, fex_fc, fc, psit
 
    INTEGER ::  nzs1,nzs2,k
 
@@ -2406,7 +2537,7 @@ SUBROUTINE SOIL (                                    &
 ! SOILPROP computes thermal diffusivity, and diffusional and
 !          hydraulic condeuctivities
 !******************************************************************
-          CALL SOILPROP(                                          &
+          CALL SOILPROP(spp_lsm,rstochcol,fieldcol_sf,       &
 !--- input variables
                nzs,fwsat,lwsat,tav,keepfr,                        &
                soilmois,soiliqw,soilice,                          &
@@ -2461,18 +2592,18 @@ SUBROUTINE SOIL (                                    &
 !--- water, and DRYCAN is the fraction of vegetated area where
 !--- transpiration may take place.
 
-          WETCAN=(CST/SAT)**CN
+          WETCAN=min(0.25,(CST/SAT)**CN)
 !          if(lai > 1.) wetcan=wetcan/lai
           DRYCAN=1.-WETCAN
 
 !**************************************************************
 !  TRANSF computes transpiration function
 !**************************************************************
-           CALL TRANSF(                                       &
+           CALL TRANSF(i,j,                                   &
 !--- input variables
-              nzs,nroot,soiliqw,tabs,                         &
+              nzs,nroot,soiliqw,tabs,lai,gswin,               &
 !--- soil fixed fields
-              dqm,qmin,ref,wilt,zshalf,                       &
+              dqm,qmin,ref,wilt,zshalf,pc,iland,              &
 !--- output variables
               tranf,transum)
 
@@ -2483,6 +2614,33 @@ SUBROUTINE SOIL (                                    &
            smold(k)=soilmois(k)
           enddo
 
+! Sakaguchi and Zeng (2009) - dry soil resistance to evaporation
+!      if (vgtype==11) then   ! MODIS wetland
+        alfa=1.
+!      else
+        fex=min(1.,soilmois(1)/dqm)
+        fex=max(fex,0.01)
+        psit=psis*fex ** (-bclh)
+        psit = max(-1.e5, psit)
+        alfa=min(1.,exp(g*psit/r_v/SOILT))
+!      endif
+        alfa=1.
+! field capacity
+        fc=max(qmin,ref*0.5)
+        fex_fc=1.
+      if((soilmois(1)+qmin) > fc .or. (qvatm-qvg) > 0.) then
+        soilres = 1.
+      else
+        fex_fc=min(1.,(soilmois(1)+qmin)/fc)
+        fex_fc=max(fex_fc,0.01)
+        soilres=0.25*(1.-cos(piconst*fex_fc))**2.
+      endif
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+!    if (i==421.and.j==280) then
+     print *,'fex,psit,psis,bclh,g,r_v,soilt,alfa,mavail,soilmois(1),fc,ref,soilres,fex_fc', &
+              fex,psit,psis,bclh,g,r_v,soilt,alfa,mavail,soilmois(1),fc,ref,soilres,fex_fc
+    endif
+
 !**************************************************************
 !  SOILTEMP soilves heat budget and diffusion eqn. in soil
 !**************************************************************
@@ -2493,9 +2651,9 @@ SUBROUTINE SOIL (                                    &
              delt,ktau,conflx,nzs,nddzs,nroot,                &
              PRCPMS,RAINF,                                    &
              PATM,TABS,QVATM,QCATM,EMISS,RNET,                &
-             QKMS,TKMS,PC,rho,vegfrac,                        &
+             QKMS,TKMS,PC,rho,vegfrac, lai,                   &
              thdif,cap,drycan,wetcan,                         & 
-             transum,dew,mavail,                              &
+             transum,dew,mavail,soilres,alfa,                 &
 !--- soil fixed fields
              dqm,qmin,bclh,zsmain,zshalf,DTDZS,tbq,           &
 !--- constants
@@ -2511,14 +2669,16 @@ SUBROUTINE SOIL (                                    &
 
         IF(QVATM.GE.QSG)THEN
           DEW=QKMS*(QVATM-QSG)
+          ETT1=0.
           DO K=1,NZS
             TRANSP(K)=0.
           ENDDO
         ELSE
+
           DO K=1,NROOT
             TRANSP(K)=VEGFRAC*RAS*QKMS*                       &
                     (QVATM-QSG)*                              &
-                     PC*TRANF(K)*DRYCAN/ZSHALF(NROOT+1)
+                    TRANF(K)*DRYCAN/ZSHALF(NROOT+1)
                IF(TRANSP(K).GT.0.) TRANSP(K)=0.
             ETT1=ETT1-TRANSP(K)
           ENDDO
@@ -2558,9 +2718,9 @@ SUBROUTINE SOIL (                                    &
 !-- input
                delt,nzs,nddzs,DTDZS,DTDZS2,RIW,                &
                zsmain,zshalf,diffu,hydro,                      &
-               QSG,QVG,QCG,QCATM,QVATM,-PRCPMS,                &
+               QSG,QVG,QCG,QCATM,QVATM,-infwater,              &
                QKMS,TRANSP,DRIP,DEW,0.,SOILICE,VEGFRAC,        &
-               0.,                                             &
+               0.,soilres,                                     &
 !-- soil properties
                DQM,QMIN,REF,KSAT,RAS,INFMAX,                   &
 !-- output
@@ -2603,43 +2763,49 @@ SUBROUTINE SOIL (                                    &
           EC1=0.
           EDIR1=0.
           ETT1=0.
+     if(myj) then
 !-- moisture flux for coupling with MYJ PBL
           EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
+          CST= CST-EETA*DELT*vegfrac
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
-!    IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then
-        print *,'Cond MYJ EETA',eeta,eeta*xlv
+!!!    IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then
+        print *,'Cond MYJ EETA',eeta,eeta*xlv, i,j
     ENDIF
-          QFX= XLV*EETA
+     else ! myj
 !-- actual moisture flux from RUC LSM
           EETA= - RHO*DEW
           CST=CST+DELT*DEW*RAS * vegfrac
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+!    IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then
 !    IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then
-       print *,'Cond RUC LSM EETA',EETA,eeta*xlv
+       print *,'Cond RUC LSM EETA',EETA,eeta*xlv, i,j
     ENDIF
+     endif ! myj
+          QFX= XLV*EETA
         ELSE
 ! ---  evaporation
-          EDIR1 =-(1.-vegfrac)*QKMS*RAS*                      &
+          EDIR1 =-soilres*(1.-vegfrac)*QKMS*RAS*                      &
                   (QVATM-QVG)
           CMC2MS=CST/DELT*RAS
-          EC1 = Q1 * WETCAN*vegfrac
+          EC1 = Q1 * WETCAN * vegfrac
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
-     IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then
+!     IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then
        print *,'CST before update=',cst
        print *,'EC1=',EC1,'CMC2MS=',CMC2MS
      ENDIF
-    ENDIF
+!    ENDIF
 
           CST=max(0.,CST-EC1 * DELT)
 
 !      if (EC1 > CMC2MS) then
-!test          EC1 = min(cmc2ms,ec1)
+!          EC1 = min(cmc2ms,ec1)
 !          CST = 0.
 !      endif
 
+     if (myj) then
 !-- moisture flux for coupling with MYJ PBL
-          EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3
-          QFX= XLV * EETA
+          EETA=-soilres*QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3
+     else ! myj
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
 !    IF(i.eq.440.and.j.eq.180.or. QFX.gt.1000..or.i.eq.417.and.j.eq.540) then
        print *,'QKMS,RAS,QVATM/(1.+QVATM),QVG/(1.+QVG),QSG ', &
@@ -2647,14 +2813,17 @@ SUBROUTINE SOIL (                                    &
        print *,'Q1*(1.-vegfrac),EDIR1',Q1*(1.-vegfrac),EDIR1
        print *,'CST,WETCAN,DRYCAN',CST,WETCAN,DRYCAN
        print *,'EC1=',EC1,'ETT1=',ETT1,'CMC2MS=',CMC2MS,'CMC2MS*ras=',CMC2MS*ras
-       print *,'MYJ EETA',eeta,eeta*xlv
+!       print *,'MYJ EETA',eeta,eeta*xlv
     ENDIF
 !-- actual moisture flux from RUC LSM
           EETA = (EDIR1 + EC1 + ETT1)*1.E3
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+!    IF(i.eq.374.and.j.eq.310.or. EETA.gt.0.0004) then
 !    IF(i.eq.440.and.j.eq.180 .or. qfx.gt.1000..or.i.eq.417.and.j.eq.540) then
         print *,'RUC LSM EETA',EETA,eeta*xlv
     ENDIF
+     endif ! myj
+          QFX= XLV * EETA
         ENDIF
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
      print *,'potential temp HFT ',HFT
@@ -2696,7 +2865,7 @@ SUBROUTINE SICE (                                       &
 !--- input variables
             i,j,iland,isoil,delt,ktau,conflx,nzs,nddzs,nroot,   &
             PRCPMS,RAINF,PATM,QVATM,QCATM,GLW,GSW,              &
-            EMISS,RNET,QKMS,TKMS,rho,                           &
+            EMISS,RNET,QKMS,TKMS,rho,myj,                       &
 !--- sea ice parameters
             tice,rhosice,capice,thdifice,                       &
             zsmain,zshalf,DTDZS,DTDZS2,tbq,                     &
@@ -2721,6 +2890,7 @@ SUBROUTINE SICE (                                       &
                                  nddzs                    !nddzs=2*(nzs-2)
    INTEGER,  INTENT(IN   )   ::  i,j,iland,isoil
    REAL,     INTENT(IN   )   ::  DELT,CONFLX
+   LOGICAL,  INTENT(IN   )   ::  myj
 !--- 3-D Atmospheric variables
    REAL,                                                         &
             INTENT(IN   )    ::                            PATM, &
@@ -2895,32 +3065,38 @@ SUBROUTINE SICE (                                       &
           Q1=-QKMS*RAS*(QVATM - QSG)
         IF (Q1.LE.0.) THEN
 ! ---  condensation
+     if(myj) then
 !-- moisture flux for coupling with MYJ PBL
           EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
        print *,'MYJ EETA',eeta
     ENDIF
-          QFX= XLS*EETA
+     else ! myj
 !-- actual moisture flux from RUC LSM
           DEW=QKMS*(QVATM-QSG)
           EETA= - RHO*DEW
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
        print *,'RUC LSM EETA',eeta
     ENDIF
+     endif ! myj
+          QFX= XLS*EETA
         ELSE
 ! ---  evaporation
+     if(myj) then
 !-- moisture flux for coupling with MYJ PBL
           EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
        print *,'MYJ EETA',eeta
     ENDIF
-! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
-          QFX= XLS * EETA
+     else ! myj
+! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************
 !-- actual moisture flux from RUC LSM
           EETA = Q1*1.E3
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
        print *,'RUC LSM EETA',eeta
     ENDIF
+     endif ! myj
+          QFX= XLS * EETA
         ENDIF
           EVAPL=EETA
 
@@ -2952,15 +3128,16 @@ END SUBROUTINE SICE
 
 
 
-        SUBROUTINE SNOWSOIL (                                  &
+        SUBROUTINE SNOWSOIL (spp_lsm,rstochcol,fieldcol_sf,&
 !--- input variables
              i,j,isoil,delt,ktau,conflx,nzs,nddzs,nroot,       &
              meltfactor,rhonewsn,SNHEI_CRIT,                   & ! new
              ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,SNOWFRAC,   &
              RHOSN,                                            &
              PATM,QVATM,QCATM,                                 &
-             GLW,GSW,EMISS,RNET,IVGTYP,                        &
-             QKMS,TKMS,PC,cst,drip,rho,vegfrac,alb,znt,lai,    & 
+             GLW,GSW,GSWin,EMISS,RNET,IVGTYP,                  &
+             QKMS,TKMS,PC,cst,drip,infwater,                   &
+             rho,vegfrac,alb,znt,lai,                          & 
              MYJ,                                              &
 !--- soil fixed fields
              QWRTZ,rhocs,dqm,qmin,ref,wilt,psis,bclh,ksat,     &
@@ -3068,10 +3245,12 @@ SUBROUTINE SNOWSOIL (                                  &
    REAL                                                        , &
             INTENT(IN   )    ::                             GLW, &
                                                             GSW, &
+                                                          GSWin, &
                                                             RHO, &
                                                              PC, &
                                                         VEGFRAC, &
                                                             lai, &
+                                                       infwater, &
                                                            QKMS, &
                                                            TKMS
 
@@ -3106,6 +3285,8 @@ SUBROUTINE SNOWSOIL (                                  &
 
    REAL,     DIMENSION(1:5001), INTENT(IN)  ::              TBQ
 
+   REAL,     DIMENSION(1:NZS), INTENT(IN)  ::          rstochcol
+   REAL,     DIMENSION(1:NZS), INTENT(INOUT) ::     fieldcol_sf
 
 !--- input/output variables
 !-------- 3-d soil moisture and temperature
@@ -3165,6 +3346,7 @@ SUBROUTINE SNOWSOIL (                                  &
    REAL,     INTENT(OUT)                    ::              RSM, &
                                                       SNWEPRINT, &
                                                      SNHEIPRINT
+   INTEGER,  INTENT(IN)                    ::       spp_lsm 
 !--- Local variables
 
 
@@ -3347,7 +3529,7 @@ SUBROUTINE SNOWSOIL (                                  &
 ! SOILPROP computes thermal diffusivity, and diffusional and
 !          hydraulic condeuctivities
 !******************************************************************
-          CALL SOILPROP(                                         &
+          CALL SOILPROP(spp_lsm,rstochcol,fieldcol_sf,      &
 !--- input variables
                nzs,fwsat,lwsat,tav,keepfr,                       &
                soilmois,soiliqw,soilice,                         &
@@ -3414,9 +3596,9 @@ SUBROUTINE SNOWSOIL (                                  &
 !--- the saturation is reached. After the canopy saturation is reached
 !--- DRIP in the solid form will be added to SNOW cover.
 
-   SNWE=SNWE-vegfrac*NEWSNOW*RHOnewSN*1.E-3                      &
+!   SNWE=SNWE-vegfrac*NEWSNOW*RHOnewSN*1.E-3                      &
 !   SNWE=SNHEI*RHOSN*1.e-3-vegfrac*NEWSNOW*RHOnewSN*1.E-3                      &
-                  + DRIP                                         
+!                  + DRIP                                         
 
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
       print *,'SNWE after subtracting intercepted snow - snwe=',snwe,vegfrac,cst
@@ -3424,8 +3606,8 @@ SUBROUTINE SNOWSOIL (                                  &
 
 !       ENDIF  ! vegfrac=0.
  
-        DRIP=0.
-        SNHEI=SNWE*1.e3/RHOSN
+!        DRIP=0.
+!        SNHEI=SNWE*1.e3/RHOSN
           SNWEPR=SNWE
 
 !  check if all snow can evaporate during DT
@@ -3436,18 +3618,18 @@ SUBROUTINE SNOWSOIL (                                  &
             SNWE=0.
          ENDIF
 
-          WETCAN=(CST/SAT)**CN
+          WETCAN=min(0.25,(CST/SAT)**CN)
 !          if(lai > 1.) wetcan=wetcan/lai
           DRYCAN=1.-WETCAN
 
 !**************************************************************
 !  TRANSF computes transpiration function
 !**************************************************************
-           CALL TRANSF(                                       &
+           CALL TRANSF(i,j,                                   &
 !--- input variables
-              nzs,nroot,soiliqw,tabs,                         &
+              nzs,nroot,soiliqw,tabs,lai,gswin,               &
 !--- soil fixed fields
-              dqm,qmin,ref,wilt,zshalf,                       & 
+              dqm,qmin,ref,wilt,zshalf,pc,iland,              & 
 !--- output variables
               tranf,transum)
 
@@ -3496,7 +3678,7 @@ SUBROUTINE SNOWSOIL (                                  &
 ! Evaporation
           DO K=1,NROOT
             TRANSP(K)=vegfrac*RAS*FQ*(QVATM-QSG)              &
-                     *PC*tranf(K)*DRYCAN/zshalf(NROOT+1)
+                     *tranf(K)*DRYCAN/zshalf(NROOT+1)
 !           IF(TRANSP(K).GT.0.) TRANSP(K)=0.
             ETT1=ETT1-TRANSP(K)
           ENDDO
@@ -3543,10 +3725,10 @@ SUBROUTINE SNOWSOIL (                                  &
 !-- input
                delt,nzs,nddzs,DTDZS,DTDZS2,RIW,                    &
                zsmain,zshalf,diffu,hydro,                          &
-               QSG,QVG,QCG,QCATM,QVATM,-PRCPMS,                    &
+               QSG,QVG,QCG,QCATM,QVATM,-INFWATER,                  &
                QKMS,TRANSP,0.,                                     &
                0.,SMELT,soilice,vegfrac,                           &
-               snowfrac,                                           &
+               snowfrac,1.,                                        &
 !-- soil properties
                DQM,QMIN,REF,KSAT,RAS,INFMAX,                       &
 !-- output
@@ -3605,12 +3787,14 @@ SUBROUTINE SNOWSOIL (                                  &
         EC1=0.
         ETT1=0.
 ! ---  condensation
+     if(myj) then
 !-- moisture flux for coupling with MYJ PBL
           EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
+          CST= CST-EETA*DELT*vegfrac
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
       print *,'MYJ EETA cond', EETA
     ENDIF
-          QFX= XLVm*EETA
+     else ! myj
 !-- actual moisture flux from RUC LSM
           DEW=QKMS*(QVATM-QSG)
           EETA= - RHO*DEW
@@ -3618,6 +3802,8 @@ SUBROUTINE SNOWSOIL (                                  &
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
       print *,'RUC LSM EETA cond',EETA
     ENDIF
+     endif ! myj
+          QFX= XLVm*EETA
         ELSE
 ! ---  evaporation
         EDIR1 = Q1*UMVEG *BETA
@@ -3637,18 +3823,21 @@ SUBROUTINE SNOWSOIL (                                  &
      print *,'EC1,CMC2MS',EC1,CMC2MS
     ENDIF
 
+     if(myj) then
 !-- moisture flux for coupling with MYJ PBL
         EETA=-(QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3)*BETA
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
       print *,'MYJ EETA', EETA*XLVm,EETA
     ENDIF
-! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
-        QFX= XLVm * EETA
+     else ! myj
+! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************
 !-- actual moisture flux from RUC LSM
         EETA = (EDIR1 + EC1 + ETT1)*1.E3
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
       print *,'RUC LSM EETA',EETA*XLVm,EETA
     ENDIF
+     endif ! myj
+        QFX= XLVm * EETA
        ENDIF
         S=SNFLX
 !        sublim=eeta
@@ -3678,7 +3867,7 @@ SUBROUTINE SNOWSEAICE(                               &
             ILAND,PRCPMS,RAINF,NEWSNOW,snhei,SNWE,snowfrac,     &
             RHOSN,PATM,QVATM,QCATM,                             &
             GLW,GSW,EMISS,RNET,                                 &
-            QKMS,TKMS,RHO,                                      &
+            QKMS,TKMS,RHO,myj,                                  &
 !--- sea ice parameters
             ALB,ZNT,                                            &
             tice,rhosice,capice,thdifice,                       &
@@ -3710,6 +3899,7 @@ SUBROUTINE SNOWSEAICE(                               &
                                  meltfactor, snhei_crit
    real                      ::  rhonewcsn
 
+   LOGICAL,  INTENT(IN   )   ::  myj
 !--- 3-D Atmospheric variables
    REAL,                                                         &
             INTENT(IN   )    ::                            PATM, &
@@ -4285,7 +4475,7 @@ SUBROUTINE SNOWSEAICE(                               &
 
          xsn=(rhosn*(snwe-rsm)+1.e3*rsm)/                            &
              snwe
-         rhosn=MIN(XSN,400.)
+         rhosn=MIN(MAX(76.9,XSN),500.)
 
         RHOCSN=2090.* RHOSN
         thdifsn = 0.265/RHOCSN
@@ -4336,21 +4526,27 @@ SUBROUTINE SNOWSEAICE(                               &
         Q1 = - FQ*RAS* (QVATM - QSG)
         IF (Q1.LT.0.) THEN
 ! ---  condensation
+      if(myj) then
 !-- moisture flux for coupling with MYJ PBL
           EETA=-QKMS*RAS*(QVATM/(1.+QVATM) - QSG/(1.+QSG))*1.E3
-          QFX= XLVm*EETA
+      else ! myj
 !-- actual moisture flux from RUC LSM
           DEW=QKMS*(QVATM-QSG)
           EETA= - RHO*DEW
+      endif ! myj
+          QFX= XLVm*EETA
           sublim = EETA
         ELSE
 ! ---  evaporation
+      if(myj) then
 !-- moisture flux for coupling with MYJ PBL
           EETA=-QKMS*RAS*BETA*(QVATM/(1.+QVATM) - QVG/(1.+QVG))*1.E3
-! to convert from kg m-2 s-1 to m s-1: 1/rho water=1.e-3************
-          QFX= XLVm * EETA
+      else ! myj
+! to convert from m s-1 to kg m-2 s-1: *rho water=1.e3************
 !-- actual moisture flux from RUC LSM
           EETA = Q1*BETA*1.E3
+      endif ! myj
+          QFX= XLVm * EETA
           sublim = EETA
         ENDIF
 
@@ -4422,9 +4618,9 @@ SUBROUTINE SOILTEMP(                             &
            delt,ktau,conflx,nzs,nddzs,nroot,                &
            PRCPMS,RAINF,PATM,TABS,QVATM,QCATM,              &
            EMISS,RNET,                                      &
-           QKMS,TKMS,PC,RHO,VEGFRAC,                        &
+           QKMS,TKMS,PC,RHO,VEGFRAC,lai,                    &
            THDIF,CAP,DRYCAN,WETCAN,                         &
-           TRANSUM,DEW,MAVAIL,                              &
+           TRANSUM,DEW,MAVAIL,soilres,alfa,                 &
 !--- soil fixed fields
            DQM,QMIN,BCLH,                                   &
            ZSMAIN,ZSHALF,DTDZS,TBQ,                         &
@@ -4504,6 +4700,7 @@ SUBROUTINE SOILTEMP(                             &
                                                            RNET, &  
                                                              PC, &
                                                         VEGFRAC, &
+                                                            LAI, &
                                                             DEW, & 
                                                            QKMS, &
                                                            TKMS
@@ -4514,6 +4711,10 @@ SUBROUTINE SOILTEMP(                             &
                                                            BCLH, &
                                                             DQM, &
                                                            QMIN
+   REAL                                                        , &
+            INTENT(IN   )    ::                                  &
+                                                   soilres,alfa
+
 
    REAL,     INTENT(IN   )   ::                              CP, &
                                                             CVW, &
@@ -4563,6 +4764,7 @@ SUBROUTINE SOILTEMP(                             &
 
    INTEGER ::  nzs1,nzs2,k,k1,kn,kk, iter
 
+
 !-----------------------------------------------------------------
 
         iter=0
@@ -4603,18 +4805,12 @@ SUBROUTINE SOILTEMP(                             &
 !--- THE HEAT BALANCE EQUATION (Smirnova et al., 1996, EQ. 21,26)
 
         RHCS=CAP(1)
-! fex > 1. - reduces direct evaporation, and makes surface forecast drier
-!       and warmer
-!        fex=1.5
-        fex=1.
-        H=MAVAIL**fex
-!        IF(DEW.NE.0.)THEN
-!          DRYCAN=0.
-!          WETCAN=1.
-!        ENDIf
-        TRANS=PC*TRANSUM*DRYCAN/ZSHALF(NROOT+1)
+
+        H=MAVAIL
+
+        TRANS=TRANSUM*DRYCAN/ZSHALF(NROOT+1)
         CAN=WETCAN+TRANS
-        UMVEG=1.-VEGFRAC
+        UMVEG=(1.-VEGFRAC) * soilres
  2111   continue
         FKT=TKMS
         D1=cotso(NZS1)
@@ -4641,15 +4837,19 @@ SUBROUTINE SOILTEMP(                             &
         +RAINF*CVW*PRCPMS*max(273.15,TABS)                            &
          )/TDENOM
         AA1=AA+CC
+!        AA1=AA*alfa+CC
         PP=PATM*1.E3
         AA1=AA1/PP
         CALL VILKA(TN,AA1,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil)
         TQ2=QVATM
         TX2=TQ2*(1.-H)
         Q1=TX2+H*QS1
+!        Q1=alfa*QS1
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+!    if (i==421.and.j==280) then
         print *,'VILKA1 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1
     ENDIF
+!with alfa        go to 100
         IF(Q1.LT.QS1) GOTO 100
 !--- if no saturation - goto 100
 !--- if saturation - goto 90
@@ -4658,24 +4858,34 @@ SUBROUTINE SOILTEMP(                             &
         TSO(1)=TS1
         QCG=max(0.,Q1-QS1)
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+!    if (i==421.and.j==280) then
         print *,'90 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1)
     ENDIF
-
         GOTO 200
   100   BB=BB-AA*TX2
         AA=(AA*H+CC)/PP
-
         CALL VILKA(TN,AA,BB,PP,QS1,TS1,TBQ,KTAU,i,j,iland,isoil)
         Q1=TX2+H*QS1
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
 !     if(i.eq.279.and.j.eq.263) then
+!    if (i==421.and.j==280) then
         print *,'VILKA2 - TS1,QS1,TQ2,H,TX2,Q1',TS1,QS1,TQ2,H,TX2,Q1
     ENDIF
-        IF(Q1.GT.QS1) GOTO 90
+        IF(Q1.GE.QS1) GOTO 90
+!with alfa  100  continue
         QSG=QS1
         QVG=Q1
+!   if( QS1>QVATM .and. QVATM > QVG) then
+! very dry soil 
+!     print *,'very dry soils mavail,qvg,qs1,qvatm,ts1',i,j,mavail,qvg,qs1,qvatm,ts1
+!        QVG = QVATM
+!   endif
         TSO(1)=TS1
         QCG=0.
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+!    if (i==421.and.j==280) then
+       print *,'q1,qsg,qvg,qvatm,alfa,h',q1,qsg,qvg,qvatm,alfa,h
+    endif
   200   CONTINUE
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
         print *,'200 QVG,QSG,QCG,TSO(1)',QVG,QSG,QCG,TSO(1)
@@ -4709,7 +4919,7 @@ SUBROUTINE SOILTEMP(                             &
 
          X= (cp*rho*r211+rhcs*zsmain(2)*0.5/delt)*(SOILT-TN) + &
             XLV*rho*r211*(QVG-QGOLD) 
-
+!
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
         print*,'SOILTEMP storage, i,j,x,soilt,tn,qvg,qvgold', &
                                   i,j,x,soilt,tn,qvg,qgold
@@ -5078,7 +5288,7 @@ SUBROUTINE SNOWTEMP(                                    &
         EPOT=-QKMS*(QVATM-QGOLD)
         RHCS=CAP(1)
         H=1.
-        TRANS=PC*TRANSUM*DRYCAN/ZSHALF(NROOT+1)
+        TRANS=TRANSUM*DRYCAN/ZSHALF(NROOT+1)
         CAN=WETCAN+TRANS
         UMVEG=1.-VEGFRAC
         FKT=TKMS
@@ -5310,7 +5520,7 @@ SUBROUTINE SNOWTEMP(                                    &
 ! ---  evaporation
           DO K=1,NROOT
             TRANSP(K)=-VEGFRAC*q1                                     &
-                      *PC*TRANF(K)*DRYCAN/zshalf(NROOT+1)
+                      *TRANF(K)*DRYCAN/zshalf(NROOT+1)
 !           IF(TRANSP(K).GT.0.) TRANSP(K)=0.
             ETT1=ETT1-TRANSP(K)
           ENDDO
@@ -5319,7 +5529,7 @@ SUBROUTINE SNOWTEMP(                                    &
           enddo
 
         EDIR1 = Q1*UMVEG * BETA
-        EC1 = Q1 * WETCAN*vegfrac
+        EC1 = Q1 * WETCAN * vegfrac
         CMC2MS=CST/DELT*RAS
 !        EC1=MIN(CMC2MS,EC1)
         EETA = (EDIR1 + EC1 + ETT1)*1.E3
@@ -5435,7 +5645,7 @@ SUBROUTINE SNOWTEMP(                                    &
 !*** Eq. 9 (with my correction) in Koren et al. (1999)
           xsn=(rhosn*(snwe-rsm)+1.e3*rsm)/                            &
               snwe
-          rhosn=MIN(XSN,400.)
+          rhosn=MIN(MAX(76.9,XSN),500.)
 
           RHOCSN=2090.* RHOSN
           thdifsn = 0.265/RHOCSN
@@ -5548,6 +5758,8 @@ SUBROUTINE SNOWTEMP(                                    &
         else
           tsnav=0.5*(soilt+tso(1)) - 273.15
         endif
+      ELSE
+          tsnav= soilt - 273.15
       ENDIF
 
 !------------------------------------------------------------------------
@@ -5561,7 +5773,7 @@ SUBROUTINE SOILMOIST (                                  &
               ZSMAIN,ZSHALF,DIFFU,HYDRO,                        &
               QSG,QVG,QCG,QCATM,QVATM,PRCP,                     &
               QKMS,TRANSP,DRIP,                                 &
-              DEW,SMELT,SOILICE,VEGFRAC,SNOWFRAC,               &
+              DEW,SMELT,SOILICE,VEGFRAC,SNOWFRAC,soilres,       &
 !--soil properties
               DQM,QMIN,REF,KSAT,RAS,INFMAX,                     &
 !--output
@@ -5628,7 +5840,7 @@ SUBROUTINE SOILMOIST (                                  &
    REAL,     INTENT(IN   )   ::    QSG,QVG,QCG,QCATM,QVATM     , &
                                    QKMS,VEGFRAC,DRIP,PRCP      , &
                                    DEW,SMELT,SNOWFRAC          , &
-                                   DQM,QMIN,REF,KSAT,RAS,RIW
+                                   DQM,QMIN,REF,KSAT,RAS,RIW,SOILRES
                          
 ! output
 
@@ -5732,7 +5944,7 @@ SUBROUTINE SOILMOIST (                                  &
 ! --- MOISTURE BALANCE BEGINS HERE
 
           TRANS=TRANSP(1)
-          UMVEG=1.-VEGFRAC
+          UMVEG=(1.-VEGFRAC)*soilres
 
           RUNOFF=0.
           RUNOFF2=0.
@@ -5750,7 +5962,9 @@ SUBROUTINE SOILMOIST (                                  &
 
   191   format (f23.19)
 
-        TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT
+!        TOTLIQ=UMVEG*PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT
+
+        TOTLIQ=PRCP-DRIP/DELT-UMVEG*DEW*RAS-SMELT
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
 print *,'UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT', &
          UMVEG*PRCP,DRIP/DELT,UMVEG*DEW*RAS,SMELT
@@ -5878,7 +6092,7 @@ SUBROUTINE SOILMOIST (                                  &
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
    print *,'FLXSAT,FLX,DELT',FLXSAT,FLX,DELT,RUNOFF2
     ENDIF
-!            RUNOFF2=(FLXSAT-FLX)*DELT
+!            RUNOFF2=(FLXSAT-FLX)
             RUNOFF=RUNOFF+(FLXSAT-FLX)
           ELSE
             SOILMOIS(1)=min(dqm,max(1.e-8,QQ))
@@ -5889,8 +6103,8 @@ SUBROUTINE SOILMOIST (                                  &
    print *,'COSMC,RHSMC',COSMC,RHSMC
     ENDIF
 !--- FINAL SOLUTION FOR SOILMOIS 
-          DO K=2,NZS1
-!          DO K=2,NZS
+!          DO K=2,NZS1
+          DO K=2,NZS
             KK=NZS-K+1
             QQ=COSMC(KK)*SOILMOIS(K-1)+RHSMC(KK)
 !            QQ=COSMC(KK)*SOILIQW(K-1)+RHSMC(KK)
@@ -5902,18 +6116,18 @@ SUBROUTINE SOILMOIST (                                  &
            ELSE IF(QQ.GT.DQM) THEN
 !-- saturation
             SOILMOIS(K)=DQM
-!             IF(K.EQ.NZS)THEN
+             IF(K.EQ.NZS)THEN
     IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
    print *,'hydro(k),QQ,DQM,k',hydro(k),QQ,DQM,k
     ENDIF
-!               RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSMAIN(K)-ZSHALF(K))
+               RUNOFF2=RUNOFF2+((QQ-DQM)*(ZSMAIN(K)-ZSHALF(K)))/DELT
 !              RUNOFF2=RUNOFF2+(QQ-DQM)*hydro(k)
 !   print *,'RUNOFF2=',RUNOFF2
-!             ELSE
+             ELSE
 !   print *,'QQ,DQM,k',QQ,DQM,k
-!               RUNOFF2=RUNOFF2+(QQ-DQM)*(ZSHALF(K+1)-ZSHALF(K))
+               RUNOFF2=RUNOFF2+((QQ-DQM)*(ZSHALF(K+1)-ZSHALF(K)))/DELT
 !              RUNOFF2=RUNOFF2+(QQ-DQM)*hydro(k)
-!             ENDIF
+             ENDIF
            ELSE
             SOILMOIS(K)=min(dqm,max(1.e-8,QQ))
            END IF
@@ -5934,7 +6148,7 @@ END SUBROUTINE SOILMOIST
 !-------------------------------------------------------------------
 
 
-            SUBROUTINE SOILPROP(                                  &
+          SUBROUTINE SOILPROP(spp_lsm,rstochcol,fieldcol_sf, &
 !--- input variables
          nzs,fwsat,lwsat,tav,keepfr,                              &
          soilmois,soiliqw,soilice,                                &
@@ -5994,6 +6208,9 @@ SUBROUTINE SOILPROP(                                  &
                                                          XLMELT, &
                                                             G0_P
 
+   REAL,     DIMENSION(1:NZS), INTENT(IN)  ::          rstochcol
+   REAL,     DIMENSION(1:NZS), INTENT(INOUT) ::      fieldcol_sf
+   INTEGER,  INTENT(IN   )   ::                     spp_lsm      
 
 
 !--- output variables
@@ -6137,9 +6354,14 @@ SUBROUTINE SOILPROP(                                  &
          endif
 
        ENDDO
-    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
-       print *,'hydro=',hydro
-    ENDIF
+
+!        perturb hydrolic conductivity by 10-30%, not more than 50%
+         if (spp_lsm==1) then 
+         DO K=1,NZS !lala
+            fieldcol_sf(k)=hydro(k)*rstochcol(k)
+            hydro(k)=hydro(k)*(1+rstochcol(k))
+         ENDDO
+         ENDIF
 
 !       RETURN
 !       END
@@ -6149,11 +6371,11 @@ END SUBROUTINE SOILPROP
 !-----------------------------------------------------------------------
 
 
-           SUBROUTINE TRANSF(                                    &
+           SUBROUTINE TRANSF(i,j,                                &
 !--- input variables
-              nzs,nroot,soiliqw,tabs,                            &
+              nzs,nroot,soiliqw,tabs,lai,gswin,                  &
 !--- soil fixed fields
-              dqm,qmin,ref,wilt,zshalf,                          &
+              dqm,qmin,ref,wilt,zshalf,pc,iland,                 &
 !--- output variables
               tranf,transum)
 
@@ -6171,15 +6393,16 @@ SUBROUTINE TRANSF(                                    &
 
 !--- input variables
 
-   INTEGER,  INTENT(IN   )   ::  nroot,nzs
+   INTEGER,  INTENT(IN   )   ::  i,j,nroot,nzs, iland
 
    REAL                                                        , &
-            INTENT(IN   )    ::                            TABS
+            INTENT(IN   )    ::                GSWin, TABS, lai
 !--- soil properties
    REAL                                                        , &
             INTENT(IN   )    ::                             DQM, &
                                                            QMIN, &
                                                             REF, &
+                                                             PC, &
                                                            WILT
 
    REAL,     DIMENSION(1:NZS), INTENT(IN)  ::          soiliqw,  &
@@ -6195,12 +6418,13 @@ SUBROUTINE TRANSF(                                    &
 
 !-- for non-linear root distribution
    REAL    ::  gx,sm1,sm2,sm3,sm4,ap0,ap1,ap2,ap3,ap4
-   REAL    ::  FTEM
+   REAL    ::  FTEM, PCtot, fsol, f1, cmin, cmax, totcnd
    REAL,     DIMENSION(1:NZS)   ::           PART
 !--------------------------------------------------------------------
 
         do k=1,nzs
            part(k)=0.
+           tranf(k)=0.
         enddo
 
         transum=0.
@@ -6221,14 +6445,6 @@ SUBROUTINE TRANSF(                                    &
           if(gx.lt.0.) gx=0.
         DID=zshalf(2)
           part(1)=DID*gx
-!--- air temperature function
-!     Avissar (1985) and AX 7/95
-        IF (TABS .LE. 302.15) THEN
-          FTEM = 1.0 / (1.0 + EXP(-0.41 * (TABS - 282.05)))
-        ELSE
-          FTEM = 1.0 / (1.0 + EXP(0.5 * (TABS - 314.0)))
-        ENDIF
-!---
         IF(TOTLIQ.GT.REF) THEN
           TRANF(1)=DID
         ELSE IF(TOTLIQ.LE.WILT) THEN
@@ -6237,10 +6453,7 @@ SUBROUTINE TRANSF(                                    &
           TRANF(1)=(TOTLIQ-WILT)/(REF-WILT)*DID
         ENDIF 
 !-- uncomment next line for non-linear root distribution
-! change made in Nov.2014
-!           TRANF(1)=part(1)
-! linear root distribution
-          TRANF(1)=TRANF(1)*FTEM
+!          TRANF(1)=part(1)
 
         DO K=2,NROOT
         totliq=soiliqw(k)+qmin
@@ -6264,15 +6477,80 @@ SUBROUTINE TRANSF(                                    &
                 /(REF-WILT)*DID
         ENDIF
 !-- uncomment next line for non-linear root distribution
-!cc          TRANF(k)=part(k)
-          TRANF(k)=TRANF(k)*FTEM
+!          TRANF(k)=part(k)
         END DO
 
+! For LAI> 3 =>  transpiration at potential rate (F.Tardieu, 2013)
+      if(lai > 4.) then
+        pctot=0.8
+      else
+        pctot=pc
+!- 26aug16-  next 2 lines could lead to LH increase and higher 2-m Q during the day
+!        pctot=min(0.8,pc*lai)
+!        pctot=min(0.8,max(pc,pc*lai))
+      endif
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+!    if (i==421.and.j==280) then
+     print *,'i,j,pctot,lai,pc',i,j,pctot,lai,pc
+    ENDIF
+!---
+!--- air temperature function
+!     Avissar (1985) and AX 7/95
+        IF (TABS .LE. 302.15) THEN
+          FTEM = 1.0 / (1.0 + EXP(-0.41 * (TABS - 282.05)))
+        ELSE
+          FTEM = 1.0 / (1.0 + EXP(0.5 * (TABS - 314.0)))
+        ENDIF
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+!    if (i==421.and.j==280) then
+     print *,'i,j,tabs,ftem',i,j,tabs,ftem
+    ENDIF
+!--- incoming solar function
+     cmin = 1./rsmax_data
+     cmax = 1./rstbl(iland)
+    if(lai > 1.) then
+     cmax = lai/rstbl(iland) ! max conductance
+    endif
+! Noihlan & Planton (1988)
+       f1=0.
+!    if(lai > 0.01) then
+!       f1 = 1.1/lai*gswin/rgltbl(iland)! f1=0. when GSWin=0.
+!       fsol = (f1+cmin/cmax)/(1.+f1)
+!       fsol=min(1.,fsol)
+!    else
+!       fsol=cmin/cmax
+!    endif
+!     totcnd = max(lai/rstbl(iland), pctot * ftem * f1) 
+! Mahrer & Avissar (1982), Avissar et al. (1985)
+     if (GSWin < rgltbl(iland)) then
+      fsol = 1. / (1. + exp(-0.034 * (GSWin - 3.5)))
+     else
+      fsol = 1.
+     endif
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+!    if (i==421.and.j==280) then
+     print *,'i,j,GSWin,lai,f1,fsol',i,j,gswin,lai,f1,fsol
+    ENDIF
+!--- total conductance
+     totcnd =(cmin + (cmax - cmin)*pctot*ftem*fsol)/cmax
+
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+!    if (i==421.and.j==280) then
+     print *,'i,j,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd'  &
+             ,i,j,iland,RGLTBL(iland),RSTBL(iland),RSMAX_DATA,totcnd
+    ENDIF
+
 !-- TRANSUM - total for the rooting zone
           transum=0.
         DO K=1,NROOT
-          transum=transum+tranf(k)
+! linear root distribution
+         TRANF(k)=max(cmin,TRANF(k)*totcnd)
+         transum=transum+tranf(k)
         END DO
+    IF ( wrf_at_debug_level(LSMRUC_DBG_LVL) ) THEN
+!    if (i==421.and.j==280) then
+      print *,'i,j,transum,TRANF',i,j,transum,tranf
+    endif
 
 !-----------------------------------------------------------------
    END SUBROUTINE TRANSF
diff --git a/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F b/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F
index eacf433d..75c30677 100644
--- a/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F
+++ b/wrfv2_fire/phys/module_sf_sfcdiags_ruclsm.F
@@ -5,7 +5,7 @@ MODULE module_sf_sfcdiags_ruclsm
 CONTAINS
 
    SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CQS,CQS2,CHS,CHS2,T2,TH2,Q2,  &
-                     T3D,QV3D,RHO3D,P3D,PSFC2D,                              &
+                     T3D,QV3D,RHO3D,P3D,PSFC2D,SNOW,                         &
                      CP,R_d,ROVCP,                                           &
                      ids,ide, jds,jde, kds,kde,                              &
                      ims,ime, jms,jme, kms,kme,                              &        
@@ -19,6 +19,7 @@ SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CQS,CQS2,CHS,CHS2,T2,TH2,Q2,  &
       REAL,     DIMENSION( ims:ime, jms:jme )                    , &
                 INTENT(IN)                  ::                HFX, &
                                                               QFX, &
+                                                             SNOW, &
                                                               TSK, &
                                                              QSFC
       REAL,     DIMENSION( ims:ime, jms:jme )                    , &
@@ -58,9 +59,9 @@ SUBROUTINE SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CQS,CQS2,CHS,CHS2,T2,TH2,Q2,  &
 
     if ( flux ) then
 !!! 2-m Temperature - T2 
-!           if(CHS2(I,J).lt.1.E-5) then
+           if(CHS2(I,J).lt.1.E-5) then
 ! may be to small treshold?
-         if(CHS2(I,J).lt.3.E-3 .AND. HFX(I,J).lt.0.) then
+!         if(CHS2(I,J).lt.3.E-3 .AND. HFX(I,J).lt.0.) then
 ! when stable - let 2-m temperature be equal the first atm. level temp.
 !             TH2(I,J) = TSK(I,J)*(1.E5/PSFC(I,J))**ROVCP 
              TH2(I,J) = t3d(i,1,j)*(1.E5/PSFC)**ROVCP 
diff --git a/wrfv2_fire/phys/module_sf_sfclay.F b/wrfv2_fire/phys/module_sf_sfclay.F
index 0bc72358..86de6c60 100644
--- a/wrfv2_fire/phys/module_sf_sfclay.F
+++ b/wrfv2_fire/phys/module_sf_sfclay.F
@@ -824,6 +824,8 @@ SUBROUTINE SFCLAY1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
 !         ZNT(I)=CZO*UST(I)*UST(I)/G+OZO                                   
 ! Since V3.7 (ref: EC Physics document for Cy36r1)
           ZNT(I)=CZO*UST(I)*UST(I)/G+0.11*1.5E-5/UST(I)
+! V3.9: Add limit as in isftcflx = 1,2
+          ZNT(I)=MIN(ZNT(I),2.85e-3)
 ! COARE 3.5 (Edson et al. 2013)
 !         CZC = 0.0017*WSPD(I)-0.005
 !         CZC = min(CZC,0.028)
diff --git a/wrfv2_fire/phys/module_sf_sfclayrev.F b/wrfv2_fire/phys/module_sf_sfclayrev.F
index 8ae60066..9c36abb6 100644
--- a/wrfv2_fire/phys/module_sf_sfclayrev.F
+++ b/wrfv2_fire/phys/module_sf_sfclayrev.F
@@ -708,11 +708,54 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
               Z0T = MAX(Z0T,2.0e-9)
               Z0Q = Z0T
 
-              PSIQ=max(ALOG((ZA(I)+Z0Q)/Z0Q)-PSIH(I), 2.)
-              PSIT=max(ALOG((ZA(I)+Z0T)/Z0T)-PSIH(I), 2.)
-              PSIQ2=max(ALOG((2.+Z0Q)/Z0Q)-PSIH2(I), 2.)
-              PSIT2=max(ALOG((2.+Z0T)/Z0T)-PSIH2(I), 2.)
-              PSIQ10=max(ALOG((10.+Z0Q)/Z0Q)-PSIH10(I), 2.)
+! following paj:
+           zolzz=zol(I)*(za(I)+z0t)/za(I)    ! (z+z0t)/L
+           zol10=zol(I)*(10.+z0t)/za(I)   ! (10+z0t)/L
+           zol2=zol(I)*(2.+z0t)/za(I)     ! (2+z0t)/L
+           zol0=zol(I)*z0t/za(I)          ! z0t/L
+!
+              if (zol(I).gt.0.) then
+              psih(I)=psih_stable(zolzz)-psih_stable(zol0)
+              psih10(I)=psih_stable(zol10)-psih_stable(zol0)
+              psih2(I)=psih_stable(zol2)-psih_stable(zol0)
+              else
+                if (zol(I).eq.0) then
+                psih(I)=0.
+                psih10(I)=0.
+                psih2(I)=0.
+                else
+                psih(I)=psih_unstable(zolzz)-psih_unstable(zol0)
+                psih10(I)=psih_unstable(zol10)-psih_unstable(zol0)
+                psih2(I)=psih_unstable(zol2)-psih_unstable(zol0)
+                endif
+              endif
+              PSIT=ALOG((ZA(I)+z0t)/Z0t)-PSIH(I)
+              PSIT2=ALOG((2.+z0t)/Z0t)-PSIH2(I)
+
+           zolzz=zol(I)*(za(I)+z0q)/za(I)    ! (z+z0q)/L
+           zol10=zol(I)*(10.+z0q)/za(I)   ! (10+z0q)/L
+           zol2=zol(I)*(2.+z0q)/za(I)     ! (2+z0q)/L
+           zol0=zol(I)*z0q/za(I)          ! z0q/L
+!
+              if (zol(I).gt.0.) then
+              psih(I)=psih_stable(zolzz)-psih_stable(zol0)
+              psih10(I)=psih_stable(zol10)-psih_stable(zol0)
+              psih2(I)=psih_stable(zol2)-psih_stable(zol0)
+              else
+                if (zol(I).eq.0) then
+                psih(I)=0.
+                psih10(I)=0.
+                psih2(I)=0.
+                else
+                psih(I)=psih_unstable(zolzz)-psih_unstable(zol0)
+                psih10(I)=psih_unstable(zol10)-psih_unstable(zol0)
+                psih2(I)=psih_unstable(zol2)-psih_unstable(zol0)
+                endif
+              endif
+!
+              PSIQ=ALOG((ZA(I)+z0q)/Z0q)-PSIH(I)
+              PSIQ2=ALOG((2.+z0q)/Z0q)-PSIH2(I)
+              PSIQ10=ALOG((10.+z0q)/Z0q)-PSIH10(I)
         ENDIF
 
         IF ( PRESENT(ISFTCFLX) ) THEN
@@ -925,6 +968,8 @@ SUBROUTINE SFCLAYREV1D(J,UX,VX,T1D,QV1D,P1D,dz8w1d,                &
 !         ZNT(I)=CZO*UST(I)*UST(I)/G+OZO                                   
 ! Since V3.7 (ref: EC Physics document for Cy36r1)
           ZNT(I)=CZO*UST(I)*UST(I)/G+0.11*1.5E-5/UST(I)
+! V3.9: Add limit as in isftcflx = 1,2
+          ZNT(I)=MIN(ZNT(I),2.85e-3)
 ! COARE 3.5 (Edson et al. 2013)
 !         CZC = 0.0017*WSPD(I)-0.005
 !         CZC = min(CZC,0.028)
diff --git a/wrfv2_fire/phys/module_sf_urban.F b/wrfv2_fire/phys/module_sf_urban.F
index 85177445..40ca135b 100644
--- a/wrfv2_fire/phys/module_sf_urban.F
+++ b/wrfv2_fire/phys/module_sf_urban.F
@@ -1129,14 +1129,12 @@ SUBROUTINE urban(LSOLAR,                                           & ! L
        end if 
        YY  = TA + (RGRR / RCH - BETGR * EPGR * ELL/ RCH) / RR2  
        ZZ1 = DF1 / (-0.5 * ZSOILR (KZ) * RCH * RR2 ) + 1.0
-       ! Update temperature in soil layer
-       CALL SHFLX (SSOILR,TGRL,SMR,SMCMAX,NGR,TGRP,DELT,YY,ZZ1,ZSOILR,       &
-                  TRLEND,ZBOT,SMCWLT,DF1,QUARTZ,CSOIL,CAPR) 
+
 
        HGR=RHO*CP*CHGR*UA*(TGRP-TA)*100.     
        RUNOFF3 = RUNOFF3/ DELT
        RUNOFF2 = RUNOFF2+ RUNOFF3      
-       G0GR    = SSOILR / 697.7 / 60
+       G0GR    = DF1*(TGRP-TGRL(1))/(DZGR(1)/2.)/697.7/60
 
        FV = SGR + RGR - HGR - ELEGR - G0GR
        DRRDTGR   = (-4.*EPSV*SIG*TGRP**3.)/60.
@@ -1152,7 +1150,9 @@ SUBROUTINE urban(LSOLAR,                                           & ! L
        EXIT
        ENDIF
      END DO
-    
+       ! Update temperature in soil layer
+       CALL SHFLX (SSOILR,TGRL,SMR,SMCMAX,NGR,TGRP,DELT,YY,ZZ1,ZSOILR,       &
+                  TRLEND,ZBOT,SMCWLT,DF1,QUARTZ,CSOIL,CAPR)     
    FLXTHGR=HGR/RHO/CP/100.
    FLXHUMGR=ELEGR/RHO/EL/100.
 ELSE
diff --git a/wrfv2_fire/phys/module_surface_driver.F b/wrfv2_fire/phys/module_surface_driver.F
index 042d3763..2c0eab06 100644
--- a/wrfv2_fire/phys/module_surface_driver.F
+++ b/wrfv2_fire/phys/module_surface_driver.F
@@ -19,13 +19,13 @@ SUBROUTINE surface_driver(                                         &
      &          ,num_soil_layers,p8w,pblh,pi_phy,pshltr,fm,fhh,psih   &
 #if (NMM_CORE==1)
      &          ,psim,p_phy,q10,q2,qfx,taux,tauy,qsfc,qshltr,qz0      &
-     &          ,icoef_sf,lcurr_sf                                    & !for gfdl-sf drag
+     &          ,zkmax,ribn,charn,msang,scurx,scury,icoef_sf,iwavecpl,lcurr_sf & !for gfdl-sf drag
      &          ,pert_Cd, ens_random_seed, ens_Cdamp                  &
      &          ,cd_out,ch_out                                        &
 #else
      &          ,psim,p_phy,q10,q2,qfx,qsfc,qshltr,qz0                &
 #endif
-     &          ,raincv,rho,sfcevp,sfcexc,sfcrunoff                   &
+     &          ,raincv,rho,sfcevp,sfcexc,sfcrunoff ,acrunoff         &
      &          ,smois,smstav,smstot,snoalb,snow,snowc,snowh,stepbl   &
      &          ,smcrel                                               &
      &          ,th10,th2,thz0,th_phy,tmn,tshltr,tsk,tslb             &
@@ -60,7 +60,8 @@ SUBROUTINE surface_driver(                                         &
      &          ,qsnowxy  ,wslakexy  ,zwtxy     ,waxy      ,wtxy      ,tsnoxy       &
      &          ,zsnsoxy  ,snicexy   ,snliqxy   ,lfmassxy  ,rtmassxy  ,stmassxy     &
      &          ,woodxy   ,stblcpxy  ,fastcpxy  ,xsaixy    ,taussxy                 &
-     &          ,grainxy  ,gddxy                                                    &
+     &          ,grainxy  ,gddxy     ,cropcat   ,pgsxy                              &
+     &          ,planting ,harvest   ,season_gdd                                    &
      &          ,t2mvxy   ,t2mbxy    ,q2mvxy    ,q2mbxy                             &
      &          ,tradxy   ,neexy     ,gppxy     ,nppxy     ,fvegxy    ,runsfxy      &
      &          ,runsbxy  ,ecanxy    ,edirxy    ,etranxy   ,fsaxy     ,firaxy       &
@@ -271,6 +272,8 @@ SUBROUTINE surface_driver(                                         &
      &          ,TS_RUL2D_mosaic                                      &  !danli mosaic     
      &          ,ZOL                                                  &  !ckay
      &          ,SDA_HFX, SDA_QFX, HFX_BOTH, QFX_BOTH, QNORM, fasdas  &  !fasdas
+     &          ,spp_lsm,pattern_spp_lsm,field_sf                     &  !SPP
+     &          ,spp_pbl,pattern_spp_pbl                              &  !SPP
      &                                                             )
 
 #if ( ! NMM_CORE == 1 )
@@ -321,7 +324,7 @@ SUBROUTINE surface_driver(                                         &
    USE module_sf_gfs
    USE module_sf_noahdrv                           ! danli mosaic, the " ,only : lsm " needs to be deleted 
    USE module_sf_noahlsm, only : LOW_DENSITY_RESIDENTIAL, HIGH_DENSITY_RESIDENTIAL, HIGH_INTENSITY_INDUSTRIAL
-   USE module_sf_noahmpdrv, only : noahmplsm
+   USE module_sf_noahmpdrv, only : noahmplsm, noahmp_urban
    USE module_sf_noahmp_groundwater
    USE module_sf_noah_seaice_drv
 #ifdef WRF_USE_CLM
@@ -605,6 +608,7 @@ SUBROUTINE surface_driver(                                         &
 #if (NMM_CORE==1)
    real , intent(IN )::   SFENTH
    INTEGER, INTENT(IN)::   ICOEF_SF
+   INTEGER, INTENT(IN)::   IWAVECPL
    LOGICAL, INTENT(IN)::   LCURR_SF
    logical,intent(in),optional  :: pert_Cd
    integer,intent(in),optional  :: ens_random_seed
@@ -653,14 +657,15 @@ SUBROUTINE surface_driver(                                         &
    REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   Q2
    REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   QFX
 #if (NMM_CORE==1)
-   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT):: TAUX
-   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT):: TAUY
-   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT):: cd_out
-   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(OUT):: ch_out
+   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: TAUX
+   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: TAUY
+   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: cd_out
+   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT):: ch_out
 #endif
    REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   QSFC
    REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   QZ0
    REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   SFCRUNOFF
+   REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   ACRUNOFF
    REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   SMSTAV
    REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   SMSTOT
    REAL, DIMENSION( ims:ime, jms:jme ) , INTENT(INOUT)::   SNOW
@@ -764,6 +769,10 @@ SUBROUTINE surface_driver(                                         &
    REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT)::   BIO4    ! ssib-snow
    REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT)::   BLO4    ! ssib-snow
    REAL, DIMENSION( ims:ime, jms:jme ) , OPTIONAL, INTENT(INOUT)::   HO4     ! ssib-snow
+#if (NMM_CORE==1)
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(IN)::    CHARN, MSANG, SCURX, SCURY
+   REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT)::   RIBN, ZKMAX
+#endif
 !----------------------------------------------------------
    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT)::   BR
    REAL, DIMENSION( ims:ime, jms:jme ), INTENT(OUT)::   CHKLOWQ
@@ -803,6 +812,11 @@ SUBROUTINE surface_driver(                                         &
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(IN )::   Z
 
    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ), INTENT(INOUT) ::   TKE_PBL
+
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(INOUT),OPTIONAL ::   pattern_spp_lsm,field_sf
+   REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),INTENT(INOUT),OPTIONAL ::   pattern_spp_pbl
+   INTEGER, INTENT(IN), OPTIONAL                 ::     spp_lsm,spp_pbl
+
    REAL, DIMENSION(1:num_soil_layers), INTENT(IN)::   DZS
    REAL, DIMENSION(1:num_soil_layers), INTENT(IN)::   ZS
    REAL, INTENT(IN )::   DT
@@ -828,7 +842,7 @@ SUBROUTINE surface_driver(                                         &
                                     iopt_inf, iopt_rad, iopt_alb, iopt_snf, iopt_tbot, iopt_stc, &
 				    iopt_gla, iopt_rsf
 
-   INTEGER, OPTIONAL, DIMENSION(ims:ime , jms:jme),                    INTENT(INOUT) :: ISNOWXY
+   INTEGER, OPTIONAL, DIMENSION(ims:ime , jms:jme),                    INTENT(INOUT) :: ISNOWXY,   PGSXY
    REAL,    OPTIONAL, DIMENSION(ims:ime ,-2:num_soil_layers, jms:jme), INTENT(INOUT) :: ZSNSOXY
    REAL,    OPTIONAL, DIMENSION(ims:ime ,-2:0,               jms:jme), INTENT(INOUT) :: TSNOXY, SNICEXY, SNLIQXY
    REAL,    OPTIONAL, DIMENSION(ims:ime , jms:jme),                    INTENT(INOUT) ::                    &
@@ -840,6 +854,10 @@ SUBROUTINE surface_driver(                                         &
 	  SAVXY,   SAGXY, RSSUNXY, RSSHAXY,  BGAPXY,  WGAPXY,   TGVXY,   TGBXY,   CHVXY,   CHBXY,   SHGXY, &
 	  SHCXY,   SHBXY,   EVGXY,   EVBXY,   GHVXY,   GHBXY,   IRGXY,   IRCXY,   IRBXY,    TRXY,   EVCXY, &
        CHLEAFXY,  CHUCXY,  CHV2XY,  CHB2XY,CHSTARXY                         
+   INTEGER,    OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(IN) :: CROPCAT
+   REAL,    OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(IN) :: PLANTING
+   REAL,    OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(IN) :: HARVEST
+   REAL,    OPTIONAL, DIMENSION(ims:ime , jms:jme), INTENT(IN) :: SEASON_GDD
 
 !  NoahMP specific fields - runoff option 5
 
@@ -1316,6 +1334,8 @@ SUBROUTINE surface_driver(                                         &
 ! local vars
    REAL, DIMENSION( ims:ime, jms:jme )                 ::   HFXOLD, QFXOLD
    REAL                                                ::   HFX_KAY, QFX_KAY
+! local var for SPP_LSM
+   INTEGER                                             ::   spp_lsm_loc
 !
 !------------------------------------------------------------------
 ! Initialize local variables
@@ -1370,6 +1390,13 @@ SUBROUTINE surface_driver(                                         &
         &              max_edom, cplmask, VOCE )
      
   END IF
+
+#if (EM_CORE==1)
+     spp_lsm_loc = spp_lsm
+#else
+     spp_lsm_loc = 0
+#endif
+
   
 !$OMP PARALLEL DO &
 !$OMP PRIVATE (ij, i, j, k)
@@ -1693,6 +1720,7 @@ SUBROUTINE surface_driver(                                         &
             (sf_sfclay_physics .EQ. QNSESFCSCHEME) )
   isisfc = ( FRACTIONAL_SEAICE .EQ. 1  .AND. (          &
             (sf_sfclay_physics .EQ. SFCLAYSCHEME ) .OR. &
+            (sf_sfclay_physics .EQ. SFCLAYREVSCHEME ) .OR. &
             (sf_sfclay_physics .EQ. PXSFCSCHEME  ) .OR. &
             (sf_sfclay_physics .EQ. MYJSFCSCHEME ) .OR. &
             (sf_sfclay_physics .EQ. QNSESFCSCHEME ) .OR. &  !emt
@@ -1798,7 +1826,7 @@ SUBROUTINE surface_driver(                                         &
          IF (scm_force_flux .EQ. 1) THEN
 ! surface forcing by observed fluxes
          CALL scmflux(u_phytmp, v_phytmp, t_phy, qv_curr, p_phy, dz8w,   &
-                     cp, rovcp, xlv, psfc, cpm, xland,                   &
+                     cp, rcp, xlv, psfc, cpm, xland,                     &
                      psim, psih, hfx, qfx, lh, tsk, flhc, flqc,          &
                      znt, gz1oz0, wspd,                                  &
                      julian_in, karman, p1000mb,                         &
@@ -2029,7 +2057,7 @@ SUBROUTINE surface_driver(                                         &
          IF (scm_force_flux .EQ. 1) THEN
 ! surface forcing by observed fluxes
          CALL scmflux(u_phytmp, v_phytmp, t_phy, qv_curr, p_phy, dz8w,   &
-                     cp, rovcp, xlv, psfc, cpm, xland,                   &
+                     cp, rcp, xlv, psfc, cpm, xland,                     &
                      psim, psih, hfx, qfx, lh, tsk, flhc, flqc,          &
                      znt, gz1oz0, wspd,                                  &
                      julian_in, karman, p1000mb,                         &
@@ -2163,6 +2191,7 @@ SUBROUTINE surface_driver(                                         &
                &itimestep,ch,th_phy,pi_phy,qc_curr,rho,            &
                &tsq,qsq,cov,Sh3d,el_pbl,qcg,                       &
                &icloud_bl,qc_bl,cldfra_bl,                         &
+               &spp_pbl,pattern_spp_pbl,                           &
                XICE,SST,TSK_SEA,                                   &
                CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA,&
                HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA,    &
@@ -2182,6 +2211,7 @@ SUBROUTINE surface_driver(                                         &
                &itimestep,ch,th_phy,pi_phy,qc_curr,rho,            &
                &tsq,qsq,cov,Sh3D,el_pbl,qcg,                       &
                &icloud_bl,qc_bl,cldfra_bl,                         &
+               &spp_pbl,pattern_spp_pbl,                           &
                ids,ide, jds,jde, kds,kde,                          &
                ims,ime, jms,jme, kms,kme,                          &
                i_start(ij),i_end(ij),j_start(ij),j_end(ij),kts,kte,&
@@ -2207,7 +2237,7 @@ SUBROUTINE surface_driver(                                         &
        ! ENDDO
          CALL TEMFSFCLAY(u3d=u_phytmp,v3d=v_phytmp,th3d=th_phy,    &
                qv3d=qv_curr,p3d=p_phy,pi3d=pi_phy,rho=rho,z=z,ht=ht, &
-               CP=cp,G=g,ROVCP=rovcp,R=r_d,XLV=xlv,psfc=psfc,chs=chs,&
+               CP=cp,G=g,ROVCP=rcp,R=r_d,XLV=xlv,psfc=psfc,chs=chs,&
                chs2=chs2,cqs2=cqs2,CPM=cpm,znt=znt,ust=ust,        &
                MAVAIL=mavail,XLAND=xland,HFX=hfx,QFX=qfx,LH=lh,   &
                TSK=tsk,FLHC=flhc,FLQC=flqc,QGH=qgh,qsfc=qsfc,      &
@@ -2228,7 +2258,7 @@ SUBROUTINE surface_driver(                                         &
          CALL wrf_debug( 100, 'in IDEALSCMSFCLAY' )
          CALL IDEALSCMSFCLAY(u3d=u_phytmp,v3d=v_phytmp,th3d=th_phy,    &
                qv3d=qv_curr,p3d=p_phy,pi3d=pi_phy,rho=rho,z=z,ht=ht, &
-               CP=cp,G=g,ROVCP=rovcp,R=r_d,XLV=xlv,psfc=psfc,chs=chs,&
+               CP=cp,G=g,ROVCP=rcp,R=r_d,XLV=xlv,psfc=psfc,chs=chs,  &
                chs2=chs2,cqs2=cqs2,CPM=cpm,znt=znt,ust=ust,        &
                MAVAIL=mavail,XLAND=xland,HFX=hfx,QFX=qfx,LH=lh,   &
                TSK=tsk,FLHC=flhc,FLQC=flqc,QGH=qgh,qsfc=qsfc,      &
@@ -2270,14 +2300,15 @@ SUBROUTINE surface_driver(                                         &
                    UST,PSIM,PSIH,                                         &  
                    XLAND,HFX,QFX,TAUX,TAUY,LH,GSW,GLW,TSK,FLHC,FLQC,  & ! gopal's doing for Ocean coupling
                    QGH,QSFC,U10,V10,                              &
-                   ICOEF_SF, LCURR_SF,                            &
+                   ICOEF_SF,IWAVECPL,LCURR_SF,CHARN, MSANG, SCURX, SCURY, &
                    pert_Cd, ens_random_seed, ens_Cdamp,           &
-                   GZ1OZ0,WSPD,BR,ISFFLX,                         &
+                   GZ1OZ0,WSPD,BR,ZKMAX, ISFFLX,                  &
                    EP_1,EP_2,KARMAN,GFDL_NTSFLG,SFENTH,           &
                    cd_out, ch_out,                                &
                    ids,ide, jds,jde, kds,kde,                     &
                    ims,ime, jms,jme, kms,kme,                             &
                    i_start(ij),i_end(ij),j_start(ij),j_end(ij),kts,kte    )
+           RIBN = BR
            DO j=j_start(ij),j_end(ij)
            DO i=i_start(ij),i_end(ij)
               CHKLOWQ(I,J)= 1.0
@@ -2888,13 +2919,14 @@ SUBROUTINE surface_driver(                                         &
          if(HYDRO_dt .ge. 0) HYDRO_dt = dtbl
 #endif
          CALL wrf_debug(100,'in NOAHMP DRV')
-         CALL noahmplsm(ITIMESTEP,       YR, JULIAN_IN,   COSZEN, XLAT_URB2D, &
+         CALL noahmplsm(ITIMESTEP,       YR, JULIAN_IN,   COSZEN, XLAT,XLONG, &
 	           DZ8W,     DTBL,      DZS,     NUM_SOIL_LAYERS,         DX, &
 		 IVGTYP,   ISLTYP,   VEGFRA,   SHDMAX,       TMN,             &
-		  XLAND,     XICE,     XICE_THRESHOLD,                        &
+		  XLAND,     XICE,     XICE_THRESHOLD,   CROPCAT,             &
+               PLANTING,  HARVEST,SEASON_GDD,                               &
                   IDVEG, IOPT_CRS, IOPT_BTR, IOPT_RUN,  IOPT_SFC,   IOPT_FRZ, &
 	       IOPT_INF, IOPT_RAD, IOPT_ALB, IOPT_SNF, IOPT_TBOT,   IOPT_STC, &
-	       IOPT_GLA, IOPT_RSF,  IZ0TLND,                                            &
+	       IOPT_GLA, IOPT_RSF,  IZ0TLND, SF_URBAN_PHYSICS,                &
 		  T_PHY,  QV_CURR,    U_PHY,    V_PHY,    SWDOWN,        GLW, &
 		    P8W,   RAINBL,       SR,                                  &
 		    TSK,      HFX,      QFX,       LH,    GRDFLX,     SMSTAV, &
@@ -2907,7 +2939,7 @@ SUBROUTINE surface_driver(                                         &
 		QSNOWXY, WSLAKEXY,    ZWTXY,     WAXY,      WTXY,     TSNOXY, &
 		ZSNSOXY,  SNICEXY,  SNLIQXY, LFMASSXY,  RTMASSXY,   STMASSXY, &
 		 WOODXY, STBLCPXY, FASTCPXY,      LAI,    XSAIXY,    TAUSSXY, &
-	        SMOISEQ, SMCWTDXY,DEEPRECHXY,  RECHXY,   GRAINXY,      GDDXY, & ! IN/OUT Noah MP only
+	        SMOISEQ, SMCWTDXY,DEEPRECHXY,  RECHXY,   GRAINXY,      GDDXY,PGSXY, & ! IN/OUT Noah MP only
 	         T2MVXY,   T2MBXY,   Q2MVXY,   Q2MBXY,                        &
                  TRADXY,    NEEXY,    GPPXY,    NPPXY,    FVEGXY,    RUNSFXY, &
 	        RUNSBXY,   ECANXY,   EDIRXY,  ETRANXY,     FSAXY,     FIRAXY, &
@@ -2926,6 +2958,57 @@ SUBROUTINE surface_driver(                                         &
                 MP_RAINC =  RAINCV, MP_RAINNC =    RAINNCV, MP_SHCV = RAINSHV,&
 		MP_SNOW  = SNOWNCV, MP_GRAUP  = GRAUPELNCV, MP_HAIL = HAILNCV )
 
+         IF(SF_URBAN_PHYSICS > 0 ) THEN  !urban
+         
+	   call noahmp_urban (sf_urban_physics,     NUM_SOIL_LAYERS,     IVGTYP,ITIMESTEP,  & ! IN : Model configuration 
+                                 DT,         COSZEN,     XLAT_URB2D,                        & ! IN : Time/Space-related
+                              T_PHY,        QV_CURR,          U_PHY,      V_PHY,   SWDOWN,  & ! IN : Forcing
+		                GLW,            P8W,         RAINBL,       DZ8W,      ZNT,  & ! IN : Forcing
+                                TSK,            HFX,            QFX,         LH,   GRDFLX,  & ! IN/OUT : LSM 
+		             ALBEDO,          EMISS,           QSFC,                        & ! IN/OUT : LSM 
+                            ids,ide,        jds,jde,        kds,kde,                        &
+                            ims,ime,        jms,jme,        kms,kme,                        &
+              i_start(ij),i_end(ij), j_start(ij),j_end(ij), kts,kte,                        &
+                         cmr_sfcdif,     chr_sfcdif,     cmc_sfcdif,                        &
+	                 chc_sfcdif,    cmgr_sfcdif,    chgr_sfcdif,                        &
+                           tr_urb2d,       tb_urb2d,       tg_urb2d,                        & !H urban
+	                   tc_urb2d,       qc_urb2d,       uc_urb2d,                        & !H urban
+                         xxxr_urb2d,     xxxb_urb2d,     xxxg_urb2d, xxxc_urb2d,            & !H urban
+                          trl_urb3d,      tbl_urb3d,      tgl_urb3d,                        & !H urban
+                           sh_urb2d,       lh_urb2d,        g_urb2d,   rn_urb2d,  ts_urb2d, & !H urban
+                         psim_urb2d,     psih_urb2d,      u10_urb2d,  v10_urb2d,            & !O urban
+                       GZ1OZ0_urb2d,     AKMS_URB2D,                                        & !O urban
+                          th2_urb2d,       q2_urb2d,      ust_urb2d,                        & !O urban
+                             declin,          hrang,                                        & !I urban
+                    num_roof_layers,num_wall_layers,num_road_layers,                        & !I urban
+                                dzr,            dzb,            dzg,                        & !I urban
+                         cmcr_urb2d,      tgr_urb2d,     tgrl_urb3d,  smr_urb3d,            & !H urban
+                        drelr_urb2d,    drelb_urb2d,    drelg_urb2d,                        & !H urban
+                      flxhumr_urb2d,  flxhumb_urb2d,  flxhumg_urb2d,                        & !H urban
+                             julian,          julyr,                                        & !H urban
+                          frc_urb2d,    utype_urb2d,                                        & !I urban
+                                chs,           chs2,           cqs2,                        & !H
+                   num_urban_layers,                                                        & !I multi-layer urban
+                       num_urban_hi,                                                        & !I multi-layer urban
+                          trb_urb4d,      tw1_urb4d,      tw2_urb4d,  tgb_urb4d,            & !H multi-layer urban
+                         tlev_urb3d,     qlev_urb3d,                                        & !H multi-layer urban
+                       tw1lev_urb3d,   tw2lev_urb3d,                                        & !H multi-layer urban
+                        tglev_urb3d,    tflev_urb3d,                                        & !H multi-layer urban
+                        sf_ac_urb3d,    lf_ac_urb3d,    cm_ac_urb3d,                        & !H multi-layer urban
+                       sfvent_urb3d,   lfvent_urb3d,                                        & !H multi-layer urban
+                       sfwin1_urb3d,   sfwin2_urb3d,                                        & !H multi-layer urban
+                         sfw1_urb3d,     sfw2_urb3d,      sfr_urb3d,  sfg_urb3d,            & !H multi-layer urban
+                           lp_urb2d,       hi_urb2d,       lb_urb2d,  hgt_urb2d,            & !H multi-layer urban
+                           mh_urb2d,     stdh_urb2d,       lf_urb2d,                        & !SLUCM
+                             th_phy,            rho,          p_phy,        ust,            & !I multi-layer urban
+                                gmt,         julday,          xlong,       xlat,            & !I multi-layer urban
+                            a_u_bep,        a_v_bep,        a_t_bep,    a_q_bep,            & !O multi-layer urban
+                            a_e_bep,        b_u_bep,        b_v_bep,                        & !O multi-layer urban
+                            b_t_bep,        b_q_bep,        b_e_bep,    dlg_bep,            & !O multi-layer urban
+                           dl_u_bep,         sf_bep,         vl_bep)                          !O multi-layer urban
+	 
+	 ENDIF 
+
   if(iopt_run.eq.5.and.mod(itimestep,STEPWTD).eq.0)then
            CALL wrf_debug( 100, 'calling WTABLE' )
 
@@ -3037,9 +3120,13 @@ SUBROUTINE surface_driver(                                         &
                  ELSE
                    T2(I,J) = TSK(I,J) - HFX(I,J)/(PSFC(I,J)/(R_d * TSK(I,J))*CP*CHS2(I,J))
                  ENDIF
-                   TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**ROVCP
+                   TH2(I,J) = T2(I,J)*(1.E5/PSFC(I,J))**RCP
 !             ELSEIF (IVGTYP(I,J) == ISURBAN .OR. IVGTYP(I,J) == ISICE .OR. FVEGXY(I,J) == 0.0 ) THEN
-              ELSEIF (IVGTYP(I,J) == ISURBAN  .OR. (IVGTYP(I,J) == ISICE .AND. XICE(I,J) .LT. XICE_THRESHOLD)) THEN
+              ELSEIF (IVGTYP(I,J) == ISURBAN                   .or. &
+	              IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL   .or. & !urban
+                      IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL  .or. & !urban
+	              IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL .or. & !urban
+	              (IVGTYP(I,J) == ISICE .AND. XICE(I,J) .LT. XICE_THRESHOLD)) THEN
                    Q2(I,J)  = Q2MBXY(I,J)
                    T2(I,J)  = T2MBXY(I,J)
                    TH2(I,J) = T2(i,j)*(1.E5/PSFC(i,j))**RCP
@@ -3059,6 +3146,43 @@ SUBROUTINE surface_driver(                                         &
 
 !jref: sfc diagnostics end
 
+         IF(SF_URBAN_PHYSICS.eq.1) THEN
+           DO j=j_start(ij),j_end(ij)                             !urban
+             DO i=i_start(ij),i_end(ij)                           !urban
+              IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. &  !urban
+                  IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL ) THEN !urban
+                 Q2(I,J)  = (FVEGXY(I,J)*Q2MVXY(I,J) + (1.-FVEGXY(I,J))*Q2MBXY(I,J))*(1.-FRC_URB2D(I,J)) +   &
+                             Q2_URB2D(I,J)*FRC_URB2D(I,J)
+                 T2(I,J)  = (FVEGXY(I,J)*T2MVXY(I,J) + (1.-FVEGXY(I,J))*T2MBXY(I,J))*(1.-FRC_URB2D(I,J)) +   &
+                             (TH2_URB2D(i,j)/((1.E5/PSFC(i,j))**RCP))*FRC_URB2D(I,J)
+                 TH2(I,J) = T2(i,j)*(1.E5/PSFC(i,j))**RCP
+                 U10(I,J)  = U10_URB2D(I,J)                       !urban
+                 V10(I,J)  = V10_URB2D(I,J)                       !urban
+                 PSIM(I,J) = PSIM_URB2D(I,J)                      !urban
+                 PSIH(I,J) = PSIH_URB2D(I,J)                      !urban
+                 GZ1OZ0(I,J) = GZ1OZ0_URB2D(I,J)                  !urban
+                 AKHS(I,J) = CHS(I,J)                             !urban
+                 AKMS(I,J) = AKMS_URB2D(I,J)                      !urban
+               END IF                                             !urban
+             ENDDO                                                !urban
+           ENDDO                                                  !urban
+         ENDIF
+
+         IF((SF_URBAN_PHYSICS.eq.2).OR.(SF_URBAN_PHYSICS.eq.3)) THEN
+           DO j=j_start(ij),j_end(ij)                             !urban
+             DO i=i_start(ij),i_end(ij)                           !urban
+              IF( IVGTYP(I,J) == ISURBAN .or. IVGTYP(I,J) == LOW_DENSITY_RESIDENTIAL .or. &  !urban
+                  IVGTYP(I,J) == HIGH_DENSITY_RESIDENTIAL .or. IVGTYP(I,J) == HIGH_INTENSITY_INDUSTRIAL ) THEN !urban
+                T2(I,J)   = TH_PHY(i,1,j)/((1.E5/PSFC(I,J))**RCP) !urban
+                TH2(I,J) = TH_PHY(i,1,j) !urban
+                Q2(I,J)   = qv_curr(i,1,j)  !urban
+                U10(I,J)  = U_phy(I,1,J)                       !urban
+                V10(I,J)  = V_phy(I,1,J)                       !urban
+               END IF                                             !urban
+             ENDDO                                                !urban
+           ENDDO                                                  !urban
+         ENDIF
+
 !------------------------------------------------------------------
 
        ELSE
@@ -3072,7 +3196,7 @@ SUBROUTINE surface_driver(                                         &
            PRESENT(qcg)        .AND.  PRESENT(soilt1)  .AND.    &
            PRESENT(tsnav)      .AND.  PRESENT(smfr3d)  .AND.    &
            PRESENT(keepfr3dflag) .AND. PRESENT(rainbl) .AND.    &
-           PRESENT(dew)                                .AND.    &
+           PRESENT(dew)                                 .AND.   &
                                                       .TRUE. ) THEN
 
            IF( PRESENT(sr) ) THEN
@@ -3127,7 +3251,11 @@ SUBROUTINE surface_driver(                                         &
               ENDIF
            ENDIF
 
-           CALL LSMRUC(dtbl,itimestep,num_soil_layers,          &
+           CALL LSMRUC( spp_lsm_loc,                            &
+#if (EM_CORE==1)
+                pattern_spp_lsm,field_sf,                       &
+#endif
+                dtbl,itimestep,num_soil_layers,                 &
 #if (EM_CORE==1)
                 lakemodel,lakemask,                             &
                 graupelncv,snowncv,rainncv,                     &
@@ -3143,9 +3271,9 @@ SUBROUTINE surface_driver(                                         &
                 qsfc,qsg,qvg,qcg,dew,soilt1,tsnav,              &
                 tmn,ivgtyp,isltyp,xland,                        &
                 iswater,isice,xice,xice_threshold,              &
-                cp,rovcp,g,xlv,stbolt,                          &
+                cp ,rcp,g,xlv,stbolt,                           &
                 smois,sh2o,smstav,smstot,tslb,tsk,hfx,qfx,lh,   &
-                sfcrunoff,udrunoff,sfcexc,                      &
+                sfcrunoff,udrunoff,acrunoff,sfcexc,             &
                 sfcevp,grdflx,snowfallac,acsnow,acsnom,         &
                 smfr3d,keepfr3dflag,                            &
                 myj,shdmin,shdmax,rdlai2d,                      &
@@ -3211,7 +3339,7 @@ SUBROUTINE surface_driver(                                         &
             ENDDO
 
           CALL SFCDIAGS_RUCLSM(HFX,QFX,TSK,QSFC,CQS,CQS2,CHS,CHS2,T2,TH2,Q2,  &
-                     T_PHY,QV_CURR,RHO,P_PHY,PSFC,                            &
+                     T_PHY,QV_CURR,RHO,P_PHY,PSFC,SNOW,                       &
                      CP,R_d,RCP,                                              &
                      ids,ide, jds,jde, kds,kde,                               &
                      ims,ime, jms,jme, kms,kme,                               &
@@ -4618,6 +4746,7 @@ SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w,     &
                &itimestep,ch,th3d,pi3d,qc3d,rho,                   &
                &tsq,qsq,cov,Sh3d,el_pbl,qcg,                       &
                &icloud_bl,qc_bl,cldfra_bl,                         &
+               &spp_pbl,pattern_spp_pbl,                           &
 XICE,SST,TSK_SEA,                                                  &
 CHS2_SEA,CHS_SEA,CPM_SEA,CQS2_SEA,FLHC_SEA,FLQC_SEA,               &
 HFX_SEA,LH_SEA,QFX_SEA,QGH_SEA,QSFC_SEA,ZNT_SEA,                   &
@@ -4638,6 +4767,10 @@ SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w,     &
      REAL,     INTENT(IN )   ::        SVP1,SVP2,SVP3,SVPT0
      REAL,     INTENT(IN )   ::        EP1,EP2,KARMAN
 
+     INTEGER,  INTENT(IN)      ::     spp_pbl
+     REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )             &
+                             ::   pattern_spp_pbl
+
      REAL,     DIMENSION( ims:ime, kms:kme, jms:jme )           , &
                INTENT(IN   )   ::                           dz8w
 
@@ -4874,6 +5007,7 @@ SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w,     &
                &itimestep,ch,th3d,pi3d,qc3d,rho,                   &
                &tsq,qsq,cov,sh3d,el_pbl,qcg,                       &
                &icloud_bl,qc_bl,cldfra_bl,                         &
+               &spp_pbl,pattern_spp_pbl,                           &
                ids,ide, jds,jde, kds,kde,                          &
                ims,ime, jms,jme, kms,kme,                          &
                its,ite, jts,jte, kts,kte,                          &
@@ -4961,6 +5095,7 @@ SUBROUTINE mynn_seaice_wrapper(U3D,V3D,T3D,QV3D,P3D,dz8w,     &
                &itimestep,CH_SEA,th3d,pi3d,qc3d,rho,               &
                &tsq,qsq,cov,sh3d,el_pbl,qcg,                       &
                &icloud_bl,qc_bl,cldfra_bl,                         &
+               &spp_pbl,pattern_spp_pbl,                           &
                ids,ide, jds,jde, kds,kde,                          &
                ims,ime, jms,jme, kms,kme,                          &
                its,ite, jts,jte, kts,kte,                          &
diff --git a/wrfv2_fire/run/MPTABLE.TBL b/wrfv2_fire/run/MPTABLE.TBL
index 54760dfe..afb852f6 100644
--- a/wrfv2_fire/run/MPTABLE.TBL
+++ b/wrfv2_fire/run/MPTABLE.TBL
@@ -36,7 +36,9 @@
  ISWATER                   = 16
  ISBARREN                  = 19
  ISICE                     = 24
+ ISCROP                    =  2
  EBLFOREST                 = 13
+ NATURAL                   =  5
  LOW_DENSITY_RESIDENTIAL   = 31
  HIGH_DENSITY_RESIDENTIAL  = 32
  HIGH_INTENSITY_INDUSTRIAL = 33
@@ -178,7 +180,9 @@
  ISWATER                   = 17
  ISBARREN                  = 16
  ISICE                     = 15
+ ISCROP                    = 12
  EBLFOREST                 =  2
+ NATURAL                   = 14
  LOW_DENSITY_RESIDENTIAL   = 31
  HIGH_DENSITY_RESIDENTIAL  = 32
  HIGH_INTENSITY_INDUSTRIAL = 33
@@ -338,6 +342,8 @@
  !  4: Rice
  !  5: Winter wheat
 
+DEFAULT_CROP = 0                                      ! The default crop type(1-5); if zero, use generic dynamic vegetation 
+
 !----------------------------------------------------------
 !                1       2       3       4       5
 !----------------------------------------------------------
@@ -355,7 +361,7 @@ GDDS3      = 1183.0,  933.0,  933.0,  933.0,  933.0,  ! GDD from seeding to post
 GDDS4      = 1253.0, 1103.0, 1103.0, 1103.0, 1103.0,  ! GDD from seeding to intial reproductive
 GDDS5      = 1605.0, 1555.0, 1555.0, 1555.0, 1555.0,  ! GDD from seeding to pysical maturity 
 
-C3C4       =    2.0,    1.0,    2.0,    2.0,    2.0,  ! photosynthetic pathway:  1. = c3 2. = c4
+C3C4       =      2,      1,      2,      2,      2,  ! photosynthetic pathway:  1. = c3 2. = c4
 Aref       =    7.0,    7.0,    7.0,    7.0,    7.0,  ! reference maximum CO2 assimulation rate 
 PSNRF      =   0.85,   0.85,   0.85,   0.85,   0.85,  ! CO2 assimulation reduction factor(0-1) (caused by non-modeling part,e.g.pest,weeds)
 I2PAR      =    0.5,    0.5,    0.5,    0.5,    0.5,  ! Fraction of incoming solar radiation to photosynthetically active radiation
diff --git a/wrfv2_fire/run/README.namelist b/wrfv2_fire/run/README.namelist
index 302e6019..f7882251 100644
--- a/wrfv2_fire/run/README.namelist
+++ b/wrfv2_fire/run/README.namelist
@@ -10,7 +10,7 @@ information on NMM specific settings (http://www.dtcenter.org/wrf-nmm/users)
        be defined for the nests when max_dom > 1.
 
  &time_control
- run_days                            = 1,	; run time in days
+ run_days                            = 0,	; run time in days
  run_hours                           = 0,	; run time in hours
                                                   Note: if it is more than 1 day, one may use both run_days and run_hours
                                                   or just run_hours. e.g. if the total run length is 36 hrs, you may
@@ -42,7 +42,7 @@ information on NMM specific settings (http://www.dtcenter.org/wrf-nmm/users)
                                                   Program real.exe uses start and end times only.
 
  interval_seconds                    = 10800,	; time interval between incoming real data, which will be the interval
-                                                  between the lateral boundary condition file
+                                                  between the lateral boundary condition file (in seconds)
  input_from_file (max_dom)           = T,       ; whether nested run will have input files for domains other than 1
  fine_input_stream (max_dom)         = 0,       ; field selection from nest input for its initialization
                                                   0: all fields are used; 2: only static and time-varying, masked land 
@@ -110,11 +110,11 @@ For SST updating (used only with sst_update=1):
  auxinput4_interval                  = 360      ; minutes generally matches time given by interval_seconds
  io_form_auxinput4                   = 2        ; IO format, required in V3.2
 
- nwp_diagnostics                     = 1        ; adds 7 history-interval max diagnostic fields
+ nwp_diagnostics                     = 0        ; set to = 1 to add 7 history-interval max diagnostic fields
 
 For additional regional climate surface fields
 
- output_diagnostics                  = 1        ; adds 36 surface diagnostic arrays (max/min/mean/std)
+ output_diagnostics                  = 0        ; set to = 1 to add 36 surface diagnostic arrays (max/min/mean/std)
  auxhist3_outname                    = 'wrfxtrm_d_' ; file name for added diagnostics
  io_form_auxhist3                    = 2        ; netcdf
  auxhist3_interval                   = 1440     ; minutes between outputs (1440 gives daily max/min)
@@ -137,20 +137,20 @@ Options for run-time IO:
 Additional settings when running WRFVAR:
 
  write_input                         = t,       ; write input-formatted data as output
- inputout_interval                   = 180,     ; interval in minutes when writing input-formatted data 
+ inputout_interval (max_dom)         = 180,     ; interval in minutes when writing input-formatted data 
  input_outname                       = 'wrfinput_d_' ; you may change the output file name
- inputout_begin_y                    = 0
+ inputout_begin_y (max_dom)          = 0
  inputout_begin_mo                   = 0
- inputout_begin_d                    = 0
- inputout_begin_h                    = 3
- inputout_begin_m                    = 0
- inputout_begin_s                    = 0
- inputout_end_y                      = 0
+ inputout_begin_d (max_dom)          = 0
+ inputout_begin_h (max_dom)          = 3
+ inputout_begin_m (max_dom)          = 0
+ inputout_begin_s (max_dom)          = 0
+ inputout_end_y (max_dom)            = 0
  inputout_end_mo                     = 0
- inputout_end_d                      = 0
- inputout_end_h                      = 12
- inputout_end_m                      = 0
- inputout_end_s                      = 0        ; the above shows that the input-formatted data are output
+ inputout_end_d (max_dom)            = 0
+ inputout_end_h (max_dom)            = 12
+ inputout_end_m (max_dom)            = 0
+ inputout_end_s (max_dom)            = 0        ; the above shows that the input-formatted data are output
                                                   starting from hour 3 to hour 12 in 180 min interval.
 
 For automatic moving nests: requires special input data, and environment variable TERRAIN_AND_LANDUSE set at compile time
@@ -190,8 +190,8 @@ For automatic moving nests: requires special input data, and environment variabl
  parent_time_step_ratio (max_dom)    = 1,       ; parent-to-nest time step ratio; it can be different
                                                   from the parent_grid_ratio (NMM: must be 3)
  feedback                            = 1,       ; feedback from nest to its parent domain; 0 = no feedback
- smooth_option                       = 0        ; smoothing option for parent domain, used only with feedback
-                                                  option on. 0: no smoothing; 1: 1-2-1 smoothing; 2: smoothing-desmoothing
+ smooth_option                       = 2        ; smoothing option for parent domain, used only with feedback
+                                                  option on. 0: no smoothing; 1: 1-2-1 smoothing; 2: smoothing-desmoothing (default)
 
 Namelist variables specifically for the WPS input for real:
 
@@ -215,7 +215,7 @@ Namelist variables specifically for the WPS input for real:
  use_surface                         = .true.   ; use the input surface level data in the vertical interp and extrap
                                                 ; T = use the input surface data
                                                 ; F = do not use the input surface data
- lagrange_order                      = 1        ; vertical interpolation order
+ lagrange_order                      = 2        ; vertical interpolation order
                                                 ; 1 = linear
                                                 ; 2 = quadratic
                                                 ; 9 = cubic spline
@@ -256,10 +256,10 @@ Namelist variables specifically for the WPS input for real:
                                                   default is option 1, the old MM5 method; option 2 uses a WMO 
                                                   recommended method (WMO-No. 49, corrigendum, August 2000) - 
                                                   there is a difference between the two methods though small
- interp_theta                        = .true.   ; If set to .false., it will vertically interpolate temperature 
+ interp_theta                        = .false.  ; If set to .false., it will vertically interpolate temperature 
                                                   instead of potential temperature, which may reduce bias when 
                                                   compared with input data
- hypsometric_opt                     = 1,       ; = 1: default method
+ hypsometric_opt                     = 2,       ; = 1: default method
                                                   = 2: it uses an alternative way (less biased 
                                                   when compared agaist input data) to compute height in program 
                                                   real and pressure in model (ARW only). 
@@ -319,7 +319,7 @@ extreme (and quite rare occurrences), other schemes are available.  For options
 1, 3, 4, and 12, the FG lateral boundaries use the same horizontal scheme for the
 lateral BC computations.
  interp_method_type                  = 1 ! bi-linear interpolation
-                                     = 2 ! SINT, default
+                                     = 2 ! SINT, (default)
                                      = 3 ! nearest neighbor - only to be used for 
                                          ! testing purposes
                                      = 4 ! overlapping quadratic
@@ -335,21 +335,24 @@ activated, the user must specify a reasonable ocean.  Currently, this is the onl
 available to run the 3d ocean option.
 
  &physics
- sf_ocean_physics                    = 0 (default), 1 (mixed layer model), 2 (3d ocean)
+ sf_ocean_physics                    = 0 (default), Activate ocean model; 1 (mixed layer model), 2 (3d ocean)
 
  &domains
  ocean_levels                        = 30,
- ocean_z                             =        5,        15,        25,        35,        45,        55,
-                                             65,        75,        85,        95,       105,       115,
-                                            125,       135,       145,       155,       165,       175,
-                                            185,       195,       210,       230,       250,       270,
-                                            290,       310,       330,       350,       370,       390
- ocean_t                             = 302.3493,  302.3493,  302.3493,  302.1055,  301.9763,  301.6818,
+ ocean_z                             ; vertical profile of layer depths for ocean (in meters), e.g.:
+                                     =       5.,       15.,       25.,       35.,       45.,       55.,
+                                            65.,       75.,       85.,       95.,      105.,      115.,
+                                           125.,      135.,      145.,      155.,      165.,      175.,
+                                           185.,      195.,      210.,      230.,      250.,      270.,
+                                           290.,      310.,      330.,      350.,      370.,      390.
+ ocean_t                             ; vertical profile of ocean temps, e.g.:
+                                     = 302.3493,  302.3493,  302.3493,  302.1055,  301.9763,  301.6818,
                                        301.2220,  300.7531,  300.1200,  299.4778,  298.7443,  297.9194,
                                        297.0883,  296.1443,  295.1941,  294.1979,  293.1558,  292.1136,
                                        291.0714,  290.0293,  288.7377,  287.1967,  285.6557,  284.8503,
                                        284.0450,  283.4316,  283.0102,  282.5888,  282.1674,  281.7461
- ocean_s                             =  34.0127,   34.0127,   34.0127,   34.3217,   34.2624,   34.2632,
+ ocean_s                             ; vertical profile of salinity, e.g.:
+                                     =  34.0127,   34.0127,   34.0127,   34.3217,   34.2624,   34.2632,
                                         34.3240,   34.3824,   34.3980,   34.4113,   34.4220,   34.4303,
                                         34.6173,   34.6409,   34.6535,   34.6550,   34.6565,   34.6527,
                                         34.6490,   34.6446,   34.6396,   34.6347,   34.6297,   34.6247,
@@ -359,7 +362,7 @@ Namelist variables for controling the specified moving nest:
                    Note that this moving nest option needs to be activated at the compile time by adding -DMOVE_NESTS
                    to the ARCHFLAGS. The maximum number of moves, max_moves, is set to 50 
                    but can be modified in source code file frame/module_driver_constants.F.
- num_moves                           = 4        ; total number of moves
+ num_moves                           = 0        ; total number of moves
  move_id(max_moves)                  = 2,2,2,2, ; a list of nest domain id's, one per move
  move_interval(max_moves)            = 60,120,150,180,   ; time in minutes since the start of this domain
  move_cd_x(max_moves)                = 1,1,0,-1,; the number of parent domain grid cells to move in i direction
@@ -454,7 +457,7 @@ Namelist variables for controlling the adaptive time step option:
  Note: even the physics options can be different in different nest domains, 
        caution must be used as what options are sensible to use
 
- chem_opt                            = 0,       ; chemistry option - use WRF-Chem
+ chem_opt (max_dom)                  = 0,       ; chemistry option - use WRF-Chem
  mp_physics (max_dom)                microphysics option
                                      = 0, no microphysics
                                      = 1, Kessler scheme
@@ -498,6 +501,8 @@ Namelist variables for controlling the adaptive time step option:
                                      = 30, HUJI (Hebrew University of Jerusalem, Israel) spectral bin microphysics,
                                            fast version
                                      = 32, HUJI spectral bin microphysics, full version
+                                     = 50, P3 1-category
+                                     = 51, P3 1-category plus double-moment cloud water
                                      = 95, Ferrier (old Eta) microphysics, operational NAM (WRF NMM) version
 
  For non-zero mp_physics options, to keep Qv .GE. 0, and to set the other moisture
@@ -521,7 +526,7 @@ Namelist variables for controlling the adaptive time step option:
                                                  default value = 0
                                                  gsfcgce_hail is ignored if gsfcgce_2ice is set to 1 or 2.
  hail_opt                            = 0       ; hail switch for WSM6, WDM6 and Morrison schemes: 0 - off, 1 - on (new in 3.6.1)
- progn                               = 0       ; switch to use mix-activate scheme (Only for Morrison, WDM6, WDM5, 
+ progn (max_dom)                     = 0       ; switch to use mix-activate scheme (Only for Morrison, WDM6, WDM5, 
                                                  and NSSL_2MOMCCN/NSSL_2MOM
  ccn_conc                            = 1.E8    ; CCN concentration, used by WDM schemes (new in 3.6.1)
 
@@ -588,8 +593,8 @@ Namelist variables for controlling the adaptive time step option:
  cam_abs_freq_s                      = 21600 default CAM clearsky longwave absorption calculation frequency
                                             (recommended minimum value to speed scheme up)
  levsiz                              = 59 for CAM radiation input ozone levels, set automatically
- paerlev                             = 29 for CAM radiation input aerosol levels, set automatically
- cam_abs_dim1                        = 4 for CAM absorption save array, set automatically
+ paerlev                             = 29 for CAM radiation input aerosol levels, set automatically 
+ cam_abs_dim1                        = 4 for CAM absorption save array, set automatically 
  cam_abs_dim2                        = value of e_vert for CAM 2nd absorption save array, set automatically
 
  o3input                             = ozone input option for radiation (currently rrtmg only)
@@ -600,30 +605,30 @@ Namelist variables for controlling the adaptive time step option:
                                      = 1, using Tegen (1997) data, 
                                      = 2, using J. A. Ruiz-Arias method (see other aer_* options) 
                                      = 3, using G. Thompson's water/ice friendly climatological aerosol 
- alevsiz                             = 12 for Tegen aerosol input levels, set automatically
+ alevsiz                             = 12 for Tegen aerosol input levels, set automatically 
  no_src_types                        = 6 for Tegen aerosols: organic and black carbon, sea salt, sulfalte, dust,
                                        and stratospheric aerosol (volcanic ashes - currently 0), set automatically
 
  The following aerosol options allow RRTMG and new Goddard radiation schemes to see it, but the aerosols are
      constant during the model integration.
- aer_aod550_opt                      = [1,2] :
+ aer_aod550_opt (max_dom)            = [1,2] :
                                        1 = input constant value for AOD at 550 nm from namelist.
                                            In this case, the value is read from aer_aod550_val;
-                                       2 = input value from auxiliary input 5. It is a time-varying 2D grid in netcdf 
+                                       2 = input value from auxiliary input 15. It is a time-varying 2D grid in netcdf 
                                            wrf-compatible format. The default is aer_aod550_opt=1 and aer_aod550_val=0.12
- aer_aod550_val                      = 0.12
- aer_angexp_opt                      = [1,2,3] :
+ aer_aod550_val (max_dom)            = 0.12
+ aer_angexp_opt (max_dom)            = [1,2,3] :
                                        1 = input constant value for Angstrom exponent from namelist. In this case, 
                                            the value is read from aer_angexp_val;
-                                       2 = input value from auxiliary input 5, as in aer_aod550_opt;
+                                       2 = input value from auxiliary input 15, as in aer_aod550_opt;
                                        3 = Angstrom exponent value estimated from the aerosol type defined in aer_type, and modulated
                                            with the RH in WRF. Default operation is aer_angexp_opt = 1, and aer_angexp_val=1.3.
- aer_angexp_val                      = 1.3   
- aer_ssa_opt                         = [1,2,3] similar to aer_angexp_opt.
- aer_ssa_val                         = 0.85
- aer_asy_opt                         = [1,2,3] similar to aer_angexp_opt.
- aer_asy_val                         = 0.9
- aer_type                            = [1,2,3] : 1 for rural, 2 is urban and 3 is maritime.
+ aer_angexp_val (max_dom)            = 1.3   
+ aer_ssa_opt (max_dom)               = [1,2,3] similar to aer_angexp_opt.
+ aer_ssa_val (max_dom)               = 0.85
+ aer_asy_opt (max_dom)               = [1,2,3] similar to aer_angexp_opt.
+ aer_asy_val (max_dom)               = 0.9
+ aer_type (max_dom)                  = [1,2,3] : 1 for rural, 2 is urban and 3 is maritime.
 
  sf_sfclay_physics (max_dom)         surface-layer option (old bl_sfclay_physics option)
                                      = 0, no surface-layer
@@ -659,7 +664,7 @@ Namelist variables for controlling the adaptive time step option:
                                      = 0, no boundary-layer 
                                      = 1, YSU scheme
                                      = 2, Mellor-Yamada-Janjic TKE scheme
-                                     = 3, NCEP Global Forecast System scheme (NMM only)
+                                     = 3, Hybrid EDMF GFS scheme (NMM only)
                                      = 4, Eddy-diffusivity Mass Flux, Quasi-Normal Scale Elimination PBL
                                      = 5, MYNN 2.5 level TKE scheme, works with
                                           sf_sfclay_physics=1 or 2 as well as 5
@@ -672,6 +677,7 @@ Namelist variables for controlling the adaptive time step option:
                                           sf_sfclay_physics=10
                                      = 11, Shin-Hong 'scale-aware' PBL scheme
                                      = 12, Grenier-Bretherton-McCaa scheme (ARW only)
+                                     = 93, 2015 GFS scheme (NMM only)
                                      = 99, MRF scheme
 
  bldt (max_dom)                      = 0,       ; minutes between boundary-layer physics calls
@@ -699,7 +705,7 @@ Namelist variables for controlling the adaptive time step option:
  icloud_bl                           option to couple the subgrid-scale clouds from the PBL scheme (MYNN only) 
                                      to radiation schemes 
                                      0: no coupling; 1: activate coupling to radiation (default)
- bl_mynn_cloudmix                    option to activate mixing of qc and qi in MYNN
+ bl_mynn_cloudmix (max_dom)          = 0, default off; =1 activates mixing of qc and qi in MYNN
                                      0: no mixing of qc & qi; 1: mixing activated (default). 
                                        Note qnc and qni are mixed when scalar_pblmix =1.
  bl_mynn_mixlength                   option to change mixing length formulation in MYNN
@@ -710,16 +716,16 @@ Namelist variables for controlling the adaptive time step option:
                                        the edmf options.
  bl_mynn_cloudpdf                    option to switch to different cloud PDFs to represent subgrid clouds
                                      0: original (Sommeria and Deardorf 1977); 
-                                     1: Kuwano et al 2010?, similar to option 0, but uses resolved scale gradients 
+                                     1: Kuwano et al 2010, similar to option 0, but uses resolved scale gradients 
                                         as opposed to higher order moments ; 
                                      2: from Chaboureau and Bechtold (2002, JAS, with mods, default) 
- bl_mynn_edmf                        option to activate mass-flux scheme in MYNN 
+ bl_mynn_edmf (max_dom)              = 0, default; = 1 activates mass-flux scheme in MYNN 
                                      1: for StEM; 2: for TEMF; default =0, just regular MYNN. 
                                      Related (hidden) options: 
- bl_mynn_edmf_mom                    option to activate momentum transport in MYNN mass-flux scheme 
-                                     (assuming bl_mynn_edmf > 0)
+ bl_mynn_edmf_mom (max_dom)          = 1, default - activates momentum transport in MYNN mass-flux scheme 
+                                     (assuming bl_mynn_edmf > 0); 0=off
                                      0: no momentum transport; 1: momentum transport activated (default)
- bl_mynn_edmf_tke                    option to activate TKE transport in MYNN mass-flux scheme 
+ bl_mynn_edmf_tke (max_dom)          = 0, default; = 1 activates TKE transport in MYNN mass-flux scheme 
                                      (assuming bl_mynn_edmf > 0)
                                      0: no TKE transport (default);1: activate TKE transport
 
@@ -733,15 +739,15 @@ Namelist variables for controlling the adaptive time step option:
                                      = 0 ; default; use dominant category only
                                      = 1 ; use mosaic landuse categories
  mosaic_cat                          = 3 ; number of mosaic landuse categories in a grid cell
- mosaic_lu                           = 1 ;  use mosaic landuse categories in RUC; default is 0
- mosaic_soil                         = 1 ;  use mosaic soil categories in RUC; default is 0
+ mosaic_lu                           = 0, default ;  set to = 1 to use mosaic landuse categories in RUC
+ mosaic_soil                         = 0, default ;  set to = 1 to use mosaic soil categories in RUC
 
  cu_physics (max_dom)                cumulus option
                                      = 0, no cumulus
                                      = 1, Kain-Fritsch (new Eta) scheme
                                      = 2, Betts-Miller-Janjic scheme
                                      = 3, Grell-Freitas ensemble scheme
-                                     = 4, Old GFS simplified Arakawa-Schubert scheme 
+                                     = 4, Scale-aware GFS Simplified Arakawa-Schubert (SAS) scheme 
                                      = 5, Grell 3D ensemble scheme
                                      = 6, Modifed Tiedtke scheme (ARW only)
                                      = 7, Zhang-McFarlane scheme from CAM5 (CESM 1_0_1)
@@ -749,7 +755,8 @@ Namelist variables for controlling the adaptive time step option:
                                      = 11, Multi-scale Kain-Fritsch scheme
                                      = 14, New GFS simplified Arakawa-Schubert scheme from YSU (ARW only)
                                      = 16, A newer Tiedtke scheme
-                                     = 84, New GFS simplified Arakawa-Schubert scheme (HWRF) 
+                                     = 94, 2015 GFS Simplified Arakawa-Schubert scheme (HWRF) 
+                                     = 95, Previous GFS Simplified Arakawa-Schubert scheme (HWRF) 
                                      = 93, Grell-Devenyi ensemble scheme
                                      = 99, previous Kain-Fritsch scheme
 
@@ -759,9 +766,9 @@ Namelist variables for controlling the adaptive time step option:
                                      = 2, Park and Bretherton shallow cumulus from CAM5 (CESM 1_0_1)
                                      = 3, GRIMS shallow cumulus from YSU group
 
- ishallow                            = 1,   Shallow convection used with Grell 3D ensemble schemes (cu_physics = 3 or 5)
+ ishallow                            = 0,   = 1 turns on shallow convection, used with Grell 3D ensemble schemes (cu_physics = 3 or 5)
  clos_choice                         = 0,   closure choice (place holder only)
- cu_diag                             = 0,   additional t-averaged stuff for cu physics (cu_phys = 3, 5 and 93 only)
+ cu_diag (max_dom)                   = 0,   additional t-averaged stuff for cu physics (cu_phys = 3, 5 and 93 only)
  kf_edrates (max_dom)                = 0,   Add entrainment/detrainment rates and convective timescale output variables for KF-based 
                                             cumulus schemes (cu_phys = 1, 11 and 99 only) (new in 3.8)
                                      = 0,   no output; = 1, additional output
@@ -769,7 +776,7 @@ Namelist variables for controlling the adaptive time step option:
  cu_rad_feedback (max_dom)           = .false.  ; sub-grid cloud effect to the optical depth in radiation
                                                   currently it works only for GF, G3, GD and KF scheme
                                                   One also needs to set cu_diag = 1 for GF, G3 and GD schemes
- cudt                                = 0,       ; minutes between cumulus physics calls
+ cudt (max_dom)                      = 0,       ; minutes between cumulus physics calls
  kfeta_trigger                       KF trigger option (cu_physics=1 only):
                                      = 1, default option
                                      = 2, moisture-advection based trigger (Ma and Tan [2009]) - ARW only
@@ -814,7 +821,7 @@ Namelist variables for controlling the adaptive time step option:
                                                       tke_heat_flux with bl_pbl_physics=0
  ideal_xland                         = 1,       ; sets XLAND (1=land,2=water) for ideal cases with no input land-use
                                                       run-time switch for wrf.exe physics_init (default 1 as before)
- ifsnow                              = 0,	; snow-cover effects
+ ifsnow                              = 1,	; snow-cover effects
                                                   (only works for sf_surface_physics = 1)
                                                   1 = with snow-cover effect
                                                   0 = without snow-cover effect
@@ -897,7 +904,7 @@ Namelist variables for controlling the adaptive time step option:
  ocean_levels                        = 30       ; number of vertical levels in 3DPWP. Note that the depth of each ocean 
                                                 ; model layers is specified in OM_DEPTH in wrfinput_d01
  traj_opt                            = 0        ; Forward trajectory calculation (Lee and Chen 2013)
- num_traj                            = 50       ; number of trajectories to be released
+ num_traj                            = 1000     ; number of trajectories to be released
  isftcflx                            = 0        ; alternative Ck, Cd formulation for tropical storm application 
                                                 ; sf_sfclay=1 and 11
                                                 ; 0=default
@@ -908,7 +915,7 @@ Namelist variables for controlling the adaptive time step option:
                                                 ;             =1: z0 from Davis et al (2008), zt & zq from COARE3.0
                                                 ;             =2: z0 from Davis et al (2008), zt & zq from Garratt (1992)
  fractional_seaice                   = 0        ; treat sea-ice as fractional field (1) or ice/no-ice flag (0)
-                                                  works for sf_sfclay_physics=1,2,5,or 7.
+                                                  works for sf_sfclay_physics=1,2,3,4,5,7,and 91 
                                                   If fractional_seaice = 1, also set seaice_threshold = 0.
  seaice_albedo_opt                   = 0        ; option to set albedo over sea ice
                                                 ; 0 = seaice albedo is a constant value from namelist option seaice_albedo_default
@@ -937,6 +944,9 @@ Namelist variables for controlling the adaptive time step option:
                                                   to the vegetation canopy. Also uses new columns added in VEGPARM.TBL
  do_radar_ref			     = 0, 	; 1 = allows radar reflectivity to be computed using mp-scheme-specific
  						  parameters.  Currently works for mp_physics = 2,4,6,7,8,10,14,16
+ hailcast_opt (max_dom)              = 0, 	; 1 = 1-D hail growth model which predicts 1st-5th rank-ordered hail diameters, mean hail 
+                                                  diagmeter and standard deviation of hail diameter. (Adams-Selin and Ziegler, MWR Dec 2016.) 
+                                                  Updated in V3.9, replacing afwa_hailcast_opt in previous versions.
 				
 Namelist variables for lake module: 
 
@@ -945,7 +955,7 @@ Namelist variables for lake module:
                                                   is assumed to be 50m)  
  lake_min_elev(max_dom)              = 5,       ; minimum elevation of lakes. May be used to determine whether a water point is a lake in the absence of lake
                                                   category. If the landuse type includes 'lake' (i.e. Modis_lake and USGS_LAKE), this variable is of no effects. 
- use_lakedepth                       = 1,       ; option to use lake depth data. Lake depth data is available from 3.6 geogrid program. If one didn't process
+ use_lakedepth (max_dom)             = 1,       ; option to use lake depth data. Lake depth data is available from 3.6 geogrid program. If one didn't process
                                                   the lake depth data, but this switch is set to 1, the program will stop and tell one to go back to geogrid
                                                   program. 
                                                   = 0, do not use lake depth data.
@@ -975,12 +985,12 @@ Namelist variables for lake module:
                                      = 3        ; Parameterization by Price and Rind (1993) based on cold-cloud depth
                                      = 4        ; Gridded input via arrays iccg_in_(num|den) from wrfinput for monthly mapped ratios. 
                                                   Points with 0/0 values use ratio defined by iccg_prescribed_(num|den)
- iccg_prescribed_num                 = 0.       ; Numerator of user-specified prescribed IC:CG
- iccg_prescribed_den                 = 1.       ; Denominator of user-specified prescribed IC:CG
+ iccg_prescribed_num (max_dom)       = 0.       ; Numerator of user-specified prescribed IC:CG
+ iccg_prescribed_den (max_dom)       = 1.       ; Denominator of user-specified prescribed IC:CG
 
 Options for wind turbine drag parameterization:
 
- windfarm_opt                       = 0         ; 1 = Simulates the effects of wind turbines in the atmospheric evolution
+ windfarm_opt (max_dom)             = 0         ; 1 = Simulates the effects of wind turbines in the atmospheric evolution
  windfarm_ij                        = 0         ; whether to use lat-lon or i-j coordinate as wind turbine locations    
                                                 ; 0 = The coordinate of the turbines are defined in terms of lat-lon
                                                 ; 1 = The coordinate of the turbines are defined in terms of grid points
@@ -989,32 +999,36 @@ Options for wind turbine drag parameterization:
 Stochastic parameterization schemes:
 
 &stoch
- skebs                                = 1       ; stochastic kinetic-energy backscatter scheme, 1: on
- tot_backscat_psi                     = 1.0E-05 ; total backscattered dissipation for streamfunction; 
-                                                ; determines amplitude of streamfunction perturbations
- tot_backscat_t                       = 1.0E-06 ; total backscattered dissipation for potential temperature 
- ztau_psi                             = 10800.0 ; decorrelation time scale of noise for streamfunction perturbations
- rand_perturb                         = 1       ; generate array with random perturbations for user determined use, 1: on
- gridpt_stddev_rand_pert              = 0.03    ; standard deviation of random perturbations at each gridpoint  
-                                                ; determines amplitude of random perturbations 
- stddev_cutoff_rand_pert              = 3.0     ; cutoff tails of pdf above this threshold standard deviation
- lengthscale_rand_pert                = 500000.0 ; correlation length scale in meters
- timescale_rand_pert                  = 21600.0 ; decorrelation time scale in s
- nens                                 = 1       ; creates different seed for random number streams in either stochastic scheme
-                                                ; must be different for each member in ensemble forecasts 
-
-Options for stochastic kinetic-energy backscatter scheme:
-
- stoch_force_opt (max_dom)          = 0,        : No stochastic parameterization
-                                      1,        : Stochastic kinetic-energy backscatter scheme (SKEB)
- stoch_vertstruc_opt (max_dom)      = 0,        : Constant vertical structure of random pattern generator
-                                      1,        : Random phase vertical structure random pattern generator
- tot_backscat_psi                   = 1.0E-05   ; Controls amplitude of rotational wind perturbations
- tot_backscat_t                     = 1.0E-06   ; Controls amplitude of potential temperature perturbations
- nens                               = 1         ; an integer that controls the random number stream which will then
-                                                  change the run. When running an ensemble, this can be
-                                                  ensemble member number, so that each ensemble member gets a
-                                                  different random number stream, hence a different perturbed run.
+; Random perturbation field (rand_perturb=1) 
+ rand_perturb (max_dom)               = 1        ; Generate array with random perturbations for user-determined use, 1: on
+ gridpt_stddev_rand_pert (max_dom)    = 0.03     ; Standard deviation of random perturbation field at each gridpoint.
+                                                 ; Determines amplitude of random perturbations
+ lengthscale_rand_pert (max_dom)      = 500000.0 ; Perturbation lengthscale (in m).
+ timescale_rand_pert (max_dom)        = 21600.0  ; Temporal decorrelation of random field (in s).
+ stddev_cutoff_rand_pert (max_dom)    = 3.0      ; Cutoff tails of perturbation pattern above this threshold standard deviation.
+ rand_pert_vertstruc                  = 0        ; Vertical structure for random perturbation field: 0=constant; 1=random phase with tilt
+ iseed_rand_pert                                 ; Seed for random number stream for rand_perturb. Will be
+                                                 ; combined with seed nens signifying ensemble member number and initial
+                                                 ; start time to ensure different random number streams for forecasts
+                                                 ; starting from different initial times and for different ensemble members.
+
+; Stochastically perturbed physics tendencies (SPPT) (sppt=1)
+ sppt (max_dom)                       = 0        ; Stochastically perturbed physics tendencies (SPPT), 0: off, 1: on
+ gridpt_stddev_sppt (max_dom)         = 0.5      ; Standard deviation of random perturbation field at each gridpoint.
+                                                 ; Determines amplitude of random perturbations
+ lengthscale_sppt (max_dom)           = 150000.0 ; Perturbation lengthscale (in m).
+ timescale_sppt (max_dom)             = 21600.0  ; Temporal decorrelation of random field (in s).
+ stddev_cutoff_sppt (max_dom)         = 2.0      ; Cutoff tails of perturbation pattern above this threshold standard deviation.
+ iseed_sppt                                      ; Seed for random number stream for sppt. Will be
+                                                 ; combined with seed nens signifying ensemble member number and initial
+                                                 ; start time to ensure different random number streams for forecasts
+                                                 ; starting from different initial times and for different ensemble members.
+
+; Stochastic kinetic-energy backscatter scheme (SKEBS)(skebs=1):
+
+ skebs (max_dom)                    = 0         ; stochastic kinetic-energy backscatter scheme, 0: off, 1: on
+ tot_backscat_psi (max_dom)         = 1.0E-05   ; Controls amplitude of rotational wind perturbations
+ tot_backscat_t (max_dom)           = 1.0E-06   ; Controls amplitude of potential temperature perturbations
  ztau_psi                           = 10800.0   ; decorr. time of noise for psi perturb
  ztau_t                             = 10800.0   ; decorr. time of noise for theta perturb
  rexponent_psi                      = -1.83     ; spectral slope of forcing for psi
@@ -1029,12 +1043,59 @@ Options for stochastic kinetic-energy backscatter scheme:
  lmaxforc                           = 1000000   ; max. forcing wavenumber in lat. for psi perturb
  kmaxforct                          = 1000000   ; max. forcing wavenumber in lon. for theta perturb
  lmaxforct                          = 1000000   ; max. forcing wavenumber in lat. for theta perturb
- perturb_chem_bdy                               ; Options for perturbing lateral boundaries of chemical tracers:
-                                                  0 = off; 1 = on with RAND_PERTURB pattern
+ skebs_vertstruc                    = 0         ; Vertical structure for random perturbation field: 0=constant; 1=random phase with tilt
+
+Stochastically perturbed parameter scheme (SPP) (spp=1)
+ sppt (max_dom)                      = 0        ; Stochastically perturbed parameter (SPP) scheme for
+                                                ; GF convection schems, MYNN boundary layer scheme and RUC LSM. 0: off, 1: on
+ spp_conv (max_dom)                  = 0        ; Perturb parameters of GF convection scheme only
+ gridpt_stddev_spp_conv (max_dom)    = 0.3      ; Standard deviation of random perturbation field at each gridpoint.
+                                                ; Determines amplitude of random perturbations
+ lengthscale_spp_conv (max_dom)      = 150000.0 ; Perturbation lengthscale (in m).
+ timescale_spp_conv (max_dom)        = 21600.0  ; Temporal decorrelation of random field (in s).
+ stddev_cutoff_spp_conv (max_dom)    = 3.0      ; Cutoff tails of perturbation pattern above this threshold standard deviation.
+ iseed_spp_conv                                 ; Seed for random number stream for spp_conv. Will be
+                                                ; combined with seed nens signifying ensemble member number and initial
+                                                ; start time to ensure different random number streams for forecasts
+                                                ; starting from different initial times and for different ensemble members.
+ spp_pbl (max_dom)                   = 0        ; Perturb parameters of MYNN PBL scheme only
+ gridpt_stddev_spp_pbl (max_dom)     = 0.15     ; Standard deviation of random perturbation field at each gridpoint.
+                                                ; Determines amplitude of random perturbations
+ lengthscale_spp_pbl (max_dom)       = 70000.0  ; Perturbation lengthscale (in m).
+ timescale_spp_pbl (max_dom)         = 21600.0  ; Temporal decorrelation of random field (in s).
+ stddev_cutoff_spp_pbl (max_dom)     = 2.0      ; Cutoff tails of perturbation pattern above this threshold standard deviation.
+ iseed_spp_pbl                                  ; Seed for random number stream for spp_pbl . Will be
+                                                ; combined with seed nens signifying ensemble member number and initial
+                                                ; start time to ensure different random number streams for forecasts
+                                                ; starting from different initial times and for different ensemble members.
+ spp_lsm (max_dom)                   = 0        ; Perturb parameters of RUC LSM
+ gridpt_stddev_spp_lsm (max_dom)     = 0.3      ; Standard deviation of random perturbation field at each gridpoint.
+                                                ; Determines amplitude of random perturbations
+ lengthscale_spp_lsm (max_dom)       = 50000.0  ; Perturbation lengthscale (in m).
+ timescale_spp_lsm (max_dom)         = 86400.0  ; Temporal decorrelation of random field (in s).
+ stddev_cutoff_spp_lsm (max_dom)     = 3.0      ; Cutoff tails of perturbation pattern above this threshold standard deviation.
+ iseed_spp_lsm                                  ; Seed for random number stream for spp_lsm . Will be
+                                                ; combined with seed nens signifying ensemble member number and initial
+                                                ; start time to ensure different random number streams for forecasts
+                                                ; starting from different initial times and for different ensemble members.
+
+; Stochastic Perturbations to the boundary conditions?| (perturb_bdy)
  perturb_bdy                        = 0         ; No boundary perturbations
                                       1         ; Use SKEBS pattern for boundary perturbations
                                       2         ; Use other user-provided pattern for boundary perturbations
 
+; Stochastic perturbations to the boundary tendencies in WRF-CHEM (perturb_chem_bdy)
+ perturb_chem_bdy                               ; Options for perturbing lateral boundaries of chemical tracers:
+                                                ;  0 = off; 1 = on with RAND_PERTURB pattern
+
+; Common to all stochastic schemes
+  nens                                =1        ; Seed for random number stream. For ensemble forecasts this parameter needs to be
+                                                ; different for each member. The seed is a function of initial start time
+                                                ; to ensure different random number streams for forecasts starting from
+                                                ; different initial times. Changing this seed changes the random number
+                                                ; streams for all activated stochastic parameterization schemes.
+
+
 Options for use with the Noah-MP Land Surface Model:
 
 &noah_mp
@@ -1044,6 +1105,11 @@ Options for use with the Noah-MP Land Surface Model:
                                                 ;    3 = Off (LAI from table; FVEG calculated)
                                                 ;    4 = Off (LAI from table; FVEG = maximum veg. fraction)
                          			;    5 = On  (LAI predicted;  FVEG = maximum veg. fraction)
+                                                ;    6 = On  (use FVEG = SHDFAC from input)
+                                                ;    7 = Off (use input LAI; use FVEG = SHDFAC from input)
+                                                ;    8 = Off (use input LAI; calculate FVEG)
+                                                ;    9 = Off (use input LAI; use maximum vegetation fraction)
+                                                ;   10 = crop model on (use maximum vegetation fraction)
  opt_crs                            = 1,        ; Noah-MP Stomatal Resistance option:
                                                 ;    1 = Ball-Berry; 2 = Jarvis
  opt_sfc                            = 1         ; Noah-MP surface layer drag coefficient calculation
@@ -1052,10 +1118,10 @@ Options for use with the Noah-MP Land Surface Model:
                                                 ;    options 3 and 4 removed in 3.7
  opt_btr                            = 1,        ; Noah-MP Soil Moisture Factor for Stomatal Resistance
                                                 ;    1 = Noah; 2 = CLM; 3 = SSiB
- opt_run                            = 1,        ; Noah-MP Runoff and Groundwater option
+ opt_run                            = 3,        ; Noah-MP Runoff and Groundwater option
                                                 ;    1 = TOPMODEL with groundwater
                                                 ;    2 = TOPMODEL with equilibrium water table
-                                                ;    3 = original surface and subsurface runoff (free drainage)
+                                                ;    3 = original surface and subsurface runoff (free drainage) - default
                                                 ;    4 = BATS surface and subsurface runoff (free drainage)
  opt_frz                            = 1,        ; Noah-MP Supercooled Liquid Water option
                                                 ;    1 = No iteration; 2 = Koren's iteration
@@ -1111,8 +1177,7 @@ Options for use with the Noah-MP Land Surface Model:
  gt (max_dom)                        = 0.0003   ; nudging coefficient for temp (sec-1)
  gq (max_dom)                        = 0.0003   ; nudging coefficient for qvapor (sec-1)
  if_ramping                          = 0        ; 0= nudging ends as a step function, 1= ramping nudging down at end of period
- dtramp_min                          = 60.0     ; time (min) for ramping function, 60.0=ramping starts at last analysis time, 
-                                                                                  -60.0=ramping ends at last analysis time
+ dtramp_min                          = 0        ; time (min) for ramping function 
  grid_sfdda (max_dom)                = 0        ; surface fdda switch
                                                   0: off; 
                                                   1: nudging selected surface fields; 
@@ -1124,7 +1189,7 @@ Options for use with the Noah-MP Land Surface Model:
  guv_sfc (max_dom)                   = 0.0003   ; nudging coefficient for sfc u and v (sec-1)
  gt_sfc (max_dom)                    = 0.0003   ; nudging coefficient for sfc temp (sec-1)
  gq_sfc (max_dom)                    = 0.0003   ; nudging coefficient for sfc qvapor (sec-1)
- rinblw                              = 250.0    ; radius of influence used to determine the confidence (or weights) for
+ rinblw (max_dom)                    = 0.       ; radius of influence used to determine the confidence (or weights) for
                                                   the analysis, which is based on the distance between the grid point to the nearest
                                                   obs. The analysis without nearby observation is used at a reduced weight.
 
@@ -1132,7 +1197,7 @@ Options for use with the Noah-MP Land Surface Model:
 
 The following are for spectral nudging:
  fgdtzero (max_dom)                  = 0,       ; 1= nudging tendencies are set to zero in between fdda calls
- if_no_pbl_nudging_ph                = 0,       ; 1= no nudging of ph in the pbl, 0= nuding in the pbl
+ if_no_pbl_nudging_ph (max_dom)      = 0,       ; 1= no nudging of ph in the pbl, 0= nuding in the pbl
  if_zfac_ph (max_dom)                = 0,       ; 0= nudge ph in all layers, 1= limit nudging to levels above k_zfac_ph
   k_zfac_ph (max_dom)                = 10,      ; 10= model level below which nudging is switched off for ph
  dk_zfac_uv (max_dom)                = 1,       ; depth in k between k_zfac_X to dk_zfac_X where nudging increases 
@@ -1147,27 +1212,27 @@ The following are for observation nudging:
  obs_nudge_opt (max_dom)             = 1        ; obs-nudging fdda on (=0 off) for each domain
                                                   also need to set auxinput11_interval and auxinput11_end_h
                                                   in time_control namelist
- max_obs                             = 150000   ; max number of observations used on a domain during any 
+ max_obs                             = 0   ; max number of observations used on a domain during any 
                                                   given time window
- fdda_start                          = 0        ; obs nudging start time in minutes
- fdda_end                            = 180      ; obs nudging end time in minutes
+ fdda_start (max_dom)                = 0        ; obs nudging start time in minutes
+ fdda_end (max_dom)                  = 0        ; obs nudging end time in minutes
  obs_nudge_wind (max_dom)            = 1        ; whether to nudge wind: (=0 off)
- obs_coef_wind                       = 6.E-4,   ; nudging coefficient for wind, unit: s-1
- obs_nudge_temp                      = 1        ; whether to nudge temperature: (=0 off)
- obs_coef_temp                       = 6.E-4,   ; nudging coefficient for temperature, unit: s-1
- obs_nudge_mois                      = 1        ; whether to nudge water vapor mixing ratio: (=0 off)
- obs_coef_mois                       = 6.E-4,   ; nudging coefficient for water vapor mixing ratio, unit: s-1
- obs_nudge_pstr                      = 0        ; whether to nudge surface pressure (not used)
- obs_coef_pstr                       = 0.       ; nudging coefficient for surface pressure, unit: s-1 (not used)
- obs_rinxy                           = 200.,    ; horizonal radius of influence in km
- obs_rinsig                          = 0.1,     ; vertical radius of influence in eta
+ obs_coef_wind (max_dom)             = 0,       ; nudging coefficient for wind, unit: s-1
+ obs_nudge_temp (max_dom)            = 0,       ; set to = 1 to turn to nudge temperature (default = 0; off) 
+ obs_coef_temp (max_dom)             = 0,       ; nudging coefficient for temperature, unit: s-1
+ obs_nudge_mois (max_dom)            = 1        ; whether to nudge water vapor mixing ratio: (=0 off)
+ obs_coef_mois (max_dom)             = 0,       ; nudging coefficient for water vapor mixing ratio, unit: s-1
+ obs_nudge_pstr (max_dom)            = 0        ; whether to nudge surface pressure (not used)
+ obs_coef_pstr (max_dom)             = 0.       ; nudging coefficient for surface pressure, unit: s-1 (not used)
+ obs_rinxy (max_dom)                 = 0.       ; horizonal radius of influence in km
+ obs_rinsig                          = 0        ; vertical radius of influence in eta
  obs_twindo (max_dom)                = 0.66667  ; half-period time window over which an observation 
                                                   will be used for nudging (hours)
- obs_npfi                            = 10,      ; freq in coarse grid timesteps for diag prints
+ obs_npfi                            = 0,       ; freq in coarse grid timesteps for diagnostic prints
  obs_ionf (max_dom)                  = 2        ; freq in coarse grid timesteps for obs input and err calc
  obs_idynin                          = 0        ; for dynamic initialization using a ramp-down function to gradually
                                                   turn off the FDDA before the pure forecast (=1 on)
- obs_dtramp                          = 40       ; time period in minutes over which the nudging is ramped down 
+ obs_dtramp                          = 0        ; time period in minutes over which the nudging is ramped down 
                                                   from one to zero.
  obs_prt_freq (max_dom)              = 10,      ; Frequency in obs index for diagnostic printout
  obs_prt_max                         = 1000,    ; Maximum allowed obs entries in diagnostic printout
@@ -1220,8 +1285,8 @@ The following are for observation nudging:
  scm_isltyp                          = 4        ; SCM soil category (4 is silt loam)
  scm_vegfra                          = 0.5      ; SCM vegetation fraction
  scm_canwat                          = 0.0      ; SCM canopy water
- scm_lat                             = 37.600   ; SCM latitude
- scm_lon                             = -96.700  ; SCM longitude
+ scm_lat                             = 36.605   ; SCM latitude
+ scm_lon                             = -97.485  ; SCM longitude
  scm_th_adv                          = .true.   ; turn on theta advection in SCM
  scm_wind_adv                        = .true.   ; turn on wind advection in SCM
  scm_qv_adv                          = .true.   ; turn on moisture advection in SCM
@@ -1273,13 +1338,13 @@ The following are for observation nudging:
                                                   1 = include QV and QC tendencies - this helps to produce correct solution
                                                       in an idealized 'moist benchmark' test case (Bryan, 2014).
                                                       In real data testing, time step needs to be reduce to maintain stable solution
- c_s                                 = 0.25     ; Smagorinsky coeff
- c_k                                 = 0.15     ; TKE coeff
- diff_6th_opt                        = 0,       ; 6th-order numerical diffusion
+ c_s (max_dom)                       = 0.25     ; Smagorinsky coeff
+ c_k (max_dom)                       = 0.15     ; TKE coeff
+ diff_6th_opt (max_dom)              = 0,       ; 6th-order numerical diffusion
                                                   0 = no 6th-order diffusion (default)
                                                   1 = 6th-order numerical diffusion (not recommended)
                                                   2 = 6th-order numerical diffusion but prohibit up-gradient diffusion
- diff_6th_factor                     = 0.12,    ; 6th-order numerical diffusion non-dimensional rate (max value 1.0
+ diff_6th_factor (max_dom)           = 0.12,    ; 6th-order numerical diffusion non-dimensional rate (max value 1.0
                                                       corresponds to complete removal of 2dx wave in one timestep)
  dampcoef (max_dom)                  = 0.,	; damping coefficient (see above)
  zdamp (max_dom)                     = 5000.,	; damping depth (m) from model top
@@ -1290,14 +1355,14 @@ The following are for observation nudging:
  base_pres                           = 10^5     ; real-data, em ONLY, base sea-level pres (Pa), DO NOT CHANGE
  base_lapse                          = 50.,     ; real-data, em ONLY, lapse rate (K), DO NOT CHANGE
  iso_temp                            = 200.,    ; real-data, em ONLY, reference temp in stratosphere, US Standard atmosphere 216.5 K
- base_pres_strat                     = 5500.    ; real-data, em ONLY, base state pressure (Pa) at bottom of the stratosphere, 
+ base_pres_strat                     = 0.       ; real-data, em ONLY, base state pressure (Pa) at bottom of the stratosphere, 
                                                   US Standard atmosphere 55 hPa
- base_lapse_strat                    = 0.       ; real-data, em ONLY, base state lapse rate ( dT / d(lnP) ) in stratosphere, 
+ base_lapse_strat                    = -11.     ; real-data, em ONLY, base state lapse rate ( dT / d(lnP) ) in stratosphere, 
                                                   approx to US Standard atmosphere -12 K
  use_baseparam_fr_nml                = .f.,     ; whether to use base state parameters from the namelist
  use_input_w                         = .f.,     ; whether to use vertical velocity from input file
- khdif (max_dom)                     = 0,	; horizontal diffusion constant (m^2/s)
- kvdif (max_dom)                     = 0,	; vertical diffusion constant (m^2/s)
+ khdif (max_dom)                     = 0,	; horizontal diffusion constant (m^2/s). A typical value should be 0.1*DX in meters.
+ kvdif (max_dom)                     = 0,	; vertical diffusion constant (m^2/s). A typical value should be 100.
  smdiv (max_dom)                     = 0.1,	; divergence damping (0.1 is typical)
  emdiv (max_dom)                     = 0.01,	; external-mode filter coef for mass coordinate model
                                                   (0.01 is typical for real-data cases)
@@ -1340,7 +1405,8 @@ The following are for observation nudging:
  do_coriolis (max_dom)               = .true.,	; whether to do Coriolis calculations (idealized) (inactive)
  do_curvature (max_dom)              = .true.,	; whether to do curvature calculations (idealized) (inactive)
  do_gradp (max_dom)                  = .true.,	; whether to do horizontal pressure gradient calculations (idealized) (inactive)
- fft_filter_lat                      = 45.      ; the latitude above which the polar filter is turned on
+ fft_filter_lat                      = 91.      ; the latitude above which the polar filter is turned on (degrees) - 45 degrees is a 
+                                                  reasonable latitude to start using polar filters
  coupled_filtering                   = .true.   ; T/F mu coupled scalar arrays are run through the polar filters
  pos_def                             = .false.  ; T/F remove negative values of scalar arrays by setting minimum value to zero
  swap_pole_with_next_j               = .false.  ; T/F replace the entire j=1 (jds-1) with the values from j=2 (jds-2)
@@ -1364,7 +1430,7 @@ The following are for observation nudging:
  spec_exp                            = 0.       ; exponential multiplier for relaxation zone ramp for specified=.t.
                                                   (0.=linear ramp default, e.g. 0.33=~3*dx exp decay factor)
  constant_bc                         = .false.  ; constant boundary condition used with DFI
- spec_bdy_final_mu                   = 0,       ; whether to call spec_bdy_final for mu (since 3.7): 
+ spec_bdy_final_mu                   = 1,       ; whether to call spec_bdy_final for mu (this may cause different restart results in V3.8): 
                                                   = 0, no call; = 1: call (this may cause different restart results)
 
  periodic_x (max_dom)                = .false., ; periodic boundary conditions in x direction
@@ -1378,11 +1444,11 @@ The following are for observation nudging:
  open_ys (max_dom)                   = .false., ; open boundary conditions at y start (south)
  open_ye (max_dom)                   = .false., ; open boundary conditions at y end (north)
  nested (max_dom)                    = .false., ; nested boundary conditions (must be used for nests)
- polar                               = .false., ; polar boundary condition
+ polar (max_dom)                     = .false., ; polar boundary condition
                                                   (v=0 at polarward-most v-point)
- have_bcs_moist                      = .false., ; model run after ndown only: do not use microphysics variables in bdy file
+ have_bcs_moist (max_dom)            = .false., ; model run after ndown only: do not use microphysics variables in bdy file
                                      = .true. , ; use microphysics variables in bdy file
- have_bcs_scalar                     = .false., ; model run after ndown only: do not use scalar variables in bdy file
+ have_bcs_scalar (max_dom)           = .false., ; model run after ndown only: do not use scalar variables in bdy file
                                      = .true. , ; use scalar variables in bdy file
 
  euler_adv                           = .false., ; conservative Eulerian passive advection (NMM only)
@@ -1463,6 +1529,108 @@ afwa_cloud_opt (max_dom)             = 0,       ; Cloud option, 1: on
 afwa_therm_opt (max_dom)             = 0,       ; Thermal indices option, 1: on
 afwa_turb_opt (max_dom)              = 0,       ; Turbulence option, 1: on
 afwa_buoy_opt (max_dom)              = 0,       ; Buoyancy option, 1: on
-afwa_hailcast_opt (max_dom)          = 0,       ; Hailcast option, 1: on
 afwa_ptype_ccn_tmp                   = 264.15,  ; CCN temperature for precipitation type calculation
 afwa_ptype_tot_melt                  = 50,      ; Total melting energy for precipitation type calculation
+
+
+
+
+Add an extra set of 3d arrays for vertical interpolation to the
+processing for the real program.  Typically, this extra data set
+is to include monthly aerosol data.  The vertical coordinate of the
+aerosol data is able to be separate from the input meteorological
+data.  To introduce new data sets, mods are required in the Registry
+and in module_initialize_real.F.  There is a space-holder/practice
+set-up for "GCA".  The actual data set for Thompson mp=28 (WIF) that 
+utilizes QNWFA and QNIFA (water and ice friendly aerosols) has 
+been tested.
+
+&domains
+ num_wif_levels                      = 30    
+ wif_input_opt                       = 1
+/
+ num_gca_levels                      = 13    
+ gca_input_opt                       = 1     
+
+
+Introduction of physics suite specification since v3.9:
+
+Starting with V3.9, there is a way to specify physics suite to use in the model. The physics suite
+specifies physics options 
+
+ mp_physics
+ cu_physics
+ ra_lw_physics
+ ra_sw_physics
+ bl_pbl_physics
+ sf_sfclay_physics
+ sf_surface_physics
+
+with a new namelist physics_suite = 'X'. Two suites are available in V3.9:
+
+ physics_suite = 'CONUS'
+
+ or 
+
+ physics_suite = 'tropical'
+
+where 'CONUS' is equivalent to
+
+ mp_physics         = 8,
+ cu_physics         = 6,
+ ra_lw_physics      = 4,
+ ra_sw_physics      = 4,
+ bl_pbl_physics     = 2,
+ sf_sfclay_physics  = 2,
+ sf_surface_physics = 2,
+
+and 'tropical' is equivalent to
+
+ mp_physics         = 6,
+ cu_physics         = 16,
+ ra_lw_physics      = 4,
+ ra_sw_physics      = 4,
+ bl_pbl_physics     = 1,
+ sf_sfclay_physics  = 91,
+ sf_surface_physics = 2,
+
+One can use physics_suite, and overwrite one or more options by explicitly including the physics 
+namelists.
+
+To overwrite an option for a nest, one can have
+
+ &physics
+ physics_suite                       = 'tropical'
+ cu_physics                          = -1,    -1,     0,
+ ...
+
+here '-1' means to use option specified by the suite, and '0' modifies the cumulus option from the 
+suite option 16 to 0 (turning cumulus off).
+
+
+Hybrid Vertical Coordinate (HVC) vs Terrain Following (TF)
+
+The HVC option is available starting in WRFv3.9. There is both a compile-time activation and
+a run-time activation. This option may not be used in conjunction with the vertical nesting
+refinement.
+
+Compile-time requirement for HVC:
+The user must build the code with 
+./configure -hyb
+
+Run-time requirement for HVC:
+There are two namelist settings that control the HVC option. Conventionally, the suggested value
+for the level at which the eta levels become isobaric is the default value in the Registry file
+(as this valus is not intuitively easy to remember). The second switch, to turn on the HVC, is by default
+set to the TF value (hybrid_opt=0) in the Registry. To activate the hybrid coordinate capability,
+this value needs to be modified in the namelist (hybrid_opt=2).
+
+Assuming that the WRF and real codes have been built with the HVC compile-time option, then
+
+1. To turn ON the HVC
+&dynamics
+ hybrid_opt         = 2,
+
+2. To turn OFF the HVC
+&dynamics
+ hybrid_opt         = 0,
diff --git a/wrfv2_fire/run/README.rasm_diag b/wrfv2_fire/run/README.rasm_diag
new file mode 100644
index 00000000..89a2c1cc
--- /dev/null
+++ b/wrfv2_fire/run/README.rasm_diag
@@ -0,0 +1,51 @@
+The RASM Climate Diagnostics provides time-step averaging output for surface 
+meteorology (PSFC, TSK, PMSL, T2, TH2, Q2, U10, V10), fluxes at the surface 
+(HFX, LH, SWDNB, GLW, LWUPB, SWUPB), and fluxes at the TOA (SWUPT, SWDNT, LWUPT, 
+LWDNT). The averaging can be set by the user with some interval of seconds, 
+minutes, hours, days, or month. The average output file is set to use auxhist5. 
+
+Additionally, diurnal averaging is provided which creates monthly averages for 
+three hour periods of time during the day (00-03, 03-06, etc.). The diurnal 
+average output is set to use auxhist6. This diurnal averaging output is only 
+created in monthly files (the simulation has to be longer than a month to see
+the output).
+
+The intended application for the RASM Diagnostics is for regional climate
+simulations and the elimination of the need to produce the high-volume and I/O
+intenstive instantaneous WRF history files for long duration simulations.
+
+namelist.input settings for RASM Climate Diagnostics in &time_control
+-settings for RASM diagnostic mean output:
+ -flag to turn on the mean diagnostic output (1 = on, 0 = off)
+   mean_diag                           = 1,
+ -set the time interval for the frequency of mean calculations
+   mean_diag_interval                  = 1440, (minutes)
+   mean_diag_interval_s                = 3600, (seconds)
+   mean_diag_interval_m                = 1440, (minutes)
+   mean_diag_interval_h                = 6, (hours)
+   mean_diag_interval_d                = 1, (days)
+   mean_diag_interval_mo               = 1, (month)
+ -use the standard WRF namelist settings for auxhist5:
+   auxhist5_outname                    = "wrf_mean_d_.nc",
+   io_form_auxhist5                    = 2,
+   frames_per_auxhist5                 = 1,
+Notes:
+ -a time interval must be set
+ -only one of the time intervals can be set (cominbations do not work)
+
+-settings for RASM diagnostic dirunal output:
+ -flag to turn on the diurnal diagnostic output (1 = on, 0 = off)
+   diurnal_diag                        = 1,
+ -use the standard WRF namelist settings for auxhist5 and auxhist6:
+   auxhist6_outname                    = "wrf_diurnal_d_.nc",
+   io_form_auxhist6                    = 2,
+   frames_per_auxhist6                 = 1,
+Note: The dirunal output is hard coded for three-hourly intervals
+(8 values in a day) and output in monthly files.
+
+Acknoledgement:
+The RASM Climate Diagnostics for WRF was developed and implemented as a part
+of the Regional Arctic System Model (RASM) project funded by the United States 
+Department of Energy - Regional and Global Climate Modeling Program.
+
+04 April 2017
diff --git a/wrfv2_fire/run/SOILPARM.TBL b/wrfv2_fire/run/SOILPARM.TBL
index 4d18a3cc..518ba6f8 100644
--- a/wrfv2_fire/run/SOILPARM.TBL
+++ b/wrfv2_fire/run/SOILPARM.TBL
@@ -1,25 +1,25 @@
 Soil Parameters
 STAS
-19,1   'BB      DRYSMC      F11     MAXSMC   REFSMC   SATPSI  SATDK       SATDW     WLTSMC  QTZ    '
-1,     2.79,    0.010,    -0.472,   0.339,   0.236,   0.069,  4.66E-5,  0.608E-6,   0.010,  0.92, 'SAND'
-2,     4.26,    0.028,    -1.044,   0.421,   0.383,   0.036,  1.41E-5,  0.514E-5,   0.028,  0.82, 'LOAMY SAND'
-3,     4.74,    0.047,    -0.569,   0.434,   0.383,   0.141,  5.23E-6,  0.805E-5,   0.047,  0.60, 'SANDY LOAM'
-4,     5.33,    0.084,     0.162,   0.476,   0.360,   0.759,  2.81E-6,  0.239E-4,   0.084,  0.25, 'SILT LOAM'
-5,     5.33,    0.084,     0.162,   0.476,   0.383,   0.759,  2.81E-6,  0.239E-4,   0.084,  0.10, 'SILT'
-6,     5.25,    0.066,    -0.327,   0.439,   0.329,   0.355,  3.38E-6,  0.143E-4,   0.066,  0.40, 'LOAM'
-7,     6.77,    0.067,    -1.491,   0.404,   0.314,   0.135,  4.45E-6,  0.990E-5,   0.067,  0.60, 'SANDY CLAY LOAM'
-8,     8.72,    0.120,    -1.118,   0.464,   0.387,   0.617,  2.03E-6,  0.237E-4,   0.120,  0.10, 'SILTY CLAY LOAM'
-9,     8.17,    0.103,    -1.297,   0.465,   0.382,   0.263,  2.45E-6,  0.113E-4,   0.103,  0.35, 'CLAY LOAM'
-10,   10.73,    0.100,    -3.209,   0.406,   0.338,   0.098,  7.22E-6,  0.187E-4,   0.100,  0.52, 'SANDY CLAY'
-11,   10.39,    0.126,    -1.916,   0.468,   0.404,   0.324,  1.34E-6,  0.964E-5,   0.126,  0.10, 'SILTY CLAY'
-12,   11.55,    0.138,    -2.138,   0.468,   0.412,   0.468,  9.74E-7,  0.112E-4,   0.138,  0.25, 'CLAY'
-13,    5.25,    0.066,    -0.327,   0.439,   0.329,   0.355,  3.38E-6,  0.143E-4,   0.066,  0.05, 'ORGANIC MATERIAL'
-14,     0.0,      0.0,       0.0,     1.0,     0.0,     0.0,      0.0,       0.0,     0.0,  0.60, 'WATER'
-15,    2.79,    0.006,    -1.111,    0.20,    0.17,   0.069,  1.41E-4,  0.136E-3,   0.006,  0.07, 'BEDROCK'
-16,    4.26,    0.028,    -1.044,   0.421,   0.283,   0.036,  1.41E-5,  0.514E-5,   0.028,  0.25, 'OTHER(land-ice)'
-17,   11.55,    0.030,   -10.472,   0.468,   0.454,   0.468,  9.74E-7,  0.112E-4,   0.030,  0.60, 'PLAYA'
-18,    2.79,    0.006,    -0.472,   0.200,    0.17,   0.069,  1.41E-4,  0.136E-3,   0.006,  0.52, 'LAVA'
-19,    2.79,     0.01,    -0.472,   0.339,   0.236,   0.069,  4.66E-5,  0.608E-6,    0.01,  0.92, 'WHITE SAND'
+19,1   'BB      DRYSMC      F11     MAXSMC   REFSMC   SATPSI  SATDK      SATDW     WLTSMC  QTZ    '
+1,     2.79,    0.010,    -0.472,   0.339,   0.192,   0.069,  4.66E-5,  2.65E-5,   0.010,  0.92, 'SAND'
+2,     4.26,    0.028,    -1.044,   0.421,   0.283,   0.036,  1.41E-5,  5.14E-6,   0.028,  0.82, 'LOAMY SAND'
+3,     4.74,    0.047,    -0.569,   0.434,   0.312,   0.141,  5.23E-6,  8.05E-6,   0.047,  0.60, 'SANDY LOAM'
+4,     5.33,    0.084,     0.162,   0.476,   0.360,   0.759,  2.81E-6,  2.39E-5,   0.084,  0.25, 'SILT LOAM'
+5,     3.86,    0.061,     0.162,   0.484,   0.347,   0.955,  2.18E-6,  1.66E-5,   0.061,  0.10, 'SILT'
+6,     5.25,    0.066,    -0.327,   0.439,   0.329,   0.355,  3.38E-6,  1.43E-5,   0.066,  0.40, 'LOAM'
+7,     6.77,    0.069,    -1.491,   0.404,   0.315,   0.135,  4.45E-6,  1.01E-5,   0.069,  0.60, 'SANDY CLAY LOAM'
+8,     8.72,    0.120,    -1.118,   0.464,   0.387,   0.617,  2.03E-6,  2.35E-5,   0.120,  0.10, 'SILTY CLAY LOAM'
+9,     8.17,    0.103,    -1.297,   0.465,   0.382,   0.263,  2.45E-6,  1.13E-5,   0.103,  0.35, 'CLAY LOAM'
+10,   10.73,    0.100,    -3.209,   0.406,   0.338,   0.098,  7.22E-6,  1.87E-5,   0.100,  0.52, 'SANDY CLAY'
+11,   10.39,    0.126,    -1.916,   0.468,   0.404,   0.324,  1.34E-6,  9.64E-6,   0.126,  0.10, 'SILTY CLAY'
+12,   11.55,    0.138,    -2.138,   0.468,   0.412,   0.468,  9.74E-7,  1.12E-5,   0.138,  0.25, 'CLAY'
+13,    5.25,    0.066,    -0.327,   0.439,   0.329,   0.355,  3.38E-6,  1.43E-5,   0.066,  0.05, 'ORGANIC MATERIAL'
+14,     0.0,      0.0,       0.0,     1.0,     0.0,     0.0,      0.0,      0.0,     0.0,  0.60, 'WATER'
+15,    2.79,    0.006,    -1.111,    0.20,    0.17,   0.069,  1.41E-4,  1.36E-4,   0.006,  0.07, 'BEDROCK'
+16,    4.26,    0.028,    -1.044,   0.421,   0.283,   0.036,  1.41E-5,  5.14E-6,   0.028,  0.25, 'OTHER(land-ice)'
+17,   11.55,    0.030,   -10.472,   0.468,   0.454,   0.468,  9.74E-7,  1.12E-5,   0.030,  0.60, 'PLAYA'
+18,    2.79,    0.006,    -0.472,   0.200,    0.17,   0.069,  1.41E-4,  1.36E-4,   0.006,  0.52, 'LAVA'
+19,    2.79,     0.01,    -0.472,   0.339,   0.192,   0.069,  4.66E-5,  2.65E-5,    0.01,  0.92, 'WHITE SAND'
 Soil Parameters
 STAS-RUC
 19,1   'BB      DRYSMC       HC     MAXSMC   REFSMC   SATPSI  SATDK       SATDW     WLTSMC  QTZ    '
diff --git a/wrfv2_fire/run/create_p3_lookupTable_1.f90 b/wrfv2_fire/run/create_p3_lookupTable_1.f90
new file mode 100644
index 00000000..f14bc2fb
--- /dev/null
+++ b/wrfv2_fire/run/create_p3_lookupTable_1.f90
@@ -0,0 +1,1803 @@
+PROGRAM make_p3_lookuptable1
+
+!______________________________________________________________________________________
+!
+! This program creates the lookup tables for ice microphysical processes used by
+! the P3 microphysics scheme.
+!
+!  Note:  compile with double-precision (pgf90 -r8 create_p3_lookupTable_1.f90)
+!
+! P3 package version: v2.4.7
+! Last modified     : 2017-06-28
+!______________________________________________________________________________________
+
+ implicit none
+
+!--
+ integer            :: i_rhor          ! index for rho_rime loop                [1 .. n_rhor]
+ integer            :: i_Fr            ! index for rime-mass-fraction loop      [1 .. n_Fr]
+ integer            :: i_Qnorm         ! index for normalized qitot loop        [1 .. n_Qnorm]
+ integer            :: i_Drscale       ! index for scaled mean rain size loop   [1 .. n_Drscale]
+
+ integer, parameter :: n_rhor    =  5  ! number of indices for i_rhor  loop           (1st; outer)
+ integer, parameter :: n_Fr      =  4  ! number of indices for i_Fr    loop           (2nd)
+ integer, parameter :: n_Qnorm   = 50  ! number of indices for i_Qnorm loop           (3rd)
+ integer, parameter :: n_Drscale = 30  ! number of indices for scaled mean rain size  (4th; inner)
+!==
+
+ integer :: i,ii,iii,jj,kk,kkk,dumii
+
+ real :: N,q,qdum,dum1,dum2,cs1,ds1,lam,n0,lamf,qerror,del0,c0,c1,c2,dd,sum1,sum2,       &
+         sum3,sum4,xx,a0,b0,a1,b1,dum,bas1,aas1,aas2,bas2,gammq,gamma,d1,d2,delu,lamold, &
+         cap,lamr,dia,amg,dv,n0dum,sum5,sum6,sum7,sum8,dg,cg,bag,aag,dcritg,dcrits,      &
+         dcritr,Fr,csr,dsr,duml,dum3,dum4,rhodep,cgpold,m1,m2,m3,dt,mu_r,initlamr,lamv,  &
+         rdumii,lammin,lammax,pi,g,p,t,rho,mu,mu_i,ds,cs,bas,aas,dcrit
+
+!-- outputs from lookup table (i.e. "f1prxx" read by access_lookup_table in s/r p3_main)
+ real, dimension(n_Qnorm,n_Fr) :: uns,ums,refl,dmm,rhomm,nagg,nrwat,qsave,nsave,vdep,    &
+        eff,lsave,a_100,n_100,vdep1,nsmall,nlarge,nrwats
+
+ real, dimension(n_Qnorm,n_Drscale,n_Fr) :: qrrain,nrrain,nsrain,qsrain,ngrain
+!==
+
+ real, dimension(n_Drscale) :: lamrs
+ real, dimension(10000)     :: fall1
+ real, dimension(1000)      :: fall2,fallr,num,numi
+ real, dimension(n_rhor)    :: cgp,crp
+ real, dimension(150)       :: mu_r_table
+
+ real, parameter            :: Dm_max = 2000.e-6   ! max. mean ice size for lambda limiter
+ real, parameter            :: Dm_min =    2.e-6   ! min. mean ice size for lambda limiter
+
+ real, parameter            :: thrd = 1./3.
+ real, parameter            :: sxth = 1./6.
+
+! end of variable declaration
+!-------------------------------------------------------------------------------
+
+! set constants and parameters
+
+! assume 600 hPa, 253 K for p and T for fallspeed calcs (for reference air density)
+ pi  = 3.14159        !=acos(-1.)
+!pi  = 3.14159265359  !=acos(-1.)        <-- to be replaced with this one (for double precision)
+ g   = 9.861                           ! gravity
+ p   = 60000.                          ! air pressure (pa)
+ t   = 253.15                          ! temp (K)
+ rho = p/(287.15*t)                    ! air density (kg m-3)
+ mu  = 1.496E-6*t**1.5/(t+120.)/rho    ! viscosity of air
+ dv  = 8.794E-5*t**1.81/p              ! diffusivity of water vapor in air
+ dt  = 10.                             ! time step for collection (s)
+
+! parameters for surface roughness of ice particle used for fallspeed
+! see mitchell and heymsfield 2005
+ del0 = 5.83
+ c0   = 0.6
+ c1   = 4./(del0**2*c0**0.5)
+ c2   = del0**2/4.
+
+!--- specified mass-dimension relationship (cgs units) for unrimed crystals:
+
+! ms = cs*D^ds
+!
+! for graupel:
+! mg = cg*D^dg     no longer used, since bulk volume is predicted
+!===
+
+!---- Choice of m-D parameters for large unrimed ice:
+
+! Heymsfield et al. 2006
+!      ds=1.75
+!      cs=0.0040157+6.06e-5*(-20.)
+
+! sector-like branches (P1b)
+!      ds=2.02
+!      cs=0.00142
+
+! bullet-rosette
+!     ds=2.45
+!      cs=0.00739
+
+! side planes
+!      ds=2.3
+!      cs=0.00419
+
+! radiating assemblages of plates (mitchell et al. 1990)
+!      ds=2.1
+!      cs=0.00239
+
+! aggreagtes of side planes, bullets, etc. (Mitchell 1996)
+!      ds=2.1
+!      cs=0.0028
+
+!-- ** note: if using one of the above (.i.e. not brown and francis, which is already in mks units),
+!           then uncomment line below to convert from cgs units to mks
+!      cs=cs*100.**ds/1000.
+!==
+
+! Brown and Francis (1995)
+ ds = 1.9
+! cs = 0.01855 ! original (pre v2.3), based on assumption of Dmax
+ cs = 0.0121 ! scaled value based on assumtion of Dmean from Hogan et al. 2012, JAMC
+
+!====
+
+! specify m-D parameter for fully rimed ice
+!  note:  cg is not constant, due to variable density
+ dg = 3.
+
+
+!--- projected area-diam relationship (mks units) for unrimed crystals:
+!     note: projected area = aas*D^bas
+
+! sector-like branches (P1b)
+!      bas = 1.97
+!      aas = 0.55*100.**bas/(100.**2)
+
+! bullet-rosettes
+!      bas = 1.57
+!      aas = 0.0869*100.**bas/(100.**2)
+
+! aggreagtes of side planes, bullets, etc.
+ bas = 1.88
+ aas = 0.2285*100.**bas/(100.**2)
+
+!===
+
+!--- projected area-diam relationship (mks units) for fully rimed ice:
+!    note: projected area = aag*D^bag
+
+! assumed non-spherical
+! bag = 2.0
+! aag = 0.625*100.**bag/(100.**2)
+
+! assumed spherical:
+ bag = 2.
+ aag = pi*0.25
+!===
+
+ dcrit = (pi/(6.*cs)*900.)**(1./(ds-3.))
+
+! check to make sure projected area at dcrit not greater than than of solid sphere
+! stop and give warning message if that is the case
+
+ if (pi/4.*dcrit**2.lt.aas*dcrit**bas) then
+    print*,'STOP, area > area of solid ice sphere, unrimed'
+    stop
+ endif
+
+ open(unit=1,file='./p3_lookup_table_1-v2.4.7.dat',status='unknown')
+
+!.........................................................
+
+! generate lookup table for mu (for rain)
+!
+! space of a scaled q/N -- initlamr
+
+ do i = 1,150              ! loop over lookup table values
+
+    initlamr = (real(i)*2.)*1.e-6 + 250.e-6
+    initlamr = 1./initlamr
+
+! iterate to get mu_r
+! mu_r-lambda relationship is from Cao et al. (2008), eq. (7)
+
+! start with first guess, mu_r = 0
+
+    mu_r = 0.
+
+    do ii = 1,50
+       lamr = initlamr*(gamma(mu_r+4.)/(6.*gamma(mu_r+1.)))**thrd
+
+! new estimate for mu_r based on lambda
+! set max lambda in formula for mu to 20 mm-1, so Cao et al.
+! formula is not extrapolated beyond Cao et al. data range
+       dum = min(20.,lamr*1.e-3)
+       mu_r = max(0.,-0.0201*dum**2+0.902*dum-1.718)
+
+! if lambda is converged within 0.1%, then exit loop
+       if (ii.ge.2) then
+          if (abs((lamold-lamr)/lamr).lt.0.001) goto 111
+       endif
+
+       lamold = lamr
+
+    enddo !ii-loop
+
+111 continue
+
+! assign lookup table values
+    mu_r_table(i) = mu_r
+
+ enddo !i-loop
+
+!.........................................................
+! main loop over rime density
+
+! alpha parameter of m-D for rimed ice
+ crp(1) =  50.*pi*sxth
+ crp(2) = 250.*pi*sxth
+ crp(3) = 450.*pi*sxth
+ crp(4) = 650.*pi*sxth
+ crp(5) = 900.*pi*sxth
+
+ do i_rhor = 1,n_rhor
+
+    print*,(pi/(4.*aas))**(1./(bas-2.))
+    print*,(aas/aag)**(1./(bag-bas))
+
+
+!------------------------------------------------------------------------
+
+! find threshold with rimed mass added
+
+! loop over rimed mass fraction (4 points)
+! Fr below are values of rime mass fraction for the lookup table
+! specific values in model are interpolated between these four points
+
+
+!- note:  add this code eventually (outside of i_Fr loop)
+!     Fr(1) = 0.
+!     Fr(2) = 0.333
+!     Fr(3) = 0.667
+!     Fr(4) = 1.
+!=
+
+    do i_Fr = 1,n_Fr   ! loop for rime mass fraction, Fr
+
+!-- these lines to be replaced by Fr(i_Fr) initialization outside of loops
+       if (i_Fr.eq.1) Fr = 0.
+       if (i_Fr.eq.2) Fr = 0.333
+       if (i_Fr.eq.3) Fr = 0.667
+       if (i_Fr.eq.4) Fr = 1.
+!==
+
+! calculate mass-dimension relationship for partially-rimed crystals
+! msr = csr*D^dsr
+! formula from P3 Part 1 (JAS)
+
+! dcritr is critical size separating fully-rimed from partially-rime ice
+
+! first guess, set cgp=crp
+       cgp(i_rhor) = crp(i_rhor)
+
+! case of no riming (Fr = 0), then we need to set dcrits and dcritr to arbitrary large values
+
+       if (i_Fr.eq.1) then
+          dcrits = 1.e+6
+          dcritr = dcrits
+          csr    = cs
+          dsr    = ds
+! case of partial riming (Fr between 0 and 1)
+       elseif (i_Fr.eq.2.or.i_Fr.eq.3) then
+          do
+             dcrits = (cs/cgp(i_rhor))**(1./(dg-ds))
+             dcritr = ((1.+Fr/(1.-Fr))*cs/cgp(i_rhor))**(1./(dg-ds))
+             csr    = cs*(1.+Fr/(1.-Fr))
+             dsr    = ds
+
+! get mean density of vapor deposition/aggregation grown ice
+             rhodep = 1./(dcritr-dcrits)*6.*cs/(pi*(ds-2.))*(dcritr**(ds-2.)-dcrits**(ds-2.))
+
+! get density of fully-rimed ice as rime mass fraction weighted rime density plus
+! density of vapor deposition/aggregation grown ice
+             cgpold      = cgp(i_rhor)
+             cgp(i_rhor) = crp(i_rhor)*Fr+rhodep*(1.-Fr)*pi*sxth
+
+             if (abs((cgp(i_rhor)-cgpold)/cgp(i_rhor)).lt.0.01) goto 115
+          enddo
+
+ 115  continue
+
+! case of complete riming (Fr=1.0)
+       else
+
+! set threshold size between partially-rimed and fully-rimed ice as arbitrary large
+          dcrits = (cs/cgp(i_rhor))**(1./(dg-ds))
+          dcritr = 1.e+6       ! here is the "arbitrary large"
+          csr    = cgp(i_rhor)
+          dsr    = dg
+
+       endif
+
+    print*,'dcrit,dcrits',i_rhor,dcrit,dcrits
+
+!---------------------------------------------------------------------------------------
+! set up particle fallspeed arrays
+! fallspeed is a function of mass dimension and projected area dimension relationships
+! following mitchell and heymsfield (2005), jas
+
+! set up array of particle fallspeed to make computationally efficient
+
+! for high-resolution (in diameter space), ice fallspeed is stored in 'fall1' array (m/s)
+! for lower-resolution (in diameter space), ice fallspeed is stored in 'fall2' array (m/s)
+! rain fallspeed is stored in 'fallr' (m/s)
+
+       dd = 2.e-6  ! m
+
+! loop over particle size
+
+       do jj = 1,10000
+
+! particle size (m)
+!         d1 = real(jj)*dd - 0.5*dd
+          d1 = real(jj)*2.*1.e-6 - 1.e-6   ! kept like this to preserve bit-matching
+
+!----- get mass-size and projected area-size relationships for given size (d1)
+!          call get_mass_size
+
+          if (d1.le.dcrit) then
+             cs1  = pi*sxth*900.
+             ds1  = 3.
+             bas1 = 2.
+             aas1 = pi/4.
+          else if (d1.gt.dcrit.and.d1.le.dcrits) then
+             cs1  = cs
+             ds1  = ds
+             bas1 = bas
+             aas1 = aas
+          else if (d1.gt.dcrits.and.d1.le.dcritr) then
+             cs1  = cgp(i_rhor)
+             ds1  = dg
+             bas1 = bag
+             aas1 = aag
+          else if (d1.gt.dcritr) then
+             cs1  = csr
+             ds1  = dsr
+             if (i_Fr.eq.1) then
+                aas1 = aas
+                bas1 = bas
+             else
+
+! for projected area, keep bas1 constant, but modify aas1 according to rimed fraction
+                bas1 = bas
+                dum1 = aas*d1**bas
+                dum2 = aag*d1**bag
+                m1   = cs1*d1**ds1
+                m2   = cs*d1**ds
+                m3   = cgp(i_rhor)*d1**dg
+! linearly interpolate based on particle mass
+                dum3 = dum1+(m1-m2)*(dum2-dum1)/(m3-m2)
+!               dum3 = (1.-Fr)*dum1+Fr*dum2
+                aas1 = dum3/(d1**bas)
+
+             endif
+          endif
+!=====
+
+!-----------------------------------------------------------
+! neglect turbulent correction for aggregates for now
+! correction for turbulence
+!            if (d1.lt.500.e-6) then
+          a0 = 0.
+          b0 = 0.
+!            else
+!               a0=1.7e-3
+!               b0=0.8
+!            end if
+
+! fall speed for particle
+! best number
+          xx = 2.*cs1*g*rho*d1**(ds1+2.-bas1)/(aas1*(mu*rho)**2)
+
+! drag terms
+          b1 = c1*xx**0.5/(2.*((1.+c1*xx**0.5)**0.5-1.)*(1.+c1*xx**0.5)**0.5)-a0*b0*xx** &
+             b0/(c2*((1.+c1*xx**0.5)**0.5-1.)**2)
+
+          a1 = (c2*((1.+c1*xx**0.5)**0.5-1.)**2-a0*xx**b0)/xx**b1
+
+! velocity in terms of drag terms
+          fall1(jj) = a1*mu**(1.-2.*b1)*(2.*cs1*g/(rho*aas1))**b1*d1**(b1*(ds1-bas1+2.)-1.)
+
+       enddo !jj-loop
+
+!.........................................................
+! fallspeed array for ice-ice and ice-rain collision calculations
+
+       do jj = 1,1000
+
+! particle size
+          d1 = real(jj)*20.*1.e-6 - 10.e-6
+
+          if (d1.le.dcrit) then
+             cs1  = pi*sxth*900.
+             ds1  = 3.
+             bas1 = 2.
+             aas1 = pi/4.
+          else if (d1.gt.dcrit.and.d1.le.dcrits) then
+             cs1  = cs
+             ds1  = ds
+             bas1 = bas
+             aas1 = aas
+          else if (d1.gt.dcrits.and.d1.le.dcritr) then
+             cs1  = cgp(i_rhor)
+             ds1  = dg
+             bas1 = bag
+             aas1 = aag
+          else if (d1.gt.dcritr) then
+             cs1  = csr
+             ds1  = dsr
+             if (i_Fr.eq.1) then
+                aas1 = aas
+                bas1 = bas
+             else
+! for area,
+! keep bas1 constant, but modify aas1 according
+! to rimed fraction
+                bas1 = bas
+                dum1 = aas*d1**bas
+                dum2 = aag*d1**bag
+!               dum3 = (1.-Fr)*dum1+Fr*dum2
+                m1   = cs1*d1**ds1
+                m2   = cs*d1**ds
+                m3   = cgp(i_rhor)*d1**dg
+! linearly interpolate based on particle mass
+                dum3 = dum1+(m1-m2)*(dum2-dum1)/(m3-m2)
+                aas1 = dum3/(d1**bas)
+             endif
+          endif
+
+! correction for turbulence
+!            if (d1.lt.500.e-6) then
+          a0 = 0.
+          b0 = 0.
+!            else
+!               a0=1.7e-3
+!               b0=0.8
+!            end if
+
+! fall speed for ice
+! Best number
+          xx = 2.*cs1*g*rho*d1**(ds1+2.-bas1)/(aas1*(mu*rho)**2)
+
+! drag terms
+          b1 = c1*xx**0.5/(2.*((1.+c1*xx**0.5)**0.5-1.)*(1.+c1*xx**0.5)**0.5)-a0*b0*xx** &
+               b0/(c2*((1.+c1*xx**0.5)**0.5-1.)**2)
+
+          a1 = (c2*((1.+c1*xx**0.5)**0.5-1.)**2-a0*xx**b0)/xx**b1
+
+! velocity in terms of drag terms
+          fall2(jj) = a1*mu**(1.-2.*b1)*(2.*cs1*g/(rho*aas1))**b1*d1**(b1*(ds1-bas1+2.)-1.)
+
+!---------------------------------------------------------------
+! fall speed for rain particle
+
+!          dia = d1*1.e+6
+! HM fix, bug noted by Melissa
+          dia = d1  ! diameter m
+          amg = pi*sxth*997.*dia**3 ! mass kg
+! HM fix, bug noted by Melissa
+          amg = amg*1000. ! convert kg to g
+
+          if(dia.le.134.43e-6) then
+             dum2 = 4.5795e5*amg**(2.*thrd)
+             goto 101
+          endif
+
+          if(dia.lt.1511.64e-6) then
+             dum2 = 4.962e3*amg**thrd
+            goto 101
+          endif
+
+          if(dia.lt.3477.84e-6) then
+             dum2 = 1.732e3*amg**sxth
+             goto 101
+          endif
+
+          dum2 = 917.
+
+101 continue
+
+          fallr(jj) = dum2*1.e-2   ! convert (cm s-1) to (m s-1)
+
+       enddo !jj-loop
+
+!---------------------------------------------------------------------------------
+! loop around normalized Q (Qnorm)
+
+       do i_Qnorm = 1,n_Qnorm
+
+! lookup table values of normalized Qnorm
+! (range of mean mass diameter from ~ 1 micron to 1 cm)
+
+          q = 261.7**((i_Qnorm+10)*0.1)*1.e-18
+
+! uncomment below to test and print proposed values of qovn
+!	print*,i_Qnorm,(6./(pi*500.)*q)**0.3333
+!	end do
+!	stop
+
+! test values
+!            N=5.e3
+!            q=0.01e-3
+
+             print*,'&&&&&&&&&&&i_rhor',i_rhor
+             print*,'***************',i_Qnorm
+             print*,'Fr',Fr
+             print*,'q,N',q,N
+
+! initialize qerror to arbitrarily large value
+             qerror = 1.e+20
+
+!.....................................................................................
+! find parameters for gamma distribution
+
+! size distribution for ice is assumed to be
+! N(D) = n0 * D^mu_i * exp(-lam*D)
+
+! for the given q and N, we need to find n0, mu_i, and lam
+
+! approach for finding lambda:
+! cycle through a range of lambda, find closest lambda to produce correct q
+
+! start with lam, range of lam from 100 to 1 x 10^7 is large enough to
+! cover full range over mean size from approximately 1 micron to 1 cm
+
+             do ii = 1,9000
+
+                lam = 1.0013**ii*100.
+
+! get 'mu' parameter (Heymsfield 2003)
+! division by 100 is to convert m-1 to cm-1
+                mu_i = 0.076*(lam/100.)**0.8-2.
+! make sure mu_i >= 0, otherwise size dist is infinity at D = 0
+                mu_i = max(mu_i,0.)
+! set upper limit at 6
+                mu_i = min(mu_i,6.)
+
+!-- for lambda limiter:
+
+! set min lam corresponding to 2000 micron for mean size
+!               dum = Dm_max+Fr*(3000.e-6)
+                dum = Dm_max
+                lam = max(lam,(mu_i+1.)/dum)
+! set max lam corresponding to 2 micron mean size
+                lam = min(lam,(mu_i+1.)/Dm_min)
+! this range corresponds to range of lam of 500 to 5000000
+!==
+
+! get normalized n0
+                n0 = lam**(mu_i+1.)/(gamma(mu_i+1.))
+
+! calculate integral for each of the 4 parts of the size distribution
+! check difference with respect to Qnorm
+
+! dum1 is integral from 0 to dcrit       (solid ice)
+! dum2 is integral from dcrit to dcrits  (unrimed large ice)
+! dum3 is integral from dcrits to dcritr (fully rimed ice)
+! dum4 is integral from dcritr to inf    (partially rimed)
+
+! set up m-D relationship for solid ice with D < Dcrit
+                cs1  = pi*sxth*900.
+                ds1  = 3.
+                dum1 = lam**(-ds1-mu_i-1.)*gamma(mu_i+ds1+1.)*(1.-gammq(mu_i+ds1+1.,dcrit*lam))
+
+                dum2 = lam**(-ds-mu_i-1.)*gamma(mu_i+ds+1.)*(gammq(mu_i+ds+1.,dcrit*lam))
+                dum  = lam**(-ds-mu_i-1.)*gamma(mu_i+ds+1.)*(gammq(mu_i+ds+1.,dcrits*lam))
+                dum2 = dum2-dum
+                dum2 = max(dum2,0.)
+
+                dum3 = lam**(-dg-mu_i-1.)*gamma(mu_i+dg+1.)*(gammq(mu_i+dg+1.,dcrits*lam))
+                dum  = lam**(-dg-mu_i-1.)*gamma(mu_i+dg+1.)*(gammq(mu_i+dg+1.,dcritr*lam))
+                dum3 = dum3-dum
+                dum3 = max(dum3,0.)
+
+                dum4 = lam**(-dsr-mu_i-1.)*gamma(mu_i+dsr+1.)*(gammq(mu_i+dsr+1.,dcritr*lam))
+
+! sum of the integrals from the 4 regions of the size distribution
+                qdum = n0*(cs1*dum1+cs*dum2+cgp(i_rhor)*dum3+csr*dum4)
+
+! numerical integration for test to make sure incomplete gamma function is working
+!               sum1 = 0.
+!               dd = 1.e-6
+!               do iii=1,50000
+!                  dum=real(iii)*dd
+!                  if (dum.lt.dcrit) then
+!                  sum1 = sum1+n0*dum**mu_i*cs1*dum**ds1*
+!     1                      exp(-lam*dum)*dd
+!                  else
+!                  sum1 = sum1+n0*dum**mu_i*cs*dum**ds*
+!     1                      exp(-lam*dum)*dd
+!                  end if
+!               end do
+!               print*,'sum1=',sum1
+!               stop
+
+                if (ii.eq.1) then
+                   qerror = abs(q-qdum)
+                   lamf   = lam
+                endif
+
+! find lam with smallest difference between Qnorm and estimate of Qnorm, assign to lamf
+                if (abs(q-qdum).lt.qerror) then
+                   lamf   = lam
+                   qerror = abs(q-qdum)
+                endif
+
+
+             enddo !ii-loop
+
+! check and print relative error in q to make sure it is not too large
+! note: large error is possible if size bounds are exceeded!!!!!!!!!!
+
+             print*,'qerror (%)',qerror/q*100.
+
+! find n0 based on final lam value
+! set final lamf to 'lam' variable
+! this is the value of lam with the smallest qerror
+             lam = lamf
+! recalculate mu_i based on final lam
+! get 'mu' parameter (Heymsfield 2003)
+! division by 100 is to convert m-1 to cm-1
+             mu_i = 0.076*(lam/100.)**0.8-2.
+! make sure mu_i >= 0, otherwise size dist is infinity at D = 0
+             mu_i = max(mu_i,0.)
+! set upper limit at 6
+             mu_i = min(mu_i,6.)
+
+!            n0 = N*lam**(mu_i+1.)/(gamma(mu_i+1.))
+
+! find n0 from lam and Qnorm
+! this is done instead of finding n0 from lam and N, since N
+! may need to be adjusted to constrain mean size within reasonable bounds
+
+             dum1 = lam**(-ds1-mu_i-1.)*gamma(mu_i+ds1+1.)*(1.-gammq(mu_i+ds1+1.,dcrit*lam))
+
+             dum2 = lam**(-ds-mu_i-1.)*gamma(mu_i+ds+1.)*(gammq(mu_i+ds+1.,dcrit*lam))
+             dum  = lam**(-ds-mu_i-1.)*gamma(mu_i+ds+1.)*(gammq(mu_i+ds+1.,dcrits*lam))
+             dum2 = dum2-dum
+
+             dum3 = lam**(-dg-mu_i-1.)*gamma(mu_i+dg+1.)*(gammq(mu_i+dg+1.,dcrits*lam))
+             dum  = lam**(-dg-mu_i-1.)*gamma(mu_i+dg+1.)*(gammq(mu_i+dg+1.,dcritr*lam))
+             dum3 = dum3-dum
+
+             dum4 = lam**(-dsr-mu_i-1.)*gamma(mu_i+dsr+1.)*(gammq(mu_i+dsr+1.,dcritr*lam))
+
+             n0   = q/(cs1*dum1+cs*dum2+cgp(i_rhor)*dum3+csr*dum4)
+             print*,'lam,N0:',lam,n0
+             print*,'mu_i:',mu_i
+
+! test final lam, N0 values
+!            sum1 = 0.
+!            dd = 1.e-6
+!               do iii=1,50000
+!                  dum=real(iii)*dd
+!                  if (dum.lt.dcrit) then
+!                     sum1 = sum1+n0*dum**mu_i*cs1*dum**ds1*exp(-lam*dum)*dd
+!                  elseif (dum.ge.dcrit.and.dum.lt.dcrits) then
+!                     sum1 = sum1+n0*dum**mu_i*cs*dum**ds*exp(-lam*dum)*dd
+!                  elseif (dum.ge.dcrits.and.dum.lt.dcritr) then
+!                     sum1 = sum1+n0*dum**mu_i*cg*dum**dg*exp(-lam*dum)*dd
+!                  elseif (dum.ge.dcritr) then
+!                     sum1 = sum1+n0*dum**mu_i*csr*dum**dsr*exp(-lam*dum)*dd
+!                  endif
+!               enddo
+!               print*,'sum1=',sum1
+!               stop
+
+
+! At this point, we have solved for all of the size distribution parameters
+
+!--------------------------------------------------------------------
+! find max/min N to constrain mean size (i.e. lambda limiter), this is stored
+! and passed to lookup table, so that N can be adjusted during
+! the simulation to constrain mean size
+
+! limit min size to 2 micron (diameter)
+
+             duml = (mu_i+1.)/Dm_min
+             dum1 = duml**(-ds1-mu_i-1.)*gamma(mu_i+ds1+1.)*(1.-gammq(mu_i+ds1+1.,dcrit*duml))
+             dum2 = duml**(-ds-mu_i-1.)*gamma(mu_i+ds+1.)*(gammq(mu_i+ds+1.,dcrit*duml))
+             dum  = duml**(-ds-mu_i-1.)*gamma(mu_i+ds+1.)*(gammq(mu_i+ds+1.,dcrits*duml))
+             dum2 = dum2-dum
+             dum3 = duml**(-dg-mu_i-1.)*gamma(mu_i+dg+1.)*(gammq(mu_i+dg+1.,dcrits*duml))
+             dum  = duml**(-dg-mu_i-1.)*gamma(mu_i+dg+1.)*(gammq(mu_i+dg+1.,dcritr*duml))
+             dum3 = dum3-dum
+             dum4 = duml**(-dsr-mu_i-1.)*gamma(mu_i+dsr+1.)*(gammq(mu_i+dsr+1.,dcritr*duml))
+
+             n0dum = q/(cs1*dum1+cs*dum2+cgp(i_rhor)*dum3+csr*dum4)
+
+! nlarge is used by P3_MAIN to apply the lambda limiter (upper limit)
+             nlarge(i_Qnorm,i_Fr) = n0dum/(duml**(mu_i+1.)/(gamma(mu_i+1.)))
+
+! limit max size (number-weighted) to 2 mm
+!            dum  = Dm_max+Fr*(3000.e-6)
+             dum  = Dm_max
+             duml = (mu_i+1.)/(dum)
+             dum1 = duml**(-ds1-mu_i-1.)*gamma(mu_i+ds1+1.)*(1.-gammq(mu_i+ds1+1.,dcrit*duml))
+             dum2 = duml**(-ds-mu_i-1.)*gamma(mu_i+ds+1.)*(gammq(mu_i+ds+1.,dcrit*duml))
+             dum  = duml**(-ds-mu_i-1.)*gamma(mu_i+ds+1.)*(gammq(mu_i+ds+1.,dcrits*duml))
+             dum2 = dum2-dum
+             dum3 = duml**(-dg-mu_i-1.)*gamma(mu_i+dg+1.)*(gammq(mu_i+dg+1.,dcrits*duml))
+             dum  = duml**(-dg-mu_i-1.)*gamma(mu_i+dg+1.)*(gammq(mu_i+dg+1.,dcritr*duml))
+             dum3 = dum3-dum
+             dum4 = duml**(-dsr-mu_i-1.)*gamma(mu_i+dsr+1.)*(gammq(mu_i+dsr+1.,dcritr*duml))
+
+             n0dum = q/(cs1*dum1+cs*dum2+cgp(i_rhor)*dum3+csr*dum4)
+
+! nsmall is used by P3_MAIN to apply the lambda limiter (lower limit)
+             nsmall(i_Qnorm,i_Fr) = n0dum/(duml**(mu_i+1.)/(gamma(mu_i+1.)))
+
+             print*,'nmax,nmin',nsmall(i_Qnorm,i_Fr),nlarge(i_Qnorm,i_Fr)
+
+!.....................................................................................
+! begin moment and microphysical process calculations for the lookup table
+
+!.....................................................................................
+! mass- and number-weighted mean fallspeed (m/s)
+! add reflectivity
+!.....................................................................................
+
+! assume conditions for t and p as assumed above (giving rhos), then in microphysics scheme
+! multiply by density correction factor (rhos/rho)^0.54, from Heymsfield et al. 2006
+
+! fallspeed formulation from Mitchell and Heymsfield 2005
+
+             dd = 2.e-6 ! dD for numerical integration, units of m
+
+! initialize for numerical integration
+             sum1 = 0.
+             sum2 = 0.
+             sum3 = 0.
+             sum4 = 0.
+! reflectivity
+             sum5 = 0.
+! mass mean size
+             sum6 = 0.
+! mass-weighted mean density
+             sum7 = 0.
+
+! numerically integrate over size distribution
+             do ii = 1,10000
+
+! dum = particle size
+!               dum = real(ii)*dd - 0.5*dd
+                dum = real(ii)*dd - 1.e-6  ! units of m
+
+          !assign mass-size parameters (depending on size at ii)
+                if (dum.le.dcrit) then
+                   ds1 = 3.
+                   cs1 = pi*sxth*900.
+                else if (dum.gt.dcrit.and.dum.le.dcrits) then
+                   ds1 = ds
+                   cs1 = cs
+                elseif (dum.gt.dcrits.and.dum.le.dcritr) then
+                   ds1 = dg
+                   cs1 = cgp(i_rhor)
+                elseif (dum.gt.dcritr) then
+                   ds1 = dsr
+                   cs1 = csr
+                endif
+
+! numerator of number-weighted velocity - sum1
+                sum1 = sum1+fall1(ii)*dum**mu_i*exp(-lam*dum)*dd
+
+! numerator of mass-weighted velocity - sum2
+                sum2 = sum2+fall1(ii)*cs1*dum**(ds1+mu_i)*exp(-lam*dum)*dd
+
+! total number and mass for weighting above fallspeeds
+! don't need to include n0 and cs since these parameters are
+! in both numerator and denominator
+      !denominator of number-weighted V
+                sum3 = sum3+dum**mu_i*exp(-lam*dum)*dd
+      !denominator of mass-weighted V
+                sum4 = sum4+cs1*dum**(ds1+mu_i)*exp(-lam*dum)*dd
+
+! reflectivity (integral of mass moment squared)
+                sum5 = sum5+n0*(cs1/917.)**2*(6./pi)**2*dum**(2.*ds1+mu_i)*exp(-lam*dum)*dd
+
+! numerator of mass-weighted mean size
+                sum6 = sum6+cs1*dum**(ds1+mu_i+1.)*exp(-lam*dum)*dd
+
+! numerator of mass-weighted density
+! particle density is defined as mass divided by volume of sphere with same D
+                sum7 = sum7+(cs1*dum**ds1)**2/(pi*sxth*dum**3)*dum**mu_i*exp(-lam*dum)*dd
+
+             enddo !ii-loop
+
+! save mean fallspeeds for lookup table
+             uns(i_Qnorm,i_Fr)   = sum1/sum3
+             ums(i_Qnorm,i_Fr)   = sum2/sum4
+             refl(i_Qnorm,i_Fr)  = sum5
+             dmm(i_Qnorm,i_Fr)   = sum6/sum4
+             rhomm(i_Qnorm,i_Fr) = sum7/sum4
+
+!.....................................................................................
+! self-aggregation
+!.....................................................................................
+
+             sum1 = 0.
+             dd   = 20.e-6
+
+             do jj=1000,1,-1
+! set up binned distribution of ice
+!               d1     = real(jj)*dd - 0.5*dd
+                d1     = real(jj)*dd - 10.e-6  !kept like this to preserve bit-matching
+                num(jj) = n0*d1**mu_i*exp(-lam*d1)*dd
+             enddo !jj-loop
+
+! loop over exponential size distribution
+! note: collection of ice within the same bin is neglected
+
+             do jj = 1000,1,-1
+                do kk = 1,jj-1
+
+! particle size
+                   d1 = real(jj)*20.*1.e-6 - 10.e-6
+                   d2 = real(kk)*20.*1.e-6 - 10.e-6
+
+                   if (d1.le.dcrit) then
+                      bas1 = 2.
+                      aas1 = pi*0.25
+                   elseif (d1.gt.dcrit.and.d1.le.dcrits) then
+                      bas1 = bas
+                      aas1 = aas
+                   else if (d1.gt.dcrits.and.d1.le.dcritr) then
+                      bas1 = bag
+                      aas1 = aag
+                   else if (d1.gt.dcritr) then
+                      cs1 = csr
+                      ds1 = dsr
+                      if (i_Fr.eq.1) then
+                         aas1 = aas
+                         bas1 = bas
+                      else
+! for area, keep bas1 constant, but modify aas1 according to rimed fraction
+                         bas1 = bas
+                         dum1 = aas*d1**bas
+                         dum2 = aag*d1**bag
+                         m1   = cs1*d1**ds1
+                         m2   = cs*d1**ds
+                         m3   = cgp(i_rhor)*d1**dg
+! linearly interpolate based on particle mass
+                         dum3 = dum1+(m1-m2)*(dum2-dum1)/(m3-m2)
+                         aas1 = dum3/(d1**bas)
+                      endif
+                   endif
+
+! parameters for particle 2
+                   if (d2.le.dcrit) then
+                      bas2 = 2.
+                      aas2 = pi/4.
+                   elseif (d2.gt.dcrit.and.d2.le.dcrits) then
+                      bas2 = bas
+                      aas2 = aas
+                   elseif (d2.gt.dcrits.and.d2.le.dcritr) then
+                      bas2 = bag
+                      aas2 = aag
+                   elseif (d2.gt.dcritr) then
+                      cs1 = csr
+                      ds1 = dsr
+                      if (i_Fr.eq.1) then
+                         aas1 = aas
+                         bas1 = bas
+                      else
+
+! for area,
+! keep bas1 constant, but modify aas1 according
+! to rimed fraction
+                         bas2 = bas
+                         dum1 = aas*d2**bas
+                         dum2 = aag*d2**bag
+                         m1   = cs1*d1**ds1
+                         m2   = cs*d1**ds
+                         m3   = cgp(i_rhor)*d1**dg
+! linearly interpolate based on particle mass
+                         dum3 = dum1+(m1-m2)*(dum2-dum1)/(m3-m2)
+                         aas2 = dum3/(d2**bas)
+                      endif
+                   endif
+
+! absolute value, differential fallspeed
+                   delu = abs(fall2(jj)-fall2(kk))
+
+! note: in micro code we have to multiply by air density
+! correction factor for fallspeed, and collection efficiency
+
+! sum for integral
+
+! sum1 = # of collision pairs
+! the assumption is that each collision pair reduces crystal
+! number mixing ratio by 1 kg^-1 s^-1 per kg/m^3 of air (this is
+! why we need to multiply by air density, to get units of
+! 1/kg^-1 s^-1)
+
+                   sum1 = sum1+(aas1*d1**bas1+aas2*d2**bas2)*delu*num(jj)*num(kk)
+   !               sum1 = sum1+(aas1*d1**bas1+aas2*d2**bas2)*delu*num(jj)*num(kk)
+
+! remove collected particles from distribution over time period dt, update num
+!  note -- dt is time scale for removal, not model time step
+!                   num(kk) = num(kk)-(aas1*d1**bas1+aas2*d2**bas2)*delu*num(jj)*num(kk)*dt
+!                   num(kk) = max(num(kk),0.)
+
+!            write(6,'(2i5,8e15.5)')jj,kk,sum1,num(jj),num(kk),delu,aas1,d1,aas2,d2
+!            num(kk)=num(kk)-(aas1*d1**bas1+aas2*d2**bas2)*delu*num(jj)*num(kk)*0.1*0.5
+!            num(kk)=max(num(kk),0.)
+!            sum1 = sum1+0.5*(aas1*d1**bas1+aas2*d2**bas2)*delu*n0*n0*(d1+d2)**mu_i*exp(-lam*(d1+d2))*dd**2
+
+                enddo !kk-loop
+             enddo !jj-loop
+
+! save for output
+             nagg(i_Qnorm,i_Fr) = sum1
+             print*,'nagg',nagg(i_Qnorm,i_Fr)
+
+!.....................................................................................
+! collection of cloud droplets
+!.....................................................................................
+! note: in microhpysics code needs to be multiplied by collection efficiency Eci
+! note: also needs to be multiplied by air density correction factor for fallspeed,
+!       air density, and cloud water mixing ratio or number concentration
+
+! initialize sum for integral
+             sum1 = 0.
+             sum2 = 0.
+
+! dd (dD for numerical integration) (m)
+             dd = 2.e-6
+
+! loop over exponential size distribution (from 1 micron to 2 cm)
+             do jj = 1,10000
+
+! particle size or dimension (m) for numerical integration
+                d1 = real(jj)*2.*1.e-6 - 1.e-6
+
+! get mass-dimension and projected area-dimension relationships
+! for different ice types across the size distribution based on critical dimensions
+! separating these ice types (see Fig. 2, morrison and grabowski 2008)
+
+! mass = cs1*D^ds1
+! projected area = bas1*D^bas1
+                if (d1.le.dcrit) then
+                   cs1  = pi*sxth*900.
+                   ds1  = 3.
+                   bas1 = 2.
+                   aas1 = pi*0.25
+                elseif (d1.gt.dcrit.and.d1.le.dcrits) then
+                   cs1  = cs
+                   ds1  = ds
+                   bas1 = bas
+                   aas1 = aas
+                elseif (d1.gt.dcrits.and.d1.le.dcritr) then
+                   cs1  = cgp(i_rhor)
+                   ds1  = dg
+                   bas1 = bag
+                   aas1 = aag
+                elseif (d1.gt.dcritr) then
+                   cs1 = csr
+                   ds1 = dsr
+                   if (i_Fr.eq.1) then
+                      aas1 = aas
+                      bas1 = bas
+                   else
+! for area, ! keep bas1 constant, but modify aas1 according to rimed fraction
+                      bas1 = bas
+                      dum1 = aas*d1**bas
+                      dum2 = aag*d1**bag
+                      m1   = cs1*d1**ds1
+                      m2   = cs*d1**ds
+                      m3   = cgp(i_rhor)*d1**dg
+! linearly interpolate based on particle mass
+                      dum3 = dum1+(m1-m2)*(dum2-dum1)/(m3-m2)
+                      aas1 = dum3/(d1**bas)
+                   endif
+                endif
+
+! sum for integral
+! include assumed ice particle size threshold for riming of 100 micron
+
+! note: sum1 (nrwat) is the scaled collection rate, units of m^3 kg^-1 s^-1
+!       sum2 (nrwats) is mass of snow times scaled collection rate,
+!       units of m^3 s^-1
+
+                if (d1.ge.100.e-6) then
+                   sum1 = sum1+aas1*d1**bas1*fall1(jj)*n0*d1**mu_i*exp(-lam*d1)*dd
+!                  sum2 = sum2+aas1*d1**bas1*fall1(jj)*n0*d1**mu_i*exp(-lam*d1)*dd*cs1*d1**ds1
+                endif
+
+             enddo !jj-loop
+
+! save for output
+! note: read in as 'f1pr4' in P3_MAIN
+             nrwat(i_Qnorm,i_Fr) = sum1
+!            nrwats(i_Qnorm,i_Fr) = sum2
+             print*,'nrwat',nrwat(i_Qnorm,i_Fr)
+
+!.....................................................................................
+! collection of rain
+!.....................................................................................
+! note: in microphysics code, we need to multiply rate by n0r, collection efficiency,
+!       air density, and air density correction factor
+
+! this approach implicitly assumes that the PSDs are constant during the microphysics
+! time step, this could produce errors if the time step is large. In particular,
+! more mass or number could be removed than is available. This will be taken care
+! of by conservation checks in the microphysics code.
+
+! loop around lambda for rain
+
+             do i_Drscale = 1,n_Drscale
+                dum = 1.24**i_Drscale*10.e-6
+
+! assumed lamv for tests
+!               dum = 7.16e-5
+! Note: the lookup table for rain is based on lamv, i.e.,
+! inverse volume mean diameter
+                lamv      = 1./dum
+                lamrs(i_Drscale) = lamv
+
+!------------------------------------------------------------
+! get mu_r from lamr
+                dum = 1./lamv
+
+                if (dum.lt.282.e-6) then
+                   mu_r = 8.282
+                elseif (dum.ge.282.e-6 .and. dum.lt.502.e-6) then
+! interpolate
+                   rdumii = (dum-250.e-6)*1.e6*0.5
+                   rdumii = max(rdumii,1.)
+                   rdumii = min(rdumii,150.)
+                   dumii  = int(rdumii)
+                   dumii  = min(149,dumii)
+                   mu_r    = mu_r_table(dumii)+(mu_r_table(dumii+1)-mu_r_table(dumii))*(rdumii-real(dumii))
+                elseif (dum.ge.502.e-6) then
+                   mu_r    = 0.
+                endif
+! recalculate slope based on mu_r
+!               LAMR = (pi*sxth*rhow*nr(i_Qnorm,k)*gamma(mu_r+4.)/(qr(i_Qnorm,k)*gamma(mu_r+1.)))**thrd
+
+! this is done by re-scaling lamv to account for DSD shape (mu_r)
+                lamr   = lamv*(gamma(mu_r+4.)/(6.*gamma(mu_r+1.)))**thrd
+
+! set maximum value for rain lambda
+!               lammax = (mu_r+1.)/10.e-6
+                lammax = (mu_r+1.)*1.e+5
+
+! set to small value since breakup is explicitly included (mean size 5 mm)
+!               lammin = (mu_r+1.)/5000.e-6
+                lammin = (mu_r+1.)*200.
+                lamr   = min(lamr,lammax)
+                lamr   = max(lamr,lammin)
+
+! initialize sum
+                sum1 = 0.
+                sum2 = 0.
+                sum6 = 0.
+
+! total rain
+!               sum8=0.
+
+                dd = 20.e-6
+
+                do jj=1,1000
+! particle size
+                   d1 = real(jj)*20.*1.e-6 - 10.e-6
+
+! num is the scaled binned rain size distribution
+! we need to multiply by n0r to get unscaled distribution
+                   num(jj) = d1**mu_r*exp(-lamr*d1)*dd
+
+! get (unscaled) binned ice size distribution
+! bug fix hm, 2/10/12
+                   numi(jj) = n0*d1**mu_i*exp(-lam*d1)*dd
+                enddo !jj-loop
+
+! loop over rain and ice size distributions
+                do jj = 1,1000
+                   do kk = 1,1000
+
+! particle size
+                      d1 = real(jj)*20.*1.e-6 - 10.e-6  ! ice
+                      d2 = real(kk)*20.*1.e-6 - 10.e-6  ! rain
+
+                      if (d1.le.dcrit) then
+                         cs1  = pi*sxth*900.
+                         ds1  = 3.
+                         bas1 = 2.
+                         aas1 = pi*0.25
+                      elseif (d1.gt.dcrit.and.d1.le.dcrits) then
+                         cs1  = cs
+                         ds1  = ds
+                         bas1 = bas
+                         aas1 = aas
+                      elseif (d1.gt.dcrits.and.d1.le.dcritr) then
+                         cs1  = cgp(i_rhor)
+                         ds1  = dg
+                         bas1 = bag
+                         aas1 = aag
+                      else if (d1.gt.dcritr) then
+                         cs1  = csr
+                         ds1  = dsr
+                         if (i_Fr.eq.1) then
+                            aas1 = aas
+                            bas1 = bas
+                         else
+! for area, keep bas1 constant, but modify aas1 accordingto rimed fraction
+                            bas1 = bas
+                            dum1 = aas*d1**bas
+                            dum2 = aag*d1**bag
+                            m1   = cs1*d1**ds1
+                            m2   = cs*d1**ds
+                            m3   = cgp(i_rhor)*d1**dg
+! linearly interpolate based on particle mass
+                            dum3 = dum1+(m1-m2)*(dum2-dum1)/(m3-m2)
+                            aas1 = dum3/(d1**bas)
+                         endif
+                      endif
+
+! absolute value, differential fallspeed
+                      delu = abs(fall2(jj)-fallr(kk))
+
+! collection of rain mass and number
+! allow collection of rain both when rain fallspeed > ice fallspeed
+! and ice fallspeed > rain fallspeed
+! this is applied below freezing to calculate total amount of rain
+! mass and number that collides with ice and freezes
+
+!        if (fall2(jj).ge.fallr(kk)) then
+
+! sum for integral
+
+! change in rain N (units of m^4 s^-1 kg^-1), thus need to multiply
+! by air density (units kg m^-3) and n0r (units kg^-1 m^-1) in the
+! microphysics code
+
+!                     sum1 = sum1+(aas1*d1**bas1+pi*0.25*d2**2)*delu*n0*d1**mu_i*        &
+!                            exp(-lam*d1)* &dd*num(kk)
+                      sum1 = sum1+(aas1*d1**bas1+pi*0.25*d2**2)*delu*n0*d1**mu_i*    &
+                             exp(-lam*d1)*dd*num(kk)
+!                     sum1 = sum1+min((aas1*d1**bas1+pi*0.25*d2**2)*delu*n0*d1**mu_i*    &
+!                            exp(-lam*d1)*dd*num(kk),num(kk))
+
+! change in rain q (units of m^4 s^-1), again need to multiply
+! by air density and n0r in the microphysics code
+
+!                     sum2 = sum2+(aas1*d1**bas1+pi*0.25*d2**2)*delu*n0*d1**mu_i*        &
+!                            exp(-lam*d1)*dd*num(kk)*pi*sxth*997.*d2**3
+                      sum2 = sum2+(aas1*d1**bas1+pi*0.25*d2**2)*delu*n0*d1**mu_i*    &
+                             exp(-lam*d1)*dd*num(kk)*pi*sxth*997.*d2**3
+
+! remove collected rain drops from distribution
+!                      num(kk) = num(kk)-(aas1*d1**bas1+pi*0.25*d2**2)*delu*n0*d1**mu_i*  &
+!                                exp(-lam*d1)*dd*num(kk)*dt
+!                      num(kk) = max(num(kk),0.)
+
+!......................................................
+! now calculate collection of ice mass by rain
+
+! ice collecting rain
+! again, allow collection both when ice fallspeed > rain fallspeed
+! and when rain fallspeed > ice fallspeed
+! this is applied to conditions above freezing to calculate
+! acceleration of melting due to collisions with liquid (rain)
+
+!        if (fall2(jj).ge.fallr(kk)) then
+
+! collection of ice number
+
+!        sum5=sum5+(aas1*d1**bas1+pi/4.*d2**2)*delu*
+!     1  exp(-lamr*d2)*dd*numi(jj)
+
+! collection of ice mass (units of m^4 s^-1), need to multiply by air density and n0r in microphysics code
+                      sum6 = sum6+(aas1*d1**bas1+pi*0.25*d2**2)*delu*d2**mu_r*          &
+                             exp(-lamr*d2)*dd*numi(jj)*cs1*d1**ds1
+
+! remove collected snow from distribution
+!                      numi(jj) = numi(jj)-(aas1*d1**bas1+pi*0.25*d2**2)*delu*d2**mu_r*       &
+!                                 exp(-lamr*d2)*dd*numi(jj)*dt
+!                      numi(jj) = max(numi(jj),0.)
+
+                   enddo !kk-loop
+                enddo !jj-loop
+
+! save for output
+                nrrain(i_Qnorm,i_Drscale,i_Fr) = sum1
+                qrrain(i_Qnorm,i_Drscale,i_Fr) = sum2
+                qsrain(i_Qnorm,i_Drscale,i_Fr) = sum6
+
+             enddo !i_Drscale-loop  (loop around lambda for rain)
+
+!
+!.....................................................................................
+! vapor deposition/melting/wet growth
+!.....................................................................................
+! vapor deposition including ventilation effects
+! note: in microphysics code we need to multiply by air density
+! and (mu/dv)^0.3333*(rhofac/mu)^0.5, where rhofac is air density
+! correction factor
+
+             sum1 = 0.
+             sum2 = 0.
+             dd   = 2.e-6
+
+! loop over exponential size distribution
+             do jj = 1,10000
+
+! particle size
+                d1 = real(jj)*2.*1.e-6 - 1.e-6
+
+! get capacitance for different ice regimes
+                if (d1.le.dcrit) then
+                   cap = 1. ! for small spherical crystal use sphere
+                elseif (d1.gt.dcrit.and.d1.le.dcrits) then
+                   cap = 0.48  ! field et al. 2006
+                elseif (d1.gt.dcrits.and.d1.le.dcritr) then
+                   cap = 1. ! for graupel assume sphere
+                elseif (d1.gt.dcritr) then
+                   cs1 = csr
+                   ds1 = dsr
+                   if (i_Fr.eq.1) then
+                      cap  = 0.48
+                   else
+                      dum1 = 0.48
+                      dum2 = 1.
+                      m1   = cs1*d1**ds1
+                      m2   = cs*d1**ds
+                      m3   = cgp(i_rhor)*d1**dg
+! linearly interpolate to get capacitance based on particle mass
+                      dum3 = dum1+(m1-m2)*(dum2-dum1)/(m3-m2)
+                      cap  = dum3
+                   endif
+                endif
+
+! hm 1/19/13 for ventilation, only include fallspeed
+! and size effects, the rest of the term
+! Sc^1/3 x Re^1/2 is multiplied in-line in the model code
+! to allow effects of atmospheric conditions on ventilation
+!               dum = (mu/dv)**0.333333*(fall1(jj)*d1/mu)**0.5
+                dum = (fall1(jj)*d1)**0.5
+
+! ventilation from hall and pruppacher 1976
+! hm 1/19/13 only include ventilation for super-100 micron particles
+!        if (dum.lt.1.) then
+
+! units are m^3 kg^-1 s^-1, thus multiplication by air density in
+! microphysics code gives s^-1
+
+                if (d1.lt.100.e-6) then
+                   sum1 = sum1+cap*n0*d1**(mu_i+1.)*exp(-lam*d1)*dd
+                else
+!                  sum1 = sum1+cap*n0*(0.65+0.44*dum)*d1**(mu_i+1.)*exp(-lam*d1)*dd
+                   sum1 = sum1+cap*n0*0.65*d1**(mu_i+1.)*exp(-lam*d1)*dd
+                   sum2 = sum2+cap*n0*0.44*dum*d1**(mu_i+1.)*exp(-lam*d1)*dd
+                endif
+
+             enddo !jj-loop
+
+             vdep(i_Qnorm,i_Fr) = sum1
+             vdep1(i_Qnorm,i_Fr) = sum2
+
+             print*,'vdep',vdep(i_Qnorm,i_Fr)
+
+!.....................................................................................
+! ice effective radius
+! use definition of Francis et al. (1994), e.g., Eq. 3.11 in Fu (1996) J. Climate
+!.....................................................................................
+             sum1 = 0.
+             sum2 = 0.
+             dd   = 2.e-6
+
+! loop over exponential size distribution
+             do jj = 1,10000
+
+! particle size
+                d1 = real(jj)*2.*1.e-6 - 1.e-6
+
+                if (d1.le.dcrit) then
+                   cs1  = pi*sxth*900.
+                   ds1  = 3.
+                   bas1 = 2.
+                   aas1 = pi*0.25
+                elseif (d1.gt.dcrit.and.d1.le.dcrits) then
+                   cs1  = cs
+                   ds1  = ds
+                   bas1 = bas
+                   aas1 = aas
+                elseif (d1.gt.dcrits.and.d1.le.dcritr) then
+                   cs1  = cgp(i_rhor)
+                   ds1  = dg
+                   bas1 = bag
+                   aas1 = aag
+                elseif (d1.gt.dcritr) then
+                   cs1  = csr
+                   ds1  = dsr
+                   if (i_Fr.eq.1) then
+                      bas1 = bas
+                      aas1 = aas
+                   else
+! for area, keep bas1 constant, but modify aas1 according to rimed fraction
+                      bas1  = bas
+                      dum1  = aas*d1**bas
+                      dum2  = aag*d1**bag
+                      m1    = cs1*d1**ds1
+                      m2    = cs*d1**ds
+                      m3    = cgp(i_rhor)*d1**dg
+! linearly interpolate based on particle mass
+                      dum3  = dum1+(m1-m2)*(dum2-dum1)/(m3-m2)
+                      aas1  = dum3/(d1**bas)
+                   endif
+                endif
+
+! n0 not included below becuase it is in both numerator and denominator
+!               cs1=pi*sxth*917.
+!               ds1=3.
+!               aas1=pi/4.*2.
+!               bas1=2.
+
+                sum1 = sum1+cs1*d1**ds1*d1**mu_i*exp(-lam*d1)*dd
+                sum2 = sum2+aas1*d1**bas1*d1**mu_i*exp(-lam*d1)*dd
+
+!               if (d1.ge.100.e-6) then
+!                  sum3 = sum3+n0*d1**mu_i*exp(-lam*d1)*dd
+!                  sum4 = sum4+n0*aas1*d1**bas1*d1**mu_i*exp(-lam*d1)*dd
+!               endif
+
+             enddo !jj-loop
+
+! calculate eff radius
+
+!            eff(i_Qnorm,i_Fr) = sum1/(1.7321*916.7*sum2)
+! hm 4/9/09, calculate effective size following Fu (1996)
+!            eff(i_Qnorm,i_Fr) = sum1/(1.1547*916.7*sum2)
+! hm, calculate for eff rad for twp ice
+             eff(i_Qnorm,i_Fr) = 3.*sum1/(4.*sum2*916.7)
+
+!            a_100(i_Qnorm,i_Fr)=sum4
+!            n_100(i_Qnorm,i_Fr)=sum3
+
+             print*,'eff rad',eff(i_Qnorm,i_Fr)
+!.....................................................................................
+
+522  continue
+
+         !-- this column is not used (for v2.2 and after)
+         !   (kept temporarly in order to preserve order of columns in lookup_table_1)
+             nsave(i_Qnorm,i_Fr) = 1.  ! HM, set to 1 for consistency w/ old lookup table file (to verify bit matching)
+         !==
+             qsave(i_Qnorm,i_Fr) = q
+             lsave(i_Qnorm,i_Fr) = lam
+
+       enddo !i_Qnorm-loop
+
+    enddo !i_Fr-loop
+
+! output variables to ascii lookup table
+
+222 format(2i5,15e15.5)
+223 format(2i5,6e15.5)
+
+!-- ice table
+    do i_Fr=1,n_Fr
+
+       do i_Qnorm = 1,n_Qnorm
+
+! set values less than 1.e-99 set to 0, otherwise the 'E' is left off in write statements for floting point
+! numbers using some compilers
+          if (qsave(i_Qnorm,i_Fr).lt.1.e-99) qsave(i_Qnorm,i_Fr)=0.
+          if (nsave(i_Qnorm,i_Fr).lt.1.e-99) nsave(i_Qnorm,i_Fr)=0.
+          if (uns(i_Qnorm,i_Fr).lt.1.e-99) uns(i_Qnorm,i_Fr)=0.
+          if (ums(i_Qnorm,i_Fr).lt.1.e-99) ums(i_Qnorm,i_Fr)=0.
+          if (nagg(i_Qnorm,i_Fr).lt.1.e-99) nagg(i_Qnorm,i_Fr)=0.
+          if (nrwat(i_Qnorm,i_Fr).lt.1.e-99) nrwat(i_Qnorm,i_Fr)=0.
+          if (vdep(i_Qnorm,i_Fr).lt.1.e-99) vdep(i_Qnorm,i_Fr)=0.
+          if (eff(i_Qnorm,i_Fr).lt.1.e-99) eff(i_Qnorm,i_Fr)=0.
+          if (nlarge(i_Qnorm,i_Fr).lt.1.e-99) nlarge(i_Qnorm,i_Fr)=0.
+          if (nsmall(i_Qnorm,i_Fr).lt.1.e-99) nsmall(i_Qnorm,i_Fr)=0.
+          if (lsave(i_Qnorm,i_Fr).lt.1.e-99) lsave(i_Qnorm,i_Fr)=0.
+          if (refl(i_Qnorm,i_Fr).lt.1.e-99) refl(i_Qnorm,i_Fr)=0.
+          if (vdep1(i_Qnorm,i_Fr).lt.1.e-99) vdep1(i_Qnorm,i_Fr)=0.
+          if (dmm(i_Qnorm,i_Fr).lt.1.e-99) dmm(i_Qnorm,i_Fr)=0.
+          if (rhomm(i_Qnorm,i_Fr).lt.1.e-99) rhomm(i_Qnorm,i_Fr)=0.
+
+
+             write(1,222)i_rhor,i_Fr,qsave(i_Qnorm,i_Fr),nsave(i_Qnorm,i_Fr),uns(i_Qnorm,i_Fr),            &
+                         ums(i_Qnorm,i_Fr),nagg(i_Qnorm,i_Fr),nrwat(i_Qnorm,i_Fr),vdep(i_Qnorm,i_Fr),      &
+                         eff(i_Qnorm,i_Fr),nlarge(i_Qnorm,i_Fr),nsmall(i_Qnorm,i_Fr),lsave(i_Qnorm,i_Fr),  &
+                         refl(i_Qnorm,i_Fr),vdep1(i_Qnorm,i_Fr),dmm(i_Qnorm,i_Fr),rhomm(i_Qnorm,i_Fr)
+       enddo !i-loop
+
+   !-- ice-rain collection table:
+       do i_Qnorm = 1,n_Qnorm
+          do i_Drscale=1,n_Drscale
+
+! set values less than 1.e-99 set to 0, otherwise the 'E' is left off in write statements for floting point
+! numbers using some compilers
+          if (qsave(i_Qnorm,i_Fr).lt.1.e-99) qsave(i_Qnorm,i_Fr)=0.
+          if (nsave(i_Qnorm,i_Fr).lt.1.e-99) nsave(i_Qnorm,i_Fr)=0.             
+          if (lamrs(i_Drscale).lt.1.e-99) lamrs(i_Drscale)=0.
+          if (nrrain(i_Qnorm,i_Drscale,i_Fr).lt.1.e-99) nrrain(i_Qnorm,i_Drscale,i_Fr)=0.
+          if (qrrain(i_Qnorm,i_Drscale,i_Fr).lt.1.e-99) qrrain(i_Qnorm,i_Drscale,i_Fr)=0.
+          if (qsrain(i_Qnorm,i_Drscale,i_Fr).lt.1.e-99) qsrain(i_Qnorm,i_Drscale,i_Fr)=0.
+
+             write(1,223) i_rhor,i_Fr,qsave(i_Qnorm,i_Fr),nsave(i_Qnorm,i_Fr),lamrs(i_Drscale),            &
+                          nrrain(i_Qnorm,i_Drscale,i_Fr),qrrain(i_Qnorm,i_Drscale,i_Fr),                   &
+                          qsrain(i_Qnorm,i_Drscale,i_Fr)
+          enddo !i_Drscale-loop
+       enddo !i-loop
+
+    enddo !i_Fr-loop  (riming fraction)
+
+ enddo !i_rhor-loop (main loop over variable rime density)
+
+
+END PROGRAM make_p3_lookuptable1
+!______________________________________________________________________________________
+
+! Incomplete gamma function
+! from Numerical Recipes in Fortran 77: The Art of
+! Scientific Computing
+
+      function gammq(a,x)
+
+      real a,gammq,x
+
+! USES gcf,gser
+! Returns the incomplete gamma function Q(a,x) = 1-P(a,x)
+
+      real gammcf,gammser,gln
+      if (x.lt.0..or.a.le.0) pause 'bad argument in gammq'
+      if (x.lt.a+1.) then
+         call gser(gamser,a,x,gln)
+         gammq=1.-gamser
+      else
+         call gcf(gammcf,a,x,gln)
+         gammq=gammcf
+      end if
+      return
+      end
+
+!-------------------------------------
+
+      subroutine gser(gamser,a,x,gln)
+      integer itmax
+      real a,gamser,gln,x,eps
+      parameter(itmax=100,eps=3.e-7)
+      integer n
+      real ap,del,sum,gamma
+      gln = log(gamma(a))
+      if (x.le.0.) then
+         if (x.lt.0.) pause 'x < 0 in gser'
+         gamser = 0.
+         return
+      end if
+      ap=a
+      sum=1./a
+      del=sum
+      do n=1,itmax
+         ap=ap+1.
+         del=del*x/ap
+         sum=sum+del
+         if (abs(del).lt.abs(sum)*eps) goto 1
+      end do
+      pause 'a too large, itmax too small in gser'
+ 1    gamser=sum*exp(-x+a*log(x)-gln)
+      return
+      end
+
+!-------------------------------------
+
+      subroutine gcf(gammcf,a,x,gln)
+      integer itmax
+      real a,gammcf,gln,x,eps,fpmin
+      parameter(itmax=100,eps=3.e-7,fpmin=1.e-30)
+      integer i
+      real an,b,c,d,del,h,gamma
+      gln=log(gamma(a))
+      b=x+1.-a
+      c=1./fpmin
+      d=1./b
+      h=d
+      do i=1,itmax
+         an=-i*(i-a)
+         b=b+2.
+         d=an*d+b
+         if(abs(d).lt.fpmin) d=fpmin
+         c=b+an/c
+         if(abs(c).lt.fpmin) c=fpmin
+         d=1./d
+         del=d*c
+         h = h*del
+         if(abs(del-1.).lt.eps)goto 1
+      end do
+      pause 'a too large, itmax too small in gcf'
+ 1    gammcf=exp(-x+a*log(x)-gln)*h
+      return
+      end
+
+!-------------------------------------
+
+      REAL FUNCTION gamma(X)
+
+
+!D    DOUBLE PRECISION FUNCTION Dgamma(X)
+!----------------------------------------------------------------------
+!
+! THIS ROUTINE CALCULATES THE gamma FUNCTION FOR A REAL ARGUMENT X.
+!   COMPUTATION IS BASED ON AN ALGORITHM OUTLINED IN REFERENCE 1.
+!   THE PROGRAM USES RATIONAL FUNCTIONS THAT APPROXIMATE THE gamma
+!   FUNCTION TO AT LEAST 20 SIGNIFICANT DECIMAL DIGITS.  COEFFICIENTS
+!   FOR THE APPROXIMATION OVER THE INTERVAL (1,2) ARE UNPUBLISHED.
+!   THOSE FOR THE APPROXIMATION FOR X .GE. 12 ARE FROM REFERENCE 2.
+!   THE ACCURACY ACHIEVED DEPENDS ON THE ARITHMETIC SYSTEM, THE
+!   COMPILER, THE INTRINSIC FUNCTIONS, AND PROPER SELECTION OF THE
+!   MACHINE-DEPENDENT CONSTANTS.
+!
+!
+!----------------------------------------------------------------------
+!
+! EXPLANATION OF MACHINE-DEPENDENT CONSTANTS
+!
+! BETA   - RADIX FOR THE FLOATING-POINT REPRESENTATION
+! MAXEXP - THE SMALLEST POSITIVE POWER OF BETA THAT OVERFLOWS
+! XBIG   - THE LARGEST ARGUMENT FOR WHICH gamma(X) IS REPRESENTABLE
+!          IN THE MACHINE, I.E., THE SOLUTION TO THE EQUATION
+!                  gamma(XBIG) = BETA**MAXEXP
+! XINF   - THE LARGEST MACHINE REPRESENTABLE FLOATING-POINT NUMBER;
+!          APPROXIMATELY BETA**MAXEXP
+! EPS    - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
+!          1.0+EPS .GT. 1.0
+! XMININ - THE SMALLEST POSITIVE FLOATING-POINT NUMBER SUCH THAT
+!          1/XMININ IS MACHINE REPRESENTABLE
+!
+!     APPROXIMATE VALUES FOR SOME IMPORTANT MACHINES ARE:
+!
+!                            BETA       MAXEXP        XBIG
+!
+! CRAY-1         (S.P.)        2         8191        966.961
+! CYBER 180/855
+!   UNDER NOS    (S.P.)        2         1070        177.803
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (S.P.)        2          128        35.040
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (D.P.)        2         1024        171.624
+! IBM 3033       (D.P.)       16           63        57.574
+! VAX D-FORMAT   (D.P.)        2          127        34.844
+! VAX G-FORMAT   (D.P.)        2         1023        171.489
+!
+!                            XINF         EPS        XMININ
+!
+! CRAY-1         (S.P.)   5.45E+2465   7.11E-15    1.84E-2466
+! CYBER 180/855
+!   UNDER NOS    (S.P.)   1.26E+322    3.55E-15    3.14E-294
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (S.P.)   3.40E+38     1.19E-7     1.18E-38
+! IEEE (IBM/XT,
+!   SUN, ETC.)   (D.P.)   1.79D+308    2.22D-16    2.23D-308
+! IBM 3033       (D.P.)   7.23D+75     2.22D-16    1.39D-76
+! VAX D-FORMAT   (D.P.)   1.70D+38     1.39D-17    5.88D-39
+! VAX G-FORMAT   (D.P.)   8.98D+307    1.11D-16    1.12D-308
+!
+!----------------------------------------------------------------------
+!
+! ERROR RETURNS
+!
+!  THE PROGRAM RETURNS THE VALUE XINF FOR SINGULARITIES OR
+!     WHEN OVERFLOW WOULD OCCUR.  THE COMPUTATION IS BELIEVED
+!     TO BE FREE OF UNDERFLOW AND OVERFLOW.
+!
+!
+!  INTRINSIC FUNCTIONS REQUIRED ARE:
+!
+!     INT, DBLE, EXP, LOG, REAL, SIN
+!
+!
+! REFERENCES:  AN OVERVIEW OF SOFTWARE DEVELOPMENT FOR SPECIAL
+!              FUNCTIONS   W. J. CODY, LECTURE NOTES IN MATHEMATICS,
+!              506, NUMERICAL ANALYSIS DUNDEE, 1975, G. A. WATSON
+!              (ED.), SPRINGER VERLAG, BERLIN, 1976.
+!
+!              COMPUTER APPROXIMATIONS, HART, ET. AL., WILEY AND
+!              SONS, NEW YORK, 1968.
+!
+!  LATEST MODIFICATION: OCTOBER 12, 1989
+!
+!  AUTHORS: W. J. CODY AND L. STOLTZ
+!           APPLIED MATHEMATICS DIVISION
+!           ARGONNE NATIONAL LABORATORY
+!           ARGONNE, IL 60439
+!
+!----------------------------------------------------------------------
+      INTEGER I,N
+      LOGICAL PARITY
+      REAL                  &
+!D    DOUBLE PRECISION
+          C,CONV,EPS,FACT,HALF,ONE,P,PI,Q,RES,SQRTPI,SUM,TWELVE, &
+          TWO,X,XBIG,XDEN,XINF,XMININ,XNUM,Y,Y1,YSQ,Z,ZERO
+      DIMENSION C(7),P(8),Q(8)
+!----------------------------------------------------------------------
+!  MATHEMATICAL CONSTANTS
+!----------------------------------------------------------------------
+      DATA ONE,HALF,TWELVE,TWO,ZERO/1.0E0,0.5E0,12.0E0,2.0E0,0.0E0/,  &
+           SQRTPI/0.9189385332046727417803297E0/,                     &
+           PI/3.1415926535897932384626434E0/
+!D    DATA ONE,HALF,TWELVE,TWO,ZERO/1.0D0,0.5D0,12.0D0,2.0D0,0.0D0/,
+!D   1     SQRTPI/0.9189385332046727417803297D0/,
+!D   2     PI/3.1415926535897932384626434D0/
+!----------------------------------------------------------------------
+!  MACHINE DEPENDENT PARAMETERS
+!----------------------------------------------------------------------
+      DATA XBIG,XMININ,EPS/35.040E0,1.18E-38,1.19E-7/,         &
+           XINF/3.4E38/
+!D    DATA XBIG,XMININ,EPS/171.624D0,2.23D-308,2.22D-16/,
+!D   1     XINF/1.79D308/
+!----------------------------------------------------------------------
+!  NUMERATOR AND DENOMINATOR COEFFICIENTS FOR RATIONAL MINIMAX
+!     APPROXIMATION OVER (1,2).
+!----------------------------------------------------------------------
+      DATA P/-1.71618513886549492533811E+0,2.47656508055759199108314E+1,  &
+             -3.79804256470945635097577E+2,6.29331155312818442661052E+2,  &
+             8.66966202790413211295064E+2,-3.14512729688483675254357E+4,  &
+             -3.61444134186911729807069E+4,6.64561438202405440627855E+4/
+      DATA Q/-3.08402300119738975254353E+1,3.15350626979604161529144E+2,  &
+            -1.01515636749021914166146E+3,-3.10777167157231109440444E+3,  &
+              2.25381184209801510330112E+4,4.75584627752788110767815E+3,  &
+            -1.34659959864969306392456E+5,-1.15132259675553483497211E+5/
+!D    DATA P/-1.71618513886549492533811D+0,2.47656508055759199108314D+1,
+!D   1       -3.79804256470945635097577D+2,6.29331155312818442661052D+2,
+!D   2       8.66966202790413211295064D+2,-3.14512729688483675254357D+4,
+!D   3       -3.61444134186911729807069D+4,6.64561438202405440627855D+4/
+!D    DATA Q/-3.08402300119738975254353D+1,3.15350626979604161529144D+2,
+!D   1      -1.01515636749021914166146D+3,-3.10777167157231109440444D+3,
+!D   2        2.25381184209801510330112D+4,4.75584627752788110767815D+3,
+!D   3      -1.34659959864969306392456D+5,-1.15132259675553483497211D+5/
+!----------------------------------------------------------------------
+!  COEFFICIENTS FOR MINIMAX APPROXIMATION OVER (12, INF).
+!----------------------------------------------------------------------
+      DATA C/-1.910444077728E-03,8.4171387781295E-04,                     &
+           -5.952379913043012E-04,7.93650793500350248E-04,                &
+           -2.777777777777681622553E-03,8.333333333333333331554247E-02,   &
+            5.7083835261E-03/
+!D    DATA C/-1.910444077728D-03,8.4171387781295D-04,
+!D   1     -5.952379913043012D-04,7.93650793500350248D-04,
+!D   2     -2.777777777777681622553D-03,8.333333333333333331554247D-02,
+!D   3      5.7083835261D-03/
+!----------------------------------------------------------------------
+!  STATEMENT FUNCTIONS FOR CONVERSION BETWEEN INTEGER AND FLOAT
+!----------------------------------------------------------------------
+      CONV(I) = REAL(I)
+!D    CONV(I) = DBLE(I)
+      PARITY=.FALSE.
+      FACT=ONE
+      N=0
+      Y=X
+      IF(Y.LE.ZERO)THEN
+!----------------------------------------------------------------------
+!  ARGUMENT IS NEGATIVE
+!----------------------------------------------------------------------
+        Y=-X
+        Y1=AINT(Y)
+        RES=Y-Y1
+        IF(RES.NE.ZERO)THEN
+          IF(Y1.NE.AINT(Y1*HALF)*TWO)PARITY=.TRUE.
+          FACT=-PI/SIN(PI*RES)
+          Y=Y+ONE
+        ELSE
+          RES=XINF
+          GOTO 900
+        ENDIF
+      ENDIF
+!----------------------------------------------------------------------
+!  ARGUMENT IS POSITIVE
+!----------------------------------------------------------------------
+      IF(Y.LT.EPS)THEN
+!----------------------------------------------------------------------
+!  ARGUMENT .LT. EPS
+!----------------------------------------------------------------------
+        IF(Y.GE.XMININ)THEN
+          RES=ONE/Y
+        ELSE
+          RES=XINF
+          GOTO 900
+        ENDIF
+      ELSEIF(Y.LT.TWELVE)THEN
+        Y1=Y
+        IF(Y.LT.ONE)THEN
+!----------------------------------------------------------------------
+!  0.0 .LT. ARGUMENT .LT. 1.0
+!----------------------------------------------------------------------
+          Z=Y
+          Y=Y+ONE
+        ELSE
+!----------------------------------------------------------------------
+!  1.0 .LT. ARGUMENT .LT. 12.0, REDUCE ARGUMENT IF NECESSARY
+!----------------------------------------------------------------------
+          N=INT(Y)-1
+          Y=Y-CONV(N)
+          Z=Y-ONE
+        ENDIF
+!----------------------------------------------------------------------
+!  EVALUATE APPROXIMATION FOR 1.0 .LT. ARGUMENT .LT. 2.0
+!----------------------------------------------------------------------
+        XNUM=ZERO
+        XDEN=ONE
+        DO 260 I=1,8
+          XNUM=(XNUM+P(I))*Z
+          XDEN=XDEN*Z+Q(I)
+  260   CONTINUE
+        RES=XNUM/XDEN+ONE
+        IF(Y1.LT.Y)THEN
+!----------------------------------------------------------------------
+!  ADJUST RESULT FOR CASE  0.0 .LT. ARGUMENT .LT. 1.0
+!----------------------------------------------------------------------
+          RES=RES/Y1
+        ELSEIF(Y1.GT.Y)THEN
+!----------------------------------------------------------------------
+!  ADJUST RESULT FOR CASE  2.0 .LT. ARGUMENT .LT. 12.0
+!----------------------------------------------------------------------
+          DO 290 I=1,N
+            RES=RES*Y
+            Y=Y+ONE
+  290     CONTINUE
+        ENDIF
+      ELSE
+!----------------------------------------------------------------------
+!  EVALUATE FOR ARGUMENT .GE. 12.0,
+!----------------------------------------------------------------------
+        IF(Y.LE.XBIG)THEN
+          YSQ=Y*Y
+          SUM=C(7)
+          DO 350 I=1,6
+            SUM=SUM/YSQ+C(I)
+  350     CONTINUE
+          SUM=SUM/Y-Y+SQRTPI
+          SUM=SUM+(Y-HALF)*LOG(Y)
+          RES=EXP(SUM)
+        ELSE
+          RES=XINF
+          GOTO 900
+        ENDIF
+      ENDIF
+!----------------------------------------------------------------------
+!  FINAL ADJUSTMENTS AND RETURN
+!----------------------------------------------------------------------
+      IF(PARITY)RES=-RES
+      IF(FACT.NE.ONE)RES=FACT/RES
+  900 gamma=RES
+!D900 Dgamma = RES
+      RETURN
+! ---------- LAST LINE OF gamma ----------
+      END
+
+
+!--------------------------------------------------------------------------
+! subroutine get_mass_size
+!
+! !----- get mass-size and projected area-size relationships for given size (d1)
+!           if (d1.le.dcrit) then
+!              cs1 = pi*sxth*900.
+!              ds1 = 3.
+!              bas1 = 2.
+!              aas1 = pi/4.
+!           else if (d1.gt.dcrit.and.d1.le.dcrits) then
+!              cs1  = cs
+!              ds1  = ds
+!              bas1 = bas
+!              aas1 = aas
+!           else if (d1.gt.dcrits.and.d1.le.dcritr) then
+!               cs1  = cgp(i_rhor)
+!               ds1  = dg
+!               bas1 = bag
+!               aas1 = aag
+!           else if (d1.gt.dcritr) then
+!              cs1 = csr
+!              ds1 = dsr
+!              if (i_Fr.eq.1) then
+!                 aas1 = aas
+!                 bas1 = bas
+!              else
+!
+! ! for projected area, keep bas1 constant, but modify aas1 according to rimed fraction
+!                 bas1 = bas
+!                 dum1 = aas*d1**bas
+!                 dum2 = aag*d1**bag
+!                 m1   = cs1*d1**ds1
+!                 m2   = cs*d1**ds
+!                 m3   = cgp(i_rhor)*d1**dg
+! ! linearly interpolate based on particle mass
+!                 dum3 = dum1+(m1-m2)*(dum2-dum1)/(m3-m2)
+! !               dum3 = (1.-Fr)*dum1+Fr*dum2
+!                 aas1 = dum3/(d1**bas)
+!              endif
+!           endif
+! !=====
+!
+! end subroutine get_mass_size
diff --git a/wrfv2_fire/run/p3_lookup_table_1.dat b/wrfv2_fire/run/p3_lookup_table_1.dat
new file mode 100644
index 00000000..cbbdc2c0
--- /dev/null
+++ b/wrfv2_fire/run/p3_lookup_table_1.dat
@@ -0,0 +1,31000 @@
+    1    1    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.45191E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    1    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.78855E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    1    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.13760E-07    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    1    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.24010E-07    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    1    1    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.41896E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    1    1    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.73106E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    1    1    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.12757E-06    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    1    1    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.22259E-06    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    1    1    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.38841E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    1    1    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.67776E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    1    1    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.11826E-05    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    1    1    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.20636E-05    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    1    1    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.36009E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    1    1    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.62834E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    1    1    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.10964E-04    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    1    1    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.19132E-04    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    1    1    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.33384E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    1    1    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.58253E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    1    1    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.10165E-03    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    1    1    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.17737E-03    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    1    1    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53957E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.30950E-03    0.19496E+06    0.99447E-26    0.48760E-10    0.50499E-04    0.88379E+03
+    1    1    0.54572E-10    0.10000E+01    0.74090E-01    0.13935E+00    0.11222E-09    0.65380E-11    0.40383E-04    0.29228E-04    0.98516E+04    0.54006E-03    0.15940E+06    0.27009E-25    0.58026E-09    0.60483E-04    0.85041E+03
+    1    1    0.95225E-10    0.10000E+01    0.11736E+00    0.19749E+00    0.21140E-09    0.50996E-10    0.44004E-04    0.38038E-04    0.17190E+05    0.94236E-03    0.12765E+06    0.72480E-25    0.43989E-08    0.73406E-04    0.78192E+03
+    1    1    0.16616E-09    0.10000E+01    0.18179E+00    0.26431E+00    0.32753E-09    0.26583E-09    0.44528E-04    0.48903E-04    0.29996E+05    0.16444E-02    0.99467E+05    0.19955E-24    0.21856E-07    0.91697E-04    0.67141E+03
+    1    1    0.28994E-09    0.10000E+01    0.25961E+00    0.33496E+00    0.47703E-09    0.94192E-09    0.43515E-04    0.57767E-04    0.52341E+05    0.28693E-02    0.75619E+05    0.57623E-24    0.71447E-07    0.11865E-03    0.53386E+03
+    1    1    0.50593E-09    0.10000E+01    0.33900E+00    0.40891E+00    0.78184E-09    0.24625E-08    0.45608E-04    0.61912E-04    0.91333E+05    0.50068E-02    0.56747E+05    0.17224E-23    0.16529E-06    0.15713E-03    0.40140E+03
+    1    1    0.88282E-09    0.10000E+01    0.41762E+00    0.48781E+00    0.14159E-08    0.54449E-08    0.54182E-04    0.63271E-04    0.15937E+06    0.87366E-02    0.42418E+05    0.52150E-23    0.31202E-06    0.20988E-03    0.29419E+03
+    1    1    0.15405E-08    0.10000E+01    0.36333E+00    0.69413E+00    0.73763E-08    0.13444E-07    0.63796E-04    0.63687E-04    0.81842E+05    0.10022E-01    0.66266E+04    0.47987E-22    0.49383E-06    0.46540E-03    0.16320E+03
+    1    1    0.26880E-08    0.10000E+01    0.41493E+00    0.79920E+00    0.14413E-07    0.26952E-07    0.78612E-04    0.64477E-04    0.11884E+06    0.16326E-01    0.43556E+04    0.16801E-21    0.82043E-06    0.66658E-03    0.11507E+03
+    1    1    0.46905E-08    0.10000E+01    0.48925E+00    0.88639E+00    0.25829E-07    0.51969E-07    0.10150E-03    0.65033E-04    0.20736E+06    0.28487E-01    0.32516E+04    0.51055E-21    0.13585E-05    0.89233E-03    0.84398E+02
+    1    1    0.81846E-08    0.10000E+01    0.56673E+00    0.97193E+00    0.45706E-07    0.98963E-07    0.13297E-03    0.65496E-04    0.36184E+06    0.49709E-01    0.24275E+04    0.15520E-20    0.22272E-05    0.11950E-02    0.61636E+02
+    1    1    0.14282E-07    0.10000E+01    0.64674E+00    0.10550E+01    0.79653E-07    0.18646E-06    0.17564E-03    0.65920E-04    0.63138E+06    0.86738E-01    0.18098E+04    0.47302E-20    0.36228E-05    0.16025E-02    0.44825E+02
+    1    1    0.24920E-07    0.10000E+01    0.72758E+00    0.11339E+01    0.13744E-06    0.34778E-06    0.23364E-03    0.66323E-04    0.11017E+07    0.15135E+00    0.13511E+04    0.14383E-19    0.58583E-05    0.21465E-02    0.32588E+02
+    1    1    0.43485E-07    0.10000E+01    0.80896E+00    0.12086E+01    0.23376E-06    0.64324E-06    0.31151E-03    0.66721E-04    0.19224E+07    0.26410E+00    0.10073E+04    0.43840E-19    0.94208E-05    0.28789E-02    0.23633E+02
+    1    1    0.75878E-07    0.10000E+01    0.88920E+00    0.12781E+01    0.39425E-06    0.11802E-05    0.41669E-03    0.67115E-04    0.33546E+07    0.46084E+00    0.75202E+03    0.13322E-18    0.15088E-04    0.38558E-02    0.17152E+02
+    1    1    0.13240E-06    0.10000E+01    0.96812E+00    0.13425E+01    0.65574E-06    0.21493E-05    0.55729E-03    0.67510E-04    0.58535E+07    0.80414E+00    0.56068E+03    0.40205E-18    0.24049E-04    0.51577E-02    0.12434E+02
+    1    1    0.23103E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.15703E-05    0.38017E-05    0.87654E-03    0.67662E-04    0.10214E+08    0.14032E+01    0.50000E+03    0.86013E-18    0.40441E-04    0.57605E-02    0.10978E+02
+    1    1    0.40314E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.47812E-05    0.66338E-05    0.15295E-02    0.67662E-04    0.17823E+08    0.24485E+01    0.50000E+03    0.15009E-17    0.70568E-04    0.57605E-02    0.10978E+02
+    1    1    0.70346E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.14558E-04    0.11576E-04    0.26689E-02    0.67662E-04    0.31100E+08    0.42724E+01    0.50000E+03    0.26189E-17    0.12314E-03    0.57605E-02    0.10978E+02
+    1    1    0.12275E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.44326E-04    0.20199E-04    0.46571E-02    0.67662E-04    0.54267E+08    0.74551E+01    0.50000E+03    0.45699E-17    0.21487E-03    0.57605E-02    0.10978E+02
+    1    1    0.21419E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.13496E-03    0.35246E-04    0.81263E-02    0.67662E-04    0.94693E+08    0.13009E+02    0.50000E+03    0.79742E-17    0.37493E-03    0.57605E-02    0.10978E+02
+    1    1    0.37375E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.41094E-03    0.61501E-04    0.14180E-01    0.67662E-04    0.16523E+09    0.22699E+02    0.50000E+03    0.13915E-16    0.65423E-03    0.57605E-02    0.10978E+02
+    1    1    0.65217E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.12512E-02    0.10732E-03    0.24743E-01    0.67662E-04    0.28832E+09    0.39609E+02    0.50000E+03    0.24280E-16    0.11416E-02    0.57605E-02    0.10978E+02
+    1    1    0.11380E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.38098E-02    0.18726E-03    0.43175E-01    0.67662E-04    0.50310E+09    0.69116E+02    0.50000E+03    0.42367E-16    0.19920E-02    0.57605E-02    0.10978E+02
+    1    1    0.19857E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.11600E-01    0.32676E-03    0.75338E-01    0.67662E-04    0.87789E+09    0.12060E+03    0.50000E+03    0.73928E-16    0.34759E-02    0.57605E-02    0.10978E+02
+    1    1    0.34650E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.35320E-01    0.57017E-03    0.13146E+00    0.67662E-04    0.15319E+10    0.21044E+03    0.50000E+03    0.12900E-15    0.60653E-02    0.57605E-02    0.10978E+02
+    1    1    0.60462E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.10754E+00    0.99492E-03    0.22939E+00    0.67662E-04    0.26730E+10    0.36721E+03    0.50000E+03    0.22510E-15    0.10583E-01    0.57605E-02    0.10978E+02
+    1    1    0.10550E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.32745E+00    0.17361E-02    0.40027E+00    0.67662E-04    0.46642E+10    0.64076E+03    0.50000E+03    0.39278E-15    0.18468E-01    0.57605E-02    0.10978E+02
+    1    1    0.18409E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.99703E+00    0.30293E-02    0.69845E+00    0.67662E-04    0.81388E+10    0.11181E+04    0.50000E+03    0.68538E-15    0.32225E-01    0.57605E-02    0.10978E+02
+    1    1    0.32123E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.30358E+01    0.52860E-02    0.12188E+01    0.67662E-04    0.14202E+11    0.19510E+04    0.50000E+03    0.11959E-14    0.56230E-01    0.57605E-02    0.10978E+02
+    1    1    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    1    1    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    1    1    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    1    1    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    1    1    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    1    1    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    1    1    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    1    1    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    1    1    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    1    1    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    1    1    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    1    1    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    1    1    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    1    1    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    1    1    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    1    1    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    1    1    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    1    1    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    1    1    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    1    1    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    1    1    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    1    1    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    1    1    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    1    1    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    1    1    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    1    1    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    1    1    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    1    1    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    1    1    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    1    1    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    1    1    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    1    1    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    1    1    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    1    1    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    1    1    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    1    1    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    1    1    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    1    1    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    1    1    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    1    1    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    1    1    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    1    1    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    1    1    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    1    1    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    1    1    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    1    1    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    1    1    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    1    1    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    1    1    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    1    1    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    1    1    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    1    1    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    1    1    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    1    1    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    1    1    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    1    1    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    1    1    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    1    1    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    1    1    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    1    1    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    1    1    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    1    1    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    1    1    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    1    1    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    1    1    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    1    1    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    1    1    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    1    1    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    1    1    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    1    1    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    1    1    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    1    1    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    1    1    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    1    1    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    1    1    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    1    1    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    1    1    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    1    1    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    1    1    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    1    1    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    1    1    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    1    1    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    1    1    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    1    1    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    1    1    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    1    1    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    1    1    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    1    1    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    1    1    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    1    1    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    1    1    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    1    1    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    1    1    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    1    1    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    1    1    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    1    1    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    1    1    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    1    1    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    1    1    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    1    1    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    1    1    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    1    1    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    1    1    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    1    1    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    1    1    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    1    1    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    1    1    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    1    1    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    1    1    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    1    1    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    1    1    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    1    1    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    1    1    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    1    1    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    1    1    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    1    1    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    1    1    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    1    1    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    1    1    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    1    1    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    1    1    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    1    1    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    1    1    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    1    1    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    1    1    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    1    1    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    1    1    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    1    1    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    1    1    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    1    1    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    1    1    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    1    1    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    1    1    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    1    1    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    1    1    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    1    1    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    1    1    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    1    1    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    1    1    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    1    1    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    1    1    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    1    1    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    1    1    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    1    1    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    1    1    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    1    1    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    1    1    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    1    1    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    1    1    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    1    1    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    1    1    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    1    1    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    1    1    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    1    1    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    1    1    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    1    1    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    1    1    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    1    1    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    1    1    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    1    1    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    1    1    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    1    1    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    1    1    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    1    1    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    1    1    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    1    1    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    1    1    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    1    1    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    1    1    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    1    1    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    1    1    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    1    1    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    1    1    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    1    1    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    1    1    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    1    1    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    1    1    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    1    1    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    1    1    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    1    1    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    1    1    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    1    1    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    1    1    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    1    1    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    1    1    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    1    1    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    1    1    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    1    1    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    1    1    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    1    1    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    1    1    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    1    1    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    1    1    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    1    1    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    1    1    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    1    1    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    1    1    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    1    1    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    1    1    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    1    1    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    1    1    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    1    1    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    1    1    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    1    1    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    1    1    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    1    1    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    1    1    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    1    1    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    1    1    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    1    1    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    1    1    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    1    1    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    1    1    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    1    1    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    1    1    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    1    1    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    1    1    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    1    1    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    1    1    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    1    1    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    1    1    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    1    1    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    1    1    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    1    1    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    1    1    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    1    1    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    1    1    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    1    1    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    1    1    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    1    1    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    1    1    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    1    1    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    1    1    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    1    1    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    1    1    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    1    1    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    1    1    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    1    1    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    1    1    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    1    1    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    1    1    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    1    1    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    1    1    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    1    1    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    1    1    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    1    1    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    1    1    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    1    1    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    1    1    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    1    1    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    1    1    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    1    1    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    1    1    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    1    1    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    1    1    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    1    1    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    1    1    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    1    1    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    1    1    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    1    1    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    1    1    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    1    1    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    1    1    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    1    1    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    1    1    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    1    1    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    1    1    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    1    1    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    1    1    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    1    1    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    1    1    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    1    1    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    1    1    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    1    1    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    1    1    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    1    1    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    1    1    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    1    1    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    1    1    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    1    1    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    1    1    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    1    1    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    1    1    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    1    1    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    1    1    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    1    1    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    1    1    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    1    1    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    1    1    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    1    1    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    1    1    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    1    1    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    1    1    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    1    1    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    1    1    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    1    1    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    1    1    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    1    1    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    1    1    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    1    1    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    1    1    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    1    1    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    1    1    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    1    1    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    1    1    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    1    1    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    1    1    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    1    1    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    1    1    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    1    1    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    1    1    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    1    1    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    1    1    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    1    1    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    1    1    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    1    1    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    1    1    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    1    1    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    1    1    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    1    1    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    1    1    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    1    1    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    1    1    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    1    1    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    1    1    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    1    1    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    1    1    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    1    1    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    1    1    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    1    1    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    1    1    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    1    1    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    1    1    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    1    1    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    1    1    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    1    1    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    1    1    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    1    1    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    1    1    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    1    1    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    1    1    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    1    1    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    1    1    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    1    1    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    1    1    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    1    1    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    1    1    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    1    1    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    1    1    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    1    1    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    1    1    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    1    1    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    1    1    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    1    1    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    1    1    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    1    1    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    1    1    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    1    1    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    1    1    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    1    1    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    1    1    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    1    1    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    1    1    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    1    1    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    1    1    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    1    1    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    1    1    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    1    1    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    1    1    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    1    1    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    1    1    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    1    1    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    1    1    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    1    1    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    1    1    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    1    1    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    1    1    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    1    1    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    1    1    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    1    1    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    1    1    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    1    1    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    1    1    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    1    1    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    1    1    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    1    1    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    1    1    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    1    1    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    1    1    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    1    1    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    1    1    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    1    1    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    1    1    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    1    1    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    1    1    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    1    1    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    1    1    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    1    1    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    1    1    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    1    1    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    1    1    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    1    1    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    1    1    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    1    1    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    1    1    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    1    1    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    1    1    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    1    1    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    1    1    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    1    1    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    1    1    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    1    1    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    1    1    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    1    1    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    1    1    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    1    1    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    1    1    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    1    1    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    1    1    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    1    1    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    1    1    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    1    1    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    1    1    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    1    1    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    1    1    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    1    1    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    1    1    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    1    1    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    1    1    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    1    1    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    1    1    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    1    1    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    1    1    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    1    1    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    1    1    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    1    1    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    1    1    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    1    1    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    1    1    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    1    1    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    1    1    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    1    1    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    1    1    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    1    1    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    1    1    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    1    1    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    1    1    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    1    1    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    1    1    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    1    1    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    1    1    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    1    1    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    1    1    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    1    1    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    1    1    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    1    1    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    1    1    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    1    1    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    1    1    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    1    1    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    1    1    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    1    1    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    1    1    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    1    1    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    1    1    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    1    1    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    1    1    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    1    1    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    1    1    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    1    1    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    1    1    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    1    1    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    1    1    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    1    1    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    1    1    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    1    1    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    1    1    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    1    1    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    1    1    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    1    1    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    1    1    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    1    1    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    1    1    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    1    1    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    1    1    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    1    1    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    1    1    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    1    1    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    1    1    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    1    1    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    1    1    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    1    1    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    1    1    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    1    1    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    1    1    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    1    1    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    1    1    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    1    1    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    1    1    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    1    1    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    1    1    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    1    1    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    1    1    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    1    1    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    1    1    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    1    1    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    1    1    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    1    1    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    1    1    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    1    1    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    1    1    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    1    1    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    1    1    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    1    1    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    1    1    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    1    1    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    1    1    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    1    1    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    1    1    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    1    1    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    1    1    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    1    1    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    1    1    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    1    1    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    1    1    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    1    1    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    1    1    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    1    1    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    1    1    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    1    1    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    1    1    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    1    1    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    1    1    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    1    1    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    1    1    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    1    1    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    1    1    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    1    1    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    1    1    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    1    1    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    1    1    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    1    1    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    1    1    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    1    1    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    1    1    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    1    1    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    1    1    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    1    1    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    1    1    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    1    1    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    1    1    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    1    1    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    1    1    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    1    1    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    1    1    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    1    1    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    1    1    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    1    1    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    1    1    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    1    1    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    1    1    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    1    1    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    1    1    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    1    1    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    1    1    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    1    1    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    1    1    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    1    1    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    1    1    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    1    1    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    1    1    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    1    1    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    1    1    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    1    1    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    1    1    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    1    1    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    1    1    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    1    1    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    1    1    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    1    1    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    1    1    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    1    1    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    1    1    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    1    1    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    1    1    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    1    1    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    1    1    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    1    1    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    1    1    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    1    1    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    1    1    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    1    1    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    1    1    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    1    1    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    1    1    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    1    1    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    1    1    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    1    1    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    1    1    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    1    1    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    1    1    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    1    1    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    1    1    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    1    1    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    1    1    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    1    1    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    1    1    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    1    1    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    1    1    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    1    1    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    1    1    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    1    1    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    1    1    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    1    1    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    1    1    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    1    1    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    1    1    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    1    1    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    1    1    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    1    1    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    1    1    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    1    1    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    1    1    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    1    1    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    1    1    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    1    1    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    1    1    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    1    1    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    1    1    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    1    1    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    1    1    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35525E-67
+    1    1    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31050E-66
+    1    1    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49297E-66    0.26759E-65
+    1    1    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20665E-64
+    1    1    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    1    1    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15327E-62
+    1    1    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    1    1    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30486E-60
+    1    1    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49479E-59
+    1    1    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76348E-58
+    1    1    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    1    1    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16341E-55
+    1    1    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    1    1    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33513E-53
+    1    1    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47754E-52
+    1    1    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86007E-46    0.21355E-49
+    1    1    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    1    1    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    1    1    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    1    1    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    1    1    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    1    1    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    1    1    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    1    1    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    1    1    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    1    1    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    1    1    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    1    1    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    1    1    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    1    1    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    1    1    0.95225E-10    0.10000E+01    0.80645E+05    0.53338E-57    0.41251E-68    0.10749E-66
+    1    1    0.95225E-10    0.10000E+01    0.65036E+05    0.46320E-56    0.66241E-67    0.94141E-66
+    1    1    0.95225E-10    0.10000E+01    0.52449E+05    0.40024E-55    0.93503E-66    0.81416E-65
+    1    1    0.95225E-10    0.10000E+01    0.42297E+05    0.31521E-54    0.15121E-64    0.62477E-64
+    1    1    0.95225E-10    0.10000E+01    0.34111E+05    0.26479E-53    0.31103E-63    0.46450E-63
+    1    1    0.95225E-10    0.10000E+01    0.27509E+05    0.27530E-52    0.84266E-62    0.36185E-62
+    1    1    0.95225E-10    0.10000E+01    0.22184E+05    0.37547E-51    0.26561E-60    0.35004E-61
+    1    1    0.95225E-10    0.10000E+01    0.17891E+05    0.59959E-50    0.82078E-59    0.47852E-60
+    1    1    0.95225E-10    0.10000E+01    0.14428E+05    0.96029E-49    0.23747E-57    0.76675E-59
+    1    1    0.95225E-10    0.10000E+01    0.11635E+05    0.14620E-47    0.65938E-56    0.12102E-57
+    1    1    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18298E-56
+    1    1    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49011E-53    0.26942E-55
+    1    1    0.95225E-10    0.10000E+01    0.61026E+04    0.43943E-44    0.13295E-51    0.39150E-54
+    1    1    0.95225E-10    0.10000E+01    0.49215E+04    0.62538E-43    0.35997E-50    0.56476E-53
+    1    1    0.95225E-10    0.10000E+01    0.39689E+04    0.88822E-42    0.97300E-49    0.81063E-52
+    1    1    0.95225E-10    0.10000E+01    0.32008E+04    0.39613E-39    0.84952E-46    0.36461E-49
+    1    1    0.95225E-10    0.10000E+01    0.25813E+04    0.29211E-30    0.14353E-36    0.27085E-40
+    1    1    0.95225E-10    0.10000E+01    0.20817E+04    0.55938E-14    0.12256E-19    0.52257E-24
+    1    1    0.95225E-10    0.10000E+01    0.16788E+04    0.18980E-08    0.18143E-13    0.17813E-18
+    1    1    0.95225E-10    0.10000E+01    0.13538E+04    0.40806E-08    0.68940E-13    0.38357E-18
+    1    1    0.95225E-10    0.10000E+01    0.10918E+04    0.85761E-08    0.25711E-12    0.80708E-18
+    1    1    0.95225E-10    0.10000E+01    0.88049E+03    0.17636E-07    0.94670E-12    0.16610E-17
+    1    1    0.95225E-10    0.10000E+01    0.71007E+03    0.35560E-07    0.34475E-11    0.33511E-17
+    1    1    0.95225E-10    0.10000E+01    0.57264E+03    0.70490E-07    0.12266E-10    0.66454E-17
+    1    1    0.95225E-10    0.10000E+01    0.46180E+03    0.13745E-06    0.41255E-10    0.12961E-16
+    1    1    0.95225E-10    0.10000E+01    0.37242E+03    0.26237E-06    0.12579E-09    0.24744E-16
+    1    1    0.95225E-10    0.10000E+01    0.30034E+03    0.48462E-06    0.33740E-09    0.45710E-16
+    1    1    0.95225E-10    0.10000E+01    0.24221E+03    0.85384E-06    0.78780E-09    0.80539E-16
+    1    1    0.95225E-10    0.10000E+01    0.19533E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    1    1    0.95225E-10    0.10000E+01    0.15752E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    1    1    0.16616E-09    0.10000E+01    0.80645E+05    0.10831E-56    0.84134E-68    0.33649E-66
+    1    1    0.16616E-09    0.10000E+01    0.65036E+05    0.94382E-56    0.13505E-66    0.29209E-65
+    1    1    0.16616E-09    0.10000E+01    0.52449E+05    0.81476E-55    0.18599E-65    0.25174E-64
+    1    1    0.16616E-09    0.10000E+01    0.42297E+05    0.62646E-54    0.26584E-64    0.19203E-63
+    1    1    0.16616E-09    0.10000E+01    0.34111E+05    0.47293E-53    0.41443E-63    0.13945E-62
+    1    1    0.16616E-09    0.10000E+01    0.27509E+05    0.38376E-52    0.82703E-62    0.99836E-62
+    1    1    0.16616E-09    0.10000E+01    0.22184E+05    0.38951E-51    0.23108E-60    0.77606E-61
+    1    1    0.16616E-09    0.10000E+01    0.17891E+05    0.53703E-50    0.71872E-59    0.82846E-60
+    1    1    0.16616E-09    0.10000E+01    0.14428E+05    0.84667E-49    0.21403E-57    0.12129E-58
+    1    1    0.16616E-09    0.10000E+01    0.11635E+05    0.13169E-47    0.60847E-56    0.19194E-57
+    1    1    0.16616E-09    0.10000E+01    0.93834E+04    0.19721E-46    0.16918E-54    0.29611E-56
+    1    1    0.16616E-09    0.10000E+01    0.75673E+04    0.28850E-45    0.46590E-53    0.44363E-55
+    1    1    0.16616E-09    0.10000E+01    0.61026E+04    0.41726E-44    0.12762E-51    0.65289E-54
+    1    1    0.16616E-09    0.10000E+01    0.49215E+04    0.59980E-43    0.34818E-50    0.95065E-53
+    1    1    0.16616E-09    0.10000E+01    0.39689E+04    0.85857E-42    0.94687E-49    0.13742E-51
+    1    1    0.16616E-09    0.10000E+01    0.32008E+04    0.38534E-39    0.83094E-46    0.62162E-49
+    1    1    0.16616E-09    0.10000E+01    0.25813E+04    0.28572E-30    0.14110E-36    0.46404E-40
+    1    1    0.16616E-09    0.10000E+01    0.20817E+04    0.55023E-14    0.12112E-19    0.89981E-24
+    1    1    0.16616E-09    0.10000E+01    0.16788E+04    0.18735E-08    0.17967E-13    0.30768E-18
+    1    1    0.16616E-09    0.10000E+01    0.13538E+04    0.40327E-08    0.68292E-13    0.66322E-18
+    1    1    0.16616E-09    0.10000E+01    0.10918E+04    0.84828E-08    0.25473E-12    0.13965E-17
+    1    1    0.16616E-09    0.10000E+01    0.88049E+03    0.17454E-07    0.93805E-12    0.28757E-17
+    1    1    0.16616E-09    0.10000E+01    0.71007E+03    0.35210E-07    0.34161E-11    0.58040E-17
+    1    1    0.16616E-09    0.10000E+01    0.57264E+03    0.69816E-07    0.12154E-10    0.11512E-16
+    1    1    0.16616E-09    0.10000E+01    0.46180E+03    0.13616E-06    0.40880E-10    0.22458E-16
+    1    1    0.16616E-09    0.10000E+01    0.37242E+03    0.25994E-06    0.12465E-09    0.42878E-16
+    1    1    0.16616E-09    0.10000E+01    0.30034E+03    0.48017E-06    0.33433E-09    0.79212E-16
+    1    1    0.16616E-09    0.10000E+01    0.24221E+03    0.84602E-06    0.78064E-09    0.13957E-15
+    1    1    0.16616E-09    0.10000E+01    0.19533E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    1    1    0.16616E-09    0.10000E+01    0.15752E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    1    1    0.28994E-09    0.10000E+01    0.80645E+05    0.22011E-56    0.16920E-67    0.11249E-65
+    1    1    0.28994E-09    0.10000E+01    0.65036E+05    0.19023E-55    0.27099E-66    0.96503E-65
+    1    1    0.28994E-09    0.10000E+01    0.52449E+05    0.16355E-54    0.36930E-65    0.82631E-64
+    1    1    0.28994E-09    0.10000E+01    0.42297E+05    0.12449E-53    0.50576E-64    0.62542E-63
+    1    1    0.28994E-09    0.10000E+01    0.34111E+05    0.90534E-53    0.69149E-63    0.44950E-62
+    1    1    0.28994E-09    0.10000E+01    0.27509E+05    0.65403E-52    0.10276E-61    0.31368E-61
+    1    1    0.28994E-09    0.10000E+01    0.22184E+05    0.51145E-51    0.21678E-60    0.21734E-60
+    1    1    0.28994E-09    0.10000E+01    0.17891E+05    0.53350E-50    0.62717E-59    0.17681E-59
+    1    1    0.28994E-09    0.10000E+01    0.14428E+05    0.75573E-49    0.19028E-57    0.20765E-58
+    1    1    0.28994E-09    0.10000E+01    0.11635E+05    0.11751E-47    0.55601E-56    0.31026E-57
+    1    1    0.28994E-09    0.10000E+01    0.93834E+04    0.17997E-46    0.15781E-54    0.48192E-56
+    1    1    0.28994E-09    0.10000E+01    0.75673E+04    0.26865E-45    0.44099E-53    0.73307E-55
+    1    1    0.28994E-09    0.10000E+01    0.61026E+04    0.39444E-44    0.12210E-51    0.10917E-53
+    1    1    0.28994E-09    0.10000E+01    0.49215E+04    0.57333E-43    0.33588E-50    0.16029E-52
+    1    1    0.28994E-09    0.10000E+01    0.39689E+04    0.82768E-42    0.91939E-49    0.23314E-51
+    1    1    0.28994E-09    0.10000E+01    0.32008E+04    0.37400E-39    0.81127E-46    0.10597E-48
+    1    1    0.28994E-09    0.10000E+01    0.25813E+04    0.27896E-30    0.13850E-36    0.79454E-40
+    1    1    0.28994E-09    0.10000E+01    0.20817E+04    0.54048E-14    0.11957E-19    0.15478E-23
+    1    1    0.28994E-09    0.10000E+01    0.16788E+04    0.18472E-08    0.17777E-13    0.53075E-18
+    1    1    0.28994E-09    0.10000E+01    0.13538E+04    0.39812E-08    0.67591E-13    0.11451E-17
+    1    1    0.28994E-09    0.10000E+01    0.10918E+04    0.83822E-08    0.25216E-12    0.24130E-17
+    1    1    0.28994E-09    0.10000E+01    0.88049E+03    0.17259E-07    0.92865E-12    0.49712E-17
+    1    1    0.28994E-09    0.10000E+01    0.71007E+03    0.34831E-07    0.33820E-11    0.10037E-16
+    1    1    0.28994E-09    0.10000E+01    0.57264E+03    0.69086E-07    0.12033E-10    0.19913E-16
+    1    1    0.28994E-09    0.10000E+01    0.46180E+03    0.13476E-06    0.40472E-10    0.38849E-16
+    1    1    0.28994E-09    0.10000E+01    0.37242E+03    0.25730E-06    0.12341E-09    0.74180E-16
+    1    1    0.28994E-09    0.10000E+01    0.30034E+03    0.47533E-06    0.33100E-09    0.13705E-15
+    1    1    0.28994E-09    0.10000E+01    0.24221E+03    0.83753E-06    0.77285E-09    0.24148E-15
+    1    1    0.28994E-09    0.10000E+01    0.19533E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    1    1    0.28994E-09    0.10000E+01    0.15752E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    1    1    0.50593E-09    0.10000E+01    0.80645E+05    0.44926E-56    0.34079E-67    0.39232E-65
+    1    1    0.50593E-09    0.10000E+01    0.65036E+05    0.38422E-55    0.54341E-66    0.33355E-64
+    1    1    0.50593E-09    0.10000E+01    0.52449E+05    0.32834E-54    0.73364E-65    0.28402E-63
+    1    1    0.50593E-09    0.10000E+01    0.42297E+05    0.24795E-53    0.99037E-64    0.21350E-62
+    1    1    0.50593E-09    0.10000E+01    0.34111E+05    0.17797E-52    0.13099E-62    0.15247E-61
+    1    1    0.50593E-09    0.10000E+01    0.27509E+05    0.12441E-51    0.16902E-61    0.10586E-60
+    1    1    0.50593E-09    0.10000E+01    0.22184E+05    0.86010E-51    0.25710E-60    0.70603E-60
+    1    1    0.50593E-09    0.10000E+01    0.17891E+05    0.67638E-50    0.58946E-59    0.47985E-59
+    1    1    0.50593E-09    0.10000E+01    0.14428E+05    0.74782E-49    0.17213E-57    0.41577E-58
+    1    1    0.50593E-09    0.10000E+01    0.11635E+05    0.10801E-47    0.51285E-56    0.52474E-57
+    1    1    0.50593E-09    0.10000E+01    0.93834E+04    0.16626E-46    0.14855E-54    0.79304E-56
+    1    1    0.50593E-09    0.10000E+01    0.75673E+04    0.25254E-45    0.42087E-53    0.12189E-54
+    1    1    0.50593E-09    0.10000E+01    0.61026E+04    0.37597E-44    0.11762E-51    0.18356E-53
+    1    1    0.50593E-09    0.10000E+01    0.49215E+04    0.55185E-43    0.32580E-50    0.27151E-52
+    1    1    0.50593E-09    0.10000E+01    0.39689E+04    0.80238E-42    0.89663E-49    0.39684E-51
+    1    1    0.50593E-09    0.10000E+01    0.32008E+04    0.36462E-39    0.79485E-46    0.18106E-48
+    1    1    0.50593E-09    0.10000E+01    0.25813E+04    0.27333E-30    0.13633E-36    0.13622E-39
+    1    1    0.50593E-09    0.10000E+01    0.20817E+04    0.53238E-14    0.11828E-19    0.26638E-23
+    1    1    0.50593E-09    0.10000E+01    0.16788E+04    0.18256E-08    0.17620E-13    0.91573E-18
+    1    1    0.50593E-09    0.10000E+01    0.13538E+04    0.39387E-08    0.67015E-13    0.19773E-17
+    1    1    0.50593E-09    0.10000E+01    0.10918E+04    0.82993E-08    0.25005E-12    0.41688E-17
+    1    1    0.50593E-09    0.10000E+01    0.88049E+03    0.17098E-07    0.92093E-12    0.85921E-17
+    1    1    0.50593E-09    0.10000E+01    0.71007E+03    0.34520E-07    0.33539E-11    0.17352E-16
+    1    1    0.50593E-09    0.10000E+01    0.57264E+03    0.68486E-07    0.11933E-10    0.34432E-16
+    1    1    0.50593E-09    0.10000E+01    0.46180E+03    0.13362E-06    0.40135E-10    0.67183E-16
+    1    1    0.50593E-09    0.10000E+01    0.37242E+03    0.25513E-06    0.12238E-09    0.12829E-15
+    1    1    0.50593E-09    0.10000E+01    0.30034E+03    0.47134E-06    0.32824E-09    0.23702E-15
+    1    1    0.50593E-09    0.10000E+01    0.24221E+03    0.83053E-06    0.76641E-09    0.41764E-15
+    1    1    0.50593E-09    0.10000E+01    0.19533E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    1    1    0.50593E-09    0.10000E+01    0.15752E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    1    1    0.88282E-09    0.10000E+01    0.80645E+05    0.91476E-56    0.68731E-67    0.13789E-64
+    1    1    0.88282E-09    0.10000E+01    0.65036E+05    0.77641E-55    0.10919E-65    0.11662E-63
+    1    1    0.88282E-09    0.10000E+01    0.52449E+05    0.66035E-54    0.14632E-64    0.98963E-63
+    1    1    0.88282E-09    0.10000E+01    0.42297E+05    0.49567E-53    0.19615E-63    0.74065E-62
+    1    1    0.88282E-09    0.10000E+01    0.34111E+05    0.35353E-52    0.25848E-62    0.52675E-61
+    1    1    0.88282E-09    0.10000E+01    0.27509E+05    0.24558E-51    0.32187E-61    0.36567E-60
+    1    1    0.88282E-09    0.10000E+01    0.22184E+05    0.16393E-50    0.40073E-60    0.24273E-59
+    1    1    0.88282E-09    0.10000E+01    0.17891E+05    0.10961E-49    0.65251E-59    0.15348E-58
+    1    1    0.88282E-09    0.10000E+01    0.14428E+05    0.89454E-49    0.16244E-57    0.10392E-57
+    1    1    0.88282E-09    0.10000E+01    0.11635E+05    0.10618E-47    0.47991E-56    0.98632E-57
+    1    1    0.88282E-09    0.10000E+01    0.93834E+04    0.15701E-46    0.14156E-54    0.13418E-55
+    1    1    0.88282E-09    0.10000E+01    0.75673E+04    0.24062E-45    0.40636E-53    0.20503E-54
+    1    1    0.88282E-09    0.10000E+01    0.61026E+04    0.36255E-44    0.11442E-51    0.31177E-53
+    1    1    0.88282E-09    0.10000E+01    0.49215E+04    0.53641E-43    0.31845E-50    0.46407E-52
+    1    1    0.88282E-09    0.10000E+01    0.39689E+04    0.78393E-42    0.87953E-49    0.68035E-51
+    1    1    0.88282E-09    0.10000E+01    0.32008E+04    0.35759E-39    0.78214E-46    0.31094E-48
+    1    1    0.88282E-09    0.10000E+01    0.25813E+04    0.26899E-30    0.13461E-36    0.23432E-39
+    1    1    0.88282E-09    0.10000E+01    0.20817E+04    0.52599E-14    0.11724E-19    0.45928E-23
+    1    1    0.88282E-09    0.10000E+01    0.16788E+04    0.18083E-08    0.17491E-13    0.15815E-17
+    1    1    0.88282E-09    0.10000E+01    0.13538E+04    0.39044E-08    0.66538E-13    0.34162E-17
+    1    1    0.88282E-09    0.10000E+01    0.10918E+04    0.82318E-08    0.24829E-12    0.72050E-17
+    1    1    0.88282E-09    0.10000E+01    0.88049E+03    0.16966E-07    0.91446E-12    0.14853E-16
+    1    1    0.88282E-09    0.10000E+01    0.71007E+03    0.34263E-07    0.33303E-11    0.30001E-16
+    1    1    0.88282E-09    0.10000E+01    0.57264E+03    0.67988E-07    0.11849E-10    0.59535E-16
+    1    1    0.88282E-09    0.10000E+01    0.46180E+03    0.13266E-06    0.39851E-10    0.11617E-15
+    1    1    0.88282E-09    0.10000E+01    0.37242E+03    0.25331E-06    0.12151E-09    0.22183E-15
+    1    1    0.88282E-09    0.10000E+01    0.30034E+03    0.46799E-06    0.32591E-09    0.40983E-15
+    1    1    0.88282E-09    0.10000E+01    0.24221E+03    0.82463E-06    0.76096E-09    0.72214E-15
+    1    1    0.88282E-09    0.10000E+01    0.19533E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    1    1    0.88282E-09    0.10000E+01    0.15752E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    1    1    0.15405E-08    0.10000E+01    0.80645E+05    0.22169E-55    0.16538E-66    0.19444E-63
+    1    1    0.15405E-08    0.10000E+01    0.65036E+05    0.18709E-54    0.26199E-65    0.16386E-62
+    1    1    0.15405E-08    0.10000E+01    0.52449E+05    0.15857E-53    0.34936E-64    0.13874E-61
+    1    1    0.15405E-08    0.10000E+01    0.42297E+05    0.11856E-52    0.46757E-63    0.10359E-60
+    1    1    0.15405E-08    0.10000E+01    0.34111E+05    0.84435E-52    0.62479E-62    0.73632E-60
+    1    1    0.15405E-08    0.10000E+01    0.27509E+05    0.59246E-51    0.81019E-61    0.51534E-59
+    1    1    0.15405E-08    0.10000E+01    0.22184E+05    0.40692E-50    0.10307E-59    0.35092E-58
+    1    1    0.15405E-08    0.10000E+01    0.17891E+05    0.27534E-49    0.14075E-58    0.22768E-57
+    1    1    0.15405E-08    0.10000E+01    0.14428E+05    0.19631E-48    0.24555E-57    0.13888E-56
+    1    1    0.15405E-08    0.10000E+01    0.11635E+05    0.17070E-47    0.57662E-56    0.81553E-56
+    1    1    0.15405E-08    0.10000E+01    0.93834E+04    0.19685E-46    0.15733E-54    0.52856E-55
+    1    1    0.15405E-08    0.10000E+01    0.75673E+04    0.27170E-45    0.44125E-53    0.48422E-54
+    1    1    0.15405E-08    0.10000E+01    0.61026E+04    0.39529E-44    0.12261E-51    0.62492E-53
+    1    1    0.15405E-08    0.10000E+01    0.49215E+04    0.57536E-43    0.33698E-50    0.90174E-52
+    1    1    0.15405E-08    0.10000E+01    0.39689E+04    0.83012E-42    0.92000E-49    0.13001E-50
+    1    1    0.15405E-08    0.10000E+01    0.32008E+04    0.37425E-39    0.80984E-46    0.58076E-48
+    1    1    0.15405E-08    0.10000E+01    0.25813E+04    0.27849E-30    0.13803E-36    0.42644E-39
+    1    1    0.15405E-08    0.10000E+01    0.20817E+04    0.53875E-14    0.11903E-19    0.81441E-23
+    1    1    0.15405E-08    0.10000E+01    0.16788E+04    0.18406E-08    0.17690E-13    0.27668E-17
+    1    1    0.15405E-08    0.10000E+01    0.13538E+04    0.39646E-08    0.67251E-13    0.59320E-17
+    1    1    0.15405E-08    0.10000E+01    0.10918E+04    0.83445E-08    0.25085E-12    0.12448E-16
+    1    1    0.15405E-08    0.10000E+01    0.88049E+03    0.17177E-07    0.92365E-12    0.25570E-16
+    1    1    0.15405E-08    0.10000E+01    0.71007E+03    0.34659E-07    0.33633E-11    0.51512E-16
+    1    1    0.15405E-08    0.10000E+01    0.57264E+03    0.68732E-07    0.11965E-10    0.10202E-15
+    1    1    0.15405E-08    0.10000E+01    0.46180E+03    0.13405E-06    0.40239E-10    0.19877E-15
+    1    1    0.15405E-08    0.10000E+01    0.37242E+03    0.25590E-06    0.12269E-09    0.37913E-15
+    1    1    0.15405E-08    0.10000E+01    0.30034E+03    0.47270E-06    0.32907E-09    0.69988E-15
+    1    1    0.15405E-08    0.10000E+01    0.24221E+03    0.83283E-06    0.76833E-09    0.12325E-14
+    1    1    0.15405E-08    0.10000E+01    0.19533E+03    0.13126E-05    0.14601E-08    0.19419E-14
+    1    1    0.15405E-08    0.10000E+01    0.15752E+03    0.13126E-05    0.14601E-08    0.19419E-14
+    1    1    0.26880E-08    0.10000E+01    0.80645E+05    0.44147E-55    0.32899E-66    0.76539E-63
+    1    1    0.26880E-08    0.10000E+01    0.65036E+05    0.37227E-54    0.52097E-65    0.64519E-62
+    1    1    0.26880E-08    0.10000E+01    0.52449E+05    0.31535E-53    0.69411E-64    0.54648E-61
+    1    1    0.26880E-08    0.10000E+01    0.42297E+05    0.23562E-52    0.92815E-63    0.40832E-60
+    1    1    0.26880E-08    0.10000E+01    0.34111E+05    0.16767E-51    0.12398E-61    0.29071E-59
+    1    1    0.26880E-08    0.10000E+01    0.27509E+05    0.11758E-50    0.16033E-60    0.20417E-58
+    1    1    0.26880E-08    0.10000E+01    0.22184E+05    0.80503E-50    0.19916E-59    0.14006E-57
+    1    1    0.26880E-08    0.10000E+01    0.17891E+05    0.53362E-49    0.24604E-58    0.92169E-57
+    1    1    0.26880E-08    0.10000E+01    0.14428E+05    0.35072E-48    0.34415E-57    0.57325E-56
+    1    1    0.26880E-08    0.10000E+01    0.11635E+05    0.25233E-47    0.64825E-56    0.33641E-55
+    1    1    0.26880E-08    0.10000E+01    0.93834E+04    0.23294E-46    0.16099E-54    0.19548E-54
+    1    1    0.26880E-08    0.10000E+01    0.75673E+04    0.28462E-45    0.44413E-53    0.13553E-53
+    1    1    0.26880E-08    0.10000E+01    0.61026E+04    0.40026E-44    0.12346E-51    0.13880E-52
+    1    1    0.26880E-08    0.10000E+01    0.49215E+04    0.57964E-43    0.33900E-50    0.18524E-51
+    1    1    0.26880E-08    0.10000E+01    0.39689E+04    0.83490E-42    0.92262E-49    0.26049E-50
+    1    1    0.26880E-08    0.10000E+01    0.32008E+04    0.37529E-39    0.80913E-46    0.11368E-47
+    1    1    0.26880E-08    0.10000E+01    0.25813E+04    0.27821E-30    0.13740E-36    0.81010E-39
+    1    1    0.26880E-08    0.10000E+01    0.20817E+04    0.53615E-14    0.11804E-19    0.14934E-22
+    1    1    0.26880E-08    0.10000E+01    0.16788E+04    0.18283E-08    0.17519E-13    0.49687E-17
+    1    1    0.26880E-08    0.10000E+01    0.13538E+04    0.39332E-08    0.66577E-13    0.10530E-16
+    1    1    0.26880E-08    0.10000E+01    0.10918E+04    0.82717E-08    0.24827E-12    0.21919E-16
+    1    1    0.26880E-08    0.10000E+01    0.88049E+03    0.17018E-07    0.91395E-12    0.44767E-16
+    1    1    0.26880E-08    0.10000E+01    0.71007E+03    0.34323E-07    0.33274E-11    0.89807E-16
+    1    1    0.26880E-08    0.10000E+01    0.57264E+03    0.68044E-07    0.11836E-10    0.17732E-15
+    1    1    0.26880E-08    0.10000E+01    0.46180E+03    0.13268E-06    0.39802E-10    0.34468E-15
+    1    1    0.26880E-08    0.10000E+01    0.37242E+03    0.25323E-06    0.12135E-09    0.65633E-15
+    1    1    0.26880E-08    0.10000E+01    0.30034E+03    0.46768E-06    0.32547E-09    0.12102E-14
+    1    1    0.26880E-08    0.10000E+01    0.24221E+03    0.82391E-06    0.75991E-09    0.21294E-14
+    1    1    0.26880E-08    0.10000E+01    0.19533E+03    0.12984E-05    0.14440E-08    0.33534E-14
+    1    1    0.26880E-08    0.10000E+01    0.15752E+03    0.12984E-05    0.14440E-08    0.33534E-14
+    1    1    0.46905E-08    0.10000E+01    0.80645E+05    0.84914E-55    0.63264E-66    0.25137E-62
+    1    1    0.46905E-08    0.10000E+01    0.65036E+05    0.71591E-54    0.10018E-64    0.21198E-61
+    1    1    0.46905E-08    0.10000E+01    0.52449E+05    0.60640E-53    0.13347E-63    0.17961E-60
+    1    1    0.46905E-08    0.10000E+01    0.42297E+05    0.45308E-52    0.17852E-62    0.13429E-59
+    1    1    0.46905E-08    0.10000E+01    0.34111E+05    0.32249E-51    0.23870E-61    0.95741E-59
+    1    1    0.46905E-08    0.10000E+01    0.27509E+05    0.22631E-50    0.30904E-60    0.67413E-58
+    1    1    0.46905E-08    0.10000E+01    0.22184E+05    0.15505E-49    0.38168E-59    0.46473E-57
+    1    1    0.46905E-08    0.10000E+01    0.17891E+05    0.10224E-48    0.45256E-58    0.30863E-56
+    1    1    0.46905E-08    0.10000E+01    0.14428E+05    0.65022E-48    0.55190E-57    0.19482E-55
+    1    1    0.46905E-08    0.10000E+01    0.11635E+05    0.41896E-47    0.82401E-56    0.11604E-54
+    1    1    0.46905E-08    0.10000E+01    0.93834E+04    0.31427E-46    0.17362E-54    0.66133E-54
+    1    1    0.46905E-08    0.10000E+01    0.75673E+04    0.31973E-45    0.45741E-53    0.40197E-53
+    1    1    0.46905E-08    0.10000E+01    0.61026E+04    0.41790E-44    0.12665E-51    0.33476E-52
+    1    1    0.46905E-08    0.10000E+01    0.49215E+04    0.59589E-43    0.34720E-50    0.40051E-51
+    1    1    0.46905E-08    0.10000E+01    0.39689E+04    0.85492E-42    0.94020E-49    0.54427E-50
+    1    1    0.46905E-08    0.10000E+01    0.32008E+04    0.38237E-39    0.81918E-46    0.23194E-47
+    1    1    0.46905E-08    0.10000E+01    0.25813E+04    0.28156E-30    0.13815E-36    0.15995E-38
+    1    1    0.46905E-08    0.10000E+01    0.20817E+04    0.53870E-14    0.11779E-19    0.28225E-22
+    1    1    0.46905E-08    0.10000E+01    0.16788E+04    0.18300E-08    0.17429E-13    0.91273E-17
+    1    1    0.46905E-08    0.10000E+01    0.13538E+04    0.39273E-08    0.66194E-13    0.19016E-16
+    1    1    0.46905E-08    0.10000E+01    0.10918E+04    0.82460E-08    0.24672E-12    0.39111E-16
+    1    1    0.46905E-08    0.10000E+01    0.88049E+03    0.16945E-07    0.90786E-12    0.79187E-16
+    1    1    0.46905E-08    0.10000E+01    0.71007E+03    0.34149E-07    0.33042E-11    0.15784E-15
+    1    1    0.46905E-08    0.10000E+01    0.57264E+03    0.67655E-07    0.11751E-10    0.31017E-15
+    1    1    0.46905E-08    0.10000E+01    0.46180E+03    0.13185E-06    0.39511E-10    0.60081E-15
+    1    1    0.46905E-08    0.10000E+01    0.37242E+03    0.25157E-06    0.12045E-09    0.11411E-14
+    1    1    0.46905E-08    0.10000E+01    0.30034E+03    0.46449E-06    0.32304E-09    0.21003E-14
+    1    1    0.46905E-08    0.10000E+01    0.24221E+03    0.81813E-06    0.75423E-09    0.36911E-14
+    1    1    0.46905E-08    0.10000E+01    0.19533E+03    0.12892E-05    0.14332E-08    0.58084E-14
+    1    1    0.46905E-08    0.10000E+01    0.15752E+03    0.12892E-05    0.14332E-08    0.58084E-14
+    1    1    0.81846E-08    0.10000E+01    0.80645E+05    0.16157E-54    0.12039E-65    0.81777E-62
+    1    1    0.81846E-08    0.10000E+01    0.65036E+05    0.13624E-53    0.19067E-64    0.68988E-61
+    1    1    0.81846E-08    0.10000E+01    0.52449E+05    0.11542E-52    0.25416E-63    0.58475E-60
+    1    1    0.81846E-08    0.10000E+01    0.42297E+05    0.86267E-52    0.34029E-62    0.43752E-59
+    1    1    0.81846E-08    0.10000E+01    0.34111E+05    0.61456E-51    0.45595E-61    0.31234E-58
+    1    1    0.81846E-08    0.10000E+01    0.27509E+05    0.43204E-50    0.59265E-60    0.22044E-57
+    1    1    0.81846E-08    0.10000E+01    0.22184E+05    0.29695E-49    0.73515E-59    0.15261E-56
+    1    1    0.81846E-08    0.10000E+01    0.17891E+05    0.19647E-48    0.86568E-58    0.10213E-55
+    1    1    0.81846E-08    0.10000E+01    0.14428E+05    0.12425E-47    0.99469E-57    0.65308E-55
+    1    1    0.81846E-08    0.10000E+01    0.11635E+05    0.76467E-47    0.12439E-55    0.39573E-54
+    1    1    0.81846E-08    0.10000E+01    0.93834E+04    0.49731E-46    0.20939E-54    0.22686E-53
+    1    1    0.81846E-08    0.10000E+01    0.75673E+04    0.40864E-45    0.49634E-53    0.12961E-52
+    1    1    0.81846E-08    0.10000E+01    0.61026E+04    0.46629E-44    0.13469E-51    0.90893E-52
+    1    1    0.81846E-08    0.10000E+01    0.49215E+04    0.63787E-43    0.36725E-50    0.94409E-51
+    1    1    0.81846E-08    0.10000E+01    0.39689E+04    0.90467E-42    0.98534E-49    0.12204E-49
+    1    1    0.81846E-08    0.10000E+01    0.32008E+04    0.40062E-39    0.84797E-46    0.50685E-47
+    1    1    0.81846E-08    0.10000E+01    0.25813E+04    0.29122E-30    0.14099E-36    0.33706E-38
+    1    1    0.81846E-08    0.10000E+01    0.20817E+04    0.54889E-14    0.11826E-19    0.56261E-22
+    1    1    0.81846E-08    0.10000E+01    0.16788E+04    0.18486E-08    0.17379E-13    0.17469E-16
+    1    1    0.81846E-08    0.10000E+01    0.13538E+04    0.39471E-08    0.65916E-13    0.35430E-16
+    1    1    0.81846E-08    0.10000E+01    0.10918E+04    0.82589E-08    0.24542E-12    0.71449E-16
+    1    1    0.81846E-08    0.10000E+01    0.88049E+03    0.16930E-07    0.90241E-12    0.14257E-15
+    1    1    0.81846E-08    0.10000E+01    0.71007E+03    0.34057E-07    0.32825E-11    0.28110E-15
+    1    1    0.81846E-08    0.10000E+01    0.57264E+03    0.67383E-07    0.11669E-10    0.54787E-15
+    1    1    0.81846E-08    0.10000E+01    0.46180E+03    0.13119E-06    0.39227E-10    0.10548E-14
+    1    1    0.81846E-08    0.10000E+01    0.37242E+03    0.25012E-06    0.11957E-09    0.19945E-14
+    1    1    0.81846E-08    0.10000E+01    0.30034E+03    0.46158E-06    0.32064E-09    0.36593E-14
+    1    1    0.81846E-08    0.10000E+01    0.24221E+03    0.81272E-06    0.74859E-09    0.64172E-14
+    1    1    0.81846E-08    0.10000E+01    0.19533E+03    0.12804E-05    0.14225E-08    0.10085E-13
+    1    1    0.81846E-08    0.10000E+01    0.15752E+03    0.12804E-05    0.14225E-08    0.10085E-13
+    1    1    0.14282E-07    0.10000E+01    0.80645E+05    0.30442E-54    0.22691E-65    0.26444E-61
+    1    1    0.14282E-07    0.10000E+01    0.65036E+05    0.25675E-53    0.35946E-64    0.22317E-60
+    1    1    0.14282E-07    0.10000E+01    0.52449E+05    0.21757E-52    0.47947E-63    0.18923E-59
+    1    1    0.14282E-07    0.10000E+01    0.42297E+05    0.16272E-51    0.64280E-62    0.14168E-58
+    1    1    0.14282E-07    0.10000E+01    0.34111E+05    0.11605E-50    0.86337E-61    0.10127E-57
+    1    1    0.14282E-07    0.10000E+01    0.27509E+05    0.81753E-50    0.11274E-59    0.71622E-57
+    1    1    0.14282E-07    0.10000E+01    0.22184E+05    0.56408E-49    0.14089E-58    0.49766E-56
+    1    1    0.14282E-07    0.10000E+01    0.17891E+05    0.37546E-48    0.16701E-57    0.33521E-55
+    1    1    0.14282E-07    0.10000E+01    0.14428E+05    0.23872E-47    0.18921E-56    0.21667E-54
+    1    1    0.14282E-07    0.10000E+01    0.11635E+05    0.14540E-46    0.21527E-55    0.13338E-53
+    1    1    0.14282E-07    0.10000E+01    0.93834E+04    0.88067E-46    0.29254E-54    0.77578E-53
+    1    1    0.14282E-07    0.10000E+01    0.75673E+04    0.60553E-45    0.58326E-53    0.43430E-52
+    1    1    0.14282E-07    0.10000E+01    0.61026E+04    0.57349E-44    0.15051E-51    0.27098E-51
+    1    1    0.14282E-07    0.10000E+01    0.49215E+04    0.72317E-43    0.40568E-50    0.24252E-50
+    1    1    0.14282E-07    0.10000E+01    0.39689E+04    0.10013E-41    0.10738E-48    0.29366E-49
+    1    1    0.14282E-07    0.10000E+01    0.32008E+04    0.43649E-39    0.90644E-46    0.11889E-46
+    1    1    0.14282E-07    0.10000E+01    0.25813E+04    0.31082E-30    0.14709E-36    0.76420E-38
+    1    1    0.14282E-07    0.10000E+01    0.20817E+04    0.57088E-14    0.11967E-19    0.12009E-21
+    1    1    0.14282E-07    0.10000E+01    0.16788E+04    0.18924E-08    0.17356E-13    0.35443E-16
+    1    1    0.14282E-07    0.10000E+01    0.13538E+04    0.40020E-08    0.65652E-13    0.69167E-16
+    1    1    0.14282E-07    0.10000E+01    0.10918E+04    0.83184E-08    0.24397E-12    0.13540E-15
+    1    1    0.14282E-07    0.10000E+01    0.88049E+03    0.16972E-07    0.89579E-12    0.26406E-15
+    1    1    0.14282E-07    0.10000E+01    0.71007E+03    0.34023E-07    0.32552E-11    0.51154E-15
+    1    1    0.14282E-07    0.10000E+01    0.57264E+03    0.67146E-07    0.11564E-10    0.98359E-15
+    1    1    0.14282E-07    0.10000E+01    0.46180E+03    0.13048E-06    0.38856E-10    0.18743E-14
+    1    1    0.14282E-07    0.10000E+01    0.37242E+03    0.24843E-06    0.11841E-09    0.35173E-14
+    1    1    0.14282E-07    0.10000E+01    0.30034E+03    0.45802E-06    0.31748E-09    0.64185E-14
+    1    1    0.14282E-07    0.10000E+01    0.24221E+03    0.80590E-06    0.74114E-09    0.11214E-13
+    1    1    0.14282E-07    0.10000E+01    0.19533E+03    0.12691E-05    0.14082E-08    0.17584E-13
+    1    1    0.14282E-07    0.10000E+01    0.15752E+03    0.12691E-05    0.14082E-08    0.17584E-13
+    1    1    0.24920E-07    0.10000E+01    0.80645E+05    0.56799E-54    0.42354E-65    0.84609E-61
+    1    1    0.24920E-07    0.10000E+01    0.65036E+05    0.47921E-53    0.67115E-64    0.71433E-60
+    1    1    0.24920E-07    0.10000E+01    0.52449E+05    0.40621E-52    0.89589E-63    0.60589E-59
+    1    1    0.24920E-07    0.10000E+01    0.42297E+05    0.30398E-51    0.12027E-61    0.45392E-58
+    1    1    0.24920E-07    0.10000E+01    0.34111E+05    0.21705E-50    0.16193E-60    0.32479E-57
+    1    1    0.24920E-07    0.10000E+01    0.27509E+05    0.15323E-49    0.21238E-59    0.23013E-56
+    1    1    0.24920E-07    0.10000E+01    0.22184E+05    0.10612E-48    0.26744E-58    0.16041E-55
+    1    1    0.24920E-07    0.10000E+01    0.17891E+05    0.71084E-48    0.32040E-57    0.10863E-54
+    1    1    0.24920E-07    0.10000E+01    0.14428E+05    0.45587E-47    0.36499E-56    0.70834E-54
+    1    1    0.24920E-07    0.10000E+01    0.11635E+05    0.27903E-46    0.40136E-55    0.44191E-53
+    1    1    0.24920E-07    0.10000E+01    0.93834E+04    0.16495E-45    0.47141E-54    0.26116E-52
+    1    1    0.24920E-07    0.10000E+01    0.75673E+04    0.10159E-44    0.76552E-53    0.14621E-51
+    1    1    0.24920E-07    0.10000E+01    0.61026E+04    0.79681E-44    0.18024E-51    0.85225E-51
+    1    1    0.24920E-07    0.10000E+01    0.49215E+04    0.88844E-43    0.47589E-50    0.66813E-50
+    1    1    0.24920E-07    0.10000E+01    0.39689E+04    0.11805E-41    0.12392E-48    0.74971E-49
+    1    1    0.24920E-07    0.10000E+01    0.32008E+04    0.50367E-39    0.10197E-45    0.29630E-46
+    1    1    0.24920E-07    0.10000E+01    0.25813E+04    0.34881E-30    0.15962E-36    0.18551E-37
+    1    1    0.24920E-07    0.10000E+01    0.20817E+04    0.61657E-14    0.12352E-19    0.27613E-21
+    1    1    0.24920E-07    0.10000E+01    0.16788E+04    0.19921E-08    0.17496E-13    0.77232E-16
+    1    1    0.24920E-07    0.10000E+01    0.13538E+04    0.41442E-08    0.65869E-13    0.14362E-15
+    1    1    0.24920E-07    0.10000E+01    0.10918E+04    0.85146E-08    0.24393E-12    0.27015E-15
+    1    1    0.24920E-07    0.10000E+01    0.88049E+03    0.17227E-07    0.89340E-12    0.50995E-15
+    1    1    0.24920E-07    0.10000E+01    0.71007E+03    0.34324E-07    0.32407E-11    0.96220E-15
+    1    1    0.24920E-07    0.10000E+01    0.57264E+03    0.67430E-07    0.11499E-10    0.18117E-14
+    1    1    0.24920E-07    0.10000E+01    0.46180E+03    0.13060E-06    0.38609E-10    0.33962E-14
+    1    1    0.24920E-07    0.10000E+01    0.37242E+03    0.24803E-06    0.11760E-09    0.62949E-14
+    1    1    0.24920E-07    0.10000E+01    0.30034E+03    0.45649E-06    0.31523E-09    0.11385E-13
+    1    1    0.24920E-07    0.10000E+01    0.24221E+03    0.80227E-06    0.73576E-09    0.19769E-13
+    1    1    0.24920E-07    0.10000E+01    0.19533E+03    0.12625E-05    0.13979E-08    0.30878E-13
+    1    1    0.24920E-07    0.10000E+01    0.15752E+03    0.12625E-05    0.13979E-08    0.30878E-13
+    1    1    0.43485E-07    0.10000E+01    0.80645E+05    0.10510E-53    0.78406E-65    0.26954E-60
+    1    1    0.43485E-07    0.10000E+01    0.65036E+05    0.88705E-53    0.12428E-63    0.22764E-59
+    1    1    0.43485E-07    0.10000E+01    0.52449E+05    0.75217E-52    0.16602E-62    0.19314E-58
+    1    1    0.43485E-07    0.10000E+01    0.42297E+05    0.56321E-51    0.22317E-61    0.14477E-57
+    1    1    0.43485E-07    0.10000E+01    0.34111E+05    0.40259E-50    0.30113E-60    0.10369E-56
+    1    1    0.43485E-07    0.10000E+01    0.27509E+05    0.28477E-49    0.39653E-59    0.73588E-56
+    1    1    0.43485E-07    0.10000E+01    0.22184E+05    0.19790E-48    0.50282E-58    0.51431E-55
+    1    1    0.43485E-07    0.10000E+01    0.17891E+05    0.13334E-47    0.60891E-57    0.34986E-54
+    1    1    0.43485E-07    0.10000E+01    0.14428E+05    0.86274E-47    0.70205E-56    0.22981E-53
+    1    1    0.43485E-07    0.10000E+01    0.11635E+05    0.53336E-46    0.76941E-55    0.14498E-52
+    1    1    0.43485E-07    0.10000E+01    0.93834E+04    0.31489E-45    0.83738E-54    0.86955E-52
+    1    1    0.43485E-07    0.10000E+01    0.75673E+04    0.18378E-44    0.11296E-52    0.49107E-51
+    1    1    0.43485E-07    0.10000E+01    0.61026E+04    0.12414E-43    0.23332E-51    0.27625E-50
+    1    1    0.43485E-07    0.10000E+01    0.49215E+04    0.11934E-42    0.59575E-50    0.19471E-49
+    1    1    0.43485E-07    0.10000E+01    0.39689E+04    0.14919E-41    0.15251E-48    0.20142E-48
+    1    1    0.43485E-07    0.10000E+01    0.32008E+04    0.62017E-39    0.12195E-45    0.77746E-46
+    1    1    0.43485E-07    0.10000E+01    0.25813E+04    0.41582E-30    0.18220E-36    0.47847E-37
+    1    1    0.43485E-07    0.10000E+01    0.20817E+04    0.69929E-14    0.13076E-19    0.68378E-21
+    1    1    0.43485E-07    0.10000E+01    0.16788E+04    0.21769E-08    0.17804E-13    0.18225E-15
+    1    1    0.43485E-07    0.10000E+01    0.13538E+04    0.44115E-08    0.66480E-13    0.32148E-15
+    1    1    0.43485E-07    0.10000E+01    0.10918E+04    0.88927E-08    0.24471E-12    0.57669E-15
+    1    1    0.43485E-07    0.10000E+01    0.88049E+03    0.17741E-07    0.89234E-12    0.10440E-14
+    1    1    0.43485E-07    0.10000E+01    0.71007E+03    0.34977E-07    0.32269E-11    0.19002E-14
+    1    1    0.43485E-07    0.10000E+01    0.57264E+03    0.68173E-07    0.11426E-10    0.34708E-14
+    1    1    0.43485E-07    0.10000E+01    0.46180E+03    0.13126E-06    0.38313E-10    0.63469E-14
+    1    1    0.43485E-07    0.10000E+01    0.37242E+03    0.24822E-06    0.11661E-09    0.11538E-13
+    1    1    0.43485E-07    0.10000E+01    0.30034E+03    0.45546E-06    0.31243E-09    0.20569E-13
+    1    1    0.43485E-07    0.10000E+01    0.24221E+03    0.79881E-06    0.72902E-09    0.35353E-13
+    1    1    0.43485E-07    0.10000E+01    0.19533E+03    0.12554E-05    0.13849E-08    0.54870E-13
+    1    1    0.43485E-07    0.10000E+01    0.15752E+03    0.12554E-05    0.13849E-08    0.54870E-13
+    1    1    0.75878E-07    0.10000E+01    0.80645E+05    0.19293E-53    0.14399E-64    0.85056E-60
+    1    1    0.75878E-07    0.10000E+01    0.65036E+05    0.16289E-52    0.22830E-63    0.71854E-59
+    1    1    0.75878E-07    0.10000E+01    0.52449E+05    0.13816E-51    0.30518E-62    0.60980E-58
+    1    1    0.75878E-07    0.10000E+01    0.42297E+05    0.10351E-50    0.41074E-61    0.45730E-57
+    1    1    0.75878E-07    0.10000E+01    0.34111E+05    0.74069E-50    0.55532E-60    0.32780E-56
+    1    1    0.75878E-07    0.10000E+01    0.27509E+05    0.52484E-49    0.73379E-59    0.23296E-55
+    1    1    0.75878E-07    0.10000E+01    0.22184E+05    0.36584E-48    0.93610E-58    0.16319E-54
+    1    1    0.75878E-07    0.10000E+01    0.17891E+05    0.24774E-47    0.11445E-56    0.11143E-53
+    1    1    0.75878E-07    0.10000E+01    0.14428E+05    0.16158E-46    0.13367E-55    0.73631E-53
+    1    1    0.75878E-07    0.10000E+01    0.11635E+05    0.10097E-45    0.14784E-54    0.46877E-52
+    1    1    0.75878E-07    0.10000E+01    0.93834E+04    0.60091E-45    0.15625E-53    0.28479E-51
+    1    1    0.75878E-07    0.10000E+01    0.75673E+04    0.34403E-44    0.18447E-52    0.16269E-50
+    1    1    0.75878E-07    0.10000E+01    0.61026E+04    0.21087E-43    0.32835E-51    0.90097E-50
+    1    1    0.75878E-07    0.10000E+01    0.49215E+04    0.17543E-42    0.79923E-50    0.58681E-49
+    1    1    0.75878E-07    0.10000E+01    0.39689E+04    0.20309E-41    0.20144E-48    0.56056E-48
+    1    1    0.75878E-07    0.10000E+01    0.32008E+04    0.82056E-39    0.15688E-45    0.21124E-45
+    1    1    0.75878E-07    0.10000E+01    0.25813E+04    0.53309E-30    0.22263E-36    0.12883E-36
+    1    1    0.75878E-07    0.10000E+01    0.20817E+04    0.84860E-14    0.14460E-19    0.17965E-20
+    1    1    0.75878E-07    0.10000E+01    0.16788E+04    0.25209E-08    0.18518E-13    0.46195E-15
+    1    1    0.75878E-07    0.10000E+01    0.13538E+04    0.49208E-08    0.68214E-13    0.77574E-15
+    1    1    0.75878E-07    0.10000E+01    0.10918E+04    0.96387E-08    0.24856E-12    0.13259E-14
+    1    1    0.75878E-07    0.10000E+01    0.88049E+03    0.18811E-07    0.89969E-12    0.22918E-14
+    1    1    0.75878E-07    0.10000E+01    0.71007E+03    0.36464E-07    0.32364E-11    0.39946E-14
+    1    1    0.75878E-07    0.10000E+01    0.57264E+03    0.70156E-07    0.11419E-10    0.70160E-14
+    1    1    0.75878E-07    0.10000E+01    0.46180E+03    0.13376E-06    0.38203E-10    0.12400E-13
+    1    1    0.75878E-07    0.10000E+01    0.37242E+03    0.25111E-06    0.11612E-09    0.21917E-13
+    1    1    0.75878E-07    0.10000E+01    0.30034E+03    0.45840E-06    0.31085E-09    0.38230E-13
+    1    1    0.75878E-07    0.10000E+01    0.24221E+03    0.80111E-06    0.72499E-09    0.64669E-13
+    1    1    0.75878E-07    0.10000E+01    0.19533E+03    0.12563E-05    0.13768E-08    0.99357E-13
+    1    1    0.75878E-07    0.10000E+01    0.15752E+03    0.12563E-05    0.13768E-08    0.99357E-13
+    1    1    0.13240E-06    0.10000E+01    0.80645E+05    0.35149E-53    0.26243E-64    0.26493E-59
+    1    1    0.13240E-06    0.10000E+01    0.65036E+05    0.29686E-52    0.41619E-63    0.22387E-58
+    1    1    0.13240E-06    0.10000E+01    0.52449E+05    0.25186E-51    0.55670E-62    0.19003E-57
+    1    1    0.13240E-06    0.10000E+01    0.42297E+05    0.18879E-50    0.75005E-61    0.14256E-56
+    1    1    0.13240E-06    0.10000E+01    0.34111E+05    0.13522E-49    0.10159E-59    0.10226E-55
+    1    1    0.13240E-06    0.10000E+01    0.27509E+05    0.95960E-49    0.13464E-58    0.72760E-55
+    1    1    0.13240E-06    0.10000E+01    0.22184E+05    0.67063E-48    0.17264E-57    0.51065E-54
+    1    1    0.13240E-06    0.10000E+01    0.17891E+05    0.45613E-47    0.21282E-56    0.34977E-53
+    1    1    0.13240E-06    0.10000E+01    0.14428E+05    0.29957E-46    0.25150E-55    0.23226E-52
+    1    1    0.13240E-06    0.10000E+01    0.11635E+05    0.18905E-45    0.28182E-54    0.14896E-51
+    1    1    0.13240E-06    0.10000E+01    0.93834E+04    0.11374E-44    0.29637E-53    0.91462E-51
+    1    1    0.13240E-06    0.10000E+01    0.75673E+04    0.64991E-44    0.32234E-52    0.52854E-50
+    1    1    0.13240E-06    0.10000E+01    0.61026E+04    0.37686E-43    0.49738E-51    0.29128E-49
+    1    1    0.13240E-06    0.10000E+01    0.49215E+04    0.27755E-42    0.11389E-49    0.17945E-48
+    1    1    0.13240E-06    0.10000E+01    0.39689E+04    0.29504E-41    0.28323E-48    0.15939E-47
+    1    1    0.13240E-06    0.10000E+01    0.32008E+04    0.11576E-38    0.21621E-45    0.58612E-45
+    1    1    0.13240E-06    0.10000E+01    0.25813E+04    0.73259E-30    0.29238E-36    0.35614E-36
+    1    1    0.13240E-06    0.10000E+01    0.20817E+04    0.11079E-13    0.16893E-19    0.49130E-20
+    1    1    0.13240E-06    0.10000E+01    0.16788E+04    0.31279E-08    0.19813E-13    0.12354E-14
+    1    1    0.13240E-06    0.10000E+01    0.13538E+04    0.58205E-08    0.71440E-13    0.19932E-14
+    1    1    0.13240E-06    0.10000E+01    0.10918E+04    0.10963E-07    0.25607E-12    0.32657E-14
+    1    1    0.13240E-06    0.10000E+01    0.88049E+03    0.20725E-07    0.91554E-12    0.54012E-14
+    1    1    0.13240E-06    0.10000E+01    0.71007E+03    0.39159E-07    0.32643E-11    0.90015E-14
+    1    1    0.13240E-06    0.10000E+01    0.57264E+03    0.73823E-07    0.11448E-10    0.15127E-13
+    1    1    0.13240E-06    0.10000E+01    0.46180E+03    0.13853E-06    0.38151E-10    0.25647E-13
+    1    1    0.13240E-06    0.10000E+01    0.37242E+03    0.25699E-06    0.11569E-09    0.43694E-13
+    1    1    0.13240E-06    0.10000E+01    0.30034E+03    0.46510E-06    0.30928E-09    0.73951E-13
+    1    1    0.13240E-06    0.10000E+01    0.24221E+03    0.80796E-06    0.72072E-09    0.12224E-12
+    1    1    0.13240E-06    0.10000E+01    0.19533E+03    0.12624E-05    0.13681E-08    0.18497E-12
+    1    1    0.13240E-06    0.10000E+01    0.15752E+03    0.12624E-05    0.13681E-08    0.18497E-12
+    1    1    0.23103E-06    0.10000E+01    0.80645E+05    0.62184E-53    0.46434E-64    0.57270E-59
+    1    1    0.23103E-06    0.10000E+01    0.65036E+05    0.52524E-52    0.73646E-63    0.48397E-58
+    1    1    0.23103E-06    0.10000E+01    0.52449E+05    0.44567E-51    0.98531E-62    0.41084E-57
+    1    1    0.23103E-06    0.10000E+01    0.42297E+05    0.33413E-50    0.13280E-60    0.30827E-56
+    1    1    0.23103E-06    0.10000E+01    0.34111E+05    0.23939E-49    0.17998E-59    0.22118E-55
+    1    1    0.23103E-06    0.10000E+01    0.27509E+05    0.16998E-48    0.23878E-58    0.15742E-54
+    1    1    0.23103E-06    0.10000E+01    0.22184E+05    0.11890E-47    0.30673E-57    0.11055E-53
+    1    1    0.23103E-06    0.10000E+01    0.17891E+05    0.80993E-47    0.37918E-56    0.75799E-53
+    1    1    0.23103E-06    0.10000E+01    0.14428E+05    0.53319E-46    0.44995E-55    0.50413E-52
+    1    1    0.23103E-06    0.10000E+01    0.11635E+05    0.33767E-45    0.50678E-54    0.32409E-51
+    1    1    0.23103E-06    0.10000E+01    0.93834E+04    0.20402E-44    0.53377E-53    0.19968E-50
+    1    1    0.23103E-06    0.10000E+01    0.75673E+04    0.11677E-43    0.56856E-52    0.11585E-49
+    1    1    0.23103E-06    0.10000E+01    0.61026E+04    0.66804E-43    0.83475E-51    0.63832E-49
+    1    1    0.23103E-06    0.10000E+01    0.49215E+04    0.47306E-42    0.18618E-49    0.38697E-48
+    1    1    0.23103E-06    0.10000E+01    0.39689E+04    0.48639E-41    0.46084E-48    0.33532E-47
+    1    1    0.23103E-06    0.10000E+01    0.32008E+04    0.18868E-38    0.34985E-45    0.12217E-44
+    1    1    0.23103E-06    0.10000E+01    0.25813E+04    0.11844E-29    0.46547E-36    0.74197E-36
+    1    1    0.23103E-06    0.10000E+01    0.20817E+04    0.17609E-13    0.25667E-19    0.10221E-19
+    1    1    0.23103E-06    0.10000E+01    0.16788E+04    0.48777E-08    0.28888E-13    0.25561E-14
+    1    1    0.23103E-06    0.10000E+01    0.13538E+04    0.88944E-08    0.10303E-12    0.40733E-14
+    1    1    0.23103E-06    0.10000E+01    0.10918E+04    0.16460E-07    0.36612E-12    0.65838E-14
+    1    1    0.23103E-06    0.10000E+01    0.88049E+03    0.30655E-07    0.13004E-11    0.10728E-13
+    1    1    0.23103E-06    0.10000E+01    0.71007E+03    0.57200E-07    0.46142E-11    0.17596E-13
+    1    1    0.23103E-06    0.10000E+01    0.57264E+03    0.10673E-06    0.16128E-10    0.29079E-13
+    1    1    0.23103E-06    0.10000E+01    0.46180E+03    0.19864E-06    0.53633E-10    0.48484E-13
+    1    1    0.23103E-06    0.10000E+01    0.37242E+03    0.36616E-06    0.16242E-09    0.81323E-13
+    1    1    0.23103E-06    0.10000E+01    0.30034E+03    0.65958E-06    0.43388E-09    0.13580E-12
+    1    1    0.23103E-06    0.10000E+01    0.24221E+03    0.11421E-05    0.10106E-08    0.22208E-12
+    1    1    0.23103E-06    0.10000E+01    0.19533E+03    0.17808E-05    0.19179E-08    0.33363E-12
+    1    1    0.23103E-06    0.10000E+01    0.15752E+03    0.17808E-05    0.19179E-08    0.33363E-12
+    1    1    0.40314E-06    0.10000E+01    0.80645E+05    0.10851E-52    0.81024E-64    0.99933E-59
+    1    1    0.40314E-06    0.10000E+01    0.65036E+05    0.91650E-52    0.12851E-62    0.84451E-58
+    1    1    0.40314E-06    0.10000E+01    0.52449E+05    0.77767E-51    0.17193E-61    0.71690E-57
+    1    1    0.40314E-06    0.10000E+01    0.42297E+05    0.58304E-50    0.23173E-60    0.53791E-56
+    1    1    0.40314E-06    0.10000E+01    0.34111E+05    0.41772E-49    0.31405E-59    0.38594E-55
+    1    1    0.40314E-06    0.10000E+01    0.27509E+05    0.29661E-48    0.41666E-58    0.27470E-54
+    1    1    0.40314E-06    0.10000E+01    0.22184E+05    0.20747E-47    0.53522E-57    0.19291E-53
+    1    1    0.40314E-06    0.10000E+01    0.17891E+05    0.14133E-46    0.66165E-56    0.13226E-52
+    1    1    0.40314E-06    0.10000E+01    0.14428E+05    0.93039E-46    0.78513E-55    0.87968E-52
+    1    1    0.40314E-06    0.10000E+01    0.11635E+05    0.58921E-45    0.88430E-54    0.56552E-51
+    1    1    0.40314E-06    0.10000E+01    0.93834E+04    0.35600E-44    0.93140E-53    0.34843E-50
+    1    1    0.40314E-06    0.10000E+01    0.75673E+04    0.20375E-43    0.99210E-52    0.20216E-49
+    1    1    0.40314E-06    0.10000E+01    0.61026E+04    0.11657E-42    0.14566E-50    0.11138E-48
+    1    1    0.40314E-06    0.10000E+01    0.49215E+04    0.82547E-42    0.32487E-49    0.67524E-48
+    1    1    0.40314E-06    0.10000E+01    0.39689E+04    0.84872E-41    0.80414E-48    0.58511E-47
+    1    1    0.40314E-06    0.10000E+01    0.32008E+04    0.32923E-38    0.61047E-45    0.21319E-44
+    1    1    0.40314E-06    0.10000E+01    0.25813E+04    0.20668E-29    0.81221E-36    0.12947E-35
+    1    1    0.40314E-06    0.10000E+01    0.20817E+04    0.30727E-13    0.44788E-19    0.17834E-19
+    1    1    0.40314E-06    0.10000E+01    0.16788E+04    0.85112E-08    0.50407E-13    0.44602E-14
+    1    1    0.40314E-06    0.10000E+01    0.13538E+04    0.15520E-07    0.17978E-12    0.71077E-14
+    1    1    0.40314E-06    0.10000E+01    0.10918E+04    0.28723E-07    0.63886E-12    0.11488E-13
+    1    1    0.40314E-06    0.10000E+01    0.88049E+03    0.53491E-07    0.22692E-11    0.18721E-13
+    1    1    0.40314E-06    0.10000E+01    0.71007E+03    0.99810E-07    0.80516E-11    0.30703E-13
+    1    1    0.40314E-06    0.10000E+01    0.57264E+03    0.18623E-06    0.28142E-10    0.50741E-13
+    1    1    0.40314E-06    0.10000E+01    0.46180E+03    0.34661E-06    0.93586E-10    0.84602E-13
+    1    1    0.40314E-06    0.10000E+01    0.37242E+03    0.63892E-06    0.28342E-09    0.14190E-12
+    1    1    0.40314E-06    0.10000E+01    0.30034E+03    0.11509E-05    0.75710E-09    0.23695E-12
+    1    1    0.40314E-06    0.10000E+01    0.24221E+03    0.19928E-05    0.17635E-08    0.38751E-12
+    1    1    0.40314E-06    0.10000E+01    0.19533E+03    0.31074E-05    0.33466E-08    0.58216E-12
+    1    1    0.40314E-06    0.10000E+01    0.15752E+03    0.31074E-05    0.33466E-08    0.58216E-12
+    1    1    0.70346E-06    0.10000E+01    0.80645E+05    0.18934E-52    0.14138E-63    0.17438E-58
+    1    1    0.70346E-06    0.10000E+01    0.65036E+05    0.15992E-51    0.22424E-62    0.14736E-57
+    1    1    0.70346E-06    0.10000E+01    0.52449E+05    0.13570E-50    0.30001E-61    0.12509E-56
+    1    1    0.70346E-06    0.10000E+01    0.42297E+05    0.10174E-49    0.40436E-60    0.93861E-56
+    1    1    0.70346E-06    0.10000E+01    0.34111E+05    0.72889E-49    0.54800E-59    0.67344E-55
+    1    1    0.70346E-06    0.10000E+01    0.27509E+05    0.51756E-48    0.72704E-58    0.47933E-54
+    1    1    0.70346E-06    0.10000E+01    0.22184E+05    0.36203E-47    0.93392E-57    0.33662E-53
+    1    1    0.70346E-06    0.10000E+01    0.17891E+05    0.24661E-46    0.11545E-55    0.23079E-52
+    1    1    0.70346E-06    0.10000E+01    0.14428E+05    0.16235E-45    0.13700E-54    0.15350E-51
+    1    1    0.70346E-06    0.10000E+01    0.11635E+05    0.10281E-44    0.15430E-53    0.98681E-51
+    1    1    0.70346E-06    0.10000E+01    0.93834E+04    0.62119E-44    0.16252E-52    0.60798E-50
+    1    1    0.70346E-06    0.10000E+01    0.75673E+04    0.35554E-43    0.17312E-51    0.35275E-49
+    1    1    0.70346E-06    0.10000E+01    0.61026E+04    0.20340E-42    0.25417E-50    0.19436E-48
+    1    1    0.70346E-06    0.10000E+01    0.49215E+04    0.14404E-41    0.56687E-49    0.11783E-47
+    1    1    0.70346E-06    0.10000E+01    0.39689E+04    0.14810E-40    0.14032E-47    0.10210E-46
+    1    1    0.70346E-06    0.10000E+01    0.32008E+04    0.57449E-38    0.10652E-44    0.37200E-44
+    1    1    0.70346E-06    0.10000E+01    0.25813E+04    0.36064E-29    0.14173E-35    0.22592E-35
+    1    1    0.70346E-06    0.10000E+01    0.20817E+04    0.53617E-13    0.78152E-19    0.31120E-19
+    1    1    0.70346E-06    0.10000E+01    0.16788E+04    0.14852E-07    0.87958E-13    0.77828E-14
+    1    1    0.70346E-06    0.10000E+01    0.13538E+04    0.27082E-07    0.31370E-12    0.12403E-13
+    1    1    0.70346E-06    0.10000E+01    0.10918E+04    0.50119E-07    0.11148E-11    0.20046E-13
+    1    1    0.70346E-06    0.10000E+01    0.88049E+03    0.93338E-07    0.39596E-11    0.32666E-13
+    1    1    0.70346E-06    0.10000E+01    0.71007E+03    0.17416E-06    0.14050E-10    0.53576E-13
+    1    1    0.70346E-06    0.10000E+01    0.57264E+03    0.32497E-06    0.49106E-10    0.88540E-13
+    1    1    0.70346E-06    0.10000E+01    0.46180E+03    0.60481E-06    0.16330E-09    0.14763E-12
+    1    1    0.70346E-06    0.10000E+01    0.37242E+03    0.11149E-05    0.49454E-09    0.24761E-12
+    1    1    0.70346E-06    0.10000E+01    0.30034E+03    0.20083E-05    0.13211E-08    0.41347E-12
+    1    1    0.70346E-06    0.10000E+01    0.24221E+03    0.34773E-05    0.30771E-08    0.67618E-12
+    1    1    0.70346E-06    0.10000E+01    0.19533E+03    0.54222E-05    0.58395E-08    0.10158E-11
+    1    1    0.70346E-06    0.10000E+01    0.15752E+03    0.54222E-05    0.58395E-08    0.10158E-11
+    1    1    0.12275E-05    0.10000E+01    0.80645E+05    0.33038E-52    0.24670E-63    0.30428E-58
+    1    1    0.12275E-05    0.10000E+01    0.65036E+05    0.27906E-51    0.39128E-62    0.25714E-57
+    1    1    0.12275E-05    0.10000E+01    0.52449E+05    0.23679E-50    0.52350E-61    0.21828E-56
+    1    1    0.12275E-05    0.10000E+01    0.42297E+05    0.17752E-49    0.70559E-60    0.16378E-55
+    1    1    0.12275E-05    0.10000E+01    0.34111E+05    0.12719E-48    0.95622E-59    0.11751E-54
+    1    1    0.12275E-05    0.10000E+01    0.27509E+05    0.90311E-48    0.12686E-57    0.83640E-54
+    1    1    0.12275E-05    0.10000E+01    0.22184E+05    0.63172E-47    0.16296E-56    0.58737E-53
+    1    1    0.12275E-05    0.10000E+01    0.17891E+05    0.43032E-46    0.20146E-55    0.40272E-52
+    1    1    0.12275E-05    0.10000E+01    0.14428E+05    0.28329E-45    0.23906E-54    0.26785E-51
+    1    1    0.12275E-05    0.10000E+01    0.11635E+05    0.17940E-44    0.26925E-53    0.17219E-50
+    1    1    0.12275E-05    0.10000E+01    0.93834E+04    0.10839E-43    0.28359E-52    0.10609E-49
+    1    1    0.12275E-05    0.10000E+01    0.75673E+04    0.62039E-43    0.30208E-51    0.61553E-49
+    1    1    0.12275E-05    0.10000E+01    0.61026E+04    0.35493E-42    0.44350E-50    0.33914E-48
+    1    1    0.12275E-05    0.10000E+01    0.49215E+04    0.25134E-41    0.98915E-49    0.20560E-47
+    1    1    0.12275E-05    0.10000E+01    0.39689E+04    0.25842E-40    0.24485E-47    0.17815E-46
+    1    1    0.12275E-05    0.10000E+01    0.32008E+04    0.10025E-37    0.18588E-44    0.64912E-44
+    1    1    0.12275E-05    0.10000E+01    0.25813E+04    0.62929E-29    0.24730E-35    0.39421E-35
+    1    1    0.12275E-05    0.10000E+01    0.20817E+04    0.93558E-13    0.13637E-18    0.54302E-19
+    1    1    0.12275E-05    0.10000E+01    0.16788E+04    0.25915E-07    0.15348E-12    0.13581E-13
+    1    1    0.12275E-05    0.10000E+01    0.13538E+04    0.47256E-07    0.54739E-12    0.21642E-13
+    1    1    0.12275E-05    0.10000E+01    0.10918E+04    0.87455E-07    0.19452E-11    0.34980E-13
+    1    1    0.12275E-05    0.10000E+01    0.88049E+03    0.16287E-06    0.69092E-11    0.57001E-13
+    1    1    0.12275E-05    0.10000E+01    0.71007E+03    0.30390E-06    0.24516E-10    0.93486E-13
+    1    1    0.12275E-05    0.10000E+01    0.57264E+03    0.56705E-06    0.85687E-10    0.15450E-12
+    1    1    0.12275E-05    0.10000E+01    0.46180E+03    0.10554E-05    0.28495E-09    0.25760E-12
+    1    1    0.12275E-05    0.10000E+01    0.37242E+03    0.19454E-05    0.86295E-09    0.43207E-12
+    1    1    0.12275E-05    0.10000E+01    0.30034E+03    0.35043E-05    0.23052E-08    0.72148E-12
+    1    1    0.12275E-05    0.10000E+01    0.24221E+03    0.60678E-05    0.53694E-08    0.11799E-11
+    1    1    0.12275E-05    0.10000E+01    0.19533E+03    0.94614E-05    0.10190E-07    0.17726E-11
+    1    1    0.12275E-05    0.10000E+01    0.15752E+03    0.94614E-05    0.10190E-07    0.17726E-11
+    1    1    0.21419E-05    0.10000E+01    0.80645E+05    0.57650E-52    0.43048E-63    0.53095E-58
+    1    1    0.21419E-05    0.10000E+01    0.65036E+05    0.48694E-51    0.68276E-62    0.44869E-57
+    1    1    0.21419E-05    0.10000E+01    0.52449E+05    0.41318E-50    0.91347E-61    0.38089E-56
+    1    1    0.21419E-05    0.10000E+01    0.42297E+05    0.30977E-49    0.12312E-59    0.28579E-55
+    1    1    0.21419E-05    0.10000E+01    0.34111E+05    0.22193E-48    0.16686E-58    0.20505E-54
+    1    1    0.21419E-05    0.10000E+01    0.27509E+05    0.15759E-47    0.22137E-57    0.14595E-53
+    1    1    0.21419E-05    0.10000E+01    0.22184E+05    0.11023E-46    0.28436E-56    0.10249E-52
+    1    1    0.21419E-05    0.10000E+01    0.17891E+05    0.75088E-46    0.35154E-55    0.70273E-52
+    1    1    0.21419E-05    0.10000E+01    0.14428E+05    0.49432E-45    0.41714E-54    0.46738E-51
+    1    1    0.21419E-05    0.10000E+01    0.11635E+05    0.31305E-44    0.46983E-53    0.30046E-50
+    1    1    0.21419E-05    0.10000E+01    0.93834E+04    0.18914E-43    0.49485E-52    0.18512E-49
+    1    1    0.21419E-05    0.10000E+01    0.75673E+04    0.10825E-42    0.52710E-51    0.10741E-48
+    1    1    0.21419E-05    0.10000E+01    0.61026E+04    0.61933E-42    0.77389E-50    0.59178E-48
+    1    1    0.21419E-05    0.10000E+01    0.49215E+04    0.43857E-41    0.17260E-48    0.35876E-47
+    1    1    0.21419E-05    0.10000E+01    0.39689E+04    0.45093E-40    0.42724E-47    0.31087E-46
+    1    1    0.21419E-05    0.10000E+01    0.32008E+04    0.17492E-37    0.32434E-44    0.11327E-43
+    1    1    0.21419E-05    0.10000E+01    0.25813E+04    0.10981E-28    0.43153E-35    0.68787E-35
+    1    1    0.21419E-05    0.10000E+01    0.20817E+04    0.16325E-12    0.23796E-18    0.94754E-19
+    1    1    0.21419E-05    0.10000E+01    0.16788E+04    0.45220E-07    0.26781E-12    0.23697E-13
+    1    1    0.21419E-05    0.10000E+01    0.13538E+04    0.82459E-07    0.95516E-12    0.37764E-13
+    1    1    0.21419E-05    0.10000E+01    0.10918E+04    0.15260E-06    0.33943E-11    0.61038E-13
+    1    1    0.21419E-05    0.10000E+01    0.88049E+03    0.28420E-06    0.12056E-10    0.99462E-13
+    1    1    0.21419E-05    0.10000E+01    0.71007E+03    0.53029E-06    0.42778E-10    0.16313E-12
+    1    1    0.21419E-05    0.10000E+01    0.57264E+03    0.98946E-06    0.14952E-09    0.26959E-12
+    1    1    0.21419E-05    0.10000E+01    0.46180E+03    0.18415E-05    0.49722E-09    0.44949E-12
+    1    1    0.21419E-05    0.10000E+01    0.37242E+03    0.33946E-05    0.15058E-08    0.75393E-12
+    1    1    0.21419E-05    0.10000E+01    0.30034E+03    0.61149E-05    0.40225E-08    0.12589E-11
+    1    1    0.21419E-05    0.10000E+01    0.24221E+03    0.10588E-04    0.93693E-08    0.20589E-11
+    1    1    0.21419E-05    0.10000E+01    0.19533E+03    0.16510E-04    0.17780E-07    0.30930E-11
+    1    1    0.21419E-05    0.10000E+01    0.15752E+03    0.16510E-04    0.17780E-07    0.30930E-11
+    1    1    0.37375E-05    0.10000E+01    0.80645E+05    0.10060E-51    0.75117E-63    0.92647E-58
+    1    1    0.37375E-05    0.10000E+01    0.65036E+05    0.84968E-51    0.11914E-61    0.78293E-57
+    1    1    0.37375E-05    0.10000E+01    0.52449E+05    0.72097E-50    0.15940E-60    0.66463E-56
+    1    1    0.37375E-05    0.10000E+01    0.42297E+05    0.54053E-49    0.21484E-59    0.49869E-55
+    1    1    0.37375E-05    0.10000E+01    0.34111E+05    0.38726E-48    0.29115E-58    0.35780E-54
+    1    1    0.37375E-05    0.10000E+01    0.27509E+05    0.27498E-47    0.38628E-57    0.25467E-53
+    1    1    0.37375E-05    0.10000E+01    0.22184E+05    0.19235E-46    0.49619E-56    0.17884E-52
+    1    1    0.37375E-05    0.10000E+01    0.17891E+05    0.13102E-45    0.61341E-55    0.12262E-51
+    1    1    0.37375E-05    0.10000E+01    0.14428E+05    0.86256E-45    0.72789E-54    0.81554E-51
+    1    1    0.37375E-05    0.10000E+01    0.11635E+05    0.54625E-44    0.81982E-53    0.52429E-50
+    1    1    0.37375E-05    0.10000E+01    0.93834E+04    0.33004E-43    0.86349E-52    0.32302E-49
+    1    1    0.37375E-05    0.10000E+01    0.75673E+04    0.18890E-42    0.91977E-51    0.18742E-48
+    1    1    0.37375E-05    0.10000E+01    0.61026E+04    0.10807E-41    0.13504E-49    0.10326E-47
+    1    1    0.37375E-05    0.10000E+01    0.49215E+04    0.76528E-41    0.30118E-48    0.62601E-47
+    1    1    0.37375E-05    0.10000E+01    0.39689E+04    0.78684E-40    0.74551E-47    0.54244E-46
+    1    1    0.37375E-05    0.10000E+01    0.32008E+04    0.30523E-37    0.56596E-44    0.19764E-43
+    1    1    0.37375E-05    0.10000E+01    0.25813E+04    0.19161E-28    0.75300E-35    0.12003E-34
+    1    1    0.37375E-05    0.10000E+01    0.20817E+04    0.28487E-12    0.41522E-18    0.16534E-18
+    1    1    0.37375E-05    0.10000E+01    0.16788E+04    0.78907E-07    0.46732E-12    0.41350E-13
+    1    1    0.37375E-05    0.10000E+01    0.13538E+04    0.14389E-06    0.16667E-11    0.65895E-13
+    1    1    0.37375E-05    0.10000E+01    0.10918E+04    0.26628E-06    0.59228E-11    0.10651E-12
+    1    1    0.37375E-05    0.10000E+01    0.88049E+03    0.49591E-06    0.21037E-10    0.17356E-12
+    1    1    0.37375E-05    0.10000E+01    0.71007E+03    0.92533E-06    0.74645E-10    0.28465E-12
+    1    1    0.37375E-05    0.10000E+01    0.57264E+03    0.17266E-05    0.26090E-09    0.47042E-12
+    1    1    0.37375E-05    0.10000E+01    0.46180E+03    0.32134E-05    0.86762E-09    0.78433E-12
+    1    1    0.37375E-05    0.10000E+01    0.37242E+03    0.59234E-05    0.26275E-08    0.13156E-11
+    1    1    0.37375E-05    0.10000E+01    0.30034E+03    0.10670E-04    0.70190E-08    0.21968E-11
+    1    1    0.37375E-05    0.10000E+01    0.24221E+03    0.18475E-04    0.16349E-07    0.35926E-11
+    1    1    0.37375E-05    0.10000E+01    0.19533E+03    0.28808E-04    0.31026E-07    0.53971E-11
+    1    1    0.37375E-05    0.10000E+01    0.15752E+03    0.28808E-04    0.31026E-07    0.53971E-11
+    1    1    0.65217E-05    0.10000E+01    0.80645E+05    0.17553E-51    0.13107E-62    0.16166E-57
+    1    1    0.65217E-05    0.10000E+01    0.65036E+05    0.14826E-50    0.20789E-61    0.13662E-56
+    1    1    0.65217E-05    0.10000E+01    0.52449E+05    0.12581E-49    0.27814E-60    0.11597E-55
+    1    1    0.65217E-05    0.10000E+01    0.42297E+05    0.94319E-49    0.37488E-59    0.87018E-55
+    1    1    0.65217E-05    0.10000E+01    0.34111E+05    0.67575E-48    0.50804E-58    0.62434E-54
+    1    1    0.65217E-05    0.10000E+01    0.27509E+05    0.47982E-47    0.67403E-57    0.44438E-53
+    1    1    0.65217E-05    0.10000E+01    0.22184E+05    0.33563E-46    0.86583E-56    0.31207E-52
+    1    1    0.65217E-05    0.10000E+01    0.17891E+05    0.22863E-45    0.10704E-54    0.21397E-51
+    1    1    0.65217E-05    0.10000E+01    0.14428E+05    0.15051E-44    0.12701E-53    0.14231E-50
+    1    1    0.65217E-05    0.10000E+01    0.11635E+05    0.95317E-44    0.14305E-52    0.91486E-50
+    1    1    0.65217E-05    0.10000E+01    0.93834E+04    0.57590E-43    0.15067E-51    0.56365E-49
+    1    1    0.65217E-05    0.10000E+01    0.75673E+04    0.32961E-42    0.16049E-50    0.32703E-48
+    1    1    0.65217E-05    0.10000E+01    0.61026E+04    0.18857E-41    0.23563E-49    0.18018E-47
+    1    1    0.65217E-05    0.10000E+01    0.49215E+04    0.13354E-40    0.52554E-48    0.10924E-46
+    1    1    0.65217E-05    0.10000E+01    0.39689E+04    0.13730E-39    0.13009E-46    0.94653E-46
+    1    1    0.65217E-05    0.10000E+01    0.32008E+04    0.53260E-37    0.98757E-44    0.34488E-43
+    1    1    0.65217E-05    0.10000E+01    0.25813E+04    0.33434E-28    0.13139E-34    0.20944E-34
+    1    1    0.65217E-05    0.10000E+01    0.20817E+04    0.49708E-12    0.72454E-18    0.28851E-18
+    1    1    0.65217E-05    0.10000E+01    0.16788E+04    0.13769E-06    0.81545E-12    0.72153E-13
+    1    1    0.65217E-05    0.10000E+01    0.13538E+04    0.25107E-06    0.29083E-11    0.11498E-12
+    1    1    0.65217E-05    0.10000E+01    0.10918E+04    0.46465E-06    0.10335E-10    0.18585E-12
+    1    1    0.65217E-05    0.10000E+01    0.88049E+03    0.86533E-06    0.36709E-10    0.30284E-12
+    1    1    0.65217E-05    0.10000E+01    0.71007E+03    0.16146E-05    0.13025E-09    0.49669E-12
+    1    1    0.65217E-05    0.10000E+01    0.57264E+03    0.30127E-05    0.45526E-09    0.82085E-12
+    1    1    0.65217E-05    0.10000E+01    0.46180E+03    0.56071E-05    0.15140E-08    0.13686E-11
+    1    1    0.65217E-05    0.10000E+01    0.37242E+03    0.10336E-04    0.45849E-08    0.22956E-11
+    1    1    0.65217E-05    0.10000E+01    0.30034E+03    0.18619E-04    0.12248E-07    0.38332E-11
+    1    1    0.65217E-05    0.10000E+01    0.24221E+03    0.32238E-04    0.28528E-07    0.62688E-11
+    1    1    0.65217E-05    0.10000E+01    0.19533E+03    0.50269E-04    0.54138E-07    0.94177E-11
+    1    1    0.65217E-05    0.10000E+01    0.15752E+03    0.50269E-04    0.54138E-07    0.94177E-11
+    1    1    0.11380E-04    0.10000E+01    0.80645E+05    0.30630E-51    0.22872E-62    0.28209E-57
+    1    1    0.11380E-04    0.10000E+01    0.65036E+05    0.25871E-50    0.36275E-61    0.23839E-56
+    1    1    0.11380E-04    0.10000E+01    0.52449E+05    0.21952E-49    0.48533E-60    0.20237E-55
+    1    1    0.11380E-04    0.10000E+01    0.42297E+05    0.16458E-48    0.65414E-59    0.15184E-54
+    1    1    0.11380E-04    0.10000E+01    0.34111E+05    0.11791E-47    0.88650E-58    0.10894E-53
+    1    1    0.11380E-04    0.10000E+01    0.27509E+05    0.83726E-47    0.11761E-56    0.77542E-53
+    1    1    0.11380E-04    0.10000E+01    0.22184E+05    0.58566E-46    0.15108E-55    0.54455E-52
+    1    1    0.11380E-04    0.10000E+01    0.17891E+05    0.39894E-45    0.18677E-54    0.37336E-51
+    1    1    0.11380E-04    0.10000E+01    0.14428E+05    0.26263E-44    0.22163E-53    0.24832E-50
+    1    1    0.11380E-04    0.10000E+01    0.11635E+05    0.16632E-43    0.24962E-52    0.15964E-49
+    1    1    0.11380E-04    0.10000E+01    0.93834E+04    0.10049E-42    0.26292E-51    0.98354E-49
+    1    1    0.11380E-04    0.10000E+01    0.75673E+04    0.57516E-42    0.28005E-50    0.57065E-48
+    1    1    0.11380E-04    0.10000E+01    0.61026E+04    0.32905E-41    0.41117E-49    0.31441E-47
+    1    1    0.11380E-04    0.10000E+01    0.49215E+04    0.23301E-40    0.91703E-48    0.19061E-46
+    1    1    0.11380E-04    0.10000E+01    0.39689E+04    0.23958E-39    0.22699E-46    0.16516E-45
+    1    1    0.11380E-04    0.10000E+01    0.32008E+04    0.92936E-37    0.17232E-43    0.60179E-43
+    1    1    0.11380E-04    0.10000E+01    0.25813E+04    0.58341E-28    0.22927E-34    0.36547E-34
+    1    1    0.11380E-04    0.10000E+01    0.20817E+04    0.86737E-12    0.12643E-17    0.50343E-18
+    1    1    0.11380E-04    0.10000E+01    0.16788E+04    0.24026E-06    0.14229E-11    0.12590E-12
+    1    1    0.11380E-04    0.10000E+01    0.13538E+04    0.43811E-06    0.50748E-11    0.20064E-12
+    1    1    0.11380E-04    0.10000E+01    0.10918E+04    0.81078E-06    0.18034E-10    0.32429E-12
+    1    1    0.11380E-04    0.10000E+01    0.88049E+03    0.15099E-05    0.64054E-10    0.52845E-12
+    1    1    0.11380E-04    0.10000E+01    0.71007E+03    0.28175E-05    0.22728E-09    0.86670E-12
+    1    1    0.11380E-04    0.10000E+01    0.57264E+03    0.52570E-05    0.79440E-09    0.14323E-11
+    1    1    0.11380E-04    0.10000E+01    0.46180E+03    0.97841E-05    0.26418E-08    0.23882E-11
+    1    1    0.11380E-04    0.10000E+01    0.37242E+03    0.18036E-04    0.80003E-08    0.40057E-11
+    1    1    0.11380E-04    0.10000E+01    0.30034E+03    0.32488E-04    0.21371E-07    0.66888E-11
+    1    1    0.11380E-04    0.10000E+01    0.24221E+03    0.56254E-04    0.49779E-07    0.10939E-10
+    1    1    0.11380E-04    0.10000E+01    0.19533E+03    0.87716E-04    0.94467E-07    0.16433E-10
+    1    1    0.11380E-04    0.10000E+01    0.15752E+03    0.87716E-04    0.94467E-07    0.16433E-10
+    1    1    0.19857E-04    0.10000E+01    0.80645E+05    0.53447E-51    0.39910E-62    0.49223E-57
+    1    1    0.19857E-04    0.10000E+01    0.65036E+05    0.45144E-50    0.63298E-61    0.41597E-56
+    1    1    0.19857E-04    0.10000E+01    0.52449E+05    0.38305E-49    0.84687E-60    0.35312E-55
+    1    1    0.19857E-04    0.10000E+01    0.42297E+05    0.28718E-48    0.11414E-58    0.26495E-54
+    1    1    0.19857E-04    0.10000E+01    0.34111E+05    0.20575E-47    0.15469E-57    0.19010E-53
+    1    1    0.19857E-04    0.10000E+01    0.27509E+05    0.14610E-46    0.20523E-56    0.13531E-52
+    1    1    0.19857E-04    0.10000E+01    0.22184E+05    0.10219E-45    0.26363E-55    0.95020E-52
+    1    1    0.19857E-04    0.10000E+01    0.17891E+05    0.69613E-45    0.32590E-54    0.65149E-51
+    1    1    0.19857E-04    0.10000E+01    0.14428E+05    0.45828E-44    0.38673E-53    0.43330E-50
+    1    1    0.19857E-04    0.10000E+01    0.11635E+05    0.29022E-43    0.43557E-52    0.27856E-49
+    1    1    0.19857E-04    0.10000E+01    0.93834E+04    0.17535E-42    0.45877E-51    0.17162E-48
+    1    1    0.19857E-04    0.10000E+01    0.75673E+04    0.10036E-41    0.48867E-50    0.99575E-48
+    1    1    0.19857E-04    0.10000E+01    0.61026E+04    0.57417E-41    0.71746E-49    0.54863E-47
+    1    1    0.19857E-04    0.10000E+01    0.49215E+04    0.40660E-40    0.16002E-47    0.33260E-46
+    1    1    0.19857E-04    0.10000E+01    0.39689E+04    0.41805E-39    0.39609E-46    0.28820E-45
+    1    1    0.19857E-04    0.10000E+01    0.32008E+04    0.16217E-36    0.30070E-43    0.10501E-42
+    1    1    0.19857E-04    0.10000E+01    0.25813E+04    0.10180E-27    0.40007E-34    0.63772E-34
+    1    1    0.19857E-04    0.10000E+01    0.20817E+04    0.15135E-11    0.22061E-17    0.87845E-18
+    1    1    0.19857E-04    0.10000E+01    0.16788E+04    0.41923E-06    0.24829E-11    0.21969E-12
+    1    1    0.19857E-04    0.10000E+01    0.13538E+04    0.76447E-06    0.88552E-11    0.35010E-12
+    1    1    0.19857E-04    0.10000E+01    0.10918E+04    0.14148E-05    0.31468E-10    0.56587E-12
+    1    1    0.19857E-04    0.10000E+01    0.88049E+03    0.26348E-05    0.11177E-09    0.92211E-12
+    1    1    0.19857E-04    0.10000E+01    0.71007E+03    0.49163E-05    0.39659E-09    0.15123E-11
+    1    1    0.19857E-04    0.10000E+01    0.57264E+03    0.91732E-05    0.13862E-08    0.24993E-11
+    1    1    0.19857E-04    0.10000E+01    0.46180E+03    0.17073E-04    0.46097E-08    0.41672E-11
+    1    1    0.19857E-04    0.10000E+01    0.37242E+03    0.31471E-04    0.13960E-07    0.69896E-11
+    1    1    0.19857E-04    0.10000E+01    0.30034E+03    0.56690E-04    0.37292E-07    0.11672E-10
+    1    1    0.19857E-04    0.10000E+01    0.24221E+03    0.98159E-04    0.86862E-07    0.19087E-10
+    1    1    0.19857E-04    0.10000E+01    0.19533E+03    0.15306E-03    0.16484E-06    0.28675E-10
+    1    1    0.19857E-04    0.10000E+01    0.15752E+03    0.15306E-03    0.16484E-06    0.28675E-10
+    1    1    0.34650E-04    0.10000E+01    0.80645E+05    0.93261E-51    0.69640E-62    0.85892E-57
+    1    1    0.34650E-04    0.10000E+01    0.65036E+05    0.78773E-50    0.11045E-60    0.72585E-56
+    1    1    0.34650E-04    0.10000E+01    0.52449E+05    0.66841E-49    0.14777E-59    0.61617E-55
+    1    1    0.34650E-04    0.10000E+01    0.42297E+05    0.50112E-48    0.19917E-58    0.46233E-54
+    1    1    0.34650E-04    0.10000E+01    0.34111E+05    0.35903E-47    0.26992E-57    0.33171E-53
+    1    1    0.34650E-04    0.10000E+01    0.27509E+05    0.25493E-46    0.35811E-56    0.23610E-52
+    1    1    0.34650E-04    0.10000E+01    0.22184E+05    0.17832E-45    0.46002E-55    0.16580E-51
+    1    1    0.34650E-04    0.10000E+01    0.17891E+05    0.12147E-44    0.56868E-54    0.11368E-50
+    1    1    0.34650E-04    0.10000E+01    0.14428E+05    0.79967E-44    0.67482E-53    0.75608E-50
+    1    1    0.34650E-04    0.10000E+01    0.11635E+05    0.50642E-43    0.76005E-52    0.48607E-49
+    1    1    0.34650E-04    0.10000E+01    0.93834E+04    0.30598E-42    0.80053E-51    0.29947E-48
+    1    1    0.34650E-04    0.10000E+01    0.75673E+04    0.17512E-41    0.85271E-50    0.17375E-47
+    1    1    0.34650E-04    0.10000E+01    0.61026E+04    0.10019E-40    0.12519E-48    0.95732E-47
+    1    1    0.34650E-04    0.10000E+01    0.49215E+04    0.70948E-40    0.27922E-47    0.58037E-46
+    1    1    0.34650E-04    0.10000E+01    0.39689E+04    0.72947E-39    0.69116E-46    0.50289E-45
+    1    1    0.34650E-04    0.10000E+01    0.32008E+04    0.28297E-36    0.52470E-43    0.18323E-42
+    1    1    0.34650E-04    0.10000E+01    0.25813E+04    0.17764E-27    0.69809E-34    0.11128E-33
+    1    1    0.34650E-04    0.10000E+01    0.20817E+04    0.26410E-11    0.38495E-17    0.15328E-17
+    1    1    0.34650E-04    0.10000E+01    0.16788E+04    0.73153E-06    0.43325E-11    0.38335E-12
+    1    1    0.34650E-04    0.10000E+01    0.13538E+04    0.13339E-05    0.15452E-10    0.61091E-12
+    1    1    0.34650E-04    0.10000E+01    0.10918E+04    0.24687E-05    0.54910E-10    0.98742E-12
+    1    1    0.34650E-04    0.10000E+01    0.88049E+03    0.45975E-05    0.19503E-09    0.16090E-11
+    1    1    0.34650E-04    0.10000E+01    0.71007E+03    0.85786E-05    0.69203E-09    0.26389E-11
+    1    1    0.34650E-04    0.10000E+01    0.57264E+03    0.16007E-04    0.24188E-08    0.43612E-11
+    1    1    0.34650E-04    0.10000E+01    0.46180E+03    0.29791E-04    0.80437E-08    0.72715E-11
+    1    1    0.34650E-04    0.10000E+01    0.37242E+03    0.54915E-04    0.24359E-07    0.12196E-10
+    1    1    0.34650E-04    0.10000E+01    0.30034E+03    0.98921E-04    0.65072E-07    0.20366E-10
+    1    1    0.34650E-04    0.10000E+01    0.24221E+03    0.17128E-03    0.15157E-06    0.33306E-10
+    1    1    0.34650E-04    0.10000E+01    0.19533E+03    0.26708E-03    0.28763E-06    0.50036E-10
+    1    1    0.34650E-04    0.10000E+01    0.15752E+03    0.26708E-03    0.28763E-06    0.50036E-10
+    1    1    0.60462E-04    0.10000E+01    0.80645E+05    0.16274E-50    0.12152E-61    0.14988E-56
+    1    1    0.60462E-04    0.10000E+01    0.65036E+05    0.13745E-49    0.19273E-60    0.12666E-55
+    1    1    0.60462E-04    0.10000E+01    0.52449E+05    0.11663E-48    0.25786E-59    0.10752E-54
+    1    1    0.60462E-04    0.10000E+01    0.42297E+05    0.87442E-48    0.34755E-58    0.80673E-54
+    1    1    0.60462E-04    0.10000E+01    0.34111E+05    0.62648E-47    0.47100E-57    0.57882E-53
+    1    1    0.60462E-04    0.10000E+01    0.27509E+05    0.44484E-46    0.62489E-56    0.41198E-52
+    1    1    0.60462E-04    0.10000E+01    0.22184E+05    0.31116E-45    0.80270E-55    0.28932E-51
+    1    1    0.60462E-04    0.10000E+01    0.17891E+05    0.21196E-44    0.99232E-54    0.19837E-50
+    1    1    0.60462E-04    0.10000E+01    0.14428E+05    0.13954E-43    0.11775E-52    0.13193E-49
+    1    1    0.60462E-04    0.10000E+01    0.11635E+05    0.88367E-43    0.13262E-51    0.84815E-49
+    1    1    0.60462E-04    0.10000E+01    0.93834E+04    0.53391E-42    0.13969E-50    0.52256E-48
+    1    1    0.60462E-04    0.10000E+01    0.75673E+04    0.30558E-41    0.14879E-49    0.30319E-47
+    1    1    0.60462E-04    0.10000E+01    0.61026E+04    0.17483E-40    0.21845E-48    0.16705E-46
+    1    1    0.60462E-04    0.10000E+01    0.49215E+04    0.12380E-39    0.48722E-47    0.10127E-45
+    1    1    0.60462E-04    0.10000E+01    0.39689E+04    0.12729E-38    0.12060E-45    0.87752E-45
+    1    1    0.60462E-04    0.10000E+01    0.32008E+04    0.49377E-36    0.91556E-43    0.31973E-42
+    1    1    0.60462E-04    0.10000E+01    0.25813E+04    0.30997E-27    0.12181E-33    0.19417E-33
+    1    1    0.60462E-04    0.10000E+01    0.20817E+04    0.46083E-11    0.67171E-17    0.26747E-17
+    1    1    0.60462E-04    0.10000E+01    0.16788E+04    0.12765E-05    0.75599E-11    0.66893E-12
+    1    1    0.60462E-04    0.10000E+01    0.13538E+04    0.23277E-05    0.26962E-10    0.10660E-11
+    1    1    0.60462E-04    0.10000E+01    0.10918E+04    0.43077E-05    0.95814E-10    0.17230E-11
+    1    1    0.60462E-04    0.10000E+01    0.88049E+03    0.80224E-05    0.34032E-09    0.28076E-11
+    1    1    0.60462E-04    0.10000E+01    0.71007E+03    0.14969E-04    0.12075E-08    0.46048E-11
+    1    1    0.60462E-04    0.10000E+01    0.57264E+03    0.27931E-04    0.42207E-08    0.76100E-11
+    1    1    0.60462E-04    0.10000E+01    0.46180E+03    0.51983E-04    0.14036E-07    0.12688E-10
+    1    1    0.60462E-04    0.10000E+01    0.37242E+03    0.95823E-04    0.42506E-07    0.21282E-10
+    1    1    0.60462E-04    0.10000E+01    0.30034E+03    0.17261E-03    0.11355E-06    0.35538E-10
+    1    1    0.60462E-04    0.10000E+01    0.24221E+03    0.29888E-03    0.26448E-06    0.58118E-10
+    1    1    0.60462E-04    0.10000E+01    0.19533E+03    0.46603E-03    0.50190E-06    0.87310E-10
+    1    1    0.60462E-04    0.10000E+01    0.15752E+03    0.46603E-03    0.50190E-06    0.87310E-10
+    1    1    0.10550E-03    0.10000E+01    0.80645E+05    0.28396E-50    0.21204E-61    0.26152E-56
+    1    1    0.10550E-03    0.10000E+01    0.65036E+05    0.23985E-49    0.33630E-60    0.22101E-55
+    1    1    0.10550E-03    0.10000E+01    0.52449E+05    0.20352E-48    0.44994E-59    0.18761E-54
+    1    1    0.10550E-03    0.10000E+01    0.42297E+05    0.15258E-47    0.60645E-58    0.14077E-53
+    1    1    0.10550E-03    0.10000E+01    0.34111E+05    0.10932E-46    0.82187E-57    0.10100E-52
+    1    1    0.10550E-03    0.10000E+01    0.27509E+05    0.77622E-46    0.10904E-55    0.71888E-52
+    1    1    0.10550E-03    0.10000E+01    0.22184E+05    0.54296E-45    0.14007E-54    0.50484E-51
+    1    1    0.10550E-03    0.10000E+01    0.17891E+05    0.36985E-44    0.17315E-53    0.34614E-50
+    1    1    0.10550E-03    0.10000E+01    0.14428E+05    0.24348E-43    0.20547E-52    0.23021E-49
+    1    1    0.10550E-03    0.10000E+01    0.11635E+05    0.15420E-42    0.23142E-51    0.14800E-48
+    1    1    0.10550E-03    0.10000E+01    0.93834E+04    0.93164E-42    0.24375E-50    0.91183E-48
+    1    1    0.10550E-03    0.10000E+01    0.75673E+04    0.53322E-41    0.25963E-49    0.52904E-47
+    1    1    0.10550E-03    0.10000E+01    0.61026E+04    0.30506E-40    0.38119E-48    0.29149E-46
+    1    1    0.10550E-03    0.10000E+01    0.49215E+04    0.21602E-39    0.85017E-47    0.17671E-45
+    1    1    0.10550E-03    0.10000E+01    0.39689E+04    0.22211E-38    0.21044E-45    0.15312E-44
+    1    1    0.10550E-03    0.10000E+01    0.32008E+04    0.86160E-36    0.15976E-42    0.55791E-42
+    1    1    0.10550E-03    0.10000E+01    0.25813E+04    0.54087E-27    0.21256E-33    0.33882E-33
+    1    1    0.10550E-03    0.10000E+01    0.20817E+04    0.80413E-11    0.11721E-16    0.46672E-17
+    1    1    0.10550E-03    0.10000E+01    0.16788E+04    0.22274E-05    0.13192E-10    0.11672E-11
+    1    1    0.10550E-03    0.10000E+01    0.13538E+04    0.40616E-05    0.47048E-10    0.18601E-11
+    1    1    0.10550E-03    0.10000E+01    0.10918E+04    0.75167E-05    0.16719E-09    0.30065E-11
+    1    1    0.10550E-03    0.10000E+01    0.88049E+03    0.13999E-04    0.59384E-09    0.48992E-11
+    1    1    0.10550E-03    0.10000E+01    0.71007E+03    0.26120E-04    0.21071E-08    0.80351E-11
+    1    1    0.10550E-03    0.10000E+01    0.57264E+03    0.48737E-04    0.73648E-08    0.13279E-10
+    1    1    0.10550E-03    0.10000E+01    0.46180E+03    0.90707E-04    0.24491E-07    0.22140E-10
+    1    1    0.10550E-03    0.10000E+01    0.37242E+03    0.16721E-03    0.74170E-07    0.37136E-10
+    1    1    0.10550E-03    0.10000E+01    0.30034E+03    0.30120E-03    0.19813E-06    0.62011E-10
+    1    1    0.10550E-03    0.10000E+01    0.24221E+03    0.52152E-03    0.46150E-06    0.10141E-09
+    1    1    0.10550E-03    0.10000E+01    0.19533E+03    0.81320E-03    0.87579E-06    0.15235E-09
+    1    1    0.10550E-03    0.10000E+01    0.15752E+03    0.81320E-03    0.87579E-06    0.15235E-09
+    1    1    0.18409E-03    0.10000E+01    0.80645E+05    0.49550E-50    0.37000E-61    0.45635E-56
+    1    1    0.18409E-03    0.10000E+01    0.65036E+05    0.41852E-49    0.58683E-60    0.38564E-55
+    1    1    0.18409E-03    0.10000E+01    0.52449E+05    0.35513E-48    0.78513E-59    0.32737E-54
+    1    1    0.18409E-03    0.10000E+01    0.42297E+05    0.26624E-47    0.10582E-57    0.24564E-53
+    1    1    0.18409E-03    0.10000E+01    0.34111E+05    0.19075E-46    0.14341E-56    0.17624E-52
+    1    1    0.18409E-03    0.10000E+01    0.27509E+05    0.13545E-45    0.19027E-55    0.12544E-51
+    1    1    0.18409E-03    0.10000E+01    0.22184E+05    0.94743E-45    0.24441E-54    0.88092E-51
+    1    1    0.18409E-03    0.10000E+01    0.17891E+05    0.64537E-44    0.30214E-53    0.60399E-50
+    1    1    0.18409E-03    0.10000E+01    0.14428E+05    0.42486E-43    0.35853E-52    0.40171E-49
+    1    1    0.18409E-03    0.10000E+01    0.11635E+05    0.26906E-42    0.40381E-51    0.25825E-48
+    1    1    0.18409E-03    0.10000E+01    0.93834E+04    0.16257E-41    0.42532E-50    0.15911E-47
+    1    1    0.18409E-03    0.10000E+01    0.75673E+04    0.93044E-41    0.45304E-49    0.92315E-47
+    1    1    0.18409E-03    0.10000E+01    0.61026E+04    0.53231E-40    0.66515E-48    0.50863E-46
+    1    1    0.18409E-03    0.10000E+01    0.49215E+04    0.37695E-39    0.14835E-46    0.30835E-45
+    1    1    0.18409E-03    0.10000E+01    0.39689E+04    0.38757E-38    0.36721E-45    0.26719E-44
+    1    1    0.18409E-03    0.10000E+01    0.32008E+04    0.15034E-35    0.27877E-42    0.97352E-42
+    1    1    0.18409E-03    0.10000E+01    0.25813E+04    0.94379E-27    0.37090E-33    0.59122E-33
+    1    1    0.18409E-03    0.10000E+01    0.20817E+04    0.14032E-10    0.20452E-16    0.81440E-17
+    1    1    0.18409E-03    0.10000E+01    0.16788E+04    0.38867E-05    0.23019E-10    0.20368E-11
+    1    1    0.18409E-03    0.10000E+01    0.13538E+04    0.70873E-05    0.82096E-10    0.32458E-11
+    1    1    0.18409E-03    0.10000E+01    0.10918E+04    0.13116E-04    0.29174E-09    0.52462E-11
+    1    1    0.18409E-03    0.10000E+01    0.88049E+03    0.24427E-04    0.10362E-08    0.85487E-11
+    1    1    0.18409E-03    0.10000E+01    0.71007E+03    0.45578E-04    0.36768E-08    0.14021E-10
+    1    1    0.18409E-03    0.10000E+01    0.57264E+03    0.85044E-04    0.12851E-07    0.23171E-10
+    1    1    0.18409E-03    0.10000E+01    0.46180E+03    0.15828E-03    0.42736E-07    0.38633E-10
+    1    1    0.18409E-03    0.10000E+01    0.37242E+03    0.29176E-03    0.12942E-06    0.64800E-10
+    1    1    0.18409E-03    0.10000E+01    0.30034E+03    0.52557E-03    0.34573E-06    0.10821E-09
+    1    1    0.18409E-03    0.10000E+01    0.24221E+03    0.91002E-03    0.80529E-06    0.17696E-09
+    1    1    0.18409E-03    0.10000E+01    0.19533E+03    0.14190E-02    0.15282E-05    0.26584E-09
+    1    1    0.18409E-03    0.10000E+01    0.15752E+03    0.14190E-02    0.15282E-05    0.26584E-09
+    1    1    0.32123E-03    0.10000E+01    0.80645E+05    0.86462E-50    0.64562E-61    0.79629E-56
+    1    1    0.32123E-03    0.10000E+01    0.65036E+05    0.73030E-49    0.10240E-59    0.67293E-55
+    1    1    0.32123E-03    0.10000E+01    0.52449E+05    0.61967E-48    0.13700E-58    0.57125E-54
+    1    1    0.32123E-03    0.10000E+01    0.42297E+05    0.46458E-47    0.18465E-57    0.42862E-53
+    1    1    0.32123E-03    0.10000E+01    0.34111E+05    0.33285E-46    0.25024E-56    0.30753E-52
+    1    1    0.32123E-03    0.10000E+01    0.27509E+05    0.23634E-45    0.33200E-55    0.21889E-51
+    1    1    0.32123E-03    0.10000E+01    0.22184E+05    0.16532E-44    0.42648E-54    0.15372E-50
+    1    1    0.32123E-03    0.10000E+01    0.17891E+05    0.11261E-43    0.52722E-53    0.10539E-49
+    1    1    0.32123E-03    0.10000E+01    0.14428E+05    0.74136E-43    0.62562E-52    0.70095E-49
+    1    1    0.32123E-03    0.10000E+01    0.11635E+05    0.46950E-42    0.70463E-51    0.45063E-48
+    1    1    0.32123E-03    0.10000E+01    0.93834E+04    0.28367E-41    0.74216E-50    0.27764E-47
+    1    1    0.32123E-03    0.10000E+01    0.75673E+04    0.16236E-40    0.79053E-49    0.16108E-46
+    1    1    0.32123E-03    0.10000E+01    0.61026E+04    0.92885E-40    0.11607E-47    0.88752E-46
+    1    1    0.32123E-03    0.10000E+01    0.49215E+04    0.65775E-39    0.25886E-46    0.53805E-45
+    1    1    0.32123E-03    0.10000E+01    0.39689E+04    0.67628E-38    0.64076E-45    0.46623E-44
+    1    1    0.32123E-03    0.10000E+01    0.32008E+04    0.26234E-35    0.48644E-42    0.16987E-41
+    1    1    0.32123E-03    0.10000E+01    0.25813E+04    0.16469E-26    0.64720E-33    0.10316E-32
+    1    1    0.32123E-03    0.10000E+01    0.20817E+04    0.24484E-10    0.35688E-16    0.14211E-16
+    1    1    0.32123E-03    0.10000E+01    0.16788E+04    0.67820E-05    0.40166E-10    0.35540E-11
+    1    1    0.32123E-03    0.10000E+01    0.13538E+04    0.12367E-04    0.14325E-09    0.56636E-11
+    1    1    0.32123E-03    0.10000E+01    0.10918E+04    0.22887E-04    0.50906E-09    0.91542E-11
+    1    1    0.32123E-03    0.10000E+01    0.88049E+03    0.42623E-04    0.18081E-08    0.14917E-10
+    1    1    0.32123E-03    0.10000E+01    0.71007E+03    0.79532E-04    0.64157E-08    0.24465E-10
+    1    1    0.32123E-03    0.10000E+01    0.57264E+03    0.14840E-03    0.22424E-07    0.40432E-10
+    1    1    0.32123E-03    0.10000E+01    0.46180E+03    0.27619E-03    0.74572E-07    0.67413E-10
+    1    1    0.32123E-03    0.10000E+01    0.37242E+03    0.50911E-03    0.22583E-06    0.11307E-09
+    1    1    0.32123E-03    0.10000E+01    0.30034E+03    0.91708E-03    0.60328E-06    0.18881E-09
+    1    1    0.32123E-03    0.10000E+01    0.24221E+03    0.15879E-02    0.14052E-05    0.30878E-09
+    1    1    0.32123E-03    0.10000E+01    0.19533E+03    0.24760E-02    0.26666E-05    0.46388E-09
+    1    1    0.32123E-03    0.10000E+01    0.15752E+03    0.24760E-02    0.26666E-05    0.46388E-09
+    1    2    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.31175E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    2    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.54398E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    2    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.94921E-08    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    2    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.16563E-07    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    1    2    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.28902E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    1    2    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.50432E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    1    2    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.88000E-07    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    1    2    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.15355E-06    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    1    2    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.26794E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    1    2    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.46755E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    1    2    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.81584E-06    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    1    2    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.14236E-05    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    1    2    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.24841E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    1    2    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.43346E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    1    2    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.75636E-05    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    1    2    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.13198E-04    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    1    2    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.23030E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    1    2    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.40185E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    1    2    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.70121E-04    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    1    2    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.12236E-03    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    1    2    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53957E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.21351E-03    0.19496E+06    0.99447E-26    0.48760E-10    0.50499E-04    0.88379E+03
+    1    2    0.54572E-10    0.10000E+01    0.74090E-01    0.13935E+00    0.11222E-09    0.65380E-11    0.40383E-04    0.29228E-04    0.98516E+04    0.37255E-03    0.15940E+06    0.27009E-25    0.58026E-09    0.60483E-04    0.85041E+03
+    1    2    0.95225E-10    0.10000E+01    0.11736E+00    0.19749E+00    0.21140E-09    0.50996E-10    0.44004E-04    0.38038E-04    0.17190E+05    0.65008E-03    0.12765E+06    0.72480E-25    0.43989E-08    0.73406E-04    0.78192E+03
+    1    2    0.16616E-09    0.10000E+01    0.18179E+00    0.26431E+00    0.32753E-09    0.26583E-09    0.44528E-04    0.48903E-04    0.29996E+05    0.11344E-02    0.99467E+05    0.19955E-24    0.21856E-07    0.91697E-04    0.67141E+03
+    1    2    0.28994E-09    0.10000E+01    0.25961E+00    0.33496E+00    0.47703E-09    0.94192E-09    0.43515E-04    0.57767E-04    0.52341E+05    0.19794E-02    0.75619E+05    0.57623E-24    0.71447E-07    0.11865E-03    0.53386E+03
+    1    2    0.50593E-09    0.10000E+01    0.33900E+00    0.40891E+00    0.78184E-09    0.24625E-08    0.45608E-04    0.61912E-04    0.91333E+05    0.34539E-02    0.56747E+05    0.17224E-23    0.16529E-06    0.15713E-03    0.40140E+03
+    1    2    0.88282E-09    0.10000E+01    0.41762E+00    0.48781E+00    0.14159E-08    0.54449E-08    0.54182E-04    0.63271E-04    0.15937E+06    0.60269E-02    0.42418E+05    0.52150E-23    0.31202E-06    0.20988E-03    0.29419E+03
+    1    2    0.15405E-08    0.10000E+01    0.34368E+00    0.70068E+00    0.79849E-08    0.13986E-07    0.62484E-04    0.61617E-04    0.68104E+05    0.63433E-02    0.58496E+04    0.58696E-22    0.49216E-06    0.50152E-03    0.15588E+03
+    1    2    0.26880E-08    0.10000E+01    0.41033E+00    0.75964E+00    0.14561E-07    0.28273E-07    0.80137E-04    0.57615E-04    0.11884E+06    0.11069E-01    0.44011E+04    0.19921E-21    0.83906E-06    0.68023E-03    0.11526E+03
+    1    2    0.46905E-08    0.10000E+01    0.47450E+00    0.79883E+00    0.26401E-07    0.56884E-07    0.10683E-03    0.51986E-04    0.20736E+06    0.19314E-01    0.33502E+04    0.67851E-21    0.14204E-05    0.92070E-03    0.85534E+02
+    1    2    0.81846E-08    0.10000E+01    0.53373E+00    0.83550E+00    0.47511E-07    0.11158E-06    0.14610E-03    0.47850E-04    0.36184E+06    0.33702E-01    0.25769E+04    0.21697E-20    0.23676E-05    0.12241E-02    0.64507E+02
+    1    2    0.14282E-07    0.10000E+01    0.58834E+00    0.88918E+00    0.85126E-07    0.21100E-06    0.20137E-03    0.46445E-04    0.63138E+06    0.58808E-01    0.19925E+04    0.64650E-20    0.38592E-05    0.15910E-02    0.49819E+02
+    1    2    0.24920E-07    0.10000E+01    0.64095E+00    0.96838E+00    0.15300E-06    0.38565E-06    0.27565E-03    0.47647E-04    0.11017E+07    0.10262E+00    0.15405E+04    0.18436E-19    0.61499E-05    0.20364E-02    0.39301E+02
+    1    2    0.43485E-07    0.10000E+01    0.69627E+00    0.10722E+01    0.27509E-06    0.68777E-06    0.37054E-03    0.51084E-04    0.19224E+07    0.17906E+00    0.11834E+04    0.52093E-19    0.96112E-05    0.26024E-02    0.31266E+02
+    1    2    0.75878E-07    0.10000E+01    0.75920E+00    0.11935E+01    0.49060E-06    0.12082E-05    0.48722E-03    0.56367E-04    0.33546E+07    0.31245E+00    0.90085E+03    0.14901E-18    0.14811E-04    0.33529E-02    0.24761E+02
+    1    2    0.13240E-06    0.10000E+01    0.83250E+00    0.13208E+01    0.86400E-06    0.21075E-05    0.63057E-03    0.62864E-04    0.58535E+07    0.54520E+00    0.68220E+03    0.43154E-18    0.22687E-04    0.43564E-02    0.19406E+02
+    1    2    0.23103E-06    0.10000E+01    0.91800E+00    0.14453E+01    0.14791E-05    0.36642E-05    0.80560E-03    0.69893E-04    0.10214E+08    0.95134E+00    0.51327E+03    0.12520E-17    0.34668E-04    0.56976E-02    0.14973E+02
+    1    2    0.40314E-06    0.10000E+01    0.92637E+00    0.14562E+01    0.42654E-05    0.63899E-05    0.13657E-02    0.70530E-04    0.17823E+08    0.16600E+01    0.50000E+03    0.22849E-17    0.59759E-04    0.58374E-02    0.14614E+02
+    1    2    0.70346E-06    0.10000E+01    0.92637E+00    0.14562E+01    0.12987E-04    0.11150E-04    0.23831E-02    0.70530E-04    0.31100E+08    0.28967E+01    0.50000E+03    0.39870E-17    0.10428E-03    0.58374E-02    0.14614E+02
+    1    2    0.12275E-05    0.10000E+01    0.92637E+00    0.14562E+01    0.39544E-04    0.19456E-04    0.41584E-02    0.70530E-04    0.54267E+08    0.50545E+01    0.50000E+03    0.69571E-17    0.18196E-03    0.58374E-02    0.14614E+02
+    1    2    0.21419E-05    0.10000E+01    0.92637E+00    0.14562E+01    0.12041E-03    0.33950E-04    0.72562E-02    0.70530E-04    0.94693E+08    0.88198E+01    0.50000E+03    0.12140E-16    0.31750E-03    0.58374E-02    0.14614E+02
+    1    2    0.37375E-05    0.10000E+01    0.92637E+00    0.14562E+01    0.36661E-03    0.59240E-04    0.12662E-01    0.70530E-04    0.16523E+09    0.15390E+02    0.50000E+03    0.21183E-16    0.55402E-03    0.58374E-02    0.14614E+02
+    1    2    0.65217E-05    0.10000E+01    0.92637E+00    0.14562E+01    0.11163E-02    0.10337E-03    0.22094E-01    0.70530E-04    0.28832E+09    0.26855E+02    0.50000E+03    0.36963E-16    0.96674E-03    0.58374E-02    0.14614E+02
+    1    2    0.11380E-04    0.10000E+01    0.92637E+00    0.14562E+01    0.33988E-02    0.18038E-03    0.38552E-01    0.70530E-04    0.50310E+09    0.46860E+02    0.50000E+03    0.64499E-16    0.16869E-02    0.58374E-02    0.14614E+02
+    1    2    0.19857E-04    0.10000E+01    0.92637E+00    0.14562E+01    0.10349E-01    0.31474E-03    0.67271E-01    0.70530E-04    0.87789E+09    0.81767E+02    0.50000E+03    0.11255E-15    0.29435E-02    0.58374E-02    0.14614E+02
+    1    2    0.34650E-04    0.10000E+01    0.92637E+00    0.14562E+01    0.31510E-01    0.54921E-03    0.11738E+00    0.70530E-04    0.15319E+10    0.14268E+03    0.50000E+03    0.19639E-15    0.51363E-02    0.58374E-02    0.14614E+02
+    1    2    0.60462E-04    0.10000E+01    0.92637E+00    0.14562E+01    0.95942E-01    0.95834E-03    0.20483E+00    0.70530E-04    0.26730E+10    0.24897E+03    0.50000E+03    0.34268E-15    0.89625E-02    0.58374E-02    0.14614E+02
+    1    2    0.10550E-03    0.10000E+01    0.92637E+00    0.14562E+01    0.29213E+00    0.16722E-02    0.35741E+00    0.70530E-04    0.46642E+10    0.43443E+03    0.50000E+03    0.59796E-15    0.15639E-01    0.58374E-02    0.14614E+02
+    1    2    0.18409E-03    0.10000E+01    0.92637E+00    0.14562E+01    0.88947E+00    0.29180E-02    0.62367E+00    0.70530E-04    0.81388E+10    0.75805E+03    0.50000E+03    0.10434E-14    0.27289E-01    0.58374E-02    0.14614E+02
+    1    2    0.32123E-03    0.10000E+01    0.92637E+00    0.14562E+01    0.27083E+01    0.50917E-02    0.10883E+01    0.70530E-04    0.14202E+11    0.13228E+04    0.50000E+03    0.18207E-14    0.47618E-01    0.58374E-02    0.14614E+02
+    1    2    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    1    2    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    1    2    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    1    2    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    1    2    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    1    2    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    1    2    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    1    2    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    1    2    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    1    2    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    1    2    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    1    2    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    1    2    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    1    2    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    1    2    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    1    2    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    1    2    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    1    2    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    1    2    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    1    2    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    1    2    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    1    2    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    1    2    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    1    2    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    1    2    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    1    2    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    1    2    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    1    2    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    1    2    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    1    2    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    1    2    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    1    2    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    1    2    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    1    2    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    1    2    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    1    2    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    1    2    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    1    2    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    1    2    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    1    2    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    1    2    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    1    2    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    1    2    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    1    2    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    1    2    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    1    2    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    1    2    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    1    2    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    1    2    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    1    2    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    1    2    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    1    2    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    1    2    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    1    2    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    1    2    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    1    2    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    1    2    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    1    2    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    1    2    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    1    2    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    1    2    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    1    2    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    1    2    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    1    2    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    1    2    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    1    2    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    1    2    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    1    2    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    1    2    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    1    2    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    1    2    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    1    2    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    1    2    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    1    2    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    1    2    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    1    2    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    1    2    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    1    2    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    1    2    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    1    2    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    1    2    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    1    2    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    1    2    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    1    2    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    1    2    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    1    2    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    1    2    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    1    2    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    1    2    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    1    2    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    1    2    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    1    2    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    1    2    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    1    2    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    1    2    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    1    2    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    1    2    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    1    2    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    1    2    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    1    2    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    1    2    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    1    2    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    1    2    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    1    2    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    1    2    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    1    2    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    1    2    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    1    2    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    1    2    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    1    2    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    1    2    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    1    2    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    1    2    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    1    2    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    1    2    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    1    2    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    1    2    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    1    2    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    1    2    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    1    2    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    1    2    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    1    2    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    1    2    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    1    2    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    1    2    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    1    2    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    1    2    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    1    2    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    1    2    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    1    2    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    1    2    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    1    2    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    1    2    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    1    2    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    1    2    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    1    2    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    1    2    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    1    2    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    1    2    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    1    2    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    1    2    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    1    2    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    1    2    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    1    2    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    1    2    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    1    2    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    1    2    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    1    2    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    1    2    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    1    2    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    1    2    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    1    2    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    1    2    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    1    2    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    1    2    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    1    2    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    1    2    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    1    2    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    1    2    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    1    2    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    1    2    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    1    2    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    1    2    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    1    2    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    1    2    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    1    2    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    1    2    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    1    2    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    1    2    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    1    2    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    1    2    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    1    2    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    1    2    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    1    2    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    1    2    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    1    2    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    1    2    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    1    2    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    1    2    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    1    2    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    1    2    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    1    2    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    1    2    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    1    2    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    1    2    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    1    2    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    1    2    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    1    2    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    1    2    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    1    2    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    1    2    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    1    2    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    1    2    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    1    2    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    1    2    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    1    2    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    1    2    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    1    2    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    1    2    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    1    2    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    1    2    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    1    2    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    1    2    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    1    2    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    1    2    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    1    2    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    1    2    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    1    2    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    1    2    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    1    2    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    1    2    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    1    2    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    1    2    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    1    2    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    1    2    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    1    2    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    1    2    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    1    2    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    1    2    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    1    2    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    1    2    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    1    2    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    1    2    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    1    2    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    1    2    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    1    2    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    1    2    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    1    2    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    1    2    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    1    2    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    1    2    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    1    2    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    1    2    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    1    2    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    1    2    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    1    2    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    1    2    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    1    2    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    1    2    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    1    2    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    1    2    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    1    2    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    1    2    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    1    2    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    1    2    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    1    2    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    1    2    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    1    2    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    1    2    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    1    2    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    1    2    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    1    2    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    1    2    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    1    2    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    1    2    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    1    2    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    1    2    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    1    2    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    1    2    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    1    2    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    1    2    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    1    2    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    1    2    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    1    2    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    1    2    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    1    2    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    1    2    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    1    2    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    1    2    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    1    2    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    1    2    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    1    2    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    1    2    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    1    2    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    1    2    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    1    2    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    1    2    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    1    2    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    1    2    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    1    2    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    1    2    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    1    2    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    1    2    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    1    2    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    1    2    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    1    2    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    1    2    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    1    2    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    1    2    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    1    2    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    1    2    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    1    2    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    1    2    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    1    2    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    1    2    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    1    2    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    1    2    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    1    2    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    1    2    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    1    2    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    1    2    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    1    2    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    1    2    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    1    2    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    1    2    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    1    2    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    1    2    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    1    2    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    1    2    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    1    2    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    1    2    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    1    2    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    1    2    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    1    2    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    1    2    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    1    2    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    1    2    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    1    2    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    1    2    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    1    2    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    1    2    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    1    2    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    1    2    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    1    2    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    1    2    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    1    2    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    1    2    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    1    2    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    1    2    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    1    2    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    1    2    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    1    2    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    1    2    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    1    2    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    1    2    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    1    2    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    1    2    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    1    2    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    1    2    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    1    2    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    1    2    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    1    2    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    1    2    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    1    2    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    1    2    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    1    2    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    1    2    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    1    2    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    1    2    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    1    2    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    1    2    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    1    2    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    1    2    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    1    2    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    1    2    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    1    2    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    1    2    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    1    2    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    1    2    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    1    2    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    1    2    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    1    2    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    1    2    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    1    2    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    1    2    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    1    2    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    1    2    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    1    2    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    1    2    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    1    2    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    1    2    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    1    2    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    1    2    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    1    2    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    1    2    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    1    2    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    1    2    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    1    2    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    1    2    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    1    2    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    1    2    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    1    2    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    1    2    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    1    2    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    1    2    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    1    2    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    1    2    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    1    2    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    1    2    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    1    2    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    1    2    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    1    2    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    1    2    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    1    2    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    1    2    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    1    2    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    1    2    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    1    2    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    1    2    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    1    2    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    1    2    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    1    2    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    1    2    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    1    2    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    1    2    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    1    2    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    1    2    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    1    2    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    1    2    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    1    2    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    1    2    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    1    2    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    1    2    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    1    2    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    1    2    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    1    2    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    1    2    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    1    2    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    1    2    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    1    2    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    1    2    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    1    2    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    1    2    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    1    2    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    1    2    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    1    2    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    1    2    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    1    2    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    1    2    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    1    2    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    1    2    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    1    2    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    1    2    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    1    2    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    1    2    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    1    2    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    1    2    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    1    2    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    1    2    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    1    2    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    1    2    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    1    2    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    1    2    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    1    2    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    1    2    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    1    2    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    1    2    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    1    2    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    1    2    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    1    2    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    1    2    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    1    2    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    1    2    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    1    2    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    1    2    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    1    2    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    1    2    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    1    2    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    1    2    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    1    2    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    1    2    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    1    2    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    1    2    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    1    2    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    1    2    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    1    2    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    1    2    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    1    2    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    1    2    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    1    2    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    1    2    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    1    2    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    1    2    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    1    2    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    1    2    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    1    2    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    1    2    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    1    2    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    1    2    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    1    2    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    1    2    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    1    2    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    1    2    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    1    2    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    1    2    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    1    2    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    1    2    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    1    2    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    1    2    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    1    2    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    1    2    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    1    2    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    1    2    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    1    2    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    1    2    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    1    2    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    1    2    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    1    2    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    1    2    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    1    2    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    1    2    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    1    2    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    1    2    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    1    2    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    1    2    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    1    2    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    1    2    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    1    2    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    1    2    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    1    2    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    1    2    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    1    2    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    1    2    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    1    2    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    1    2    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    1    2    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    1    2    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    1    2    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    1    2    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    1    2    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    1    2    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    1    2    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    1    2    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    1    2    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    1    2    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    1    2    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    1    2    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    1    2    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    1    2    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    1    2    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    1    2    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    1    2    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    1    2    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    1    2    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    1    2    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    1    2    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    1    2    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    1    2    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    1    2    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    1    2    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    1    2    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    1    2    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    1    2    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    1    2    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    1    2    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    1    2    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    1    2    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    1    2    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    1    2    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    1    2    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    1    2    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    1    2    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    1    2    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    1    2    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    1    2    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    1    2    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    1    2    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    1    2    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    1    2    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    1    2    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    1    2    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    1    2    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    1    2    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    1    2    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    1    2    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    1    2    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    1    2    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    1    2    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    1    2    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    1    2    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    1    2    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    1    2    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    1    2    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    1    2    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    1    2    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    1    2    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    1    2    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    1    2    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    1    2    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    1    2    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    1    2    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    1    2    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    1    2    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    1    2    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    1    2    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    1    2    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    1    2    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    1    2    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    1    2    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    1    2    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    1    2    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    1    2    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    1    2    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    1    2    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    1    2    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    1    2    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    1    2    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    1    2    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    1    2    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    1    2    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    1    2    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    1    2    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    1    2    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    1    2    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    1    2    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    1    2    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    1    2    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    1    2    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    1    2    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    1    2    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    1    2    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    1    2    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    1    2    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    1    2    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    1    2    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    1    2    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    1    2    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    1    2    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    1    2    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    1    2    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    1    2    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    1    2    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    1    2    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    1    2    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    1    2    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    1    2    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    1    2    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    1    2    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    1    2    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    1    2    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    1    2    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35525E-67
+    1    2    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31050E-66
+    1    2    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49297E-66    0.26759E-65
+    1    2    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20665E-64
+    1    2    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    1    2    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15327E-62
+    1    2    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    1    2    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30486E-60
+    1    2    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49479E-59
+    1    2    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76348E-58
+    1    2    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    1    2    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16341E-55
+    1    2    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    1    2    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33513E-53
+    1    2    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47754E-52
+    1    2    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86007E-46    0.21355E-49
+    1    2    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    1    2    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    1    2    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    1    2    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    1    2    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    1    2    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    1    2    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    1    2    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    1    2    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    1    2    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    1    2    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    1    2    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    1    2    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    1    2    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    1    2    0.95225E-10    0.10000E+01    0.80645E+05    0.53338E-57    0.41251E-68    0.10749E-66
+    1    2    0.95225E-10    0.10000E+01    0.65036E+05    0.46320E-56    0.66241E-67    0.94141E-66
+    1    2    0.95225E-10    0.10000E+01    0.52449E+05    0.40024E-55    0.93503E-66    0.81416E-65
+    1    2    0.95225E-10    0.10000E+01    0.42297E+05    0.31521E-54    0.15121E-64    0.62477E-64
+    1    2    0.95225E-10    0.10000E+01    0.34111E+05    0.26479E-53    0.31103E-63    0.46450E-63
+    1    2    0.95225E-10    0.10000E+01    0.27509E+05    0.27530E-52    0.84266E-62    0.36185E-62
+    1    2    0.95225E-10    0.10000E+01    0.22184E+05    0.37547E-51    0.26561E-60    0.35004E-61
+    1    2    0.95225E-10    0.10000E+01    0.17891E+05    0.59959E-50    0.82078E-59    0.47852E-60
+    1    2    0.95225E-10    0.10000E+01    0.14428E+05    0.96029E-49    0.23747E-57    0.76675E-59
+    1    2    0.95225E-10    0.10000E+01    0.11635E+05    0.14620E-47    0.65938E-56    0.12102E-57
+    1    2    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18298E-56
+    1    2    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49011E-53    0.26942E-55
+    1    2    0.95225E-10    0.10000E+01    0.61026E+04    0.43943E-44    0.13295E-51    0.39150E-54
+    1    2    0.95225E-10    0.10000E+01    0.49215E+04    0.62538E-43    0.35997E-50    0.56476E-53
+    1    2    0.95225E-10    0.10000E+01    0.39689E+04    0.88822E-42    0.97300E-49    0.81063E-52
+    1    2    0.95225E-10    0.10000E+01    0.32008E+04    0.39613E-39    0.84952E-46    0.36461E-49
+    1    2    0.95225E-10    0.10000E+01    0.25813E+04    0.29211E-30    0.14353E-36    0.27085E-40
+    1    2    0.95225E-10    0.10000E+01    0.20817E+04    0.55938E-14    0.12256E-19    0.52257E-24
+    1    2    0.95225E-10    0.10000E+01    0.16788E+04    0.18980E-08    0.18143E-13    0.17813E-18
+    1    2    0.95225E-10    0.10000E+01    0.13538E+04    0.40806E-08    0.68940E-13    0.38357E-18
+    1    2    0.95225E-10    0.10000E+01    0.10918E+04    0.85761E-08    0.25711E-12    0.80708E-18
+    1    2    0.95225E-10    0.10000E+01    0.88049E+03    0.17636E-07    0.94670E-12    0.16610E-17
+    1    2    0.95225E-10    0.10000E+01    0.71007E+03    0.35560E-07    0.34475E-11    0.33511E-17
+    1    2    0.95225E-10    0.10000E+01    0.57264E+03    0.70490E-07    0.12266E-10    0.66454E-17
+    1    2    0.95225E-10    0.10000E+01    0.46180E+03    0.13745E-06    0.41255E-10    0.12961E-16
+    1    2    0.95225E-10    0.10000E+01    0.37242E+03    0.26237E-06    0.12579E-09    0.24744E-16
+    1    2    0.95225E-10    0.10000E+01    0.30034E+03    0.48462E-06    0.33740E-09    0.45710E-16
+    1    2    0.95225E-10    0.10000E+01    0.24221E+03    0.85384E-06    0.78780E-09    0.80539E-16
+    1    2    0.95225E-10    0.10000E+01    0.19533E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    1    2    0.95225E-10    0.10000E+01    0.15752E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    1    2    0.16616E-09    0.10000E+01    0.80645E+05    0.10831E-56    0.84134E-68    0.33649E-66
+    1    2    0.16616E-09    0.10000E+01    0.65036E+05    0.94382E-56    0.13505E-66    0.29209E-65
+    1    2    0.16616E-09    0.10000E+01    0.52449E+05    0.81476E-55    0.18599E-65    0.25174E-64
+    1    2    0.16616E-09    0.10000E+01    0.42297E+05    0.62646E-54    0.26584E-64    0.19203E-63
+    1    2    0.16616E-09    0.10000E+01    0.34111E+05    0.47293E-53    0.41443E-63    0.13945E-62
+    1    2    0.16616E-09    0.10000E+01    0.27509E+05    0.38376E-52    0.82703E-62    0.99836E-62
+    1    2    0.16616E-09    0.10000E+01    0.22184E+05    0.38951E-51    0.23108E-60    0.77606E-61
+    1    2    0.16616E-09    0.10000E+01    0.17891E+05    0.53703E-50    0.71872E-59    0.82846E-60
+    1    2    0.16616E-09    0.10000E+01    0.14428E+05    0.84667E-49    0.21403E-57    0.12129E-58
+    1    2    0.16616E-09    0.10000E+01    0.11635E+05    0.13169E-47    0.60847E-56    0.19194E-57
+    1    2    0.16616E-09    0.10000E+01    0.93834E+04    0.19721E-46    0.16918E-54    0.29611E-56
+    1    2    0.16616E-09    0.10000E+01    0.75673E+04    0.28850E-45    0.46590E-53    0.44363E-55
+    1    2    0.16616E-09    0.10000E+01    0.61026E+04    0.41726E-44    0.12762E-51    0.65289E-54
+    1    2    0.16616E-09    0.10000E+01    0.49215E+04    0.59980E-43    0.34818E-50    0.95065E-53
+    1    2    0.16616E-09    0.10000E+01    0.39689E+04    0.85857E-42    0.94687E-49    0.13742E-51
+    1    2    0.16616E-09    0.10000E+01    0.32008E+04    0.38534E-39    0.83094E-46    0.62162E-49
+    1    2    0.16616E-09    0.10000E+01    0.25813E+04    0.28572E-30    0.14110E-36    0.46404E-40
+    1    2    0.16616E-09    0.10000E+01    0.20817E+04    0.55023E-14    0.12112E-19    0.89981E-24
+    1    2    0.16616E-09    0.10000E+01    0.16788E+04    0.18735E-08    0.17967E-13    0.30768E-18
+    1    2    0.16616E-09    0.10000E+01    0.13538E+04    0.40327E-08    0.68292E-13    0.66322E-18
+    1    2    0.16616E-09    0.10000E+01    0.10918E+04    0.84828E-08    0.25473E-12    0.13965E-17
+    1    2    0.16616E-09    0.10000E+01    0.88049E+03    0.17454E-07    0.93805E-12    0.28757E-17
+    1    2    0.16616E-09    0.10000E+01    0.71007E+03    0.35210E-07    0.34161E-11    0.58040E-17
+    1    2    0.16616E-09    0.10000E+01    0.57264E+03    0.69816E-07    0.12154E-10    0.11512E-16
+    1    2    0.16616E-09    0.10000E+01    0.46180E+03    0.13616E-06    0.40880E-10    0.22458E-16
+    1    2    0.16616E-09    0.10000E+01    0.37242E+03    0.25994E-06    0.12465E-09    0.42878E-16
+    1    2    0.16616E-09    0.10000E+01    0.30034E+03    0.48017E-06    0.33433E-09    0.79212E-16
+    1    2    0.16616E-09    0.10000E+01    0.24221E+03    0.84602E-06    0.78064E-09    0.13957E-15
+    1    2    0.16616E-09    0.10000E+01    0.19533E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    1    2    0.16616E-09    0.10000E+01    0.15752E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    1    2    0.28994E-09    0.10000E+01    0.80645E+05    0.22011E-56    0.16920E-67    0.11249E-65
+    1    2    0.28994E-09    0.10000E+01    0.65036E+05    0.19023E-55    0.27099E-66    0.96503E-65
+    1    2    0.28994E-09    0.10000E+01    0.52449E+05    0.16355E-54    0.36930E-65    0.82631E-64
+    1    2    0.28994E-09    0.10000E+01    0.42297E+05    0.12449E-53    0.50576E-64    0.62542E-63
+    1    2    0.28994E-09    0.10000E+01    0.34111E+05    0.90534E-53    0.69149E-63    0.44950E-62
+    1    2    0.28994E-09    0.10000E+01    0.27509E+05    0.65403E-52    0.10276E-61    0.31368E-61
+    1    2    0.28994E-09    0.10000E+01    0.22184E+05    0.51145E-51    0.21678E-60    0.21734E-60
+    1    2    0.28994E-09    0.10000E+01    0.17891E+05    0.53350E-50    0.62717E-59    0.17681E-59
+    1    2    0.28994E-09    0.10000E+01    0.14428E+05    0.75573E-49    0.19028E-57    0.20765E-58
+    1    2    0.28994E-09    0.10000E+01    0.11635E+05    0.11751E-47    0.55601E-56    0.31026E-57
+    1    2    0.28994E-09    0.10000E+01    0.93834E+04    0.17997E-46    0.15781E-54    0.48192E-56
+    1    2    0.28994E-09    0.10000E+01    0.75673E+04    0.26865E-45    0.44099E-53    0.73307E-55
+    1    2    0.28994E-09    0.10000E+01    0.61026E+04    0.39444E-44    0.12210E-51    0.10917E-53
+    1    2    0.28994E-09    0.10000E+01    0.49215E+04    0.57333E-43    0.33588E-50    0.16029E-52
+    1    2    0.28994E-09    0.10000E+01    0.39689E+04    0.82768E-42    0.91939E-49    0.23314E-51
+    1    2    0.28994E-09    0.10000E+01    0.32008E+04    0.37400E-39    0.81127E-46    0.10597E-48
+    1    2    0.28994E-09    0.10000E+01    0.25813E+04    0.27896E-30    0.13850E-36    0.79454E-40
+    1    2    0.28994E-09    0.10000E+01    0.20817E+04    0.54048E-14    0.11957E-19    0.15478E-23
+    1    2    0.28994E-09    0.10000E+01    0.16788E+04    0.18472E-08    0.17777E-13    0.53075E-18
+    1    2    0.28994E-09    0.10000E+01    0.13538E+04    0.39812E-08    0.67591E-13    0.11451E-17
+    1    2    0.28994E-09    0.10000E+01    0.10918E+04    0.83822E-08    0.25216E-12    0.24130E-17
+    1    2    0.28994E-09    0.10000E+01    0.88049E+03    0.17259E-07    0.92865E-12    0.49712E-17
+    1    2    0.28994E-09    0.10000E+01    0.71007E+03    0.34831E-07    0.33820E-11    0.10037E-16
+    1    2    0.28994E-09    0.10000E+01    0.57264E+03    0.69086E-07    0.12033E-10    0.19913E-16
+    1    2    0.28994E-09    0.10000E+01    0.46180E+03    0.13476E-06    0.40472E-10    0.38849E-16
+    1    2    0.28994E-09    0.10000E+01    0.37242E+03    0.25730E-06    0.12341E-09    0.74180E-16
+    1    2    0.28994E-09    0.10000E+01    0.30034E+03    0.47533E-06    0.33100E-09    0.13705E-15
+    1    2    0.28994E-09    0.10000E+01    0.24221E+03    0.83753E-06    0.77285E-09    0.24148E-15
+    1    2    0.28994E-09    0.10000E+01    0.19533E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    1    2    0.28994E-09    0.10000E+01    0.15752E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    1    2    0.50593E-09    0.10000E+01    0.80645E+05    0.44926E-56    0.34079E-67    0.39232E-65
+    1    2    0.50593E-09    0.10000E+01    0.65036E+05    0.38422E-55    0.54341E-66    0.33355E-64
+    1    2    0.50593E-09    0.10000E+01    0.52449E+05    0.32834E-54    0.73364E-65    0.28402E-63
+    1    2    0.50593E-09    0.10000E+01    0.42297E+05    0.24795E-53    0.99037E-64    0.21350E-62
+    1    2    0.50593E-09    0.10000E+01    0.34111E+05    0.17797E-52    0.13099E-62    0.15247E-61
+    1    2    0.50593E-09    0.10000E+01    0.27509E+05    0.12441E-51    0.16902E-61    0.10586E-60
+    1    2    0.50593E-09    0.10000E+01    0.22184E+05    0.86010E-51    0.25710E-60    0.70603E-60
+    1    2    0.50593E-09    0.10000E+01    0.17891E+05    0.67638E-50    0.58946E-59    0.47985E-59
+    1    2    0.50593E-09    0.10000E+01    0.14428E+05    0.74782E-49    0.17213E-57    0.41577E-58
+    1    2    0.50593E-09    0.10000E+01    0.11635E+05    0.10801E-47    0.51285E-56    0.52474E-57
+    1    2    0.50593E-09    0.10000E+01    0.93834E+04    0.16626E-46    0.14855E-54    0.79304E-56
+    1    2    0.50593E-09    0.10000E+01    0.75673E+04    0.25254E-45    0.42087E-53    0.12189E-54
+    1    2    0.50593E-09    0.10000E+01    0.61026E+04    0.37597E-44    0.11762E-51    0.18356E-53
+    1    2    0.50593E-09    0.10000E+01    0.49215E+04    0.55185E-43    0.32580E-50    0.27151E-52
+    1    2    0.50593E-09    0.10000E+01    0.39689E+04    0.80238E-42    0.89663E-49    0.39684E-51
+    1    2    0.50593E-09    0.10000E+01    0.32008E+04    0.36462E-39    0.79485E-46    0.18106E-48
+    1    2    0.50593E-09    0.10000E+01    0.25813E+04    0.27333E-30    0.13633E-36    0.13622E-39
+    1    2    0.50593E-09    0.10000E+01    0.20817E+04    0.53238E-14    0.11828E-19    0.26638E-23
+    1    2    0.50593E-09    0.10000E+01    0.16788E+04    0.18256E-08    0.17620E-13    0.91573E-18
+    1    2    0.50593E-09    0.10000E+01    0.13538E+04    0.39387E-08    0.67015E-13    0.19773E-17
+    1    2    0.50593E-09    0.10000E+01    0.10918E+04    0.82993E-08    0.25005E-12    0.41688E-17
+    1    2    0.50593E-09    0.10000E+01    0.88049E+03    0.17098E-07    0.92093E-12    0.85921E-17
+    1    2    0.50593E-09    0.10000E+01    0.71007E+03    0.34520E-07    0.33539E-11    0.17352E-16
+    1    2    0.50593E-09    0.10000E+01    0.57264E+03    0.68486E-07    0.11933E-10    0.34432E-16
+    1    2    0.50593E-09    0.10000E+01    0.46180E+03    0.13362E-06    0.40135E-10    0.67183E-16
+    1    2    0.50593E-09    0.10000E+01    0.37242E+03    0.25513E-06    0.12238E-09    0.12829E-15
+    1    2    0.50593E-09    0.10000E+01    0.30034E+03    0.47134E-06    0.32824E-09    0.23702E-15
+    1    2    0.50593E-09    0.10000E+01    0.24221E+03    0.83053E-06    0.76641E-09    0.41764E-15
+    1    2    0.50593E-09    0.10000E+01    0.19533E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    1    2    0.50593E-09    0.10000E+01    0.15752E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    1    2    0.88282E-09    0.10000E+01    0.80645E+05    0.91476E-56    0.68731E-67    0.13789E-64
+    1    2    0.88282E-09    0.10000E+01    0.65036E+05    0.77641E-55    0.10919E-65    0.11662E-63
+    1    2    0.88282E-09    0.10000E+01    0.52449E+05    0.66035E-54    0.14632E-64    0.98963E-63
+    1    2    0.88282E-09    0.10000E+01    0.42297E+05    0.49567E-53    0.19615E-63    0.74065E-62
+    1    2    0.88282E-09    0.10000E+01    0.34111E+05    0.35353E-52    0.25848E-62    0.52675E-61
+    1    2    0.88282E-09    0.10000E+01    0.27509E+05    0.24558E-51    0.32187E-61    0.36567E-60
+    1    2    0.88282E-09    0.10000E+01    0.22184E+05    0.16393E-50    0.40073E-60    0.24273E-59
+    1    2    0.88282E-09    0.10000E+01    0.17891E+05    0.10961E-49    0.65251E-59    0.15348E-58
+    1    2    0.88282E-09    0.10000E+01    0.14428E+05    0.89454E-49    0.16244E-57    0.10392E-57
+    1    2    0.88282E-09    0.10000E+01    0.11635E+05    0.10618E-47    0.47991E-56    0.98632E-57
+    1    2    0.88282E-09    0.10000E+01    0.93834E+04    0.15701E-46    0.14156E-54    0.13418E-55
+    1    2    0.88282E-09    0.10000E+01    0.75673E+04    0.24062E-45    0.40636E-53    0.20503E-54
+    1    2    0.88282E-09    0.10000E+01    0.61026E+04    0.36255E-44    0.11442E-51    0.31177E-53
+    1    2    0.88282E-09    0.10000E+01    0.49215E+04    0.53641E-43    0.31845E-50    0.46407E-52
+    1    2    0.88282E-09    0.10000E+01    0.39689E+04    0.78393E-42    0.87953E-49    0.68035E-51
+    1    2    0.88282E-09    0.10000E+01    0.32008E+04    0.35759E-39    0.78214E-46    0.31094E-48
+    1    2    0.88282E-09    0.10000E+01    0.25813E+04    0.26899E-30    0.13461E-36    0.23432E-39
+    1    2    0.88282E-09    0.10000E+01    0.20817E+04    0.52599E-14    0.11724E-19    0.45928E-23
+    1    2    0.88282E-09    0.10000E+01    0.16788E+04    0.18083E-08    0.17491E-13    0.15815E-17
+    1    2    0.88282E-09    0.10000E+01    0.13538E+04    0.39044E-08    0.66538E-13    0.34162E-17
+    1    2    0.88282E-09    0.10000E+01    0.10918E+04    0.82318E-08    0.24829E-12    0.72050E-17
+    1    2    0.88282E-09    0.10000E+01    0.88049E+03    0.16966E-07    0.91446E-12    0.14853E-16
+    1    2    0.88282E-09    0.10000E+01    0.71007E+03    0.34263E-07    0.33303E-11    0.30001E-16
+    1    2    0.88282E-09    0.10000E+01    0.57264E+03    0.67988E-07    0.11849E-10    0.59535E-16
+    1    2    0.88282E-09    0.10000E+01    0.46180E+03    0.13266E-06    0.39851E-10    0.11617E-15
+    1    2    0.88282E-09    0.10000E+01    0.37242E+03    0.25331E-06    0.12151E-09    0.22183E-15
+    1    2    0.88282E-09    0.10000E+01    0.30034E+03    0.46799E-06    0.32591E-09    0.40983E-15
+    1    2    0.88282E-09    0.10000E+01    0.24221E+03    0.82463E-06    0.76096E-09    0.72214E-15
+    1    2    0.88282E-09    0.10000E+01    0.19533E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    1    2    0.88282E-09    0.10000E+01    0.15752E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    1    2    0.15405E-08    0.10000E+01    0.80645E+05    0.23034E-55    0.17173E-66    0.26666E-63
+    1    2    0.15405E-08    0.10000E+01    0.65036E+05    0.19430E-54    0.27196E-65    0.22434E-62
+    1    2    0.15405E-08    0.10000E+01    0.52449E+05    0.16462E-53    0.36241E-64    0.18968E-61
+    1    2    0.15405E-08    0.10000E+01    0.42297E+05    0.12301E-52    0.48467E-63    0.14126E-60
+    1    2    0.15405E-08    0.10000E+01    0.34111E+05    0.87550E-52    0.64744E-62    0.99955E-60
+    1    2    0.15405E-08    0.10000E+01    0.27509E+05    0.61409E-51    0.84030E-61    0.69457E-59
+    1    2    0.15405E-08    0.10000E+01    0.22184E+05    0.42200E-50    0.10717E-59    0.46759E-58
+    1    2    0.15405E-08    0.10000E+01    0.17891E+05    0.28605E-49    0.14663E-58    0.29803E-57
+    1    2    0.15405E-08    0.10000E+01    0.14428E+05    0.20426E-48    0.25481E-57    0.17758E-56
+    1    2    0.15405E-08    0.10000E+01    0.11635E+05    0.17712E-47    0.59325E-56    0.10250E-55
+    1    2    0.15405E-08    0.10000E+01    0.93834E+04    0.20270E-46    0.16066E-54    0.67252E-55
+    1    2    0.15405E-08    0.10000E+01    0.75673E+04    0.27766E-45    0.44817E-53    0.62938E-54
+    1    2    0.15405E-08    0.10000E+01    0.61026E+04    0.40167E-44    0.12401E-51    0.79547E-53
+    1    2    0.15405E-08    0.10000E+01    0.49215E+04    0.58214E-43    0.33969E-50    0.10967E-51
+    1    2    0.15405E-08    0.10000E+01    0.39689E+04    0.83704E-42    0.92491E-49    0.15099E-50
+    1    2    0.15405E-08    0.10000E+01    0.32008E+04    0.37632E-39    0.81234E-46    0.64803E-48
+    1    2    0.15405E-08    0.10000E+01    0.25813E+04    0.27936E-30    0.13816E-36    0.45986E-39
+    1    2    0.15405E-08    0.10000E+01    0.20817E+04    0.53916E-14    0.11889E-19    0.85065E-23
+    1    2    0.15405E-08    0.10000E+01    0.16788E+04    0.18395E-08    0.17655E-13    0.28371E-17
+    1    2    0.15405E-08    0.10000E+01    0.13538E+04    0.39601E-08    0.67110E-13    0.60382E-17
+    1    2    0.15405E-08    0.10000E+01    0.10918E+04    0.83320E-08    0.25030E-12    0.12605E-16
+    1    2    0.15405E-08    0.10000E+01    0.88049E+03    0.17147E-07    0.92160E-12    0.25797E-16
+    1    2    0.15405E-08    0.10000E+01    0.71007E+03    0.34592E-07    0.33557E-11    0.51829E-16
+    1    2    0.15405E-08    0.10000E+01    0.57264E+03    0.68592E-07    0.11938E-10    0.10245E-15
+    1    2    0.15405E-08    0.10000E+01    0.46180E+03    0.13377E-06    0.40148E-10    0.19933E-15
+    1    2    0.15405E-08    0.10000E+01    0.37242E+03    0.25535E-06    0.12241E-09    0.37981E-15
+    1    2    0.15405E-08    0.10000E+01    0.30034E+03    0.47165E-06    0.32832E-09    0.70065E-15
+    1    2    0.15405E-08    0.10000E+01    0.24221E+03    0.83097E-06    0.76658E-09    0.12333E-14
+    1    2    0.15405E-08    0.10000E+01    0.19533E+03    0.13096E-05    0.14567E-08    0.19426E-14
+    1    2    0.15405E-08    0.10000E+01    0.15752E+03    0.13096E-05    0.14567E-08    0.19426E-14
+    1    2    0.26880E-08    0.10000E+01    0.80645E+05    0.46241E-55    0.34411E-66    0.10620E-62
+    1    2    0.26880E-08    0.10000E+01    0.65036E+05    0.38949E-54    0.54445E-65    0.89267E-62
+    1    2    0.26880E-08    0.10000E+01    0.52449E+05    0.32961E-53    0.72383E-64    0.75419E-61
+    1    2    0.26880E-08    0.10000E+01    0.42297E+05    0.24584E-52    0.96434E-63    0.56094E-60
+    1    2    0.26880E-08    0.10000E+01    0.34111E+05    0.17440E-51    0.12806E-61    0.39611E-59
+    1    2    0.26880E-08    0.10000E+01    0.27509E+05    0.12167E-50    0.16397E-60    0.27444E-58
+    1    2    0.26880E-08    0.10000E+01    0.22184E+05    0.82594E-50    0.20034E-59    0.18404E-57
+    1    2    0.26880E-08    0.10000E+01    0.17891E+05    0.54006E-49    0.24273E-58    0.11668E-56
+    1    2    0.26880E-08    0.10000E+01    0.14428E+05    0.34919E-48    0.33950E-57    0.68938E-56
+    1    2    0.26880E-08    0.10000E+01    0.11635E+05    0.25019E-47    0.65943E-56    0.39029E-55
+    1    2    0.26880E-08    0.10000E+01    0.93834E+04    0.23590E-46    0.16744E-54    0.24238E-54
+    1    2    0.26880E-08    0.10000E+01    0.75673E+04    0.29445E-45    0.46186E-53    0.20517E-53
+    1    2    0.26880E-08    0.10000E+01    0.61026E+04    0.41541E-44    0.12727E-51    0.23538E-52
+    1    2    0.26880E-08    0.10000E+01    0.49215E+04    0.59755E-43    0.34641E-50    0.30005E-51
+    1    2    0.26880E-08    0.10000E+01    0.39689E+04    0.85372E-42    0.93657E-49    0.38373E-50
+    1    2    0.26880E-08    0.10000E+01    0.32008E+04    0.38117E-39    0.81739E-46    0.15279E-47
+    1    2    0.26880E-08    0.10000E+01    0.25813E+04    0.28112E-30    0.13826E-36    0.10035E-38
+    1    2    0.26880E-08    0.10000E+01    0.20817E+04    0.53942E-14    0.11836E-19    0.17042E-22
+    1    2    0.26880E-08    0.10000E+01    0.16788E+04    0.18350E-08    0.17544E-13    0.53821E-17
+    1    2    0.26880E-08    0.10000E+01    0.13538E+04    0.39444E-08    0.66659E-13    0.11176E-16
+    1    2    0.26880E-08    0.10000E+01    0.10918E+04    0.82902E-08    0.24854E-12    0.22917E-16
+    1    2    0.26880E-08    0.10000E+01    0.88049E+03    0.17048E-07    0.91485E-12    0.46295E-16
+    1    2    0.26880E-08    0.10000E+01    0.71007E+03    0.34375E-07    0.33304E-11    0.92129E-16
+    1    2    0.26880E-08    0.10000E+01    0.57264E+03    0.68132E-07    0.11846E-10    0.18084E-15
+    1    2    0.26880E-08    0.10000E+01    0.46180E+03    0.13283E-06    0.39836E-10    0.35003E-15
+    1    2    0.26880E-08    0.10000E+01    0.37242E+03    0.25349E-06    0.12145E-09    0.66452E-15
+    1    2    0.26880E-08    0.10000E+01    0.30034E+03    0.46814E-06    0.32573E-09    0.12227E-14
+    1    2    0.26880E-08    0.10000E+01    0.24221E+03    0.82467E-06    0.76053E-09    0.21485E-14
+    1    2    0.26880E-08    0.10000E+01    0.19533E+03    0.12996E-05    0.14452E-08    0.33805E-14
+    1    2    0.26880E-08    0.10000E+01    0.15752E+03    0.12996E-05    0.14452E-08    0.33805E-14
+    1    2    0.46905E-08    0.10000E+01    0.80645E+05    0.92701E-55    0.68895E-66    0.39853E-62
+    1    2    0.46905E-08    0.10000E+01    0.65036E+05    0.77999E-54    0.10892E-64    0.33502E-61
+    1    2    0.46905E-08    0.10000E+01    0.52449E+05    0.65953E-53    0.14456E-63    0.28308E-60
+    1    2    0.46905E-08    0.10000E+01    0.42297E+05    0.49122E-52    0.19208E-62    0.21060E-59
+    1    2    0.46905E-08    0.10000E+01    0.34111E+05    0.34767E-51    0.25410E-61    0.14880E-58
+    1    2    0.46905E-08    0.10000E+01    0.27509E+05    0.24170E-50    0.32302E-60    0.10322E-57
+    1    2    0.46905E-08    0.10000E+01    0.22184E+05    0.16302E-49    0.38678E-59    0.69404E-57
+    1    2    0.46905E-08    0.10000E+01    0.17891E+05    0.10479E-48    0.44027E-58    0.44230E-56
+    1    2    0.46905E-08    0.10000E+01    0.14428E+05    0.64467E-48    0.53049E-57    0.26327E-55
+    1    2    0.46905E-08    0.10000E+01    0.11635E+05    0.40885E-47    0.85151E-56    0.14923E-54
+    1    2    0.46905E-08    0.10000E+01    0.93834E+04    0.32109E-46    0.19475E-54    0.89508E-54
+    1    2    0.46905E-08    0.10000E+01    0.75673E+04    0.35149E-45    0.51870E-53    0.69169E-53
+    1    2    0.46905E-08    0.10000E+01    0.61026E+04    0.46983E-44    0.14006E-51    0.72513E-52
+    1    2    0.46905E-08    0.10000E+01    0.49215E+04    0.65869E-43    0.37341E-50    0.87043E-51
+    1    2    0.46905E-08    0.10000E+01    0.39689E+04    0.92133E-42    0.98936E-49    0.10571E-49
+    1    2    0.46905E-08    0.10000E+01    0.32008E+04    0.40310E-39    0.84807E-46    0.39681E-47
+    1    2    0.46905E-08    0.10000E+01    0.25813E+04    0.29175E-30    0.14111E-36    0.24216E-38
+    1    2    0.46905E-08    0.10000E+01    0.20817E+04    0.54991E-14    0.11883E-19    0.37230E-22
+    1    2    0.46905E-08    0.10000E+01    0.16788E+04    0.18523E-08    0.17505E-13    0.10907E-16
+    1    2    0.46905E-08    0.10000E+01    0.13538E+04    0.39637E-08    0.66430E-13    0.21794E-16
+    1    2    0.46905E-08    0.10000E+01    0.10918E+04    0.83049E-08    0.24746E-12    0.43395E-16
+    1    2    0.46905E-08    0.10000E+01    0.88049E+03    0.17041E-07    0.91028E-12    0.85724E-16
+    1    2    0.46905E-08    0.10000E+01    0.71007E+03    0.34305E-07    0.33122E-11    0.16774E-15
+    1    2    0.46905E-08    0.10000E+01    0.57264E+03    0.67912E-07    0.11777E-10    0.32509E-15
+    1    2    0.46905E-08    0.10000E+01    0.46180E+03    0.13228E-06    0.39597E-10    0.62333E-15
+    1    2    0.46905E-08    0.10000E+01    0.37242E+03    0.25229E-06    0.12071E-09    0.11753E-14
+    1    2    0.46905E-08    0.10000E+01    0.30034E+03    0.46571E-06    0.32371E-09    0.21521E-14
+    1    2    0.46905E-08    0.10000E+01    0.24221E+03    0.82013E-06    0.75578E-09    0.37692E-14
+    1    2    0.46905E-08    0.10000E+01    0.19533E+03    0.12922E-05    0.14362E-08    0.59190E-14
+    1    2    0.46905E-08    0.10000E+01    0.15752E+03    0.12922E-05    0.14362E-08    0.59190E-14
+    1    2    0.81846E-08    0.10000E+01    0.80645E+05    0.18156E-54    0.13485E-65    0.13224E-61
+    1    2    0.81846E-08    0.10000E+01    0.65036E+05    0.15269E-53    0.21314E-64    0.11126E-60
+    1    2    0.81846E-08    0.10000E+01    0.52449E+05    0.12906E-52    0.28267E-63    0.94081E-60
+    1    2    0.81846E-08    0.10000E+01    0.42297E+05    0.96070E-52    0.37518E-62    0.70089E-59
+    1    2    0.81846E-08    0.10000E+01    0.34111E+05    0.67934E-51    0.49572E-61    0.49648E-58
+    1    2    0.81846E-08    0.10000E+01    0.27509E+05    0.47173E-50    0.62901E-60    0.34592E-57
+    1    2    0.81846E-08    0.10000E+01    0.22184E+05    0.31760E-49    0.74878E-59    0.23440E-56
+    1    2    0.81846E-08    0.10000E+01    0.17891E+05    0.20313E-48    0.83243E-58    0.15141E-55
+    1    2    0.81846E-08    0.10000E+01    0.14428E+05    0.12264E-47    0.92767E-57    0.91985E-55
+    1    2    0.81846E-08    0.10000E+01    0.11635E+05    0.73198E-47    0.12788E-55    0.53085E-54
+    1    2    0.81846E-08    0.10000E+01    0.93834E+04    0.50404E-46    0.25692E-54    0.31137E-53
+    1    2    0.81846E-08    0.10000E+01    0.75673E+04    0.47870E-45    0.64405E-53    0.21691E-52
+    1    2    0.81846E-08    0.10000E+01    0.61026E+04    0.59016E-44    0.16778E-51    0.20221E-51
+    1    2    0.81846E-08    0.10000E+01    0.49215E+04    0.79182E-43    0.43225E-50    0.22881E-50
+    1    2    0.81846E-08    0.10000E+01    0.39689E+04    0.10689E-41    0.11068E-48    0.27081E-49
+    1    2    0.81846E-08    0.10000E+01    0.32008E+04    0.45183E-39    0.91877E-46    0.99141E-47
+    1    2    0.81846E-08    0.10000E+01    0.25813E+04    0.31617E-30    0.14811E-36    0.58086E-38
+    1    2    0.81846E-08    0.10000E+01    0.20817E+04    0.57578E-14    0.12061E-19    0.83137E-22
+    1    2    0.81846E-08    0.10000E+01    0.16788E+04    0.19005E-08    0.17530E-13    0.22831E-16
+    1    2    0.81846E-08    0.10000E+01    0.13538E+04    0.40296E-08    0.66358E-13    0.43784E-16
+    1    2    0.81846E-08    0.10000E+01    0.10918E+04    0.83883E-08    0.24674E-12    0.84310E-16
+    1    2    0.81846E-08    0.10000E+01    0.88049E+03    0.17132E-07    0.90642E-12    0.16214E-15
+    1    2    0.81846E-08    0.10000E+01    0.71007E+03    0.34372E-07    0.32951E-11    0.31063E-15
+    1    2    0.81846E-08    0.10000E+01    0.57264E+03    0.67877E-07    0.11709E-10    0.59218E-15
+    1    2    0.81846E-08    0.10000E+01    0.46180E+03    0.13197E-06    0.39352E-10    0.11213E-14
+    1    2    0.81846E-08    0.10000E+01    0.37242E+03    0.25137E-06    0.11993E-09    0.20945E-14
+    1    2    0.81846E-08    0.10000E+01    0.30034E+03    0.46358E-06    0.32159E-09    0.38100E-14
+    1    2    0.81846E-08    0.10000E+01    0.24221E+03    0.81588E-06    0.75077E-09    0.66425E-14
+    1    2    0.81846E-08    0.10000E+01    0.19533E+03    0.12850E-05    0.14266E-08    0.10402E-13
+    1    2    0.81846E-08    0.10000E+01    0.15752E+03    0.12850E-05    0.14266E-08    0.10402E-13
+    1    2    0.14282E-07    0.10000E+01    0.80645E+05    0.34323E-54    0.25497E-65    0.39604E-61
+    1    2    0.14282E-07    0.10000E+01    0.65036E+05    0.28870E-53    0.40305E-64    0.33357E-60
+    1    2    0.14282E-07    0.10000E+01    0.52449E+05    0.24406E-52    0.53475E-63    0.28234E-59
+    1    2    0.14282E-07    0.10000E+01    0.42297E+05    0.18173E-51    0.71033E-62    0.21072E-58
+    1    2    0.14282E-07    0.10000E+01    0.34111E+05    0.12859E-50    0.94005E-61    0.14975E-57
+    1    2    0.14282E-07    0.10000E+01    0.27509E+05    0.89416E-50    0.11967E-59    0.10492E-56
+    1    2    0.14282E-07    0.10000E+01    0.22184E+05    0.60360E-49    0.14318E-58    0.71773E-56
+    1    2    0.14282E-07    0.10000E+01    0.17891E+05    0.38757E-48    0.15946E-57    0.47122E-55
+    1    2    0.14282E-07    0.10000E+01    0.14428E+05    0.23430E-47    0.17297E-56    0.29344E-54
+    1    2    0.14282E-07    0.10000E+01    0.11635E+05    0.13713E-46    0.21491E-55    0.17390E-53
+    1    2    0.14282E-07    0.10000E+01    0.93834E+04    0.87125E-46    0.37436E-54    0.10158E-52
+    1    2    0.14282E-07    0.10000E+01    0.75673E+04    0.72281E-45    0.86112E-53    0.64688E-52
+    1    2    0.14282E-07    0.10000E+01    0.61026E+04    0.80368E-44    0.21461E-51    0.52136E-51
+    1    2    0.14282E-07    0.10000E+01    0.49215E+04    0.10193E-42    0.53289E-50    0.54071E-50
+    1    2    0.14282E-07    0.10000E+01    0.39689E+04    0.13217E-41    0.13123E-48    0.62589E-49
+    1    2    0.14282E-07    0.10000E+01    0.32008E+04    0.53685E-39    0.10456E-45    0.22824E-46
+    1    2    0.14282E-07    0.10000E+01    0.25813E+04    0.35981E-30    0.16113E-36    0.13193E-37
+    1    2    0.14282E-07    0.10000E+01    0.20817E+04    0.62382E-14    0.12439E-19    0.18178E-21
+    1    2    0.14282E-07    0.10000E+01    0.16788E+04    0.19953E-08    0.17669E-13    0.47880E-16
+    1    2    0.14282E-07    0.10000E+01    0.13538E+04    0.41667E-08    0.66587E-13    0.88504E-16
+    1    2    0.14282E-07    0.10000E+01    0.10918E+04    0.85795E-08    0.24680E-12    0.16512E-15
+    1    2    0.14282E-07    0.10000E+01    0.88049E+03    0.17384E-07    0.90460E-12    0.30921E-15
+    1    2    0.14282E-07    0.10000E+01    0.71007E+03    0.34674E-07    0.32833E-11    0.57947E-15
+    1    2    0.14282E-07    0.10000E+01    0.57264E+03    0.68181E-07    0.11655E-10    0.10852E-14
+    1    2    0.14282E-07    0.10000E+01    0.46180E+03    0.13215E-06    0.39142E-10    0.20259E-14
+    1    2    0.14282E-07    0.10000E+01    0.37242E+03    0.25113E-06    0.11925E-09    0.37441E-14
+    1    2    0.14282E-07    0.10000E+01    0.30034E+03    0.46241E-06    0.31968E-09    0.67579E-14
+    1    2    0.14282E-07    0.10000E+01    0.24221E+03    0.81294E-06    0.74618E-09    0.11718E-13
+    1    2    0.14282E-07    0.10000E+01    0.19533E+03    0.12795E-05    0.14177E-08    0.18289E-13
+    1    2    0.14282E-07    0.10000E+01    0.15752E+03    0.12795E-05    0.14177E-08    0.18289E-13
+    1    2    0.24920E-07    0.10000E+01    0.80645E+05    0.62772E-54    0.46665E-65    0.11213E-60
+    1    2    0.24920E-07    0.10000E+01    0.65036E+05    0.52830E-53    0.73801E-64    0.94548E-60
+    1    2    0.24920E-07    0.10000E+01    0.52449E+05    0.44685E-52    0.98035E-63    0.80107E-59
+    1    2    0.24920E-07    0.10000E+01    0.42297E+05    0.33306E-51    0.13051E-61    0.59895E-58
+    1    2    0.24920E-07    0.10000E+01    0.34111E+05    0.23611E-50    0.17337E-60    0.42705E-57
+    1    2    0.24920E-07    0.10000E+01    0.27509E+05    0.16472E-49    0.22222E-59    0.30084E-56
+    1    2    0.24920E-07    0.10000E+01    0.22184E+05    0.11185E-48    0.26912E-58    0.20770E-55
+    1    2    0.24920E-07    0.10000E+01    0.17891E+05    0.72526E-48    0.30476E-57    0.13849E-54
+    1    2    0.24920E-07    0.10000E+01    0.14428E+05    0.44426E-47    0.33190E-56    0.88303E-54
+    1    2    0.24920E-07    0.10000E+01    0.11635E+05    0.26121E-46    0.38771E-55    0.53815E-53
+    1    2    0.24920E-07    0.10000E+01    0.93834E+04    0.15910E-45    0.58514E-54    0.31786E-52
+    1    2    0.24920E-07    0.10000E+01    0.75673E+04    0.11716E-44    0.11986E-52    0.19142E-51
+    1    2    0.24920E-07    0.10000E+01    0.61026E+04    0.11502E-43    0.28334E-51    0.13347E-50
+    1    2    0.24920E-07    0.10000E+01    0.49215E+04    0.13611E-42    0.68218E-50    0.12171E-49
+    1    2    0.24920E-07    0.10000E+01    0.39689E+04    0.16983E-41    0.16261E-48    0.13524E-48
+    1    2    0.24920E-07    0.10000E+01    0.32008E+04    0.66631E-39    0.12451E-45    0.49479E-46
+    1    2    0.24920E-07    0.10000E+01    0.25813E+04    0.42814E-30    0.18234E-36    0.28697E-37
+    1    2    0.24920E-07    0.10000E+01    0.20817E+04    0.70203E-14    0.13114E-19    0.39010E-21
+    1    2    0.24920E-07    0.10000E+01    0.16788E+04    0.21580E-08    0.18006E-13    0.10050E-15
+    1    2    0.24920E-07    0.10000E+01    0.13538E+04    0.44101E-08    0.67393E-13    0.17968E-15
+    1    2    0.24920E-07    0.10000E+01    0.10918E+04    0.89371E-08    0.24856E-12    0.32547E-15
+    1    2    0.24920E-07    0.10000E+01    0.88049E+03    0.17896E-07    0.90781E-12    0.59385E-15
+    1    2    0.24920E-07    0.10000E+01    0.71007E+03    0.35382E-07    0.32868E-11    0.10882E-14
+    1    2    0.24920E-07    0.10000E+01    0.57264E+03    0.69115E-07    0.11648E-10    0.19996E-14
+    1    2    0.24920E-07    0.10000E+01    0.46180E+03    0.13331E-06    0.39078E-10    0.36757E-14
+    1    2    0.24920E-07    0.10000E+01    0.37242E+03    0.25244E-06    0.11898E-09    0.67111E-14
+    1    2    0.24920E-07    0.10000E+01    0.30034E+03    0.46368E-06    0.31884E-09    0.12005E-13
+    1    2    0.24920E-07    0.10000E+01    0.24221E+03    0.81381E-06    0.74406E-09    0.20684E-13
+    1    2    0.24920E-07    0.10000E+01    0.19533E+03    0.12796E-05    0.14135E-08    0.32155E-13
+    1    2    0.24920E-07    0.10000E+01    0.15752E+03    0.12796E-05    0.14135E-08    0.32155E-13
+    1    2    0.43485E-07    0.10000E+01    0.80645E+05    0.11207E-53    0.83401E-65    0.31396E-60
+    1    2    0.43485E-07    0.10000E+01    0.65036E+05    0.94399E-53    0.13199E-63    0.26501E-59
+    1    2    0.43485E-07    0.10000E+01    0.52449E+05    0.79906E-52    0.17563E-62    0.22473E-58
+    1    2    0.43485E-07    0.10000E+01    0.42297E+05    0.59642E-51    0.23452E-61    0.16830E-57
+    1    2    0.43485E-07    0.10000E+01    0.34111E+05    0.42390E-50    0.31309E-60    0.12035E-56
+    1    2    0.43485E-07    0.10000E+01    0.27509E+05    0.29703E-49    0.40489E-59    0.85191E-56
+    1    2    0.43485E-07    0.10000E+01    0.22184E+05    0.20322E-48    0.49807E-58    0.59289E-55
+    1    2    0.43485E-07    0.10000E+01    0.17891E+05    0.13348E-47    0.57742E-57    0.40058E-54
+    1    2    0.43485E-07    0.10000E+01    0.14428E+05    0.83323E-47    0.64146E-56    0.26063E-53
+    1    2    0.43485E-07    0.10000E+01    0.11635E+05    0.49841E-46    0.72832E-55    0.16295E-52
+    1    2    0.43485E-07    0.10000E+01    0.93834E+04    0.29888E-45    0.96872E-54    0.98110E-52
+    1    2    0.43485E-07    0.10000E+01    0.75673E+04    0.20018E-44    0.17119E-52    0.57824E-51
+    1    2    0.43485E-07    0.10000E+01    0.61026E+04    0.17073E-43    0.37604E-51    0.36080E-50
+    1    2    0.43485E-07    0.10000E+01    0.49215E+04    0.18422E-42    0.88187E-50    0.28108E-49
+    1    2    0.43485E-07    0.10000E+01    0.39689E+04    0.22083E-41    0.20590E-48    0.28881E-48
+    1    2    0.43485E-07    0.10000E+01    0.32008E+04    0.84474E-39    0.15292E-45    0.10541E-45
+    1    2    0.43485E-07    0.10000E+01    0.25813E+04    0.52495E-30    0.21332E-36    0.61919E-37
+    1    2    0.43485E-07    0.10000E+01    0.20817E+04    0.81642E-14    0.14124E-19    0.84476E-21
+    1    2    0.43485E-07    0.10000E+01    0.16788E+04    0.24037E-08    0.18514E-13    0.21565E-15
+    1    2    0.43485E-07    0.10000E+01    0.13538E+04    0.47763E-08    0.68614E-13    0.37296E-15
+    1    2    0.43485E-07    0.10000E+01    0.10918E+04    0.94745E-08    0.25124E-12    0.65539E-15
+    1    2    0.43485E-07    0.10000E+01    0.88049E+03    0.18665E-07    0.91280E-12    0.11632E-14
+    1    2    0.43485E-07    0.10000E+01    0.71007E+03    0.36447E-07    0.32926E-11    0.20790E-14
+    1    2    0.43485E-07    0.10000E+01    0.57264E+03    0.70527E-07    0.11640E-10    0.37376E-14
+    1    2    0.43485E-07    0.10000E+01    0.46180E+03    0.13507E-06    0.38990E-10    0.67442E-14
+    1    2    0.43485E-07    0.10000E+01    0.37242E+03    0.25446E-06    0.11860E-09    0.12130E-13
+    1    2    0.43485E-07    0.10000E+01    0.30034E+03    0.46567E-06    0.31764E-09    0.21452E-13
+    1    2    0.43485E-07    0.10000E+01    0.24221E+03    0.81526E-06    0.74101E-09    0.36658E-13
+    1    2    0.43485E-07    0.10000E+01    0.19533E+03    0.12799E-05    0.14075E-08    0.56691E-13
+    1    2    0.43485E-07    0.10000E+01    0.15752E+03    0.12799E-05    0.14075E-08    0.56691E-13
+    1    2    0.75878E-07    0.10000E+01    0.80645E+05    0.19714E-53    0.14688E-64    0.89266E-60
+    1    2    0.75878E-07    0.10000E+01    0.65036E+05    0.16621E-52    0.23263E-63    0.75410E-59
+    1    2    0.75878E-07    0.10000E+01    0.52449E+05    0.14081E-51    0.31014E-62    0.63996E-58
+    1    2    0.75878E-07    0.10000E+01    0.42297E+05    0.10527E-50    0.41550E-61    0.47991E-57
+    1    2    0.75878E-07    0.10000E+01    0.34111E+05    0.75030E-50    0.55770E-60    0.34399E-56
+    1    2    0.75878E-07    0.10000E+01    0.27509E+05    0.52824E-49    0.72798E-59    0.24445E-55
+    1    2    0.75878E-07    0.10000E+01    0.22184E+05    0.36432E-48    0.91010E-58    0.17121E-54
+    1    2    0.75878E-07    0.10000E+01    0.17891E+05    0.24255E-47    0.10814E-56    0.11689E-53
+    1    2    0.75878E-07    0.10000E+01    0.14428E+05    0.15449E-46    0.12329E-55    0.77272E-53
+    1    2    0.75878E-07    0.10000E+01    0.11635E+05    0.94470E-46    0.13935E-54    0.49339E-52
+    1    2    0.75878E-07    0.10000E+01    0.93834E+04    0.56769E-45    0.16914E-53    0.30338E-51
+    1    2    0.75878E-07    0.10000E+01    0.75673E+04    0.35691E-44    0.25391E-52    0.17917E-50
+    1    2    0.75878E-07    0.10000E+01    0.61026E+04    0.26489E-43    0.50001E-51    0.10509E-49
+    1    2    0.75878E-07    0.10000E+01    0.49215E+04    0.25284E-42    0.11357E-49    0.70631E-49
+    1    2    0.75878E-07    0.10000E+01    0.39689E+04    0.28750E-41    0.26272E-48    0.64405E-48
+    1    2    0.75878E-07    0.10000E+01    0.32008E+04    0.10796E-38    0.19177E-45    0.23008E-45
+    1    2    0.75878E-07    0.10000E+01    0.25813E+04    0.65683E-30    0.25713E-36    0.13729E-36
+    1    2    0.75878E-07    0.10000E+01    0.20817E+04    0.97914E-14    0.15586E-19    0.19030E-20
+    1    2    0.75878E-07    0.10000E+01    0.16788E+04    0.27671E-08    0.19247E-13    0.48549E-15
+    1    2    0.75878E-07    0.10000E+01    0.13538E+04    0.53137E-08    0.70359E-13    0.81066E-15
+    1    2    0.75878E-07    0.10000E+01    0.10918E+04    0.10258E-07    0.25498E-12    0.13784E-14
+    1    2    0.75878E-07    0.10000E+01    0.88049E+03    0.19781E-07    0.91940E-12    0.23710E-14
+    1    2    0.75878E-07    0.10000E+01    0.71007E+03    0.37984E-07    0.32985E-11    0.41148E-14
+    1    2    0.75878E-07    0.10000E+01    0.57264E+03    0.72546E-07    0.11618E-10    0.71993E-14
+    1    2    0.75878E-07    0.10000E+01    0.46180E+03    0.13755E-06    0.38825E-10    0.12682E-13
+    1    2    0.75878E-07    0.10000E+01    0.37242E+03    0.25721E-06    0.11793E-09    0.22354E-13
+    1    2    0.75878E-07    0.10000E+01    0.30034E+03    0.46821E-06    0.31559E-09    0.38911E-13
+    1    2    0.75878E-07    0.10000E+01    0.24221E+03    0.81670E-06    0.73587E-09    0.65719E-13
+    1    2    0.75878E-07    0.10000E+01    0.19533E+03    0.12793E-05    0.13973E-08    0.10087E-12
+    1    2    0.75878E-07    0.10000E+01    0.15752E+03    0.12793E-05    0.13973E-08    0.10087E-12
+    1    2    0.13240E-06    0.10000E+01    0.80645E+05    0.34430E-53    0.25682E-64    0.25810E-59
+    1    2    0.13240E-06    0.10000E+01    0.65036E+05    0.29056E-52    0.40705E-63    0.21818E-58
+    1    2    0.13240E-06    0.10000E+01    0.52449E+05    0.24636E-51    0.54366E-62    0.18526E-57
+    1    2    0.13240E-06    0.10000E+01    0.42297E+05    0.18444E-50    0.73063E-61    0.13906E-56
+    1    2    0.13240E-06    0.10000E+01    0.34111E+05    0.13181E-49    0.98561E-60    0.99857E-56
+    1    2    0.13240E-06    0.10000E+01    0.27509E+05    0.93215E-49    0.12976E-58    0.71167E-55
+    1    2    0.13240E-06    0.10000E+01    0.22184E+05    0.64768E-48    0.16459E-57    0.50083E-54
+    1    2    0.13240E-06    0.10000E+01    0.17891E+05    0.43650E-47    0.19994E-56    0.34457E-53
+    1    2    0.13240E-06    0.10000E+01    0.14428E+05    0.28316E-46    0.23379E-55    0.23043E-52
+    1    2    0.13240E-06    0.10000E+01    0.11635E+05    0.17696E-45    0.26681E-54    0.14949E-51
+    1    2    0.13240E-06    0.10000E+01    0.93834E+04    0.10759E-44    0.30781E-53    0.93635E-51
+    1    2    0.13240E-06    0.10000E+01    0.75673E+04    0.65507E-44    0.39990E-52    0.56019E-50
+    1    2    0.13240E-06    0.10000E+01    0.61026E+04    0.43465E-43    0.68060E-51    0.32155E-49
+    1    2    0.13240E-06    0.10000E+01    0.49215E+04    0.35962E-42    0.14667E-49    0.19501E-48
+    1    2    0.13240E-06    0.10000E+01    0.39689E+04    0.37850E-41    0.33814E-48    0.15526E-47
+    1    2    0.13240E-06    0.10000E+01    0.32008E+04    0.13951E-38    0.24585E-45    0.52882E-45
+    1    2    0.13240E-06    0.10000E+01    0.25813E+04    0.84057E-30    0.32088E-36    0.31929E-36
+    1    2    0.13240E-06    0.10000E+01    0.20817E+04    0.12196E-13    0.17837E-19    0.45305E-20
+    1    2    0.13240E-06    0.10000E+01    0.16788E+04    0.33323E-08    0.20477E-13    0.11609E-14
+    1    2    0.13240E-06    0.10000E+01    0.13538E+04    0.61519E-08    0.73487E-13    0.18718E-14
+    1    2    0.13240E-06    0.10000E+01    0.10918E+04    0.11496E-07    0.26252E-12    0.30757E-14
+    1    2    0.13240E-06    0.10000E+01    0.88049E+03    0.21582E-07    0.93636E-12    0.51143E-14
+    1    2    0.13240E-06    0.10000E+01    0.71007E+03    0.40544E-07    0.33331E-11    0.85817E-14
+    1    2    0.13240E-06    0.10000E+01    0.57264E+03    0.76086E-07    0.11676E-10    0.14531E-13
+    1    2    0.13240E-06    0.10000E+01    0.46180E+03    0.14228E-06    0.38886E-10    0.24824E-13
+    1    2    0.13240E-06    0.10000E+01    0.37242E+03    0.26328E-06    0.11787E-09    0.42591E-13
+    1    2    0.13240E-06    0.10000E+01    0.30034E+03    0.47561E-06    0.31503E-09    0.72512E-13
+    1    2    0.13240E-06    0.10000E+01    0.24221E+03    0.82520E-06    0.73402E-09    0.12042E-12
+    1    2    0.13240E-06    0.10000E+01    0.19533E+03    0.12884E-05    0.13932E-08    0.18278E-12
+    1    2    0.13240E-06    0.10000E+01    0.15752E+03    0.12884E-05    0.13932E-08    0.18278E-12
+    1    2    0.23103E-06    0.10000E+01    0.80645E+05    0.59930E-53    0.44747E-64    0.75027E-59
+    1    2    0.23103E-06    0.10000E+01    0.65036E+05    0.50616E-52    0.70967E-63    0.63450E-58
+    1    2    0.23103E-06    0.10000E+01    0.52449E+05    0.42946E-51    0.94934E-62    0.53898E-57
+    1    2    0.23103E-06    0.10000E+01    0.42297E+05    0.32194E-50    0.12793E-60    0.40488E-56
+    1    2    0.23103E-06    0.10000E+01    0.34111E+05    0.23061E-49    0.17331E-59    0.29110E-55
+    1    2    0.23103E-06    0.10000E+01    0.27509E+05    0.16370E-48    0.22982E-58    0.20789E-54
+    1    2    0.23103E-06    0.10000E+01    0.22184E+05    0.11446E-47    0.29504E-57    0.14680E-53
+    1    2    0.23103E-06    0.10000E+01    0.17891E+05    0.77929E-47    0.36494E-56    0.10154E-52
+    1    2    0.23103E-06    0.10000E+01    0.14428E+05    0.51329E-46    0.43619E-55    0.68455E-52
+    1    2    0.23103E-06    0.10000E+01    0.11635E+05    0.32692E-45    0.50556E-54    0.44913E-51
+    1    2    0.23103E-06    0.10000E+01    0.93834E+04    0.20181E-44    0.57221E-53    0.28542E-50
+    1    2    0.23103E-06    0.10000E+01    0.75673E+04    0.12170E-43    0.67131E-52    0.17329E-49
+    1    2    0.23103E-06    0.10000E+01    0.61026E+04    0.75039E-43    0.97202E-51    0.99463E-49
+    1    2    0.23103E-06    0.10000E+01    0.49215E+04    0.54015E-42    0.19222E-49    0.57051E-48
+    1    2    0.23103E-06    0.10000E+01    0.39689E+04    0.51129E-41    0.44030E-48    0.40359E-47
+    1    2    0.23103E-06    0.10000E+01    0.32008E+04    0.18320E-38    0.32219E-45    0.12858E-44
+    1    2    0.23103E-06    0.10000E+01    0.25813E+04    0.11019E-29    0.41458E-36    0.77932E-36
+    1    2    0.23103E-06    0.10000E+01    0.20817E+04    0.15808E-13    0.21253E-19    0.11346E-19
+    1    2    0.23103E-06    0.10000E+01    0.16788E+04    0.42153E-08    0.22371E-13    0.29276E-14
+    1    2    0.23103E-06    0.10000E+01    0.13538E+04    0.74508E-08    0.78320E-13    0.45750E-14
+    1    2    0.23103E-06    0.10000E+01    0.10918E+04    0.13405E-07    0.27422E-12    0.72832E-14
+    1    2    0.23103E-06    0.10000E+01    0.88049E+03    0.24354E-07    0.96289E-12    0.11718E-13
+    1    2    0.23103E-06    0.10000E+01    0.71007E+03    0.44489E-07    0.33878E-11    0.18994E-13
+    1    2    0.23103E-06    0.10000E+01    0.57264E+03    0.81550E-07    0.11772E-10    0.31031E-13
+    1    2    0.23103E-06    0.10000E+01    0.46180E+03    0.14960E-06    0.38997E-10    0.51152E-13
+    1    2    0.23103E-06    0.10000E+01    0.37242E+03    0.27270E-06    0.11783E-09    0.84873E-13
+    1    2    0.23103E-06    0.10000E+01    0.30034E+03    0.48718E-06    0.31432E-09    0.14037E-12
+    1    2    0.23103E-06    0.10000E+01    0.24221E+03    0.83864E-06    0.73153E-09    0.22778E-12
+    1    2    0.23103E-06    0.10000E+01    0.19533E+03    0.13029E-05    0.13876E-08    0.34036E-12
+    1    2    0.23103E-06    0.10000E+01    0.15752E+03    0.13029E-05    0.13876E-08    0.34036E-12
+    1    2    0.40314E-06    0.10000E+01    0.80645E+05    0.10452E-52    0.78047E-64    0.13696E-58
+    1    2    0.40314E-06    0.10000E+01    0.65036E+05    0.88283E-52    0.12379E-62    0.11583E-57
+    1    2    0.40314E-06    0.10000E+01    0.52449E+05    0.74910E-51    0.16561E-61    0.98394E-57
+    1    2    0.40314E-06    0.10000E+01    0.42297E+05    0.56161E-50    0.22322E-60    0.73917E-56
+    1    2    0.40314E-06    0.10000E+01    0.34111E+05    0.40237E-49    0.30251E-59    0.53150E-55
+    1    2    0.40314E-06    0.10000E+01    0.27509E+05    0.28571E-48    0.40138E-58    0.37964E-54
+    1    2    0.40314E-06    0.10000E+01    0.22184E+05    0.19986E-47    0.51577E-57    0.26813E-53
+    1    2    0.40314E-06    0.10000E+01    0.17891E+05    0.13619E-46    0.63888E-56    0.18553E-52
+    1    2    0.40314E-06    0.10000E+01    0.14428E+05    0.89812E-46    0.76498E-55    0.12516E-51
+    1    2    0.40314E-06    0.10000E+01    0.11635E+05    0.57290E-45    0.88796E-54    0.82184E-51
+    1    2    0.40314E-06    0.10000E+01    0.93834E+04    0.35415E-44    0.10044E-52    0.52283E-50
+    1    2    0.40314E-06    0.10000E+01    0.75673E+04    0.21354E-43    0.11703E-51    0.31784E-49
+    1    2    0.40314E-06    0.10000E+01    0.61026E+04    0.13104E-42    0.16705E-50    0.18251E-48
+    1    2    0.40314E-06    0.10000E+01    0.49215E+04    0.93251E-42    0.32722E-49    0.10435E-47
+    1    2    0.40314E-06    0.10000E+01    0.39689E+04    0.87326E-41    0.74873E-48    0.73159E-47
+    1    2    0.40314E-06    0.10000E+01    0.32008E+04    0.31185E-38    0.54841E-45    0.23160E-44
+    1    2    0.40314E-06    0.10000E+01    0.25813E+04    0.18758E-29    0.70516E-36    0.14037E-35
+    1    2    0.40314E-06    0.10000E+01    0.20817E+04    0.26904E-13    0.35901E-19    0.20482E-19
+    1    2    0.40314E-06    0.10000E+01    0.16788E+04    0.71619E-08    0.37467E-13    0.52886E-14
+    1    2    0.40314E-06    0.10000E+01    0.13538E+04    0.12608E-07    0.13083E-12    0.82438E-14
+    1    2    0.40314E-06    0.10000E+01    0.10918E+04    0.22600E-07    0.45708E-12    0.13090E-13
+    1    2    0.40314E-06    0.10000E+01    0.88049E+03    0.40926E-07    0.16022E-11    0.21002E-13
+    1    2    0.40314E-06    0.10000E+01    0.71007E+03    0.74546E-07    0.56298E-11    0.33943E-13
+    1    2    0.40314E-06    0.10000E+01    0.57264E+03    0.13631E-06    0.19544E-10    0.55276E-13
+    1    2    0.40314E-06    0.10000E+01    0.46180E+03    0.24955E-06    0.64707E-10    0.90818E-13
+    1    2    0.40314E-06    0.10000E+01    0.37242E+03    0.45413E-06    0.19543E-09    0.15020E-12
+    1    2    0.40314E-06    0.10000E+01    0.30034E+03    0.81030E-06    0.52124E-09    0.24771E-12
+    1    2    0.40314E-06    0.10000E+01    0.24221E+03    0.13936E-05    0.12129E-08    0.40101E-12
+    1    2    0.40314E-06    0.10000E+01    0.19533E+03    0.21640E-05    0.23005E-08    0.59821E-12
+    1    2    0.40314E-06    0.10000E+01    0.15752E+03    0.21640E-05    0.23005E-08    0.59821E-12
+    1    2    0.70346E-06    0.10000E+01    0.80645E+05    0.18238E-52    0.13619E-63    0.23898E-58
+    1    2    0.70346E-06    0.10000E+01    0.65036E+05    0.15405E-51    0.21600E-62    0.20211E-57
+    1    2    0.70346E-06    0.10000E+01    0.52449E+05    0.13071E-50    0.28898E-61    0.17169E-56
+    1    2    0.70346E-06    0.10000E+01    0.42297E+05    0.97998E-50    0.38950E-60    0.12898E-55
+    1    2    0.70346E-06    0.10000E+01    0.34111E+05    0.70211E-49    0.52787E-59    0.92744E-55
+    1    2    0.70346E-06    0.10000E+01    0.27509E+05    0.49855E-48    0.70038E-58    0.66244E-54
+    1    2    0.70346E-06    0.10000E+01    0.22184E+05    0.34875E-47    0.89999E-57    0.46787E-53
+    1    2    0.70346E-06    0.10000E+01    0.17891E+05    0.23764E-46    0.11148E-55    0.32375E-52
+    1    2    0.70346E-06    0.10000E+01    0.14428E+05    0.15672E-45    0.13348E-54    0.21840E-51
+    1    2    0.70346E-06    0.10000E+01    0.11635E+05    0.99968E-45    0.15494E-53    0.14341E-50
+    1    2    0.70346E-06    0.10000E+01    0.93834E+04    0.61797E-44    0.17526E-52    0.91231E-50
+    1    2    0.70346E-06    0.10000E+01    0.75673E+04    0.37261E-43    0.20420E-51    0.55460E-49
+    1    2    0.70346E-06    0.10000E+01    0.61026E+04    0.22866E-42    0.29150E-50    0.31847E-48
+    1    2    0.70346E-06    0.10000E+01    0.49215E+04    0.16272E-41    0.57098E-49    0.18209E-47
+    1    2    0.70346E-06    0.10000E+01    0.39689E+04    0.15238E-40    0.13065E-47    0.12766E-46
+    1    2    0.70346E-06    0.10000E+01    0.32008E+04    0.54417E-38    0.95694E-45    0.40414E-44
+    1    2    0.70346E-06    0.10000E+01    0.25813E+04    0.32732E-29    0.12305E-35    0.24493E-35
+    1    2    0.70346E-06    0.10000E+01    0.20817E+04    0.46946E-13    0.62644E-19    0.35740E-19
+    1    2    0.70346E-06    0.10000E+01    0.16788E+04    0.12497E-07    0.65377E-13    0.92282E-14
+    1    2    0.70346E-06    0.10000E+01    0.13538E+04    0.21999E-07    0.22829E-12    0.14385E-13
+    1    2    0.70346E-06    0.10000E+01    0.10918E+04    0.39436E-07    0.79757E-12    0.22841E-13
+    1    2    0.70346E-06    0.10000E+01    0.88049E+03    0.71413E-07    0.27958E-11    0.36648E-13
+    1    2    0.70346E-06    0.10000E+01    0.71007E+03    0.13008E-06    0.98236E-11    0.59228E-13
+    1    2    0.70346E-06    0.10000E+01    0.57264E+03    0.23785E-06    0.34103E-10    0.96453E-13
+    1    2    0.70346E-06    0.10000E+01    0.46180E+03    0.43544E-06    0.11291E-09    0.15847E-12
+    1    2    0.70346E-06    0.10000E+01    0.37242E+03    0.79243E-06    0.34102E-09    0.26210E-12
+    1    2    0.70346E-06    0.10000E+01    0.30034E+03    0.14139E-05    0.90952E-09    0.43224E-12
+    1    2    0.70346E-06    0.10000E+01    0.24221E+03    0.24318E-05    0.21165E-08    0.69973E-12
+    1    2    0.70346E-06    0.10000E+01    0.19533E+03    0.37760E-05    0.40143E-08    0.10438E-11
+    1    2    0.70346E-06    0.10000E+01    0.15752E+03    0.37760E-05    0.40143E-08    0.10438E-11
+    1    2    0.12275E-05    0.10000E+01    0.80645E+05    0.31825E-52    0.23764E-63    0.41701E-58
+    1    2    0.12275E-05    0.10000E+01    0.65036E+05    0.26880E-51    0.37690E-62    0.35268E-57
+    1    2    0.12275E-05    0.10000E+01    0.52449E+05    0.22809E-50    0.50426E-61    0.29959E-56
+    1    2    0.12275E-05    0.10000E+01    0.42297E+05    0.17100E-49    0.67966E-60    0.22506E-55
+    1    2    0.12275E-05    0.10000E+01    0.34111E+05    0.12251E-48    0.92110E-59    0.16183E-54
+    1    2    0.12275E-05    0.10000E+01    0.27509E+05    0.86993E-48    0.12221E-57    0.11559E-53
+    1    2    0.12275E-05    0.10000E+01    0.22184E+05    0.60855E-47    0.15704E-56    0.81641E-53
+    1    2    0.12275E-05    0.10000E+01    0.17891E+05    0.41467E-46    0.19453E-55    0.56492E-52
+    1    2    0.12275E-05    0.10000E+01    0.14428E+05    0.27346E-45    0.23292E-54    0.38109E-51
+    1    2    0.12275E-05    0.10000E+01    0.11635E+05    0.17444E-44    0.27037E-53    0.25024E-50
+    1    2    0.12275E-05    0.10000E+01    0.93834E+04    0.10783E-43    0.30582E-52    0.15919E-49
+    1    2    0.12275E-05    0.10000E+01    0.75673E+04    0.65019E-43    0.35632E-51    0.96775E-49
+    1    2    0.12275E-05    0.10000E+01    0.61026E+04    0.39900E-42    0.50865E-50    0.55572E-48
+    1    2    0.12275E-05    0.10000E+01    0.49215E+04    0.28393E-41    0.99632E-49    0.31773E-47
+    1    2    0.12275E-05    0.10000E+01    0.39689E+04    0.26589E-40    0.22797E-47    0.22276E-46
+    1    2    0.12275E-05    0.10000E+01    0.32008E+04    0.94954E-38    0.16698E-44    0.70519E-44
+    1    2    0.12275E-05    0.10000E+01    0.25813E+04    0.57115E-29    0.21471E-35    0.42739E-35
+    1    2    0.12275E-05    0.10000E+01    0.20817E+04    0.81918E-13    0.10931E-18    0.62364E-19
+    1    2    0.12275E-05    0.10000E+01    0.16788E+04    0.21807E-07    0.11408E-12    0.16103E-13
+    1    2    0.12275E-05    0.10000E+01    0.13538E+04    0.38388E-07    0.39836E-12    0.25101E-13
+    1    2    0.12275E-05    0.10000E+01    0.10918E+04    0.68814E-07    0.13917E-11    0.39856E-13
+    1    2    0.12275E-05    0.10000E+01    0.88049E+03    0.12461E-06    0.48784E-11    0.63949E-13
+    1    2    0.12275E-05    0.10000E+01    0.71007E+03    0.22698E-06    0.17142E-10    0.10335E-12
+    1    2    0.12275E-05    0.10000E+01    0.57264E+03    0.41503E-06    0.59507E-10    0.16830E-12
+    1    2    0.12275E-05    0.10000E+01    0.46180E+03    0.75982E-06    0.19702E-09    0.27652E-12
+    1    2    0.12275E-05    0.10000E+01    0.37242E+03    0.13827E-05    0.59506E-09    0.45734E-12
+    1    2    0.12275E-05    0.10000E+01    0.30034E+03    0.24672E-05    0.15871E-08    0.75423E-12
+    1    2    0.12275E-05    0.10000E+01    0.24221E+03    0.42433E-05    0.36931E-08    0.12210E-11
+    1    2    0.12275E-05    0.10000E+01    0.19533E+03    0.65888E-05    0.70046E-08    0.18214E-11
+    1    2    0.12275E-05    0.10000E+01    0.15752E+03    0.65888E-05    0.70046E-08    0.18214E-11
+    1    2    0.21419E-05    0.10000E+01    0.80645E+05    0.55532E-52    0.41466E-63    0.72766E-58
+    1    2    0.21419E-05    0.10000E+01    0.65036E+05    0.46905E-51    0.65767E-62    0.61540E-57
+    1    2    0.21419E-05    0.10000E+01    0.52449E+05    0.39800E-50    0.87990E-61    0.52277E-56
+    1    2    0.21419E-05    0.10000E+01    0.42297E+05    0.29838E-49    0.11860E-59    0.39272E-55
+    1    2    0.21419E-05    0.10000E+01    0.34111E+05    0.21378E-48    0.16073E-58    0.28239E-54
+    1    2    0.21419E-05    0.10000E+01    0.27509E+05    0.15180E-47    0.21325E-57    0.20170E-53
+    1    2    0.21419E-05    0.10000E+01    0.22184E+05    0.10619E-46    0.27403E-56    0.14246E-52
+    1    2    0.21419E-05    0.10000E+01    0.17891E+05    0.72358E-46    0.33944E-55    0.98575E-52
+    1    2    0.21419E-05    0.10000E+01    0.14428E+05    0.47717E-45    0.40643E-54    0.66497E-51
+    1    2    0.21419E-05    0.10000E+01    0.11635E+05    0.30438E-44    0.47177E-53    0.43665E-50
+    1    2    0.21419E-05    0.10000E+01    0.93834E+04    0.18816E-43    0.53364E-52    0.27778E-49
+    1    2    0.21419E-05    0.10000E+01    0.75673E+04    0.11345E-42    0.62176E-51    0.16887E-48
+    1    2    0.21419E-05    0.10000E+01    0.61026E+04    0.69623E-42    0.88756E-50    0.96970E-48
+    1    2    0.21419E-05    0.10000E+01    0.49215E+04    0.49544E-41    0.17385E-48    0.55442E-47
+    1    2    0.21419E-05    0.10000E+01    0.39689E+04    0.46396E-40    0.39780E-47    0.38870E-46
+    1    2    0.21419E-05    0.10000E+01    0.32008E+04    0.16569E-37    0.29137E-44    0.12305E-43
+    1    2    0.21419E-05    0.10000E+01    0.25813E+04    0.99663E-29    0.37465E-35    0.74577E-35
+    1    2    0.21419E-05    0.10000E+01    0.20817E+04    0.14294E-12    0.19074E-18    0.10882E-18
+    1    2    0.21419E-05    0.10000E+01    0.16788E+04    0.38051E-07    0.19906E-12    0.28098E-13
+    1    2    0.21419E-05    0.10000E+01    0.13538E+04    0.66984E-07    0.69511E-12    0.43799E-13
+    1    2    0.21419E-05    0.10000E+01    0.10918E+04    0.12008E-06    0.24285E-11    0.69547E-13
+    1    2    0.21419E-05    0.10000E+01    0.88049E+03    0.21744E-06    0.85126E-11    0.11159E-12
+    1    2    0.21419E-05    0.10000E+01    0.71007E+03    0.39606E-06    0.29911E-10    0.18034E-12
+    1    2    0.21419E-05    0.10000E+01    0.57264E+03    0.72421E-06    0.10384E-09    0.29368E-12
+    1    2    0.21419E-05    0.10000E+01    0.46180E+03    0.13258E-05    0.34379E-09    0.48252E-12
+    1    2    0.21419E-05    0.10000E+01    0.37242E+03    0.24128E-05    0.10383E-08    0.79803E-12
+    1    2    0.21419E-05    0.10000E+01    0.30034E+03    0.43051E-05    0.27693E-08    0.13161E-11
+    1    2    0.21419E-05    0.10000E+01    0.24221E+03    0.74043E-05    0.64443E-08    0.21305E-11
+    1    2    0.21419E-05    0.10000E+01    0.19533E+03    0.11497E-04    0.12223E-07    0.31783E-11
+    1    2    0.21419E-05    0.10000E+01    0.15752E+03    0.11497E-04    0.12223E-07    0.31783E-11
+    1    2    0.37375E-05    0.10000E+01    0.80645E+05    0.96900E-52    0.72356E-63    0.12697E-57
+    1    2    0.37375E-05    0.10000E+01    0.65036E+05    0.81846E-51    0.11476E-61    0.10738E-56
+    1    2    0.37375E-05    0.10000E+01    0.52449E+05    0.69448E-50    0.15354E-60    0.91220E-56
+    1    2    0.37375E-05    0.10000E+01    0.42297E+05    0.52066E-49    0.20694E-59    0.68528E-55
+    1    2    0.37375E-05    0.10000E+01    0.34111E+05    0.37303E-48    0.28046E-58    0.49275E-54
+    1    2    0.37375E-05    0.10000E+01    0.27509E+05    0.26488E-47    0.37211E-57    0.35196E-53
+    1    2    0.37375E-05    0.10000E+01    0.22184E+05    0.18529E-46    0.47817E-56    0.24858E-52
+    1    2    0.37375E-05    0.10000E+01    0.17891E+05    0.12626E-45    0.59230E-55    0.17201E-51
+    1    2    0.37375E-05    0.10000E+01    0.14428E+05    0.83263E-45    0.70920E-54    0.11603E-50
+    1    2    0.37375E-05    0.10000E+01    0.11635E+05    0.53113E-44    0.82322E-53    0.76192E-50
+    1    2    0.37375E-05    0.10000E+01    0.93834E+04    0.32833E-43    0.93117E-52    0.48471E-49
+    1    2    0.37375E-05    0.10000E+01    0.75673E+04    0.19797E-42    0.10849E-50    0.29466E-48
+    1    2    0.37375E-05    0.10000E+01    0.61026E+04    0.12149E-41    0.15487E-49    0.16921E-47
+    1    2    0.37375E-05    0.10000E+01    0.49215E+04    0.86452E-41    0.30336E-48    0.96742E-47
+    1    2    0.37375E-05    0.10000E+01    0.39689E+04    0.80959E-40    0.69414E-47    0.67825E-46
+    1    2    0.37375E-05    0.10000E+01    0.32008E+04    0.28912E-37    0.50842E-44    0.21472E-43
+    1    2    0.37375E-05    0.10000E+01    0.25813E+04    0.17391E-28    0.65374E-35    0.13013E-34
+    1    2    0.37375E-05    0.10000E+01    0.20817E+04    0.24942E-12    0.33283E-18    0.18989E-18
+    1    2    0.37375E-05    0.10000E+01    0.16788E+04    0.66397E-07    0.34735E-12    0.49030E-13
+    1    2    0.37375E-05    0.10000E+01    0.13538E+04    0.11688E-06    0.12129E-11    0.76427E-13
+    1    2    0.37375E-05    0.10000E+01    0.10918E+04    0.20953E-06    0.42375E-11    0.12136E-12
+    1    2    0.37375E-05    0.10000E+01    0.88049E+03    0.37942E-06    0.14854E-10    0.19471E-12
+    1    2    0.37375E-05    0.10000E+01    0.71007E+03    0.69111E-06    0.52193E-10    0.31468E-12
+    1    2    0.37375E-05    0.10000E+01    0.57264E+03    0.12637E-05    0.18119E-09    0.51246E-12
+    1    2    0.37375E-05    0.10000E+01    0.46180E+03    0.23135E-05    0.59989E-09    0.84196E-12
+    1    2    0.37375E-05    0.10000E+01    0.37242E+03    0.42102E-05    0.18118E-08    0.13925E-11
+    1    2    0.37375E-05    0.10000E+01    0.30034E+03    0.75122E-05    0.48323E-08    0.22965E-11
+    1    2    0.37375E-05    0.10000E+01    0.24221E+03    0.12920E-04    0.11245E-07    0.37177E-11
+    1    2    0.37375E-05    0.10000E+01    0.19533E+03    0.20062E-04    0.21328E-07    0.55460E-11
+    1    2    0.37375E-05    0.10000E+01    0.15752E+03    0.20062E-04    0.21328E-07    0.55460E-11
+    1    2    0.65217E-05    0.10000E+01    0.80645E+05    0.16908E-51    0.12626E-62    0.22156E-57
+    1    2    0.65217E-05    0.10000E+01    0.65036E+05    0.14282E-50    0.20025E-61    0.18738E-56
+    1    2    0.65217E-05    0.10000E+01    0.52449E+05    0.12118E-49    0.26791E-60    0.15917E-55
+    1    2    0.65217E-05    0.10000E+01    0.42297E+05    0.90853E-49    0.36110E-59    0.11958E-54
+    1    2    0.65217E-05    0.10000E+01    0.34111E+05    0.65091E-48    0.48938E-58    0.85982E-54
+    1    2    0.65217E-05    0.10000E+01    0.27509E+05    0.46220E-47    0.64931E-57    0.61414E-53
+    1    2    0.65217E-05    0.10000E+01    0.22184E+05    0.32332E-46    0.83437E-56    0.43376E-52
+    1    2    0.65217E-05    0.10000E+01    0.17891E+05    0.22032E-45    0.10335E-54    0.30014E-51
+    1    2    0.65217E-05    0.10000E+01    0.14428E+05    0.14529E-44    0.12375E-53    0.20247E-50
+    1    2    0.65217E-05    0.10000E+01    0.11635E+05    0.92679E-44    0.14365E-52    0.13295E-49
+    1    2    0.65217E-05    0.10000E+01    0.93834E+04    0.57291E-43    0.16248E-51    0.84580E-49
+    1    2    0.65217E-05    0.10000E+01    0.75673E+04    0.34544E-42    0.18931E-50    0.51417E-48
+    1    2    0.65217E-05    0.10000E+01    0.61026E+04    0.21199E-41    0.27025E-49    0.29525E-47
+    1    2    0.65217E-05    0.10000E+01    0.49215E+04    0.15085E-40    0.52935E-48    0.16881E-46
+    1    2    0.65217E-05    0.10000E+01    0.39689E+04    0.14127E-39    0.12112E-46    0.11835E-45
+    1    2    0.65217E-05    0.10000E+01    0.32008E+04    0.50449E-37    0.88717E-44    0.37467E-43
+    1    2    0.65217E-05    0.10000E+01    0.25813E+04    0.30346E-28    0.11407E-34    0.22707E-34
+    1    2    0.65217E-05    0.10000E+01    0.20817E+04    0.43523E-12    0.58077E-18    0.33134E-18
+    1    2    0.65217E-05    0.10000E+01    0.16788E+04    0.11586E-06    0.60611E-12    0.85554E-13
+    1    2    0.65217E-05    0.10000E+01    0.13538E+04    0.20395E-06    0.21165E-11    0.13336E-12
+    1    2    0.65217E-05    0.10000E+01    0.10918E+04    0.36561E-06    0.73942E-11    0.21176E-12
+    1    2    0.65217E-05    0.10000E+01    0.88049E+03    0.66206E-06    0.25919E-10    0.33976E-12
+    1    2    0.65217E-05    0.10000E+01    0.71007E+03    0.12059E-05    0.91074E-10    0.54910E-12
+    1    2    0.65217E-05    0.10000E+01    0.57264E+03    0.22051E-05    0.31616E-09    0.89421E-12
+    1    2    0.65217E-05    0.10000E+01    0.46180E+03    0.40370E-05    0.10468E-08    0.14692E-11
+    1    2    0.65217E-05    0.10000E+01    0.37242E+03    0.73466E-05    0.31616E-08    0.24299E-11
+    1    2    0.65217E-05    0.10000E+01    0.30034E+03    0.13108E-04    0.84321E-08    0.40073E-11
+    1    2    0.65217E-05    0.10000E+01    0.24221E+03    0.22545E-04    0.19622E-07    0.64871E-11
+    1    2    0.65217E-05    0.10000E+01    0.19533E+03    0.35007E-04    0.37216E-07    0.96774E-11
+    1    2    0.65217E-05    0.10000E+01    0.15752E+03    0.35007E-04    0.37216E-07    0.96774E-11
+    1    2    0.11380E-04    0.10000E+01    0.80645E+05    0.29504E-51    0.22031E-62    0.38661E-57
+    1    2    0.11380E-04    0.10000E+01    0.65036E+05    0.24921E-50    0.34942E-61    0.32696E-56
+    1    2    0.11380E-04    0.10000E+01    0.52449E+05    0.21146E-49    0.46749E-60    0.27775E-55
+    1    2    0.11380E-04    0.10000E+01    0.42297E+05    0.15853E-48    0.63010E-59    0.20866E-54
+    1    2    0.11380E-04    0.10000E+01    0.34111E+05    0.11358E-47    0.85394E-58    0.15003E-53
+    1    2    0.11380E-04    0.10000E+01    0.27509E+05    0.80650E-47    0.11330E-56    0.10716E-52
+    1    2    0.11380E-04    0.10000E+01    0.22184E+05    0.56418E-46    0.14559E-55    0.75688E-52
+    1    2    0.11380E-04    0.10000E+01    0.17891E+05    0.38444E-45    0.18034E-54    0.52373E-51
+    1    2    0.11380E-04    0.10000E+01    0.14428E+05    0.25352E-44    0.21594E-53    0.35330E-50
+    1    2    0.11380E-04    0.10000E+01    0.11635E+05    0.16172E-43    0.25065E-52    0.23199E-49
+    1    2    0.11380E-04    0.10000E+01    0.93834E+04    0.99970E-43    0.28352E-51    0.14759E-48
+    1    2    0.11380E-04    0.10000E+01    0.75673E+04    0.60278E-42    0.33034E-50    0.89719E-48
+    1    2    0.11380E-04    0.10000E+01    0.61026E+04    0.36991E-41    0.47156E-49    0.51520E-47
+    1    2    0.11380E-04    0.10000E+01    0.49215E+04    0.26323E-40    0.92368E-48    0.29456E-46
+    1    2    0.11380E-04    0.10000E+01    0.39689E+04    0.24650E-39    0.21135E-46    0.20651E-45
+    1    2    0.11380E-04    0.10000E+01    0.32008E+04    0.88030E-37    0.15481E-43    0.65378E-43
+    1    2    0.11380E-04    0.10000E+01    0.25813E+04    0.52951E-28    0.19905E-34    0.39623E-34
+    1    2    0.11380E-04    0.10000E+01    0.20817E+04    0.75945E-12    0.10134E-17    0.57817E-18
+    1    2    0.11380E-04    0.10000E+01    0.16788E+04    0.20217E-06    0.10576E-11    0.14929E-12
+    1    2    0.11380E-04    0.10000E+01    0.13538E+04    0.35589E-06    0.36931E-11    0.23271E-12
+    1    2    0.11380E-04    0.10000E+01    0.10918E+04    0.63797E-06    0.12902E-10    0.36950E-12
+    1    2    0.11380E-04    0.10000E+01    0.88049E+03    0.11553E-05    0.45228E-10    0.59286E-12
+    1    2    0.11380E-04    0.10000E+01    0.71007E+03    0.21043E-05    0.15892E-09    0.95814E-12
+    1    2    0.11380E-04    0.10000E+01    0.57264E+03    0.38477E-05    0.55168E-09    0.15603E-11
+    1    2    0.11380E-04    0.10000E+01    0.46180E+03    0.70442E-05    0.18266E-08    0.25636E-11
+    1    2    0.11380E-04    0.10000E+01    0.37242E+03    0.12819E-04    0.55167E-08    0.42400E-11
+    1    2    0.11380E-04    0.10000E+01    0.30034E+03    0.22873E-04    0.14714E-07    0.69924E-11
+    1    2    0.11380E-04    0.10000E+01    0.24221E+03    0.39339E-04    0.34239E-07    0.11320E-10
+    1    2    0.11380E-04    0.10000E+01    0.19533E+03    0.61084E-04    0.64939E-07    0.16886E-10
+    1    2    0.11380E-04    0.10000E+01    0.15752E+03    0.61084E-04    0.64939E-07    0.16886E-10
+    1    2    0.19857E-04    0.10000E+01    0.80645E+05    0.51483E-51    0.38443E-62    0.67461E-57
+    1    2    0.19857E-04    0.10000E+01    0.65036E+05    0.43485E-50    0.60972E-61    0.57053E-56
+    1    2    0.19857E-04    0.10000E+01    0.52449E+05    0.36898E-49    0.81575E-60    0.48465E-55
+    1    2    0.19857E-04    0.10000E+01    0.42297E+05    0.27663E-48    0.10995E-58    0.36409E-54
+    1    2    0.19857E-04    0.10000E+01    0.34111E+05    0.19819E-47    0.14901E-57    0.26180E-53
+    1    2    0.19857E-04    0.10000E+01    0.27509E+05    0.14073E-46    0.19770E-56    0.18699E-52
+    1    2    0.19857E-04    0.10000E+01    0.22184E+05    0.98446E-46    0.25405E-55    0.13207E-51
+    1    2    0.19857E-04    0.10000E+01    0.17891E+05    0.67082E-45    0.31469E-54    0.91388E-51
+    1    2    0.19857E-04    0.10000E+01    0.14428E+05    0.44238E-44    0.37680E-53    0.61649E-50
+    1    2    0.19857E-04    0.10000E+01    0.11635E+05    0.28219E-43    0.43738E-52    0.40481E-49
+    1    2    0.19857E-04    0.10000E+01    0.93834E+04    0.17444E-42    0.49473E-51    0.25753E-48
+    1    2    0.19857E-04    0.10000E+01    0.75673E+04    0.10518E-41    0.57643E-50    0.15655E-47
+    1    2    0.19857E-04    0.10000E+01    0.61026E+04    0.64547E-41    0.82285E-49    0.89899E-47
+    1    2    0.19857E-04    0.10000E+01    0.49215E+04    0.45932E-40    0.16118E-47    0.51399E-46
+    1    2    0.19857E-04    0.10000E+01    0.39689E+04    0.43013E-39    0.36880E-46    0.36036E-45
+    1    2    0.19857E-04    0.10000E+01    0.32008E+04    0.15361E-36    0.27013E-43    0.11408E-42
+    1    2    0.19857E-04    0.10000E+01    0.25813E+04    0.92397E-28    0.34733E-34    0.69140E-34
+    1    2    0.19857E-04    0.10000E+01    0.20817E+04    0.13252E-11    0.17683E-17    0.10089E-17
+    1    2    0.19857E-04    0.10000E+01    0.16788E+04    0.35277E-06    0.18455E-11    0.26050E-12
+    1    2    0.19857E-04    0.10000E+01    0.13538E+04    0.62100E-06    0.64443E-11    0.40606E-12
+    1    2    0.19857E-04    0.10000E+01    0.10918E+04    0.11132E-05    0.22514E-10    0.64476E-12
+    1    2    0.19857E-04    0.10000E+01    0.88049E+03    0.20159E-05    0.78919E-10    0.10345E-11
+    1    2    0.19857E-04    0.10000E+01    0.71007E+03    0.36719E-05    0.27730E-09    0.16719E-11
+    1    2    0.19857E-04    0.10000E+01    0.57264E+03    0.67141E-05    0.96266E-09    0.27227E-11
+    1    2    0.19857E-04    0.10000E+01    0.46180E+03    0.12292E-04    0.31872E-08    0.44733E-11
+    1    2    0.19857E-04    0.10000E+01    0.37242E+03    0.22369E-04    0.96263E-08    0.73985E-11
+    1    2    0.19857E-04    0.10000E+01    0.30034E+03    0.39912E-04    0.25674E-07    0.12201E-10
+    1    2    0.19857E-04    0.10000E+01    0.24221E+03    0.68645E-04    0.59744E-07    0.19752E-10
+    1    2    0.19857E-04    0.10000E+01    0.19533E+03    0.10659E-03    0.11332E-06    0.29466E-10
+    1    2    0.19857E-04    0.10000E+01    0.15752E+03    0.10659E-03    0.11332E-06    0.29466E-10
+    1    2    0.34650E-04    0.10000E+01    0.80645E+05    0.89835E-51    0.67081E-62    0.11771E-56
+    1    2    0.34650E-04    0.10000E+01    0.65036E+05    0.75878E-50    0.10639E-60    0.99554E-56
+    1    2    0.34650E-04    0.10000E+01    0.52449E+05    0.64385E-49    0.14234E-59    0.84569E-55
+    1    2    0.34650E-04    0.10000E+01    0.42297E+05    0.48270E-48    0.19185E-58    0.63532E-54
+    1    2    0.34650E-04    0.10000E+01    0.34111E+05    0.34583E-47    0.26001E-57    0.45682E-53
+    1    2    0.34650E-04    0.10000E+01    0.27509E+05    0.24557E-46    0.34498E-56    0.32629E-52
+    1    2    0.34650E-04    0.10000E+01    0.22184E+05    0.17178E-45    0.44330E-55    0.23046E-51
+    1    2    0.34650E-04    0.10000E+01    0.17891E+05    0.11705E-44    0.54911E-54    0.15947E-50
+    1    2    0.34650E-04    0.10000E+01    0.14428E+05    0.77193E-44    0.65750E-53    0.10757E-49
+    1    2    0.34650E-04    0.10000E+01    0.11635E+05    0.49240E-43    0.76320E-52    0.70637E-49
+    1    2    0.34650E-04    0.10000E+01    0.93834E+04    0.30439E-42    0.86327E-51    0.44937E-48
+    1    2    0.34650E-04    0.10000E+01    0.75673E+04    0.18354E-41    0.10058E-49    0.27318E-47
+    1    2    0.34650E-04    0.10000E+01    0.61026E+04    0.11263E-40    0.14358E-48    0.15687E-46
+    1    2    0.34650E-04    0.10000E+01    0.49215E+04    0.80148E-40    0.28124E-47    0.89689E-46
+    1    2    0.34650E-04    0.10000E+01    0.39689E+04    0.75056E-39    0.64353E-46    0.62880E-45
+    1    2    0.34650E-04    0.10000E+01    0.32008E+04    0.26804E-36    0.47135E-43    0.19906E-42
+    1    2    0.34650E-04    0.10000E+01    0.25813E+04    0.16123E-27    0.60608E-34    0.12064E-33
+    1    2    0.34650E-04    0.10000E+01    0.20817E+04    0.23124E-11    0.30856E-17    0.17604E-17
+    1    2    0.34650E-04    0.10000E+01    0.16788E+04    0.61556E-06    0.32203E-11    0.45455E-12
+    1    2    0.34650E-04    0.10000E+01    0.13538E+04    0.10836E-05    0.11245E-10    0.70855E-12
+    1    2    0.34650E-04    0.10000E+01    0.10918E+04    0.19425E-05    0.39286E-10    0.11251E-11
+    1    2    0.34650E-04    0.10000E+01    0.88049E+03    0.35175E-05    0.13771E-09    0.18052E-11
+    1    2    0.34650E-04    0.10000E+01    0.71007E+03    0.64072E-05    0.48388E-09    0.29174E-11
+    1    2    0.34650E-04    0.10000E+01    0.57264E+03    0.11716E-04    0.16798E-08    0.47509E-11
+    1    2    0.34650E-04    0.10000E+01    0.46180E+03    0.21448E-04    0.55615E-08    0.78057E-11
+    1    2    0.34650E-04    0.10000E+01    0.37242E+03    0.39032E-04    0.16797E-07    0.12910E-10
+    1    2    0.34650E-04    0.10000E+01    0.30034E+03    0.69645E-04    0.44800E-07    0.21291E-10
+    1    2    0.34650E-04    0.10000E+01    0.24221E+03    0.11978E-03    0.10425E-06    0.34466E-10
+    1    2    0.34650E-04    0.10000E+01    0.19533E+03    0.18599E-03    0.19773E-06    0.51416E-10
+    1    2    0.34650E-04    0.10000E+01    0.15752E+03    0.18599E-03    0.19773E-06    0.51416E-10
+    1    2    0.60462E-04    0.10000E+01    0.80645E+05    0.15676E-50    0.11705E-61    0.20541E-56
+    1    2    0.60462E-04    0.10000E+01    0.65036E+05    0.13240E-49    0.18565E-60    0.17372E-55
+    1    2    0.60462E-04    0.10000E+01    0.52449E+05    0.11235E-48    0.24838E-59    0.14757E-54
+    1    2    0.60462E-04    0.10000E+01    0.42297E+05    0.84228E-48    0.33478E-58    0.11086E-53
+    1    2    0.60462E-04    0.10000E+01    0.34111E+05    0.60346E-47    0.45370E-57    0.79713E-53
+    1    2    0.60462E-04    0.10000E+01    0.27509E+05    0.42850E-46    0.60197E-56    0.56936E-52
+    1    2    0.60462E-04    0.10000E+01    0.22184E+05    0.29975E-45    0.77353E-55    0.40213E-51
+    1    2    0.60462E-04    0.10000E+01    0.17891E+05    0.20425E-44    0.95817E-54    0.27826E-50
+    1    2    0.60462E-04    0.10000E+01    0.14428E+05    0.13470E-43    0.11473E-52    0.18771E-49
+    1    2    0.60462E-04    0.10000E+01    0.11635E+05    0.85922E-43    0.13317E-51    0.12326E-48
+    1    2    0.60462E-04    0.10000E+01    0.93834E+04    0.53114E-42    0.15064E-50    0.78413E-48
+    1    2    0.60462E-04    0.10000E+01    0.75673E+04    0.32026E-41    0.17551E-49    0.47668E-47
+    1    2    0.60462E-04    0.10000E+01    0.61026E+04    0.19653E-40    0.25054E-48    0.27373E-46
+    1    2    0.60462E-04    0.10000E+01    0.49215E+04    0.13985E-39    0.49075E-47    0.15650E-45
+    1    2    0.60462E-04    0.10000E+01    0.39689E+04    0.13097E-38    0.11229E-45    0.10972E-44
+    1    2    0.60462E-04    0.10000E+01    0.32008E+04    0.46771E-36    0.82249E-43    0.34735E-42
+    1    2    0.60462E-04    0.10000E+01    0.25813E+04    0.28133E-27    0.10576E-33    0.21052E-33
+    1    2    0.60462E-04    0.10000E+01    0.20817E+04    0.40350E-11    0.53842E-17    0.30718E-17
+    1    2    0.60462E-04    0.10000E+01    0.16788E+04    0.10741E-05    0.56192E-11    0.79316E-12
+    1    2    0.60462E-04    0.10000E+01    0.13538E+04    0.18908E-05    0.19622E-10    0.12364E-11
+    1    2    0.60462E-04    0.10000E+01    0.10918E+04    0.33895E-05    0.68551E-10    0.19632E-11
+    1    2    0.60462E-04    0.10000E+01    0.88049E+03    0.61379E-05    0.24029E-09    0.31499E-11
+    1    2    0.60462E-04    0.10000E+01    0.71007E+03    0.11180E-04    0.84434E-09    0.50906E-11
+    1    2    0.60462E-04    0.10000E+01    0.57264E+03    0.20443E-04    0.29311E-08    0.82901E-11
+    1    2    0.60462E-04    0.10000E+01    0.46180E+03    0.37426E-04    0.97045E-08    0.13621E-10
+    1    2    0.60462E-04    0.10000E+01    0.37242E+03    0.68109E-04    0.29310E-07    0.22527E-10
+    1    2    0.60462E-04    0.10000E+01    0.30034E+03    0.12153E-03    0.78173E-07    0.37151E-10
+    1    2    0.60462E-04    0.10000E+01    0.24221E+03    0.20901E-03    0.18191E-06    0.60141E-10
+    1    2    0.60462E-04    0.10000E+01    0.19533E+03    0.32454E-03    0.34502E-06    0.89718E-10
+    1    2    0.60462E-04    0.10000E+01    0.15752E+03    0.32454E-03    0.34502E-06    0.89718E-10
+    1    2    0.10550E-03    0.10000E+01    0.80645E+05    0.27353E-50    0.20425E-61    0.35842E-56
+    1    2    0.10550E-03    0.10000E+01    0.65036E+05    0.23104E-49    0.32395E-60    0.30312E-55
+    1    2    0.10550E-03    0.10000E+01    0.52449E+05    0.19604E-48    0.43341E-59    0.25750E-54
+    1    2    0.10550E-03    0.10000E+01    0.42297E+05    0.14697E-47    0.58416E-58    0.19344E-53
+    1    2    0.10550E-03    0.10000E+01    0.34111E+05    0.10530E-46    0.79168E-57    0.13909E-52
+    1    2    0.10550E-03    0.10000E+01    0.27509E+05    0.74770E-46    0.10504E-55    0.99351E-52
+    1    2    0.10550E-03    0.10000E+01    0.22184E+05    0.52305E-45    0.13498E-54    0.70170E-51
+    1    2    0.10550E-03    0.10000E+01    0.17891E+05    0.35641E-44    0.16720E-53    0.48554E-50
+    1    2    0.10550E-03    0.10000E+01    0.14428E+05    0.23504E-43    0.20020E-52    0.32754E-49
+    1    2    0.10550E-03    0.10000E+01    0.11635E+05    0.14993E-42    0.23238E-51    0.21508E-48
+    1    2    0.10550E-03    0.10000E+01    0.93834E+04    0.92681E-42    0.26285E-50    0.13683E-47
+    1    2    0.10550E-03    0.10000E+01    0.75673E+04    0.55883E-41    0.30626E-49    0.83177E-47
+    1    2    0.10550E-03    0.10000E+01    0.61026E+04    0.34294E-40    0.43718E-48    0.47764E-46
+    1    2    0.10550E-03    0.10000E+01    0.49215E+04    0.24404E-39    0.85633E-47    0.27309E-45
+    1    2    0.10550E-03    0.10000E+01    0.39689E+04    0.22853E-38    0.19594E-45    0.19146E-44
+    1    2    0.10550E-03    0.10000E+01    0.32008E+04    0.81612E-36    0.14352E-42    0.60611E-42
+    1    2    0.10550E-03    0.10000E+01    0.25813E+04    0.49090E-27    0.18454E-33    0.36734E-33
+    1    2    0.10550E-03    0.10000E+01    0.20817E+04    0.70408E-11    0.93952E-17    0.53602E-17
+    1    2    0.10550E-03    0.10000E+01    0.16788E+04    0.18743E-05    0.98051E-11    0.13840E-11
+    1    2    0.10550E-03    0.10000E+01    0.13538E+04    0.32994E-05    0.34239E-10    0.21574E-11
+    1    2    0.10550E-03    0.10000E+01    0.10918E+04    0.59145E-05    0.11962E-09    0.34256E-11
+    1    2    0.10550E-03    0.10000E+01    0.88049E+03    0.10710E-04    0.41930E-09    0.54963E-11
+    1    2    0.10550E-03    0.10000E+01    0.71007E+03    0.19509E-04    0.14733E-08    0.88829E-11
+    1    2    0.10550E-03    0.10000E+01    0.57264E+03    0.35672E-04    0.51146E-08    0.14466E-10
+    1    2    0.10550E-03    0.10000E+01    0.46180E+03    0.65306E-04    0.16934E-07    0.23767E-10
+    1    2    0.10550E-03    0.10000E+01    0.37242E+03    0.11885E-03    0.51145E-07    0.39308E-10
+    1    2    0.10550E-03    0.10000E+01    0.30034E+03    0.21206E-03    0.13641E-06    0.64826E-10
+    1    2    0.10550E-03    0.10000E+01    0.24221E+03    0.36471E-03    0.31742E-06    0.10494E-09
+    1    2    0.10550E-03    0.10000E+01    0.19533E+03    0.56631E-03    0.60205E-06    0.15655E-09
+    1    2    0.10550E-03    0.10000E+01    0.15752E+03    0.56631E-03    0.60205E-06    0.15655E-09
+    1    2    0.18409E-03    0.10000E+01    0.80645E+05    0.47729E-50    0.35640E-61    0.62542E-56
+    1    2    0.18409E-03    0.10000E+01    0.65036E+05    0.40314E-49    0.56527E-60    0.52893E-55
+    1    2    0.18409E-03    0.10000E+01    0.52449E+05    0.34208E-48    0.75627E-59    0.44931E-54
+    1    2    0.18409E-03    0.10000E+01    0.42297E+05    0.25646E-47    0.10193E-57    0.33754E-53
+    1    2    0.18409E-03    0.10000E+01    0.34111E+05    0.18374E-46    0.13814E-56    0.24271E-52
+    1    2    0.18409E-03    0.10000E+01    0.27509E+05    0.13047E-45    0.18329E-55    0.17336E-51
+    1    2    0.18409E-03    0.10000E+01    0.22184E+05    0.91268E-45    0.23553E-54    0.12244E-50
+    1    2    0.18409E-03    0.10000E+01    0.17891E+05    0.62191E-44    0.29175E-53    0.84725E-50
+    1    2    0.18409E-03    0.10000E+01    0.14428E+05    0.41013E-43    0.34933E-52    0.57154E-49
+    1    2    0.18409E-03    0.10000E+01    0.11635E+05    0.26162E-42    0.40549E-51    0.37529E-48
+    1    2    0.18409E-03    0.10000E+01    0.93834E+04    0.16172E-41    0.45866E-50    0.23875E-47
+    1    2    0.18409E-03    0.10000E+01    0.75673E+04    0.97513E-41    0.53440E-49    0.14514E-46
+    1    2    0.18409E-03    0.10000E+01    0.61026E+04    0.59841E-40    0.76285E-48    0.83345E-46
+    1    2    0.18409E-03    0.10000E+01    0.49215E+04    0.42583E-39    0.14942E-46    0.47652E-45
+    1    2    0.18409E-03    0.10000E+01    0.39689E+04    0.39877E-38    0.34191E-45    0.33408E-44
+    1    2    0.18409E-03    0.10000E+01    0.32008E+04    0.14241E-35    0.25043E-42    0.10576E-41
+    1    2    0.18409E-03    0.10000E+01    0.25813E+04    0.85660E-27    0.32201E-33    0.64099E-33
+    1    2    0.18409E-03    0.10000E+01    0.20817E+04    0.12286E-10    0.16394E-16    0.93532E-17
+    1    2    0.18409E-03    0.10000E+01    0.16788E+04    0.32705E-05    0.17109E-10    0.24150E-11
+    1    2    0.18409E-03    0.10000E+01    0.13538E+04    0.57573E-05    0.59744E-10    0.37645E-11
+    1    2    0.18409E-03    0.10000E+01    0.10918E+04    0.10321E-04    0.20872E-09    0.59775E-11
+    1    2    0.18409E-03    0.10000E+01    0.88049E+03    0.18689E-04    0.73165E-09    0.95908E-11
+    1    2    0.18409E-03    0.10000E+01    0.71007E+03    0.34042E-04    0.25708E-08    0.15500E-10
+    1    2    0.18409E-03    0.10000E+01    0.57264E+03    0.62245E-04    0.89247E-08    0.25242E-10
+    1    2    0.18409E-03    0.10000E+01    0.46180E+03    0.11396E-03    0.29548E-07    0.41472E-10
+    1    2    0.18409E-03    0.10000E+01    0.37242E+03    0.20738E-03    0.89245E-07    0.68590E-10
+    1    2    0.18409E-03    0.10000E+01    0.30034E+03    0.37002E-03    0.23802E-06    0.11312E-09
+    1    2    0.18409E-03    0.10000E+01    0.24221E+03    0.63640E-03    0.55388E-06    0.18312E-09
+    1    2    0.18409E-03    0.10000E+01    0.19533E+03    0.98817E-03    0.10505E-05    0.27317E-09
+    1    2    0.18409E-03    0.10000E+01    0.15752E+03    0.98817E-03    0.10505E-05    0.27317E-09
+    1    2    0.32123E-03    0.10000E+01    0.80645E+05    0.83285E-50    0.62190E-61    0.10913E-55
+    1    2    0.32123E-03    0.10000E+01    0.65036E+05    0.70346E-49    0.98636E-60    0.92296E-55
+    1    2    0.32123E-03    0.10000E+01    0.52449E+05    0.59690E-48    0.13196E-58    0.78403E-54
+    1    2    0.32123E-03    0.10000E+01    0.42297E+05    0.44751E-47    0.17787E-57    0.58900E-53
+    1    2    0.32123E-03    0.10000E+01    0.34111E+05    0.32062E-46    0.24105E-56    0.42352E-52
+    1    2    0.32123E-03    0.10000E+01    0.27509E+05    0.22766E-45    0.31983E-55    0.30250E-51
+    1    2    0.32123E-03    0.10000E+01    0.22184E+05    0.15926E-44    0.41098E-54    0.21365E-50
+    1    2    0.32123E-03    0.10000E+01    0.17891E+05    0.10852E-43    0.50908E-53    0.14784E-49
+    1    2    0.32123E-03    0.10000E+01    0.14428E+05    0.71564E-43    0.60956E-52    0.99730E-49
+    1    2    0.32123E-03    0.10000E+01    0.11635E+05    0.45650E-42    0.70755E-51    0.65487E-48
+    1    2    0.32123E-03    0.10000E+01    0.93834E+04    0.28220E-41    0.80033E-50    0.41661E-47
+    1    2    0.32123E-03    0.10000E+01    0.75673E+04    0.17015E-40    0.93249E-49    0.25326E-46
+    1    2    0.32123E-03    0.10000E+01    0.61026E+04    0.10442E-39    0.13311E-47    0.14543E-45
+    1    2    0.32123E-03    0.10000E+01    0.49215E+04    0.74305E-39    0.26074E-46    0.83149E-45
+    1    2    0.32123E-03    0.10000E+01    0.39689E+04    0.69583E-38    0.59661E-45    0.58295E-44
+    1    2    0.32123E-03    0.10000E+01    0.32008E+04    0.24849E-35    0.43699E-42    0.18455E-41
+    1    2    0.32123E-03    0.10000E+01    0.25813E+04    0.14947E-26    0.56189E-33    0.11185E-32
+    1    2    0.32123E-03    0.10000E+01    0.20817E+04    0.21438E-10    0.28607E-16    0.16321E-16
+    1    2    0.32123E-03    0.10000E+01    0.16788E+04    0.57068E-05    0.29855E-10    0.42141E-11
+    1    2    0.32123E-03    0.10000E+01    0.13538E+04    0.10046E-04    0.10425E-09    0.65689E-11
+    1    2    0.32123E-03    0.10000E+01    0.10918E+04    0.18009E-04    0.36421E-09    0.10430E-10
+    1    2    0.32123E-03    0.10000E+01    0.88049E+03    0.32611E-04    0.12767E-08    0.16735E-10
+    1    2    0.32123E-03    0.10000E+01    0.71007E+03    0.59400E-04    0.44860E-08    0.27047E-10
+    1    2    0.32123E-03    0.10000E+01    0.57264E+03    0.10861E-03    0.15573E-07    0.44045E-10
+    1    2    0.32123E-03    0.10000E+01    0.46180E+03    0.19885E-03    0.51560E-07    0.72366E-10
+    1    2    0.32123E-03    0.10000E+01    0.37242E+03    0.36187E-03    0.15573E-06    0.11969E-09
+    1    2    0.32123E-03    0.10000E+01    0.30034E+03    0.64567E-03    0.41533E-06    0.19738E-09
+    1    2    0.32123E-03    0.10000E+01    0.24221E+03    0.11105E-02    0.96649E-06    0.31953E-09
+    1    2    0.32123E-03    0.10000E+01    0.19533E+03    0.17243E-02    0.18331E-05    0.47667E-09
+    1    2    0.32123E-03    0.10000E+01    0.15752E+03    0.17243E-02    0.18331E-05    0.47667E-09
+    1    3    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.19539E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    3    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.34094E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    3    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.59492E-08    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    3    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.10381E-07    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    1    3    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.18114E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    1    3    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.31608E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    1    3    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.55155E-07    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    1    3    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.96242E-07    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    1    3    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.16794E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    1    3    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.29304E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    1    3    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.51133E-06    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    1    3    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.89225E-06    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    1    3    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.15569E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    1    3    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.27167E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    1    3    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.47405E-05    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    1    3    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.82719E-05    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    1    3    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.14434E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    1    3    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.25186E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    1    3    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.43949E-04    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    1    3    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.76688E-04    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    1    3    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53957E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.13382E-03    0.19496E+06    0.99447E-26    0.48760E-10    0.50499E-04    0.88379E+03
+    1    3    0.54572E-10    0.10000E+01    0.74090E-01    0.13935E+00    0.11222E-09    0.65380E-11    0.40383E-04    0.29228E-04    0.98516E+04    0.23350E-03    0.15940E+06    0.27009E-25    0.58026E-09    0.60483E-04    0.85041E+03
+    1    3    0.95225E-10    0.10000E+01    0.11736E+00    0.19749E+00    0.21140E-09    0.50996E-10    0.44004E-04    0.38038E-04    0.17190E+05    0.40745E-03    0.12765E+06    0.72480E-25    0.43989E-08    0.73406E-04    0.78192E+03
+    1    3    0.16616E-09    0.10000E+01    0.18179E+00    0.26431E+00    0.32753E-09    0.26583E-09    0.44528E-04    0.48903E-04    0.29996E+05    0.71097E-03    0.99467E+05    0.19955E-24    0.21856E-07    0.91697E-04    0.67141E+03
+    1    3    0.28994E-09    0.10000E+01    0.25961E+00    0.33496E+00    0.47703E-09    0.94192E-09    0.43515E-04    0.57767E-04    0.52341E+05    0.12406E-02    0.75619E+05    0.57623E-24    0.71447E-07    0.11865E-03    0.53386E+03
+    1    3    0.50593E-09    0.10000E+01    0.33900E+00    0.40891E+00    0.78184E-09    0.24625E-08    0.45608E-04    0.61912E-04    0.91333E+05    0.21648E-02    0.56747E+05    0.17224E-23    0.16529E-06    0.15713E-03    0.40140E+03
+    1    3    0.88282E-09    0.10000E+01    0.41762E+00    0.48781E+00    0.14159E-08    0.54449E-08    0.54182E-04    0.63271E-04    0.15937E+06    0.37774E-02    0.42418E+05    0.52150E-23    0.31202E-06    0.20988E-03    0.29419E+03
+    1    3    0.15405E-08    0.10000E+01    0.35956E+00    0.68448E+00    0.74805E-08    0.13722E-07    0.63916E-04    0.61349E-04    0.79790E+05    0.35960E-02    0.65241E+04    0.52896E-22    0.49698E-06    0.47376E-03    0.16217E+03
+    1    3    0.26880E-08    0.10000E+01    0.40702E+00    0.74670E+00    0.14690E-07    0.28729E-07    0.80731E-04    0.55614E-04    0.11884E+06    0.58536E-02    0.44413E+04    0.23501E-21    0.84372E-06    0.69052E-03    0.11571E+03
+    1    3    0.46905E-08    0.10000E+01    0.46636E+00    0.78626E+00    0.26881E-07    0.57830E-07    0.10747E-03    0.50337E-04    0.20736E+06    0.10214E-01    0.34295E+04    0.93187E-21    0.14173E-05    0.94681E-03    0.87038E+02
+    1    3    0.81846E-08    0.10000E+01    0.51852E+00    0.83418E+00    0.48974E-07    0.11254E-06    0.14521E-03    0.47357E-04    0.36184E+06    0.17823E-01    0.27038E+04    0.34137E-20    0.23162E-05    0.12694E-02    0.67971E+02
+    1    3    0.14282E-07    0.10000E+01    0.56494E+00    0.90460E+00    0.88615E-07    0.21040E-06    0.19602E-03    0.47157E-04    0.63138E+06    0.31100E-01    0.21624E+04    0.11050E-19    0.36758E-05    0.16437E-02    0.55827E+02
+    1    3    0.24920E-07    0.10000E+01    0.60844E+00    0.99800E+00    0.16015E-06    0.38014E-06    0.26317E-03    0.49300E-04    0.11017E+07    0.54268E-01    0.17429E+04    0.32083E-19    0.57052E-05    0.20572E-02    0.48074E+02
+    1    3    0.43485E-07    0.10000E+01    0.65325E+00    0.11109E+01    0.28824E-06    0.67027E-06    0.35012E-03    0.53408E-04    0.19224E+07    0.94695E-01    0.14030E+04    0.87101E-19    0.87195E-05    0.25200E-02    0.42626E+02
+    1    3    0.75878E-07    0.10000E+01    0.70371E+00    0.12394E+01    0.51648E-06    0.11623E-05    0.46160E-03    0.59300E-04    0.33546E+07    0.16524E+00    0.11220E+04    0.22876E-18    0.13202E-04    0.30587E-02    0.38170E+02
+    1    3    0.13240E-06    0.10000E+01    0.76514E+00    0.13823E+01    0.91489E-06    0.19934E-05    0.60164E-03    0.67007E-04    0.58535E+07    0.28833E+00    0.88692E+03    0.59961E-18    0.19858E-04    0.37264E-02    0.33908E+02
+    1    3    0.23103E-06    0.10000E+01    0.84246E+00    0.15379E+01    0.15958E-05    0.33946E-05    0.77497E-03    0.76574E-04    0.10214E+08    0.50312E+00    0.69202E+03    0.15978E-17    0.29753E-04    0.45961E-02    0.29507E+02
+    1    3    0.40314E-06    0.10000E+01    0.94012E+00    0.17036E+01    0.27151E-05    0.57515E-05    0.98436E-03    0.88011E-04    0.17823E+08    0.87791E+00    0.53229E+03    0.43410E-17    0.44427E-04    0.57603E-02    0.24948E+02
+    1    3    0.70346E-06    0.10000E+01    0.96583E+00    0.17425E+01    0.71930E-05    0.99587E-05    0.15929E-02    0.90885E-04    0.31100E+08    0.15319E+01    0.50000E+03    0.83883E-17    0.74740E-04    0.60775E-02    0.23899E+02
+    1    3    0.12275E-05    0.10000E+01    0.96583E+00    0.17425E+01    0.21901E-04    0.17377E-04    0.27794E-02    0.90885E-04    0.54267E+08    0.26731E+01    0.50000E+03    0.14637E-16    0.13042E-03    0.60775E-02    0.23899E+02
+    1    3    0.21419E-05    0.10000E+01    0.96583E+00    0.17425E+01    0.66685E-04    0.30322E-04    0.48499E-02    0.90885E-04    0.94693E+08    0.46643E+01    0.50000E+03    0.25541E-16    0.22757E-03    0.60775E-02    0.23899E+02
+    1    3    0.37375E-05    0.10000E+01    0.96583E+00    0.17425E+01    0.20304E-03    0.52911E-04    0.84628E-02    0.90885E-04    0.16523E+09    0.81390E+01    0.50000E+03    0.44567E-16    0.39709E-03    0.60775E-02    0.23899E+02
+    1    3    0.65217E-05    0.10000E+01    0.96583E+00    0.17425E+01    0.61823E-03    0.92326E-04    0.14767E-01    0.90885E-04    0.28832E+09    0.14202E+02    0.50000E+03    0.77767E-16    0.69290E-03    0.60775E-02    0.23899E+02
+    1    3    0.11380E-04    0.10000E+01    0.96583E+00    0.17425E+01    0.18824E-02    0.16110E-03    0.25768E-01    0.90885E-04    0.50310E+09    0.24782E+02    0.50000E+03    0.13570E-15    0.12091E-02    0.60775E-02    0.23899E+02
+    1    3    0.19857E-04    0.10000E+01    0.96583E+00    0.17425E+01    0.57316E-02    0.28112E-03    0.44963E-01    0.90885E-04    0.87789E+09    0.43243E+02    0.50000E+03    0.23679E-15    0.21098E-02    0.60775E-02    0.23899E+02
+    1    3    0.34650E-04    0.10000E+01    0.96583E+00    0.17425E+01    0.17452E-01    0.49053E-03    0.78458E-01    0.90885E-04    0.15319E+10    0.75456E+02    0.50000E+03    0.41318E-15    0.36814E-02    0.60775E-02    0.23899E+02
+    1    3    0.60462E-04    0.10000E+01    0.96583E+00    0.17425E+01    0.53137E-01    0.85595E-03    0.13690E+00    0.90885E-04    0.26730E+10    0.13167E+03    0.50000E+03    0.72097E-15    0.64238E-02    0.60775E-02    0.23899E+02
+    1    3    0.10550E-03    0.10000E+01    0.96583E+00    0.17425E+01    0.16179E+00    0.14936E-02    0.23889E+00    0.90885E-04    0.46642E+10    0.22975E+03    0.50000E+03    0.12580E-14    0.11209E-01    0.60775E-02    0.23899E+02
+    1    3    0.18409E-03    0.10000E+01    0.96583E+00    0.17425E+01    0.49262E+00    0.26062E-02    0.41685E+00    0.90885E-04    0.81388E+10    0.40090E+03    0.50000E+03    0.21952E-14    0.19559E-01    0.60775E-02    0.23899E+02
+    1    3    0.32123E-03    0.10000E+01    0.96583E+00    0.17425E+01    0.15000E+01    0.45477E-02    0.72738E+00    0.90885E-04    0.14202E+11    0.69954E+03    0.50000E+03    0.38305E-14    0.34130E-01    0.60775E-02    0.23899E+02
+    1    3    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    1    3    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    1    3    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    1    3    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    1    3    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    1    3    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    1    3    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    1    3    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    1    3    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    1    3    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    1    3    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    1    3    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    1    3    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    1    3    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    1    3    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    1    3    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    1    3    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    1    3    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    1    3    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    1    3    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    1    3    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    1    3    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    1    3    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    1    3    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    1    3    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    1    3    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    1    3    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    1    3    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    1    3    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    1    3    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    1    3    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    1    3    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    1    3    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    1    3    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    1    3    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    1    3    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    1    3    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    1    3    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    1    3    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    1    3    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    1    3    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    1    3    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    1    3    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    1    3    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    1    3    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    1    3    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    1    3    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    1    3    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    1    3    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    1    3    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    1    3    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    1    3    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    1    3    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    1    3    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    1    3    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    1    3    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    1    3    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    1    3    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    1    3    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    1    3    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    1    3    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    1    3    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    1    3    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    1    3    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    1    3    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    1    3    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    1    3    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    1    3    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    1    3    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    1    3    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    1    3    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    1    3    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    1    3    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    1    3    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    1    3    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    1    3    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    1    3    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    1    3    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    1    3    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    1    3    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    1    3    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    1    3    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    1    3    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    1    3    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    1    3    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    1    3    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    1    3    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    1    3    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    1    3    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    1    3    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    1    3    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    1    3    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    1    3    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    1    3    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    1    3    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    1    3    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    1    3    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    1    3    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    1    3    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    1    3    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    1    3    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    1    3    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    1    3    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    1    3    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    1    3    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    1    3    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    1    3    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    1    3    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    1    3    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    1    3    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    1    3    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    1    3    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    1    3    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    1    3    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    1    3    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    1    3    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    1    3    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    1    3    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    1    3    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    1    3    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    1    3    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    1    3    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    1    3    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    1    3    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    1    3    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    1    3    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    1    3    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    1    3    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    1    3    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    1    3    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    1    3    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    1    3    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    1    3    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    1    3    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    1    3    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    1    3    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    1    3    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    1    3    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    1    3    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    1    3    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    1    3    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    1    3    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    1    3    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    1    3    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    1    3    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    1    3    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    1    3    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    1    3    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    1    3    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    1    3    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    1    3    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    1    3    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    1    3    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    1    3    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    1    3    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    1    3    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    1    3    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    1    3    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    1    3    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    1    3    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    1    3    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    1    3    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    1    3    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    1    3    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    1    3    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    1    3    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    1    3    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    1    3    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    1    3    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    1    3    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    1    3    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    1    3    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    1    3    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    1    3    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    1    3    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    1    3    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    1    3    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    1    3    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    1    3    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    1    3    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    1    3    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    1    3    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    1    3    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    1    3    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    1    3    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    1    3    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    1    3    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    1    3    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    1    3    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    1    3    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    1    3    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    1    3    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    1    3    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    1    3    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    1    3    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    1    3    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    1    3    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    1    3    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    1    3    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    1    3    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    1    3    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    1    3    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    1    3    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    1    3    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    1    3    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    1    3    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    1    3    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    1    3    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    1    3    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    1    3    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    1    3    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    1    3    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    1    3    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    1    3    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    1    3    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    1    3    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    1    3    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    1    3    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    1    3    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    1    3    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    1    3    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    1    3    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    1    3    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    1    3    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    1    3    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    1    3    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    1    3    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    1    3    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    1    3    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    1    3    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    1    3    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    1    3    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    1    3    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    1    3    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    1    3    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    1    3    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    1    3    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    1    3    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    1    3    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    1    3    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    1    3    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    1    3    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    1    3    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    1    3    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    1    3    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    1    3    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    1    3    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    1    3    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    1    3    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    1    3    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    1    3    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    1    3    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    1    3    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    1    3    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    1    3    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    1    3    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    1    3    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    1    3    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    1    3    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    1    3    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    1    3    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    1    3    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    1    3    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    1    3    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    1    3    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    1    3    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    1    3    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    1    3    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    1    3    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    1    3    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    1    3    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    1    3    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    1    3    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    1    3    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    1    3    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    1    3    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    1    3    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    1    3    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    1    3    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    1    3    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    1    3    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    1    3    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    1    3    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    1    3    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    1    3    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    1    3    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    1    3    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    1    3    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    1    3    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    1    3    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    1    3    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    1    3    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    1    3    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    1    3    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    1    3    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    1    3    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    1    3    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    1    3    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    1    3    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    1    3    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    1    3    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    1    3    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    1    3    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    1    3    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    1    3    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    1    3    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    1    3    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    1    3    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    1    3    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    1    3    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    1    3    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    1    3    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    1    3    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    1    3    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    1    3    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    1    3    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    1    3    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    1    3    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    1    3    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    1    3    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    1    3    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    1    3    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    1    3    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    1    3    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    1    3    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    1    3    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    1    3    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    1    3    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    1    3    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    1    3    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    1    3    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    1    3    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    1    3    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    1    3    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    1    3    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    1    3    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    1    3    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    1    3    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    1    3    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    1    3    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    1    3    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    1    3    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    1    3    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    1    3    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    1    3    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    1    3    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    1    3    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    1    3    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    1    3    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    1    3    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    1    3    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    1    3    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    1    3    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    1    3    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    1    3    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    1    3    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    1    3    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    1    3    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    1    3    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    1    3    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    1    3    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    1    3    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    1    3    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    1    3    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    1    3    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    1    3    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    1    3    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    1    3    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    1    3    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    1    3    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    1    3    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    1    3    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    1    3    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    1    3    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    1    3    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    1    3    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    1    3    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    1    3    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    1    3    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    1    3    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    1    3    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    1    3    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    1    3    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    1    3    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    1    3    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    1    3    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    1    3    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    1    3    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    1    3    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    1    3    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    1    3    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    1    3    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    1    3    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    1    3    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    1    3    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    1    3    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    1    3    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    1    3    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    1    3    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    1    3    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    1    3    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    1    3    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    1    3    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    1    3    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    1    3    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    1    3    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    1    3    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    1    3    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    1    3    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    1    3    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    1    3    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    1    3    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    1    3    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    1    3    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    1    3    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    1    3    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    1    3    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    1    3    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    1    3    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    1    3    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    1    3    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    1    3    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    1    3    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    1    3    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    1    3    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    1    3    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    1    3    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    1    3    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    1    3    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    1    3    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    1    3    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    1    3    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    1    3    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    1    3    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    1    3    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    1    3    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    1    3    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    1    3    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    1    3    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    1    3    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    1    3    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    1    3    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    1    3    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    1    3    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    1    3    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    1    3    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    1    3    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    1    3    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    1    3    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    1    3    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    1    3    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    1    3    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    1    3    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    1    3    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    1    3    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    1    3    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    1    3    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    1    3    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    1    3    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    1    3    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    1    3    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    1    3    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    1    3    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    1    3    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    1    3    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    1    3    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    1    3    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    1    3    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    1    3    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    1    3    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    1    3    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    1    3    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    1    3    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    1    3    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    1    3    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    1    3    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    1    3    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    1    3    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    1    3    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    1    3    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    1    3    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    1    3    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    1    3    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    1    3    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    1    3    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    1    3    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    1    3    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    1    3    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    1    3    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    1    3    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    1    3    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    1    3    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    1    3    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    1    3    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    1    3    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    1    3    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    1    3    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    1    3    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    1    3    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    1    3    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    1    3    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    1    3    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    1    3    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    1    3    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    1    3    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    1    3    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    1    3    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    1    3    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    1    3    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    1    3    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    1    3    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    1    3    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    1    3    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    1    3    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    1    3    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    1    3    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    1    3    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    1    3    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    1    3    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    1    3    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    1    3    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    1    3    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    1    3    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    1    3    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    1    3    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    1    3    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    1    3    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    1    3    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    1    3    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    1    3    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    1    3    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    1    3    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    1    3    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    1    3    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    1    3    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    1    3    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    1    3    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    1    3    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    1    3    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    1    3    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    1    3    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    1    3    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    1    3    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    1    3    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    1    3    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    1    3    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    1    3    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    1    3    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    1    3    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    1    3    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    1    3    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    1    3    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    1    3    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    1    3    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    1    3    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    1    3    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    1    3    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    1    3    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    1    3    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    1    3    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    1    3    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    1    3    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    1    3    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    1    3    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    1    3    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    1    3    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    1    3    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    1    3    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    1    3    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    1    3    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    1    3    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    1    3    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    1    3    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    1    3    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    1    3    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    1    3    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    1    3    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    1    3    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    1    3    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    1    3    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    1    3    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    1    3    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    1    3    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    1    3    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    1    3    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    1    3    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    1    3    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    1    3    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    1    3    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    1    3    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    1    3    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    1    3    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    1    3    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    1    3    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    1    3    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    1    3    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    1    3    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    1    3    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    1    3    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    1    3    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    1    3    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    1    3    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    1    3    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    1    3    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    1    3    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    1    3    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    1    3    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    1    3    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    1    3    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    1    3    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    1    3    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    1    3    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    1    3    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    1    3    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    1    3    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    1    3    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    1    3    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    1    3    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    1    3    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    1    3    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    1    3    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    1    3    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    1    3    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    1    3    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    1    3    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    1    3    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    1    3    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    1    3    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    1    3    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    1    3    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    1    3    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35525E-67
+    1    3    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31050E-66
+    1    3    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49297E-66    0.26759E-65
+    1    3    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20665E-64
+    1    3    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    1    3    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15327E-62
+    1    3    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    1    3    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30486E-60
+    1    3    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49479E-59
+    1    3    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76348E-58
+    1    3    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    1    3    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16341E-55
+    1    3    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    1    3    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33513E-53
+    1    3    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47754E-52
+    1    3    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86007E-46    0.21355E-49
+    1    3    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    1    3    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    1    3    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    1    3    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    1    3    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    1    3    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    1    3    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    1    3    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    1    3    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    1    3    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    1    3    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    1    3    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    1    3    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    1    3    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    1    3    0.95225E-10    0.10000E+01    0.80645E+05    0.53338E-57    0.41251E-68    0.10749E-66
+    1    3    0.95225E-10    0.10000E+01    0.65036E+05    0.46320E-56    0.66241E-67    0.94141E-66
+    1    3    0.95225E-10    0.10000E+01    0.52449E+05    0.40024E-55    0.93503E-66    0.81416E-65
+    1    3    0.95225E-10    0.10000E+01    0.42297E+05    0.31521E-54    0.15121E-64    0.62477E-64
+    1    3    0.95225E-10    0.10000E+01    0.34111E+05    0.26479E-53    0.31103E-63    0.46450E-63
+    1    3    0.95225E-10    0.10000E+01    0.27509E+05    0.27530E-52    0.84266E-62    0.36185E-62
+    1    3    0.95225E-10    0.10000E+01    0.22184E+05    0.37547E-51    0.26561E-60    0.35004E-61
+    1    3    0.95225E-10    0.10000E+01    0.17891E+05    0.59959E-50    0.82078E-59    0.47852E-60
+    1    3    0.95225E-10    0.10000E+01    0.14428E+05    0.96029E-49    0.23747E-57    0.76675E-59
+    1    3    0.95225E-10    0.10000E+01    0.11635E+05    0.14620E-47    0.65938E-56    0.12102E-57
+    1    3    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18298E-56
+    1    3    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49011E-53    0.26942E-55
+    1    3    0.95225E-10    0.10000E+01    0.61026E+04    0.43943E-44    0.13295E-51    0.39150E-54
+    1    3    0.95225E-10    0.10000E+01    0.49215E+04    0.62538E-43    0.35997E-50    0.56476E-53
+    1    3    0.95225E-10    0.10000E+01    0.39689E+04    0.88822E-42    0.97300E-49    0.81063E-52
+    1    3    0.95225E-10    0.10000E+01    0.32008E+04    0.39613E-39    0.84952E-46    0.36461E-49
+    1    3    0.95225E-10    0.10000E+01    0.25813E+04    0.29211E-30    0.14353E-36    0.27085E-40
+    1    3    0.95225E-10    0.10000E+01    0.20817E+04    0.55938E-14    0.12256E-19    0.52257E-24
+    1    3    0.95225E-10    0.10000E+01    0.16788E+04    0.18980E-08    0.18143E-13    0.17813E-18
+    1    3    0.95225E-10    0.10000E+01    0.13538E+04    0.40806E-08    0.68940E-13    0.38357E-18
+    1    3    0.95225E-10    0.10000E+01    0.10918E+04    0.85761E-08    0.25711E-12    0.80708E-18
+    1    3    0.95225E-10    0.10000E+01    0.88049E+03    0.17636E-07    0.94670E-12    0.16610E-17
+    1    3    0.95225E-10    0.10000E+01    0.71007E+03    0.35560E-07    0.34475E-11    0.33511E-17
+    1    3    0.95225E-10    0.10000E+01    0.57264E+03    0.70490E-07    0.12266E-10    0.66454E-17
+    1    3    0.95225E-10    0.10000E+01    0.46180E+03    0.13745E-06    0.41255E-10    0.12961E-16
+    1    3    0.95225E-10    0.10000E+01    0.37242E+03    0.26237E-06    0.12579E-09    0.24744E-16
+    1    3    0.95225E-10    0.10000E+01    0.30034E+03    0.48462E-06    0.33740E-09    0.45710E-16
+    1    3    0.95225E-10    0.10000E+01    0.24221E+03    0.85384E-06    0.78780E-09    0.80539E-16
+    1    3    0.95225E-10    0.10000E+01    0.19533E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    1    3    0.95225E-10    0.10000E+01    0.15752E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    1    3    0.16616E-09    0.10000E+01    0.80645E+05    0.10831E-56    0.84134E-68    0.33649E-66
+    1    3    0.16616E-09    0.10000E+01    0.65036E+05    0.94382E-56    0.13505E-66    0.29209E-65
+    1    3    0.16616E-09    0.10000E+01    0.52449E+05    0.81476E-55    0.18599E-65    0.25174E-64
+    1    3    0.16616E-09    0.10000E+01    0.42297E+05    0.62646E-54    0.26584E-64    0.19203E-63
+    1    3    0.16616E-09    0.10000E+01    0.34111E+05    0.47293E-53    0.41443E-63    0.13945E-62
+    1    3    0.16616E-09    0.10000E+01    0.27509E+05    0.38376E-52    0.82703E-62    0.99836E-62
+    1    3    0.16616E-09    0.10000E+01    0.22184E+05    0.38951E-51    0.23108E-60    0.77606E-61
+    1    3    0.16616E-09    0.10000E+01    0.17891E+05    0.53703E-50    0.71872E-59    0.82846E-60
+    1    3    0.16616E-09    0.10000E+01    0.14428E+05    0.84667E-49    0.21403E-57    0.12129E-58
+    1    3    0.16616E-09    0.10000E+01    0.11635E+05    0.13169E-47    0.60847E-56    0.19194E-57
+    1    3    0.16616E-09    0.10000E+01    0.93834E+04    0.19721E-46    0.16918E-54    0.29611E-56
+    1    3    0.16616E-09    0.10000E+01    0.75673E+04    0.28850E-45    0.46590E-53    0.44363E-55
+    1    3    0.16616E-09    0.10000E+01    0.61026E+04    0.41726E-44    0.12762E-51    0.65289E-54
+    1    3    0.16616E-09    0.10000E+01    0.49215E+04    0.59980E-43    0.34818E-50    0.95065E-53
+    1    3    0.16616E-09    0.10000E+01    0.39689E+04    0.85857E-42    0.94687E-49    0.13742E-51
+    1    3    0.16616E-09    0.10000E+01    0.32008E+04    0.38534E-39    0.83094E-46    0.62162E-49
+    1    3    0.16616E-09    0.10000E+01    0.25813E+04    0.28572E-30    0.14110E-36    0.46404E-40
+    1    3    0.16616E-09    0.10000E+01    0.20817E+04    0.55023E-14    0.12112E-19    0.89981E-24
+    1    3    0.16616E-09    0.10000E+01    0.16788E+04    0.18735E-08    0.17967E-13    0.30768E-18
+    1    3    0.16616E-09    0.10000E+01    0.13538E+04    0.40327E-08    0.68292E-13    0.66322E-18
+    1    3    0.16616E-09    0.10000E+01    0.10918E+04    0.84828E-08    0.25473E-12    0.13965E-17
+    1    3    0.16616E-09    0.10000E+01    0.88049E+03    0.17454E-07    0.93805E-12    0.28757E-17
+    1    3    0.16616E-09    0.10000E+01    0.71007E+03    0.35210E-07    0.34161E-11    0.58040E-17
+    1    3    0.16616E-09    0.10000E+01    0.57264E+03    0.69816E-07    0.12154E-10    0.11512E-16
+    1    3    0.16616E-09    0.10000E+01    0.46180E+03    0.13616E-06    0.40880E-10    0.22458E-16
+    1    3    0.16616E-09    0.10000E+01    0.37242E+03    0.25994E-06    0.12465E-09    0.42878E-16
+    1    3    0.16616E-09    0.10000E+01    0.30034E+03    0.48017E-06    0.33433E-09    0.79212E-16
+    1    3    0.16616E-09    0.10000E+01    0.24221E+03    0.84602E-06    0.78064E-09    0.13957E-15
+    1    3    0.16616E-09    0.10000E+01    0.19533E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    1    3    0.16616E-09    0.10000E+01    0.15752E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    1    3    0.28994E-09    0.10000E+01    0.80645E+05    0.22011E-56    0.16920E-67    0.11249E-65
+    1    3    0.28994E-09    0.10000E+01    0.65036E+05    0.19023E-55    0.27099E-66    0.96503E-65
+    1    3    0.28994E-09    0.10000E+01    0.52449E+05    0.16355E-54    0.36930E-65    0.82631E-64
+    1    3    0.28994E-09    0.10000E+01    0.42297E+05    0.12449E-53    0.50576E-64    0.62542E-63
+    1    3    0.28994E-09    0.10000E+01    0.34111E+05    0.90534E-53    0.69149E-63    0.44950E-62
+    1    3    0.28994E-09    0.10000E+01    0.27509E+05    0.65403E-52    0.10276E-61    0.31368E-61
+    1    3    0.28994E-09    0.10000E+01    0.22184E+05    0.51145E-51    0.21678E-60    0.21734E-60
+    1    3    0.28994E-09    0.10000E+01    0.17891E+05    0.53350E-50    0.62717E-59    0.17681E-59
+    1    3    0.28994E-09    0.10000E+01    0.14428E+05    0.75573E-49    0.19028E-57    0.20765E-58
+    1    3    0.28994E-09    0.10000E+01    0.11635E+05    0.11751E-47    0.55601E-56    0.31026E-57
+    1    3    0.28994E-09    0.10000E+01    0.93834E+04    0.17997E-46    0.15781E-54    0.48192E-56
+    1    3    0.28994E-09    0.10000E+01    0.75673E+04    0.26865E-45    0.44099E-53    0.73307E-55
+    1    3    0.28994E-09    0.10000E+01    0.61026E+04    0.39444E-44    0.12210E-51    0.10917E-53
+    1    3    0.28994E-09    0.10000E+01    0.49215E+04    0.57333E-43    0.33588E-50    0.16029E-52
+    1    3    0.28994E-09    0.10000E+01    0.39689E+04    0.82768E-42    0.91939E-49    0.23314E-51
+    1    3    0.28994E-09    0.10000E+01    0.32008E+04    0.37400E-39    0.81127E-46    0.10597E-48
+    1    3    0.28994E-09    0.10000E+01    0.25813E+04    0.27896E-30    0.13850E-36    0.79454E-40
+    1    3    0.28994E-09    0.10000E+01    0.20817E+04    0.54048E-14    0.11957E-19    0.15478E-23
+    1    3    0.28994E-09    0.10000E+01    0.16788E+04    0.18472E-08    0.17777E-13    0.53075E-18
+    1    3    0.28994E-09    0.10000E+01    0.13538E+04    0.39812E-08    0.67591E-13    0.11451E-17
+    1    3    0.28994E-09    0.10000E+01    0.10918E+04    0.83822E-08    0.25216E-12    0.24130E-17
+    1    3    0.28994E-09    0.10000E+01    0.88049E+03    0.17259E-07    0.92865E-12    0.49712E-17
+    1    3    0.28994E-09    0.10000E+01    0.71007E+03    0.34831E-07    0.33820E-11    0.10037E-16
+    1    3    0.28994E-09    0.10000E+01    0.57264E+03    0.69086E-07    0.12033E-10    0.19913E-16
+    1    3    0.28994E-09    0.10000E+01    0.46180E+03    0.13476E-06    0.40472E-10    0.38849E-16
+    1    3    0.28994E-09    0.10000E+01    0.37242E+03    0.25730E-06    0.12341E-09    0.74180E-16
+    1    3    0.28994E-09    0.10000E+01    0.30034E+03    0.47533E-06    0.33100E-09    0.13705E-15
+    1    3    0.28994E-09    0.10000E+01    0.24221E+03    0.83753E-06    0.77285E-09    0.24148E-15
+    1    3    0.28994E-09    0.10000E+01    0.19533E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    1    3    0.28994E-09    0.10000E+01    0.15752E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    1    3    0.50593E-09    0.10000E+01    0.80645E+05    0.44926E-56    0.34079E-67    0.39232E-65
+    1    3    0.50593E-09    0.10000E+01    0.65036E+05    0.38422E-55    0.54341E-66    0.33355E-64
+    1    3    0.50593E-09    0.10000E+01    0.52449E+05    0.32834E-54    0.73364E-65    0.28402E-63
+    1    3    0.50593E-09    0.10000E+01    0.42297E+05    0.24795E-53    0.99037E-64    0.21350E-62
+    1    3    0.50593E-09    0.10000E+01    0.34111E+05    0.17797E-52    0.13099E-62    0.15247E-61
+    1    3    0.50593E-09    0.10000E+01    0.27509E+05    0.12441E-51    0.16902E-61    0.10586E-60
+    1    3    0.50593E-09    0.10000E+01    0.22184E+05    0.86010E-51    0.25710E-60    0.70603E-60
+    1    3    0.50593E-09    0.10000E+01    0.17891E+05    0.67638E-50    0.58946E-59    0.47985E-59
+    1    3    0.50593E-09    0.10000E+01    0.14428E+05    0.74782E-49    0.17213E-57    0.41577E-58
+    1    3    0.50593E-09    0.10000E+01    0.11635E+05    0.10801E-47    0.51285E-56    0.52474E-57
+    1    3    0.50593E-09    0.10000E+01    0.93834E+04    0.16626E-46    0.14855E-54    0.79304E-56
+    1    3    0.50593E-09    0.10000E+01    0.75673E+04    0.25254E-45    0.42087E-53    0.12189E-54
+    1    3    0.50593E-09    0.10000E+01    0.61026E+04    0.37597E-44    0.11762E-51    0.18356E-53
+    1    3    0.50593E-09    0.10000E+01    0.49215E+04    0.55185E-43    0.32580E-50    0.27151E-52
+    1    3    0.50593E-09    0.10000E+01    0.39689E+04    0.80238E-42    0.89663E-49    0.39684E-51
+    1    3    0.50593E-09    0.10000E+01    0.32008E+04    0.36462E-39    0.79485E-46    0.18106E-48
+    1    3    0.50593E-09    0.10000E+01    0.25813E+04    0.27333E-30    0.13633E-36    0.13622E-39
+    1    3    0.50593E-09    0.10000E+01    0.20817E+04    0.53238E-14    0.11828E-19    0.26638E-23
+    1    3    0.50593E-09    0.10000E+01    0.16788E+04    0.18256E-08    0.17620E-13    0.91573E-18
+    1    3    0.50593E-09    0.10000E+01    0.13538E+04    0.39387E-08    0.67015E-13    0.19773E-17
+    1    3    0.50593E-09    0.10000E+01    0.10918E+04    0.82993E-08    0.25005E-12    0.41688E-17
+    1    3    0.50593E-09    0.10000E+01    0.88049E+03    0.17098E-07    0.92093E-12    0.85921E-17
+    1    3    0.50593E-09    0.10000E+01    0.71007E+03    0.34520E-07    0.33539E-11    0.17352E-16
+    1    3    0.50593E-09    0.10000E+01    0.57264E+03    0.68486E-07    0.11933E-10    0.34432E-16
+    1    3    0.50593E-09    0.10000E+01    0.46180E+03    0.13362E-06    0.40135E-10    0.67183E-16
+    1    3    0.50593E-09    0.10000E+01    0.37242E+03    0.25513E-06    0.12238E-09    0.12829E-15
+    1    3    0.50593E-09    0.10000E+01    0.30034E+03    0.47134E-06    0.32824E-09    0.23702E-15
+    1    3    0.50593E-09    0.10000E+01    0.24221E+03    0.83053E-06    0.76641E-09    0.41764E-15
+    1    3    0.50593E-09    0.10000E+01    0.19533E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    1    3    0.50593E-09    0.10000E+01    0.15752E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    1    3    0.88282E-09    0.10000E+01    0.80645E+05    0.91476E-56    0.68731E-67    0.13789E-64
+    1    3    0.88282E-09    0.10000E+01    0.65036E+05    0.77641E-55    0.10919E-65    0.11662E-63
+    1    3    0.88282E-09    0.10000E+01    0.52449E+05    0.66035E-54    0.14632E-64    0.98963E-63
+    1    3    0.88282E-09    0.10000E+01    0.42297E+05    0.49567E-53    0.19615E-63    0.74065E-62
+    1    3    0.88282E-09    0.10000E+01    0.34111E+05    0.35353E-52    0.25848E-62    0.52675E-61
+    1    3    0.88282E-09    0.10000E+01    0.27509E+05    0.24558E-51    0.32187E-61    0.36567E-60
+    1    3    0.88282E-09    0.10000E+01    0.22184E+05    0.16393E-50    0.40073E-60    0.24273E-59
+    1    3    0.88282E-09    0.10000E+01    0.17891E+05    0.10961E-49    0.65251E-59    0.15348E-58
+    1    3    0.88282E-09    0.10000E+01    0.14428E+05    0.89454E-49    0.16244E-57    0.10392E-57
+    1    3    0.88282E-09    0.10000E+01    0.11635E+05    0.10618E-47    0.47991E-56    0.98632E-57
+    1    3    0.88282E-09    0.10000E+01    0.93834E+04    0.15701E-46    0.14156E-54    0.13418E-55
+    1    3    0.88282E-09    0.10000E+01    0.75673E+04    0.24062E-45    0.40636E-53    0.20503E-54
+    1    3    0.88282E-09    0.10000E+01    0.61026E+04    0.36255E-44    0.11442E-51    0.31177E-53
+    1    3    0.88282E-09    0.10000E+01    0.49215E+04    0.53641E-43    0.31845E-50    0.46407E-52
+    1    3    0.88282E-09    0.10000E+01    0.39689E+04    0.78393E-42    0.87953E-49    0.68035E-51
+    1    3    0.88282E-09    0.10000E+01    0.32008E+04    0.35759E-39    0.78214E-46    0.31094E-48
+    1    3    0.88282E-09    0.10000E+01    0.25813E+04    0.26899E-30    0.13461E-36    0.23432E-39
+    1    3    0.88282E-09    0.10000E+01    0.20817E+04    0.52599E-14    0.11724E-19    0.45928E-23
+    1    3    0.88282E-09    0.10000E+01    0.16788E+04    0.18083E-08    0.17491E-13    0.15815E-17
+    1    3    0.88282E-09    0.10000E+01    0.13538E+04    0.39044E-08    0.66538E-13    0.34162E-17
+    1    3    0.88282E-09    0.10000E+01    0.10918E+04    0.82318E-08    0.24829E-12    0.72050E-17
+    1    3    0.88282E-09    0.10000E+01    0.88049E+03    0.16966E-07    0.91446E-12    0.14853E-16
+    1    3    0.88282E-09    0.10000E+01    0.71007E+03    0.34263E-07    0.33303E-11    0.30001E-16
+    1    3    0.88282E-09    0.10000E+01    0.57264E+03    0.67988E-07    0.11849E-10    0.59535E-16
+    1    3    0.88282E-09    0.10000E+01    0.46180E+03    0.13266E-06    0.39851E-10    0.11617E-15
+    1    3    0.88282E-09    0.10000E+01    0.37242E+03    0.25331E-06    0.12151E-09    0.22183E-15
+    1    3    0.88282E-09    0.10000E+01    0.30034E+03    0.46799E-06    0.32591E-09    0.40983E-15
+    1    3    0.88282E-09    0.10000E+01    0.24221E+03    0.82463E-06    0.76096E-09    0.72214E-15
+    1    3    0.88282E-09    0.10000E+01    0.19533E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    1    3    0.88282E-09    0.10000E+01    0.15752E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    1    3    0.15405E-08    0.10000E+01    0.80645E+05    0.22620E-55    0.16864E-66    0.23703E-63
+    1    3    0.15405E-08    0.10000E+01    0.65036E+05    0.19081E-54    0.26706E-65    0.19937E-62
+    1    3    0.15405E-08    0.10000E+01    0.52449E+05    0.16165E-53    0.35581E-64    0.16853E-61
+    1    3    0.15405E-08    0.10000E+01    0.42297E+05    0.12078E-52    0.47552E-63    0.12545E-60
+    1    3    0.15405E-08    0.10000E+01    0.34111E+05    0.85908E-52    0.63408E-62    0.88694E-60
+    1    3    0.15405E-08    0.10000E+01    0.27509E+05    0.60167E-51    0.81948E-61    0.61536E-59
+    1    3    0.15405E-08    0.10000E+01    0.22184E+05    0.41204E-50    0.10373E-59    0.41308E-58
+    1    3    0.15405E-08    0.10000E+01    0.17891E+05    0.27762E-49    0.14102E-58    0.26202E-57
+    1    3    0.15405E-08    0.10000E+01    0.14428E+05    0.19712E-48    0.24653E-57    0.15531E-56
+    1    3    0.15405E-08    0.10000E+01    0.11635E+05    0.17148E-47    0.58223E-56    0.90013E-56
+    1    3    0.15405E-08    0.10000E+01    0.93834E+04    0.19859E-46    0.15915E-54    0.61112E-55
+    1    3    0.15405E-08    0.10000E+01    0.75673E+04    0.27465E-45    0.44565E-53    0.60167E-54
+    1    3    0.15405E-08    0.10000E+01    0.61026E+04    0.39916E-44    0.12353E-51    0.77885E-53
+    1    3    0.15405E-08    0.10000E+01    0.49215E+04    0.57973E-43    0.33877E-50    0.10787E-51
+    1    3    0.15405E-08    0.10000E+01    0.39689E+04    0.83470E-42    0.92343E-49    0.14869E-50
+    1    3    0.15405E-08    0.10000E+01    0.32008E+04    0.37570E-39    0.81189E-46    0.63957E-48
+    1    3    0.15405E-08    0.10000E+01    0.25813E+04    0.27921E-30    0.13824E-36    0.45542E-39
+    1    3    0.15405E-08    0.10000E+01    0.20817E+04    0.53954E-14    0.11910E-19    0.84600E-23
+    1    3    0.15405E-08    0.10000E+01    0.16788E+04    0.18422E-08    0.17695E-13    0.28286E-17
+    1    3    0.15405E-08    0.10000E+01    0.13538E+04    0.39671E-08    0.67265E-13    0.60285E-17
+    1    3    0.15405E-08    0.10000E+01    0.10918E+04    0.83484E-08    0.25089E-12    0.12597E-16
+    1    3    0.15405E-08    0.10000E+01    0.88049E+03    0.17183E-07    0.92378E-12    0.25798E-16
+    1    3    0.15405E-08    0.10000E+01    0.71007E+03    0.34669E-07    0.33637E-11    0.51857E-16
+    1    3    0.15405E-08    0.10000E+01    0.57264E+03    0.68748E-07    0.11966E-10    0.10254E-15
+    1    3    0.15405E-08    0.10000E+01    0.46180E+03    0.13408E-06    0.40244E-10    0.19956E-15
+    1    3    0.15405E-08    0.10000E+01    0.37242E+03    0.25595E-06    0.12271E-09    0.38034E-15
+    1    3    0.15405E-08    0.10000E+01    0.30034E+03    0.47277E-06    0.32910E-09    0.70172E-15
+    1    3    0.15405E-08    0.10000E+01    0.24221E+03    0.83294E-06    0.76841E-09    0.12353E-14
+    1    3    0.15405E-08    0.10000E+01    0.19533E+03    0.13127E-05    0.14602E-08    0.19459E-14
+    1    3    0.15405E-08    0.10000E+01    0.15752E+03    0.13127E-05    0.14602E-08    0.19459E-14
+    1    3    0.26880E-08    0.10000E+01    0.80645E+05    0.47006E-55    0.34964E-66    0.12965E-62
+    1    3    0.26880E-08    0.10000E+01    0.65036E+05    0.39578E-54    0.55302E-65    0.10897E-61
+    1    3    0.26880E-08    0.10000E+01    0.52449E+05    0.33482E-53    0.73466E-64    0.92058E-61
+    1    3    0.26880E-08    0.10000E+01    0.42297E+05    0.24957E-52    0.97749E-63    0.68466E-60
+    1    3    0.26880E-08    0.10000E+01    0.34111E+05    0.17685E-51    0.12954E-61    0.48342E-59
+    1    3    0.26880E-08    0.10000E+01    0.27509E+05    0.12315E-50    0.16528E-60    0.33492E-58
+    1    3    0.26880E-08    0.10000E+01    0.22184E+05    0.83349E-50    0.20083E-59    0.22462E-57
+    1    3    0.26880E-08    0.10000E+01    0.17891E+05    0.54253E-49    0.24200E-58    0.14251E-56
+    1    3    0.26880E-08    0.10000E+01    0.14428E+05    0.34916E-48    0.33952E-57    0.84343E-56
+    1    3    0.26880E-08    0.10000E+01    0.11635E+05    0.25040E-47    0.66759E-56    0.47815E-55
+    1    3    0.26880E-08    0.10000E+01    0.93834E+04    0.23827E-46    0.17057E-54    0.29526E-54
+    1    3    0.26880E-08    0.10000E+01    0.75673E+04    0.29940E-45    0.46972E-53    0.24503E-53
+    1    3    0.26880E-08    0.10000E+01    0.61026E+04    0.42228E-44    0.12894E-51    0.27461E-52
+    1    3    0.26880E-08    0.10000E+01    0.49215E+04    0.60549E-43    0.34976E-50    0.34354E-51
+    1    3    0.26880E-08    0.10000E+01    0.39689E+04    0.86222E-42    0.94322E-49    0.43193E-50
+    1    3    0.26880E-08    0.10000E+01    0.32008E+04    0.38396E-39    0.82165E-46    0.16890E-47
+    1    3    0.26880E-08    0.10000E+01    0.25813E+04    0.28261E-30    0.13877E-36    0.10865E-38
+    1    3    0.26880E-08    0.10000E+01    0.20817E+04    0.54136E-14    0.11863E-19    0.17980E-22
+    1    3    0.26880E-08    0.10000E+01    0.16788E+04    0.18398E-08    0.17575E-13    0.55750E-17
+    1    3    0.26880E-08    0.10000E+01    0.13538E+04    0.39534E-08    0.66770E-13    0.11475E-16
+    1    3    0.26880E-08    0.10000E+01    0.10918E+04    0.83073E-08    0.24894E-12    0.23377E-16
+    1    3    0.26880E-08    0.10000E+01    0.88049E+03    0.17081E-07    0.91628E-12    0.46994E-16
+    1    3    0.26880E-08    0.10000E+01    0.71007E+03    0.34436E-07    0.33356E-11    0.93182E-16
+    1    3    0.26880E-08    0.10000E+01    0.57264E+03    0.68247E-07    0.11864E-10    0.18241E-15
+    1    3    0.26880E-08    0.10000E+01    0.46180E+03    0.13305E-06    0.39896E-10    0.35239E-15
+    1    3    0.26880E-08    0.10000E+01    0.37242E+03    0.25389E-06    0.12164E-09    0.66804E-15
+    1    3    0.26880E-08    0.10000E+01    0.30034E+03    0.46887E-06    0.32622E-09    0.12280E-14
+    1    3    0.26880E-08    0.10000E+01    0.24221E+03    0.82594E-06    0.76167E-09    0.21563E-14
+    1    3    0.26880E-08    0.10000E+01    0.19533E+03    0.13016E-05    0.14474E-08    0.33915E-14
+    1    3    0.26880E-08    0.10000E+01    0.15752E+03    0.13016E-05    0.14474E-08    0.33915E-14
+    1    3    0.46905E-08    0.10000E+01    0.80645E+05    0.94304E-55    0.70058E-66    0.55234E-62
+    1    3    0.46905E-08    0.10000E+01    0.65036E+05    0.79323E-54    0.11074E-64    0.46463E-61
+    1    3    0.46905E-08    0.10000E+01    0.52449E+05    0.67053E-53    0.14687E-63    0.39283E-60
+    1    3    0.46905E-08    0.10000E+01    0.42297E+05    0.49915E-52    0.19493E-62    0.29257E-59
+    1    3    0.46905E-08    0.10000E+01    0.34111E+05    0.35295E-51    0.25743E-61    0.20714E-58
+    1    3    0.46905E-08    0.10000E+01    0.27509E+05    0.24500E-50    0.32630E-60    0.14419E-57
+    1    3    0.46905E-08    0.10000E+01    0.22184E+05    0.16483E-49    0.38892E-59    0.97546E-57
+    1    3    0.46905E-08    0.10000E+01    0.17891E+05    0.10557E-48    0.44067E-58    0.62839E-56
+    1    3    0.46905E-08    0.10000E+01    0.14428E+05    0.64692E-48    0.53252E-57    0.38025E-55
+    1    3    0.46905E-08    0.10000E+01    0.11635E+05    0.41071E-47    0.86809E-56    0.21873E-54
+    1    3    0.46905E-08    0.10000E+01    0.93834E+04    0.32617E-46    0.20055E-54    0.12907E-53
+    1    3    0.46905E-08    0.10000E+01    0.75673E+04    0.36079E-45    0.53297E-53    0.92525E-53
+    1    3    0.46905E-08    0.10000E+01    0.61026E+04    0.48234E-44    0.14307E-51    0.89592E-52
+    1    3    0.46905E-08    0.10000E+01    0.49215E+04    0.67297E-43    0.37937E-50    0.10381E-50
+    1    3    0.46905E-08    0.10000E+01    0.39689E+04    0.93648E-42    0.10010E-48    0.12466E-49
+    1    3    0.46905E-08    0.10000E+01    0.32008E+04    0.40801E-39    0.85540E-46    0.46364E-47
+    1    3    0.46905E-08    0.10000E+01    0.25813E+04    0.29431E-30    0.14194E-36    0.27817E-38
+    1    3    0.46905E-08    0.10000E+01    0.20817E+04    0.55308E-14    0.11922E-19    0.41446E-22
+    1    3    0.46905E-08    0.10000E+01    0.16788E+04    0.18597E-08    0.17545E-13    0.11810E-16
+    1    3    0.46905E-08    0.10000E+01    0.13538E+04    0.39770E-08    0.66571E-13    0.23178E-16
+    1    3    0.46905E-08    0.10000E+01    0.10918E+04    0.83290E-08    0.24796E-12    0.45495E-16
+    1    3    0.46905E-08    0.10000E+01    0.88049E+03    0.17085E-07    0.91204E-12    0.88868E-16
+    1    3    0.46905E-08    0.10000E+01    0.71007E+03    0.34385E-07    0.33185E-11    0.17238E-15
+    1    3    0.46905E-08    0.10000E+01    0.57264E+03    0.68060E-07    0.11799E-10    0.33184E-15
+    1    3    0.46905E-08    0.10000E+01    0.46180E+03    0.13256E-06    0.39670E-10    0.63304E-15
+    1    3    0.46905E-08    0.10000E+01    0.37242E+03    0.25279E-06    0.12093E-09    0.11891E-14
+    1    3    0.46905E-08    0.10000E+01    0.30034E+03    0.46661E-06    0.32431E-09    0.21717E-14
+    1    3    0.46905E-08    0.10000E+01    0.24221E+03    0.82169E-06    0.75716E-09    0.37967E-14
+    1    3    0.46905E-08    0.10000E+01    0.19533E+03    0.12946E-05    0.14388E-08    0.59555E-14
+    1    3    0.46905E-08    0.10000E+01    0.15752E+03    0.12946E-05    0.14388E-08    0.59555E-14
+    1    3    0.81846E-08    0.10000E+01    0.80645E+05    0.18327E-54    0.13611E-65    0.20472E-61
+    1    3    0.81846E-08    0.10000E+01    0.65036E+05    0.15412E-53    0.21511E-64    0.17242E-60
+    1    3    0.81846E-08    0.10000E+01    0.52449E+05    0.13026E-52    0.28523E-63    0.14593E-59
+    1    3    0.81846E-08    0.10000E+01    0.42297E+05    0.96944E-52    0.37845E-62    0.10890E-58
+    1    3    0.81846E-08    0.10000E+01    0.34111E+05    0.68532E-51    0.49977E-61    0.77371E-58
+    1    3    0.81846E-08    0.10000E+01    0.27509E+05    0.47567E-50    0.63366E-60    0.54185E-57
+    1    3    0.81846E-08    0.10000E+01    0.22184E+05    0.32004E-49    0.75366E-59    0.37040E-56
+    1    3    0.81846E-08    0.10000E+01    0.17891E+05    0.20454E-48    0.83821E-58    0.24290E-55
+    1    3    0.81846E-08    0.10000E+01    0.14428E+05    0.12352E-47    0.93869E-57    0.15097E-54
+    1    3    0.81846E-08    0.10000E+01    0.11635E+05    0.73968E-47    0.13073E-55    0.89202E-54
+    1    3    0.81846E-08    0.10000E+01    0.93834E+04    0.51345E-46    0.26393E-54    0.51996E-53
+    1    3    0.81846E-08    0.10000E+01    0.75673E+04    0.49056E-45    0.65906E-53    0.33325E-52
+    1    3    0.81846E-08    0.10000E+01    0.61026E+04    0.60374E-44    0.17078E-51    0.27343E-51
+    1    3    0.81846E-08    0.10000E+01    0.49215E+04    0.80635E-43    0.43826E-50    0.28767E-50
+    1    3    0.81846E-08    0.10000E+01    0.39689E+04    0.10843E-41    0.11191E-48    0.33476E-49
+    1    3    0.81846E-08    0.10000E+01    0.32008E+04    0.45699E-39    0.92696E-46    0.12239E-46
+    1    3    0.81846E-08    0.10000E+01    0.25813E+04    0.31902E-30    0.14912E-36    0.71085E-38
+    1    3    0.81846E-08    0.10000E+01    0.20817E+04    0.57961E-14    0.12115E-19    0.98929E-22
+    1    3    0.81846E-08    0.10000E+01    0.16788E+04    0.19102E-08    0.17593E-13    0.26338E-16
+    1    3    0.81846E-08    0.10000E+01    0.13538E+04    0.40478E-08    0.66583E-13    0.49105E-16
+    1    3    0.81846E-08    0.10000E+01    0.10918E+04    0.84228E-08    0.24755E-12    0.92317E-16
+    1    3    0.81846E-08    0.10000E+01    0.88049E+03    0.17198E-07    0.90936E-12    0.17402E-15
+    1    3    0.81846E-08    0.10000E+01    0.71007E+03    0.34496E-07    0.33057E-11    0.32793E-15
+    1    3    0.81846E-08    0.10000E+01    0.57264E+03    0.68111E-07    0.11747E-10    0.61694E-15
+    1    3    0.81846E-08    0.10000E+01    0.46180E+03    0.13242E-06    0.39477E-10    0.11560E-14
+    1    3    0.81846E-08    0.10000E+01    0.37242E+03    0.25219E-06    0.12031E-09    0.21425E-14
+    1    3    0.81846E-08    0.10000E+01    0.30034E+03    0.46509E-06    0.32261E-09    0.38750E-14
+    1    3    0.81846E-08    0.10000E+01    0.24221E+03    0.81850E-06    0.75314E-09    0.67291E-14
+    1    3    0.81846E-08    0.10000E+01    0.19533E+03    0.12891E-05    0.14311E-08    0.10512E-13
+    1    3    0.81846E-08    0.10000E+01    0.15752E+03    0.12891E-05    0.14311E-08    0.10512E-13
+    1    3    0.14282E-07    0.10000E+01    0.80645E+05    0.34257E-54    0.25451E-65    0.65442E-61
+    1    3    0.14282E-07    0.10000E+01    0.65036E+05    0.28817E-53    0.40236E-64    0.55175E-60
+    1    3    0.14282E-07    0.10000E+01    0.52449E+05    0.24363E-52    0.53394E-63    0.46742E-59
+    1    3    0.14282E-07    0.10000E+01    0.42297E+05    0.18144E-51    0.70950E-62    0.34942E-58
+    1    3    0.14282E-07    0.10000E+01    0.34111E+05    0.12843E-50    0.93953E-61    0.24904E-57
+    1    3    0.14282E-07    0.10000E+01    0.27509E+05    0.89351E-50    0.11974E-59    0.17533E-56
+    1    3    0.14282E-07    0.10000E+01    0.22184E+05    0.60376E-49    0.14362E-58    0.12093E-55
+    1    3    0.14282E-07    0.10000E+01    0.17891E+05    0.38846E-48    0.16077E-57    0.80497E-55
+    1    3    0.14282E-07    0.10000E+01    0.14428E+05    0.23576E-47    0.17575E-56    0.51183E-54
+    1    3    0.14282E-07    0.10000E+01    0.11635E+05    0.13883E-46    0.21944E-55    0.31057E-53
+    1    3    0.14282E-07    0.10000E+01    0.93834E+04    0.88664E-46    0.38013E-54    0.18261E-52
+    1    3    0.14282E-07    0.10000E+01    0.75673E+04    0.73386E-45    0.86593E-53    0.11035E-51
+    1    3    0.14282E-07    0.10000E+01    0.61026E+04    0.80940E-44    0.21466E-51    0.78459E-51
+    1    3    0.14282E-07    0.10000E+01    0.49215E+04    0.10208E-42    0.53246E-50    0.73008E-50
+    1    3    0.14282E-07    0.10000E+01    0.39689E+04    0.13213E-41    0.13123E-48    0.81438E-49
+    1    3    0.14282E-07    0.10000E+01    0.32008E+04    0.53689E-39    0.10467E-45    0.29647E-46
+    1    3    0.14282E-07    0.10000E+01    0.25813E+04    0.36018E-30    0.16144E-36    0.17095E-37
+    1    3    0.14282E-07    0.10000E+01    0.20817E+04    0.62502E-14    0.12469E-19    0.23078E-21
+    1    3    0.14282E-07    0.10000E+01    0.16788E+04    0.19999E-08    0.17715E-13    0.59069E-16
+    1    3    0.14282E-07    0.10000E+01    0.13538E+04    0.41767E-08    0.66763E-13    0.10536E-15
+    1    3    0.14282E-07    0.10000E+01    0.10918E+04    0.86008E-08    0.24747E-12    0.19036E-15
+    1    3    0.14282E-07    0.10000E+01    0.88049E+03    0.17428E-07    0.90707E-12    0.34647E-15
+    1    3    0.14282E-07    0.10000E+01    0.71007E+03    0.34765E-07    0.32924E-11    0.63350E-15
+    1    3    0.14282E-07    0.10000E+01    0.57264E+03    0.68362E-07    0.11687E-10    0.11619E-14
+    1    3    0.14282E-07    0.10000E+01    0.46180E+03    0.13251E-06    0.39253E-10    0.21327E-14
+    1    3    0.14282E-07    0.10000E+01    0.37242E+03    0.25182E-06    0.11959E-09    0.38894E-14
+    1    3    0.14282E-07    0.10000E+01    0.30034E+03    0.46369E-06    0.32059E-09    0.69512E-14
+    1    3    0.14282E-07    0.10000E+01    0.24221E+03    0.81521E-06    0.74832E-09    0.11970E-13
+    1    3    0.14282E-07    0.10000E+01    0.19533E+03    0.12831E-05    0.14218E-08    0.18601E-13
+    1    3    0.14282E-07    0.10000E+01    0.15752E+03    0.12831E-05    0.14218E-08    0.18601E-13
+    1    3    0.24920E-07    0.10000E+01    0.80645E+05    0.61926E-54    0.46046E-65    0.18610E-60
+    1    3    0.24920E-07    0.10000E+01    0.65036E+05    0.52127E-53    0.72834E-64    0.15704E-59
+    1    3    0.24920E-07    0.10000E+01    0.52449E+05    0.44098E-52    0.96787E-63    0.13315E-58
+    1    3    0.24920E-07    0.10000E+01    0.42297E+05    0.32878E-51    0.12893E-61    0.99679E-58
+    1    3    0.24920E-07    0.10000E+01    0.34111E+05    0.23322E-50    0.17146E-60    0.71230E-57
+    1    3    0.24920E-07    0.10000E+01    0.27509E+05    0.16286E-49    0.22020E-59    0.50364E-56
+    1    3    0.24920E-07    0.10000E+01    0.22184E+05    0.11076E-48    0.26768E-58    0.34986E-55
+    1    3    0.24920E-07    0.10000E+01    0.17891E+05    0.72045E-48    0.30512E-57    0.23567E-54
+    1    3    0.24920E-07    0.10000E+01    0.14428E+05    0.44362E-47    0.33516E-56    0.15260E-53
+    1    3    0.24920E-07    0.10000E+01    0.11635E+05    0.26267E-46    0.39332E-55    0.94766E-53
+    1    3    0.24920E-07    0.10000E+01    0.93834E+04    0.16083E-45    0.58908E-54    0.56702E-52
+    1    3    0.24920E-07    0.10000E+01    0.75673E+04    0.11798E-44    0.11890E-52    0.33574E-51
+    1    3    0.24920E-07    0.10000E+01    0.61026E+04    0.11442E-43    0.27860E-51    0.21620E-50
+    1    3    0.24920E-07    0.10000E+01    0.49215E+04    0.13413E-42    0.67009E-50    0.17609E-49
+    1    3    0.24920E-07    0.10000E+01    0.39689E+04    0.16697E-41    0.16021E-48    0.18363E-48
+    1    3    0.24920E-07    0.10000E+01    0.32008E+04    0.65659E-39    0.12319E-45    0.66346E-46
+    1    3    0.24920E-07    0.10000E+01    0.25813E+04    0.42361E-30    0.18122E-36    0.38445E-37
+    1    3    0.24920E-07    0.10000E+01    0.20817E+04    0.69807E-14    0.13100E-19    0.51648E-21
+    1    3    0.24920E-07    0.10000E+01    0.16788E+04    0.21527E-08    0.18027E-13    0.13007E-15
+    1    3    0.24920E-07    0.10000E+01    0.13538E+04    0.44047E-08    0.67502E-13    0.22392E-15
+    1    3    0.24920E-07    0.10000E+01    0.10918E+04    0.89349E-08    0.24905E-12    0.39142E-15
+    1    3    0.24920E-07    0.10000E+01    0.88049E+03    0.17905E-07    0.90985E-12    0.69099E-15
+    1    3    0.24920E-07    0.10000E+01    0.71007E+03    0.35420E-07    0.32948E-11    0.12288E-14
+    1    3    0.24920E-07    0.10000E+01    0.57264E+03    0.69222E-07    0.11678E-10    0.21989E-14
+    1    3    0.24920E-07    0.10000E+01    0.46180E+03    0.13356E-06    0.39183E-10    0.39523E-14
+    1    3    0.24920E-07    0.10000E+01    0.37242E+03    0.25299E-06    0.11930E-09    0.70862E-14
+    1    3    0.24920E-07    0.10000E+01    0.30034E+03    0.46476E-06    0.31972E-09    0.12501E-13
+    1    3    0.24920E-07    0.10000E+01    0.24221E+03    0.81581E-06    0.74613E-09    0.21327E-13
+    1    3    0.24920E-07    0.10000E+01    0.19533E+03    0.12828E-05    0.14175E-08    0.32945E-13
+    1    3    0.24920E-07    0.10000E+01    0.15752E+03    0.12828E-05    0.14175E-08    0.32945E-13
+    1    3    0.43485E-07    0.10000E+01    0.80645E+05    0.10929E-53    0.81346E-65    0.49312E-60
+    1    3    0.43485E-07    0.10000E+01    0.65036E+05    0.92070E-53    0.12875E-63    0.41646E-59
+    1    3    0.43485E-07    0.10000E+01    0.52449E+05    0.77946E-52    0.17139E-62    0.35333E-58
+    1    3    0.43485E-07    0.10000E+01    0.42297E+05    0.58195E-51    0.22899E-61    0.26484E-57
+    1    3    0.43485E-07    0.10000E+01    0.34111E+05    0.41383E-50    0.30600E-60    0.18968E-56
+    1    3    0.43485E-07    0.10000E+01    0.27509E+05    0.29022E-49    0.39638E-59    0.13460E-55
+    1    3    0.43485E-07    0.10000E+01    0.22184E+05    0.19885E-48    0.48910E-58    0.94070E-55
+    1    3    0.43485E-07    0.10000E+01    0.17891E+05    0.13095E-47    0.56999E-57    0.63994E-54
+    1    3    0.43485E-07    0.10000E+01    0.14428E+05    0.82084E-47    0.63764E-56    0.42069E-53
+    1    3    0.43485E-07    0.10000E+01    0.11635E+05    0.49386E-46    0.72866E-55    0.26662E-52
+    1    3    0.43485E-07    0.10000E+01    0.93834E+04    0.29798E-45    0.97043E-54    0.16283E-51
+    1    3    0.43485E-07    0.10000E+01    0.75673E+04    0.20011E-44    0.16987E-52    0.96583E-51
+    1    3    0.43485E-07    0.10000E+01    0.61026E+04    0.16956E-43    0.36824E-51    0.58727E-50
+    1    3    0.43485E-07    0.10000E+01    0.49215E+04    0.18085E-42    0.85835E-50    0.42195E-49
+    1    3    0.43485E-07    0.10000E+01    0.39689E+04    0.21535E-41    0.20067E-48    0.39899E-48
+    1    3    0.43485E-07    0.10000E+01    0.32008E+04    0.82391E-39    0.14976E-45    0.14088E-45
+    1    3    0.43485E-07    0.10000E+01    0.25813E+04    0.51434E-30    0.21030E-36    0.82356E-37
+    1    3    0.43485E-07    0.10000E+01    0.20817E+04    0.80589E-14    0.14054E-19    0.11199E-20
+    1    3    0.43485E-07    0.10000E+01    0.16788E+04    0.23855E-08    0.18511E-13    0.28178E-15
+    1    3    0.43485E-07    0.10000E+01    0.13538E+04    0.47516E-08    0.68676E-13    0.47098E-15
+    1    3    0.43485E-07    0.10000E+01    0.10918E+04    0.94444E-08    0.25166E-12    0.80072E-15
+    1    3    0.43485E-07    0.10000E+01    0.88049E+03    0.18636E-07    0.91489E-12    0.13766E-14
+    1    3    0.43485E-07    0.10000E+01    0.71007E+03    0.36436E-07    0.33016E-11    0.23874E-14
+    1    3    0.43485E-07    0.10000E+01    0.57264E+03    0.70577E-07    0.11675E-10    0.41745E-14
+    1    3    0.43485E-07    0.10000E+01    0.46180E+03    0.13527E-06    0.39115E-10    0.73500E-14
+    1    3    0.43485E-07    0.10000E+01    0.37242E+03    0.25498E-06    0.11899E-09    0.12951E-13
+    1    3    0.43485E-07    0.10000E+01    0.30034E+03    0.46682E-06    0.31872E-09    0.22539E-13
+    1    3    0.43485E-07    0.10000E+01    0.24221E+03    0.81750E-06    0.74356E-09    0.38062E-13
+    1    3    0.43485E-07    0.10000E+01    0.19533E+03    0.12837E-05    0.14123E-08    0.58417E-13
+    1    3    0.43485E-07    0.10000E+01    0.15752E+03    0.12837E-05    0.14123E-08    0.58417E-13
+    1    3    0.75878E-07    0.10000E+01    0.80645E+05    0.18972E-53    0.14137E-64    0.12615E-59
+    1    3    0.75878E-07    0.10000E+01    0.65036E+05    0.15997E-52    0.22392E-63    0.10661E-58
+    1    3    0.75878E-07    0.10000E+01    0.52449E+05    0.13554E-51    0.29858E-62    0.90506E-58
+    1    3    0.75878E-07    0.10000E+01    0.42297E+05    0.10134E-50    0.40015E-61    0.67915E-57
+    1    3    0.75878E-07    0.10000E+01    0.34111E+05    0.72251E-50    0.53738E-60    0.48736E-56
+    1    3    0.75878E-07    0.10000E+01    0.27509E+05    0.50892E-49    0.70211E-59    0.34697E-55
+    1    3    0.75878E-07    0.10000E+01    0.22184E+05    0.35128E-48    0.87923E-58    0.24377E-54
+    1    3    0.75878E-07    0.10000E+01    0.17891E+05    0.23419E-47    0.10477E-56    0.16725E-53
+    1    3    0.75878E-07    0.10000E+01    0.14428E+05    0.14952E-46    0.11998E-55    0.11139E-52
+    1    3    0.75878E-07    0.10000E+01    0.11635E+05    0.91776E-46    0.13667E-54    0.71882E-52
+    1    3    0.75878E-07    0.10000E+01    0.93834E+04    0.55513E-45    0.16820E-53    0.44830E-51
+    1    3    0.75878E-07    0.10000E+01    0.75673E+04    0.35297E-44    0.25483E-52    0.26958E-50
+    1    3    0.75878E-07    0.10000E+01    0.61026E+04    0.26440E-43    0.49629E-51    0.15993E-49
+    1    3    0.75878E-07    0.10000E+01    0.49215E+04    0.25097E-42    0.11099E-49    0.10388E-48
+    1    3    0.75878E-07    0.10000E+01    0.39689E+04    0.28179E-41    0.25528E-48    0.86782E-48
+    1    3    0.75878E-07    0.10000E+01    0.32008E+04    0.10514E-38    0.18676E-45    0.29154E-45
+    1    3    0.75878E-07    0.10000E+01    0.25813E+04    0.64076E-30    0.25213E-36    0.17150E-36
+    1    3    0.75878E-07    0.10000E+01    0.20817E+04    0.96264E-14    0.15481E-19    0.23911E-20
+    1    3    0.75878E-07    0.10000E+01    0.16788E+04    0.27378E-08    0.19275E-13    0.60747E-15
+    1    3    0.75878E-07    0.10000E+01    0.13538E+04    0.52768E-08    0.70600E-13    0.98848E-15
+    1    3    0.75878E-07    0.10000E+01    0.10918E+04    0.10220E-07    0.25624E-12    0.16392E-14
+    1    3    0.75878E-07    0.10000E+01    0.88049E+03    0.19762E-07    0.92497E-12    0.27514E-14
+    1    3    0.75878E-07    0.10000E+01    0.71007E+03    0.38031E-07    0.33212E-11    0.46622E-14
+    1    3    0.75878E-07    0.10000E+01    0.57264E+03    0.72768E-07    0.11704E-10    0.79729E-14
+    1    3    0.75878E-07    0.10000E+01    0.46180E+03    0.13817E-06    0.39129E-10    0.13752E-13
+    1    3    0.75878E-07    0.10000E+01    0.37242E+03    0.25865E-06    0.11888E-09    0.23801E-13
+    1    3    0.75878E-07    0.10000E+01    0.30034E+03    0.47119E-06    0.31817E-09    0.40819E-13
+    1    3    0.75878E-07    0.10000E+01    0.24221E+03    0.82235E-06    0.74195E-09    0.68173E-13
+    1    3    0.75878E-07    0.10000E+01    0.19533E+03    0.12886E-05    0.14089E-08    0.10387E-12
+    1    3    0.75878E-07    0.10000E+01    0.15752E+03    0.12886E-05    0.14089E-08    0.10387E-12
+    1    3    0.13240E-06    0.10000E+01    0.80645E+05    0.32574E-53    0.24299E-64    0.32157E-59
+    1    3    0.13240E-06    0.10000E+01    0.65036E+05    0.27491E-52    0.38515E-63    0.27194E-58
+    1    3    0.13240E-06    0.10000E+01    0.52449E+05    0.23310E-51    0.51447E-62    0.23099E-57
+    1    3    0.13240E-06    0.10000E+01    0.42297E+05    0.17453E-50    0.69154E-61    0.17351E-56
+    1    3    0.13240E-06    0.10000E+01    0.34111E+05    0.12475E-49    0.93317E-60    0.12474E-55
+    1    3    0.13240E-06    0.10000E+01    0.27509E+05    0.88247E-49    0.12292E-58    0.89065E-55
+    1    3    0.13240E-06    0.10000E+01    0.22184E+05    0.61345E-48    0.15607E-57    0.62871E-54
+    1    3    0.13240E-06    0.10000E+01    0.17891E+05    0.41377E-47    0.18992E-56    0.43466E-53
+    1    3    0.13240E-06    0.10000E+01    0.14428E+05    0.26881E-46    0.22284E-55    0.29285E-52
+    1    3    0.13240E-06    0.10000E+01    0.11635E+05    0.16849E-45    0.25657E-54    0.19204E-51
+    1    3    0.13240E-06    0.10000E+01    0.93834E+04    0.10317E-44    0.30266E-53    0.12221E-50
+    1    3    0.13240E-06    0.10000E+01    0.75673E+04    0.63899E-44    0.40504E-52    0.74925E-50
+    1    3    0.13240E-06    0.10000E+01    0.61026E+04    0.43449E-43    0.68890E-51    0.44369E-49
+    1    3    0.13240E-06    0.10000E+01    0.49215E+04    0.36192E-42    0.14431E-49    0.26939E-48
+    1    3    0.13240E-06    0.10000E+01    0.39689E+04    0.37378E-41    0.32637E-48    0.19690E-47
+    1    3    0.13240E-06    0.10000E+01    0.32008E+04    0.13529E-38    0.23641E-45    0.60680E-45
+    1    3    0.13240E-06    0.10000E+01    0.25813E+04    0.81164E-30    0.31031E-36    0.35554E-36
+    1    3    0.13240E-06    0.10000E+01    0.20817E+04    0.11855E-13    0.17527E-19    0.51374E-20
+    1    3    0.13240E-06    0.10000E+01    0.16788E+04    0.32595E-08    0.20380E-13    0.13278E-14
+    1    3    0.13240E-06    0.10000E+01    0.13538E+04    0.60466E-08    0.73378E-13    0.21034E-14
+    1    3    0.13240E-06    0.10000E+01    0.10918E+04    0.11351E-07    0.26282E-12    0.34036E-14
+    1    3    0.13240E-06    0.10000E+01    0.88049E+03    0.21397E-07    0.93932E-12    0.55812E-14
+    1    3    0.13240E-06    0.10000E+01    0.71007E+03    0.40340E-07    0.33486E-11    0.92422E-14
+    1    3    0.13240E-06    0.10000E+01    0.57264E+03    0.75932E-07    0.11743E-10    0.15451E-13
+    1    3    0.13240E-06    0.10000E+01    0.46180E+03    0.14234E-06    0.39133E-10    0.26077E-13
+    1    3    0.13240E-06    0.10000E+01    0.37242E+03    0.26388E-06    0.11867E-09    0.44252E-13
+    1    3    0.13240E-06    0.10000E+01    0.30034E+03    0.47737E-06    0.31724E-09    0.74648E-13
+    1    3    0.13240E-06    0.10000E+01    0.24221E+03    0.82909E-06    0.73928E-09    0.12307E-12
+    1    3    0.13240E-06    0.10000E+01    0.19533E+03    0.12953E-05    0.14033E-08    0.18591E-12
+    1    3    0.13240E-06    0.10000E+01    0.15752E+03    0.12953E-05    0.14033E-08    0.18591E-12
+    1    3    0.23103E-06    0.10000E+01    0.80645E+05    0.55534E-53    0.41470E-64    0.83320E-59
+    1    3    0.23103E-06    0.10000E+01    0.65036E+05    0.46908E-52    0.65774E-63    0.70502E-58
+    1    3    0.23103E-06    0.10000E+01    0.52449E+05    0.39804E-51    0.88004E-62    0.59916E-57
+    1    3    0.23103E-06    0.10000E+01    0.42297E+05    0.29843E-50    0.11863E-60    0.45047E-56
+    1    3    0.23103E-06    0.10000E+01    0.34111E+05    0.21383E-49    0.16079E-59    0.32437E-55
+    1    3    0.23103E-06    0.10000E+01    0.27509E+05    0.15185E-48    0.21339E-58    0.23221E-54
+    1    3    0.23103E-06    0.10000E+01    0.22184E+05    0.10625E-47    0.27433E-57    0.16461E-53
+    1    3    0.23103E-06    0.10000E+01    0.17891E+05    0.72428E-47    0.34016E-56    0.11456E-52
+    1    3    0.23103E-06    0.10000E+01    0.14428E+05    0.47805E-46    0.40847E-55    0.77963E-52
+    1    3    0.23103E-06    0.10000E+01    0.11635E+05    0.30569E-45    0.47868E-54    0.51842E-51
+    1    3    0.23103E-06    0.10000E+01    0.93834E+04    0.19042E-44    0.55683E-53    0.33596E-50
+    1    3    0.23103E-06    0.10000E+01    0.75673E+04    0.11728E-43    0.68333E-52    0.21027E-49
+    1    3    0.23103E-06    0.10000E+01    0.61026E+04    0.74904E-43    0.10046E-50    0.12600E-48
+    1    3    0.23103E-06    0.10000E+01    0.49215E+04    0.55035E-42    0.19007E-49    0.73999E-48
+    1    3    0.23103E-06    0.10000E+01    0.39689E+04    0.50783E-41    0.41766E-48    0.48108E-47
+    1    3    0.23103E-06    0.10000E+01    0.32008E+04    0.17539E-38    0.30166E-45    0.13137E-44
+    1    3    0.23103E-06    0.10000E+01    0.25813E+04    0.10405E-29    0.39025E-36    0.75162E-36
+    1    3    0.23103E-06    0.10000E+01    0.20817E+04    0.15035E-13    0.20466E-19    0.11339E-19
+    1    3    0.23103E-06    0.10000E+01    0.16788E+04    0.40400E-08    0.22014E-13    0.29951E-14
+    1    3    0.23103E-06    0.10000E+01    0.13538E+04    0.71865E-08    0.77551E-13    0.46135E-14
+    1    3    0.23103E-06    0.10000E+01    0.10918E+04    0.13018E-07    0.27292E-12    0.72787E-14
+    1    3    0.23103E-06    0.10000E+01    0.88049E+03    0.23809E-07    0.96221E-12    0.11651E-13
+    1    3    0.23103E-06    0.10000E+01    0.71007E+03    0.43765E-07    0.33957E-11    0.18837E-13
+    1    3    0.23103E-06    0.10000E+01    0.57264E+03    0.80666E-07    0.11824E-10    0.30739E-13
+    1    3    0.23103E-06    0.10000E+01    0.46180E+03    0.14868E-06    0.39226E-10    0.50648E-13
+    1    3    0.23103E-06    0.10000E+01    0.37242E+03    0.27203E-06    0.11862E-09    0.84027E-13
+    1    3    0.23103E-06    0.10000E+01    0.30034E+03    0.48736E-06    0.31660E-09    0.13897E-12
+    1    3    0.23103E-06    0.10000E+01    0.24221E+03    0.84065E-06    0.73705E-09    0.22552E-12
+    1    3    0.23103E-06    0.10000E+01    0.19533E+03    0.13077E-05    0.13983E-08    0.33698E-12
+    1    3    0.23103E-06    0.10000E+01    0.15752E+03    0.13077E-05    0.13983E-08    0.33698E-12
+    1    3    0.40314E-06    0.10000E+01    0.80645E+05    0.94192E-53    0.70404E-64    0.22053E-58
+    1    3    0.40314E-06    0.10000E+01    0.65036E+05    0.79623E-52    0.11173E-62    0.18670E-57
+    1    3    0.40314E-06    0.10000E+01    0.52449E+05    0.67609E-51    0.14972E-61    0.15873E-56
+    1    3    0.40314E-06    0.10000E+01    0.42297E+05    0.50752E-50    0.20234E-60    0.11944E-55
+    1    3    0.40314E-06    0.10000E+01    0.34111E+05    0.36444E-49    0.27536E-59    0.86119E-55
+    1    3    0.40314E-06    0.10000E+01    0.27509E+05    0.25974E-48    0.36788E-58    0.61789E-54
+    1    3    0.40314E-06    0.10000E+01    0.22184E+05    0.18280E-47    0.47814E-57    0.43955E-53
+    1    3    0.40314E-06    0.10000E+01    0.17891E+05    0.12578E-46    0.60264E-56    0.30763E-52
+    1    3    0.40314E-06    0.10000E+01    0.14428E+05    0.84186E-46    0.73885E-55    0.21108E-51
+    1    3    0.40314E-06    0.10000E+01    0.11635E+05    0.54816E-45    0.88337E-54    0.14196E-50
+    1    3    0.40314E-06    0.10000E+01    0.93834E+04    0.34785E-44    0.10318E-52    0.93394E-50
+    1    3    0.40314E-06    0.10000E+01    0.75673E+04    0.21580E-43    0.12081E-51    0.59557E-49
+    1    3    0.40314E-06    0.10000E+01    0.61026E+04    0.13359E-42    0.15630E-50    0.36308E-48
+    1    3    0.40314E-06    0.10000E+01    0.49215E+04    0.88810E-42    0.25757E-49    0.21164E-47
+    1    3    0.40314E-06    0.10000E+01    0.39689E+04    0.71766E-41    0.53492E-48    0.12695E-46
+    1    3    0.40314E-06    0.10000E+01    0.32008E+04    0.22991E-38    0.38542E-45    0.30350E-44
+    1    3    0.40314E-06    0.10000E+01    0.25813E+04    0.13458E-29    0.49799E-36    0.16530E-35
+    1    3    0.40314E-06    0.10000E+01    0.20817E+04    0.19587E-13    0.24616E-19    0.26057E-19
+    1    3    0.40314E-06    0.10000E+01    0.16788E+04    0.52107E-08    0.24355E-13    0.70404E-14
+    1    3    0.40314E-06    0.10000E+01    0.13538E+04    0.88681E-08    0.83540E-13    0.10540E-13
+    1    3    0.40314E-06    0.10000E+01    0.10918E+04    0.15451E-07    0.28740E-12    0.16202E-13
+    1    3    0.40314E-06    0.10000E+01    0.88049E+03    0.27307E-07    0.99484E-12    0.25303E-13
+    1    3    0.40314E-06    0.10000E+01    0.71007E+03    0.48708E-07    0.34620E-11    0.39905E-13
+    1    3    0.40314E-06    0.10000E+01    0.57264E+03    0.87480E-07    0.11935E-10    0.63461E-13
+    1    3    0.40314E-06    0.10000E+01    0.46180E+03    0.15777E-06    0.39337E-10    0.10183E-12
+    1    3    0.40314E-06    0.10000E+01    0.37242E+03    0.28367E-06    0.11848E-09    0.16459E-12
+    1    3    0.40314E-06    0.10000E+01    0.30034E+03    0.50152E-06    0.31546E-09    0.26584E-12
+    1    3    0.40314E-06    0.10000E+01    0.24221E+03    0.85688E-06    0.73334E-09    0.42291E-12
+    1    3    0.40314E-06    0.10000E+01    0.19533E+03    0.13250E-05    0.13901E-08    0.62317E-12
+    1    3    0.40314E-06    0.10000E+01    0.15752E+03    0.13250E-05    0.13901E-08    0.62317E-12
+    1    3    0.70346E-06    0.10000E+01    0.80645E+05    0.16313E-52    0.12196E-63    0.42383E-58
+    1    3    0.70346E-06    0.10000E+01    0.65036E+05    0.13792E-51    0.19358E-62    0.35884E-57
+    1    3    0.70346E-06    0.10000E+01    0.52449E+05    0.11713E-50    0.25948E-61    0.30512E-56
+    1    3    0.70346E-06    0.10000E+01    0.42297E+05    0.87949E-50    0.35085E-60    0.22961E-55
+    1    3    0.70346E-06    0.10000E+01    0.34111E+05    0.63184E-49    0.47787E-59    0.16561E-54
+    1    3    0.70346E-06    0.10000E+01    0.27509E+05    0.45065E-48    0.63934E-58    0.11887E-53
+    1    3    0.70346E-06    0.10000E+01    0.22184E+05    0.31755E-47    0.83285E-57    0.84623E-53
+    1    3    0.70346E-06    0.10000E+01    0.17891E+05    0.21893E-46    0.10533E-55    0.59289E-52
+    1    3    0.70346E-06    0.10000E+01    0.14428E+05    0.14696E-45    0.12970E-54    0.40746E-51
+    1    3    0.70346E-06    0.10000E+01    0.11635E+05    0.96056E-45    0.15578E-53    0.27465E-50
+    1    3    0.70346E-06    0.10000E+01    0.93834E+04    0.61210E-44    0.18240E-52    0.18121E-49
+    1    3    0.70346E-06    0.10000E+01    0.75673E+04    0.38077E-43    0.21231E-51    0.11599E-48
+    1    3    0.70346E-06    0.10000E+01    0.61026E+04    0.23488E-42    0.26808E-50    0.70997E-48
+    1    3    0.70346E-06    0.10000E+01    0.49215E+04    0.15335E-41    0.42658E-49    0.41410E-47
+    1    3    0.70346E-06    0.10000E+01    0.39689E+04    0.12014E-40    0.86978E-48    0.24524E-46
+    1    3    0.70346E-06    0.10000E+01    0.32008E+04    0.37653E-38    0.62576E-45    0.56977E-44
+    1    3    0.70346E-06    0.10000E+01    0.25813E+04    0.21943E-29    0.80963E-36    0.30592E-35
+    1    3    0.70346E-06    0.10000E+01    0.20817E+04    0.32067E-13    0.39578E-19    0.48672E-19
+    1    3    0.70346E-06    0.10000E+01    0.16788E+04    0.85263E-08    0.38399E-13    0.13215E-13
+    1    3    0.70346E-06    0.10000E+01    0.13538E+04    0.14362E-07    0.13082E-12    0.19658E-13
+    1    3    0.70346E-06    0.10000E+01    0.10918E+04    0.24792E-07    0.44735E-12    0.30045E-13
+    1    3    0.70346E-06    0.10000E+01    0.88049E+03    0.43451E-07    0.15408E-11    0.46661E-13
+    1    3    0.70346E-06    0.10000E+01    0.71007E+03    0.76924E-07    0.53409E-11    0.73175E-13
+    1    3    0.70346E-06    0.10000E+01    0.57264E+03    0.13724E-06    0.18361E-10    0.11568E-12
+    1    3    0.70346E-06    0.10000E+01    0.46180E+03    0.24608E-06    0.60401E-10    0.18446E-12
+    1    3    0.70346E-06    0.10000E+01    0.37242E+03    0.44036E-06    0.18171E-09    0.29627E-12
+    1    3    0.70346E-06    0.10000E+01    0.30034E+03    0.77573E-06    0.48348E-09    0.47569E-12
+    1    3    0.70346E-06    0.10000E+01    0.24221E+03    0.13218E-05    0.11235E-08    0.75291E-12
+    1    3    0.70346E-06    0.10000E+01    0.19533E+03    0.20405E-05    0.21291E-08    0.11054E-11
+    1    3    0.70346E-06    0.10000E+01    0.15752E+03    0.20405E-05    0.21291E-08    0.11054E-11
+    1    3    0.12275E-05    0.10000E+01    0.80645E+05    0.28466E-52    0.21281E-63    0.73956E-58
+    1    3    0.12275E-05    0.10000E+01    0.65036E+05    0.24067E-51    0.33778E-62    0.62615E-57
+    1    3    0.12275E-05    0.10000E+01    0.52449E+05    0.20438E-50    0.45277E-61    0.53241E-56
+    1    3    0.12275E-05    0.10000E+01    0.42297E+05    0.15347E-49    0.61221E-60    0.40066E-55
+    1    3    0.12275E-05    0.10000E+01    0.34111E+05    0.11025E-48    0.83386E-59    0.28898E-54
+    1    3    0.12275E-05    0.10000E+01    0.27509E+05    0.78636E-48    0.11156E-57    0.20743E-53
+    1    3    0.12275E-05    0.10000E+01    0.22184E+05    0.55411E-47    0.14533E-56    0.14766E-52
+    1    3    0.12275E-05    0.10000E+01    0.17891E+05    0.38202E-46    0.18379E-55    0.10346E-51
+    1    3    0.12275E-05    0.10000E+01    0.14428E+05    0.25644E-45    0.22632E-54    0.71099E-51
+    1    3    0.12275E-05    0.10000E+01    0.11635E+05    0.16761E-44    0.27183E-53    0.47925E-50
+    1    3    0.12275E-05    0.10000E+01    0.93834E+04    0.10681E-43    0.31828E-52    0.31621E-49
+    1    3    0.12275E-05    0.10000E+01    0.75673E+04    0.66442E-43    0.37047E-51    0.20240E-48
+    1    3    0.12275E-05    0.10000E+01    0.61026E+04    0.40985E-42    0.46778E-50    0.12389E-47
+    1    3    0.12275E-05    0.10000E+01    0.49215E+04    0.26759E-41    0.74436E-49    0.72257E-47
+    1    3    0.12275E-05    0.10000E+01    0.39689E+04    0.20963E-40    0.15177E-47    0.42794E-46
+    1    3    0.12275E-05    0.10000E+01    0.32008E+04    0.65702E-38    0.10919E-44    0.99421E-44
+    1    3    0.12275E-05    0.10000E+01    0.25813E+04    0.38289E-29    0.14128E-35    0.53382E-35
+    1    3    0.12275E-05    0.10000E+01    0.20817E+04    0.55955E-13    0.69062E-19    0.84930E-19
+    1    3    0.12275E-05    0.10000E+01    0.16788E+04    0.14878E-07    0.67004E-13    0.23059E-13
+    1    3    0.12275E-05    0.10000E+01    0.13538E+04    0.25061E-07    0.22827E-12    0.34302E-13
+    1    3    0.12275E-05    0.10000E+01    0.10918E+04    0.43261E-07    0.78059E-12    0.52427E-13
+    1    3    0.12275E-05    0.10000E+01    0.88049E+03    0.75820E-07    0.26886E-11    0.81420E-13
+    1    3    0.12275E-05    0.10000E+01    0.71007E+03    0.13423E-06    0.93195E-11    0.12769E-12
+    1    3    0.12275E-05    0.10000E+01    0.57264E+03    0.23947E-06    0.32039E-10    0.20186E-12
+    1    3    0.12275E-05    0.10000E+01    0.46180E+03    0.42939E-06    0.10540E-09    0.32187E-12
+    1    3    0.12275E-05    0.10000E+01    0.37242E+03    0.76841E-06    0.31707E-09    0.51697E-12
+    1    3    0.12275E-05    0.10000E+01    0.30034E+03    0.13536E-05    0.84365E-09    0.83005E-12
+    1    3    0.12275E-05    0.10000E+01    0.24221E+03    0.23065E-05    0.19604E-08    0.13138E-11
+    1    3    0.12275E-05    0.10000E+01    0.19533E+03    0.35605E-05    0.37152E-08    0.19288E-11
+    1    3    0.12275E-05    0.10000E+01    0.15752E+03    0.35605E-05    0.37152E-08    0.19288E-11
+    1    3    0.21419E-05    0.10000E+01    0.80645E+05    0.49671E-52    0.37134E-63    0.12905E-57
+    1    3    0.21419E-05    0.10000E+01    0.65036E+05    0.41995E-51    0.58941E-62    0.10926E-56
+    1    3    0.21419E-05    0.10000E+01    0.52449E+05    0.35664E-50    0.79006E-61    0.92902E-56
+    1    3    0.21419E-05    0.10000E+01    0.42297E+05    0.26779E-49    0.10683E-59    0.69913E-55
+    1    3    0.21419E-05    0.10000E+01    0.34111E+05    0.19238E-48    0.14550E-58    0.50425E-54
+    1    3    0.21419E-05    0.10000E+01    0.27509E+05    0.13722E-47    0.19467E-57    0.36195E-53
+    1    3    0.21419E-05    0.10000E+01    0.22184E+05    0.96688E-47    0.25359E-56    0.25766E-52
+    1    3    0.21419E-05    0.10000E+01    0.17891E+05    0.66661E-46    0.32070E-55    0.18052E-51
+    1    3    0.21419E-05    0.10000E+01    0.14428E+05    0.44746E-45    0.39491E-54    0.12406E-50
+    1    3    0.21419E-05    0.10000E+01    0.11635E+05    0.29247E-44    0.47433E-53    0.83626E-50
+    1    3    0.21419E-05    0.10000E+01    0.93834E+04    0.18637E-43    0.55539E-52    0.55176E-49
+    1    3    0.21419E-05    0.10000E+01    0.75673E+04    0.11594E-42    0.64644E-51    0.35318E-48
+    1    3    0.21419E-05    0.10000E+01    0.61026E+04    0.71516E-42    0.81625E-50    0.21617E-47
+    1    3    0.21419E-05    0.10000E+01    0.49215E+04    0.46693E-41    0.12989E-48    0.12608E-46
+    1    3    0.21419E-05    0.10000E+01    0.39689E+04    0.36579E-40    0.26483E-47    0.74672E-46
+    1    3    0.21419E-05    0.10000E+01    0.32008E+04    0.11465E-37    0.19053E-44    0.17348E-43
+    1    3    0.21419E-05    0.10000E+01    0.25813E+04    0.66812E-29    0.24652E-35    0.93148E-35
+    1    3    0.21419E-05    0.10000E+01    0.20817E+04    0.97638E-13    0.12051E-18    0.14820E-18
+    1    3    0.21419E-05    0.10000E+01    0.16788E+04    0.25961E-07    0.11692E-12    0.40237E-13
+    1    3    0.21419E-05    0.10000E+01    0.13538E+04    0.43730E-07    0.39832E-12    0.59856E-13
+    1    3    0.21419E-05    0.10000E+01    0.10918E+04    0.75488E-07    0.13621E-11    0.91481E-13
+    1    3    0.21419E-05    0.10000E+01    0.88049E+03    0.13230E-06    0.46914E-11    0.14207E-12
+    1    3    0.21419E-05    0.10000E+01    0.71007E+03    0.23422E-06    0.16262E-10    0.22280E-12
+    1    3    0.21419E-05    0.10000E+01    0.57264E+03    0.41786E-06    0.55906E-10    0.35223E-12
+    1    3    0.21419E-05    0.10000E+01    0.46180E+03    0.74926E-06    0.18391E-09    0.56165E-12
+    1    3    0.21419E-05    0.10000E+01    0.37242E+03    0.13408E-05    0.55327E-09    0.90209E-12
+    1    3    0.21419E-05    0.10000E+01    0.30034E+03    0.23619E-05    0.14721E-08    0.14484E-11
+    1    3    0.21419E-05    0.10000E+01    0.24221E+03    0.40248E-05    0.34207E-08    0.22925E-11
+    1    3    0.21419E-05    0.10000E+01    0.19533E+03    0.62129E-05    0.64827E-08    0.33656E-11
+    1    3    0.21419E-05    0.10000E+01    0.15752E+03    0.62129E-05    0.64827E-08    0.33656E-11
+    1    3    0.37375E-05    0.10000E+01    0.80645E+05    0.86672E-52    0.64797E-63    0.22518E-57
+    1    3    0.37375E-05    0.10000E+01    0.65036E+05    0.73278E-51    0.10285E-61    0.19065E-56
+    1    3    0.37375E-05    0.10000E+01    0.52449E+05    0.62231E-50    0.13786E-60    0.16211E-55
+    1    3    0.37375E-05    0.10000E+01    0.42297E+05    0.46727E-49    0.18641E-59    0.12199E-54
+    1    3    0.37375E-05    0.10000E+01    0.34111E+05    0.33570E-48    0.25390E-58    0.87988E-54
+    1    3    0.37375E-05    0.10000E+01    0.27509E+05    0.23943E-47    0.33968E-57    0.63157E-53
+    1    3    0.37375E-05    0.10000E+01    0.22184E+05    0.16871E-46    0.44250E-56    0.44960E-52
+    1    3    0.37375E-05    0.10000E+01    0.17891E+05    0.11632E-45    0.55961E-55    0.31500E-51
+    1    3    0.37375E-05    0.10000E+01    0.14428E+05    0.78080E-45    0.68910E-54    0.21648E-50
+    1    3    0.37375E-05    0.10000E+01    0.11635E+05    0.51035E-44    0.82767E-53    0.14592E-49
+    1    3    0.37375E-05    0.10000E+01    0.93834E+04    0.32521E-43    0.96912E-52    0.96279E-49
+    1    3    0.37375E-05    0.10000E+01    0.75673E+04    0.20230E-42    0.11280E-50    0.61628E-48
+    1    3    0.37375E-05    0.10000E+01    0.61026E+04    0.12479E-41    0.14243E-49    0.37721E-47
+    1    3    0.37375E-05    0.10000E+01    0.49215E+04    0.81477E-41    0.22664E-48    0.22001E-46
+    1    3    0.37375E-05    0.10000E+01    0.39689E+04    0.63829E-40    0.46211E-47    0.13030E-45
+    1    3    0.37375E-05    0.10000E+01    0.32008E+04    0.20005E-37    0.33247E-44    0.30272E-43
+    1    3    0.37375E-05    0.10000E+01    0.25813E+04    0.11658E-28    0.43016E-35    0.16254E-34
+    1    3    0.37375E-05    0.10000E+01    0.20817E+04    0.17037E-12    0.21028E-18    0.25860E-18
+    1    3    0.37375E-05    0.10000E+01    0.16788E+04    0.45300E-07    0.20401E-12    0.70211E-13
+    1    3    0.37375E-05    0.10000E+01    0.13538E+04    0.76305E-07    0.69504E-12    0.10444E-12
+    1    3    0.37375E-05    0.10000E+01    0.10918E+04    0.13172E-06    0.23768E-11    0.15963E-12
+    1    3    0.37375E-05    0.10000E+01    0.88049E+03    0.23086E-06    0.81862E-11    0.24791E-12
+    1    3    0.37375E-05    0.10000E+01    0.71007E+03    0.40870E-06    0.28376E-10    0.38878E-12
+    1    3    0.37375E-05    0.10000E+01    0.57264E+03    0.72913E-06    0.97553E-10    0.61462E-12
+    1    3    0.37375E-05    0.10000E+01    0.46180E+03    0.13074E-05    0.32091E-09    0.98004E-12
+    1    3    0.37375E-05    0.10000E+01    0.37242E+03    0.23397E-05    0.96542E-09    0.15741E-11
+    1    3    0.37375E-05    0.10000E+01    0.30034E+03    0.41215E-05    0.25688E-08    0.25274E-11
+    1    3    0.37375E-05    0.10000E+01    0.24221E+03    0.70230E-05    0.59690E-08    0.40002E-11
+    1    3    0.37375E-05    0.10000E+01    0.19533E+03    0.10841E-04    0.11312E-07    0.58729E-11
+    1    3    0.37375E-05    0.10000E+01    0.15752E+03    0.10841E-04    0.11312E-07    0.58729E-11
+    1    3    0.65217E-05    0.10000E+01    0.80645E+05    0.15124E-51    0.11307E-62    0.39293E-57
+    1    3    0.65217E-05    0.10000E+01    0.65036E+05    0.12787E-50    0.17946E-61    0.33268E-56
+    1    3    0.65217E-05    0.10000E+01    0.52449E+05    0.10859E-49    0.24056E-60    0.28287E-55
+    1    3    0.65217E-05    0.10000E+01    0.42297E+05    0.81536E-49    0.32527E-59    0.21287E-54
+    1    3    0.65217E-05    0.10000E+01    0.34111E+05    0.58577E-48    0.44303E-58    0.15353E-53
+    1    3    0.65217E-05    0.10000E+01    0.27509E+05    0.41780E-47    0.59272E-57    0.11021E-52
+    1    3    0.65217E-05    0.10000E+01    0.22184E+05    0.29440E-46    0.77213E-56    0.78453E-52
+    1    3    0.65217E-05    0.10000E+01    0.17891E+05    0.20297E-45    0.97649E-55    0.54966E-51
+    1    3    0.65217E-05    0.10000E+01    0.14428E+05    0.13624E-44    0.12024E-53    0.37775E-50
+    1    3    0.65217E-05    0.10000E+01    0.11635E+05    0.89053E-44    0.14442E-52    0.25463E-49
+    1    3    0.65217E-05    0.10000E+01    0.93834E+04    0.56747E-43    0.16911E-51    0.16800E-48
+    1    3    0.65217E-05    0.10000E+01    0.75673E+04    0.35301E-42    0.19683E-50    0.10754E-47
+    1    3    0.65217E-05    0.10000E+01    0.61026E+04    0.21775E-41    0.24853E-49    0.65821E-47
+    1    3    0.65217E-05    0.10000E+01    0.49215E+04    0.14217E-40    0.39548E-48    0.38390E-46
+    1    3    0.65217E-05    0.10000E+01    0.39689E+04    0.11138E-39    0.80636E-47    0.22736E-45
+    1    3    0.65217E-05    0.10000E+01    0.32008E+04    0.34908E-37    0.58014E-44    0.52822E-43
+    1    3    0.65217E-05    0.10000E+01    0.25813E+04    0.20343E-28    0.75060E-35    0.28362E-34
+    1    3    0.65217E-05    0.10000E+01    0.20817E+04    0.29729E-12    0.36693E-18    0.45123E-18
+    1    3    0.65217E-05    0.10000E+01    0.16788E+04    0.79046E-07    0.35599E-12    0.12251E-12
+    1    3    0.65217E-05    0.10000E+01    0.13538E+04    0.13315E-06    0.12128E-11    0.18225E-12
+    1    3    0.65217E-05    0.10000E+01    0.10918E+04    0.22985E-06    0.41473E-11    0.27854E-12
+    1    3    0.65217E-05    0.10000E+01    0.88049E+03    0.40283E-06    0.14284E-10    0.43258E-12
+    1    3    0.65217E-05    0.10000E+01    0.71007E+03    0.71316E-06    0.49515E-10    0.67840E-12
+    1    3    0.65217E-05    0.10000E+01    0.57264E+03    0.12723E-05    0.17022E-09    0.10725E-11
+    1    3    0.65217E-05    0.10000E+01    0.46180E+03    0.22813E-05    0.55997E-09    0.17101E-11
+    1    3    0.65217E-05    0.10000E+01    0.37242E+03    0.40826E-05    0.16846E-08    0.27467E-11
+    1    3    0.65217E-05    0.10000E+01    0.30034E+03    0.71917E-05    0.44823E-08    0.44101E-11
+    1    3    0.65217E-05    0.10000E+01    0.24221E+03    0.12255E-04    0.10416E-07    0.69802E-11
+    1    3    0.65217E-05    0.10000E+01    0.19533E+03    0.18917E-04    0.19739E-07    0.10248E-10
+    1    3    0.65217E-05    0.10000E+01    0.15752E+03    0.18917E-04    0.19739E-07    0.10248E-10
+    1    3    0.11380E-04    0.10000E+01    0.80645E+05    0.26390E-51    0.19729E-62    0.68564E-57
+    1    3    0.11380E-04    0.10000E+01    0.65036E+05    0.22312E-50    0.31315E-61    0.58050E-56
+    1    3    0.11380E-04    0.10000E+01    0.52449E+05    0.18948E-49    0.41976E-60    0.49359E-55
+    1    3    0.11380E-04    0.10000E+01    0.42297E+05    0.14228E-48    0.56757E-59    0.37145E-54
+    1    3    0.11380E-04    0.10000E+01    0.34111E+05    0.10221E-47    0.77306E-58    0.26791E-53
+    1    3    0.11380E-04    0.10000E+01    0.27509E+05    0.72903E-47    0.10343E-56    0.19230E-52
+    1    3    0.11380E-04    0.10000E+01    0.22184E+05    0.51370E-46    0.13473E-55    0.13690E-51
+    1    3    0.11380E-04    0.10000E+01    0.17891E+05    0.35417E-45    0.17039E-54    0.95912E-51
+    1    3    0.11380E-04    0.10000E+01    0.14428E+05    0.23774E-44    0.20982E-53    0.65915E-50
+    1    3    0.11380E-04    0.10000E+01    0.11635E+05    0.15539E-43    0.25201E-52    0.44431E-49
+    1    3    0.11380E-04    0.10000E+01    0.93834E+04    0.99020E-43    0.29508E-51    0.29315E-48
+    1    3    0.11380E-04    0.10000E+01    0.75673E+04    0.61598E-42    0.34346E-50    0.18764E-47
+    1    3    0.11380E-04    0.10000E+01    0.61026E+04    0.37996E-41    0.43367E-49    0.11485E-46
+    1    3    0.11380E-04    0.10000E+01    0.49215E+04    0.24808E-40    0.69009E-48    0.66989E-46
+    1    3    0.11380E-04    0.10000E+01    0.39689E+04    0.19435E-39    0.14071E-46    0.39674E-45
+    1    3    0.11380E-04    0.10000E+01    0.32008E+04    0.60912E-37    0.10123E-43    0.92172E-43
+    1    3    0.11380E-04    0.10000E+01    0.25813E+04    0.35497E-28    0.13097E-34    0.49490E-34
+    1    3    0.11380E-04    0.10000E+01    0.20817E+04    0.51875E-12    0.64026E-18    0.78737E-18
+    1    3    0.11380E-04    0.10000E+01    0.16788E+04    0.13793E-06    0.62119E-12    0.21378E-12
+    1    3    0.11380E-04    0.10000E+01    0.13538E+04    0.23234E-06    0.21163E-11    0.31801E-12
+    1    3    0.11380E-04    0.10000E+01    0.10918E+04    0.40107E-06    0.72368E-11    0.48604E-12
+    1    3    0.11380E-04    0.10000E+01    0.88049E+03    0.70292E-06    0.24925E-10    0.75483E-12
+    1    3    0.11380E-04    0.10000E+01    0.71007E+03    0.12444E-05    0.86400E-10    0.11838E-11
+    1    3    0.11380E-04    0.10000E+01    0.57264E+03    0.22201E-05    0.29703E-09    0.18714E-11
+    1    3    0.11380E-04    0.10000E+01    0.46180E+03    0.39808E-05    0.97712E-09    0.29840E-11
+    1    3    0.11380E-04    0.10000E+01    0.37242E+03    0.71238E-05    0.29395E-08    0.47928E-11
+    1    3    0.11380E-04    0.10000E+01    0.30034E+03    0.12549E-04    0.78214E-08    0.76953E-11
+    1    3    0.11380E-04    0.10000E+01    0.24221E+03    0.21384E-04    0.18174E-07    0.12180E-10
+    1    3    0.11380E-04    0.10000E+01    0.19533E+03    0.33009E-04    0.34443E-07    0.17882E-10
+    1    3    0.11380E-04    0.10000E+01    0.15752E+03    0.33009E-04    0.34443E-07    0.17882E-10
+    1    3    0.19857E-04    0.10000E+01    0.80645E+05    0.46049E-51    0.34427E-62    0.11964E-56
+    1    3    0.19857E-04    0.10000E+01    0.65036E+05    0.38933E-50    0.54643E-61    0.10129E-55
+    1    3    0.19857E-04    0.10000E+01    0.52449E+05    0.33063E-49    0.73245E-60    0.86128E-55
+    1    3    0.19857E-04    0.10000E+01    0.42297E+05    0.24826E-48    0.99038E-59    0.64816E-54
+    1    3    0.19857E-04    0.10000E+01    0.34111E+05    0.17836E-47    0.13489E-57    0.46748E-53
+    1    3    0.19857E-04    0.10000E+01    0.27509E+05    0.12721E-46    0.18047E-56    0.33556E-52
+    1    3    0.19857E-04    0.10000E+01    0.22184E+05    0.89638E-46    0.23510E-55    0.23887E-51
+    1    3    0.19857E-04    0.10000E+01    0.17891E+05    0.61800E-45    0.29732E-54    0.16736E-50
+    1    3    0.19857E-04    0.10000E+01    0.14428E+05    0.41484E-44    0.36612E-53    0.11502E-49
+    1    3    0.19857E-04    0.10000E+01    0.11635E+05    0.27115E-43    0.43974E-52    0.77529E-49
+    1    3    0.19857E-04    0.10000E+01    0.93834E+04    0.17278E-42    0.51489E-51    0.51153E-48
+    1    3    0.19857E-04    0.10000E+01    0.75673E+04    0.10748E-41    0.59931E-50    0.32743E-47
+    1    3    0.19857E-04    0.10000E+01    0.61026E+04    0.66302E-41    0.75673E-49    0.20041E-46
+    1    3    0.19857E-04    0.10000E+01    0.49215E+04    0.43289E-40    0.12042E-47    0.11689E-45
+    1    3    0.19857E-04    0.10000E+01    0.39689E+04    0.33912E-39    0.24552E-46    0.69228E-45
+    1    3    0.19857E-04    0.10000E+01    0.32008E+04    0.10629E-36    0.17664E-43    0.16083E-42
+    1    3    0.19857E-04    0.10000E+01    0.25813E+04    0.61941E-28    0.22854E-34    0.86357E-34
+    1    3    0.19857E-04    0.10000E+01    0.20817E+04    0.90519E-12    0.11172E-17    0.13739E-17
+    1    3    0.19857E-04    0.10000E+01    0.16788E+04    0.24068E-06    0.10839E-11    0.37303E-12
+    1    3    0.19857E-04    0.10000E+01    0.13538E+04    0.40541E-06    0.36928E-11    0.55492E-12
+    1    3    0.19857E-04    0.10000E+01    0.10918E+04    0.69984E-06    0.12628E-10    0.84811E-12
+    1    3    0.19857E-04    0.10000E+01    0.88049E+03    0.12265E-05    0.43493E-10    0.13171E-11
+    1    3    0.19857E-04    0.10000E+01    0.71007E+03    0.21714E-05    0.15076E-09    0.20656E-11
+    1    3    0.19857E-04    0.10000E+01    0.57264E+03    0.38739E-05    0.51830E-09    0.32655E-11
+    1    3    0.19857E-04    0.10000E+01    0.46180E+03    0.69463E-05    0.17050E-08    0.52069E-11
+    1    3    0.19857E-04    0.10000E+01    0.37242E+03    0.12431E-04    0.51293E-08    0.83631E-11
+    1    3    0.19857E-04    0.10000E+01    0.30034E+03    0.21897E-04    0.13648E-07    0.13428E-10
+    1    3    0.19857E-04    0.10000E+01    0.24221E+03    0.37313E-04    0.31713E-07    0.21253E-10
+    1    3    0.19857E-04    0.10000E+01    0.19533E+03    0.57599E-04    0.60101E-07    0.31203E-10
+    1    3    0.19857E-04    0.10000E+01    0.15752E+03    0.57599E-04    0.60101E-07    0.31203E-10
+    1    3    0.34650E-04    0.10000E+01    0.80645E+05    0.80353E-51    0.60072E-62    0.20876E-56
+    1    3    0.34650E-04    0.10000E+01    0.65036E+05    0.67935E-50    0.95349E-61    0.17675E-55
+    1    3    0.34650E-04    0.10000E+01    0.52449E+05    0.57694E-49    0.12781E-59    0.15029E-54
+    1    3    0.34650E-04    0.10000E+01    0.42297E+05    0.43320E-48    0.17282E-58    0.11310E-53
+    1    3    0.34650E-04    0.10000E+01    0.34111E+05    0.31122E-47    0.23538E-57    0.81573E-53
+    1    3    0.34650E-04    0.10000E+01    0.27509E+05    0.22198E-46    0.31491E-56    0.58553E-52
+    1    3    0.34650E-04    0.10000E+01    0.22184E+05    0.15641E-45    0.41023E-55    0.41682E-51
+    1    3    0.34650E-04    0.10000E+01    0.17891E+05    0.10784E-44    0.51881E-54    0.29203E-50
+    1    3    0.34650E-04    0.10000E+01    0.14428E+05    0.72387E-44    0.63886E-53    0.20070E-49
+    1    3    0.34650E-04    0.10000E+01    0.11635E+05    0.47314E-43    0.76732E-52    0.13528E-48
+    1    3    0.34650E-04    0.10000E+01    0.93834E+04    0.30150E-42    0.89846E-51    0.89259E-48
+    1    3    0.34650E-04    0.10000E+01    0.75673E+04    0.18755E-41    0.10458E-49    0.57134E-47
+    1    3    0.34650E-04    0.10000E+01    0.61026E+04    0.11569E-40    0.13205E-48    0.34971E-46
+    1    3    0.34650E-04    0.10000E+01    0.49215E+04    0.75536E-40    0.21012E-47    0.20397E-45
+    1    3    0.34650E-04    0.10000E+01    0.39689E+04    0.59175E-39    0.42842E-46    0.12080E-44
+    1    3    0.34650E-04    0.10000E+01    0.32008E+04    0.18546E-36    0.30823E-43    0.28065E-42
+    1    3    0.34650E-04    0.10000E+01    0.25813E+04    0.10808E-27    0.39879E-34    0.15069E-33
+    1    3    0.34650E-04    0.10000E+01    0.20817E+04    0.15795E-11    0.19495E-17    0.23974E-17
+    1    3    0.34650E-04    0.10000E+01    0.16788E+04    0.41997E-06    0.18914E-11    0.65092E-12
+    1    3    0.34650E-04    0.10000E+01    0.13538E+04    0.70742E-06    0.64436E-11    0.96829E-12
+    1    3    0.34650E-04    0.10000E+01    0.10918E+04    0.12212E-05    0.22035E-10    0.14799E-11
+    1    3    0.34650E-04    0.10000E+01    0.88049E+03    0.21403E-05    0.75893E-10    0.22983E-11
+    1    3    0.34650E-04    0.10000E+01    0.71007E+03    0.37890E-05    0.26307E-09    0.36043E-11
+    1    3    0.34650E-04    0.10000E+01    0.57264E+03    0.67597E-05    0.90440E-09    0.56980E-11
+    1    3    0.34650E-04    0.10000E+01    0.46180E+03    0.12121E-04    0.29752E-08    0.90858E-11
+    1    3    0.34650E-04    0.10000E+01    0.37242E+03    0.21691E-04    0.89503E-08    0.14593E-10
+    1    3    0.34650E-04    0.10000E+01    0.30034E+03    0.38210E-04    0.23815E-07    0.23431E-10
+    1    3    0.34650E-04    0.10000E+01    0.24221E+03    0.65109E-04    0.55338E-07    0.37086E-10
+    1    3    0.34650E-04    0.10000E+01    0.19533E+03    0.10051E-03    0.10487E-06    0.54447E-10
+    1    3    0.34650E-04    0.10000E+01    0.15752E+03    0.10051E-03    0.10487E-06    0.54447E-10
+    1    3    0.60462E-04    0.10000E+01    0.80645E+05    0.14021E-50    0.10482E-61    0.36428E-56
+    1    3    0.60462E-04    0.10000E+01    0.65036E+05    0.11854E-49    0.16638E-60    0.30842E-55
+    1    3    0.60462E-04    0.10000E+01    0.52449E+05    0.10067E-48    0.22302E-59    0.26225E-54
+    1    3    0.60462E-04    0.10000E+01    0.42297E+05    0.75591E-48    0.30155E-58    0.19735E-53
+    1    3    0.60462E-04    0.10000E+01    0.34111E+05    0.54306E-47    0.41073E-57    0.14234E-52
+    1    3    0.60462E-04    0.10000E+01    0.27509E+05    0.38733E-46    0.54951E-56    0.10217E-51
+    1    3    0.60462E-04    0.10000E+01    0.22184E+05    0.27293E-45    0.71583E-55    0.72733E-51
+    1    3    0.60462E-04    0.10000E+01    0.17891E+05    0.18817E-44    0.90529E-54    0.50958E-50
+    1    3    0.60462E-04    0.10000E+01    0.14428E+05    0.12631E-43    0.11148E-52    0.35021E-49
+    1    3    0.60462E-04    0.10000E+01    0.11635E+05    0.82560E-43    0.13389E-51    0.23606E-48
+    1    3    0.60462E-04    0.10000E+01    0.93834E+04    0.52610E-42    0.15678E-50    0.15575E-47
+    1    3    0.60462E-04    0.10000E+01    0.75673E+04    0.32727E-41    0.18248E-49    0.99696E-47
+    1    3    0.60462E-04    0.10000E+01    0.61026E+04    0.20188E-40    0.23041E-48    0.61022E-46
+    1    3    0.60462E-04    0.10000E+01    0.49215E+04    0.13181E-39    0.36664E-47    0.35591E-45
+    1    3    0.60462E-04    0.10000E+01    0.39689E+04    0.10326E-38    0.74757E-46    0.21079E-44
+    1    3    0.60462E-04    0.10000E+01    0.32008E+04    0.32362E-36    0.53784E-43    0.48971E-42
+    1    3    0.60462E-04    0.10000E+01    0.25813E+04    0.18860E-27    0.69587E-34    0.26294E-33
+    1    3    0.60462E-04    0.10000E+01    0.20817E+04    0.27561E-11    0.34017E-17    0.41833E-17
+    1    3    0.60462E-04    0.10000E+01    0.16788E+04    0.73283E-06    0.33004E-11    0.11358E-11
+    1    3    0.60462E-04    0.10000E+01    0.13538E+04    0.12344E-05    0.11244E-10    0.16896E-11
+    1    3    0.60462E-04    0.10000E+01    0.10918E+04    0.21309E-05    0.38449E-10    0.25823E-11
+    1    3    0.60462E-04    0.10000E+01    0.88049E+03    0.37346E-05    0.13243E-09    0.40104E-11
+    1    3    0.60462E-04    0.10000E+01    0.71007E+03    0.66116E-05    0.45905E-09    0.62893E-11
+    1    3    0.60462E-04    0.10000E+01    0.57264E+03    0.11795E-04    0.15781E-08    0.99427E-11
+    1    3    0.60462E-04    0.10000E+01    0.46180E+03    0.21150E-04    0.51915E-08    0.15854E-10
+    1    3    0.60462E-04    0.10000E+01    0.37242E+03    0.37849E-04    0.15618E-07    0.25464E-10
+    1    3    0.60462E-04    0.10000E+01    0.30034E+03    0.66673E-04    0.41555E-07    0.40886E-10
+    1    3    0.60462E-04    0.10000E+01    0.24221E+03    0.11361E-03    0.96561E-07    0.64712E-10
+    1    3    0.60462E-04    0.10000E+01    0.19533E+03    0.17538E-03    0.18300E-06    0.95006E-10
+    1    3    0.60462E-04    0.10000E+01    0.15752E+03    0.17538E-03    0.18300E-06    0.95006E-10
+    1    3    0.10550E-03    0.10000E+01    0.80645E+05    0.24466E-50    0.18291E-61    0.63565E-56
+    1    3    0.10550E-03    0.10000E+01    0.65036E+05    0.20685E-49    0.29032E-60    0.53817E-55
+    1    3    0.10550E-03    0.10000E+01    0.52449E+05    0.17567E-48    0.38915E-59    0.45760E-54
+    1    3    0.10550E-03    0.10000E+01    0.42297E+05    0.13190E-47    0.52619E-58    0.34437E-53
+    1    3    0.10550E-03    0.10000E+01    0.34111E+05    0.94761E-47    0.71670E-57    0.24837E-52
+    1    3    0.10550E-03    0.10000E+01    0.27509E+05    0.67588E-46    0.95885E-56    0.17828E-51
+    1    3    0.10550E-03    0.10000E+01    0.22184E+05    0.47625E-45    0.12491E-54    0.12691E-50
+    1    3    0.10550E-03    0.10000E+01    0.17891E+05    0.32835E-44    0.15797E-53    0.88919E-50
+    1    3    0.10550E-03    0.10000E+01    0.14428E+05    0.22040E-43    0.19452E-52    0.61109E-49
+    1    3    0.10550E-03    0.10000E+01    0.11635E+05    0.14406E-42    0.23364E-51    0.41191E-48
+    1    3    0.10550E-03    0.10000E+01    0.93834E+04    0.91800E-42    0.27356E-50    0.27178E-47
+    1    3    0.10550E-03    0.10000E+01    0.75673E+04    0.57106E-41    0.31842E-49    0.17396E-46
+    1    3    0.10550E-03    0.10000E+01    0.61026E+04    0.35226E-40    0.40205E-48    0.10648E-45
+    1    3    0.10550E-03    0.10000E+01    0.49215E+04    0.22999E-39    0.63977E-47    0.62105E-45
+    1    3    0.10550E-03    0.10000E+01    0.39689E+04    0.18018E-38    0.13045E-45    0.36781E-44
+    1    3    0.10550E-03    0.10000E+01    0.32008E+04    0.56470E-36    0.93850E-43    0.85452E-42
+    1    3    0.10550E-03    0.10000E+01    0.25813E+04    0.32909E-27    0.12143E-33    0.45881E-33
+    1    3    0.10550E-03    0.10000E+01    0.20817E+04    0.48093E-11    0.59358E-17    0.72997E-17
+    1    3    0.10550E-03    0.10000E+01    0.16788E+04    0.12787E-05    0.57590E-11    0.19819E-11
+    1    3    0.10550E-03    0.10000E+01    0.13538E+04    0.21540E-05    0.19620E-10    0.29483E-11
+    1    3    0.10550E-03    0.10000E+01    0.10918E+04    0.37183E-05    0.67091E-10    0.45060E-11
+    1    3    0.10550E-03    0.10000E+01    0.88049E+03    0.65167E-05    0.23108E-09    0.69980E-11
+    1    3    0.10550E-03    0.10000E+01    0.71007E+03    0.11537E-04    0.80101E-09    0.10975E-10
+    1    3    0.10550E-03    0.10000E+01    0.57264E+03    0.20582E-04    0.27537E-08    0.17349E-10
+    1    3    0.10550E-03    0.10000E+01    0.46180E+03    0.36906E-04    0.90588E-08    0.27665E-10
+    1    3    0.10550E-03    0.10000E+01    0.37242E+03    0.66044E-04    0.27252E-07    0.44433E-10
+    1    3    0.10550E-03    0.10000E+01    0.30034E+03    0.11634E-03    0.72511E-07    0.71343E-10
+    1    3    0.10550E-03    0.10000E+01    0.24221E+03    0.19825E-03    0.16849E-06    0.11292E-09
+    1    3    0.10550E-03    0.10000E+01    0.19533E+03    0.30602E-03    0.31932E-06    0.16578E-09
+    1    3    0.10550E-03    0.10000E+01    0.15752E+03    0.30602E-03    0.31932E-06    0.16578E-09
+    1    3    0.18409E-03    0.10000E+01    0.80645E+05    0.42692E-50    0.31917E-61    0.11092E-55
+    1    3    0.18409E-03    0.10000E+01    0.65036E+05    0.36094E-49    0.50659E-60    0.93908E-55
+    1    3    0.18409E-03    0.10000E+01    0.52449E+05    0.30653E-48    0.67905E-59    0.79849E-54
+    1    3    0.18409E-03    0.10000E+01    0.42297E+05    0.23016E-47    0.91817E-58    0.60090E-53
+    1    3    0.18409E-03    0.10000E+01    0.34111E+05    0.16535E-46    0.12506E-56    0.43340E-52
+    1    3    0.18409E-03    0.10000E+01    0.27509E+05    0.11794E-45    0.16731E-55    0.31109E-51
+    1    3    0.18409E-03    0.10000E+01    0.22184E+05    0.83103E-45    0.21796E-54    0.22146E-50
+    1    3    0.18409E-03    0.10000E+01    0.17891E+05    0.57294E-44    0.27564E-53    0.15516E-49
+    1    3    0.18409E-03    0.10000E+01    0.14428E+05    0.38459E-43    0.33943E-52    0.10663E-48
+    1    3    0.18409E-03    0.10000E+01    0.11635E+05    0.25138E-42    0.40768E-51    0.71876E-48
+    1    3    0.18409E-03    0.10000E+01    0.93834E+04    0.16019E-41    0.47735E-50    0.47424E-47
+    1    3    0.18409E-03    0.10000E+01    0.75673E+04    0.99647E-41    0.55562E-49    0.30356E-46
+    1    3    0.18409E-03    0.10000E+01    0.61026E+04    0.61467E-40    0.70156E-48    0.18580E-45
+    1    3    0.18409E-03    0.10000E+01    0.49215E+04    0.40133E-39    0.11164E-46    0.10837E-44
+    1    3    0.18409E-03    0.10000E+01    0.39689E+04    0.31440E-38    0.22762E-45    0.64180E-44
+    1    3    0.18409E-03    0.10000E+01    0.32008E+04    0.98537E-36    0.16376E-42    0.14911E-41
+    1    3    0.18409E-03    0.10000E+01    0.25813E+04    0.57425E-27    0.21188E-33    0.80060E-33
+    1    3    0.18409E-03    0.10000E+01    0.20817E+04    0.83919E-11    0.10358E-16    0.12737E-16
+    1    3    0.18409E-03    0.10000E+01    0.16788E+04    0.22313E-05    0.10049E-10    0.34583E-11
+    1    3    0.18409E-03    0.10000E+01    0.13538E+04    0.37585E-05    0.34235E-10    0.51446E-11
+    1    3    0.18409E-03    0.10000E+01    0.10918E+04    0.64881E-05    0.11707E-09    0.78628E-11
+    1    3    0.18409E-03    0.10000E+01    0.88049E+03    0.11371E-04    0.40322E-09    0.12211E-10
+    1    3    0.18409E-03    0.10000E+01    0.71007E+03    0.20131E-04    0.13977E-08    0.19150E-10
+    1    3    0.18409E-03    0.10000E+01    0.57264E+03    0.35914E-04    0.48051E-08    0.30274E-10
+    1    3    0.18409E-03    0.10000E+01    0.46180E+03    0.64398E-04    0.15807E-07    0.48273E-10
+    1    3    0.18409E-03    0.10000E+01    0.37242E+03    0.11524E-03    0.47553E-07    0.77534E-10
+    1    3    0.18409E-03    0.10000E+01    0.30034E+03    0.20301E-03    0.12653E-06    0.12449E-09
+    1    3    0.18409E-03    0.10000E+01    0.24221E+03    0.34593E-03    0.29401E-06    0.19704E-09
+    1    3    0.18409E-03    0.10000E+01    0.19533E+03    0.53399E-03    0.55719E-06    0.28928E-09
+    1    3    0.18409E-03    0.10000E+01    0.15752E+03    0.53399E-03    0.55719E-06    0.28928E-09
+    1    3    0.32123E-03    0.10000E+01    0.80645E+05    0.74494E-50    0.55692E-61    0.19354E-55
+    1    3    0.32123E-03    0.10000E+01    0.65036E+05    0.62982E-49    0.88397E-60    0.16386E-54
+    1    3    0.32123E-03    0.10000E+01    0.52449E+05    0.53487E-48    0.11849E-58    0.13933E-53
+    1    3    0.32123E-03    0.10000E+01    0.42297E+05    0.40162E-47    0.16022E-57    0.10485E-52
+    1    3    0.32123E-03    0.10000E+01    0.34111E+05    0.28853E-46    0.21822E-56    0.75625E-52
+    1    3    0.32123E-03    0.10000E+01    0.27509E+05    0.20579E-45    0.29195E-55    0.54283E-51
+    1    3    0.32123E-03    0.10000E+01    0.22184E+05    0.14501E-44    0.38032E-54    0.38643E-50
+    1    3    0.32123E-03    0.10000E+01    0.17891E+05    0.99975E-44    0.48098E-53    0.27074E-49
+    1    3    0.32123E-03    0.10000E+01    0.14428E+05    0.67109E-43    0.59228E-52    0.18607E-48
+    1    3    0.32123E-03    0.10000E+01    0.11635E+05    0.43864E-42    0.71138E-51    0.12542E-47
+    1    3    0.32123E-03    0.10000E+01    0.93834E+04    0.27952E-41    0.83295E-50    0.82751E-47
+    1    3    0.32123E-03    0.10000E+01    0.75673E+04    0.17388E-40    0.96952E-49    0.52969E-46
+    1    3    0.32123E-03    0.10000E+01    0.61026E+04    0.10726E-39    0.12242E-47    0.32421E-45
+    1    3    0.32123E-03    0.10000E+01    0.49215E+04    0.70029E-39    0.19480E-46    0.18910E-44
+    1    3    0.32123E-03    0.10000E+01    0.39689E+04    0.54861E-38    0.39718E-45    0.11199E-43
+    1    3    0.32123E-03    0.10000E+01    0.32008E+04    0.17194E-35    0.28575E-42    0.26018E-41
+    1    3    0.32123E-03    0.10000E+01    0.25813E+04    0.10020E-26    0.36972E-33    0.13970E-32
+    1    3    0.32123E-03    0.10000E+01    0.20817E+04    0.14643E-10    0.18073E-16    0.22226E-16
+    1    3    0.32123E-03    0.10000E+01    0.16788E+04    0.38935E-05    0.17535E-10    0.60346E-11
+    1    3    0.32123E-03    0.10000E+01    0.13538E+04    0.65584E-05    0.59738E-10    0.89769E-11
+    1    3    0.32123E-03    0.10000E+01    0.10918E+04    0.11321E-04    0.20428E-09    0.13720E-10
+    1    3    0.32123E-03    0.10000E+01    0.88049E+03    0.19842E-04    0.70360E-09    0.21308E-10
+    1    3    0.32123E-03    0.10000E+01    0.71007E+03    0.35128E-04    0.24389E-08    0.33415E-10
+    1    3    0.32123E-03    0.10000E+01    0.57264E+03    0.62669E-04    0.83846E-08    0.52826E-10
+    1    3    0.32123E-03    0.10000E+01    0.46180E+03    0.11237E-03    0.27582E-07    0.84234E-10
+    1    3    0.32123E-03    0.10000E+01    0.37242E+03    0.20109E-03    0.82978E-07    0.13529E-09
+    1    3    0.32123E-03    0.10000E+01    0.30034E+03    0.35424E-03    0.22078E-06    0.21723E-09
+    1    3    0.32123E-03    0.10000E+01    0.24221E+03    0.60362E-03    0.51303E-06    0.34382E-09
+    1    3    0.32123E-03    0.10000E+01    0.19533E+03    0.93179E-03    0.97226E-06    0.50477E-09
+    1    3    0.32123E-03    0.10000E+01    0.15752E+03    0.93179E-03    0.97226E-06    0.50477E-09
+    1    4    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.14833E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    4    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.25883E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    4    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.45165E-08    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    1    4    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.78810E-08    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    1    4    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.13752E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    1    4    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.23996E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    1    4    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.41872E-07    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    1    4    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.73064E-07    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    1    4    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.12749E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    1    4    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.22247E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    1    4    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.38819E-06    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    1    4    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.67737E-06    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    1    4    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.11820E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    1    4    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.20625E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    1    4    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.35989E-05    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    1    4    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.62798E-05    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    1    4    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.10958E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    1    4    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.19121E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    1    4    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.33365E-04    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    1    4    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.58220E-04    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    1    4    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53957E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.10159E-03    0.19496E+06    0.99447E-26    0.48760E-10    0.50499E-04    0.88379E+03
+    1    4    0.54572E-10    0.10000E+01    0.74090E-01    0.13935E+00    0.11222E-09    0.65380E-11    0.40383E-04    0.29228E-04    0.98516E+04    0.17727E-03    0.15940E+06    0.27009E-25    0.58026E-09    0.60483E-04    0.85041E+03
+    1    4    0.95225E-10    0.10000E+01    0.11736E+00    0.19749E+00    0.21140E-09    0.50996E-10    0.44004E-04    0.38038E-04    0.17190E+05    0.30932E-03    0.12765E+06    0.72480E-25    0.43989E-08    0.73406E-04    0.78192E+03
+    1    4    0.16616E-09    0.10000E+01    0.18179E+00    0.26431E+00    0.32753E-09    0.26583E-09    0.44528E-04    0.48903E-04    0.29996E+05    0.53975E-03    0.99467E+05    0.19955E-24    0.21856E-07    0.91697E-04    0.67141E+03
+    1    4    0.28994E-09    0.10000E+01    0.25961E+00    0.33496E+00    0.47703E-09    0.94192E-09    0.43515E-04    0.57767E-04    0.52341E+05    0.94183E-03    0.75619E+05    0.57623E-24    0.71447E-07    0.11865E-03    0.53386E+03
+    1    4    0.50593E-09    0.10000E+01    0.33900E+00    0.40891E+00    0.78184E-09    0.24625E-08    0.45608E-04    0.61912E-04    0.91333E+05    0.16434E-02    0.56747E+05    0.17224E-23    0.16529E-06    0.15713E-03    0.40140E+03
+    1    4    0.88282E-09    0.10000E+01    0.41762E+00    0.48781E+00    0.14159E-08    0.54449E-08    0.54182E-04    0.63271E-04    0.15937E+06    0.28677E-02    0.42418E+05    0.52150E-23    0.31202E-06    0.20988E-03    0.29419E+03
+    1    4    0.15405E-08    0.10000E+01    0.47643E+00    0.59399E+00    0.34861E-08    0.11623E-07    0.68996E-04    0.63774E-04    0.22420E+06    0.40328E-02    0.19786E+05    0.19797E-22    0.52964E-06    0.30956E-03    0.20541E+03
+    1    4    0.26880E-08    0.10000E+01    0.39978E+00    0.72423E+00    0.14861E-07    0.29429E-07    0.82057E-04    0.52468E-04    0.11884E+06    0.21379E-02    0.45228E+04    0.28205E-21    0.85282E-06    0.70262E-03    0.11705E+03
+    1    4    0.46905E-08    0.10000E+01    0.45326E+00    0.77281E+00    0.27319E-07    0.58410E-07    0.10932E-03    0.48740E-04    0.20736E+06    0.37305E-02    0.35427E+04    0.11266E-20    0.14174E-05    0.95520E-03    0.90258E+02
+    1    4    0.81846E-08    0.10000E+01    0.50050E+00    0.84411E+00    0.49974E-07    0.11123E-06    0.14635E-03    0.47849E-04    0.36184E+06    0.65094E-02    0.28296E+04    0.42176E-20    0.22753E-05    0.12651E-02    0.73178E+02
+    1    4    0.14282E-07    0.10000E+01    0.54323E+00    0.94580E+00    0.91346E-07    0.20353E-06    0.19462E-03    0.49717E-04    0.63138E+06    0.11359E-01    0.22956E+04    0.14674E-19    0.35376E-05    0.16258E-02    0.62967E+02
+    1    4    0.24920E-07    0.10000E+01    0.58431E+00    0.10768E+01    0.16671E-06    0.36104E-06    0.25570E-03    0.54017E-04    0.11017E+07    0.19820E-01    0.18818E+04    0.48348E-19    0.53621E-05    0.20393E-02    0.57098E+02
+    1    4    0.43485E-07    0.10000E+01    0.62695E+00    0.12345E+01    0.30157E-06    0.62605E-06    0.33084E-03    0.60665E-04    0.19224E+07    0.34585E-01    0.15506E+04    0.15437E-18    0.79646E-05    0.25188E-02    0.53800E+02
+    1    4    0.75878E-07    0.10000E+01    0.67406E+00    0.14164E+01    0.53797E-06    0.10677E-05    0.42165E-03    0.69773E-04    0.33546E+07    0.60348E-01    0.12810E+04    0.48417E-18    0.11647E-04    0.30811E-02    0.51993E+02
+    1    4    0.13240E-06    0.10000E+01    0.72793E+00    0.16197E+01    0.94730E-06    0.17989E-05    0.53146E-03    0.81505E-04    0.58535E+07    0.10530E+00    0.10611E+04    0.14976E-17    0.16852E-04    0.37424E-02    0.51032E+02
+    1    4    0.23103E-06    0.10000E+01    0.79057E+00    0.18425E+01    0.16491E-05    0.30046E-05    0.66484E-03    0.96110E-04    0.10214E+08    0.18375E+00    0.88117E+03    0.45752E-17    0.24221E-04    0.45213E-02    0.50531E+02
+    1    4    0.40314E-06    0.10000E+01    0.86529E+00    0.20890E+01    0.28097E-05    0.49800E-05    0.82188E-03    0.11432E-03    0.17823E+08    0.32063E+00    0.73083E+03    0.13906E-16    0.34520E-04    0.54574E-02    0.50268E+02
+    1    4    0.70346E-06    0.10000E+01    0.95288E+00    0.23539E+01    0.47279E-05    0.82016E-05    0.10109E-02    0.13634E-03    0.31100E+08    0.55948E+00    0.60692E+03    0.41014E-16    0.48995E-04    0.65518E-02    0.50135E+02
+    1    4    0.12275E-05    0.10000E+01    0.10553E+01    0.26305E+01    0.78142E-05    0.13392E-04    0.12360E-02    0.16242E-03    0.54267E+08    0.97626E+00    0.50402E+03    0.11423E-15    0.69164E-04    0.77875E-02    0.50067E+02
+    1    4    0.21419E-05    0.10000E+01    0.10601E+01    0.26424E+01    0.23163E-04    0.23295E-04    0.21236E-02    0.16363E-03    0.94693E+08    0.17035E+01    0.50000E+03    0.20301E-15    0.11957E-03    0.78429E-02    0.50065E+02
+    1    4    0.37375E-05    0.10000E+01    0.10601E+01    0.26424E+01    0.70526E-04    0.40649E-04    0.37056E-02    0.16363E-03    0.16523E+09    0.29725E+01    0.50000E+03    0.35423E-15    0.20864E-03    0.78429E-02    0.50065E+02
+    1    4    0.65217E-05    0.10000E+01    0.10601E+01    0.26424E+01    0.21474E-03    0.70930E-04    0.64660E-02    0.16363E-03    0.28832E+09    0.51869E+01    0.50000E+03    0.61812E-15    0.36407E-03    0.78429E-02    0.50065E+02
+    1    4    0.11380E-04    0.10000E+01    0.10601E+01    0.26424E+01    0.65384E-03    0.12377E-03    0.11283E-01    0.16363E-03    0.50310E+09    0.90508E+01    0.50000E+03    0.10786E-14    0.63528E-03    0.78429E-02    0.50065E+02
+    1    4    0.19857E-04    0.10000E+01    0.10601E+01    0.26424E+01    0.19908E-02    0.21597E-03    0.19688E-01    0.16363E-03    0.87789E+09    0.15793E+02    0.50000E+03    0.18820E-14    0.11085E-02    0.78429E-02    0.50065E+02
+    1    4    0.34650E-04    0.10000E+01    0.10601E+01    0.26424E+01    0.60617E-02    0.37685E-03    0.34354E-01    0.16363E-03    0.15319E+10    0.27558E+02    0.50000E+03    0.32841E-14    0.19343E-02    0.78429E-02    0.50065E+02
+    1    4    0.60462E-04    0.10000E+01    0.10601E+01    0.26424E+01    0.18457E-01    0.65759E-03    0.59946E-01    0.16363E-03    0.26730E+10    0.48087E+02    0.50000E+03    0.57305E-14    0.33753E-02    0.78429E-02    0.50065E+02
+    1    4    0.10550E-03    0.10000E+01    0.10601E+01    0.26424E+01    0.56197E-01    0.11474E-02    0.10460E+00    0.16363E-03    0.46642E+10    0.83909E+02    0.50000E+03    0.99993E-14    0.58896E-02    0.78429E-02    0.50065E+02
+    1    4    0.18409E-03    0.10000E+01    0.10601E+01    0.26424E+01    0.17111E+00    0.20022E-02    0.18252E+00    0.16363E-03    0.81388E+10    0.14642E+03    0.50000E+03    0.17448E-13    0.10277E-01    0.78429E-02    0.50065E+02
+    1    4    0.32123E-03    0.10000E+01    0.10601E+01    0.26424E+01    0.52100E+00    0.34938E-02    0.31849E+00    0.16363E-03    0.14202E+11    0.25549E+03    0.50000E+03    0.30446E-13    0.17933E-01    0.78429E-02    0.50065E+02
+    1    4    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    1    4    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    1    4    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    1    4    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    1    4    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    1    4    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    1    4    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    1    4    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    1    4    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    1    4    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    1    4    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    1    4    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    1    4    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    1    4    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    1    4    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    1    4    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    1    4    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    1    4    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    1    4    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    1    4    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    1    4    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    1    4    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    1    4    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    1    4    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    1    4    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    1    4    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    1    4    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    1    4    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    1    4    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    1    4    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    1    4    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    1    4    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    1    4    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    1    4    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    1    4    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    1    4    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    1    4    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    1    4    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    1    4    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    1    4    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    1    4    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    1    4    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    1    4    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    1    4    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    1    4    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    1    4    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    1    4    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    1    4    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    1    4    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    1    4    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    1    4    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    1    4    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    1    4    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    1    4    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    1    4    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    1    4    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    1    4    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    1    4    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    1    4    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    1    4    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    1    4    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    1    4    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    1    4    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    1    4    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    1    4    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    1    4    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    1    4    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    1    4    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    1    4    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    1    4    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    1    4    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    1    4    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    1    4    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    1    4    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    1    4    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    1    4    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    1    4    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    1    4    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    1    4    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    1    4    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    1    4    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    1    4    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    1    4    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    1    4    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    1    4    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    1    4    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    1    4    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    1    4    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    1    4    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    1    4    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    1    4    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    1    4    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    1    4    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    1    4    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    1    4    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    1    4    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    1    4    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    1    4    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    1    4    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    1    4    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    1    4    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    1    4    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    1    4    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    1    4    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    1    4    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    1    4    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    1    4    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    1    4    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    1    4    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    1    4    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    1    4    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    1    4    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    1    4    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    1    4    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    1    4    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    1    4    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    1    4    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    1    4    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    1    4    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    1    4    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    1    4    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    1    4    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    1    4    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    1    4    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    1    4    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    1    4    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    1    4    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    1    4    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    1    4    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    1    4    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    1    4    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    1    4    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    1    4    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    1    4    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    1    4    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    1    4    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    1    4    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    1    4    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    1    4    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    1    4    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    1    4    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    1    4    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    1    4    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    1    4    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    1    4    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    1    4    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    1    4    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    1    4    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    1    4    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    1    4    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    1    4    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    1    4    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    1    4    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    1    4    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    1    4    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    1    4    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    1    4    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    1    4    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    1    4    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    1    4    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    1    4    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    1    4    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    1    4    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    1    4    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    1    4    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    1    4    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    1    4    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    1    4    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    1    4    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    1    4    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    1    4    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    1    4    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    1    4    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    1    4    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    1    4    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    1    4    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    1    4    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    1    4    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    1    4    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    1    4    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    1    4    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    1    4    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    1    4    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    1    4    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    1    4    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    1    4    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    1    4    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    1    4    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    1    4    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    1    4    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    1    4    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    1    4    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    1    4    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    1    4    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    1    4    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    1    4    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    1    4    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    1    4    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    1    4    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    1    4    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    1    4    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    1    4    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    1    4    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    1    4    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    1    4    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    1    4    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    1    4    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    1    4    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    1    4    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    1    4    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    1    4    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    1    4    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    1    4    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    1    4    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    1    4    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    1    4    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    1    4    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    1    4    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    1    4    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    1    4    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    1    4    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    1    4    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    1    4    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    1    4    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    1    4    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    1    4    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    1    4    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    1    4    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    1    4    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    1    4    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    1    4    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    1    4    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    1    4    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    1    4    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    1    4    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    1    4    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    1    4    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    1    4    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    1    4    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    1    4    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    1    4    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    1    4    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    1    4    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    1    4    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    1    4    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    1    4    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    1    4    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    1    4    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    1    4    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    1    4    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    1    4    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    1    4    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    1    4    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    1    4    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    1    4    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    1    4    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    1    4    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    1    4    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    1    4    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    1    4    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    1    4    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    1    4    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    1    4    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    1    4    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    1    4    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    1    4    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    1    4    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    1    4    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    1    4    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    1    4    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    1    4    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    1    4    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    1    4    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    1    4    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    1    4    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    1    4    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    1    4    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    1    4    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    1    4    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    1    4    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    1    4    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    1    4    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    1    4    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    1    4    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    1    4    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    1    4    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    1    4    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    1    4    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    1    4    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    1    4    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    1    4    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    1    4    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    1    4    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    1    4    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    1    4    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    1    4    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    1    4    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    1    4    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    1    4    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    1    4    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    1    4    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    1    4    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    1    4    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    1    4    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    1    4    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    1    4    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    1    4    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    1    4    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    1    4    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    1    4    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    1    4    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    1    4    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    1    4    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    1    4    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    1    4    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    1    4    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    1    4    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    1    4    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    1    4    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    1    4    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    1    4    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    1    4    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    1    4    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    1    4    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    1    4    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    1    4    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    1    4    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    1    4    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    1    4    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    1    4    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    1    4    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    1    4    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    1    4    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    1    4    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    1    4    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    1    4    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    1    4    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    1    4    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    1    4    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    1    4    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    1    4    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    1    4    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    1    4    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    1    4    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    1    4    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    1    4    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    1    4    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    1    4    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    1    4    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    1    4    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    1    4    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    1    4    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    1    4    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    1    4    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    1    4    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    1    4    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    1    4    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    1    4    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    1    4    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    1    4    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    1    4    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    1    4    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    1    4    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    1    4    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    1    4    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    1    4    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    1    4    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    1    4    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    1    4    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    1    4    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    1    4    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    1    4    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    1    4    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    1    4    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    1    4    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    1    4    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    1    4    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    1    4    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    1    4    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    1    4    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    1    4    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    1    4    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    1    4    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    1    4    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    1    4    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    1    4    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    1    4    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    1    4    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    1    4    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    1    4    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    1    4    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    1    4    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    1    4    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    1    4    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    1    4    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    1    4    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    1    4    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    1    4    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    1    4    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    1    4    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    1    4    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    1    4    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    1    4    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    1    4    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    1    4    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    1    4    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    1    4    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    1    4    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    1    4    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    1    4    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    1    4    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    1    4    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    1    4    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    1    4    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    1    4    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    1    4    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    1    4    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    1    4    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    1    4    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    1    4    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    1    4    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    1    4    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    1    4    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    1    4    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    1    4    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    1    4    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    1    4    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    1    4    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    1    4    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    1    4    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    1    4    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    1    4    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    1    4    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    1    4    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    1    4    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    1    4    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    1    4    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    1    4    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    1    4    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    1    4    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    1    4    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    1    4    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    1    4    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    1    4    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    1    4    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    1    4    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    1    4    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    1    4    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    1    4    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    1    4    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    1    4    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    1    4    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    1    4    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    1    4    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    1    4    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    1    4    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    1    4    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    1    4    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    1    4    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    1    4    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    1    4    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    1    4    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    1    4    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    1    4    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    1    4    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    1    4    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    1    4    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    1    4    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    1    4    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    1    4    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    1    4    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    1    4    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    1    4    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    1    4    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    1    4    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    1    4    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    1    4    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    1    4    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    1    4    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    1    4    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    1    4    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    1    4    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    1    4    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    1    4    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    1    4    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    1    4    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    1    4    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    1    4    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    1    4    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    1    4    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    1    4    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    1    4    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    1    4    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    1    4    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    1    4    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    1    4    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    1    4    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    1    4    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    1    4    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    1    4    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    1    4    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    1    4    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    1    4    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    1    4    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    1    4    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    1    4    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    1    4    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    1    4    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    1    4    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    1    4    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    1    4    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    1    4    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    1    4    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    1    4    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    1    4    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    1    4    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    1    4    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    1    4    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    1    4    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    1    4    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    1    4    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    1    4    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    1    4    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    1    4    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    1    4    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    1    4    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    1    4    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    1    4    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    1    4    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    1    4    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    1    4    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    1    4    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    1    4    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    1    4    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    1    4    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    1    4    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    1    4    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    1    4    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    1    4    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    1    4    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    1    4    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    1    4    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    1    4    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    1    4    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    1    4    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    1    4    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    1    4    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    1    4    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    1    4    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    1    4    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    1    4    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    1    4    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    1    4    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    1    4    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    1    4    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    1    4    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    1    4    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    1    4    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    1    4    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    1    4    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    1    4    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    1    4    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    1    4    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    1    4    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    1    4    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    1    4    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    1    4    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    1    4    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    1    4    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    1    4    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    1    4    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    1    4    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    1    4    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    1    4    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    1    4    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    1    4    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    1    4    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    1    4    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    1    4    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    1    4    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    1    4    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    1    4    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    1    4    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    1    4    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    1    4    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    1    4    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    1    4    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    1    4    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    1    4    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    1    4    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    1    4    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    1    4    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    1    4    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    1    4    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    1    4    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    1    4    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    1    4    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    1    4    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    1    4    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    1    4    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    1    4    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    1    4    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    1    4    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    1    4    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    1    4    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    1    4    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    1    4    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    1    4    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    1    4    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    1    4    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    1    4    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    1    4    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    1    4    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    1    4    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    1    4    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    1    4    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    1    4    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    1    4    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    1    4    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    1    4    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    1    4    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    1    4    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    1    4    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    1    4    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    1    4    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    1    4    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    1    4    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    1    4    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    1    4    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    1    4    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    1    4    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35525E-67
+    1    4    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31050E-66
+    1    4    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49297E-66    0.26759E-65
+    1    4    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20665E-64
+    1    4    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    1    4    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15327E-62
+    1    4    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    1    4    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30486E-60
+    1    4    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49479E-59
+    1    4    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76348E-58
+    1    4    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    1    4    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16341E-55
+    1    4    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    1    4    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33513E-53
+    1    4    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47754E-52
+    1    4    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86007E-46    0.21355E-49
+    1    4    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    1    4    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    1    4    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    1    4    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    1    4    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    1    4    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    1    4    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    1    4    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    1    4    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    1    4    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    1    4    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    1    4    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    1    4    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    1    4    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    1    4    0.95225E-10    0.10000E+01    0.80645E+05    0.53338E-57    0.41251E-68    0.10749E-66
+    1    4    0.95225E-10    0.10000E+01    0.65036E+05    0.46320E-56    0.66241E-67    0.94141E-66
+    1    4    0.95225E-10    0.10000E+01    0.52449E+05    0.40024E-55    0.93503E-66    0.81416E-65
+    1    4    0.95225E-10    0.10000E+01    0.42297E+05    0.31521E-54    0.15121E-64    0.62477E-64
+    1    4    0.95225E-10    0.10000E+01    0.34111E+05    0.26479E-53    0.31103E-63    0.46450E-63
+    1    4    0.95225E-10    0.10000E+01    0.27509E+05    0.27530E-52    0.84266E-62    0.36185E-62
+    1    4    0.95225E-10    0.10000E+01    0.22184E+05    0.37547E-51    0.26561E-60    0.35004E-61
+    1    4    0.95225E-10    0.10000E+01    0.17891E+05    0.59959E-50    0.82078E-59    0.47852E-60
+    1    4    0.95225E-10    0.10000E+01    0.14428E+05    0.96029E-49    0.23747E-57    0.76675E-59
+    1    4    0.95225E-10    0.10000E+01    0.11635E+05    0.14620E-47    0.65938E-56    0.12102E-57
+    1    4    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18298E-56
+    1    4    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49011E-53    0.26942E-55
+    1    4    0.95225E-10    0.10000E+01    0.61026E+04    0.43943E-44    0.13295E-51    0.39150E-54
+    1    4    0.95225E-10    0.10000E+01    0.49215E+04    0.62538E-43    0.35997E-50    0.56476E-53
+    1    4    0.95225E-10    0.10000E+01    0.39689E+04    0.88822E-42    0.97300E-49    0.81063E-52
+    1    4    0.95225E-10    0.10000E+01    0.32008E+04    0.39613E-39    0.84952E-46    0.36461E-49
+    1    4    0.95225E-10    0.10000E+01    0.25813E+04    0.29211E-30    0.14353E-36    0.27085E-40
+    1    4    0.95225E-10    0.10000E+01    0.20817E+04    0.55938E-14    0.12256E-19    0.52257E-24
+    1    4    0.95225E-10    0.10000E+01    0.16788E+04    0.18980E-08    0.18143E-13    0.17813E-18
+    1    4    0.95225E-10    0.10000E+01    0.13538E+04    0.40806E-08    0.68940E-13    0.38357E-18
+    1    4    0.95225E-10    0.10000E+01    0.10918E+04    0.85761E-08    0.25711E-12    0.80708E-18
+    1    4    0.95225E-10    0.10000E+01    0.88049E+03    0.17636E-07    0.94670E-12    0.16610E-17
+    1    4    0.95225E-10    0.10000E+01    0.71007E+03    0.35560E-07    0.34475E-11    0.33511E-17
+    1    4    0.95225E-10    0.10000E+01    0.57264E+03    0.70490E-07    0.12266E-10    0.66454E-17
+    1    4    0.95225E-10    0.10000E+01    0.46180E+03    0.13745E-06    0.41255E-10    0.12961E-16
+    1    4    0.95225E-10    0.10000E+01    0.37242E+03    0.26237E-06    0.12579E-09    0.24744E-16
+    1    4    0.95225E-10    0.10000E+01    0.30034E+03    0.48462E-06    0.33740E-09    0.45710E-16
+    1    4    0.95225E-10    0.10000E+01    0.24221E+03    0.85384E-06    0.78780E-09    0.80539E-16
+    1    4    0.95225E-10    0.10000E+01    0.19533E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    1    4    0.95225E-10    0.10000E+01    0.15752E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    1    4    0.16616E-09    0.10000E+01    0.80645E+05    0.10831E-56    0.84134E-68    0.33649E-66
+    1    4    0.16616E-09    0.10000E+01    0.65036E+05    0.94382E-56    0.13505E-66    0.29209E-65
+    1    4    0.16616E-09    0.10000E+01    0.52449E+05    0.81476E-55    0.18599E-65    0.25174E-64
+    1    4    0.16616E-09    0.10000E+01    0.42297E+05    0.62646E-54    0.26584E-64    0.19203E-63
+    1    4    0.16616E-09    0.10000E+01    0.34111E+05    0.47293E-53    0.41443E-63    0.13945E-62
+    1    4    0.16616E-09    0.10000E+01    0.27509E+05    0.38376E-52    0.82703E-62    0.99836E-62
+    1    4    0.16616E-09    0.10000E+01    0.22184E+05    0.38951E-51    0.23108E-60    0.77606E-61
+    1    4    0.16616E-09    0.10000E+01    0.17891E+05    0.53703E-50    0.71872E-59    0.82846E-60
+    1    4    0.16616E-09    0.10000E+01    0.14428E+05    0.84667E-49    0.21403E-57    0.12129E-58
+    1    4    0.16616E-09    0.10000E+01    0.11635E+05    0.13169E-47    0.60847E-56    0.19194E-57
+    1    4    0.16616E-09    0.10000E+01    0.93834E+04    0.19721E-46    0.16918E-54    0.29611E-56
+    1    4    0.16616E-09    0.10000E+01    0.75673E+04    0.28850E-45    0.46590E-53    0.44363E-55
+    1    4    0.16616E-09    0.10000E+01    0.61026E+04    0.41726E-44    0.12762E-51    0.65289E-54
+    1    4    0.16616E-09    0.10000E+01    0.49215E+04    0.59980E-43    0.34818E-50    0.95065E-53
+    1    4    0.16616E-09    0.10000E+01    0.39689E+04    0.85857E-42    0.94687E-49    0.13742E-51
+    1    4    0.16616E-09    0.10000E+01    0.32008E+04    0.38534E-39    0.83094E-46    0.62162E-49
+    1    4    0.16616E-09    0.10000E+01    0.25813E+04    0.28572E-30    0.14110E-36    0.46404E-40
+    1    4    0.16616E-09    0.10000E+01    0.20817E+04    0.55023E-14    0.12112E-19    0.89981E-24
+    1    4    0.16616E-09    0.10000E+01    0.16788E+04    0.18735E-08    0.17967E-13    0.30768E-18
+    1    4    0.16616E-09    0.10000E+01    0.13538E+04    0.40327E-08    0.68292E-13    0.66322E-18
+    1    4    0.16616E-09    0.10000E+01    0.10918E+04    0.84828E-08    0.25473E-12    0.13965E-17
+    1    4    0.16616E-09    0.10000E+01    0.88049E+03    0.17454E-07    0.93805E-12    0.28757E-17
+    1    4    0.16616E-09    0.10000E+01    0.71007E+03    0.35210E-07    0.34161E-11    0.58040E-17
+    1    4    0.16616E-09    0.10000E+01    0.57264E+03    0.69816E-07    0.12154E-10    0.11512E-16
+    1    4    0.16616E-09    0.10000E+01    0.46180E+03    0.13616E-06    0.40880E-10    0.22458E-16
+    1    4    0.16616E-09    0.10000E+01    0.37242E+03    0.25994E-06    0.12465E-09    0.42878E-16
+    1    4    0.16616E-09    0.10000E+01    0.30034E+03    0.48017E-06    0.33433E-09    0.79212E-16
+    1    4    0.16616E-09    0.10000E+01    0.24221E+03    0.84602E-06    0.78064E-09    0.13957E-15
+    1    4    0.16616E-09    0.10000E+01    0.19533E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    1    4    0.16616E-09    0.10000E+01    0.15752E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    1    4    0.28994E-09    0.10000E+01    0.80645E+05    0.22011E-56    0.16920E-67    0.11249E-65
+    1    4    0.28994E-09    0.10000E+01    0.65036E+05    0.19023E-55    0.27099E-66    0.96503E-65
+    1    4    0.28994E-09    0.10000E+01    0.52449E+05    0.16355E-54    0.36930E-65    0.82631E-64
+    1    4    0.28994E-09    0.10000E+01    0.42297E+05    0.12449E-53    0.50576E-64    0.62542E-63
+    1    4    0.28994E-09    0.10000E+01    0.34111E+05    0.90534E-53    0.69149E-63    0.44950E-62
+    1    4    0.28994E-09    0.10000E+01    0.27509E+05    0.65403E-52    0.10276E-61    0.31368E-61
+    1    4    0.28994E-09    0.10000E+01    0.22184E+05    0.51145E-51    0.21678E-60    0.21734E-60
+    1    4    0.28994E-09    0.10000E+01    0.17891E+05    0.53350E-50    0.62717E-59    0.17681E-59
+    1    4    0.28994E-09    0.10000E+01    0.14428E+05    0.75573E-49    0.19028E-57    0.20765E-58
+    1    4    0.28994E-09    0.10000E+01    0.11635E+05    0.11751E-47    0.55601E-56    0.31026E-57
+    1    4    0.28994E-09    0.10000E+01    0.93834E+04    0.17997E-46    0.15781E-54    0.48192E-56
+    1    4    0.28994E-09    0.10000E+01    0.75673E+04    0.26865E-45    0.44099E-53    0.73307E-55
+    1    4    0.28994E-09    0.10000E+01    0.61026E+04    0.39444E-44    0.12210E-51    0.10917E-53
+    1    4    0.28994E-09    0.10000E+01    0.49215E+04    0.57333E-43    0.33588E-50    0.16029E-52
+    1    4    0.28994E-09    0.10000E+01    0.39689E+04    0.82768E-42    0.91939E-49    0.23314E-51
+    1    4    0.28994E-09    0.10000E+01    0.32008E+04    0.37400E-39    0.81127E-46    0.10597E-48
+    1    4    0.28994E-09    0.10000E+01    0.25813E+04    0.27896E-30    0.13850E-36    0.79454E-40
+    1    4    0.28994E-09    0.10000E+01    0.20817E+04    0.54048E-14    0.11957E-19    0.15478E-23
+    1    4    0.28994E-09    0.10000E+01    0.16788E+04    0.18472E-08    0.17777E-13    0.53075E-18
+    1    4    0.28994E-09    0.10000E+01    0.13538E+04    0.39812E-08    0.67591E-13    0.11451E-17
+    1    4    0.28994E-09    0.10000E+01    0.10918E+04    0.83822E-08    0.25216E-12    0.24130E-17
+    1    4    0.28994E-09    0.10000E+01    0.88049E+03    0.17259E-07    0.92865E-12    0.49712E-17
+    1    4    0.28994E-09    0.10000E+01    0.71007E+03    0.34831E-07    0.33820E-11    0.10037E-16
+    1    4    0.28994E-09    0.10000E+01    0.57264E+03    0.69086E-07    0.12033E-10    0.19913E-16
+    1    4    0.28994E-09    0.10000E+01    0.46180E+03    0.13476E-06    0.40472E-10    0.38849E-16
+    1    4    0.28994E-09    0.10000E+01    0.37242E+03    0.25730E-06    0.12341E-09    0.74180E-16
+    1    4    0.28994E-09    0.10000E+01    0.30034E+03    0.47533E-06    0.33100E-09    0.13705E-15
+    1    4    0.28994E-09    0.10000E+01    0.24221E+03    0.83753E-06    0.77285E-09    0.24148E-15
+    1    4    0.28994E-09    0.10000E+01    0.19533E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    1    4    0.28994E-09    0.10000E+01    0.15752E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    1    4    0.50593E-09    0.10000E+01    0.80645E+05    0.44926E-56    0.34079E-67    0.39232E-65
+    1    4    0.50593E-09    0.10000E+01    0.65036E+05    0.38422E-55    0.54341E-66    0.33355E-64
+    1    4    0.50593E-09    0.10000E+01    0.52449E+05    0.32834E-54    0.73364E-65    0.28402E-63
+    1    4    0.50593E-09    0.10000E+01    0.42297E+05    0.24795E-53    0.99037E-64    0.21350E-62
+    1    4    0.50593E-09    0.10000E+01    0.34111E+05    0.17797E-52    0.13099E-62    0.15247E-61
+    1    4    0.50593E-09    0.10000E+01    0.27509E+05    0.12441E-51    0.16902E-61    0.10586E-60
+    1    4    0.50593E-09    0.10000E+01    0.22184E+05    0.86010E-51    0.25710E-60    0.70603E-60
+    1    4    0.50593E-09    0.10000E+01    0.17891E+05    0.67638E-50    0.58946E-59    0.47985E-59
+    1    4    0.50593E-09    0.10000E+01    0.14428E+05    0.74782E-49    0.17213E-57    0.41577E-58
+    1    4    0.50593E-09    0.10000E+01    0.11635E+05    0.10801E-47    0.51285E-56    0.52474E-57
+    1    4    0.50593E-09    0.10000E+01    0.93834E+04    0.16626E-46    0.14855E-54    0.79304E-56
+    1    4    0.50593E-09    0.10000E+01    0.75673E+04    0.25254E-45    0.42087E-53    0.12189E-54
+    1    4    0.50593E-09    0.10000E+01    0.61026E+04    0.37597E-44    0.11762E-51    0.18356E-53
+    1    4    0.50593E-09    0.10000E+01    0.49215E+04    0.55185E-43    0.32580E-50    0.27151E-52
+    1    4    0.50593E-09    0.10000E+01    0.39689E+04    0.80238E-42    0.89663E-49    0.39684E-51
+    1    4    0.50593E-09    0.10000E+01    0.32008E+04    0.36462E-39    0.79485E-46    0.18106E-48
+    1    4    0.50593E-09    0.10000E+01    0.25813E+04    0.27333E-30    0.13633E-36    0.13622E-39
+    1    4    0.50593E-09    0.10000E+01    0.20817E+04    0.53238E-14    0.11828E-19    0.26638E-23
+    1    4    0.50593E-09    0.10000E+01    0.16788E+04    0.18256E-08    0.17620E-13    0.91573E-18
+    1    4    0.50593E-09    0.10000E+01    0.13538E+04    0.39387E-08    0.67015E-13    0.19773E-17
+    1    4    0.50593E-09    0.10000E+01    0.10918E+04    0.82993E-08    0.25005E-12    0.41688E-17
+    1    4    0.50593E-09    0.10000E+01    0.88049E+03    0.17098E-07    0.92093E-12    0.85921E-17
+    1    4    0.50593E-09    0.10000E+01    0.71007E+03    0.34520E-07    0.33539E-11    0.17352E-16
+    1    4    0.50593E-09    0.10000E+01    0.57264E+03    0.68486E-07    0.11933E-10    0.34432E-16
+    1    4    0.50593E-09    0.10000E+01    0.46180E+03    0.13362E-06    0.40135E-10    0.67183E-16
+    1    4    0.50593E-09    0.10000E+01    0.37242E+03    0.25513E-06    0.12238E-09    0.12829E-15
+    1    4    0.50593E-09    0.10000E+01    0.30034E+03    0.47134E-06    0.32824E-09    0.23702E-15
+    1    4    0.50593E-09    0.10000E+01    0.24221E+03    0.83053E-06    0.76641E-09    0.41764E-15
+    1    4    0.50593E-09    0.10000E+01    0.19533E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    1    4    0.50593E-09    0.10000E+01    0.15752E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    1    4    0.88282E-09    0.10000E+01    0.80645E+05    0.91476E-56    0.68731E-67    0.13789E-64
+    1    4    0.88282E-09    0.10000E+01    0.65036E+05    0.77641E-55    0.10919E-65    0.11662E-63
+    1    4    0.88282E-09    0.10000E+01    0.52449E+05    0.66035E-54    0.14632E-64    0.98963E-63
+    1    4    0.88282E-09    0.10000E+01    0.42297E+05    0.49567E-53    0.19615E-63    0.74065E-62
+    1    4    0.88282E-09    0.10000E+01    0.34111E+05    0.35353E-52    0.25848E-62    0.52675E-61
+    1    4    0.88282E-09    0.10000E+01    0.27509E+05    0.24558E-51    0.32187E-61    0.36567E-60
+    1    4    0.88282E-09    0.10000E+01    0.22184E+05    0.16393E-50    0.40073E-60    0.24273E-59
+    1    4    0.88282E-09    0.10000E+01    0.17891E+05    0.10961E-49    0.65251E-59    0.15348E-58
+    1    4    0.88282E-09    0.10000E+01    0.14428E+05    0.89454E-49    0.16244E-57    0.10392E-57
+    1    4    0.88282E-09    0.10000E+01    0.11635E+05    0.10618E-47    0.47991E-56    0.98632E-57
+    1    4    0.88282E-09    0.10000E+01    0.93834E+04    0.15701E-46    0.14156E-54    0.13418E-55
+    1    4    0.88282E-09    0.10000E+01    0.75673E+04    0.24062E-45    0.40636E-53    0.20503E-54
+    1    4    0.88282E-09    0.10000E+01    0.61026E+04    0.36255E-44    0.11442E-51    0.31177E-53
+    1    4    0.88282E-09    0.10000E+01    0.49215E+04    0.53641E-43    0.31845E-50    0.46407E-52
+    1    4    0.88282E-09    0.10000E+01    0.39689E+04    0.78393E-42    0.87953E-49    0.68035E-51
+    1    4    0.88282E-09    0.10000E+01    0.32008E+04    0.35759E-39    0.78214E-46    0.31094E-48
+    1    4    0.88282E-09    0.10000E+01    0.25813E+04    0.26899E-30    0.13461E-36    0.23432E-39
+    1    4    0.88282E-09    0.10000E+01    0.20817E+04    0.52599E-14    0.11724E-19    0.45928E-23
+    1    4    0.88282E-09    0.10000E+01    0.16788E+04    0.18083E-08    0.17491E-13    0.15815E-17
+    1    4    0.88282E-09    0.10000E+01    0.13538E+04    0.39044E-08    0.66538E-13    0.34162E-17
+    1    4    0.88282E-09    0.10000E+01    0.10918E+04    0.82318E-08    0.24829E-12    0.72050E-17
+    1    4    0.88282E-09    0.10000E+01    0.88049E+03    0.16966E-07    0.91446E-12    0.14853E-16
+    1    4    0.88282E-09    0.10000E+01    0.71007E+03    0.34263E-07    0.33303E-11    0.30001E-16
+    1    4    0.88282E-09    0.10000E+01    0.57264E+03    0.67988E-07    0.11849E-10    0.59535E-16
+    1    4    0.88282E-09    0.10000E+01    0.46180E+03    0.13266E-06    0.39851E-10    0.11617E-15
+    1    4    0.88282E-09    0.10000E+01    0.37242E+03    0.25331E-06    0.12151E-09    0.22183E-15
+    1    4    0.88282E-09    0.10000E+01    0.30034E+03    0.46799E-06    0.32591E-09    0.40983E-15
+    1    4    0.88282E-09    0.10000E+01    0.24221E+03    0.82463E-06    0.76096E-09    0.72214E-15
+    1    4    0.88282E-09    0.10000E+01    0.19533E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    1    4    0.88282E-09    0.10000E+01    0.15752E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    1    4    0.15405E-08    0.10000E+01    0.80645E+05    0.19148E-55    0.14304E-66    0.64549E-64
+    1    4    0.15405E-08    0.10000E+01    0.65036E+05    0.16177E-54    0.22667E-65    0.54419E-63
+    1    4    0.15405E-08    0.10000E+01    0.52449E+05    0.13717E-53    0.30230E-64    0.46081E-62
+    1    4    0.15405E-08    0.10000E+01    0.42297E+05    0.10257E-52    0.40364E-63    0.34394E-61
+    1    4    0.15405E-08    0.10000E+01    0.34111E+05    0.72900E-52    0.53361E-62    0.24407E-60
+    1    4    0.15405E-08    0.10000E+01    0.27509E+05    0.50699E-51    0.66987E-61    0.16985E-59
+    1    4    0.15405E-08    0.10000E+01    0.22184E+05    0.33929E-50    0.79423E-60    0.11394E-58
+    1    4    0.15405E-08    0.10000E+01    0.17891E+05    0.21742E-49    0.10042E-58    0.71853E-58
+    1    4    0.15405E-08    0.10000E+01    0.14428E+05    0.14537E-48    0.18130E-57    0.43039E-57
+    1    4    0.15405E-08    0.10000E+01    0.11635E+05    0.12749E-47    0.47622E-56    0.28276E-56
+    1    4    0.15405E-08    0.10000E+01    0.93834E+04    0.16067E-46    0.13944E-54    0.26903E-55
+    1    4    0.15405E-08    0.10000E+01    0.75673E+04    0.23847E-45    0.40338E-53    0.36493E-54
+    1    4    0.15405E-08    0.10000E+01    0.61026E+04    0.35982E-44    0.11395E-51    0.54839E-53
+    1    4    0.15405E-08    0.10000E+01    0.49215E+04    0.53385E-43    0.31709E-50    0.81774E-52
+    1    4    0.15405E-08    0.10000E+01    0.39689E+04    0.78041E-42    0.87482E-49    0.11960E-50
+    1    4    0.15405E-08    0.10000E+01    0.32008E+04    0.35568E-39    0.77726E-46    0.54394E-48
+    1    4    0.15405E-08    0.10000E+01    0.25813E+04    0.26733E-30    0.13372E-36    0.40787E-39
+    1    4    0.15405E-08    0.10000E+01    0.20817E+04    0.52263E-14    0.11647E-19    0.79630E-23
+    1    4    0.15405E-08    0.10000E+01    0.16788E+04    0.17970E-08    0.17378E-13    0.27379E-17
+    1    4    0.15405E-08    0.10000E+01    0.13538E+04    0.38795E-08    0.66103E-13    0.59072E-17
+    1    4    0.15405E-08    0.10000E+01    0.10918E+04    0.81788E-08    0.24665E-12    0.12449E-16
+    1    4    0.15405E-08    0.10000E+01    0.88049E+03    0.16856E-07    0.90833E-12    0.25651E-16
+    1    4    0.15405E-08    0.10000E+01    0.71007E+03    0.34038E-07    0.33077E-11    0.51791E-16
+    1    4    0.15405E-08    0.10000E+01    0.57264E+03    0.67538E-07    0.11768E-10    0.10274E-15
+    1    4    0.15405E-08    0.10000E+01    0.46180E+03    0.13177E-06    0.39577E-10    0.20043E-15
+    1    4    0.15405E-08    0.10000E+01    0.37242E+03    0.25160E-06    0.12067E-09    0.38263E-15
+    1    4    0.15405E-08    0.10000E+01    0.30034E+03    0.46482E-06    0.32365E-09    0.70679E-15
+    1    4    0.15405E-08    0.10000E+01    0.24221E+03    0.81901E-06    0.75568E-09    0.12452E-14
+    1    4    0.15405E-08    0.10000E+01    0.19533E+03    0.12908E-05    0.14360E-08    0.19625E-14
+    1    4    0.15405E-08    0.10000E+01    0.15752E+03    0.12908E-05    0.14360E-08    0.19625E-14
+    1    4    0.26880E-08    0.10000E+01    0.80645E+05    0.48120E-55    0.35762E-66    0.15528E-62
+    1    4    0.26880E-08    0.10000E+01    0.65036E+05    0.40488E-54    0.56534E-65    0.13053E-61
+    1    4    0.26880E-08    0.10000E+01    0.52449E+05    0.34232E-53    0.75005E-64    0.11029E-60
+    1    4    0.26880E-08    0.10000E+01    0.42297E+05    0.25488E-52    0.99572E-63    0.82050E-60
+    1    4    0.26880E-08    0.10000E+01    0.34111E+05    0.18027E-51    0.13148E-61    0.57963E-59
+    1    4    0.26880E-08    0.10000E+01    0.27509E+05    0.12514E-50    0.16675E-60    0.40195E-58
+    1    4    0.26880E-08    0.10000E+01    0.22184E+05    0.84262E-50    0.20078E-59    0.27008E-57
+    1    4    0.26880E-08    0.10000E+01    0.17891E+05    0.54440E-49    0.24021E-58    0.17202E-56
+    1    4    0.26880E-08    0.10000E+01    0.14428E+05    0.34812E-48    0.34029E-57    0.10259E-55
+    1    4    0.26880E-08    0.10000E+01    0.11635E+05    0.25093E-47    0.68430E-56    0.58811E-55
+    1    4    0.26880E-08    0.10000E+01    0.93834E+04    0.24305E-46    0.17627E-54    0.36387E-54
+    1    4    0.26880E-08    0.10000E+01    0.75673E+04    0.30845E-45    0.48307E-53    0.29367E-53
+    1    4    0.26880E-08    0.10000E+01    0.61026E+04    0.43402E-44    0.13162E-51    0.31654E-52
+    1    4    0.26880E-08    0.10000E+01    0.49215E+04    0.61834E-43    0.35485E-50    0.38601E-51
+    1    4    0.26880E-08    0.10000E+01    0.39689E+04    0.87526E-42    0.95268E-49    0.47781E-50
+    1    4    0.26880E-08    0.10000E+01    0.32008E+04    0.38797E-39    0.82716E-46    0.18433E-47
+    1    4    0.26880E-08    0.10000E+01    0.25813E+04    0.28456E-30    0.13932E-36    0.11673E-38
+    1    4    0.26880E-08    0.10000E+01    0.20817E+04    0.54344E-14    0.11879E-19    0.18914E-22
+    1    4    0.26880E-08    0.10000E+01    0.16788E+04    0.18437E-08    0.17583E-13    0.57719E-17
+    1    4    0.26880E-08    0.10000E+01    0.13538E+04    0.39593E-08    0.66792E-13    0.11783E-16
+    1    4    0.26880E-08    0.10000E+01    0.10918E+04    0.83161E-08    0.24899E-12    0.23856E-16
+    1    4    0.26880E-08    0.10000E+01    0.88049E+03    0.17094E-07    0.91642E-12    0.47734E-16
+    1    4    0.26880E-08    0.10000E+01    0.71007E+03    0.34454E-07    0.33359E-11    0.94320E-16
+    1    4    0.26880E-08    0.10000E+01    0.57264E+03    0.68274E-07    0.11865E-10    0.18417E-15
+    1    4    0.26880E-08    0.10000E+01    0.46180E+03    0.13308E-06    0.39899E-10    0.35509E-15
+    1    4    0.26880E-08    0.10000E+01    0.37242E+03    0.25395E-06    0.12164E-09    0.67225E-15
+    1    4    0.26880E-08    0.10000E+01    0.30034E+03    0.46894E-06    0.32624E-09    0.12345E-14
+    1    4    0.26880E-08    0.10000E+01    0.24221E+03    0.82605E-06    0.76171E-09    0.21664E-14
+    1    4    0.26880E-08    0.10000E+01    0.19533E+03    0.13017E-05    0.14475E-08    0.34061E-14
+    1    4    0.26880E-08    0.10000E+01    0.15752E+03    0.13017E-05    0.14475E-08    0.34061E-14
+    1    4    0.46905E-08    0.10000E+01    0.80645E+05    0.95209E-55    0.70695E-66    0.63861E-62
+    1    4    0.46905E-08    0.10000E+01    0.65036E+05    0.80051E-54    0.11171E-64    0.53757E-61
+    1    4    0.46905E-08    0.10000E+01    0.52449E+05    0.67645E-53    0.14804E-63    0.45478E-60
+    1    4    0.46905E-08    0.10000E+01    0.42297E+05    0.50323E-52    0.19622E-62    0.33910E-59
+    1    4    0.46905E-08    0.10000E+01    0.34111E+05    0.35542E-51    0.25855E-61    0.24057E-58
+    1    4    0.46905E-08    0.10000E+01    0.27509E+05    0.24624E-50    0.32652E-60    0.16805E-57
+    1    4    0.46905E-08    0.10000E+01    0.22184E+05    0.16516E-49    0.38718E-59    0.11438E-56
+    1    4    0.46905E-08    0.10000E+01    0.17891E+05    0.10533E-48    0.43758E-58    0.74470E-56
+    1    4    0.46905E-08    0.10000E+01    0.14428E+05    0.64392E-48    0.53536E-57    0.45857E-55
+    1    4    0.46905E-08    0.10000E+01    0.11635E+05    0.41200E-47    0.89589E-56    0.26967E-54
+    1    4    0.46905E-08    0.10000E+01    0.93834E+04    0.33408E-46    0.20893E-54    0.16031E-53
+    1    4    0.46905E-08    0.10000E+01    0.75673E+04    0.37422E-45    0.55124E-53    0.10991E-52
+    1    4    0.46905E-08    0.10000E+01    0.61026E+04    0.49861E-44    0.14659E-51    0.98279E-52
+    1    4    0.46905E-08    0.10000E+01    0.49215E+04    0.69006E-43    0.38600E-50    0.10838E-50
+    1    4    0.46905E-08    0.10000E+01    0.39689E+04    0.95355E-42    0.10135E-48    0.12840E-49
+    1    4    0.46905E-08    0.10000E+01    0.32008E+04    0.41328E-39    0.86283E-46    0.47797E-47
+    1    4    0.46905E-08    0.10000E+01    0.25813E+04    0.29693E-30    0.14271E-36    0.28725E-38
+    1    4    0.46905E-08    0.10000E+01    0.20817E+04    0.55603E-14    0.11950E-19    0.42716E-22
+    1    4    0.46905E-08    0.10000E+01    0.16788E+04    0.18656E-08    0.17566E-13    0.12127E-16
+    1    4    0.46905E-08    0.10000E+01    0.13538E+04    0.39867E-08    0.66637E-13    0.23659E-16
+    1    4    0.46905E-08    0.10000E+01    0.10918E+04    0.83449E-08    0.24818E-12    0.46231E-16
+    1    4    0.46905E-08    0.10000E+01    0.88049E+03    0.17111E-07    0.91277E-12    0.89991E-16
+    1    4    0.46905E-08    0.10000E+01    0.71007E+03    0.34428E-07    0.33210E-11    0.17408E-15
+    1    4    0.46905E-08    0.10000E+01    0.57264E+03    0.68134E-07    0.11808E-10    0.33441E-15
+    1    4    0.46905E-08    0.10000E+01    0.46180E+03    0.13268E-06    0.39698E-10    0.63693E-15
+    1    4    0.46905E-08    0.10000E+01    0.37242E+03    0.25301E-06    0.12101E-09    0.11950E-14
+    1    4    0.46905E-08    0.10000E+01    0.30034E+03    0.46698E-06    0.32453E-09    0.21806E-14
+    1    4    0.46905E-08    0.10000E+01    0.24221E+03    0.82231E-06    0.75767E-09    0.38099E-14
+    1    4    0.46905E-08    0.10000E+01    0.19533E+03    0.12956E-05    0.14397E-08    0.59742E-14
+    1    4    0.46905E-08    0.10000E+01    0.15752E+03    0.12956E-05    0.14397E-08    0.59742E-14
+    1    4    0.81846E-08    0.10000E+01    0.80645E+05    0.18111E-54    0.13450E-65    0.23556E-61
+    1    4    0.81846E-08    0.10000E+01    0.65036E+05    0.15229E-53    0.21255E-64    0.19859E-60
+    1    4    0.81846E-08    0.10000E+01    0.52449E+05    0.12871E-52    0.28181E-63    0.16822E-59
+    1    4    0.81846E-08    0.10000E+01    0.42297E+05    0.95784E-52    0.37384E-62    0.12573E-58
+    1    4    0.81846E-08    0.10000E+01    0.34111E+05    0.67702E-51    0.49355E-61    0.89590E-58
+    1    4    0.81846E-08    0.10000E+01    0.27509E+05    0.46979E-50    0.62555E-60    0.63043E-57
+    1    4    0.81846E-08    0.10000E+01    0.22184E+05    0.31600E-49    0.74438E-59    0.43445E-56
+    1    4    0.81846E-08    0.10000E+01    0.17891E+05    0.20205E-48    0.83205E-58    0.28883E-55
+    1    4    0.81846E-08    0.10000E+01    0.14428E+05    0.12246E-47    0.94697E-57    0.18350E-54
+    1    4    0.81846E-08    0.10000E+01    0.11635E+05    0.74197E-47    0.13473E-55    0.11165E-53
+    1    4    0.81846E-08    0.10000E+01    0.93834E+04    0.52445E-46    0.27223E-54    0.66559E-53
+    1    4    0.81846E-08    0.10000E+01    0.75673E+04    0.50420E-45    0.67103E-53    0.41573E-52
+    1    4    0.81846E-08    0.10000E+01    0.61026E+04    0.61527E-44    0.17222E-51    0.30814E-51
+    1    4    0.81846E-08    0.10000E+01    0.49215E+04    0.81434E-43    0.44006E-50    0.29215E-50
+    1    4    0.81846E-08    0.10000E+01    0.39689E+04    0.10896E-41    0.11219E-48    0.32574E-49
+    1    4    0.81846E-08    0.10000E+01    0.32008E+04    0.45827E-39    0.92847E-46    0.11906E-46
+    1    4    0.81846E-08    0.10000E+01    0.25813E+04    0.31959E-30    0.14925E-36    0.70041E-38
+    1    4    0.81846E-08    0.10000E+01    0.20817E+04    0.58019E-14    0.12116E-19    0.99109E-22
+    1    4    0.81846E-08    0.10000E+01    0.16788E+04    0.19109E-08    0.17589E-13    0.26669E-16
+    1    4    0.81846E-08    0.10000E+01    0.13538E+04    0.40484E-08    0.66565E-13    0.49519E-16
+    1    4    0.81846E-08    0.10000E+01    0.10918E+04    0.84228E-08    0.24748E-12    0.92868E-16
+    1    4    0.81846E-08    0.10000E+01    0.88049E+03    0.17196E-07    0.90910E-12    0.17477E-15
+    1    4    0.81846E-08    0.10000E+01    0.71007E+03    0.34489E-07    0.33048E-11    0.32896E-15
+    1    4    0.81846E-08    0.10000E+01    0.57264E+03    0.68096E-07    0.11743E-10    0.61828E-15
+    1    4    0.81846E-08    0.10000E+01    0.46180E+03    0.13238E-06    0.39467E-10    0.11576E-14
+    1    4    0.81846E-08    0.10000E+01    0.37242E+03    0.25213E-06    0.12028E-09    0.21442E-14
+    1    4    0.81846E-08    0.10000E+01    0.30034E+03    0.46496E-06    0.32253E-09    0.38763E-14
+    1    4    0.81846E-08    0.10000E+01    0.24221E+03    0.81829E-06    0.75294E-09    0.67291E-14
+    1    4    0.81846E-08    0.10000E+01    0.19533E+03    0.12888E-05    0.14307E-08    0.10510E-13
+    1    4    0.81846E-08    0.10000E+01    0.15752E+03    0.12888E-05    0.14307E-08    0.10510E-13
+    1    4    0.14282E-07    0.10000E+01    0.80645E+05    0.33147E-54    0.24634E-65    0.79150E-61
+    1    4    0.14282E-07    0.10000E+01    0.65036E+05    0.27890E-53    0.38951E-64    0.66813E-60
+    1    4    0.14282E-07    0.10000E+01    0.52449E+05    0.23585E-52    0.51713E-63    0.56661E-59
+    1    4    0.14282E-07    0.10000E+01    0.42297E+05    0.17571E-51    0.68772E-62    0.42438E-58
+    1    4    0.14282E-07    0.10000E+01    0.34111E+05    0.12446E-50    0.91188E-61    0.30352E-57
+    1    4    0.14282E-07    0.10000E+01    0.27509E+05    0.86687E-50    0.11650E-59    0.21490E-56
+    1    4    0.14282E-07    0.10000E+01    0.22184E+05    0.58699E-49    0.14044E-58    0.14962E-55
+    1    4    0.14282E-07    0.10000E+01    0.17891E+05    0.37926E-48    0.15901E-57    0.10117E-54
+    1    4    0.14282E-07    0.10000E+01    0.14428E+05    0.23222E-47    0.17745E-56    0.65935E-54
+    1    4    0.14282E-07    0.10000E+01    0.11635E+05    0.13894E-46    0.22579E-55    0.41406E-53
+    1    4    0.14282E-07    0.10000E+01    0.93834E+04    0.90280E-46    0.38735E-54    0.25238E-52
+    1    4    0.14282E-07    0.10000E+01    0.75673E+04    0.74621E-45    0.86049E-53    0.15321E-51
+    1    4    0.14282E-07    0.10000E+01    0.61026E+04    0.80735E-44    0.21040E-51    0.10000E-50
+    1    4    0.14282E-07    0.10000E+01    0.49215E+04    0.10038E-42    0.52110E-50    0.79413E-50
+    1    4    0.14282E-07    0.10000E+01    0.39689E+04    0.12947E-41    0.12892E-48    0.79429E-49
+    1    4    0.14282E-07    0.10000E+01    0.32008E+04    0.52756E-39    0.10335E-45    0.28194E-46
+    1    4    0.14282E-07    0.10000E+01    0.25813E+04    0.35570E-30    0.16027E-36    0.16512E-37
+    1    4    0.14282E-07    0.10000E+01    0.20817E+04    0.62095E-14    0.12451E-19    0.23039E-21
+    1    4    0.14282E-07    0.10000E+01    0.16788E+04    0.19940E-08    0.17732E-13    0.60294E-16
+    1    4    0.14282E-07    0.10000E+01    0.13538E+04    0.41701E-08    0.66858E-13    0.10667E-15
+    1    4    0.14282E-07    0.10000E+01    0.10918E+04    0.85964E-08    0.24791E-12    0.19182E-15
+    1    4    0.14282E-07    0.10000E+01    0.88049E+03    0.17433E-07    0.90892E-12    0.34813E-15
+    1    4    0.14282E-07    0.10000E+01    0.71007E+03    0.34796E-07    0.32997E-11    0.63523E-15
+    1    4    0.14282E-07    0.10000E+01    0.57264E+03    0.68454E-07    0.11715E-10    0.11633E-14
+    1    4    0.14282E-07    0.10000E+01    0.46180E+03    0.13273E-06    0.39349E-10    0.21323E-14
+    1    4    0.14282E-07    0.10000E+01    0.37242E+03    0.25230E-06    0.11988E-09    0.38846E-14
+    1    4    0.14282E-07    0.10000E+01    0.30034E+03    0.46467E-06    0.32139E-09    0.69368E-14
+    1    4    0.14282E-07    0.10000E+01    0.24221E+03    0.81703E-06    0.75021E-09    0.11938E-13
+    1    4    0.14282E-07    0.10000E+01    0.19533E+03    0.12861E-05    0.14254E-08    0.18544E-13
+    1    4    0.14282E-07    0.10000E+01    0.15752E+03    0.12861E-05    0.14254E-08    0.18544E-13
+    1    4    0.24920E-07    0.10000E+01    0.80645E+05    0.58846E-54    0.43781E-65    0.24932E-60
+    1    4    0.24920E-07    0.10000E+01    0.65036E+05    0.49557E-53    0.69276E-64    0.21069E-59
+    1    4    0.24920E-07    0.10000E+01    0.52449E+05    0.41941E-52    0.92141E-63    0.17884E-58
+    1    4    0.24920E-07    0.10000E+01    0.42297E+05    0.31293E-51    0.12293E-61    0.13418E-57
+    1    4    0.24920E-07    0.10000E+01    0.34111E+05    0.22226E-50    0.16388E-60    0.96257E-57
+    1    4    0.24920E-07    0.10000E+01    0.27509E+05    0.15554E-49    0.21139E-59    0.68494E-56
+    1    4    0.24920E-07    0.10000E+01    0.22184E+05    0.10619E-48    0.25909E-58    0.48080E-55
+    1    4    0.24920E-07    0.10000E+01    0.17891E+05    0.69545E-48    0.29991E-57    0.32945E-54
+    1    4    0.24920E-07    0.10000E+01    0.14428E+05    0.43352E-47    0.33749E-56    0.21906E-53
+    1    4    0.24920E-07    0.10000E+01    0.11635E+05    0.26169E-46    0.40452E-55    0.14124E-52
+    1    4    0.24920E-07    0.10000E+01    0.93834E+04    0.16337E-45    0.59807E-54    0.88397E-52
+    1    4    0.24920E-07    0.10000E+01    0.75673E+04    0.11949E-44    0.11584E-52    0.54003E-51
+    1    4    0.24920E-07    0.10000E+01    0.61026E+04    0.11229E-43    0.26413E-51    0.33289E-50
+    1    4    0.24920E-07    0.10000E+01    0.49215E+04    0.12801E-42    0.63243E-50    0.22820E-49
+    1    4    0.24920E-07    0.10000E+01    0.39689E+04    0.15805E-41    0.15237E-48    0.19583E-48
+    1    4    0.24920E-07    0.10000E+01    0.32008E+04    0.62485E-39    0.11854E-45    0.65013E-46
+    1    4    0.24920E-07    0.10000E+01    0.25813E+04    0.40779E-30    0.17678E-36    0.37883E-37
+    1    4    0.24920E-07    0.10000E+01    0.20817E+04    0.68243E-14    0.12995E-19    0.53558E-21
+    1    4    0.24920E-07    0.10000E+01    0.16788E+04    0.21261E-08    0.18018E-13    0.13936E-15
+    1    4    0.24920E-07    0.10000E+01    0.13538E+04    0.43680E-08    0.67570E-13    0.23544E-15
+    1    4    0.24920E-07    0.10000E+01    0.10918E+04    0.88890E-08    0.24957E-12    0.40632E-15
+    1    4    0.24920E-07    0.10000E+01    0.88049E+03    0.17857E-07    0.91247E-12    0.71066E-15
+    1    4    0.24920E-07    0.10000E+01    0.71007E+03    0.35393E-07    0.33061E-11    0.12546E-14
+    1    4    0.24920E-07    0.10000E+01    0.57264E+03    0.69268E-07    0.11722E-10    0.22315E-14
+    1    4    0.24920E-07    0.10000E+01    0.46180E+03    0.13379E-06    0.39341E-10    0.39901E-14
+    1    4    0.24920E-07    0.10000E+01    0.37242E+03    0.25362E-06    0.11980E-09    0.71237E-14
+    1    4    0.24920E-07    0.10000E+01    0.30034E+03    0.46618E-06    0.32108E-09    0.12526E-13
+    1    4    0.24920E-07    0.10000E+01    0.24221E+03    0.81861E-06    0.74934E-09    0.21315E-13
+    1    4    0.24920E-07    0.10000E+01    0.19533E+03    0.12875E-05    0.14236E-08    0.32875E-13
+    1    4    0.24920E-07    0.10000E+01    0.15752E+03    0.12875E-05    0.14236E-08    0.32875E-13
+    1    4    0.43485E-07    0.10000E+01    0.80645E+05    0.10216E-53    0.76096E-65    0.75592E-60
+    1    4    0.43485E-07    0.10000E+01    0.65036E+05    0.86116E-53    0.12050E-63    0.63934E-59
+    1    4    0.43485E-07    0.10000E+01    0.52449E+05    0.72944E-52    0.16059E-62    0.54314E-58
+    1    4    0.43485E-07    0.10000E+01    0.42297E+05    0.54513E-51    0.21500E-61    0.40807E-57
+    1    4    0.43485E-07    0.10000E+01    0.34111E+05    0.38833E-50    0.28825E-60    0.29348E-56
+    1    4    0.43485E-07    0.10000E+01    0.27509E+05    0.27312E-49    0.37551E-59    0.20968E-55
+    1    4    0.43485E-07    0.10000E+01    0.22184E+05    0.18805E-48    0.46806E-58    0.14817E-54
+    1    4    0.43485E-07    0.10000E+01    0.17891E+05    0.12489E-47    0.55515E-57    0.10260E-53
+    1    4    0.43485E-07    0.10000E+01    0.14428E+05    0.79420E-47    0.63758E-56    0.69311E-53
+    1    4    0.43485E-07    0.10000E+01    0.11635E+05    0.48821E-46    0.74770E-55    0.45652E-52
+    1    4    0.43485E-07    0.10000E+01    0.93834E+04    0.30148E-45    0.99102E-54    0.29292E-51
+    1    4    0.43485E-07    0.10000E+01    0.75673E+04    0.20315E-44    0.16493E-52    0.18254E-50
+    1    4    0.43485E-07    0.10000E+01    0.61026E+04    0.16608E-43    0.33999E-51    0.11131E-49
+    1    4    0.43485E-07    0.10000E+01    0.49215E+04    0.16895E-42    0.77833E-50    0.69992E-49
+    1    4    0.43485E-07    0.10000E+01    0.39689E+04    0.19656E-41    0.18306E-48    0.51314E-48
+    1    4    0.43485E-07    0.10000E+01    0.32008E+04    0.75334E-39    0.13890E-45    0.15157E-45
+    1    4    0.43485E-07    0.10000E+01    0.25813E+04    0.47780E-30    0.19950E-36    0.86168E-37
+    1    4    0.43485E-07    0.10000E+01    0.20817E+04    0.76816E-14    0.13754E-19    0.12564E-20
+    1    4    0.43485E-07    0.10000E+01    0.16788E+04    0.23163E-08    0.18403E-13    0.33019E-15
+    1    4    0.43485E-07    0.10000E+01    0.13538E+04    0.46490E-08    0.68499E-13    0.53342E-15
+    1    4    0.43485E-07    0.10000E+01    0.10918E+04    0.92993E-08    0.25161E-12    0.88426E-15
+    1    4    0.43485E-07    0.10000E+01    0.88049E+03    0.18443E-07    0.91628E-12    0.14905E-14
+    1    4    0.43485E-07    0.10000E+01    0.71007E+03    0.36203E-07    0.33106E-11    0.25427E-14
+    1    4    0.43485E-07    0.10000E+01    0.57264E+03    0.70341E-07    0.11716E-10    0.43825E-14
+    1    4    0.43485E-07    0.10000E+01    0.46180E+03    0.13513E-06    0.39273E-10    0.76188E-14
+    1    4    0.43485E-07    0.10000E+01    0.37242E+03    0.25515E-06    0.11951E-09    0.13280E-13
+    1    4    0.43485E-07    0.10000E+01    0.30034E+03    0.46770E-06    0.32016E-09    0.22911E-13
+    1    4    0.43485E-07    0.10000E+01    0.24221E+03    0.81971E-06    0.74701E-09    0.38436E-13
+    1    4    0.43485E-07    0.10000E+01    0.19533E+03    0.12878E-05    0.14190E-08    0.58737E-13
+    1    4    0.43485E-07    0.10000E+01    0.15752E+03    0.12878E-05    0.14190E-08    0.58737E-13
+    1    4    0.75878E-07    0.10000E+01    0.80645E+05    0.17443E-53    0.13009E-64    0.22393E-59
+    1    4    0.75878E-07    0.10000E+01    0.65036E+05    0.14719E-52    0.20617E-63    0.18954E-58
+    1    4    0.75878E-07    0.10000E+01    0.52449E+05    0.12479E-51    0.27531E-62    0.16112E-57
+    1    4    0.75878E-07    0.10000E+01    0.42297E+05    0.93405E-51    0.36983E-61    0.12120E-56
+    1    4    0.75878E-07    0.10000E+01    0.34111E+05    0.66730E-50    0.49854E-60    0.87345E-56
+    1    4    0.75878E-07    0.10000E+01    0.27509E+05    0.47160E-49    0.65554E-59    0.62617E-55
+    1    4    0.75878E-07    0.10000E+01    0.22184E+05    0.32733E-48    0.83008E-58    0.44486E-54
+    1    4    0.75878E-07    0.10000E+01    0.17891E+05    0.22029E-47    0.10076E-56    0.31070E-53
+    1    4    0.75878E-07    0.10000E+01    0.14428E+05    0.14281E-46    0.11853E-55    0.21256E-52
+    1    4    0.75878E-07    0.10000E+01    0.11635E+05    0.89654E-46    0.13916E-54    0.14243E-51
+    1    4    0.75878E-07    0.10000E+01    0.93834E+04    0.55684E-45    0.17298E-53    0.93362E-51
+    1    4    0.75878E-07    0.10000E+01    0.75673E+04    0.35907E-44    0.25108E-52    0.59519E-50
+    1    4    0.75878E-07    0.10000E+01    0.61026E+04    0.26189E-43    0.45435E-51    0.36735E-49
+    1    4    0.75878E-07    0.10000E+01    0.49215E+04    0.23353E-42    0.97133E-50    0.22369E-48
+    1    4    0.75878E-07    0.10000E+01    0.39689E+04    0.24973E-41    0.22214E-48    0.14596E-47
+    1    4    0.75878E-07    0.10000E+01    0.32008E+04    0.92057E-39    0.16527E-45    0.37149E-45
+    1    4    0.75878E-07    0.10000E+01    0.25813E+04    0.56958E-30    0.22986E-36    0.19859E-36
+    1    4    0.75878E-07    0.10000E+01    0.20817E+04    0.88612E-14    0.14792E-19    0.30033E-20
+    1    4    0.75878E-07    0.10000E+01    0.16788E+04    0.25887E-08    0.18921E-13    0.80391E-15
+    1    4    0.75878E-07    0.10000E+01    0.13538E+04    0.50451E-08    0.69715E-13    0.12428E-14
+    1    4    0.75878E-07    0.10000E+01    0.10918E+04    0.98701E-08    0.25414E-12    0.19802E-14
+    1    4    0.75878E-07    0.10000E+01    0.88049E+03    0.19248E-07    0.92035E-12    0.32181E-14
+    1    4    0.75878E-07    0.10000E+01    0.71007E+03    0.37299E-07    0.33122E-11    0.53034E-14
+    1    4    0.75878E-07    0.10000E+01    0.57264E+03    0.71760E-07    0.11690E-10    0.88446E-14
+    1    4    0.75878E-07    0.10000E+01    0.46180E+03    0.13683E-06    0.39121E-10    0.14910E-13
+    1    4    0.75878E-07    0.10000E+01    0.37242E+03    0.25695E-06    0.11892E-09    0.25287E-13
+    1    4    0.75878E-07    0.10000E+01    0.30034E+03    0.46917E-06    0.31840E-09    0.42643E-13
+    1    4    0.75878E-07    0.10000E+01    0.24221E+03    0.82009E-06    0.74263E-09    0.70293E-13
+    1    4    0.75878E-07    0.10000E+01    0.19533E+03    0.12863E-05    0.14104E-08    0.10617E-12
+    1    4    0.75878E-07    0.10000E+01    0.15752E+03    0.12863E-05    0.14104E-08    0.10617E-12
+    1    4    0.13240E-06    0.10000E+01    0.80645E+05    0.29427E-53    0.21972E-64    0.65148E-59
+    1    4    0.13240E-06    0.10000E+01    0.65036E+05    0.24854E-52    0.34847E-63    0.55177E-58
+    1    4    0.13240E-06    0.10000E+01    0.52449E+05    0.21088E-51    0.46617E-62    0.46931E-57
+    1    4    0.13240E-06    0.10000E+01    0.42297E+05    0.15809E-50    0.62818E-61    0.35337E-56
+    1    4    0.13240E-06    0.10000E+01    0.34111E+05    0.11324E-49    0.85103E-60    0.25511E-55
+    1    4    0.13240E-06    0.10000E+01    0.27509E+05    0.80384E-49    0.11285E-58    0.18340E-54
+    1    4    0.13240E-06    0.10000E+01    0.22184E+05    0.56202E-48    0.14489E-57    0.13088E-53
+    1    4    0.13240E-06    0.10000E+01    0.17891E+05    0.38272E-47    0.17951E-56    0.92045E-53
+    1    4    0.13240E-06    0.10000E+01    0.14428E+05    0.25243E-46    0.21619E-55    0.63613E-52
+    1    4    0.13240E-06    0.10000E+01    0.11635E+05    0.16176E-45    0.25704E-54    0.43216E-51
+    1    4    0.13240E-06    0.10000E+01    0.93834E+04    0.10187E-44    0.31076E-53    0.28831E-50
+    1    4    0.13240E-06    0.10000E+01    0.75673E+04    0.64641E-44    0.40868E-52    0.18772E-49
+    1    4    0.13240E-06    0.10000E+01    0.61026E+04    0.43696E-43    0.64331E-51    0.11823E-48
+    1    4    0.13240E-06    0.10000E+01    0.49215E+04    0.34324E-42    0.12446E-49    0.72060E-48
+    1    4    0.13240E-06    0.10000E+01    0.39689E+04    0.32874E-41    0.27274E-48    0.44263E-47
+    1    4    0.13240E-06    0.10000E+01    0.32008E+04    0.11451E-38    0.19929E-45    0.98141E-45
+    1    4    0.13240E-06    0.10000E+01    0.25813E+04    0.69120E-30    0.27050E-36    0.47410E-36
+    1    4    0.13240E-06    0.10000E+01    0.20817E+04    0.10521E-13    0.16264E-19    0.73597E-20
+    1    4    0.13240E-06    0.10000E+01    0.16788E+04    0.29921E-08    0.19712E-13    0.20081E-14
+    1    4    0.13240E-06    0.10000E+01    0.13538E+04    0.56278E-08    0.71678E-13    0.29736E-14
+    1    4    0.13240E-06    0.10000E+01    0.10918E+04    0.10712E-07    0.25867E-12    0.45565E-14
+    1    4    0.13240E-06    0.10000E+01    0.88049E+03    0.20449E-07    0.92966E-12    0.71447E-14
+    1    4    0.13240E-06    0.10000E+01    0.71007E+03    0.38973E-07    0.33275E-11    0.11381E-13
+    1    4    0.13240E-06    0.10000E+01    0.57264E+03    0.74017E-07    0.11701E-10    0.18363E-13
+    1    4    0.13240E-06    0.10000E+01    0.46180E+03    0.13974E-06    0.39062E-10    0.29978E-13
+    1    4    0.13240E-06    0.10000E+01    0.37242E+03    0.26047E-06    0.11857E-09    0.49347E-13
+    1    4    0.13240E-06    0.10000E+01    0.30034E+03    0.47305E-06    0.31720E-09    0.81086E-13
+    1    4    0.13240E-06    0.10000E+01    0.24221E+03    0.82383E-06    0.73945E-09    0.13090E-12
+    1    4    0.13240E-06    0.10000E+01    0.19533E+03    0.12892E-05    0.14039E-08    0.19491E-12
+    1    4    0.13240E-06    0.10000E+01    0.15752E+03    0.12892E-05    0.14039E-08    0.19491E-12
+    1    4    0.23103E-06    0.10000E+01    0.80645E+05    0.49207E-53    0.36779E-64    0.18666E-58
+    1    4    0.23103E-06    0.10000E+01    0.65036E+05    0.41595E-52    0.58370E-63    0.15818E-57
+    1    4    0.23103E-06    0.10000E+01    0.52449E+05    0.35319E-51    0.78212E-62    0.13460E-56
+    1    4    0.23103E-06    0.10000E+01    0.42297E+05    0.26512E-50    0.10569E-60    0.10143E-55
+    1    4    0.23103E-06    0.10000E+01    0.34111E+05    0.19037E-49    0.14381E-59    0.73335E-55
+    1    4    0.23103E-06    0.10000E+01    0.27509E+05    0.13566E-48    0.19209E-58    0.52844E-54
+    1    4    0.23103E-06    0.10000E+01    0.22184E+05    0.95456E-48    0.24959E-57    0.37850E-53
+    1    4    0.23103E-06    0.10000E+01    0.17891E+05    0.65669E-47    0.31470E-56    0.26772E-52
+    1    4    0.23103E-06    0.10000E+01    0.14428E+05    0.43966E-46    0.38707E-55    0.18655E-51
+    1    4    0.23103E-06    0.10000E+01    0.11635E+05    0.28700E-45    0.46811E-54    0.12814E-50
+    1    4    0.23103E-06    0.10000E+01    0.93834E+04    0.18376E-44    0.56330E-53    0.86714E-50
+    1    4    0.23103E-06    0.10000E+01    0.75673E+04    0.11670E-43    0.70004E-52    0.57486E-49
+    1    4    0.23103E-06    0.10000E+01    0.61026E+04    0.75765E-43    0.97715E-51    0.36974E-48
+    1    4    0.23103E-06    0.10000E+01    0.49215E+04    0.53857E-42    0.16679E-49    0.22894E-47
+    1    4    0.23103E-06    0.10000E+01    0.39689E+04    0.45601E-41    0.34119E-48    0.13822E-46
+    1    4    0.23103E-06    0.10000E+01    0.32008E+04    0.14638E-38    0.24331E-45    0.27890E-44
+    1    4    0.23103E-06    0.10000E+01    0.25813E+04    0.85577E-30    0.32450E-36    0.11940E-35
+    1    4    0.23103E-06    0.10000E+01    0.20817E+04    0.12896E-13    0.18346E-19    0.18557E-19
+    1    4    0.23103E-06    0.10000E+01    0.16788E+04    0.35971E-08    0.20916E-13    0.51300E-14
+    1    4    0.23103E-06    0.10000E+01    0.13538E+04    0.64930E-08    0.74817E-13    0.72872E-14
+    1    4    0.23103E-06    0.10000E+01    0.10918E+04    0.11962E-07    0.26648E-12    0.10747E-13
+    1    4    0.23103E-06    0.10000E+01    0.88049E+03    0.22250E-07    0.94817E-12    0.16272E-13
+    1    4    0.23103E-06    0.10000E+01    0.71007E+03    0.41536E-07    0.33688E-11    0.25081E-13
+    1    4    0.23103E-06    0.10000E+01    0.57264E+03    0.77593E-07    0.11786E-10    0.39183E-13
+    1    4    0.23103E-06    0.10000E+01    0.46180E+03    0.14461E-06    0.39217E-10    0.61952E-13
+    1    4    0.23103E-06    0.10000E+01    0.37242E+03    0.26690E-06    0.11881E-09    0.98869E-13
+    1    4    0.23103E-06    0.10000E+01    0.30034E+03    0.48128E-06    0.31744E-09    0.15796E-12
+    1    4    0.23103E-06    0.10000E+01    0.24221E+03    0.83398E-06    0.73950E-09    0.24905E-12
+    1    4    0.23103E-06    0.10000E+01    0.19533E+03    0.13011E-05    0.14035E-08    0.36468E-12
+    1    4    0.23103E-06    0.10000E+01    0.15752E+03    0.13011E-05    0.14035E-08    0.36468E-12
+    1    4    0.40314E-06    0.10000E+01    0.80645E+05    0.81645E-53    0.61081E-64    0.53109E-58
+    1    4    0.40314E-06    0.10000E+01    0.65036E+05    0.69067E-52    0.96995E-63    0.45025E-57
+    1    4    0.40314E-06    0.10000E+01    0.52449E+05    0.58684E-51    0.13016E-61    0.38328E-56
+    1    4    0.40314E-06    0.10000E+01    0.42297E+05    0.44104E-50    0.17632E-60    0.28904E-55
+    1    4    0.40314E-06    0.10000E+01    0.34111E+05    0.31736E-49    0.24086E-59    0.20924E-54
+    1    4    0.40314E-06    0.10000E+01    0.27509E+05    0.22694E-48    0.32377E-58    0.15107E-53
+    1    4    0.40314E-06    0.10000E+01    0.22184E+05    0.16058E-47    0.42505E-57    0.10854E-52
+    1    4    0.40314E-06    0.10000E+01    0.17891E+05    0.11145E-46    0.54399E-56    0.77140E-52
+    1    4    0.40314E-06    0.10000E+01    0.14428E+05    0.75588E-46    0.68160E-55    0.54120E-51
+    1    4    0.40314E-06    0.10000E+01    0.11635E+05    0.50159E-45    0.83927E-54    0.37512E-50
+    1    4    0.40314E-06    0.10000E+01    0.93834E+04    0.32664E-44    0.10178E-52    0.25679E-49
+    1    4    0.40314E-06    0.10000E+01    0.75673E+04    0.20944E-43    0.12346E-51    0.17279E-48
+    1    4    0.40314E-06    0.10000E+01    0.61026E+04    0.13395E-42    0.15836E-50    0.11326E-47
+    1    4    0.40314E-06    0.10000E+01    0.49215E+04    0.89200E-42    0.23716E-49    0.71567E-47
+    1    4    0.40314E-06    0.10000E+01    0.39689E+04    0.67248E-41    0.43799E-48    0.43493E-46
+    1    4    0.40314E-06    0.10000E+01    0.32008E+04    0.19392E-38    0.29920E-45    0.83696E-44
+    1    4    0.40314E-06    0.10000E+01    0.25813E+04    0.10796E-29    0.39285E-36    0.32059E-35
+    1    4    0.40314E-06    0.10000E+01    0.20817E+04    0.16255E-13    0.21073E-19    0.48409E-19
+    1    4    0.40314E-06    0.10000E+01    0.16788E+04    0.44828E-08    0.22471E-13    0.13424E-13
+    1    4    0.40314E-06    0.10000E+01    0.13538E+04    0.77225E-08    0.78773E-13    0.18328E-13
+    1    4    0.40314E-06    0.10000E+01    0.10918E+04    0.13694E-07    0.27591E-12    0.26027E-13
+    1    4    0.40314E-06    0.10000E+01    0.88049E+03    0.24689E-07    0.96881E-12    0.38066E-13
+    1    4    0.40314E-06    0.10000E+01    0.71007E+03    0.44927E-07    0.34079E-11    0.56814E-13
+    1    4    0.40314E-06    0.10000E+01    0.57264E+03    0.82195E-07    0.11839E-10    0.86027E-13
+    1    4    0.40314E-06    0.10000E+01    0.46180E+03    0.15064E-06    0.39215E-10    0.13182E-12
+    1    4    0.40314E-06    0.10000E+01    0.37242E+03    0.27444E-06    0.11847E-09    0.20391E-12
+    1    4    0.40314E-06    0.10000E+01    0.30034E+03    0.49014E-06    0.31602E-09    0.31632E-12
+    1    4    0.40314E-06    0.10000E+01    0.24221E+03    0.84355E-06    0.73546E-09    0.48604E-12
+    1    4    0.40314E-06    0.10000E+01    0.19533E+03    0.13104E-05    0.13950E-08    0.69836E-12
+    1    4    0.40314E-06    0.10000E+01    0.15752E+03    0.13104E-05    0.13950E-08    0.69836E-12
+    1    4    0.70346E-06    0.10000E+01    0.80645E+05    0.13459E-52    0.10077E-63    0.14717E-57
+    1    4    0.70346E-06    0.10000E+01    0.65036E+05    0.11393E-51    0.16011E-62    0.12481E-56
+    1    4    0.70346E-06    0.10000E+01    0.52449E+05    0.96860E-51    0.21513E-61    0.10628E-55
+    1    4    0.70346E-06    0.10000E+01    0.42297E+05    0.72872E-50    0.29205E-60    0.80196E-55
+    1    4    0.70346E-06    0.10000E+01    0.34111E+05    0.52533E-49    0.40028E-59    0.58112E-54
+    1    4    0.70346E-06    0.10000E+01    0.27509E+05    0.37678E-48    0.54101E-58    0.42024E-53
+    1    4    0.70346E-06    0.10000E+01    0.22184E+05    0.26788E-47    0.71639E-57    0.30270E-52
+    1    4    0.70346E-06    0.10000E+01    0.17891E+05    0.18733E-46    0.92838E-56    0.21594E-51
+    1    4    0.70346E-06    0.10000E+01    0.14428E+05    0.12843E-45    0.11816E-54    0.15232E-50
+    1    4    0.70346E-06    0.10000E+01    0.11635E+05    0.86420E-45    0.14795E-53    0.10632E-49
+    1    4    0.70346E-06    0.10000E+01    0.93834E+04    0.57160E-44    0.18178E-52    0.73436E-49
+    1    4    0.70346E-06    0.10000E+01    0.75673E+04    0.37138E-43    0.21979E-51    0.49991E-48
+    1    4    0.70346E-06    0.10000E+01    0.61026E+04    0.23768E-42    0.26926E-50    0.33273E-47
+    1    4    0.70346E-06    0.10000E+01    0.49215E+04    0.15315E-41    0.36197E-49    0.21422E-46
+    1    4    0.70346E-06    0.10000E+01    0.39689E+04    0.10574E-40    0.59025E-48    0.13224E-45
+    1    4    0.70346E-06    0.10000E+01    0.32008E+04    0.27140E-38    0.37510E-45    0.25096E-43
+    1    4    0.70346E-06    0.10000E+01    0.25813E+04    0.14072E-29    0.48167E-36    0.88827E-35
+    1    4    0.70346E-06    0.10000E+01    0.20817E+04    0.21237E-13    0.24790E-19    0.12772E-18
+    1    4    0.70346E-06    0.10000E+01    0.16788E+04    0.58311E-08    0.24695E-13    0.35176E-13
+    1    4    0.70346E-06    0.10000E+01    0.13538E+04    0.95543E-08    0.84583E-13    0.46384E-13
+    1    4    0.70346E-06    0.10000E+01    0.10918E+04    0.16238E-07    0.29031E-12    0.63615E-13
+    1    4    0.70346E-06    0.10000E+01    0.88049E+03    0.28251E-07    0.10024E-11    0.90060E-13
+    1    4    0.70346E-06    0.10000E+01    0.71007E+03    0.49892E-07    0.34804E-11    0.13042E-12
+    1    4    0.70346E-06    0.10000E+01    0.57264E+03    0.89014E-07    0.11978E-10    0.19186E-12
+    1    4    0.70346E-06    0.10000E+01    0.46180E+03    0.15979E-06    0.39431E-10    0.28563E-12
+    1    4    0.70346E-06    0.10000E+01    0.37242E+03    0.28633E-06    0.11867E-09    0.42912E-12
+    1    4    0.70346E-06    0.10000E+01    0.30034E+03    0.50501E-06    0.31583E-09    0.64701E-12
+    1    4    0.70346E-06    0.10000E+01    0.24221E+03    0.86137E-06    0.73399E-09    0.96876E-12
+    1    4    0.70346E-06    0.10000E+01    0.19533E+03    0.13305E-05    0.13911E-08    0.13648E-11
+    1    4    0.70346E-06    0.10000E+01    0.15752E+03    0.13305E-05    0.13911E-08    0.13648E-11
+    1    4    0.12275E-05    0.10000E+01    0.80645E+05    0.21995E-52    0.16480E-63    0.38845E-57
+    1    4    0.12275E-05    0.10000E+01    0.65036E+05    0.18630E-51    0.26195E-62    0.32953E-56
+    1    4    0.12275E-05    0.10000E+01    0.52449E+05    0.15846E-50    0.35235E-61    0.28068E-55
+    1    4    0.12275E-05    0.10000E+01    0.42297E+05    0.11932E-49    0.47924E-60    0.21188E-54
+    1    4    0.12275E-05    0.10000E+01    0.34111E+05    0.86156E-49    0.65871E-59    0.15365E-53
+    1    4    0.12275E-05    0.10000E+01    0.27509E+05    0.61951E-48    0.89437E-58    0.11125E-52
+    1    4    0.12275E-05    0.10000E+01    0.22184E+05    0.44224E-47    0.11929E-56    0.80287E-52
+    1    4    0.12275E-05    0.10000E+01    0.17891E+05    0.31120E-46    0.15619E-55    0.57443E-51
+    1    4    0.12275E-05    0.10000E+01    0.14428E+05    0.21529E-45    0.20140E-54    0.40683E-50
+    1    4    0.12275E-05    0.10000E+01    0.11635E+05    0.14657E-44    0.25592E-53    0.28547E-49
+    1    4    0.12275E-05    0.10000E+01    0.93834E+04    0.98276E-44    0.31899E-52    0.19848E-48
+    1    4    0.12275E-05    0.10000E+01    0.75673E+04    0.64733E-43    0.38857E-51    0.13627E-47
+    1    4    0.12275E-05    0.10000E+01    0.61026E+04    0.41781E-42    0.46775E-50    0.91739E-47
+    1    4    0.12275E-05    0.10000E+01    0.49215E+04    0.26633E-41    0.58535E-49    0.59953E-46
+    1    4    0.12275E-05    0.10000E+01    0.39689E+04    0.17415E-40    0.84411E-48    0.37608E-45
+    1    4    0.12275E-05    0.10000E+01    0.32008E+04    0.40265E-38    0.48351E-45    0.71538E-43
+    1    4    0.12275E-05    0.10000E+01    0.25813E+04    0.19083E-29    0.59649E-36    0.24168E-34
+    1    4    0.12275E-05    0.10000E+01    0.20817E+04    0.28724E-13    0.29715E-19    0.32985E-18
+    1    4    0.12275E-05    0.10000E+01    0.16788E+04    0.78821E-08    0.27726E-13    0.89705E-13
+    1    4    0.12275E-05    0.10000E+01    0.13538E+04    0.12269E-07    0.92572E-13    0.11500E-12
+    1    4    0.12275E-05    0.10000E+01    0.10918E+04    0.19927E-07    0.31029E-12    0.15313E-12
+    1    4    0.12275E-05    0.10000E+01    0.88049E+03    0.33335E-07    0.10496E-11    0.21068E-12
+    1    4    0.12275E-05    0.10000E+01    0.71007E+03    0.56909E-07    0.35843E-11    0.29709E-12
+    1    4    0.12275E-05    0.10000E+01    0.57264E+03    0.98601E-07    0.12185E-10    0.42614E-12
+    1    4    0.12275E-05    0.10000E+01    0.46180E+03    0.17264E-06    0.39781E-10    0.61870E-12
+    1    4    0.12275E-05    0.10000E+01    0.37242E+03    0.30310E-06    0.11911E-09    0.90614E-12
+    1    4    0.12275E-05    0.10000E+01    0.30034E+03    0.52615E-06    0.31600E-09    0.13319E-11
+    1    4    0.12275E-05    0.10000E+01    0.24221E+03    0.88701E-06    0.73300E-09    0.19472E-11
+    1    4    0.12275E-05    0.10000E+01    0.19533E+03    0.13599E-05    0.13877E-08    0.26920E-11
+    1    4    0.12275E-05    0.10000E+01    0.15752E+03    0.13599E-05    0.13877E-08    0.26920E-11
+    1    4    0.21419E-05    0.10000E+01    0.80645E+05    0.38261E-52    0.28669E-63    0.68893E-57
+    1    4    0.21419E-05    0.10000E+01    0.65036E+05    0.32408E-51    0.45570E-62    0.58445E-56
+    1    4    0.21419E-05    0.10000E+01    0.52449E+05    0.27566E-50    0.61298E-61    0.49781E-55
+    1    4    0.21419E-05    0.10000E+01    0.42297E+05    0.20758E-49    0.83379E-60    0.37580E-54
+    1    4    0.21419E-05    0.10000E+01    0.34111E+05    0.14989E-48    0.11462E-58    0.27253E-53
+    1    4    0.21419E-05    0.10000E+01    0.27509E+05    0.10779E-47    0.15565E-57    0.19734E-52
+    1    4    0.21419E-05    0.10000E+01    0.22184E+05    0.76960E-47    0.20766E-56    0.14242E-51
+    1    4    0.21419E-05    0.10000E+01    0.17891E+05    0.54169E-46    0.27201E-55    0.10191E-50
+    1    4    0.21419E-05    0.10000E+01    0.14428E+05    0.37488E-45    0.35091E-54    0.72184E-50
+    1    4    0.21419E-05    0.10000E+01    0.11635E+05    0.25534E-44    0.44617E-53    0.50661E-49
+    1    4    0.21419E-05    0.10000E+01    0.93834E+04    0.17130E-43    0.55647E-52    0.35232E-48
+    1    4    0.21419E-05    0.10000E+01    0.75673E+04    0.11289E-42    0.67814E-51    0.24197E-47
+    1    4    0.21419E-05    0.10000E+01    0.61026E+04    0.72899E-42    0.81609E-50    0.16296E-46
+    1    4    0.21419E-05    0.10000E+01    0.49215E+04    0.46464E-41    0.10190E-48    0.10656E-45
+    1    4    0.21419E-05    0.10000E+01    0.39689E+04    0.30332E-40    0.14623E-47    0.66883E-45
+    1    4    0.21419E-05    0.10000E+01    0.32008E+04    0.69853E-38    0.83340E-45    0.12726E-42
+    1    4    0.21419E-05    0.10000E+01    0.25813E+04    0.32969E-29    0.10258E-35    0.42932E-34
+    1    4    0.21419E-05    0.10000E+01    0.20817E+04    0.49611E-13    0.51037E-19    0.58471E-18
+    1    4    0.21419E-05    0.10000E+01    0.16788E+04    0.13614E-07    0.47492E-13    0.15892E-12
+    1    4    0.21419E-05    0.10000E+01    0.13538E+04    0.21144E-07    0.15839E-12    0.20353E-12
+    1    4    0.21419E-05    0.10000E+01    0.10918E+04    0.34273E-07    0.53032E-12    0.27069E-12
+    1    4    0.21419E-05    0.10000E+01    0.88049E+03    0.57235E-07    0.17921E-11    0.37202E-12
+    1    4    0.21419E-05    0.10000E+01    0.71007E+03    0.97561E-07    0.61152E-11    0.52404E-12
+    1    4    0.21419E-05    0.10000E+01    0.57264E+03    0.16881E-06    0.20776E-10    0.75094E-12
+    1    4    0.21419E-05    0.10000E+01    0.46180E+03    0.29521E-06    0.67801E-10    0.10892E-11
+    1    4    0.21419E-05    0.10000E+01    0.37242E+03    0.51780E-06    0.20295E-09    0.15937E-11
+    1    4    0.21419E-05    0.10000E+01    0.30034E+03    0.89818E-06    0.53836E-09    0.23402E-11
+    1    4    0.21419E-05    0.10000E+01    0.24221E+03    0.15133E-05    0.12487E-08    0.34179E-11
+    1    4    0.21419E-05    0.10000E+01    0.19533E+03    0.23193E-05    0.23639E-08    0.47218E-11
+    1    4    0.21419E-05    0.10000E+01    0.15752E+03    0.23193E-05    0.23639E-08    0.47218E-11
+    1    4    0.37375E-05    0.10000E+01    0.80645E+05    0.66764E-52    0.50026E-63    0.12021E-56
+    1    4    0.37375E-05    0.10000E+01    0.65036E+05    0.56549E-51    0.79516E-62    0.10198E-55
+    1    4    0.37375E-05    0.10000E+01    0.52449E+05    0.48101E-50    0.10696E-60    0.86865E-55
+    1    4    0.37375E-05    0.10000E+01    0.42297E+05    0.36222E-49    0.14549E-59    0.65575E-54
+    1    4    0.37375E-05    0.10000E+01    0.34111E+05    0.26155E-48    0.20000E-58    0.47555E-53
+    1    4    0.37375E-05    0.10000E+01    0.27509E+05    0.18809E-47    0.27160E-57    0.34434E-52
+    1    4    0.37375E-05    0.10000E+01    0.22184E+05    0.13429E-46    0.36236E-56    0.24851E-51
+    1    4    0.37375E-05    0.10000E+01    0.17891E+05    0.94522E-46    0.47465E-55    0.17782E-50
+    1    4    0.37375E-05    0.10000E+01    0.14428E+05    0.65414E-45    0.61232E-54    0.12596E-49
+    1    4    0.37375E-05    0.10000E+01    0.11635E+05    0.44555E-44    0.77853E-53    0.88401E-49
+    1    4    0.37375E-05    0.10000E+01    0.93834E+04    0.29890E-43    0.97101E-52    0.61477E-48
+    1    4    0.37375E-05    0.10000E+01    0.75673E+04    0.19699E-42    0.11833E-50    0.42222E-47
+    1    4    0.37375E-05    0.10000E+01    0.61026E+04    0.12720E-41    0.14240E-49    0.28436E-46
+    1    4    0.37375E-05    0.10000E+01    0.49215E+04    0.81076E-41    0.17780E-48    0.18593E-45
+    1    4    0.37375E-05    0.10000E+01    0.39689E+04    0.52927E-40    0.25516E-47    0.11671E-44
+    1    4    0.37375E-05    0.10000E+01    0.32008E+04    0.12189E-37    0.14542E-44    0.22206E-42
+    1    4    0.37375E-05    0.10000E+01    0.25813E+04    0.57529E-29    0.17900E-35    0.74914E-34
+    1    4    0.37375E-05    0.10000E+01    0.20817E+04    0.86569E-13    0.89056E-19    0.10203E-17
+    1    4    0.37375E-05    0.10000E+01    0.16788E+04    0.23755E-07    0.82870E-13    0.27731E-12
+    1    4    0.37375E-05    0.10000E+01    0.13538E+04    0.36894E-07    0.27638E-12    0.35515E-12
+    1    4    0.37375E-05    0.10000E+01    0.10918E+04    0.59804E-07    0.92537E-12    0.47234E-12
+    1    4    0.37375E-05    0.10000E+01    0.88049E+03    0.99872E-07    0.31271E-11    0.64915E-12
+    1    4    0.37375E-05    0.10000E+01    0.71007E+03    0.17024E-06    0.10671E-10    0.91442E-12
+    1    4    0.37375E-05    0.10000E+01    0.57264E+03    0.29456E-06    0.36253E-10    0.13103E-11
+    1    4    0.37375E-05    0.10000E+01    0.46180E+03    0.51513E-06    0.11831E-09    0.19006E-11
+    1    4    0.37375E-05    0.10000E+01    0.37242E+03    0.90353E-06    0.35413E-09    0.27808E-11
+    1    4    0.37375E-05    0.10000E+01    0.30034E+03    0.15673E-05    0.93941E-09    0.40835E-11
+    1    4    0.37375E-05    0.10000E+01    0.24221E+03    0.26407E-05    0.21788E-08    0.59640E-11
+    1    4    0.37375E-05    0.10000E+01    0.19533E+03    0.40470E-05    0.41248E-08    0.82392E-11
+    1    4    0.37375E-05    0.10000E+01    0.15752E+03    0.40470E-05    0.41248E-08    0.82392E-11
+    1    4    0.65217E-05    0.10000E+01    0.80645E+05    0.11650E-51    0.87292E-63    0.20977E-56
+    1    4    0.65217E-05    0.10000E+01    0.65036E+05    0.98675E-51    0.13875E-61    0.17795E-55
+    1    4    0.65217E-05    0.10000E+01    0.52449E+05    0.83933E-50    0.18664E-60    0.15157E-54
+    1    4    0.65217E-05    0.10000E+01    0.42297E+05    0.63205E-49    0.25387E-59    0.11442E-53
+    1    4    0.65217E-05    0.10000E+01    0.34111E+05    0.45640E-48    0.34898E-58    0.82981E-53
+    1    4    0.65217E-05    0.10000E+01    0.27509E+05    0.32821E-47    0.47392E-57    0.60085E-52
+    1    4    0.65217E-05    0.10000E+01    0.22184E+05    0.23433E-46    0.63229E-56    0.43364E-51
+    1    4    0.65217E-05    0.10000E+01    0.17891E+05    0.16494E-45    0.82823E-55    0.31029E-50
+    1    4    0.65217E-05    0.10000E+01    0.14428E+05    0.11414E-44    0.10685E-53    0.21979E-49
+    1    4    0.65217E-05    0.10000E+01    0.11635E+05    0.77746E-44    0.13585E-52    0.15425E-48
+    1    4    0.65217E-05    0.10000E+01    0.93834E+04    0.52156E-43    0.16944E-51    0.10727E-47
+    1    4    0.65217E-05    0.10000E+01    0.75673E+04    0.34374E-42    0.20648E-50    0.73674E-47
+    1    4    0.65217E-05    0.10000E+01    0.61026E+04    0.22196E-41    0.24848E-49    0.49619E-46
+    1    4    0.65217E-05    0.10000E+01    0.49215E+04    0.14147E-40    0.31025E-48    0.32444E-45
+    1    4    0.65217E-05    0.10000E+01    0.39689E+04    0.92354E-40    0.44524E-47    0.20365E-44
+    1    4    0.65217E-05    0.10000E+01    0.32008E+04    0.21269E-37    0.25375E-44    0.38749E-42
+    1    4    0.65217E-05    0.10000E+01    0.25813E+04    0.10039E-28    0.31234E-35    0.13072E-33
+    1    4    0.65217E-05    0.10000E+01    0.20817E+04    0.15106E-12    0.15540E-18    0.17803E-17
+    1    4    0.65217E-05    0.10000E+01    0.16788E+04    0.41451E-07    0.14460E-12    0.48388E-12
+    1    4    0.65217E-05    0.10000E+01    0.13538E+04    0.64378E-07    0.48226E-12    0.61971E-12
+    1    4    0.65217E-05    0.10000E+01    0.10918E+04    0.10435E-06    0.16147E-11    0.82420E-12
+    1    4    0.65217E-05    0.10000E+01    0.88049E+03    0.17427E-06    0.54567E-11    0.11327E-11
+    1    4    0.65217E-05    0.10000E+01    0.71007E+03    0.29705E-06    0.18620E-10    0.15956E-11
+    1    4    0.65217E-05    0.10000E+01    0.57264E+03    0.51399E-06    0.63260E-10    0.22865E-11
+    1    4    0.65217E-05    0.10000E+01    0.46180E+03    0.89887E-06    0.20644E-09    0.33165E-11
+    1    4    0.65217E-05    0.10000E+01    0.37242E+03    0.15766E-05    0.61794E-09    0.48524E-11
+    1    4    0.65217E-05    0.10000E+01    0.30034E+03    0.27348E-05    0.16392E-08    0.71254E-11
+    1    4    0.65217E-05    0.10000E+01    0.24221E+03    0.46078E-05    0.38019E-08    0.10407E-10
+    1    4    0.65217E-05    0.10000E+01    0.19533E+03    0.70617E-05    0.71976E-08    0.14377E-10
+    1    4    0.65217E-05    0.10000E+01    0.15752E+03    0.70617E-05    0.71976E-08    0.14377E-10
+    1    4    0.11380E-04    0.10000E+01    0.80645E+05    0.20328E-51    0.15232E-62    0.36603E-56
+    1    4    0.11380E-04    0.10000E+01    0.65036E+05    0.17218E-50    0.24211E-61    0.31052E-55
+    1    4    0.11380E-04    0.10000E+01    0.52449E+05    0.14646E-49    0.32568E-60    0.26449E-54
+    1    4    0.11380E-04    0.10000E+01    0.42297E+05    0.11029E-48    0.44299E-59    0.19966E-53
+    1    4    0.11380E-04    0.10000E+01    0.34111E+05    0.79638E-48    0.60896E-58    0.14480E-52
+    1    4    0.11380E-04    0.10000E+01    0.27509E+05    0.57270E-47    0.82697E-57    0.10484E-51
+    1    4    0.11380E-04    0.10000E+01    0.22184E+05    0.40889E-46    0.11033E-55    0.75668E-51
+    1    4    0.11380E-04    0.10000E+01    0.17891E+05    0.28780E-45    0.14452E-54    0.54143E-50
+    1    4    0.11380E-04    0.10000E+01    0.14428E+05    0.19917E-44    0.18644E-53    0.38352E-49
+    1    4    0.11380E-04    0.10000E+01    0.11635E+05    0.13566E-43    0.23705E-52    0.26916E-48
+    1    4    0.11380E-04    0.10000E+01    0.93834E+04    0.91010E-43    0.29565E-51    0.18719E-47
+    1    4    0.11380E-04    0.10000E+01    0.75673E+04    0.59981E-42    0.36030E-50    0.12856E-46
+    1    4    0.11380E-04    0.10000E+01    0.61026E+04    0.38731E-41    0.43359E-49    0.86581E-46
+    1    4    0.11380E-04    0.10000E+01    0.49215E+04    0.24686E-40    0.54137E-48    0.56613E-45
+    1    4    0.11380E-04    0.10000E+01    0.39689E+04    0.16115E-39    0.77691E-47    0.35535E-44
+    1    4    0.11380E-04    0.10000E+01    0.32008E+04    0.37113E-37    0.44278E-44    0.67614E-42
+    1    4    0.11380E-04    0.10000E+01    0.25813E+04    0.17517E-28    0.54501E-35    0.22810E-33
+    1    4    0.11380E-04    0.10000E+01    0.20817E+04    0.26359E-12    0.27116E-18    0.31066E-17
+    1    4    0.11380E-04    0.10000E+01    0.16788E+04    0.72329E-07    0.25232E-12    0.84435E-12
+    1    4    0.11380E-04    0.10000E+01    0.13538E+04    0.11234E-06    0.84152E-12    0.10814E-11
+    1    4    0.11380E-04    0.10000E+01    0.10918E+04    0.18209E-06    0.28176E-11    0.14382E-11
+    1    4    0.11380E-04    0.10000E+01    0.88049E+03    0.30409E-06    0.95216E-11    0.19765E-11
+    1    4    0.11380E-04    0.10000E+01    0.71007E+03    0.51834E-06    0.32490E-10    0.27842E-11
+    1    4    0.11380E-04    0.10000E+01    0.57264E+03    0.89688E-06    0.11039E-09    0.39898E-11
+    1    4    0.11380E-04    0.10000E+01    0.46180E+03    0.15685E-05    0.36023E-09    0.57870E-11
+    1    4    0.11380E-04    0.10000E+01    0.37242E+03    0.27511E-05    0.10783E-08    0.84672E-11
+    1    4    0.11380E-04    0.10000E+01    0.30034E+03    0.47720E-05    0.28603E-08    0.12433E-10
+    1    4    0.11380E-04    0.10000E+01    0.24221E+03    0.80403E-05    0.66342E-08    0.18159E-10
+    1    4    0.11380E-04    0.10000E+01    0.19533E+03    0.12322E-04    0.12559E-07    0.25087E-10
+    1    4    0.11380E-04    0.10000E+01    0.15752E+03    0.12322E-04    0.12559E-07    0.25087E-10
+    1    4    0.19857E-04    0.10000E+01    0.80645E+05    0.35472E-51    0.26579E-62    0.63870E-56
+    1    4    0.19857E-04    0.10000E+01    0.65036E+05    0.30045E-50    0.42247E-61    0.54184E-55
+    1    4    0.19857E-04    0.10000E+01    0.52449E+05    0.25556E-49    0.56829E-60    0.46152E-54
+    1    4    0.19857E-04    0.10000E+01    0.42297E+05    0.19245E-48    0.77299E-59    0.34840E-53
+    1    4    0.19857E-04    0.10000E+01    0.34111E+05    0.13896E-47    0.10626E-57    0.25266E-52
+    1    4    0.19857E-04    0.10000E+01    0.27509E+05    0.99933E-47    0.14430E-56    0.18295E-51
+    1    4    0.19857E-04    0.10000E+01    0.22184E+05    0.71349E-46    0.19252E-55    0.13204E-50
+    1    4    0.19857E-04    0.10000E+01    0.17891E+05    0.50220E-45    0.25218E-54    0.94477E-50
+    1    4    0.19857E-04    0.10000E+01    0.14428E+05    0.34755E-44    0.32532E-53    0.66921E-49
+    1    4    0.19857E-04    0.10000E+01    0.11635E+05    0.23672E-43    0.41364E-52    0.46968E-48
+    1    4    0.19857E-04    0.10000E+01    0.93834E+04    0.15881E-42    0.51590E-51    0.32663E-47
+    1    4    0.19857E-04    0.10000E+01    0.75673E+04    0.10466E-41    0.62870E-50    0.22432E-46
+    1    4    0.19857E-04    0.10000E+01    0.61026E+04    0.67584E-41    0.75659E-49    0.15108E-45
+    1    4    0.19857E-04    0.10000E+01    0.49215E+04    0.43076E-40    0.94466E-48    0.98786E-45
+    1    4    0.19857E-04    0.10000E+01    0.39689E+04    0.28120E-39    0.13557E-46    0.62007E-44
+    1    4    0.19857E-04    0.10000E+01    0.32008E+04    0.64760E-37    0.77263E-44    0.11798E-41
+    1    4    0.19857E-04    0.10000E+01    0.25813E+04    0.30565E-28    0.95101E-35    0.39802E-33
+    1    4    0.19857E-04    0.10000E+01    0.20817E+04    0.45994E-12    0.47316E-18    0.54208E-17
+    1    4    0.19857E-04    0.10000E+01    0.16788E+04    0.12621E-06    0.44029E-12    0.14733E-11
+    1    4    0.19857E-04    0.10000E+01    0.13538E+04    0.19602E-06    0.14684E-11    0.18869E-11
+    1    4    0.19857E-04    0.10000E+01    0.10918E+04    0.31774E-06    0.49165E-11    0.25095E-11
+    1    4    0.19857E-04    0.10000E+01    0.88049E+03    0.53062E-06    0.16615E-10    0.34489E-11
+    1    4    0.19857E-04    0.10000E+01    0.71007E+03    0.90447E-06    0.56694E-10    0.48583E-11
+    1    4    0.19857E-04    0.10000E+01    0.57264E+03    0.15650E-05    0.19262E-09    0.69619E-11
+    1    4    0.19857E-04    0.10000E+01    0.46180E+03    0.27369E-05    0.62858E-09    0.10098E-10
+    1    4    0.19857E-04    0.10000E+01    0.37242E+03    0.48005E-05    0.18815E-08    0.14775E-10
+    1    4    0.19857E-04    0.10000E+01    0.30034E+03    0.83269E-05    0.49911E-08    0.21696E-10
+    1    4    0.19857E-04    0.10000E+01    0.24221E+03    0.14030E-04    0.11576E-07    0.31687E-10
+    1    4    0.19857E-04    0.10000E+01    0.19533E+03    0.21502E-04    0.21915E-07    0.43775E-10
+    1    4    0.19857E-04    0.10000E+01    0.15752E+03    0.21502E-04    0.21915E-07    0.43775E-10
+    1    4    0.34650E-04    0.10000E+01    0.80645E+05    0.61896E-51    0.46378E-62    0.11145E-55
+    1    4    0.34650E-04    0.10000E+01    0.65036E+05    0.52426E-50    0.73719E-61    0.94548E-55
+    1    4    0.34650E-04    0.10000E+01    0.52449E+05    0.44594E-49    0.99163E-60    0.80532E-54
+    1    4    0.34650E-04    0.10000E+01    0.42297E+05    0.33581E-48    0.13488E-58    0.60793E-53
+    1    4    0.34650E-04    0.10000E+01    0.34111E+05    0.24248E-47    0.18542E-57    0.44088E-52
+    1    4    0.34650E-04    0.10000E+01    0.27509E+05    0.17438E-46    0.25180E-56    0.31923E-51
+    1    4    0.34650E-04    0.10000E+01    0.22184E+05    0.12450E-45    0.33594E-55    0.23039E-50
+    1    4    0.34650E-04    0.10000E+01    0.17891E+05    0.87630E-45    0.44004E-54    0.16486E-49
+    1    4    0.34650E-04    0.10000E+01    0.14428E+05    0.60645E-44    0.56767E-53    0.11677E-48
+    1    4    0.34650E-04    0.10000E+01    0.11635E+05    0.41307E-43    0.72177E-52    0.81956E-48
+    1    4    0.34650E-04    0.10000E+01    0.93834E+04    0.27711E-42    0.90021E-51    0.56995E-47
+    1    4    0.34650E-04    0.10000E+01    0.75673E+04    0.18263E-41    0.10970E-49    0.39143E-46
+    1    4    0.34650E-04    0.10000E+01    0.61026E+04    0.11793E-40    0.13202E-48    0.26362E-45
+    1    4    0.34650E-04    0.10000E+01    0.49215E+04    0.75165E-40    0.16484E-47    0.17238E-44
+    1    4    0.34650E-04    0.10000E+01    0.39689E+04    0.49068E-39    0.23656E-46    0.10820E-43
+    1    4    0.34650E-04    0.10000E+01    0.32008E+04    0.11300E-36    0.13482E-43    0.20587E-41
+    1    4    0.34650E-04    0.10000E+01    0.25813E+04    0.53335E-28    0.16594E-34    0.69452E-33
+    1    4    0.34650E-04    0.10000E+01    0.20817E+04    0.80257E-12    0.82563E-18    0.94590E-17
+    1    4    0.34650E-04    0.10000E+01    0.16788E+04    0.22023E-06    0.76828E-12    0.25709E-11
+    1    4    0.34650E-04    0.10000E+01    0.13538E+04    0.34204E-06    0.25623E-11    0.32925E-11
+    1    4    0.34650E-04    0.10000E+01    0.10918E+04    0.55444E-06    0.85790E-11    0.43790E-11
+    1    4    0.34650E-04    0.10000E+01    0.88049E+03    0.92591E-06    0.28991E-10    0.60182E-11
+    1    4    0.34650E-04    0.10000E+01    0.71007E+03    0.15783E-05    0.98927E-10    0.84775E-11
+    1    4    0.34650E-04    0.10000E+01    0.57264E+03    0.27308E-05    0.33610E-09    0.12148E-10
+    1    4    0.34650E-04    0.10000E+01    0.46180E+03    0.47757E-05    0.10968E-08    0.17620E-10
+    1    4    0.34650E-04    0.10000E+01    0.37242E+03    0.83766E-05    0.32831E-08    0.25781E-10
+    1    4    0.34650E-04    0.10000E+01    0.30034E+03    0.14530E-04    0.87091E-08    0.37857E-10
+    1    4    0.34650E-04    0.10000E+01    0.24221E+03    0.24481E-04    0.20200E-07    0.55292E-10
+    1    4    0.34650E-04    0.10000E+01    0.19533E+03    0.37519E-04    0.38241E-07    0.76385E-10
+    1    4    0.34650E-04    0.10000E+01    0.15752E+03    0.37519E-04    0.38241E-07    0.76385E-10
+    1    4    0.60462E-04    0.10000E+01    0.80645E+05    0.10800E-50    0.80927E-62    0.19447E-55
+    1    4    0.60462E-04    0.10000E+01    0.65036E+05    0.91481E-50    0.12863E-60    0.16498E-54
+    1    4    0.60462E-04    0.10000E+01    0.52449E+05    0.77813E-49    0.17303E-59    0.14052E-53
+    1    4    0.60462E-04    0.10000E+01    0.42297E+05    0.58597E-48    0.23536E-58    0.10608E-52
+    1    4    0.60462E-04    0.10000E+01    0.34111E+05    0.42312E-47    0.32354E-57    0.76931E-52
+    1    4    0.60462E-04    0.10000E+01    0.27509E+05    0.30428E-46    0.43937E-56    0.55704E-51
+    1    4    0.60462E-04    0.10000E+01    0.22184E+05    0.21724E-45    0.58619E-55    0.40202E-50
+    1    4    0.60462E-04    0.10000E+01    0.17891E+05    0.15291E-44    0.76784E-54    0.28766E-49
+    1    4    0.60462E-04    0.10000E+01    0.14428E+05    0.10582E-43    0.99055E-53    0.20376E-48
+    1    4    0.60462E-04    0.10000E+01    0.11635E+05    0.72078E-43    0.12594E-51    0.14301E-47
+    1    4    0.60462E-04    0.10000E+01    0.93834E+04    0.48354E-42    0.15708E-50    0.99453E-47
+    1    4    0.60462E-04    0.10000E+01    0.75673E+04    0.31868E-41    0.19143E-49    0.68303E-46
+    1    4    0.60462E-04    0.10000E+01    0.61026E+04    0.20578E-40    0.23037E-48    0.46001E-45
+    1    4    0.60462E-04    0.10000E+01    0.49215E+04    0.13116E-39    0.28763E-47    0.30079E-44
+    1    4    0.60462E-04    0.10000E+01    0.39689E+04    0.85620E-39    0.41278E-46    0.18880E-43
+    1    4    0.60462E-04    0.10000E+01    0.32008E+04    0.19718E-36    0.23525E-43    0.35924E-41
+    1    4    0.60462E-04    0.10000E+01    0.25813E+04    0.93066E-28    0.28956E-34    0.12119E-32
+    1    4    0.60462E-04    0.10000E+01    0.20817E+04    0.14004E-11    0.14407E-17    0.16505E-16
+    1    4    0.60462E-04    0.10000E+01    0.16788E+04    0.38429E-06    0.13406E-11    0.44860E-11
+    1    4    0.60462E-04    0.10000E+01    0.13538E+04    0.59685E-06    0.44710E-11    0.57452E-11
+    1    4    0.60462E-04    0.10000E+01    0.10918E+04    0.96746E-06    0.14970E-10    0.76411E-11
+    1    4    0.60462E-04    0.10000E+01    0.88049E+03    0.16156E-05    0.50588E-10    0.10501E-10
+    1    4    0.60462E-04    0.10000E+01    0.71007E+03    0.27540E-05    0.17262E-09    0.14793E-10
+    1    4    0.60462E-04    0.10000E+01    0.57264E+03    0.47651E-05    0.58648E-09    0.21198E-10
+    1    4    0.60462E-04    0.10000E+01    0.46180E+03    0.83333E-05    0.19139E-08    0.30747E-10
+    1    4    0.60462E-04    0.10000E+01    0.37242E+03    0.14617E-04    0.57289E-08    0.44986E-10
+    1    4    0.60462E-04    0.10000E+01    0.30034E+03    0.25354E-04    0.15197E-07    0.66059E-10
+    1    4    0.60462E-04    0.10000E+01    0.24221E+03    0.42718E-04    0.35247E-07    0.96481E-10
+    1    4    0.60462E-04    0.10000E+01    0.19533E+03    0.65468E-04    0.66728E-07    0.13329E-09
+    1    4    0.60462E-04    0.10000E+01    0.15752E+03    0.65468E-04    0.66728E-07    0.13329E-09
+    1    4    0.10550E-03    0.10000E+01    0.80645E+05    0.18846E-50    0.14121E-61    0.33934E-55
+    1    4    0.10550E-03    0.10000E+01    0.65036E+05    0.15963E-49    0.22446E-60    0.28788E-54
+    1    4    0.10550E-03    0.10000E+01    0.52449E+05    0.13578E-48    0.30193E-59    0.24520E-53
+    1    4    0.10550E-03    0.10000E+01    0.42297E+05    0.10225E-47    0.41069E-58    0.18510E-52
+    1    4    0.10550E-03    0.10000E+01    0.34111E+05    0.73832E-47    0.56456E-57    0.13424E-51
+    1    4    0.10550E-03    0.10000E+01    0.27509E+05    0.53094E-46    0.76668E-56    0.97200E-51
+    1    4    0.10550E-03    0.10000E+01    0.22184E+05    0.37908E-45    0.10229E-54    0.70151E-50
+    1    4    0.10550E-03    0.10000E+01    0.17891E+05    0.26682E-44    0.13398E-53    0.50196E-49
+    1    4    0.10550E-03    0.10000E+01    0.14428E+05    0.18465E-43    0.17285E-52    0.35555E-48
+    1    4    0.10550E-03    0.10000E+01    0.11635E+05    0.12577E-42    0.21977E-51    0.24954E-47
+    1    4    0.10550E-03    0.10000E+01    0.93834E+04    0.84374E-42    0.27410E-50    0.17354E-46
+    1    4    0.10550E-03    0.10000E+01    0.75673E+04    0.55608E-41    0.33403E-49    0.11918E-45
+    1    4    0.10550E-03    0.10000E+01    0.61026E+04    0.35907E-40    0.40198E-48    0.80269E-45
+    1    4    0.10550E-03    0.10000E+01    0.49215E+04    0.22886E-39    0.50190E-47    0.52485E-44
+    1    4    0.10550E-03    0.10000E+01    0.39689E+04    0.14940E-38    0.72027E-46    0.32944E-43
+    1    4    0.10550E-03    0.10000E+01    0.32008E+04    0.34407E-36    0.41050E-43    0.62684E-41
+    1    4    0.10550E-03    0.10000E+01    0.25813E+04    0.16239E-27    0.50527E-34    0.21147E-32
+    1    4    0.10550E-03    0.10000E+01    0.20817E+04    0.24437E-11    0.25139E-17    0.28801E-16
+    1    4    0.10550E-03    0.10000E+01    0.16788E+04    0.67056E-06    0.23393E-11    0.78279E-11
+    1    4    0.10550E-03    0.10000E+01    0.13538E+04    0.10415E-05    0.78016E-11    0.10025E-10
+    1    4    0.10550E-03    0.10000E+01    0.10918E+04    0.16882E-05    0.26122E-10    0.13333E-10
+    1    4    0.10550E-03    0.10000E+01    0.88049E+03    0.28192E-05    0.88273E-10    0.18324E-10
+    1    4    0.10550E-03    0.10000E+01    0.71007E+03    0.48055E-05    0.30121E-09    0.25812E-10
+    1    4    0.10550E-03    0.10000E+01    0.57264E+03    0.83148E-05    0.10234E-08    0.36989E-10
+    1    4    0.10550E-03    0.10000E+01    0.46180E+03    0.14541E-04    0.33396E-08    0.53651E-10
+    1    4    0.10550E-03    0.10000E+01    0.37242E+03    0.25505E-04    0.99965E-08    0.78498E-10
+    1    4    0.10550E-03    0.10000E+01    0.30034E+03    0.44241E-04    0.26518E-07    0.11527E-09
+    1    4    0.10550E-03    0.10000E+01    0.24221E+03    0.74541E-04    0.61505E-07    0.16835E-09
+    1    4    0.10550E-03    0.10000E+01    0.19533E+03    0.11424E-03    0.11644E-06    0.23258E-09
+    1    4    0.10550E-03    0.10000E+01    0.15752E+03    0.11424E-03    0.11644E-06    0.23258E-09
+    1    4    0.18409E-03    0.10000E+01    0.80645E+05    0.32885E-50    0.24641E-61    0.59213E-55
+    1    4    0.18409E-03    0.10000E+01    0.65036E+05    0.27854E-49    0.39167E-60    0.50233E-54
+    1    4    0.18409E-03    0.10000E+01    0.52449E+05    0.23693E-48    0.52686E-59    0.42787E-53
+    1    4    0.18409E-03    0.10000E+01    0.42297E+05    0.17842E-47    0.71663E-58    0.32300E-52
+    1    4    0.18409E-03    0.10000E+01    0.34111E+05    0.12883E-46    0.98512E-57    0.23424E-51
+    1    4    0.18409E-03    0.10000E+01    0.27509E+05    0.92647E-46    0.13378E-55    0.16961E-50
+    1    4    0.18409E-03    0.10000E+01    0.22184E+05    0.66147E-45    0.17848E-54    0.12241E-49
+    1    4    0.18409E-03    0.10000E+01    0.17891E+05    0.46558E-44    0.23379E-53    0.87588E-49
+    1    4    0.18409E-03    0.10000E+01    0.14428E+05    0.32221E-43    0.30160E-52    0.62042E-48
+    1    4    0.18409E-03    0.10000E+01    0.11635E+05    0.21946E-42    0.38348E-51    0.43543E-47
+    1    4    0.18409E-03    0.10000E+01    0.93834E+04    0.14723E-41    0.47829E-50    0.30282E-46
+    1    4    0.18409E-03    0.10000E+01    0.75673E+04    0.97032E-41    0.58286E-49    0.20797E-45
+    1    4    0.18409E-03    0.10000E+01    0.61026E+04    0.62656E-40    0.70143E-48    0.14006E-44
+    1    4    0.18409E-03    0.10000E+01    0.49215E+04    0.39935E-39    0.87578E-47    0.91584E-44
+    1    4    0.18409E-03    0.10000E+01    0.39689E+04    0.26070E-38    0.12568E-45    0.57486E-43
+    1    4    0.18409E-03    0.10000E+01    0.32008E+04    0.60038E-36    0.71630E-43    0.10938E-40
+    1    4    0.18409E-03    0.10000E+01    0.25813E+04    0.28337E-27    0.88167E-34    0.36900E-32
+    1    4    0.18409E-03    0.10000E+01    0.20817E+04    0.42641E-11    0.43866E-17    0.50256E-16
+    1    4    0.18409E-03    0.10000E+01    0.16788E+04    0.11701E-05    0.40819E-11    0.13659E-10
+    1    4    0.18409E-03    0.10000E+01    0.13538E+04    0.18173E-05    0.13613E-10    0.17493E-10
+    1    4    0.18409E-03    0.10000E+01    0.10918E+04    0.29457E-05    0.45581E-10    0.23266E-10
+    1    4    0.18409E-03    0.10000E+01    0.88049E+03    0.49193E-05    0.15403E-09    0.31975E-10
+    1    4    0.18409E-03    0.10000E+01    0.71007E+03    0.83853E-05    0.52560E-09    0.45041E-10
+    1    4    0.18409E-03    0.10000E+01    0.57264E+03    0.14509E-04    0.17857E-08    0.64543E-10
+    1    4    0.18409E-03    0.10000E+01    0.46180E+03    0.25373E-04    0.58275E-08    0.93618E-10
+    1    4    0.18409E-03    0.10000E+01    0.37242E+03    0.44505E-04    0.17443E-07    0.13697E-09
+    1    4    0.18409E-03    0.10000E+01    0.30034E+03    0.77198E-04    0.46272E-07    0.20114E-09
+    1    4    0.18409E-03    0.10000E+01    0.24221E+03    0.13007E-03    0.10732E-06    0.29377E-09
+    1    4    0.18409E-03    0.10000E+01    0.19533E+03    0.19934E-03    0.20317E-06    0.40583E-09
+    1    4    0.18409E-03    0.10000E+01    0.15752E+03    0.19934E-03    0.20317E-06    0.40583E-09
+    1    4    0.32123E-03    0.10000E+01    0.80645E+05    0.57383E-50    0.42997E-61    0.10332E-54
+    1    4    0.32123E-03    0.10000E+01    0.65036E+05    0.48604E-49    0.68344E-60    0.87654E-54
+    1    4    0.32123E-03    0.10000E+01    0.52449E+05    0.41342E-48    0.91933E-59    0.74660E-53
+    1    4    0.32123E-03    0.10000E+01    0.42297E+05    0.31133E-47    0.12505E-57    0.56361E-52
+    1    4    0.32123E-03    0.10000E+01    0.34111E+05    0.22480E-46    0.17190E-56    0.40874E-51
+    1    4    0.32123E-03    0.10000E+01    0.27509E+05    0.16166E-45    0.23344E-55    0.29596E-50
+    1    4    0.32123E-03    0.10000E+01    0.22184E+05    0.11542E-44    0.31144E-54    0.21360E-49
+    1    4    0.32123E-03    0.10000E+01    0.17891E+05    0.81241E-44    0.40795E-53    0.15284E-48
+    1    4    0.32123E-03    0.10000E+01    0.14428E+05    0.56223E-43    0.52628E-52    0.10826E-47
+    1    4    0.32123E-03    0.10000E+01    0.11635E+05    0.38295E-42    0.66914E-51    0.75980E-47
+    1    4    0.32123E-03    0.10000E+01    0.93834E+04    0.25690E-41    0.83458E-50    0.52839E-46
+    1    4    0.32123E-03    0.10000E+01    0.75673E+04    0.16931E-40    0.10171E-48    0.36289E-45
+    1    4    0.32123E-03    0.10000E+01    0.61026E+04    0.10933E-39    0.12239E-47    0.24440E-44
+    1    4    0.32123E-03    0.10000E+01    0.49215E+04    0.69685E-39    0.15282E-46    0.15981E-43
+    1    4    0.32123E-03    0.10000E+01    0.39689E+04    0.45490E-38    0.21931E-45    0.10031E-42
+    1    4    0.32123E-03    0.10000E+01    0.32008E+04    0.10476E-35    0.12499E-42    0.19086E-40
+    1    4    0.32123E-03    0.10000E+01    0.25813E+04    0.49446E-27    0.15385E-33    0.64388E-32
+    1    4    0.32123E-03    0.10000E+01    0.20817E+04    0.74405E-11    0.76543E-17    0.87693E-16
+    1    4    0.32123E-03    0.10000E+01    0.16788E+04    0.20417E-05    0.71227E-11    0.23834E-10
+    1    4    0.32123E-03    0.10000E+01    0.13538E+04    0.31710E-05    0.23754E-10    0.30525E-10
+    1    4    0.32123E-03    0.10000E+01    0.10918E+04    0.51401E-05    0.79535E-10    0.40597E-10
+    1    4    0.32123E-03    0.10000E+01    0.88049E+03    0.85840E-05    0.26878E-09    0.55794E-10
+    1    4    0.32123E-03    0.10000E+01    0.71007E+03    0.14632E-04    0.91714E-09    0.78594E-10
+    1    4    0.32123E-03    0.10000E+01    0.57264E+03    0.25317E-04    0.31160E-08    0.11262E-09
+    1    4    0.32123E-03    0.10000E+01    0.46180E+03    0.44275E-04    0.10169E-07    0.16336E-09
+    1    4    0.32123E-03    0.10000E+01    0.37242E+03    0.77658E-04    0.30438E-07    0.23901E-09
+    1    4    0.32123E-03    0.10000E+01    0.30034E+03    0.13471E-03    0.80741E-07    0.35097E-09
+    1    4    0.32123E-03    0.10000E+01    0.24221E+03    0.22696E-03    0.18727E-06    0.51261E-09
+    1    4    0.32123E-03    0.10000E+01    0.19533E+03    0.34783E-03    0.35453E-06    0.70815E-09
+    1    4    0.32123E-03    0.10000E+01    0.15752E+03    0.34783E-03    0.35453E-06    0.70815E-09
+    2    1    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.45191E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    1    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.78855E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    1    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.13760E-07    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    1    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.24010E-07    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    2    1    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.41896E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    2    1    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.73106E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    2    1    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.12757E-06    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    2    1    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.22259E-06    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    2    1    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.38841E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    2    1    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.67776E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    2    1    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.11826E-05    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    2    1    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.20636E-05    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    2    1    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.36009E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    2    1    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.62834E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    2    1    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.10964E-04    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    2    1    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.19132E-04    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    2    1    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.33384E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    2    1    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.58253E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    2    1    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.10165E-03    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    2    1    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.17737E-03    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    2    1    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53957E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.30950E-03    0.19496E+06    0.99447E-26    0.48760E-10    0.50499E-04    0.88379E+03
+    2    1    0.54572E-10    0.10000E+01    0.74090E-01    0.13935E+00    0.11222E-09    0.65380E-11    0.40383E-04    0.29228E-04    0.98516E+04    0.54006E-03    0.15940E+06    0.27009E-25    0.58026E-09    0.60483E-04    0.85041E+03
+    2    1    0.95225E-10    0.10000E+01    0.11736E+00    0.19749E+00    0.21140E-09    0.50996E-10    0.44004E-04    0.38038E-04    0.17190E+05    0.94236E-03    0.12765E+06    0.72480E-25    0.43989E-08    0.73406E-04    0.78192E+03
+    2    1    0.16616E-09    0.10000E+01    0.18179E+00    0.26431E+00    0.32753E-09    0.26583E-09    0.44528E-04    0.48903E-04    0.29996E+05    0.16444E-02    0.99467E+05    0.19955E-24    0.21856E-07    0.91697E-04    0.67141E+03
+    2    1    0.28994E-09    0.10000E+01    0.25961E+00    0.33496E+00    0.47703E-09    0.94192E-09    0.43515E-04    0.57767E-04    0.52341E+05    0.28693E-02    0.75619E+05    0.57623E-24    0.71447E-07    0.11865E-03    0.53386E+03
+    2    1    0.50593E-09    0.10000E+01    0.33900E+00    0.40891E+00    0.78184E-09    0.24625E-08    0.45608E-04    0.61912E-04    0.91333E+05    0.50068E-02    0.56747E+05    0.17224E-23    0.16529E-06    0.15713E-03    0.40140E+03
+    2    1    0.88282E-09    0.10000E+01    0.41762E+00    0.48781E+00    0.14159E-08    0.54449E-08    0.54182E-04    0.63271E-04    0.15937E+06    0.87366E-02    0.42418E+05    0.52150E-23    0.31202E-06    0.20988E-03    0.29419E+03
+    2    1    0.15405E-08    0.10000E+01    0.36333E+00    0.69413E+00    0.73763E-08    0.13444E-07    0.63796E-04    0.63687E-04    0.81842E+05    0.10022E-01    0.66266E+04    0.47987E-22    0.49383E-06    0.46540E-03    0.16320E+03
+    2    1    0.26880E-08    0.10000E+01    0.41493E+00    0.79920E+00    0.14413E-07    0.26952E-07    0.78612E-04    0.64477E-04    0.11884E+06    0.16326E-01    0.43556E+04    0.16801E-21    0.82043E-06    0.66658E-03    0.11507E+03
+    2    1    0.46905E-08    0.10000E+01    0.48925E+00    0.88639E+00    0.25829E-07    0.51969E-07    0.10150E-03    0.65033E-04    0.20736E+06    0.28487E-01    0.32516E+04    0.51055E-21    0.13585E-05    0.89233E-03    0.84398E+02
+    2    1    0.81846E-08    0.10000E+01    0.56673E+00    0.97193E+00    0.45706E-07    0.98963E-07    0.13297E-03    0.65496E-04    0.36184E+06    0.49709E-01    0.24275E+04    0.15520E-20    0.22272E-05    0.11950E-02    0.61636E+02
+    2    1    0.14282E-07    0.10000E+01    0.64674E+00    0.10550E+01    0.79653E-07    0.18646E-06    0.17564E-03    0.65920E-04    0.63138E+06    0.86738E-01    0.18098E+04    0.47302E-20    0.36228E-05    0.16025E-02    0.44825E+02
+    2    1    0.24920E-07    0.10000E+01    0.72758E+00    0.11339E+01    0.13744E-06    0.34778E-06    0.23364E-03    0.66323E-04    0.11017E+07    0.15135E+00    0.13511E+04    0.14383E-19    0.58583E-05    0.21465E-02    0.32588E+02
+    2    1    0.43485E-07    0.10000E+01    0.80896E+00    0.12086E+01    0.23376E-06    0.64324E-06    0.31151E-03    0.66721E-04    0.19224E+07    0.26410E+00    0.10073E+04    0.43840E-19    0.94208E-05    0.28789E-02    0.23633E+02
+    2    1    0.75878E-07    0.10000E+01    0.88920E+00    0.12781E+01    0.39425E-06    0.11802E-05    0.41669E-03    0.67115E-04    0.33546E+07    0.46084E+00    0.75202E+03    0.13322E-18    0.15088E-04    0.38558E-02    0.17152E+02
+    2    1    0.13240E-06    0.10000E+01    0.96812E+00    0.13425E+01    0.65574E-06    0.21493E-05    0.55729E-03    0.67510E-04    0.58535E+07    0.80414E+00    0.56068E+03    0.40205E-18    0.24049E-04    0.51577E-02    0.12434E+02
+    2    1    0.23103E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.15703E-05    0.38017E-05    0.87654E-03    0.67662E-04    0.10214E+08    0.14032E+01    0.50000E+03    0.86013E-18    0.40441E-04    0.57605E-02    0.10978E+02
+    2    1    0.40314E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.47812E-05    0.66338E-05    0.15295E-02    0.67662E-04    0.17823E+08    0.24485E+01    0.50000E+03    0.15009E-17    0.70568E-04    0.57605E-02    0.10978E+02
+    2    1    0.70346E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.14558E-04    0.11576E-04    0.26689E-02    0.67662E-04    0.31100E+08    0.42724E+01    0.50000E+03    0.26189E-17    0.12314E-03    0.57605E-02    0.10978E+02
+    2    1    0.12275E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.44326E-04    0.20199E-04    0.46571E-02    0.67662E-04    0.54267E+08    0.74551E+01    0.50000E+03    0.45699E-17    0.21487E-03    0.57605E-02    0.10978E+02
+    2    1    0.21419E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.13496E-03    0.35246E-04    0.81263E-02    0.67662E-04    0.94693E+08    0.13009E+02    0.50000E+03    0.79742E-17    0.37493E-03    0.57605E-02    0.10978E+02
+    2    1    0.37375E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.41094E-03    0.61501E-04    0.14180E-01    0.67662E-04    0.16523E+09    0.22699E+02    0.50000E+03    0.13915E-16    0.65423E-03    0.57605E-02    0.10978E+02
+    2    1    0.65217E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.12512E-02    0.10732E-03    0.24743E-01    0.67662E-04    0.28832E+09    0.39609E+02    0.50000E+03    0.24280E-16    0.11416E-02    0.57605E-02    0.10978E+02
+    2    1    0.11380E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.38098E-02    0.18726E-03    0.43175E-01    0.67662E-04    0.50310E+09    0.69116E+02    0.50000E+03    0.42367E-16    0.19920E-02    0.57605E-02    0.10978E+02
+    2    1    0.19857E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.11600E-01    0.32676E-03    0.75338E-01    0.67662E-04    0.87789E+09    0.12060E+03    0.50000E+03    0.73928E-16    0.34759E-02    0.57605E-02    0.10978E+02
+    2    1    0.34650E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.35320E-01    0.57017E-03    0.13146E+00    0.67662E-04    0.15319E+10    0.21044E+03    0.50000E+03    0.12900E-15    0.60653E-02    0.57605E-02    0.10978E+02
+    2    1    0.60462E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.10754E+00    0.99492E-03    0.22939E+00    0.67662E-04    0.26730E+10    0.36721E+03    0.50000E+03    0.22510E-15    0.10583E-01    0.57605E-02    0.10978E+02
+    2    1    0.10550E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.32745E+00    0.17361E-02    0.40027E+00    0.67662E-04    0.46642E+10    0.64076E+03    0.50000E+03    0.39278E-15    0.18468E-01    0.57605E-02    0.10978E+02
+    2    1    0.18409E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.99703E+00    0.30293E-02    0.69845E+00    0.67662E-04    0.81388E+10    0.11181E+04    0.50000E+03    0.68538E-15    0.32225E-01    0.57605E-02    0.10978E+02
+    2    1    0.32123E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.30358E+01    0.52860E-02    0.12188E+01    0.67662E-04    0.14202E+11    0.19510E+04    0.50000E+03    0.11959E-14    0.56230E-01    0.57605E-02    0.10978E+02
+    2    1    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    2    1    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    2    1    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    2    1    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    2    1    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    2    1    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    2    1    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    2    1    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    2    1    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    2    1    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    2    1    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    2    1    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    2    1    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    2    1    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    2    1    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    2    1    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    2    1    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    2    1    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    2    1    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    2    1    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    2    1    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    2    1    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    2    1    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    2    1    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    2    1    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    2    1    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    2    1    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    2    1    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    2    1    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    2    1    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    2    1    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    2    1    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    2    1    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    2    1    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    2    1    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    2    1    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    2    1    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    2    1    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    2    1    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    2    1    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    2    1    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    2    1    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    2    1    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    2    1    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    2    1    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    2    1    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    2    1    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    2    1    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    2    1    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    2    1    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    2    1    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    2    1    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    2    1    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    2    1    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    2    1    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    2    1    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    2    1    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    2    1    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    2    1    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    2    1    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    2    1    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    2    1    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    2    1    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    2    1    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    2    1    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    2    1    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    2    1    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    2    1    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    2    1    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    2    1    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    2    1    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    2    1    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    2    1    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    2    1    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    2    1    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    2    1    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    2    1    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    2    1    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    2    1    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    2    1    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    2    1    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    2    1    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    2    1    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    2    1    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    2    1    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    2    1    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    2    1    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    2    1    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    2    1    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    2    1    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    2    1    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    2    1    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    2    1    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    2    1    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    2    1    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    2    1    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    2    1    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    2    1    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    2    1    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    2    1    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    2    1    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    2    1    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    2    1    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    2    1    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    2    1    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    2    1    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    2    1    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    2    1    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    2    1    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    2    1    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    2    1    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    2    1    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    2    1    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    2    1    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    2    1    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    2    1    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    2    1    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    2    1    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    2    1    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    2    1    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    2    1    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    2    1    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    2    1    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    2    1    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    2    1    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    2    1    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    2    1    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    2    1    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    2    1    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    2    1    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    2    1    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    2    1    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    2    1    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    2    1    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    2    1    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    2    1    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    2    1    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    2    1    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    2    1    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    2    1    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    2    1    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    2    1    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    2    1    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    2    1    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    2    1    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    2    1    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    2    1    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    2    1    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    2    1    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    2    1    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    2    1    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    2    1    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    2    1    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    2    1    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    2    1    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    2    1    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    2    1    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    2    1    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    2    1    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    2    1    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    2    1    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    2    1    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    2    1    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    2    1    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    2    1    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    2    1    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    2    1    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    2    1    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    2    1    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    2    1    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    2    1    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    2    1    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    2    1    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    2    1    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    2    1    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    2    1    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    2    1    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    2    1    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    2    1    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    2    1    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    2    1    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    2    1    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    2    1    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    2    1    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    2    1    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    2    1    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    2    1    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    2    1    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    2    1    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    2    1    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    2    1    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    2    1    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    2    1    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    2    1    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    2    1    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    2    1    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    2    1    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    2    1    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    2    1    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    2    1    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    2    1    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    2    1    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    2    1    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    2    1    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    2    1    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    2    1    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    2    1    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    2    1    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    2    1    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    2    1    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    2    1    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    2    1    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    2    1    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    2    1    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    2    1    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    2    1    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    2    1    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    2    1    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    2    1    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    2    1    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    2    1    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    2    1    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    2    1    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    2    1    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    2    1    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    2    1    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    2    1    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    2    1    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    2    1    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    2    1    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    2    1    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    2    1    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    2    1    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    2    1    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    2    1    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    2    1    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    2    1    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    2    1    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    2    1    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    2    1    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    2    1    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    2    1    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    2    1    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    2    1    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    2    1    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    2    1    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    2    1    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    2    1    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    2    1    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    2    1    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    2    1    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    2    1    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    2    1    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    2    1    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    2    1    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    2    1    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    2    1    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    2    1    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    2    1    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    2    1    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    2    1    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    2    1    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    2    1    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    2    1    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    2    1    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    2    1    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    2    1    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    2    1    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    2    1    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    2    1    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    2    1    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    2    1    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    2    1    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    2    1    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    2    1    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    2    1    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    2    1    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    2    1    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    2    1    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    2    1    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    2    1    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    2    1    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    2    1    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    2    1    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    2    1    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    2    1    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    2    1    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    2    1    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    2    1    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    2    1    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    2    1    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    2    1    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    2    1    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    2    1    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    2    1    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    2    1    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    2    1    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    2    1    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    2    1    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    2    1    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    2    1    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    2    1    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    2    1    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    2    1    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    2    1    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    2    1    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    2    1    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    2    1    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    2    1    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    2    1    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    2    1    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    2    1    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    2    1    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    2    1    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    2    1    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    2    1    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    2    1    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    2    1    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    2    1    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    2    1    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    2    1    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    2    1    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    2    1    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    2    1    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    2    1    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    2    1    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    2    1    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    2    1    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    2    1    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    2    1    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    2    1    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    2    1    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    2    1    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    2    1    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    2    1    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    2    1    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    2    1    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    2    1    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    2    1    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    2    1    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    2    1    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    2    1    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    2    1    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    2    1    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    2    1    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    2    1    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    2    1    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    2    1    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    2    1    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    2    1    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    2    1    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    2    1    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    2    1    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    2    1    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    2    1    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    2    1    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    2    1    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    2    1    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    2    1    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    2    1    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    2    1    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    2    1    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    2    1    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    2    1    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    2    1    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    2    1    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    2    1    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    2    1    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    2    1    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    2    1    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    2    1    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    2    1    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    2    1    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    2    1    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    2    1    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    2    1    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    2    1    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    2    1    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    2    1    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    2    1    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    2    1    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    2    1    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    2    1    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    2    1    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    2    1    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    2    1    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    2    1    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    2    1    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    2    1    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    2    1    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    2    1    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    2    1    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    2    1    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    2    1    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    2    1    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    2    1    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    2    1    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    2    1    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    2    1    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    2    1    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    2    1    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    2    1    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    2    1    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    2    1    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    2    1    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    2    1    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    2    1    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    2    1    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    2    1    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    2    1    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    2    1    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    2    1    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    2    1    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    2    1    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    2    1    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    2    1    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    2    1    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    2    1    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    2    1    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    2    1    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    2    1    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    2    1    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    2    1    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    2    1    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    2    1    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    2    1    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    2    1    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    2    1    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    2    1    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    2    1    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    2    1    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    2    1    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    2    1    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    2    1    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    2    1    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    2    1    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    2    1    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    2    1    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    2    1    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    2    1    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    2    1    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    2    1    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    2    1    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    2    1    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    2    1    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    2    1    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    2    1    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    2    1    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    2    1    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    2    1    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    2    1    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    2    1    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    2    1    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    2    1    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    2    1    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    2    1    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    2    1    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    2    1    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    2    1    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    2    1    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    2    1    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    2    1    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    2    1    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    2    1    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    2    1    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    2    1    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    2    1    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    2    1    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    2    1    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    2    1    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    2    1    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    2    1    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    2    1    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    2    1    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    2    1    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    2    1    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    2    1    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    2    1    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    2    1    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    2    1    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    2    1    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    2    1    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    2    1    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    2    1    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    2    1    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    2    1    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    2    1    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    2    1    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    2    1    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    2    1    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    2    1    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    2    1    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    2    1    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    2    1    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    2    1    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    2    1    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    2    1    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    2    1    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    2    1    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    2    1    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    2    1    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    2    1    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    2    1    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    2    1    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    2    1    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    2    1    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    2    1    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    2    1    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    2    1    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    2    1    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    2    1    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    2    1    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    2    1    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    2    1    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    2    1    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    2    1    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    2    1    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    2    1    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    2    1    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    2    1    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    2    1    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    2    1    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    2    1    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    2    1    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    2    1    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    2    1    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    2    1    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    2    1    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    2    1    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    2    1    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    2    1    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    2    1    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    2    1    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    2    1    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    2    1    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    2    1    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    2    1    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    2    1    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    2    1    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    2    1    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    2    1    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    2    1    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    2    1    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    2    1    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    2    1    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    2    1    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    2    1    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    2    1    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    2    1    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    2    1    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    2    1    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    2    1    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    2    1    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    2    1    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    2    1    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    2    1    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    2    1    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    2    1    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    2    1    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    2    1    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    2    1    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    2    1    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    2    1    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    2    1    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    2    1    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    2    1    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    2    1    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    2    1    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    2    1    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    2    1    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    2    1    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    2    1    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    2    1    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    2    1    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    2    1    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    2    1    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    2    1    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    2    1    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    2    1    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    2    1    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    2    1    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    2    1    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    2    1    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    2    1    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    2    1    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    2    1    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    2    1    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    2    1    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    2    1    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    2    1    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    2    1    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    2    1    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    2    1    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    2    1    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    2    1    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    2    1    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    2    1    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    2    1    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    2    1    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    2    1    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    2    1    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    2    1    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    2    1    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    2    1    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    2    1    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    2    1    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    2    1    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    2    1    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    2    1    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    2    1    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    2    1    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    2    1    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    2    1    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    2    1    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    2    1    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    2    1    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    2    1    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    2    1    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    2    1    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    2    1    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    2    1    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    2    1    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    2    1    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    2    1    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    2    1    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    2    1    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    2    1    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    2    1    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    2    1    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    2    1    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    2    1    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35525E-67
+    2    1    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31050E-66
+    2    1    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49297E-66    0.26759E-65
+    2    1    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20665E-64
+    2    1    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    2    1    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15327E-62
+    2    1    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    2    1    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30486E-60
+    2    1    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49479E-59
+    2    1    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76348E-58
+    2    1    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    2    1    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16341E-55
+    2    1    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    2    1    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33513E-53
+    2    1    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47754E-52
+    2    1    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86007E-46    0.21355E-49
+    2    1    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    2    1    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    2    1    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    2    1    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    2    1    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    2    1    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    2    1    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    2    1    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    2    1    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    2    1    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    2    1    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    2    1    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    2    1    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    2    1    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    2    1    0.95225E-10    0.10000E+01    0.80645E+05    0.53338E-57    0.41251E-68    0.10749E-66
+    2    1    0.95225E-10    0.10000E+01    0.65036E+05    0.46320E-56    0.66241E-67    0.94141E-66
+    2    1    0.95225E-10    0.10000E+01    0.52449E+05    0.40024E-55    0.93503E-66    0.81416E-65
+    2    1    0.95225E-10    0.10000E+01    0.42297E+05    0.31521E-54    0.15121E-64    0.62477E-64
+    2    1    0.95225E-10    0.10000E+01    0.34111E+05    0.26479E-53    0.31103E-63    0.46450E-63
+    2    1    0.95225E-10    0.10000E+01    0.27509E+05    0.27530E-52    0.84266E-62    0.36185E-62
+    2    1    0.95225E-10    0.10000E+01    0.22184E+05    0.37547E-51    0.26561E-60    0.35004E-61
+    2    1    0.95225E-10    0.10000E+01    0.17891E+05    0.59959E-50    0.82078E-59    0.47852E-60
+    2    1    0.95225E-10    0.10000E+01    0.14428E+05    0.96029E-49    0.23747E-57    0.76675E-59
+    2    1    0.95225E-10    0.10000E+01    0.11635E+05    0.14620E-47    0.65938E-56    0.12102E-57
+    2    1    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18298E-56
+    2    1    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49011E-53    0.26942E-55
+    2    1    0.95225E-10    0.10000E+01    0.61026E+04    0.43943E-44    0.13295E-51    0.39150E-54
+    2    1    0.95225E-10    0.10000E+01    0.49215E+04    0.62538E-43    0.35997E-50    0.56476E-53
+    2    1    0.95225E-10    0.10000E+01    0.39689E+04    0.88822E-42    0.97300E-49    0.81063E-52
+    2    1    0.95225E-10    0.10000E+01    0.32008E+04    0.39613E-39    0.84952E-46    0.36461E-49
+    2    1    0.95225E-10    0.10000E+01    0.25813E+04    0.29211E-30    0.14353E-36    0.27085E-40
+    2    1    0.95225E-10    0.10000E+01    0.20817E+04    0.55938E-14    0.12256E-19    0.52257E-24
+    2    1    0.95225E-10    0.10000E+01    0.16788E+04    0.18980E-08    0.18143E-13    0.17813E-18
+    2    1    0.95225E-10    0.10000E+01    0.13538E+04    0.40806E-08    0.68940E-13    0.38357E-18
+    2    1    0.95225E-10    0.10000E+01    0.10918E+04    0.85761E-08    0.25711E-12    0.80708E-18
+    2    1    0.95225E-10    0.10000E+01    0.88049E+03    0.17636E-07    0.94670E-12    0.16610E-17
+    2    1    0.95225E-10    0.10000E+01    0.71007E+03    0.35560E-07    0.34475E-11    0.33511E-17
+    2    1    0.95225E-10    0.10000E+01    0.57264E+03    0.70490E-07    0.12266E-10    0.66454E-17
+    2    1    0.95225E-10    0.10000E+01    0.46180E+03    0.13745E-06    0.41255E-10    0.12961E-16
+    2    1    0.95225E-10    0.10000E+01    0.37242E+03    0.26237E-06    0.12579E-09    0.24744E-16
+    2    1    0.95225E-10    0.10000E+01    0.30034E+03    0.48462E-06    0.33740E-09    0.45710E-16
+    2    1    0.95225E-10    0.10000E+01    0.24221E+03    0.85384E-06    0.78780E-09    0.80539E-16
+    2    1    0.95225E-10    0.10000E+01    0.19533E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    2    1    0.95225E-10    0.10000E+01    0.15752E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    2    1    0.16616E-09    0.10000E+01    0.80645E+05    0.10831E-56    0.84134E-68    0.33649E-66
+    2    1    0.16616E-09    0.10000E+01    0.65036E+05    0.94382E-56    0.13505E-66    0.29209E-65
+    2    1    0.16616E-09    0.10000E+01    0.52449E+05    0.81476E-55    0.18599E-65    0.25174E-64
+    2    1    0.16616E-09    0.10000E+01    0.42297E+05    0.62646E-54    0.26584E-64    0.19203E-63
+    2    1    0.16616E-09    0.10000E+01    0.34111E+05    0.47293E-53    0.41443E-63    0.13945E-62
+    2    1    0.16616E-09    0.10000E+01    0.27509E+05    0.38376E-52    0.82703E-62    0.99836E-62
+    2    1    0.16616E-09    0.10000E+01    0.22184E+05    0.38951E-51    0.23108E-60    0.77606E-61
+    2    1    0.16616E-09    0.10000E+01    0.17891E+05    0.53703E-50    0.71872E-59    0.82846E-60
+    2    1    0.16616E-09    0.10000E+01    0.14428E+05    0.84667E-49    0.21403E-57    0.12129E-58
+    2    1    0.16616E-09    0.10000E+01    0.11635E+05    0.13169E-47    0.60847E-56    0.19194E-57
+    2    1    0.16616E-09    0.10000E+01    0.93834E+04    0.19721E-46    0.16918E-54    0.29611E-56
+    2    1    0.16616E-09    0.10000E+01    0.75673E+04    0.28850E-45    0.46590E-53    0.44363E-55
+    2    1    0.16616E-09    0.10000E+01    0.61026E+04    0.41726E-44    0.12762E-51    0.65289E-54
+    2    1    0.16616E-09    0.10000E+01    0.49215E+04    0.59980E-43    0.34818E-50    0.95065E-53
+    2    1    0.16616E-09    0.10000E+01    0.39689E+04    0.85857E-42    0.94687E-49    0.13742E-51
+    2    1    0.16616E-09    0.10000E+01    0.32008E+04    0.38534E-39    0.83094E-46    0.62162E-49
+    2    1    0.16616E-09    0.10000E+01    0.25813E+04    0.28572E-30    0.14110E-36    0.46404E-40
+    2    1    0.16616E-09    0.10000E+01    0.20817E+04    0.55023E-14    0.12112E-19    0.89981E-24
+    2    1    0.16616E-09    0.10000E+01    0.16788E+04    0.18735E-08    0.17967E-13    0.30768E-18
+    2    1    0.16616E-09    0.10000E+01    0.13538E+04    0.40327E-08    0.68292E-13    0.66322E-18
+    2    1    0.16616E-09    0.10000E+01    0.10918E+04    0.84828E-08    0.25473E-12    0.13965E-17
+    2    1    0.16616E-09    0.10000E+01    0.88049E+03    0.17454E-07    0.93805E-12    0.28757E-17
+    2    1    0.16616E-09    0.10000E+01    0.71007E+03    0.35210E-07    0.34161E-11    0.58040E-17
+    2    1    0.16616E-09    0.10000E+01    0.57264E+03    0.69816E-07    0.12154E-10    0.11512E-16
+    2    1    0.16616E-09    0.10000E+01    0.46180E+03    0.13616E-06    0.40880E-10    0.22458E-16
+    2    1    0.16616E-09    0.10000E+01    0.37242E+03    0.25994E-06    0.12465E-09    0.42878E-16
+    2    1    0.16616E-09    0.10000E+01    0.30034E+03    0.48017E-06    0.33433E-09    0.79212E-16
+    2    1    0.16616E-09    0.10000E+01    0.24221E+03    0.84602E-06    0.78064E-09    0.13957E-15
+    2    1    0.16616E-09    0.10000E+01    0.19533E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    2    1    0.16616E-09    0.10000E+01    0.15752E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    2    1    0.28994E-09    0.10000E+01    0.80645E+05    0.22011E-56    0.16920E-67    0.11249E-65
+    2    1    0.28994E-09    0.10000E+01    0.65036E+05    0.19023E-55    0.27099E-66    0.96503E-65
+    2    1    0.28994E-09    0.10000E+01    0.52449E+05    0.16355E-54    0.36930E-65    0.82631E-64
+    2    1    0.28994E-09    0.10000E+01    0.42297E+05    0.12449E-53    0.50576E-64    0.62542E-63
+    2    1    0.28994E-09    0.10000E+01    0.34111E+05    0.90534E-53    0.69149E-63    0.44950E-62
+    2    1    0.28994E-09    0.10000E+01    0.27509E+05    0.65403E-52    0.10276E-61    0.31368E-61
+    2    1    0.28994E-09    0.10000E+01    0.22184E+05    0.51145E-51    0.21678E-60    0.21734E-60
+    2    1    0.28994E-09    0.10000E+01    0.17891E+05    0.53350E-50    0.62717E-59    0.17681E-59
+    2    1    0.28994E-09    0.10000E+01    0.14428E+05    0.75573E-49    0.19028E-57    0.20765E-58
+    2    1    0.28994E-09    0.10000E+01    0.11635E+05    0.11751E-47    0.55601E-56    0.31026E-57
+    2    1    0.28994E-09    0.10000E+01    0.93834E+04    0.17997E-46    0.15781E-54    0.48192E-56
+    2    1    0.28994E-09    0.10000E+01    0.75673E+04    0.26865E-45    0.44099E-53    0.73307E-55
+    2    1    0.28994E-09    0.10000E+01    0.61026E+04    0.39444E-44    0.12210E-51    0.10917E-53
+    2    1    0.28994E-09    0.10000E+01    0.49215E+04    0.57333E-43    0.33588E-50    0.16029E-52
+    2    1    0.28994E-09    0.10000E+01    0.39689E+04    0.82768E-42    0.91939E-49    0.23314E-51
+    2    1    0.28994E-09    0.10000E+01    0.32008E+04    0.37400E-39    0.81127E-46    0.10597E-48
+    2    1    0.28994E-09    0.10000E+01    0.25813E+04    0.27896E-30    0.13850E-36    0.79454E-40
+    2    1    0.28994E-09    0.10000E+01    0.20817E+04    0.54048E-14    0.11957E-19    0.15478E-23
+    2    1    0.28994E-09    0.10000E+01    0.16788E+04    0.18472E-08    0.17777E-13    0.53075E-18
+    2    1    0.28994E-09    0.10000E+01    0.13538E+04    0.39812E-08    0.67591E-13    0.11451E-17
+    2    1    0.28994E-09    0.10000E+01    0.10918E+04    0.83822E-08    0.25216E-12    0.24130E-17
+    2    1    0.28994E-09    0.10000E+01    0.88049E+03    0.17259E-07    0.92865E-12    0.49712E-17
+    2    1    0.28994E-09    0.10000E+01    0.71007E+03    0.34831E-07    0.33820E-11    0.10037E-16
+    2    1    0.28994E-09    0.10000E+01    0.57264E+03    0.69086E-07    0.12033E-10    0.19913E-16
+    2    1    0.28994E-09    0.10000E+01    0.46180E+03    0.13476E-06    0.40472E-10    0.38849E-16
+    2    1    0.28994E-09    0.10000E+01    0.37242E+03    0.25730E-06    0.12341E-09    0.74180E-16
+    2    1    0.28994E-09    0.10000E+01    0.30034E+03    0.47533E-06    0.33100E-09    0.13705E-15
+    2    1    0.28994E-09    0.10000E+01    0.24221E+03    0.83753E-06    0.77285E-09    0.24148E-15
+    2    1    0.28994E-09    0.10000E+01    0.19533E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    2    1    0.28994E-09    0.10000E+01    0.15752E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    2    1    0.50593E-09    0.10000E+01    0.80645E+05    0.44926E-56    0.34079E-67    0.39232E-65
+    2    1    0.50593E-09    0.10000E+01    0.65036E+05    0.38422E-55    0.54341E-66    0.33355E-64
+    2    1    0.50593E-09    0.10000E+01    0.52449E+05    0.32834E-54    0.73364E-65    0.28402E-63
+    2    1    0.50593E-09    0.10000E+01    0.42297E+05    0.24795E-53    0.99037E-64    0.21350E-62
+    2    1    0.50593E-09    0.10000E+01    0.34111E+05    0.17797E-52    0.13099E-62    0.15247E-61
+    2    1    0.50593E-09    0.10000E+01    0.27509E+05    0.12441E-51    0.16902E-61    0.10586E-60
+    2    1    0.50593E-09    0.10000E+01    0.22184E+05    0.86010E-51    0.25710E-60    0.70603E-60
+    2    1    0.50593E-09    0.10000E+01    0.17891E+05    0.67638E-50    0.58946E-59    0.47985E-59
+    2    1    0.50593E-09    0.10000E+01    0.14428E+05    0.74782E-49    0.17213E-57    0.41577E-58
+    2    1    0.50593E-09    0.10000E+01    0.11635E+05    0.10801E-47    0.51285E-56    0.52474E-57
+    2    1    0.50593E-09    0.10000E+01    0.93834E+04    0.16626E-46    0.14855E-54    0.79304E-56
+    2    1    0.50593E-09    0.10000E+01    0.75673E+04    0.25254E-45    0.42087E-53    0.12189E-54
+    2    1    0.50593E-09    0.10000E+01    0.61026E+04    0.37597E-44    0.11762E-51    0.18356E-53
+    2    1    0.50593E-09    0.10000E+01    0.49215E+04    0.55185E-43    0.32580E-50    0.27151E-52
+    2    1    0.50593E-09    0.10000E+01    0.39689E+04    0.80238E-42    0.89663E-49    0.39684E-51
+    2    1    0.50593E-09    0.10000E+01    0.32008E+04    0.36462E-39    0.79485E-46    0.18106E-48
+    2    1    0.50593E-09    0.10000E+01    0.25813E+04    0.27333E-30    0.13633E-36    0.13622E-39
+    2    1    0.50593E-09    0.10000E+01    0.20817E+04    0.53238E-14    0.11828E-19    0.26638E-23
+    2    1    0.50593E-09    0.10000E+01    0.16788E+04    0.18256E-08    0.17620E-13    0.91573E-18
+    2    1    0.50593E-09    0.10000E+01    0.13538E+04    0.39387E-08    0.67015E-13    0.19773E-17
+    2    1    0.50593E-09    0.10000E+01    0.10918E+04    0.82993E-08    0.25005E-12    0.41688E-17
+    2    1    0.50593E-09    0.10000E+01    0.88049E+03    0.17098E-07    0.92093E-12    0.85921E-17
+    2    1    0.50593E-09    0.10000E+01    0.71007E+03    0.34520E-07    0.33539E-11    0.17352E-16
+    2    1    0.50593E-09    0.10000E+01    0.57264E+03    0.68486E-07    0.11933E-10    0.34432E-16
+    2    1    0.50593E-09    0.10000E+01    0.46180E+03    0.13362E-06    0.40135E-10    0.67183E-16
+    2    1    0.50593E-09    0.10000E+01    0.37242E+03    0.25513E-06    0.12238E-09    0.12829E-15
+    2    1    0.50593E-09    0.10000E+01    0.30034E+03    0.47134E-06    0.32824E-09    0.23702E-15
+    2    1    0.50593E-09    0.10000E+01    0.24221E+03    0.83053E-06    0.76641E-09    0.41764E-15
+    2    1    0.50593E-09    0.10000E+01    0.19533E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    2    1    0.50593E-09    0.10000E+01    0.15752E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    2    1    0.88282E-09    0.10000E+01    0.80645E+05    0.91476E-56    0.68731E-67    0.13789E-64
+    2    1    0.88282E-09    0.10000E+01    0.65036E+05    0.77641E-55    0.10919E-65    0.11662E-63
+    2    1    0.88282E-09    0.10000E+01    0.52449E+05    0.66035E-54    0.14632E-64    0.98963E-63
+    2    1    0.88282E-09    0.10000E+01    0.42297E+05    0.49567E-53    0.19615E-63    0.74065E-62
+    2    1    0.88282E-09    0.10000E+01    0.34111E+05    0.35353E-52    0.25848E-62    0.52675E-61
+    2    1    0.88282E-09    0.10000E+01    0.27509E+05    0.24558E-51    0.32187E-61    0.36567E-60
+    2    1    0.88282E-09    0.10000E+01    0.22184E+05    0.16393E-50    0.40073E-60    0.24273E-59
+    2    1    0.88282E-09    0.10000E+01    0.17891E+05    0.10961E-49    0.65251E-59    0.15348E-58
+    2    1    0.88282E-09    0.10000E+01    0.14428E+05    0.89454E-49    0.16244E-57    0.10392E-57
+    2    1    0.88282E-09    0.10000E+01    0.11635E+05    0.10618E-47    0.47991E-56    0.98632E-57
+    2    1    0.88282E-09    0.10000E+01    0.93834E+04    0.15701E-46    0.14156E-54    0.13418E-55
+    2    1    0.88282E-09    0.10000E+01    0.75673E+04    0.24062E-45    0.40636E-53    0.20503E-54
+    2    1    0.88282E-09    0.10000E+01    0.61026E+04    0.36255E-44    0.11442E-51    0.31177E-53
+    2    1    0.88282E-09    0.10000E+01    0.49215E+04    0.53641E-43    0.31845E-50    0.46407E-52
+    2    1    0.88282E-09    0.10000E+01    0.39689E+04    0.78393E-42    0.87953E-49    0.68035E-51
+    2    1    0.88282E-09    0.10000E+01    0.32008E+04    0.35759E-39    0.78214E-46    0.31094E-48
+    2    1    0.88282E-09    0.10000E+01    0.25813E+04    0.26899E-30    0.13461E-36    0.23432E-39
+    2    1    0.88282E-09    0.10000E+01    0.20817E+04    0.52599E-14    0.11724E-19    0.45928E-23
+    2    1    0.88282E-09    0.10000E+01    0.16788E+04    0.18083E-08    0.17491E-13    0.15815E-17
+    2    1    0.88282E-09    0.10000E+01    0.13538E+04    0.39044E-08    0.66538E-13    0.34162E-17
+    2    1    0.88282E-09    0.10000E+01    0.10918E+04    0.82318E-08    0.24829E-12    0.72050E-17
+    2    1    0.88282E-09    0.10000E+01    0.88049E+03    0.16966E-07    0.91446E-12    0.14853E-16
+    2    1    0.88282E-09    0.10000E+01    0.71007E+03    0.34263E-07    0.33303E-11    0.30001E-16
+    2    1    0.88282E-09    0.10000E+01    0.57264E+03    0.67988E-07    0.11849E-10    0.59535E-16
+    2    1    0.88282E-09    0.10000E+01    0.46180E+03    0.13266E-06    0.39851E-10    0.11617E-15
+    2    1    0.88282E-09    0.10000E+01    0.37242E+03    0.25331E-06    0.12151E-09    0.22183E-15
+    2    1    0.88282E-09    0.10000E+01    0.30034E+03    0.46799E-06    0.32591E-09    0.40983E-15
+    2    1    0.88282E-09    0.10000E+01    0.24221E+03    0.82463E-06    0.76096E-09    0.72214E-15
+    2    1    0.88282E-09    0.10000E+01    0.19533E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    2    1    0.88282E-09    0.10000E+01    0.15752E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    2    1    0.15405E-08    0.10000E+01    0.80645E+05    0.22169E-55    0.16538E-66    0.19444E-63
+    2    1    0.15405E-08    0.10000E+01    0.65036E+05    0.18709E-54    0.26199E-65    0.16386E-62
+    2    1    0.15405E-08    0.10000E+01    0.52449E+05    0.15857E-53    0.34936E-64    0.13874E-61
+    2    1    0.15405E-08    0.10000E+01    0.42297E+05    0.11856E-52    0.46757E-63    0.10359E-60
+    2    1    0.15405E-08    0.10000E+01    0.34111E+05    0.84435E-52    0.62479E-62    0.73632E-60
+    2    1    0.15405E-08    0.10000E+01    0.27509E+05    0.59246E-51    0.81019E-61    0.51534E-59
+    2    1    0.15405E-08    0.10000E+01    0.22184E+05    0.40692E-50    0.10307E-59    0.35092E-58
+    2    1    0.15405E-08    0.10000E+01    0.17891E+05    0.27534E-49    0.14075E-58    0.22768E-57
+    2    1    0.15405E-08    0.10000E+01    0.14428E+05    0.19631E-48    0.24555E-57    0.13888E-56
+    2    1    0.15405E-08    0.10000E+01    0.11635E+05    0.17070E-47    0.57662E-56    0.81553E-56
+    2    1    0.15405E-08    0.10000E+01    0.93834E+04    0.19685E-46    0.15733E-54    0.52856E-55
+    2    1    0.15405E-08    0.10000E+01    0.75673E+04    0.27170E-45    0.44125E-53    0.48422E-54
+    2    1    0.15405E-08    0.10000E+01    0.61026E+04    0.39529E-44    0.12261E-51    0.62492E-53
+    2    1    0.15405E-08    0.10000E+01    0.49215E+04    0.57536E-43    0.33698E-50    0.90174E-52
+    2    1    0.15405E-08    0.10000E+01    0.39689E+04    0.83012E-42    0.92000E-49    0.13001E-50
+    2    1    0.15405E-08    0.10000E+01    0.32008E+04    0.37425E-39    0.80984E-46    0.58076E-48
+    2    1    0.15405E-08    0.10000E+01    0.25813E+04    0.27849E-30    0.13803E-36    0.42644E-39
+    2    1    0.15405E-08    0.10000E+01    0.20817E+04    0.53875E-14    0.11903E-19    0.81441E-23
+    2    1    0.15405E-08    0.10000E+01    0.16788E+04    0.18406E-08    0.17690E-13    0.27668E-17
+    2    1    0.15405E-08    0.10000E+01    0.13538E+04    0.39646E-08    0.67251E-13    0.59320E-17
+    2    1    0.15405E-08    0.10000E+01    0.10918E+04    0.83445E-08    0.25085E-12    0.12448E-16
+    2    1    0.15405E-08    0.10000E+01    0.88049E+03    0.17177E-07    0.92365E-12    0.25570E-16
+    2    1    0.15405E-08    0.10000E+01    0.71007E+03    0.34659E-07    0.33633E-11    0.51512E-16
+    2    1    0.15405E-08    0.10000E+01    0.57264E+03    0.68732E-07    0.11965E-10    0.10202E-15
+    2    1    0.15405E-08    0.10000E+01    0.46180E+03    0.13405E-06    0.40239E-10    0.19877E-15
+    2    1    0.15405E-08    0.10000E+01    0.37242E+03    0.25590E-06    0.12269E-09    0.37913E-15
+    2    1    0.15405E-08    0.10000E+01    0.30034E+03    0.47270E-06    0.32907E-09    0.69988E-15
+    2    1    0.15405E-08    0.10000E+01    0.24221E+03    0.83283E-06    0.76833E-09    0.12325E-14
+    2    1    0.15405E-08    0.10000E+01    0.19533E+03    0.13126E-05    0.14601E-08    0.19419E-14
+    2    1    0.15405E-08    0.10000E+01    0.15752E+03    0.13126E-05    0.14601E-08    0.19419E-14
+    2    1    0.26880E-08    0.10000E+01    0.80645E+05    0.44147E-55    0.32899E-66    0.76539E-63
+    2    1    0.26880E-08    0.10000E+01    0.65036E+05    0.37227E-54    0.52097E-65    0.64519E-62
+    2    1    0.26880E-08    0.10000E+01    0.52449E+05    0.31535E-53    0.69411E-64    0.54648E-61
+    2    1    0.26880E-08    0.10000E+01    0.42297E+05    0.23562E-52    0.92815E-63    0.40832E-60
+    2    1    0.26880E-08    0.10000E+01    0.34111E+05    0.16767E-51    0.12398E-61    0.29071E-59
+    2    1    0.26880E-08    0.10000E+01    0.27509E+05    0.11758E-50    0.16033E-60    0.20417E-58
+    2    1    0.26880E-08    0.10000E+01    0.22184E+05    0.80503E-50    0.19916E-59    0.14006E-57
+    2    1    0.26880E-08    0.10000E+01    0.17891E+05    0.53362E-49    0.24604E-58    0.92169E-57
+    2    1    0.26880E-08    0.10000E+01    0.14428E+05    0.35072E-48    0.34415E-57    0.57325E-56
+    2    1    0.26880E-08    0.10000E+01    0.11635E+05    0.25233E-47    0.64825E-56    0.33641E-55
+    2    1    0.26880E-08    0.10000E+01    0.93834E+04    0.23294E-46    0.16099E-54    0.19548E-54
+    2    1    0.26880E-08    0.10000E+01    0.75673E+04    0.28462E-45    0.44413E-53    0.13553E-53
+    2    1    0.26880E-08    0.10000E+01    0.61026E+04    0.40026E-44    0.12346E-51    0.13880E-52
+    2    1    0.26880E-08    0.10000E+01    0.49215E+04    0.57964E-43    0.33900E-50    0.18524E-51
+    2    1    0.26880E-08    0.10000E+01    0.39689E+04    0.83490E-42    0.92262E-49    0.26049E-50
+    2    1    0.26880E-08    0.10000E+01    0.32008E+04    0.37529E-39    0.80913E-46    0.11368E-47
+    2    1    0.26880E-08    0.10000E+01    0.25813E+04    0.27821E-30    0.13740E-36    0.81010E-39
+    2    1    0.26880E-08    0.10000E+01    0.20817E+04    0.53615E-14    0.11804E-19    0.14934E-22
+    2    1    0.26880E-08    0.10000E+01    0.16788E+04    0.18283E-08    0.17519E-13    0.49687E-17
+    2    1    0.26880E-08    0.10000E+01    0.13538E+04    0.39332E-08    0.66577E-13    0.10530E-16
+    2    1    0.26880E-08    0.10000E+01    0.10918E+04    0.82717E-08    0.24827E-12    0.21919E-16
+    2    1    0.26880E-08    0.10000E+01    0.88049E+03    0.17018E-07    0.91395E-12    0.44767E-16
+    2    1    0.26880E-08    0.10000E+01    0.71007E+03    0.34323E-07    0.33274E-11    0.89807E-16
+    2    1    0.26880E-08    0.10000E+01    0.57264E+03    0.68044E-07    0.11836E-10    0.17732E-15
+    2    1    0.26880E-08    0.10000E+01    0.46180E+03    0.13268E-06    0.39802E-10    0.34468E-15
+    2    1    0.26880E-08    0.10000E+01    0.37242E+03    0.25323E-06    0.12135E-09    0.65633E-15
+    2    1    0.26880E-08    0.10000E+01    0.30034E+03    0.46768E-06    0.32547E-09    0.12102E-14
+    2    1    0.26880E-08    0.10000E+01    0.24221E+03    0.82391E-06    0.75991E-09    0.21294E-14
+    2    1    0.26880E-08    0.10000E+01    0.19533E+03    0.12984E-05    0.14440E-08    0.33534E-14
+    2    1    0.26880E-08    0.10000E+01    0.15752E+03    0.12984E-05    0.14440E-08    0.33534E-14
+    2    1    0.46905E-08    0.10000E+01    0.80645E+05    0.84914E-55    0.63264E-66    0.25137E-62
+    2    1    0.46905E-08    0.10000E+01    0.65036E+05    0.71591E-54    0.10018E-64    0.21198E-61
+    2    1    0.46905E-08    0.10000E+01    0.52449E+05    0.60640E-53    0.13347E-63    0.17961E-60
+    2    1    0.46905E-08    0.10000E+01    0.42297E+05    0.45308E-52    0.17852E-62    0.13429E-59
+    2    1    0.46905E-08    0.10000E+01    0.34111E+05    0.32249E-51    0.23870E-61    0.95741E-59
+    2    1    0.46905E-08    0.10000E+01    0.27509E+05    0.22631E-50    0.30904E-60    0.67413E-58
+    2    1    0.46905E-08    0.10000E+01    0.22184E+05    0.15505E-49    0.38168E-59    0.46473E-57
+    2    1    0.46905E-08    0.10000E+01    0.17891E+05    0.10224E-48    0.45256E-58    0.30863E-56
+    2    1    0.46905E-08    0.10000E+01    0.14428E+05    0.65022E-48    0.55190E-57    0.19482E-55
+    2    1    0.46905E-08    0.10000E+01    0.11635E+05    0.41896E-47    0.82401E-56    0.11604E-54
+    2    1    0.46905E-08    0.10000E+01    0.93834E+04    0.31427E-46    0.17362E-54    0.66133E-54
+    2    1    0.46905E-08    0.10000E+01    0.75673E+04    0.31973E-45    0.45741E-53    0.40197E-53
+    2    1    0.46905E-08    0.10000E+01    0.61026E+04    0.41790E-44    0.12665E-51    0.33476E-52
+    2    1    0.46905E-08    0.10000E+01    0.49215E+04    0.59589E-43    0.34720E-50    0.40051E-51
+    2    1    0.46905E-08    0.10000E+01    0.39689E+04    0.85492E-42    0.94020E-49    0.54427E-50
+    2    1    0.46905E-08    0.10000E+01    0.32008E+04    0.38237E-39    0.81918E-46    0.23194E-47
+    2    1    0.46905E-08    0.10000E+01    0.25813E+04    0.28156E-30    0.13815E-36    0.15995E-38
+    2    1    0.46905E-08    0.10000E+01    0.20817E+04    0.53870E-14    0.11779E-19    0.28225E-22
+    2    1    0.46905E-08    0.10000E+01    0.16788E+04    0.18300E-08    0.17429E-13    0.91273E-17
+    2    1    0.46905E-08    0.10000E+01    0.13538E+04    0.39273E-08    0.66194E-13    0.19016E-16
+    2    1    0.46905E-08    0.10000E+01    0.10918E+04    0.82460E-08    0.24672E-12    0.39111E-16
+    2    1    0.46905E-08    0.10000E+01    0.88049E+03    0.16945E-07    0.90786E-12    0.79187E-16
+    2    1    0.46905E-08    0.10000E+01    0.71007E+03    0.34149E-07    0.33042E-11    0.15784E-15
+    2    1    0.46905E-08    0.10000E+01    0.57264E+03    0.67655E-07    0.11751E-10    0.31017E-15
+    2    1    0.46905E-08    0.10000E+01    0.46180E+03    0.13185E-06    0.39511E-10    0.60081E-15
+    2    1    0.46905E-08    0.10000E+01    0.37242E+03    0.25157E-06    0.12045E-09    0.11411E-14
+    2    1    0.46905E-08    0.10000E+01    0.30034E+03    0.46449E-06    0.32304E-09    0.21003E-14
+    2    1    0.46905E-08    0.10000E+01    0.24221E+03    0.81813E-06    0.75423E-09    0.36911E-14
+    2    1    0.46905E-08    0.10000E+01    0.19533E+03    0.12892E-05    0.14332E-08    0.58084E-14
+    2    1    0.46905E-08    0.10000E+01    0.15752E+03    0.12892E-05    0.14332E-08    0.58084E-14
+    2    1    0.81846E-08    0.10000E+01    0.80645E+05    0.16157E-54    0.12039E-65    0.81777E-62
+    2    1    0.81846E-08    0.10000E+01    0.65036E+05    0.13624E-53    0.19067E-64    0.68988E-61
+    2    1    0.81846E-08    0.10000E+01    0.52449E+05    0.11542E-52    0.25416E-63    0.58475E-60
+    2    1    0.81846E-08    0.10000E+01    0.42297E+05    0.86267E-52    0.34029E-62    0.43752E-59
+    2    1    0.81846E-08    0.10000E+01    0.34111E+05    0.61456E-51    0.45595E-61    0.31234E-58
+    2    1    0.81846E-08    0.10000E+01    0.27509E+05    0.43204E-50    0.59265E-60    0.22044E-57
+    2    1    0.81846E-08    0.10000E+01    0.22184E+05    0.29695E-49    0.73515E-59    0.15261E-56
+    2    1    0.81846E-08    0.10000E+01    0.17891E+05    0.19647E-48    0.86568E-58    0.10213E-55
+    2    1    0.81846E-08    0.10000E+01    0.14428E+05    0.12425E-47    0.99469E-57    0.65308E-55
+    2    1    0.81846E-08    0.10000E+01    0.11635E+05    0.76467E-47    0.12439E-55    0.39573E-54
+    2    1    0.81846E-08    0.10000E+01    0.93834E+04    0.49731E-46    0.20939E-54    0.22686E-53
+    2    1    0.81846E-08    0.10000E+01    0.75673E+04    0.40864E-45    0.49634E-53    0.12961E-52
+    2    1    0.81846E-08    0.10000E+01    0.61026E+04    0.46629E-44    0.13469E-51    0.90893E-52
+    2    1    0.81846E-08    0.10000E+01    0.49215E+04    0.63787E-43    0.36725E-50    0.94409E-51
+    2    1    0.81846E-08    0.10000E+01    0.39689E+04    0.90467E-42    0.98534E-49    0.12204E-49
+    2    1    0.81846E-08    0.10000E+01    0.32008E+04    0.40062E-39    0.84797E-46    0.50685E-47
+    2    1    0.81846E-08    0.10000E+01    0.25813E+04    0.29122E-30    0.14099E-36    0.33706E-38
+    2    1    0.81846E-08    0.10000E+01    0.20817E+04    0.54889E-14    0.11826E-19    0.56261E-22
+    2    1    0.81846E-08    0.10000E+01    0.16788E+04    0.18486E-08    0.17379E-13    0.17469E-16
+    2    1    0.81846E-08    0.10000E+01    0.13538E+04    0.39471E-08    0.65916E-13    0.35430E-16
+    2    1    0.81846E-08    0.10000E+01    0.10918E+04    0.82589E-08    0.24542E-12    0.71449E-16
+    2    1    0.81846E-08    0.10000E+01    0.88049E+03    0.16930E-07    0.90241E-12    0.14257E-15
+    2    1    0.81846E-08    0.10000E+01    0.71007E+03    0.34057E-07    0.32825E-11    0.28110E-15
+    2    1    0.81846E-08    0.10000E+01    0.57264E+03    0.67383E-07    0.11669E-10    0.54787E-15
+    2    1    0.81846E-08    0.10000E+01    0.46180E+03    0.13119E-06    0.39227E-10    0.10548E-14
+    2    1    0.81846E-08    0.10000E+01    0.37242E+03    0.25012E-06    0.11957E-09    0.19945E-14
+    2    1    0.81846E-08    0.10000E+01    0.30034E+03    0.46158E-06    0.32064E-09    0.36593E-14
+    2    1    0.81846E-08    0.10000E+01    0.24221E+03    0.81272E-06    0.74859E-09    0.64172E-14
+    2    1    0.81846E-08    0.10000E+01    0.19533E+03    0.12804E-05    0.14225E-08    0.10085E-13
+    2    1    0.81846E-08    0.10000E+01    0.15752E+03    0.12804E-05    0.14225E-08    0.10085E-13
+    2    1    0.14282E-07    0.10000E+01    0.80645E+05    0.30442E-54    0.22691E-65    0.26444E-61
+    2    1    0.14282E-07    0.10000E+01    0.65036E+05    0.25675E-53    0.35946E-64    0.22317E-60
+    2    1    0.14282E-07    0.10000E+01    0.52449E+05    0.21757E-52    0.47947E-63    0.18923E-59
+    2    1    0.14282E-07    0.10000E+01    0.42297E+05    0.16272E-51    0.64280E-62    0.14168E-58
+    2    1    0.14282E-07    0.10000E+01    0.34111E+05    0.11605E-50    0.86337E-61    0.10127E-57
+    2    1    0.14282E-07    0.10000E+01    0.27509E+05    0.81753E-50    0.11274E-59    0.71622E-57
+    2    1    0.14282E-07    0.10000E+01    0.22184E+05    0.56408E-49    0.14089E-58    0.49766E-56
+    2    1    0.14282E-07    0.10000E+01    0.17891E+05    0.37546E-48    0.16701E-57    0.33521E-55
+    2    1    0.14282E-07    0.10000E+01    0.14428E+05    0.23872E-47    0.18921E-56    0.21667E-54
+    2    1    0.14282E-07    0.10000E+01    0.11635E+05    0.14540E-46    0.21527E-55    0.13338E-53
+    2    1    0.14282E-07    0.10000E+01    0.93834E+04    0.88067E-46    0.29254E-54    0.77578E-53
+    2    1    0.14282E-07    0.10000E+01    0.75673E+04    0.60553E-45    0.58326E-53    0.43430E-52
+    2    1    0.14282E-07    0.10000E+01    0.61026E+04    0.57349E-44    0.15051E-51    0.27098E-51
+    2    1    0.14282E-07    0.10000E+01    0.49215E+04    0.72317E-43    0.40568E-50    0.24252E-50
+    2    1    0.14282E-07    0.10000E+01    0.39689E+04    0.10013E-41    0.10738E-48    0.29366E-49
+    2    1    0.14282E-07    0.10000E+01    0.32008E+04    0.43649E-39    0.90644E-46    0.11889E-46
+    2    1    0.14282E-07    0.10000E+01    0.25813E+04    0.31082E-30    0.14709E-36    0.76420E-38
+    2    1    0.14282E-07    0.10000E+01    0.20817E+04    0.57088E-14    0.11967E-19    0.12009E-21
+    2    1    0.14282E-07    0.10000E+01    0.16788E+04    0.18924E-08    0.17356E-13    0.35443E-16
+    2    1    0.14282E-07    0.10000E+01    0.13538E+04    0.40020E-08    0.65652E-13    0.69167E-16
+    2    1    0.14282E-07    0.10000E+01    0.10918E+04    0.83184E-08    0.24397E-12    0.13540E-15
+    2    1    0.14282E-07    0.10000E+01    0.88049E+03    0.16972E-07    0.89579E-12    0.26406E-15
+    2    1    0.14282E-07    0.10000E+01    0.71007E+03    0.34023E-07    0.32552E-11    0.51154E-15
+    2    1    0.14282E-07    0.10000E+01    0.57264E+03    0.67146E-07    0.11564E-10    0.98359E-15
+    2    1    0.14282E-07    0.10000E+01    0.46180E+03    0.13048E-06    0.38856E-10    0.18743E-14
+    2    1    0.14282E-07    0.10000E+01    0.37242E+03    0.24843E-06    0.11841E-09    0.35173E-14
+    2    1    0.14282E-07    0.10000E+01    0.30034E+03    0.45802E-06    0.31748E-09    0.64185E-14
+    2    1    0.14282E-07    0.10000E+01    0.24221E+03    0.80590E-06    0.74114E-09    0.11214E-13
+    2    1    0.14282E-07    0.10000E+01    0.19533E+03    0.12691E-05    0.14082E-08    0.17584E-13
+    2    1    0.14282E-07    0.10000E+01    0.15752E+03    0.12691E-05    0.14082E-08    0.17584E-13
+    2    1    0.24920E-07    0.10000E+01    0.80645E+05    0.56799E-54    0.42354E-65    0.84609E-61
+    2    1    0.24920E-07    0.10000E+01    0.65036E+05    0.47921E-53    0.67115E-64    0.71433E-60
+    2    1    0.24920E-07    0.10000E+01    0.52449E+05    0.40621E-52    0.89589E-63    0.60589E-59
+    2    1    0.24920E-07    0.10000E+01    0.42297E+05    0.30398E-51    0.12027E-61    0.45392E-58
+    2    1    0.24920E-07    0.10000E+01    0.34111E+05    0.21705E-50    0.16193E-60    0.32479E-57
+    2    1    0.24920E-07    0.10000E+01    0.27509E+05    0.15323E-49    0.21238E-59    0.23013E-56
+    2    1    0.24920E-07    0.10000E+01    0.22184E+05    0.10612E-48    0.26744E-58    0.16041E-55
+    2    1    0.24920E-07    0.10000E+01    0.17891E+05    0.71084E-48    0.32040E-57    0.10863E-54
+    2    1    0.24920E-07    0.10000E+01    0.14428E+05    0.45587E-47    0.36499E-56    0.70834E-54
+    2    1    0.24920E-07    0.10000E+01    0.11635E+05    0.27903E-46    0.40136E-55    0.44191E-53
+    2    1    0.24920E-07    0.10000E+01    0.93834E+04    0.16495E-45    0.47141E-54    0.26116E-52
+    2    1    0.24920E-07    0.10000E+01    0.75673E+04    0.10159E-44    0.76552E-53    0.14621E-51
+    2    1    0.24920E-07    0.10000E+01    0.61026E+04    0.79681E-44    0.18024E-51    0.85225E-51
+    2    1    0.24920E-07    0.10000E+01    0.49215E+04    0.88844E-43    0.47589E-50    0.66813E-50
+    2    1    0.24920E-07    0.10000E+01    0.39689E+04    0.11805E-41    0.12392E-48    0.74971E-49
+    2    1    0.24920E-07    0.10000E+01    0.32008E+04    0.50367E-39    0.10197E-45    0.29630E-46
+    2    1    0.24920E-07    0.10000E+01    0.25813E+04    0.34881E-30    0.15962E-36    0.18551E-37
+    2    1    0.24920E-07    0.10000E+01    0.20817E+04    0.61657E-14    0.12352E-19    0.27613E-21
+    2    1    0.24920E-07    0.10000E+01    0.16788E+04    0.19921E-08    0.17496E-13    0.77232E-16
+    2    1    0.24920E-07    0.10000E+01    0.13538E+04    0.41442E-08    0.65869E-13    0.14362E-15
+    2    1    0.24920E-07    0.10000E+01    0.10918E+04    0.85146E-08    0.24393E-12    0.27015E-15
+    2    1    0.24920E-07    0.10000E+01    0.88049E+03    0.17227E-07    0.89340E-12    0.50995E-15
+    2    1    0.24920E-07    0.10000E+01    0.71007E+03    0.34324E-07    0.32407E-11    0.96220E-15
+    2    1    0.24920E-07    0.10000E+01    0.57264E+03    0.67430E-07    0.11499E-10    0.18117E-14
+    2    1    0.24920E-07    0.10000E+01    0.46180E+03    0.13060E-06    0.38609E-10    0.33962E-14
+    2    1    0.24920E-07    0.10000E+01    0.37242E+03    0.24803E-06    0.11760E-09    0.62949E-14
+    2    1    0.24920E-07    0.10000E+01    0.30034E+03    0.45649E-06    0.31523E-09    0.11385E-13
+    2    1    0.24920E-07    0.10000E+01    0.24221E+03    0.80227E-06    0.73576E-09    0.19769E-13
+    2    1    0.24920E-07    0.10000E+01    0.19533E+03    0.12625E-05    0.13979E-08    0.30878E-13
+    2    1    0.24920E-07    0.10000E+01    0.15752E+03    0.12625E-05    0.13979E-08    0.30878E-13
+    2    1    0.43485E-07    0.10000E+01    0.80645E+05    0.10510E-53    0.78406E-65    0.26954E-60
+    2    1    0.43485E-07    0.10000E+01    0.65036E+05    0.88705E-53    0.12428E-63    0.22764E-59
+    2    1    0.43485E-07    0.10000E+01    0.52449E+05    0.75217E-52    0.16602E-62    0.19314E-58
+    2    1    0.43485E-07    0.10000E+01    0.42297E+05    0.56321E-51    0.22317E-61    0.14477E-57
+    2    1    0.43485E-07    0.10000E+01    0.34111E+05    0.40259E-50    0.30113E-60    0.10369E-56
+    2    1    0.43485E-07    0.10000E+01    0.27509E+05    0.28477E-49    0.39653E-59    0.73588E-56
+    2    1    0.43485E-07    0.10000E+01    0.22184E+05    0.19790E-48    0.50282E-58    0.51431E-55
+    2    1    0.43485E-07    0.10000E+01    0.17891E+05    0.13334E-47    0.60891E-57    0.34986E-54
+    2    1    0.43485E-07    0.10000E+01    0.14428E+05    0.86274E-47    0.70205E-56    0.22981E-53
+    2    1    0.43485E-07    0.10000E+01    0.11635E+05    0.53336E-46    0.76941E-55    0.14498E-52
+    2    1    0.43485E-07    0.10000E+01    0.93834E+04    0.31489E-45    0.83738E-54    0.86955E-52
+    2    1    0.43485E-07    0.10000E+01    0.75673E+04    0.18378E-44    0.11296E-52    0.49107E-51
+    2    1    0.43485E-07    0.10000E+01    0.61026E+04    0.12414E-43    0.23332E-51    0.27625E-50
+    2    1    0.43485E-07    0.10000E+01    0.49215E+04    0.11934E-42    0.59575E-50    0.19471E-49
+    2    1    0.43485E-07    0.10000E+01    0.39689E+04    0.14919E-41    0.15251E-48    0.20142E-48
+    2    1    0.43485E-07    0.10000E+01    0.32008E+04    0.62017E-39    0.12195E-45    0.77746E-46
+    2    1    0.43485E-07    0.10000E+01    0.25813E+04    0.41582E-30    0.18220E-36    0.47847E-37
+    2    1    0.43485E-07    0.10000E+01    0.20817E+04    0.69929E-14    0.13076E-19    0.68378E-21
+    2    1    0.43485E-07    0.10000E+01    0.16788E+04    0.21769E-08    0.17804E-13    0.18225E-15
+    2    1    0.43485E-07    0.10000E+01    0.13538E+04    0.44115E-08    0.66480E-13    0.32148E-15
+    2    1    0.43485E-07    0.10000E+01    0.10918E+04    0.88927E-08    0.24471E-12    0.57669E-15
+    2    1    0.43485E-07    0.10000E+01    0.88049E+03    0.17741E-07    0.89234E-12    0.10440E-14
+    2    1    0.43485E-07    0.10000E+01    0.71007E+03    0.34977E-07    0.32269E-11    0.19002E-14
+    2    1    0.43485E-07    0.10000E+01    0.57264E+03    0.68173E-07    0.11426E-10    0.34708E-14
+    2    1    0.43485E-07    0.10000E+01    0.46180E+03    0.13126E-06    0.38313E-10    0.63469E-14
+    2    1    0.43485E-07    0.10000E+01    0.37242E+03    0.24822E-06    0.11661E-09    0.11538E-13
+    2    1    0.43485E-07    0.10000E+01    0.30034E+03    0.45546E-06    0.31243E-09    0.20569E-13
+    2    1    0.43485E-07    0.10000E+01    0.24221E+03    0.79881E-06    0.72902E-09    0.35353E-13
+    2    1    0.43485E-07    0.10000E+01    0.19533E+03    0.12554E-05    0.13849E-08    0.54870E-13
+    2    1    0.43485E-07    0.10000E+01    0.15752E+03    0.12554E-05    0.13849E-08    0.54870E-13
+    2    1    0.75878E-07    0.10000E+01    0.80645E+05    0.19293E-53    0.14399E-64    0.85056E-60
+    2    1    0.75878E-07    0.10000E+01    0.65036E+05    0.16289E-52    0.22830E-63    0.71854E-59
+    2    1    0.75878E-07    0.10000E+01    0.52449E+05    0.13816E-51    0.30518E-62    0.60980E-58
+    2    1    0.75878E-07    0.10000E+01    0.42297E+05    0.10351E-50    0.41074E-61    0.45730E-57
+    2    1    0.75878E-07    0.10000E+01    0.34111E+05    0.74069E-50    0.55532E-60    0.32780E-56
+    2    1    0.75878E-07    0.10000E+01    0.27509E+05    0.52484E-49    0.73379E-59    0.23296E-55
+    2    1    0.75878E-07    0.10000E+01    0.22184E+05    0.36584E-48    0.93610E-58    0.16319E-54
+    2    1    0.75878E-07    0.10000E+01    0.17891E+05    0.24774E-47    0.11445E-56    0.11143E-53
+    2    1    0.75878E-07    0.10000E+01    0.14428E+05    0.16158E-46    0.13367E-55    0.73631E-53
+    2    1    0.75878E-07    0.10000E+01    0.11635E+05    0.10097E-45    0.14784E-54    0.46877E-52
+    2    1    0.75878E-07    0.10000E+01    0.93834E+04    0.60091E-45    0.15625E-53    0.28479E-51
+    2    1    0.75878E-07    0.10000E+01    0.75673E+04    0.34403E-44    0.18447E-52    0.16269E-50
+    2    1    0.75878E-07    0.10000E+01    0.61026E+04    0.21087E-43    0.32835E-51    0.90097E-50
+    2    1    0.75878E-07    0.10000E+01    0.49215E+04    0.17543E-42    0.79923E-50    0.58681E-49
+    2    1    0.75878E-07    0.10000E+01    0.39689E+04    0.20309E-41    0.20144E-48    0.56056E-48
+    2    1    0.75878E-07    0.10000E+01    0.32008E+04    0.82056E-39    0.15688E-45    0.21124E-45
+    2    1    0.75878E-07    0.10000E+01    0.25813E+04    0.53309E-30    0.22263E-36    0.12883E-36
+    2    1    0.75878E-07    0.10000E+01    0.20817E+04    0.84860E-14    0.14460E-19    0.17965E-20
+    2    1    0.75878E-07    0.10000E+01    0.16788E+04    0.25209E-08    0.18518E-13    0.46195E-15
+    2    1    0.75878E-07    0.10000E+01    0.13538E+04    0.49208E-08    0.68214E-13    0.77574E-15
+    2    1    0.75878E-07    0.10000E+01    0.10918E+04    0.96387E-08    0.24856E-12    0.13259E-14
+    2    1    0.75878E-07    0.10000E+01    0.88049E+03    0.18811E-07    0.89969E-12    0.22918E-14
+    2    1    0.75878E-07    0.10000E+01    0.71007E+03    0.36464E-07    0.32364E-11    0.39946E-14
+    2    1    0.75878E-07    0.10000E+01    0.57264E+03    0.70156E-07    0.11419E-10    0.70160E-14
+    2    1    0.75878E-07    0.10000E+01    0.46180E+03    0.13376E-06    0.38203E-10    0.12400E-13
+    2    1    0.75878E-07    0.10000E+01    0.37242E+03    0.25111E-06    0.11612E-09    0.21917E-13
+    2    1    0.75878E-07    0.10000E+01    0.30034E+03    0.45840E-06    0.31085E-09    0.38230E-13
+    2    1    0.75878E-07    0.10000E+01    0.24221E+03    0.80111E-06    0.72499E-09    0.64669E-13
+    2    1    0.75878E-07    0.10000E+01    0.19533E+03    0.12563E-05    0.13768E-08    0.99357E-13
+    2    1    0.75878E-07    0.10000E+01    0.15752E+03    0.12563E-05    0.13768E-08    0.99357E-13
+    2    1    0.13240E-06    0.10000E+01    0.80645E+05    0.35149E-53    0.26243E-64    0.26493E-59
+    2    1    0.13240E-06    0.10000E+01    0.65036E+05    0.29686E-52    0.41619E-63    0.22387E-58
+    2    1    0.13240E-06    0.10000E+01    0.52449E+05    0.25186E-51    0.55670E-62    0.19003E-57
+    2    1    0.13240E-06    0.10000E+01    0.42297E+05    0.18879E-50    0.75005E-61    0.14256E-56
+    2    1    0.13240E-06    0.10000E+01    0.34111E+05    0.13522E-49    0.10159E-59    0.10226E-55
+    2    1    0.13240E-06    0.10000E+01    0.27509E+05    0.95960E-49    0.13464E-58    0.72760E-55
+    2    1    0.13240E-06    0.10000E+01    0.22184E+05    0.67063E-48    0.17264E-57    0.51065E-54
+    2    1    0.13240E-06    0.10000E+01    0.17891E+05    0.45613E-47    0.21282E-56    0.34977E-53
+    2    1    0.13240E-06    0.10000E+01    0.14428E+05    0.29957E-46    0.25150E-55    0.23226E-52
+    2    1    0.13240E-06    0.10000E+01    0.11635E+05    0.18905E-45    0.28182E-54    0.14896E-51
+    2    1    0.13240E-06    0.10000E+01    0.93834E+04    0.11374E-44    0.29637E-53    0.91462E-51
+    2    1    0.13240E-06    0.10000E+01    0.75673E+04    0.64991E-44    0.32234E-52    0.52854E-50
+    2    1    0.13240E-06    0.10000E+01    0.61026E+04    0.37686E-43    0.49738E-51    0.29128E-49
+    2    1    0.13240E-06    0.10000E+01    0.49215E+04    0.27755E-42    0.11389E-49    0.17945E-48
+    2    1    0.13240E-06    0.10000E+01    0.39689E+04    0.29504E-41    0.28323E-48    0.15939E-47
+    2    1    0.13240E-06    0.10000E+01    0.32008E+04    0.11576E-38    0.21621E-45    0.58612E-45
+    2    1    0.13240E-06    0.10000E+01    0.25813E+04    0.73259E-30    0.29238E-36    0.35614E-36
+    2    1    0.13240E-06    0.10000E+01    0.20817E+04    0.11079E-13    0.16893E-19    0.49130E-20
+    2    1    0.13240E-06    0.10000E+01    0.16788E+04    0.31279E-08    0.19813E-13    0.12354E-14
+    2    1    0.13240E-06    0.10000E+01    0.13538E+04    0.58205E-08    0.71440E-13    0.19932E-14
+    2    1    0.13240E-06    0.10000E+01    0.10918E+04    0.10963E-07    0.25607E-12    0.32657E-14
+    2    1    0.13240E-06    0.10000E+01    0.88049E+03    0.20725E-07    0.91554E-12    0.54012E-14
+    2    1    0.13240E-06    0.10000E+01    0.71007E+03    0.39159E-07    0.32643E-11    0.90015E-14
+    2    1    0.13240E-06    0.10000E+01    0.57264E+03    0.73823E-07    0.11448E-10    0.15127E-13
+    2    1    0.13240E-06    0.10000E+01    0.46180E+03    0.13853E-06    0.38151E-10    0.25647E-13
+    2    1    0.13240E-06    0.10000E+01    0.37242E+03    0.25699E-06    0.11569E-09    0.43694E-13
+    2    1    0.13240E-06    0.10000E+01    0.30034E+03    0.46510E-06    0.30928E-09    0.73951E-13
+    2    1    0.13240E-06    0.10000E+01    0.24221E+03    0.80796E-06    0.72072E-09    0.12224E-12
+    2    1    0.13240E-06    0.10000E+01    0.19533E+03    0.12624E-05    0.13681E-08    0.18497E-12
+    2    1    0.13240E-06    0.10000E+01    0.15752E+03    0.12624E-05    0.13681E-08    0.18497E-12
+    2    1    0.23103E-06    0.10000E+01    0.80645E+05    0.62184E-53    0.46434E-64    0.57270E-59
+    2    1    0.23103E-06    0.10000E+01    0.65036E+05    0.52524E-52    0.73646E-63    0.48397E-58
+    2    1    0.23103E-06    0.10000E+01    0.52449E+05    0.44567E-51    0.98531E-62    0.41084E-57
+    2    1    0.23103E-06    0.10000E+01    0.42297E+05    0.33413E-50    0.13280E-60    0.30827E-56
+    2    1    0.23103E-06    0.10000E+01    0.34111E+05    0.23939E-49    0.17998E-59    0.22118E-55
+    2    1    0.23103E-06    0.10000E+01    0.27509E+05    0.16998E-48    0.23878E-58    0.15742E-54
+    2    1    0.23103E-06    0.10000E+01    0.22184E+05    0.11890E-47    0.30673E-57    0.11055E-53
+    2    1    0.23103E-06    0.10000E+01    0.17891E+05    0.80993E-47    0.37918E-56    0.75799E-53
+    2    1    0.23103E-06    0.10000E+01    0.14428E+05    0.53319E-46    0.44995E-55    0.50413E-52
+    2    1    0.23103E-06    0.10000E+01    0.11635E+05    0.33767E-45    0.50678E-54    0.32409E-51
+    2    1    0.23103E-06    0.10000E+01    0.93834E+04    0.20402E-44    0.53377E-53    0.19968E-50
+    2    1    0.23103E-06    0.10000E+01    0.75673E+04    0.11677E-43    0.56856E-52    0.11585E-49
+    2    1    0.23103E-06    0.10000E+01    0.61026E+04    0.66804E-43    0.83475E-51    0.63832E-49
+    2    1    0.23103E-06    0.10000E+01    0.49215E+04    0.47306E-42    0.18618E-49    0.38697E-48
+    2    1    0.23103E-06    0.10000E+01    0.39689E+04    0.48639E-41    0.46084E-48    0.33532E-47
+    2    1    0.23103E-06    0.10000E+01    0.32008E+04    0.18868E-38    0.34985E-45    0.12217E-44
+    2    1    0.23103E-06    0.10000E+01    0.25813E+04    0.11844E-29    0.46547E-36    0.74197E-36
+    2    1    0.23103E-06    0.10000E+01    0.20817E+04    0.17609E-13    0.25667E-19    0.10221E-19
+    2    1    0.23103E-06    0.10000E+01    0.16788E+04    0.48777E-08    0.28888E-13    0.25561E-14
+    2    1    0.23103E-06    0.10000E+01    0.13538E+04    0.88944E-08    0.10303E-12    0.40733E-14
+    2    1    0.23103E-06    0.10000E+01    0.10918E+04    0.16460E-07    0.36612E-12    0.65838E-14
+    2    1    0.23103E-06    0.10000E+01    0.88049E+03    0.30655E-07    0.13004E-11    0.10728E-13
+    2    1    0.23103E-06    0.10000E+01    0.71007E+03    0.57200E-07    0.46142E-11    0.17596E-13
+    2    1    0.23103E-06    0.10000E+01    0.57264E+03    0.10673E-06    0.16128E-10    0.29079E-13
+    2    1    0.23103E-06    0.10000E+01    0.46180E+03    0.19864E-06    0.53633E-10    0.48484E-13
+    2    1    0.23103E-06    0.10000E+01    0.37242E+03    0.36616E-06    0.16242E-09    0.81323E-13
+    2    1    0.23103E-06    0.10000E+01    0.30034E+03    0.65958E-06    0.43388E-09    0.13580E-12
+    2    1    0.23103E-06    0.10000E+01    0.24221E+03    0.11421E-05    0.10106E-08    0.22208E-12
+    2    1    0.23103E-06    0.10000E+01    0.19533E+03    0.17808E-05    0.19179E-08    0.33363E-12
+    2    1    0.23103E-06    0.10000E+01    0.15752E+03    0.17808E-05    0.19179E-08    0.33363E-12
+    2    1    0.40314E-06    0.10000E+01    0.80645E+05    0.10851E-52    0.81024E-64    0.99933E-59
+    2    1    0.40314E-06    0.10000E+01    0.65036E+05    0.91650E-52    0.12851E-62    0.84451E-58
+    2    1    0.40314E-06    0.10000E+01    0.52449E+05    0.77767E-51    0.17193E-61    0.71690E-57
+    2    1    0.40314E-06    0.10000E+01    0.42297E+05    0.58304E-50    0.23173E-60    0.53791E-56
+    2    1    0.40314E-06    0.10000E+01    0.34111E+05    0.41772E-49    0.31405E-59    0.38594E-55
+    2    1    0.40314E-06    0.10000E+01    0.27509E+05    0.29661E-48    0.41666E-58    0.27470E-54
+    2    1    0.40314E-06    0.10000E+01    0.22184E+05    0.20747E-47    0.53522E-57    0.19291E-53
+    2    1    0.40314E-06    0.10000E+01    0.17891E+05    0.14133E-46    0.66165E-56    0.13226E-52
+    2    1    0.40314E-06    0.10000E+01    0.14428E+05    0.93039E-46    0.78513E-55    0.87968E-52
+    2    1    0.40314E-06    0.10000E+01    0.11635E+05    0.58921E-45    0.88430E-54    0.56552E-51
+    2    1    0.40314E-06    0.10000E+01    0.93834E+04    0.35600E-44    0.93140E-53    0.34843E-50
+    2    1    0.40314E-06    0.10000E+01    0.75673E+04    0.20375E-43    0.99210E-52    0.20216E-49
+    2    1    0.40314E-06    0.10000E+01    0.61026E+04    0.11657E-42    0.14566E-50    0.11138E-48
+    2    1    0.40314E-06    0.10000E+01    0.49215E+04    0.82547E-42    0.32487E-49    0.67524E-48
+    2    1    0.40314E-06    0.10000E+01    0.39689E+04    0.84872E-41    0.80414E-48    0.58511E-47
+    2    1    0.40314E-06    0.10000E+01    0.32008E+04    0.32923E-38    0.61047E-45    0.21319E-44
+    2    1    0.40314E-06    0.10000E+01    0.25813E+04    0.20668E-29    0.81221E-36    0.12947E-35
+    2    1    0.40314E-06    0.10000E+01    0.20817E+04    0.30727E-13    0.44788E-19    0.17834E-19
+    2    1    0.40314E-06    0.10000E+01    0.16788E+04    0.85112E-08    0.50407E-13    0.44602E-14
+    2    1    0.40314E-06    0.10000E+01    0.13538E+04    0.15520E-07    0.17978E-12    0.71077E-14
+    2    1    0.40314E-06    0.10000E+01    0.10918E+04    0.28723E-07    0.63886E-12    0.11488E-13
+    2    1    0.40314E-06    0.10000E+01    0.88049E+03    0.53491E-07    0.22692E-11    0.18721E-13
+    2    1    0.40314E-06    0.10000E+01    0.71007E+03    0.99810E-07    0.80516E-11    0.30703E-13
+    2    1    0.40314E-06    0.10000E+01    0.57264E+03    0.18623E-06    0.28142E-10    0.50741E-13
+    2    1    0.40314E-06    0.10000E+01    0.46180E+03    0.34661E-06    0.93586E-10    0.84602E-13
+    2    1    0.40314E-06    0.10000E+01    0.37242E+03    0.63892E-06    0.28342E-09    0.14190E-12
+    2    1    0.40314E-06    0.10000E+01    0.30034E+03    0.11509E-05    0.75710E-09    0.23695E-12
+    2    1    0.40314E-06    0.10000E+01    0.24221E+03    0.19928E-05    0.17635E-08    0.38751E-12
+    2    1    0.40314E-06    0.10000E+01    0.19533E+03    0.31074E-05    0.33466E-08    0.58216E-12
+    2    1    0.40314E-06    0.10000E+01    0.15752E+03    0.31074E-05    0.33466E-08    0.58216E-12
+    2    1    0.70346E-06    0.10000E+01    0.80645E+05    0.18934E-52    0.14138E-63    0.17438E-58
+    2    1    0.70346E-06    0.10000E+01    0.65036E+05    0.15992E-51    0.22424E-62    0.14736E-57
+    2    1    0.70346E-06    0.10000E+01    0.52449E+05    0.13570E-50    0.30001E-61    0.12509E-56
+    2    1    0.70346E-06    0.10000E+01    0.42297E+05    0.10174E-49    0.40436E-60    0.93861E-56
+    2    1    0.70346E-06    0.10000E+01    0.34111E+05    0.72889E-49    0.54800E-59    0.67344E-55
+    2    1    0.70346E-06    0.10000E+01    0.27509E+05    0.51756E-48    0.72704E-58    0.47933E-54
+    2    1    0.70346E-06    0.10000E+01    0.22184E+05    0.36203E-47    0.93392E-57    0.33662E-53
+    2    1    0.70346E-06    0.10000E+01    0.17891E+05    0.24661E-46    0.11545E-55    0.23079E-52
+    2    1    0.70346E-06    0.10000E+01    0.14428E+05    0.16235E-45    0.13700E-54    0.15350E-51
+    2    1    0.70346E-06    0.10000E+01    0.11635E+05    0.10281E-44    0.15430E-53    0.98681E-51
+    2    1    0.70346E-06    0.10000E+01    0.93834E+04    0.62119E-44    0.16252E-52    0.60798E-50
+    2    1    0.70346E-06    0.10000E+01    0.75673E+04    0.35554E-43    0.17312E-51    0.35275E-49
+    2    1    0.70346E-06    0.10000E+01    0.61026E+04    0.20340E-42    0.25417E-50    0.19436E-48
+    2    1    0.70346E-06    0.10000E+01    0.49215E+04    0.14404E-41    0.56687E-49    0.11783E-47
+    2    1    0.70346E-06    0.10000E+01    0.39689E+04    0.14810E-40    0.14032E-47    0.10210E-46
+    2    1    0.70346E-06    0.10000E+01    0.32008E+04    0.57449E-38    0.10652E-44    0.37200E-44
+    2    1    0.70346E-06    0.10000E+01    0.25813E+04    0.36064E-29    0.14173E-35    0.22592E-35
+    2    1    0.70346E-06    0.10000E+01    0.20817E+04    0.53617E-13    0.78152E-19    0.31120E-19
+    2    1    0.70346E-06    0.10000E+01    0.16788E+04    0.14852E-07    0.87958E-13    0.77828E-14
+    2    1    0.70346E-06    0.10000E+01    0.13538E+04    0.27082E-07    0.31370E-12    0.12403E-13
+    2    1    0.70346E-06    0.10000E+01    0.10918E+04    0.50119E-07    0.11148E-11    0.20046E-13
+    2    1    0.70346E-06    0.10000E+01    0.88049E+03    0.93338E-07    0.39596E-11    0.32666E-13
+    2    1    0.70346E-06    0.10000E+01    0.71007E+03    0.17416E-06    0.14050E-10    0.53576E-13
+    2    1    0.70346E-06    0.10000E+01    0.57264E+03    0.32497E-06    0.49106E-10    0.88540E-13
+    2    1    0.70346E-06    0.10000E+01    0.46180E+03    0.60481E-06    0.16330E-09    0.14763E-12
+    2    1    0.70346E-06    0.10000E+01    0.37242E+03    0.11149E-05    0.49454E-09    0.24761E-12
+    2    1    0.70346E-06    0.10000E+01    0.30034E+03    0.20083E-05    0.13211E-08    0.41347E-12
+    2    1    0.70346E-06    0.10000E+01    0.24221E+03    0.34773E-05    0.30771E-08    0.67618E-12
+    2    1    0.70346E-06    0.10000E+01    0.19533E+03    0.54222E-05    0.58395E-08    0.10158E-11
+    2    1    0.70346E-06    0.10000E+01    0.15752E+03    0.54222E-05    0.58395E-08    0.10158E-11
+    2    1    0.12275E-05    0.10000E+01    0.80645E+05    0.33038E-52    0.24670E-63    0.30428E-58
+    2    1    0.12275E-05    0.10000E+01    0.65036E+05    0.27906E-51    0.39128E-62    0.25714E-57
+    2    1    0.12275E-05    0.10000E+01    0.52449E+05    0.23679E-50    0.52350E-61    0.21828E-56
+    2    1    0.12275E-05    0.10000E+01    0.42297E+05    0.17752E-49    0.70559E-60    0.16378E-55
+    2    1    0.12275E-05    0.10000E+01    0.34111E+05    0.12719E-48    0.95622E-59    0.11751E-54
+    2    1    0.12275E-05    0.10000E+01    0.27509E+05    0.90311E-48    0.12686E-57    0.83640E-54
+    2    1    0.12275E-05    0.10000E+01    0.22184E+05    0.63172E-47    0.16296E-56    0.58737E-53
+    2    1    0.12275E-05    0.10000E+01    0.17891E+05    0.43032E-46    0.20146E-55    0.40272E-52
+    2    1    0.12275E-05    0.10000E+01    0.14428E+05    0.28329E-45    0.23906E-54    0.26785E-51
+    2    1    0.12275E-05    0.10000E+01    0.11635E+05    0.17940E-44    0.26925E-53    0.17219E-50
+    2    1    0.12275E-05    0.10000E+01    0.93834E+04    0.10839E-43    0.28359E-52    0.10609E-49
+    2    1    0.12275E-05    0.10000E+01    0.75673E+04    0.62039E-43    0.30208E-51    0.61553E-49
+    2    1    0.12275E-05    0.10000E+01    0.61026E+04    0.35493E-42    0.44350E-50    0.33914E-48
+    2    1    0.12275E-05    0.10000E+01    0.49215E+04    0.25134E-41    0.98915E-49    0.20560E-47
+    2    1    0.12275E-05    0.10000E+01    0.39689E+04    0.25842E-40    0.24485E-47    0.17815E-46
+    2    1    0.12275E-05    0.10000E+01    0.32008E+04    0.10025E-37    0.18588E-44    0.64912E-44
+    2    1    0.12275E-05    0.10000E+01    0.25813E+04    0.62929E-29    0.24730E-35    0.39421E-35
+    2    1    0.12275E-05    0.10000E+01    0.20817E+04    0.93558E-13    0.13637E-18    0.54302E-19
+    2    1    0.12275E-05    0.10000E+01    0.16788E+04    0.25915E-07    0.15348E-12    0.13581E-13
+    2    1    0.12275E-05    0.10000E+01    0.13538E+04    0.47256E-07    0.54739E-12    0.21642E-13
+    2    1    0.12275E-05    0.10000E+01    0.10918E+04    0.87455E-07    0.19452E-11    0.34980E-13
+    2    1    0.12275E-05    0.10000E+01    0.88049E+03    0.16287E-06    0.69092E-11    0.57001E-13
+    2    1    0.12275E-05    0.10000E+01    0.71007E+03    0.30390E-06    0.24516E-10    0.93486E-13
+    2    1    0.12275E-05    0.10000E+01    0.57264E+03    0.56705E-06    0.85687E-10    0.15450E-12
+    2    1    0.12275E-05    0.10000E+01    0.46180E+03    0.10554E-05    0.28495E-09    0.25760E-12
+    2    1    0.12275E-05    0.10000E+01    0.37242E+03    0.19454E-05    0.86295E-09    0.43207E-12
+    2    1    0.12275E-05    0.10000E+01    0.30034E+03    0.35043E-05    0.23052E-08    0.72148E-12
+    2    1    0.12275E-05    0.10000E+01    0.24221E+03    0.60678E-05    0.53694E-08    0.11799E-11
+    2    1    0.12275E-05    0.10000E+01    0.19533E+03    0.94614E-05    0.10190E-07    0.17726E-11
+    2    1    0.12275E-05    0.10000E+01    0.15752E+03    0.94614E-05    0.10190E-07    0.17726E-11
+    2    1    0.21419E-05    0.10000E+01    0.80645E+05    0.57650E-52    0.43048E-63    0.53095E-58
+    2    1    0.21419E-05    0.10000E+01    0.65036E+05    0.48694E-51    0.68276E-62    0.44869E-57
+    2    1    0.21419E-05    0.10000E+01    0.52449E+05    0.41318E-50    0.91347E-61    0.38089E-56
+    2    1    0.21419E-05    0.10000E+01    0.42297E+05    0.30977E-49    0.12312E-59    0.28579E-55
+    2    1    0.21419E-05    0.10000E+01    0.34111E+05    0.22193E-48    0.16686E-58    0.20505E-54
+    2    1    0.21419E-05    0.10000E+01    0.27509E+05    0.15759E-47    0.22137E-57    0.14595E-53
+    2    1    0.21419E-05    0.10000E+01    0.22184E+05    0.11023E-46    0.28436E-56    0.10249E-52
+    2    1    0.21419E-05    0.10000E+01    0.17891E+05    0.75088E-46    0.35154E-55    0.70273E-52
+    2    1    0.21419E-05    0.10000E+01    0.14428E+05    0.49432E-45    0.41714E-54    0.46738E-51
+    2    1    0.21419E-05    0.10000E+01    0.11635E+05    0.31305E-44    0.46983E-53    0.30046E-50
+    2    1    0.21419E-05    0.10000E+01    0.93834E+04    0.18914E-43    0.49485E-52    0.18512E-49
+    2    1    0.21419E-05    0.10000E+01    0.75673E+04    0.10825E-42    0.52710E-51    0.10741E-48
+    2    1    0.21419E-05    0.10000E+01    0.61026E+04    0.61933E-42    0.77389E-50    0.59178E-48
+    2    1    0.21419E-05    0.10000E+01    0.49215E+04    0.43857E-41    0.17260E-48    0.35876E-47
+    2    1    0.21419E-05    0.10000E+01    0.39689E+04    0.45093E-40    0.42724E-47    0.31087E-46
+    2    1    0.21419E-05    0.10000E+01    0.32008E+04    0.17492E-37    0.32434E-44    0.11327E-43
+    2    1    0.21419E-05    0.10000E+01    0.25813E+04    0.10981E-28    0.43153E-35    0.68787E-35
+    2    1    0.21419E-05    0.10000E+01    0.20817E+04    0.16325E-12    0.23796E-18    0.94754E-19
+    2    1    0.21419E-05    0.10000E+01    0.16788E+04    0.45220E-07    0.26781E-12    0.23697E-13
+    2    1    0.21419E-05    0.10000E+01    0.13538E+04    0.82459E-07    0.95516E-12    0.37764E-13
+    2    1    0.21419E-05    0.10000E+01    0.10918E+04    0.15260E-06    0.33943E-11    0.61038E-13
+    2    1    0.21419E-05    0.10000E+01    0.88049E+03    0.28420E-06    0.12056E-10    0.99462E-13
+    2    1    0.21419E-05    0.10000E+01    0.71007E+03    0.53029E-06    0.42778E-10    0.16313E-12
+    2    1    0.21419E-05    0.10000E+01    0.57264E+03    0.98946E-06    0.14952E-09    0.26959E-12
+    2    1    0.21419E-05    0.10000E+01    0.46180E+03    0.18415E-05    0.49722E-09    0.44949E-12
+    2    1    0.21419E-05    0.10000E+01    0.37242E+03    0.33946E-05    0.15058E-08    0.75393E-12
+    2    1    0.21419E-05    0.10000E+01    0.30034E+03    0.61149E-05    0.40225E-08    0.12589E-11
+    2    1    0.21419E-05    0.10000E+01    0.24221E+03    0.10588E-04    0.93693E-08    0.20589E-11
+    2    1    0.21419E-05    0.10000E+01    0.19533E+03    0.16510E-04    0.17780E-07    0.30930E-11
+    2    1    0.21419E-05    0.10000E+01    0.15752E+03    0.16510E-04    0.17780E-07    0.30930E-11
+    2    1    0.37375E-05    0.10000E+01    0.80645E+05    0.10060E-51    0.75117E-63    0.92647E-58
+    2    1    0.37375E-05    0.10000E+01    0.65036E+05    0.84968E-51    0.11914E-61    0.78293E-57
+    2    1    0.37375E-05    0.10000E+01    0.52449E+05    0.72097E-50    0.15940E-60    0.66463E-56
+    2    1    0.37375E-05    0.10000E+01    0.42297E+05    0.54053E-49    0.21484E-59    0.49869E-55
+    2    1    0.37375E-05    0.10000E+01    0.34111E+05    0.38726E-48    0.29115E-58    0.35780E-54
+    2    1    0.37375E-05    0.10000E+01    0.27509E+05    0.27498E-47    0.38628E-57    0.25467E-53
+    2    1    0.37375E-05    0.10000E+01    0.22184E+05    0.19235E-46    0.49619E-56    0.17884E-52
+    2    1    0.37375E-05    0.10000E+01    0.17891E+05    0.13102E-45    0.61341E-55    0.12262E-51
+    2    1    0.37375E-05    0.10000E+01    0.14428E+05    0.86256E-45    0.72789E-54    0.81554E-51
+    2    1    0.37375E-05    0.10000E+01    0.11635E+05    0.54625E-44    0.81982E-53    0.52429E-50
+    2    1    0.37375E-05    0.10000E+01    0.93834E+04    0.33004E-43    0.86349E-52    0.32302E-49
+    2    1    0.37375E-05    0.10000E+01    0.75673E+04    0.18890E-42    0.91977E-51    0.18742E-48
+    2    1    0.37375E-05    0.10000E+01    0.61026E+04    0.10807E-41    0.13504E-49    0.10326E-47
+    2    1    0.37375E-05    0.10000E+01    0.49215E+04    0.76528E-41    0.30118E-48    0.62601E-47
+    2    1    0.37375E-05    0.10000E+01    0.39689E+04    0.78684E-40    0.74551E-47    0.54244E-46
+    2    1    0.37375E-05    0.10000E+01    0.32008E+04    0.30523E-37    0.56596E-44    0.19764E-43
+    2    1    0.37375E-05    0.10000E+01    0.25813E+04    0.19161E-28    0.75300E-35    0.12003E-34
+    2    1    0.37375E-05    0.10000E+01    0.20817E+04    0.28487E-12    0.41522E-18    0.16534E-18
+    2    1    0.37375E-05    0.10000E+01    0.16788E+04    0.78907E-07    0.46732E-12    0.41350E-13
+    2    1    0.37375E-05    0.10000E+01    0.13538E+04    0.14389E-06    0.16667E-11    0.65895E-13
+    2    1    0.37375E-05    0.10000E+01    0.10918E+04    0.26628E-06    0.59228E-11    0.10651E-12
+    2    1    0.37375E-05    0.10000E+01    0.88049E+03    0.49591E-06    0.21037E-10    0.17356E-12
+    2    1    0.37375E-05    0.10000E+01    0.71007E+03    0.92533E-06    0.74645E-10    0.28465E-12
+    2    1    0.37375E-05    0.10000E+01    0.57264E+03    0.17266E-05    0.26090E-09    0.47042E-12
+    2    1    0.37375E-05    0.10000E+01    0.46180E+03    0.32134E-05    0.86762E-09    0.78433E-12
+    2    1    0.37375E-05    0.10000E+01    0.37242E+03    0.59234E-05    0.26275E-08    0.13156E-11
+    2    1    0.37375E-05    0.10000E+01    0.30034E+03    0.10670E-04    0.70190E-08    0.21968E-11
+    2    1    0.37375E-05    0.10000E+01    0.24221E+03    0.18475E-04    0.16349E-07    0.35926E-11
+    2    1    0.37375E-05    0.10000E+01    0.19533E+03    0.28808E-04    0.31026E-07    0.53971E-11
+    2    1    0.37375E-05    0.10000E+01    0.15752E+03    0.28808E-04    0.31026E-07    0.53971E-11
+    2    1    0.65217E-05    0.10000E+01    0.80645E+05    0.17553E-51    0.13107E-62    0.16166E-57
+    2    1    0.65217E-05    0.10000E+01    0.65036E+05    0.14826E-50    0.20789E-61    0.13662E-56
+    2    1    0.65217E-05    0.10000E+01    0.52449E+05    0.12581E-49    0.27814E-60    0.11597E-55
+    2    1    0.65217E-05    0.10000E+01    0.42297E+05    0.94319E-49    0.37488E-59    0.87018E-55
+    2    1    0.65217E-05    0.10000E+01    0.34111E+05    0.67575E-48    0.50804E-58    0.62434E-54
+    2    1    0.65217E-05    0.10000E+01    0.27509E+05    0.47982E-47    0.67403E-57    0.44438E-53
+    2    1    0.65217E-05    0.10000E+01    0.22184E+05    0.33563E-46    0.86583E-56    0.31207E-52
+    2    1    0.65217E-05    0.10000E+01    0.17891E+05    0.22863E-45    0.10704E-54    0.21397E-51
+    2    1    0.65217E-05    0.10000E+01    0.14428E+05    0.15051E-44    0.12701E-53    0.14231E-50
+    2    1    0.65217E-05    0.10000E+01    0.11635E+05    0.95317E-44    0.14305E-52    0.91486E-50
+    2    1    0.65217E-05    0.10000E+01    0.93834E+04    0.57590E-43    0.15067E-51    0.56365E-49
+    2    1    0.65217E-05    0.10000E+01    0.75673E+04    0.32961E-42    0.16049E-50    0.32703E-48
+    2    1    0.65217E-05    0.10000E+01    0.61026E+04    0.18857E-41    0.23563E-49    0.18018E-47
+    2    1    0.65217E-05    0.10000E+01    0.49215E+04    0.13354E-40    0.52554E-48    0.10924E-46
+    2    1    0.65217E-05    0.10000E+01    0.39689E+04    0.13730E-39    0.13009E-46    0.94653E-46
+    2    1    0.65217E-05    0.10000E+01    0.32008E+04    0.53260E-37    0.98757E-44    0.34488E-43
+    2    1    0.65217E-05    0.10000E+01    0.25813E+04    0.33434E-28    0.13139E-34    0.20944E-34
+    2    1    0.65217E-05    0.10000E+01    0.20817E+04    0.49708E-12    0.72454E-18    0.28851E-18
+    2    1    0.65217E-05    0.10000E+01    0.16788E+04    0.13769E-06    0.81545E-12    0.72153E-13
+    2    1    0.65217E-05    0.10000E+01    0.13538E+04    0.25107E-06    0.29083E-11    0.11498E-12
+    2    1    0.65217E-05    0.10000E+01    0.10918E+04    0.46465E-06    0.10335E-10    0.18585E-12
+    2    1    0.65217E-05    0.10000E+01    0.88049E+03    0.86533E-06    0.36709E-10    0.30284E-12
+    2    1    0.65217E-05    0.10000E+01    0.71007E+03    0.16146E-05    0.13025E-09    0.49669E-12
+    2    1    0.65217E-05    0.10000E+01    0.57264E+03    0.30127E-05    0.45526E-09    0.82085E-12
+    2    1    0.65217E-05    0.10000E+01    0.46180E+03    0.56071E-05    0.15140E-08    0.13686E-11
+    2    1    0.65217E-05    0.10000E+01    0.37242E+03    0.10336E-04    0.45849E-08    0.22956E-11
+    2    1    0.65217E-05    0.10000E+01    0.30034E+03    0.18619E-04    0.12248E-07    0.38332E-11
+    2    1    0.65217E-05    0.10000E+01    0.24221E+03    0.32238E-04    0.28528E-07    0.62688E-11
+    2    1    0.65217E-05    0.10000E+01    0.19533E+03    0.50269E-04    0.54138E-07    0.94177E-11
+    2    1    0.65217E-05    0.10000E+01    0.15752E+03    0.50269E-04    0.54138E-07    0.94177E-11
+    2    1    0.11380E-04    0.10000E+01    0.80645E+05    0.30630E-51    0.22872E-62    0.28209E-57
+    2    1    0.11380E-04    0.10000E+01    0.65036E+05    0.25871E-50    0.36275E-61    0.23839E-56
+    2    1    0.11380E-04    0.10000E+01    0.52449E+05    0.21952E-49    0.48533E-60    0.20237E-55
+    2    1    0.11380E-04    0.10000E+01    0.42297E+05    0.16458E-48    0.65414E-59    0.15184E-54
+    2    1    0.11380E-04    0.10000E+01    0.34111E+05    0.11791E-47    0.88650E-58    0.10894E-53
+    2    1    0.11380E-04    0.10000E+01    0.27509E+05    0.83726E-47    0.11761E-56    0.77542E-53
+    2    1    0.11380E-04    0.10000E+01    0.22184E+05    0.58566E-46    0.15108E-55    0.54455E-52
+    2    1    0.11380E-04    0.10000E+01    0.17891E+05    0.39894E-45    0.18677E-54    0.37336E-51
+    2    1    0.11380E-04    0.10000E+01    0.14428E+05    0.26263E-44    0.22163E-53    0.24832E-50
+    2    1    0.11380E-04    0.10000E+01    0.11635E+05    0.16632E-43    0.24962E-52    0.15964E-49
+    2    1    0.11380E-04    0.10000E+01    0.93834E+04    0.10049E-42    0.26292E-51    0.98354E-49
+    2    1    0.11380E-04    0.10000E+01    0.75673E+04    0.57516E-42    0.28005E-50    0.57065E-48
+    2    1    0.11380E-04    0.10000E+01    0.61026E+04    0.32905E-41    0.41117E-49    0.31441E-47
+    2    1    0.11380E-04    0.10000E+01    0.49215E+04    0.23301E-40    0.91703E-48    0.19061E-46
+    2    1    0.11380E-04    0.10000E+01    0.39689E+04    0.23958E-39    0.22699E-46    0.16516E-45
+    2    1    0.11380E-04    0.10000E+01    0.32008E+04    0.92936E-37    0.17232E-43    0.60179E-43
+    2    1    0.11380E-04    0.10000E+01    0.25813E+04    0.58341E-28    0.22927E-34    0.36547E-34
+    2    1    0.11380E-04    0.10000E+01    0.20817E+04    0.86737E-12    0.12643E-17    0.50343E-18
+    2    1    0.11380E-04    0.10000E+01    0.16788E+04    0.24026E-06    0.14229E-11    0.12590E-12
+    2    1    0.11380E-04    0.10000E+01    0.13538E+04    0.43811E-06    0.50748E-11    0.20064E-12
+    2    1    0.11380E-04    0.10000E+01    0.10918E+04    0.81078E-06    0.18034E-10    0.32429E-12
+    2    1    0.11380E-04    0.10000E+01    0.88049E+03    0.15099E-05    0.64054E-10    0.52845E-12
+    2    1    0.11380E-04    0.10000E+01    0.71007E+03    0.28175E-05    0.22728E-09    0.86670E-12
+    2    1    0.11380E-04    0.10000E+01    0.57264E+03    0.52570E-05    0.79440E-09    0.14323E-11
+    2    1    0.11380E-04    0.10000E+01    0.46180E+03    0.97841E-05    0.26418E-08    0.23882E-11
+    2    1    0.11380E-04    0.10000E+01    0.37242E+03    0.18036E-04    0.80003E-08    0.40057E-11
+    2    1    0.11380E-04    0.10000E+01    0.30034E+03    0.32488E-04    0.21371E-07    0.66888E-11
+    2    1    0.11380E-04    0.10000E+01    0.24221E+03    0.56254E-04    0.49779E-07    0.10939E-10
+    2    1    0.11380E-04    0.10000E+01    0.19533E+03    0.87716E-04    0.94467E-07    0.16433E-10
+    2    1    0.11380E-04    0.10000E+01    0.15752E+03    0.87716E-04    0.94467E-07    0.16433E-10
+    2    1    0.19857E-04    0.10000E+01    0.80645E+05    0.53447E-51    0.39910E-62    0.49223E-57
+    2    1    0.19857E-04    0.10000E+01    0.65036E+05    0.45144E-50    0.63298E-61    0.41597E-56
+    2    1    0.19857E-04    0.10000E+01    0.52449E+05    0.38305E-49    0.84687E-60    0.35312E-55
+    2    1    0.19857E-04    0.10000E+01    0.42297E+05    0.28718E-48    0.11414E-58    0.26495E-54
+    2    1    0.19857E-04    0.10000E+01    0.34111E+05    0.20575E-47    0.15469E-57    0.19010E-53
+    2    1    0.19857E-04    0.10000E+01    0.27509E+05    0.14610E-46    0.20523E-56    0.13531E-52
+    2    1    0.19857E-04    0.10000E+01    0.22184E+05    0.10219E-45    0.26363E-55    0.95020E-52
+    2    1    0.19857E-04    0.10000E+01    0.17891E+05    0.69613E-45    0.32590E-54    0.65149E-51
+    2    1    0.19857E-04    0.10000E+01    0.14428E+05    0.45828E-44    0.38673E-53    0.43330E-50
+    2    1    0.19857E-04    0.10000E+01    0.11635E+05    0.29022E-43    0.43557E-52    0.27856E-49
+    2    1    0.19857E-04    0.10000E+01    0.93834E+04    0.17535E-42    0.45877E-51    0.17162E-48
+    2    1    0.19857E-04    0.10000E+01    0.75673E+04    0.10036E-41    0.48867E-50    0.99575E-48
+    2    1    0.19857E-04    0.10000E+01    0.61026E+04    0.57417E-41    0.71746E-49    0.54863E-47
+    2    1    0.19857E-04    0.10000E+01    0.49215E+04    0.40660E-40    0.16002E-47    0.33260E-46
+    2    1    0.19857E-04    0.10000E+01    0.39689E+04    0.41805E-39    0.39609E-46    0.28820E-45
+    2    1    0.19857E-04    0.10000E+01    0.32008E+04    0.16217E-36    0.30070E-43    0.10501E-42
+    2    1    0.19857E-04    0.10000E+01    0.25813E+04    0.10180E-27    0.40007E-34    0.63772E-34
+    2    1    0.19857E-04    0.10000E+01    0.20817E+04    0.15135E-11    0.22061E-17    0.87845E-18
+    2    1    0.19857E-04    0.10000E+01    0.16788E+04    0.41923E-06    0.24829E-11    0.21969E-12
+    2    1    0.19857E-04    0.10000E+01    0.13538E+04    0.76447E-06    0.88552E-11    0.35010E-12
+    2    1    0.19857E-04    0.10000E+01    0.10918E+04    0.14148E-05    0.31468E-10    0.56587E-12
+    2    1    0.19857E-04    0.10000E+01    0.88049E+03    0.26348E-05    0.11177E-09    0.92211E-12
+    2    1    0.19857E-04    0.10000E+01    0.71007E+03    0.49163E-05    0.39659E-09    0.15123E-11
+    2    1    0.19857E-04    0.10000E+01    0.57264E+03    0.91732E-05    0.13862E-08    0.24993E-11
+    2    1    0.19857E-04    0.10000E+01    0.46180E+03    0.17073E-04    0.46097E-08    0.41672E-11
+    2    1    0.19857E-04    0.10000E+01    0.37242E+03    0.31471E-04    0.13960E-07    0.69896E-11
+    2    1    0.19857E-04    0.10000E+01    0.30034E+03    0.56690E-04    0.37292E-07    0.11672E-10
+    2    1    0.19857E-04    0.10000E+01    0.24221E+03    0.98159E-04    0.86862E-07    0.19087E-10
+    2    1    0.19857E-04    0.10000E+01    0.19533E+03    0.15306E-03    0.16484E-06    0.28675E-10
+    2    1    0.19857E-04    0.10000E+01    0.15752E+03    0.15306E-03    0.16484E-06    0.28675E-10
+    2    1    0.34650E-04    0.10000E+01    0.80645E+05    0.93261E-51    0.69640E-62    0.85892E-57
+    2    1    0.34650E-04    0.10000E+01    0.65036E+05    0.78773E-50    0.11045E-60    0.72585E-56
+    2    1    0.34650E-04    0.10000E+01    0.52449E+05    0.66841E-49    0.14777E-59    0.61617E-55
+    2    1    0.34650E-04    0.10000E+01    0.42297E+05    0.50112E-48    0.19917E-58    0.46233E-54
+    2    1    0.34650E-04    0.10000E+01    0.34111E+05    0.35903E-47    0.26992E-57    0.33171E-53
+    2    1    0.34650E-04    0.10000E+01    0.27509E+05    0.25493E-46    0.35811E-56    0.23610E-52
+    2    1    0.34650E-04    0.10000E+01    0.22184E+05    0.17832E-45    0.46002E-55    0.16580E-51
+    2    1    0.34650E-04    0.10000E+01    0.17891E+05    0.12147E-44    0.56868E-54    0.11368E-50
+    2    1    0.34650E-04    0.10000E+01    0.14428E+05    0.79967E-44    0.67482E-53    0.75608E-50
+    2    1    0.34650E-04    0.10000E+01    0.11635E+05    0.50642E-43    0.76005E-52    0.48607E-49
+    2    1    0.34650E-04    0.10000E+01    0.93834E+04    0.30598E-42    0.80053E-51    0.29947E-48
+    2    1    0.34650E-04    0.10000E+01    0.75673E+04    0.17512E-41    0.85271E-50    0.17375E-47
+    2    1    0.34650E-04    0.10000E+01    0.61026E+04    0.10019E-40    0.12519E-48    0.95732E-47
+    2    1    0.34650E-04    0.10000E+01    0.49215E+04    0.70948E-40    0.27922E-47    0.58037E-46
+    2    1    0.34650E-04    0.10000E+01    0.39689E+04    0.72947E-39    0.69116E-46    0.50289E-45
+    2    1    0.34650E-04    0.10000E+01    0.32008E+04    0.28297E-36    0.52470E-43    0.18323E-42
+    2    1    0.34650E-04    0.10000E+01    0.25813E+04    0.17764E-27    0.69809E-34    0.11128E-33
+    2    1    0.34650E-04    0.10000E+01    0.20817E+04    0.26410E-11    0.38495E-17    0.15328E-17
+    2    1    0.34650E-04    0.10000E+01    0.16788E+04    0.73153E-06    0.43325E-11    0.38335E-12
+    2    1    0.34650E-04    0.10000E+01    0.13538E+04    0.13339E-05    0.15452E-10    0.61091E-12
+    2    1    0.34650E-04    0.10000E+01    0.10918E+04    0.24687E-05    0.54910E-10    0.98742E-12
+    2    1    0.34650E-04    0.10000E+01    0.88049E+03    0.45975E-05    0.19503E-09    0.16090E-11
+    2    1    0.34650E-04    0.10000E+01    0.71007E+03    0.85786E-05    0.69203E-09    0.26389E-11
+    2    1    0.34650E-04    0.10000E+01    0.57264E+03    0.16007E-04    0.24188E-08    0.43612E-11
+    2    1    0.34650E-04    0.10000E+01    0.46180E+03    0.29791E-04    0.80437E-08    0.72715E-11
+    2    1    0.34650E-04    0.10000E+01    0.37242E+03    0.54915E-04    0.24359E-07    0.12196E-10
+    2    1    0.34650E-04    0.10000E+01    0.30034E+03    0.98921E-04    0.65072E-07    0.20366E-10
+    2    1    0.34650E-04    0.10000E+01    0.24221E+03    0.17128E-03    0.15157E-06    0.33306E-10
+    2    1    0.34650E-04    0.10000E+01    0.19533E+03    0.26708E-03    0.28763E-06    0.50036E-10
+    2    1    0.34650E-04    0.10000E+01    0.15752E+03    0.26708E-03    0.28763E-06    0.50036E-10
+    2    1    0.60462E-04    0.10000E+01    0.80645E+05    0.16274E-50    0.12152E-61    0.14988E-56
+    2    1    0.60462E-04    0.10000E+01    0.65036E+05    0.13745E-49    0.19273E-60    0.12666E-55
+    2    1    0.60462E-04    0.10000E+01    0.52449E+05    0.11663E-48    0.25786E-59    0.10752E-54
+    2    1    0.60462E-04    0.10000E+01    0.42297E+05    0.87442E-48    0.34755E-58    0.80673E-54
+    2    1    0.60462E-04    0.10000E+01    0.34111E+05    0.62648E-47    0.47100E-57    0.57882E-53
+    2    1    0.60462E-04    0.10000E+01    0.27509E+05    0.44484E-46    0.62489E-56    0.41198E-52
+    2    1    0.60462E-04    0.10000E+01    0.22184E+05    0.31116E-45    0.80270E-55    0.28932E-51
+    2    1    0.60462E-04    0.10000E+01    0.17891E+05    0.21196E-44    0.99232E-54    0.19837E-50
+    2    1    0.60462E-04    0.10000E+01    0.14428E+05    0.13954E-43    0.11775E-52    0.13193E-49
+    2    1    0.60462E-04    0.10000E+01    0.11635E+05    0.88367E-43    0.13262E-51    0.84815E-49
+    2    1    0.60462E-04    0.10000E+01    0.93834E+04    0.53391E-42    0.13969E-50    0.52256E-48
+    2    1    0.60462E-04    0.10000E+01    0.75673E+04    0.30558E-41    0.14879E-49    0.30319E-47
+    2    1    0.60462E-04    0.10000E+01    0.61026E+04    0.17483E-40    0.21845E-48    0.16705E-46
+    2    1    0.60462E-04    0.10000E+01    0.49215E+04    0.12380E-39    0.48722E-47    0.10127E-45
+    2    1    0.60462E-04    0.10000E+01    0.39689E+04    0.12729E-38    0.12060E-45    0.87752E-45
+    2    1    0.60462E-04    0.10000E+01    0.32008E+04    0.49377E-36    0.91556E-43    0.31973E-42
+    2    1    0.60462E-04    0.10000E+01    0.25813E+04    0.30997E-27    0.12181E-33    0.19417E-33
+    2    1    0.60462E-04    0.10000E+01    0.20817E+04    0.46083E-11    0.67171E-17    0.26747E-17
+    2    1    0.60462E-04    0.10000E+01    0.16788E+04    0.12765E-05    0.75599E-11    0.66893E-12
+    2    1    0.60462E-04    0.10000E+01    0.13538E+04    0.23277E-05    0.26962E-10    0.10660E-11
+    2    1    0.60462E-04    0.10000E+01    0.10918E+04    0.43077E-05    0.95814E-10    0.17230E-11
+    2    1    0.60462E-04    0.10000E+01    0.88049E+03    0.80224E-05    0.34032E-09    0.28076E-11
+    2    1    0.60462E-04    0.10000E+01    0.71007E+03    0.14969E-04    0.12075E-08    0.46048E-11
+    2    1    0.60462E-04    0.10000E+01    0.57264E+03    0.27931E-04    0.42207E-08    0.76100E-11
+    2    1    0.60462E-04    0.10000E+01    0.46180E+03    0.51983E-04    0.14036E-07    0.12688E-10
+    2    1    0.60462E-04    0.10000E+01    0.37242E+03    0.95823E-04    0.42506E-07    0.21282E-10
+    2    1    0.60462E-04    0.10000E+01    0.30034E+03    0.17261E-03    0.11355E-06    0.35538E-10
+    2    1    0.60462E-04    0.10000E+01    0.24221E+03    0.29888E-03    0.26448E-06    0.58118E-10
+    2    1    0.60462E-04    0.10000E+01    0.19533E+03    0.46603E-03    0.50190E-06    0.87310E-10
+    2    1    0.60462E-04    0.10000E+01    0.15752E+03    0.46603E-03    0.50190E-06    0.87310E-10
+    2    1    0.10550E-03    0.10000E+01    0.80645E+05    0.28396E-50    0.21204E-61    0.26152E-56
+    2    1    0.10550E-03    0.10000E+01    0.65036E+05    0.23985E-49    0.33630E-60    0.22101E-55
+    2    1    0.10550E-03    0.10000E+01    0.52449E+05    0.20352E-48    0.44994E-59    0.18761E-54
+    2    1    0.10550E-03    0.10000E+01    0.42297E+05    0.15258E-47    0.60645E-58    0.14077E-53
+    2    1    0.10550E-03    0.10000E+01    0.34111E+05    0.10932E-46    0.82187E-57    0.10100E-52
+    2    1    0.10550E-03    0.10000E+01    0.27509E+05    0.77622E-46    0.10904E-55    0.71888E-52
+    2    1    0.10550E-03    0.10000E+01    0.22184E+05    0.54296E-45    0.14007E-54    0.50484E-51
+    2    1    0.10550E-03    0.10000E+01    0.17891E+05    0.36985E-44    0.17315E-53    0.34614E-50
+    2    1    0.10550E-03    0.10000E+01    0.14428E+05    0.24348E-43    0.20547E-52    0.23021E-49
+    2    1    0.10550E-03    0.10000E+01    0.11635E+05    0.15420E-42    0.23142E-51    0.14800E-48
+    2    1    0.10550E-03    0.10000E+01    0.93834E+04    0.93164E-42    0.24375E-50    0.91183E-48
+    2    1    0.10550E-03    0.10000E+01    0.75673E+04    0.53322E-41    0.25963E-49    0.52904E-47
+    2    1    0.10550E-03    0.10000E+01    0.61026E+04    0.30506E-40    0.38119E-48    0.29149E-46
+    2    1    0.10550E-03    0.10000E+01    0.49215E+04    0.21602E-39    0.85017E-47    0.17671E-45
+    2    1    0.10550E-03    0.10000E+01    0.39689E+04    0.22211E-38    0.21044E-45    0.15312E-44
+    2    1    0.10550E-03    0.10000E+01    0.32008E+04    0.86160E-36    0.15976E-42    0.55791E-42
+    2    1    0.10550E-03    0.10000E+01    0.25813E+04    0.54087E-27    0.21256E-33    0.33882E-33
+    2    1    0.10550E-03    0.10000E+01    0.20817E+04    0.80413E-11    0.11721E-16    0.46672E-17
+    2    1    0.10550E-03    0.10000E+01    0.16788E+04    0.22274E-05    0.13192E-10    0.11672E-11
+    2    1    0.10550E-03    0.10000E+01    0.13538E+04    0.40616E-05    0.47048E-10    0.18601E-11
+    2    1    0.10550E-03    0.10000E+01    0.10918E+04    0.75167E-05    0.16719E-09    0.30065E-11
+    2    1    0.10550E-03    0.10000E+01    0.88049E+03    0.13999E-04    0.59384E-09    0.48992E-11
+    2    1    0.10550E-03    0.10000E+01    0.71007E+03    0.26120E-04    0.21071E-08    0.80351E-11
+    2    1    0.10550E-03    0.10000E+01    0.57264E+03    0.48737E-04    0.73648E-08    0.13279E-10
+    2    1    0.10550E-03    0.10000E+01    0.46180E+03    0.90707E-04    0.24491E-07    0.22140E-10
+    2    1    0.10550E-03    0.10000E+01    0.37242E+03    0.16721E-03    0.74170E-07    0.37136E-10
+    2    1    0.10550E-03    0.10000E+01    0.30034E+03    0.30120E-03    0.19813E-06    0.62011E-10
+    2    1    0.10550E-03    0.10000E+01    0.24221E+03    0.52152E-03    0.46150E-06    0.10141E-09
+    2    1    0.10550E-03    0.10000E+01    0.19533E+03    0.81320E-03    0.87579E-06    0.15235E-09
+    2    1    0.10550E-03    0.10000E+01    0.15752E+03    0.81320E-03    0.87579E-06    0.15235E-09
+    2    1    0.18409E-03    0.10000E+01    0.80645E+05    0.49550E-50    0.37000E-61    0.45635E-56
+    2    1    0.18409E-03    0.10000E+01    0.65036E+05    0.41852E-49    0.58683E-60    0.38564E-55
+    2    1    0.18409E-03    0.10000E+01    0.52449E+05    0.35513E-48    0.78513E-59    0.32737E-54
+    2    1    0.18409E-03    0.10000E+01    0.42297E+05    0.26624E-47    0.10582E-57    0.24564E-53
+    2    1    0.18409E-03    0.10000E+01    0.34111E+05    0.19075E-46    0.14341E-56    0.17624E-52
+    2    1    0.18409E-03    0.10000E+01    0.27509E+05    0.13545E-45    0.19027E-55    0.12544E-51
+    2    1    0.18409E-03    0.10000E+01    0.22184E+05    0.94743E-45    0.24441E-54    0.88092E-51
+    2    1    0.18409E-03    0.10000E+01    0.17891E+05    0.64537E-44    0.30214E-53    0.60399E-50
+    2    1    0.18409E-03    0.10000E+01    0.14428E+05    0.42486E-43    0.35853E-52    0.40171E-49
+    2    1    0.18409E-03    0.10000E+01    0.11635E+05    0.26906E-42    0.40381E-51    0.25825E-48
+    2    1    0.18409E-03    0.10000E+01    0.93834E+04    0.16257E-41    0.42532E-50    0.15911E-47
+    2    1    0.18409E-03    0.10000E+01    0.75673E+04    0.93044E-41    0.45304E-49    0.92315E-47
+    2    1    0.18409E-03    0.10000E+01    0.61026E+04    0.53231E-40    0.66515E-48    0.50863E-46
+    2    1    0.18409E-03    0.10000E+01    0.49215E+04    0.37695E-39    0.14835E-46    0.30835E-45
+    2    1    0.18409E-03    0.10000E+01    0.39689E+04    0.38757E-38    0.36721E-45    0.26719E-44
+    2    1    0.18409E-03    0.10000E+01    0.32008E+04    0.15034E-35    0.27877E-42    0.97352E-42
+    2    1    0.18409E-03    0.10000E+01    0.25813E+04    0.94379E-27    0.37090E-33    0.59122E-33
+    2    1    0.18409E-03    0.10000E+01    0.20817E+04    0.14032E-10    0.20452E-16    0.81440E-17
+    2    1    0.18409E-03    0.10000E+01    0.16788E+04    0.38867E-05    0.23019E-10    0.20368E-11
+    2    1    0.18409E-03    0.10000E+01    0.13538E+04    0.70873E-05    0.82096E-10    0.32458E-11
+    2    1    0.18409E-03    0.10000E+01    0.10918E+04    0.13116E-04    0.29174E-09    0.52462E-11
+    2    1    0.18409E-03    0.10000E+01    0.88049E+03    0.24427E-04    0.10362E-08    0.85487E-11
+    2    1    0.18409E-03    0.10000E+01    0.71007E+03    0.45578E-04    0.36768E-08    0.14021E-10
+    2    1    0.18409E-03    0.10000E+01    0.57264E+03    0.85044E-04    0.12851E-07    0.23171E-10
+    2    1    0.18409E-03    0.10000E+01    0.46180E+03    0.15828E-03    0.42736E-07    0.38633E-10
+    2    1    0.18409E-03    0.10000E+01    0.37242E+03    0.29176E-03    0.12942E-06    0.64800E-10
+    2    1    0.18409E-03    0.10000E+01    0.30034E+03    0.52557E-03    0.34573E-06    0.10821E-09
+    2    1    0.18409E-03    0.10000E+01    0.24221E+03    0.91002E-03    0.80529E-06    0.17696E-09
+    2    1    0.18409E-03    0.10000E+01    0.19533E+03    0.14190E-02    0.15282E-05    0.26584E-09
+    2    1    0.18409E-03    0.10000E+01    0.15752E+03    0.14190E-02    0.15282E-05    0.26584E-09
+    2    1    0.32123E-03    0.10000E+01    0.80645E+05    0.86462E-50    0.64562E-61    0.79629E-56
+    2    1    0.32123E-03    0.10000E+01    0.65036E+05    0.73030E-49    0.10240E-59    0.67293E-55
+    2    1    0.32123E-03    0.10000E+01    0.52449E+05    0.61967E-48    0.13700E-58    0.57125E-54
+    2    1    0.32123E-03    0.10000E+01    0.42297E+05    0.46458E-47    0.18465E-57    0.42862E-53
+    2    1    0.32123E-03    0.10000E+01    0.34111E+05    0.33285E-46    0.25024E-56    0.30753E-52
+    2    1    0.32123E-03    0.10000E+01    0.27509E+05    0.23634E-45    0.33200E-55    0.21889E-51
+    2    1    0.32123E-03    0.10000E+01    0.22184E+05    0.16532E-44    0.42648E-54    0.15372E-50
+    2    1    0.32123E-03    0.10000E+01    0.17891E+05    0.11261E-43    0.52722E-53    0.10539E-49
+    2    1    0.32123E-03    0.10000E+01    0.14428E+05    0.74136E-43    0.62562E-52    0.70095E-49
+    2    1    0.32123E-03    0.10000E+01    0.11635E+05    0.46950E-42    0.70463E-51    0.45063E-48
+    2    1    0.32123E-03    0.10000E+01    0.93834E+04    0.28367E-41    0.74216E-50    0.27764E-47
+    2    1    0.32123E-03    0.10000E+01    0.75673E+04    0.16236E-40    0.79053E-49    0.16108E-46
+    2    1    0.32123E-03    0.10000E+01    0.61026E+04    0.92885E-40    0.11607E-47    0.88752E-46
+    2    1    0.32123E-03    0.10000E+01    0.49215E+04    0.65775E-39    0.25886E-46    0.53805E-45
+    2    1    0.32123E-03    0.10000E+01    0.39689E+04    0.67628E-38    0.64076E-45    0.46623E-44
+    2    1    0.32123E-03    0.10000E+01    0.32008E+04    0.26234E-35    0.48644E-42    0.16987E-41
+    2    1    0.32123E-03    0.10000E+01    0.25813E+04    0.16469E-26    0.64720E-33    0.10316E-32
+    2    1    0.32123E-03    0.10000E+01    0.20817E+04    0.24484E-10    0.35688E-16    0.14211E-16
+    2    1    0.32123E-03    0.10000E+01    0.16788E+04    0.67820E-05    0.40166E-10    0.35540E-11
+    2    1    0.32123E-03    0.10000E+01    0.13538E+04    0.12367E-04    0.14325E-09    0.56636E-11
+    2    1    0.32123E-03    0.10000E+01    0.10918E+04    0.22887E-04    0.50906E-09    0.91542E-11
+    2    1    0.32123E-03    0.10000E+01    0.88049E+03    0.42623E-04    0.18081E-08    0.14917E-10
+    2    1    0.32123E-03    0.10000E+01    0.71007E+03    0.79532E-04    0.64157E-08    0.24465E-10
+    2    1    0.32123E-03    0.10000E+01    0.57264E+03    0.14840E-03    0.22424E-07    0.40432E-10
+    2    1    0.32123E-03    0.10000E+01    0.46180E+03    0.27619E-03    0.74572E-07    0.67413E-10
+    2    1    0.32123E-03    0.10000E+01    0.37242E+03    0.50911E-03    0.22583E-06    0.11307E-09
+    2    1    0.32123E-03    0.10000E+01    0.30034E+03    0.91708E-03    0.60328E-06    0.18881E-09
+    2    1    0.32123E-03    0.10000E+01    0.24221E+03    0.15879E-02    0.14052E-05    0.30878E-09
+    2    1    0.32123E-03    0.10000E+01    0.19533E+03    0.24760E-02    0.26666E-05    0.46388E-09
+    2    1    0.32123E-03    0.10000E+01    0.15752E+03    0.24760E-02    0.26666E-05    0.46388E-09
+    2    2    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.30142E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    2    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.52597E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    2    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.91778E-08    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    2    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.16015E-07    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    2    2    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.27945E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    2    2    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.48762E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    2    2    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.85086E-07    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    2    2    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.14847E-06    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    2    2    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.25907E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    2    2    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.45207E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    2    2    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.78883E-06    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    2    2    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.13765E-05    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    2    2    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.24018E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    2    2    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.41910E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    2    2    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.73131E-05    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    2    2    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.12761E-04    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    2    2    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.22267E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    2    2    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.38855E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    2    2    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.67799E-04    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    2    2    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.11831E-03    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    2    2    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53957E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.20644E-03    0.19496E+06    0.99447E-26    0.48760E-10    0.50499E-04    0.88379E+03
+    2    2    0.54572E-10    0.10000E+01    0.74090E-01    0.13935E+00    0.11222E-09    0.65380E-11    0.40383E-04    0.29228E-04    0.98516E+04    0.36022E-03    0.15940E+06    0.27009E-25    0.58026E-09    0.60483E-04    0.85041E+03
+    2    2    0.95225E-10    0.10000E+01    0.11736E+00    0.19749E+00    0.21140E-09    0.50996E-10    0.44004E-04    0.38038E-04    0.17190E+05    0.62856E-03    0.12765E+06    0.72480E-25    0.43989E-08    0.73406E-04    0.78192E+03
+    2    2    0.16616E-09    0.10000E+01    0.18179E+00    0.26431E+00    0.32752E-09    0.26583E-09    0.44528E-04    0.48903E-04    0.29996E+05    0.10968E-02    0.99467E+05    0.19955E-24    0.21856E-07    0.91697E-04    0.67141E+03
+    2    2    0.28994E-09    0.10000E+01    0.25959E+00    0.33476E+00    0.47652E-09    0.94234E-09    0.43521E-04    0.57722E-04    0.52341E+05    0.19138E-02    0.75619E+05    0.57661E-24    0.71485E-07    0.11866E-03    0.53385E+03
+    2    2    0.50593E-09    0.10000E+01    0.33769E+00    0.40367E+00    0.76583E-09    0.24786E-08    0.45986E-04    0.60624E-04    0.91333E+05    0.33395E-02    0.56820E+05    0.17474E-23    0.16677E-06    0.15732E-03    0.40181E+03
+    2    2    0.88282E-09    0.10000E+01    0.40406E+00    0.45091E+00    0.13453E-08    0.56444E-08    0.58118E-04    0.55328E-04    0.15937E+06    0.58273E-02    0.42917E+05    0.57250E-23    0.32922E-06    0.21108E-03    0.29851E+03
+    2    2    0.15405E-08    0.10000E+01    0.44088E+00    0.47410E+00    0.28161E-08    0.12125E-07    0.85637E-04    0.47263E-04    0.27007E+06    0.10076E-01    0.30855E+05    0.20051E-22    0.60936E-06    0.28301E-03    0.23220E+03
+    2    2    0.26880E-08    0.10000E+01    0.34230E+00    0.74058E+00    0.15558E-07    0.26702E-07    0.93011E-04    0.55375E-04    0.11884E+06    0.10893E-01    0.51169E+04    0.19969E-21    0.84509E-06    0.60269E-03    0.15282E+03
+    2    2    0.46905E-08    0.10000E+01    0.40592E+00    0.86090E+00    0.28539E-07    0.49560E-07    0.11867E-03    0.60643E-04    0.20736E+06    0.19008E-01    0.39002E+04    0.56948E-21    0.13437E-05    0.77502E-03    0.12237E+03
+    2    2    0.81846E-08    0.10000E+01    0.48191E+00    0.98898E+00    0.51336E-07    0.91227E-07    0.15036E-03    0.66803E-04    0.36184E+06    0.33167E-01    0.29497E+04    0.16554E-20    0.21108E-05    0.10083E-02    0.96349E+02
+    2    2    0.14282E-07    0.10000E+01    0.57042E+00    0.11180E+01    0.90297E-07    0.16710E-06    0.18978E-03    0.73167E-04    0.63138E+06    0.57875E-01    0.22193E+04    0.48926E-20    0.33009E-05    0.13254E-02    0.74475E+02
+    2    2    0.24920E-07    0.10000E+01    0.67005E+00    0.12430E+01    0.15522E-06    0.30500E-06    0.23959E-03    0.79135E-04    0.11017E+07    0.10099E+00    0.16633E+04    0.14649E-19    0.51610E-05    0.17566E-02    0.56555E+02
+    2    2    0.43485E-07    0.10000E+01    0.77749E+00    0.13599E+01    0.26215E-06    0.55474E-06    0.30429E-03    0.84306E-04    0.19224E+07    0.17622E+00    0.12449E+04    0.44135E-19    0.80870E-05    0.23381E-02    0.42370E+02
+    2    2    0.75878E-07    0.10000E+01    0.89021E+00    0.14680E+01    0.43461E-06    0.10055E-05    0.38894E-03    0.88597E-04    0.33546E+07    0.30749E+00    0.92938E+03    0.13391E-18    0.12693E-04    0.31259E-02    0.31356E+02
+    2    2    0.13240E-06    0.10000E+01    0.10042E+01    0.15658E+01    0.71235E-06    0.18153E-05    0.50195E-03    0.92039E-04    0.58535E+07    0.53655E+00    0.69382E+03    0.40615E-18    0.19957E-04    0.41817E-02    0.23044E+02
+    2    2    0.23103E-06    0.10000E+01    0.11167E+01    0.16532E+01    0.11540E-05    0.32592E-05    0.65331E-03    0.94772E-04    0.10214E+08    0.93626E+00    0.51796E+03    0.12128E-17    0.31379E-04    0.55715E-02    0.16877E+02
+    2    2    0.40314E-06    0.10000E+01    0.11300E+01    0.16630E+01    0.32521E-05    0.57026E-05    0.11008E-02    0.95060E-04    0.17823E+08    0.16337E+01    0.50000E+03    0.22510E-17    0.54058E-04    0.57624E-02    0.16256E+02
+    2    2    0.70346E-06    0.10000E+01    0.11300E+01    0.16630E+01    0.99021E-05    0.99507E-05    0.19209E-02    0.95060E-04    0.31100E+08    0.28507E+01    0.50000E+03    0.39279E-17    0.94328E-04    0.57624E-02    0.16256E+02
+    2    2    0.12275E-05    0.10000E+01    0.11300E+01    0.16630E+01    0.30150E-04    0.17363E-04    0.33518E-02    0.95060E-04    0.54267E+08    0.49743E+01    0.50000E+03    0.68539E-17    0.16460E-03    0.57624E-02    0.16256E+02
+    2    2    0.21419E-05    0.10000E+01    0.11300E+01    0.16630E+01    0.91801E-04    0.30298E-04    0.58487E-02    0.95060E-04    0.94693E+08    0.86799E+01    0.50000E+03    0.11960E-16    0.28721E-03    0.57624E-02    0.16256E+02
+    2    2    0.37375E-05    0.10000E+01    0.11300E+01    0.16630E+01    0.27952E-03    0.52868E-04    0.10206E-01    0.95060E-04    0.16523E+09    0.15146E+02    0.50000E+03    0.20869E-16    0.50116E-03    0.57624E-02    0.16256E+02
+    2    2    0.65217E-05    0.10000E+01    0.11300E+01    0.16630E+01    0.85108E-03    0.92252E-04    0.17808E-01    0.95060E-04    0.28832E+09    0.26429E+02    0.50000E+03    0.36415E-16    0.87450E-03    0.57624E-02    0.16256E+02
+    2    2    0.11380E-04    0.10000E+01    0.11300E+01    0.16630E+01    0.25914E-02    0.16097E-03    0.31074E-01    0.95060E-04    0.50310E+09    0.46117E+02    0.50000E+03    0.63541E-16    0.15260E-02    0.57624E-02    0.16256E+02
+    2    2    0.19857E-04    0.10000E+01    0.11300E+01    0.16630E+01    0.78902E-02    0.28089E-03    0.54223E-01    0.95060E-04    0.87789E+09    0.80471E+02    0.50000E+03    0.11088E-15    0.26627E-02    0.57624E-02    0.16256E+02
+    2    2    0.34650E-04    0.10000E+01    0.11300E+01    0.16630E+01    0.24024E-01    0.49014E-03    0.94616E-01    0.95060E-04    0.15319E+10    0.14042E+03    0.50000E+03    0.19347E-15    0.46462E-02    0.57624E-02    0.16256E+02
+    2    2    0.60462E-04    0.10000E+01    0.11300E+01    0.16630E+01    0.73150E-01    0.85526E-03    0.16510E+00    0.95060E-04    0.26730E+10    0.24502E+03    0.50000E+03    0.33760E-15    0.81074E-02    0.57624E-02    0.16256E+02
+    2    2    0.10550E-03    0.10000E+01    0.11300E+01    0.16630E+01    0.22273E+00    0.14924E-02    0.28809E+00    0.95060E-04    0.46642E+10    0.42754E+03    0.50000E+03    0.58909E-15    0.14147E-01    0.57624E-02    0.16256E+02
+    2    2    0.18409E-03    0.10000E+01    0.11300E+01    0.16630E+01    0.67816E+00    0.26041E-02    0.50270E+00    0.95060E-04    0.81388E+10    0.74603E+03    0.50000E+03    0.10279E-14    0.24686E-01    0.57624E-02    0.16256E+02
+    2    2    0.32123E-03    0.10000E+01    0.11300E+01    0.16630E+01    0.20649E+01    0.45440E-02    0.87717E+00    0.95060E-04    0.14202E+11    0.13018E+04    0.50000E+03    0.17937E-14    0.43075E-01    0.57624E-02    0.16256E+02
+    2    2    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    2    2    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    2    2    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    2    2    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    2    2    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    2    2    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    2    2    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    2    2    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    2    2    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    2    2    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    2    2    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    2    2    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    2    2    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    2    2    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    2    2    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    2    2    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    2    2    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    2    2    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    2    2    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    2    2    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    2    2    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    2    2    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    2    2    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    2    2    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    2    2    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    2    2    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    2    2    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    2    2    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    2    2    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    2    2    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    2    2    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    2    2    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    2    2    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    2    2    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    2    2    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    2    2    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    2    2    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    2    2    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    2    2    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    2    2    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    2    2    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    2    2    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    2    2    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    2    2    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    2    2    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    2    2    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    2    2    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    2    2    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    2    2    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    2    2    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    2    2    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    2    2    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    2    2    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    2    2    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    2    2    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    2    2    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    2    2    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    2    2    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    2    2    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    2    2    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    2    2    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    2    2    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    2    2    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    2    2    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    2    2    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    2    2    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    2    2    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    2    2    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    2    2    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    2    2    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    2    2    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    2    2    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    2    2    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    2    2    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    2    2    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    2    2    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    2    2    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    2    2    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    2    2    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    2    2    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    2    2    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    2    2    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    2    2    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    2    2    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    2    2    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    2    2    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    2    2    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    2    2    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    2    2    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    2    2    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    2    2    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    2    2    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    2    2    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    2    2    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    2    2    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    2    2    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    2    2    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    2    2    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    2    2    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    2    2    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    2    2    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    2    2    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    2    2    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    2    2    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    2    2    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    2    2    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    2    2    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    2    2    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    2    2    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    2    2    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    2    2    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    2    2    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    2    2    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    2    2    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    2    2    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    2    2    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    2    2    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    2    2    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    2    2    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    2    2    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    2    2    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    2    2    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    2    2    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    2    2    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    2    2    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    2    2    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    2    2    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    2    2    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    2    2    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    2    2    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    2    2    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    2    2    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    2    2    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    2    2    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    2    2    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    2    2    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    2    2    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    2    2    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    2    2    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    2    2    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    2    2    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    2    2    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    2    2    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    2    2    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    2    2    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    2    2    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    2    2    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    2    2    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    2    2    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    2    2    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    2    2    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    2    2    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    2    2    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    2    2    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    2    2    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    2    2    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    2    2    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    2    2    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    2    2    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    2    2    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    2    2    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    2    2    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    2    2    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    2    2    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    2    2    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    2    2    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    2    2    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    2    2    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    2    2    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    2    2    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    2    2    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    2    2    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    2    2    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    2    2    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    2    2    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    2    2    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    2    2    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    2    2    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    2    2    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    2    2    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    2    2    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    2    2    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    2    2    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    2    2    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    2    2    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    2    2    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    2    2    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    2    2    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    2    2    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    2    2    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    2    2    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    2    2    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    2    2    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    2    2    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    2    2    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    2    2    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    2    2    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    2    2    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    2    2    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    2    2    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    2    2    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    2    2    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    2    2    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    2    2    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    2    2    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    2    2    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    2    2    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    2    2    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    2    2    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    2    2    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    2    2    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    2    2    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    2    2    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    2    2    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    2    2    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    2    2    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    2    2    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    2    2    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    2    2    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    2    2    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    2    2    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    2    2    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    2    2    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    2    2    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    2    2    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    2    2    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    2    2    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    2    2    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    2    2    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    2    2    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    2    2    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    2    2    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    2    2    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    2    2    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    2    2    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    2    2    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    2    2    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    2    2    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    2    2    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    2    2    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    2    2    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    2    2    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    2    2    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    2    2    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    2    2    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    2    2    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    2    2    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    2    2    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    2    2    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    2    2    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    2    2    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    2    2    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    2    2    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    2    2    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    2    2    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    2    2    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    2    2    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    2    2    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    2    2    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    2    2    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    2    2    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    2    2    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    2    2    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    2    2    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    2    2    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    2    2    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    2    2    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    2    2    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    2    2    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    2    2    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    2    2    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    2    2    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    2    2    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    2    2    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    2    2    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    2    2    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    2    2    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    2    2    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    2    2    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    2    2    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    2    2    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    2    2    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    2    2    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    2    2    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    2    2    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    2    2    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    2    2    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    2    2    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    2    2    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    2    2    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    2    2    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    2    2    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    2    2    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    2    2    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    2    2    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    2    2    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    2    2    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    2    2    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    2    2    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    2    2    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    2    2    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    2    2    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    2    2    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    2    2    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    2    2    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    2    2    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    2    2    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    2    2    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    2    2    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    2    2    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    2    2    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    2    2    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    2    2    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    2    2    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    2    2    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    2    2    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    2    2    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    2    2    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    2    2    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    2    2    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    2    2    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    2    2    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    2    2    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    2    2    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    2    2    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    2    2    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    2    2    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    2    2    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    2    2    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    2    2    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    2    2    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    2    2    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    2    2    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    2    2    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    2    2    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    2    2    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    2    2    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    2    2    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    2    2    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    2    2    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    2    2    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    2    2    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    2    2    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    2    2    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    2    2    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    2    2    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    2    2    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    2    2    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    2    2    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    2    2    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    2    2    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    2    2    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    2    2    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    2    2    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    2    2    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    2    2    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    2    2    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    2    2    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    2    2    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    2    2    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    2    2    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    2    2    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    2    2    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    2    2    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    2    2    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    2    2    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    2    2    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    2    2    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    2    2    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    2    2    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    2    2    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    2    2    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    2    2    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    2    2    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    2    2    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    2    2    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    2    2    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    2    2    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    2    2    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    2    2    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    2    2    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    2    2    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    2    2    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    2    2    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    2    2    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    2    2    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    2    2    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    2    2    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    2    2    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    2    2    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    2    2    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    2    2    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    2    2    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    2    2    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    2    2    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    2    2    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    2    2    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    2    2    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    2    2    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    2    2    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    2    2    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    2    2    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    2    2    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    2    2    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    2    2    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    2    2    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    2    2    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    2    2    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    2    2    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    2    2    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    2    2    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    2    2    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    2    2    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    2    2    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    2    2    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    2    2    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    2    2    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    2    2    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    2    2    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    2    2    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    2    2    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    2    2    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    2    2    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    2    2    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    2    2    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    2    2    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    2    2    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    2    2    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    2    2    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    2    2    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    2    2    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    2    2    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    2    2    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    2    2    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    2    2    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    2    2    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    2    2    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    2    2    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    2    2    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    2    2    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    2    2    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    2    2    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    2    2    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    2    2    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    2    2    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    2    2    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    2    2    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    2    2    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    2    2    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    2    2    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    2    2    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    2    2    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    2    2    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    2    2    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    2    2    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    2    2    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    2    2    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    2    2    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    2    2    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    2    2    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    2    2    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    2    2    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    2    2    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    2    2    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    2    2    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    2    2    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    2    2    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    2    2    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    2    2    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    2    2    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    2    2    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    2    2    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    2    2    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    2    2    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    2    2    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    2    2    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    2    2    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    2    2    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    2    2    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    2    2    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    2    2    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    2    2    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    2    2    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    2    2    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    2    2    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    2    2    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    2    2    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    2    2    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    2    2    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    2    2    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    2    2    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    2    2    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    2    2    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    2    2    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    2    2    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    2    2    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    2    2    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    2    2    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    2    2    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    2    2    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    2    2    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    2    2    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    2    2    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    2    2    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    2    2    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    2    2    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    2    2    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    2    2    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    2    2    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    2    2    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    2    2    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    2    2    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    2    2    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    2    2    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    2    2    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    2    2    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    2    2    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    2    2    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    2    2    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    2    2    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    2    2    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    2    2    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    2    2    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    2    2    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    2    2    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    2    2    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    2    2    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    2    2    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    2    2    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    2    2    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    2    2    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    2    2    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    2    2    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    2    2    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    2    2    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    2    2    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    2    2    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    2    2    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    2    2    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    2    2    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    2    2    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    2    2    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    2    2    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    2    2    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    2    2    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    2    2    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    2    2    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    2    2    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    2    2    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    2    2    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    2    2    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    2    2    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    2    2    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    2    2    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    2    2    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    2    2    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    2    2    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    2    2    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    2    2    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    2    2    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    2    2    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    2    2    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    2    2    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    2    2    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    2    2    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    2    2    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    2    2    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    2    2    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    2    2    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    2    2    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    2    2    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    2    2    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    2    2    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    2    2    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    2    2    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    2    2    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    2    2    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    2    2    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    2    2    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    2    2    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    2    2    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    2    2    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    2    2    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    2    2    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    2    2    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    2    2    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    2    2    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    2    2    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    2    2    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    2    2    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    2    2    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    2    2    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    2    2    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    2    2    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    2    2    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    2    2    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    2    2    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    2    2    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    2    2    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    2    2    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    2    2    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    2    2    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    2    2    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    2    2    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    2    2    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    2    2    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    2    2    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    2    2    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    2    2    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    2    2    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    2    2    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    2    2    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    2    2    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    2    2    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    2    2    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    2    2    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    2    2    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    2    2    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    2    2    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    2    2    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    2    2    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    2    2    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    2    2    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    2    2    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    2    2    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    2    2    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    2    2    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    2    2    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    2    2    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    2    2    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    2    2    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35525E-67
+    2    2    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31050E-66
+    2    2    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49297E-66    0.26759E-65
+    2    2    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20665E-64
+    2    2    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    2    2    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15327E-62
+    2    2    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    2    2    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30486E-60
+    2    2    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49479E-59
+    2    2    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76348E-58
+    2    2    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    2    2    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16341E-55
+    2    2    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    2    2    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33513E-53
+    2    2    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47754E-52
+    2    2    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86007E-46    0.21355E-49
+    2    2    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    2    2    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    2    2    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    2    2    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    2    2    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    2    2    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    2    2    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    2    2    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    2    2    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    2    2    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    2    2    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    2    2    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    2    2    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    2    2    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    2    2    0.95225E-10    0.10000E+01    0.80645E+05    0.53338E-57    0.41251E-68    0.10749E-66
+    2    2    0.95225E-10    0.10000E+01    0.65036E+05    0.46320E-56    0.66241E-67    0.94141E-66
+    2    2    0.95225E-10    0.10000E+01    0.52449E+05    0.40024E-55    0.93503E-66    0.81416E-65
+    2    2    0.95225E-10    0.10000E+01    0.42297E+05    0.31521E-54    0.15121E-64    0.62477E-64
+    2    2    0.95225E-10    0.10000E+01    0.34111E+05    0.26479E-53    0.31103E-63    0.46450E-63
+    2    2    0.95225E-10    0.10000E+01    0.27509E+05    0.27530E-52    0.84266E-62    0.36185E-62
+    2    2    0.95225E-10    0.10000E+01    0.22184E+05    0.37547E-51    0.26561E-60    0.35004E-61
+    2    2    0.95225E-10    0.10000E+01    0.17891E+05    0.59959E-50    0.82078E-59    0.47852E-60
+    2    2    0.95225E-10    0.10000E+01    0.14428E+05    0.96029E-49    0.23747E-57    0.76675E-59
+    2    2    0.95225E-10    0.10000E+01    0.11635E+05    0.14620E-47    0.65938E-56    0.12102E-57
+    2    2    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18298E-56
+    2    2    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49011E-53    0.26942E-55
+    2    2    0.95225E-10    0.10000E+01    0.61026E+04    0.43943E-44    0.13295E-51    0.39150E-54
+    2    2    0.95225E-10    0.10000E+01    0.49215E+04    0.62538E-43    0.35997E-50    0.56476E-53
+    2    2    0.95225E-10    0.10000E+01    0.39689E+04    0.88822E-42    0.97300E-49    0.81063E-52
+    2    2    0.95225E-10    0.10000E+01    0.32008E+04    0.39613E-39    0.84952E-46    0.36461E-49
+    2    2    0.95225E-10    0.10000E+01    0.25813E+04    0.29211E-30    0.14353E-36    0.27085E-40
+    2    2    0.95225E-10    0.10000E+01    0.20817E+04    0.55938E-14    0.12256E-19    0.52257E-24
+    2    2    0.95225E-10    0.10000E+01    0.16788E+04    0.18980E-08    0.18143E-13    0.17813E-18
+    2    2    0.95225E-10    0.10000E+01    0.13538E+04    0.40806E-08    0.68940E-13    0.38357E-18
+    2    2    0.95225E-10    0.10000E+01    0.10918E+04    0.85761E-08    0.25711E-12    0.80708E-18
+    2    2    0.95225E-10    0.10000E+01    0.88049E+03    0.17636E-07    0.94670E-12    0.16610E-17
+    2    2    0.95225E-10    0.10000E+01    0.71007E+03    0.35560E-07    0.34475E-11    0.33511E-17
+    2    2    0.95225E-10    0.10000E+01    0.57264E+03    0.70490E-07    0.12266E-10    0.66454E-17
+    2    2    0.95225E-10    0.10000E+01    0.46180E+03    0.13745E-06    0.41255E-10    0.12961E-16
+    2    2    0.95225E-10    0.10000E+01    0.37242E+03    0.26237E-06    0.12579E-09    0.24744E-16
+    2    2    0.95225E-10    0.10000E+01    0.30034E+03    0.48462E-06    0.33740E-09    0.45710E-16
+    2    2    0.95225E-10    0.10000E+01    0.24221E+03    0.85384E-06    0.78780E-09    0.80539E-16
+    2    2    0.95225E-10    0.10000E+01    0.19533E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    2    2    0.95225E-10    0.10000E+01    0.15752E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    2    2    0.16616E-09    0.10000E+01    0.80645E+05    0.10831E-56    0.84134E-68    0.33650E-66
+    2    2    0.16616E-09    0.10000E+01    0.65036E+05    0.94382E-56    0.13506E-66    0.29210E-65
+    2    2    0.16616E-09    0.10000E+01    0.52449E+05    0.81476E-55    0.18599E-65    0.25175E-64
+    2    2    0.16616E-09    0.10000E+01    0.42297E+05    0.62646E-54    0.26584E-64    0.19204E-63
+    2    2    0.16616E-09    0.10000E+01    0.34111E+05    0.47293E-53    0.41443E-63    0.13945E-62
+    2    2    0.16616E-09    0.10000E+01    0.27509E+05    0.38376E-52    0.82703E-62    0.99836E-62
+    2    2    0.16616E-09    0.10000E+01    0.22184E+05    0.38951E-51    0.23108E-60    0.77605E-61
+    2    2    0.16616E-09    0.10000E+01    0.17891E+05    0.53703E-50    0.71872E-59    0.82846E-60
+    2    2    0.16616E-09    0.10000E+01    0.14428E+05    0.84667E-49    0.21403E-57    0.12129E-58
+    2    2    0.16616E-09    0.10000E+01    0.11635E+05    0.13169E-47    0.60847E-56    0.19194E-57
+    2    2    0.16616E-09    0.10000E+01    0.93834E+04    0.19721E-46    0.16918E-54    0.29612E-56
+    2    2    0.16616E-09    0.10000E+01    0.75673E+04    0.28850E-45    0.46590E-53    0.44363E-55
+    2    2    0.16616E-09    0.10000E+01    0.61026E+04    0.41726E-44    0.12762E-51    0.65289E-54
+    2    2    0.16616E-09    0.10000E+01    0.49215E+04    0.59980E-43    0.34818E-50    0.95066E-53
+    2    2    0.16616E-09    0.10000E+01    0.39689E+04    0.85857E-42    0.94687E-49    0.13742E-51
+    2    2    0.16616E-09    0.10000E+01    0.32008E+04    0.38534E-39    0.83094E-46    0.62162E-49
+    2    2    0.16616E-09    0.10000E+01    0.25813E+04    0.28572E-30    0.14110E-36    0.46404E-40
+    2    2    0.16616E-09    0.10000E+01    0.20817E+04    0.55023E-14    0.12112E-19    0.89981E-24
+    2    2    0.16616E-09    0.10000E+01    0.16788E+04    0.18735E-08    0.17967E-13    0.30768E-18
+    2    2    0.16616E-09    0.10000E+01    0.13538E+04    0.40327E-08    0.68292E-13    0.66322E-18
+    2    2    0.16616E-09    0.10000E+01    0.10918E+04    0.84828E-08    0.25473E-12    0.13965E-17
+    2    2    0.16616E-09    0.10000E+01    0.88049E+03    0.17454E-07    0.93805E-12    0.28757E-17
+    2    2    0.16616E-09    0.10000E+01    0.71007E+03    0.35210E-07    0.34161E-11    0.58040E-17
+    2    2    0.16616E-09    0.10000E+01    0.57264E+03    0.69816E-07    0.12154E-10    0.11512E-16
+    2    2    0.16616E-09    0.10000E+01    0.46180E+03    0.13616E-06    0.40880E-10    0.22458E-16
+    2    2    0.16616E-09    0.10000E+01    0.37242E+03    0.25994E-06    0.12465E-09    0.42878E-16
+    2    2    0.16616E-09    0.10000E+01    0.30034E+03    0.48017E-06    0.33433E-09    0.79212E-16
+    2    2    0.16616E-09    0.10000E+01    0.24221E+03    0.84602E-06    0.78064E-09    0.13957E-15
+    2    2    0.16616E-09    0.10000E+01    0.19533E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    2    2    0.16616E-09    0.10000E+01    0.15752E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    2    2    0.28994E-09    0.10000E+01    0.80645E+05    0.22018E-56    0.16924E-67    0.11277E-65
+    2    2    0.28994E-09    0.10000E+01    0.65036E+05    0.19028E-55    0.27104E-66    0.96716E-65
+    2    2    0.28994E-09    0.10000E+01    0.52449E+05    0.16358E-54    0.36936E-65    0.82800E-64
+    2    2    0.28994E-09    0.10000E+01    0.42297E+05    0.12452E-53    0.50578E-64    0.62651E-63
+    2    2    0.28994E-09    0.10000E+01    0.34111E+05    0.90540E-53    0.69142E-63    0.45007E-62
+    2    2    0.28994E-09    0.10000E+01    0.27509E+05    0.65399E-52    0.10273E-61    0.31386E-61
+    2    2    0.28994E-09    0.10000E+01    0.22184E+05    0.51137E-51    0.21676E-60    0.21732E-60
+    2    2    0.28994E-09    0.10000E+01    0.17891E+05    0.53345E-50    0.62723E-59    0.17683E-59
+    2    2    0.28994E-09    0.10000E+01    0.14428E+05    0.75578E-49    0.19031E-57    0.20791E-58
+    2    2    0.28994E-09    0.10000E+01    0.11635E+05    0.11753E-47    0.55607E-56    0.31079E-57
+    2    2    0.28994E-09    0.10000E+01    0.93834E+04    0.17999E-46    0.15782E-54    0.48263E-56
+    2    2    0.28994E-09    0.10000E+01    0.75673E+04    0.26867E-45    0.44100E-53    0.73387E-55
+    2    2    0.28994E-09    0.10000E+01    0.61026E+04    0.39446E-44    0.12210E-51    0.10925E-53
+    2    2    0.28994E-09    0.10000E+01    0.49215E+04    0.57333E-43    0.33587E-50    0.16037E-52
+    2    2    0.28994E-09    0.10000E+01    0.39689E+04    0.82767E-42    0.91937E-49    0.23322E-51
+    2    2    0.28994E-09    0.10000E+01    0.32008E+04    0.37399E-39    0.81124E-46    0.10600E-48
+    2    2    0.28994E-09    0.10000E+01    0.25813E+04    0.27895E-30    0.13850E-36    0.79468E-40
+    2    2    0.28994E-09    0.10000E+01    0.20817E+04    0.54046E-14    0.11956E-19    0.15479E-23
+    2    2    0.28994E-09    0.10000E+01    0.16788E+04    0.18472E-08    0.17776E-13    0.53079E-18
+    2    2    0.28994E-09    0.10000E+01    0.13538E+04    0.39810E-08    0.67587E-13    0.11452E-17
+    2    2    0.28994E-09    0.10000E+01    0.10918E+04    0.83818E-08    0.25215E-12    0.24131E-17
+    2    2    0.28994E-09    0.10000E+01    0.88049E+03    0.17258E-07    0.92860E-12    0.49714E-17
+    2    2    0.28994E-09    0.10000E+01    0.71007E+03    0.34829E-07    0.33818E-11    0.10037E-16
+    2    2    0.28994E-09    0.10000E+01    0.57264E+03    0.69083E-07    0.12032E-10    0.19913E-16
+    2    2    0.28994E-09    0.10000E+01    0.46180E+03    0.13476E-06    0.40470E-10    0.38851E-16
+    2    2    0.28994E-09    0.10000E+01    0.37242E+03    0.25729E-06    0.12340E-09    0.74183E-16
+    2    2    0.28994E-09    0.10000E+01    0.30034E+03    0.47530E-06    0.33098E-09    0.13705E-15
+    2    2    0.28994E-09    0.10000E+01    0.24221E+03    0.83748E-06    0.77281E-09    0.24149E-15
+    2    2    0.28994E-09    0.10000E+01    0.19533E+03    0.13200E-05    0.14686E-08    0.38062E-15
+    2    2    0.28994E-09    0.10000E+01    0.15752E+03    0.13200E-05    0.14686E-08    0.38062E-15
+    2    2    0.50593E-09    0.10000E+01    0.80645E+05    0.45186E-56    0.34244E-67    0.40784E-65
+    2    2    0.50593E-09    0.10000E+01    0.65036E+05    0.38615E-55    0.54575E-66    0.34590E-64
+    2    2    0.50593E-09    0.10000E+01    0.52449E+05    0.32979E-54    0.73583E-65    0.29392E-63
+    2    2    0.50593E-09    0.10000E+01    0.42297E+05    0.24878E-53    0.99119E-64    0.22015E-62
+    2    2    0.50593E-09    0.10000E+01    0.34111E+05    0.17824E-52    0.13069E-62    0.15625E-61
+    2    2    0.50593E-09    0.10000E+01    0.27509E+05    0.12426E-51    0.16812E-61    0.10751E-60
+    2    2    0.50593E-09    0.10000E+01    0.22184E+05    0.85693E-51    0.25655E-60    0.70994E-60
+    2    2    0.50593E-09    0.10000E+01    0.17891E+05    0.67513E-50    0.59316E-59    0.48268E-59
+    2    2    0.50593E-09    0.10000E+01    0.14428E+05    0.75142E-49    0.17367E-57    0.42746E-58
+    2    2    0.50593E-09    0.10000E+01    0.11635E+05    0.10888E-47    0.51671E-56    0.54801E-57
+    2    2    0.50593E-09    0.10000E+01    0.93834E+04    0.16748E-46    0.14936E-54    0.82467E-56
+    2    2    0.50593E-09    0.10000E+01    0.75673E+04    0.25395E-45    0.42250E-53    0.12546E-54
+    2    2    0.50593E-09    0.10000E+01    0.61026E+04    0.37748E-44    0.11795E-51    0.18729E-53
+    2    2    0.50593E-09    0.10000E+01    0.49215E+04    0.55345E-43    0.32647E-50    0.27529E-52
+    2    2    0.50593E-09    0.10000E+01    0.39689E+04    0.80410E-42    0.89805E-49    0.40065E-51
+    2    2    0.50593E-09    0.10000E+01    0.32008E+04    0.36521E-39    0.79582E-46    0.18226E-48
+    2    2    0.50593E-09    0.10000E+01    0.25813E+04    0.27367E-30    0.13646E-36    0.13683E-39
+    2    2    0.50593E-09    0.10000E+01    0.20817E+04    0.53288E-14    0.11836E-19    0.26712E-23
+    2    2    0.50593E-09    0.10000E+01    0.16788E+04    0.18269E-08    0.17631E-13    0.91739E-18
+    2    2    0.50593E-09    0.10000E+01    0.13538E+04    0.39414E-08    0.67053E-13    0.19802E-17
+    2    2    0.50593E-09    0.10000E+01    0.10918E+04    0.83047E-08    0.25019E-12    0.41740E-17
+    2    2    0.50593E-09    0.10000E+01    0.88049E+03    0.17108E-07    0.92144E-12    0.86012E-17
+    2    2    0.50593E-09    0.10000E+01    0.71007E+03    0.34540E-07    0.33558E-11    0.17368E-16
+    2    2    0.50593E-09    0.10000E+01    0.57264E+03    0.68525E-07    0.11940E-10    0.34461E-16
+    2    2    0.50593E-09    0.10000E+01    0.46180E+03    0.13369E-06    0.40157E-10    0.67237E-16
+    2    2    0.50593E-09    0.10000E+01    0.37242E+03    0.25527E-06    0.12245E-09    0.12839E-15
+    2    2    0.50593E-09    0.10000E+01    0.30034E+03    0.47160E-06    0.32842E-09    0.23719E-15
+    2    2    0.50593E-09    0.10000E+01    0.24221E+03    0.83098E-06    0.76683E-09    0.41795E-15
+    2    2    0.50593E-09    0.10000E+01    0.19533E+03    0.13097E-05    0.14572E-08    0.65874E-15
+    2    2    0.50593E-09    0.10000E+01    0.15752E+03    0.13097E-05    0.14572E-08    0.65874E-15
+    2    2    0.88282E-09    0.10000E+01    0.80645E+05    0.94532E-56    0.70698E-67    0.16539E-64
+    2    2    0.88282E-09    0.10000E+01    0.65036E+05    0.79934E-55    0.11199E-65    0.13885E-63
+    2    2    0.88282E-09    0.10000E+01    0.52449E+05    0.67767E-54    0.14902E-64    0.11707E-62
+    2    2    0.88282E-09    0.10000E+01    0.42297E+05    0.50576E-53    0.19741E-63    0.86627E-62
+    2    2    0.88282E-09    0.10000E+01    0.34111E+05    0.35710E-52    0.25553E-62    0.60391E-61
+    2    2    0.88282E-09    0.10000E+01    0.27509E+05    0.24429E-51    0.31158E-61    0.40660E-60
+    2    2    0.88282E-09    0.10000E+01    0.22184E+05    0.16030E-50    0.39106E-60    0.26006E-59
+    2    2    0.88282E-09    0.10000E+01    0.17891E+05    0.10753E-49    0.68321E-59    0.16279E-58
+    2    2    0.88282E-09    0.10000E+01    0.14428E+05    0.92304E-49    0.17749E-57    0.11971E-57
+    2    2    0.88282E-09    0.10000E+01    0.11635E+05    0.11453E-47    0.51854E-56    0.12705E-56
+    2    2    0.88282E-09    0.10000E+01    0.93834E+04    0.16913E-46    0.14961E-54    0.17315E-55
+    2    2    0.88282E-09    0.10000E+01    0.75673E+04    0.25451E-45    0.42198E-53    0.24989E-54
+    2    2    0.88282E-09    0.10000E+01    0.61026E+04    0.37703E-44    0.11740E-51    0.35917E-53
+    2    2    0.88282E-09    0.10000E+01    0.49215E+04    0.55101E-43    0.32412E-50    0.51243E-52
+    2    2    0.88282E-09    0.10000E+01    0.39689E+04    0.79854E-42    0.89034E-49    0.72913E-51
+    2    2    0.88282E-09    0.10000E+01    0.32008E+04    0.36217E-39    0.78871E-46    0.32633E-48
+    2    2    0.88282E-09    0.10000E+01    0.25813E+04    0.27130E-30    0.13531E-36    0.24219E-39
+    2    2    0.88282E-09    0.10000E+01    0.20817E+04    0.52867E-14    0.11751E-19    0.46868E-23
+    2    2    0.88282E-09    0.10000E+01    0.16788E+04    0.18138E-08    0.17514E-13    0.16023E-17
+    2    2    0.88282E-09    0.10000E+01    0.13538E+04    0.39137E-08    0.66612E-13    0.34523E-17
+    2    2    0.88282E-09    0.10000E+01    0.10918E+04    0.82476E-08    0.24854E-12    0.72682E-17
+    2    2    0.88282E-09    0.10000E+01    0.88049E+03    0.16993E-07    0.91532E-12    0.14965E-16
+    2    2    0.88282E-09    0.10000E+01    0.71007E+03    0.34309E-07    0.33333E-11    0.30199E-16
+    2    2    0.88282E-09    0.10000E+01    0.57264E+03    0.68068E-07    0.11859E-10    0.59894E-16
+    2    2    0.88282E-09    0.10000E+01    0.46180E+03    0.13280E-06    0.39886E-10    0.11682E-15
+    2    2    0.88282E-09    0.10000E+01    0.37242E+03    0.25356E-06    0.12162E-09    0.22301E-15
+    2    2    0.88282E-09    0.10000E+01    0.30034E+03    0.46844E-06    0.32619E-09    0.41193E-15
+    2    2    0.88282E-09    0.10000E+01    0.24221E+03    0.82539E-06    0.76161E-09    0.72575E-15
+    2    2    0.88282E-09    0.10000E+01    0.19533E+03    0.13009E-05    0.14473E-08    0.11438E-14
+    2    2    0.88282E-09    0.10000E+01    0.15752E+03    0.13009E-05    0.14473E-08    0.11438E-14
+    2    2    0.15405E-08    0.10000E+01    0.80645E+05    0.19793E-55    0.14661E-66    0.68500E-64
+    2    2    0.15405E-08    0.10000E+01    0.65036E+05    0.16608E-54    0.23109E-65    0.57290E-63
+    2    2    0.15405E-08    0.10000E+01    0.52449E+05    0.13999E-53    0.30403E-64    0.48172E-62
+    2    2    0.15405E-08    0.10000E+01    0.42297E+05    0.10352E-52    0.39635E-63    0.35491E-61
+    2    2    0.15405E-08    0.10000E+01    0.34111E+05    0.72101E-52    0.50398E-62    0.24596E-60
+    2    2    0.15405E-08    0.10000E+01    0.27509E+05    0.48506E-51    0.59835E-61    0.16464E-59
+    2    2    0.15405E-08    0.10000E+01    0.22184E+05    0.31032E-50    0.69333E-60    0.10457E-58
+    2    2    0.15405E-08    0.10000E+01    0.17891E+05    0.19456E-49    0.10108E-58    0.63464E-58
+    2    2    0.15405E-08    0.10000E+01    0.14428E+05    0.14275E-48    0.22523E-57    0.41471E-57
+    2    2    0.15405E-08    0.10000E+01    0.11635E+05    0.14989E-47    0.61293E-56    0.36284E-56
+    2    2    0.15405E-08    0.10000E+01    0.93834E+04    0.20204E-46    0.16954E-54    0.42937E-55
+    2    2    0.15405E-08    0.10000E+01    0.75673E+04    0.28948E-45    0.46219E-53    0.57127E-54
+    2    2    0.15405E-08    0.10000E+01    0.61026E+04    0.41400E-44    0.12506E-51    0.77345E-53
+    2    2    0.15405E-08    0.10000E+01    0.49215E+04    0.58832E-43    0.33802E-50    0.10482E-51
+    2    2    0.15405E-08    0.10000E+01    0.39689E+04    0.83444E-42    0.91452E-49    0.14278E-50
+    2    2    0.15405E-08    0.10000E+01    0.32008E+04    0.37251E-39    0.80144E-46    0.61701E-48
+    2    2    0.15405E-08    0.10000E+01    0.25813E+04    0.27587E-30    0.13636E-36    0.44537E-39
+    2    2    0.15405E-08    0.10000E+01    0.20817E+04    0.53282E-14    0.11760E-19    0.84161E-23
+    2    2    0.15405E-08    0.10000E+01    0.16788E+04    0.18194E-08    0.17486E-13    0.28390E-17
+    2    2    0.15405E-08    0.10000E+01    0.13538E+04    0.39186E-08    0.66475E-13    0.60857E-17
+    2    2    0.15405E-08    0.10000E+01    0.10918E+04    0.82476E-08    0.24794E-12    0.12767E-16
+    2    2    0.15405E-08    0.10000E+01    0.88049E+03    0.16978E-07    0.91289E-12    0.26220E-16
+    2    2    0.15405E-08    0.10000E+01    0.71007E+03    0.34257E-07    0.33239E-11    0.52817E-16
+    2    2    0.15405E-08    0.10000E+01    0.57264E+03    0.67934E-07    0.11824E-10    0.10461E-15
+    2    2    0.15405E-08    0.10000E+01    0.46180E+03    0.13249E-06    0.39764E-10    0.20385E-15
+    2    2    0.15405E-08    0.10000E+01    0.37242E+03    0.25291E-06    0.12124E-09    0.38889E-15
+    2    2    0.15405E-08    0.10000E+01    0.30034E+03    0.46715E-06    0.32517E-09    0.71800E-15
+    2    2    0.15405E-08    0.10000E+01    0.24221E+03    0.82303E-06    0.75921E-09    0.12646E-14
+    2    2    0.15405E-08    0.10000E+01    0.19533E+03    0.12971E-05    0.14427E-08    0.19927E-14
+    2    2    0.15405E-08    0.10000E+01    0.15752E+03    0.12971E-05    0.14427E-08    0.19927E-14
+    2    2    0.26880E-08    0.10000E+01    0.80645E+05    0.43598E-55    0.32366E-66    0.84405E-63
+    2    2    0.26880E-08    0.10000E+01    0.65036E+05    0.36651E-54    0.51130E-65    0.71110E-62
+    2    2    0.26880E-08    0.10000E+01    0.52449E+05    0.30963E-53    0.67715E-64    0.60200E-61
+    2    2    0.26880E-08    0.10000E+01    0.42297E+05    0.23022E-52    0.89624E-63    0.44941E-60
+    2    2    0.26880E-08    0.10000E+01    0.34111E+05    0.16241E-51    0.11785E-61    0.31947E-59
+    2    2    0.26880E-08    0.10000E+01    0.27509E+05    0.11235E-50    0.14926E-60    0.22383E-58
+    2    2    0.26880E-08    0.10000E+01    0.22184E+05    0.75589E-50    0.18377E-59    0.15308E-57
+    2    2    0.26880E-08    0.10000E+01    0.17891E+05    0.49671E-49    0.23874E-58    0.10061E-56
+    2    2    0.26880E-08    0.10000E+01    0.14428E+05    0.33775E-48    0.37998E-57    0.63149E-56
+    2    2    0.26880E-08    0.10000E+01    0.11635E+05    0.26889E-47    0.78924E-56    0.38403E-55
+    2    2    0.26880E-08    0.10000E+01    0.93834E+04    0.27442E-46    0.19477E-54    0.23999E-54
+    2    2    0.26880E-08    0.10000E+01    0.75673E+04    0.34085E-45    0.51259E-53    0.17687E-53
+    2    2    0.26880E-08    0.10000E+01    0.61026E+04    0.46273E-44    0.13673E-51    0.17518E-52
+    2    2    0.26880E-08    0.10000E+01    0.49215E+04    0.64436E-43    0.36484E-50    0.21741E-51
+    2    2    0.26880E-08    0.10000E+01    0.39689E+04    0.90126E-42    0.97377E-49    0.29081E-50
+    2    2    0.26880E-08    0.10000E+01    0.32008E+04    0.39683E-39    0.84193E-46    0.12318E-47
+    2    2    0.26880E-08    0.10000E+01    0.25813E+04    0.28970E-30    0.14126E-36    0.85918E-39
+    2    2    0.26880E-08    0.10000E+01    0.20817E+04    0.55090E-14    0.11997E-19    0.15526E-22
+    2    2    0.26880E-08    0.10000E+01    0.16788E+04    0.18637E-08    0.17730E-13    0.50991E-17
+    2    2    0.26880E-08    0.10000E+01    0.13538E+04    0.39987E-08    0.67336E-13    0.10748E-16
+    2    2    0.26880E-08    0.10000E+01    0.10918E+04    0.83933E-08    0.25099E-12    0.22288E-16
+    2    2    0.26880E-08    0.10000E+01    0.88049E+03    0.17244E-07    0.92375E-12    0.45396E-16
+    2    2    0.26880E-08    0.10000E+01    0.71007E+03    0.34747E-07    0.33626E-11    0.90891E-16
+    2    2    0.26880E-08    0.10000E+01    0.57264E+03    0.68839E-07    0.11960E-10    0.17921E-15
+    2    2    0.26880E-08    0.10000E+01    0.46180E+03    0.13417E-06    0.40218E-10    0.34801E-15
+    2    2    0.26880E-08    0.10000E+01    0.37242E+03    0.25600E-06    0.12262E-09    0.66224E-15
+    2    2    0.26880E-08    0.10000E+01    0.30034E+03    0.47272E-06    0.32885E-09    0.12205E-14
+    2    2    0.26880E-08    0.10000E+01    0.24221E+03    0.83268E-06    0.76781E-09    0.21469E-14
+    2    2    0.26880E-08    0.10000E+01    0.19533E+03    0.13122E-05    0.14591E-08    0.33804E-14
+    2    2    0.26880E-08    0.10000E+01    0.15752E+03    0.13122E-05    0.14591E-08    0.33804E-14
+    2    2    0.46905E-08    0.10000E+01    0.80645E+05    0.80826E-55    0.60080E-66    0.25172E-62
+    2    2    0.46905E-08    0.10000E+01    0.65036E+05    0.68017E-54    0.94997E-65    0.21231E-61
+    2    2    0.46905E-08    0.10000E+01    0.52449E+05    0.57519E-53    0.12611E-63    0.17992E-60
+    2    2    0.46905E-08    0.10000E+01    0.42297E+05    0.42849E-52    0.16763E-62    0.13457E-59
+    2    2    0.46905E-08    0.10000E+01    0.34111E+05    0.30338E-51    0.22199E-61    0.96000E-59
+    2    2    0.46905E-08    0.10000E+01    0.27509E+05    0.21113E-50    0.28375E-60    0.67667E-58
+    2    2    0.46905E-08    0.10000E+01    0.22184E+05    0.14310E-49    0.34841E-59    0.46746E-57
+    2    2    0.46905E-08    0.10000E+01    0.17891E+05    0.93846E-49    0.42679E-58    0.31204E-56
+    2    2    0.46905E-08    0.10000E+01    0.14428E+05    0.61020E-48    0.57873E-57    0.19957E-55
+    2    2    0.46905E-08    0.10000E+01    0.11635E+05    0.42573E-47    0.98364E-56    0.12250E-54
+    2    2    0.46905E-08    0.10000E+01    0.93834E+04    0.35867E-46    0.21362E-54    0.73662E-54
+    2    2    0.46905E-08    0.10000E+01    0.75673E+04    0.38505E-45    0.53629E-53    0.46997E-53
+    2    2    0.46905E-08    0.10000E+01    0.61026E+04    0.48978E-44    0.14126E-51    0.37875E-52
+    2    2    0.46905E-08    0.10000E+01    0.49215E+04    0.66774E-43    0.37469E-50    0.41846E-51
+    2    2    0.46905E-08    0.10000E+01    0.39689E+04    0.92611E-42    0.99357E-49    0.54566E-50
+    2    2    0.46905E-08    0.10000E+01    0.32008E+04    0.40497E-39    0.85304E-46    0.23044E-47
+    2    2    0.46905E-08    0.10000E+01    0.25813E+04    0.29349E-30    0.14209E-36    0.15921E-38
+    2    2    0.46905E-08    0.10000E+01    0.20817E+04    0.55387E-14    0.11974E-19    0.28226E-22
+    2    2    0.46905E-08    0.10000E+01    0.16788E+04    0.18659E-08    0.17641E-13    0.91433E-17
+    2    2    0.46905E-08    0.10000E+01    0.13538E+04    0.39935E-08    0.66952E-13    0.19050E-16
+    2    2    0.46905E-08    0.10000E+01    0.10918E+04    0.83684E-08    0.24944E-12    0.39189E-16
+    2    2    0.46905E-08    0.10000E+01    0.88049E+03    0.17173E-07    0.91766E-12    0.79363E-16
+    2    2    0.46905E-08    0.10000E+01    0.71007E+03    0.34574E-07    0.33395E-11    0.15823E-15
+    2    2    0.46905E-08    0.10000E+01    0.57264E+03    0.68452E-07    0.11875E-10    0.31099E-15
+    2    2    0.46905E-08    0.10000E+01    0.46180E+03    0.13335E-06    0.39928E-10    0.60250E-15
+    2    2    0.46905E-08    0.10000E+01    0.37242E+03    0.25434E-06    0.12172E-09    0.11445E-14
+    2    2    0.46905E-08    0.10000E+01    0.30034E+03    0.46953E-06    0.32644E-09    0.21066E-14
+    2    2    0.46905E-08    0.10000E+01    0.24221E+03    0.82692E-06    0.76216E-09    0.37026E-14
+    2    2    0.46905E-08    0.10000E+01    0.19533E+03    0.13029E-05    0.14483E-08    0.58266E-14
+    2    2    0.46905E-08    0.10000E+01    0.15752E+03    0.13029E-05    0.14483E-08    0.58266E-14
+    2    2    0.81846E-08    0.10000E+01    0.80645E+05    0.14883E-54    0.11078E-65    0.76483E-62
+    2    2    0.81846E-08    0.10000E+01    0.65036E+05    0.12539E-53    0.17534E-64    0.64566E-61
+    2    2    0.81846E-08    0.10000E+01    0.52449E+05    0.10615E-52    0.23333E-63    0.54758E-60
+    2    2    0.81846E-08    0.10000E+01    0.42297E+05    0.79232E-52    0.31152E-62    0.41015E-59
+    2    2    0.81846E-08    0.10000E+01    0.34111E+05    0.56308E-51    0.41560E-61    0.29335E-58
+    2    2    0.81846E-08    0.10000E+01    0.27509E+05    0.39437E-50    0.53731E-60    0.20769E-57
+    2    2    0.81846E-08    0.10000E+01    0.22184E+05    0.26984E-49    0.66636E-59    0.14455E-56
+    2    2    0.81846E-08    0.10000E+01    0.17891E+05    0.17844E-48    0.80345E-58    0.97644E-56
+    2    2    0.81846E-08    0.10000E+01    0.14428E+05    0.11479E-47    0.99569E-57    0.63500E-55
+    2    2    0.81846E-08    0.10000E+01    0.11635E+05    0.74742E-47    0.14067E-55    0.39648E-54
+    2    2    0.81846E-08    0.10000E+01    0.93834E+04    0.53735E-46    0.25282E-54    0.23820E-53
+    2    2    0.81846E-08    0.10000E+01    0.75673E+04    0.47717E-45    0.57551E-53    0.14184E-52
+    2    2    0.81846E-08    0.10000E+01    0.61026E+04    0.53854E-44    0.14751E-51    0.95360E-52
+    2    2    0.81846E-08    0.10000E+01    0.49215E+04    0.70269E-43    0.38879E-50    0.88176E-51
+    2    2    0.81846E-08    0.10000E+01    0.39689E+04    0.96226E-42    0.10248E-48    0.10776E-49
+    2    2    0.81846E-08    0.10000E+01    0.32008E+04    0.41772E-39    0.87259E-46    0.45019E-47
+    2    2    0.81846E-08    0.10000E+01    0.25813E+04    0.30003E-30    0.14386E-36    0.30739E-38
+    2    2    0.81846E-08    0.10000E+01    0.20817E+04    0.56020E-14    0.11972E-19    0.53129E-22
+    2    2    0.81846E-08    0.10000E+01    0.16788E+04    0.18752E-08    0.17543E-13    0.16856E-16
+    2    2    0.81846E-08    0.10000E+01    0.13538E+04    0.39968E-08    0.66508E-13    0.34451E-16
+    2    2    0.81846E-08    0.10000E+01    0.10918E+04    0.83517E-08    0.24757E-12    0.69918E-16
+    2    2    0.81846E-08    0.10000E+01    0.88049E+03    0.17105E-07    0.91022E-12    0.14021E-15
+    2    2    0.81846E-08    0.10000E+01    0.71007E+03    0.34386E-07    0.33108E-11    0.27753E-15
+    2    2    0.81846E-08    0.10000E+01    0.57264E+03    0.68007E-07    0.11770E-10    0.54251E-15
+    2    2    0.81846E-08    0.10000E+01    0.46180E+03    0.13237E-06    0.39565E-10    0.10467E-14
+    2    2    0.81846E-08    0.10000E+01    0.37242E+03    0.25233E-06    0.12060E-09    0.19824E-14
+    2    2    0.81846E-08    0.10000E+01    0.30034E+03    0.46562E-06    0.32341E-09    0.36412E-14
+    2    2    0.81846E-08    0.10000E+01    0.24221E+03    0.81978E-06    0.75504E-09    0.63903E-14
+    2    2    0.81846E-08    0.10000E+01    0.19533E+03    0.12914E-05    0.14347E-08    0.10047E-13
+    2    2    0.81846E-08    0.10000E+01    0.15752E+03    0.12914E-05    0.14347E-08    0.10047E-13
+    2    2    0.14282E-07    0.10000E+01    0.80645E+05    0.27285E-54    0.20336E-65    0.23577E-61
+    2    2    0.14282E-07    0.10000E+01    0.65036E+05    0.23011E-53    0.32213E-64    0.19916E-60
+    2    2    0.14282E-07    0.10000E+01    0.52449E+05    0.19498E-52    0.42960E-63    0.16901E-59
+    2    2    0.14282E-07    0.10000E+01    0.42297E+05    0.14580E-51    0.57576E-62    0.12672E-58
+    2    2    0.14282E-07    0.10000E+01    0.34111E+05    0.10395E-50    0.77302E-61    0.90811E-58
+    2    2    0.14282E-07    0.10000E+01    0.27509E+05    0.73212E-50    0.10097E-59    0.64500E-57
+    2    2    0.14282E-07    0.10000E+01    0.22184E+05    0.50533E-49    0.12685E-58    0.45133E-56
+    2    2    0.14282E-07    0.10000E+01    0.17891E+05    0.33780E-48    0.15360E-57    0.30758E-55
+    2    2    0.14282E-07    0.10000E+01    0.14428E+05    0.21833E-47    0.18390E-56    0.20268E-54
+    2    2    0.14282E-07    0.10000E+01    0.11635E+05    0.13873E-46    0.23059E-55    0.12870E-53
+    2    2    0.14282E-07    0.10000E+01    0.93834E+04    0.90746E-46    0.33890E-54    0.78387E-53
+    2    2    0.14282E-07    0.10000E+01    0.75673E+04    0.67394E-45    0.65435E-53    0.45884E-52
+    2    2    0.14282E-07    0.10000E+01    0.61026E+04    0.63849E-44    0.15764E-51    0.27644E-51
+    2    2    0.14282E-07    0.10000E+01    0.49215E+04    0.76409E-43    0.41073E-50    0.21122E-50
+    2    2    0.14282E-07    0.10000E+01    0.39689E+04    0.10204E-41    0.10771E-48    0.23026E-49
+    2    2    0.14282E-07    0.10000E+01    0.32008E+04    0.43906E-39    0.90850E-46    0.93591E-47
+    2    2    0.14282E-07    0.10000E+01    0.25813E+04    0.31202E-30    0.14764E-36    0.62949E-38
+    2    2    0.14282E-07    0.10000E+01    0.20817E+04    0.57402E-14    0.12042E-19    0.10549E-21
+    2    2    0.14282E-07    0.10000E+01    0.16788E+04    0.19031E-08    0.17485E-13    0.32501E-16
+    2    2    0.14282E-07    0.10000E+01    0.13538E+04    0.40273E-08    0.66164E-13    0.64463E-16
+    2    2    0.14282E-07    0.10000E+01    0.10918E+04    0.83752E-08    0.24594E-12    0.12800E-15
+    2    2    0.14282E-07    0.10000E+01    0.88049E+03    0.17095E-07    0.90328E-12    0.25257E-15
+    2    2    0.14282E-07    0.10000E+01    0.71007E+03    0.34281E-07    0.32831E-11    0.49386E-15
+    2    2    0.14282E-07    0.10000E+01    0.57264E+03    0.67675E-07    0.11665E-10    0.95650E-15
+    2    2    0.14282E-07    0.10000E+01    0.46180E+03    0.13155E-06    0.39199E-10    0.18327E-14
+    2    2    0.14282E-07    0.10000E+01    0.37242E+03    0.25050E-06    0.11946E-09    0.34531E-14
+    2    2    0.14282E-07    0.10000E+01    0.30034E+03    0.46191E-06    0.32032E-09    0.63193E-14
+    2    2    0.14282E-07    0.10000E+01    0.24221E+03    0.81285E-06    0.74777E-09    0.11062E-13
+    2    2    0.14282E-07    0.10000E+01    0.19533E+03    0.12801E-05    0.14208E-08    0.17366E-13
+    2    2    0.14282E-07    0.10000E+01    0.15752E+03    0.12801E-05    0.14208E-08    0.17366E-13
+    2    2    0.24920E-07    0.10000E+01    0.80645E+05    0.49850E-54    0.37192E-65    0.73393E-61
+    2    2    0.24920E-07    0.10000E+01    0.65036E+05    0.42076E-53    0.58954E-64    0.62028E-60
+    2    2    0.24920E-07    0.10000E+01    0.52449E+05    0.35680E-52    0.78761E-63    0.52660E-59
+    2    2    0.24920E-07    0.10000E+01    0.42297E+05    0.26718E-51    0.10588E-61    0.39517E-58
+    2    2    0.24920E-07    0.10000E+01    0.34111E+05    0.19100E-50    0.14288E-60    0.28359E-57
+    2    2    0.24920E-07    0.10000E+01    0.27509E+05    0.13511E-49    0.18819E-59    0.20191E-56
+    2    2    0.24920E-07    0.10000E+01    0.22184E+05    0.93927E-49    0.23924E-58    0.14185E-55
+    2    2    0.24920E-07    0.10000E+01    0.17891E+05    0.63422E-48    0.29292E-57    0.97309E-55
+    2    2    0.24920E-07    0.10000E+01    0.14428E+05    0.41396E-47    0.34905E-56    0.64771E-54
+    2    2    0.24920E-07    0.10000E+01    0.11635E+05    0.26259E-46    0.41444E-55    0.41710E-53
+    2    2    0.24920E-07    0.10000E+01    0.93834E+04    0.16496E-45    0.52408E-54    0.25822E-52
+    2    2    0.24920E-07    0.10000E+01    0.75673E+04    0.10849E-44    0.82396E-53    0.15213E-51
+    2    2    0.24920E-07    0.10000E+01    0.61026E+04    0.84965E-44    0.17621E-51    0.87443E-51
+    2    2    0.24920E-07    0.10000E+01    0.49215E+04    0.88234E-43    0.44631E-50    0.57534E-50
+    2    2    0.24920E-07    0.10000E+01    0.39689E+04    0.11192E-41    0.11639E-48    0.54166E-49
+    2    2    0.24920E-07    0.10000E+01    0.32008E+04    0.47489E-39    0.97151E-46    0.20950E-46
+    2    2    0.24920E-07    0.10000E+01    0.25813E+04    0.33311E-30    0.15478E-36    0.13840E-37
+    2    2    0.24920E-07    0.10000E+01    0.20817E+04    0.60060E-14    0.12230E-19    0.22464E-21
+    2    2    0.24920E-07    0.10000E+01    0.16788E+04    0.19623E-08    0.17481E-13    0.66779E-16
+    2    2    0.24920E-07    0.10000E+01    0.13538E+04    0.41028E-08    0.65935E-13    0.12695E-15
+    2    2    0.24920E-07    0.10000E+01    0.10918E+04    0.84622E-08    0.24450E-12    0.24402E-15
+    2    2    0.24920E-07    0.10000E+01    0.88049E+03    0.17172E-07    0.89638E-12    0.46958E-15
+    2    2    0.24920E-07    0.10000E+01    0.71007E+03    0.34290E-07    0.32538E-11    0.90048E-15
+    2    2    0.24920E-07    0.10000E+01    0.57264E+03    0.67479E-07    0.11551E-10    0.17179E-14
+    2    2    0.24920E-07    0.10000E+01    0.46180E+03    0.13086E-06    0.38795E-10    0.32536E-14
+    2    2    0.24920E-07    0.10000E+01    0.37242E+03    0.24876E-06    0.11819E-09    0.60775E-14
+    2    2    0.24920E-07    0.10000E+01    0.30034E+03    0.45815E-06    0.31684E-09    0.11053E-13
+    2    2    0.24920E-07    0.10000E+01    0.24221E+03    0.80555E-06    0.73958E-09    0.19267E-13
+    2    2    0.24920E-07    0.10000E+01    0.19533E+03    0.12680E-05    0.14052E-08    0.30166E-13
+    2    2    0.24920E-07    0.10000E+01    0.15752E+03    0.12680E-05    0.14052E-08    0.30166E-13
+    2    2    0.43485E-07    0.10000E+01    0.80645E+05    0.90744E-54    0.67758E-65    0.22898E-60
+    2    2    0.43485E-07    0.10000E+01    0.65036E+05    0.76645E-53    0.10746E-63    0.19360E-59
+    2    2    0.43485E-07    0.10000E+01    0.52449E+05    0.65033E-52    0.14376E-62    0.16442E-58
+    2    2    0.43485E-07    0.10000E+01    0.42297E+05    0.48753E-51    0.19373E-61    0.12346E-57
+    2    2    0.43485E-07    0.10000E+01    0.34111E+05    0.34923E-50    0.26242E-60    0.88701E-57
+    2    2    0.43485E-07    0.10000E+01    0.27509E+05    0.24788E-49    0.34787E-59    0.63270E-56
+    2    2    0.43485E-07    0.10000E+01    0.22184E+05    0.17327E-48    0.44657E-58    0.44586E-55
+    2    2    0.43485E-07    0.10000E+01    0.17891E+05    0.11797E-47    0.55321E-57    0.30738E-54
+    2    2    0.43485E-07    0.10000E+01    0.14428E+05    0.77787E-47    0.66412E-56    0.20617E-53
+    2    2    0.43485E-07    0.10000E+01    0.11635E+05    0.49708E-46    0.77697E-55    0.13423E-52
+    2    2    0.43485E-07    0.10000E+01    0.93834E+04    0.30932E-45    0.90696E-54    0.84318E-52
+    2    2    0.43485E-07    0.10000E+01    0.75673E+04    0.19146E-44    0.11877E-52    0.50368E-51
+    2    2    0.43485E-07    0.10000E+01    0.61026E+04    0.12897E-43    0.21316E-51    0.28620E-50
+    2    2    0.43485E-07    0.10000E+01    0.49215E+04    0.11210E-42    0.50802E-50    0.17168E-49
+    2    2    0.43485E-07    0.10000E+01    0.39689E+04    0.12983E-41    0.13118E-48    0.13980E-48
+    2    2    0.43485E-07    0.10000E+01    0.32008E+04    0.53711E-39    0.10830E-45    0.50446E-46
+    2    2    0.43485E-07    0.10000E+01    0.25813E+04    0.37075E-30    0.16814E-36    0.32679E-37
+    2    2    0.43485E-07    0.10000E+01    0.20817E+04    0.65135E-14    0.12660E-19    0.51678E-21
+    2    2    0.43485E-07    0.10000E+01    0.16788E+04    0.20832E-08    0.17629E-13    0.14810E-15
+    2    2    0.43485E-07    0.10000E+01    0.13538E+04    0.42705E-08    0.66127E-13    0.26727E-15
+    2    2    0.43485E-07    0.10000E+01    0.10918E+04    0.86882E-08    0.24421E-12    0.49214E-15
+    2    2    0.43485E-07    0.10000E+01    0.88049E+03    0.17458E-07    0.89261E-12    0.91436E-15
+    2    2    0.43485E-07    0.10000E+01    0.71007E+03    0.34611E-07    0.32332E-11    0.17040E-14
+    2    2    0.43485E-07    0.10000E+01    0.57264E+03    0.67746E-07    0.11461E-10    0.31766E-14
+    2    2    0.43485E-07    0.10000E+01    0.46180E+03    0.13085E-06    0.38457E-10    0.59076E-14
+    2    2    0.43485E-07    0.10000E+01    0.37242E+03    0.24802E-06    0.11710E-09    0.10882E-13
+    2    2    0.43485E-07    0.10000E+01    0.30034E+03    0.45584E-06    0.31381E-09    0.19591E-13
+    2    2    0.43485E-07    0.10000E+01    0.24221E+03    0.80036E-06    0.73234E-09    0.33905E-13
+    2    2    0.43485E-07    0.10000E+01    0.19533E+03    0.12587E-05    0.13913E-08    0.52850E-13
+    2    2    0.43485E-07    0.10000E+01    0.15752E+03    0.12587E-05    0.13913E-08    0.52850E-13
+    2    2    0.75878E-07    0.10000E+01    0.80645E+05    0.16460E-53    0.12298E-64    0.71670E-60
+    2    2    0.75878E-07    0.10000E+01    0.65036E+05    0.13910E-52    0.19513E-63    0.60615E-59
+    2    2    0.75878E-07    0.10000E+01    0.52449E+05    0.11808E-51    0.26132E-62    0.51492E-58
+    2    2    0.75878E-07    0.10000E+01    0.42297E+05    0.88596E-51    0.35279E-61    0.38685E-57
+    2    2    0.75878E-07    0.10000E+01    0.34111E+05    0.63562E-50    0.47929E-60    0.27819E-56
+    2    2    0.75878E-07    0.10000E+01    0.27509E+05    0.45233E-49    0.63848E-59    0.19872E-55
+    2    2    0.75878E-07    0.10000E+01    0.22184E+05    0.31754E-48    0.82598E-58    0.14038E-54
+    2    2    0.75878E-07    0.10000E+01    0.17891E+05    0.21762E-47    0.10339E-56    0.97154E-54
+    2    2    0.75878E-07    0.10000E+01    0.14428E+05    0.14479E-46    0.12546E-55    0.65554E-53
+    2    2    0.75878E-07    0.10000E+01    0.11635E+05    0.93423E-46    0.14726E-54    0.43050E-52
+    2    2    0.75878E-07    0.10000E+01    0.93834E+04    0.58378E-45    0.16689E-53    0.27368E-51
+    2    2    0.75878E-07    0.10000E+01    0.75673E+04    0.35382E-44    0.19389E-52    0.16587E-50
+    2    2    0.75878E-07    0.10000E+01    0.61026E+04    0.21767E-43    0.28674E-51    0.94653E-50
+    2    2    0.75878E-07    0.10000E+01    0.49215E+04    0.15960E-42    0.61539E-50    0.54070E-49
+    2    2    0.75878E-07    0.10000E+01    0.39689E+04    0.16228E-41    0.15575E-48    0.39017E-48
+    2    2    0.75878E-07    0.10000E+01    0.32008E+04    0.64284E-39    0.12715E-45    0.12986E-45
+    2    2    0.75878E-07    0.10000E+01    0.25813E+04    0.43513E-30    0.19139E-36    0.82420E-37
+    2    2    0.75878E-07    0.10000E+01    0.20817E+04    0.74151E-14    0.13450E-19    0.12828E-20
+    2    2    0.75878E-07    0.10000E+01    0.16788E+04    0.23037E-08    0.17957E-13    0.35639E-15
+    2    2    0.75878E-07    0.10000E+01    0.13538E+04    0.45805E-08    0.66735E-13    0.60854E-15
+    2    2    0.75878E-07    0.10000E+01    0.10918E+04    0.91169E-08    0.24474E-12    0.10662E-14
+    2    2    0.75878E-07    0.10000E+01    0.88049E+03    0.18028E-07    0.88999E-12    0.18959E-14
+    2    2    0.75878E-07    0.10000E+01    0.71007E+03    0.35314E-07    0.32119E-11    0.34007E-14
+    2    2    0.75878E-07    0.10000E+01    0.57264E+03    0.68498E-07    0.11357E-10    0.61364E-14
+    2    2    0.75878E-07    0.10000E+01    0.46180E+03    0.13141E-06    0.38050E-10    0.11108E-13
+    2    2    0.75878E-07    0.10000E+01    0.37242E+03    0.24784E-06    0.11575E-09    0.20026E-13
+    2    2    0.75878E-07    0.10000E+01    0.30034E+03    0.45389E-06    0.31002E-09    0.35473E-13
+    2    2    0.75878E-07    0.10000E+01    0.24221E+03    0.79501E-06    0.72325E-09    0.60685E-13
+    2    2    0.75878E-07    0.10000E+01    0.19533E+03    0.12485E-05    0.13738E-08    0.93908E-13
+    2    2    0.75878E-07    0.10000E+01    0.15752E+03    0.12485E-05    0.13738E-08    0.93908E-13
+    2    2    0.13240E-06    0.10000E+01    0.80645E+05    0.29734E-53    0.22228E-64    0.22335E-59
+    2    2    0.13240E-06    0.10000E+01    0.65036E+05    0.25138E-52    0.35280E-63    0.18895E-58
+    2    2    0.13240E-06    0.10000E+01    0.52449E+05    0.21347E-51    0.47286E-62    0.16055E-57
+    2    2    0.13240E-06    0.10000E+01    0.42297E+05    0.16028E-50    0.63927E-61    0.12067E-56
+    2    2    0.13240E-06    0.10000E+01    0.34111E+05    0.11513E-49    0.87045E-60    0.86835E-56
+    2    2    0.13240E-06    0.10000E+01    0.27509E+05    0.82094E-49    0.11639E-58    0.62104E-55
+    2    2    0.13240E-06    0.10000E+01    0.22184E+05    0.57820E-48    0.15148E-57    0.43955E-54
+    2    2    0.13240E-06    0.10000E+01    0.17891E+05    0.39831E-47    0.19125E-56    0.30515E-53
+    2    2    0.13240E-06    0.10000E+01    0.14428E+05    0.26697E-46    0.23449E-55    0.20687E-52
+    2    2    0.13240E-06    0.10000E+01    0.11635E+05    0.17385E-45    0.27789E-54    0.13677E-51
+    2    2    0.13240E-06    0.10000E+01    0.93834E+04    0.10959E-44    0.31389E-53    0.87782E-51
+    2    2    0.13240E-06    0.10000E+01    0.75673E+04    0.66346E-44    0.34381E-52    0.53883E-50
+    2    2    0.13240E-06    0.10000E+01    0.61026E+04    0.39133E-43    0.43278E-51    0.31053E-49
+    2    2    0.13240E-06    0.10000E+01    0.49215E+04    0.25297E-42    0.80771E-50    0.17353E-48
+    2    2    0.13240E-06    0.10000E+01    0.39689E+04    0.22214E-41    0.19718E-48    0.11454E-47
+    2    2    0.13240E-06    0.10000E+01    0.32008E+04    0.82558E-39    0.15927E-45    0.35133E-45
+    2    2    0.13240E-06    0.10000E+01    0.25813E+04    0.54631E-30    0.23215E-36    0.21841E-36
+    2    2    0.13240E-06    0.10000E+01    0.20817E+04    0.90287E-14    0.14932E-19    0.33824E-20
+    2    2    0.13240E-06    0.10000E+01    0.16788E+04    0.27094E-08    0.18705E-13    0.91991E-15
+    2    2    0.13240E-06    0.10000E+01    0.13538E+04    0.51620E-08    0.68478E-13    0.14937E-14
+    2    2    0.13240E-06    0.10000E+01    0.10918E+04    0.99478E-08    0.24828E-12    0.24916E-14
+    2    2    0.13240E-06    0.10000E+01    0.88049E+03    0.19192E-07    0.89519E-12    0.42263E-14
+    2    2    0.13240E-06    0.10000E+01    0.71007E+03    0.36889E-07    0.32109E-11    0.72517E-14
+    2    2    0.13240E-06    0.10000E+01    0.57264E+03    0.70516E-07    0.11306E-10    0.12562E-13
+    2    2    0.13240E-06    0.10000E+01    0.46180E+03    0.13378E-06    0.37778E-10    0.21931E-13
+    2    2    0.13240E-06    0.10000E+01    0.37242E+03    0.25023E-06    0.11474E-09    0.38355E-13
+    2    2    0.13240E-06    0.10000E+01    0.30034E+03    0.45555E-06    0.30702E-09    0.66334E-13
+    2    2    0.13240E-06    0.10000E+01    0.24221E+03    0.79464E-06    0.71584E-09    0.11149E-12
+    2    2    0.13240E-06    0.10000E+01    0.19533E+03    0.12447E-05    0.13592E-08    0.17056E-12
+    2    2    0.13240E-06    0.10000E+01    0.15752E+03    0.12447E-05    0.13592E-08    0.17056E-12
+    2    2    0.23103E-06    0.10000E+01    0.80645E+05    0.53408E-53    0.39943E-64    0.68217E-59
+    2    2    0.23103E-06    0.10000E+01    0.65036E+05    0.45168E-52    0.63413E-63    0.57722E-58
+    2    2    0.23103E-06    0.10000E+01    0.52449E+05    0.38368E-51    0.85049E-62    0.49054E-57
+    2    2    0.23103E-06    0.10000E+01    0.42297E+05    0.28823E-50    0.11511E-60    0.36881E-56
+    2    2    0.23103E-06    0.10000E+01    0.34111E+05    0.20724E-49    0.15701E-59    0.26556E-55
+    2    2    0.23103E-06    0.10000E+01    0.27509E+05    0.14800E-48    0.21055E-58    0.19011E-54
+    2    2    0.23103E-06    0.10000E+01    0.22184E+05    0.10450E-47    0.27532E-57    0.13475E-53
+    2    2    0.23103E-06    0.10000E+01    0.17891E+05    0.72283E-47    0.35000E-56    0.93777E-53
+    2    2    0.23103E-06    0.10000E+01    0.14428E+05    0.48736E-46    0.43301E-55    0.63804E-52
+    2    2    0.23103E-06    0.10000E+01    0.11635E+05    0.31989E-45    0.51853E-54    0.42403E-51
+    2    2    0.23103E-06    0.10000E+01    0.93834E+04    0.20353E-44    0.59005E-53    0.27415E-50
+    2    2    0.23103E-06    0.10000E+01    0.75673E+04    0.12405E-43    0.63306E-52    0.17001E-49
+    2    2    0.23103E-06    0.10000E+01    0.61026E+04    0.72169E-43    0.71546E-51    0.99015E-49
+    2    2    0.23103E-06    0.10000E+01    0.49215E+04    0.43183E-42    0.11516E-49    0.54911E-48
+    2    2    0.23103E-06    0.10000E+01    0.39689E+04    0.33155E-41    0.26647E-48    0.34115E-47
+    2    2    0.23103E-06    0.10000E+01    0.32008E+04    0.11388E-38    0.21308E-45    0.97284E-45
+    2    2    0.23103E-06    0.10000E+01    0.25813E+04    0.73537E-30    0.30190E-36    0.59279E-36
+    2    2    0.23103E-06    0.10000E+01    0.20817E+04    0.11849E-13    0.17567E-19    0.92063E-20
+    2    2    0.23103E-06    0.10000E+01    0.16788E+04    0.34316E-08    0.20147E-13    0.24750E-14
+    2    2    0.23103E-06    0.10000E+01    0.13538E+04    0.62041E-08    0.72083E-13    0.38630E-14
+    2    2    0.23103E-06    0.10000E+01    0.10918E+04    0.11457E-07    0.25666E-12    0.61822E-14
+    2    2    0.23103E-06    0.10000E+01    0.88049E+03    0.21353E-07    0.91273E-12    0.10046E-13
+    2    2    0.23103E-06    0.10000E+01    0.71007E+03    0.39915E-07    0.32409E-11    0.16500E-13
+    2    2    0.23103E-06    0.10000E+01    0.57264E+03    0.74617E-07    0.11333E-10    0.27360E-13
+    2    2    0.23103E-06    0.10000E+01    0.46180E+03    0.13910E-06    0.37697E-10    0.45806E-13
+    2    2    0.23103E-06    0.10000E+01    0.37242E+03    0.25673E-06    0.11418E-09    0.77140E-13
+    2    2    0.23103E-06    0.10000E+01    0.30034E+03    0.46286E-06    0.30503E-09    0.12925E-12
+    2    2    0.23103E-06    0.10000E+01    0.24221E+03    0.80191E-06    0.71053E-09    0.21195E-12
+    2    2    0.23103E-06    0.10000E+01    0.19533E+03    0.12508E-05    0.13484E-08    0.31897E-12
+    2    2    0.23103E-06    0.10000E+01    0.15752E+03    0.12508E-05    0.13484E-08    0.31897E-12
+    2    2    0.40314E-06    0.10000E+01    0.80645E+05    0.93454E-53    0.69895E-64    0.12691E-58
+    2    2    0.40314E-06    0.10000E+01    0.65036E+05    0.79038E-52    0.11097E-62    0.10739E-57
+    2    2    0.40314E-06    0.10000E+01    0.52449E+05    0.67141E-51    0.14884E-61    0.91266E-57
+    2    2    0.40314E-06    0.10000E+01    0.42297E+05    0.50441E-50    0.20147E-60    0.68619E-56
+    2    2    0.40314E-06    0.10000E+01    0.34111E+05    0.36270E-49    0.27486E-59    0.49412E-55
+    2    2    0.40314E-06    0.10000E+01    0.27509E+05    0.25907E-48    0.36870E-58    0.35376E-54
+    2    2    0.40314E-06    0.10000E+01    0.22184E+05    0.18298E-47    0.48235E-57    0.25080E-53
+    2    2    0.40314E-06    0.10000E+01    0.17891E+05    0.12662E-46    0.61364E-56    0.17458E-52
+    2    2    0.40314E-06    0.10000E+01    0.14428E+05    0.85424E-46    0.75990E-55    0.11882E-51
+    2    2    0.40314E-06    0.10000E+01    0.11635E+05    0.56117E-45    0.91109E-54    0.79007E-51
+    2    2    0.40314E-06    0.10000E+01    0.93834E+04    0.35743E-44    0.10380E-52    0.51119E-50
+    2    2    0.40314E-06    0.10000E+01    0.75673E+04    0.21808E-43    0.11126E-51    0.31734E-49
+    2    2    0.40314E-06    0.10000E+01    0.61026E+04    0.12680E-42    0.12455E-50    0.18503E-48
+    2    2    0.40314E-06    0.10000E+01    0.49215E+04    0.75376E-42    0.19709E-49    0.10258E-47
+    2    2    0.40314E-06    0.10000E+01    0.39689E+04    0.57048E-41    0.45266E-48    0.63374E-47
+    2    2    0.40314E-06    0.10000E+01    0.32008E+04    0.19400E-38    0.36154E-45    0.17932E-44
+    2    2    0.40314E-06    0.10000E+01    0.25813E+04    0.12490E-29    0.51074E-36    0.10902E-35
+    2    2    0.40314E-06    0.10000E+01    0.20817E+04    0.20075E-13    0.29358E-19    0.16942E-19
+    2    2    0.40314E-06    0.10000E+01    0.16788E+04    0.57905E-08    0.33260E-13    0.45508E-14
+    2    2    0.40314E-06    0.10000E+01    0.13538E+04    0.10399E-07    0.11860E-12    0.70752E-14
+    2    2    0.40314E-06    0.10000E+01    0.10918E+04    0.19094E-07    0.42114E-12    0.11276E-13
+    2    2    0.40314E-06    0.10000E+01    0.88049E+03    0.35417E-07    0.14944E-11    0.18241E-13
+    2    2    0.40314E-06    0.10000E+01    0.71007E+03    0.65941E-07    0.52982E-11    0.29813E-13
+    2    2    0.40314E-06    0.10000E+01    0.57264E+03    0.12287E-06    0.18506E-10    0.49188E-13
+    2    2    0.40314E-06    0.10000E+01    0.46180E+03    0.22844E-06    0.61514E-10    0.81934E-13
+    2    2    0.40314E-06    0.10000E+01    0.37242E+03    0.42076E-06    0.18624E-09    0.13732E-12
+    2    2    0.40314E-06    0.10000E+01    0.30034E+03    0.75745E-06    0.49741E-09    0.22914E-12
+    2    2    0.40314E-06    0.10000E+01    0.24221E+03    0.13109E-05    0.11585E-08    0.37448E-12
+    2    2    0.40314E-06    0.10000E+01    0.19533E+03    0.20434E-05    0.21983E-08    0.56230E-12
+    2    2    0.40314E-06    0.10000E+01    0.15752E+03    0.20434E-05    0.21983E-08    0.56230E-12
+    2    2    0.70346E-06    0.10000E+01    0.80645E+05    0.16307E-52    0.12196E-63    0.22146E-58
+    2    2    0.70346E-06    0.10000E+01    0.65036E+05    0.13792E-51    0.19363E-62    0.18739E-57
+    2    2    0.70346E-06    0.10000E+01    0.52449E+05    0.11716E-50    0.25972E-61    0.15925E-56
+    2    2    0.70346E-06    0.10000E+01    0.42297E+05    0.88016E-50    0.35155E-60    0.11974E-55
+    2    2    0.70346E-06    0.10000E+01    0.34111E+05    0.63289E-49    0.47961E-59    0.86221E-55
+    2    2    0.70346E-06    0.10000E+01    0.27509E+05    0.45207E-48    0.64337E-58    0.61729E-54
+    2    2    0.70346E-06    0.10000E+01    0.22184E+05    0.31929E-47    0.84167E-57    0.43762E-53
+    2    2    0.70346E-06    0.10000E+01    0.17891E+05    0.22094E-46    0.10708E-55    0.30462E-52
+    2    2    0.70346E-06    0.10000E+01    0.14428E+05    0.14906E-45    0.13260E-54    0.20734E-51
+    2    2    0.70346E-06    0.10000E+01    0.11635E+05    0.97921E-45    0.15898E-53    0.13786E-50
+    2    2    0.70346E-06    0.10000E+01    0.93834E+04    0.62370E-44    0.18112E-52    0.89199E-50
+    2    2    0.70346E-06    0.10000E+01    0.75673E+04    0.38053E-43    0.19414E-51    0.55374E-49
+    2    2    0.70346E-06    0.10000E+01    0.61026E+04    0.22126E-42    0.21733E-50    0.32287E-48
+    2    2    0.70346E-06    0.10000E+01    0.49215E+04    0.13153E-41    0.34391E-49    0.17899E-47
+    2    2    0.70346E-06    0.10000E+01    0.39689E+04    0.99545E-41    0.78987E-48    0.11058E-46
+    2    2    0.70346E-06    0.10000E+01    0.32008E+04    0.33851E-38    0.63087E-45    0.31290E-44
+    2    2    0.70346E-06    0.10000E+01    0.25813E+04    0.21794E-29    0.89121E-36    0.19023E-35
+    2    2    0.70346E-06    0.10000E+01    0.20817E+04    0.35030E-13    0.51227E-19    0.29563E-19
+    2    2    0.70346E-06    0.10000E+01    0.16788E+04    0.10104E-07    0.58037E-13    0.79409E-14
+    2    2    0.70346E-06    0.10000E+01    0.13538E+04    0.18146E-07    0.20695E-12    0.12346E-13
+    2    2    0.70346E-06    0.10000E+01    0.10918E+04    0.33318E-07    0.73486E-12    0.19675E-13
+    2    2    0.70346E-06    0.10000E+01    0.88049E+03    0.61800E-07    0.26077E-11    0.31829E-13
+    2    2    0.70346E-06    0.10000E+01    0.71007E+03    0.11506E-06    0.92450E-11    0.52021E-13
+    2    2    0.70346E-06    0.10000E+01    0.57264E+03    0.21440E-06    0.32292E-10    0.85830E-13
+    2    2    0.70346E-06    0.10000E+01    0.46180E+03    0.39862E-06    0.10734E-09    0.14297E-12
+    2    2    0.70346E-06    0.10000E+01    0.37242E+03    0.73420E-06    0.32497E-09    0.23962E-12
+    2    2    0.70346E-06    0.10000E+01    0.30034E+03    0.13217E-05    0.86795E-09    0.39984E-12
+    2    2    0.70346E-06    0.10000E+01    0.24221E+03    0.22874E-05    0.20215E-08    0.65345E-12
+    2    2    0.70346E-06    0.10000E+01    0.19533E+03    0.35657E-05    0.38359E-08    0.98117E-12
+    2    2    0.70346E-06    0.10000E+01    0.15752E+03    0.35657E-05    0.38359E-08    0.98117E-12
+    2    2    0.12275E-05    0.10000E+01    0.80645E+05    0.28455E-52    0.21282E-63    0.38643E-58
+    2    2    0.12275E-05    0.10000E+01    0.65036E+05    0.24066E-51    0.33788E-62    0.32698E-57
+    2    2    0.12275E-05    0.10000E+01    0.52449E+05    0.20443E-50    0.45319E-61    0.27789E-56
+    2    2    0.12275E-05    0.10000E+01    0.42297E+05    0.15358E-49    0.61343E-60    0.20893E-55
+    2    2    0.12275E-05    0.10000E+01    0.34111E+05    0.11044E-48    0.83689E-59    0.15045E-54
+    2    2    0.12275E-05    0.10000E+01    0.27509E+05    0.78883E-48    0.11226E-57    0.10771E-53
+    2    2    0.12275E-05    0.10000E+01    0.22184E+05    0.55715E-47    0.14687E-56    0.76363E-53
+    2    2    0.12275E-05    0.10000E+01    0.17891E+05    0.38552E-46    0.18684E-55    0.53155E-52
+    2    2    0.12275E-05    0.10000E+01    0.14428E+05    0.26010E-45    0.23138E-54    0.36179E-51
+    2    2    0.12275E-05    0.10000E+01    0.11635E+05    0.17087E-44    0.27741E-53    0.24056E-50
+    2    2    0.12275E-05    0.10000E+01    0.93834E+04    0.10883E-43    0.31604E-52    0.15565E-49
+    2    2    0.12275E-05    0.10000E+01    0.75673E+04    0.66400E-43    0.33876E-51    0.96625E-49
+    2    2    0.12275E-05    0.10000E+01    0.61026E+04    0.38609E-42    0.37922E-50    0.56340E-48
+    2    2    0.12275E-05    0.10000E+01    0.49215E+04    0.22951E-41    0.60011E-49    0.31233E-47
+    2    2    0.12275E-05    0.10000E+01    0.39689E+04    0.17370E-40    0.13783E-47    0.19296E-46
+    2    2    0.12275E-05    0.10000E+01    0.32008E+04    0.59069E-38    0.11008E-44    0.54600E-44
+    2    2    0.12275E-05    0.10000E+01    0.25813E+04    0.38029E-29    0.15551E-35    0.33194E-35
+    2    2    0.12275E-05    0.10000E+01    0.20817E+04    0.61126E-13    0.89388E-19    0.51586E-19
+    2    2    0.12275E-05    0.10000E+01    0.16788E+04    0.17631E-07    0.10127E-12    0.13856E-13
+    2    2    0.12275E-05    0.10000E+01    0.13538E+04    0.31663E-07    0.36111E-12    0.21543E-13
+    2    2    0.12275E-05    0.10000E+01    0.10918E+04    0.58138E-07    0.12823E-11    0.34332E-13
+    2    2    0.12275E-05    0.10000E+01    0.88049E+03    0.10784E-06    0.45503E-11    0.55539E-13
+    2    2    0.12275E-05    0.10000E+01    0.71007E+03    0.20078E-06    0.16132E-10    0.90774E-13
+    2    2    0.12275E-05    0.10000E+01    0.57264E+03    0.37411E-06    0.56348E-10    0.14977E-12
+    2    2    0.12275E-05    0.10000E+01    0.46180E+03    0.69556E-06    0.18730E-09    0.24947E-12
+    2    2    0.12275E-05    0.10000E+01    0.37242E+03    0.12811E-05    0.56705E-09    0.41812E-12
+    2    2    0.12275E-05    0.10000E+01    0.30034E+03    0.23063E-05    0.15145E-08    0.69769E-12
+    2    2    0.12275E-05    0.10000E+01    0.24221E+03    0.39914E-05    0.35273E-08    0.11402E-11
+    2    2    0.12275E-05    0.10000E+01    0.19533E+03    0.62219E-05    0.66934E-08    0.17121E-11
+    2    2    0.12275E-05    0.10000E+01    0.15752E+03    0.62219E-05    0.66934E-08    0.17121E-11
+    2    2    0.21419E-05    0.10000E+01    0.80645E+05    0.49652E-52    0.37135E-63    0.67429E-58
+    2    2    0.21419E-05    0.10000E+01    0.65036E+05    0.41993E-51    0.58958E-62    0.57056E-57
+    2    2    0.21419E-05    0.10000E+01    0.52449E+05    0.35672E-50    0.79079E-61    0.48490E-56
+    2    2    0.21419E-05    0.10000E+01    0.42297E+05    0.26799E-49    0.10704E-59    0.36458E-55
+    2    2    0.21419E-05    0.10000E+01    0.34111E+05    0.19270E-48    0.14603E-58    0.26253E-54
+    2    2    0.21419E-05    0.10000E+01    0.27509E+05    0.13765E-47    0.19589E-57    0.18795E-53
+    2    2    0.21419E-05    0.10000E+01    0.22184E+05    0.97218E-47    0.25627E-56    0.13325E-52
+    2    2    0.21419E-05    0.10000E+01    0.17891E+05    0.67272E-46    0.32603E-55    0.92752E-52
+    2    2    0.21419E-05    0.10000E+01    0.14428E+05    0.45386E-45    0.40374E-54    0.63130E-51
+    2    2    0.21419E-05    0.10000E+01    0.11635E+05    0.29815E-44    0.48406E-53    0.41977E-50
+    2    2    0.21419E-05    0.10000E+01    0.93834E+04    0.18991E-43    0.55148E-52    0.27159E-49
+    2    2    0.21419E-05    0.10000E+01    0.75673E+04    0.11586E-42    0.59112E-51    0.16860E-48
+    2    2    0.21419E-05    0.10000E+01    0.61026E+04    0.67370E-42    0.66172E-50    0.98309E-48
+    2    2    0.21419E-05    0.10000E+01    0.49215E+04    0.40047E-41    0.10472E-48    0.54499E-47
+    2    2    0.21419E-05    0.10000E+01    0.39689E+04    0.30310E-40    0.24050E-47    0.33671E-46
+    2    2    0.21419E-05    0.10000E+01    0.32008E+04    0.10307E-37    0.19209E-44    0.95273E-44
+    2    2    0.21419E-05    0.10000E+01    0.25813E+04    0.66358E-29    0.27136E-35    0.57922E-35
+    2    2    0.21419E-05    0.10000E+01    0.20817E+04    0.10666E-12    0.15598E-18    0.90015E-19
+    2    2    0.21419E-05    0.10000E+01    0.16788E+04    0.30765E-07    0.17671E-12    0.24179E-13
+    2    2    0.21419E-05    0.10000E+01    0.13538E+04    0.55251E-07    0.63012E-12    0.37591E-13
+    2    2    0.21419E-05    0.10000E+01    0.10918E+04    0.10145E-06    0.22375E-11    0.59907E-13
+    2    2    0.21419E-05    0.10000E+01    0.88049E+03    0.18817E-06    0.79400E-11    0.96913E-13
+    2    2    0.21419E-05    0.10000E+01    0.71007E+03    0.35034E-06    0.28149E-10    0.15840E-12
+    2    2    0.21419E-05    0.10000E+01    0.57264E+03    0.65280E-06    0.98323E-10    0.26134E-12
+    2    2    0.21419E-05    0.10000E+01    0.46180E+03    0.12137E-05    0.32682E-09    0.43532E-12
+    2    2    0.21419E-05    0.10000E+01    0.37242E+03    0.22355E-05    0.98947E-09    0.72960E-12
+    2    2    0.21419E-05    0.10000E+01    0.30034E+03    0.40243E-05    0.26428E-08    0.12174E-11
+    2    2    0.21419E-05    0.10000E+01    0.24221E+03    0.69648E-05    0.61550E-08    0.19896E-11
+    2    2    0.21419E-05    0.10000E+01    0.19533E+03    0.10857E-04    0.11680E-07    0.29875E-11
+    2    2    0.21419E-05    0.10000E+01    0.15752E+03    0.10857E-04    0.11680E-07    0.29875E-11
+    2    2    0.37375E-05    0.10000E+01    0.80645E+05    0.86640E-52    0.64799E-63    0.11766E-57
+    2    2    0.37375E-05    0.10000E+01    0.65036E+05    0.73275E-51    0.10288E-61    0.99560E-57
+    2    2    0.37375E-05    0.10000E+01    0.52449E+05    0.62246E-50    0.13799E-60    0.84612E-56
+    2    2    0.37375E-05    0.10000E+01    0.42297E+05    0.46763E-49    0.18678E-59    0.63616E-55
+    2    2    0.37375E-05    0.10000E+01    0.34111E+05    0.33626E-48    0.25482E-58    0.45810E-54
+    2    2    0.37375E-05    0.10000E+01    0.27509E+05    0.24018E-47    0.34182E-57    0.32797E-53
+    2    2    0.37375E-05    0.10000E+01    0.22184E+05    0.16964E-46    0.44718E-56    0.23251E-52
+    2    2    0.37375E-05    0.10000E+01    0.17891E+05    0.11739E-45    0.56890E-55    0.16185E-51
+    2    2    0.37375E-05    0.10000E+01    0.14428E+05    0.79196E-45    0.70450E-54    0.11016E-50
+    2    2    0.37375E-05    0.10000E+01    0.11635E+05    0.52026E-44    0.84466E-53    0.73247E-50
+    2    2    0.37375E-05    0.10000E+01    0.93834E+04    0.33137E-43    0.96230E-52    0.47392E-49
+    2    2    0.37375E-05    0.10000E+01    0.75673E+04    0.20218E-42    0.10315E-50    0.29420E-48
+    2    2    0.37375E-05    0.10000E+01    0.61026E+04    0.11756E-41    0.11547E-49    0.17154E-47
+    2    2    0.37375E-05    0.10000E+01    0.49215E+04    0.69880E-41    0.18272E-48    0.95098E-47
+    2    2    0.37375E-05    0.10000E+01    0.39689E+04    0.52888E-40    0.41966E-47    0.58753E-46
+    2    2    0.37375E-05    0.10000E+01    0.32008E+04    0.17985E-37    0.33518E-44    0.16625E-43
+    2    2    0.37375E-05    0.10000E+01    0.25813E+04    0.11579E-28    0.47350E-35    0.10107E-34
+    2    2    0.37375E-05    0.10000E+01    0.20817E+04    0.18612E-12    0.27217E-18    0.15707E-18
+    2    2    0.37375E-05    0.10000E+01    0.16788E+04    0.53683E-07    0.30835E-12    0.42190E-13
+    2    2    0.37375E-05    0.10000E+01    0.13538E+04    0.96409E-07    0.10995E-11    0.65594E-13
+    2    2    0.37375E-05    0.10000E+01    0.10918E+04    0.17702E-06    0.39043E-11    0.10453E-12
+    2    2    0.37375E-05    0.10000E+01    0.88049E+03    0.32834E-06    0.13855E-10    0.16911E-12
+    2    2    0.37375E-05    0.10000E+01    0.71007E+03    0.61133E-06    0.49119E-10    0.27639E-12
+    2    2    0.37375E-05    0.10000E+01    0.57264E+03    0.11391E-05    0.17157E-09    0.45601E-12
+    2    2    0.37375E-05    0.10000E+01    0.46180E+03    0.21178E-05    0.57029E-09    0.75960E-12
+    2    2    0.37375E-05    0.10000E+01    0.37242E+03    0.39008E-05    0.17266E-08    0.12731E-11
+    2    2    0.37375E-05    0.10000E+01    0.30034E+03    0.70222E-05    0.46114E-08    0.21243E-11
+    2    2    0.37375E-05    0.10000E+01    0.24221E+03    0.12153E-04    0.10740E-07    0.34718E-11
+    2    2    0.37375E-05    0.10000E+01    0.19533E+03    0.18944E-04    0.20380E-07    0.52130E-11
+    2    2    0.37375E-05    0.10000E+01    0.15752E+03    0.18944E-04    0.20380E-07    0.52130E-11
+    2    2    0.65217E-05    0.10000E+01    0.80645E+05    0.15118E-51    0.11307E-62    0.20531E-57
+    2    2    0.65217E-05    0.10000E+01    0.65036E+05    0.12786E-50    0.17952E-61    0.17373E-56
+    2    2    0.65217E-05    0.10000E+01    0.52449E+05    0.10862E-49    0.24078E-60    0.14764E-55
+    2    2    0.65217E-05    0.10000E+01    0.42297E+05    0.81599E-49    0.32592E-59    0.11101E-54
+    2    2    0.65217E-05    0.10000E+01    0.34111E+05    0.58675E-48    0.44464E-58    0.79935E-54
+    2    2    0.65217E-05    0.10000E+01    0.27509E+05    0.41911E-47    0.59646E-57    0.57229E-53
+    2    2    0.65217E-05    0.10000E+01    0.22184E+05    0.29601E-46    0.78031E-56    0.40572E-52
+    2    2    0.65217E-05    0.10000E+01    0.17891E+05    0.20483E-45    0.99269E-55    0.28241E-51
+    2    2    0.65217E-05    0.10000E+01    0.14428E+05    0.13819E-44    0.12293E-53    0.19222E-50
+    2    2    0.65217E-05    0.10000E+01    0.11635E+05    0.90782E-44    0.14739E-52    0.12781E-49
+    2    2    0.65217E-05    0.10000E+01    0.93834E+04    0.57823E-43    0.16792E-51    0.82696E-49
+    2    2    0.65217E-05    0.10000E+01    0.75673E+04    0.35278E-42    0.17998E-50    0.51337E-48
+    2    2    0.65217E-05    0.10000E+01    0.61026E+04    0.20513E-41    0.20148E-49    0.29933E-47
+    2    2    0.65217E-05    0.10000E+01    0.49215E+04    0.12194E-40    0.31884E-48    0.16594E-46
+    2    2    0.65217E-05    0.10000E+01    0.39689E+04    0.92287E-40    0.73228E-47    0.10252E-45
+    2    2    0.65217E-05    0.10000E+01    0.32008E+04    0.31383E-37    0.58488E-44    0.29009E-43
+    2    2    0.65217E-05    0.10000E+01    0.25813E+04    0.20205E-28    0.82623E-35    0.17636E-34
+    2    2    0.65217E-05    0.10000E+01    0.20817E+04    0.32476E-12    0.47492E-18    0.27408E-18
+    2    2    0.65217E-05    0.10000E+01    0.16788E+04    0.93674E-07    0.53805E-12    0.73620E-13
+    2    2    0.65217E-05    0.10000E+01    0.13538E+04    0.16823E-06    0.19186E-11    0.11446E-12
+    2    2    0.65217E-05    0.10000E+01    0.10918E+04    0.30889E-06    0.68128E-11    0.18241E-12
+    2    2    0.65217E-05    0.10000E+01    0.88049E+03    0.57294E-06    0.24176E-10    0.29508E-12
+    2    2    0.65217E-05    0.10000E+01    0.71007E+03    0.10667E-05    0.85710E-10    0.48228E-12
+    2    2    0.65217E-05    0.10000E+01    0.57264E+03    0.19876E-05    0.29938E-09    0.79572E-12
+    2    2    0.65217E-05    0.10000E+01    0.46180E+03    0.36955E-05    0.99512E-09    0.13255E-11
+    2    2    0.65217E-05    0.10000E+01    0.37242E+03    0.68067E-05    0.30128E-08    0.22215E-11
+    2    2    0.65217E-05    0.10000E+01    0.30034E+03    0.12253E-04    0.80467E-08    0.37068E-11
+    2    2    0.65217E-05    0.10000E+01    0.24221E+03    0.21207E-04    0.18741E-07    0.60580E-11
+    2    2    0.65217E-05    0.10000E+01    0.19533E+03    0.33057E-04    0.35562E-07    0.90964E-11
+    2    2    0.65217E-05    0.10000E+01    0.15752E+03    0.33057E-04    0.35562E-07    0.90964E-11
+    2    2    0.11380E-04    0.10000E+01    0.80645E+05    0.26380E-51    0.19730E-62    0.35825E-57
+    2    2    0.11380E-04    0.10000E+01    0.65036E+05    0.22311E-50    0.31324E-61    0.30314E-56
+    2    2    0.11380E-04    0.10000E+01    0.52449E+05    0.18953E-49    0.42015E-60    0.25763E-55
+    2    2    0.11380E-04    0.10000E+01    0.42297E+05    0.14238E-48    0.56870E-59    0.19370E-54
+    2    2    0.11380E-04    0.10000E+01    0.34111E+05    0.10238E-47    0.77587E-58    0.13948E-53
+    2    2    0.11380E-04    0.10000E+01    0.27509E+05    0.73132E-47    0.10408E-56    0.99860E-53
+    2    2    0.11380E-04    0.10000E+01    0.22184E+05    0.51652E-46    0.13616E-55    0.70795E-52
+    2    2    0.11380E-04    0.10000E+01    0.17891E+05    0.35742E-45    0.17322E-54    0.49280E-51
+    2    2    0.11380E-04    0.10000E+01    0.14428E+05    0.24114E-44    0.21451E-53    0.33541E-50
+    2    2    0.11380E-04    0.10000E+01    0.11635E+05    0.15841E-43    0.25718E-52    0.22302E-49
+    2    2    0.11380E-04    0.10000E+01    0.93834E+04    0.10090E-42    0.29300E-51    0.14430E-48
+    2    2    0.11380E-04    0.10000E+01    0.75673E+04    0.61559E-42    0.31406E-50    0.89580E-48
+    2    2    0.11380E-04    0.10000E+01    0.61026E+04    0.35794E-41    0.35157E-49    0.52232E-47
+    2    2    0.11380E-04    0.10000E+01    0.49215E+04    0.21277E-40    0.55635E-48    0.28956E-46
+    2    2    0.11380E-04    0.10000E+01    0.39689E+04    0.16104E-39    0.12778E-46    0.17889E-45
+    2    2    0.11380E-04    0.10000E+01    0.32008E+04    0.54762E-37    0.10206E-43    0.50619E-43
+    2    2    0.11380E-04    0.10000E+01    0.25813E+04    0.35256E-28    0.14417E-34    0.30774E-34
+    2    2    0.11380E-04    0.10000E+01    0.20817E+04    0.56669E-12    0.82871E-18    0.47825E-18
+    2    2    0.11380E-04    0.10000E+01    0.16788E+04    0.16345E-06    0.93887E-12    0.12846E-12
+    2    2    0.11380E-04    0.10000E+01    0.13538E+04    0.29355E-06    0.33478E-11    0.19972E-12
+    2    2    0.11380E-04    0.10000E+01    0.10918E+04    0.53899E-06    0.11888E-10    0.31829E-12
+    2    2    0.11380E-04    0.10000E+01    0.88049E+03    0.99975E-06    0.42185E-10    0.51490E-12
+    2    2    0.11380E-04    0.10000E+01    0.71007E+03    0.18614E-05    0.14956E-09    0.84156E-12
+    2    2    0.11380E-04    0.10000E+01    0.57264E+03    0.34683E-05    0.52239E-09    0.13885E-11
+    2    2    0.11380E-04    0.10000E+01    0.46180E+03    0.64485E-05    0.17364E-08    0.23128E-11
+    2    2    0.11380E-04    0.10000E+01    0.37242E+03    0.11877E-04    0.52571E-08    0.38764E-11
+    2    2    0.11380E-04    0.10000E+01    0.30034E+03    0.21381E-04    0.14041E-07    0.64682E-11
+    2    2    0.11380E-04    0.10000E+01    0.24221E+03    0.37004E-04    0.32701E-07    0.10571E-10
+    2    2    0.11380E-04    0.10000E+01    0.19533E+03    0.57682E-04    0.62054E-07    0.15873E-10
+    2    2    0.11380E-04    0.10000E+01    0.15752E+03    0.57682E-04    0.62054E-07    0.15873E-10
+    2    2    0.19857E-04    0.10000E+01    0.80645E+05    0.46032E-51    0.34428E-62    0.62513E-57
+    2    2    0.19857E-04    0.10000E+01    0.65036E+05    0.38931E-50    0.54659E-61    0.52896E-56
+    2    2    0.19857E-04    0.10000E+01    0.52449E+05    0.33071E-49    0.73313E-60    0.44954E-55
+    2    2    0.19857E-04    0.10000E+01    0.42297E+05    0.24845E-48    0.99235E-59    0.33799E-54
+    2    2    0.19857E-04    0.10000E+01    0.34111E+05    0.17865E-47    0.13538E-57    0.24339E-53
+    2    2    0.19857E-04    0.10000E+01    0.27509E+05    0.12761E-46    0.18161E-56    0.17425E-52
+    2    2    0.19857E-04    0.10000E+01    0.22184E+05    0.90130E-46    0.23759E-55    0.12353E-51
+    2    2    0.19857E-04    0.10000E+01    0.17891E+05    0.62367E-45    0.30226E-54    0.85990E-51
+    2    2    0.19857E-04    0.10000E+01    0.14428E+05    0.42077E-44    0.37430E-53    0.58527E-50
+    2    2    0.19857E-04    0.10000E+01    0.11635E+05    0.27641E-43    0.44877E-52    0.38916E-49
+    2    2    0.19857E-04    0.10000E+01    0.93834E+04    0.17606E-42    0.51127E-51    0.25179E-48
+    2    2    0.19857E-04    0.10000E+01    0.75673E+04    0.10742E-41    0.54802E-50    0.15631E-47
+    2    2    0.19857E-04    0.10000E+01    0.61026E+04    0.62458E-41    0.61348E-49    0.91141E-47
+    2    2    0.19857E-04    0.10000E+01    0.49215E+04    0.37128E-40    0.97080E-48    0.50526E-46
+    2    2    0.19857E-04    0.10000E+01    0.39689E+04    0.28100E-39    0.22297E-46    0.31216E-45
+    2    2    0.19857E-04    0.10000E+01    0.32008E+04    0.95556E-37    0.17808E-43    0.88327E-43
+    2    2    0.19857E-04    0.10000E+01    0.25813E+04    0.61520E-28    0.25157E-34    0.53699E-34
+    2    2    0.19857E-04    0.10000E+01    0.20817E+04    0.98884E-12    0.14460E-17    0.83452E-18
+    2    2    0.19857E-04    0.10000E+01    0.16788E+04    0.28522E-06    0.16383E-11    0.22416E-12
+    2    2    0.19857E-04    0.10000E+01    0.13538E+04    0.51222E-06    0.58418E-11    0.34850E-12
+    2    2    0.19857E-04    0.10000E+01    0.10918E+04    0.94050E-06    0.20744E-10    0.55539E-12
+    2    2    0.19857E-04    0.10000E+01    0.88049E+03    0.17445E-05    0.73611E-10    0.89847E-12
+    2    2    0.19857E-04    0.10000E+01    0.71007E+03    0.32480E-05    0.26097E-09    0.14685E-11
+    2    2    0.19857E-04    0.10000E+01    0.57264E+03    0.60520E-05    0.91155E-09    0.24228E-11
+    2    2    0.19857E-04    0.10000E+01    0.46180E+03    0.11252E-04    0.30300E-08    0.40358E-11
+    2    2    0.19857E-04    0.10000E+01    0.37242E+03    0.20725E-04    0.91733E-08    0.67640E-11
+    2    2    0.19857E-04    0.10000E+01    0.30034E+03    0.37309E-04    0.24501E-07    0.11287E-10
+    2    2    0.19857E-04    0.10000E+01    0.24221E+03    0.64570E-04    0.57062E-07    0.18446E-10
+    2    2    0.19857E-04    0.10000E+01    0.19533E+03    0.10065E-03    0.10828E-06    0.27697E-10
+    2    2    0.19857E-04    0.10000E+01    0.15752E+03    0.10065E-03    0.10828E-06    0.27697E-10
+    2    2    0.34650E-04    0.10000E+01    0.80645E+05    0.80323E-51    0.60074E-62    0.10908E-56
+    2    2    0.34650E-04    0.10000E+01    0.65036E+05    0.67933E-50    0.95377E-61    0.92301E-56
+    2    2    0.34650E-04    0.10000E+01    0.52449E+05    0.57708E-49    0.12793E-59    0.78443E-55
+    2    2    0.34650E-04    0.10000E+01    0.42297E+05    0.43353E-48    0.17316E-58    0.58978E-54
+    2    2    0.34650E-04    0.10000E+01    0.34111E+05    0.31174E-47    0.23624E-57    0.42469E-53
+    2    2    0.34650E-04    0.10000E+01    0.27509E+05    0.22267E-46    0.31690E-56    0.30406E-52
+    2    2    0.34650E-04    0.10000E+01    0.22184E+05    0.15727E-45    0.41458E-55    0.21556E-51
+    2    2    0.34650E-04    0.10000E+01    0.17891E+05    0.10883E-44    0.52742E-54    0.15005E-50
+    2    2    0.34650E-04    0.10000E+01    0.14428E+05    0.73421E-44    0.65313E-53    0.10213E-49
+    2    2    0.34650E-04    0.10000E+01    0.11635E+05    0.48232E-43    0.78308E-52    0.67906E-49
+    2    2    0.34650E-04    0.10000E+01    0.93834E+04    0.30721E-42    0.89214E-51    0.43936E-48
+    2    2    0.34650E-04    0.10000E+01    0.75673E+04    0.18744E-41    0.95626E-50    0.27275E-47
+    2    2    0.34650E-04    0.10000E+01    0.61026E+04    0.10898E-40    0.10705E-48    0.15904E-46
+    2    2    0.34650E-04    0.10000E+01    0.49215E+04    0.64785E-40    0.16940E-47    0.88164E-46
+    2    2    0.34650E-04    0.10000E+01    0.39689E+04    0.49032E-39    0.38906E-46    0.54469E-45
+    2    2    0.34650E-04    0.10000E+01    0.32008E+04    0.16674E-36    0.31075E-43    0.15413E-42
+    2    2    0.34650E-04    0.10000E+01    0.25813E+04    0.10735E-27    0.43898E-34    0.93702E-34
+    2    2    0.34650E-04    0.10000E+01    0.20817E+04    0.17255E-11    0.25233E-17    0.14562E-17
+    2    2    0.34650E-04    0.10000E+01    0.16788E+04    0.49769E-06    0.28587E-11    0.39114E-12
+    2    2    0.34650E-04    0.10000E+01    0.13538E+04    0.89380E-06    0.10194E-10    0.60811E-12
+    2    2    0.34650E-04    0.10000E+01    0.10918E+04    0.16411E-05    0.36196E-10    0.96913E-12
+    2    2    0.34650E-04    0.10000E+01    0.88049E+03    0.30440E-05    0.12845E-09    0.15678E-11
+    2    2    0.34650E-04    0.10000E+01    0.71007E+03    0.56676E-05    0.45538E-09    0.25624E-11
+    2    2    0.34650E-04    0.10000E+01    0.57264E+03    0.10560E-04    0.15906E-08    0.42277E-11
+    2    2    0.34650E-04    0.10000E+01    0.46180E+03    0.19634E-04    0.52871E-08    0.70422E-11
+    2    2    0.34650E-04    0.10000E+01    0.37242E+03    0.36164E-04    0.16007E-07    0.11803E-10
+    2    2    0.34650E-04    0.10000E+01    0.30034E+03    0.65102E-04    0.42752E-07    0.19694E-10
+    2    2    0.34650E-04    0.10000E+01    0.24221E+03    0.11267E-03    0.99570E-07    0.32186E-10
+    2    2    0.34650E-04    0.10000E+01    0.19533E+03    0.17563E-03    0.18894E-06    0.48329E-10
+    2    2    0.34650E-04    0.10000E+01    0.15752E+03    0.17563E-03    0.18894E-06    0.48329E-10
+    2    2    0.60462E-04    0.10000E+01    0.80645E+05    0.14016E-50    0.10483E-61    0.19034E-56
+    2    2    0.60462E-04    0.10000E+01    0.65036E+05    0.11854E-49    0.16643E-60    0.16106E-55
+    2    2    0.60462E-04    0.10000E+01    0.52449E+05    0.10070E-48    0.22322E-59    0.13688E-54
+    2    2    0.60462E-04    0.10000E+01    0.42297E+05    0.75649E-48    0.30215E-58    0.10291E-53
+    2    2    0.60462E-04    0.10000E+01    0.34111E+05    0.54397E-47    0.41222E-57    0.74107E-53
+    2    2    0.60462E-04    0.10000E+01    0.27509E+05    0.38855E-46    0.55297E-56    0.53056E-52
+    2    2    0.60462E-04    0.10000E+01    0.22184E+05    0.27443E-45    0.72341E-55    0.37614E-51
+    2    2    0.60462E-04    0.10000E+01    0.17891E+05    0.18990E-44    0.92031E-54    0.26182E-50
+    2    2    0.60462E-04    0.10000E+01    0.14428E+05    0.12812E-43    0.11397E-52    0.17821E-49
+    2    2    0.60462E-04    0.10000E+01    0.11635E+05    0.84163E-43    0.13664E-51    0.11849E-48
+    2    2    0.60462E-04    0.10000E+01    0.93834E+04    0.53607E-42    0.15567E-50    0.76666E-48
+    2    2    0.60462E-04    0.10000E+01    0.75673E+04    0.32706E-41    0.16686E-49    0.47594E-47
+    2    2    0.60462E-04    0.10000E+01    0.61026E+04    0.19017E-40    0.18679E-48    0.27751E-46
+    2    2    0.60462E-04    0.10000E+01    0.49215E+04    0.11305E-39    0.29559E-47    0.15384E-45
+    2    2    0.60462E-04    0.10000E+01    0.39689E+04    0.85558E-39    0.67889E-46    0.95046E-45
+    2    2    0.60462E-04    0.10000E+01    0.32008E+04    0.29095E-36    0.54223E-43    0.26894E-42
+    2    2    0.60462E-04    0.10000E+01    0.25813E+04    0.18732E-27    0.76599E-34    0.16350E-33
+    2    2    0.60462E-04    0.10000E+01    0.20817E+04    0.30108E-11    0.44029E-17    0.25409E-17
+    2    2    0.60462E-04    0.10000E+01    0.16788E+04    0.86844E-06    0.49882E-11    0.68252E-12
+    2    2    0.60462E-04    0.10000E+01    0.13538E+04    0.15596E-05    0.17787E-10    0.10611E-11
+    2    2    0.60462E-04    0.10000E+01    0.10918E+04    0.28636E-05    0.63160E-10    0.16911E-11
+    2    2    0.60462E-04    0.10000E+01    0.88049E+03    0.53117E-05    0.22413E-09    0.27357E-11
+    2    2    0.60462E-04    0.10000E+01    0.71007E+03    0.98896E-05    0.79461E-09    0.44712E-11
+    2    2    0.60462E-04    0.10000E+01    0.57264E+03    0.18427E-04    0.27755E-08    0.73770E-11
+    2    2    0.60462E-04    0.10000E+01    0.46180E+03    0.34261E-04    0.92256E-08    0.12288E-10
+    2    2    0.60462E-04    0.10000E+01    0.37242E+03    0.63104E-04    0.27931E-07    0.20595E-10
+    2    2    0.60462E-04    0.10000E+01    0.30034E+03    0.11360E-03    0.74600E-07    0.34366E-10
+    2    2    0.60462E-04    0.10000E+01    0.24221E+03    0.19660E-03    0.17374E-06    0.56163E-10
+    2    2    0.60462E-04    0.10000E+01    0.19533E+03    0.30647E-03    0.32969E-06    0.84331E-10
+    2    2    0.60462E-04    0.10000E+01    0.15752E+03    0.30647E-03    0.32969E-06    0.84331E-10
+    2    2    0.10550E-03    0.10000E+01    0.80645E+05    0.24457E-50    0.18292E-61    0.33213E-56
+    2    2    0.10550E-03    0.10000E+01    0.65036E+05    0.20684E-49    0.29041E-60    0.28104E-55
+    2    2    0.10550E-03    0.10000E+01    0.52449E+05    0.17571E-48    0.38951E-59    0.23884E-54
+    2    2    0.10550E-03    0.10000E+01    0.42297E+05    0.13200E-47    0.52724E-58    0.17958E-53
+    2    2    0.10550E-03    0.10000E+01    0.34111E+05    0.94919E-47    0.71930E-57    0.12931E-52
+    2    2    0.10550E-03    0.10000E+01    0.27509E+05    0.67800E-46    0.96490E-56    0.92580E-52
+    2    2    0.10550E-03    0.10000E+01    0.22184E+05    0.47886E-45    0.12623E-54    0.65633E-51
+    2    2    0.10550E-03    0.10000E+01    0.17891E+05    0.33136E-44    0.16059E-53    0.45687E-50
+    2    2    0.10550E-03    0.10000E+01    0.14428E+05    0.22355E-43    0.19887E-52    0.31096E-49
+    2    2    0.10550E-03    0.10000E+01    0.11635E+05    0.14686E-42    0.23843E-51    0.20676E-48
+    2    2    0.10550E-03    0.10000E+01    0.93834E+04    0.93540E-42    0.27164E-50    0.13378E-47
+    2    2    0.10550E-03    0.10000E+01    0.75673E+04    0.57071E-41    0.29116E-49    0.83048E-47
+    2    2    0.10550E-03    0.10000E+01    0.61026E+04    0.33184E-40    0.32594E-48    0.48423E-46
+    2    2    0.10550E-03    0.10000E+01    0.49215E+04    0.19726E-39    0.51579E-47    0.26844E-45
+    2    2    0.10550E-03    0.10000E+01    0.39689E+04    0.14929E-38    0.11846E-45    0.16585E-44
+    2    2    0.10550E-03    0.10000E+01    0.32008E+04    0.50769E-36    0.94616E-43    0.46928E-42
+    2    2    0.10550E-03    0.10000E+01    0.25813E+04    0.32686E-27    0.13366E-33    0.28530E-33
+    2    2    0.10550E-03    0.10000E+01    0.20817E+04    0.52537E-11    0.76829E-17    0.44338E-17
+    2    2    0.10550E-03    0.10000E+01    0.16788E+04    0.15154E-05    0.87042E-11    0.11910E-11
+    2    2    0.10550E-03    0.10000E+01    0.13538E+04    0.27215E-05    0.31037E-10    0.18516E-11
+    2    2    0.10550E-03    0.10000E+01    0.10918E+04    0.49969E-05    0.11021E-09    0.29508E-11
+    2    2    0.10550E-03    0.10000E+01    0.88049E+03    0.92686E-05    0.39110E-09    0.47736E-11
+    2    2    0.10550E-03    0.10000E+01    0.71007E+03    0.17257E-04    0.13865E-08    0.78020E-11
+    2    2    0.10550E-03    0.10000E+01    0.57264E+03    0.32154E-04    0.48431E-08    0.12872E-10
+    2    2    0.10550E-03    0.10000E+01    0.46180E+03    0.59783E-04    0.16098E-07    0.21442E-10
+    2    2    0.10550E-03    0.10000E+01    0.37242E+03    0.11011E-03    0.48738E-07    0.35937E-10
+    2    2    0.10550E-03    0.10000E+01    0.30034E+03    0.19822E-03    0.13017E-06    0.59966E-10
+    2    2    0.10550E-03    0.10000E+01    0.24221E+03    0.34306E-03    0.30317E-06    0.98002E-10
+    2    2    0.10550E-03    0.10000E+01    0.19533E+03    0.53476E-03    0.57530E-06    0.14715E-09
+    2    2    0.10550E-03    0.10000E+01    0.15752E+03    0.53476E-03    0.57530E-06    0.14715E-09
+    2    2    0.18409E-03    0.10000E+01    0.80645E+05    0.42676E-50    0.31918E-61    0.57955E-56
+    2    2    0.18409E-03    0.10000E+01    0.65036E+05    0.36093E-49    0.50674E-60    0.49040E-55
+    2    2    0.18409E-03    0.10000E+01    0.52449E+05    0.30660E-48    0.67968E-59    0.41677E-54
+    2    2    0.18409E-03    0.10000E+01    0.42297E+05    0.23034E-47    0.92000E-58    0.31335E-53
+    2    2    0.18409E-03    0.10000E+01    0.34111E+05    0.16563E-46    0.12551E-56    0.22564E-52
+    2    2    0.18409E-03    0.10000E+01    0.27509E+05    0.11831E-45    0.16837E-55    0.16155E-51
+    2    2    0.18409E-03    0.10000E+01    0.22184E+05    0.83559E-45    0.22027E-54    0.11453E-50
+    2    2    0.18409E-03    0.10000E+01    0.17891E+05    0.57820E-44    0.28022E-53    0.79720E-50
+    2    2    0.18409E-03    0.10000E+01    0.14428E+05    0.39009E-43    0.34701E-52    0.54260E-49
+    2    2    0.18409E-03    0.10000E+01    0.11635E+05    0.25626E-42    0.41605E-51    0.36079E-48
+    2    2    0.18409E-03    0.10000E+01    0.93834E+04    0.16322E-41    0.47399E-50    0.23343E-47
+    2    2    0.18409E-03    0.10000E+01    0.75673E+04    0.99585E-41    0.50806E-49    0.14491E-46
+    2    2    0.18409E-03    0.10000E+01    0.61026E+04    0.57904E-40    0.56875E-48    0.84496E-46
+    2    2    0.18409E-03    0.10000E+01    0.49215E+04    0.34421E-39    0.90002E-47    0.46842E-45
+    2    2    0.18409E-03    0.10000E+01    0.39689E+04    0.26051E-38    0.20671E-45    0.28940E-44
+    2    2    0.18409E-03    0.10000E+01    0.32008E+04    0.88589E-36    0.16510E-42    0.81887E-42
+    2    2    0.18409E-03    0.10000E+01    0.25813E+04    0.57035E-27    0.23323E-33    0.49784E-33
+    2    2    0.18409E-03    0.10000E+01    0.20817E+04    0.91675E-11    0.13406E-16    0.77367E-17
+    2    2    0.18409E-03    0.10000E+01    0.16788E+04    0.26442E-05    0.15188E-10    0.20781E-11
+    2    2    0.18409E-03    0.10000E+01    0.13538E+04    0.47488E-05    0.54158E-10    0.32309E-11
+    2    2    0.18409E-03    0.10000E+01    0.10918E+04    0.87193E-05    0.19231E-09    0.51490E-11
+    2    2    0.18409E-03    0.10000E+01    0.88049E+03    0.16173E-04    0.68244E-09    0.83296E-11
+    2    2    0.18409E-03    0.10000E+01    0.71007E+03    0.30112E-04    0.24194E-08    0.13614E-10
+    2    2    0.18409E-03    0.10000E+01    0.57264E+03    0.56107E-04    0.84508E-08    0.22462E-10
+    2    2    0.18409E-03    0.10000E+01    0.46180E+03    0.10432E-03    0.28090E-07    0.37415E-10
+    2    2    0.18409E-03    0.10000E+01    0.37242E+03    0.19214E-03    0.85045E-07    0.62709E-10
+    2    2    0.18409E-03    0.10000E+01    0.30034E+03    0.34589E-03    0.22714E-06    0.10464E-09
+    2    2    0.18409E-03    0.10000E+01    0.24221E+03    0.59862E-03    0.52902E-06    0.17101E-09
+    2    2    0.18409E-03    0.10000E+01    0.19533E+03    0.93313E-03    0.10039E-05    0.25677E-09
+    2    2    0.18409E-03    0.10000E+01    0.15752E+03    0.93313E-03    0.10039E-05    0.25677E-09
+    2    2    0.32123E-03    0.10000E+01    0.80645E+05    0.74467E-50    0.55694E-61    0.10113E-55
+    2    2    0.32123E-03    0.10000E+01    0.65036E+05    0.62980E-49    0.88423E-60    0.85571E-55
+    2    2    0.32123E-03    0.10000E+01    0.52449E+05    0.53500E-48    0.11860E-58    0.72723E-54
+    2    2    0.32123E-03    0.10000E+01    0.42297E+05    0.40192E-47    0.16053E-57    0.54678E-53
+    2    2    0.32123E-03    0.10000E+01    0.34111E+05    0.28901E-46    0.21901E-56    0.39373E-52
+    2    2    0.32123E-03    0.10000E+01    0.27509E+05    0.20644E-45    0.29379E-55    0.28189E-51
+    2    2    0.32123E-03    0.10000E+01    0.22184E+05    0.14580E-44    0.38435E-54    0.19984E-50
+    2    2    0.32123E-03    0.10000E+01    0.17891E+05    0.10089E-43    0.48896E-53    0.13911E-49
+    2    2    0.32123E-03    0.10000E+01    0.14428E+05    0.68068E-43    0.60551E-52    0.94681E-49
+    2    2    0.32123E-03    0.10000E+01    0.11635E+05    0.44716E-42    0.72598E-51    0.62955E-48
+    2    2    0.32123E-03    0.10000E+01    0.93834E+04    0.28481E-41    0.82709E-50    0.40733E-47
+    2    2    0.32123E-03    0.10000E+01    0.75673E+04    0.17377E-40    0.88654E-49    0.25287E-46
+    2    2    0.32123E-03    0.10000E+01    0.61026E+04    0.10104E-39    0.99243E-48    0.14744E-45
+    2    2    0.32123E-03    0.10000E+01    0.49215E+04    0.60062E-39    0.15705E-46    0.81736E-45
+    2    2    0.32123E-03    0.10000E+01    0.39689E+04    0.45457E-38    0.36069E-45    0.50498E-44
+    2    2    0.32123E-03    0.10000E+01    0.32008E+04    0.15458E-35    0.28809E-42    0.14289E-41
+    2    2    0.32123E-03    0.10000E+01    0.25813E+04    0.99522E-27    0.40697E-33    0.86870E-33
+    2    2    0.32123E-03    0.10000E+01    0.20817E+04    0.15997E-10    0.23393E-16    0.13500E-16
+    2    2    0.32123E-03    0.10000E+01    0.16788E+04    0.46140E-05    0.26503E-10    0.36262E-11
+    2    2    0.32123E-03    0.10000E+01    0.13538E+04    0.82863E-05    0.94503E-10    0.56378E-11
+    2    2    0.32123E-03    0.10000E+01    0.10918E+04    0.15215E-04    0.33557E-09    0.89847E-11
+    2    2    0.32123E-03    0.10000E+01    0.88049E+03    0.28221E-04    0.11908E-08    0.14535E-10
+    2    2    0.32123E-03    0.10000E+01    0.71007E+03    0.52543E-04    0.42217E-08    0.23756E-10
+    2    2    0.32123E-03    0.10000E+01    0.57264E+03    0.97904E-04    0.14746E-07    0.39194E-10
+    2    2    0.32123E-03    0.10000E+01    0.46180E+03    0.18203E-03    0.49016E-07    0.65287E-10
+    2    2    0.32123E-03    0.10000E+01    0.37242E+03    0.33527E-03    0.14840E-06    0.10942E-09
+    2    2    0.32123E-03    0.10000E+01    0.30034E+03    0.60356E-03    0.39635E-06    0.18259E-09
+    2    2    0.32123E-03    0.10000E+01    0.24221E+03    0.10446E-02    0.92310E-06    0.29840E-09
+    2    2    0.32123E-03    0.10000E+01    0.19533E+03    0.16283E-02    0.17517E-05    0.44805E-09
+    2    2    0.32123E-03    0.10000E+01    0.15752E+03    0.16283E-02    0.17517E-05    0.44805E-09
+    2    3    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.15051E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    3    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.26263E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    3    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.45827E-08    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    3    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.79966E-08    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    2    3    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.13954E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    2    3    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.24348E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    2    3    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.42486E-07    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    2    3    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.74135E-07    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    2    3    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.12936E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    2    3    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.22573E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    2    3    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.39388E-06    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    2    3    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.68730E-06    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    2    3    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.11993E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    2    3    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.20927E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    2    3    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.36516E-05    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    2    3    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.63719E-05    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    2    3    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.11119E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    2    3    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.19401E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    2    3    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.33854E-04    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    2    3    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.59073E-04    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    2    3    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53957E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.10308E-03    0.19496E+06    0.99447E-26    0.48760E-10    0.50499E-04    0.88379E+03
+    2    3    0.54572E-10    0.10000E+01    0.74090E-01    0.13935E+00    0.11222E-09    0.65380E-11    0.40383E-04    0.29228E-04    0.98516E+04    0.17987E-03    0.15940E+06    0.27009E-25    0.58026E-09    0.60483E-04    0.85041E+03
+    2    3    0.95225E-10    0.10000E+01    0.11736E+00    0.19749E+00    0.21140E-09    0.50997E-10    0.44004E-04    0.38038E-04    0.17190E+05    0.31386E-03    0.12765E+06    0.72480E-25    0.43989E-08    0.73406E-04    0.78192E+03
+    2    3    0.16616E-09    0.10000E+01    0.18179E+00    0.26430E+00    0.32752E-09    0.26585E-09    0.44528E-04    0.48901E-04    0.29996E+05    0.54766E-03    0.99467E+05    0.19956E-24    0.21857E-07    0.91697E-04    0.67141E+03
+    2    3    0.28994E-09    0.10000E+01    0.25914E+00    0.33393E+00    0.47731E-09    0.94109E-09    0.43655E-04    0.57569E-04    0.52341E+05    0.95563E-03    0.75717E+05    0.57623E-24    0.71454E-07    0.11854E-03    0.53447E+03
+    2    3    0.50593E-09    0.10000E+01    0.33551E+00    0.39738E+00    0.75762E-09    0.24938E-08    0.46577E-04    0.59128E-04    0.91333E+05    0.16675E-02    0.56968E+05    0.17781E-23    0.16861E-06    0.15742E-03    0.40285E+03
+    2    3    0.88282E-09    0.10000E+01    0.39404E+00    0.43339E+00    0.13295E-08    0.57181E-08    0.60660E-04    0.52172E-04    0.15937E+06    0.29097E-02    0.43366E+05    0.61338E-23    0.33801E-06    0.21141E-03    0.30365E+03
+    2    3    0.15405E-08    0.10000E+01    0.42582E+00    0.45871E+00    0.27220E-08    0.12084E-07    0.89627E-04    0.45843E-04    0.27809E+06    0.50773E-02    0.34145E+05    0.22068E-22    0.61995E-06    0.27805E-03    0.24678E+03
+    2    3    0.26880E-08    0.10000E+01    0.38374E+00    0.66632E+00    0.11439E-07    0.24736E-07    0.10533E-03    0.53230E-04    0.24244E+06    0.70565E-02    0.10095E+05    0.19039E-21    0.87649E-06    0.46730E-03    0.22178E+03
+    2    3    0.46905E-08    0.10000E+01    0.35815E+00    0.93330E+00    0.29182E-07    0.46257E-07    0.11392E-03    0.66976E-04    0.20736E+06    0.95050E-02    0.48515E+04    0.87645E-21    0.12043E-05    0.70802E-03    0.18897E+03
+    2    3    0.81846E-08    0.10000E+01    0.42281E+00    0.10767E+01    0.52074E-07    0.82744E-07    0.14505E-03    0.75643E-04    0.36184E+06    0.16586E-01    0.38349E+04    0.22966E-20    0.18597E-05    0.86227E-03    0.16870E+03
+    2    3    0.14282E-07    0.10000E+01    0.50463E+00    0.12324E+01    0.91425E-07    0.14696E-06    0.18397E-03    0.85953E-04    0.63138E+06    0.28941E-01    0.29922E+04    0.61281E-20    0.28492E-05    0.10637E-02    0.14718E+03
+    2    3    0.24920E-07    0.10000E+01    0.60684E+00    0.13994E+01    0.15761E-06    0.26001E-06    0.23173E-03    0.97782E-04    0.11017E+07    0.50500E-01    0.23045E+04    0.16849E-19    0.43432E-05    0.13367E-02    0.12459E+03
+    2    3    0.43485E-07    0.10000E+01    0.73065E+00    0.15748E+01    0.26628E-06    0.45913E-06    0.28960E-03    0.11080E-03    0.19224E+07    0.88120E-01    0.17543E+04    0.47879E-19    0.66035E-05    0.17136E-02    0.10202E+03
+    2    3    0.75878E-07    0.10000E+01    0.87439E+00    0.17529E+01    0.44112E-06    0.81006E-06    0.35993E-03    0.12441E-03    0.33546E+07    0.15376E+00    0.13233E+04    0.13995E-18    0.10041E-04    0.22353E-02    0.80902E+02
+    2    3    0.13240E-06    0.10000E+01    0.10326E+01    0.19257E+01    0.72204E-06    0.14286E-05    0.44808E-03    0.13776E-03    0.58535E+07    0.26831E+00    0.99434E+03    0.41564E-18    0.15323E-04    0.29467E-02    0.62556E+02
+    2    3    0.23103E-06    0.10000E+01    0.12009E+01    0.20891E+01    0.11654E-05    0.25185E-05    0.55982E-03    0.15027E-03    0.10214E+08    0.46818E+00    0.74424E+03    0.12493E-17    0.23477E-04    0.39158E-02    0.47353E+02
+    2    3    0.40314E-06    0.10000E+01    0.13741E+01    0.22390E+01    0.18571E-05    0.44347E-05    0.70416E-03    0.16147E-03    0.17823E+08    0.81695E+00    0.55560E+03    0.37470E-17    0.36108E-04    0.52163E-02    0.35305E+02
+    2    3    0.70346E-06    0.10000E+01    0.14365E+01    0.22888E+01    0.44634E-05    0.77538E-05    0.10945E-02    0.16510E-03    0.31100E+08    0.14255E+01    0.50000E+03    0.78801E-17    0.60236E-04    0.57711E-02    0.31707E+02
+    2    3    0.12275E-05    0.10000E+01    0.14365E+01    0.22888E+01    0.13590E-04    0.13530E-04    0.19098E-02    0.16510E-03    0.54267E+08    0.24875E+01    0.50000E+03    0.13750E-16    0.10511E-03    0.57711E-02    0.31707E+02
+    2    3    0.21419E-05    0.10000E+01    0.14365E+01    0.22888E+01    0.41379E-04    0.23609E-04    0.33325E-02    0.16510E-03    0.94693E+08    0.43405E+01    0.50000E+03    0.23993E-16    0.18341E-03    0.57711E-02    0.31707E+02
+    2    3    0.37375E-05    0.10000E+01    0.14365E+01    0.22888E+01    0.12599E-03    0.41196E-04    0.58150E-02    0.16510E-03    0.16523E+09    0.75739E+01    0.50000E+03    0.41867E-16    0.32004E-03    0.57711E-02    0.31707E+02
+    2    3    0.65217E-05    0.10000E+01    0.14365E+01    0.22888E+01    0.38362E-03    0.71885E-04    0.10147E-01    0.16510E-03    0.28832E+09    0.13216E+02    0.50000E+03    0.73056E-16    0.55844E-03    0.57711E-02    0.31707E+02
+    2    3    0.11380E-04    0.10000E+01    0.14365E+01    0.22888E+01    0.11681E-02    0.12543E-03    0.17706E-01    0.16510E-03    0.50310E+09    0.23061E+02    0.50000E+03    0.12748E-15    0.97445E-03    0.57711E-02    0.31707E+02
+    2    3    0.19857E-04    0.10000E+01    0.14365E+01    0.22888E+01    0.35565E-02    0.21888E-03    0.30895E-01    0.16510E-03    0.87789E+09    0.40240E+02    0.50000E+03    0.22244E-15    0.17004E-02    0.57711E-02    0.31707E+02
+    2    3    0.34650E-04    0.10000E+01    0.14365E+01    0.22888E+01    0.10829E-01    0.38192E-03    0.53911E-01    0.16510E-03    0.15319E+10    0.70216E+02    0.50000E+03    0.38815E-15    0.29670E-02    0.57711E-02    0.31707E+02
+    2    3    0.60462E-04    0.10000E+01    0.14365E+01    0.22888E+01    0.32972E-01    0.66643E-03    0.94071E-01    0.16510E-03    0.26730E+10    0.12252E+03    0.50000E+03    0.67729E-15    0.51773E-02    0.57711E-02    0.31707E+02
+    2    3    0.10550E-03    0.10000E+01    0.14365E+01    0.22888E+01    0.10039E+00    0.11629E-02    0.16415E+00    0.16510E-03    0.46642E+10    0.21380E+03    0.50000E+03    0.11818E-14    0.90340E-02    0.57711E-02    0.31707E+02
+    2    3    0.18409E-03    0.10000E+01    0.14365E+01    0.22888E+01    0.30568E+00    0.20292E-02    0.28643E+00    0.16510E-03    0.81388E+10    0.37306E+03    0.50000E+03    0.20622E-14    0.15764E-01    0.57711E-02    0.31707E+02
+    2    3    0.32123E-03    0.10000E+01    0.14365E+01    0.22888E+01    0.93075E+00    0.35408E-02    0.49980E+00    0.16510E-03    0.14202E+11    0.65097E+03    0.50000E+03    0.35985E-14    0.27507E-01    0.57711E-02    0.31707E+02
+    2    3    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    2    3    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    2    3    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    2    3    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    2    3    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    2    3    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    2    3    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    2    3    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    2    3    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    2    3    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    2    3    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    2    3    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    2    3    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    2    3    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    2    3    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    2    3    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    2    3    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    2    3    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    2    3    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    2    3    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    2    3    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    2    3    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    2    3    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    2    3    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    2    3    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    2    3    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    2    3    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    2    3    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    2    3    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    2    3    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    2    3    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    2    3    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    2    3    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    2    3    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    2    3    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    2    3    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    2    3    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    2    3    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    2    3    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    2    3    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    2    3    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    2    3    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    2    3    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    2    3    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    2    3    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    2    3    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    2    3    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    2    3    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    2    3    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    2    3    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    2    3    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    2    3    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    2    3    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    2    3    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    2    3    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    2    3    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    2    3    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    2    3    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    2    3    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    2    3    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    2    3    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    2    3    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    2    3    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    2    3    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    2    3    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    2    3    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    2    3    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    2    3    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    2    3    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    2    3    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    2    3    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    2    3    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    2    3    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    2    3    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    2    3    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    2    3    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    2    3    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    2    3    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    2    3    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    2    3    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    2    3    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    2    3    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    2    3    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    2    3    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    2    3    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    2    3    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    2    3    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    2    3    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    2    3    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    2    3    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    2    3    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    2    3    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    2    3    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    2    3    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    2    3    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    2    3    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    2    3    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    2    3    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    2    3    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    2    3    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    2    3    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    2    3    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    2    3    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    2    3    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    2    3    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    2    3    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    2    3    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    2    3    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    2    3    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    2    3    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    2    3    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    2    3    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    2    3    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    2    3    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    2    3    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    2    3    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    2    3    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    2    3    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    2    3    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    2    3    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    2    3    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    2    3    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    2    3    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    2    3    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    2    3    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    2    3    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    2    3    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    2    3    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    2    3    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    2    3    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    2    3    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    2    3    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    2    3    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    2    3    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    2    3    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    2    3    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    2    3    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    2    3    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    2    3    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    2    3    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    2    3    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    2    3    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    2    3    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    2    3    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    2    3    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    2    3    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    2    3    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    2    3    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    2    3    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    2    3    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    2    3    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    2    3    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    2    3    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    2    3    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    2    3    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    2    3    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    2    3    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    2    3    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    2    3    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    2    3    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    2    3    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    2    3    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    2    3    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    2    3    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    2    3    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    2    3    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    2    3    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    2    3    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    2    3    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    2    3    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    2    3    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    2    3    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    2    3    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    2    3    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    2    3    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    2    3    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    2    3    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    2    3    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    2    3    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    2    3    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    2    3    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    2    3    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    2    3    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    2    3    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    2    3    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    2    3    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    2    3    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    2    3    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    2    3    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    2    3    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    2    3    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    2    3    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    2    3    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    2    3    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    2    3    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    2    3    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    2    3    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    2    3    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    2    3    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    2    3    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    2    3    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    2    3    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    2    3    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    2    3    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    2    3    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    2    3    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    2    3    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    2    3    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    2    3    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    2    3    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    2    3    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    2    3    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    2    3    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    2    3    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    2    3    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    2    3    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    2    3    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    2    3    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    2    3    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    2    3    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    2    3    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    2    3    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    2    3    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    2    3    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    2    3    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    2    3    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    2    3    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    2    3    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    2    3    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    2    3    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    2    3    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    2    3    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    2    3    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    2    3    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    2    3    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    2    3    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    2    3    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    2    3    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    2    3    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    2    3    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    2    3    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    2    3    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    2    3    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    2    3    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    2    3    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    2    3    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    2    3    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    2    3    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    2    3    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    2    3    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    2    3    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    2    3    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    2    3    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    2    3    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    2    3    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    2    3    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    2    3    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    2    3    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    2    3    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    2    3    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    2    3    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    2    3    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    2    3    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    2    3    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    2    3    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    2    3    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    2    3    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    2    3    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    2    3    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    2    3    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    2    3    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    2    3    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    2    3    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    2    3    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    2    3    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    2    3    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    2    3    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    2    3    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    2    3    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    2    3    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    2    3    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    2    3    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    2    3    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    2    3    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    2    3    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    2    3    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    2    3    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    2    3    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    2    3    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    2    3    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    2    3    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    2    3    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    2    3    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    2    3    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    2    3    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    2    3    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    2    3    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    2    3    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    2    3    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    2    3    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    2    3    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    2    3    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    2    3    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    2    3    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    2    3    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    2    3    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    2    3    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    2    3    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    2    3    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    2    3    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    2    3    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    2    3    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    2    3    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    2    3    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    2    3    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    2    3    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    2    3    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    2    3    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    2    3    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    2    3    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    2    3    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    2    3    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    2    3    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    2    3    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    2    3    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    2    3    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    2    3    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    2    3    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    2    3    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    2    3    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    2    3    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    2    3    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    2    3    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    2    3    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    2    3    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    2    3    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    2    3    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    2    3    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    2    3    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    2    3    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    2    3    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    2    3    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    2    3    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    2    3    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    2    3    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    2    3    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    2    3    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    2    3    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    2    3    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    2    3    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    2    3    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    2    3    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    2    3    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    2    3    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    2    3    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    2    3    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    2    3    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    2    3    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    2    3    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    2    3    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    2    3    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    2    3    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    2    3    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    2    3    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    2    3    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    2    3    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    2    3    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    2    3    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    2    3    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    2    3    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    2    3    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    2    3    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    2    3    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    2    3    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    2    3    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    2    3    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    2    3    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    2    3    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    2    3    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    2    3    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    2    3    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    2    3    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    2    3    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    2    3    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    2    3    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    2    3    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    2    3    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    2    3    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    2    3    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    2    3    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    2    3    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    2    3    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    2    3    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    2    3    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    2    3    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    2    3    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    2    3    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    2    3    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    2    3    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    2    3    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    2    3    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    2    3    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    2    3    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    2    3    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    2    3    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    2    3    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    2    3    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    2    3    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    2    3    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    2    3    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    2    3    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    2    3    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    2    3    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    2    3    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    2    3    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    2    3    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    2    3    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    2    3    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    2    3    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    2    3    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    2    3    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    2    3    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    2    3    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    2    3    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    2    3    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    2    3    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    2    3    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    2    3    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    2    3    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    2    3    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    2    3    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    2    3    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    2    3    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    2    3    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    2    3    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    2    3    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    2    3    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    2    3    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    2    3    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    2    3    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    2    3    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    2    3    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    2    3    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    2    3    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    2    3    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    2    3    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    2    3    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    2    3    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    2    3    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    2    3    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    2    3    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    2    3    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    2    3    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    2    3    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    2    3    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    2    3    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    2    3    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    2    3    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    2    3    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    2    3    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    2    3    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    2    3    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    2    3    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    2    3    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    2    3    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    2    3    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    2    3    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    2    3    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    2    3    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    2    3    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    2    3    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    2    3    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    2    3    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    2    3    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    2    3    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    2    3    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    2    3    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    2    3    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    2    3    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    2    3    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    2    3    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    2    3    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    2    3    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    2    3    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    2    3    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    2    3    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    2    3    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    2    3    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    2    3    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    2    3    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    2    3    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    2    3    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    2    3    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    2    3    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    2    3    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    2    3    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    2    3    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    2    3    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    2    3    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    2    3    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    2    3    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    2    3    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    2    3    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    2    3    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    2    3    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    2    3    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    2    3    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    2    3    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    2    3    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    2    3    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    2    3    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    2    3    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    2    3    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    2    3    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    2    3    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    2    3    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    2    3    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    2    3    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    2    3    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    2    3    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    2    3    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    2    3    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    2    3    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    2    3    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    2    3    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    2    3    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    2    3    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    2    3    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    2    3    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    2    3    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    2    3    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    2    3    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    2    3    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    2    3    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    2    3    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    2    3    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    2    3    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    2    3    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    2    3    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    2    3    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    2    3    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    2    3    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    2    3    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    2    3    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    2    3    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    2    3    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    2    3    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    2    3    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    2    3    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    2    3    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    2    3    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    2    3    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    2    3    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    2    3    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    2    3    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    2    3    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    2    3    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    2    3    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    2    3    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    2    3    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    2    3    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    2    3    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    2    3    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    2    3    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    2    3    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    2    3    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    2    3    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    2    3    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    2    3    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    2    3    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    2    3    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    2    3    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    2    3    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    2    3    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    2    3    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    2    3    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    2    3    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    2    3    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    2    3    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    2    3    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    2    3    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    2    3    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    2    3    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    2    3    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    2    3    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    2    3    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    2    3    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    2    3    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    2    3    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    2    3    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    2    3    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    2    3    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    2    3    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    2    3    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    2    3    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    2    3    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    2    3    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    2    3    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    2    3    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    2    3    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    2    3    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    2    3    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    2    3    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    2    3    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    2    3    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    2    3    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    2    3    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    2    3    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    2    3    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    2    3    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    2    3    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    2    3    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    2    3    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    2    3    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    2    3    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    2    3    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    2    3    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    2    3    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    2    3    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    2    3    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    2    3    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    2    3    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    2    3    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    2    3    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    2    3    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    2    3    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    2    3    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    2    3    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    2    3    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    2    3    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    2    3    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35525E-67
+    2    3    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31050E-66
+    2    3    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49297E-66    0.26759E-65
+    2    3    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20665E-64
+    2    3    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    2    3    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15327E-62
+    2    3    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    2    3    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30486E-60
+    2    3    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49479E-59
+    2    3    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76348E-58
+    2    3    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    2    3    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16341E-55
+    2    3    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    2    3    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33513E-53
+    2    3    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47754E-52
+    2    3    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86007E-46    0.21355E-49
+    2    3    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    2    3    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    2    3    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    2    3    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    2    3    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    2    3    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    2    3    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    2    3    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    2    3    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    2    3    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    2    3    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    2    3    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    2    3    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    2    3    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    2    3    0.95225E-10    0.10000E+01    0.80645E+05    0.53338E-57    0.41251E-68    0.10749E-66
+    2    3    0.95225E-10    0.10000E+01    0.65036E+05    0.46320E-56    0.66241E-67    0.94141E-66
+    2    3    0.95225E-10    0.10000E+01    0.52449E+05    0.40024E-55    0.93503E-66    0.81416E-65
+    2    3    0.95225E-10    0.10000E+01    0.42297E+05    0.31521E-54    0.15121E-64    0.62477E-64
+    2    3    0.95225E-10    0.10000E+01    0.34111E+05    0.26479E-53    0.31103E-63    0.46450E-63
+    2    3    0.95225E-10    0.10000E+01    0.27509E+05    0.27530E-52    0.84266E-62    0.36185E-62
+    2    3    0.95225E-10    0.10000E+01    0.22184E+05    0.37547E-51    0.26561E-60    0.35004E-61
+    2    3    0.95225E-10    0.10000E+01    0.17891E+05    0.59959E-50    0.82078E-59    0.47852E-60
+    2    3    0.95225E-10    0.10000E+01    0.14428E+05    0.96029E-49    0.23747E-57    0.76675E-59
+    2    3    0.95225E-10    0.10000E+01    0.11635E+05    0.14620E-47    0.65938E-56    0.12102E-57
+    2    3    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18298E-56
+    2    3    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49011E-53    0.26942E-55
+    2    3    0.95225E-10    0.10000E+01    0.61026E+04    0.43943E-44    0.13295E-51    0.39150E-54
+    2    3    0.95225E-10    0.10000E+01    0.49215E+04    0.62538E-43    0.35997E-50    0.56476E-53
+    2    3    0.95225E-10    0.10000E+01    0.39689E+04    0.88822E-42    0.97300E-49    0.81063E-52
+    2    3    0.95225E-10    0.10000E+01    0.32008E+04    0.39613E-39    0.84952E-46    0.36461E-49
+    2    3    0.95225E-10    0.10000E+01    0.25813E+04    0.29211E-30    0.14353E-36    0.27085E-40
+    2    3    0.95225E-10    0.10000E+01    0.20817E+04    0.55938E-14    0.12256E-19    0.52257E-24
+    2    3    0.95225E-10    0.10000E+01    0.16788E+04    0.18980E-08    0.18143E-13    0.17813E-18
+    2    3    0.95225E-10    0.10000E+01    0.13538E+04    0.40806E-08    0.68940E-13    0.38357E-18
+    2    3    0.95225E-10    0.10000E+01    0.10918E+04    0.85761E-08    0.25711E-12    0.80708E-18
+    2    3    0.95225E-10    0.10000E+01    0.88049E+03    0.17636E-07    0.94670E-12    0.16610E-17
+    2    3    0.95225E-10    0.10000E+01    0.71007E+03    0.35560E-07    0.34475E-11    0.33511E-17
+    2    3    0.95225E-10    0.10000E+01    0.57264E+03    0.70490E-07    0.12266E-10    0.66454E-17
+    2    3    0.95225E-10    0.10000E+01    0.46180E+03    0.13745E-06    0.41255E-10    0.12961E-16
+    2    3    0.95225E-10    0.10000E+01    0.37242E+03    0.26237E-06    0.12579E-09    0.24744E-16
+    2    3    0.95225E-10    0.10000E+01    0.30034E+03    0.48462E-06    0.33740E-09    0.45710E-16
+    2    3    0.95225E-10    0.10000E+01    0.24221E+03    0.85384E-06    0.78780E-09    0.80539E-16
+    2    3    0.95225E-10    0.10000E+01    0.19533E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    2    3    0.95225E-10    0.10000E+01    0.15752E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    2    3    0.16616E-09    0.10000E+01    0.80645E+05    0.10831E-56    0.84135E-68    0.33654E-66
+    2    3    0.16616E-09    0.10000E+01    0.65036E+05    0.94383E-56    0.13506E-66    0.29213E-65
+    2    3    0.16616E-09    0.10000E+01    0.52449E+05    0.81476E-55    0.18599E-65    0.25178E-64
+    2    3    0.16616E-09    0.10000E+01    0.42297E+05    0.62646E-54    0.26584E-64    0.19205E-63
+    2    3    0.16616E-09    0.10000E+01    0.34111E+05    0.47293E-53    0.41443E-63    0.13946E-62
+    2    3    0.16616E-09    0.10000E+01    0.27509E+05    0.38376E-52    0.82702E-62    0.99839E-62
+    2    3    0.16616E-09    0.10000E+01    0.22184E+05    0.38950E-51    0.23108E-60    0.77605E-61
+    2    3    0.16616E-09    0.10000E+01    0.17891E+05    0.53703E-50    0.71872E-59    0.82847E-60
+    2    3    0.16616E-09    0.10000E+01    0.14428E+05    0.84667E-49    0.21403E-57    0.12130E-58
+    2    3    0.16616E-09    0.10000E+01    0.11635E+05    0.13169E-47    0.60847E-56    0.19195E-57
+    2    3    0.16616E-09    0.10000E+01    0.93834E+04    0.19721E-46    0.16918E-54    0.29613E-56
+    2    3    0.16616E-09    0.10000E+01    0.75673E+04    0.28850E-45    0.46590E-53    0.44364E-55
+    2    3    0.16616E-09    0.10000E+01    0.61026E+04    0.41726E-44    0.12762E-51    0.65290E-54
+    2    3    0.16616E-09    0.10000E+01    0.49215E+04    0.59980E-43    0.34818E-50    0.95067E-53
+    2    3    0.16616E-09    0.10000E+01    0.39689E+04    0.85857E-42    0.94686E-49    0.13743E-51
+    2    3    0.16616E-09    0.10000E+01    0.32008E+04    0.38533E-39    0.83094E-46    0.62162E-49
+    2    3    0.16616E-09    0.10000E+01    0.25813E+04    0.28572E-30    0.14110E-36    0.46405E-40
+    2    3    0.16616E-09    0.10000E+01    0.20817E+04    0.55023E-14    0.12112E-19    0.89981E-24
+    2    3    0.16616E-09    0.10000E+01    0.16788E+04    0.18735E-08    0.17967E-13    0.30768E-18
+    2    3    0.16616E-09    0.10000E+01    0.13538E+04    0.40327E-08    0.68292E-13    0.66322E-18
+    2    3    0.16616E-09    0.10000E+01    0.10918E+04    0.84828E-08    0.25473E-12    0.13965E-17
+    2    3    0.16616E-09    0.10000E+01    0.88049E+03    0.17454E-07    0.93804E-12    0.28757E-17
+    2    3    0.16616E-09    0.10000E+01    0.71007E+03    0.35210E-07    0.34161E-11    0.58040E-17
+    2    3    0.16616E-09    0.10000E+01    0.57264E+03    0.69816E-07    0.12154E-10    0.11512E-16
+    2    3    0.16616E-09    0.10000E+01    0.46180E+03    0.13616E-06    0.40880E-10    0.22458E-16
+    2    3    0.16616E-09    0.10000E+01    0.37242E+03    0.25994E-06    0.12465E-09    0.42878E-16
+    2    3    0.16616E-09    0.10000E+01    0.30034E+03    0.48016E-06    0.33433E-09    0.79212E-16
+    2    3    0.16616E-09    0.10000E+01    0.24221E+03    0.84602E-06    0.78064E-09    0.13957E-15
+    2    3    0.16616E-09    0.10000E+01    0.19533E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    2    3    0.16616E-09    0.10000E+01    0.15752E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    2    3    0.28994E-09    0.10000E+01    0.80645E+05    0.22012E-56    0.16919E-67    0.11289E-65
+    2    3    0.28994E-09    0.10000E+01    0.65036E+05    0.19023E-55    0.27096E-66    0.96802E-65
+    2    3    0.28994E-09    0.10000E+01    0.52449E+05    0.16354E-54    0.36922E-65    0.82855E-64
+    2    3    0.28994E-09    0.10000E+01    0.42297E+05    0.12447E-53    0.50556E-64    0.62670E-63
+    2    3    0.28994E-09    0.10000E+01    0.34111E+05    0.90504E-53    0.69117E-63    0.44993E-62
+    2    3    0.28994E-09    0.10000E+01    0.27509E+05    0.65379E-52    0.10278E-61    0.31349E-61
+    2    3    0.28994E-09    0.10000E+01    0.22184E+05    0.51157E-51    0.21724E-60    0.21693E-60
+    2    3    0.28994E-09    0.10000E+01    0.17891E+05    0.53449E-50    0.62921E-59    0.17673E-59
+    2    3    0.28994E-09    0.10000E+01    0.14428E+05    0.75802E-49    0.19092E-57    0.20830E-58
+    2    3    0.28994E-09    0.10000E+01    0.11635E+05    0.11790E-47    0.55776E-56    0.31163E-57
+    2    3    0.28994E-09    0.10000E+01    0.93834E+04    0.18053E-46    0.15828E-54    0.48376E-56
+    2    3    0.28994E-09    0.10000E+01    0.75673E+04    0.26944E-45    0.44222E-53    0.73513E-55
+    2    3    0.28994E-09    0.10000E+01    0.61026E+04    0.39554E-44    0.12242E-51    0.10938E-53
+    2    3    0.28994E-09    0.10000E+01    0.49215E+04    0.57487E-43    0.33675E-50    0.16051E-52
+    2    3    0.28994E-09    0.10000E+01    0.39689E+04    0.82983E-42    0.92172E-49    0.23337E-51
+    2    3    0.28994E-09    0.10000E+01    0.32008E+04    0.37495E-39    0.81329E-46    0.10605E-48
+    2    3    0.28994E-09    0.10000E+01    0.25813E+04    0.27965E-30    0.13884E-36    0.79494E-40
+    2    3    0.28994E-09    0.10000E+01    0.20817E+04    0.54181E-14    0.11986E-19    0.15483E-23
+    2    3    0.28994E-09    0.10000E+01    0.16788E+04    0.18517E-08    0.17819E-13    0.53087E-18
+    2    3    0.28994E-09    0.10000E+01    0.13538E+04    0.39907E-08    0.67752E-13    0.11454E-17
+    2    3    0.28994E-09    0.10000E+01    0.10918E+04    0.84023E-08    0.25276E-12    0.24134E-17
+    2    3    0.28994E-09    0.10000E+01    0.88049E+03    0.17300E-07    0.93087E-12    0.49720E-17
+    2    3    0.28994E-09    0.10000E+01    0.71007E+03    0.34914E-07    0.33901E-11    0.10038E-16
+    2    3    0.28994E-09    0.10000E+01    0.57264E+03    0.69251E-07    0.12062E-10    0.19915E-16
+    2    3    0.28994E-09    0.10000E+01    0.46180E+03    0.13509E-06    0.40568E-10    0.38854E-16
+    2    3    0.28994E-09    0.10000E+01    0.37242E+03    0.25791E-06    0.12370E-09    0.74189E-16
+    2    3    0.28994E-09    0.10000E+01    0.30034E+03    0.47646E-06    0.33179E-09    0.13706E-15
+    2    3    0.28994E-09    0.10000E+01    0.24221E+03    0.83953E-06    0.77469E-09    0.24151E-15
+    2    3    0.28994E-09    0.10000E+01    0.19533E+03    0.13232E-05    0.14722E-08    0.38066E-15
+    2    3    0.28994E-09    0.10000E+01    0.15752E+03    0.13232E-05    0.14722E-08    0.38066E-15
+    2    3    0.50593E-09    0.10000E+01    0.80645E+05    0.45341E-56    0.34340E-67    0.42125E-65
+    2    3    0.50593E-09    0.10000E+01    0.65036E+05    0.38727E-55    0.54705E-66    0.35673E-64
+    2    3    0.50593E-09    0.10000E+01    0.52449E+05    0.33060E-54    0.73685E-65    0.30274E-63
+    2    3    0.50593E-09    0.10000E+01    0.42297E+05    0.24919E-53    0.99096E-64    0.22626E-62
+    2    3    0.50593E-09    0.10000E+01    0.34111E+05    0.17828E-52    0.13036E-62    0.15999E-61
+    2    3    0.50593E-09    0.10000E+01    0.27509E+05    0.12405E-51    0.16741E-61    0.10950E-60
+    2    3    0.50593E-09    0.10000E+01    0.22184E+05    0.85426E-51    0.25647E-60    0.71904E-60
+    2    3    0.50593E-09    0.10000E+01    0.17891E+05    0.67481E-50    0.59736E-59    0.48902E-59
+    2    3    0.50593E-09    0.10000E+01    0.14428E+05    0.75566E-49    0.17522E-57    0.43775E-58
+    2    3    0.50593E-09    0.10000E+01    0.11635E+05    0.10977E-47    0.52058E-56    0.56437E-57
+    2    3    0.50593E-09    0.10000E+01    0.93834E+04    0.16872E-46    0.15022E-54    0.84564E-56
+    2    3    0.50593E-09    0.10000E+01    0.75673E+04    0.25544E-45    0.42440E-53    0.12781E-54
+    2    3    0.50593E-09    0.10000E+01    0.61026E+04    0.37922E-44    0.11838E-51    0.18976E-53
+    2    3    0.50593E-09    0.10000E+01    0.49215E+04    0.55550E-43    0.32746E-50    0.27783E-52
+    2    3    0.50593E-09    0.10000E+01    0.39689E+04    0.80658E-42    0.90039E-49    0.40324E-51
+    2    3    0.50593E-09    0.10000E+01    0.32008E+04    0.36618E-39    0.79766E-46    0.18309E-48
+    2    3    0.50593E-09    0.10000E+01    0.25813E+04    0.27430E-30    0.13674E-36    0.13726E-39
+    2    3    0.50593E-09    0.10000E+01    0.20817E+04    0.53397E-14    0.11858E-19    0.26765E-23
+    2    3    0.50593E-09    0.10000E+01    0.16788E+04    0.18304E-08    0.17661E-13    0.91859E-18
+    2    3    0.50593E-09    0.10000E+01    0.13538E+04    0.39486E-08    0.67168E-13    0.19823E-17
+    2    3    0.50593E-09    0.10000E+01    0.10918E+04    0.83195E-08    0.25062E-12    0.41778E-17
+    2    3    0.50593E-09    0.10000E+01    0.88049E+03    0.17138E-07    0.92301E-12    0.86081E-17
+    2    3    0.50593E-09    0.10000E+01    0.71007E+03    0.34600E-07    0.33615E-11    0.17381E-16
+    2    3    0.50593E-09    0.10000E+01    0.57264E+03    0.68643E-07    0.11960E-10    0.34484E-16
+    2    3    0.50593E-09    0.10000E+01    0.46180E+03    0.13392E-06    0.40225E-10    0.67279E-16
+    2    3    0.50593E-09    0.10000E+01    0.37242E+03    0.25571E-06    0.12265E-09    0.12846E-15
+    2    3    0.50593E-09    0.10000E+01    0.30034E+03    0.47240E-06    0.32898E-09    0.23733E-15
+    2    3    0.50593E-09    0.10000E+01    0.24221E+03    0.83240E-06    0.76813E-09    0.41818E-15
+    2    3    0.50593E-09    0.10000E+01    0.19533E+03    0.13120E-05    0.14597E-08    0.65911E-15
+    2    3    0.50593E-09    0.10000E+01    0.15752E+03    0.13120E-05    0.14597E-08    0.65911E-15
+    2    3    0.88282E-09    0.10000E+01    0.80645E+05    0.95152E-56    0.71065E-67    0.18030E-64
+    2    3    0.88282E-09    0.10000E+01    0.65036E+05    0.80369E-55    0.11247E-65    0.15117E-63
+    2    3    0.88282E-09    0.10000E+01    0.52449E+05    0.68071E-54    0.14935E-64    0.12733E-62
+    2    3    0.88282E-09    0.10000E+01    0.42297E+05    0.50715E-53    0.19713E-63    0.94046E-62
+    2    3    0.88282E-09    0.10000E+01    0.34111E+05    0.35699E-52    0.25379E-62    0.65363E-61
+    2    3    0.88282E-09    0.10000E+01    0.27509E+05    0.24310E-51    0.30774E-61    0.43818E-60
+    2    3    0.88282E-09    0.10000E+01    0.22184E+05    0.15880E-50    0.38865E-60    0.27891E-59
+    2    3    0.88282E-09    0.10000E+01    0.17891E+05    0.10692E-49    0.69598E-59    0.17423E-58
+    2    3    0.88282E-09    0.10000E+01    0.14428E+05    0.93502E-49    0.18279E-57    0.12849E-57
+    2    3    0.88282E-09    0.10000E+01    0.11635E+05    0.11750E-47    0.53149E-56    0.13611E-56
+    2    3    0.88282E-09    0.10000E+01    0.93834E+04    0.17323E-46    0.15228E-54    0.18345E-55
+    2    3    0.88282E-09    0.10000E+01    0.75673E+04    0.25913E-45    0.42719E-53    0.26139E-54
+    2    3    0.88282E-09    0.10000E+01    0.61026E+04    0.38186E-44    0.11841E-51    0.37158E-53
+    2    3    0.88282E-09    0.10000E+01    0.49215E+04    0.55593E-43    0.32605E-50    0.52549E-52
+    2    3    0.88282E-09    0.10000E+01    0.39689E+04    0.80351E-42    0.89404E-49    0.74266E-51
+    2    3    0.88282E-09    0.10000E+01    0.32008E+04    0.36373E-39    0.79093E-46    0.33069E-48
+    2    3    0.88282E-09    0.10000E+01    0.25813E+04    0.27208E-30    0.13554E-36    0.24444E-39
+    2    3    0.88282E-09    0.10000E+01    0.20817E+04    0.52953E-14    0.11758E-19    0.47140E-23
+    2    3    0.88282E-09    0.10000E+01    0.16788E+04    0.18155E-08    0.17518E-13    0.16083E-17
+    2    3    0.88282E-09    0.10000E+01    0.13538E+04    0.39163E-08    0.66624E-13    0.34629E-17
+    2    3    0.88282E-09    0.10000E+01    0.10918E+04    0.82516E-08    0.24858E-12    0.72868E-17
+    2    3    0.88282E-09    0.10000E+01    0.88049E+03    0.16999E-07    0.91544E-12    0.14998E-16
+    2    3    0.88282E-09    0.10000E+01    0.71007E+03    0.34318E-07    0.33337E-11    0.30258E-16
+    2    3    0.88282E-09    0.10000E+01    0.57264E+03    0.68083E-07    0.11860E-10    0.60000E-16
+    2    3    0.88282E-09    0.10000E+01    0.46180E+03    0.13282E-06    0.39890E-10    0.11701E-15
+    2    3    0.88282E-09    0.10000E+01    0.37242E+03    0.25360E-06    0.12163E-09    0.22336E-15
+    2    3    0.88282E-09    0.10000E+01    0.30034E+03    0.46850E-06    0.32622E-09    0.41255E-15
+    2    3    0.88282E-09    0.10000E+01    0.24221E+03    0.82549E-06    0.76169E-09    0.72682E-15
+    2    3    0.88282E-09    0.10000E+01    0.19533E+03    0.13011E-05    0.14474E-08    0.11454E-14
+    2    3    0.88282E-09    0.10000E+01    0.15752E+03    0.13011E-05    0.14474E-08    0.11454E-14
+    2    3    0.15405E-08    0.10000E+01    0.80645E+05    0.19599E-55    0.14510E-66    0.74807E-64
+    2    3    0.15405E-08    0.10000E+01    0.65036E+05    0.16438E-54    0.22862E-65    0.62586E-63
+    2    3    0.15405E-08    0.10000E+01    0.52449E+05    0.13850E-53    0.30052E-64    0.52642E-62
+    2    3    0.15405E-08    0.10000E+01    0.42297E+05    0.10234E-52    0.39113E-63    0.38811E-61
+    2    3    0.15405E-08    0.10000E+01    0.34111E+05    0.71186E-52    0.49600E-62    0.26934E-60
+    2    3    0.15405E-08    0.10000E+01    0.27509E+05    0.47784E-51    0.58699E-61    0.18078E-59
+    2    3    0.15405E-08    0.10000E+01    0.22184E+05    0.30493E-50    0.68223E-60    0.11532E-58
+    2    3    0.15405E-08    0.10000E+01    0.17891E+05    0.19155E-49    0.10136E-58    0.70179E-58
+    2    3    0.15405E-08    0.10000E+01    0.14428E+05    0.14249E-48    0.22926E-57    0.45306E-57
+    2    3    0.15405E-08    0.10000E+01    0.11635E+05    0.15190E-47    0.62372E-56    0.38348E-56
+    2    3    0.15405E-08    0.10000E+01    0.93834E+04    0.20535E-46    0.17178E-54    0.44193E-55
+    2    3    0.15405E-08    0.10000E+01    0.75673E+04    0.29335E-45    0.46659E-53    0.58230E-54
+    2    3    0.15405E-08    0.10000E+01    0.61026E+04    0.41808E-44    0.12593E-51    0.78615E-53
+    2    3    0.15405E-08    0.10000E+01    0.49215E+04    0.59254E-43    0.33974E-50    0.10634E-51
+    2    3    0.15405E-08    0.10000E+01    0.39689E+04    0.83883E-42    0.91794E-49    0.14452E-50
+    2    3    0.15405E-08    0.10000E+01    0.32008E+04    0.37394E-39    0.80360E-46    0.62297E-48
+    2    3    0.15405E-08    0.10000E+01    0.25813E+04    0.27662E-30    0.13660E-36    0.44854E-39
+    2    3    0.15405E-08    0.10000E+01    0.20817E+04    0.53371E-14    0.11770E-19    0.84539E-23
+    2    3    0.15405E-08    0.10000E+01    0.16788E+04    0.18213E-08    0.17494E-13    0.28474E-17
+    2    3    0.15405E-08    0.10000E+01    0.13538E+04    0.39219E-08    0.66502E-13    0.60998E-17
+    2    3    0.15405E-08    0.10000E+01    0.10918E+04    0.82532E-08    0.24804E-12    0.12791E-16
+    2    3    0.15405E-08    0.10000E+01    0.88049E+03    0.16987E-07    0.91323E-12    0.26260E-16
+    2    3    0.15405E-08    0.10000E+01    0.71007E+03    0.34274E-07    0.33251E-11    0.52887E-16
+    2    3    0.15405E-08    0.10000E+01    0.57264E+03    0.67964E-07    0.11828E-10    0.10474E-15
+    2    3    0.15405E-08    0.10000E+01    0.46180E+03    0.13255E-06    0.39778E-10    0.20407E-15
+    2    3    0.15405E-08    0.10000E+01    0.37242E+03    0.25301E-06    0.12128E-09    0.38927E-15
+    2    3    0.15405E-08    0.10000E+01    0.30034E+03    0.46733E-06    0.32528E-09    0.71866E-15
+    2    3    0.15405E-08    0.10000E+01    0.24221E+03    0.82333E-06    0.75948E-09    0.12657E-14
+    2    3    0.15405E-08    0.10000E+01    0.19533E+03    0.12976E-05    0.14432E-08    0.19944E-14
+    2    3    0.15405E-08    0.10000E+01    0.15752E+03    0.12976E-05    0.14432E-08    0.19944E-14
+    2    3    0.26880E-08    0.10000E+01    0.80645E+05    0.40276E-55    0.29860E-66    0.72737E-63
+    2    3    0.26880E-08    0.10000E+01    0.65036E+05    0.33821E-54    0.47121E-65    0.61226E-62
+    2    3    0.26880E-08    0.10000E+01    0.52449E+05    0.28540E-53    0.62229E-64    0.51792E-61
+    2    3    0.26880E-08    0.10000E+01    0.42297E+05    0.21171E-52    0.81894E-63    0.38608E-60
+    2    3    0.26880E-08    0.10000E+01    0.34111E+05    0.14863E-51    0.10649E-61    0.27371E-59
+    2    3    0.26880E-08    0.10000E+01    0.27509E+05    0.10185E-50    0.13209E-60    0.19091E-58
+    2    3    0.26880E-08    0.10000E+01    0.22184E+05    0.67368E-50    0.15802E-59    0.12959E-57
+    2    3    0.26880E-08    0.10000E+01    0.17891E+05    0.43249E-49    0.20343E-58    0.84214E-57
+    2    3    0.26880E-08    0.10000E+01    0.14428E+05    0.29078E-48    0.33959E-57    0.52185E-56
+    2    3    0.26880E-08    0.10000E+01    0.11635E+05    0.23897E-47    0.75410E-56    0.31719E-55
+    2    3    0.26880E-08    0.10000E+01    0.93834E+04    0.25887E-46    0.19254E-54    0.20693E-54
+    2    3    0.26880E-08    0.10000E+01    0.75673E+04    0.33429E-45    0.51007E-53    0.16812E-53
+    2    3    0.26880E-08    0.10000E+01    0.61026E+04    0.45924E-44    0.13576E-51    0.18028E-52
+    2    3    0.26880E-08    0.10000E+01    0.49215E+04    0.63965E-43    0.36145E-50    0.22751E-51
+    2    3    0.26880E-08    0.10000E+01    0.39689E+04    0.89316E-42    0.96412E-49    0.30098E-50
+    2    3    0.26880E-08    0.10000E+01    0.32008E+04    0.39300E-39    0.83409E-46    0.12593E-47
+    2    3    0.26880E-08    0.10000E+01    0.25813E+04    0.28710E-30    0.14016E-36    0.87170E-39
+    2    3    0.26880E-08    0.10000E+01    0.20817E+04    0.54692E-14    0.11932E-19    0.15676E-22
+    2    3    0.26880E-08    0.10000E+01    0.16788E+04    0.18526E-08    0.17652E-13    0.51335E-17
+    2    3    0.26880E-08    0.10000E+01    0.13538E+04    0.39771E-08    0.67049E-13    0.10825E-16
+    2    3    0.26880E-08    0.10000E+01    0.10918E+04    0.83514E-08    0.24994E-12    0.22451E-16
+    2    3    0.26880E-08    0.10000E+01    0.88049E+03    0.17163E-07    0.91991E-12    0.45734E-16
+    2    3    0.26880E-08    0.10000E+01    0.71007E+03    0.34591E-07    0.33486E-11    0.91578E-16
+    2    3    0.26880E-08    0.10000E+01    0.57264E+03    0.68540E-07    0.11910E-10    0.18058E-15
+    2    3    0.26880E-08    0.10000E+01    0.46180E+03    0.13360E-06    0.40051E-10    0.35072E-15
+    2    3    0.26880E-08    0.10000E+01    0.37242E+03    0.25492E-06    0.12211E-09    0.66745E-15
+    2    3    0.26880E-08    0.10000E+01    0.30034E+03    0.47074E-06    0.32749E-09    0.12302E-14
+    2    3    0.26880E-08    0.10000E+01    0.24221E+03    0.82920E-06    0.76462E-09    0.21642E-14
+    2    3    0.26880E-08    0.10000E+01    0.19533E+03    0.13067E-05    0.14530E-08    0.34077E-14
+    2    3    0.26880E-08    0.10000E+01    0.15752E+03    0.13067E-05    0.14530E-08    0.34077E-14
+    2    3    0.46905E-08    0.10000E+01    0.80645E+05    0.75448E-55    0.56108E-66    0.34389E-62
+    2    3    0.46905E-08    0.10000E+01    0.65036E+05    0.63515E-54    0.88744E-65    0.29027E-61
+    2    3    0.46905E-08    0.10000E+01    0.52449E+05    0.53730E-53    0.11790E-63    0.24616E-60
+    2    3    0.46905E-08    0.10000E+01    0.42297E+05    0.40052E-52    0.15694E-62    0.18434E-59
+    2    3    0.46905E-08    0.10000E+01    0.34111E+05    0.28392E-51    0.20837E-61    0.13180E-58
+    2    3    0.46905E-08    0.10000E+01    0.27509E+05    0.19804E-50    0.26776E-60    0.93250E-58
+    2    3    0.46905E-08    0.10000E+01    0.22184E+05    0.13483E-49    0.33247E-59    0.64829E-57
+    2    3    0.46905E-08    0.10000E+01    0.17891E+05    0.89241E-49    0.41598E-58    0.43728E-56
+    2    3    0.46905E-08    0.10000E+01    0.14428E+05    0.59048E-48    0.58115E-57    0.28414E-55
+    2    3    0.46905E-08    0.10000E+01    0.11635E+05    0.42298E-47    0.10089E-55    0.17819E-54
+    2    3    0.46905E-08    0.10000E+01    0.93834E+04    0.36470E-46    0.21863E-54    0.10933E-53
+    2    3    0.46905E-08    0.10000E+01    0.75673E+04    0.39306E-45    0.54181E-53    0.68784E-53
+    2    3    0.46905E-08    0.10000E+01    0.61026E+04    0.49539E-44    0.14153E-51    0.50072E-52
+    2    3    0.46905E-08    0.10000E+01    0.49215E+04    0.67007E-43    0.37478E-50    0.48087E-51
+    2    3    0.46905E-08    0.10000E+01    0.39689E+04    0.92699E-42    0.99496E-49    0.58096E-50
+    2    3    0.46905E-08    0.10000E+01    0.32008E+04    0.40559E-39    0.85548E-46    0.24022E-47
+    2    3    0.46905E-08    0.10000E+01    0.25813E+04    0.29432E-30    0.14263E-36    0.16506E-38
+    2    3    0.46905E-08    0.10000E+01    0.20817E+04    0.55598E-14    0.12026E-19    0.29071E-22
+    2    3    0.46905E-08    0.10000E+01    0.16788E+04    0.18734E-08    0.17719E-13    0.93485E-17
+    2    3    0.46905E-08    0.10000E+01    0.13538E+04    0.40103E-08    0.67252E-13    0.19302E-16
+    2    3    0.46905E-08    0.10000E+01    0.10918E+04    0.84045E-08    0.25057E-12    0.39465E-16
+    2    3    0.46905E-08    0.10000E+01    0.88049E+03    0.17248E-07    0.92190E-12    0.79584E-16
+    2    3    0.46905E-08    0.10000E+01    0.71007E+03    0.34728E-07    0.33551E-11    0.15818E-15
+    2    3    0.46905E-08    0.10000E+01    0.57264E+03    0.68762E-07    0.11932E-10    0.31018E-15
+    2    3    0.46905E-08    0.10000E+01    0.46180E+03    0.13396E-06    0.40119E-10    0.59990E-15
+    2    3    0.46905E-08    0.10000E+01    0.37242E+03    0.25552E-06    0.12231E-09    0.11381E-14
+    2    3    0.46905E-08    0.10000E+01    0.30034E+03    0.47173E-06    0.32801E-09    0.20930E-14
+    2    3    0.46905E-08    0.10000E+01    0.24221E+03    0.83082E-06    0.76583E-09    0.36764E-14
+    2    3    0.46905E-08    0.10000E+01    0.19533E+03    0.13091E-05    0.14553E-08    0.57833E-14
+    2    3    0.46905E-08    0.10000E+01    0.15752E+03    0.13091E-05    0.14553E-08    0.57833E-14
+    2    3    0.81846E-08    0.10000E+01    0.80645E+05    0.13502E-54    0.10054E-65    0.90958E-62
+    2    3    0.81846E-08    0.10000E+01    0.65036E+05    0.11379E-53    0.15917E-64    0.76843E-61
+    2    3    0.81846E-08    0.10000E+01    0.52449E+05    0.96353E-53    0.21194E-63    0.65215E-60
+    2    3    0.81846E-08    0.10000E+01    0.42297E+05    0.71958E-52    0.28327E-62    0.48907E-59
+    2    3    0.81846E-08    0.10000E+01    0.34111E+05    0.51187E-51    0.37862E-61    0.35056E-58
+    2    3    0.81846E-08    0.10000E+01    0.27509E+05    0.35909E-50    0.49133E-60    0.24908E-57
+    2    3    0.81846E-08    0.10000E+01    0.22184E+05    0.24650E-49    0.61438E-59    0.17438E-56
+    2    3    0.81846E-08    0.10000E+01    0.17891E+05    0.16413E-48    0.75421E-58    0.11896E-55
+    2    3    0.81846E-08    0.10000E+01    0.14428E+05    0.10714E-47    0.96669E-57    0.78569E-55
+    2    3    0.81846E-08    0.10000E+01    0.11635E+05    0.71738E-47    0.14258E-55    0.50229E-54
+    2    3    0.81846E-08    0.10000E+01    0.93834E+04    0.53617E-46    0.26168E-54    0.31193E-53
+    2    3    0.81846E-08    0.10000E+01    0.75673E+04    0.48874E-45    0.58799E-53    0.19137E-52
+    2    3    0.81846E-08    0.10000E+01    0.61026E+04    0.54954E-44    0.14792E-51    0.12467E-51
+    2    3    0.81846E-08    0.10000E+01    0.49215E+04    0.70645E-43    0.38692E-50    0.10078E-50
+    2    3    0.81846E-08    0.10000E+01    0.39689E+04    0.95944E-42    0.10203E-48    0.10924E-49
+    2    3    0.81846E-08    0.10000E+01    0.32008E+04    0.41618E-39    0.87126E-46    0.43990E-47
+    2    3    0.81846E-08    0.10000E+01    0.25813E+04    0.29969E-30    0.14408E-36    0.30180E-38
+    2    3    0.81846E-08    0.10000E+01    0.20817E+04    0.56134E-14    0.12024E-19    0.52957E-22
+    2    3    0.81846E-08    0.10000E+01    0.16788E+04    0.18817E-08    0.17638E-13    0.16895E-16
+    2    3    0.81846E-08    0.10000E+01    0.13538E+04    0.40136E-08    0.66884E-13    0.34361E-16
+    2    3    0.81846E-08    0.10000E+01    0.10918E+04    0.83913E-08    0.24903E-12    0.69549E-16
+    2    3    0.81846E-08    0.10000E+01    0.88049E+03    0.17193E-07    0.91574E-12    0.13926E-15
+    2    3    0.81846E-08    0.10000E+01    0.71007E+03    0.34573E-07    0.33314E-11    0.27535E-15
+    2    3    0.81846E-08    0.10000E+01    0.57264E+03    0.68394E-07    0.11844E-10    0.53786E-15
+    2    3    0.81846E-08    0.10000E+01    0.46180E+03    0.13315E-06    0.39817E-10    0.10372E-14
+    2    3    0.81846E-08    0.10000E+01    0.37242E+03    0.25386E-06    0.12138E-09    0.19635E-14
+    2    3    0.81846E-08    0.10000E+01    0.30034E+03    0.46849E-06    0.32549E-09    0.36052E-14
+    2    3    0.81846E-08    0.10000E+01    0.24221E+03    0.82490E-06    0.75992E-09    0.63257E-14
+    2    3    0.81846E-08    0.10000E+01    0.19533E+03    0.12996E-05    0.14440E-08    0.99442E-14
+    2    3    0.81846E-08    0.10000E+01    0.15752E+03    0.12996E-05    0.14440E-08    0.99442E-14
+    2    3    0.14282E-07    0.10000E+01    0.80645E+05    0.24007E-54    0.17900E-65    0.24507E-61
+    2    3    0.14282E-07    0.10000E+01    0.65036E+05    0.20253E-53    0.28362E-64    0.20720E-60
+    2    3    0.14282E-07    0.10000E+01    0.52449E+05    0.17166E-52    0.37850E-63    0.17596E-59
+    2    3    0.14282E-07    0.10000E+01    0.42297E+05    0.12843E-51    0.50787E-62    0.13212E-58
+    2    3    0.14282E-07    0.10000E+01    0.34111E+05    0.91666E-51    0.68318E-61    0.94913E-58
+    2    3    0.14282E-07    0.10000E+01    0.27509E+05    0.64667E-50    0.89556E-60    0.67683E-57
+    2    3    0.14282E-07    0.10000E+01    0.22184E+05    0.44774E-49    0.11334E-58    0.47669E-56
+    2    3    0.14282E-07    0.10000E+01    0.17891E+05    0.30118E-48    0.13944E-57    0.32832E-55
+    2    3    0.14282E-07    0.10000E+01    0.14428E+05    0.19722E-47    0.17234E-56    0.21997E-54
+    2    3    0.14282E-07    0.10000E+01    0.11635E+05    0.12862E-46    0.22762E-55    0.14325E-53
+    2    3    0.14282E-07    0.10000E+01    0.93834E+04    0.87901E-46    0.35106E-54    0.90616E-53
+    2    3    0.14282E-07    0.10000E+01    0.75673E+04    0.68402E-45    0.67726E-53    0.55695E-52
+    2    3    0.14282E-07    0.10000E+01    0.61026E+04    0.65582E-44    0.15790E-51    0.34230E-51
+    2    3    0.14282E-07    0.10000E+01    0.49215E+04    0.76781E-43    0.40319E-50    0.23657E-50
+    2    3    0.14282E-07    0.10000E+01    0.39689E+04    0.10059E-41    0.10551E-48    0.21797E-49
+    2    3    0.14282E-07    0.10000E+01    0.32008E+04    0.43098E-39    0.89493E-46    0.82429E-47
+    2    3    0.14282E-07    0.10000E+01    0.25813E+04    0.30778E-30    0.14656E-36    0.56192E-38
+    2    3    0.14282E-07    0.10000E+01    0.20817E+04    0.57089E-14    0.12058E-19    0.98697E-22
+    2    3    0.14282E-07    0.10000E+01    0.16788E+04    0.19009E-08    0.17569E-13    0.31218E-16
+    2    3    0.14282E-07    0.10000E+01    0.13538E+04    0.40317E-08    0.66529E-13    0.62119E-16
+    2    3    0.14282E-07    0.10000E+01    0.10918E+04    0.83976E-08    0.24744E-12    0.12389E-15
+    2    3    0.14282E-07    0.10000E+01    0.88049E+03    0.17161E-07    0.90916E-12    0.24550E-15
+    2    3    0.14282E-07    0.10000E+01    0.71007E+03    0.34445E-07    0.33055E-11    0.48177E-15
+    2    3    0.14282E-07    0.10000E+01    0.57264E+03    0.68045E-07    0.11747E-10    0.93571E-15
+    2    3    0.14282E-07    0.10000E+01    0.46180E+03    0.13233E-06    0.39482E-10    0.17967E-14
+    2    3    0.14282E-07    0.10000E+01    0.37242E+03    0.25210E-06    0.12033E-09    0.33905E-14
+    2    3    0.14282E-07    0.10000E+01    0.30034E+03    0.46500E-06    0.32267E-09    0.62114E-14
+    2    3    0.14282E-07    0.10000E+01    0.24221E+03    0.81845E-06    0.75328E-09    0.10881E-13
+    2    3    0.14282E-07    0.10000E+01    0.19533E+03    0.12891E-05    0.14314E-08    0.17089E-13
+    2    3    0.14282E-07    0.10000E+01    0.15752E+03    0.12891E-05    0.14314E-08    0.17089E-13
+    2    3    0.24920E-07    0.10000E+01    0.80645E+05    0.42524E-54    0.31746E-65    0.68076E-61
+    2    3    0.24920E-07    0.10000E+01    0.65036E+05    0.35911E-53    0.50341E-64    0.57593E-60
+    2    3    0.24920E-07    0.10000E+01    0.52449E+05    0.30465E-52    0.67317E-63    0.48938E-59
+    2    3    0.24920E-07    0.10000E+01    0.42297E+05    0.22831E-51    0.90645E-62    0.36784E-58
+    2    3    0.24920E-07    0.10000E+01    0.34111E+05    0.16344E-50    0.12263E-60    0.26473E-57
+    2    3    0.24920E-07    0.10000E+01    0.27509E+05    0.11588E-49    0.16224E-59    0.18935E-56
+    2    3    0.24920E-07    0.10000E+01    0.22184E+05    0.80870E-49    0.20798E-58    0.13402E-55
+    2    3    0.24920E-07    0.10000E+01    0.17891E+05    0.54994E-48    0.25873E-57    0.93037E-55
+    2    3    0.24920E-07    0.10000E+01    0.14428E+05    0.36377E-47    0.31768E-56    0.63073E-54
+    2    3    0.24920E-07    0.10000E+01    0.11635E+05    0.23655E-46    0.39724E-55    0.41735E-53
+    2    3    0.24920E-07    0.10000E+01    0.93834E+04    0.15513E-45    0.53622E-54    0.26898E-52
+    2    3    0.24920E-07    0.10000E+01    0.75673E+04    0.10800E-44    0.86216E-53    0.16770E-51
+    2    3    0.24920E-07    0.10000E+01    0.61026E+04    0.87310E-44    0.17589E-51    0.10134E-50
+    2    3    0.24920E-07    0.10000E+01    0.49215E+04    0.88327E-43    0.42623E-50    0.63099E-50
+    2    3    0.24920E-07    0.10000E+01    0.39689E+04    0.10779E-41    0.11013E-48    0.48346E-49
+    2    3    0.24920E-07    0.10000E+01    0.32008E+04    0.45161E-39    0.92860E-46    0.16270E-46
+    2    3    0.24920E-07    0.10000E+01    0.25813E+04    0.31955E-30    0.15049E-36    0.10848E-37
+    2    3    0.24920E-07    0.10000E+01    0.20817E+04    0.58681E-14    0.12143E-19    0.19145E-21
+    2    3    0.24920E-07    0.10000E+01    0.16788E+04    0.19377E-08    0.17516E-13    0.59919E-16
+    2    3    0.24920E-07    0.10000E+01    0.13538E+04    0.40728E-08    0.66184E-13    0.11545E-15
+    2    3    0.24920E-07    0.10000E+01    0.10918E+04    0.84335E-08    0.24575E-12    0.22517E-15
+    2    3    0.24920E-07    0.10000E+01    0.88049E+03    0.17164E-07    0.90183E-12    0.43916E-15
+    2    3    0.24920E-07    0.10000E+01    0.71007E+03    0.34351E-07    0.32759E-11    0.85175E-15
+    2    3    0.24920E-07    0.10000E+01    0.57264E+03    0.67714E-07    0.11635E-10    0.16398E-14
+    2    3    0.24920E-07    0.10000E+01    0.46180E+03    0.13148E-06    0.39088E-10    0.31277E-14
+    2    3    0.24920E-07    0.10000E+01    0.37242E+03    0.25018E-06    0.11911E-09    0.58732E-14
+    2    3    0.24920E-07    0.10000E+01    0.30034E+03    0.46106E-06    0.31933E-09    0.10722E-13
+    2    3    0.24920E-07    0.10000E+01    0.24221E+03    0.81105E-06    0.74543E-09    0.18737E-13
+    2    3    0.24920E-07    0.10000E+01    0.19533E+03    0.12770E-05    0.14164E-08    0.29382E-13
+    2    3    0.24920E-07    0.10000E+01    0.15752E+03    0.12770E-05    0.14164E-08    0.29382E-13
+    2    3    0.43485E-07    0.10000E+01    0.80645E+05    0.75178E-54    0.56183E-65    0.19551E-60
+    2    3    0.43485E-07    0.10000E+01    0.65036E+05    0.63542E-53    0.89155E-64    0.16549E-59
+    2    3    0.43485E-07    0.10000E+01    0.52449E+05    0.53948E-52    0.11943E-62    0.14069E-58
+    2    3    0.43485E-07    0.10000E+01    0.42297E+05    0.40487E-51    0.16130E-61    0.10583E-57
+    2    3    0.43485E-07    0.10000E+01    0.34111E+05    0.29057E-50    0.21927E-60    0.76282E-57
+    2    3    0.43485E-07    0.10000E+01    0.27509E+05    0.20690E-49    0.29239E-59    0.54694E-56
+    2    3    0.43485E-07    0.10000E+01    0.22184E+05    0.14538E-48    0.37923E-58    0.38864E-55
+    2    3    0.43485E-07    0.10000E+01    0.17891E+05    0.99857E-48    0.47815E-57    0.27149E-54
+    2    3    0.43485E-07    0.10000E+01    0.14428E+05    0.66837E-47    0.59135E-56    0.18577E-53
+    2    3    0.43485E-07    0.10000E+01    0.11635E+05    0.43801E-46    0.72704E-55    0.12450E-52
+    2    3    0.43485E-07    0.10000E+01    0.93834E+04    0.28413E-45    0.91124E-54    0.81538E-52
+    2    3    0.43485E-07    0.10000E+01    0.75673E+04    0.18667E-44    0.12507E-52    0.51727E-51
+    2    3    0.43485E-07    0.10000E+01    0.61026E+04    0.13188E-43    0.21238E-51    0.31447E-50
+    2    3    0.43485E-07    0.10000E+01    0.49215E+04    0.11169E-42    0.46380E-50    0.18665E-49
+    2    3    0.43485E-07    0.10000E+01    0.39689E+04    0.12048E-41    0.11643E-48    0.12269E-48
+    2    3    0.43485E-07    0.10000E+01    0.32008E+04    0.48213E-39    0.97568E-46    0.35080E-46
+    2    3    0.43485E-07    0.10000E+01    0.25813E+04    0.33683E-30    0.15647E-36    0.22221E-37
+    2    3    0.43485E-07    0.10000E+01    0.20817E+04    0.61299E-14    0.12303E-19    0.39466E-21
+    2    3    0.43485E-07    0.10000E+01    0.16788E+04    0.20036E-08    0.17477E-13    0.12187E-15
+    2    3    0.43485E-07    0.10000E+01    0.13538E+04    0.41506E-08    0.65816E-13    0.22442E-15
+    2    3    0.43485E-07    0.10000E+01    0.10918E+04    0.85139E-08    0.24376E-12    0.42348E-15
+    2    3    0.43485E-07    0.10000E+01    0.88049E+03    0.17217E-07    0.89281E-12    0.80609E-15
+    2    3    0.43485E-07    0.10000E+01    0.71007E+03    0.34297E-07    0.32386E-11    0.15352E-14
+    2    3    0.43485E-07    0.10000E+01    0.57264E+03    0.67378E-07    0.11491E-10    0.29147E-14
+    2    3    0.43485E-07    0.10000E+01    0.46180E+03    0.13050E-06    0.38583E-10    0.55007E-14
+    2    3    0.43485E-07    0.10000E+01    0.37242E+03    0.24785E-06    0.11752E-09    0.10247E-13
+    2    3    0.43485E-07    0.10000E+01    0.30034E+03    0.45618E-06    0.31502E-09    0.18600E-13
+    2    3    0.43485E-07    0.10000E+01    0.24221E+03    0.80173E-06    0.73527E-09    0.32375E-13
+    2    3    0.43485E-07    0.10000E+01    0.19533E+03    0.12616E-05    0.13970E-08    0.50644E-13
+    2    3    0.43485E-07    0.10000E+01    0.15752E+03    0.12616E-05    0.13970E-08    0.50644E-13
+    2    3    0.75878E-07    0.10000E+01    0.80645E+05    0.13278E-53    0.99318E-65    0.57762E-60
+    2    3    0.75878E-07    0.10000E+01    0.65036E+05    0.11231E-52    0.15769E-63    0.48914E-59
+    2    3    0.75878E-07    0.10000E+01    0.52449E+05    0.95411E-52    0.21155E-62    0.41598E-58
+    2    3    0.75878E-07    0.10000E+01    0.42297E+05    0.71688E-51    0.28642E-61    0.31314E-57
+    2    3    0.75878E-07    0.10000E+01    0.34111E+05    0.51560E-50    0.39088E-60    0.22596E-56
+    2    3    0.75878E-07    0.10000E+01    0.27509E+05    0.36839E-49    0.52458E-59    0.16233E-55
+    2    3    0.75878E-07    0.10000E+01    0.22184E+05    0.26031E-48    0.68707E-58    0.11570E-54
+    2    3    0.75878E-07    0.10000E+01    0.17891E+05    0.18031E-47    0.87729E-57    0.81214E-54
+    2    3    0.75878E-07    0.10000E+01    0.14428E+05    0.12203E-46    0.10978E-55    0.55968E-53
+    2    3    0.75878E-07    0.10000E+01    0.11635E+05    0.80851E-46    0.13525E-54    0.37874E-52
+    2    3    0.75878E-07    0.10000E+01    0.93834E+04    0.52650E-45    0.16480E-53    0.25122E-51
+    2    3    0.75878E-07    0.10000E+01    0.75673E+04    0.33895E-44    0.20497E-52    0.16191E-50
+    2    3    0.75878E-07    0.10000E+01    0.61026E+04    0.22147E-43    0.28960E-51    0.99868E-50
+    2    3    0.75878E-07    0.10000E+01    0.49215E+04    0.15992E-42    0.53580E-50    0.58667E-49
+    2    3    0.75878E-07    0.10000E+01    0.39689E+04    0.14538E-41    0.12609E-48    0.35128E-48
+    2    3    0.75878E-07    0.10000E+01    0.32008E+04    0.53313E-39    0.10447E-45    0.84807E-46
+    2    3    0.75878E-07    0.10000E+01    0.25813E+04    0.36403E-30    0.16589E-36    0.49340E-37
+    2    3    0.75878E-07    0.10000E+01    0.20817E+04    0.65787E-14    0.12603E-19    0.87990E-21
+    2    3    0.75878E-07    0.10000E+01    0.16788E+04    0.21232E-08    0.17491E-13    0.26749E-15
+    2    3    0.75878E-07    0.10000E+01    0.13538E+04    0.42981E-08    0.65521E-13    0.46503E-15
+    2    3    0.75878E-07    0.10000E+01    0.10918E+04    0.86840E-08    0.24169E-12    0.83882E-15
+    2    3    0.75878E-07    0.10000E+01    0.88049E+03    0.17380E-07    0.88253E-12    0.15419E-14
+    2    3    0.75878E-07    0.10000E+01    0.71007E+03    0.34367E-07    0.31943E-11    0.28575E-14
+    2    3    0.75878E-07    0.10000E+01    0.57264E+03    0.67149E-07    0.11317E-10    0.53105E-14
+    2    3    0.75878E-07    0.10000E+01    0.46180E+03    0.12953E-06    0.37961E-10    0.98561E-14
+    2    3    0.75878E-07    0.10000E+01    0.37242E+03    0.24529E-06    0.11556E-09    0.18129E-13
+    2    3    0.75878E-07    0.10000E+01    0.30034E+03    0.45051E-06    0.30965E-09    0.32601E-13
+    2    3    0.75878E-07    0.10000E+01    0.24221E+03    0.79063E-06    0.72260E-09    0.56376E-13
+    2    3    0.75878E-07    0.10000E+01    0.19533E+03    0.12431E-05    0.13727E-08    0.87831E-13
+    2    3    0.75878E-07    0.10000E+01    0.15752E+03    0.12431E-05    0.13727E-08    0.87831E-13
+    2    3    0.13240E-06    0.10000E+01    0.80645E+05    0.23435E-53    0.17542E-64    0.17333E-59
+    2    3    0.13240E-06    0.10000E+01    0.65036E+05    0.19834E-52    0.27866E-63    0.14683E-58
+    2    3    0.13240E-06    0.10000E+01    0.52449E+05    0.16858E-51    0.37425E-62    0.12490E-57
+    2    3    0.13240E-06    0.10000E+01    0.42297E+05    0.12679E-50    0.50769E-61    0.94072E-57
+    2    3    0.13240E-06    0.10000E+01    0.34111E+05    0.91341E-50    0.69497E-60    0.67946E-56
+    2    3    0.13240E-06    0.10000E+01    0.27509E+05    0.65440E-49    0.93736E-59    0.48882E-55
+    2    3    0.13240E-06    0.10000E+01    0.22184E+05    0.46443E-48    0.12373E-57    0.34923E-54
+    2    3    0.13240E-06    0.10000E+01    0.17891E+05    0.32387E-47    0.15965E-56    0.24604E-53
+    2    3    0.13240E-06    0.10000E+01    0.14428E+05    0.22120E-46    0.20213E-55    0.17046E-52
+    2    3    0.13240E-06    0.10000E+01    0.11635E+05    0.14813E-45    0.25126E-54    0.11619E-51
+    2    3    0.13240E-06    0.10000E+01    0.93834E+04    0.97332E-45    0.30515E-53    0.77810E-51
+    2    3    0.13240E-06    0.10000E+01    0.75673E+04    0.62614E-44    0.36354E-52    0.50788E-50
+    2    3    0.13240E-06    0.10000E+01    0.61026E+04    0.39609E-43    0.45057E-51    0.31809E-49
+    2    3    0.13240E-06    0.10000E+01    0.49215E+04    0.25765E-42    0.68574E-50    0.18822E-48
+    2    3    0.13240E-06    0.10000E+01    0.39689E+04    0.19637E-41    0.14341E-48    0.10809E-47
+    2    3    0.13240E-06    0.10000E+01    0.32008E+04    0.62894E-39    0.11567E-45    0.22832E-45
+    2    3    0.13240E-06    0.10000E+01    0.25813E+04    0.41136E-30    0.18186E-36    0.11952E-36
+    2    3    0.13240E-06    0.10000E+01    0.20817E+04    0.73980E-14    0.13219E-19    0.21278E-20
+    2    3    0.13240E-06    0.10000E+01    0.16788E+04    0.23508E-08    0.17718E-13    0.63675E-15
+    2    3    0.13240E-06    0.10000E+01    0.13538E+04    0.45955E-08    0.65826E-13    0.10397E-14
+    2    3    0.13240E-06    0.10000E+01    0.10918E+04    0.90689E-08    0.24126E-12    0.17770E-14
+    2    3    0.13240E-06    0.10000E+01    0.88049E+03    0.17856E-07    0.87675E-12    0.31229E-14
+    2    3    0.13240E-06    0.10000E+01    0.71007E+03    0.34896E-07    0.31623E-11    0.55768E-14
+    2    3    0.13240E-06    0.10000E+01    0.57264E+03    0.67594E-07    0.11177E-10    0.10052E-13
+    2    3    0.13240E-06    0.10000E+01    0.46180E+03    0.12955E-06    0.37433E-10    0.18200E-13
+    2    3    0.13240E-06    0.10000E+01    0.37242E+03    0.24417E-06    0.11385E-09    0.32830E-13
+    2    3    0.13240E-06    0.10000E+01    0.30034E+03    0.44695E-06    0.30490E-09    0.58183E-13
+    2    3    0.13240E-06    0.10000E+01    0.24221E+03    0.78256E-06    0.71126E-09    0.99570E-13
+    2    3    0.13240E-06    0.10000E+01    0.19533E+03    0.12286E-05    0.13509E-08    0.15411E-12
+    2    3    0.13240E-06    0.10000E+01    0.15752E+03    0.12286E-05    0.13509E-08    0.15411E-12
+    2    3    0.23103E-06    0.10000E+01    0.80645E+05    0.41344E-53    0.30965E-64    0.52620E-59
+    2    3    0.23103E-06    0.10000E+01    0.65036E+05    0.35006E-52    0.49206E-63    0.44585E-58
+    2    3    0.23103E-06    0.10000E+01    0.52449E+05    0.29767E-51    0.66144E-62    0.37936E-57
+    2    3    0.23103E-06    0.10000E+01    0.42297E+05    0.22403E-50    0.89865E-61    0.28583E-56
+    2    3    0.23103E-06    0.10000E+01    0.34111E+05    0.16161E-49    0.12331E-59    0.20660E-55
+    2    3    0.23103E-06    0.10000E+01    0.27509E+05    0.11603E-48    0.16696E-58    0.14880E-54
+    2    3    0.23103E-06    0.10000E+01    0.22184E+05    0.82625E-48    0.22171E-57    0.10650E-53
+    2    3    0.23103E-06    0.10000E+01    0.17891E+05    0.57920E-47    0.28849E-56    0.75242E-53
+    2    3    0.23103E-06    0.10000E+01    0.14428E+05    0.39850E-46    0.36891E-55    0.52343E-52
+    2    3    0.23103E-06    0.10000E+01    0.11635E+05    0.26929E-45    0.46330E-54    0.35873E-51
+    2    3    0.23103E-06    0.10000E+01    0.93834E+04    0.17865E-44    0.56647E-53    0.24197E-50
+    2    3    0.23103E-06    0.10000E+01    0.75673E+04    0.11573E-43    0.66780E-52    0.15949E-49
+    2    3    0.23103E-06    0.10000E+01    0.61026E+04    0.72709E-43    0.77277E-51    0.10122E-48
+    2    3    0.23103E-06    0.10000E+01    0.49215E+04    0.44912E-42    0.99263E-50    0.60665E-48
+    2    3    0.23103E-06    0.10000E+01    0.39689E+04    0.29842E-41    0.17556E-48    0.34434E-47
+    2    3    0.23103E-06    0.10000E+01    0.32008E+04    0.81093E-39    0.13386E-45    0.66647E-45
+    2    3    0.23103E-06    0.10000E+01    0.25813E+04    0.49366E-30    0.20789E-36    0.31396E-36
+    2    3    0.23103E-06    0.10000E+01    0.20817E+04    0.88418E-14    0.14307E-19    0.55415E-20
+    2    3    0.23103E-06    0.10000E+01    0.16788E+04    0.27585E-08    0.18222E-13    0.16358E-14
+    2    3    0.23103E-06    0.10000E+01    0.13538E+04    0.51337E-08    0.66830E-13    0.25172E-14
+    2    3    0.23103E-06    0.10000E+01    0.10918E+04    0.97835E-08    0.24247E-12    0.40676E-14
+    2    3    0.23103E-06    0.10000E+01    0.88049E+03    0.18786E-07    0.87435E-12    0.67943E-14
+    2    3    0.23103E-06    0.10000E+01    0.71007E+03    0.36045E-07    0.31358E-11    0.11597E-13
+    2    3    0.23103E-06    0.10000E+01    0.57264E+03    0.68865E-07    0.11040E-10    0.20089E-13
+    2    3    0.23103E-06    0.10000E+01    0.46180E+03    0.13063E-06    0.36883E-10    0.35152E-13
+    2    3    0.23103E-06    0.10000E+01    0.37242E+03    0.24432E-06    0.11201E-09    0.61653E-13
+    2    3    0.23103E-06    0.10000E+01    0.30034E+03    0.44479E-06    0.29970E-09    0.10690E-12
+    2    3    0.23103E-06    0.10000E+01    0.24221E+03    0.77583E-06    0.69876E-09    0.18001E-12
+    2    3    0.23103E-06    0.10000E+01    0.19533E+03    0.12152E-05    0.13268E-08    0.27575E-12
+    2    3    0.23103E-06    0.10000E+01    0.15752E+03    0.12152E-05    0.13268E-08    0.27575E-12
+    2    3    0.40314E-06    0.10000E+01    0.80645E+05    0.72837E-53    0.54577E-64    0.15927E-58
+    2    3    0.40314E-06    0.10000E+01    0.65036E+05    0.61695E-52    0.86752E-63    0.13498E-57
+    2    3    0.40314E-06    0.10000E+01    0.52449E+05    0.52478E-51    0.11670E-61    0.11487E-56
+    2    3    0.40314E-06    0.10000E+01    0.42297E+05    0.39518E-50    0.15873E-60    0.86577E-56
+    2    3    0.40314E-06    0.10000E+01    0.34111E+05    0.28536E-49    0.21820E-59    0.62612E-55
+    2    3    0.40314E-06    0.10000E+01    0.27509E+05    0.20521E-48    0.29631E-58    0.45135E-54
+    2    3    0.40314E-06    0.10000E+01    0.22184E+05    0.14651E-47    0.39530E-57    0.32349E-53
+    2    3    0.40314E-06    0.10000E+01    0.17891E+05    0.10312E-46    0.51772E-56    0.22904E-52
+    2    3    0.40314E-06    0.10000E+01    0.14428E+05    0.71351E-46    0.66738E-55    0.15982E-51
+    2    3    0.40314E-06    0.10000E+01    0.11635E+05    0.48567E-45    0.84589E-54    0.10999E-50
+    2    3    0.40314E-06    0.10000E+01    0.93834E+04    0.32496E-44    0.10440E-52    0.74587E-50
+    2    3    0.40314E-06    0.10000E+01    0.75673E+04    0.21236E-43    0.12359E-51    0.49525E-49
+    2    3    0.40314E-06    0.10000E+01    0.61026E+04    0.13401E-42    0.13950E-50    0.31761E-48
+    2    3    0.40314E-06    0.10000E+01    0.49215E+04    0.81320E-42    0.16039E-49    0.19278E-47
+    2    3    0.40314E-06    0.10000E+01    0.39689E+04    0.49740E-41    0.23670E-48    0.10965E-46
+    2    3    0.40314E-06    0.10000E+01    0.32008E+04    0.11581E-38    0.16439E-45    0.20198E-44
+    2    3    0.40314E-06    0.10000E+01    0.25813E+04    0.63942E-30    0.25069E-36    0.87072E-36
+    2    3    0.40314E-06    0.10000E+01    0.20817E+04    0.11387E-13    0.16202E-19    0.15162E-19
+    2    3    0.40314E-06    0.10000E+01    0.16788E+04    0.34832E-08    0.19225E-13    0.44294E-14
+    2    3    0.40314E-06    0.10000E+01    0.13538E+04    0.60953E-08    0.69144E-13    0.64936E-14
+    2    3    0.40314E-06    0.10000E+01    0.10918E+04    0.11079E-07    0.24693E-12    0.99823E-14
+    2    3    0.40314E-06    0.10000E+01    0.88049E+03    0.20525E-07    0.87957E-12    0.15876E-13
+    2    3    0.40314E-06    0.10000E+01    0.71007E+03    0.38317E-07    0.31259E-11    0.25845E-13
+    2    3    0.40314E-06    0.10000E+01    0.57264E+03    0.71676E-07    0.10936E-10    0.42809E-13
+    2    3    0.40314E-06    0.10000E+01    0.46180E+03    0.13377E-06    0.36384E-10    0.71868E-13
+    2    3    0.40314E-06    0.10000E+01    0.37242E+03    0.24717E-06    0.11022E-09    0.12154E-12
+    2    3    0.40314E-06    0.10000E+01    0.30034E+03    0.44600E-06    0.29447E-09    0.20451E-12
+    2    3    0.40314E-06    0.10000E+01    0.24221E+03    0.77316E-06    0.68595E-09    0.33654E-12
+    2    3    0.40314E-06    0.10000E+01    0.19533E+03    0.12064E-05    0.13018E-08    0.50771E-12
+    2    3    0.40314E-06    0.10000E+01    0.15752E+03    0.12064E-05    0.13018E-08    0.50771E-12
+    2    3    0.70346E-06    0.10000E+01    0.80645E+05    0.12737E-52    0.95452E-64    0.33594E-58
+    2    3    0.70346E-06    0.10000E+01    0.65036E+05    0.10790E-51    0.15174E-62    0.28472E-57
+    2    3    0.70346E-06    0.10000E+01    0.52449E+05    0.91786E-51    0.20415E-61    0.24231E-56
+    2    3    0.70346E-06    0.10000E+01    0.42297E+05    0.69131E-50    0.27779E-60    0.18264E-55
+    2    3    0.70346E-06    0.10000E+01    0.34111E+05    0.49934E-49    0.38207E-59    0.13211E-54
+    2    3    0.70346E-06    0.10000E+01    0.27509E+05    0.35927E-48    0.51930E-58    0.95256E-54
+    2    3    0.70346E-06    0.10000E+01    0.22184E+05    0.25670E-47    0.69373E-57    0.68299E-53
+    2    3    0.70346E-06    0.10000E+01    0.17891E+05    0.18089E-46    0.91031E-56    0.48387E-52
+    2    3    0.70346E-06    0.10000E+01    0.14428E+05    0.12537E-45    0.11763E-54    0.33794E-51
+    2    3    0.70346E-06    0.10000E+01    0.11635E+05    0.85527E-45    0.14953E-53    0.23284E-50
+    2    3    0.70346E-06    0.10000E+01    0.93834E+04    0.57378E-44    0.18517E-52    0.15814E-49
+    2    3    0.70346E-06    0.10000E+01    0.75673E+04    0.37610E-43    0.21986E-51    0.10522E-48
+    2    3    0.70346E-06    0.10000E+01    0.61026E+04    0.23799E-42    0.24750E-50    0.67683E-48
+    2    3    0.70346E-06    0.10000E+01    0.49215E+04    0.14418E-41    0.27741E-49    0.41247E-47
+    2    3    0.70346E-06    0.10000E+01    0.39689E+04    0.86590E-41    0.38578E-48    0.23510E-46
+    2    3    0.70346E-06    0.10000E+01    0.32008E+04    0.19241E-38    0.25705E-45    0.42826E-44
+    2    3    0.70346E-06    0.10000E+01    0.25813E+04    0.10223E-29    0.38862E-36    0.17991E-35
+    2    3    0.70346E-06    0.10000E+01    0.20817E+04    0.18155E-13    0.24535E-19    0.31163E-19
+    2    3    0.70346E-06    0.10000E+01    0.16788E+04    0.55148E-08    0.28243E-13    0.90781E-14
+    2    3    0.70346E-06    0.10000E+01    0.13538E+04    0.94238E-08    0.10067E-12    0.13124E-13
+    2    3    0.70346E-06    0.10000E+01    0.10918E+04    0.16798E-07    0.35687E-12    0.19875E-13
+    2    3    0.70346E-06    0.10000E+01    0.88049E+03    0.30640E-07    0.12637E-11    0.31121E-13
+    2    3    0.70346E-06    0.10000E+01    0.71007E+03    0.56503E-07    0.44711E-11    0.49873E-13
+    2    3    0.70346E-06    0.10000E+01    0.57264E+03    0.10467E-06    0.15592E-10    0.81314E-13
+    2    3    0.70346E-06    0.10000E+01    0.46180E+03    0.19386E-06    0.51772E-10    0.13443E-12
+    2    3    0.70346E-06    0.10000E+01    0.37242E+03    0.35609E-06    0.15663E-09    0.22413E-12
+    2    3    0.70346E-06    0.10000E+01    0.30034E+03    0.63978E-06    0.41817E-09    0.37256E-12
+    2    3    0.70346E-06    0.10000E+01    0.24221E+03    0.11057E-05    0.97367E-09    0.60712E-12
+    2    3    0.70346E-06    0.10000E+01    0.19533E+03    0.17221E-05    0.18474E-08    0.90985E-12
+    2    3    0.70346E-06    0.10000E+01    0.15752E+03    0.17221E-05    0.18474E-08    0.90985E-12
+    2    3    0.12275E-05    0.10000E+01    0.80645E+05    0.22225E-52    0.16656E-63    0.58619E-58
+    2    3    0.12275E-05    0.10000E+01    0.65036E+05    0.18827E-51    0.26477E-62    0.49681E-57
+    2    3    0.12275E-05    0.10000E+01    0.52449E+05    0.16016E-50    0.35624E-61    0.42281E-56
+    2    3    0.12275E-05    0.10000E+01    0.42297E+05    0.12063E-49    0.48473E-60    0.31870E-55
+    2    3    0.12275E-05    0.10000E+01    0.34111E+05    0.87132E-49    0.66669E-59    0.23052E-54
+    2    3    0.12275E-05    0.10000E+01    0.27509E+05    0.62690E-48    0.90615E-58    0.16622E-53
+    2    3    0.12275E-05    0.10000E+01    0.22184E+05    0.44792E-47    0.12105E-56    0.11918E-52
+    2    3    0.12275E-05    0.10000E+01    0.17891E+05    0.31563E-46    0.15884E-55    0.84432E-52
+    2    3    0.12275E-05    0.10000E+01    0.14428E+05    0.21877E-45    0.20526E-54    0.58969E-51
+    2    3    0.12275E-05    0.10000E+01    0.11635E+05    0.14924E-44    0.26092E-53    0.40629E-50
+    2    3    0.12275E-05    0.10000E+01    0.93834E+04    0.10012E-43    0.32312E-52    0.27594E-49
+    2    3    0.12275E-05    0.10000E+01    0.75673E+04    0.65628E-43    0.38364E-51    0.18361E-48
+    2    3    0.12275E-05    0.10000E+01    0.61026E+04    0.41528E-42    0.43187E-50    0.11810E-47
+    2    3    0.12275E-05    0.10000E+01    0.49215E+04    0.25159E-41    0.48406E-49    0.71973E-47
+    2    3    0.12275E-05    0.10000E+01    0.39689E+04    0.15109E-40    0.67316E-48    0.41023E-46
+    2    3    0.12275E-05    0.10000E+01    0.32008E+04    0.33574E-38    0.44853E-45    0.74728E-44
+    2    3    0.12275E-05    0.10000E+01    0.25813E+04    0.17839E-29    0.67812E-36    0.31394E-35
+    2    3    0.12275E-05    0.10000E+01    0.20817E+04    0.31680E-13    0.42813E-19    0.54378E-19
+    2    3    0.12275E-05    0.10000E+01    0.16788E+04    0.96230E-08    0.49283E-13    0.15841E-13
+    2    3    0.12275E-05    0.10000E+01    0.13538E+04    0.16444E-07    0.17567E-12    0.22901E-13
+    2    3    0.12275E-05    0.10000E+01    0.10918E+04    0.29312E-07    0.62272E-12    0.34681E-13
+    2    3    0.12275E-05    0.10000E+01    0.88049E+03    0.53466E-07    0.22050E-11    0.54305E-13
+    2    3    0.12275E-05    0.10000E+01    0.71007E+03    0.98595E-07    0.78018E-11    0.87026E-13
+    2    3    0.12275E-05    0.10000E+01    0.57264E+03    0.18264E-06    0.27208E-10    0.14189E-12
+    2    3    0.12275E-05    0.10000E+01    0.46180E+03    0.33827E-06    0.90339E-10    0.23457E-12
+    2    3    0.12275E-05    0.10000E+01    0.37242E+03    0.62135E-06    0.27332E-09    0.39110E-12
+    2    3    0.12275E-05    0.10000E+01    0.30034E+03    0.11164E-05    0.72968E-09    0.65009E-12
+    2    3    0.12275E-05    0.10000E+01    0.24221E+03    0.19294E-05    0.16990E-08    0.10594E-11
+    2    3    0.12275E-05    0.10000E+01    0.19533E+03    0.30050E-05    0.32235E-08    0.15876E-11
+    2    3    0.12275E-05    0.10000E+01    0.15752E+03    0.30050E-05    0.32235E-08    0.15876E-11
+    2    3    0.21419E-05    0.10000E+01    0.80645E+05    0.38782E-52    0.29063E-63    0.10229E-57
+    2    3    0.21419E-05    0.10000E+01    0.65036E+05    0.32853E-51    0.46201E-62    0.86691E-57
+    2    3    0.21419E-05    0.10000E+01    0.52449E+05    0.27947E-50    0.62161E-61    0.73778E-56
+    2    3    0.21419E-05    0.10000E+01    0.42297E+05    0.21049E-49    0.84582E-60    0.55611E-55
+    2    3    0.21419E-05    0.10000E+01    0.34111E+05    0.15204E-48    0.11633E-58    0.40224E-54
+    2    3    0.21419E-05    0.10000E+01    0.27509E+05    0.10939E-47    0.15812E-57    0.29004E-53
+    2    3    0.21419E-05    0.10000E+01    0.22184E+05    0.78160E-47    0.21123E-56    0.20796E-52
+    2    3    0.21419E-05    0.10000E+01    0.17891E+05    0.55076E-46    0.27717E-55    0.14733E-51
+    2    3    0.21419E-05    0.10000E+01    0.14428E+05    0.38174E-45    0.35817E-54    0.10290E-50
+    2    3    0.21419E-05    0.10000E+01    0.11635E+05    0.26041E-44    0.45529E-53    0.70894E-50
+    2    3    0.21419E-05    0.10000E+01    0.93834E+04    0.17471E-43    0.56382E-52    0.48150E-49
+    2    3    0.21419E-05    0.10000E+01    0.75673E+04    0.11452E-42    0.66942E-51    0.32038E-48
+    2    3    0.21419E-05    0.10000E+01    0.61026E+04    0.72464E-42    0.75360E-50    0.20608E-47
+    2    3    0.21419E-05    0.10000E+01    0.49215E+04    0.43901E-41    0.84465E-49    0.12559E-46
+    2    3    0.21419E-05    0.10000E+01    0.39689E+04    0.26365E-40    0.11746E-47    0.71583E-46
+    2    3    0.21419E-05    0.10000E+01    0.32008E+04    0.58585E-38    0.78266E-45    0.13040E-43
+    2    3    0.21419E-05    0.10000E+01    0.25813E+04    0.31128E-29    0.11833E-35    0.54780E-35
+    2    3    0.21419E-05    0.10000E+01    0.20817E+04    0.55280E-13    0.74706E-19    0.94886E-19
+    2    3    0.21419E-05    0.10000E+01    0.16788E+04    0.16792E-07    0.85996E-13    0.27641E-13
+    2    3    0.21419E-05    0.10000E+01    0.13538E+04    0.28694E-07    0.30653E-12    0.39962E-13
+    2    3    0.21419E-05    0.10000E+01    0.10918E+04    0.51148E-07    0.10866E-11    0.60515E-13
+    2    3    0.21419E-05    0.10000E+01    0.88049E+03    0.93294E-07    0.38477E-11    0.94759E-13
+    2    3    0.21419E-05    0.10000E+01    0.71007E+03    0.17204E-06    0.13614E-10    0.15185E-12
+    2    3    0.21419E-05    0.10000E+01    0.57264E+03    0.31870E-06    0.47476E-10    0.24759E-12
+    2    3    0.21419E-05    0.10000E+01    0.46180E+03    0.59026E-06    0.15764E-09    0.40931E-12
+    2    3    0.21419E-05    0.10000E+01    0.37242E+03    0.10842E-05    0.47692E-09    0.68244E-12
+    2    3    0.21419E-05    0.10000E+01    0.30034E+03    0.19480E-05    0.12733E-08    0.11344E-11
+    2    3    0.21419E-05    0.10000E+01    0.24221E+03    0.33667E-05    0.29647E-08    0.18486E-11
+    2    3    0.21419E-05    0.10000E+01    0.19533E+03    0.52435E-05    0.56249E-08    0.27703E-11
+    2    3    0.21419E-05    0.10000E+01    0.15752E+03    0.52435E-05    0.56249E-08    0.27703E-11
+    2    3    0.37375E-05    0.10000E+01    0.80645E+05    0.67672E-52    0.50714E-63    0.17848E-57
+    2    3    0.37375E-05    0.10000E+01    0.65036E+05    0.57326E-51    0.80618E-62    0.15127E-56
+    2    3    0.37375E-05    0.10000E+01    0.52449E+05    0.48766E-50    0.10847E-60    0.12874E-55
+    2    3    0.37375E-05    0.10000E+01    0.42297E+05    0.36730E-49    0.14759E-59    0.97039E-55
+    2    3    0.37375E-05    0.10000E+01    0.34111E+05    0.26530E-48    0.20300E-58    0.70188E-54
+    2    3    0.37375E-05    0.10000E+01    0.27509E+05    0.19088E-47    0.27590E-57    0.50610E-53
+    2    3    0.37375E-05    0.10000E+01    0.22184E+05    0.13638E-46    0.36858E-56    0.36287E-52
+    2    3    0.37375E-05    0.10000E+01    0.17891E+05    0.96105E-46    0.48365E-55    0.25708E-51
+    2    3    0.37375E-05    0.10000E+01    0.14428E+05    0.66612E-45    0.62498E-54    0.17955E-50
+    2    3    0.37375E-05    0.10000E+01    0.11635E+05    0.45441E-44    0.79445E-53    0.12371E-49
+    2    3    0.37375E-05    0.10000E+01    0.93834E+04    0.30485E-43    0.98384E-52    0.84019E-49
+    2    3    0.37375E-05    0.10000E+01    0.75673E+04    0.19982E-42    0.11681E-50    0.55905E-48
+    2    3    0.37375E-05    0.10000E+01    0.61026E+04    0.12645E-41    0.13150E-49    0.35960E-47
+    2    3    0.37375E-05    0.10000E+01    0.49215E+04    0.76604E-41    0.14739E-48    0.21914E-46
+    2    3    0.37375E-05    0.10000E+01    0.39689E+04    0.46005E-40    0.20497E-47    0.12491E-45
+    2    3    0.37375E-05    0.10000E+01    0.32008E+04    0.10223E-37    0.13657E-44    0.22753E-43
+    2    3    0.37375E-05    0.10000E+01    0.25813E+04    0.54317E-29    0.20647E-35    0.95588E-35
+    2    3    0.37375E-05    0.10000E+01    0.20817E+04    0.96460E-13    0.13036E-18    0.16557E-18
+    2    3    0.37375E-05    0.10000E+01    0.16788E+04    0.29300E-07    0.15006E-12    0.48232E-13
+    2    3    0.37375E-05    0.10000E+01    0.13538E+04    0.50069E-07    0.53488E-12    0.69730E-13
+    2    3    0.37375E-05    0.10000E+01    0.10918E+04    0.89249E-07    0.18961E-11    0.10560E-12
+    2    3    0.37375E-05    0.10000E+01    0.88049E+03    0.16279E-06    0.67139E-11    0.16535E-12
+    2    3    0.37375E-05    0.10000E+01    0.71007E+03    0.30020E-06    0.23755E-10    0.26498E-12
+    2    3    0.37375E-05    0.10000E+01    0.57264E+03    0.55611E-06    0.82843E-10    0.43202E-12
+    2    3    0.37375E-05    0.10000E+01    0.46180E+03    0.10300E-05    0.27507E-09    0.71422E-12
+    2    3    0.37375E-05    0.10000E+01    0.37242E+03    0.18919E-05    0.83219E-09    0.11908E-11
+    2    3    0.37375E-05    0.10000E+01    0.30034E+03    0.33992E-05    0.22218E-08    0.19794E-11
+    2    3    0.37375E-05    0.10000E+01    0.24221E+03    0.58747E-05    0.51731E-08    0.32256E-11
+    2    3    0.37375E-05    0.10000E+01    0.19533E+03    0.91495E-05    0.98151E-08    0.48340E-11
+    2    3    0.37375E-05    0.10000E+01    0.15752E+03    0.91495E-05    0.98151E-08    0.48340E-11
+    2    3    0.65217E-05    0.10000E+01    0.80645E+05    0.11808E-51    0.88493E-63    0.31145E-57
+    2    3    0.65217E-05    0.10000E+01    0.65036E+05    0.10003E-50    0.14067E-61    0.26396E-56
+    2    3    0.65217E-05    0.10000E+01    0.52449E+05    0.85094E-50    0.18927E-60    0.22464E-55
+    2    3    0.65217E-05    0.10000E+01    0.42297E+05    0.64091E-49    0.25754E-59    0.16933E-54
+    2    3    0.65217E-05    0.10000E+01    0.34111E+05    0.46294E-48    0.35421E-58    0.12247E-53
+    2    3    0.65217E-05    0.10000E+01    0.27509E+05    0.33307E-47    0.48144E-57    0.88311E-53
+    2    3    0.65217E-05    0.10000E+01    0.22184E+05    0.23798E-46    0.64315E-56    0.63319E-52
+    2    3    0.65217E-05    0.10000E+01    0.17891E+05    0.16770E-45    0.84394E-55    0.44859E-51
+    2    3    0.65217E-05    0.10000E+01    0.14428E+05    0.11623E-44    0.10906E-53    0.31330E-50
+    2    3    0.65217E-05    0.10000E+01    0.11635E+05    0.79291E-44    0.13863E-52    0.21586E-49
+    2    3    0.65217E-05    0.10000E+01    0.93834E+04    0.53195E-43    0.17167E-51    0.14661E-48
+    2    3    0.65217E-05    0.10000E+01    0.75673E+04    0.34868E-42    0.20383E-50    0.97551E-48
+    2    3    0.65217E-05    0.10000E+01    0.61026E+04    0.22064E-41    0.22946E-49    0.62748E-47
+    2    3    0.65217E-05    0.10000E+01    0.49215E+04    0.13367E-40    0.25718E-48    0.38239E-46
+    2    3    0.65217E-05    0.10000E+01    0.39689E+04    0.80277E-40    0.35765E-47    0.21796E-45
+    2    3    0.65217E-05    0.10000E+01    0.32008E+04    0.17838E-37    0.23831E-44    0.39703E-43
+    2    3    0.65217E-05    0.10000E+01    0.25813E+04    0.94780E-29    0.36029E-35    0.16679E-34
+    2    3    0.65217E-05    0.10000E+01    0.20817E+04    0.16832E-12    0.22746E-18    0.28891E-18
+    2    3    0.65217E-05    0.10000E+01    0.16788E+04    0.51127E-07    0.26184E-12    0.84162E-13
+    2    3    0.65217E-05    0.10000E+01    0.13538E+04    0.87367E-07    0.93334E-12    0.12168E-12
+    2    3    0.65217E-05    0.10000E+01    0.10918E+04    0.15573E-06    0.33085E-11    0.18426E-12
+    2    3    0.65217E-05    0.10000E+01    0.88049E+03    0.28406E-06    0.11715E-10    0.28852E-12
+    2    3    0.65217E-05    0.10000E+01    0.71007E+03    0.52384E-06    0.41451E-10    0.46237E-12
+    2    3    0.65217E-05    0.10000E+01    0.57264E+03    0.97039E-06    0.14456E-09    0.75385E-12
+    2    3    0.65217E-05    0.10000E+01    0.46180E+03    0.17972E-05    0.47997E-09    0.12463E-11
+    2    3    0.65217E-05    0.10000E+01    0.37242E+03    0.33012E-05    0.14521E-08    0.20779E-11
+    2    3    0.65217E-05    0.10000E+01    0.30034E+03    0.59313E-05    0.38768E-08    0.34539E-11
+    2    3    0.65217E-05    0.10000E+01    0.24221E+03    0.10251E-04    0.90268E-08    0.56285E-11
+    2    3    0.65217E-05    0.10000E+01    0.19533E+03    0.15965E-04    0.17127E-07    0.84351E-11
+    2    3    0.65217E-05    0.10000E+01    0.15752E+03    0.15965E-04    0.17127E-07    0.84351E-11
+    2    3    0.11380E-04    0.10000E+01    0.80645E+05    0.20605E-51    0.15441E-62    0.54345E-57
+    2    3    0.11380E-04    0.10000E+01    0.65036E+05    0.17455E-50    0.24547E-61    0.46059E-56
+    2    3    0.11380E-04    0.10000E+01    0.52449E+05    0.14848E-49    0.33026E-60    0.39199E-55
+    2    3    0.11380E-04    0.10000E+01    0.42297E+05    0.11183E-48    0.44939E-59    0.29546E-54
+    2    3    0.11380E-04    0.10000E+01    0.34111E+05    0.80780E-48    0.61808E-58    0.21371E-53
+    2    3    0.11380E-04    0.10000E+01    0.27509E+05    0.58119E-47    0.84008E-57    0.15410E-52
+    2    3    0.11380E-04    0.10000E+01    0.22184E+05    0.41527E-46    0.11223E-55    0.11049E-51
+    2    3    0.11380E-04    0.10000E+01    0.17891E+05    0.29262E-45    0.14726E-54    0.78276E-51
+    2    3    0.11380E-04    0.10000E+01    0.14428E+05    0.20282E-44    0.19030E-53    0.54670E-50
+    2    3    0.11380E-04    0.10000E+01    0.11635E+05    0.13836E-43    0.24190E-52    0.37666E-49
+    2    3    0.11380E-04    0.10000E+01    0.93834E+04    0.92822E-43    0.29956E-51    0.25582E-48
+    2    3    0.11380E-04    0.10000E+01    0.75673E+04    0.60843E-42    0.35566E-50    0.17022E-47
+    2    3    0.11380E-04    0.10000E+01    0.61026E+04    0.38500E-41    0.40039E-49    0.10949E-46
+    2    3    0.11380E-04    0.10000E+01    0.49215E+04    0.23325E-40    0.44877E-48    0.66725E-46
+    2    3    0.11380E-04    0.10000E+01    0.39689E+04    0.14008E-39    0.62408E-47    0.38032E-45
+    2    3    0.11380E-04    0.10000E+01    0.32008E+04    0.31126E-37    0.41583E-44    0.69280E-43
+    2    3    0.11380E-04    0.10000E+01    0.25813E+04    0.16538E-28    0.62868E-35    0.29105E-34
+    2    3    0.11380E-04    0.10000E+01    0.20817E+04    0.29370E-12    0.39691E-18    0.50413E-18
+    2    3    0.11380E-04    0.10000E+01    0.16788E+04    0.89214E-07    0.45690E-12    0.14686E-12
+    2    3    0.11380E-04    0.10000E+01    0.13538E+04    0.15245E-06    0.16286E-11    0.21232E-12
+    2    3    0.11380E-04    0.10000E+01    0.10918E+04    0.27175E-06    0.57731E-11    0.32152E-12
+    2    3    0.11380E-04    0.10000E+01    0.88049E+03    0.49567E-06    0.20443E-10    0.50345E-12
+    2    3    0.11380E-04    0.10000E+01    0.71007E+03    0.91406E-06    0.72329E-10    0.80680E-12
+    2    3    0.11380E-04    0.10000E+01    0.57264E+03    0.16933E-05    0.25224E-09    0.13154E-11
+    2    3    0.11380E-04    0.10000E+01    0.46180E+03    0.31360E-05    0.83752E-09    0.21747E-11
+    2    3    0.11380E-04    0.10000E+01    0.37242E+03    0.57605E-05    0.25339E-08    0.36258E-11
+    2    3    0.11380E-04    0.10000E+01    0.30034E+03    0.10350E-04    0.67648E-08    0.60269E-11
+    2    3    0.11380E-04    0.10000E+01    0.24221E+03    0.17887E-04    0.15751E-07    0.98214E-11
+    2    3    0.11380E-04    0.10000E+01    0.19533E+03    0.27859E-04    0.29885E-07    0.14719E-10
+    2    3    0.11380E-04    0.10000E+01    0.15752E+03    0.27859E-04    0.29885E-07    0.14719E-10
+    2    3    0.19857E-04    0.10000E+01    0.80645E+05    0.35954E-51    0.26944E-62    0.94829E-57
+    2    3    0.19857E-04    0.10000E+01    0.65036E+05    0.30457E-50    0.42832E-61    0.80370E-56
+    2    3    0.19857E-04    0.10000E+01    0.52449E+05    0.25910E-49    0.57629E-60    0.68399E-55
+    2    3    0.19857E-04    0.10000E+01    0.42297E+05    0.19514E-48    0.78415E-59    0.51557E-54
+    2    3    0.19857E-04    0.10000E+01    0.34111E+05    0.14096E-47    0.10785E-57    0.37291E-53
+    2    3    0.19857E-04    0.10000E+01    0.27509E+05    0.10141E-46    0.14659E-56    0.26889E-52
+    2    3    0.19857E-04    0.10000E+01    0.22184E+05    0.72461E-46    0.19583E-55    0.19280E-51
+    2    3    0.19857E-04    0.10000E+01    0.17891E+05    0.51061E-45    0.25696E-54    0.13659E-50
+    2    3    0.19857E-04    0.10000E+01    0.14428E+05    0.35391E-44    0.33205E-53    0.95395E-50
+    2    3    0.19857E-04    0.10000E+01    0.11635E+05    0.24143E-43    0.42209E-52    0.65725E-49
+    2    3    0.19857E-04    0.10000E+01    0.93834E+04    0.16197E-42    0.52271E-51    0.44640E-48
+    2    3    0.19857E-04    0.10000E+01    0.75673E+04    0.10617E-41    0.62061E-50    0.29702E-47
+    2    3    0.19857E-04    0.10000E+01    0.61026E+04    0.67181E-41    0.69865E-49    0.19106E-46
+    2    3    0.19857E-04    0.10000E+01    0.49215E+04    0.40700E-40    0.78307E-48    0.11643E-45
+    2    3    0.19857E-04    0.10000E+01    0.39689E+04    0.24443E-39    0.10890E-46    0.66364E-45
+    2    3    0.19857E-04    0.10000E+01    0.32008E+04    0.54314E-37    0.72560E-44    0.12089E-42
+    2    3    0.19857E-04    0.10000E+01    0.25813E+04    0.28859E-28    0.10970E-34    0.50786E-34
+    2    3    0.19857E-04    0.10000E+01    0.20817E+04    0.51249E-12    0.69259E-18    0.87968E-18
+    2    3    0.19857E-04    0.10000E+01    0.16788E+04    0.15567E-06    0.79726E-12    0.25626E-12
+    2    3    0.19857E-04    0.10000E+01    0.13538E+04    0.26602E-06    0.28419E-11    0.37048E-12
+    2    3    0.19857E-04    0.10000E+01    0.10918E+04    0.47418E-06    0.10074E-10    0.56103E-12
+    2    3    0.19857E-04    0.10000E+01    0.88049E+03    0.86492E-06    0.35671E-10    0.87850E-12
+    2    3    0.19857E-04    0.10000E+01    0.71007E+03    0.15950E-05    0.12621E-09    0.14078E-11
+    2    3    0.19857E-04    0.10000E+01    0.57264E+03    0.29546E-05    0.44014E-09    0.22953E-11
+    2    3    0.19857E-04    0.10000E+01    0.46180E+03    0.54722E-05    0.14614E-08    0.37947E-11
+    2    3    0.19857E-04    0.10000E+01    0.37242E+03    0.10052E-04    0.44215E-08    0.63269E-11
+    2    3    0.19857E-04    0.10000E+01    0.30034E+03    0.18060E-04    0.11804E-07    0.10517E-10
+    2    3    0.19857E-04    0.10000E+01    0.24221E+03    0.31212E-04    0.27485E-07    0.17138E-10
+    2    3    0.19857E-04    0.10000E+01    0.19533E+03    0.48612E-04    0.52148E-07    0.25683E-10
+    2    3    0.19857E-04    0.10000E+01    0.15752E+03    0.48612E-04    0.52148E-07    0.25683E-10
+    2    3    0.34650E-04    0.10000E+01    0.80645E+05    0.62738E-51    0.47016E-62    0.16547E-56
+    2    3    0.34650E-04    0.10000E+01    0.65036E+05    0.53146E-50    0.74740E-61    0.14024E-55
+    2    3    0.34650E-04    0.10000E+01    0.52449E+05    0.45211E-49    0.10056E-59    0.11935E-54
+    2    3    0.34650E-04    0.10000E+01    0.42297E+05    0.34052E-48    0.13683E-58    0.89963E-54
+    2    3    0.34650E-04    0.10000E+01    0.34111E+05    0.24596E-47    0.18819E-57    0.65071E-53
+    2    3    0.34650E-04    0.10000E+01    0.27509E+05    0.17696E-46    0.25579E-56    0.46920E-52
+    2    3    0.34650E-04    0.10000E+01    0.22184E+05    0.12644E-45    0.34171E-55    0.33642E-51
+    2    3    0.34650E-04    0.10000E+01    0.17891E+05    0.89098E-45    0.44839E-54    0.23833E-50
+    2    3    0.34650E-04    0.10000E+01    0.14428E+05    0.61755E-44    0.57942E-53    0.16646E-49
+    2    3    0.34650E-04    0.10000E+01    0.11635E+05    0.42128E-43    0.73653E-52    0.11469E-48
+    2    3    0.34650E-04    0.10000E+01    0.93834E+04    0.28263E-42    0.91210E-51    0.77893E-48
+    2    3    0.34650E-04    0.10000E+01    0.75673E+04    0.18526E-41    0.10829E-49    0.51829E-47
+    2    3    0.34650E-04    0.10000E+01    0.61026E+04    0.11723E-40    0.12191E-48    0.33338E-46
+    2    3    0.34650E-04    0.10000E+01    0.49215E+04    0.71019E-40    0.13664E-47    0.20317E-45
+    2    3    0.34650E-04    0.10000E+01    0.39689E+04    0.42651E-39    0.19002E-46    0.11580E-44
+    2    3    0.34650E-04    0.10000E+01    0.32008E+04    0.94774E-37    0.12661E-43    0.21094E-42
+    2    3    0.34650E-04    0.10000E+01    0.25813E+04    0.50357E-28    0.19142E-34    0.88618E-34
+    2    3    0.34650E-04    0.10000E+01    0.20817E+04    0.89427E-12    0.12085E-17    0.15350E-17
+    2    3    0.34650E-04    0.10000E+01    0.16788E+04    0.27164E-06    0.13912E-11    0.44715E-12
+    2    3    0.34650E-04    0.10000E+01    0.13538E+04    0.46418E-06    0.49589E-11    0.64646E-12
+    2    3    0.34650E-04    0.10000E+01    0.10918E+04    0.82742E-06    0.17578E-10    0.97897E-12
+    2    3    0.34650E-04    0.10000E+01    0.88049E+03    0.15092E-05    0.62244E-10    0.15329E-11
+    2    3    0.34650E-04    0.10000E+01    0.71007E+03    0.27832E-05    0.22023E-09    0.24566E-11
+    2    3    0.34650E-04    0.10000E+01    0.57264E+03    0.51557E-05    0.76802E-09    0.40052E-11
+    2    3    0.34650E-04    0.10000E+01    0.46180E+03    0.95487E-05    0.25501E-08    0.66215E-11
+    2    3    0.34650E-04    0.10000E+01    0.37242E+03    0.17540E-04    0.77152E-08    0.11040E-10
+    2    3    0.34650E-04    0.10000E+01    0.30034E+03    0.31513E-04    0.20598E-07    0.18351E-10
+    2    3    0.34650E-04    0.10000E+01    0.24221E+03    0.54464E-04    0.47960E-07    0.29904E-10
+    2    3    0.34650E-04    0.10000E+01    0.19533E+03    0.84824E-04    0.90995E-07    0.44816E-10
+    2    3    0.34650E-04    0.10000E+01    0.15752E+03    0.84824E-04    0.90995E-07    0.44816E-10
+    2    3    0.60462E-04    0.10000E+01    0.80645E+05    0.10947E-50    0.82041E-62    0.28874E-56
+    2    3    0.60462E-04    0.10000E+01    0.65036E+05    0.92737E-50    0.13042E-60    0.24471E-55
+    2    3    0.60462E-04    0.10000E+01    0.52449E+05    0.78890E-49    0.17547E-59    0.20826E-54
+    2    3    0.60462E-04    0.10000E+01    0.42297E+05    0.59418E-48    0.23876E-58    0.15698E-53
+    2    3    0.60462E-04    0.10000E+01    0.34111E+05    0.42918E-47    0.32839E-57    0.11354E-52
+    2    3    0.60462E-04    0.10000E+01    0.27509E+05    0.30879E-46    0.44633E-56    0.81872E-52
+    2    3    0.60462E-04    0.10000E+01    0.22184E+05    0.22063E-45    0.59626E-55    0.58703E-51
+    2    3    0.60462E-04    0.10000E+01    0.17891E+05    0.15547E-44    0.78241E-54    0.41588E-50
+    2    3    0.60462E-04    0.10000E+01    0.14428E+05    0.10776E-43    0.10110E-52    0.29046E-49
+    2    3    0.60462E-04    0.10000E+01    0.11635E+05    0.73510E-43    0.12852E-51    0.20012E-48
+    2    3    0.60462E-04    0.10000E+01    0.93834E+04    0.49316E-42    0.15916E-50    0.13592E-47
+    2    3    0.60462E-04    0.10000E+01    0.75673E+04    0.32326E-41    0.18896E-49    0.90438E-47
+    2    3    0.60462E-04    0.10000E+01    0.61026E+04    0.20455E-40    0.21273E-48    0.58173E-46
+    2    3    0.60462E-04    0.10000E+01    0.49215E+04    0.12392E-39    0.23843E-47    0.35451E-45
+    2    3    0.60462E-04    0.10000E+01    0.39689E+04    0.74424E-39    0.33158E-46    0.20206E-44
+    2    3    0.60462E-04    0.10000E+01    0.32008E+04    0.16538E-36    0.22093E-43    0.36809E-42
+    2    3    0.60462E-04    0.10000E+01    0.25813E+04    0.87869E-28    0.33402E-34    0.15463E-33
+    2    3    0.60462E-04    0.10000E+01    0.20817E+04    0.15604E-11    0.21088E-17    0.26785E-17
+    2    3    0.60462E-04    0.10000E+01    0.16788E+04    0.47399E-06    0.24275E-11    0.78025E-12
+    2    3    0.60462E-04    0.10000E+01    0.13538E+04    0.80997E-06    0.86529E-11    0.11280E-11
+    2    3    0.60462E-04    0.10000E+01    0.10918E+04    0.14438E-05    0.30673E-10    0.17082E-11
+    2    3    0.60462E-04    0.10000E+01    0.88049E+03    0.26335E-05    0.10861E-09    0.26749E-11
+    2    3    0.60462E-04    0.10000E+01    0.71007E+03    0.48564E-05    0.38429E-09    0.42866E-11
+    2    3    0.60462E-04    0.10000E+01    0.57264E+03    0.89963E-05    0.13402E-08    0.69889E-11
+    2    3    0.60462E-04    0.10000E+01    0.46180E+03    0.16662E-04    0.44498E-08    0.11554E-10
+    2    3    0.60462E-04    0.10000E+01    0.37242E+03    0.30605E-04    0.13463E-07    0.19264E-10
+    2    3    0.60462E-04    0.10000E+01    0.30034E+03    0.54989E-04    0.35942E-07    0.32021E-10
+    2    3    0.60462E-04    0.10000E+01    0.24221E+03    0.95036E-04    0.83687E-07    0.52181E-10
+    2    3    0.60462E-04    0.10000E+01    0.19533E+03    0.14801E-03    0.15878E-06    0.78201E-10
+    2    3    0.60462E-04    0.10000E+01    0.15752E+03    0.14801E-03    0.15878E-06    0.78201E-10
+    2    3    0.10550E-03    0.10000E+01    0.80645E+05    0.19103E-50    0.14316E-61    0.50383E-56
+    2    3    0.10550E-03    0.10000E+01    0.65036E+05    0.16182E-49    0.22757E-60    0.42701E-55
+    2    3    0.10550E-03    0.10000E+01    0.52449E+05    0.13766E-48    0.30618E-59    0.36341E-54
+    2    3    0.10550E-03    0.10000E+01    0.42297E+05    0.10368E-47    0.41662E-58    0.27392E-53
+    2    3    0.10550E-03    0.10000E+01    0.34111E+05    0.74890E-47    0.57302E-57    0.19813E-52
+    2    3    0.10550E-03    0.10000E+01    0.27509E+05    0.53881E-46    0.77883E-56    0.14286E-51
+    2    3    0.10550E-03    0.10000E+01    0.22184E+05    0.38499E-45    0.10404E-54    0.10243E-50
+    2    3    0.10550E-03    0.10000E+01    0.17891E+05    0.27129E-44    0.13653E-53    0.72568E-50
+    2    3    0.10550E-03    0.10000E+01    0.14428E+05    0.18803E-43    0.17642E-52    0.50684E-49
+    2    3    0.10550E-03    0.10000E+01    0.11635E+05    0.12827E-42    0.22426E-51    0.34920E-48
+    2    3    0.10550E-03    0.10000E+01    0.93834E+04    0.86054E-42    0.27772E-50    0.23717E-47
+    2    3    0.10550E-03    0.10000E+01    0.75673E+04    0.56407E-41    0.32973E-49    0.15781E-46
+    2    3    0.10550E-03    0.10000E+01    0.61026E+04    0.35693E-40    0.37119E-48    0.10151E-45
+    2    3    0.10550E-03    0.10000E+01    0.49215E+04    0.21624E-39    0.41605E-47    0.61860E-45
+    2    3    0.10550E-03    0.10000E+01    0.39689E+04    0.12986E-38    0.57858E-46    0.35259E-44
+    2    3    0.10550E-03    0.10000E+01    0.32008E+04    0.28857E-36    0.38551E-43    0.64229E-42
+    2    3    0.10550E-03    0.10000E+01    0.25813E+04    0.15333E-27    0.58284E-34    0.26983E-33
+    2    3    0.10550E-03    0.10000E+01    0.20817E+04    0.27229E-11    0.36797E-17    0.46737E-17
+    2    3    0.10550E-03    0.10000E+01    0.16788E+04    0.82709E-06    0.42358E-11    0.13615E-11
+    2    3    0.10550E-03    0.10000E+01    0.13538E+04    0.14133E-05    0.15099E-10    0.19684E-11
+    2    3    0.10550E-03    0.10000E+01    0.10918E+04    0.25193E-05    0.53522E-10    0.29808E-11
+    2    3    0.10550E-03    0.10000E+01    0.88049E+03    0.45953E-05    0.18952E-09    0.46675E-11
+    2    3    0.10550E-03    0.10000E+01    0.71007E+03    0.84742E-05    0.67056E-09    0.74798E-11
+    2    3    0.10550E-03    0.10000E+01    0.57264E+03    0.15698E-04    0.23385E-08    0.12195E-10
+    2    3    0.10550E-03    0.10000E+01    0.46180E+03    0.29074E-04    0.77646E-08    0.20161E-10
+    2    3    0.10550E-03    0.10000E+01    0.37242E+03    0.53405E-04    0.23491E-07    0.33615E-10
+    2    3    0.10550E-03    0.10000E+01    0.30034E+03    0.95952E-04    0.62716E-07    0.55875E-10
+    2    3    0.10550E-03    0.10000E+01    0.24221E+03    0.16583E-03    0.14603E-06    0.91053E-10
+    2    3    0.10550E-03    0.10000E+01    0.19533E+03    0.25827E-03    0.27706E-06    0.13646E-09
+    2    3    0.10550E-03    0.10000E+01    0.15752E+03    0.25827E-03    0.27706E-06    0.13646E-09
+    2    3    0.18409E-03    0.10000E+01    0.80645E+05    0.33333E-50    0.24980E-61    0.87915E-56
+    2    3    0.18409E-03    0.10000E+01    0.65036E+05    0.28237E-49    0.39709E-60    0.74511E-55
+    2    3    0.18409E-03    0.10000E+01    0.52449E+05    0.24020E-48    0.53427E-59    0.63412E-54
+    2    3    0.18409E-03    0.10000E+01    0.42297E+05    0.18092E-47    0.72698E-58    0.47798E-53
+    2    3    0.18409E-03    0.10000E+01    0.34111E+05    0.13068E-46    0.99988E-57    0.34572E-52
+    2    3    0.18409E-03    0.10000E+01    0.27509E+05    0.94020E-46    0.13590E-55    0.24929E-51
+    2    3    0.18409E-03    0.10000E+01    0.22184E+05    0.67178E-45    0.18155E-54    0.17874E-50
+    2    3    0.18409E-03    0.10000E+01    0.17891E+05    0.47338E-44    0.23823E-53    0.12663E-49
+    2    3    0.18409E-03    0.10000E+01    0.14428E+05    0.32810E-43    0.30784E-52    0.88440E-49
+    2    3    0.18409E-03    0.10000E+01    0.11635E+05    0.22382E-42    0.39132E-51    0.60933E-48
+    2    3    0.18409E-03    0.10000E+01    0.93834E+04    0.15016E-41    0.48460E-50    0.41385E-47
+    2    3    0.18409E-03    0.10000E+01    0.75673E+04    0.98426E-41    0.57536E-49    0.27537E-46
+    2    3    0.18409E-03    0.10000E+01    0.61026E+04    0.62282E-40    0.64771E-48    0.17713E-45
+    2    3    0.18409E-03    0.10000E+01    0.49215E+04    0.37733E-39    0.72597E-47    0.10794E-44
+    2    3    0.18409E-03    0.10000E+01    0.39689E+04    0.22661E-38    0.10096E-45    0.61525E-44
+    2    3    0.18409E-03    0.10000E+01    0.32008E+04    0.50354E-36    0.67270E-43    0.11208E-41
+    2    3    0.18409E-03    0.10000E+01    0.25813E+04    0.26755E-27    0.10170E-33    0.47083E-33
+    2    3    0.18409E-03    0.10000E+01    0.20817E+04    0.47513E-11    0.64209E-17    0.81554E-17
+    2    3    0.18409E-03    0.10000E+01    0.16788E+04    0.14432E-05    0.73913E-11    0.23757E-11
+    2    3    0.18409E-03    0.10000E+01    0.13538E+04    0.24662E-05    0.26346E-10    0.34347E-11
+    2    3    0.18409E-03    0.10000E+01    0.10918E+04    0.43961E-05    0.93393E-10    0.52013E-11
+    2    3    0.18409E-03    0.10000E+01    0.88049E+03    0.80186E-05    0.33070E-09    0.81444E-11
+    2    3    0.18409E-03    0.10000E+01    0.71007E+03    0.14787E-04    0.11701E-08    0.13052E-10
+    2    3    0.18409E-03    0.10000E+01    0.57264E+03    0.27392E-04    0.40805E-08    0.21280E-10
+    2    3    0.18409E-03    0.10000E+01    0.46180E+03    0.50732E-04    0.13549E-07    0.35180E-10
+    2    3    0.18409E-03    0.10000E+01    0.37242E+03    0.93188E-04    0.40991E-07    0.58656E-10
+    2    3    0.18409E-03    0.10000E+01    0.30034E+03    0.16743E-03    0.10944E-06    0.97498E-10
+    2    3    0.18409E-03    0.10000E+01    0.24221E+03    0.28937E-03    0.25481E-06    0.15888E-09
+    2    3    0.18409E-03    0.10000E+01    0.19533E+03    0.45067E-03    0.48346E-06    0.23811E-09
+    2    3    0.18409E-03    0.10000E+01    0.15752E+03    0.45067E-03    0.48346E-06    0.23811E-09
+    2    3    0.32123E-03    0.10000E+01    0.80645E+05    0.58164E-50    0.43588E-61    0.15341E-55
+    2    3    0.32123E-03    0.10000E+01    0.65036E+05    0.49271E-49    0.69290E-60    0.13002E-54
+    2    3    0.32123E-03    0.10000E+01    0.52449E+05    0.41914E-48    0.93227E-59    0.11065E-53
+    2    3    0.32123E-03    0.10000E+01    0.42297E+05    0.31569E-47    0.12685E-57    0.83404E-53
+    2    3    0.32123E-03    0.10000E+01    0.34111E+05    0.22803E-46    0.17447E-56    0.60326E-52
+    2    3    0.32123E-03    0.10000E+01    0.27509E+05    0.16406E-45    0.23714E-55    0.43499E-51
+    2    3    0.32123E-03    0.10000E+01    0.22184E+05    0.11722E-44    0.31679E-54    0.31189E-50
+    2    3    0.32123E-03    0.10000E+01    0.17891E+05    0.82601E-44    0.41569E-53    0.22096E-49
+    2    3    0.32123E-03    0.10000E+01    0.14428E+05    0.57252E-43    0.53717E-52    0.15432E-48
+    2    3    0.32123E-03    0.10000E+01    0.11635E+05    0.39056E-42    0.68283E-51    0.10633E-47
+    2    3    0.32123E-03    0.10000E+01    0.93834E+04    0.26202E-41    0.84560E-50    0.72214E-47
+    2    3    0.32123E-03    0.10000E+01    0.75673E+04    0.17175E-40    0.10040E-48    0.48050E-46
+    2    3    0.32123E-03    0.10000E+01    0.61026E+04    0.10868E-39    0.11302E-47    0.30907E-45
+    2    3    0.32123E-03    0.10000E+01    0.49215E+04    0.65841E-39    0.12668E-46    0.18835E-44
+    2    3    0.32123E-03    0.10000E+01    0.39689E+04    0.39541E-38    0.17617E-45    0.10736E-43
+    2    3    0.32123E-03    0.10000E+01    0.32008E+04    0.87864E-36    0.11738E-42    0.19556E-41
+    2    3    0.32123E-03    0.10000E+01    0.25813E+04    0.46685E-27    0.17746E-33    0.82157E-33
+    2    3    0.32123E-03    0.10000E+01    0.20817E+04    0.82907E-11    0.11204E-16    0.14231E-16
+    2    3    0.32123E-03    0.10000E+01    0.16788E+04    0.25183E-05    0.12897E-10    0.41455E-11
+    2    3    0.32123E-03    0.10000E+01    0.13538E+04    0.43034E-05    0.45973E-10    0.59933E-11
+    2    3    0.32123E-03    0.10000E+01    0.10918E+04    0.76709E-05    0.16297E-09    0.90759E-11
+    2    3    0.32123E-03    0.10000E+01    0.88049E+03    0.13992E-04    0.57706E-09    0.14212E-10
+    2    3    0.32123E-03    0.10000E+01    0.71007E+03    0.25802E-04    0.20417E-08    0.22775E-10
+    2    3    0.32123E-03    0.10000E+01    0.57264E+03    0.47798E-04    0.71203E-08    0.37132E-10
+    2    3    0.32123E-03    0.10000E+01    0.46180E+03    0.88525E-04    0.23642E-07    0.61387E-10
+    2    3    0.32123E-03    0.10000E+01    0.37242E+03    0.16261E-03    0.71527E-07    0.10235E-09
+    2    3    0.32123E-03    0.10000E+01    0.30034E+03    0.29216E-03    0.19096E-06    0.17013E-09
+    2    3    0.32123E-03    0.10000E+01    0.24221E+03    0.50493E-03    0.44463E-06    0.27724E-09
+    2    3    0.32123E-03    0.10000E+01    0.19533E+03    0.78640E-03    0.84360E-06    0.41548E-09
+    2    3    0.32123E-03    0.10000E+01    0.15752E+03    0.78640E-03    0.84360E-06    0.41548E-09
+    2    4    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.29677E-09    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    4    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.51785E-09    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    4    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.90361E-09    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    2    4    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.15767E-08    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    2    4    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.27513E-08    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    2    4    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.48009E-08    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    2    4    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.83773E-08    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    2    4    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.14618E-07    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    2    4    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.25507E-07    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    2    4    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.44508E-07    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    2    4    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.77665E-07    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    2    4    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.13552E-06    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    2    4    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.23647E-06    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    2    4    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.41263E-06    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    2    4    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.72002E-06    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    2    4    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.12564E-05    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    2    4    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.21923E-05    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    2    4    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.38255E-05    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    2    4    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.66752E-05    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    2    4    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.11648E-04    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    2    4    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53957E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.20325E-04    0.19496E+06    0.99447E-26    0.48760E-10    0.50499E-04    0.88379E+03
+    2    4    0.54572E-10    0.10000E+01    0.74090E-01    0.13935E+00    0.11222E-09    0.65380E-11    0.40383E-04    0.29228E-04    0.98516E+04    0.35466E-04    0.15940E+06    0.27009E-25    0.58026E-09    0.60483E-04    0.85041E+03
+    2    4    0.95225E-10    0.10000E+01    0.11736E+00    0.19748E+00    0.21140E-09    0.50998E-10    0.44004E-04    0.38037E-04    0.17190E+05    0.61885E-04    0.12765E+06    0.72481E-25    0.43991E-08    0.73406E-04    0.78192E+03
+    2    4    0.16616E-09    0.10000E+01    0.18177E+00    0.26414E+00    0.32739E-09    0.26604E-09    0.44532E-04    0.48872E-04    0.29996E+05    0.10799E-03    0.99467E+05    0.19970E-24    0.21881E-07    0.91706E-04    0.67140E+03
+    2    4    0.28994E-09    0.10000E+01    0.25854E+00    0.33095E+00    0.47178E-09    0.94784E-09    0.43791E-04    0.56810E-04    0.52341E+05    0.18843E-03    0.75717E+05    0.58441E-24    0.72218E-07    0.11878E-03    0.53435E+03
+    2    4    0.50593E-09    0.10000E+01    0.32770E+00    0.37996E+00    0.73303E-09    0.25336E-08    0.48496E-04    0.55253E-04    0.91333E+05    0.32880E-03    0.57489E+05    0.19003E-23    0.17417E-06    0.15790E-03    0.40764E+03
+    2    4    0.88282E-09    0.10000E+01    0.37216E+00    0.40770E+00    0.13393E-08    0.57614E-08    0.65582E-04    0.48475E-04    0.15937E+06    0.57373E-03    0.44681E+05    0.68213E-23    0.35038E-06    0.20975E-03    0.32172E+03
+    2    4    0.15405E-08    0.10000E+01    0.39855E+00    0.45050E+00    0.29013E-08    0.11837E-07    0.94629E-04    0.45662E-04    0.27809E+06    0.10011E-02    0.35827E+05    0.23891E-22    0.62305E-06    0.26994E-03    0.27820E+03
+    2    4    0.26880E-08    0.10000E+01    0.40631E+00    0.62604E+00    0.92802E-08    0.23093E-07    0.11495E-03    0.53386E-04    0.34661E+06    0.12478E-02    0.15948E+05    0.14482E-21    0.91199E-06    0.39223E-03    0.26496E+03
+    2    4    0.46905E-08    0.10000E+01    0.33565E+00    0.11090E+01    0.29268E-07    0.42571E-07    0.10525E-03    0.79651E-04    0.20736E+06    0.74651E-03    0.55390E+04    0.18527E-20    0.10603E-05    0.71313E-03    0.25786E+03
+    2    4    0.81846E-08    0.10000E+01    0.39060E+00    0.13197E+01    0.51819E-07    0.74644E-07    0.12958E-03    0.93509E-04    0.36184E+06    0.13026E-02    0.45879E+04    0.57287E-20    0.15778E-05    0.86586E-03    0.25413E+03
+    2    4    0.14282E-07    0.10000E+01    0.45529E+00    0.15531E+01    0.90651E-07    0.12924E-06    0.15950E-03    0.11060E-03    0.63138E+06    0.22730E-02    0.38101E+04    0.17520E-19    0.23227E-05    0.10460E-02    0.25215E+03
+    2    4    0.24920E-07    0.10000E+01    0.53293E+00    0.18151E+01    0.15529E-06    0.22142E-06    0.19494E-03    0.13184E-03    0.11017E+07    0.39662E-02    0.31600E+04    0.53696E-19    0.33817E-05    0.12634E-02    0.25109E+03
+    2    4    0.43485E-07    0.10000E+01    0.62425E+00    0.21034E+01    0.26320E-06    0.37603E-06    0.23792E-03    0.15763E-03    0.19224E+07    0.69208E-02    0.26242E+04    0.16377E-18    0.48923E-05    0.15227E-02    0.25055E+03
+    2    4    0.75878E-07    0.10000E+01    0.73147E+00    0.24216E+01    0.44061E-06    0.63364E-06    0.28942E-03    0.18897E-03    0.33546E+07    0.12076E-01    0.21793E+04    0.49923E-18    0.70342E-05    0.18345E-02    0.25028E+03
+    2    4    0.13240E-06    0.10000E+01    0.85621E+00    0.27716E+01    0.72993E-06    0.10605E-05    0.35114E-03    0.22694E-03    0.58535E+07    0.21073E-01    0.18098E+04    0.15214E-17    0.10063E-04    0.22096E-02    0.25014E+03
+    2    4    0.23103E-06    0.10000E+01    0.10001E+01    0.31559E+01    0.11988E-05    0.17641E-05    0.42514E-03    0.27283E-03    0.10214E+08    0.36770E-01    0.15030E+04    0.46359E-17    0.14334E-04    0.26610E-02    0.25007E+03
+    2    4    0.40314E-06    0.10000E+01    0.11645E+01    0.35772E+01    0.19545E-05    0.29188E-05    0.51391E-03    0.32820E-03    0.17823E+08    0.64162E-01    0.12482E+04    0.14125E-16    0.20344E-04    0.32045E-02    0.25003E+03
+    2    4    0.70346E-06    0.10000E+01    0.13498E+01    0.40351E+01    0.31818E-05    0.48083E-05    0.62207E-03    0.39447E-03    0.31100E+08    0.11196E+00    0.10379E+04    0.42863E-16    0.28825E-04    0.38538E-02    0.25002E+03
+    2    4    0.12275E-05    0.10000E+01    0.15600E+01    0.45391E+01    0.51316E-05    0.78844E-05    0.75037E-03    0.47482E-03    0.54267E+08    0.19536E+00    0.86193E+03    0.13038E-15    0.40669E-04    0.46401E-02    0.25001E+03
+    2    4    0.21419E-05    0.10000E+01    0.17957E+01    0.50884E+01    0.82417E-05    0.12878E-04    0.90453E-03    0.57149E-03    0.94693E+08    0.34089E+00    0.71579E+03    0.39328E-15    0.57236E-04    0.55822E-02    0.25000E+03
+    2    4    0.37375E-05    0.10000E+01    0.20586E+01    0.56788E+01    0.13176E-04    0.20942E-04    0.10898E-02    0.68697E-03    0.16523E+09    0.59484E+00    0.59444E+03    0.11533E-14    0.80356E-04    0.66905E-02    0.25000E+03
+    2    4    0.65217E-05    0.10000E+01    0.23293E+01    0.62490E+01    0.21865E-04    0.34008E-04    0.13459E-02    0.81203E-03    0.28832E+09    0.10380E+01    0.50000E+03    0.30923E-14    0.11417E-03    0.78471E-02    0.25000E+03
+    2    4    0.11380E-04    0.10000E+01    0.23293E+01    0.62490E+01    0.66576E-04    0.59341E-04    0.23485E-02    0.81203E-03    0.50310E+09    0.18112E+01    0.50000E+03    0.53959E-14    0.19923E-03    0.78471E-02    0.25000E+03
+    2    4    0.19857E-04    0.10000E+01    0.23293E+01    0.62490E+01    0.20271E-03    0.10355E-03    0.40980E-02    0.81203E-03    0.87789E+09    0.31604E+01    0.50000E+03    0.94155E-14    0.34764E-03    0.78471E-02    0.25000E+03
+    2    4    0.34650E-04    0.10000E+01    0.23293E+01    0.62490E+01    0.61722E-03    0.18068E-03    0.71508E-02    0.81203E-03    0.15319E+10    0.55147E+01    0.50000E+03    0.16429E-13    0.60660E-03    0.78471E-02    0.25000E+03
+    2    4    0.60462E-04    0.10000E+01    0.23293E+01    0.62490E+01    0.18793E-02    0.31528E-03    0.12478E-01    0.81203E-03    0.26730E+10    0.96228E+01    0.50000E+03    0.28668E-13    0.10585E-02    0.78471E-02    0.25000E+03
+    2    4    0.10550E-03    0.10000E+01    0.23293E+01    0.62490E+01    0.57222E-02    0.55015E-03    0.21773E-01    0.81203E-03    0.46642E+10    0.16791E+02    0.50000E+03    0.50025E-13    0.18470E-02    0.78471E-02    0.25000E+03
+    2    4    0.18409E-03    0.10000E+01    0.23293E+01    0.62490E+01    0.17423E-01    0.95997E-03    0.37992E-01    0.81203E-03    0.81388E+10    0.29300E+02    0.50000E+03    0.87290E-13    0.32229E-02    0.78471E-02    0.25000E+03
+    2    4    0.32123E-03    0.10000E+01    0.23293E+01    0.62490E+01    0.53050E-01    0.16751E-02    0.66294E-01    0.81203E-03    0.14202E+11    0.51126E+02    0.50000E+03    0.15232E-12    0.56238E-02    0.78471E-02    0.25000E+03
+    2    4    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    2    4    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    2    4    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    2    4    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    2    4    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    2    4    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    2    4    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    2    4    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    2    4    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    2    4    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    2    4    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    2    4    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    2    4    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    2    4    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    2    4    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    2    4    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    2    4    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    2    4    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    2    4    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    2    4    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    2    4    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    2    4    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    2    4    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    2    4    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    2    4    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    2    4    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    2    4    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    2    4    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    2    4    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    2    4    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    2    4    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    2    4    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    2    4    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    2    4    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    2    4    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    2    4    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    2    4    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    2    4    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    2    4    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    2    4    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    2    4    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    2    4    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    2    4    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    2    4    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    2    4    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    2    4    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    2    4    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    2    4    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    2    4    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    2    4    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    2    4    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    2    4    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    2    4    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    2    4    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    2    4    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    2    4    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    2    4    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    2    4    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    2    4    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    2    4    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    2    4    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    2    4    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    2    4    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    2    4    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    2    4    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    2    4    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    2    4    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    2    4    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    2    4    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    2    4    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    2    4    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    2    4    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    2    4    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    2    4    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    2    4    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    2    4    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    2    4    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    2    4    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    2    4    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    2    4    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    2    4    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    2    4    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    2    4    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    2    4    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    2    4    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    2    4    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    2    4    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    2    4    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    2    4    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    2    4    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    2    4    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    2    4    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    2    4    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    2    4    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    2    4    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    2    4    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    2    4    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    2    4    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    2    4    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    2    4    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    2    4    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    2    4    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    2    4    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    2    4    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    2    4    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    2    4    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    2    4    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    2    4    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    2    4    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    2    4    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    2    4    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    2    4    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    2    4    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    2    4    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    2    4    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    2    4    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    2    4    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    2    4    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    2    4    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    2    4    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    2    4    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    2    4    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    2    4    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    2    4    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    2    4    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    2    4    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    2    4    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    2    4    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    2    4    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    2    4    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    2    4    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    2    4    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    2    4    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    2    4    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    2    4    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    2    4    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    2    4    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    2    4    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    2    4    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    2    4    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    2    4    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    2    4    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    2    4    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    2    4    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    2    4    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    2    4    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    2    4    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    2    4    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    2    4    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    2    4    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    2    4    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    2    4    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    2    4    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    2    4    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    2    4    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    2    4    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    2    4    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    2    4    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    2    4    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    2    4    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    2    4    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    2    4    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    2    4    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    2    4    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    2    4    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    2    4    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    2    4    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    2    4    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    2    4    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    2    4    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    2    4    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    2    4    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    2    4    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    2    4    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    2    4    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    2    4    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    2    4    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    2    4    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    2    4    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    2    4    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    2    4    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    2    4    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    2    4    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    2    4    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    2    4    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    2    4    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    2    4    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    2    4    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    2    4    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    2    4    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    2    4    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    2    4    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    2    4    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    2    4    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    2    4    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    2    4    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    2    4    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    2    4    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    2    4    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    2    4    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    2    4    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    2    4    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    2    4    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    2    4    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    2    4    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    2    4    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    2    4    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    2    4    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    2    4    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    2    4    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    2    4    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    2    4    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    2    4    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    2    4    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    2    4    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    2    4    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    2    4    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    2    4    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    2    4    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    2    4    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    2    4    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    2    4    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    2    4    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    2    4    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    2    4    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    2    4    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    2    4    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    2    4    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    2    4    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    2    4    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    2    4    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    2    4    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    2    4    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    2    4    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    2    4    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    2    4    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    2    4    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    2    4    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    2    4    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    2    4    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    2    4    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    2    4    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    2    4    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    2    4    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    2    4    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    2    4    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    2    4    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    2    4    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    2    4    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    2    4    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    2    4    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    2    4    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    2    4    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    2    4    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    2    4    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    2    4    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    2    4    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    2    4    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    2    4    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    2    4    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    2    4    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    2    4    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    2    4    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    2    4    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    2    4    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    2    4    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    2    4    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    2    4    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    2    4    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    2    4    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    2    4    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    2    4    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    2    4    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    2    4    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    2    4    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    2    4    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    2    4    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    2    4    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    2    4    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    2    4    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    2    4    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    2    4    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    2    4    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    2    4    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    2    4    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    2    4    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    2    4    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    2    4    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    2    4    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    2    4    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    2    4    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    2    4    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    2    4    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    2    4    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    2    4    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    2    4    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    2    4    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    2    4    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    2    4    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    2    4    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    2    4    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    2    4    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    2    4    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    2    4    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    2    4    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    2    4    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    2    4    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    2    4    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    2    4    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    2    4    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    2    4    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    2    4    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    2    4    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    2    4    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    2    4    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    2    4    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    2    4    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    2    4    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    2    4    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    2    4    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    2    4    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    2    4    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    2    4    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    2    4    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    2    4    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    2    4    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    2    4    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    2    4    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    2    4    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    2    4    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    2    4    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    2    4    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    2    4    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    2    4    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    2    4    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    2    4    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    2    4    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    2    4    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    2    4    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    2    4    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    2    4    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    2    4    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    2    4    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    2    4    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    2    4    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    2    4    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    2    4    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    2    4    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    2    4    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    2    4    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    2    4    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    2    4    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    2    4    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    2    4    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    2    4    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    2    4    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    2    4    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    2    4    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    2    4    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    2    4    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    2    4    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    2    4    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    2    4    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    2    4    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    2    4    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    2    4    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    2    4    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    2    4    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    2    4    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    2    4    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    2    4    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    2    4    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    2    4    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    2    4    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    2    4    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    2    4    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    2    4    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    2    4    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    2    4    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    2    4    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    2    4    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    2    4    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    2    4    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    2    4    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    2    4    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    2    4    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    2    4    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    2    4    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    2    4    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    2    4    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    2    4    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    2    4    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    2    4    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    2    4    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    2    4    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    2    4    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    2    4    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    2    4    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    2    4    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    2    4    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    2    4    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    2    4    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    2    4    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    2    4    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    2    4    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    2    4    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    2    4    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    2    4    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    2    4    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    2    4    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    2    4    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    2    4    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    2    4    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    2    4    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    2    4    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    2    4    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    2    4    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    2    4    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    2    4    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    2    4    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    2    4    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    2    4    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    2    4    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    2    4    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    2    4    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    2    4    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    2    4    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    2    4    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    2    4    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    2    4    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    2    4    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    2    4    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    2    4    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    2    4    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    2    4    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    2    4    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    2    4    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    2    4    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    2    4    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    2    4    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    2    4    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    2    4    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    2    4    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    2    4    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    2    4    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    2    4    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    2    4    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    2    4    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    2    4    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    2    4    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    2    4    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    2    4    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    2    4    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    2    4    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    2    4    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    2    4    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    2    4    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    2    4    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    2    4    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    2    4    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    2    4    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    2    4    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    2    4    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    2    4    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    2    4    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    2    4    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    2    4    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    2    4    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    2    4    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    2    4    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    2    4    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    2    4    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    2    4    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    2    4    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    2    4    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    2    4    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    2    4    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    2    4    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    2    4    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    2    4    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    2    4    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    2    4    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    2    4    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    2    4    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    2    4    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    2    4    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    2    4    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    2    4    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    2    4    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    2    4    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    2    4    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    2    4    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    2    4    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    2    4    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    2    4    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    2    4    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    2    4    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    2    4    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    2    4    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    2    4    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    2    4    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    2    4    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    2    4    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    2    4    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    2    4    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    2    4    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    2    4    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    2    4    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    2    4    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    2    4    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    2    4    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    2    4    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    2    4    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    2    4    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    2    4    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    2    4    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    2    4    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    2    4    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    2    4    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    2    4    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    2    4    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    2    4    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    2    4    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    2    4    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    2    4    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    2    4    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    2    4    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    2    4    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    2    4    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    2    4    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    2    4    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    2    4    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    2    4    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    2    4    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    2    4    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    2    4    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    2    4    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    2    4    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    2    4    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    2    4    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    2    4    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    2    4    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    2    4    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    2    4    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    2    4    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    2    4    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    2    4    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    2    4    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    2    4    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    2    4    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    2    4    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    2    4    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    2    4    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    2    4    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    2    4    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    2    4    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    2    4    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    2    4    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    2    4    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    2    4    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    2    4    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    2    4    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    2    4    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    2    4    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    2    4    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    2    4    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    2    4    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    2    4    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    2    4    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    2    4    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    2    4    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    2    4    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    2    4    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    2    4    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    2    4    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    2    4    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    2    4    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    2    4    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    2    4    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    2    4    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    2    4    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    2    4    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    2    4    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    2    4    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    2    4    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    2    4    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    2    4    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    2    4    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    2    4    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    2    4    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    2    4    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    2    4    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    2    4    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    2    4    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    2    4    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    2    4    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    2    4    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    2    4    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    2    4    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    2    4    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    2    4    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    2    4    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    2    4    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    2    4    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    2    4    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    2    4    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    2    4    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    2    4    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    2    4    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    2    4    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    2    4    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    2    4    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    2    4    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    2    4    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    2    4    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    2    4    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    2    4    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    2    4    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    2    4    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    2    4    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    2    4    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    2    4    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    2    4    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    2    4    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    2    4    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    2    4    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    2    4    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    2    4    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    2    4    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    2    4    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    2    4    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35525E-67
+    2    4    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31050E-66
+    2    4    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49297E-66    0.26759E-65
+    2    4    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20665E-64
+    2    4    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    2    4    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15327E-62
+    2    4    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    2    4    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30486E-60
+    2    4    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49479E-59
+    2    4    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76348E-58
+    2    4    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    2    4    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16341E-55
+    2    4    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    2    4    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33513E-53
+    2    4    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47754E-52
+    2    4    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86007E-46    0.21355E-49
+    2    4    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    2    4    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    2    4    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    2    4    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    2    4    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    2    4    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    2    4    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    2    4    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    2    4    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    2    4    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    2    4    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    2    4    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    2    4    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    2    4    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    2    4    0.95225E-10    0.10000E+01    0.80645E+05    0.53338E-57    0.41251E-68    0.10750E-66
+    2    4    0.95225E-10    0.10000E+01    0.65036E+05    0.46320E-56    0.66241E-67    0.94145E-66
+    2    4    0.95225E-10    0.10000E+01    0.52449E+05    0.40024E-55    0.93503E-66    0.81418E-65
+    2    4    0.95225E-10    0.10000E+01    0.42297E+05    0.31521E-54    0.15121E-64    0.62479E-64
+    2    4    0.95225E-10    0.10000E+01    0.34111E+05    0.26479E-53    0.31103E-63    0.46451E-63
+    2    4    0.95225E-10    0.10000E+01    0.27509E+05    0.27530E-52    0.84266E-62    0.36185E-62
+    2    4    0.95225E-10    0.10000E+01    0.22184E+05    0.37547E-51    0.26561E-60    0.35004E-61
+    2    4    0.95225E-10    0.10000E+01    0.17891E+05    0.59959E-50    0.82078E-59    0.47852E-60
+    2    4    0.95225E-10    0.10000E+01    0.14428E+05    0.96029E-49    0.23747E-57    0.76675E-59
+    2    4    0.95225E-10    0.10000E+01    0.11635E+05    0.14620E-47    0.65938E-56    0.12102E-57
+    2    4    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18298E-56
+    2    4    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49011E-53    0.26942E-55
+    2    4    0.95225E-10    0.10000E+01    0.61026E+04    0.43943E-44    0.13295E-51    0.39150E-54
+    2    4    0.95225E-10    0.10000E+01    0.49215E+04    0.62538E-43    0.35997E-50    0.56476E-53
+    2    4    0.95225E-10    0.10000E+01    0.39689E+04    0.88822E-42    0.97300E-49    0.81063E-52
+    2    4    0.95225E-10    0.10000E+01    0.32008E+04    0.39613E-39    0.84952E-46    0.36461E-49
+    2    4    0.95225E-10    0.10000E+01    0.25813E+04    0.29211E-30    0.14353E-36    0.27085E-40
+    2    4    0.95225E-10    0.10000E+01    0.20817E+04    0.55938E-14    0.12256E-19    0.52257E-24
+    2    4    0.95225E-10    0.10000E+01    0.16788E+04    0.18980E-08    0.18143E-13    0.17813E-18
+    2    4    0.95225E-10    0.10000E+01    0.13538E+04    0.40806E-08    0.68940E-13    0.38357E-18
+    2    4    0.95225E-10    0.10000E+01    0.10918E+04    0.85761E-08    0.25711E-12    0.80708E-18
+    2    4    0.95225E-10    0.10000E+01    0.88049E+03    0.17636E-07    0.94670E-12    0.16610E-17
+    2    4    0.95225E-10    0.10000E+01    0.71007E+03    0.35560E-07    0.34475E-11    0.33511E-17
+    2    4    0.95225E-10    0.10000E+01    0.57264E+03    0.70490E-07    0.12266E-10    0.66454E-17
+    2    4    0.95225E-10    0.10000E+01    0.46180E+03    0.13745E-06    0.41255E-10    0.12961E-16
+    2    4    0.95225E-10    0.10000E+01    0.37242E+03    0.26237E-06    0.12579E-09    0.24744E-16
+    2    4    0.95225E-10    0.10000E+01    0.30034E+03    0.48462E-06    0.33740E-09    0.45710E-16
+    2    4    0.95225E-10    0.10000E+01    0.24221E+03    0.85384E-06    0.78780E-09    0.80539E-16
+    2    4    0.95225E-10    0.10000E+01    0.19533E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    2    4    0.95225E-10    0.10000E+01    0.15752E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    2    4    0.16616E-09    0.10000E+01    0.80645E+05    0.10833E-56    0.84146E-68    0.33715E-66
+    2    4    0.16616E-09    0.10000E+01    0.65036E+05    0.94395E-56    0.13507E-66    0.29260E-65
+    2    4    0.16616E-09    0.10000E+01    0.52449E+05    0.81485E-55    0.18600E-65    0.25215E-64
+    2    4    0.16616E-09    0.10000E+01    0.42297E+05    0.62650E-54    0.26584E-64    0.19230E-63
+    2    4    0.16616E-09    0.10000E+01    0.34111E+05    0.47294E-53    0.41439E-63    0.13959E-62
+    2    4    0.16616E-09    0.10000E+01    0.27509E+05    0.38374E-52    0.82693E-62    0.99884E-62
+    2    4    0.16616E-09    0.10000E+01    0.22184E+05    0.38947E-51    0.23107E-60    0.77612E-61
+    2    4    0.16616E-09    0.10000E+01    0.17891E+05    0.53700E-50    0.71872E-59    0.82873E-60
+    2    4    0.16616E-09    0.10000E+01    0.14428E+05    0.84666E-49    0.21403E-57    0.12138E-58
+    2    4    0.16616E-09    0.10000E+01    0.11635E+05    0.13169E-47    0.60847E-56    0.19209E-57
+    2    4    0.16616E-09    0.10000E+01    0.93834E+04    0.19721E-46    0.16918E-54    0.29630E-56
+    2    4    0.16616E-09    0.10000E+01    0.75673E+04    0.28849E-45    0.46589E-53    0.44383E-55
+    2    4    0.16616E-09    0.10000E+01    0.61026E+04    0.41725E-44    0.12761E-51    0.65309E-54
+    2    4    0.16616E-09    0.10000E+01    0.49215E+04    0.59977E-43    0.34816E-50    0.95086E-53
+    2    4    0.16616E-09    0.10000E+01    0.39689E+04    0.85853E-42    0.94682E-49    0.13745E-51
+    2    4    0.16616E-09    0.10000E+01    0.32008E+04    0.38532E-39    0.83090E-46    0.62169E-49
+    2    4    0.16616E-09    0.10000E+01    0.25813E+04    0.28570E-30    0.14109E-36    0.46408E-40
+    2    4    0.16616E-09    0.10000E+01    0.20817E+04    0.55020E-14    0.12111E-19    0.89985E-24
+    2    4    0.16616E-09    0.10000E+01    0.16788E+04    0.18734E-08    0.17966E-13    0.30769E-18
+    2    4    0.16616E-09    0.10000E+01    0.13538E+04    0.40324E-08    0.68288E-13    0.66323E-18
+    2    4    0.16616E-09    0.10000E+01    0.10918E+04    0.84823E-08    0.25472E-12    0.13966E-17
+    2    4    0.16616E-09    0.10000E+01    0.88049E+03    0.17453E-07    0.93799E-12    0.28758E-17
+    2    4    0.16616E-09    0.10000E+01    0.71007E+03    0.35208E-07    0.34159E-11    0.58041E-17
+    2    4    0.16616E-09    0.10000E+01    0.57264E+03    0.69812E-07    0.12153E-10    0.11513E-16
+    2    4    0.16616E-09    0.10000E+01    0.46180E+03    0.13615E-06    0.40877E-10    0.22458E-16
+    2    4    0.16616E-09    0.10000E+01    0.37242E+03    0.25992E-06    0.12464E-09    0.42878E-16
+    2    4    0.16616E-09    0.10000E+01    0.30034E+03    0.48014E-06    0.33431E-09    0.79213E-16
+    2    4    0.16616E-09    0.10000E+01    0.24221E+03    0.84597E-06    0.78059E-09    0.13957E-15
+    2    4    0.16616E-09    0.10000E+01    0.19533E+03    0.13333E-05    0.14834E-08    0.21999E-15
+    2    4    0.16616E-09    0.10000E+01    0.15752E+03    0.13333E-05    0.14834E-08    0.21999E-15
+    2    4    0.28994E-09    0.10000E+01    0.80645E+05    0.22083E-56    0.16962E-67    0.11610E-65
+    2    4    0.28994E-09    0.10000E+01    0.65036E+05    0.19074E-55    0.27155E-66    0.99360E-65
+    2    4    0.28994E-09    0.10000E+01    0.52449E+05    0.16390E-54    0.36968E-65    0.84912E-64
+    2    4    0.28994E-09    0.10000E+01    0.42297E+05    0.12466E-53    0.50548E-64    0.64057E-63
+    2    4    0.28994E-09    0.10000E+01    0.34111E+05    0.90529E-53    0.68980E-63    0.45793E-62
+    2    4    0.28994E-09    0.10000E+01    0.27509E+05    0.65292E-52    0.10247E-61    0.31724E-61
+    2    4    0.28994E-09    0.10000E+01    0.22184E+05    0.51035E-51    0.21699E-60    0.21843E-60
+    2    4    0.28994E-09    0.10000E+01    0.17891E+05    0.53384E-50    0.62972E-59    0.17835E-59
+    2    4    0.28994E-09    0.10000E+01    0.14428E+05    0.75838E-49    0.19110E-57    0.21173E-58
+    2    4    0.28994E-09    0.10000E+01    0.11635E+05    0.11799E-47    0.55796E-56    0.31708E-57
+    2    4    0.28994E-09    0.10000E+01    0.93834E+04    0.18060E-46    0.15823E-54    0.49053E-56
+    2    4    0.28994E-09    0.10000E+01    0.75673E+04    0.26938E-45    0.44189E-53    0.74255E-55
+    2    4    0.28994E-09    0.10000E+01    0.61026E+04    0.39527E-44    0.12229E-51    0.11015E-53
+    2    4    0.28994E-09    0.10000E+01    0.49215E+04    0.57428E-43    0.33632E-50    0.16129E-52
+    2    4    0.28994E-09    0.10000E+01    0.39689E+04    0.82879E-42    0.92040E-49    0.23416E-51
+    2    4    0.28994E-09    0.10000E+01    0.32008E+04    0.37442E-39    0.81204E-46    0.10630E-48
+    2    4    0.28994E-09    0.10000E+01    0.25813E+04    0.27922E-30    0.13861E-36    0.79624E-40
+    2    4    0.28994E-09    0.10000E+01    0.20817E+04    0.54092E-14    0.11965E-19    0.15498E-23
+    2    4    0.28994E-09    0.10000E+01    0.16788E+04    0.18486E-08    0.17788E-13    0.53123E-18
+    2    4    0.28994E-09    0.10000E+01    0.13538E+04    0.39839E-08    0.67634E-13    0.11460E-17
+    2    4    0.28994E-09    0.10000E+01    0.10918E+04    0.83878E-08    0.25232E-12    0.24145E-17
+    2    4    0.28994E-09    0.10000E+01    0.88049E+03    0.17270E-07    0.92923E-12    0.49739E-17
+    2    4    0.28994E-09    0.10000E+01    0.71007E+03    0.34853E-07    0.33841E-11    0.10042E-16
+    2    4    0.28994E-09    0.10000E+01    0.57264E+03    0.69130E-07    0.12040E-10    0.19922E-16
+    2    4    0.28994E-09    0.10000E+01    0.46180E+03    0.13485E-06    0.40497E-10    0.38866E-16
+    2    4    0.28994E-09    0.10000E+01    0.37242E+03    0.25746E-06    0.12348E-09    0.74211E-16
+    2    4    0.28994E-09    0.10000E+01    0.30034E+03    0.47562E-06    0.33120E-09    0.13710E-15
+    2    4    0.28994E-09    0.10000E+01    0.24221E+03    0.83805E-06    0.77333E-09    0.24158E-15
+    2    4    0.28994E-09    0.10000E+01    0.19533E+03    0.13209E-05    0.14696E-08    0.38076E-15
+    2    4    0.28994E-09    0.10000E+01    0.15752E+03    0.13209E-05    0.14696E-08    0.38076E-15
+    2    4    0.50593E-09    0.10000E+01    0.80645E+05    0.45863E-56    0.34638E-67    0.46604E-65
+    2    4    0.50593E-09    0.10000E+01    0.65036E+05    0.39084E-55    0.55087E-66    0.39292E-64
+    2    4    0.50593E-09    0.10000E+01    0.52449E+05    0.33301E-54    0.73894E-65    0.33224E-63
+    2    4    0.50593E-09    0.10000E+01    0.42297E+05    0.25016E-53    0.98708E-64    0.24672E-62
+    2    4    0.50593E-09    0.10000E+01    0.34111E+05    0.17796E-52    0.12866E-62    0.17259E-61
+    2    4    0.50593E-09    0.10000E+01    0.27509E+05    0.12287E-51    0.16433E-61    0.11635E-60
+    2    4    0.50593E-09    0.10000E+01    0.22184E+05    0.84215E-51    0.25655E-60    0.75349E-60
+    2    4    0.50593E-09    0.10000E+01    0.17891E+05    0.67381E-50    0.61438E-59    0.51611E-59
+    2    4    0.50593E-09    0.10000E+01    0.14428E+05    0.77265E-49    0.18096E-57    0.47757E-58
+    2    4    0.50593E-09    0.10000E+01    0.11635E+05    0.11307E-47    0.53391E-56    0.62217E-57
+    2    4    0.50593E-09    0.10000E+01    0.93834E+04    0.17300E-46    0.15297E-54    0.91671E-56
+    2    4    0.50593E-09    0.10000E+01    0.75673E+04    0.26022E-45    0.42988E-53    0.13566E-54
+    2    4    0.50593E-09    0.10000E+01    0.61026E+04    0.38429E-44    0.11947E-51    0.19799E-53
+    2    4    0.50593E-09    0.10000E+01    0.49215E+04    0.56084E-43    0.32968E-50    0.28630E-52
+    2    4    0.50593E-09    0.10000E+01    0.39689E+04    0.81225E-42    0.90496E-49    0.41191E-51
+    2    4    0.50593E-09    0.10000E+01    0.32008E+04    0.36809E-39    0.80070E-46    0.18587E-48
+    2    4    0.50593E-09    0.10000E+01    0.25813E+04    0.27536E-30    0.13712E-36    0.13871E-39
+    2    4    0.50593E-09    0.10000E+01    0.20817E+04    0.53540E-14    0.11879E-19    0.26942E-23
+    2    4    0.50593E-09    0.10000E+01    0.16788E+04    0.18340E-08    0.17685E-13    0.92260E-18
+    2    4    0.50593E-09    0.10000E+01    0.13538E+04    0.39555E-08    0.67257E-13    0.19894E-17
+    2    4    0.50593E-09    0.10000E+01    0.10918E+04    0.83328E-08    0.25094E-12    0.41904E-17
+    2    4    0.50593E-09    0.10000E+01    0.88049E+03    0.17164E-07    0.92417E-12    0.86307E-17
+    2    4    0.50593E-09    0.10000E+01    0.71007E+03    0.34648E-07    0.33657E-11    0.17422E-16
+    2    4    0.50593E-09    0.10000E+01    0.57264E+03    0.68735E-07    0.11975E-10    0.34559E-16
+    2    4    0.50593E-09    0.10000E+01    0.46180E+03    0.13409E-06    0.40275E-10    0.67417E-16
+    2    4    0.50593E-09    0.10000E+01    0.37242E+03    0.25603E-06    0.12281E-09    0.12872E-15
+    2    4    0.50593E-09    0.10000E+01    0.30034E+03    0.47300E-06    0.32938E-09    0.23778E-15
+    2    4    0.50593E-09    0.10000E+01    0.24221E+03    0.83344E-06    0.76908E-09    0.41896E-15
+    2    4    0.50593E-09    0.10000E+01    0.19533E+03    0.13136E-05    0.14615E-08    0.66032E-15
+    2    4    0.50593E-09    0.10000E+01    0.15752E+03    0.13136E-05    0.14615E-08    0.66032E-15
+    2    4    0.88282E-09    0.10000E+01    0.80645E+05    0.95629E-56    0.71190E-67    0.20056E-64
+    2    4    0.88282E-09    0.10000E+01    0.65036E+05    0.80560E-55    0.11244E-65    0.16787E-63
+    2    4    0.88282E-09    0.10000E+01    0.52449E+05    0.68076E-54    0.14854E-64    0.14120E-62
+    2    4    0.88282E-09    0.10000E+01    0.42297E+05    0.50506E-53    0.19431E-63    0.10403E-61
+    2    4    0.88282E-09    0.10000E+01    0.34111E+05    0.35287E-52    0.24692E-62    0.72002E-61
+    2    4    0.88282E-09    0.10000E+01    0.27509E+05    0.23770E-51    0.29658E-61    0.48003E-60
+    2    4    0.88282E-09    0.10000E+01    0.22184E+05    0.15408E-50    0.38557E-60    0.30445E-59
+    2    4    0.88282E-09    0.10000E+01    0.17891E+05    0.10575E-49    0.73851E-59    0.19149E-58
+    2    4    0.88282E-09    0.10000E+01    0.14428E+05    0.97567E-49    0.19790E-57    0.14368E-57
+    2    4    0.88282E-09    0.10000E+01    0.11635E+05    0.12612E-47    0.56701E-56    0.15220E-56
+    2    4    0.88282E-09    0.10000E+01    0.93834E+04    0.18460E-46    0.15963E-54    0.20113E-55
+    2    4    0.88282E-09    0.10000E+01    0.75673E+04    0.27194E-45    0.44204E-53    0.28059E-54
+    2    4    0.88282E-09    0.10000E+01    0.61026E+04    0.39559E-44    0.12142E-51    0.39209E-53
+    2    4    0.88282E-09    0.10000E+01    0.49215E+04    0.57058E-43    0.33226E-50    0.54713E-52
+    2    4    0.88282E-09    0.10000E+01    0.39689E+04    0.81930E-42    0.90702E-49    0.76529E-51
+    2    4    0.88282E-09    0.10000E+01    0.32008E+04    0.36915E-39    0.79977E-46    0.33806E-48
+    2    4    0.88282E-09    0.10000E+01    0.25813E+04    0.27515E-30    0.13666E-36    0.24832E-39
+    2    4    0.88282E-09    0.10000E+01    0.20817E+04    0.53381E-14    0.11823E-19    0.47615E-23
+    2    4    0.88282E-09    0.10000E+01    0.16788E+04    0.18268E-08    0.17597E-13    0.16191E-17
+    2    4    0.88282E-09    0.10000E+01    0.13538E+04    0.39382E-08    0.66914E-13    0.34820E-17
+    2    4    0.88282E-09    0.10000E+01    0.10918E+04    0.82939E-08    0.24964E-12    0.73208E-17
+    2    4    0.88282E-09    0.10000E+01    0.88049E+03    0.17080E-07    0.91929E-12    0.15059E-16
+    2    4    0.88282E-09    0.10000E+01    0.71007E+03    0.34475E-07    0.33476E-11    0.30369E-16
+    2    4    0.88282E-09    0.10000E+01    0.57264E+03    0.68384E-07    0.11910E-10    0.60201E-16
+    2    4    0.88282E-09    0.10000E+01    0.46180E+03    0.13340E-06    0.40055E-10    0.11738E-15
+    2    4    0.88282E-09    0.10000E+01    0.37242E+03    0.25468E-06    0.12213E-09    0.22403E-15
+    2    4    0.88282E-09    0.10000E+01    0.30034E+03    0.47047E-06    0.32757E-09    0.41376E-15
+    2    4    0.88282E-09    0.10000E+01    0.24221E+03    0.82895E-06    0.76484E-09    0.72890E-15
+    2    4    0.88282E-09    0.10000E+01    0.19533E+03    0.13065E-05    0.14534E-08    0.11487E-14
+    2    4    0.88282E-09    0.10000E+01    0.15752E+03    0.13065E-05    0.14534E-08    0.11487E-14
+    2    4    0.15405E-08    0.10000E+01    0.80645E+05    0.19193E-55    0.14192E-66    0.77721E-64
+    2    4    0.15405E-08    0.10000E+01    0.65036E+05    0.16082E-54    0.22342E-65    0.65066E-63
+    2    4    0.15405E-08    0.10000E+01    0.52449E+05    0.13537E-53    0.29304E-64    0.54760E-62
+    2    4    0.15405E-08    0.10000E+01    0.42297E+05    0.99853E-53    0.37992E-63    0.40418E-61
+    2    4    0.15405E-08    0.10000E+01    0.34111E+05    0.69231E-52    0.47910E-62    0.28111E-60
+    2    4    0.15405E-08    0.10000E+01    0.27509E+05    0.46261E-51    0.56579E-61    0.18946E-59
+    2    4    0.15405E-08    0.10000E+01    0.22184E+05    0.29471E-50    0.67236E-60    0.12181E-58
+    2    4    0.15405E-08    0.10000E+01    0.17891E+05    0.18795E-49    0.10529E-58    0.74923E-58
+    2    4    0.15405E-08    0.10000E+01    0.14428E+05    0.14566E-48    0.24334E-57    0.48372E-57
+    2    4    0.15405E-08    0.10000E+01    0.11635E+05    0.15974E-47    0.65506E-56    0.39813E-56
+    2    4    0.15405E-08    0.10000E+01    0.93834E+04    0.21544E-46    0.17805E-54    0.44458E-55
+    2    4    0.15405E-08    0.10000E+01    0.75673E+04    0.30436E-45    0.47916E-53    0.57889E-54
+    2    4    0.15405E-08    0.10000E+01    0.61026E+04    0.42974E-44    0.12850E-51    0.78150E-53
+    2    4    0.15405E-08    0.10000E+01    0.49215E+04    0.60503E-43    0.34508E-50    0.10600E-51
+    2    4    0.15405E-08    0.10000E+01    0.39689E+04    0.85241E-42    0.92917E-49    0.14440E-50
+    2    4    0.15405E-08    0.10000E+01    0.32008E+04    0.37862E-39    0.81119E-46    0.62327E-48
+    2    4    0.15405E-08    0.10000E+01    0.25813E+04    0.27925E-30    0.13754E-36    0.44900E-39
+    2    4    0.15405E-08    0.10000E+01    0.20817E+04    0.53725E-14    0.11820E-19    0.84628E-23
+    2    4    0.15405E-08    0.10000E+01    0.16788E+04    0.18302E-08    0.17551E-13    0.28503E-17
+    2    4    0.15405E-08    0.10000E+01    0.13538E+04    0.39387E-08    0.66710E-13    0.61058E-17
+    2    4    0.15405E-08    0.10000E+01    0.10918E+04    0.82850E-08    0.24880E-12    0.12803E-16
+    2    4    0.15405E-08    0.10000E+01    0.88049E+03    0.17048E-07    0.91597E-12    0.26284E-16
+    2    4    0.15405E-08    0.10000E+01    0.71007E+03    0.34388E-07    0.33350E-11    0.52933E-16
+    2    4    0.15405E-08    0.10000E+01    0.57264E+03    0.68182E-07    0.11863E-10    0.10482E-15
+    2    4    0.15405E-08    0.10000E+01    0.46180E+03    0.13296E-06    0.39896E-10    0.20424E-15
+    2    4    0.15405E-08    0.10000E+01    0.37242E+03    0.25378E-06    0.12164E-09    0.38959E-15
+    2    4    0.15405E-08    0.10000E+01    0.30034E+03    0.46874E-06    0.32625E-09    0.71926E-15
+    2    4    0.15405E-08    0.10000E+01    0.24221E+03    0.82580E-06    0.76173E-09    0.12668E-14
+    2    4    0.15405E-08    0.10000E+01    0.19533E+03    0.13014E-05    0.14475E-08    0.19960E-14
+    2    4    0.15405E-08    0.10000E+01    0.15752E+03    0.13014E-05    0.14475E-08    0.19960E-14
+    2    4    0.26880E-08    0.10000E+01    0.80645E+05    0.37535E-55    0.27805E-66    0.51060E-63
+    2    4    0.26880E-08    0.10000E+01    0.65036E+05    0.31498E-54    0.43851E-65    0.42973E-62
+    2    4    0.26880E-08    0.10000E+01    0.52449E+05    0.26562E-53    0.57811E-64    0.36346E-61
+    2    4    0.26880E-08    0.10000E+01    0.42297E+05    0.19676E-52    0.75811E-63    0.27084E-60
+    2    4    0.26880E-08    0.10000E+01    0.34111E+05    0.13773E-51    0.97914E-62    0.19188E-59
+    2    4    0.26880E-08    0.10000E+01    0.27509E+05    0.93841E-51    0.12010E-60    0.13366E-58
+    2    4    0.26880E-08    0.10000E+01    0.22184E+05    0.61518E-50    0.14231E-59    0.90524E-58
+    2    4    0.26880E-08    0.10000E+01    0.17891E+05    0.39174E-49    0.18550E-58    0.58704E-57
+    2    4    0.26880E-08    0.10000E+01    0.14428E+05    0.26518E-48    0.32260E-57    0.36496E-56
+    2    4    0.26880E-08    0.10000E+01    0.11635E+05    0.22507E-47    0.74066E-56    0.22692E-55
+    2    4    0.26880E-08    0.10000E+01    0.93834E+04    0.25232E-46    0.19125E-54    0.15739E-54
+    2    4    0.26880E-08    0.10000E+01    0.75673E+04    0.33098E-45    0.50693E-53    0.13930E-53
+    2    4    0.26880E-08    0.10000E+01    0.61026E+04    0.45607E-44    0.13471E-51    0.15822E-52
+    2    4    0.26880E-08    0.10000E+01    0.49215E+04    0.63474E-43    0.35833E-50    0.20449E-51
+    2    4    0.26880E-08    0.10000E+01    0.39689E+04    0.88562E-42    0.95593E-49    0.27451E-50
+    2    4    0.26880E-08    0.10000E+01    0.32008E+04    0.38971E-39    0.82764E-46    0.11674E-47
+    2    4    0.26880E-08    0.10000E+01    0.25813E+04    0.28493E-30    0.13925E-36    0.82391E-39
+    2    4    0.26880E-08    0.10000E+01    0.20817E+04    0.54357E-14    0.11874E-19    0.15151E-22
+    2    4    0.26880E-08    0.10000E+01    0.16788E+04    0.18430E-08    0.17579E-13    0.50304E-17
+    2    4    0.26880E-08    0.10000E+01    0.13538E+04    0.39580E-08    0.66781E-13    0.10681E-16
+    2    4    0.26880E-08    0.10000E+01    0.10918E+04    0.83138E-08    0.24896E-12    0.22262E-16
+    2    4    0.26880E-08    0.10000E+01    0.88049E+03    0.17090E-07    0.91633E-12    0.45509E-16
+    2    4    0.26880E-08    0.10000E+01    0.71007E+03    0.34448E-07    0.33356E-11    0.91363E-16
+    2    4    0.26880E-08    0.10000E+01    0.57264E+03    0.68263E-07    0.11864E-10    0.18050E-15
+    2    4    0.26880E-08    0.10000E+01    0.46180E+03    0.13306E-06    0.39896E-10    0.35106E-15
+    2    4    0.26880E-08    0.10000E+01    0.37242E+03    0.25392E-06    0.12163E-09    0.66878E-15
+    2    4    0.26880E-08    0.10000E+01    0.30034E+03    0.46889E-06    0.32622E-09    0.12335E-14
+    2    4    0.26880E-08    0.10000E+01    0.24221E+03    0.82597E-06    0.76165E-09    0.21711E-14
+    2    4    0.26880E-08    0.10000E+01    0.19533E+03    0.13016E-05    0.14474E-08    0.34195E-14
+    2    4    0.26880E-08    0.10000E+01    0.15752E+03    0.13016E-05    0.14474E-08    0.34195E-14
+    2    4    0.46905E-08    0.10000E+01    0.80645E+05    0.69589E-55    0.51825E-66    0.62812E-62
+    2    4    0.46905E-08    0.10000E+01    0.65036E+05    0.58651E-54    0.82044E-65    0.53132E-61
+    2    4    0.46905E-08    0.10000E+01    0.52449E+05    0.49666E-53    0.10925E-63    0.45141E-60
+    2    4    0.46905E-08    0.10000E+01    0.42297E+05    0.37091E-52    0.14601E-62    0.33920E-59
+    2    4    0.46905E-08    0.10000E+01    0.34111E+05    0.26384E-51    0.19518E-61    0.24400E-58
+    2    4    0.46905E-08    0.10000E+01    0.27509E+05    0.18513E-50    0.25399E-60    0.17438E-57
+    2    4    0.46905E-08    0.10000E+01    0.22184E+05    0.12741E-49    0.32266E-59    0.12324E-56
+    2    4    0.46905E-08    0.10000E+01    0.17891E+05    0.85943E-49    0.41717E-58    0.85368E-56
+    2    4    0.46905E-08    0.10000E+01    0.14428E+05    0.58476E-48    0.59892E-57    0.57727E-55
+    2    4    0.46905E-08    0.10000E+01    0.11635E+05    0.43049E-47    0.10399E-55    0.38163E-54
+    2    4    0.46905E-08    0.10000E+01    0.93834E+04    0.37407E-46    0.22047E-54    0.24751E-53
+    2    4    0.46905E-08    0.10000E+01    0.75673E+04    0.39708E-45    0.53508E-53    0.15863E-52
+    2    4    0.46905E-08    0.10000E+01    0.61026E+04    0.49088E-44    0.13852E-51    0.10351E-51
+    2    4    0.46905E-08    0.10000E+01    0.49215E+04    0.65733E-43    0.36706E-50    0.74872E-51
+    2    4    0.46905E-08    0.10000E+01    0.39689E+04    0.90868E-42    0.97921E-49    0.67542E-50
+    2    4    0.46905E-08    0.10000E+01    0.32008E+04    0.39922E-39    0.84653E-46    0.24306E-47
+    2    4    0.46905E-08    0.10000E+01    0.25813E+04    0.29126E-30    0.14185E-36    0.16411E-38
+    2    4    0.46905E-08    0.10000E+01    0.20817E+04    0.55320E-14    0.12013E-19    0.29770E-22
+    2    4    0.46905E-08    0.10000E+01    0.16788E+04    0.18694E-08    0.17728E-13    0.96570E-17
+    2    4    0.46905E-08    0.10000E+01    0.13538E+04    0.40056E-08    0.67307E-13    0.19555E-16
+    2    4    0.46905E-08    0.10000E+01    0.10918E+04    0.84008E-08    0.25083E-12    0.39540E-16
+    2    4    0.46905E-08    0.10000E+01    0.88049E+03    0.17250E-07    0.92303E-12    0.79197E-16
+    2    4    0.46905E-08    0.10000E+01    0.71007E+03    0.34745E-07    0.33596E-11    0.15671E-15
+    2    4    0.46905E-08    0.10000E+01    0.57264E+03    0.68815E-07    0.11949E-10    0.30633E-15
+    2    4    0.46905E-08    0.10000E+01    0.46180E+03    0.13409E-06    0.40178E-10    0.59108E-15
+    2    4    0.46905E-08    0.10000E+01    0.37242E+03    0.25582E-06    0.12249E-09    0.11195E-14
+    2    4    0.46905E-08    0.10000E+01    0.30034E+03    0.47233E-06    0.32852E-09    0.20562E-14
+    2    4    0.46905E-08    0.10000E+01    0.24221E+03    0.83195E-06    0.76702E-09    0.36086E-14
+    2    4    0.46905E-08    0.10000E+01    0.19533E+03    0.13109E-05    0.14575E-08    0.56736E-14
+    2    4    0.46905E-08    0.10000E+01    0.15752E+03    0.13109E-05    0.14575E-08    0.56736E-14
+    2    4    0.81846E-08    0.10000E+01    0.80645E+05    0.12206E-54    0.91022E-66    0.18815E-61
+    2    4    0.81846E-08    0.10000E+01    0.65036E+05    0.10298E-53    0.14423E-64    0.15928E-60
+    2    4    0.81846E-08    0.10000E+01    0.52449E+05    0.87295E-53    0.19250E-63    0.13542E-59
+    2    4    0.81846E-08    0.10000E+01    0.42297E+05    0.65318E-52    0.25833E-62    0.10189E-58
+    2    4    0.81846E-08    0.10000E+01    0.34111E+05    0.46623E-51    0.34756E-61    0.73462E-58
+    2    4    0.81846E-08    0.10000E+01    0.27509E+05    0.32898E-50    0.45635E-60    0.52696E-57
+    2    4    0.81846E-08    0.10000E+01    0.22184E+05    0.22813E-49    0.58273E-59    0.37470E-56
+    2    4    0.81846E-08    0.10000E+01    0.17891E+05    0.15460E-48    0.73883E-58    0.26203E-55
+    2    4    0.81846E-08    0.10000E+01    0.14428E+05    0.10371E-47    0.98221E-57    0.17963E-54
+    2    4    0.81846E-08    0.10000E+01    0.11635E+05    0.71793E-47    0.14794E-55    0.12082E-53
+    2    4    0.81846E-08    0.10000E+01    0.93834E+04    0.55003E-46    0.26864E-54    0.79803E-53
+    2    4    0.81846E-08    0.10000E+01    0.75673E+04    0.50050E-45    0.58606E-53    0.51699E-52
+    2    4    0.81846E-08    0.10000E+01    0.61026E+04    0.54966E-44    0.14413E-51    0.33060E-51
+    2    4    0.81846E-08    0.10000E+01    0.49215E+04    0.69127E-43    0.37451E-50    0.21735E-50
+    2    4    0.81846E-08    0.10000E+01    0.39689E+04    0.93095E-42    0.99170E-49    0.16330E-49
+    2    4    0.81846E-08    0.10000E+01    0.32008E+04    0.40488E-39    0.85365E-46    0.49698E-47
+    2    4    0.81846E-08    0.10000E+01    0.25813E+04    0.29385E-30    0.14241E-36    0.31333E-38
+    2    4    0.81846E-08    0.10000E+01    0.20817E+04    0.55568E-14    0.11988E-19    0.56785E-22
+    2    4    0.81846E-08    0.10000E+01    0.16788E+04    0.18723E-08    0.17640E-13    0.18252E-16
+    2    4    0.81846E-08    0.10000E+01    0.13538E+04    0.40011E-08    0.66933E-13    0.35727E-16
+    2    4    0.81846E-08    0.10000E+01    0.10918E+04    0.83767E-08    0.24932E-12    0.70698E-16
+    2    4    0.81846E-08    0.10000E+01    0.88049E+03    0.17180E-07    0.91710E-12    0.13960E-15
+    2    4    0.81846E-08    0.10000E+01    0.71007E+03    0.34575E-07    0.33371E-11    0.27353E-15
+    2    4    0.81846E-08    0.10000E+01    0.57264E+03    0.68437E-07    0.11866E-10    0.53092E-15
+    2    4    0.81846E-08    0.10000E+01    0.46180E+03    0.13329E-06    0.39896E-10    0.10191E-14
+    2    4    0.81846E-08    0.10000E+01    0.37242E+03    0.25420E-06    0.12162E-09    0.19228E-14
+    2    4    0.81846E-08    0.10000E+01    0.30034E+03    0.46924E-06    0.32617E-09    0.35222E-14
+    2    4    0.81846E-08    0.10000E+01    0.24221E+03    0.82634E-06    0.76152E-09    0.61698E-14
+    2    4    0.81846E-08    0.10000E+01    0.19533E+03    0.13020E-05    0.14471E-08    0.96892E-14
+    2    4    0.81846E-08    0.10000E+01    0.15752E+03    0.13020E-05    0.14471E-08    0.96892E-14
+    2    4    0.14282E-07    0.10000E+01    0.80645E+05    0.21152E-54    0.15794E-65    0.55350E-61
+    2    4    0.14282E-07    0.10000E+01    0.65036E+05    0.17865E-53    0.25047E-64    0.46888E-60
+    2    4    0.14282E-07    0.10000E+01    0.52449E+05    0.15158E-52    0.33501E-63    0.39888E-59
+    2    4    0.14282E-07    0.10000E+01    0.42297E+05    0.11361E-51    0.45124E-62    0.30043E-58
+    2    4    0.14282E-07    0.10000E+01    0.34111E+05    0.81353E-51    0.61072E-61    0.21701E-57
+    2    4    0.14282E-07    0.10000E+01    0.27509E+05    0.57704E-50    0.80914E-60    0.15614E-56
+    2    4    0.14282E-07    0.10000E+01    0.22184E+05    0.40324E-49    0.10433E-58    0.11156E-55
+    2    4    0.14282E-07    0.10000E+01    0.17891E+05    0.27556E-48    0.13223E-57    0.78603E-55
+    2    4    0.14282E-07    0.10000E+01    0.14428E+05    0.18504E-47    0.17002E-56    0.54473E-54
+    2    4    0.14282E-07    0.10000E+01    0.11635E+05    0.12494E-46    0.23356E-55    0.37163E-53
+    2    4    0.14282E-07    0.10000E+01    0.93834E+04    0.88696E-46    0.36658E-54    0.24960E-52
+    2    4    0.14282E-07    0.10000E+01    0.75673E+04    0.70633E-45    0.69299E-53    0.16441E-51
+    2    4    0.14282E-07    0.10000E+01    0.61026E+04    0.67042E-44    0.15570E-51    0.10583E-50
+    2    4    0.14282E-07    0.10000E+01    0.49215E+04    0.76096E-43    0.38861E-50    0.67349E-50
+    2    4    0.14282E-07    0.10000E+01    0.39689E+04    0.97430E-42    0.10142E-48    0.44979E-49
+    2    4    0.14282E-07    0.10000E+01    0.32008E+04    0.41546E-39    0.86786E-46    0.11367E-46
+    2    4    0.14282E-07    0.10000E+01    0.25813E+04    0.29917E-30    0.14404E-36    0.63366E-38
+    2    4    0.14282E-07    0.10000E+01    0.20817E+04    0.56307E-14    0.12029E-19    0.11349E-21
+    2    4    0.14282E-07    0.10000E+01    0.16788E+04    0.18904E-08    0.17629E-13    0.36018E-16
+    2    4    0.14282E-07    0.10000E+01    0.13538E+04    0.40223E-08    0.66830E-13    0.67194E-16
+    2    4    0.14282E-07    0.10000E+01    0.10918E+04    0.83984E-08    0.24876E-12    0.12882E-15
+    2    4    0.14282E-07    0.10000E+01    0.88049E+03    0.17194E-07    0.91457E-12    0.24909E-15
+    2    4    0.14282E-07    0.10000E+01    0.71007E+03    0.34559E-07    0.33266E-11    0.48110E-15
+    2    4    0.14282E-07    0.10000E+01    0.57264E+03    0.68341E-07    0.11826E-10    0.92430E-15
+    2    4    0.14282E-07    0.10000E+01    0.46180E+03    0.13302E-06    0.39753E-10    0.17611E-14
+    2    4    0.14282E-07    0.10000E+01    0.37242E+03    0.25355E-06    0.12117E-09    0.33048E-14
+    2    4    0.14282E-07    0.10000E+01    0.30034E+03    0.46785E-06    0.32494E-09    0.60305E-14
+    2    4    0.14282E-07    0.10000E+01    0.24221E+03    0.82370E-06    0.75862E-09    0.10536E-13
+    2    4    0.14282E-07    0.10000E+01    0.19533E+03    0.12976E-05    0.14415E-08    0.16519E-13
+    2    4    0.14282E-07    0.10000E+01    0.15752E+03    0.12976E-05    0.14415E-08    0.16519E-13
+    2    4    0.24920E-07    0.10000E+01    0.80645E+05    0.36277E-54    0.27119E-65    0.16205E-60
+    2    4    0.24920E-07    0.10000E+01    0.65036E+05    0.30669E-53    0.43040E-64    0.13736E-59
+    2    4    0.24920E-07    0.10000E+01    0.52449E+05    0.26043E-52    0.57677E-63    0.11691E-58
+    2    4    0.24920E-07    0.10000E+01    0.42297E+05    0.19550E-51    0.77943E-62    0.88131E-58
+    2    4    0.24920E-07    0.10000E+01    0.34111E+05    0.14039E-50    0.10604E-60    0.63759E-57
+    2    4    0.24920E-07    0.10000E+01    0.27509E+05    0.10004E-49    0.14166E-59    0.45989E-56
+    2    4    0.24920E-07    0.10000E+01    0.22184E+05    0.70404E-49    0.18461E-58    0.32990E-55
+    2    4    0.24920E-07    0.10000E+01    0.17891E+05    0.48558E-48    0.23580E-57    0.23388E-54
+    2    4    0.24920E-07    0.10000E+01    0.14428E+05    0.32850E-47    0.30062E-56    0.16352E-53
+    2    4    0.24920E-07    0.10000E+01    0.11635E+05    0.22073E-46    0.39399E-55    0.11285E-52
+    2    4    0.24920E-07    0.10000E+01    0.93834E+04    0.15104E-45    0.55606E-54    0.76882E-52
+    2    4    0.24920E-07    0.10000E+01    0.75673E+04    0.10985E-44    0.90449E-53    0.51486E-51
+    2    4    0.24920E-07    0.10000E+01    0.61026E+04    0.90566E-44    0.17789E-51    0.33662E-50
+    2    4    0.24920E-07    0.10000E+01    0.49215E+04    0.89479E-43    0.41156E-50    0.21441E-49
+    2    4    0.24920E-07    0.10000E+01    0.39689E+04    0.10486E-41    0.10416E-48    0.13607E-48
+    2    4    0.24920E-07    0.10000E+01    0.32008E+04    0.42979E-39    0.88171E-46    0.29754E-46
+    2    4    0.24920E-07    0.10000E+01    0.25813E+04    0.30513E-30    0.14542E-36    0.14083E-37
+    2    4    0.24920E-07    0.10000E+01    0.20817E+04    0.57131E-14    0.12022E-19    0.24249E-21
+    2    4    0.24920E-07    0.10000E+01    0.16788E+04    0.19093E-08    0.17517E-13    0.75399E-16
+    2    4    0.24920E-07    0.10000E+01    0.13538E+04    0.40341E-08    0.66320E-13    0.13187E-15
+    2    4    0.24920E-07    0.10000E+01    0.10918E+04    0.83872E-08    0.24661E-12    0.24161E-15
+    2    4    0.24920E-07    0.10000E+01    0.88049E+03    0.17123E-07    0.90596E-12    0.45301E-15
+    2    4    0.24920E-07    0.10000E+01    0.71007E+03    0.34351E-07    0.32934E-11    0.85663E-15
+    2    4    0.24920E-07    0.10000E+01    0.57264E+03    0.67836E-07    0.11703E-10    0.16213E-14
+    2    4    0.24920E-07    0.10000E+01    0.46180E+03    0.13190E-06    0.39330E-10    0.30559E-14
+    2    4    0.24920E-07    0.10000E+01    0.37242E+03    0.25123E-06    0.11987E-09    0.56901E-14
+    2    4    0.24920E-07    0.10000E+01    0.30034E+03    0.46332E-06    0.32141E-09    0.10326E-13
+    2    4    0.24920E-07    0.10000E+01    0.24221E+03    0.81542E-06    0.75034E-09    0.17972E-13
+    2    4    0.24920E-07    0.10000E+01    0.19533E+03    0.12843E-05    0.14257E-08    0.28113E-13
+    2    4    0.24920E-07    0.10000E+01    0.15752E+03    0.12843E-05    0.14257E-08    0.28113E-13
+    2    4    0.43485E-07    0.10000E+01    0.80645E+05    0.61671E-54    0.46149E-65    0.46954E-60
+    2    4    0.43485E-07    0.10000E+01    0.65036E+05    0.52180E-53    0.73290E-64    0.39817E-59
+    2    4    0.43485E-07    0.10000E+01    0.52449E+05    0.44341E-52    0.98374E-63    0.33903E-58
+    2    4    0.43485E-07    0.10000E+01    0.42297E+05    0.33332E-51    0.13331E-61    0.25577E-57
+    2    4    0.43485E-07    0.10000E+01    0.34111E+05    0.23992E-50    0.18218E-60    0.18528E-56
+    2    4    0.43485E-07    0.10000E+01    0.27509E+05    0.17164E-49    0.24509E-59    0.13392E-55
+    2    4    0.43485E-07    0.10000E+01    0.22184E+05    0.12154E-48    0.32261E-58    0.96382E-55
+    2    4    0.43485E-07    0.10000E+01    0.17891E+05    0.84551E-48    0.41637E-57    0.68673E-54
+    2    4    0.43485E-07    0.10000E+01    0.14428E+05    0.57738E-47    0.53270E-56    0.48356E-53
+    2    4    0.43485E-07    0.10000E+01    0.11635E+05    0.38975E-46    0.68635E-55    0.33684E-52
+    2    4    0.43485E-07    0.10000E+01    0.93834E+04    0.26357E-45    0.91298E-54    0.23214E-51
+    2    4    0.43485E-07    0.10000E+01    0.75673E+04    0.18272E-44    0.13197E-52    0.15769E-50
+    2    4    0.43485E-07    0.10000E+01    0.61026E+04    0.13588E-43    0.22328E-51    0.10483E-49
+    2    4    0.43485E-07    0.10000E+01    0.49215E+04    0.11623E-42    0.45886E-50    0.67714E-49
+    2    4    0.43485E-07    0.10000E+01    0.39689E+04    0.11996E-41    0.10936E-48    0.42617E-48
+    2    4    0.43485E-07    0.10000E+01    0.32008E+04    0.45762E-39    0.90522E-46    0.86290E-46
+    2    4    0.43485E-07    0.10000E+01    0.25813E+04    0.31602E-30    0.14795E-36    0.35013E-37
+    2    4    0.43485E-07    0.10000E+01    0.20817E+04    0.58784E-14    0.12079E-19    0.55974E-21
+    2    4    0.43485E-07    0.10000E+01    0.16788E+04    0.19529E-08    0.17462E-13    0.16861E-15
+    2    4    0.43485E-07    0.10000E+01    0.13538E+04    0.40803E-08    0.65989E-13    0.27303E-15
+    2    4    0.43485E-07    0.10000E+01    0.10918E+04    0.84264E-08    0.24503E-12    0.47125E-15
+    2    4    0.43485E-07    0.10000E+01    0.88049E+03    0.17130E-07    0.89918E-12    0.84652E-15
+    2    4    0.43485E-07    0.10000E+01    0.71007E+03    0.34265E-07    0.32661E-11    0.15533E-14
+    2    4    0.43485E-07    0.10000E+01    0.57264E+03    0.67528E-07    0.11600E-10    0.28777E-14
+    2    4    0.43485E-07    0.10000E+01    0.46180E+03    0.13110E-06    0.38969E-10    0.53411E-14
+    2    4    0.43485E-07    0.10000E+01    0.37242E+03    0.24945E-06    0.11874E-09    0.98354E-14
+    2    4    0.43485E-07    0.10000E+01    0.30034E+03    0.45969E-06    0.31835E-09    0.17710E-13
+    2    4    0.43485E-07    0.10000E+01    0.24221E+03    0.80861E-06    0.74314E-09    0.30658E-13
+    2    4    0.43485E-07    0.10000E+01    0.19533E+03    0.12731E-05    0.14120E-08    0.47799E-13
+    2    4    0.43485E-07    0.10000E+01    0.15752E+03    0.12731E-05    0.14120E-08    0.47799E-13
+    2    4    0.75878E-07    0.10000E+01    0.80645E+05    0.10402E-53    0.77908E-65    0.13528E-59
+    2    4    0.75878E-07    0.10000E+01    0.65036E+05    0.88075E-53    0.12380E-63    0.11476E-58
+    2    4    0.75878E-07    0.10000E+01    0.52449E+05    0.74892E-52    0.16640E-62    0.97749E-58
+    2    4    0.75878E-07    0.10000E+01    0.42297E+05    0.56361E-51    0.22604E-61    0.73790E-57
+    2    4    0.75878E-07    0.10000E+01    0.34111E+05    0.40652E-50    0.31006E-60    0.53513E-56
+    2    4    0.75878E-07    0.10000E+01    0.27509E+05    0.29178E-49    0.41962E-59    0.38747E-55
+    2    4    0.75878E-07    0.10000E+01    0.22184E+05    0.20770E-48    0.55721E-58    0.27963E-54
+    2    4    0.75878E-07    0.10000E+01    0.17891E+05    0.14560E-47    0.72672E-57    0.20007E-53
+    2    4    0.75878E-07    0.10000E+01    0.14428E+05    0.10036E-46    0.93758E-56    0.14171E-52
+    2    4    0.75878E-07    0.10000E+01    0.11635E+05    0.68306E-46    0.12063E-54    0.99460E-52
+    2    4    0.75878E-07    0.10000E+01    0.93834E+04    0.46228E-45    0.15643E-53    0.69192E-51
+    2    4    0.75878E-07    0.10000E+01    0.75673E+04    0.31439E-44    0.21032E-52    0.47560E-50
+    2    4    0.75878E-07    0.10000E+01    0.61026E+04    0.22020E-43    0.31228E-51    0.32093E-49
+    2    4    0.75878E-07    0.10000E+01    0.49215E+04    0.16768E-42    0.55355E-50    0.21088E-48
+    2    4    0.75878E-07    0.10000E+01    0.39689E+04    0.14965E-41    0.11918E-48    0.13418E-47
+    2    4    0.75878E-07    0.10000E+01    0.32008E+04    0.51059E-39    0.94219E-46    0.26491E-45
+    2    4    0.75878E-07    0.10000E+01    0.25813E+04    0.33464E-30    0.15144E-36    0.96559E-37
+    2    4    0.75878E-07    0.10000E+01    0.20817E+04    0.61568E-14    0.12172E-19    0.13997E-20
+    2    4    0.75878E-07    0.10000E+01    0.16788E+04    0.20283E-08    0.17410E-13    0.40377E-15
+    2    4    0.75878E-07    0.10000E+01    0.13538E+04    0.41628E-08    0.65629E-13    0.60245E-15
+    2    4    0.75878E-07    0.10000E+01    0.10918E+04    0.85060E-08    0.24321E-12    0.96752E-15
+    2    4    0.75878E-07    0.10000E+01    0.88049E+03    0.17177E-07    0.89113E-12    0.16427E-14
+    2    4    0.75878E-07    0.10000E+01    0.71007E+03    0.34210E-07    0.32332E-11    0.28915E-14
+    2    4    0.75878E-07    0.10000E+01    0.57264E+03    0.67215E-07    0.11474E-10    0.51982E-14
+    2    4    0.75878E-07    0.10000E+01    0.46180E+03    0.13021E-06    0.38527E-10    0.94399E-14
+    2    4    0.75878E-07    0.10000E+01    0.37242E+03    0.24737E-06    0.11736E-09    0.17113E-13
+    2    4    0.75878E-07    0.10000E+01    0.30034E+03    0.45536E-06    0.31459E-09    0.30474E-13
+    2    4    0.75878E-07    0.10000E+01    0.24221E+03    0.80039E-06    0.73427E-09    0.52355E-13
+    2    4    0.75878E-07    0.10000E+01    0.19533E+03    0.12596E-05    0.13951E-08    0.81246E-13
+    2    4    0.75878E-07    0.10000E+01    0.15752E+03    0.12596E-05    0.13951E-08    0.81246E-13
+    2    4    0.13240E-06    0.10000E+01    0.80645E+05    0.17424E-53    0.13060E-64    0.38786E-59
+    2    4    0.13240E-06    0.10000E+01    0.65036E+05    0.14762E-52    0.20762E-63    0.32915E-58
+    2    4    0.13240E-06    0.10000E+01    0.52449E+05    0.12559E-51    0.27941E-62    0.28044E-57
+    2    4    0.13240E-06    0.10000E+01    0.42297E+05    0.94609E-51    0.38032E-61    0.21182E-56
+    2    4    0.13240E-06    0.10000E+01    0.34111E+05    0.68357E-50    0.52332E-60    0.15376E-55
+    2    4    0.13240E-06    0.10000E+01    0.27509E+05    0.49202E-49    0.71180E-59    0.11150E-54
+    2    4    0.13240E-06    0.10000E+01    0.22184E+05    0.35179E-48    0.95232E-58    0.80653E-54
+    2    4    0.13240E-06    0.10000E+01    0.17891E+05    0.24822E-47    0.12540E-56    0.57908E-53
+    2    4    0.13240E-06    0.10000E+01    0.14428E+05    0.17256E-46    0.16334E-55    0.41216E-52
+    2    4    0.13240E-06    0.10000E+01    0.11635E+05    0.11851E-45    0.21136E-54    0.29109E-51
+    2    4    0.13240E-06    0.10000E+01    0.93834E+04    0.80710E-45    0.27240E-53    0.20407E-50
+    2    4    0.13240E-06    0.10000E+01    0.75673E+04    0.54708E-44    0.35382E-52    0.14163E-49
+    2    4    0.13240E-06    0.10000E+01    0.61026E+04    0.37293E-43    0.48136E-51    0.96787E-49
+    2    4    0.13240E-06    0.10000E+01    0.49215E+04    0.26386E-42    0.74035E-50    0.64634E-48
+    2    4    0.13240E-06    0.10000E+01    0.39689E+04    0.20702E-41    0.13862E-48    0.41837E-47
+    2    4    0.13240E-06    0.10000E+01    0.32008E+04    0.61382E-39    0.10078E-45    0.82832E-45
+    2    4    0.13240E-06    0.10000E+01    0.25813E+04    0.36865E-30    0.15657E-36    0.28544E-36
+    2    4    0.13240E-06    0.10000E+01    0.20817E+04    0.66381E-14    0.12320E-19    0.37489E-20
+    2    4    0.13240E-06    0.10000E+01    0.16788E+04    0.21587E-08    0.17378E-13    0.10280E-14
+    2    4    0.13240E-06    0.10000E+01    0.13538E+04    0.43090E-08    0.65283E-13    0.14205E-14
+    2    4    0.13240E-06    0.10000E+01    0.10918E+04    0.86589E-08    0.24127E-12    0.21105E-14
+    2    4    0.13240E-06    0.10000E+01    0.88049E+03    0.17307E-07    0.88215E-12    0.33471E-14
+    2    4    0.13240E-06    0.10000E+01    0.71007E+03    0.34239E-07    0.31956E-11    0.55806E-14
+    2    4    0.13240E-06    0.10000E+01    0.57264E+03    0.66966E-07    0.11328E-10    0.96297E-14
+    2    4    0.13240E-06    0.10000E+01    0.46180E+03    0.12932E-06    0.38012E-10    0.16965E-13
+    2    4    0.13240E-06    0.10000E+01    0.37242E+03    0.24511E-06    0.11574E-09    0.30084E-13
+    2    4    0.13240E-06    0.10000E+01    0.30034E+03    0.45051E-06    0.31017E-09    0.52745E-13
+    2    4    0.13240E-06    0.10000E+01    0.24221E+03    0.79102E-06    0.72385E-09    0.89650E-13
+    2    4    0.13240E-06    0.10000E+01    0.19533E+03    0.12441E-05    0.13751E-08    0.13821E-12
+    2    4    0.13240E-06    0.10000E+01    0.15752E+03    0.12441E-05    0.13751E-08    0.13821E-12
+    2    4    0.23103E-06    0.10000E+01    0.80645E+05    0.29007E-53    0.21755E-64    0.11075E-58
+    2    4    0.23103E-06    0.10000E+01    0.65036E+05    0.24588E-52    0.34601E-63    0.94011E-58
+    2    4    0.23103E-06    0.10000E+01    0.52449E+05    0.20928E-51    0.46611E-62    0.80120E-57
+    2    4    0.23103E-06    0.10000E+01    0.42297E+05    0.15779E-50    0.63554E-61    0.60543E-56
+    2    4    0.23103E-06    0.10000E+01    0.34111E+05    0.11417E-49    0.87683E-60    0.43983E-55
+    2    4    0.23103E-06    0.10000E+01    0.27509E+05    0.82373E-49    0.11977E-58    0.31935E-54
+    2    4    0.23103E-06    0.10000E+01    0.22184E+05    0.59115E-48    0.16126E-57    0.23147E-53
+    2    4    0.23103E-06    0.10000E+01    0.17891E+05    0.41944E-47    0.21413E-56    0.16669E-52
+    2    4    0.23103E-06    0.10000E+01    0.14428E+05    0.29377E-46    0.28151E-55    0.11913E-51
+    2    4    0.23103E-06    0.10000E+01    0.11635E+05    0.20350E-45    0.36724E-54    0.84573E-51
+    2    4    0.23103E-06    0.10000E+01    0.93834E+04    0.13971E-44    0.47485E-53    0.59666E-50
+    2    4    0.23103E-06    0.10000E+01    0.75673E+04    0.95097E-44    0.60999E-52    0.41741E-49
+    2    4    0.23103E-06    0.10000E+01    0.61026E+04    0.64332E-43    0.79282E-51    0.28823E-48
+    2    4    0.23103E-06    0.10000E+01    0.49215E+04    0.43881E-42    0.10982E-49    0.19518E-47
+    2    4    0.23103E-06    0.10000E+01    0.39689E+04    0.31491E-41    0.17706E-48    0.12857E-46
+    2    4    0.23103E-06    0.10000E+01    0.32008E+04    0.81312E-39    0.11328E-45    0.25826E-44
+    2    4    0.23103E-06    0.10000E+01    0.25813E+04    0.43254E-30    0.16470E-36    0.87252E-36
+    2    4    0.23103E-06    0.10000E+01    0.20817E+04    0.74797E-14    0.12547E-19    0.10551E-19
+    2    4    0.23103E-06    0.10000E+01    0.16788E+04    0.23828E-08    0.17383E-13    0.27467E-14
+    2    4    0.23103E-06    0.10000E+01    0.13538E+04    0.45631E-08    0.65002E-13    0.35608E-14
+    2    4    0.23103E-06    0.10000E+01    0.10918E+04    0.89365E-08    0.23934E-12    0.49097E-14
+    2    4    0.23103E-06    0.10000E+01    0.88049E+03    0.17579E-07    0.87257E-12    0.72274E-14
+    2    4    0.23103E-06    0.10000E+01    0.71007E+03    0.34424E-07    0.31542E-11    0.11285E-13
+    2    4    0.23103E-06    0.10000E+01    0.57264E+03    0.66874E-07    0.11164E-10    0.18466E-13
+    2    4    0.23103E-06    0.10000E+01    0.46180E+03    0.12854E-06    0.37426E-10    0.31227E-13
+    2    4    0.23103E-06    0.10000E+01    0.37242E+03    0.24283E-06    0.11389E-09    0.53716E-13
+    2    4    0.23103E-06    0.10000E+01    0.30034E+03    0.44531E-06    0.30511E-09    0.92148E-13
+    2    4    0.23103E-06    0.10000E+01    0.24221E+03    0.78071E-06    0.71188E-09    0.15428E-12
+    2    4    0.23103E-06    0.10000E+01    0.19533E+03    0.12267E-05    0.13523E-08    0.23566E-12
+    2    4    0.23103E-06    0.10000E+01    0.15752E+03    0.12267E-05    0.13523E-08    0.23566E-12
+    2    4    0.40314E-06    0.10000E+01    0.80645E+05    0.48026E-53    0.36040E-64    0.31508E-58
+    2    4    0.40314E-06    0.10000E+01    0.65036E+05    0.40728E-52    0.57340E-63    0.26754E-57
+    2    4    0.40314E-06    0.10000E+01    0.52449E+05    0.34680E-51    0.77310E-62    0.22805E-56
+    2    4    0.40314E-06    0.10000E+01    0.42297E+05    0.26165E-50    0.10556E-60    0.17240E-55
+    2    4    0.40314E-06    0.10000E+01    0.34111E+05    0.18956E-49    0.14597E-59    0.12533E-54
+    2    4    0.40314E-06    0.10000E+01    0.27509E+05    0.13704E-48    0.20009E-58    0.91103E-54
+    2    4    0.40314E-06    0.10000E+01    0.22184E+05    0.98656E-48    0.27086E-57    0.66144E-53
+    2    4    0.40314E-06    0.10000E+01    0.17891E+05    0.70330E-47    0.36227E-56    0.47754E-52
+    2    4    0.40314E-06    0.10000E+01    0.14428E+05    0.49575E-46    0.48024E-55    0.34248E-51
+    2    4    0.40314E-06    0.10000E+01    0.11635E+05    0.34605E-45    0.63179E-54    0.24421E-50
+    2    4    0.40314E-06    0.10000E+01    0.93834E+04    0.23952E-44    0.82271E-53    0.17320E-49
+    2    4    0.40314E-06    0.10000E+01    0.75673E+04    0.16420E-43    0.10580E-51    0.12197E-48
+    2    4    0.40314E-06    0.10000E+01    0.61026E+04    0.11132E-42    0.13515E-50    0.84949E-48
+    2    4    0.40314E-06    0.10000E+01    0.49215E+04    0.74963E-42    0.17626E-49    0.58199E-47
+    2    4    0.40314E-06    0.10000E+01    0.39689E+04    0.51234E-41    0.25124E-48    0.38941E-46
+    2    4    0.40314E-06    0.10000E+01    0.32008E+04    0.11893E-38    0.13765E-45    0.79604E-44
+    2    4    0.40314E-06    0.10000E+01    0.25813E+04    0.55293E-30    0.17866E-36    0.26903E-35
+    2    4    0.40314E-06    0.10000E+01    0.20817E+04    0.89588E-14    0.12889E-19    0.30617E-19
+    2    4    0.40314E-06    0.10000E+01    0.16788E+04    0.27654E-08    0.17444E-13    0.75959E-14
+    2    4    0.40314E-06    0.10000E+01    0.13538E+04    0.49988E-08    0.64837E-13    0.93877E-14
+    2    4    0.40314E-06    0.10000E+01    0.10918E+04    0.94226E-08    0.23757E-12    0.12143E-13
+    2    4    0.40314E-06    0.10000E+01    0.88049E+03    0.18090E-07    0.86275E-12    0.16620E-13
+    2    4    0.40314E-06    0.10000E+01    0.71007E+03    0.34880E-07    0.31096E-11    0.24142E-13
+    2    4    0.40314E-06    0.10000E+01    0.57264E+03    0.67069E-07    0.10984E-10    0.37040E-13
+    2    4    0.40314E-06    0.10000E+01    0.46180E+03    0.12802E-06    0.36773E-10    0.59407E-13
+    2    4    0.40314E-06    0.10000E+01    0.37242E+03    0.24071E-06    0.11181E-09    0.98086E-13
+    2    4    0.40314E-06    0.10000E+01    0.30034E+03    0.44000E-06    0.29940E-09    0.16328E-12
+    2    4    0.40314E-06    0.10000E+01    0.24221E+03    0.76973E-06    0.69836E-09    0.26769E-12
+    2    4    0.40314E-06    0.10000E+01    0.19533E+03    0.12079E-05    0.13264E-08    0.40360E-12
+    2    4    0.40314E-06    0.10000E+01    0.15752E+03    0.12079E-05    0.13264E-08    0.40360E-12
+    2    4    0.70346E-06    0.10000E+01    0.80645E+05    0.79161E-53    0.59433E-64    0.89052E-58
+    2    4    0.70346E-06    0.10000E+01    0.65036E+05    0.67158E-52    0.94587E-63    0.75632E-57
+    2    4    0.70346E-06    0.10000E+01    0.52449E+05    0.57204E-51    0.12762E-61    0.64483E-56
+    2    4    0.70346E-06    0.10000E+01    0.42297E+05    0.43185E-50    0.17448E-60    0.48764E-55
+    2    4    0.70346E-06    0.10000E+01    0.34111E+05    0.31321E-49    0.24172E-59    0.35473E-54
+    2    4    0.70346E-06    0.10000E+01    0.27509E+05    0.22681E-48    0.33233E-58    0.25809E-53
+    2    4    0.70346E-06    0.10000E+01    0.22184E+05    0.16371E-47    0.45191E-57    0.18766E-52
+    2    4    0.70346E-06    0.10000E+01    0.17891E+05    0.11717E-46    0.60811E-56    0.13578E-51
+    2    4    0.70346E-06    0.10000E+01    0.14428E+05    0.83043E-46    0.81196E-55    0.97669E-51
+    2    4    0.70346E-06    0.10000E+01    0.11635E+05    0.58354E-45    0.10766E-53    0.69902E-50
+    2    4    0.70346E-06    0.10000E+01    0.93834E+04    0.40692E-44    0.14132E-52    0.49797E-49
+    2    4    0.70346E-06    0.10000E+01    0.75673E+04    0.28112E-43    0.18289E-51    0.35259E-48
+    2    4    0.70346E-06    0.10000E+01    0.61026E+04    0.19181E-42    0.23322E-50    0.24732E-47
+    2    4    0.70346E-06    0.10000E+01    0.49215E+04    0.12914E-41    0.29634E-49    0.17107E-46
+    2    4    0.70346E-06    0.10000E+01    0.39689E+04    0.86512E-41    0.39055E-48    0.11598E-45
+    2    4    0.70346E-06    0.10000E+01    0.32008E+04    0.18826E-38    0.18506E-45    0.24109E-43
+    2    4    0.70346E-06    0.10000E+01    0.25813E+04    0.77806E-30    0.20462E-36    0.82259E-35
+    2    4    0.70346E-06    0.10000E+01    0.20817E+04    0.11579E-13    0.13450E-19    0.89905E-19
+    2    4    0.70346E-06    0.10000E+01    0.16788E+04    0.34229E-08    0.17651E-13    0.21410E-13
+    2    4    0.70346E-06    0.10000E+01    0.13538E+04    0.57547E-08    0.65103E-13    0.25619E-13
+    2    4    0.70346E-06    0.10000E+01    0.10918E+04    0.10288E-07    0.23703E-12    0.31562E-13
+    2    4    0.70346E-06    0.10000E+01    0.88049E+03    0.19063E-07    0.85646E-12    0.40557E-13
+    2    4    0.70346E-06    0.10000E+01    0.71007E+03    0.35912E-07    0.30750E-11    0.54868E-13
+    2    4    0.70346E-06    0.10000E+01    0.57264E+03    0.68010E-07    0.10833E-10    0.78413E-13
+    2    4    0.70346E-06    0.10000E+01    0.46180E+03    0.12850E-06    0.36201E-10    0.11797E-12
+    2    4    0.70346E-06    0.10000E+01    0.37242E+03    0.23996E-06    0.10995E-09    0.18475E-12
+    2    4    0.70346E-06    0.10000E+01    0.30034E+03    0.43659E-06    0.29423E-09    0.29537E-12
+    2    4    0.70346E-06    0.10000E+01    0.24221E+03    0.76143E-06    0.68604E-09    0.47036E-12
+    2    4    0.70346E-06    0.10000E+01    0.19533E+03    0.11927E-05    0.13027E-08    0.69639E-12
+    2    4    0.70346E-06    0.10000E+01    0.15752E+03    0.11927E-05    0.13027E-08    0.69639E-12
+    2    4    0.12275E-05    0.10000E+01    0.80645E+05    0.12987E-52    0.97542E-64    0.25163E-57
+    2    4    0.12275E-05    0.10000E+01    0.65036E+05    0.11021E-51    0.15528E-62    0.21375E-56
+    2    4    0.12275E-05    0.10000E+01    0.52449E+05    0.93905E-51    0.20965E-61    0.18228E-55
+    2    4    0.12275E-05    0.10000E+01    0.42297E+05    0.70930E-50    0.28693E-60    0.13788E-54
+    2    4    0.12275E-05    0.10000E+01    0.34111E+05    0.51490E-49    0.39816E-59    0.10035E-53
+    2    4    0.12275E-05    0.10000E+01    0.27509E+05    0.37341E-48    0.54881E-58    0.73077E-53
+    2    4    0.12275E-05    0.10000E+01    0.22184E+05    0.27015E-47    0.74916E-57    0.53203E-52
+    2    4    0.12275E-05    0.10000E+01    0.17891E+05    0.19401E-46    0.10134E-55    0.38568E-51
+    2    4    0.12275E-05    0.10000E+01    0.14428E+05    0.13814E-45    0.13615E-54    0.27814E-50
+    2    4    0.12275E-05    0.10000E+01    0.11635E+05    0.97632E-45    0.18180E-53    0.19970E-49
+    2    4    0.12275E-05    0.10000E+01    0.93834E+04    0.68536E-44    0.24052E-52    0.14281E-48
+    2    4    0.12275E-05    0.10000E+01    0.75673E+04    0.47701E-43    0.31381E-51    0.10159E-47
+    2    4    0.12275E-05    0.10000E+01    0.61026E+04    0.32799E-42    0.40241E-50    0.71681E-47
+    2    4    0.12275E-05    0.10000E+01    0.49215E+04    0.22209E-41    0.50824E-49    0.49981E-46
+    2    4    0.12275E-05    0.10000E+01    0.39689E+04    0.14824E-40    0.64407E-48    0.34263E-45
+    2    4    0.12275E-05    0.10000E+01    0.32008E+04    0.31267E-38    0.27415E-45    0.72276E-43
+    2    4    0.12275E-05    0.10000E+01    0.25813E+04    0.11881E-29    0.25217E-36    0.24975E-34
+    2    4    0.12275E-05    0.10000E+01    0.20817E+04    0.16132E-13    0.14237E-19    0.26619E-18
+    2    4    0.12275E-05    0.10000E+01    0.16788E+04    0.45236E-08    0.17898E-13    0.61313E-13
+    2    4    0.12275E-05    0.10000E+01    0.13538E+04    0.70065E-08    0.65358E-13    0.71932E-13
+    2    4    0.12275E-05    0.10000E+01    0.10918E+04    0.11700E-07    0.23603E-12    0.85667E-13
+    2    4    0.12275E-05    0.10000E+01    0.88049E+03    0.20622E-07    0.84724E-12    0.10476E-12
+    2    4    0.12275E-05    0.10000E+01    0.71007E+03    0.37545E-07    0.30266E-11    0.13305E-12
+    2    4    0.12275E-05    0.10000E+01    0.57264E+03    0.69500E-07    0.10623E-10    0.17705E-12
+    2    4    0.12275E-05    0.10000E+01    0.46180E+03    0.12933E-06    0.35417E-10    0.24788E-12
+    2    4    0.12275E-05    0.10000E+01    0.37242E+03    0.23906E-06    0.10742E-09    0.36368E-12
+    2    4    0.12275E-05    0.10000E+01    0.30034E+03    0.43204E-06    0.28719E-09    0.55113E-12
+    2    4    0.12275E-05    0.10000E+01    0.24221E+03    0.75016E-06    0.66927E-09    0.84304E-12
+    2    4    0.12275E-05    0.10000E+01    0.19533E+03    0.11720E-05    0.12704E-08    0.12163E-11
+    2    4    0.12275E-05    0.10000E+01    0.15752E+03    0.11720E-05    0.12704E-08    0.12163E-11
+    2    4    0.21419E-05    0.10000E+01    0.80645E+05    0.21221E-52    0.15944E-63    0.70527E-57
+    2    4    0.21419E-05    0.10000E+01    0.65036E+05    0.18014E-51    0.25388E-62    0.59921E-56
+    2    4    0.21419E-05    0.10000E+01    0.52449E+05    0.15353E-50    0.34296E-61    0.51104E-55
+    2    4    0.21419E-05    0.10000E+01    0.42297E+05    0.11602E-49    0.46983E-60    0.38668E-54
+    2    4    0.21419E-05    0.10000E+01    0.34111E+05    0.84287E-49    0.65286E-59    0.28157E-53
+    2    4    0.21419E-05    0.10000E+01    0.27509E+05    0.61203E-48    0.90186E-58    0.20518E-52
+    2    4    0.21419E-05    0.10000E+01    0.22184E+05    0.44364E-47    0.12352E-56    0.14954E-51
+    2    4    0.21419E-05    0.10000E+01    0.17891E+05    0.31954E-46    0.16782E-55    0.10858E-50
+    2    4    0.21419E-05    0.10000E+01    0.14428E+05    0.22843E-45    0.22668E-54    0.78480E-50
+    2    4    0.21419E-05    0.10000E+01    0.11635E+05    0.16224E-44    0.30454E-53    0.56500E-49
+    2    4    0.21419E-05    0.10000E+01    0.93834E+04    0.11455E-43    0.40577E-52    0.40533E-48
+    2    4    0.21419E-05    0.10000E+01    0.75673E+04    0.80263E-43    0.53379E-51    0.28945E-47
+    2    4    0.21419E-05    0.10000E+01    0.61026E+04    0.55614E-42    0.69026E-50    0.20525E-46
+    2    4    0.21419E-05    0.10000E+01    0.49215E+04    0.37955E-41    0.87542E-49    0.14406E-45
+    2    4    0.21419E-05    0.10000E+01    0.39689E+04    0.25451E-40    0.10952E-47    0.99653E-45
+    2    4    0.21419E-05    0.10000E+01    0.32008E+04    0.53160E-38    0.43834E-45    0.21281E-42
+    2    4    0.21419E-05    0.10000E+01    0.25813E+04    0.19236E-29    0.34147E-36    0.74461E-34
+    2    4    0.21419E-05    0.10000E+01    0.20817E+04    0.24057E-13    0.15499E-19    0.78242E-18
+    2    4    0.21419E-05    0.10000E+01    0.16788E+04    0.63808E-08    0.18292E-13    0.17573E-12
+    2    4    0.21419E-05    0.10000E+01    0.13538E+04    0.91166E-08    0.65935E-13    0.20408E-12
+    2    4    0.21419E-05    0.10000E+01    0.10918E+04    0.14078E-07    0.23566E-12    0.23811E-12
+    2    4    0.21419E-05    0.10000E+01    0.88049E+03    0.23263E-07    0.83886E-12    0.28146E-12
+    2    4    0.21419E-05    0.10000E+01    0.71007E+03    0.40382E-07    0.29773E-11    0.34041E-12
+    2    4    0.21419E-05    0.10000E+01    0.57264E+03    0.72311E-07    0.10401E-10    0.42560E-12
+    2    4    0.21419E-05    0.10000E+01    0.46180E+03    0.13157E-06    0.34570E-10    0.55491E-12
+    2    4    0.21419E-05    0.10000E+01    0.37242E+03    0.23958E-06    0.10464E-09    0.75724E-12
+    2    4    0.21419E-05    0.10000E+01    0.30034E+03    0.42872E-06    0.27946E-09    0.10747E-11
+    2    4    0.21419E-05    0.10000E+01    0.24221E+03    0.73966E-06    0.65080E-09    0.15586E-11
+    2    4    0.21419E-05    0.10000E+01    0.19533E+03    0.11512E-05    0.12349E-08    0.21692E-11
+    2    4    0.21419E-05    0.10000E+01    0.15752E+03    0.11512E-05    0.12349E-08    0.21692E-11
+    2    4    0.37375E-05    0.10000E+01    0.80645E+05    0.34522E-52    0.25947E-63    0.19320E-56
+    2    4    0.37375E-05    0.10000E+01    0.65036E+05    0.29314E-51    0.41323E-62    0.16417E-55
+    2    4    0.37375E-05    0.10000E+01    0.52449E+05    0.24988E-50    0.55850E-61    0.14003E-54
+    2    4    0.37375E-05    0.10000E+01    0.42297E+05    0.18890E-49    0.76570E-60    0.10598E-53
+    2    4    0.37375E-05    0.10000E+01    0.34111E+05    0.13734E-48    0.10653E-58    0.77200E-53
+    2    4    0.37375E-05    0.10000E+01    0.27509E+05    0.99831E-48    0.14743E-57    0.56290E-52
+    2    4    0.37375E-05    0.10000E+01    0.22184E+05    0.72486E-47    0.20249E-56    0.41063E-51
+    2    4    0.37375E-05    0.10000E+01    0.17891E+05    0.52338E-46    0.27617E-55    0.29856E-50
+    2    4    0.37375E-05    0.10000E+01    0.14428E+05    0.37542E-45    0.37473E-54    0.21618E-49
+    2    4    0.37375E-05    0.10000E+01    0.11635E+05    0.26777E-44    0.50608E-53    0.15598E-48
+    2    4    0.37375E-05    0.10000E+01    0.93834E+04    0.19000E-43    0.67853E-52    0.11219E-47
+    2    4    0.37375E-05    0.10000E+01    0.75673E+04    0.13391E-42    0.89939E-51    0.80365E-47
+    2    4    0.37375E-05    0.10000E+01    0.61026E+04    0.93445E-42    0.11734E-49    0.57214E-46
+    2    4    0.37375E-05    0.10000E+01    0.49215E+04    0.64296E-41    0.15006E-48    0.40367E-45
+    2    4    0.37375E-05    0.10000E+01    0.39689E+04    0.43456E-40    0.18798E-47    0.28123E-44
+    2    4    0.37375E-05    0.10000E+01    0.32008E+04    0.90921E-38    0.73273E-45    0.60638E-42
+    2    4    0.37375E-05    0.10000E+01    0.25813E+04    0.32155E-29    0.50664E-36    0.21446E-33
+    2    4    0.37375E-05    0.10000E+01    0.20817E+04    0.37710E-13    0.17623E-19    0.22371E-17
+    2    4    0.37375E-05    0.10000E+01    0.16788E+04    0.94971E-08    0.18902E-13    0.49353E-12
+    2    4    0.37375E-05    0.10000E+01    0.13538E+04    0.12659E-07    0.66936E-13    0.57106E-12
+    2    4    0.37375E-05    0.10000E+01    0.10918E+04    0.18070E-07    0.23608E-12    0.65934E-12
+    2    4    0.37375E-05    0.10000E+01    0.88049E+03    0.27705E-07    0.83157E-12    0.76383E-12
+    2    4    0.37375E-05    0.10000E+01    0.71007E+03    0.45208E-07    0.29274E-11    0.89427E-12
+    2    4    0.37375E-05    0.10000E+01    0.57264E+03    0.77292E-07    0.10166E-10    0.10673E-11
+    2    4    0.37375E-05    0.10000E+01    0.46180E+03    0.13612E-06    0.33656E-10    0.13110E-11
+    2    4    0.37375E-05    0.10000E+01    0.37242E+03    0.24246E-06    0.10163E-09    0.16702E-11
+    2    4    0.37375E-05    0.10000E+01    0.30034E+03    0.42762E-06    0.27100E-09    0.22097E-11
+    2    4    0.37375E-05    0.10000E+01    0.24221E+03    0.73091E-06    0.63055E-09    0.30083E-11
+    2    4    0.37375E-05    0.10000E+01    0.19533E+03    0.11314E-05    0.11959E-08    0.39975E-11
+    2    4    0.37375E-05    0.10000E+01    0.15752E+03    0.11314E-05    0.11959E-08    0.39975E-11
+    2    4    0.65217E-05    0.10000E+01    0.80645E+05    0.56078E-52    0.42159E-63    0.49084E-56
+    2    4    0.65217E-05    0.10000E+01    0.65036E+05    0.47627E-51    0.67152E-62    0.41712E-55
+    2    4    0.65217E-05    0.10000E+01    0.52449E+05    0.40606E-50    0.90795E-61    0.35583E-54
+    2    4    0.65217E-05    0.10000E+01    0.42297E+05    0.30707E-49    0.12456E-59    0.26934E-53
+    2    4    0.65217E-05    0.10000E+01    0.34111E+05    0.22337E-48    0.17346E-58    0.19625E-52
+    2    4    0.65217E-05    0.10000E+01    0.27509E+05    0.16251E-47    0.24043E-57    0.14316E-51
+    2    4    0.65217E-05    0.10000E+01    0.22184E+05    0.11815E-46    0.33096E-56    0.10450E-50
+    2    4    0.65217E-05    0.10000E+01    0.17891E+05    0.85483E-46    0.45273E-55    0.76054E-50
+    2    4    0.65217E-05    0.10000E+01    0.14428E+05    0.61483E-45    0.61652E-54    0.55139E-49
+    2    4    0.65217E-05    0.10000E+01    0.11635E+05    0.43999E-44    0.83609E-53    0.39848E-48
+    2    4    0.65217E-05    0.10000E+01    0.93834E+04    0.31343E-43    0.11266E-51    0.28715E-47
+    2    4    0.65217E-05    0.10000E+01    0.75673E+04    0.22195E-42    0.15026E-50    0.20616E-46
+    2    4    0.65217E-05    0.10000E+01    0.61026E+04    0.15577E-41    0.19755E-49    0.14718E-45
+    2    4    0.65217E-05    0.10000E+01    0.49215E+04    0.10794E-40    0.25486E-48    0.10422E-44
+    2    4    0.65217E-05    0.10000E+01    0.39689E+04    0.73540E-40    0.32148E-47    0.72973E-44
+    2    4    0.65217E-05    0.10000E+01    0.32008E+04    0.15482E-37    0.12461E-44    0.15841E-41
+    2    4    0.65217E-05    0.10000E+01    0.25813E+04    0.54369E-29    0.80715E-36    0.56460E-33
+    2    4    0.65217E-05    0.10000E+01    0.20817E+04    0.61095E-13    0.21799E-19    0.58705E-17
+    2    4    0.65217E-05    0.10000E+01    0.16788E+04    0.14769E-07    0.20541E-13    0.12807E-11
+    2    4    0.65217E-05    0.10000E+01    0.13538E+04    0.18736E-07    0.71075E-13    0.14816E-11
+    2    4    0.65217E-05    0.10000E+01    0.10918E+04    0.25070E-07    0.24664E-12    0.17040E-11
+    2    4    0.65217E-05    0.10000E+01    0.88049E+03    0.35798E-07    0.85812E-12    0.19550E-11
+    2    4    0.65217E-05    0.10000E+01    0.71007E+03    0.54634E-07    0.29926E-11    0.22489E-11
+    2    4    0.65217E-05    0.10000E+01    0.57264E+03    0.88379E-07    0.10322E-10    0.26106E-11
+    2    4    0.65217E-05    0.10000E+01    0.46180E+03    0.14930E-06    0.34017E-10    0.30827E-11
+    2    4    0.65217E-05    0.10000E+01    0.37242E+03    0.25827E-06    0.10243E-09    0.37337E-11
+    2    4    0.65217E-05    0.10000E+01    0.30034E+03    0.44672E-06    0.27267E-09    0.46618E-11
+    2    4    0.65217E-05    0.10000E+01    0.24221E+03    0.75401E-06    0.63377E-09    0.59861E-11
+    2    4    0.65217E-05    0.10000E+01    0.19533E+03    0.11587E-05    0.12012E-08    0.75884E-11
+    2    4    0.65217E-05    0.10000E+01    0.15752E+03    0.11587E-05    0.12012E-08    0.75884E-11
+    2    4    0.11380E-04    0.10000E+01    0.80645E+05    0.97853E-52    0.73564E-63    0.85648E-56
+    2    4    0.11380E-04    0.10000E+01    0.65036E+05    0.83106E-51    0.11718E-61    0.72786E-55
+    2    4    0.11380E-04    0.10000E+01    0.52449E+05    0.70855E-50    0.15843E-60    0.62089E-54
+    2    4    0.11380E-04    0.10000E+01    0.42297E+05    0.53582E-49    0.21735E-59    0.46998E-53
+    2    4    0.11380E-04    0.10000E+01    0.34111E+05    0.38976E-48    0.30268E-58    0.34244E-52
+    2    4    0.11380E-04    0.10000E+01    0.27509E+05    0.28357E-47    0.41954E-57    0.24980E-51
+    2    4    0.11380E-04    0.10000E+01    0.22184E+05    0.20617E-46    0.57750E-56    0.18235E-50
+    2    4    0.11380E-04    0.10000E+01    0.17891E+05    0.14916E-45    0.78999E-55    0.13271E-49
+    2    4    0.11380E-04    0.10000E+01    0.14428E+05    0.10728E-44    0.10758E-53    0.96214E-49
+    2    4    0.11380E-04    0.10000E+01    0.11635E+05    0.76775E-44    0.14589E-52    0.69532E-48
+    2    4    0.11380E-04    0.10000E+01    0.93834E+04    0.54692E-43    0.19658E-51    0.50106E-47
+    2    4    0.11380E-04    0.10000E+01    0.75673E+04    0.38729E-42    0.26219E-50    0.35973E-46
+    2    4    0.11380E-04    0.10000E+01    0.61026E+04    0.27181E-41    0.34471E-49    0.25682E-45
+    2    4    0.11380E-04    0.10000E+01    0.49215E+04    0.18835E-40    0.44471E-48    0.18186E-44
+    2    4    0.11380E-04    0.10000E+01    0.39689E+04    0.12832E-39    0.56096E-47    0.12733E-43
+    2    4    0.11380E-04    0.10000E+01    0.32008E+04    0.27015E-37    0.21743E-44    0.27641E-41
+    2    4    0.11380E-04    0.10000E+01    0.25813E+04    0.94870E-29    0.14084E-35    0.98519E-33
+    2    4    0.11380E-04    0.10000E+01    0.20817E+04    0.10661E-12    0.38038E-19    0.10244E-16
+    2    4    0.11380E-04    0.10000E+01    0.16788E+04    0.25771E-07    0.35842E-13    0.22348E-11
+    2    4    0.11380E-04    0.10000E+01    0.13538E+04    0.32694E-07    0.12402E-12    0.25853E-11
+    2    4    0.11380E-04    0.10000E+01    0.10918E+04    0.43746E-07    0.43036E-12    0.29733E-11
+    2    4    0.11380E-04    0.10000E+01    0.88049E+03    0.62465E-07    0.14974E-11    0.34114E-11
+    2    4    0.11380E-04    0.10000E+01    0.71007E+03    0.95333E-07    0.52219E-11    0.39242E-11
+    2    4    0.11380E-04    0.10000E+01    0.57264E+03    0.15422E-06    0.18012E-10    0.45553E-11
+    2    4    0.11380E-04    0.10000E+01    0.46180E+03    0.26052E-06    0.59357E-10    0.53792E-11
+    2    4    0.11380E-04    0.10000E+01    0.37242E+03    0.45067E-06    0.17873E-09    0.65150E-11
+    2    4    0.11380E-04    0.10000E+01    0.30034E+03    0.77950E-06    0.47579E-09    0.81346E-11
+    2    4    0.11380E-04    0.10000E+01    0.24221E+03    0.13157E-05    0.11059E-08    0.10445E-10
+    2    4    0.11380E-04    0.10000E+01    0.19533E+03    0.20219E-05    0.20961E-08    0.13241E-10
+    2    4    0.11380E-04    0.10000E+01    0.15752E+03    0.20219E-05    0.20961E-08    0.13241E-10
+    2    4    0.19857E-04    0.10000E+01    0.80645E+05    0.17075E-51    0.12837E-62    0.14945E-55
+    2    4    0.19857E-04    0.10000E+01    0.65036E+05    0.14502E-50    0.20447E-61    0.12701E-54
+    2    4    0.19857E-04    0.10000E+01    0.52449E+05    0.12364E-49    0.27645E-60    0.10834E-53
+    2    4    0.19857E-04    0.10000E+01    0.42297E+05    0.93497E-49    0.37926E-59    0.82009E-53
+    2    4    0.19857E-04    0.10000E+01    0.34111E+05    0.68011E-48    0.52816E-58    0.59755E-52
+    2    4    0.19857E-04    0.10000E+01    0.27509E+05    0.49481E-47    0.73207E-57    0.43588E-51
+    2    4    0.19857E-04    0.10000E+01    0.22184E+05    0.35976E-46    0.10077E-55    0.31819E-50
+    2    4    0.19857E-04    0.10000E+01    0.17891E+05    0.26028E-45    0.13785E-54    0.23157E-49
+    2    4    0.19857E-04    0.10000E+01    0.14428E+05    0.18720E-44    0.18772E-53    0.16789E-48
+    2    4    0.19857E-04    0.10000E+01    0.11635E+05    0.13397E-43    0.25457E-52    0.12133E-47
+    2    4    0.19857E-04    0.10000E+01    0.93834E+04    0.95433E-43    0.34302E-51    0.87431E-47
+    2    4    0.19857E-04    0.10000E+01    0.75673E+04    0.67580E-42    0.45751E-50    0.62771E-46
+    2    4    0.19857E-04    0.10000E+01    0.61026E+04    0.47430E-41    0.60149E-49    0.44814E-45
+    2    4    0.19857E-04    0.10000E+01    0.49215E+04    0.32865E-40    0.77599E-48    0.31734E-44
+    2    4    0.19857E-04    0.10000E+01    0.39689E+04    0.22391E-39    0.97883E-47    0.22219E-43
+    2    4    0.19857E-04    0.10000E+01    0.32008E+04    0.47140E-37    0.37941E-44    0.48233E-41
+    2    4    0.19857E-04    0.10000E+01    0.25813E+04    0.16554E-28    0.24576E-35    0.17191E-32
+    2    4    0.19857E-04    0.10000E+01    0.20817E+04    0.18602E-12    0.66374E-19    0.17875E-16
+    2    4    0.19857E-04    0.10000E+01    0.16788E+04    0.44969E-07    0.62543E-13    0.38995E-11
+    2    4    0.19857E-04    0.10000E+01    0.13538E+04    0.57049E-07    0.21641E-12    0.45112E-11
+    2    4    0.19857E-04    0.10000E+01    0.10918E+04    0.76334E-07    0.75096E-12    0.51882E-11
+    2    4    0.19857E-04    0.10000E+01    0.88049E+03    0.10900E-06    0.26128E-11    0.59526E-11
+    2    4    0.19857E-04    0.10000E+01    0.71007E+03    0.16635E-06    0.91119E-11    0.68474E-11
+    2    4    0.19857E-04    0.10000E+01    0.57264E+03    0.26910E-06    0.31430E-10    0.79488E-11
+    2    4    0.19857E-04    0.10000E+01    0.46180E+03    0.45460E-06    0.10357E-09    0.93863E-11
+    2    4    0.19857E-04    0.10000E+01    0.37242E+03    0.78639E-06    0.31187E-09    0.11368E-10
+    2    4    0.19857E-04    0.10000E+01    0.30034E+03    0.13602E-05    0.83023E-09    0.14194E-10
+    2    4    0.19857E-04    0.10000E+01    0.24221E+03    0.22958E-05    0.19297E-08    0.18226E-10
+    2    4    0.19857E-04    0.10000E+01    0.19533E+03    0.35281E-05    0.36576E-08    0.23105E-10
+    2    4    0.19857E-04    0.10000E+01    0.15752E+03    0.35281E-05    0.36576E-08    0.23105E-10
+    2    4    0.34650E-04    0.10000E+01    0.80645E+05    0.29794E-51    0.22399E-62    0.26078E-55
+    2    4    0.34650E-04    0.10000E+01    0.65036E+05    0.25304E-50    0.35678E-61    0.22162E-54
+    2    4    0.34650E-04    0.10000E+01    0.52449E+05    0.21574E-49    0.48240E-60    0.18905E-53
+    2    4    0.34650E-04    0.10000E+01    0.42297E+05    0.16315E-48    0.66179E-59    0.14310E-52
+    2    4    0.34650E-04    0.10000E+01    0.34111E+05    0.11868E-47    0.92160E-58    0.10427E-51
+    2    4    0.34650E-04    0.10000E+01    0.27509E+05    0.86342E-47    0.12774E-56    0.76059E-51
+    2    4    0.34650E-04    0.10000E+01    0.22184E+05    0.62776E-46    0.17584E-55    0.55522E-50
+    2    4    0.34650E-04    0.10000E+01    0.17891E+05    0.45417E-45    0.24054E-54    0.40407E-49
+    2    4    0.34650E-04    0.10000E+01    0.14428E+05    0.32666E-44    0.32756E-53    0.29295E-48
+    2    4    0.34650E-04    0.10000E+01    0.11635E+05    0.23377E-43    0.44421E-52    0.21171E-47
+    2    4    0.34650E-04    0.10000E+01    0.93834E+04    0.16653E-42    0.59855E-51    0.15256E-46
+    2    4    0.34650E-04    0.10000E+01    0.75673E+04    0.11792E-41    0.79833E-50    0.10953E-45
+    2    4    0.34650E-04    0.10000E+01    0.61026E+04    0.82762E-41    0.10496E-48    0.78197E-45
+    2    4    0.34650E-04    0.10000E+01    0.49215E+04    0.57348E-40    0.13541E-47    0.55374E-44
+    2    4    0.34650E-04    0.10000E+01    0.39689E+04    0.39072E-39    0.17080E-46    0.38771E-43
+    2    4    0.34650E-04    0.10000E+01    0.32008E+04    0.82257E-37    0.66205E-44    0.84163E-41
+    2    4    0.34650E-04    0.10000E+01    0.25813E+04    0.28886E-28    0.42884E-35    0.29997E-32
+    2    4    0.34650E-04    0.10000E+01    0.20817E+04    0.32460E-12    0.11582E-18    0.31190E-16
+    2    4    0.34650E-04    0.10000E+01    0.16788E+04    0.78468E-07    0.10913E-12    0.68044E-11
+    2    4    0.34650E-04    0.10000E+01    0.13538E+04    0.99547E-07    0.37762E-12    0.78718E-11
+    2    4    0.34650E-04    0.10000E+01    0.10918E+04    0.13320E-06    0.13104E-11    0.90531E-11
+    2    4    0.34650E-04    0.10000E+01    0.88049E+03    0.19019E-06    0.45592E-11    0.10387E-10
+    2    4    0.34650E-04    0.10000E+01    0.71007E+03    0.29027E-06    0.15900E-10    0.11948E-10
+    2    4    0.34650E-04    0.10000E+01    0.57264E+03    0.46956E-06    0.54843E-10    0.13870E-10
+    2    4    0.34650E-04    0.10000E+01    0.46180E+03    0.79325E-06    0.18073E-09    0.16379E-10
+    2    4    0.34650E-04    0.10000E+01    0.37242E+03    0.13722E-05    0.54420E-09    0.19837E-10
+    2    4    0.34650E-04    0.10000E+01    0.30034E+03    0.23734E-05    0.14487E-08    0.24768E-10
+    2    4    0.34650E-04    0.10000E+01    0.24221E+03    0.40061E-05    0.33672E-08    0.31804E-10
+    2    4    0.34650E-04    0.10000E+01    0.19533E+03    0.61563E-05    0.63823E-08    0.40317E-10
+    2    4    0.34650E-04    0.10000E+01    0.15752E+03    0.61563E-05    0.63823E-08    0.40317E-10
+    2    4    0.60462E-04    0.10000E+01    0.80645E+05    0.51989E-51    0.39085E-62    0.45505E-55
+    2    4    0.60462E-04    0.10000E+01    0.65036E+05    0.44154E-50    0.62256E-61    0.38671E-54
+    2    4    0.60462E-04    0.10000E+01    0.52449E+05    0.37645E-49    0.84175E-60    0.32988E-53
+    2    4    0.60462E-04    0.10000E+01    0.42297E+05    0.28468E-48    0.11548E-58    0.24970E-52
+    2    4    0.60462E-04    0.10000E+01    0.34111E+05    0.20708E-47    0.16081E-57    0.18194E-51
+    2    4    0.60462E-04    0.10000E+01    0.27509E+05    0.15066E-46    0.22290E-56    0.13272E-50
+    2    4    0.60462E-04    0.10000E+01    0.22184E+05    0.10954E-45    0.30683E-55    0.96882E-50
+    2    4    0.60462E-04    0.10000E+01    0.17891E+05    0.79250E-45    0.41972E-54    0.70509E-49
+    2    4    0.60462E-04    0.10000E+01    0.14428E+05    0.57000E-44    0.57157E-53    0.51119E-48
+    2    4    0.60462E-04    0.10000E+01    0.11635E+05    0.40791E-43    0.77513E-52    0.36942E-47
+    2    4    0.60462E-04    0.10000E+01    0.93834E+04    0.29058E-42    0.10444E-50    0.26621E-46
+    2    4    0.60462E-04    0.10000E+01    0.75673E+04    0.20577E-41    0.13930E-49    0.19112E-45
+    2    4    0.60462E-04    0.10000E+01    0.61026E+04    0.14441E-40    0.18314E-48    0.13645E-44
+    2    4    0.60462E-04    0.10000E+01    0.49215E+04    0.10007E-39    0.23627E-47    0.96625E-44
+    2    4    0.60462E-04    0.10000E+01    0.39689E+04    0.68178E-39    0.29804E-46    0.67653E-43
+    2    4    0.60462E-04    0.10000E+01    0.32008E+04    0.14353E-36    0.11552E-43    0.14686E-40
+    2    4    0.60462E-04    0.10000E+01    0.25813E+04    0.50405E-28    0.74830E-35    0.52343E-32
+    2    4    0.60462E-04    0.10000E+01    0.20817E+04    0.56640E-12    0.20210E-18    0.54425E-16
+    2    4    0.60462E-04    0.10000E+01    0.16788E+04    0.13692E-06    0.19043E-12    0.11873E-10
+    2    4    0.60462E-04    0.10000E+01    0.13538E+04    0.17370E-06    0.65892E-12    0.13736E-10
+    2    4    0.60462E-04    0.10000E+01    0.10918E+04    0.23242E-06    0.22865E-11    0.15797E-10
+    2    4    0.60462E-04    0.10000E+01    0.88049E+03    0.33188E-06    0.79555E-11    0.18125E-10
+    2    4    0.60462E-04    0.10000E+01    0.71007E+03    0.50650E-06    0.27744E-10    0.20849E-10
+    2    4    0.60462E-04    0.10000E+01    0.57264E+03    0.81936E-06    0.95697E-10    0.24203E-10
+    2    4    0.60462E-04    0.10000E+01    0.46180E+03    0.13842E-05    0.31536E-09    0.28580E-10
+    2    4    0.60462E-04    0.10000E+01    0.37242E+03    0.23944E-05    0.94960E-09    0.34614E-10
+    2    4    0.60462E-04    0.10000E+01    0.30034E+03    0.41415E-05    0.25279E-08    0.43219E-10
+    2    4    0.60462E-04    0.10000E+01    0.24221E+03    0.69903E-05    0.58756E-08    0.55496E-10
+    2    4    0.60462E-04    0.10000E+01    0.19533E+03    0.10742E-04    0.11137E-07    0.70351E-10
+    2    4    0.60462E-04    0.10000E+01    0.15752E+03    0.10742E-04    0.11137E-07    0.70351E-10
+    2    4    0.10550E-03    0.10000E+01    0.80645E+05    0.90718E-51    0.68201E-62    0.79403E-55
+    2    4    0.10550E-03    0.10000E+01    0.65036E+05    0.77047E-50    0.10863E-60    0.67479E-54
+    2    4    0.10550E-03    0.10000E+01    0.52449E+05    0.65689E-49    0.14688E-59    0.57562E-53
+    2    4    0.10550E-03    0.10000E+01    0.42297E+05    0.49675E-48    0.20150E-58    0.43572E-52
+    2    4    0.10550E-03    0.10000E+01    0.34111E+05    0.36134E-47    0.28061E-57    0.31748E-51
+    2    4    0.10550E-03    0.10000E+01    0.27509E+05    0.26290E-46    0.38895E-56    0.23159E-50
+    2    4    0.10550E-03    0.10000E+01    0.22184E+05    0.19114E-45    0.53539E-55    0.16905E-49
+    2    4    0.10550E-03    0.10000E+01    0.17891E+05    0.13829E-44    0.73239E-54    0.12303E-48
+    2    4    0.10550E-03    0.10000E+01    0.14428E+05    0.99461E-44    0.99735E-53    0.89199E-48
+    2    4    0.10550E-03    0.10000E+01    0.11635E+05    0.71177E-43    0.13526E-51    0.64462E-47
+    2    4    0.10550E-03    0.10000E+01    0.93834E+04    0.50704E-42    0.18225E-50    0.46452E-46
+    2    4    0.10550E-03    0.10000E+01    0.75673E+04    0.35905E-41    0.24308E-49    0.33350E-45
+    2    4    0.10550E-03    0.10000E+01    0.61026E+04    0.25199E-40    0.31957E-48    0.23809E-44
+    2    4    0.10550E-03    0.10000E+01    0.49215E+04    0.17461E-39    0.41229E-47    0.16860E-43
+    2    4    0.10550E-03    0.10000E+01    0.39689E+04    0.11897E-38    0.52006E-46    0.11805E-42
+    2    4    0.10550E-03    0.10000E+01    0.32008E+04    0.25046E-36    0.20158E-43    0.25626E-40
+    2    4    0.10550E-03    0.10000E+01    0.25813E+04    0.87953E-28    0.13057E-34    0.91336E-32
+    2    4    0.10550E-03    0.10000E+01    0.20817E+04    0.98834E-12    0.35265E-18    0.94968E-16
+    2    4    0.10550E-03    0.10000E+01    0.16788E+04    0.23892E-06    0.33229E-12    0.20718E-10
+    2    4    0.10550E-03    0.10000E+01    0.13538E+04    0.30310E-06    0.11498E-11    0.23968E-10
+    2    4    0.10550E-03    0.10000E+01    0.10918E+04    0.40556E-06    0.39899E-11    0.27565E-10
+    2    4    0.10550E-03    0.10000E+01    0.88049E+03    0.57911E-06    0.13882E-10    0.31626E-10
+    2    4    0.10550E-03    0.10000E+01    0.71007E+03    0.88382E-06    0.48411E-10    0.36380E-10
+    2    4    0.10550E-03    0.10000E+01    0.57264E+03    0.14297E-05    0.16699E-09    0.42232E-10
+    2    4    0.10550E-03    0.10000E+01    0.46180E+03    0.24153E-05    0.55029E-09    0.49870E-10
+    2    4    0.10550E-03    0.10000E+01    0.37242E+03    0.41781E-05    0.16570E-08    0.60400E-10
+    2    4    0.10550E-03    0.10000E+01    0.30034E+03    0.72266E-05    0.44110E-08    0.75415E-10
+    2    4    0.10550E-03    0.10000E+01    0.24221E+03    0.12198E-04    0.10253E-07    0.96837E-10
+    2    4    0.10550E-03    0.10000E+01    0.19533E+03    0.18745E-04    0.19433E-07    0.12276E-09
+    2    4    0.10550E-03    0.10000E+01    0.15752E+03    0.18745E-04    0.19433E-07    0.12276E-09
+    2    4    0.18409E-03    0.10000E+01    0.80645E+05    0.15830E-50    0.11901E-61    0.13855E-54
+    2    4    0.18409E-03    0.10000E+01    0.65036E+05    0.13444E-49    0.18956E-60    0.11775E-53
+    2    4    0.18409E-03    0.10000E+01    0.52449E+05    0.11462E-48    0.25630E-59    0.10044E-52
+    2    4    0.18409E-03    0.10000E+01    0.42297E+05    0.86680E-48    0.35161E-58    0.76030E-52
+    2    4    0.18409E-03    0.10000E+01    0.34111E+05    0.63052E-47    0.48965E-57    0.55398E-51
+    2    4    0.18409E-03    0.10000E+01    0.27509E+05    0.45874E-46    0.67869E-56    0.40410E-50
+    2    4    0.18409E-03    0.10000E+01    0.22184E+05    0.33353E-45    0.93423E-55    0.29499E-49
+    2    4    0.18409E-03    0.10000E+01    0.17891E+05    0.24130E-44    0.12780E-53    0.21469E-48
+    2    4    0.18409E-03    0.10000E+01    0.14428E+05    0.17355E-43    0.17403E-52    0.15565E-47
+    2    4    0.18409E-03    0.10000E+01    0.11635E+05    0.12420E-42    0.23601E-51    0.11248E-46
+    2    4    0.18409E-03    0.10000E+01    0.93834E+04    0.88475E-42    0.31801E-50    0.81057E-46
+    2    4    0.18409E-03    0.10000E+01    0.75673E+04    0.62652E-41    0.42415E-49    0.58194E-45
+    2    4    0.18409E-03    0.10000E+01    0.61026E+04    0.43971E-40    0.55764E-48    0.41546E-44
+    2    4    0.18409E-03    0.10000E+01    0.49215E+04    0.30469E-39    0.71941E-47    0.29421E-43
+    2    4    0.18409E-03    0.10000E+01    0.39689E+04    0.20759E-38    0.90747E-46    0.20599E-42
+    2    4    0.18409E-03    0.10000E+01    0.32008E+04    0.43703E-36    0.35175E-43    0.44716E-40
+    2    4    0.18409E-03    0.10000E+01    0.25813E+04    0.15347E-27    0.22784E-34    0.15938E-31
+    2    4    0.18409E-03    0.10000E+01    0.20817E+04    0.17246E-11    0.61535E-18    0.16571E-15
+    2    4    0.18409E-03    0.10000E+01    0.16788E+04    0.41690E-06    0.57983E-12    0.36152E-10
+    2    4    0.18409E-03    0.10000E+01    0.13538E+04    0.52889E-06    0.20063E-11    0.41823E-10
+    2    4    0.18409E-03    0.10000E+01    0.10918E+04    0.70768E-06    0.69621E-11    0.48099E-10
+    2    4    0.18409E-03    0.10000E+01    0.88049E+03    0.10105E-05    0.24223E-10    0.55186E-10
+    2    4    0.18409E-03    0.10000E+01    0.71007E+03    0.15422E-05    0.84475E-10    0.63482E-10
+    2    4    0.18409E-03    0.10000E+01    0.57264E+03    0.24948E-05    0.29138E-09    0.73692E-10
+    2    4    0.18409E-03    0.10000E+01    0.46180E+03    0.42145E-05    0.96022E-09    0.87020E-10
+    2    4    0.18409E-03    0.10000E+01    0.37242E+03    0.72905E-05    0.28913E-08    0.10539E-09
+    2    4    0.18409E-03    0.10000E+01    0.30034E+03    0.12610E-04    0.76969E-08    0.13160E-09
+    2    4    0.18409E-03    0.10000E+01    0.24221E+03    0.21284E-04    0.17890E-07    0.16898E-09
+    2    4    0.18409E-03    0.10000E+01    0.19533E+03    0.32709E-04    0.33909E-07    0.21421E-09
+    2    4    0.18409E-03    0.10000E+01    0.15752E+03    0.32709E-04    0.33909E-07    0.21421E-09
+    2    4    0.32123E-03    0.10000E+01    0.80645E+05    0.27622E-50    0.20766E-61    0.24177E-54
+    2    4    0.32123E-03    0.10000E+01    0.65036E+05    0.23459E-49    0.33077E-60    0.20546E-53
+    2    4    0.32123E-03    0.10000E+01    0.52449E+05    0.20001E-48    0.44722E-59    0.17527E-52
+    2    4    0.32123E-03    0.10000E+01    0.42297E+05    0.15125E-47    0.61353E-58    0.13267E-51
+    2    4    0.32123E-03    0.10000E+01    0.34111E+05    0.11002E-46    0.85441E-57    0.96666E-51
+    2    4    0.32123E-03    0.10000E+01    0.27509E+05    0.80047E-46    0.11843E-55    0.70513E-50
+    2    4    0.32123E-03    0.10000E+01    0.22184E+05    0.58199E-45    0.16302E-54    0.51474E-49
+    2    4    0.32123E-03    0.10000E+01    0.17891E+05    0.42106E-44    0.22300E-53    0.37461E-48
+    2    4    0.32123E-03    0.10000E+01    0.14428E+05    0.30284E-43    0.30368E-52    0.27160E-47
+    2    4    0.32123E-03    0.10000E+01    0.11635E+05    0.21672E-42    0.41183E-51    0.19628E-46
+    2    4    0.32123E-03    0.10000E+01    0.93834E+04    0.15438E-41    0.55491E-50    0.14144E-45
+    2    4    0.32123E-03    0.10000E+01    0.75673E+04    0.10932E-40    0.74012E-49    0.10154E-44
+    2    4    0.32123E-03    0.10000E+01    0.61026E+04    0.76727E-40    0.97304E-48    0.72495E-44
+    2    4    0.32123E-03    0.10000E+01    0.49215E+04    0.53167E-39    0.12553E-46    0.51337E-43
+    2    4    0.32123E-03    0.10000E+01    0.39689E+04    0.36223E-38    0.15835E-45    0.35944E-42
+    2    4    0.32123E-03    0.10000E+01    0.32008E+04    0.76259E-36    0.61378E-43    0.78027E-40
+    2    4    0.32123E-03    0.10000E+01    0.25813E+04    0.26780E-27    0.39757E-34    0.27810E-31
+    2    4    0.32123E-03    0.10000E+01    0.20817E+04    0.30093E-11    0.10737E-17    0.28916E-15
+    2    4    0.32123E-03    0.10000E+01    0.16788E+04    0.72747E-06    0.10118E-11    0.63083E-10
+    2    4    0.32123E-03    0.10000E+01    0.13538E+04    0.92289E-06    0.35009E-11    0.72979E-10
+    2    4    0.32123E-03    0.10000E+01    0.10918E+04    0.12349E-05    0.12148E-10    0.83930E-10
+    2    4    0.32123E-03    0.10000E+01    0.88049E+03    0.17633E-05    0.42268E-10    0.96297E-10
+    2    4    0.32123E-03    0.10000E+01    0.71007E+03    0.26911E-05    0.14740E-09    0.11077E-09
+    2    4    0.32123E-03    0.10000E+01    0.57264E+03    0.43532E-05    0.50844E-09    0.12859E-09
+    2    4    0.32123E-03    0.10000E+01    0.46180E+03    0.73541E-05    0.16755E-08    0.15184E-09
+    2    4    0.32123E-03    0.10000E+01    0.37242E+03    0.12722E-04    0.50452E-08    0.18391E-09
+    2    4    0.32123E-03    0.10000E+01    0.30034E+03    0.22004E-04    0.13431E-07    0.22963E-09
+    2    4    0.32123E-03    0.10000E+01    0.24221E+03    0.37140E-04    0.31217E-07    0.29485E-09
+    2    4    0.32123E-03    0.10000E+01    0.19533E+03    0.57074E-04    0.59169E-07    0.37377E-09
+    2    4    0.32123E-03    0.10000E+01    0.15752E+03    0.57074E-04    0.59169E-07    0.37377E-09
+    3    1    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.45191E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    1    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.78855E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    1    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.13760E-07    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    1    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.24010E-07    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    3    1    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.41896E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    3    1    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.73106E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    3    1    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.12757E-06    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    3    1    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.22259E-06    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    3    1    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.38841E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    3    1    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.67776E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    3    1    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.11826E-05    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    3    1    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.20636E-05    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    3    1    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.36009E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    3    1    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.62834E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    3    1    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.10964E-04    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    3    1    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.19132E-04    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    3    1    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.33384E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    3    1    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.58253E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    3    1    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.10165E-03    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    3    1    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.17737E-03    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    3    1    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53957E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.30950E-03    0.19496E+06    0.99447E-26    0.48760E-10    0.50499E-04    0.88379E+03
+    3    1    0.54572E-10    0.10000E+01    0.74090E-01    0.13935E+00    0.11222E-09    0.65380E-11    0.40383E-04    0.29228E-04    0.98516E+04    0.54006E-03    0.15940E+06    0.27009E-25    0.58026E-09    0.60483E-04    0.85041E+03
+    3    1    0.95225E-10    0.10000E+01    0.11736E+00    0.19749E+00    0.21140E-09    0.50996E-10    0.44004E-04    0.38038E-04    0.17190E+05    0.94236E-03    0.12765E+06    0.72480E-25    0.43989E-08    0.73406E-04    0.78192E+03
+    3    1    0.16616E-09    0.10000E+01    0.18179E+00    0.26431E+00    0.32753E-09    0.26583E-09    0.44528E-04    0.48903E-04    0.29996E+05    0.16444E-02    0.99467E+05    0.19955E-24    0.21856E-07    0.91697E-04    0.67141E+03
+    3    1    0.28994E-09    0.10000E+01    0.25961E+00    0.33496E+00    0.47703E-09    0.94192E-09    0.43515E-04    0.57767E-04    0.52341E+05    0.28693E-02    0.75619E+05    0.57623E-24    0.71447E-07    0.11865E-03    0.53386E+03
+    3    1    0.50593E-09    0.10000E+01    0.33900E+00    0.40891E+00    0.78184E-09    0.24625E-08    0.45608E-04    0.61912E-04    0.91333E+05    0.50068E-02    0.56747E+05    0.17224E-23    0.16529E-06    0.15713E-03    0.40140E+03
+    3    1    0.88282E-09    0.10000E+01    0.41762E+00    0.48781E+00    0.14159E-08    0.54449E-08    0.54182E-04    0.63271E-04    0.15937E+06    0.87366E-02    0.42418E+05    0.52150E-23    0.31202E-06    0.20988E-03    0.29419E+03
+    3    1    0.15405E-08    0.10000E+01    0.36333E+00    0.69413E+00    0.73763E-08    0.13444E-07    0.63796E-04    0.63687E-04    0.81842E+05    0.10022E-01    0.66266E+04    0.47987E-22    0.49383E-06    0.46540E-03    0.16320E+03
+    3    1    0.26880E-08    0.10000E+01    0.41493E+00    0.79920E+00    0.14413E-07    0.26952E-07    0.78612E-04    0.64477E-04    0.11884E+06    0.16326E-01    0.43556E+04    0.16801E-21    0.82043E-06    0.66658E-03    0.11507E+03
+    3    1    0.46905E-08    0.10000E+01    0.48925E+00    0.88639E+00    0.25829E-07    0.51969E-07    0.10150E-03    0.65033E-04    0.20736E+06    0.28487E-01    0.32516E+04    0.51055E-21    0.13585E-05    0.89233E-03    0.84398E+02
+    3    1    0.81846E-08    0.10000E+01    0.56673E+00    0.97193E+00    0.45706E-07    0.98963E-07    0.13297E-03    0.65496E-04    0.36184E+06    0.49709E-01    0.24275E+04    0.15520E-20    0.22272E-05    0.11950E-02    0.61636E+02
+    3    1    0.14282E-07    0.10000E+01    0.64674E+00    0.10550E+01    0.79653E-07    0.18646E-06    0.17564E-03    0.65920E-04    0.63138E+06    0.86738E-01    0.18098E+04    0.47302E-20    0.36228E-05    0.16025E-02    0.44825E+02
+    3    1    0.24920E-07    0.10000E+01    0.72758E+00    0.11339E+01    0.13744E-06    0.34778E-06    0.23364E-03    0.66323E-04    0.11017E+07    0.15135E+00    0.13511E+04    0.14383E-19    0.58583E-05    0.21465E-02    0.32588E+02
+    3    1    0.43485E-07    0.10000E+01    0.80896E+00    0.12086E+01    0.23376E-06    0.64324E-06    0.31151E-03    0.66721E-04    0.19224E+07    0.26410E+00    0.10073E+04    0.43840E-19    0.94208E-05    0.28789E-02    0.23633E+02
+    3    1    0.75878E-07    0.10000E+01    0.88920E+00    0.12781E+01    0.39425E-06    0.11802E-05    0.41669E-03    0.67115E-04    0.33546E+07    0.46084E+00    0.75202E+03    0.13322E-18    0.15088E-04    0.38558E-02    0.17152E+02
+    3    1    0.13240E-06    0.10000E+01    0.96812E+00    0.13425E+01    0.65574E-06    0.21493E-05    0.55729E-03    0.67510E-04    0.58535E+07    0.80414E+00    0.56068E+03    0.40205E-18    0.24049E-04    0.51577E-02    0.12434E+02
+    3    1    0.23103E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.15703E-05    0.38017E-05    0.87654E-03    0.67662E-04    0.10214E+08    0.14032E+01    0.50000E+03    0.86013E-18    0.40441E-04    0.57605E-02    0.10978E+02
+    3    1    0.40314E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.47812E-05    0.66338E-05    0.15295E-02    0.67662E-04    0.17823E+08    0.24485E+01    0.50000E+03    0.15009E-17    0.70568E-04    0.57605E-02    0.10978E+02
+    3    1    0.70346E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.14558E-04    0.11576E-04    0.26689E-02    0.67662E-04    0.31100E+08    0.42724E+01    0.50000E+03    0.26189E-17    0.12314E-03    0.57605E-02    0.10978E+02
+    3    1    0.12275E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.44326E-04    0.20199E-04    0.46571E-02    0.67662E-04    0.54267E+08    0.74551E+01    0.50000E+03    0.45699E-17    0.21487E-03    0.57605E-02    0.10978E+02
+    3    1    0.21419E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.13496E-03    0.35246E-04    0.81263E-02    0.67662E-04    0.94693E+08    0.13009E+02    0.50000E+03    0.79742E-17    0.37493E-03    0.57605E-02    0.10978E+02
+    3    1    0.37375E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.41094E-03    0.61501E-04    0.14180E-01    0.67662E-04    0.16523E+09    0.22699E+02    0.50000E+03    0.13915E-16    0.65423E-03    0.57605E-02    0.10978E+02
+    3    1    0.65217E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.12512E-02    0.10732E-03    0.24743E-01    0.67662E-04    0.28832E+09    0.39609E+02    0.50000E+03    0.24280E-16    0.11416E-02    0.57605E-02    0.10978E+02
+    3    1    0.11380E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.38098E-02    0.18726E-03    0.43175E-01    0.67662E-04    0.50310E+09    0.69116E+02    0.50000E+03    0.42367E-16    0.19920E-02    0.57605E-02    0.10978E+02
+    3    1    0.19857E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.11600E-01    0.32676E-03    0.75338E-01    0.67662E-04    0.87789E+09    0.12060E+03    0.50000E+03    0.73928E-16    0.34759E-02    0.57605E-02    0.10978E+02
+    3    1    0.34650E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.35320E-01    0.57017E-03    0.13146E+00    0.67662E-04    0.15319E+10    0.21044E+03    0.50000E+03    0.12900E-15    0.60653E-02    0.57605E-02    0.10978E+02
+    3    1    0.60462E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.10754E+00    0.99492E-03    0.22939E+00    0.67662E-04    0.26730E+10    0.36721E+03    0.50000E+03    0.22510E-15    0.10583E-01    0.57605E-02    0.10978E+02
+    3    1    0.10550E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.32745E+00    0.17361E-02    0.40027E+00    0.67662E-04    0.46642E+10    0.64076E+03    0.50000E+03    0.39278E-15    0.18468E-01    0.57605E-02    0.10978E+02
+    3    1    0.18409E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.99703E+00    0.30293E-02    0.69845E+00    0.67662E-04    0.81388E+10    0.11181E+04    0.50000E+03    0.68538E-15    0.32225E-01    0.57605E-02    0.10978E+02
+    3    1    0.32123E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.30358E+01    0.52860E-02    0.12188E+01    0.67662E-04    0.14202E+11    0.19510E+04    0.50000E+03    0.11959E-14    0.56230E-01    0.57605E-02    0.10978E+02
+    3    1    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    3    1    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    3    1    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    3    1    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    3    1    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    3    1    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    3    1    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    3    1    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    3    1    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    3    1    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    3    1    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    3    1    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    3    1    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    3    1    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    3    1    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    3    1    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    3    1    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    3    1    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    3    1    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    3    1    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    3    1    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    3    1    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    3    1    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    3    1    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    3    1    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    3    1    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    3    1    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    3    1    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    3    1    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    3    1    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    3    1    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    3    1    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    3    1    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    3    1    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    3    1    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    3    1    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    3    1    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    3    1    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    3    1    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    3    1    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    3    1    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    3    1    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    3    1    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    3    1    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    3    1    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    3    1    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    3    1    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    3    1    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    3    1    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    3    1    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    3    1    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    3    1    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    3    1    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    3    1    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    3    1    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    3    1    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    3    1    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    3    1    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    3    1    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    3    1    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    3    1    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    3    1    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    3    1    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    3    1    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    3    1    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    3    1    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    3    1    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    3    1    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    3    1    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    3    1    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    3    1    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    3    1    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    3    1    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    3    1    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    3    1    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    3    1    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    3    1    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    3    1    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    3    1    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    3    1    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    3    1    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    3    1    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    3    1    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    3    1    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    3    1    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    3    1    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    3    1    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    3    1    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    3    1    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    3    1    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    3    1    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    3    1    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    3    1    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    3    1    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    3    1    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    3    1    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    3    1    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    3    1    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    3    1    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    3    1    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    3    1    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    3    1    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    3    1    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    3    1    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    3    1    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    3    1    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    3    1    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    3    1    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    3    1    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    3    1    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    3    1    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    3    1    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    3    1    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    3    1    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    3    1    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    3    1    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    3    1    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    3    1    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    3    1    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    3    1    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    3    1    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    3    1    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    3    1    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    3    1    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    3    1    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    3    1    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    3    1    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    3    1    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    3    1    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    3    1    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    3    1    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    3    1    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    3    1    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    3    1    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    3    1    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    3    1    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    3    1    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    3    1    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    3    1    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    3    1    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    3    1    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    3    1    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    3    1    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    3    1    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    3    1    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    3    1    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    3    1    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    3    1    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    3    1    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    3    1    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    3    1    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    3    1    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    3    1    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    3    1    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    3    1    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    3    1    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    3    1    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    3    1    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    3    1    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    3    1    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    3    1    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    3    1    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    3    1    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    3    1    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    3    1    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    3    1    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    3    1    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    3    1    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    3    1    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    3    1    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    3    1    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    3    1    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    3    1    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    3    1    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    3    1    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    3    1    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    3    1    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    3    1    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    3    1    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    3    1    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    3    1    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    3    1    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    3    1    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    3    1    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    3    1    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    3    1    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    3    1    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    3    1    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    3    1    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    3    1    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    3    1    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    3    1    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    3    1    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    3    1    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    3    1    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    3    1    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    3    1    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    3    1    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    3    1    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    3    1    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    3    1    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    3    1    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    3    1    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    3    1    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    3    1    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    3    1    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    3    1    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    3    1    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    3    1    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    3    1    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    3    1    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    3    1    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    3    1    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    3    1    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    3    1    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    3    1    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    3    1    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    3    1    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    3    1    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    3    1    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    3    1    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    3    1    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    3    1    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    3    1    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    3    1    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    3    1    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    3    1    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    3    1    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    3    1    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    3    1    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    3    1    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    3    1    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    3    1    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    3    1    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    3    1    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    3    1    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    3    1    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    3    1    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    3    1    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    3    1    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    3    1    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    3    1    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    3    1    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    3    1    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    3    1    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    3    1    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    3    1    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    3    1    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    3    1    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    3    1    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    3    1    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    3    1    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    3    1    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    3    1    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    3    1    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    3    1    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    3    1    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    3    1    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    3    1    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    3    1    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    3    1    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    3    1    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    3    1    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    3    1    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    3    1    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    3    1    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    3    1    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    3    1    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    3    1    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    3    1    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    3    1    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    3    1    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    3    1    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    3    1    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    3    1    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    3    1    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    3    1    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    3    1    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    3    1    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    3    1    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    3    1    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    3    1    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    3    1    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    3    1    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    3    1    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    3    1    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    3    1    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    3    1    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    3    1    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    3    1    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    3    1    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    3    1    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    3    1    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    3    1    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    3    1    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    3    1    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    3    1    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    3    1    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    3    1    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    3    1    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    3    1    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    3    1    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    3    1    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    3    1    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    3    1    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    3    1    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    3    1    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    3    1    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    3    1    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    3    1    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    3    1    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    3    1    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    3    1    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    3    1    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    3    1    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    3    1    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    3    1    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    3    1    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    3    1    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    3    1    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    3    1    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    3    1    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    3    1    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    3    1    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    3    1    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    3    1    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    3    1    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    3    1    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    3    1    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    3    1    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    3    1    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    3    1    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    3    1    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    3    1    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    3    1    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    3    1    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    3    1    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    3    1    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    3    1    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    3    1    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    3    1    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    3    1    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    3    1    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    3    1    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    3    1    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    3    1    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    3    1    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    3    1    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    3    1    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    3    1    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    3    1    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    3    1    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    3    1    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    3    1    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    3    1    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    3    1    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    3    1    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    3    1    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    3    1    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    3    1    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    3    1    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    3    1    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    3    1    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    3    1    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    3    1    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    3    1    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    3    1    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    3    1    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    3    1    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    3    1    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    3    1    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    3    1    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    3    1    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    3    1    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    3    1    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    3    1    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    3    1    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    3    1    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    3    1    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    3    1    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    3    1    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    3    1    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    3    1    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    3    1    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    3    1    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    3    1    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    3    1    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    3    1    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    3    1    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    3    1    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    3    1    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    3    1    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    3    1    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    3    1    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    3    1    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    3    1    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    3    1    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    3    1    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    3    1    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    3    1    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    3    1    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    3    1    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    3    1    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    3    1    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    3    1    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    3    1    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    3    1    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    3    1    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    3    1    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    3    1    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    3    1    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    3    1    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    3    1    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    3    1    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    3    1    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    3    1    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    3    1    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    3    1    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    3    1    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    3    1    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    3    1    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    3    1    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    3    1    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    3    1    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    3    1    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    3    1    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    3    1    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    3    1    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    3    1    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    3    1    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    3    1    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    3    1    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    3    1    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    3    1    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    3    1    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    3    1    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    3    1    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    3    1    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    3    1    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    3    1    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    3    1    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    3    1    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    3    1    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    3    1    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    3    1    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    3    1    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    3    1    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    3    1    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    3    1    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    3    1    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    3    1    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    3    1    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    3    1    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    3    1    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    3    1    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    3    1    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    3    1    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    3    1    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    3    1    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    3    1    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    3    1    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    3    1    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    3    1    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    3    1    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    3    1    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    3    1    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    3    1    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    3    1    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    3    1    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    3    1    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    3    1    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    3    1    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    3    1    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    3    1    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    3    1    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    3    1    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    3    1    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    3    1    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    3    1    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    3    1    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    3    1    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    3    1    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    3    1    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    3    1    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    3    1    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    3    1    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    3    1    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    3    1    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    3    1    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    3    1    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    3    1    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    3    1    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    3    1    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    3    1    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    3    1    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    3    1    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    3    1    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    3    1    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    3    1    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    3    1    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    3    1    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    3    1    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    3    1    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    3    1    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    3    1    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    3    1    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    3    1    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    3    1    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    3    1    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    3    1    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    3    1    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    3    1    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    3    1    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    3    1    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    3    1    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    3    1    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    3    1    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    3    1    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    3    1    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    3    1    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    3    1    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    3    1    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    3    1    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    3    1    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    3    1    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    3    1    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    3    1    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    3    1    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    3    1    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    3    1    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    3    1    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    3    1    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    3    1    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    3    1    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    3    1    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    3    1    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    3    1    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    3    1    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    3    1    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    3    1    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    3    1    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    3    1    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    3    1    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    3    1    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    3    1    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    3    1    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    3    1    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    3    1    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    3    1    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    3    1    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    3    1    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    3    1    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    3    1    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    3    1    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    3    1    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    3    1    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    3    1    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    3    1    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    3    1    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    3    1    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    3    1    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    3    1    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    3    1    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    3    1    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    3    1    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    3    1    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    3    1    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    3    1    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    3    1    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    3    1    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    3    1    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    3    1    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    3    1    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    3    1    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    3    1    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    3    1    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    3    1    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    3    1    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    3    1    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    3    1    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    3    1    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    3    1    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    3    1    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    3    1    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    3    1    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    3    1    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    3    1    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    3    1    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    3    1    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    3    1    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    3    1    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    3    1    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    3    1    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    3    1    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    3    1    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    3    1    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    3    1    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    3    1    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    3    1    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    3    1    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    3    1    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    3    1    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    3    1    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    3    1    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    3    1    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    3    1    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    3    1    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    3    1    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    3    1    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    3    1    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    3    1    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    3    1    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    3    1    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    3    1    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    3    1    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    3    1    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    3    1    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    3    1    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    3    1    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    3    1    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    3    1    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    3    1    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    3    1    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    3    1    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    3    1    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    3    1    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    3    1    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    3    1    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    3    1    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    3    1    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    3    1    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35525E-67
+    3    1    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31050E-66
+    3    1    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49297E-66    0.26759E-65
+    3    1    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20665E-64
+    3    1    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    3    1    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15327E-62
+    3    1    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    3    1    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30486E-60
+    3    1    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49479E-59
+    3    1    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76348E-58
+    3    1    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    3    1    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16341E-55
+    3    1    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    3    1    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33513E-53
+    3    1    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47754E-52
+    3    1    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86007E-46    0.21355E-49
+    3    1    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    3    1    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    3    1    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    3    1    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    3    1    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    3    1    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    3    1    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    3    1    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    3    1    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    3    1    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    3    1    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    3    1    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    3    1    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    3    1    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    3    1    0.95225E-10    0.10000E+01    0.80645E+05    0.53338E-57    0.41251E-68    0.10749E-66
+    3    1    0.95225E-10    0.10000E+01    0.65036E+05    0.46320E-56    0.66241E-67    0.94141E-66
+    3    1    0.95225E-10    0.10000E+01    0.52449E+05    0.40024E-55    0.93503E-66    0.81416E-65
+    3    1    0.95225E-10    0.10000E+01    0.42297E+05    0.31521E-54    0.15121E-64    0.62477E-64
+    3    1    0.95225E-10    0.10000E+01    0.34111E+05    0.26479E-53    0.31103E-63    0.46450E-63
+    3    1    0.95225E-10    0.10000E+01    0.27509E+05    0.27530E-52    0.84266E-62    0.36185E-62
+    3    1    0.95225E-10    0.10000E+01    0.22184E+05    0.37547E-51    0.26561E-60    0.35004E-61
+    3    1    0.95225E-10    0.10000E+01    0.17891E+05    0.59959E-50    0.82078E-59    0.47852E-60
+    3    1    0.95225E-10    0.10000E+01    0.14428E+05    0.96029E-49    0.23747E-57    0.76675E-59
+    3    1    0.95225E-10    0.10000E+01    0.11635E+05    0.14620E-47    0.65938E-56    0.12102E-57
+    3    1    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18298E-56
+    3    1    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49011E-53    0.26942E-55
+    3    1    0.95225E-10    0.10000E+01    0.61026E+04    0.43943E-44    0.13295E-51    0.39150E-54
+    3    1    0.95225E-10    0.10000E+01    0.49215E+04    0.62538E-43    0.35997E-50    0.56476E-53
+    3    1    0.95225E-10    0.10000E+01    0.39689E+04    0.88822E-42    0.97300E-49    0.81063E-52
+    3    1    0.95225E-10    0.10000E+01    0.32008E+04    0.39613E-39    0.84952E-46    0.36461E-49
+    3    1    0.95225E-10    0.10000E+01    0.25813E+04    0.29211E-30    0.14353E-36    0.27085E-40
+    3    1    0.95225E-10    0.10000E+01    0.20817E+04    0.55938E-14    0.12256E-19    0.52257E-24
+    3    1    0.95225E-10    0.10000E+01    0.16788E+04    0.18980E-08    0.18143E-13    0.17813E-18
+    3    1    0.95225E-10    0.10000E+01    0.13538E+04    0.40806E-08    0.68940E-13    0.38357E-18
+    3    1    0.95225E-10    0.10000E+01    0.10918E+04    0.85761E-08    0.25711E-12    0.80708E-18
+    3    1    0.95225E-10    0.10000E+01    0.88049E+03    0.17636E-07    0.94670E-12    0.16610E-17
+    3    1    0.95225E-10    0.10000E+01    0.71007E+03    0.35560E-07    0.34475E-11    0.33511E-17
+    3    1    0.95225E-10    0.10000E+01    0.57264E+03    0.70490E-07    0.12266E-10    0.66454E-17
+    3    1    0.95225E-10    0.10000E+01    0.46180E+03    0.13745E-06    0.41255E-10    0.12961E-16
+    3    1    0.95225E-10    0.10000E+01    0.37242E+03    0.26237E-06    0.12579E-09    0.24744E-16
+    3    1    0.95225E-10    0.10000E+01    0.30034E+03    0.48462E-06    0.33740E-09    0.45710E-16
+    3    1    0.95225E-10    0.10000E+01    0.24221E+03    0.85384E-06    0.78780E-09    0.80539E-16
+    3    1    0.95225E-10    0.10000E+01    0.19533E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    3    1    0.95225E-10    0.10000E+01    0.15752E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    3    1    0.16616E-09    0.10000E+01    0.80645E+05    0.10831E-56    0.84134E-68    0.33649E-66
+    3    1    0.16616E-09    0.10000E+01    0.65036E+05    0.94382E-56    0.13505E-66    0.29209E-65
+    3    1    0.16616E-09    0.10000E+01    0.52449E+05    0.81476E-55    0.18599E-65    0.25174E-64
+    3    1    0.16616E-09    0.10000E+01    0.42297E+05    0.62646E-54    0.26584E-64    0.19203E-63
+    3    1    0.16616E-09    0.10000E+01    0.34111E+05    0.47293E-53    0.41443E-63    0.13945E-62
+    3    1    0.16616E-09    0.10000E+01    0.27509E+05    0.38376E-52    0.82703E-62    0.99836E-62
+    3    1    0.16616E-09    0.10000E+01    0.22184E+05    0.38951E-51    0.23108E-60    0.77606E-61
+    3    1    0.16616E-09    0.10000E+01    0.17891E+05    0.53703E-50    0.71872E-59    0.82846E-60
+    3    1    0.16616E-09    0.10000E+01    0.14428E+05    0.84667E-49    0.21403E-57    0.12129E-58
+    3    1    0.16616E-09    0.10000E+01    0.11635E+05    0.13169E-47    0.60847E-56    0.19194E-57
+    3    1    0.16616E-09    0.10000E+01    0.93834E+04    0.19721E-46    0.16918E-54    0.29611E-56
+    3    1    0.16616E-09    0.10000E+01    0.75673E+04    0.28850E-45    0.46590E-53    0.44363E-55
+    3    1    0.16616E-09    0.10000E+01    0.61026E+04    0.41726E-44    0.12762E-51    0.65289E-54
+    3    1    0.16616E-09    0.10000E+01    0.49215E+04    0.59980E-43    0.34818E-50    0.95065E-53
+    3    1    0.16616E-09    0.10000E+01    0.39689E+04    0.85857E-42    0.94687E-49    0.13742E-51
+    3    1    0.16616E-09    0.10000E+01    0.32008E+04    0.38534E-39    0.83094E-46    0.62162E-49
+    3    1    0.16616E-09    0.10000E+01    0.25813E+04    0.28572E-30    0.14110E-36    0.46404E-40
+    3    1    0.16616E-09    0.10000E+01    0.20817E+04    0.55023E-14    0.12112E-19    0.89981E-24
+    3    1    0.16616E-09    0.10000E+01    0.16788E+04    0.18735E-08    0.17967E-13    0.30768E-18
+    3    1    0.16616E-09    0.10000E+01    0.13538E+04    0.40327E-08    0.68292E-13    0.66322E-18
+    3    1    0.16616E-09    0.10000E+01    0.10918E+04    0.84828E-08    0.25473E-12    0.13965E-17
+    3    1    0.16616E-09    0.10000E+01    0.88049E+03    0.17454E-07    0.93805E-12    0.28757E-17
+    3    1    0.16616E-09    0.10000E+01    0.71007E+03    0.35210E-07    0.34161E-11    0.58040E-17
+    3    1    0.16616E-09    0.10000E+01    0.57264E+03    0.69816E-07    0.12154E-10    0.11512E-16
+    3    1    0.16616E-09    0.10000E+01    0.46180E+03    0.13616E-06    0.40880E-10    0.22458E-16
+    3    1    0.16616E-09    0.10000E+01    0.37242E+03    0.25994E-06    0.12465E-09    0.42878E-16
+    3    1    0.16616E-09    0.10000E+01    0.30034E+03    0.48017E-06    0.33433E-09    0.79212E-16
+    3    1    0.16616E-09    0.10000E+01    0.24221E+03    0.84602E-06    0.78064E-09    0.13957E-15
+    3    1    0.16616E-09    0.10000E+01    0.19533E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    3    1    0.16616E-09    0.10000E+01    0.15752E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    3    1    0.28994E-09    0.10000E+01    0.80645E+05    0.22011E-56    0.16920E-67    0.11249E-65
+    3    1    0.28994E-09    0.10000E+01    0.65036E+05    0.19023E-55    0.27099E-66    0.96503E-65
+    3    1    0.28994E-09    0.10000E+01    0.52449E+05    0.16355E-54    0.36930E-65    0.82631E-64
+    3    1    0.28994E-09    0.10000E+01    0.42297E+05    0.12449E-53    0.50576E-64    0.62542E-63
+    3    1    0.28994E-09    0.10000E+01    0.34111E+05    0.90534E-53    0.69149E-63    0.44950E-62
+    3    1    0.28994E-09    0.10000E+01    0.27509E+05    0.65403E-52    0.10276E-61    0.31368E-61
+    3    1    0.28994E-09    0.10000E+01    0.22184E+05    0.51145E-51    0.21678E-60    0.21734E-60
+    3    1    0.28994E-09    0.10000E+01    0.17891E+05    0.53350E-50    0.62717E-59    0.17681E-59
+    3    1    0.28994E-09    0.10000E+01    0.14428E+05    0.75573E-49    0.19028E-57    0.20765E-58
+    3    1    0.28994E-09    0.10000E+01    0.11635E+05    0.11751E-47    0.55601E-56    0.31026E-57
+    3    1    0.28994E-09    0.10000E+01    0.93834E+04    0.17997E-46    0.15781E-54    0.48192E-56
+    3    1    0.28994E-09    0.10000E+01    0.75673E+04    0.26865E-45    0.44099E-53    0.73307E-55
+    3    1    0.28994E-09    0.10000E+01    0.61026E+04    0.39444E-44    0.12210E-51    0.10917E-53
+    3    1    0.28994E-09    0.10000E+01    0.49215E+04    0.57333E-43    0.33588E-50    0.16029E-52
+    3    1    0.28994E-09    0.10000E+01    0.39689E+04    0.82768E-42    0.91939E-49    0.23314E-51
+    3    1    0.28994E-09    0.10000E+01    0.32008E+04    0.37400E-39    0.81127E-46    0.10597E-48
+    3    1    0.28994E-09    0.10000E+01    0.25813E+04    0.27896E-30    0.13850E-36    0.79454E-40
+    3    1    0.28994E-09    0.10000E+01    0.20817E+04    0.54048E-14    0.11957E-19    0.15478E-23
+    3    1    0.28994E-09    0.10000E+01    0.16788E+04    0.18472E-08    0.17777E-13    0.53075E-18
+    3    1    0.28994E-09    0.10000E+01    0.13538E+04    0.39812E-08    0.67591E-13    0.11451E-17
+    3    1    0.28994E-09    0.10000E+01    0.10918E+04    0.83822E-08    0.25216E-12    0.24130E-17
+    3    1    0.28994E-09    0.10000E+01    0.88049E+03    0.17259E-07    0.92865E-12    0.49712E-17
+    3    1    0.28994E-09    0.10000E+01    0.71007E+03    0.34831E-07    0.33820E-11    0.10037E-16
+    3    1    0.28994E-09    0.10000E+01    0.57264E+03    0.69086E-07    0.12033E-10    0.19913E-16
+    3    1    0.28994E-09    0.10000E+01    0.46180E+03    0.13476E-06    0.40472E-10    0.38849E-16
+    3    1    0.28994E-09    0.10000E+01    0.37242E+03    0.25730E-06    0.12341E-09    0.74180E-16
+    3    1    0.28994E-09    0.10000E+01    0.30034E+03    0.47533E-06    0.33100E-09    0.13705E-15
+    3    1    0.28994E-09    0.10000E+01    0.24221E+03    0.83753E-06    0.77285E-09    0.24148E-15
+    3    1    0.28994E-09    0.10000E+01    0.19533E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    3    1    0.28994E-09    0.10000E+01    0.15752E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    3    1    0.50593E-09    0.10000E+01    0.80645E+05    0.44926E-56    0.34079E-67    0.39232E-65
+    3    1    0.50593E-09    0.10000E+01    0.65036E+05    0.38422E-55    0.54341E-66    0.33355E-64
+    3    1    0.50593E-09    0.10000E+01    0.52449E+05    0.32834E-54    0.73364E-65    0.28402E-63
+    3    1    0.50593E-09    0.10000E+01    0.42297E+05    0.24795E-53    0.99037E-64    0.21350E-62
+    3    1    0.50593E-09    0.10000E+01    0.34111E+05    0.17797E-52    0.13099E-62    0.15247E-61
+    3    1    0.50593E-09    0.10000E+01    0.27509E+05    0.12441E-51    0.16902E-61    0.10586E-60
+    3    1    0.50593E-09    0.10000E+01    0.22184E+05    0.86010E-51    0.25710E-60    0.70603E-60
+    3    1    0.50593E-09    0.10000E+01    0.17891E+05    0.67638E-50    0.58946E-59    0.47985E-59
+    3    1    0.50593E-09    0.10000E+01    0.14428E+05    0.74782E-49    0.17213E-57    0.41577E-58
+    3    1    0.50593E-09    0.10000E+01    0.11635E+05    0.10801E-47    0.51285E-56    0.52474E-57
+    3    1    0.50593E-09    0.10000E+01    0.93834E+04    0.16626E-46    0.14855E-54    0.79304E-56
+    3    1    0.50593E-09    0.10000E+01    0.75673E+04    0.25254E-45    0.42087E-53    0.12189E-54
+    3    1    0.50593E-09    0.10000E+01    0.61026E+04    0.37597E-44    0.11762E-51    0.18356E-53
+    3    1    0.50593E-09    0.10000E+01    0.49215E+04    0.55185E-43    0.32580E-50    0.27151E-52
+    3    1    0.50593E-09    0.10000E+01    0.39689E+04    0.80238E-42    0.89663E-49    0.39684E-51
+    3    1    0.50593E-09    0.10000E+01    0.32008E+04    0.36462E-39    0.79485E-46    0.18106E-48
+    3    1    0.50593E-09    0.10000E+01    0.25813E+04    0.27333E-30    0.13633E-36    0.13622E-39
+    3    1    0.50593E-09    0.10000E+01    0.20817E+04    0.53238E-14    0.11828E-19    0.26638E-23
+    3    1    0.50593E-09    0.10000E+01    0.16788E+04    0.18256E-08    0.17620E-13    0.91573E-18
+    3    1    0.50593E-09    0.10000E+01    0.13538E+04    0.39387E-08    0.67015E-13    0.19773E-17
+    3    1    0.50593E-09    0.10000E+01    0.10918E+04    0.82993E-08    0.25005E-12    0.41688E-17
+    3    1    0.50593E-09    0.10000E+01    0.88049E+03    0.17098E-07    0.92093E-12    0.85921E-17
+    3    1    0.50593E-09    0.10000E+01    0.71007E+03    0.34520E-07    0.33539E-11    0.17352E-16
+    3    1    0.50593E-09    0.10000E+01    0.57264E+03    0.68486E-07    0.11933E-10    0.34432E-16
+    3    1    0.50593E-09    0.10000E+01    0.46180E+03    0.13362E-06    0.40135E-10    0.67183E-16
+    3    1    0.50593E-09    0.10000E+01    0.37242E+03    0.25513E-06    0.12238E-09    0.12829E-15
+    3    1    0.50593E-09    0.10000E+01    0.30034E+03    0.47134E-06    0.32824E-09    0.23702E-15
+    3    1    0.50593E-09    0.10000E+01    0.24221E+03    0.83053E-06    0.76641E-09    0.41764E-15
+    3    1    0.50593E-09    0.10000E+01    0.19533E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    3    1    0.50593E-09    0.10000E+01    0.15752E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    3    1    0.88282E-09    0.10000E+01    0.80645E+05    0.91476E-56    0.68731E-67    0.13789E-64
+    3    1    0.88282E-09    0.10000E+01    0.65036E+05    0.77641E-55    0.10919E-65    0.11662E-63
+    3    1    0.88282E-09    0.10000E+01    0.52449E+05    0.66035E-54    0.14632E-64    0.98963E-63
+    3    1    0.88282E-09    0.10000E+01    0.42297E+05    0.49567E-53    0.19615E-63    0.74065E-62
+    3    1    0.88282E-09    0.10000E+01    0.34111E+05    0.35353E-52    0.25848E-62    0.52675E-61
+    3    1    0.88282E-09    0.10000E+01    0.27509E+05    0.24558E-51    0.32187E-61    0.36567E-60
+    3    1    0.88282E-09    0.10000E+01    0.22184E+05    0.16393E-50    0.40073E-60    0.24273E-59
+    3    1    0.88282E-09    0.10000E+01    0.17891E+05    0.10961E-49    0.65251E-59    0.15348E-58
+    3    1    0.88282E-09    0.10000E+01    0.14428E+05    0.89454E-49    0.16244E-57    0.10392E-57
+    3    1    0.88282E-09    0.10000E+01    0.11635E+05    0.10618E-47    0.47991E-56    0.98632E-57
+    3    1    0.88282E-09    0.10000E+01    0.93834E+04    0.15701E-46    0.14156E-54    0.13418E-55
+    3    1    0.88282E-09    0.10000E+01    0.75673E+04    0.24062E-45    0.40636E-53    0.20503E-54
+    3    1    0.88282E-09    0.10000E+01    0.61026E+04    0.36255E-44    0.11442E-51    0.31177E-53
+    3    1    0.88282E-09    0.10000E+01    0.49215E+04    0.53641E-43    0.31845E-50    0.46407E-52
+    3    1    0.88282E-09    0.10000E+01    0.39689E+04    0.78393E-42    0.87953E-49    0.68035E-51
+    3    1    0.88282E-09    0.10000E+01    0.32008E+04    0.35759E-39    0.78214E-46    0.31094E-48
+    3    1    0.88282E-09    0.10000E+01    0.25813E+04    0.26899E-30    0.13461E-36    0.23432E-39
+    3    1    0.88282E-09    0.10000E+01    0.20817E+04    0.52599E-14    0.11724E-19    0.45928E-23
+    3    1    0.88282E-09    0.10000E+01    0.16788E+04    0.18083E-08    0.17491E-13    0.15815E-17
+    3    1    0.88282E-09    0.10000E+01    0.13538E+04    0.39044E-08    0.66538E-13    0.34162E-17
+    3    1    0.88282E-09    0.10000E+01    0.10918E+04    0.82318E-08    0.24829E-12    0.72050E-17
+    3    1    0.88282E-09    0.10000E+01    0.88049E+03    0.16966E-07    0.91446E-12    0.14853E-16
+    3    1    0.88282E-09    0.10000E+01    0.71007E+03    0.34263E-07    0.33303E-11    0.30001E-16
+    3    1    0.88282E-09    0.10000E+01    0.57264E+03    0.67988E-07    0.11849E-10    0.59535E-16
+    3    1    0.88282E-09    0.10000E+01    0.46180E+03    0.13266E-06    0.39851E-10    0.11617E-15
+    3    1    0.88282E-09    0.10000E+01    0.37242E+03    0.25331E-06    0.12151E-09    0.22183E-15
+    3    1    0.88282E-09    0.10000E+01    0.30034E+03    0.46799E-06    0.32591E-09    0.40983E-15
+    3    1    0.88282E-09    0.10000E+01    0.24221E+03    0.82463E-06    0.76096E-09    0.72214E-15
+    3    1    0.88282E-09    0.10000E+01    0.19533E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    3    1    0.88282E-09    0.10000E+01    0.15752E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    3    1    0.15405E-08    0.10000E+01    0.80645E+05    0.22169E-55    0.16538E-66    0.19444E-63
+    3    1    0.15405E-08    0.10000E+01    0.65036E+05    0.18709E-54    0.26199E-65    0.16386E-62
+    3    1    0.15405E-08    0.10000E+01    0.52449E+05    0.15857E-53    0.34936E-64    0.13874E-61
+    3    1    0.15405E-08    0.10000E+01    0.42297E+05    0.11856E-52    0.46757E-63    0.10359E-60
+    3    1    0.15405E-08    0.10000E+01    0.34111E+05    0.84435E-52    0.62479E-62    0.73632E-60
+    3    1    0.15405E-08    0.10000E+01    0.27509E+05    0.59246E-51    0.81019E-61    0.51534E-59
+    3    1    0.15405E-08    0.10000E+01    0.22184E+05    0.40692E-50    0.10307E-59    0.35092E-58
+    3    1    0.15405E-08    0.10000E+01    0.17891E+05    0.27534E-49    0.14075E-58    0.22768E-57
+    3    1    0.15405E-08    0.10000E+01    0.14428E+05    0.19631E-48    0.24555E-57    0.13888E-56
+    3    1    0.15405E-08    0.10000E+01    0.11635E+05    0.17070E-47    0.57662E-56    0.81553E-56
+    3    1    0.15405E-08    0.10000E+01    0.93834E+04    0.19685E-46    0.15733E-54    0.52856E-55
+    3    1    0.15405E-08    0.10000E+01    0.75673E+04    0.27170E-45    0.44125E-53    0.48422E-54
+    3    1    0.15405E-08    0.10000E+01    0.61026E+04    0.39529E-44    0.12261E-51    0.62492E-53
+    3    1    0.15405E-08    0.10000E+01    0.49215E+04    0.57536E-43    0.33698E-50    0.90174E-52
+    3    1    0.15405E-08    0.10000E+01    0.39689E+04    0.83012E-42    0.92000E-49    0.13001E-50
+    3    1    0.15405E-08    0.10000E+01    0.32008E+04    0.37425E-39    0.80984E-46    0.58076E-48
+    3    1    0.15405E-08    0.10000E+01    0.25813E+04    0.27849E-30    0.13803E-36    0.42644E-39
+    3    1    0.15405E-08    0.10000E+01    0.20817E+04    0.53875E-14    0.11903E-19    0.81441E-23
+    3    1    0.15405E-08    0.10000E+01    0.16788E+04    0.18406E-08    0.17690E-13    0.27668E-17
+    3    1    0.15405E-08    0.10000E+01    0.13538E+04    0.39646E-08    0.67251E-13    0.59320E-17
+    3    1    0.15405E-08    0.10000E+01    0.10918E+04    0.83445E-08    0.25085E-12    0.12448E-16
+    3    1    0.15405E-08    0.10000E+01    0.88049E+03    0.17177E-07    0.92365E-12    0.25570E-16
+    3    1    0.15405E-08    0.10000E+01    0.71007E+03    0.34659E-07    0.33633E-11    0.51512E-16
+    3    1    0.15405E-08    0.10000E+01    0.57264E+03    0.68732E-07    0.11965E-10    0.10202E-15
+    3    1    0.15405E-08    0.10000E+01    0.46180E+03    0.13405E-06    0.40239E-10    0.19877E-15
+    3    1    0.15405E-08    0.10000E+01    0.37242E+03    0.25590E-06    0.12269E-09    0.37913E-15
+    3    1    0.15405E-08    0.10000E+01    0.30034E+03    0.47270E-06    0.32907E-09    0.69988E-15
+    3    1    0.15405E-08    0.10000E+01    0.24221E+03    0.83283E-06    0.76833E-09    0.12325E-14
+    3    1    0.15405E-08    0.10000E+01    0.19533E+03    0.13126E-05    0.14601E-08    0.19419E-14
+    3    1    0.15405E-08    0.10000E+01    0.15752E+03    0.13126E-05    0.14601E-08    0.19419E-14
+    3    1    0.26880E-08    0.10000E+01    0.80645E+05    0.44147E-55    0.32899E-66    0.76539E-63
+    3    1    0.26880E-08    0.10000E+01    0.65036E+05    0.37227E-54    0.52097E-65    0.64519E-62
+    3    1    0.26880E-08    0.10000E+01    0.52449E+05    0.31535E-53    0.69411E-64    0.54648E-61
+    3    1    0.26880E-08    0.10000E+01    0.42297E+05    0.23562E-52    0.92815E-63    0.40832E-60
+    3    1    0.26880E-08    0.10000E+01    0.34111E+05    0.16767E-51    0.12398E-61    0.29071E-59
+    3    1    0.26880E-08    0.10000E+01    0.27509E+05    0.11758E-50    0.16033E-60    0.20417E-58
+    3    1    0.26880E-08    0.10000E+01    0.22184E+05    0.80503E-50    0.19916E-59    0.14006E-57
+    3    1    0.26880E-08    0.10000E+01    0.17891E+05    0.53362E-49    0.24604E-58    0.92169E-57
+    3    1    0.26880E-08    0.10000E+01    0.14428E+05    0.35072E-48    0.34415E-57    0.57325E-56
+    3    1    0.26880E-08    0.10000E+01    0.11635E+05    0.25233E-47    0.64825E-56    0.33641E-55
+    3    1    0.26880E-08    0.10000E+01    0.93834E+04    0.23294E-46    0.16099E-54    0.19548E-54
+    3    1    0.26880E-08    0.10000E+01    0.75673E+04    0.28462E-45    0.44413E-53    0.13553E-53
+    3    1    0.26880E-08    0.10000E+01    0.61026E+04    0.40026E-44    0.12346E-51    0.13880E-52
+    3    1    0.26880E-08    0.10000E+01    0.49215E+04    0.57964E-43    0.33900E-50    0.18524E-51
+    3    1    0.26880E-08    0.10000E+01    0.39689E+04    0.83490E-42    0.92262E-49    0.26049E-50
+    3    1    0.26880E-08    0.10000E+01    0.32008E+04    0.37529E-39    0.80913E-46    0.11368E-47
+    3    1    0.26880E-08    0.10000E+01    0.25813E+04    0.27821E-30    0.13740E-36    0.81010E-39
+    3    1    0.26880E-08    0.10000E+01    0.20817E+04    0.53615E-14    0.11804E-19    0.14934E-22
+    3    1    0.26880E-08    0.10000E+01    0.16788E+04    0.18283E-08    0.17519E-13    0.49687E-17
+    3    1    0.26880E-08    0.10000E+01    0.13538E+04    0.39332E-08    0.66577E-13    0.10530E-16
+    3    1    0.26880E-08    0.10000E+01    0.10918E+04    0.82717E-08    0.24827E-12    0.21919E-16
+    3    1    0.26880E-08    0.10000E+01    0.88049E+03    0.17018E-07    0.91395E-12    0.44767E-16
+    3    1    0.26880E-08    0.10000E+01    0.71007E+03    0.34323E-07    0.33274E-11    0.89807E-16
+    3    1    0.26880E-08    0.10000E+01    0.57264E+03    0.68044E-07    0.11836E-10    0.17732E-15
+    3    1    0.26880E-08    0.10000E+01    0.46180E+03    0.13268E-06    0.39802E-10    0.34468E-15
+    3    1    0.26880E-08    0.10000E+01    0.37242E+03    0.25323E-06    0.12135E-09    0.65633E-15
+    3    1    0.26880E-08    0.10000E+01    0.30034E+03    0.46768E-06    0.32547E-09    0.12102E-14
+    3    1    0.26880E-08    0.10000E+01    0.24221E+03    0.82391E-06    0.75991E-09    0.21294E-14
+    3    1    0.26880E-08    0.10000E+01    0.19533E+03    0.12984E-05    0.14440E-08    0.33534E-14
+    3    1    0.26880E-08    0.10000E+01    0.15752E+03    0.12984E-05    0.14440E-08    0.33534E-14
+    3    1    0.46905E-08    0.10000E+01    0.80645E+05    0.84914E-55    0.63264E-66    0.25137E-62
+    3    1    0.46905E-08    0.10000E+01    0.65036E+05    0.71591E-54    0.10018E-64    0.21198E-61
+    3    1    0.46905E-08    0.10000E+01    0.52449E+05    0.60640E-53    0.13347E-63    0.17961E-60
+    3    1    0.46905E-08    0.10000E+01    0.42297E+05    0.45308E-52    0.17852E-62    0.13429E-59
+    3    1    0.46905E-08    0.10000E+01    0.34111E+05    0.32249E-51    0.23870E-61    0.95741E-59
+    3    1    0.46905E-08    0.10000E+01    0.27509E+05    0.22631E-50    0.30904E-60    0.67413E-58
+    3    1    0.46905E-08    0.10000E+01    0.22184E+05    0.15505E-49    0.38168E-59    0.46473E-57
+    3    1    0.46905E-08    0.10000E+01    0.17891E+05    0.10224E-48    0.45256E-58    0.30863E-56
+    3    1    0.46905E-08    0.10000E+01    0.14428E+05    0.65022E-48    0.55190E-57    0.19482E-55
+    3    1    0.46905E-08    0.10000E+01    0.11635E+05    0.41896E-47    0.82401E-56    0.11604E-54
+    3    1    0.46905E-08    0.10000E+01    0.93834E+04    0.31427E-46    0.17362E-54    0.66133E-54
+    3    1    0.46905E-08    0.10000E+01    0.75673E+04    0.31973E-45    0.45741E-53    0.40197E-53
+    3    1    0.46905E-08    0.10000E+01    0.61026E+04    0.41790E-44    0.12665E-51    0.33476E-52
+    3    1    0.46905E-08    0.10000E+01    0.49215E+04    0.59589E-43    0.34720E-50    0.40051E-51
+    3    1    0.46905E-08    0.10000E+01    0.39689E+04    0.85492E-42    0.94020E-49    0.54427E-50
+    3    1    0.46905E-08    0.10000E+01    0.32008E+04    0.38237E-39    0.81918E-46    0.23194E-47
+    3    1    0.46905E-08    0.10000E+01    0.25813E+04    0.28156E-30    0.13815E-36    0.15995E-38
+    3    1    0.46905E-08    0.10000E+01    0.20817E+04    0.53870E-14    0.11779E-19    0.28225E-22
+    3    1    0.46905E-08    0.10000E+01    0.16788E+04    0.18300E-08    0.17429E-13    0.91273E-17
+    3    1    0.46905E-08    0.10000E+01    0.13538E+04    0.39273E-08    0.66194E-13    0.19016E-16
+    3    1    0.46905E-08    0.10000E+01    0.10918E+04    0.82460E-08    0.24672E-12    0.39111E-16
+    3    1    0.46905E-08    0.10000E+01    0.88049E+03    0.16945E-07    0.90786E-12    0.79187E-16
+    3    1    0.46905E-08    0.10000E+01    0.71007E+03    0.34149E-07    0.33042E-11    0.15784E-15
+    3    1    0.46905E-08    0.10000E+01    0.57264E+03    0.67655E-07    0.11751E-10    0.31017E-15
+    3    1    0.46905E-08    0.10000E+01    0.46180E+03    0.13185E-06    0.39511E-10    0.60081E-15
+    3    1    0.46905E-08    0.10000E+01    0.37242E+03    0.25157E-06    0.12045E-09    0.11411E-14
+    3    1    0.46905E-08    0.10000E+01    0.30034E+03    0.46449E-06    0.32304E-09    0.21003E-14
+    3    1    0.46905E-08    0.10000E+01    0.24221E+03    0.81813E-06    0.75423E-09    0.36911E-14
+    3    1    0.46905E-08    0.10000E+01    0.19533E+03    0.12892E-05    0.14332E-08    0.58084E-14
+    3    1    0.46905E-08    0.10000E+01    0.15752E+03    0.12892E-05    0.14332E-08    0.58084E-14
+    3    1    0.81846E-08    0.10000E+01    0.80645E+05    0.16157E-54    0.12039E-65    0.81777E-62
+    3    1    0.81846E-08    0.10000E+01    0.65036E+05    0.13624E-53    0.19067E-64    0.68988E-61
+    3    1    0.81846E-08    0.10000E+01    0.52449E+05    0.11542E-52    0.25416E-63    0.58475E-60
+    3    1    0.81846E-08    0.10000E+01    0.42297E+05    0.86267E-52    0.34029E-62    0.43752E-59
+    3    1    0.81846E-08    0.10000E+01    0.34111E+05    0.61456E-51    0.45595E-61    0.31234E-58
+    3    1    0.81846E-08    0.10000E+01    0.27509E+05    0.43204E-50    0.59265E-60    0.22044E-57
+    3    1    0.81846E-08    0.10000E+01    0.22184E+05    0.29695E-49    0.73515E-59    0.15261E-56
+    3    1    0.81846E-08    0.10000E+01    0.17891E+05    0.19647E-48    0.86568E-58    0.10213E-55
+    3    1    0.81846E-08    0.10000E+01    0.14428E+05    0.12425E-47    0.99469E-57    0.65308E-55
+    3    1    0.81846E-08    0.10000E+01    0.11635E+05    0.76467E-47    0.12439E-55    0.39573E-54
+    3    1    0.81846E-08    0.10000E+01    0.93834E+04    0.49731E-46    0.20939E-54    0.22686E-53
+    3    1    0.81846E-08    0.10000E+01    0.75673E+04    0.40864E-45    0.49634E-53    0.12961E-52
+    3    1    0.81846E-08    0.10000E+01    0.61026E+04    0.46629E-44    0.13469E-51    0.90893E-52
+    3    1    0.81846E-08    0.10000E+01    0.49215E+04    0.63787E-43    0.36725E-50    0.94409E-51
+    3    1    0.81846E-08    0.10000E+01    0.39689E+04    0.90467E-42    0.98534E-49    0.12204E-49
+    3    1    0.81846E-08    0.10000E+01    0.32008E+04    0.40062E-39    0.84797E-46    0.50685E-47
+    3    1    0.81846E-08    0.10000E+01    0.25813E+04    0.29122E-30    0.14099E-36    0.33706E-38
+    3    1    0.81846E-08    0.10000E+01    0.20817E+04    0.54889E-14    0.11826E-19    0.56261E-22
+    3    1    0.81846E-08    0.10000E+01    0.16788E+04    0.18486E-08    0.17379E-13    0.17469E-16
+    3    1    0.81846E-08    0.10000E+01    0.13538E+04    0.39471E-08    0.65916E-13    0.35430E-16
+    3    1    0.81846E-08    0.10000E+01    0.10918E+04    0.82589E-08    0.24542E-12    0.71449E-16
+    3    1    0.81846E-08    0.10000E+01    0.88049E+03    0.16930E-07    0.90241E-12    0.14257E-15
+    3    1    0.81846E-08    0.10000E+01    0.71007E+03    0.34057E-07    0.32825E-11    0.28110E-15
+    3    1    0.81846E-08    0.10000E+01    0.57264E+03    0.67383E-07    0.11669E-10    0.54787E-15
+    3    1    0.81846E-08    0.10000E+01    0.46180E+03    0.13119E-06    0.39227E-10    0.10548E-14
+    3    1    0.81846E-08    0.10000E+01    0.37242E+03    0.25012E-06    0.11957E-09    0.19945E-14
+    3    1    0.81846E-08    0.10000E+01    0.30034E+03    0.46158E-06    0.32064E-09    0.36593E-14
+    3    1    0.81846E-08    0.10000E+01    0.24221E+03    0.81272E-06    0.74859E-09    0.64172E-14
+    3    1    0.81846E-08    0.10000E+01    0.19533E+03    0.12804E-05    0.14225E-08    0.10085E-13
+    3    1    0.81846E-08    0.10000E+01    0.15752E+03    0.12804E-05    0.14225E-08    0.10085E-13
+    3    1    0.14282E-07    0.10000E+01    0.80645E+05    0.30442E-54    0.22691E-65    0.26444E-61
+    3    1    0.14282E-07    0.10000E+01    0.65036E+05    0.25675E-53    0.35946E-64    0.22317E-60
+    3    1    0.14282E-07    0.10000E+01    0.52449E+05    0.21757E-52    0.47947E-63    0.18923E-59
+    3    1    0.14282E-07    0.10000E+01    0.42297E+05    0.16272E-51    0.64280E-62    0.14168E-58
+    3    1    0.14282E-07    0.10000E+01    0.34111E+05    0.11605E-50    0.86337E-61    0.10127E-57
+    3    1    0.14282E-07    0.10000E+01    0.27509E+05    0.81753E-50    0.11274E-59    0.71622E-57
+    3    1    0.14282E-07    0.10000E+01    0.22184E+05    0.56408E-49    0.14089E-58    0.49766E-56
+    3    1    0.14282E-07    0.10000E+01    0.17891E+05    0.37546E-48    0.16701E-57    0.33521E-55
+    3    1    0.14282E-07    0.10000E+01    0.14428E+05    0.23872E-47    0.18921E-56    0.21667E-54
+    3    1    0.14282E-07    0.10000E+01    0.11635E+05    0.14540E-46    0.21527E-55    0.13338E-53
+    3    1    0.14282E-07    0.10000E+01    0.93834E+04    0.88067E-46    0.29254E-54    0.77578E-53
+    3    1    0.14282E-07    0.10000E+01    0.75673E+04    0.60553E-45    0.58326E-53    0.43430E-52
+    3    1    0.14282E-07    0.10000E+01    0.61026E+04    0.57349E-44    0.15051E-51    0.27098E-51
+    3    1    0.14282E-07    0.10000E+01    0.49215E+04    0.72317E-43    0.40568E-50    0.24252E-50
+    3    1    0.14282E-07    0.10000E+01    0.39689E+04    0.10013E-41    0.10738E-48    0.29366E-49
+    3    1    0.14282E-07    0.10000E+01    0.32008E+04    0.43649E-39    0.90644E-46    0.11889E-46
+    3    1    0.14282E-07    0.10000E+01    0.25813E+04    0.31082E-30    0.14709E-36    0.76420E-38
+    3    1    0.14282E-07    0.10000E+01    0.20817E+04    0.57088E-14    0.11967E-19    0.12009E-21
+    3    1    0.14282E-07    0.10000E+01    0.16788E+04    0.18924E-08    0.17356E-13    0.35443E-16
+    3    1    0.14282E-07    0.10000E+01    0.13538E+04    0.40020E-08    0.65652E-13    0.69167E-16
+    3    1    0.14282E-07    0.10000E+01    0.10918E+04    0.83184E-08    0.24397E-12    0.13540E-15
+    3    1    0.14282E-07    0.10000E+01    0.88049E+03    0.16972E-07    0.89579E-12    0.26406E-15
+    3    1    0.14282E-07    0.10000E+01    0.71007E+03    0.34023E-07    0.32552E-11    0.51154E-15
+    3    1    0.14282E-07    0.10000E+01    0.57264E+03    0.67146E-07    0.11564E-10    0.98359E-15
+    3    1    0.14282E-07    0.10000E+01    0.46180E+03    0.13048E-06    0.38856E-10    0.18743E-14
+    3    1    0.14282E-07    0.10000E+01    0.37242E+03    0.24843E-06    0.11841E-09    0.35173E-14
+    3    1    0.14282E-07    0.10000E+01    0.30034E+03    0.45802E-06    0.31748E-09    0.64185E-14
+    3    1    0.14282E-07    0.10000E+01    0.24221E+03    0.80590E-06    0.74114E-09    0.11214E-13
+    3    1    0.14282E-07    0.10000E+01    0.19533E+03    0.12691E-05    0.14082E-08    0.17584E-13
+    3    1    0.14282E-07    0.10000E+01    0.15752E+03    0.12691E-05    0.14082E-08    0.17584E-13
+    3    1    0.24920E-07    0.10000E+01    0.80645E+05    0.56799E-54    0.42354E-65    0.84609E-61
+    3    1    0.24920E-07    0.10000E+01    0.65036E+05    0.47921E-53    0.67115E-64    0.71433E-60
+    3    1    0.24920E-07    0.10000E+01    0.52449E+05    0.40621E-52    0.89589E-63    0.60589E-59
+    3    1    0.24920E-07    0.10000E+01    0.42297E+05    0.30398E-51    0.12027E-61    0.45392E-58
+    3    1    0.24920E-07    0.10000E+01    0.34111E+05    0.21705E-50    0.16193E-60    0.32479E-57
+    3    1    0.24920E-07    0.10000E+01    0.27509E+05    0.15323E-49    0.21238E-59    0.23013E-56
+    3    1    0.24920E-07    0.10000E+01    0.22184E+05    0.10612E-48    0.26744E-58    0.16041E-55
+    3    1    0.24920E-07    0.10000E+01    0.17891E+05    0.71084E-48    0.32040E-57    0.10863E-54
+    3    1    0.24920E-07    0.10000E+01    0.14428E+05    0.45587E-47    0.36499E-56    0.70834E-54
+    3    1    0.24920E-07    0.10000E+01    0.11635E+05    0.27903E-46    0.40136E-55    0.44191E-53
+    3    1    0.24920E-07    0.10000E+01    0.93834E+04    0.16495E-45    0.47141E-54    0.26116E-52
+    3    1    0.24920E-07    0.10000E+01    0.75673E+04    0.10159E-44    0.76552E-53    0.14621E-51
+    3    1    0.24920E-07    0.10000E+01    0.61026E+04    0.79681E-44    0.18024E-51    0.85225E-51
+    3    1    0.24920E-07    0.10000E+01    0.49215E+04    0.88844E-43    0.47589E-50    0.66813E-50
+    3    1    0.24920E-07    0.10000E+01    0.39689E+04    0.11805E-41    0.12392E-48    0.74971E-49
+    3    1    0.24920E-07    0.10000E+01    0.32008E+04    0.50367E-39    0.10197E-45    0.29630E-46
+    3    1    0.24920E-07    0.10000E+01    0.25813E+04    0.34881E-30    0.15962E-36    0.18551E-37
+    3    1    0.24920E-07    0.10000E+01    0.20817E+04    0.61657E-14    0.12352E-19    0.27613E-21
+    3    1    0.24920E-07    0.10000E+01    0.16788E+04    0.19921E-08    0.17496E-13    0.77232E-16
+    3    1    0.24920E-07    0.10000E+01    0.13538E+04    0.41442E-08    0.65869E-13    0.14362E-15
+    3    1    0.24920E-07    0.10000E+01    0.10918E+04    0.85146E-08    0.24393E-12    0.27015E-15
+    3    1    0.24920E-07    0.10000E+01    0.88049E+03    0.17227E-07    0.89340E-12    0.50995E-15
+    3    1    0.24920E-07    0.10000E+01    0.71007E+03    0.34324E-07    0.32407E-11    0.96220E-15
+    3    1    0.24920E-07    0.10000E+01    0.57264E+03    0.67430E-07    0.11499E-10    0.18117E-14
+    3    1    0.24920E-07    0.10000E+01    0.46180E+03    0.13060E-06    0.38609E-10    0.33962E-14
+    3    1    0.24920E-07    0.10000E+01    0.37242E+03    0.24803E-06    0.11760E-09    0.62949E-14
+    3    1    0.24920E-07    0.10000E+01    0.30034E+03    0.45649E-06    0.31523E-09    0.11385E-13
+    3    1    0.24920E-07    0.10000E+01    0.24221E+03    0.80227E-06    0.73576E-09    0.19769E-13
+    3    1    0.24920E-07    0.10000E+01    0.19533E+03    0.12625E-05    0.13979E-08    0.30878E-13
+    3    1    0.24920E-07    0.10000E+01    0.15752E+03    0.12625E-05    0.13979E-08    0.30878E-13
+    3    1    0.43485E-07    0.10000E+01    0.80645E+05    0.10510E-53    0.78406E-65    0.26954E-60
+    3    1    0.43485E-07    0.10000E+01    0.65036E+05    0.88705E-53    0.12428E-63    0.22764E-59
+    3    1    0.43485E-07    0.10000E+01    0.52449E+05    0.75217E-52    0.16602E-62    0.19314E-58
+    3    1    0.43485E-07    0.10000E+01    0.42297E+05    0.56321E-51    0.22317E-61    0.14477E-57
+    3    1    0.43485E-07    0.10000E+01    0.34111E+05    0.40259E-50    0.30113E-60    0.10369E-56
+    3    1    0.43485E-07    0.10000E+01    0.27509E+05    0.28477E-49    0.39653E-59    0.73588E-56
+    3    1    0.43485E-07    0.10000E+01    0.22184E+05    0.19790E-48    0.50282E-58    0.51431E-55
+    3    1    0.43485E-07    0.10000E+01    0.17891E+05    0.13334E-47    0.60891E-57    0.34986E-54
+    3    1    0.43485E-07    0.10000E+01    0.14428E+05    0.86274E-47    0.70205E-56    0.22981E-53
+    3    1    0.43485E-07    0.10000E+01    0.11635E+05    0.53336E-46    0.76941E-55    0.14498E-52
+    3    1    0.43485E-07    0.10000E+01    0.93834E+04    0.31489E-45    0.83738E-54    0.86955E-52
+    3    1    0.43485E-07    0.10000E+01    0.75673E+04    0.18378E-44    0.11296E-52    0.49107E-51
+    3    1    0.43485E-07    0.10000E+01    0.61026E+04    0.12414E-43    0.23332E-51    0.27625E-50
+    3    1    0.43485E-07    0.10000E+01    0.49215E+04    0.11934E-42    0.59575E-50    0.19471E-49
+    3    1    0.43485E-07    0.10000E+01    0.39689E+04    0.14919E-41    0.15251E-48    0.20142E-48
+    3    1    0.43485E-07    0.10000E+01    0.32008E+04    0.62017E-39    0.12195E-45    0.77746E-46
+    3    1    0.43485E-07    0.10000E+01    0.25813E+04    0.41582E-30    0.18220E-36    0.47847E-37
+    3    1    0.43485E-07    0.10000E+01    0.20817E+04    0.69929E-14    0.13076E-19    0.68378E-21
+    3    1    0.43485E-07    0.10000E+01    0.16788E+04    0.21769E-08    0.17804E-13    0.18225E-15
+    3    1    0.43485E-07    0.10000E+01    0.13538E+04    0.44115E-08    0.66480E-13    0.32148E-15
+    3    1    0.43485E-07    0.10000E+01    0.10918E+04    0.88927E-08    0.24471E-12    0.57669E-15
+    3    1    0.43485E-07    0.10000E+01    0.88049E+03    0.17741E-07    0.89234E-12    0.10440E-14
+    3    1    0.43485E-07    0.10000E+01    0.71007E+03    0.34977E-07    0.32269E-11    0.19002E-14
+    3    1    0.43485E-07    0.10000E+01    0.57264E+03    0.68173E-07    0.11426E-10    0.34708E-14
+    3    1    0.43485E-07    0.10000E+01    0.46180E+03    0.13126E-06    0.38313E-10    0.63469E-14
+    3    1    0.43485E-07    0.10000E+01    0.37242E+03    0.24822E-06    0.11661E-09    0.11538E-13
+    3    1    0.43485E-07    0.10000E+01    0.30034E+03    0.45546E-06    0.31243E-09    0.20569E-13
+    3    1    0.43485E-07    0.10000E+01    0.24221E+03    0.79881E-06    0.72902E-09    0.35353E-13
+    3    1    0.43485E-07    0.10000E+01    0.19533E+03    0.12554E-05    0.13849E-08    0.54870E-13
+    3    1    0.43485E-07    0.10000E+01    0.15752E+03    0.12554E-05    0.13849E-08    0.54870E-13
+    3    1    0.75878E-07    0.10000E+01    0.80645E+05    0.19293E-53    0.14399E-64    0.85056E-60
+    3    1    0.75878E-07    0.10000E+01    0.65036E+05    0.16289E-52    0.22830E-63    0.71854E-59
+    3    1    0.75878E-07    0.10000E+01    0.52449E+05    0.13816E-51    0.30518E-62    0.60980E-58
+    3    1    0.75878E-07    0.10000E+01    0.42297E+05    0.10351E-50    0.41074E-61    0.45730E-57
+    3    1    0.75878E-07    0.10000E+01    0.34111E+05    0.74069E-50    0.55532E-60    0.32780E-56
+    3    1    0.75878E-07    0.10000E+01    0.27509E+05    0.52484E-49    0.73379E-59    0.23296E-55
+    3    1    0.75878E-07    0.10000E+01    0.22184E+05    0.36584E-48    0.93610E-58    0.16319E-54
+    3    1    0.75878E-07    0.10000E+01    0.17891E+05    0.24774E-47    0.11445E-56    0.11143E-53
+    3    1    0.75878E-07    0.10000E+01    0.14428E+05    0.16158E-46    0.13367E-55    0.73631E-53
+    3    1    0.75878E-07    0.10000E+01    0.11635E+05    0.10097E-45    0.14784E-54    0.46877E-52
+    3    1    0.75878E-07    0.10000E+01    0.93834E+04    0.60091E-45    0.15625E-53    0.28479E-51
+    3    1    0.75878E-07    0.10000E+01    0.75673E+04    0.34403E-44    0.18447E-52    0.16269E-50
+    3    1    0.75878E-07    0.10000E+01    0.61026E+04    0.21087E-43    0.32835E-51    0.90097E-50
+    3    1    0.75878E-07    0.10000E+01    0.49215E+04    0.17543E-42    0.79923E-50    0.58681E-49
+    3    1    0.75878E-07    0.10000E+01    0.39689E+04    0.20309E-41    0.20144E-48    0.56056E-48
+    3    1    0.75878E-07    0.10000E+01    0.32008E+04    0.82056E-39    0.15688E-45    0.21124E-45
+    3    1    0.75878E-07    0.10000E+01    0.25813E+04    0.53309E-30    0.22263E-36    0.12883E-36
+    3    1    0.75878E-07    0.10000E+01    0.20817E+04    0.84860E-14    0.14460E-19    0.17965E-20
+    3    1    0.75878E-07    0.10000E+01    0.16788E+04    0.25209E-08    0.18518E-13    0.46195E-15
+    3    1    0.75878E-07    0.10000E+01    0.13538E+04    0.49208E-08    0.68214E-13    0.77574E-15
+    3    1    0.75878E-07    0.10000E+01    0.10918E+04    0.96387E-08    0.24856E-12    0.13259E-14
+    3    1    0.75878E-07    0.10000E+01    0.88049E+03    0.18811E-07    0.89969E-12    0.22918E-14
+    3    1    0.75878E-07    0.10000E+01    0.71007E+03    0.36464E-07    0.32364E-11    0.39946E-14
+    3    1    0.75878E-07    0.10000E+01    0.57264E+03    0.70156E-07    0.11419E-10    0.70160E-14
+    3    1    0.75878E-07    0.10000E+01    0.46180E+03    0.13376E-06    0.38203E-10    0.12400E-13
+    3    1    0.75878E-07    0.10000E+01    0.37242E+03    0.25111E-06    0.11612E-09    0.21917E-13
+    3    1    0.75878E-07    0.10000E+01    0.30034E+03    0.45840E-06    0.31085E-09    0.38230E-13
+    3    1    0.75878E-07    0.10000E+01    0.24221E+03    0.80111E-06    0.72499E-09    0.64669E-13
+    3    1    0.75878E-07    0.10000E+01    0.19533E+03    0.12563E-05    0.13768E-08    0.99357E-13
+    3    1    0.75878E-07    0.10000E+01    0.15752E+03    0.12563E-05    0.13768E-08    0.99357E-13
+    3    1    0.13240E-06    0.10000E+01    0.80645E+05    0.35149E-53    0.26243E-64    0.26493E-59
+    3    1    0.13240E-06    0.10000E+01    0.65036E+05    0.29686E-52    0.41619E-63    0.22387E-58
+    3    1    0.13240E-06    0.10000E+01    0.52449E+05    0.25186E-51    0.55670E-62    0.19003E-57
+    3    1    0.13240E-06    0.10000E+01    0.42297E+05    0.18879E-50    0.75005E-61    0.14256E-56
+    3    1    0.13240E-06    0.10000E+01    0.34111E+05    0.13522E-49    0.10159E-59    0.10226E-55
+    3    1    0.13240E-06    0.10000E+01    0.27509E+05    0.95960E-49    0.13464E-58    0.72760E-55
+    3    1    0.13240E-06    0.10000E+01    0.22184E+05    0.67063E-48    0.17264E-57    0.51065E-54
+    3    1    0.13240E-06    0.10000E+01    0.17891E+05    0.45613E-47    0.21282E-56    0.34977E-53
+    3    1    0.13240E-06    0.10000E+01    0.14428E+05    0.29957E-46    0.25150E-55    0.23226E-52
+    3    1    0.13240E-06    0.10000E+01    0.11635E+05    0.18905E-45    0.28182E-54    0.14896E-51
+    3    1    0.13240E-06    0.10000E+01    0.93834E+04    0.11374E-44    0.29637E-53    0.91462E-51
+    3    1    0.13240E-06    0.10000E+01    0.75673E+04    0.64991E-44    0.32234E-52    0.52854E-50
+    3    1    0.13240E-06    0.10000E+01    0.61026E+04    0.37686E-43    0.49738E-51    0.29128E-49
+    3    1    0.13240E-06    0.10000E+01    0.49215E+04    0.27755E-42    0.11389E-49    0.17945E-48
+    3    1    0.13240E-06    0.10000E+01    0.39689E+04    0.29504E-41    0.28323E-48    0.15939E-47
+    3    1    0.13240E-06    0.10000E+01    0.32008E+04    0.11576E-38    0.21621E-45    0.58612E-45
+    3    1    0.13240E-06    0.10000E+01    0.25813E+04    0.73259E-30    0.29238E-36    0.35614E-36
+    3    1    0.13240E-06    0.10000E+01    0.20817E+04    0.11079E-13    0.16893E-19    0.49130E-20
+    3    1    0.13240E-06    0.10000E+01    0.16788E+04    0.31279E-08    0.19813E-13    0.12354E-14
+    3    1    0.13240E-06    0.10000E+01    0.13538E+04    0.58205E-08    0.71440E-13    0.19932E-14
+    3    1    0.13240E-06    0.10000E+01    0.10918E+04    0.10963E-07    0.25607E-12    0.32657E-14
+    3    1    0.13240E-06    0.10000E+01    0.88049E+03    0.20725E-07    0.91554E-12    0.54012E-14
+    3    1    0.13240E-06    0.10000E+01    0.71007E+03    0.39159E-07    0.32643E-11    0.90015E-14
+    3    1    0.13240E-06    0.10000E+01    0.57264E+03    0.73823E-07    0.11448E-10    0.15127E-13
+    3    1    0.13240E-06    0.10000E+01    0.46180E+03    0.13853E-06    0.38151E-10    0.25647E-13
+    3    1    0.13240E-06    0.10000E+01    0.37242E+03    0.25699E-06    0.11569E-09    0.43694E-13
+    3    1    0.13240E-06    0.10000E+01    0.30034E+03    0.46510E-06    0.30928E-09    0.73951E-13
+    3    1    0.13240E-06    0.10000E+01    0.24221E+03    0.80796E-06    0.72072E-09    0.12224E-12
+    3    1    0.13240E-06    0.10000E+01    0.19533E+03    0.12624E-05    0.13681E-08    0.18497E-12
+    3    1    0.13240E-06    0.10000E+01    0.15752E+03    0.12624E-05    0.13681E-08    0.18497E-12
+    3    1    0.23103E-06    0.10000E+01    0.80645E+05    0.62184E-53    0.46434E-64    0.57270E-59
+    3    1    0.23103E-06    0.10000E+01    0.65036E+05    0.52524E-52    0.73646E-63    0.48397E-58
+    3    1    0.23103E-06    0.10000E+01    0.52449E+05    0.44567E-51    0.98531E-62    0.41084E-57
+    3    1    0.23103E-06    0.10000E+01    0.42297E+05    0.33413E-50    0.13280E-60    0.30827E-56
+    3    1    0.23103E-06    0.10000E+01    0.34111E+05    0.23939E-49    0.17998E-59    0.22118E-55
+    3    1    0.23103E-06    0.10000E+01    0.27509E+05    0.16998E-48    0.23878E-58    0.15742E-54
+    3    1    0.23103E-06    0.10000E+01    0.22184E+05    0.11890E-47    0.30673E-57    0.11055E-53
+    3    1    0.23103E-06    0.10000E+01    0.17891E+05    0.80993E-47    0.37918E-56    0.75799E-53
+    3    1    0.23103E-06    0.10000E+01    0.14428E+05    0.53319E-46    0.44995E-55    0.50413E-52
+    3    1    0.23103E-06    0.10000E+01    0.11635E+05    0.33767E-45    0.50678E-54    0.32409E-51
+    3    1    0.23103E-06    0.10000E+01    0.93834E+04    0.20402E-44    0.53377E-53    0.19968E-50
+    3    1    0.23103E-06    0.10000E+01    0.75673E+04    0.11677E-43    0.56856E-52    0.11585E-49
+    3    1    0.23103E-06    0.10000E+01    0.61026E+04    0.66804E-43    0.83475E-51    0.63832E-49
+    3    1    0.23103E-06    0.10000E+01    0.49215E+04    0.47306E-42    0.18618E-49    0.38697E-48
+    3    1    0.23103E-06    0.10000E+01    0.39689E+04    0.48639E-41    0.46084E-48    0.33532E-47
+    3    1    0.23103E-06    0.10000E+01    0.32008E+04    0.18868E-38    0.34985E-45    0.12217E-44
+    3    1    0.23103E-06    0.10000E+01    0.25813E+04    0.11844E-29    0.46547E-36    0.74197E-36
+    3    1    0.23103E-06    0.10000E+01    0.20817E+04    0.17609E-13    0.25667E-19    0.10221E-19
+    3    1    0.23103E-06    0.10000E+01    0.16788E+04    0.48777E-08    0.28888E-13    0.25561E-14
+    3    1    0.23103E-06    0.10000E+01    0.13538E+04    0.88944E-08    0.10303E-12    0.40733E-14
+    3    1    0.23103E-06    0.10000E+01    0.10918E+04    0.16460E-07    0.36612E-12    0.65838E-14
+    3    1    0.23103E-06    0.10000E+01    0.88049E+03    0.30655E-07    0.13004E-11    0.10728E-13
+    3    1    0.23103E-06    0.10000E+01    0.71007E+03    0.57200E-07    0.46142E-11    0.17596E-13
+    3    1    0.23103E-06    0.10000E+01    0.57264E+03    0.10673E-06    0.16128E-10    0.29079E-13
+    3    1    0.23103E-06    0.10000E+01    0.46180E+03    0.19864E-06    0.53633E-10    0.48484E-13
+    3    1    0.23103E-06    0.10000E+01    0.37242E+03    0.36616E-06    0.16242E-09    0.81323E-13
+    3    1    0.23103E-06    0.10000E+01    0.30034E+03    0.65958E-06    0.43388E-09    0.13580E-12
+    3    1    0.23103E-06    0.10000E+01    0.24221E+03    0.11421E-05    0.10106E-08    0.22208E-12
+    3    1    0.23103E-06    0.10000E+01    0.19533E+03    0.17808E-05    0.19179E-08    0.33363E-12
+    3    1    0.23103E-06    0.10000E+01    0.15752E+03    0.17808E-05    0.19179E-08    0.33363E-12
+    3    1    0.40314E-06    0.10000E+01    0.80645E+05    0.10851E-52    0.81024E-64    0.99933E-59
+    3    1    0.40314E-06    0.10000E+01    0.65036E+05    0.91650E-52    0.12851E-62    0.84451E-58
+    3    1    0.40314E-06    0.10000E+01    0.52449E+05    0.77767E-51    0.17193E-61    0.71690E-57
+    3    1    0.40314E-06    0.10000E+01    0.42297E+05    0.58304E-50    0.23173E-60    0.53791E-56
+    3    1    0.40314E-06    0.10000E+01    0.34111E+05    0.41772E-49    0.31405E-59    0.38594E-55
+    3    1    0.40314E-06    0.10000E+01    0.27509E+05    0.29661E-48    0.41666E-58    0.27470E-54
+    3    1    0.40314E-06    0.10000E+01    0.22184E+05    0.20747E-47    0.53522E-57    0.19291E-53
+    3    1    0.40314E-06    0.10000E+01    0.17891E+05    0.14133E-46    0.66165E-56    0.13226E-52
+    3    1    0.40314E-06    0.10000E+01    0.14428E+05    0.93039E-46    0.78513E-55    0.87968E-52
+    3    1    0.40314E-06    0.10000E+01    0.11635E+05    0.58921E-45    0.88430E-54    0.56552E-51
+    3    1    0.40314E-06    0.10000E+01    0.93834E+04    0.35600E-44    0.93140E-53    0.34843E-50
+    3    1    0.40314E-06    0.10000E+01    0.75673E+04    0.20375E-43    0.99210E-52    0.20216E-49
+    3    1    0.40314E-06    0.10000E+01    0.61026E+04    0.11657E-42    0.14566E-50    0.11138E-48
+    3    1    0.40314E-06    0.10000E+01    0.49215E+04    0.82547E-42    0.32487E-49    0.67524E-48
+    3    1    0.40314E-06    0.10000E+01    0.39689E+04    0.84872E-41    0.80414E-48    0.58511E-47
+    3    1    0.40314E-06    0.10000E+01    0.32008E+04    0.32923E-38    0.61047E-45    0.21319E-44
+    3    1    0.40314E-06    0.10000E+01    0.25813E+04    0.20668E-29    0.81221E-36    0.12947E-35
+    3    1    0.40314E-06    0.10000E+01    0.20817E+04    0.30727E-13    0.44788E-19    0.17834E-19
+    3    1    0.40314E-06    0.10000E+01    0.16788E+04    0.85112E-08    0.50407E-13    0.44602E-14
+    3    1    0.40314E-06    0.10000E+01    0.13538E+04    0.15520E-07    0.17978E-12    0.71077E-14
+    3    1    0.40314E-06    0.10000E+01    0.10918E+04    0.28723E-07    0.63886E-12    0.11488E-13
+    3    1    0.40314E-06    0.10000E+01    0.88049E+03    0.53491E-07    0.22692E-11    0.18721E-13
+    3    1    0.40314E-06    0.10000E+01    0.71007E+03    0.99810E-07    0.80516E-11    0.30703E-13
+    3    1    0.40314E-06    0.10000E+01    0.57264E+03    0.18623E-06    0.28142E-10    0.50741E-13
+    3    1    0.40314E-06    0.10000E+01    0.46180E+03    0.34661E-06    0.93586E-10    0.84602E-13
+    3    1    0.40314E-06    0.10000E+01    0.37242E+03    0.63892E-06    0.28342E-09    0.14190E-12
+    3    1    0.40314E-06    0.10000E+01    0.30034E+03    0.11509E-05    0.75710E-09    0.23695E-12
+    3    1    0.40314E-06    0.10000E+01    0.24221E+03    0.19928E-05    0.17635E-08    0.38751E-12
+    3    1    0.40314E-06    0.10000E+01    0.19533E+03    0.31074E-05    0.33466E-08    0.58216E-12
+    3    1    0.40314E-06    0.10000E+01    0.15752E+03    0.31074E-05    0.33466E-08    0.58216E-12
+    3    1    0.70346E-06    0.10000E+01    0.80645E+05    0.18934E-52    0.14138E-63    0.17438E-58
+    3    1    0.70346E-06    0.10000E+01    0.65036E+05    0.15992E-51    0.22424E-62    0.14736E-57
+    3    1    0.70346E-06    0.10000E+01    0.52449E+05    0.13570E-50    0.30001E-61    0.12509E-56
+    3    1    0.70346E-06    0.10000E+01    0.42297E+05    0.10174E-49    0.40436E-60    0.93861E-56
+    3    1    0.70346E-06    0.10000E+01    0.34111E+05    0.72889E-49    0.54800E-59    0.67344E-55
+    3    1    0.70346E-06    0.10000E+01    0.27509E+05    0.51756E-48    0.72704E-58    0.47933E-54
+    3    1    0.70346E-06    0.10000E+01    0.22184E+05    0.36203E-47    0.93392E-57    0.33662E-53
+    3    1    0.70346E-06    0.10000E+01    0.17891E+05    0.24661E-46    0.11545E-55    0.23079E-52
+    3    1    0.70346E-06    0.10000E+01    0.14428E+05    0.16235E-45    0.13700E-54    0.15350E-51
+    3    1    0.70346E-06    0.10000E+01    0.11635E+05    0.10281E-44    0.15430E-53    0.98681E-51
+    3    1    0.70346E-06    0.10000E+01    0.93834E+04    0.62119E-44    0.16252E-52    0.60798E-50
+    3    1    0.70346E-06    0.10000E+01    0.75673E+04    0.35554E-43    0.17312E-51    0.35275E-49
+    3    1    0.70346E-06    0.10000E+01    0.61026E+04    0.20340E-42    0.25417E-50    0.19436E-48
+    3    1    0.70346E-06    0.10000E+01    0.49215E+04    0.14404E-41    0.56687E-49    0.11783E-47
+    3    1    0.70346E-06    0.10000E+01    0.39689E+04    0.14810E-40    0.14032E-47    0.10210E-46
+    3    1    0.70346E-06    0.10000E+01    0.32008E+04    0.57449E-38    0.10652E-44    0.37200E-44
+    3    1    0.70346E-06    0.10000E+01    0.25813E+04    0.36064E-29    0.14173E-35    0.22592E-35
+    3    1    0.70346E-06    0.10000E+01    0.20817E+04    0.53617E-13    0.78152E-19    0.31120E-19
+    3    1    0.70346E-06    0.10000E+01    0.16788E+04    0.14852E-07    0.87958E-13    0.77828E-14
+    3    1    0.70346E-06    0.10000E+01    0.13538E+04    0.27082E-07    0.31370E-12    0.12403E-13
+    3    1    0.70346E-06    0.10000E+01    0.10918E+04    0.50119E-07    0.11148E-11    0.20046E-13
+    3    1    0.70346E-06    0.10000E+01    0.88049E+03    0.93338E-07    0.39596E-11    0.32666E-13
+    3    1    0.70346E-06    0.10000E+01    0.71007E+03    0.17416E-06    0.14050E-10    0.53576E-13
+    3    1    0.70346E-06    0.10000E+01    0.57264E+03    0.32497E-06    0.49106E-10    0.88540E-13
+    3    1    0.70346E-06    0.10000E+01    0.46180E+03    0.60481E-06    0.16330E-09    0.14763E-12
+    3    1    0.70346E-06    0.10000E+01    0.37242E+03    0.11149E-05    0.49454E-09    0.24761E-12
+    3    1    0.70346E-06    0.10000E+01    0.30034E+03    0.20083E-05    0.13211E-08    0.41347E-12
+    3    1    0.70346E-06    0.10000E+01    0.24221E+03    0.34773E-05    0.30771E-08    0.67618E-12
+    3    1    0.70346E-06    0.10000E+01    0.19533E+03    0.54222E-05    0.58395E-08    0.10158E-11
+    3    1    0.70346E-06    0.10000E+01    0.15752E+03    0.54222E-05    0.58395E-08    0.10158E-11
+    3    1    0.12275E-05    0.10000E+01    0.80645E+05    0.33038E-52    0.24670E-63    0.30428E-58
+    3    1    0.12275E-05    0.10000E+01    0.65036E+05    0.27906E-51    0.39128E-62    0.25714E-57
+    3    1    0.12275E-05    0.10000E+01    0.52449E+05    0.23679E-50    0.52350E-61    0.21828E-56
+    3    1    0.12275E-05    0.10000E+01    0.42297E+05    0.17752E-49    0.70559E-60    0.16378E-55
+    3    1    0.12275E-05    0.10000E+01    0.34111E+05    0.12719E-48    0.95622E-59    0.11751E-54
+    3    1    0.12275E-05    0.10000E+01    0.27509E+05    0.90311E-48    0.12686E-57    0.83640E-54
+    3    1    0.12275E-05    0.10000E+01    0.22184E+05    0.63172E-47    0.16296E-56    0.58737E-53
+    3    1    0.12275E-05    0.10000E+01    0.17891E+05    0.43032E-46    0.20146E-55    0.40272E-52
+    3    1    0.12275E-05    0.10000E+01    0.14428E+05    0.28329E-45    0.23906E-54    0.26785E-51
+    3    1    0.12275E-05    0.10000E+01    0.11635E+05    0.17940E-44    0.26925E-53    0.17219E-50
+    3    1    0.12275E-05    0.10000E+01    0.93834E+04    0.10839E-43    0.28359E-52    0.10609E-49
+    3    1    0.12275E-05    0.10000E+01    0.75673E+04    0.62039E-43    0.30208E-51    0.61553E-49
+    3    1    0.12275E-05    0.10000E+01    0.61026E+04    0.35493E-42    0.44350E-50    0.33914E-48
+    3    1    0.12275E-05    0.10000E+01    0.49215E+04    0.25134E-41    0.98915E-49    0.20560E-47
+    3    1    0.12275E-05    0.10000E+01    0.39689E+04    0.25842E-40    0.24485E-47    0.17815E-46
+    3    1    0.12275E-05    0.10000E+01    0.32008E+04    0.10025E-37    0.18588E-44    0.64912E-44
+    3    1    0.12275E-05    0.10000E+01    0.25813E+04    0.62929E-29    0.24730E-35    0.39421E-35
+    3    1    0.12275E-05    0.10000E+01    0.20817E+04    0.93558E-13    0.13637E-18    0.54302E-19
+    3    1    0.12275E-05    0.10000E+01    0.16788E+04    0.25915E-07    0.15348E-12    0.13581E-13
+    3    1    0.12275E-05    0.10000E+01    0.13538E+04    0.47256E-07    0.54739E-12    0.21642E-13
+    3    1    0.12275E-05    0.10000E+01    0.10918E+04    0.87455E-07    0.19452E-11    0.34980E-13
+    3    1    0.12275E-05    0.10000E+01    0.88049E+03    0.16287E-06    0.69092E-11    0.57001E-13
+    3    1    0.12275E-05    0.10000E+01    0.71007E+03    0.30390E-06    0.24516E-10    0.93486E-13
+    3    1    0.12275E-05    0.10000E+01    0.57264E+03    0.56705E-06    0.85687E-10    0.15450E-12
+    3    1    0.12275E-05    0.10000E+01    0.46180E+03    0.10554E-05    0.28495E-09    0.25760E-12
+    3    1    0.12275E-05    0.10000E+01    0.37242E+03    0.19454E-05    0.86295E-09    0.43207E-12
+    3    1    0.12275E-05    0.10000E+01    0.30034E+03    0.35043E-05    0.23052E-08    0.72148E-12
+    3    1    0.12275E-05    0.10000E+01    0.24221E+03    0.60678E-05    0.53694E-08    0.11799E-11
+    3    1    0.12275E-05    0.10000E+01    0.19533E+03    0.94614E-05    0.10190E-07    0.17726E-11
+    3    1    0.12275E-05    0.10000E+01    0.15752E+03    0.94614E-05    0.10190E-07    0.17726E-11
+    3    1    0.21419E-05    0.10000E+01    0.80645E+05    0.57650E-52    0.43048E-63    0.53095E-58
+    3    1    0.21419E-05    0.10000E+01    0.65036E+05    0.48694E-51    0.68276E-62    0.44869E-57
+    3    1    0.21419E-05    0.10000E+01    0.52449E+05    0.41318E-50    0.91347E-61    0.38089E-56
+    3    1    0.21419E-05    0.10000E+01    0.42297E+05    0.30977E-49    0.12312E-59    0.28579E-55
+    3    1    0.21419E-05    0.10000E+01    0.34111E+05    0.22193E-48    0.16686E-58    0.20505E-54
+    3    1    0.21419E-05    0.10000E+01    0.27509E+05    0.15759E-47    0.22137E-57    0.14595E-53
+    3    1    0.21419E-05    0.10000E+01    0.22184E+05    0.11023E-46    0.28436E-56    0.10249E-52
+    3    1    0.21419E-05    0.10000E+01    0.17891E+05    0.75088E-46    0.35154E-55    0.70273E-52
+    3    1    0.21419E-05    0.10000E+01    0.14428E+05    0.49432E-45    0.41714E-54    0.46738E-51
+    3    1    0.21419E-05    0.10000E+01    0.11635E+05    0.31305E-44    0.46983E-53    0.30046E-50
+    3    1    0.21419E-05    0.10000E+01    0.93834E+04    0.18914E-43    0.49485E-52    0.18512E-49
+    3    1    0.21419E-05    0.10000E+01    0.75673E+04    0.10825E-42    0.52710E-51    0.10741E-48
+    3    1    0.21419E-05    0.10000E+01    0.61026E+04    0.61933E-42    0.77389E-50    0.59178E-48
+    3    1    0.21419E-05    0.10000E+01    0.49215E+04    0.43857E-41    0.17260E-48    0.35876E-47
+    3    1    0.21419E-05    0.10000E+01    0.39689E+04    0.45093E-40    0.42724E-47    0.31087E-46
+    3    1    0.21419E-05    0.10000E+01    0.32008E+04    0.17492E-37    0.32434E-44    0.11327E-43
+    3    1    0.21419E-05    0.10000E+01    0.25813E+04    0.10981E-28    0.43153E-35    0.68787E-35
+    3    1    0.21419E-05    0.10000E+01    0.20817E+04    0.16325E-12    0.23796E-18    0.94754E-19
+    3    1    0.21419E-05    0.10000E+01    0.16788E+04    0.45220E-07    0.26781E-12    0.23697E-13
+    3    1    0.21419E-05    0.10000E+01    0.13538E+04    0.82459E-07    0.95516E-12    0.37764E-13
+    3    1    0.21419E-05    0.10000E+01    0.10918E+04    0.15260E-06    0.33943E-11    0.61038E-13
+    3    1    0.21419E-05    0.10000E+01    0.88049E+03    0.28420E-06    0.12056E-10    0.99462E-13
+    3    1    0.21419E-05    0.10000E+01    0.71007E+03    0.53029E-06    0.42778E-10    0.16313E-12
+    3    1    0.21419E-05    0.10000E+01    0.57264E+03    0.98946E-06    0.14952E-09    0.26959E-12
+    3    1    0.21419E-05    0.10000E+01    0.46180E+03    0.18415E-05    0.49722E-09    0.44949E-12
+    3    1    0.21419E-05    0.10000E+01    0.37242E+03    0.33946E-05    0.15058E-08    0.75393E-12
+    3    1    0.21419E-05    0.10000E+01    0.30034E+03    0.61149E-05    0.40225E-08    0.12589E-11
+    3    1    0.21419E-05    0.10000E+01    0.24221E+03    0.10588E-04    0.93693E-08    0.20589E-11
+    3    1    0.21419E-05    0.10000E+01    0.19533E+03    0.16510E-04    0.17780E-07    0.30930E-11
+    3    1    0.21419E-05    0.10000E+01    0.15752E+03    0.16510E-04    0.17780E-07    0.30930E-11
+    3    1    0.37375E-05    0.10000E+01    0.80645E+05    0.10060E-51    0.75117E-63    0.92647E-58
+    3    1    0.37375E-05    0.10000E+01    0.65036E+05    0.84968E-51    0.11914E-61    0.78293E-57
+    3    1    0.37375E-05    0.10000E+01    0.52449E+05    0.72097E-50    0.15940E-60    0.66463E-56
+    3    1    0.37375E-05    0.10000E+01    0.42297E+05    0.54053E-49    0.21484E-59    0.49869E-55
+    3    1    0.37375E-05    0.10000E+01    0.34111E+05    0.38726E-48    0.29115E-58    0.35780E-54
+    3    1    0.37375E-05    0.10000E+01    0.27509E+05    0.27498E-47    0.38628E-57    0.25467E-53
+    3    1    0.37375E-05    0.10000E+01    0.22184E+05    0.19235E-46    0.49619E-56    0.17884E-52
+    3    1    0.37375E-05    0.10000E+01    0.17891E+05    0.13102E-45    0.61341E-55    0.12262E-51
+    3    1    0.37375E-05    0.10000E+01    0.14428E+05    0.86256E-45    0.72789E-54    0.81554E-51
+    3    1    0.37375E-05    0.10000E+01    0.11635E+05    0.54625E-44    0.81982E-53    0.52429E-50
+    3    1    0.37375E-05    0.10000E+01    0.93834E+04    0.33004E-43    0.86349E-52    0.32302E-49
+    3    1    0.37375E-05    0.10000E+01    0.75673E+04    0.18890E-42    0.91977E-51    0.18742E-48
+    3    1    0.37375E-05    0.10000E+01    0.61026E+04    0.10807E-41    0.13504E-49    0.10326E-47
+    3    1    0.37375E-05    0.10000E+01    0.49215E+04    0.76528E-41    0.30118E-48    0.62601E-47
+    3    1    0.37375E-05    0.10000E+01    0.39689E+04    0.78684E-40    0.74551E-47    0.54244E-46
+    3    1    0.37375E-05    0.10000E+01    0.32008E+04    0.30523E-37    0.56596E-44    0.19764E-43
+    3    1    0.37375E-05    0.10000E+01    0.25813E+04    0.19161E-28    0.75300E-35    0.12003E-34
+    3    1    0.37375E-05    0.10000E+01    0.20817E+04    0.28487E-12    0.41522E-18    0.16534E-18
+    3    1    0.37375E-05    0.10000E+01    0.16788E+04    0.78907E-07    0.46732E-12    0.41350E-13
+    3    1    0.37375E-05    0.10000E+01    0.13538E+04    0.14389E-06    0.16667E-11    0.65895E-13
+    3    1    0.37375E-05    0.10000E+01    0.10918E+04    0.26628E-06    0.59228E-11    0.10651E-12
+    3    1    0.37375E-05    0.10000E+01    0.88049E+03    0.49591E-06    0.21037E-10    0.17356E-12
+    3    1    0.37375E-05    0.10000E+01    0.71007E+03    0.92533E-06    0.74645E-10    0.28465E-12
+    3    1    0.37375E-05    0.10000E+01    0.57264E+03    0.17266E-05    0.26090E-09    0.47042E-12
+    3    1    0.37375E-05    0.10000E+01    0.46180E+03    0.32134E-05    0.86762E-09    0.78433E-12
+    3    1    0.37375E-05    0.10000E+01    0.37242E+03    0.59234E-05    0.26275E-08    0.13156E-11
+    3    1    0.37375E-05    0.10000E+01    0.30034E+03    0.10670E-04    0.70190E-08    0.21968E-11
+    3    1    0.37375E-05    0.10000E+01    0.24221E+03    0.18475E-04    0.16349E-07    0.35926E-11
+    3    1    0.37375E-05    0.10000E+01    0.19533E+03    0.28808E-04    0.31026E-07    0.53971E-11
+    3    1    0.37375E-05    0.10000E+01    0.15752E+03    0.28808E-04    0.31026E-07    0.53971E-11
+    3    1    0.65217E-05    0.10000E+01    0.80645E+05    0.17553E-51    0.13107E-62    0.16166E-57
+    3    1    0.65217E-05    0.10000E+01    0.65036E+05    0.14826E-50    0.20789E-61    0.13662E-56
+    3    1    0.65217E-05    0.10000E+01    0.52449E+05    0.12581E-49    0.27814E-60    0.11597E-55
+    3    1    0.65217E-05    0.10000E+01    0.42297E+05    0.94319E-49    0.37488E-59    0.87018E-55
+    3    1    0.65217E-05    0.10000E+01    0.34111E+05    0.67575E-48    0.50804E-58    0.62434E-54
+    3    1    0.65217E-05    0.10000E+01    0.27509E+05    0.47982E-47    0.67403E-57    0.44438E-53
+    3    1    0.65217E-05    0.10000E+01    0.22184E+05    0.33563E-46    0.86583E-56    0.31207E-52
+    3    1    0.65217E-05    0.10000E+01    0.17891E+05    0.22863E-45    0.10704E-54    0.21397E-51
+    3    1    0.65217E-05    0.10000E+01    0.14428E+05    0.15051E-44    0.12701E-53    0.14231E-50
+    3    1    0.65217E-05    0.10000E+01    0.11635E+05    0.95317E-44    0.14305E-52    0.91486E-50
+    3    1    0.65217E-05    0.10000E+01    0.93834E+04    0.57590E-43    0.15067E-51    0.56365E-49
+    3    1    0.65217E-05    0.10000E+01    0.75673E+04    0.32961E-42    0.16049E-50    0.32703E-48
+    3    1    0.65217E-05    0.10000E+01    0.61026E+04    0.18857E-41    0.23563E-49    0.18018E-47
+    3    1    0.65217E-05    0.10000E+01    0.49215E+04    0.13354E-40    0.52554E-48    0.10924E-46
+    3    1    0.65217E-05    0.10000E+01    0.39689E+04    0.13730E-39    0.13009E-46    0.94653E-46
+    3    1    0.65217E-05    0.10000E+01    0.32008E+04    0.53260E-37    0.98757E-44    0.34488E-43
+    3    1    0.65217E-05    0.10000E+01    0.25813E+04    0.33434E-28    0.13139E-34    0.20944E-34
+    3    1    0.65217E-05    0.10000E+01    0.20817E+04    0.49708E-12    0.72454E-18    0.28851E-18
+    3    1    0.65217E-05    0.10000E+01    0.16788E+04    0.13769E-06    0.81545E-12    0.72153E-13
+    3    1    0.65217E-05    0.10000E+01    0.13538E+04    0.25107E-06    0.29083E-11    0.11498E-12
+    3    1    0.65217E-05    0.10000E+01    0.10918E+04    0.46465E-06    0.10335E-10    0.18585E-12
+    3    1    0.65217E-05    0.10000E+01    0.88049E+03    0.86533E-06    0.36709E-10    0.30284E-12
+    3    1    0.65217E-05    0.10000E+01    0.71007E+03    0.16146E-05    0.13025E-09    0.49669E-12
+    3    1    0.65217E-05    0.10000E+01    0.57264E+03    0.30127E-05    0.45526E-09    0.82085E-12
+    3    1    0.65217E-05    0.10000E+01    0.46180E+03    0.56071E-05    0.15140E-08    0.13686E-11
+    3    1    0.65217E-05    0.10000E+01    0.37242E+03    0.10336E-04    0.45849E-08    0.22956E-11
+    3    1    0.65217E-05    0.10000E+01    0.30034E+03    0.18619E-04    0.12248E-07    0.38332E-11
+    3    1    0.65217E-05    0.10000E+01    0.24221E+03    0.32238E-04    0.28528E-07    0.62688E-11
+    3    1    0.65217E-05    0.10000E+01    0.19533E+03    0.50269E-04    0.54138E-07    0.94177E-11
+    3    1    0.65217E-05    0.10000E+01    0.15752E+03    0.50269E-04    0.54138E-07    0.94177E-11
+    3    1    0.11380E-04    0.10000E+01    0.80645E+05    0.30630E-51    0.22872E-62    0.28209E-57
+    3    1    0.11380E-04    0.10000E+01    0.65036E+05    0.25871E-50    0.36275E-61    0.23839E-56
+    3    1    0.11380E-04    0.10000E+01    0.52449E+05    0.21952E-49    0.48533E-60    0.20237E-55
+    3    1    0.11380E-04    0.10000E+01    0.42297E+05    0.16458E-48    0.65414E-59    0.15184E-54
+    3    1    0.11380E-04    0.10000E+01    0.34111E+05    0.11791E-47    0.88650E-58    0.10894E-53
+    3    1    0.11380E-04    0.10000E+01    0.27509E+05    0.83726E-47    0.11761E-56    0.77542E-53
+    3    1    0.11380E-04    0.10000E+01    0.22184E+05    0.58566E-46    0.15108E-55    0.54455E-52
+    3    1    0.11380E-04    0.10000E+01    0.17891E+05    0.39894E-45    0.18677E-54    0.37336E-51
+    3    1    0.11380E-04    0.10000E+01    0.14428E+05    0.26263E-44    0.22163E-53    0.24832E-50
+    3    1    0.11380E-04    0.10000E+01    0.11635E+05    0.16632E-43    0.24962E-52    0.15964E-49
+    3    1    0.11380E-04    0.10000E+01    0.93834E+04    0.10049E-42    0.26292E-51    0.98354E-49
+    3    1    0.11380E-04    0.10000E+01    0.75673E+04    0.57516E-42    0.28005E-50    0.57065E-48
+    3    1    0.11380E-04    0.10000E+01    0.61026E+04    0.32905E-41    0.41117E-49    0.31441E-47
+    3    1    0.11380E-04    0.10000E+01    0.49215E+04    0.23301E-40    0.91703E-48    0.19061E-46
+    3    1    0.11380E-04    0.10000E+01    0.39689E+04    0.23958E-39    0.22699E-46    0.16516E-45
+    3    1    0.11380E-04    0.10000E+01    0.32008E+04    0.92936E-37    0.17232E-43    0.60179E-43
+    3    1    0.11380E-04    0.10000E+01    0.25813E+04    0.58341E-28    0.22927E-34    0.36547E-34
+    3    1    0.11380E-04    0.10000E+01    0.20817E+04    0.86737E-12    0.12643E-17    0.50343E-18
+    3    1    0.11380E-04    0.10000E+01    0.16788E+04    0.24026E-06    0.14229E-11    0.12590E-12
+    3    1    0.11380E-04    0.10000E+01    0.13538E+04    0.43811E-06    0.50748E-11    0.20064E-12
+    3    1    0.11380E-04    0.10000E+01    0.10918E+04    0.81078E-06    0.18034E-10    0.32429E-12
+    3    1    0.11380E-04    0.10000E+01    0.88049E+03    0.15099E-05    0.64054E-10    0.52845E-12
+    3    1    0.11380E-04    0.10000E+01    0.71007E+03    0.28175E-05    0.22728E-09    0.86670E-12
+    3    1    0.11380E-04    0.10000E+01    0.57264E+03    0.52570E-05    0.79440E-09    0.14323E-11
+    3    1    0.11380E-04    0.10000E+01    0.46180E+03    0.97841E-05    0.26418E-08    0.23882E-11
+    3    1    0.11380E-04    0.10000E+01    0.37242E+03    0.18036E-04    0.80003E-08    0.40057E-11
+    3    1    0.11380E-04    0.10000E+01    0.30034E+03    0.32488E-04    0.21371E-07    0.66888E-11
+    3    1    0.11380E-04    0.10000E+01    0.24221E+03    0.56254E-04    0.49779E-07    0.10939E-10
+    3    1    0.11380E-04    0.10000E+01    0.19533E+03    0.87716E-04    0.94467E-07    0.16433E-10
+    3    1    0.11380E-04    0.10000E+01    0.15752E+03    0.87716E-04    0.94467E-07    0.16433E-10
+    3    1    0.19857E-04    0.10000E+01    0.80645E+05    0.53447E-51    0.39910E-62    0.49223E-57
+    3    1    0.19857E-04    0.10000E+01    0.65036E+05    0.45144E-50    0.63298E-61    0.41597E-56
+    3    1    0.19857E-04    0.10000E+01    0.52449E+05    0.38305E-49    0.84687E-60    0.35312E-55
+    3    1    0.19857E-04    0.10000E+01    0.42297E+05    0.28718E-48    0.11414E-58    0.26495E-54
+    3    1    0.19857E-04    0.10000E+01    0.34111E+05    0.20575E-47    0.15469E-57    0.19010E-53
+    3    1    0.19857E-04    0.10000E+01    0.27509E+05    0.14610E-46    0.20523E-56    0.13531E-52
+    3    1    0.19857E-04    0.10000E+01    0.22184E+05    0.10219E-45    0.26363E-55    0.95020E-52
+    3    1    0.19857E-04    0.10000E+01    0.17891E+05    0.69613E-45    0.32590E-54    0.65149E-51
+    3    1    0.19857E-04    0.10000E+01    0.14428E+05    0.45828E-44    0.38673E-53    0.43330E-50
+    3    1    0.19857E-04    0.10000E+01    0.11635E+05    0.29022E-43    0.43557E-52    0.27856E-49
+    3    1    0.19857E-04    0.10000E+01    0.93834E+04    0.17535E-42    0.45877E-51    0.17162E-48
+    3    1    0.19857E-04    0.10000E+01    0.75673E+04    0.10036E-41    0.48867E-50    0.99575E-48
+    3    1    0.19857E-04    0.10000E+01    0.61026E+04    0.57417E-41    0.71746E-49    0.54863E-47
+    3    1    0.19857E-04    0.10000E+01    0.49215E+04    0.40660E-40    0.16002E-47    0.33260E-46
+    3    1    0.19857E-04    0.10000E+01    0.39689E+04    0.41805E-39    0.39609E-46    0.28820E-45
+    3    1    0.19857E-04    0.10000E+01    0.32008E+04    0.16217E-36    0.30070E-43    0.10501E-42
+    3    1    0.19857E-04    0.10000E+01    0.25813E+04    0.10180E-27    0.40007E-34    0.63772E-34
+    3    1    0.19857E-04    0.10000E+01    0.20817E+04    0.15135E-11    0.22061E-17    0.87845E-18
+    3    1    0.19857E-04    0.10000E+01    0.16788E+04    0.41923E-06    0.24829E-11    0.21969E-12
+    3    1    0.19857E-04    0.10000E+01    0.13538E+04    0.76447E-06    0.88552E-11    0.35010E-12
+    3    1    0.19857E-04    0.10000E+01    0.10918E+04    0.14148E-05    0.31468E-10    0.56587E-12
+    3    1    0.19857E-04    0.10000E+01    0.88049E+03    0.26348E-05    0.11177E-09    0.92211E-12
+    3    1    0.19857E-04    0.10000E+01    0.71007E+03    0.49163E-05    0.39659E-09    0.15123E-11
+    3    1    0.19857E-04    0.10000E+01    0.57264E+03    0.91732E-05    0.13862E-08    0.24993E-11
+    3    1    0.19857E-04    0.10000E+01    0.46180E+03    0.17073E-04    0.46097E-08    0.41672E-11
+    3    1    0.19857E-04    0.10000E+01    0.37242E+03    0.31471E-04    0.13960E-07    0.69896E-11
+    3    1    0.19857E-04    0.10000E+01    0.30034E+03    0.56690E-04    0.37292E-07    0.11672E-10
+    3    1    0.19857E-04    0.10000E+01    0.24221E+03    0.98159E-04    0.86862E-07    0.19087E-10
+    3    1    0.19857E-04    0.10000E+01    0.19533E+03    0.15306E-03    0.16484E-06    0.28675E-10
+    3    1    0.19857E-04    0.10000E+01    0.15752E+03    0.15306E-03    0.16484E-06    0.28675E-10
+    3    1    0.34650E-04    0.10000E+01    0.80645E+05    0.93261E-51    0.69640E-62    0.85892E-57
+    3    1    0.34650E-04    0.10000E+01    0.65036E+05    0.78773E-50    0.11045E-60    0.72585E-56
+    3    1    0.34650E-04    0.10000E+01    0.52449E+05    0.66841E-49    0.14777E-59    0.61617E-55
+    3    1    0.34650E-04    0.10000E+01    0.42297E+05    0.50112E-48    0.19917E-58    0.46233E-54
+    3    1    0.34650E-04    0.10000E+01    0.34111E+05    0.35903E-47    0.26992E-57    0.33171E-53
+    3    1    0.34650E-04    0.10000E+01    0.27509E+05    0.25493E-46    0.35811E-56    0.23610E-52
+    3    1    0.34650E-04    0.10000E+01    0.22184E+05    0.17832E-45    0.46002E-55    0.16580E-51
+    3    1    0.34650E-04    0.10000E+01    0.17891E+05    0.12147E-44    0.56868E-54    0.11368E-50
+    3    1    0.34650E-04    0.10000E+01    0.14428E+05    0.79967E-44    0.67482E-53    0.75608E-50
+    3    1    0.34650E-04    0.10000E+01    0.11635E+05    0.50642E-43    0.76005E-52    0.48607E-49
+    3    1    0.34650E-04    0.10000E+01    0.93834E+04    0.30598E-42    0.80053E-51    0.29947E-48
+    3    1    0.34650E-04    0.10000E+01    0.75673E+04    0.17512E-41    0.85271E-50    0.17375E-47
+    3    1    0.34650E-04    0.10000E+01    0.61026E+04    0.10019E-40    0.12519E-48    0.95732E-47
+    3    1    0.34650E-04    0.10000E+01    0.49215E+04    0.70948E-40    0.27922E-47    0.58037E-46
+    3    1    0.34650E-04    0.10000E+01    0.39689E+04    0.72947E-39    0.69116E-46    0.50289E-45
+    3    1    0.34650E-04    0.10000E+01    0.32008E+04    0.28297E-36    0.52470E-43    0.18323E-42
+    3    1    0.34650E-04    0.10000E+01    0.25813E+04    0.17764E-27    0.69809E-34    0.11128E-33
+    3    1    0.34650E-04    0.10000E+01    0.20817E+04    0.26410E-11    0.38495E-17    0.15328E-17
+    3    1    0.34650E-04    0.10000E+01    0.16788E+04    0.73153E-06    0.43325E-11    0.38335E-12
+    3    1    0.34650E-04    0.10000E+01    0.13538E+04    0.13339E-05    0.15452E-10    0.61091E-12
+    3    1    0.34650E-04    0.10000E+01    0.10918E+04    0.24687E-05    0.54910E-10    0.98742E-12
+    3    1    0.34650E-04    0.10000E+01    0.88049E+03    0.45975E-05    0.19503E-09    0.16090E-11
+    3    1    0.34650E-04    0.10000E+01    0.71007E+03    0.85786E-05    0.69203E-09    0.26389E-11
+    3    1    0.34650E-04    0.10000E+01    0.57264E+03    0.16007E-04    0.24188E-08    0.43612E-11
+    3    1    0.34650E-04    0.10000E+01    0.46180E+03    0.29791E-04    0.80437E-08    0.72715E-11
+    3    1    0.34650E-04    0.10000E+01    0.37242E+03    0.54915E-04    0.24359E-07    0.12196E-10
+    3    1    0.34650E-04    0.10000E+01    0.30034E+03    0.98921E-04    0.65072E-07    0.20366E-10
+    3    1    0.34650E-04    0.10000E+01    0.24221E+03    0.17128E-03    0.15157E-06    0.33306E-10
+    3    1    0.34650E-04    0.10000E+01    0.19533E+03    0.26708E-03    0.28763E-06    0.50036E-10
+    3    1    0.34650E-04    0.10000E+01    0.15752E+03    0.26708E-03    0.28763E-06    0.50036E-10
+    3    1    0.60462E-04    0.10000E+01    0.80645E+05    0.16274E-50    0.12152E-61    0.14988E-56
+    3    1    0.60462E-04    0.10000E+01    0.65036E+05    0.13745E-49    0.19273E-60    0.12666E-55
+    3    1    0.60462E-04    0.10000E+01    0.52449E+05    0.11663E-48    0.25786E-59    0.10752E-54
+    3    1    0.60462E-04    0.10000E+01    0.42297E+05    0.87442E-48    0.34755E-58    0.80673E-54
+    3    1    0.60462E-04    0.10000E+01    0.34111E+05    0.62648E-47    0.47100E-57    0.57882E-53
+    3    1    0.60462E-04    0.10000E+01    0.27509E+05    0.44484E-46    0.62489E-56    0.41198E-52
+    3    1    0.60462E-04    0.10000E+01    0.22184E+05    0.31116E-45    0.80270E-55    0.28932E-51
+    3    1    0.60462E-04    0.10000E+01    0.17891E+05    0.21196E-44    0.99232E-54    0.19837E-50
+    3    1    0.60462E-04    0.10000E+01    0.14428E+05    0.13954E-43    0.11775E-52    0.13193E-49
+    3    1    0.60462E-04    0.10000E+01    0.11635E+05    0.88367E-43    0.13262E-51    0.84815E-49
+    3    1    0.60462E-04    0.10000E+01    0.93834E+04    0.53391E-42    0.13969E-50    0.52256E-48
+    3    1    0.60462E-04    0.10000E+01    0.75673E+04    0.30558E-41    0.14879E-49    0.30319E-47
+    3    1    0.60462E-04    0.10000E+01    0.61026E+04    0.17483E-40    0.21845E-48    0.16705E-46
+    3    1    0.60462E-04    0.10000E+01    0.49215E+04    0.12380E-39    0.48722E-47    0.10127E-45
+    3    1    0.60462E-04    0.10000E+01    0.39689E+04    0.12729E-38    0.12060E-45    0.87752E-45
+    3    1    0.60462E-04    0.10000E+01    0.32008E+04    0.49377E-36    0.91556E-43    0.31973E-42
+    3    1    0.60462E-04    0.10000E+01    0.25813E+04    0.30997E-27    0.12181E-33    0.19417E-33
+    3    1    0.60462E-04    0.10000E+01    0.20817E+04    0.46083E-11    0.67171E-17    0.26747E-17
+    3    1    0.60462E-04    0.10000E+01    0.16788E+04    0.12765E-05    0.75599E-11    0.66893E-12
+    3    1    0.60462E-04    0.10000E+01    0.13538E+04    0.23277E-05    0.26962E-10    0.10660E-11
+    3    1    0.60462E-04    0.10000E+01    0.10918E+04    0.43077E-05    0.95814E-10    0.17230E-11
+    3    1    0.60462E-04    0.10000E+01    0.88049E+03    0.80224E-05    0.34032E-09    0.28076E-11
+    3    1    0.60462E-04    0.10000E+01    0.71007E+03    0.14969E-04    0.12075E-08    0.46048E-11
+    3    1    0.60462E-04    0.10000E+01    0.57264E+03    0.27931E-04    0.42207E-08    0.76100E-11
+    3    1    0.60462E-04    0.10000E+01    0.46180E+03    0.51983E-04    0.14036E-07    0.12688E-10
+    3    1    0.60462E-04    0.10000E+01    0.37242E+03    0.95823E-04    0.42506E-07    0.21282E-10
+    3    1    0.60462E-04    0.10000E+01    0.30034E+03    0.17261E-03    0.11355E-06    0.35538E-10
+    3    1    0.60462E-04    0.10000E+01    0.24221E+03    0.29888E-03    0.26448E-06    0.58118E-10
+    3    1    0.60462E-04    0.10000E+01    0.19533E+03    0.46603E-03    0.50190E-06    0.87310E-10
+    3    1    0.60462E-04    0.10000E+01    0.15752E+03    0.46603E-03    0.50190E-06    0.87310E-10
+    3    1    0.10550E-03    0.10000E+01    0.80645E+05    0.28396E-50    0.21204E-61    0.26152E-56
+    3    1    0.10550E-03    0.10000E+01    0.65036E+05    0.23985E-49    0.33630E-60    0.22101E-55
+    3    1    0.10550E-03    0.10000E+01    0.52449E+05    0.20352E-48    0.44994E-59    0.18761E-54
+    3    1    0.10550E-03    0.10000E+01    0.42297E+05    0.15258E-47    0.60645E-58    0.14077E-53
+    3    1    0.10550E-03    0.10000E+01    0.34111E+05    0.10932E-46    0.82187E-57    0.10100E-52
+    3    1    0.10550E-03    0.10000E+01    0.27509E+05    0.77622E-46    0.10904E-55    0.71888E-52
+    3    1    0.10550E-03    0.10000E+01    0.22184E+05    0.54296E-45    0.14007E-54    0.50484E-51
+    3    1    0.10550E-03    0.10000E+01    0.17891E+05    0.36985E-44    0.17315E-53    0.34614E-50
+    3    1    0.10550E-03    0.10000E+01    0.14428E+05    0.24348E-43    0.20547E-52    0.23021E-49
+    3    1    0.10550E-03    0.10000E+01    0.11635E+05    0.15420E-42    0.23142E-51    0.14800E-48
+    3    1    0.10550E-03    0.10000E+01    0.93834E+04    0.93164E-42    0.24375E-50    0.91183E-48
+    3    1    0.10550E-03    0.10000E+01    0.75673E+04    0.53322E-41    0.25963E-49    0.52904E-47
+    3    1    0.10550E-03    0.10000E+01    0.61026E+04    0.30506E-40    0.38119E-48    0.29149E-46
+    3    1    0.10550E-03    0.10000E+01    0.49215E+04    0.21602E-39    0.85017E-47    0.17671E-45
+    3    1    0.10550E-03    0.10000E+01    0.39689E+04    0.22211E-38    0.21044E-45    0.15312E-44
+    3    1    0.10550E-03    0.10000E+01    0.32008E+04    0.86160E-36    0.15976E-42    0.55791E-42
+    3    1    0.10550E-03    0.10000E+01    0.25813E+04    0.54087E-27    0.21256E-33    0.33882E-33
+    3    1    0.10550E-03    0.10000E+01    0.20817E+04    0.80413E-11    0.11721E-16    0.46672E-17
+    3    1    0.10550E-03    0.10000E+01    0.16788E+04    0.22274E-05    0.13192E-10    0.11672E-11
+    3    1    0.10550E-03    0.10000E+01    0.13538E+04    0.40616E-05    0.47048E-10    0.18601E-11
+    3    1    0.10550E-03    0.10000E+01    0.10918E+04    0.75167E-05    0.16719E-09    0.30065E-11
+    3    1    0.10550E-03    0.10000E+01    0.88049E+03    0.13999E-04    0.59384E-09    0.48992E-11
+    3    1    0.10550E-03    0.10000E+01    0.71007E+03    0.26120E-04    0.21071E-08    0.80351E-11
+    3    1    0.10550E-03    0.10000E+01    0.57264E+03    0.48737E-04    0.73648E-08    0.13279E-10
+    3    1    0.10550E-03    0.10000E+01    0.46180E+03    0.90707E-04    0.24491E-07    0.22140E-10
+    3    1    0.10550E-03    0.10000E+01    0.37242E+03    0.16721E-03    0.74170E-07    0.37136E-10
+    3    1    0.10550E-03    0.10000E+01    0.30034E+03    0.30120E-03    0.19813E-06    0.62011E-10
+    3    1    0.10550E-03    0.10000E+01    0.24221E+03    0.52152E-03    0.46150E-06    0.10141E-09
+    3    1    0.10550E-03    0.10000E+01    0.19533E+03    0.81320E-03    0.87579E-06    0.15235E-09
+    3    1    0.10550E-03    0.10000E+01    0.15752E+03    0.81320E-03    0.87579E-06    0.15235E-09
+    3    1    0.18409E-03    0.10000E+01    0.80645E+05    0.49550E-50    0.37000E-61    0.45635E-56
+    3    1    0.18409E-03    0.10000E+01    0.65036E+05    0.41852E-49    0.58683E-60    0.38564E-55
+    3    1    0.18409E-03    0.10000E+01    0.52449E+05    0.35513E-48    0.78513E-59    0.32737E-54
+    3    1    0.18409E-03    0.10000E+01    0.42297E+05    0.26624E-47    0.10582E-57    0.24564E-53
+    3    1    0.18409E-03    0.10000E+01    0.34111E+05    0.19075E-46    0.14341E-56    0.17624E-52
+    3    1    0.18409E-03    0.10000E+01    0.27509E+05    0.13545E-45    0.19027E-55    0.12544E-51
+    3    1    0.18409E-03    0.10000E+01    0.22184E+05    0.94743E-45    0.24441E-54    0.88092E-51
+    3    1    0.18409E-03    0.10000E+01    0.17891E+05    0.64537E-44    0.30214E-53    0.60399E-50
+    3    1    0.18409E-03    0.10000E+01    0.14428E+05    0.42486E-43    0.35853E-52    0.40171E-49
+    3    1    0.18409E-03    0.10000E+01    0.11635E+05    0.26906E-42    0.40381E-51    0.25825E-48
+    3    1    0.18409E-03    0.10000E+01    0.93834E+04    0.16257E-41    0.42532E-50    0.15911E-47
+    3    1    0.18409E-03    0.10000E+01    0.75673E+04    0.93044E-41    0.45304E-49    0.92315E-47
+    3    1    0.18409E-03    0.10000E+01    0.61026E+04    0.53231E-40    0.66515E-48    0.50863E-46
+    3    1    0.18409E-03    0.10000E+01    0.49215E+04    0.37695E-39    0.14835E-46    0.30835E-45
+    3    1    0.18409E-03    0.10000E+01    0.39689E+04    0.38757E-38    0.36721E-45    0.26719E-44
+    3    1    0.18409E-03    0.10000E+01    0.32008E+04    0.15034E-35    0.27877E-42    0.97352E-42
+    3    1    0.18409E-03    0.10000E+01    0.25813E+04    0.94379E-27    0.37090E-33    0.59122E-33
+    3    1    0.18409E-03    0.10000E+01    0.20817E+04    0.14032E-10    0.20452E-16    0.81440E-17
+    3    1    0.18409E-03    0.10000E+01    0.16788E+04    0.38867E-05    0.23019E-10    0.20368E-11
+    3    1    0.18409E-03    0.10000E+01    0.13538E+04    0.70873E-05    0.82096E-10    0.32458E-11
+    3    1    0.18409E-03    0.10000E+01    0.10918E+04    0.13116E-04    0.29174E-09    0.52462E-11
+    3    1    0.18409E-03    0.10000E+01    0.88049E+03    0.24427E-04    0.10362E-08    0.85487E-11
+    3    1    0.18409E-03    0.10000E+01    0.71007E+03    0.45578E-04    0.36768E-08    0.14021E-10
+    3    1    0.18409E-03    0.10000E+01    0.57264E+03    0.85044E-04    0.12851E-07    0.23171E-10
+    3    1    0.18409E-03    0.10000E+01    0.46180E+03    0.15828E-03    0.42736E-07    0.38633E-10
+    3    1    0.18409E-03    0.10000E+01    0.37242E+03    0.29176E-03    0.12942E-06    0.64800E-10
+    3    1    0.18409E-03    0.10000E+01    0.30034E+03    0.52557E-03    0.34573E-06    0.10821E-09
+    3    1    0.18409E-03    0.10000E+01    0.24221E+03    0.91002E-03    0.80529E-06    0.17696E-09
+    3    1    0.18409E-03    0.10000E+01    0.19533E+03    0.14190E-02    0.15282E-05    0.26584E-09
+    3    1    0.18409E-03    0.10000E+01    0.15752E+03    0.14190E-02    0.15282E-05    0.26584E-09
+    3    1    0.32123E-03    0.10000E+01    0.80645E+05    0.86462E-50    0.64562E-61    0.79629E-56
+    3    1    0.32123E-03    0.10000E+01    0.65036E+05    0.73030E-49    0.10240E-59    0.67293E-55
+    3    1    0.32123E-03    0.10000E+01    0.52449E+05    0.61967E-48    0.13700E-58    0.57125E-54
+    3    1    0.32123E-03    0.10000E+01    0.42297E+05    0.46458E-47    0.18465E-57    0.42862E-53
+    3    1    0.32123E-03    0.10000E+01    0.34111E+05    0.33285E-46    0.25024E-56    0.30753E-52
+    3    1    0.32123E-03    0.10000E+01    0.27509E+05    0.23634E-45    0.33200E-55    0.21889E-51
+    3    1    0.32123E-03    0.10000E+01    0.22184E+05    0.16532E-44    0.42648E-54    0.15372E-50
+    3    1    0.32123E-03    0.10000E+01    0.17891E+05    0.11261E-43    0.52722E-53    0.10539E-49
+    3    1    0.32123E-03    0.10000E+01    0.14428E+05    0.74136E-43    0.62562E-52    0.70095E-49
+    3    1    0.32123E-03    0.10000E+01    0.11635E+05    0.46950E-42    0.70463E-51    0.45063E-48
+    3    1    0.32123E-03    0.10000E+01    0.93834E+04    0.28367E-41    0.74216E-50    0.27764E-47
+    3    1    0.32123E-03    0.10000E+01    0.75673E+04    0.16236E-40    0.79053E-49    0.16108E-46
+    3    1    0.32123E-03    0.10000E+01    0.61026E+04    0.92885E-40    0.11607E-47    0.88752E-46
+    3    1    0.32123E-03    0.10000E+01    0.49215E+04    0.65775E-39    0.25886E-46    0.53805E-45
+    3    1    0.32123E-03    0.10000E+01    0.39689E+04    0.67628E-38    0.64076E-45    0.46623E-44
+    3    1    0.32123E-03    0.10000E+01    0.32008E+04    0.26234E-35    0.48644E-42    0.16987E-41
+    3    1    0.32123E-03    0.10000E+01    0.25813E+04    0.16469E-26    0.64720E-33    0.10316E-32
+    3    1    0.32123E-03    0.10000E+01    0.20817E+04    0.24484E-10    0.35688E-16    0.14211E-16
+    3    1    0.32123E-03    0.10000E+01    0.16788E+04    0.67820E-05    0.40166E-10    0.35540E-11
+    3    1    0.32123E-03    0.10000E+01    0.13538E+04    0.12367E-04    0.14325E-09    0.56636E-11
+    3    1    0.32123E-03    0.10000E+01    0.10918E+04    0.22887E-04    0.50906E-09    0.91542E-11
+    3    1    0.32123E-03    0.10000E+01    0.88049E+03    0.42623E-04    0.18081E-08    0.14917E-10
+    3    1    0.32123E-03    0.10000E+01    0.71007E+03    0.79532E-04    0.64157E-08    0.24465E-10
+    3    1    0.32123E-03    0.10000E+01    0.57264E+03    0.14840E-03    0.22424E-07    0.40432E-10
+    3    1    0.32123E-03    0.10000E+01    0.46180E+03    0.27619E-03    0.74572E-07    0.67413E-10
+    3    1    0.32123E-03    0.10000E+01    0.37242E+03    0.50911E-03    0.22583E-06    0.11307E-09
+    3    1    0.32123E-03    0.10000E+01    0.30034E+03    0.91708E-03    0.60328E-06    0.18881E-09
+    3    1    0.32123E-03    0.10000E+01    0.24221E+03    0.15879E-02    0.14052E-05    0.30878E-09
+    3    1    0.32123E-03    0.10000E+01    0.19533E+03    0.24760E-02    0.26666E-05    0.46388E-09
+    3    1    0.32123E-03    0.10000E+01    0.15752E+03    0.24760E-02    0.26666E-05    0.46388E-09
+    3    2    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.30142E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    2    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.52597E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    2    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.91778E-08    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    2    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.16015E-07    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    3    2    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.27945E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    3    2    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.48762E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    3    2    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.85086E-07    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    3    2    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.14847E-06    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    3    2    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.25907E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    3    2    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.45206E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    3    2    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.78882E-06    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    3    2    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.13765E-05    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    3    2    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.24018E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    3    2    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.41910E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    3    2    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.73131E-05    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    3    2    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.12761E-04    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    3    2    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.22267E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    3    2    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.38855E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    3    2    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.67799E-04    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    3    2    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.11831E-03    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    3    2    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53959E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.20644E-03    0.19496E+06    0.99447E-26    0.48763E-10    0.50499E-04    0.88379E+03
+    3    2    0.54572E-10    0.10000E+01    0.74089E-01    0.13934E+00    0.11222E-09    0.65399E-11    0.40383E-04    0.29227E-04    0.98516E+04    0.36022E-03    0.15940E+06    0.27009E-25    0.58062E-09    0.60483E-04    0.85041E+03
+    3    2    0.95225E-10    0.10000E+01    0.11734E+00    0.19730E+00    0.21126E-09    0.51117E-10    0.44007E-04    0.38014E-04    0.17190E+05    0.62856E-03    0.12765E+06    0.72541E-25    0.44193E-08    0.73414E-04    0.78191E+03
+    3    2    0.16616E-09    0.10000E+01    0.18089E+00    0.26103E+00    0.32441E-09    0.26825E-09    0.44753E-04    0.48263E-04    0.29996E+05    0.10968E-02    0.99597E+05    0.20177E-24    0.22315E-07    0.91766E-04    0.67194E+03
+    3    2    0.28994E-09    0.10000E+01    0.25124E+00    0.31295E+00    0.45121E-09    0.97008E-09    0.45516E-04    0.52588E-04    0.52341E+05    0.19138E-02    0.76310E+05    0.62202E-24    0.76479E-07    0.11926E-03    0.53918E+03
+    3    2    0.50593E-09    0.10000E+01    0.30303E+00    0.34402E+00    0.74626E-09    0.25745E-08    0.54264E-04    0.48560E-04    0.91333E+05    0.33395E-02    0.59079E+05    0.20639E-23    0.18727E-06    0.15683E-03    0.42874E+03
+    3    2    0.88282E-09    0.10000E+01    0.33696E+00    0.38371E+00    0.15892E-08    0.56449E-08    0.73667E-04    0.45859E-04    0.15937E+06    0.58273E-02    0.46517E+05    0.64340E-23    0.36455E-06    0.20134E-03    0.35676E+03
+    3    2    0.15405E-08    0.10000E+01    0.37771E+00    0.45701E+00    0.37374E-08    0.11236E-07    0.99755E-04    0.47861E-04    0.27809E+06    0.10168E-01    0.36674E+05    0.18465E-22    0.61982E-06    0.25303E-03    0.30515E+03
+    3    2    0.26880E-08    0.10000E+01    0.34820E+00    0.81778E+00    0.15539E-07    0.24447E-07    0.89642E-04    0.66805E-04    0.11884E+06    0.10890E-01    0.52859E+04    0.18023E-21    0.78343E-06    0.56463E-03    0.17868E+03
+    3    2    0.46905E-08    0.10000E+01    0.42875E+00    0.94285E+00    0.27848E-07    0.45963E-07    0.11095E-03    0.73037E-04    0.20736E+06    0.19003E-01    0.39821E+04    0.53044E-21    0.12455E-05    0.74019E-03    0.13935E+03
+    3    2    0.81846E-08    0.10000E+01    0.52090E+00    0.10677E+01    0.48919E-07    0.85870E-07    0.13817E-03    0.78831E-04    0.36184E+06    0.33158E-01    0.29883E+04    0.15825E-20    0.19726E-05    0.97884E-03    0.10654E+03
+    3    2    0.14282E-07    0.10000E+01    0.62293E+00    0.11892E+01    0.84138E-07    0.15951E-06    0.17334E-03    0.83866E-04    0.63138E+06    0.57859E-01    0.22338E+04    0.47764E-20    0.31214E-05    0.13038E-02    0.80022E+02
+    3    2    0.24920E-07    0.10000E+01    0.73096E+00    0.13036E+01    0.14287E-06    0.29444E-06    0.22018E-03    0.87990E-04    0.11017E+07    0.10096E+00    0.16698E+04    0.14452E-19    0.49441E-05    0.17404E-02    0.59454E+02
+    3    2    0.43485E-07    0.10000E+01    0.84274E+00    0.14102E+01    0.23919E-06    0.54027E-06    0.28262E-03    0.91305E-04    0.19224E+07    0.17617E+00    0.12465E+04    0.43892E-19    0.78331E-05    0.23287E-02    0.43767E+02
+    3    2    0.75878E-07    0.10000E+01    0.95521E+00    0.15083E+01    0.39635E-06    0.98553E-06    0.36658E-03    0.93945E-04    0.33546E+07    0.30741E+00    0.93059E+03    0.13338E-18    0.12410E-04    0.31177E-02    0.32043E+02
+    3    2    0.13240E-06    0.10000E+01    0.10667E+01    0.15980E+01    0.64894E-06    0.17881E-05    0.47899E-03    0.96076E-04    0.58535E+07    0.53641E+00    0.69382E+03    0.40587E-18    0.19640E-04    0.41791E-02    0.23344E+02
+    3    2    0.23103E-06    0.10000E+01    0.11745E+01    0.16785E+01    0.10544E-05    0.32216E-05    0.63072E-03    0.97803E-04    0.10214E+08    0.93600E+00    0.51796E+03    0.12124E-17    0.31034E-04    0.55698E-02    0.17014E+02
+    3    2    0.40314E-06    0.10000E+01    0.11872E+01    0.16875E+01    0.29729E-05    0.56390E-05    0.10641E-02    0.97989E-04    0.17823E+08    0.16333E+01    0.50000E+03    0.22504E-17    0.53490E-04    0.57609E-02    0.16381E+02
+    3    2    0.70346E-06    0.10000E+01    0.11872E+01    0.16875E+01    0.90520E-05    0.98397E-05    0.18567E-02    0.97989E-04    0.31100E+08    0.28499E+01    0.50000E+03    0.39268E-17    0.93337E-04    0.57609E-02    0.16381E+02
+    3    2    0.12275E-05    0.10000E+01    0.11872E+01    0.16875E+01    0.27562E-04    0.17170E-04    0.32399E-02    0.97989E-04    0.54267E+08    0.49730E+01    0.50000E+03    0.68520E-17    0.16287E-03    0.57609E-02    0.16381E+02
+    3    2    0.21419E-05    0.10000E+01    0.11872E+01    0.16875E+01    0.83920E-04    0.29960E-04    0.56534E-02    0.97989E-04    0.94693E+08    0.86775E+01    0.50000E+03    0.11956E-16    0.28419E-03    0.57609E-02    0.16381E+02
+    3    2    0.37375E-05    0.10000E+01    0.11872E+01    0.16875E+01    0.25552E-03    0.52278E-04    0.98649E-02    0.97989E-04    0.16523E+09    0.15142E+02    0.50000E+03    0.20863E-16    0.49590E-03    0.57609E-02    0.16381E+02
+    3    2    0.65217E-05    0.10000E+01    0.11872E+01    0.16875E+01    0.77801E-03    0.91222E-04    0.17214E-01    0.97989E-04    0.28832E+09    0.26421E+02    0.50000E+03    0.36405E-16    0.86532E-03    0.57609E-02    0.16381E+02
+    3    2    0.11380E-04    0.10000E+01    0.11872E+01    0.16875E+01    0.23689E-02    0.15918E-03    0.30037E-01    0.97989E-04    0.50310E+09    0.46104E+02    0.50000E+03    0.63524E-16    0.15099E-02    0.57609E-02    0.16381E+02
+    3    2    0.19857E-04    0.10000E+01    0.11872E+01    0.16875E+01    0.72129E-02    0.27776E-03    0.52412E-01    0.97989E-04    0.87789E+09    0.80448E+02    0.50000E+03    0.11085E-15    0.26347E-02    0.57609E-02    0.16381E+02
+    3    2    0.34650E-04    0.10000E+01    0.11872E+01    0.16875E+01    0.21962E-01    0.48467E-03    0.91457E-01    0.97989E-04    0.15319E+10    0.14038E+03    0.50000E+03    0.19342E-15    0.45974E-02    0.57609E-02    0.16381E+02
+    3    2    0.60462E-04    0.10000E+01    0.11872E+01    0.16875E+01    0.66870E-01    0.84571E-03    0.15959E+00    0.97989E-04    0.26730E+10    0.24495E+03    0.50000E+03    0.33750E-15    0.80223E-02    0.57609E-02    0.16381E+02
+    3    2    0.10550E-03    0.10000E+01    0.11872E+01    0.16875E+01    0.20361E+00    0.14757E-02    0.27847E+00    0.97989E-04    0.46642E+10    0.42742E+03    0.50000E+03    0.58892E-15    0.13998E-01    0.57609E-02    0.16381E+02
+    3    2    0.18409E-03    0.10000E+01    0.11872E+01    0.16875E+01    0.61994E+00    0.25750E-02    0.48591E+00    0.97989E-04    0.81388E+10    0.74583E+03    0.50000E+03    0.10276E-14    0.24426E-01    0.57609E-02    0.16381E+02
+    3    2    0.32123E-03    0.10000E+01    0.11872E+01    0.16875E+01    0.18876E+01    0.44933E-02    0.84788E+00    0.97989E-04    0.14202E+11    0.13014E+04    0.50000E+03    0.17932E-14    0.42622E-01    0.57609E-02    0.16381E+02
+    3    2    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    3    2    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    3    2    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    3    2    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    3    2    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    3    2    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    3    2    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    3    2    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    3    2    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    3    2    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    3    2    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    3    2    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    3    2    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    3    2    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    3    2    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    3    2    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    3    2    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    3    2    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    3    2    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    3    2    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    3    2    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    3    2    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    3    2    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    3    2    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    3    2    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    3    2    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    3    2    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    3    2    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    3    2    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    3    2    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    3    2    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    3    2    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    3    2    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    3    2    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    3    2    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    3    2    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    3    2    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    3    2    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    3    2    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    3    2    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    3    2    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    3    2    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    3    2    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    3    2    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    3    2    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    3    2    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    3    2    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    3    2    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    3    2    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    3    2    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    3    2    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    3    2    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    3    2    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    3    2    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    3    2    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    3    2    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    3    2    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    3    2    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    3    2    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    3    2    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    3    2    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    3    2    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    3    2    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    3    2    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    3    2    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    3    2    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    3    2    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    3    2    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    3    2    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    3    2    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    3    2    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    3    2    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    3    2    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    3    2    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    3    2    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    3    2    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    3    2    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    3    2    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    3    2    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    3    2    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    3    2    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    3    2    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    3    2    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    3    2    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    3    2    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    3    2    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    3    2    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    3    2    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    3    2    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    3    2    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    3    2    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    3    2    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    3    2    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    3    2    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    3    2    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    3    2    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    3    2    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    3    2    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    3    2    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    3    2    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    3    2    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    3    2    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    3    2    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    3    2    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    3    2    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    3    2    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    3    2    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    3    2    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    3    2    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    3    2    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    3    2    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    3    2    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    3    2    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    3    2    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    3    2    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    3    2    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    3    2    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    3    2    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    3    2    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    3    2    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    3    2    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    3    2    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    3    2    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    3    2    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    3    2    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    3    2    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    3    2    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    3    2    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    3    2    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    3    2    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    3    2    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    3    2    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    3    2    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    3    2    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    3    2    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    3    2    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    3    2    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    3    2    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    3    2    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    3    2    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    3    2    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    3    2    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    3    2    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    3    2    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    3    2    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    3    2    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    3    2    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    3    2    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    3    2    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    3    2    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    3    2    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    3    2    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    3    2    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    3    2    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    3    2    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    3    2    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    3    2    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    3    2    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    3    2    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    3    2    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    3    2    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    3    2    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    3    2    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    3    2    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    3    2    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    3    2    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    3    2    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    3    2    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    3    2    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    3    2    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    3    2    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    3    2    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    3    2    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    3    2    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    3    2    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    3    2    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    3    2    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    3    2    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    3    2    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    3    2    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    3    2    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    3    2    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    3    2    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    3    2    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    3    2    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    3    2    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    3    2    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    3    2    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    3    2    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    3    2    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    3    2    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    3    2    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    3    2    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    3    2    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    3    2    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    3    2    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    3    2    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    3    2    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    3    2    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    3    2    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    3    2    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    3    2    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    3    2    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    3    2    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    3    2    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    3    2    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    3    2    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    3    2    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    3    2    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    3    2    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    3    2    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    3    2    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    3    2    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    3    2    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    3    2    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    3    2    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    3    2    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    3    2    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    3    2    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    3    2    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    3    2    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    3    2    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    3    2    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    3    2    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    3    2    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    3    2    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    3    2    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    3    2    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    3    2    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    3    2    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    3    2    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    3    2    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    3    2    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    3    2    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    3    2    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    3    2    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    3    2    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    3    2    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    3    2    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    3    2    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    3    2    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    3    2    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    3    2    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    3    2    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    3    2    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    3    2    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    3    2    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    3    2    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    3    2    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    3    2    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    3    2    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    3    2    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    3    2    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    3    2    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    3    2    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    3    2    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    3    2    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    3    2    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    3    2    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    3    2    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    3    2    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    3    2    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    3    2    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    3    2    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    3    2    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    3    2    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    3    2    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    3    2    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    3    2    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    3    2    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    3    2    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    3    2    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    3    2    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    3    2    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    3    2    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    3    2    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    3    2    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    3    2    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    3    2    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    3    2    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    3    2    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    3    2    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    3    2    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    3    2    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    3    2    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    3    2    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    3    2    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    3    2    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    3    2    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    3    2    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    3    2    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    3    2    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    3    2    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    3    2    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    3    2    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    3    2    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    3    2    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    3    2    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    3    2    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    3    2    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    3    2    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    3    2    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    3    2    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    3    2    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    3    2    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    3    2    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    3    2    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    3    2    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    3    2    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    3    2    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    3    2    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    3    2    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    3    2    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    3    2    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    3    2    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    3    2    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    3    2    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    3    2    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    3    2    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    3    2    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    3    2    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    3    2    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    3    2    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    3    2    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    3    2    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    3    2    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    3    2    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    3    2    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    3    2    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    3    2    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    3    2    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    3    2    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    3    2    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    3    2    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    3    2    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    3    2    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    3    2    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    3    2    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    3    2    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    3    2    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    3    2    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    3    2    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    3    2    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    3    2    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    3    2    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    3    2    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    3    2    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    3    2    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    3    2    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    3    2    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    3    2    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    3    2    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    3    2    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    3    2    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    3    2    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    3    2    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    3    2    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    3    2    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    3    2    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    3    2    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    3    2    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    3    2    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    3    2    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    3    2    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    3    2    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    3    2    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    3    2    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    3    2    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    3    2    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    3    2    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    3    2    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    3    2    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    3    2    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    3    2    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    3    2    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    3    2    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    3    2    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    3    2    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    3    2    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    3    2    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    3    2    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    3    2    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    3    2    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    3    2    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    3    2    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    3    2    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    3    2    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    3    2    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    3    2    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    3    2    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    3    2    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    3    2    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    3    2    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    3    2    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    3    2    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    3    2    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    3    2    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    3    2    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    3    2    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    3    2    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    3    2    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    3    2    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    3    2    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    3    2    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    3    2    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    3    2    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    3    2    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    3    2    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    3    2    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    3    2    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    3    2    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    3    2    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    3    2    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    3    2    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    3    2    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    3    2    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    3    2    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    3    2    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    3    2    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    3    2    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    3    2    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    3    2    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    3    2    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    3    2    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    3    2    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    3    2    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    3    2    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    3    2    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    3    2    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    3    2    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    3    2    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    3    2    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    3    2    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    3    2    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    3    2    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    3    2    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    3    2    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    3    2    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    3    2    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    3    2    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    3    2    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    3    2    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    3    2    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    3    2    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    3    2    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    3    2    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    3    2    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    3    2    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    3    2    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    3    2    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    3    2    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    3    2    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    3    2    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    3    2    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    3    2    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    3    2    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    3    2    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    3    2    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    3    2    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    3    2    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    3    2    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    3    2    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    3    2    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    3    2    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    3    2    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    3    2    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    3    2    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    3    2    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    3    2    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    3    2    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    3    2    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    3    2    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    3    2    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    3    2    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    3    2    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    3    2    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    3    2    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    3    2    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    3    2    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    3    2    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    3    2    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    3    2    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    3    2    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    3    2    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    3    2    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    3    2    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    3    2    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    3    2    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    3    2    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    3    2    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    3    2    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    3    2    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    3    2    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    3    2    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    3    2    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    3    2    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    3    2    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    3    2    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    3    2    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    3    2    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    3    2    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    3    2    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    3    2    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    3    2    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    3    2    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    3    2    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    3    2    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    3    2    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    3    2    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    3    2    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    3    2    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    3    2    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    3    2    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    3    2    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    3    2    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    3    2    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    3    2    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    3    2    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    3    2    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    3    2    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    3    2    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    3    2    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    3    2    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    3    2    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    3    2    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    3    2    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    3    2    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    3    2    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    3    2    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    3    2    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    3    2    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    3    2    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    3    2    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    3    2    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    3    2    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    3    2    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    3    2    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    3    2    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    3    2    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    3    2    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    3    2    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    3    2    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    3    2    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    3    2    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    3    2    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    3    2    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    3    2    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    3    2    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    3    2    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    3    2    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    3    2    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    3    2    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    3    2    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    3    2    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    3    2    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    3    2    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    3    2    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    3    2    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    3    2    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    3    2    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    3    2    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    3    2    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    3    2    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    3    2    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    3    2    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    3    2    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    3    2    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    3    2    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    3    2    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    3    2    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    3    2    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    3    2    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    3    2    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    3    2    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    3    2    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    3    2    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    3    2    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    3    2    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    3    2    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    3    2    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    3    2    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    3    2    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    3    2    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    3    2    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    3    2    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    3    2    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    3    2    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    3    2    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    3    2    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    3    2    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    3    2    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    3    2    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    3    2    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    3    2    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    3    2    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    3    2    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    3    2    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    3    2    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    3    2    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    3    2    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    3    2    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    3    2    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    3    2    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    3    2    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    3    2    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    3    2    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75390E-63
+    3    2    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    3    2    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    3    2    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    3    2    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    3    2    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    3    2    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    3    2    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    3    2    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    3    2    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    3    2    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    3    2    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    3    2    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    3    2    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    3    2    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    3    2    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    3    2    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    3    2    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    3    2    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    3    2    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    3    2    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    3    2    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    3    2    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    3    2    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    3    2    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    3    2    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35529E-67
+    3    2    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31053E-66
+    3    2    0.54572E-10    0.10000E+01    0.52449E+05    0.19287E-55    0.49297E-66    0.26761E-65
+    3    2    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20666E-64
+    3    2    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    3    2    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15326E-62
+    3    2    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19331E-61
+    3    2    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30487E-60
+    3    2    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49481E-59
+    3    2    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76351E-58
+    3    2    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    3    2    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16342E-55
+    3    2    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    3    2    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33514E-53
+    3    2    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47755E-52
+    3    2    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86006E-46    0.21355E-49
+    3    2    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    3    2    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    3    2    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    3    2    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    3    2    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    3    2    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    3    2    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    3    2    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    3    2    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    3    2    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    3    2    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    3    2    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    3    2    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73115E-16
+    3    2    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73115E-16
+    3    2    0.95225E-10    0.10000E+01    0.80645E+05    0.53353E-57    0.41258E-68    0.10776E-66
+    3    2    0.95225E-10    0.10000E+01    0.65036E+05    0.46330E-56    0.66249E-67    0.94330E-66
+    3    2    0.95225E-10    0.10000E+01    0.52449E+05    0.40029E-55    0.93498E-66    0.81548E-65
+    3    2    0.95225E-10    0.10000E+01    0.42297E+05    0.31520E-54    0.15117E-64    0.62539E-64
+    3    2    0.95225E-10    0.10000E+01    0.34111E+05    0.26473E-53    0.31091E-63    0.46450E-63
+    3    2    0.95225E-10    0.10000E+01    0.27509E+05    0.27522E-52    0.84249E-62    0.36147E-62
+    3    2    0.95225E-10    0.10000E+01    0.22184E+05    0.37540E-51    0.26561E-60    0.34974E-61
+    3    2    0.95225E-10    0.10000E+01    0.17891E+05    0.59958E-50    0.82083E-59    0.47879E-60
+    3    2    0.95225E-10    0.10000E+01    0.14428E+05    0.96033E-49    0.23748E-57    0.76775E-59
+    3    2    0.95225E-10    0.10000E+01    0.11635E+05    0.14621E-47    0.65940E-56    0.12118E-57
+    3    2    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18317E-56
+    3    2    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49010E-53    0.26962E-55
+    3    2    0.95225E-10    0.10000E+01    0.61026E+04    0.43942E-44    0.13294E-51    0.39171E-54
+    3    2    0.95225E-10    0.10000E+01    0.49215E+04    0.62536E-43    0.35995E-50    0.56497E-53
+    3    2    0.95225E-10    0.10000E+01    0.39689E+04    0.88818E-42    0.97295E-49    0.81085E-52
+    3    2    0.95225E-10    0.10000E+01    0.32008E+04    0.39611E-39    0.84947E-46    0.36468E-49
+    3    2    0.95225E-10    0.10000E+01    0.25813E+04    0.29209E-30    0.14352E-36    0.27089E-40
+    3    2    0.95225E-10    0.10000E+01    0.20817E+04    0.55934E-14    0.12255E-19    0.52261E-24
+    3    2    0.95225E-10    0.10000E+01    0.16788E+04    0.18979E-08    0.18142E-13    0.17814E-18
+    3    2    0.95225E-10    0.10000E+01    0.13538E+04    0.40803E-08    0.68935E-13    0.38359E-18
+    3    2    0.95225E-10    0.10000E+01    0.10918E+04    0.85756E-08    0.25709E-12    0.80712E-18
+    3    2    0.95225E-10    0.10000E+01    0.88049E+03    0.17634E-07    0.94663E-12    0.16611E-17
+    3    2    0.95225E-10    0.10000E+01    0.71007E+03    0.35557E-07    0.34473E-11    0.33512E-17
+    3    2    0.95225E-10    0.10000E+01    0.57264E+03    0.70485E-07    0.12265E-10    0.66456E-17
+    3    2    0.95225E-10    0.10000E+01    0.46180E+03    0.13744E-06    0.41252E-10    0.12962E-16
+    3    2    0.95225E-10    0.10000E+01    0.37242E+03    0.26235E-06    0.12579E-09    0.24745E-16
+    3    2    0.95225E-10    0.10000E+01    0.30034E+03    0.48459E-06    0.33738E-09    0.45711E-16
+    3    2    0.95225E-10    0.10000E+01    0.24221E+03    0.85378E-06    0.78775E-09    0.80541E-16
+    3    2    0.95225E-10    0.10000E+01    0.19533E+03    0.13456E-05    0.14970E-08    0.12694E-15
+    3    2    0.95225E-10    0.10000E+01    0.15752E+03    0.13456E-05    0.14970E-08    0.12694E-15
+    3    2    0.16616E-09    0.10000E+01    0.80645E+05    0.10866E-56    0.84282E-68    0.34549E-66
+    3    2    0.16616E-09    0.10000E+01    0.65036E+05    0.94572E-56    0.13518E-66    0.29872E-65
+    3    2    0.16616E-09    0.10000E+01    0.52449E+05    0.81563E-55    0.18581E-65    0.25665E-64
+    3    2    0.16616E-09    0.10000E+01    0.42297E+05    0.62614E-54    0.26486E-64    0.19474E-63
+    3    2    0.16616E-09    0.10000E+01    0.34111E+05    0.47161E-53    0.41219E-63    0.14020E-62
+    3    2    0.16616E-09    0.10000E+01    0.27509E+05    0.38208E-52    0.82516E-62    0.99364E-62
+    3    2    0.16616E-09    0.10000E+01    0.22184E+05    0.38870E-51    0.23184E-60    0.77112E-61
+    3    2    0.16616E-09    0.10000E+01    0.17891E+05    0.53844E-50    0.72254E-59    0.83650E-60
+    3    2    0.16616E-09    0.10000E+01    0.14428E+05    0.85077E-49    0.21509E-57    0.12394E-58
+    3    2    0.16616E-09    0.10000E+01    0.11635E+05    0.13233E-47    0.61094E-56    0.19605E-57
+    3    2    0.16616E-09    0.10000E+01    0.93834E+04    0.19801E-46    0.16973E-54    0.30103E-56
+    3    2    0.16616E-09    0.10000E+01    0.75673E+04    0.28945E-45    0.46714E-53    0.44893E-55
+    3    2    0.16616E-09    0.10000E+01    0.61026E+04    0.41839E-44    0.12790E-51    0.65839E-54
+    3    2    0.16616E-09    0.10000E+01    0.49215E+04    0.60116E-43    0.34885E-50    0.95633E-53
+    3    2    0.16616E-09    0.10000E+01    0.39689E+04    0.86026E-42    0.94850E-49    0.13801E-51
+    3    2    0.16616E-09    0.10000E+01    0.32008E+04    0.38601E-39    0.83225E-46    0.62354E-49
+    3    2    0.16616E-09    0.10000E+01    0.25813E+04    0.28617E-30    0.14130E-36    0.46507E-40
+    3    2    0.16616E-09    0.10000E+01    0.20817E+04    0.55101E-14    0.12128E-19    0.90110E-24
+    3    2    0.16616E-09    0.10000E+01    0.16788E+04    0.18760E-08    0.17990E-13    0.30798E-18
+    3    2    0.16616E-09    0.10000E+01    0.13538E+04    0.40379E-08    0.68377E-13    0.66377E-18
+    3    2    0.16616E-09    0.10000E+01    0.10918E+04    0.84936E-08    0.25505E-12    0.13976E-17
+    3    2    0.16616E-09    0.10000E+01    0.88049E+03    0.17476E-07    0.93919E-12    0.28776E-17
+    3    2    0.16616E-09    0.10000E+01    0.71007E+03    0.35254E-07    0.34203E-11    0.58074E-17
+    3    2    0.16616E-09    0.10000E+01    0.57264E+03    0.69902E-07    0.12169E-10    0.11519E-16
+    3    2    0.16616E-09    0.10000E+01    0.46180E+03    0.13633E-06    0.40930E-10    0.22469E-16
+    3    2    0.16616E-09    0.10000E+01    0.37242E+03    0.26025E-06    0.12480E-09    0.42900E-16
+    3    2    0.16616E-09    0.10000E+01    0.30034E+03    0.48075E-06    0.33474E-09    0.79252E-16
+    3    2    0.16616E-09    0.10000E+01    0.24221E+03    0.84706E-06    0.78159E-09    0.13964E-15
+    3    2    0.16616E-09    0.10000E+01    0.19533E+03    0.13350E-05    0.14853E-08    0.22009E-15
+    3    2    0.16616E-09    0.10000E+01    0.15752E+03    0.13350E-05    0.14853E-08    0.22009E-15
+    3    2    0.28994E-09    0.10000E+01    0.80645E+05    0.22418E-56    0.17110E-67    0.12880E-65
+    3    2    0.28994E-09    0.10000E+01    0.65036E+05    0.19263E-55    0.27287E-66    0.10912E-64
+    3    2    0.28994E-09    0.10000E+01    0.52449E+05    0.16481E-54    0.36810E-65    0.92487E-64
+    3    2    0.28994E-09    0.10000E+01    0.42297E+05    0.12442E-53    0.49615E-64    0.68771E-63
+    3    2    0.28994E-09    0.10000E+01    0.34111E+05    0.89267E-53    0.66647E-63    0.47992E-62
+    3    2    0.28994E-09    0.10000E+01    0.27509E+05    0.63532E-52    0.99632E-62    0.32244E-61
+    3    2    0.28994E-09    0.10000E+01    0.22184E+05    0.49830E-51    0.22041E-60    0.21932E-60
+    3    2    0.28994E-09    0.10000E+01    0.17891E+05    0.53898E-50    0.65499E-59    0.18857E-59
+    3    2    0.28994E-09    0.10000E+01    0.14428E+05    0.78448E-49    0.19822E-57    0.23786E-58
+    3    2    0.28994E-09    0.10000E+01    0.11635E+05    0.12218E-47    0.57347E-56    0.35664E-57
+    3    2    0.28994E-09    0.10000E+01    0.93834E+04    0.18565E-46    0.16136E-54    0.53789E-56
+    3    2    0.28994E-09    0.10000E+01    0.75673E+04    0.27486E-45    0.44807E-53    0.79370E-55
+    3    2    0.28994E-09    0.10000E+01    0.61026E+04    0.40100E-44    0.12352E-51    0.11548E-53
+    3    2    0.28994E-09    0.10000E+01    0.49215E+04    0.58025E-43    0.33876E-50    0.16679E-52
+    3    2    0.28994E-09    0.10000E+01    0.39689E+04    0.83504E-42    0.92533E-49    0.23984E-51
+    3    2    0.28994E-09    0.10000E+01    0.32008E+04    0.37648E-39    0.81522E-46    0.10815E-48
+    3    2    0.28994E-09    0.10000E+01    0.25813E+04    0.28033E-30    0.13899E-36    0.80606E-40
+    3    2    0.28994E-09    0.10000E+01    0.20817E+04    0.54233E-14    0.11983E-19    0.15621E-23
+    3    2    0.28994E-09    0.10000E+01    0.16788E+04    0.18519E-08    0.17807E-13    0.53409E-18
+    3    2    0.28994E-09    0.10000E+01    0.13538E+04    0.39900E-08    0.67701E-13    0.11512E-17
+    3    2    0.28994E-09    0.10000E+01    0.10918E+04    0.83990E-08    0.25256E-12    0.24239E-17
+    3    2    0.28994E-09    0.10000E+01    0.88049E+03    0.17291E-07    0.93009E-12    0.49911E-17
+    3    2    0.28994E-09    0.10000E+01    0.71007E+03    0.34892E-07    0.33872E-11    0.10073E-16
+    3    2    0.28994E-09    0.10000E+01    0.57264E+03    0.69201E-07    0.12051E-10    0.19980E-16
+    3    2    0.28994E-09    0.10000E+01    0.46180E+03    0.13498E-06    0.40534E-10    0.38975E-16
+    3    2    0.28994E-09    0.10000E+01    0.37242E+03    0.25770E-06    0.12359E-09    0.74411E-16
+    3    2    0.28994E-09    0.10000E+01    0.30034E+03    0.47607E-06    0.33150E-09    0.13746E-15
+    3    2    0.28994E-09    0.10000E+01    0.24221E+03    0.83882E-06    0.77403E-09    0.24221E-15
+    3    2    0.28994E-09    0.10000E+01    0.19533E+03    0.13221E-05    0.14709E-08    0.38174E-15
+    3    2    0.28994E-09    0.10000E+01    0.15752E+03    0.13221E-05    0.14709E-08    0.38174E-15
+    3    2    0.50593E-09    0.10000E+01    0.80645E+05    0.46557E-56    0.34819E-67    0.50776E-65
+    3    2    0.50593E-09    0.10000E+01    0.65036E+05    0.39361E-55    0.55035E-66    0.42513E-64
+    3    2    0.50593E-09    0.10000E+01    0.52449E+05    0.33308E-54    0.72712E-65    0.35732E-63
+    3    2    0.50593E-09    0.10000E+01    0.42297E+05    0.24713E-53    0.94680E-64    0.26248E-62
+    3    2    0.50593E-09    0.10000E+01    0.34111E+05    0.17210E-52    0.11947E-62    0.18016E-61
+    3    2    0.50593E-09    0.10000E+01    0.27509E+05    0.11570E-51    0.15255E-61    0.11844E-60
+    3    2    0.50593E-09    0.10000E+01    0.22184E+05    0.79114E-51    0.26457E-60    0.75982E-60
+    3    2    0.50593E-09    0.10000E+01    0.17891E+05    0.68251E-50    0.69442E-59    0.55163E-59
+    3    2    0.50593E-09    0.10000E+01    0.14428E+05    0.85381E-49    0.20409E-57    0.56310E-58
+    3    2    0.50593E-09    0.10000E+01    0.11635E+05    0.12663E-47    0.58446E-56    0.74972E-57
+    3    2    0.50593E-09    0.10000E+01    0.93834E+04    0.18945E-46    0.16308E-54    0.10687E-55
+    3    2    0.50593E-09    0.10000E+01    0.75673E+04    0.27796E-45    0.44972E-53    0.15211E-54
+    3    2    0.50593E-09    0.10000E+01    0.61026E+04    0.40272E-44    0.12336E-51    0.21520E-53
+    3    2    0.50593E-09    0.10000E+01    0.49215E+04    0.57984E-43    0.33733E-50    0.30417E-52
+    3    2    0.50593E-09    0.10000E+01    0.39689E+04    0.83184E-42    0.92003E-49    0.43050E-51
+    3    2    0.50593E-09    0.10000E+01    0.32008E+04    0.37442E-39    0.81014E-46    0.19196E-48
+    3    2    0.50593E-09    0.10000E+01    0.25813E+04    0.27866E-30    0.13816E-36    0.14195E-39
+    3    2    0.50593E-09    0.10000E+01    0.20817E+04    0.53933E-14    0.11921E-19    0.27349E-23
+    3    2    0.50593E-09    0.10000E+01    0.16788E+04    0.18425E-08    0.17723E-13    0.93210E-18
+    3    2    0.50593E-09    0.10000E+01    0.13538E+04    0.39701E-08    0.67384E-13    0.20066E-17
+    3    2    0.50593E-09    0.10000E+01    0.10918E+04    0.83579E-08    0.25138E-12    0.42217E-17
+    3    2    0.50593E-09    0.10000E+01    0.88049E+03    0.17208E-07    0.92571E-12    0.86879E-17
+    3    2    0.50593E-09    0.10000E+01    0.71007E+03    0.34725E-07    0.33711E-11    0.17527E-16
+    3    2    0.50593E-09    0.10000E+01    0.57264E+03    0.68873E-07    0.11994E-10    0.34754E-16
+    3    2    0.50593E-09    0.10000E+01    0.46180E+03    0.13434E-06    0.40339E-10    0.67779E-16
+    3    2    0.50593E-09    0.10000E+01    0.37242E+03    0.25648E-06    0.12300E-09    0.12938E-15
+    3    2    0.50593E-09    0.10000E+01    0.30034E+03    0.47380E-06    0.32990E-09    0.23899E-15
+    3    2    0.50593E-09    0.10000E+01    0.24221E+03    0.83482E-06    0.77029E-09    0.42106E-15
+    3    2    0.50593E-09    0.10000E+01    0.19533E+03    0.13157E-05    0.14638E-08    0.66360E-15
+    3    2    0.50593E-09    0.10000E+01    0.15752E+03    0.13157E-05    0.14638E-08    0.66360E-15
+    3    2    0.88282E-09    0.10000E+01    0.80645E+05    0.93908E-56    0.69472E-67    0.17643E-64
+    3    2    0.88282E-09    0.10000E+01    0.65036E+05    0.78710E-55    0.10928E-65    0.14753E-63
+    3    2    0.88282E-09    0.10000E+01    0.52449E+05    0.66213E-54    0.14287E-64    0.12396E-62
+    3    2    0.88282E-09    0.10000E+01    0.42297E+05    0.48711E-53    0.18352E-63    0.91139E-62
+    3    2    0.88282E-09    0.10000E+01    0.34111E+05    0.33526E-52    0.22766E-62    0.62827E-61
+    3    2    0.88282E-09    0.10000E+01    0.27509E+05    0.22149E-51    0.27340E-61    0.41685E-60
+    3    2    0.88282E-09    0.10000E+01    0.22184E+05    0.14337E-50    0.39233E-60    0.26554E-59
+    3    2    0.88282E-09    0.10000E+01    0.17891E+05    0.10539E-49    0.84949E-59    0.17364E-58
+    3    2    0.88282E-09    0.10000E+01    0.14428E+05    0.10846E-48    0.23007E-57    0.14079E-57
+    3    2    0.88282E-09    0.10000E+01    0.11635E+05    0.14486E-47    0.63660E-56    0.15665E-56
+    3    2    0.88282E-09    0.10000E+01    0.93834E+04    0.20727E-46    0.17353E-54    0.20760E-55
+    3    2    0.88282E-09    0.10000E+01    0.75673E+04    0.29636E-45    0.46947E-53    0.28704E-54
+    3    2    0.88282E-09    0.10000E+01    0.61026E+04    0.42107E-44    0.12687E-51    0.39841E-53
+    3    2    0.88282E-09    0.10000E+01    0.49215E+04    0.59713E-43    0.34315E-50    0.55381E-52
+    3    2    0.88282E-09    0.10000E+01    0.39689E+04    0.84713E-42    0.92894E-49    0.77290E-51
+    3    2    0.88282E-09    0.10000E+01    0.32008E+04    0.37833E-39    0.81387E-46    0.34089E-48
+    3    2    0.88282E-09    0.10000E+01    0.25813E+04    0.28006E-30    0.13829E-36    0.25005E-39
+    3    2    0.88282E-09    0.10000E+01    0.20817E+04    0.53996E-14    0.11899E-19    0.47870E-23
+    3    2    0.88282E-09    0.10000E+01    0.16788E+04    0.18409E-08    0.17673E-13    0.16260E-17
+    3    2    0.88282E-09    0.10000E+01    0.13538E+04    0.39636E-08    0.67181E-13    0.34956E-17
+    3    2    0.88282E-09    0.10000E+01    0.10918E+04    0.83399E-08    0.25059E-12    0.73476E-17
+    3    2    0.88282E-09    0.10000E+01    0.88049E+03    0.17164E-07    0.92268E-12    0.15111E-16
+    3    2    0.88282E-09    0.10000E+01    0.71007E+03    0.34629E-07    0.33598E-11    0.30471E-16
+    3    2    0.88282E-09    0.10000E+01    0.57264E+03    0.68667E-07    0.11953E-10    0.60400E-16
+    3    2    0.88282E-09    0.10000E+01    0.46180E+03    0.13392E-06    0.40199E-10    0.11776E-15
+    3    2    0.88282E-09    0.10000E+01    0.37242E+03    0.25565E-06    0.12257E-09    0.22475E-15
+    3    2    0.88282E-09    0.10000E+01    0.30034E+03    0.47222E-06    0.32874E-09    0.41509E-15
+    3    2    0.88282E-09    0.10000E+01    0.24221E+03    0.83199E-06    0.76758E-09    0.73125E-15
+    3    2    0.88282E-09    0.10000E+01    0.19533E+03    0.13113E-05    0.14586E-08    0.11524E-14
+    3    2    0.88282E-09    0.10000E+01    0.15752E+03    0.13113E-05    0.14586E-08    0.11524E-14
+    3    2    0.15405E-08    0.10000E+01    0.80645E+05    0.18269E-55    0.13490E-66    0.54677E-64
+    3    2    0.15405E-08    0.10000E+01    0.65036E+05    0.15290E-54    0.21218E-65    0.45826E-63
+    3    2    0.15405E-08    0.10000E+01    0.52449E+05    0.12858E-53    0.27762E-64    0.38601E-62
+    3    2    0.15405E-08    0.10000E+01    0.42297E+05    0.94658E-53    0.35838E-63    0.28530E-61
+    3    2    0.15405E-08    0.10000E+01    0.34111E+05    0.65402E-52    0.45000E-62    0.19884E-60
+    3    2    0.15405E-08    0.10000E+01    0.27509E+05    0.43562E-51    0.53687E-61    0.13444E-59
+    3    2    0.15405E-08    0.10000E+01    0.22184E+05    0.27961E-50    0.67363E-60    0.87080E-59
+    3    2    0.15405E-08    0.10000E+01    0.17891E+05    0.18533E-49    0.11289E-58    0.54622E-58
+    3    2    0.15405E-08    0.10000E+01    0.14428E+05    0.15238E-48    0.26201E-57    0.36757E-57
+    3    2    0.15405E-08    0.10000E+01    0.11635E+05    0.17062E-47    0.68977E-56    0.32004E-56
+    3    2    0.15405E-08    0.10000E+01    0.93834E+04    0.22709E-46    0.18452E-54    0.37435E-55
+    3    2    0.15405E-08    0.10000E+01    0.75673E+04    0.31601E-45    0.49207E-53    0.50389E-54
+    3    2    0.15405E-08    0.10000E+01    0.61026E+04    0.44183E-44    0.13120E-51    0.69935E-53
+    3    2    0.15405E-08    0.10000E+01    0.49215E+04    0.61817E-43    0.35090E-50    0.97243E-52
+    3    2    0.15405E-08    0.10000E+01    0.39689E+04    0.86713E-42    0.94186E-49    0.13538E-50
+    3    2    0.15405E-08    0.10000E+01    0.32008E+04    0.38388E-39    0.82015E-46    0.59497E-48
+    3    2    0.15405E-08    0.10000E+01    0.25813E+04    0.28234E-30    0.13871E-36    0.43503E-39
+    3    2    0.15405E-08    0.10000E+01    0.20817E+04    0.54168E-14    0.11889E-19    0.83090E-23
+    3    2    0.15405E-08    0.10000E+01    0.16788E+04    0.18421E-08    0.17637E-13    0.28198E-17
+    3    2    0.15405E-08    0.10000E+01    0.13538E+04    0.39619E-08    0.67025E-13    0.60582E-17
+    3    2    0.15405E-08    0.10000E+01    0.10918E+04    0.83302E-08    0.24995E-12    0.12729E-16
+    3    2    0.15405E-08    0.10000E+01    0.88049E+03    0.17136E-07    0.92018E-12    0.26171E-16
+    3    2    0.15405E-08    0.10000E+01    0.71007E+03    0.34558E-07    0.33502E-11    0.52760E-16
+    3    2    0.15405E-08    0.10000E+01    0.57264E+03    0.68509E-07    0.11918E-10    0.10456E-15
+    3    2    0.15405E-08    0.10000E+01    0.46180E+03    0.13358E-06    0.40079E-10    0.20383E-15
+    3    2    0.15405E-08    0.10000E+01    0.37242E+03    0.25496E-06    0.12220E-09    0.38897E-15
+    3    2    0.15405E-08    0.10000E+01    0.30034E+03    0.47091E-06    0.32774E-09    0.71830E-15
+    3    2    0.15405E-08    0.10000E+01    0.24221E+03    0.82960E-06    0.76522E-09    0.12653E-14
+    3    2    0.15405E-08    0.10000E+01    0.19533E+03    0.13074E-05    0.14541E-08    0.19939E-14
+    3    2    0.15405E-08    0.10000E+01    0.15752E+03    0.13074E-05    0.14541E-08    0.19939E-14
+    3    2    0.26880E-08    0.10000E+01    0.80645E+05    0.40016E-55    0.29775E-66    0.71377E-63
+    3    2    0.26880E-08    0.10000E+01    0.65036E+05    0.33702E-54    0.47104E-65    0.60220E-62
+    3    2    0.26880E-08    0.10000E+01    0.52449E+05    0.28518E-53    0.62608E-64    0.51044E-61
+    3    2    0.26880E-08    0.10000E+01    0.42297E+05    0.21266E-52    0.83389E-63    0.38190E-60
+    3    2    0.26880E-08    0.10000E+01    0.34111E+05    0.15083E-51    0.11085E-61    0.27256E-59
+    3    2    0.26880E-08    0.10000E+01    0.27509E+05    0.10534E-50    0.14340E-60    0.19220E-58
+    3    2    0.26880E-08    0.10000E+01    0.22184E+05    0.72140E-50    0.18275E-59    0.13280E-57
+    3    2    0.26880E-08    0.10000E+01    0.17891E+05    0.48753E-49    0.24425E-58    0.88610E-57
+    3    2    0.26880E-08    0.10000E+01    0.14428E+05    0.34040E-48    0.38257E-57    0.56597E-56
+    3    2    0.26880E-08    0.10000E+01    0.11635E+05    0.26995E-47    0.75904E-56    0.34744E-55
+    3    2    0.26880E-08    0.10000E+01    0.93834E+04    0.26607E-46    0.18283E-54    0.21233E-54
+    3    2    0.26880E-08    0.10000E+01    0.75673E+04    0.32214E-45    0.48263E-53    0.14582E-53
+    3    2    0.26880E-08    0.10000E+01    0.61026E+04    0.43665E-44    0.13044E-51    0.13601E-52
+    3    2    0.26880E-08    0.10000E+01    0.49215E+04    0.61450E-43    0.35257E-50    0.17068E-51
+    3    2    0.26880E-08    0.10000E+01    0.39689E+04    0.87003E-42    0.95041E-49    0.23909E-50
+    3    2    0.26880E-08    0.10000E+01    0.32008E+04    0.38698E-39    0.82781E-46    0.10617E-47
+    3    2    0.26880E-08    0.10000E+01    0.25813E+04    0.28473E-30    0.13972E-36    0.77188E-39
+    3    2    0.26880E-08    0.10000E+01    0.20817E+04    0.54503E-14    0.11932E-19    0.14522E-22
+    3    2    0.26880E-08    0.10000E+01    0.16788E+04    0.18508E-08    0.17668E-13    0.48863E-17
+    3    2    0.26880E-08    0.10000E+01    0.13538E+04    0.39761E-08    0.67123E-13    0.10395E-16
+    3    2    0.26880E-08    0.10000E+01    0.10918E+04    0.83536E-08    0.25026E-12    0.21701E-16
+    3    2    0.26880E-08    0.10000E+01    0.88049E+03    0.17174E-07    0.92119E-12    0.44417E-16
+    3    2    0.26880E-08    0.10000E+01    0.71007E+03    0.34622E-07    0.33536E-11    0.89244E-16
+    3    2    0.26880E-08    0.10000E+01    0.57264E+03    0.68615E-07    0.11929E-10    0.17641E-15
+    3    2    0.26880E-08    0.10000E+01    0.46180E+03    0.13376E-06    0.40115E-10    0.34319E-15
+    3    2    0.26880E-08    0.10000E+01    0.37242E+03    0.25527E-06    0.12231E-09    0.65389E-15
+    3    2    0.26880E-08    0.10000E+01    0.30034E+03    0.47142E-06    0.32803E-09    0.12061E-14
+    3    2    0.26880E-08    0.10000E+01    0.24221E+03    0.83045E-06    0.76589E-09    0.21229E-14
+    3    2    0.26880E-08    0.10000E+01    0.19533E+03    0.13087E-05    0.14554E-08    0.33436E-14
+    3    2    0.26880E-08    0.10000E+01    0.15752E+03    0.13087E-05    0.14554E-08    0.33436E-14
+    3    2    0.46905E-08    0.10000E+01    0.80645E+05    0.75128E-55    0.55962E-66    0.22366E-62
+    3    2    0.46905E-08    0.10000E+01    0.65036E+05    0.63330E-54    0.88604E-65    0.18882E-61
+    3    2    0.46905E-08    0.10000E+01    0.52449E+05    0.53636E-53    0.11802E-63    0.16015E-60
+    3    2    0.46905E-08    0.10000E+01    0.42297E+05    0.40065E-52    0.15778E-62    0.11996E-59
+    3    2    0.46905E-08    0.10000E+01    0.34111E+05    0.28507E-51    0.21094E-61    0.85796E-59
+    3    2    0.46905E-08    0.10000E+01    0.27509E+05    0.20006E-50    0.27425E-60    0.60731E-58
+    3    2    0.46905E-08    0.10000E+01    0.22184E+05    0.13756E-49    0.34567E-59    0.42239E-57
+    3    2    0.46905E-08    0.10000E+01    0.17891E+05    0.92174E-49    0.43346E-58    0.28485E-56
+    3    2    0.46905E-08    0.10000E+01    0.14428E+05    0.61213E-48    0.58213E-57    0.18463E-55
+    3    2    0.46905E-08    0.10000E+01    0.11635E+05    0.42663E-47    0.93912E-56    0.11471E-54
+    3    2    0.46905E-08    0.10000E+01    0.93834E+04    0.34602E-46    0.19496E-54    0.68833E-54
+    3    2    0.46905E-08    0.10000E+01    0.75673E+04    0.35571E-45    0.48707E-53    0.42158E-53
+    3    2    0.46905E-08    0.10000E+01    0.61026E+04    0.44715E-44    0.13056E-51    0.31484E-52
+    3    2    0.46905E-08    0.10000E+01    0.49215E+04    0.61733E-43    0.35344E-50    0.33668E-51
+    3    2    0.46905E-08    0.10000E+01    0.39689E+04    0.87232E-42    0.95280E-49    0.45077E-50
+    3    2    0.46905E-08    0.10000E+01    0.32008E+04    0.38783E-39    0.82838E-46    0.19847E-47
+    3    2    0.46905E-08    0.10000E+01    0.25813E+04    0.28483E-30    0.13945E-36    0.14265E-38
+    3    2    0.46905E-08    0.10000E+01    0.20817E+04    0.54385E-14    0.11867E-19    0.26321E-22
+    3    2    0.46905E-08    0.10000E+01    0.16788E+04    0.18444E-08    0.17547E-13    0.87387E-17
+    3    2    0.46905E-08    0.10000E+01    0.13538E+04    0.39567E-08    0.66637E-13    0.18380E-16
+    3    2    0.46905E-08    0.10000E+01    0.10918E+04    0.83052E-08    0.24836E-12    0.38077E-16
+    3    2    0.46905E-08    0.10000E+01    0.88049E+03    0.17064E-07    0.91397E-12    0.77515E-16
+    3    2    0.46905E-08    0.10000E+01    0.71007E+03    0.34383E-07    0.33266E-11    0.15513E-15
+    3    2    0.46905E-08    0.10000E+01    0.57264E+03    0.68115E-07    0.11831E-10    0.30575E-15
+    3    2    0.46905E-08    0.10000E+01    0.46180E+03    0.13275E-06    0.39782E-10    0.59352E-15
+    3    2    0.46905E-08    0.10000E+01    0.37242E+03    0.25327E-06    0.12128E-09    0.11290E-14
+    3    2    0.46905E-08    0.10000E+01    0.30034E+03    0.46765E-06    0.32527E-09    0.20801E-14
+    3    2    0.46905E-08    0.10000E+01    0.24221E+03    0.82371E-06    0.75942E-09    0.36583E-14
+    3    2    0.46905E-08    0.10000E+01    0.19533E+03    0.12980E-05    0.14431E-08    0.57592E-14
+    3    2    0.46905E-08    0.10000E+01    0.15752E+03    0.12980E-05    0.14431E-08    0.57592E-14
+    3    2    0.81846E-08    0.10000E+01    0.80645E+05    0.14034E-54    0.10464E-65    0.70657E-62
+    3    2    0.81846E-08    0.10000E+01    0.65036E+05    0.11840E-53    0.16579E-64    0.59682E-61
+    3    2    0.81846E-08    0.10000E+01    0.52449E+05    0.10035E-52    0.22122E-63    0.50642E-60
+    3    2    0.81846E-08    0.10000E+01    0.42297E+05    0.75068E-52    0.29670E-62    0.37967E-59
+    3    2    0.81846E-08    0.10000E+01    0.34111E+05    0.53558E-51    0.39876E-61    0.27200E-58
+    3    2    0.81846E-08    0.10000E+01    0.27509E+05    0.37755E-50    0.52205E-60    0.19308E-57
+    3    2    0.81846E-08    0.10000E+01    0.22184E+05    0.26112E-49    0.65981E-59    0.13495E-56
+    3    2    0.81846E-08    0.10000E+01    0.17891E+05    0.17543E-48    0.81085E-58    0.91763E-56
+    3    2    0.81846E-08    0.10000E+01    0.14428E+05    0.11476E-47    0.10048E-56    0.60231E-55
+    3    2    0.81846E-08    0.10000E+01    0.11635E+05    0.75041E-47    0.13636E-55    0.38011E-54
+    3    2    0.81846E-08    0.10000E+01    0.93834E+04    0.52499E-46    0.23032E-54    0.22989E-53
+    3    2    0.81846E-08    0.10000E+01    0.75673E+04    0.44205E-45    0.51040E-53    0.13512E-52
+    3    2    0.81846E-08    0.10000E+01    0.61026E+04    0.48277E-44    0.13264E-51    0.86084E-52
+    3    2    0.81846E-08    0.10000E+01    0.49215E+04    0.63332E-43    0.35860E-50    0.74954E-51
+    3    2    0.81846E-08    0.10000E+01    0.39689E+04    0.88632E-42    0.96668E-49    0.91285E-50
+    3    2    0.81846E-08    0.10000E+01    0.32008E+04    0.39335E-39    0.83768E-46    0.39273E-47
+    3    2    0.81846E-08    0.10000E+01    0.25813E+04    0.28781E-30    0.14021E-36    0.27727E-38
+    3    2    0.81846E-08    0.10000E+01    0.20817E+04    0.54650E-14    0.11837E-19    0.49673E-22
+    3    2    0.81846E-08    0.10000E+01    0.16788E+04    0.18472E-08    0.17439E-13    0.16122E-16
+    3    2    0.81846E-08    0.10000E+01    0.13538E+04    0.39504E-08    0.66175E-13    0.33239E-16
+    3    2    0.81846E-08    0.10000E+01    0.10918E+04    0.82749E-08    0.24648E-12    0.67921E-16
+    3    2    0.81846E-08    0.10000E+01    0.88049E+03    0.16977E-07    0.90659E-12    0.13692E-15
+    3    2    0.81846E-08    0.10000E+01    0.71007E+03    0.34173E-07    0.32985E-11    0.27206E-15
+    3    2    0.81846E-08    0.10000E+01    0.57264E+03    0.67646E-07    0.11728E-10    0.53333E-15
+    3    2    0.81846E-08    0.10000E+01    0.46180E+03    0.13175E-06    0.39428E-10    0.10312E-14
+    3    2    0.81846E-08    0.10000E+01    0.37242E+03    0.25126E-06    0.12019E-09    0.19558E-14
+    3    2    0.81846E-08    0.10000E+01    0.30034E+03    0.46378E-06    0.32232E-09    0.35960E-14
+    3    2    0.81846E-08    0.10000E+01    0.24221E+03    0.81669E-06    0.75251E-09    0.63152E-14
+    3    2    0.81846E-08    0.10000E+01    0.19533E+03    0.12867E-05    0.14299E-08    0.99332E-14
+    3    2    0.81846E-08    0.10000E+01    0.15752E+03    0.12867E-05    0.14299E-08    0.99332E-14
+    3    2    0.14282E-07    0.10000E+01    0.80645E+05    0.26081E-54    0.19462E-65    0.22451E-61
+    3    2    0.14282E-07    0.10000E+01    0.65036E+05    0.22017E-53    0.30853E-64    0.18972E-60
+    3    2    0.14282E-07    0.10000E+01    0.52449E+05    0.18672E-52    0.41226E-63    0.16105E-59
+    3    2    0.14282E-07    0.10000E+01    0.42297E+05    0.13985E-51    0.55436E-62    0.12083E-58
+    3    2    0.14282E-07    0.10000E+01    0.34111E+05    0.99993E-51    0.74822E-61    0.86673E-58
+    3    2    0.14282E-07    0.10000E+01    0.27509E+05    0.70750E-50    0.98594E-60    0.61663E-57
+    3    2    0.14282E-07    0.10000E+01    0.22184E+05    0.49204E-49    0.12551E-58    0.43263E-56
+    3    2    0.14282E-07    0.10000E+01    0.17891E+05    0.33260E-48    0.15423E-57    0.29607E-55
+    3    2    0.14282E-07    0.10000E+01    0.14428E+05    0.21775E-47    0.18574E-56    0.19631E-54
+    3    2    0.14282E-07    0.10000E+01    0.11635E+05    0.13936E-46    0.22811E-55    0.12566E-53
+    3    2    0.14282E-07    0.10000E+01    0.93834E+04    0.90020E-46    0.31640E-54    0.77156E-53
+    3    2    0.14282E-07    0.10000E+01    0.75673E+04    0.63923E-45    0.57863E-53    0.45198E-52
+    3    2    0.14282E-07    0.10000E+01    0.61026E+04    0.57455E-44    0.13890E-51    0.26546E-51
+    3    2    0.14282E-07    0.10000E+01    0.49215E+04    0.67788E-43    0.37101E-50    0.19165E-50
+    3    2    0.14282E-07    0.10000E+01    0.39689E+04    0.92153E-42    0.99885E-49    0.20280E-49
+    3    2    0.14282E-07    0.10000E+01    0.32008E+04    0.40647E-39    0.86071E-46    0.83505E-47
+    3    2    0.14282E-07    0.10000E+01    0.25813E+04    0.29538E-30    0.14252E-36    0.57581E-38
+    3    2    0.14282E-07    0.10000E+01    0.20817E+04    0.55493E-14    0.11840E-19    0.99370E-22
+    3    2    0.14282E-07    0.10000E+01    0.16788E+04    0.18625E-08    0.17312E-13    0.31207E-16
+    3    2    0.14282E-07    0.10000E+01    0.13538E+04    0.39581E-08    0.65587E-13    0.62336E-16
+    3    2    0.14282E-07    0.10000E+01    0.10918E+04    0.82569E-08    0.24400E-12    0.12452E-15
+    3    2    0.14282E-07    0.10000E+01    0.88049E+03    0.16891E-07    0.89661E-12    0.24687E-15
+    3    2    0.14282E-07    0.10000E+01    0.71007E+03    0.33929E-07    0.32599E-11    0.48450E-15
+    3    2    0.14282E-07    0.10000E+01    0.57264E+03    0.67058E-07    0.11585E-10    0.94100E-15
+    3    2    0.14282E-07    0.10000E+01    0.46180E+03    0.13045E-06    0.38937E-10    0.18067E-14
+    3    2    0.14282E-07    0.10000E+01    0.37242E+03    0.24856E-06    0.11867E-09    0.34092E-14
+    3    2    0.14282E-07    0.10000E+01    0.30034E+03    0.45852E-06    0.31821E-09    0.62455E-14
+    3    2    0.14282E-07    0.10000E+01    0.24221E+03    0.80708E-06    0.74287E-09    0.10941E-13
+    3    2    0.14282E-07    0.10000E+01    0.19533E+03    0.12712E-05    0.14116E-08    0.17183E-13
+    3    2    0.14282E-07    0.10000E+01    0.15752E+03    0.12712E-05    0.14116E-08    0.17183E-13
+    3    2    0.24920E-07    0.10000E+01    0.80645E+05    0.48168E-54    0.35967E-65    0.71069E-61
+    3    2    0.24920E-07    0.10000E+01    0.65036E+05    0.40685E-53    0.57044E-64    0.60078E-60
+    3    2    0.24920E-07    0.10000E+01    0.52449E+05    0.34521E-52    0.76309E-63    0.51014E-59
+    3    2    0.24920E-07    0.10000E+01    0.42297E+05    0.25878E-51    0.10282E-61    0.38296E-58
+    3    2    0.24920E-07    0.10000E+01    0.34111E+05    0.18535E-50    0.13924E-60    0.27501E-57
+    3    2    0.24920E-07    0.10000E+01    0.27509E+05    0.13153E-49    0.18447E-59    0.19600E-56
+    3    2    0.24920E-07    0.10000E+01    0.22184E+05    0.91899E-49    0.23660E-58    0.13793E-55
+    3    2    0.24920E-07    0.10000E+01    0.17891E+05    0.62523E-48    0.29281E-57    0.94872E-55
+    3    2    0.24920E-07    0.10000E+01    0.14428E+05    0.41192E-47    0.35165E-56    0.63402E-54
+    3    2    0.24920E-07    0.10000E+01    0.11635E+05    0.26332E-46    0.41519E-55    0.41054E-53
+    3    2    0.24920E-07    0.10000E+01    0.93834E+04    0.16508E-45    0.50655E-54    0.25587E-52
+    3    2    0.24920E-07    0.10000E+01    0.75673E+04    0.10582E-44    0.74804E-53    0.15150E-51
+    3    2    0.24920E-07    0.10000E+01    0.61026E+04    0.78665E-44    0.15523E-51    0.86408E-51
+    3    2    0.24920E-07    0.10000E+01    0.49215E+04    0.78744E-43    0.39945E-50    0.54803E-50
+    3    2    0.24920E-07    0.10000E+01    0.39689E+04    0.10040E-41    0.10697E-48    0.49613E-49
+    3    2    0.24920E-07    0.10000E+01    0.32008E+04    0.43599E-39    0.91397E-46    0.19150E-46
+    3    2    0.24920E-07    0.10000E+01    0.25813E+04    0.31320E-30    0.14869E-36    0.12860E-37
+    3    2    0.24920E-07    0.10000E+01    0.20817E+04    0.57813E-14    0.11999E-19    0.21353E-21
+    3    2    0.24920E-07    0.10000E+01    0.16788E+04    0.19155E-08    0.17297E-13    0.64434E-16
+    3    2    0.24920E-07    0.10000E+01    0.13538E+04    0.40243E-08    0.65337E-13    0.12313E-15
+    3    2    0.24920E-07    0.10000E+01    0.10918E+04    0.83304E-08    0.24253E-12    0.23782E-15
+    3    2    0.24920E-07    0.10000E+01    0.88049E+03    0.16950E-07    0.88973E-12    0.45957E-15
+    3    2    0.24920E-07    0.10000E+01    0.71007E+03    0.33914E-07    0.32311E-11    0.88432E-15
+    3    2    0.24920E-07    0.10000E+01    0.57264E+03    0.66834E-07    0.11473E-10    0.16916E-14
+    3    2    0.24920E-07    0.10000E+01    0.46180E+03    0.12974E-06    0.38541E-10    0.32105E-14
+    3    2    0.24920E-07    0.10000E+01    0.37242E+03    0.24681E-06    0.11743E-09    0.60062E-14
+    3    2    0.24920E-07    0.10000E+01    0.30034E+03    0.45477E-06    0.31482E-09    0.10935E-13
+    3    2    0.24920E-07    0.10000E+01    0.24221E+03    0.79986E-06    0.73487E-09    0.19075E-13
+    3    2    0.24920E-07    0.10000E+01    0.19533E+03    0.12593E-05    0.13963E-08    0.29880E-13
+    3    2    0.24920E-07    0.10000E+01    0.15752E+03    0.12593E-05    0.13963E-08    0.29880E-13
+    3    2    0.43485E-07    0.10000E+01    0.80645E+05    0.88433E-54    0.66069E-65    0.22456E-60
+    3    2    0.43485E-07    0.10000E+01    0.65036E+05    0.74727E-53    0.10482E-63    0.18989E-59
+    3    2    0.43485E-07    0.10000E+01    0.52449E+05    0.63431E-52    0.14035E-62    0.16128E-58
+    3    2    0.43485E-07    0.10000E+01    0.42297E+05    0.47586E-51    0.18942E-61    0.12114E-57
+    3    2    0.43485E-07    0.10000E+01    0.34111E+05    0.34130E-50    0.25718E-60    0.87068E-57
+    3    2    0.43485E-07    0.10000E+01    0.27509E+05    0.24275E-49    0.34223E-59    0.62148E-56
+    3    2    0.43485E-07    0.10000E+01    0.22184E+05    0.17026E-48    0.44192E-58    0.43843E-55
+    3    2    0.43485E-07    0.10000E+01    0.17891E+05    0.11650E-47    0.55163E-57    0.30278E-54
+    3    2    0.43485E-07    0.10000E+01    0.14428E+05    0.77328E-47    0.66699E-56    0.20362E-53
+    3    2    0.43485E-07    0.10000E+01    0.11635E+05    0.49745E-46    0.78169E-55    0.13307E-52
+    3    2    0.43485E-07    0.10000E+01    0.93834E+04    0.31041E-45    0.89829E-54    0.84004E-52
+    3    2    0.43485E-07    0.10000E+01    0.75673E+04    0.19017E-44    0.11204E-52    0.50443E-51
+    3    2    0.43485E-07    0.10000E+01    0.61026E+04    0.12351E-43    0.19108E-51    0.28660E-50
+    3    2    0.43485E-07    0.10000E+01    0.49215E+04    0.10231E-42    0.45463E-50    0.16860E-49
+    3    2    0.43485E-07    0.10000E+01    0.39689E+04    0.11691E-41    0.12006E-48    0.13250E-48
+    3    2    0.43485E-07    0.10000E+01    0.32008E+04    0.49165E-39    0.10140E-45    0.47236E-46
+    3    2    0.43485E-07    0.10000E+01    0.25813E+04    0.34707E-30    0.16075E-36    0.30878E-37
+    3    2    0.43485E-07    0.10000E+01    0.20817E+04    0.62441E-14    0.12373E-19    0.49653E-21
+    3    2    0.43485E-07    0.10000E+01    0.16788E+04    0.20261E-08    0.17392E-13    0.14386E-15
+    3    2    0.43485E-07    0.10000E+01    0.13538E+04    0.41734E-08    0.65347E-13    0.26038E-15
+    3    2    0.43485E-07    0.10000E+01    0.10918E+04    0.85233E-08    0.24161E-12    0.48107E-15
+    3    2    0.43485E-07    0.10000E+01    0.88049E+03    0.17177E-07    0.88378E-12    0.89670E-15
+    3    2    0.43485E-07    0.10000E+01    0.71007E+03    0.34129E-07    0.32028E-11    0.16759E-14
+    3    2    0.43485E-07    0.10000E+01    0.57264E+03    0.66910E-07    0.11357E-10    0.31319E-14
+    3    2    0.43485E-07    0.10000E+01    0.46180E+03    0.12939E-06    0.38116E-10    0.58358E-14
+    3    2    0.43485E-07    0.10000E+01    0.37242E+03    0.24545E-06    0.11607E-09    0.10766E-13
+    3    2    0.43485E-07    0.10000E+01    0.30034E+03    0.45136E-06    0.31108E-09    0.19403E-13
+    3    2    0.43485E-07    0.10000E+01    0.24221E+03    0.79279E-06    0.72601E-09    0.33605E-13
+    3    2    0.43485E-07    0.10000E+01    0.19533E+03    0.12471E-05    0.13793E-08    0.52408E-13
+    3    2    0.43485E-07    0.10000E+01    0.15752E+03    0.12471E-05    0.13793E-08    0.52408E-13
+    3    2    0.75878E-07    0.10000E+01    0.80645E+05    0.16140E-53    0.12064E-64    0.70625E-60
+    3    2    0.75878E-07    0.10000E+01    0.65036E+05    0.13643E-52    0.19145E-63    0.59738E-59
+    3    2    0.75878E-07    0.10000E+01    0.52449E+05    0.11585E-51    0.25654E-62    0.50751E-58
+    3    2    0.75878E-07    0.10000E+01    0.42297E+05    0.86962E-51    0.34667E-61    0.38134E-57
+    3    2    0.75878E-07    0.10000E+01    0.34111E+05    0.62442E-50    0.47169E-60    0.27430E-56
+    3    2    0.75878E-07    0.10000E+01    0.27509E+05    0.44496E-49    0.62991E-59    0.19604E-55
+    3    2    0.75878E-07    0.10000E+01    0.22184E+05    0.31304E-48    0.81803E-58    0.13858E-54
+    3    2    0.75878E-07    0.10000E+01    0.17891E+05    0.21525E-47    0.10293E-56    0.96021E-54
+    3    2    0.75878E-07    0.10000E+01    0.14428E+05    0.14386E-46    0.12561E-55    0.64903E-53
+    3    2    0.75878E-07    0.10000E+01    0.11635E+05    0.93300E-46    0.14805E-54    0.42728E-52
+    3    2    0.75878E-07    0.10000E+01    0.93834E+04    0.58540E-45    0.16714E-53    0.27257E-51
+    3    2    0.75878E-07    0.10000E+01    0.75673E+04    0.35416E-44    0.18898E-52    0.16589E-50
+    3    2    0.75878E-07    0.10000E+01    0.61026E+04    0.21379E-43    0.26550E-51    0.94893E-50
+    3    2    0.75878E-07    0.10000E+01    0.49215E+04    0.15041E-42    0.55820E-50    0.53739E-49
+    3    2    0.75878E-07    0.10000E+01    0.39689E+04    0.14871E-41    0.14332E-48    0.37789E-48
+    3    2    0.75878E-07    0.10000E+01    0.32008E+04    0.59270E-39    0.11937E-45    0.12378E-45
+    3    2    0.75878E-07    0.10000E+01    0.25813E+04    0.40870E-30    0.18314E-36    0.78862E-37
+    3    2    0.75878E-07    0.10000E+01    0.20817E+04    0.71198E-14    0.13148E-19    0.12425E-20
+    3    2    0.75878E-07    0.10000E+01    0.16788E+04    0.22426E-08    0.17729E-13    0.34790E-15
+    3    2    0.75878E-07    0.10000E+01    0.13538E+04    0.44786E-08    0.66012E-13    0.59486E-15
+    3    2    0.75878E-07    0.10000E+01    0.10918E+04    0.89480E-08    0.24241E-12    0.10445E-14
+    3    2    0.75878E-07    0.10000E+01    0.88049E+03    0.17748E-07    0.88232E-12    0.18618E-14
+    3    2    0.75878E-07    0.10000E+01    0.71007E+03    0.34848E-07    0.31862E-11    0.33478E-14
+    3    2    0.75878E-07    0.10000E+01    0.57264E+03    0.67717E-07    0.11271E-10    0.60543E-14
+    3    2    0.75878E-07    0.10000E+01    0.46180E+03    0.13008E-06    0.37768E-10    0.10980E-13
+    3    2    0.75878E-07    0.10000E+01    0.37242E+03    0.24557E-06    0.11491E-09    0.19826E-13
+    3    2    0.75878E-07    0.10000E+01    0.30034E+03    0.45002E-06    0.30779E-09    0.35159E-13
+    3    2    0.75878E-07    0.10000E+01    0.24221E+03    0.78857E-06    0.71810E-09    0.60198E-13
+    3    2    0.75878E-07    0.10000E+01    0.19533E+03    0.12387E-05    0.13640E-08    0.93204E-13
+    3    2    0.75878E-07    0.10000E+01    0.15752E+03    0.12387E-05    0.13640E-08    0.93204E-13
+    3    2    0.13240E-06    0.10000E+01    0.80645E+05    0.29295E-53    0.21906E-64    0.22138E-59
+    3    2    0.13240E-06    0.10000E+01    0.65036E+05    0.24772E-52    0.34774E-63    0.18729E-58
+    3    2    0.13240E-06    0.10000E+01    0.52449E+05    0.21040E-51    0.46625E-62    0.15915E-57
+    3    2    0.13240E-06    0.10000E+01    0.42297E+05    0.15802E-50    0.63074E-61    0.11963E-56
+    3    2    0.13240E-06    0.10000E+01    0.34111E+05    0.11357E-49    0.85969E-60    0.86105E-56
+    3    2    0.13240E-06    0.10000E+01    0.27509E+05    0.81055E-49    0.11514E-58    0.61602E-55
+    3    2    0.13240E-06    0.10000E+01    0.22184E+05    0.57169E-48    0.15023E-57    0.43621E-54
+    3    2    0.13240E-06    0.10000E+01    0.17891E+05    0.39469E-47    0.19035E-56    0.30308E-53
+    3    2    0.13240E-06    0.10000E+01    0.14428E+05    0.26536E-46    0.23438E-55    0.20571E-52
+    3    2    0.13240E-06    0.10000E+01    0.11635E+05    0.17346E-45    0.27892E-54    0.13623E-51
+    3    2    0.13240E-06    0.10000E+01    0.93834E+04    0.10977E-44    0.31545E-53    0.87647E-51
+    3    2    0.13240E-06    0.10000E+01    0.75673E+04    0.66564E-44    0.34149E-52    0.53971E-50
+    3    2    0.13240E-06    0.10000E+01    0.61026E+04    0.38961E-43    0.41357E-51    0.31192E-49
+    3    2    0.13240E-06    0.10000E+01    0.49215E+04    0.24490E-42    0.74700E-50    0.17374E-48
+    3    2    0.13240E-06    0.10000E+01    0.39689E+04    0.20806E-41    0.18311E-48    0.11270E-47
+    3    2    0.13240E-06    0.10000E+01    0.32008E+04    0.76969E-39    0.15023E-45    0.34017E-45
+    3    2    0.13240E-06    0.10000E+01    0.25813E+04    0.51603E-30    0.22247E-36    0.21156E-36
+    3    2    0.13240E-06    0.10000E+01    0.20817E+04    0.86882E-14    0.14574E-19    0.33052E-20
+    3    2    0.13240E-06    0.10000E+01    0.16788E+04    0.26379E-08    0.18431E-13    0.90376E-15
+    3    2    0.13240E-06    0.10000E+01    0.13538E+04    0.50422E-08    0.67611E-13    0.14677E-14
+    3    2    0.13240E-06    0.10000E+01    0.10918E+04    0.97482E-08    0.24548E-12    0.24504E-14
+    3    2    0.13240E-06    0.10000E+01    0.88049E+03    0.18860E-07    0.88596E-12    0.41623E-14
+    3    2    0.13240E-06    0.10000E+01    0.71007E+03    0.36334E-07    0.31799E-11    0.71535E-14
+    3    2    0.13240E-06    0.10000E+01    0.57264E+03    0.69582E-07    0.11202E-10    0.12412E-13
+    3    2    0.13240E-06    0.10000E+01    0.46180E+03    0.13219E-06    0.37440E-10    0.21703E-13
+    3    2    0.13240E-06    0.10000E+01    0.37242E+03    0.24750E-06    0.11373E-09    0.38008E-13
+    3    2    0.13240E-06    0.10000E+01    0.30034E+03    0.45091E-06    0.30435E-09    0.65805E-13
+    3    2    0.13240E-06    0.10000E+01    0.24221E+03    0.78691E-06    0.70966E-09    0.11068E-12
+    3    2    0.13240E-06    0.10000E+01    0.19533E+03    0.12330E-05    0.13476E-08    0.16942E-12
+    3    2    0.13240E-06    0.10000E+01    0.15752E+03    0.12330E-05    0.13476E-08    0.16942E-12
+    3    2    0.23103E-06    0.10000E+01    0.80645E+05    0.52803E-53    0.39496E-64    0.67761E-59
+    3    2    0.23103E-06    0.10000E+01    0.65036E+05    0.44662E-52    0.62711E-63    0.57339E-58
+    3    2    0.23103E-06    0.10000E+01    0.52449E+05    0.37943E-51    0.84128E-62    0.48731E-57
+    3    2    0.23103E-06    0.10000E+01    0.42297E+05    0.28509E-50    0.11391E-60    0.36641E-56
+    3    2    0.23103E-06    0.10000E+01    0.34111E+05    0.20505E-49    0.15548E-59    0.26387E-55
+    3    2    0.23103E-06    0.10000E+01    0.27509E+05    0.14653E-48    0.20872E-58    0.18894E-54
+    3    2    0.23103E-06    0.10000E+01    0.22184E+05    0.10356E-47    0.27339E-57    0.13397E-53
+    3    2    0.23103E-06    0.10000E+01    0.17891E+05    0.71736E-47    0.34839E-56    0.93285E-53
+    3    2    0.23103E-06    0.10000E+01    0.14428E+05    0.48469E-46    0.43233E-55    0.63523E-52
+    3    2    0.23103E-06    0.10000E+01    0.11635E+05    0.31900E-45    0.51953E-54    0.42266E-51
+    3    2    0.23103E-06    0.10000E+01    0.93834E+04    0.20361E-44    0.59284E-53    0.27372E-50
+    3    2    0.23103E-06    0.10000E+01    0.75673E+04    0.12442E-43    0.63388E-52    0.17014E-49
+    3    2    0.23103E-06    0.10000E+01    0.61026E+04    0.72247E-43    0.69984E-51    0.99339E-49
+    3    2    0.23103E-06    0.10000E+01    0.49215E+04    0.42552E-42    0.10891E-49    0.55049E-48
+    3    2    0.23103E-06    0.10000E+01    0.39689E+04    0.31742E-41    0.25078E-48    0.33826E-47
+    3    2    0.23103E-06    0.10000E+01    0.32008E+04    0.10776E-38    0.20272E-45    0.95118E-45
+    3    2    0.23103E-06    0.10000E+01    0.25813E+04    0.70122E-30    0.29079E-36    0.57874E-36
+    3    2    0.23103E-06    0.10000E+01    0.20817E+04    0.11466E-13    0.17168E-19    0.90458E-20
+    3    2    0.23103E-06    0.10000E+01    0.16788E+04    0.33517E-08    0.19859E-13    0.24412E-14
+    3    2    0.23103E-06    0.10000E+01    0.13538E+04    0.60716E-08    0.71198E-13    0.38086E-14
+    3    2    0.23103E-06    0.10000E+01    0.10918E+04    0.11239E-07    0.25388E-12    0.60969E-14
+    3    2    0.23103E-06    0.10000E+01    0.88049E+03    0.20997E-07    0.90382E-12    0.99150E-14
+    3    2    0.23103E-06    0.10000E+01    0.71007E+03    0.39333E-07    0.32117E-11    0.16300E-13
+    3    2    0.23103E-06    0.10000E+01    0.57264E+03    0.73660E-07    0.11236E-10    0.27062E-13
+    3    2    0.23103E-06    0.10000E+01    0.46180E+03    0.13751E-06    0.37387E-10    0.45364E-13
+    3    2    0.23103E-06    0.10000E+01    0.37242E+03    0.25406E-06    0.11326E-09    0.76484E-13
+    3    2    0.23103E-06    0.10000E+01    0.30034E+03    0.45840E-06    0.30262E-09    0.12829E-12
+    3    2    0.23103E-06    0.10000E+01    0.24221E+03    0.79461E-06    0.70495E-09    0.21053E-12
+    3    2    0.23103E-06    0.10000E+01    0.19533E+03    0.12399E-05    0.13379E-08    0.31701E-12
+    3    2    0.23103E-06    0.10000E+01    0.15752E+03    0.12399E-05    0.13379E-08    0.31701E-12
+    3    2    0.40314E-06    0.10000E+01    0.80645E+05    0.92428E-53    0.69138E-64    0.12609E-58
+    3    2    0.40314E-06    0.10000E+01    0.65036E+05    0.78179E-52    0.10978E-62    0.10670E-57
+    3    2    0.40314E-06    0.10000E+01    0.52449E+05    0.66419E-51    0.14728E-61    0.90683E-57
+    3    2    0.40314E-06    0.10000E+01    0.42297E+05    0.49908E-50    0.19943E-60    0.68186E-56
+    3    2    0.40314E-06    0.10000E+01    0.34111E+05    0.35900E-49    0.27225E-59    0.49107E-55
+    3    2    0.40314E-06    0.10000E+01    0.27509E+05    0.25657E-48    0.36558E-58    0.35165E-54
+    3    2    0.40314E-06    0.10000E+01    0.22184E+05    0.18138E-47    0.47904E-57    0.24939E-53
+    3    2    0.40314E-06    0.10000E+01    0.17891E+05    0.12568E-46    0.61083E-56    0.17369E-52
+    3    2    0.40314E-06    0.10000E+01    0.14428E+05    0.84962E-46    0.75865E-55    0.11831E-51
+    3    2    0.40314E-06    0.10000E+01    0.11635E+05    0.55960E-45    0.91267E-54    0.78759E-51
+    3    2    0.40314E-06    0.10000E+01    0.93834E+04    0.35752E-44    0.10428E-52    0.51040E-50
+    3    2    0.40314E-06    0.10000E+01    0.75673E+04    0.21870E-43    0.11146E-51    0.31756E-49
+    3    2    0.40314E-06    0.10000E+01    0.61026E+04    0.12698E-42    0.12209E-50    0.18562E-48
+    3    2    0.40314E-06    0.10000E+01    0.49215E+04    0.74387E-42    0.18688E-49    0.10284E-47
+    3    2    0.40314E-06    0.10000E+01    0.39689E+04    0.54744E-41    0.42672E-48    0.62876E-47
+    3    2    0.40314E-06    0.10000E+01    0.32008E+04    0.18390E-38    0.34435E-45    0.17549E-44
+    3    2    0.40314E-06    0.10000E+01    0.25813E+04    0.11924E-29    0.49229E-36    0.10652E-35
+    3    2    0.40314E-06    0.10000E+01    0.20817E+04    0.19441E-13    0.28697E-19    0.16656E-19
+    3    2    0.40314E-06    0.10000E+01    0.16788E+04    0.56581E-08    0.32788E-13    0.44905E-14
+    3    2    0.40314E-06    0.10000E+01    0.13538E+04    0.10180E-07    0.11715E-12    0.69783E-14
+    3    2    0.40314E-06    0.10000E+01    0.10918E+04    0.18734E-07    0.41660E-12    0.11123E-13
+    3    2    0.40314E-06    0.10000E+01    0.88049E+03    0.34830E-07    0.14800E-11    0.18006E-13
+    3    2    0.40314E-06    0.10000E+01    0.71007E+03    0.64984E-07    0.52508E-11    0.29458E-13
+    3    2    0.40314E-06    0.10000E+01    0.57264E+03    0.12130E-06    0.18350E-10    0.48659E-13
+    3    2    0.40314E-06    0.10000E+01    0.46180E+03    0.22584E-06    0.61014E-10    0.81150E-13
+    3    2    0.40314E-06    0.10000E+01    0.37242E+03    0.41641E-06    0.18476E-09    0.13616E-12
+    3    2    0.40314E-06    0.10000E+01    0.30034E+03    0.75021E-06    0.49352E-09    0.22743E-12
+    3    2    0.40314E-06    0.10000E+01    0.24221E+03    0.12991E-05    0.11495E-08    0.37199E-12
+    3    2    0.40314E-06    0.10000E+01    0.19533E+03    0.20256E-05    0.21813E-08    0.55886E-12
+    3    2    0.40314E-06    0.10000E+01    0.15752E+03    0.20256E-05    0.21813E-08    0.55886E-12
+    3    2    0.70346E-06    0.10000E+01    0.80645E+05    0.16128E-52    0.12064E-63    0.22002E-58
+    3    2    0.70346E-06    0.10000E+01    0.65036E+05    0.13642E-51    0.19156E-62    0.18618E-57
+    3    2    0.70346E-06    0.10000E+01    0.52449E+05    0.11590E-50    0.25699E-61    0.15824E-56
+    3    2    0.70346E-06    0.10000E+01    0.42297E+05    0.87086E-50    0.34800E-60    0.11898E-55
+    3    2    0.70346E-06    0.10000E+01    0.34111E+05    0.62643E-49    0.47506E-59    0.85689E-55
+    3    2    0.70346E-06    0.10000E+01    0.27509E+05    0.44770E-48    0.63792E-58    0.61361E-54
+    3    2    0.70346E-06    0.10000E+01    0.22184E+05    0.31649E-47    0.83589E-57    0.43516E-53
+    3    2    0.70346E-06    0.10000E+01    0.17891E+05    0.21930E-46    0.10659E-55    0.30307E-52
+    3    2    0.70346E-06    0.10000E+01    0.14428E+05    0.14825E-45    0.13238E-54    0.20645E-51
+    3    2    0.70346E-06    0.10000E+01    0.11635E+05    0.97646E-45    0.15926E-53    0.13743E-50
+    3    2    0.70346E-06    0.10000E+01    0.93834E+04    0.62385E-44    0.18195E-52    0.89061E-50
+    3    2    0.70346E-06    0.10000E+01    0.75673E+04    0.38162E-43    0.19449E-51    0.55412E-49
+    3    2    0.70346E-06    0.10000E+01    0.61026E+04    0.22157E-42    0.21303E-50    0.32389E-48
+    3    2    0.70346E-06    0.10000E+01    0.49215E+04    0.12980E-41    0.32609E-49    0.17945E-47
+    3    2    0.70346E-06    0.10000E+01    0.39689E+04    0.95526E-41    0.74461E-48    0.10972E-46
+    3    2    0.70346E-06    0.10000E+01    0.32008E+04    0.32090E-38    0.60087E-45    0.30622E-44
+    3    2    0.70346E-06    0.10000E+01    0.25813E+04    0.20807E-29    0.85901E-36    0.18587E-35
+    3    2    0.70346E-06    0.10000E+01    0.20817E+04    0.33924E-13    0.50075E-19    0.29064E-19
+    3    2    0.70346E-06    0.10000E+01    0.16788E+04    0.98731E-08    0.57213E-13    0.78356E-14
+    3    2    0.70346E-06    0.10000E+01    0.13538E+04    0.17763E-07    0.20442E-12    0.12177E-13
+    3    2    0.70346E-06    0.10000E+01    0.10918E+04    0.32690E-07    0.72695E-12    0.19410E-13
+    3    2    0.70346E-06    0.10000E+01    0.88049E+03    0.60777E-07    0.25824E-11    0.31420E-13
+    3    2    0.70346E-06    0.10000E+01    0.71007E+03    0.11339E-06    0.91623E-11    0.51403E-13
+    3    2    0.70346E-06    0.10000E+01    0.57264E+03    0.21166E-06    0.32019E-10    0.84906E-13
+    3    2    0.70346E-06    0.10000E+01    0.46180E+03    0.39408E-06    0.10647E-09    0.14160E-12
+    3    2    0.70346E-06    0.10000E+01    0.37242E+03    0.72661E-06    0.32239E-09    0.23760E-12
+    3    2    0.70346E-06    0.10000E+01    0.30034E+03    0.13091E-05    0.86116E-09    0.39686E-12
+    3    2    0.70346E-06    0.10000E+01    0.24221E+03    0.22668E-05    0.20058E-08    0.64910E-12
+    3    2    0.70346E-06    0.10000E+01    0.19533E+03    0.35346E-05    0.38063E-08    0.97518E-12
+    3    2    0.70346E-06    0.10000E+01    0.15752E+03    0.35346E-05    0.38063E-08    0.97518E-12
+    3    2    0.12275E-05    0.10000E+01    0.80645E+05    0.28142E-52    0.21051E-63    0.38393E-58
+    3    2    0.12275E-05    0.10000E+01    0.65036E+05    0.23804E-51    0.33425E-62    0.32488E-57
+    3    2    0.12275E-05    0.10000E+01    0.52449E+05    0.20223E-50    0.44843E-61    0.27611E-56
+    3    2    0.12275E-05    0.10000E+01    0.42297E+05    0.15196E-49    0.60723E-60    0.20761E-55
+    3    2    0.12275E-05    0.10000E+01    0.34111E+05    0.10931E-48    0.82896E-59    0.14952E-54
+    3    2    0.12275E-05    0.10000E+01    0.27509E+05    0.78121E-48    0.11131E-57    0.10707E-53
+    3    2    0.12275E-05    0.10000E+01    0.22184E+05    0.55226E-47    0.14586E-56    0.75933E-53
+    3    2    0.12275E-05    0.10000E+01    0.17891E+05    0.38267E-46    0.18599E-55    0.52885E-52
+    3    2    0.12275E-05    0.10000E+01    0.14428E+05    0.25869E-45    0.23099E-54    0.36024E-51
+    3    2    0.12275E-05    0.10000E+01    0.11635E+05    0.17039E-44    0.27789E-53    0.23981E-50
+    3    2    0.12275E-05    0.10000E+01    0.93834E+04    0.10886E-43    0.31750E-52    0.15541E-49
+    3    2    0.12275E-05    0.10000E+01    0.75673E+04    0.66591E-43    0.33938E-51    0.96691E-49
+    3    2    0.12275E-05    0.10000E+01    0.61026E+04    0.38663E-42    0.37173E-50    0.56516E-48
+    3    2    0.12275E-05    0.10000E+01    0.49215E+04    0.22649E-41    0.56900E-49    0.31313E-47
+    3    2    0.12275E-05    0.10000E+01    0.39689E+04    0.16669E-40    0.12993E-47    0.19145E-46
+    3    2    0.12275E-05    0.10000E+01    0.32008E+04    0.55995E-38    0.10485E-44    0.53434E-44
+    3    2    0.12275E-05    0.10000E+01    0.25813E+04    0.36306E-29    0.14989E-35    0.32433E-35
+    3    2    0.12275E-05    0.10000E+01    0.20817E+04    0.59195E-13    0.87377E-19    0.50715E-19
+    3    2    0.12275E-05    0.10000E+01    0.16788E+04    0.17228E-07    0.99834E-13    0.13673E-13
+    3    2    0.12275E-05    0.10000E+01    0.13538E+04    0.30996E-07    0.35670E-12    0.21248E-13
+    3    2    0.12275E-05    0.10000E+01    0.10918E+04    0.57043E-07    0.12685E-11    0.33869E-13
+    3    2    0.12275E-05    0.10000E+01    0.88049E+03    0.10605E-06    0.45062E-11    0.54826E-13
+    3    2    0.12275E-05    0.10000E+01    0.71007E+03    0.19787E-06    0.15988E-10    0.89695E-13
+    3    2    0.12275E-05    0.10000E+01    0.57264E+03    0.36933E-06    0.55872E-10    0.14816E-12
+    3    2    0.12275E-05    0.10000E+01    0.46180E+03    0.68764E-06    0.18578E-09    0.24709E-12
+    3    2    0.12275E-05    0.10000E+01    0.37242E+03    0.12679E-05    0.56255E-09    0.41460E-12
+    3    2    0.12275E-05    0.10000E+01    0.30034E+03    0.22842E-05    0.15027E-08    0.69250E-12
+    3    2    0.12275E-05    0.10000E+01    0.24221E+03    0.39554E-05    0.34999E-08    0.11326E-11
+    3    2    0.12275E-05    0.10000E+01    0.19533E+03    0.61677E-05    0.66417E-08    0.17016E-11
+    3    2    0.12275E-05    0.10000E+01    0.15752E+03    0.61677E-05    0.66417E-08    0.17016E-11
+    3    2    0.21419E-05    0.10000E+01    0.80645E+05    0.49107E-52    0.36733E-63    0.66993E-58
+    3    2    0.21419E-05    0.10000E+01    0.65036E+05    0.41537E-51    0.58325E-62    0.56690E-57
+    3    2    0.21419E-05    0.10000E+01    0.52449E+05    0.35289E-50    0.78248E-61    0.48180E-56
+    3    2    0.21419E-05    0.10000E+01    0.42297E+05    0.26516E-49    0.10596E-59    0.36227E-55
+    3    2    0.21419E-05    0.10000E+01    0.34111E+05    0.19074E-48    0.14465E-58    0.26091E-54
+    3    2    0.21419E-05    0.10000E+01    0.27509E+05    0.13632E-47    0.19424E-57    0.18683E-53
+    3    2    0.21419E-05    0.10000E+01    0.22184E+05    0.96365E-47    0.25451E-56    0.13250E-52
+    3    2    0.21419E-05    0.10000E+01    0.17891E+05    0.66774E-46    0.32453E-55    0.92280E-52
+    3    2    0.21419E-05    0.10000E+01    0.14428E+05    0.45141E-45    0.40307E-54    0.62860E-51
+    3    2    0.21419E-05    0.10000E+01    0.11635E+05    0.29731E-44    0.48490E-53    0.41845E-50
+    3    2    0.21419E-05    0.10000E+01    0.93834E+04    0.18995E-43    0.55402E-52    0.27117E-49
+    3    2    0.21419E-05    0.10000E+01    0.75673E+04    0.11620E-42    0.59219E-51    0.16872E-48
+    3    2    0.21419E-05    0.10000E+01    0.61026E+04    0.67465E-42    0.64864E-50    0.98618E-48
+    3    2    0.21419E-05    0.10000E+01    0.49215E+04    0.39522E-41    0.99287E-49    0.54639E-47
+    3    2    0.21419E-05    0.10000E+01    0.39689E+04    0.29086E-40    0.22672E-47    0.33406E-46
+    3    2    0.21419E-05    0.10000E+01    0.32008E+04    0.97707E-38    0.18295E-44    0.93239E-44
+    3    2    0.21419E-05    0.10000E+01    0.25813E+04    0.63353E-29    0.26155E-35    0.56594E-35
+    3    2    0.21419E-05    0.10000E+01    0.20817E+04    0.10329E-12    0.15247E-18    0.88495E-19
+    3    2    0.21419E-05    0.10000E+01    0.16788E+04    0.30062E-07    0.17420E-12    0.23858E-13
+    3    2    0.21419E-05    0.10000E+01    0.13538E+04    0.54086E-07    0.62242E-12    0.37076E-13
+    3    2    0.21419E-05    0.10000E+01    0.10918E+04    0.99536E-07    0.22134E-11    0.59099E-13
+    3    2    0.21419E-05    0.10000E+01    0.88049E+03    0.18505E-06    0.78630E-11    0.95668E-13
+    3    2    0.21419E-05    0.10000E+01    0.71007E+03    0.34526E-06    0.27897E-10    0.15651E-12
+    3    2    0.21419E-05    0.10000E+01    0.57264E+03    0.64446E-06    0.97493E-10    0.25852E-12
+    3    2    0.21419E-05    0.10000E+01    0.46180E+03    0.11999E-05    0.32417E-09    0.43115E-12
+    3    2    0.21419E-05    0.10000E+01    0.37242E+03    0.22124E-05    0.98161E-09    0.72344E-12
+    3    2    0.21419E-05    0.10000E+01    0.30034E+03    0.39859E-05    0.26221E-08    0.12084E-11
+    3    2    0.21419E-05    0.10000E+01    0.24221E+03    0.69019E-05    0.61072E-08    0.19764E-11
+    3    2    0.21419E-05    0.10000E+01    0.19533E+03    0.10762E-04    0.11589E-07    0.29693E-11
+    3    2    0.21419E-05    0.10000E+01    0.15752E+03    0.10762E-04    0.11589E-07    0.29693E-11
+    3    2    0.37375E-05    0.10000E+01    0.80645E+05    0.85689E-52    0.64097E-63    0.11690E-57
+    3    2    0.37375E-05    0.10000E+01    0.65036E+05    0.72479E-51    0.10177E-61    0.98920E-57
+    3    2    0.37375E-05    0.10000E+01    0.52449E+05    0.61577E-50    0.13654E-60    0.84071E-56
+    3    2    0.37375E-05    0.10000E+01    0.42297E+05    0.46269E-49    0.18489E-59    0.63215E-55
+    3    2    0.37375E-05    0.10000E+01    0.34111E+05    0.33282E-48    0.25240E-58    0.45526E-54
+    3    2    0.37375E-05    0.10000E+01    0.27509E+05    0.23786E-47    0.33893E-57    0.32601E-53
+    3    2    0.37375E-05    0.10000E+01    0.22184E+05    0.16815E-46    0.44411E-56    0.23120E-52
+    3    2    0.37375E-05    0.10000E+01    0.17891E+05    0.11652E-45    0.56629E-55    0.16102E-51
+    3    2    0.37375E-05    0.10000E+01    0.14428E+05    0.78768E-45    0.70333E-54    0.10969E-50
+    3    2    0.37375E-05    0.10000E+01    0.11635E+05    0.51879E-44    0.84613E-53    0.73016E-50
+    3    2    0.37375E-05    0.10000E+01    0.93834E+04    0.33145E-43    0.96672E-52    0.47318E-49
+    3    2    0.37375E-05    0.10000E+01    0.75673E+04    0.20276E-42    0.10333E-50    0.29441E-48
+    3    2    0.37375E-05    0.10000E+01    0.61026E+04    0.11772E-41    0.11318E-49    0.17208E-47
+    3    2    0.37375E-05    0.10000E+01    0.49215E+04    0.68963E-41    0.17325E-48    0.95341E-47
+    3    2    0.37375E-05    0.10000E+01    0.39689E+04    0.50753E-40    0.39561E-47    0.58292E-46
+    3    2    0.37375E-05    0.10000E+01    0.32008E+04    0.17049E-37    0.31924E-44    0.16270E-43
+    3    2    0.37375E-05    0.10000E+01    0.25813E+04    0.11055E-28    0.45639E-35    0.98753E-35
+    3    2    0.37375E-05    0.10000E+01    0.20817E+04    0.18024E-12    0.26605E-18    0.15442E-18
+    3    2    0.37375E-05    0.10000E+01    0.16788E+04    0.52456E-07    0.30397E-12    0.41631E-13
+    3    2    0.37375E-05    0.10000E+01    0.13538E+04    0.94376E-07    0.10861E-11    0.64695E-13
+    3    2    0.37375E-05    0.10000E+01    0.10918E+04    0.17368E-06    0.38623E-11    0.10312E-12
+    3    2    0.37375E-05    0.10000E+01    0.88049E+03    0.32291E-06    0.13720E-10    0.16693E-12
+    3    2    0.37375E-05    0.10000E+01    0.71007E+03    0.60246E-06    0.48679E-10    0.27311E-12
+    3    2    0.37375E-05    0.10000E+01    0.57264E+03    0.11245E-05    0.17012E-09    0.45111E-12
+    3    2    0.37375E-05    0.10000E+01    0.46180E+03    0.20937E-05    0.56565E-09    0.75233E-12
+    3    2    0.37375E-05    0.10000E+01    0.37242E+03    0.38605E-05    0.17129E-08    0.12624E-11
+    3    2    0.37375E-05    0.10000E+01    0.30034E+03    0.69551E-05    0.45753E-08    0.21085E-11
+    3    2    0.37375E-05    0.10000E+01    0.24221E+03    0.12043E-04    0.10657E-07    0.34487E-11
+    3    2    0.37375E-05    0.10000E+01    0.19533E+03    0.18780E-04    0.20223E-07    0.51812E-11
+    3    2    0.37375E-05    0.10000E+01    0.15752E+03    0.18780E-04    0.20223E-07    0.51812E-11
+    3    2    0.65217E-05    0.10000E+01    0.80645E+05    0.14952E-51    0.11185E-62    0.20398E-57
+    3    2    0.65217E-05    0.10000E+01    0.65036E+05    0.12647E-50    0.17759E-61    0.17261E-56
+    3    2    0.65217E-05    0.10000E+01    0.52449E+05    0.10745E-49    0.23825E-60    0.14670E-55
+    3    2    0.65217E-05    0.10000E+01    0.42297E+05    0.80737E-49    0.32262E-59    0.11031E-54
+    3    2    0.65217E-05    0.10000E+01    0.34111E+05    0.58076E-48    0.44043E-58    0.79441E-54
+    3    2    0.65217E-05    0.10000E+01    0.27509E+05    0.41506E-47    0.59141E-57    0.56887E-53
+    3    2    0.65217E-05    0.10000E+01    0.22184E+05    0.29341E-46    0.77495E-56    0.40343E-52
+    3    2    0.65217E-05    0.10000E+01    0.17891E+05    0.20332E-45    0.98815E-55    0.28098E-51
+    3    2    0.65217E-05    0.10000E+01    0.14428E+05    0.13744E-44    0.12273E-53    0.19140E-50
+    3    2    0.65217E-05    0.10000E+01    0.11635E+05    0.90526E-44    0.14764E-52    0.12741E-49
+    3    2    0.65217E-05    0.10000E+01    0.93834E+04    0.57836E-43    0.16869E-51    0.82567E-49
+    3    2    0.65217E-05    0.10000E+01    0.75673E+04    0.35380E-42    0.18031E-50    0.51372E-48
+    3    2    0.65217E-05    0.10000E+01    0.61026E+04    0.20542E-41    0.19750E-49    0.30027E-47
+    3    2    0.65217E-05    0.10000E+01    0.49215E+04    0.12034E-40    0.30231E-48    0.16636E-46
+    3    2    0.65217E-05    0.10000E+01    0.39689E+04    0.88561E-40    0.69032E-47    0.10172E-45
+    3    2    0.65217E-05    0.10000E+01    0.32008E+04    0.29750E-37    0.55706E-44    0.28389E-43
+    3    2    0.65217E-05    0.10000E+01    0.25813E+04    0.19290E-28    0.79638E-35    0.17232E-34
+    3    2    0.65217E-05    0.10000E+01    0.20817E+04    0.31450E-12    0.46424E-18    0.26945E-18
+    3    2    0.65217E-05    0.10000E+01    0.16788E+04    0.91532E-07    0.53042E-12    0.72643E-13
+    3    2    0.65217E-05    0.10000E+01    0.13538E+04    0.16468E-06    0.18951E-11    0.11289E-12
+    3    2    0.65217E-05    0.10000E+01    0.10918E+04    0.30307E-06    0.67394E-11    0.17994E-12
+    3    2    0.65217E-05    0.10000E+01    0.88049E+03    0.56346E-06    0.23941E-10    0.29129E-12
+    3    2    0.65217E-05    0.10000E+01    0.71007E+03    0.10513E-05    0.84942E-10    0.47655E-12
+    3    2    0.65217E-05    0.10000E+01    0.57264E+03    0.19623E-05    0.29685E-09    0.78716E-12
+    3    2    0.65217E-05    0.10000E+01    0.46180E+03    0.36534E-05    0.98703E-09    0.13128E-11
+    3    2    0.65217E-05    0.10000E+01    0.37242E+03    0.67364E-05    0.29888E-08    0.22028E-11
+    3    2    0.65217E-05    0.10000E+01    0.30034E+03    0.12136E-04    0.79837E-08    0.36792E-11
+    3    2    0.65217E-05    0.10000E+01    0.24221E+03    0.21015E-04    0.18595E-07    0.60178E-11
+    3    2    0.65217E-05    0.10000E+01    0.19533E+03    0.32769E-04    0.35288E-07    0.90408E-11
+    3    2    0.65217E-05    0.10000E+01    0.15752E+03    0.32769E-04    0.35288E-07    0.90408E-11
+    3    2    0.11380E-04    0.10000E+01    0.80645E+05    0.26091E-51    0.19516E-62    0.35593E-57
+    3    2    0.11380E-04    0.10000E+01    0.65036E+05    0.22069E-50    0.30988E-61    0.30119E-56
+    3    2    0.11380E-04    0.10000E+01    0.52449E+05    0.18749E-49    0.41574E-60    0.25598E-55
+    3    2    0.11380E-04    0.10000E+01    0.42297E+05    0.14088E-48    0.56296E-59    0.19248E-54
+    3    2    0.11380E-04    0.10000E+01    0.34111E+05    0.10134E-47    0.76852E-58    0.13862E-53
+    3    2    0.11380E-04    0.10000E+01    0.27509E+05    0.72425E-47    0.10320E-56    0.99265E-53
+    3    2    0.11380E-04    0.10000E+01    0.22184E+05    0.51199E-46    0.13522E-55    0.70397E-52
+    3    2    0.11380E-04    0.10000E+01    0.17891E+05    0.35477E-45    0.17243E-54    0.49029E-51
+    3    2    0.11380E-04    0.10000E+01    0.14428E+05    0.23983E-44    0.21415E-53    0.33397E-50
+    3    2    0.11380E-04    0.10000E+01    0.11635E+05    0.15796E-43    0.25763E-52    0.22232E-49
+    3    2    0.11380E-04    0.10000E+01    0.93834E+04    0.10092E-42    0.29435E-51    0.14408E-48
+    3    2    0.11380E-04    0.10000E+01    0.75673E+04    0.61735E-42    0.31463E-50    0.89641E-48
+    3    2    0.11380E-04    0.10000E+01    0.61026E+04    0.35844E-41    0.34462E-49    0.52396E-47
+    3    2    0.11380E-04    0.10000E+01    0.49215E+04    0.20998E-40    0.52752E-48    0.29030E-46
+    3    2    0.11380E-04    0.10000E+01    0.39689E+04    0.15453E-39    0.12046E-46    0.17749E-45
+    3    2    0.11380E-04    0.10000E+01    0.32008E+04    0.51912E-37    0.97203E-44    0.49538E-43
+    3    2    0.11380E-04    0.10000E+01    0.25813E+04    0.33659E-28    0.13896E-34    0.30069E-34
+    3    2    0.11380E-04    0.10000E+01    0.20817E+04    0.54879E-12    0.81006E-18    0.47017E-18
+    3    2    0.11380E-04    0.10000E+01    0.16788E+04    0.15972E-06    0.92555E-12    0.12676E-12
+    3    2    0.11380E-04    0.10000E+01    0.13538E+04    0.28736E-06    0.33069E-11    0.19698E-12
+    3    2    0.11380E-04    0.10000E+01    0.10918E+04    0.52884E-06    0.11760E-10    0.31399E-12
+    3    2    0.11380E-04    0.10000E+01    0.88049E+03    0.98320E-06    0.41776E-10    0.50829E-12
+    3    2    0.11380E-04    0.10000E+01    0.71007E+03    0.18344E-05    0.14822E-09    0.83156E-12
+    3    2    0.11380E-04    0.10000E+01    0.57264E+03    0.34240E-05    0.51798E-09    0.13735E-11
+    3    2    0.11380E-04    0.10000E+01    0.46180E+03    0.63750E-05    0.17223E-08    0.22907E-11
+    3    2    0.11380E-04    0.10000E+01    0.37242E+03    0.11755E-04    0.52153E-08    0.38437E-11
+    3    2    0.11380E-04    0.10000E+01    0.30034E+03    0.21177E-04    0.13931E-07    0.64200E-11
+    3    2    0.11380E-04    0.10000E+01    0.24221E+03    0.36670E-04    0.32448E-07    0.10501E-10
+    3    2    0.11380E-04    0.10000E+01    0.19533E+03    0.57180E-04    0.61575E-07    0.15776E-10
+    3    2    0.11380E-04    0.10000E+01    0.15752E+03    0.57180E-04    0.61575E-07    0.15776E-10
+    3    2    0.19857E-04    0.10000E+01    0.80645E+05    0.45526E-51    0.34055E-62    0.62108E-57
+    3    2    0.19857E-04    0.10000E+01    0.65036E+05    0.38508E-50    0.54073E-61    0.52556E-56
+    3    2    0.19857E-04    0.10000E+01    0.52449E+05    0.32716E-49    0.72543E-60    0.44667E-55
+    3    2    0.19857E-04    0.10000E+01    0.42297E+05    0.24583E-48    0.98233E-59    0.33586E-54
+    3    2    0.19857E-04    0.10000E+01    0.34111E+05    0.17683E-47    0.13410E-57    0.24188E-53
+    3    2    0.19857E-04    0.10000E+01    0.27509E+05    0.12638E-46    0.18007E-56    0.17321E-52
+    3    2    0.19857E-04    0.10000E+01    0.22184E+05    0.89339E-46    0.23596E-55    0.12284E-51
+    3    2    0.19857E-04    0.10000E+01    0.17891E+05    0.61906E-45    0.30087E-54    0.85552E-51
+    3    2    0.19857E-04    0.10000E+01    0.14428E+05    0.41849E-44    0.37368E-53    0.58277E-50
+    3    2    0.19857E-04    0.10000E+01    0.11635E+05    0.27564E-43    0.44955E-52    0.38794E-49
+    3    2    0.19857E-04    0.10000E+01    0.93834E+04    0.17610E-42    0.51362E-51    0.25140E-48
+    3    2    0.19857E-04    0.10000E+01    0.75673E+04    0.10772E-41    0.54901E-50    0.15642E-47
+    3    2    0.19857E-04    0.10000E+01    0.61026E+04    0.62546E-41    0.60135E-49    0.91427E-47
+    3    2    0.19857E-04    0.10000E+01    0.49215E+04    0.36640E-40    0.92048E-48    0.50655E-46
+    3    2    0.19857E-04    0.10000E+01    0.39689E+04    0.26965E-39    0.21019E-46    0.30971E-45
+    3    2    0.19857E-04    0.10000E+01    0.32008E+04    0.90583E-37    0.16961E-43    0.86440E-43
+    3    2    0.19857E-04    0.10000E+01    0.25813E+04    0.58733E-28    0.24248E-34    0.52468E-34
+    3    2    0.19857E-04    0.10000E+01    0.20817E+04    0.95760E-12    0.14135E-17    0.82043E-18
+    3    2    0.19857E-04    0.10000E+01    0.16788E+04    0.27870E-06    0.16150E-11    0.22118E-12
+    3    2    0.19857E-04    0.10000E+01    0.13538E+04    0.50142E-06    0.57703E-11    0.34373E-12
+    3    2    0.19857E-04    0.10000E+01    0.10918E+04    0.92279E-06    0.20520E-10    0.54790E-12
+    3    2    0.19857E-04    0.10000E+01    0.88049E+03    0.17156E-05    0.72897E-10    0.88693E-12
+    3    2    0.19857E-04    0.10000E+01    0.71007E+03    0.32009E-05    0.25863E-09    0.14510E-11
+    3    2    0.19857E-04    0.10000E+01    0.57264E+03    0.59747E-05    0.90384E-09    0.23967E-11
+    3    2    0.19857E-04    0.10000E+01    0.46180E+03    0.11124E-04    0.30053E-08    0.39971E-11
+    3    2    0.19857E-04    0.10000E+01    0.37242E+03    0.20511E-04    0.91004E-08    0.67070E-11
+    3    2    0.19857E-04    0.10000E+01    0.30034E+03    0.36953E-04    0.24309E-07    0.11203E-10
+    3    2    0.19857E-04    0.10000E+01    0.24221E+03    0.63987E-04    0.56619E-07    0.18323E-10
+    3    2    0.19857E-04    0.10000E+01    0.19533E+03    0.99776E-04    0.10744E-06    0.27528E-10
+    3    2    0.19857E-04    0.10000E+01    0.15752E+03    0.99776E-04    0.10744E-06    0.27528E-10
+    3    2    0.34650E-04    0.10000E+01    0.80645E+05    0.79441E-51    0.59424E-62    0.10838E-56
+    3    2    0.34650E-04    0.10000E+01    0.65036E+05    0.67195E-50    0.94353E-61    0.91708E-56
+    3    2    0.34650E-04    0.10000E+01    0.52449E+05    0.57087E-49    0.12658E-59    0.77942E-55
+    3    2    0.34650E-04    0.10000E+01    0.42297E+05    0.42896E-48    0.17141E-58    0.58606E-54
+    3    2    0.34650E-04    0.10000E+01    0.34111E+05    0.30856E-47    0.23400E-57    0.42207E-53
+    3    2    0.34650E-04    0.10000E+01    0.27509E+05    0.22052E-46    0.31422E-56    0.30224E-52
+    3    2    0.34650E-04    0.10000E+01    0.22184E+05    0.15589E-45    0.41173E-55    0.21435E-51
+    3    2    0.34650E-04    0.10000E+01    0.17891E+05    0.10802E-44    0.52500E-54    0.14928E-50
+    3    2    0.34650E-04    0.10000E+01    0.14428E+05    0.73025E-44    0.65205E-53    0.10169E-49
+    3    2    0.34650E-04    0.10000E+01    0.11635E+05    0.48097E-43    0.78443E-52    0.67693E-49
+    3    2    0.34650E-04    0.10000E+01    0.93834E+04    0.30728E-42    0.89624E-51    0.43868E-48
+    3    2    0.34650E-04    0.10000E+01    0.75673E+04    0.18797E-41    0.95799E-50    0.27294E-47
+    3    2    0.34650E-04    0.10000E+01    0.61026E+04    0.10914E-40    0.10493E-48    0.15954E-46
+    3    2    0.34650E-04    0.10000E+01    0.49215E+04    0.63935E-40    0.16062E-47    0.88390E-46
+    3    2    0.34650E-04    0.10000E+01    0.39689E+04    0.47053E-39    0.36677E-46    0.54042E-45
+    3    2    0.34650E-04    0.10000E+01    0.32008E+04    0.15806E-36    0.29597E-43    0.15083E-42
+    3    2    0.34650E-04    0.10000E+01    0.25813E+04    0.10249E-27    0.42312E-34    0.91553E-34
+    3    2    0.34650E-04    0.10000E+01    0.20817E+04    0.16710E-11    0.24665E-17    0.14316E-17
+    3    2    0.34650E-04    0.10000E+01    0.16788E+04    0.48631E-06    0.28181E-11    0.38595E-12
+    3    2    0.34650E-04    0.10000E+01    0.13538E+04    0.87495E-06    0.10069E-10    0.59978E-12
+    3    2    0.34650E-04    0.10000E+01    0.10918E+04    0.16102E-05    0.35807E-10    0.95605E-12
+    3    2    0.34650E-04    0.10000E+01    0.88049E+03    0.29937E-05    0.12720E-09    0.15476E-11
+    3    2    0.34650E-04    0.10000E+01    0.71007E+03    0.55854E-05    0.45130E-09    0.25319E-11
+    3    2    0.34650E-04    0.10000E+01    0.57264E+03    0.10425E-04    0.15772E-08    0.41822E-11
+    3    2    0.34650E-04    0.10000E+01    0.46180E+03    0.19411E-04    0.52441E-08    0.69748E-11
+    3    2    0.34650E-04    0.10000E+01    0.37242E+03    0.35790E-04    0.15880E-07    0.11703E-10
+    3    2    0.34650E-04    0.10000E+01    0.30034E+03    0.64480E-04    0.42417E-07    0.19548E-10
+    3    2    0.34650E-04    0.10000E+01    0.24221E+03    0.11165E-03    0.98797E-07    0.31973E-10
+    3    2    0.34650E-04    0.10000E+01    0.19533E+03    0.17410E-03    0.18748E-06    0.48034E-10
+    3    2    0.34650E-04    0.10000E+01    0.15752E+03    0.17410E-03    0.18748E-06    0.48034E-10
+    3    2    0.60462E-04    0.10000E+01    0.80645E+05    0.13862E-50    0.10369E-61    0.18911E-56
+    3    2    0.60462E-04    0.10000E+01    0.65036E+05    0.11725E-49    0.16464E-60    0.16002E-55
+    3    2    0.60462E-04    0.10000E+01    0.52449E+05    0.99613E-49    0.22088E-59    0.13600E-54
+    3    2    0.60462E-04    0.10000E+01    0.42297E+05    0.74850E-48    0.29910E-58    0.10226E-53
+    3    2    0.60462E-04    0.10000E+01    0.34111E+05    0.53841E-47    0.40832E-57    0.73649E-53
+    3    2    0.60462E-04    0.10000E+01    0.27509E+05    0.38480E-46    0.54829E-56    0.52739E-52
+    3    2    0.60462E-04    0.10000E+01    0.22184E+05    0.27202E-45    0.71844E-55    0.37402E-51
+    3    2    0.60462E-04    0.10000E+01    0.17891E+05    0.18849E-44    0.91610E-54    0.26049E-50
+    3    2    0.60462E-04    0.10000E+01    0.14428E+05    0.12742E-43    0.11378E-52    0.17744E-49
+    3    2    0.60462E-04    0.10000E+01    0.11635E+05    0.83926E-43    0.13688E-51    0.11812E-48
+    3    2    0.60462E-04    0.10000E+01    0.93834E+04    0.53619E-42    0.15639E-50    0.76547E-48
+    3    2    0.60462E-04    0.10000E+01    0.75673E+04    0.32800E-41    0.16716E-49    0.47627E-47
+    3    2    0.60462E-04    0.10000E+01    0.61026E+04    0.19044E-40    0.18310E-48    0.27838E-46
+    3    2    0.60462E-04    0.10000E+01    0.49215E+04    0.11156E-39    0.28027E-47    0.15424E-45
+    3    2    0.60462E-04    0.10000E+01    0.39689E+04    0.82104E-39    0.63999E-46    0.94300E-45
+    3    2    0.60462E-04    0.10000E+01    0.32008E+04    0.27581E-36    0.51644E-43    0.26320E-42
+    3    2    0.60462E-04    0.10000E+01    0.25813E+04    0.17883E-27    0.73832E-34    0.15975E-33
+    3    2    0.60462E-04    0.10000E+01    0.20817E+04    0.29157E-11    0.43039E-17    0.24980E-17
+    3    2    0.60462E-04    0.10000E+01    0.16788E+04    0.84859E-06    0.49174E-11    0.67346E-12
+    3    2    0.60462E-04    0.10000E+01    0.13538E+04    0.15267E-05    0.17570E-10    0.10466E-11
+    3    2    0.60462E-04    0.10000E+01    0.10918E+04    0.28097E-05    0.62481E-10    0.16682E-11
+    3    2    0.60462E-04    0.10000E+01    0.88049E+03    0.52237E-05    0.22196E-09    0.27005E-11
+    3    2    0.60462E-04    0.10000E+01    0.71007E+03    0.97461E-05    0.78749E-09    0.44181E-11
+    3    2    0.60462E-04    0.10000E+01    0.57264E+03    0.18192E-04    0.27520E-08    0.72977E-11
+    3    2    0.60462E-04    0.10000E+01    0.46180E+03    0.33871E-04    0.91506E-08    0.12171E-10
+    3    2    0.60462E-04    0.10000E+01    0.37242E+03    0.62452E-04    0.27709E-07    0.20421E-10
+    3    2    0.60462E-04    0.10000E+01    0.30034E+03    0.11251E-03    0.74016E-07    0.34110E-10
+    3    2    0.60462E-04    0.10000E+01    0.24221E+03    0.19483E-03    0.17239E-06    0.55790E-10
+    3    2    0.60462E-04    0.10000E+01    0.19533E+03    0.30380E-03    0.32715E-06    0.83817E-10
+    3    2    0.60462E-04    0.10000E+01    0.15752E+03    0.30380E-03    0.32715E-06    0.83817E-10
+    3    2    0.10550E-03    0.10000E+01    0.80645E+05    0.24188E-50    0.18093E-61    0.32998E-56
+    3    2    0.10550E-03    0.10000E+01    0.65036E+05    0.20460E-49    0.28729E-60    0.27923E-55
+    3    2    0.10550E-03    0.10000E+01    0.52449E+05    0.17382E-48    0.38542E-59    0.23732E-54
+    3    2    0.10550E-03    0.10000E+01    0.42297E+05    0.13061E-47    0.52191E-58    0.17844E-53
+    3    2    0.10550E-03    0.10000E+01    0.34111E+05    0.93950E-47    0.71249E-57    0.12851E-52
+    3    2    0.10550E-03    0.10000E+01    0.27509E+05    0.67145E-46    0.95673E-56    0.92027E-52
+    3    2    0.10550E-03    0.10000E+01    0.22184E+05    0.47466E-45    0.12536E-54    0.65264E-51
+    3    2    0.10550E-03    0.10000E+01    0.17891E+05    0.32891E-44    0.15985E-53    0.45454E-50
+    3    2    0.10550E-03    0.10000E+01    0.14428E+05    0.22235E-43    0.19854E-52    0.30962E-49
+    3    2    0.10550E-03    0.10000E+01    0.11635E+05    0.14645E-42    0.23885E-51    0.20611E-48
+    3    2    0.10550E-03    0.10000E+01    0.93834E+04    0.93562E-42    0.27289E-50    0.13357E-47
+    3    2    0.10550E-03    0.10000E+01    0.75673E+04    0.57234E-41    0.29169E-49    0.83105E-47
+    3    2    0.10550E-03    0.10000E+01    0.61026E+04    0.33231E-40    0.31950E-48    0.48576E-46
+    3    2    0.10550E-03    0.10000E+01    0.49215E+04    0.19467E-39    0.48905E-47    0.26913E-45
+    3    2    0.10550E-03    0.10000E+01    0.39689E+04    0.14327E-38    0.11167E-45    0.16455E-44
+    3    2    0.10550E-03    0.10000E+01    0.32008E+04    0.48127E-36    0.90116E-43    0.45926E-42
+    3    2    0.10550E-03    0.10000E+01    0.25813E+04    0.31205E-27    0.12883E-33    0.27876E-33
+    3    2    0.10550E-03    0.10000E+01    0.20817E+04    0.50878E-11    0.75100E-17    0.43589E-17
+    3    2    0.10550E-03    0.10000E+01    0.16788E+04    0.14807E-05    0.85806E-11    0.11752E-11
+    3    2    0.10550E-03    0.10000E+01    0.13538E+04    0.26641E-05    0.30658E-10    0.18262E-11
+    3    2    0.10550E-03    0.10000E+01    0.10918E+04    0.49028E-05    0.10902E-09    0.29110E-11
+    3    2    0.10550E-03    0.10000E+01    0.88049E+03    0.91151E-05    0.38730E-09    0.47123E-11
+    3    2    0.10550E-03    0.10000E+01    0.71007E+03    0.17006E-04    0.13741E-08    0.77093E-11
+    3    2    0.10550E-03    0.10000E+01    0.57264E+03    0.31744E-04    0.48021E-08    0.12734E-10
+    3    2    0.10550E-03    0.10000E+01    0.46180E+03    0.59102E-04    0.15967E-07    0.21237E-10
+    3    2    0.10550E-03    0.10000E+01    0.37242E+03    0.10898E-03    0.48351E-07    0.35634E-10
+    3    2    0.10550E-03    0.10000E+01    0.30034E+03    0.19633E-03    0.12915E-06    0.59520E-10
+    3    2    0.10550E-03    0.10000E+01    0.24221E+03    0.33996E-03    0.30082E-06    0.97350E-10
+    3    2    0.10550E-03    0.10000E+01    0.19533E+03    0.53011E-03    0.57085E-06    0.14625E-09
+    3    2    0.10550E-03    0.10000E+01    0.15752E+03    0.53011E-03    0.57085E-06    0.14625E-09
+    3    2    0.18409E-03    0.10000E+01    0.80645E+05    0.42207E-50    0.31572E-61    0.57580E-56
+    3    2    0.18409E-03    0.10000E+01    0.65036E+05    0.35701E-49    0.50130E-60    0.48725E-55
+    3    2    0.18409E-03    0.10000E+01    0.52449E+05    0.30330E-48    0.67254E-59    0.41411E-54
+    3    2    0.18409E-03    0.10000E+01    0.42297E+05    0.22791E-47    0.91071E-58    0.31137E-53
+    3    2    0.18409E-03    0.10000E+01    0.34111E+05    0.16394E-46    0.12432E-56    0.22425E-52
+    3    2    0.18409E-03    0.10000E+01    0.27509E+05    0.11716E-45    0.16694E-55    0.16058E-51
+    3    2    0.18409E-03    0.10000E+01    0.22184E+05    0.82825E-45    0.21875E-54    0.11388E-50
+    3    2    0.18409E-03    0.10000E+01    0.17891E+05    0.57392E-44    0.27894E-53    0.79314E-50
+    3    2    0.18409E-03    0.10000E+01    0.14428E+05    0.38798E-43    0.34644E-52    0.54028E-49
+    3    2    0.18409E-03    0.10000E+01    0.11635E+05    0.25554E-42    0.41677E-51    0.35965E-48
+    3    2    0.18409E-03    0.10000E+01    0.93834E+04    0.16326E-41    0.47617E-50    0.23307E-47
+    3    2    0.18409E-03    0.10000E+01    0.75673E+04    0.99870E-41    0.50898E-49    0.14501E-46
+    3    2    0.18409E-03    0.10000E+01    0.61026E+04    0.57986E-40    0.55750E-48    0.84761E-46
+    3    2    0.18409E-03    0.10000E+01    0.49215E+04    0.33969E-39    0.85337E-47    0.46962E-45
+    3    2    0.18409E-03    0.10000E+01    0.39689E+04    0.24999E-38    0.19486E-45    0.28712E-44
+    3    2    0.18409E-03    0.10000E+01    0.32008E+04    0.83979E-36    0.15725E-42    0.80138E-42
+    3    2    0.18409E-03    0.10000E+01    0.25813E+04    0.54451E-27    0.22480E-33    0.48642E-33
+    3    2    0.18409E-03    0.10000E+01    0.20817E+04    0.88778E-11    0.13105E-16    0.76061E-17
+    3    2    0.18409E-03    0.10000E+01    0.16788E+04    0.25838E-05    0.14973E-10    0.20506E-11
+    3    2    0.18409E-03    0.10000E+01    0.13538E+04    0.46486E-05    0.53496E-10    0.31867E-11
+    3    2    0.18409E-03    0.10000E+01    0.10918E+04    0.85551E-05    0.19024E-09    0.50795E-11
+    3    2    0.18409E-03    0.10000E+01    0.88049E+03    0.15905E-04    0.67582E-09    0.82226E-11
+    3    2    0.18409E-03    0.10000E+01    0.71007E+03    0.29675E-04    0.23978E-08    0.13452E-10
+    3    2    0.18409E-03    0.10000E+01    0.57264E+03    0.55391E-04    0.83794E-08    0.22220E-10
+    3    2    0.18409E-03    0.10000E+01    0.46180E+03    0.10313E-03    0.27862E-07    0.37057E-10
+    3    2    0.18409E-03    0.10000E+01    0.37242E+03    0.19015E-03    0.84369E-07    0.62180E-10
+    3    2    0.18409E-03    0.10000E+01    0.30034E+03    0.34258E-03    0.22536E-06    0.10386E-09
+    3    2    0.18409E-03    0.10000E+01    0.24221E+03    0.59322E-03    0.52491E-06    0.16987E-09
+    3    2    0.18409E-03    0.10000E+01    0.19533E+03    0.92501E-03    0.99611E-06    0.25521E-09
+    3    2    0.18409E-03    0.10000E+01    0.15752E+03    0.92501E-03    0.99611E-06    0.25521E-09
+    3    2    0.32123E-03    0.10000E+01    0.80645E+05    0.73649E-50    0.55091E-61    0.10047E-55
+    3    2    0.32123E-03    0.10000E+01    0.65036E+05    0.62296E-49    0.87474E-60    0.85021E-55
+    3    2    0.32123E-03    0.10000E+01    0.52449E+05    0.52925E-48    0.11735E-58    0.72259E-54
+    3    2    0.32123E-03    0.10000E+01    0.42297E+05    0.39768E-47    0.15891E-57    0.54333E-53
+    3    2    0.32123E-03    0.10000E+01    0.34111E+05    0.28606E-46    0.21694E-56    0.39130E-52
+    3    2    0.32123E-03    0.10000E+01    0.27509E+05    0.20444E-45    0.29131E-55    0.28021E-51
+    3    2    0.32123E-03    0.10000E+01    0.22184E+05    0.14453E-44    0.38171E-54    0.19872E-50
+    3    2    0.32123E-03    0.10000E+01    0.17891E+05    0.10015E-43    0.48673E-53    0.13840E-49
+    3    2    0.32123E-03    0.10000E+01    0.14428E+05    0.67700E-43    0.60451E-52    0.94275E-49
+    3    2    0.32123E-03    0.10000E+01    0.11635E+05    0.44590E-42    0.72724E-51    0.62757E-48
+    3    2    0.32123E-03    0.10000E+01    0.93834E+04    0.28488E-41    0.83089E-50    0.40670E-47
+    3    2    0.32123E-03    0.10000E+01    0.75673E+04    0.17427E-40    0.88814E-49    0.25304E-46
+    3    2    0.32123E-03    0.10000E+01    0.61026E+04    0.10118E-39    0.97281E-48    0.14790E-45
+    3    2    0.32123E-03    0.10000E+01    0.49215E+04    0.59274E-39    0.14891E-46    0.81945E-45
+    3    2    0.32123E-03    0.10000E+01    0.39689E+04    0.43622E-38    0.34003E-45    0.50101E-44
+    3    2    0.32123E-03    0.10000E+01    0.32008E+04    0.14654E-35    0.27439E-42    0.13984E-41
+    3    2    0.32123E-03    0.10000E+01    0.25813E+04    0.95014E-27    0.39227E-33    0.84878E-33
+    3    2    0.32123E-03    0.10000E+01    0.20817E+04    0.15491E-10    0.22867E-16    0.13272E-16
+    3    2    0.32123E-03    0.10000E+01    0.16788E+04    0.45086E-05    0.26126E-10    0.35781E-11
+    3    2    0.32123E-03    0.10000E+01    0.13538E+04    0.81116E-05    0.93348E-10    0.55605E-11
+    3    2    0.32123E-03    0.10000E+01    0.10918E+04    0.14928E-04    0.33196E-09    0.88634E-11
+    3    2    0.32123E-03    0.10000E+01    0.88049E+03    0.27754E-04    0.11793E-08    0.14348E-10
+    3    2    0.32123E-03    0.10000E+01    0.71007E+03    0.51781E-04    0.41840E-08    0.23473E-10
+    3    2    0.32123E-03    0.10000E+01    0.57264E+03    0.96654E-04    0.14622E-07    0.38773E-10
+    3    2    0.32123E-03    0.10000E+01    0.46180E+03    0.17996E-03    0.48617E-07    0.64662E-10
+    3    2    0.32123E-03    0.10000E+01    0.37242E+03    0.33181E-03    0.14722E-06    0.10850E-09
+    3    2    0.32123E-03    0.10000E+01    0.30034E+03    0.59779E-03    0.39325E-06    0.18123E-09
+    3    2    0.32123E-03    0.10000E+01    0.24221E+03    0.10351E-02    0.91594E-06    0.29641E-09
+    3    2    0.32123E-03    0.10000E+01    0.19533E+03    0.16141E-02    0.17381E-05    0.44532E-09
+    3    2    0.32123E-03    0.10000E+01    0.15752E+03    0.16141E-02    0.17381E-05    0.44532E-09
+    3    3    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.15049E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    3    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.26259E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    3    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.45820E-08    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    3    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.79953E-08    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    3    3    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.13951E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    3    3    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.24344E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    3    3    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.42479E-07    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    3    3    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.74124E-07    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    3    3    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.12934E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    3    3    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.22569E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    3    3    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.39382E-06    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    3    3    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.68720E-06    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    3    3    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.11991E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    3    3    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.20924E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    3    3    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.36511E-05    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    3    3    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.63709E-05    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    3    3    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.11117E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    3    3    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.19398E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    3    3    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.33849E-04    0.28490E+06    0.11866E-26    0.49925E-13    0.35071E-04    0.89947E+03
+    3    3    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.59064E-04    0.23629E+06    0.35027E-26    0.22598E-11    0.42127E-04    0.89631E+03
+    3    3    0.31275E-10    0.10000E+01    0.48387E-01    0.94692E-01    0.50540E-10    0.53972E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.10306E-03    0.19496E+06    0.99447E-26    0.48792E-10    0.50499E-04    0.88379E+03
+    3    3    0.54572E-10    0.10000E+01    0.74087E-01    0.13932E+00    0.11222E-09    0.65489E-11    0.40384E-04    0.29225E-04    0.98516E+04    0.17984E-03    0.15940E+06    0.27013E-25    0.58246E-09    0.60484E-04    0.85041E+03
+    3    3    0.95225E-10    0.10000E+01    0.11727E+00    0.19685E+00    0.21124E-09    0.51414E-10    0.44016E-04    0.37956E-04    0.17190E+05    0.31381E-03    0.12765E+06    0.72701E-25    0.44751E-08    0.73437E-04    0.78189E+03
+    3    3    0.16616E-09    0.10000E+01    0.17968E+00    0.25727E+00    0.32506E-09    0.27162E-09    0.45014E-04    0.47501E-04    0.29996E+05    0.54758E-03    0.99726E+05    0.20520E-24    0.22993E-07    0.91909E-04    0.67266E+03
+    3    3    0.28994E-09    0.10000E+01    0.24446E+00    0.30169E+00    0.45318E-09    0.97942E-09    0.47015E-04    0.50177E-04    0.52341E+05    0.95549E-03    0.77007E+05    0.65991E-24    0.79221E-07    0.11945E-03    0.54636E+03
+    3    3    0.50593E-09    0.10000E+01    0.28919E+00    0.33435E+00    0.73151E-09    0.25636E-08    0.56977E-04    0.47031E-04    0.91333E+05    0.16673E-02    0.60555E+05    0.23332E-23    0.19005E-06    0.15624E-03    0.45116E+03
+    3    3    0.88282E-09    0.10000E+01    0.32019E+00    0.38630E+00    0.15269E-08    0.55362E-08    0.75761E-04    0.46436E-04    0.15937E+06    0.29093E-02    0.48871E+05    0.79654E-23    0.35942E-06    0.19889E-03    0.40105E+03
+    3    3    0.15405E-08    0.10000E+01    0.35672E+00    0.46894E+00    0.35360E-08    0.10874E-07    0.10056E-03    0.49843E-04    0.27809E+06    0.50765E-02    0.40062E+05    0.25120E-22    0.59942E-06    0.24588E-03    0.37889E+03
+    3    3    0.26880E-08    0.10000E+01    0.41240E+00    0.59091E+00    0.80145E-08    0.20452E-07    0.12703E-03    0.57419E-04    0.46469E+06    0.87395E-02    0.29637E+05    0.78315E-22    0.92603E-06    0.30429E-03    0.36587E+03
+    3    3    0.46905E-08    0.10000E+01    0.37203E+00    0.10524E+01    0.27266E-07    0.39895E-07    0.10861E-03    0.87340E-04    0.20736E+06    0.94906E-02    0.53411E+04    0.67527E-21    0.10798E-05    0.60016E-03    0.27069E+03
+    3    3    0.81846E-08    0.10000E+01    0.46549E+00    0.12133E+01    0.47587E-07    0.72138E-07    0.13463E-03    0.99182E-04    0.36184E+06    0.16560E-01    0.41190E+04    0.18484E-20    0.16682E-05    0.75192E-03    0.23079E+03
+    3    3    0.14282E-07    0.10000E+01    0.57956E+00    0.13842E+01    0.81897E-07    0.13004E-06    0.16674E-03    0.11198E-03    0.63138E+06    0.28897E-01    0.31436E+04    0.52156E-20    0.25655E-05    0.95990E-03    0.19041E+03
+    3    3    0.24920E-07    0.10000E+01    0.71436E+00    0.15620E+01    0.13820E-06    0.23399E-06    0.20579E-03    0.12528E-03    0.11017E+07    0.50424E-01    0.23744E+04    0.15179E-19    0.39363E-05    0.12487E-02    0.15190E+03
+    3    3    0.43485E-07    0.10000E+01    0.86546E+00    0.17387E+01    0.23011E-06    0.42016E-06    0.25461E-03    0.13827E-03    0.19224E+07    0.87986E-01    0.17842E+04    0.45022E-19    0.60490E-05    0.16444E-02    0.11792E+03
+    3    3    0.75878E-07    0.10000E+01    0.10279E+01    0.19082E+01    0.37909E-06    0.75278E-06    0.31706E-03    0.15032E-03    0.33546E+07    0.15353E+00    0.13371E+04    0.13498E-18    0.93277E-05    0.21814E-02    0.89635E+02
+    3    3    0.13240E-06    0.10000E+01    0.11981E+01    0.20679E+01    0.61533E-06    0.13459E-05    0.39732E-03    0.16113E-03    0.58535E+07    0.26790E+00    0.99822E+03    0.40905E-18    0.14425E-04    0.29132E-02    0.66923E+02
+    3    3    0.23103E-06    0.10000E+01    0.13688E+01    0.22128E+01    0.99472E-06    0.24001E-05    0.50429E-03    0.17039E-03    0.10214E+08    0.46747E+00    0.74618E+03    0.12379E-17    0.22409E-04    0.38909E-02    0.49529E+02
+    3    3    0.40314E-06    0.10000E+01    0.15387E+01    0.23441E+01    0.15864E-05    0.42670E-05    0.64521E-03    0.17825E-03    0.17823E+08    0.81571E+00    0.55633E+03    0.37308E-17    0.34865E-04    0.52001E-02    0.36331E+02
+    3    3    0.70346E-06    0.10000E+01    0.15991E+01    0.23877E+01    0.38064E-05    0.74834E-05    0.10080E-02    0.18076E-03    0.31100E+08    0.14234E+01    0.50000E+03    0.78683E-17    0.58350E-04    0.57630E-02    0.32451E+02
+    3    3    0.12275E-05    0.10000E+01    0.15991E+01    0.23877E+01    0.11590E-04    0.13058E-04    0.17590E-02    0.18076E-03    0.54267E+08    0.24837E+01    0.50000E+03    0.13730E-16    0.10182E-03    0.57630E-02    0.32451E+02
+    3    3    0.21419E-05    0.10000E+01    0.15991E+01    0.23877E+01    0.35289E-04    0.22786E-04    0.30693E-02    0.18076E-03    0.94693E+08    0.43339E+01    0.50000E+03    0.23957E-16    0.17767E-03    0.57630E-02    0.32451E+02
+    3    3    0.37375E-05    0.10000E+01    0.15991E+01    0.23877E+01    0.10745E-03    0.39759E-04    0.53558E-02    0.18076E-03    0.16523E+09    0.75624E+01    0.50000E+03    0.41804E-16    0.31002E-03    0.57630E-02    0.32451E+02
+    3    3    0.65217E-05    0.10000E+01    0.15991E+01    0.23877E+01    0.32716E-03    0.69378E-04    0.93455E-02    0.18076E-03    0.28832E+09    0.13196E+02    0.50000E+03    0.72946E-16    0.54096E-03    0.57630E-02    0.32451E+02
+    3    3    0.11380E-04    0.10000E+01    0.15991E+01    0.23877E+01    0.99613E-03    0.12106E-03    0.16307E-01    0.18076E-03    0.50310E+09    0.23026E+02    0.50000E+03    0.12729E-15    0.94394E-03    0.57630E-02    0.32451E+02
+    3    3    0.19857E-04    0.10000E+01    0.15991E+01    0.23877E+01    0.30330E-02    0.21124E-03    0.28455E-01    0.18076E-03    0.87789E+09    0.40179E+02    0.50000E+03    0.22211E-15    0.16471E-02    0.57630E-02    0.32451E+02
+    3    3    0.34650E-04    0.10000E+01    0.15991E+01    0.23877E+01    0.92350E-02    0.36861E-03    0.49653E-01    0.18076E-03    0.15319E+10    0.70110E+02    0.50000E+03    0.38756E-15    0.28741E-02    0.57630E-02    0.32451E+02
+    3    3    0.60462E-04    0.10000E+01    0.15991E+01    0.23877E+01    0.28119E-01    0.64319E-03    0.86641E-01    0.18076E-03    0.26730E+10    0.12234E+03    0.50000E+03    0.67627E-15    0.50152E-02    0.57630E-02    0.32451E+02
+    3    3    0.10550E-03    0.10000E+01    0.15991E+01    0.23877E+01    0.85617E-01    0.11223E-02    0.15118E+00    0.18076E-03    0.46642E+10    0.21347E+03    0.50000E+03    0.11801E-14    0.87512E-02    0.57630E-02    0.32451E+02
+    3    3    0.18409E-03    0.10000E+01    0.15991E+01    0.23877E+01    0.26069E+00    0.19584E-02    0.26381E+00    0.18076E-03    0.81388E+10    0.37249E+03    0.50000E+03    0.20591E-14    0.15270E-01    0.57630E-02    0.32451E+02
+    3    3    0.32123E-03    0.10000E+01    0.15991E+01    0.23877E+01    0.79375E+00    0.34173E-02    0.46033E+00    0.18076E-03    0.14202E+11    0.64998E+03    0.50000E+03    0.35931E-14    0.26646E-01    0.57630E-02    0.32451E+02
+    3    3    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    3    3    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    3    3    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    3    3    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    3    3    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    3    3    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    3    3    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    3    3    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    3    3    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    3    3    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    3    3    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    3    3    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    3    3    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    3    3    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    3    3    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    3    3    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    3    3    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    3    3    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    3    3    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    3    3    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    3    3    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    3    3    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    3    3    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    3    3    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    3    3    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    3    3    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    3    3    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    3    3    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    3    3    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    3    3    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    3    3    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    3    3    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    3    3    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    3    3    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    3    3    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    3    3    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    3    3    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    3    3    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    3    3    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    3    3    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    3    3    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    3    3    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    3    3    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    3    3    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    3    3    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    3    3    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    3    3    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    3    3    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    3    3    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    3    3    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    3    3    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    3    3    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    3    3    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    3    3    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    3    3    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    3    3    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    3    3    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    3    3    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    3    3    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    3    3    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    3    3    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    3    3    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    3    3    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    3    3    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    3    3    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    3    3    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    3    3    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    3    3    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    3    3    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    3    3    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    3    3    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    3    3    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    3    3    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    3    3    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    3    3    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    3    3    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    3    3    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    3    3    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    3    3    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    3    3    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    3    3    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    3    3    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    3    3    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    3    3    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    3    3    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    3    3    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    3    3    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    3    3    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    3    3    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    3    3    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    3    3    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    3    3    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    3    3    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    3    3    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    3    3    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    3    3    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    3    3    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    3    3    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    3    3    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    3    3    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    3    3    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    3    3    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    3    3    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    3    3    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    3    3    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    3    3    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    3    3    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    3    3    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    3    3    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    3    3    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    3    3    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    3    3    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    3    3    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    3    3    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    3    3    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    3    3    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    3    3    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    3    3    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    3    3    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    3    3    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    3    3    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    3    3    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    3    3    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    3    3    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    3    3    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    3    3    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    3    3    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    3    3    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    3    3    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    3    3    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    3    3    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    3    3    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    3    3    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    3    3    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    3    3    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    3    3    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    3    3    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    3    3    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    3    3    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    3    3    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    3    3    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    3    3    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    3    3    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    3    3    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    3    3    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    3    3    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    3    3    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    3    3    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    3    3    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    3    3    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    3    3    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    3    3    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    3    3    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    3    3    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    3    3    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    3    3    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    3    3    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    3    3    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    3    3    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    3    3    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    3    3    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    3    3    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    3    3    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    3    3    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    3    3    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    3    3    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    3    3    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    3    3    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    3    3    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    3    3    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    3    3    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    3    3    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    3    3    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    3    3    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    3    3    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    3    3    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    3    3    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    3    3    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    3    3    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    3    3    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    3    3    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    3    3    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    3    3    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    3    3    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    3    3    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    3    3    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    3    3    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    3    3    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    3    3    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    3    3    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    3    3    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    3    3    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    3    3    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    3    3    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    3    3    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    3    3    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    3    3    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    3    3    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    3    3    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    3    3    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    3    3    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    3    3    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    3    3    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    3    3    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    3    3    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    3    3    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    3    3    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    3    3    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    3    3    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    3    3    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    3    3    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    3    3    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    3    3    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    3    3    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    3    3    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    3    3    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    3    3    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    3    3    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    3    3    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    3    3    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    3    3    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    3    3    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    3    3    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    3    3    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    3    3    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    3    3    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    3    3    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    3    3    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    3    3    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    3    3    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    3    3    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    3    3    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    3    3    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    3    3    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    3    3    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    3    3    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    3    3    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    3    3    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    3    3    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    3    3    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    3    3    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    3    3    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    3    3    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    3    3    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    3    3    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    3    3    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    3    3    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    3    3    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    3    3    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    3    3    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    3    3    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    3    3    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    3    3    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    3    3    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    3    3    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    3    3    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    3    3    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    3    3    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    3    3    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    3    3    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    3    3    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    3    3    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    3    3    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    3    3    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    3    3    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    3    3    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    3    3    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    3    3    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    3    3    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    3    3    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    3    3    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    3    3    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    3    3    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    3    3    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    3    3    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    3    3    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    3    3    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    3    3    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    3    3    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    3    3    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    3    3    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    3    3    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    3    3    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    3    3    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    3    3    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    3    3    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    3    3    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    3    3    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    3    3    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    3    3    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    3    3    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    3    3    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    3    3    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    3    3    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    3    3    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    3    3    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    3    3    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    3    3    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    3    3    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    3    3    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    3    3    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    3    3    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    3    3    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    3    3    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    3    3    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    3    3    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    3    3    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    3    3    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    3    3    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    3    3    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    3    3    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    3    3    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    3    3    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    3    3    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    3    3    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    3    3    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    3    3    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    3    3    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    3    3    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    3    3    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    3    3    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    3    3    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    3    3    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    3    3    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    3    3    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    3    3    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    3    3    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    3    3    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    3    3    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    3    3    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    3    3    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    3    3    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    3    3    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    3    3    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    3    3    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    3    3    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    3    3    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    3    3    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    3    3    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    3    3    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    3    3    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    3    3    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    3    3    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    3    3    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    3    3    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    3    3    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    3    3    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    3    3    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    3    3    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    3    3    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    3    3    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    3    3    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    3    3    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    3    3    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    3    3    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    3    3    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    3    3    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    3    3    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    3    3    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    3    3    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    3    3    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    3    3    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    3    3    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    3    3    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    3    3    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    3    3    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    3    3    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    3    3    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    3    3    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    3    3    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    3    3    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    3    3    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    3    3    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    3    3    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    3    3    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    3    3    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    3    3    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    3    3    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    3    3    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    3    3    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    3    3    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    3    3    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    3    3    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    3    3    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    3    3    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    3    3    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    3    3    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    3    3    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    3    3    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    3    3    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    3    3    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    3    3    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    3    3    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    3    3    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    3    3    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    3    3    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    3    3    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    3    3    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    3    3    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    3    3    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    3    3    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    3    3    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    3    3    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    3    3    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    3    3    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    3    3    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    3    3    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    3    3    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    3    3    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    3    3    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    3    3    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    3    3    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    3    3    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    3    3    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    3    3    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    3    3    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    3    3    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    3    3    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    3    3    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    3    3    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    3    3    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    3    3    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    3    3    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    3    3    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    3    3    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    3    3    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    3    3    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    3    3    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    3    3    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    3    3    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    3    3    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    3    3    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    3    3    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    3    3    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    3    3    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    3    3    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    3    3    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    3    3    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    3    3    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    3    3    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    3    3    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    3    3    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    3    3    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    3    3    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    3    3    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    3    3    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    3    3    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    3    3    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    3    3    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    3    3    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    3    3    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    3    3    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    3    3    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    3    3    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    3    3    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    3    3    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    3    3    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    3    3    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    3    3    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    3    3    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    3    3    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    3    3    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    3    3    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    3    3    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    3    3    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    3    3    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    3    3    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    3    3    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    3    3    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    3    3    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    3    3    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    3    3    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    3    3    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    3    3    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    3    3    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    3    3    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    3    3    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    3    3    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    3    3    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    3    3    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    3    3    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    3    3    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    3    3    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    3    3    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    3    3    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    3    3    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    3    3    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    3    3    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    3    3    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    3    3    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    3    3    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    3    3    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    3    3    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    3    3    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    3    3    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    3    3    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    3    3    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    3    3    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    3    3    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    3    3    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    3    3    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    3    3    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    3    3    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    3    3    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    3    3    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    3    3    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    3    3    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    3    3    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    3    3    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    3    3    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    3    3    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    3    3    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    3    3    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    3    3    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    3    3    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    3    3    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    3    3    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    3    3    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    3    3    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    3    3    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    3    3    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    3    3    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    3    3    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    3    3    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    3    3    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    3    3    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    3    3    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    3    3    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    3    3    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    3    3    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    3    3    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    3    3    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    3    3    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    3    3    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    3    3    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    3    3    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    3    3    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    3    3    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    3    3    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    3    3    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    3    3    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    3    3    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    3    3    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    3    3    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    3    3    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    3    3    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    3    3    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    3    3    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    3    3    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    3    3    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    3    3    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    3    3    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    3    3    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    3    3    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    3    3    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    3    3    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    3    3    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    3    3    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    3    3    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    3    3    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    3    3    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    3    3    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    3    3    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    3    3    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    3    3    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    3    3    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    3    3    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    3    3    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    3    3    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    3    3    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    3    3    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    3    3    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    3    3    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    3    3    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    3    3    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    3    3    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    3    3    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    3    3    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    3    3    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    3    3    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    3    3    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    3    3    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    3    3    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    3    3    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    3    3    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    3    3    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    3    3    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    3    3    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    3    3    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    3    3    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    3    3    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    3    3    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    3    3    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    3    3    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    3    3    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    3    3    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    3    3    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    3    3    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    3    3    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    3    3    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    3    3    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    3    3    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98307E-67
+    3    3    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    3    3    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85108E-65    0.66902E-65
+    3    3    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    3    3    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    3    3    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    3    3    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    3    3    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    3    3    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    3    3    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    3    3    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    3    3    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    3    3    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    3    3    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    3    3    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    3    3    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    3    3    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    3    3    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    3    3    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    3    3    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    3    3    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    3    3    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    3    3    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    3    3    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    3    3    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    3    3    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    3    3    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    3    3    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    3    3    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    3    3    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35535E-67
+    3    3    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31828E-67    0.31058E-66
+    3    3    0.54572E-10    0.10000E+01    0.52449E+05    0.19287E-55    0.49297E-66    0.26765E-65
+    3    3    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20669E-64
+    3    3    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16351E-63
+    3    3    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91025E-62    0.15327E-62
+    3    3    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    3    3    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30487E-60
+    3    3    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49480E-59
+    3    3    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69358E-56    0.76350E-58
+    3    3    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    3    3    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16342E-55
+    3    3    0.54572E-10    0.10000E+01    0.61026E+04    0.45398E-44    0.13637E-51    0.23452E-54
+    3    3    0.54572E-10    0.10000E+01    0.49215E+04    0.64182E-43    0.36731E-50    0.33513E-53
+    3    3    0.54572E-10    0.10000E+01    0.39689E+04    0.90672E-42    0.98863E-49    0.47755E-52
+    3    3    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86006E-46    0.21355E-49
+    3    3    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    3    3    0.54572E-10    0.10000E+01    0.20817E+04    0.56405E-14    0.12317E-19    0.30298E-24
+    3    3    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    3    3    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    3    3    0.54572E-10    0.10000E+01    0.10918E+04    0.86135E-08    0.25791E-12    0.46561E-18
+    3    3    0.54572E-10    0.10000E+01    0.88049E+03    0.17704E-07    0.94961E-12    0.95771E-18
+    3    3    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19314E-17
+    3    3    0.54572E-10    0.10000E+01    0.57264E+03    0.70728E-07    0.12303E-10    0.38292E-17
+    3    3    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    3    3    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    3    3    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33842E-09    0.26330E-16
+    3    3    0.54572E-10    0.10000E+01    0.24221E+03    0.85647E-06    0.79019E-09    0.46390E-16
+    3    3    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    3    3    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    3    3    0.95225E-10    0.10000E+01    0.80645E+05    0.53357E-57    0.41261E-68    0.10807E-66
+    3    3    0.95225E-10    0.10000E+01    0.65036E+05    0.46332E-56    0.66253E-67    0.94594E-66
+    3    3    0.95225E-10    0.10000E+01    0.52449E+05    0.40031E-55    0.93503E-66    0.81771E-65
+    3    3    0.95225E-10    0.10000E+01    0.42297E+05    0.31522E-54    0.15118E-64    0.62704E-64
+    3    3    0.95225E-10    0.10000E+01    0.34111E+05    0.26474E-53    0.31089E-63    0.46565E-63
+    3    3    0.95225E-10    0.10000E+01    0.27509E+05    0.27520E-52    0.84235E-62    0.36223E-62
+    3    3    0.95225E-10    0.10000E+01    0.22184E+05    0.37534E-51    0.26554E-60    0.35016E-61
+    3    3    0.95225E-10    0.10000E+01    0.17891E+05    0.59944E-50    0.82063E-59    0.47894E-60
+    3    3    0.95225E-10    0.10000E+01    0.14428E+05    0.96010E-49    0.23742E-57    0.76773E-59
+    3    3    0.95225E-10    0.10000E+01    0.11635E+05    0.14618E-47    0.65924E-56    0.12117E-57
+    3    3    0.95225E-10    0.10000E+01    0.93834E+04    0.21405E-46    0.18019E-54    0.18315E-56
+    3    3    0.95225E-10    0.10000E+01    0.75673E+04    0.30774E-45    0.48998E-53    0.26960E-55
+    3    3    0.95225E-10    0.10000E+01    0.61026E+04    0.43932E-44    0.13291E-51    0.39168E-54
+    3    3    0.95225E-10    0.10000E+01    0.49215E+04    0.62522E-43    0.35987E-50    0.56494E-53
+    3    3    0.95225E-10    0.10000E+01    0.39689E+04    0.88798E-42    0.97272E-49    0.81081E-52
+    3    3    0.95225E-10    0.10000E+01    0.32008E+04    0.39602E-39    0.84927E-46    0.36466E-49
+    3    3    0.95225E-10    0.10000E+01    0.25813E+04    0.29202E-30    0.14349E-36    0.27087E-40
+    3    3    0.95225E-10    0.10000E+01    0.20817E+04    0.55921E-14    0.12253E-19    0.52259E-24
+    3    3    0.95225E-10    0.10000E+01    0.16788E+04    0.18975E-08    0.18138E-13    0.17813E-18
+    3    3    0.95225E-10    0.10000E+01    0.13538E+04    0.40794E-08    0.68919E-13    0.38357E-18
+    3    3    0.95225E-10    0.10000E+01    0.10918E+04    0.85736E-08    0.25703E-12    0.80707E-18
+    3    3    0.95225E-10    0.10000E+01    0.88049E+03    0.17630E-07    0.94641E-12    0.16610E-17
+    3    3    0.95225E-10    0.10000E+01    0.71007E+03    0.35549E-07    0.34465E-11    0.33511E-17
+    3    3    0.95225E-10    0.10000E+01    0.57264E+03    0.70469E-07    0.12262E-10    0.66453E-17
+    3    3    0.95225E-10    0.10000E+01    0.46180E+03    0.13741E-06    0.41242E-10    0.12961E-16
+    3    3    0.95225E-10    0.10000E+01    0.37242E+03    0.26229E-06    0.12576E-09    0.24744E-16
+    3    3    0.95225E-10    0.10000E+01    0.30034E+03    0.48448E-06    0.33730E-09    0.45709E-16
+    3    3    0.95225E-10    0.10000E+01    0.24221E+03    0.85358E-06    0.78757E-09    0.80537E-16
+    3    3    0.95225E-10    0.10000E+01    0.19533E+03    0.13453E-05    0.14966E-08    0.12693E-15
+    3    3    0.95225E-10    0.10000E+01    0.15752E+03    0.13453E-05    0.14966E-08    0.12693E-15
+    3    3    0.16616E-09    0.10000E+01    0.80645E+05    0.10865E-56    0.84277E-68    0.35308E-66
+    3    3    0.16616E-09    0.10000E+01    0.65036E+05    0.94568E-56    0.13517E-66    0.30509E-65
+    3    3    0.16616E-09    0.10000E+01    0.52449E+05    0.81560E-55    0.18582E-65    0.26203E-64
+    3    3    0.16616E-09    0.10000E+01    0.42297E+05    0.62618E-54    0.26498E-64    0.19873E-63
+    3    3    0.16616E-09    0.10000E+01    0.34111E+05    0.47178E-53    0.41262E-63    0.14301E-62
+    3    3    0.16616E-09    0.10000E+01    0.27509E+05    0.38240E-52    0.82608E-62    0.10125E-61
+    3    3    0.16616E-09    0.10000E+01    0.22184E+05    0.38907E-51    0.23195E-60    0.78214E-61
+    3    3    0.16616E-09    0.10000E+01    0.17891E+05    0.53871E-50    0.72261E-59    0.84114E-60
+    3    3    0.16616E-09    0.10000E+01    0.14428E+05    0.85089E-49    0.21509E-57    0.12400E-58
+    3    3    0.16616E-09    0.10000E+01    0.11635E+05    0.13233E-47    0.61092E-56    0.19595E-57
+    3    3    0.16616E-09    0.10000E+01    0.93834E+04    0.19801E-46    0.16972E-54    0.30089E-56
+    3    3    0.16616E-09    0.10000E+01    0.75673E+04    0.28944E-45    0.46711E-53    0.44876E-55
+    3    3    0.16616E-09    0.10000E+01    0.61026E+04    0.41837E-44    0.12789E-51    0.65817E-54
+    3    3    0.16616E-09    0.10000E+01    0.49215E+04    0.60112E-43    0.34882E-50    0.95601E-53
+    3    3    0.16616E-09    0.10000E+01    0.39689E+04    0.86019E-42    0.94840E-49    0.13796E-51
+    3    3    0.16616E-09    0.10000E+01    0.32008E+04    0.38597E-39    0.83215E-46    0.62332E-49
+    3    3    0.16616E-09    0.10000E+01    0.25813E+04    0.28613E-30    0.14128E-36    0.46490E-40
+    3    3    0.16616E-09    0.10000E+01    0.20817E+04    0.55094E-14    0.12126E-19    0.90078E-24
+    3    3    0.16616E-09    0.10000E+01    0.16788E+04    0.18757E-08    0.17987E-13    0.30787E-18
+    3    3    0.16616E-09    0.10000E+01    0.13538E+04    0.40373E-08    0.68366E-13    0.66353E-18
+    3    3    0.16616E-09    0.10000E+01    0.10918E+04    0.84923E-08    0.25501E-12    0.13971E-17
+    3    3    0.16616E-09    0.10000E+01    0.88049E+03    0.17474E-07    0.93904E-12    0.28765E-17
+    3    3    0.16616E-09    0.10000E+01    0.71007E+03    0.35248E-07    0.34197E-11    0.58053E-17
+    3    3    0.16616E-09    0.10000E+01    0.57264E+03    0.69891E-07    0.12167E-10    0.11515E-16
+    3    3    0.16616E-09    0.10000E+01    0.46180E+03    0.13631E-06    0.40923E-10    0.22461E-16
+    3    3    0.16616E-09    0.10000E+01    0.37242E+03    0.26021E-06    0.12478E-09    0.42884E-16
+    3    3    0.16616E-09    0.10000E+01    0.30034E+03    0.48068E-06    0.33469E-09    0.79223E-16
+    3    3    0.16616E-09    0.10000E+01    0.24221E+03    0.84692E-06    0.78147E-09    0.13959E-15
+    3    3    0.16616E-09    0.10000E+01    0.19533E+03    0.13348E-05    0.14850E-08    0.22001E-15
+    3    3    0.16616E-09    0.10000E+01    0.15752E+03    0.13348E-05    0.14850E-08    0.22001E-15
+    3    3    0.28994E-09    0.10000E+01    0.80645E+05    0.22351E-56    0.17069E-67    0.13771E-65
+    3    3    0.28994E-09    0.10000E+01    0.65036E+05    0.19215E-55    0.27233E-66    0.11666E-64
+    3    3    0.28994E-09    0.10000E+01    0.52449E+05    0.16448E-54    0.36780E-65    0.98885E-64
+    3    3    0.28994E-09    0.10000E+01    0.42297E+05    0.12428E-53    0.49689E-64    0.73576E-63
+    3    3    0.28994E-09    0.10000E+01    0.34111E+05    0.89342E-53    0.66977E-63    0.51435E-62
+    3    3    0.28994E-09    0.10000E+01    0.27509E+05    0.63763E-52    0.10022E-61    0.34624E-61
+    3    3    0.28994E-09    0.10000E+01    0.22184E+05    0.50068E-51    0.22068E-60    0.23372E-60
+    3    3    0.28994E-09    0.10000E+01    0.17891E+05    0.53988E-50    0.65398E-59    0.19468E-59
+    3    3    0.28994E-09    0.10000E+01    0.14428E+05    0.78374E-49    0.19796E-57    0.23813E-58
+    3    3    0.28994E-09    0.10000E+01    0.11635E+05    0.12205E-47    0.57325E-56    0.35405E-57
+    3    3    0.28994E-09    0.10000E+01    0.93834E+04    0.18558E-46    0.16141E-54    0.53448E-56
+    3    3    0.28994E-09    0.10000E+01    0.75673E+04    0.27493E-45    0.44841E-53    0.79024E-55
+    3    3    0.28994E-09    0.10000E+01    0.61026E+04    0.40129E-44    0.12364E-51    0.11513E-53
+    3    3    0.28994E-09    0.10000E+01    0.49215E+04    0.58082E-43    0.33915E-50    0.16641E-52
+    3    3    0.28994E-09    0.10000E+01    0.39689E+04    0.83598E-42    0.92645E-49    0.23939E-51
+    3    3    0.28994E-09    0.10000E+01    0.32008E+04    0.37693E-39    0.81623E-46    0.10797E-48
+    3    3    0.28994E-09    0.10000E+01    0.25813E+04    0.28068E-30    0.13916E-36    0.80487E-40
+    3    3    0.28994E-09    0.10000E+01    0.20817E+04    0.54300E-14    0.11998E-19    0.15601E-23
+    3    3    0.28994E-09    0.10000E+01    0.16788E+04    0.18542E-08    0.17829E-13    0.53345E-18
+    3    3    0.28994E-09    0.10000E+01    0.13538E+04    0.39949E-08    0.67783E-13    0.11498E-17
+    3    3    0.28994E-09    0.10000E+01    0.10918E+04    0.84092E-08    0.25287E-12    0.24211E-17
+    3    3    0.28994E-09    0.10000E+01    0.88049E+03    0.17312E-07    0.93122E-12    0.49855E-17
+    3    3    0.28994E-09    0.10000E+01    0.71007E+03    0.34934E-07    0.33913E-11    0.10062E-16
+    3    3    0.28994E-09    0.10000E+01    0.57264E+03    0.69285E-07    0.12066E-10    0.19958E-16
+    3    3    0.28994E-09    0.10000E+01    0.46180E+03    0.13515E-06    0.40583E-10    0.38932E-16
+    3    3    0.28994E-09    0.10000E+01    0.37242E+03    0.25802E-06    0.12375E-09    0.74329E-16
+    3    3    0.28994E-09    0.10000E+01    0.30034E+03    0.47665E-06    0.33190E-09    0.13731E-15
+    3    3    0.28994E-09    0.10000E+01    0.24221E+03    0.83984E-06    0.77497E-09    0.24194E-15
+    3    3    0.28994E-09    0.10000E+01    0.19533E+03    0.13237E-05    0.14727E-08    0.38132E-15
+    3    3    0.28994E-09    0.10000E+01    0.15752E+03    0.13237E-05    0.14727E-08    0.38132E-15
+    3    3    0.50593E-09    0.10000E+01    0.80645E+05    0.46012E-56    0.34486E-67    0.57574E-65
+    3    3    0.50593E-09    0.10000E+01    0.65036E+05    0.38969E-55    0.54583E-66    0.48270E-64
+    3    3    0.50593E-09    0.10000E+01    0.52449E+05    0.33026E-54    0.72364E-65    0.40629E-63
+    3    3    0.50593E-09    0.10000E+01    0.42297E+05    0.24573E-53    0.94808E-64    0.29935E-62
+    3    3    0.50593E-09    0.10000E+01    0.34111E+05    0.17200E-52    0.12062E-62    0.20672E-61
+    3    3    0.50593E-09    0.10000E+01    0.27509E+05    0.11640E-51    0.15413E-61    0.13711E-60
+    3    3    0.50593E-09    0.10000E+01    0.22184E+05    0.79704E-51    0.26187E-60    0.87935E-60
+    3    3    0.50593E-09    0.10000E+01    0.17891E+05    0.67800E-50    0.67769E-59    0.61124E-59
+    3    3    0.50593E-09    0.10000E+01    0.14428E+05    0.83647E-49    0.19970E-57    0.57673E-58
+    3    3    0.50593E-09    0.10000E+01    0.11635E+05    0.12403E-47    0.57556E-56    0.73698E-57
+    3    3    0.50593E-09    0.10000E+01    0.93834E+04    0.18652E-46    0.16145E-54    0.10460E-55
+    3    3    0.50593E-09    0.10000E+01    0.75673E+04    0.27507E-45    0.44686E-53    0.14969E-54
+    3    3    0.50593E-09    0.10000E+01    0.61026E+04    0.40002E-44    0.12288E-51    0.21290E-53
+    3    3    0.50593E-09    0.10000E+01    0.49215E+04    0.57740E-43    0.33653E-50    0.30191E-52
+    3    3    0.50593E-09    0.10000E+01    0.39689E+04    0.82972E-42    0.91878E-49    0.42815E-51
+    3    3    0.50593E-09    0.10000E+01    0.32008E+04    0.37388E-39    0.80961E-46    0.19114E-48
+    3    3    0.50593E-09    0.10000E+01    0.25813E+04    0.27846E-30    0.13814E-36    0.14146E-39
+    3    3    0.50593E-09    0.10000E+01    0.20817E+04    0.53925E-14    0.11925E-19    0.27273E-23
+    3    3    0.50593E-09    0.10000E+01    0.16788E+04    0.18428E-08    0.17732E-13    0.92995E-18
+    3    3    0.50593E-09    0.10000E+01    0.13538E+04    0.39713E-08    0.67418E-13    0.20022E-17
+    3    3    0.50593E-09    0.10000E+01    0.10918E+04    0.83611E-08    0.25151E-12    0.42129E-17
+    3    3    0.50593E-09    0.10000E+01    0.88049E+03    0.17215E-07    0.92622E-12    0.86705E-17
+    3    3    0.50593E-09    0.10000E+01    0.71007E+03    0.34742E-07    0.33730E-11    0.17493E-16
+    3    3    0.50593E-09    0.10000E+01    0.57264E+03    0.68907E-07    0.12001E-10    0.34687E-16
+    3    3    0.50593E-09    0.10000E+01    0.46180E+03    0.13441E-06    0.40362E-10    0.67650E-16
+    3    3    0.50593E-09    0.10000E+01    0.37242E+03    0.25662E-06    0.12307E-09    0.12914E-15
+    3    3    0.50593E-09    0.10000E+01    0.30034E+03    0.47406E-06    0.33009E-09    0.23854E-15
+    3    3    0.50593E-09    0.10000E+01    0.24221E+03    0.83528E-06    0.77073E-09    0.42026E-15
+    3    3    0.50593E-09    0.10000E+01    0.19533E+03    0.13165E-05    0.14646E-08    0.66235E-15
+    3    3    0.50593E-09    0.10000E+01    0.15752E+03    0.13165E-05    0.14646E-08    0.66235E-15
+    3    3    0.88282E-09    0.10000E+01    0.80645E+05    0.91865E-56    0.68141E-67    0.21790E-64
+    3    3    0.88282E-09    0.10000E+01    0.65036E+05    0.77163E-55    0.10737E-65    0.18252E-63
+    3    3    0.88282E-09    0.10000E+01    0.52449E+05    0.65033E-54    0.14097E-64    0.15362E-62
+    3    3    0.88282E-09    0.10000E+01    0.42297E+05    0.48008E-53    0.18244E-63    0.11333E-61
+    3    3    0.88282E-09    0.10000E+01    0.34111E+05    0.33246E-52    0.22862E-62    0.78662E-61
+    3    3    0.88282E-09    0.10000E+01    0.27509E+05    0.22147E-51    0.27544E-61    0.52771E-60
+    3    3    0.88282E-09    0.10000E+01    0.22184E+05    0.14384E-50    0.38522E-60    0.33902E-59
+    3    3    0.88282E-09    0.10000E+01    0.17891E+05    0.10398E-49    0.80943E-59    0.21634E-58
+    3    3    0.88282E-09    0.10000E+01    0.14428E+05    0.10420E-48    0.21912E-57    0.15995E-57
+    3    3    0.88282E-09    0.10000E+01    0.11635E+05    0.13837E-47    0.61336E-56    0.16104E-56
+    3    3    0.88282E-09    0.10000E+01    0.93834E+04    0.19969E-46    0.16909E-54    0.20517E-55
+    3    3    0.88282E-09    0.10000E+01    0.75673E+04    0.28853E-45    0.46135E-53    0.28287E-54
+    3    3    0.88282E-09    0.10000E+01    0.61026E+04    0.41345E-44    0.12542E-51    0.39470E-53
+    3    3    0.88282E-09    0.10000E+01    0.49215E+04    0.58993E-43    0.34060E-50    0.55092E-52
+    3    3    0.88282E-09    0.10000E+01    0.39689E+04    0.84046E-42    0.92456E-49    0.77043E-51
+    3    3    0.88282E-09    0.10000E+01    0.32008E+04    0.37644E-39    0.81158E-46    0.34005E-48
+    3    3    0.88282E-09    0.10000E+01    0.25813E+04    0.27924E-30    0.13811E-36    0.24948E-39
+    3    3    0.88282E-09    0.10000E+01    0.20817E+04    0.53925E-14    0.11899E-19    0.47765E-23
+    3    3    0.88282E-09    0.10000E+01    0.16788E+04    0.18403E-08    0.17682E-13    0.16227E-17
+    3    3    0.88282E-09    0.10000E+01    0.13538E+04    0.39635E-08    0.67221E-13    0.34884E-17
+    3    3    0.88282E-09    0.10000E+01    0.10918E+04    0.83416E-08    0.25074E-12    0.73323E-17
+    3    3    0.88282E-09    0.10000E+01    0.88049E+03    0.17170E-07    0.92330E-12    0.15079E-16
+    3    3    0.88282E-09    0.10000E+01    0.71007E+03    0.34645E-07    0.33621E-11    0.30406E-16
+    3    3    0.88282E-09    0.10000E+01    0.57264E+03    0.68705E-07    0.11961E-10    0.60270E-16
+    3    3    0.88282E-09    0.10000E+01    0.46180E+03    0.13400E-06    0.40228E-10    0.11751E-15
+    3    3    0.88282E-09    0.10000E+01    0.37242E+03    0.25581E-06    0.12266E-09    0.22426E-15
+    3    3    0.88282E-09    0.10000E+01    0.30034E+03    0.47254E-06    0.32898E-09    0.41417E-15
+    3    3    0.88282E-09    0.10000E+01    0.24221E+03    0.83257E-06    0.76813E-09    0.72963E-15
+    3    3    0.88282E-09    0.10000E+01    0.19533E+03    0.13122E-05    0.14597E-08    0.11498E-14
+    3    3    0.88282E-09    0.10000E+01    0.15752E+03    0.13122E-05    0.14597E-08    0.11498E-14
+    3    3    0.15405E-08    0.10000E+01    0.80645E+05    0.17676E-55    0.13074E-66    0.73136E-64
+    3    3    0.15405E-08    0.10000E+01    0.65036E+05    0.14814E-54    0.20586E-65    0.61367E-63
+    3    3    0.15405E-08    0.10000E+01    0.52449E+05    0.12472E-53    0.27008E-64    0.51750E-62
+    3    3    0.15405E-08    0.10000E+01    0.42297E+05    0.92021E-53    0.35026E-63    0.38336E-61
+    3    3    0.15405E-08    0.10000E+01    0.34111E+05    0.63823E-52    0.44256E-62    0.26842E-60
+    3    3    0.15405E-08    0.10000E+01    0.27509E+05    0.42732E-51    0.52988E-61    0.18298E-59
+    3    3    0.15405E-08    0.10000E+01    0.22184E+05    0.27522E-50    0.65827E-60    0.11974E-58
+    3    3    0.15405E-08    0.10000E+01    0.17891E+05    0.18138E-49    0.10819E-58    0.75032E-58
+    3    3    0.15405E-08    0.10000E+01    0.14428E+05    0.14689E-48    0.24993E-57    0.48106E-57
+    3    3    0.15405E-08    0.10000E+01    0.11635E+05    0.16325E-47    0.66302E-56    0.37409E-56
+    3    3    0.15405E-08    0.10000E+01    0.93834E+04    0.21836E-46    0.17916E-54    0.39647E-55
+    3    3    0.15405E-08    0.10000E+01    0.75673E+04    0.30666E-45    0.48206E-53    0.51408E-54
+    3    3    0.15405E-08    0.10000E+01    0.61026E+04    0.43251E-44    0.12941E-51    0.70877E-53
+    3    3    0.15405E-08    0.10000E+01    0.49215E+04    0.60932E-43    0.34779E-50    0.98505E-52
+    3    3    0.15405E-08    0.10000E+01    0.39689E+04    0.85900E-42    0.93662E-49    0.13694E-50
+    3    3    0.15405E-08    0.10000E+01    0.32008E+04    0.38162E-39    0.81744E-46    0.60027E-48
+    3    3    0.15405E-08    0.10000E+01    0.25813E+04    0.28136E-30    0.13850E-36    0.43756E-39
+    3    3    0.15405E-08    0.10000E+01    0.20817E+04    0.54081E-14    0.11889E-19    0.83309E-23
+    3    3    0.15405E-08    0.10000E+01    0.16788E+04    0.18411E-08    0.17644E-13    0.28225E-17
+    3    3    0.15405E-08    0.10000E+01    0.13538E+04    0.39612E-08    0.67060E-13    0.60587E-17
+    3    3    0.15405E-08    0.10000E+01    0.10918E+04    0.83310E-08    0.25010E-12    0.12723E-16
+    3    3    0.15405E-08    0.10000E+01    0.88049E+03    0.17140E-07    0.92076E-12    0.26147E-16
+    3    3    0.15405E-08    0.10000E+01    0.71007E+03    0.34573E-07    0.33525E-11    0.52696E-16
+    3    3    0.15405E-08    0.10000E+01    0.57264E+03    0.68543E-07    0.11926E-10    0.10441E-15
+    3    3    0.15405E-08    0.10000E+01    0.46180E+03    0.13366E-06    0.40107E-10    0.20350E-15
+    3    3    0.15405E-08    0.10000E+01    0.37242E+03    0.25512E-06    0.12228E-09    0.38828E-15
+    3    3    0.15405E-08    0.10000E+01    0.30034E+03    0.47121E-06    0.32797E-09    0.71697E-15
+    3    3    0.15405E-08    0.10000E+01    0.24221E+03    0.83016E-06    0.76577E-09    0.12629E-14
+    3    3    0.15405E-08    0.10000E+01    0.19533E+03    0.13083E-05    0.14552E-08    0.19900E-14
+    3    3    0.15405E-08    0.10000E+01    0.15752E+03    0.13083E-05    0.14552E-08    0.19900E-14
+    3    3    0.26880E-08    0.10000E+01    0.80645E+05    0.33184E-55    0.24578E-66    0.23904E-63
+    3    3    0.26880E-08    0.10000E+01    0.65036E+05    0.27844E-54    0.38755E-65    0.20103E-62
+    3    3    0.26880E-08    0.10000E+01    0.52449E+05    0.23476E-53    0.51061E-64    0.16990E-61
+    3    3    0.26880E-08    0.10000E+01    0.42297E+05    0.17381E-52    0.66856E-63    0.12640E-60
+    3    3    0.26880E-08    0.10000E+01    0.34111E+05    0.12151E-51    0.86079E-62    0.89261E-60
+    3    3    0.26880E-08    0.10000E+01    0.27509E+05    0.82585E-51    0.10522E-60    0.61777E-59
+    3    3    0.26880E-08    0.10000E+01    0.22184E+05    0.53992E-50    0.12507E-59    0.41346E-58
+    3    3    0.26880E-08    0.10000E+01    0.17891E+05    0.34445E-49    0.16644E-58    0.26323E-57
+    3    3    0.26880E-08    0.10000E+01    0.14428E+05    0.23680E-48    0.29954E-57    0.16125E-56
+    3    3    0.26880E-08    0.10000E+01    0.11635E+05    0.20733E-47    0.70675E-56    0.10363E-55
+    3    3    0.26880E-08    0.10000E+01    0.93834E+04    0.23950E-46    0.18533E-54    0.83623E-55
+    3    3    0.26880E-08    0.10000E+01    0.75673E+04    0.31991E-45    0.49527E-53    0.92556E-54
+    3    3    0.26880E-08    0.10000E+01    0.61026E+04    0.44505E-44    0.13226E-51    0.12299E-52
+    3    3    0.26880E-08    0.10000E+01    0.49215E+04    0.62286E-43    0.35315E-50    0.17134E-51
+    3    3    0.26880E-08    0.10000E+01    0.39689E+04    0.87253E-42    0.94513E-49    0.23924E-50
+    3    3    0.26880E-08    0.10000E+01    0.32008E+04    0.38523E-39    0.82060E-46    0.10485E-47
+    3    3    0.26880E-08    0.10000E+01    0.25813E+04    0.28251E-30    0.13844E-36    0.76195E-39
+    3    3    0.26880E-08    0.10000E+01    0.20817E+04    0.54056E-14    0.11838E-19    0.14454E-22
+    3    3    0.26880E-08    0.10000E+01    0.16788E+04    0.18361E-08    0.17546E-13    0.48894E-17
+    3    3    0.26880E-08    0.10000E+01    0.13538E+04    0.39459E-08    0.66668E-13    0.10479E-16
+    3    3    0.26880E-08    0.10000E+01    0.10918E+04    0.82926E-08    0.24857E-12    0.21981E-16
+    3    3    0.26880E-08    0.10000E+01    0.88049E+03    0.17052E-07    0.91496E-12    0.45140E-16
+    3    3    0.26880E-08    0.10000E+01    0.71007E+03    0.34381E-07    0.33308E-11    0.90923E-16
+    3    3    0.26880E-08    0.10000E+01    0.57264E+03    0.68142E-07    0.11847E-10    0.18007E-15
+    3    3    0.26880E-08    0.10000E+01    0.46180E+03    0.13285E-06    0.39840E-10    0.35083E-15
+    3    3    0.26880E-08    0.10000E+01    0.37242E+03    0.25352E-06    0.12147E-09    0.66920E-15
+    3    3    0.26880E-08    0.10000E+01    0.30034E+03    0.46820E-06    0.32577E-09    0.12354E-14
+    3    3    0.26880E-08    0.10000E+01    0.24221E+03    0.82477E-06    0.76061E-09    0.21757E-14
+    3    3    0.26880E-08    0.10000E+01    0.19533E+03    0.12997E-05    0.14454E-08    0.34280E-14
+    3    3    0.26880E-08    0.10000E+01    0.15752E+03    0.12997E-05    0.14454E-08    0.34280E-14
+    3    3    0.46905E-08    0.10000E+01    0.80645E+05    0.65298E-55    0.48674E-66    0.23367E-62
+    3    3    0.46905E-08    0.10000E+01    0.65036E+05    0.55075E-54    0.77101E-65    0.19749E-61
+    3    3    0.46905E-08    0.10000E+01    0.52449E+05    0.46668E-53    0.10281E-63    0.16766E-60
+    3    3    0.46905E-08    0.10000E+01    0.42297E+05    0.34893E-52    0.13774E-62    0.12580E-59
+    3    3    0.46905E-08    0.10000E+01    0.34111E+05    0.24872E-51    0.18483E-61    0.90258E-59
+    3    3    0.46905E-08    0.10000E+01    0.27509E+05    0.17511E-50    0.24204E-60    0.64215E-58
+    3    3    0.46905E-08    0.10000E+01    0.22184E+05    0.12117E-49    0.31006E-59    0.45038E-57
+    3    3    0.46905E-08    0.10000E+01    0.17891E+05    0.82305E-49    0.40250E-58    0.30797E-56
+    3    3    0.46905E-08    0.10000E+01    0.14428E+05    0.56244E-48    0.57172E-57    0.20415E-55
+    3    3    0.46905E-08    0.10000E+01    0.11635E+05    0.41138E-47    0.97120E-56    0.13131E-54
+    3    3    0.46905E-08    0.10000E+01    0.93834E+04    0.35126E-46    0.20361E-54    0.82551E-54
+    3    3    0.46905E-08    0.10000E+01    0.75673E+04    0.36843E-45    0.49838E-53    0.52162E-53
+    3    3    0.46905E-08    0.10000E+01    0.61026E+04    0.45781E-44    0.13129E-51    0.36510E-52
+    3    3    0.46905E-08    0.10000E+01    0.49215E+04    0.62238E-43    0.35338E-50    0.33371E-51
+    3    3    0.46905E-08    0.10000E+01    0.39689E+04    0.87348E-42    0.95317E-49    0.40684E-50
+    3    3    0.46905E-08    0.10000E+01    0.32008E+04    0.38817E-39    0.83040E-46    0.17798E-47
+    3    3    0.46905E-08    0.10000E+01    0.25813E+04    0.28558E-30    0.14005E-36    0.13136E-38
+    3    3    0.46905E-08    0.10000E+01    0.20817E+04    0.54634E-14    0.11937E-19    0.25086E-22
+    3    3    0.46905E-08    0.10000E+01    0.16788E+04    0.18542E-08    0.17657E-13    0.84794E-17
+    3    3    0.46905E-08    0.10000E+01    0.13538E+04    0.39793E-08    0.67066E-13    0.17903E-16
+    3    3    0.46905E-08    0.10000E+01    0.10918E+04    0.83548E-08    0.25000E-12    0.37214E-16
+    3    3    0.46905E-08    0.10000E+01    0.88049E+03    0.17169E-07    0.92009E-12    0.75963E-16
+    3    3    0.46905E-08    0.10000E+01    0.71007E+03    0.34601E-07    0.33492E-11    0.15234E-15
+    3    3    0.46905E-08    0.10000E+01    0.57264E+03    0.68557E-07    0.11912E-10    0.30069E-15
+    3    3    0.46905E-08    0.10000E+01    0.46180E+03    0.13363E-06    0.40057E-10    0.58431E-15
+    3    3    0.46905E-08    0.10000E+01    0.37242E+03    0.25497E-06    0.12213E-09    0.11123E-14
+    3    3    0.46905E-08    0.10000E+01    0.30034E+03    0.47083E-06    0.32754E-09    0.20503E-14
+    3    3    0.46905E-08    0.10000E+01    0.24221E+03    0.82935E-06    0.76474E-09    0.36070E-14
+    3    3    0.46905E-08    0.10000E+01    0.19533E+03    0.13069E-05    0.14532E-08    0.56793E-14
+    3    3    0.46905E-08    0.10000E+01    0.15752E+03    0.13069E-05    0.14532E-08    0.56793E-14
+    3    3    0.81846E-08    0.10000E+01    0.80645E+05    0.11807E-54    0.88110E-66    0.65814E-62
+    3    3    0.81846E-08    0.10000E+01    0.65036E+05    0.99676E-54    0.13968E-64    0.55661E-61
+    3    3    0.81846E-08    0.10000E+01    0.52449E+05    0.84534E-53    0.18663E-63    0.47282E-60
+    3    3    0.81846E-08    0.10000E+01    0.42297E+05    0.63309E-52    0.25093E-62    0.35518E-59
+    3    3    0.81846E-08    0.10000E+01    0.34111E+05    0.45262E-51    0.33857E-61    0.25534E-58
+    3    3    0.81846E-08    0.10000E+01    0.27509E+05    0.32019E-50    0.44647E-60    0.18229E-57
+    3    3    0.81846E-08    0.10000E+01    0.22184E+05    0.22286E-49    0.57277E-59    0.12859E-56
+    3    3    0.81846E-08    0.10000E+01    0.17891E+05    0.15163E-48    0.72568E-58    0.88756E-56
+    3    3    0.81846E-08    0.10000E+01    0.14428E+05    0.10173E-47    0.94921E-57    0.59651E-55
+    3    3    0.81846E-08    0.10000E+01    0.11635E+05    0.69597E-47    0.13797E-55    0.39027E-54
+    3    3    0.81846E-08    0.10000E+01    0.93834E+04    0.51792E-46    0.24193E-54    0.24868E-53
+    3    3    0.81846E-08    0.10000E+01    0.75673E+04    0.45579E-45    0.52481E-53    0.15498E-52
+    3    3    0.81846E-08    0.10000E+01    0.61026E+04    0.49508E-44    0.13178E-51    0.98560E-52
+    3    3    0.81846E-08    0.10000E+01    0.49215E+04    0.63211E-43    0.35129E-50    0.73861E-51
+    3    3    0.81846E-08    0.10000E+01    0.39689E+04    0.87129E-42    0.94806E-49    0.76422E-50
+    3    3    0.81846E-08    0.10000E+01    0.32008E+04    0.38630E-39    0.82650E-46    0.31782E-47
+    3    3    0.81846E-08    0.10000E+01    0.25813E+04    0.28422E-30    0.13926E-36    0.23405E-38
+    3    3    0.81846E-08    0.10000E+01    0.20817E+04    0.54354E-14    0.11836E-19    0.44835E-22
+    3    3    0.81846E-08    0.10000E+01    0.16788E+04    0.18438E-08    0.17482E-13    0.15098E-16
+    3    3    0.81846E-08    0.10000E+01    0.13538E+04    0.39495E-08    0.66373E-13    0.31472E-16
+    3    3    0.81846E-08    0.10000E+01    0.10918E+04    0.82827E-08    0.24732E-12    0.64907E-16
+    3    3    0.81846E-08    0.10000E+01    0.88049E+03    0.17008E-07    0.90994E-12    0.13180E-15
+    3    3    0.81846E-08    0.10000E+01    0.71007E+03    0.34257E-07    0.33114E-11    0.26334E-15
+    3    3    0.81846E-08    0.10000E+01    0.57264E+03    0.67845E-07    0.11776E-10    0.51839E-15
+    3    3    0.81846E-08    0.10000E+01    0.46180E+03    0.13219E-06    0.39593E-10    0.10053E-14
+    3    3    0.81846E-08    0.10000E+01    0.37242E+03    0.25217E-06    0.12070E-09    0.19108E-14
+    3    3    0.81846E-08    0.10000E+01    0.30034E+03    0.46555E-06    0.32370E-09    0.35184E-14
+    3    3    0.81846E-08    0.10000E+01    0.24221E+03    0.81992E-06    0.75575E-09    0.61849E-14
+    3    3    0.81846E-08    0.10000E+01    0.19533E+03    0.12919E-05    0.14361E-08    0.97339E-14
+    3    3    0.81846E-08    0.10000E+01    0.15752E+03    0.12919E-05    0.14361E-08    0.97339E-14
+    3    3    0.14282E-07    0.10000E+01    0.80645E+05    0.21296E-54    0.15909E-65    0.19097E-61
+    3    3    0.14282E-07    0.10000E+01    0.65036E+05    0.17994E-53    0.25238E-64    0.16160E-60
+    3    3    0.14282E-07    0.10000E+01    0.52449E+05    0.15272E-52    0.33783E-63    0.13734E-59
+    3    3    0.14282E-07    0.10000E+01    0.42297E+05    0.11455E-51    0.45563E-62    0.10326E-58
+    3    3    0.14282E-07    0.10000E+01    0.34111E+05    0.82112E-51    0.61788E-61    0.74357E-58
+    3    3    0.14282E-07    0.10000E+01    0.27509E+05    0.58344E-50    0.82090E-60    0.53227E-57
+    3    3    0.14282E-07    0.10000E+01    0.22184E+05    0.40869E-49    0.10610E-58    0.37716E-56
+    3    3    0.14282E-07    0.10000E+01    0.17891E+05    0.27987E-48    0.13412E-57    0.26224E-55
+    3    3    0.14282E-07    0.10000E+01    0.14428E+05    0.18762E-47    0.16963E-56    0.17819E-54
+    3    3    0.14282E-07    0.10000E+01    0.11635E+05    0.12511E-46    0.22388E-55    0.11829E-53
+    3    3    0.14282E-07    0.10000E+01    0.93834E+04    0.85969E-46    0.33127E-54    0.76586E-53
+    3    3    0.14282E-07    0.10000E+01    0.75673E+04    0.64989E-45    0.60134E-53    0.48079E-52
+    3    3    0.14282E-07    0.10000E+01    0.61026E+04    0.59079E-44    0.13620E-51    0.29477E-51
+    3    3    0.14282E-07    0.10000E+01    0.49215E+04    0.66914E-43    0.35193E-50    0.19129E-50
+    3    3    0.14282E-07    0.10000E+01    0.39689E+04    0.88069E-42    0.94742E-49    0.16043E-49
+    3    3    0.14282E-07    0.10000E+01    0.32008E+04    0.38689E-39    0.82725E-46    0.59723E-47
+    3    3    0.14282E-07    0.10000E+01    0.25813E+04    0.28459E-30    0.13926E-36    0.43148E-38
+    3    3    0.14282E-07    0.10000E+01    0.20817E+04    0.54427E-14    0.11776E-19    0.82805E-22
+    3    3    0.14282E-07    0.10000E+01    0.16788E+04    0.18444E-08    0.17340E-13    0.27649E-16
+    3    3    0.14282E-07    0.10000E+01    0.13538E+04    0.39362E-08    0.65783E-13    0.56382E-16
+    3    3    0.14282E-07    0.10000E+01    0.10918E+04    0.82364E-08    0.24497E-12    0.11467E-15
+    3    3    0.14282E-07    0.10000E+01    0.88049E+03    0.16888E-07    0.90080E-12    0.23069E-15
+    3    3    0.14282E-07    0.10000E+01    0.71007E+03    0.33980E-07    0.32768E-11    0.45794E-15
+    3    3    0.14282E-07    0.10000E+01    0.57264E+03    0.67243E-07    0.11649E-10    0.89714E-15
+    3    3    0.14282E-07    0.10000E+01    0.46180E+03    0.13094E-06    0.39160E-10    0.17337E-14
+    3    3    0.14282E-07    0.10000E+01    0.37242E+03    0.24965E-06    0.11937E-09    0.32866E-14
+    3    3    0.14282E-07    0.10000E+01    0.30034E+03    0.46075E-06    0.32010E-09    0.60405E-14
+    3    3    0.14282E-07    0.10000E+01    0.24221E+03    0.81128E-06    0.74732E-09    0.10605E-13
+    3    3    0.14282E-07    0.10000E+01    0.19533E+03    0.12781E-05    0.14200E-08    0.16677E-13
+    3    3    0.14282E-07    0.10000E+01    0.15752E+03    0.12781E-05    0.14200E-08    0.16677E-13
+    3    3    0.24920E-07    0.10000E+01    0.80645E+05    0.38346E-54    0.28673E-65    0.57083E-61
+    3    3    0.24920E-07    0.10000E+01    0.65036E+05    0.32424E-53    0.45513E-64    0.48325E-60
+    3    3    0.24920E-07    0.10000E+01    0.52449E+05    0.27538E-52    0.61015E-63    0.41086E-59
+    3    3    0.24920E-07    0.10000E+01    0.42297E+05    0.20680E-51    0.82508E-62    0.30914E-58
+    3    3    0.24920E-07    0.10000E+01    0.34111E+05    0.14858E-50    0.11236E-60    0.22289E-57
+    3    3    0.24920E-07    0.10000E+01    0.27509E+05    0.10596E-49    0.15028E-59    0.15989E-56
+    3    3    0.24920E-07    0.10000E+01    0.22184E+05    0.74654E-49    0.19593E-58    0.11369E-55
+    3    3    0.24920E-07    0.10000E+01    0.17891E+05    0.51509E-48    0.24930E-57    0.79495E-55
+    3    3    0.24920E-07    0.10000E+01    0.14428E+05    0.34745E-47    0.31319E-56    0.54471E-54
+    3    3    0.24920E-07    0.10000E+01    0.11635E+05    0.23077E-46    0.39586E-55    0.36577E-53
+    3    3    0.24920E-07    0.10000E+01    0.93834E+04    0.15332E-45    0.52263E-54    0.24020E-52
+    3    3    0.24920E-07    0.10000E+01    0.75673E+04    0.10538E-44    0.78606E-53    0.15291E-51
+    3    3    0.24920E-07    0.10000E+01    0.61026E+04    0.80819E-44    0.14992E-51    0.93492E-51
+    3    3    0.24920E-07    0.10000E+01    0.49215E+04    0.76691E-43    0.35840E-50    0.56458E-50
+    3    3    0.24920E-07    0.10000E+01    0.39689E+04    0.91483E-42    0.95065E-49    0.39197E-49
+    3    3    0.24920E-07    0.10000E+01    0.32008E+04    0.39073E-39    0.83111E-46    0.12279E-46
+    3    3    0.24920E-07    0.10000E+01    0.25813E+04    0.28653E-30    0.13974E-36    0.84297E-38
+    3    3    0.24920E-07    0.10000E+01    0.20817E+04    0.54818E-14    0.11711E-19    0.16143E-21
+    3    3    0.24920E-07    0.10000E+01    0.16788E+04    0.18533E-08    0.17143E-13    0.53082E-16
+    3    3    0.24920E-07    0.10000E+01    0.13538E+04    0.39274E-08    0.64944E-13    0.10444E-15
+    3    3    0.24920E-07    0.10000E+01    0.10918E+04    0.81830E-08    0.24157E-12    0.20745E-15
+    3    3    0.24920E-07    0.10000E+01    0.88049E+03    0.16732E-07    0.88751E-12    0.41069E-15
+    3    3    0.24920E-07    0.10000E+01    0.71007E+03    0.33599E-07    0.32263E-11    0.80599E-15
+    3    3    0.24920E-07    0.10000E+01    0.57264E+03    0.66393E-07    0.11464E-10    0.15659E-14
+    3    3    0.24920E-07    0.10000E+01    0.46180E+03    0.12914E-06    0.38526E-10    0.30073E-14
+    3    3    0.24920E-07    0.10000E+01    0.37242E+03    0.24603E-06    0.11741E-09    0.56754E-14
+    3    3    0.24920E-07    0.10000E+01    0.30034E+03    0.45378E-06    0.31482E-09    0.10397E-13
+    3    3    0.24920E-07    0.10000E+01    0.24221E+03    0.79867E-06    0.73494E-09    0.18213E-13
+    3    3    0.24920E-07    0.10000E+01    0.19533E+03    0.12579E-05    0.13965E-08    0.28602E-13
+    3    3    0.24920E-07    0.10000E+01    0.15752E+03    0.12579E-05    0.13965E-08    0.28602E-13
+    3    3    0.43485E-07    0.10000E+01    0.80645E+05    0.68905E-54    0.51560E-65    0.17351E-60
+    3    3    0.43485E-07    0.10000E+01    0.65036E+05    0.58299E-53    0.81884E-64    0.14694E-59
+    3    3    0.43485E-07    0.10000E+01    0.52449E+05    0.49541E-52    0.10991E-62    0.12497E-58
+    3    3    0.43485E-07    0.10000E+01    0.42297E+05    0.37240E-51    0.14893E-61    0.94080E-58
+    3    3    0.43485E-07    0.10000E+01    0.34111E+05    0.26803E-50    0.20351E-60    0.67900E-57
+    3    3    0.43485E-07    0.10000E+01    0.27509E+05    0.19173E-49    0.27366E-59    0.48788E-56
+    3    3    0.43485E-07    0.10000E+01    0.22184E+05    0.13571E-48    0.35959E-58    0.34784E-55
+    3    3    0.43485E-07    0.10000E+01    0.17891E+05    0.94274E-48    0.46159E-57    0.24426E-54
+    3    3    0.43485E-07    0.10000E+01    0.14428E+05    0.64091E-47    0.58251E-56    0.16843E-53
+    3    3    0.43485E-07    0.10000E+01    0.11635E+05    0.42777E-46    0.72774E-55    0.11407E-52
+    3    3    0.43485E-07    0.10000E+01    0.93834E+04    0.28198E-45    0.91020E-54    0.75757E-52
+    3    3    0.43485E-07    0.10000E+01    0.75673E+04    0.18567E-44    0.11944E-52    0.48895E-51
+    3    3    0.43485E-07    0.10000E+01    0.61026E+04    0.12703E-43    0.18593E-51    0.30213E-50
+    3    3    0.43485E-07    0.10000E+01    0.49215E+04    0.10004E-42    0.38398E-50    0.17854E-49
+    3    3    0.43485E-07    0.10000E+01    0.39689E+04    0.10164E-41    0.97343E-49    0.10990E-48
+    3    3    0.43485E-07    0.10000E+01    0.32008E+04    0.40621E-39    0.84811E-46    0.28455E-46
+    3    3    0.43485E-07    0.10000E+01    0.25813E+04    0.29428E-30    0.14230E-36    0.17857E-37
+    3    3    0.43485E-07    0.10000E+01    0.20817E+04    0.56303E-14    0.11738E-19    0.33896E-21
+    3    3    0.43485E-07    0.10000E+01    0.16788E+04    0.18941E-08    0.17001E-13    0.10899E-15
+    3    3    0.43485E-07    0.10000E+01    0.13538E+04    0.39623E-08    0.64246E-13    0.20363E-15
+    3    3    0.43485E-07    0.10000E+01    0.10918E+04    0.81909E-08    0.23850E-12    0.39002E-15
+    3    3    0.43485E-07    0.10000E+01    0.88049E+03    0.16661E-07    0.87492E-12    0.75247E-15
+    3    3    0.43485E-07    0.10000E+01    0.71007E+03    0.33338E-07    0.31769E-11    0.14493E-14
+    3    3    0.43485E-07    0.10000E+01    0.57264E+03    0.65704E-07    0.11280E-10    0.27768E-14
+    3    3    0.43485E-07    0.10000E+01    0.46180E+03    0.12755E-06    0.37888E-10    0.52776E-14
+    3    3    0.43485E-07    0.10000E+01    0.37242E+03    0.24265E-06    0.11543E-09    0.98837E-14
+    3    3    0.43485E-07    0.10000E+01    0.30034E+03    0.44710E-06    0.30946E-09    0.18008E-13
+    3    3    0.43485E-07    0.10000E+01    0.24221E+03    0.78635E-06    0.72234E-09    0.31425E-13
+    3    3    0.43485E-07    0.10000E+01    0.19533E+03    0.12380E-05    0.13724E-08    0.49235E-13
+    3    3    0.43485E-07    0.10000E+01    0.15752E+03    0.12380E-05    0.13724E-08    0.49235E-13
+    3    3    0.75878E-07    0.10000E+01    0.80645E+05    0.12353E-53    0.92490E-65    0.53186E-60
+    3    3    0.75878E-07    0.10000E+01    0.65036E+05    0.10457E-52    0.14694E-63    0.45054E-59
+    3    3    0.75878E-07    0.10000E+01    0.52449E+05    0.88895E-52    0.19741E-62    0.38327E-58
+    3    3    0.75878E-07    0.10000E+01    0.42297E+05    0.66874E-51    0.26795E-61    0.28867E-57
+    3    3    0.75878E-07    0.10000E+01    0.34111E+05    0.48201E-50    0.36709E-60    0.20850E-56
+    3    3    0.75878E-07    0.10000E+01    0.27509E+05    0.34558E-49    0.49573E-59    0.15001E-55
+    3    3    0.75878E-07    0.10000E+01    0.22184E+05    0.24552E-48    0.65560E-58    0.10717E-54
+    3    3    0.75878E-07    0.10000E+01    0.17891E+05    0.17151E-47    0.84850E-57    0.75505E-54
+    3    3    0.75878E-07    0.10000E+01    0.14428E+05    0.11744E-46    0.10791E-55    0.52314E-53
+    3    3    0.75878E-07    0.10000E+01    0.11635E+05    0.78959E-46    0.13510E-54    0.35662E-52
+    3    3    0.75878E-07    0.10000E+01    0.93834E+04    0.52205E-45    0.16611E-53    0.23886E-51
+    3    3    0.75878E-07    0.10000E+01    0.75673E+04    0.33946E-44    0.20316E-52    0.15593E-50
+    3    3    0.75878E-07    0.10000E+01    0.61026E+04    0.21959E-43    0.26761E-51    0.97643E-50
+    3    3    0.75878E-07    0.10000E+01    0.49215E+04    0.15039E-42    0.45210E-50    0.57824E-49
+    3    3    0.75878E-07    0.10000E+01    0.39689E+04    0.12603E-41    0.10387E-48    0.33602E-48
+    3    3    0.75878E-07    0.10000E+01    0.32008E+04    0.44639E-39    0.88940E-46    0.74334E-46
+    3    3    0.75878E-07    0.10000E+01    0.25813E+04    0.31323E-30    0.14852E-36    0.41530E-37
+    3    3    0.75878E-07    0.10000E+01    0.20817E+04    0.59832E-14    0.11940E-19    0.77571E-21
+    3    3    0.75878E-07    0.10000E+01    0.16788E+04    0.19940E-08    0.16972E-13    0.24289E-15
+    3    3    0.75878E-07    0.10000E+01    0.13538E+04    0.40792E-08    0.63860E-13    0.42536E-15
+    3    3    0.75878E-07    0.10000E+01    0.10918E+04    0.83154E-08    0.23627E-12    0.77518E-15
+    3    3    0.75878E-07    0.10000E+01    0.88049E+03    0.16760E-07    0.86452E-12    0.14405E-14
+    3    3    0.75878E-07    0.10000E+01    0.71007E+03    0.33321E-07    0.31333E-11    0.26965E-14
+    3    3    0.75878E-07    0.10000E+01    0.57264E+03    0.65368E-07    0.11111E-10    0.50547E-14
+    3    3    0.75878E-07    0.10000E+01    0.46180E+03    0.12647E-06    0.37288E-10    0.94477E-14
+    3    3    0.75878E-07    0.10000E+01    0.37242E+03    0.23999E-06    0.11355E-09    0.17473E-13
+    3    3    0.75878E-07    0.10000E+01    0.30034E+03    0.44142E-06    0.30432E-09    0.31547E-13
+    3    3    0.75878E-07    0.10000E+01    0.24221E+03    0.77542E-06    0.71022E-09    0.54705E-13
+    3    3    0.75878E-07    0.10000E+01    0.19533E+03    0.12198E-05    0.13493E-08    0.85374E-13
+    3    3    0.75878E-07    0.10000E+01    0.15752E+03    0.12198E-05    0.13493E-08    0.85374E-13
+    3    3    0.13240E-06    0.10000E+01    0.80645E+05    0.22097E-53    0.16552E-64    0.16443E-59
+    3    3    0.13240E-06    0.10000E+01    0.65036E+05    0.18712E-52    0.26305E-63    0.13932E-58
+    3    3    0.13240E-06    0.10000E+01    0.52449E+05    0.15913E-51    0.35367E-62    0.11854E-57
+    3    3    0.13240E-06    0.10000E+01    0.42297E+05    0.11978E-50    0.48066E-61    0.89314E-57
+    3    3    0.13240E-06    0.10000E+01    0.34111E+05    0.86430E-50    0.65982E-60    0.64552E-56
+    3    3    0.13240E-06    0.10000E+01    0.27509E+05    0.62078E-49    0.89399E-59    0.46490E-55
+    3    3    0.13240E-06    0.10000E+01    0.22184E+05    0.44233E-48    0.11884E-57    0.33269E-54
+    3    3    0.13240E-06    0.10000E+01    0.17891E+05    0.31036E-47    0.15487E-56    0.23500E-53
+    3    3    0.13240E-06    0.10000E+01    0.14428E+05    0.21382E-46    0.19850E-55    0.16343E-52
+    3    3    0.13240E-06    0.10000E+01    0.11635E+05    0.14478E-45    0.25015E-54    0.11197E-51
+    3    3    0.13240E-06    0.10000E+01    0.93834E+04    0.96344E-45    0.30756E-53    0.75493E-51
+    3    3    0.13240E-06    0.10000E+01    0.75673E+04    0.62714E-44    0.36668E-52    0.49729E-50
+    3    3    0.13240E-06    0.10000E+01    0.61026E+04    0.39786E-43    0.43733E-51    0.31523E-49
+    3    3    0.13240E-06    0.10000E+01    0.49215E+04    0.25198E-42    0.60554E-50    0.18865E-48
+    3    3    0.13240E-06    0.10000E+01    0.39689E+04    0.17826E-41    0.11847E-48    0.10746E-47
+    3    3    0.13240E-06    0.10000E+01    0.32008E+04    0.53354E-39    0.96912E-46    0.21377E-45
+    3    3    0.13240E-06    0.10000E+01    0.25813E+04    0.35130E-30    0.16018E-36    0.10600E-36
+    3    3    0.13240E-06    0.10000E+01    0.20817E+04    0.66727E-14    0.12375E-19    0.19370E-20
+    3    3    0.13240E-06    0.10000E+01    0.16788E+04    0.21895E-08    0.17048E-13    0.59084E-15
+    3    3    0.13240E-06    0.10000E+01    0.13538E+04    0.43197E-08    0.63671E-13    0.96528E-15
+    3    3    0.13240E-06    0.10000E+01    0.10918E+04    0.86011E-08    0.23422E-12    0.16575E-14
+    3    3    0.13240E-06    0.10000E+01    0.88049E+03    0.17064E-07    0.85328E-12    0.29332E-14
+    3    3    0.13240E-06    0.10000E+01    0.71007E+03    0.33552E-07    0.30828E-11    0.52778E-14
+    3    3    0.13240E-06    0.10000E+01    0.57264E+03    0.65295E-07    0.10908E-10    0.95825E-14
+    3    3    0.13240E-06    0.10000E+01    0.46180E+03    0.12558E-06    0.36556E-10    0.17460E-13
+    3    3    0.13240E-06    0.10000E+01    0.37242E+03    0.23729E-06    0.11123E-09    0.31661E-13
+    3    3    0.13240E-06    0.10000E+01    0.30034E+03    0.43512E-06    0.29794E-09    0.56333E-13
+    3    3    0.13240E-06    0.10000E+01    0.24221E+03    0.76276E-06    0.69513E-09    0.96680E-13
+    3    3    0.13240E-06    0.10000E+01    0.19533E+03    0.11984E-05    0.13204E-08    0.14991E-12
+    3    3    0.13240E-06    0.10000E+01    0.15752E+03    0.11984E-05    0.13204E-08    0.14991E-12
+    3    3    0.23103E-06    0.10000E+01    0.80645E+05    0.39423E-53    0.29541E-64    0.50644E-59
+    3    3    0.23103E-06    0.10000E+01    0.65036E+05    0.33393E-52    0.46958E-63    0.42918E-58
+    3    3    0.23103E-06    0.10000E+01    0.52449E+05    0.28406E-51    0.63172E-62    0.36523E-57
+    3    3    0.23103E-06    0.10000E+01    0.42297E+05    0.21392E-50    0.85940E-61    0.27526E-56
+    3    3    0.23103E-06    0.10000E+01    0.34111E+05    0.15449E-49    0.11816E-59    0.19905E-55
+    3    3    0.23103E-06    0.10000E+01    0.27509E+05    0.11112E-48    0.16050E-58    0.14347E-54
+    3    3    0.23103E-06    0.10000E+01    0.22184E+05    0.79352E-48    0.21420E-57    0.10281E-53
+    3    3    0.23103E-06    0.10000E+01    0.17891E+05    0.55869E-47    0.28070E-56    0.72766E-53
+    3    3    0.23103E-06    0.10000E+01    0.14428E+05    0.38679E-46    0.36218E-55    0.50754E-52
+    3    3    0.23103E-06    0.10000E+01    0.11635E+05    0.26349E-45    0.45969E-54    0.34908E-51
+    3    3    0.23103E-06    0.10000E+01    0.93834E+04    0.17651E-44    0.56857E-53    0.23656E-50
+    3    3    0.23103E-06    0.10000E+01    0.75673E+04    0.11556E-43    0.67581E-52    0.15693E-49
+    3    3    0.23103E-06    0.10000E+01    0.61026E+04    0.73191E-43    0.77240E-51    0.10048E-48
+    3    3    0.23103E-06    0.10000E+01    0.49215E+04    0.44880E-42    0.92764E-50    0.60851E-48
+    3    3    0.23103E-06    0.10000E+01    0.39689E+04    0.28415E-41    0.14973E-48    0.34605E-47
+    3    3    0.23103E-06    0.10000E+01    0.32008E+04    0.71441E-39    0.11251E-45    0.64725E-45
+    3    3    0.23103E-06    0.10000E+01    0.25813E+04    0.42694E-30    0.18242E-36    0.28979E-36
+    3    3    0.23103E-06    0.10000E+01    0.20817E+04    0.80153E-14    0.13339E-19    0.51701E-20
+    3    3    0.23103E-06    0.10000E+01    0.16788E+04    0.25733E-08    0.17500E-13    0.15437E-14
+    3    3    0.23103E-06    0.10000E+01    0.13538E+04    0.48207E-08    0.64574E-13    0.23684E-14
+    3    3    0.23103E-06    0.10000E+01    0.10918E+04    0.92602E-08    0.23530E-12    0.38299E-14
+    3    3    0.23103E-06    0.10000E+01    0.88049E+03    0.17916E-07    0.85107E-12    0.64200E-14
+    3    3    0.23103E-06    0.10000E+01    0.71007E+03    0.34600E-07    0.30587E-11    0.11014E-13
+    3    3    0.23103E-06    0.10000E+01    0.57264E+03    0.66452E-07    0.10783E-10    0.19189E-13
+    3    3    0.23103E-06    0.10000E+01    0.46180E+03    0.12656E-06    0.36055E-10    0.33763E-13
+    3    3    0.23103E-06    0.10000E+01    0.37242E+03    0.23742E-06    0.10955E-09    0.59507E-13
+    3    3    0.23103E-06    0.10000E+01    0.30034E+03    0.43314E-06    0.29320E-09    0.10359E-12
+    3    3    0.23103E-06    0.10000E+01    0.24221E+03    0.75661E-06    0.68373E-09    0.17495E-12
+    3    3    0.23103E-06    0.10000E+01    0.19533E+03    0.11862E-05    0.12984E-08    0.26851E-12
+    3    3    0.23103E-06    0.10000E+01    0.15752E+03    0.11862E-05    0.12984E-08    0.26851E-12
+    3    3    0.40314E-06    0.10000E+01    0.80645E+05    0.70114E-53    0.52555E-64    0.15497E-58
+    3    3    0.40314E-06    0.10000E+01    0.65036E+05    0.59405E-52    0.83556E-63    0.13135E-57
+    3    3    0.40314E-06    0.10000E+01    0.52449E+05    0.50543E-51    0.11246E-61    0.11179E-56
+    3    3    0.40314E-06    0.10000E+01    0.42297E+05    0.38078E-50    0.15311E-60    0.84272E-56
+    3    3    0.40314E-06    0.10000E+01    0.34111E+05    0.27518E-49    0.21078E-59    0.60965E-55
+    3    3    0.40314E-06    0.10000E+01    0.27509E+05    0.19814E-48    0.28688E-58    0.43972E-54
+    3    3    0.40314E-06    0.10000E+01    0.22184E+05    0.14175E-47    0.38407E-57    0.31542E-53
+    3    3    0.40314E-06    0.10000E+01    0.17891E+05    0.10007E-46    0.50553E-56    0.22362E-52
+    3    3    0.40314E-06    0.10000E+01    0.14428E+05    0.69552E-46    0.65586E-55    0.15633E-51
+    3    3    0.40314E-06    0.10000E+01    0.11635E+05    0.47617E-45    0.83783E-54    0.10786E-50
+    3    3    0.40314E-06    0.10000E+01    0.93834E+04    0.32089E-44    0.10439E-52    0.73382E-50
+    3    3    0.40314E-06    0.10000E+01    0.75673E+04    0.21150E-43    0.12478E-51    0.48945E-49
+    3    3    0.40314E-06    0.10000E+01    0.61026E+04    0.13464E-42    0.14101E-50    0.31591E-48
+    3    3    0.40314E-06    0.10000E+01    0.49215E+04    0.81894E-42    0.15640E-49    0.19338E-47
+    3    3    0.40314E-06    0.10000E+01    0.39689E+04    0.48900E-41    0.21141E-48    0.11058E-46
+    3    3    0.40314E-06    0.10000E+01    0.32008E+04    0.10659E-38    0.14047E-45    0.20011E-44
+    3    3    0.40314E-06    0.10000E+01    0.25813E+04    0.56655E-30    0.22069E-36    0.82800E-36
+    3    3    0.40314E-06    0.10000E+01    0.20817E+04    0.10442E-13    0.15063E-19    0.14434E-19
+    3    3    0.40314E-06    0.10000E+01    0.16788E+04    0.32665E-08    0.18407E-13    0.42431E-14
+    3    3    0.40314E-06    0.10000E+01    0.13538E+04    0.57313E-08    0.66643E-13    0.61928E-14
+    3    3    0.40314E-06    0.10000E+01    0.10918E+04    0.10475E-07    0.23916E-12    0.95032E-14
+    3    3    0.40314E-06    0.10000E+01    0.88049E+03    0.19532E-07    0.85486E-12    0.15125E-13
+    3    3    0.40314E-06    0.10000E+01    0.71007E+03    0.36690E-07    0.30455E-11    0.24689E-13
+    3    3    0.40314E-06    0.10000E+01    0.57264E+03    0.69002E-07    0.10672E-10    0.41048E-13
+    3    3    0.40314E-06    0.10000E+01    0.46180E+03    0.12934E-06    0.35543E-10    0.69204E-13
+    3    3    0.40314E-06    0.10000E+01    0.37242E+03    0.23978E-06    0.10773E-09    0.11752E-12
+    3    3    0.40314E-06    0.10000E+01    0.30034E+03    0.43373E-06    0.28794E-09    0.19846E-12
+    3    3    0.40314E-06    0.10000E+01    0.24221E+03    0.75315E-06    0.67089E-09    0.32752E-12
+    3    3    0.40314E-06    0.10000E+01    0.19533E+03    0.11764E-05    0.12734E-08    0.49506E-12
+    3    3    0.40314E-06    0.10000E+01    0.15752E+03    0.11764E-05    0.12734E-08    0.49506E-12
+    3    3    0.70346E-06    0.10000E+01    0.80645E+05    0.12298E-52    0.92188E-64    0.32838E-58
+    3    3    0.70346E-06    0.10000E+01    0.65036E+05    0.10420E-51    0.14658E-62    0.27834E-57
+    3    3    0.70346E-06    0.10000E+01    0.52449E+05    0.88662E-51    0.19731E-61    0.23691E-56
+    3    3    0.70346E-06    0.10000E+01    0.42297E+05    0.66805E-50    0.26870E-60    0.17860E-55
+    3    3    0.70346E-06    0.10000E+01    0.34111E+05    0.48289E-49    0.37003E-59    0.12922E-54
+    3    3    0.70346E-06    0.10000E+01    0.27509E+05    0.34782E-48    0.50395E-58    0.93223E-54
+    3    3    0.70346E-06    0.10000E+01    0.22184E+05    0.24896E-47    0.67533E-57    0.66892E-53
+    3    3    0.70346E-06    0.10000E+01    0.17891E+05    0.17591E-46    0.89010E-56    0.47445E-52
+    3    3    0.70346E-06    0.10000E+01    0.14428E+05    0.12240E-45    0.11568E-54    0.33193E-51
+    3    3    0.70346E-06    0.10000E+01    0.11635E+05    0.83930E-45    0.14808E-53    0.22920E-50
+    3    3    0.70346E-06    0.10000E+01    0.93834E+04    0.56669E-44    0.18496E-52    0.15613E-49
+    3    3    0.70346E-06    0.10000E+01    0.75673E+04    0.37437E-43    0.22171E-51    0.10430E-48
+    3    3    0.70346E-06    0.10000E+01    0.61026E+04    0.23892E-42    0.25054E-50    0.67478E-48
+    3    3    0.70346E-06    0.10000E+01    0.49215E+04    0.14534E-41    0.27333E-49    0.41443E-47
+    3    3    0.70346E-06    0.10000E+01    0.39689E+04    0.85764E-41    0.35035E-48    0.23757E-46
+    3    3    0.70346E-06    0.10000E+01    0.32008E+04    0.17962E-38    0.22143E-45    0.42684E-44
+    3    3    0.70346E-06    0.10000E+01    0.25813E+04    0.91479E-30    0.34288E-36    0.17271E-35
+    3    3    0.70346E-06    0.10000E+01    0.20817E+04    0.16725E-13    0.22781E-19    0.29881E-19
+    3    3    0.70346E-06    0.10000E+01    0.16788E+04    0.51829E-08    0.26979E-13    0.87476E-14
+    3    3    0.70346E-06    0.10000E+01    0.13538E+04    0.88650E-08    0.96804E-13    0.12587E-13
+    3    3    0.70346E-06    0.10000E+01    0.10918E+04    0.15869E-07    0.34484E-12    0.19016E-13
+    3    3    0.70346E-06    0.10000E+01    0.88049E+03    0.29110E-07    0.12254E-11    0.29774E-13
+    3    3    0.70346E-06    0.10000E+01    0.71007E+03    0.53993E-07    0.43467E-11    0.47799E-13
+    3    3    0.70346E-06    0.10000E+01    0.57264E+03    0.10054E-06    0.15185E-10    0.78163E-13
+    3    3    0.70346E-06    0.10000E+01    0.46180E+03    0.18701E-06    0.50472E-10    0.12968E-12
+    3    3    0.70346E-06    0.10000E+01    0.37242E+03    0.34467E-06    0.15280E-09    0.21701E-12
+    3    3    0.70346E-06    0.10000E+01    0.30034E+03    0.62081E-06    0.40810E-09    0.36190E-12
+    3    3    0.70346E-06    0.10000E+01    0.24221E+03    0.10748E-05    0.95043E-09    0.59135E-12
+    3    3    0.70346E-06    0.10000E+01    0.19533E+03    0.16757E-05    0.18035E-08    0.88787E-12
+    3    3    0.70346E-06    0.10000E+01    0.15752E+03    0.16757E-05    0.18035E-08    0.88787E-12
+    3    3    0.12275E-05    0.10000E+01    0.80645E+05    0.21459E-52    0.16086E-63    0.57300E-58
+    3    3    0.12275E-05    0.10000E+01    0.65036E+05    0.18183E-51    0.25577E-62    0.48569E-57
+    3    3    0.12275E-05    0.10000E+01    0.52449E+05    0.15471E-50    0.34429E-61    0.41339E-56
+    3    3    0.12275E-05    0.10000E+01    0.42297E+05    0.11657E-49    0.46887E-60    0.31165E-55
+    3    3    0.12275E-05    0.10000E+01    0.34111E+05    0.84261E-49    0.64569E-59    0.22549E-54
+    3    3    0.12275E-05    0.10000E+01    0.27509E+05    0.60692E-48    0.87937E-58    0.16267E-53
+    3    3    0.12275E-05    0.10000E+01    0.22184E+05    0.43442E-47    0.11784E-56    0.11672E-52
+    3    3    0.12275E-05    0.10000E+01    0.17891E+05    0.30696E-46    0.15532E-55    0.82789E-52
+    3    3    0.12275E-05    0.10000E+01    0.14428E+05    0.21359E-45    0.20185E-54    0.57919E-51
+    3    3    0.12275E-05    0.10000E+01    0.11635E+05    0.14645E-44    0.25838E-53    0.39995E-50
+    3    3    0.12275E-05    0.10000E+01    0.93834E+04    0.98884E-44    0.32275E-52    0.27244E-49
+    3    3    0.12275E-05    0.10000E+01    0.75673E+04    0.65325E-43    0.38687E-51    0.18200E-48
+    3    3    0.12275E-05    0.10000E+01    0.61026E+04    0.41690E-42    0.43718E-50    0.11775E-47
+    3    3    0.12275E-05    0.10000E+01    0.49215E+04    0.25361E-41    0.47695E-49    0.72315E-47
+    3    3    0.12275E-05    0.10000E+01    0.39689E+04    0.14965E-40    0.61134E-48    0.41455E-46
+    3    3    0.12275E-05    0.10000E+01    0.32008E+04    0.31343E-38    0.38638E-45    0.74481E-44
+    3    3    0.12275E-05    0.10000E+01    0.25813E+04    0.15963E-29    0.59830E-36    0.30137E-35
+    3    3    0.12275E-05    0.10000E+01    0.20817E+04    0.29185E-13    0.39751E-19    0.52140E-19
+    3    3    0.12275E-05    0.10000E+01    0.16788E+04    0.90438E-08    0.47077E-13    0.15264E-13
+    3    3    0.12275E-05    0.10000E+01    0.13538E+04    0.15469E-07    0.16892E-12    0.21964E-13
+    3    3    0.12275E-05    0.10000E+01    0.10918E+04    0.27691E-07    0.60172E-12    0.33181E-13
+    3    3    0.12275E-05    0.10000E+01    0.88049E+03    0.50796E-07    0.21383E-11    0.51954E-13
+    3    3    0.12275E-05    0.10000E+01    0.71007E+03    0.94214E-07    0.75848E-11    0.83406E-13
+    3    3    0.12275E-05    0.10000E+01    0.57264E+03    0.17543E-06    0.26496E-10    0.13639E-12
+    3    3    0.12275E-05    0.10000E+01    0.46180E+03    0.32632E-06    0.88071E-10    0.22629E-12
+    3    3    0.12275E-05    0.10000E+01    0.37242E+03    0.60143E-06    0.26663E-09    0.37866E-12
+    3    3    0.12275E-05    0.10000E+01    0.30034E+03    0.10833E-05    0.71210E-09    0.63150E-12
+    3    3    0.12275E-05    0.10000E+01    0.24221E+03    0.18755E-05    0.16585E-08    0.10319E-11
+    3    3    0.12275E-05    0.10000E+01    0.19533E+03    0.29241E-05    0.31470E-08    0.15493E-11
+    3    3    0.12275E-05    0.10000E+01    0.15752E+03    0.29241E-05    0.31470E-08    0.15493E-11
+    3    3    0.21419E-05    0.10000E+01    0.80645E+05    0.37444E-52    0.28070E-63    0.99986E-58
+    3    3    0.21419E-05    0.10000E+01    0.65036E+05    0.31727E-51    0.44630E-62    0.84750E-57
+    3    3    0.21419E-05    0.10000E+01    0.52449E+05    0.26996E-50    0.60077E-61    0.72133E-56
+    3    3    0.21419E-05    0.10000E+01    0.42297E+05    0.20341E-49    0.81814E-60    0.54381E-55
+    3    3    0.21419E-05    0.10000E+01    0.34111E+05    0.14703E-48    0.11267E-58    0.39346E-54
+    3    3    0.21419E-05    0.10000E+01    0.27509E+05    0.10590E-47    0.15344E-57    0.28385E-53
+    3    3    0.21419E-05    0.10000E+01    0.22184E+05    0.75804E-47    0.20563E-56    0.20367E-52
+    3    3    0.21419E-05    0.10000E+01    0.17891E+05    0.53562E-46    0.27102E-55    0.14446E-51
+    3    3    0.21419E-05    0.10000E+01    0.14428E+05    0.37270E-45    0.35221E-54    0.10107E-50
+    3    3    0.21419E-05    0.10000E+01    0.11635E+05    0.25555E-44    0.45087E-53    0.69788E-50
+    3    3    0.21419E-05    0.10000E+01    0.93834E+04    0.17255E-43    0.56317E-52    0.47538E-49
+    3    3    0.21419E-05    0.10000E+01    0.75673E+04    0.11399E-42    0.67506E-51    0.31758E-48
+    3    3    0.21419E-05    0.10000E+01    0.61026E+04    0.72746E-42    0.76286E-50    0.20546E-47
+    3    3    0.21419E-05    0.10000E+01    0.49215E+04    0.44254E-41    0.83224E-49    0.12619E-46
+    3    3    0.21419E-05    0.10000E+01    0.39689E+04    0.26113E-40    0.10667E-47    0.72336E-46
+    3    3    0.21419E-05    0.10000E+01    0.32008E+04    0.54692E-38    0.67422E-45    0.12996E-43
+    3    3    0.21419E-05    0.10000E+01    0.25813E+04    0.27854E-29    0.10440E-35    0.52588E-35
+    3    3    0.21419E-05    0.10000E+01    0.20817E+04    0.50926E-13    0.69363E-19    0.90982E-19
+    3    3    0.21419E-05    0.10000E+01    0.16788E+04    0.15781E-07    0.82147E-13    0.26635E-13
+    3    3    0.21419E-05    0.10000E+01    0.13538E+04    0.26992E-07    0.29475E-12    0.38325E-13
+    3    3    0.21419E-05    0.10000E+01    0.10918E+04    0.48319E-07    0.10500E-11    0.57899E-13
+    3    3    0.21419E-05    0.10000E+01    0.88049E+03    0.88636E-07    0.37312E-11    0.90656E-13
+    3    3    0.21419E-05    0.10000E+01    0.71007E+03    0.16440E-06    0.13235E-10    0.14554E-12
+    3    3    0.21419E-05    0.10000E+01    0.57264E+03    0.30612E-06    0.46234E-10    0.23799E-12
+    3    3    0.21419E-05    0.10000E+01    0.46180E+03    0.56941E-06    0.15368E-09    0.39486E-12
+    3    3    0.21419E-05    0.10000E+01    0.37242E+03    0.10495E-05    0.46525E-09    0.66075E-12
+    3    3    0.21419E-05    0.10000E+01    0.30034E+03    0.18902E-05    0.12426E-08    0.11019E-11
+    3    3    0.21419E-05    0.10000E+01    0.24221E+03    0.32726E-05    0.28939E-08    0.18005E-11
+    3    3    0.21419E-05    0.10000E+01    0.19533E+03    0.51023E-05    0.54914E-08    0.27034E-11
+    3    3    0.21419E-05    0.10000E+01    0.15752E+03    0.51023E-05    0.54914E-08    0.27034E-11
+    3    3    0.37375E-05    0.10000E+01    0.80645E+05    0.65338E-52    0.48980E-63    0.17447E-57
+    3    3    0.37375E-05    0.10000E+01    0.65036E+05    0.55362E-51    0.77877E-62    0.14788E-56
+    3    3    0.37375E-05    0.10000E+01    0.52449E+05    0.47106E-50    0.10483E-60    0.12587E-55
+    3    3    0.37375E-05    0.10000E+01    0.42297E+05    0.35494E-49    0.14276E-59    0.94892E-55
+    3    3    0.37375E-05    0.10000E+01    0.34111E+05    0.25656E-48    0.19660E-58    0.68656E-54
+    3    3    0.37375E-05    0.10000E+01    0.27509E+05    0.18480E-47    0.26775E-57    0.49529E-53
+    3    3    0.37375E-05    0.10000E+01    0.22184E+05    0.13227E-46    0.35881E-56    0.35540E-52
+    3    3    0.37375E-05    0.10000E+01    0.17891E+05    0.93463E-46    0.47291E-55    0.25208E-51
+    3    3    0.37375E-05    0.10000E+01    0.14428E+05    0.65033E-45    0.61459E-54    0.17635E-50
+    3    3    0.37375E-05    0.10000E+01    0.11635E+05    0.44592E-44    0.78673E-53    0.12178E-49
+    3    3    0.37375E-05    0.10000E+01    0.93834E+04    0.30108E-43    0.98270E-52    0.82952E-49
+    3    3    0.37375E-05    0.10000E+01    0.75673E+04    0.19890E-42    0.11779E-50    0.55416E-48
+    3    3    0.37375E-05    0.10000E+01    0.61026E+04    0.12694E-41    0.13311E-49    0.35851E-47
+    3    3    0.37375E-05    0.10000E+01    0.49215E+04    0.77220E-41    0.14522E-48    0.22019E-46
+    3    3    0.37375E-05    0.10000E+01    0.39689E+04    0.45566E-40    0.18614E-47    0.12622E-45
+    3    3    0.37375E-05    0.10000E+01    0.32008E+04    0.95434E-38    0.11765E-44    0.22678E-43
+    3    3    0.37375E-05    0.10000E+01    0.25813E+04    0.48603E-29    0.18217E-35    0.91763E-35
+    3    3    0.37375E-05    0.10000E+01    0.20817E+04    0.88863E-13    0.12103E-18    0.15876E-18
+    3    3    0.37375E-05    0.10000E+01    0.16788E+04    0.27537E-07    0.14334E-12    0.46476E-13
+    3    3    0.37375E-05    0.10000E+01    0.13538E+04    0.47100E-07    0.51432E-12    0.66875E-13
+    3    3    0.37375E-05    0.10000E+01    0.10918E+04    0.84314E-07    0.18321E-11    0.10103E-12
+    3    3    0.37375E-05    0.10000E+01    0.88049E+03    0.15466E-06    0.65108E-11    0.15819E-12
+    3    3    0.37375E-05    0.10000E+01    0.71007E+03    0.28686E-06    0.23094E-10    0.25395E-12
+    3    3    0.37375E-05    0.10000E+01    0.57264E+03    0.53417E-06    0.80676E-10    0.41528E-12
+    3    3    0.37375E-05    0.10000E+01    0.46180E+03    0.99359E-06    0.26816E-09    0.68900E-12
+    3    3    0.37375E-05    0.10000E+01    0.37242E+03    0.18312E-05    0.81183E-09    0.11530E-11
+    3    3    0.37375E-05    0.10000E+01    0.30034E+03    0.32984E-05    0.21682E-08    0.19228E-11
+    3    3    0.37375E-05    0.10000E+01    0.24221E+03    0.57104E-05    0.50497E-08    0.31418E-11
+    3    3    0.37375E-05    0.10000E+01    0.19533E+03    0.89032E-05    0.95821E-08    0.47173E-11
+    3    3    0.37375E-05    0.10000E+01    0.15752E+03    0.89032E-05    0.95821E-08    0.47173E-11
+    3    3    0.65217E-05    0.10000E+01    0.80645E+05    0.11401E-51    0.85467E-63    0.30444E-57
+    3    3    0.65217E-05    0.10000E+01    0.65036E+05    0.96604E-51    0.13589E-61    0.25805E-56
+    3    3    0.65217E-05    0.10000E+01    0.52449E+05    0.82198E-50    0.18292E-60    0.21963E-55
+    3    3    0.65217E-05    0.10000E+01    0.42297E+05    0.61935E-49    0.24911E-59    0.16558E-54
+    3    3    0.65217E-05    0.10000E+01    0.34111E+05    0.44768E-48    0.34306E-58    0.11980E-53
+    3    3    0.65217E-05    0.10000E+01    0.27509E+05    0.32246E-47    0.46721E-57    0.86426E-53
+    3    3    0.65217E-05    0.10000E+01    0.22184E+05    0.23081E-46    0.62609E-56    0.62015E-52
+    3    3    0.65217E-05    0.10000E+01    0.17891E+05    0.16309E-45    0.82520E-55    0.43986E-51
+    3    3    0.65217E-05    0.10000E+01    0.14428E+05    0.11348E-44    0.10724E-53    0.30772E-50
+    3    3    0.65217E-05    0.10000E+01    0.11635E+05    0.77811E-44    0.13728E-52    0.21249E-49
+    3    3    0.65217E-05    0.10000E+01    0.93834E+04    0.52537E-43    0.17148E-51    0.14475E-48
+    3    3    0.65217E-05    0.10000E+01    0.75673E+04    0.34707E-42    0.20554E-50    0.96698E-48
+    3    3    0.65217E-05    0.10000E+01    0.61026E+04    0.22150E-41    0.23228E-49    0.62558E-47
+    3    3    0.65217E-05    0.10000E+01    0.49215E+04    0.13474E-40    0.25340E-48    0.38421E-46
+    3    3    0.65217E-05    0.10000E+01    0.39689E+04    0.79510E-40    0.32480E-47    0.22025E-45
+    3    3    0.65217E-05    0.10000E+01    0.32008E+04    0.16653E-37    0.20529E-44    0.39572E-43
+    3    3    0.65217E-05    0.10000E+01    0.25813E+04    0.84810E-29    0.31788E-35    0.16012E-34
+    3    3    0.65217E-05    0.10000E+01    0.20817E+04    0.15506E-12    0.21120E-18    0.27702E-18
+    3    3    0.65217E-05    0.10000E+01    0.16788E+04    0.48050E-07    0.25012E-12    0.81098E-13
+    3    3    0.65217E-05    0.10000E+01    0.13538E+04    0.82186E-07    0.89746E-12    0.11669E-12
+    3    3    0.65217E-05    0.10000E+01    0.10918E+04    0.14712E-06    0.31969E-11    0.17629E-12
+    3    3    0.65217E-05    0.10000E+01    0.88049E+03    0.26988E-06    0.11361E-10    0.27603E-12
+    3    3    0.65217E-05    0.10000E+01    0.71007E+03    0.50056E-06    0.40298E-10    0.44314E-12
+    3    3    0.65217E-05    0.10000E+01    0.57264E+03    0.93209E-06    0.14077E-09    0.72464E-12
+    3    3    0.65217E-05    0.10000E+01    0.46180E+03    0.17338E-05    0.46792E-09    0.12023E-11
+    3    3    0.65217E-05    0.10000E+01    0.37242E+03    0.31954E-05    0.14166E-08    0.20119E-11
+    3    3    0.65217E-05    0.10000E+01    0.30034E+03    0.57555E-05    0.37834E-08    0.33552E-11
+    3    3    0.65217E-05    0.10000E+01    0.24221E+03    0.99644E-05    0.88114E-08    0.54823E-11
+    3    3    0.65217E-05    0.10000E+01    0.19533E+03    0.15536E-04    0.16720E-07    0.82313E-11
+    3    3    0.65217E-05    0.10000E+01    0.15752E+03    0.15536E-04    0.16720E-07    0.82313E-11
+    3    3    0.11380E-04    0.10000E+01    0.80645E+05    0.19894E-51    0.14913E-62    0.53123E-57
+    3    3    0.11380E-04    0.10000E+01    0.65036E+05    0.16857E-50    0.23712E-61    0.45028E-56
+    3    3    0.11380E-04    0.10000E+01    0.52449E+05    0.14343E-49    0.31919E-60    0.38325E-55
+    3    3    0.11380E-04    0.10000E+01    0.42297E+05    0.10807E-48    0.43468E-59    0.28893E-54
+    3    3    0.11380E-04    0.10000E+01    0.34111E+05    0.78117E-48    0.59861E-58    0.20905E-53
+    3    3    0.11380E-04    0.10000E+01    0.27509E+05    0.56267E-47    0.81525E-57    0.15081E-52
+    3    3    0.11380E-04    0.10000E+01    0.22184E+05    0.40275E-46    0.10925E-55    0.10821E-51
+    3    3    0.11380E-04    0.10000E+01    0.17891E+05    0.28458E-45    0.14399E-54    0.76753E-51
+    3    3    0.11380E-04    0.10000E+01    0.14428E+05    0.19801E-44    0.18713E-53    0.53696E-50
+    3    3    0.11380E-04    0.10000E+01    0.11635E+05    0.13578E-43    0.23955E-52    0.37079E-49
+    3    3    0.11380E-04    0.10000E+01    0.93834E+04    0.91675E-43    0.29921E-51    0.25257E-48
+    3    3    0.11380E-04    0.10000E+01    0.75673E+04    0.60562E-42    0.35866E-50    0.16873E-47
+    3    3    0.11380E-04    0.10000E+01    0.61026E+04    0.38650E-41    0.40531E-49    0.10916E-46
+    3    3    0.11380E-04    0.10000E+01    0.49215E+04    0.23512E-40    0.44217E-48    0.67043E-46
+    3    3    0.11380E-04    0.10000E+01    0.39689E+04    0.13874E-39    0.56676E-47    0.38432E-45
+    3    3    0.11380E-04    0.10000E+01    0.32008E+04    0.29058E-37    0.35821E-44    0.69050E-43
+    3    3    0.11380E-04    0.10000E+01    0.25813E+04    0.14799E-28    0.55468E-35    0.27940E-34
+    3    3    0.11380E-04    0.10000E+01    0.20817E+04    0.27057E-12    0.36852E-18    0.48339E-18
+    3    3    0.11380E-04    0.10000E+01    0.16788E+04    0.83844E-07    0.43645E-12    0.14151E-12
+    3    3    0.11380E-04    0.10000E+01    0.13538E+04    0.14341E-06    0.15660E-11    0.20362E-12
+    3    3    0.11380E-04    0.10000E+01    0.10918E+04    0.25672E-06    0.55785E-11    0.30762E-12
+    3    3    0.11380E-04    0.10000E+01    0.88049E+03    0.47092E-06    0.19824E-10    0.48166E-12
+    3    3    0.11380E-04    0.10000E+01    0.71007E+03    0.87345E-06    0.70318E-10    0.77324E-12
+    3    3    0.11380E-04    0.10000E+01    0.57264E+03    0.16264E-05    0.24564E-09    0.12645E-11
+    3    3    0.11380E-04    0.10000E+01    0.46180E+03    0.30253E-05    0.81650E-09    0.20979E-11
+    3    3    0.11380E-04    0.10000E+01    0.37242E+03    0.55758E-05    0.24719E-08    0.35106E-11
+    3    3    0.11380E-04    0.10000E+01    0.30034E+03    0.10043E-04    0.66018E-08    0.58546E-11
+    3    3    0.11380E-04    0.10000E+01    0.24221E+03    0.17387E-04    0.15375E-07    0.95663E-11
+    3    3    0.11380E-04    0.10000E+01    0.19533E+03    0.27109E-04    0.29176E-07    0.14363E-10
+    3    3    0.11380E-04    0.10000E+01    0.15752E+03    0.27109E-04    0.29176E-07    0.14363E-10
+    3    3    0.19857E-04    0.10000E+01    0.80645E+05    0.34714E-51    0.26023E-62    0.92696E-57
+    3    3    0.19857E-04    0.10000E+01    0.65036E+05    0.29414E-50    0.41376E-61    0.78571E-56
+    3    3    0.19857E-04    0.10000E+01    0.52449E+05    0.25028E-49    0.55697E-60    0.66874E-55
+    3    3    0.19857E-04    0.10000E+01    0.42297E+05    0.18858E-48    0.75849E-59    0.50416E-54
+    3    3    0.19857E-04    0.10000E+01    0.34111E+05    0.13631E-47    0.10445E-57    0.36477E-53
+    3    3    0.19857E-04    0.10000E+01    0.27509E+05    0.98182E-47    0.14226E-56    0.26315E-52
+    3    3    0.19857E-04    0.10000E+01    0.22184E+05    0.70277E-46    0.19063E-55    0.18882E-51
+    3    3    0.19857E-04    0.10000E+01    0.17891E+05    0.49657E-45    0.25126E-54    0.13393E-50
+    3    3    0.19857E-04    0.10000E+01    0.14428E+05    0.34552E-44    0.32653E-53    0.93696E-50
+    3    3    0.19857E-04    0.10000E+01    0.11635E+05    0.23692E-43    0.41799E-52    0.64700E-49
+    3    3    0.19857E-04    0.10000E+01    0.93834E+04    0.15997E-42    0.52211E-51    0.44072E-48
+    3    3    0.19857E-04    0.10000E+01    0.75673E+04    0.10568E-41    0.62584E-50    0.29443E-47
+    3    3    0.19857E-04    0.10000E+01    0.61026E+04    0.67442E-41    0.70724E-49    0.19048E-46
+    3    3    0.19857E-04    0.10000E+01    0.49215E+04    0.41027E-40    0.77156E-48    0.11699E-45
+    3    3    0.19857E-04    0.10000E+01    0.39689E+04    0.24209E-39    0.98897E-47    0.67062E-45
+    3    3    0.19857E-04    0.10000E+01    0.32008E+04    0.50704E-37    0.62506E-44    0.12049E-42
+    3    3    0.19857E-04    0.10000E+01    0.25813E+04    0.25823E-28    0.96788E-35    0.48754E-34
+    3    3    0.19857E-04    0.10000E+01    0.20817E+04    0.47213E-12    0.64305E-18    0.84348E-18
+    3    3    0.19857E-04    0.10000E+01    0.16788E+04    0.14630E-06    0.76158E-12    0.24693E-12
+    3    3    0.19857E-04    0.10000E+01    0.13538E+04    0.25024E-06    0.27326E-11    0.35531E-12
+    3    3    0.19857E-04    0.10000E+01    0.10918E+04    0.44796E-06    0.97341E-11    0.53677E-12
+    3    3    0.19857E-04    0.10000E+01    0.88049E+03    0.82173E-06    0.34592E-10    0.84047E-12
+    3    3    0.19857E-04    0.10000E+01    0.71007E+03    0.15241E-05    0.12270E-09    0.13493E-11
+    3    3    0.19857E-04    0.10000E+01    0.57264E+03    0.28380E-05    0.42863E-09    0.22064E-11
+    3    3    0.19857E-04    0.10000E+01    0.46180E+03    0.52790E-05    0.14247E-08    0.36607E-11
+    3    3    0.19857E-04    0.10000E+01    0.37242E+03    0.97295E-05    0.43133E-08    0.61257E-11
+    3    3    0.19857E-04    0.10000E+01    0.30034E+03    0.17524E-04    0.11520E-07    0.10216E-10
+    3    3    0.19857E-04    0.10000E+01    0.24221E+03    0.30340E-04    0.26829E-07    0.16693E-10
+    3    3    0.19857E-04    0.10000E+01    0.19533E+03    0.47303E-04    0.50910E-07    0.25063E-10
+    3    3    0.19857E-04    0.10000E+01    0.15752E+03    0.47303E-04    0.50910E-07    0.25063E-10
+    3    3    0.34650E-04    0.10000E+01    0.80645E+05    0.60574E-51    0.45409E-62    0.16175E-56
+    3    3    0.34650E-04    0.10000E+01    0.65036E+05    0.51326E-50    0.72198E-61    0.13710E-55
+    3    3    0.34650E-04    0.10000E+01    0.52449E+05    0.43672E-49    0.97188E-60    0.11669E-54
+    3    3    0.34650E-04    0.10000E+01    0.42297E+05    0.32906E-48    0.13235E-58    0.87973E-54
+    3    3    0.34650E-04    0.10000E+01    0.34111E+05    0.23785E-47    0.18227E-57    0.63650E-53
+    3    3    0.34650E-04    0.10000E+01    0.27509E+05    0.17132E-46    0.24823E-56    0.45918E-52
+    3    3    0.34650E-04    0.10000E+01    0.22184E+05    0.12263E-45    0.33264E-55    0.32949E-51
+    3    3    0.34650E-04    0.10000E+01    0.17891E+05    0.86648E-45    0.43843E-54    0.23370E-50
+    3    3    0.34650E-04    0.10000E+01    0.14428E+05    0.60292E-44    0.56978E-53    0.16349E-49
+    3    3    0.34650E-04    0.10000E+01    0.11635E+05    0.41341E-43    0.72937E-52    0.11290E-48
+    3    3    0.34650E-04    0.10000E+01    0.93834E+04    0.27913E-42    0.91105E-51    0.76904E-48
+    3    3    0.34650E-04    0.10000E+01    0.75673E+04    0.18440E-41    0.10921E-49    0.51376E-47
+    3    3    0.34650E-04    0.10000E+01    0.61026E+04    0.11768E-40    0.12341E-48    0.33237E-46
+    3    3    0.34650E-04    0.10000E+01    0.49215E+04    0.71590E-40    0.13463E-47    0.20413E-45
+    3    3    0.34650E-04    0.10000E+01    0.39689E+04    0.42244E-39    0.17257E-46    0.11702E-44
+    3    3    0.34650E-04    0.10000E+01    0.32008E+04    0.88476E-37    0.10907E-43    0.21025E-42
+    3    3    0.34650E-04    0.10000E+01    0.25813E+04    0.45059E-28    0.16889E-34    0.85072E-34
+    3    3    0.34650E-04    0.10000E+01    0.20817E+04    0.82384E-12    0.11221E-17    0.14718E-17
+    3    3    0.34650E-04    0.10000E+01    0.16788E+04    0.25529E-06    0.13289E-11    0.43087E-12
+    3    3    0.34650E-04    0.10000E+01    0.13538E+04    0.43666E-06    0.47682E-11    0.61999E-12
+    3    3    0.34650E-04    0.10000E+01    0.10918E+04    0.78167E-06    0.16985E-10    0.93664E-12
+    3    3    0.34650E-04    0.10000E+01    0.88049E+03    0.14339E-05    0.60361E-10    0.14666E-11
+    3    3    0.34650E-04    0.10000E+01    0.71007E+03    0.26595E-05    0.21410E-09    0.23544E-11
+    3    3    0.34650E-04    0.10000E+01    0.57264E+03    0.49522E-05    0.74794E-09    0.38500E-11
+    3    3    0.34650E-04    0.10000E+01    0.46180E+03    0.92115E-05    0.24861E-08    0.63876E-11
+    3    3    0.34650E-04    0.10000E+01    0.37242E+03    0.16977E-04    0.75264E-08    0.10689E-10
+    3    3    0.34650E-04    0.10000E+01    0.30034E+03    0.30579E-04    0.20101E-07    0.17826E-10
+    3    3    0.34650E-04    0.10000E+01    0.24221E+03    0.52941E-04    0.46815E-07    0.29128E-10
+    3    3    0.34650E-04    0.10000E+01    0.19533E+03    0.82541E-04    0.88835E-07    0.43733E-10
+    3    3    0.34650E-04    0.10000E+01    0.15752E+03    0.82541E-04    0.88835E-07    0.43733E-10
+    3    3    0.60462E-04    0.10000E+01    0.80645E+05    0.10570E-50    0.79235E-62    0.28224E-56
+    3    3    0.60462E-04    0.10000E+01    0.65036E+05    0.89561E-50    0.12598E-60    0.23923E-55
+    3    3    0.60462E-04    0.10000E+01    0.52449E+05    0.76205E-49    0.16959E-59    0.20362E-54
+    3    3    0.60462E-04    0.10000E+01    0.42297E+05    0.57419E-48    0.23095E-58    0.15351E-53
+    3    3    0.60462E-04    0.10000E+01    0.34111E+05    0.41504E-47    0.31804E-57    0.11107E-52
+    3    3    0.60462E-04    0.10000E+01    0.27509E+05    0.29895E-46    0.43314E-56    0.80124E-52
+    3    3    0.60462E-04    0.10000E+01    0.22184E+05    0.21398E-45    0.58044E-55    0.57493E-51
+    3    3    0.60462E-04    0.10000E+01    0.17891E+05    0.15120E-44    0.76504E-54    0.40779E-50
+    3    3    0.60462E-04    0.10000E+01    0.14428E+05    0.10521E-43    0.99424E-53    0.28529E-49
+    3    3    0.60462E-04    0.10000E+01    0.11635E+05    0.72138E-43    0.12727E-51    0.19700E-48
+    3    3    0.60462E-04    0.10000E+01    0.93834E+04    0.48707E-42    0.15897E-50    0.13419E-47
+    3    3    0.60462E-04    0.10000E+01    0.75673E+04    0.32177E-41    0.19056E-49    0.89647E-47
+    3    3    0.60462E-04    0.10000E+01    0.61026E+04    0.20535E-40    0.21534E-48    0.57997E-46
+    3    3    0.60462E-04    0.10000E+01    0.49215E+04    0.12492E-39    0.23493E-47    0.35620E-45
+    3    3    0.60462E-04    0.10000E+01    0.39689E+04    0.73713E-39    0.30112E-46    0.20419E-44
+    3    3    0.60462E-04    0.10000E+01    0.32008E+04    0.15438E-36    0.19032E-43    0.36686E-42
+    3    3    0.60462E-04    0.10000E+01    0.25813E+04    0.78626E-28    0.29470E-34    0.14845E-33
+    3    3    0.60462E-04    0.10000E+01    0.20817E+04    0.14375E-11    0.19580E-17    0.25682E-17
+    3    3    0.60462E-04    0.10000E+01    0.16788E+04    0.44546E-06    0.23189E-11    0.75185E-12
+    3    3    0.60462E-04    0.10000E+01    0.13538E+04    0.76194E-06    0.83202E-11    0.10818E-11
+    3    3    0.60462E-04    0.10000E+01    0.10918E+04    0.13640E-05    0.29639E-10    0.16344E-11
+    3    3    0.60462E-04    0.10000E+01    0.88049E+03    0.25020E-05    0.10533E-09    0.25591E-11
+    3    3    0.60462E-04    0.10000E+01    0.71007E+03    0.46406E-05    0.37360E-09    0.41083E-11
+    3    3    0.60462E-04    0.10000E+01    0.57264E+03    0.86413E-05    0.13051E-08    0.67181E-11
+    3    3    0.60462E-04    0.10000E+01    0.46180E+03    0.16073E-04    0.43381E-08    0.11146E-10
+    3    3    0.60462E-04    0.10000E+01    0.37242E+03    0.29624E-04    0.13133E-07    0.18652E-10
+    3    3    0.60462E-04    0.10000E+01    0.30034E+03    0.53358E-04    0.35076E-07    0.31105E-10
+    3    3    0.60462E-04    0.10000E+01    0.24221E+03    0.92379E-04    0.81689E-07    0.50826E-10
+    3    3    0.60462E-04    0.10000E+01    0.19533E+03    0.14403E-03    0.15501E-06    0.76312E-10
+    3    3    0.60462E-04    0.10000E+01    0.15752E+03    0.14403E-03    0.15501E-06    0.76312E-10
+    3    3    0.10550E-03    0.10000E+01    0.80645E+05    0.18444E-50    0.13826E-61    0.49249E-56
+    3    3    0.10550E-03    0.10000E+01    0.65036E+05    0.15628E-49    0.21983E-60    0.41745E-55
+    3    3    0.10550E-03    0.10000E+01    0.52449E+05    0.13297E-48    0.29592E-59    0.35530E-54
+    3    3    0.10550E-03    0.10000E+01    0.42297E+05    0.10019E-47    0.40299E-58    0.26786E-53
+    3    3    0.10550E-03    0.10000E+01    0.34111E+05    0.72421E-47    0.55497E-57    0.19380E-52
+    3    3    0.10550E-03    0.10000E+01    0.27509E+05    0.52164E-46    0.75581E-56    0.13981E-51
+    3    3    0.10550E-03    0.10000E+01    0.22184E+05    0.37338E-45    0.10128E-54    0.10032E-50
+    3    3    0.10550E-03    0.10000E+01    0.17891E+05    0.26383E-44    0.13349E-53    0.71157E-50
+    3    3    0.10550E-03    0.10000E+01    0.14428E+05    0.18358E-43    0.17349E-52    0.49781E-49
+    3    3    0.10550E-03    0.10000E+01    0.11635E+05    0.12588E-42    0.22208E-51    0.34375E-48
+    3    3    0.10550E-03    0.10000E+01    0.93834E+04    0.84991E-42    0.27740E-50    0.23416E-47
+    3    3    0.10550E-03    0.10000E+01    0.75673E+04    0.56146E-41    0.33251E-49    0.15643E-46
+    3    3    0.10550E-03    0.10000E+01    0.61026E+04    0.35832E-40    0.37576E-48    0.10120E-45
+    3    3    0.10550E-03    0.10000E+01    0.49215E+04    0.21798E-39    0.40993E-47    0.62155E-45
+    3    3    0.10550E-03    0.10000E+01    0.39689E+04    0.12863E-38    0.52544E-46    0.35630E-44
+    3    3    0.10550E-03    0.10000E+01    0.32008E+04    0.26939E-36    0.33209E-43    0.64016E-42
+    3    3    0.10550E-03    0.10000E+01    0.25813E+04    0.13720E-27    0.51423E-34    0.25903E-33
+    3    3    0.10550E-03    0.10000E+01    0.20817E+04    0.25084E-11    0.34166E-17    0.44814E-17
+    3    3    0.10550E-03    0.10000E+01    0.16788E+04    0.77731E-06    0.40463E-11    0.13119E-11
+    3    3    0.10550E-03    0.10000E+01    0.13538E+04    0.13295E-05    0.14518E-10    0.18878E-11
+    3    3    0.10550E-03    0.10000E+01    0.10918E+04    0.23800E-05    0.51718E-10    0.28519E-11
+    3    3    0.10550E-03    0.10000E+01    0.88049E+03    0.43659E-05    0.18379E-09    0.44654E-11
+    3    3    0.10550E-03    0.10000E+01    0.71007E+03    0.80976E-05    0.65191E-09    0.71687E-11
+    3    3    0.10550E-03    0.10000E+01    0.57264E+03    0.15079E-04    0.22773E-08    0.11723E-10
+    3    3    0.10550E-03    0.10000E+01    0.46180E+03    0.28047E-04    0.75697E-08    0.19449E-10
+    3    3    0.10550E-03    0.10000E+01    0.37242E+03    0.51693E-04    0.22917E-07    0.32546E-10
+    3    3    0.10550E-03    0.10000E+01    0.30034E+03    0.93107E-04    0.61205E-07    0.54277E-10
+    3    3    0.10550E-03    0.10000E+01    0.24221E+03    0.16120E-03    0.14254E-06    0.88688E-10
+    3    3    0.10550E-03    0.10000E+01    0.19533E+03    0.25132E-03    0.27048E-06    0.13316E-09
+    3    3    0.10550E-03    0.10000E+01    0.15752E+03    0.25132E-03    0.27048E-06    0.13316E-09
+    3    3    0.18409E-03    0.10000E+01    0.80645E+05    0.32183E-50    0.24126E-61    0.85937E-56
+    3    3    0.18409E-03    0.10000E+01    0.65036E+05    0.27270E-49    0.38359E-60    0.72842E-55
+    3    3    0.18409E-03    0.10000E+01    0.52449E+05    0.23203E-48    0.51636E-59    0.61998E-54
+    3    3    0.18409E-03    0.10000E+01    0.42297E+05    0.17483E-47    0.70319E-58    0.46740E-53
+    3    3    0.18409E-03    0.10000E+01    0.34111E+05    0.12637E-46    0.96838E-57    0.33818E-52
+    3    3    0.18409E-03    0.10000E+01    0.27509E+05    0.91024E-46    0.13188E-55    0.24396E-51
+    3    3    0.18409E-03    0.10000E+01    0.22184E+05    0.65153E-45    0.17673E-54    0.17506E-50
+    3    3    0.18409E-03    0.10000E+01    0.17891E+05    0.46036E-44    0.23294E-53    0.12416E-49
+    3    3    0.18409E-03    0.10000E+01    0.14428E+05    0.32033E-43    0.30273E-52    0.86865E-49
+    3    3    0.18409E-03    0.10000E+01    0.11635E+05    0.21965E-42    0.38752E-51    0.59983E-48
+    3    3    0.18409E-03    0.10000E+01    0.93834E+04    0.14830E-41    0.48404E-50    0.40859E-47
+    3    3    0.18409E-03    0.10000E+01    0.75673E+04    0.97972E-41    0.58021E-49    0.27296E-46
+    3    3    0.18409E-03    0.10000E+01    0.61026E+04    0.62525E-40    0.65567E-48    0.17659E-45
+    3    3    0.18409E-03    0.10000E+01    0.49215E+04    0.38036E-39    0.71531E-47    0.10846E-44
+    3    3    0.18409E-03    0.10000E+01    0.39689E+04    0.22444E-38    0.91686E-46    0.62173E-44
+    3    3    0.18409E-03    0.10000E+01    0.32008E+04    0.47007E-36    0.57948E-43    0.11170E-41
+    3    3    0.18409E-03    0.10000E+01    0.25813E+04    0.23940E-27    0.89731E-34    0.45199E-33
+    3    3    0.18409E-03    0.10000E+01    0.20817E+04    0.43771E-11    0.59617E-17    0.78198E-17
+    3    3    0.18409E-03    0.10000E+01    0.16788E+04    0.13564E-05    0.70605E-11    0.22892E-11
+    3    3    0.18409E-03    0.10000E+01    0.13538E+04    0.23200E-05    0.25333E-10    0.32940E-11
+    3    3    0.18409E-03    0.10000E+01    0.10918E+04    0.41530E-05    0.90244E-10    0.49764E-11
+    3    3    0.18409E-03    0.10000E+01    0.88049E+03    0.76182E-05    0.32070E-09    0.77919E-11
+    3    3    0.18409E-03    0.10000E+01    0.71007E+03    0.14130E-04    0.11375E-08    0.12509E-10
+    3    3    0.18409E-03    0.10000E+01    0.57264E+03    0.26311E-04    0.39738E-08    0.20455E-10
+    3    3    0.18409E-03    0.10000E+01    0.46180E+03    0.48941E-04    0.13209E-07    0.33938E-10
+    3    3    0.18409E-03    0.10000E+01    0.37242E+03    0.90201E-04    0.39988E-07    0.56791E-10
+    3    3    0.18409E-03    0.10000E+01    0.30034E+03    0.16247E-03    0.10680E-06    0.94710E-10
+    3    3    0.18409E-03    0.10000E+01    0.24221E+03    0.28128E-03    0.24873E-06    0.15476E-09
+    3    3    0.18409E-03    0.10000E+01    0.19533E+03    0.43854E-03    0.47198E-06    0.23235E-09
+    3    3    0.18409E-03    0.10000E+01    0.15752E+03    0.43854E-03    0.47198E-06    0.23235E-09
+    3    3    0.32123E-03    0.10000E+01    0.80645E+05    0.56157E-50    0.42098E-61    0.14996E-55
+    3    3    0.32123E-03    0.10000E+01    0.65036E+05    0.47584E-49    0.66934E-60    0.12711E-54
+    3    3    0.32123E-03    0.10000E+01    0.52449E+05    0.40488E-48    0.90102E-59    0.10818E-53
+    3    3    0.32123E-03    0.10000E+01    0.42297E+05    0.30507E-47    0.12270E-57    0.81559E-53
+    3    3    0.32123E-03    0.10000E+01    0.34111E+05    0.22051E-46    0.16898E-56    0.59010E-52
+    3    3    0.32123E-03    0.10000E+01    0.27509E+05    0.15883E-45    0.23013E-55    0.42570E-51
+    3    3    0.32123E-03    0.10000E+01    0.22184E+05    0.11369E-44    0.30839E-54    0.30546E-50
+    3    3    0.32123E-03    0.10000E+01    0.17891E+05    0.80331E-44    0.40647E-53    0.21666E-49
+    3    3    0.32123E-03    0.10000E+01    0.14428E+05    0.55896E-43    0.52824E-52    0.15157E-48
+    3    3    0.32123E-03    0.10000E+01    0.11635E+05    0.38327E-42    0.67619E-51    0.10467E-47
+    3    3    0.32123E-03    0.10000E+01    0.93834E+04    0.25878E-41    0.84463E-50    0.71296E-47
+    3    3    0.32123E-03    0.10000E+01    0.75673E+04    0.17096E-40    0.10124E-48    0.47630E-46
+    3    3    0.32123E-03    0.10000E+01    0.61026E+04    0.10910E-39    0.11441E-47    0.30814E-45
+    3    3    0.32123E-03    0.10000E+01    0.49215E+04    0.66370E-39    0.12482E-46    0.18925E-44
+    3    3    0.32123E-03    0.10000E+01    0.39689E+04    0.39164E-38    0.15999E-45    0.10849E-43
+    3    3    0.32123E-03    0.10000E+01    0.32008E+04    0.82025E-36    0.10112E-42    0.19492E-41
+    3    3    0.32123E-03    0.10000E+01    0.25813E+04    0.41774E-27    0.15657E-33    0.78870E-33
+    3    3    0.32123E-03    0.10000E+01    0.20817E+04    0.76377E-11    0.10403E-16    0.13645E-16
+    3    3    0.32123E-03    0.10000E+01    0.16788E+04    0.23668E-05    0.12320E-10    0.39946E-11
+    3    3    0.32123E-03    0.10000E+01    0.13538E+04    0.40482E-05    0.44205E-10    0.57479E-11
+    3    3    0.32123E-03    0.10000E+01    0.10918E+04    0.72468E-05    0.15747E-09    0.86835E-11
+    3    3    0.32123E-03    0.10000E+01    0.88049E+03    0.13293E-04    0.55960E-09    0.13596E-10
+    3    3    0.32123E-03    0.10000E+01    0.71007E+03    0.24656E-04    0.19849E-08    0.21827E-10
+    3    3    0.32123E-03    0.10000E+01    0.57264E+03    0.45911E-04    0.69341E-08    0.35693E-10
+    3    3    0.32123E-03    0.10000E+01    0.46180E+03    0.85399E-04    0.23048E-07    0.59219E-10
+    3    3    0.32123E-03    0.10000E+01    0.37242E+03    0.15739E-03    0.69777E-07    0.99096E-10
+    3    3    0.32123E-03    0.10000E+01    0.30034E+03    0.28349E-03    0.18636E-06    0.16526E-09
+    3    3    0.32123E-03    0.10000E+01    0.24221E+03    0.49081E-03    0.43402E-06    0.27004E-09
+    3    3    0.32123E-03    0.10000E+01    0.19533E+03    0.76523E-03    0.82358E-06    0.40545E-09
+    3    3    0.32123E-03    0.10000E+01    0.15752E+03    0.76523E-03    0.82358E-06    0.40545E-09
+    3    4    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.16487E-09    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    4    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.28769E-09    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    4    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.50200E-09    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    3    4    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.87597E-09    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    3    4    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.15285E-08    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    3    4    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.26672E-08    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    3    4    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.46540E-08    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    3    4    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.81210E-08    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    3    4    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.14171E-07    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    3    4    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.24727E-07    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    3    4    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.43147E-07    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    3    4    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.75289E-07    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    3    4    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.13137E-06    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    3    4    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.22924E-06    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    3    4    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.40001E-06    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    3    4    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.69800E-06    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    3    4    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12001E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.12180E-05    0.41311E+06    0.12910E-27    0.11213E-17    0.24207E-04    0.90000E+03
+    3    4    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45883E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.21253E-05    0.34307E+06    0.39288E-27    0.42663E-15    0.29147E-04    0.89996E+03
+    3    4    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54107E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.37085E-05    0.28490E+06    0.11866E-26    0.50023E-13    0.35071E-04    0.89947E+03
+    3    4    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24753E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.64710E-05    0.23629E+06    0.35027E-26    0.22752E-11    0.42127E-04    0.89631E+03
+    3    4    0.31275E-10    0.10000E+01    0.48386E-01    0.94672E-01    0.50538E-10    0.54357E-12    0.34961E-04    0.23128E-04    0.56458E+04    0.11292E-04    0.19496E+06    0.99461E-26    0.49740E-10    0.50500E-04    0.88379E+03
+    3    4    0.54572E-10    0.10000E+01    0.74052E-01    0.13900E+00    0.11211E-09    0.66684E-11    0.40386E-04    0.29200E-04    0.98516E+04    0.19703E-04    0.15940E+06    0.27067E-25    0.60921E-09    0.60499E-04    0.85041E+03
+    3    4    0.95225E-10    0.10000E+01    0.11677E+00    0.19424E+00    0.20910E-09    0.53454E-10    0.44065E-04    0.37602E-04    0.17190E+05    0.34381E-04    0.12765E+06    0.73944E-25    0.48802E-08    0.73610E-04    0.78203E+03
+    3    4    0.16616E-09    0.10000E+01    0.17445E+00    0.24561E+00    0.31787E-09    0.28238E-09    0.46046E-04    0.45179E-04    0.29996E+05    0.59992E-04    0.10038E+06    0.21904E-24    0.25430E-07    0.92364E-04    0.67827E+03
+    3    4    0.28994E-09    0.10000E+01    0.22816E+00    0.28335E+00    0.47136E-09    0.98582E-09    0.50340E-04    0.46643E-04    0.52341E+05    0.10468E-03    0.78931E+05    0.73818E-24    0.84106E-07    0.11916E-03    0.57239E+03
+    3    4    0.50593E-09    0.10000E+01    0.26683E+00    0.32723E+00    0.88440E-09    0.24888E-08    0.61252E-04    0.46324E-04    0.91333E+05    0.18267E-03    0.63372E+05    0.25451E-23    0.19105E-06    0.15233E-03    0.50331E+03
+    3    4    0.88282E-09    0.10000E+01    0.30277E+00    0.39779E+00    0.19641E-08    0.52701E-08    0.78168E-04    0.48873E-04    0.15937E+06    0.31874E-03    0.51746E+05    0.83904E-23    0.34898E-06    0.19018E-03    0.46990E+03
+    3    4    0.15405E-08    0.10000E+01    0.35084E+00    0.49729E+00    0.42764E-08    0.10247E-07    0.99491E-04    0.54800E-04    0.27809E+06    0.55618E-03    0.42695E+05    0.26464E-22    0.57002E-06    0.23278E-03    0.45661E+03
+    3    4    0.26880E-08    0.10000E+01    0.42020E+00    0.62268E+00    0.85384E-08    0.19116E-07    0.12444E-03    0.63777E-04    0.48525E+06    0.97050E-03    0.35410E+05    0.81438E-22    0.88163E-06    0.28181E-03    0.45199E+03
+    3    4    0.46905E-08    0.10000E+01    0.47019E+00    0.92265E+00    0.19703E-07    0.35109E-07    0.13451E-03    0.84598E-04    0.60482E+06    0.12096E-02    0.15948E+05    0.46803E-21    0.11841E-05    0.40017E-03    0.45183E+03
+    3    4    0.81846E-08    0.10000E+01    0.40118E+00    0.16091E+01    0.46864E-07    0.61614E-07    0.11571E-03    0.13418E-03    0.36184E+06    0.72367E-03    0.55751E+04    0.57811E-20    0.13104E-05    0.71617E-03    0.45152E+03
+    3    4    0.14282E-07    0.10000E+01    0.48546E+00    0.18930E+01    0.80192E-07    0.10647E-06    0.13950E-03    0.16059E-03    0.63138E+06    0.12628E-02    0.46298E+04    0.17631E-19    0.19206E-05    0.86313E-03    0.45078E+03
+    3    4    0.24920E-07    0.10000E+01    0.58547E+00    0.22090E+01    0.13552E-06    0.18224E-06    0.16817E-03    0.19264E-03    0.11017E+07    0.22035E-02    0.38449E+04    0.53744E-19    0.27922E-05    0.10398E-02    0.45039E+03
+    3    4    0.43485E-07    0.10000E+01    0.70300E+00    0.25592E+01    0.22655E-06    0.30931E-06    0.20270E-03    0.23143E-03    0.19224E+07    0.38449E-02    0.31930E+04    0.16379E-18    0.40328E-05    0.12524E-02    0.45020E+03
+    3    4    0.75878E-07    0.10000E+01    0.83983E+00    0.29458E+01    0.37524E-06    0.52108E-06    0.24426E-03    0.27828E-03    0.33546E+07    0.67091E-02    0.26517E+04    0.49907E-18    0.57928E-05    0.15083E-02    0.45010E+03
+    3    4    0.13240E-06    0.10000E+01    0.99770E+00    0.33714E+01    0.61657E-06    0.87196E-06    0.29426E-03    0.33480E-03    0.58535E+07    0.11707E-01    0.22021E+04    0.15206E-17    0.82821E-05    0.18163E-02    0.45005E+03
+    3    4    0.23103E-06    0.10000E+01    0.11784E+01    0.38386E+01    0.10063E-05    0.14504E-05    0.35441E-03    0.40294E-03    0.10214E+08    0.20428E-01    0.18287E+04    0.46330E-17    0.11793E-04    0.21872E-02    0.45002E+03
+    3    4    0.40314E-06    0.10000E+01    0.13836E+01    0.43509E+01    0.16328E-05    0.23997E-05    0.42677E-03    0.48506E-03    0.17823E+08    0.35646E-01    0.15187E+04    0.14116E-16    0.16735E-04    0.26338E-02    0.45001E+03
+    3    4    0.70346E-06    0.10000E+01    0.16153E+01    0.49119E+01    0.26368E-05    0.39515E-05    0.51383E-03    0.58398E-03    0.31100E+08    0.62199E-01    0.12612E+04    0.43006E-16    0.23673E-04    0.31715E-02    0.45001E+03
+    3    4    0.12275E-05    0.10000E+01    0.18734E+01    0.55210E+01    0.42599E-05    0.64822E-05    0.62018E-03    0.70222E-03    0.54267E+08    0.10853E+00    0.10487E+04    0.13050E-15    0.33446E-04    0.38141E-02    0.45000E+03
+    3    4    0.21419E-05    0.10000E+01    0.21637E+01    0.61914E+01    0.68286E-05    0.10589E-04    0.74652E-03    0.84551E-03    0.94693E+08    0.18939E+00    0.87093E+03    0.39703E-15    0.47071E-04    0.45923E-02    0.45000E+03
+    3    4    0.37375E-05    0.10000E+01    0.24866E+01    0.69219E+01    0.10915E-04    0.17238E-04    0.89853E-03    0.10178E-02    0.16523E+09    0.33047E+00    0.72327E+03    0.11986E-14    0.66104E-04    0.55252E-02    0.45000E+03
+    3    4    0.65217E-05    0.10000E+01    0.28446E+01    0.77081E+01    0.17386E-04    0.27955E-04    0.10814E-02    0.12238E-02    0.28832E+09    0.57664E+00    0.60065E+03    0.35232E-14    0.92633E-04    0.66244E-02    0.45000E+03
+    3    4    0.11380E-04    0.10000E+01    0.32346E+01    0.85152E+01    0.27741E-04    0.45092E-04    0.13071E-02    0.14615E-02    0.50310E+09    0.10062E+01    0.50000E+03    0.97126E-14    0.12979E-03    0.78471E-02    0.45000E+03
+    3    4    0.19857E-04    0.10000E+01    0.32346E+01    0.85152E+01    0.84467E-04    0.78682E-04    0.22809E-02    0.14615E-02    0.87789E+09    0.17558E+01    0.50000E+03    0.16948E-13    0.22648E-03    0.78471E-02    0.45000E+03
+    3    4    0.34650E-04    0.10000E+01    0.32346E+01    0.85152E+01    0.25719E-03    0.13730E-03    0.39799E-02    0.14615E-02    0.15319E+10    0.30637E+01    0.50000E+03    0.29573E-13    0.39519E-03    0.78471E-02    0.45000E+03
+    3    4    0.60462E-04    0.10000E+01    0.32346E+01    0.85152E+01    0.78309E-03    0.23957E-03    0.69448E-02    0.14615E-02    0.26730E+10    0.53460E+01    0.50000E+03    0.51603E-13    0.68959E-03    0.78471E-02    0.45000E+03
+    3    4    0.10550E-03    0.10000E+01    0.32346E+01    0.85152E+01    0.23844E-02    0.41804E-03    0.12118E-01    0.14615E-02    0.46642E+10    0.93285E+01    0.50000E+03    0.90044E-13    0.12033E-02    0.78471E-02    0.45000E+03
+    3    4    0.18409E-03    0.10000E+01    0.32346E+01    0.85152E+01    0.72599E-02    0.72945E-03    0.21146E-01    0.14615E-02    0.81388E+10    0.16278E+02    0.50000E+03    0.15712E-12    0.20997E-02    0.78471E-02    0.45000E+03
+    3    4    0.32123E-03    0.10000E+01    0.32346E+01    0.85152E+01    0.22105E-01    0.12729E-02    0.36898E-01    0.14615E-02    0.14202E+11    0.28403E+02    0.50000E+03    0.27417E-12    0.36638E-02    0.78471E-02    0.45000E+03
+    3    4    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    3    4    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    3    4    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    3    4    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    3    4    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    3    4    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    3    4    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    3    4    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    3    4    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    3    4    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    3    4    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    3    4    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    3    4    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    3    4    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    3    4    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    3    4    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    3    4    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    3    4    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    3    4    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    3    4    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    3    4    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    3    4    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    3    4    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    3    4    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    3    4    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    3    4    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    3    4    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    3    4    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    3    4    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    3    4    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    3    4    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    3    4    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    3    4    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    3    4    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    3    4    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    3    4    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    3    4    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    3    4    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    3    4    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    3    4    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    3    4    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    3    4    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    3    4    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    3    4    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    3    4    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    3    4    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    3    4    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    3    4    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    3    4    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    3    4    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    3    4    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    3    4    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    3    4    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    3    4    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    3    4    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    3    4    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    3    4    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    3    4    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    3    4    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    3    4    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    3    4    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    3    4    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    3    4    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    3    4    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    3    4    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    3    4    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    3    4    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    3    4    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    3    4    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    3    4    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    3    4    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    3    4    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    3    4    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    3    4    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    3    4    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    3    4    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    3    4    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    3    4    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    3    4    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    3    4    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    3    4    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    3    4    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    3    4    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    3    4    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    3    4    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    3    4    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    3    4    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    3    4    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    3    4    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    3    4    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    3    4    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    3    4    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    3    4    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    3    4    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    3    4    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    3    4    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    3    4    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    3    4    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    3    4    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    3    4    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    3    4    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    3    4    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    3    4    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    3    4    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    3    4    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    3    4    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    3    4    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    3    4    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    3    4    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    3    4    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    3    4    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    3    4    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    3    4    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    3    4    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    3    4    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    3    4    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    3    4    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    3    4    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    3    4    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    3    4    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    3    4    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    3    4    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    3    4    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    3    4    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    3    4    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    3    4    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    3    4    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    3    4    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    3    4    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    3    4    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    3    4    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    3    4    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    3    4    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    3    4    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    3    4    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    3    4    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    3    4    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    3    4    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    3    4    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    3    4    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    3    4    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    3    4    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    3    4    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    3    4    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    3    4    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    3    4    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    3    4    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    3    4    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    3    4    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    3    4    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    3    4    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    3    4    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    3    4    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    3    4    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    3    4    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    3    4    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    3    4    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    3    4    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    3    4    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    3    4    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    3    4    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    3    4    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    3    4    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    3    4    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    3    4    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    3    4    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    3    4    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    3    4    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    3    4    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    3    4    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    3    4    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    3    4    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    3    4    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    3    4    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    3    4    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    3    4    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    3    4    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    3    4    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    3    4    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    3    4    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    3    4    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    3    4    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    3    4    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    3    4    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    3    4    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    3    4    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    3    4    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    3    4    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    3    4    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    3    4    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    3    4    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    3    4    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    3    4    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    3    4    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    3    4    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    3    4    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    3    4    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    3    4    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    3    4    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    3    4    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    3    4    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    3    4    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    3    4    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    3    4    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    3    4    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    3    4    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    3    4    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    3    4    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    3    4    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    3    4    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    3    4    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    3    4    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    3    4    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    3    4    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    3    4    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    3    4    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    3    4    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    3    4    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    3    4    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    3    4    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    3    4    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    3    4    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    3    4    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    3    4    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    3    4    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    3    4    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    3    4    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    3    4    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    3    4    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    3    4    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    3    4    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    3    4    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    3    4    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    3    4    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    3    4    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    3    4    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    3    4    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    3    4    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    3    4    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    3    4    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    3    4    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    3    4    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    3    4    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    3    4    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    3    4    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    3    4    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    3    4    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    3    4    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    3    4    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    3    4    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    3    4    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    3    4    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    3    4    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    3    4    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    3    4    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    3    4    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    3    4    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    3    4    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    3    4    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    3    4    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    3    4    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    3    4    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    3    4    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    3    4    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    3    4    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    3    4    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    3    4    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    3    4    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    3    4    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    3    4    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    3    4    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    3    4    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    3    4    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    3    4    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    3    4    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    3    4    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    3    4    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    3    4    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    3    4    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    3    4    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    3    4    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    3    4    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    3    4    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    3    4    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    3    4    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    3    4    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    3    4    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    3    4    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    3    4    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    3    4    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    3    4    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    3    4    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    3    4    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    3    4    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    3    4    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    3    4    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    3    4    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    3    4    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    3    4    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    3    4    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    3    4    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    3    4    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    3    4    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    3    4    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    3    4    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    3    4    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    3    4    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    3    4    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    3    4    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    3    4    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    3    4    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    3    4    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    3    4    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    3    4    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    3    4    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    3    4    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    3    4    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    3    4    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    3    4    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    3    4    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    3    4    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    3    4    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    3    4    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    3    4    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    3    4    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    3    4    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    3    4    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    3    4    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    3    4    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    3    4    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    3    4    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    3    4    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    3    4    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    3    4    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    3    4    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    3    4    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    3    4    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    3    4    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    3    4    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    3    4    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    3    4    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    3    4    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    3    4    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    3    4    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    3    4    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    3    4    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    3    4    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    3    4    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    3    4    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    3    4    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    3    4    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    3    4    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    3    4    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    3    4    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    3    4    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    3    4    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    3    4    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    3    4    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    3    4    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    3    4    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    3    4    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    3    4    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    3    4    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    3    4    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    3    4    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    3    4    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    3    4    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    3    4    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    3    4    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    3    4    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    3    4    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    3    4    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    3    4    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    3    4    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    3    4    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    3    4    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    3    4    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    3    4    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    3    4    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    3    4    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    3    4    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    3    4    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    3    4    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    3    4    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    3    4    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    3    4    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    3    4    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    3    4    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    3    4    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    3    4    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    3    4    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    3    4    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    3    4    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    3    4    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    3    4    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    3    4    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    3    4    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    3    4    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    3    4    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    3    4    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    3    4    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    3    4    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    3    4    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    3    4    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    3    4    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    3    4    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    3    4    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    3    4    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    3    4    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    3    4    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    3    4    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    3    4    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    3    4    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    3    4    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    3    4    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    3    4    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    3    4    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    3    4    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    3    4    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    3    4    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    3    4    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    3    4    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    3    4    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    3    4    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    3    4    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    3    4    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    3    4    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    3    4    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    3    4    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    3    4    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    3    4    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    3    4    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    3    4    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    3    4    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    3    4    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    3    4    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    3    4    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    3    4    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    3    4    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    3    4    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    3    4    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    3    4    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    3    4    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    3    4    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    3    4    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    3    4    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    3    4    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    3    4    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    3    4    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    3    4    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    3    4    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    3    4    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    3    4    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    3    4    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    3    4    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    3    4    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    3    4    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    3    4    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    3    4    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    3    4    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    3    4    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    3    4    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    3    4    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    3    4    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    3    4    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    3    4    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    3    4    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    3    4    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    3    4    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    3    4    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    3    4    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    3    4    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    3    4    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    3    4    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    3    4    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    3    4    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    3    4    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    3    4    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    3    4    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    3    4    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    3    4    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    3    4    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    3    4    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    3    4    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    3    4    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    3    4    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    3    4    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    3    4    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    3    4    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    3    4    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    3    4    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    3    4    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    3    4    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    3    4    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    3    4    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    3    4    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    3    4    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    3    4    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    3    4    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    3    4    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    3    4    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    3    4    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    3    4    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    3    4    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    3    4    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    3    4    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    3    4    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    3    4    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    3    4    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    3    4    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    3    4    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    3    4    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    3    4    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    3    4    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    3    4    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    3    4    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    3    4    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    3    4    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    3    4    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    3    4    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    3    4    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    3    4    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    3    4    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    3    4    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    3    4    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    3    4    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    3    4    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    3    4    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    3    4    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    3    4    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    3    4    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    3    4    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    3    4    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    3    4    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    3    4    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    3    4    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    3    4    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    3    4    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    3    4    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    3    4    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    3    4    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    3    4    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    3    4    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    3    4    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    3    4    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    3    4    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    3    4    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    3    4    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    3    4    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    3    4    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    3    4    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    3    4    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    3    4    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    3    4    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    3    4    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    3    4    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    3    4    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    3    4    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    3    4    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    3    4    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    3    4    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    3    4    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    3    4    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    3    4    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    3    4    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    3    4    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    3    4    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    3    4    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    3    4    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    3    4    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    3    4    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    3    4    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28312E-67
+    3    4    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    3    4    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    3    4    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    3    4    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41870E-63
+    3    4    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    3    4    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    3    4    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    3    4    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28903E-58
+    3    4    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    3    4    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    3    4    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    3    4    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11731E-53
+    3    4    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    3    4    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73373E-50
+    3    4    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    3    4    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    3    4    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    3    4    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    3    4    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    3    4    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    3    4    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    3    4    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    3    4    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    3    4    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    3    4    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    3    4    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    3    4    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    3    4    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    3    4    0.31275E-10    0.10000E+01    0.80645E+05    0.12245E-57    0.88089E-69    0.11452E-67
+    3    4    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98336E-67
+    3    4    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30733E-66    0.84216E-66
+    3    4    0.31275E-10    0.10000E+01    0.42297E+05    0.99583E-55    0.85105E-65    0.66901E-65
+    3    4    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61256E-64
+    3    4    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94802E-62    0.75374E-63
+    3    4    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30613E-60    0.11739E-61
+    3    4    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19607E-60
+    3    4    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31441E-59
+    3    4    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47461E-58
+    3    4    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68930E-57
+    3    4    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98474E-56
+    3    4    0.31275E-10    0.10000E+01    0.61026E+04    0.45469E-44    0.13609E-51    0.13991E-54
+    3    4    0.31275E-10    0.10000E+01    0.49215E+04    0.64066E-43    0.36553E-50    0.19838E-53
+    3    4    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98158E-49    0.28095E-52
+    3    4    0.31275E-10    0.10000E+01    0.32008E+04    0.39979E-39    0.85220E-46    0.12501E-49
+    3    4    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91999E-41
+    3    4    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    3    4    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59583E-19
+    3    4    0.31275E-10    0.10000E+01    0.13538E+04    0.40464E-08    0.68177E-13    0.12804E-18
+    3    4    0.31275E-10    0.10000E+01    0.10918E+04    0.84959E-08    0.25421E-12    0.26902E-18
+    3    4    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93595E-12    0.55307E-18
+    3    4    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34082E-11    0.11150E-17
+    3    4    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22101E-17
+    3    4    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43092E-17
+    3    4    0.31275E-10    0.10000E+01    0.37242E+03    0.25942E-06    0.12436E-09    0.82250E-17
+    3    4    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    3    4    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77881E-09    0.26766E-16
+    3    4    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    3    4    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    3    4    0.54572E-10    0.10000E+01    0.80645E+05    0.25902E-57    0.19496E-68    0.35699E-67
+    3    4    0.54572E-10    0.10000E+01    0.65036E+05    0.22055E-56    0.31826E-67    0.31164E-66
+    3    4    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49272E-66    0.26831E-65
+    3    4    0.54572E-10    0.10000E+01    0.42297E+05    0.16488E-54    0.10212E-64    0.20686E-64
+    3    4    0.54572E-10    0.10000E+01    0.34111E+05    0.17291E-53    0.28417E-63    0.16327E-63
+    3    4    0.54572E-10    0.10000E+01    0.27509E+05    0.24066E-52    0.91002E-62    0.15290E-62
+    3    4    0.54572E-10    0.10000E+01    0.22184E+05    0.39352E-51    0.29454E-60    0.19323E-61
+    3    4    0.54572E-10    0.10000E+01    0.17891E+05    0.65778E-50    0.89334E-59    0.30540E-60
+    3    4    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49597E-59
+    3    4    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69355E-56    0.76509E-58
+    3    4    0.54572E-10    0.10000E+01    0.93834E+04    0.22547E-46    0.18758E-54    0.11306E-56
+    3    4    0.54572E-10    0.10000E+01    0.75673E+04    0.32066E-45    0.50594E-53    0.16361E-55
+    3    4    0.54572E-10    0.10000E+01    0.61026E+04    0.45394E-44    0.13635E-51    0.23472E-54
+    3    4    0.54572E-10    0.10000E+01    0.49215E+04    0.64174E-43    0.36725E-50    0.33535E-53
+    3    4    0.54572E-10    0.10000E+01    0.39689E+04    0.90659E-42    0.98848E-49    0.47778E-52
+    3    4    0.54572E-10    0.10000E+01    0.32008E+04    0.40255E-39    0.85992E-46    0.21362E-49
+    3    4    0.54572E-10    0.10000E+01    0.25813E+04    0.29568E-30    0.14477E-36    0.15788E-40
+    3    4    0.54572E-10    0.10000E+01    0.20817E+04    0.56396E-14    0.12315E-19    0.30303E-24
+    3    4    0.54572E-10    0.10000E+01    0.16788E+04    0.19088E-08    0.18204E-13    0.10297E-18
+    3    4    0.54572E-10    0.10000E+01    0.13538E+04    0.41002E-08    0.69152E-13    0.22149E-18
+    3    4    0.54572E-10    0.10000E+01    0.10918E+04    0.86120E-08    0.25786E-12    0.46566E-18
+    3    4    0.54572E-10    0.10000E+01    0.88049E+03    0.17701E-07    0.94944E-12    0.95781E-18
+    3    4    0.54572E-10    0.10000E+01    0.71007E+03    0.35681E-07    0.34574E-11    0.19316E-17
+    3    4    0.54572E-10    0.10000E+01    0.57264E+03    0.70716E-07    0.12301E-10    0.38295E-17
+    3    4    0.54572E-10    0.10000E+01    0.46180E+03    0.13787E-06    0.41372E-10    0.74679E-17
+    3    4    0.54572E-10    0.10000E+01    0.37242E+03    0.26315E-06    0.12615E-09    0.14255E-16
+    3    4    0.54572E-10    0.10000E+01    0.30034E+03    0.48604E-06    0.33836E-09    0.26332E-16
+    3    4    0.54572E-10    0.10000E+01    0.24221E+03    0.85631E-06    0.79005E-09    0.46394E-16
+    3    4    0.54572E-10    0.10000E+01    0.19533E+03    0.13496E-05    0.15014E-08    0.73121E-16
+    3    4    0.54572E-10    0.10000E+01    0.15752E+03    0.13496E-05    0.15014E-08    0.73121E-16
+    3    4    0.95225E-10    0.10000E+01    0.80645E+05    0.53554E-57    0.41311E-68    0.11149E-66
+    3    4    0.95225E-10    0.10000E+01    0.65036E+05    0.46410E-56    0.66237E-67    0.97002E-66
+    3    4    0.95225E-10    0.10000E+01    0.52449E+05    0.40032E-55    0.93164E-66    0.83456E-65
+    3    4    0.95225E-10    0.10000E+01    0.42297E+05    0.31435E-54    0.15004E-64    0.63488E-64
+    3    4    0.95225E-10    0.10000E+01    0.34111E+05    0.26310E-53    0.30850E-63    0.46587E-63
+    3    4    0.95225E-10    0.10000E+01    0.27509E+05    0.27333E-52    0.83965E-62    0.35909E-62
+    3    4    0.95225E-10    0.10000E+01    0.22184E+05    0.37409E-51    0.26564E-60    0.35001E-61
+    3    4    0.95225E-10    0.10000E+01    0.17891E+05    0.59938E-50    0.82154E-59    0.48696E-60
+    3    4    0.95225E-10    0.10000E+01    0.14428E+05    0.96092E-49    0.23756E-57    0.78460E-59
+    3    4    0.95225E-10    0.10000E+01    0.11635E+05    0.14626E-47    0.65916E-56    0.12347E-57
+    3    4    0.95225E-10    0.10000E+01    0.93834E+04    0.21403E-46    0.18007E-54    0.18579E-56
+    3    4    0.95225E-10    0.10000E+01    0.75673E+04    0.30754E-45    0.48943E-53    0.27243E-55
+    3    4    0.95225E-10    0.10000E+01    0.61026E+04    0.43884E-44    0.13272E-51    0.39464E-54
+    3    4    0.95225E-10    0.10000E+01    0.49215E+04    0.62433E-43    0.35927E-50    0.56805E-53
+    3    4    0.95225E-10    0.10000E+01    0.39689E+04    0.88652E-42    0.97095E-49    0.81410E-52
+    3    4    0.95225E-10    0.10000E+01    0.32008E+04    0.39530E-39    0.84762E-46    0.36576E-49
+    3    4    0.95225E-10    0.10000E+01    0.25813E+04    0.29145E-30    0.14320E-36    0.27148E-40
+    3    4    0.95225E-10    0.10000E+01    0.20817E+04    0.55806E-14    0.12226E-19    0.52339E-24
+    3    4    0.95225E-10    0.10000E+01    0.16788E+04    0.18934E-08    0.18098E-13    0.17833E-18
+    3    4    0.95225E-10    0.10000E+01    0.13538E+04    0.40706E-08    0.68767E-13    0.38395E-18
+    3    4    0.95225E-10    0.10000E+01    0.10918E+04    0.85549E-08    0.25646E-12    0.80778E-18
+    3    4    0.95225E-10    0.10000E+01    0.88049E+03    0.17592E-07    0.94432E-12    0.16623E-17
+    3    4    0.95225E-10    0.10000E+01    0.71007E+03    0.35471E-07    0.34388E-11    0.33536E-17
+    3    4    0.95225E-10    0.10000E+01    0.57264E+03    0.70314E-07    0.12235E-10    0.66500E-17
+    3    4    0.95225E-10    0.10000E+01    0.46180E+03    0.13711E-06    0.41151E-10    0.12970E-16
+    3    4    0.95225E-10    0.10000E+01    0.37242E+03    0.26171E-06    0.12548E-09    0.24760E-16
+    3    4    0.95225E-10    0.10000E+01    0.30034E+03    0.48340E-06    0.33655E-09    0.45739E-16
+    3    4    0.95225E-10    0.10000E+01    0.24221E+03    0.85169E-06    0.78582E-09    0.80590E-16
+    3    4    0.95225E-10    0.10000E+01    0.19533E+03    0.13423E-05    0.14933E-08    0.12702E-15
+    3    4    0.95225E-10    0.10000E+01    0.15752E+03    0.13423E-05    0.14933E-08    0.12702E-15
+    3    4    0.16616E-09    0.10000E+01    0.80645E+05    0.10977E-56    0.84399E-68    0.38931E-66
+    3    4    0.16616E-09    0.10000E+01    0.65036E+05    0.94859E-56    0.13467E-66    0.33201E-65
+    3    4    0.16616E-09    0.10000E+01    0.52449E+05    0.81337E-55    0.18293E-65    0.28216E-64
+    3    4    0.16616E-09    0.10000E+01    0.42297E+05    0.61843E-54    0.25682E-64    0.21018E-63
+    3    4    0.16616E-09    0.10000E+01    0.34111E+05    0.45987E-53    0.39813E-63    0.14712E-62
+    3    4    0.16616E-09    0.10000E+01    0.27509E+05    0.37095E-52    0.81962E-62    0.10153E-61
+    3    4    0.16616E-09    0.10000E+01    0.22184E+05    0.38546E-51    0.23727E-60    0.79594E-61
+    3    4    0.16616E-09    0.10000E+01    0.17891E+05    0.54843E-50    0.74347E-59    0.90731E-60
+    3    4    0.16616E-09    0.10000E+01    0.14428E+05    0.87339E-49    0.22016E-57    0.13675E-58
+    3    4    0.16616E-09    0.10000E+01    0.11635E+05    0.13539E-47    0.62136E-56    0.21319E-57
+    3    4    0.16616E-09    0.10000E+01    0.93834E+04    0.20146E-46    0.17176E-54    0.32067E-56
+    3    4    0.16616E-09    0.10000E+01    0.75673E+04    0.29303E-45    0.47099E-53    0.47000E-55
+    3    4    0.16616E-09    0.10000E+01    0.61026E+04    0.42199E-44    0.12862E-51    0.68052E-54
+    3    4    0.16616E-09    0.10000E+01    0.49215E+04    0.60470E-43    0.35016E-50    0.97951E-53
+    3    4    0.16616E-09    0.10000E+01    0.39689E+04    0.86365E-42    0.95077E-49    0.14045E-51
+    3    4    0.16616E-09    0.10000E+01    0.32008E+04    0.38697E-39    0.83337E-46    0.63164E-49
+    3    4    0.16616E-09    0.10000E+01    0.25813E+04    0.28656E-30    0.14136E-36    0.46945E-40
+    3    4    0.16616E-09    0.10000E+01    0.20817E+04    0.55121E-14    0.12122E-19    0.90676E-24
+    3    4    0.16616E-09    0.10000E+01    0.16788E+04    0.18755E-08    0.17975E-13    0.30935E-18
+    3    4    0.16616E-09    0.10000E+01    0.13538E+04    0.40360E-08    0.68316E-13    0.66628E-18
+    3    4    0.16616E-09    0.10000E+01    0.10918E+04    0.84882E-08    0.25481E-12    0.14022E-17
+    3    4    0.16616E-09    0.10000E+01    0.88049E+03    0.17463E-07    0.93831E-12    0.28862E-17
+    3    4    0.16616E-09    0.10000E+01    0.71007E+03    0.35225E-07    0.34171E-11    0.58236E-17
+    3    4    0.16616E-09    0.10000E+01    0.57264E+03    0.69842E-07    0.12157E-10    0.11549E-16
+    3    4    0.16616E-09    0.10000E+01    0.46180E+03    0.13621E-06    0.40891E-10    0.22526E-16
+    3    4    0.16616E-09    0.10000E+01    0.37242E+03    0.26002E-06    0.12468E-09    0.43005E-16
+    3    4    0.16616E-09    0.10000E+01    0.30034E+03    0.48030E-06    0.33442E-09    0.79443E-16
+    3    4    0.16616E-09    0.10000E+01    0.24221E+03    0.84626E-06    0.78084E-09    0.13998E-15
+    3    4    0.16616E-09    0.10000E+01    0.19533E+03    0.13338E-05    0.14839E-08    0.22061E-15
+    3    4    0.16616E-09    0.10000E+01    0.15752E+03    0.13338E-05    0.14839E-08    0.22061E-15
+    3    4    0.28994E-09    0.10000E+01    0.80645E+05    0.22525E-56    0.16982E-67    0.15580E-65
+    3    4    0.28994E-09    0.10000E+01    0.65036E+05    0.19163E-55    0.26880E-66    0.13079E-64
+    3    4    0.28994E-09    0.10000E+01    0.52449E+05    0.16258E-54    0.35615E-65    0.11002E-63
+    3    4    0.28994E-09    0.10000E+01    0.42297E+05    0.12097E-53    0.46774E-64    0.80781E-63
+    3    4    0.28994E-09    0.10000E+01    0.34111E+05    0.84961E-53    0.61904E-63    0.55304E-62
+    3    4    0.28994E-09    0.10000E+01    0.27509E+05    0.59687E-52    0.97508E-62    0.36507E-61
+    3    4    0.28994E-09    0.10000E+01    0.22184E+05    0.48605E-51    0.23700E-60    0.24962E-60
+    3    4    0.28994E-09    0.10000E+01    0.17891E+05    0.56913E-50    0.72079E-59    0.22159E-59
+    3    4    0.28994E-09    0.10000E+01    0.14428E+05    0.85552E-49    0.21453E-57    0.28024E-58
+    3    4    0.28994E-09    0.10000E+01    0.11635E+05    0.13206E-47    0.60815E-56    0.40800E-57
+    3    4    0.28994E-09    0.10000E+01    0.93834E+04    0.19709E-46    0.16842E-54    0.59575E-56
+    3    4    0.28994E-09    0.10000E+01    0.75673E+04    0.28727E-45    0.46239E-53    0.85626E-55
+    3    4    0.28994E-09    0.10000E+01    0.61026E+04    0.41426E-44    0.12644E-51    0.12213E-53
+    3    4    0.28994E-09    0.10000E+01    0.49215E+04    0.59443E-43    0.34476E-50    0.17382E-52
+    3    4    0.28994E-09    0.10000E+01    0.39689E+04    0.85030E-42    0.93774E-49    0.24727E-51
+    3    4    0.28994E-09    0.10000E+01    0.32008E+04    0.38166E-39    0.82345E-46    0.11062E-48
+    3    4    0.28994E-09    0.10000E+01    0.25813E+04    0.28319E-30    0.13998E-36    0.81940E-40
+    3    4    0.28994E-09    0.10000E+01    0.20817E+04    0.54608E-14    0.12034E-19    0.15793E-23
+    3    4    0.28994E-09    0.10000E+01    0.16788E+04    0.18611E-08    0.17863E-13    0.53820E-18
+    3    4    0.28994E-09    0.10000E+01    0.13538E+04    0.40071E-08    0.67903E-13    0.11587E-17
+    3    4    0.28994E-09    0.10000E+01    0.10918E+04    0.84309E-08    0.25329E-12    0.24378E-17
+    3    4    0.28994E-09    0.10000E+01    0.88049E+03    0.17351E-07    0.93273E-12    0.50169E-17
+    3    4    0.28994E-09    0.10000E+01    0.71007E+03    0.35004E-07    0.33967E-11    0.10121E-16
+    3    4    0.28994E-09    0.10000E+01    0.57264E+03    0.69413E-07    0.12085E-10    0.20070E-16
+    3    4    0.28994E-09    0.10000E+01    0.46180E+03    0.13538E-06    0.40646E-10    0.39142E-16
+    3    4    0.28994E-09    0.10000E+01    0.37242E+03    0.25845E-06    0.12394E-09    0.74722E-16
+    3    4    0.28994E-09    0.10000E+01    0.30034E+03    0.47742E-06    0.33242E-09    0.13803E-15
+    3    4    0.28994E-09    0.10000E+01    0.24221E+03    0.84119E-06    0.77617E-09    0.24319E-15
+    3    4    0.28994E-09    0.10000E+01    0.19533E+03    0.13258E-05    0.14750E-08    0.38328E-15
+    3    4    0.28994E-09    0.10000E+01    0.15752E+03    0.13258E-05    0.14750E-08    0.38328E-15
+    3    4    0.50593E-09    0.10000E+01    0.80645E+05    0.45324E-56    0.33672E-67    0.60821E-65
+    3    4    0.50593E-09    0.10000E+01    0.65036E+05    0.38112E-55    0.52991E-66    0.50902E-64
+    3    4    0.50593E-09    0.10000E+01    0.52449E+05    0.32096E-54    0.69262E-65    0.42780E-63
+    3    4    0.50593E-09    0.10000E+01    0.42297E+05    0.23610E-53    0.88743E-64    0.31439E-62
+    3    4    0.50593E-09    0.10000E+01    0.34111E+05    0.16230E-52    0.11100E-62    0.21634E-61
+    3    4    0.50593E-09    0.10000E+01    0.27509E+05    0.10832E-51    0.14819E-61    0.14348E-60
+    3    4    0.50593E-09    0.10000E+01    0.22184E+05    0.76455E-51    0.28522E-60    0.93352E-60
+    3    4    0.50593E-09    0.10000E+01    0.17891E+05    0.71743E-50    0.77696E-59    0.67015E-59
+    3    4    0.50593E-09    0.10000E+01    0.14428E+05    0.94219E-49    0.22429E-57    0.64121E-58
+    3    4    0.50593E-09    0.10000E+01    0.11635E+05    0.13887E-47    0.62754E-56    0.80314E-57
+    3    4    0.50593E-09    0.10000E+01    0.93834E+04    0.20368E-46    0.17202E-54    0.11131E-55
+    3    4    0.50593E-09    0.10000E+01    0.75673E+04    0.29366E-45    0.46837E-53    0.15671E-54
+    3    4    0.50593E-09    0.10000E+01    0.61026E+04    0.41993E-44    0.12729E-51    0.22045E-53
+    3    4    0.50593E-09    0.10000E+01    0.49215E+04    0.59882E-43    0.34569E-50    0.31015E-52
+    3    4    0.50593E-09    0.10000E+01    0.39689E+04    0.85299E-42    0.93797E-49    0.43720E-51
+    3    4    0.50593E-09    0.10000E+01    0.32008E+04    0.38187E-39    0.82256E-46    0.19427E-48
+    3    4    0.50593E-09    0.10000E+01    0.25813E+04    0.28295E-30    0.13975E-36    0.14323E-39
+    3    4    0.50593E-09    0.10000E+01    0.20817E+04    0.54533E-14    0.12013E-19    0.27515E-23
+    3    4    0.50593E-09    0.10000E+01    0.16788E+04    0.18583E-08    0.17833E-13    0.93615E-18
+    3    4    0.50593E-09    0.10000E+01    0.13538E+04    0.40006E-08    0.67786E-13    0.20140E-17
+    3    4    0.50593E-09    0.10000E+01    0.10918E+04    0.84169E-08    0.25285E-12    0.42355E-17
+    3    4    0.50593E-09    0.10000E+01    0.88049E+03    0.17321E-07    0.93106E-12    0.87135E-17
+    3    4    0.50593E-09    0.10000E+01    0.71007E+03    0.34944E-07    0.33905E-11    0.17575E-16
+    3    4    0.50593E-09    0.10000E+01    0.57264E+03    0.69292E-07    0.12063E-10    0.34844E-16
+    3    4    0.50593E-09    0.10000E+01    0.46180E+03    0.13514E-06    0.40570E-10    0.67946E-16
+    3    4    0.50593E-09    0.10000E+01    0.37242E+03    0.25798E-06    0.12370E-09    0.12969E-15
+    3    4    0.50593E-09    0.10000E+01    0.30034E+03    0.47655E-06    0.33179E-09    0.23955E-15
+    3    4    0.50593E-09    0.10000E+01    0.24221E+03    0.83964E-06    0.77469E-09    0.42204E-15
+    3    4    0.50593E-09    0.10000E+01    0.19533E+03    0.13233E-05    0.14722E-08    0.66513E-15
+    3    4    0.50593E-09    0.10000E+01    0.15752E+03    0.13233E-05    0.14722E-08    0.66513E-15
+    3    4    0.88282E-09    0.10000E+01    0.80645E+05    0.88415E-56    0.65362E-67    0.21761E-64
+    3    4    0.88282E-09    0.10000E+01    0.65036E+05    0.74062E-55    0.10276E-65    0.18245E-63
+    3    4    0.88282E-09    0.10000E+01    0.52449E+05    0.62265E-54    0.13415E-64    0.15370E-62
+    3    4    0.88282E-09    0.10000E+01    0.42297E+05    0.45756E-53    0.17208E-63    0.11359E-61
+    3    4    0.88282E-09    0.10000E+01    0.34111E+05    0.31464E-52    0.21469E-62    0.79108E-61
+    3    4    0.88282E-09    0.10000E+01    0.27509E+05    0.20885E-51    0.26631E-61    0.53455E-60
+    3    4    0.88282E-09    0.10000E+01    0.22184E+05    0.13849E-50    0.40568E-60    0.34830E-59
+    3    4    0.88282E-09    0.10000E+01    0.17891E+05    0.10685E-49    0.89724E-59    0.22611E-58
+    3    4    0.88282E-09    0.10000E+01    0.14428E+05    0.11334E-48    0.23955E-57    0.16676E-57
+    3    4    0.88282E-09    0.10000E+01    0.11635E+05    0.15076E-47    0.65448E-56    0.16281E-56
+    3    4    0.88282E-09    0.10000E+01    0.93834E+04    0.21340E-46    0.17727E-54    0.20242E-55
+    3    4    0.88282E-09    0.10000E+01    0.75673E+04    0.30302E-45    0.47798E-53    0.27752E-54
+    3    4    0.88282E-09    0.10000E+01    0.61026E+04    0.42888E-44    0.12885E-51    0.38849E-53
+    3    4    0.88282E-09    0.10000E+01    0.49215E+04    0.60657E-43    0.34775E-50    0.54490E-52
+    3    4    0.88282E-09    0.10000E+01    0.39689E+04    0.85861E-42    0.93953E-49    0.76508E-51
+    3    4    0.88282E-09    0.10000E+01    0.32008E+04    0.38267E-39    0.82160E-46    0.33866E-48
+    3    4    0.88282E-09    0.10000E+01    0.25813E+04    0.28271E-30    0.13932E-36    0.24894E-39
+    3    4    0.88282E-09    0.10000E+01    0.20817E+04    0.54381E-14    0.11961E-19    0.47731E-23
+    3    4    0.88282E-09    0.10000E+01    0.16788E+04    0.18514E-08    0.17749E-13    0.16229E-17
+    3    4    0.88282E-09    0.10000E+01    0.13538E+04    0.39842E-08    0.67462E-13    0.34897E-17
+    3    4    0.88282E-09    0.10000E+01    0.10918E+04    0.83801E-08    0.25162E-12    0.73363E-17
+    3    4    0.88282E-09    0.10000E+01    0.88049E+03    0.17242E-07    0.92645E-12    0.15090E-16
+    3    4    0.88282E-09    0.10000E+01    0.71007E+03    0.34780E-07    0.33735E-11    0.30430E-16
+    3    4    0.88282E-09    0.10000E+01    0.57264E+03    0.68960E-07    0.12001E-10    0.60321E-16
+    3    4    0.88282E-09    0.10000E+01    0.46180E+03    0.13448E-06    0.40363E-10    0.11761E-15
+    3    4    0.88282E-09    0.10000E+01    0.37242E+03    0.25671E-06    0.12307E-09    0.22447E-15
+    3    4    0.88282E-09    0.10000E+01    0.30034E+03    0.47417E-06    0.33009E-09    0.41457E-15
+    3    4    0.88282E-09    0.10000E+01    0.24221E+03    0.83541E-06    0.77072E-09    0.73033E-15
+    3    4    0.88282E-09    0.10000E+01    0.19533E+03    0.13166E-05    0.14646E-08    0.11510E-14
+    3    4    0.88282E-09    0.10000E+01    0.15752E+03    0.13166E-05    0.14646E-08    0.11510E-14
+    3    4    0.15405E-08    0.10000E+01    0.80645E+05    0.16765E-55    0.12400E-66    0.72558E-64
+    3    4    0.15405E-08    0.10000E+01    0.65036E+05    0.14050E-54    0.19522E-65    0.60981E-63
+    3    4    0.15405E-08    0.10000E+01    0.52449E+05    0.11828E-53    0.25606E-64    0.51499E-62
+    3    4    0.15405E-08    0.10000E+01    0.42297E+05    0.87251E-53    0.33211E-63    0.38252E-61
+    3    4    0.15405E-08    0.10000E+01    0.34111E+05    0.60529E-52    0.42144E-62    0.26916E-60
+    3    4    0.15405E-08    0.10000E+01    0.27509E+05    0.40678E-51    0.51518E-61    0.18506E-59
+    3    4    0.15405E-08    0.10000E+01    0.22184E+05    0.26613E-50    0.66955E-60    0.12279E-58
+    3    4    0.15405E-08    0.10000E+01    0.17891E+05    0.18155E-49    0.11343E-58    0.78266E-58
+    3    4    0.15405E-08    0.10000E+01    0.14428E+05    0.15183E-48    0.25890E-57    0.50359E-57
+    3    4    0.15405E-08    0.10000E+01    0.11635E+05    0.16878E-47    0.67477E-56    0.37798E-56
+    3    4    0.15405E-08    0.10000E+01    0.93834E+04    0.22269E-46    0.18082E-54    0.38005E-55
+    3    4    0.15405E-08    0.10000E+01    0.75673E+04    0.30995E-45    0.48517E-53    0.48182E-54
+    3    4    0.15405E-08    0.10000E+01    0.61026E+04    0.43555E-44    0.13013E-51    0.66726E-53
+    3    4    0.15405E-08    0.10000E+01    0.49215E+04    0.61280E-43    0.34953E-50    0.93959E-52
+    3    4    0.15405E-08    0.10000E+01    0.39689E+04    0.86333E-42    0.94072E-49    0.13229E-50
+    3    4    0.15405E-08    0.10000E+01    0.32008E+04    0.38329E-39    0.82043E-46    0.58575E-48
+    3    4    0.15405E-08    0.10000E+01    0.25813E+04    0.28237E-30    0.13887E-36    0.43026E-39
+    3    4    0.15405E-08    0.10000E+01    0.20817E+04    0.54217E-14    0.11907E-19    0.82462E-23
+    3    4    0.15405E-08    0.10000E+01    0.16788E+04    0.18444E-08    0.17664E-13    0.28045E-17
+    3    4    0.15405E-08    0.10000E+01    0.13538E+04    0.39673E-08    0.67130E-13    0.60277E-17
+    3    4    0.15405E-08    0.10000E+01    0.10918E+04    0.83424E-08    0.25035E-12    0.12669E-16
+    3    4    0.15405E-08    0.10000E+01    0.88049E+03    0.17161E-07    0.92169E-12    0.26053E-16
+    3    4    0.15405E-08    0.10000E+01    0.71007E+03    0.34612E-07    0.33559E-11    0.52531E-16
+    3    4    0.15405E-08    0.10000E+01    0.57264E+03    0.68618E-07    0.11938E-10    0.10412E-15
+    3    4    0.15405E-08    0.10000E+01    0.46180E+03    0.13380E-06    0.40148E-10    0.20297E-15
+    3    4    0.15405E-08    0.10000E+01    0.37242E+03    0.25539E-06    0.12241E-09    0.38734E-15
+    3    4    0.15405E-08    0.10000E+01    0.30034E+03    0.47170E-06    0.32831E-09    0.71529E-15
+    3    4    0.15405E-08    0.10000E+01    0.24221E+03    0.83101E-06    0.76656E-09    0.12600E-14
+    3    4    0.15405E-08    0.10000E+01    0.19533E+03    0.13097E-05    0.14567E-08    0.19856E-14
+    3    4    0.15405E-08    0.10000E+01    0.15752E+03    0.13097E-05    0.14567E-08    0.19856E-14
+    3    4    0.26880E-08    0.10000E+01    0.80645E+05    0.31105E-55    0.23059E-66    0.23187E-63
+    3    4    0.26880E-08    0.10000E+01    0.65036E+05    0.26118E-54    0.36378E-65    0.19527E-62
+    3    4    0.26880E-08    0.10000E+01    0.52449E+05    0.22034E-53    0.47992E-64    0.16523E-61
+    3    4    0.26880E-08    0.10000E+01    0.42297E+05    0.16331E-52    0.62987E-63    0.12321E-60
+    3    4    0.26880E-08    0.10000E+01    0.34111E+05    0.11440E-51    0.81519E-62    0.87355E-60
+    3    4    0.26880E-08    0.10000E+01    0.27509E+05    0.78105E-51    0.10091E-60    0.60867E-59
+    3    4    0.26880E-08    0.10000E+01    0.22184E+05    0.51579E-50    0.12271E-59    0.41190E-58
+    3    4    0.26880E-08    0.10000E+01    0.17891E+05    0.33498E-49    0.16649E-58    0.26662E-57
+    3    4    0.26880E-08    0.10000E+01    0.14428E+05    0.23459E-48    0.29832E-57    0.16635E-56
+    3    4    0.26880E-08    0.10000E+01    0.11635E+05    0.20603E-47    0.69467E-56    0.10714E-55
+    3    4    0.26880E-08    0.10000E+01    0.93834E+04    0.23588E-46    0.18137E-54    0.83140E-55
+    3    4    0.26880E-08    0.10000E+01    0.75673E+04    0.31355E-45    0.48601E-53    0.87290E-54
+    3    4    0.26880E-08    0.10000E+01    0.61026E+04    0.43691E-44    0.13045E-51    0.11373E-52
+    3    4    0.26880E-08    0.10000E+01    0.49215E+04    0.61418E-43    0.34997E-50    0.15962E-51
+    3    4    0.26880E-08    0.10000E+01    0.39689E+04    0.86433E-42    0.94008E-49    0.22639E-50
+    3    4    0.26880E-08    0.10000E+01    0.32008E+04    0.38305E-39    0.81844E-46    0.10072E-47
+    3    4    0.26880E-08    0.10000E+01    0.25813E+04    0.28171E-30    0.13837E-36    0.74105E-39
+    3    4    0.26880E-08    0.10000E+01    0.20817E+04    0.54032E-14    0.11855E-19    0.14213E-22
+    3    4    0.26880E-08    0.10000E+01    0.16788E+04    0.18376E-08    0.17582E-13    0.48380E-17
+    3    4    0.26880E-08    0.10000E+01    0.13538E+04    0.39510E-08    0.66812E-13    0.10390E-16
+    3    4    0.26880E-08    0.10000E+01    0.10918E+04    0.83060E-08    0.24913E-12    0.21827E-16
+    3    4    0.26880E-08    0.10000E+01    0.88049E+03    0.17084E-07    0.91708E-12    0.44874E-16
+    3    4    0.26880E-08    0.10000E+01    0.71007E+03    0.34450E-07    0.33387E-11    0.90455E-16
+    3    4    0.26880E-08    0.10000E+01    0.57264E+03    0.68288E-07    0.11876E-10    0.17924E-15
+    3    4    0.26880E-08    0.10000E+01    0.46180E+03    0.13314E-06    0.39937E-10    0.34935E-15
+    3    4    0.26880E-08    0.10000E+01    0.37242E+03    0.25410E-06    0.12176E-09    0.66654E-15
+    3    4    0.26880E-08    0.10000E+01    0.30034E+03    0.46929E-06    0.32656E-09    0.12307E-14
+    3    4    0.26880E-08    0.10000E+01    0.24221E+03    0.82672E-06    0.76247E-09    0.21676E-14
+    3    4    0.26880E-08    0.10000E+01    0.19533E+03    0.13028E-05    0.14489E-08    0.34156E-14
+    3    4    0.26880E-08    0.10000E+01    0.15752E+03    0.13028E-05    0.14489E-08    0.34156E-14
+    3    4    0.46905E-08    0.10000E+01    0.80645E+05    0.57369E-55    0.42704E-66    0.13729E-62
+    3    4    0.46905E-08    0.10000E+01    0.65036E+05    0.48332E-54    0.67570E-65    0.11601E-61
+    3    4    0.46905E-08    0.10000E+01    0.52449E+05    0.40906E-53    0.89842E-64    0.98466E-61
+    3    4    0.46905E-08    0.10000E+01    0.42297E+05    0.30512E-52    0.11968E-62    0.73856E-60
+    3    4    0.46905E-08    0.10000E+01    0.34111E+05    0.21644E-51    0.15894E-61    0.52946E-59
+    3    4    0.46905E-08    0.10000E+01    0.27509E+05    0.15104E-50    0.20450E-60    0.37613E-58
+    3    4    0.46905E-08    0.10000E+01    0.22184E+05    0.10297E-49    0.25552E-59    0.26307E-57
+    3    4    0.46905E-08    0.10000E+01    0.17891E+05    0.68479E-49    0.32445E-58    0.17907E-56
+    3    4    0.46905E-08    0.10000E+01    0.14428E+05    0.45852E-48    0.46476E-57    0.11806E-55
+    3    4    0.46905E-08    0.10000E+01    0.11635E+05    0.33591E-47    0.83523E-56    0.75861E-55
+    3    4    0.46905E-08    0.10000E+01    0.93834E+04    0.29966E-46    0.18759E-54    0.48648E-54
+    3    4    0.46905E-08    0.10000E+01    0.75673E+04    0.33529E-45    0.47847E-53    0.33142E-53
+    3    4    0.46905E-08    0.10000E+01    0.61026E+04    0.43590E-44    0.12780E-51    0.27096E-52
+    3    4    0.46905E-08    0.10000E+01    0.49215E+04    0.60378E-43    0.34483E-50    0.29067E-51
+    3    4    0.46905E-08    0.10000E+01    0.39689E+04    0.85167E-42    0.93080E-49    0.38064E-50
+    3    4    0.46905E-08    0.10000E+01    0.32008E+04    0.37908E-39    0.81241E-46    0.16903E-47
+    3    4    0.46905E-08    0.10000E+01    0.25813E+04    0.27952E-30    0.13749E-36    0.12576E-38
+    3    4    0.46905E-08    0.10000E+01    0.20817E+04    0.53686E-14    0.11778E-19    0.24345E-22
+    3    4    0.46905E-08    0.10000E+01    0.16788E+04    0.18273E-08    0.17463E-13    0.83139E-17
+    3    4    0.46905E-08    0.10000E+01    0.13538E+04    0.39267E-08    0.66350E-13    0.17740E-16
+    3    4    0.46905E-08    0.10000E+01    0.10918E+04    0.82522E-08    0.24737E-12    0.37131E-16
+    3    4    0.46905E-08    0.10000E+01    0.88049E+03    0.16970E-07    0.91050E-12    0.76155E-16
+    3    4    0.46905E-08    0.10000E+01    0.71007E+03    0.34215E-07    0.33144E-11    0.15325E-15
+    3    4    0.46905E-08    0.10000E+01    0.57264E+03    0.67812E-07    0.11788E-10    0.30326E-15
+    3    4    0.46905E-08    0.10000E+01    0.46180E+03    0.13220E-06    0.39640E-10    0.59044E-15
+    3    4    0.46905E-08    0.10000E+01    0.37242E+03    0.25228E-06    0.12085E-09    0.11255E-14
+    3    4    0.46905E-08    0.10000E+01    0.30034E+03    0.46588E-06    0.32412E-09    0.20768E-14
+    3    4    0.46905E-08    0.10000E+01    0.24221E+03    0.82066E-06    0.75676E-09    0.36562E-14
+    3    4    0.46905E-08    0.10000E+01    0.19533E+03    0.12932E-05    0.14380E-08    0.57593E-14
+    3    4    0.46905E-08    0.10000E+01    0.15752E+03    0.12932E-05    0.14380E-08    0.57593E-14
+    3    4    0.81846E-08    0.10000E+01    0.80645E+05    0.10110E-54    0.75562E-66    0.15631E-61
+    3    4    0.81846E-08    0.10000E+01    0.65036E+05    0.85456E-54    0.11990E-64    0.13247E-60
+    3    4    0.81846E-08    0.10000E+01    0.52449E+05    0.72554E-53    0.16061E-63    0.11273E-59
+    3    4    0.81846E-08    0.10000E+01    0.42297E+05    0.54447E-52    0.21687E-62    0.84964E-59
+    3    4    0.81846E-08    0.10000E+01    0.34111E+05    0.39070E-51    0.29476E-61    0.61441E-58
+    3    4    0.81846E-08    0.10000E+01    0.27509E+05    0.27819E-50    0.39405E-60    0.44284E-57
+    3    4    0.81846E-08    0.10000E+01    0.22184E+05    0.19593E-49    0.51840E-59    0.31725E-56
+    3    4    0.81846E-08    0.10000E+01    0.17891E+05    0.13617E-48    0.68397E-58    0.22443E-55
+    3    4    0.81846E-08    0.10000E+01    0.14428E+05    0.94576E-48    0.94409E-57    0.15644E-54
+    3    4    0.81846E-08    0.10000E+01    0.11635E+05    0.67911E-47    0.14470E-55    0.10760E-53
+    3    4    0.81846E-08    0.10000E+01    0.93834E+04    0.53254E-46    0.26026E-54    0.73084E-53
+    3    4    0.81846E-08    0.10000E+01    0.75673E+04    0.48417E-45    0.55635E-53    0.48901E-52
+    3    4    0.81846E-08    0.10000E+01    0.61026E+04    0.52346E-44    0.13533E-51    0.32198E-51
+    3    4    0.81846E-08    0.10000E+01    0.49215E+04    0.65109E-43    0.35265E-50    0.21199E-50
+    3    4    0.81846E-08    0.10000E+01    0.39689E+04    0.87785E-42    0.94411E-49    0.14894E-49
+    3    4    0.81846E-08    0.10000E+01    0.32008E+04    0.38558E-39    0.82374E-46    0.40236E-47
+    3    4    0.81846E-08    0.10000E+01    0.25813E+04    0.28375E-30    0.13939E-36    0.24147E-38
+    3    4    0.81846E-08    0.10000E+01    0.20817E+04    0.54507E-14    0.11906E-19    0.46849E-22
+    3    4    0.81846E-08    0.10000E+01    0.16788E+04    0.18530E-08    0.17618E-13    0.15869E-16
+    3    4    0.81846E-08    0.10000E+01    0.13538E+04    0.39731E-08    0.66914E-13    0.31682E-16
+    3    4    0.81846E-08    0.10000E+01    0.10918E+04    0.83386E-08    0.24942E-12    0.63868E-16
+    3    4    0.81846E-08    0.10000E+01    0.88049E+03    0.17133E-07    0.91793E-12    0.12812E-15
+    3    4    0.81846E-08    0.10000E+01    0.71007E+03    0.34524E-07    0.33412E-11    0.25420E-15
+    3    4    0.81846E-08    0.10000E+01    0.57264E+03    0.68401E-07    0.11883E-10    0.49820E-15
+    3    4    0.81846E-08    0.10000E+01    0.46180E+03    0.13332E-06    0.39959E-10    0.96328E-15
+    3    4    0.81846E-08    0.10000E+01    0.37242E+03    0.25437E-06    0.12183E-09    0.18271E-14
+    3    4    0.81846E-08    0.10000E+01    0.30034E+03    0.46970E-06    0.32673E-09    0.33591E-14
+    3    4    0.81846E-08    0.10000E+01    0.24221E+03    0.82734E-06    0.76284E-09    0.58988E-14
+    3    4    0.81846E-08    0.10000E+01    0.19533E+03    0.13037E-05    0.14496E-08    0.92776E-14
+    3    4    0.81846E-08    0.10000E+01    0.15752E+03    0.13037E-05    0.14496E-08    0.92776E-14
+    3    4    0.14282E-07    0.10000E+01    0.80645E+05    0.17474E-54    0.13074E-65    0.45841E-61
+    3    4    0.14282E-07    0.10000E+01    0.65036E+05    0.14783E-53    0.20760E-64    0.38869E-60
+    3    4    0.14282E-07    0.10000E+01    0.52449E+05    0.12560E-52    0.27855E-63    0.33092E-59
+    3    4    0.14282E-07    0.10000E+01    0.42297E+05    0.94387E-52    0.37721E-62    0.24961E-58
+    3    4    0.14282E-07    0.10000E+01    0.34111E+05    0.67898E-51    0.51493E-61    0.18075E-57
+    3    4    0.14282E-07    0.10000E+01    0.27509E+05    0.48530E-50    0.69226E-60    0.13057E-56
+    3    4    0.14282E-07    0.10000E+01    0.22184E+05    0.34347E-49    0.91393E-59    0.93877E-56
+    3    4    0.14282E-07    0.10000E+01    0.17891E+05    0.23950E-48    0.11963E-57    0.66782E-55
+    3    4    0.14282E-07    0.10000E+01    0.14428E+05    0.16542E-47    0.15921E-56    0.46923E-54
+    3    4    0.14282E-07    0.10000E+01    0.11635E+05    0.11536E-46    0.22426E-55    0.32605E-53
+    3    4    0.14282E-07    0.10000E+01    0.93834E+04    0.84147E-46    0.35309E-54    0.22417E-52
+    3    4    0.14282E-07    0.10000E+01    0.75673E+04    0.67673E-45    0.65511E-53    0.15201E-51
+    3    4    0.14282E-07    0.10000E+01    0.61026E+04    0.63487E-44    0.14414E-51    0.10114E-50
+    3    4    0.14282E-07    0.10000E+01    0.49215E+04    0.70749E-43    0.35758E-50    0.66063E-50
+    3    4    0.14282E-07    0.10000E+01    0.39689E+04    0.89920E-42    0.94114E-49    0.43459E-49
+    3    4    0.14282E-07    0.10000E+01    0.32008E+04    0.38608E-39    0.81831E-46    0.99722E-47
+    3    4    0.14282E-07    0.10000E+01    0.25813E+04    0.28262E-30    0.13854E-36    0.50035E-38
+    3    4    0.14282E-07    0.10000E+01    0.20817E+04    0.54379E-14    0.11830E-19    0.92207E-22
+    3    4    0.14282E-07    0.10000E+01    0.16788E+04    0.18495E-08    0.17488E-13    0.30568E-16
+    3    4    0.14282E-07    0.10000E+01    0.13538E+04    0.39552E-08    0.66400E-13    0.57999E-16
+    3    4    0.14282E-07    0.10000E+01    0.10918E+04    0.82893E-08    0.24743E-12    0.11337E-15
+    3    4    0.14282E-07    0.10000E+01    0.88049E+03    0.17017E-07    0.91033E-12    0.22326E-15
+    3    4    0.14282E-07    0.10000E+01    0.71007E+03    0.34272E-07    0.33128E-11    0.43797E-15
+    3    4    0.14282E-07    0.10000E+01    0.57264E+03    0.67874E-07    0.11780E-10    0.85203E-15
+    3    4    0.14282E-07    0.10000E+01    0.46180E+03    0.13225E-06    0.39609E-10    0.16391E-14
+    3    4    0.14282E-07    0.10000E+01    0.37242E+03    0.25227E-06    0.12075E-09    0.30979E-14
+    3    4    0.14282E-07    0.10000E+01    0.30034E+03    0.46574E-06    0.32383E-09    0.56817E-14
+    3    4    0.14282E-07    0.10000E+01    0.24221E+03    0.82026E-06    0.75605E-09    0.99607E-14
+    3    4    0.14282E-07    0.10000E+01    0.19533E+03    0.12925E-05    0.14367E-08    0.15650E-13
+    3    4    0.14282E-07    0.10000E+01    0.15752E+03    0.12925E-05    0.14367E-08    0.15650E-13
+    3    4    0.24920E-07    0.10000E+01    0.80645E+05    0.29926E-54    0.22410E-65    0.13350E-60
+    3    4    0.24920E-07    0.10000E+01    0.65036E+05    0.25335E-53    0.35606E-64    0.11325E-59
+    3    4    0.24920E-07    0.10000E+01    0.52449E+05    0.21540E-52    0.47844E-63    0.96450E-59
+    3    4    0.24920E-07    0.10000E+01    0.42297E+05    0.16206E-51    0.64952E-62    0.72798E-58
+    3    4    0.24920E-07    0.10000E+01    0.34111E+05    0.11683E-50    0.89009E-61    0.52779E-57
+    3    4    0.24920E-07    0.10000E+01    0.27509E+05    0.83788E-50    0.12033E-59    0.38198E-56
+    3    4    0.24920E-07    0.10000E+01    0.22184E+05    0.59588E-49    0.15981E-58    0.27545E-55
+    3    4    0.24920E-07    0.10000E+01    0.17891E+05    0.41775E-48    0.20955E-57    0.19685E-54
+    3    4    0.24920E-07    0.10000E+01    0.14428E+05    0.28917E-47    0.27536E-56    0.13920E-53
+    3    4    0.24920E-07    0.10000E+01    0.11635E+05    0.19978E-46    0.37110E-55    0.97528E-53
+    3    4    0.24920E-07    0.10000E+01    0.93834E+04    0.14055E-45    0.53207E-54    0.67730E-52
+    3    4    0.24920E-07    0.10000E+01    0.75673E+04    0.10419E-44    0.85951E-53    0.46484E-51
+    3    4    0.24920E-07    0.10000E+01    0.61026E+04    0.85883E-44    0.16494E-51    0.31344E-50
+    3    4    0.24920E-07    0.10000E+01    0.49215E+04    0.83282E-43    0.37443E-50    0.20654E-49
+    3    4    0.24920E-07    0.10000E+01    0.39689E+04    0.95855E-42    0.94743E-49    0.13361E-48
+    3    4    0.24920E-07    0.10000E+01    0.32008E+04    0.39221E-39    0.81403E-46    0.28008E-46
+    3    4    0.24920E-07    0.10000E+01    0.25813E+04    0.28280E-30    0.13763E-36    0.11802E-37
+    3    4    0.24920E-07    0.10000E+01    0.20817E+04    0.54451E-14    0.11741E-19    0.19723E-21
+    3    4    0.24920E-07    0.10000E+01    0.16788E+04    0.18517E-08    0.17330E-13    0.62773E-16
+    3    4    0.24920E-07    0.10000E+01    0.13538E+04    0.39406E-08    0.65767E-13    0.11085E-15
+    3    4    0.24920E-07    0.10000E+01    0.10918E+04    0.82371E-08    0.24496E-12    0.20658E-15
+    3    4    0.24920E-07    0.10000E+01    0.88049E+03    0.16884E-07    0.90087E-12    0.39487E-15
+    3    4    0.24920E-07    0.10000E+01    0.71007E+03    0.33972E-07    0.32773E-11    0.76038E-15
+    3    4    0.24920E-07    0.10000E+01    0.57264E+03    0.67233E-07    0.11652E-10    0.14617E-14
+    3    4    0.24920E-07    0.10000E+01    0.46180E+03    0.13093E-06    0.39169E-10    0.27897E-14
+    3    4    0.24920E-07    0.10000E+01    0.37242E+03    0.24967E-06    0.11940E-09    0.52440E-14
+    3    4    0.24920E-07    0.10000E+01    0.30034E+03    0.46080E-06    0.32018E-09    0.95822E-14
+    3    4    0.24920E-07    0.10000E+01    0.24221E+03    0.81141E-06    0.74752E-09    0.16757E-13
+    3    4    0.24920E-07    0.10000E+01    0.19533E+03    0.12784E-05    0.14204E-08    0.26289E-13
+    3    4    0.24920E-07    0.10000E+01    0.15752E+03    0.12784E-05    0.14204E-08    0.26289E-13
+    3    4    0.43485E-07    0.10000E+01    0.80645E+05    0.50827E-54    0.38091E-65    0.38645E-60
+    3    4    0.43485E-07    0.10000E+01    0.65036E+05    0.43057E-53    0.60550E-64    0.32793E-59
+    3    4    0.43485E-07    0.10000E+01    0.52449E+05    0.36627E-52    0.81463E-63    0.27938E-58
+    3    4    0.43485E-07    0.10000E+01    0.42297E+05    0.27586E-51    0.11083E-61    0.21099E-57
+    3    4    0.43485E-07    0.10000E+01    0.34111E+05    0.19923E-50    0.15238E-60    0.15312E-56
+    3    4    0.43485E-07    0.10000E+01    0.27509E+05    0.14330E-49    0.20703E-59    0.11100E-55
+    3    4    0.43485E-07    0.10000E+01    0.22184E+05    0.10236E-48    0.27675E-58    0.80242E-55
+    3    4    0.43485E-07    0.10000E+01    0.17891E+05    0.72170E-48    0.36495E-57    0.57562E-54
+    3    4    0.43485E-07    0.10000E+01    0.14428E+05    0.50223E-47    0.47916E-56    0.40921E-53
+    3    4    0.43485E-07    0.10000E+01    0.11635E+05    0.34712E-46    0.63430E-55    0.28863E-52
+    3    4    0.43485E-07    0.10000E+01    0.93834E+04    0.24090E-45    0.86309E-54    0.20209E-51
+    3    4    0.43485E-07    0.10000E+01    0.75673E+04    0.17095E-44    0.12567E-52    0.14010E-50
+    3    4    0.43485E-07    0.10000E+01    0.61026E+04    0.12859E-43    0.20894E-51    0.95657E-50
+    3    4    0.43485E-07    0.10000E+01    0.49215E+04    0.10886E-42    0.41676E-50    0.63891E-49
+    3    4    0.43485E-07    0.10000E+01    0.39689E+04    0.10958E-41    0.97778E-49    0.41574E-48
+    3    4    0.43485E-07    0.10000E+01    0.32008E+04    0.41147E-39    0.81520E-46    0.84381E-46
+    3    4    0.43485E-07    0.10000E+01    0.25813E+04    0.28653E-30    0.13686E-36    0.31502E-37
+    3    4    0.43485E-07    0.10000E+01    0.20817E+04    0.54993E-14    0.11648E-19    0.46447E-21
+    3    4    0.43485E-07    0.10000E+01    0.16788E+04    0.18668E-08    0.17150E-13    0.13924E-15
+    3    4    0.43485E-07    0.10000E+01    0.13538E+04    0.39379E-08    0.65035E-13    0.22500E-15
+    3    4    0.43485E-07    0.10000E+01    0.10918E+04    0.81925E-08    0.24206E-12    0.39198E-15
+    3    4    0.43485E-07    0.10000E+01    0.88049E+03    0.16747E-07    0.88970E-12    0.71589E-15
+    3    4    0.43485E-07    0.10000E+01    0.71007E+03    0.33640E-07    0.32352E-11    0.13386E-14
+    3    4    0.43485E-07    0.10000E+01    0.57264E+03    0.66502E-07    0.11498E-10    0.25249E-14
+    3    4    0.43485E-07    0.10000E+01    0.46180E+03    0.12940E-06    0.38644E-10    0.47589E-14
+    3    4    0.43485E-07    0.10000E+01    0.37242E+03    0.24661E-06    0.11778E-09    0.88712E-14
+    3    4    0.43485E-07    0.10000E+01    0.30034E+03    0.45497E-06    0.31582E-09    0.16120E-13
+    3    4    0.43485E-07    0.10000E+01    0.24221E+03    0.80090E-06    0.73730E-09    0.28086E-13
+    3    4    0.43485E-07    0.10000E+01    0.19533E+03    0.12616E-05    0.14010E-08    0.43963E-13
+    3    4    0.43485E-07    0.10000E+01    0.15752E+03    0.12616E-05    0.14010E-08    0.43963E-13
+    3    4    0.75878E-07    0.10000E+01    0.80645E+05    0.85680E-54    0.64253E-65    0.11128E-59
+    3    4    0.75878E-07    0.10000E+01    0.65036E+05    0.72621E-53    0.10218E-63    0.94456E-59
+    3    4    0.75878E-07    0.10000E+01    0.52449E+05    0.61806E-52    0.13762E-62    0.80495E-58
+    3    4    0.75878E-07    0.10000E+01    0.42297E+05    0.46590E-51    0.18757E-61    0.60820E-57
+    3    4    0.75878E-07    0.10000E+01    0.34111E+05    0.33700E-50    0.25862E-60    0.44177E-56
+    3    4    0.75878E-07    0.10000E+01    0.27509E+05    0.24300E-49    0.35289E-59    0.32067E-55
+    3    4    0.75878E-07    0.10000E+01    0.22184E+05    0.17424E-48    0.47461E-58    0.23231E-54
+    3    4    0.75878E-07    0.10000E+01    0.17891E+05    0.12351E-47    0.63012E-57    0.16718E-53
+    3    4    0.75878E-07    0.10000E+01    0.14428E+05    0.86479E-47    0.83092E-56    0.11937E-52
+    3    4    0.75878E-07    0.10000E+01    0.11635E+05    0.60043E-46    0.10957E-54    0.84667E-52
+    3    4    0.75878E-07    0.10000E+01    0.93834E+04    0.41585E-45    0.14565E-53    0.59678E-51
+    3    4    0.75878E-07    0.10000E+01    0.75673E+04    0.28970E-44    0.19943E-52    0.41717E-50
+    3    4    0.75878E-07    0.10000E+01    0.61026E+04    0.20688E-43    0.29547E-51    0.28787E-49
+    3    4    0.75878E-07    0.10000E+01    0.49215E+04    0.15805E-42    0.50898E-50    0.19486E-48
+    3    4    0.75878E-07    0.10000E+01    0.39689E+04    0.13815E-41    0.10607E-48    0.12852E-47
+    3    4    0.75878E-07    0.10000E+01    0.32008E+04    0.45789E-39    0.83095E-46    0.26054E-45
+    3    4    0.75878E-07    0.10000E+01    0.25813E+04    0.29818E-30    0.13659E-36    0.91447E-37
+    3    4    0.75878E-07    0.10000E+01    0.20817E+04    0.56483E-14    0.11557E-19    0.11963E-20
+    3    4    0.75878E-07    0.10000E+01    0.16788E+04    0.19065E-08    0.16953E-13    0.33425E-15
+    3    4    0.75878E-07    0.10000E+01    0.13538E+04    0.39604E-08    0.64214E-13    0.49173E-15
+    3    4    0.75878E-07    0.10000E+01    0.10918E+04    0.81709E-08    0.23877E-12    0.78751E-15
+    3    4    0.75878E-07    0.10000E+01    0.88049E+03    0.16625E-07    0.87687E-12    0.13488E-14
+    3    4    0.75878E-07    0.10000E+01    0.71007E+03    0.33299E-07    0.31865E-11    0.24122E-14
+    3    4    0.75878E-07    0.10000E+01    0.57264E+03    0.65705E-07    0.11319E-10    0.44174E-14
+    3    4    0.75878E-07    0.10000E+01    0.46180E+03    0.12769E-06    0.38032E-10    0.81648E-14
+    3    4    0.75878E-07    0.10000E+01    0.37242E+03    0.24313E-06    0.11589E-09    0.15025E-13
+    3    4    0.75878E-07    0.10000E+01    0.30034E+03    0.44826E-06    0.31073E-09    0.27070E-13
+    3    4    0.75878E-07    0.10000E+01    0.24221E+03    0.78876E-06    0.72536E-09    0.46902E-13
+    3    4    0.75878E-07    0.10000E+01    0.19533E+03    0.12421E-05    0.13782E-08    0.73176E-13
+    3    4    0.75878E-07    0.10000E+01    0.15752E+03    0.12421E-05    0.13782E-08    0.73176E-13
+    3    4    0.13240E-06    0.10000E+01    0.80645E+05    0.14346E-53    0.10765E-64    0.31895E-59
+    3    4    0.13240E-06    0.10000E+01    0.65036E+05    0.12165E-52    0.17126E-63    0.27081E-58
+    3    4    0.13240E-06    0.10000E+01    0.52449E+05    0.10358E-51    0.23086E-62    0.23084E-57
+    3    4    0.13240E-06    0.10000E+01    0.42297E+05    0.78137E-51    0.31514E-61    0.17449E-56
+    3    4    0.13240E-06    0.10000E+01    0.34111E+05    0.56594E-50    0.43552E-60    0.12683E-55
+    3    4    0.13240E-06    0.10000E+01    0.27509E+05    0.40894E-49    0.59650E-59    0.92173E-55
+    3    4    0.13240E-06    0.10000E+01    0.22184E+05    0.29419E-48    0.80660E-58    0.66897E-54
+    3    4    0.13240E-06    0.10000E+01    0.17891E+05    0.20952E-47    0.10780E-56    0.48273E-53
+    3    4    0.13240E-06    0.10000E+01    0.14428E+05    0.14758E-46    0.14302E-55    0.34597E-52
+    3    4    0.13240E-06    0.10000E+01    0.11635E+05    0.10307E-45    0.18908E-54    0.24652E-51
+    3    4    0.13240E-06    0.10000E+01    0.93834E+04    0.71617E-45    0.24962E-53    0.17472E-50
+    3    4    0.13240E-06    0.10000E+01    0.75673E+04    0.49658E-44    0.33193E-52    0.12297E-49
+    3    4    0.13240E-06    0.10000E+01    0.61026E+04    0.34631E-43    0.45732E-51    0.85608E-49
+    3    4    0.13240E-06    0.10000E+01    0.49215E+04    0.24869E-42    0.69348E-50    0.58629E-48
+    3    4    0.13240E-06    0.10000E+01    0.39689E+04    0.19377E-41    0.12484E-48    0.39232E-47
+    3    4    0.13240E-06    0.10000E+01    0.32008E+04    0.55664E-39    0.87940E-46    0.80440E-45
+    3    4    0.13240E-06    0.10000E+01    0.25813E+04    0.32595E-30    0.13768E-36    0.27638E-36
+    3    4    0.13240E-06    0.10000E+01    0.20817E+04    0.59774E-14    0.11478E-19    0.32959E-20
+    3    4    0.13240E-06    0.10000E+01    0.16788E+04    0.19909E-08    0.16743E-13    0.85944E-15
+    3    4    0.13240E-06    0.10000E+01    0.13538E+04    0.40308E-08    0.63318E-13    0.11621E-14
+    3    4    0.13240E-06    0.10000E+01    0.10918E+04    0.81979E-08    0.23511E-12    0.16995E-14
+    3    4    0.13240E-06    0.10000E+01    0.88049E+03    0.16545E-07    0.86242E-12    0.26845E-14
+    3    4    0.13240E-06    0.10000E+01    0.71007E+03    0.32981E-07    0.31311E-11    0.45100E-14
+    3    4    0.13240E-06    0.10000E+01    0.57264E+03    0.64881E-07    0.11116E-10    0.79002E-14
+    3    4    0.13240E-06    0.10000E+01    0.46180E+03    0.12584E-06    0.37332E-10    0.14168E-13
+    3    4    0.13240E-06    0.10000E+01    0.37242E+03    0.23926E-06    0.11373E-09    0.25555E-13
+    3    4    0.13240E-06    0.10000E+01    0.30034E+03    0.44073E-06    0.30488E-09    0.45442E-13
+    3    4    0.13240E-06    0.10000E+01    0.24221E+03    0.77500E-06    0.71164E-09    0.78072E-13
+    3    4    0.13240E-06    0.10000E+01    0.19533E+03    0.12200E-05    0.13521E-08    0.12120E-12
+    3    4    0.13240E-06    0.10000E+01    0.15752E+03    0.12200E-05    0.13521E-08    0.12120E-12
+    3    4    0.23103E-06    0.10000E+01    0.80645E+05    0.23877E-53    0.17925E-64    0.91052E-59
+    3    4    0.23103E-06    0.10000E+01    0.65036E+05    0.20255E-52    0.28526E-63    0.77328E-58
+    3    4    0.23103E-06    0.10000E+01    0.52449E+05    0.17252E-51    0.38484E-62    0.65927E-57
+    3    4    0.23103E-06    0.10000E+01    0.42297E+05    0.13023E-50    0.52601E-61    0.49853E-56
+    3    4    0.23103E-06    0.10000E+01    0.34111E+05    0.94428E-50    0.72842E-60    0.36261E-55
+    3    4    0.23103E-06    0.10000E+01    0.27509E+05    0.68355E-49    0.10008E-58    0.26378E-54
+    3    4    0.23103E-06    0.10000E+01    0.22184E+05    0.49311E-48    0.13597E-57    0.19174E-53
+    3    4    0.23103E-06    0.10000E+01    0.17891E+05    0.35265E-47    0.18281E-56    0.13868E-52
+    3    4    0.23103E-06    0.10000E+01    0.14428E+05    0.24974E-46    0.24408E-55    0.99708E-52
+    3    4    0.23103E-06    0.10000E+01    0.11635E+05    0.17546E-45    0.32433E-54    0.71324E-51
+    3    4    0.23103E-06    0.10000E+01    0.93834E+04    0.12255E-44    0.42860E-53    0.50788E-50
+    3    4    0.23103E-06    0.10000E+01    0.75673E+04    0.85131E-44    0.56422E-52    0.35948E-49
+    3    4    0.23103E-06    0.10000E+01    0.61026E+04    0.58924E-43    0.74937E-51    0.25208E-48
+    3    4    0.23103E-06    0.10000E+01    0.49215E+04    0.41059E-42    0.10424E-49    0.17434E-47
+    3    4    0.23103E-06    0.10000E+01    0.39689E+04    0.29709E-41    0.16325E-48    0.11820E-46
+    3    4    0.23103E-06    0.10000E+01    0.32008E+04    0.75148E-39    0.99449E-46    0.24592E-44
+    3    4    0.23103E-06    0.10000E+01    0.25813E+04    0.38464E-30    0.14183E-36    0.84471E-36
+    3    4    0.23103E-06    0.10000E+01    0.20817E+04    0.66370E-14    0.11428E-19    0.94662E-20
+    3    4    0.23103E-06    0.10000E+01    0.16788E+04    0.21538E-08    0.16526E-13    0.23264E-14
+    3    4    0.23103E-06    0.10000E+01    0.13538E+04    0.41872E-08    0.62359E-13    0.29476E-14
+    3    4    0.23103E-06    0.10000E+01    0.10918E+04    0.83159E-08    0.23110E-12    0.39654E-14
+    3    4    0.23103E-06    0.10000E+01    0.88049E+03    0.16556E-07    0.84639E-12    0.57330E-14
+    3    4    0.23103E-06    0.10000E+01    0.71007E+03    0.32737E-07    0.30691E-11    0.88974E-14
+    3    4    0.23103E-06    0.10000E+01    0.57264E+03    0.64084E-07    0.10886E-10    0.14642E-13
+    3    4    0.23103E-06    0.10000E+01    0.46180E+03    0.12389E-06    0.36539E-10    0.25097E-13
+    3    4    0.23103E-06    0.10000E+01    0.37242E+03    0.23508E-06    0.11128E-09    0.43887E-13
+    3    4    0.23103E-06    0.10000E+01    0.30034E+03    0.43240E-06    0.29824E-09    0.76467E-13
+    3    4    0.23103E-06    0.10000E+01    0.24221E+03    0.75965E-06    0.69604E-09    0.12967E-12
+    3    4    0.23103E-06    0.10000E+01    0.19533E+03    0.11951E-05    0.13224E-08    0.19978E-12
+    3    4    0.23103E-06    0.10000E+01    0.15752E+03    0.11951E-05    0.13224E-08    0.19978E-12
+    3    4    0.40314E-06    0.10000E+01    0.80645E+05    0.39524E-53    0.29684E-64    0.25902E-58
+    3    4    0.40314E-06    0.10000E+01    0.65036E+05    0.33541E-52    0.47253E-63    0.22002E-57
+    3    4    0.40314E-06    0.10000E+01    0.52449E+05    0.28576E-51    0.63791E-62    0.18762E-56
+    3    4    0.40314E-06    0.10000E+01    0.42297E+05    0.21583E-50    0.87289E-61    0.14192E-55
+    3    4    0.40314E-06    0.10000E+01    0.34111E+05    0.15665E-49    0.12109E-59    0.10328E-54
+    3    4    0.40314E-06    0.10000E+01    0.27509E+05    0.11357E-48    0.16681E-58    0.75199E-54
+    3    4    0.40314E-06    0.10000E+01    0.22184E+05    0.82126E-48    0.22754E-57    0.54737E-53
+    3    4    0.40314E-06    0.10000E+01    0.17891E+05    0.58941E-47    0.30755E-56    0.39669E-52
+    3    4    0.40314E-06    0.10000E+01    0.14428E+05    0.41938E-46    0.41307E-55    0.28598E-51
+    3    4    0.40314E-06    0.10000E+01    0.11635E+05    0.29627E-45    0.55202E-54    0.20525E-50
+    3    4    0.40314E-06    0.10000E+01    0.93834E+04    0.20809E-44    0.73267E-53    0.14673E-49
+    3    4    0.40314E-06    0.10000E+01    0.75673E+04    0.14521E-43    0.96418E-52    0.10435E-48
+    3    4    0.40314E-06    0.10000E+01    0.61026E+04    0.10057E-42    0.12628E-50    0.73622E-48
+    3    4    0.40314E-06    0.10000E+01    0.49215E+04    0.69321E-42    0.16767E-49    0.51332E-47
+    3    4    0.40314E-06    0.10000E+01    0.39689E+04    0.48265E-41    0.23698E-48    0.35192E-46
+    3    4    0.40314E-06    0.10000E+01    0.32008E+04    0.11169E-38    0.12370E-45    0.74265E-44
+    3    4    0.40314E-06    0.10000E+01    0.25813E+04    0.50014E-30    0.15238E-36    0.25731E-35
+    3    4    0.40314E-06    0.10000E+01    0.20817E+04    0.78887E-14    0.11436E-19    0.27768E-19
+    3    4    0.40314E-06    0.10000E+01    0.16788E+04    0.24528E-08    0.16310E-13    0.65153E-14
+    3    4    0.40314E-06    0.10000E+01    0.13538E+04    0.44942E-08    0.61352E-13    0.79030E-14
+    3    4    0.40314E-06    0.10000E+01    0.10918E+04    0.85969E-08    0.22678E-12    0.99573E-14
+    3    4    0.40314E-06    0.10000E+01    0.88049E+03    0.16735E-07    0.82879E-12    0.13255E-13
+    3    4    0.40314E-06    0.10000E+01    0.71007E+03    0.32655E-07    0.30003E-11    0.18848E-13
+    3    4    0.40314E-06    0.10000E+01    0.57264E+03    0.63408E-07    0.10629E-10    0.28643E-13
+    3    4    0.40314E-06    0.10000E+01    0.46180E+03    0.12197E-06    0.35649E-10    0.46053E-13
+    3    4    0.40314E-06    0.10000E+01    0.37242E+03    0.23065E-06    0.10851E-09    0.76852E-13
+    3    4    0.40314E-06    0.10000E+01    0.30034E+03    0.42336E-06    0.29075E-09    0.12971E-12
+    3    4    0.40314E-06    0.10000E+01    0.24221E+03    0.74274E-06    0.67845E-09    0.21544E-12
+    3    4    0.40314E-06    0.10000E+01    0.19533E+03    0.11676E-05    0.12888E-08    0.32798E-12
+    3    4    0.40314E-06    0.10000E+01    0.15752E+03    0.11676E-05    0.12888E-08    0.32798E-12
+    3    4    0.70346E-06    0.10000E+01    0.80645E+05    0.65112E-53    0.48920E-64    0.73455E-58
+    3    4    0.70346E-06    0.10000E+01    0.65036E+05    0.55271E-52    0.77891E-63    0.62407E-57
+    3    4    0.70346E-06    0.10000E+01    0.52449E+05    0.47103E-51    0.10521E-61    0.53224E-56
+    3    4    0.70346E-06    0.10000E+01    0.42297E+05    0.35592E-50    0.14411E-60    0.40272E-55
+    3    4    0.70346E-06    0.10000E+01    0.34111E+05    0.25854E-49    0.20020E-59    0.29322E-54
+    3    4    0.70346E-06    0.10000E+01    0.27509E+05    0.18769E-48    0.27644E-58    0.21366E-53
+    3    4    0.70346E-06    0.10000E+01    0.22184E+05    0.13600E-47    0.37838E-57    0.15570E-52
+    3    4    0.70346E-06    0.10000E+01    0.17891E+05    0.97906E-47    0.51376E-56    0.11304E-51
+    3    4    0.70346E-06    0.10000E+01    0.14428E+05    0.69948E-46    0.69367E-55    0.81682E-51
+    3    4    0.70346E-06    0.10000E+01    0.11635E+05    0.49658E-45    0.93215E-54    0.58794E-50
+    3    4    0.70346E-06    0.10000E+01    0.93834E+04    0.35064E-44    0.12439E-52    0.42172E-49
+    3    4    0.70346E-06    0.10000E+01    0.75673E+04    0.24599E-43    0.16435E-51    0.30113E-48
+    3    4    0.70346E-06    0.10000E+01    0.61026E+04    0.17106E-42    0.21485E-50    0.21355E-47
+    3    4    0.70346E-06    0.10000E+01    0.49215E+04    0.11782E-41    0.27978E-49    0.14991E-46
+    3    4    0.70346E-06    0.10000E+01    0.39689E+04    0.80784E-41    0.37248E-48    0.10373E-45
+    3    4    0.70346E-06    0.10000E+01    0.32008E+04    0.17780E-38    0.17123E-45    0.22165E-43
+    3    4    0.70346E-06    0.10000E+01    0.25813E+04    0.71687E-30    0.17554E-36    0.77671E-35
+    3    4    0.70346E-06    0.10000E+01    0.20817E+04    0.10182E-13    0.11565E-19    0.82082E-19
+    3    4    0.70346E-06    0.10000E+01    0.16788E+04    0.29847E-08    0.16105E-13    0.18615E-13
+    3    4    0.70346E-06    0.10000E+01    0.13538E+04    0.50615E-08    0.60313E-13    0.22018E-13
+    3    4    0.70346E-06    0.10000E+01    0.10918E+04    0.91632E-08    0.22216E-12    0.26544E-13
+    3    4    0.70346E-06    0.10000E+01    0.88049E+03    0.17219E-07    0.80962E-12    0.33109E-13
+    3    4    0.70346E-06    0.10000E+01    0.71007E+03    0.32880E-07    0.29245E-11    0.43383E-13
+    3    4    0.70346E-06    0.10000E+01    0.57264E+03    0.63008E-07    0.10344E-10    0.60381E-13
+    3    4    0.70346E-06    0.10000E+01    0.46180E+03    0.12021E-06    0.34658E-10    0.89465E-13
+    3    4    0.70346E-06    0.10000E+01    0.37242E+03    0.22616E-06    0.10543E-09    0.13966E-12
+    3    4    0.70346E-06    0.10000E+01    0.30034E+03    0.41376E-06    0.28237E-09    0.22446E-12
+    3    4    0.70346E-06    0.10000E+01    0.24221E+03    0.72438E-06    0.65876E-09    0.36070E-12
+    3    4    0.70346E-06    0.10000E+01    0.19533E+03    0.11373E-05    0.12512E-08    0.53850E-12
+    3    4    0.70346E-06    0.10000E+01    0.15752E+03    0.11373E-05    0.12512E-08    0.53850E-12
+    3    4    0.12275E-05    0.10000E+01    0.80645E+05    0.10685E-52    0.80306E-64    0.20704E-57
+    3    4    0.12275E-05    0.10000E+01    0.65036E+05    0.90728E-52    0.12789E-62    0.17593E-56
+    3    4    0.12275E-05    0.10000E+01    0.52449E+05    0.77337E-51    0.17284E-61    0.15006E-55
+    3    4    0.12275E-05    0.10000E+01    0.42297E+05    0.58461E-50    0.23693E-60    0.11357E-54
+    3    4    0.12275E-05    0.10000E+01    0.34111E+05    0.42497E-49    0.32957E-59    0.82728E-54
+    3    4    0.12275E-05    0.10000E+01    0.27509E+05    0.30887E-48    0.45597E-58    0.60320E-53
+    3    4    0.12275E-05    0.10000E+01    0.22184E+05    0.22420E-47    0.62595E-57    0.44004E-52
+    3    4    0.12275E-05    0.10000E+01    0.17891E+05    0.16182E-46    0.85324E-56    0.31994E-51
+    3    4    0.12275E-05    0.10000E+01    0.14428E+05    0.11601E-45    0.11573E-54    0.23166E-50
+    3    4    0.12275E-05    0.10000E+01    0.11635E+05    0.82712E-45    0.15630E-53    0.16716E-49
+    3    4    0.12275E-05    0.10000E+01    0.93834E+04    0.58683E-44    0.20970E-52    0.12025E-48
+    3    4    0.12275E-05    0.10000E+01    0.75673E+04    0.41383E-43    0.27859E-51    0.86159E-48
+    3    4    0.12275E-05    0.10000E+01    0.61026E+04    0.28930E-42    0.36550E-50    0.61364E-47
+    3    4    0.12275E-05    0.10000E+01    0.49215E+04    0.20001E-41    0.47395E-49    0.43323E-46
+    3    4    0.12275E-05    0.10000E+01    0.39689E+04    0.13677E-40    0.61408E-48    0.30212E-45
+    3    4    0.12275E-05    0.10000E+01    0.32008E+04    0.29438E-38    0.26017E-45    0.65234E-43
+    3    4    0.12275E-05    0.10000E+01    0.25813E+04    0.11105E-29    0.22283E-36    0.23116E-34
+    3    4    0.12275E-05    0.10000E+01    0.20817E+04    0.14300E-13    0.11981E-19    0.24172E-18
+    3    4    0.12275E-05    0.10000E+01    0.16788E+04    0.39191E-08    0.15994E-13    0.53532E-13
+    3    4    0.12275E-05    0.10000E+01    0.13538E+04    0.60892E-08    0.59508E-13    0.62577E-13
+    3    4    0.12275E-05    0.10000E+01    0.10918E+04    0.10253E-07    0.21816E-12    0.73584E-13
+    3    4    0.12275E-05    0.10000E+01    0.88049E+03    0.18298E-07    0.79208E-12    0.87940E-13
+    3    4    0.12275E-05    0.10000E+01    0.71007E+03    0.33786E-07    0.28530E-11    0.10821E-12
+    3    4    0.12275E-05    0.10000E+01    0.57264E+03    0.63394E-07    0.10071E-10    0.13902E-12
+    3    4    0.12275E-05    0.10000E+01    0.46180E+03    0.11937E-06    0.33697E-10    0.18862E-12
+    3    4    0.12275E-05    0.10000E+01    0.37242E+03    0.22277E-06    0.10242E-09    0.27077E-12
+    3    4    0.12275E-05    0.10000E+01    0.30034E+03    0.40549E-06    0.27419E-09    0.40607E-12
+    3    4    0.12275E-05    0.10000E+01    0.24221E+03    0.70768E-06    0.63946E-09    0.62004E-12
+    3    4    0.12275E-05    0.10000E+01    0.19533E+03    0.11091E-05    0.12144E-08    0.89681E-12
+    3    4    0.12275E-05    0.10000E+01    0.15752E+03    0.11091E-05    0.12144E-08    0.89681E-12
+    3    4    0.21419E-05    0.10000E+01    0.80645E+05    0.17461E-52    0.13127E-63    0.58367E-57
+    3    4    0.21419E-05    0.10000E+01    0.65036E+05    0.14830E-51    0.20909E-62    0.49604E-56
+    3    4    0.21419E-05    0.10000E+01    0.52449E+05    0.12643E-50    0.28270E-61    0.42315E-55
+    3    4    0.21419E-05    0.10000E+01    0.42297E+05    0.95609E-50    0.38781E-60    0.32032E-54
+    3    4    0.21419E-05    0.10000E+01    0.34111E+05    0.69545E-49    0.54003E-59    0.23342E-53
+    3    4    0.21419E-05    0.10000E+01    0.27509E+05    0.50595E-48    0.74844E-58    0.17030E-52
+    3    4    0.21419E-05    0.10000E+01    0.22184E+05    0.36782E-47    0.10301E-56    0.12435E-51
+    3    4    0.21419E-05    0.10000E+01    0.17891E+05    0.26607E-46    0.14089E-55    0.90528E-51
+    3    4    0.21419E-05    0.10000E+01    0.14428E+05    0.19135E-45    0.19186E-54    0.65666E-50
+    3    4    0.21419E-05    0.10000E+01    0.11635E+05    0.13693E-44    0.26027E-53    0.47485E-49
+    3    4    0.21419E-05    0.10000E+01    0.93834E+04    0.97563E-44    0.35098E-52    0.34245E-48
+    3    4    0.21419E-05    0.10000E+01    0.75673E+04    0.69134E-43    0.46895E-51    0.24611E-47
+    3    4    0.21419E-05    0.10000E+01    0.61026E+04    0.48593E-42    0.61882E-50    0.17594E-46
+    3    4    0.21419E-05    0.10000E+01    0.49215E+04    0.33779E-41    0.80489E-49    0.12482E-45
+    3    4    0.21419E-05    0.10000E+01    0.39689E+04    0.23175E-40    0.10345E-47    0.87615E-45
+    3    4    0.21419E-05    0.10000E+01    0.32008E+04    0.49570E-38    0.42019E-45    0.19086E-42
+    3    4    0.21419E-05    0.10000E+01    0.25813E+04    0.18048E-29    0.31269E-36    0.68318E-34
+    3    4    0.21419E-05    0.10000E+01    0.20817E+04    0.21492E-13    0.12845E-19    0.71095E-18
+    3    4    0.21419E-05    0.10000E+01    0.16788E+04    0.55146E-08    0.15894E-13    0.15491E-12
+    3    4    0.21419E-05    0.10000E+01    0.13538E+04    0.78623E-08    0.58520E-13    0.18049E-12
+    3    4    0.21419E-05    0.10000E+01    0.10918E+04    0.12164E-07    0.21305E-12    0.20991E-12
+    3    4    0.21419E-05    0.10000E+01    0.88049E+03    0.20248E-07    0.76964E-12    0.24511E-12
+    3    4    0.21419E-05    0.10000E+01    0.71007E+03    0.35562E-07    0.27619E-11    0.28986E-12
+    3    4    0.21419E-05    0.10000E+01    0.57264E+03    0.64548E-07    0.97237E-11    0.35108E-12
+    3    4    0.21419E-05    0.10000E+01    0.46180E+03    0.11900E-06    0.32479E-10    0.44107E-12
+    3    4    0.21419E-05    0.10000E+01    0.37242E+03    0.21918E-06    0.98615E-10    0.58045E-12
+    3    4    0.21419E-05    0.10000E+01    0.30034E+03    0.39574E-06    0.26383E-09    0.79989E-12
+    3    4    0.21419E-05    0.10000E+01    0.24221E+03    0.68727E-06    0.61508E-09    0.11374E-11
+    3    4    0.21419E-05    0.10000E+01    0.19533E+03    0.10742E-05    0.11678E-08    0.15668E-11
+    3    4    0.21419E-05    0.10000E+01    0.15752E+03    0.10742E-05    0.11678E-08    0.15668E-11
+    3    4    0.37375E-05    0.10000E+01    0.80645E+05    0.28434E-52    0.21381E-63    0.16335E-56
+    3    4    0.37375E-05    0.10000E+01    0.65036E+05    0.24154E-51    0.34062E-62    0.13884E-55
+    3    4    0.37375E-05    0.10000E+01    0.52449E+05    0.20596E-50    0.46072E-61    0.11845E-54
+    3    4    0.37375E-05    0.10000E+01    0.42297E+05    0.15580E-49    0.63242E-60    0.89685E-54
+    3    4    0.37375E-05    0.10000E+01    0.34111E+05    0.11339E-48    0.88150E-59    0.65376E-53
+    3    4    0.37375E-05    0.10000E+01    0.27509E+05    0.82563E-48    0.12235E-57    0.47721E-52
+    3    4    0.37375E-05    0.10000E+01    0.22184E+05    0.60102E-47    0.16876E-56    0.34871E-51
+    3    4    0.37375E-05    0.10000E+01    0.17891E+05    0.43562E-46    0.23151E-55    0.25417E-50
+    3    4    0.37375E-05    0.10000E+01    0.14428E+05    0.31411E-45    0.31635E-54    0.18465E-49
+    3    4    0.37375E-05    0.10000E+01    0.11635E+05    0.22550E-44    0.43082E-53    0.13377E-48
+    3    4    0.37375E-05    0.10000E+01    0.93834E+04    0.16127E-43    0.58361E-52    0.96683E-48
+    3    4    0.37375E-05    0.10000E+01    0.75673E+04    0.11477E-42    0.78401E-51    0.69661E-47
+    3    4    0.37375E-05    0.10000E+01    0.61026E+04    0.81081E-42    0.10411E-49    0.49958E-46
+    3    4    0.37375E-05    0.10000E+01    0.49215E+04    0.56693E-41    0.13624E-48    0.35588E-45
+    3    4    0.37375E-05    0.10000E+01    0.39689E+04    0.39120E-40    0.17543E-47    0.25117E-44
+    3    4    0.37375E-05    0.10000E+01    0.32008E+04    0.83837E-38    0.70146E-45    0.55116E-42
+    3    4    0.37375E-05    0.10000E+01    0.25813E+04    0.30075E-29    0.47843E-36    0.19898E-33
+    3    4    0.37375E-05    0.10000E+01    0.20817E+04    0.33915E-13    0.14665E-19    0.20670E-17
+    3    4    0.37375E-05    0.10000E+01    0.16788E+04    0.82294E-08    0.15970E-13    0.44551E-12
+    3    4    0.37375E-05    0.10000E+01    0.13538E+04    0.10921E-07    0.57752E-13    0.51995E-12
+    3    4    0.37375E-05    0.10000E+01    0.10918E+04    0.15528E-07    0.20798E-12    0.60335E-12
+    3    4    0.37375E-05    0.10000E+01    0.88049E+03    0.23815E-07    0.74594E-12    0.69834E-12
+    3    4    0.37375E-05    0.10000E+01    0.71007E+03    0.39096E-07    0.26634E-11    0.81030E-12
+    3    4    0.37375E-05    0.10000E+01    0.57264E+03    0.67556E-07    0.93449E-11    0.94941E-12
+    3    4    0.37375E-05    0.10000E+01    0.46180E+03    0.12049E-06    0.31145E-10    0.11341E-11
+    3    4    0.37375E-05    0.10000E+01    0.37242E+03    0.21727E-06    0.94438E-10    0.13951E-11
+    3    4    0.37375E-05    0.10000E+01    0.30034E+03    0.38721E-06    0.25245E-09    0.17783E-11
+    3    4    0.37375E-05    0.10000E+01    0.24221E+03    0.66714E-06    0.58827E-09    0.23400E-11
+    3    4    0.37375E-05    0.10000E+01    0.19533E+03    0.10381E-05    0.11166E-08    0.30340E-11
+    3    4    0.37375E-05    0.10000E+01    0.15752E+03    0.10381E-05    0.11166E-08    0.30340E-11
+    3    4    0.65217E-05    0.10000E+01    0.80645E+05    0.46123E-52    0.34690E-63    0.44753E-56
+    3    4    0.65217E-05    0.10000E+01    0.65036E+05    0.39186E-51    0.55272E-62    0.38042E-55
+    3    4    0.65217E-05    0.10000E+01    0.52449E+05    0.33420E-50    0.74784E-61    0.32459E-54
+    3    4    0.65217E-05    0.10000E+01    0.42297E+05    0.25288E-49    0.10271E-59    0.24580E-53
+    3    4    0.65217E-05    0.10000E+01    0.34111E+05    0.18413E-48    0.14329E-58    0.17922E-52
+    3    4    0.65217E-05    0.10000E+01    0.27509E+05    0.13417E-47    0.19914E-57    0.13088E-51
+    3    4    0.65217E-05    0.10000E+01    0.22184E+05    0.97783E-47    0.27520E-56    0.95699E-51
+    3    4    0.65217E-05    0.10000E+01    0.17891E+05    0.70995E-46    0.37848E-55    0.69819E-50
+    3    4    0.65217E-05    0.10000E+01    0.14428E+05    0.51308E-45    0.51873E-54    0.50786E-49
+    3    4    0.65217E-05    0.10000E+01    0.11635E+05    0.36937E-44    0.70882E-53    0.36851E-48
+    3    4    0.65217E-05    0.10000E+01    0.93834E+04    0.26502E-43    0.96403E-52    0.26681E-47
+    3    4    0.65217E-05    0.10000E+01    0.75673E+04    0.18932E-42    0.13014E-50    0.19265E-46
+    3    4    0.65217E-05    0.10000E+01    0.61026E+04    0.13436E-41    0.17385E-49    0.13852E-45
+    3    4    0.65217E-05    0.10000E+01    0.49215E+04    0.94467E-41    0.22907E-48    0.99002E-45
+    3    4    0.65217E-05    0.10000E+01    0.39689E+04    0.65600E-40    0.29679E-47    0.70182E-44
+    3    4    0.65217E-05    0.10000E+01    0.32008E+04    0.14136E-37    0.11852E-44    0.15491E-41
+    3    4    0.65217E-05    0.10000E+01    0.25813E+04    0.50545E-29    0.77442E-36    0.56309E-33
+    3    4    0.65217E-05    0.10000E+01    0.20817E+04    0.55053E-13    0.18272E-19    0.58473E-17
+    3    4    0.65217E-05    0.10000E+01    0.16788E+04    0.12798E-07    0.16426E-13    0.12513E-11
+    3    4    0.65217E-05    0.10000E+01    0.13538E+04    0.16129E-07    0.57584E-13    0.14658E-11
+    3    4    0.65217E-05    0.10000E+01    0.10918E+04    0.21352E-07    0.20366E-12    0.17048E-11
+    3    4    0.65217E-05    0.10000E+01    0.88049E+03    0.30153E-07    0.72227E-12    0.19720E-11
+    3    4    0.65217E-05    0.10000E+01    0.71007E+03    0.45701E-07    0.25603E-11    0.22754E-11
+    3    4    0.65217E-05    0.10000E+01    0.57264E+03    0.73893E-07    0.89405E-11    0.26309E-11
+    3    4    0.65217E-05    0.10000E+01    0.46180E+03    0.12548E-06    0.29709E-10    0.30676E-11
+    3    4    0.65217E-05    0.10000E+01    0.37242E+03    0.21888E-06    0.89923E-10    0.36340E-11
+    3    4    0.65217E-05    0.10000E+01    0.30034E+03    0.38191E-06    0.24013E-09    0.44021E-11
+    3    4    0.65217E-05    0.10000E+01    0.24221E+03    0.64953E-06    0.55921E-09    0.54590E-11
+    3    4    0.65217E-05    0.10000E+01    0.19533E+03    0.10035E-05    0.10611E-08    0.67098E-11
+    3    4    0.65217E-05    0.10000E+01    0.15752E+03    0.10035E-05    0.10611E-08    0.67098E-11
+    3    4    0.11380E-04    0.10000E+01    0.80645E+05    0.74413E-52    0.55979E-63    0.11632E-55
+    3    4    0.11380E-04    0.10000E+01    0.65036E+05    0.63232E-51    0.89201E-62    0.98885E-55
+    3    4    0.11380E-04    0.10000E+01    0.52449E+05    0.53935E-50    0.12073E-60    0.84379E-54
+    3    4    0.11380E-04    0.10000E+01    0.42297E+05    0.40820E-49    0.16589E-59    0.63904E-53
+    3    4    0.11380E-04    0.10000E+01    0.34111E+05    0.29735E-48    0.23159E-58    0.46605E-52
+    3    4    0.11380E-04    0.10000E+01    0.27509E+05    0.21681E-47    0.32221E-57    0.34045E-51
+    3    4    0.11380E-04    0.10000E+01    0.22184E+05    0.15817E-46    0.44602E-56    0.24907E-50
+    3    4    0.11380E-04    0.10000E+01    0.17891E+05    0.11500E-45    0.61471E-55    0.18184E-49
+    3    4    0.11380E-04    0.10000E+01    0.14428E+05    0.83273E-45    0.84464E-54    0.13240E-48
+    3    4    0.11380E-04    0.10000E+01    0.11635E+05    0.60091E-44    0.11575E-52    0.96185E-48
+    3    4    0.11380E-04    0.10000E+01    0.93834E+04    0.43233E-43    0.15796E-51    0.69737E-47
+    3    4    0.11380E-04    0.10000E+01    0.75673E+04    0.30983E-42    0.21413E-50    0.50433E-46
+    3    4    0.11380E-04    0.10000E+01    0.61026E+04    0.22075E-41    0.28757E-49    0.36334E-45
+    3    4    0.11380E-04    0.10000E+01    0.49215E+04    0.15597E-40    0.38139E-48    0.26035E-44
+    3    4    0.11380E-04    0.10000E+01    0.39689E+04    0.10896E-39    0.49776E-47    0.18517E-43
+    3    4    0.11380E-04    0.10000E+01    0.32008E+04    0.23631E-37    0.19983E-44    0.41049E-41
+    3    4    0.11380E-04    0.10000E+01    0.25813E+04    0.84693E-29    0.12865E-35    0.14998E-32
+    3    4    0.11380E-04    0.10000E+01    0.20817E+04    0.90365E-13    0.25108E-19    0.15576E-16
+    3    4    0.11380E-04    0.10000E+01    0.16788E+04    0.20379E-07    0.17753E-13    0.33181E-11
+    3    4    0.11380E-04    0.10000E+01    0.13538E+04    0.24868E-07    0.59174E-13    0.39020E-11
+    3    4    0.11380E-04    0.10000E+01    0.10918E+04    0.31276E-07    0.20305E-12    0.45548E-11
+    3    4    0.11380E-04    0.10000E+01    0.88049E+03    0.41216E-07    0.70716E-12    0.52829E-11
+    3    4    0.11380E-04    0.10000E+01    0.71007E+03    0.57716E-07    0.24786E-11    0.61007E-11
+    3    4    0.11380E-04    0.10000E+01    0.57264E+03    0.86406E-07    0.85950E-11    0.70364E-11
+    3    4    0.11380E-04    0.10000E+01    0.46180E+03    0.13754E-06    0.28440E-10    0.81416E-11
+    3    4    0.11380E-04    0.10000E+01    0.37242E+03    0.22864E-06    0.85866E-10    0.95021E-11
+    3    4    0.11380E-04    0.10000E+01    0.30034E+03    0.38618E-06    0.22896E-09    0.11242E-10
+    3    4    0.11380E-04    0.10000E+01    0.24221E+03    0.64335E-06    0.53272E-09    0.13510E-10
+    3    4    0.11380E-04    0.10000E+01    0.19533E+03    0.98245E-06    0.10103E-08    0.16084E-10
+    3    4    0.11380E-04    0.10000E+01    0.15752E+03    0.98245E-06    0.10103E-08    0.16084E-10
+    3    4    0.19857E-04    0.10000E+01    0.80645E+05    0.12985E-51    0.97680E-63    0.20297E-55
+    3    4    0.19857E-04    0.10000E+01    0.65036E+05    0.11034E-50    0.15565E-61    0.17255E-54
+    3    4    0.19857E-04    0.10000E+01    0.52449E+05    0.94113E-50    0.21066E-60    0.14724E-53
+    3    4    0.19857E-04    0.10000E+01    0.42297E+05    0.71228E-49    0.28947E-59    0.11151E-52
+    3    4    0.19857E-04    0.10000E+01    0.34111E+05    0.51885E-48    0.40410E-58    0.81323E-52
+    3    4    0.19857E-04    0.10000E+01    0.27509E+05    0.37832E-47    0.56224E-57    0.59407E-51
+    3    4    0.19857E-04    0.10000E+01    0.22184E+05    0.27599E-46    0.77827E-56    0.43461E-50
+    3    4    0.19857E-04    0.10000E+01    0.17891E+05    0.20067E-45    0.10726E-54    0.31731E-49
+    3    4    0.19857E-04    0.10000E+01    0.14428E+05    0.14531E-44    0.14738E-53    0.23103E-48
+    3    4    0.19857E-04    0.10000E+01    0.11635E+05    0.10486E-43    0.20197E-52    0.16784E-47
+    3    4    0.19857E-04    0.10000E+01    0.93834E+04    0.75438E-43    0.27562E-51    0.12169E-46
+    3    4    0.19857E-04    0.10000E+01    0.75673E+04    0.54064E-42    0.37364E-50    0.88002E-46
+    3    4    0.19857E-04    0.10000E+01    0.61026E+04    0.38520E-41    0.50179E-49    0.63401E-45
+    3    4    0.19857E-04    0.10000E+01    0.49215E+04    0.27216E-40    0.66551E-48    0.45429E-44
+    3    4    0.19857E-04    0.10000E+01    0.39689E+04    0.19013E-39    0.86856E-47    0.32311E-43
+    3    4    0.19857E-04    0.10000E+01    0.32008E+04    0.41235E-37    0.34869E-44    0.71629E-41
+    3    4    0.19857E-04    0.10000E+01    0.25813E+04    0.14778E-28    0.22449E-35    0.26171E-32
+    3    4    0.19857E-04    0.10000E+01    0.20817E+04    0.15768E-12    0.43812E-19    0.27180E-16
+    3    4    0.19857E-04    0.10000E+01    0.16788E+04    0.35560E-07    0.30977E-13    0.57899E-11
+    3    4    0.19857E-04    0.10000E+01    0.13538E+04    0.43393E-07    0.10326E-12    0.68088E-11
+    3    4    0.19857E-04    0.10000E+01    0.10918E+04    0.54575E-07    0.35431E-12    0.79478E-11
+    3    4    0.19857E-04    0.10000E+01    0.88049E+03    0.71920E-07    0.12339E-11    0.92184E-11
+    3    4    0.19857E-04    0.10000E+01    0.71007E+03    0.10071E-06    0.43251E-11    0.10645E-10
+    3    4    0.19857E-04    0.10000E+01    0.57264E+03    0.15077E-06    0.14998E-10    0.12278E-10
+    3    4    0.19857E-04    0.10000E+01    0.46180E+03    0.24000E-06    0.49625E-10    0.14207E-10
+    3    4    0.19857E-04    0.10000E+01    0.37242E+03    0.39897E-06    0.14983E-09    0.16581E-10
+    3    4    0.19857E-04    0.10000E+01    0.30034E+03    0.67386E-06    0.39952E-09    0.19617E-10
+    3    4    0.19857E-04    0.10000E+01    0.24221E+03    0.11226E-05    0.92957E-09    0.23574E-10
+    3    4    0.19857E-04    0.10000E+01    0.19533E+03    0.17143E-05    0.17630E-08    0.28065E-10
+    3    4    0.19857E-04    0.10000E+01    0.15752E+03    0.17143E-05    0.17630E-08    0.28065E-10
+    3    4    0.34650E-04    0.10000E+01    0.80645E+05    0.22657E-51    0.17045E-62    0.35417E-55
+    3    4    0.34650E-04    0.10000E+01    0.65036E+05    0.19253E-50    0.27160E-61    0.30109E-54
+    3    4    0.34650E-04    0.10000E+01    0.52449E+05    0.16422E-49    0.36759E-60    0.25692E-53
+    3    4    0.34650E-04    0.10000E+01    0.42297E+05    0.12429E-48    0.50511E-59    0.19458E-52
+    3    4    0.34650E-04    0.10000E+01    0.34111E+05    0.90536E-48    0.70514E-58    0.14190E-51
+    3    4    0.34650E-04    0.10000E+01    0.27509E+05    0.66015E-47    0.98107E-57    0.10366E-50
+    3    4    0.34650E-04    0.10000E+01    0.22184E+05    0.48159E-46    0.13580E-55    0.75836E-50
+    3    4    0.34650E-04    0.10000E+01    0.17891E+05    0.35016E-45    0.18717E-54    0.55368E-49
+    3    4    0.34650E-04    0.10000E+01    0.14428E+05    0.25355E-44    0.25718E-53    0.40314E-48
+    3    4    0.34650E-04    0.10000E+01    0.11635E+05    0.18297E-43    0.35243E-52    0.29287E-47
+    3    4    0.34650E-04    0.10000E+01    0.93834E+04    0.13164E-42    0.48095E-51    0.21234E-46
+    3    4    0.34650E-04    0.10000E+01    0.75673E+04    0.94338E-42    0.65199E-50    0.15356E-45
+    3    4    0.34650E-04    0.10000E+01    0.61026E+04    0.67214E-41    0.87560E-49    0.11063E-44
+    3    4    0.34650E-04    0.10000E+01    0.49215E+04    0.47490E-40    0.11613E-47    0.79271E-44
+    3    4    0.34650E-04    0.10000E+01    0.39689E+04    0.33177E-39    0.15156E-46    0.56382E-43
+    3    4    0.34650E-04    0.10000E+01    0.32008E+04    0.71953E-37    0.60845E-44    0.12499E-40
+    3    4    0.34650E-04    0.10000E+01    0.25813E+04    0.25788E-28    0.39172E-35    0.45667E-32
+    3    4    0.34650E-04    0.10000E+01    0.20817E+04    0.27514E-12    0.76449E-19    0.47427E-16
+    3    4    0.34650E-04    0.10000E+01    0.16788E+04    0.62051E-07    0.54054E-13    0.10103E-10
+    3    4    0.34650E-04    0.10000E+01    0.13538E+04    0.75718E-07    0.18017E-12    0.11881E-10
+    3    4    0.34650E-04    0.10000E+01    0.10918E+04    0.95230E-07    0.61826E-12    0.13868E-10
+    3    4    0.34650E-04    0.10000E+01    0.88049E+03    0.12550E-06    0.21532E-11    0.16086E-10
+    3    4    0.34650E-04    0.10000E+01    0.71007E+03    0.17573E-06    0.75470E-11    0.18576E-10
+    3    4    0.34650E-04    0.10000E+01    0.57264E+03    0.26309E-06    0.26170E-10    0.21425E-10
+    3    4    0.34650E-04    0.10000E+01    0.46180E+03    0.41879E-06    0.86593E-10    0.24790E-10
+    3    4    0.34650E-04    0.10000E+01    0.37242E+03    0.69617E-06    0.26144E-09    0.28932E-10
+    3    4    0.34650E-04    0.10000E+01    0.30034E+03    0.11758E-05    0.69714E-09    0.34230E-10
+    3    4    0.34650E-04    0.10000E+01    0.24221E+03    0.19589E-05    0.16220E-08    0.41135E-10
+    3    4    0.34650E-04    0.10000E+01    0.19533E+03    0.29914E-05    0.30763E-08    0.48972E-10
+    3    4    0.34650E-04    0.10000E+01    0.15752E+03    0.29914E-05    0.30763E-08    0.48972E-10
+    3    4    0.60462E-04    0.10000E+01    0.80645E+05    0.39536E-51    0.29742E-62    0.61801E-55
+    3    4    0.60462E-04    0.10000E+01    0.65036E+05    0.33595E-50    0.47393E-61    0.52538E-54
+    3    4    0.60462E-04    0.10000E+01    0.52449E+05    0.28656E-49    0.64142E-60    0.44830E-53
+    3    4    0.60462E-04    0.10000E+01    0.42297E+05    0.21688E-48    0.88138E-59    0.33952E-52
+    3    4    0.60462E-04    0.10000E+01    0.34111E+05    0.15798E-47    0.12304E-57    0.24761E-51
+    3    4    0.60462E-04    0.10000E+01    0.27509E+05    0.11519E-46    0.17119E-56    0.18088E-50
+    3    4    0.60462E-04    0.10000E+01    0.22184E+05    0.84034E-46    0.23697E-55    0.13233E-49
+    3    4    0.60462E-04    0.10000E+01    0.17891E+05    0.61100E-45    0.32659E-54    0.96614E-49
+    3    4    0.60462E-04    0.10000E+01    0.14428E+05    0.44243E-44    0.44876E-53    0.70346E-48
+    3    4    0.60462E-04    0.10000E+01    0.11635E+05    0.31927E-43    0.61497E-52    0.51103E-47
+    3    4    0.60462E-04    0.10000E+01    0.93834E+04    0.22970E-42    0.83922E-51    0.37051E-46
+    3    4    0.60462E-04    0.10000E+01    0.75673E+04    0.16461E-41    0.11377E-49    0.26795E-45
+    3    4    0.60462E-04    0.10000E+01    0.61026E+04    0.11728E-40    0.15279E-48    0.19304E-44
+    3    4    0.60462E-04    0.10000E+01    0.49215E+04    0.82867E-40    0.20264E-47    0.13832E-43
+    3    4    0.60462E-04    0.10000E+01    0.39689E+04    0.57891E-39    0.26446E-46    0.98382E-43
+    3    4    0.60462E-04    0.10000E+01    0.32008E+04    0.12555E-36    0.10617E-43    0.21810E-40
+    3    4    0.60462E-04    0.10000E+01    0.25813E+04    0.44998E-28    0.68352E-35    0.79685E-32
+    3    4    0.60462E-04    0.10000E+01    0.20817E+04    0.48011E-12    0.13340E-18    0.82758E-16
+    3    4    0.60462E-04    0.10000E+01    0.16788E+04    0.10827E-06    0.94321E-13    0.17629E-10
+    3    4    0.60462E-04    0.10000E+01    0.13538E+04    0.13212E-06    0.31439E-12    0.20732E-10
+    3    4    0.60462E-04    0.10000E+01    0.10918E+04    0.16617E-06    0.10788E-11    0.24200E-10
+    3    4    0.60462E-04    0.10000E+01    0.88049E+03    0.21898E-06    0.37571E-11    0.28068E-10
+    3    4    0.60462E-04    0.10000E+01    0.71007E+03    0.30664E-06    0.13169E-10    0.32413E-10
+    3    4    0.60462E-04    0.10000E+01    0.57264E+03    0.45908E-06    0.45665E-10    0.37384E-10
+    3    4    0.60462E-04    0.10000E+01    0.46180E+03    0.73076E-06    0.15110E-09    0.43257E-10
+    3    4    0.60462E-04    0.10000E+01    0.37242E+03    0.12148E-05    0.45620E-09    0.50485E-10
+    3    4    0.60462E-04    0.10000E+01    0.30034E+03    0.20518E-05    0.12165E-08    0.59729E-10
+    3    4    0.60462E-04    0.10000E+01    0.24221E+03    0.34181E-05    0.28304E-08    0.71778E-10
+    3    4    0.60462E-04    0.10000E+01    0.19533E+03    0.52198E-05    0.53679E-08    0.85453E-10
+    3    4    0.60462E-04    0.10000E+01    0.15752E+03    0.52198E-05    0.53679E-08    0.85453E-10
+    3    4    0.10550E-03    0.10000E+01    0.80645E+05    0.68988E-51    0.51897E-62    0.10784E-54
+    3    4    0.10550E-03    0.10000E+01    0.65036E+05    0.58622E-50    0.82698E-61    0.91675E-54
+    3    4    0.10550E-03    0.10000E+01    0.52449E+05    0.50003E-49    0.11192E-59    0.78226E-53
+    3    4    0.10550E-03    0.10000E+01    0.42297E+05    0.37843E-48    0.15380E-58    0.59245E-52
+    3    4    0.10550E-03    0.10000E+01    0.34111E+05    0.27567E-47    0.21470E-57    0.43207E-51
+    3    4    0.10550E-03    0.10000E+01    0.27509E+05    0.20100E-46    0.29872E-56    0.31563E-50
+    3    4    0.10550E-03    0.10000E+01    0.22184E+05    0.14663E-45    0.41350E-55    0.23091E-49
+    3    4    0.10550E-03    0.10000E+01    0.17891E+05    0.10662E-44    0.56989E-54    0.16859E-48
+    3    4    0.10550E-03    0.10000E+01    0.14428E+05    0.77201E-44    0.78305E-53    0.12275E-47
+    3    4    0.10550E-03    0.10000E+01    0.11635E+05    0.55710E-43    0.10731E-51    0.89172E-47
+    3    4    0.10550E-03    0.10000E+01    0.93834E+04    0.40081E-42    0.14644E-50    0.64652E-46
+    3    4    0.10550E-03    0.10000E+01    0.75673E+04    0.28724E-41    0.19852E-49    0.46756E-45
+    3    4    0.10550E-03    0.10000E+01    0.61026E+04    0.20466E-40    0.26660E-48    0.33685E-44
+    3    4    0.10550E-03    0.10000E+01    0.49215E+04    0.14460E-39    0.35359E-47    0.24137E-43
+    3    4    0.10550E-03    0.10000E+01    0.39689E+04    0.10102E-38    0.46147E-46    0.17167E-42
+    3    4    0.10550E-03    0.10000E+01    0.32008E+04    0.21908E-36    0.18526E-43    0.38056E-40
+    3    4    0.10550E-03    0.10000E+01    0.25813E+04    0.78518E-28    0.11927E-34    0.13905E-31
+    3    4    0.10550E-03    0.10000E+01    0.20817E+04    0.83776E-12    0.23277E-18    0.14441E-15
+    3    4    0.10550E-03    0.10000E+01    0.16788E+04    0.18893E-06    0.16458E-12    0.30762E-10
+    3    4    0.10550E-03    0.10000E+01    0.13538E+04    0.23055E-06    0.54860E-12    0.36175E-10
+    3    4    0.10550E-03    0.10000E+01    0.10918E+04    0.28996E-06    0.18825E-11    0.42227E-10
+    3    4    0.10550E-03    0.10000E+01    0.88049E+03    0.38211E-06    0.65560E-11    0.48977E-10
+    3    4    0.10550E-03    0.10000E+01    0.71007E+03    0.53508E-06    0.22979E-10    0.56559E-10
+    3    4    0.10550E-03    0.10000E+01    0.57264E+03    0.80106E-06    0.79683E-10    0.65234E-10
+    3    4    0.10550E-03    0.10000E+01    0.46180E+03    0.12751E-05    0.26366E-09    0.75480E-10
+    3    4    0.10550E-03    0.10000E+01    0.37242E+03    0.21197E-05    0.79605E-09    0.88093E-10
+    3    4    0.10550E-03    0.10000E+01    0.30034E+03    0.35802E-05    0.21227E-08    0.10422E-09
+    3    4    0.10550E-03    0.10000E+01    0.24221E+03    0.59644E-05    0.49388E-08    0.12525E-09
+    3    4    0.10550E-03    0.10000E+01    0.19533E+03    0.91082E-05    0.93667E-08    0.14911E-09
+    3    4    0.10550E-03    0.10000E+01    0.15752E+03    0.91082E-05    0.93667E-08    0.14911E-09
+    3    4    0.18409E-03    0.10000E+01    0.80645E+05    0.12038E-50    0.90558E-62    0.18817E-54
+    3    4    0.18409E-03    0.10000E+01    0.65036E+05    0.10229E-49    0.14430E-60    0.15997E-53
+    3    4    0.18409E-03    0.10000E+01    0.52449E+05    0.87251E-49    0.19530E-59    0.13650E-52
+    3    4    0.18409E-03    0.10000E+01    0.42297E+05    0.66034E-48    0.26836E-58    0.10338E-51
+    3    4    0.18409E-03    0.10000E+01    0.34111E+05    0.48102E-47    0.37464E-57    0.75394E-51
+    3    4    0.18409E-03    0.10000E+01    0.27509E+05    0.35074E-46    0.52124E-56    0.55075E-50
+    3    4    0.18409E-03    0.10000E+01    0.22184E+05    0.25587E-45    0.72153E-55    0.40292E-49
+    3    4    0.18409E-03    0.10000E+01    0.17891E+05    0.18604E-44    0.99442E-54    0.29417E-48
+    3    4    0.18409E-03    0.10000E+01    0.14428E+05    0.13471E-43    0.13664E-52    0.21419E-47
+    3    4    0.18409E-03    0.10000E+01    0.11635E+05    0.97211E-43    0.18725E-51    0.15560E-46
+    3    4    0.18409E-03    0.10000E+01    0.93834E+04    0.69938E-42    0.25553E-50    0.11281E-45
+    3    4    0.18409E-03    0.10000E+01    0.75673E+04    0.50122E-41    0.34640E-49    0.81586E-45
+    3    4    0.18409E-03    0.10000E+01    0.61026E+04    0.35711E-40    0.46521E-48    0.58778E-44
+    3    4    0.18409E-03    0.10000E+01    0.49215E+04    0.25231E-39    0.61699E-47    0.42117E-43
+    3    4    0.18409E-03    0.10000E+01    0.39689E+04    0.17627E-38    0.80523E-46    0.29956E-42
+    3    4    0.18409E-03    0.10000E+01    0.32008E+04    0.38229E-36    0.32327E-43    0.66406E-40
+    3    4    0.18409E-03    0.10000E+01    0.25813E+04    0.13701E-27    0.20812E-34    0.24263E-31
+    3    4    0.18409E-03    0.10000E+01    0.20817E+04    0.14618E-11    0.40617E-18    0.25198E-15
+    3    4    0.18409E-03    0.10000E+01    0.16788E+04    0.32968E-06    0.28719E-12    0.53677E-10
+    3    4    0.18409E-03    0.10000E+01    0.13538E+04    0.40229E-06    0.95727E-12    0.63124E-10
+    3    4    0.18409E-03    0.10000E+01    0.10918E+04    0.50596E-06    0.32848E-11    0.73683E-10
+    3    4    0.18409E-03    0.10000E+01    0.88049E+03    0.66676E-06    0.11440E-10    0.85463E-10
+    3    4    0.18409E-03    0.10000E+01    0.71007E+03    0.93368E-06    0.40097E-10    0.98692E-10
+    3    4    0.18409E-03    0.10000E+01    0.57264E+03    0.13978E-05    0.13904E-09    0.11383E-09
+    3    4    0.18409E-03    0.10000E+01    0.46180E+03    0.22250E-05    0.46007E-09    0.13171E-09
+    3    4    0.18409E-03    0.10000E+01    0.37242E+03    0.36988E-05    0.13891E-08    0.15372E-09
+    3    4    0.18409E-03    0.10000E+01    0.30034E+03    0.62473E-05    0.37039E-08    0.18186E-09
+    3    4    0.18409E-03    0.10000E+01    0.24221E+03    0.10408E-04    0.86180E-08    0.21855E-09
+    3    4    0.18409E-03    0.10000E+01    0.19533E+03    0.15893E-04    0.16344E-07    0.26019E-09
+    3    4    0.18409E-03    0.10000E+01    0.15752E+03    0.15893E-04    0.16344E-07    0.26019E-09
+    3    4    0.32123E-03    0.10000E+01    0.80645E+05    0.21005E-50    0.15802E-61    0.32835E-54
+    3    4    0.32123E-03    0.10000E+01    0.65036E+05    0.17849E-49    0.25180E-60    0.27913E-53
+    3    4    0.32123E-03    0.10000E+01    0.52449E+05    0.15225E-48    0.34079E-59    0.23818E-52
+    3    4    0.32123E-03    0.10000E+01    0.42297E+05    0.11523E-47    0.46828E-58    0.18039E-51
+    3    4    0.32123E-03    0.10000E+01    0.34111E+05    0.83935E-47    0.65372E-57    0.13156E-50
+    3    4    0.32123E-03    0.10000E+01    0.27509E+05    0.61201E-46    0.90954E-56    0.96103E-50
+    3    4    0.32123E-03    0.10000E+01    0.22184E+05    0.44647E-45    0.12590E-54    0.70307E-49
+    3    4    0.32123E-03    0.10000E+01    0.17891E+05    0.32463E-44    0.17352E-53    0.51331E-48
+    3    4    0.32123E-03    0.10000E+01    0.14428E+05    0.23506E-43    0.23843E-52    0.37375E-47
+    3    4    0.32123E-03    0.10000E+01    0.11635E+05    0.16963E-42    0.32673E-51    0.27151E-46
+    3    4    0.32123E-03    0.10000E+01    0.93834E+04    0.12204E-41    0.44588E-50    0.19685E-45
+    3    4    0.32123E-03    0.10000E+01    0.75673E+04    0.87460E-41    0.60445E-49    0.14236E-44
+    3    4    0.32123E-03    0.10000E+01    0.61026E+04    0.62314E-40    0.81176E-48    0.10256E-43
+    3    4    0.32123E-03    0.10000E+01    0.49215E+04    0.44027E-39    0.10766E-46    0.73492E-43
+    3    4    0.32123E-03    0.10000E+01    0.39689E+04    0.30758E-38    0.14051E-45    0.52271E-42
+    3    4    0.32123E-03    0.10000E+01    0.32008E+04    0.66707E-36    0.56409E-43    0.11587E-39
+    3    4    0.32123E-03    0.10000E+01    0.25813E+04    0.23907E-27    0.36316E-34    0.42337E-31
+    3    4    0.32123E-03    0.10000E+01    0.20817E+04    0.25508E-11    0.70875E-18    0.43969E-15
+    3    4    0.32123E-03    0.10000E+01    0.16788E+04    0.57526E-06    0.50113E-12    0.93664E-10
+    3    4    0.32123E-03    0.10000E+01    0.13538E+04    0.70198E-06    0.16704E-11    0.11015E-09
+    3    4    0.32123E-03    0.10000E+01    0.10918E+04    0.88287E-06    0.57318E-11    0.12857E-09
+    3    4    0.32123E-03    0.10000E+01    0.88049E+03    0.11635E-05    0.19962E-10    0.14913E-09
+    3    4    0.32123E-03    0.10000E+01    0.71007E+03    0.16292E-05    0.69968E-10    0.17221E-09
+    3    4    0.32123E-03    0.10000E+01    0.57264E+03    0.24391E-05    0.24262E-09    0.19862E-09
+    3    4    0.32123E-03    0.10000E+01    0.46180E+03    0.38825E-05    0.80280E-09    0.22982E-09
+    3    4    0.32123E-03    0.10000E+01    0.37242E+03    0.64542E-05    0.24238E-08    0.26823E-09
+    3    4    0.32123E-03    0.10000E+01    0.30034E+03    0.10901E-04    0.64631E-08    0.31734E-09
+    3    4    0.32123E-03    0.10000E+01    0.24221E+03    0.18161E-04    0.15038E-07    0.38136E-09
+    3    4    0.32123E-03    0.10000E+01    0.19533E+03    0.27733E-04    0.28520E-07    0.45401E-09
+    3    4    0.32123E-03    0.10000E+01    0.15752E+03    0.27733E-04    0.28520E-07    0.45401E-09
+    4    1    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.45191E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    1    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.78855E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    1    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.13760E-07    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    1    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.24010E-07    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    4    1    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.41896E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    4    1    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.73106E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    4    1    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.12757E-06    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    4    1    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.22259E-06    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    4    1    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.38841E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    4    1    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.67776E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    4    1    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.11826E-05    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    4    1    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.20636E-05    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    4    1    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.36009E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    4    1    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.62834E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    4    1    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.10964E-04    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    4    1    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.19132E-04    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    4    1    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.33384E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    4    1    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.58253E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    4    1    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.10165E-03    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    4    1    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.17737E-03    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    4    1    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53957E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.30950E-03    0.19496E+06    0.99447E-26    0.48760E-10    0.50499E-04    0.88379E+03
+    4    1    0.54572E-10    0.10000E+01    0.74090E-01    0.13935E+00    0.11222E-09    0.65380E-11    0.40383E-04    0.29228E-04    0.98516E+04    0.54006E-03    0.15940E+06    0.27009E-25    0.58026E-09    0.60483E-04    0.85041E+03
+    4    1    0.95225E-10    0.10000E+01    0.11736E+00    0.19749E+00    0.21140E-09    0.50996E-10    0.44004E-04    0.38038E-04    0.17190E+05    0.94236E-03    0.12765E+06    0.72480E-25    0.43989E-08    0.73406E-04    0.78192E+03
+    4    1    0.16616E-09    0.10000E+01    0.18179E+00    0.26431E+00    0.32753E-09    0.26583E-09    0.44528E-04    0.48903E-04    0.29996E+05    0.16444E-02    0.99467E+05    0.19955E-24    0.21856E-07    0.91697E-04    0.67141E+03
+    4    1    0.28994E-09    0.10000E+01    0.25961E+00    0.33496E+00    0.47703E-09    0.94192E-09    0.43515E-04    0.57767E-04    0.52341E+05    0.28693E-02    0.75619E+05    0.57623E-24    0.71447E-07    0.11865E-03    0.53386E+03
+    4    1    0.50593E-09    0.10000E+01    0.33900E+00    0.40891E+00    0.78184E-09    0.24625E-08    0.45608E-04    0.61912E-04    0.91333E+05    0.50068E-02    0.56747E+05    0.17224E-23    0.16529E-06    0.15713E-03    0.40140E+03
+    4    1    0.88282E-09    0.10000E+01    0.41762E+00    0.48781E+00    0.14159E-08    0.54449E-08    0.54182E-04    0.63271E-04    0.15937E+06    0.87366E-02    0.42418E+05    0.52150E-23    0.31202E-06    0.20988E-03    0.29419E+03
+    4    1    0.15405E-08    0.10000E+01    0.36333E+00    0.69413E+00    0.73763E-08    0.13444E-07    0.63796E-04    0.63687E-04    0.81842E+05    0.10022E-01    0.66266E+04    0.47987E-22    0.49383E-06    0.46540E-03    0.16320E+03
+    4    1    0.26880E-08    0.10000E+01    0.41493E+00    0.79920E+00    0.14413E-07    0.26952E-07    0.78612E-04    0.64477E-04    0.11884E+06    0.16326E-01    0.43556E+04    0.16801E-21    0.82043E-06    0.66658E-03    0.11507E+03
+    4    1    0.46905E-08    0.10000E+01    0.48925E+00    0.88639E+00    0.25829E-07    0.51969E-07    0.10150E-03    0.65033E-04    0.20736E+06    0.28487E-01    0.32516E+04    0.51055E-21    0.13585E-05    0.89233E-03    0.84398E+02
+    4    1    0.81846E-08    0.10000E+01    0.56673E+00    0.97193E+00    0.45706E-07    0.98963E-07    0.13297E-03    0.65496E-04    0.36184E+06    0.49709E-01    0.24275E+04    0.15520E-20    0.22272E-05    0.11950E-02    0.61636E+02
+    4    1    0.14282E-07    0.10000E+01    0.64674E+00    0.10550E+01    0.79653E-07    0.18646E-06    0.17564E-03    0.65920E-04    0.63138E+06    0.86738E-01    0.18098E+04    0.47302E-20    0.36228E-05    0.16025E-02    0.44825E+02
+    4    1    0.24920E-07    0.10000E+01    0.72758E+00    0.11339E+01    0.13744E-06    0.34778E-06    0.23364E-03    0.66323E-04    0.11017E+07    0.15135E+00    0.13511E+04    0.14383E-19    0.58583E-05    0.21465E-02    0.32588E+02
+    4    1    0.43485E-07    0.10000E+01    0.80896E+00    0.12086E+01    0.23376E-06    0.64324E-06    0.31151E-03    0.66721E-04    0.19224E+07    0.26410E+00    0.10073E+04    0.43840E-19    0.94208E-05    0.28789E-02    0.23633E+02
+    4    1    0.75878E-07    0.10000E+01    0.88920E+00    0.12781E+01    0.39425E-06    0.11802E-05    0.41669E-03    0.67115E-04    0.33546E+07    0.46084E+00    0.75202E+03    0.13322E-18    0.15088E-04    0.38558E-02    0.17152E+02
+    4    1    0.13240E-06    0.10000E+01    0.96812E+00    0.13425E+01    0.65574E-06    0.21493E-05    0.55729E-03    0.67510E-04    0.58535E+07    0.80414E+00    0.56068E+03    0.40205E-18    0.24049E-04    0.51577E-02    0.12434E+02
+    4    1    0.23103E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.15703E-05    0.38017E-05    0.87654E-03    0.67662E-04    0.10214E+08    0.14032E+01    0.50000E+03    0.86013E-18    0.40441E-04    0.57605E-02    0.10978E+02
+    4    1    0.40314E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.47812E-05    0.66338E-05    0.15295E-02    0.67662E-04    0.17823E+08    0.24485E+01    0.50000E+03    0.15009E-17    0.70568E-04    0.57605E-02    0.10978E+02
+    4    1    0.70346E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.14558E-04    0.11576E-04    0.26689E-02    0.67662E-04    0.31100E+08    0.42724E+01    0.50000E+03    0.26189E-17    0.12314E-03    0.57605E-02    0.10978E+02
+    4    1    0.12275E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.44326E-04    0.20199E-04    0.46571E-02    0.67662E-04    0.54267E+08    0.74551E+01    0.50000E+03    0.45699E-17    0.21487E-03    0.57605E-02    0.10978E+02
+    4    1    0.21419E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.13496E-03    0.35246E-04    0.81263E-02    0.67662E-04    0.94693E+08    0.13009E+02    0.50000E+03    0.79742E-17    0.37493E-03    0.57605E-02    0.10978E+02
+    4    1    0.37375E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.41094E-03    0.61501E-04    0.14180E-01    0.67662E-04    0.16523E+09    0.22699E+02    0.50000E+03    0.13915E-16    0.65423E-03    0.57605E-02    0.10978E+02
+    4    1    0.65217E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.12512E-02    0.10732E-03    0.24743E-01    0.67662E-04    0.28832E+09    0.39609E+02    0.50000E+03    0.24280E-16    0.11416E-02    0.57605E-02    0.10978E+02
+    4    1    0.11380E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.38098E-02    0.18726E-03    0.43175E-01    0.67662E-04    0.50310E+09    0.69116E+02    0.50000E+03    0.42367E-16    0.19920E-02    0.57605E-02    0.10978E+02
+    4    1    0.19857E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.11600E-01    0.32676E-03    0.75338E-01    0.67662E-04    0.87789E+09    0.12060E+03    0.50000E+03    0.73928E-16    0.34759E-02    0.57605E-02    0.10978E+02
+    4    1    0.34650E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.35320E-01    0.57017E-03    0.13146E+00    0.67662E-04    0.15319E+10    0.21044E+03    0.50000E+03    0.12900E-15    0.60653E-02    0.57605E-02    0.10978E+02
+    4    1    0.60462E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.10754E+00    0.99492E-03    0.22939E+00    0.67662E-04    0.26730E+10    0.36721E+03    0.50000E+03    0.22510E-15    0.10583E-01    0.57605E-02    0.10978E+02
+    4    1    0.10550E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.32745E+00    0.17361E-02    0.40027E+00    0.67662E-04    0.46642E+10    0.64076E+03    0.50000E+03    0.39278E-15    0.18468E-01    0.57605E-02    0.10978E+02
+    4    1    0.18409E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.99703E+00    0.30293E-02    0.69845E+00    0.67662E-04    0.81388E+10    0.11181E+04    0.50000E+03    0.68538E-15    0.32225E-01    0.57605E-02    0.10978E+02
+    4    1    0.32123E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.30358E+01    0.52860E-02    0.12188E+01    0.67662E-04    0.14202E+11    0.19510E+04    0.50000E+03    0.11959E-14    0.56230E-01    0.57605E-02    0.10978E+02
+    4    1    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    4    1    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    4    1    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    4    1    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    4    1    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    4    1    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    4    1    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    4    1    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    4    1    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    4    1    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    4    1    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    4    1    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    4    1    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    4    1    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    4    1    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    4    1    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    4    1    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    4    1    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    4    1    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    4    1    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    4    1    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    4    1    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    4    1    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    4    1    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    4    1    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    4    1    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    4    1    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    4    1    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    4    1    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    4    1    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    4    1    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    4    1    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    4    1    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    4    1    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    4    1    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    4    1    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    4    1    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    4    1    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    4    1    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    4    1    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    4    1    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    4    1    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    4    1    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    4    1    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    4    1    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    4    1    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    4    1    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    4    1    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    4    1    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    4    1    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    4    1    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    4    1    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    4    1    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    4    1    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    4    1    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    4    1    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    4    1    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    4    1    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    4    1    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    4    1    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    4    1    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    4    1    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    4    1    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    4    1    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    4    1    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    4    1    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    4    1    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    4    1    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    4    1    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    4    1    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    4    1    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    4    1    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    4    1    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    4    1    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    4    1    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    4    1    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    4    1    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    4    1    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    4    1    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    4    1    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    4    1    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    4    1    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    4    1    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    4    1    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    4    1    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    4    1    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    4    1    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    4    1    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    4    1    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    4    1    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    4    1    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    4    1    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    4    1    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    4    1    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    4    1    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    4    1    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    4    1    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    4    1    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    4    1    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    4    1    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    4    1    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    4    1    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    4    1    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    4    1    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    4    1    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    4    1    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    4    1    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    4    1    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    4    1    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    4    1    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    4    1    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    4    1    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    4    1    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    4    1    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    4    1    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    4    1    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    4    1    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    4    1    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    4    1    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    4    1    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    4    1    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    4    1    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    4    1    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    4    1    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    4    1    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    4    1    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    4    1    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    4    1    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    4    1    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    4    1    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    4    1    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    4    1    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    4    1    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    4    1    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    4    1    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    4    1    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    4    1    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    4    1    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    4    1    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    4    1    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    4    1    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    4    1    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    4    1    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    4    1    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    4    1    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    4    1    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    4    1    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    4    1    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    4    1    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    4    1    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    4    1    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    4    1    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    4    1    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    4    1    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    4    1    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    4    1    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    4    1    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    4    1    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    4    1    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    4    1    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    4    1    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    4    1    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    4    1    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    4    1    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    4    1    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    4    1    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    4    1    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    4    1    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    4    1    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    4    1    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    4    1    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    4    1    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    4    1    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    4    1    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    4    1    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    4    1    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    4    1    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    4    1    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    4    1    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    4    1    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    4    1    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    4    1    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    4    1    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    4    1    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    4    1    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    4    1    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    4    1    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    4    1    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    4    1    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    4    1    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    4    1    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    4    1    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    4    1    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    4    1    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    4    1    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    4    1    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    4    1    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    4    1    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    4    1    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    4    1    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    4    1    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    4    1    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    4    1    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    4    1    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    4    1    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    4    1    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    4    1    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    4    1    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    4    1    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    4    1    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    4    1    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    4    1    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    4    1    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    4    1    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    4    1    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    4    1    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    4    1    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    4    1    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    4    1    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    4    1    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    4    1    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    4    1    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    4    1    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    4    1    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    4    1    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    4    1    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    4    1    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    4    1    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    4    1    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    4    1    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    4    1    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    4    1    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    4    1    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    4    1    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    4    1    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    4    1    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    4    1    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    4    1    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    4    1    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    4    1    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    4    1    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    4    1    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    4    1    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    4    1    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    4    1    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    4    1    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    4    1    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    4    1    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    4    1    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    4    1    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    4    1    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    4    1    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    4    1    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    4    1    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    4    1    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    4    1    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    4    1    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    4    1    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    4    1    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    4    1    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    4    1    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    4    1    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    4    1    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    4    1    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    4    1    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    4    1    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    4    1    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    4    1    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    4    1    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    4    1    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    4    1    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    4    1    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    4    1    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    4    1    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    4    1    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    4    1    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    4    1    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    4    1    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    4    1    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    4    1    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    4    1    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    4    1    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    4    1    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    4    1    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    4    1    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    4    1    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    4    1    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    4    1    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    4    1    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    4    1    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    4    1    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    4    1    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    4    1    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    4    1    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    4    1    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    4    1    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    4    1    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    4    1    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    4    1    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    4    1    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    4    1    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    4    1    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    4    1    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    4    1    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    4    1    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    4    1    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    4    1    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    4    1    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    4    1    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    4    1    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    4    1    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    4    1    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    4    1    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    4    1    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    4    1    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    4    1    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    4    1    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    4    1    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    4    1    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    4    1    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    4    1    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    4    1    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    4    1    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    4    1    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    4    1    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    4    1    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    4    1    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    4    1    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    4    1    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    4    1    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    4    1    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    4    1    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    4    1    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    4    1    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    4    1    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    4    1    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    4    1    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    4    1    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    4    1    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    4    1    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    4    1    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    4    1    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    4    1    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    4    1    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    4    1    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    4    1    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    4    1    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    4    1    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    4    1    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    4    1    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    4    1    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    4    1    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    4    1    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    4    1    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    4    1    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    4    1    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    4    1    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    4    1    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    4    1    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    4    1    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    4    1    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    4    1    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    4    1    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    4    1    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    4    1    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    4    1    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    4    1    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    4    1    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    4    1    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    4    1    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    4    1    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    4    1    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    4    1    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    4    1    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    4    1    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    4    1    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    4    1    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    4    1    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    4    1    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    4    1    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    4    1    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    4    1    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    4    1    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    4    1    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    4    1    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    4    1    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    4    1    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    4    1    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    4    1    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    4    1    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    4    1    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    4    1    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    4    1    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    4    1    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    4    1    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    4    1    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    4    1    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    4    1    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    4    1    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    4    1    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    4    1    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    4    1    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    4    1    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    4    1    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    4    1    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    4    1    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    4    1    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    4    1    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    4    1    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    4    1    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    4    1    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    4    1    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    4    1    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    4    1    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    4    1    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    4    1    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    4    1    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    4    1    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    4    1    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    4    1    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    4    1    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    4    1    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    4    1    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    4    1    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    4    1    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    4    1    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    4    1    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    4    1    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    4    1    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    4    1    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    4    1    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    4    1    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    4    1    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    4    1    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    4    1    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    4    1    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    4    1    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    4    1    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    4    1    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    4    1    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    4    1    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    4    1    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    4    1    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    4    1    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    4    1    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    4    1    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    4    1    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    4    1    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    4    1    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    4    1    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    4    1    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    4    1    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    4    1    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    4    1    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    4    1    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    4    1    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    4    1    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    4    1    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    4    1    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    4    1    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    4    1    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    4    1    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    4    1    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    4    1    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    4    1    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    4    1    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    4    1    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    4    1    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    4    1    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    4    1    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    4    1    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    4    1    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    4    1    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    4    1    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    4    1    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    4    1    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    4    1    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    4    1    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    4    1    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    4    1    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    4    1    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    4    1    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    4    1    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    4    1    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    4    1    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    4    1    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    4    1    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    4    1    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    4    1    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    4    1    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    4    1    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    4    1    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    4    1    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    4    1    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    4    1    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    4    1    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    4    1    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    4    1    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    4    1    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    4    1    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    4    1    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    4    1    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    4    1    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    4    1    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    4    1    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    4    1    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    4    1    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    4    1    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    4    1    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    4    1    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    4    1    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    4    1    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    4    1    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    4    1    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    4    1    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    4    1    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    4    1    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    4    1    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    4    1    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    4    1    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    4    1    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    4    1    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    4    1    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    4    1    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    4    1    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    4    1    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    4    1    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    4    1    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    4    1    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    4    1    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    4    1    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    4    1    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    4    1    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    4    1    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    4    1    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    4    1    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    4    1    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    4    1    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    4    1    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    4    1    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    4    1    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    4    1    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    4    1    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    4    1    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    4    1    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    4    1    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    4    1    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    4    1    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    4    1    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    4    1    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    4    1    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    4    1    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    4    1    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    4    1    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    4    1    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    4    1    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    4    1    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    4    1    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    4    1    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    4    1    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    4    1    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    4    1    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    4    1    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    4    1    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    4    1    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    4    1    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    4    1    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    4    1    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    4    1    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    4    1    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    4    1    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    4    1    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    4    1    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    4    1    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    4    1    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    4    1    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    4    1    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    4    1    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    4    1    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    4    1    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    4    1    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    4    1    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    4    1    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    4    1    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    4    1    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    4    1    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    4    1    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    4    1    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    4    1    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    4    1    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    4    1    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    4    1    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    4    1    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    4    1    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    4    1    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    4    1    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    4    1    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    4    1    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    4    1    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    4    1    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    4    1    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    4    1    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    4    1    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    4    1    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    4    1    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    4    1    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    4    1    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    4    1    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    4    1    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    4    1    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    4    1    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    4    1    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    4    1    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    4    1    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    4    1    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    4    1    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    4    1    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    4    1    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    4    1    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    4    1    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    4    1    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    4    1    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    4    1    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    4    1    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    4    1    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    4    1    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    4    1    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    4    1    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    4    1    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    4    1    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    4    1    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35525E-67
+    4    1    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31050E-66
+    4    1    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49297E-66    0.26759E-65
+    4    1    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20665E-64
+    4    1    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    4    1    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15327E-62
+    4    1    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    4    1    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30486E-60
+    4    1    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49479E-59
+    4    1    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76348E-58
+    4    1    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    4    1    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16341E-55
+    4    1    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    4    1    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33513E-53
+    4    1    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47754E-52
+    4    1    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86007E-46    0.21355E-49
+    4    1    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    4    1    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    4    1    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    4    1    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    4    1    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    4    1    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    4    1    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    4    1    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    4    1    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    4    1    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    4    1    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    4    1    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    4    1    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    4    1    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    4    1    0.95225E-10    0.10000E+01    0.80645E+05    0.53338E-57    0.41251E-68    0.10749E-66
+    4    1    0.95225E-10    0.10000E+01    0.65036E+05    0.46320E-56    0.66241E-67    0.94141E-66
+    4    1    0.95225E-10    0.10000E+01    0.52449E+05    0.40024E-55    0.93503E-66    0.81416E-65
+    4    1    0.95225E-10    0.10000E+01    0.42297E+05    0.31521E-54    0.15121E-64    0.62477E-64
+    4    1    0.95225E-10    0.10000E+01    0.34111E+05    0.26479E-53    0.31103E-63    0.46450E-63
+    4    1    0.95225E-10    0.10000E+01    0.27509E+05    0.27530E-52    0.84266E-62    0.36185E-62
+    4    1    0.95225E-10    0.10000E+01    0.22184E+05    0.37547E-51    0.26561E-60    0.35004E-61
+    4    1    0.95225E-10    0.10000E+01    0.17891E+05    0.59959E-50    0.82078E-59    0.47852E-60
+    4    1    0.95225E-10    0.10000E+01    0.14428E+05    0.96029E-49    0.23747E-57    0.76675E-59
+    4    1    0.95225E-10    0.10000E+01    0.11635E+05    0.14620E-47    0.65938E-56    0.12102E-57
+    4    1    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18298E-56
+    4    1    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49011E-53    0.26942E-55
+    4    1    0.95225E-10    0.10000E+01    0.61026E+04    0.43943E-44    0.13295E-51    0.39150E-54
+    4    1    0.95225E-10    0.10000E+01    0.49215E+04    0.62538E-43    0.35997E-50    0.56476E-53
+    4    1    0.95225E-10    0.10000E+01    0.39689E+04    0.88822E-42    0.97300E-49    0.81063E-52
+    4    1    0.95225E-10    0.10000E+01    0.32008E+04    0.39613E-39    0.84952E-46    0.36461E-49
+    4    1    0.95225E-10    0.10000E+01    0.25813E+04    0.29211E-30    0.14353E-36    0.27085E-40
+    4    1    0.95225E-10    0.10000E+01    0.20817E+04    0.55938E-14    0.12256E-19    0.52257E-24
+    4    1    0.95225E-10    0.10000E+01    0.16788E+04    0.18980E-08    0.18143E-13    0.17813E-18
+    4    1    0.95225E-10    0.10000E+01    0.13538E+04    0.40806E-08    0.68940E-13    0.38357E-18
+    4    1    0.95225E-10    0.10000E+01    0.10918E+04    0.85761E-08    0.25711E-12    0.80708E-18
+    4    1    0.95225E-10    0.10000E+01    0.88049E+03    0.17636E-07    0.94670E-12    0.16610E-17
+    4    1    0.95225E-10    0.10000E+01    0.71007E+03    0.35560E-07    0.34475E-11    0.33511E-17
+    4    1    0.95225E-10    0.10000E+01    0.57264E+03    0.70490E-07    0.12266E-10    0.66454E-17
+    4    1    0.95225E-10    0.10000E+01    0.46180E+03    0.13745E-06    0.41255E-10    0.12961E-16
+    4    1    0.95225E-10    0.10000E+01    0.37242E+03    0.26237E-06    0.12579E-09    0.24744E-16
+    4    1    0.95225E-10    0.10000E+01    0.30034E+03    0.48462E-06    0.33740E-09    0.45710E-16
+    4    1    0.95225E-10    0.10000E+01    0.24221E+03    0.85384E-06    0.78780E-09    0.80539E-16
+    4    1    0.95225E-10    0.10000E+01    0.19533E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    4    1    0.95225E-10    0.10000E+01    0.15752E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    4    1    0.16616E-09    0.10000E+01    0.80645E+05    0.10831E-56    0.84134E-68    0.33649E-66
+    4    1    0.16616E-09    0.10000E+01    0.65036E+05    0.94382E-56    0.13505E-66    0.29209E-65
+    4    1    0.16616E-09    0.10000E+01    0.52449E+05    0.81476E-55    0.18599E-65    0.25174E-64
+    4    1    0.16616E-09    0.10000E+01    0.42297E+05    0.62646E-54    0.26584E-64    0.19203E-63
+    4    1    0.16616E-09    0.10000E+01    0.34111E+05    0.47293E-53    0.41443E-63    0.13945E-62
+    4    1    0.16616E-09    0.10000E+01    0.27509E+05    0.38376E-52    0.82703E-62    0.99836E-62
+    4    1    0.16616E-09    0.10000E+01    0.22184E+05    0.38951E-51    0.23108E-60    0.77606E-61
+    4    1    0.16616E-09    0.10000E+01    0.17891E+05    0.53703E-50    0.71872E-59    0.82846E-60
+    4    1    0.16616E-09    0.10000E+01    0.14428E+05    0.84667E-49    0.21403E-57    0.12129E-58
+    4    1    0.16616E-09    0.10000E+01    0.11635E+05    0.13169E-47    0.60847E-56    0.19194E-57
+    4    1    0.16616E-09    0.10000E+01    0.93834E+04    0.19721E-46    0.16918E-54    0.29611E-56
+    4    1    0.16616E-09    0.10000E+01    0.75673E+04    0.28850E-45    0.46590E-53    0.44363E-55
+    4    1    0.16616E-09    0.10000E+01    0.61026E+04    0.41726E-44    0.12762E-51    0.65289E-54
+    4    1    0.16616E-09    0.10000E+01    0.49215E+04    0.59980E-43    0.34818E-50    0.95065E-53
+    4    1    0.16616E-09    0.10000E+01    0.39689E+04    0.85857E-42    0.94687E-49    0.13742E-51
+    4    1    0.16616E-09    0.10000E+01    0.32008E+04    0.38534E-39    0.83094E-46    0.62162E-49
+    4    1    0.16616E-09    0.10000E+01    0.25813E+04    0.28572E-30    0.14110E-36    0.46404E-40
+    4    1    0.16616E-09    0.10000E+01    0.20817E+04    0.55023E-14    0.12112E-19    0.89981E-24
+    4    1    0.16616E-09    0.10000E+01    0.16788E+04    0.18735E-08    0.17967E-13    0.30768E-18
+    4    1    0.16616E-09    0.10000E+01    0.13538E+04    0.40327E-08    0.68292E-13    0.66322E-18
+    4    1    0.16616E-09    0.10000E+01    0.10918E+04    0.84828E-08    0.25473E-12    0.13965E-17
+    4    1    0.16616E-09    0.10000E+01    0.88049E+03    0.17454E-07    0.93805E-12    0.28757E-17
+    4    1    0.16616E-09    0.10000E+01    0.71007E+03    0.35210E-07    0.34161E-11    0.58040E-17
+    4    1    0.16616E-09    0.10000E+01    0.57264E+03    0.69816E-07    0.12154E-10    0.11512E-16
+    4    1    0.16616E-09    0.10000E+01    0.46180E+03    0.13616E-06    0.40880E-10    0.22458E-16
+    4    1    0.16616E-09    0.10000E+01    0.37242E+03    0.25994E-06    0.12465E-09    0.42878E-16
+    4    1    0.16616E-09    0.10000E+01    0.30034E+03    0.48017E-06    0.33433E-09    0.79212E-16
+    4    1    0.16616E-09    0.10000E+01    0.24221E+03    0.84602E-06    0.78064E-09    0.13957E-15
+    4    1    0.16616E-09    0.10000E+01    0.19533E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    4    1    0.16616E-09    0.10000E+01    0.15752E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    4    1    0.28994E-09    0.10000E+01    0.80645E+05    0.22011E-56    0.16920E-67    0.11249E-65
+    4    1    0.28994E-09    0.10000E+01    0.65036E+05    0.19023E-55    0.27099E-66    0.96503E-65
+    4    1    0.28994E-09    0.10000E+01    0.52449E+05    0.16355E-54    0.36930E-65    0.82631E-64
+    4    1    0.28994E-09    0.10000E+01    0.42297E+05    0.12449E-53    0.50576E-64    0.62542E-63
+    4    1    0.28994E-09    0.10000E+01    0.34111E+05    0.90534E-53    0.69149E-63    0.44950E-62
+    4    1    0.28994E-09    0.10000E+01    0.27509E+05    0.65403E-52    0.10276E-61    0.31368E-61
+    4    1    0.28994E-09    0.10000E+01    0.22184E+05    0.51145E-51    0.21678E-60    0.21734E-60
+    4    1    0.28994E-09    0.10000E+01    0.17891E+05    0.53350E-50    0.62717E-59    0.17681E-59
+    4    1    0.28994E-09    0.10000E+01    0.14428E+05    0.75573E-49    0.19028E-57    0.20765E-58
+    4    1    0.28994E-09    0.10000E+01    0.11635E+05    0.11751E-47    0.55601E-56    0.31026E-57
+    4    1    0.28994E-09    0.10000E+01    0.93834E+04    0.17997E-46    0.15781E-54    0.48192E-56
+    4    1    0.28994E-09    0.10000E+01    0.75673E+04    0.26865E-45    0.44099E-53    0.73307E-55
+    4    1    0.28994E-09    0.10000E+01    0.61026E+04    0.39444E-44    0.12210E-51    0.10917E-53
+    4    1    0.28994E-09    0.10000E+01    0.49215E+04    0.57333E-43    0.33588E-50    0.16029E-52
+    4    1    0.28994E-09    0.10000E+01    0.39689E+04    0.82768E-42    0.91939E-49    0.23314E-51
+    4    1    0.28994E-09    0.10000E+01    0.32008E+04    0.37400E-39    0.81127E-46    0.10597E-48
+    4    1    0.28994E-09    0.10000E+01    0.25813E+04    0.27896E-30    0.13850E-36    0.79454E-40
+    4    1    0.28994E-09    0.10000E+01    0.20817E+04    0.54048E-14    0.11957E-19    0.15478E-23
+    4    1    0.28994E-09    0.10000E+01    0.16788E+04    0.18472E-08    0.17777E-13    0.53075E-18
+    4    1    0.28994E-09    0.10000E+01    0.13538E+04    0.39812E-08    0.67591E-13    0.11451E-17
+    4    1    0.28994E-09    0.10000E+01    0.10918E+04    0.83822E-08    0.25216E-12    0.24130E-17
+    4    1    0.28994E-09    0.10000E+01    0.88049E+03    0.17259E-07    0.92865E-12    0.49712E-17
+    4    1    0.28994E-09    0.10000E+01    0.71007E+03    0.34831E-07    0.33820E-11    0.10037E-16
+    4    1    0.28994E-09    0.10000E+01    0.57264E+03    0.69086E-07    0.12033E-10    0.19913E-16
+    4    1    0.28994E-09    0.10000E+01    0.46180E+03    0.13476E-06    0.40472E-10    0.38849E-16
+    4    1    0.28994E-09    0.10000E+01    0.37242E+03    0.25730E-06    0.12341E-09    0.74180E-16
+    4    1    0.28994E-09    0.10000E+01    0.30034E+03    0.47533E-06    0.33100E-09    0.13705E-15
+    4    1    0.28994E-09    0.10000E+01    0.24221E+03    0.83753E-06    0.77285E-09    0.24148E-15
+    4    1    0.28994E-09    0.10000E+01    0.19533E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    4    1    0.28994E-09    0.10000E+01    0.15752E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    4    1    0.50593E-09    0.10000E+01    0.80645E+05    0.44926E-56    0.34079E-67    0.39232E-65
+    4    1    0.50593E-09    0.10000E+01    0.65036E+05    0.38422E-55    0.54341E-66    0.33355E-64
+    4    1    0.50593E-09    0.10000E+01    0.52449E+05    0.32834E-54    0.73364E-65    0.28402E-63
+    4    1    0.50593E-09    0.10000E+01    0.42297E+05    0.24795E-53    0.99037E-64    0.21350E-62
+    4    1    0.50593E-09    0.10000E+01    0.34111E+05    0.17797E-52    0.13099E-62    0.15247E-61
+    4    1    0.50593E-09    0.10000E+01    0.27509E+05    0.12441E-51    0.16902E-61    0.10586E-60
+    4    1    0.50593E-09    0.10000E+01    0.22184E+05    0.86010E-51    0.25710E-60    0.70603E-60
+    4    1    0.50593E-09    0.10000E+01    0.17891E+05    0.67638E-50    0.58946E-59    0.47985E-59
+    4    1    0.50593E-09    0.10000E+01    0.14428E+05    0.74782E-49    0.17213E-57    0.41577E-58
+    4    1    0.50593E-09    0.10000E+01    0.11635E+05    0.10801E-47    0.51285E-56    0.52474E-57
+    4    1    0.50593E-09    0.10000E+01    0.93834E+04    0.16626E-46    0.14855E-54    0.79304E-56
+    4    1    0.50593E-09    0.10000E+01    0.75673E+04    0.25254E-45    0.42087E-53    0.12189E-54
+    4    1    0.50593E-09    0.10000E+01    0.61026E+04    0.37597E-44    0.11762E-51    0.18356E-53
+    4    1    0.50593E-09    0.10000E+01    0.49215E+04    0.55185E-43    0.32580E-50    0.27151E-52
+    4    1    0.50593E-09    0.10000E+01    0.39689E+04    0.80238E-42    0.89663E-49    0.39684E-51
+    4    1    0.50593E-09    0.10000E+01    0.32008E+04    0.36462E-39    0.79485E-46    0.18106E-48
+    4    1    0.50593E-09    0.10000E+01    0.25813E+04    0.27333E-30    0.13633E-36    0.13622E-39
+    4    1    0.50593E-09    0.10000E+01    0.20817E+04    0.53238E-14    0.11828E-19    0.26638E-23
+    4    1    0.50593E-09    0.10000E+01    0.16788E+04    0.18256E-08    0.17620E-13    0.91573E-18
+    4    1    0.50593E-09    0.10000E+01    0.13538E+04    0.39387E-08    0.67015E-13    0.19773E-17
+    4    1    0.50593E-09    0.10000E+01    0.10918E+04    0.82993E-08    0.25005E-12    0.41688E-17
+    4    1    0.50593E-09    0.10000E+01    0.88049E+03    0.17098E-07    0.92093E-12    0.85921E-17
+    4    1    0.50593E-09    0.10000E+01    0.71007E+03    0.34520E-07    0.33539E-11    0.17352E-16
+    4    1    0.50593E-09    0.10000E+01    0.57264E+03    0.68486E-07    0.11933E-10    0.34432E-16
+    4    1    0.50593E-09    0.10000E+01    0.46180E+03    0.13362E-06    0.40135E-10    0.67183E-16
+    4    1    0.50593E-09    0.10000E+01    0.37242E+03    0.25513E-06    0.12238E-09    0.12829E-15
+    4    1    0.50593E-09    0.10000E+01    0.30034E+03    0.47134E-06    0.32824E-09    0.23702E-15
+    4    1    0.50593E-09    0.10000E+01    0.24221E+03    0.83053E-06    0.76641E-09    0.41764E-15
+    4    1    0.50593E-09    0.10000E+01    0.19533E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    4    1    0.50593E-09    0.10000E+01    0.15752E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    4    1    0.88282E-09    0.10000E+01    0.80645E+05    0.91476E-56    0.68731E-67    0.13789E-64
+    4    1    0.88282E-09    0.10000E+01    0.65036E+05    0.77641E-55    0.10919E-65    0.11662E-63
+    4    1    0.88282E-09    0.10000E+01    0.52449E+05    0.66035E-54    0.14632E-64    0.98963E-63
+    4    1    0.88282E-09    0.10000E+01    0.42297E+05    0.49567E-53    0.19615E-63    0.74065E-62
+    4    1    0.88282E-09    0.10000E+01    0.34111E+05    0.35353E-52    0.25848E-62    0.52675E-61
+    4    1    0.88282E-09    0.10000E+01    0.27509E+05    0.24558E-51    0.32187E-61    0.36567E-60
+    4    1    0.88282E-09    0.10000E+01    0.22184E+05    0.16393E-50    0.40073E-60    0.24273E-59
+    4    1    0.88282E-09    0.10000E+01    0.17891E+05    0.10961E-49    0.65251E-59    0.15348E-58
+    4    1    0.88282E-09    0.10000E+01    0.14428E+05    0.89454E-49    0.16244E-57    0.10392E-57
+    4    1    0.88282E-09    0.10000E+01    0.11635E+05    0.10618E-47    0.47991E-56    0.98632E-57
+    4    1    0.88282E-09    0.10000E+01    0.93834E+04    0.15701E-46    0.14156E-54    0.13418E-55
+    4    1    0.88282E-09    0.10000E+01    0.75673E+04    0.24062E-45    0.40636E-53    0.20503E-54
+    4    1    0.88282E-09    0.10000E+01    0.61026E+04    0.36255E-44    0.11442E-51    0.31177E-53
+    4    1    0.88282E-09    0.10000E+01    0.49215E+04    0.53641E-43    0.31845E-50    0.46407E-52
+    4    1    0.88282E-09    0.10000E+01    0.39689E+04    0.78393E-42    0.87953E-49    0.68035E-51
+    4    1    0.88282E-09    0.10000E+01    0.32008E+04    0.35759E-39    0.78214E-46    0.31094E-48
+    4    1    0.88282E-09    0.10000E+01    0.25813E+04    0.26899E-30    0.13461E-36    0.23432E-39
+    4    1    0.88282E-09    0.10000E+01    0.20817E+04    0.52599E-14    0.11724E-19    0.45928E-23
+    4    1    0.88282E-09    0.10000E+01    0.16788E+04    0.18083E-08    0.17491E-13    0.15815E-17
+    4    1    0.88282E-09    0.10000E+01    0.13538E+04    0.39044E-08    0.66538E-13    0.34162E-17
+    4    1    0.88282E-09    0.10000E+01    0.10918E+04    0.82318E-08    0.24829E-12    0.72050E-17
+    4    1    0.88282E-09    0.10000E+01    0.88049E+03    0.16966E-07    0.91446E-12    0.14853E-16
+    4    1    0.88282E-09    0.10000E+01    0.71007E+03    0.34263E-07    0.33303E-11    0.30001E-16
+    4    1    0.88282E-09    0.10000E+01    0.57264E+03    0.67988E-07    0.11849E-10    0.59535E-16
+    4    1    0.88282E-09    0.10000E+01    0.46180E+03    0.13266E-06    0.39851E-10    0.11617E-15
+    4    1    0.88282E-09    0.10000E+01    0.37242E+03    0.25331E-06    0.12151E-09    0.22183E-15
+    4    1    0.88282E-09    0.10000E+01    0.30034E+03    0.46799E-06    0.32591E-09    0.40983E-15
+    4    1    0.88282E-09    0.10000E+01    0.24221E+03    0.82463E-06    0.76096E-09    0.72214E-15
+    4    1    0.88282E-09    0.10000E+01    0.19533E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    4    1    0.88282E-09    0.10000E+01    0.15752E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    4    1    0.15405E-08    0.10000E+01    0.80645E+05    0.22169E-55    0.16538E-66    0.19444E-63
+    4    1    0.15405E-08    0.10000E+01    0.65036E+05    0.18709E-54    0.26199E-65    0.16386E-62
+    4    1    0.15405E-08    0.10000E+01    0.52449E+05    0.15857E-53    0.34936E-64    0.13874E-61
+    4    1    0.15405E-08    0.10000E+01    0.42297E+05    0.11856E-52    0.46757E-63    0.10359E-60
+    4    1    0.15405E-08    0.10000E+01    0.34111E+05    0.84435E-52    0.62479E-62    0.73632E-60
+    4    1    0.15405E-08    0.10000E+01    0.27509E+05    0.59246E-51    0.81019E-61    0.51534E-59
+    4    1    0.15405E-08    0.10000E+01    0.22184E+05    0.40692E-50    0.10307E-59    0.35092E-58
+    4    1    0.15405E-08    0.10000E+01    0.17891E+05    0.27534E-49    0.14075E-58    0.22768E-57
+    4    1    0.15405E-08    0.10000E+01    0.14428E+05    0.19631E-48    0.24555E-57    0.13888E-56
+    4    1    0.15405E-08    0.10000E+01    0.11635E+05    0.17070E-47    0.57662E-56    0.81553E-56
+    4    1    0.15405E-08    0.10000E+01    0.93834E+04    0.19685E-46    0.15733E-54    0.52856E-55
+    4    1    0.15405E-08    0.10000E+01    0.75673E+04    0.27170E-45    0.44125E-53    0.48422E-54
+    4    1    0.15405E-08    0.10000E+01    0.61026E+04    0.39529E-44    0.12261E-51    0.62492E-53
+    4    1    0.15405E-08    0.10000E+01    0.49215E+04    0.57536E-43    0.33698E-50    0.90174E-52
+    4    1    0.15405E-08    0.10000E+01    0.39689E+04    0.83012E-42    0.92000E-49    0.13001E-50
+    4    1    0.15405E-08    0.10000E+01    0.32008E+04    0.37425E-39    0.80984E-46    0.58076E-48
+    4    1    0.15405E-08    0.10000E+01    0.25813E+04    0.27849E-30    0.13803E-36    0.42644E-39
+    4    1    0.15405E-08    0.10000E+01    0.20817E+04    0.53875E-14    0.11903E-19    0.81441E-23
+    4    1    0.15405E-08    0.10000E+01    0.16788E+04    0.18406E-08    0.17690E-13    0.27668E-17
+    4    1    0.15405E-08    0.10000E+01    0.13538E+04    0.39646E-08    0.67251E-13    0.59320E-17
+    4    1    0.15405E-08    0.10000E+01    0.10918E+04    0.83445E-08    0.25085E-12    0.12448E-16
+    4    1    0.15405E-08    0.10000E+01    0.88049E+03    0.17177E-07    0.92365E-12    0.25570E-16
+    4    1    0.15405E-08    0.10000E+01    0.71007E+03    0.34659E-07    0.33633E-11    0.51512E-16
+    4    1    0.15405E-08    0.10000E+01    0.57264E+03    0.68732E-07    0.11965E-10    0.10202E-15
+    4    1    0.15405E-08    0.10000E+01    0.46180E+03    0.13405E-06    0.40239E-10    0.19877E-15
+    4    1    0.15405E-08    0.10000E+01    0.37242E+03    0.25590E-06    0.12269E-09    0.37913E-15
+    4    1    0.15405E-08    0.10000E+01    0.30034E+03    0.47270E-06    0.32907E-09    0.69988E-15
+    4    1    0.15405E-08    0.10000E+01    0.24221E+03    0.83283E-06    0.76833E-09    0.12325E-14
+    4    1    0.15405E-08    0.10000E+01    0.19533E+03    0.13126E-05    0.14601E-08    0.19419E-14
+    4    1    0.15405E-08    0.10000E+01    0.15752E+03    0.13126E-05    0.14601E-08    0.19419E-14
+    4    1    0.26880E-08    0.10000E+01    0.80645E+05    0.44147E-55    0.32899E-66    0.76539E-63
+    4    1    0.26880E-08    0.10000E+01    0.65036E+05    0.37227E-54    0.52097E-65    0.64519E-62
+    4    1    0.26880E-08    0.10000E+01    0.52449E+05    0.31535E-53    0.69411E-64    0.54648E-61
+    4    1    0.26880E-08    0.10000E+01    0.42297E+05    0.23562E-52    0.92815E-63    0.40832E-60
+    4    1    0.26880E-08    0.10000E+01    0.34111E+05    0.16767E-51    0.12398E-61    0.29071E-59
+    4    1    0.26880E-08    0.10000E+01    0.27509E+05    0.11758E-50    0.16033E-60    0.20417E-58
+    4    1    0.26880E-08    0.10000E+01    0.22184E+05    0.80503E-50    0.19916E-59    0.14006E-57
+    4    1    0.26880E-08    0.10000E+01    0.17891E+05    0.53362E-49    0.24604E-58    0.92169E-57
+    4    1    0.26880E-08    0.10000E+01    0.14428E+05    0.35072E-48    0.34415E-57    0.57325E-56
+    4    1    0.26880E-08    0.10000E+01    0.11635E+05    0.25233E-47    0.64825E-56    0.33641E-55
+    4    1    0.26880E-08    0.10000E+01    0.93834E+04    0.23294E-46    0.16099E-54    0.19548E-54
+    4    1    0.26880E-08    0.10000E+01    0.75673E+04    0.28462E-45    0.44413E-53    0.13553E-53
+    4    1    0.26880E-08    0.10000E+01    0.61026E+04    0.40026E-44    0.12346E-51    0.13880E-52
+    4    1    0.26880E-08    0.10000E+01    0.49215E+04    0.57964E-43    0.33900E-50    0.18524E-51
+    4    1    0.26880E-08    0.10000E+01    0.39689E+04    0.83490E-42    0.92262E-49    0.26049E-50
+    4    1    0.26880E-08    0.10000E+01    0.32008E+04    0.37529E-39    0.80913E-46    0.11368E-47
+    4    1    0.26880E-08    0.10000E+01    0.25813E+04    0.27821E-30    0.13740E-36    0.81010E-39
+    4    1    0.26880E-08    0.10000E+01    0.20817E+04    0.53615E-14    0.11804E-19    0.14934E-22
+    4    1    0.26880E-08    0.10000E+01    0.16788E+04    0.18283E-08    0.17519E-13    0.49687E-17
+    4    1    0.26880E-08    0.10000E+01    0.13538E+04    0.39332E-08    0.66577E-13    0.10530E-16
+    4    1    0.26880E-08    0.10000E+01    0.10918E+04    0.82717E-08    0.24827E-12    0.21919E-16
+    4    1    0.26880E-08    0.10000E+01    0.88049E+03    0.17018E-07    0.91395E-12    0.44767E-16
+    4    1    0.26880E-08    0.10000E+01    0.71007E+03    0.34323E-07    0.33274E-11    0.89807E-16
+    4    1    0.26880E-08    0.10000E+01    0.57264E+03    0.68044E-07    0.11836E-10    0.17732E-15
+    4    1    0.26880E-08    0.10000E+01    0.46180E+03    0.13268E-06    0.39802E-10    0.34468E-15
+    4    1    0.26880E-08    0.10000E+01    0.37242E+03    0.25323E-06    0.12135E-09    0.65633E-15
+    4    1    0.26880E-08    0.10000E+01    0.30034E+03    0.46768E-06    0.32547E-09    0.12102E-14
+    4    1    0.26880E-08    0.10000E+01    0.24221E+03    0.82391E-06    0.75991E-09    0.21294E-14
+    4    1    0.26880E-08    0.10000E+01    0.19533E+03    0.12984E-05    0.14440E-08    0.33534E-14
+    4    1    0.26880E-08    0.10000E+01    0.15752E+03    0.12984E-05    0.14440E-08    0.33534E-14
+    4    1    0.46905E-08    0.10000E+01    0.80645E+05    0.84914E-55    0.63264E-66    0.25137E-62
+    4    1    0.46905E-08    0.10000E+01    0.65036E+05    0.71591E-54    0.10018E-64    0.21198E-61
+    4    1    0.46905E-08    0.10000E+01    0.52449E+05    0.60640E-53    0.13347E-63    0.17961E-60
+    4    1    0.46905E-08    0.10000E+01    0.42297E+05    0.45308E-52    0.17852E-62    0.13429E-59
+    4    1    0.46905E-08    0.10000E+01    0.34111E+05    0.32249E-51    0.23870E-61    0.95741E-59
+    4    1    0.46905E-08    0.10000E+01    0.27509E+05    0.22631E-50    0.30904E-60    0.67413E-58
+    4    1    0.46905E-08    0.10000E+01    0.22184E+05    0.15505E-49    0.38168E-59    0.46473E-57
+    4    1    0.46905E-08    0.10000E+01    0.17891E+05    0.10224E-48    0.45256E-58    0.30863E-56
+    4    1    0.46905E-08    0.10000E+01    0.14428E+05    0.65022E-48    0.55190E-57    0.19482E-55
+    4    1    0.46905E-08    0.10000E+01    0.11635E+05    0.41896E-47    0.82401E-56    0.11604E-54
+    4    1    0.46905E-08    0.10000E+01    0.93834E+04    0.31427E-46    0.17362E-54    0.66133E-54
+    4    1    0.46905E-08    0.10000E+01    0.75673E+04    0.31973E-45    0.45741E-53    0.40197E-53
+    4    1    0.46905E-08    0.10000E+01    0.61026E+04    0.41790E-44    0.12665E-51    0.33476E-52
+    4    1    0.46905E-08    0.10000E+01    0.49215E+04    0.59589E-43    0.34720E-50    0.40051E-51
+    4    1    0.46905E-08    0.10000E+01    0.39689E+04    0.85492E-42    0.94020E-49    0.54427E-50
+    4    1    0.46905E-08    0.10000E+01    0.32008E+04    0.38237E-39    0.81918E-46    0.23194E-47
+    4    1    0.46905E-08    0.10000E+01    0.25813E+04    0.28156E-30    0.13815E-36    0.15995E-38
+    4    1    0.46905E-08    0.10000E+01    0.20817E+04    0.53870E-14    0.11779E-19    0.28225E-22
+    4    1    0.46905E-08    0.10000E+01    0.16788E+04    0.18300E-08    0.17429E-13    0.91273E-17
+    4    1    0.46905E-08    0.10000E+01    0.13538E+04    0.39273E-08    0.66194E-13    0.19016E-16
+    4    1    0.46905E-08    0.10000E+01    0.10918E+04    0.82460E-08    0.24672E-12    0.39111E-16
+    4    1    0.46905E-08    0.10000E+01    0.88049E+03    0.16945E-07    0.90786E-12    0.79187E-16
+    4    1    0.46905E-08    0.10000E+01    0.71007E+03    0.34149E-07    0.33042E-11    0.15784E-15
+    4    1    0.46905E-08    0.10000E+01    0.57264E+03    0.67655E-07    0.11751E-10    0.31017E-15
+    4    1    0.46905E-08    0.10000E+01    0.46180E+03    0.13185E-06    0.39511E-10    0.60081E-15
+    4    1    0.46905E-08    0.10000E+01    0.37242E+03    0.25157E-06    0.12045E-09    0.11411E-14
+    4    1    0.46905E-08    0.10000E+01    0.30034E+03    0.46449E-06    0.32304E-09    0.21003E-14
+    4    1    0.46905E-08    0.10000E+01    0.24221E+03    0.81813E-06    0.75423E-09    0.36911E-14
+    4    1    0.46905E-08    0.10000E+01    0.19533E+03    0.12892E-05    0.14332E-08    0.58084E-14
+    4    1    0.46905E-08    0.10000E+01    0.15752E+03    0.12892E-05    0.14332E-08    0.58084E-14
+    4    1    0.81846E-08    0.10000E+01    0.80645E+05    0.16157E-54    0.12039E-65    0.81777E-62
+    4    1    0.81846E-08    0.10000E+01    0.65036E+05    0.13624E-53    0.19067E-64    0.68988E-61
+    4    1    0.81846E-08    0.10000E+01    0.52449E+05    0.11542E-52    0.25416E-63    0.58475E-60
+    4    1    0.81846E-08    0.10000E+01    0.42297E+05    0.86267E-52    0.34029E-62    0.43752E-59
+    4    1    0.81846E-08    0.10000E+01    0.34111E+05    0.61456E-51    0.45595E-61    0.31234E-58
+    4    1    0.81846E-08    0.10000E+01    0.27509E+05    0.43204E-50    0.59265E-60    0.22044E-57
+    4    1    0.81846E-08    0.10000E+01    0.22184E+05    0.29695E-49    0.73515E-59    0.15261E-56
+    4    1    0.81846E-08    0.10000E+01    0.17891E+05    0.19647E-48    0.86568E-58    0.10213E-55
+    4    1    0.81846E-08    0.10000E+01    0.14428E+05    0.12425E-47    0.99469E-57    0.65308E-55
+    4    1    0.81846E-08    0.10000E+01    0.11635E+05    0.76467E-47    0.12439E-55    0.39573E-54
+    4    1    0.81846E-08    0.10000E+01    0.93834E+04    0.49731E-46    0.20939E-54    0.22686E-53
+    4    1    0.81846E-08    0.10000E+01    0.75673E+04    0.40864E-45    0.49634E-53    0.12961E-52
+    4    1    0.81846E-08    0.10000E+01    0.61026E+04    0.46629E-44    0.13469E-51    0.90893E-52
+    4    1    0.81846E-08    0.10000E+01    0.49215E+04    0.63787E-43    0.36725E-50    0.94409E-51
+    4    1    0.81846E-08    0.10000E+01    0.39689E+04    0.90467E-42    0.98534E-49    0.12204E-49
+    4    1    0.81846E-08    0.10000E+01    0.32008E+04    0.40062E-39    0.84797E-46    0.50685E-47
+    4    1    0.81846E-08    0.10000E+01    0.25813E+04    0.29122E-30    0.14099E-36    0.33706E-38
+    4    1    0.81846E-08    0.10000E+01    0.20817E+04    0.54889E-14    0.11826E-19    0.56261E-22
+    4    1    0.81846E-08    0.10000E+01    0.16788E+04    0.18486E-08    0.17379E-13    0.17469E-16
+    4    1    0.81846E-08    0.10000E+01    0.13538E+04    0.39471E-08    0.65916E-13    0.35430E-16
+    4    1    0.81846E-08    0.10000E+01    0.10918E+04    0.82589E-08    0.24542E-12    0.71449E-16
+    4    1    0.81846E-08    0.10000E+01    0.88049E+03    0.16930E-07    0.90241E-12    0.14257E-15
+    4    1    0.81846E-08    0.10000E+01    0.71007E+03    0.34057E-07    0.32825E-11    0.28110E-15
+    4    1    0.81846E-08    0.10000E+01    0.57264E+03    0.67383E-07    0.11669E-10    0.54787E-15
+    4    1    0.81846E-08    0.10000E+01    0.46180E+03    0.13119E-06    0.39227E-10    0.10548E-14
+    4    1    0.81846E-08    0.10000E+01    0.37242E+03    0.25012E-06    0.11957E-09    0.19945E-14
+    4    1    0.81846E-08    0.10000E+01    0.30034E+03    0.46158E-06    0.32064E-09    0.36593E-14
+    4    1    0.81846E-08    0.10000E+01    0.24221E+03    0.81272E-06    0.74859E-09    0.64172E-14
+    4    1    0.81846E-08    0.10000E+01    0.19533E+03    0.12804E-05    0.14225E-08    0.10085E-13
+    4    1    0.81846E-08    0.10000E+01    0.15752E+03    0.12804E-05    0.14225E-08    0.10085E-13
+    4    1    0.14282E-07    0.10000E+01    0.80645E+05    0.30442E-54    0.22691E-65    0.26444E-61
+    4    1    0.14282E-07    0.10000E+01    0.65036E+05    0.25675E-53    0.35946E-64    0.22317E-60
+    4    1    0.14282E-07    0.10000E+01    0.52449E+05    0.21757E-52    0.47947E-63    0.18923E-59
+    4    1    0.14282E-07    0.10000E+01    0.42297E+05    0.16272E-51    0.64280E-62    0.14168E-58
+    4    1    0.14282E-07    0.10000E+01    0.34111E+05    0.11605E-50    0.86337E-61    0.10127E-57
+    4    1    0.14282E-07    0.10000E+01    0.27509E+05    0.81753E-50    0.11274E-59    0.71622E-57
+    4    1    0.14282E-07    0.10000E+01    0.22184E+05    0.56408E-49    0.14089E-58    0.49766E-56
+    4    1    0.14282E-07    0.10000E+01    0.17891E+05    0.37546E-48    0.16701E-57    0.33521E-55
+    4    1    0.14282E-07    0.10000E+01    0.14428E+05    0.23872E-47    0.18921E-56    0.21667E-54
+    4    1    0.14282E-07    0.10000E+01    0.11635E+05    0.14540E-46    0.21527E-55    0.13338E-53
+    4    1    0.14282E-07    0.10000E+01    0.93834E+04    0.88067E-46    0.29254E-54    0.77578E-53
+    4    1    0.14282E-07    0.10000E+01    0.75673E+04    0.60553E-45    0.58326E-53    0.43430E-52
+    4    1    0.14282E-07    0.10000E+01    0.61026E+04    0.57349E-44    0.15051E-51    0.27098E-51
+    4    1    0.14282E-07    0.10000E+01    0.49215E+04    0.72317E-43    0.40568E-50    0.24252E-50
+    4    1    0.14282E-07    0.10000E+01    0.39689E+04    0.10013E-41    0.10738E-48    0.29366E-49
+    4    1    0.14282E-07    0.10000E+01    0.32008E+04    0.43649E-39    0.90644E-46    0.11889E-46
+    4    1    0.14282E-07    0.10000E+01    0.25813E+04    0.31082E-30    0.14709E-36    0.76420E-38
+    4    1    0.14282E-07    0.10000E+01    0.20817E+04    0.57088E-14    0.11967E-19    0.12009E-21
+    4    1    0.14282E-07    0.10000E+01    0.16788E+04    0.18924E-08    0.17356E-13    0.35443E-16
+    4    1    0.14282E-07    0.10000E+01    0.13538E+04    0.40020E-08    0.65652E-13    0.69167E-16
+    4    1    0.14282E-07    0.10000E+01    0.10918E+04    0.83184E-08    0.24397E-12    0.13540E-15
+    4    1    0.14282E-07    0.10000E+01    0.88049E+03    0.16972E-07    0.89579E-12    0.26406E-15
+    4    1    0.14282E-07    0.10000E+01    0.71007E+03    0.34023E-07    0.32552E-11    0.51154E-15
+    4    1    0.14282E-07    0.10000E+01    0.57264E+03    0.67146E-07    0.11564E-10    0.98359E-15
+    4    1    0.14282E-07    0.10000E+01    0.46180E+03    0.13048E-06    0.38856E-10    0.18743E-14
+    4    1    0.14282E-07    0.10000E+01    0.37242E+03    0.24843E-06    0.11841E-09    0.35173E-14
+    4    1    0.14282E-07    0.10000E+01    0.30034E+03    0.45802E-06    0.31748E-09    0.64185E-14
+    4    1    0.14282E-07    0.10000E+01    0.24221E+03    0.80590E-06    0.74114E-09    0.11214E-13
+    4    1    0.14282E-07    0.10000E+01    0.19533E+03    0.12691E-05    0.14082E-08    0.17584E-13
+    4    1    0.14282E-07    0.10000E+01    0.15752E+03    0.12691E-05    0.14082E-08    0.17584E-13
+    4    1    0.24920E-07    0.10000E+01    0.80645E+05    0.56799E-54    0.42354E-65    0.84609E-61
+    4    1    0.24920E-07    0.10000E+01    0.65036E+05    0.47921E-53    0.67115E-64    0.71433E-60
+    4    1    0.24920E-07    0.10000E+01    0.52449E+05    0.40621E-52    0.89589E-63    0.60589E-59
+    4    1    0.24920E-07    0.10000E+01    0.42297E+05    0.30398E-51    0.12027E-61    0.45392E-58
+    4    1    0.24920E-07    0.10000E+01    0.34111E+05    0.21705E-50    0.16193E-60    0.32479E-57
+    4    1    0.24920E-07    0.10000E+01    0.27509E+05    0.15323E-49    0.21238E-59    0.23013E-56
+    4    1    0.24920E-07    0.10000E+01    0.22184E+05    0.10612E-48    0.26744E-58    0.16041E-55
+    4    1    0.24920E-07    0.10000E+01    0.17891E+05    0.71084E-48    0.32040E-57    0.10863E-54
+    4    1    0.24920E-07    0.10000E+01    0.14428E+05    0.45587E-47    0.36499E-56    0.70834E-54
+    4    1    0.24920E-07    0.10000E+01    0.11635E+05    0.27903E-46    0.40136E-55    0.44191E-53
+    4    1    0.24920E-07    0.10000E+01    0.93834E+04    0.16495E-45    0.47141E-54    0.26116E-52
+    4    1    0.24920E-07    0.10000E+01    0.75673E+04    0.10159E-44    0.76552E-53    0.14621E-51
+    4    1    0.24920E-07    0.10000E+01    0.61026E+04    0.79681E-44    0.18024E-51    0.85225E-51
+    4    1    0.24920E-07    0.10000E+01    0.49215E+04    0.88844E-43    0.47589E-50    0.66813E-50
+    4    1    0.24920E-07    0.10000E+01    0.39689E+04    0.11805E-41    0.12392E-48    0.74971E-49
+    4    1    0.24920E-07    0.10000E+01    0.32008E+04    0.50367E-39    0.10197E-45    0.29630E-46
+    4    1    0.24920E-07    0.10000E+01    0.25813E+04    0.34881E-30    0.15962E-36    0.18551E-37
+    4    1    0.24920E-07    0.10000E+01    0.20817E+04    0.61657E-14    0.12352E-19    0.27613E-21
+    4    1    0.24920E-07    0.10000E+01    0.16788E+04    0.19921E-08    0.17496E-13    0.77232E-16
+    4    1    0.24920E-07    0.10000E+01    0.13538E+04    0.41442E-08    0.65869E-13    0.14362E-15
+    4    1    0.24920E-07    0.10000E+01    0.10918E+04    0.85146E-08    0.24393E-12    0.27015E-15
+    4    1    0.24920E-07    0.10000E+01    0.88049E+03    0.17227E-07    0.89340E-12    0.50995E-15
+    4    1    0.24920E-07    0.10000E+01    0.71007E+03    0.34324E-07    0.32407E-11    0.96220E-15
+    4    1    0.24920E-07    0.10000E+01    0.57264E+03    0.67430E-07    0.11499E-10    0.18117E-14
+    4    1    0.24920E-07    0.10000E+01    0.46180E+03    0.13060E-06    0.38609E-10    0.33962E-14
+    4    1    0.24920E-07    0.10000E+01    0.37242E+03    0.24803E-06    0.11760E-09    0.62949E-14
+    4    1    0.24920E-07    0.10000E+01    0.30034E+03    0.45649E-06    0.31523E-09    0.11385E-13
+    4    1    0.24920E-07    0.10000E+01    0.24221E+03    0.80227E-06    0.73576E-09    0.19769E-13
+    4    1    0.24920E-07    0.10000E+01    0.19533E+03    0.12625E-05    0.13979E-08    0.30878E-13
+    4    1    0.24920E-07    0.10000E+01    0.15752E+03    0.12625E-05    0.13979E-08    0.30878E-13
+    4    1    0.43485E-07    0.10000E+01    0.80645E+05    0.10510E-53    0.78406E-65    0.26954E-60
+    4    1    0.43485E-07    0.10000E+01    0.65036E+05    0.88705E-53    0.12428E-63    0.22764E-59
+    4    1    0.43485E-07    0.10000E+01    0.52449E+05    0.75217E-52    0.16602E-62    0.19314E-58
+    4    1    0.43485E-07    0.10000E+01    0.42297E+05    0.56321E-51    0.22317E-61    0.14477E-57
+    4    1    0.43485E-07    0.10000E+01    0.34111E+05    0.40259E-50    0.30113E-60    0.10369E-56
+    4    1    0.43485E-07    0.10000E+01    0.27509E+05    0.28477E-49    0.39653E-59    0.73588E-56
+    4    1    0.43485E-07    0.10000E+01    0.22184E+05    0.19790E-48    0.50282E-58    0.51431E-55
+    4    1    0.43485E-07    0.10000E+01    0.17891E+05    0.13334E-47    0.60891E-57    0.34986E-54
+    4    1    0.43485E-07    0.10000E+01    0.14428E+05    0.86274E-47    0.70205E-56    0.22981E-53
+    4    1    0.43485E-07    0.10000E+01    0.11635E+05    0.53336E-46    0.76941E-55    0.14498E-52
+    4    1    0.43485E-07    0.10000E+01    0.93834E+04    0.31489E-45    0.83738E-54    0.86955E-52
+    4    1    0.43485E-07    0.10000E+01    0.75673E+04    0.18378E-44    0.11296E-52    0.49107E-51
+    4    1    0.43485E-07    0.10000E+01    0.61026E+04    0.12414E-43    0.23332E-51    0.27625E-50
+    4    1    0.43485E-07    0.10000E+01    0.49215E+04    0.11934E-42    0.59575E-50    0.19471E-49
+    4    1    0.43485E-07    0.10000E+01    0.39689E+04    0.14919E-41    0.15251E-48    0.20142E-48
+    4    1    0.43485E-07    0.10000E+01    0.32008E+04    0.62017E-39    0.12195E-45    0.77746E-46
+    4    1    0.43485E-07    0.10000E+01    0.25813E+04    0.41582E-30    0.18220E-36    0.47847E-37
+    4    1    0.43485E-07    0.10000E+01    0.20817E+04    0.69929E-14    0.13076E-19    0.68378E-21
+    4    1    0.43485E-07    0.10000E+01    0.16788E+04    0.21769E-08    0.17804E-13    0.18225E-15
+    4    1    0.43485E-07    0.10000E+01    0.13538E+04    0.44115E-08    0.66480E-13    0.32148E-15
+    4    1    0.43485E-07    0.10000E+01    0.10918E+04    0.88927E-08    0.24471E-12    0.57669E-15
+    4    1    0.43485E-07    0.10000E+01    0.88049E+03    0.17741E-07    0.89234E-12    0.10440E-14
+    4    1    0.43485E-07    0.10000E+01    0.71007E+03    0.34977E-07    0.32269E-11    0.19002E-14
+    4    1    0.43485E-07    0.10000E+01    0.57264E+03    0.68173E-07    0.11426E-10    0.34708E-14
+    4    1    0.43485E-07    0.10000E+01    0.46180E+03    0.13126E-06    0.38313E-10    0.63469E-14
+    4    1    0.43485E-07    0.10000E+01    0.37242E+03    0.24822E-06    0.11661E-09    0.11538E-13
+    4    1    0.43485E-07    0.10000E+01    0.30034E+03    0.45546E-06    0.31243E-09    0.20569E-13
+    4    1    0.43485E-07    0.10000E+01    0.24221E+03    0.79881E-06    0.72902E-09    0.35353E-13
+    4    1    0.43485E-07    0.10000E+01    0.19533E+03    0.12554E-05    0.13849E-08    0.54870E-13
+    4    1    0.43485E-07    0.10000E+01    0.15752E+03    0.12554E-05    0.13849E-08    0.54870E-13
+    4    1    0.75878E-07    0.10000E+01    0.80645E+05    0.19293E-53    0.14399E-64    0.85056E-60
+    4    1    0.75878E-07    0.10000E+01    0.65036E+05    0.16289E-52    0.22830E-63    0.71854E-59
+    4    1    0.75878E-07    0.10000E+01    0.52449E+05    0.13816E-51    0.30518E-62    0.60980E-58
+    4    1    0.75878E-07    0.10000E+01    0.42297E+05    0.10351E-50    0.41074E-61    0.45730E-57
+    4    1    0.75878E-07    0.10000E+01    0.34111E+05    0.74069E-50    0.55532E-60    0.32780E-56
+    4    1    0.75878E-07    0.10000E+01    0.27509E+05    0.52484E-49    0.73379E-59    0.23296E-55
+    4    1    0.75878E-07    0.10000E+01    0.22184E+05    0.36584E-48    0.93610E-58    0.16319E-54
+    4    1    0.75878E-07    0.10000E+01    0.17891E+05    0.24774E-47    0.11445E-56    0.11143E-53
+    4    1    0.75878E-07    0.10000E+01    0.14428E+05    0.16158E-46    0.13367E-55    0.73631E-53
+    4    1    0.75878E-07    0.10000E+01    0.11635E+05    0.10097E-45    0.14784E-54    0.46877E-52
+    4    1    0.75878E-07    0.10000E+01    0.93834E+04    0.60091E-45    0.15625E-53    0.28479E-51
+    4    1    0.75878E-07    0.10000E+01    0.75673E+04    0.34403E-44    0.18447E-52    0.16269E-50
+    4    1    0.75878E-07    0.10000E+01    0.61026E+04    0.21087E-43    0.32835E-51    0.90097E-50
+    4    1    0.75878E-07    0.10000E+01    0.49215E+04    0.17543E-42    0.79923E-50    0.58681E-49
+    4    1    0.75878E-07    0.10000E+01    0.39689E+04    0.20309E-41    0.20144E-48    0.56056E-48
+    4    1    0.75878E-07    0.10000E+01    0.32008E+04    0.82056E-39    0.15688E-45    0.21124E-45
+    4    1    0.75878E-07    0.10000E+01    0.25813E+04    0.53309E-30    0.22263E-36    0.12883E-36
+    4    1    0.75878E-07    0.10000E+01    0.20817E+04    0.84860E-14    0.14460E-19    0.17965E-20
+    4    1    0.75878E-07    0.10000E+01    0.16788E+04    0.25209E-08    0.18518E-13    0.46195E-15
+    4    1    0.75878E-07    0.10000E+01    0.13538E+04    0.49208E-08    0.68214E-13    0.77574E-15
+    4    1    0.75878E-07    0.10000E+01    0.10918E+04    0.96387E-08    0.24856E-12    0.13259E-14
+    4    1    0.75878E-07    0.10000E+01    0.88049E+03    0.18811E-07    0.89969E-12    0.22918E-14
+    4    1    0.75878E-07    0.10000E+01    0.71007E+03    0.36464E-07    0.32364E-11    0.39946E-14
+    4    1    0.75878E-07    0.10000E+01    0.57264E+03    0.70156E-07    0.11419E-10    0.70160E-14
+    4    1    0.75878E-07    0.10000E+01    0.46180E+03    0.13376E-06    0.38203E-10    0.12400E-13
+    4    1    0.75878E-07    0.10000E+01    0.37242E+03    0.25111E-06    0.11612E-09    0.21917E-13
+    4    1    0.75878E-07    0.10000E+01    0.30034E+03    0.45840E-06    0.31085E-09    0.38230E-13
+    4    1    0.75878E-07    0.10000E+01    0.24221E+03    0.80111E-06    0.72499E-09    0.64669E-13
+    4    1    0.75878E-07    0.10000E+01    0.19533E+03    0.12563E-05    0.13768E-08    0.99357E-13
+    4    1    0.75878E-07    0.10000E+01    0.15752E+03    0.12563E-05    0.13768E-08    0.99357E-13
+    4    1    0.13240E-06    0.10000E+01    0.80645E+05    0.35149E-53    0.26243E-64    0.26493E-59
+    4    1    0.13240E-06    0.10000E+01    0.65036E+05    0.29686E-52    0.41619E-63    0.22387E-58
+    4    1    0.13240E-06    0.10000E+01    0.52449E+05    0.25186E-51    0.55670E-62    0.19003E-57
+    4    1    0.13240E-06    0.10000E+01    0.42297E+05    0.18879E-50    0.75005E-61    0.14256E-56
+    4    1    0.13240E-06    0.10000E+01    0.34111E+05    0.13522E-49    0.10159E-59    0.10226E-55
+    4    1    0.13240E-06    0.10000E+01    0.27509E+05    0.95960E-49    0.13464E-58    0.72760E-55
+    4    1    0.13240E-06    0.10000E+01    0.22184E+05    0.67063E-48    0.17264E-57    0.51065E-54
+    4    1    0.13240E-06    0.10000E+01    0.17891E+05    0.45613E-47    0.21282E-56    0.34977E-53
+    4    1    0.13240E-06    0.10000E+01    0.14428E+05    0.29957E-46    0.25150E-55    0.23226E-52
+    4    1    0.13240E-06    0.10000E+01    0.11635E+05    0.18905E-45    0.28182E-54    0.14896E-51
+    4    1    0.13240E-06    0.10000E+01    0.93834E+04    0.11374E-44    0.29637E-53    0.91462E-51
+    4    1    0.13240E-06    0.10000E+01    0.75673E+04    0.64991E-44    0.32234E-52    0.52854E-50
+    4    1    0.13240E-06    0.10000E+01    0.61026E+04    0.37686E-43    0.49738E-51    0.29128E-49
+    4    1    0.13240E-06    0.10000E+01    0.49215E+04    0.27755E-42    0.11389E-49    0.17945E-48
+    4    1    0.13240E-06    0.10000E+01    0.39689E+04    0.29504E-41    0.28323E-48    0.15939E-47
+    4    1    0.13240E-06    0.10000E+01    0.32008E+04    0.11576E-38    0.21621E-45    0.58612E-45
+    4    1    0.13240E-06    0.10000E+01    0.25813E+04    0.73259E-30    0.29238E-36    0.35614E-36
+    4    1    0.13240E-06    0.10000E+01    0.20817E+04    0.11079E-13    0.16893E-19    0.49130E-20
+    4    1    0.13240E-06    0.10000E+01    0.16788E+04    0.31279E-08    0.19813E-13    0.12354E-14
+    4    1    0.13240E-06    0.10000E+01    0.13538E+04    0.58205E-08    0.71440E-13    0.19932E-14
+    4    1    0.13240E-06    0.10000E+01    0.10918E+04    0.10963E-07    0.25607E-12    0.32657E-14
+    4    1    0.13240E-06    0.10000E+01    0.88049E+03    0.20725E-07    0.91554E-12    0.54012E-14
+    4    1    0.13240E-06    0.10000E+01    0.71007E+03    0.39159E-07    0.32643E-11    0.90015E-14
+    4    1    0.13240E-06    0.10000E+01    0.57264E+03    0.73823E-07    0.11448E-10    0.15127E-13
+    4    1    0.13240E-06    0.10000E+01    0.46180E+03    0.13853E-06    0.38151E-10    0.25647E-13
+    4    1    0.13240E-06    0.10000E+01    0.37242E+03    0.25699E-06    0.11569E-09    0.43694E-13
+    4    1    0.13240E-06    0.10000E+01    0.30034E+03    0.46510E-06    0.30928E-09    0.73951E-13
+    4    1    0.13240E-06    0.10000E+01    0.24221E+03    0.80796E-06    0.72072E-09    0.12224E-12
+    4    1    0.13240E-06    0.10000E+01    0.19533E+03    0.12624E-05    0.13681E-08    0.18497E-12
+    4    1    0.13240E-06    0.10000E+01    0.15752E+03    0.12624E-05    0.13681E-08    0.18497E-12
+    4    1    0.23103E-06    0.10000E+01    0.80645E+05    0.62184E-53    0.46434E-64    0.57270E-59
+    4    1    0.23103E-06    0.10000E+01    0.65036E+05    0.52524E-52    0.73646E-63    0.48397E-58
+    4    1    0.23103E-06    0.10000E+01    0.52449E+05    0.44567E-51    0.98531E-62    0.41084E-57
+    4    1    0.23103E-06    0.10000E+01    0.42297E+05    0.33413E-50    0.13280E-60    0.30827E-56
+    4    1    0.23103E-06    0.10000E+01    0.34111E+05    0.23939E-49    0.17998E-59    0.22118E-55
+    4    1    0.23103E-06    0.10000E+01    0.27509E+05    0.16998E-48    0.23878E-58    0.15742E-54
+    4    1    0.23103E-06    0.10000E+01    0.22184E+05    0.11890E-47    0.30673E-57    0.11055E-53
+    4    1    0.23103E-06    0.10000E+01    0.17891E+05    0.80993E-47    0.37918E-56    0.75799E-53
+    4    1    0.23103E-06    0.10000E+01    0.14428E+05    0.53319E-46    0.44995E-55    0.50413E-52
+    4    1    0.23103E-06    0.10000E+01    0.11635E+05    0.33767E-45    0.50678E-54    0.32409E-51
+    4    1    0.23103E-06    0.10000E+01    0.93834E+04    0.20402E-44    0.53377E-53    0.19968E-50
+    4    1    0.23103E-06    0.10000E+01    0.75673E+04    0.11677E-43    0.56856E-52    0.11585E-49
+    4    1    0.23103E-06    0.10000E+01    0.61026E+04    0.66804E-43    0.83475E-51    0.63832E-49
+    4    1    0.23103E-06    0.10000E+01    0.49215E+04    0.47306E-42    0.18618E-49    0.38697E-48
+    4    1    0.23103E-06    0.10000E+01    0.39689E+04    0.48639E-41    0.46084E-48    0.33532E-47
+    4    1    0.23103E-06    0.10000E+01    0.32008E+04    0.18868E-38    0.34985E-45    0.12217E-44
+    4    1    0.23103E-06    0.10000E+01    0.25813E+04    0.11844E-29    0.46547E-36    0.74197E-36
+    4    1    0.23103E-06    0.10000E+01    0.20817E+04    0.17609E-13    0.25667E-19    0.10221E-19
+    4    1    0.23103E-06    0.10000E+01    0.16788E+04    0.48777E-08    0.28888E-13    0.25561E-14
+    4    1    0.23103E-06    0.10000E+01    0.13538E+04    0.88944E-08    0.10303E-12    0.40733E-14
+    4    1    0.23103E-06    0.10000E+01    0.10918E+04    0.16460E-07    0.36612E-12    0.65838E-14
+    4    1    0.23103E-06    0.10000E+01    0.88049E+03    0.30655E-07    0.13004E-11    0.10728E-13
+    4    1    0.23103E-06    0.10000E+01    0.71007E+03    0.57200E-07    0.46142E-11    0.17596E-13
+    4    1    0.23103E-06    0.10000E+01    0.57264E+03    0.10673E-06    0.16128E-10    0.29079E-13
+    4    1    0.23103E-06    0.10000E+01    0.46180E+03    0.19864E-06    0.53633E-10    0.48484E-13
+    4    1    0.23103E-06    0.10000E+01    0.37242E+03    0.36616E-06    0.16242E-09    0.81323E-13
+    4    1    0.23103E-06    0.10000E+01    0.30034E+03    0.65958E-06    0.43388E-09    0.13580E-12
+    4    1    0.23103E-06    0.10000E+01    0.24221E+03    0.11421E-05    0.10106E-08    0.22208E-12
+    4    1    0.23103E-06    0.10000E+01    0.19533E+03    0.17808E-05    0.19179E-08    0.33363E-12
+    4    1    0.23103E-06    0.10000E+01    0.15752E+03    0.17808E-05    0.19179E-08    0.33363E-12
+    4    1    0.40314E-06    0.10000E+01    0.80645E+05    0.10851E-52    0.81024E-64    0.99933E-59
+    4    1    0.40314E-06    0.10000E+01    0.65036E+05    0.91650E-52    0.12851E-62    0.84451E-58
+    4    1    0.40314E-06    0.10000E+01    0.52449E+05    0.77767E-51    0.17193E-61    0.71690E-57
+    4    1    0.40314E-06    0.10000E+01    0.42297E+05    0.58304E-50    0.23173E-60    0.53791E-56
+    4    1    0.40314E-06    0.10000E+01    0.34111E+05    0.41772E-49    0.31405E-59    0.38594E-55
+    4    1    0.40314E-06    0.10000E+01    0.27509E+05    0.29661E-48    0.41666E-58    0.27470E-54
+    4    1    0.40314E-06    0.10000E+01    0.22184E+05    0.20747E-47    0.53522E-57    0.19291E-53
+    4    1    0.40314E-06    0.10000E+01    0.17891E+05    0.14133E-46    0.66165E-56    0.13226E-52
+    4    1    0.40314E-06    0.10000E+01    0.14428E+05    0.93039E-46    0.78513E-55    0.87968E-52
+    4    1    0.40314E-06    0.10000E+01    0.11635E+05    0.58921E-45    0.88430E-54    0.56552E-51
+    4    1    0.40314E-06    0.10000E+01    0.93834E+04    0.35600E-44    0.93140E-53    0.34843E-50
+    4    1    0.40314E-06    0.10000E+01    0.75673E+04    0.20375E-43    0.99210E-52    0.20216E-49
+    4    1    0.40314E-06    0.10000E+01    0.61026E+04    0.11657E-42    0.14566E-50    0.11138E-48
+    4    1    0.40314E-06    0.10000E+01    0.49215E+04    0.82547E-42    0.32487E-49    0.67524E-48
+    4    1    0.40314E-06    0.10000E+01    0.39689E+04    0.84872E-41    0.80414E-48    0.58511E-47
+    4    1    0.40314E-06    0.10000E+01    0.32008E+04    0.32923E-38    0.61047E-45    0.21319E-44
+    4    1    0.40314E-06    0.10000E+01    0.25813E+04    0.20668E-29    0.81221E-36    0.12947E-35
+    4    1    0.40314E-06    0.10000E+01    0.20817E+04    0.30727E-13    0.44788E-19    0.17834E-19
+    4    1    0.40314E-06    0.10000E+01    0.16788E+04    0.85112E-08    0.50407E-13    0.44602E-14
+    4    1    0.40314E-06    0.10000E+01    0.13538E+04    0.15520E-07    0.17978E-12    0.71077E-14
+    4    1    0.40314E-06    0.10000E+01    0.10918E+04    0.28723E-07    0.63886E-12    0.11488E-13
+    4    1    0.40314E-06    0.10000E+01    0.88049E+03    0.53491E-07    0.22692E-11    0.18721E-13
+    4    1    0.40314E-06    0.10000E+01    0.71007E+03    0.99810E-07    0.80516E-11    0.30703E-13
+    4    1    0.40314E-06    0.10000E+01    0.57264E+03    0.18623E-06    0.28142E-10    0.50741E-13
+    4    1    0.40314E-06    0.10000E+01    0.46180E+03    0.34661E-06    0.93586E-10    0.84602E-13
+    4    1    0.40314E-06    0.10000E+01    0.37242E+03    0.63892E-06    0.28342E-09    0.14190E-12
+    4    1    0.40314E-06    0.10000E+01    0.30034E+03    0.11509E-05    0.75710E-09    0.23695E-12
+    4    1    0.40314E-06    0.10000E+01    0.24221E+03    0.19928E-05    0.17635E-08    0.38751E-12
+    4    1    0.40314E-06    0.10000E+01    0.19533E+03    0.31074E-05    0.33466E-08    0.58216E-12
+    4    1    0.40314E-06    0.10000E+01    0.15752E+03    0.31074E-05    0.33466E-08    0.58216E-12
+    4    1    0.70346E-06    0.10000E+01    0.80645E+05    0.18934E-52    0.14138E-63    0.17438E-58
+    4    1    0.70346E-06    0.10000E+01    0.65036E+05    0.15992E-51    0.22424E-62    0.14736E-57
+    4    1    0.70346E-06    0.10000E+01    0.52449E+05    0.13570E-50    0.30001E-61    0.12509E-56
+    4    1    0.70346E-06    0.10000E+01    0.42297E+05    0.10174E-49    0.40436E-60    0.93861E-56
+    4    1    0.70346E-06    0.10000E+01    0.34111E+05    0.72889E-49    0.54800E-59    0.67344E-55
+    4    1    0.70346E-06    0.10000E+01    0.27509E+05    0.51756E-48    0.72704E-58    0.47933E-54
+    4    1    0.70346E-06    0.10000E+01    0.22184E+05    0.36203E-47    0.93392E-57    0.33662E-53
+    4    1    0.70346E-06    0.10000E+01    0.17891E+05    0.24661E-46    0.11545E-55    0.23079E-52
+    4    1    0.70346E-06    0.10000E+01    0.14428E+05    0.16235E-45    0.13700E-54    0.15350E-51
+    4    1    0.70346E-06    0.10000E+01    0.11635E+05    0.10281E-44    0.15430E-53    0.98681E-51
+    4    1    0.70346E-06    0.10000E+01    0.93834E+04    0.62119E-44    0.16252E-52    0.60798E-50
+    4    1    0.70346E-06    0.10000E+01    0.75673E+04    0.35554E-43    0.17312E-51    0.35275E-49
+    4    1    0.70346E-06    0.10000E+01    0.61026E+04    0.20340E-42    0.25417E-50    0.19436E-48
+    4    1    0.70346E-06    0.10000E+01    0.49215E+04    0.14404E-41    0.56687E-49    0.11783E-47
+    4    1    0.70346E-06    0.10000E+01    0.39689E+04    0.14810E-40    0.14032E-47    0.10210E-46
+    4    1    0.70346E-06    0.10000E+01    0.32008E+04    0.57449E-38    0.10652E-44    0.37200E-44
+    4    1    0.70346E-06    0.10000E+01    0.25813E+04    0.36064E-29    0.14173E-35    0.22592E-35
+    4    1    0.70346E-06    0.10000E+01    0.20817E+04    0.53617E-13    0.78152E-19    0.31120E-19
+    4    1    0.70346E-06    0.10000E+01    0.16788E+04    0.14852E-07    0.87958E-13    0.77828E-14
+    4    1    0.70346E-06    0.10000E+01    0.13538E+04    0.27082E-07    0.31370E-12    0.12403E-13
+    4    1    0.70346E-06    0.10000E+01    0.10918E+04    0.50119E-07    0.11148E-11    0.20046E-13
+    4    1    0.70346E-06    0.10000E+01    0.88049E+03    0.93338E-07    0.39596E-11    0.32666E-13
+    4    1    0.70346E-06    0.10000E+01    0.71007E+03    0.17416E-06    0.14050E-10    0.53576E-13
+    4    1    0.70346E-06    0.10000E+01    0.57264E+03    0.32497E-06    0.49106E-10    0.88540E-13
+    4    1    0.70346E-06    0.10000E+01    0.46180E+03    0.60481E-06    0.16330E-09    0.14763E-12
+    4    1    0.70346E-06    0.10000E+01    0.37242E+03    0.11149E-05    0.49454E-09    0.24761E-12
+    4    1    0.70346E-06    0.10000E+01    0.30034E+03    0.20083E-05    0.13211E-08    0.41347E-12
+    4    1    0.70346E-06    0.10000E+01    0.24221E+03    0.34773E-05    0.30771E-08    0.67618E-12
+    4    1    0.70346E-06    0.10000E+01    0.19533E+03    0.54222E-05    0.58395E-08    0.10158E-11
+    4    1    0.70346E-06    0.10000E+01    0.15752E+03    0.54222E-05    0.58395E-08    0.10158E-11
+    4    1    0.12275E-05    0.10000E+01    0.80645E+05    0.33038E-52    0.24670E-63    0.30428E-58
+    4    1    0.12275E-05    0.10000E+01    0.65036E+05    0.27906E-51    0.39128E-62    0.25714E-57
+    4    1    0.12275E-05    0.10000E+01    0.52449E+05    0.23679E-50    0.52350E-61    0.21828E-56
+    4    1    0.12275E-05    0.10000E+01    0.42297E+05    0.17752E-49    0.70559E-60    0.16378E-55
+    4    1    0.12275E-05    0.10000E+01    0.34111E+05    0.12719E-48    0.95622E-59    0.11751E-54
+    4    1    0.12275E-05    0.10000E+01    0.27509E+05    0.90311E-48    0.12686E-57    0.83640E-54
+    4    1    0.12275E-05    0.10000E+01    0.22184E+05    0.63172E-47    0.16296E-56    0.58737E-53
+    4    1    0.12275E-05    0.10000E+01    0.17891E+05    0.43032E-46    0.20146E-55    0.40272E-52
+    4    1    0.12275E-05    0.10000E+01    0.14428E+05    0.28329E-45    0.23906E-54    0.26785E-51
+    4    1    0.12275E-05    0.10000E+01    0.11635E+05    0.17940E-44    0.26925E-53    0.17219E-50
+    4    1    0.12275E-05    0.10000E+01    0.93834E+04    0.10839E-43    0.28359E-52    0.10609E-49
+    4    1    0.12275E-05    0.10000E+01    0.75673E+04    0.62039E-43    0.30208E-51    0.61553E-49
+    4    1    0.12275E-05    0.10000E+01    0.61026E+04    0.35493E-42    0.44350E-50    0.33914E-48
+    4    1    0.12275E-05    0.10000E+01    0.49215E+04    0.25134E-41    0.98915E-49    0.20560E-47
+    4    1    0.12275E-05    0.10000E+01    0.39689E+04    0.25842E-40    0.24485E-47    0.17815E-46
+    4    1    0.12275E-05    0.10000E+01    0.32008E+04    0.10025E-37    0.18588E-44    0.64912E-44
+    4    1    0.12275E-05    0.10000E+01    0.25813E+04    0.62929E-29    0.24730E-35    0.39421E-35
+    4    1    0.12275E-05    0.10000E+01    0.20817E+04    0.93558E-13    0.13637E-18    0.54302E-19
+    4    1    0.12275E-05    0.10000E+01    0.16788E+04    0.25915E-07    0.15348E-12    0.13581E-13
+    4    1    0.12275E-05    0.10000E+01    0.13538E+04    0.47256E-07    0.54739E-12    0.21642E-13
+    4    1    0.12275E-05    0.10000E+01    0.10918E+04    0.87455E-07    0.19452E-11    0.34980E-13
+    4    1    0.12275E-05    0.10000E+01    0.88049E+03    0.16287E-06    0.69092E-11    0.57001E-13
+    4    1    0.12275E-05    0.10000E+01    0.71007E+03    0.30390E-06    0.24516E-10    0.93486E-13
+    4    1    0.12275E-05    0.10000E+01    0.57264E+03    0.56705E-06    0.85687E-10    0.15450E-12
+    4    1    0.12275E-05    0.10000E+01    0.46180E+03    0.10554E-05    0.28495E-09    0.25760E-12
+    4    1    0.12275E-05    0.10000E+01    0.37242E+03    0.19454E-05    0.86295E-09    0.43207E-12
+    4    1    0.12275E-05    0.10000E+01    0.30034E+03    0.35043E-05    0.23052E-08    0.72148E-12
+    4    1    0.12275E-05    0.10000E+01    0.24221E+03    0.60678E-05    0.53694E-08    0.11799E-11
+    4    1    0.12275E-05    0.10000E+01    0.19533E+03    0.94614E-05    0.10190E-07    0.17726E-11
+    4    1    0.12275E-05    0.10000E+01    0.15752E+03    0.94614E-05    0.10190E-07    0.17726E-11
+    4    1    0.21419E-05    0.10000E+01    0.80645E+05    0.57650E-52    0.43048E-63    0.53095E-58
+    4    1    0.21419E-05    0.10000E+01    0.65036E+05    0.48694E-51    0.68276E-62    0.44869E-57
+    4    1    0.21419E-05    0.10000E+01    0.52449E+05    0.41318E-50    0.91347E-61    0.38089E-56
+    4    1    0.21419E-05    0.10000E+01    0.42297E+05    0.30977E-49    0.12312E-59    0.28579E-55
+    4    1    0.21419E-05    0.10000E+01    0.34111E+05    0.22193E-48    0.16686E-58    0.20505E-54
+    4    1    0.21419E-05    0.10000E+01    0.27509E+05    0.15759E-47    0.22137E-57    0.14595E-53
+    4    1    0.21419E-05    0.10000E+01    0.22184E+05    0.11023E-46    0.28436E-56    0.10249E-52
+    4    1    0.21419E-05    0.10000E+01    0.17891E+05    0.75088E-46    0.35154E-55    0.70273E-52
+    4    1    0.21419E-05    0.10000E+01    0.14428E+05    0.49432E-45    0.41714E-54    0.46738E-51
+    4    1    0.21419E-05    0.10000E+01    0.11635E+05    0.31305E-44    0.46983E-53    0.30046E-50
+    4    1    0.21419E-05    0.10000E+01    0.93834E+04    0.18914E-43    0.49485E-52    0.18512E-49
+    4    1    0.21419E-05    0.10000E+01    0.75673E+04    0.10825E-42    0.52710E-51    0.10741E-48
+    4    1    0.21419E-05    0.10000E+01    0.61026E+04    0.61933E-42    0.77389E-50    0.59178E-48
+    4    1    0.21419E-05    0.10000E+01    0.49215E+04    0.43857E-41    0.17260E-48    0.35876E-47
+    4    1    0.21419E-05    0.10000E+01    0.39689E+04    0.45093E-40    0.42724E-47    0.31087E-46
+    4    1    0.21419E-05    0.10000E+01    0.32008E+04    0.17492E-37    0.32434E-44    0.11327E-43
+    4    1    0.21419E-05    0.10000E+01    0.25813E+04    0.10981E-28    0.43153E-35    0.68787E-35
+    4    1    0.21419E-05    0.10000E+01    0.20817E+04    0.16325E-12    0.23796E-18    0.94754E-19
+    4    1    0.21419E-05    0.10000E+01    0.16788E+04    0.45220E-07    0.26781E-12    0.23697E-13
+    4    1    0.21419E-05    0.10000E+01    0.13538E+04    0.82459E-07    0.95516E-12    0.37764E-13
+    4    1    0.21419E-05    0.10000E+01    0.10918E+04    0.15260E-06    0.33943E-11    0.61038E-13
+    4    1    0.21419E-05    0.10000E+01    0.88049E+03    0.28420E-06    0.12056E-10    0.99462E-13
+    4    1    0.21419E-05    0.10000E+01    0.71007E+03    0.53029E-06    0.42778E-10    0.16313E-12
+    4    1    0.21419E-05    0.10000E+01    0.57264E+03    0.98946E-06    0.14952E-09    0.26959E-12
+    4    1    0.21419E-05    0.10000E+01    0.46180E+03    0.18415E-05    0.49722E-09    0.44949E-12
+    4    1    0.21419E-05    0.10000E+01    0.37242E+03    0.33946E-05    0.15058E-08    0.75393E-12
+    4    1    0.21419E-05    0.10000E+01    0.30034E+03    0.61149E-05    0.40225E-08    0.12589E-11
+    4    1    0.21419E-05    0.10000E+01    0.24221E+03    0.10588E-04    0.93693E-08    0.20589E-11
+    4    1    0.21419E-05    0.10000E+01    0.19533E+03    0.16510E-04    0.17780E-07    0.30930E-11
+    4    1    0.21419E-05    0.10000E+01    0.15752E+03    0.16510E-04    0.17780E-07    0.30930E-11
+    4    1    0.37375E-05    0.10000E+01    0.80645E+05    0.10060E-51    0.75117E-63    0.92647E-58
+    4    1    0.37375E-05    0.10000E+01    0.65036E+05    0.84968E-51    0.11914E-61    0.78293E-57
+    4    1    0.37375E-05    0.10000E+01    0.52449E+05    0.72097E-50    0.15940E-60    0.66463E-56
+    4    1    0.37375E-05    0.10000E+01    0.42297E+05    0.54053E-49    0.21484E-59    0.49869E-55
+    4    1    0.37375E-05    0.10000E+01    0.34111E+05    0.38726E-48    0.29115E-58    0.35780E-54
+    4    1    0.37375E-05    0.10000E+01    0.27509E+05    0.27498E-47    0.38628E-57    0.25467E-53
+    4    1    0.37375E-05    0.10000E+01    0.22184E+05    0.19235E-46    0.49619E-56    0.17884E-52
+    4    1    0.37375E-05    0.10000E+01    0.17891E+05    0.13102E-45    0.61341E-55    0.12262E-51
+    4    1    0.37375E-05    0.10000E+01    0.14428E+05    0.86256E-45    0.72789E-54    0.81554E-51
+    4    1    0.37375E-05    0.10000E+01    0.11635E+05    0.54625E-44    0.81982E-53    0.52429E-50
+    4    1    0.37375E-05    0.10000E+01    0.93834E+04    0.33004E-43    0.86349E-52    0.32302E-49
+    4    1    0.37375E-05    0.10000E+01    0.75673E+04    0.18890E-42    0.91977E-51    0.18742E-48
+    4    1    0.37375E-05    0.10000E+01    0.61026E+04    0.10807E-41    0.13504E-49    0.10326E-47
+    4    1    0.37375E-05    0.10000E+01    0.49215E+04    0.76528E-41    0.30118E-48    0.62601E-47
+    4    1    0.37375E-05    0.10000E+01    0.39689E+04    0.78684E-40    0.74551E-47    0.54244E-46
+    4    1    0.37375E-05    0.10000E+01    0.32008E+04    0.30523E-37    0.56596E-44    0.19764E-43
+    4    1    0.37375E-05    0.10000E+01    0.25813E+04    0.19161E-28    0.75300E-35    0.12003E-34
+    4    1    0.37375E-05    0.10000E+01    0.20817E+04    0.28487E-12    0.41522E-18    0.16534E-18
+    4    1    0.37375E-05    0.10000E+01    0.16788E+04    0.78907E-07    0.46732E-12    0.41350E-13
+    4    1    0.37375E-05    0.10000E+01    0.13538E+04    0.14389E-06    0.16667E-11    0.65895E-13
+    4    1    0.37375E-05    0.10000E+01    0.10918E+04    0.26628E-06    0.59228E-11    0.10651E-12
+    4    1    0.37375E-05    0.10000E+01    0.88049E+03    0.49591E-06    0.21037E-10    0.17356E-12
+    4    1    0.37375E-05    0.10000E+01    0.71007E+03    0.92533E-06    0.74645E-10    0.28465E-12
+    4    1    0.37375E-05    0.10000E+01    0.57264E+03    0.17266E-05    0.26090E-09    0.47042E-12
+    4    1    0.37375E-05    0.10000E+01    0.46180E+03    0.32134E-05    0.86762E-09    0.78433E-12
+    4    1    0.37375E-05    0.10000E+01    0.37242E+03    0.59234E-05    0.26275E-08    0.13156E-11
+    4    1    0.37375E-05    0.10000E+01    0.30034E+03    0.10670E-04    0.70190E-08    0.21968E-11
+    4    1    0.37375E-05    0.10000E+01    0.24221E+03    0.18475E-04    0.16349E-07    0.35926E-11
+    4    1    0.37375E-05    0.10000E+01    0.19533E+03    0.28808E-04    0.31026E-07    0.53971E-11
+    4    1    0.37375E-05    0.10000E+01    0.15752E+03    0.28808E-04    0.31026E-07    0.53971E-11
+    4    1    0.65217E-05    0.10000E+01    0.80645E+05    0.17553E-51    0.13107E-62    0.16166E-57
+    4    1    0.65217E-05    0.10000E+01    0.65036E+05    0.14826E-50    0.20789E-61    0.13662E-56
+    4    1    0.65217E-05    0.10000E+01    0.52449E+05    0.12581E-49    0.27814E-60    0.11597E-55
+    4    1    0.65217E-05    0.10000E+01    0.42297E+05    0.94319E-49    0.37488E-59    0.87018E-55
+    4    1    0.65217E-05    0.10000E+01    0.34111E+05    0.67575E-48    0.50804E-58    0.62434E-54
+    4    1    0.65217E-05    0.10000E+01    0.27509E+05    0.47982E-47    0.67403E-57    0.44438E-53
+    4    1    0.65217E-05    0.10000E+01    0.22184E+05    0.33563E-46    0.86583E-56    0.31207E-52
+    4    1    0.65217E-05    0.10000E+01    0.17891E+05    0.22863E-45    0.10704E-54    0.21397E-51
+    4    1    0.65217E-05    0.10000E+01    0.14428E+05    0.15051E-44    0.12701E-53    0.14231E-50
+    4    1    0.65217E-05    0.10000E+01    0.11635E+05    0.95317E-44    0.14305E-52    0.91486E-50
+    4    1    0.65217E-05    0.10000E+01    0.93834E+04    0.57590E-43    0.15067E-51    0.56365E-49
+    4    1    0.65217E-05    0.10000E+01    0.75673E+04    0.32961E-42    0.16049E-50    0.32703E-48
+    4    1    0.65217E-05    0.10000E+01    0.61026E+04    0.18857E-41    0.23563E-49    0.18018E-47
+    4    1    0.65217E-05    0.10000E+01    0.49215E+04    0.13354E-40    0.52554E-48    0.10924E-46
+    4    1    0.65217E-05    0.10000E+01    0.39689E+04    0.13730E-39    0.13009E-46    0.94653E-46
+    4    1    0.65217E-05    0.10000E+01    0.32008E+04    0.53260E-37    0.98757E-44    0.34488E-43
+    4    1    0.65217E-05    0.10000E+01    0.25813E+04    0.33434E-28    0.13139E-34    0.20944E-34
+    4    1    0.65217E-05    0.10000E+01    0.20817E+04    0.49708E-12    0.72454E-18    0.28851E-18
+    4    1    0.65217E-05    0.10000E+01    0.16788E+04    0.13769E-06    0.81545E-12    0.72153E-13
+    4    1    0.65217E-05    0.10000E+01    0.13538E+04    0.25107E-06    0.29083E-11    0.11498E-12
+    4    1    0.65217E-05    0.10000E+01    0.10918E+04    0.46465E-06    0.10335E-10    0.18585E-12
+    4    1    0.65217E-05    0.10000E+01    0.88049E+03    0.86533E-06    0.36709E-10    0.30284E-12
+    4    1    0.65217E-05    0.10000E+01    0.71007E+03    0.16146E-05    0.13025E-09    0.49669E-12
+    4    1    0.65217E-05    0.10000E+01    0.57264E+03    0.30127E-05    0.45526E-09    0.82085E-12
+    4    1    0.65217E-05    0.10000E+01    0.46180E+03    0.56071E-05    0.15140E-08    0.13686E-11
+    4    1    0.65217E-05    0.10000E+01    0.37242E+03    0.10336E-04    0.45849E-08    0.22956E-11
+    4    1    0.65217E-05    0.10000E+01    0.30034E+03    0.18619E-04    0.12248E-07    0.38332E-11
+    4    1    0.65217E-05    0.10000E+01    0.24221E+03    0.32238E-04    0.28528E-07    0.62688E-11
+    4    1    0.65217E-05    0.10000E+01    0.19533E+03    0.50269E-04    0.54138E-07    0.94177E-11
+    4    1    0.65217E-05    0.10000E+01    0.15752E+03    0.50269E-04    0.54138E-07    0.94177E-11
+    4    1    0.11380E-04    0.10000E+01    0.80645E+05    0.30630E-51    0.22872E-62    0.28209E-57
+    4    1    0.11380E-04    0.10000E+01    0.65036E+05    0.25871E-50    0.36275E-61    0.23839E-56
+    4    1    0.11380E-04    0.10000E+01    0.52449E+05    0.21952E-49    0.48533E-60    0.20237E-55
+    4    1    0.11380E-04    0.10000E+01    0.42297E+05    0.16458E-48    0.65414E-59    0.15184E-54
+    4    1    0.11380E-04    0.10000E+01    0.34111E+05    0.11791E-47    0.88650E-58    0.10894E-53
+    4    1    0.11380E-04    0.10000E+01    0.27509E+05    0.83726E-47    0.11761E-56    0.77542E-53
+    4    1    0.11380E-04    0.10000E+01    0.22184E+05    0.58566E-46    0.15108E-55    0.54455E-52
+    4    1    0.11380E-04    0.10000E+01    0.17891E+05    0.39894E-45    0.18677E-54    0.37336E-51
+    4    1    0.11380E-04    0.10000E+01    0.14428E+05    0.26263E-44    0.22163E-53    0.24832E-50
+    4    1    0.11380E-04    0.10000E+01    0.11635E+05    0.16632E-43    0.24962E-52    0.15964E-49
+    4    1    0.11380E-04    0.10000E+01    0.93834E+04    0.10049E-42    0.26292E-51    0.98354E-49
+    4    1    0.11380E-04    0.10000E+01    0.75673E+04    0.57516E-42    0.28005E-50    0.57065E-48
+    4    1    0.11380E-04    0.10000E+01    0.61026E+04    0.32905E-41    0.41117E-49    0.31441E-47
+    4    1    0.11380E-04    0.10000E+01    0.49215E+04    0.23301E-40    0.91703E-48    0.19061E-46
+    4    1    0.11380E-04    0.10000E+01    0.39689E+04    0.23958E-39    0.22699E-46    0.16516E-45
+    4    1    0.11380E-04    0.10000E+01    0.32008E+04    0.92936E-37    0.17232E-43    0.60179E-43
+    4    1    0.11380E-04    0.10000E+01    0.25813E+04    0.58341E-28    0.22927E-34    0.36547E-34
+    4    1    0.11380E-04    0.10000E+01    0.20817E+04    0.86737E-12    0.12643E-17    0.50343E-18
+    4    1    0.11380E-04    0.10000E+01    0.16788E+04    0.24026E-06    0.14229E-11    0.12590E-12
+    4    1    0.11380E-04    0.10000E+01    0.13538E+04    0.43811E-06    0.50748E-11    0.20064E-12
+    4    1    0.11380E-04    0.10000E+01    0.10918E+04    0.81078E-06    0.18034E-10    0.32429E-12
+    4    1    0.11380E-04    0.10000E+01    0.88049E+03    0.15099E-05    0.64054E-10    0.52845E-12
+    4    1    0.11380E-04    0.10000E+01    0.71007E+03    0.28175E-05    0.22728E-09    0.86670E-12
+    4    1    0.11380E-04    0.10000E+01    0.57264E+03    0.52570E-05    0.79440E-09    0.14323E-11
+    4    1    0.11380E-04    0.10000E+01    0.46180E+03    0.97841E-05    0.26418E-08    0.23882E-11
+    4    1    0.11380E-04    0.10000E+01    0.37242E+03    0.18036E-04    0.80003E-08    0.40057E-11
+    4    1    0.11380E-04    0.10000E+01    0.30034E+03    0.32488E-04    0.21371E-07    0.66888E-11
+    4    1    0.11380E-04    0.10000E+01    0.24221E+03    0.56254E-04    0.49779E-07    0.10939E-10
+    4    1    0.11380E-04    0.10000E+01    0.19533E+03    0.87716E-04    0.94467E-07    0.16433E-10
+    4    1    0.11380E-04    0.10000E+01    0.15752E+03    0.87716E-04    0.94467E-07    0.16433E-10
+    4    1    0.19857E-04    0.10000E+01    0.80645E+05    0.53447E-51    0.39910E-62    0.49223E-57
+    4    1    0.19857E-04    0.10000E+01    0.65036E+05    0.45144E-50    0.63298E-61    0.41597E-56
+    4    1    0.19857E-04    0.10000E+01    0.52449E+05    0.38305E-49    0.84687E-60    0.35312E-55
+    4    1    0.19857E-04    0.10000E+01    0.42297E+05    0.28718E-48    0.11414E-58    0.26495E-54
+    4    1    0.19857E-04    0.10000E+01    0.34111E+05    0.20575E-47    0.15469E-57    0.19010E-53
+    4    1    0.19857E-04    0.10000E+01    0.27509E+05    0.14610E-46    0.20523E-56    0.13531E-52
+    4    1    0.19857E-04    0.10000E+01    0.22184E+05    0.10219E-45    0.26363E-55    0.95020E-52
+    4    1    0.19857E-04    0.10000E+01    0.17891E+05    0.69613E-45    0.32590E-54    0.65149E-51
+    4    1    0.19857E-04    0.10000E+01    0.14428E+05    0.45828E-44    0.38673E-53    0.43330E-50
+    4    1    0.19857E-04    0.10000E+01    0.11635E+05    0.29022E-43    0.43557E-52    0.27856E-49
+    4    1    0.19857E-04    0.10000E+01    0.93834E+04    0.17535E-42    0.45877E-51    0.17162E-48
+    4    1    0.19857E-04    0.10000E+01    0.75673E+04    0.10036E-41    0.48867E-50    0.99575E-48
+    4    1    0.19857E-04    0.10000E+01    0.61026E+04    0.57417E-41    0.71746E-49    0.54863E-47
+    4    1    0.19857E-04    0.10000E+01    0.49215E+04    0.40660E-40    0.16002E-47    0.33260E-46
+    4    1    0.19857E-04    0.10000E+01    0.39689E+04    0.41805E-39    0.39609E-46    0.28820E-45
+    4    1    0.19857E-04    0.10000E+01    0.32008E+04    0.16217E-36    0.30070E-43    0.10501E-42
+    4    1    0.19857E-04    0.10000E+01    0.25813E+04    0.10180E-27    0.40007E-34    0.63772E-34
+    4    1    0.19857E-04    0.10000E+01    0.20817E+04    0.15135E-11    0.22061E-17    0.87845E-18
+    4    1    0.19857E-04    0.10000E+01    0.16788E+04    0.41923E-06    0.24829E-11    0.21969E-12
+    4    1    0.19857E-04    0.10000E+01    0.13538E+04    0.76447E-06    0.88552E-11    0.35010E-12
+    4    1    0.19857E-04    0.10000E+01    0.10918E+04    0.14148E-05    0.31468E-10    0.56587E-12
+    4    1    0.19857E-04    0.10000E+01    0.88049E+03    0.26348E-05    0.11177E-09    0.92211E-12
+    4    1    0.19857E-04    0.10000E+01    0.71007E+03    0.49163E-05    0.39659E-09    0.15123E-11
+    4    1    0.19857E-04    0.10000E+01    0.57264E+03    0.91732E-05    0.13862E-08    0.24993E-11
+    4    1    0.19857E-04    0.10000E+01    0.46180E+03    0.17073E-04    0.46097E-08    0.41672E-11
+    4    1    0.19857E-04    0.10000E+01    0.37242E+03    0.31471E-04    0.13960E-07    0.69896E-11
+    4    1    0.19857E-04    0.10000E+01    0.30034E+03    0.56690E-04    0.37292E-07    0.11672E-10
+    4    1    0.19857E-04    0.10000E+01    0.24221E+03    0.98159E-04    0.86862E-07    0.19087E-10
+    4    1    0.19857E-04    0.10000E+01    0.19533E+03    0.15306E-03    0.16484E-06    0.28675E-10
+    4    1    0.19857E-04    0.10000E+01    0.15752E+03    0.15306E-03    0.16484E-06    0.28675E-10
+    4    1    0.34650E-04    0.10000E+01    0.80645E+05    0.93261E-51    0.69640E-62    0.85892E-57
+    4    1    0.34650E-04    0.10000E+01    0.65036E+05    0.78773E-50    0.11045E-60    0.72585E-56
+    4    1    0.34650E-04    0.10000E+01    0.52449E+05    0.66841E-49    0.14777E-59    0.61617E-55
+    4    1    0.34650E-04    0.10000E+01    0.42297E+05    0.50112E-48    0.19917E-58    0.46233E-54
+    4    1    0.34650E-04    0.10000E+01    0.34111E+05    0.35903E-47    0.26992E-57    0.33171E-53
+    4    1    0.34650E-04    0.10000E+01    0.27509E+05    0.25493E-46    0.35811E-56    0.23610E-52
+    4    1    0.34650E-04    0.10000E+01    0.22184E+05    0.17832E-45    0.46002E-55    0.16580E-51
+    4    1    0.34650E-04    0.10000E+01    0.17891E+05    0.12147E-44    0.56868E-54    0.11368E-50
+    4    1    0.34650E-04    0.10000E+01    0.14428E+05    0.79967E-44    0.67482E-53    0.75608E-50
+    4    1    0.34650E-04    0.10000E+01    0.11635E+05    0.50642E-43    0.76005E-52    0.48607E-49
+    4    1    0.34650E-04    0.10000E+01    0.93834E+04    0.30598E-42    0.80053E-51    0.29947E-48
+    4    1    0.34650E-04    0.10000E+01    0.75673E+04    0.17512E-41    0.85271E-50    0.17375E-47
+    4    1    0.34650E-04    0.10000E+01    0.61026E+04    0.10019E-40    0.12519E-48    0.95732E-47
+    4    1    0.34650E-04    0.10000E+01    0.49215E+04    0.70948E-40    0.27922E-47    0.58037E-46
+    4    1    0.34650E-04    0.10000E+01    0.39689E+04    0.72947E-39    0.69116E-46    0.50289E-45
+    4    1    0.34650E-04    0.10000E+01    0.32008E+04    0.28297E-36    0.52470E-43    0.18323E-42
+    4    1    0.34650E-04    0.10000E+01    0.25813E+04    0.17764E-27    0.69809E-34    0.11128E-33
+    4    1    0.34650E-04    0.10000E+01    0.20817E+04    0.26410E-11    0.38495E-17    0.15328E-17
+    4    1    0.34650E-04    0.10000E+01    0.16788E+04    0.73153E-06    0.43325E-11    0.38335E-12
+    4    1    0.34650E-04    0.10000E+01    0.13538E+04    0.13339E-05    0.15452E-10    0.61091E-12
+    4    1    0.34650E-04    0.10000E+01    0.10918E+04    0.24687E-05    0.54910E-10    0.98742E-12
+    4    1    0.34650E-04    0.10000E+01    0.88049E+03    0.45975E-05    0.19503E-09    0.16090E-11
+    4    1    0.34650E-04    0.10000E+01    0.71007E+03    0.85786E-05    0.69203E-09    0.26389E-11
+    4    1    0.34650E-04    0.10000E+01    0.57264E+03    0.16007E-04    0.24188E-08    0.43612E-11
+    4    1    0.34650E-04    0.10000E+01    0.46180E+03    0.29791E-04    0.80437E-08    0.72715E-11
+    4    1    0.34650E-04    0.10000E+01    0.37242E+03    0.54915E-04    0.24359E-07    0.12196E-10
+    4    1    0.34650E-04    0.10000E+01    0.30034E+03    0.98921E-04    0.65072E-07    0.20366E-10
+    4    1    0.34650E-04    0.10000E+01    0.24221E+03    0.17128E-03    0.15157E-06    0.33306E-10
+    4    1    0.34650E-04    0.10000E+01    0.19533E+03    0.26708E-03    0.28763E-06    0.50036E-10
+    4    1    0.34650E-04    0.10000E+01    0.15752E+03    0.26708E-03    0.28763E-06    0.50036E-10
+    4    1    0.60462E-04    0.10000E+01    0.80645E+05    0.16274E-50    0.12152E-61    0.14988E-56
+    4    1    0.60462E-04    0.10000E+01    0.65036E+05    0.13745E-49    0.19273E-60    0.12666E-55
+    4    1    0.60462E-04    0.10000E+01    0.52449E+05    0.11663E-48    0.25786E-59    0.10752E-54
+    4    1    0.60462E-04    0.10000E+01    0.42297E+05    0.87442E-48    0.34755E-58    0.80673E-54
+    4    1    0.60462E-04    0.10000E+01    0.34111E+05    0.62648E-47    0.47100E-57    0.57882E-53
+    4    1    0.60462E-04    0.10000E+01    0.27509E+05    0.44484E-46    0.62489E-56    0.41198E-52
+    4    1    0.60462E-04    0.10000E+01    0.22184E+05    0.31116E-45    0.80270E-55    0.28932E-51
+    4    1    0.60462E-04    0.10000E+01    0.17891E+05    0.21196E-44    0.99232E-54    0.19837E-50
+    4    1    0.60462E-04    0.10000E+01    0.14428E+05    0.13954E-43    0.11775E-52    0.13193E-49
+    4    1    0.60462E-04    0.10000E+01    0.11635E+05    0.88367E-43    0.13262E-51    0.84815E-49
+    4    1    0.60462E-04    0.10000E+01    0.93834E+04    0.53391E-42    0.13969E-50    0.52256E-48
+    4    1    0.60462E-04    0.10000E+01    0.75673E+04    0.30558E-41    0.14879E-49    0.30319E-47
+    4    1    0.60462E-04    0.10000E+01    0.61026E+04    0.17483E-40    0.21845E-48    0.16705E-46
+    4    1    0.60462E-04    0.10000E+01    0.49215E+04    0.12380E-39    0.48722E-47    0.10127E-45
+    4    1    0.60462E-04    0.10000E+01    0.39689E+04    0.12729E-38    0.12060E-45    0.87752E-45
+    4    1    0.60462E-04    0.10000E+01    0.32008E+04    0.49377E-36    0.91556E-43    0.31973E-42
+    4    1    0.60462E-04    0.10000E+01    0.25813E+04    0.30997E-27    0.12181E-33    0.19417E-33
+    4    1    0.60462E-04    0.10000E+01    0.20817E+04    0.46083E-11    0.67171E-17    0.26747E-17
+    4    1    0.60462E-04    0.10000E+01    0.16788E+04    0.12765E-05    0.75599E-11    0.66893E-12
+    4    1    0.60462E-04    0.10000E+01    0.13538E+04    0.23277E-05    0.26962E-10    0.10660E-11
+    4    1    0.60462E-04    0.10000E+01    0.10918E+04    0.43077E-05    0.95814E-10    0.17230E-11
+    4    1    0.60462E-04    0.10000E+01    0.88049E+03    0.80224E-05    0.34032E-09    0.28076E-11
+    4    1    0.60462E-04    0.10000E+01    0.71007E+03    0.14969E-04    0.12075E-08    0.46048E-11
+    4    1    0.60462E-04    0.10000E+01    0.57264E+03    0.27931E-04    0.42207E-08    0.76100E-11
+    4    1    0.60462E-04    0.10000E+01    0.46180E+03    0.51983E-04    0.14036E-07    0.12688E-10
+    4    1    0.60462E-04    0.10000E+01    0.37242E+03    0.95823E-04    0.42506E-07    0.21282E-10
+    4    1    0.60462E-04    0.10000E+01    0.30034E+03    0.17261E-03    0.11355E-06    0.35538E-10
+    4    1    0.60462E-04    0.10000E+01    0.24221E+03    0.29888E-03    0.26448E-06    0.58118E-10
+    4    1    0.60462E-04    0.10000E+01    0.19533E+03    0.46603E-03    0.50190E-06    0.87310E-10
+    4    1    0.60462E-04    0.10000E+01    0.15752E+03    0.46603E-03    0.50190E-06    0.87310E-10
+    4    1    0.10550E-03    0.10000E+01    0.80645E+05    0.28396E-50    0.21204E-61    0.26152E-56
+    4    1    0.10550E-03    0.10000E+01    0.65036E+05    0.23985E-49    0.33630E-60    0.22101E-55
+    4    1    0.10550E-03    0.10000E+01    0.52449E+05    0.20352E-48    0.44994E-59    0.18761E-54
+    4    1    0.10550E-03    0.10000E+01    0.42297E+05    0.15258E-47    0.60645E-58    0.14077E-53
+    4    1    0.10550E-03    0.10000E+01    0.34111E+05    0.10932E-46    0.82187E-57    0.10100E-52
+    4    1    0.10550E-03    0.10000E+01    0.27509E+05    0.77622E-46    0.10904E-55    0.71888E-52
+    4    1    0.10550E-03    0.10000E+01    0.22184E+05    0.54296E-45    0.14007E-54    0.50484E-51
+    4    1    0.10550E-03    0.10000E+01    0.17891E+05    0.36985E-44    0.17315E-53    0.34614E-50
+    4    1    0.10550E-03    0.10000E+01    0.14428E+05    0.24348E-43    0.20547E-52    0.23021E-49
+    4    1    0.10550E-03    0.10000E+01    0.11635E+05    0.15420E-42    0.23142E-51    0.14800E-48
+    4    1    0.10550E-03    0.10000E+01    0.93834E+04    0.93164E-42    0.24375E-50    0.91183E-48
+    4    1    0.10550E-03    0.10000E+01    0.75673E+04    0.53322E-41    0.25963E-49    0.52904E-47
+    4    1    0.10550E-03    0.10000E+01    0.61026E+04    0.30506E-40    0.38119E-48    0.29149E-46
+    4    1    0.10550E-03    0.10000E+01    0.49215E+04    0.21602E-39    0.85017E-47    0.17671E-45
+    4    1    0.10550E-03    0.10000E+01    0.39689E+04    0.22211E-38    0.21044E-45    0.15312E-44
+    4    1    0.10550E-03    0.10000E+01    0.32008E+04    0.86160E-36    0.15976E-42    0.55791E-42
+    4    1    0.10550E-03    0.10000E+01    0.25813E+04    0.54087E-27    0.21256E-33    0.33882E-33
+    4    1    0.10550E-03    0.10000E+01    0.20817E+04    0.80413E-11    0.11721E-16    0.46672E-17
+    4    1    0.10550E-03    0.10000E+01    0.16788E+04    0.22274E-05    0.13192E-10    0.11672E-11
+    4    1    0.10550E-03    0.10000E+01    0.13538E+04    0.40616E-05    0.47048E-10    0.18601E-11
+    4    1    0.10550E-03    0.10000E+01    0.10918E+04    0.75167E-05    0.16719E-09    0.30065E-11
+    4    1    0.10550E-03    0.10000E+01    0.88049E+03    0.13999E-04    0.59384E-09    0.48992E-11
+    4    1    0.10550E-03    0.10000E+01    0.71007E+03    0.26120E-04    0.21071E-08    0.80351E-11
+    4    1    0.10550E-03    0.10000E+01    0.57264E+03    0.48737E-04    0.73648E-08    0.13279E-10
+    4    1    0.10550E-03    0.10000E+01    0.46180E+03    0.90707E-04    0.24491E-07    0.22140E-10
+    4    1    0.10550E-03    0.10000E+01    0.37242E+03    0.16721E-03    0.74170E-07    0.37136E-10
+    4    1    0.10550E-03    0.10000E+01    0.30034E+03    0.30120E-03    0.19813E-06    0.62011E-10
+    4    1    0.10550E-03    0.10000E+01    0.24221E+03    0.52152E-03    0.46150E-06    0.10141E-09
+    4    1    0.10550E-03    0.10000E+01    0.19533E+03    0.81320E-03    0.87579E-06    0.15235E-09
+    4    1    0.10550E-03    0.10000E+01    0.15752E+03    0.81320E-03    0.87579E-06    0.15235E-09
+    4    1    0.18409E-03    0.10000E+01    0.80645E+05    0.49550E-50    0.37000E-61    0.45635E-56
+    4    1    0.18409E-03    0.10000E+01    0.65036E+05    0.41852E-49    0.58683E-60    0.38564E-55
+    4    1    0.18409E-03    0.10000E+01    0.52449E+05    0.35513E-48    0.78513E-59    0.32737E-54
+    4    1    0.18409E-03    0.10000E+01    0.42297E+05    0.26624E-47    0.10582E-57    0.24564E-53
+    4    1    0.18409E-03    0.10000E+01    0.34111E+05    0.19075E-46    0.14341E-56    0.17624E-52
+    4    1    0.18409E-03    0.10000E+01    0.27509E+05    0.13545E-45    0.19027E-55    0.12544E-51
+    4    1    0.18409E-03    0.10000E+01    0.22184E+05    0.94743E-45    0.24441E-54    0.88092E-51
+    4    1    0.18409E-03    0.10000E+01    0.17891E+05    0.64537E-44    0.30214E-53    0.60399E-50
+    4    1    0.18409E-03    0.10000E+01    0.14428E+05    0.42486E-43    0.35853E-52    0.40171E-49
+    4    1    0.18409E-03    0.10000E+01    0.11635E+05    0.26906E-42    0.40381E-51    0.25825E-48
+    4    1    0.18409E-03    0.10000E+01    0.93834E+04    0.16257E-41    0.42532E-50    0.15911E-47
+    4    1    0.18409E-03    0.10000E+01    0.75673E+04    0.93044E-41    0.45304E-49    0.92315E-47
+    4    1    0.18409E-03    0.10000E+01    0.61026E+04    0.53231E-40    0.66515E-48    0.50863E-46
+    4    1    0.18409E-03    0.10000E+01    0.49215E+04    0.37695E-39    0.14835E-46    0.30835E-45
+    4    1    0.18409E-03    0.10000E+01    0.39689E+04    0.38757E-38    0.36721E-45    0.26719E-44
+    4    1    0.18409E-03    0.10000E+01    0.32008E+04    0.15034E-35    0.27877E-42    0.97352E-42
+    4    1    0.18409E-03    0.10000E+01    0.25813E+04    0.94379E-27    0.37090E-33    0.59122E-33
+    4    1    0.18409E-03    0.10000E+01    0.20817E+04    0.14032E-10    0.20452E-16    0.81440E-17
+    4    1    0.18409E-03    0.10000E+01    0.16788E+04    0.38867E-05    0.23019E-10    0.20368E-11
+    4    1    0.18409E-03    0.10000E+01    0.13538E+04    0.70873E-05    0.82096E-10    0.32458E-11
+    4    1    0.18409E-03    0.10000E+01    0.10918E+04    0.13116E-04    0.29174E-09    0.52462E-11
+    4    1    0.18409E-03    0.10000E+01    0.88049E+03    0.24427E-04    0.10362E-08    0.85487E-11
+    4    1    0.18409E-03    0.10000E+01    0.71007E+03    0.45578E-04    0.36768E-08    0.14021E-10
+    4    1    0.18409E-03    0.10000E+01    0.57264E+03    0.85044E-04    0.12851E-07    0.23171E-10
+    4    1    0.18409E-03    0.10000E+01    0.46180E+03    0.15828E-03    0.42736E-07    0.38633E-10
+    4    1    0.18409E-03    0.10000E+01    0.37242E+03    0.29176E-03    0.12942E-06    0.64800E-10
+    4    1    0.18409E-03    0.10000E+01    0.30034E+03    0.52557E-03    0.34573E-06    0.10821E-09
+    4    1    0.18409E-03    0.10000E+01    0.24221E+03    0.91002E-03    0.80529E-06    0.17696E-09
+    4    1    0.18409E-03    0.10000E+01    0.19533E+03    0.14190E-02    0.15282E-05    0.26584E-09
+    4    1    0.18409E-03    0.10000E+01    0.15752E+03    0.14190E-02    0.15282E-05    0.26584E-09
+    4    1    0.32123E-03    0.10000E+01    0.80645E+05    0.86462E-50    0.64562E-61    0.79629E-56
+    4    1    0.32123E-03    0.10000E+01    0.65036E+05    0.73030E-49    0.10240E-59    0.67293E-55
+    4    1    0.32123E-03    0.10000E+01    0.52449E+05    0.61967E-48    0.13700E-58    0.57125E-54
+    4    1    0.32123E-03    0.10000E+01    0.42297E+05    0.46458E-47    0.18465E-57    0.42862E-53
+    4    1    0.32123E-03    0.10000E+01    0.34111E+05    0.33285E-46    0.25024E-56    0.30753E-52
+    4    1    0.32123E-03    0.10000E+01    0.27509E+05    0.23634E-45    0.33200E-55    0.21889E-51
+    4    1    0.32123E-03    0.10000E+01    0.22184E+05    0.16532E-44    0.42648E-54    0.15372E-50
+    4    1    0.32123E-03    0.10000E+01    0.17891E+05    0.11261E-43    0.52722E-53    0.10539E-49
+    4    1    0.32123E-03    0.10000E+01    0.14428E+05    0.74136E-43    0.62562E-52    0.70095E-49
+    4    1    0.32123E-03    0.10000E+01    0.11635E+05    0.46950E-42    0.70463E-51    0.45063E-48
+    4    1    0.32123E-03    0.10000E+01    0.93834E+04    0.28367E-41    0.74216E-50    0.27764E-47
+    4    1    0.32123E-03    0.10000E+01    0.75673E+04    0.16236E-40    0.79053E-49    0.16108E-46
+    4    1    0.32123E-03    0.10000E+01    0.61026E+04    0.92885E-40    0.11607E-47    0.88752E-46
+    4    1    0.32123E-03    0.10000E+01    0.49215E+04    0.65775E-39    0.25886E-46    0.53805E-45
+    4    1    0.32123E-03    0.10000E+01    0.39689E+04    0.67628E-38    0.64076E-45    0.46623E-44
+    4    1    0.32123E-03    0.10000E+01    0.32008E+04    0.26234E-35    0.48644E-42    0.16987E-41
+    4    1    0.32123E-03    0.10000E+01    0.25813E+04    0.16469E-26    0.64720E-33    0.10316E-32
+    4    1    0.32123E-03    0.10000E+01    0.20817E+04    0.24484E-10    0.35688E-16    0.14211E-16
+    4    1    0.32123E-03    0.10000E+01    0.16788E+04    0.67820E-05    0.40166E-10    0.35540E-11
+    4    1    0.32123E-03    0.10000E+01    0.13538E+04    0.12367E-04    0.14325E-09    0.56636E-11
+    4    1    0.32123E-03    0.10000E+01    0.10918E+04    0.22887E-04    0.50906E-09    0.91542E-11
+    4    1    0.32123E-03    0.10000E+01    0.88049E+03    0.42623E-04    0.18081E-08    0.14917E-10
+    4    1    0.32123E-03    0.10000E+01    0.71007E+03    0.79532E-04    0.64157E-08    0.24465E-10
+    4    1    0.32123E-03    0.10000E+01    0.57264E+03    0.14840E-03    0.22424E-07    0.40432E-10
+    4    1    0.32123E-03    0.10000E+01    0.46180E+03    0.27619E-03    0.74572E-07    0.67413E-10
+    4    1    0.32123E-03    0.10000E+01    0.37242E+03    0.50911E-03    0.22583E-06    0.11307E-09
+    4    1    0.32123E-03    0.10000E+01    0.30034E+03    0.91708E-03    0.60328E-06    0.18881E-09
+    4    1    0.32123E-03    0.10000E+01    0.24221E+03    0.15879E-02    0.14052E-05    0.30878E-09
+    4    1    0.32123E-03    0.10000E+01    0.19533E+03    0.24760E-02    0.26666E-05    0.46388E-09
+    4    1    0.32123E-03    0.10000E+01    0.15752E+03    0.24760E-02    0.26666E-05    0.46388E-09
+    4    2    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.30142E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    2    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.52597E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    2    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.91778E-08    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    2    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.16015E-07    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    4    2    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.27945E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    4    2    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.48762E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    4    2    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.85086E-07    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    4    2    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.14847E-06    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    4    2    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.25907E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    4    2    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.45206E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    4    2    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.78882E-06    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    4    2    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.13765E-05    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    4    2    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.24018E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    4    2    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.41910E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    4    2    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91239E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.73131E-05    0.59822E+06    0.13964E-28    0.85843E-25    0.16716E-04    0.90000E+03
+    4    2    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79750E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.12761E-04    0.49680E+06    0.42543E-28    0.74819E-21    0.20129E-04    0.90000E+03
+    4    2    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12004E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.22267E-04    0.41311E+06    0.12910E-27    0.11225E-17    0.24207E-04    0.90000E+03
+    4    2    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45927E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.38855E-04    0.34307E+06    0.39288E-27    0.42818E-15    0.29147E-04    0.89996E+03
+    4    2    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54250E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.67799E-04    0.28490E+06    0.11866E-26    0.50504E-13    0.35071E-04    0.89947E+03
+    4    2    0.17923E-10    0.10000E+01    0.32889E-01    0.63725E-01    0.20398E-10    0.24902E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.11831E-03    0.23629E+06    0.35028E-26    0.23224E-11    0.42127E-04    0.89631E+03
+    4    2    0.31275E-10    0.10000E+01    0.48383E-01    0.94632E-01    0.50539E-10    0.54991E-12    0.34961E-04    0.23126E-04    0.56458E+04    0.20644E-03    0.19496E+06    0.99480E-26    0.51608E-10    0.50501E-04    0.88379E+03
+    4    2    0.54572E-10    0.10000E+01    0.73999E-01    0.13860E+00    0.11211E-09    0.67996E-11    0.40393E-04    0.29166E-04    0.98516E+04    0.36022E-03    0.15940E+06    0.27116E-25    0.64419E-09    0.60514E-04    0.85042E+03
+    4    2    0.95225E-10    0.10000E+01    0.11597E+00    0.19175E+00    0.20948E-09    0.54532E-10    0.44255E-04    0.37248E-04    0.17190E+05    0.62856E-03    0.12781E+06    0.74492E-25    0.51949E-08    0.73631E-04    0.78277E+03
+    4    2    0.16616E-09    0.10000E+01    0.17109E+00    0.23915E+00    0.31764E-09    0.28570E-09    0.46795E-04    0.43960E-04    0.29996E+05    0.10968E-02    0.10077E+06    0.22115E-24    0.26755E-07    0.92307E-04    0.68195E+03
+    4    2    0.28994E-09    0.10000E+01    0.22209E+00    0.27574E+00    0.46024E-09    0.98361E-09    0.51792E-04    0.45342E-04    0.52341E+05    0.19138E-02    0.79240E+05    0.70174E-24    0.86648E-07    0.11818E-03    0.57838E+03
+    4    2    0.50593E-09    0.10000E+01    0.26311E+00    0.32201E+00    0.84773E-09    0.24660E-08    0.62745E-04    0.45850E-04    0.91333E+05    0.33395E-02    0.62798E+05    0.21148E-23    0.19470E-06    0.14947E-03    0.49780E+03
+    4    2    0.88282E-09    0.10000E+01    0.31231E+00    0.39680E+00    0.19004E-08    0.52427E-08    0.78117E-04    0.49395E-04    0.15937E+06    0.58273E-02    0.49446E+05    0.60112E-23    0.35355E-06    0.18731E-03    0.42929E+03
+    4    2    0.15405E-08    0.10000E+01    0.39143E+00    0.50322E+00    0.40112E-08    0.10384E-07    0.94746E-04    0.56436E-04    0.27809E+06    0.10168E-01    0.38281E+05    0.16932E-22    0.57333E-06    0.23728E-03    0.35753E+03
+    4    2    0.26880E-08    0.10000E+01    0.36605E+00    0.85970E+00    0.14991E-07    0.23516E-07    0.85666E-04    0.74241E-04    0.11884E+06    0.10890E-01    0.53411E+04    0.17388E-21    0.74737E-06    0.55156E-03    0.19227E+03
+    4    2    0.46905E-08    0.10000E+01    0.45438E+00    0.98186E+00    0.26620E-07    0.44615E-07    0.10522E-03    0.79857E-04    0.20736E+06    0.19002E-01    0.40081E+04    0.51889E-21    0.11971E-05    0.72950E-03    0.14718E+03
+    4    2    0.81846E-08    0.10000E+01    0.55266E+00    0.11026E+01    0.46359E-07    0.84002E-07    0.13080E-03    0.84623E-04    0.36184E+06    0.33157E-01    0.29961E+04    0.15665E-20    0.19114E-05    0.97188E-03    0.11059E+03
+    4    2    0.14282E-07    0.10000E+01    0.65735E+00    0.12182E+01    0.79757E-07    0.15687E-06    0.16521E-03    0.88470E-04    0.63138E+06    0.57856E-01    0.22396E+04    0.47403E-20    0.30500E-05    0.12974E-02    0.82165E+02
+    4    2    0.24920E-07    0.10000E+01    0.76696E+00    0.13280E+01    0.13494E-06    0.29086E-06    0.21110E-03    0.91551E-04    0.11017E+07    0.10096E+00    0.16698E+04    0.14433E-19    0.48598E-05    0.17383E-02    0.60396E+02
+    4    2    0.43485E-07    0.10000E+01    0.87770E+00    0.14299E+01    0.22646E-06    0.53525E-06    0.27337E-03    0.93989E-04    0.19224E+07    0.17616E+00    0.12465E+04    0.43865E-19    0.77389E-05    0.23274E-02    0.44211E+02
+    4    2    0.75878E-07    0.10000E+01    0.98799E+00    0.15239E+01    0.37636E-06    0.97849E-06    0.35740E-03    0.95954E-04    0.33546E+07    0.30739E+00    0.93059E+03    0.13335E-18    0.12306E-04    0.31168E-02    0.32248E+02
+    4    2    0.13240E-06    0.10000E+01    0.10966E+01    0.16103E+01    0.61819E-06    0.17782E-05    0.47005E-03    0.97578E-04    0.58535E+07    0.53638E+00    0.69382E+03    0.40582E-18    0.19527E-04    0.41786E-02    0.23437E+02
+    4    2    0.23103E-06    0.10000E+01    0.12011E+01    0.16881E+01    0.10078E-05    0.32079E-05    0.62209E-03    0.98932E-04    0.10214E+08    0.93595E+00    0.51796E+03    0.12123E-17    0.30910E-04    0.55695E-02    0.17056E+02
+    4    2    0.40314E-06    0.10000E+01    0.12134E+01    0.16969E+01    0.28425E-05    0.56156E-05    0.10501E-02    0.99080E-04    0.17823E+08    0.16332E+01    0.50000E+03    0.22503E-17    0.53286E-04    0.57606E-02    0.16418E+02
+    4    2    0.70346E-06    0.10000E+01    0.12134E+01    0.16969E+01    0.86548E-05    0.97989E-05    0.18323E-02    0.99080E-04    0.31100E+08    0.28498E+01    0.50000E+03    0.39266E-17    0.92980E-04    0.57606E-02    0.16418E+02
+    4    2    0.12275E-05    0.10000E+01    0.12134E+01    0.16969E+01    0.26352E-04    0.17098E-04    0.31972E-02    0.99080E-04    0.54267E+08    0.49727E+01    0.50000E+03    0.68516E-17    0.16225E-03    0.57606E-02    0.16418E+02
+    4    2    0.21419E-05    0.10000E+01    0.12134E+01    0.16969E+01    0.80237E-04    0.29836E-04    0.55790E-02    0.99080E-04    0.94693E+08    0.86771E+01    0.50000E+03    0.11956E-16    0.28311E-03    0.57606E-02    0.16418E+02
+    4    2    0.37375E-05    0.10000E+01    0.12134E+01    0.16969E+01    0.24431E-03    0.52061E-04    0.97350E-02    0.99080E-04    0.16523E+09    0.15141E+02    0.50000E+03    0.20862E-16    0.49401E-03    0.57606E-02    0.16418E+02
+    4    2    0.65217E-05    0.10000E+01    0.12134E+01    0.16969E+01    0.74387E-03    0.90844E-04    0.16987E-01    0.99080E-04    0.28832E+09    0.26420E+02    0.50000E+03    0.36403E-16    0.86201E-03    0.57606E-02    0.16418E+02
+    4    2    0.11380E-04    0.10000E+01    0.12134E+01    0.16969E+01    0.22650E-02    0.15852E-03    0.29641E-01    0.99080E-04    0.50310E+09    0.46101E+02    0.50000E+03    0.63521E-16    0.15042E-02    0.57606E-02    0.16418E+02
+    4    2    0.19857E-04    0.10000E+01    0.12134E+01    0.16969E+01    0.68964E-02    0.27660E-03    0.51722E-01    0.99080E-04    0.87789E+09    0.80444E+02    0.50000E+03    0.11084E-15    0.26247E-02    0.57606E-02    0.16418E+02
+    4    2    0.34650E-04    0.10000E+01    0.12134E+01    0.16969E+01    0.20998E-01    0.48266E-03    0.90252E-01    0.99080E-04    0.15319E+10    0.14037E+03    0.50000E+03    0.19341E-15    0.45799E-02    0.57606E-02    0.16418E+02
+    4    2    0.60462E-04    0.10000E+01    0.12134E+01    0.16969E+01    0.63935E-01    0.84221E-03    0.15748E+00    0.99080E-04    0.26730E+10    0.24494E+03    0.50000E+03    0.33749E-15    0.79916E-02    0.57606E-02    0.16418E+02
+    4    2    0.10550E-03    0.10000E+01    0.12134E+01    0.16969E+01    0.19467E+00    0.14696E-02    0.27480E+00    0.99080E-04    0.46642E+10    0.42740E+03    0.50000E+03    0.58889E-15    0.13945E-01    0.57606E-02    0.16418E+02
+    4    2    0.18409E-03    0.10000E+01    0.12134E+01    0.16969E+01    0.59274E+00    0.25644E-02    0.47951E+00    0.99080E-04    0.81388E+10    0.74579E+03    0.50000E+03    0.10276E-14    0.24333E-01    0.57606E-02    0.16418E+02
+    4    2    0.32123E-03    0.10000E+01    0.12134E+01    0.16969E+01    0.18048E+01    0.44747E-02    0.83672E+00    0.99080E-04    0.14202E+11    0.13014E+04    0.50000E+03    0.17931E-14    0.42460E-01    0.57606E-02    0.16418E+02
+    4    2    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    4    2    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    4    2    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    4    2    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    4    2    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    4    2    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    4    2    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    4    2    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    4    2    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    4    2    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    4    2    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    4    2    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    4    2    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    4    2    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    4    2    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    4    2    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    4    2    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    4    2    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    4    2    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    4    2    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    4    2    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    4    2    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    4    2    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    4    2    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    4    2    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    4    2    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    4    2    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    4    2    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    4    2    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    4    2    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    4    2    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    4    2    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    4    2    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    4    2    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    4    2    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    4    2    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    4    2    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    4    2    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    4    2    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    4    2    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    4    2    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    4    2    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    4    2    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    4    2    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    4    2    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    4    2    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    4    2    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    4    2    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    4    2    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    4    2    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    4    2    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    4    2    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    4    2    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    4    2    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    4    2    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    4    2    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    4    2    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    4    2    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    4    2    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    4    2    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    4    2    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    4    2    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    4    2    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    4    2    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    4    2    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    4    2    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    4    2    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    4    2    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    4    2    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    4    2    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    4    2    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    4    2    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    4    2    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    4    2    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    4    2    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    4    2    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    4    2    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    4    2    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    4    2    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    4    2    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    4    2    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    4    2    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    4    2    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    4    2    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    4    2    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    4    2    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    4    2    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    4    2    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    4    2    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    4    2    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    4    2    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    4    2    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    4    2    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    4    2    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    4    2    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    4    2    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    4    2    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    4    2    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    4    2    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    4    2    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    4    2    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    4    2    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    4    2    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    4    2    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    4    2    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    4    2    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    4    2    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    4    2    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    4    2    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    4    2    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    4    2    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    4    2    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    4    2    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    4    2    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    4    2    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    4    2    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    4    2    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    4    2    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    4    2    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    4    2    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    4    2    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    4    2    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    4    2    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    4    2    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    4    2    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    4    2    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    4    2    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    4    2    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    4    2    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    4    2    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    4    2    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    4    2    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    4    2    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    4    2    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    4    2    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    4    2    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    4    2    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    4    2    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    4    2    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    4    2    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    4    2    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    4    2    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    4    2    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    4    2    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    4    2    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    4    2    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    4    2    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    4    2    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    4    2    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    4    2    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    4    2    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    4    2    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    4    2    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    4    2    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    4    2    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    4    2    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    4    2    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    4    2    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    4    2    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    4    2    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    4    2    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    4    2    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    4    2    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    4    2    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    4    2    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    4    2    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    4    2    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    4    2    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    4    2    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    4    2    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    4    2    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    4    2    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    4    2    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    4    2    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    4    2    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    4    2    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    4    2    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    4    2    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    4    2    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    4    2    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    4    2    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    4    2    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    4    2    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    4    2    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    4    2    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    4    2    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    4    2    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    4    2    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    4    2    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    4    2    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    4    2    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    4    2    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    4    2    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    4    2    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    4    2    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    4    2    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    4    2    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    4    2    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    4    2    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    4    2    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    4    2    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    4    2    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    4    2    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    4    2    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    4    2    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    4    2    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    4    2    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    4    2    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    4    2    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    4    2    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    4    2    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    4    2    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    4    2    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    4    2    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    4    2    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    4    2    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    4    2    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    4    2    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    4    2    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    4    2    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    4    2    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    4    2    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    4    2    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    4    2    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    4    2    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    4    2    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    4    2    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    4    2    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    4    2    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    4    2    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    4    2    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    4    2    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    4    2    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    4    2    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    4    2    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    4    2    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    4    2    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    4    2    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    4    2    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    4    2    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    4    2    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    4    2    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    4    2    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    4    2    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    4    2    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    4    2    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    4    2    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    4    2    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    4    2    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    4    2    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    4    2    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    4    2    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    4    2    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    4    2    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    4    2    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    4    2    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    4    2    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    4    2    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    4    2    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    4    2    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    4    2    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    4    2    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    4    2    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    4    2    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    4    2    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    4    2    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    4    2    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    4    2    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    4    2    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    4    2    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    4    2    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    4    2    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    4    2    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    4    2    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    4    2    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    4    2    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    4    2    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    4    2    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    4    2    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    4    2    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    4    2    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    4    2    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    4    2    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    4    2    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    4    2    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    4    2    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    4    2    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    4    2    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    4    2    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    4    2    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    4    2    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    4    2    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    4    2    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    4    2    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    4    2    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    4    2    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    4    2    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    4    2    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    4    2    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    4    2    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    4    2    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    4    2    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    4    2    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    4    2    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    4    2    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    4    2    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    4    2    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    4    2    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    4    2    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    4    2    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    4    2    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    4    2    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    4    2    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    4    2    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    4    2    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    4    2    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    4    2    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    4    2    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    4    2    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    4    2    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    4    2    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    4    2    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    4    2    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    4    2    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    4    2    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    4    2    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    4    2    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    4    2    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    4    2    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    4    2    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    4    2    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    4    2    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    4    2    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    4    2    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    4    2    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    4    2    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    4    2    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    4    2    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    4    2    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    4    2    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    4    2    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    4    2    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    4    2    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    4    2    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    4    2    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    4    2    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    4    2    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    4    2    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    4    2    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    4    2    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    4    2    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    4    2    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    4    2    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    4    2    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    4    2    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    4    2    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    4    2    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    4    2    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    4    2    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    4    2    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    4    2    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    4    2    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    4    2    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    4    2    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    4    2    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    4    2    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    4    2    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    4    2    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    4    2    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    4    2    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    4    2    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    4    2    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    4    2    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    4    2    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    4    2    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    4    2    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    4    2    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    4    2    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    4    2    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    4    2    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    4    2    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    4    2    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    4    2    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    4    2    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    4    2    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    4    2    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    4    2    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    4    2    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    4    2    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    4    2    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    4    2    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    4    2    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    4    2    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    4    2    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    4    2    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    4    2    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    4    2    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    4    2    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    4    2    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    4    2    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    4    2    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    4    2    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    4    2    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    4    2    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    4    2    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    4    2    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    4    2    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    4    2    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    4    2    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    4    2    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    4    2    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    4    2    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    4    2    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    4    2    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    4    2    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    4    2    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    4    2    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    4    2    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    4    2    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    4    2    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    4    2    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    4    2    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    4    2    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    4    2    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    4    2    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    4    2    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    4    2    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    4    2    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    4    2    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    4    2    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    4    2    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    4    2    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    4    2    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    4    2    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    4    2    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    4    2    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    4    2    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    4    2    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    4    2    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    4    2    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    4    2    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    4    2    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    4    2    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    4    2    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    4    2    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    4    2    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    4    2    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    4    2    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    4    2    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    4    2    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    4    2    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    4    2    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    4    2    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    4    2    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    4    2    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    4    2    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    4    2    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    4    2    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    4    2    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    4    2    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    4    2    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    4    2    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    4    2    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    4    2    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    4    2    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    4    2    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    4    2    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    4    2    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    4    2    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    4    2    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    4    2    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    4    2    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    4    2    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    4    2    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    4    2    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    4    2    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    4    2    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    4    2    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    4    2    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    4    2    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    4    2    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    4    2    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    4    2    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    4    2    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    4    2    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    4    2    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    4    2    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    4    2    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    4    2    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    4    2    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    4    2    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    4    2    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    4    2    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    4    2    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    4    2    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    4    2    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    4    2    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    4    2    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    4    2    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    4    2    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    4    2    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    4    2    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    4    2    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    4    2    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    4    2    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    4    2    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    4    2    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    4    2    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    4    2    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    4    2    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    4    2    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    4    2    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    4    2    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    4    2    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    4    2    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    4    2    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    4    2    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    4    2    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    4    2    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    4    2    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    4    2    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    4    2    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    4    2    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    4    2    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    4    2    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    4    2    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    4    2    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    4    2    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    4    2    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    4    2    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    4    2    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    4    2    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    4    2    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    4    2    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    4    2    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    4    2    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    4    2    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    4    2    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    4    2    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    4    2    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    4    2    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    4    2    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    4    2    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    4    2    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    4    2    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    4    2    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    4    2    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    4    2    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    4    2    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    4    2    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    4    2    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    4    2    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    4    2    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    4    2    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    4    2    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    4    2    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    4    2    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    4    2    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    4    2    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    4    2    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    4    2    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    4    2    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    4    2    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    4    2    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    4    2    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    4    2    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    4    2    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    4    2    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    4    2    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    4    2    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    4    2    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34054E-68
+    4    2    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28312E-67
+    4    2    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24727E-66
+    4    2    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    4    2    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    4    2    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41870E-63
+    4    2    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    4    2    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    4    2    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    4    2    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28903E-58
+    4    2    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    4    2    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    4    2    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    4    2    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11731E-53
+    4    2    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    4    2    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73373E-50
+    4    2    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    4    2    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    4    2    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    4    2    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    4    2    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    4    2    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    4    2    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    4    2    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    4    2    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    4    2    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    4    2    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    4    2    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    4    2    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    4    2    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    4    2    0.31275E-10    0.10000E+01    0.80645E+05    0.12245E-57    0.88091E-69    0.11456E-67
+    4    2    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15654E-67    0.98371E-67
+    4    2    0.31275E-10    0.10000E+01    0.52449E+05    0.94833E-56    0.30733E-66    0.84245E-66
+    4    2    0.31275E-10    0.10000E+01    0.42297E+05    0.99584E-55    0.85105E-65    0.66923E-65
+    4    2    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28098E-63    0.61270E-64
+    4    2    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94801E-62    0.75382E-63
+    4    2    0.31275E-10    0.10000E+01    0.22184E+05    0.40542E-51    0.30613E-60    0.11739E-61
+    4    2    0.31275E-10    0.10000E+01    0.17891E+05    0.68166E-50    0.91702E-59    0.19607E-60
+    4    2    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25764E-57    0.31441E-59
+    4    2    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70062E-56    0.47461E-58
+    4    2    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18857E-54    0.68930E-57
+    4    2    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50661E-53    0.98474E-56
+    4    2    0.31275E-10    0.10000E+01    0.61026E+04    0.45469E-44    0.13609E-51    0.13991E-54
+    4    2    0.31275E-10    0.10000E+01    0.49215E+04    0.64066E-43    0.36552E-50    0.19838E-53
+    4    2    0.31275E-10    0.10000E+01    0.39689E+04    0.90253E-42    0.98157E-49    0.28095E-52
+    4    2    0.31275E-10    0.10000E+01    0.32008E+04    0.39979E-39    0.85219E-46    0.12501E-49
+    4    2    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14318E-36    0.91999E-41
+    4    2    0.31275E-10    0.10000E+01    0.20817E+04    0.55762E-14    0.12154E-19    0.17582E-24
+    4    2    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59583E-19
+    4    2    0.31275E-10    0.10000E+01    0.13538E+04    0.40464E-08    0.68176E-13    0.12804E-18
+    4    2    0.31275E-10    0.10000E+01    0.10918E+04    0.84958E-08    0.25421E-12    0.26902E-18
+    4    2    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93594E-12    0.55307E-18
+    4    2    0.31275E-10    0.10000E+01    0.71007E+03    0.35184E-07    0.34082E-11    0.11150E-17
+    4    2    0.31275E-10    0.10000E+01    0.57264E+03    0.69723E-07    0.12126E-10    0.22101E-17
+    4    2    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40783E-10    0.43092E-17
+    4    2    0.31275E-10    0.10000E+01    0.37242E+03    0.25942E-06    0.12436E-09    0.82250E-17
+    4    2    0.31275E-10    0.10000E+01    0.30034E+03    0.47914E-06    0.33354E-09    0.15192E-16
+    4    2    0.31275E-10    0.10000E+01    0.24221E+03    0.84414E-06    0.77880E-09    0.26766E-16
+    4    2    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    4    2    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    4    2    0.54572E-10    0.10000E+01    0.80645E+05    0.25907E-57    0.19499E-68    0.35812E-67
+    4    2    0.54572E-10    0.10000E+01    0.65036E+05    0.22059E-56    0.31832E-67    0.31260E-66
+    4    2    0.54572E-10    0.10000E+01    0.52449E+05    0.19290E-55    0.49279E-66    0.26911E-65
+    4    2    0.54572E-10    0.10000E+01    0.42297E+05    0.16491E-54    0.10213E-64    0.20746E-64
+    4    2    0.54572E-10    0.10000E+01    0.34111E+05    0.17291E-53    0.28413E-63    0.16368E-63
+    4    2    0.54572E-10    0.10000E+01    0.27509E+05    0.24064E-52    0.90984E-62    0.15314E-62
+    4    2    0.54572E-10    0.10000E+01    0.22184E+05    0.39345E-51    0.29448E-60    0.19333E-61
+    4    2    0.54572E-10    0.10000E+01    0.17891E+05    0.65763E-50    0.89314E-59    0.30540E-60
+    4    2    0.54572E-10    0.10000E+01    0.14428E+05    0.10437E-48    0.25334E-57    0.49593E-59
+    4    2    0.54572E-10    0.10000E+01    0.11635E+05    0.15617E-47    0.69341E-56    0.76506E-58
+    4    2    0.54572E-10    0.10000E+01    0.93834E+04    0.22543E-46    0.18754E-54    0.11306E-56
+    4    2    0.54572E-10    0.10000E+01    0.75673E+04    0.32059E-45    0.50583E-53    0.16361E-55
+    4    2    0.54572E-10    0.10000E+01    0.61026E+04    0.45384E-44    0.13632E-51    0.23472E-54
+    4    2    0.54572E-10    0.10000E+01    0.49215E+04    0.64161E-43    0.36718E-50    0.33535E-53
+    4    2    0.54572E-10    0.10000E+01    0.39689E+04    0.90641E-42    0.98828E-49    0.47778E-52
+    4    2    0.54572E-10    0.10000E+01    0.32008E+04    0.40246E-39    0.85974E-46    0.21363E-49
+    4    2    0.54572E-10    0.10000E+01    0.25813E+04    0.29562E-30    0.14474E-36    0.15788E-40
+    4    2    0.54572E-10    0.10000E+01    0.20817E+04    0.56384E-14    0.12313E-19    0.30304E-24
+    4    2    0.54572E-10    0.10000E+01    0.16788E+04    0.19084E-08    0.18200E-13    0.10297E-18
+    4    2    0.54572E-10    0.10000E+01    0.13538E+04    0.40994E-08    0.69138E-13    0.22149E-18
+    4    2    0.54572E-10    0.10000E+01    0.10918E+04    0.86102E-08    0.25781E-12    0.46567E-18
+    4    2    0.54572E-10    0.10000E+01    0.88049E+03    0.17698E-07    0.94924E-12    0.95782E-18
+    4    2    0.54572E-10    0.10000E+01    0.71007E+03    0.35674E-07    0.34567E-11    0.19317E-17
+    4    2    0.54572E-10    0.10000E+01    0.57264E+03    0.70701E-07    0.12298E-10    0.38296E-17
+    4    2    0.54572E-10    0.10000E+01    0.46180E+03    0.13784E-06    0.41364E-10    0.74680E-17
+    4    2    0.54572E-10    0.10000E+01    0.37242E+03    0.26309E-06    0.12613E-09    0.14256E-16
+    4    2    0.54572E-10    0.10000E+01    0.30034E+03    0.48594E-06    0.33829E-09    0.26333E-16
+    4    2    0.54572E-10    0.10000E+01    0.24221E+03    0.85614E-06    0.78989E-09    0.46395E-16
+    4    2    0.54572E-10    0.10000E+01    0.19533E+03    0.13493E-05    0.15010E-08    0.73122E-16
+    4    2    0.54572E-10    0.10000E+01    0.15752E+03    0.13493E-05    0.15010E-08    0.73122E-16
+    4    2    0.95225E-10    0.10000E+01    0.80645E+05    0.53559E-57    0.41313E-68    0.11278E-66
+    4    2    0.95225E-10    0.10000E+01    0.65036E+05    0.46413E-56    0.66243E-67    0.98085E-66
+    4    2    0.95225E-10    0.10000E+01    0.52449E+05    0.40036E-55    0.93198E-66    0.84373E-65
+    4    2    0.95225E-10    0.10000E+01    0.42297E+05    0.31445E-54    0.15019E-64    0.64171E-64
+    4    2    0.95225E-10    0.10000E+01    0.34111E+05    0.26334E-53    0.30904E-63    0.47062E-63
+    4    2    0.95225E-10    0.10000E+01    0.27509E+05    0.27376E-52    0.84128E-62    0.36203E-62
+    4    2    0.95225E-10    0.10000E+01    0.22184E+05    0.37479E-51    0.26613E-60    0.35140E-61
+    4    2    0.95225E-10    0.10000E+01    0.17891E+05    0.60047E-50    0.82295E-59    0.48732E-60
+    4    2    0.95225E-10    0.10000E+01    0.14428E+05    0.96257E-49    0.23795E-57    0.78455E-59
+    4    2    0.95225E-10    0.10000E+01    0.11635E+05    0.14650E-47    0.66022E-56    0.12347E-57
+    4    2    0.95225E-10    0.10000E+01    0.93834E+04    0.21438E-46    0.18035E-54    0.18581E-56
+    4    2    0.95225E-10    0.10000E+01    0.75673E+04    0.30802E-45    0.49018E-53    0.27246E-55
+    4    2    0.95225E-10    0.10000E+01    0.61026E+04    0.43951E-44    0.13292E-51    0.39471E-54
+    4    2    0.95225E-10    0.10000E+01    0.49215E+04    0.62528E-43    0.35981E-50    0.56815E-53
+    4    2    0.95225E-10    0.10000E+01    0.39689E+04    0.88784E-42    0.97238E-49    0.81424E-52
+    4    2    0.95225E-10    0.10000E+01    0.32008E+04    0.39588E-39    0.84885E-46    0.36583E-49
+    4    2    0.95225E-10    0.10000E+01    0.25813E+04    0.29188E-30    0.14340E-36    0.27153E-40
+    4    2    0.95225E-10    0.10000E+01    0.20817E+04    0.55886E-14    0.12243E-19    0.52348E-24
+    4    2    0.95225E-10    0.10000E+01    0.16788E+04    0.18961E-08    0.18124E-13    0.17837E-18
+    4    2    0.95225E-10    0.10000E+01    0.13538E+04    0.40764E-08    0.68864E-13    0.38402E-18
+    4    2    0.95225E-10    0.10000E+01    0.10918E+04    0.85670E-08    0.25682E-12    0.80793E-18
+    4    2    0.95225E-10    0.10000E+01    0.88049E+03    0.17617E-07    0.94565E-12    0.16626E-17
+    4    2    0.95225E-10    0.10000E+01    0.71007E+03    0.35521E-07    0.34437E-11    0.33542E-17
+    4    2    0.95225E-10    0.10000E+01    0.57264E+03    0.70413E-07    0.12252E-10    0.66513E-17
+    4    2    0.95225E-10    0.10000E+01    0.46180E+03    0.13730E-06    0.41209E-10    0.12972E-16
+    4    2    0.95225E-10    0.10000E+01    0.37242E+03    0.26208E-06    0.12565E-09    0.24765E-16
+    4    2    0.95225E-10    0.10000E+01    0.30034E+03    0.48409E-06    0.33703E-09    0.45748E-16
+    4    2    0.95225E-10    0.10000E+01    0.24221E+03    0.85289E-06    0.78693E-09    0.80606E-16
+    4    2    0.95225E-10    0.10000E+01    0.19533E+03    0.13442E-05    0.14954E-08    0.12704E-15
+    4    2    0.95225E-10    0.10000E+01    0.15752E+03    0.13442E-05    0.14954E-08    0.12704E-15
+    4    2    0.16616E-09    0.10000E+01    0.80645E+05    0.10971E-56    0.84385E-68    0.39282E-66
+    4    2    0.16616E-09    0.10000E+01    0.65036E+05    0.94838E-56    0.13469E-66    0.33517E-65
+    4    2    0.16616E-09    0.10000E+01    0.52449E+05    0.81345E-55    0.18311E-65    0.28497E-64
+    4    2    0.16616E-09    0.10000E+01    0.42297E+05    0.61893E-54    0.25747E-64    0.21247E-63
+    4    2    0.16616E-09    0.10000E+01    0.34111E+05    0.46080E-53    0.39954E-63    0.14889E-62
+    4    2    0.16616E-09    0.10000E+01    0.27509E+05    0.37207E-52    0.82161E-62    0.10269E-61
+    4    2    0.16616E-09    0.10000E+01    0.22184E+05    0.38638E-51    0.23751E-60    0.80001E-61
+    4    2    0.16616E-09    0.10000E+01    0.17891E+05    0.54910E-50    0.74403E-59    0.90435E-60
+    4    2    0.16616E-09    0.10000E+01    0.14428E+05    0.87413E-49    0.22037E-57    0.13601E-58
+    4    2    0.16616E-09    0.10000E+01    0.11635E+05    0.13553E-47    0.62211E-56    0.21226E-57
+    4    2    0.16616E-09    0.10000E+01    0.93834E+04    0.20170E-46    0.17199E-54    0.31974E-56
+    4    2    0.16616E-09    0.10000E+01    0.75673E+04    0.29343E-45    0.47169E-53    0.46915E-55
+    4    2    0.16616E-09    0.10000E+01    0.61026E+04    0.42261E-44    0.12882E-51    0.67982E-54
+    4    2    0.16616E-09    0.10000E+01    0.49215E+04    0.60562E-43    0.35071E-50    0.97901E-53
+    4    2    0.16616E-09    0.10000E+01    0.39689E+04    0.86499E-42    0.95227E-49    0.14043E-51
+    4    2    0.16616E-09    0.10000E+01    0.32008E+04    0.38758E-39    0.83468E-46    0.63171E-49
+    4    2    0.16616E-09    0.10000E+01    0.25813E+04    0.28701E-30    0.14158E-36    0.46959E-40
+    4    2    0.16616E-09    0.10000E+01    0.20817E+04    0.55207E-14    0.12141E-19    0.90720E-24
+    4    2    0.16616E-09    0.10000E+01    0.16788E+04    0.18784E-08    0.18002E-13    0.30953E-18
+    4    2    0.16616E-09    0.10000E+01    0.13538E+04    0.40422E-08    0.68421E-13    0.66670E-18
+    4    2    0.16616E-09    0.10000E+01    0.10918E+04    0.85014E-08    0.25521E-12    0.14031E-17
+    4    2    0.16616E-09    0.10000E+01    0.88049E+03    0.17491E-07    0.93976E-12    0.28882E-17
+    4    2    0.16616E-09    0.10000E+01    0.71007E+03    0.35279E-07    0.34223E-11    0.58276E-17
+    4    2    0.16616E-09    0.10000E+01    0.57264E+03    0.69950E-07    0.12176E-10    0.11557E-16
+    4    2    0.16616E-09    0.10000E+01    0.46180E+03    0.13642E-06    0.40954E-10    0.22542E-16
+    4    2    0.16616E-09    0.10000E+01    0.37242E+03    0.26042E-06    0.12488E-09    0.43035E-16
+    4    2    0.16616E-09    0.10000E+01    0.30034E+03    0.48105E-06    0.33494E-09    0.79499E-16
+    4    2    0.16616E-09    0.10000E+01    0.24221E+03    0.84757E-06    0.78205E-09    0.14007E-15
+    4    2    0.16616E-09    0.10000E+01    0.19533E+03    0.13358E-05    0.14862E-08    0.22077E-15
+    4    2    0.16616E-09    0.10000E+01    0.15752E+03    0.13358E-05    0.14862E-08    0.22077E-15
+    4    2    0.28994E-09    0.10000E+01    0.80645E+05    0.22403E-56    0.16915E-67    0.14455E-65
+    4    2    0.28994E-09    0.10000E+01    0.65036E+05    0.19082E-55    0.26798E-66    0.12155E-64
+    4    2    0.28994E-09    0.10000E+01    0.52449E+05    0.16207E-54    0.35589E-65    0.10238E-63
+    4    2    0.28994E-09    0.10000E+01    0.42297E+05    0.12080E-53    0.46898E-64    0.75318E-63
+    4    2    0.28994E-09    0.10000E+01    0.34111E+05    0.85077E-53    0.62165E-63    0.51693E-62
+    4    2    0.28994E-09    0.10000E+01    0.27509E+05    0.59859E-52    0.97335E-62    0.34189E-61
+    4    2    0.28994E-09    0.10000E+01    0.22184E+05    0.48548E-51    0.23468E-60    0.23443E-60
+    4    2    0.28994E-09    0.10000E+01    0.17891E+05    0.56452E-50    0.71312E-59    0.21039E-59
+    4    2    0.28994E-09    0.10000E+01    0.14428E+05    0.84702E-49    0.21271E-57    0.27030E-58
+    4    2    0.28994E-09    0.10000E+01    0.11635E+05    0.13095E-47    0.60439E-56    0.39795E-57
+    4    2    0.28994E-09    0.10000E+01    0.93834E+04    0.19584E-46    0.16767E-54    0.58522E-56
+    4    2    0.28994E-09    0.10000E+01    0.75673E+04    0.28594E-45    0.46088E-53    0.84538E-55
+    4    2    0.28994E-09    0.10000E+01    0.61026E+04    0.41286E-44    0.12613E-51    0.12104E-53
+    4    2    0.28994E-09    0.10000E+01    0.49215E+04    0.59293E-43    0.34412E-50    0.17276E-52
+    4    2    0.28994E-09    0.10000E+01    0.39689E+04    0.84866E-42    0.93636E-49    0.24631E-51
+    4    2    0.28994E-09    0.10000E+01    0.32008E+04    0.38109E-39    0.82249E-46    0.11036E-48
+    4    2    0.28994E-09    0.10000E+01    0.25813E+04    0.28285E-30    0.13985E-36    0.81848E-40
+    4    2    0.28994E-09    0.10000E+01    0.20817E+04    0.54558E-14    0.12026E-19    0.15791E-23
+    4    2    0.28994E-09    0.10000E+01    0.16788E+04    0.18597E-08    0.17852E-13    0.53848E-18
+    4    2    0.28994E-09    0.10000E+01    0.13538E+04    0.40043E-08    0.67862E-13    0.11595E-17
+    4    2    0.28994E-09    0.10000E+01    0.10918E+04    0.84254E-08    0.25314E-12    0.24400E-17
+    4    2    0.28994E-09    0.10000E+01    0.88049E+03    0.17340E-07    0.93218E-12    0.50218E-17
+    4    2    0.28994E-09    0.10000E+01    0.71007E+03    0.34983E-07    0.33947E-11    0.10132E-16
+    4    2    0.28994E-09    0.10000E+01    0.57264E+03    0.69371E-07    0.12078E-10    0.20092E-16
+    4    2    0.28994E-09    0.10000E+01    0.46180E+03    0.13530E-06    0.40623E-10    0.39187E-16
+    4    2    0.28994E-09    0.10000E+01    0.37242E+03    0.25830E-06    0.12387E-09    0.74810E-16
+    4    2    0.28994E-09    0.10000E+01    0.30034E+03    0.47715E-06    0.33223E-09    0.13819E-15
+    4    2    0.28994E-09    0.10000E+01    0.24221E+03    0.84070E-06    0.77573E-09    0.24348E-15
+    4    2    0.28994E-09    0.10000E+01    0.19533E+03    0.13250E-05    0.14741E-08    0.38374E-15
+    4    2    0.28994E-09    0.10000E+01    0.15752E+03    0.13250E-05    0.14741E-08    0.38374E-15
+    4    2    0.50593E-09    0.10000E+01    0.80645E+05    0.44812E-56    0.33357E-67    0.48481E-65
+    4    2    0.50593E-09    0.10000E+01    0.65036E+05    0.37742E-55    0.52561E-66    0.40633E-64
+    4    2    0.50593E-09    0.10000E+01    0.52449E+05    0.31829E-54    0.68909E-65    0.34180E-63
+    4    2    0.50593E-09    0.10000E+01    0.42297E+05    0.23470E-53    0.88689E-64    0.25145E-62
+    4    2    0.50593E-09    0.10000E+01    0.34111E+05    0.16193E-52    0.11128E-62    0.17314E-61
+    4    2    0.50593E-09    0.10000E+01    0.27509E+05    0.10837E-51    0.14757E-61    0.11479E-60
+    4    2    0.50593E-09    0.10000E+01    0.22184E+05    0.76158E-51    0.27918E-60    0.75027E-60
+    4    2    0.50593E-09    0.10000E+01    0.17891E+05    0.70497E-50    0.75599E-59    0.55612E-59
+    4    2    0.50593E-09    0.10000E+01    0.14428E+05    0.91889E-49    0.21911E-57    0.56675E-58
+    4    2    0.50593E-09    0.10000E+01    0.11635E+05    0.13572E-47    0.61646E-56    0.74594E-57
+    4    2    0.50593E-09    0.10000E+01    0.93834E+04    0.20003E-46    0.16976E-54    0.10598E-55
+    4    2    0.50593E-09    0.10000E+01    0.75673E+04    0.28967E-45    0.46375E-53    0.15118E-54
+    4    2    0.50593E-09    0.10000E+01    0.61026E+04    0.41565E-44    0.12634E-51    0.21462E-53
+    4    2    0.50593E-09    0.10000E+01    0.49215E+04    0.59421E-43    0.34371E-50    0.30416E-52
+    4    2    0.50593E-09    0.10000E+01    0.39689E+04    0.84795E-42    0.93378E-49    0.43125E-51
+    4    2    0.50593E-09    0.10000E+01    0.32008E+04    0.38013E-39    0.81969E-46    0.19249E-48
+    4    2    0.50593E-09    0.10000E+01    0.25813E+04    0.28195E-30    0.13938E-36    0.14242E-39
+    4    2    0.50593E-09    0.10000E+01    0.20817E+04    0.54393E-14    0.11991E-19    0.27442E-23
+    4    2    0.50593E-09    0.10000E+01    0.16788E+04    0.18546E-08    0.17807E-13    0.93529E-18
+    4    2    0.50593E-09    0.10000E+01    0.13538E+04    0.39935E-08    0.67691E-13    0.20135E-17
+    4    2    0.50593E-09    0.10000E+01    0.10918E+04    0.84030E-08    0.25250E-12    0.42362E-17
+    4    2    0.50593E-09    0.10000E+01    0.88049E+03    0.17294E-07    0.92979E-12    0.87178E-17
+    4    2    0.50593E-09    0.10000E+01    0.71007E+03    0.34892E-07    0.33859E-11    0.17587E-16
+    4    2    0.50593E-09    0.10000E+01    0.57264E+03    0.69193E-07    0.12046E-10    0.34874E-16
+    4    2    0.50593E-09    0.10000E+01    0.46180E+03    0.13495E-06    0.40516E-10    0.68013E-16
+    4    2    0.50593E-09    0.10000E+01    0.37242E+03    0.25763E-06    0.12354E-09    0.12983E-15
+    4    2    0.50593E-09    0.10000E+01    0.30034E+03    0.47590E-06    0.33134E-09    0.23982E-15
+    4    2    0.50593E-09    0.10000E+01    0.24221E+03    0.83850E-06    0.77366E-09    0.42252E-15
+    4    2    0.50593E-09    0.10000E+01    0.19533E+03    0.13215E-05    0.14702E-08    0.66591E-15
+    4    2    0.50593E-09    0.10000E+01    0.15752E+03    0.13215E-05    0.14702E-08    0.66591E-15
+    4    2    0.88282E-09    0.10000E+01    0.80645E+05    0.87719E-56    0.64998E-67    0.15069E-64
+    4    2    0.88282E-09    0.10000E+01    0.65036E+05    0.73618E-55    0.10233E-65    0.12650E-63
+    4    2    0.88282E-09    0.10000E+01    0.52449E+05    0.61993E-54    0.13409E-64    0.10664E-62
+    4    2    0.88282E-09    0.10000E+01    0.42297E+05    0.45691E-53    0.17303E-63    0.78876E-62
+    4    2    0.88282E-09    0.10000E+01    0.34111E+05    0.31573E-52    0.21726E-62    0.54959E-61
+    4    2    0.88282E-09    0.10000E+01    0.27509E+05    0.21070E-51    0.26874E-61    0.37098E-60
+    4    2    0.88282E-09    0.10000E+01    0.22184E+05    0.13950E-50    0.39763E-60    0.24160E-59
+    4    2    0.88282E-09    0.10000E+01    0.17891E+05    0.10536E-49    0.85384E-59    0.15941E-58
+    4    2    0.88282E-09    0.10000E+01    0.14428E+05    0.10873E-48    0.22760E-57    0.12557E-57
+    4    2    0.88282E-09    0.10000E+01    0.11635E+05    0.14366E-47    0.62825E-56    0.13551E-56
+    4    2    0.88282E-09    0.10000E+01    0.93834E+04    0.20483E-46    0.17190E-54    0.18095E-55
+    4    2    0.88282E-09    0.10000E+01    0.75673E+04    0.29361E-45    0.46706E-53    0.25715E-54
+    4    2    0.88282E-09    0.10000E+01    0.61026E+04    0.41877E-44    0.12661E-51    0.36715E-53
+    4    2    0.88282E-09    0.10000E+01    0.49215E+04    0.59570E-43    0.34311E-50    0.52226E-52
+    4    2    0.88282E-09    0.10000E+01    0.39689E+04    0.84682E-42    0.92986E-49    0.74163E-51
+    4    2    0.88282E-09    0.10000E+01    0.32008E+04    0.37864E-39    0.81513E-46    0.33129E-48
+    4    2    0.88282E-09    0.10000E+01    0.25813E+04    0.28046E-30    0.13853E-36    0.24534E-39
+    4    2    0.88282E-09    0.10000E+01    0.20817E+04    0.54081E-14    0.11919E-19    0.47353E-23
+    4    2    0.88282E-09    0.10000E+01    0.16788E+04    0.18439E-08    0.17702E-13    0.16160E-17
+    4    2    0.88282E-09    0.10000E+01    0.13538E+04    0.39701E-08    0.67290E-13    0.34799E-17
+    4    2    0.88282E-09    0.10000E+01    0.10918E+04    0.83535E-08    0.25099E-12    0.73231E-17
+    4    2    0.88282E-09    0.10000E+01    0.88049E+03    0.17192E-07    0.92420E-12    0.15073E-16
+    4    2    0.88282E-09    0.10000E+01    0.71007E+03    0.34685E-07    0.33654E-11    0.30412E-16
+    4    2    0.88282E-09    0.10000E+01    0.57264E+03    0.68780E-07    0.11973E-10    0.60308E-16
+    4    2    0.88282E-09    0.10000E+01    0.46180E+03    0.13414E-06    0.40267E-10    0.11762E-15
+    4    2    0.88282E-09    0.10000E+01    0.37242E+03    0.25607E-06    0.12278E-09    0.22452E-15
+    4    2    0.88282E-09    0.10000E+01    0.30034E+03    0.47301E-06    0.32930E-09    0.41471E-15
+    4    2    0.88282E-09    0.10000E+01    0.24221E+03    0.83338E-06    0.76887E-09    0.73065E-15
+    4    2    0.88282E-09    0.10000E+01    0.19533E+03    0.13134E-05    0.14611E-08    0.11515E-14
+    4    2    0.88282E-09    0.10000E+01    0.15752E+03    0.13134E-05    0.14611E-08    0.11515E-14
+    4    2    0.15405E-08    0.10000E+01    0.80645E+05    0.16981E-55    0.12597E-66    0.46489E-64
+    4    2    0.15405E-08    0.10000E+01    0.65036E+05    0.14265E-54    0.19870E-65    0.39116E-63
+    4    2    0.15405E-08    0.10000E+01    0.52449E+05    0.12035E-53    0.26190E-64    0.33060E-62
+    4    2    0.15405E-08    0.10000E+01    0.42297E+05    0.89127E-53    0.34252E-63    0.24584E-61
+    4    2    0.15405E-08    0.10000E+01    0.34111E+05    0.62258E-52    0.43946E-62    0.17320E-60
+    4    2    0.15405E-08    0.10000E+01    0.27509E+05    0.42225E-51    0.53947E-61    0.11910E-59
+    4    2    0.15405E-08    0.10000E+01    0.22184E+05    0.27731E-50    0.67705E-60    0.78812E-59
+    4    2    0.15405E-08    0.10000E+01    0.17891E+05    0.18461E-49    0.10590E-58    0.49995E-58
+    4    2    0.15405E-08    0.10000E+01    0.14428E+05    0.14484E-48    0.23196E-57    0.32564E-57
+    4    2    0.15405E-08    0.10000E+01    0.11635E+05    0.15350E-47    0.61211E-56    0.26360E-56
+    4    2    0.15405E-08    0.10000E+01    0.93834E+04    0.20263E-46    0.16806E-54    0.29996E-55
+    4    2    0.15405E-08    0.10000E+01    0.75673E+04    0.28768E-45    0.45976E-53    0.41633E-54
+    4    2    0.15405E-08    0.10000E+01    0.61026E+04    0.41198E-44    0.12501E-51    0.60425E-53
+    4    2    0.15405E-08    0.10000E+01    0.49215E+04    0.58788E-43    0.33909E-50    0.87345E-52
+    4    2    0.15405E-08    0.10000E+01    0.39689E+04    0.83673E-42    0.91928E-49    0.12527E-50
+    4    2    0.15405E-08    0.10000E+01    0.32008E+04    0.37433E-39    0.80633E-46    0.56293E-48
+    4    2    0.15405E-08    0.10000E+01    0.25813E+04    0.27748E-30    0.13720E-36    0.41868E-39
+    4    2    0.15405E-08    0.10000E+01    0.20817E+04    0.53588E-14    0.11825E-19    0.81165E-23
+    4    2    0.15405E-08    0.10000E+01    0.16788E+04    0.18294E-08    0.17577E-13    0.27783E-17
+    4    2    0.15405E-08    0.10000E+01    0.13538E+04    0.39398E-08    0.66820E-13    0.59871E-17
+    4    2    0.15405E-08    0.10000E+01    0.10918E+04    0.82916E-08    0.24924E-12    0.12607E-16
+    4    2    0.15405E-08    0.10000E+01    0.88049E+03    0.17067E-07    0.91768E-12    0.25959E-16
+    4    2    0.15405E-08    0.10000E+01    0.71007E+03    0.34437E-07    0.33414E-11    0.52389E-16
+    4    2    0.15405E-08    0.10000E+01    0.57264E+03    0.68290E-07    0.11887E-10    0.10390E-15
+    4    2    0.15405E-08    0.10000E+01    0.46180E+03    0.13319E-06    0.39977E-10    0.20266E-15
+    4    2    0.15405E-08    0.10000E+01    0.37242E+03    0.25425E-06    0.12189E-09    0.38686E-15
+    4    2    0.15405E-08    0.10000E+01    0.30034E+03    0.46963E-06    0.32691E-09    0.71457E-15
+    4    2    0.15405E-08    0.10000E+01    0.24221E+03    0.82741E-06    0.76330E-09    0.12589E-14
+    4    2    0.15405E-08    0.10000E+01    0.19533E+03    0.13040E-05    0.14505E-08    0.19840E-14
+    4    2    0.15405E-08    0.10000E+01    0.15752E+03    0.13040E-05    0.14505E-08    0.19840E-14
+    4    2    0.26880E-08    0.10000E+01    0.80645E+05    0.38571E-55    0.28748E-66    0.67365E-63
+    4    2    0.26880E-08    0.10000E+01    0.65036E+05    0.32529E-54    0.45528E-65    0.56867E-62
+    4    2    0.26880E-08    0.10000E+01    0.52449E+05    0.27558E-53    0.60676E-64    0.48226E-61
+    4    2    0.26880E-08    0.10000E+01    0.42297E+05    0.20595E-52    0.81194E-63    0.36115E-60
+    4    2    0.26880E-08    0.10000E+01    0.34111E+05    0.14666E-51    0.10875E-61    0.25815E-59
+    4    2    0.26880E-08    0.10000E+01    0.27509E+05    0.10310E-50    0.14226E-60    0.18251E-58
+    4    2    0.26880E-08    0.10000E+01    0.22184E+05    0.71280E-50    0.18328E-59    0.12660E-57
+    4    2    0.26880E-08    0.10000E+01    0.17891E+05    0.48638E-49    0.24447E-58    0.84938E-57
+    4    2    0.26880E-08    0.10000E+01    0.14428E+05    0.33991E-48    0.37416E-57    0.54601E-56
+    4    2    0.26880E-08    0.10000E+01    0.11635E+05    0.26516E-47    0.72263E-56    0.33655E-55
+    4    2    0.26880E-08    0.10000E+01    0.93834E+04    0.25505E-46    0.17267E-54    0.20427E-54
+    4    2    0.26880E-08    0.10000E+01    0.75673E+04    0.30540E-45    0.45936E-53    0.13637E-53
+    4    2    0.26880E-08    0.10000E+01    0.61026E+04    0.41589E-44    0.12562E-51    0.12337E-52
+    4    2    0.26880E-08    0.10000E+01    0.49215E+04    0.59145E-43    0.34306E-50    0.15497E-51
+    4    2    0.26880E-08    0.10000E+01    0.39689E+04    0.84583E-42    0.93192E-49    0.22125E-50
+    4    2    0.26880E-08    0.10000E+01    0.32008E+04    0.37920E-39    0.81639E-46    0.10020E-47
+    4    2    0.26880E-08    0.10000E+01    0.25813E+04    0.28073E-30    0.13847E-36    0.74073E-39
+    4    2    0.26880E-08    0.10000E+01    0.20817E+04    0.54029E-14    0.11879E-19    0.14155E-22
+    4    2    0.26880E-08    0.10000E+01    0.16788E+04    0.18404E-08    0.17620E-13    0.48065E-17
+    4    2    0.26880E-08    0.10000E+01    0.13538E+04    0.39581E-08    0.66958E-13    0.10259E-16
+    4    2    0.26880E-08    0.10000E+01    0.10918E+04    0.83222E-08    0.24969E-12    0.21468E-16
+    4    2    0.26880E-08    0.10000E+01    0.88049E+03    0.17119E-07    0.91920E-12    0.44017E-16
+    4    2    0.26880E-08    0.10000E+01    0.71007E+03    0.34524E-07    0.33466E-11    0.88551E-16
+    4    2    0.26880E-08    0.10000E+01    0.57264E+03    0.68439E-07    0.11904E-10    0.17519E-15
+    4    2    0.26880E-08    0.10000E+01    0.46180E+03    0.13344E-06    0.40034E-10    0.34104E-15
+    4    2    0.26880E-08    0.10000E+01    0.37242E+03    0.25469E-06    0.12206E-09    0.65007E-15
+    4    2    0.26880E-08    0.10000E+01    0.30034E+03    0.47040E-06    0.32737E-09    0.11994E-14
+    4    2    0.26880E-08    0.10000E+01    0.24221E+03    0.82870E-06    0.76436E-09    0.21115E-14
+    4    2    0.26880E-08    0.10000E+01    0.19533E+03    0.13060E-05    0.14525E-08    0.33261E-14
+    4    2    0.26880E-08    0.10000E+01    0.15752E+03    0.13060E-05    0.14525E-08    0.33261E-14
+    4    2    0.46905E-08    0.10000E+01    0.80645E+05    0.73029E-55    0.54464E-66    0.21533E-62
+    4    2    0.46905E-08    0.10000E+01    0.65036E+05    0.61621E-54    0.86299E-65    0.18185E-61
+    4    2    0.46905E-08    0.10000E+01    0.52449E+05    0.52233E-53    0.11516E-63    0.15428E-60
+    4    2    0.46905E-08    0.10000E+01    0.42297E+05    0.39077E-52    0.15447E-62    0.11562E-59
+    4    2    0.46905E-08    0.10000E+01    0.34111E+05    0.27882E-51    0.20760E-61    0.82775E-59
+    4    2    0.46905E-08    0.10000E+01    0.27509E+05    0.19656E-50    0.27200E-60    0.58681E-58
+    4    2    0.46905E-08    0.10000E+01    0.22184E+05    0.13606E-49    0.34575E-59    0.40911E-57
+    4    2    0.46905E-08    0.10000E+01    0.17891E+05    0.91848E-49    0.43457E-58    0.27689E-56
+    4    2    0.46905E-08    0.10000E+01    0.14428E+05    0.61201E-48    0.57575E-57    0.18033E-55
+    4    2    0.46905E-08    0.10000E+01    0.11635E+05    0.42282E-47    0.90211E-56    0.11260E-54
+    4    2    0.46905E-08    0.10000E+01    0.93834E+04    0.33488E-46    0.18328E-54    0.67652E-54
+    4    2    0.46905E-08    0.10000E+01    0.75673E+04    0.33668E-45    0.45834E-53    0.40928E-53
+    4    2    0.46905E-08    0.10000E+01    0.61026E+04    0.42185E-44    0.12441E-51    0.29651E-52
+    4    2    0.46905E-08    0.10000E+01    0.49215E+04    0.58812E-43    0.34115E-50    0.31131E-51
+    4    2    0.46905E-08    0.10000E+01    0.39689E+04    0.84116E-42    0.92897E-49    0.42014E-50
+    4    2    0.46905E-08    0.10000E+01    0.32008E+04    0.37783E-39    0.81387E-46    0.18794E-47
+    4    2    0.46905E-08    0.10000E+01    0.25813E+04    0.27975E-30    0.13790E-36    0.13712E-38
+    4    2    0.46905E-08    0.10000E+01    0.20817E+04    0.53805E-14    0.11809E-19    0.25674E-22
+    4    2    0.46905E-08    0.10000E+01    0.16788E+04    0.18324E-08    0.17499E-13    0.85979E-17
+    4    2    0.46905E-08    0.10000E+01    0.13538E+04    0.39366E-08    0.66482E-13    0.18141E-16
+    4    2    0.46905E-08    0.10000E+01    0.10918E+04    0.82714E-08    0.24785E-12    0.37672E-16
+    4    2    0.46905E-08    0.10000E+01    0.88049E+03    0.17007E-07    0.91221E-12    0.76822E-16
+    4    2    0.46905E-08    0.10000E+01    0.71007E+03    0.34286E-07    0.33205E-11    0.15394E-15
+    4    2    0.46905E-08    0.10000E+01    0.57264E+03    0.67948E-07    0.11810E-10    0.30368E-15
+    4    2    0.46905E-08    0.10000E+01    0.46180E+03    0.13246E-06    0.39712E-10    0.58987E-15
+    4    2    0.46905E-08    0.10000E+01    0.37242E+03    0.25276E-06    0.12107E-09    0.11226E-14
+    4    2    0.46905E-08    0.10000E+01    0.30034E+03    0.46675E-06    0.32471E-09    0.20689E-14
+    4    2    0.46905E-08    0.10000E+01    0.24221E+03    0.82218E-06    0.75813E-09    0.36393E-14
+    4    2    0.46905E-08    0.10000E+01    0.19533E+03    0.12956E-05    0.14406E-08    0.57299E-14
+    4    2    0.46905E-08    0.10000E+01    0.15752E+03    0.12956E-05    0.14406E-08    0.57299E-14
+    4    2    0.81846E-08    0.10000E+01    0.80645E+05    0.13742E-54    0.10255E-65    0.69136E-62
+    4    2    0.81846E-08    0.10000E+01    0.65036E+05    0.11601E-53    0.16256E-64    0.58409E-61
+    4    2    0.81846E-08    0.10000E+01    0.52449E+05    0.98380E-53    0.21717E-63    0.49571E-60
+    4    2    0.81846E-08    0.10000E+01    0.42297E+05    0.73671E-52    0.29191E-62    0.37176E-59
+    4    2    0.81846E-08    0.10000E+01    0.34111E+05    0.52659E-51    0.39366E-61    0.26648E-58
+    4    2    0.81846E-08    0.10000E+01    0.27509E+05    0.37233E-50    0.51805E-60    0.18934E-57
+    4    2    0.81846E-08    0.10000E+01    0.22184E+05    0.25866E-49    0.65886E-59    0.13253E-56
+    4    2    0.81846E-08    0.10000E+01    0.17891E+05    0.17472E-48    0.81293E-58    0.90326E-56
+    4    2    0.81846E-08    0.10000E+01    0.14428E+05    0.11477E-47    0.10027E-56    0.59485E-55
+    4    2    0.81846E-08    0.10000E+01    0.11635E+05    0.74870E-47    0.13325E-55    0.37699E-54
+    4    2    0.81846E-08    0.10000E+01    0.93834E+04    0.51568E-46    0.21829E-54    0.22882E-53
+    4    2    0.81846E-08    0.10000E+01    0.75673E+04    0.42270E-45    0.47730E-53    0.13418E-52
+    4    2    0.81846E-08    0.10000E+01    0.61026E+04    0.45404E-44    0.12504E-51    0.83931E-52
+    4    2    0.81846E-08    0.10000E+01    0.49215E+04    0.59778E-43    0.34280E-50    0.71170E-51
+    4    2    0.81846E-08    0.10000E+01    0.39689E+04    0.84666E-42    0.93513E-49    0.86202E-50
+    4    2    0.81846E-08    0.10000E+01    0.32008E+04    0.38018E-39    0.81779E-46    0.37451E-47
+    4    2    0.81846E-08    0.10000E+01    0.25813E+04    0.28089E-30    0.13796E-36    0.26762E-38
+    4    2    0.81846E-08    0.10000E+01    0.20817E+04    0.53804E-14    0.11735E-19    0.48558E-22
+    4    2    0.81846E-08    0.10000E+01    0.16788E+04    0.18279E-08    0.17336E-13    0.15881E-16
+    4    2    0.81846E-08    0.10000E+01    0.13538E+04    0.39156E-08    0.65815E-13    0.32833E-16
+    4    2    0.81846E-08    0.10000E+01    0.10918E+04    0.82123E-08    0.24522E-12    0.67235E-16
+    4    2    0.81846E-08    0.10000E+01    0.88049E+03    0.16864E-07    0.90210E-12    0.13576E-15
+    4    2    0.81846E-08    0.10000E+01    0.71007E+03    0.33966E-07    0.32825E-11    0.27007E-15
+    4    2    0.81846E-08    0.10000E+01    0.57264E+03    0.67266E-07    0.11672E-10    0.52991E-15
+    4    2    0.81846E-08    0.10000E+01    0.46180E+03    0.13105E-06    0.39241E-10    0.10252E-14
+    4    2    0.81846E-08    0.10000E+01    0.37242E+03    0.24998E-06    0.11962E-09    0.19454E-14
+    4    2    0.81846E-08    0.10000E+01    0.30034E+03    0.46148E-06    0.32080E-09    0.35779E-14
+    4    2    0.81846E-08    0.10000E+01    0.24221E+03    0.81271E-06    0.74898E-09    0.62847E-14
+    4    2    0.81846E-08    0.10000E+01    0.19533E+03    0.12805E-05    0.14232E-08    0.98864E-14
+    4    2    0.81846E-08    0.10000E+01    0.15752E+03    0.12805E-05    0.14232E-08    0.98864E-14
+    4    2    0.14282E-07    0.10000E+01    0.80645E+05    0.25665E-54    0.19161E-65    0.22083E-61
+    4    2    0.14282E-07    0.10000E+01    0.65036E+05    0.21675E-53    0.30386E-64    0.18663E-60
+    4    2    0.14282E-07    0.10000E+01    0.52449E+05    0.18389E-52    0.40635E-63    0.15844E-59
+    4    2    0.14282E-07    0.10000E+01    0.42297E+05    0.13781E-51    0.54717E-62    0.11889E-58
+    4    2    0.14282E-07    0.10000E+01    0.34111E+05    0.98655E-51    0.74010E-61    0.85317E-58
+    4    2    0.14282E-07    0.10000E+01    0.27509E+05    0.69936E-50    0.97849E-60    0.60732E-57
+    4    2    0.14282E-07    0.10000E+01    0.22184E+05    0.48778E-49    0.12510E-58    0.42648E-56
+    4    2    0.14282E-07    0.10000E+01    0.17891E+05    0.33096E-48    0.15434E-57    0.29229E-55
+    4    2    0.14282E-07    0.10000E+01    0.14428E+05    0.21749E-47    0.18598E-56    0.19422E-54
+    4    2    0.14282E-07    0.10000E+01    0.11635E+05    0.13936E-46    0.22632E-55    0.12469E-53
+    4    2    0.14282E-07    0.10000E+01    0.93834E+04    0.89465E-46    0.30633E-54    0.76816E-53
+    4    2    0.14282E-07    0.10000E+01    0.75673E+04    0.62324E-45    0.54642E-53    0.45068E-52
+    4    2    0.14282E-07    0.10000E+01    0.61026E+04    0.54706E-44    0.13095E-51    0.26282E-51
+    4    2    0.14282E-07    0.10000E+01    0.49215E+04    0.64118E-43    0.35403E-50    0.18591E-50
+    4    2    0.14282E-07    0.10000E+01    0.39689E+04    0.87928E-42    0.96516E-49    0.19409E-49
+    4    2    0.14282E-07    0.10000E+01    0.32008E+04    0.39247E-39    0.84012E-46    0.80196E-47
+    4    2    0.14282E-07    0.10000E+01    0.25813E+04    0.28823E-30    0.14034E-36    0.55795E-38
+    4    2    0.14282E-07    0.10000E+01    0.20817E+04    0.54685E-14    0.11759E-19    0.97319E-22
+    4    2    0.14282E-07    0.10000E+01    0.16788E+04    0.18459E-08    0.17249E-13    0.30767E-16
+    4    2    0.14282E-07    0.10000E+01    0.13538E+04    0.39304E-08    0.65385E-13    0.61604E-16
+    4    2    0.14282E-07    0.10000E+01    0.10918E+04    0.82108E-08    0.24333E-12    0.12330E-15
+    4    2    0.14282E-07    0.10000E+01    0.88049E+03    0.16815E-07    0.89436E-12    0.24486E-15
+    4    2    0.14282E-07    0.10000E+01    0.71007E+03    0.33800E-07    0.32522E-11    0.48114E-15
+    4    2    0.14282E-07    0.10000E+01    0.57264E+03    0.66837E-07    0.11559E-10    0.93534E-15
+    4    2    0.14282E-07    0.10000E+01    0.46180E+03    0.13007E-06    0.38850E-10    0.17971E-14
+    4    2    0.14282E-07    0.10000E+01    0.37242E+03    0.24790E-06    0.11841E-09    0.33927E-14
+    4    2    0.14282E-07    0.10000E+01    0.30034E+03    0.45737E-06    0.31751E-09    0.62174E-14
+    4    2    0.14282E-07    0.10000E+01    0.24221E+03    0.80514E-06    0.74125E-09    0.10894E-13
+    4    2    0.14282E-07    0.10000E+01    0.19533E+03    0.12683E-05    0.14085E-08    0.17112E-13
+    4    2    0.14282E-07    0.10000E+01    0.15752E+03    0.12683E-05    0.14085E-08    0.17112E-13
+    4    2    0.24920E-07    0.10000E+01    0.80645E+05    0.47601E-54    0.35556E-65    0.70510E-61
+    4    2    0.24920E-07    0.10000E+01    0.65036E+05    0.40216E-53    0.56402E-64    0.59610E-60
+    4    2    0.24920E-07    0.10000E+01    0.52449E+05    0.34131E-52    0.75490E-63    0.50621E-59
+    4    2    0.24920E-07    0.10000E+01    0.42297E+05    0.25597E-51    0.10180E-61    0.38006E-58
+    4    2    0.24920E-07    0.10000E+01    0.34111E+05    0.18348E-50    0.13805E-60    0.27299E-57
+    4    2    0.24920E-07    0.10000E+01    0.27509E+05    0.13035E-49    0.18329E-59    0.19464E-56
+    4    2    0.24920E-07    0.10000E+01    0.22184E+05    0.91248E-49    0.23579E-58    0.13705E-55
+    4    2    0.24920E-07    0.10000E+01    0.17891E+05    0.62240E-48    0.29278E-57    0.94356E-55
+    4    2    0.24920E-07    0.10000E+01    0.14428E+05    0.41128E-47    0.35240E-56    0.63148E-54
+    4    2    0.24920E-07    0.10000E+01    0.11635E+05    0.26351E-46    0.41513E-55    0.40974E-53
+    4    2    0.24920E-07    0.10000E+01    0.93834E+04    0.16502E-45    0.49944E-54    0.25605E-52
+    4    2    0.24920E-07    0.10000E+01    0.75673E+04    0.10471E-44    0.71765E-53    0.15197E-51
+    4    2    0.24920E-07    0.10000E+01    0.61026E+04    0.76124E-44    0.14664E-51    0.86530E-51
+    4    2    0.24920E-07    0.10000E+01    0.49215E+04    0.74858E-43    0.37974E-50    0.54177E-50
+    4    2    0.24920E-07    0.10000E+01    0.39689E+04    0.95571E-42    0.10289E-48    0.48250E-49
+    4    2    0.24920E-07    0.10000E+01    0.32008E+04    0.41919E-39    0.88807E-46    0.18579E-46
+    4    2    0.24920E-07    0.10000E+01    0.25813E+04    0.30426E-30    0.14577E-36    0.12546E-37
+    4    2    0.24920E-07    0.10000E+01    0.20817E+04    0.56734E-14    0.11869E-19    0.21002E-21
+    4    2    0.24920E-07    0.10000E+01    0.16788E+04    0.18909E-08    0.17168E-13    0.63698E-16
+    4    2    0.24920E-07    0.10000E+01    0.13538E+04    0.39802E-08    0.64889E-13    0.12190E-15
+    4    2    0.24920E-07    0.10000E+01    0.10918E+04    0.82513E-08    0.24096E-12    0.23580E-15
+    4    2    0.24920E-07    0.10000E+01    0.88049E+03    0.16807E-07    0.88418E-12    0.45625E-15
+    4    2    0.24920E-07    0.10000E+01    0.71007E+03    0.33655E-07    0.32114E-11    0.87884E-15
+    4    2    0.24920E-07    0.10000E+01    0.57264E+03    0.66361E-07    0.11405E-10    0.16825E-14
+    4    2    0.24920E-07    0.10000E+01    0.46180E+03    0.12887E-06    0.38312E-10    0.31953E-14
+    4    2    0.24920E-07    0.10000E+01    0.37242E+03    0.24523E-06    0.11674E-09    0.59804E-14
+    4    2    0.24920E-07    0.10000E+01    0.30034E+03    0.45193E-06    0.31297E-09    0.10892E-13
+    4    2    0.24920E-07    0.10000E+01    0.24221E+03    0.79497E-06    0.73056E-09    0.19004E-13
+    4    2    0.24920E-07    0.10000E+01    0.19533E+03    0.12517E-05    0.13881E-08    0.29771E-13
+    4    2    0.24920E-07    0.10000E+01    0.15752E+03    0.12517E-05    0.13881E-08    0.29771E-13
+    4    2    0.43485E-07    0.10000E+01    0.80645E+05    0.87633E-54    0.65486E-65    0.22327E-60
+    4    2    0.43485E-07    0.10000E+01    0.65036E+05    0.74064E-53    0.10391E-63    0.18881E-59
+    4    2    0.43485E-07    0.10000E+01    0.52449E+05    0.62877E-52    0.13918E-62    0.16038E-58
+    4    2    0.43485E-07    0.10000E+01    0.42297E+05    0.47183E-51    0.18793E-61    0.12047E-57
+    4    2    0.43485E-07    0.10000E+01    0.34111E+05    0.33857E-50    0.25539E-60    0.86600E-57
+    4    2    0.43485E-07    0.10000E+01    0.27509E+05    0.24100E-49    0.34031E-59    0.61828E-56
+    4    2    0.43485E-07    0.10000E+01    0.22184E+05    0.16923E-48    0.44031E-58    0.43635E-55
+    4    2    0.43485E-07    0.10000E+01    0.17891E+05    0.11600E-47    0.55098E-57    0.30154E-54
+    4    2    0.43485E-07    0.10000E+01    0.14428E+05    0.77161E-47    0.66781E-56    0.20298E-53
+    4    2    0.43485E-07    0.10000E+01    0.11635E+05    0.49749E-46    0.78327E-55    0.13283E-52
+    4    2    0.43485E-07    0.10000E+01    0.93834E+04    0.31076E-45    0.89540E-54    0.84010E-52
+    4    2    0.43485E-07    0.10000E+01    0.75673E+04    0.18972E-44    0.10962E-52    0.50555E-51
+    4    2    0.43485E-07    0.10000E+01    0.61026E+04    0.12152E-43    0.18279E-51    0.28738E-50
+    4    2    0.43485E-07    0.10000E+01    0.49215E+04    0.98640E-43    0.43398E-50    0.16798E-49
+    4    2    0.43485E-07    0.10000E+01    0.39689E+04    0.11193E-41    0.11567E-48    0.13023E-48
+    4    2    0.43485E-07    0.10000E+01    0.32008E+04    0.47375E-39    0.98610E-46    0.46169E-46
+    4    2    0.43485E-07    0.10000E+01    0.25813E+04    0.33753E-30    0.15766E-36    0.30272E-37
+    4    2    0.43485E-07    0.10000E+01    0.20817E+04    0.61318E-14    0.12243E-19    0.48977E-21
+    4    2    0.43485E-07    0.10000E+01    0.16788E+04    0.20013E-08    0.17272E-13    0.14245E-15
+    4    2    0.43485E-07    0.10000E+01    0.13538E+04    0.41298E-08    0.64942E-13    0.25806E-15
+    4    2    0.43485E-07    0.10000E+01    0.10918E+04    0.84467E-08    0.24021E-12    0.47730E-15
+    4    2    0.43485E-07    0.10000E+01    0.88049E+03    0.17042E-07    0.87893E-12    0.89064E-15
+    4    2    0.43485E-07    0.10000E+01    0.71007E+03    0.33889E-07    0.31858E-11    0.16662E-14
+    4    2    0.43485E-07    0.10000E+01    0.57264E+03    0.66480E-07    0.11298E-10    0.31162E-14
+    4    2    0.43485E-07    0.10000E+01    0.46180E+03    0.12861E-06    0.37920E-10    0.58103E-14
+    4    2    0.43485E-07    0.10000E+01    0.37242E+03    0.24405E-06    0.11548E-09    0.10724E-13
+    4    2    0.43485E-07    0.10000E+01    0.30034E+03    0.44889E-06    0.30950E-09    0.19334E-13
+    4    2    0.43485E-07    0.10000E+01    0.24221E+03    0.78854E-06    0.72233E-09    0.33495E-13
+    4    2    0.43485E-07    0.10000E+01    0.19533E+03    0.12405E-05    0.13723E-08    0.52243E-13
+    4    2    0.43485E-07    0.10000E+01    0.15752E+03    0.12405E-05    0.13723E-08    0.52243E-13
+    4    2    0.75878E-07    0.10000E+01    0.80645E+05    0.16027E-53    0.11981E-64    0.70325E-60
+    4    2    0.75878E-07    0.10000E+01    0.65036E+05    0.13549E-52    0.19016E-63    0.59486E-59
+    4    2    0.75878E-07    0.10000E+01    0.52449E+05    0.11506E-51    0.25486E-62    0.50539E-58
+    4    2    0.75878E-07    0.10000E+01    0.42297E+05    0.86387E-51    0.34452E-61    0.37977E-57
+    4    2    0.75878E-07    0.10000E+01    0.34111E+05    0.62048E-50    0.46903E-60    0.27320E-56
+    4    2    0.75878E-07    0.10000E+01    0.27509E+05    0.44237E-49    0.62690E-59    0.19528E-55
+    4    2    0.75878E-07    0.10000E+01    0.22184E+05    0.31146E-48    0.81519E-58    0.13808E-54
+    4    2    0.75878E-07    0.10000E+01    0.17891E+05    0.21440E-47    0.10276E-56    0.95717E-54
+    4    2    0.75878E-07    0.10000E+01    0.14428E+05    0.14351E-46    0.12565E-55    0.64739E-53
+    4    2    0.75878E-07    0.10000E+01    0.11635E+05    0.93247E-46    0.14834E-54    0.42660E-52
+    4    2    0.75878E-07    0.10000E+01    0.93834E+04    0.58599E-45    0.16732E-53    0.27249E-51
+    4    2    0.75878E-07    0.10000E+01    0.75673E+04    0.35441E-44    0.18739E-52    0.16611E-50
+    4    2    0.75878E-07    0.10000E+01    0.61026E+04    0.21253E-43    0.25787E-51    0.95128E-50
+    4    2    0.75878E-07    0.10000E+01    0.49215E+04    0.14712E-42    0.53682E-50    0.53722E-49
+    4    2    0.75878E-07    0.10000E+01    0.39689E+04    0.14366E-41    0.13856E-48    0.37413E-48
+    4    2    0.75878E-07    0.10000E+01    0.32008E+04    0.57357E-39    0.11632E-45    0.12174E-45
+    4    2    0.75878E-07    0.10000E+01    0.25813E+04    0.39839E-30    0.17981E-36    0.77652E-37
+    4    2    0.75878E-07    0.10000E+01    0.20817E+04    0.70006E-14    0.13015E-19    0.12290E-20
+    4    2    0.75878E-07    0.10000E+01    0.16788E+04    0.22168E-08    0.17614E-13    0.34508E-15
+    4    2    0.75878E-07    0.10000E+01    0.13538E+04    0.44340E-08    0.65631E-13    0.59027E-15
+    4    2    0.75878E-07    0.10000E+01    0.10918E+04    0.88711E-08    0.24113E-12    0.10371E-14
+    4    2    0.75878E-07    0.10000E+01    0.88049E+03    0.17615E-07    0.87791E-12    0.18502E-14
+    4    2    0.75878E-07    0.10000E+01    0.71007E+03    0.34617E-07    0.31709E-11    0.33295E-14
+    4    2    0.75878E-07    0.10000E+01    0.57264E+03    0.67310E-07    0.11218E-10    0.60257E-14
+    4    2    0.75878E-07    0.10000E+01    0.46180E+03    0.12936E-06    0.37595E-10    0.10935E-13
+    4    2    0.75878E-07    0.10000E+01    0.37242E+03    0.24429E-06    0.11438E-09    0.19754E-13
+    4    2    0.75878E-07    0.10000E+01    0.30034E+03    0.44778E-06    0.30640E-09    0.35046E-13
+    4    2    0.75878E-07    0.10000E+01    0.24221E+03    0.78476E-06    0.71487E-09    0.60021E-13
+    4    2    0.75878E-07    0.10000E+01    0.19533E+03    0.12328E-05    0.13579E-08    0.92945E-13
+    4    2    0.75878E-07    0.10000E+01    0.15752E+03    0.12328E-05    0.13579E-08    0.92945E-13
+    4    2    0.13240E-06    0.10000E+01    0.80645E+05    0.29137E-53    0.21789E-64    0.22067E-59
+    4    2    0.13240E-06    0.10000E+01    0.65036E+05    0.24640E-52    0.34591E-63    0.18670E-58
+    4    2    0.13240E-06    0.10000E+01    0.52449E+05    0.20929E-51    0.46386E-62    0.15865E-57
+    4    2    0.13240E-06    0.10000E+01    0.42297E+05    0.15721E-50    0.62765E-61    0.11925E-56
+    4    2    0.13240E-06    0.10000E+01    0.34111E+05    0.11301E-49    0.85579E-60    0.85842E-56
+    4    2    0.13240E-06    0.10000E+01    0.27509E+05    0.80678E-49    0.11468E-58    0.61421E-55
+    4    2    0.13240E-06    0.10000E+01    0.22184E+05    0.56932E-48    0.14977E-57    0.43501E-54
+    4    2    0.13240E-06    0.10000E+01    0.17891E+05    0.39335E-47    0.18999E-56    0.30233E-53
+    4    2    0.13240E-06    0.10000E+01    0.14428E+05    0.26474E-46    0.23430E-55    0.20529E-52
+    4    2    0.13240E-06    0.10000E+01    0.11635E+05    0.17329E-45    0.27928E-54    0.13605E-51
+    4    2    0.13240E-06    0.10000E+01    0.93834E+04    0.10983E-44    0.31611E-53    0.87603E-51
+    4    2    0.13240E-06    0.10000E+01    0.75673E+04    0.66654E-44    0.34093E-52    0.54009E-50
+    4    2    0.13240E-06    0.10000E+01    0.61026E+04    0.38921E-43    0.40702E-51    0.31250E-49
+    4    2    0.13240E-06    0.10000E+01    0.49215E+04    0.24217E-42    0.72513E-50    0.17389E-48
+    4    2    0.13240E-06    0.10000E+01    0.39689E+04    0.20301E-41    0.17791E-48    0.11209E-47
+    4    2    0.13240E-06    0.10000E+01    0.32008E+04    0.74916E-39    0.14684E-45    0.33618E-45
+    4    2    0.13240E-06    0.10000E+01    0.25813E+04    0.50473E-30    0.21879E-36    0.20907E-36
+    4    2    0.13240E-06    0.10000E+01    0.20817E+04    0.85591E-14    0.14433E-19    0.32772E-20
+    4    2    0.13240E-06    0.10000E+01    0.16788E+04    0.26103E-08    0.18318E-13    0.89789E-15
+    4    2    0.13240E-06    0.10000E+01    0.13538E+04    0.49952E-08    0.67242E-13    0.14582E-14
+    4    2    0.13240E-06    0.10000E+01    0.10918E+04    0.96686E-08    0.24426E-12    0.24354E-14
+    4    2    0.13240E-06    0.10000E+01    0.88049E+03    0.18725E-07    0.88188E-12    0.41389E-14
+    4    2    0.13240E-06    0.10000E+01    0.71007E+03    0.36105E-07    0.31660E-11    0.71174E-14
+    4    2    0.13240E-06    0.10000E+01    0.57264E+03    0.69188E-07    0.11155E-10    0.12357E-13
+    4    2    0.13240E-06    0.10000E+01    0.46180E+03    0.13150E-06    0.37285E-10    0.21619E-13
+    4    2    0.13240E-06    0.10000E+01    0.37242E+03    0.24631E-06    0.11326E-09    0.37879E-13
+    4    2    0.13240E-06    0.10000E+01    0.30034E+03    0.44884E-06    0.30311E-09    0.65608E-13
+    4    2    0.13240E-06    0.10000E+01    0.24221E+03    0.78344E-06    0.70680E-09    0.11039E-12
+    4    2    0.13240E-06    0.10000E+01    0.19533E+03    0.12277E-05    0.13421E-08    0.16900E-12
+    4    2    0.13240E-06    0.10000E+01    0.15752E+03    0.12277E-05    0.13421E-08    0.16900E-12
+    4    2    0.23103E-06    0.10000E+01    0.80645E+05    0.52581E-53    0.39333E-64    0.67593E-59
+    4    2    0.23103E-06    0.10000E+01    0.65036E+05    0.44476E-52    0.62453E-63    0.57198E-58
+    4    2    0.23103E-06    0.10000E+01    0.52449E+05    0.37786E-51    0.83790E-62    0.48612E-57
+    4    2    0.23103E-06    0.10000E+01    0.42297E+05    0.28394E-50    0.11347E-60    0.36552E-56
+    4    2    0.23103E-06    0.10000E+01    0.34111E+05    0.20425E-49    0.15491E-59    0.26324E-55
+    4    2    0.23103E-06    0.10000E+01    0.27509E+05    0.14599E-48    0.20805E-58    0.18851E-54
+    4    2    0.23103E-06    0.10000E+01    0.22184E+05    0.10321E-47    0.27266E-57    0.13368E-53
+    4    2    0.23103E-06    0.10000E+01    0.17891E+05    0.71531E-47    0.34776E-56    0.93104E-53
+    4    2    0.23103E-06    0.10000E+01    0.14428E+05    0.48367E-46    0.43203E-55    0.63420E-52
+    4    2    0.23103E-06    0.10000E+01    0.11635E+05    0.31864E-45    0.51986E-54    0.42216E-51
+    4    2    0.23103E-06    0.10000E+01    0.93834E+04    0.20362E-44    0.59394E-53    0.27357E-50
+    4    2    0.23103E-06    0.10000E+01    0.75673E+04    0.12456E-43    0.63452E-52    0.17020E-49
+    4    2    0.23103E-06    0.10000E+01    0.61026E+04    0.72302E-43    0.69477E-51    0.99468E-49
+    4    2    0.23103E-06    0.10000E+01    0.49215E+04    0.42350E-42    0.10669E-49    0.55111E-48
+    4    2    0.23103E-06    0.10000E+01    0.39689E+04    0.31243E-41    0.24504E-48    0.33728E-47
+    4    2    0.23103E-06    0.10000E+01    0.32008E+04    0.10553E-38    0.19888E-45    0.94331E-45
+    4    2    0.23103E-06    0.10000E+01    0.25813E+04    0.68859E-30    0.28662E-36    0.57357E-36
+    4    2    0.23103E-06    0.10000E+01    0.20817E+04    0.11323E-13    0.17014E-19    0.89867E-20
+    4    2    0.23103E-06    0.10000E+01    0.16788E+04    0.33213E-08    0.19743E-13    0.24287E-14
+    4    2    0.23103E-06    0.10000E+01    0.13538E+04    0.60205E-08    0.70832E-13    0.37885E-14
+    4    2    0.23103E-06    0.10000E+01    0.10918E+04    0.11154E-07    0.25271E-12    0.60652E-14
+    4    2    0.23103E-06    0.10000E+01    0.88049E+03    0.20856E-07    0.89997E-12    0.98662E-14
+    4    2    0.23103E-06    0.10000E+01    0.71007E+03    0.39098E-07    0.31989E-11    0.16226E-13
+    4    2    0.23103E-06    0.10000E+01    0.57264E+03    0.73266E-07    0.11193E-10    0.26951E-13
+    4    2    0.23103E-06    0.10000E+01    0.46180E+03    0.13684E-06    0.37248E-10    0.45199E-13
+    4    2    0.23103E-06    0.10000E+01    0.37242E+03    0.25292E-06    0.11285E-09    0.76239E-13
+    4    2    0.23103E-06    0.10000E+01    0.30034E+03    0.45647E-06    0.30152E-09    0.12792E-12
+    4    2    0.23103E-06    0.10000E+01    0.24221E+03    0.79141E-06    0.70241E-09    0.20999E-12
+    4    2    0.23103E-06    0.10000E+01    0.19533E+03    0.12350E-05    0.13331E-08    0.31627E-12
+    4    2    0.23103E-06    0.10000E+01    0.15752E+03    0.12350E-05    0.13331E-08    0.31627E-12
+    4    2    0.40314E-06    0.10000E+01    0.80645E+05    0.92050E-53    0.68860E-64    0.12579E-58
+    4    2    0.40314E-06    0.10000E+01    0.65036E+05    0.77864E-52    0.10934E-62    0.10644E-57
+    4    2    0.40314E-06    0.10000E+01    0.52449E+05    0.66154E-51    0.14670E-61    0.90468E-57
+    4    2    0.40314E-06    0.10000E+01    0.42297E+05    0.49712E-50    0.19868E-60    0.68026E-56
+    4    2    0.40314E-06    0.10000E+01    0.34111E+05    0.35763E-49    0.27129E-59    0.48994E-55
+    4    2    0.40314E-06    0.10000E+01    0.27509E+05    0.25565E-48    0.36443E-58    0.35087E-54
+    4    2    0.40314E-06    0.10000E+01    0.22184E+05    0.18078E-47    0.47779E-57    0.24886E-53
+    4    2    0.40314E-06    0.10000E+01    0.17891E+05    0.12533E-46    0.60974E-56    0.17336E-52
+    4    2    0.40314E-06    0.10000E+01    0.14428E+05    0.84786E-46    0.75811E-55    0.11812E-51
+    4    2    0.40314E-06    0.10000E+01    0.11635E+05    0.55896E-45    0.91320E-54    0.78667E-51
+    4    2    0.40314E-06    0.10000E+01    0.93834E+04    0.35753E-44    0.10446E-52    0.51011E-50
+    4    2    0.40314E-06    0.10000E+01    0.75673E+04    0.21895E-43    0.11159E-51    0.31765E-49
+    4    2    0.40314E-06    0.10000E+01    0.61026E+04    0.12709E-42    0.12129E-50    0.18585E-48
+    4    2    0.40314E-06    0.10000E+01    0.49215E+04    0.74073E-42    0.18325E-49    0.10296E-47
+    4    2    0.40314E-06    0.10000E+01    0.39689E+04    0.53933E-41    0.41724E-48    0.62707E-47
+    4    2    0.40314E-06    0.10000E+01    0.32008E+04    0.18023E-38    0.33797E-45    0.17410E-44
+    4    2    0.40314E-06    0.10000E+01    0.25813E+04    0.11715E-29    0.48536E-36    0.10560E-35
+    4    2    0.40314E-06    0.10000E+01    0.20817E+04    0.19204E-13    0.28442E-19    0.16551E-19
+    4    2    0.40314E-06    0.10000E+01    0.16788E+04    0.56078E-08    0.32597E-13    0.44681E-14
+    4    2    0.40314E-06    0.10000E+01    0.13538E+04    0.10096E-07    0.11655E-12    0.69424E-14
+    4    2    0.40314E-06    0.10000E+01    0.10918E+04    0.18594E-07    0.41469E-12    0.11067E-13
+    4    2    0.40314E-06    0.10000E+01    0.88049E+03    0.34598E-07    0.14737E-11    0.17919E-13
+    4    2    0.40314E-06    0.10000E+01    0.71007E+03    0.64599E-07    0.52300E-11    0.29327E-13
+    4    2    0.40314E-06    0.10000E+01    0.57264E+03    0.12065E-06    0.18280E-10    0.48461E-13
+    4    2    0.40314E-06    0.10000E+01    0.46180E+03    0.22475E-06    0.60789E-10    0.80857E-13
+    4    2    0.40314E-06    0.10000E+01    0.37242E+03    0.41456E-06    0.18409E-09    0.13573E-12
+    4    2    0.40314E-06    0.10000E+01    0.30034E+03    0.74708E-06    0.49175E-09    0.22680E-12
+    4    2    0.40314E-06    0.10000E+01    0.24221E+03    0.12939E-05    0.11454E-08    0.37106E-12
+    4    2    0.40314E-06    0.10000E+01    0.19533E+03    0.20178E-05    0.21736E-08    0.55757E-12
+    4    2    0.40314E-06    0.10000E+01    0.15752E+03    0.20178E-05    0.21736E-08    0.55757E-12
+    4    2    0.70346E-06    0.10000E+01    0.80645E+05    0.16062E-52    0.12016E-63    0.21949E-58
+    4    2    0.70346E-06    0.10000E+01    0.65036E+05    0.13587E-51    0.19079E-62    0.18574E-57
+    4    2    0.70346E-06    0.10000E+01    0.52449E+05    0.11543E-50    0.25599E-61    0.15786E-56
+    4    2    0.70346E-06    0.10000E+01    0.42297E+05    0.86745E-50    0.34669E-60    0.11870E-55
+    4    2    0.70346E-06    0.10000E+01    0.34111E+05    0.62405E-49    0.47339E-59    0.85491E-55
+    4    2    0.70346E-06    0.10000E+01    0.27509E+05    0.44609E-48    0.63590E-58    0.61225E-54
+    4    2    0.70346E-06    0.10000E+01    0.22184E+05    0.31545E-47    0.83372E-57    0.43425E-53
+    4    2    0.70346E-06    0.10000E+01    0.17891E+05    0.21869E-46    0.10640E-55    0.30250E-52
+    4    2    0.70346E-06    0.10000E+01    0.14428E+05    0.14795E-45    0.13228E-54    0.20612E-51
+    4    2    0.70346E-06    0.10000E+01    0.11635E+05    0.97536E-45    0.15935E-53    0.13727E-50
+    4    2    0.70346E-06    0.10000E+01    0.93834E+04    0.62386E-44    0.18228E-52    0.89011E-50
+    4    2    0.70346E-06    0.10000E+01    0.75673E+04    0.38205E-43    0.19472E-51    0.55428E-49
+    4    2    0.70346E-06    0.10000E+01    0.61026E+04    0.22176E-42    0.21165E-50    0.32429E-48
+    4    2    0.70346E-06    0.10000E+01    0.49215E+04    0.12925E-41    0.31975E-49    0.17965E-47
+    4    2    0.70346E-06    0.10000E+01    0.39689E+04    0.94109E-41    0.72805E-48    0.10942E-46
+    4    2    0.70346E-06    0.10000E+01    0.32008E+04    0.31449E-38    0.58973E-45    0.30379E-44
+    4    2    0.70346E-06    0.10000E+01    0.25813E+04    0.20442E-29    0.84692E-36    0.18426E-35
+    4    2    0.70346E-06    0.10000E+01    0.20817E+04    0.33510E-13    0.49630E-19    0.28880E-19
+    4    2    0.70346E-06    0.10000E+01    0.16788E+04    0.97853E-08    0.56880E-13    0.77966E-14
+    4    2    0.70346E-06    0.10000E+01    0.13538E+04    0.17616E-07    0.20337E-12    0.12114E-13
+    4    2    0.70346E-06    0.10000E+01    0.10918E+04    0.32446E-07    0.72361E-12    0.19311E-13
+    4    2    0.70346E-06    0.10000E+01    0.88049E+03    0.60372E-07    0.25715E-11    0.31268E-13
+    4    2    0.70346E-06    0.10000E+01    0.71007E+03    0.11272E-06    0.91260E-11    0.51173E-13
+    4    2    0.70346E-06    0.10000E+01    0.57264E+03    0.21053E-06    0.31898E-10    0.84562E-13
+    4    2    0.70346E-06    0.10000E+01    0.46180E+03    0.39218E-06    0.10607E-09    0.14109E-12
+    4    2    0.70346E-06    0.10000E+01    0.37242E+03    0.72339E-06    0.32122E-09    0.23684E-12
+    4    2    0.70346E-06    0.10000E+01    0.30034E+03    0.13036E-05    0.85808E-09    0.39574E-12
+    4    2    0.70346E-06    0.10000E+01    0.24221E+03    0.22577E-05    0.19986E-08    0.64747E-12
+    4    2    0.70346E-06    0.10000E+01    0.19533E+03    0.35209E-05    0.37928E-08    0.97293E-12
+    4    2    0.70346E-06    0.10000E+01    0.15752E+03    0.35209E-05    0.37928E-08    0.97293E-12
+    4    2    0.12275E-05    0.10000E+01    0.80645E+05    0.28028E-52    0.20966E-63    0.38300E-58
+    4    2    0.12275E-05    0.10000E+01    0.65036E+05    0.23708E-51    0.33292E-62    0.32410E-57
+    4    2    0.12275E-05    0.10000E+01    0.52449E+05    0.20143E-50    0.44668E-61    0.27546E-56
+    4    2    0.12275E-05    0.10000E+01    0.42297E+05    0.15136E-49    0.60495E-60    0.20713E-55
+    4    2    0.12275E-05    0.10000E+01    0.34111E+05    0.10889E-48    0.82603E-59    0.14918E-54
+    4    2    0.12275E-05    0.10000E+01    0.27509E+05    0.77840E-48    0.11096E-57    0.10683E-53
+    4    2    0.12275E-05    0.10000E+01    0.22184E+05    0.55044E-47    0.14548E-56    0.75774E-53
+    4    2    0.12275E-05    0.10000E+01    0.17891E+05    0.38161E-46    0.18565E-55    0.52785E-52
+    4    2    0.12275E-05    0.10000E+01    0.14428E+05    0.25816E-45    0.23083E-54    0.35967E-51
+    4    2    0.12275E-05    0.10000E+01    0.11635E+05    0.17019E-44    0.27805E-53    0.23953E-50
+    4    2    0.12275E-05    0.10000E+01    0.93834E+04    0.10886E-43    0.31807E-52    0.15532E-49
+    4    2    0.12275E-05    0.10000E+01    0.75673E+04    0.66665E-43    0.33977E-51    0.96719E-49
+    4    2    0.12275E-05    0.10000E+01    0.61026E+04    0.38696E-42    0.36931E-50    0.56587E-48
+    4    2    0.12275E-05    0.10000E+01    0.49215E+04    0.22554E-41    0.55795E-49    0.31348E-47
+    4    2    0.12275E-05    0.10000E+01    0.39689E+04    0.16421E-40    0.12704E-47    0.19093E-46
+    4    2    0.12275E-05    0.10000E+01    0.32008E+04    0.54876E-38    0.10291E-44    0.53009E-44
+    4    2    0.12275E-05    0.10000E+01    0.25813E+04    0.35670E-29    0.14778E-35    0.32153E-35
+    4    2    0.12275E-05    0.10000E+01    0.20817E+04    0.58472E-13    0.86601E-19    0.50393E-19
+    4    2    0.12275E-05    0.10000E+01    0.16788E+04    0.17075E-07    0.99253E-13    0.13605E-13
+    4    2    0.12275E-05    0.10000E+01    0.13538E+04    0.30739E-07    0.35488E-12    0.21138E-13
+    4    2    0.12275E-05    0.10000E+01    0.10918E+04    0.56616E-07    0.12627E-11    0.33696E-13
+    4    2    0.12275E-05    0.10000E+01    0.88049E+03    0.10535E-06    0.44872E-11    0.54561E-13
+    4    2    0.12275E-05    0.10000E+01    0.71007E+03    0.19669E-06    0.15924E-10    0.89294E-13
+    4    2    0.12275E-05    0.10000E+01    0.57264E+03    0.36737E-06    0.55660E-10    0.14756E-12
+    4    2    0.12275E-05    0.10000E+01    0.46180E+03    0.68433E-06    0.18509E-09    0.24619E-12
+    4    2    0.12275E-05    0.10000E+01    0.37242E+03    0.12623E-05    0.56052E-09    0.41328E-12
+    4    2    0.12275E-05    0.10000E+01    0.30034E+03    0.22747E-05    0.14973E-08    0.69055E-12
+    4    2    0.12275E-05    0.10000E+01    0.24221E+03    0.39396E-05    0.34875E-08    0.11298E-11
+    4    2    0.12275E-05    0.10000E+01    0.19533E+03    0.61438E-05    0.66182E-08    0.16977E-11
+    4    2    0.12275E-05    0.10000E+01    0.15752E+03    0.61438E-05    0.66182E-08    0.16977E-11
+    4    2    0.21419E-05    0.10000E+01    0.80645E+05    0.48907E-52    0.36585E-63    0.66831E-58
+    4    2    0.21419E-05    0.10000E+01    0.65036E+05    0.41369E-51    0.58092E-62    0.56554E-57
+    4    2    0.21419E-05    0.10000E+01    0.52449E+05    0.35148E-50    0.77943E-61    0.48066E-56
+    4    2    0.21419E-05    0.10000E+01    0.42297E+05    0.26412E-49    0.10556E-59    0.36142E-55
+    4    2    0.21419E-05    0.10000E+01    0.34111E+05    0.19001E-48    0.14414E-58    0.26031E-54
+    4    2    0.21419E-05    0.10000E+01    0.27509E+05    0.13583E-47    0.19362E-57    0.18642E-53
+    4    2    0.21419E-05    0.10000E+01    0.22184E+05    0.96049E-47    0.25385E-56    0.13222E-52
+    4    2    0.21419E-05    0.10000E+01    0.17891E+05    0.66588E-46    0.32396E-55    0.92106E-52
+    4    2    0.21419E-05    0.10000E+01    0.14428E+05    0.45047E-45    0.40278E-54    0.62760E-51
+    4    2    0.21419E-05    0.10000E+01    0.11635E+05    0.29698E-44    0.48518E-53    0.41796E-50
+    4    2    0.21419E-05    0.10000E+01    0.93834E+04    0.18995E-43    0.55502E-52    0.27102E-49
+    4    2    0.21419E-05    0.10000E+01    0.75673E+04    0.11633E-42    0.59288E-51    0.16877E-48
+    4    2    0.21419E-05    0.10000E+01    0.61026E+04    0.67523E-42    0.64443E-50    0.98741E-48
+    4    2    0.21419E-05    0.10000E+01    0.49215E+04    0.39355E-41    0.97359E-49    0.54701E-47
+    4    2    0.21419E-05    0.10000E+01    0.39689E+04    0.28654E-40    0.22168E-47    0.33317E-46
+    4    2    0.21419E-05    0.10000E+01    0.32008E+04    0.95755E-38    0.17956E-44    0.92498E-44
+    4    2    0.21419E-05    0.10000E+01    0.25813E+04    0.62242E-29    0.25787E-35    0.56105E-35
+    4    2    0.21419E-05    0.10000E+01    0.20817E+04    0.10203E-12    0.15111E-18    0.87933E-19
+    4    2    0.21419E-05    0.10000E+01    0.16788E+04    0.29794E-07    0.17319E-12    0.23739E-13
+    4    2    0.21419E-05    0.10000E+01    0.13538E+04    0.53638E-07    0.61924E-12    0.36885E-13
+    4    2    0.21419E-05    0.10000E+01    0.10918E+04    0.98791E-07    0.22033E-11    0.58798E-13
+    4    2    0.21419E-05    0.10000E+01    0.88049E+03    0.18382E-06    0.78299E-11    0.95205E-13
+    4    2    0.21419E-05    0.10000E+01    0.71007E+03    0.34322E-06    0.27787E-10    0.15581E-12
+    4    2    0.21419E-05    0.10000E+01    0.57264E+03    0.64104E-06    0.97124E-10    0.25748E-12
+    4    2    0.21419E-05    0.10000E+01    0.46180E+03    0.11941E-05    0.32297E-09    0.42959E-12
+    4    2    0.21419E-05    0.10000E+01    0.37242E+03    0.22026E-05    0.97807E-09    0.72114E-12
+    4    2    0.21419E-05    0.10000E+01    0.30034E+03    0.39692E-05    0.26127E-08    0.12050E-11
+    4    2    0.21419E-05    0.10000E+01    0.24221E+03    0.68744E-05    0.60855E-08    0.19714E-11
+    4    2    0.21419E-05    0.10000E+01    0.19533E+03    0.10721E-04    0.11548E-07    0.29624E-11
+    4    2    0.21419E-05    0.10000E+01    0.15752E+03    0.10721E-04    0.11548E-07    0.29624E-11
+    4    2    0.37375E-05    0.10000E+01    0.80645E+05    0.85339E-52    0.63839E-63    0.11662E-57
+    4    2    0.37375E-05    0.10000E+01    0.65036E+05    0.72187E-51    0.10137E-61    0.98683E-57
+    4    2    0.37375E-05    0.10000E+01    0.52449E+05    0.61331E-50    0.13601E-60    0.83872E-56
+    4    2    0.37375E-05    0.10000E+01    0.42297E+05    0.46087E-49    0.18420E-59    0.63066E-55
+    4    2    0.37375E-05    0.10000E+01    0.34111E+05    0.33156E-48    0.25151E-58    0.45422E-54
+    4    2    0.37375E-05    0.10000E+01    0.27509E+05    0.23701E-47    0.33785E-57    0.32529E-53
+    4    2    0.37375E-05    0.10000E+01    0.22184E+05    0.16760E-46    0.44296E-56    0.23072E-52
+    4    2    0.37375E-05    0.10000E+01    0.17891E+05    0.11619E-45    0.56528E-55    0.16072E-51
+    4    2    0.37375E-05    0.10000E+01    0.14428E+05    0.78604E-45    0.70283E-54    0.10951E-50
+    4    2    0.37375E-05    0.10000E+01    0.11635E+05    0.51821E-44    0.84662E-53    0.72932E-50
+    4    2    0.37375E-05    0.10000E+01    0.93834E+04    0.33146E-43    0.96847E-52    0.47292E-49
+    4    2    0.37375E-05    0.10000E+01    0.75673E+04    0.20298E-42    0.10345E-50    0.29449E-48
+    4    2    0.37375E-05    0.10000E+01    0.61026E+04    0.11782E-41    0.11245E-49    0.17230E-47
+    4    2    0.37375E-05    0.10000E+01    0.49215E+04    0.68673E-41    0.16989E-48    0.95449E-47
+    4    2    0.37375E-05    0.10000E+01    0.39689E+04    0.50000E-40    0.38682E-47    0.58135E-46
+    4    2    0.37375E-05    0.10000E+01    0.32008E+04    0.16709E-37    0.31333E-44    0.16140E-43
+    4    2    0.37375E-05    0.10000E+01    0.25813E+04    0.10861E-28    0.44997E-35    0.97899E-35
+    4    2    0.37375E-05    0.10000E+01    0.20817E+04    0.17804E-12    0.26368E-18    0.15344E-18
+    4    2    0.37375E-05    0.10000E+01    0.16788E+04    0.51989E-07    0.30221E-12    0.41423E-13
+    4    2    0.37375E-05    0.10000E+01    0.13538E+04    0.93594E-07    0.10805E-11    0.64362E-13
+    4    2    0.37375E-05    0.10000E+01    0.10918E+04    0.17238E-06    0.38446E-11    0.10260E-12
+    4    2    0.37375E-05    0.10000E+01    0.88049E+03    0.32076E-06    0.13663E-10    0.16613E-12
+    4    2    0.37375E-05    0.10000E+01    0.71007E+03    0.59889E-06    0.48487E-10    0.27188E-12
+    4    2    0.37375E-05    0.10000E+01    0.57264E+03    0.11186E-05    0.16947E-09    0.44928E-12
+    4    2    0.37375E-05    0.10000E+01    0.46180E+03    0.20837E-05    0.56357E-09    0.74962E-12
+    4    2    0.37375E-05    0.10000E+01    0.37242E+03    0.38434E-05    0.17067E-08    0.12584E-11
+    4    2    0.37375E-05    0.10000E+01    0.30034E+03    0.69261E-05    0.45590E-08    0.21026E-11
+    4    2    0.37375E-05    0.10000E+01    0.24221E+03    0.11995E-04    0.10619E-07    0.34400E-11
+    4    2    0.37375E-05    0.10000E+01    0.19533E+03    0.18707E-04    0.20151E-07    0.51692E-11
+    4    2    0.37375E-05    0.10000E+01    0.15752E+03    0.18707E-04    0.20151E-07    0.51692E-11
+    4    2    0.65217E-05    0.10000E+01    0.80645E+05    0.14891E-51    0.11140E-62    0.20349E-57
+    4    2    0.65217E-05    0.10000E+01    0.65036E+05    0.12596E-50    0.17688E-61    0.17220E-56
+    4    2    0.65217E-05    0.10000E+01    0.52449E+05    0.10702E-49    0.23732E-60    0.14635E-55
+    4    2    0.65217E-05    0.10000E+01    0.42297E+05    0.80420E-49    0.32141E-59    0.11005E-54
+    4    2    0.65217E-05    0.10000E+01    0.34111E+05    0.57855E-48    0.43887E-58    0.79258E-54
+    4    2    0.65217E-05    0.10000E+01    0.27509E+05    0.41356E-47    0.58954E-57    0.56761E-53
+    4    2    0.65217E-05    0.10000E+01    0.22184E+05    0.29245E-46    0.77293E-56    0.40259E-52
+    4    2    0.65217E-05    0.10000E+01    0.17891E+05    0.20275E-45    0.98639E-55    0.28045E-51
+    4    2    0.65217E-05    0.10000E+01    0.14428E+05    0.13716E-44    0.12264E-53    0.19109E-50
+    4    2    0.65217E-05    0.10000E+01    0.11635E+05    0.90424E-44    0.14773E-52    0.12726E-49
+    4    2    0.65217E-05    0.10000E+01    0.93834E+04    0.57837E-43    0.16899E-51    0.82521E-49
+    4    2    0.65217E-05    0.10000E+01    0.75673E+04    0.35419E-42    0.18052E-50    0.51387E-48
+    4    2    0.65217E-05    0.10000E+01    0.61026E+04    0.20559E-41    0.19622E-49    0.30065E-47
+    4    2    0.65217E-05    0.10000E+01    0.49215E+04    0.11983E-40    0.29644E-48    0.16655E-46
+    4    2    0.65217E-05    0.10000E+01    0.39689E+04    0.87248E-40    0.67497E-47    0.10144E-45
+    4    2    0.65217E-05    0.10000E+01    0.32008E+04    0.29156E-37    0.54674E-44    0.28164E-43
+    4    2    0.65217E-05    0.10000E+01    0.25813E+04    0.18952E-28    0.78517E-35    0.17083E-34
+    4    2    0.65217E-05    0.10000E+01    0.20817E+04    0.31066E-12    0.46011E-18    0.26774E-18
+    4    2    0.65217E-05    0.10000E+01    0.16788E+04    0.90718E-07    0.52733E-12    0.72281E-13
+    4    2    0.65217E-05    0.10000E+01    0.13538E+04    0.16332E-06    0.18855E-11    0.11231E-12
+    4    2    0.65217E-05    0.10000E+01    0.10918E+04    0.30080E-06    0.67085E-11    0.17903E-12
+    4    2    0.65217E-05    0.10000E+01    0.88049E+03    0.55970E-06    0.23840E-10    0.28988E-12
+    4    2    0.65217E-05    0.10000E+01    0.71007E+03    0.10450E-05    0.84606E-10    0.47442E-12
+    4    2    0.65217E-05    0.10000E+01    0.57264E+03    0.19518E-05    0.29572E-09    0.78397E-12
+    4    2    0.65217E-05    0.10000E+01    0.46180E+03    0.36358E-05    0.98340E-09    0.13080E-11
+    4    2    0.65217E-05    0.10000E+01    0.37242E+03    0.67064E-05    0.29780E-08    0.21957E-11
+    4    2    0.65217E-05    0.10000E+01    0.30034E+03    0.12086E-04    0.79551E-08    0.36689E-11
+    4    2    0.65217E-05    0.10000E+01    0.24221E+03    0.20931E-04    0.18529E-07    0.60027E-11
+    4    2    0.65217E-05    0.10000E+01    0.19533E+03    0.32642E-04    0.35163E-07    0.90200E-11
+    4    2    0.65217E-05    0.10000E+01    0.15752E+03    0.32642E-04    0.35163E-07    0.90200E-11
+    4    2    0.11380E-04    0.10000E+01    0.80645E+05    0.25984E-51    0.19438E-62    0.35508E-57
+    4    2    0.11380E-04    0.10000E+01    0.65036E+05    0.21980E-50    0.30865E-61    0.30047E-56
+    4    2    0.11380E-04    0.10000E+01    0.52449E+05    0.18674E-49    0.41411E-60    0.25537E-55
+    4    2    0.11380E-04    0.10000E+01    0.42297E+05    0.14033E-48    0.56084E-59    0.19202E-54
+    4    2    0.11380E-04    0.10000E+01    0.34111E+05    0.10095E-47    0.76580E-58    0.13830E-53
+    4    2    0.11380E-04    0.10000E+01    0.27509E+05    0.72165E-47    0.10287E-56    0.99044E-53
+    4    2    0.11380E-04    0.10000E+01    0.22184E+05    0.51031E-46    0.13487E-55    0.70249E-52
+    4    2    0.11380E-04    0.10000E+01    0.17891E+05    0.35378E-45    0.17212E-54    0.48936E-51
+    4    2    0.11380E-04    0.10000E+01    0.14428E+05    0.23933E-44    0.21400E-53    0.33344E-50
+    4    2    0.11380E-04    0.10000E+01    0.11635E+05    0.15778E-43    0.25778E-52    0.22206E-49
+    4    2    0.11380E-04    0.10000E+01    0.93834E+04    0.10092E-42    0.29488E-51    0.14399E-48
+    4    2    0.11380E-04    0.10000E+01    0.75673E+04    0.61804E-42    0.31500E-50    0.89667E-48
+    4    2    0.11380E-04    0.10000E+01    0.61026E+04    0.35875E-41    0.34238E-49    0.52461E-47
+    4    2    0.11380E-04    0.10000E+01    0.49215E+04    0.20910E-40    0.51727E-48    0.29062E-46
+    4    2    0.11380E-04    0.10000E+01    0.39689E+04    0.15224E-39    0.11778E-46    0.17701E-45
+    4    2    0.11380E-04    0.10000E+01    0.32008E+04    0.50875E-37    0.95402E-44    0.49145E-43
+    4    2    0.11380E-04    0.10000E+01    0.25813E+04    0.33069E-28    0.13701E-34    0.29808E-34
+    4    2    0.11380E-04    0.10000E+01    0.20817E+04    0.54209E-12    0.80286E-18    0.46719E-18
+    4    2    0.11380E-04    0.10000E+01    0.16788E+04    0.15830E-06    0.92016E-12    0.12613E-12
+    4    2    0.11380E-04    0.10000E+01    0.13538E+04    0.28498E-06    0.32900E-11    0.19597E-12
+    4    2    0.11380E-04    0.10000E+01    0.10918E+04    0.52488E-06    0.11706E-10    0.31240E-12
+    4    2    0.11380E-04    0.10000E+01    0.88049E+03    0.97664E-06    0.41600E-10    0.50583E-12
+    4    2    0.11380E-04    0.10000E+01    0.71007E+03    0.18235E-05    0.14763E-09    0.82783E-12
+    4    2    0.11380E-04    0.10000E+01    0.57264E+03    0.34058E-05    0.51602E-09    0.13680E-11
+    4    2    0.11380E-04    0.10000E+01    0.46180E+03    0.63443E-05    0.17160E-08    0.22824E-11
+    4    2    0.11380E-04    0.10000E+01    0.37242E+03    0.11702E-04    0.51965E-08    0.38314E-11
+    4    2    0.11380E-04    0.10000E+01    0.30034E+03    0.21089E-04    0.13881E-07    0.64020E-11
+    4    2    0.11380E-04    0.10000E+01    0.24221E+03    0.36524E-04    0.32332E-07    0.10474E-10
+    4    2    0.11380E-04    0.10000E+01    0.19533E+03    0.56959E-04    0.61357E-07    0.15739E-10
+    4    2    0.11380E-04    0.10000E+01    0.15752E+03    0.56959E-04    0.61357E-07    0.15739E-10
+    4    2    0.19857E-04    0.10000E+01    0.80645E+05    0.45341E-51    0.33918E-62    0.61959E-57
+    4    2    0.19857E-04    0.10000E+01    0.65036E+05    0.38353E-50    0.53857E-61    0.52431E-56
+    4    2    0.19857E-04    0.10000E+01    0.52449E+05    0.32585E-49    0.72260E-60    0.44561E-55
+    4    2    0.19857E-04    0.10000E+01    0.42297E+05    0.24486E-48    0.97864E-59    0.33507E-54
+    4    2    0.19857E-04    0.10000E+01    0.34111E+05    0.17616E-47    0.13363E-57    0.24133E-53
+    4    2    0.19857E-04    0.10000E+01    0.27509E+05    0.12592E-46    0.17950E-56    0.17283E-52
+    4    2    0.19857E-04    0.10000E+01    0.22184E+05    0.89046E-46    0.23534E-55    0.12258E-51
+    4    2    0.19857E-04    0.10000E+01    0.17891E+05    0.61733E-45    0.30034E-54    0.85390E-51
+    4    2    0.19857E-04    0.10000E+01    0.14428E+05    0.41762E-44    0.37342E-53    0.58184E-50
+    4    2    0.19857E-04    0.10000E+01    0.11635E+05    0.27532E-43    0.44981E-52    0.38749E-49
+    4    2    0.19857E-04    0.10000E+01    0.93834E+04    0.17610E-42    0.51455E-51    0.25126E-48
+    4    2    0.19857E-04    0.10000E+01    0.75673E+04    0.10784E-41    0.54965E-50    0.15646E-47
+    4    2    0.19857E-04    0.10000E+01    0.61026E+04    0.62600E-41    0.59744E-49    0.91541E-47
+    4    2    0.19857E-04    0.10000E+01    0.49215E+04    0.36486E-40    0.90261E-48    0.50712E-46
+    4    2    0.19857E-04    0.10000E+01    0.39689E+04    0.26565E-39    0.20552E-46    0.30887E-45
+    4    2    0.19857E-04    0.10000E+01    0.32008E+04    0.88774E-37    0.16647E-43    0.85754E-43
+    4    2    0.19857E-04    0.10000E+01    0.25813E+04    0.57704E-28    0.23907E-34    0.52014E-34
+    4    2    0.19857E-04    0.10000E+01    0.20817E+04    0.94591E-12    0.14009E-17    0.81522E-18
+    4    2    0.19857E-04    0.10000E+01    0.16788E+04    0.27622E-06    0.16056E-11    0.22008E-12
+    4    2    0.19857E-04    0.10000E+01    0.13538E+04    0.49727E-06    0.57409E-11    0.34196E-12
+    4    2    0.19857E-04    0.10000E+01    0.10918E+04    0.91588E-06    0.20426E-10    0.54511E-12
+    4    2    0.19857E-04    0.10000E+01    0.88049E+03    0.17042E-05    0.72590E-10    0.88264E-12
+    4    2    0.19857E-04    0.10000E+01    0.71007E+03    0.31819E-05    0.25761E-09    0.14445E-11
+    4    2    0.19857E-04    0.10000E+01    0.57264E+03    0.59430E-05    0.90042E-09    0.23870E-11
+    4    2    0.19857E-04    0.10000E+01    0.46180E+03    0.11070E-04    0.29943E-08    0.39827E-11
+    4    2    0.19857E-04    0.10000E+01    0.37242E+03    0.20420E-04    0.90676E-08    0.66856E-11
+    4    2    0.19857E-04    0.10000E+01    0.30034E+03    0.36798E-04    0.24222E-07    0.11171E-10
+    4    2    0.19857E-04    0.10000E+01    0.24221E+03    0.63732E-04    0.56418E-07    0.18277E-10
+    4    2    0.19857E-04    0.10000E+01    0.19533E+03    0.99389E-04    0.10706E-06    0.27464E-10
+    4    2    0.19857E-04    0.10000E+01    0.15752E+03    0.99389E-04    0.10706E-06    0.27464E-10
+    4    2    0.34650E-04    0.10000E+01    0.80645E+05    0.79117E-51    0.59184E-62    0.10811E-56
+    4    2    0.34650E-04    0.10000E+01    0.65036E+05    0.66924E-50    0.93977E-61    0.91488E-56
+    4    2    0.34650E-04    0.10000E+01    0.52449E+05    0.56859E-49    0.12609E-59    0.77756E-55
+    4    2    0.34650E-04    0.10000E+01    0.42297E+05    0.42727E-48    0.17077E-58    0.58468E-54
+    4    2    0.34650E-04    0.10000E+01    0.34111E+05    0.30738E-47    0.23317E-57    0.42110E-53
+    4    2    0.34650E-04    0.10000E+01    0.27509E+05    0.21973E-46    0.31322E-56    0.30157E-52
+    4    2    0.34650E-04    0.10000E+01    0.22184E+05    0.15538E-45    0.41066E-55    0.21390E-51
+    4    2    0.34650E-04    0.10000E+01    0.17891E+05    0.10772E-44    0.52407E-54    0.14900E-50
+    4    2    0.34650E-04    0.10000E+01    0.14428E+05    0.72873E-44    0.65159E-53    0.10153E-49
+    4    2    0.34650E-04    0.10000E+01    0.11635E+05    0.48043E-43    0.78489E-52    0.67614E-49
+    4    2    0.34650E-04    0.10000E+01    0.93834E+04    0.30729E-42    0.89786E-51    0.43844E-48
+    4    2    0.34650E-04    0.10000E+01    0.75673E+04    0.18818E-41    0.95911E-50    0.27302E-47
+    4    2    0.34650E-04    0.10000E+01    0.61026E+04    0.10923E-40    0.10425E-48    0.15973E-46
+    4    2    0.34650E-04    0.10000E+01    0.49215E+04    0.63666E-40    0.15750E-47    0.88490E-46
+    4    2    0.34650E-04    0.10000E+01    0.39689E+04    0.46355E-39    0.35861E-46    0.53897E-45
+    4    2    0.34650E-04    0.10000E+01    0.32008E+04    0.15491E-36    0.29048E-43    0.14964E-42
+    4    2    0.34650E-04    0.10000E+01    0.25813E+04    0.10069E-27    0.41716E-34    0.90761E-34
+    4    2    0.34650E-04    0.10000E+01    0.20817E+04    0.16506E-11    0.24446E-17    0.14225E-17
+    4    2    0.34650E-04    0.10000E+01    0.16788E+04    0.48199E-06    0.28017E-11    0.38403E-12
+    4    2    0.34650E-04    0.10000E+01    0.13538E+04    0.86770E-06    0.10017E-10    0.59669E-12
+    4    2    0.34650E-04    0.10000E+01    0.10918E+04    0.15982E-05    0.35643E-10    0.95119E-12
+    4    2    0.34650E-04    0.10000E+01    0.88049E+03    0.29737E-05    0.12666E-09    0.15402E-11
+    4    2    0.34650E-04    0.10000E+01    0.71007E+03    0.55523E-05    0.44951E-09    0.25206E-11
+    4    2    0.34650E-04    0.10000E+01    0.57264E+03    0.10370E-04    0.15712E-08    0.41652E-11
+    4    2    0.34650E-04    0.10000E+01    0.46180E+03    0.19317E-04    0.52248E-08    0.69496E-11
+    4    2    0.34650E-04    0.10000E+01    0.37242E+03    0.35631E-04    0.15822E-07    0.11666E-10
+    4    2    0.34650E-04    0.10000E+01    0.30034E+03    0.64211E-04    0.42266E-07    0.19493E-10
+    4    2    0.34650E-04    0.10000E+01    0.24221E+03    0.11121E-03    0.98446E-07    0.31892E-10
+    4    2    0.34650E-04    0.10000E+01    0.19533E+03    0.17343E-03    0.18682E-06    0.47923E-10
+    4    2    0.34650E-04    0.10000E+01    0.15752E+03    0.17343E-03    0.18682E-06    0.47923E-10
+    4    2    0.60462E-04    0.10000E+01    0.80645E+05    0.13805E-50    0.10327E-61    0.18865E-56
+    4    2    0.60462E-04    0.10000E+01    0.65036E+05    0.11678E-49    0.16398E-60    0.15964E-55
+    4    2    0.60462E-04    0.10000E+01    0.52449E+05    0.99215E-49    0.22002E-59    0.13568E-54
+    4    2    0.60462E-04    0.10000E+01    0.42297E+05    0.74556E-48    0.29798E-58    0.10202E-53
+    4    2    0.60462E-04    0.10000E+01    0.34111E+05    0.53637E-47    0.40687E-57    0.73479E-53
+    4    2    0.60462E-04    0.10000E+01    0.27509E+05    0.38341E-46    0.54655E-56    0.52622E-52
+    4    2    0.60462E-04    0.10000E+01    0.22184E+05    0.27113E-45    0.71658E-55    0.37324E-51
+    4    2    0.60462E-04    0.10000E+01    0.17891E+05    0.18797E-44    0.91447E-54    0.26000E-50
+    4    2    0.60462E-04    0.10000E+01    0.14428E+05    0.12716E-43    0.11370E-52    0.17716E-49
+    4    2    0.60462E-04    0.10000E+01    0.11635E+05    0.83831E-43    0.13696E-51    0.11798E-48
+    4    2    0.60462E-04    0.10000E+01    0.93834E+04    0.53620E-42    0.15667E-50    0.76505E-48
+    4    2    0.60462E-04    0.10000E+01    0.75673E+04    0.32837E-41    0.16736E-49    0.47640E-47
+    4    2    0.60462E-04    0.10000E+01    0.61026E+04    0.19060E-40    0.18191E-48    0.27873E-46
+    4    2    0.60462E-04    0.10000E+01    0.49215E+04    0.11109E-39    0.27483E-47    0.15441E-45
+    4    2    0.60462E-04    0.10000E+01    0.39689E+04    0.80886E-39    0.62576E-46    0.94046E-45
+    4    2    0.60462E-04    0.10000E+01    0.32008E+04    0.27030E-36    0.50687E-43    0.26111E-42
+    4    2    0.60462E-04    0.10000E+01    0.25813E+04    0.17570E-27    0.72792E-34    0.15837E-33
+    4    2    0.60462E-04    0.10000E+01    0.20817E+04    0.28801E-11    0.42656E-17    0.24822E-17
+    4    2    0.60462E-04    0.10000E+01    0.16788E+04    0.84104E-06    0.48888E-11    0.67011E-12
+    4    2    0.60462E-04    0.10000E+01    0.13538E+04    0.15141E-05    0.17480E-10    0.10412E-11
+    4    2    0.60462E-04    0.10000E+01    0.10918E+04    0.27887E-05    0.62194E-10    0.16598E-11
+    4    2    0.60462E-04    0.10000E+01    0.88049E+03    0.51889E-05    0.22102E-09    0.26875E-11
+    4    2    0.60462E-04    0.10000E+01    0.71007E+03    0.96884E-05    0.78438E-09    0.43983E-11
+    4    2    0.60462E-04    0.10000E+01    0.57264E+03    0.18095E-04    0.27416E-08    0.72681E-11
+    4    2    0.60462E-04    0.10000E+01    0.46180E+03    0.33708E-04    0.91170E-08    0.12127E-10
+    4    2    0.60462E-04    0.10000E+01    0.37242E+03    0.62175E-04    0.27609E-07    0.20357E-10
+    4    2    0.60462E-04    0.10000E+01    0.30034E+03    0.11204E-03    0.73751E-07    0.34014E-10
+    4    2    0.60462E-04    0.10000E+01    0.24221E+03    0.19405E-03    0.17178E-06    0.55650E-10
+    4    2    0.60462E-04    0.10000E+01    0.19533E+03    0.30262E-03    0.32599E-06    0.83623E-10
+    4    2    0.60462E-04    0.10000E+01    0.15752E+03    0.30262E-03    0.32599E-06    0.83623E-10
+    4    2    0.10550E-03    0.10000E+01    0.80645E+05    0.24090E-50    0.18021E-61    0.32919E-56
+    4    2    0.10550E-03    0.10000E+01    0.65036E+05    0.20377E-49    0.28614E-60    0.27856E-55
+    4    2    0.10550E-03    0.10000E+01    0.52449E+05    0.17312E-48    0.38392E-59    0.23675E-54
+    4    2    0.10550E-03    0.10000E+01    0.42297E+05    0.13010E-47    0.51995E-58    0.17802E-53
+    4    2    0.10550E-03    0.10000E+01    0.34111E+05    0.93593E-47    0.70997E-57    0.12822E-52
+    4    2    0.10550E-03    0.10000E+01    0.27509E+05    0.66903E-46    0.95370E-56    0.91823E-52
+    4    2    0.10550E-03    0.10000E+01    0.22184E+05    0.47310E-45    0.12504E-54    0.65128E-51
+    4    2    0.10550E-03    0.10000E+01    0.17891E+05    0.32799E-44    0.15957E-53    0.45368E-50
+    4    2    0.10550E-03    0.10000E+01    0.14428E+05    0.22188E-43    0.19840E-52    0.30913E-49
+    4    2    0.10550E-03    0.10000E+01    0.11635E+05    0.14628E-42    0.23898E-51    0.20587E-48
+    4    2    0.10550E-03    0.10000E+01    0.93834E+04    0.93564E-42    0.27338E-50    0.13350E-47
+    4    2    0.10550E-03    0.10000E+01    0.75673E+04    0.57298E-41    0.29203E-49    0.83129E-47
+    4    2    0.10550E-03    0.10000E+01    0.61026E+04    0.33259E-40    0.31742E-48    0.48636E-46
+    4    2    0.10550E-03    0.10000E+01    0.49215E+04    0.19385E-39    0.47956E-47    0.26944E-45
+    4    2    0.10550E-03    0.10000E+01    0.39689E+04    0.14114E-38    0.10919E-45    0.16411E-44
+    4    2    0.10550E-03    0.10000E+01    0.32008E+04    0.47166E-36    0.88446E-43    0.45561E-42
+    4    2    0.10550E-03    0.10000E+01    0.25813E+04    0.30658E-27    0.12702E-33    0.27635E-33
+    4    2    0.10550E-03    0.10000E+01    0.20817E+04    0.50257E-11    0.74433E-17    0.43313E-17
+    4    2    0.10550E-03    0.10000E+01    0.16788E+04    0.14676E-05    0.85307E-11    0.11693E-11
+    4    2    0.10550E-03    0.10000E+01    0.13538E+04    0.26420E-05    0.30501E-10    0.18168E-11
+    4    2    0.10550E-03    0.10000E+01    0.10918E+04    0.48661E-05    0.10852E-09    0.28962E-11
+    4    2    0.10550E-03    0.10000E+01    0.88049E+03    0.90544E-05    0.38567E-09    0.46895E-11
+    4    2    0.10550E-03    0.10000E+01    0.71007E+03    0.16906E-04    0.13687E-08    0.76748E-11
+    4    2    0.10550E-03    0.10000E+01    0.57264E+03    0.31575E-04    0.47840E-08    0.12682E-10
+    4    2    0.10550E-03    0.10000E+01    0.46180E+03    0.58818E-04    0.15909E-07    0.21160E-10
+    4    2    0.10550E-03    0.10000E+01    0.37242E+03    0.10849E-03    0.48176E-07    0.35521E-10
+    4    2    0.10550E-03    0.10000E+01    0.30034E+03    0.19551E-03    0.12869E-06    0.59352E-10
+    4    2    0.10550E-03    0.10000E+01    0.24221E+03    0.33861E-03    0.29975E-06    0.97106E-10
+    4    2    0.10550E-03    0.10000E+01    0.19533E+03    0.52806E-03    0.56883E-06    0.14592E-09
+    4    2    0.10550E-03    0.10000E+01    0.15752E+03    0.52806E-03    0.56883E-06    0.14592E-09
+    4    2    0.18409E-03    0.10000E+01    0.80645E+05    0.42035E-50    0.31445E-61    0.57441E-56
+    4    2    0.18409E-03    0.10000E+01    0.65036E+05    0.35557E-49    0.49930E-60    0.48608E-55
+    4    2    0.18409E-03    0.10000E+01    0.52449E+05    0.30209E-48    0.66992E-59    0.41312E-54
+    4    2    0.18409E-03    0.10000E+01    0.42297E+05    0.22701E-47    0.90729E-58    0.31064E-53
+    4    2    0.18409E-03    0.10000E+01    0.34111E+05    0.16331E-46    0.12389E-56    0.22373E-52
+    4    2    0.18409E-03    0.10000E+01    0.27509E+05    0.11674E-45    0.16642E-55    0.16023E-51
+    4    2    0.18409E-03    0.10000E+01    0.22184E+05    0.82554E-45    0.21818E-54    0.11364E-50
+    4    2    0.18409E-03    0.10000E+01    0.17891E+05    0.57232E-44    0.27844E-53    0.79164E-50
+    4    2    0.18409E-03    0.10000E+01    0.14428E+05    0.38718E-43    0.34619E-52    0.53942E-49
+    4    2    0.18409E-03    0.10000E+01    0.11635E+05    0.25525E-42    0.41701E-51    0.35923E-48
+    4    2    0.18409E-03    0.10000E+01    0.93834E+04    0.16326E-41    0.47703E-50    0.23294E-47
+    4    2    0.18409E-03    0.10000E+01    0.75673E+04    0.99982E-41    0.50958E-49    0.14506E-46
+    4    2    0.18409E-03    0.10000E+01    0.61026E+04    0.58036E-40    0.55388E-48    0.84867E-46
+    4    2    0.18409E-03    0.10000E+01    0.49215E+04    0.33826E-39    0.83680E-47    0.47015E-45
+    4    2    0.18409E-03    0.10000E+01    0.39689E+04    0.24628E-38    0.19053E-45    0.28635E-44
+    4    2    0.18409E-03    0.10000E+01    0.32008E+04    0.82301E-36    0.15433E-42    0.79502E-42
+    4    2    0.18409E-03    0.10000E+01    0.25813E+04    0.53497E-27    0.22164E-33    0.48222E-33
+    4    2    0.18409E-03    0.10000E+01    0.20817E+04    0.87695E-11    0.12988E-16    0.75578E-17
+    4    2    0.18409E-03    0.10000E+01    0.16788E+04    0.25608E-05    0.14886E-10    0.20404E-11
+    4    2    0.18409E-03    0.10000E+01    0.13538E+04    0.46101E-05    0.53223E-10    0.31702E-11
+    4    2    0.18409E-03    0.10000E+01    0.10918E+04    0.84911E-05    0.18937E-09    0.50537E-11
+    4    2    0.18409E-03    0.10000E+01    0.88049E+03    0.15799E-04    0.67297E-09    0.81828E-11
+    4    2    0.18409E-03    0.10000E+01    0.71007E+03    0.29499E-04    0.23883E-08    0.13392E-10
+    4    2    0.18409E-03    0.10000E+01    0.57264E+03    0.55097E-04    0.83477E-08    0.22130E-10
+    4    2    0.18409E-03    0.10000E+01    0.46180E+03    0.10263E-03    0.27759E-07    0.36923E-10
+    4    2    0.18409E-03    0.10000E+01    0.37242E+03    0.18931E-03    0.84064E-07    0.61982E-10
+    4    2    0.18409E-03    0.10000E+01    0.30034E+03    0.34115E-03    0.22456E-06    0.10357E-09
+    4    2    0.18409E-03    0.10000E+01    0.24221E+03    0.59085E-03    0.52305E-06    0.16944E-09
+    4    2    0.18409E-03    0.10000E+01    0.19533E+03    0.92143E-03    0.99258E-06    0.25462E-09
+    4    2    0.18409E-03    0.10000E+01    0.15752E+03    0.92143E-03    0.99258E-06    0.25462E-09
+    4    2    0.32123E-03    0.10000E+01    0.80645E+05    0.73348E-50    0.54869E-61    0.10023E-55
+    4    2    0.32123E-03    0.10000E+01    0.65036E+05    0.62044E-49    0.87125E-60    0.84818E-55
+    4    2    0.32123E-03    0.10000E+01    0.52449E+05    0.52713E-48    0.11690E-58    0.72087E-54
+    4    2    0.32123E-03    0.10000E+01    0.42297E+05    0.39612E-47    0.15832E-57    0.54205E-53
+    4    2    0.32123E-03    0.10000E+01    0.34111E+05    0.28497E-46    0.21617E-56    0.39040E-52
+    4    2    0.32123E-03    0.10000E+01    0.27509E+05    0.20371E-45    0.29038E-55    0.27958E-51
+    4    2    0.32123E-03    0.10000E+01    0.22184E+05    0.14405E-44    0.38072E-54    0.19830E-50
+    4    2    0.32123E-03    0.10000E+01    0.17891E+05    0.99867E-44    0.48586E-53    0.13814E-49
+    4    2    0.32123E-03    0.10000E+01    0.14428E+05    0.67560E-43    0.60408E-52    0.94125E-49
+    4    2    0.32123E-03    0.10000E+01    0.11635E+05    0.44540E-42    0.72766E-51    0.62684E-48
+    4    2    0.32123E-03    0.10000E+01    0.93834E+04    0.28489E-41    0.83239E-50    0.40647E-47
+    4    2    0.32123E-03    0.10000E+01    0.75673E+04    0.17446E-40    0.88918E-49    0.25311E-46
+    4    2    0.32123E-03    0.10000E+01    0.61026E+04    0.10127E-39    0.96649E-48    0.14809E-45
+    4    2    0.32123E-03    0.10000E+01    0.49215E+04    0.59024E-39    0.14602E-46    0.82038E-45
+    4    2    0.32123E-03    0.10000E+01    0.39689E+04    0.42975E-38    0.33247E-45    0.49967E-44
+    4    2    0.32123E-03    0.10000E+01    0.32008E+04    0.14361E-35    0.26930E-42    0.13873E-41
+    4    2    0.32123E-03    0.10000E+01    0.25813E+04    0.93348E-27    0.38675E-33    0.84144E-33
+    4    2    0.32123E-03    0.10000E+01    0.20817E+04    0.15302E-10    0.22663E-16    0.13188E-16
+    4    2    0.32123E-03    0.10000E+01    0.16788E+04    0.44685E-05    0.25974E-10    0.35603E-11
+    4    2    0.32123E-03    0.10000E+01    0.13538E+04    0.80444E-05    0.92871E-10    0.55319E-11
+    4    2    0.32123E-03    0.10000E+01    0.10918E+04    0.14816E-04    0.33044E-09    0.88184E-11
+    4    2    0.32123E-03    0.10000E+01    0.88049E+03    0.27569E-04    0.11743E-08    0.14279E-10
+    4    2    0.32123E-03    0.10000E+01    0.71007E+03    0.51474E-04    0.41674E-08    0.23368E-10
+    4    2    0.32123E-03    0.10000E+01    0.57264E+03    0.96140E-04    0.14566E-07    0.38615E-10
+    4    2    0.32123E-03    0.10000E+01    0.46180E+03    0.17909E-03    0.48439E-07    0.64429E-10
+    4    2    0.32123E-03    0.10000E+01    0.37242E+03    0.33033E-03    0.14669E-06    0.10815E-09
+    4    2    0.32123E-03    0.10000E+01    0.30034E+03    0.59529E-03    0.39184E-06    0.18072E-09
+    4    2    0.32123E-03    0.10000E+01    0.24221E+03    0.10310E-02    0.91268E-06    0.29567E-09
+    4    2    0.32123E-03    0.10000E+01    0.19533E+03    0.16078E-02    0.17320E-05    0.44429E-09
+    4    2    0.32123E-03    0.10000E+01    0.15752E+03    0.16078E-02    0.17320E-05    0.44429E-09
+    4    3    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.15049E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    3    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.26259E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    3    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.45820E-08    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    3    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.79953E-08    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    4    3    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.13951E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    4    3    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.24344E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    4    3    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.42479E-07    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    4    3    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.74124E-07    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    4    3    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.12934E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    4    3    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.22569E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    4    3    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.39382E-06    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    4    3    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90475E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.68719E-06    0.10445E+07    0.49376E-30    0.85596E-43    0.95741E-05    0.90000E+03
+    4    3    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15567E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.11991E-05    0.86742E+06    0.15043E-29    0.14717E-35    0.11528E-04    0.90000E+03
+    4    3    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13157E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.20924E-05    0.72035E+06    0.45832E-29    0.12437E-29    0.13882E-04    0.90000E+03
+    4    3    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91418E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.36511E-05    0.59822E+06    0.13964E-28    0.86567E-25    0.16716E-04    0.90000E+03
+    4    3    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.80111E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.63709E-05    0.49680E+06    0.42543E-28    0.76230E-21    0.20129E-04    0.90000E+03
+    4    3    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12113E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.11117E-04    0.41311E+06    0.12910E-27    0.11632E-17    0.24207E-04    0.90000E+03
+    4    3    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.46668E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.19398E-04    0.34307E+06    0.39288E-27    0.45453E-15    0.29147E-04    0.89996E+03
+    4    3    0.10271E-10    0.10000E+01    0.22942E-01    0.43838E-01    0.84780E-11    0.55656E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.33849E-04    0.28490E+06    0.11866E-26    0.55189E-13    0.35071E-04    0.89947E+03
+    4    3    0.17923E-10    0.10000E+01    0.32889E-01    0.63716E-01    0.20397E-10    0.25850E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.59064E-04    0.23629E+06    0.35031E-26    0.26135E-11    0.42128E-04    0.89631E+03
+    4    3    0.31275E-10    0.10000E+01    0.48370E-01    0.94496E-01    0.50496E-10    0.57842E-12    0.34961E-04    0.23119E-04    0.56458E+04    0.10306E-03    0.19496E+06    0.99590E-26    0.59486E-10    0.50508E-04    0.88380E+03
+    4    3    0.54572E-10    0.10000E+01    0.73841E-01    0.13762E+00    0.11141E-09    0.72430E-11    0.40398E-04    0.29084E-04    0.98516E+04    0.17984E-03    0.15940E+06    0.27334E-25    0.75129E-09    0.60577E-04    0.85059E+03
+    4    3    0.95225E-10    0.10000E+01    0.11432E+00    0.18745E+00    0.20649E-09    0.57663E-10    0.44544E-04    0.36636E-04    0.17190E+05    0.31381E-03    0.12815E+06    0.76794E-25    0.59189E-08    0.73816E-04    0.78522E+03
+    4    3    0.16616E-09    0.10000E+01    0.16491E+00    0.23138E+00    0.32029E-09    0.29350E-09    0.47896E-04    0.42509E-04    0.29996E+05    0.54757E-03    0.10182E+06    0.23889E-24    0.28789E-07    0.92577E-04    0.69460E+03
+    4    3    0.28994E-09    0.10000E+01    0.21060E+00    0.27236E+00    0.51213E-09    0.97362E-09    0.53767E-04    0.44711E-04    0.52341E+05    0.95549E-03    0.81431E+05    0.80701E-24    0.87282E-07    0.11776E-03    0.61403E+03
+    4    3    0.50593E-09    0.10000E+01    0.24923E+00    0.32938E+00    0.10142E-08    0.23910E-08    0.64457E-04    0.47049E-04    0.91333E+05    0.16673E-02    0.66234E+05    0.26654E-23    0.18839E-06    0.14760E-03    0.56619E+03
+    4    3    0.88282E-09    0.10000E+01    0.29269E+00    0.41095E+00    0.21828E-08    0.50085E-08    0.79566E-04    0.51896E-04    0.15937E+06    0.29093E-02    0.54436E+05    0.82533E-23    0.33678E-06    0.18122E-03    0.54263E+03
+    4    3    0.15405E-08    0.10000E+01    0.35395E+00    0.51511E+00    0.44159E-08    0.97210E-08    0.98245E-04    0.59547E-04    0.27809E+06    0.50765E-02    0.44739E+05    0.23938E-22    0.54694E-06    0.21942E-03    0.52693E+03
+    4    3    0.26880E-08    0.10000E+01    0.44235E+00    0.63648E+00    0.82107E-08    0.18193E-07    0.12088E-03    0.69602E-04    0.48525E+06    0.88582E-02    0.36532E+05    0.65510E-22    0.84986E-06    0.26377E-03    0.50458E+03
+    4    3    0.46905E-08    0.10000E+01    0.40681E+00    0.11292E+01    0.25765E-07    0.36846E-07    0.10298E-03    0.10304E-03    0.20736E+06    0.94879E-02    0.55390E+04    0.60043E-21    0.10070E-05    0.55703E-03    0.32406E+03
+    4    3    0.81846E-08    0.10000E+01    0.51804E+00    0.12977E+01    0.44571E-07    0.67383E-07    0.12601E-03    0.11595E-03    0.36184E+06    0.16556E-01    0.42219E+04    0.17008E-20    0.15626E-05    0.71276E-03    0.26641E+03
+    4    3    0.14282E-07    0.10000E+01    0.64910E+00    0.14736E+01    0.75883E-07    0.12288E-06    0.15439E-03    0.12904E-03    0.63138E+06    0.28889E-01    0.31889E+04    0.49570E-20    0.24170E-05    0.92819E-03    0.21195E+03
+    4    3    0.24920E-07    0.10000E+01    0.79703E+00    0.16506E+01    0.12721E-06    0.22341E-06    0.18984E-03    0.14166E-03    0.11017E+07    0.50410E-01    0.23930E+04    0.14752E-19    0.37382E-05    0.12248E-02    0.16393E+03
+    4    3    0.43485E-07    0.10000E+01    0.95657E+00    0.18218E+01    0.21103E-06    0.40473E-06    0.23547E-03    0.15319E-03    0.19224E+07    0.87962E-01    0.17911E+04    0.44363E-19    0.57961E-05    0.16276E-02    0.12421E+03
+    4    3    0.75878E-07    0.10000E+01    0.11230E+01    0.19830E+01    0.34684E-06    0.73049E-06    0.29523E-03    0.16332E-03    0.33546E+07    0.15349E+00    0.13389E+04    0.13415E-18    0.90151E-05    0.21714E-02    0.92712E+02
+    4    3    0.13240E-06    0.10000E+01    0.12922E+01    0.21320E+01    0.56444E-06    0.13138E-05    0.37418E-03    0.17201E-03    0.58535E+07    0.26783E+00    0.99952E+03    0.40733E-18    0.14059E-04    0.29048E-02    0.68448E+02
+    4    3    0.23103E-06    0.10000E+01    0.14600E+01    0.22672E+01    0.91202E-06    0.23544E-05    0.47969E-03    0.17931E-03    0.10214E+08    0.46734E+00    0.74618E+03    0.12369E-17    0.21977E-04    0.38879E-02    0.50204E+02
+    4    3    0.40314E-06    0.10000E+01    0.16240E+01    0.23888E+01    0.14578E-05    0.42024E-05    0.62025E-03    0.18540E-03    0.17823E+08    0.81548E+00    0.55633E+03    0.37294E-17    0.34377E-04    0.51983E-02    0.36640E+02
+    4    3    0.70346E-06    0.10000E+01    0.16820E+01    0.24292E+01    0.35008E-05    0.73791E-05    0.97243E-03    0.18734E-03    0.31100E+08    0.14230E+01    0.50000E+03    0.78661E-17    0.57625E-04    0.57614E-02    0.32683E+02
+    4    3    0.12275E-05    0.10000E+01    0.16820E+01    0.24292E+01    0.10659E-04    0.12876E-04    0.16968E-02    0.18734E-03    0.54267E+08    0.24830E+01    0.50000E+03    0.13726E-16    0.10055E-03    0.57614E-02    0.32683E+02
+    4    3    0.21419E-05    0.10000E+01    0.16820E+01    0.24292E+01    0.32456E-04    0.22468E-04    0.29609E-02    0.18734E-03    0.94693E+08    0.43327E+01    0.50000E+03    0.23951E-16    0.17546E-03    0.57614E-02    0.32683E+02
+    4    3    0.37375E-05    0.10000E+01    0.16820E+01    0.24292E+01    0.98822E-04    0.39205E-04    0.51665E-02    0.18734E-03    0.16523E+09    0.75603E+01    0.50000E+03    0.41793E-16    0.30616E-03    0.57614E-02    0.32683E+02
+    4    3    0.65217E-05    0.10000E+01    0.16820E+01    0.24292E+01    0.30090E-03    0.68411E-04    0.90153E-02    0.18734E-03    0.28832E+09    0.13192E+02    0.50000E+03    0.72926E-16    0.53423E-03    0.57614E-02    0.32683E+02
+    4    3    0.11380E-04    0.10000E+01    0.16820E+01    0.24292E+01    0.91617E-03    0.11937E-03    0.15731E-01    0.18734E-03    0.50310E+09    0.23020E+02    0.50000E+03    0.12725E-15    0.93220E-03    0.57614E-02    0.32683E+02
+    4    3    0.19857E-04    0.10000E+01    0.16820E+01    0.24292E+01    0.27896E-02    0.20830E-03    0.27450E-01    0.18734E-03    0.87789E+09    0.40168E+02    0.50000E+03    0.22205E-15    0.16266E-02    0.57614E-02    0.32683E+02
+    4    3    0.34650E-04    0.10000E+01    0.16820E+01    0.24292E+01    0.84937E-02    0.36347E-03    0.47899E-01    0.18734E-03    0.15319E+10    0.70090E+02    0.50000E+03    0.38746E-15    0.28384E-02    0.57614E-02    0.32683E+02
+    4    3    0.60462E-04    0.10000E+01    0.16820E+01    0.24292E+01    0.25862E-01    0.63423E-03    0.83580E-01    0.18734E-03    0.26730E+10    0.12230E+03    0.50000E+03    0.67609E-15    0.49528E-02    0.57614E-02    0.32683E+02
+    4    3    0.10550E-03    0.10000E+01    0.16820E+01    0.24292E+01    0.78744E-01    0.11067E-02    0.14584E+00    0.18734E-03    0.46642E+10    0.21341E+03    0.50000E+03    0.11797E-14    0.86423E-02    0.57614E-02    0.32683E+02
+    4    3    0.18409E-03    0.10000E+01    0.16820E+01    0.24292E+01    0.23976E+00    0.19311E-02    0.25449E+00    0.18734E-03    0.81388E+10    0.37239E+03    0.50000E+03    0.20586E-14    0.15080E-01    0.57614E-02    0.32683E+02
+    4    3    0.32123E-03    0.10000E+01    0.16820E+01    0.24292E+01    0.73003E+00    0.33697E-02    0.44406E+00    0.18734E-03    0.14202E+11    0.64980E+03    0.50000E+03    0.35921E-14    0.26314E-01    0.57614E-02    0.32683E+02
+    4    3    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    4    3    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    4    3    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    4    3    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    4    3    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    4    3    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    4    3    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    4    3    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    4    3    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    4    3    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    4    3    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    4    3    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    4    3    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    4    3    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    4    3    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    4    3    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    4    3    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    4    3    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    4    3    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    4    3    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    4    3    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    4    3    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    4    3    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    4    3    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    4    3    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    4    3    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    4    3    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    4    3    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    4    3    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    4    3    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    4    3    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    4    3    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    4    3    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    4    3    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    4    3    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    4    3    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    4    3    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    4    3    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    4    3    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    4    3    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    4    3    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    4    3    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    4    3    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    4    3    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    4    3    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    4    3    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    4    3    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    4    3    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    4    3    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    4    3    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    4    3    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    4    3    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    4    3    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    4    3    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    4    3    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    4    3    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    4    3    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    4    3    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    4    3    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    4    3    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    4    3    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    4    3    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    4    3    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    4    3    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    4    3    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    4    3    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    4    3    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    4    3    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    4    3    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    4    3    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    4    3    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    4    3    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    4    3    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    4    3    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    4    3    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    4    3    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    4    3    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    4    3    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    4    3    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    4    3    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    4    3    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    4    3    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    4    3    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    4    3    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    4    3    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    4    3    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    4    3    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    4    3    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    4    3    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    4    3    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    4    3    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    4    3    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    4    3    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    4    3    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    4    3    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    4    3    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    4    3    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    4    3    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    4    3    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    4    3    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    4    3    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    4    3    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    4    3    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    4    3    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    4    3    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    4    3    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    4    3    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    4    3    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    4    3    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    4    3    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    4    3    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    4    3    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    4    3    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    4    3    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    4    3    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    4    3    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    4    3    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    4    3    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    4    3    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    4    3    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    4    3    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    4    3    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    4    3    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    4    3    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    4    3    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    4    3    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    4    3    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    4    3    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    4    3    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    4    3    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    4    3    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    4    3    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    4    3    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    4    3    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    4    3    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    4    3    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    4    3    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    4    3    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    4    3    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    4    3    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    4    3    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    4    3    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    4    3    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    4    3    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    4    3    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    4    3    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    4    3    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    4    3    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    4    3    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    4    3    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    4    3    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    4    3    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    4    3    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    4    3    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    4    3    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    4    3    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    4    3    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    4    3    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    4    3    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    4    3    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    4    3    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    4    3    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    4    3    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    4    3    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    4    3    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    4    3    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    4    3    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    4    3    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    4    3    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    4    3    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    4    3    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    4    3    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    4    3    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    4    3    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    4    3    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    4    3    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    4    3    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    4    3    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    4    3    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    4    3    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    4    3    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    4    3    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    4    3    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    4    3    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    4    3    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    4    3    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    4    3    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    4    3    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    4    3    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    4    3    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    4    3    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    4    3    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    4    3    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    4    3    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    4    3    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    4    3    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    4    3    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    4    3    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    4    3    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    4    3    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    4    3    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    4    3    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    4    3    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    4    3    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    4    3    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    4    3    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    4    3    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    4    3    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    4    3    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    4    3    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    4    3    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    4    3    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    4    3    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    4    3    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    4    3    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    4    3    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    4    3    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    4    3    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    4    3    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    4    3    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    4    3    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    4    3    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    4    3    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    4    3    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    4    3    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    4    3    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    4    3    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    4    3    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    4    3    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    4    3    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    4    3    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    4    3    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    4    3    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    4    3    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    4    3    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    4    3    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    4    3    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    4    3    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    4    3    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    4    3    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    4    3    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    4    3    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    4    3    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    4    3    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    4    3    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    4    3    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    4    3    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    4    3    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    4    3    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    4    3    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    4    3    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    4    3    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    4    3    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    4    3    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    4    3    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    4    3    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    4    3    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    4    3    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    4    3    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    4    3    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    4    3    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    4    3    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    4    3    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    4    3    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    4    3    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    4    3    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    4    3    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    4    3    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    4    3    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    4    3    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    4    3    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    4    3    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    4    3    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    4    3    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    4    3    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    4    3    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    4    3    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    4    3    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    4    3    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    4    3    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    4    3    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    4    3    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    4    3    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    4    3    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    4    3    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    4    3    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    4    3    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    4    3    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    4    3    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    4    3    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    4    3    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    4    3    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    4    3    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    4    3    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    4    3    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    4    3    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    4    3    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    4    3    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    4    3    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    4    3    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    4    3    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    4    3    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    4    3    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    4    3    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    4    3    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    4    3    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    4    3    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    4    3    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    4    3    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    4    3    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    4    3    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    4    3    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    4    3    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    4    3    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    4    3    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    4    3    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    4    3    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    4    3    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    4    3    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    4    3    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    4    3    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    4    3    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    4    3    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    4    3    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    4    3    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    4    3    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    4    3    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    4    3    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    4    3    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    4    3    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    4    3    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    4    3    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    4    3    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    4    3    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    4    3    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    4    3    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    4    3    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    4    3    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    4    3    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    4    3    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    4    3    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    4    3    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    4    3    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    4    3    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    4    3    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    4    3    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    4    3    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    4    3    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    4    3    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    4    3    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    4    3    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    4    3    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    4    3    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    4    3    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    4    3    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    4    3    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    4    3    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    4    3    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    4    3    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    4    3    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    4    3    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    4    3    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    4    3    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    4    3    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    4    3    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    4    3    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    4    3    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    4    3    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    4    3    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    4    3    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    4    3    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    4    3    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    4    3    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    4    3    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    4    3    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    4    3    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    4    3    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    4    3    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    4    3    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    4    3    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    4    3    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    4    3    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    4    3    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    4    3    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    4    3    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    4    3    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    4    3    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    4    3    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    4    3    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    4    3    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    4    3    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    4    3    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    4    3    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    4    3    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    4    3    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    4    3    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    4    3    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    4    3    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    4    3    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    4    3    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    4    3    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    4    3    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    4    3    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    4    3    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    4    3    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    4    3    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    4    3    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    4    3    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    4    3    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    4    3    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    4    3    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    4    3    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    4    3    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    4    3    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    4    3    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    4    3    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    4    3    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    4    3    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    4    3    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    4    3    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    4    3    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    4    3    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    4    3    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    4    3    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    4    3    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    4    3    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    4    3    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    4    3    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    4    3    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    4    3    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    4    3    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    4    3    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    4    3    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    4    3    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    4    3    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    4    3    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    4    3    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    4    3    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    4    3    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    4    3    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    4    3    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    4    3    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    4    3    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    4    3    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    4    3    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    4    3    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    4    3    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    4    3    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    4    3    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    4    3    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    4    3    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    4    3    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    4    3    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    4    3    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    4    3    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    4    3    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    4    3    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    4    3    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    4    3    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    4    3    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    4    3    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    4    3    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    4    3    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    4    3    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    4    3    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    4    3    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    4    3    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    4    3    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    4    3    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    4    3    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    4    3    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    4    3    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    4    3    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    4    3    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    4    3    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    4    3    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    4    3    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    4    3    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    4    3    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    4    3    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    4    3    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    4    3    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    4    3    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    4    3    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    4    3    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    4    3    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    4    3    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    4    3    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    4    3    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    4    3    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    4    3    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    4    3    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    4    3    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    4    3    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    4    3    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    4    3    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    4    3    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    4    3    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    4    3    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    4    3    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    4    3    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    4    3    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    4    3    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    4    3    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    4    3    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    4    3    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    4    3    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    4    3    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    4    3    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    4    3    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    4    3    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    4    3    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    4    3    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    4    3    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    4    3    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    4    3    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    4    3    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    4    3    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    4    3    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    4    3    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    4    3    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    4    3    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    4    3    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    4    3    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    4    3    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    4    3    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    4    3    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    4    3    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    4    3    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    4    3    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    4    3    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    4    3    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    4    3    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    4    3    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    4    3    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    4    3    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    4    3    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    4    3    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    4    3    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    4    3    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    4    3    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92888E-69
+    4    3    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    4    3    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73136E-67
+    4    3    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87546E-66
+    4    3    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    4    3    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    4    3    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    4    3    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    4    3    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    4    3    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    4    3    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    4    3    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    4    3    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    4    3    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    4    3    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96300E-53
+    4    3    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    4    3    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    4    3    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    4    3    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    4    3    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    4    3    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    4    3    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    4    3    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    4    3    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    4    3    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    4    3    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    4    3    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    4    3    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    4    3    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    4    3    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    4    3    0.17923E-10    0.10000E+01    0.80645E+05    0.56933E-58    0.39458E-69    0.34061E-68
+    4    3    0.17923E-10    0.10000E+01    0.65036E+05    0.46736E-57    0.87603E-68    0.28314E-67
+    4    3    0.17923E-10    0.10000E+01    0.52449E+05    0.52530E-56    0.24092E-66    0.24725E-66
+    4    3    0.17923E-10    0.10000E+01    0.42297E+05    0.74526E-55    0.80035E-65    0.22163E-65
+    4    3    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27753E-63    0.26468E-64
+    4    3    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94017E-62    0.41863E-63
+    4    3    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72570E-62
+    4    3    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12276E-60
+    4    3    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19420E-59
+    4    3    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28905E-58
+    4    3    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41540E-57
+    4    3    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58881E-56
+    4    3    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83143E-55
+    4    3    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11731E-53
+    4    3    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    4    3    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73374E-50
+    4    3    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53835E-41
+    4    3    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    4    3    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17280E-13    0.34689E-19
+    4    3    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74496E-19
+    4    3    0.17923E-10    0.10000E+01    0.10918E+04    0.81814E-08    0.24471E-12    0.15644E-18
+    4    3    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    4    3    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    4    3    0.17923E-10    0.10000E+01    0.57264E+03    0.67123E-07    0.11672E-10    0.12842E-17
+    4    3    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    4    3    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47786E-17
+    4    3    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88260E-17
+    4    3    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    4    3    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    4    3    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    4    3    0.31275E-10    0.10000E+01    0.80645E+05    0.12247E-57    0.88074E-69    0.11479E-67
+    4    3    0.31275E-10    0.10000E+01    0.65036E+05    0.10137E-56    0.15648E-67    0.98452E-67
+    4    3    0.31275E-10    0.10000E+01    0.52449E+05    0.94800E-56    0.30713E-66    0.84229E-66
+    4    3    0.31275E-10    0.10000E+01    0.42297E+05    0.99527E-55    0.85054E-65    0.66800E-65
+    4    3    0.31275E-10    0.10000E+01    0.34111E+05    0.13829E-53    0.28089E-63    0.61071E-64
+    4    3    0.31275E-10    0.10000E+01    0.27509E+05    0.23213E-52    0.94793E-62    0.75210E-63
+    4    3    0.31275E-10    0.10000E+01    0.22184E+05    0.40538E-51    0.30614E-60    0.11739E-61
+    4    3    0.31275E-10    0.10000E+01    0.17891E+05    0.68166E-50    0.91705E-59    0.19631E-60
+    4    3    0.31275E-10    0.10000E+01    0.14428E+05    0.10720E-48    0.25765E-57    0.31487E-59
+    4    3    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70061E-56    0.47520E-58
+    4    3    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18857E-54    0.68996E-57
+    4    3    0.31275E-10    0.10000E+01    0.75673E+04    0.32248E-45    0.50659E-53    0.98545E-56
+    4    3    0.31275E-10    0.10000E+01    0.61026E+04    0.45467E-44    0.13608E-51    0.13998E-54
+    4    3    0.31275E-10    0.10000E+01    0.49215E+04    0.64062E-43    0.36550E-50    0.19846E-53
+    4    3    0.31275E-10    0.10000E+01    0.39689E+04    0.90247E-42    0.98149E-49    0.28104E-52
+    4    3    0.31275E-10    0.10000E+01    0.32008E+04    0.39976E-39    0.85213E-46    0.12504E-49
+    4    3    0.31275E-10    0.10000E+01    0.25813E+04    0.29300E-30    0.14317E-36    0.92014E-41
+    4    3    0.31275E-10    0.10000E+01    0.20817E+04    0.55757E-14    0.12152E-19    0.17584E-24
+    4    3    0.31275E-10    0.10000E+01    0.16788E+04    0.18845E-08    0.17947E-13    0.59587E-19
+    4    3    0.31275E-10    0.10000E+01    0.13538E+04    0.40460E-08    0.68170E-13    0.12805E-18
+    4    3    0.31275E-10    0.10000E+01    0.10918E+04    0.84950E-08    0.25418E-12    0.26903E-18
+    4    3    0.31275E-10    0.10000E+01    0.88049E+03    0.17456E-07    0.93585E-12    0.55310E-18
+    4    3    0.31275E-10    0.10000E+01    0.71007E+03    0.35181E-07    0.34079E-11    0.11151E-17
+    4    3    0.31275E-10    0.10000E+01    0.57264E+03    0.69717E-07    0.12125E-10    0.22102E-17
+    4    3    0.31275E-10    0.10000E+01    0.46180E+03    0.13591E-06    0.40780E-10    0.43094E-17
+    4    3    0.31275E-10    0.10000E+01    0.37242E+03    0.25940E-06    0.12435E-09    0.82253E-17
+    4    3    0.31275E-10    0.10000E+01    0.30034E+03    0.47910E-06    0.33352E-09    0.15193E-16
+    4    3    0.31275E-10    0.10000E+01    0.24221E+03    0.84407E-06    0.77873E-09    0.26767E-16
+    4    3    0.31275E-10    0.10000E+01    0.19533E+03    0.13303E-05    0.14798E-08    0.42186E-16
+    4    3    0.31275E-10    0.10000E+01    0.15752E+03    0.13303E-05    0.14798E-08    0.42186E-16
+    4    3    0.54572E-10    0.10000E+01    0.80645E+05    0.25935E-57    0.19479E-68    0.36230E-67
+    4    3    0.54572E-10    0.10000E+01    0.65036E+05    0.22045E-56    0.31757E-67    0.31472E-66
+    4    3    0.54572E-10    0.10000E+01    0.52449E+05    0.19249E-55    0.49040E-66    0.26988E-65
+    4    3    0.54572E-10    0.10000E+01    0.42297E+05    0.16422E-54    0.10153E-64    0.20667E-64
+    4    3    0.54572E-10    0.10000E+01    0.34111E+05    0.17201E-53    0.28309E-63    0.16173E-63
+    4    3    0.54572E-10    0.10000E+01    0.27509E+05    0.23979E-52    0.90904E-62    0.15132E-62
+    4    3    0.54572E-10    0.10000E+01    0.22184E+05    0.39303E-51    0.29460E-60    0.19339E-61
+    4    3    0.54572E-10    0.10000E+01    0.17891E+05    0.65778E-50    0.89364E-59    0.30836E-60
+    4    3    0.54572E-10    0.10000E+01    0.14428E+05    0.10442E-48    0.25341E-57    0.50146E-59
+    4    3    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69339E-56    0.77219E-58
+    4    3    0.54572E-10    0.10000E+01    0.93834E+04    0.22542E-46    0.18749E-54    0.11386E-56
+    4    3    0.54572E-10    0.10000E+01    0.75673E+04    0.32051E-45    0.50560E-53    0.16445E-55
+    4    3    0.54572E-10    0.10000E+01    0.61026E+04    0.45364E-44    0.13624E-51    0.23560E-54
+    4    3    0.54572E-10    0.10000E+01    0.49215E+04    0.64124E-43    0.36692E-50    0.33627E-53
+    4    3    0.54572E-10    0.10000E+01    0.39689E+04    0.90579E-42    0.98752E-49    0.47874E-52
+    4    3    0.54572E-10    0.10000E+01    0.32008E+04    0.40216E-39    0.85904E-46    0.21394E-49
+    4    3    0.54572E-10    0.10000E+01    0.25813E+04    0.29538E-30    0.14462E-36    0.15805E-40
+    4    3    0.54572E-10    0.10000E+01    0.20817E+04    0.56335E-14    0.12301E-19    0.30325E-24
+    4    3    0.54572E-10    0.10000E+01    0.16788E+04    0.19067E-08    0.18183E-13    0.10302E-18
+    4    3    0.54572E-10    0.10000E+01    0.13538E+04    0.40956E-08    0.69073E-13    0.22157E-18
+    4    3    0.54572E-10    0.10000E+01    0.10918E+04    0.86022E-08    0.25757E-12    0.46582E-18
+    4    3    0.54572E-10    0.10000E+01    0.88049E+03    0.17681E-07    0.94835E-12    0.95809E-18
+    4    3    0.54572E-10    0.10000E+01    0.71007E+03    0.35641E-07    0.34534E-11    0.19322E-17
+    4    3    0.54572E-10    0.10000E+01    0.57264E+03    0.70635E-07    0.12287E-10    0.38305E-17
+    4    3    0.54572E-10    0.10000E+01    0.46180E+03    0.13771E-06    0.41325E-10    0.74697E-17
+    4    3    0.54572E-10    0.10000E+01    0.37242E+03    0.26285E-06    0.12601E-09    0.14259E-16
+    4    3    0.54572E-10    0.10000E+01    0.30034E+03    0.48548E-06    0.33797E-09    0.26338E-16
+    4    3    0.54572E-10    0.10000E+01    0.24221E+03    0.85533E-06    0.78914E-09    0.46405E-16
+    4    3    0.54572E-10    0.10000E+01    0.19533E+03    0.13480E-05    0.14996E-08    0.73137E-16
+    4    3    0.54572E-10    0.10000E+01    0.15752E+03    0.13480E-05    0.14996E-08    0.73137E-16
+    4    3    0.95225E-10    0.10000E+01    0.80645E+05    0.53648E-57    0.41091E-68    0.11715E-66
+    4    3    0.95225E-10    0.10000E+01    0.65036E+05    0.46225E-56    0.65617E-67    0.10081E-65
+    4    3    0.95225E-10    0.10000E+01    0.52449E+05    0.39689E-55    0.91487E-66    0.85980E-65
+    4    3    0.95225E-10    0.10000E+01    0.42297E+05    0.30948E-54    0.14639E-64    0.64450E-64
+    4    3    0.95225E-10    0.10000E+01    0.34111E+05    0.25757E-53    0.30377E-63    0.46327E-63
+    4    3    0.95225E-10    0.10000E+01    0.27509E+05    0.26941E-52    0.84282E-62    0.35368E-62
+    4    3    0.95225E-10    0.10000E+01    0.22184E+05    0.37483E-51    0.26924E-60    0.35404E-61
+    4    3    0.95225E-10    0.10000E+01    0.17891E+05    0.60644E-50    0.83292E-59    0.50819E-60
+    4    3    0.95225E-10    0.10000E+01    0.14428E+05    0.97360E-49    0.24026E-57    0.82207E-59
+    4    3    0.95225E-10    0.10000E+01    0.11635E+05    0.14792E-47    0.66500E-56    0.12827E-57
+    4    3    0.95225E-10    0.10000E+01    0.93834E+04    0.21596E-46    0.18131E-54    0.19117E-56
+    4    3    0.95225E-10    0.10000E+01    0.75673E+04    0.30971E-45    0.49211E-53    0.27813E-55
+    4    3    0.95225E-10    0.10000E+01    0.61026E+04    0.44130E-44    0.13331E-51    0.40060E-54
+    4    3    0.95225E-10    0.10000E+01    0.49215E+04    0.62717E-43    0.36060E-50    0.57426E-53
+    4    3    0.95225E-10    0.10000E+01    0.39689E+04    0.88985E-42    0.97398E-49    0.82059E-52
+    4    3    0.95225E-10    0.10000E+01    0.32008E+04    0.39656E-39    0.84989E-46    0.36789E-49
+    4    3    0.95225E-10    0.10000E+01    0.25813E+04    0.29224E-30    0.14352E-36    0.27260E-40
+    4    3    0.95225E-10    0.10000E+01    0.20817E+04    0.55932E-14    0.12249E-19    0.52474E-24
+    4    3    0.95225E-10    0.10000E+01    0.16788E+04    0.18972E-08    0.18129E-13    0.17863E-18
+    4    3    0.95225E-10    0.10000E+01    0.13538E+04    0.40783E-08    0.68884E-13    0.38447E-18
+    4    3    0.95225E-10    0.10000E+01    0.10918E+04    0.85705E-08    0.25689E-12    0.80869E-18
+    4    3    0.95225E-10    0.10000E+01    0.88049E+03    0.17623E-07    0.94591E-12    0.16639E-17
+    4    3    0.95225E-10    0.10000E+01    0.71007E+03    0.35533E-07    0.34446E-11    0.33564E-17
+    4    3    0.95225E-10    0.10000E+01    0.57264E+03    0.70434E-07    0.12255E-10    0.66552E-17
+    4    3    0.95225E-10    0.10000E+01    0.46180E+03    0.13734E-06    0.41220E-10    0.12979E-16
+    4    3    0.95225E-10    0.10000E+01    0.37242E+03    0.26215E-06    0.12569E-09    0.24778E-16
+    4    3    0.95225E-10    0.10000E+01    0.30034E+03    0.48422E-06    0.33711E-09    0.45770E-16
+    4    3    0.95225E-10    0.10000E+01    0.24221E+03    0.85312E-06    0.78713E-09    0.80643E-16
+    4    3    0.95225E-10    0.10000E+01    0.19533E+03    0.13446E-05    0.14958E-08    0.12710E-15
+    4    3    0.95225E-10    0.10000E+01    0.15752E+03    0.13446E-05    0.14958E-08    0.12710E-15
+    4    3    0.16616E-09    0.10000E+01    0.80645E+05    0.10967E-56    0.83368E-68    0.42739E-66
+    4    3    0.16616E-09    0.10000E+01    0.65036E+05    0.93901E-56    0.13212E-66    0.36102E-65
+    4    3    0.16616E-09    0.10000E+01    0.52449E+05    0.79899E-55    0.17665E-65    0.30444E-64
+    4    3    0.16616E-09    0.10000E+01    0.42297E+05    0.59988E-54    0.24361E-64    0.22383E-63
+    4    3    0.16616E-09    0.10000E+01    0.34111E+05    0.43958E-53    0.38045E-63    0.15370E-62
+    4    3    0.16616E-09    0.10000E+01    0.27509E+05    0.35617E-52    0.82563E-62    0.10472E-61
+    4    3    0.16616E-09    0.10000E+01    0.22184E+05    0.38588E-51    0.24797E-60    0.83754E-61
+    4    3    0.16616E-09    0.10000E+01    0.17891E+05    0.56905E-50    0.77773E-59    0.98792E-60
+    4    3    0.16616E-09    0.10000E+01    0.14428E+05    0.91133E-49    0.22814E-57    0.14901E-58
+    4    3    0.16616E-09    0.10000E+01    0.11635E+05    0.14030E-47    0.63811E-56    0.22839E-57
+    4    3    0.16616E-09    0.10000E+01    0.93834E+04    0.20702E-46    0.17518E-54    0.33763E-56
+    4    3    0.16616E-09    0.10000E+01    0.75673E+04    0.29906E-45    0.47802E-53    0.48805E-55
+    4    3    0.16616E-09    0.10000E+01    0.61026E+04    0.42849E-44    0.13007E-51    0.69942E-54
+    4    3    0.16616E-09    0.10000E+01    0.49215E+04    0.61174E-43    0.35319E-50    0.99920E-53
+    4    3    0.16616E-09    0.10000E+01    0.39689E+04    0.87133E-42    0.95713E-49    0.14250E-51
+    4    3    0.16616E-09    0.10000E+01    0.32008E+04    0.38963E-39    0.83767E-46    0.63827E-49
+    4    3    0.16616E-09    0.10000E+01    0.25813E+04    0.28805E-30    0.14189E-36    0.47289E-40
+    4    3    0.16616E-09    0.10000E+01    0.20817E+04    0.55323E-14    0.12151E-19    0.91080E-24
+    4    3    0.16616E-09    0.10000E+01    0.16788E+04    0.18806E-08    0.18008E-13    0.31020E-18
+    4    3    0.16616E-09    0.10000E+01    0.13538E+04    0.40457E-08    0.68438E-13    0.66772E-18
+    4    3    0.16616E-09    0.10000E+01    0.10918E+04    0.85068E-08    0.25526E-12    0.14046E-17
+    4    3    0.16616E-09    0.10000E+01    0.88049E+03    0.17499E-07    0.93992E-12    0.28904E-17
+    4    3    0.16616E-09    0.10000E+01    0.71007E+03    0.35292E-07    0.34229E-11    0.58307E-17
+    4    3    0.16616E-09    0.10000E+01    0.57264E+03    0.69970E-07    0.12178E-10    0.11562E-16
+    4    3    0.16616E-09    0.10000E+01    0.46180E+03    0.13645E-06    0.40960E-10    0.22549E-16
+    4    3    0.16616E-09    0.10000E+01    0.37242E+03    0.26047E-06    0.12489E-09    0.43045E-16
+    4    3    0.16616E-09    0.10000E+01    0.30034E+03    0.48113E-06    0.33499E-09    0.79514E-16
+    4    3    0.16616E-09    0.10000E+01    0.24221E+03    0.84771E-06    0.78217E-09    0.14010E-15
+    4    3    0.16616E-09    0.10000E+01    0.19533E+03    0.13360E-05    0.14864E-08    0.22080E-15
+    4    3    0.16616E-09    0.10000E+01    0.15752E+03    0.13360E-05    0.14864E-08    0.22080E-15
+    4    3    0.28994E-09    0.10000E+01    0.80645E+05    0.22190E-56    0.16592E-67    0.16672E-65
+    4    3    0.28994E-09    0.10000E+01    0.65036E+05    0.18752E-55    0.26125E-66    0.13967E-64
+    4    3    0.28994E-09    0.10000E+01    0.52449E+05    0.15818E-54    0.34184E-65    0.11731E-63
+    4    3    0.28994E-09    0.10000E+01    0.42297E+05    0.11653E-53    0.44171E-64    0.85925E-63
+    4    3    0.28994E-09    0.10000E+01    0.34111E+05    0.80788E-53    0.58564E-63    0.58669E-62
+    4    3    0.28994E-09    0.10000E+01    0.27509E+05    0.56787E-52    0.97940E-62    0.38784E-61
+    4    3    0.28994E-09    0.10000E+01    0.22184E+05    0.48363E-51    0.25307E-60    0.26781E-60
+    4    3    0.28994E-09    0.10000E+01    0.17891E+05    0.59939E-50    0.77229E-59    0.23874E-59
+    4    3    0.28994E-09    0.10000E+01    0.14428E+05    0.91236E-49    0.22642E-57    0.29721E-58
+    4    3    0.28994E-09    0.10000E+01    0.11635E+05    0.13937E-47    0.63301E-56    0.42501E-57
+    4    3    0.28994E-09    0.10000E+01    0.93834E+04    0.20534E-46    0.17351E-54    0.61335E-56
+    4    3    0.28994E-09    0.10000E+01    0.75673E+04    0.29622E-45    0.47282E-53    0.87495E-55
+    4    3    0.28994E-09    0.10000E+01    0.61026E+04    0.42390E-44    0.12859E-51    0.12412E-53
+    4    3    0.28994E-09    0.10000E+01    0.49215E+04    0.60484E-43    0.34921E-50    0.17593E-52
+    4    3    0.28994E-09    0.10000E+01    0.39689E+04    0.86158E-42    0.94695E-49    0.24948E-51
+    4    3    0.28994E-09    0.10000E+01    0.32008E+04    0.38550E-39    0.82955E-46    0.11133E-48
+    4    3    0.28994E-09    0.10000E+01    0.25813E+04    0.28530E-30    0.14071E-36    0.82299E-40
+    4    3    0.28994E-09    0.10000E+01    0.20817E+04    0.54881E-14    0.12070E-19    0.15832E-23
+    4    3    0.28994E-09    0.10000E+01    0.16788E+04    0.18676E-08    0.17901E-13    0.53892E-18
+    4    3    0.28994E-09    0.10000E+01    0.13538E+04    0.40191E-08    0.68038E-13    0.11598E-17
+    4    3    0.28994E-09    0.10000E+01    0.10918E+04    0.84531E-08    0.25377E-12    0.24394E-17
+    4    3    0.28994E-09    0.10000E+01    0.88049E+03    0.17392E-07    0.93448E-12    0.50191E-17
+    4    3    0.28994E-09    0.10000E+01    0.71007E+03    0.35081E-07    0.34030E-11    0.10124E-16
+    4    3    0.28994E-09    0.10000E+01    0.57264E+03    0.69556E-07    0.12107E-10    0.20074E-16
+    4    3    0.28994E-09    0.10000E+01    0.46180E+03    0.13565E-06    0.40721E-10    0.39147E-16
+    4    3    0.28994E-09    0.10000E+01    0.37242E+03    0.25895E-06    0.12417E-09    0.74729E-16
+    4    3    0.28994E-09    0.10000E+01    0.30034E+03    0.47833E-06    0.33303E-09    0.13803E-15
+    4    3    0.28994E-09    0.10000E+01    0.24221E+03    0.84277E-06    0.77760E-09    0.24320E-15
+    4    3    0.28994E-09    0.10000E+01    0.19533E+03    0.13283E-05    0.14777E-08    0.38329E-15
+    4    3    0.28994E-09    0.10000E+01    0.15752E+03    0.13283E-05    0.14777E-08    0.38329E-15
+    4    3    0.50593E-09    0.10000E+01    0.80645E+05    0.43880E-56    0.32513E-67    0.61002E-65
+    4    3    0.50593E-09    0.10000E+01    0.65036E+05    0.36818E-55    0.51075E-66    0.51113E-64
+    4    3    0.50593E-09    0.10000E+01    0.52449E+05    0.30946E-54    0.66468E-65    0.43002E-63
+    4    3    0.50593E-09    0.10000E+01    0.42297E+05    0.22687E-53    0.84709E-64    0.31666E-62
+    4    3    0.50593E-09    0.10000E+01    0.34111E+05    0.15532E-52    0.10642E-62    0.21878E-61
+    4    3    0.50593E-09    0.10000E+01    0.27509E+05    0.10400E-51    0.14759E-61    0.14617E-60
+    4    3    0.50593E-09    0.10000E+01    0.22184E+05    0.75506E-51    0.29839E-60    0.95991E-60
+    4    3    0.50593E-09    0.10000E+01    0.17891E+05    0.74022E-50    0.81706E-59    0.68798E-59
+    4    3    0.50593E-09    0.10000E+01    0.14428E+05    0.98606E-49    0.23300E-57    0.64331E-58
+    4    3    0.50593E-09    0.10000E+01    0.11635E+05    0.14428E-47    0.64537E-56    0.78971E-57
+    4    3    0.50593E-09    0.10000E+01    0.93834E+04    0.20965E-46    0.17572E-54    0.10899E-55
+    4    3    0.50593E-09    0.10000E+01    0.75673E+04    0.30017E-45    0.47617E-53    0.15398E-54
+    4    3    0.50593E-09    0.10000E+01    0.61026E+04    0.42711E-44    0.12895E-51    0.21762E-53
+    4    3    0.50593E-09    0.10000E+01    0.49215E+04    0.60681E-43    0.34922E-50    0.30734E-52
+    4    3    0.50593E-09    0.10000E+01    0.39689E+04    0.86191E-42    0.94547E-49    0.43437E-51
+    4    3    0.50593E-09    0.10000E+01    0.32008E+04    0.38499E-39    0.82764E-46    0.19336E-48
+    4    3    0.50593E-09    0.10000E+01    0.25813E+04    0.28470E-30    0.14037E-36    0.14273E-39
+    4    3    0.50593E-09    0.10000E+01    0.20817E+04    0.54764E-14    0.12044E-19    0.27447E-23
+    4    3    0.50593E-09    0.10000E+01    0.16788E+04    0.18639E-08    0.17867E-13    0.93438E-18
+    4    3    0.50593E-09    0.10000E+01    0.13538E+04    0.40111E-08    0.67909E-13    0.20106E-17
+    4    3    0.50593E-09    0.10000E+01    0.10918E+04    0.84364E-08    0.25329E-12    0.42288E-17
+    4    3    0.50593E-09    0.10000E+01    0.88049E+03    0.17358E-07    0.93266E-12    0.87007E-17
+    4    3    0.50593E-09    0.10000E+01    0.71007E+03    0.35013E-07    0.33963E-11    0.17550E-16
+    4    3    0.50593E-09    0.10000E+01    0.57264E+03    0.69421E-07    0.12083E-10    0.34796E-16
+    4    3    0.50593E-09    0.10000E+01    0.46180E+03    0.13538E-06    0.40639E-10    0.67856E-16
+    4    3    0.50593E-09    0.10000E+01    0.37242E+03    0.25844E-06    0.12391E-09    0.12952E-15
+    4    3    0.50593E-09    0.10000E+01    0.30034E+03    0.47738E-06    0.33235E-09    0.23924E-15
+    4    3    0.50593E-09    0.10000E+01    0.24221E+03    0.84108E-06    0.77601E-09    0.42150E-15
+    4    3    0.50593E-09    0.10000E+01    0.19533E+03    0.13256E-05    0.14747E-08    0.66428E-15
+    4    3    0.50593E-09    0.10000E+01    0.15752E+03    0.13256E-05    0.14747E-08    0.66428E-15
+    4    3    0.88282E-09    0.10000E+01    0.80645E+05    0.84571E-56    0.62555E-67    0.20275E-64
+    4    3    0.88282E-09    0.10000E+01    0.65036E+05    0.70874E-55    0.98367E-66    0.17023E-63
+    4    3    0.88282E-09    0.10000E+01    0.52449E+05    0.59603E-54    0.12850E-64    0.14358E-62
+    4    3    0.88282E-09    0.10000E+01    0.42297E+05    0.43826E-53    0.16516E-63    0.10633E-61
+    4    3    0.88282E-09    0.10000E+01    0.34111E+05    0.30190E-52    0.20762E-62    0.74338E-61
+    4    3    0.88282E-09    0.10000E+01    0.27509E+05    0.20163E-51    0.26301E-61    0.50527E-60
+    4    3    0.88282E-09    0.10000E+01    0.22184E+05    0.13588E-50    0.41067E-60    0.33159E-59
+    4    3    0.88282E-09    0.10000E+01    0.17891E+05    0.10714E-49    0.90896E-59    0.21590E-58
+    4    3    0.88282E-09    0.10000E+01    0.14428E+05    0.11448E-48    0.24063E-57    0.15769E-57
+    4    3    0.88282E-09    0.10000E+01    0.11635E+05    0.15156E-47    0.65529E-56    0.15191E-56
+    4    3    0.88282E-09    0.10000E+01    0.93834E+04    0.21383E-46    0.17756E-54    0.18922E-55
+    4    3    0.88282E-09    0.10000E+01    0.75673E+04    0.30358E-45    0.47932E-53    0.26268E-54
+    4    3    0.88282E-09    0.10000E+01    0.61026E+04    0.43005E-44    0.12933E-51    0.37268E-53
+    4    3    0.88282E-09    0.10000E+01    0.49215E+04    0.60876E-43    0.34921E-50    0.52850E-52
+    4    3    0.88282E-09    0.10000E+01    0.39689E+04    0.86214E-42    0.94363E-49    0.74821E-51
+    4    3    0.88282E-09    0.10000E+01    0.32008E+04    0.38433E-39    0.82516E-46    0.33323E-48
+    4    3    0.88282E-09    0.10000E+01    0.25813E+04    0.28391E-30    0.13990E-36    0.24611E-39
+    4    3    0.88282E-09    0.10000E+01    0.20817E+04    0.54597E-14    0.12006E-19    0.47384E-23
+    4    3    0.88282E-09    0.10000E+01    0.16788E+04    0.18584E-08    0.17813E-13    0.16149E-17
+    4    3    0.88282E-09    0.10000E+01    0.13538E+04    0.39989E-08    0.67701E-13    0.34755E-17
+    4    3    0.88282E-09    0.10000E+01    0.10918E+04    0.84106E-08    0.25251E-12    0.73110E-17
+    4    3    0.88282E-09    0.10000E+01    0.88049E+03    0.17304E-07    0.92973E-12    0.15044E-16
+    4    3    0.88282E-09    0.10000E+01    0.71007E+03    0.34905E-07    0.33855E-11    0.30347E-16
+    4    3    0.88282E-09    0.10000E+01    0.57264E+03    0.69206E-07    0.12044E-10    0.60169E-16
+    4    3    0.88282E-09    0.10000E+01    0.46180E+03    0.13496E-06    0.40507E-10    0.11733E-15
+    4    3    0.88282E-09    0.10000E+01    0.37242E+03    0.25762E-06    0.12351E-09    0.22396E-15
+    4    3    0.88282E-09    0.10000E+01    0.30034E+03    0.47585E-06    0.33126E-09    0.41365E-15
+    4    3    0.88282E-09    0.10000E+01    0.24221E+03    0.83838E-06    0.77346E-09    0.72875E-15
+    4    3    0.88282E-09    0.10000E+01    0.19533E+03    0.13213E-05    0.14698E-08    0.11485E-14
+    4    3    0.88282E-09    0.10000E+01    0.15752E+03    0.13213E-05    0.14698E-08    0.11485E-14
+    4    3    0.15405E-08    0.10000E+01    0.80645E+05    0.15964E-55    0.11826E-66    0.61969E-64
+    4    3    0.15405E-08    0.10000E+01    0.65036E+05    0.13396E-54    0.18637E-65    0.52131E-63
+    4    3    0.15405E-08    0.10000E+01    0.52449E+05    0.11290E-53    0.24505E-64    0.44059E-62
+    4    3    0.15405E-08    0.10000E+01    0.42297E+05    0.83446E-53    0.31923E-63    0.32769E-61
+    4    3    0.15405E-08    0.10000E+01    0.34111E+05    0.58106E-52    0.40834E-62    0.23108E-60
+    4    3    0.15405E-08    0.10000E+01    0.27509E+05    0.39312E-51    0.50554E-61    0.15934E-59
+    4    3    0.15405E-08    0.10000E+01    0.22184E+05    0.25983E-50    0.66242E-60    0.10605E-58
+    4    3    0.15405E-08    0.10000E+01    0.17891E+05    0.17867E-49    0.11093E-58    0.67665E-58
+    4    3    0.15405E-08    0.10000E+01    0.14428E+05    0.14859E-48    0.24954E-57    0.43421E-57
+    4    3    0.15405E-08    0.10000E+01    0.11635E+05    0.16324E-47    0.65014E-56    0.32648E-56
+    4    3    0.15405E-08    0.10000E+01    0.93834E+04    0.21491E-46    0.17550E-54    0.33543E-55
+    4    3    0.15405E-08    0.10000E+01    0.75673E+04    0.30083E-45    0.47468E-53    0.43884E-54
+    4    3    0.15405E-08    0.10000E+01    0.61026E+04    0.42589E-44    0.12813E-51    0.62346E-53
+    4    3    0.15405E-08    0.10000E+01    0.49215E+04    0.60301E-43    0.34573E-50    0.89381E-52
+    4    3    0.15405E-08    0.10000E+01    0.39689E+04    0.85355E-42    0.93351E-49    0.12749E-50
+    4    3    0.15405E-08    0.10000E+01    0.32008E+04    0.38024E-39    0.81603E-46    0.57010E-48
+    4    3    0.15405E-08    0.10000E+01    0.25813E+04    0.28082E-30    0.13839E-36    0.42212E-39
+    4    3    0.15405E-08    0.10000E+01    0.20817E+04    0.54028E-14    0.11886E-19    0.81490E-23
+    4    3    0.15405E-08    0.10000E+01    0.16788E+04    0.18401E-08    0.17642E-13    0.27831E-17
+    4    3    0.15405E-08    0.10000E+01    0.13538E+04    0.39597E-08    0.67053E-13    0.59912E-17
+    4    3    0.15405E-08    0.10000E+01    0.10918E+04    0.83288E-08    0.25008E-12    0.12606E-16
+    4    3    0.15405E-08    0.10000E+01    0.88049E+03    0.17137E-07    0.92074E-12    0.25945E-16
+    4    3    0.15405E-08    0.10000E+01    0.71007E+03    0.34568E-07    0.33525E-11    0.52342E-16
+    4    3    0.15405E-08    0.10000E+01    0.57264E+03    0.68537E-07    0.11926E-10    0.10378E-15
+    4    3    0.15405E-08    0.10000E+01    0.46180E+03    0.13365E-06    0.40109E-10    0.20238E-15
+    4    3    0.15405E-08    0.10000E+01    0.37242E+03    0.25512E-06    0.12229E-09    0.38628E-15
+    4    3    0.15405E-08    0.10000E+01    0.30034E+03    0.47121E-06    0.32800E-09    0.71343E-15
+    4    3    0.15405E-08    0.10000E+01    0.24221E+03    0.83018E-06    0.76583E-09    0.12568E-14
+    4    3    0.15405E-08    0.10000E+01    0.19533E+03    0.13084E-05    0.14553E-08    0.19807E-14
+    4    3    0.15405E-08    0.10000E+01    0.15752E+03    0.13084E-05    0.14553E-08    0.19807E-14
+    4    3    0.26880E-08    0.10000E+01    0.80645E+05    0.29672E-55    0.22033E-66    0.17715E-63
+    4    3    0.26880E-08    0.10000E+01    0.65036E+05    0.24948E-54    0.34796E-65    0.14926E-62
+    4    3    0.26880E-08    0.10000E+01    0.52449E+05    0.21072E-53    0.46024E-64    0.12634E-61
+    4    3    0.26880E-08    0.10000E+01    0.42297E+05    0.15650E-52    0.60678E-63    0.94258E-61
+    4    3    0.26880E-08    0.10000E+01    0.34111E+05    0.11006E-51    0.79083E-62    0.66879E-60
+    4    3    0.26880E-08    0.10000E+01    0.27509E+05    0.75589E-51    0.98787E-61    0.46624E-59
+    4    3    0.26880E-08    0.10000E+01    0.22184E+05    0.50297E-50    0.12051E-59    0.31530E-58
+    4    3    0.26880E-08    0.10000E+01    0.17891E+05    0.32783E-49    0.16047E-58    0.20331E-57
+    4    3    0.26880E-08    0.10000E+01    0.14428E+05    0.22683E-48    0.27853E-57    0.12590E-56
+    4    3    0.26880E-08    0.10000E+01    0.11635E+05    0.19407E-47    0.64278E-56    0.81088E-56
+    4    3    0.26880E-08    0.10000E+01    0.93834E+04    0.21938E-46    0.16990E-54    0.65477E-55
+    4    3    0.26880E-08    0.10000E+01    0.75673E+04    0.29390E-45    0.46270E-53    0.74126E-54
+    4    3    0.26880E-08    0.10000E+01    0.61026E+04    0.41550E-44    0.12582E-51    0.10249E-52
+    4    3    0.26880E-08    0.10000E+01    0.49215E+04    0.59171E-43    0.34081E-50    0.14865E-51
+    4    3    0.26880E-08    0.10000E+01    0.39689E+04    0.84091E-42    0.92181E-49    0.21485E-50
+    4    3    0.26880E-08    0.10000E+01    0.32008E+04    0.37538E-39    0.80672E-46    0.96872E-48
+    4    3    0.26880E-08    0.10000E+01    0.25813E+04    0.27762E-30    0.13700E-36    0.72080E-39
+    4    3    0.26880E-08    0.10000E+01    0.20817E+04    0.53509E-14    0.11788E-19    0.13974E-22
+    4    3    0.26880E-08    0.10000E+01    0.16788E+04    0.18251E-08    0.17510E-13    0.47862E-17
+    4    3    0.26880E-08    0.10000E+01    0.13538E+04    0.39282E-08    0.66556E-13    0.10306E-16
+    4    3    0.26880E-08    0.10000E+01    0.10918E+04    0.82640E-08    0.24821E-12    0.21692E-16
+    4    3    0.26880E-08    0.10000E+01    0.88049E+03    0.17006E-07    0.91380E-12    0.44654E-16
+    4    3    0.26880E-08    0.10000E+01    0.71007E+03    0.34306E-07    0.33270E-11    0.90095E-16
+    4    3    0.26880E-08    0.10000E+01    0.57264E+03    0.68019E-07    0.11834E-10    0.17865E-15
+    4    3    0.26880E-08    0.10000E+01    0.46180E+03    0.13264E-06    0.39798E-10    0.34836E-15
+    4    3    0.26880E-08    0.10000E+01    0.37242E+03    0.25317E-06    0.12134E-09    0.66487E-15
+    4    3    0.26880E-08    0.10000E+01    0.30034E+03    0.46761E-06    0.32544E-09    0.12279E-14
+    4    3    0.26880E-08    0.10000E+01    0.24221E+03    0.82380E-06    0.75984E-09    0.21630E-14
+    4    3    0.26880E-08    0.10000E+01    0.19533E+03    0.12983E-05    0.14439E-08    0.34086E-14
+    4    3    0.26880E-08    0.10000E+01    0.15752E+03    0.12983E-05    0.14439E-08    0.34086E-14
+    4    3    0.46905E-08    0.10000E+01    0.80645E+05    0.60451E-55    0.45131E-66    0.19611E-62
+    4    3    0.46905E-08    0.10000E+01    0.65036E+05    0.51051E-54    0.71559E-65    0.16588E-61
+    4    3    0.46905E-08    0.10000E+01    0.52449E+05    0.43306E-53    0.95655E-64    0.14091E-60
+    4    3    0.46905E-08    0.10000E+01    0.42297E+05    0.32444E-52    0.12870E-62    0.10586E-59
+    4    3    0.46905E-08    0.10000E+01    0.34111E+05    0.23211E-51    0.17396E-61    0.76113E-59
+    4    3    0.46905E-08    0.10000E+01    0.27509E+05    0.16446E-50    0.23075E-60    0.54334E-58
+    4    3    0.46905E-08    0.10000E+01    0.22184E+05    0.11505E-49    0.30134E-59    0.38309E-57
+    4    3    0.46905E-08    0.10000E+01    0.17891E+05    0.79436E-49    0.39892E-58    0.26410E-56
+    4    3    0.46905E-08    0.10000E+01    0.14428E+05    0.55269E-48    0.57041E-57    0.17713E-55
+    4    3    0.46905E-08    0.10000E+01    0.11635E+05    0.40819E-47    0.95497E-56    0.11566E-54
+    4    3    0.46905E-08    0.10000E+01    0.93834E+04    0.34568E-46    0.19563E-54    0.73844E-54
+    4    3    0.46905E-08    0.10000E+01    0.75673E+04    0.35554E-45    0.47317E-53    0.46939E-53
+    4    3    0.46905E-08    0.10000E+01    0.61026E+04    0.43615E-44    0.12493E-51    0.32200E-52
+    4    3    0.46905E-08    0.10000E+01    0.49215E+04    0.59300E-43    0.33927E-50    0.28377E-51
+    4    3    0.46905E-08    0.10000E+01    0.39689E+04    0.83851E-42    0.92385E-49    0.34421E-50
+    4    3    0.46905E-08    0.10000E+01    0.32008E+04    0.37605E-39    0.81140E-46    0.15480E-47
+    4    3    0.46905E-08    0.10000E+01    0.25813E+04    0.27901E-30    0.13783E-36    0.11854E-38
+    4    3    0.46905E-08    0.10000E+01    0.20817E+04    0.53805E-14    0.11828E-19    0.23538E-22
+    4    3    0.46905E-08    0.10000E+01    0.16788E+04    0.18343E-08    0.17542E-13    0.81321E-17
+    4    3    0.46905E-08    0.10000E+01    0.13538E+04    0.39428E-08    0.66657E-13    0.17325E-16
+    4    3    0.46905E-08    0.10000E+01    0.10918E+04    0.82876E-08    0.24854E-12    0.36250E-16
+    4    3    0.46905E-08    0.10000E+01    0.88049E+03    0.17045E-07    0.91490E-12    0.74346E-16
+    4    3    0.46905E-08    0.10000E+01    0.71007E+03    0.34371E-07    0.33307E-11    0.14961E-15
+    4    3    0.46905E-08    0.10000E+01    0.57264E+03    0.68129E-07    0.11847E-10    0.29603E-15
+    4    3    0.46905E-08    0.10000E+01    0.46180E+03    0.13283E-06    0.39840E-10    0.57628E-15
+    4    3    0.46905E-08    0.10000E+01    0.37242E+03    0.25350E-06    0.12147E-09    0.10984E-14
+    4    3    0.46905E-08    0.10000E+01    0.30034E+03    0.46817E-06    0.32577E-09    0.20264E-14
+    4    3    0.46905E-08    0.10000E+01    0.24221E+03    0.82474E-06    0.76063E-09    0.35669E-14
+    4    3    0.46905E-08    0.10000E+01    0.19533E+03    0.12997E-05    0.14454E-08    0.56181E-14
+    4    3    0.46905E-08    0.10000E+01    0.15752E+03    0.12997E-05    0.14454E-08    0.56181E-14
+    4    3    0.81846E-08    0.10000E+01    0.80645E+05    0.11048E-54    0.82560E-66    0.57821E-62
+    4    3    0.81846E-08    0.10000E+01    0.65036E+05    0.93374E-54    0.13099E-64    0.48929E-61
+    4    3    0.81846E-08    0.10000E+01    0.52449E+05    0.79264E-53    0.17539E-63    0.41584E-60
+    4    3    0.81846E-08    0.10000E+01    0.42297E+05    0.59464E-52    0.23666E-62    0.31265E-59
+    4    3    0.81846E-08    0.10000E+01    0.34111E+05    0.42644E-51    0.32119E-61    0.22512E-58
+    4    3    0.81846E-08    0.10000E+01    0.27509E+05    0.30323E-50    0.42774E-60    0.16112E-57
+    4    3    0.81846E-08    0.10000E+01    0.22184E+05    0.21285E-49    0.55685E-59    0.11410E-56
+    4    3    0.81846E-08    0.10000E+01    0.17891E+05    0.14664E-48    0.71740E-58    0.79239E-56
+    4    3    0.81846E-08    0.10000E+01    0.14428E+05    0.99865E-48    0.94827E-57    0.53734E-55
+    4    3    0.81846E-08    0.10000E+01    0.11635E+05    0.69105E-47    0.13687E-55    0.35581E-54
+    4    3    0.81846E-08    0.10000E+01    0.93834E+04    0.51315E-46    0.23373E-54    0.22990E-53
+    4    3    0.81846E-08    0.10000E+01    0.75673E+04    0.44242E-45    0.49412E-53    0.14482E-52
+    4    3    0.81846E-08    0.10000E+01    0.61026E+04    0.46899E-44    0.12330E-51    0.91444E-52
+    4    3    0.81846E-08    0.10000E+01    0.49215E+04    0.59343E-43    0.33162E-50    0.65827E-51
+    4    3    0.81846E-08    0.10000E+01    0.39689E+04    0.82305E-42    0.90681E-49    0.65581E-50
+    4    3    0.81846E-08    0.10000E+01    0.32008E+04    0.36937E-39    0.80026E-46    0.27506E-47
+    4    3    0.81846E-08    0.10000E+01    0.25813E+04    0.27521E-30    0.13636E-36    0.20963E-38
+    4    3    0.81846E-08    0.10000E+01    0.20817E+04    0.53290E-14    0.11716E-19    0.41852E-22
+    4    3    0.81846E-08    0.10000E+01    0.16788E+04    0.18204E-08    0.17373E-13    0.14420E-16
+    4    3    0.81846E-08    0.10000E+01    0.13538E+04    0.39087E-08    0.66005E-13    0.30344E-16
+    4    3    0.81846E-08    0.10000E+01    0.10918E+04    0.82117E-08    0.24606E-12    0.63024E-16
+    4    3    0.81846E-08    0.10000E+01    0.88049E+03    0.16883E-07    0.90555E-12    0.12864E-15
+    4    3    0.81846E-08    0.10000E+01    0.71007E+03    0.34037E-07    0.32960E-11    0.25802E-15
+    4    3    0.81846E-08    0.10000E+01    0.57264E+03    0.67453E-07    0.11722E-10    0.50933E-15
+    4    3    0.81846E-08    0.10000E+01    0.46180E+03    0.13149E-06    0.39415E-10    0.98972E-15
+    4    3    0.81846E-08    0.10000E+01    0.37242E+03    0.25090E-06    0.12016E-09    0.18838E-14
+    4    3    0.81846E-08    0.10000E+01    0.30034E+03    0.46330E-06    0.32227E-09    0.34721E-14
+    4    3    0.81846E-08    0.10000E+01    0.24221E+03    0.81608E-06    0.75242E-09    0.61075E-14
+    4    3    0.81846E-08    0.10000E+01    0.19533E+03    0.12860E-05    0.14298E-08    0.96158E-14
+    4    3    0.81846E-08    0.10000E+01    0.15752E+03    0.12860E-05    0.14298E-08    0.96158E-14
+    4    3    0.14282E-07    0.10000E+01    0.80645E+05    0.20149E-54    0.15069E-65    0.17496E-61
+    4    3    0.14282E-07    0.10000E+01    0.65036E+05    0.17040E-53    0.23921E-64    0.14811E-60
+    4    3    0.14282E-07    0.10000E+01    0.52449E+05    0.14474E-52    0.32074E-63    0.12592E-59
+    4    3    0.14282E-07    0.10000E+01    0.42297E+05    0.10870E-51    0.43381E-62    0.94733E-59
+    4    3    0.14282E-07    0.10000E+01    0.34111E+05    0.78115E-51    0.59095E-61    0.68291E-58
+    4    3    0.14282E-07    0.10000E+01    0.27509E+05    0.55726E-50    0.79095E-60    0.48971E-57
+    4    3    0.14282E-07    0.10000E+01    0.22184E+05    0.39286E-49    0.10337E-58    0.34798E-56
+    4    3    0.14282E-07    0.10000E+01    0.17891E+05    0.27162E-48    0.13246E-57    0.24302E-55
+    4    3    0.14282E-07    0.10000E+01    0.14428E+05    0.18430E-47    0.16953E-56    0.16620E-54
+    4    3    0.14282E-07    0.10000E+01    0.11635E+05    0.12431E-46    0.22404E-55    0.11131E-53
+    4    3    0.14282E-07    0.10000E+01    0.93834E+04    0.85750E-46    0.32507E-54    0.72869E-53
+    4    3    0.14282E-07    0.10000E+01    0.75673E+04    0.63947E-45    0.56894E-53    0.46271E-52
+    4    3    0.14282E-07    0.10000E+01    0.61026E+04    0.56354E-44    0.12578E-51    0.28470E-51
+    4    3    0.14282E-07    0.10000E+01    0.49215E+04    0.62237E-43    0.32564E-50    0.18036E-50
+    4    3    0.14282E-07    0.10000E+01    0.39689E+04    0.81710E-42    0.88963E-49    0.14342E-49
+    4    3    0.14282E-07    0.10000E+01    0.32008E+04    0.36343E-39    0.78954E-46    0.52245E-47
+    4    3    0.14282E-07    0.10000E+01    0.25813E+04    0.27176E-30    0.13499E-36    0.38659E-38
+    4    3    0.14282E-07    0.10000E+01    0.20817E+04    0.52880E-14    0.11590E-19    0.77245E-22
+    4    3    0.14282E-07    0.10000E+01    0.16788E+04    0.18093E-08    0.17163E-13    0.26374E-16
+    4    3    0.14282E-07    0.10000E+01    0.13538E+04    0.38738E-08    0.65175E-13    0.54254E-16
+    4    3    0.14282E-07    0.10000E+01    0.10918E+04    0.81256E-08    0.24285E-12    0.11111E-15
+    4    3    0.14282E-07    0.10000E+01    0.88049E+03    0.16690E-07    0.89337E-12    0.22474E-15
+    4    3    0.14282E-07    0.10000E+01    0.71007E+03    0.33624E-07    0.32506E-11    0.44792E-15
+    4    3    0.14282E-07    0.10000E+01    0.57264E+03    0.66599E-07    0.11558E-10    0.88014E-15
+    4    3    0.14282E-07    0.10000E+01    0.46180E+03    0.12976E-06    0.38856E-10    0.17045E-14
+    4    3    0.14282E-07    0.10000E+01    0.37242E+03    0.24753E-06    0.11845E-09    0.32363E-14
+    4    3    0.14282E-07    0.10000E+01    0.30034E+03    0.45695E-06    0.31764E-09    0.59543E-14
+    4    3    0.14282E-07    0.10000E+01    0.24221E+03    0.80474E-06    0.74159E-09    0.10461E-13
+    4    3    0.14282E-07    0.10000E+01    0.19533E+03    0.12680E-05    0.14092E-08    0.16458E-13
+    4    3    0.14282E-07    0.10000E+01    0.15752E+03    0.12680E-05    0.14092E-08    0.16458E-13
+    4    3    0.24920E-07    0.10000E+01    0.80645E+05    0.36648E-54    0.27425E-65    0.53880E-61
+    4    3    0.24920E-07    0.10000E+01    0.65036E+05    0.31009E-53    0.43555E-64    0.45626E-60
+    4    3    0.24920E-07    0.10000E+01    0.52449E+05    0.26351E-52    0.58463E-63    0.38801E-59
+    4    3    0.24920E-07    0.10000E+01    0.42297E+05    0.19809E-51    0.79225E-62    0.29207E-58
+    4    3    0.24920E-07    0.10000E+01    0.34111E+05    0.14258E-50    0.10825E-60    0.21074E-57
+    4    3    0.24920E-07    0.10000E+01    0.27509E+05    0.10199E-49    0.14556E-59    0.15136E-56
+    4    3    0.24920E-07    0.10000E+01    0.22184E+05    0.72190E-49    0.19133E-58    0.10784E-55
+    4    3    0.24920E-07    0.10000E+01    0.17891E+05    0.50161E-48    0.24605E-57    0.75631E-55
+    4    3    0.24920E-07    0.10000E+01    0.14428E+05    0.34154E-47    0.31252E-56    0.52055E-54
+    4    3    0.24920E-07    0.10000E+01    0.11635E+05    0.22917E-46    0.39765E-55    0.35169E-53
+    4    3    0.24920E-07    0.10000E+01    0.93834E+04    0.15337E-45    0.52134E-54    0.23281E-52
+    4    3    0.24920E-07    0.10000E+01    0.75673E+04    0.10505E-44    0.76007E-53    0.14965E-51
+    4    3    0.24920E-07    0.10000E+01    0.61026E+04    0.78658E-44    0.13911E-51    0.92227E-51
+    4    3    0.24920E-07    0.10000E+01    0.49215E+04    0.71924E-43    0.32759E-50    0.55322E-50
+    4    3    0.24920E-07    0.10000E+01    0.39689E+04    0.84159E-42    0.87871E-49    0.36854E-49
+    4    3    0.24920E-07    0.10000E+01    0.32008E+04    0.36192E-39    0.78301E-46    0.11041E-46
+    4    3    0.24920E-07    0.10000E+01    0.25813E+04    0.27038E-30    0.13428E-36    0.76254E-38
+    4    3    0.24920E-07    0.10000E+01    0.20817E+04    0.52869E-14    0.11475E-19    0.15125E-21
+    4    3    0.24920E-07    0.10000E+01    0.16788E+04    0.18091E-08    0.16923E-13    0.50722E-16
+    4    3    0.24920E-07    0.10000E+01    0.13538E+04    0.38490E-08    0.64193E-13    0.10050E-15
+    4    3    0.24920E-07    0.10000E+01    0.10918E+04    0.80442E-08    0.23897E-12    0.20088E-15
+    4    3    0.24920E-07    0.10000E+01    0.88049E+03    0.16485E-07    0.87842E-12    0.39975E-15
+    4    3    0.24920E-07    0.10000E+01    0.71007E+03    0.33158E-07    0.31943E-11    0.78769E-15
+    4    3    0.24920E-07    0.10000E+01    0.57264E+03    0.65597E-07    0.11353E-10    0.15351E-14
+    4    3    0.24920E-07    0.10000E+01    0.46180E+03    0.12770E-06    0.38156E-10    0.29548E-14
+    4    3    0.24920E-07    0.10000E+01    0.37242E+03    0.24342E-06    0.11629E-09    0.55855E-14
+    4    3    0.24920E-07    0.10000E+01    0.30034E+03    0.44914E-06    0.31184E-09    0.10244E-13
+    4    3    0.24920E-07    0.10000E+01    0.24221E+03    0.79070E-06    0.72799E-09    0.17959E-13
+    4    3    0.24920E-07    0.10000E+01    0.19533E+03    0.12456E-05    0.13833E-08    0.28216E-13
+    4    3    0.24920E-07    0.10000E+01    0.15752E+03    0.12456E-05    0.13833E-08    0.28216E-13
+    4    3    0.43485E-07    0.10000E+01    0.80645E+05    0.66421E-54    0.49731E-65    0.16705E-60
+    4    3    0.43485E-07    0.10000E+01    0.65036E+05    0.56224E-53    0.79007E-64    0.14150E-59
+    4    3    0.43485E-07    0.10000E+01    0.52449E+05    0.47797E-52    0.10614E-62    0.12036E-58
+    4    3    0.43485E-07    0.10000E+01    0.42297E+05    0.35955E-51    0.14405E-61    0.90638E-58
+    4    3    0.43485E-07    0.10000E+01    0.34111E+05    0.25913E-50    0.19730E-60    0.65450E-57
+    4    3    0.43485E-07    0.10000E+01    0.27509E+05    0.18575E-49    0.26633E-59    0.47067E-56
+    4    3    0.43485E-07    0.10000E+01    0.22184E+05    0.13192E-48    0.35201E-58    0.33602E-55
+    4    3    0.43485E-07    0.10000E+01    0.17891E+05    0.92106E-48    0.45542E-57    0.23645E-54
+    4    3    0.43485E-07    0.10000E+01    0.14428E+05    0.63052E-47    0.57992E-56    0.16354E-53
+    4    3    0.43485E-07    0.10000E+01    0.11635E+05    0.42431E-46    0.73035E-55    0.11122E-52
+    4    3    0.43485E-07    0.10000E+01    0.93834E+04    0.28188E-45    0.91514E-54    0.74274E-52
+    4    3    0.43485E-07    0.10000E+01    0.75673E+04    0.18618E-44    0.11818E-52    0.48284E-51
+    4    3    0.43485E-07    0.10000E+01    0.61026E+04    0.12598E-43    0.17643E-51    0.30076E-50
+    4    3    0.43485E-07    0.10000E+01    0.49215E+04    0.95933E-43    0.35125E-50    0.17817E-49
+    4    3    0.43485E-07    0.10000E+01    0.39689E+04    0.94011E-42    0.88996E-49    0.10735E-48
+    4    3    0.43485E-07    0.10000E+01    0.32008E+04    0.37335E-39    0.79012E-46    0.26528E-46
+    4    3    0.43485E-07    0.10000E+01    0.25813E+04    0.27512E-30    0.13565E-36    0.16441E-37
+    4    3    0.43485E-07    0.10000E+01    0.20817E+04    0.53982E-14    0.11456E-19    0.32044E-21
+    4    3    0.43485E-07    0.10000E+01    0.16788E+04    0.18413E-08    0.16743E-13    0.10464E-15
+    4    3    0.43485E-07    0.10000E+01    0.13538E+04    0.38690E-08    0.63371E-13    0.19637E-15
+    4    3    0.43485E-07    0.10000E+01    0.10918E+04    0.80263E-08    0.23550E-12    0.37798E-15
+    4    3    0.43485E-07    0.10000E+01    0.88049E+03    0.16370E-07    0.86447E-12    0.73256E-15
+    4    3    0.43485E-07    0.10000E+01    0.71007E+03    0.32820E-07    0.31403E-11    0.14164E-14
+    4    3    0.43485E-07    0.10000E+01    0.57264E+03    0.64778E-07    0.11153E-10    0.27220E-14
+    4    3    0.43485E-07    0.10000E+01    0.46180E+03    0.12588E-06    0.37467E-10    0.51855E-14
+    4    3    0.43485E-07    0.10000E+01    0.37242E+03    0.23965E-06    0.11416E-09    0.97281E-14
+    4    3    0.43485E-07    0.10000E+01    0.30034E+03    0.44177E-06    0.30606E-09    0.17746E-13
+    4    3    0.43485E-07    0.10000E+01    0.24221E+03    0.77722E-06    0.71444E-09    0.30994E-13
+    4    3    0.43485E-07    0.10000E+01    0.19533E+03    0.12238E-05    0.13575E-08    0.48585E-13
+    4    3    0.43485E-07    0.10000E+01    0.15752E+03    0.12238E-05    0.13575E-08    0.48585E-13
+    4    3    0.75878E-07    0.10000E+01    0.80645E+05    0.11993E-53    0.89834E-65    0.51898E-60
+    4    3    0.75878E-07    0.10000E+01    0.65036E+05    0.10156E-52    0.14276E-63    0.43969E-59
+    4    3    0.75878E-07    0.10000E+01    0.52449E+05    0.86360E-52    0.19192E-62    0.37408E-58
+    4    3    0.75878E-07    0.10000E+01    0.42297E+05    0.65001E-51    0.26077E-61    0.28180E-57
+    4    3    0.75878E-07    0.10000E+01    0.34111E+05    0.46894E-50    0.35785E-60    0.20362E-56
+    4    3    0.75878E-07    0.10000E+01    0.27509E+05    0.33671E-49    0.48453E-59    0.14658E-55
+    4    3    0.75878E-07    0.10000E+01    0.22184E+05    0.23978E-48    0.64342E-58    0.10482E-54
+    4    3    0.75878E-07    0.10000E+01    0.17891E+05    0.16809E-47    0.83745E-57    0.73953E-54
+    4    3    0.75878E-07    0.10000E+01    0.14428E+05    0.11568E-46    0.10724E-55    0.51345E-53
+    4    3    0.75878E-07    0.10000E+01    0.11635E+05    0.78257E-46    0.13523E-54    0.35101E-52
+    4    3    0.75878E-07    0.10000E+01    0.93834E+04    0.52091E-45    0.16717E-53    0.23599E-51
+    4    3    0.75878E-07    0.10000E+01    0.75673E+04    0.34056E-44    0.20371E-52    0.15484E-50
+    4    3    0.75878E-07    0.10000E+01    0.61026E+04    0.21995E-43    0.26102E-51    0.97599E-50
+    4    3    0.75878E-07    0.10000E+01    0.49215E+04    0.14761E-42    0.42044E-50    0.58107E-49
+    4    3    0.75878E-07    0.10000E+01    0.39689E+04    0.11882E-41    0.94677E-49    0.33516E-48
+    4    3    0.75878E-07    0.10000E+01    0.32008E+04    0.41089E-39    0.82168E-46    0.71605E-46
+    4    3    0.75878E-07    0.10000E+01    0.25813E+04    0.29130E-30    0.14059E-36    0.39078E-37
+    4    3    0.75878E-07    0.10000E+01    0.20817E+04    0.57128E-14    0.11603E-19    0.74205E-21
+    4    3    0.75878E-07    0.10000E+01    0.16788E+04    0.19318E-08    0.16668E-13    0.23485E-15
+    4    3    0.75878E-07    0.10000E+01    0.13538E+04    0.39690E-08    0.62834E-13    0.41196E-15
+    4    3    0.75878E-07    0.10000E+01    0.10918E+04    0.81211E-08    0.23276E-12    0.75305E-15
+    4    3    0.75878E-07    0.10000E+01    0.88049E+03    0.16417E-07    0.85238E-12    0.14042E-14
+    4    3    0.75878E-07    0.10000E+01    0.71007E+03    0.32713E-07    0.30909E-11    0.26372E-14
+    4    3    0.75878E-07    0.10000E+01    0.57264E+03    0.64283E-07    0.10964E-10    0.49576E-14
+    4    3    0.75878E-07    0.10000E+01    0.46180E+03    0.12452E-06    0.36803E-10    0.92874E-14
+    4    3    0.75878E-07    0.10000E+01    0.37242E+03    0.23650E-06    0.11208E-09    0.17207E-13
+    4    3    0.75878E-07    0.10000E+01    0.30034E+03    0.43524E-06    0.30041E-09    0.31106E-13
+    4    3    0.75878E-07    0.10000E+01    0.24221E+03    0.76485E-06    0.70113E-09    0.53989E-13
+    4    3    0.75878E-07    0.10000E+01    0.19533E+03    0.12035E-05    0.13320E-08    0.84303E-13
+    4    3    0.75878E-07    0.10000E+01    0.15752E+03    0.12035E-05    0.13320E-08    0.84303E-13
+    4    3    0.13240E-06    0.10000E+01    0.80645E+05    0.21578E-53    0.16168E-64    0.16137E-59
+    4    3    0.13240E-06    0.10000E+01    0.65036E+05    0.18276E-52    0.25698E-63    0.13674E-58
+    4    3    0.13240E-06    0.10000E+01    0.52449E+05    0.15545E-51    0.34567E-62    0.11635E-57
+    4    3    0.13240E-06    0.10000E+01    0.42297E+05    0.11706E-50    0.47013E-61    0.87677E-57
+    4    3    0.13240E-06    0.10000E+01    0.34111E+05    0.84519E-50    0.64611E-60    0.63386E-56
+    4    3    0.13240E-06    0.10000E+01    0.27509E+05    0.60768E-49    0.87701E-59    0.45668E-55
+    4    3    0.13240E-06    0.10000E+01    0.22184E+05    0.43369E-48    0.11691E-57    0.32702E-54
+    4    3    0.13240E-06    0.10000E+01    0.17891E+05    0.30504E-47    0.15296E-56    0.23122E-53
+    4    3    0.13240E-06    0.10000E+01    0.14428E+05    0.21089E-46    0.19702E-55    0.16103E-52
+    4    3    0.13240E-06    0.10000E+01    0.11635E+05    0.14344E-45    0.24971E-54    0.11054E-51
+    4    3    0.13240E-06    0.10000E+01    0.93834E+04    0.95950E-45    0.30879E-53    0.74717E-51
+    4    3    0.13240E-06    0.10000E+01    0.75673E+04    0.62795E-44    0.36911E-52    0.49391E-50
+    4    3    0.13240E-06    0.10000E+01    0.61026E+04    0.39954E-43    0.43518E-51    0.31460E-49
+    4    3    0.13240E-06    0.10000E+01    0.49215E+04    0.25111E-42    0.57911E-50    0.18926E-48
+    4    3    0.13240E-06    0.10000E+01    0.39689E+04    0.17240E-41    0.10913E-48    0.10775E-47
+    4    3    0.13240E-06    0.10000E+01    0.32008E+04    0.49830E-39    0.89493E-46    0.20995E-45
+    4    3    0.13240E-06    0.10000E+01    0.25813E+04    0.32785E-30    0.15136E-36    0.10157E-36
+    4    3    0.13240E-06    0.10000E+01    0.20817E+04    0.63815E-14    0.12020E-19    0.18712E-20
+    4    3    0.13240E-06    0.10000E+01    0.16788E+04    0.21232E-08    0.16753E-13    0.57469E-15
+    4    3    0.13240E-06    0.10000E+01    0.13538E+04    0.42047E-08    0.62709E-13    0.93866E-15
+    4    3    0.13240E-06    0.10000E+01    0.10918E+04    0.84028E-08    0.23102E-12    0.16141E-14
+    4    3    0.13240E-06    0.10000E+01    0.88049E+03    0.16723E-07    0.84247E-12    0.28632E-14
+    4    3    0.13240E-06    0.10000E+01    0.71007E+03    0.32964E-07    0.30457E-11    0.51658E-14
+    4    3    0.13240E-06    0.10000E+01    0.57264E+03    0.64273E-07    0.10781E-10    0.94033E-14
+    4    3    0.13240E-06    0.10000E+01    0.46180E+03    0.12379E-06    0.36140E-10    0.17172E-13
+    4    3    0.13240E-06    0.10000E+01    0.37242E+03    0.23414E-06    0.10998E-09    0.31196E-13
+    4    3    0.13240E-06    0.10000E+01    0.30034E+03    0.42965E-06    0.29462E-09    0.55583E-13
+    4    3    0.13240E-06    0.10000E+01    0.24221E+03    0.75351E-06    0.68742E-09    0.95488E-13
+    4    3    0.13240E-06    0.10000E+01    0.19533E+03    0.11842E-05    0.13058E-08    0.14815E-12
+    4    3    0.13240E-06    0.10000E+01    0.15752E+03    0.11842E-05    0.13058E-08    0.14815E-12
+    4    3    0.23103E-06    0.10000E+01    0.80645E+05    0.38682E-53    0.28992E-64    0.50026E-59
+    4    3    0.23103E-06    0.10000E+01    0.65036E+05    0.32771E-52    0.46091E-63    0.42398E-58
+    4    3    0.23103E-06    0.10000E+01    0.52449E+05    0.27880E-51    0.62025E-62    0.36082E-57
+    4    3    0.23103E-06    0.10000E+01    0.42297E+05    0.21002E-50    0.84423E-61    0.27196E-56
+    4    3    0.23103E-06    0.10000E+01    0.34111E+05    0.15174E-49    0.11617E-59    0.19670E-55
+    4    3    0.23103E-06    0.10000E+01    0.27509E+05    0.10922E-48    0.15799E-58    0.14182E-54
+    4    3    0.23103E-06    0.10000E+01    0.22184E+05    0.78082E-48    0.21127E-57    0.10167E-53
+    4    3    0.23103E-06    0.10000E+01    0.17891E+05    0.55069E-47    0.27762E-56    0.72011E-53
+    4    3    0.23103E-06    0.10000E+01    0.14428E+05    0.38218E-46    0.35947E-55    0.50278E-52
+    4    3    0.23103E-06    0.10000E+01    0.11635E+05    0.26118E-45    0.45819E-54    0.34627E-51
+    4    3    0.23103E-06    0.10000E+01    0.93834E+04    0.17565E-44    0.56952E-53    0.23508E-50
+    4    3    0.23103E-06    0.10000E+01    0.75673E+04    0.11551E-43    0.67996E-52    0.15632E-49
+    4    3    0.23103E-06    0.10000E+01    0.61026E+04    0.73461E-43    0.77553E-51    0.10044E-48
+    4    3    0.23103E-06    0.10000E+01    0.49215E+04    0.45010E-42    0.90888E-50    0.61094E-48
+    4    3    0.23103E-06    0.10000E+01    0.39689E+04    0.28016E-41    0.14044E-48    0.34814E-47
+    4    3    0.23103E-06    0.10000E+01    0.32008E+04    0.68018E-39    0.10423E-45    0.64389E-45
+    4    3    0.23103E-06    0.10000E+01    0.25813E+04    0.40140E-30    0.17212E-36    0.28225E-36
+    4    3    0.23103E-06    0.10000E+01    0.20817E+04    0.76844E-14    0.12920E-19    0.50472E-20
+    4    3    0.23103E-06    0.10000E+01    0.16788E+04    0.24961E-08    0.17158E-13    0.15128E-14
+    4    3    0.23103E-06    0.10000E+01    0.13538E+04    0.46867E-08    0.63464E-13    0.23173E-14
+    4    3    0.23103E-06    0.10000E+01    0.10918E+04    0.90293E-08    0.23164E-12    0.37469E-14
+    4    3    0.23103E-06    0.10000E+01    0.88049E+03    0.17520E-07    0.83877E-12    0.62871E-14
+    4    3    0.23103E-06    0.10000E+01    0.71007E+03    0.33920E-07    0.30167E-11    0.10804E-13
+    4    3    0.23103E-06    0.10000E+01    0.57264E+03    0.65275E-07    0.10641E-10    0.18859E-13
+    4    3    0.23103E-06    0.10000E+01    0.46180E+03    0.12451E-06    0.35589E-10    0.33245E-13
+    4    3    0.23103E-06    0.10000E+01    0.37242E+03    0.23384E-06    0.10815E-09    0.58691E-13
+    4    3    0.23103E-06    0.10000E+01    0.30034E+03    0.42694E-06    0.28949E-09    0.10230E-12
+    4    3    0.23103E-06    0.10000E+01    0.24221E+03    0.74617E-06    0.67512E-09    0.17296E-12
+    4    3    0.23103E-06    0.10000E+01    0.19533E+03    0.11702E-05    0.12821E-08    0.26562E-12
+    4    3    0.23103E-06    0.10000E+01    0.15752E+03    0.11702E-05    0.12821E-08    0.26562E-12
+    4    3    0.40314E-06    0.10000E+01    0.80645E+05    0.69063E-53    0.51775E-64    0.15352E-58
+    4    3    0.40314E-06    0.10000E+01    0.65036E+05    0.58522E-52    0.82323E-63    0.13013E-57
+    4    3    0.40314E-06    0.10000E+01    0.52449E+05    0.49796E-51    0.11082E-61    0.11075E-56
+    4    3    0.40314E-06    0.10000E+01    0.42297E+05    0.37522E-50    0.15094E-60    0.83497E-56
+    4    3    0.40314E-06    0.10000E+01    0.34111E+05    0.27125E-49    0.20790E-59    0.60412E-55
+    4    3    0.40314E-06    0.10000E+01    0.27509E+05    0.19541E-48    0.28321E-58    0.43582E-54
+    4    3    0.40314E-06    0.10000E+01    0.22184E+05    0.13990E-47    0.37968E-57    0.31273E-53
+    4    3    0.40314E-06    0.10000E+01    0.17891E+05    0.98887E-47    0.50070E-56    0.22182E-52
+    4    3    0.40314E-06    0.10000E+01    0.14428E+05    0.68842E-46    0.65120E-55    0.15519E-51
+    4    3    0.40314E-06    0.10000E+01    0.11635E+05    0.47236E-45    0.83443E-54    0.10716E-50
+    4    3    0.40314E-06    0.10000E+01    0.93834E+04    0.31922E-44    0.10436E-52    0.73004E-50
+    4    3    0.40314E-06    0.10000E+01    0.75673E+04    0.21112E-43    0.12529E-51    0.48775E-49
+    4    3    0.40314E-06    0.10000E+01    0.61026E+04    0.13493E-42    0.14189E-50    0.31559E-48
+    4    3    0.40314E-06    0.10000E+01    0.49215E+04    0.82243E-42    0.15563E-49    0.19384E-47
+    4    3    0.40314E-06    0.10000E+01    0.39689E+04    0.48754E-41    0.20283E-48    0.11113E-46
+    4    3    0.40314E-06    0.10000E+01    0.32008E+04    0.10352E-38    0.13154E-45    0.20002E-44
+    4    3    0.40314E-06    0.10000E+01    0.25813E+04    0.53970E-30    0.20900E-36    0.81439E-36
+    4    3    0.40314E-06    0.10000E+01    0.20817E+04    0.10077E-13    0.14596E-19    0.14184E-19
+    4    3    0.40314E-06    0.10000E+01    0.16788E+04    0.31801E-08    0.18048E-13    0.41784E-14
+    4    3    0.40314E-06    0.10000E+01    0.13538E+04    0.55831E-08    0.65507E-13    0.60866E-14
+    4    3    0.40314E-06    0.10000E+01    0.10918E+04    0.10224E-07    0.23551E-12    0.93320E-14
+    4    3    0.40314E-06    0.10000E+01    0.88049E+03    0.19108E-07    0.84290E-12    0.14855E-13
+    4    3    0.40314E-06    0.10000E+01    0.71007E+03    0.35977E-07    0.30056E-11    0.24268E-13
+    4    3    0.40314E-06    0.10000E+01    0.57264E+03    0.67796E-07    0.10538E-10    0.40400E-13
+    4    3    0.40314E-06    0.10000E+01    0.46180E+03    0.12729E-06    0.35110E-10    0.68211E-13
+    4    3    0.40314E-06    0.10000E+01    0.37242E+03    0.23626E-06    0.10644E-09    0.11600E-12
+    4    3    0.40314E-06    0.10000E+01    0.30034E+03    0.42774E-06    0.28453E-09    0.19614E-12
+    4    3    0.40314E-06    0.10000E+01    0.24221E+03    0.74320E-06    0.66299E-09    0.32403E-12
+    4    3    0.40314E-06    0.10000E+01    0.19533E+03    0.11613E-05    0.12584E-08    0.49012E-12
+    4    3    0.40314E-06    0.10000E+01    0.15752E+03    0.11613E-05    0.12584E-08    0.49012E-12
+    4    3    0.70346E-06    0.10000E+01    0.80645E+05    0.12128E-52    0.90928E-64    0.32557E-58
+    4    3    0.70346E-06    0.10000E+01    0.65036E+05    0.10277E-51    0.14458E-62    0.27597E-57
+    4    3    0.70346E-06    0.10000E+01    0.52449E+05    0.87456E-51    0.19466E-61    0.23490E-56
+    4    3    0.70346E-06    0.10000E+01    0.42297E+05    0.65906E-50    0.26518E-60    0.17710E-55
+    4    3    0.70346E-06    0.10000E+01    0.34111E+05    0.47652E-49    0.36537E-59    0.12815E-54
+    4    3    0.70346E-06    0.10000E+01    0.27509E+05    0.34338E-48    0.49797E-58    0.92466E-54
+    4    3    0.70346E-06    0.10000E+01    0.22184E+05    0.24595E-47    0.66812E-57    0.66368E-53
+    4    3    0.70346E-06    0.10000E+01    0.17891E+05    0.17397E-46    0.88207E-56    0.47094E-52
+    4    3    0.70346E-06    0.10000E+01    0.14428E+05    0.12123E-45    0.11488E-54    0.32968E-51
+    4    3    0.70346E-06    0.10000E+01    0.11635E+05    0.83288E-45    0.14746E-53    0.22785E-50
+    4    3    0.70346E-06    0.10000E+01    0.93834E+04    0.56376E-44    0.18482E-52    0.15538E-49
+    4    3    0.70346E-06    0.10000E+01    0.75673E+04    0.37359E-43    0.22246E-51    0.10396E-48
+    4    3    0.70346E-06    0.10000E+01    0.61026E+04    0.23929E-42    0.25211E-50    0.67402E-48
+    4    3    0.70346E-06    0.10000E+01    0.49215E+04    0.14595E-41    0.27290E-49    0.41523E-47
+    4    3    0.70346E-06    0.10000E+01    0.39689E+04    0.85703E-41    0.33867E-48    0.23867E-46
+    4    3    0.70346E-06    0.10000E+01    0.32008E+04    0.17548E-38    0.20837E-45    0.42701E-44
+    4    3    0.70346E-06    0.10000E+01    0.25813E+04    0.87586E-30    0.32538E-36    0.17030E-35
+    4    3    0.70346E-06    0.10000E+01    0.20817E+04    0.16184E-13    0.22084E-19    0.29420E-19
+    4    3    0.70346E-06    0.10000E+01    0.16788E+04    0.50538E-08    0.26454E-13    0.86264E-14
+    4    3    0.70346E-06    0.10000E+01    0.13538E+04    0.86446E-08    0.95159E-13    0.12389E-13
+    4    3    0.70346E-06    0.10000E+01    0.10918E+04    0.15497E-07    0.33961E-12    0.18697E-13
+    4    3    0.70346E-06    0.10000E+01    0.88049E+03    0.28488E-07    0.12085E-11    0.29271E-13
+    4    3    0.70346E-06    0.10000E+01    0.71007E+03    0.52952E-07    0.42905E-11    0.47020E-13
+    4    3    0.70346E-06    0.10000E+01    0.57264E+03    0.98793E-07    0.14997E-10    0.76973E-13
+    4    3    0.70346E-06    0.10000E+01    0.46180E+03    0.18406E-06    0.49870E-10    0.12788E-12
+    4    3    0.70346E-06    0.10000E+01    0.37242E+03    0.33966E-06    0.15101E-09    0.21427E-12
+    4    3    0.70346E-06    0.10000E+01    0.30034E+03    0.61234E-06    0.40337E-09    0.35778E-12
+    4    3    0.70346E-06    0.10000E+01    0.24221E+03    0.10608E-05    0.93951E-09    0.58519E-12
+    4    3    0.70346E-06    0.10000E+01    0.19533E+03    0.16546E-05    0.17829E-08    0.87923E-12
+    4    3    0.70346E-06    0.10000E+01    0.15752E+03    0.16546E-05    0.17829E-08    0.87923E-12
+    4    3    0.12275E-05    0.10000E+01    0.80645E+05    0.21163E-52    0.15866E-63    0.56810E-58
+    4    3    0.12275E-05    0.10000E+01    0.65036E+05    0.17934E-51    0.25229E-62    0.48155E-57
+    4    3    0.12275E-05    0.10000E+01    0.52449E+05    0.15260E-50    0.33968E-61    0.40988E-56
+    4    3    0.12275E-05    0.10000E+01    0.42297E+05    0.11500E-49    0.46273E-60    0.30903E-55
+    4    3    0.12275E-05    0.10000E+01    0.34111E+05    0.83149E-49    0.63754E-59    0.22361E-54
+    4    3    0.12275E-05    0.10000E+01    0.27509E+05    0.59918E-48    0.86894E-58    0.16135E-53
+    4    3    0.12275E-05    0.10000E+01    0.22184E+05    0.42917E-47    0.11658E-56    0.11581E-52
+    4    3    0.12275E-05    0.10000E+01    0.17891E+05    0.30356E-46    0.15392E-55    0.82177E-52
+    4    3    0.12275E-05    0.10000E+01    0.14428E+05    0.21154E-45    0.20046E-54    0.57527E-51
+    4    3    0.12275E-05    0.10000E+01    0.11635E+05    0.14533E-44    0.25731E-53    0.39758E-50
+    4    3    0.12275E-05    0.10000E+01    0.93834E+04    0.98372E-44    0.32251E-52    0.27112E-49
+    4    3    0.12275E-05    0.10000E+01    0.75673E+04    0.65189E-43    0.38818E-51    0.18140E-48
+    4    3    0.12275E-05    0.10000E+01    0.61026E+04    0.41755E-42    0.43991E-50    0.11761E-47
+    4    3    0.12275E-05    0.10000E+01    0.49215E+04    0.25467E-41    0.47619E-49    0.72455E-47
+    4    3    0.12275E-05    0.10000E+01    0.39689E+04    0.14955E-40    0.59095E-48    0.41646E-46
+    4    3    0.12275E-05    0.10000E+01    0.32008E+04    0.30620E-38    0.36359E-45    0.74511E-44
+    4    3    0.12275E-05    0.10000E+01    0.25813E+04    0.15283E-29    0.56776E-36    0.29717E-35
+    4    3    0.12275E-05    0.10000E+01    0.20817E+04    0.28241E-13    0.38535E-19    0.51336E-19
+    4    3    0.12275E-05    0.10000E+01    0.16788E+04    0.88186E-08    0.46160E-13    0.15053E-13
+    4    3    0.12275E-05    0.10000E+01    0.13538E+04    0.15084E-07    0.16605E-12    0.21618E-13
+    4    3    0.12275E-05    0.10000E+01    0.10918E+04    0.27042E-07    0.59260E-12    0.32625E-13
+    4    3    0.12275E-05    0.10000E+01    0.88049E+03    0.49709E-07    0.21087E-11    0.51077E-13
+    4    3    0.12275E-05    0.10000E+01    0.71007E+03    0.92398E-07    0.74867E-11    0.82048E-13
+    4    3    0.12275E-05    0.10000E+01    0.57264E+03    0.17239E-06    0.26170E-10    0.13431E-12
+    4    3    0.12275E-05    0.10000E+01    0.46180E+03    0.32118E-06    0.87020E-10    0.22314E-12
+    4    3    0.12275E-05    0.10000E+01    0.37242E+03    0.59269E-06    0.26351E-09    0.37389E-12
+    4    3    0.12275E-05    0.10000E+01    0.30034E+03    0.10685E-05    0.70386E-09    0.62431E-12
+    4    3    0.12275E-05    0.10000E+01    0.24221E+03    0.18511E-05    0.16394E-08    0.10211E-11
+    4    3    0.12275E-05    0.10000E+01    0.19533E+03    0.28872E-05    0.31110E-08    0.15342E-11
+    4    3    0.12275E-05    0.10000E+01    0.15752E+03    0.28872E-05    0.31110E-08    0.15342E-11
+    4    3    0.21419E-05    0.10000E+01    0.80645E+05    0.36928E-52    0.27686E-63    0.99129E-58
+    4    3    0.21419E-05    0.10000E+01    0.65036E+05    0.31293E-51    0.44023E-62    0.84028E-57
+    4    3    0.21419E-05    0.10000E+01    0.52449E+05    0.26629E-50    0.59272E-61    0.71521E-56
+    4    3    0.21419E-05    0.10000E+01    0.42297E+05    0.20067E-49    0.80743E-60    0.53923E-55
+    4    3    0.21419E-05    0.10000E+01    0.34111E+05    0.14509E-48    0.11125E-58    0.39019E-54
+    4    3    0.21419E-05    0.10000E+01    0.27509E+05    0.10455E-47    0.15162E-57    0.28154E-53
+    4    3    0.21419E-05    0.10000E+01    0.22184E+05    0.74888E-47    0.20343E-56    0.20208E-52
+    4    3    0.21419E-05    0.10000E+01    0.17891E+05    0.52970E-46    0.26858E-55    0.14339E-51
+    4    3    0.21419E-05    0.10000E+01    0.14428E+05    0.36912E-45    0.34980E-54    0.10038E-50
+    4    3    0.21419E-05    0.10000E+01    0.11635E+05    0.25360E-44    0.44898E-53    0.69375E-50
+    4    3    0.21419E-05    0.10000E+01    0.93834E+04    0.17165E-43    0.56276E-52    0.47309E-49
+    4    3    0.21419E-05    0.10000E+01    0.75673E+04    0.11375E-42    0.67736E-51    0.31653E-48
+    4    3    0.21419E-05    0.10000E+01    0.61026E+04    0.72859E-42    0.76762E-50    0.20523E-47
+    4    3    0.21419E-05    0.10000E+01    0.49215E+04    0.44438E-41    0.83093E-49    0.12643E-46
+    4    3    0.21419E-05    0.10000E+01    0.39689E+04    0.26095E-40    0.10312E-47    0.72670E-46
+    4    3    0.21419E-05    0.10000E+01    0.32008E+04    0.53430E-38    0.63445E-45    0.13002E-43
+    4    3    0.21419E-05    0.10000E+01    0.25813E+04    0.26668E-29    0.99071E-36    0.51855E-35
+    4    3    0.21419E-05    0.10000E+01    0.20817E+04    0.49279E-13    0.67241E-19    0.89578E-19
+    4    3    0.21419E-05    0.10000E+01    0.16788E+04    0.15388E-07    0.80547E-13    0.26266E-13
+    4    3    0.21419E-05    0.10000E+01    0.13538E+04    0.26321E-07    0.28974E-12    0.37721E-13
+    4    3    0.21419E-05    0.10000E+01    0.10918E+04    0.47187E-07    0.10341E-11    0.56928E-13
+    4    3    0.21419E-05    0.10000E+01    0.88049E+03    0.86740E-07    0.36796E-11    0.89126E-13
+    4    3    0.21419E-05    0.10000E+01    0.71007E+03    0.16123E-06    0.13064E-10    0.14317E-12
+    4    3    0.21419E-05    0.10000E+01    0.57264E+03    0.30081E-06    0.45665E-10    0.23437E-12
+    4    3    0.21419E-05    0.10000E+01    0.46180E+03    0.56043E-06    0.15184E-09    0.38936E-12
+    4    3    0.21419E-05    0.10000E+01    0.37242E+03    0.10342E-05    0.45980E-09    0.65242E-12
+    4    3    0.21419E-05    0.10000E+01    0.30034E+03    0.18645E-05    0.12282E-08    0.10894E-11
+    4    3    0.21419E-05    0.10000E+01    0.24221E+03    0.32300E-05    0.28606E-08    0.17818E-11
+    4    3    0.21419E-05    0.10000E+01    0.19533E+03    0.50379E-05    0.54285E-08    0.26771E-11
+    4    3    0.21419E-05    0.10000E+01    0.15752E+03    0.50379E-05    0.54285E-08    0.26771E-11
+    4    3    0.37375E-05    0.10000E+01    0.80645E+05    0.64437E-52    0.48310E-63    0.17297E-57
+    4    3    0.37375E-05    0.10000E+01    0.65036E+05    0.54604E-51    0.76818E-62    0.14662E-56
+    4    3    0.37375E-05    0.10000E+01    0.52449E+05    0.46465E-50    0.10343E-60    0.12480E-55
+    4    3    0.37375E-05    0.10000E+01    0.42297E+05    0.35016E-49    0.14089E-59    0.94093E-55
+    4    3    0.37375E-05    0.10000E+01    0.34111E+05    0.25317E-48    0.19412E-58    0.68086E-54
+    4    3    0.37375E-05    0.10000E+01    0.27509E+05    0.18244E-47    0.26457E-57    0.49127E-53
+    4    3    0.37375E-05    0.10000E+01    0.22184E+05    0.13067E-46    0.35497E-56    0.35261E-52
+    4    3    0.37375E-05    0.10000E+01    0.17891E+05    0.92429E-46    0.46865E-55    0.25021E-51
+    4    3    0.37375E-05    0.10000E+01    0.14428E+05    0.64410E-45    0.61037E-54    0.17516E-50
+    4    3    0.37375E-05    0.10000E+01    0.11635E+05    0.44251E-44    0.78345E-53    0.12106E-49
+    4    3    0.37375E-05    0.10000E+01    0.93834E+04    0.29952E-43    0.98198E-52    0.82552E-49
+    4    3    0.37375E-05    0.10000E+01    0.75673E+04    0.19849E-42    0.11820E-50    0.55232E-48
+    4    3    0.37375E-05    0.10000E+01    0.61026E+04    0.12713E-41    0.13395E-49    0.35811E-47
+    4    3    0.37375E-05    0.10000E+01    0.49215E+04    0.77541E-41    0.14499E-48    0.22061E-46
+    4    3    0.37375E-05    0.10000E+01    0.39689E+04    0.45534E-40    0.17993E-47    0.12680E-45
+    4    3    0.37375E-05    0.10000E+01    0.32008E+04    0.93233E-38    0.11071E-44    0.22687E-43
+    4    3    0.37375E-05    0.10000E+01    0.25813E+04    0.46535E-29    0.17287E-35    0.90483E-35
+    4    3    0.37375E-05    0.10000E+01    0.20817E+04    0.85988E-13    0.11733E-18    0.15631E-18
+    4    3    0.37375E-05    0.10000E+01    0.16788E+04    0.26851E-07    0.14055E-12    0.45832E-13
+    4    3    0.37375E-05    0.10000E+01    0.13538E+04    0.45929E-07    0.50558E-12    0.65822E-13
+    4    3    0.37375E-05    0.10000E+01    0.10918E+04    0.82338E-07    0.18044E-11    0.99336E-13
+    4    3    0.37375E-05    0.10000E+01    0.88049E+03    0.15136E-06    0.64206E-11    0.15552E-12
+    4    3    0.37375E-05    0.10000E+01    0.71007E+03    0.28133E-06    0.22796E-10    0.24982E-12
+    4    3    0.37375E-05    0.10000E+01    0.57264E+03    0.52489E-06    0.79682E-10    0.40896E-12
+    4    3    0.37375E-05    0.10000E+01    0.46180E+03    0.97792E-06    0.26496E-09    0.67941E-12
+    4    3    0.37375E-05    0.10000E+01    0.37242E+03    0.18046E-05    0.80232E-09    0.11384E-11
+    4    3    0.37375E-05    0.10000E+01    0.30034E+03    0.32534E-05    0.21431E-08    0.19009E-11
+    4    3    0.37375E-05    0.10000E+01    0.24221E+03    0.56362E-05    0.49916E-08    0.31091E-11
+    4    3    0.37375E-05    0.10000E+01    0.19533E+03    0.87909E-05    0.94723E-08    0.46713E-11
+    4    3    0.37375E-05    0.10000E+01    0.15752E+03    0.87909E-05    0.94723E-08    0.46713E-11
+    4    3    0.65217E-05    0.10000E+01    0.80645E+05    0.11244E-51    0.84298E-63    0.30183E-57
+    4    3    0.65217E-05    0.10000E+01    0.65036E+05    0.95281E-51    0.13404E-61    0.25585E-56
+    4    3    0.65217E-05    0.10000E+01    0.52449E+05    0.81079E-50    0.18047E-60    0.21777E-55
+    4    3    0.65217E-05    0.10000E+01    0.42297E+05    0.61101E-49    0.24585E-59    0.16419E-54
+    4    3    0.65217E-05    0.10000E+01    0.34111E+05    0.44177E-48    0.33873E-58    0.11881E-53
+    4    3    0.65217E-05    0.10000E+01    0.27509E+05    0.31834E-47    0.46167E-57    0.85724E-53
+    4    3    0.65217E-05    0.10000E+01    0.22184E+05    0.22802E-46    0.61940E-56    0.61529E-52
+    4    3    0.65217E-05    0.10000E+01    0.17891E+05    0.16128E-45    0.81776E-55    0.43661E-51
+    4    3    0.65217E-05    0.10000E+01    0.14428E+05    0.11239E-44    0.10651E-53    0.30564E-50
+    4    3    0.65217E-05    0.10000E+01    0.11635E+05    0.77216E-44    0.13671E-52    0.21124E-49
+    4    3    0.65217E-05    0.10000E+01    0.93834E+04    0.52265E-43    0.17135E-51    0.14405E-48
+    4    3    0.65217E-05    0.10000E+01    0.75673E+04    0.34635E-42    0.20624E-50    0.96377E-48
+    4    3    0.65217E-05    0.10000E+01    0.61026E+04    0.22184E-41    0.23373E-49    0.62488E-47
+    4    3    0.65217E-05    0.10000E+01    0.49215E+04    0.13530E-40    0.25300E-48    0.38495E-46
+    4    3    0.65217E-05    0.10000E+01    0.39689E+04    0.79454E-40    0.31397E-47    0.22127E-45
+    4    3    0.65217E-05    0.10000E+01    0.32008E+04    0.16269E-37    0.19318E-44    0.39588E-43
+    4    3    0.65217E-05    0.10000E+01    0.25813E+04    0.81200E-29    0.30165E-35    0.15789E-34
+    4    3    0.65217E-05    0.10000E+01    0.20817E+04    0.15004E-12    0.20474E-18    0.27275E-18
+    4    3    0.65217E-05    0.10000E+01    0.16788E+04    0.46853E-07    0.24525E-12    0.79974E-13
+    4    3    0.65217E-05    0.10000E+01    0.13538E+04    0.80143E-07    0.88221E-12    0.11485E-12
+    4    3    0.65217E-05    0.10000E+01    0.10918E+04    0.14368E-06    0.31485E-11    0.17334E-12
+    4    3    0.65217E-05    0.10000E+01    0.88049E+03    0.26411E-06    0.11204E-10    0.27137E-12
+    4    3    0.65217E-05    0.10000E+01    0.71007E+03    0.49091E-06    0.39777E-10    0.43592E-12
+    4    3    0.65217E-05    0.10000E+01    0.57264E+03    0.91590E-06    0.13904E-09    0.71361E-12
+    4    3    0.65217E-05    0.10000E+01    0.46180E+03    0.17064E-05    0.46234E-09    0.11855E-11
+    4    3    0.65217E-05    0.10000E+01    0.37242E+03    0.31490E-05    0.14000E-08    0.19865E-11
+    4    3    0.65217E-05    0.10000E+01    0.30034E+03    0.56770E-05    0.37396E-08    0.33169E-11
+    4    3    0.65217E-05    0.10000E+01    0.24221E+03    0.98348E-05    0.87101E-08    0.54253E-11
+    4    3    0.65217E-05    0.10000E+01    0.19533E+03    0.15340E-04    0.16529E-07    0.81512E-11
+    4    3    0.65217E-05    0.10000E+01    0.15752E+03    0.15340E-04    0.16529E-07    0.81512E-11
+    4    3    0.11380E-04    0.10000E+01    0.80645E+05    0.19620E-51    0.14710E-62    0.52668E-57
+    4    3    0.11380E-04    0.10000E+01    0.65036E+05    0.16626E-50    0.23390E-61    0.44644E-56
+    4    3    0.11380E-04    0.10000E+01    0.52449E+05    0.14148E-49    0.31491E-60    0.37999E-55
+    4    3    0.11380E-04    0.10000E+01    0.42297E+05    0.10662E-48    0.42899E-59    0.28649E-54
+    4    3    0.11380E-04    0.10000E+01    0.34111E+05    0.77087E-48    0.59106E-58    0.20731E-53
+    4    3    0.11380E-04    0.10000E+01    0.27509E+05    0.55549E-47    0.80558E-57    0.14958E-52
+    4    3    0.11380E-04    0.10000E+01    0.22184E+05    0.39788E-46    0.10808E-55    0.10736E-51
+    4    3    0.11380E-04    0.10000E+01    0.17891E+05    0.28143E-45    0.14269E-54    0.76185E-51
+    4    3    0.11380E-04    0.10000E+01    0.14428E+05    0.19612E-44    0.18585E-53    0.53333E-50
+    4    3    0.11380E-04    0.10000E+01    0.11635E+05    0.13474E-43    0.23855E-52    0.36859E-49
+    4    3    0.11380E-04    0.10000E+01    0.93834E+04    0.91200E-43    0.29899E-51    0.25136E-48
+    4    3    0.11380E-04    0.10000E+01    0.75673E+04    0.60436E-42    0.35988E-50    0.16817E-47
+    4    3    0.11380E-04    0.10000E+01    0.61026E+04    0.38710E-41    0.40784E-49    0.10904E-46
+    4    3    0.11380E-04    0.10000E+01    0.49215E+04    0.23610E-40    0.44147E-48    0.67172E-46
+    4    3    0.11380E-04    0.10000E+01    0.39689E+04    0.13864E-39    0.54787E-47    0.38609E-45
+    4    3    0.11380E-04    0.10000E+01    0.32008E+04    0.28388E-37    0.33708E-44    0.69079E-43
+    4    3    0.11380E-04    0.10000E+01    0.25813E+04    0.14169E-28    0.52637E-35    0.27550E-34
+    4    3    0.11380E-04    0.10000E+01    0.20817E+04    0.26182E-12    0.35725E-18    0.47593E-18
+    4    3    0.11380E-04    0.10000E+01    0.16788E+04    0.81756E-07    0.42795E-12    0.13955E-12
+    4    3    0.11380E-04    0.10000E+01    0.13538E+04    0.13984E-06    0.15394E-11    0.20041E-12
+    4    3    0.11380E-04    0.10000E+01    0.10918E+04    0.25070E-06    0.54940E-11    0.30246E-12
+    4    3    0.11380E-04    0.10000E+01    0.88049E+03    0.46085E-06    0.19550E-10    0.47353E-12
+    4    3    0.11380E-04    0.10000E+01    0.71007E+03    0.85661E-06    0.69408E-10    0.76065E-12
+    4    3    0.11380E-04    0.10000E+01    0.57264E+03    0.15982E-05    0.24262E-09    0.12452E-11
+    4    3    0.11380E-04    0.10000E+01    0.46180E+03    0.29776E-05    0.80675E-09    0.20687E-11
+    4    3    0.11380E-04    0.10000E+01    0.37242E+03    0.54947E-05    0.24429E-08    0.34663E-11
+    4    3    0.11380E-04    0.10000E+01    0.30034E+03    0.99060E-05    0.65254E-08    0.57879E-11
+    4    3    0.11380E-04    0.10000E+01    0.24221E+03    0.17161E-04    0.15199E-07    0.94667E-11
+    4    3    0.11380E-04    0.10000E+01    0.19533E+03    0.26767E-04    0.28842E-07    0.14223E-10
+    4    3    0.11380E-04    0.10000E+01    0.15752E+03    0.26767E-04    0.28842E-07    0.14223E-10
+    4    3    0.19857E-04    0.10000E+01    0.80645E+05    0.34235E-51    0.25667E-62    0.91902E-57
+    4    3    0.19857E-04    0.10000E+01    0.65036E+05    0.29011E-50    0.40813E-61    0.77901E-56
+    4    3    0.19857E-04    0.10000E+01    0.52449E+05    0.24687E-49    0.54950E-60    0.66306E-55
+    4    3    0.19857E-04    0.10000E+01    0.42297E+05    0.18604E-48    0.74856E-59    0.49991E-54
+    4    3    0.19857E-04    0.10000E+01    0.34111E+05    0.13451E-47    0.10314E-57    0.36174E-53
+    4    3    0.19857E-04    0.10000E+01    0.27509E+05    0.96929E-47    0.14057E-56    0.26101E-52
+    4    3    0.19857E-04    0.10000E+01    0.22184E+05    0.69427E-46    0.18860E-55    0.18734E-51
+    4    3    0.19857E-04    0.10000E+01    0.17891E+05    0.49108E-45    0.24899E-54    0.13294E-50
+    4    3    0.19857E-04    0.10000E+01    0.14428E+05    0.34221E-44    0.32429E-53    0.93063E-50
+    4    3    0.19857E-04    0.10000E+01    0.11635E+05    0.23511E-43    0.41625E-52    0.64317E-49
+    4    3    0.19857E-04    0.10000E+01    0.93834E+04    0.15914E-42    0.52173E-51    0.43860E-48
+    4    3    0.19857E-04    0.10000E+01    0.75673E+04    0.10546E-41    0.62797E-50    0.29345E-47
+    4    3    0.19857E-04    0.10000E+01    0.61026E+04    0.67547E-41    0.71166E-49    0.19026E-46
+    4    3    0.19857E-04    0.10000E+01    0.49215E+04    0.41198E-40    0.77034E-48    0.11721E-45
+    4    3    0.19857E-04    0.10000E+01    0.39689E+04    0.24192E-39    0.95599E-47    0.67371E-45
+    4    3    0.19857E-04    0.10000E+01    0.32008E+04    0.49535E-37    0.58819E-44    0.12054E-42
+    4    3    0.19857E-04    0.10000E+01    0.25813E+04    0.24724E-28    0.91848E-35    0.48074E-34
+    4    3    0.19857E-04    0.10000E+01    0.20817E+04    0.45686E-12    0.62338E-18    0.83047E-18
+    4    3    0.19857E-04    0.10000E+01    0.16788E+04    0.14266E-06    0.74674E-12    0.24351E-12
+    4    3    0.19857E-04    0.10000E+01    0.13538E+04    0.24402E-06    0.26862E-11    0.34971E-12
+    4    3    0.19857E-04    0.10000E+01    0.10918E+04    0.43746E-06    0.95866E-11    0.52777E-12
+    4    3    0.19857E-04    0.10000E+01    0.88049E+03    0.80415E-06    0.34113E-10    0.82628E-12
+    4    3    0.19857E-04    0.10000E+01    0.71007E+03    0.14947E-05    0.12111E-09    0.13273E-11
+    4    3    0.19857E-04    0.10000E+01    0.57264E+03    0.27888E-05    0.42335E-09    0.21728E-11
+    4    3    0.19857E-04    0.10000E+01    0.46180E+03    0.51957E-05    0.14077E-08    0.36097E-11
+    4    3    0.19857E-04    0.10000E+01    0.37242E+03    0.95880E-05    0.42628E-08    0.60486E-11
+    4    3    0.19857E-04    0.10000E+01    0.30034E+03    0.17285E-04    0.11386E-07    0.10099E-10
+    4    3    0.19857E-04    0.10000E+01    0.24221E+03    0.29945E-04    0.26521E-07    0.16519E-10
+    4    3    0.19857E-04    0.10000E+01    0.19533E+03    0.46706E-04    0.50327E-07    0.24819E-10
+    4    3    0.19857E-04    0.10000E+01    0.15752E+03    0.46706E-04    0.50327E-07    0.24819E-10
+    4    3    0.34650E-04    0.10000E+01    0.80645E+05    0.59739E-51    0.44788E-62    0.16036E-56
+    4    3    0.34650E-04    0.10000E+01    0.65036E+05    0.50623E-50    0.71217E-61    0.13593E-55
+    4    3    0.34650E-04    0.10000E+01    0.52449E+05    0.43078E-49    0.95885E-60    0.11570E-54
+    4    3    0.34650E-04    0.10000E+01    0.42297E+05    0.32463E-48    0.13062E-58    0.87232E-54
+    4    3    0.34650E-04    0.10000E+01    0.34111E+05    0.23472E-47    0.17997E-57    0.63122E-53
+    4    3    0.34650E-04    0.10000E+01    0.27509E+05    0.16914E-46    0.24528E-56    0.45545E-52
+    4    3    0.34650E-04    0.10000E+01    0.22184E+05    0.12115E-45    0.32909E-55    0.32690E-51
+    4    3    0.34650E-04    0.10000E+01    0.17891E+05    0.85690E-45    0.43448E-54    0.23197E-50
+    4    3    0.34650E-04    0.10000E+01    0.14428E+05    0.59714E-44    0.56587E-53    0.16239E-49
+    4    3    0.34650E-04    0.10000E+01    0.11635E+05    0.41025E-43    0.72633E-52    0.11223E-48
+    4    3    0.34650E-04    0.10000E+01    0.93834E+04    0.27769E-42    0.91038E-51    0.76533E-48
+    4    3    0.34650E-04    0.10000E+01    0.75673E+04    0.18402E-41    0.10958E-49    0.51205E-47
+    4    3    0.34650E-04    0.10000E+01    0.61026E+04    0.11787E-40    0.12418E-48    0.33200E-46
+    4    3    0.34650E-04    0.10000E+01    0.49215E+04    0.71888E-40    0.13442E-47    0.20453E-45
+    4    3    0.34650E-04    0.10000E+01    0.39689E+04    0.42214E-39    0.16681E-46    0.11756E-44
+    4    3    0.34650E-04    0.10000E+01    0.32008E+04    0.86435E-37    0.10264E-43    0.21033E-42
+    4    3    0.34650E-04    0.10000E+01    0.25813E+04    0.43142E-28    0.16027E-34    0.83886E-34
+    4    3    0.34650E-04    0.10000E+01    0.20817E+04    0.79719E-12    0.10878E-17    0.14491E-17
+    4    3    0.34650E-04    0.10000E+01    0.16788E+04    0.24893E-06    0.13030E-11    0.42490E-12
+    4    3    0.34650E-04    0.10000E+01    0.13538E+04    0.42580E-06    0.46872E-11    0.61023E-12
+    4    3    0.34650E-04    0.10000E+01    0.10918E+04    0.76335E-06    0.16728E-10    0.92093E-12
+    4    3    0.34650E-04    0.10000E+01    0.88049E+03    0.14032E-05    0.59525E-10    0.14418E-11
+    4    3    0.34650E-04    0.10000E+01    0.71007E+03    0.26082E-05    0.21134E-09    0.23161E-11
+    4    3    0.34650E-04    0.10000E+01    0.57264E+03    0.48662E-05    0.73872E-09    0.37914E-11
+    4    3    0.34650E-04    0.10000E+01    0.46180E+03    0.90662E-05    0.24564E-08    0.62987E-11
+    4    3    0.34650E-04    0.10000E+01    0.37242E+03    0.16730E-04    0.74383E-08    0.10554E-10
+    4    3    0.34650E-04    0.10000E+01    0.30034E+03    0.30162E-04    0.19869E-07    0.17623E-10
+    4    3    0.34650E-04    0.10000E+01    0.24221E+03    0.52252E-04    0.46277E-07    0.28824E-10
+    4    3    0.34650E-04    0.10000E+01    0.19533E+03    0.81499E-04    0.87817E-07    0.43307E-10
+    4    3    0.34650E-04    0.10000E+01    0.15752E+03    0.81499E-04    0.87817E-07    0.43307E-10
+    4    3    0.60462E-04    0.10000E+01    0.80645E+05    0.10424E-50    0.78152E-62    0.27982E-56
+    4    3    0.60462E-04    0.10000E+01    0.65036E+05    0.88334E-50    0.12427E-60    0.23719E-55
+    4    3    0.60462E-04    0.10000E+01    0.52449E+05    0.75168E-49    0.16731E-59    0.20189E-54
+    4    3    0.60462E-04    0.10000E+01    0.42297E+05    0.56646E-48    0.22792E-58    0.15221E-53
+    4    3    0.60462E-04    0.10000E+01    0.34111E+05    0.40956E-47    0.31403E-57    0.11014E-52
+    4    3    0.60462E-04    0.10000E+01    0.27509E+05    0.29513E-46    0.42801E-56    0.79474E-52
+    4    3    0.60462E-04    0.10000E+01    0.22184E+05    0.21139E-45    0.57424E-55    0.57043E-51
+    4    3    0.60462E-04    0.10000E+01    0.17891E+05    0.14952E-44    0.75814E-54    0.40477E-50
+    4    3    0.60462E-04    0.10000E+01    0.14428E+05    0.10420E-43    0.98741E-53    0.28336E-49
+    4    3    0.60462E-04    0.10000E+01    0.11635E+05    0.71586E-43    0.12674E-51    0.19583E-48
+    4    3    0.60462E-04    0.10000E+01    0.93834E+04    0.48455E-42    0.15886E-50    0.13355E-47
+    4    3    0.60462E-04    0.10000E+01    0.75673E+04    0.32110E-41    0.19121E-49    0.89350E-47
+    4    3    0.60462E-04    0.10000E+01    0.61026E+04    0.20567E-40    0.21669E-48    0.57932E-46
+    4    3    0.60462E-04    0.10000E+01    0.49215E+04    0.12544E-39    0.23455E-47    0.35689E-45
+    4    3    0.60462E-04    0.10000E+01    0.39689E+04    0.73661E-39    0.29108E-46    0.20513E-44
+    4    3    0.60462E-04    0.10000E+01    0.32008E+04    0.15082E-36    0.17909E-43    0.36702E-42
+    4    3    0.60462E-04    0.10000E+01    0.25813E+04    0.75280E-28    0.27966E-34    0.14638E-33
+    4    3    0.60462E-04    0.10000E+01    0.20817E+04    0.13910E-11    0.18981E-17    0.25286E-17
+    4    3    0.60462E-04    0.10000E+01    0.16788E+04    0.43437E-06    0.22737E-11    0.74143E-12
+    4    3    0.60462E-04    0.10000E+01    0.13538E+04    0.74300E-06    0.81789E-11    0.10648E-11
+    4    3    0.60462E-04    0.10000E+01    0.10918E+04    0.13320E-05    0.29189E-10    0.16070E-11
+    4    3    0.60462E-04    0.10000E+01    0.88049E+03    0.24485E-05    0.10387E-09    0.25159E-11
+    4    3    0.60462E-04    0.10000E+01    0.71007E+03    0.45512E-05    0.36877E-09    0.40414E-11
+    4    3    0.60462E-04    0.10000E+01    0.57264E+03    0.84912E-05    0.12890E-08    0.66158E-11
+    4    3    0.60462E-04    0.10000E+01    0.46180E+03    0.15820E-04    0.42863E-08    0.10991E-10
+    4    3    0.60462E-04    0.10000E+01    0.37242E+03    0.29194E-04    0.12979E-07    0.18417E-10
+    4    3    0.60462E-04    0.10000E+01    0.30034E+03    0.52631E-04    0.34670E-07    0.30751E-10
+    4    3    0.60462E-04    0.10000E+01    0.24221E+03    0.91177E-04    0.80750E-07    0.50297E-10
+    4    3    0.60462E-04    0.10000E+01    0.19533E+03    0.14221E-03    0.15324E-06    0.75569E-10
+    4    3    0.60462E-04    0.10000E+01    0.15752E+03    0.14221E-03    0.15324E-06    0.75569E-10
+    4    3    0.10550E-03    0.10000E+01    0.80645E+05    0.18189E-50    0.13637E-61    0.48828E-56
+    4    3    0.10550E-03    0.10000E+01    0.65036E+05    0.15414E-49    0.21684E-60    0.41389E-55
+    4    3    0.10550E-03    0.10000E+01    0.52449E+05    0.13116E-48    0.29195E-59    0.35229E-54
+    4    3    0.10550E-03    0.10000E+01    0.42297E+05    0.98844E-48    0.39771E-58    0.26561E-53
+    4    3    0.10550E-03    0.10000E+01    0.34111E+05    0.71466E-47    0.54796E-57    0.19219E-52
+    4    3    0.10550E-03    0.10000E+01    0.27509E+05    0.51499E-46    0.74685E-56    0.13868E-51
+    4    3    0.10550E-03    0.10000E+01    0.22184E+05    0.36887E-45    0.10020E-54    0.99536E-51
+    4    3    0.10550E-03    0.10000E+01    0.17891E+05    0.26091E-44    0.13229E-53    0.70631E-50
+    4    3    0.10550E-03    0.10000E+01    0.14428E+05    0.18182E-43    0.17230E-52    0.49444E-49
+    4    3    0.10550E-03    0.10000E+01    0.11635E+05    0.12491E-42    0.22115E-51    0.34172E-48
+    4    3    0.10550E-03    0.10000E+01    0.93834E+04    0.84550E-42    0.27719E-50    0.23303E-47
+    4    3    0.10550E-03    0.10000E+01    0.75673E+04    0.56030E-41    0.33364E-49    0.15591E-46
+    4    3    0.10550E-03    0.10000E+01    0.61026E+04    0.35888E-40    0.37810E-48    0.10109E-45
+    4    3    0.10550E-03    0.10000E+01    0.49215E+04    0.21888E-39    0.40928E-47    0.62275E-45
+    4    3    0.10550E-03    0.10000E+01    0.39689E+04    0.12853E-38    0.50792E-46    0.35794E-44
+    4    3    0.10550E-03    0.10000E+01    0.32008E+04    0.26318E-36    0.31251E-43    0.64042E-42
+    4    3    0.10550E-03    0.10000E+01    0.25813E+04    0.13136E-27    0.48799E-34    0.25542E-33
+    4    3    0.10550E-03    0.10000E+01    0.20817E+04    0.24273E-11    0.33121E-17    0.44123E-17
+    4    3    0.10550E-03    0.10000E+01    0.16788E+04    0.75795E-06    0.39674E-11    0.12938E-11
+    4    3    0.10550E-03    0.10000E+01    0.13538E+04    0.12965E-05    0.14272E-10    0.18580E-11
+    4    3    0.10550E-03    0.10000E+01    0.10918E+04    0.23243E-05    0.50934E-10    0.28041E-11
+    4    3    0.10550E-03    0.10000E+01    0.88049E+03    0.42725E-05    0.18124E-09    0.43900E-11
+    4    3    0.10550E-03    0.10000E+01    0.71007E+03    0.79416E-05    0.64348E-09    0.70519E-11
+    4    3    0.10550E-03    0.10000E+01    0.57264E+03    0.14817E-04    0.22493E-08    0.11544E-10
+    4    3    0.10550E-03    0.10000E+01    0.46180E+03    0.27605E-04    0.74793E-08    0.19178E-10
+    4    3    0.10550E-03    0.10000E+01    0.37242E+03    0.50941E-04    0.22648E-07    0.32136E-10
+    4    3    0.10550E-03    0.10000E+01    0.30034E+03    0.91837E-04    0.60496E-07    0.53659E-10
+    4    3    0.10550E-03    0.10000E+01    0.24221E+03    0.15910E-03    0.14090E-06    0.87765E-10
+    4    3    0.10550E-03    0.10000E+01    0.19533E+03    0.24815E-03    0.26739E-06    0.13186E-09
+    4    3    0.10550E-03    0.10000E+01    0.15752E+03    0.24815E-03    0.26739E-06    0.13186E-09
+    4    3    0.18409E-03    0.10000E+01    0.80645E+05    0.31739E-50    0.23796E-61    0.85201E-56
+    4    3    0.18409E-03    0.10000E+01    0.65036E+05    0.26896E-49    0.37838E-60    0.72221E-55
+    4    3    0.18409E-03    0.10000E+01    0.52449E+05    0.22887E-48    0.50944E-59    0.61472E-54
+    4    3    0.18409E-03    0.10000E+01    0.42297E+05    0.17248E-47    0.69398E-58    0.46347E-53
+    4    3    0.18409E-03    0.10000E+01    0.34111E+05    0.12470E-46    0.95616E-57    0.33537E-52
+    4    3    0.18409E-03    0.10000E+01    0.27509E+05    0.89862E-46    0.13032E-55    0.24198E-51
+    4    3    0.18409E-03    0.10000E+01    0.22184E+05    0.64365E-45    0.17485E-54    0.17369E-50
+    4    3    0.18409E-03    0.10000E+01    0.17891E+05    0.45527E-44    0.23084E-53    0.12325E-49
+    4    3    0.18409E-03    0.10000E+01    0.14428E+05    0.31726E-43    0.30065E-52    0.86278E-49
+    4    3    0.18409E-03    0.10000E+01    0.11635E+05    0.21797E-42    0.38590E-51    0.59628E-48
+    4    3    0.18409E-03    0.10000E+01    0.93834E+04    0.14753E-41    0.48369E-50    0.40662E-47
+    4    3    0.18409E-03    0.10000E+01    0.75673E+04    0.97768E-41    0.58219E-49    0.27205E-46
+    4    3    0.18409E-03    0.10000E+01    0.61026E+04    0.62622E-40    0.65977E-48    0.17639E-45
+    4    3    0.18409E-03    0.10000E+01    0.49215E+04    0.38194E-39    0.71418E-47    0.10867E-44
+    4    3    0.18409E-03    0.10000E+01    0.39689E+04    0.22428E-38    0.88629E-46    0.62459E-44
+    4    3    0.18409E-03    0.10000E+01    0.32008E+04    0.45923E-36    0.54531E-43    0.11175E-41
+    4    3    0.18409E-03    0.10000E+01    0.25813E+04    0.22921E-27    0.85151E-34    0.44569E-33
+    4    3    0.18409E-03    0.10000E+01    0.20817E+04    0.42355E-11    0.57793E-17    0.76992E-17
+    4    3    0.18409E-03    0.10000E+01    0.16788E+04    0.13226E-05    0.69229E-11    0.22575E-11
+    4    3    0.18409E-03    0.10000E+01    0.13538E+04    0.22623E-05    0.24903E-10    0.32421E-11
+    4    3    0.18409E-03    0.10000E+01    0.10918E+04    0.40557E-05    0.88876E-10    0.48929E-11
+    4    3    0.18409E-03    0.10000E+01    0.88049E+03    0.74552E-05    0.31626E-09    0.76603E-11
+    4    3    0.18409E-03    0.10000E+01    0.71007E+03    0.13858E-04    0.11228E-08    0.12305E-10
+    4    3    0.18409E-03    0.10000E+01    0.57264E+03    0.25854E-04    0.39248E-08    0.20144E-10
+    4    3    0.18409E-03    0.10000E+01    0.46180E+03    0.48169E-04    0.13051E-07    0.33465E-10
+    4    3    0.18409E-03    0.10000E+01    0.37242E+03    0.88889E-04    0.39520E-07    0.56075E-10
+    4    3    0.18409E-03    0.10000E+01    0.30034E+03    0.16025E-03    0.10556E-06    0.93631E-10
+    4    3    0.18409E-03    0.10000E+01    0.24221E+03    0.27762E-03    0.24587E-06    0.15314E-09
+    4    3    0.18409E-03    0.10000E+01    0.19533E+03    0.43301E-03    0.46657E-06    0.23009E-09
+    4    3    0.18409E-03    0.10000E+01    0.15752E+03    0.43301E-03    0.46657E-06    0.23009E-09
+    4    3    0.32123E-03    0.10000E+01    0.80645E+05    0.55383E-50    0.41522E-61    0.14867E-55
+    4    3    0.32123E-03    0.10000E+01    0.65036E+05    0.46932E-49    0.66025E-60    0.12602E-54
+    4    3    0.32123E-03    0.10000E+01    0.52449E+05    0.39937E-48    0.88894E-59    0.10726E-53
+    4    3    0.32123E-03    0.10000E+01    0.42297E+05    0.30096E-47    0.12110E-57    0.80872E-53
+    4    3    0.32123E-03    0.10000E+01    0.34111E+05    0.21760E-46    0.16684E-56    0.58520E-52
+    4    3    0.32123E-03    0.10000E+01    0.27509E+05    0.15680E-45    0.22740E-55    0.42224E-51
+    4    3    0.32123E-03    0.10000E+01    0.22184E+05    0.11231E-44    0.30510E-54    0.30307E-50
+    4    3    0.32123E-03    0.10000E+01    0.17891E+05    0.79442E-44    0.40280E-53    0.21506E-49
+    4    3    0.32123E-03    0.10000E+01    0.14428E+05    0.55360E-43    0.52461E-52    0.15055E-48
+    4    3    0.32123E-03    0.10000E+01    0.11635E+05    0.38034E-42    0.67337E-51    0.10405E-47
+    4    3    0.32123E-03    0.10000E+01    0.93834E+04    0.25744E-41    0.84400E-50    0.70953E-47
+    4    3    0.32123E-03    0.10000E+01    0.75673E+04    0.17060E-40    0.10159E-48    0.47472E-46
+    4    3    0.32123E-03    0.10000E+01    0.61026E+04    0.10927E-39    0.11513E-47    0.30779E-45
+    4    3    0.32123E-03    0.10000E+01    0.49215E+04    0.66646E-39    0.12462E-46    0.18961E-44
+    4    3    0.32123E-03    0.10000E+01    0.39689E+04    0.39136E-38    0.15465E-45    0.10899E-43
+    4    3    0.32123E-03    0.10000E+01    0.32008E+04    0.80133E-36    0.95153E-43    0.19500E-41
+    4    3    0.32123E-03    0.10000E+01    0.25813E+04    0.39996E-27    0.14858E-33    0.77770E-33
+    4    3    0.32123E-03    0.10000E+01    0.20817E+04    0.73907E-11    0.10085E-16    0.13435E-16
+    4    3    0.32123E-03    0.10000E+01    0.16788E+04    0.23078E-05    0.12080E-10    0.39392E-11
+    4    3    0.32123E-03    0.10000E+01    0.13538E+04    0.39476E-05    0.43455E-10    0.56573E-11
+    4    3    0.32123E-03    0.10000E+01    0.10918E+04    0.70769E-05    0.15508E-09    0.85379E-11
+    4    3    0.32123E-03    0.10000E+01    0.88049E+03    0.13009E-04    0.55185E-09    0.13367E-10
+    4    3    0.32123E-03    0.10000E+01    0.71007E+03    0.24181E-04    0.19593E-08    0.21472E-10
+    4    3    0.32123E-03    0.10000E+01    0.57264E+03    0.45114E-04    0.68486E-08    0.35150E-10
+    4    3    0.32123E-03    0.10000E+01    0.46180E+03    0.84052E-04    0.22773E-07    0.58394E-10
+    4    3    0.32123E-03    0.10000E+01    0.37242E+03    0.15511E-03    0.68959E-07    0.97848E-10
+    4    3    0.32123E-03    0.10000E+01    0.30034E+03    0.27963E-03    0.18420E-06    0.16338E-09
+    4    3    0.32123E-03    0.10000E+01    0.24221E+03    0.48443E-03    0.42903E-06    0.26723E-09
+    4    3    0.32123E-03    0.10000E+01    0.19533E+03    0.75557E-03    0.81414E-06    0.40150E-09
+    4    3    0.32123E-03    0.10000E+01    0.15752E+03    0.75557E-03    0.81414E-06    0.40150E-09
+    4    4    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.11414E-09    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    4    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.19917E-09    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    4    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.34754E-09    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    4    4    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.60644E-09    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    4    4    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.10582E-08    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    4    4    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.18465E-08    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    4    4    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.32220E-08    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    4    4    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.70872E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.56222E-08    0.21932E+07    0.57448E-32    0.89895E-91    0.45338E-05    0.90000E+03
+    4    4    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.40106E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.98105E-08    0.18214E+07    0.17525E-31    0.50850E-75    0.54820E-05    0.90000E+03
+    4    4    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.32721E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.17119E-07    0.15145E+07    0.53194E-31    0.41455E-62    0.66021E-05    0.90000E+03
+    4    4    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.17040E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.29871E-07    0.12578E+07    0.16206E-30    0.21564E-51    0.79511E-05    0.90000E+03
+    4    4    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.11111E-44    0.67064E-05    0.42297E-05    0.37644E+02    0.52123E-07    0.10445E+07    0.49376E-30    0.14037E-42    0.95741E-05    0.90000E+03
+    4    4    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.19149E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.90952E-07    0.86742E+06    0.15043E-29    0.24135E-35    0.11528E-04    0.90000E+03
+    4    4    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.16217E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.15871E-06    0.72035E+06    0.45832E-29    0.20374E-29    0.13882E-04    0.90000E+03
+    4    4    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.11292E-26    0.11686E-04    0.73852E-05    0.20001E+03    0.27693E-06    0.59822E+06    0.13964E-28    0.14126E-24    0.16716E-04    0.90000E+03
+    4    4    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.99124E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.48323E-06    0.49680E+06    0.42543E-28    0.12332E-20    0.20129E-04    0.90000E+03
+    4    4    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.15002E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.84320E-06    0.41311E+06    0.12910E-27    0.18530E-17    0.24207E-04    0.90000E+03
+    4    4    0.58864E-11    0.10000E+01    0.16087E-01    0.30718E-01    0.51398E-11    0.57782E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.14713E-05    0.34307E+06    0.39289E-27    0.70694E-15    0.29147E-04    0.89996E+03
+    4    4    0.10271E-10    0.10000E+01    0.22942E-01    0.43827E-01    0.84780E-11    0.68783E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.25674E-05    0.28490E+06    0.11867E-26    0.83100E-13    0.35071E-04    0.89948E+03
+    4    4    0.17923E-10    0.10000E+01    0.32877E-01    0.63549E-01    0.20396E-10    0.31833E-13    0.29495E-04    0.18788E-04    0.32355E+04    0.44799E-05    0.23629E+06    0.35087E-26    0.37811E-11    0.42135E-04    0.89635E+03
+    4    4    0.31275E-10    0.10000E+01    0.48087E-01    0.93026E-01    0.50555E-10    0.69749E-12    0.35071E-04    0.23018E-04    0.56458E+04    0.78172E-05    0.19521E+06    0.10036E-25    0.80914E-10    0.50511E-04    0.88434E+03
+    4    4    0.54572E-10    0.10000E+01    0.72339E-01    0.13212E+00    0.11139E-09    0.85660E-11    0.40754E-04    0.28569E-04    0.98516E+04    0.13641E-04    0.15982E+06    0.28425E-25    0.96002E-09    0.60787E-04    0.85377E+03
+    4    4    0.95225E-10    0.10000E+01    0.10745E+00    0.17439E+00    0.20691E-09    0.63294E-10    0.46231E-04    0.34785E-04    0.17190E+05    0.23802E-04    0.12965E+06    0.84127E-25    0.67363E-08    0.74167E-04    0.80078E+03
+    4    4    0.16616E-09    0.10000E+01    0.14878E+00    0.21719E+00    0.32144E-09    0.29421E-09    0.51950E-04    0.39970E-04    0.29996E+05    0.41533E-04    0.10477E+06    0.26900E-24    0.29014E-07    0.92163E-04    0.73923E+03
+    4    4    0.28994E-09    0.10000E+01    0.18960E+00    0.26920E+00    0.50957E-09    0.91905E-09    0.59483E-04    0.44227E-04    0.52341E+05    0.72473E-04    0.85441E+05    0.87576E-24    0.81766E-07    0.11449E-03    0.69278E+03
+    4    4    0.50593E-09    0.10000E+01    0.23325E+00    0.34165E+00    0.97309E-09    0.22274E-08    0.69082E-04    0.49559E-04    0.91333E+05    0.12646E-03    0.70222E+05    0.28009E-23    0.17371E-06    0.14089E-03    0.66713E+03
+    4    4    0.88282E-09    0.10000E+01    0.28731E+00    0.43751E+00    0.20521E-08    0.46655E-08    0.81266E-04    0.57088E-04    0.15937E+06    0.22067E-03    0.58089E+05    0.87213E-23    0.31087E-06    0.17141E-03    0.65597E+03
+    4    4    0.15405E-08    0.10000E+01    0.35967E+00    0.55855E+00    0.41593E-08    0.90650E-08    0.96101E-04    0.67317E-04    0.27809E+06    0.38505E-03    0.48115E+05    0.26894E-22    0.50504E-06    0.20753E-03    0.65182E+03
+    4    4    0.26880E-08    0.10000E+01    0.45355E+00    0.70365E+00    0.78951E-08    0.16913E-07    0.11473E-03    0.80275E-04    0.48525E+06    0.67189E-03    0.39958E+05    0.82059E-22    0.77980E-06    0.25015E-03    0.65051E+03
+    4    4    0.46905E-08    0.10000E+01    0.56603E+00    0.88911E+00    0.14584E-07    0.30865E-07    0.13637E-03    0.97125E-04    0.82414E+06    0.11411E-02    0.31056E+05    0.26445E-21    0.11612E-05    0.30556E-03    0.65016E+03
+    4    4    0.81846E-08    0.10000E+01    0.56187E+00    0.14335E+01    0.35831E-07    0.55196E-07    0.13531E-03    0.13982E-03    0.77655E+06    0.10752E-02    0.10647E+05    0.23014E-20    0.14186E-05    0.48644E-03    0.65039E+03
+    4    4    0.14282E-07    0.10000E+01    0.52312E+00    0.21416E+01    0.72049E-07    0.94209E-07    0.12776E-03    0.20402E-03    0.63138E+06    0.87422E-03    0.52312E+04    0.17668E-19    0.16978E-05    0.76441E-03    0.65028E+03
+    4    4    0.24920E-07    0.10000E+01    0.63899E+00    0.24986E+01    0.12123E-06    0.16123E-06    0.15263E-03    0.24534E-03    0.11017E+07    0.15255E-02    0.43443E+04    0.53837E-19    0.24683E-05    0.92061E-03    0.65014E+03
+    4    4    0.43485E-07    0.10000E+01    0.77462E+00    0.28944E+01    0.20202E-06    0.27363E-06    0.18268E-03    0.29518E-03    0.19224E+07    0.26618E-02    0.36078E+04    0.16404E-18    0.35652E-05    0.11086E-02    0.65007E+03
+    4    4    0.75878E-07    0.10000E+01    0.93193E+00    0.33313E+01    0.33381E-06    0.46093E-06    0.21897E-03    0.35526E-03    0.33546E+07    0.46448E-02    0.29961E+04    0.49980E-18    0.51213E-05    0.13350E-02    0.65003E+03
+    4    4    0.13240E-06    0.10000E+01    0.11128E+01    0.38124E+01    0.54753E-06    0.77129E-06    0.26275E-03    0.42766E-03    0.58535E+07    0.81048E-02    0.24881E+04    0.15228E-17    0.73223E-05    0.16076E-02    0.65002E+03
+    4    4    0.23103E-06    0.10000E+01    0.13193E+01    0.43406E+01    0.89240E-06    0.12829E-05    0.31555E-03    0.51487E-03    0.10214E+08    0.14142E-01    0.20663E+04    0.46395E-17    0.10427E-04    0.19358E-02    0.65001E+03
+    4    4    0.40314E-06    0.10000E+01    0.15516E+01    0.49156E+01    0.14530E-05    0.21234E-05    0.38016E-03    0.61912E-03    0.17823E+08    0.24678E-01    0.17182E+04    0.14080E-16    0.14817E-04    0.23280E-02    0.65000E+03
+    4    4    0.70346E-06    0.10000E+01    0.18150E+01    0.55494E+01    0.23448E-05    0.34966E-05    0.45701E-03    0.74547E-03    0.31100E+08    0.43061E-01    0.14269E+04    0.42898E-16    0.20961E-04    0.28033E-02    0.65000E+03
+    4    4    0.12275E-05    0.10000E+01    0.21103E+01    0.62428E+01    0.37692E-05    0.57335E-05    0.54957E-03    0.89763E-03    0.54267E+08    0.75139E-01    0.11850E+04    0.13069E-15    0.29572E-04    0.33756E-02    0.65000E+03
+    4    4    0.21419E-05    0.10000E+01    0.24398E+01    0.70009E+01    0.60395E-05    0.93662E-05    0.66101E-03    0.10809E-02    0.94693E+08    0.13111E+00    0.98406E+03    0.39807E-15    0.41618E-04    0.40647E-02    0.65000E+03
+    4    4    0.37375E-05    0.10000E+01    0.28060E+01    0.78290E+01    0.96517E-05    0.15249E-04    0.79518E-03    0.13014E-02    0.16523E+09    0.22878E+00    0.81722E+03    0.12093E-14    0.58448E-04    0.48935E-02    0.65000E+03
+    4    4    0.65217E-05    0.10000E+01    0.32117E+01    0.87290E+01    0.15386E-04    0.24748E-04    0.95667E-03    0.15664E-02    0.28832E+09    0.39922E+00    0.67866E+03    0.36281E-14    0.81924E-04    0.58833E-02    0.65000E+03
+    4    4    0.11380E-04    0.10000E+01    0.36566E+01    0.96824E+01    0.24547E-04    0.40019E-04    0.11539E-02    0.18790E-02    0.50310E+09    0.69661E+00    0.56433E+03    0.10459E-13    0.11476E-03    0.70277E-02    0.65000E+03
+    4    4    0.19857E-04    0.10000E+01    0.39724E+01    0.10323E+02    0.48709E-04    0.66175E-04    0.15799E-02    0.21111E-02    0.87789E+09    0.12155E+01    0.50000E+03    0.24480E-13    0.17307E-03    0.78471E-02    0.65000E+03
+    4    4    0.34650E-04    0.10000E+01    0.39724E+01    0.10323E+02    0.14831E-03    0.11547E-03    0.27568E-02    0.21111E-02    0.15319E+10    0.21210E+01    0.50000E+03    0.42717E-13    0.30200E-03    0.78471E-02    0.65000E+03
+    4    4    0.60462E-04    0.10000E+01    0.39724E+01    0.10323E+02    0.45158E-03    0.20149E-03    0.48105E-02    0.21111E-02    0.26730E+10    0.37011E+01    0.50000E+03    0.74538E-13    0.52698E-03    0.78471E-02    0.65000E+03
+    4    4    0.10550E-03    0.10000E+01    0.39724E+01    0.10323E+02    0.13750E-02    0.35159E-03    0.83941E-02    0.21111E-02    0.46642E+10    0.64582E+01    0.50000E+03    0.13006E-12    0.91955E-03    0.78471E-02    0.65000E+03
+    4    4    0.18409E-03    0.10000E+01    0.39724E+01    0.10323E+02    0.41865E-02    0.61350E-03    0.14647E-01    0.21111E-02    0.81388E+10    0.11269E+02    0.50000E+03    0.22695E-12    0.16046E-02    0.78471E-02    0.65000E+03
+    4    4    0.32123E-03    0.10000E+01    0.39724E+01    0.10323E+02    0.12747E-01    0.10705E-02    0.25558E-01    0.21111E-02    0.14202E+11    0.19664E+02    0.50000E+03    0.39602E-12    0.27998E-02    0.78471E-02    0.65000E+03
+    4    4    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    4    4    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    4    4    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    4    4    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    4    4    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    4    4    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    4    4    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    4    4    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    4    4    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    4    4    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    4    4    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    4    4    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    4    4    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    4    4    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    4    4    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    4    4    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    4    4    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    4    4    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    4    4    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    4    4    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    4    4    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    4    4    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    4    4    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    4    4    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    4    4    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    4    4    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    4    4    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    4    4    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    4    4    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    4    4    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    4    4    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    4    4    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    4    4    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    4    4    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    4    4    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    4    4    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    4    4    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    4    4    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    4    4    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    4    4    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    4    4    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    4    4    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    4    4    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    4    4    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    4    4    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    4    4    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    4    4    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    4    4    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    4    4    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    4    4    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    4    4    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    4    4    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    4    4    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    4    4    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    4    4    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    4    4    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    4    4    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    4    4    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    4    4    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    4    4    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    4    4    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    4    4    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    4    4    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    4    4    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    4    4    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    4    4    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    4    4    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    4    4    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    4    4    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    4    4    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    4    4    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    4    4    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    4    4    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    4    4    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    4    4    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    4    4    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    4    4    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    4    4    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    4    4    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    4    4    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    4    4    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    4    4    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    4    4    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    4    4    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    4    4    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    4    4    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    4    4    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    4    4    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    4    4    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    4    4    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    4    4    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    4    4    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    4    4    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    4    4    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    4    4    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    4    4    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    4    4    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    4    4    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    4    4    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    4    4    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    4    4    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    4    4    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    4    4    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    4    4    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    4    4    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    4    4    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    4    4    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    4    4    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    4    4    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    4    4    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    4    4    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    4    4    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    4    4    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    4    4    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    4    4    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    4    4    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    4    4    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    4    4    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    4    4    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    4    4    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    4    4    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    4    4    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    4    4    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    4    4    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    4    4    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    4    4    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    4    4    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    4    4    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    4    4    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    4    4    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    4    4    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    4    4    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    4    4    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    4    4    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    4    4    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    4    4    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    4    4    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    4    4    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    4    4    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    4    4    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    4    4    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    4    4    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    4    4    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    4    4    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    4    4    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    4    4    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    4    4    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    4    4    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    4    4    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    4    4    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    4    4    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    4    4    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    4    4    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    4    4    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    4    4    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    4    4    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    4    4    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    4    4    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    4    4    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    4    4    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    4    4    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    4    4    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    4    4    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    4    4    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    4    4    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    4    4    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    4    4    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    4    4    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    4    4    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    4    4    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    4    4    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    4    4    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    4    4    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    4    4    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    4    4    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    4    4    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    4    4    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    4    4    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    4    4    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    4    4    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    4    4    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    4    4    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    4    4    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    4    4    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    4    4    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    4    4    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    4    4    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    4    4    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    4    4    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    4    4    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    4    4    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    4    4    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    4    4    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    4    4    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    4    4    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    4    4    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    4    4    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    4    4    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    4    4    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    4    4    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    4    4    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    4    4    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    4    4    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    4    4    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    4    4    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    4    4    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    4    4    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    4    4    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    4    4    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    4    4    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    4    4    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    4    4    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    4    4    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    4    4    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    4    4    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    4    4    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    4    4    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    4    4    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    4    4    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    4    4    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    4    4    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    4    4    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    4    4    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    4    4    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    4    4    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    4    4    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    4    4    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    4    4    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    4    4    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    4    4    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    4    4    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    4    4    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    4    4    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    4    4    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    4    4    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    4    4    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    4    4    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    4    4    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    4    4    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    4    4    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    4    4    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    4    4    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    4    4    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    4    4    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    4    4    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    4    4    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    4    4    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    4    4    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    4    4    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    4    4    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    4    4    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    4    4    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    4    4    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    4    4    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    4    4    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    4    4    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    4    4    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    4    4    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    4    4    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    4    4    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    4    4    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    4    4    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    4    4    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    4    4    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    4    4    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    4    4    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    4    4    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    4    4    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    4    4    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    4    4    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    4    4    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    4    4    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    4    4    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    4    4    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    4    4    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    4    4    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    4    4    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    4    4    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    4    4    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    4    4    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    4    4    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    4    4    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    4    4    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    4    4    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    4    4    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    4    4    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    4    4    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    4    4    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    4    4    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    4    4    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    4    4    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    4    4    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    4    4    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    4    4    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    4    4    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    4    4    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    4    4    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    4    4    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    4    4    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    4    4    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    4    4    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    4    4    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    4    4    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    4    4    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    4    4    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    4    4    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    4    4    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    4    4    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    4    4    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    4    4    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    4    4    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    4    4    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    4    4    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    4    4    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    4    4    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    4    4    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    4    4    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    4    4    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    4    4    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    4    4    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    4    4    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    4    4    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    4    4    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    4    4    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    4    4    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    4    4    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    4    4    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    4    4    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    4    4    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    4    4    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    4    4    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    4    4    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    4    4    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    4    4    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    4    4    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    4    4    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    4    4    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    4    4    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    4    4    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    4    4    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    4    4    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    4    4    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    4    4    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    4    4    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    4    4    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    4    4    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    4    4    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    4    4    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    4    4    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    4    4    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    4    4    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    4    4    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    4    4    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    4    4    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    4    4    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    4    4    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    4    4    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    4    4    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    4    4    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    4    4    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    4    4    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    4    4    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    4    4    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    4    4    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    4    4    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    4    4    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    4    4    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    4    4    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    4    4    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    4    4    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    4    4    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    4    4    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    4    4    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    4    4    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    4    4    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    4    4    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    4    4    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    4    4    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    4    4    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    4    4    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    4    4    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    4    4    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    4    4    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    4    4    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    4    4    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    4    4    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    4    4    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    4    4    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    4    4    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    4    4    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    4    4    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    4    4    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    4    4    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    4    4    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    4    4    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    4    4    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    4    4    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    4    4    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    4    4    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    4    4    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    4    4    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    4    4    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    4    4    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    4    4    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    4    4    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    4    4    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    4    4    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    4    4    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    4    4    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    4    4    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    4    4    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    4    4    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    4    4    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    4    4    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    4    4    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    4    4    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    4    4    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    4    4    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    4    4    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    4    4    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    4    4    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    4    4    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    4    4    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    4    4    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    4    4    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    4    4    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    4    4    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    4    4    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    4    4    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    4    4    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    4    4    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    4    4    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    4    4    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    4    4    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    4    4    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    4    4    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    4    4    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    4    4    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    4    4    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    4    4    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    4    4    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    4    4    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    4    4    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    4    4    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    4    4    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    4    4    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    4    4    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    4    4    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    4    4    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    4    4    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    4    4    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    4    4    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    4    4    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    4    4    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    4    4    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    4    4    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    4    4    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    4    4    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    4    4    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    4    4    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    4    4    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    4    4    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    4    4    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    4    4    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    4    4    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    4    4    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    4    4    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    4    4    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    4    4    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    4    4    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    4    4    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    4    4    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    4    4    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    4    4    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    4    4    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    4    4    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    4    4    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    4    4    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    4    4    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    4    4    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    4    4    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    4    4    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    4    4    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    4    4    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    4    4    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    4    4    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    4    4    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    4    4    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    4    4    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    4    4    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    4    4    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    4    4    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    4    4    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    4    4    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    4    4    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    4    4    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    4    4    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    4    4    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    4    4    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    4    4    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    4    4    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    4    4    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    4    4    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    4    4    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    4    4    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    4    4    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    4    4    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    4    4    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    4    4    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    4    4    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    4    4    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    4    4    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    4    4    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    4    4    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    4    4    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    4    4    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    4    4    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    4    4    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    4    4    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    4    4    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    4    4    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    4    4    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    4    4    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    4    4    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    4    4    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    4    4    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    4    4    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    4    4    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    4    4    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    4    4    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    4    4    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    4    4    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    4    4    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    4    4    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    4    4    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    4    4    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    4    4    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    4    4    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    4    4    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    4    4    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    4    4    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92897E-69
+    4    4    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74362E-68
+    4    4    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73143E-67
+    4    4    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87551E-66
+    4    4    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13789E-64
+    4    4    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89973E-62    0.24580E-63
+    4    4    0.10271E-10    0.10000E+01    0.22184E+05    0.38373E-51    0.28684E-60    0.43685E-62
+    4    4    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85155E-59    0.73546E-61
+    4    4    0.10271E-10    0.10000E+01    0.14428E+05    0.99625E-49    0.23814E-57    0.11535E-59
+    4    4    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    4    4    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    4    4    0.10271E-10    0.10000E+01    0.75673E+04    0.29666E-45    0.46498E-53    0.34503E-56
+    4    4    0.10271E-10    0.10000E+01    0.61026E+04    0.41737E-44    0.12464E-51    0.48594E-55
+    4    4    0.10271E-10    0.10000E+01    0.49215E+04    0.58686E-43    0.33415E-50    0.68408E-54
+    4    4    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89576E-49    0.96299E-53
+    4    4    0.10271E-10    0.10000E+01    0.32008E+04    0.36487E-39    0.77647E-46    0.42631E-50
+    4    4    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    4    4    0.10271E-10    0.10000E+01    0.20817E+04    0.50710E-14    0.11035E-19    0.59395E-25
+    4    4    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    4    4    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    4    4    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    4    4    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    4    4    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    4    4    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74211E-18
+    4    4    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    4    4    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    4    4    0.10271E-10    0.10000E+01    0.30034E+03    0.43464E-06    0.30256E-09    0.50997E-17
+    4    4    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89845E-17
+    4    4    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    4    4    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    4    4    0.17923E-10    0.10000E+01    0.80645E+05    0.56933E-58    0.39458E-69    0.34113E-68
+    4    4    0.17923E-10    0.10000E+01    0.65036E+05    0.46736E-57    0.87601E-68    0.28357E-67
+    4    4    0.17923E-10    0.10000E+01    0.52449E+05    0.52528E-56    0.24091E-66    0.24761E-66
+    4    4    0.17923E-10    0.10000E+01    0.42297E+05    0.74521E-55    0.80027E-65    0.22190E-65
+    4    4    0.17923E-10    0.10000E+01    0.34111E+05    0.12654E-53    0.27750E-63    0.26486E-64
+    4    4    0.17923E-10    0.10000E+01    0.27509E+05    0.22717E-52    0.94007E-62    0.41870E-63
+    4    4    0.17923E-10    0.10000E+01    0.22184E+05    0.40091E-51    0.30148E-60    0.72568E-62
+    4    4    0.17923E-10    0.10000E+01    0.17891E+05    0.67115E-50    0.89755E-59    0.12275E-60
+    4    4    0.17923E-10    0.10000E+01    0.14428E+05    0.10497E-48    0.25126E-57    0.19418E-59
+    4    4    0.17923E-10    0.10000E+01    0.11635E+05    0.15507E-47    0.68175E-56    0.28903E-58
+    4    4    0.17923E-10    0.10000E+01    0.93834E+04    0.22182E-46    0.18318E-54    0.41537E-57
+    4    4    0.17923E-10    0.10000E+01    0.75673E+04    0.31330E-45    0.49134E-53    0.58876E-56
+    4    4    0.17923E-10    0.10000E+01    0.61026E+04    0.44103E-44    0.13180E-51    0.83137E-55
+    4    4    0.17923E-10    0.10000E+01    0.49215E+04    0.62052E-43    0.35355E-50    0.11730E-53
+    4    4    0.17923E-10    0.10000E+01    0.39689E+04    0.87304E-42    0.94835E-49    0.16545E-52
+    4    4    0.17923E-10    0.10000E+01    0.32008E+04    0.38629E-39    0.82253E-46    0.73369E-50
+    4    4    0.17923E-10    0.10000E+01    0.25813E+04    0.28282E-30    0.13806E-36    0.53831E-41
+    4    4    0.17923E-10    0.10000E+01    0.20817E+04    0.53757E-14    0.11705E-19    0.10256E-24
+    4    4    0.17923E-10    0.10000E+01    0.16788E+04    0.18155E-08    0.17278E-13    0.34687E-19
+    4    4    0.17923E-10    0.10000E+01    0.13538E+04    0.38970E-08    0.65625E-13    0.74491E-19
+    4    4    0.17923E-10    0.10000E+01    0.10918E+04    0.81805E-08    0.24468E-12    0.15643E-18
+    4    4    0.17923E-10    0.10000E+01    0.88049E+03    0.16808E-07    0.90086E-12    0.32149E-18
+    4    4    0.17923E-10    0.10000E+01    0.71007E+03    0.33871E-07    0.32804E-11    0.64798E-18
+    4    4    0.17923E-10    0.10000E+01    0.57264E+03    0.67116E-07    0.11671E-10    0.12841E-17
+    4    4    0.17923E-10    0.10000E+01    0.46180E+03    0.13084E-06    0.39254E-10    0.25035E-17
+    4    4    0.17923E-10    0.10000E+01    0.37242E+03    0.24970E-06    0.11969E-09    0.47782E-17
+    4    4    0.17923E-10    0.10000E+01    0.30034E+03    0.46119E-06    0.32104E-09    0.88254E-17
+    4    4    0.17923E-10    0.10000E+01    0.24221E+03    0.81251E-06    0.74960E-09    0.15549E-16
+    4    4    0.17923E-10    0.10000E+01    0.19533E+03    0.12805E-05    0.14245E-08    0.24505E-16
+    4    4    0.17923E-10    0.10000E+01    0.15752E+03    0.12805E-05    0.14245E-08    0.24505E-16
+    4    4    0.31275E-10    0.10000E+01    0.80645E+05    0.12232E-57    0.87945E-69    0.11564E-67
+    4    4    0.31275E-10    0.10000E+01    0.65036E+05    0.10124E-56    0.15638E-67    0.99155E-67
+    4    4    0.31275E-10    0.10000E+01    0.52449E+05    0.94738E-56    0.30747E-66    0.84825E-66
+    4    4    0.31275E-10    0.10000E+01    0.42297E+05    0.99610E-55    0.85251E-65    0.67251E-65
+    4    4    0.31275E-10    0.10000E+01    0.34111E+05    0.13858E-53    0.28164E-63    0.61392E-64
+    4    4    0.31275E-10    0.10000E+01    0.27509E+05    0.23273E-52    0.95042E-62    0.75410E-63
+    4    4    0.31275E-10    0.10000E+01    0.22184E+05    0.40644E-51    0.30692E-60    0.11747E-61
+    4    4    0.31275E-10    0.10000E+01    0.17891E+05    0.68340E-50    0.91935E-59    0.19631E-60
+    4    4    0.31275E-10    0.10000E+01    0.14428E+05    0.10746E-48    0.25828E-57    0.31479E-59
+    4    4    0.31275E-10    0.10000E+01    0.11635E+05    0.15935E-47    0.70233E-56    0.47507E-58
+    4    4    0.31275E-10    0.10000E+01    0.93834E+04    0.22846E-46    0.18903E-54    0.68976E-57
+    4    4    0.31275E-10    0.10000E+01    0.75673E+04    0.32326E-45    0.50781E-53    0.98514E-56
+    4    4    0.31275E-10    0.10000E+01    0.61026E+04    0.45577E-44    0.13641E-51    0.13994E-54
+    4    4    0.31275E-10    0.10000E+01    0.49215E+04    0.64216E-43    0.36638E-50    0.19839E-53
+    4    4    0.31275E-10    0.10000E+01    0.39689E+04    0.90463E-42    0.98384E-49    0.28093E-52
+    4    4    0.31275E-10    0.10000E+01    0.32008E+04    0.40072E-39    0.85415E-46    0.12499E-49
+    4    4    0.31275E-10    0.10000E+01    0.25813E+04    0.29370E-30    0.14351E-36    0.91977E-41
+    4    4    0.31275E-10    0.10000E+01    0.20817E+04    0.55890E-14    0.12181E-19    0.17577E-24
+    4    4    0.31275E-10    0.10000E+01    0.16788E+04    0.18890E-08    0.17990E-13    0.59563E-19
+    4    4    0.31275E-10    0.10000E+01    0.13538E+04    0.40556E-08    0.68331E-13    0.12800E-18
+    4    4    0.31275E-10    0.10000E+01    0.10918E+04    0.85151E-08    0.25478E-12    0.26892E-18
+    4    4    0.31275E-10    0.10000E+01    0.88049E+03    0.17498E-07    0.93806E-12    0.55287E-18
+    4    4    0.31275E-10    0.10000E+01    0.71007E+03    0.35264E-07    0.34159E-11    0.11146E-17
+    4    4    0.31275E-10    0.10000E+01    0.57264E+03    0.69881E-07    0.12153E-10    0.22092E-17
+    4    4    0.31275E-10    0.10000E+01    0.46180E+03    0.13623E-06    0.40876E-10    0.43076E-17
+    4    4    0.31275E-10    0.10000E+01    0.37242E+03    0.26001E-06    0.12464E-09    0.82219E-17
+    4    4    0.31275E-10    0.10000E+01    0.30034E+03    0.48023E-06    0.33430E-09    0.15186E-16
+    4    4    0.31275E-10    0.10000E+01    0.24221E+03    0.84606E-06    0.78057E-09    0.26756E-16
+    4    4    0.31275E-10    0.10000E+01    0.19533E+03    0.13334E-05    0.14833E-08    0.42168E-16
+    4    4    0.31275E-10    0.10000E+01    0.15752E+03    0.13334E-05    0.14833E-08    0.42168E-16
+    4    4    0.54572E-10    0.10000E+01    0.80645E+05    0.25904E-57    0.19453E-68    0.37828E-67
+    4    4    0.54572E-10    0.10000E+01    0.65036E+05    0.22017E-56    0.31730E-67    0.32820E-66
+    4    4    0.54572E-10    0.10000E+01    0.52449E+05    0.19232E-55    0.49060E-66    0.28131E-65
+    4    4    0.54572E-10    0.10000E+01    0.42297E+05    0.16424E-54    0.10168E-64    0.21520E-64
+    4    4    0.54572E-10    0.10000E+01    0.34111E+05    0.17221E-53    0.28346E-63    0.16760E-63
+    4    4    0.54572E-10    0.10000E+01    0.27509E+05    0.24007E-52    0.90954E-62    0.15478E-62
+    4    4    0.54572E-10    0.10000E+01    0.22184E+05    0.39325E-51    0.29463E-60    0.19464E-61
+    4    4    0.54572E-10    0.10000E+01    0.17891E+05    0.65786E-50    0.89354E-59    0.30794E-60
+    4    4    0.54572E-10    0.10000E+01    0.14428E+05    0.10441E-48    0.25337E-57    0.50003E-59
+    4    4    0.54572E-10    0.10000E+01    0.11635E+05    0.15619E-47    0.69324E-56    0.77011E-58
+    4    4    0.54572E-10    0.10000E+01    0.93834E+04    0.22538E-46    0.18745E-54    0.11359E-56
+    4    4    0.54572E-10    0.10000E+01    0.75673E+04    0.32043E-45    0.50547E-53    0.16409E-55
+    4    4    0.54572E-10    0.10000E+01    0.61026E+04    0.45352E-44    0.13620E-51    0.23511E-54
+    4    4    0.54572E-10    0.10000E+01    0.49215E+04    0.64105E-43    0.36681E-50    0.33558E-53
+    4    4    0.54572E-10    0.10000E+01    0.39689E+04    0.90551E-42    0.98719E-49    0.47779E-52
+    4    4    0.54572E-10    0.10000E+01    0.32008E+04    0.40203E-39    0.85873E-46    0.21353E-49
+    4    4    0.54572E-10    0.10000E+01    0.25813E+04    0.29528E-30    0.14456E-36    0.15775E-40
+    4    4    0.54572E-10    0.10000E+01    0.20817E+04    0.56314E-14    0.12296E-19    0.30268E-24
+    4    4    0.54572E-10    0.10000E+01    0.16788E+04    0.19059E-08    0.18175E-13    0.10283E-18
+    4    4    0.54572E-10    0.10000E+01    0.13538E+04    0.40940E-08    0.69045E-13    0.22117E-18
+    4    4    0.54572E-10    0.10000E+01    0.10918E+04    0.85987E-08    0.25746E-12    0.46497E-18
+    4    4    0.54572E-10    0.10000E+01    0.88049E+03    0.17674E-07    0.94796E-12    0.95635E-18
+    4    4    0.54572E-10    0.10000E+01    0.71007E+03    0.35626E-07    0.34520E-11    0.19286E-17
+    4    4    0.54572E-10    0.10000E+01    0.57264E+03    0.70606E-07    0.12282E-10    0.38235E-17
+    4    4    0.54572E-10    0.10000E+01    0.46180E+03    0.13766E-06    0.41308E-10    0.74561E-17
+    4    4    0.54572E-10    0.10000E+01    0.37242E+03    0.26274E-06    0.12596E-09    0.14233E-16
+    4    4    0.54572E-10    0.10000E+01    0.30034E+03    0.48528E-06    0.33783E-09    0.26290E-16
+    4    4    0.54572E-10    0.10000E+01    0.24221E+03    0.85498E-06    0.78882E-09    0.46321E-16
+    4    4    0.54572E-10    0.10000E+01    0.19533E+03    0.13475E-05    0.14990E-08    0.73004E-16
+    4    4    0.54572E-10    0.10000E+01    0.15752E+03    0.13475E-05    0.14990E-08    0.73004E-16
+    4    4    0.95225E-10    0.10000E+01    0.80645E+05    0.53386E-57    0.40896E-68    0.12905E-66
+    4    4    0.95225E-10    0.10000E+01    0.65036E+05    0.46007E-56    0.65371E-67    0.11092E-65
+    4    4    0.95225E-10    0.10000E+01    0.52449E+05    0.39538E-55    0.91453E-66    0.94612E-65
+    4    4    0.95225E-10    0.10000E+01    0.42297E+05    0.30916E-54    0.14722E-64    0.70984E-64
+    4    4    0.95225E-10    0.10000E+01    0.34111E+05    0.25861E-53    0.30647E-63    0.50975E-63
+    4    4    0.95225E-10    0.10000E+01    0.27509E+05    0.27142E-52    0.84809E-62    0.38313E-62
+    4    4    0.95225E-10    0.10000E+01    0.22184E+05    0.37709E-51    0.27010E-60    0.36715E-61
+    4    4    0.95225E-10    0.10000E+01    0.17891E+05    0.60855E-50    0.83459E-59    0.50791E-60
+    4    4    0.95225E-10    0.10000E+01    0.14428E+05    0.97574E-49    0.24068E-57    0.81333E-59
+    4    4    0.95225E-10    0.10000E+01    0.11635E+05    0.14818E-47    0.66611E-56    0.12695E-57
+    4    4    0.95225E-10    0.10000E+01    0.93834E+04    0.21633E-46    0.18160E-54    0.18955E-56
+    4    4    0.95225E-10    0.10000E+01    0.75673E+04    0.31022E-45    0.49288E-53    0.27618E-55
+    4    4    0.95225E-10    0.10000E+01    0.61026E+04    0.44199E-44    0.13351E-51    0.39818E-54
+    4    4    0.95225E-10    0.10000E+01    0.49215E+04    0.62809E-43    0.36108E-50    0.57114E-53
+    4    4    0.95225E-10    0.10000E+01    0.39689E+04    0.89106E-42    0.97521E-49    0.81646E-52
+    4    4    0.95225E-10    0.10000E+01    0.32008E+04    0.39706E-39    0.85088E-46    0.36615E-49
+    4    4    0.95225E-10    0.10000E+01    0.25813E+04    0.29258E-30    0.14368E-36    0.27138E-40
+    4    4    0.95225E-10    0.10000E+01    0.20817E+04    0.55990E-14    0.12261E-19    0.52254E-24
+    4    4    0.95225E-10    0.10000E+01    0.16788E+04    0.18990E-08    0.18146E-13    0.17791E-18
+    4    4    0.95225E-10    0.10000E+01    0.13538E+04    0.40822E-08    0.68947E-13    0.38294E-18
+    4    4    0.95225E-10    0.10000E+01    0.10918E+04    0.85785E-08    0.25713E-12    0.80551E-18
+    4    4    0.95225E-10    0.10000E+01    0.88049E+03    0.17639E-07    0.94676E-12    0.16574E-17
+    4    4    0.95225E-10    0.10000E+01    0.71007E+03    0.35565E-07    0.34477E-11    0.33434E-17
+    4    4    0.95225E-10    0.10000E+01    0.57264E+03    0.70498E-07    0.12266E-10    0.66295E-17
+    4    4    0.95225E-10    0.10000E+01    0.46180E+03    0.13746E-06    0.41257E-10    0.12929E-16
+    4    4    0.95225E-10    0.10000E+01    0.37242E+03    0.26239E-06    0.12580E-09    0.24682E-16
+    4    4    0.95225E-10    0.10000E+01    0.30034E+03    0.48465E-06    0.33742E-09    0.45594E-16
+    4    4    0.95225E-10    0.10000E+01    0.24221E+03    0.85389E-06    0.78784E-09    0.80333E-16
+    4    4    0.95225E-10    0.10000E+01    0.19533E+03    0.13458E-05    0.14972E-08    0.12661E-15
+    4    4    0.95225E-10    0.10000E+01    0.15752E+03    0.13458E-05    0.14972E-08    0.12661E-15
+    4    4    0.16616E-09    0.10000E+01    0.80645E+05    0.10807E-56    0.82399E-68    0.47500E-66
+    4    4    0.16616E-09    0.10000E+01    0.65036E+05    0.92760E-56    0.13091E-66    0.40231E-65
+    4    4    0.16616E-09    0.10000E+01    0.52449E+05    0.79143E-55    0.17633E-65    0.34029E-64
+    4    4    0.16616E-09    0.10000E+01    0.42297E+05    0.59778E-54    0.24642E-64    0.25177E-63
+    4    4    0.16616E-09    0.10000E+01    0.34111E+05    0.44275E-53    0.38828E-63    0.17458E-62
+    4    4    0.16616E-09    0.10000E+01    0.27509E+05    0.36172E-52    0.83316E-62    0.11899E-61
+    4    4    0.16616E-09    0.10000E+01    0.22184E+05    0.38928E-51    0.24678E-60    0.90849E-61
+    4    4    0.16616E-09    0.10000E+01    0.17891E+05    0.56738E-50    0.77147E-59    0.98961E-60
+    4    4    0.16616E-09    0.10000E+01    0.14428E+05    0.90490E-49    0.22661E-57    0.14405E-58
+    4    4    0.16616E-09    0.10000E+01    0.11635E+05    0.13939E-47    0.63511E-56    0.22055E-57
+    4    4    0.16616E-09    0.10000E+01    0.93834E+04    0.20602E-46    0.17463E-54    0.32836E-56
+    4    4    0.16616E-09    0.10000E+01    0.75673E+04    0.29807E-45    0.47697E-53    0.47783E-55
+    4    4    0.16616E-09    0.10000E+01    0.61026E+04    0.42750E-44    0.12986E-51    0.68809E-54
+    4    4    0.16616E-09    0.10000E+01    0.49215E+04    0.61071E-43    0.35274E-50    0.98628E-53
+    4    4    0.16616E-09    0.10000E+01    0.39689E+04    0.87019E-42    0.95610E-49    0.14098E-51
+    4    4    0.16616E-09    0.10000E+01    0.32008E+04    0.38919E-39    0.83685E-46    0.63253E-49
+    4    4    0.16616E-09    0.10000E+01    0.25813E+04    0.28776E-30    0.14176E-36    0.46926E-40
+    4    4    0.16616E-09    0.10000E+01    0.20817E+04    0.55269E-14    0.12139E-19    0.90493E-24
+    4    4    0.16616E-09    0.10000E+01    0.16788E+04    0.18788E-08    0.17991E-13    0.30843E-18
+    4    4    0.16616E-09    0.10000E+01    0.13538E+04    0.40419E-08    0.68373E-13    0.66409E-18
+    4    4    0.16616E-09    0.10000E+01    0.10918E+04    0.84987E-08    0.25501E-12    0.13973E-17
+    4    4    0.16616E-09    0.10000E+01    0.88049E+03    0.17482E-07    0.93903E-12    0.28755E-17
+    4    4    0.16616E-09    0.10000E+01    0.71007E+03    0.35259E-07    0.34196E-11    0.58013E-17
+    4    4    0.16616E-09    0.10000E+01    0.57264E+03    0.69903E-07    0.12167E-10    0.11504E-16
+    4    4    0.16616E-09    0.10000E+01    0.46180E+03    0.13632E-06    0.40921E-10    0.22437E-16
+    4    4    0.16616E-09    0.10000E+01    0.37242E+03    0.26022E-06    0.12478E-09    0.42834E-16
+    4    4    0.16616E-09    0.10000E+01    0.30034E+03    0.48068E-06    0.33467E-09    0.79124E-16
+    4    4    0.16616E-09    0.10000E+01    0.24221E+03    0.84691E-06    0.78143E-09    0.13941E-15
+    4    4    0.16616E-09    0.10000E+01    0.19533E+03    0.13348E-05    0.14850E-08    0.21972E-15
+    4    4    0.16616E-09    0.10000E+01    0.15752E+03    0.13348E-05    0.14850E-08    0.21972E-15
+    4    4    0.28994E-09    0.10000E+01    0.80645E+05    0.21474E-56    0.16160E-67    0.17368E-65
+    4    4    0.28994E-09    0.10000E+01    0.65036E+05    0.18241E-55    0.25551E-66    0.14612E-64
+    4    4    0.28994E-09    0.10000E+01    0.52449E+05    0.15459E-54    0.33806E-65    0.12321E-63
+    4    4    0.28994E-09    0.10000E+01    0.42297E+05    0.11491E-53    0.44516E-64    0.90915E-63
+    4    4    0.28994E-09    0.10000E+01    0.34111E+05    0.80883E-53    0.59946E-63    0.62852E-62
+    4    4    0.28994E-09    0.10000E+01    0.27509E+05    0.57629E-52    0.98513E-62    0.42042E-61
+    4    4    0.28994E-09    0.10000E+01    0.22184E+05    0.48609E-51    0.24629E-60    0.28635E-60
+    4    4    0.28994E-09    0.10000E+01    0.17891E+05    0.58664E-50    0.74649E-59    0.23922E-59
+    4    4    0.28994E-09    0.10000E+01    0.14428E+05    0.88450E-49    0.22035E-57    0.28079E-58
+    4    4    0.28994E-09    0.10000E+01    0.11635E+05    0.13569E-47    0.62123E-56    0.39704E-57
+    4    4    0.28994E-09    0.10000E+01    0.93834E+04    0.20143E-46    0.17142E-54    0.57919E-56
+    4    4    0.28994E-09    0.10000E+01    0.75673E+04    0.29249E-45    0.46935E-53    0.83764E-55
+    4    4    0.28994E-09    0.10000E+01    0.61026E+04    0.42058E-44    0.12805E-51    0.12016E-53
+    4    4    0.28994E-09    0.10000E+01    0.49215E+04    0.60211E-43    0.34850E-50    0.17171E-52
+    4    4    0.28994E-09    0.10000E+01    0.39689E+04    0.85964E-42    0.94641E-49    0.24491E-51
+    4    4    0.28994E-09    0.10000E+01    0.32008E+04    0.38523E-39    0.82994E-46    0.10975E-48
+    4    4    0.28994E-09    0.10000E+01    0.25813E+04    0.28541E-30    0.14089E-36    0.81391E-40
+    4    4    0.28994E-09    0.10000E+01    0.20817E+04    0.54952E-14    0.12094E-19    0.15703E-23
+    4    4    0.28994E-09    0.10000E+01    0.16788E+04    0.18710E-08    0.17942E-13    0.53546E-18
+    4    4    0.28994E-09    0.10000E+01    0.13538E+04    0.40272E-08    0.68198E-13    0.11530E-17
+    4    4    0.28994E-09    0.10000E+01    0.10918E+04    0.84711E-08    0.25438E-12    0.24262E-17
+    4    4    0.28994E-09    0.10000E+01    0.88049E+03    0.17430E-07    0.93671E-12    0.49934E-17
+    4    4    0.28994E-09    0.10000E+01    0.71007E+03    0.35161E-07    0.34112E-11    0.10075E-16
+    4    4    0.28994E-09    0.10000E+01    0.57264E+03    0.69718E-07    0.12136E-10    0.19978E-16
+    4    4    0.28994E-09    0.10000E+01    0.46180E+03    0.13597E-06    0.40820E-10    0.38965E-16
+    4    4    0.28994E-09    0.10000E+01    0.37242E+03    0.25956E-06    0.12447E-09    0.74385E-16
+    4    4    0.28994E-09    0.10000E+01    0.30034E+03    0.47947E-06    0.33384E-09    0.13741E-15
+    4    4    0.28994E-09    0.10000E+01    0.24221E+03    0.84479E-06    0.77948E-09    0.24210E-15
+    4    4    0.28994E-09    0.10000E+01    0.19533E+03    0.13315E-05    0.14813E-08    0.38156E-15
+    4    4    0.28994E-09    0.10000E+01    0.15752E+03    0.13315E-05    0.14813E-08    0.38156E-15
+    4    4    0.50593E-09    0.10000E+01    0.80645E+05    0.41857E-56    0.31215E-67    0.60722E-65
+    4    4    0.50593E-09    0.10000E+01    0.65036E+05    0.35306E-55    0.49237E-66    0.51054E-64
+    4    4    0.50593E-09    0.10000E+01    0.52449E+05    0.29810E-54    0.64746E-65    0.43083E-63
+    4    4    0.50593E-09    0.10000E+01    0.42297E+05    0.22038E-53    0.83945E-64    0.31903E-62
+    4    4    0.50593E-09    0.10000E+01    0.34111E+05    0.15299E-52    0.10719E-62    0.22256E-61
+    4    4    0.50593E-09    0.10000E+01    0.27509E+05    0.10387E-51    0.14695E-61    0.15057E-60
+    4    4    0.50593E-09    0.10000E+01    0.22184E+05    0.75001E-51    0.28393E-60    0.99466E-60
+    4    4    0.50593E-09    0.10000E+01    0.17891E+05    0.71056E-50    0.76273E-59    0.69556E-59
+    4    4    0.50593E-09    0.10000E+01    0.14428E+05    0.92627E-49    0.21938E-57    0.61451E-58
+    4    4    0.50593E-09    0.10000E+01    0.11635E+05    0.13604E-47    0.61663E-56    0.72828E-57
+    4    4    0.50593E-09    0.10000E+01    0.93834E+04    0.20019E-46    0.17007E-54    0.10063E-55
+    4    4    0.50593E-09    0.10000E+01    0.75673E+04    0.29021E-45    0.46530E-53    0.14437E-54
+    4    4    0.50593E-09    0.10000E+01    0.61026E+04    0.41697E-44    0.12687E-51    0.20731E-53
+    4    4    0.50593E-09    0.10000E+01    0.49215E+04    0.59660E-43    0.34521E-50    0.29651E-52
+    4    4    0.50593E-09    0.10000E+01    0.39689E+04    0.85160E-42    0.93773E-49    0.42302E-51
+    4    4    0.50593E-09    0.10000E+01    0.32008E+04    0.38172E-39    0.82286E-46    0.18959E-48
+    4    4    0.50593E-09    0.10000E+01    0.25813E+04    0.28302E-30    0.13984E-36    0.14069E-39
+    4    4    0.50593E-09    0.10000E+01    0.20817E+04    0.54562E-14    0.12022E-19    0.27179E-23
+    4    4    0.50593E-09    0.10000E+01    0.16788E+04    0.18595E-08    0.17846E-13    0.92779E-18
+    4    4    0.50593E-09    0.10000E+01    0.13538E+04    0.40034E-08    0.67837E-13    0.19983E-17
+    4    4    0.50593E-09    0.10000E+01    0.10918E+04    0.84229E-08    0.25304E-12    0.42057E-17
+    4    4    0.50593E-09    0.10000E+01    0.88049E+03    0.17334E-07    0.93178E-12    0.86573E-17
+    4    4    0.50593E-09    0.10000E+01    0.71007E+03    0.34970E-07    0.33932E-11    0.17468E-16
+    4    4    0.50593E-09    0.10000E+01    0.57264E+03    0.69344E-07    0.12072E-10    0.34642E-16
+    4    4    0.50593E-09    0.10000E+01    0.46180E+03    0.13525E-06    0.40603E-10    0.67565E-16
+    4    4    0.50593E-09    0.10000E+01    0.37242E+03    0.25818E-06    0.12380E-09    0.12898E-15
+    4    4    0.50593E-09    0.10000E+01    0.30034E+03    0.47693E-06    0.33206E-09    0.23826E-15
+    4    4    0.50593E-09    0.10000E+01    0.24221E+03    0.84030E-06    0.77532E-09    0.41978E-15
+    4    4    0.50593E-09    0.10000E+01    0.19533E+03    0.13244E-05    0.14734E-08    0.66159E-15
+    4    4    0.50593E-09    0.10000E+01    0.15752E+03    0.13244E-05    0.14734E-08    0.66159E-15
+    4    4    0.88282E-09    0.10000E+01    0.80645E+05    0.79949E-56    0.59435E-67    0.20224E-64
+    4    4    0.88282E-09    0.10000E+01    0.65036E+05    0.67274E-55    0.93757E-66    0.17026E-63
+    4    4    0.88282E-09    0.10000E+01    0.52449E+05    0.56776E-54    0.12345E-64    0.14394E-62
+    4    4    0.88282E-09    0.10000E+01    0.42297E+05    0.42014E-53    0.16075E-63    0.10706E-61
+    4    4    0.88282E-09    0.10000E+01    0.34111E+05    0.29253E-52    0.20505E-62    0.75418E-61
+    4    4    0.88282E-09    0.10000E+01    0.27509E+05    0.19784E-51    0.26019E-61    0.51855E-60
+    4    4    0.88282E-09    0.10000E+01    0.22184E+05    0.13378E-50    0.39311E-60    0.34486E-59
+    4    4    0.88282E-09    0.10000E+01    0.17891E+05    0.10315E-49    0.83967E-59    0.22530E-58
+    4    4    0.88282E-09    0.10000E+01    0.14428E+05    0.10674E-48    0.22176E-57    0.15966E-57
+    4    4    0.88282E-09    0.10000E+01    0.11635E+05    0.14022E-47    0.61289E-56    0.14505E-56
+    4    4    0.88282E-09    0.10000E+01    0.93834E+04    0.20003E-46    0.16886E-54    0.17456E-55
+    4    4    0.88282E-09    0.10000E+01    0.75673E+04    0.28840E-45    0.46215E-53    0.24252E-54
+    4    4    0.88282E-09    0.10000E+01    0.61026E+04    0.41414E-44    0.12598E-51    0.34932E-53
+    4    4    0.88282E-09    0.10000E+01    0.49215E+04    0.59240E-43    0.34267E-50    0.50340E-52
+    4    4    0.88282E-09    0.10000E+01    0.39689E+04    0.84538E-42    0.93081E-49    0.72199E-51
+    4    4    0.88282E-09    0.10000E+01    0.32008E+04    0.37893E-39    0.81709E-46    0.32468E-48
+    4    4    0.88282E-09    0.10000E+01    0.25813E+04    0.28108E-30    0.13898E-36    0.24157E-39
+    4    4    0.88282E-09    0.10000E+01    0.20817E+04    0.54248E-14    0.11964E-19    0.46812E-23
+    4    4    0.88282E-09    0.10000E+01    0.16788E+04    0.18503E-08    0.17770E-13    0.16015E-17
+    4    4    0.88282E-09    0.10000E+01    0.13538E+04    0.39846E-08    0.67553E-13    0.34509E-17
+    4    4    0.88282E-09    0.10000E+01    0.10918E+04    0.83848E-08    0.25198E-12    0.72659E-17
+    4    4    0.88282E-09    0.10000E+01    0.88049E+03    0.17258E-07    0.92786E-12    0.14961E-16
+    4    4    0.88282E-09    0.10000E+01    0.71007E+03    0.34819E-07    0.33788E-11    0.30192E-16
+    4    4    0.88282E-09    0.10000E+01    0.57264E+03    0.69048E-07    0.12021E-10    0.59881E-16
+    4    4    0.88282E-09    0.10000E+01    0.46180E+03    0.13467E-06    0.40429E-10    0.11680E-15
+    4    4    0.88282E-09    0.10000E+01    0.37242E+03    0.25709E-06    0.12327E-09    0.22296E-15
+    4    4    0.88282E-09    0.10000E+01    0.30034E+03    0.47489E-06    0.33063E-09    0.41185E-15
+    4    4    0.88282E-09    0.10000E+01    0.24221E+03    0.83671E-06    0.77198E-09    0.72562E-15
+    4    4    0.88282E-09    0.10000E+01    0.19533E+03    0.13187E-05    0.14670E-08    0.11436E-14
+    4    4    0.88282E-09    0.10000E+01    0.15752E+03    0.13187E-05    0.14670E-08    0.11436E-14
+    4    4    0.15405E-08    0.10000E+01    0.80645E+05    0.15009E-55    0.11160E-66    0.65617E-64
+    4    4    0.15405E-08    0.10000E+01    0.65036E+05    0.12632E-54    0.17627E-65    0.55323E-63
+    4    4    0.15405E-08    0.10000E+01    0.52449E+05    0.10673E-53    0.23309E-64    0.46849E-62
+    4    4    0.15405E-08    0.10000E+01    0.42297E+05    0.79254E-53    0.30655E-63    0.34972E-61
+    4    4    0.15405E-08    0.10000E+01    0.34111E+05    0.55626E-52    0.39704E-62    0.24826E-60
+    4    4    0.15405E-08    0.10000E+01    0.27509E+05    0.38041E-51    0.49677E-61    0.17308E-59
+    4    4    0.15405E-08    0.10000E+01    0.22184E+05    0.25386E-50    0.64630E-60    0.11710E-58
+    4    4    0.15405E-08    0.10000E+01    0.17891E+05    0.17407E-49    0.10476E-58    0.76160E-58
+    4    4    0.15405E-08    0.10000E+01    0.14428E+05    0.14132E-48    0.23005E-57    0.49073E-57
+    4    4    0.15405E-08    0.10000E+01    0.11635E+05    0.15155E-47    0.60041E-56    0.35162E-56
+    4    4    0.15405E-08    0.10000E+01    0.93834E+04    0.19899E-46    0.16439E-54    0.32981E-55
+    4    4    0.15405E-08    0.10000E+01    0.75673E+04    0.28178E-45    0.45171E-53    0.40813E-54
+    4    4    0.15405E-08    0.10000E+01    0.61026E+04    0.40486E-44    0.12355E-51    0.57631E-53
+    4    4    0.15405E-08    0.10000E+01    0.49215E+04    0.58080E-43    0.33673E-50    0.83803E-52
+    4    4    0.15405E-08    0.10000E+01    0.39689E+04    0.83052E-42    0.91578E-49    0.12151E-50
+    4    4    0.15405E-08    0.10000E+01    0.32008E+04    0.37278E-39    0.80483E-46    0.55064E-48
+    4    4    0.15405E-08    0.10000E+01    0.25813E+04    0.27689E-30    0.13711E-36    0.41188E-39
+    4    4    0.15405E-08    0.10000E+01    0.20817E+04    0.53539E-14    0.11825E-19    0.80217E-23
+    4    4    0.15405E-08    0.10000E+01    0.16788E+04    0.18287E-08    0.17579E-13    0.27534E-17
+    4    4    0.15405E-08    0.10000E+01    0.13538E+04    0.39392E-08    0.66832E-13    0.59367E-17
+    4    4    0.15405E-08    0.10000E+01    0.10918E+04    0.82914E-08    0.24930E-12    0.12506E-16
+    4    4    0.15405E-08    0.10000E+01    0.88049E+03    0.17069E-07    0.91794E-12    0.25759E-16
+    4    4    0.15405E-08    0.10000E+01    0.71007E+03    0.34442E-07    0.33425E-11    0.51997E-16
+    4    4    0.15405E-08    0.10000E+01    0.57264E+03    0.68304E-07    0.11891E-10    0.10314E-15
+    4    4    0.15405E-08    0.10000E+01    0.46180E+03    0.13322E-06    0.39992E-10    0.20118E-15
+    4    4    0.15405E-08    0.10000E+01    0.37242E+03    0.25432E-06    0.12194E-09    0.38405E-15
+    4    4    0.15405E-08    0.10000E+01    0.30034E+03    0.46978E-06    0.32704E-09    0.70939E-15
+    4    4    0.15405E-08    0.10000E+01    0.24221E+03    0.82769E-06    0.76361E-09    0.12498E-14
+    4    4    0.15405E-08    0.10000E+01    0.19533E+03    0.13045E-05    0.14511E-08    0.19697E-14
+    4    4    0.15405E-08    0.10000E+01    0.15752E+03    0.13045E-05    0.14511E-08    0.19697E-14
+    4    4    0.26880E-08    0.10000E+01    0.80645E+05    0.27715E-55    0.20635E-66    0.20750E-63
+    4    4    0.26880E-08    0.10000E+01    0.65036E+05    0.23353E-54    0.32643E-65    0.17517E-62
+    4    4    0.26880E-08    0.10000E+01    0.52449E+05    0.19762E-53    0.43356E-64    0.14854E-61
+    4    4    0.26880E-08    0.10000E+01    0.42297E+05    0.14727E-52    0.57561E-63    0.11118E-60
+    4    4    0.26880E-08    0.10000E+01    0.34111E+05    0.10417E-51    0.75786E-62    0.79366E-60
+    4    4    0.26880E-08    0.10000E+01    0.27509E+05    0.72187E-51    0.95965E-61    0.55900E-59
+    4    4    0.26880E-08    0.10000E+01    0.22184E+05    0.48601E-50    0.11857E-59    0.38457E-58
+    4    4    0.26880E-08    0.10000E+01    0.17891E+05    0.32048E-49    0.15760E-58    0.25461E-57
+    4    4    0.26880E-08    0.10000E+01    0.14428E+05    0.22210E-48    0.26665E-57    0.16246E-56
+    4    4    0.26880E-08    0.10000E+01    0.11635E+05    0.18658E-47    0.60071E-56    0.10457E-55
+    4    4    0.26880E-08    0.10000E+01    0.93834E+04    0.20619E-46    0.15826E-54    0.76865E-55
+    4    4    0.26880E-08    0.10000E+01    0.75673E+04    0.27456E-45    0.43551E-53    0.75046E-54
+    4    4    0.26880E-08    0.10000E+01    0.61026E+04    0.39128E-44    0.12009E-51    0.95744E-53
+    4    4    0.26880E-08    0.10000E+01    0.49215E+04    0.56433E-43    0.32928E-50    0.13745E-51
+    4    4    0.26880E-08    0.10000E+01    0.39689E+04    0.81165E-42    0.89895E-49    0.20165E-50
+    4    4    0.26880E-08    0.10000E+01    0.32008E+04    0.36579E-39    0.79220E-46    0.92496E-48
+    4    4    0.26880E-08    0.10000E+01    0.25813E+04    0.27254E-30    0.13532E-36    0.69788E-39
+    4    4    0.26880E-08    0.10000E+01    0.20817E+04    0.52868E-14    0.11705E-19    0.13692E-22
+    4    4    0.26880E-08    0.10000E+01    0.16788E+04    0.18098E-08    0.17421E-13    0.47207E-17
+    4    4    0.26880E-08    0.10000E+01    0.13538E+04    0.39002E-08    0.66239E-13    0.10182E-16
+    4    4    0.26880E-08    0.10000E+01    0.10918E+04    0.82123E-08    0.24709E-12    0.21458E-16
+    4    4    0.26880E-08    0.10000E+01    0.88049E+03    0.16910E-07    0.90976E-12    0.44213E-16
+    4    4    0.26880E-08    0.10000E+01    0.71007E+03    0.34128E-07    0.33125E-11    0.89264E-16
+    4    4    0.26880E-08    0.10000E+01    0.57264E+03    0.67687E-07    0.11784E-10    0.17707E-15
+    4    4    0.26880E-08    0.10000E+01    0.46180E+03    0.13202E-06    0.39629E-10    0.34539E-15
+    4    4    0.26880E-08    0.10000E+01    0.37242E+03    0.25203E-06    0.12083E-09    0.65933E-15
+    4    4    0.26880E-08    0.10000E+01    0.30034E+03    0.46554E-06    0.32406E-09    0.12178E-14
+    4    4    0.26880E-08    0.10000E+01    0.24221E+03    0.82021E-06    0.75664E-09    0.21454E-14
+    4    4    0.26880E-08    0.10000E+01    0.19533E+03    0.12927E-05    0.14378E-08    0.33810E-14
+    4    4    0.26880E-08    0.10000E+01    0.15752E+03    0.12927E-05    0.14378E-08    0.33810E-14
+    4    4    0.46905E-08    0.10000E+01    0.80645E+05    0.50497E-55    0.37660E-66    0.68486E-63
+    4    4    0.46905E-08    0.10000E+01    0.65036E+05    0.42608E-54    0.59658E-65    0.57887E-62
+    4    4    0.46905E-08    0.10000E+01    0.52449E+05    0.36109E-53    0.79543E-64    0.49142E-61
+    4    4    0.46905E-08    0.10000E+01    0.42297E+05    0.26995E-52    0.10642E-62    0.36868E-60
+    4    4    0.46905E-08    0.10000E+01    0.34111E+05    0.19220E-51    0.14209E-61    0.26435E-59
+    4    4    0.46905E-08    0.10000E+01    0.27509E+05    0.13475E-50    0.18347E-60    0.18773E-58
+    4    4    0.46905E-08    0.10000E+01    0.22184E+05    0.92167E-50    0.22757E-59    0.13105E-57
+    4    4    0.46905E-08    0.10000E+01    0.17891E+05    0.61013E-49    0.28055E-58    0.88761E-57
+    4    4    0.46905E-08    0.10000E+01    0.14428E+05    0.39981E-48    0.38397E-57    0.58010E-56
+    4    4    0.46905E-08    0.10000E+01    0.11635E+05    0.28208E-47    0.67615E-56    0.36998E-55
+    4    4    0.46905E-08    0.10000E+01    0.93834E+04    0.24551E-46    0.15590E-54    0.24097E-54
+    4    4    0.46905E-08    0.10000E+01    0.75673E+04    0.27911E-45    0.41509E-53    0.17956E-53
+    4    4    0.46905E-08    0.10000E+01    0.61026E+04    0.37701E-44    0.11495E-51    0.17688E-52
+    4    4    0.46905E-08    0.10000E+01    0.49215E+04    0.54129E-43    0.31840E-50    0.22755E-51
+    4    4    0.46905E-08    0.10000E+01    0.39689E+04    0.78441E-42    0.87583E-49    0.32941E-50
+    4    4    0.46905E-08    0.10000E+01    0.32008E+04    0.35615E-39    0.77575E-46    0.15313E-47
+    4    4    0.46905E-08    0.10000E+01    0.25813E+04    0.26681E-30    0.13306E-36    0.11715E-38
+    4    4    0.46905E-08    0.10000E+01    0.20817E+04    0.52016E-14    0.11553E-19    0.23260E-22
+    4    4    0.46905E-08    0.10000E+01    0.16788E+04    0.17863E-08    0.17217E-13    0.80697E-17
+    4    4    0.46905E-08    0.10000E+01    0.13538E+04    0.38508E-08    0.65471E-13    0.17397E-16
+    4    4    0.46905E-08    0.10000E+01    0.10918E+04    0.81113E-08    0.24422E-12    0.36662E-16
+    4    4    0.46905E-08    0.10000E+01    0.88049E+03    0.16707E-07    0.89914E-12    0.75545E-16
+    4    4    0.46905E-08    0.10000E+01    0.71007E+03    0.33723E-07    0.32735E-11    0.15253E-15
+    4    4    0.46905E-08    0.10000E+01    0.57264E+03    0.66889E-07    0.11644E-10    0.30255E-15
+    4    4    0.46905E-08    0.10000E+01    0.46180E+03    0.13047E-06    0.39157E-10    0.59008E-15
+    4    4    0.46905E-08    0.10000E+01    0.37242E+03    0.24906E-06    0.11938E-09    0.11263E-14
+    4    4    0.46905E-08    0.10000E+01    0.30034E+03    0.46003E-06    0.32018E-09    0.20800E-14
+    4    4    0.46905E-08    0.10000E+01    0.24221E+03    0.81048E-06    0.74756E-09    0.36639E-14
+    4    4    0.46905E-08    0.10000E+01    0.19533E+03    0.12773E-05    0.14206E-08    0.57736E-14
+    4    4    0.46905E-08    0.10000E+01    0.15752E+03    0.12773E-05    0.14206E-08    0.57736E-14
+    4    4    0.81846E-08    0.10000E+01    0.80645E+05    0.90630E-55    0.67775E-66    0.58361E-62
+    4    4    0.81846E-08    0.10000E+01    0.65036E+05    0.76641E-54    0.10757E-64    0.49446E-61
+    4    4    0.81846E-08    0.10000E+01    0.52449E+05    0.65088E-53    0.14416E-63    0.42068E-60
+    4    4    0.81846E-08    0.10000E+01    0.42297E+05    0.48863E-52    0.19474E-62    0.31690E-59
+    4    4    0.81846E-08    0.10000E+01    0.34111E+05    0.35076E-51    0.26456E-61    0.22895E-58
+    4    4    0.81846E-08    0.10000E+01    0.27509E+05    0.24966E-50    0.35258E-60    0.16474E-57
+    4    4    0.81846E-08    0.10000E+01    0.22184E+05    0.17540E-49    0.45968E-59    0.11768E-56
+    4    4    0.81846E-08    0.10000E+01    0.17891E+05    0.12102E-48    0.59578E-58    0.82849E-56
+    4    4    0.81846E-08    0.10000E+01    0.14428E+05    0.82839E-48    0.80205E-57    0.57344E-55
+    4    4    0.81846E-08    0.10000E+01    0.11635E+05    0.58198E-47    0.12026E-55    0.39095E-54
+    4    4    0.81846E-08    0.10000E+01    0.93834E+04    0.44656E-46    0.21587E-54    0.26313E-53
+    4    4    0.81846E-08    0.10000E+01    0.75673E+04    0.40350E-45    0.47243E-53    0.17519E-52
+    4    4    0.81846E-08    0.10000E+01    0.61026E+04    0.44431E-44    0.11896E-51    0.11711E-51
+    4    4    0.81846E-08    0.10000E+01    0.49215E+04    0.57067E-43    0.31972E-50    0.83539E-51
+    4    4    0.81846E-08    0.10000E+01    0.39689E+04    0.79346E-42    0.87575E-49    0.72177E-50
+    4    4    0.81846E-08    0.10000E+01    0.32008E+04    0.35695E-39    0.77727E-46    0.25978E-47
+    4    4    0.81846E-08    0.10000E+01    0.25813E+04    0.26759E-30    0.13355E-36    0.18971E-38
+    4    4    0.81846E-08    0.10000E+01    0.20817E+04    0.52287E-14    0.11588E-19    0.39234E-22
+    4    4    0.81846E-08    0.10000E+01    0.16788E+04    0.17961E-08    0.17253E-13    0.13817E-16
+    4    4    0.81846E-08    0.10000E+01    0.13538E+04    0.38660E-08    0.65595E-13    0.29188E-16
+    4    4    0.81846E-08    0.10000E+01    0.10918E+04    0.81362E-08    0.24464E-12    0.60901E-16
+    4    4    0.81846E-08    0.10000E+01    0.88049E+03    0.16749E-07    0.90058E-12    0.12483E-15
+    4    4    0.81846E-08    0.10000E+01    0.71007E+03    0.33796E-07    0.32785E-11    0.25122E-15
+    4    4    0.81846E-08    0.10000E+01    0.57264E+03    0.67019E-07    0.11661E-10    0.49720E-15
+    4    4    0.81846E-08    0.10000E+01    0.46180E+03    0.13070E-06    0.39212E-10    0.96801E-15
+    4    4    0.81846E-08    0.10000E+01    0.37242E+03    0.24947E-06    0.11955E-09    0.18451E-14
+    4    4    0.81846E-08    0.10000E+01    0.30034E+03    0.46076E-06    0.32063E-09    0.34038E-14
+    4    4    0.81846E-08    0.10000E+01    0.24221E+03    0.81170E-06    0.74859E-09    0.59912E-14
+    4    4    0.81846E-08    0.10000E+01    0.19533E+03    0.12792E-05    0.14225E-08    0.94362E-14
+    4    4    0.81846E-08    0.10000E+01    0.15752E+03    0.12792E-05    0.14225E-08    0.94362E-14
+    4    4    0.14282E-07    0.10000E+01    0.80645E+05    0.15489E-54    0.11604E-65    0.40665E-61
+    4    4    0.14282E-07    0.10000E+01    0.65036E+05    0.13118E-53    0.18442E-64    0.34498E-60
+    4    4    0.14282E-07    0.10000E+01    0.52449E+05    0.11156E-52    0.24796E-63    0.29384E-59
+    4    4    0.14282E-07    0.10000E+01    0.42297E+05    0.83979E-52    0.33696E-62    0.22181E-58
+    4    4    0.14282E-07    0.10000E+01    0.34111E+05    0.60592E-51    0.46245E-61    0.16085E-57
+    4    4    0.14282E-07    0.10000E+01    0.27509E+05    0.43514E-50    0.62690E-60    0.11645E-56
+    4    4    0.14282E-07    0.10000E+01    0.22184E+05    0.31023E-49    0.83780E-59    0.84013E-56
+    4    4    0.14282E-07    0.10000E+01    0.17891E+05    0.21866E-48    0.11142E-57    0.60077E-55
+    4    4    0.14282E-07    0.10000E+01    0.14428E+05    0.15319E-47    0.15092E-56    0.42526E-54
+    4    4    0.14282E-07    0.10000E+01    0.11635E+05    0.10861E-46    0.21579E-55    0.29842E-53
+    4    4    0.14282E-07    0.10000E+01    0.93834E+04    0.80464E-46    0.34205E-54    0.20777E-52
+    4    4    0.14282E-07    0.10000E+01    0.75673E+04    0.65307E-45    0.63206E-53    0.14318E-51
+    4    4    0.14282E-07    0.10000E+01    0.61026E+04    0.61218E-44    0.13787E-51    0.97196E-51
+    4    4    0.14282E-07    0.10000E+01    0.49215E+04    0.67762E-43    0.34058E-50    0.64869E-50
+    4    4    0.14282E-07    0.10000E+01    0.39689E+04    0.85767E-42    0.89895E-49    0.43169E-49
+    4    4    0.14282E-07    0.10000E+01    0.32008E+04    0.36913E-39    0.78770E-46    0.96538E-47
+    4    4    0.14282E-07    0.10000E+01    0.25813E+04    0.27243E-30    0.13484E-36    0.45440E-38
+    4    4    0.14282E-07    0.10000E+01    0.20817E+04    0.53076E-14    0.11667E-19    0.82707E-22
+    4    4    0.14282E-07    0.10000E+01    0.16788E+04    0.18190E-08    0.17339E-13    0.27841E-16
+    4    4    0.14282E-07    0.10000E+01    0.13538E+04    0.39014E-08    0.65895E-13    0.53263E-16
+    4    4    0.14282E-07    0.10000E+01    0.10918E+04    0.81945E-08    0.24570E-12    0.10513E-15
+    4    4    0.14282E-07    0.10000E+01    0.88049E+03    0.16849E-07    0.90433E-12    0.20896E-15
+    4    4    0.14282E-07    0.10000E+01    0.71007E+03    0.33975E-07    0.32918E-11    0.41314E-15
+    4    4    0.14282E-07    0.10000E+01    0.57264E+03    0.67341E-07    0.11708E-10    0.80875E-15
+    4    4    0.14282E-07    0.10000E+01    0.46180E+03    0.13129E-06    0.39368E-10    0.15633E-14
+    4    4    0.14282E-07    0.10000E+01    0.37242E+03    0.25055E-06    0.12002E-09    0.29649E-14
+    4    4    0.14282E-07    0.10000E+01    0.30034E+03    0.46268E-06    0.32189E-09    0.54512E-14
+    4    4    0.14282E-07    0.10000E+01    0.24221E+03    0.81503E-06    0.75154E-09    0.95725E-14
+    4    4    0.14282E-07    0.10000E+01    0.19533E+03    0.12844E-05    0.14281E-08    0.15055E-13
+    4    4    0.14282E-07    0.10000E+01    0.15752E+03    0.12844E-05    0.14281E-08    0.15055E-13
+    4    4    0.24920E-07    0.10000E+01    0.80645E+05    0.26513E-54    0.19876E-65    0.11837E-60
+    4    4    0.24920E-07    0.10000E+01    0.65036E+05    0.22466E-53    0.31602E-64    0.10045E-59
+    4    4    0.24920E-07    0.10000E+01    0.52449E+05    0.19115E-52    0.42536E-63    0.85586E-59
+    4    4    0.24920E-07    0.10000E+01    0.42297E+05    0.14402E-51    0.57911E-62    0.64642E-58
+    4    4    0.24920E-07    0.10000E+01    0.34111E+05    0.10408E-50    0.79705E-61    0.46921E-57
+    4    4    0.24920E-07    0.10000E+01    0.27509E+05    0.74932E-50    0.10848E-59    0.34021E-56
+    4    4    0.24920E-07    0.10000E+01    0.22184E+05    0.53608E-49    0.14553E-58    0.24604E-55
+    4    4    0.24920E-07    0.10000E+01    0.17891E+05    0.37916E-48    0.19342E-57    0.17660E-54
+    4    4    0.24920E-07    0.10000E+01    0.14428E+05    0.26564E-47    0.25824E-56    0.12565E-53
+    4    4    0.24920E-07    0.10000E+01    0.11635E+05    0.18624E-46    0.35371E-55    0.88746E-53
+    4    4    0.24920E-07    0.10000E+01    0.93834E+04    0.13311E-45    0.51345E-54    0.62267E-52
+    4    4    0.24920E-07    0.10000E+01    0.75673E+04    0.99990E-45    0.83176E-53    0.43306E-51
+    4    4    0.24920E-07    0.10000E+01    0.61026E+04    0.82880E-44    0.15833E-51    0.29711E-50
+    4    4    0.24920E-07    0.10000E+01    0.49215E+04    0.79982E-43    0.35581E-50    0.20003E-49
+    4    4    0.24920E-07    0.10000E+01    0.39689E+04    0.91265E-42    0.89762E-49    0.13217E-48
+    4    4    0.24920E-07    0.10000E+01    0.32008E+04    0.37226E-39    0.77535E-46    0.27764E-46
+    4    4    0.24920E-07    0.10000E+01    0.25813E+04    0.27002E-30    0.13270E-36    0.11147E-37
+    4    4    0.24920E-07    0.10000E+01    0.20817E+04    0.52733E-14    0.11519E-19    0.17802E-21
+    4    4    0.24920E-07    0.10000E+01    0.16788E+04    0.18102E-08    0.17126E-13    0.56657E-16
+    4    4    0.24920E-07    0.10000E+01    0.13538E+04    0.38674E-08    0.65077E-13    0.10040E-15
+    4    4    0.24920E-07    0.10000E+01    0.10918E+04    0.81077E-08    0.24260E-12    0.18856E-15
+    4    4    0.24920E-07    0.10000E+01    0.88049E+03    0.16655E-07    0.89271E-12    0.36378E-15
+    4    4    0.24920E-07    0.10000E+01    0.71007E+03    0.33565E-07    0.32488E-11    0.70673E-15
+    4    4    0.24920E-07    0.10000E+01    0.57264E+03    0.66506E-07    0.11553E-10    0.13689E-14
+    4    4    0.24920E-07    0.10000E+01    0.46180E+03    0.12962E-06    0.38843E-10    0.26284E-14
+    4    4    0.24920E-07    0.10000E+01    0.37242E+03    0.24732E-06    0.11841E-09    0.49635E-14
+    4    4    0.24920E-07    0.10000E+01    0.30034E+03    0.45665E-06    0.31756E-09    0.90994E-14
+    4    4    0.24920E-07    0.10000E+01    0.24221E+03    0.80431E-06    0.74141E-09    0.15949E-13
+    4    4    0.24920E-07    0.10000E+01    0.19533E+03    0.12674E-05    0.14088E-08    0.25055E-13
+    4    4    0.24920E-07    0.10000E+01    0.15752E+03    0.12674E-05    0.14088E-08    0.25055E-13
+    4    4    0.43485E-07    0.10000E+01    0.80645E+05    0.45014E-54    0.33765E-65    0.34254E-60
+    4    4    0.43485E-07    0.10000E+01    0.65036E+05    0.38161E-53    0.53705E-64    0.29078E-59
+    4    4    0.43485E-07    0.10000E+01    0.52449E+05    0.32483E-52    0.72356E-63    0.24781E-58
+    4    4    0.43485E-07    0.10000E+01    0.42297E+05    0.24493E-51    0.98670E-62    0.18726E-57
+    4    4    0.43485E-07    0.10000E+01    0.34111E+05    0.17725E-50    0.13615E-60    0.13603E-56
+    4    4    0.43485E-07    0.10000E+01    0.27509E+05    0.12790E-49    0.18600E-59    0.98765E-56
+    4    4    0.43485E-07    0.10000E+01    0.22184E+05    0.91805E-49    0.25071E-58    0.71575E-55
+    4    4    0.43485E-07    0.10000E+01    0.17891E+05    0.65204E-48    0.33439E-57    0.51533E-54
+    4    4    0.43485E-07    0.10000E+01    0.14428E+05    0.45836E-47    0.44516E-56    0.36824E-53
+    4    4    0.43485E-07    0.10000E+01    0.11635E+05    0.32085E-46    0.59844E-55    0.26147E-52
+    4    4    0.43485E-07    0.10000E+01    0.93834E+04    0.22594E-45    0.82661E-54    0.18462E-51
+    4    4    0.43485E-07    0.10000E+01    0.75673E+04    0.16273E-44    0.12156E-52    0.12939E-50
+    4    4    0.43485E-07    0.10000E+01    0.61026E+04    0.12378E-43    0.20176E-51    0.89620E-50
+    4    4    0.43485E-07    0.10000E+01    0.49215E+04    0.10495E-42    0.39763E-50    0.61009E-49
+    4    4    0.43485E-07    0.10000E+01    0.39689E+04    0.10470E-41    0.92307E-49    0.40619E-48
+    4    4    0.43485E-07    0.10000E+01    0.32008E+04    0.38943E-39    0.76917E-46    0.83883E-46
+    4    4    0.43485E-07    0.10000E+01    0.25813E+04    0.27134E-30    0.13057E-36    0.30664E-37
+    4    4    0.43485E-07    0.10000E+01    0.20817E+04    0.52808E-14    0.11354E-19    0.42515E-21
+    4    4    0.43485E-07    0.10000E+01    0.16788E+04    0.18120E-08    0.16883E-13    0.12525E-15
+    4    4    0.43485E-07    0.10000E+01    0.13538E+04    0.38414E-08    0.64136E-13    0.20175E-15
+    4    4    0.43485E-07    0.10000E+01    0.10918E+04    0.80225E-08    0.23900E-12    0.35246E-15
+    4    4    0.43485E-07    0.10000E+01    0.88049E+03    0.16448E-07    0.87917E-12    0.64828E-15
+    4    4    0.43485E-07    0.10000E+01    0.71007E+03    0.33109E-07    0.31986E-11    0.12228E-14
+    4    4    0.43485E-07    0.10000E+01    0.57264E+03    0.65556E-07    0.11372E-10    0.23260E-14
+    4    4    0.43485E-07    0.10000E+01    0.46180E+03    0.12771E-06    0.38227E-10    0.44162E-14
+    4    4    0.43485E-07    0.10000E+01    0.37242E+03    0.24358E-06    0.11652E-09    0.82801E-14
+    4    4    0.43485E-07    0.10000E+01    0.30034E+03    0.44963E-06    0.31247E-09    0.15110E-13
+    4    4    0.43485E-07    0.10000E+01    0.24221E+03    0.79179E-06    0.72951E-09    0.26406E-13
+    4    4    0.43485E-07    0.10000E+01    0.19533E+03    0.12475E-05    0.13862E-08    0.41411E-13
+    4    4    0.43485E-07    0.10000E+01    0.15752E+03    0.12475E-05    0.13862E-08    0.41411E-13
+    4    4    0.75878E-07    0.10000E+01    0.80645E+05    0.75862E-54    0.56934E-65    0.98616E-60
+    4    4    0.75878E-07    0.10000E+01    0.65036E+05    0.64339E-53    0.90586E-64    0.83736E-59
+    4    4    0.75878E-07    0.10000E+01    0.52449E+05    0.54787E-52    0.12215E-62    0.71379E-58
+    4    4    0.75878E-07    0.10000E+01    0.42297E+05    0.41338E-51    0.16680E-61    0.53959E-57
+    4    4    0.75878E-07    0.10000E+01    0.34111E+05    0.29952E-50    0.23066E-60    0.39227E-56
+    4    4    0.75878E-07    0.10000E+01    0.27509E+05    0.21654E-49    0.31619E-59    0.28512E-55
+    4    4    0.75878E-07    0.10000E+01    0.22184E+05    0.15590E-48    0.42820E-58    0.20699E-54
+    4    4    0.75878E-07    0.10000E+01    0.17891E+05    0.11118E-47    0.57392E-57    0.14943E-53
+    4    4    0.75878E-07    0.10000E+01    0.14428E+05    0.78510E-47    0.76580E-56    0.10716E-52
+    4    4    0.75878E-07    0.10000E+01    0.11635E+05    0.55102E-46    0.10238E-54    0.76430E-52
+    4    4    0.75878E-07    0.10000E+01    0.93834E+04    0.38658E-45    0.13818E-53    0.54249E-51
+    4    4    0.75878E-07    0.10000E+01    0.75673E+04    0.27324E-44    0.19189E-52    0.38260E-50
+    4    4    0.75878E-07    0.10000E+01    0.61026E+04    0.19789E-43    0.28623E-51    0.26716E-49
+    4    4    0.75878E-07    0.10000E+01    0.49215E+04    0.15247E-42    0.48961E-50    0.18376E-48
+    4    4    0.75878E-07    0.10000E+01    0.39689E+04    0.13284E-41    0.10046E-48    0.12378E-47
+    4    4    0.75878E-07    0.10000E+01    0.32008E+04    0.43471E-39    0.77941E-46    0.25663E-45
+    4    4    0.75878E-07    0.10000E+01    0.25813E+04    0.28097E-30    0.12891E-36    0.90109E-37
+    4    4    0.75878E-07    0.10000E+01    0.20817E+04    0.53769E-14    0.11177E-19    0.11120E-20
+    4    4    0.75878E-07    0.10000E+01    0.16788E+04    0.18351E-08    0.16610E-13    0.30139E-15
+    4    4    0.75878E-07    0.10000E+01    0.13538E+04    0.38356E-08    0.63070E-13    0.43933E-15
+    4    4    0.75878E-07    0.10000E+01    0.10918E+04    0.79520E-08    0.23491E-12    0.70047E-15
+    4    4    0.75878E-07    0.10000E+01    0.88049E+03    0.16240E-07    0.86366E-12    0.12017E-14
+    4    4    0.75878E-07    0.10000E+01    0.71007E+03    0.32621E-07    0.31408E-11    0.21625E-14
+    4    4    0.75878E-07    0.10000E+01    0.57264E+03    0.64505E-07    0.11162E-10    0.39919E-14
+    4    4    0.75878E-07    0.10000E+01    0.46180E+03    0.12555E-06    0.37516E-10    0.74374E-14
+    4    4    0.75878E-07    0.10000E+01    0.37242E+03    0.23932E-06    0.11434E-09    0.13781E-13
+    4    4    0.75878E-07    0.10000E+01    0.30034E+03    0.44159E-06    0.30659E-09    0.24961E-13
+    4    4    0.75878E-07    0.10000E+01    0.24221E+03    0.77740E-06    0.71574E-09    0.43417E-13
+    4    4    0.75878E-07    0.10000E+01    0.19533E+03    0.12246E-05    0.13600E-08    0.67905E-13
+    4    4    0.75878E-07    0.10000E+01    0.15752E+03    0.12246E-05    0.13600E-08    0.67905E-13
+    4    4    0.13240E-06    0.10000E+01    0.80645E+05    0.12700E-53    0.95355E-65    0.28263E-59
+    4    4    0.13240E-06    0.10000E+01    0.65036E+05    0.10775E-52    0.15176E-63    0.24004E-58
+    4    4    0.13240E-06    0.10000E+01    0.52449E+05    0.91782E-52    0.20478E-62    0.20465E-57
+    4    4    0.13240E-06    0.10000E+01    0.42297E+05    0.69293E-51    0.27999E-61    0.15476E-56
+    4    4    0.13240E-06    0.10000E+01    0.34111E+05    0.50259E-50    0.38791E-60    0.11258E-55
+    4    4    0.13240E-06    0.10000E+01    0.27509E+05    0.36397E-49    0.53333E-59    0.81911E-55
+    4    4    0.13240E-06    0.10000E+01    0.22184E+05    0.26273E-48    0.72535E-58    0.59556E-54
+    4    4    0.13240E-06    0.10000E+01    0.17891E+05    0.18807E-47    0.97713E-57    0.43091E-53
+    4    4    0.13240E-06    0.10000E+01    0.14428E+05    0.13342E-46    0.13094E-55    0.30998E-52
+    4    4    0.13240E-06    0.10000E+01    0.11635E+05    0.94031E-46    0.17517E-54    0.22192E-51
+    4    4    0.13240E-06    0.10000E+01    0.93834E+04    0.66063E-45    0.23451E-53    0.15820E-50
+    4    4    0.13240E-06    0.10000E+01    0.75673E+04    0.46413E-44    0.31667E-52    0.11217E-49
+    4    4    0.13240E-06    0.10000E+01    0.61026E+04    0.32842E-43    0.44196E-51    0.78849E-49
+    4    4    0.13240E-06    0.10000E+01    0.49215E+04    0.23895E-42    0.67176E-50    0.54721E-48
+    4    4    0.13240E-06    0.10000E+01    0.39689E+04    0.18710E-41    0.11934E-48    0.37286E-47
+    4    4    0.13240E-06    0.10000E+01    0.32008E+04    0.53249E-39    0.82527E-46    0.78168E-45
+    4    4    0.13240E-06    0.10000E+01    0.25813E+04    0.30724E-30    0.12868E-36    0.27181E-36
+    4    4    0.13240E-06    0.10000E+01    0.20817E+04    0.56449E-14    0.10995E-19    0.30988E-20
+    4    4    0.13240E-06    0.10000E+01    0.16788E+04    0.18981E-08    0.16309E-13    0.77957E-15
+    4    4    0.13240E-06    0.10000E+01    0.13538E+04    0.38705E-08    0.61880E-13    0.10418E-14
+    4    4    0.13240E-06    0.10000E+01    0.10918E+04    0.79187E-08    0.23030E-12    0.15067E-14
+    4    4    0.13240E-06    0.10000E+01    0.88049E+03    0.16057E-07    0.84609E-12    0.23651E-14
+    4    4    0.13240E-06    0.10000E+01    0.71007E+03    0.32126E-07    0.30750E-11    0.39734E-14
+    4    4    0.13240E-06    0.10000E+01    0.57264E+03    0.63377E-07    0.10924E-10    0.69933E-14
+    4    4    0.13240E-06    0.10000E+01    0.46180E+03    0.12317E-06    0.36703E-10    0.12630E-13
+    4    4    0.13240E-06    0.10000E+01    0.37242E+03    0.23456E-06    0.11184E-09    0.22943E-13
+    4    4    0.13240E-06    0.10000E+01    0.30034E+03    0.43250E-06    0.29986E-09    0.41049E-13
+    4    4    0.13240E-06    0.10000E+01    0.24221E+03    0.76107E-06    0.69997E-09    0.70858E-13
+    4    4    0.13240E-06    0.10000E+01    0.19533E+03    0.11986E-05    0.13300E-08    0.11035E-12
+    4    4    0.13240E-06    0.10000E+01    0.15752E+03    0.11986E-05    0.13300E-08    0.11035E-12
+    4    4    0.23103E-06    0.10000E+01    0.80645E+05    0.21134E-53    0.15874E-64    0.80676E-59
+    4    4    0.23103E-06    0.10000E+01    0.65036E+05    0.17936E-52    0.25271E-63    0.68532E-58
+    4    4    0.23103E-06    0.10000E+01    0.52449E+05    0.15282E-51    0.34121E-62    0.58441E-57
+    4    4    0.23103E-06    0.10000E+01    0.42297E+05    0.11544E-50    0.46702E-61    0.44208E-56
+    4    4    0.23103E-06    0.10000E+01    0.34111E+05    0.83804E-50    0.64807E-60    0.32176E-55
+    4    4    0.23103E-06    0.10000E+01    0.27509E+05    0.60779E-49    0.89330E-59    0.23431E-54
+    4    4    0.23103E-06    0.10000E+01    0.22184E+05    0.43972E-48    0.12195E-57    0.17059E-53
+    4    4    0.23103E-06    0.10000E+01    0.17891E+05    0.31582E-47    0.16506E-56    0.12367E-52
+    4    4    0.23103E-06    0.10000E+01    0.14428E+05    0.22499E-46    0.22225E-55    0.89197E-52
+    4    4    0.23103E-06    0.10000E+01    0.11635E+05    0.15929E-45    0.29830E-54    0.64062E-51
+    4    4    0.23103E-06    0.10000E+01    0.93834E+04    0.11231E-44    0.39908E-53    0.45841E-50
+    4    4    0.23103E-06    0.10000E+01    0.75673E+04    0.78917E-44    0.53314E-52    0.32646E-49
+    4    4    0.23103E-06    0.10000E+01    0.61026E+04    0.55375E-43    0.71917E-51    0.23078E-48
+    4    4    0.23103E-06    0.10000E+01    0.49215E+04    0.39158E-42    0.10111E-49    0.16136E-47
+    4    4    0.23103E-06    0.10000E+01    0.39689E+04    0.28658E-41    0.15771E-48    0.11107E-46
+    4    4    0.23103E-06    0.10000E+01    0.32008E+04    0.72424E-39    0.94104E-46    0.23572E-44
+    4    4    0.23103E-06    0.10000E+01    0.25813E+04    0.36463E-30    0.13180E-36    0.82310E-36
+    4    4    0.23103E-06    0.10000E+01    0.20817E+04    0.62305E-14    0.10826E-19    0.89496E-20
+    4    4    0.23103E-06    0.10000E+01    0.16788E+04    0.20327E-08    0.15981E-13    0.21246E-14
+    4    4    0.23103E-06    0.10000E+01    0.13538E+04    0.39816E-08    0.60566E-13    0.26648E-14
+    4    4    0.23103E-06    0.10000E+01    0.10918E+04    0.79616E-08    0.22515E-12    0.35352E-14
+    4    4    0.23103E-06    0.10000E+01    0.88049E+03    0.15941E-07    0.82637E-12    0.50418E-14
+    4    4    0.23103E-06    0.10000E+01    0.71007E+03    0.31668E-07    0.30009E-11    0.77547E-14
+    4    4    0.23103E-06    0.10000E+01    0.57264E+03    0.62216E-07    0.10654E-10    0.12728E-13
+    4    4    0.23103E-06    0.10000E+01    0.46180E+03    0.12061E-06    0.35781E-10    0.21872E-13
+    4    4    0.23103E-06    0.10000E+01    0.37242E+03    0.22930E-06    0.10900E-09    0.38447E-13
+    4    4    0.23103E-06    0.10000E+01    0.30034E+03    0.42237E-06    0.29221E-09    0.67375E-13
+    4    4    0.23103E-06    0.10000E+01    0.24221E+03    0.74274E-06    0.68205E-09    0.11482E-12
+    4    4    0.23103E-06    0.10000E+01    0.19533E+03    0.11692E-05    0.12959E-08    0.17754E-12
+    4    4    0.23103E-06    0.10000E+01    0.15752E+03    0.11692E-05    0.12959E-08    0.17754E-12
+    4    4    0.40314E-06    0.10000E+01    0.80645E+05    0.34993E-53    0.26293E-64    0.22870E-58
+    4    4    0.40314E-06    0.10000E+01    0.65036E+05    0.29707E-52    0.41867E-63    0.19431E-57
+    4    4    0.40314E-06    0.10000E+01    0.52449E+05    0.25318E-51    0.56560E-62    0.16572E-56
+    4    4    0.40314E-06    0.10000E+01    0.42297E+05    0.19133E-50    0.77485E-61    0.12540E-55
+    4    4    0.40314E-06    0.10000E+01    0.34111E+05    0.13901E-49    0.10768E-59    0.91313E-55
+    4    4    0.40314E-06    0.10000E+01    0.27509E+05    0.10094E-48    0.14874E-58    0.66544E-54
+    4    4    0.40314E-06    0.10000E+01    0.22184E+05    0.73171E-48    0.20373E-57    0.48503E-53
+    4    4    0.40314E-06    0.10000E+01    0.17891E+05    0.52705E-47    0.27691E-56    0.35222E-52
+    4    4    0.40314E-06    0.10000E+01    0.14428E+05    0.37690E-46    0.37454E-55    0.25462E-51
+    4    4    0.40314E-06    0.10000E+01    0.11635E+05    0.26798E-45    0.50479E-54    0.18338E-50
+    4    4    0.40314E-06    0.10000E+01    0.93834E+04    0.18972E-44    0.67708E-53    0.13164E-49
+    4    4    0.40314E-06    0.10000E+01    0.75673E+04    0.13369E-43    0.90285E-52    0.94102E-49
+    4    4    0.40314E-06    0.10000E+01    0.61026E+04    0.93724E-43    0.12012E-50    0.66837E-48
+    4    4    0.40314E-06    0.10000E+01    0.49215E+04    0.65546E-42    0.16195E-49    0.47024E-47
+    4    4    0.40314E-06    0.10000E+01    0.39689E+04    0.46315E-41    0.23052E-48    0.32643E-46
+    4    4    0.40314E-06    0.10000E+01    0.32008E+04    0.10803E-38    0.11882E-45    0.70057E-44
+    4    4    0.40314E-06    0.10000E+01    0.25813E+04    0.47878E-30    0.14225E-36    0.24686E-35
+    4    4    0.40314E-06    0.10000E+01    0.20817E+04    0.74024E-14    0.10745E-19    0.26168E-19
+    4    4    0.40314E-06    0.10000E+01    0.16788E+04    0.22988E-08    0.15695E-13    0.59630E-14
+    4    4    0.40314E-06    0.10000E+01    0.13538E+04    0.42436E-08    0.59370E-13    0.71925E-14
+    4    4    0.40314E-06    0.10000E+01    0.10918E+04    0.81780E-08    0.22037E-12    0.89585E-14
+    4    4    0.40314E-06    0.10000E+01    0.88049E+03    0.16027E-07    0.80770E-12    0.11739E-13
+    4    4    0.40314E-06    0.10000E+01    0.71007E+03    0.31449E-07    0.29299E-11    0.16425E-13
+    4    4    0.40314E-06    0.10000E+01    0.57264E+03    0.61346E-07    0.10393E-10    0.24661E-13
+    4    4    0.40314E-06    0.10000E+01    0.46180E+03    0.11842E-06    0.34887E-10    0.39418E-13
+    4    4    0.40314E-06    0.10000E+01    0.37242E+03    0.22453E-06    0.10625E-09    0.65751E-13
+    4    4    0.40314E-06    0.10000E+01    0.30034E+03    0.41291E-06    0.28476E-09    0.11127E-12
+    4    4    0.40314E-06    0.10000E+01    0.24221E+03    0.72533E-06    0.66458E-09    0.18552E-12
+    4    4    0.40314E-06    0.10000E+01    0.19533E+03    0.11411E-05    0.12626E-08    0.28334E-12
+    4    4    0.40314E-06    0.10000E+01    0.15752E+03    0.11411E-05    0.12626E-08    0.28334E-12
+    4    4    0.70346E-06    0.10000E+01    0.80645E+05    0.57644E-53    0.43326E-64    0.64857E-58
+    4    4    0.70346E-06    0.10000E+01    0.65036E+05    0.48948E-52    0.69002E-63    0.55113E-57
+    4    4    0.70346E-06    0.10000E+01    0.52449E+05    0.41726E-51    0.93263E-62    0.47011E-56
+    4    4    0.70346E-06    0.10000E+01    0.42297E+05    0.31544E-50    0.12787E-60    0.35580E-55
+    4    4    0.70346E-06    0.10000E+01    0.34111E+05    0.22934E-49    0.17791E-59    0.25920E-54
+    4    4    0.70346E-06    0.10000E+01    0.27509E+05    0.16672E-48    0.24623E-58    0.18901E-53
+    4    4    0.70346E-06    0.10000E+01    0.22184E+05    0.12106E-47    0.33822E-57    0.13791E-52
+    4    4    0.70346E-06    0.10000E+01    0.17891E+05    0.87418E-47    0.46143E-56    0.10030E-51
+    4    4    0.70346E-06    0.10000E+01    0.14428E+05    0.62723E-46    0.62671E-55    0.72651E-51
+    4    4    0.70346E-06    0.10000E+01    0.11635E+05    0.44773E-45    0.84821E-54    0.52449E-50
+    4    4    0.70346E-06    0.10000E+01    0.93834E+04    0.31827E-44    0.11421E-52    0.37756E-49
+    4    4    0.70346E-06    0.10000E+01    0.75673E+04    0.22514E-43    0.15263E-51    0.27079E-48
+    4    4    0.70346E-06    0.10000E+01    0.61026E+04    0.15822E-42    0.20242E-50    0.19311E-47
+    4    4    0.70346E-06    0.10000E+01    0.49215E+04    0.11042E-41    0.26798E-49    0.13659E-46
+    4    4    0.70346E-06    0.10000E+01    0.39689E+04    0.76877E-41    0.36178E-48    0.95504E-46
+    4    4    0.70346E-06    0.10000E+01    0.32008E+04    0.17142E-38    0.16623E-45    0.20696E-43
+    4    4    0.70346E-06    0.10000E+01    0.25813E+04    0.68980E-30    0.16539E-36    0.73659E-35
+    4    4    0.70346E-06    0.10000E+01    0.20817E+04    0.95501E-14    0.10740E-19    0.77108E-19
+    4    4    0.70346E-06    0.10000E+01    0.16788E+04    0.27737E-08    0.15331E-13    0.17092E-13
+    4    4    0.70346E-06    0.10000E+01    0.13538E+04    0.47312E-08    0.57815E-13    0.20201E-13
+    4    4    0.70346E-06    0.10000E+01    0.10918E+04    0.86234E-08    0.21410E-12    0.24202E-13
+    4    4    0.70346E-06    0.10000E+01    0.88049E+03    0.16317E-07    0.78329E-12    0.29812E-13
+    4    4    0.70346E-06    0.10000E+01    0.71007E+03    0.31356E-07    0.28372E-11    0.38379E-13
+    4    4    0.70346E-06    0.10000E+01    0.57264E+03    0.60414E-07    0.10054E-10    0.52398E-13
+    4    4    0.70346E-06    0.10000E+01    0.46180E+03    0.11577E-06    0.33724E-10    0.76368E-13
+    4    4    0.70346E-06    0.10000E+01    0.37242E+03    0.21854E-06    0.10266E-09    0.11793E-12
+    4    4    0.70346E-06    0.10000E+01    0.30034E+03    0.40079E-06    0.27506E-09    0.18857E-12
+    4    4    0.70346E-06    0.10000E+01    0.24221E+03    0.70288E-06    0.64186E-09    0.30265E-12
+    4    4    0.70346E-06    0.10000E+01    0.19533E+03    0.11048E-05    0.12193E-08    0.45212E-12
+    4    4    0.70346E-06    0.10000E+01    0.15752E+03    0.11048E-05    0.12193E-08    0.45212E-12
+    4    4    0.12275E-05    0.10000E+01    0.80645E+05    0.94551E-53    0.71085E-64    0.18343E-57
+    4    4    0.12275E-05    0.10000E+01    0.65036E+05    0.80305E-52    0.11323E-62    0.15589E-56
+    4    4    0.12275E-05    0.10000E+01    0.52449E+05    0.68469E-51    0.15311E-61    0.13299E-55
+    4    4    0.12275E-05    0.10000E+01    0.42297E+05    0.51780E-50    0.21007E-60    0.10068E-54
+    4    4    0.12275E-05    0.10000E+01    0.34111E+05    0.37669E-49    0.29258E-59    0.73369E-54
+    4    4    0.12275E-05    0.10000E+01    0.27509E+05    0.27410E-48    0.40563E-58    0.53534E-53
+    4    4    0.12275E-05    0.10000E+01    0.22184E+05    0.19932E-47    0.55853E-57    0.39095E-52
+    4    4    0.12275E-05    0.10000E+01    0.17891E+05    0.14425E-46    0.76448E-56    0.28470E-51
+    4    4    0.12275E-05    0.10000E+01    0.14428E+05    0.10380E-45    0.10422E-54    0.20658E-50
+    4    4    0.12275E-05    0.10000E+01    0.11635E+05    0.74354E-45    0.14161E-53    0.14945E-49
+    4    4    0.12275E-05    0.10000E+01    0.93834E+04    0.53056E-44    0.19144E-52    0.10785E-48
+    4    4    0.12275E-05    0.10000E+01    0.75673E+04    0.37680E-43    0.25683E-51    0.77569E-48
+    4    4    0.12275E-05    0.10000E+01    0.61026E+04    0.26581E-42    0.34128E-50    0.55514E-47
+    4    4    0.12275E-05    0.10000E+01    0.49215E+04    0.18591E-41    0.44958E-49    0.39445E-46
+    4    4    0.12275E-05    0.10000E+01    0.39689E+04    0.12897E-40    0.59232E-48    0.27748E-45
+    4    4    0.12275E-05    0.10000E+01    0.32008E+04    0.28177E-38    0.25338E-45    0.60627E-43
+    4    4    0.12275E-05    0.10000E+01    0.25813E+04    0.10682E-29    0.21260E-36    0.21779E-34
+    4    4    0.12275E-05    0.10000E+01    0.20817E+04    0.13409E-13    0.10995E-19    0.22675E-18
+    4    4    0.12275E-05    0.10000E+01    0.16788E+04    0.36153E-08    0.14981E-13    0.49372E-13
+    4    4    0.12275E-05    0.10000E+01    0.13538E+04    0.56334E-08    0.56181E-13    0.57903E-13
+    4    4    0.12275E-05    0.10000E+01    0.10918E+04    0.95270E-08    0.20730E-12    0.68060E-13
+    4    4    0.12275E-05    0.10000E+01    0.88049E+03    0.17097E-07    0.75644E-12    0.80868E-13
+    4    4    0.12275E-05    0.10000E+01    0.71007E+03    0.31758E-07    0.27346E-11    0.98299E-13
+    4    4    0.12275E-05    0.10000E+01    0.57264E+03    0.59932E-07    0.96768E-11    0.12403E-12
+    4    4    0.12275E-05    0.10000E+01    0.46180E+03    0.11342E-06    0.32430E-10    0.16474E-12
+    4    4    0.12275E-05    0.10000E+01    0.37242E+03    0.21251E-06    0.98663E-10    0.23171E-12
+    4    4    0.12275E-05    0.10000E+01    0.30034E+03    0.38801E-06    0.26427E-09    0.34193E-12
+    4    4    0.12275E-05    0.10000E+01    0.24221E+03    0.67864E-06    0.61655E-09    0.51657E-12
+    4    4    0.12275E-05    0.10000E+01    0.19533E+03    0.10651E-05    0.11711E-08    0.74295E-12
+    4    4    0.12275E-05    0.10000E+01    0.15752E+03    0.10651E-05    0.11711E-08    0.74295E-12
+    4    4    0.21419E-05    0.10000E+01    0.80645E+05    0.15450E-52    0.11619E-63    0.51746E-57
+    4    4    0.21419E-05    0.10000E+01    0.65036E+05    0.13125E-51    0.18510E-62    0.43983E-56
+    4    4    0.21419E-05    0.10000E+01    0.52449E+05    0.11192E-50    0.25038E-61    0.37526E-55
+    4    4    0.21419E-05    0.10000E+01    0.42297E+05    0.84668E-50    0.34373E-60    0.28413E-54
+    4    4    0.21419E-05    0.10000E+01    0.34111E+05    0.61628E-49    0.47920E-59    0.20713E-53
+    4    4    0.21419E-05    0.10000E+01    0.27509E+05    0.44881E-48    0.66531E-58    0.15121E-52
+    4    4    0.21419E-05    0.10000E+01    0.22184E+05    0.32679E-47    0.91808E-57    0.11051E-51
+    4    4    0.21419E-05    0.10000E+01    0.17891E+05    0.23695E-46    0.12602E-55    0.80572E-51
+    4    4    0.21419E-05    0.10000E+01    0.14428E+05    0.17095E-45    0.17235E-54    0.58554E-50
+    4    4    0.21419E-05    0.10000E+01    0.11635E+05    0.12282E-44    0.23502E-53    0.42440E-49
+    4    4    0.21419E-05    0.10000E+01    0.93834E+04    0.87940E-44    0.31897E-52    0.30691E-48
+    4    4    0.21419E-05    0.10000E+01    0.75673E+04    0.62691E-43    0.42976E-51    0.22130E-47
+    4    4    0.21419E-05    0.10000E+01    0.61026E+04    0.44405E-42    0.57338E-50    0.15886E-46
+    4    4    0.21419E-05    0.10000E+01    0.49215E+04    0.31179E-41    0.75646E-49    0.11332E-45
+    4    4    0.21419E-05    0.10000E+01    0.39689E+04    0.21669E-40    0.98895E-48    0.80133E-45
+    4    4    0.21419E-05    0.10000E+01    0.32008E+04    0.47046E-38    0.40811E-45    0.17630E-42
+    4    4    0.21419E-05    0.10000E+01    0.25813E+04    0.17293E-29    0.30238E-36    0.63849E-34
+    4    4    0.21419E-05    0.10000E+01    0.20817E+04    0.20171E-13    0.11780E-19    0.66351E-18
+    4    4    0.21419E-05    0.10000E+01    0.16788E+04    0.50750E-08    0.14704E-13    0.14282E-12
+    4    4    0.21419E-05    0.10000E+01    0.13538E+04    0.72445E-08    0.54565E-13    0.16742E-12
+    4    4    0.21419E-05    0.10000E+01    0.10918E+04    0.11228E-07    0.20012E-12    0.19558E-12
+    4    4    0.21419E-05    0.10000E+01    0.88049E+03    0.18752E-07    0.72736E-12    0.22871E-12
+    4    4    0.21419E-05    0.10000E+01    0.71007E+03    0.33087E-07    0.26223E-11    0.26969E-12
+    4    4    0.21419E-05    0.10000E+01    0.57264E+03    0.60376E-07    0.92625E-11    0.32392E-12
+    4    4    0.21419E-05    0.10000E+01    0.46180E+03    0.11189E-06    0.31004E-10    0.40127E-12
+    4    4    0.21419E-05    0.10000E+01    0.37242E+03    0.20702E-06    0.94258E-10    0.51852E-12
+    4    4    0.21419E-05    0.10000E+01    0.30034E+03    0.37513E-06    0.25237E-09    0.70079E-12
+    4    4    0.21419E-05    0.10000E+01    0.24221E+03    0.65318E-06    0.58862E-09    0.97930E-12
+    4    4    0.21419E-05    0.10000E+01    0.19533E+03    0.10226E-05    0.11179E-08    0.13327E-11
+    4    4    0.21419E-05    0.10000E+01    0.15752E+03    0.10226E-05    0.11179E-08    0.13327E-11
+    4    4    0.37375E-05    0.10000E+01    0.80645E+05    0.25161E-52    0.18925E-63    0.14544E-56
+    4    4    0.37375E-05    0.10000E+01    0.65036E+05    0.21378E-51    0.30154E-62    0.12363E-55
+    4    4    0.37375E-05    0.10000E+01    0.52449E+05    0.18233E-50    0.40802E-61    0.10549E-54
+    4    4    0.37375E-05    0.10000E+01    0.42297E+05    0.13797E-49    0.56046E-60    0.79888E-54
+    4    4    0.37375E-05    0.10000E+01    0.34111E+05    0.10047E-48    0.78199E-59    0.58255E-53
+    4    4    0.37375E-05    0.10000E+01    0.27509E+05    0.73221E-48    0.10871E-57    0.42548E-52
+    4    4    0.37375E-05    0.10000E+01    0.22184E+05    0.53375E-47    0.15029E-56    0.31118E-51
+    4    4    0.37375E-05    0.10000E+01    0.17891E+05    0.38766E-46    0.20680E-55    0.22710E-50
+    4    4    0.37375E-05    0.10000E+01    0.14428E+05    0.28030E-45    0.28364E-54    0.16526E-49
+    4    4    0.37375E-05    0.10000E+01    0.11635E+05    0.20193E-44    0.38799E-53    0.11998E-48
+    4    4    0.37375E-05    0.10000E+01    0.93834E+04    0.14502E-43    0.52848E-52    0.86925E-48
+    4    4    0.37375E-05    0.10000E+01    0.75673E+04    0.10374E-42    0.71501E-51    0.62813E-47
+    4    4    0.37375E-05    0.10000E+01    0.61026E+04    0.73768E-42    0.95844E-50    0.45212E-46
+    4    4    0.37375E-05    0.10000E+01    0.49215E+04    0.52025E-41    0.12699E-48    0.32361E-45
+    4    4    0.37375E-05    0.10000E+01    0.39689E+04    0.36305E-40    0.16614E-47    0.22986E-44
+    4    4    0.37375E-05    0.10000E+01    0.32008E+04    0.78893E-38    0.67641E-45    0.50869E-42
+    4    4    0.37375E-05    0.10000E+01    0.25813E+04    0.28630E-29    0.46571E-36    0.18550E-33
+    4    4    0.37375E-05    0.10000E+01    0.20817E+04    0.31809E-13    0.13581E-19    0.19271E-17
+    4    4    0.37375E-05    0.10000E+01    0.16788E+04    0.75687E-08    0.14626E-13    0.41169E-12
+    4    4    0.37375E-05    0.10000E+01    0.13538E+04    0.10055E-07    0.53209E-13    0.48413E-12
+    4    4    0.37375E-05    0.10000E+01    0.10918E+04    0.14299E-07    0.19302E-12    0.56604E-12
+    4    4    0.37375E-05    0.10000E+01    0.88049E+03    0.21944E-07    0.69700E-12    0.65960E-12
+    4    4    0.37375E-05    0.10000E+01    0.71007E+03    0.36101E-07    0.25025E-11    0.76926E-12
+    4    4    0.37375E-05    0.10000E+01    0.57264E+03    0.62607E-07    0.88160E-11    0.90354E-12
+    4    4    0.37375E-05    0.10000E+01    0.46180E+03    0.11216E-06    0.29462E-10    0.10781E-11
+    4    4    0.37375E-05    0.10000E+01    0.37242E+03    0.20314E-06    0.89481E-10    0.13192E-11
+    4    4    0.37375E-05    0.10000E+01    0.30034E+03    0.36340E-06    0.23944E-09    0.16663E-11
+    4    4    0.37375E-05    0.10000E+01    0.24221E+03    0.62794E-06    0.55828E-09    0.21678E-11
+    4    4    0.37375E-05    0.10000E+01    0.19533E+03    0.97904E-06    0.10601E-08    0.27819E-11
+    4    4    0.37375E-05    0.10000E+01    0.15752E+03    0.97904E-06    0.10601E-08    0.27819E-11
+    4    4    0.65217E-05    0.10000E+01    0.80645E+05    0.40843E-52    0.30726E-63    0.40452E-56
+    4    4    0.65217E-05    0.10000E+01    0.65036E+05    0.34707E-51    0.48963E-62    0.34390E-55
+    4    4    0.65217E-05    0.10000E+01    0.52449E+05    0.29605E-50    0.66272E-61    0.29346E-54
+    4    4    0.65217E-05    0.10000E+01    0.42297E+05    0.22407E-49    0.91076E-60    0.22227E-53
+    4    4    0.65217E-05    0.10000E+01    0.34111E+05    0.16324E-48    0.12716E-58    0.16212E-52
+    4    4    0.65217E-05    0.10000E+01    0.27509E+05    0.11905E-47    0.17697E-57    0.11846E-51
+    4    4    0.65217E-05    0.10000E+01    0.22184E+05    0.86866E-47    0.24507E-56    0.86686E-51
+    4    4    0.65217E-05    0.10000E+01    0.17891E+05    0.63182E-46    0.33794E-55    0.63318E-50
+    4    4    0.65217E-05    0.10000E+01    0.14428E+05    0.45773E-45    0.46469E-54    0.46131E-49
+    4    4    0.65217E-05    0.10000E+01    0.11635E+05    0.33052E-44    0.63741E-53    0.33537E-48
+    4    4    0.65217E-05    0.10000E+01    0.93834E+04    0.23800E-43    0.87100E-52    0.24337E-47
+    4    4    0.65217E-05    0.10000E+01    0.75673E+04    0.17077E-42    0.11830E-50    0.17619E-46
+    4    4    0.65217E-05    0.10000E+01    0.61026E+04    0.12188E-41    0.15931E-49    0.12711E-45
+    4    4    0.65217E-05    0.10000E+01    0.49215E+04    0.86329E-41    0.21218E-48    0.91243E-45
+    4    4    0.65217E-05    0.10000E+01    0.39689E+04    0.60537E-40    0.27882E-47    0.65053E-44
+    4    4    0.65217E-05    0.10000E+01    0.32008E+04    0.13208E-37    0.11335E-44    0.14467E-41
+    4    4    0.65217E-05    0.10000E+01    0.25813E+04    0.47789E-29    0.75377E-36    0.53061E-33
+    4    4    0.65217E-05    0.10000E+01    0.20817E+04    0.51547E-13    0.17246E-19    0.55135E-17
+    4    4    0.65217E-05    0.10000E+01    0.16788E+04    0.11776E-07    0.14997E-13    0.11719E-11
+    4    4    0.65217E-05    0.10000E+01    0.13538E+04    0.14872E-07    0.52633E-13    0.13841E-11
+    4    4    0.65217E-05    0.10000E+01    0.10918E+04    0.19694E-07    0.18711E-12    0.16247E-11
+    4    4    0.65217E-05    0.10000E+01    0.88049E+03    0.27792E-07    0.66786E-12    0.18978E-11
+    4    4    0.65217E-05    0.10000E+01    0.71007E+03    0.42104E-07    0.23813E-11    0.22122E-11
+    4    4    0.65217E-05    0.10000E+01    0.57264E+03    0.68138E-07    0.83537E-11    0.25836E-11
+    4    4    0.65217E-05    0.10000E+01    0.46180E+03    0.11598E-06    0.27846E-10    0.30408E-11
+    4    4    0.65217E-05    0.10000E+01    0.37242E+03    0.20295E-06    0.84451E-10    0.36314E-11
+    4    4    0.65217E-05    0.10000E+01    0.30034E+03    0.35527E-06    0.22579E-09    0.44253E-11
+    4    4    0.65217E-05    0.10000E+01    0.24221E+03    0.60588E-06    0.52618E-09    0.55072E-11
+    4    4    0.65217E-05    0.10000E+01    0.19533E+03    0.93787E-06    0.99882E-09    0.67770E-11
+    4    4    0.65217E-05    0.10000E+01    0.15752E+03    0.93787E-06    0.99882E-09    0.67770E-11
+    4    4    0.11380E-04    0.10000E+01    0.80645E+05    0.66059E-52    0.49705E-63    0.10899E-55
+    4    4    0.11380E-04    0.10000E+01    0.65036E+05    0.56142E-51    0.79214E-62    0.92663E-55
+    4    4    0.11380E-04    0.10000E+01    0.52449E+05    0.47895E-50    0.10724E-60    0.79077E-54
+    4    4    0.11380E-04    0.10000E+01    0.42297E+05    0.36258E-49    0.14744E-59    0.59901E-53
+    4    4    0.11380E-04    0.10000E+01    0.34111E+05    0.26424E-48    0.20600E-58    0.43700E-52
+    4    4    0.11380E-04    0.10000E+01    0.27509E+05    0.19281E-47    0.28696E-57    0.31940E-51
+    4    4    0.11380E-04    0.10000E+01    0.22184E+05    0.14081E-46    0.39795E-56    0.23385E-50
+    4    4    0.11380E-04    0.10000E+01    0.17891E+05    0.10255E-45    0.54978E-55    0.17093E-49
+    4    4    0.11380E-04    0.10000E+01    0.14428E+05    0.74418E-45    0.75761E-54    0.12465E-48
+    4    4    0.11380E-04    0.10000E+01    0.11635E+05    0.53847E-44    0.10417E-52    0.90723E-48
+    4    4    0.11380E-04    0.10000E+01    0.93834E+04    0.38864E-43    0.14275E-51    0.65920E-47
+    4    4    0.11380E-04    0.10000E+01    0.75673E+04    0.27961E-42    0.19454E-50    0.47797E-46
+    4    4    0.11380E-04    0.10000E+01    0.61026E+04    0.20020E-41    0.26310E-49    0.34546E-45
+    4    4    0.11380E-04    0.10000E+01    0.49215E+04    0.14236E-40    0.35224E-48    0.24855E-44
+    4    4    0.11380E-04    0.10000E+01    0.39689E+04    0.10031E-39    0.46550E-47    0.17774E-43
+    4    4    0.11380E-04    0.10000E+01    0.32008E+04    0.21996E-37    0.19003E-44    0.39683E-41
+    4    4    0.11380E-04    0.10000E+01    0.25813E+04    0.79734E-29    0.12494E-35    0.14620E-32
+    4    4    0.11380E-04    0.10000E+01    0.20817E+04    0.84561E-13    0.24213E-19    0.15197E-16
+    4    4    0.11380E-04    0.10000E+01    0.16788E+04    0.18789E-07    0.16319E-13    0.32187E-11
+    4    4    0.11380E-04    0.10000E+01    0.13538E+04    0.23009E-07    0.54006E-13    0.38178E-11
+    4    4    0.11380E-04    0.10000E+01    0.10918E+04    0.28983E-07    0.18530E-12    0.45013E-11
+    4    4    0.11380E-04    0.10000E+01    0.88049E+03    0.38175E-07    0.64774E-12    0.52808E-11
+    4    4    0.11380E-04    0.10000E+01    0.71007E+03    0.53354E-07    0.22812E-11    0.61767E-11
+    4    4    0.11380E-04    0.10000E+01    0.57264E+03    0.79714E-07    0.79437E-11    0.72251E-11
+    4    4    0.11380E-04    0.10000E+01    0.46180E+03    0.12676E-06    0.26366E-10    0.84882E-11
+    4    4    0.11380E-04    0.10000E+01    0.37242E+03    0.21080E-06    0.79763E-10    0.10067E-10
+    4    4    0.11380E-04    0.10000E+01    0.30034E+03    0.35648E-06    0.21295E-09    0.12104E-10
+    4    4    0.11380E-04    0.10000E+01    0.24221E+03    0.59477E-06    0.49584E-09    0.14770E-10
+    4    4    0.11380E-04    0.10000E+01    0.19533E+03    0.90942E-06    0.94079E-09    0.17799E-10
+    4    4    0.11380E-04    0.10000E+01    0.15752E+03    0.90942E-06    0.94079E-09    0.17799E-10
+    4    4    0.19857E-04    0.10000E+01    0.80645E+05    0.10925E-51    0.82209E-63    0.24559E-55
+    4    4    0.19857E-04    0.10000E+01    0.65036E+05    0.92855E-51    0.13102E-61    0.20882E-54
+    4    4    0.19857E-04    0.10000E+01    0.52449E+05    0.79220E-50    0.17741E-60    0.17821E-53
+    4    4    0.19857E-04    0.10000E+01    0.42297E+05    0.59979E-49    0.24398E-59    0.13500E-52
+    4    4    0.19857E-04    0.10000E+01    0.34111E+05    0.43720E-48    0.34099E-58    0.98499E-52
+    4    4    0.19857E-04    0.10000E+01    0.27509E+05    0.31912E-47    0.47528E-57    0.72004E-51
+    4    4    0.19857E-04    0.10000E+01    0.22184E+05    0.23318E-46    0.65964E-56    0.52732E-50
+    4    4    0.19857E-04    0.10000E+01    0.17891E+05    0.16994E-45    0.91231E-55    0.38558E-49
+    4    4    0.19857E-04    0.10000E+01    0.14428E+05    0.12345E-44    0.12588E-53    0.28132E-48
+    4    4    0.19857E-04    0.10000E+01    0.11635E+05    0.89427E-44    0.17333E-52    0.20487E-47
+    4    4    0.19857E-04    0.10000E+01    0.93834E+04    0.64632E-43    0.23790E-51    0.14896E-46
+    4    4    0.19857E-04    0.10000E+01    0.75673E+04    0.46572E-42    0.32487E-50    0.10810E-45
+    4    4    0.19857E-04    0.10000E+01    0.61026E+04    0.33409E-41    0.44047E-49    0.78203E-45
+    4    4    0.19857E-04    0.10000E+01    0.49215E+04    0.23813E-40    0.59156E-48    0.56335E-44
+    4    4    0.19857E-04    0.10000E+01    0.39689E+04    0.16828E-39    0.78475E-47    0.40349E-43
+    4    4    0.19857E-04    0.10000E+01    0.32008E+04    0.37025E-37    0.32161E-44    0.90264E-41
+    4    4    0.19857E-04    0.10000E+01    0.25813E+04    0.13453E-28    0.21134E-35    0.33332E-32
+    4    4    0.19857E-04    0.10000E+01    0.20817E+04    0.14172E-12    0.38230E-19    0.34655E-16
+    4    4    0.19857E-04    0.10000E+01    0.16788E+04    0.31085E-07    0.21808E-13    0.73278E-11
+    4    4    0.19857E-04    0.10000E+01    0.13538E+04    0.37604E-07    0.68542E-13    0.87121E-11
+    4    4    0.19857E-04    0.10000E+01    0.10918E+04    0.46340E-07    0.22721E-12    0.10299E-10
+    4    4    0.19857E-04    0.10000E+01    0.88049E+03    0.58994E-07    0.77737E-12    0.12116E-10
+    4    4    0.19857E-04    0.10000E+01    0.71007E+03    0.78794E-07    0.27023E-11    0.14210E-10
+    4    4    0.19857E-04    0.10000E+01    0.57264E+03    0.11179E-06    0.93365E-11    0.16659E-10
+    4    4    0.19857E-04    0.10000E+01    0.46180E+03    0.16903E-06    0.30846E-10    0.19595E-10
+    4    4    0.19857E-04    0.10000E+01    0.37242E+03    0.26947E-06    0.93069E-10    0.23228E-10
+    4    4    0.19857E-04    0.10000E+01    0.30034E+03    0.44175E-06    0.24810E-09    0.27850E-10
+    4    4    0.19857E-04    0.10000E+01    0.24221E+03    0.72182E-06    0.57717E-09    0.33803E-10
+    4    4    0.19857E-04    0.10000E+01    0.19533E+03    0.10903E-05    0.10945E-08    0.40470E-10
+    4    4    0.19857E-04    0.10000E+01    0.15752E+03    0.10903E-05    0.10945E-08    0.40470E-10
+    4    4    0.34650E-04    0.10000E+01    0.80645E+05    0.19063E-51    0.14345E-62    0.42854E-55
+    4    4    0.34650E-04    0.10000E+01    0.65036E+05    0.16203E-50    0.22863E-61    0.36437E-54
+    4    4    0.34650E-04    0.10000E+01    0.52449E+05    0.13823E-49    0.30958E-60    0.31096E-53
+    4    4    0.34650E-04    0.10000E+01    0.42297E+05    0.10466E-48    0.42572E-59    0.23557E-52
+    4    4    0.34650E-04    0.10000E+01    0.34111E+05    0.76290E-48    0.59501E-58    0.17187E-51
+    4    4    0.34650E-04    0.10000E+01    0.27509E+05    0.55685E-47    0.82933E-57    0.12564E-50
+    4    4    0.34650E-04    0.10000E+01    0.22184E+05    0.40688E-46    0.11510E-55    0.92013E-50
+    4    4    0.34650E-04    0.10000E+01    0.17891E+05    0.29654E-45    0.15919E-54    0.67282E-49
+    4    4    0.34650E-04    0.10000E+01    0.14428E+05    0.21540E-44    0.21965E-53    0.49089E-48
+    4    4    0.34650E-04    0.10000E+01    0.11635E+05    0.15604E-43    0.30244E-52    0.35749E-47
+    4    4    0.34650E-04    0.10000E+01    0.93834E+04    0.11278E-42    0.41512E-51    0.25993E-46
+    4    4    0.34650E-04    0.10000E+01    0.75673E+04    0.81266E-42    0.56688E-50    0.18862E-45
+    4    4    0.34650E-04    0.10000E+01    0.61026E+04    0.58296E-41    0.76860E-49    0.13646E-44
+    4    4    0.34650E-04    0.10000E+01    0.49215E+04    0.41552E-40    0.10322E-47    0.98301E-44
+    4    4    0.34650E-04    0.10000E+01    0.39689E+04    0.29363E-39    0.13693E-46    0.70406E-43
+    4    4    0.34650E-04    0.10000E+01    0.32008E+04    0.64606E-37    0.56119E-44    0.15750E-40
+    4    4    0.34650E-04    0.10000E+01    0.25813E+04    0.23475E-28    0.36878E-35    0.58161E-32
+    4    4    0.34650E-04    0.10000E+01    0.20817E+04    0.24729E-12    0.66709E-19    0.60471E-16
+    4    4    0.34650E-04    0.10000E+01    0.16788E+04    0.54242E-07    0.38054E-13    0.12787E-10
+    4    4    0.34650E-04    0.10000E+01    0.13538E+04    0.65616E-07    0.11960E-12    0.15202E-10
+    4    4    0.34650E-04    0.10000E+01    0.10918E+04    0.80860E-07    0.39647E-12    0.17971E-10
+    4    4    0.34650E-04    0.10000E+01    0.88049E+03    0.10294E-06    0.13565E-11    0.21142E-10
+    4    4    0.34650E-04    0.10000E+01    0.71007E+03    0.13749E-06    0.47153E-11    0.24795E-10
+    4    4    0.34650E-04    0.10000E+01    0.57264E+03    0.19506E-06    0.16292E-10    0.29068E-10
+    4    4    0.34650E-04    0.10000E+01    0.46180E+03    0.29495E-06    0.53824E-10    0.34192E-10
+    4    4    0.34650E-04    0.10000E+01    0.37242E+03    0.47021E-06    0.16240E-09    0.40531E-10
+    4    4    0.34650E-04    0.10000E+01    0.30034E+03    0.77083E-06    0.43291E-09    0.48596E-10
+    4    4    0.34650E-04    0.10000E+01    0.24221E+03    0.12595E-05    0.10071E-08    0.58985E-10
+    4    4    0.34650E-04    0.10000E+01    0.19533E+03    0.19026E-05    0.19099E-08    0.70617E-10
+    4    4    0.34650E-04    0.10000E+01    0.15752E+03    0.19026E-05    0.19099E-08    0.70617E-10
+    4    4    0.60462E-04    0.10000E+01    0.80645E+05    0.33264E-51    0.25031E-62    0.74778E-55
+    4    4    0.60462E-04    0.10000E+01    0.65036E+05    0.28273E-50    0.39894E-61    0.63580E-54
+    4    4    0.60462E-04    0.10000E+01    0.52449E+05    0.24121E-49    0.54019E-60    0.54261E-53
+    4    4    0.60462E-04    0.10000E+01    0.42297E+05    0.18263E-48    0.74286E-59    0.41105E-52
+    4    4    0.60462E-04    0.10000E+01    0.34111E+05    0.13312E-47    0.10382E-57    0.29991E-51
+    4    4    0.60462E-04    0.10000E+01    0.27509E+05    0.97167E-47    0.14471E-56    0.21924E-50
+    4    4    0.60462E-04    0.10000E+01    0.22184E+05    0.70999E-46    0.20085E-55    0.16056E-49
+    4    4    0.60462E-04    0.10000E+01    0.17891E+05    0.51744E-45    0.27778E-54    0.11740E-48
+    4    4    0.60462E-04    0.10000E+01    0.14428E+05    0.37587E-44    0.38327E-53    0.85657E-48
+    4    4    0.60462E-04    0.10000E+01    0.11635E+05    0.27229E-43    0.52775E-52    0.62380E-47
+    4    4    0.60462E-04    0.10000E+01    0.93834E+04    0.19679E-42    0.72436E-51    0.45357E-46
+    4    4    0.60462E-04    0.10000E+01    0.75673E+04    0.14180E-41    0.98917E-50    0.32913E-45
+    4    4    0.60462E-04    0.10000E+01    0.61026E+04    0.10172E-40    0.13412E-48    0.23811E-44
+    4    4    0.60462E-04    0.10000E+01    0.49215E+04    0.72506E-40    0.18012E-47    0.17153E-43
+    4    4    0.60462E-04    0.10000E+01    0.39689E+04    0.51237E-39    0.23894E-46    0.12285E-42
+    4    4    0.60462E-04    0.10000E+01    0.32008E+04    0.11273E-36    0.97923E-44    0.27484E-40
+    4    4    0.60462E-04    0.10000E+01    0.25813E+04    0.40962E-28    0.64350E-35    0.10149E-31
+    4    4    0.60462E-04    0.10000E+01    0.20817E+04    0.43150E-12    0.11640E-18    0.10552E-15
+    4    4    0.60462E-04    0.10000E+01    0.16788E+04    0.94649E-07    0.66402E-13    0.22312E-10
+    4    4    0.60462E-04    0.10000E+01    0.13538E+04    0.11450E-06    0.20870E-12    0.26527E-10
+    4    4    0.60462E-04    0.10000E+01    0.10918E+04    0.14110E-06    0.69181E-12    0.31358E-10
+    4    4    0.60462E-04    0.10000E+01    0.88049E+03    0.17963E-06    0.23669E-11    0.36891E-10
+    4    4    0.60462E-04    0.10000E+01    0.71007E+03    0.23991E-06    0.82279E-11    0.43266E-10
+    4    4    0.60462E-04    0.10000E+01    0.57264E+03    0.34037E-06    0.28428E-10    0.50722E-10
+    4    4    0.60462E-04    0.10000E+01    0.46180E+03    0.51466E-06    0.93920E-10    0.59663E-10
+    4    4    0.60462E-04    0.10000E+01    0.37242E+03    0.82049E-06    0.28338E-09    0.70724E-10
+    4    4    0.60462E-04    0.10000E+01    0.30034E+03    0.13451E-05    0.75541E-09    0.84797E-10
+    4    4    0.60462E-04    0.10000E+01    0.24221E+03    0.21978E-05    0.17574E-08    0.10292E-09
+    4    4    0.60462E-04    0.10000E+01    0.19533E+03    0.33199E-05    0.33327E-08    0.12322E-09
+    4    4    0.60462E-04    0.10000E+01    0.15752E+03    0.33199E-05    0.33327E-08    0.12322E-09
+    4    4    0.10550E-03    0.10000E+01    0.80645E+05    0.58043E-51    0.43678E-62    0.13048E-54
+    4    4    0.10550E-03    0.10000E+01    0.65036E+05    0.49334E-50    0.69613E-61    0.11094E-53
+    4    4    0.10550E-03    0.10000E+01    0.52449E+05    0.42090E-49    0.94260E-60    0.94682E-53
+    4    4    0.10550E-03    0.10000E+01    0.42297E+05    0.31867E-48    0.12962E-58    0.71725E-52
+    4    4    0.10550E-03    0.10000E+01    0.34111E+05    0.23229E-47    0.18117E-57    0.52333E-51
+    4    4    0.10550E-03    0.10000E+01    0.27509E+05    0.16955E-46    0.25251E-56    0.38256E-50
+    4    4    0.10550E-03    0.10000E+01    0.22184E+05    0.12389E-45    0.35047E-55    0.28016E-49
+    4    4    0.10550E-03    0.10000E+01    0.17891E+05    0.90291E-45    0.48471E-54    0.20486E-48
+    4    4    0.10550E-03    0.10000E+01    0.14428E+05    0.65587E-44    0.66879E-53    0.14947E-47
+    4    4    0.10550E-03    0.10000E+01    0.11635E+05    0.47513E-43    0.92089E-52    0.10885E-46
+    4    4    0.10550E-03    0.10000E+01    0.93834E+04    0.34339E-42    0.12640E-50    0.79145E-46
+    4    4    0.10550E-03    0.10000E+01    0.75673E+04    0.24744E-41    0.17260E-49    0.57431E-45
+    4    4    0.10550E-03    0.10000E+01    0.61026E+04    0.17750E-40    0.23402E-48    0.41549E-44
+    4    4    0.10550E-03    0.10000E+01    0.49215E+04    0.12652E-39    0.31430E-47    0.29931E-43
+    4    4    0.10550E-03    0.10000E+01    0.39689E+04    0.89405E-39    0.41694E-46    0.21437E-42
+    4    4    0.10550E-03    0.10000E+01    0.32008E+04    0.19671E-36    0.17087E-43    0.47957E-40
+    4    4    0.10550E-03    0.10000E+01    0.25813E+04    0.71476E-28    0.11229E-34    0.17709E-31
+    4    4    0.10550E-03    0.10000E+01    0.20817E+04    0.75295E-12    0.20312E-18    0.18412E-15
+    4    4    0.10550E-03    0.10000E+01    0.16788E+04    0.16516E-06    0.11587E-12    0.38933E-10
+    4    4    0.10550E-03    0.10000E+01    0.13538E+04    0.19979E-06    0.36417E-12    0.46288E-10
+    4    4    0.10550E-03    0.10000E+01    0.10918E+04    0.24620E-06    0.12072E-11    0.54718E-10
+    4    4    0.10550E-03    0.10000E+01    0.88049E+03    0.31344E-06    0.41302E-11    0.64372E-10
+    4    4    0.10550E-03    0.10000E+01    0.71007E+03    0.41863E-06    0.14357E-10    0.75496E-10
+    4    4    0.10550E-03    0.10000E+01    0.57264E+03    0.59392E-06    0.49605E-10    0.88508E-10
+    4    4    0.10550E-03    0.10000E+01    0.46180E+03    0.89805E-06    0.16388E-09    0.10411E-09
+    4    4    0.10550E-03    0.10000E+01    0.37242E+03    0.14317E-05    0.49448E-09    0.12341E-09
+    4    4    0.10550E-03    0.10000E+01    0.30034E+03    0.23470E-05    0.13181E-08    0.14797E-09
+    4    4    0.10550E-03    0.10000E+01    0.24221E+03    0.38351E-05    0.30665E-08    0.17960E-09
+    4    4    0.10550E-03    0.10000E+01    0.19533E+03    0.57930E-05    0.58153E-08    0.21502E-09
+    4    4    0.10550E-03    0.10000E+01    0.15752E+03    0.57930E-05    0.58153E-08    0.21502E-09
+    4    4    0.18409E-03    0.10000E+01    0.80645E+05    0.10128E-50    0.76215E-62    0.22769E-54
+    4    4    0.18409E-03    0.10000E+01    0.65036E+05    0.86085E-50    0.12147E-60    0.19359E-53
+    4    4    0.18409E-03    0.10000E+01    0.52449E+05    0.73444E-49    0.16448E-59    0.16521E-52
+    4    4    0.18409E-03    0.10000E+01    0.42297E+05    0.55606E-48    0.22619E-58    0.12516E-51
+    4    4    0.18409E-03    0.10000E+01    0.34111E+05    0.40533E-47    0.31613E-57    0.91317E-51
+    4    4    0.18409E-03    0.10000E+01    0.27509E+05    0.29586E-46    0.44062E-56    0.66754E-50
+    4    4    0.18409E-03    0.10000E+01    0.22184E+05    0.21618E-45    0.61155E-55    0.48887E-49
+    4    4    0.18409E-03    0.10000E+01    0.17891E+05    0.15755E-44    0.84579E-54    0.35747E-48
+    4    4    0.18409E-03    0.10000E+01    0.14428E+05    0.11444E-43    0.11670E-52    0.26081E-47
+    4    4    0.18409E-03    0.10000E+01    0.11635E+05    0.82906E-43    0.16069E-51    0.18994E-46
+    4    4    0.18409E-03    0.10000E+01    0.93834E+04    0.59919E-42    0.22055E-50    0.13810E-45
+    4    4    0.18409E-03    0.10000E+01    0.75673E+04    0.43177E-41    0.30118E-49    0.10021E-44
+    4    4    0.18409E-03    0.10000E+01    0.61026E+04    0.30973E-40    0.40836E-48    0.72501E-44
+    4    4    0.18409E-03    0.10000E+01    0.49215E+04    0.22077E-39    0.54843E-47    0.52228E-43
+    4    4    0.18409E-03    0.10000E+01    0.39689E+04    0.15601E-38    0.72753E-46    0.37407E-42
+    4    4    0.18409E-03    0.10000E+01    0.32008E+04    0.34325E-36    0.29816E-43    0.83682E-40
+    4    4    0.18409E-03    0.10000E+01    0.25813E+04    0.12472E-27    0.19593E-34    0.30901E-31
+    4    4    0.18409E-03    0.10000E+01    0.20817E+04    0.13138E-11    0.35442E-18    0.32128E-15
+    4    4    0.18409E-03    0.10000E+01    0.16788E+04    0.28819E-06    0.20218E-12    0.67935E-10
+    4    4    0.18409E-03    0.10000E+01    0.13538E+04    0.34862E-06    0.63545E-12    0.80769E-10
+    4    4    0.18409E-03    0.10000E+01    0.10918E+04    0.42961E-06    0.21064E-11    0.95479E-10
+    4    4    0.18409E-03    0.10000E+01    0.88049E+03    0.54693E-06    0.72069E-11    0.11233E-09
+    4    4    0.18409E-03    0.10000E+01    0.71007E+03    0.73049E-06    0.25052E-10    0.13174E-09
+    4    4    0.18409E-03    0.10000E+01    0.57264E+03    0.10364E-05    0.86558E-10    0.15444E-09
+    4    4    0.18409E-03    0.10000E+01    0.46180E+03    0.15671E-05    0.28597E-09    0.18166E-09
+    4    4    0.18409E-03    0.10000E+01    0.37242E+03    0.24982E-05    0.86284E-09    0.21534E-09
+    4    4    0.18409E-03    0.10000E+01    0.30034E+03    0.40954E-05    0.23001E-08    0.25819E-09
+    4    4    0.18409E-03    0.10000E+01    0.24221E+03    0.66919E-05    0.53508E-08    0.31339E-09
+    4    4    0.18409E-03    0.10000E+01    0.19533E+03    0.10108E-04    0.10147E-07    0.37519E-09
+    4    4    0.18409E-03    0.10000E+01    0.15752E+03    0.10108E-04    0.10147E-07    0.37519E-09
+    4    4    0.32123E-03    0.10000E+01    0.80645E+05    0.17673E-50    0.13299E-61    0.39730E-54
+    4    4    0.32123E-03    0.10000E+01    0.65036E+05    0.15021E-49    0.21196E-60    0.33780E-53
+    4    4    0.32123E-03    0.10000E+01    0.52449E+05    0.12815E-48    0.28700E-59    0.28829E-52
+    4    4    0.32123E-03    0.10000E+01    0.42297E+05    0.97029E-48    0.39468E-58    0.21839E-51
+    4    4    0.32123E-03    0.10000E+01    0.34111E+05    0.70727E-47    0.55162E-57    0.15934E-50
+    4    4    0.32123E-03    0.10000E+01    0.27509E+05    0.51625E-46    0.76886E-56    0.11648E-49
+    4    4    0.32123E-03    0.10000E+01    0.22184E+05    0.37722E-45    0.10671E-54    0.85305E-49
+    4    4    0.32123E-03    0.10000E+01    0.17891E+05    0.27492E-44    0.14759E-53    0.62377E-48
+    4    4    0.32123E-03    0.10000E+01    0.14428E+05    0.19970E-43    0.20363E-52    0.45510E-47
+    4    4    0.32123E-03    0.10000E+01    0.11635E+05    0.14467E-42    0.28039E-51    0.33143E-46
+    4    4    0.32123E-03    0.10000E+01    0.93834E+04    0.10456E-41    0.38485E-50    0.24098E-45
+    4    4    0.32123E-03    0.10000E+01    0.75673E+04    0.75341E-41    0.52555E-49    0.17487E-44
+    4    4    0.32123E-03    0.10000E+01    0.61026E+04    0.54046E-40    0.71256E-48    0.12651E-43
+    4    4    0.32123E-03    0.10000E+01    0.49215E+04    0.38523E-39    0.95698E-47    0.91134E-43
+    4    4    0.32123E-03    0.10000E+01    0.39689E+04    0.27222E-38    0.12695E-45    0.65273E-42
+    4    4    0.32123E-03    0.10000E+01    0.32008E+04    0.59896E-36    0.52027E-43    0.14602E-39
+    4    4    0.32123E-03    0.10000E+01    0.25813E+04    0.21763E-27    0.34189E-34    0.53921E-31
+    4    4    0.32123E-03    0.10000E+01    0.20817E+04    0.22926E-11    0.61845E-18    0.56062E-15
+    4    4    0.32123E-03    0.10000E+01    0.16788E+04    0.50287E-06    0.35280E-12    0.11854E-09
+    4    4    0.32123E-03    0.10000E+01    0.13538E+04    0.60832E-06    0.11088E-11    0.14094E-09
+    4    4    0.32123E-03    0.10000E+01    0.10918E+04    0.74965E-06    0.36756E-11    0.16661E-09
+    4    4    0.32123E-03    0.10000E+01    0.88049E+03    0.95436E-06    0.12576E-10    0.19600E-09
+    4    4    0.32123E-03    0.10000E+01    0.71007E+03    0.12747E-05    0.43715E-10    0.22987E-09
+    4    4    0.32123E-03    0.10000E+01    0.57264E+03    0.18084E-05    0.15104E-09    0.26949E-09
+    4    4    0.32123E-03    0.10000E+01    0.46180E+03    0.27344E-05    0.49900E-09    0.31699E-09
+    4    4    0.32123E-03    0.10000E+01    0.37242E+03    0.43593E-05    0.15056E-08    0.37576E-09
+    4    4    0.32123E-03    0.10000E+01    0.30034E+03    0.71463E-05    0.40135E-08    0.45053E-09
+    4    4    0.32123E-03    0.10000E+01    0.24221E+03    0.11677E-04    0.93369E-08    0.54684E-09
+    4    4    0.32123E-03    0.10000E+01    0.19533E+03    0.17639E-04    0.17706E-07    0.65469E-09
+    4    4    0.32123E-03    0.10000E+01    0.15752E+03    0.17639E-04    0.17706E-07    0.65469E-09
+    5    1    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.45191E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    1    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.78855E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    1    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.13760E-07    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    1    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.24010E-07    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    5    1    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.41896E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    5    1    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.73106E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    5    1    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.12757E-06    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    5    1    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.57889E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.22259E-06    0.21932E+07    0.57448E-32    0.54879E-91    0.45338E-05    0.90000E+03
+    5    1    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.32748E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.38841E-06    0.18214E+07    0.17525E-31    0.31038E-75    0.54820E-05    0.90000E+03
+    5    1    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.26702E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.67776E-06    0.15145E+07    0.53194E-31    0.25298E-62    0.66021E-05    0.90000E+03
+    5    1    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.13893E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.11826E-05    0.12578E+07    0.16206E-30    0.13154E-51    0.79511E-05    0.90000E+03
+    5    1    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.90470E-45    0.67064E-05    0.42297E-05    0.37644E+02    0.20636E-05    0.10445E+07    0.49376E-30    0.85576E-43    0.95741E-05    0.90000E+03
+    5    1    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.15563E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.36009E-05    0.86742E+06    0.15043E-29    0.14702E-35    0.11528E-04    0.90000E+03
+    5    1    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.13147E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.62834E-05    0.72035E+06    0.45832E-29    0.12398E-29    0.13882E-04    0.90000E+03
+    5    1    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.91238E-27    0.11686E-04    0.73852E-05    0.20001E+03    0.10964E-04    0.59822E+06    0.13964E-28    0.85840E-25    0.16716E-04    0.90000E+03
+    5    1    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.79745E-23    0.14063E-04    0.88930E-05    0.34900E+03    0.19132E-04    0.49680E+06    0.42543E-28    0.74800E-21    0.20129E-04    0.90000E+03
+    5    1    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.12000E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.33384E-04    0.41311E+06    0.12910E-27    0.11212E-17    0.24207E-04    0.90000E+03
+    5    1    0.58864E-11    0.10000E+01    0.16087E-01    0.30719E-01    0.51398E-11    0.45877E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.58253E-04    0.34307E+06    0.39288E-27    0.42644E-15    0.29147E-04    0.89996E+03
+    5    1    0.10271E-10    0.10000E+01    0.22942E-01    0.43839E-01    0.84780E-11    0.54073E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.10165E-03    0.28490E+06    0.11866E-26    0.49924E-13    0.35071E-04    0.89947E+03
+    5    1    0.17923E-10    0.10000E+01    0.32889E-01    0.63727E-01    0.20398E-10    0.24695E-13    0.29494E-04    0.18794E-04    0.32355E+04    0.17737E-03    0.23629E+06    0.35027E-26    0.22596E-11    0.42127E-04    0.89631E+03
+    5    1    0.31275E-10    0.10000E+01    0.48387E-01    0.94693E-01    0.50540E-10    0.53957E-12    0.34961E-04    0.23129E-04    0.56458E+04    0.30950E-03    0.19496E+06    0.99447E-26    0.48760E-10    0.50499E-04    0.88379E+03
+    5    1    0.54572E-10    0.10000E+01    0.74090E-01    0.13935E+00    0.11222E-09    0.65380E-11    0.40383E-04    0.29228E-04    0.98516E+04    0.54006E-03    0.15940E+06    0.27009E-25    0.58026E-09    0.60483E-04    0.85041E+03
+    5    1    0.95225E-10    0.10000E+01    0.11736E+00    0.19749E+00    0.21140E-09    0.50996E-10    0.44004E-04    0.38038E-04    0.17190E+05    0.94236E-03    0.12765E+06    0.72480E-25    0.43989E-08    0.73406E-04    0.78192E+03
+    5    1    0.16616E-09    0.10000E+01    0.18179E+00    0.26431E+00    0.32753E-09    0.26583E-09    0.44528E-04    0.48903E-04    0.29996E+05    0.16444E-02    0.99467E+05    0.19955E-24    0.21856E-07    0.91697E-04    0.67141E+03
+    5    1    0.28994E-09    0.10000E+01    0.25961E+00    0.33496E+00    0.47703E-09    0.94192E-09    0.43515E-04    0.57767E-04    0.52341E+05    0.28693E-02    0.75619E+05    0.57623E-24    0.71447E-07    0.11865E-03    0.53386E+03
+    5    1    0.50593E-09    0.10000E+01    0.33900E+00    0.40891E+00    0.78184E-09    0.24625E-08    0.45608E-04    0.61912E-04    0.91333E+05    0.50068E-02    0.56747E+05    0.17224E-23    0.16529E-06    0.15713E-03    0.40140E+03
+    5    1    0.88282E-09    0.10000E+01    0.41762E+00    0.48781E+00    0.14159E-08    0.54449E-08    0.54182E-04    0.63271E-04    0.15937E+06    0.87366E-02    0.42418E+05    0.52150E-23    0.31202E-06    0.20988E-03    0.29419E+03
+    5    1    0.15405E-08    0.10000E+01    0.36333E+00    0.69413E+00    0.73763E-08    0.13444E-07    0.63796E-04    0.63687E-04    0.81842E+05    0.10022E-01    0.66266E+04    0.47987E-22    0.49383E-06    0.46540E-03    0.16320E+03
+    5    1    0.26880E-08    0.10000E+01    0.41493E+00    0.79920E+00    0.14413E-07    0.26952E-07    0.78612E-04    0.64477E-04    0.11884E+06    0.16326E-01    0.43556E+04    0.16801E-21    0.82043E-06    0.66658E-03    0.11507E+03
+    5    1    0.46905E-08    0.10000E+01    0.48925E+00    0.88639E+00    0.25829E-07    0.51969E-07    0.10150E-03    0.65033E-04    0.20736E+06    0.28487E-01    0.32516E+04    0.51055E-21    0.13585E-05    0.89233E-03    0.84398E+02
+    5    1    0.81846E-08    0.10000E+01    0.56673E+00    0.97193E+00    0.45706E-07    0.98963E-07    0.13297E-03    0.65496E-04    0.36184E+06    0.49709E-01    0.24275E+04    0.15520E-20    0.22272E-05    0.11950E-02    0.61636E+02
+    5    1    0.14282E-07    0.10000E+01    0.64674E+00    0.10550E+01    0.79653E-07    0.18646E-06    0.17564E-03    0.65920E-04    0.63138E+06    0.86738E-01    0.18098E+04    0.47302E-20    0.36228E-05    0.16025E-02    0.44825E+02
+    5    1    0.24920E-07    0.10000E+01    0.72758E+00    0.11339E+01    0.13744E-06    0.34778E-06    0.23364E-03    0.66323E-04    0.11017E+07    0.15135E+00    0.13511E+04    0.14383E-19    0.58583E-05    0.21465E-02    0.32588E+02
+    5    1    0.43485E-07    0.10000E+01    0.80896E+00    0.12086E+01    0.23376E-06    0.64324E-06    0.31151E-03    0.66721E-04    0.19224E+07    0.26410E+00    0.10073E+04    0.43840E-19    0.94208E-05    0.28789E-02    0.23633E+02
+    5    1    0.75878E-07    0.10000E+01    0.88920E+00    0.12781E+01    0.39425E-06    0.11802E-05    0.41669E-03    0.67115E-04    0.33546E+07    0.46084E+00    0.75202E+03    0.13322E-18    0.15088E-04    0.38558E-02    0.17152E+02
+    5    1    0.13240E-06    0.10000E+01    0.96812E+00    0.13425E+01    0.65574E-06    0.21493E-05    0.55729E-03    0.67510E-04    0.58535E+07    0.80414E+00    0.56068E+03    0.40205E-18    0.24049E-04    0.51577E-02    0.12434E+02
+    5    1    0.23103E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.15703E-05    0.38017E-05    0.87654E-03    0.67662E-04    0.10214E+08    0.14032E+01    0.50000E+03    0.86013E-18    0.40441E-04    0.57605E-02    0.10978E+02
+    5    1    0.40314E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.47812E-05    0.66338E-05    0.15295E-02    0.67662E-04    0.17823E+08    0.24485E+01    0.50000E+03    0.15009E-17    0.70568E-04    0.57605E-02    0.10978E+02
+    5    1    0.70346E-06    0.10000E+01    0.99828E+00    0.13659E+01    0.14558E-04    0.11576E-04    0.26689E-02    0.67662E-04    0.31100E+08    0.42724E+01    0.50000E+03    0.26189E-17    0.12314E-03    0.57605E-02    0.10978E+02
+    5    1    0.12275E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.44326E-04    0.20199E-04    0.46571E-02    0.67662E-04    0.54267E+08    0.74551E+01    0.50000E+03    0.45699E-17    0.21487E-03    0.57605E-02    0.10978E+02
+    5    1    0.21419E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.13496E-03    0.35246E-04    0.81263E-02    0.67662E-04    0.94693E+08    0.13009E+02    0.50000E+03    0.79742E-17    0.37493E-03    0.57605E-02    0.10978E+02
+    5    1    0.37375E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.41094E-03    0.61501E-04    0.14180E-01    0.67662E-04    0.16523E+09    0.22699E+02    0.50000E+03    0.13915E-16    0.65423E-03    0.57605E-02    0.10978E+02
+    5    1    0.65217E-05    0.10000E+01    0.99828E+00    0.13659E+01    0.12512E-02    0.10732E-03    0.24743E-01    0.67662E-04    0.28832E+09    0.39609E+02    0.50000E+03    0.24280E-16    0.11416E-02    0.57605E-02    0.10978E+02
+    5    1    0.11380E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.38098E-02    0.18726E-03    0.43175E-01    0.67662E-04    0.50310E+09    0.69116E+02    0.50000E+03    0.42367E-16    0.19920E-02    0.57605E-02    0.10978E+02
+    5    1    0.19857E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.11600E-01    0.32676E-03    0.75338E-01    0.67662E-04    0.87789E+09    0.12060E+03    0.50000E+03    0.73928E-16    0.34759E-02    0.57605E-02    0.10978E+02
+    5    1    0.34650E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.35320E-01    0.57017E-03    0.13146E+00    0.67662E-04    0.15319E+10    0.21044E+03    0.50000E+03    0.12900E-15    0.60653E-02    0.57605E-02    0.10978E+02
+    5    1    0.60462E-04    0.10000E+01    0.99828E+00    0.13659E+01    0.10754E+00    0.99492E-03    0.22939E+00    0.67662E-04    0.26730E+10    0.36721E+03    0.50000E+03    0.22510E-15    0.10583E-01    0.57605E-02    0.10978E+02
+    5    1    0.10550E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.32745E+00    0.17361E-02    0.40027E+00    0.67662E-04    0.46642E+10    0.64076E+03    0.50000E+03    0.39278E-15    0.18468E-01    0.57605E-02    0.10978E+02
+    5    1    0.18409E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.99703E+00    0.30293E-02    0.69845E+00    0.67662E-04    0.81388E+10    0.11181E+04    0.50000E+03    0.68538E-15    0.32225E-01    0.57605E-02    0.10978E+02
+    5    1    0.32123E-03    0.10000E+01    0.99828E+00    0.13659E+01    0.30358E+01    0.52860E-02    0.12188E+01    0.67662E-04    0.14202E+11    0.19510E+04    0.50000E+03    0.11959E-14    0.56230E-01    0.57605E-02    0.10978E+02
+    5    1    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    5    1    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    5    1    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    5    1    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    5    1    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    5    1    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    5    1    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    5    1    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    5    1    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    5    1    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    5    1    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    5    1    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    5    1    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    5    1    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    5    1    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    5    1    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    5    1    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    5    1    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    5    1    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    5    1    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    5    1    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    5    1    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    5    1    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    5    1    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    5    1    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    5    1    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    5    1    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    5    1    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    5    1    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    5    1    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    5    1    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    5    1    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    5    1    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    5    1    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    5    1    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    5    1    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    5    1    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    5    1    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    5    1    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    5    1    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    5    1    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    5    1    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    5    1    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    5    1    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    5    1    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    5    1    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    5    1    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    5    1    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    5    1    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    5    1    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    5    1    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    5    1    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    5    1    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    5    1    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    5    1    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    5    1    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    5    1    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    5    1    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    5    1    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    5    1    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    5    1    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    5    1    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    5    1    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    5    1    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    5    1    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    5    1    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    5    1    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    5    1    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    5    1    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    5    1    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    5    1    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    5    1    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    5    1    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    5    1    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    5    1    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    5    1    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    5    1    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    5    1    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    5    1    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    5    1    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    5    1    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    5    1    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    5    1    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    5    1    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    5    1    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    5    1    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    5    1    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    5    1    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    5    1    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    5    1    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    5    1    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    5    1    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    5    1    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    5    1    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    5    1    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    5    1    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    5    1    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    5    1    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    5    1    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    5    1    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    5    1    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    5    1    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    5    1    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    5    1    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    5    1    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    5    1    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    5    1    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    5    1    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    5    1    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    5    1    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    5    1    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    5    1    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    5    1    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    5    1    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    5    1    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    5    1    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    5    1    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    5    1    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    5    1    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    5    1    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    5    1    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    5    1    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    5    1    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    5    1    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    5    1    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    5    1    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    5    1    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    5    1    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    5    1    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    5    1    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    5    1    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    5    1    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    5    1    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    5    1    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    5    1    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    5    1    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    5    1    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    5    1    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    5    1    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    5    1    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    5    1    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    5    1    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    5    1    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    5    1    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    5    1    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    5    1    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    5    1    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    5    1    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    5    1    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    5    1    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    5    1    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    5    1    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    5    1    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    5    1    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    5    1    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    5    1    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    5    1    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    5    1    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    5    1    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    5    1    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    5    1    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    5    1    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    5    1    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    5    1    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    5    1    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    5    1    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    5    1    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    5    1    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    5    1    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    5    1    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    5    1    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    5    1    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    5    1    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    5    1    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    5    1    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    5    1    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    5    1    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    5    1    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    5    1    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    5    1    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    5    1    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    5    1    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    5    1    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    5    1    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    5    1    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    5    1    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    5    1    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    5    1    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    5    1    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    5    1    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    5    1    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    5    1    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    5    1    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    5    1    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    5    1    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    5    1    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    5    1    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    5    1    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    5    1    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    5    1    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    5    1    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    5    1    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    5    1    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    5    1    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    5    1    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    5    1    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    5    1    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    5    1    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    5    1    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    5    1    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    5    1    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    5    1    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    5    1    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    5    1    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    5    1    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    5    1    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    5    1    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    5    1    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    5    1    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    5    1    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    5    1    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    5    1    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    5    1    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    5    1    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    5    1    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    5    1    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    5    1    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    5    1    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    5    1    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    5    1    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    5    1    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    5    1    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    5    1    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    5    1    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    5    1    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    5    1    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    5    1    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    5    1    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    5    1    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    5    1    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    5    1    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    5    1    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    5    1    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    5    1    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    5    1    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    5    1    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    5    1    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    5    1    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    5    1    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    5    1    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    5    1    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    5    1    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    5    1    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    5    1    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    5    1    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    5    1    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    5    1    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    5    1    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    5    1    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    5    1    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    5    1    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    5    1    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    5    1    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    5    1    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    5    1    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    5    1    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    5    1    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    5    1    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    5    1    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    5    1    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    5    1    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    5    1    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    5    1    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    5    1    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    5    1    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    5    1    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    5    1    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    5    1    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    5    1    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    5    1    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    5    1    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    5    1    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    5    1    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    5    1    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    5    1    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    5    1    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    5    1    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    5    1    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    5    1    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    5    1    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    5    1    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    5    1    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    5    1    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    5    1    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    5    1    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    5    1    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    5    1    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    5    1    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    5    1    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    5    1    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    5    1    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    5    1    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    5    1    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    5    1    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    5    1    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    5    1    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    5    1    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    5    1    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    5    1    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    5    1    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    5    1    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    5    1    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    5    1    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    5    1    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    5    1    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    5    1    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    5    1    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    5    1    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    5    1    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    5    1    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    5    1    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    5    1    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    5    1    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    5    1    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    5    1    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    5    1    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    5    1    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    5    1    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    5    1    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    5    1    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    5    1    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    5    1    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    5    1    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    5    1    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    5    1    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    5    1    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    5    1    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    5    1    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    5    1    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    5    1    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    5    1    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    5    1    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    5    1    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    5    1    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    5    1    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    5    1    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    5    1    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    5    1    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    5    1    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    5    1    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    5    1    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    5    1    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    5    1    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    5    1    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    5    1    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    5    1    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    5    1    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    5    1    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    5    1    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    5    1    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    5    1    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    5    1    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    5    1    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    5    1    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    5    1    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    5    1    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    5    1    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    5    1    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    5    1    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    5    1    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    5    1    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    5    1    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    5    1    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    5    1    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    5    1    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    5    1    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    5    1    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    5    1    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    5    1    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    5    1    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    5    1    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    5    1    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    5    1    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    5    1    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    5    1    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    5    1    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    5    1    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    5    1    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    5    1    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    5    1    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    5    1    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    5    1    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    5    1    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    5    1    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    5    1    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    5    1    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    5    1    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    5    1    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    5    1    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    5    1    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    5    1    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    5    1    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    5    1    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    5    1    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    5    1    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    5    1    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    5    1    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    5    1    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    5    1    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    5    1    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    5    1    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    5    1    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    5    1    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    5    1    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    5    1    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    5    1    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    5    1    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    5    1    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    5    1    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    5    1    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    5    1    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    5    1    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    5    1    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    5    1    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    5    1    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    5    1    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    5    1    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    5    1    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    5    1    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    5    1    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    5    1    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    5    1    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    5    1    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    5    1    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    5    1    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    5    1    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    5    1    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    5    1    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    5    1    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    5    1    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    5    1    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    5    1    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    5    1    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    5    1    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    5    1    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    5    1    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    5    1    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    5    1    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    5    1    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    5    1    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    5    1    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    5    1    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    5    1    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    5    1    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    5    1    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    5    1    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    5    1    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    5    1    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    5    1    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    5    1    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    5    1    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    5    1    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    5    1    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    5    1    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    5    1    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    5    1    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    5    1    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    5    1    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    5    1    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    5    1    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    5    1    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    5    1    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    5    1    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    5    1    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    5    1    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    5    1    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    5    1    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    5    1    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    5    1    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    5    1    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    5    1    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    5    1    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    5    1    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    5    1    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    5    1    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    5    1    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    5    1    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    5    1    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    5    1    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    5    1    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    5    1    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    5    1    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    5    1    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    5    1    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    5    1    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    5    1    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    5    1    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    5    1    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    5    1    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    5    1    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    5    1    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    5    1    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    5    1    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    5    1    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    5    1    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    5    1    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    5    1    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    5    1    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    5    1    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    5    1    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    5    1    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    5    1    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    5    1    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24433E-67
+    5    1    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40734E-66
+    5    1    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    5    1    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    5    1    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    5    1    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    5    1    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    5    1    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    5    1    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    5    1    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    5    1    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    5    1    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    5    1    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    5    1    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    5    1    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    5    1    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    5    1    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    5    1    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    5    1    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23278E-12    0.48928E-19
+    5    1    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    5    1    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    5    1    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    5    1    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    5    1    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    5    1    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    5    1    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71311E-09    0.48594E-17
+    5    1    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    5    1    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    5    1    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21428E-69    0.92887E-69
+    5    1    0.10271E-10    0.10000E+01    0.65036E+05    0.25728E-57    0.63708E-68    0.74355E-68
+    5    1    0.10271E-10    0.10000E+01    0.52449E+05    0.37513E-56    0.22054E-66    0.73137E-67
+    5    1    0.10271E-10    0.10000E+01    0.42297E+05    0.66185E-55    0.77499E-65    0.87548E-66
+    5    1    0.10271E-10    0.10000E+01    0.34111E+05    0.12106E-53    0.26796E-63    0.13788E-64
+    5    1    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89974E-62    0.24580E-63
+    5    1    0.10271E-10    0.10000E+01    0.22184E+05    0.38374E-51    0.28684E-60    0.43685E-62
+    5    1    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73547E-61
+    5    1    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11535E-59
+    5    1    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17062E-58
+    5    1    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24418E-57
+    5    1    0.10271E-10    0.10000E+01    0.75673E+04    0.29667E-45    0.46498E-53    0.34503E-56
+    5    1    0.10271E-10    0.10000E+01    0.61026E+04    0.41738E-44    0.12464E-51    0.48594E-55
+    5    1    0.10271E-10    0.10000E+01    0.49215E+04    0.58687E-43    0.33415E-50    0.68408E-54
+    5    1    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89577E-49    0.96299E-53
+    5    1    0.10271E-10    0.10000E+01    0.32008E+04    0.36488E-39    0.77647E-46    0.42631E-50
+    5    1    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31229E-41
+    5    1    0.10271E-10    0.10000E+01    0.20817E+04    0.50711E-14    0.11035E-19    0.59395E-25
+    5    1    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20067E-19
+    5    1    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    5    1    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90440E-19
+    5    1    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    5    1    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    5    1    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    5    1    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36995E-10    0.14467E-17
+    5    1    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27611E-17
+    5    1    0.10271E-10    0.10000E+01    0.30034E+03    0.43465E-06    0.30256E-09    0.50997E-17
+    5    1    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    5    1    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    5    1    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    5    1    0.17923E-10    0.10000E+01    0.80645E+05    0.56932E-58    0.39458E-69    0.34053E-68
+    5    1    0.17923E-10    0.10000E+01    0.65036E+05    0.46737E-57    0.87605E-68    0.28311E-67
+    5    1    0.17923E-10    0.10000E+01    0.52449E+05    0.52531E-56    0.24093E-66    0.24726E-66
+    5    1    0.17923E-10    0.10000E+01    0.42297E+05    0.74528E-55    0.80037E-65    0.22169E-65
+    5    1    0.17923E-10    0.10000E+01    0.34111E+05    0.12655E-53    0.27754E-63    0.26477E-64
+    5    1    0.17923E-10    0.10000E+01    0.27509E+05    0.22720E-52    0.94018E-62    0.41871E-63
+    5    1    0.17923E-10    0.10000E+01    0.22184E+05    0.40096E-51    0.30151E-60    0.72571E-62
+    5    1    0.17923E-10    0.10000E+01    0.17891E+05    0.67123E-50    0.89765E-59    0.12275E-60
+    5    1    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25129E-57    0.19418E-59
+    5    1    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68183E-56    0.28902E-58
+    5    1    0.17923E-10    0.10000E+01    0.93834E+04    0.22184E-46    0.18320E-54    0.41538E-57
+    5    1    0.17923E-10    0.10000E+01    0.75673E+04    0.31333E-45    0.49140E-53    0.58878E-56
+    5    1    0.17923E-10    0.10000E+01    0.61026E+04    0.44108E-44    0.13181E-51    0.83140E-55
+    5    1    0.17923E-10    0.10000E+01    0.49215E+04    0.62059E-43    0.35359E-50    0.11730E-53
+    5    1    0.17923E-10    0.10000E+01    0.39689E+04    0.87314E-42    0.94846E-49    0.16546E-52
+    5    1    0.17923E-10    0.10000E+01    0.32008E+04    0.38633E-39    0.82262E-46    0.73372E-50
+    5    1    0.17923E-10    0.10000E+01    0.25813E+04    0.28285E-30    0.13807E-36    0.53834E-41
+    5    1    0.17923E-10    0.10000E+01    0.20817E+04    0.53763E-14    0.11706E-19    0.10256E-24
+    5    1    0.17923E-10    0.10000E+01    0.16788E+04    0.18158E-08    0.17281E-13    0.34689E-19
+    5    1    0.17923E-10    0.10000E+01    0.13538E+04    0.38974E-08    0.65632E-13    0.74495E-19
+    5    1    0.17923E-10    0.10000E+01    0.10918E+04    0.81815E-08    0.24471E-12    0.15644E-18
+    5    1    0.17923E-10    0.10000E+01    0.88049E+03    0.16810E-07    0.90096E-12    0.32151E-18
+    5    1    0.17923E-10    0.10000E+01    0.71007E+03    0.33875E-07    0.32808E-11    0.64802E-18
+    5    1    0.17923E-10    0.10000E+01    0.57264E+03    0.67124E-07    0.11672E-10    0.12842E-17
+    5    1    0.17923E-10    0.10000E+01    0.46180E+03    0.13085E-06    0.39259E-10    0.25037E-17
+    5    1    0.17923E-10    0.10000E+01    0.37242E+03    0.24973E-06    0.11971E-09    0.47785E-17
+    5    1    0.17923E-10    0.10000E+01    0.30034E+03    0.46124E-06    0.32108E-09    0.88259E-17
+    5    1    0.17923E-10    0.10000E+01    0.24221E+03    0.81260E-06    0.74969E-09    0.15550E-16
+    5    1    0.17923E-10    0.10000E+01    0.19533E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    5    1    0.17923E-10    0.10000E+01    0.15752E+03    0.12807E-05    0.14247E-08    0.24506E-16
+    5    1    0.31275E-10    0.10000E+01    0.80645E+05    0.12244E-57    0.88088E-69    0.11447E-67
+    5    1    0.31275E-10    0.10000E+01    0.65036E+05    0.10138E-56    0.15653E-67    0.98306E-67
+    5    1    0.31275E-10    0.10000E+01    0.52449E+05    0.94832E-56    0.30734E-66    0.84200E-66
+    5    1    0.31275E-10    0.10000E+01    0.42297E+05    0.99586E-55    0.85109E-65    0.66901E-65
+    5    1    0.31275E-10    0.10000E+01    0.34111E+05    0.13837E-53    0.28099E-63    0.61269E-64
+    5    1    0.31275E-10    0.10000E+01    0.27509E+05    0.23221E-52    0.94803E-62    0.75391E-63
+    5    1    0.31275E-10    0.10000E+01    0.22184E+05    0.40543E-51    0.30614E-60    0.11740E-61
+    5    1    0.31275E-10    0.10000E+01    0.17891E+05    0.68167E-50    0.91704E-59    0.19605E-60
+    5    1    0.31275E-10    0.10000E+01    0.14428E+05    0.10719E-48    0.25765E-57    0.31437E-59
+    5    1    0.31275E-10    0.10000E+01    0.11635E+05    0.15895E-47    0.70063E-56    0.47455E-58
+    5    1    0.31275E-10    0.10000E+01    0.93834E+04    0.22791E-46    0.18858E-54    0.68923E-57
+    5    1    0.31275E-10    0.10000E+01    0.75673E+04    0.32249E-45    0.50662E-53    0.98467E-56
+    5    1    0.31275E-10    0.10000E+01    0.61026E+04    0.45470E-44    0.13609E-51    0.13990E-54
+    5    1    0.31275E-10    0.10000E+01    0.49215E+04    0.64067E-43    0.36553E-50    0.19838E-53
+    5    1    0.31275E-10    0.10000E+01    0.39689E+04    0.90254E-42    0.98159E-49    0.28095E-52
+    5    1    0.31275E-10    0.10000E+01    0.32008E+04    0.39980E-39    0.85221E-46    0.12501E-49
+    5    1    0.31275E-10    0.10000E+01    0.25813E+04    0.29303E-30    0.14319E-36    0.91997E-41
+    5    1    0.31275E-10    0.10000E+01    0.20817E+04    0.55763E-14    0.12154E-19    0.17582E-24
+    5    1    0.31275E-10    0.10000E+01    0.16788E+04    0.18847E-08    0.17949E-13    0.59582E-19
+    5    1    0.31275E-10    0.10000E+01    0.13538E+04    0.40465E-08    0.68178E-13    0.12804E-18
+    5    1    0.31275E-10    0.10000E+01    0.10918E+04    0.84960E-08    0.25421E-12    0.26901E-18
+    5    1    0.31275E-10    0.10000E+01    0.88049E+03    0.17458E-07    0.93596E-12    0.55306E-18
+    5    1    0.31275E-10    0.10000E+01    0.71007E+03    0.35185E-07    0.34083E-11    0.11150E-17
+    5    1    0.31275E-10    0.10000E+01    0.57264E+03    0.69724E-07    0.12126E-10    0.22100E-17
+    5    1    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43091E-17
+    5    1    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82249E-17
+    5    1    0.31275E-10    0.10000E+01    0.30034E+03    0.47915E-06    0.33355E-09    0.15192E-16
+    5    1    0.31275E-10    0.10000E+01    0.24221E+03    0.84416E-06    0.77882E-09    0.26766E-16
+    5    1    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    5    1    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42184E-16
+    5    1    0.54572E-10    0.10000E+01    0.80645E+05    0.25889E-57    0.19493E-68    0.35525E-67
+    5    1    0.54572E-10    0.10000E+01    0.65036E+05    0.22050E-56    0.31827E-67    0.31050E-66
+    5    1    0.54572E-10    0.10000E+01    0.52449E+05    0.19286E-55    0.49297E-66    0.26759E-65
+    5    1    0.54572E-10    0.10000E+01    0.42297E+05    0.16495E-54    0.10221E-64    0.20665E-64
+    5    1    0.54572E-10    0.10000E+01    0.34111E+05    0.17303E-53    0.28435E-63    0.16349E-63
+    5    1    0.54572E-10    0.10000E+01    0.27509E+05    0.24081E-52    0.91026E-62    0.15327E-62
+    5    1    0.54572E-10    0.10000E+01    0.22184E+05    0.39363E-51    0.29455E-60    0.19332E-61
+    5    1    0.54572E-10    0.10000E+01    0.17891E+05    0.65781E-50    0.89331E-59    0.30486E-60
+    5    1    0.54572E-10    0.10000E+01    0.14428E+05    0.10439E-48    0.25340E-57    0.49479E-59
+    5    1    0.54572E-10    0.10000E+01    0.11635E+05    0.15621E-47    0.69359E-56    0.76348E-58
+    5    1    0.54572E-10    0.10000E+01    0.93834E+04    0.22548E-46    0.18760E-54    0.11288E-56
+    5    1    0.54572E-10    0.10000E+01    0.75673E+04    0.32068E-45    0.50599E-53    0.16341E-55
+    5    1    0.54572E-10    0.10000E+01    0.61026E+04    0.45399E-44    0.13637E-51    0.23452E-54
+    5    1    0.54572E-10    0.10000E+01    0.49215E+04    0.64183E-43    0.36731E-50    0.33513E-53
+    5    1    0.54572E-10    0.10000E+01    0.39689E+04    0.90673E-42    0.98864E-49    0.47754E-52
+    5    1    0.54572E-10    0.10000E+01    0.32008E+04    0.40261E-39    0.86007E-46    0.21355E-49
+    5    1    0.54572E-10    0.10000E+01    0.25813E+04    0.29573E-30    0.14480E-36    0.15784E-40
+    5    1    0.54572E-10    0.10000E+01    0.20817E+04    0.56406E-14    0.12317E-19    0.30298E-24
+    5    1    0.54572E-10    0.10000E+01    0.16788E+04    0.19092E-08    0.18207E-13    0.10296E-18
+    5    1    0.54572E-10    0.10000E+01    0.13538E+04    0.41010E-08    0.69165E-13    0.22146E-18
+    5    1    0.54572E-10    0.10000E+01    0.10918E+04    0.86136E-08    0.25791E-12    0.46561E-18
+    5    1    0.54572E-10    0.10000E+01    0.88049E+03    0.17705E-07    0.94962E-12    0.95771E-18
+    5    1    0.54572E-10    0.10000E+01    0.71007E+03    0.35688E-07    0.34580E-11    0.19315E-17
+    5    1    0.54572E-10    0.10000E+01    0.57264E+03    0.70729E-07    0.12303E-10    0.38292E-17
+    5    1    0.54572E-10    0.10000E+01    0.46180E+03    0.13790E-06    0.41380E-10    0.74672E-17
+    5    1    0.54572E-10    0.10000E+01    0.37242E+03    0.26320E-06    0.12618E-09    0.14254E-16
+    5    1    0.54572E-10    0.10000E+01    0.30034E+03    0.48613E-06    0.33843E-09    0.26330E-16
+    5    1    0.54572E-10    0.10000E+01    0.24221E+03    0.85648E-06    0.79020E-09    0.46390E-16
+    5    1    0.54572E-10    0.10000E+01    0.19533E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    5    1    0.54572E-10    0.10000E+01    0.15752E+03    0.13498E-05    0.15016E-08    0.73114E-16
+    5    1    0.95225E-10    0.10000E+01    0.80645E+05    0.53338E-57    0.41251E-68    0.10749E-66
+    5    1    0.95225E-10    0.10000E+01    0.65036E+05    0.46320E-56    0.66241E-67    0.94141E-66
+    5    1    0.95225E-10    0.10000E+01    0.52449E+05    0.40024E-55    0.93503E-66    0.81416E-65
+    5    1    0.95225E-10    0.10000E+01    0.42297E+05    0.31521E-54    0.15121E-64    0.62477E-64
+    5    1    0.95225E-10    0.10000E+01    0.34111E+05    0.26479E-53    0.31103E-63    0.46450E-63
+    5    1    0.95225E-10    0.10000E+01    0.27509E+05    0.27530E-52    0.84266E-62    0.36185E-62
+    5    1    0.95225E-10    0.10000E+01    0.22184E+05    0.37547E-51    0.26561E-60    0.35004E-61
+    5    1    0.95225E-10    0.10000E+01    0.17891E+05    0.59959E-50    0.82078E-59    0.47852E-60
+    5    1    0.95225E-10    0.10000E+01    0.14428E+05    0.96029E-49    0.23747E-57    0.76675E-59
+    5    1    0.95225E-10    0.10000E+01    0.11635E+05    0.14620E-47    0.65938E-56    0.12102E-57
+    5    1    0.95225E-10    0.10000E+01    0.93834E+04    0.21410E-46    0.18023E-54    0.18298E-56
+    5    1    0.95225E-10    0.10000E+01    0.75673E+04    0.30781E-45    0.49011E-53    0.26942E-55
+    5    1    0.95225E-10    0.10000E+01    0.61026E+04    0.43943E-44    0.13295E-51    0.39150E-54
+    5    1    0.95225E-10    0.10000E+01    0.49215E+04    0.62538E-43    0.35997E-50    0.56476E-53
+    5    1    0.95225E-10    0.10000E+01    0.39689E+04    0.88822E-42    0.97300E-49    0.81063E-52
+    5    1    0.95225E-10    0.10000E+01    0.32008E+04    0.39613E-39    0.84952E-46    0.36461E-49
+    5    1    0.95225E-10    0.10000E+01    0.25813E+04    0.29211E-30    0.14353E-36    0.27085E-40
+    5    1    0.95225E-10    0.10000E+01    0.20817E+04    0.55938E-14    0.12256E-19    0.52257E-24
+    5    1    0.95225E-10    0.10000E+01    0.16788E+04    0.18980E-08    0.18143E-13    0.17813E-18
+    5    1    0.95225E-10    0.10000E+01    0.13538E+04    0.40806E-08    0.68940E-13    0.38357E-18
+    5    1    0.95225E-10    0.10000E+01    0.10918E+04    0.85761E-08    0.25711E-12    0.80708E-18
+    5    1    0.95225E-10    0.10000E+01    0.88049E+03    0.17636E-07    0.94670E-12    0.16610E-17
+    5    1    0.95225E-10    0.10000E+01    0.71007E+03    0.35560E-07    0.34475E-11    0.33511E-17
+    5    1    0.95225E-10    0.10000E+01    0.57264E+03    0.70490E-07    0.12266E-10    0.66454E-17
+    5    1    0.95225E-10    0.10000E+01    0.46180E+03    0.13745E-06    0.41255E-10    0.12961E-16
+    5    1    0.95225E-10    0.10000E+01    0.37242E+03    0.26237E-06    0.12579E-09    0.24744E-16
+    5    1    0.95225E-10    0.10000E+01    0.30034E+03    0.48462E-06    0.33740E-09    0.45710E-16
+    5    1    0.95225E-10    0.10000E+01    0.24221E+03    0.85384E-06    0.78780E-09    0.80539E-16
+    5    1    0.95225E-10    0.10000E+01    0.19533E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    5    1    0.95225E-10    0.10000E+01    0.15752E+03    0.13457E-05    0.14971E-08    0.12694E-15
+    5    1    0.16616E-09    0.10000E+01    0.80645E+05    0.10831E-56    0.84134E-68    0.33649E-66
+    5    1    0.16616E-09    0.10000E+01    0.65036E+05    0.94382E-56    0.13505E-66    0.29209E-65
+    5    1    0.16616E-09    0.10000E+01    0.52449E+05    0.81476E-55    0.18599E-65    0.25174E-64
+    5    1    0.16616E-09    0.10000E+01    0.42297E+05    0.62646E-54    0.26584E-64    0.19203E-63
+    5    1    0.16616E-09    0.10000E+01    0.34111E+05    0.47293E-53    0.41443E-63    0.13945E-62
+    5    1    0.16616E-09    0.10000E+01    0.27509E+05    0.38376E-52    0.82703E-62    0.99836E-62
+    5    1    0.16616E-09    0.10000E+01    0.22184E+05    0.38951E-51    0.23108E-60    0.77606E-61
+    5    1    0.16616E-09    0.10000E+01    0.17891E+05    0.53703E-50    0.71872E-59    0.82846E-60
+    5    1    0.16616E-09    0.10000E+01    0.14428E+05    0.84667E-49    0.21403E-57    0.12129E-58
+    5    1    0.16616E-09    0.10000E+01    0.11635E+05    0.13169E-47    0.60847E-56    0.19194E-57
+    5    1    0.16616E-09    0.10000E+01    0.93834E+04    0.19721E-46    0.16918E-54    0.29611E-56
+    5    1    0.16616E-09    0.10000E+01    0.75673E+04    0.28850E-45    0.46590E-53    0.44363E-55
+    5    1    0.16616E-09    0.10000E+01    0.61026E+04    0.41726E-44    0.12762E-51    0.65289E-54
+    5    1    0.16616E-09    0.10000E+01    0.49215E+04    0.59980E-43    0.34818E-50    0.95065E-53
+    5    1    0.16616E-09    0.10000E+01    0.39689E+04    0.85857E-42    0.94687E-49    0.13742E-51
+    5    1    0.16616E-09    0.10000E+01    0.32008E+04    0.38534E-39    0.83094E-46    0.62162E-49
+    5    1    0.16616E-09    0.10000E+01    0.25813E+04    0.28572E-30    0.14110E-36    0.46404E-40
+    5    1    0.16616E-09    0.10000E+01    0.20817E+04    0.55023E-14    0.12112E-19    0.89981E-24
+    5    1    0.16616E-09    0.10000E+01    0.16788E+04    0.18735E-08    0.17967E-13    0.30768E-18
+    5    1    0.16616E-09    0.10000E+01    0.13538E+04    0.40327E-08    0.68292E-13    0.66322E-18
+    5    1    0.16616E-09    0.10000E+01    0.10918E+04    0.84828E-08    0.25473E-12    0.13965E-17
+    5    1    0.16616E-09    0.10000E+01    0.88049E+03    0.17454E-07    0.93805E-12    0.28757E-17
+    5    1    0.16616E-09    0.10000E+01    0.71007E+03    0.35210E-07    0.34161E-11    0.58040E-17
+    5    1    0.16616E-09    0.10000E+01    0.57264E+03    0.69816E-07    0.12154E-10    0.11512E-16
+    5    1    0.16616E-09    0.10000E+01    0.46180E+03    0.13616E-06    0.40880E-10    0.22458E-16
+    5    1    0.16616E-09    0.10000E+01    0.37242E+03    0.25994E-06    0.12465E-09    0.42878E-16
+    5    1    0.16616E-09    0.10000E+01    0.30034E+03    0.48017E-06    0.33433E-09    0.79212E-16
+    5    1    0.16616E-09    0.10000E+01    0.24221E+03    0.84602E-06    0.78064E-09    0.13957E-15
+    5    1    0.16616E-09    0.10000E+01    0.19533E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    5    1    0.16616E-09    0.10000E+01    0.15752E+03    0.13334E-05    0.14835E-08    0.21998E-15
+    5    1    0.28994E-09    0.10000E+01    0.80645E+05    0.22011E-56    0.16920E-67    0.11249E-65
+    5    1    0.28994E-09    0.10000E+01    0.65036E+05    0.19023E-55    0.27099E-66    0.96503E-65
+    5    1    0.28994E-09    0.10000E+01    0.52449E+05    0.16355E-54    0.36930E-65    0.82631E-64
+    5    1    0.28994E-09    0.10000E+01    0.42297E+05    0.12449E-53    0.50576E-64    0.62542E-63
+    5    1    0.28994E-09    0.10000E+01    0.34111E+05    0.90534E-53    0.69149E-63    0.44950E-62
+    5    1    0.28994E-09    0.10000E+01    0.27509E+05    0.65403E-52    0.10276E-61    0.31368E-61
+    5    1    0.28994E-09    0.10000E+01    0.22184E+05    0.51145E-51    0.21678E-60    0.21734E-60
+    5    1    0.28994E-09    0.10000E+01    0.17891E+05    0.53350E-50    0.62717E-59    0.17681E-59
+    5    1    0.28994E-09    0.10000E+01    0.14428E+05    0.75573E-49    0.19028E-57    0.20765E-58
+    5    1    0.28994E-09    0.10000E+01    0.11635E+05    0.11751E-47    0.55601E-56    0.31026E-57
+    5    1    0.28994E-09    0.10000E+01    0.93834E+04    0.17997E-46    0.15781E-54    0.48192E-56
+    5    1    0.28994E-09    0.10000E+01    0.75673E+04    0.26865E-45    0.44099E-53    0.73307E-55
+    5    1    0.28994E-09    0.10000E+01    0.61026E+04    0.39444E-44    0.12210E-51    0.10917E-53
+    5    1    0.28994E-09    0.10000E+01    0.49215E+04    0.57333E-43    0.33588E-50    0.16029E-52
+    5    1    0.28994E-09    0.10000E+01    0.39689E+04    0.82768E-42    0.91939E-49    0.23314E-51
+    5    1    0.28994E-09    0.10000E+01    0.32008E+04    0.37400E-39    0.81127E-46    0.10597E-48
+    5    1    0.28994E-09    0.10000E+01    0.25813E+04    0.27896E-30    0.13850E-36    0.79454E-40
+    5    1    0.28994E-09    0.10000E+01    0.20817E+04    0.54048E-14    0.11957E-19    0.15478E-23
+    5    1    0.28994E-09    0.10000E+01    0.16788E+04    0.18472E-08    0.17777E-13    0.53075E-18
+    5    1    0.28994E-09    0.10000E+01    0.13538E+04    0.39812E-08    0.67591E-13    0.11451E-17
+    5    1    0.28994E-09    0.10000E+01    0.10918E+04    0.83822E-08    0.25216E-12    0.24130E-17
+    5    1    0.28994E-09    0.10000E+01    0.88049E+03    0.17259E-07    0.92865E-12    0.49712E-17
+    5    1    0.28994E-09    0.10000E+01    0.71007E+03    0.34831E-07    0.33820E-11    0.10037E-16
+    5    1    0.28994E-09    0.10000E+01    0.57264E+03    0.69086E-07    0.12033E-10    0.19913E-16
+    5    1    0.28994E-09    0.10000E+01    0.46180E+03    0.13476E-06    0.40472E-10    0.38849E-16
+    5    1    0.28994E-09    0.10000E+01    0.37242E+03    0.25730E-06    0.12341E-09    0.74180E-16
+    5    1    0.28994E-09    0.10000E+01    0.30034E+03    0.47533E-06    0.33100E-09    0.13705E-15
+    5    1    0.28994E-09    0.10000E+01    0.24221E+03    0.83753E-06    0.77285E-09    0.24148E-15
+    5    1    0.28994E-09    0.10000E+01    0.19533E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    5    1    0.28994E-09    0.10000E+01    0.15752E+03    0.13200E-05    0.14687E-08    0.38061E-15
+    5    1    0.50593E-09    0.10000E+01    0.80645E+05    0.44926E-56    0.34079E-67    0.39232E-65
+    5    1    0.50593E-09    0.10000E+01    0.65036E+05    0.38422E-55    0.54341E-66    0.33355E-64
+    5    1    0.50593E-09    0.10000E+01    0.52449E+05    0.32834E-54    0.73364E-65    0.28402E-63
+    5    1    0.50593E-09    0.10000E+01    0.42297E+05    0.24795E-53    0.99037E-64    0.21350E-62
+    5    1    0.50593E-09    0.10000E+01    0.34111E+05    0.17797E-52    0.13099E-62    0.15247E-61
+    5    1    0.50593E-09    0.10000E+01    0.27509E+05    0.12441E-51    0.16902E-61    0.10586E-60
+    5    1    0.50593E-09    0.10000E+01    0.22184E+05    0.86010E-51    0.25710E-60    0.70603E-60
+    5    1    0.50593E-09    0.10000E+01    0.17891E+05    0.67638E-50    0.58946E-59    0.47985E-59
+    5    1    0.50593E-09    0.10000E+01    0.14428E+05    0.74782E-49    0.17213E-57    0.41577E-58
+    5    1    0.50593E-09    0.10000E+01    0.11635E+05    0.10801E-47    0.51285E-56    0.52474E-57
+    5    1    0.50593E-09    0.10000E+01    0.93834E+04    0.16626E-46    0.14855E-54    0.79304E-56
+    5    1    0.50593E-09    0.10000E+01    0.75673E+04    0.25254E-45    0.42087E-53    0.12189E-54
+    5    1    0.50593E-09    0.10000E+01    0.61026E+04    0.37597E-44    0.11762E-51    0.18356E-53
+    5    1    0.50593E-09    0.10000E+01    0.49215E+04    0.55185E-43    0.32580E-50    0.27151E-52
+    5    1    0.50593E-09    0.10000E+01    0.39689E+04    0.80238E-42    0.89663E-49    0.39684E-51
+    5    1    0.50593E-09    0.10000E+01    0.32008E+04    0.36462E-39    0.79485E-46    0.18106E-48
+    5    1    0.50593E-09    0.10000E+01    0.25813E+04    0.27333E-30    0.13633E-36    0.13622E-39
+    5    1    0.50593E-09    0.10000E+01    0.20817E+04    0.53238E-14    0.11828E-19    0.26638E-23
+    5    1    0.50593E-09    0.10000E+01    0.16788E+04    0.18256E-08    0.17620E-13    0.91573E-18
+    5    1    0.50593E-09    0.10000E+01    0.13538E+04    0.39387E-08    0.67015E-13    0.19773E-17
+    5    1    0.50593E-09    0.10000E+01    0.10918E+04    0.82993E-08    0.25005E-12    0.41688E-17
+    5    1    0.50593E-09    0.10000E+01    0.88049E+03    0.17098E-07    0.92093E-12    0.85921E-17
+    5    1    0.50593E-09    0.10000E+01    0.71007E+03    0.34520E-07    0.33539E-11    0.17352E-16
+    5    1    0.50593E-09    0.10000E+01    0.57264E+03    0.68486E-07    0.11933E-10    0.34432E-16
+    5    1    0.50593E-09    0.10000E+01    0.46180E+03    0.13362E-06    0.40135E-10    0.67183E-16
+    5    1    0.50593E-09    0.10000E+01    0.37242E+03    0.25513E-06    0.12238E-09    0.12829E-15
+    5    1    0.50593E-09    0.10000E+01    0.30034E+03    0.47134E-06    0.32824E-09    0.23702E-15
+    5    1    0.50593E-09    0.10000E+01    0.24221E+03    0.83053E-06    0.76641E-09    0.41764E-15
+    5    1    0.50593E-09    0.10000E+01    0.19533E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    5    1    0.50593E-09    0.10000E+01    0.15752E+03    0.13090E-05    0.14564E-08    0.65826E-15
+    5    1    0.88282E-09    0.10000E+01    0.80645E+05    0.91476E-56    0.68731E-67    0.13789E-64
+    5    1    0.88282E-09    0.10000E+01    0.65036E+05    0.77641E-55    0.10919E-65    0.11662E-63
+    5    1    0.88282E-09    0.10000E+01    0.52449E+05    0.66035E-54    0.14632E-64    0.98963E-63
+    5    1    0.88282E-09    0.10000E+01    0.42297E+05    0.49567E-53    0.19615E-63    0.74065E-62
+    5    1    0.88282E-09    0.10000E+01    0.34111E+05    0.35353E-52    0.25848E-62    0.52675E-61
+    5    1    0.88282E-09    0.10000E+01    0.27509E+05    0.24558E-51    0.32187E-61    0.36567E-60
+    5    1    0.88282E-09    0.10000E+01    0.22184E+05    0.16393E-50    0.40073E-60    0.24273E-59
+    5    1    0.88282E-09    0.10000E+01    0.17891E+05    0.10961E-49    0.65251E-59    0.15348E-58
+    5    1    0.88282E-09    0.10000E+01    0.14428E+05    0.89454E-49    0.16244E-57    0.10392E-57
+    5    1    0.88282E-09    0.10000E+01    0.11635E+05    0.10618E-47    0.47991E-56    0.98632E-57
+    5    1    0.88282E-09    0.10000E+01    0.93834E+04    0.15701E-46    0.14156E-54    0.13418E-55
+    5    1    0.88282E-09    0.10000E+01    0.75673E+04    0.24062E-45    0.40636E-53    0.20503E-54
+    5    1    0.88282E-09    0.10000E+01    0.61026E+04    0.36255E-44    0.11442E-51    0.31177E-53
+    5    1    0.88282E-09    0.10000E+01    0.49215E+04    0.53641E-43    0.31845E-50    0.46407E-52
+    5    1    0.88282E-09    0.10000E+01    0.39689E+04    0.78393E-42    0.87953E-49    0.68035E-51
+    5    1    0.88282E-09    0.10000E+01    0.32008E+04    0.35759E-39    0.78214E-46    0.31094E-48
+    5    1    0.88282E-09    0.10000E+01    0.25813E+04    0.26899E-30    0.13461E-36    0.23432E-39
+    5    1    0.88282E-09    0.10000E+01    0.20817E+04    0.52599E-14    0.11724E-19    0.45928E-23
+    5    1    0.88282E-09    0.10000E+01    0.16788E+04    0.18083E-08    0.17491E-13    0.15815E-17
+    5    1    0.88282E-09    0.10000E+01    0.13538E+04    0.39044E-08    0.66538E-13    0.34162E-17
+    5    1    0.88282E-09    0.10000E+01    0.10918E+04    0.82318E-08    0.24829E-12    0.72050E-17
+    5    1    0.88282E-09    0.10000E+01    0.88049E+03    0.16966E-07    0.91446E-12    0.14853E-16
+    5    1    0.88282E-09    0.10000E+01    0.71007E+03    0.34263E-07    0.33303E-11    0.30001E-16
+    5    1    0.88282E-09    0.10000E+01    0.57264E+03    0.67988E-07    0.11849E-10    0.59535E-16
+    5    1    0.88282E-09    0.10000E+01    0.46180E+03    0.13266E-06    0.39851E-10    0.11617E-15
+    5    1    0.88282E-09    0.10000E+01    0.37242E+03    0.25331E-06    0.12151E-09    0.22183E-15
+    5    1    0.88282E-09    0.10000E+01    0.30034E+03    0.46799E-06    0.32591E-09    0.40983E-15
+    5    1    0.88282E-09    0.10000E+01    0.24221E+03    0.82463E-06    0.76096E-09    0.72214E-15
+    5    1    0.88282E-09    0.10000E+01    0.19533E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    5    1    0.88282E-09    0.10000E+01    0.15752E+03    0.12997E-05    0.14461E-08    0.11382E-14
+    5    1    0.15405E-08    0.10000E+01    0.80645E+05    0.22169E-55    0.16538E-66    0.19444E-63
+    5    1    0.15405E-08    0.10000E+01    0.65036E+05    0.18709E-54    0.26199E-65    0.16386E-62
+    5    1    0.15405E-08    0.10000E+01    0.52449E+05    0.15857E-53    0.34936E-64    0.13874E-61
+    5    1    0.15405E-08    0.10000E+01    0.42297E+05    0.11856E-52    0.46757E-63    0.10359E-60
+    5    1    0.15405E-08    0.10000E+01    0.34111E+05    0.84435E-52    0.62479E-62    0.73632E-60
+    5    1    0.15405E-08    0.10000E+01    0.27509E+05    0.59246E-51    0.81019E-61    0.51534E-59
+    5    1    0.15405E-08    0.10000E+01    0.22184E+05    0.40692E-50    0.10307E-59    0.35092E-58
+    5    1    0.15405E-08    0.10000E+01    0.17891E+05    0.27534E-49    0.14075E-58    0.22768E-57
+    5    1    0.15405E-08    0.10000E+01    0.14428E+05    0.19631E-48    0.24555E-57    0.13888E-56
+    5    1    0.15405E-08    0.10000E+01    0.11635E+05    0.17070E-47    0.57662E-56    0.81553E-56
+    5    1    0.15405E-08    0.10000E+01    0.93834E+04    0.19685E-46    0.15733E-54    0.52856E-55
+    5    1    0.15405E-08    0.10000E+01    0.75673E+04    0.27170E-45    0.44125E-53    0.48422E-54
+    5    1    0.15405E-08    0.10000E+01    0.61026E+04    0.39529E-44    0.12261E-51    0.62492E-53
+    5    1    0.15405E-08    0.10000E+01    0.49215E+04    0.57536E-43    0.33698E-50    0.90174E-52
+    5    1    0.15405E-08    0.10000E+01    0.39689E+04    0.83012E-42    0.92000E-49    0.13001E-50
+    5    1    0.15405E-08    0.10000E+01    0.32008E+04    0.37425E-39    0.80984E-46    0.58076E-48
+    5    1    0.15405E-08    0.10000E+01    0.25813E+04    0.27849E-30    0.13803E-36    0.42644E-39
+    5    1    0.15405E-08    0.10000E+01    0.20817E+04    0.53875E-14    0.11903E-19    0.81441E-23
+    5    1    0.15405E-08    0.10000E+01    0.16788E+04    0.18406E-08    0.17690E-13    0.27668E-17
+    5    1    0.15405E-08    0.10000E+01    0.13538E+04    0.39646E-08    0.67251E-13    0.59320E-17
+    5    1    0.15405E-08    0.10000E+01    0.10918E+04    0.83445E-08    0.25085E-12    0.12448E-16
+    5    1    0.15405E-08    0.10000E+01    0.88049E+03    0.17177E-07    0.92365E-12    0.25570E-16
+    5    1    0.15405E-08    0.10000E+01    0.71007E+03    0.34659E-07    0.33633E-11    0.51512E-16
+    5    1    0.15405E-08    0.10000E+01    0.57264E+03    0.68732E-07    0.11965E-10    0.10202E-15
+    5    1    0.15405E-08    0.10000E+01    0.46180E+03    0.13405E-06    0.40239E-10    0.19877E-15
+    5    1    0.15405E-08    0.10000E+01    0.37242E+03    0.25590E-06    0.12269E-09    0.37913E-15
+    5    1    0.15405E-08    0.10000E+01    0.30034E+03    0.47270E-06    0.32907E-09    0.69988E-15
+    5    1    0.15405E-08    0.10000E+01    0.24221E+03    0.83283E-06    0.76833E-09    0.12325E-14
+    5    1    0.15405E-08    0.10000E+01    0.19533E+03    0.13126E-05    0.14601E-08    0.19419E-14
+    5    1    0.15405E-08    0.10000E+01    0.15752E+03    0.13126E-05    0.14601E-08    0.19419E-14
+    5    1    0.26880E-08    0.10000E+01    0.80645E+05    0.44147E-55    0.32899E-66    0.76539E-63
+    5    1    0.26880E-08    0.10000E+01    0.65036E+05    0.37227E-54    0.52097E-65    0.64519E-62
+    5    1    0.26880E-08    0.10000E+01    0.52449E+05    0.31535E-53    0.69411E-64    0.54648E-61
+    5    1    0.26880E-08    0.10000E+01    0.42297E+05    0.23562E-52    0.92815E-63    0.40832E-60
+    5    1    0.26880E-08    0.10000E+01    0.34111E+05    0.16767E-51    0.12398E-61    0.29071E-59
+    5    1    0.26880E-08    0.10000E+01    0.27509E+05    0.11758E-50    0.16033E-60    0.20417E-58
+    5    1    0.26880E-08    0.10000E+01    0.22184E+05    0.80503E-50    0.19916E-59    0.14006E-57
+    5    1    0.26880E-08    0.10000E+01    0.17891E+05    0.53362E-49    0.24604E-58    0.92169E-57
+    5    1    0.26880E-08    0.10000E+01    0.14428E+05    0.35072E-48    0.34415E-57    0.57325E-56
+    5    1    0.26880E-08    0.10000E+01    0.11635E+05    0.25233E-47    0.64825E-56    0.33641E-55
+    5    1    0.26880E-08    0.10000E+01    0.93834E+04    0.23294E-46    0.16099E-54    0.19548E-54
+    5    1    0.26880E-08    0.10000E+01    0.75673E+04    0.28462E-45    0.44413E-53    0.13553E-53
+    5    1    0.26880E-08    0.10000E+01    0.61026E+04    0.40026E-44    0.12346E-51    0.13880E-52
+    5    1    0.26880E-08    0.10000E+01    0.49215E+04    0.57964E-43    0.33900E-50    0.18524E-51
+    5    1    0.26880E-08    0.10000E+01    0.39689E+04    0.83490E-42    0.92262E-49    0.26049E-50
+    5    1    0.26880E-08    0.10000E+01    0.32008E+04    0.37529E-39    0.80913E-46    0.11368E-47
+    5    1    0.26880E-08    0.10000E+01    0.25813E+04    0.27821E-30    0.13740E-36    0.81010E-39
+    5    1    0.26880E-08    0.10000E+01    0.20817E+04    0.53615E-14    0.11804E-19    0.14934E-22
+    5    1    0.26880E-08    0.10000E+01    0.16788E+04    0.18283E-08    0.17519E-13    0.49687E-17
+    5    1    0.26880E-08    0.10000E+01    0.13538E+04    0.39332E-08    0.66577E-13    0.10530E-16
+    5    1    0.26880E-08    0.10000E+01    0.10918E+04    0.82717E-08    0.24827E-12    0.21919E-16
+    5    1    0.26880E-08    0.10000E+01    0.88049E+03    0.17018E-07    0.91395E-12    0.44767E-16
+    5    1    0.26880E-08    0.10000E+01    0.71007E+03    0.34323E-07    0.33274E-11    0.89807E-16
+    5    1    0.26880E-08    0.10000E+01    0.57264E+03    0.68044E-07    0.11836E-10    0.17732E-15
+    5    1    0.26880E-08    0.10000E+01    0.46180E+03    0.13268E-06    0.39802E-10    0.34468E-15
+    5    1    0.26880E-08    0.10000E+01    0.37242E+03    0.25323E-06    0.12135E-09    0.65633E-15
+    5    1    0.26880E-08    0.10000E+01    0.30034E+03    0.46768E-06    0.32547E-09    0.12102E-14
+    5    1    0.26880E-08    0.10000E+01    0.24221E+03    0.82391E-06    0.75991E-09    0.21294E-14
+    5    1    0.26880E-08    0.10000E+01    0.19533E+03    0.12984E-05    0.14440E-08    0.33534E-14
+    5    1    0.26880E-08    0.10000E+01    0.15752E+03    0.12984E-05    0.14440E-08    0.33534E-14
+    5    1    0.46905E-08    0.10000E+01    0.80645E+05    0.84914E-55    0.63264E-66    0.25137E-62
+    5    1    0.46905E-08    0.10000E+01    0.65036E+05    0.71591E-54    0.10018E-64    0.21198E-61
+    5    1    0.46905E-08    0.10000E+01    0.52449E+05    0.60640E-53    0.13347E-63    0.17961E-60
+    5    1    0.46905E-08    0.10000E+01    0.42297E+05    0.45308E-52    0.17852E-62    0.13429E-59
+    5    1    0.46905E-08    0.10000E+01    0.34111E+05    0.32249E-51    0.23870E-61    0.95741E-59
+    5    1    0.46905E-08    0.10000E+01    0.27509E+05    0.22631E-50    0.30904E-60    0.67413E-58
+    5    1    0.46905E-08    0.10000E+01    0.22184E+05    0.15505E-49    0.38168E-59    0.46473E-57
+    5    1    0.46905E-08    0.10000E+01    0.17891E+05    0.10224E-48    0.45256E-58    0.30863E-56
+    5    1    0.46905E-08    0.10000E+01    0.14428E+05    0.65022E-48    0.55190E-57    0.19482E-55
+    5    1    0.46905E-08    0.10000E+01    0.11635E+05    0.41896E-47    0.82401E-56    0.11604E-54
+    5    1    0.46905E-08    0.10000E+01    0.93834E+04    0.31427E-46    0.17362E-54    0.66133E-54
+    5    1    0.46905E-08    0.10000E+01    0.75673E+04    0.31973E-45    0.45741E-53    0.40197E-53
+    5    1    0.46905E-08    0.10000E+01    0.61026E+04    0.41790E-44    0.12665E-51    0.33476E-52
+    5    1    0.46905E-08    0.10000E+01    0.49215E+04    0.59589E-43    0.34720E-50    0.40051E-51
+    5    1    0.46905E-08    0.10000E+01    0.39689E+04    0.85492E-42    0.94020E-49    0.54427E-50
+    5    1    0.46905E-08    0.10000E+01    0.32008E+04    0.38237E-39    0.81918E-46    0.23194E-47
+    5    1    0.46905E-08    0.10000E+01    0.25813E+04    0.28156E-30    0.13815E-36    0.15995E-38
+    5    1    0.46905E-08    0.10000E+01    0.20817E+04    0.53870E-14    0.11779E-19    0.28225E-22
+    5    1    0.46905E-08    0.10000E+01    0.16788E+04    0.18300E-08    0.17429E-13    0.91273E-17
+    5    1    0.46905E-08    0.10000E+01    0.13538E+04    0.39273E-08    0.66194E-13    0.19016E-16
+    5    1    0.46905E-08    0.10000E+01    0.10918E+04    0.82460E-08    0.24672E-12    0.39111E-16
+    5    1    0.46905E-08    0.10000E+01    0.88049E+03    0.16945E-07    0.90786E-12    0.79187E-16
+    5    1    0.46905E-08    0.10000E+01    0.71007E+03    0.34149E-07    0.33042E-11    0.15784E-15
+    5    1    0.46905E-08    0.10000E+01    0.57264E+03    0.67655E-07    0.11751E-10    0.31017E-15
+    5    1    0.46905E-08    0.10000E+01    0.46180E+03    0.13185E-06    0.39511E-10    0.60081E-15
+    5    1    0.46905E-08    0.10000E+01    0.37242E+03    0.25157E-06    0.12045E-09    0.11411E-14
+    5    1    0.46905E-08    0.10000E+01    0.30034E+03    0.46449E-06    0.32304E-09    0.21003E-14
+    5    1    0.46905E-08    0.10000E+01    0.24221E+03    0.81813E-06    0.75423E-09    0.36911E-14
+    5    1    0.46905E-08    0.10000E+01    0.19533E+03    0.12892E-05    0.14332E-08    0.58084E-14
+    5    1    0.46905E-08    0.10000E+01    0.15752E+03    0.12892E-05    0.14332E-08    0.58084E-14
+    5    1    0.81846E-08    0.10000E+01    0.80645E+05    0.16157E-54    0.12039E-65    0.81777E-62
+    5    1    0.81846E-08    0.10000E+01    0.65036E+05    0.13624E-53    0.19067E-64    0.68988E-61
+    5    1    0.81846E-08    0.10000E+01    0.52449E+05    0.11542E-52    0.25416E-63    0.58475E-60
+    5    1    0.81846E-08    0.10000E+01    0.42297E+05    0.86267E-52    0.34029E-62    0.43752E-59
+    5    1    0.81846E-08    0.10000E+01    0.34111E+05    0.61456E-51    0.45595E-61    0.31234E-58
+    5    1    0.81846E-08    0.10000E+01    0.27509E+05    0.43204E-50    0.59265E-60    0.22044E-57
+    5    1    0.81846E-08    0.10000E+01    0.22184E+05    0.29695E-49    0.73515E-59    0.15261E-56
+    5    1    0.81846E-08    0.10000E+01    0.17891E+05    0.19647E-48    0.86568E-58    0.10213E-55
+    5    1    0.81846E-08    0.10000E+01    0.14428E+05    0.12425E-47    0.99469E-57    0.65308E-55
+    5    1    0.81846E-08    0.10000E+01    0.11635E+05    0.76467E-47    0.12439E-55    0.39573E-54
+    5    1    0.81846E-08    0.10000E+01    0.93834E+04    0.49731E-46    0.20939E-54    0.22686E-53
+    5    1    0.81846E-08    0.10000E+01    0.75673E+04    0.40864E-45    0.49634E-53    0.12961E-52
+    5    1    0.81846E-08    0.10000E+01    0.61026E+04    0.46629E-44    0.13469E-51    0.90893E-52
+    5    1    0.81846E-08    0.10000E+01    0.49215E+04    0.63787E-43    0.36725E-50    0.94409E-51
+    5    1    0.81846E-08    0.10000E+01    0.39689E+04    0.90467E-42    0.98534E-49    0.12204E-49
+    5    1    0.81846E-08    0.10000E+01    0.32008E+04    0.40062E-39    0.84797E-46    0.50685E-47
+    5    1    0.81846E-08    0.10000E+01    0.25813E+04    0.29122E-30    0.14099E-36    0.33706E-38
+    5    1    0.81846E-08    0.10000E+01    0.20817E+04    0.54889E-14    0.11826E-19    0.56261E-22
+    5    1    0.81846E-08    0.10000E+01    0.16788E+04    0.18486E-08    0.17379E-13    0.17469E-16
+    5    1    0.81846E-08    0.10000E+01    0.13538E+04    0.39471E-08    0.65916E-13    0.35430E-16
+    5    1    0.81846E-08    0.10000E+01    0.10918E+04    0.82589E-08    0.24542E-12    0.71449E-16
+    5    1    0.81846E-08    0.10000E+01    0.88049E+03    0.16930E-07    0.90241E-12    0.14257E-15
+    5    1    0.81846E-08    0.10000E+01    0.71007E+03    0.34057E-07    0.32825E-11    0.28110E-15
+    5    1    0.81846E-08    0.10000E+01    0.57264E+03    0.67383E-07    0.11669E-10    0.54787E-15
+    5    1    0.81846E-08    0.10000E+01    0.46180E+03    0.13119E-06    0.39227E-10    0.10548E-14
+    5    1    0.81846E-08    0.10000E+01    0.37242E+03    0.25012E-06    0.11957E-09    0.19945E-14
+    5    1    0.81846E-08    0.10000E+01    0.30034E+03    0.46158E-06    0.32064E-09    0.36593E-14
+    5    1    0.81846E-08    0.10000E+01    0.24221E+03    0.81272E-06    0.74859E-09    0.64172E-14
+    5    1    0.81846E-08    0.10000E+01    0.19533E+03    0.12804E-05    0.14225E-08    0.10085E-13
+    5    1    0.81846E-08    0.10000E+01    0.15752E+03    0.12804E-05    0.14225E-08    0.10085E-13
+    5    1    0.14282E-07    0.10000E+01    0.80645E+05    0.30442E-54    0.22691E-65    0.26444E-61
+    5    1    0.14282E-07    0.10000E+01    0.65036E+05    0.25675E-53    0.35946E-64    0.22317E-60
+    5    1    0.14282E-07    0.10000E+01    0.52449E+05    0.21757E-52    0.47947E-63    0.18923E-59
+    5    1    0.14282E-07    0.10000E+01    0.42297E+05    0.16272E-51    0.64280E-62    0.14168E-58
+    5    1    0.14282E-07    0.10000E+01    0.34111E+05    0.11605E-50    0.86337E-61    0.10127E-57
+    5    1    0.14282E-07    0.10000E+01    0.27509E+05    0.81753E-50    0.11274E-59    0.71622E-57
+    5    1    0.14282E-07    0.10000E+01    0.22184E+05    0.56408E-49    0.14089E-58    0.49766E-56
+    5    1    0.14282E-07    0.10000E+01    0.17891E+05    0.37546E-48    0.16701E-57    0.33521E-55
+    5    1    0.14282E-07    0.10000E+01    0.14428E+05    0.23872E-47    0.18921E-56    0.21667E-54
+    5    1    0.14282E-07    0.10000E+01    0.11635E+05    0.14540E-46    0.21527E-55    0.13338E-53
+    5    1    0.14282E-07    0.10000E+01    0.93834E+04    0.88067E-46    0.29254E-54    0.77578E-53
+    5    1    0.14282E-07    0.10000E+01    0.75673E+04    0.60553E-45    0.58326E-53    0.43430E-52
+    5    1    0.14282E-07    0.10000E+01    0.61026E+04    0.57349E-44    0.15051E-51    0.27098E-51
+    5    1    0.14282E-07    0.10000E+01    0.49215E+04    0.72317E-43    0.40568E-50    0.24252E-50
+    5    1    0.14282E-07    0.10000E+01    0.39689E+04    0.10013E-41    0.10738E-48    0.29366E-49
+    5    1    0.14282E-07    0.10000E+01    0.32008E+04    0.43649E-39    0.90644E-46    0.11889E-46
+    5    1    0.14282E-07    0.10000E+01    0.25813E+04    0.31082E-30    0.14709E-36    0.76420E-38
+    5    1    0.14282E-07    0.10000E+01    0.20817E+04    0.57088E-14    0.11967E-19    0.12009E-21
+    5    1    0.14282E-07    0.10000E+01    0.16788E+04    0.18924E-08    0.17356E-13    0.35443E-16
+    5    1    0.14282E-07    0.10000E+01    0.13538E+04    0.40020E-08    0.65652E-13    0.69167E-16
+    5    1    0.14282E-07    0.10000E+01    0.10918E+04    0.83184E-08    0.24397E-12    0.13540E-15
+    5    1    0.14282E-07    0.10000E+01    0.88049E+03    0.16972E-07    0.89579E-12    0.26406E-15
+    5    1    0.14282E-07    0.10000E+01    0.71007E+03    0.34023E-07    0.32552E-11    0.51154E-15
+    5    1    0.14282E-07    0.10000E+01    0.57264E+03    0.67146E-07    0.11564E-10    0.98359E-15
+    5    1    0.14282E-07    0.10000E+01    0.46180E+03    0.13048E-06    0.38856E-10    0.18743E-14
+    5    1    0.14282E-07    0.10000E+01    0.37242E+03    0.24843E-06    0.11841E-09    0.35173E-14
+    5    1    0.14282E-07    0.10000E+01    0.30034E+03    0.45802E-06    0.31748E-09    0.64185E-14
+    5    1    0.14282E-07    0.10000E+01    0.24221E+03    0.80590E-06    0.74114E-09    0.11214E-13
+    5    1    0.14282E-07    0.10000E+01    0.19533E+03    0.12691E-05    0.14082E-08    0.17584E-13
+    5    1    0.14282E-07    0.10000E+01    0.15752E+03    0.12691E-05    0.14082E-08    0.17584E-13
+    5    1    0.24920E-07    0.10000E+01    0.80645E+05    0.56799E-54    0.42354E-65    0.84609E-61
+    5    1    0.24920E-07    0.10000E+01    0.65036E+05    0.47921E-53    0.67115E-64    0.71433E-60
+    5    1    0.24920E-07    0.10000E+01    0.52449E+05    0.40621E-52    0.89589E-63    0.60589E-59
+    5    1    0.24920E-07    0.10000E+01    0.42297E+05    0.30398E-51    0.12027E-61    0.45392E-58
+    5    1    0.24920E-07    0.10000E+01    0.34111E+05    0.21705E-50    0.16193E-60    0.32479E-57
+    5    1    0.24920E-07    0.10000E+01    0.27509E+05    0.15323E-49    0.21238E-59    0.23013E-56
+    5    1    0.24920E-07    0.10000E+01    0.22184E+05    0.10612E-48    0.26744E-58    0.16041E-55
+    5    1    0.24920E-07    0.10000E+01    0.17891E+05    0.71084E-48    0.32040E-57    0.10863E-54
+    5    1    0.24920E-07    0.10000E+01    0.14428E+05    0.45587E-47    0.36499E-56    0.70834E-54
+    5    1    0.24920E-07    0.10000E+01    0.11635E+05    0.27903E-46    0.40136E-55    0.44191E-53
+    5    1    0.24920E-07    0.10000E+01    0.93834E+04    0.16495E-45    0.47141E-54    0.26116E-52
+    5    1    0.24920E-07    0.10000E+01    0.75673E+04    0.10159E-44    0.76552E-53    0.14621E-51
+    5    1    0.24920E-07    0.10000E+01    0.61026E+04    0.79681E-44    0.18024E-51    0.85225E-51
+    5    1    0.24920E-07    0.10000E+01    0.49215E+04    0.88844E-43    0.47589E-50    0.66813E-50
+    5    1    0.24920E-07    0.10000E+01    0.39689E+04    0.11805E-41    0.12392E-48    0.74971E-49
+    5    1    0.24920E-07    0.10000E+01    0.32008E+04    0.50367E-39    0.10197E-45    0.29630E-46
+    5    1    0.24920E-07    0.10000E+01    0.25813E+04    0.34881E-30    0.15962E-36    0.18551E-37
+    5    1    0.24920E-07    0.10000E+01    0.20817E+04    0.61657E-14    0.12352E-19    0.27613E-21
+    5    1    0.24920E-07    0.10000E+01    0.16788E+04    0.19921E-08    0.17496E-13    0.77232E-16
+    5    1    0.24920E-07    0.10000E+01    0.13538E+04    0.41442E-08    0.65869E-13    0.14362E-15
+    5    1    0.24920E-07    0.10000E+01    0.10918E+04    0.85146E-08    0.24393E-12    0.27015E-15
+    5    1    0.24920E-07    0.10000E+01    0.88049E+03    0.17227E-07    0.89340E-12    0.50995E-15
+    5    1    0.24920E-07    0.10000E+01    0.71007E+03    0.34324E-07    0.32407E-11    0.96220E-15
+    5    1    0.24920E-07    0.10000E+01    0.57264E+03    0.67430E-07    0.11499E-10    0.18117E-14
+    5    1    0.24920E-07    0.10000E+01    0.46180E+03    0.13060E-06    0.38609E-10    0.33962E-14
+    5    1    0.24920E-07    0.10000E+01    0.37242E+03    0.24803E-06    0.11760E-09    0.62949E-14
+    5    1    0.24920E-07    0.10000E+01    0.30034E+03    0.45649E-06    0.31523E-09    0.11385E-13
+    5    1    0.24920E-07    0.10000E+01    0.24221E+03    0.80227E-06    0.73576E-09    0.19769E-13
+    5    1    0.24920E-07    0.10000E+01    0.19533E+03    0.12625E-05    0.13979E-08    0.30878E-13
+    5    1    0.24920E-07    0.10000E+01    0.15752E+03    0.12625E-05    0.13979E-08    0.30878E-13
+    5    1    0.43485E-07    0.10000E+01    0.80645E+05    0.10510E-53    0.78406E-65    0.26954E-60
+    5    1    0.43485E-07    0.10000E+01    0.65036E+05    0.88705E-53    0.12428E-63    0.22764E-59
+    5    1    0.43485E-07    0.10000E+01    0.52449E+05    0.75217E-52    0.16602E-62    0.19314E-58
+    5    1    0.43485E-07    0.10000E+01    0.42297E+05    0.56321E-51    0.22317E-61    0.14477E-57
+    5    1    0.43485E-07    0.10000E+01    0.34111E+05    0.40259E-50    0.30113E-60    0.10369E-56
+    5    1    0.43485E-07    0.10000E+01    0.27509E+05    0.28477E-49    0.39653E-59    0.73588E-56
+    5    1    0.43485E-07    0.10000E+01    0.22184E+05    0.19790E-48    0.50282E-58    0.51431E-55
+    5    1    0.43485E-07    0.10000E+01    0.17891E+05    0.13334E-47    0.60891E-57    0.34986E-54
+    5    1    0.43485E-07    0.10000E+01    0.14428E+05    0.86274E-47    0.70205E-56    0.22981E-53
+    5    1    0.43485E-07    0.10000E+01    0.11635E+05    0.53336E-46    0.76941E-55    0.14498E-52
+    5    1    0.43485E-07    0.10000E+01    0.93834E+04    0.31489E-45    0.83738E-54    0.86955E-52
+    5    1    0.43485E-07    0.10000E+01    0.75673E+04    0.18378E-44    0.11296E-52    0.49107E-51
+    5    1    0.43485E-07    0.10000E+01    0.61026E+04    0.12414E-43    0.23332E-51    0.27625E-50
+    5    1    0.43485E-07    0.10000E+01    0.49215E+04    0.11934E-42    0.59575E-50    0.19471E-49
+    5    1    0.43485E-07    0.10000E+01    0.39689E+04    0.14919E-41    0.15251E-48    0.20142E-48
+    5    1    0.43485E-07    0.10000E+01    0.32008E+04    0.62017E-39    0.12195E-45    0.77746E-46
+    5    1    0.43485E-07    0.10000E+01    0.25813E+04    0.41582E-30    0.18220E-36    0.47847E-37
+    5    1    0.43485E-07    0.10000E+01    0.20817E+04    0.69929E-14    0.13076E-19    0.68378E-21
+    5    1    0.43485E-07    0.10000E+01    0.16788E+04    0.21769E-08    0.17804E-13    0.18225E-15
+    5    1    0.43485E-07    0.10000E+01    0.13538E+04    0.44115E-08    0.66480E-13    0.32148E-15
+    5    1    0.43485E-07    0.10000E+01    0.10918E+04    0.88927E-08    0.24471E-12    0.57669E-15
+    5    1    0.43485E-07    0.10000E+01    0.88049E+03    0.17741E-07    0.89234E-12    0.10440E-14
+    5    1    0.43485E-07    0.10000E+01    0.71007E+03    0.34977E-07    0.32269E-11    0.19002E-14
+    5    1    0.43485E-07    0.10000E+01    0.57264E+03    0.68173E-07    0.11426E-10    0.34708E-14
+    5    1    0.43485E-07    0.10000E+01    0.46180E+03    0.13126E-06    0.38313E-10    0.63469E-14
+    5    1    0.43485E-07    0.10000E+01    0.37242E+03    0.24822E-06    0.11661E-09    0.11538E-13
+    5    1    0.43485E-07    0.10000E+01    0.30034E+03    0.45546E-06    0.31243E-09    0.20569E-13
+    5    1    0.43485E-07    0.10000E+01    0.24221E+03    0.79881E-06    0.72902E-09    0.35353E-13
+    5    1    0.43485E-07    0.10000E+01    0.19533E+03    0.12554E-05    0.13849E-08    0.54870E-13
+    5    1    0.43485E-07    0.10000E+01    0.15752E+03    0.12554E-05    0.13849E-08    0.54870E-13
+    5    1    0.75878E-07    0.10000E+01    0.80645E+05    0.19293E-53    0.14399E-64    0.85056E-60
+    5    1    0.75878E-07    0.10000E+01    0.65036E+05    0.16289E-52    0.22830E-63    0.71854E-59
+    5    1    0.75878E-07    0.10000E+01    0.52449E+05    0.13816E-51    0.30518E-62    0.60980E-58
+    5    1    0.75878E-07    0.10000E+01    0.42297E+05    0.10351E-50    0.41074E-61    0.45730E-57
+    5    1    0.75878E-07    0.10000E+01    0.34111E+05    0.74069E-50    0.55532E-60    0.32780E-56
+    5    1    0.75878E-07    0.10000E+01    0.27509E+05    0.52484E-49    0.73379E-59    0.23296E-55
+    5    1    0.75878E-07    0.10000E+01    0.22184E+05    0.36584E-48    0.93610E-58    0.16319E-54
+    5    1    0.75878E-07    0.10000E+01    0.17891E+05    0.24774E-47    0.11445E-56    0.11143E-53
+    5    1    0.75878E-07    0.10000E+01    0.14428E+05    0.16158E-46    0.13367E-55    0.73631E-53
+    5    1    0.75878E-07    0.10000E+01    0.11635E+05    0.10097E-45    0.14784E-54    0.46877E-52
+    5    1    0.75878E-07    0.10000E+01    0.93834E+04    0.60091E-45    0.15625E-53    0.28479E-51
+    5    1    0.75878E-07    0.10000E+01    0.75673E+04    0.34403E-44    0.18447E-52    0.16269E-50
+    5    1    0.75878E-07    0.10000E+01    0.61026E+04    0.21087E-43    0.32835E-51    0.90097E-50
+    5    1    0.75878E-07    0.10000E+01    0.49215E+04    0.17543E-42    0.79923E-50    0.58681E-49
+    5    1    0.75878E-07    0.10000E+01    0.39689E+04    0.20309E-41    0.20144E-48    0.56056E-48
+    5    1    0.75878E-07    0.10000E+01    0.32008E+04    0.82056E-39    0.15688E-45    0.21124E-45
+    5    1    0.75878E-07    0.10000E+01    0.25813E+04    0.53309E-30    0.22263E-36    0.12883E-36
+    5    1    0.75878E-07    0.10000E+01    0.20817E+04    0.84860E-14    0.14460E-19    0.17965E-20
+    5    1    0.75878E-07    0.10000E+01    0.16788E+04    0.25209E-08    0.18518E-13    0.46195E-15
+    5    1    0.75878E-07    0.10000E+01    0.13538E+04    0.49208E-08    0.68214E-13    0.77574E-15
+    5    1    0.75878E-07    0.10000E+01    0.10918E+04    0.96387E-08    0.24856E-12    0.13259E-14
+    5    1    0.75878E-07    0.10000E+01    0.88049E+03    0.18811E-07    0.89969E-12    0.22918E-14
+    5    1    0.75878E-07    0.10000E+01    0.71007E+03    0.36464E-07    0.32364E-11    0.39946E-14
+    5    1    0.75878E-07    0.10000E+01    0.57264E+03    0.70156E-07    0.11419E-10    0.70160E-14
+    5    1    0.75878E-07    0.10000E+01    0.46180E+03    0.13376E-06    0.38203E-10    0.12400E-13
+    5    1    0.75878E-07    0.10000E+01    0.37242E+03    0.25111E-06    0.11612E-09    0.21917E-13
+    5    1    0.75878E-07    0.10000E+01    0.30034E+03    0.45840E-06    0.31085E-09    0.38230E-13
+    5    1    0.75878E-07    0.10000E+01    0.24221E+03    0.80111E-06    0.72499E-09    0.64669E-13
+    5    1    0.75878E-07    0.10000E+01    0.19533E+03    0.12563E-05    0.13768E-08    0.99357E-13
+    5    1    0.75878E-07    0.10000E+01    0.15752E+03    0.12563E-05    0.13768E-08    0.99357E-13
+    5    1    0.13240E-06    0.10000E+01    0.80645E+05    0.35149E-53    0.26243E-64    0.26493E-59
+    5    1    0.13240E-06    0.10000E+01    0.65036E+05    0.29686E-52    0.41619E-63    0.22387E-58
+    5    1    0.13240E-06    0.10000E+01    0.52449E+05    0.25186E-51    0.55670E-62    0.19003E-57
+    5    1    0.13240E-06    0.10000E+01    0.42297E+05    0.18879E-50    0.75005E-61    0.14256E-56
+    5    1    0.13240E-06    0.10000E+01    0.34111E+05    0.13522E-49    0.10159E-59    0.10226E-55
+    5    1    0.13240E-06    0.10000E+01    0.27509E+05    0.95960E-49    0.13464E-58    0.72760E-55
+    5    1    0.13240E-06    0.10000E+01    0.22184E+05    0.67063E-48    0.17264E-57    0.51065E-54
+    5    1    0.13240E-06    0.10000E+01    0.17891E+05    0.45613E-47    0.21282E-56    0.34977E-53
+    5    1    0.13240E-06    0.10000E+01    0.14428E+05    0.29957E-46    0.25150E-55    0.23226E-52
+    5    1    0.13240E-06    0.10000E+01    0.11635E+05    0.18905E-45    0.28182E-54    0.14896E-51
+    5    1    0.13240E-06    0.10000E+01    0.93834E+04    0.11374E-44    0.29637E-53    0.91462E-51
+    5    1    0.13240E-06    0.10000E+01    0.75673E+04    0.64991E-44    0.32234E-52    0.52854E-50
+    5    1    0.13240E-06    0.10000E+01    0.61026E+04    0.37686E-43    0.49738E-51    0.29128E-49
+    5    1    0.13240E-06    0.10000E+01    0.49215E+04    0.27755E-42    0.11389E-49    0.17945E-48
+    5    1    0.13240E-06    0.10000E+01    0.39689E+04    0.29504E-41    0.28323E-48    0.15939E-47
+    5    1    0.13240E-06    0.10000E+01    0.32008E+04    0.11576E-38    0.21621E-45    0.58612E-45
+    5    1    0.13240E-06    0.10000E+01    0.25813E+04    0.73259E-30    0.29238E-36    0.35614E-36
+    5    1    0.13240E-06    0.10000E+01    0.20817E+04    0.11079E-13    0.16893E-19    0.49130E-20
+    5    1    0.13240E-06    0.10000E+01    0.16788E+04    0.31279E-08    0.19813E-13    0.12354E-14
+    5    1    0.13240E-06    0.10000E+01    0.13538E+04    0.58205E-08    0.71440E-13    0.19932E-14
+    5    1    0.13240E-06    0.10000E+01    0.10918E+04    0.10963E-07    0.25607E-12    0.32657E-14
+    5    1    0.13240E-06    0.10000E+01    0.88049E+03    0.20725E-07    0.91554E-12    0.54012E-14
+    5    1    0.13240E-06    0.10000E+01    0.71007E+03    0.39159E-07    0.32643E-11    0.90015E-14
+    5    1    0.13240E-06    0.10000E+01    0.57264E+03    0.73823E-07    0.11448E-10    0.15127E-13
+    5    1    0.13240E-06    0.10000E+01    0.46180E+03    0.13853E-06    0.38151E-10    0.25647E-13
+    5    1    0.13240E-06    0.10000E+01    0.37242E+03    0.25699E-06    0.11569E-09    0.43694E-13
+    5    1    0.13240E-06    0.10000E+01    0.30034E+03    0.46510E-06    0.30928E-09    0.73951E-13
+    5    1    0.13240E-06    0.10000E+01    0.24221E+03    0.80796E-06    0.72072E-09    0.12224E-12
+    5    1    0.13240E-06    0.10000E+01    0.19533E+03    0.12624E-05    0.13681E-08    0.18497E-12
+    5    1    0.13240E-06    0.10000E+01    0.15752E+03    0.12624E-05    0.13681E-08    0.18497E-12
+    5    1    0.23103E-06    0.10000E+01    0.80645E+05    0.62184E-53    0.46434E-64    0.57270E-59
+    5    1    0.23103E-06    0.10000E+01    0.65036E+05    0.52524E-52    0.73646E-63    0.48397E-58
+    5    1    0.23103E-06    0.10000E+01    0.52449E+05    0.44567E-51    0.98531E-62    0.41084E-57
+    5    1    0.23103E-06    0.10000E+01    0.42297E+05    0.33413E-50    0.13280E-60    0.30827E-56
+    5    1    0.23103E-06    0.10000E+01    0.34111E+05    0.23939E-49    0.17998E-59    0.22118E-55
+    5    1    0.23103E-06    0.10000E+01    0.27509E+05    0.16998E-48    0.23878E-58    0.15742E-54
+    5    1    0.23103E-06    0.10000E+01    0.22184E+05    0.11890E-47    0.30673E-57    0.11055E-53
+    5    1    0.23103E-06    0.10000E+01    0.17891E+05    0.80993E-47    0.37918E-56    0.75799E-53
+    5    1    0.23103E-06    0.10000E+01    0.14428E+05    0.53319E-46    0.44995E-55    0.50413E-52
+    5    1    0.23103E-06    0.10000E+01    0.11635E+05    0.33767E-45    0.50678E-54    0.32409E-51
+    5    1    0.23103E-06    0.10000E+01    0.93834E+04    0.20402E-44    0.53377E-53    0.19968E-50
+    5    1    0.23103E-06    0.10000E+01    0.75673E+04    0.11677E-43    0.56856E-52    0.11585E-49
+    5    1    0.23103E-06    0.10000E+01    0.61026E+04    0.66804E-43    0.83475E-51    0.63832E-49
+    5    1    0.23103E-06    0.10000E+01    0.49215E+04    0.47306E-42    0.18618E-49    0.38697E-48
+    5    1    0.23103E-06    0.10000E+01    0.39689E+04    0.48639E-41    0.46084E-48    0.33532E-47
+    5    1    0.23103E-06    0.10000E+01    0.32008E+04    0.18868E-38    0.34985E-45    0.12217E-44
+    5    1    0.23103E-06    0.10000E+01    0.25813E+04    0.11844E-29    0.46547E-36    0.74197E-36
+    5    1    0.23103E-06    0.10000E+01    0.20817E+04    0.17609E-13    0.25667E-19    0.10221E-19
+    5    1    0.23103E-06    0.10000E+01    0.16788E+04    0.48777E-08    0.28888E-13    0.25561E-14
+    5    1    0.23103E-06    0.10000E+01    0.13538E+04    0.88944E-08    0.10303E-12    0.40733E-14
+    5    1    0.23103E-06    0.10000E+01    0.10918E+04    0.16460E-07    0.36612E-12    0.65838E-14
+    5    1    0.23103E-06    0.10000E+01    0.88049E+03    0.30655E-07    0.13004E-11    0.10728E-13
+    5    1    0.23103E-06    0.10000E+01    0.71007E+03    0.57200E-07    0.46142E-11    0.17596E-13
+    5    1    0.23103E-06    0.10000E+01    0.57264E+03    0.10673E-06    0.16128E-10    0.29079E-13
+    5    1    0.23103E-06    0.10000E+01    0.46180E+03    0.19864E-06    0.53633E-10    0.48484E-13
+    5    1    0.23103E-06    0.10000E+01    0.37242E+03    0.36616E-06    0.16242E-09    0.81323E-13
+    5    1    0.23103E-06    0.10000E+01    0.30034E+03    0.65958E-06    0.43388E-09    0.13580E-12
+    5    1    0.23103E-06    0.10000E+01    0.24221E+03    0.11421E-05    0.10106E-08    0.22208E-12
+    5    1    0.23103E-06    0.10000E+01    0.19533E+03    0.17808E-05    0.19179E-08    0.33363E-12
+    5    1    0.23103E-06    0.10000E+01    0.15752E+03    0.17808E-05    0.19179E-08    0.33363E-12
+    5    1    0.40314E-06    0.10000E+01    0.80645E+05    0.10851E-52    0.81024E-64    0.99933E-59
+    5    1    0.40314E-06    0.10000E+01    0.65036E+05    0.91650E-52    0.12851E-62    0.84451E-58
+    5    1    0.40314E-06    0.10000E+01    0.52449E+05    0.77767E-51    0.17193E-61    0.71690E-57
+    5    1    0.40314E-06    0.10000E+01    0.42297E+05    0.58304E-50    0.23173E-60    0.53791E-56
+    5    1    0.40314E-06    0.10000E+01    0.34111E+05    0.41772E-49    0.31405E-59    0.38594E-55
+    5    1    0.40314E-06    0.10000E+01    0.27509E+05    0.29661E-48    0.41666E-58    0.27470E-54
+    5    1    0.40314E-06    0.10000E+01    0.22184E+05    0.20747E-47    0.53522E-57    0.19291E-53
+    5    1    0.40314E-06    0.10000E+01    0.17891E+05    0.14133E-46    0.66165E-56    0.13226E-52
+    5    1    0.40314E-06    0.10000E+01    0.14428E+05    0.93039E-46    0.78513E-55    0.87968E-52
+    5    1    0.40314E-06    0.10000E+01    0.11635E+05    0.58921E-45    0.88430E-54    0.56552E-51
+    5    1    0.40314E-06    0.10000E+01    0.93834E+04    0.35600E-44    0.93140E-53    0.34843E-50
+    5    1    0.40314E-06    0.10000E+01    0.75673E+04    0.20375E-43    0.99210E-52    0.20216E-49
+    5    1    0.40314E-06    0.10000E+01    0.61026E+04    0.11657E-42    0.14566E-50    0.11138E-48
+    5    1    0.40314E-06    0.10000E+01    0.49215E+04    0.82547E-42    0.32487E-49    0.67524E-48
+    5    1    0.40314E-06    0.10000E+01    0.39689E+04    0.84872E-41    0.80414E-48    0.58511E-47
+    5    1    0.40314E-06    0.10000E+01    0.32008E+04    0.32923E-38    0.61047E-45    0.21319E-44
+    5    1    0.40314E-06    0.10000E+01    0.25813E+04    0.20668E-29    0.81221E-36    0.12947E-35
+    5    1    0.40314E-06    0.10000E+01    0.20817E+04    0.30727E-13    0.44788E-19    0.17834E-19
+    5    1    0.40314E-06    0.10000E+01    0.16788E+04    0.85112E-08    0.50407E-13    0.44602E-14
+    5    1    0.40314E-06    0.10000E+01    0.13538E+04    0.15520E-07    0.17978E-12    0.71077E-14
+    5    1    0.40314E-06    0.10000E+01    0.10918E+04    0.28723E-07    0.63886E-12    0.11488E-13
+    5    1    0.40314E-06    0.10000E+01    0.88049E+03    0.53491E-07    0.22692E-11    0.18721E-13
+    5    1    0.40314E-06    0.10000E+01    0.71007E+03    0.99810E-07    0.80516E-11    0.30703E-13
+    5    1    0.40314E-06    0.10000E+01    0.57264E+03    0.18623E-06    0.28142E-10    0.50741E-13
+    5    1    0.40314E-06    0.10000E+01    0.46180E+03    0.34661E-06    0.93586E-10    0.84602E-13
+    5    1    0.40314E-06    0.10000E+01    0.37242E+03    0.63892E-06    0.28342E-09    0.14190E-12
+    5    1    0.40314E-06    0.10000E+01    0.30034E+03    0.11509E-05    0.75710E-09    0.23695E-12
+    5    1    0.40314E-06    0.10000E+01    0.24221E+03    0.19928E-05    0.17635E-08    0.38751E-12
+    5    1    0.40314E-06    0.10000E+01    0.19533E+03    0.31074E-05    0.33466E-08    0.58216E-12
+    5    1    0.40314E-06    0.10000E+01    0.15752E+03    0.31074E-05    0.33466E-08    0.58216E-12
+    5    1    0.70346E-06    0.10000E+01    0.80645E+05    0.18934E-52    0.14138E-63    0.17438E-58
+    5    1    0.70346E-06    0.10000E+01    0.65036E+05    0.15992E-51    0.22424E-62    0.14736E-57
+    5    1    0.70346E-06    0.10000E+01    0.52449E+05    0.13570E-50    0.30001E-61    0.12509E-56
+    5    1    0.70346E-06    0.10000E+01    0.42297E+05    0.10174E-49    0.40436E-60    0.93861E-56
+    5    1    0.70346E-06    0.10000E+01    0.34111E+05    0.72889E-49    0.54800E-59    0.67344E-55
+    5    1    0.70346E-06    0.10000E+01    0.27509E+05    0.51756E-48    0.72704E-58    0.47933E-54
+    5    1    0.70346E-06    0.10000E+01    0.22184E+05    0.36203E-47    0.93392E-57    0.33662E-53
+    5    1    0.70346E-06    0.10000E+01    0.17891E+05    0.24661E-46    0.11545E-55    0.23079E-52
+    5    1    0.70346E-06    0.10000E+01    0.14428E+05    0.16235E-45    0.13700E-54    0.15350E-51
+    5    1    0.70346E-06    0.10000E+01    0.11635E+05    0.10281E-44    0.15430E-53    0.98681E-51
+    5    1    0.70346E-06    0.10000E+01    0.93834E+04    0.62119E-44    0.16252E-52    0.60798E-50
+    5    1    0.70346E-06    0.10000E+01    0.75673E+04    0.35554E-43    0.17312E-51    0.35275E-49
+    5    1    0.70346E-06    0.10000E+01    0.61026E+04    0.20340E-42    0.25417E-50    0.19436E-48
+    5    1    0.70346E-06    0.10000E+01    0.49215E+04    0.14404E-41    0.56687E-49    0.11783E-47
+    5    1    0.70346E-06    0.10000E+01    0.39689E+04    0.14810E-40    0.14032E-47    0.10210E-46
+    5    1    0.70346E-06    0.10000E+01    0.32008E+04    0.57449E-38    0.10652E-44    0.37200E-44
+    5    1    0.70346E-06    0.10000E+01    0.25813E+04    0.36064E-29    0.14173E-35    0.22592E-35
+    5    1    0.70346E-06    0.10000E+01    0.20817E+04    0.53617E-13    0.78152E-19    0.31120E-19
+    5    1    0.70346E-06    0.10000E+01    0.16788E+04    0.14852E-07    0.87958E-13    0.77828E-14
+    5    1    0.70346E-06    0.10000E+01    0.13538E+04    0.27082E-07    0.31370E-12    0.12403E-13
+    5    1    0.70346E-06    0.10000E+01    0.10918E+04    0.50119E-07    0.11148E-11    0.20046E-13
+    5    1    0.70346E-06    0.10000E+01    0.88049E+03    0.93338E-07    0.39596E-11    0.32666E-13
+    5    1    0.70346E-06    0.10000E+01    0.71007E+03    0.17416E-06    0.14050E-10    0.53576E-13
+    5    1    0.70346E-06    0.10000E+01    0.57264E+03    0.32497E-06    0.49106E-10    0.88540E-13
+    5    1    0.70346E-06    0.10000E+01    0.46180E+03    0.60481E-06    0.16330E-09    0.14763E-12
+    5    1    0.70346E-06    0.10000E+01    0.37242E+03    0.11149E-05    0.49454E-09    0.24761E-12
+    5    1    0.70346E-06    0.10000E+01    0.30034E+03    0.20083E-05    0.13211E-08    0.41347E-12
+    5    1    0.70346E-06    0.10000E+01    0.24221E+03    0.34773E-05    0.30771E-08    0.67618E-12
+    5    1    0.70346E-06    0.10000E+01    0.19533E+03    0.54222E-05    0.58395E-08    0.10158E-11
+    5    1    0.70346E-06    0.10000E+01    0.15752E+03    0.54222E-05    0.58395E-08    0.10158E-11
+    5    1    0.12275E-05    0.10000E+01    0.80645E+05    0.33038E-52    0.24670E-63    0.30428E-58
+    5    1    0.12275E-05    0.10000E+01    0.65036E+05    0.27906E-51    0.39128E-62    0.25714E-57
+    5    1    0.12275E-05    0.10000E+01    0.52449E+05    0.23679E-50    0.52350E-61    0.21828E-56
+    5    1    0.12275E-05    0.10000E+01    0.42297E+05    0.17752E-49    0.70559E-60    0.16378E-55
+    5    1    0.12275E-05    0.10000E+01    0.34111E+05    0.12719E-48    0.95622E-59    0.11751E-54
+    5    1    0.12275E-05    0.10000E+01    0.27509E+05    0.90311E-48    0.12686E-57    0.83640E-54
+    5    1    0.12275E-05    0.10000E+01    0.22184E+05    0.63172E-47    0.16296E-56    0.58737E-53
+    5    1    0.12275E-05    0.10000E+01    0.17891E+05    0.43032E-46    0.20146E-55    0.40272E-52
+    5    1    0.12275E-05    0.10000E+01    0.14428E+05    0.28329E-45    0.23906E-54    0.26785E-51
+    5    1    0.12275E-05    0.10000E+01    0.11635E+05    0.17940E-44    0.26925E-53    0.17219E-50
+    5    1    0.12275E-05    0.10000E+01    0.93834E+04    0.10839E-43    0.28359E-52    0.10609E-49
+    5    1    0.12275E-05    0.10000E+01    0.75673E+04    0.62039E-43    0.30208E-51    0.61553E-49
+    5    1    0.12275E-05    0.10000E+01    0.61026E+04    0.35493E-42    0.44350E-50    0.33914E-48
+    5    1    0.12275E-05    0.10000E+01    0.49215E+04    0.25134E-41    0.98915E-49    0.20560E-47
+    5    1    0.12275E-05    0.10000E+01    0.39689E+04    0.25842E-40    0.24485E-47    0.17815E-46
+    5    1    0.12275E-05    0.10000E+01    0.32008E+04    0.10025E-37    0.18588E-44    0.64912E-44
+    5    1    0.12275E-05    0.10000E+01    0.25813E+04    0.62929E-29    0.24730E-35    0.39421E-35
+    5    1    0.12275E-05    0.10000E+01    0.20817E+04    0.93558E-13    0.13637E-18    0.54302E-19
+    5    1    0.12275E-05    0.10000E+01    0.16788E+04    0.25915E-07    0.15348E-12    0.13581E-13
+    5    1    0.12275E-05    0.10000E+01    0.13538E+04    0.47256E-07    0.54739E-12    0.21642E-13
+    5    1    0.12275E-05    0.10000E+01    0.10918E+04    0.87455E-07    0.19452E-11    0.34980E-13
+    5    1    0.12275E-05    0.10000E+01    0.88049E+03    0.16287E-06    0.69092E-11    0.57001E-13
+    5    1    0.12275E-05    0.10000E+01    0.71007E+03    0.30390E-06    0.24516E-10    0.93486E-13
+    5    1    0.12275E-05    0.10000E+01    0.57264E+03    0.56705E-06    0.85687E-10    0.15450E-12
+    5    1    0.12275E-05    0.10000E+01    0.46180E+03    0.10554E-05    0.28495E-09    0.25760E-12
+    5    1    0.12275E-05    0.10000E+01    0.37242E+03    0.19454E-05    0.86295E-09    0.43207E-12
+    5    1    0.12275E-05    0.10000E+01    0.30034E+03    0.35043E-05    0.23052E-08    0.72148E-12
+    5    1    0.12275E-05    0.10000E+01    0.24221E+03    0.60678E-05    0.53694E-08    0.11799E-11
+    5    1    0.12275E-05    0.10000E+01    0.19533E+03    0.94614E-05    0.10190E-07    0.17726E-11
+    5    1    0.12275E-05    0.10000E+01    0.15752E+03    0.94614E-05    0.10190E-07    0.17726E-11
+    5    1    0.21419E-05    0.10000E+01    0.80645E+05    0.57650E-52    0.43048E-63    0.53095E-58
+    5    1    0.21419E-05    0.10000E+01    0.65036E+05    0.48694E-51    0.68276E-62    0.44869E-57
+    5    1    0.21419E-05    0.10000E+01    0.52449E+05    0.41318E-50    0.91347E-61    0.38089E-56
+    5    1    0.21419E-05    0.10000E+01    0.42297E+05    0.30977E-49    0.12312E-59    0.28579E-55
+    5    1    0.21419E-05    0.10000E+01    0.34111E+05    0.22193E-48    0.16686E-58    0.20505E-54
+    5    1    0.21419E-05    0.10000E+01    0.27509E+05    0.15759E-47    0.22137E-57    0.14595E-53
+    5    1    0.21419E-05    0.10000E+01    0.22184E+05    0.11023E-46    0.28436E-56    0.10249E-52
+    5    1    0.21419E-05    0.10000E+01    0.17891E+05    0.75088E-46    0.35154E-55    0.70273E-52
+    5    1    0.21419E-05    0.10000E+01    0.14428E+05    0.49432E-45    0.41714E-54    0.46738E-51
+    5    1    0.21419E-05    0.10000E+01    0.11635E+05    0.31305E-44    0.46983E-53    0.30046E-50
+    5    1    0.21419E-05    0.10000E+01    0.93834E+04    0.18914E-43    0.49485E-52    0.18512E-49
+    5    1    0.21419E-05    0.10000E+01    0.75673E+04    0.10825E-42    0.52710E-51    0.10741E-48
+    5    1    0.21419E-05    0.10000E+01    0.61026E+04    0.61933E-42    0.77389E-50    0.59178E-48
+    5    1    0.21419E-05    0.10000E+01    0.49215E+04    0.43857E-41    0.17260E-48    0.35876E-47
+    5    1    0.21419E-05    0.10000E+01    0.39689E+04    0.45093E-40    0.42724E-47    0.31087E-46
+    5    1    0.21419E-05    0.10000E+01    0.32008E+04    0.17492E-37    0.32434E-44    0.11327E-43
+    5    1    0.21419E-05    0.10000E+01    0.25813E+04    0.10981E-28    0.43153E-35    0.68787E-35
+    5    1    0.21419E-05    0.10000E+01    0.20817E+04    0.16325E-12    0.23796E-18    0.94754E-19
+    5    1    0.21419E-05    0.10000E+01    0.16788E+04    0.45220E-07    0.26781E-12    0.23697E-13
+    5    1    0.21419E-05    0.10000E+01    0.13538E+04    0.82459E-07    0.95516E-12    0.37764E-13
+    5    1    0.21419E-05    0.10000E+01    0.10918E+04    0.15260E-06    0.33943E-11    0.61038E-13
+    5    1    0.21419E-05    0.10000E+01    0.88049E+03    0.28420E-06    0.12056E-10    0.99462E-13
+    5    1    0.21419E-05    0.10000E+01    0.71007E+03    0.53029E-06    0.42778E-10    0.16313E-12
+    5    1    0.21419E-05    0.10000E+01    0.57264E+03    0.98946E-06    0.14952E-09    0.26959E-12
+    5    1    0.21419E-05    0.10000E+01    0.46180E+03    0.18415E-05    0.49722E-09    0.44949E-12
+    5    1    0.21419E-05    0.10000E+01    0.37242E+03    0.33946E-05    0.15058E-08    0.75393E-12
+    5    1    0.21419E-05    0.10000E+01    0.30034E+03    0.61149E-05    0.40225E-08    0.12589E-11
+    5    1    0.21419E-05    0.10000E+01    0.24221E+03    0.10588E-04    0.93693E-08    0.20589E-11
+    5    1    0.21419E-05    0.10000E+01    0.19533E+03    0.16510E-04    0.17780E-07    0.30930E-11
+    5    1    0.21419E-05    0.10000E+01    0.15752E+03    0.16510E-04    0.17780E-07    0.30930E-11
+    5    1    0.37375E-05    0.10000E+01    0.80645E+05    0.10060E-51    0.75117E-63    0.92647E-58
+    5    1    0.37375E-05    0.10000E+01    0.65036E+05    0.84968E-51    0.11914E-61    0.78293E-57
+    5    1    0.37375E-05    0.10000E+01    0.52449E+05    0.72097E-50    0.15940E-60    0.66463E-56
+    5    1    0.37375E-05    0.10000E+01    0.42297E+05    0.54053E-49    0.21484E-59    0.49869E-55
+    5    1    0.37375E-05    0.10000E+01    0.34111E+05    0.38726E-48    0.29115E-58    0.35780E-54
+    5    1    0.37375E-05    0.10000E+01    0.27509E+05    0.27498E-47    0.38628E-57    0.25467E-53
+    5    1    0.37375E-05    0.10000E+01    0.22184E+05    0.19235E-46    0.49619E-56    0.17884E-52
+    5    1    0.37375E-05    0.10000E+01    0.17891E+05    0.13102E-45    0.61341E-55    0.12262E-51
+    5    1    0.37375E-05    0.10000E+01    0.14428E+05    0.86256E-45    0.72789E-54    0.81554E-51
+    5    1    0.37375E-05    0.10000E+01    0.11635E+05    0.54625E-44    0.81982E-53    0.52429E-50
+    5    1    0.37375E-05    0.10000E+01    0.93834E+04    0.33004E-43    0.86349E-52    0.32302E-49
+    5    1    0.37375E-05    0.10000E+01    0.75673E+04    0.18890E-42    0.91977E-51    0.18742E-48
+    5    1    0.37375E-05    0.10000E+01    0.61026E+04    0.10807E-41    0.13504E-49    0.10326E-47
+    5    1    0.37375E-05    0.10000E+01    0.49215E+04    0.76528E-41    0.30118E-48    0.62601E-47
+    5    1    0.37375E-05    0.10000E+01    0.39689E+04    0.78684E-40    0.74551E-47    0.54244E-46
+    5    1    0.37375E-05    0.10000E+01    0.32008E+04    0.30523E-37    0.56596E-44    0.19764E-43
+    5    1    0.37375E-05    0.10000E+01    0.25813E+04    0.19161E-28    0.75300E-35    0.12003E-34
+    5    1    0.37375E-05    0.10000E+01    0.20817E+04    0.28487E-12    0.41522E-18    0.16534E-18
+    5    1    0.37375E-05    0.10000E+01    0.16788E+04    0.78907E-07    0.46732E-12    0.41350E-13
+    5    1    0.37375E-05    0.10000E+01    0.13538E+04    0.14389E-06    0.16667E-11    0.65895E-13
+    5    1    0.37375E-05    0.10000E+01    0.10918E+04    0.26628E-06    0.59228E-11    0.10651E-12
+    5    1    0.37375E-05    0.10000E+01    0.88049E+03    0.49591E-06    0.21037E-10    0.17356E-12
+    5    1    0.37375E-05    0.10000E+01    0.71007E+03    0.92533E-06    0.74645E-10    0.28465E-12
+    5    1    0.37375E-05    0.10000E+01    0.57264E+03    0.17266E-05    0.26090E-09    0.47042E-12
+    5    1    0.37375E-05    0.10000E+01    0.46180E+03    0.32134E-05    0.86762E-09    0.78433E-12
+    5    1    0.37375E-05    0.10000E+01    0.37242E+03    0.59234E-05    0.26275E-08    0.13156E-11
+    5    1    0.37375E-05    0.10000E+01    0.30034E+03    0.10670E-04    0.70190E-08    0.21968E-11
+    5    1    0.37375E-05    0.10000E+01    0.24221E+03    0.18475E-04    0.16349E-07    0.35926E-11
+    5    1    0.37375E-05    0.10000E+01    0.19533E+03    0.28808E-04    0.31026E-07    0.53971E-11
+    5    1    0.37375E-05    0.10000E+01    0.15752E+03    0.28808E-04    0.31026E-07    0.53971E-11
+    5    1    0.65217E-05    0.10000E+01    0.80645E+05    0.17553E-51    0.13107E-62    0.16166E-57
+    5    1    0.65217E-05    0.10000E+01    0.65036E+05    0.14826E-50    0.20789E-61    0.13662E-56
+    5    1    0.65217E-05    0.10000E+01    0.52449E+05    0.12581E-49    0.27814E-60    0.11597E-55
+    5    1    0.65217E-05    0.10000E+01    0.42297E+05    0.94319E-49    0.37488E-59    0.87018E-55
+    5    1    0.65217E-05    0.10000E+01    0.34111E+05    0.67575E-48    0.50804E-58    0.62434E-54
+    5    1    0.65217E-05    0.10000E+01    0.27509E+05    0.47982E-47    0.67403E-57    0.44438E-53
+    5    1    0.65217E-05    0.10000E+01    0.22184E+05    0.33563E-46    0.86583E-56    0.31207E-52
+    5    1    0.65217E-05    0.10000E+01    0.17891E+05    0.22863E-45    0.10704E-54    0.21397E-51
+    5    1    0.65217E-05    0.10000E+01    0.14428E+05    0.15051E-44    0.12701E-53    0.14231E-50
+    5    1    0.65217E-05    0.10000E+01    0.11635E+05    0.95317E-44    0.14305E-52    0.91486E-50
+    5    1    0.65217E-05    0.10000E+01    0.93834E+04    0.57590E-43    0.15067E-51    0.56365E-49
+    5    1    0.65217E-05    0.10000E+01    0.75673E+04    0.32961E-42    0.16049E-50    0.32703E-48
+    5    1    0.65217E-05    0.10000E+01    0.61026E+04    0.18857E-41    0.23563E-49    0.18018E-47
+    5    1    0.65217E-05    0.10000E+01    0.49215E+04    0.13354E-40    0.52554E-48    0.10924E-46
+    5    1    0.65217E-05    0.10000E+01    0.39689E+04    0.13730E-39    0.13009E-46    0.94653E-46
+    5    1    0.65217E-05    0.10000E+01    0.32008E+04    0.53260E-37    0.98757E-44    0.34488E-43
+    5    1    0.65217E-05    0.10000E+01    0.25813E+04    0.33434E-28    0.13139E-34    0.20944E-34
+    5    1    0.65217E-05    0.10000E+01    0.20817E+04    0.49708E-12    0.72454E-18    0.28851E-18
+    5    1    0.65217E-05    0.10000E+01    0.16788E+04    0.13769E-06    0.81545E-12    0.72153E-13
+    5    1    0.65217E-05    0.10000E+01    0.13538E+04    0.25107E-06    0.29083E-11    0.11498E-12
+    5    1    0.65217E-05    0.10000E+01    0.10918E+04    0.46465E-06    0.10335E-10    0.18585E-12
+    5    1    0.65217E-05    0.10000E+01    0.88049E+03    0.86533E-06    0.36709E-10    0.30284E-12
+    5    1    0.65217E-05    0.10000E+01    0.71007E+03    0.16146E-05    0.13025E-09    0.49669E-12
+    5    1    0.65217E-05    0.10000E+01    0.57264E+03    0.30127E-05    0.45526E-09    0.82085E-12
+    5    1    0.65217E-05    0.10000E+01    0.46180E+03    0.56071E-05    0.15140E-08    0.13686E-11
+    5    1    0.65217E-05    0.10000E+01    0.37242E+03    0.10336E-04    0.45849E-08    0.22956E-11
+    5    1    0.65217E-05    0.10000E+01    0.30034E+03    0.18619E-04    0.12248E-07    0.38332E-11
+    5    1    0.65217E-05    0.10000E+01    0.24221E+03    0.32238E-04    0.28528E-07    0.62688E-11
+    5    1    0.65217E-05    0.10000E+01    0.19533E+03    0.50269E-04    0.54138E-07    0.94177E-11
+    5    1    0.65217E-05    0.10000E+01    0.15752E+03    0.50269E-04    0.54138E-07    0.94177E-11
+    5    1    0.11380E-04    0.10000E+01    0.80645E+05    0.30630E-51    0.22872E-62    0.28209E-57
+    5    1    0.11380E-04    0.10000E+01    0.65036E+05    0.25871E-50    0.36275E-61    0.23839E-56
+    5    1    0.11380E-04    0.10000E+01    0.52449E+05    0.21952E-49    0.48533E-60    0.20237E-55
+    5    1    0.11380E-04    0.10000E+01    0.42297E+05    0.16458E-48    0.65414E-59    0.15184E-54
+    5    1    0.11380E-04    0.10000E+01    0.34111E+05    0.11791E-47    0.88650E-58    0.10894E-53
+    5    1    0.11380E-04    0.10000E+01    0.27509E+05    0.83726E-47    0.11761E-56    0.77542E-53
+    5    1    0.11380E-04    0.10000E+01    0.22184E+05    0.58566E-46    0.15108E-55    0.54455E-52
+    5    1    0.11380E-04    0.10000E+01    0.17891E+05    0.39894E-45    0.18677E-54    0.37336E-51
+    5    1    0.11380E-04    0.10000E+01    0.14428E+05    0.26263E-44    0.22163E-53    0.24832E-50
+    5    1    0.11380E-04    0.10000E+01    0.11635E+05    0.16632E-43    0.24962E-52    0.15964E-49
+    5    1    0.11380E-04    0.10000E+01    0.93834E+04    0.10049E-42    0.26292E-51    0.98354E-49
+    5    1    0.11380E-04    0.10000E+01    0.75673E+04    0.57516E-42    0.28005E-50    0.57065E-48
+    5    1    0.11380E-04    0.10000E+01    0.61026E+04    0.32905E-41    0.41117E-49    0.31441E-47
+    5    1    0.11380E-04    0.10000E+01    0.49215E+04    0.23301E-40    0.91703E-48    0.19061E-46
+    5    1    0.11380E-04    0.10000E+01    0.39689E+04    0.23958E-39    0.22699E-46    0.16516E-45
+    5    1    0.11380E-04    0.10000E+01    0.32008E+04    0.92936E-37    0.17232E-43    0.60179E-43
+    5    1    0.11380E-04    0.10000E+01    0.25813E+04    0.58341E-28    0.22927E-34    0.36547E-34
+    5    1    0.11380E-04    0.10000E+01    0.20817E+04    0.86737E-12    0.12643E-17    0.50343E-18
+    5    1    0.11380E-04    0.10000E+01    0.16788E+04    0.24026E-06    0.14229E-11    0.12590E-12
+    5    1    0.11380E-04    0.10000E+01    0.13538E+04    0.43811E-06    0.50748E-11    0.20064E-12
+    5    1    0.11380E-04    0.10000E+01    0.10918E+04    0.81078E-06    0.18034E-10    0.32429E-12
+    5    1    0.11380E-04    0.10000E+01    0.88049E+03    0.15099E-05    0.64054E-10    0.52845E-12
+    5    1    0.11380E-04    0.10000E+01    0.71007E+03    0.28175E-05    0.22728E-09    0.86670E-12
+    5    1    0.11380E-04    0.10000E+01    0.57264E+03    0.52570E-05    0.79440E-09    0.14323E-11
+    5    1    0.11380E-04    0.10000E+01    0.46180E+03    0.97841E-05    0.26418E-08    0.23882E-11
+    5    1    0.11380E-04    0.10000E+01    0.37242E+03    0.18036E-04    0.80003E-08    0.40057E-11
+    5    1    0.11380E-04    0.10000E+01    0.30034E+03    0.32488E-04    0.21371E-07    0.66888E-11
+    5    1    0.11380E-04    0.10000E+01    0.24221E+03    0.56254E-04    0.49779E-07    0.10939E-10
+    5    1    0.11380E-04    0.10000E+01    0.19533E+03    0.87716E-04    0.94467E-07    0.16433E-10
+    5    1    0.11380E-04    0.10000E+01    0.15752E+03    0.87716E-04    0.94467E-07    0.16433E-10
+    5    1    0.19857E-04    0.10000E+01    0.80645E+05    0.53447E-51    0.39910E-62    0.49223E-57
+    5    1    0.19857E-04    0.10000E+01    0.65036E+05    0.45144E-50    0.63298E-61    0.41597E-56
+    5    1    0.19857E-04    0.10000E+01    0.52449E+05    0.38305E-49    0.84687E-60    0.35312E-55
+    5    1    0.19857E-04    0.10000E+01    0.42297E+05    0.28718E-48    0.11414E-58    0.26495E-54
+    5    1    0.19857E-04    0.10000E+01    0.34111E+05    0.20575E-47    0.15469E-57    0.19010E-53
+    5    1    0.19857E-04    0.10000E+01    0.27509E+05    0.14610E-46    0.20523E-56    0.13531E-52
+    5    1    0.19857E-04    0.10000E+01    0.22184E+05    0.10219E-45    0.26363E-55    0.95020E-52
+    5    1    0.19857E-04    0.10000E+01    0.17891E+05    0.69613E-45    0.32590E-54    0.65149E-51
+    5    1    0.19857E-04    0.10000E+01    0.14428E+05    0.45828E-44    0.38673E-53    0.43330E-50
+    5    1    0.19857E-04    0.10000E+01    0.11635E+05    0.29022E-43    0.43557E-52    0.27856E-49
+    5    1    0.19857E-04    0.10000E+01    0.93834E+04    0.17535E-42    0.45877E-51    0.17162E-48
+    5    1    0.19857E-04    0.10000E+01    0.75673E+04    0.10036E-41    0.48867E-50    0.99575E-48
+    5    1    0.19857E-04    0.10000E+01    0.61026E+04    0.57417E-41    0.71746E-49    0.54863E-47
+    5    1    0.19857E-04    0.10000E+01    0.49215E+04    0.40660E-40    0.16002E-47    0.33260E-46
+    5    1    0.19857E-04    0.10000E+01    0.39689E+04    0.41805E-39    0.39609E-46    0.28820E-45
+    5    1    0.19857E-04    0.10000E+01    0.32008E+04    0.16217E-36    0.30070E-43    0.10501E-42
+    5    1    0.19857E-04    0.10000E+01    0.25813E+04    0.10180E-27    0.40007E-34    0.63772E-34
+    5    1    0.19857E-04    0.10000E+01    0.20817E+04    0.15135E-11    0.22061E-17    0.87845E-18
+    5    1    0.19857E-04    0.10000E+01    0.16788E+04    0.41923E-06    0.24829E-11    0.21969E-12
+    5    1    0.19857E-04    0.10000E+01    0.13538E+04    0.76447E-06    0.88552E-11    0.35010E-12
+    5    1    0.19857E-04    0.10000E+01    0.10918E+04    0.14148E-05    0.31468E-10    0.56587E-12
+    5    1    0.19857E-04    0.10000E+01    0.88049E+03    0.26348E-05    0.11177E-09    0.92211E-12
+    5    1    0.19857E-04    0.10000E+01    0.71007E+03    0.49163E-05    0.39659E-09    0.15123E-11
+    5    1    0.19857E-04    0.10000E+01    0.57264E+03    0.91732E-05    0.13862E-08    0.24993E-11
+    5    1    0.19857E-04    0.10000E+01    0.46180E+03    0.17073E-04    0.46097E-08    0.41672E-11
+    5    1    0.19857E-04    0.10000E+01    0.37242E+03    0.31471E-04    0.13960E-07    0.69896E-11
+    5    1    0.19857E-04    0.10000E+01    0.30034E+03    0.56690E-04    0.37292E-07    0.11672E-10
+    5    1    0.19857E-04    0.10000E+01    0.24221E+03    0.98159E-04    0.86862E-07    0.19087E-10
+    5    1    0.19857E-04    0.10000E+01    0.19533E+03    0.15306E-03    0.16484E-06    0.28675E-10
+    5    1    0.19857E-04    0.10000E+01    0.15752E+03    0.15306E-03    0.16484E-06    0.28675E-10
+    5    1    0.34650E-04    0.10000E+01    0.80645E+05    0.93261E-51    0.69640E-62    0.85892E-57
+    5    1    0.34650E-04    0.10000E+01    0.65036E+05    0.78773E-50    0.11045E-60    0.72585E-56
+    5    1    0.34650E-04    0.10000E+01    0.52449E+05    0.66841E-49    0.14777E-59    0.61617E-55
+    5    1    0.34650E-04    0.10000E+01    0.42297E+05    0.50112E-48    0.19917E-58    0.46233E-54
+    5    1    0.34650E-04    0.10000E+01    0.34111E+05    0.35903E-47    0.26992E-57    0.33171E-53
+    5    1    0.34650E-04    0.10000E+01    0.27509E+05    0.25493E-46    0.35811E-56    0.23610E-52
+    5    1    0.34650E-04    0.10000E+01    0.22184E+05    0.17832E-45    0.46002E-55    0.16580E-51
+    5    1    0.34650E-04    0.10000E+01    0.17891E+05    0.12147E-44    0.56868E-54    0.11368E-50
+    5    1    0.34650E-04    0.10000E+01    0.14428E+05    0.79967E-44    0.67482E-53    0.75608E-50
+    5    1    0.34650E-04    0.10000E+01    0.11635E+05    0.50642E-43    0.76005E-52    0.48607E-49
+    5    1    0.34650E-04    0.10000E+01    0.93834E+04    0.30598E-42    0.80053E-51    0.29947E-48
+    5    1    0.34650E-04    0.10000E+01    0.75673E+04    0.17512E-41    0.85271E-50    0.17375E-47
+    5    1    0.34650E-04    0.10000E+01    0.61026E+04    0.10019E-40    0.12519E-48    0.95732E-47
+    5    1    0.34650E-04    0.10000E+01    0.49215E+04    0.70948E-40    0.27922E-47    0.58037E-46
+    5    1    0.34650E-04    0.10000E+01    0.39689E+04    0.72947E-39    0.69116E-46    0.50289E-45
+    5    1    0.34650E-04    0.10000E+01    0.32008E+04    0.28297E-36    0.52470E-43    0.18323E-42
+    5    1    0.34650E-04    0.10000E+01    0.25813E+04    0.17764E-27    0.69809E-34    0.11128E-33
+    5    1    0.34650E-04    0.10000E+01    0.20817E+04    0.26410E-11    0.38495E-17    0.15328E-17
+    5    1    0.34650E-04    0.10000E+01    0.16788E+04    0.73153E-06    0.43325E-11    0.38335E-12
+    5    1    0.34650E-04    0.10000E+01    0.13538E+04    0.13339E-05    0.15452E-10    0.61091E-12
+    5    1    0.34650E-04    0.10000E+01    0.10918E+04    0.24687E-05    0.54910E-10    0.98742E-12
+    5    1    0.34650E-04    0.10000E+01    0.88049E+03    0.45975E-05    0.19503E-09    0.16090E-11
+    5    1    0.34650E-04    0.10000E+01    0.71007E+03    0.85786E-05    0.69203E-09    0.26389E-11
+    5    1    0.34650E-04    0.10000E+01    0.57264E+03    0.16007E-04    0.24188E-08    0.43612E-11
+    5    1    0.34650E-04    0.10000E+01    0.46180E+03    0.29791E-04    0.80437E-08    0.72715E-11
+    5    1    0.34650E-04    0.10000E+01    0.37242E+03    0.54915E-04    0.24359E-07    0.12196E-10
+    5    1    0.34650E-04    0.10000E+01    0.30034E+03    0.98921E-04    0.65072E-07    0.20366E-10
+    5    1    0.34650E-04    0.10000E+01    0.24221E+03    0.17128E-03    0.15157E-06    0.33306E-10
+    5    1    0.34650E-04    0.10000E+01    0.19533E+03    0.26708E-03    0.28763E-06    0.50036E-10
+    5    1    0.34650E-04    0.10000E+01    0.15752E+03    0.26708E-03    0.28763E-06    0.50036E-10
+    5    1    0.60462E-04    0.10000E+01    0.80645E+05    0.16274E-50    0.12152E-61    0.14988E-56
+    5    1    0.60462E-04    0.10000E+01    0.65036E+05    0.13745E-49    0.19273E-60    0.12666E-55
+    5    1    0.60462E-04    0.10000E+01    0.52449E+05    0.11663E-48    0.25786E-59    0.10752E-54
+    5    1    0.60462E-04    0.10000E+01    0.42297E+05    0.87442E-48    0.34755E-58    0.80673E-54
+    5    1    0.60462E-04    0.10000E+01    0.34111E+05    0.62648E-47    0.47100E-57    0.57882E-53
+    5    1    0.60462E-04    0.10000E+01    0.27509E+05    0.44484E-46    0.62489E-56    0.41198E-52
+    5    1    0.60462E-04    0.10000E+01    0.22184E+05    0.31116E-45    0.80270E-55    0.28932E-51
+    5    1    0.60462E-04    0.10000E+01    0.17891E+05    0.21196E-44    0.99232E-54    0.19837E-50
+    5    1    0.60462E-04    0.10000E+01    0.14428E+05    0.13954E-43    0.11775E-52    0.13193E-49
+    5    1    0.60462E-04    0.10000E+01    0.11635E+05    0.88367E-43    0.13262E-51    0.84815E-49
+    5    1    0.60462E-04    0.10000E+01    0.93834E+04    0.53391E-42    0.13969E-50    0.52256E-48
+    5    1    0.60462E-04    0.10000E+01    0.75673E+04    0.30558E-41    0.14879E-49    0.30319E-47
+    5    1    0.60462E-04    0.10000E+01    0.61026E+04    0.17483E-40    0.21845E-48    0.16705E-46
+    5    1    0.60462E-04    0.10000E+01    0.49215E+04    0.12380E-39    0.48722E-47    0.10127E-45
+    5    1    0.60462E-04    0.10000E+01    0.39689E+04    0.12729E-38    0.12060E-45    0.87752E-45
+    5    1    0.60462E-04    0.10000E+01    0.32008E+04    0.49377E-36    0.91556E-43    0.31973E-42
+    5    1    0.60462E-04    0.10000E+01    0.25813E+04    0.30997E-27    0.12181E-33    0.19417E-33
+    5    1    0.60462E-04    0.10000E+01    0.20817E+04    0.46083E-11    0.67171E-17    0.26747E-17
+    5    1    0.60462E-04    0.10000E+01    0.16788E+04    0.12765E-05    0.75599E-11    0.66893E-12
+    5    1    0.60462E-04    0.10000E+01    0.13538E+04    0.23277E-05    0.26962E-10    0.10660E-11
+    5    1    0.60462E-04    0.10000E+01    0.10918E+04    0.43077E-05    0.95814E-10    0.17230E-11
+    5    1    0.60462E-04    0.10000E+01    0.88049E+03    0.80224E-05    0.34032E-09    0.28076E-11
+    5    1    0.60462E-04    0.10000E+01    0.71007E+03    0.14969E-04    0.12075E-08    0.46048E-11
+    5    1    0.60462E-04    0.10000E+01    0.57264E+03    0.27931E-04    0.42207E-08    0.76100E-11
+    5    1    0.60462E-04    0.10000E+01    0.46180E+03    0.51983E-04    0.14036E-07    0.12688E-10
+    5    1    0.60462E-04    0.10000E+01    0.37242E+03    0.95823E-04    0.42506E-07    0.21282E-10
+    5    1    0.60462E-04    0.10000E+01    0.30034E+03    0.17261E-03    0.11355E-06    0.35538E-10
+    5    1    0.60462E-04    0.10000E+01    0.24221E+03    0.29888E-03    0.26448E-06    0.58118E-10
+    5    1    0.60462E-04    0.10000E+01    0.19533E+03    0.46603E-03    0.50190E-06    0.87310E-10
+    5    1    0.60462E-04    0.10000E+01    0.15752E+03    0.46603E-03    0.50190E-06    0.87310E-10
+    5    1    0.10550E-03    0.10000E+01    0.80645E+05    0.28396E-50    0.21204E-61    0.26152E-56
+    5    1    0.10550E-03    0.10000E+01    0.65036E+05    0.23985E-49    0.33630E-60    0.22101E-55
+    5    1    0.10550E-03    0.10000E+01    0.52449E+05    0.20352E-48    0.44994E-59    0.18761E-54
+    5    1    0.10550E-03    0.10000E+01    0.42297E+05    0.15258E-47    0.60645E-58    0.14077E-53
+    5    1    0.10550E-03    0.10000E+01    0.34111E+05    0.10932E-46    0.82187E-57    0.10100E-52
+    5    1    0.10550E-03    0.10000E+01    0.27509E+05    0.77622E-46    0.10904E-55    0.71888E-52
+    5    1    0.10550E-03    0.10000E+01    0.22184E+05    0.54296E-45    0.14007E-54    0.50484E-51
+    5    1    0.10550E-03    0.10000E+01    0.17891E+05    0.36985E-44    0.17315E-53    0.34614E-50
+    5    1    0.10550E-03    0.10000E+01    0.14428E+05    0.24348E-43    0.20547E-52    0.23021E-49
+    5    1    0.10550E-03    0.10000E+01    0.11635E+05    0.15420E-42    0.23142E-51    0.14800E-48
+    5    1    0.10550E-03    0.10000E+01    0.93834E+04    0.93164E-42    0.24375E-50    0.91183E-48
+    5    1    0.10550E-03    0.10000E+01    0.75673E+04    0.53322E-41    0.25963E-49    0.52904E-47
+    5    1    0.10550E-03    0.10000E+01    0.61026E+04    0.30506E-40    0.38119E-48    0.29149E-46
+    5    1    0.10550E-03    0.10000E+01    0.49215E+04    0.21602E-39    0.85017E-47    0.17671E-45
+    5    1    0.10550E-03    0.10000E+01    0.39689E+04    0.22211E-38    0.21044E-45    0.15312E-44
+    5    1    0.10550E-03    0.10000E+01    0.32008E+04    0.86160E-36    0.15976E-42    0.55791E-42
+    5    1    0.10550E-03    0.10000E+01    0.25813E+04    0.54087E-27    0.21256E-33    0.33882E-33
+    5    1    0.10550E-03    0.10000E+01    0.20817E+04    0.80413E-11    0.11721E-16    0.46672E-17
+    5    1    0.10550E-03    0.10000E+01    0.16788E+04    0.22274E-05    0.13192E-10    0.11672E-11
+    5    1    0.10550E-03    0.10000E+01    0.13538E+04    0.40616E-05    0.47048E-10    0.18601E-11
+    5    1    0.10550E-03    0.10000E+01    0.10918E+04    0.75167E-05    0.16719E-09    0.30065E-11
+    5    1    0.10550E-03    0.10000E+01    0.88049E+03    0.13999E-04    0.59384E-09    0.48992E-11
+    5    1    0.10550E-03    0.10000E+01    0.71007E+03    0.26120E-04    0.21071E-08    0.80351E-11
+    5    1    0.10550E-03    0.10000E+01    0.57264E+03    0.48737E-04    0.73648E-08    0.13279E-10
+    5    1    0.10550E-03    0.10000E+01    0.46180E+03    0.90707E-04    0.24491E-07    0.22140E-10
+    5    1    0.10550E-03    0.10000E+01    0.37242E+03    0.16721E-03    0.74170E-07    0.37136E-10
+    5    1    0.10550E-03    0.10000E+01    0.30034E+03    0.30120E-03    0.19813E-06    0.62011E-10
+    5    1    0.10550E-03    0.10000E+01    0.24221E+03    0.52152E-03    0.46150E-06    0.10141E-09
+    5    1    0.10550E-03    0.10000E+01    0.19533E+03    0.81320E-03    0.87579E-06    0.15235E-09
+    5    1    0.10550E-03    0.10000E+01    0.15752E+03    0.81320E-03    0.87579E-06    0.15235E-09
+    5    1    0.18409E-03    0.10000E+01    0.80645E+05    0.49550E-50    0.37000E-61    0.45635E-56
+    5    1    0.18409E-03    0.10000E+01    0.65036E+05    0.41852E-49    0.58683E-60    0.38564E-55
+    5    1    0.18409E-03    0.10000E+01    0.52449E+05    0.35513E-48    0.78513E-59    0.32737E-54
+    5    1    0.18409E-03    0.10000E+01    0.42297E+05    0.26624E-47    0.10582E-57    0.24564E-53
+    5    1    0.18409E-03    0.10000E+01    0.34111E+05    0.19075E-46    0.14341E-56    0.17624E-52
+    5    1    0.18409E-03    0.10000E+01    0.27509E+05    0.13545E-45    0.19027E-55    0.12544E-51
+    5    1    0.18409E-03    0.10000E+01    0.22184E+05    0.94743E-45    0.24441E-54    0.88092E-51
+    5    1    0.18409E-03    0.10000E+01    0.17891E+05    0.64537E-44    0.30214E-53    0.60399E-50
+    5    1    0.18409E-03    0.10000E+01    0.14428E+05    0.42486E-43    0.35853E-52    0.40171E-49
+    5    1    0.18409E-03    0.10000E+01    0.11635E+05    0.26906E-42    0.40381E-51    0.25825E-48
+    5    1    0.18409E-03    0.10000E+01    0.93834E+04    0.16257E-41    0.42532E-50    0.15911E-47
+    5    1    0.18409E-03    0.10000E+01    0.75673E+04    0.93044E-41    0.45304E-49    0.92315E-47
+    5    1    0.18409E-03    0.10000E+01    0.61026E+04    0.53231E-40    0.66515E-48    0.50863E-46
+    5    1    0.18409E-03    0.10000E+01    0.49215E+04    0.37695E-39    0.14835E-46    0.30835E-45
+    5    1    0.18409E-03    0.10000E+01    0.39689E+04    0.38757E-38    0.36721E-45    0.26719E-44
+    5    1    0.18409E-03    0.10000E+01    0.32008E+04    0.15034E-35    0.27877E-42    0.97352E-42
+    5    1    0.18409E-03    0.10000E+01    0.25813E+04    0.94379E-27    0.37090E-33    0.59122E-33
+    5    1    0.18409E-03    0.10000E+01    0.20817E+04    0.14032E-10    0.20452E-16    0.81440E-17
+    5    1    0.18409E-03    0.10000E+01    0.16788E+04    0.38867E-05    0.23019E-10    0.20368E-11
+    5    1    0.18409E-03    0.10000E+01    0.13538E+04    0.70873E-05    0.82096E-10    0.32458E-11
+    5    1    0.18409E-03    0.10000E+01    0.10918E+04    0.13116E-04    0.29174E-09    0.52462E-11
+    5    1    0.18409E-03    0.10000E+01    0.88049E+03    0.24427E-04    0.10362E-08    0.85487E-11
+    5    1    0.18409E-03    0.10000E+01    0.71007E+03    0.45578E-04    0.36768E-08    0.14021E-10
+    5    1    0.18409E-03    0.10000E+01    0.57264E+03    0.85044E-04    0.12851E-07    0.23171E-10
+    5    1    0.18409E-03    0.10000E+01    0.46180E+03    0.15828E-03    0.42736E-07    0.38633E-10
+    5    1    0.18409E-03    0.10000E+01    0.37242E+03    0.29176E-03    0.12942E-06    0.64800E-10
+    5    1    0.18409E-03    0.10000E+01    0.30034E+03    0.52557E-03    0.34573E-06    0.10821E-09
+    5    1    0.18409E-03    0.10000E+01    0.24221E+03    0.91002E-03    0.80529E-06    0.17696E-09
+    5    1    0.18409E-03    0.10000E+01    0.19533E+03    0.14190E-02    0.15282E-05    0.26584E-09
+    5    1    0.18409E-03    0.10000E+01    0.15752E+03    0.14190E-02    0.15282E-05    0.26584E-09
+    5    1    0.32123E-03    0.10000E+01    0.80645E+05    0.86462E-50    0.64562E-61    0.79629E-56
+    5    1    0.32123E-03    0.10000E+01    0.65036E+05    0.73030E-49    0.10240E-59    0.67293E-55
+    5    1    0.32123E-03    0.10000E+01    0.52449E+05    0.61967E-48    0.13700E-58    0.57125E-54
+    5    1    0.32123E-03    0.10000E+01    0.42297E+05    0.46458E-47    0.18465E-57    0.42862E-53
+    5    1    0.32123E-03    0.10000E+01    0.34111E+05    0.33285E-46    0.25024E-56    0.30753E-52
+    5    1    0.32123E-03    0.10000E+01    0.27509E+05    0.23634E-45    0.33200E-55    0.21889E-51
+    5    1    0.32123E-03    0.10000E+01    0.22184E+05    0.16532E-44    0.42648E-54    0.15372E-50
+    5    1    0.32123E-03    0.10000E+01    0.17891E+05    0.11261E-43    0.52722E-53    0.10539E-49
+    5    1    0.32123E-03    0.10000E+01    0.14428E+05    0.74136E-43    0.62562E-52    0.70095E-49
+    5    1    0.32123E-03    0.10000E+01    0.11635E+05    0.46950E-42    0.70463E-51    0.45063E-48
+    5    1    0.32123E-03    0.10000E+01    0.93834E+04    0.28367E-41    0.74216E-50    0.27764E-47
+    5    1    0.32123E-03    0.10000E+01    0.75673E+04    0.16236E-40    0.79053E-49    0.16108E-46
+    5    1    0.32123E-03    0.10000E+01    0.61026E+04    0.92885E-40    0.11607E-47    0.88752E-46
+    5    1    0.32123E-03    0.10000E+01    0.49215E+04    0.65775E-39    0.25886E-46    0.53805E-45
+    5    1    0.32123E-03    0.10000E+01    0.39689E+04    0.67628E-38    0.64076E-45    0.46623E-44
+    5    1    0.32123E-03    0.10000E+01    0.32008E+04    0.26234E-35    0.48644E-42    0.16987E-41
+    5    1    0.32123E-03    0.10000E+01    0.25813E+04    0.16469E-26    0.64720E-33    0.10316E-32
+    5    1    0.32123E-03    0.10000E+01    0.20817E+04    0.24484E-10    0.35688E-16    0.14211E-16
+    5    1    0.32123E-03    0.10000E+01    0.16788E+04    0.67820E-05    0.40166E-10    0.35540E-11
+    5    1    0.32123E-03    0.10000E+01    0.13538E+04    0.12367E-04    0.14325E-09    0.56636E-11
+    5    1    0.32123E-03    0.10000E+01    0.10918E+04    0.22887E-04    0.50906E-09    0.91542E-11
+    5    1    0.32123E-03    0.10000E+01    0.88049E+03    0.42623E-04    0.18081E-08    0.14917E-10
+    5    1    0.32123E-03    0.10000E+01    0.71007E+03    0.79532E-04    0.64157E-08    0.24465E-10
+    5    1    0.32123E-03    0.10000E+01    0.57264E+03    0.14840E-03    0.22424E-07    0.40432E-10
+    5    1    0.32123E-03    0.10000E+01    0.46180E+03    0.27619E-03    0.74572E-07    0.67413E-10
+    5    1    0.32123E-03    0.10000E+01    0.37242E+03    0.50911E-03    0.22583E-06    0.11307E-09
+    5    1    0.32123E-03    0.10000E+01    0.30034E+03    0.91708E-03    0.60328E-06    0.18881E-09
+    5    1    0.32123E-03    0.10000E+01    0.24221E+03    0.15879E-02    0.14052E-05    0.30878E-09
+    5    1    0.32123E-03    0.10000E+01    0.19533E+03    0.24760E-02    0.26666E-05    0.46388E-09
+    5    1    0.32123E-03    0.10000E+01    0.15752E+03    0.24760E-02    0.26666E-05    0.46388E-09
+    5    2    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.30142E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    2    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.52597E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    2    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.91778E-08    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    2    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.16015E-07    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    5    2    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.27945E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    5    2    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.48762E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    5    2    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.85086E-07    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    5    2    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.71837E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.14847E-06    0.21932E+07    0.57448E-32    0.90506E-91    0.45338E-05    0.90000E+03
+    5    2    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.40653E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.25907E-06    0.18214E+07    0.17525E-31    0.51195E-75    0.54820E-05    0.90000E+03
+    5    2    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.33167E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.45206E-06    0.15145E+07    0.53194E-31    0.41737E-62    0.66021E-05    0.90000E+03
+    5    2    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.17272E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.78882E-06    0.12578E+07    0.16206E-30    0.21710E-51    0.79511E-05    0.90000E+03
+    5    2    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.11262E-44    0.67064E-05    0.42297E-05    0.37644E+02    0.13765E-05    0.10445E+07    0.49376E-30    0.14132E-42    0.95741E-05    0.90000E+03
+    5    2    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.19410E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.24018E-05    0.86742E+06    0.15043E-29    0.24299E-35    0.11528E-04    0.90000E+03
+    5    2    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.16438E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.41910E-05    0.72035E+06    0.45832E-29    0.20512E-29    0.13882E-04    0.90000E+03
+    5    2    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.11445E-26    0.11686E-04    0.73852E-05    0.20001E+03    0.73131E-05    0.59822E+06    0.13964E-28    0.14222E-24    0.16716E-04    0.90000E+03
+    5    2    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.10047E-22    0.14063E-04    0.88930E-05    0.34900E+03    0.12761E-04    0.49680E+06    0.42543E-28    0.12416E-20    0.20129E-04    0.90000E+03
+    5    2    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.15205E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.22267E-04    0.41311E+06    0.12910E-27    0.18655E-17    0.24207E-04    0.90000E+03
+    5    2    0.58864E-11    0.10000E+01    0.16087E-01    0.30718E-01    0.51398E-11    0.58565E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.38855E-04    0.34307E+06    0.39289E-27    0.71171E-15    0.29147E-04    0.89996E+03
+    5    2    0.10271E-10    0.10000E+01    0.22941E-01    0.43822E-01    0.84772E-11    0.69707E-15    0.24574E-04    0.15519E-04    0.18542E+04    0.67799E-04    0.28490E+06    0.11868E-26    0.83653E-13    0.35071E-04    0.89948E+03
+    5    2    0.17923E-10    0.10000E+01    0.32872E-01    0.63485E-01    0.20359E-10    0.32244E-13    0.29496E-04    0.18785E-04    0.32355E+04    0.11831E-03    0.23629E+06    0.35099E-26    0.38047E-11    0.42136E-04    0.89636E+03
+    5    2    0.31275E-10    0.10000E+01    0.48037E-01    0.92666E-01    0.50008E-10    0.70516E-12    0.35083E-04    0.22997E-04    0.56458E+04    0.20644E-03    0.19521E+06    0.10053E-25    0.81295E-10    0.50521E-04    0.88443E+03
+    5    2    0.54572E-10    0.10000E+01    0.72062E-01    0.13098E+00    0.10801E-09    0.86077E-11    0.40828E-04    0.28464E-04    0.98516E+04    0.36022E-03    0.15982E+06    0.28498E-25    0.95984E-09    0.60815E-04    0.85420E+03
+    5    2    0.95225E-10    0.10000E+01    0.10657E+00    0.17216E+00    0.19994E-09    0.62673E-10    0.46545E-04    0.34500E-04    0.17190E+05    0.62856E-03    0.12965E+06    0.82903E-25    0.66602E-08    0.74081E-04    0.80151E+03
+    5    2    0.16616E-09    0.10000E+01    0.14775E+00    0.21376E+00    0.33040E-09    0.28732E-09    0.52721E-04    0.39575E-04    0.29996E+05    0.10968E-02    0.10450E+06    0.24627E-24    0.28508E-07    0.91386E-04    0.73519E+03
+    5    2    0.28994E-09    0.10000E+01    0.19257E+00    0.26468E+00    0.57628E-09    0.91065E-09    0.59924E-04    0.43952E-04    0.52341E+05    0.19138E-02    0.83683E+05    0.71183E-24    0.82062E-07    0.11305E-03    0.66493E+03
+    5    2    0.50593E-09    0.10000E+01    0.24771E+00    0.33587E+00    0.11324E-08    0.22535E-08    0.67981E-04    0.49492E-04    0.91333E+05    0.33395E-02    0.66234E+05    0.19838E-23    0.17774E-06    0.14016E-03    0.58698E+03
+    5    2    0.88282E-09    0.10000E+01    0.32744E+00    0.43353E+00    0.21589E-08    0.48651E-08    0.75919E-04    0.57328E-04    0.15937E+06    0.58273E-02    0.51278E+05    0.55715E-23    0.32052E-06    0.17721E-03    0.49230E+03
+    5    2    0.15405E-08    0.10000E+01    0.43652E+00    0.55310E+00    0.36988E-08    0.98477E-08    0.85097E-04    0.66497E-04    0.27809E+06    0.10168E-01    0.38933E+05    0.16181E-22    0.52330E-06    0.23020E-03    0.38746E+03
+    5    2    0.26880E-08    0.10000E+01    0.38736E+00    0.88922E+00    0.14551E-07    0.22963E-07    0.82427E-04    0.79986E-04    0.11884E+06    0.10889E-01    0.53689E+04    0.17077E-21    0.71876E-06    0.54496E-03    0.20158E+03
+    5    2    0.46905E-08    0.10000E+01    0.48034E+00    0.10087E+01    0.25608E-07    0.43864E-07    0.10077E-03    0.84690E-04    0.20736E+06    0.19001E-01    0.40133E+04    0.51533E-21    0.11619E-05    0.72577E-03    0.15187E+03
+    5    2    0.81846E-08    0.10000E+01    0.58041E+00    0.11251E+01    0.44586E-07    0.82933E-07    0.12577E-03    0.88431E-04    0.36184E+06    0.33156E-01    0.30000E+04    0.15591E-20    0.18709E-05    0.96869E-03    0.11303E+03
+    5    2    0.14282E-07    0.10000E+01    0.68581E+00    0.12371E+01    0.76583E-07    0.15540E-06    0.15963E-03    0.91389E-04    0.63138E+06    0.57855E-01    0.22396E+04    0.47352E-20    0.30033E-05    0.12961E-02    0.83280E+02
+    5    2    0.24920E-07    0.10000E+01    0.79397E+00    0.13428E+01    0.13013E-06    0.28869E-06    0.20565E-03    0.93730E-04    0.11017E+07    0.10095E+00    0.16719E+04    0.14391E-19    0.48099E-05    0.17353E-02    0.61004E+02
+    5    2    0.43485E-07    0.10000E+01    0.90339E+00    0.14421E+01    0.21827E-06    0.53228E-06    0.26765E-03    0.95624E-04    0.19224E+07    0.17616E+00    0.12465E+04    0.43855E-19    0.76817E-05    0.23269E-02    0.44452E+02
+    5    2    0.75878E-07    0.10000E+01    0.10114E+01    0.15335E+01    0.36358E-06    0.97427E-06    0.35178E-03    0.97178E-04    0.33546E+07    0.30739E+00    0.93059E+03    0.13333E-18    0.12243E-04    0.31165E-02    0.32357E+02
+    5    2    0.13240E-06    0.10000E+01    0.11174E+01    0.16179E+01    0.59861E-06    0.17722E-05    0.46462E-03    0.98496E-04    0.58535E+07    0.53637E+00    0.69382E+03    0.40581E-18    0.19458E-04    0.41784E-02    0.23485E+02
+    5    2    0.23103E-06    0.10000E+01    0.12193E+01    0.16941E+01    0.97814E-06    0.31994E-05    0.61686E-03    0.99625E-04    0.10214E+08    0.93593E+00    0.51796E+03    0.12123E-17    0.30835E-04    0.55694E-02    0.17077E+02
+    5    2    0.40314E-06    0.10000E+01    0.12314E+01    0.17028E+01    0.27596E-05    0.56013E-05    0.10416E-02    0.99750E-04    0.17823E+08    0.16331E+01    0.50000E+03    0.22502E-17    0.53162E-04    0.57605E-02    0.16437E+02
+    5    2    0.70346E-06    0.10000E+01    0.12314E+01    0.17028E+01    0.84026E-05    0.97739E-05    0.18175E-02    0.99750E-04    0.31100E+08    0.28497E+01    0.50000E+03    0.39265E-17    0.92765E-04    0.57605E-02    0.16437E+02
+    5    2    0.12275E-05    0.10000E+01    0.12314E+01    0.17028E+01    0.25584E-04    0.17055E-04    0.31714E-02    0.99750E-04    0.54267E+08    0.49726E+01    0.50000E+03    0.68515E-17    0.16187E-03    0.57605E-02    0.16437E+02
+    5    2    0.21419E-05    0.10000E+01    0.12314E+01    0.17028E+01    0.77900E-04    0.29760E-04    0.55339E-02    0.99750E-04    0.94693E+08    0.86769E+01    0.50000E+03    0.11955E-16    0.28245E-03    0.57605E-02    0.16437E+02
+    5    2    0.37375E-05    0.10000E+01    0.12314E+01    0.17028E+01    0.23719E-03    0.51929E-04    0.96563E-02    0.99750E-04    0.16523E+09    0.15141E+02    0.50000E+03    0.20862E-16    0.49286E-03    0.57605E-02    0.16437E+02
+    5    2    0.65217E-05    0.10000E+01    0.12314E+01    0.17028E+01    0.72220E-03    0.90613E-04    0.16850E-01    0.99750E-04    0.28832E+09    0.26420E+02    0.50000E+03    0.36402E-16    0.86001E-03    0.57605E-02    0.16437E+02
+    5    2    0.11380E-04    0.10000E+01    0.12314E+01    0.17028E+01    0.21990E-02    0.15811E-03    0.29402E-01    0.99750E-04    0.50310E+09    0.46101E+02    0.50000E+03    0.63520E-16    0.15007E-02    0.57605E-02    0.16437E+02
+    5    2    0.19857E-04    0.10000E+01    0.12314E+01    0.17028E+01    0.66954E-02    0.27590E-03    0.51304E-01    0.99750E-04    0.87789E+09    0.80443E+02    0.50000E+03    0.11084E-15    0.26186E-02    0.57605E-02    0.16437E+02
+    5    2    0.34650E-04    0.10000E+01    0.12314E+01    0.17028E+01    0.20386E-01    0.48143E-03    0.89523E-01    0.99750E-04    0.15319E+10    0.14037E+03    0.50000E+03    0.19341E-15    0.45693E-02    0.57605E-02    0.16437E+02
+    5    2    0.60462E-04    0.10000E+01    0.12314E+01    0.17028E+01    0.62073E-01    0.84006E-03    0.15621E+00    0.99750E-04    0.26730E+10    0.24493E+03    0.50000E+03    0.33748E-15    0.79731E-02    0.57605E-02    0.16437E+02
+    5    2    0.10550E-03    0.10000E+01    0.12314E+01    0.17028E+01    0.18900E+00    0.14659E-02    0.27258E+00    0.99750E-04    0.46642E+10    0.42739E+03    0.50000E+03    0.58888E-15    0.13913E-01    0.57605E-02    0.16437E+02
+    5    2    0.18409E-03    0.10000E+01    0.12314E+01    0.17028E+01    0.57547E+00    0.25578E-02    0.47564E+00    0.99750E-04    0.81388E+10    0.74578E+03    0.50000E+03    0.10276E-14    0.24277E-01    0.57605E-02    0.16437E+02
+    5    2    0.32123E-03    0.10000E+01    0.12314E+01    0.17028E+01    0.17522E+01    0.44633E-02    0.82995E+00    0.99750E-04    0.14202E+11    0.13013E+04    0.50000E+03    0.17930E-14    0.42361E-01    0.57605E-02    0.16437E+02
+    5    2    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    5    2    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    5    2    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    5    2    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    5    2    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    5    2    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    5    2    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    5    2    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    5    2    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    5    2    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    5    2    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    5    2    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    5    2    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    5    2    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    5    2    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    5    2    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    5    2    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    5    2    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    5    2    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    5    2    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    5    2    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    5    2    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    5    2    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    5    2    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    5    2    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    5    2    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    5    2    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    5    2    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    5    2    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    5    2    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    5    2    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    5    2    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    5    2    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    5    2    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    5    2    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    5    2    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    5    2    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    5    2    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    5    2    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    5    2    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    5    2    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    5    2    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    5    2    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    5    2    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    5    2    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    5    2    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    5    2    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    5    2    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    5    2    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    5    2    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    5    2    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    5    2    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    5    2    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    5    2    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    5    2    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    5    2    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    5    2    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    5    2    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    5    2    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    5    2    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    5    2    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    5    2    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    5    2    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    5    2    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    5    2    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    5    2    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    5    2    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    5    2    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    5    2    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    5    2    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    5    2    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    5    2    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    5    2    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    5    2    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    5    2    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    5    2    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    5    2    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    5    2    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    5    2    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    5    2    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    5    2    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    5    2    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    5    2    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    5    2    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    5    2    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    5    2    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    5    2    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    5    2    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    5    2    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    5    2    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    5    2    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    5    2    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    5    2    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    5    2    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    5    2    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    5    2    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    5    2    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    5    2    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    5    2    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    5    2    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    5    2    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    5    2    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    5    2    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    5    2    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    5    2    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    5    2    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    5    2    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    5    2    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    5    2    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    5    2    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    5    2    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    5    2    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    5    2    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    5    2    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    5    2    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    5    2    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    5    2    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    5    2    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    5    2    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    5    2    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    5    2    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    5    2    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    5    2    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    5    2    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    5    2    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    5    2    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    5    2    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    5    2    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    5    2    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    5    2    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    5    2    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    5    2    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    5    2    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    5    2    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    5    2    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    5    2    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    5    2    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    5    2    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    5    2    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    5    2    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    5    2    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    5    2    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    5    2    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    5    2    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    5    2    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    5    2    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    5    2    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    5    2    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    5    2    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    5    2    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    5    2    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    5    2    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    5    2    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    5    2    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    5    2    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    5    2    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    5    2    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    5    2    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    5    2    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    5    2    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    5    2    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    5    2    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    5    2    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    5    2    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    5    2    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    5    2    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    5    2    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    5    2    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    5    2    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    5    2    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    5    2    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    5    2    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    5    2    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    5    2    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    5    2    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    5    2    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    5    2    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    5    2    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    5    2    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    5    2    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    5    2    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    5    2    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    5    2    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    5    2    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    5    2    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    5    2    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    5    2    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    5    2    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    5    2    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    5    2    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    5    2    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    5    2    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    5    2    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    5    2    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    5    2    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    5    2    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    5    2    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    5    2    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    5    2    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    5    2    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    5    2    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    5    2    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    5    2    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    5    2    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    5    2    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    5    2    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    5    2    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    5    2    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    5    2    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    5    2    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    5    2    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    5    2    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    5    2    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    5    2    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    5    2    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    5    2    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    5    2    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    5    2    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    5    2    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    5    2    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    5    2    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    5    2    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    5    2    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    5    2    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    5    2    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    5    2    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    5    2    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    5    2    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    5    2    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    5    2    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    5    2    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    5    2    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    5    2    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    5    2    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    5    2    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    5    2    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    5    2    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    5    2    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    5    2    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    5    2    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    5    2    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    5    2    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    5    2    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    5    2    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    5    2    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    5    2    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    5    2    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    5    2    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    5    2    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    5    2    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    5    2    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    5    2    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    5    2    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    5    2    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    5    2    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    5    2    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    5    2    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    5    2    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    5    2    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    5    2    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    5    2    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    5    2    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    5    2    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    5    2    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    5    2    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    5    2    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    5    2    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    5    2    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    5    2    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    5    2    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    5    2    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    5    2    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    5    2    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    5    2    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    5    2    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    5    2    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    5    2    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    5    2    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    5    2    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    5    2    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    5    2    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    5    2    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    5    2    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    5    2    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    5    2    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    5    2    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    5    2    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    5    2    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    5    2    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    5    2    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    5    2    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    5    2    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    5    2    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    5    2    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    5    2    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    5    2    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    5    2    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    5    2    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    5    2    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    5    2    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    5    2    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    5    2    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    5    2    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    5    2    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    5    2    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    5    2    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    5    2    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    5    2    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    5    2    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    5    2    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    5    2    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    5    2    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    5    2    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    5    2    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    5    2    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    5    2    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    5    2    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    5    2    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    5    2    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    5    2    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    5    2    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    5    2    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    5    2    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    5    2    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    5    2    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    5    2    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    5    2    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    5    2    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    5    2    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    5    2    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    5    2    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    5    2    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    5    2    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    5    2    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    5    2    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    5    2    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    5    2    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    5    2    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    5    2    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    5    2    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    5    2    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    5    2    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    5    2    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    5    2    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    5    2    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    5    2    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    5    2    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    5    2    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    5    2    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    5    2    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    5    2    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    5    2    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    5    2    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    5    2    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    5    2    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    5    2    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    5    2    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    5    2    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    5    2    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    5    2    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    5    2    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    5    2    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    5    2    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    5    2    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    5    2    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    5    2    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    5    2    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    5    2    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    5    2    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    5    2    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    5    2    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    5    2    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    5    2    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    5    2    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    5    2    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    5    2    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    5    2    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    5    2    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    5    2    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    5    2    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    5    2    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    5    2    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    5    2    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    5    2    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    5    2    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    5    2    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    5    2    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    5    2    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    5    2    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    5    2    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    5    2    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    5    2    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    5    2    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    5    2    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    5    2    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    5    2    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    5    2    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    5    2    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    5    2    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    5    2    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    5    2    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    5    2    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    5    2    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    5    2    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    5    2    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    5    2    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    5    2    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    5    2    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    5    2    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    5    2    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    5    2    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    5    2    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    5    2    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    5    2    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    5    2    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    5    2    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    5    2    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    5    2    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    5    2    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    5    2    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    5    2    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    5    2    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    5    2    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    5    2    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    5    2    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    5    2    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    5    2    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    5    2    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    5    2    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    5    2    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    5    2    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    5    2    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    5    2    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    5    2    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    5    2    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    5    2    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    5    2    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    5    2    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    5    2    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    5    2    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    5    2    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    5    2    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    5    2    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    5    2    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    5    2    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    5    2    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    5    2    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    5    2    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    5    2    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    5    2    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    5    2    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    5    2    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    5    2    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    5    2    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    5    2    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    5    2    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    5    2    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    5    2    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    5    2    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    5    2    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    5    2    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    5    2    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    5    2    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    5    2    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    5    2    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    5    2    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    5    2    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    5    2    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    5    2    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    5    2    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    5    2    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    5    2    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    5    2    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    5    2    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    5    2    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    5    2    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    5    2    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    5    2    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    5    2    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    5    2    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    5    2    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    5    2    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    5    2    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    5    2    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    5    2    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    5    2    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    5    2    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    5    2    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    5    2    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    5    2    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    5    2    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    5    2    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    5    2    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    5    2    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    5    2    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    5    2    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    5    2    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    5    2    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    5    2    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    5    2    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    5    2    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    5    2    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    5    2    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    5    2    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    5    2    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    5    2    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    5    2    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    5    2    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    5    2    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    5    2    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    5    2    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24239E-69
+    5    2    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18973E-68
+    5    2    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24432E-67
+    5    2    0.58864E-11    0.10000E+01    0.42297E+05    0.69440E-55    0.81224E-65    0.40732E-66
+    5    2    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74407E-65
+    5    2    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    5    2    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    5    2    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    5    2    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    5    2    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    5    2    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    5    2    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    5    2    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    5    2    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33815E-50    0.37145E-54
+    5    2    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    5    2    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    5    2    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    5    2    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    5    2    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    5    2    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    5    2    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23277E-12    0.48928E-19
+    5    2    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    5    2    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    5    2    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    5    2    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    5    2    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    5    2    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    5    2    0.58864E-11    0.10000E+01    0.24221E+03    0.77296E-06    0.71310E-09    0.48594E-17
+    5    2    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    5    2    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    5    2    0.10271E-10    0.10000E+01    0.80645E+05    0.28442E-58    0.21427E-69    0.92905E-69
+    5    2    0.10271E-10    0.10000E+01    0.65036E+05    0.25727E-57    0.63704E-68    0.74332E-68
+    5    2    0.10271E-10    0.10000E+01    0.52449E+05    0.37510E-56    0.22053E-66    0.73089E-67
+    5    2    0.10271E-10    0.10000E+01    0.42297E+05    0.66181E-55    0.77497E-65    0.87475E-66
+    5    2    0.10271E-10    0.10000E+01    0.34111E+05    0.12105E-53    0.26795E-63    0.13780E-64
+    5    2    0.10271E-10    0.10000E+01    0.27509E+05    0.21884E-52    0.89973E-62    0.24574E-63
+    5    2    0.10271E-10    0.10000E+01    0.22184E+05    0.38373E-51    0.28684E-60    0.43687E-62
+    5    2    0.10271E-10    0.10000E+01    0.17891E+05    0.63887E-50    0.85156E-59    0.73557E-61
+    5    2    0.10271E-10    0.10000E+01    0.14428E+05    0.99626E-49    0.23814E-57    0.11537E-59
+    5    2    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64585E-56    0.17064E-58
+    5    2    0.10271E-10    0.10000E+01    0.93834E+04    0.21015E-46    0.17345E-54    0.24421E-57
+    5    2    0.10271E-10    0.10000E+01    0.75673E+04    0.29666E-45    0.46498E-53    0.34506E-56
+    5    2    0.10271E-10    0.10000E+01    0.61026E+04    0.41737E-44    0.12464E-51    0.48597E-55
+    5    2    0.10271E-10    0.10000E+01    0.49215E+04    0.58686E-43    0.33415E-50    0.68411E-54
+    5    2    0.10271E-10    0.10000E+01    0.39689E+04    0.82516E-42    0.89576E-49    0.96302E-53
+    5    2    0.10271E-10    0.10000E+01    0.32008E+04    0.36487E-39    0.77647E-46    0.42632E-50
+    5    2    0.10271E-10    0.10000E+01    0.25813E+04    0.26698E-30    0.13025E-36    0.31230E-41
+    5    2    0.10271E-10    0.10000E+01    0.20817E+04    0.50710E-14    0.11035E-19    0.59395E-25
+    5    2    0.10271E-10    0.10000E+01    0.16788E+04    0.17119E-08    0.16285E-13    0.20068E-19
+    5    2    0.10271E-10    0.10000E+01    0.13538E+04    0.36739E-08    0.61849E-13    0.43079E-19
+    5    2    0.10271E-10    0.10000E+01    0.10918E+04    0.77114E-08    0.23060E-12    0.90441E-19
+    5    2    0.10271E-10    0.10000E+01    0.88049E+03    0.15843E-07    0.84900E-12    0.18583E-18
+    5    2    0.10271E-10    0.10000E+01    0.71007E+03    0.31924E-07    0.30916E-11    0.37451E-18
+    5    2    0.10271E-10    0.10000E+01    0.57264E+03    0.63256E-07    0.10999E-10    0.74212E-18
+    5    2    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36994E-10    0.14468E-17
+    5    2    0.10271E-10    0.10000E+01    0.37242E+03    0.23533E-06    0.11280E-09    0.27612E-17
+    5    2    0.10271E-10    0.10000E+01    0.30034E+03    0.43464E-06    0.30256E-09    0.50997E-17
+    5    2    0.10271E-10    0.10000E+01    0.24221E+03    0.76574E-06    0.70645E-09    0.89846E-17
+    5    2    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    5    2    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13425E-08    0.14160E-16
+    5    2    0.17923E-10    0.10000E+01    0.80645E+05    0.56931E-58    0.39421E-69    0.34132E-68
+    5    2    0.17923E-10    0.10000E+01    0.65036E+05    0.46702E-57    0.87507E-68    0.28293E-67
+    5    2    0.17923E-10    0.10000E+01    0.52449E+05    0.52476E-56    0.24066E-66    0.24648E-66
+    5    2    0.17923E-10    0.10000E+01    0.42297E+05    0.74450E-55    0.79975E-65    0.22029E-65
+    5    2    0.17923E-10    0.10000E+01    0.34111E+05    0.12646E-53    0.27744E-63    0.26304E-64
+    5    2    0.17923E-10    0.10000E+01    0.27509E+05    0.22712E-52    0.94009E-62    0.41750E-63
+    5    2    0.17923E-10    0.10000E+01    0.22184E+05    0.40091E-51    0.30152E-60    0.72601E-62
+    5    2    0.17923E-10    0.10000E+01    0.17891E+05    0.67122E-50    0.89765E-59    0.12297E-60
+    5    2    0.17923E-10    0.10000E+01    0.14428E+05    0.10498E-48    0.25128E-57    0.19455E-59
+    5    2    0.17923E-10    0.10000E+01    0.11635E+05    0.15509E-47    0.68179E-56    0.28948E-58
+    5    2    0.17923E-10    0.10000E+01    0.93834E+04    0.22183E-46    0.18318E-54    0.41588E-57
+    5    2    0.17923E-10    0.10000E+01    0.75673E+04    0.31331E-45    0.49135E-53    0.58931E-56
+    5    2    0.17923E-10    0.10000E+01    0.61026E+04    0.44104E-44    0.13180E-51    0.83196E-55
+    5    2    0.17923E-10    0.10000E+01    0.49215E+04    0.62053E-43    0.35355E-50    0.11736E-53
+    5    2    0.17923E-10    0.10000E+01    0.39689E+04    0.87304E-42    0.94835E-49    0.16552E-52
+    5    2    0.17923E-10    0.10000E+01    0.32008E+04    0.38628E-39    0.82252E-46    0.73393E-50
+    5    2    0.17923E-10    0.10000E+01    0.25813E+04    0.28282E-30    0.13805E-36    0.53845E-41
+    5    2    0.17923E-10    0.10000E+01    0.20817E+04    0.53756E-14    0.11705E-19    0.10258E-24
+    5    2    0.17923E-10    0.10000E+01    0.16788E+04    0.18155E-08    0.17278E-13    0.34692E-19
+    5    2    0.17923E-10    0.10000E+01    0.13538E+04    0.38969E-08    0.65623E-13    0.74501E-19
+    5    2    0.17923E-10    0.10000E+01    0.10918E+04    0.81803E-08    0.24468E-12    0.15645E-18
+    5    2    0.17923E-10    0.10000E+01    0.88049E+03    0.16807E-07    0.90084E-12    0.32153E-18
+    5    2    0.17923E-10    0.10000E+01    0.71007E+03    0.33870E-07    0.32803E-11    0.64805E-18
+    5    2    0.17923E-10    0.10000E+01    0.57264E+03    0.67114E-07    0.11671E-10    0.12843E-17
+    5    2    0.17923E-10    0.10000E+01    0.46180E+03    0.13084E-06    0.39254E-10    0.25038E-17
+    5    2    0.17923E-10    0.10000E+01    0.37242E+03    0.24970E-06    0.11969E-09    0.47787E-17
+    5    2    0.17923E-10    0.10000E+01    0.30034E+03    0.46118E-06    0.32103E-09    0.88263E-17
+    5    2    0.17923E-10    0.10000E+01    0.24221E+03    0.81249E-06    0.74959E-09    0.15550E-16
+    5    2    0.17923E-10    0.10000E+01    0.19533E+03    0.12805E-05    0.14245E-08    0.24507E-16
+    5    2    0.17923E-10    0.10000E+01    0.15752E+03    0.12805E-05    0.14245E-08    0.24507E-16
+    5    2    0.31275E-10    0.10000E+01    0.80645E+05    0.12229E-57    0.87554E-69    0.11588E-67
+    5    2    0.31275E-10    0.10000E+01    0.65036E+05    0.10087E-56    0.15538E-67    0.98503E-67
+    5    2    0.31275E-10    0.10000E+01    0.52449E+05    0.94176E-56    0.30492E-66    0.83643E-66
+    5    2    0.31275E-10    0.10000E+01    0.42297E+05    0.98862E-55    0.84707E-65    0.65559E-65
+    5    2    0.31275E-10    0.10000E+01    0.34111E+05    0.13775E-53    0.28095E-63    0.59480E-64
+    5    2    0.31275E-10    0.10000E+01    0.27509E+05    0.23215E-52    0.95075E-62    0.74138E-63
+    5    2    0.31275E-10    0.10000E+01    0.22184E+05    0.40647E-51    0.30731E-60    0.11782E-61
+    5    2    0.31275E-10    0.10000E+01    0.17891E+05    0.68416E-50    0.92049E-59    0.19859E-60
+    5    2    0.31275E-10    0.10000E+01    0.14428E+05    0.10759E-48    0.25853E-57    0.31863E-59
+    5    2    0.31275E-10    0.10000E+01    0.11635E+05    0.15950E-47    0.70280E-56    0.47986E-58
+    5    2    0.31275E-10    0.10000E+01    0.93834E+04    0.22862E-46    0.18911E-54    0.69511E-57
+    5    2    0.31275E-10    0.10000E+01    0.75673E+04    0.32342E-45    0.50796E-53    0.99093E-56
+    5    2    0.31275E-10    0.10000E+01    0.61026E+04    0.45591E-44    0.13643E-51    0.14056E-54
+    5    2    0.31275E-10    0.10000E+01    0.49215E+04    0.64228E-43    0.36640E-50    0.19907E-53
+    5    2    0.31275E-10    0.10000E+01    0.39689E+04    0.90471E-42    0.98385E-49    0.28168E-52
+    5    2    0.31275E-10    0.10000E+01    0.32008E+04    0.40072E-39    0.85412E-46    0.12525E-49
+    5    2    0.31275E-10    0.10000E+01    0.25813E+04    0.29369E-30    0.14350E-36    0.92126E-41
+    5    2    0.31275E-10    0.10000E+01    0.20817E+04    0.55884E-14    0.12179E-19    0.17597E-24
+    5    2    0.31275E-10    0.10000E+01    0.16788E+04    0.18887E-08    0.17987E-13    0.59617E-19
+    5    2    0.31275E-10    0.10000E+01    0.13538E+04    0.40550E-08    0.68320E-13    0.12810E-18
+    5    2    0.31275E-10    0.10000E+01    0.10918E+04    0.85138E-08    0.25474E-12    0.26913E-18
+    5    2    0.31275E-10    0.10000E+01    0.88049E+03    0.17495E-07    0.93790E-12    0.55326E-18
+    5    2    0.31275E-10    0.10000E+01    0.71007E+03    0.35259E-07    0.34153E-11    0.11154E-17
+    5    2    0.31275E-10    0.10000E+01    0.57264E+03    0.69870E-07    0.12151E-10    0.22107E-17
+    5    2    0.31275E-10    0.10000E+01    0.46180E+03    0.13621E-06    0.40869E-10    0.43103E-17
+    5    2    0.31275E-10    0.10000E+01    0.37242E+03    0.25997E-06    0.12462E-09    0.82271E-17
+    5    2    0.31275E-10    0.10000E+01    0.30034E+03    0.48015E-06    0.33425E-09    0.15196E-16
+    5    2    0.31275E-10    0.10000E+01    0.24221E+03    0.84592E-06    0.78044E-09    0.26773E-16
+    5    2    0.31275E-10    0.10000E+01    0.19533E+03    0.13332E-05    0.14831E-08    0.42195E-16
+    5    2    0.31275E-10    0.10000E+01    0.15752E+03    0.13332E-05    0.14831E-08    0.42195E-16
+    5    2    0.54572E-10    0.10000E+01    0.80645E+05    0.25881E-57    0.19216E-68    0.37897E-67
+    5    2    0.54572E-10    0.10000E+01    0.65036E+05    0.21796E-56    0.31133E-67    0.32374E-66
+    5    2    0.54572E-10    0.10000E+01    0.52449E+05    0.18896E-55    0.47548E-66    0.27381E-65
+    5    2    0.54572E-10    0.10000E+01    0.42297E+05    0.15980E-54    0.98472E-65    0.20481E-64
+    5    2    0.54572E-10    0.10000E+01    0.34111E+05    0.16733E-53    0.27950E-63    0.15604E-63
+    5    2    0.54572E-10    0.10000E+01    0.27509E+05    0.23672E-52    0.91188E-62    0.14709E-62
+    5    2    0.54572E-10    0.10000E+01    0.22184E+05    0.39364E-51    0.29709E-60    0.19659E-61
+    5    2    0.54572E-10    0.10000E+01    0.17891E+05    0.66261E-50    0.90073E-59    0.32145E-60
+    5    2    0.54572E-10    0.10000E+01    0.14428E+05    0.10521E-48    0.25494E-57    0.52271E-59
+    5    2    0.54572E-10    0.10000E+01    0.11635E+05    0.15716E-47    0.69634E-56    0.79843E-58
+    5    2    0.54572E-10    0.10000E+01    0.93834E+04    0.22641E-46    0.18803E-54    0.11675E-56
+    5    2    0.54572E-10    0.10000E+01    0.75673E+04    0.32147E-45    0.50653E-53    0.16751E-55
+    5    2    0.54572E-10    0.10000E+01    0.61026E+04    0.45453E-44    0.13639E-51    0.23879E-54
+    5    2    0.54572E-10    0.10000E+01    0.49215E+04    0.64199E-43    0.36712E-50    0.33959E-53
+    5    2    0.54572E-10    0.10000E+01    0.39689E+04    0.90632E-42    0.98762E-49    0.48218E-52
+    5    2    0.54572E-10    0.10000E+01    0.32008E+04    0.40221E-39    0.85883E-46    0.21505E-49
+    5    2    0.54572E-10    0.10000E+01    0.25813E+04    0.29531E-30    0.14454E-36    0.15862E-40
+    5    2    0.54572E-10    0.10000E+01    0.20817E+04    0.56303E-14    0.12291E-19    0.30390E-24
+    5    2    0.54572E-10    0.10000E+01    0.16788E+04    0.19052E-08    0.18165E-13    0.10315E-18
+    5    2    0.54572E-10    0.10000E+01    0.13538E+04    0.40921E-08    0.69004E-13    0.22178E-18
+    5    2    0.54572E-10    0.10000E+01    0.10918E+04    0.85944E-08    0.25731E-12    0.46616E-18
+    5    2    0.54572E-10    0.10000E+01    0.88049E+03    0.17664E-07    0.94738E-12    0.95864E-18
+    5    2    0.54572E-10    0.10000E+01    0.71007E+03    0.35606E-07    0.34499E-11    0.19331E-17
+    5    2    0.54572E-10    0.10000E+01    0.57264E+03    0.70565E-07    0.12274E-10    0.38320E-17
+    5    2    0.54572E-10    0.10000E+01    0.46180E+03    0.13758E-06    0.41283E-10    0.74722E-17
+    5    2    0.54572E-10    0.10000E+01    0.37242E+03    0.26258E-06    0.12588E-09    0.14263E-16
+    5    2    0.54572E-10    0.10000E+01    0.30034E+03    0.48499E-06    0.33763E-09    0.26346E-16
+    5    2    0.54572E-10    0.10000E+01    0.24221E+03    0.85446E-06    0.78833E-09    0.46417E-16
+    5    2    0.54572E-10    0.10000E+01    0.19533E+03    0.13466E-05    0.14981E-08    0.73156E-16
+    5    2    0.54572E-10    0.10000E+01    0.15752E+03    0.13466E-05    0.14981E-08    0.73156E-16
+    5    2    0.95225E-10    0.10000E+01    0.80645E+05    0.53245E-57    0.40027E-68    0.12613E-66
+    5    2    0.95225E-10    0.10000E+01    0.65036E+05    0.45188E-56    0.63224E-67    0.10677E-65
+    5    2    0.95225E-10    0.10000E+01    0.52449E+05    0.38326E-55    0.86129E-66    0.89829E-65
+    5    2    0.95225E-10    0.10000E+01    0.42297E+05    0.29346E-54    0.13609E-64    0.65797E-64
+    5    2    0.95225E-10    0.10000E+01    0.34111E+05    0.24165E-53    0.29315E-63    0.45896E-63
+    5    2    0.95225E-10    0.10000E+01    0.27509E+05    0.26010E-52    0.85811E-62    0.34970E-62
+    5    2    0.95225E-10    0.10000E+01    0.22184E+05    0.37922E-51    0.27933E-60    0.36999E-61
+    5    2    0.95225E-10    0.10000E+01    0.17891E+05    0.62652E-50    0.86161E-59    0.55261E-60
+    5    2    0.95225E-10    0.10000E+01    0.14428E+05    0.10060E-48    0.24671E-57    0.89063E-59
+    5    2    0.95225E-10    0.10000E+01    0.11635E+05    0.15191E-47    0.67842E-56    0.13665E-57
+    5    2    0.95225E-10    0.10000E+01    0.93834E+04    0.22043E-46    0.18405E-54    0.20041E-56
+    5    2    0.95225E-10    0.10000E+01    0.75673E+04    0.31454E-45    0.49772E-53    0.28791E-55
+    5    2    0.95225E-10    0.10000E+01    0.61026E+04    0.44649E-44    0.13447E-51    0.41082E-54
+    5    2    0.95225E-10    0.10000E+01    0.49215E+04    0.63276E-43    0.36298E-50    0.58489E-53
+    5    2    0.95225E-10    0.10000E+01    0.39689E+04    0.89590E-42    0.97892E-49    0.83158E-52
+    5    2    0.95225E-10    0.10000E+01    0.32008E+04    0.39861E-39    0.85317E-46    0.37142E-49
+    5    2    0.95225E-10    0.10000E+01    0.25813E+04    0.29337E-30    0.14392E-36    0.27440E-40
+    5    2    0.95225E-10    0.10000E+01    0.20817E+04    0.56079E-14    0.12269E-19    0.52676E-24
+    5    2    0.95225E-10    0.10000E+01    0.16788E+04    0.19007E-08    0.18150E-13    0.17902E-18
+    5    2    0.95225E-10    0.10000E+01    0.13538E+04    0.40848E-08    0.68959E-13    0.38508E-18
+    5    2    0.95225E-10    0.10000E+01    0.10918E+04    0.85826E-08    0.25716E-12    0.80965E-18
+    5    2    0.95225E-10    0.10000E+01    0.88049E+03    0.17645E-07    0.94688E-12    0.16654E-17
+    5    2    0.95225E-10    0.10000E+01    0.71007E+03    0.35575E-07    0.34481E-11    0.33588E-17
+    5    2    0.95225E-10    0.10000E+01    0.57264E+03    0.70513E-07    0.12268E-10    0.66589E-17
+    5    2    0.95225E-10    0.10000E+01    0.46180E+03    0.13749E-06    0.41261E-10    0.12985E-16
+    5    2    0.95225E-10    0.10000E+01    0.37242E+03    0.26243E-06    0.12581E-09    0.24788E-16
+    5    2    0.95225E-10    0.10000E+01    0.30034E+03    0.48472E-06    0.33745E-09    0.45787E-16
+    5    2    0.95225E-10    0.10000E+01    0.24221E+03    0.85400E-06    0.78793E-09    0.80671E-16
+    5    2    0.95225E-10    0.10000E+01    0.19533E+03    0.13459E-05    0.14973E-08    0.12714E-15
+    5    2    0.95225E-10    0.10000E+01    0.15752E+03    0.13459E-05    0.14973E-08    0.12714E-15
+    5    2    0.16616E-09    0.10000E+01    0.80645E+05    0.10743E-56    0.80357E-68    0.42459E-66
+    5    2    0.16616E-09    0.10000E+01    0.65036E+05    0.90785E-56    0.12609E-66    0.35673E-65
+    5    2    0.16616E-09    0.10000E+01    0.52449E+05    0.76402E-55    0.16480E-65    0.29939E-64
+    5    2    0.16616E-09    0.10000E+01    0.42297E+05    0.56355E-54    0.22270E-64    0.21830E-63
+    5    2    0.16616E-09    0.10000E+01    0.34111E+05    0.40643E-53    0.36010E-63    0.14847E-62
+    5    2    0.16616E-09    0.10000E+01    0.27509E+05    0.33771E-52    0.85530E-62    0.10185E-61
+    5    2    0.16616E-09    0.10000E+01    0.22184E+05    0.39416E-51    0.26687E-60    0.85277E-61
+    5    2    0.16616E-09    0.10000E+01    0.17891E+05    0.60661E-50    0.83090E-59    0.10486E-59
+    5    2    0.16616E-09    0.10000E+01    0.14428E+05    0.97145E-49    0.24015E-57    0.15826E-58
+    5    2    0.16616E-09    0.10000E+01    0.11635E+05    0.14775E-47    0.66350E-56    0.23942E-57
+    5    2    0.16616E-09    0.10000E+01    0.93834E+04    0.21546E-46    0.18050E-54    0.34971E-56
+    5    2    0.16616E-09    0.10000E+01    0.75673E+04    0.30839E-45    0.48921E-53    0.50096E-55
+    5    2    0.16616E-09    0.10000E+01    0.61026E+04    0.43879E-44    0.13246E-51    0.71315E-54
+    5    2    0.16616E-09    0.10000E+01    0.49215E+04    0.62323E-43    0.35831E-50    0.10138E-52
+    5    2    0.16616E-09    0.10000E+01    0.39689E+04    0.88428E-42    0.96828E-49    0.14404E-51
+    5    2    0.16616E-09    0.10000E+01    0.32008E+04    0.39425E-39    0.84552E-46    0.64336E-49
+    5    2    0.16616E-09    0.10000E+01    0.25813E+04    0.29076E-30    0.14292E-36    0.47556E-40
+    5    2    0.16616E-09    0.10000E+01    0.20817E+04    0.55714E-14    0.12213E-19    0.91393E-24
+    5    2    0.16616E-09    0.10000E+01    0.16788E+04    0.18913E-08    0.18086E-13    0.31085E-18
+    5    2    0.16616E-09    0.10000E+01    0.13538E+04    0.40666E-08    0.68724E-13    0.66881E-18
+    5    2    0.16616E-09    0.10000E+01    0.10918E+04    0.85476E-08    0.25631E-12    0.14065E-17
+    5    2    0.16616E-09    0.10000E+01    0.88049E+03    0.17578E-07    0.94375E-12    0.28934E-17
+    5    2    0.16616E-09    0.10000E+01    0.71007E+03    0.35446E-07    0.34367E-11    0.58359E-17
+    5    2    0.16616E-09    0.10000E+01    0.57264E+03    0.70267E-07    0.12227E-10    0.11571E-16
+    5    2    0.16616E-09    0.10000E+01    0.46180E+03    0.13702E-06    0.41125E-10    0.22564E-16
+    5    2    0.16616E-09    0.10000E+01    0.37242E+03    0.26154E-06    0.12540E-09    0.43073E-16
+    5    2    0.16616E-09    0.10000E+01    0.30034E+03    0.48310E-06    0.33634E-09    0.79564E-16
+    5    2    0.16616E-09    0.10000E+01    0.24221E+03    0.85116E-06    0.78532E-09    0.14018E-15
+    5    2    0.16616E-09    0.10000E+01    0.19533E+03    0.13415E-05    0.14924E-08    0.22094E-15
+    5    2    0.16616E-09    0.10000E+01    0.15752E+03    0.13415E-05    0.14924E-08    0.22094E-15
+    5    2    0.28994E-09    0.10000E+01    0.80645E+05    0.21375E-56    0.15885E-67    0.13668E-65
+    5    2    0.28994E-09    0.10000E+01    0.65036E+05    0.17974E-55    0.24910E-66    0.11475E-64
+    5    2    0.28994E-09    0.10000E+01    0.52449E+05    0.15094E-54    0.32280E-65    0.96505E-64
+    5    2    0.28994E-09    0.10000E+01    0.42297E+05    0.11037E-53    0.41340E-64    0.70805E-63
+    5    2    0.28994E-09    0.10000E+01    0.34111E+05    0.76017E-53    0.56002E-63    0.48520E-62
+    5    2    0.28994E-09    0.10000E+01    0.27509E+05    0.54283E-52    0.10064E-61    0.32477E-61
+    5    2    0.28994E-09    0.10000E+01    0.22184E+05    0.48918E-51    0.27029E-60    0.23275E-60
+    5    2    0.28994E-09    0.10000E+01    0.17891E+05    0.63283E-50    0.81767E-59    0.22005E-59
+    5    2    0.28994E-09    0.10000E+01    0.14428E+05    0.96387E-49    0.23628E-57    0.28469E-58
+    5    2    0.28994E-09    0.10000E+01    0.11635E+05    0.14554E-47    0.65371E-56    0.41305E-57
+    5    2    0.28994E-09    0.10000E+01    0.93834E+04    0.21226E-46    0.17788E-54    0.60035E-56
+    5    2    0.28994E-09    0.10000E+01    0.75673E+04    0.30390E-45    0.48217E-53    0.86119E-55
+    5    2    0.28994E-09    0.10000E+01    0.61026E+04    0.43249E-44    0.13061E-51    0.12274E-53
+    5    2    0.28994E-09    0.10000E+01    0.49215E+04    0.61456E-43    0.35362E-50    0.17462E-52
+    5    2    0.28994E-09    0.10000E+01    0.39689E+04    0.87269E-42    0.95665E-49    0.24831E-51
+    5    2    0.28994E-09    0.10000E+01    0.32008E+04    0.38951E-39    0.83645E-46    0.11102E-48
+    5    2    0.28994E-09    0.10000E+01    0.25813E+04    0.28768E-30    0.14162E-36    0.82183E-40
+    5    2    0.28994E-09    0.10000E+01    0.20817E+04    0.55227E-14    0.12126E-19    0.15825E-23
+    5    2    0.28994E-09    0.10000E+01    0.16788E+04    0.18771E-08    0.17972E-13    0.53897E-18
+    5    2    0.28994E-09    0.10000E+01    0.13538E+04    0.40378E-08    0.68297E-13    0.11601E-17
+    5    2    0.28994E-09    0.10000E+01    0.10918E+04    0.84898E-08    0.25473E-12    0.24405E-17
+    5    2    0.28994E-09    0.10000E+01    0.88049E+03    0.17463E-07    0.93795E-12    0.50218E-17
+    5    2    0.28994E-09    0.10000E+01    0.71007E+03    0.35220E-07    0.34156E-11    0.10130E-16
+    5    2    0.28994E-09    0.10000E+01    0.57264E+03    0.69825E-07    0.12152E-10    0.20087E-16
+    5    2    0.28994E-09    0.10000E+01    0.46180E+03    0.13616E-06    0.40872E-10    0.39175E-16
+    5    2    0.28994E-09    0.10000E+01    0.37242E+03    0.25992E-06    0.12462E-09    0.74783E-16
+    5    2    0.28994E-09    0.10000E+01    0.30034E+03    0.48011E-06    0.33426E-09    0.13814E-15
+    5    2    0.28994E-09    0.10000E+01    0.24221E+03    0.84590E-06    0.78047E-09    0.24338E-15
+    5    2    0.28994E-09    0.10000E+01    0.19533E+03    0.13332E-05    0.14831E-08    0.38359E-15
+    5    2    0.28994E-09    0.10000E+01    0.15752E+03    0.13332E-05    0.14831E-08    0.38359E-15
+    5    2    0.50593E-09    0.10000E+01    0.80645E+05    0.42061E-56    0.31220E-67    0.42079E-65
+    5    2    0.50593E-09    0.10000E+01    0.65036E+05    0.35343E-55    0.49092E-66    0.35408E-64
+    5    2    0.50593E-09    0.10000E+01    0.52449E+05    0.29739E-54    0.64046E-65    0.29882E-63
+    5    2    0.50593E-09    0.10000E+01    0.42297E+05    0.21848E-53    0.82154E-64    0.22111E-62
+    5    2    0.50593E-09    0.10000E+01    0.34111E+05    0.15042E-52    0.10519E-62    0.15390E-61
+    5    2    0.50593E-09    0.10000E+01    0.27509E+05    0.10223E-51    0.15014E-61    0.10397E-60
+    5    2    0.50593E-09    0.10000E+01    0.22184E+05    0.75945E-51    0.30326E-60    0.69750E-60
+    5    2    0.50593E-09    0.10000E+01    0.17891E+05    0.74882E-50    0.81437E-59    0.52389E-59
+    5    2    0.50593E-09    0.10000E+01    0.14428E+05    0.98482E-49    0.23051E-57    0.52689E-58
+    5    2    0.50593E-09    0.10000E+01    0.11635E+05    0.14299E-47    0.63908E-56    0.68844E-57
+    5    2    0.50593E-09    0.10000E+01    0.93834E+04    0.20770E-46    0.17450E-54    0.98804E-56
+    5    2    0.50593E-09    0.10000E+01    0.75673E+04    0.29806E-45    0.47403E-53    0.14322E-54
+    5    2    0.50593E-09    0.10000E+01    0.61026E+04    0.42510E-44    0.12860E-51    0.20629E-53
+    5    2    0.50593E-09    0.10000E+01    0.49215E+04    0.60503E-43    0.34867E-50    0.29567E-52
+    5    2    0.50593E-09    0.10000E+01    0.39689E+04    0.86044E-42    0.94473E-49    0.42263E-51
+    5    2    0.50593E-09    0.10000E+01    0.32008E+04    0.38465E-39    0.82744E-46    0.18974E-48
+    5    2    0.50593E-09    0.10000E+01    0.25813E+04    0.28462E-30    0.14039E-36    0.14098E-39
+    5    2    0.50593E-09    0.10000E+01    0.20817E+04    0.54772E-14    0.12050E-19    0.27261E-23
+    5    2    0.50593E-09    0.10000E+01    0.16788E+04    0.18646E-08    0.17878E-13    0.93098E-18
+    5    2    0.50593E-09    0.10000E+01    0.13538E+04    0.40130E-08    0.67951E-13    0.20056E-17
+    5    2    0.50593E-09    0.10000E+01    0.10918E+04    0.84409E-08    0.25345E-12    0.42217E-17
+    5    2    0.50593E-09    0.10000E+01    0.88049E+03    0.17368E-07    0.93326E-12    0.86911E-17
+    5    2    0.50593E-09    0.10000E+01    0.71007E+03    0.35033E-07    0.33985E-11    0.17538E-16
+    5    2    0.50593E-09    0.10000E+01    0.57264E+03    0.69464E-07    0.12091E-10    0.34782E-16
+    5    2    0.50593E-09    0.10000E+01    0.46180E+03    0.13547E-06    0.40666E-10    0.67842E-16
+    5    2    0.50593E-09    0.10000E+01    0.37242E+03    0.25860E-06    0.12400E-09    0.12952E-15
+    5    2    0.50593E-09    0.10000E+01    0.30034E+03    0.47769E-06    0.33257E-09    0.23925E-15
+    5    2    0.50593E-09    0.10000E+01    0.24221E+03    0.84163E-06    0.77653E-09    0.42153E-15
+    5    2    0.50593E-09    0.10000E+01    0.19533E+03    0.13265E-05    0.14756E-08    0.66437E-15
+    5    2    0.50593E-09    0.10000E+01    0.15752E+03    0.13265E-05    0.14756E-08    0.66437E-15
+    5    2    0.88282E-09    0.10000E+01    0.80645E+05    0.82558E-56    0.61414E-67    0.13139E-64
+    5    2    0.88282E-09    0.10000E+01    0.65036E+05    0.69505E-55    0.96922E-66    0.11079E-63
+    5    2    0.88282E-09    0.10000E+01    0.52449E+05    0.58687E-54    0.12777E-64    0.93762E-63
+    5    2    0.88282E-09    0.10000E+01    0.42297E+05    0.43471E-53    0.16686E-63    0.69826E-62
+    5    2    0.88282E-09    0.10000E+01    0.34111E+05    0.30345E-52    0.21457E-62    0.49242E-61
+    5    2    0.88282E-09    0.10000E+01    0.27509E+05    0.20649E-51    0.27454E-61    0.33842E-60
+    5    2    0.88282E-09    0.10000E+01    0.22184E+05    0.14042E-50    0.40606E-60    0.22473E-59
+    5    2    0.88282E-09    0.10000E+01    0.17891E+05    0.10669E-49    0.83060E-59    0.14835E-58
+    5    2    0.88282E-09    0.10000E+01    0.14428E+05    0.10652E-48    0.21574E-57    0.11212E-57
+    5    2    0.88282E-09    0.10000E+01    0.11635E+05    0.13710E-47    0.59794E-56    0.11620E-56
+    5    2    0.88282E-09    0.10000E+01    0.93834E+04    0.19533E-46    0.16563E-54    0.15630E-55
+    5    2    0.88282E-09    0.10000E+01    0.75673E+04    0.28279E-45    0.45500E-53    0.22902E-54
+    5    2    0.88282E-09    0.10000E+01    0.61026E+04    0.40759E-44    0.12434E-51    0.33699E-53
+    5    2    0.88282E-09    0.10000E+01    0.49215E+04    0.58458E-43    0.33888E-50    0.49078E-52
+    5    2    0.88282E-09    0.10000E+01    0.39689E+04    0.83589E-42    0.92195E-49    0.70908E-51
+    5    2    0.88282E-09    0.10000E+01    0.32008E+04    0.37529E-39    0.81043E-46    0.32075E-48
+    5    2    0.88282E-09    0.10000E+01    0.25813E+04    0.27880E-30    0.13804E-36    0.23981E-39
+    5    2    0.88282E-09    0.10000E+01    0.20817E+04    0.53892E-14    0.11901E-19    0.46667E-23
+    5    2    0.88282E-09    0.10000E+01    0.16788E+04    0.18400E-08    0.17687E-13    0.16002E-17
+    5    2    0.88282E-09    0.10000E+01    0.13538E+04    0.39637E-08    0.67244E-13    0.34515E-17
+    5    2    0.88282E-09    0.10000E+01    0.10918E+04    0.83429E-08    0.25084E-12    0.72720E-17
+    5    2    0.88282E-09    0.10000E+01    0.88049E+03    0.17174E-07    0.92368E-12    0.14980E-16
+    5    2    0.88282E-09    0.10000E+01    0.71007E+03    0.34655E-07    0.33636E-11    0.30243E-16
+    5    2    0.88282E-09    0.10000E+01    0.57264E+03    0.68729E-07    0.11967E-10    0.59995E-16
+    5    2    0.88282E-09    0.10000E+01    0.46180E+03    0.13405E-06    0.40247E-10    0.11704E-15
+    5    2    0.88282E-09    0.10000E+01    0.37242E+03    0.25592E-06    0.12272E-09    0.22346E-15
+    5    2    0.88282E-09    0.10000E+01    0.30034E+03    0.47274E-06    0.32914E-09    0.41281E-15
+    5    2    0.88282E-09    0.10000E+01    0.24221E+03    0.83293E-06    0.76850E-09    0.72735E-15
+    5    2    0.88282E-09    0.10000E+01    0.19533E+03    0.13128E-05    0.14604E-08    0.11464E-14
+    5    2    0.88282E-09    0.10000E+01    0.15752E+03    0.13128E-05    0.14604E-08    0.11464E-14
+    5    2    0.15405E-08    0.10000E+01    0.80645E+05    0.16225E-55    0.12095E-66    0.42720E-64
+    5    2    0.15405E-08    0.10000E+01    0.65036E+05    0.13684E-54    0.19137E-65    0.36056E-63
+    5    2    0.15405E-08    0.10000E+01    0.52449E+05    0.11584E-53    0.25417E-64    0.30554E-62
+    5    2    0.15405E-08    0.10000E+01    0.42297E+05    0.86327E-53    0.33691E-63    0.22829E-61
+    5    2    0.15405E-08    0.10000E+01    0.34111E+05    0.60988E-52    0.44135E-62    0.16220E-60
+    5    2    0.15405E-08    0.10000E+01    0.27509E+05    0.42097E-51    0.55433E-61    0.11297E-59
+    5    2    0.15405E-08    0.10000E+01    0.22184E+05    0.28176E-50    0.68900E-60    0.75945E-59
+    5    2    0.15405E-08    0.10000E+01    0.17891E+05    0.18692E-49    0.99464E-59    0.48579E-58
+    5    2    0.15405E-08    0.10000E+01    0.14428E+05    0.13848E-48    0.20246E-57    0.30850E-57
+    5    2    0.15405E-08    0.10000E+01    0.11635E+05    0.13687E-47    0.53431E-56    0.23295E-56
+    5    2    0.15405E-08    0.10000E+01    0.93834E+04    0.17819E-46    0.15118E-54    0.25442E-55
+    5    2    0.15405E-08    0.10000E+01    0.75673E+04    0.25871E-45    0.42571E-53    0.35974E-54
+    5    2    0.15405E-08    0.10000E+01    0.61026E+04    0.38065E-44    0.11828E-51    0.54090E-53
+    5    2    0.15405E-08    0.10000E+01    0.49215E+04    0.55512E-43    0.32579E-50    0.80592E-52
+    5    2    0.15405E-08    0.10000E+01    0.39689E+04    0.80271E-42    0.89287E-49    0.11820E-50
+    5    2    0.15405E-08    0.10000E+01    0.32008E+04    0.36324E-39    0.78951E-46    0.53982E-48
+    5    2    0.15405E-08    0.10000E+01    0.25813E+04    0.27160E-30    0.13527E-36    0.40645E-39
+    5    2    0.15405E-08    0.10000E+01    0.20817E+04    0.52853E-14    0.11735E-19    0.79641E-23
+    5    2    0.15405E-08    0.10000E+01    0.16788E+04    0.18123E-08    0.17483E-13    0.27429E-17
+    5    2    0.15405E-08    0.10000E+01    0.13538E+04    0.39090E-08    0.66491E-13    0.59235E-17
+    5    2    0.15405E-08    0.10000E+01    0.10918E+04    0.82357E-08    0.24807E-12    0.12491E-16
+    5    2    0.15405E-08    0.10000E+01    0.88049E+03    0.16965E-07    0.91351E-12    0.25749E-16
+    5    2    0.15405E-08    0.10000E+01    0.71007E+03    0.34249E-07    0.33265E-11    0.52004E-16
+    5    2    0.15405E-08    0.10000E+01    0.57264E+03    0.67943E-07    0.11834E-10    0.10319E-15
+    5    2    0.15405E-08    0.10000E+01    0.46180E+03    0.13254E-06    0.39801E-10    0.20134E-15
+    5    2    0.15405E-08    0.10000E+01    0.37242E+03    0.25306E-06    0.12135E-09    0.38444E-15
+    5    2    0.15405E-08    0.10000E+01    0.30034E+03    0.46748E-06    0.32548E-09    0.71020E-15
+    5    2    0.15405E-08    0.10000E+01    0.24221E+03    0.82368E-06    0.75996E-09    0.12513E-14
+    5    2    0.15405E-08    0.10000E+01    0.19533E+03    0.12982E-05    0.14442E-08    0.19722E-14
+    5    2    0.15405E-08    0.10000E+01    0.15752E+03    0.12982E-05    0.14442E-08    0.19722E-14
+    5    2    0.26880E-08    0.10000E+01    0.80645E+05    0.37733E-55    0.28155E-66    0.65349E-63
+    5    2    0.26880E-08    0.10000E+01    0.65036E+05    0.31851E-54    0.44620E-65    0.55184E-62
+    5    2    0.26880E-08    0.10000E+01    0.52449E+05    0.27005E-53    0.59572E-64    0.46812E-61
+    5    2    0.26880E-08    0.10000E+01    0.42297E+05    0.20211E-52    0.79968E-63    0.35075E-60
+    5    2    0.26880E-08    0.10000E+01    0.34111E+05    0.14431E-51    0.10769E-61    0.25096E-59
+    5    2    0.26880E-08    0.10000E+01    0.27509E+05    0.10193E-50    0.14205E-60    0.17769E-58
+    5    2    0.26880E-08    0.10000E+01    0.22184E+05    0.70961E-50    0.18442E-59    0.12354E-57
+    5    2    0.26880E-08    0.10000E+01    0.17891E+05    0.48761E-49    0.24578E-58    0.83162E-57
+    5    2    0.26880E-08    0.10000E+01    0.14428E+05    0.34114E-48    0.37045E-57    0.53679E-56
+    5    2    0.26880E-08    0.10000E+01    0.11635E+05    0.26327E-47    0.70157E-56    0.33194E-55
+    5    2    0.26880E-08    0.10000E+01    0.93834E+04    0.24883E-46    0.16640E-54    0.20091E-54
+    5    2    0.26880E-08    0.10000E+01    0.75673E+04    0.29517E-45    0.44459E-53    0.13191E-53
+    5    2    0.26880E-08    0.10000E+01    0.61026E+04    0.40280E-44    0.12253E-51    0.11677E-52
+    5    2    0.26880E-08    0.10000E+01    0.49215E+04    0.57668E-43    0.33690E-50    0.14635E-51
+    5    2    0.26880E-08    0.10000E+01    0.39689E+04    0.83018E-42    0.91992E-49    0.21123E-50
+    5    2    0.26880E-08    0.10000E+01    0.32008E+04    0.37416E-39    0.80900E-46    0.96795E-48
+    5    2    0.26880E-08    0.10000E+01    0.25813E+04    0.27815E-30    0.13767E-36    0.72275E-39
+    5    2    0.26880E-08    0.10000E+01    0.20817E+04    0.53729E-14    0.11848E-19    0.13940E-22
+    5    2    0.26880E-08    0.10000E+01    0.16788E+04    0.18341E-08    0.17593E-13    0.47583E-17
+    5    2    0.26880E-08    0.10000E+01    0.13538E+04    0.39473E-08    0.66868E-13    0.10175E-16
+    5    2    0.26880E-08    0.10000E+01    0.10918E+04    0.83037E-08    0.24938E-12    0.21321E-16
+    5    2    0.26880E-08    0.10000E+01    0.88049E+03    0.17087E-07    0.91813E-12    0.43758E-16
+    5    2    0.26880E-08    0.10000E+01    0.71007E+03    0.34468E-07    0.33429E-11    0.88091E-16
+    5    2    0.26880E-08    0.10000E+01    0.57264E+03    0.68341E-07    0.11891E-10    0.17437E-15
+    5    2    0.26880E-08    0.10000E+01    0.46180E+03    0.13327E-06    0.39991E-10    0.33955E-15
+    5    2    0.26880E-08    0.10000E+01    0.37242E+03    0.25438E-06    0.12193E-09    0.64739E-15
+    5    2    0.26880E-08    0.10000E+01    0.30034E+03    0.46985E-06    0.32702E-09    0.11947E-14
+    5    2    0.26880E-08    0.10000E+01    0.24221E+03    0.82776E-06    0.76355E-09    0.21033E-14
+    5    2    0.26880E-08    0.10000E+01    0.19533E+03    0.13045E-05    0.14510E-08    0.33134E-14
+    5    2    0.26880E-08    0.10000E+01    0.15752E+03    0.13045E-05    0.14510E-08    0.33134E-14
+    5    2    0.46905E-08    0.10000E+01    0.80645E+05    0.71878E-55    0.53647E-66    0.21199E-62
+    5    2    0.46905E-08    0.10000E+01    0.65036E+05    0.60687E-54    0.85044E-65    0.17906E-61
+    5    2    0.46905E-08    0.10000E+01    0.52449E+05    0.51468E-53    0.11362E-63    0.15194E-60
+    5    2    0.46905E-08    0.10000E+01    0.42297E+05    0.38544E-52    0.15273E-62    0.11391E-59
+    5    2    0.46905E-08    0.10000E+01    0.34111E+05    0.27551E-51    0.20597E-61    0.81591E-59
+    5    2    0.46905E-08    0.10000E+01    0.27509E+05    0.19481E-50    0.27129E-60    0.57893E-58
+    5    2    0.46905E-08    0.10000E+01    0.22184E+05    0.13545E-49    0.34679E-59    0.40419E-57
+    5    2    0.46905E-08    0.10000E+01    0.17891E+05    0.91895E-49    0.43661E-58    0.27415E-56
+    5    2    0.46905E-08    0.10000E+01    0.14428E+05    0.61376E-48    0.57354E-57    0.17909E-55
+    5    2    0.46905E-08    0.10000E+01    0.11635E+05    0.42170E-47    0.88070E-56    0.11222E-54
+    5    2    0.46905E-08    0.10000E+01    0.93834E+04    0.32859E-46    0.17587E-54    0.67529E-54
+    5    2    0.46905E-08    0.10000E+01    0.75673E+04    0.32472E-45    0.43916E-53    0.40588E-53
+    5    2    0.46905E-08    0.10000E+01    0.61026E+04    0.40505E-44    0.12011E-51    0.28825E-52
+    5    2    0.46905E-08    0.10000E+01    0.49215E+04    0.56786E-43    0.33214E-50    0.29811E-51
+    5    2    0.46905E-08    0.10000E+01    0.39689E+04    0.81849E-42    0.91044E-49    0.40347E-50
+    5    2    0.46905E-08    0.10000E+01    0.32008E+04    0.37011E-39    0.80162E-46    0.18213E-47
+    5    2    0.46905E-08    0.10000E+01    0.25813E+04    0.27549E-30    0.13641E-36    0.13404E-38
+    5    2    0.46905E-08    0.10000E+01    0.20817E+04    0.53238E-14    0.11728E-19    0.25311E-22
+    5    2    0.46905E-08    0.10000E+01    0.16788E+04    0.18181E-08    0.17405E-13    0.85178E-17
+    5    2    0.46905E-08    0.10000E+01    0.13538E+04    0.39094E-08    0.66141E-13    0.18002E-16
+    5    2    0.46905E-08    0.10000E+01    0.10918E+04    0.82196E-08    0.24661E-12    0.37429E-16
+    5    2    0.46905E-08    0.10000E+01    0.88049E+03    0.16908E-07    0.90774E-12    0.76397E-16
+    5    2    0.46905E-08    0.10000E+01    0.71007E+03    0.34098E-07    0.33044E-11    0.15319E-15
+    5    2    0.46905E-08    0.10000E+01    0.57264E+03    0.67592E-07    0.11753E-10    0.30234E-15
+    5    2    0.46905E-08    0.10000E+01    0.46180E+03    0.13178E-06    0.39522E-10    0.58748E-15
+    5    2    0.46905E-08    0.10000E+01    0.37242E+03    0.25150E-06    0.12049E-09    0.11183E-14
+    5    2    0.46905E-08    0.10000E+01    0.30034E+03    0.46446E-06    0.32316E-09    0.20613E-14
+    5    2    0.46905E-08    0.10000E+01    0.24221E+03    0.81819E-06    0.75451E-09    0.36263E-14
+    5    2    0.46905E-08    0.10000E+01    0.19533E+03    0.12894E-05    0.14338E-08    0.57097E-14
+    5    2    0.46905E-08    0.10000E+01    0.15752E+03    0.12894E-05    0.14338E-08    0.57097E-14
+    5    2    0.81846E-08    0.10000E+01    0.80645E+05    0.13576E-54    0.10136E-65    0.68343E-62
+    5    2    0.81846E-08    0.10000E+01    0.65036E+05    0.11465E-53    0.16072E-64    0.57746E-61
+    5    2    0.81846E-08    0.10000E+01    0.52449E+05    0.97265E-53    0.21489E-63    0.49013E-60
+    5    2    0.81846E-08    0.10000E+01    0.42297E+05    0.72882E-52    0.28923E-62    0.36765E-59
+    5    2    0.81846E-08    0.10000E+01    0.34111E+05    0.52154E-51    0.39088E-61    0.26362E-58
+    5    2    0.81846E-08    0.10000E+01    0.27509E+05    0.36946E-50    0.51608E-60    0.18741E-57
+    5    2    0.81846E-08    0.10000E+01    0.22184E+05    0.25739E-49    0.65895E-59    0.13129E-56
+    5    2    0.81846E-08    0.10000E+01    0.17891E+05    0.17446E-48    0.81528E-58    0.89602E-56
+    5    2    0.81846E-08    0.10000E+01    0.14428E+05    0.11491E-47    0.10035E-56    0.59127E-55
+    5    2    0.81846E-08    0.10000E+01    0.11635E+05    0.74902E-47    0.13175E-55    0.37571E-54
+    5    2    0.81846E-08    0.10000E+01    0.93834E+04    0.51133E-46    0.21157E-54    0.22862E-53
+    5    2    0.81846E-08    0.10000E+01    0.75673E+04    0.41203E-45    0.45787E-53    0.13398E-52
+    5    2    0.81846E-08    0.10000E+01    0.61026E+04    0.43730E-44    0.12048E-51    0.82952E-52
+    5    2    0.81846E-08    0.10000E+01    0.49215E+04    0.57651E-43    0.33319E-50    0.69161E-51
+    5    2    0.81846E-08    0.10000E+01    0.39689E+04    0.82261E-42    0.91582E-49    0.83372E-50
+    5    2    0.81846E-08    0.10000E+01    0.32008E+04    0.37214E-39    0.80560E-46    0.36419E-47
+    5    2    0.81846E-08    0.10000E+01    0.25813E+04    0.27665E-30    0.13658E-36    0.26211E-38
+    5    2    0.81846E-08    0.10000E+01    0.20817E+04    0.53291E-14    0.11673E-19    0.47919E-22
+    5    2    0.81846E-08    0.10000E+01    0.16788E+04    0.18163E-08    0.17276E-13    0.15742E-16
+    5    2    0.81846E-08    0.10000E+01    0.13538E+04    0.38949E-08    0.65607E-13    0.32595E-16
+    5    2    0.81846E-08    0.10000E+01    0.10918E+04    0.81753E-08    0.24449E-12    0.66827E-16
+    5    2    0.81846E-08    0.10000E+01    0.88049E+03    0.16797E-07    0.89951E-12    0.13506E-15
+    5    2    0.81846E-08    0.10000E+01    0.71007E+03    0.33845E-07    0.32733E-11    0.26886E-15
+    5    2    0.81846E-08    0.10000E+01    0.57264E+03    0.67045E-07    0.11640E-10    0.52780E-15
+    5    2    0.81846E-08    0.10000E+01    0.46180E+03    0.13065E-06    0.39134E-10    0.10215E-14
+    5    2    0.81846E-08    0.10000E+01    0.37242E+03    0.24924E-06    0.11930E-09    0.19388E-14
+    5    2    0.81846E-08    0.10000E+01    0.30034E+03    0.46015E-06    0.31993E-09    0.35664E-14
+    5    2    0.81846E-08    0.10000E+01    0.24221E+03    0.81042E-06    0.74695E-09    0.62652E-14
+    5    2    0.81846E-08    0.10000E+01    0.19533E+03    0.12769E-05    0.14194E-08    0.98564E-14
+    5    2    0.81846E-08    0.10000E+01    0.15752E+03    0.12769E-05    0.14194E-08    0.98564E-14
+    5    2    0.14282E-07    0.10000E+01    0.80645E+05    0.25434E-54    0.18995E-65    0.21946E-61
+    5    2    0.14282E-07    0.10000E+01    0.65036E+05    0.21485E-53    0.30128E-64    0.18549E-60
+    5    2    0.14282E-07    0.10000E+01    0.52449E+05    0.18232E-52    0.40309E-63    0.15748E-59
+    5    2    0.14282E-07    0.10000E+01    0.42297E+05    0.13669E-51    0.54323E-62    0.11819E-58
+    5    2    0.14282E-07    0.10000E+01    0.34111E+05    0.97921E-51    0.73576E-61    0.84827E-58
+    5    2    0.14282E-07    0.10000E+01    0.27509E+05    0.69497E-50    0.97474E-60    0.60404E-57
+    5    2    0.14282E-07    0.10000E+01    0.22184E+05    0.48558E-49    0.12495E-58    0.42441E-56
+    5    2    0.14282E-07    0.10000E+01    0.17891E+05    0.33024E-48    0.15457E-57    0.29113E-55
+    5    2    0.14282E-07    0.10000E+01    0.14428E+05    0.21754E-47    0.18639E-56    0.19370E-54
+    5    2    0.14282E-07    0.10000E+01    0.11635E+05    0.13954E-46    0.22569E-55    0.12459E-53
+    5    2    0.14282E-07    0.10000E+01    0.93834E+04    0.89285E-46    0.30082E-54    0.76927E-53
+    5    2    0.14282E-07    0.10000E+01    0.75673E+04    0.61465E-45    0.52708E-53    0.45192E-52
+    5    2    0.14282E-07    0.10000E+01    0.61026E+04    0.53070E-44    0.12594E-51    0.26253E-51
+    5    2    0.14282E-07    0.10000E+01    0.49215E+04    0.61822E-43    0.34294E-50    0.18329E-50
+    5    2    0.14282E-07    0.10000E+01    0.39689E+04    0.85185E-42    0.94231E-49    0.18948E-49
+    5    2    0.14282E-07    0.10000E+01    0.32008E+04    0.38302E-39    0.82542E-46    0.78393E-47
+    5    2    0.14282E-07    0.10000E+01    0.25813E+04    0.28314E-30    0.13864E-36    0.54822E-38
+    5    2    0.14282E-07    0.10000E+01    0.20817E+04    0.54050E-14    0.11677E-19    0.96214E-22
+    5    2    0.14282E-07    0.10000E+01    0.16788E+04    0.18309E-08    0.17162E-13    0.30532E-16
+    5    2    0.14282E-07    0.10000E+01    0.13538E+04    0.39029E-08    0.65079E-13    0.61204E-16
+    5    2    0.14282E-07    0.10000E+01    0.10918E+04    0.81602E-08    0.24224E-12    0.12263E-15
+    5    2    0.14282E-07    0.10000E+01    0.88049E+03    0.16721E-07    0.89047E-12    0.24371E-15
+    5    2    0.14282E-07    0.10000E+01    0.71007E+03    0.33627E-07    0.32383E-11    0.47919E-15
+    5    2    0.14282E-07    0.10000E+01    0.57264E+03    0.66516E-07    0.11510E-10    0.93199E-15
+    5    2    0.14282E-07    0.10000E+01    0.46180E+03    0.12948E-06    0.38687E-10    0.17913E-14
+    5    2    0.14282E-07    0.10000E+01    0.37242E+03    0.24680E-06    0.11791E-09    0.33826E-14
+    5    2    0.14282E-07    0.10000E+01    0.30034E+03    0.45537E-06    0.31619E-09    0.61999E-14
+    5    2    0.14282E-07    0.10000E+01    0.24221E+03    0.80168E-06    0.73816E-09    0.10865E-13
+    5    2    0.14282E-07    0.10000E+01    0.19533E+03    0.12629E-05    0.14026E-08    0.17066E-13
+    5    2    0.14282E-07    0.10000E+01    0.15752E+03    0.12629E-05    0.14026E-08    0.17066E-13
+    5    2    0.24920E-07    0.10000E+01    0.80645E+05    0.47258E-54    0.35306E-65    0.70004E-61
+    5    2    0.24920E-07    0.10000E+01    0.65036E+05    0.39933E-53    0.56014E-64    0.59186E-60
+    5    2    0.24920E-07    0.10000E+01    0.52449E+05    0.33895E-52    0.74992E-63    0.50262E-59
+    5    2    0.24920E-07    0.10000E+01    0.42297E+05    0.25426E-51    0.10118E-61    0.37740E-58
+    5    2    0.24920E-07    0.10000E+01    0.34111E+05    0.18233E-50    0.13732E-60    0.27111E-57
+    5    2    0.24920E-07    0.10000E+01    0.27509E+05    0.12963E-49    0.18255E-59    0.19334E-56
+    5    2    0.24920E-07    0.10000E+01    0.22184E+05    0.90844E-49    0.23526E-58    0.13619E-55
+    5    2    0.24920E-07    0.10000E+01    0.17891E+05    0.62060E-48    0.29272E-57    0.93812E-55
+    5    2    0.24920E-07    0.10000E+01    0.14428E+05    0.41084E-47    0.35289E-56    0.62837E-54
+    5    2    0.24920E-07    0.10000E+01    0.11635E+05    0.26364E-46    0.41539E-55    0.40822E-53
+    5    2    0.24920E-07    0.10000E+01    0.93834E+04    0.16506E-45    0.49607E-54    0.25550E-52
+    5    2    0.24920E-07    0.10000E+01    0.75673E+04    0.10419E-44    0.70147E-53    0.15188E-51
+    5    2    0.24920E-07    0.10000E+01    0.61026E+04    0.74782E-44    0.14191E-51    0.86420E-51
+    5    2    0.24920E-07    0.10000E+01    0.49215E+04    0.72731E-43    0.36883E-50    0.53725E-50
+    5    2    0.24920E-07    0.10000E+01    0.39689E+04    0.92906E-42    0.10066E-48    0.47388E-49
+    5    2    0.24920E-07    0.10000E+01    0.32008E+04    0.41002E-39    0.87436E-46    0.18220E-46
+    5    2    0.24920E-07    0.10000E+01    0.25813E+04    0.29955E-30    0.14433E-36    0.12346E-37
+    5    2    0.24920E-07    0.10000E+01    0.20817E+04    0.56212E-14    0.11818E-19    0.20772E-21
+    5    2    0.24920E-07    0.10000E+01    0.16788E+04    0.18805E-08    0.17132E-13    0.63205E-16
+    5    2    0.24920E-07    0.10000E+01    0.13538E+04    0.39631E-08    0.64779E-13    0.12109E-15
+    5    2    0.24920E-07    0.10000E+01    0.10918E+04    0.82235E-08    0.24061E-12    0.23447E-15
+    5    2    0.24920E-07    0.10000E+01    0.88049E+03    0.16762E-07    0.88304E-12    0.45408E-15
+    5    2    0.24920E-07    0.10000E+01    0.71007E+03    0.33581E-07    0.32076E-11    0.87529E-15
+    5    2    0.24920E-07    0.10000E+01    0.57264E+03    0.66240E-07    0.11392E-10    0.16767E-14
+    5    2    0.24920E-07    0.10000E+01    0.46180E+03    0.12867E-06    0.38270E-10    0.31855E-14
+    5    2    0.24920E-07    0.10000E+01    0.37242E+03    0.24488E-06    0.11661E-09    0.59641E-14
+    5    2    0.24920E-07    0.10000E+01    0.30034E+03    0.45135E-06    0.31263E-09    0.10865E-13
+    5    2    0.24920E-07    0.10000E+01    0.24221E+03    0.79400E-06    0.72978E-09    0.18959E-13
+    5    2    0.24920E-07    0.10000E+01    0.19533E+03    0.12502E-05    0.13866E-08    0.29704E-13
+    5    2    0.24920E-07    0.10000E+01    0.15752E+03    0.12502E-05    0.13866E-08    0.29704E-13
+    5    2    0.43485E-07    0.10000E+01    0.80645E+05    0.87160E-54    0.65140E-65    0.22252E-60
+    5    2    0.43485E-07    0.10000E+01    0.65036E+05    0.73671E-53    0.10337E-63    0.18818E-59
+    5    2    0.43485E-07    0.10000E+01    0.52449E+05    0.62549E-52    0.13848E-62    0.15985E-58
+    5    2    0.43485E-07    0.10000E+01    0.42297E+05    0.46944E-51    0.18705E-61    0.12007E-57
+    5    2    0.43485E-07    0.10000E+01    0.34111E+05    0.33696E-50    0.25432E-60    0.86325E-57
+    5    2    0.43485E-07    0.10000E+01    0.27509E+05    0.23996E-49    0.33916E-59    0.61641E-56
+    5    2    0.43485E-07    0.10000E+01    0.22184E+05    0.16861E-48    0.43935E-58    0.43513E-55
+    5    2    0.43485E-07    0.10000E+01    0.17891E+05    0.11570E-47    0.55062E-57    0.30081E-54
+    5    2    0.43485E-07    0.10000E+01    0.14428E+05    0.77063E-47    0.66843E-56    0.20261E-53
+    5    2    0.43485E-07    0.10000E+01    0.11635E+05    0.49757E-46    0.78460E-55    0.13270E-52
+    5    2    0.43485E-07    0.10000E+01    0.93834E+04    0.31108E-45    0.89459E-54    0.84023E-52
+    5    2    0.43485E-07    0.10000E+01    0.75673E+04    0.18960E-44    0.10832E-52    0.50631E-51
+    5    2    0.43485E-07    0.10000E+01    0.61026E+04    0.12049E-43    0.17804E-51    0.28795E-50
+    5    2    0.43485E-07    0.10000E+01    0.49215E+04    0.96554E-43    0.42183E-50    0.16768E-49
+    5    2    0.43485E-07    0.10000E+01    0.39689E+04    0.10902E-41    0.11305E-48    0.12893E-48
+    5    2    0.43485E-07    0.10000E+01    0.32008E+04    0.46310E-39    0.96935E-46    0.45537E-46
+    5    2    0.43485E-07    0.10000E+01    0.25813E+04    0.33181E-30    0.15580E-36    0.29910E-37
+    5    2    0.43485E-07    0.10000E+01    0.20817E+04    0.60643E-14    0.12164E-19    0.48574E-21
+    5    2    0.43485E-07    0.10000E+01    0.16788E+04    0.19862E-08    0.17199E-13    0.14161E-15
+    5    2    0.43485E-07    0.10000E+01    0.13538E+04    0.41033E-08    0.64691E-13    0.25667E-15
+    5    2    0.43485E-07    0.10000E+01    0.10918E+04    0.83999E-08    0.23935E-12    0.47504E-15
+    5    2    0.43485E-07    0.10000E+01    0.88049E+03    0.16959E-07    0.87591E-12    0.88698E-15
+    5    2    0.43485E-07    0.10000E+01    0.71007E+03    0.33741E-07    0.31752E-11    0.16603E-14
+    5    2    0.43485E-07    0.10000E+01    0.57264E+03    0.66215E-07    0.11261E-10    0.31067E-14
+    5    2    0.43485E-07    0.10000E+01    0.46180E+03    0.12813E-06    0.37798E-10    0.57947E-14
+    5    2    0.43485E-07    0.10000E+01    0.37242E+03    0.24318E-06    0.11511E-09    0.10699E-13
+    5    2    0.43485E-07    0.10000E+01    0.30034E+03    0.44734E-06    0.30851E-09    0.19292E-13
+    5    2    0.43485E-07    0.10000E+01    0.24221E+03    0.78590E-06    0.72003E-09    0.33426E-13
+    5    2    0.43485E-07    0.10000E+01    0.19533E+03    0.12364E-05    0.13680E-08    0.52141E-13
+    5    2    0.43485E-07    0.10000E+01    0.15752E+03    0.12364E-05    0.13680E-08    0.52141E-13
+    5    2    0.75878E-07    0.10000E+01    0.80645E+05    0.15959E-53    0.11931E-64    0.70144E-60
+    5    2    0.75878E-07    0.10000E+01    0.65036E+05    0.13493E-52    0.18938E-63    0.59334E-59
+    5    2    0.75878E-07    0.10000E+01    0.52449E+05    0.11459E-51    0.25385E-62    0.50411E-58
+    5    2    0.75878E-07    0.10000E+01    0.42297E+05    0.86042E-51    0.34323E-61    0.37883E-57
+    5    2    0.75878E-07    0.10000E+01    0.34111E+05    0.61811E-50    0.46742E-60    0.27254E-56
+    5    2    0.75878E-07    0.10000E+01    0.27509E+05    0.44081E-49    0.62507E-59    0.19483E-55
+    5    2    0.75878E-07    0.10000E+01    0.22184E+05    0.31050E-48    0.81347E-58    0.13778E-54
+    5    2    0.75878E-07    0.10000E+01    0.17891E+05    0.21389E-47    0.10265E-56    0.95536E-54
+    5    2    0.75878E-07    0.10000E+01    0.14428E+05    0.14331E-46    0.12568E-55    0.64642E-53
+    5    2    0.75878E-07    0.10000E+01    0.11635E+05    0.93218E-46    0.14854E-54    0.42620E-52
+    5    2    0.75878E-07    0.10000E+01    0.93834E+04    0.58644E-45    0.16752E-53    0.27245E-51
+    5    2    0.75878E-07    0.10000E+01    0.75673E+04    0.35470E-44    0.18661E-52    0.16626E-50
+    5    2    0.75878E-07    0.10000E+01    0.61026E+04    0.21193E-43    0.25355E-51    0.95284E-50
+    5    2    0.75878E-07    0.10000E+01    0.49215E+04    0.14527E-42    0.52426E-50    0.53724E-49
+    5    2    0.75878E-07    0.10000E+01    0.39689E+04    0.14071E-41    0.13572E-48    0.37194E-48
+    5    2    0.75878E-07    0.10000E+01    0.32008E+04    0.56219E-39    0.11448E-45    0.12051E-45
+    5    2    0.75878E-07    0.10000E+01    0.25813E+04    0.39220E-30    0.17780E-36    0.76921E-37
+    5    2    0.75878E-07    0.10000E+01    0.20817E+04    0.69288E-14    0.12933E-19    0.12208E-20
+    5    2    0.75878E-07    0.10000E+01    0.16788E+04    0.22011E-08    0.17543E-13    0.34337E-15
+    5    2    0.75878E-07    0.10000E+01    0.13538E+04    0.44067E-08    0.65393E-13    0.58749E-15
+    5    2    0.75878E-07    0.10000E+01    0.10918E+04    0.88238E-08    0.24032E-12    0.10327E-14
+    5    2    0.75878E-07    0.10000E+01    0.88049E+03    0.17533E-07    0.87514E-12    0.18431E-14
+    5    2    0.75878E-07    0.10000E+01    0.71007E+03    0.34473E-07    0.31613E-11    0.33184E-14
+    5    2    0.75878E-07    0.10000E+01    0.57264E+03    0.67057E-07    0.11185E-10    0.60082E-14
+    5    2    0.75878E-07    0.10000E+01    0.46180E+03    0.12891E-06    0.37485E-10    0.10907E-13
+    5    2    0.75878E-07    0.10000E+01    0.37242E+03    0.24349E-06    0.11405E-09    0.19711E-13
+    5    2    0.75878E-07    0.10000E+01    0.30034E+03    0.44637E-06    0.30552E-09    0.34977E-13
+    5    2    0.75878E-07    0.10000E+01    0.24221E+03    0.78235E-06    0.71282E-09    0.59912E-13
+    5    2    0.75878E-07    0.10000E+01    0.19533E+03    0.12291E-05    0.13540E-08    0.92786E-13
+    5    2    0.75878E-07    0.10000E+01    0.15752E+03    0.12291E-05    0.13540E-08    0.92786E-13
+    5    2    0.13240E-06    0.10000E+01    0.80645E+05    0.29041E-53    0.21719E-64    0.22023E-59
+    5    2    0.13240E-06    0.10000E+01    0.65036E+05    0.24560E-52    0.34480E-63    0.18633E-58
+    5    2    0.13240E-06    0.10000E+01    0.52449E+05    0.20862E-51    0.46241E-62    0.15834E-57
+    5    2    0.13240E-06    0.10000E+01    0.42297E+05    0.15671E-50    0.62577E-61    0.11903E-56
+    5    2    0.13240E-06    0.10000E+01    0.34111E+05    0.11267E-49    0.85341E-60    0.85682E-56
+    5    2    0.13240E-06    0.10000E+01    0.27509E+05    0.80449E-49    0.11440E-58    0.61311E-55
+    5    2    0.13240E-06    0.10000E+01    0.22184E+05    0.56787E-48    0.14948E-57    0.43428E-54
+    5    2    0.13240E-06    0.10000E+01    0.17891E+05    0.39253E-47    0.18977E-56    0.30188E-53
+    5    2    0.13240E-06    0.10000E+01    0.14428E+05    0.26436E-46    0.23425E-55    0.20504E-52
+    5    2    0.13240E-06    0.10000E+01    0.11635E+05    0.17319E-45    0.27951E-54    0.13593E-51
+    5    2    0.13240E-06    0.10000E+01    0.93834E+04    0.10987E-44    0.31659E-53    0.87578E-51
+    5    2    0.13240E-06    0.10000E+01    0.75673E+04    0.66721E-44    0.34078E-52    0.54034E-50
+    5    2    0.13240E-06    0.10000E+01    0.61026E+04    0.38912E-43    0.40337E-51    0.31287E-49
+    5    2    0.13240E-06    0.10000E+01    0.49215E+04    0.24067E-42    0.71227E-50    0.17400E-48
+    5    2    0.13240E-06    0.10000E+01    0.39689E+04    0.20007E-41    0.17481E-48    0.11172E-47
+    5    2    0.13240E-06    0.10000E+01    0.32008E+04    0.73693E-39    0.14480E-45    0.33377E-45
+    5    2    0.13240E-06    0.10000E+01    0.25813E+04    0.49795E-30    0.21656E-36    0.20756E-36
+    5    2    0.13240E-06    0.10000E+01    0.20817E+04    0.84812E-14    0.14346E-19    0.32601E-20
+    5    2    0.13240E-06    0.10000E+01    0.16788E+04    0.25935E-08    0.18247E-13    0.89431E-15
+    5    2    0.13240E-06    0.10000E+01    0.13538E+04    0.49665E-08    0.67012E-13    0.14524E-14
+    5    2    0.13240E-06    0.10000E+01    0.10918E+04    0.96197E-08    0.24350E-12    0.24262E-14
+    5    2    0.13240E-06    0.10000E+01    0.88049E+03    0.18642E-07    0.87931E-12    0.41245E-14
+    5    2    0.13240E-06    0.10000E+01    0.71007E+03    0.35962E-07    0.31572E-11    0.70953E-14
+    5    2    0.13240E-06    0.10000E+01    0.57264E+03    0.68942E-07    0.11125E-10    0.12323E-13
+    5    2    0.13240E-06    0.10000E+01    0.46180E+03    0.13108E-06    0.37187E-10    0.21567E-13
+    5    2    0.13240E-06    0.10000E+01    0.37242E+03    0.24556E-06    0.11297E-09    0.37800E-13
+    5    2    0.13240E-06    0.10000E+01    0.30034E+03    0.44754E-06    0.30233E-09    0.65487E-13
+    5    2    0.13240E-06    0.10000E+01    0.24221E+03    0.78125E-06    0.70498E-09    0.11020E-12
+    5    2    0.13240E-06    0.10000E+01    0.19533E+03    0.12243E-05    0.13387E-08    0.16874E-12
+    5    2    0.13240E-06    0.10000E+01    0.15752E+03    0.12243E-05    0.13387E-08    0.16874E-12
+    5    2    0.23103E-06    0.10000E+01    0.80645E+05    0.52445E-53    0.39232E-64    0.67490E-59
+    5    2    0.23103E-06    0.10000E+01    0.65036E+05    0.44363E-52    0.62296E-63    0.57111E-58
+    5    2    0.23103E-06    0.10000E+01    0.52449E+05    0.37691E-51    0.83583E-62    0.48538E-57
+    5    2    0.23103E-06    0.10000E+01    0.42297E+05    0.28323E-50    0.11320E-60    0.36497E-56
+    5    2    0.23103E-06    0.10000E+01    0.34111E+05    0.20376E-49    0.15457E-59    0.26286E-55
+    5    2    0.23103E-06    0.10000E+01    0.27509E+05    0.14565E-48    0.20763E-58    0.18824E-54
+    5    2    0.23103E-06    0.10000E+01    0.22184E+05    0.10300E-47    0.27221E-57    0.13351E-53
+    5    2    0.23103E-06    0.10000E+01    0.17891E+05    0.71405E-47    0.34737E-56    0.92993E-53
+    5    2    0.23103E-06    0.10000E+01    0.14428E+05    0.48303E-46    0.43185E-55    0.63356E-52
+    5    2    0.23103E-06    0.10000E+01    0.11635E+05    0.31842E-45    0.52007E-54    0.42186E-51
+    5    2    0.23103E-06    0.10000E+01    0.93834E+04    0.20363E-44    0.59468E-53    0.27348E-50
+    5    2    0.23103E-06    0.10000E+01    0.75673E+04    0.12466E-43    0.63508E-52    0.17023E-49
+    5    2    0.23103E-06    0.10000E+01    0.61026E+04    0.72350E-43    0.69201E-51    0.99550E-49
+    5    2    0.23103E-06    0.10000E+01    0.49215E+04    0.42242E-42    0.10538E-49    0.55152E-48
+    5    2    0.23103E-06    0.10000E+01    0.39689E+04    0.30952E-41    0.24159E-48    0.33670E-47
+    5    2    0.23103E-06    0.10000E+01    0.32008E+04    0.10420E-38    0.19655E-45    0.93852E-45
+    5    2    0.23103E-06    0.10000E+01    0.25813E+04    0.68098E-30    0.28408E-36    0.57040E-36
+    5    2    0.23103E-06    0.10000E+01    0.20817E+04    0.11236E-13    0.16919E-19    0.89503E-20
+    5    2    0.23103E-06    0.10000E+01    0.16788E+04    0.33027E-08    0.19671E-13    0.24210E-14
+    5    2    0.23103E-06    0.10000E+01    0.13538E+04    0.59892E-08    0.70603E-13    0.37762E-14
+    5    2    0.23103E-06    0.10000E+01    0.10918E+04    0.11102E-07    0.25198E-12    0.60458E-14
+    5    2    0.23103E-06    0.10000E+01    0.88049E+03    0.20769E-07    0.89755E-12    0.98361E-14
+    5    2    0.23103E-06    0.10000E+01    0.71007E+03    0.38952E-07    0.31907E-11    0.16181E-13
+    5    2    0.23103E-06    0.10000E+01    0.57264E+03    0.73021E-07    0.11166E-10    0.26883E-13
+    5    2    0.23103E-06    0.10000E+01    0.46180E+03    0.13642E-06    0.37159E-10    0.45097E-13
+    5    2    0.23103E-06    0.10000E+01    0.37242E+03    0.25221E-06    0.11258E-09    0.76088E-13
+    5    2    0.23103E-06    0.10000E+01    0.30034E+03    0.45525E-06    0.30082E-09    0.12770E-12
+    5    2    0.23103E-06    0.10000E+01    0.24221E+03    0.78938E-06    0.70079E-09    0.20967E-12
+    5    2    0.23103E-06    0.10000E+01    0.19533E+03    0.12319E-05    0.13300E-08    0.31581E-12
+    5    2    0.23103E-06    0.10000E+01    0.15752E+03    0.12319E-05    0.13300E-08    0.31581E-12
+    5    2    0.40314E-06    0.10000E+01    0.80645E+05    0.91820E-53    0.68689E-64    0.12560E-58
+    5    2    0.40314E-06    0.10000E+01    0.65036E+05    0.77671E-52    0.10907E-62    0.10629E-57
+    5    2    0.40314E-06    0.10000E+01    0.52449E+05    0.65991E-51    0.14635E-61    0.90335E-57
+    5    2    0.40314E-06    0.10000E+01    0.42297E+05    0.49592E-50    0.19822E-60    0.67927E-56
+    5    2    0.40314E-06    0.10000E+01    0.34111E+05    0.35680E-49    0.27070E-59    0.48924E-55
+    5    2    0.40314E-06    0.10000E+01    0.27509E+05    0.25508E-48    0.36371E-58    0.35039E-54
+    5    2    0.40314E-06    0.10000E+01    0.22184E+05    0.18042E-47    0.47702E-57    0.24854E-53
+    5    2    0.40314E-06    0.10000E+01    0.17891E+05    0.12511E-46    0.60906E-56    0.17316E-52
+    5    2    0.40314E-06    0.10000E+01    0.14428E+05    0.84677E-46    0.75777E-55    0.11801E-51
+    5    2    0.40314E-06    0.10000E+01    0.11635E+05    0.55857E-45    0.91354E-54    0.78611E-51
+    5    2    0.40314E-06    0.10000E+01    0.93834E+04    0.35753E-44    0.10459E-52    0.50994E-50
+    5    2    0.40314E-06    0.10000E+01    0.75673E+04    0.21911E-43    0.11170E-51    0.31771E-49
+    5    2    0.40314E-06    0.10000E+01    0.61026E+04    0.12718E-42    0.12086E-50    0.18599E-48
+    5    2    0.40314E-06    0.10000E+01    0.49215E+04    0.73907E-42    0.18111E-49    0.10303E-47
+    5    2    0.40314E-06    0.10000E+01    0.39689E+04    0.53458E-41    0.41154E-48    0.62608E-47
+    5    2    0.40314E-06    0.10000E+01    0.32008E+04    0.17803E-38    0.33411E-45    0.17325E-44
+    5    2    0.40314E-06    0.10000E+01    0.25813E+04    0.11589E-29    0.48115E-36    0.10503E-35
+    5    2    0.40314E-06    0.10000E+01    0.20817E+04    0.19060E-13    0.28286E-19    0.16486E-19
+    5    2    0.40314E-06    0.10000E+01    0.16788E+04    0.55771E-08    0.32479E-13    0.44544E-14
+    5    2    0.40314E-06    0.10000E+01    0.13538E+04    0.10044E-07    0.11618E-12    0.69203E-14
+    5    2    0.40314E-06    0.10000E+01    0.10918E+04    0.18508E-07    0.41350E-12    0.11032E-13
+    5    2    0.40314E-06    0.10000E+01    0.88049E+03    0.34455E-07    0.14698E-11    0.17866E-13
+    5    2    0.40314E-06    0.10000E+01    0.71007E+03    0.64360E-07    0.52169E-11    0.29245E-13
+    5    2    0.40314E-06    0.10000E+01    0.57264E+03    0.12025E-06    0.18236E-10    0.48340E-13
+    5    2    0.40314E-06    0.10000E+01    0.46180E+03    0.22407E-06    0.60647E-10    0.80676E-13
+    5    2    0.40314E-06    0.10000E+01    0.37242E+03    0.41340E-06    0.18366E-09    0.13546E-12
+    5    2    0.40314E-06    0.10000E+01    0.30034E+03    0.74510E-06    0.49063E-09    0.22640E-12
+    5    2    0.40314E-06    0.10000E+01    0.24221E+03    0.12906E-05    0.11428E-08    0.37048E-12
+    5    2    0.40314E-06    0.10000E+01    0.19533E+03    0.20128E-05    0.21687E-08    0.55678E-12
+    5    2    0.40314E-06    0.10000E+01    0.15752E+03    0.20128E-05    0.21687E-08    0.55678E-12
+    5    2    0.70346E-06    0.10000E+01    0.80645E+05    0.16022E-52    0.11986E-63    0.21917E-58
+    5    2    0.70346E-06    0.10000E+01    0.65036E+05    0.13553E-51    0.19032E-62    0.18546E-57
+    5    2    0.70346E-06    0.10000E+01    0.52449E+05    0.11515E-50    0.25537E-61    0.15763E-56
+    5    2    0.70346E-06    0.10000E+01    0.42297E+05    0.86535E-50    0.34589E-60    0.11853E-55
+    5    2    0.70346E-06    0.10000E+01    0.34111E+05    0.62259E-49    0.47236E-59    0.85370E-55
+    5    2    0.70346E-06    0.10000E+01    0.27509E+05    0.44510E-48    0.63466E-58    0.61141E-54
+    5    2    0.70346E-06    0.10000E+01    0.22184E+05    0.31481E-47    0.83238E-57    0.43369E-53
+    5    2    0.70346E-06    0.10000E+01    0.17891E+05    0.21832E-46    0.10628E-55    0.30215E-52
+    5    2    0.70346E-06    0.10000E+01    0.14428E+05    0.14776E-45    0.13223E-54    0.20592E-51
+    5    2    0.70346E-06    0.10000E+01    0.11635E+05    0.97467E-45    0.15941E-53    0.13717E-50
+    5    2    0.70346E-06    0.10000E+01    0.93834E+04    0.62387E-44    0.18250E-52    0.88981E-50
+    5    2    0.70346E-06    0.10000E+01    0.75673E+04    0.38233E-43    0.19491E-51    0.55438E-49
+    5    2    0.70346E-06    0.10000E+01    0.61026E+04    0.22192E-42    0.21090E-50    0.32455E-48
+    5    2    0.70346E-06    0.10000E+01    0.49215E+04    0.12896E-41    0.31603E-49    0.17978E-47
+    5    2    0.70346E-06    0.10000E+01    0.39689E+04    0.93281E-41    0.71811E-48    0.10925E-46
+    5    2    0.70346E-06    0.10000E+01    0.32008E+04    0.31065E-38    0.58300E-45    0.30231E-44
+    5    2    0.70346E-06    0.10000E+01    0.25813E+04    0.20222E-29    0.83957E-36    0.18328E-35
+    5    2    0.70346E-06    0.10000E+01    0.20817E+04    0.33259E-13    0.49357E-19    0.28766E-19
+    5    2    0.70346E-06    0.10000E+01    0.16788E+04    0.97318E-08    0.56674E-13    0.77726E-14
+    5    2    0.70346E-06    0.10000E+01    0.13538E+04    0.17526E-07    0.20272E-12    0.12075E-13
+    5    2    0.70346E-06    0.10000E+01    0.10918E+04    0.32296E-07    0.72152E-12    0.19250E-13
+    5    2    0.70346E-06    0.10000E+01    0.88049E+03    0.60122E-07    0.25647E-11    0.31174E-13
+    5    2    0.70346E-06    0.10000E+01    0.71007E+03    0.11231E-06    0.91031E-11    0.51031E-13
+    5    2    0.70346E-06    0.10000E+01    0.57264E+03    0.20983E-06    0.31821E-10    0.84350E-13
+    5    2    0.70346E-06    0.10000E+01    0.46180E+03    0.39099E-06    0.10583E-09    0.14078E-12
+    5    2    0.70346E-06    0.10000E+01    0.37242E+03    0.72136E-06    0.32048E-09    0.23638E-12
+    5    2    0.70346E-06    0.10000E+01    0.30034E+03    0.13002E-05    0.85612E-09    0.39506E-12
+    5    2    0.70346E-06    0.10000E+01    0.24221E+03    0.22520E-05    0.19941E-08    0.64647E-12
+    5    2    0.70346E-06    0.10000E+01    0.19533E+03    0.35123E-05    0.37842E-08    0.97154E-12
+    5    2    0.70346E-06    0.10000E+01    0.15752E+03    0.35123E-05    0.37842E-08    0.97154E-12
+    5    2    0.12275E-05    0.10000E+01    0.80645E+05    0.27957E-52    0.20915E-63    0.38243E-58
+    5    2    0.12275E-05    0.10000E+01    0.65036E+05    0.23649E-51    0.33210E-62    0.32362E-57
+    5    2    0.12275E-05    0.10000E+01    0.52449E+05    0.20093E-50    0.44561E-61    0.27505E-56
+    5    2    0.12275E-05    0.10000E+01    0.42297E+05    0.15100E-49    0.60355E-60    0.20683E-55
+    5    2    0.12275E-05    0.10000E+01    0.34111E+05    0.10864E-48    0.82423E-59    0.14897E-54
+    5    2    0.12275E-05    0.10000E+01    0.27509E+05    0.77667E-48    0.11074E-57    0.10669E-53
+    5    2    0.12275E-05    0.10000E+01    0.22184E+05    0.54933E-47    0.14524E-56    0.75676E-53
+    5    2    0.12275E-05    0.10000E+01    0.17891E+05    0.38095E-46    0.18545E-55    0.52723E-52
+    5    2    0.12275E-05    0.10000E+01    0.14428E+05    0.25782E-45    0.23073E-54    0.35932E-51
+    5    2    0.12275E-05    0.10000E+01    0.11635E+05    0.17007E-44    0.27815E-53    0.23936E-50
+    5    2    0.12275E-05    0.10000E+01    0.93834E+04    0.10886E-43    0.31845E-52    0.15527E-49
+    5    2    0.12275E-05    0.10000E+01    0.75673E+04    0.66715E-43    0.34010E-51    0.96737E-49
+    5    2    0.12275E-05    0.10000E+01    0.61026E+04    0.38724E-42    0.36800E-50    0.56631E-48
+    5    2    0.12275E-05    0.10000E+01    0.49215E+04    0.22503E-41    0.55145E-49    0.31371E-47
+    5    2    0.12275E-05    0.10000E+01    0.39689E+04    0.16277E-40    0.12531E-47    0.19063E-46
+    5    2    0.12275E-05    0.10000E+01    0.32008E+04    0.54207E-38    0.10173E-44    0.52751E-44
+    5    2    0.12275E-05    0.10000E+01    0.25813E+04    0.35286E-29    0.14650E-35    0.31980E-35
+    5    2    0.12275E-05    0.10000E+01    0.20817E+04    0.58034E-13    0.86124E-19    0.50195E-19
+    5    2    0.12275E-05    0.10000E+01    0.16788E+04    0.16981E-07    0.98893E-13    0.13563E-13
+    5    2    0.12275E-05    0.10000E+01    0.13538E+04    0.30582E-07    0.35374E-12    0.21071E-13
+    5    2    0.12275E-05    0.10000E+01    0.10918E+04    0.56354E-07    0.12590E-11    0.33590E-13
+    5    2    0.12275E-05    0.10000E+01    0.88049E+03    0.10491E-06    0.44752E-11    0.54397E-13
+    5    2    0.12275E-05    0.10000E+01    0.71007E+03    0.19597E-06    0.15884E-10    0.89046E-13
+    5    2    0.12275E-05    0.10000E+01    0.57264E+03    0.36615E-06    0.55526E-10    0.14719E-12
+    5    2    0.12275E-05    0.10000E+01    0.46180E+03    0.68226E-06    0.18466E-09    0.24564E-12
+    5    2    0.12275E-05    0.10000E+01    0.37242E+03    0.12587E-05    0.55922E-09    0.41246E-12
+    5    2    0.12275E-05    0.10000E+01    0.30034E+03    0.22687E-05    0.14939E-08    0.68935E-12
+    5    2    0.12275E-05    0.10000E+01    0.24221E+03    0.39297E-05    0.34796E-08    0.11280E-11
+    5    2    0.12275E-05    0.10000E+01    0.19533E+03    0.61287E-05    0.66033E-08    0.16953E-11
+    5    2    0.12275E-05    0.10000E+01    0.15752E+03    0.61287E-05    0.66033E-08    0.16953E-11
+    5    2    0.21419E-05    0.10000E+01    0.80645E+05    0.48784E-52    0.36495E-63    0.66732E-58
+    5    2    0.21419E-05    0.10000E+01    0.65036E+05    0.41267E-51    0.57950E-62    0.56471E-57
+    5    2    0.21419E-05    0.10000E+01    0.52449E+05    0.35061E-50    0.77756E-61    0.47995E-56
+    5    2    0.21419E-05    0.10000E+01    0.42297E+05    0.26348E-49    0.10532E-59    0.36090E-55
+    5    2    0.21419E-05    0.10000E+01    0.34111E+05    0.18957E-48    0.14382E-58    0.25994E-54
+    5    2    0.21419E-05    0.10000E+01    0.27509E+05    0.13552E-47    0.19324E-57    0.18616E-53
+    5    2    0.21419E-05    0.10000E+01    0.22184E+05    0.95855E-47    0.25344E-56    0.13205E-52
+    5    2    0.21419E-05    0.10000E+01    0.17891E+05    0.66473E-46    0.32360E-55    0.91998E-52
+    5    2    0.21419E-05    0.10000E+01    0.14428E+05    0.44989E-45    0.40260E-54    0.62698E-51
+    5    2    0.21419E-05    0.10000E+01    0.11635E+05    0.29677E-44    0.48536E-53    0.41766E-50
+    5    2    0.21419E-05    0.10000E+01    0.93834E+04    0.18996E-43    0.55568E-52    0.27093E-49
+    5    2    0.21419E-05    0.10000E+01    0.75673E+04    0.11641E-42    0.59345E-51    0.16880E-48
+    5    2    0.21419E-05    0.10000E+01    0.61026E+04    0.67571E-42    0.64214E-50    0.98818E-48
+    5    2    0.21419E-05    0.10000E+01    0.49215E+04    0.39267E-41    0.96224E-49    0.54741E-47
+    5    2    0.21419E-05    0.10000E+01    0.39689E+04    0.28402E-40    0.21865E-47    0.33264E-46
+    5    2    0.21419E-05    0.10000E+01    0.32008E+04    0.94588E-38    0.17751E-44    0.92047E-44
+    5    2    0.21419E-05    0.10000E+01    0.25813E+04    0.61572E-29    0.25563E-35    0.55804E-35
+    5    2    0.21419E-05    0.10000E+01    0.20817E+04    0.10127E-12    0.15028E-18    0.87588E-19
+    5    2    0.21419E-05    0.10000E+01    0.16788E+04    0.29631E-07    0.17256E-12    0.23666E-13
+    5    2    0.21419E-05    0.10000E+01    0.13538E+04    0.53363E-07    0.61726E-12    0.36767E-13
+    5    2    0.21419E-05    0.10000E+01    0.10918E+04    0.98334E-07    0.21969E-11    0.58613E-13
+    5    2    0.21419E-05    0.10000E+01    0.88049E+03    0.18306E-06    0.78090E-11    0.94920E-13
+    5    2    0.21419E-05    0.10000E+01    0.71007E+03    0.34195E-06    0.27717E-10    0.15538E-12
+    5    2    0.21419E-05    0.10000E+01    0.57264E+03    0.63891E-06    0.96890E-10    0.25683E-12
+    5    2    0.21419E-05    0.10000E+01    0.46180E+03    0.11905E-05    0.32222E-09    0.42864E-12
+    5    2    0.21419E-05    0.10000E+01    0.37242E+03    0.21964E-05    0.97581E-09    0.71972E-12
+    5    2    0.21419E-05    0.10000E+01    0.30034E+03    0.39588E-05    0.26067E-08    0.12029E-11
+    5    2    0.21419E-05    0.10000E+01    0.24221E+03    0.68570E-05    0.60717E-08    0.19684E-11
+    5    2    0.21419E-05    0.10000E+01    0.19533E+03    0.10694E-04    0.11522E-07    0.29582E-11
+    5    2    0.21419E-05    0.10000E+01    0.15752E+03    0.10694E-04    0.11522E-07    0.29582E-11
+    5    2    0.37375E-05    0.10000E+01    0.80645E+05    0.85125E-52    0.63681E-63    0.11644E-57
+    5    2    0.37375E-05    0.10000E+01    0.65036E+05    0.72008E-51    0.10112E-61    0.98538E-57
+    5    2    0.37375E-05    0.10000E+01    0.52449E+05    0.61180E-50    0.13568E-60    0.83749E-56
+    5    2    0.37375E-05    0.10000E+01    0.42297E+05    0.45976E-49    0.18377E-59    0.62975E-55
+    5    2    0.37375E-05    0.10000E+01    0.34111E+05    0.33078E-48    0.25096E-58    0.45357E-54
+    5    2    0.37375E-05    0.10000E+01    0.27509E+05    0.23648E-47    0.33719E-57    0.32484E-53
+    5    2    0.37375E-05    0.10000E+01    0.22184E+05    0.16726E-46    0.44224E-56    0.23042E-52
+    5    2    0.37375E-05    0.10000E+01    0.17891E+05    0.11599E-45    0.56466E-55    0.16053E-51
+    5    2    0.37375E-05    0.10000E+01    0.14428E+05    0.78503E-45    0.70252E-54    0.10940E-50
+    5    2    0.37375E-05    0.10000E+01    0.11635E+05    0.51784E-44    0.84693E-53    0.72879E-50
+    5    2    0.37375E-05    0.10000E+01    0.93834E+04    0.33147E-43    0.96962E-52    0.47276E-49
+    5    2    0.37375E-05    0.10000E+01    0.75673E+04    0.20313E-42    0.10355E-50    0.29455E-48
+    5    2    0.37375E-05    0.10000E+01    0.61026E+04    0.11791E-41    0.11205E-49    0.17243E-47
+    5    2    0.37375E-05    0.10000E+01    0.49215E+04    0.68519E-41    0.16790E-48    0.95520E-47
+    5    2    0.37375E-05    0.10000E+01    0.39689E+04    0.49560E-40    0.38153E-47    0.58043E-46
+    5    2    0.37375E-05    0.10000E+01    0.32008E+04    0.16505E-37    0.30975E-44    0.16062E-43
+    5    2    0.37375E-05    0.10000E+01    0.25813E+04    0.10744E-28    0.44606E-35    0.97375E-35
+    5    2    0.37375E-05    0.10000E+01    0.20817E+04    0.17670E-12    0.26223E-18    0.15284E-18
+    5    2    0.37375E-05    0.10000E+01    0.16788E+04    0.51705E-07    0.30111E-12    0.41296E-13
+    5    2    0.37375E-05    0.10000E+01    0.13538E+04    0.93116E-07    0.10771E-11    0.64157E-13
+    5    2    0.37375E-05    0.10000E+01    0.10918E+04    0.17159E-06    0.38335E-11    0.10228E-12
+    5    2    0.37375E-05    0.10000E+01    0.88049E+03    0.31943E-06    0.13626E-10    0.16563E-12
+    5    2    0.37375E-05    0.10000E+01    0.71007E+03    0.59668E-06    0.48365E-10    0.27113E-12
+    5    2    0.37375E-05    0.10000E+01    0.57264E+03    0.11149E-05    0.16907E-09    0.44815E-12
+    5    2    0.37375E-05    0.10000E+01    0.46180E+03    0.20773E-05    0.56225E-09    0.74794E-12
+    5    2    0.37375E-05    0.10000E+01    0.37242E+03    0.38326E-05    0.17027E-08    0.12559E-11
+    5    2    0.37375E-05    0.10000E+01    0.30034E+03    0.69078E-05    0.45486E-08    0.20989E-11
+    5    2    0.37375E-05    0.10000E+01    0.24221E+03    0.11965E-04    0.10595E-07    0.34347E-11
+    5    2    0.37375E-05    0.10000E+01    0.19533E+03    0.18661E-04    0.20106E-07    0.51618E-11
+    5    2    0.37375E-05    0.10000E+01    0.15752E+03    0.18661E-04    0.20106E-07    0.51618E-11
+    5    2    0.65217E-05    0.10000E+01    0.80645E+05    0.14854E-51    0.11112E-62    0.20319E-57
+    5    2    0.65217E-05    0.10000E+01    0.65036E+05    0.12565E-50    0.17645E-61    0.17194E-56
+    5    2    0.65217E-05    0.10000E+01    0.52449E+05    0.10676E-49    0.23675E-60    0.14614E-55
+    5    2    0.65217E-05    0.10000E+01    0.42297E+05    0.80226E-49    0.32067E-59    0.10989E-54
+    5    2    0.65217E-05    0.10000E+01    0.34111E+05    0.57719E-48    0.43792E-58    0.79146E-54
+    5    2    0.65217E-05    0.10000E+01    0.27509E+05    0.41265E-47    0.58838E-57    0.56683E-53
+    5    2    0.65217E-05    0.10000E+01    0.22184E+05    0.29186E-46    0.77169E-56    0.40207E-52
+    5    2    0.65217E-05    0.10000E+01    0.17891E+05    0.20240E-45    0.98529E-55    0.28012E-51
+    5    2    0.65217E-05    0.10000E+01    0.14428E+05    0.13698E-44    0.12258E-53    0.19090E-50
+    5    2    0.65217E-05    0.10000E+01    0.11635E+05    0.90361E-44    0.14778E-52    0.12717E-49
+    5    2    0.65217E-05    0.10000E+01    0.93834E+04    0.57839E-43    0.16919E-51    0.82493E-49
+    5    2    0.65217E-05    0.10000E+01    0.75673E+04    0.35446E-42    0.18069E-50    0.51396E-48
+    5    2    0.65217E-05    0.10000E+01    0.61026E+04    0.20574E-41    0.19552E-49    0.30088E-47
+    5    2    0.65217E-05    0.10000E+01    0.49215E+04    0.11956E-40    0.29298E-48    0.16668E-46
+    5    2    0.65217E-05    0.10000E+01    0.39689E+04    0.86479E-40    0.66575E-47    0.10128E-45
+    5    2    0.65217E-05    0.10000E+01    0.32008E+04    0.28800E-37    0.54049E-44    0.28027E-43
+    5    2    0.65217E-05    0.10000E+01    0.25813E+04    0.18747E-28    0.77836E-35    0.16991E-34
+    5    2    0.65217E-05    0.10000E+01    0.20817E+04    0.30834E-12    0.45758E-18    0.26669E-18
+    5    2    0.65217E-05    0.10000E+01    0.16788E+04    0.90222E-07    0.52542E-12    0.72059E-13
+    5    2    0.65217E-05    0.10000E+01    0.13538E+04    0.16248E-06    0.18794E-11    0.11195E-12
+    5    2    0.65217E-05    0.10000E+01    0.10918E+04    0.29941E-06    0.66892E-11    0.17847E-12
+    5    2    0.65217E-05    0.10000E+01    0.88049E+03    0.55738E-06    0.23777E-10    0.28901E-12
+    5    2    0.65217E-05    0.10000E+01    0.71007E+03    0.10412E-05    0.84394E-10    0.47311E-12
+    5    2    0.65217E-05    0.10000E+01    0.57264E+03    0.19454E-05    0.29501E-09    0.78200E-12
+    5    2    0.65217E-05    0.10000E+01    0.46180E+03    0.36248E-05    0.98109E-09    0.13051E-11
+    5    2    0.65217E-05    0.10000E+01    0.37242E+03    0.66876E-05    0.29712E-08    0.21914E-11
+    5    2    0.65217E-05    0.10000E+01    0.30034E+03    0.12054E-04    0.79370E-08    0.36625E-11
+    5    2    0.65217E-05    0.10000E+01    0.24221E+03    0.20878E-04    0.18487E-07    0.59933E-11
+    5    2    0.65217E-05    0.10000E+01    0.19533E+03    0.32562E-04    0.35083E-07    0.90071E-11
+    5    2    0.65217E-05    0.10000E+01    0.15752E+03    0.32562E-04    0.35083E-07    0.90071E-11
+    5    2    0.11380E-04    0.10000E+01    0.80645E+05    0.25919E-51    0.19390E-62    0.35455E-57
+    5    2    0.11380E-04    0.10000E+01    0.65036E+05    0.21925E-50    0.30789E-61    0.30003E-56
+    5    2    0.11380E-04    0.10000E+01    0.52449E+05    0.18628E-49    0.41312E-60    0.25500E-55
+    5    2    0.11380E-04    0.10000E+01    0.42297E+05    0.13999E-48    0.55955E-59    0.19175E-54
+    5    2    0.11380E-04    0.10000E+01    0.34111E+05    0.10072E-47    0.76414E-58    0.13810E-53
+    5    2    0.11380E-04    0.10000E+01    0.27509E+05    0.72005E-47    0.10267E-56    0.98909E-53
+    5    2    0.11380E-04    0.10000E+01    0.22184E+05    0.50928E-46    0.13465E-55    0.70159E-52
+    5    2    0.11380E-04    0.10000E+01    0.17891E+05    0.35317E-45    0.17193E-54    0.48879E-51
+    5    2    0.11380E-04    0.10000E+01    0.14428E+05    0.23903E-44    0.21390E-53    0.33312E-50
+    5    2    0.11380E-04    0.10000E+01    0.11635E+05    0.15767E-43    0.25787E-52    0.22190E-49
+    5    2    0.11380E-04    0.10000E+01    0.93834E+04    0.10092E-42    0.29523E-51    0.14395E-48
+    5    2    0.11380E-04    0.10000E+01    0.75673E+04    0.61850E-42    0.31530E-50    0.89684E-48
+    5    2    0.11380E-04    0.10000E+01    0.61026E+04    0.35900E-41    0.34117E-49    0.52502E-47
+    5    2    0.11380E-04    0.10000E+01    0.49215E+04    0.20863E-40    0.51124E-48    0.29084E-46
+    5    2    0.11380E-04    0.10000E+01    0.39689E+04    0.15090E-39    0.11617E-46    0.17673E-45
+    5    2    0.11380E-04    0.10000E+01    0.32008E+04    0.50255E-37    0.94312E-44    0.48905E-43
+    5    2    0.11380E-04    0.10000E+01    0.25813E+04    0.32713E-28    0.13582E-34    0.29649E-34
+    5    2    0.11380E-04    0.10000E+01    0.20817E+04    0.53803E-12    0.79845E-18    0.46536E-18
+    5    2    0.11380E-04    0.10000E+01    0.16788E+04    0.15743E-06    0.91682E-12    0.12574E-12
+    5    2    0.11380E-04    0.10000E+01    0.13538E+04    0.28352E-06    0.32795E-11    0.19535E-12
+    5    2    0.11380E-04    0.10000E+01    0.10918E+04    0.52245E-06    0.11672E-10    0.31141E-12
+    5    2    0.11380E-04    0.10000E+01    0.88049E+03    0.97260E-06    0.41489E-10    0.50431E-12
+    5    2    0.11380E-04    0.10000E+01    0.71007E+03    0.18168E-05    0.14726E-09    0.82554E-12
+    5    2    0.11380E-04    0.10000E+01    0.57264E+03    0.33945E-05    0.51478E-09    0.13645E-11
+    5    2    0.11380E-04    0.10000E+01    0.46180E+03    0.63251E-05    0.17119E-08    0.22773E-11
+    5    2    0.11380E-04    0.10000E+01    0.37242E+03    0.11670E-04    0.51845E-08    0.38239E-11
+    5    2    0.11380E-04    0.10000E+01    0.30034E+03    0.21033E-04    0.13850E-07    0.63909E-11
+    5    2    0.11380E-04    0.10000E+01    0.24221E+03    0.36431E-04    0.32259E-07    0.10458E-10
+    5    2    0.11380E-04    0.10000E+01    0.19533E+03    0.56818E-04    0.61218E-07    0.15717E-10
+    5    2    0.11380E-04    0.10000E+01    0.15752E+03    0.56818E-04    0.61218E-07    0.15717E-10
+    5    2    0.19857E-04    0.10000E+01    0.80645E+05    0.45227E-51    0.33834E-62    0.61866E-57
+    5    2    0.19857E-04    0.10000E+01    0.65036E+05    0.38258E-50    0.53725E-61    0.52353E-56
+    5    2    0.19857E-04    0.10000E+01    0.52449E+05    0.32505E-49    0.72087E-60    0.44496E-55
+    5    2    0.19857E-04    0.10000E+01    0.42297E+05    0.24427E-48    0.97638E-59    0.33459E-54
+    5    2    0.19857E-04    0.10000E+01    0.34111E+05    0.17575E-47    0.13334E-57    0.24098E-53
+    5    2    0.19857E-04    0.10000E+01    0.27509E+05    0.12564E-46    0.17915E-56    0.17259E-52
+    5    2    0.19857E-04    0.10000E+01    0.22184E+05    0.88866E-46    0.23496E-55    0.12242E-51
+    5    2    0.19857E-04    0.10000E+01    0.17891E+05    0.61627E-45    0.30000E-54    0.85291E-51
+    5    2    0.19857E-04    0.10000E+01    0.14428E+05    0.41709E-44    0.37325E-53    0.58127E-50
+    5    2    0.19857E-04    0.10000E+01    0.11635E+05    0.27513E-43    0.44997E-52    0.38721E-49
+    5    2    0.19857E-04    0.10000E+01    0.93834E+04    0.17611E-42    0.51516E-51    0.25118E-48
+    5    2    0.19857E-04    0.10000E+01    0.75673E+04    0.10793E-41    0.55018E-50    0.15649E-47
+    5    2    0.19857E-04    0.10000E+01    0.61026E+04    0.62644E-41    0.59532E-49    0.91613E-47
+    5    2    0.19857E-04    0.10000E+01    0.49215E+04    0.36404E-40    0.89208E-48    0.50750E-46
+    5    2    0.19857E-04    0.10000E+01    0.39689E+04    0.26331E-39    0.20271E-46    0.30838E-45
+    5    2    0.19857E-04    0.10000E+01    0.32008E+04    0.87691E-37    0.16457E-43    0.85336E-43
+    5    2    0.19857E-04    0.10000E+01    0.25813E+04    0.57083E-28    0.23699E-34    0.51735E-34
+    5    2    0.19857E-04    0.10000E+01    0.20817E+04    0.93883E-12    0.13932E-17    0.81202E-18
+    5    2    0.19857E-04    0.10000E+01    0.16788E+04    0.27471E-06    0.15998E-11    0.21941E-12
+    5    2    0.19857E-04    0.10000E+01    0.13538E+04    0.49473E-06    0.57225E-11    0.34087E-12
+    5    2    0.19857E-04    0.10000E+01    0.10918E+04    0.91164E-06    0.20367E-10    0.54340E-12
+    5    2    0.19857E-04    0.10000E+01    0.88049E+03    0.16971E-05    0.72397E-10    0.88000E-12
+    5    2    0.19857E-04    0.10000E+01    0.71007E+03    0.31702E-05    0.25696E-09    0.14405E-11
+    5    2    0.19857E-04    0.10000E+01    0.57264E+03    0.59232E-05    0.89825E-09    0.23811E-11
+    5    2    0.19857E-04    0.10000E+01    0.46180E+03    0.11037E-04    0.29872E-08    0.39738E-11
+    5    2    0.19857E-04    0.10000E+01    0.37242E+03    0.20363E-04    0.90467E-08    0.66725E-11
+    5    2    0.19857E-04    0.10000E+01    0.30034E+03    0.36701E-04    0.24167E-07    0.11152E-10
+    5    2    0.19857E-04    0.10000E+01    0.24221E+03    0.63571E-04    0.56290E-07    0.18249E-10
+    5    2    0.19857E-04    0.10000E+01    0.19533E+03    0.99145E-04    0.10682E-06    0.27425E-10
+    5    2    0.19857E-04    0.10000E+01    0.15752E+03    0.99145E-04    0.10682E-06    0.27425E-10
+    5    2    0.34650E-04    0.10000E+01    0.80645E+05    0.78918E-51    0.59038E-62    0.10795E-56
+    5    2    0.34650E-04    0.10000E+01    0.65036E+05    0.66758E-50    0.93746E-61    0.91353E-56
+    5    2    0.34650E-04    0.10000E+01    0.52449E+05    0.56719E-49    0.12579E-59    0.77642E-55
+    5    2    0.34650E-04    0.10000E+01    0.42297E+05    0.42624E-48    0.17037E-58    0.58383E-54
+    5    2    0.34650E-04    0.10000E+01    0.34111E+05    0.30666E-47    0.23267E-57    0.42050E-53
+    5    2    0.34650E-04    0.10000E+01    0.27509E+05    0.21924E-46    0.31261E-56    0.30116E-52
+    5    2    0.34650E-04    0.10000E+01    0.22184E+05    0.15507E-45    0.41000E-55    0.21362E-51
+    5    2    0.34650E-04    0.10000E+01    0.17891E+05    0.10754E-44    0.52349E-54    0.14883E-50
+    5    2    0.34650E-04    0.10000E+01    0.14428E+05    0.72779E-44    0.65130E-53    0.10143E-49
+    5    2    0.34650E-04    0.10000E+01    0.11635E+05    0.48009E-43    0.78518E-52    0.67566E-49
+    5    2    0.34650E-04    0.10000E+01    0.93834E+04    0.30730E-42    0.89893E-51    0.43829E-48
+    5    2    0.34650E-04    0.10000E+01    0.75673E+04    0.18832E-41    0.96003E-50    0.27307E-47
+    5    2    0.34650E-04    0.10000E+01    0.61026E+04    0.10931E-40    0.10388E-48    0.15986E-46
+    5    2    0.34650E-04    0.10000E+01    0.49215E+04    0.63523E-40    0.15566E-47    0.88556E-46
+    5    2    0.34650E-04    0.10000E+01    0.39689E+04    0.45947E-39    0.35372E-46    0.53811E-45
+    5    2    0.34650E-04    0.10000E+01    0.32008E+04    0.15302E-36    0.28716E-43    0.14891E-42
+    5    2    0.34650E-04    0.10000E+01    0.25813E+04    0.99606E-28    0.41354E-34    0.90275E-34
+    5    2    0.34650E-04    0.10000E+01    0.20817E+04    0.16382E-11    0.24311E-17    0.14169E-17
+    5    2    0.34650E-04    0.10000E+01    0.16788E+04    0.47935E-06    0.27916E-11    0.38285E-12
+    5    2    0.34650E-04    0.10000E+01    0.13538E+04    0.86327E-06    0.99854E-11    0.59479E-12
+    5    2    0.34650E-04    0.10000E+01    0.10918E+04    0.15908E-05    0.35540E-10    0.94820E-12
+    5    2    0.34650E-04    0.10000E+01    0.88049E+03    0.29614E-05    0.12633E-09    0.15355E-11
+    5    2    0.34650E-04    0.10000E+01    0.71007E+03    0.55317E-05    0.44839E-09    0.25136E-11
+    5    2    0.34650E-04    0.10000E+01    0.57264E+03    0.10336E-04    0.15674E-08    0.41548E-11
+    5    2    0.34650E-04    0.10000E+01    0.46180E+03    0.19259E-04    0.52126E-08    0.69341E-11
+    5    2    0.34650E-04    0.10000E+01    0.37242E+03    0.35532E-04    0.15786E-07    0.11643E-10
+    5    2    0.34650E-04    0.10000E+01    0.30034E+03    0.64041E-04    0.42169E-07    0.19459E-10
+    5    2    0.34650E-04    0.10000E+01    0.24221E+03    0.11093E-03    0.98223E-07    0.31843E-10
+    5    2    0.34650E-04    0.10000E+01    0.19533E+03    0.17300E-03    0.18640E-06    0.47855E-10
+    5    2    0.34650E-04    0.10000E+01    0.15752E+03    0.17300E-03    0.18640E-06    0.47855E-10
+    5    2    0.60462E-04    0.10000E+01    0.80645E+05    0.13771E-50    0.10302E-61    0.18837E-56
+    5    2    0.60462E-04    0.10000E+01    0.65036E+05    0.11649E-49    0.16358E-60    0.15941E-55
+    5    2    0.60462E-04    0.10000E+01    0.52449E+05    0.98972E-49    0.21949E-59    0.13548E-54
+    5    2    0.60462E-04    0.10000E+01    0.42297E+05    0.74376E-48    0.29729E-58    0.10188E-53
+    5    2    0.60462E-04    0.10000E+01    0.34111E+05    0.53511E-47    0.40599E-57    0.73375E-53
+    5    2    0.60462E-04    0.10000E+01    0.27509E+05    0.38256E-46    0.54548E-56    0.52550E-52
+    5    2    0.60462E-04    0.10000E+01    0.22184E+05    0.27058E-45    0.71542E-55    0.37276E-51
+    5    2    0.60462E-04    0.10000E+01    0.17891E+05    0.18764E-44    0.91345E-54    0.25969E-50
+    5    2    0.60462E-04    0.10000E+01    0.14428E+05    0.12700E-43    0.11365E-52    0.17699E-49
+    5    2    0.60462E-04    0.10000E+01    0.11635E+05    0.83772E-43    0.13701E-51    0.11790E-48
+    5    2    0.60462E-04    0.10000E+01    0.93834E+04    0.53622E-42    0.15686E-50    0.76478E-48
+    5    2    0.60462E-04    0.10000E+01    0.75673E+04    0.32861E-41    0.16752E-49    0.47649E-47
+    5    2    0.60462E-04    0.10000E+01    0.61026E+04    0.19074E-40    0.18126E-48    0.27894E-46
+    5    2    0.60462E-04    0.10000E+01    0.49215E+04    0.11084E-39    0.27162E-47    0.15452E-45
+    5    2    0.60462E-04    0.10000E+01    0.39689E+04    0.80174E-39    0.61721E-46    0.93897E-45
+    5    2    0.60462E-04    0.10000E+01    0.32008E+04    0.26700E-36    0.50108E-43    0.25983E-42
+    5    2    0.60462E-04    0.10000E+01    0.25813E+04    0.17381E-27    0.72160E-34    0.15752E-33
+    5    2    0.60462E-04    0.10000E+01    0.20817E+04    0.28586E-11    0.42422E-17    0.24724E-17
+    5    2    0.60462E-04    0.10000E+01    0.16788E+04    0.83644E-06    0.48711E-11    0.66805E-12
+    5    2    0.60462E-04    0.10000E+01    0.13538E+04    0.15063E-05    0.17424E-10    0.10379E-11
+    5    2    0.60462E-04    0.10000E+01    0.10918E+04    0.27758E-05    0.62015E-10    0.16545E-11
+    5    2    0.60462E-04    0.10000E+01    0.88049E+03    0.51675E-05    0.22043E-09    0.26794E-11
+    5    2    0.60462E-04    0.10000E+01    0.71007E+03    0.96526E-05    0.78241E-09    0.43861E-11
+    5    2    0.60462E-04    0.10000E+01    0.57264E+03    0.18035E-04    0.27350E-08    0.72499E-11
+    5    2    0.60462E-04    0.10000E+01    0.46180E+03    0.33606E-04    0.90956E-08    0.12100E-10
+    5    2    0.60462E-04    0.10000E+01    0.37242E+03    0.62000E-04    0.27545E-07    0.20316E-10
+    5    2    0.60462E-04    0.10000E+01    0.30034E+03    0.11175E-03    0.73583E-07    0.33955E-10
+    5    2    0.60462E-04    0.10000E+01    0.24221E+03    0.19356E-03    0.17139E-06    0.55564E-10
+    5    2    0.60462E-04    0.10000E+01    0.19533E+03    0.30188E-03    0.32525E-06    0.83504E-10
+    5    2    0.60462E-04    0.10000E+01    0.15752E+03    0.30188E-03    0.32525E-06    0.83504E-10
+    5    2    0.10550E-03    0.10000E+01    0.80645E+05    0.24029E-50    0.17976E-61    0.32870E-56
+    5    2    0.10550E-03    0.10000E+01    0.65036E+05    0.20326E-49    0.28544E-60    0.27815E-55
+    5    2    0.10550E-03    0.10000E+01    0.52449E+05    0.17270E-48    0.38300E-59    0.23641E-54
+    5    2    0.10550E-03    0.10000E+01    0.42297E+05    0.12978E-47    0.51875E-58    0.17777E-53
+    5    2    0.10550E-03    0.10000E+01    0.34111E+05    0.93374E-47    0.70842E-57    0.12804E-52
+    5    2    0.10550E-03    0.10000E+01    0.27509E+05    0.66755E-46    0.95184E-56    0.91697E-52
+    5    2    0.10550E-03    0.10000E+01    0.22184E+05    0.47215E-45    0.12484E-54    0.65043E-51
+    5    2    0.10550E-03    0.10000E+01    0.17891E+05    0.32742E-44    0.15939E-53    0.45315E-50
+    5    2    0.10550E-03    0.10000E+01    0.14428E+05    0.22160E-43    0.19831E-52    0.30883E-49
+    5    2    0.10550E-03    0.10000E+01    0.11635E+05    0.14618E-42    0.23907E-51    0.20573E-48
+    5    2    0.10550E-03    0.10000E+01    0.93834E+04    0.93566E-42    0.27371E-50    0.13345E-47
+    5    2    0.10550E-03    0.10000E+01    0.75673E+04    0.57341E-41    0.29231E-49    0.83145E-47
+    5    2    0.10550E-03    0.10000E+01    0.61026E+04    0.33283E-40    0.31629E-48    0.48674E-46
+    5    2    0.10550E-03    0.10000E+01    0.49215E+04    0.19342E-39    0.47396E-47    0.26964E-45
+    5    2    0.10550E-03    0.10000E+01    0.39689E+04    0.13990E-38    0.10770E-45    0.16384E-44
+    5    2    0.10550E-03    0.10000E+01    0.32008E+04    0.46590E-36    0.87436E-43    0.45339E-42
+    5    2    0.10550E-03    0.10000E+01    0.25813E+04    0.30328E-27    0.12592E-33    0.27487E-33
+    5    2    0.10550E-03    0.10000E+01    0.20817E+04    0.49880E-11    0.74023E-17    0.43143E-17
+    5    2    0.10550E-03    0.10000E+01    0.16788E+04    0.14595E-05    0.84998E-11    0.11657E-11
+    5    2    0.10550E-03    0.10000E+01    0.13538E+04    0.26285E-05    0.30404E-10    0.18110E-11
+    5    2    0.10550E-03    0.10000E+01    0.10918E+04    0.48436E-05    0.10821E-09    0.28871E-11
+    5    2    0.10550E-03    0.10000E+01    0.88049E+03    0.90169E-05    0.38464E-09    0.46754E-11
+    5    2    0.10550E-03    0.10000E+01    0.71007E+03    0.16843E-04    0.13653E-08    0.76535E-11
+    5    2    0.10550E-03    0.10000E+01    0.57264E+03    0.31470E-04    0.47724E-08    0.12651E-10
+    5    2    0.10550E-03    0.10000E+01    0.46180E+03    0.58640E-04    0.15871E-07    0.21113E-10
+    5    2    0.10550E-03    0.10000E+01    0.37242E+03    0.10819E-03    0.48065E-07    0.35451E-10
+    5    2    0.10550E-03    0.10000E+01    0.30034E+03    0.19499E-03    0.12840E-06    0.59249E-10
+    5    2    0.10550E-03    0.10000E+01    0.24221E+03    0.33775E-03    0.29907E-06    0.96955E-10
+    5    2    0.10550E-03    0.10000E+01    0.19533E+03    0.52676E-03    0.56755E-06    0.14571E-09
+    5    2    0.10550E-03    0.10000E+01    0.15752E+03    0.52676E-03    0.56755E-06    0.14571E-09
+    5    2    0.18409E-03    0.10000E+01    0.80645E+05    0.41929E-50    0.31367E-61    0.57356E-56
+    5    2    0.18409E-03    0.10000E+01    0.65036E+05    0.35468E-49    0.49808E-60    0.48536E-55
+    5    2    0.18409E-03    0.10000E+01    0.52449E+05    0.30135E-48    0.66831E-59    0.41251E-54
+    5    2    0.18409E-03    0.10000E+01    0.42297E+05    0.22646E-47    0.90519E-58    0.31019E-53
+    5    2    0.18409E-03    0.10000E+01    0.34111E+05    0.16293E-46    0.12362E-56    0.22341E-52
+    5    2    0.18409E-03    0.10000E+01    0.27509E+05    0.11648E-45    0.16609E-55    0.16001E-51
+    5    2    0.18409E-03    0.10000E+01    0.22184E+05    0.82387E-45    0.21783E-54    0.11350E-50
+    5    2    0.18409E-03    0.10000E+01    0.17891E+05    0.57134E-44    0.27813E-53    0.79072E-50
+    5    2    0.18409E-03    0.10000E+01    0.14428E+05    0.38668E-43    0.34603E-52    0.53889E-49
+    5    2    0.18409E-03    0.10000E+01    0.11635E+05    0.25507E-42    0.41717E-51    0.35898E-48
+    5    2    0.18409E-03    0.10000E+01    0.93834E+04    0.16327E-41    0.47760E-50    0.23286E-47
+    5    2    0.18409E-03    0.10000E+01    0.75673E+04    0.10006E-40    0.51007E-49    0.14508E-46
+    5    2    0.18409E-03    0.10000E+01    0.61026E+04    0.58077E-40    0.55192E-48    0.84934E-46
+    5    2    0.18409E-03    0.10000E+01    0.49215E+04    0.33750E-39    0.82704E-47    0.47050E-45
+    5    2    0.18409E-03    0.10000E+01    0.39689E+04    0.24412E-38    0.18793E-45    0.28590E-44
+    5    2    0.18409E-03    0.10000E+01    0.32008E+04    0.81297E-36    0.15257E-42    0.79114E-42
+    5    2    0.18409E-03    0.10000E+01    0.25813E+04    0.52921E-27    0.21972E-33    0.47963E-33
+    5    2    0.18409E-03    0.10000E+01    0.20817E+04    0.87038E-11    0.12917E-16    0.75281E-17
+    5    2    0.18409E-03    0.10000E+01    0.16788E+04    0.25468E-05    0.14832E-10    0.20341E-11
+    5    2    0.18409E-03    0.10000E+01    0.13538E+04    0.45866E-05    0.53053E-10    0.31601E-11
+    5    2    0.18409E-03    0.10000E+01    0.10918E+04    0.84517E-05    0.18882E-09    0.50378E-11
+    5    2    0.18409E-03    0.10000E+01    0.88049E+03    0.15734E-04    0.67118E-09    0.81583E-11
+    5    2    0.18409E-03    0.10000E+01    0.71007E+03    0.29390E-04    0.23823E-08    0.13355E-10
+    5    2    0.18409E-03    0.10000E+01    0.57264E+03    0.54914E-04    0.83276E-08    0.22074E-10
+    5    2    0.18409E-03    0.10000E+01    0.46180E+03    0.10232E-03    0.27694E-07    0.36841E-10
+    5    2    0.18409E-03    0.10000E+01    0.37242E+03    0.18878E-03    0.83871E-07    0.61860E-10
+    5    2    0.18409E-03    0.10000E+01    0.30034E+03    0.34025E-03    0.22405E-06    0.10339E-09
+    5    2    0.18409E-03    0.10000E+01    0.24221E+03    0.58936E-03    0.52186E-06    0.16918E-09
+    5    2    0.18409E-03    0.10000E+01    0.19533E+03    0.91916E-03    0.99033E-06    0.25425E-09
+    5    2    0.18409E-03    0.10000E+01    0.15752E+03    0.91916E-03    0.99033E-06    0.25425E-09
+    5    2    0.32123E-03    0.10000E+01    0.80645E+05    0.73164E-50    0.54734E-61    0.10008E-55
+    5    2    0.32123E-03    0.10000E+01    0.65036E+05    0.61890E-49    0.86911E-60    0.84693E-55
+    5    2    0.32123E-03    0.10000E+01    0.52449E+05    0.52584E-48    0.11662E-58    0.71981E-54
+    5    2    0.32123E-03    0.10000E+01    0.42297E+05    0.39516E-47    0.15795E-57    0.54126E-53
+    5    2    0.32123E-03    0.10000E+01    0.34111E+05    0.28431E-46    0.21570E-56    0.38984E-52
+    5    2    0.32123E-03    0.10000E+01    0.27509E+05    0.20326E-45    0.28982E-55    0.27920E-51
+    5    2    0.32123E-03    0.10000E+01    0.22184E+05    0.14376E-44    0.38011E-54    0.19805E-50
+    5    2    0.32123E-03    0.10000E+01    0.17891E+05    0.99695E-44    0.48532E-53    0.13798E-49
+    5    2    0.32123E-03    0.10000E+01    0.14428E+05    0.67473E-43    0.60381E-52    0.94033E-49
+    5    2    0.32123E-03    0.10000E+01    0.11635E+05    0.44508E-42    0.72793E-51    0.62639E-48
+    5    2    0.32123E-03    0.10000E+01    0.93834E+04    0.28489E-41    0.83339E-50    0.40633E-47
+    5    2    0.32123E-03    0.10000E+01    0.75673E+04    0.17459E-40    0.89004E-49    0.25316E-46
+    5    2    0.32123E-03    0.10000E+01    0.61026E+04    0.10134E-39    0.96306E-48    0.14820E-45
+    5    2    0.32123E-03    0.10000E+01    0.49215E+04    0.58891E-39    0.14431E-46    0.82099E-45
+    5    2    0.32123E-03    0.10000E+01    0.39689E+04    0.42597E-38    0.32793E-45    0.49888E-44
+    5    2    0.32123E-03    0.10000E+01    0.32008E+04    0.14186E-35    0.26623E-42    0.13805E-41
+    5    2    0.32123E-03    0.10000E+01    0.25813E+04    0.92343E-27    0.38339E-33    0.83693E-33
+    5    2    0.32123E-03    0.10000E+01    0.20817E+04    0.15188E-10    0.22539E-16    0.13136E-16
+    5    2    0.32123E-03    0.10000E+01    0.16788E+04    0.44440E-05    0.25880E-10    0.35494E-11
+    5    2    0.32123E-03    0.10000E+01    0.13538E+04    0.80033E-05    0.92574E-10    0.55142E-11
+    5    2    0.32123E-03    0.10000E+01    0.10918E+04    0.14748E-04    0.32948E-09    0.87906E-11
+    5    2    0.32123E-03    0.10000E+01    0.88049E+03    0.27455E-04    0.11712E-08    0.14236E-10
+    5    2    0.32123E-03    0.10000E+01    0.71007E+03    0.51284E-04    0.41569E-08    0.23303E-10
+    5    2    0.32123E-03    0.10000E+01    0.57264E+03    0.95821E-04    0.14531E-07    0.38519E-10
+    5    2    0.32123E-03    0.10000E+01    0.46180E+03    0.17855E-03    0.48325E-07    0.64285E-10
+    5    2    0.32123E-03    0.10000E+01    0.37242E+03    0.32941E-03    0.14635E-06    0.10794E-09
+    5    2    0.32123E-03    0.10000E+01    0.30034E+03    0.59372E-03    0.39095E-06    0.18040E-09
+    5    2    0.32123E-03    0.10000E+01    0.24221E+03    0.10284E-02    0.91061E-06    0.29521E-09
+    5    2    0.32123E-03    0.10000E+01    0.19533E+03    0.16039E-02    0.17281E-05    0.44366E-09
+    5    2    0.32123E-03    0.10000E+01    0.15752E+03    0.16039E-02    0.17281E-05    0.44366E-09
+    5    3    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.15049E-08    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    3    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.26259E-08    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    3    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.45820E-08    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    3    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.79953E-08    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    5    3    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.13951E-07    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    5    3    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.24344E-07    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    5    3    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.42479E-07    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    5    3    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.79064E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.74124E-07    0.21932E+07    0.57448E-32    0.94949E-91    0.45338E-05    0.90000E+03
+    5    3    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.44742E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.12934E-06    0.18214E+07    0.17525E-31    0.53708E-75    0.54820E-05    0.90000E+03
+    5    3    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.36503E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.22569E-06    0.15145E+07    0.53194E-31    0.43786E-62    0.66021E-05    0.90000E+03
+    5    3    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.19009E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.39382E-06    0.12578E+07    0.16206E-30    0.22776E-51    0.79511E-05    0.90000E+03
+    5    3    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.12395E-44    0.67064E-05    0.42297E-05    0.37644E+02    0.68719E-06    0.10445E+07    0.49376E-30    0.14826E-42    0.95741E-05    0.90000E+03
+    5    3    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.21361E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.11991E-05    0.86742E+06    0.15043E-29    0.25491E-35    0.11528E-04    0.90000E+03
+    5    3    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.18089E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.20924E-05    0.72035E+06    0.45832E-29    0.21518E-29    0.13882E-04    0.90000E+03
+    5    3    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.12595E-26    0.11686E-04    0.73852E-05    0.20001E+03    0.36511E-05    0.59822E+06    0.13964E-28    0.14919E-24    0.16716E-04    0.90000E+03
+    5    3    0.19333E-11    0.10000E+01    0.78654E-02    0.15174E-01    0.15384E-11    0.11056E-22    0.14063E-04    0.88930E-05    0.34900E+03    0.63709E-05    0.49680E+06    0.42543E-28    0.13024E-20    0.20129E-04    0.90000E+03
+    5    3    0.33734E-11    0.10000E+01    0.11252E-01    0.21596E-01    0.34563E-11    0.16730E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.11117E-04    0.41311E+06    0.12910E-27    0.19568E-17    0.24207E-04    0.90000E+03
+    5    3    0.58864E-11    0.10000E+01    0.16087E-01    0.30715E-01    0.51398E-11    0.64431E-17    0.20419E-04    0.12879E-04    0.10626E+04    0.19398E-04    0.34307E+06    0.39291E-27    0.74652E-15    0.29147E-04    0.89996E+03
+    5    3    0.10271E-10    0.10000E+01    0.22938E-01    0.43766E-01    0.84782E-11    0.76684E-15    0.24575E-04    0.15517E-04    0.18542E+04    0.33849E-04    0.28490E+06    0.11876E-26    0.87743E-13    0.35073E-04    0.89950E+03
+    5    3    0.17923E-10    0.10000E+01    0.32828E-01    0.63019E-01    0.20382E-10    0.35465E-13    0.29500E-04    0.18768E-04    0.32355E+04    0.59064E-04    0.23629E+06    0.35284E-26    0.39901E-11    0.42158E-04    0.89659E+03
+    5    3    0.31275E-10    0.10000E+01    0.47571E-01    0.90492E-01    0.50267E-10    0.76333E-12    0.35212E-04    0.22855E-04    0.56458E+04    0.10306E-03    0.19547E+06    0.10242E-25    0.83908E-10    0.50589E-04    0.88612E+03
+    5    3    0.54572E-10    0.10000E+01    0.69839E-01    0.12558E+00    0.10928E-09    0.90208E-11    0.41424E-04    0.27934E-04    0.98516E+04    0.17984E-03    0.16065E+06    0.29897E-25    0.95905E-09    0.60977E-04    0.86185E+03
+    5    3    0.95225E-10    0.10000E+01    0.10048E+00    0.16545E+00    0.20307E-09    0.63142E-10    0.48085E-04    0.33531E-04    0.17190E+05    0.31381E-03    0.13135E+06    0.90932E-25    0.63952E-08    0.74274E-04    0.82470E+03
+    5    3    0.16616E-09    0.10000E+01    0.13703E+00    0.21209E+00    0.33738E-09    0.27943E-09    0.55331E-04    0.39016E-04    0.29996E+05    0.54757E-03    0.10739E+06    0.28765E-24    0.26414E-07    0.91256E-04    0.78684E+03
+    5    3    0.28994E-09    0.10000E+01    0.17790E+00    0.27240E+00    0.58873E-09    0.86288E-09    0.63287E-04    0.44775E-04    0.52341E+05    0.95548E-03    0.88262E+05    0.90626E-24    0.74312E-07    0.11187E-03    0.75991E+03
+    5    3    0.50593E-09    0.10000E+01    0.22664E+00    0.35091E+00    0.11405E-08    0.21003E-08    0.72065E-04    0.51793E-04    0.91333E+05    0.16673E-02    0.72823E+05    0.27460E-23    0.16056E-06    0.13595E-03    0.74331E+03
+    5    3    0.88282E-09    0.10000E+01    0.29012E+00    0.44722E+00    0.22390E-08    0.44413E-08    0.82428E-04    0.60647E-04    0.15937E+06    0.29093E-02    0.60007E+05    0.78731E-23    0.29399E-06    0.16376E-03    0.72714E+03
+    5    3    0.15405E-08    0.10000E+01    0.37661E+00    0.55999E+00    0.41708E-08    0.87108E-08    0.95565E-04    0.71457E-04    0.27809E+06    0.50765E-02    0.48998E+05    0.21505E-22    0.48876E-06    0.19667E-03    0.69763E+03
+    5    3    0.26880E-08    0.10000E+01    0.49554E+00    0.69234E+00    0.72545E-08    0.16510E-07    0.11207E-03    0.84240E-04    0.48525E+06    0.88582E-02    0.39238E+05    0.57772E-22    0.77012E-06    0.23881E-03    0.64104E+03
+    5    3    0.46905E-08    0.10000E+01    0.45020E+00    0.11951E+01    0.23839E-07    0.34778E-07    0.98466E-04    0.11773E-03    0.20736E+06    0.94870E-02    0.56553E+04    0.55943E-21    0.94538E-06    0.53220E-03    0.36704E+03
+    5    3    0.81846E-08    0.10000E+01    0.57494E+00    0.13681E+01    0.41070E-07    0.64299E-07    0.11885E-03    0.13075E-03    0.36184E+06    0.16554E-01    0.42715E+04    0.16302E-20    0.14782E-05    0.69297E-03    0.29218E+03
+    5    3    0.14282E-07    0.10000E+01    0.71612E+00    0.15437E+01    0.69911E-07    0.11834E-06    0.14476E-03    0.14308E-03    0.63138E+06    0.28886E-01    0.32096E+04    0.48396E-20    0.23063E-05    0.91319E-03    0.22633E+03
+    5    3    0.24920E-07    0.10000E+01    0.87024E+00    0.17163E+01    0.11746E-06    0.21676E-06    0.17816E-03    0.15428E-03    0.11017E+07    0.50404E-01    0.24024E+04    0.14554E-19    0.35992E-05    0.12135E-02    0.17151E+03
+    5    3    0.43485E-07    0.10000E+01    0.10323E+01    0.18807E+01    0.19545E-06    0.39506E-06    0.22222E-03    0.16405E-03    0.19224E+07    0.87953E-01    0.17958E+04    0.44010E-19    0.56274E-05    0.16190E-02    0.12804E+03
+    5    3    0.75878E-07    0.10000E+01    0.11986E+01    0.20342E+01    0.32180E-06    0.71655E-06    0.28070E-03    0.17238E-03    0.33546E+07    0.15347E+00    0.13406E+04    0.13363E-18    0.88139E-05    0.21657E-02    0.94534E+02
+    5    3    0.13240E-06    0.10000E+01    0.13655E+01    0.21756E+01    0.52423E-06    0.12938E-05    0.35862E-03    0.17939E-03    0.58535E+07    0.26780E+00    0.99952E+03    0.40705E-18    0.13822E-04    0.29029E-02    0.69242E+02
+    5    3    0.23103E-06    0.10000E+01    0.15286E+01    0.23031E+01    0.84987E-06    0.23259E-05    0.46381E-03    0.18520E-03    0.10214E+08    0.46729E+00    0.74618E+03    0.12365E-17    0.21707E-04    0.38868E-02    0.50568E+02
+    5    3    0.40314E-06    0.10000E+01    0.16868E+01    0.24180E+01    0.13627E-05    0.41620E-05    0.60433E-03    0.19006E-03    0.17823E+08    0.81540E+00    0.55633E+03    0.37289E-17    0.34073E-04    0.51976E-02    0.36804E+02
+    5    3    0.70346E-06    0.10000E+01    0.17426E+01    0.24563E+01    0.32758E-05    0.73139E-05    0.94980E-03    0.19160E-03    0.31100E+08    0.14228E+01    0.50000E+03    0.78653E-17    0.57173E-04    0.57609E-02    0.32805E+02
+    5    3    0.12275E-05    0.10000E+01    0.17426E+01    0.24563E+01    0.99742E-05    0.12762E-04    0.16573E-02    0.19160E-03    0.54267E+08    0.24827E+01    0.50000E+03    0.13724E-16    0.99764E-04    0.57609E-02    0.32805E+02
+    5    3    0.21419E-05    0.10000E+01    0.17426E+01    0.24563E+01    0.30369E-04    0.22270E-04    0.28920E-02    0.19160E-03    0.94693E+08    0.43322E+01    0.50000E+03    0.23948E-16    0.17408E-03    0.57609E-02    0.32805E+02
+    5    3    0.37375E-05    0.10000E+01    0.17426E+01    0.24563E+01    0.92469E-04    0.38859E-04    0.50463E-02    0.19160E-03    0.16523E+09    0.75595E+01    0.50000E+03    0.41788E-16    0.30376E-03    0.57609E-02    0.32805E+02
+    5    3    0.65217E-05    0.10000E+01    0.17426E+01    0.24563E+01    0.28155E-03    0.67807E-04    0.88055E-02    0.19160E-03    0.28832E+09    0.13191E+02    0.50000E+03    0.72918E-16    0.53005E-03    0.57609E-02    0.32805E+02
+    5    3    0.11380E-04    0.10000E+01    0.17426E+01    0.24563E+01    0.85727E-03    0.11832E-03    0.15365E-01    0.19160E-03    0.50310E+09    0.23017E+02    0.50000E+03    0.12724E-15    0.92490E-03    0.57609E-02    0.32805E+02
+    5    3    0.19857E-04    0.10000E+01    0.17426E+01    0.24563E+01    0.26102E-02    0.20646E-03    0.26811E-01    0.19160E-03    0.87789E+09    0.40164E+02    0.50000E+03    0.22202E-15    0.16139E-02    0.57609E-02    0.32805E+02
+    5    3    0.34650E-04    0.10000E+01    0.17426E+01    0.24563E+01    0.79477E-02    0.36026E-03    0.46784E-01    0.19160E-03    0.15319E+10    0.70083E+02    0.50000E+03    0.38742E-15    0.28161E-02    0.57609E-02    0.32805E+02
+    5    3    0.60462E-04    0.10000E+01    0.17426E+01    0.24563E+01    0.24199E-01    0.62863E-03    0.81635E-01    0.19160E-03    0.26730E+10    0.12229E+03    0.50000E+03    0.67602E-15    0.49140E-02    0.57609E-02    0.32805E+02
+    5    3    0.10550E-03    0.10000E+01    0.17426E+01    0.24563E+01    0.73682E-01    0.10969E-02    0.14245E+00    0.19160E-03    0.46642E+10    0.21339E+03    0.50000E+03    0.11796E-14    0.85746E-02    0.57609E-02    0.32805E+02
+    5    3    0.18409E-03    0.10000E+01    0.17426E+01    0.24563E+01    0.22435E+00    0.19141E-02    0.24856E+00    0.19160E-03    0.81388E+10    0.37235E+03    0.50000E+03    0.20583E-14    0.14962E-01    0.57609E-02    0.32805E+02
+    5    3    0.32123E-03    0.10000E+01    0.17426E+01    0.24563E+01    0.68310E+00    0.33399E-02    0.43373E+00    0.19160E-03    0.14202E+11    0.64973E+03    0.50000E+03    0.35917E-14    0.26108E-01    0.57609E-02    0.32805E+02
+    5    3    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    5    3    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    5    3    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    5    3    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    5    3    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    5    3    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    5    3    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    5    3    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    5    3    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    5    3    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    5    3    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    5    3    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    5    3    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    5    3    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    5    3    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    5    3    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    5    3    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    5    3    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    5    3    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    5    3    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    5    3    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    5    3    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    5    3    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    5    3    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    5    3    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    5    3    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    5    3    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    5    3    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    5    3    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    5    3    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    5    3    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    5    3    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    5    3    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    5    3    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    5    3    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    5    3    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    5    3    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    5    3    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    5    3    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    5    3    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    5    3    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    5    3    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    5    3    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    5    3    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    5    3    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    5    3    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    5    3    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    5    3    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    5    3    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    5    3    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    5    3    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    5    3    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    5    3    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    5    3    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    5    3    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    5    3    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    5    3    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    5    3    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    5    3    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    5    3    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    5    3    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    5    3    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    5    3    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    5    3    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    5    3    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    5    3    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    5    3    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    5    3    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    5    3    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    5    3    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    5    3    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    5    3    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    5    3    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    5    3    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    5    3    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    5    3    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    5    3    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    5    3    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    5    3    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    5    3    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    5    3    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    5    3    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    5    3    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    5    3    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    5    3    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    5    3    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    5    3    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    5    3    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    5    3    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    5    3    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    5    3    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    5    3    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    5    3    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    5    3    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    5    3    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    5    3    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    5    3    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    5    3    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    5    3    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    5    3    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    5    3    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    5    3    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    5    3    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    5    3    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    5    3    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    5    3    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    5    3    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    5    3    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    5    3    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    5    3    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    5    3    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    5    3    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    5    3    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    5    3    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    5    3    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    5    3    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    5    3    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    5    3    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    5    3    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    5    3    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    5    3    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    5    3    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    5    3    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    5    3    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    5    3    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    5    3    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    5    3    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    5    3    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    5    3    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    5    3    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    5    3    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    5    3    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    5    3    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    5    3    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    5    3    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    5    3    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    5    3    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    5    3    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    5    3    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    5    3    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    5    3    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    5    3    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    5    3    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    5    3    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    5    3    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    5    3    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    5    3    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    5    3    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    5    3    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    5    3    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    5    3    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    5    3    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    5    3    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    5    3    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    5    3    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    5    3    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    5    3    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    5    3    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    5    3    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    5    3    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    5    3    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    5    3    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    5    3    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    5    3    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    5    3    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    5    3    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    5    3    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    5    3    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    5    3    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    5    3    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    5    3    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    5    3    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    5    3    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    5    3    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    5    3    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    5    3    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    5    3    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    5    3    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    5    3    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    5    3    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    5    3    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    5    3    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    5    3    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    5    3    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    5    3    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    5    3    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    5    3    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    5    3    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    5    3    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    5    3    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    5    3    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    5    3    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    5    3    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    5    3    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    5    3    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    5    3    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    5    3    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    5    3    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    5    3    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    5    3    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    5    3    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    5    3    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    5    3    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    5    3    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    5    3    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    5    3    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    5    3    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    5    3    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    5    3    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    5    3    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    5    3    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    5    3    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    5    3    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    5    3    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    5    3    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    5    3    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    5    3    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    5    3    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    5    3    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    5    3    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    5    3    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    5    3    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    5    3    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    5    3    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    5    3    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    5    3    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    5    3    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    5    3    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    5    3    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    5    3    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    5    3    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    5    3    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    5    3    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    5    3    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    5    3    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    5    3    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    5    3    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    5    3    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    5    3    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    5    3    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    5    3    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    5    3    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    5    3    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    5    3    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    5    3    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    5    3    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    5    3    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    5    3    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    5    3    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    5    3    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    5    3    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    5    3    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    5    3    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    5    3    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    5    3    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    5    3    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    5    3    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    5    3    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    5    3    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    5    3    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    5    3    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    5    3    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    5    3    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    5    3    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    5    3    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    5    3    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    5    3    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    5    3    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    5    3    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    5    3    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    5    3    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    5    3    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    5    3    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    5    3    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    5    3    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    5    3    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    5    3    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    5    3    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    5    3    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    5    3    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    5    3    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    5    3    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    5    3    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    5    3    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    5    3    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    5    3    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    5    3    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    5    3    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    5    3    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    5    3    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    5    3    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    5    3    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    5    3    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    5    3    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    5    3    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    5    3    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    5    3    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    5    3    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    5    3    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    5    3    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    5    3    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    5    3    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    5    3    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    5    3    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    5    3    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    5    3    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    5    3    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    5    3    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    5    3    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    5    3    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    5    3    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    5    3    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    5    3    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    5    3    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    5    3    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    5    3    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    5    3    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    5    3    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    5    3    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    5    3    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    5    3    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    5    3    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    5    3    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    5    3    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    5    3    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    5    3    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    5    3    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    5    3    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    5    3    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    5    3    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    5    3    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    5    3    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    5    3    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    5    3    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    5    3    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    5    3    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    5    3    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    5    3    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    5    3    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    5    3    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    5    3    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    5    3    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    5    3    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    5    3    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    5    3    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    5    3    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    5    3    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    5    3    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    5    3    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    5    3    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    5    3    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    5    3    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    5    3    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    5    3    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    5    3    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    5    3    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    5    3    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    5    3    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    5    3    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    5    3    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    5    3    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    5    3    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    5    3    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    5    3    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    5    3    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    5    3    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    5    3    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    5    3    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    5    3    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    5    3    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    5    3    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    5    3    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    5    3    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    5    3    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    5    3    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    5    3    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    5    3    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    5    3    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    5    3    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    5    3    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    5    3    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    5    3    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    5    3    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    5    3    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    5    3    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    5    3    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    5    3    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    5    3    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    5    3    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    5    3    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    5    3    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    5    3    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    5    3    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    5    3    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    5    3    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    5    3    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    5    3    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    5    3    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    5    3    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    5    3    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    5    3    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    5    3    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    5    3    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    5    3    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    5    3    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    5    3    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    5    3    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    5    3    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    5    3    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    5    3    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    5    3    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    5    3    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    5    3    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    5    3    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    5    3    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    5    3    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    5    3    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    5    3    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    5    3    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    5    3    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    5    3    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    5    3    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    5    3    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    5    3    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    5    3    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    5    3    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    5    3    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    5    3    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    5    3    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    5    3    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    5    3    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    5    3    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    5    3    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    5    3    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    5    3    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    5    3    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    5    3    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    5    3    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    5    3    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    5    3    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    5    3    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    5    3    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    5    3    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    5    3    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    5    3    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    5    3    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    5    3    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    5    3    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    5    3    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    5    3    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    5    3    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    5    3    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    5    3    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    5    3    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    5    3    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    5    3    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    5    3    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    5    3    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    5    3    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    5    3    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    5    3    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    5    3    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    5    3    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    5    3    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    5    3    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    5    3    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    5    3    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    5    3    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    5    3    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    5    3    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    5    3    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    5    3    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    5    3    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    5    3    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    5    3    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    5    3    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    5    3    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    5    3    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    5    3    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    5    3    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    5    3    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69289E-70
+    5    3    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58689E-69
+    5    3    0.33734E-11    0.10000E+01    0.52449E+05    0.49918E-56    0.30034E-66    0.97614E-68
+    5    3    0.33734E-11    0.10000E+01    0.42297E+05    0.89370E-55    0.10197E-64    0.19084E-66
+    5    3    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36176E-65
+    5    3    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65987E-64
+    5    3    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    5    3    0.33734E-11    0.10000E+01    0.17891E+05    0.79426E-50    0.10550E-58    0.19302E-61
+    5    3    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30094E-60
+    5    3    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44396E-59
+    5    3    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63457E-58
+    5    3    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89579E-57
+    5    3    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    5    3    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41288E-50    0.17722E-54
+    5    3    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    5    3    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    5    3    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    5    3    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    5    3    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51714E-20
+    5    3    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76079E-13    0.11099E-19
+    5    3    0.33734E-11    0.10000E+01    0.10918E+04    0.94887E-08    0.28364E-12    0.23296E-19
+    5    3    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    5    3    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96444E-19
+    5    3    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    5    3    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    5    3    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    5    3    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    5    3    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    5    3    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    5    3    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    5    3    0.58864E-11    0.10000E+01    0.80645E+05    0.18691E-58    0.19570E-69    0.24242E-69
+    5    3    0.58864E-11    0.10000E+01    0.65036E+05    0.22390E-57    0.64784E-68    0.18976E-68
+    5    3    0.58864E-11    0.10000E+01    0.52449E+05    0.37608E-56    0.23348E-66    0.24434E-67
+    5    3    0.58864E-11    0.10000E+01    0.42297E+05    0.69439E-55    0.81224E-65    0.40734E-66
+    5    3    0.58864E-11    0.10000E+01    0.34111E+05    0.12655E-53    0.27615E-63    0.74408E-65
+    5    3    0.58864E-11    0.10000E+01    0.27509E+05    0.22561E-52    0.91774E-62    0.13621E-63
+    5    3    0.58864E-11    0.10000E+01    0.22184E+05    0.39172E-51    0.29120E-60    0.24108E-62
+    5    3    0.58864E-11    0.10000E+01    0.17891E+05    0.64896E-50    0.86316E-59    0.40320E-61
+    5    3    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24134E-57    0.62981E-60
+    5    3    0.58864E-11    0.10000E+01    0.11635E+05    0.14899E-47    0.65456E-56    0.92966E-59
+    5    3    0.58864E-11    0.10000E+01    0.93834E+04    0.21298E-46    0.17577E-54    0.13290E-57
+    5    3    0.58864E-11    0.10000E+01    0.75673E+04    0.30062E-45    0.47102E-53    0.18764E-56
+    5    3    0.58864E-11    0.10000E+01    0.61026E+04    0.42279E-44    0.12620E-51    0.26407E-55
+    5    3    0.58864E-11    0.10000E+01    0.49215E+04    0.59421E-43    0.33814E-50    0.37145E-54
+    5    3    0.58864E-11    0.10000E+01    0.39689E+04    0.83506E-42    0.90601E-49    0.52250E-53
+    5    3    0.58864E-11    0.10000E+01    0.32008E+04    0.36906E-39    0.78496E-46    0.23115E-50
+    5    3    0.58864E-11    0.10000E+01    0.25813E+04    0.26989E-30    0.13160E-36    0.16921E-41
+    5    3    0.58864E-11    0.10000E+01    0.20817E+04    0.51232E-14    0.11143E-19    0.32157E-25
+    5    3    0.58864E-11    0.10000E+01    0.16788E+04    0.17288E-08    0.16440E-13    0.10860E-19
+    5    3    0.58864E-11    0.10000E+01    0.13538E+04    0.37097E-08    0.62433E-13    0.23308E-19
+    5    3    0.58864E-11    0.10000E+01    0.10918E+04    0.77857E-08    0.23277E-12    0.48928E-19
+    5    3    0.58864E-11    0.10000E+01    0.88049E+03    0.15994E-07    0.85700E-12    0.10053E-18
+    5    3    0.58864E-11    0.10000E+01    0.71007E+03    0.32228E-07    0.31207E-11    0.20258E-18
+    5    3    0.58864E-11    0.10000E+01    0.57264E+03    0.63855E-07    0.11103E-10    0.40140E-18
+    5    3    0.58864E-11    0.10000E+01    0.46180E+03    0.12448E-06    0.37343E-10    0.78251E-18
+    5    3    0.58864E-11    0.10000E+01    0.37242E+03    0.23755E-06    0.11387E-09    0.14934E-17
+    5    3    0.58864E-11    0.10000E+01    0.30034E+03    0.43874E-06    0.30541E-09    0.27582E-17
+    5    3    0.58864E-11    0.10000E+01    0.24221E+03    0.77295E-06    0.71310E-09    0.48594E-17
+    5    3    0.58864E-11    0.10000E+01    0.19533E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    5    3    0.58864E-11    0.10000E+01    0.15752E+03    0.12182E-05    0.13551E-08    0.76584E-17
+    5    3    0.10271E-10    0.10000E+01    0.80645E+05    0.28444E-58    0.21428E-69    0.93074E-69
+    5    3    0.10271E-10    0.10000E+01    0.65036E+05    0.25729E-57    0.63705E-68    0.74476E-68
+    5    3    0.10271E-10    0.10000E+01    0.52449E+05    0.37511E-56    0.22053E-66    0.73212E-67
+    5    3    0.10271E-10    0.10000E+01    0.42297E+05    0.66181E-55    0.77494E-65    0.87566E-66
+    5    3    0.10271E-10    0.10000E+01    0.34111E+05    0.12105E-53    0.26794E-63    0.13786E-64
+    5    3    0.10271E-10    0.10000E+01    0.27509E+05    0.21883E-52    0.89970E-62    0.24577E-63
+    5    3    0.10271E-10    0.10000E+01    0.22184E+05    0.38372E-51    0.28683E-60    0.43687E-62
+    5    3    0.10271E-10    0.10000E+01    0.17891E+05    0.63885E-50    0.85152E-59    0.73556E-61
+    5    3    0.10271E-10    0.10000E+01    0.14428E+05    0.99622E-49    0.23813E-57    0.11537E-59
+    5    3    0.10271E-10    0.10000E+01    0.11635E+05    0.14700E-47    0.64583E-56    0.17064E-58
+    5    3    0.10271E-10    0.10000E+01    0.93834E+04    0.21014E-46    0.17344E-54    0.24420E-57
+    5    3    0.10271E-10    0.10000E+01    0.75673E+04    0.29665E-45    0.46496E-53    0.34506E-56
+    5    3    0.10271E-10    0.10000E+01    0.61026E+04    0.41736E-44    0.12464E-51    0.48597E-55
+    5    3    0.10271E-10    0.10000E+01    0.49215E+04    0.58684E-43    0.33413E-50    0.68411E-54
+    5    3    0.10271E-10    0.10000E+01    0.39689E+04    0.82513E-42    0.89573E-49    0.96303E-53
+    5    3    0.10271E-10    0.10000E+01    0.32008E+04    0.36486E-39    0.77644E-46    0.42633E-50
+    5    3    0.10271E-10    0.10000E+01    0.25813E+04    0.26697E-30    0.13024E-36    0.31230E-41
+    5    3    0.10271E-10    0.10000E+01    0.20817E+04    0.50708E-14    0.11035E-19    0.59396E-25
+    5    3    0.10271E-10    0.10000E+01    0.16788E+04    0.17118E-08    0.16284E-13    0.20068E-19
+    5    3    0.10271E-10    0.10000E+01    0.13538E+04    0.36738E-08    0.61846E-13    0.43080E-19
+    5    3    0.10271E-10    0.10000E+01    0.10918E+04    0.77111E-08    0.23059E-12    0.90442E-19
+    5    3    0.10271E-10    0.10000E+01    0.88049E+03    0.15842E-07    0.84896E-12    0.18584E-18
+    5    3    0.10271E-10    0.10000E+01    0.71007E+03    0.31923E-07    0.30914E-11    0.37451E-18
+    5    3    0.10271E-10    0.10000E+01    0.57264E+03    0.63253E-07    0.10999E-10    0.74213E-18
+    5    3    0.10271E-10    0.10000E+01    0.46180E+03    0.12331E-06    0.36993E-10    0.14468E-17
+    5    3    0.10271E-10    0.10000E+01    0.37242E+03    0.23532E-06    0.11280E-09    0.27612E-17
+    5    3    0.10271E-10    0.10000E+01    0.30034E+03    0.43463E-06    0.30255E-09    0.50998E-17
+    5    3    0.10271E-10    0.10000E+01    0.24221E+03    0.76571E-06    0.70642E-09    0.89847E-17
+    5    3    0.10271E-10    0.10000E+01    0.19533E+03    0.12068E-05    0.13424E-08    0.14160E-16
+    5    3    0.10271E-10    0.10000E+01    0.15752E+03    0.12068E-05    0.13424E-08    0.14160E-16
+    5    3    0.17923E-10    0.10000E+01    0.80645E+05    0.56974E-58    0.39458E-69    0.34512E-68
+    5    3    0.17923E-10    0.10000E+01    0.65036E+05    0.46742E-57    0.87557E-68    0.28619E-67
+    5    3    0.17923E-10    0.10000E+01    0.52449E+05    0.52506E-56    0.24068E-66    0.24925E-66
+    5    3    0.17923E-10    0.10000E+01    0.42297E+05    0.74459E-55    0.79957E-65    0.22235E-65
+    5    3    0.17923E-10    0.10000E+01    0.34111E+05    0.12643E-53    0.27733E-63    0.26441E-64
+    5    3    0.17923E-10    0.10000E+01    0.27509E+05    0.22703E-52    0.93966E-62    0.41822E-63
+    5    3    0.17923E-10    0.10000E+01    0.22184E+05    0.40073E-51    0.30137E-60    0.72619E-62
+    5    3    0.17923E-10    0.10000E+01    0.17891E+05    0.67090E-50    0.89723E-59    0.12295E-60
+    5    3    0.17923E-10    0.10000E+01    0.14428E+05    0.10493E-48    0.25117E-57    0.19453E-59
+    5    3    0.17923E-10    0.10000E+01    0.11635E+05    0.15502E-47    0.68147E-56    0.28947E-58
+    5    3    0.17923E-10    0.10000E+01    0.93834E+04    0.22173E-46    0.18310E-54    0.41588E-57
+    5    3    0.17923E-10    0.10000E+01    0.75673E+04    0.31317E-45    0.49112E-53    0.58933E-56
+    5    3    0.17923E-10    0.10000E+01    0.61026E+04    0.44084E-44    0.13174E-51    0.83200E-55
+    5    3    0.17923E-10    0.10000E+01    0.49215E+04    0.62024E-43    0.35339E-50    0.11737E-53
+    5    3    0.17923E-10    0.10000E+01    0.39689E+04    0.87264E-42    0.94791E-49    0.16553E-52
+    5    3    0.17923E-10    0.10000E+01    0.32008E+04    0.38611E-39    0.82214E-46    0.73400E-50
+    5    3    0.17923E-10    0.10000E+01    0.25813E+04    0.28269E-30    0.13799E-36    0.53851E-41
+    5    3    0.17923E-10    0.10000E+01    0.20817E+04    0.53731E-14    0.11699E-19    0.10259E-24
+    5    3    0.17923E-10    0.10000E+01    0.16788E+04    0.18147E-08    0.17270E-13    0.34696E-19
+    5    3    0.17923E-10    0.10000E+01    0.13538E+04    0.38951E-08    0.65593E-13    0.74510E-19
+    5    3    0.17923E-10    0.10000E+01    0.10918E+04    0.81766E-08    0.24457E-12    0.15647E-18
+    5    3    0.17923E-10    0.10000E+01    0.88049E+03    0.16800E-07    0.90043E-12    0.32157E-18
+    5    3    0.17923E-10    0.10000E+01    0.71007E+03    0.33855E-07    0.32788E-11    0.64814E-18
+    5    3    0.17923E-10    0.10000E+01    0.57264E+03    0.67084E-07    0.11665E-10    0.12844E-17
+    5    3    0.17923E-10    0.10000E+01    0.46180E+03    0.13078E-06    0.39236E-10    0.25041E-17
+    5    3    0.17923E-10    0.10000E+01    0.37242E+03    0.24958E-06    0.11964E-09    0.47794E-17
+    5    3    0.17923E-10    0.10000E+01    0.30034E+03    0.46097E-06    0.32089E-09    0.88275E-17
+    5    3    0.17923E-10    0.10000E+01    0.24221E+03    0.81212E-06    0.74925E-09    0.15552E-16
+    5    3    0.17923E-10    0.10000E+01    0.19533E+03    0.12799E-05    0.14238E-08    0.24511E-16
+    5    3    0.17923E-10    0.10000E+01    0.15752E+03    0.12799E-05    0.14238E-08    0.24511E-16
+    5    3    0.31275E-10    0.10000E+01    0.80645E+05    0.12254E-57    0.87767E-69    0.11986E-67
+    5    3    0.31275E-10    0.10000E+01    0.65036E+05    0.10111E-56    0.15583E-67    0.10190E-66
+    5    3    0.31275E-10    0.10000E+01    0.52449E+05    0.94440E-56    0.30592E-66    0.86548E-66
+    5    3    0.31275E-10    0.10000E+01    0.42297E+05    0.99165E-55    0.84922E-65    0.67747E-65
+    5    3    0.31275E-10    0.10000E+01    0.34111E+05    0.13809E-53    0.28136E-63    0.60987E-64
+    5    3    0.31275E-10    0.10000E+01    0.27509E+05    0.23250E-52    0.95151E-62    0.75009E-63
+    5    3    0.31275E-10    0.10000E+01    0.22184E+05    0.40683E-51    0.30749E-60    0.11815E-61
+    5    3    0.31275E-10    0.10000E+01    0.17891E+05    0.68458E-50    0.92100E-59    0.19861E-60
+    5    3    0.31275E-10    0.10000E+01    0.14428E+05    0.10765E-48    0.25868E-57    0.31859E-59
+    5    3    0.31275E-10    0.10000E+01    0.11635E+05    0.15959E-47    0.70320E-56    0.47991E-58
+    5    3    0.31275E-10    0.10000E+01    0.93834E+04    0.22875E-46    0.18922E-54    0.69534E-57
+    5    3    0.31275E-10    0.10000E+01    0.75673E+04    0.32361E-45    0.50826E-53    0.99140E-56
+    5    3    0.31275E-10    0.10000E+01    0.61026E+04    0.45617E-44    0.13651E-51    0.14064E-54
+    5    3    0.31275E-10    0.10000E+01    0.49215E+04    0.64265E-43    0.36662E-50    0.19920E-53
+    5    3    0.31275E-10    0.10000E+01    0.39689E+04    0.90524E-42    0.98442E-49    0.28188E-52
+    5    3    0.31275E-10    0.10000E+01    0.32008E+04    0.40095E-39    0.85461E-46    0.12535E-49
+    5    3    0.31275E-10    0.10000E+01    0.25813E+04    0.29386E-30    0.14358E-36    0.92200E-41
+    5    3    0.31275E-10    0.10000E+01    0.20817E+04    0.55916E-14    0.12186E-19    0.17612E-24
+    5    3    0.31275E-10    0.10000E+01    0.16788E+04    0.18898E-08    0.17997E-13    0.59670E-19
+    5    3    0.31275E-10    0.10000E+01    0.13538E+04    0.40573E-08    0.68359E-13    0.12822E-18
+    5    3    0.31275E-10    0.10000E+01    0.10918E+04    0.85187E-08    0.25489E-12    0.26937E-18
+    5    3    0.31275E-10    0.10000E+01    0.88049E+03    0.17505E-07    0.93844E-12    0.55376E-18
+    5    3    0.31275E-10    0.10000E+01    0.71007E+03    0.35279E-07    0.34173E-11    0.11164E-17
+    5    3    0.31275E-10    0.10000E+01    0.57264E+03    0.69910E-07    0.12158E-10    0.22127E-17
+    5    3    0.31275E-10    0.10000E+01    0.46180E+03    0.13629E-06    0.40892E-10    0.43143E-17
+    5    3    0.31275E-10    0.10000E+01    0.37242E+03    0.26011E-06    0.12469E-09    0.82346E-17
+    5    3    0.31275E-10    0.10000E+01    0.30034E+03    0.48042E-06    0.33444E-09    0.15210E-16
+    5    3    0.31275E-10    0.10000E+01    0.24221E+03    0.84640E-06    0.78088E-09    0.26797E-16
+    5    3    0.31275E-10    0.10000E+01    0.19533E+03    0.13339E-05    0.14839E-08    0.42233E-16
+    5    3    0.31275E-10    0.10000E+01    0.15752E+03    0.13339E-05    0.14839E-08    0.42233E-16
+    5    3    0.54572E-10    0.10000E+01    0.80645E+05    0.25989E-57    0.19307E-68    0.40683E-67
+    5    3    0.54572E-10    0.10000E+01    0.65036E+05    0.21898E-56    0.31323E-67    0.34753E-66
+    5    3    0.54572E-10    0.10000E+01    0.52449E+05    0.19008E-55    0.47980E-66    0.29417E-65
+    5    3    0.54572E-10    0.10000E+01    0.42297E+05    0.16112E-54    0.99461E-65    0.22024E-64
+    5    3    0.54572E-10    0.10000E+01    0.34111E+05    0.16888E-53    0.28139E-63    0.16686E-63
+    5    3    0.54572E-10    0.10000E+01    0.27509E+05    0.23830E-52    0.91500E-62    0.15363E-62
+    5    3    0.54572E-10    0.10000E+01    0.22184E+05    0.39509E-51    0.29771E-60    0.19930E-61
+    5    3    0.54572E-10    0.10000E+01    0.17891E+05    0.66412E-50    0.90236E-59    0.32167E-60
+    5    3    0.54572E-10    0.10000E+01    0.14428E+05    0.10541E-48    0.25542E-57    0.52208E-59
+    5    3    0.54572E-10    0.10000E+01    0.11635E+05    0.15746E-47    0.69768E-56    0.79811E-58
+    5    3    0.54572E-10    0.10000E+01    0.93834E+04    0.22685E-46    0.18840E-54    0.11681E-56
+    5    3    0.54572E-10    0.10000E+01    0.75673E+04    0.32210E-45    0.50754E-53    0.16770E-55
+    5    3    0.54572E-10    0.10000E+01    0.61026E+04    0.45543E-44    0.13666E-51    0.23917E-54
+    5    3    0.54572E-10    0.10000E+01    0.49215E+04    0.64327E-43    0.36785E-50    0.34023E-53
+    5    3    0.54572E-10    0.10000E+01    0.39689E+04    0.90812E-42    0.98957E-49    0.48321E-52
+    5    3    0.54572E-10    0.10000E+01    0.32008E+04    0.40301E-39    0.86052E-46    0.21555E-49
+    5    3    0.54572E-10    0.10000E+01    0.25813E+04    0.29589E-30    0.14482E-36    0.15901E-40
+    5    3    0.54572E-10    0.10000E+01    0.20817E+04    0.56412E-14    0.12314E-19    0.30470E-24
+    5    3    0.54572E-10    0.10000E+01    0.16788E+04    0.19089E-08    0.18200E-13    0.10343E-18
+    5    3    0.54572E-10    0.10000E+01    0.13538E+04    0.41000E-08    0.69136E-13    0.22240E-18
+    5    3    0.54572E-10    0.10000E+01    0.10918E+04    0.86109E-08    0.25780E-12    0.46747E-18
+    5    3    0.54572E-10    0.10000E+01    0.88049E+03    0.17698E-07    0.94919E-12    0.96135E-18
+    5    3    0.54572E-10    0.10000E+01    0.71007E+03    0.35674E-07    0.34565E-11    0.19385E-17
+    5    3    0.54572E-10    0.10000E+01    0.57264E+03    0.70700E-07    0.12298E-10    0.38429E-17
+    5    3    0.54572E-10    0.10000E+01    0.46180E+03    0.13784E-06    0.41362E-10    0.74935E-17
+    5    3    0.54572E-10    0.10000E+01    0.37242E+03    0.26308E-06    0.12612E-09    0.14304E-16
+    5    3    0.54572E-10    0.10000E+01    0.30034E+03    0.48592E-06    0.33827E-09    0.26421E-16
+    5    3    0.54572E-10    0.10000E+01    0.24221E+03    0.85609E-06    0.78984E-09    0.46550E-16
+    5    3    0.54572E-10    0.10000E+01    0.19533E+03    0.13492E-05    0.15010E-08    0.73366E-16
+    5    3    0.54572E-10    0.10000E+01    0.15752E+03    0.13492E-05    0.15010E-08    0.73366E-16
+    5    3    0.95225E-10    0.10000E+01    0.80645E+05    0.53461E-57    0.40254E-68    0.14122E-66
+    5    3    0.95225E-10    0.10000E+01    0.65036E+05    0.45434E-56    0.63724E-67    0.11967E-65
+    5    3    0.95225E-10    0.10000E+01    0.52449E+05    0.38618E-55    0.87333E-66    0.10089E-64
+    5    3    0.95225E-10    0.10000E+01    0.42297E+05    0.29710E-54    0.13890E-64    0.74222E-64
+    5    3    0.95225E-10    0.10000E+01    0.34111E+05    0.24595E-53    0.29785E-63    0.51916E-63
+    5    3    0.95225E-10    0.10000E+01    0.27509E+05    0.26398E-52    0.86193E-62    0.38789E-62
+    5    3    0.95225E-10    0.10000E+01    0.22184E+05    0.38126E-51    0.27904E-60    0.38758E-61
+    5    3    0.95225E-10    0.10000E+01    0.17891E+05    0.62639E-50    0.86001E-59    0.55468E-60
+    5    3    0.95225E-10    0.10000E+01    0.14428E+05    0.10044E-48    0.24637E-57    0.88477E-59
+    5    3    0.95225E-10    0.10000E+01    0.11635E+05    0.15171E-47    0.67788E-56    0.13590E-57
+    5    3    0.95225E-10    0.10000E+01    0.93834E+04    0.22025E-46    0.18398E-54    0.19985E-56
+    5    3    0.95225E-10    0.10000E+01    0.75673E+04    0.31441E-45    0.49766E-53    0.28773E-55
+    5    3    0.95225E-10    0.10000E+01    0.61026E+04    0.44642E-44    0.13447E-51    0.41119E-54
+    5    3    0.95225E-10    0.10000E+01    0.49215E+04    0.63276E-43    0.36301E-50    0.58603E-53
+    5    3    0.95225E-10    0.10000E+01    0.39689E+04    0.89597E-42    0.97905E-49    0.83384E-52
+    5    3    0.95225E-10    0.10000E+01    0.32008E+04    0.39866E-39    0.85329E-46    0.37265E-49
+    5    3    0.95225E-10    0.10000E+01    0.25813E+04    0.29341E-30    0.14394E-36    0.27544E-40
+    5    3    0.95225E-10    0.10000E+01    0.20817E+04    0.56086E-14    0.12270E-19    0.52902E-24
+    5    3    0.95225E-10    0.10000E+01    0.16788E+04    0.19010E-08    0.18153E-13    0.17985E-18
+    5    3    0.95225E-10    0.10000E+01    0.13538E+04    0.40854E-08    0.68968E-13    0.38690E-18
+    5    3    0.95225E-10    0.10000E+01    0.10918E+04    0.85837E-08    0.25720E-12    0.81353E-18
+    5    3    0.95225E-10    0.10000E+01    0.88049E+03    0.17648E-07    0.94700E-12    0.16735E-17
+    5    3    0.95225E-10    0.10000E+01    0.71007E+03    0.35579E-07    0.34485E-11    0.33751E-17
+    5    3    0.95225E-10    0.10000E+01    0.57264E+03    0.70522E-07    0.12269E-10    0.66915E-17
+    5    3    0.95225E-10    0.10000E+01    0.46180E+03    0.13751E-06    0.41267E-10    0.13049E-16
+    5    3    0.95225E-10    0.10000E+01    0.37242E+03    0.26246E-06    0.12583E-09    0.24910E-16
+    5    3    0.95225E-10    0.10000E+01    0.30034E+03    0.48478E-06    0.33750E-09    0.46013E-16
+    5    3    0.95225E-10    0.10000E+01    0.24221E+03    0.85411E-06    0.78803E-09    0.81069E-16
+    5    3    0.95225E-10    0.10000E+01    0.19533E+03    0.13461E-05    0.14975E-08    0.12777E-15
+    5    3    0.95225E-10    0.10000E+01    0.15752E+03    0.13461E-05    0.14975E-08    0.12777E-15
+    5    3    0.16616E-09    0.10000E+01    0.80645E+05    0.10714E-56    0.80397E-68    0.50208E-66
+    5    3    0.16616E-09    0.10000E+01    0.65036E+05    0.90781E-56    0.12652E-66    0.42268E-65
+    5    3    0.16616E-09    0.10000E+01    0.52449E+05    0.76628E-55    0.16673E-65    0.35572E-64
+    5    3    0.16616E-09    0.10000E+01    0.42297E+05    0.56896E-54    0.22832E-64    0.26097E-63
+    5    3    0.16616E-09    0.10000E+01    0.34111E+05    0.41461E-53    0.36971E-63    0.17908E-62
+    5    3    0.16616E-09    0.10000E+01    0.27509E+05    0.34534E-52    0.85936E-62    0.12227E-61
+    5    3    0.16616E-09    0.10000E+01    0.22184E+05    0.39674E-51    0.26427E-60    0.96450E-61
+    5    3    0.16616E-09    0.10000E+01    0.17891E+05    0.60212E-50    0.82123E-59    0.10844E-59
+    5    3    0.16616E-09    0.10000E+01    0.14428E+05    0.96102E-49    0.23782E-57    0.15695E-58
+    5    3    0.16616E-09    0.10000E+01    0.11635E+05    0.14634E-47    0.65853E-56    0.23595E-57
+    5    3    0.16616E-09    0.10000E+01    0.93834E+04    0.21381E-46    0.17944E-54    0.34587E-56
+    5    3    0.16616E-09    0.10000E+01    0.75673E+04    0.30654E-45    0.48691E-53    0.49761E-55
+    5    3    0.16616E-09    0.10000E+01    0.61026E+04    0.43667E-44    0.13193E-51    0.71068E-54
+    5    3    0.16616E-09    0.10000E+01    0.49215E+04    0.62069E-43    0.35705E-50    0.10125E-52
+    5    3    0.16616E-09    0.10000E+01    0.39689E+04    0.88112E-42    0.96515E-49    0.14409E-51
+    5    3    0.16616E-09    0.10000E+01    0.32008E+04    0.39296E-39    0.84295E-46    0.64430E-49
+    5    3    0.16616E-09    0.10000E+01    0.25813E+04    0.28988E-30    0.14251E-36    0.47671E-40
+    5    3    0.16616E-09    0.10000E+01    0.20817E+04    0.55552E-14    0.12179E-19    0.91699E-24
+    5    3    0.16616E-09    0.10000E+01    0.16788E+04    0.18859E-08    0.18037E-13    0.31207E-18
+    5    3    0.16616E-09    0.10000E+01    0.13538E+04    0.40553E-08    0.68537E-13    0.67158E-18
+    5    3    0.16616E-09    0.10000E+01    0.10918E+04    0.85240E-08    0.25561E-12    0.14125E-17
+    5    3    0.16616E-09    0.10000E+01    0.88049E+03    0.17530E-07    0.94119E-12    0.29061E-17
+    5    3    0.16616E-09    0.10000E+01    0.71007E+03    0.35349E-07    0.34274E-11    0.58620E-17
+    5    3    0.16616E-09    0.10000E+01    0.57264E+03    0.70076E-07    0.12194E-10    0.11623E-16
+    5    3    0.16616E-09    0.10000E+01    0.46180E+03    0.13665E-06    0.41014E-10    0.22667E-16
+    5    3    0.16616E-09    0.10000E+01    0.37242E+03    0.26083E-06    0.12506E-09    0.43270E-16
+    5    3    0.16616E-09    0.10000E+01    0.30034E+03    0.48179E-06    0.33543E-09    0.79927E-16
+    5    3    0.16616E-09    0.10000E+01    0.24221E+03    0.84885E-06    0.78319E-09    0.14082E-15
+    5    3    0.16616E-09    0.10000E+01    0.19533E+03    0.13378E-05    0.14883E-08    0.22195E-15
+    5    3    0.16616E-09    0.10000E+01    0.15752E+03    0.13378E-05    0.14883E-08    0.22195E-15
+    5    3    0.28994E-09    0.10000E+01    0.80645E+05    0.21033E-56    0.15684E-67    0.17438E-65
+    5    3    0.28994E-09    0.10000E+01    0.65036E+05    0.17735E-55    0.24656E-66    0.14661E-64
+    5    3    0.28994E-09    0.10000E+01    0.52449E+05    0.14934E-54    0.32183E-65    0.12355E-63
+    5    3    0.28994E-09    0.10000E+01    0.42297E+05    0.10984E-53    0.41765E-64    0.91083E-63
+    5    3    0.28994E-09    0.10000E+01    0.34111E+05    0.76438E-53    0.57111E-63    0.62968E-62
+    5    3    0.28994E-09    0.10000E+01    0.27509E+05    0.55045E-52    0.10122E-61    0.42381E-61
+    5    3    0.28994E-09    0.10000E+01    0.22184E+05    0.49210E-51    0.26664E-60    0.29412E-60
+    5    3    0.28994E-09    0.10000E+01    0.17891E+05    0.62627E-50    0.80315E-59    0.25045E-59
+    5    3    0.28994E-09    0.10000E+01    0.14428E+05    0.94825E-49    0.23275E-57    0.29289E-58
+    5    3    0.28994E-09    0.10000E+01    0.11635E+05    0.14341E-47    0.64652E-56    0.40884E-57
+    5    3    0.28994E-09    0.10000E+01    0.93834E+04    0.20988E-46    0.17651E-54    0.59138E-56
+    5    3    0.28994E-09    0.10000E+01    0.75673E+04    0.30147E-45    0.47959E-53    0.85158E-55
+    5    3    0.28994E-09    0.10000E+01    0.61026E+04    0.43007E-44    0.13011E-51    0.12186E-53
+    5    3    0.28994E-09    0.10000E+01    0.49215E+04    0.61210E-43    0.35261E-50    0.17383E-52
+    5    3    0.28994E-09    0.10000E+01    0.39689E+04    0.87010E-42    0.95452E-49    0.24761E-51
+    5    3    0.28994E-09    0.10000E+01    0.32008E+04    0.38862E-39    0.83492E-46    0.11084E-48
+    5    3    0.28994E-09    0.10000E+01    0.25813E+04    0.28714E-30    0.14140E-36    0.82128E-40
+    5    3    0.28994E-09    0.10000E+01    0.20817E+04    0.55141E-14    0.12110E-19    0.15830E-23
+    5    3    0.28994E-09    0.10000E+01    0.16788E+04    0.18745E-08    0.17949E-13    0.53951E-18
+    5    3    0.28994E-09    0.10000E+01    0.13538E+04    0.40324E-08    0.68213E-13    0.11615E-17
+    5    3    0.28994E-09    0.10000E+01    0.10918E+04    0.84788E-08    0.25442E-12    0.24437E-17
+    5    3    0.28994E-09    0.10000E+01    0.88049E+03    0.17441E-07    0.93681E-12    0.50290E-17
+    5    3    0.28994E-09    0.10000E+01    0.71007E+03    0.35176E-07    0.34115E-11    0.10146E-16
+    5    3    0.28994E-09    0.10000E+01    0.57264E+03    0.69739E-07    0.12137E-10    0.20118E-16
+    5    3    0.28994E-09    0.10000E+01    0.46180E+03    0.13600E-06    0.40822E-10    0.39237E-16
+    5    3    0.28994E-09    0.10000E+01    0.37242E+03    0.25960E-06    0.12447E-09    0.74903E-16
+    5    3    0.28994E-09    0.10000E+01    0.30034E+03    0.47953E-06    0.33386E-09    0.13836E-15
+    5    3    0.28994E-09    0.10000E+01    0.24221E+03    0.84488E-06    0.77953E-09    0.24378E-15
+    5    3    0.28994E-09    0.10000E+01    0.19533E+03    0.13316E-05    0.14814E-08    0.38421E-15
+    5    3    0.28994E-09    0.10000E+01    0.15752E+03    0.13316E-05    0.14814E-08    0.38421E-15
+    5    3    0.50593E-09    0.10000E+01    0.80645E+05    0.40590E-56    0.30176E-67    0.57074E-65
+    5    3    0.50593E-09    0.10000E+01    0.65036E+05    0.34151E-55    0.47501E-66    0.48032E-64
+    5    3    0.50593E-09    0.10000E+01    0.52449E+05    0.28770E-54    0.62161E-65    0.40563E-63
+    5    3    0.50593E-09    0.10000E+01    0.42297E+05    0.21189E-53    0.80221E-64    0.30075E-62
+    5    3    0.50593E-09    0.10000E+01    0.34111E+05    0.14659E-52    0.10350E-62    0.21033E-61
+    5    3    0.50593E-09    0.10000E+01    0.27509E+05    0.10029E-51    0.14869E-61    0.14303E-60
+    5    3    0.50593E-09    0.10000E+01    0.22184E+05    0.75013E-51    0.30117E-60    0.95416E-60
+    5    3    0.50593E-09    0.10000E+01    0.17891E+05    0.74269E-50    0.80809E-59    0.67533E-59
+    5    3    0.50593E-09    0.10000E+01    0.14428E+05    0.97716E-49    0.22868E-57    0.60021E-58
+    5    3    0.50593E-09    0.10000E+01    0.11635E+05    0.14190E-47    0.63504E-56    0.71222E-57
+    5    3    0.50593E-09    0.10000E+01    0.93834E+04    0.20640E-46    0.17378E-54    0.98770E-56
+    5    3    0.50593E-09    0.10000E+01    0.75673E+04    0.29678E-45    0.47289E-53    0.14243E-54
+    5    3    0.50593E-09    0.10000E+01    0.61026E+04    0.42400E-44    0.12843E-51    0.20547E-53
+    5    3    0.50593E-09    0.10000E+01    0.49215E+04    0.60416E-43    0.34842E-50    0.29491E-52
+    5    3    0.50593E-09    0.10000E+01    0.39689E+04    0.85974E-42    0.94427E-49    0.42180E-51
+    5    3    0.50593E-09    0.10000E+01    0.32008E+04    0.38444E-39    0.82705E-46    0.18940E-48
+    5    3    0.50593E-09    0.10000E+01    0.25813E+04    0.28447E-30    0.14030E-36    0.14074E-39
+    5    3    0.50593E-09    0.10000E+01    0.20817E+04    0.54734E-14    0.12040E-19    0.27220E-23
+    5    3    0.50593E-09    0.10000E+01    0.16788E+04    0.18631E-08    0.17861E-13    0.92978E-18
+    5    3    0.50593E-09    0.10000E+01    0.13538E+04    0.40095E-08    0.67886E-13    0.20031E-17
+    5    3    0.50593E-09    0.10000E+01    0.10918E+04    0.84333E-08    0.25321E-12    0.42165E-17
+    5    3    0.50593E-09    0.10000E+01    0.88049E+03    0.17352E-07    0.93237E-12    0.86804E-17
+    5    3    0.50593E-09    0.10000E+01    0.71007E+03    0.35001E-07    0.33953E-11    0.17516E-16
+    5    3    0.50593E-09    0.10000E+01    0.57264E+03    0.69398E-07    0.12080E-10    0.34739E-16
+    5    3    0.50593E-09    0.10000E+01    0.46180E+03    0.13534E-06    0.40627E-10    0.67758E-16
+    5    3    0.50593E-09    0.10000E+01    0.37242E+03    0.25836E-06    0.12388E-09    0.12935E-15
+    5    3    0.50593E-09    0.10000E+01    0.30034E+03    0.47723E-06    0.33226E-09    0.23895E-15
+    5    3    0.50593E-09    0.10000E+01    0.24221E+03    0.84083E-06    0.77579E-09    0.42100E-15
+    5    3    0.50593E-09    0.10000E+01    0.19533E+03    0.13252E-05    0.14743E-08    0.66352E-15
+    5    3    0.50593E-09    0.10000E+01    0.15752E+03    0.13252E-05    0.14743E-08    0.66352E-15
+    5    3    0.88282E-09    0.10000E+01    0.80645E+05    0.77159E-56    0.57364E-67    0.17406E-64
+    5    3    0.88282E-09    0.10000E+01    0.65036E+05    0.64929E-55    0.90486E-66    0.14667E-63
+    5    3    0.88282E-09    0.10000E+01    0.52449E+05    0.54795E-54    0.11914E-64    0.12409E-62
+    5    3    0.88282E-09    0.10000E+01    0.42297E+05    0.40550E-53    0.15534E-63    0.92405E-62
+    5    3    0.88282E-09    0.10000E+01    0.34111E+05    0.28268E-52    0.19975E-62    0.65214E-61
+    5    3    0.88282E-09    0.10000E+01    0.27509E+05    0.19242E-51    0.25932E-61    0.44947E-60
+    5    3    0.88282E-09    0.10000E+01    0.22184E+05    0.13240E-50    0.40181E-60    0.29981E-59
+    5    3    0.88282E-09    0.10000E+01    0.17891E+05    0.10439E-49    0.85758E-59    0.19667E-58
+    5    3    0.88282E-09    0.10000E+01    0.14428E+05    0.10867E-48    0.22386E-57    0.14080E-57
+    5    3    0.88282E-09    0.10000E+01    0.11635E+05    0.14170E-47    0.61499E-56    0.13128E-56
+    5    3    0.88282E-09    0.10000E+01    0.93834E+04    0.20092E-46    0.16914E-54    0.16332E-55
+    5    3    0.88282E-09    0.10000E+01    0.75673E+04    0.28899E-45    0.46267E-53    0.23244E-54
+    5    3    0.88282E-09    0.10000E+01    0.61026E+04    0.41465E-44    0.12608E-51    0.33953E-53
+    5    3    0.88282E-09    0.10000E+01    0.49215E+04    0.59289E-43    0.34284E-50    0.49343E-52
+    5    3    0.88282E-09    0.10000E+01    0.39689E+04    0.84579E-42    0.93094E-49    0.71177E-51
+    5    3    0.88282E-09    0.10000E+01    0.32008E+04    0.37899E-39    0.81693E-46    0.32146E-48
+    5    3    0.88282E-09    0.10000E+01    0.25813E+04    0.28102E-30    0.13890E-36    0.23999E-39
+    5    3    0.88282E-09    0.10000E+01    0.20817E+04    0.54212E-14    0.11951E-19    0.46647E-23
+    5    3    0.88282E-09    0.10000E+01    0.16788E+04    0.18486E-08    0.17749E-13    0.15986E-17
+    5    3    0.88282E-09    0.10000E+01    0.13538E+04    0.39804E-08    0.67469E-13    0.34470E-17
+    5    3    0.88282E-09    0.10000E+01    0.10918E+04    0.83755E-08    0.25167E-12    0.72609E-17
+    5    3    0.88282E-09    0.10000E+01    0.88049E+03    0.17238E-07    0.92670E-12    0.14955E-16
+    5    3    0.88282E-09    0.10000E+01    0.71007E+03    0.34777E-07    0.33746E-11    0.30189E-16
+    5    3    0.88282E-09    0.10000E+01    0.57264E+03    0.68964E-07    0.12006E-10    0.59883E-16
+    5    3    0.88282E-09    0.10000E+01    0.46180E+03    0.13450E-06    0.40378E-10    0.11681E-15
+    5    3    0.88282E-09    0.10000E+01    0.37242E+03    0.25677E-06    0.12312E-09    0.22302E-15
+    5    3    0.88282E-09    0.10000E+01    0.30034E+03    0.47430E-06    0.33021E-09    0.41197E-15
+    5    3    0.88282E-09    0.10000E+01    0.24221E+03    0.83567E-06    0.77101E-09    0.72586E-15
+    5    3    0.88282E-09    0.10000E+01    0.19533E+03    0.13171E-05    0.14652E-08    0.11440E-14
+    5    3    0.88282E-09    0.10000E+01    0.15752E+03    0.13171E-05    0.14652E-08    0.11440E-14
+    5    3    0.15405E-08    0.10000E+01    0.80645E+05    0.14500E-55    0.10794E-66    0.50220E-64
+    5    3    0.15405E-08    0.10000E+01    0.65036E+05    0.12216E-54    0.17062E-65    0.42370E-63
+    5    3    0.15405E-08    0.10000E+01    0.52449E+05    0.10330E-53    0.22601E-64    0.35897E-62
+    5    3    0.15405E-08    0.10000E+01    0.42297E+05    0.76814E-53    0.29822E-63    0.26814E-61
+    5    3    0.15405E-08    0.10000E+01    0.34111E+05    0.54065E-52    0.38877E-62    0.19048E-60
+    5    3    0.15405E-08    0.10000E+01    0.27509E+05    0.37175E-51    0.49171E-61    0.13280E-59
+    5    3    0.15405E-08    0.10000E+01    0.22184E+05    0.25023E-50    0.64390E-60    0.89688E-59
+    5    3    0.15405E-08    0.10000E+01    0.17891E+05    0.17266E-49    0.10315E-58    0.58050E-58
+    5    3    0.15405E-08    0.10000E+01    0.14428E+05    0.13929E-48    0.22322E-57    0.37352E-57
+    5    3    0.15405E-08    0.10000E+01    0.11635E+05    0.14761E-47    0.58281E-56    0.27586E-56
+    5    3    0.15405E-08    0.10000E+01    0.93834E+04    0.19347E-46    0.16080E-54    0.28013E-55
+    5    3    0.15405E-08    0.10000E+01    0.75673E+04    0.27557E-45    0.44496E-53    0.37382E-54
+    5    3    0.15405E-08    0.10000E+01    0.61026E+04    0.39858E-44    0.12232E-51    0.54924E-53
+    5    3    0.15405E-08    0.10000E+01    0.49215E+04    0.57472E-43    0.33453E-50    0.81259E-52
+    5    3    0.15405E-08    0.10000E+01    0.39689E+04    0.82481E-42    0.91204E-49    0.11886E-50
+    5    3    0.15405E-08    0.10000E+01    0.32008E+04    0.37118E-39    0.80303E-46    0.54185E-48
+    5    3    0.15405E-08    0.10000E+01    0.25813E+04    0.27626E-30    0.13702E-36    0.40733E-39
+    5    3    0.15405E-08    0.10000E+01    0.20817E+04    0.53511E-14    0.11836E-19    0.79697E-23
+    5    3    0.15405E-08    0.10000E+01    0.16788E+04    0.18296E-08    0.17605E-13    0.27427E-17
+    5    3    0.15405E-08    0.10000E+01    0.13538E+04    0.39427E-08    0.66938E-13    0.59205E-17
+    5    3    0.15405E-08    0.10000E+01    0.10918E+04    0.83009E-08    0.24971E-12    0.12482E-16
+    5    3    0.15405E-08    0.10000E+01    0.88049E+03    0.17091E-07    0.91949E-12    0.25724E-16
+    5    3    0.15405E-08    0.10000E+01    0.71007E+03    0.34492E-07    0.33482E-11    0.51946E-16
+    5    3    0.15405E-08    0.10000E+01    0.57264E+03    0.68410E-07    0.11911E-10    0.10307E-15
+    5    3    0.15405E-08    0.10000E+01    0.46180E+03    0.13344E-06    0.40061E-10    0.20108E-15
+    5    3    0.15405E-08    0.10000E+01    0.37242E+03    0.25474E-06    0.12215E-09    0.38392E-15
+    5    3    0.15405E-08    0.10000E+01    0.30034E+03    0.47057E-06    0.32761E-09    0.70922E-15
+    5    3    0.15405E-08    0.10000E+01    0.24221E+03    0.82909E-06    0.76493E-09    0.12496E-14
+    5    3    0.15405E-08    0.10000E+01    0.19533E+03    0.13067E-05    0.14536E-08    0.19694E-14
+    5    3    0.15405E-08    0.10000E+01    0.15752E+03    0.13067E-05    0.14536E-08    0.19694E-14
+    5    3    0.26880E-08    0.10000E+01    0.80645E+05    0.27103E-55    0.20208E-66    0.14273E-63
+    5    3    0.26880E-08    0.10000E+01    0.65036E+05    0.22864E-54    0.31996E-65    0.12054E-62
+    5    3    0.26880E-08    0.10000E+01    0.52449E+05    0.19367E-53    0.42589E-64    0.10224E-61
+    5    3    0.26880E-08    0.10000E+01    0.42297E+05    0.14459E-52    0.56755E-63    0.76551E-61
+    5    3    0.26880E-08    0.10000E+01    0.34111E+05    0.10260E-51    0.75157E-62    0.54649E-60
+    5    3    0.26880E-08    0.10000E+01    0.27509E+05    0.71447E-51    0.95810E-61    0.38457E-59
+    5    3    0.26880E-08    0.10000E+01    0.22184E+05    0.48372E-50    0.11821E-59    0.26360E-58
+    5    3    0.26880E-08    0.10000E+01    0.17891E+05    0.31886E-49    0.15288E-58    0.17289E-57
+    5    3    0.26880E-08    0.10000E+01    0.14428E+05    0.21676E-48    0.24756E-57    0.10867E-56
+    5    3    0.26880E-08    0.10000E+01    0.11635E+05    0.17554E-47    0.55050E-56    0.69837E-56
+    5    3    0.26880E-08    0.10000E+01    0.93834E+04    0.19040E-46    0.14757E-54    0.54925E-55
+    5    3    0.26880E-08    0.10000E+01    0.75673E+04    0.25619E-45    0.41455E-53    0.61546E-54
+    5    3    0.26880E-08    0.10000E+01    0.61026E+04    0.37187E-44    0.11599E-51    0.87256E-53
+    5    3    0.26880E-08    0.10000E+01    0.49215E+04    0.54429E-43    0.32113E-50    0.13119E-51
+    5    3    0.26880E-08    0.10000E+01    0.39689E+04    0.79078E-42    0.88255E-49    0.19578E-50
+    5    3    0.26880E-08    0.10000E+01    0.32008E+04    0.35892E-39    0.78171E-46    0.90539E-48
+    5    3    0.26880E-08    0.10000E+01    0.25813E+04    0.26889E-30    0.13414E-36    0.68742E-39
+    5    3    0.26880E-08    0.10000E+01    0.20817E+04    0.52426E-14    0.11655E-19    0.13569E-22
+    5    3    0.26880E-08    0.10000E+01    0.16788E+04    0.18001E-08    0.17375E-13    0.46948E-17
+    5    3    0.26880E-08    0.10000E+01    0.13538E+04    0.38832E-08    0.66083E-13    0.10146E-16
+    5    3    0.26880E-08    0.10000E+01    0.10918E+04    0.81826E-08    0.24654E-12    0.21410E-16
+    5    3    0.26880E-08    0.10000E+01    0.88049E+03    0.16858E-07    0.90783E-12    0.44154E-16
+    5    3    0.26880E-08    0.10000E+01    0.71007E+03    0.34034E-07    0.33057E-11    0.89203E-16
+    5    3    0.26880E-08    0.10000E+01    0.57264E+03    0.67519E-07    0.11760E-10    0.17704E-15
+    5    3    0.26880E-08    0.10000E+01    0.46180E+03    0.13172E-06    0.39548E-10    0.34544E-15
+    5    3    0.26880E-08    0.10000E+01    0.37242E+03    0.25147E-06    0.12058E-09    0.65958E-15
+    5    3    0.26880E-08    0.10000E+01    0.30034E+03    0.46454E-06    0.32340E-09    0.12185E-14
+    5    3    0.26880E-08    0.10000E+01    0.24221E+03    0.81848E-06    0.75510E-09    0.21468E-14
+    5    3    0.26880E-08    0.10000E+01    0.19533E+03    0.12900E-05    0.14349E-08    0.33835E-14
+    5    3    0.26880E-08    0.10000E+01    0.15752E+03    0.12900E-05    0.14349E-08    0.33835E-14
+    5    3    0.46905E-08    0.10000E+01    0.80645E+05    0.57199E-55    0.42774E-66    0.17595E-62
+    5    3    0.46905E-08    0.10000E+01    0.65036E+05    0.48369E-54    0.67891E-65    0.14891E-61
+    5    3    0.46905E-08    0.10000E+01    0.52449E+05    0.41078E-53    0.90985E-64    0.12657E-60
+    5    3    0.46905E-08    0.10000E+01    0.42297E+05    0.30840E-52    0.12295E-62    0.95174E-60
+    5    3    0.46905E-08    0.10000E+01    0.34111E+05    0.22145E-51    0.16729E-61    0.68538E-59
+    5    3    0.46905E-08    0.10000E+01    0.27509E+05    0.15783E-50    0.22404E-60    0.49053E-58
+    5    3    0.46905E-08    0.10000E+01    0.22184E+05    0.11134E-49    0.29589E-59    0.34724E-57
+    5    3    0.46905E-08    0.10000E+01    0.17891E+05    0.77654E-49    0.39495E-58    0.24086E-56
+    5    3    0.46905E-08    0.10000E+01    0.14428E+05    0.54485E-48    0.56332E-57    0.16297E-55
+    5    3    0.46905E-08    0.10000E+01    0.11635E+05    0.40250E-47    0.92705E-56    0.10763E-54
+    5    3    0.46905E-08    0.10000E+01    0.93834E+04    0.33649E-46    0.18591E-54    0.69544E-54
+    5    3    0.46905E-08    0.10000E+01    0.75673E+04    0.33944E-45    0.44546E-53    0.44455E-53
+    5    3    0.46905E-08    0.10000E+01    0.61026E+04    0.41195E-44    0.11814E-51    0.30053E-52
+    5    3    0.46905E-08    0.10000E+01    0.49215E+04    0.56143E-43    0.32431E-50    0.25615E-51
+    5    3    0.46905E-08    0.10000E+01    0.39689E+04    0.80130E-42    0.89267E-49    0.30704E-50
+    5    3    0.46905E-08    0.10000E+01    0.32008E+04    0.36317E-39    0.79118E-46    0.14055E-47
+    5    3    0.46905E-08    0.10000E+01    0.25813E+04    0.27204E-30    0.13549E-36    0.11052E-38
+    5    3    0.46905E-08    0.10000E+01    0.20817E+04    0.52938E-14    0.11720E-19    0.22555E-22
+    5    3    0.46905E-08    0.10000E+01    0.16788E+04    0.18141E-08    0.17432E-13    0.79068E-17
+    5    3    0.46905E-08    0.10000E+01    0.13538E+04    0.39062E-08    0.66269E-13    0.16939E-16
+    5    3    0.46905E-08    0.10000E+01    0.10918E+04    0.82213E-08    0.24717E-12    0.35588E-16
+    5    3    0.46905E-08    0.10000E+01    0.88049E+03    0.16924E-07    0.91001E-12    0.73202E-16
+    5    3    0.46905E-08    0.10000E+01    0.71007E+03    0.34149E-07    0.33132E-11    0.14762E-15
+    5    3    0.46905E-08    0.10000E+01    0.57264E+03    0.67719E-07    0.11786E-10    0.29254E-15
+    5    3    0.46905E-08    0.10000E+01    0.46180E+03    0.13207E-06    0.39635E-10    0.57009E-15
+    5    3    0.46905E-08    0.10000E+01    0.37242E+03    0.25211E-06    0.12084E-09    0.10874E-14
+    5    3    0.46905E-08    0.10000E+01    0.30034E+03    0.46566E-06    0.32411E-09    0.20071E-14
+    5    3    0.46905E-08    0.10000E+01    0.24221E+03    0.82038E-06    0.75674E-09    0.35341E-14
+    5    3    0.46905E-08    0.10000E+01    0.19533E+03    0.12929E-05    0.14380E-08    0.55676E-14
+    5    3    0.46905E-08    0.10000E+01    0.15752E+03    0.12929E-05    0.14380E-08    0.55676E-14
+    5    3    0.81846E-08    0.10000E+01    0.80645E+05    0.10560E-54    0.79009E-66    0.53807E-62
+    5    3    0.81846E-08    0.10000E+01    0.65036E+05    0.89337E-54    0.12545E-64    0.45551E-61
+    5    3    0.81846E-08    0.10000E+01    0.52449E+05    0.75902E-53    0.16830E-63    0.38726E-60
+    5    3    0.81846E-08    0.10000E+01    0.42297E+05    0.57031E-52    0.22781E-62    0.29135E-59
+    5    3    0.81846E-08    0.10000E+01    0.34111E+05    0.41011E-51    0.31069E-61    0.21002E-58
+    5    3    0.81846E-08    0.10000E+01    0.27509E+05    0.29287E-50    0.41674E-60    0.15057E-57
+    5    3    0.81846E-08    0.10000E+01    0.22184E+05    0.20688E-49    0.54761E-59    0.10693E-56
+    5    3    0.81846E-08    0.10000E+01    0.17891E+05    0.14371E-48    0.71196E-58    0.74577E-56
+    5    3    0.81846E-08    0.10000E+01    0.14428E+05    0.98707E-48    0.94448E-57    0.50891E-55
+    5    3    0.81846E-08    0.10000E+01    0.11635E+05    0.68623E-47    0.13501E-55    0.33984E-54
+    5    3    0.81846E-08    0.10000E+01    0.93834E+04    0.50646E-46    0.22484E-54    0.22180E-53
+    5    3    0.81846E-08    0.10000E+01    0.75673E+04    0.42776E-45    0.46396E-53    0.14092E-52
+    5    3    0.81846E-08    0.10000E+01    0.61026E+04    0.44301E-44    0.11509E-51    0.88725E-52
+    5    3    0.81846E-08    0.10000E+01    0.49215E+04    0.55577E-43    0.31234E-50    0.62009E-51
+    5    3    0.81846E-08    0.10000E+01    0.39689E+04    0.77569E-42    0.86527E-49    0.59583E-50
+    5    3    0.81846E-08    0.10000E+01    0.32008E+04    0.35234E-39    0.77282E-46    0.24981E-47
+    5    3    0.81846E-08    0.10000E+01    0.25813E+04    0.26580E-30    0.13313E-36    0.19484E-38
+    5    3    0.81846E-08    0.10000E+01    0.20817E+04    0.52100E-14    0.11559E-19    0.40023E-22
+    5    3    0.81846E-08    0.10000E+01    0.16788E+04    0.17920E-08    0.17208E-13    0.13998E-16
+    5    3    0.81846E-08    0.10000E+01    0.13538E+04    0.38564E-08    0.65420E-13    0.29620E-16
+    5    3    0.81846E-08    0.10000E+01    0.10918E+04    0.81154E-08    0.24398E-12    0.61778E-16
+    5    3    0.81846E-08    0.10000E+01    0.88049E+03    0.16705E-07    0.89810E-12    0.12649E-15
+    5    3    0.81846E-08    0.10000E+01    0.71007E+03    0.33707E-07    0.32694E-11    0.25429E-15
+    5    3    0.81846E-08    0.10000E+01    0.57264E+03    0.66839E-07    0.11628E-10    0.50277E-15
+    5    3    0.81846E-08    0.10000E+01    0.46180E+03    0.13034E-06    0.39102E-10    0.97812E-15
+    5    3    0.81846E-08    0.10000E+01    0.37242E+03    0.24878E-06    0.11921E-09    0.18633E-14
+    5    3    0.81846E-08    0.10000E+01    0.30034E+03    0.45948E-06    0.31972E-09    0.34361E-14
+    5    3    0.81846E-08    0.10000E+01    0.24221E+03    0.80944E-06    0.74647E-09    0.60464E-14
+    5    3    0.81846E-08    0.10000E+01    0.19533E+03    0.12756E-05    0.14185E-08    0.95217E-14
+    5    3    0.81846E-08    0.10000E+01    0.15752E+03    0.12756E-05    0.14185E-08    0.95217E-14
+    5    3    0.14282E-07    0.10000E+01    0.80645E+05    0.19426E-54    0.14541E-65    0.16687E-61
+    5    3    0.14282E-07    0.10000E+01    0.65036E+05    0.16440E-53    0.23096E-64    0.14130E-60
+    5    3    0.14282E-07    0.10000E+01    0.52449E+05    0.13973E-52    0.31009E-63    0.12016E-59
+    5    3    0.14282E-07    0.10000E+01    0.42297E+05    0.10506E-51    0.42035E-62    0.90437E-59
+    5    3    0.14282E-07    0.10000E+01    0.34111E+05    0.75641E-51    0.57459E-61    0.65242E-58
+    5    3    0.14282E-07    0.10000E+01    0.27509E+05    0.54126E-50    0.77306E-60    0.46840E-57
+    5    3    0.14282E-07    0.10000E+01    0.22184E+05    0.38333E-49    0.10176E-58    0.33345E-56
+    5    3    0.14282E-07    0.10000E+01    0.17891E+05    0.26671E-48    0.13149E-57    0.23355E-55
+    5    3    0.14282E-07    0.10000E+01    0.14428E+05    0.18233E-47    0.16940E-56    0.16040E-54
+    5    3    0.14282E-07    0.10000E+01    0.11635E+05    0.12380E-46    0.22370E-55    0.10805E-53
+    5    3    0.14282E-07    0.10000E+01    0.93834E+04    0.85477E-46    0.31933E-54    0.71267E-53
+    5    3    0.14282E-07    0.10000E+01    0.75673E+04    0.62983E-45    0.54195E-53    0.45628E-52
+    5    3    0.14282E-07    0.10000E+01    0.61026E+04    0.54061E-44    0.11719E-51    0.28194E-51
+    5    3    0.14282E-07    0.10000E+01    0.49215E+04    0.58360E-43    0.30368E-50    0.17621E-50
+    5    3    0.14282E-07    0.10000E+01    0.39689E+04    0.76396E-42    0.84048E-49    0.13474E-49
+    5    3    0.14282E-07    0.10000E+01    0.32008E+04    0.34350E-39    0.75679E-46    0.47993E-47
+    5    3    0.14282E-07    0.10000E+01    0.25813E+04    0.26064E-30    0.13118E-36    0.36009E-38
+    5    3    0.14282E-07    0.10000E+01    0.20817E+04    0.51495E-14    0.11412E-19    0.73924E-22
+    5    3    0.14282E-07    0.10000E+01    0.16788E+04    0.17768E-08    0.16982E-13    0.25601E-16
+    5    3    0.14282E-07    0.10000E+01    0.13538E+04    0.38146E-08    0.64541E-13    0.52929E-16
+    5    3    0.14282E-07    0.10000E+01    0.10918E+04    0.80177E-08    0.24061E-12    0.10884E-15
+    5    3    0.14282E-07    0.10000E+01    0.88049E+03    0.16493E-07    0.88541E-12    0.22084E-15
+    5    3    0.14282E-07    0.10000E+01    0.71007E+03    0.33262E-07    0.32222E-11    0.44117E-15
+    5    3    0.14282E-07    0.10000E+01    0.57264E+03    0.65931E-07    0.11458E-10    0.86838E-15
+    5    3    0.14282E-07    0.10000E+01    0.46180E+03    0.12853E-06    0.38523E-10    0.16838E-14
+    5    3    0.14282E-07    0.10000E+01    0.37242E+03    0.24526E-06    0.11744E-09    0.31999E-14
+    5    3    0.14282E-07    0.10000E+01    0.30034E+03    0.45287E-06    0.31494E-09    0.58908E-14
+    5    3    0.14282E-07    0.10000E+01    0.24221E+03    0.79766E-06    0.73529E-09    0.10354E-13
+    5    3    0.14282E-07    0.10000E+01    0.19533E+03    0.12569E-05    0.13972E-08    0.16293E-13
+    5    3    0.14282E-07    0.10000E+01    0.15752E+03    0.12569E-05    0.13972E-08    0.16293E-13
+    5    3    0.24920E-07    0.10000E+01    0.80645E+05    0.35585E-54    0.26645E-65    0.52175E-61
+    5    3    0.24920E-07    0.10000E+01    0.65036E+05    0.30124E-53    0.42333E-64    0.44190E-60
+    5    3    0.24920E-07    0.10000E+01    0.52449E+05    0.25610E-52    0.56875E-63    0.37586E-59
+    5    3    0.24920E-07    0.10000E+01    0.42297E+05    0.19266E-51    0.77192E-62    0.28300E-58
+    5    3    0.24920E-07    0.10000E+01    0.34111E+05    0.13886E-50    0.10572E-60    0.20430E-57
+    5    3    0.24920E-07    0.10000E+01    0.27509E+05    0.99533E-50    0.14268E-59    0.14685E-56
+    5    3    0.24920E-07    0.10000E+01    0.22184E+05    0.70679E-49    0.18853E-58    0.10475E-55
+    5    3    0.24920E-07    0.10000E+01    0.17891E+05    0.49337E-48    0.24406E-57    0.73607E-55
+    5    3    0.24920E-07    0.10000E+01    0.14428E+05    0.33792E-47    0.31210E-56    0.50805E-54
+    5    3    0.24920E-07    0.10000E+01    0.11635E+05    0.22818E-46    0.39872E-55    0.34458E-53
+    5    3    0.24920E-07    0.10000E+01    0.93834E+04    0.15338E-45    0.52008E-54    0.22928E-52
+    5    3    0.24920E-07    0.10000E+01    0.75673E+04    0.10477E-44    0.74110E-53    0.14833E-51
+    5    3    0.24920E-07    0.10000E+01    0.61026E+04    0.77065E-44    0.13121E-51    0.91974E-51
+    5    3    0.24920E-07    0.10000E+01    0.49215E+04    0.68424E-43    0.30466E-50    0.55063E-50
+    5    3    0.24920E-07    0.10000E+01    0.39689E+04    0.78710E-42    0.82425E-49    0.35767E-49
+    5    3    0.24920E-07    0.10000E+01    0.32008E+04    0.34015E-39    0.74606E-46    0.10358E-46
+    5    3    0.24920E-07    0.10000E+01    0.25813E+04    0.25800E-30    0.13002E-36    0.71574E-38
+    5    3    0.24920E-07    0.10000E+01    0.20817E+04    0.51356E-14    0.11287E-19    0.14524E-21
+    5    3    0.24920E-07    0.10000E+01    0.16788E+04    0.17744E-08    0.16743E-13    0.49308E-16
+    5    3    0.24920E-07    0.10000E+01    0.13538E+04    0.37869E-08    0.63574E-13    0.98088E-16
+    5    3    0.24920E-07    0.10000E+01    0.10918E+04    0.79330E-08    0.23681E-12    0.19678E-15
+    5    3    0.24920E-07    0.10000E+01    0.88049E+03    0.16285E-07    0.87082E-12    0.39277E-15
+    5    3    0.24920E-07    0.10000E+01    0.71007E+03    0.32797E-07    0.31674E-11    0.77577E-15
+    5    3    0.24920E-07    0.10000E+01    0.57264E+03    0.64942E-07    0.11259E-10    0.15145E-14
+    5    3    0.24920E-07    0.10000E+01    0.46180E+03    0.12650E-06    0.37843E-10    0.29192E-14
+    5    3    0.24920E-07    0.10000E+01    0.37242E+03    0.24124E-06    0.11534E-09    0.55235E-14
+    5    3    0.24920E-07    0.10000E+01    0.30034E+03    0.44525E-06    0.30930E-09    0.10137E-13
+    5    3    0.24920E-07    0.10000E+01    0.24221E+03    0.78398E-06    0.72208E-09    0.17779E-13
+    5    3    0.24920E-07    0.10000E+01    0.19533E+03    0.12351E-05    0.13721E-08    0.27941E-13
+    5    3    0.24920E-07    0.10000E+01    0.15752E+03    0.12351E-05    0.13721E-08    0.27941E-13
+    5    3    0.43485E-07    0.10000E+01    0.80645E+05    0.64866E-54    0.48586E-65    0.16328E-60
+    5    3    0.43485E-07    0.10000E+01    0.65036E+05    0.54926E-53    0.77208E-64    0.13832E-59
+    5    3    0.43485E-07    0.10000E+01    0.52449E+05    0.46707E-52    0.10379E-62    0.11767E-58
+    5    3    0.43485E-07    0.10000E+01    0.42297E+05    0.35153E-51    0.14101E-61    0.88629E-58
+    5    3    0.43485E-07    0.10000E+01    0.34111E+05    0.25358E-50    0.19344E-60    0.64021E-57
+    5    3    0.43485E-07    0.10000E+01    0.27509E+05    0.18203E-49    0.26177E-59    0.46063E-56
+    5    3    0.43485E-07    0.10000E+01    0.22184E+05    0.12956E-48    0.34725E-58    0.32912E-55
+    5    3    0.43485E-07    0.10000E+01    0.17891E+05    0.90751E-48    0.45148E-57    0.23189E-54
+    5    3    0.43485E-07    0.10000E+01    0.14428E+05    0.62395E-47    0.57816E-56    0.16069E-53
+    5    3    0.43485E-07    0.10000E+01    0.11635E+05    0.42205E-46    0.73188E-55    0.10957E-52
+    5    3    0.43485E-07    0.10000E+01    0.93834E+04    0.28178E-45    0.91837E-54    0.73421E-52
+    5    3    0.43485E-07    0.10000E+01    0.75673E+04    0.18650E-44    0.11740E-52    0.47949E-51
+    5    3    0.43485E-07    0.10000E+01    0.61026E+04    0.12530E-43    0.17014E-51    0.30031E-50
+    5    3    0.43485E-07    0.10000E+01    0.49215E+04    0.93207E-43    0.32897E-50    0.17841E-49
+    5    3    0.43485E-07    0.10000E+01    0.39689E+04    0.88824E-42    0.83193E-49    0.10630E-48
+    5    3    0.43485E-07    0.10000E+01    0.32008E+04    0.35056E-39    0.74930E-46    0.25476E-46
+    5    3    0.43485E-07    0.10000E+01    0.25813E+04    0.26169E-30    0.13094E-36    0.15615E-37
+    5    3    0.43485E-07    0.10000E+01    0.20817E+04    0.52350E-14    0.11257E-19    0.30940E-21
+    5    3    0.43485E-07    0.10000E+01    0.16788E+04    0.18044E-08    0.16563E-13    0.10200E-15
+    5    3    0.43485E-07    0.10000E+01    0.13538E+04    0.38037E-08    0.62762E-13    0.19192E-15
+    5    3    0.43485E-07    0.10000E+01    0.10918E+04    0.79111E-08    0.23341E-12    0.37049E-15
+    5    3    0.43485E-07    0.10000E+01    0.88049E+03    0.16167E-07    0.85719E-12    0.71999E-15
+    5    3    0.43485E-07    0.10000E+01    0.71007E+03    0.32459E-07    0.31148E-11    0.13953E-14
+    5    3    0.43485E-07    0.10000E+01    0.57264E+03    0.64131E-07    0.11064E-10    0.26863E-14
+    5    3    0.43485E-07    0.10000E+01    0.46180E+03    0.12472E-06    0.37172E-10    0.51248E-14
+    5    3    0.43485E-07    0.10000E+01    0.37242E+03    0.23755E-06    0.11327E-09    0.96241E-14
+    5    3    0.43485E-07    0.10000E+01    0.30034E+03    0.43805E-06    0.30368E-09    0.17569E-13
+    5    3    0.43485E-07    0.10000E+01    0.24221E+03    0.77083E-06    0.70890E-09    0.30700E-13
+    5    3    0.43485E-07    0.10000E+01    0.19533E+03    0.12139E-05    0.13469E-08    0.48138E-13
+    5    3    0.43485E-07    0.10000E+01    0.15752E+03    0.12139E-05    0.13469E-08    0.48138E-13
+    5    3    0.75878E-07    0.10000E+01    0.80645E+05    0.11768E-53    0.88172E-65    0.51092E-60
+    5    3    0.75878E-07    0.10000E+01    0.65036E+05    0.99672E-53    0.14014E-63    0.43290E-59
+    5    3    0.75878E-07    0.10000E+01    0.52449E+05    0.84774E-52    0.18848E-62    0.36832E-58
+    5    3    0.75878E-07    0.10000E+01    0.42297E+05    0.63829E-51    0.25628E-61    0.27750E-57
+    5    3    0.75878E-07    0.10000E+01    0.34111E+05    0.46077E-50    0.35206E-60    0.20056E-56
+    5    3    0.75878E-07    0.10000E+01    0.27509E+05    0.33116E-49    0.47750E-59    0.14443E-55
+    5    3    0.75878E-07    0.10000E+01    0.22184E+05    0.23618E-48    0.63571E-58    0.10334E-54
+    5    3    0.75878E-07    0.10000E+01    0.17891E+05    0.16594E-47    0.83031E-57    0.72972E-54
+    5    3    0.75878E-07    0.10000E+01    0.14428E+05    0.11455E-46    0.10678E-55    0.50729E-53
+    5    3    0.75878E-07    0.10000E+01    0.11635E+05    0.77794E-46    0.13527E-54    0.34740E-52
+    5    3    0.75878E-07    0.10000E+01    0.93834E+04    0.52005E-45    0.16783E-53    0.23411E-51
+    5    3    0.75878E-07    0.10000E+01    0.75673E+04    0.34123E-44    0.20417E-52    0.15410E-50
+    5    3    0.75878E-07    0.10000E+01    0.61026E+04    0.22025E-43    0.25710E-51    0.97537E-50
+    5    3    0.75878E-07    0.10000E+01    0.49215E+04    0.14594E-42    0.40025E-50    0.58297E-49
+    5    3    0.75878E-07    0.10000E+01    0.39689E+04    0.11423E-41    0.88627E-49    0.33520E-48
+    5    3    0.75878E-07    0.10000E+01    0.32008E+04    0.38760E-39    0.77638E-46    0.70126E-46
+    5    3    0.75878E-07    0.10000E+01    0.25813E+04    0.27669E-30    0.13525E-36    0.37638E-37
+    5    3    0.75878E-07    0.10000E+01    0.20817E+04    0.55318E-14    0.11376E-19    0.72165E-21
+    5    3    0.75878E-07    0.10000E+01    0.16788E+04    0.18902E-08    0.16465E-13    0.22990E-15
+    5    3    0.75878E-07    0.10000E+01    0.13538E+04    0.38953E-08    0.62149E-13    0.40365E-15
+    5    3    0.75878E-07    0.10000E+01    0.10918E+04    0.79910E-08    0.23042E-12    0.73923E-15
+    5    3    0.75878E-07    0.10000E+01    0.88049E+03    0.16187E-07    0.84425E-12    0.13813E-14
+    5    3    0.75878E-07    0.10000E+01    0.71007E+03    0.32306E-07    0.30625E-11    0.25996E-14
+    5    3    0.75878E-07    0.10000E+01    0.57264E+03    0.63557E-07    0.10865E-10    0.48953E-14
+    5    3    0.75878E-07    0.10000E+01    0.46180E+03    0.12322E-06    0.36477E-10    0.91836E-14
+    5    3    0.75878E-07    0.10000E+01    0.37242E+03    0.23416E-06    0.11110E-09    0.17033E-13
+    5    3    0.75878E-07    0.10000E+01    0.30034E+03    0.43110E-06    0.29778E-09    0.30815E-13
+    5    3    0.75878E-07    0.10000E+01    0.24221E+03    0.75776E-06    0.69501E-09    0.53513E-13
+    5    3    0.75878E-07    0.10000E+01    0.19533E+03    0.11925E-05    0.13204E-08    0.83588E-13
+    5    3    0.75878E-07    0.10000E+01    0.15752E+03    0.11925E-05    0.13204E-08    0.83588E-13
+    5    3    0.13240E-06    0.10000E+01    0.80645E+05    0.21255E-53    0.15929E-64    0.15978E-59
+    5    3    0.13240E-06    0.10000E+01    0.65036E+05    0.18006E-52    0.25322E-63    0.13540E-58
+    5    3    0.13240E-06    0.10000E+01    0.52449E+05    0.15317E-51    0.34070E-62    0.11522E-57
+    5    3    0.13240E-06    0.10000E+01    0.42297E+05    0.11537E-50    0.46359E-61    0.86834E-57
+    5    3    0.13240E-06    0.10000E+01    0.34111E+05    0.83333E-50    0.63760E-60    0.62786E-56
+    5    3    0.13240E-06    0.10000E+01    0.27509E+05    0.59954E-49    0.86645E-59    0.45248E-55
+    5    3    0.13240E-06    0.10000E+01    0.22184E+05    0.42832E-48    0.11570E-57    0.32414E-54
+    5    3    0.13240E-06    0.10000E+01    0.17891E+05    0.30173E-47    0.15176E-56    0.22932E-53
+    5    3    0.13240E-06    0.10000E+01    0.14428E+05    0.20905E-46    0.19608E-55    0.15985E-52
+    5    3    0.13240E-06    0.10000E+01    0.11635E+05    0.14258E-45    0.24941E-54    0.10986E-51
+    5    3    0.13240E-06    0.10000E+01    0.93834E+04    0.95697E-45    0.30958E-53    0.74376E-51
+    5    3    0.13240E-06    0.10000E+01    0.75673E+04    0.62849E-44    0.37082E-52    0.49273E-50
+    5    3    0.13240E-06    0.10000E+01    0.61026E+04    0.40074E-43    0.43429E-51    0.31481E-49
+    5    3    0.13240E-06    0.10000E+01    0.49215E+04    0.25075E-42    0.56277E-50    0.19007E-48
+    5    3    0.13240E-06    0.10000E+01    0.39689E+04    0.16879E-41    0.10304E-48    0.10826E-47
+    5    3    0.13240E-06    0.10000E+01    0.32008E+04    0.47538E-39    0.84508E-46    0.20835E-45
+    5    3    0.13240E-06    0.10000E+01    0.25813E+04    0.31212E-30    0.14525E-36    0.99135E-37
+    5    3    0.13240E-06    0.10000E+01    0.20817E+04    0.61795E-14    0.11757E-19    0.18341E-20
+    5    3    0.13240E-06    0.10000E+01    0.16788E+04    0.20755E-08    0.16516E-13    0.56552E-15
+    5    3    0.13240E-06    0.10000E+01    0.13538E+04    0.41198E-08    0.61909E-13    0.92326E-15
+    5    3    0.13240E-06    0.10000E+01    0.10918E+04    0.82524E-08    0.22829E-12    0.15886E-14
+    5    3    0.13240E-06    0.10000E+01    0.88049E+03    0.16457E-07    0.83303E-12    0.28215E-14
+    5    3    0.13240E-06    0.10000E+01    0.71007E+03    0.32491E-07    0.30127E-11    0.50981E-14
+    5    3    0.13240E-06    0.10000E+01    0.57264E+03    0.63429E-07    0.10667E-10    0.92936E-14
+    5    3    0.13240E-06    0.10000E+01    0.46180E+03    0.12228E-06    0.35763E-10    0.16994E-13
+    5    3    0.13240E-06    0.10000E+01    0.37242E+03    0.23143E-06    0.10884E-09    0.30903E-13
+    5    3    0.13240E-06    0.10000E+01    0.30034E+03    0.42485E-06    0.29159E-09    0.55105E-13
+    5    3    0.13240E-06    0.10000E+01    0.24221E+03    0.74530E-06    0.68036E-09    0.94720E-13
+    5    3    0.13240E-06    0.10000E+01    0.19533E+03    0.11715E-05    0.12924E-08    0.14701E-12
+    5    3    0.13240E-06    0.10000E+01    0.15752E+03    0.11715E-05    0.12924E-08    0.14701E-12
+    5    3    0.23103E-06    0.10000E+01    0.80645E+05    0.38220E-53    0.28649E-64    0.49650E-59
+    5    3    0.23103E-06    0.10000E+01    0.65036E+05    0.32383E-52    0.45550E-63    0.42081E-58
+    5    3    0.23103E-06    0.10000E+01    0.52449E+05    0.27552E-51    0.61308E-62    0.35814E-57
+    5    3    0.23103E-06    0.10000E+01    0.42297E+05    0.20758E-50    0.83474E-61    0.26996E-56
+    5    3    0.23103E-06    0.10000E+01    0.34111E+05    0.15002E-49    0.11492E-59    0.19527E-55
+    5    3    0.23103E-06    0.10000E+01    0.27509E+05    0.10803E-48    0.15642E-58    0.14082E-54
+    5    3    0.23103E-06    0.10000E+01    0.22184E+05    0.77286E-48    0.20941E-57    0.10098E-53
+    5    3    0.23103E-06    0.10000E+01    0.17891E+05    0.54565E-47    0.27565E-56    0.71552E-53
+    5    3    0.23103E-06    0.10000E+01    0.14428E+05    0.37925E-46    0.35770E-55    0.49988E-52
+    5    3    0.23103E-06    0.10000E+01    0.11635E+05    0.25968E-45    0.45716E-54    0.34456E-51
+    5    3    0.23103E-06    0.10000E+01    0.93834E+04    0.17507E-44    0.57003E-53    0.23417E-50
+    5    3    0.23103E-06    0.10000E+01    0.75673E+04    0.11547E-43    0.68264E-52    0.15595E-49
+    5    3    0.23103E-06    0.10000E+01    0.61026E+04    0.73634E-43    0.77808E-51    0.10042E-48
+    5    3    0.23103E-06    0.10000E+01    0.49215E+04    0.45115E-42    0.89840E-50    0.61254E-48
+    5    3    0.23103E-06    0.10000E+01    0.39689E+04    0.27794E-41    0.13470E-48    0.34963E-47
+    5    3    0.23103E-06    0.10000E+01    0.32008E+04    0.65912E-39    0.98949E-46    0.64255E-45
+    5    3    0.23103E-06    0.10000E+01    0.25813E+04    0.38516E-30    0.16542E-36    0.27788E-36
+    5    3    0.23103E-06    0.10000E+01    0.20817E+04    0.74693E-14    0.12640E-19    0.49735E-20
+    5    3    0.23103E-06    0.10000E+01    0.16788E+04    0.24451E-08    0.16919E-13    0.14940E-14
+    5    3    0.23103E-06    0.10000E+01    0.13538E+04    0.45970E-08    0.62679E-13    0.22862E-14
+    5    3    0.23103E-06    0.10000E+01    0.10918E+04    0.88730E-08    0.22902E-12    0.36959E-14
+    5    3    0.23103E-06    0.10000E+01    0.88049E+03    0.17249E-07    0.82986E-12    0.62051E-14
+    5    3    0.23103E-06    0.10000E+01    0.71007E+03    0.33447E-07    0.29860E-11    0.10674E-13
+    5    3    0.23103E-06    0.10000E+01    0.57264E+03    0.64446E-07    0.10535E-10    0.18653E-13
+    5    3    0.23103E-06    0.10000E+01    0.46180E+03    0.12305E-06    0.35243E-10    0.32920E-13
+    5    3    0.23103E-06    0.10000E+01    0.37242E+03    0.23125E-06    0.10711E-09    0.58175E-13
+    5    3    0.23103E-06    0.10000E+01    0.30034E+03    0.42243E-06    0.28673E-09    0.10148E-12
+    5    3    0.23103E-06    0.10000E+01    0.24221E+03    0.73853E-06    0.66870E-09    0.17168E-12
+    5    3    0.23103E-06    0.10000E+01    0.19533E+03    0.11584E-05    0.12699E-08    0.26376E-12
+    5    3    0.23103E-06    0.10000E+01    0.15752E+03    0.11584E-05    0.12699E-08    0.26376E-12
+    5    3    0.40314E-06    0.10000E+01    0.80645E+05    0.68407E-53    0.51287E-64    0.15262E-58
+    5    3    0.40314E-06    0.10000E+01    0.65036E+05    0.57969E-52    0.81552E-63    0.12937E-57
+    5    3    0.40314E-06    0.10000E+01    0.52449E+05    0.49329E-51    0.10980E-61    0.11012E-56
+    5    3    0.40314E-06    0.10000E+01    0.42297E+05    0.37175E-50    0.14958E-60    0.83019E-56
+    5    3    0.40314E-06    0.10000E+01    0.34111E+05    0.26879E-49    0.20610E-59    0.60072E-55
+    5    3    0.40314E-06    0.10000E+01    0.27509E+05    0.19369E-48    0.28091E-58    0.43342E-54
+    5    3    0.40314E-06    0.10000E+01    0.22184E+05    0.13874E-47    0.37690E-57    0.31107E-53
+    5    3    0.40314E-06    0.10000E+01    0.17891E+05    0.98138E-47    0.49763E-56    0.22071E-52
+    5    3    0.40314E-06    0.10000E+01    0.14428E+05    0.68392E-46    0.64820E-55    0.15448E-51
+    5    3    0.40314E-06    0.10000E+01    0.11635E+05    0.46992E-45    0.83216E-54    0.10674E-50
+    5    3    0.40314E-06    0.10000E+01    0.93834E+04    0.31813E-44    0.10433E-52    0.72770E-50
+    5    3    0.40314E-06    0.10000E+01    0.75673E+04    0.21086E-43    0.12561E-51    0.48670E-49
+    5    3    0.40314E-06    0.10000E+01    0.61026E+04    0.13510E-42    0.14250E-50    0.31539E-48
+    5    3    0.40314E-06    0.10000E+01    0.49215E+04    0.82482E-42    0.15532E-49    0.19413E-47
+    5    3    0.40314E-06    0.10000E+01    0.39689E+04    0.48699E-41    0.19770E-48    0.11150E-46
+    5    3    0.40314E-06    0.10000E+01    0.32008E+04    0.10169E-38    0.12597E-45    0.20007E-44
+    5    3    0.40314E-06    0.10000E+01    0.25813E+04    0.52297E-30    0.20153E-36    0.80646E-36
+    5    3    0.40314E-06    0.10000E+01    0.20817E+04    0.98439E-14    0.14290E-19    0.14034E-19
+    5    3    0.40314E-06    0.10000E+01    0.16788E+04    0.31241E-08    0.17803E-13    0.41388E-14
+    5    3    0.40314E-06    0.10000E+01    0.13538E+04    0.54861E-08    0.64721E-13    0.60214E-14
+    5    3    0.40314E-06    0.10000E+01    0.10918E+04    0.10057E-07    0.23295E-12    0.92266E-14
+    5    3    0.40314E-06    0.10000E+01    0.88049E+03    0.18824E-07    0.83438E-12    0.14687E-13
+    5    3    0.40314E-06    0.10000E+01    0.71007E+03    0.35492E-07    0.29768E-11    0.24007E-13
+    5    3    0.40314E-06    0.10000E+01    0.57264E+03    0.66964E-07    0.10440E-10    0.39997E-13
+    5    3    0.40314E-06    0.10000E+01    0.46180E+03    0.12585E-06    0.34793E-10    0.67592E-13
+    5    3    0.40314E-06    0.10000E+01    0.37242E+03    0.23377E-06    0.10550E-09    0.11505E-12
+    5    3    0.40314E-06    0.10000E+01    0.30034E+03    0.42345E-06    0.28202E-09    0.19469E-12
+    5    3    0.40314E-06    0.10000E+01    0.24221E+03    0.73603E-06    0.65716E-09    0.32181E-12
+    5    3    0.40314E-06    0.10000E+01    0.19533E+03    0.11504E-05    0.12474E-08    0.48697E-12
+    5    3    0.40314E-06    0.10000E+01    0.15752E+03    0.11504E-05    0.12474E-08    0.48697E-12
+    5    3    0.70346E-06    0.10000E+01    0.80645E+05    0.12022E-52    0.90140E-64    0.32383E-58
+    5    3    0.70346E-06    0.10000E+01    0.65036E+05    0.10188E-51    0.14334E-62    0.27450E-57
+    5    3    0.70346E-06    0.10000E+01    0.52449E+05    0.86701E-51    0.19301E-61    0.23365E-56
+    5    3    0.70346E-06    0.10000E+01    0.42297E+05    0.65344E-50    0.26298E-60    0.17617E-55
+    5    3    0.70346E-06    0.10000E+01    0.34111E+05    0.47253E-49    0.36244E-59    0.12749E-54
+    5    3    0.70346E-06    0.10000E+01    0.27509E+05    0.34060E-48    0.49422E-58    0.91998E-54
+    5    3    0.70346E-06    0.10000E+01    0.22184E+05    0.24406E-47    0.66357E-57    0.66044E-53
+    5    3    0.70346E-06    0.10000E+01    0.17891E+05    0.17274E-46    0.87698E-56    0.46878E-52
+    5    3    0.70346E-06    0.10000E+01    0.14428E+05    0.12049E-45    0.11437E-54    0.32829E-51
+    5    3    0.70346E-06    0.10000E+01    0.11635E+05    0.82878E-45    0.14705E-53    0.22701E-50
+    5    3    0.70346E-06    0.10000E+01    0.93834E+04    0.56184E-44    0.18471E-52    0.15491E-49
+    5    3    0.70346E-06    0.10000E+01    0.75673E+04    0.37305E-43    0.22293E-51    0.10374E-48
+    5    3    0.70346E-06    0.10000E+01    0.61026E+04    0.23951E-42    0.25316E-50    0.67354E-48
+    5    3    0.70346E-06    0.10000E+01    0.49215E+04    0.14635E-41    0.27288E-49    0.41573E-47
+    5    3    0.70346E-06    0.10000E+01    0.39689E+04    0.85720E-41    0.33177E-48    0.23938E-46
+    5    3    0.70346E-06    0.10000E+01    0.32008E+04    0.17305E-38    0.20026E-45    0.42731E-44
+    5    3    0.70346E-06    0.10000E+01    0.25813E+04    0.85177E-30    0.31427E-36    0.16890E-35
+    5    3    0.70346E-06    0.10000E+01    0.20817E+04    0.15842E-13    0.21630E-19    0.29140E-19
+    5    3    0.70346E-06    0.10000E+01    0.16788E+04    0.49707E-08    0.26099E-13    0.85521E-14
+    5    3    0.70346E-06    0.10000E+01    0.13538E+04    0.85013E-08    0.94032E-13    0.12267E-13
+    5    3    0.70346E-06    0.10000E+01    0.10918E+04    0.15253E-07    0.33597E-12    0.18500E-13
+    5    3    0.70346E-06    0.10000E+01    0.88049E+03    0.28073E-07    0.11965E-11    0.28961E-13
+    5    3    0.70346E-06    0.10000E+01    0.71007E+03    0.52250E-07    0.42503E-11    0.46538E-13
+    5    3    0.70346E-06    0.10000E+01    0.57264E+03    0.97600E-07    0.14862E-10    0.76234E-13
+    5    3    0.70346E-06    0.10000E+01    0.46180E+03    0.18202E-06    0.49431E-10    0.12675E-12
+    5    3    0.70346E-06    0.10000E+01    0.37242E+03    0.33614E-06    0.14970E-09    0.21256E-12
+    5    3    0.70346E-06    0.10000E+01    0.30034E+03    0.60634E-06    0.39991E-09    0.35519E-12
+    5    3    0.70346E-06    0.10000E+01    0.24221E+03    0.10508E-05    0.93149E-09    0.58131E-12
+    5    3    0.70346E-06    0.10000E+01    0.19533E+03    0.16394E-05    0.17677E-08    0.87375E-12
+    5    3    0.70346E-06    0.10000E+01    0.15752E+03    0.16394E-05    0.17677E-08    0.87375E-12
+    5    3    0.12275E-05    0.10000E+01    0.80645E+05    0.20978E-52    0.15729E-63    0.56506E-58
+    5    3    0.12275E-05    0.10000E+01    0.65036E+05    0.17778E-51    0.25012E-62    0.47899E-57
+    5    3    0.12275E-05    0.10000E+01    0.52449E+05    0.15129E-50    0.33679E-61    0.40771E-56
+    5    3    0.12275E-05    0.10000E+01    0.42297E+05    0.11402E-49    0.45888E-60    0.30740E-55
+    5    3    0.12275E-05    0.10000E+01    0.34111E+05    0.82454E-49    0.63243E-59    0.22246E-54
+    5    3    0.12275E-05    0.10000E+01    0.27509E+05    0.59432E-48    0.86239E-58    0.16053E-53
+    5    3    0.12275E-05    0.10000E+01    0.22184E+05    0.42587E-47    0.11579E-56    0.11524E-52
+    5    3    0.12275E-05    0.10000E+01    0.17891E+05    0.30142E-46    0.15303E-55    0.81799E-52
+    5    3    0.12275E-05    0.10000E+01    0.14428E+05    0.21024E-45    0.19957E-54    0.57285E-51
+    5    3    0.12275E-05    0.10000E+01    0.11635E+05    0.14462E-44    0.25660E-53    0.39611E-50
+    5    3    0.12275E-05    0.10000E+01    0.93834E+04    0.98038E-44    0.32231E-52    0.27031E-49
+    5    3    0.12275E-05    0.10000E+01    0.75673E+04    0.65095E-43    0.38899E-51    0.18102E-48
+    5    3    0.12275E-05    0.10000E+01    0.61026E+04    0.41793E-42    0.44175E-50    0.11753E-47
+    5    3    0.12275E-05    0.10000E+01    0.49215E+04    0.25537E-41    0.47616E-49    0.72543E-47
+    5    3    0.12275E-05    0.10000E+01    0.39689E+04    0.14958E-40    0.57892E-48    0.41771E-46
+    5    3    0.12275E-05    0.10000E+01    0.32008E+04    0.30195E-38    0.34944E-45    0.74564E-44
+    5    3    0.12275E-05    0.10000E+01    0.25813E+04    0.14863E-29    0.54838E-36    0.29472E-35
+    5    3    0.12275E-05    0.10000E+01    0.20817E+04    0.27643E-13    0.37743E-19    0.50848E-19
+    5    3    0.12275E-05    0.10000E+01    0.16788E+04    0.86736E-08    0.45541E-13    0.14923E-13
+    5    3    0.12275E-05    0.10000E+01    0.13538E+04    0.14834E-07    0.16408E-12    0.21405E-13
+    5    3    0.12275E-05    0.10000E+01    0.10918E+04    0.26615E-07    0.58625E-12    0.32282E-13
+    5    3    0.12275E-05    0.10000E+01    0.88049E+03    0.48986E-07    0.20878E-11    0.50535E-13
+    5    3    0.12275E-05    0.10000E+01    0.71007E+03    0.91173E-07    0.74165E-11    0.81207E-13
+    5    3    0.12275E-05    0.10000E+01    0.57264E+03    0.17031E-06    0.25934E-10    0.13302E-12
+    5    3    0.12275E-05    0.10000E+01    0.46180E+03    0.31761E-06    0.86255E-10    0.22117E-12
+    5    3    0.12275E-05    0.10000E+01    0.37242E+03    0.58655E-06    0.26122E-09    0.37091E-12
+    5    3    0.12275E-05    0.10000E+01    0.30034E+03    0.10580E-05    0.69782E-09    0.61978E-12
+    5    3    0.12275E-05    0.10000E+01    0.24221E+03    0.18336E-05    0.16254E-08    0.10143E-11
+    5    3    0.12275E-05    0.10000E+01    0.19533E+03    0.28606E-05    0.30845E-08    0.15246E-11
+    5    3    0.12275E-05    0.10000E+01    0.15752E+03    0.28606E-05    0.30845E-08    0.15246E-11
+    5    3    0.21419E-05    0.10000E+01    0.80645E+05    0.36605E-52    0.27446E-63    0.98600E-58
+    5    3    0.21419E-05    0.10000E+01    0.65036E+05    0.31021E-51    0.43644E-62    0.83582E-57
+    5    3    0.21419E-05    0.10000E+01    0.52449E+05    0.26399E-50    0.58768E-61    0.71143E-56
+    5    3    0.21419E-05    0.10000E+01    0.42297E+05    0.19896E-49    0.80072E-60    0.53640E-55
+    5    3    0.21419E-05    0.10000E+01    0.34111E+05    0.14388E-48    0.11036E-58    0.38817E-54
+    5    3    0.21419E-05    0.10000E+01    0.27509E+05    0.10371E-47    0.15048E-57    0.28012E-53
+    5    3    0.21419E-05    0.10000E+01    0.22184E+05    0.74312E-47    0.20204E-56    0.20109E-52
+    5    3    0.21419E-05    0.10000E+01    0.17891E+05    0.52597E-46    0.26702E-55    0.14273E-51
+    5    3    0.21419E-05    0.10000E+01    0.14428E+05    0.36686E-45    0.34824E-54    0.99959E-51
+    5    3    0.21419E-05    0.10000E+01    0.11635E+05    0.25235E-44    0.44774E-53    0.69119E-50
+    5    3    0.21419E-05    0.10000E+01    0.93834E+04    0.17107E-43    0.56242E-52    0.47167E-49
+    5    3    0.21419E-05    0.10000E+01    0.75673E+04    0.11359E-42    0.67877E-51    0.31587E-48
+    5    3    0.21419E-05    0.10000E+01    0.61026E+04    0.72926E-42    0.77082E-50    0.20508E-47
+    5    3    0.21419E-05    0.10000E+01    0.49215E+04    0.44561E-41    0.83088E-49    0.12658E-46
+    5    3    0.21419E-05    0.10000E+01    0.39689E+04    0.26100E-40    0.10102E-47    0.72888E-46
+    5    3    0.21419E-05    0.10000E+01    0.32008E+04    0.52689E-38    0.60975E-45    0.13011E-43
+    5    3    0.21419E-05    0.10000E+01    0.25813E+04    0.25935E-29    0.95688E-36    0.51426E-35
+    5    3    0.21419E-05    0.10000E+01    0.20817E+04    0.48235E-13    0.65858E-19    0.88727E-19
+    5    3    0.21419E-05    0.10000E+01    0.16788E+04    0.15135E-07    0.79466E-13    0.26040E-13
+    5    3    0.21419E-05    0.10000E+01    0.13538E+04    0.25885E-07    0.28631E-12    0.37351E-13
+    5    3    0.21419E-05    0.10000E+01    0.10918E+04    0.46442E-07    0.10230E-11    0.56330E-13
+    5    3    0.21419E-05    0.10000E+01    0.88049E+03    0.85478E-07    0.36431E-11    0.88181E-13
+    5    3    0.21419E-05    0.10000E+01    0.71007E+03    0.15909E-06    0.12941E-10    0.14170E-12
+    5    3    0.21419E-05    0.10000E+01    0.57264E+03    0.29717E-06    0.45253E-10    0.23212E-12
+    5    3    0.21419E-05    0.10000E+01    0.46180E+03    0.55421E-06    0.15051E-09    0.38593E-12
+    5    3    0.21419E-05    0.10000E+01    0.37242E+03    0.10235E-05    0.45582E-09    0.64722E-12
+    5    3    0.21419E-05    0.10000E+01    0.30034E+03    0.18462E-05    0.12177E-08    0.10815E-11
+    5    3    0.21419E-05    0.10000E+01    0.24221E+03    0.31995E-05    0.28362E-08    0.17700E-11
+    5    3    0.21419E-05    0.10000E+01    0.19533E+03    0.49916E-05    0.53823E-08    0.26604E-11
+    5    3    0.21419E-05    0.10000E+01    0.15752E+03    0.49916E-05    0.53823E-08    0.26604E-11
+    5    3    0.37375E-05    0.10000E+01    0.80645E+05    0.63873E-52    0.47891E-63    0.17205E-57
+    5    3    0.37375E-05    0.10000E+01    0.65036E+05    0.54130E-51    0.76156E-62    0.14584E-56
+    5    3    0.37375E-05    0.10000E+01    0.52449E+05    0.46064E-50    0.10255E-60    0.12414E-55
+    5    3    0.37375E-05    0.10000E+01    0.42297E+05    0.34717E-49    0.13972E-59    0.93599E-55
+    5    3    0.37375E-05    0.10000E+01    0.34111E+05    0.25106E-48    0.19256E-58    0.67734E-54
+    5    3    0.37375E-05    0.10000E+01    0.27509E+05    0.18096E-47    0.26258E-57    0.48879E-53
+    5    3    0.37375E-05    0.10000E+01    0.22184E+05    0.12967E-46    0.35255E-56    0.35089E-52
+    5    3    0.37375E-05    0.10000E+01    0.17891E+05    0.91778E-46    0.46594E-55    0.24906E-51
+    5    3    0.37375E-05    0.10000E+01    0.14428E+05    0.64015E-45    0.60766E-54    0.17442E-50
+    5    3    0.37375E-05    0.10000E+01    0.11635E+05    0.44033E-44    0.78129E-53    0.12061E-49
+    5    3    0.37375E-05    0.10000E+01    0.93834E+04    0.29851E-43    0.98138E-52    0.82304E-49
+    5    3    0.37375E-05    0.10000E+01    0.75673E+04    0.19820E-42    0.11844E-50    0.55118E-48
+    5    3    0.37375E-05    0.10000E+01    0.61026E+04    0.12725E-41    0.13450E-49    0.35785E-47
+    5    3    0.37375E-05    0.10000E+01    0.49215E+04    0.77756E-41    0.14498E-48    0.22088E-46
+    5    3    0.37375E-05    0.10000E+01    0.39689E+04    0.45543E-40    0.17627E-47    0.12718E-45
+    5    3    0.37375E-05    0.10000E+01    0.32008E+04    0.91940E-38    0.10640E-44    0.22703E-43
+    5    3    0.37375E-05    0.10000E+01    0.25813E+04    0.45255E-29    0.16697E-35    0.89736E-35
+    5    3    0.37375E-05    0.10000E+01    0.20817E+04    0.84167E-13    0.11492E-18    0.15482E-18
+    5    3    0.37375E-05    0.10000E+01    0.16788E+04    0.26409E-07    0.13866E-12    0.45438E-13
+    5    3    0.37375E-05    0.10000E+01    0.13538E+04    0.45167E-07    0.49959E-12    0.65175E-13
+    5    3    0.37375E-05    0.10000E+01    0.10918E+04    0.81039E-07    0.17850E-11    0.98293E-13
+    5    3    0.37375E-05    0.10000E+01    0.88049E+03    0.14915E-06    0.63569E-11    0.15387E-12
+    5    3    0.37375E-05    0.10000E+01    0.71007E+03    0.27761E-06    0.22582E-10    0.24726E-12
+    5    3    0.37375E-05    0.10000E+01    0.57264E+03    0.51855E-06    0.78963E-10    0.40503E-12
+    5    3    0.37375E-05    0.10000E+01    0.46180E+03    0.96705E-06    0.26263E-09    0.67342E-12
+    5    3    0.37375E-05    0.10000E+01    0.37242E+03    0.17859E-05    0.79538E-09    0.11294E-11
+    5    3    0.37375E-05    0.10000E+01    0.30034E+03    0.32215E-05    0.21247E-08    0.18871E-11
+    5    3    0.37375E-05    0.10000E+01    0.24221E+03    0.55830E-05    0.49490E-08    0.30885E-11
+    5    3    0.37375E-05    0.10000E+01    0.19533E+03    0.87100E-05    0.93918E-08    0.46423E-11
+    5    3    0.37375E-05    0.10000E+01    0.15752E+03    0.87100E-05    0.93918E-08    0.46423E-11
+    5    3    0.65217E-05    0.10000E+01    0.80645E+05    0.11146E-51    0.83568E-63    0.30022E-57
+    5    3    0.65217E-05    0.10000E+01    0.65036E+05    0.94454E-51    0.13289E-61    0.25449E-56
+    5    3    0.65217E-05    0.10000E+01    0.52449E+05    0.80380E-50    0.17894E-60    0.21662E-55
+    5    3    0.65217E-05    0.10000E+01    0.42297E+05    0.60580E-49    0.24380E-59    0.16332E-54
+    5    3    0.65217E-05    0.10000E+01    0.34111E+05    0.43808E-48    0.33601E-58    0.11819E-53
+    5    3    0.65217E-05    0.10000E+01    0.27509E+05    0.31576E-47    0.45819E-57    0.85290E-53
+    5    3    0.65217E-05    0.10000E+01    0.22184E+05    0.22627E-46    0.61518E-56    0.61229E-52
+    5    3    0.65217E-05    0.10000E+01    0.17891E+05    0.16015E-45    0.81303E-55    0.43460E-51
+    5    3    0.65217E-05    0.10000E+01    0.14428E+05    0.11170E-44    0.10603E-53    0.30436E-50
+    5    3    0.65217E-05    0.10000E+01    0.11635E+05    0.76835E-44    0.13633E-52    0.21046E-49
+    5    3    0.65217E-05    0.10000E+01    0.93834E+04    0.52088E-43    0.17125E-51    0.14362E-48
+    5    3    0.65217E-05    0.10000E+01    0.75673E+04    0.34585E-42    0.20667E-50    0.96177E-48
+    5    3    0.65217E-05    0.10000E+01    0.61026E+04    0.22205E-41    0.23470E-49    0.62443E-47
+    5    3    0.65217E-05    0.10000E+01    0.49215E+04    0.13568E-40    0.25299E-48    0.38542E-46
+    5    3    0.65217E-05    0.10000E+01    0.39689E+04    0.79470E-40    0.30758E-47    0.22193E-45
+    5    3    0.65217E-05    0.10000E+01    0.32008E+04    0.16043E-37    0.18566E-44    0.39616E-43
+    5    3    0.65217E-05    0.10000E+01    0.25813E+04    0.78967E-29    0.29135E-35    0.15658E-34
+    5    3    0.65217E-05    0.10000E+01    0.20817E+04    0.14687E-12    0.20053E-18    0.27016E-18
+    5    3    0.65217E-05    0.10000E+01    0.16788E+04    0.46083E-07    0.24196E-12    0.79286E-13
+    5    3    0.65217E-05    0.10000E+01    0.13538E+04    0.78814E-07    0.87176E-12    0.11373E-12
+    5    3    0.65217E-05    0.10000E+01    0.10918E+04    0.14141E-06    0.31148E-11    0.17152E-12
+    5    3    0.65217E-05    0.10000E+01    0.88049E+03    0.26026E-06    0.11092E-10    0.26850E-12
+    5    3    0.65217E-05    0.10000E+01    0.71007E+03    0.48441E-06    0.39404E-10    0.43145E-12
+    5    3    0.65217E-05    0.10000E+01    0.57264E+03    0.90484E-06    0.13779E-09    0.70676E-12
+    5    3    0.65217E-05    0.10000E+01    0.46180E+03    0.16875E-05    0.45827E-09    0.11751E-11
+    5    3    0.65217E-05    0.10000E+01    0.37242E+03    0.31163E-05    0.13879E-08    0.19707E-11
+    5    3    0.65217E-05    0.10000E+01    0.30034E+03    0.56213E-05    0.37075E-08    0.32929E-11
+    5    3    0.65217E-05    0.10000E+01    0.24221E+03    0.97420E-05    0.86357E-08    0.53892E-11
+    5    3    0.65217E-05    0.10000E+01    0.19533E+03    0.15198E-04    0.16388E-07    0.81005E-11
+    5    3    0.65217E-05    0.10000E+01    0.15752E+03    0.15198E-04    0.16388E-07    0.81005E-11
+    5    3    0.11380E-04    0.10000E+01    0.80645E+05    0.19448E-51    0.14582E-62    0.52387E-57
+    5    3    0.11380E-04    0.10000E+01    0.65036E+05    0.16482E-50    0.23188E-61    0.44407E-56
+    5    3    0.11380E-04    0.10000E+01    0.52449E+05    0.14026E-49    0.31223E-60    0.37798E-55
+    5    3    0.11380E-04    0.10000E+01    0.42297E+05    0.10571E-48    0.42542E-59    0.28499E-54
+    5    3    0.11380E-04    0.10000E+01    0.34111E+05    0.76442E-48    0.58632E-58    0.20624E-53
+    5    3    0.11380E-04    0.10000E+01    0.27509E+05    0.55099E-47    0.79951E-57    0.14883E-52
+    5    3    0.11380E-04    0.10000E+01    0.22184E+05    0.39482E-46    0.10735E-55    0.10684E-51
+    5    3    0.11380E-04    0.10000E+01    0.17891E+05    0.27945E-45    0.14187E-54    0.75835E-51
+    5    3    0.11380E-04    0.10000E+01    0.14428E+05    0.19491E-44    0.18502E-53    0.53108E-50
+    5    3    0.11380E-04    0.10000E+01    0.11635E+05    0.13407E-43    0.23789E-52    0.36723E-49
+    5    3    0.11380E-04    0.10000E+01    0.93834E+04    0.90890E-43    0.29881E-51    0.25060E-48
+    5    3    0.11380E-04    0.10000E+01    0.75673E+04    0.60349E-42    0.36063E-50    0.16782E-47
+    5    3    0.11380E-04    0.10000E+01    0.61026E+04    0.38746E-41    0.40954E-49    0.10896E-46
+    5    3    0.11380E-04    0.10000E+01    0.49215E+04    0.23675E-40    0.44145E-48    0.67254E-46
+    5    3    0.11380E-04    0.10000E+01    0.39689E+04    0.13867E-39    0.53671E-47    0.38725E-45
+    5    3    0.11380E-04    0.10000E+01    0.32008E+04    0.27994E-37    0.32396E-44    0.69127E-43
+    5    3    0.11380E-04    0.10000E+01    0.25813E+04    0.13779E-28    0.50839E-35    0.27323E-34
+    5    3    0.11380E-04    0.10000E+01    0.20817E+04    0.25627E-12    0.34991E-18    0.47141E-18
+    5    3    0.11380E-04    0.10000E+01    0.16788E+04    0.80412E-07    0.42220E-12    0.13835E-12
+    5    3    0.11380E-04    0.10000E+01    0.13538E+04    0.13753E-06    0.15212E-11    0.19844E-12
+    5    3    0.11380E-04    0.10000E+01    0.10918E+04    0.24675E-06    0.54351E-11    0.29928E-12
+    5    3    0.11380E-04    0.10000E+01    0.88049E+03    0.45414E-06    0.19356E-10    0.46851E-12
+    5    3    0.11380E-04    0.10000E+01    0.71007E+03    0.84526E-06    0.68758E-10    0.75286E-12
+    5    3    0.11380E-04    0.10000E+01    0.57264E+03    0.15789E-05    0.24043E-09    0.12332E-11
+    5    3    0.11380E-04    0.10000E+01    0.46180E+03    0.29445E-05    0.79966E-09    0.20505E-11
+    5    3    0.11380E-04    0.10000E+01    0.37242E+03    0.54378E-05    0.24218E-08    0.34387E-11
+    5    3    0.11380E-04    0.10000E+01    0.30034E+03    0.98088E-05    0.64694E-08    0.57459E-11
+    5    3    0.11380E-04    0.10000E+01    0.24221E+03    0.16999E-04    0.15069E-07    0.94039E-11
+    5    3    0.11380E-04    0.10000E+01    0.19533E+03    0.26520E-04    0.28596E-07    0.14135E-10
+    5    3    0.11380E-04    0.10000E+01    0.15752E+03    0.26520E-04    0.28596E-07    0.14135E-10
+    5    3    0.19857E-04    0.10000E+01    0.80645E+05    0.33936E-51    0.25445E-62    0.91411E-57
+    5    3    0.19857E-04    0.10000E+01    0.65036E+05    0.28760E-50    0.40462E-61    0.77488E-56
+    5    3    0.19857E-04    0.10000E+01    0.52449E+05    0.24474E-49    0.54483E-60    0.65956E-55
+    5    3    0.19857E-04    0.10000E+01    0.42297E+05    0.18445E-48    0.74234E-59    0.49729E-54
+    5    3    0.19857E-04    0.10000E+01    0.34111E+05    0.13339E-47    0.10231E-57    0.35987E-53
+    5    3    0.19857E-04    0.10000E+01    0.27509E+05    0.96144E-47    0.13951E-56    0.25969E-52
+    5    3    0.19857E-04    0.10000E+01    0.22184E+05    0.68894E-46    0.18731E-55    0.18643E-51
+    5    3    0.19857E-04    0.10000E+01    0.17891E+05    0.48762E-45    0.24755E-54    0.13233E-50
+    5    3    0.19857E-04    0.10000E+01    0.14428E+05    0.34011E-44    0.32285E-53    0.92671E-50
+    5    3    0.19857E-04    0.10000E+01    0.11635E+05    0.23395E-43    0.41510E-52    0.64080E-49
+    5    3    0.19857E-04    0.10000E+01    0.93834E+04    0.15860E-42    0.52141E-51    0.43728E-48
+    5    3    0.19857E-04    0.10000E+01    0.75673E+04    0.10531E-41    0.62928E-50    0.29284E-47
+    5    3    0.19857E-04    0.10000E+01    0.61026E+04    0.67609E-41    0.71462E-49    0.19013E-46
+    5    3    0.19857E-04    0.10000E+01    0.49215E+04    0.41312E-40    0.77030E-48    0.11735E-45
+    5    3    0.19857E-04    0.10000E+01    0.39689E+04    0.24197E-39    0.93652E-47    0.67573E-45
+    5    3    0.19857E-04    0.10000E+01    0.32008E+04    0.48848E-37    0.56530E-44    0.12062E-42
+    5    3    0.19857E-04    0.10000E+01    0.25813E+04    0.24044E-28    0.88711E-35    0.47677E-34
+    5    3    0.19857E-04    0.10000E+01    0.20817E+04    0.44718E-12    0.61057E-18    0.82258E-18
+    5    3    0.19857E-04    0.10000E+01    0.16788E+04    0.14031E-06    0.73672E-12    0.24141E-12
+    5    3    0.19857E-04    0.10000E+01    0.13538E+04    0.23998E-06    0.26544E-11    0.34627E-12
+    5    3    0.19857E-04    0.10000E+01    0.10918E+04    0.43056E-06    0.94839E-11    0.52223E-12
+    5    3    0.19857E-04    0.10000E+01    0.88049E+03    0.79245E-06    0.33775E-10    0.81752E-12
+    5    3    0.19857E-04    0.10000E+01    0.71007E+03    0.14749E-05    0.11998E-09    0.13137E-11
+    5    3    0.19857E-04    0.10000E+01    0.57264E+03    0.27551E-05    0.41953E-09    0.21519E-11
+    5    3    0.19857E-04    0.10000E+01    0.46180E+03    0.51380E-05    0.13954E-08    0.35779E-11
+    5    3    0.19857E-04    0.10000E+01    0.37242E+03    0.94887E-05    0.42259E-08    0.60003E-11
+    5    3    0.19857E-04    0.10000E+01    0.30034E+03    0.17116E-04    0.11289E-07    0.10026E-10
+    5    3    0.19857E-04    0.10000E+01    0.24221E+03    0.29663E-04    0.26294E-07    0.16409E-10
+    5    3    0.19857E-04    0.10000E+01    0.19533E+03    0.46277E-04    0.49899E-07    0.24664E-10
+    5    3    0.19857E-04    0.10000E+01    0.15752E+03    0.46277E-04    0.49899E-07    0.24664E-10
+    5    3    0.34650E-04    0.10000E+01    0.80645E+05    0.59216E-51    0.44400E-62    0.15951E-56
+    5    3    0.34650E-04    0.10000E+01    0.65036E+05    0.50184E-50    0.70603E-61    0.13521E-55
+    5    3    0.34650E-04    0.10000E+01    0.52449E+05    0.42706E-49    0.95069E-60    0.11509E-54
+    5    3    0.34650E-04    0.10000E+01    0.42297E+05    0.32186E-48    0.12953E-58    0.86775E-54
+    5    3    0.34650E-04    0.10000E+01    0.34111E+05    0.23275E-47    0.17852E-57    0.62795E-53
+    5    3    0.34650E-04    0.10000E+01    0.27509E+05    0.16777E-46    0.24344E-56    0.45315E-52
+    5    3    0.34650E-04    0.10000E+01    0.22184E+05    0.12022E-45    0.32685E-55    0.32531E-51
+    5    3    0.34650E-04    0.10000E+01    0.17891E+05    0.85086E-45    0.43197E-54    0.23090E-50
+    5    3    0.34650E-04    0.10000E+01    0.14428E+05    0.59347E-44    0.56335E-53    0.16171E-49
+    5    3    0.34650E-04    0.10000E+01    0.11635E+05    0.40823E-43    0.72432E-52    0.11182E-48
+    5    3    0.34650E-04    0.10000E+01    0.93834E+04    0.27674E-42    0.90983E-51    0.76303E-48
+    5    3    0.34650E-04    0.10000E+01    0.75673E+04    0.18375E-41    0.10981E-49    0.51099E-47
+    5    3    0.34650E-04    0.10000E+01    0.61026E+04    0.11797E-40    0.12470E-48    0.33176E-46
+    5    3    0.34650E-04    0.10000E+01    0.49215E+04    0.72087E-40    0.13441E-47    0.20478E-45
+    5    3    0.34650E-04    0.10000E+01    0.39689E+04    0.42222E-39    0.16342E-46    0.11791E-44
+    5    3    0.34650E-04    0.10000E+01    0.32008E+04    0.85236E-37    0.98641E-44    0.21048E-42
+    5    3    0.34650E-04    0.10000E+01    0.25813E+04    0.41955E-28    0.15480E-34    0.83193E-34
+    5    3    0.34650E-04    0.10000E+01    0.20817E+04    0.78030E-12    0.10654E-17    0.14354E-17
+    5    3    0.34650E-04    0.10000E+01    0.16788E+04    0.24484E-06    0.12855E-11    0.42125E-12
+    5    3    0.34650E-04    0.10000E+01    0.13538E+04    0.41874E-06    0.46317E-11    0.60423E-12
+    5    3    0.34650E-04    0.10000E+01    0.10918E+04    0.75130E-06    0.16549E-10    0.91126E-12
+    5    3    0.34650E-04    0.10000E+01    0.88049E+03    0.13828E-05    0.58934E-10    0.14265E-11
+    5    3    0.34650E-04    0.10000E+01    0.71007E+03    0.25737E-05    0.20935E-09    0.22923E-11
+    5    3    0.34650E-04    0.10000E+01    0.57264E+03    0.48074E-05    0.73206E-09    0.37550E-11
+    5    3    0.34650E-04    0.10000E+01    0.46180E+03    0.89655E-05    0.24348E-08    0.62432E-11
+    5    3    0.34650E-04    0.10000E+01    0.37242E+03    0.16557E-04    0.73739E-08    0.10470E-10
+    5    3    0.34650E-04    0.10000E+01    0.30034E+03    0.29866E-04    0.19698E-07    0.17495E-10
+    5    3    0.34650E-04    0.10000E+01    0.24221E+03    0.51759E-04    0.45882E-07    0.28633E-10
+    5    3    0.34650E-04    0.10000E+01    0.19533E+03    0.80750E-04    0.87070E-07    0.43038E-10
+    5    3    0.34650E-04    0.10000E+01    0.15752E+03    0.80750E-04    0.87070E-07    0.43038E-10
+    5    3    0.60462E-04    0.10000E+01    0.80645E+05    0.10333E-50    0.77475E-62    0.27833E-56
+    5    3    0.60462E-04    0.10000E+01    0.65036E+05    0.87567E-50    0.12320E-60    0.23594E-55
+    5    3    0.60462E-04    0.10000E+01    0.52449E+05    0.74519E-49    0.16589E-59    0.20082E-54
+    5    3    0.60462E-04    0.10000E+01    0.42297E+05    0.56163E-48    0.22603E-58    0.15142E-53
+    5    3    0.60462E-04    0.10000E+01    0.34111E+05    0.40614E-47    0.31151E-57    0.10957E-52
+    5    3    0.60462E-04    0.10000E+01    0.27509E+05    0.29274E-46    0.42478E-56    0.79072E-52
+    5    3    0.60462E-04    0.10000E+01    0.22184E+05    0.20977E-45    0.57033E-55    0.56765E-51
+    5    3    0.60462E-04    0.10000E+01    0.17891E+05    0.14847E-44    0.75376E-54    0.40291E-50
+    5    3    0.60462E-04    0.10000E+01    0.14428E+05    0.10356E-43    0.98302E-53    0.28217E-49
+    5    3    0.60462E-04    0.10000E+01    0.11635E+05    0.71233E-43    0.12639E-51    0.19511E-48
+    5    3    0.60462E-04    0.10000E+01    0.93834E+04    0.48290E-42    0.15876E-50    0.13314E-47
+    5    3    0.60462E-04    0.10000E+01    0.75673E+04    0.32064E-41    0.19160E-49    0.89165E-47
+    5    3    0.60462E-04    0.10000E+01    0.61026E+04    0.20586E-40    0.21759E-48    0.57890E-46
+    5    3    0.60462E-04    0.10000E+01    0.49215E+04    0.12579E-39    0.23454E-47    0.35732E-45
+    5    3    0.60462E-04    0.10000E+01    0.39689E+04    0.73675E-39    0.28515E-46    0.20575E-44
+    5    3    0.60462E-04    0.10000E+01    0.32008E+04    0.14873E-36    0.17212E-43    0.36727E-42
+    5    3    0.60462E-04    0.10000E+01    0.25813E+04    0.73209E-28    0.27011E-34    0.14517E-33
+    5    3    0.60462E-04    0.10000E+01    0.20817E+04    0.13616E-11    0.18591E-17    0.25046E-17
+    5    3    0.60462E-04    0.10000E+01    0.16788E+04    0.42723E-06    0.22432E-11    0.73505E-12
+    5    3    0.60462E-04    0.10000E+01    0.13538E+04    0.73068E-06    0.80820E-11    0.10543E-11
+    5    3    0.60462E-04    0.10000E+01    0.10918E+04    0.13110E-05    0.28877E-10    0.15901E-11
+    5    3    0.60462E-04    0.10000E+01    0.88049E+03    0.24129E-05    0.10284E-09    0.24892E-11
+    5    3    0.60462E-04    0.10000E+01    0.71007E+03    0.44909E-05    0.36531E-09    0.39999E-11
+    5    3    0.60462E-04    0.10000E+01    0.57264E+03    0.83887E-05    0.12774E-08    0.65523E-11
+    5    3    0.60462E-04    0.10000E+01    0.46180E+03    0.15644E-04    0.42486E-08    0.10894E-10
+    5    3    0.60462E-04    0.10000E+01    0.37242E+03    0.28891E-04    0.12867E-07    0.18270E-10
+    5    3    0.60462E-04    0.10000E+01    0.30034E+03    0.52114E-04    0.34372E-07    0.30528E-10
+    5    3    0.60462E-04    0.10000E+01    0.24221E+03    0.90317E-04    0.80061E-07    0.49963E-10
+    5    3    0.60462E-04    0.10000E+01    0.19533E+03    0.14090E-03    0.15193E-06    0.75099E-10
+    5    3    0.60462E-04    0.10000E+01    0.15752E+03    0.14090E-03    0.15193E-06    0.75099E-10
+    5    3    0.10550E-03    0.10000E+01    0.80645E+05    0.18030E-50    0.13519E-61    0.48567E-56
+    5    3    0.10550E-03    0.10000E+01    0.65036E+05    0.15280E-49    0.21497E-60    0.41169E-55
+    5    3    0.10550E-03    0.10000E+01    0.52449E+05    0.13003E-48    0.28947E-59    0.35042E-54
+    5    3    0.10550E-03    0.10000E+01    0.42297E+05    0.98001E-48    0.39441E-58    0.26421E-53
+    5    3    0.10550E-03    0.10000E+01    0.34111E+05    0.70869E-47    0.54357E-57    0.19120E-52
+    5    3    0.10550E-03    0.10000E+01    0.27509E+05    0.51082E-46    0.74122E-56    0.13798E-51
+    5    3    0.10550E-03    0.10000E+01    0.22184E+05    0.36604E-45    0.99519E-55    0.99051E-51
+    5    3    0.10550E-03    0.10000E+01    0.17891E+05    0.25907E-44    0.13153E-53    0.70305E-50
+    5    3    0.10550E-03    0.10000E+01    0.14428E+05    0.18070E-43    0.17153E-52    0.49236E-49
+    5    3    0.10550E-03    0.10000E+01    0.11635E+05    0.12430E-42    0.22054E-51    0.34046E-48
+    5    3    0.10550E-03    0.10000E+01    0.93834E+04    0.84263E-42    0.27703E-50    0.23233E-47
+    5    3    0.10550E-03    0.10000E+01    0.75673E+04    0.55949E-41    0.33434E-49    0.15559E-46
+    5    3    0.10550E-03    0.10000E+01    0.61026E+04    0.35921E-40    0.37968E-48    0.10102E-45
+    5    3    0.10550E-03    0.10000E+01    0.49215E+04    0.21949E-39    0.40926E-47    0.62350E-45
+    5    3    0.10550E-03    0.10000E+01    0.39689E+04    0.12856E-38    0.49758E-46    0.35902E-44
+    5    3    0.10550E-03    0.10000E+01    0.32008E+04    0.25953E-36    0.30034E-43    0.64087E-42
+    5    3    0.10550E-03    0.10000E+01    0.25813E+04    0.12775E-27    0.47133E-34    0.25331E-33
+    5    3    0.10550E-03    0.10000E+01    0.20817E+04    0.23759E-11    0.32440E-17    0.43704E-17
+    5    3    0.10550E-03    0.10000E+01    0.16788E+04    0.74549E-06    0.39142E-11    0.12826E-11
+    5    3    0.10550E-03    0.10000E+01    0.13538E+04    0.12750E-05    0.14103E-10    0.18398E-11
+    5    3    0.10550E-03    0.10000E+01    0.10918E+04    0.22876E-05    0.50388E-10    0.27746E-11
+    5    3    0.10550E-03    0.10000E+01    0.88049E+03    0.42103E-05    0.17944E-09    0.43435E-11
+    5    3    0.10550E-03    0.10000E+01    0.71007E+03    0.78363E-05    0.63744E-09    0.69797E-11
+    5    3    0.10550E-03    0.10000E+01    0.57264E+03    0.14638E-04    0.22290E-08    0.11433E-10
+    5    3    0.10550E-03    0.10000E+01    0.46180E+03    0.27298E-04    0.74135E-08    0.19010E-10
+    5    3    0.10550E-03    0.10000E+01    0.37242E+03    0.50413E-04    0.22452E-07    0.31880E-10
+    5    3    0.10550E-03    0.10000E+01    0.30034E+03    0.90936E-04    0.59977E-07    0.53270E-10
+    5    3    0.10550E-03    0.10000E+01    0.24221E+03    0.15760E-03    0.13970E-06    0.87182E-10
+    5    3    0.10550E-03    0.10000E+01    0.19533E+03    0.24587E-03    0.26511E-06    0.13104E-09
+    5    3    0.10550E-03    0.10000E+01    0.15752E+03    0.24587E-03    0.26511E-06    0.13104E-09
+    5    3    0.18409E-03    0.10000E+01    0.80645E+05    0.31462E-50    0.23590E-61    0.84746E-56
+    5    3    0.18409E-03    0.10000E+01    0.65036E+05    0.26663E-49    0.37512E-60    0.71838E-55
+    5    3    0.18409E-03    0.10000E+01    0.52449E+05    0.22690E-48    0.50510E-59    0.61147E-54
+    5    3    0.18409E-03    0.10000E+01    0.42297E+05    0.17101E-47    0.68821E-58    0.46103E-53
+    5    3    0.18409E-03    0.10000E+01    0.34111E+05    0.12366E-46    0.94850E-57    0.33363E-52
+    5    3    0.18409E-03    0.10000E+01    0.27509E+05    0.89134E-46    0.12934E-55    0.24076E-51
+    5    3    0.18409E-03    0.10000E+01    0.22184E+05    0.63871E-45    0.17366E-54    0.17284E-50
+    5    3    0.18409E-03    0.10000E+01    0.17891E+05    0.45206E-44    0.22950E-53    0.12268E-49
+    5    3    0.18409E-03    0.10000E+01    0.14428E+05    0.31531E-43    0.29931E-52    0.85914E-49
+    5    3    0.18409E-03    0.10000E+01    0.11635E+05    0.21689E-42    0.38483E-51    0.59408E-48
+    5    3    0.18409E-03    0.10000E+01    0.93834E+04    0.14703E-41    0.48339E-50    0.40540E-47
+    5    3    0.18409E-03    0.10000E+01    0.75673E+04    0.97627E-41    0.58340E-49    0.27149E-46
+    5    3    0.18409E-03    0.10000E+01    0.61026E+04    0.62679E-40    0.66252E-48    0.17627E-45
+    5    3    0.18409E-03    0.10000E+01    0.49215E+04    0.38300E-39    0.71413E-47    0.10880E-44
+    5    3    0.18409E-03    0.10000E+01    0.39689E+04    0.22433E-38    0.86824E-46    0.62647E-44
+    5    3    0.18409E-03    0.10000E+01    0.32008E+04    0.45286E-36    0.52408E-43    0.11183E-41
+    5    3    0.18409E-03    0.10000E+01    0.25813E+04    0.22291E-27    0.82243E-34    0.44201E-33
+    5    3    0.18409E-03    0.10000E+01    0.20817E+04    0.41458E-11    0.56605E-17    0.76260E-17
+    5    3    0.18409E-03    0.10000E+01    0.16788E+04    0.13008E-05    0.68301E-11    0.22381E-11
+    5    3    0.18409E-03    0.10000E+01    0.13538E+04    0.22248E-05    0.24608E-10    0.32103E-11
+    5    3    0.18409E-03    0.10000E+01    0.10918E+04    0.39917E-05    0.87924E-10    0.48416E-11
+    5    3    0.18409E-03    0.10000E+01    0.88049E+03    0.73467E-05    0.31312E-09    0.75791E-11
+    5    3    0.18409E-03    0.10000E+01    0.71007E+03    0.13674E-04    0.11123E-08    0.12179E-10
+    5    3    0.18409E-03    0.10000E+01    0.57264E+03    0.25542E-04    0.38895E-08    0.19950E-10
+    5    3    0.18409E-03    0.10000E+01    0.46180E+03    0.47634E-04    0.12936E-07    0.33170E-10
+    5    3    0.18409E-03    0.10000E+01    0.37242E+03    0.87968E-04    0.39177E-07    0.55628E-10
+    5    3    0.18409E-03    0.10000E+01    0.30034E+03    0.15868E-03    0.10466E-06    0.92953E-10
+    5    3    0.18409E-03    0.10000E+01    0.24221E+03    0.27500E-03    0.24377E-06    0.15213E-09
+    5    3    0.18409E-03    0.10000E+01    0.19533E+03    0.42902E-03    0.46261E-06    0.22866E-09
+    5    3    0.18409E-03    0.10000E+01    0.15752E+03    0.42902E-03    0.46261E-06    0.22866E-09
+    5    3    0.32123E-03    0.10000E+01    0.80645E+05    0.54899E-50    0.41162E-61    0.14788E-55
+    5    3    0.32123E-03    0.10000E+01    0.65036E+05    0.46525E-49    0.65455E-60    0.12535E-54
+    5    3    0.32123E-03    0.10000E+01    0.52449E+05    0.39592E-48    0.88138E-59    0.10670E-53
+    5    3    0.32123E-03    0.10000E+01    0.42297E+05    0.29839E-47    0.12009E-57    0.80448E-53
+    5    3    0.32123E-03    0.10000E+01    0.34111E+05    0.21578E-46    0.16551E-56    0.58217E-52
+    5    3    0.32123E-03    0.10000E+01    0.27509E+05    0.15553E-45    0.22569E-55    0.42011E-51
+    5    3    0.32123E-03    0.10000E+01    0.22184E+05    0.11145E-44    0.30302E-54    0.30159E-50
+    5    3    0.32123E-03    0.10000E+01    0.17891E+05    0.78883E-44    0.40047E-53    0.21407E-49
+    5    3    0.32123E-03    0.10000E+01    0.14428E+05    0.55020E-43    0.52228E-52    0.14992E-48
+    5    3    0.32123E-03    0.10000E+01    0.11635E+05    0.37846E-42    0.67151E-51    0.10366E-47
+    5    3    0.32123E-03    0.10000E+01    0.93834E+04    0.25657E-41    0.84349E-50    0.70740E-47
+    5    3    0.32123E-03    0.10000E+01    0.75673E+04    0.17035E-40    0.10180E-48    0.47373E-46
+    5    3    0.32123E-03    0.10000E+01    0.61026E+04    0.10937E-39    0.11561E-47    0.30757E-45
+    5    3    0.32123E-03    0.10000E+01    0.49215E+04    0.66831E-39    0.12461E-46    0.18984E-44
+    5    3    0.32123E-03    0.10000E+01    0.39689E+04    0.39144E-38    0.15150E-45    0.10931E-43
+    5    3    0.32123E-03    0.10000E+01    0.32008E+04    0.79022E-36    0.91449E-43    0.19513E-41
+    5    3    0.32123E-03    0.10000E+01    0.25813E+04    0.38896E-27    0.14351E-33    0.77127E-33
+    5    3    0.32123E-03    0.10000E+01    0.20817E+04    0.72341E-11    0.98772E-17    0.13307E-16
+    5    3    0.32123E-03    0.10000E+01    0.16788E+04    0.22699E-05    0.11918E-10    0.39053E-11
+    5    3    0.32123E-03    0.10000E+01    0.13538E+04    0.38821E-05    0.42940E-10    0.56017E-11
+    5    3    0.32123E-03    0.10000E+01    0.10918E+04    0.69652E-05    0.15342E-09    0.84482E-11
+    5    3    0.32123E-03    0.10000E+01    0.88049E+03    0.12820E-04    0.54638E-09    0.13225E-10
+    5    3    0.32123E-03    0.10000E+01    0.71007E+03    0.23860E-04    0.19409E-08    0.21252E-10
+    5    3    0.32123E-03    0.10000E+01    0.57264E+03    0.44569E-04    0.67869E-08    0.34812E-10
+    5    3    0.32123E-03    0.10000E+01    0.46180E+03    0.83118E-04    0.22573E-07    0.57880E-10
+    5    3    0.32123E-03    0.10000E+01    0.37242E+03    0.15350E-03    0.68362E-07    0.97067E-10
+    5    3    0.32123E-03    0.10000E+01    0.30034E+03    0.27688E-03    0.18262E-06    0.16220E-09
+    5    3    0.32123E-03    0.10000E+01    0.24221E+03    0.47986E-03    0.42537E-06    0.26545E-09
+    5    3    0.32123E-03    0.10000E+01    0.19533E+03    0.74862E-03    0.80722E-06    0.39900E-09
+    5    3    0.32123E-03    0.10000E+01    0.15752E+03    0.74862E-03    0.80722E-06    0.39900E-09
+    5    4    0.45665E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.52131E-54    0.00000E+00    0.13613E-06    0.13832E-05    0.82436E-01    0.82436E-10    0.35000E+07    0.29969E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    4    0.79683E-15    0.10000E+01    0.15624E-03    0.35587E-03    0.15873E-53    0.00000E+00    0.23754E-06    0.13832E-05    0.14385E+00    0.14385E-09    0.35000E+07    0.52295E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    4    0.13904E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.48330E-53    0.00000E+00    0.41450E-06    0.13832E-05    0.25100E+00    0.25100E-09    0.35000E+07    0.91251E-34    0.00000E+00    0.30666E-05    0.90000E+03
+    5    4    0.24262E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.14716E-52    0.00000E+00    0.72328E-06    0.13832E-05    0.43798E+00    0.43798E-09    0.35000E+07    0.15923E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    5    4    0.42336E-14    0.10000E+01    0.15624E-03    0.35587E-03    0.44806E-52    0.00000E+00    0.12621E-05    0.13832E-05    0.76426E+00    0.76426E-09    0.35000E+07    0.27784E-33    0.00000E+00    0.30666E-05    0.90000E+03
+    5    4    0.73873E-14    0.10000E+01    0.21032E-03    0.40424E-03    0.72299E-47    0.00000E+00    0.19075E-05    0.14892E-05    0.13336E+01    0.13336E-08    0.31801E+07    0.63104E-33    0.00000E+00    0.32564E-05    0.90000E+03
+    5    4    0.12890E-13    0.10000E+01    0.31613E-03    0.55667E-03    0.12456E-38    0.00000E+00    0.25272E-05    0.17048E-05    0.23270E+01    0.23270E-08    0.26410E+07    0.18842E-32    0.00000E+00    0.37750E-05    0.90000E+03
+    5    4    0.22493E-13    0.10000E+01    0.43672E-03    0.80967E-03    0.55411E-32    0.93929E-93    0.31761E-05    0.20104E-05    0.40605E+01    0.40605E-08    0.21932E+07    0.57448E-32    0.10349E-90    0.45338E-05    0.90000E+03
+    5    4    0.39249E-13    0.10000E+01    0.61095E-03    0.11801E-02    0.11832E-26    0.53154E-77    0.38523E-05    0.24185E-05    0.70853E+01    0.70853E-08    0.18214E+07    0.17525E-31    0.58539E-75    0.54820E-05    0.90000E+03
+    5    4    0.68487E-13    0.10000E+01    0.87202E-03    0.17051E-02    0.19253E-22    0.43365E-64    0.46406E-05    0.29143E-05    0.12363E+02    0.12363E-07    0.15145E+07    0.53194E-31    0.47724E-62    0.66021E-05    0.90000E+03
+    5    4    0.11951E-12    0.10000E+01    0.12594E-02    0.24643E-02    0.41218E-19    0.22582E-53    0.55759E-05    0.35121E-05    0.21574E+02    0.21574E-07    0.12578E+07    0.16206E-30    0.24824E-51    0.79511E-05    0.90000E+03
+    5    4    0.20853E-12    0.10000E+01    0.18214E-02    0.35573E-02    0.15467E-16    0.14724E-44    0.67064E-05    0.42297E-05    0.37644E+02    0.37644E-07    0.10445E+07    0.49376E-30    0.16159E-42    0.95741E-05    0.90000E+03
+    5    4    0.36387E-12    0.10000E+01    0.26317E-02    0.51283E-02    0.13667E-14    0.25374E-37    0.80695E-05    0.50933E-05    0.65687E+02    0.65687E-07    0.86742E+06    0.15043E-29    0.27782E-35    0.11528E-04    0.90000E+03
+    5    4    0.63493E-12    0.10000E+01    0.37974E-02    0.73804E-02    0.36339E-13    0.21486E-31    0.97107E-05    0.61331E-05    0.11462E+03    0.11462E-06    0.72035E+06    0.45832E-29    0.23452E-29    0.13882E-04    0.90000E+03
+    5    4    0.11079E-11    0.10000E+01    0.54706E-02    0.10598E-01    0.35670E-12    0.14959E-26    0.11686E-04    0.73852E-05    0.20001E+03    0.20001E-06    0.59822E+06    0.13964E-28    0.16259E-24    0.16716E-04    0.90000E+03
+    5    4    0.19333E-11    0.10000E+01    0.78654E-02    0.15173E-01    0.15384E-11    0.13129E-22    0.14063E-04    0.88930E-05    0.34900E+03    0.34900E-06    0.49680E+06    0.42543E-28    0.14193E-20    0.20129E-04    0.90000E+03
+    5    4    0.33734E-11    0.10000E+01    0.11252E-01    0.21593E-01    0.34564E-11    0.19865E-19    0.16968E-04    0.10695E-04    0.60898E+03    0.60898E-06    0.41311E+06    0.12911E-27    0.21323E-17    0.24207E-04    0.90000E+03
+    5    4    0.58864E-11    0.10000E+01    0.16085E-01    0.30668E-01    0.51389E-11    0.76485E-17    0.20419E-04    0.12878E-04    0.10626E+04    0.10626E-05    0.34307E+06    0.39336E-27    0.81335E-15    0.29149E-04    0.90000E+03
+    5    4    0.10271E-10    0.10000E+01    0.22905E-01    0.43316E-01    0.84256E-11    0.90951E-15    0.24572E-04    0.15507E-04    0.18542E+04    0.18542E-05    0.28490E+06    0.11985E-26    0.95530E-13    0.35100E-04    0.90000E+03
+    5    4    0.17923E-10    0.10000E+01    0.32455E-01    0.60772E-01    0.19634E-10    0.41071E-13    0.29570E-04    0.18673E-04    0.32355E+04    0.32355E-05    0.23660E+06    0.36513E-26    0.42432E-11    0.42266E-04    0.90000E+03
+    5    4    0.31275E-10    0.10000E+01    0.45715E-01    0.84589E-01    0.45426E-10    0.83816E-12    0.35574E-04    0.22485E-04    0.56458E+04    0.56458E-05    0.19649E+06    0.11125E-25    0.84679E-10    0.50894E-04    0.90000E+03
+    5    4    0.54572E-10    0.10000E+01    0.63935E-01    0.11666E+00    0.94554E-10    0.89621E-11    0.42701E-04    0.27076E-04    0.98516E+04    0.98516E-05    0.16317E+06    0.33893E-25    0.87813E-09    0.61285E-04    0.90000E+03
+    5    4    0.95225E-10    0.10000E+01    0.88476E-01    0.15887E+00    0.18794E-09    0.56603E-10    0.50947E-04    0.32561E-04    0.17190E+05    0.17190E-04    0.13568E+06    0.10286E-24    0.53182E-08    0.73701E-04    0.90000E+03
+    5    4    0.16616E-09    0.10000E+01    0.12155E+00    0.21432E+00    0.36384E-09    0.24030E-09    0.59423E-04    0.39209E-04    0.29996E+05    0.29996E-04    0.11268E+06    0.31338E-24    0.21294E-07    0.88747E-04    0.90000E+03
+    5    4    0.28994E-09    0.10000E+01    0.16521E+00    0.28552E+00    0.69100E-09    0.74928E-09    0.67399E-04    0.47213E-04    0.52341E+05    0.52341E-04    0.93576E+05    0.95478E-24    0.61276E-07    0.10687E-03    0.90000E+03
+    5    4    0.50593E-09    0.10000E+01    0.22194E+00    0.37532E+00    0.12881E-08    0.18740E-08    0.74753E-04    0.56852E-04    0.91333E+05    0.91333E-04    0.77710E+05    0.29089E-23    0.13772E-06    0.12868E-03    0.90000E+03
+    5    4    0.88282E-09    0.10000E+01    0.29440E+00    0.48663E+00    0.23570E-08    0.40514E-08    0.82592E-04    0.68459E-04    0.15937E+06    0.15937E-03    0.64535E+05    0.88627E-23    0.25998E-06    0.15495E-03    0.90000E+03
+    5    4    0.15405E-08    0.10000E+01    0.38541E+00    0.62222E+00    0.42346E-08    0.80191E-08    0.92684E-04    0.82435E-04    0.27809E+06    0.27809E-03    0.53594E+05    0.27002E-22    0.43797E-06    0.18659E-03    0.90000E+03
+    5    4    0.26880E-08    0.10000E+01    0.49690E+00    0.78347E+00    0.75040E-08    0.15093E-07    0.10685E-03    0.99136E-04    0.48525E+06    0.48525E-03    0.44565E+05    0.81946E-22    0.68999E-06    0.22439E-03    0.90000E+03
+    5    4    0.46905E-08    0.10000E+01    0.63317E+00    0.97502E+00    0.13029E-07    0.27624E-07    0.12542E-03    0.11938E-03    0.84674E+06    0.84674E-03    0.37009E+05    0.24967E-21    0.10464E-05    0.27020E-03    0.90000E+03
+    5    4    0.81846E-08    0.10000E+01    0.73378E+00    0.13254E+01    0.26610E-07    0.49634E-07    0.14147E-03    0.15256E-03    0.12130E+07    0.12130E-02    0.20519E+05    0.11222E-20    0.14543E-05    0.35952E-03    0.90000E+03
+    5    4    0.14282E-07    0.10000E+01    0.56847E+00    0.23889E+01    0.65715E-07    0.84491E-07    0.11845E-03    0.25274E-03    0.63138E+06    0.63138E-03    0.58268E+04    0.17708E-19    0.15160E-05    0.68648E-03    0.90000E+03
+    5    4    0.24920E-07    0.10000E+01    0.69941E+00    0.27867E+01    0.11006E-06    0.14461E-06    0.14031E-03    0.30434E-03    0.11017E+07    0.11017E-02    0.48389E+04    0.53950E-19    0.22074E-05    0.82663E-03    0.90000E+03
+    5    4    0.43485E-07    0.10000E+01    0.85117E+00    0.32246E+01    0.18355E-06    0.24550E-06    0.16727E-03    0.36600E-03    0.19224E+07    0.19224E-02    0.40237E+04    0.16373E-18    0.31956E-05    0.99410E-03    0.90000E+03
+    5    4    0.75878E-07    0.10000E+01    0.10280E+01    0.37113E+01    0.30251E-06    0.41358E-06    0.19948E-03    0.44072E-03    0.33546E+07    0.33546E-02    0.33415E+04    0.49884E-18    0.45933E-05    0.11970E-02    0.90000E+03
+    5    4    0.13240E-06    0.10000E+01    0.12309E+01    0.42473E+01    0.49523E-06    0.69209E-06    0.23844E-03    0.53069E-03    0.58535E+07    0.58535E-02    0.27750E+04    0.15198E-17    0.65701E-05    0.14414E-02    0.90000E+03
+    5    4    0.23103E-06    0.10000E+01    0.14621E+01    0.48358E+01    0.80601E-06    0.11512E-05    0.28554E-03    0.63903E-03    0.10214E+08    0.10214E-01    0.23045E+04    0.46304E-17    0.93583E-05    0.17357E-02    0.90000E+03
+    5    4    0.40314E-06    0.10000E+01    0.17240E+01    0.54812E+01    0.13052E-05    0.19048E-05    0.34240E-03    0.76950E-03    0.17823E+08    0.17823E-01    0.19138E+04    0.14107E-16    0.13282E-04    0.20901E-02    0.90000E+03
+    5    4    0.70346E-06    0.10000E+01    0.20187E+01    0.61878E+01    0.21044E-05    0.31365E-05    0.41100E-03    0.92660E-03    0.31100E+08    0.31100E-01    0.15893E+04    0.42981E-16    0.18790E-04    0.25168E-02    0.90000E+03
+    5    4    0.12275E-05    0.10000E+01    0.23488E+01    0.69609E+01    0.33807E-05    0.51430E-05    0.49371E-03    0.11158E-02    0.54267E+08    0.54267E-01    0.13199E+04    0.13095E-15    0.26510E-04    0.30306E-02    0.90000E+03
+    5    4    0.21419E-05    0.10000E+01    0.27142E+01    0.78000E+01    0.54389E-05    0.84054E-05    0.59492E-03    0.13418E-02    0.94693E+08    0.94693E-01    0.10975E+04    0.39739E-15    0.37367E-04    0.36446E-02    0.90000E+03
+    5    4    0.37375E-05    0.10000E+01    0.31228E+01    0.87233E+01    0.86892E-05    0.13685E-04    0.71528E-03    0.16157E-02    0.16523E+09    0.16523E+00    0.91145E+03    0.12097E-14    0.52479E-04    0.43884E-02    0.90000E+03
+    5    4    0.65217E-05    0.10000E+01    0.35754E+01    0.97305E+01    0.13852E-04    0.22215E-04    0.86023E-03    0.19453E-02    0.28832E+09    0.28832E+00    0.75692E+03    0.36631E-14    0.73563E-04    0.52815E-02    0.90000E+03
+    5    4    0.11380E-04    0.10000E+01    0.40752E+01    0.10820E+02    0.22029E-04    0.35947E-04    0.10347E-02    0.23401E-02    0.50310E+09    0.50310E+00    0.62859E+03    0.10866E-13    0.10293E-03    0.63405E-02    0.90000E+03
+    5    4    0.19857E-04    0.10000E+01    0.46258E+01    0.11965E+02    0.34861E-04    0.57872E-04    0.12444E-02    0.28055E-02    0.87789E+09    0.87789E+00    0.52201E+03    0.30656E-13    0.14367E-03    0.75509E-02    0.90000E+03
+    5    4    0.34650E-04    0.10000E+01    0.47611E+01    0.12232E+02    0.91073E-04    0.98994E-04    0.19917E-02    0.29230E-02    0.15319E+10    0.15319E+01    0.50000E+03    0.59146E-13    0.23793E-03    0.78471E-02    0.90000E+03
+    5    4    0.60462E-04    0.10000E+01    0.47611E+01    0.12232E+02    0.27730E-03    0.17274E-03    0.34754E-02    0.29230E-02    0.26730E+10    0.26730E+01    0.50000E+03    0.10321E-12    0.41516E-03    0.78471E-02    0.90000E+03
+    5    4    0.10550E-03    0.10000E+01    0.47611E+01    0.12232E+02    0.84433E-03    0.30142E-03    0.60644E-02    0.29230E-02    0.46642E+10    0.46642E+01    0.50000E+03    0.18009E-12    0.72444E-03    0.78471E-02    0.90000E+03
+    5    4    0.18409E-03    0.10000E+01    0.47611E+01    0.12232E+02    0.25708E-02    0.52596E-03    0.10582E-01    0.29230E-02    0.81388E+10    0.81388E+01    0.50000E+03    0.31424E-12    0.12641E-02    0.78471E-02    0.90000E+03
+    5    4    0.32123E-03    0.10000E+01    0.47611E+01    0.12232E+02    0.78277E-02    0.91776E-03    0.18465E-01    0.29230E-02    0.14202E+11    0.14202E+02    0.50000E+03    0.54834E-12    0.22058E-02    0.78471E-02    0.90000E+03
+    5    4    0.45665E-15    0.10000E+01    0.80645E+05    0.14863E-66    0.25305E-77    0.70039E-79
+    5    4    0.45665E-15    0.10000E+01    0.65036E+05    0.26801E-65    0.78089E-76    0.12630E-77
+    5    4    0.45665E-15    0.10000E+01    0.52449E+05    0.44956E-64    0.26368E-74    0.21185E-76
+    5    4    0.45665E-15    0.10000E+01    0.42297E+05    0.78569E-63    0.88227E-73    0.37025E-75
+    5    4    0.45665E-15    0.10000E+01    0.34111E+05    0.13771E-61    0.29314E-71    0.64894E-74
+    5    4    0.45665E-15    0.10000E+01    0.27509E+05    0.23987E-60    0.96296E-70    0.11304E-72
+    5    4    0.45665E-15    0.10000E+01    0.22184E+05    0.41147E-59    0.30405E-68    0.19390E-71
+    5    4    0.45665E-15    0.10000E+01    0.17891E+05    0.67806E-58    0.90000E-67    0.31953E-70
+    5    4    0.45665E-15    0.10000E+01    0.14428E+05    0.10536E-56    0.25165E-65    0.49650E-69
+    5    4    0.45665E-15    0.10000E+01    0.11635E+05    0.15536E-55    0.68267E-64    0.73213E-68
+    5    4    0.45665E-15    0.10000E+01    0.93834E+04    0.22211E-54    0.18330E-62    0.10467E-66
+    5    4    0.45665E-15    0.10000E+01    0.75673E+04    0.31348E-53    0.49100E-61    0.14772E-65
+    5    4    0.45665E-15    0.10000E+01    0.61026E+04    0.44072E-52    0.13148E-59    0.20769E-64
+    5    4    0.45665E-15    0.10000E+01    0.49215E+04    0.61906E-51    0.35206E-58    0.29173E-63
+    5    4    0.45665E-15    0.10000E+01    0.39689E+04    0.86944E-50    0.94268E-57    0.40971E-62
+    5    4    0.45665E-15    0.10000E+01    0.32008E+04    0.38400E-47    0.81622E-54    0.18096E-59
+    5    4    0.45665E-15    0.10000E+01    0.25813E+04    0.28064E-38    0.13675E-44    0.13225E-50
+    5    4    0.45665E-15    0.10000E+01    0.20817E+04    0.53229E-22    0.11569E-27    0.25084E-34
+    5    4    0.45665E-15    0.10000E+01    0.16788E+04    0.17953E-16    0.17064E-21    0.84602E-29
+    5    4    0.45665E-15    0.10000E+01    0.13538E+04    0.38517E-16    0.64801E-21    0.18151E-28
+    5    4    0.45665E-15    0.10000E+01    0.10918E+04    0.80828E-16    0.24160E-20    0.38089E-28
+    5    4    0.45665E-15    0.10000E+01    0.88049E+03    0.16603E-15    0.88946E-20    0.78239E-28
+    5    4    0.45665E-15    0.10000E+01    0.71007E+03    0.33452E-15    0.32389E-19    0.15764E-27
+    5    4    0.45665E-15    0.10000E+01    0.57264E+03    0.66278E-15    0.11523E-18    0.31233E-27
+    5    4    0.45665E-15    0.10000E+01    0.46180E+03    0.12920E-14    0.38758E-18    0.60882E-27
+    5    4    0.45665E-15    0.10000E+01    0.37242E+03    0.24656E-14    0.11818E-17    0.11619E-26
+    5    4    0.45665E-15    0.10000E+01    0.30034E+03    0.45537E-14    0.31698E-17    0.21459E-26
+    5    4    0.45665E-15    0.10000E+01    0.24221E+03    0.80224E-14    0.74012E-17    0.37805E-26
+    5    4    0.45665E-15    0.10000E+01    0.19533E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    5    4    0.45665E-15    0.10000E+01    0.15752E+03    0.12643E-13    0.14065E-16    0.59580E-26
+    5    4    0.79683E-15    0.10000E+01    0.80645E+05    0.25934E-66    0.44156E-77    0.12221E-78
+    5    4    0.79683E-15    0.10000E+01    0.65036E+05    0.46766E-65    0.13626E-75    0.22038E-77
+    5    4    0.79683E-15    0.10000E+01    0.52449E+05    0.78446E-64    0.46011E-74    0.36967E-76
+    5    4    0.79683E-15    0.10000E+01    0.42297E+05    0.13710E-62    0.15395E-72    0.64606E-75
+    5    4    0.79683E-15    0.10000E+01    0.34111E+05    0.24029E-61    0.51151E-71    0.11324E-73
+    5    4    0.79683E-15    0.10000E+01    0.27509E+05    0.41856E-60    0.16803E-69    0.19724E-72
+    5    4    0.79683E-15    0.10000E+01    0.22184E+05    0.71798E-59    0.53055E-68    0.33834E-71
+    5    4    0.79683E-15    0.10000E+01    0.17891E+05    0.11832E-57    0.15704E-66    0.55756E-70
+    5    4    0.79683E-15    0.10000E+01    0.14428E+05    0.18385E-56    0.43911E-65    0.86636E-69
+    5    4    0.79683E-15    0.10000E+01    0.11635E+05    0.27110E-55    0.11912E-63    0.12775E-67
+    5    4    0.79683E-15    0.10000E+01    0.93834E+04    0.38757E-54    0.31984E-62    0.18264E-66
+    5    4    0.79683E-15    0.10000E+01    0.75673E+04    0.54701E-53    0.85676E-61    0.25777E-65
+    5    4    0.79683E-15    0.10000E+01    0.61026E+04    0.76904E-52    0.22942E-59    0.36240E-64
+    5    4    0.79683E-15    0.10000E+01    0.49215E+04    0.10802E-50    0.61432E-58    0.50905E-63
+    5    4    0.79683E-15    0.10000E+01    0.39689E+04    0.15171E-49    0.16449E-56    0.71492E-62
+    5    4    0.79683E-15    0.10000E+01    0.32008E+04    0.67006E-47    0.14243E-53    0.31576E-59
+    5    4    0.79683E-15    0.10000E+01    0.25813E+04    0.48969E-38    0.23861E-44    0.23076E-50
+    5    4    0.79683E-15    0.10000E+01    0.20817E+04    0.92882E-22    0.20188E-27    0.43769E-34
+    5    4    0.79683E-15    0.10000E+01    0.16788E+04    0.31327E-16    0.29775E-21    0.14762E-28
+    5    4    0.79683E-15    0.10000E+01    0.13538E+04    0.67210E-16    0.11307E-20    0.31672E-28
+    5    4    0.79683E-15    0.10000E+01    0.10918E+04    0.14104E-15    0.42157E-20    0.66463E-28
+    5    4    0.79683E-15    0.10000E+01    0.88049E+03    0.28971E-15    0.15521E-19    0.13652E-27
+    5    4    0.79683E-15    0.10000E+01    0.71007E+03    0.58372E-15    0.56517E-19    0.27507E-27
+    5    4    0.79683E-15    0.10000E+01    0.57264E+03    0.11565E-14    0.20107E-18    0.54499E-27
+    5    4    0.79683E-15    0.10000E+01    0.46180E+03    0.22544E-14    0.67630E-18    0.10624E-26
+    5    4    0.79683E-15    0.10000E+01    0.37242E+03    0.43023E-14    0.20622E-17    0.20274E-26
+    5    4    0.79683E-15    0.10000E+01    0.30034E+03    0.79459E-14    0.55311E-17    0.37444E-26
+    5    4    0.79683E-15    0.10000E+01    0.24221E+03    0.13999E-13    0.12915E-16    0.65967E-26
+    5    4    0.79683E-15    0.10000E+01    0.19533E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    5    4    0.79683E-15    0.10000E+01    0.15752E+03    0.22062E-13    0.24542E-16    0.10396E-25
+    5    4    0.13904E-14    0.10000E+01    0.80645E+05    0.45254E-66    0.77050E-77    0.21325E-78
+    5    4    0.13904E-14    0.10000E+01    0.65036E+05    0.81603E-65    0.23777E-75    0.38455E-77
+    5    4    0.13904E-14    0.10000E+01    0.52449E+05    0.13688E-63    0.80286E-74    0.64504E-76
+    5    4    0.13904E-14    0.10000E+01    0.42297E+05    0.23923E-62    0.26863E-72    0.11273E-74
+    5    4    0.13904E-14    0.10000E+01    0.34111E+05    0.41930E-61    0.89255E-71    0.19759E-73
+    5    4    0.13904E-14    0.10000E+01    0.27509E+05    0.73036E-60    0.29320E-69    0.34417E-72
+    5    4    0.13904E-14    0.10000E+01    0.22184E+05    0.12528E-58    0.92578E-68    0.59039E-71
+    5    4    0.13904E-14    0.10000E+01    0.17891E+05    0.20646E-57    0.27403E-66    0.97290E-70
+    5    4    0.13904E-14    0.10000E+01    0.14428E+05    0.32080E-56    0.76622E-65    0.15117E-68
+    5    4    0.13904E-14    0.10000E+01    0.11635E+05    0.47305E-55    0.20786E-63    0.22292E-67
+    5    4    0.13904E-14    0.10000E+01    0.93834E+04    0.67629E-54    0.55810E-62    0.31869E-66
+    5    4    0.13904E-14    0.10000E+01    0.75673E+04    0.95450E-53    0.14950E-60    0.44979E-65
+    5    4    0.13904E-14    0.10000E+01    0.61026E+04    0.13419E-51    0.40033E-59    0.63236E-64
+    5    4    0.13904E-14    0.10000E+01    0.49215E+04    0.18849E-50    0.10719E-57    0.88825E-63
+    5    4    0.13904E-14    0.10000E+01    0.39689E+04    0.26473E-49    0.28703E-56    0.12475E-61
+    5    4    0.13904E-14    0.10000E+01    0.32008E+04    0.11692E-46    0.24852E-53    0.55098E-59
+    5    4    0.13904E-14    0.10000E+01    0.25813E+04    0.85449E-38    0.41636E-44    0.40267E-50
+    5    4    0.13904E-14    0.10000E+01    0.20817E+04    0.16207E-21    0.35227E-27    0.76375E-34
+    5    4    0.13904E-14    0.10000E+01    0.16788E+04    0.54664E-16    0.51956E-21    0.25760E-28
+    5    4    0.13904E-14    0.10000E+01    0.13538E+04    0.11728E-15    0.19731E-20    0.55266E-28
+    5    4    0.13904E-14    0.10000E+01    0.10918E+04    0.24610E-15    0.73562E-20    0.11597E-27
+    5    4    0.13904E-14    0.10000E+01    0.88049E+03    0.50553E-15    0.27083E-19    0.23822E-27
+    5    4    0.13904E-14    0.10000E+01    0.71007E+03    0.10186E-14    0.98618E-19    0.47998E-27
+    5    4    0.13904E-14    0.10000E+01    0.57264E+03    0.20180E-14    0.35086E-18    0.95098E-27
+    5    4    0.13904E-14    0.10000E+01    0.46180E+03    0.39338E-14    0.11801E-17    0.18537E-26
+    5    4    0.13904E-14    0.10000E+01    0.37242E+03    0.75072E-14    0.35983E-17    0.35377E-26
+    5    4    0.13904E-14    0.10000E+01    0.30034E+03    0.13865E-13    0.96514E-17    0.65338E-26
+    5    4    0.13904E-14    0.10000E+01    0.24221E+03    0.24427E-13    0.22535E-16    0.11511E-25
+    5    4    0.13904E-14    0.10000E+01    0.19533E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    5    4    0.13904E-14    0.10000E+01    0.15752E+03    0.38497E-13    0.42824E-16    0.18141E-25
+    5    4    0.24262E-14    0.10000E+01    0.80645E+05    0.78965E-66    0.13445E-76    0.37212E-78
+    5    4    0.24262E-14    0.10000E+01    0.65036E+05    0.14239E-64    0.41489E-75    0.67101E-77
+    5    4    0.24262E-14    0.10000E+01    0.52449E+05    0.23885E-63    0.14009E-73    0.11256E-75
+    5    4    0.24262E-14    0.10000E+01    0.42297E+05    0.41744E-62    0.46875E-72    0.19671E-74
+    5    4    0.24262E-14    0.10000E+01    0.34111E+05    0.73165E-61    0.15575E-70    0.34478E-73
+    5    4    0.24262E-14    0.10000E+01    0.27509E+05    0.12744E-59    0.51162E-69    0.60056E-72
+    5    4    0.24262E-14    0.10000E+01    0.22184E+05    0.21861E-58    0.16154E-67    0.10302E-70
+    5    4    0.24262E-14    0.10000E+01    0.17891E+05    0.36025E-57    0.47817E-66    0.16977E-69
+    5    4    0.24262E-14    0.10000E+01    0.14428E+05    0.55978E-56    0.13370E-64    0.26379E-68
+    5    4    0.24262E-14    0.10000E+01    0.11635E+05    0.82545E-55    0.36270E-63    0.38898E-67
+    5    4    0.24262E-14    0.10000E+01    0.93834E+04    0.11801E-53    0.97385E-62    0.55610E-66
+    5    4    0.24262E-14    0.10000E+01    0.75673E+04    0.16655E-52    0.26087E-60    0.78486E-65
+    5    4    0.24262E-14    0.10000E+01    0.61026E+04    0.23416E-51    0.69854E-59    0.11034E-63
+    5    4    0.24262E-14    0.10000E+01    0.49215E+04    0.32891E-50    0.18705E-57    0.15499E-62
+    5    4    0.24262E-14    0.10000E+01    0.39689E+04    0.46193E-49    0.50085E-56    0.21768E-61
+    5    4    0.24262E-14    0.10000E+01    0.32008E+04    0.20402E-46    0.43366E-53    0.96143E-59
+    5    4    0.24262E-14    0.10000E+01    0.25813E+04    0.14910E-37    0.72653E-44    0.70263E-50
+    5    4    0.24262E-14    0.10000E+01    0.20817E+04    0.28281E-21    0.61468E-27    0.13327E-33
+    5    4    0.24262E-14    0.10000E+01    0.16788E+04    0.95385E-16    0.90660E-21    0.44949E-28
+    5    4    0.24262E-14    0.10000E+01    0.13538E+04    0.20464E-15    0.34429E-20    0.96436E-28
+    5    4    0.24262E-14    0.10000E+01    0.10918E+04    0.42944E-15    0.12836E-19    0.20237E-27
+    5    4    0.24262E-14    0.10000E+01    0.88049E+03    0.88211E-15    0.47257E-19    0.41568E-27
+    5    4    0.24262E-14    0.10000E+01    0.71007E+03    0.17773E-14    0.17208E-18    0.83754E-27
+    5    4    0.24262E-14    0.10000E+01    0.57264E+03    0.35214E-14    0.61224E-18    0.16594E-26
+    5    4    0.24262E-14    0.10000E+01    0.46180E+03    0.68642E-14    0.20592E-17    0.32347E-26
+    5    4    0.24262E-14    0.10000E+01    0.37242E+03    0.13100E-13    0.62789E-17    0.61731E-26
+    5    4    0.24262E-14    0.10000E+01    0.30034E+03    0.24194E-13    0.16841E-16    0.11401E-25
+    5    4    0.24262E-14    0.10000E+01    0.24221E+03    0.42623E-13    0.39323E-16    0.20086E-25
+    5    4    0.24262E-14    0.10000E+01    0.19533E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    5    4    0.24262E-14    0.10000E+01    0.15752E+03    0.67174E-13    0.74726E-16    0.31655E-25
+    5    4    0.42336E-14    0.10000E+01    0.80645E+05    0.13779E-65    0.23460E-76    0.64932E-78
+    5    4    0.42336E-14    0.10000E+01    0.65036E+05    0.24847E-64    0.72396E-75    0.11709E-76
+    5    4    0.42336E-14    0.10000E+01    0.52449E+05    0.41678E-63    0.24446E-73    0.19640E-75
+    5    4    0.42336E-14    0.10000E+01    0.42297E+05    0.72841E-62    0.81794E-72    0.34325E-74
+    5    4    0.42336E-14    0.10000E+01    0.34111E+05    0.12767E-60    0.27177E-70    0.60162E-73
+    5    4    0.42336E-14    0.10000E+01    0.27509E+05    0.22238E-59    0.89275E-69    0.10479E-71
+    5    4    0.42336E-14    0.10000E+01    0.22184E+05    0.38147E-58    0.28188E-67    0.17976E-70
+    5    4    0.42336E-14    0.10000E+01    0.17891E+05    0.62862E-57    0.83438E-66    0.29623E-69
+    5    4    0.42336E-14    0.10000E+01    0.14428E+05    0.97678E-56    0.23330E-64    0.46030E-68
+    5    4    0.42336E-14    0.10000E+01    0.11635E+05    0.14404E-54    0.63289E-63    0.67875E-67
+    5    4    0.42336E-14    0.10000E+01    0.93834E+04    0.20592E-53    0.16993E-61    0.97036E-66
+    5    4    0.42336E-14    0.10000E+01    0.75673E+04    0.29063E-52    0.45520E-60    0.13695E-64
+    5    4    0.42336E-14    0.10000E+01    0.61026E+04    0.40859E-51    0.12189E-58    0.19254E-63
+    5    4    0.42336E-14    0.10000E+01    0.49215E+04    0.57393E-50    0.32639E-57    0.27046E-62
+    5    4    0.42336E-14    0.10000E+01    0.39689E+04    0.80604E-49    0.87395E-56    0.37984E-61
+    5    4    0.42336E-14    0.10000E+01    0.32008E+04    0.35601E-46    0.75671E-53    0.16776E-58
+    5    4    0.42336E-14    0.10000E+01    0.25813E+04    0.26018E-37    0.12678E-43    0.12260E-49
+    5    4    0.42336E-14    0.10000E+01    0.20817E+04    0.49348E-21    0.10726E-26    0.23255E-33
+    5    4    0.42336E-14    0.10000E+01    0.16788E+04    0.16644E-15    0.15820E-20    0.78433E-28
+    5    4    0.42336E-14    0.10000E+01    0.13538E+04    0.35709E-15    0.60076E-20    0.16827E-27
+    5    4    0.42336E-14    0.10000E+01    0.10918E+04    0.74934E-15    0.22398E-19    0.35312E-27
+    5    4    0.42336E-14    0.10000E+01    0.88049E+03    0.15392E-14    0.82461E-19    0.72534E-27
+    5    4    0.42336E-14    0.10000E+01    0.71007E+03    0.31013E-14    0.30027E-18    0.14615E-26
+    5    4    0.42336E-14    0.10000E+01    0.57264E+03    0.61446E-14    0.10683E-17    0.28956E-26
+    5    4    0.42336E-14    0.10000E+01    0.46180E+03    0.11978E-13    0.35932E-17    0.56443E-26
+    5    4    0.42336E-14    0.10000E+01    0.37242E+03    0.22858E-13    0.10956E-16    0.10772E-25
+    5    4    0.42336E-14    0.10000E+01    0.30034E+03    0.42217E-13    0.29387E-16    0.19894E-25
+    5    4    0.42336E-14    0.10000E+01    0.24221E+03    0.74375E-13    0.68616E-16    0.35048E-25
+    5    4    0.42336E-14    0.10000E+01    0.19533E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    5    4    0.42336E-14    0.10000E+01    0.15752E+03    0.11721E-12    0.13039E-15    0.55236E-25
+    5    4    0.73873E-14    0.10000E+01    0.80645E+05    0.22591E-64    0.38464E-75    0.10646E-76
+    5    4    0.73873E-14    0.10000E+01    0.65036E+05    0.40737E-63    0.11870E-73    0.19197E-75
+    5    4    0.73873E-14    0.10000E+01    0.52449E+05    0.68333E-62    0.40080E-72    0.32201E-74
+    5    4    0.73873E-14    0.10000E+01    0.42297E+05    0.11943E-60    0.13411E-70    0.56278E-73
+    5    4    0.73873E-14    0.10000E+01    0.34111E+05    0.20932E-59    0.44557E-69    0.98639E-72
+    5    4    0.73873E-14    0.10000E+01    0.27509E+05    0.36460E-58    0.14637E-67    0.17182E-70
+    5    4    0.73873E-14    0.10000E+01    0.22184E+05    0.62543E-57    0.46216E-66    0.29473E-69
+    5    4    0.73873E-14    0.10000E+01    0.17891E+05    0.10307E-55    0.13680E-64    0.48568E-68
+    5    4    0.73873E-14    0.10000E+01    0.14428E+05    0.16015E-54    0.38251E-63    0.75468E-67
+    5    4    0.73873E-14    0.10000E+01    0.11635E+05    0.23615E-53    0.10377E-61    0.11128E-65
+    5    4    0.73873E-14    0.10000E+01    0.93834E+04    0.33761E-52    0.27861E-60    0.15910E-64
+    5    4    0.73873E-14    0.10000E+01    0.75673E+04    0.47649E-51    0.74632E-59    0.22454E-63
+    5    4    0.73873E-14    0.10000E+01    0.61026E+04    0.66990E-50    0.19985E-57    0.31568E-62
+    5    4    0.73873E-14    0.10000E+01    0.49215E+04    0.94098E-49    0.53513E-56    0.44343E-61
+    5    4    0.73873E-14    0.10000E+01    0.39689E+04    0.13215E-47    0.14329E-54    0.62276E-60
+    5    4    0.73873E-14    0.10000E+01    0.32008E+04    0.58369E-45    0.12407E-51    0.27506E-57
+    5    4    0.73873E-14    0.10000E+01    0.25813E+04    0.42657E-36    0.20785E-42    0.20102E-48
+    5    4    0.73873E-14    0.10000E+01    0.20817E+04    0.80909E-20    0.17586E-25    0.38127E-32
+    5    4    0.73873E-14    0.10000E+01    0.16788E+04    0.27289E-14    0.25937E-19    0.12860E-26
+    5    4    0.73873E-14    0.10000E+01    0.13538E+04    0.58546E-14    0.98498E-19    0.27589E-26
+    5    4    0.73873E-14    0.10000E+01    0.10918E+04    0.12286E-13    0.36723E-18    0.57896E-26
+    5    4    0.73873E-14    0.10000E+01    0.88049E+03    0.25236E-13    0.13520E-17    0.11892E-25
+    5    4    0.73873E-14    0.10000E+01    0.71007E+03    0.50847E-13    0.49231E-17    0.23961E-25
+    5    4    0.73873E-14    0.10000E+01    0.57264E+03    0.10074E-12    0.17516E-16    0.47474E-25
+    5    4    0.73873E-14    0.10000E+01    0.46180E+03    0.19638E-12    0.58912E-16    0.92541E-25
+    5    4    0.73873E-14    0.10000E+01    0.37242E+03    0.37477E-12    0.17963E-15    0.17661E-24
+    5    4    0.73873E-14    0.10000E+01    0.30034E+03    0.69216E-12    0.48181E-15    0.32617E-24
+    5    4    0.73873E-14    0.10000E+01    0.24221E+03    0.12194E-11    0.11250E-14    0.57463E-24
+    5    4    0.73873E-14    0.10000E+01    0.19533E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    5    4    0.73873E-14    0.10000E+01    0.15752E+03    0.19218E-11    0.21378E-14    0.90562E-24
+    5    4    0.12890E-13    0.10000E+01    0.80645E+05    0.13504E-62    0.22993E-73    0.63638E-75
+    5    4    0.12890E-13    0.10000E+01    0.65036E+05    0.24351E-61    0.70953E-72    0.11475E-73
+    5    4    0.12890E-13    0.10000E+01    0.52449E+05    0.40848E-60    0.23958E-70    0.19249E-72
+    5    4    0.12890E-13    0.10000E+01    0.42297E+05    0.71389E-59    0.80164E-69    0.33641E-71
+    5    4    0.12890E-13    0.10000E+01    0.34111E+05    0.12512E-57    0.26635E-67    0.58963E-70
+    5    4    0.12890E-13    0.10000E+01    0.27509E+05    0.21795E-56    0.87495E-66    0.10271E-68
+    5    4    0.12890E-13    0.10000E+01    0.22184E+05    0.37386E-55    0.27627E-64    0.17618E-67
+    5    4    0.12890E-13    0.10000E+01    0.17891E+05    0.61609E-54    0.81775E-63    0.29033E-66
+    5    4    0.12890E-13    0.10000E+01    0.14428E+05    0.95731E-53    0.22865E-61    0.45112E-65
+    5    4    0.12890E-13    0.10000E+01    0.11635E+05    0.14117E-51    0.62028E-60    0.66523E-64
+    5    4    0.12890E-13    0.10000E+01    0.93834E+04    0.20181E-50    0.16654E-58    0.95103E-63
+    5    4    0.12890E-13    0.10000E+01    0.75673E+04    0.28483E-49    0.44613E-57    0.13422E-61
+    5    4    0.12890E-13    0.10000E+01    0.61026E+04    0.40045E-48    0.11946E-55    0.18871E-60
+    5    4    0.12890E-13    0.10000E+01    0.49215E+04    0.56249E-47    0.31988E-54    0.26507E-59
+    5    4    0.12890E-13    0.10000E+01    0.39689E+04    0.78998E-46    0.85653E-53    0.37227E-58
+    5    4    0.12890E-13    0.10000E+01    0.32008E+04    0.34891E-43    0.74163E-50    0.16442E-55
+    5    4    0.12890E-13    0.10000E+01    0.25813E+04    0.25499E-34    0.12425E-40    0.12016E-46
+    5    4    0.12890E-13    0.10000E+01    0.20817E+04    0.48365E-18    0.10512E-23    0.22791E-30
+    5    4    0.12890E-13    0.10000E+01    0.16788E+04    0.16312E-12    0.15504E-17    0.76870E-25
+    5    4    0.12890E-13    0.10000E+01    0.13538E+04    0.34997E-12    0.58879E-17    0.16492E-24
+    5    4    0.12890E-13    0.10000E+01    0.10918E+04    0.73441E-12    0.21952E-16    0.34608E-24
+    5    4    0.12890E-13    0.10000E+01    0.88049E+03    0.15086E-11    0.80818E-16    0.71089E-24
+    5    4    0.12890E-13    0.10000E+01    0.71007E+03    0.30395E-11    0.29429E-15    0.14323E-23
+    5    4    0.12890E-13    0.10000E+01    0.57264E+03    0.60221E-11    0.10470E-14    0.28379E-23
+    5    4    0.12890E-13    0.10000E+01    0.46180E+03    0.11739E-10    0.35216E-14    0.55318E-23
+    5    4    0.12890E-13    0.10000E+01    0.37242E+03    0.22403E-10    0.10738E-13    0.10557E-22
+    5    4    0.12890E-13    0.10000E+01    0.30034E+03    0.41375E-10    0.28801E-13    0.19498E-22
+    5    4    0.12890E-13    0.10000E+01    0.24221E+03    0.72893E-10    0.67248E-13    0.34350E-22
+    5    4    0.12890E-13    0.10000E+01    0.19533E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    5    4    0.12890E-13    0.10000E+01    0.15752E+03    0.11488E-09    0.12779E-12    0.54135E-22
+    5    4    0.22493E-13    0.10000E+01    0.80645E+05    0.32360E-61    0.55097E-72    0.15249E-73
+    5    4    0.22493E-13    0.10000E+01    0.65036E+05    0.58352E-60    0.17002E-70    0.27498E-72
+    5    4    0.22493E-13    0.10000E+01    0.52449E+05    0.97882E-59    0.57411E-69    0.46126E-71
+    5    4    0.22493E-13    0.10000E+01    0.42297E+05    0.17107E-57    0.19209E-67    0.80613E-70
+    5    4    0.22493E-13    0.10000E+01    0.34111E+05    0.29983E-56    0.63825E-66    0.14129E-68
+    5    4    0.22493E-13    0.10000E+01    0.27509E+05    0.52226E-55    0.20966E-64    0.24611E-67
+    5    4    0.22493E-13    0.10000E+01    0.22184E+05    0.89588E-54    0.66200E-63    0.42217E-66
+    5    4    0.22493E-13    0.10000E+01    0.17891E+05    0.14763E-52    0.19595E-61    0.69570E-65
+    5    4    0.22493E-13    0.10000E+01    0.14428E+05    0.22940E-51    0.54791E-60    0.10810E-63
+    5    4    0.22493E-13    0.10000E+01    0.11635E+05    0.33827E-50    0.14864E-58    0.15941E-62
+    5    4    0.22493E-13    0.10000E+01    0.93834E+04    0.48360E-49    0.39909E-57    0.22789E-61
+    5    4    0.22493E-13    0.10000E+01    0.75673E+04    0.68254E-48    0.10690E-55    0.32164E-60
+    5    4    0.22493E-13    0.10000E+01    0.61026E+04    0.95958E-47    0.28626E-54    0.45219E-59
+    5    4    0.22493E-13    0.10000E+01    0.49215E+04    0.13479E-45    0.76652E-53    0.63517E-58
+    5    4    0.22493E-13    0.10000E+01    0.39689E+04    0.18930E-44    0.20525E-51    0.89206E-57
+    5    4    0.22493E-13    0.10000E+01    0.32008E+04    0.83608E-42    0.17771E-48    0.39399E-54
+    5    4    0.22493E-13    0.10000E+01    0.25813E+04    0.61102E-33    0.29773E-39    0.28794E-45
+    5    4    0.22493E-13    0.10000E+01    0.20817E+04    0.11589E-16    0.25190E-22    0.54614E-29
+    5    4    0.22493E-13    0.10000E+01    0.16788E+04    0.39089E-11    0.37153E-16    0.18420E-23
+    5    4    0.22493E-13    0.10000E+01    0.13538E+04    0.83863E-11    0.14109E-15    0.39519E-23
+    5    4    0.22493E-13    0.10000E+01    0.10918E+04    0.17598E-10    0.52602E-15    0.82930E-23
+    5    4    0.22493E-13    0.10000E+01    0.88049E+03    0.36149E-10    0.19366E-14    0.17035E-22
+    5    4    0.22493E-13    0.10000E+01    0.71007E+03    0.72835E-10    0.70520E-14    0.34322E-22
+    5    4    0.22493E-13    0.10000E+01    0.57264E+03    0.14431E-09    0.25089E-13    0.68002E-22
+    5    4    0.22493E-13    0.10000E+01    0.46180E+03    0.28130E-09    0.84386E-13    0.13256E-21
+    5    4    0.22493E-13    0.10000E+01    0.37242E+03    0.53683E-09    0.25731E-12    0.25297E-21
+    5    4    0.22493E-13    0.10000E+01    0.30034E+03    0.99146E-09    0.69015E-12    0.46722E-21
+    5    4    0.22493E-13    0.10000E+01    0.24221E+03    0.17467E-08    0.16114E-11    0.82311E-21
+    5    4    0.22493E-13    0.10000E+01    0.19533E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    5    4    0.22493E-13    0.10000E+01    0.15752E+03    0.27528E-08    0.30623E-11    0.12972E-20
+    5    4    0.39249E-13    0.10000E+01    0.80645E+05    0.36296E-60    0.61797E-71    0.17104E-72
+    5    4    0.39249E-13    0.10000E+01    0.65036E+05    0.65449E-59    0.19070E-69    0.30842E-71
+    5    4    0.39249E-13    0.10000E+01    0.52449E+05    0.10979E-57    0.64393E-68    0.51735E-70
+    5    4    0.39249E-13    0.10000E+01    0.42297E+05    0.19187E-56    0.21546E-66    0.90417E-69
+    5    4    0.39249E-13    0.10000E+01    0.34111E+05    0.33629E-55    0.71587E-65    0.15847E-67
+    5    4    0.39249E-13    0.10000E+01    0.27509E+05    0.58578E-54    0.23516E-63    0.27604E-66
+    5    4    0.39249E-13    0.10000E+01    0.22184E+05    0.10048E-52    0.74251E-62    0.47351E-65
+    5    4    0.39249E-13    0.10000E+01    0.17891E+05    0.16559E-51    0.21979E-60    0.78031E-64
+    5    4    0.39249E-13    0.10000E+01    0.14428E+05    0.25730E-50    0.61454E-59    0.12125E-62
+    5    4    0.39249E-13    0.10000E+01    0.11635E+05    0.37941E-49    0.16671E-57    0.17879E-61
+    5    4    0.39249E-13    0.10000E+01    0.93834E+04    0.54241E-48    0.44762E-56    0.25561E-60
+    5    4    0.39249E-13    0.10000E+01    0.75673E+04    0.76554E-47    0.11991E-54    0.36075E-59
+    5    4    0.39249E-13    0.10000E+01    0.61026E+04    0.10763E-45    0.32108E-53    0.50718E-58
+    5    4    0.39249E-13    0.10000E+01    0.49215E+04    0.15118E-44    0.85974E-52    0.71242E-57
+    5    4    0.39249E-13    0.10000E+01    0.39689E+04    0.21232E-43    0.23021E-50    0.10005E-55
+    5    4    0.39249E-13    0.10000E+01    0.32008E+04    0.93776E-41    0.19933E-47    0.44191E-53
+    5    4    0.39249E-13    0.10000E+01    0.25813E+04    0.68533E-32    0.33394E-38    0.32296E-44
+    5    4    0.39249E-13    0.10000E+01    0.20817E+04    0.12999E-15    0.28253E-21    0.61256E-28
+    5    4    0.39249E-13    0.10000E+01    0.16788E+04    0.43843E-10    0.41671E-15    0.20660E-22
+    5    4    0.39249E-13    0.10000E+01    0.13538E+04    0.94062E-10    0.15825E-14    0.44326E-22
+    5    4    0.39249E-13    0.10000E+01    0.10918E+04    0.19739E-09    0.58999E-14    0.93016E-22
+    5    4    0.39249E-13    0.10000E+01    0.88049E+03    0.40545E-09    0.21721E-13    0.19106E-21
+    5    4    0.39249E-13    0.10000E+01    0.71007E+03    0.81692E-09    0.79096E-13    0.38497E-21
+    5    4    0.39249E-13    0.10000E+01    0.57264E+03    0.16186E-08    0.28141E-12    0.76273E-21
+    5    4    0.39249E-13    0.10000E+01    0.46180E+03    0.31551E-08    0.94648E-12    0.14868E-20
+    5    4    0.39249E-13    0.10000E+01    0.37242E+03    0.60211E-08    0.28860E-11    0.28374E-20
+    5    4    0.39249E-13    0.10000E+01    0.30034E+03    0.11120E-07    0.77408E-11    0.52404E-20
+    5    4    0.39249E-13    0.10000E+01    0.24221E+03    0.19591E-07    0.18074E-10    0.92322E-20
+    5    4    0.39249E-13    0.10000E+01    0.19533E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    5    4    0.39249E-13    0.10000E+01    0.15752E+03    0.30876E-07    0.34347E-10    0.14550E-19
+    5    4    0.68487E-13    0.10000E+01    0.80645E+05    0.21528E-59    0.36654E-70    0.10145E-71
+    5    4    0.68487E-13    0.10000E+01    0.65036E+05    0.38820E-58    0.11311E-68    0.18293E-70
+    5    4    0.68487E-13    0.10000E+01    0.52449E+05    0.65117E-57    0.38193E-67    0.30686E-69
+    5    4    0.68487E-13    0.10000E+01    0.42297E+05    0.11381E-55    0.12779E-65    0.53630E-68
+    5    4    0.68487E-13    0.10000E+01    0.34111E+05    0.19947E-54    0.42460E-64    0.93997E-67
+    5    4    0.68487E-13    0.10000E+01    0.27509E+05    0.34744E-53    0.13948E-62    0.16373E-65
+    5    4    0.68487E-13    0.10000E+01    0.22184E+05    0.59600E-52    0.44041E-61    0.28086E-64
+    5    4    0.68487E-13    0.10000E+01    0.17891E+05    0.98215E-51    0.13036E-59    0.46283E-63
+    5    4    0.68487E-13    0.10000E+01    0.14428E+05    0.15261E-49    0.36451E-58    0.71916E-62
+    5    4    0.68487E-13    0.10000E+01    0.11635E+05    0.22504E-48    0.98883E-57    0.10605E-60
+    5    4    0.68487E-13    0.10000E+01    0.93834E+04    0.32172E-47    0.26550E-55    0.15161E-59
+    5    4    0.68487E-13    0.10000E+01    0.75673E+04    0.45407E-46    0.71120E-54    0.21398E-58
+    5    4    0.68487E-13    0.10000E+01    0.61026E+04    0.63837E-45    0.19044E-52    0.30083E-57
+    5    4    0.68487E-13    0.10000E+01    0.49215E+04    0.89670E-44    0.50994E-51    0.42256E-56
+    5    4    0.68487E-13    0.10000E+01    0.39689E+04    0.12594E-42    0.13654E-49    0.59346E-55
+    5    4    0.68487E-13    0.10000E+01    0.32008E+04    0.55622E-40    0.11823E-46    0.26211E-52
+    5    4    0.68487E-13    0.10000E+01    0.25813E+04    0.40649E-31    0.19807E-37    0.19156E-43
+    5    4    0.68487E-13    0.10000E+01    0.20817E+04    0.77101E-15    0.16758E-20    0.36333E-27
+    5    4    0.68487E-13    0.10000E+01    0.16788E+04    0.26005E-09    0.24716E-14    0.12254E-21
+    5    4    0.68487E-13    0.10000E+01    0.13538E+04    0.55791E-09    0.93862E-14    0.26291E-21
+    5    4    0.68487E-13    0.10000E+01    0.10918E+04    0.11708E-08    0.34995E-13    0.55171E-21
+    5    4    0.68487E-13    0.10000E+01    0.88049E+03    0.24049E-08    0.12884E-12    0.11333E-20
+    5    4    0.68487E-13    0.10000E+01    0.71007E+03    0.48454E-08    0.46914E-12    0.22834E-20
+    5    4    0.68487E-13    0.10000E+01    0.57264E+03    0.96002E-08    0.16691E-11    0.45240E-20
+    5    4    0.68487E-13    0.10000E+01    0.46180E+03    0.18714E-07    0.56139E-11    0.88186E-20
+    5    4    0.68487E-13    0.10000E+01    0.37242E+03    0.35713E-07    0.17118E-10    0.16829E-19
+    5    4    0.68487E-13    0.10000E+01    0.30034E+03    0.65959E-07    0.45913E-10    0.31082E-19
+    5    4    0.68487E-13    0.10000E+01    0.24221E+03    0.11620E-06    0.10720E-09    0.54759E-19
+    5    4    0.68487E-13    0.10000E+01    0.19533E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    5    4    0.68487E-13    0.10000E+01    0.15752E+03    0.18313E-06    0.20372E-09    0.86300E-19
+    5    4    0.11951E-12    0.10000E+01    0.80645E+05    0.76406E-59    0.13009E-69    0.36006E-71
+    5    4    0.11951E-12    0.10000E+01    0.65036E+05    0.13778E-57    0.40144E-68    0.64926E-70
+    5    4    0.11951E-12    0.10000E+01    0.52449E+05    0.23111E-56    0.13555E-66    0.10891E-68
+    5    4    0.11951E-12    0.10000E+01    0.42297E+05    0.40391E-55    0.45356E-65    0.19034E-67
+    5    4    0.11951E-12    0.10000E+01    0.34111E+05    0.70794E-54    0.15070E-63    0.33361E-66
+    5    4    0.11951E-12    0.10000E+01    0.27509E+05    0.12331E-52    0.49504E-62    0.58110E-65
+    5    4    0.11951E-12    0.10000E+01    0.22184E+05    0.21153E-51    0.15631E-60    0.99680E-64
+    5    4    0.11951E-12    0.10000E+01    0.17891E+05    0.34858E-50    0.46267E-59    0.16426E-62
+    5    4    0.11951E-12    0.10000E+01    0.14428E+05    0.54164E-49    0.12937E-57    0.25524E-61
+    5    4    0.11951E-12    0.10000E+01    0.11635E+05    0.79870E-48    0.35095E-56    0.37638E-60
+    5    4    0.11951E-12    0.10000E+01    0.93834E+04    0.11418E-46    0.94229E-55    0.53808E-59
+    5    4    0.11951E-12    0.10000E+01    0.75673E+04    0.16116E-45    0.25241E-53    0.75943E-58
+    5    4    0.11951E-12    0.10000E+01    0.61026E+04    0.22657E-44    0.67591E-52    0.10677E-56
+    5    4    0.11951E-12    0.10000E+01    0.49215E+04    0.31825E-43    0.18099E-50    0.14997E-55
+    5    4    0.11951E-12    0.10000E+01    0.39689E+04    0.44696E-42    0.48462E-49    0.21063E-54
+    5    4    0.11951E-12    0.10000E+01    0.32008E+04    0.19741E-39    0.41960E-46    0.93027E-52
+    5    4    0.11951E-12    0.10000E+01    0.25813E+04    0.14427E-30    0.70299E-37    0.67986E-43
+    5    4    0.11951E-12    0.10000E+01    0.20817E+04    0.27364E-14    0.59476E-20    0.12895E-26
+    5    4    0.11951E-12    0.10000E+01    0.16788E+04    0.92294E-09    0.87722E-14    0.43492E-21
+    5    4    0.11951E-12    0.10000E+01    0.13538E+04    0.19801E-08    0.33313E-13    0.93310E-21
+    5    4    0.11951E-12    0.10000E+01    0.10918E+04    0.41552E-08    0.12420E-12    0.19581E-20
+    5    4    0.11951E-12    0.10000E+01    0.88049E+03    0.85352E-08    0.45726E-12    0.40221E-20
+    5    4    0.11951E-12    0.10000E+01    0.71007E+03    0.17197E-07    0.16651E-11    0.81040E-20
+    5    4    0.11951E-12    0.10000E+01    0.57264E+03    0.34072E-07    0.59239E-11    0.16056E-19
+    5    4    0.11951E-12    0.10000E+01    0.46180E+03    0.66418E-07    0.19925E-10    0.31299E-19
+    5    4    0.11951E-12    0.10000E+01    0.37242E+03    0.12675E-06    0.60754E-10    0.59730E-19
+    5    4    0.11951E-12    0.10000E+01    0.30034E+03    0.23410E-06    0.16295E-09    0.11032E-18
+    5    4    0.11951E-12    0.10000E+01    0.24221E+03    0.41242E-06    0.38048E-09    0.19435E-18
+    5    4    0.11951E-12    0.10000E+01    0.19533E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    5    4    0.11951E-12    0.10000E+01    0.15752E+03    0.64997E-06    0.72304E-09    0.30629E-18
+    5    4    0.20853E-12    0.10000E+01    0.80645E+05    0.17546E-58    0.29874E-69    0.82687E-71
+    5    4    0.20853E-12    0.10000E+01    0.65036E+05    0.31640E-57    0.92189E-68    0.14910E-69
+    5    4    0.20853E-12    0.10000E+01    0.52449E+05    0.53073E-56    0.31129E-66    0.25010E-68
+    5    4    0.20853E-12    0.10000E+01    0.42297E+05    0.92756E-55    0.10416E-64    0.43711E-67
+    5    4    0.20853E-12    0.10000E+01    0.34111E+05    0.16257E-53    0.34607E-63    0.76612E-66
+    5    4    0.20853E-12    0.10000E+01    0.27509E+05    0.28318E-52    0.11368E-61    0.13345E-64
+    5    4    0.20853E-12    0.10000E+01    0.22184E+05    0.48576E-51    0.35895E-60    0.22891E-63
+    5    4    0.20853E-12    0.10000E+01    0.17891E+05    0.80049E-50    0.10625E-58    0.37723E-62
+    5    4    0.20853E-12    0.10000E+01    0.14428E+05    0.12438E-48    0.29709E-57    0.58615E-61
+    5    4    0.20853E-12    0.10000E+01    0.11635E+05    0.18342E-47    0.80593E-56    0.86434E-60
+    5    4    0.20853E-12    0.10000E+01    0.93834E+04    0.26222E-46    0.21639E-54    0.12357E-58
+    5    4    0.20853E-12    0.10000E+01    0.75673E+04    0.37008E-45    0.57965E-53    0.17440E-57
+    5    4    0.20853E-12    0.10000E+01    0.61026E+04    0.52030E-44    0.15522E-51    0.24519E-56
+    5    4    0.20853E-12    0.10000E+01    0.49215E+04    0.73084E-43    0.41562E-50    0.34441E-55
+    5    4    0.20853E-12    0.10000E+01    0.39689E+04    0.10264E-41    0.11129E-48    0.48370E-54
+    5    4    0.20853E-12    0.10000E+01    0.32008E+04    0.45334E-39    0.96359E-46    0.21363E-51
+    5    4    0.20853E-12    0.10000E+01    0.25813E+04    0.33131E-30    0.16144E-36    0.15613E-42
+    5    4    0.20853E-12    0.10000E+01    0.20817E+04    0.62840E-14    0.13658E-19    0.29613E-26
+    5    4    0.20853E-12    0.10000E+01    0.16788E+04    0.21195E-08    0.20145E-13    0.99879E-21
+    5    4    0.20853E-12    0.10000E+01    0.13538E+04    0.45472E-08    0.76502E-13    0.21428E-20
+    5    4    0.20853E-12    0.10000E+01    0.10918E+04    0.95422E-08    0.28522E-12    0.44967E-20
+    5    4    0.20853E-12    0.10000E+01    0.88049E+03    0.19601E-07    0.10501E-11    0.92367E-20
+    5    4    0.20853E-12    0.10000E+01    0.71007E+03    0.39492E-07    0.38237E-11    0.18611E-19
+    5    4    0.20853E-12    0.10000E+01    0.57264E+03    0.78245E-07    0.13604E-10    0.36873E-19
+    5    4    0.20853E-12    0.10000E+01    0.46180E+03    0.15252E-06    0.45756E-10    0.71876E-19
+    5    4    0.20853E-12    0.10000E+01    0.37242E+03    0.29108E-06    0.13952E-09    0.13717E-18
+    5    4    0.20853E-12    0.10000E+01    0.30034E+03    0.53759E-06    0.37421E-09    0.25334E-18
+    5    4    0.20853E-12    0.10000E+01    0.24221E+03    0.94710E-06    0.87375E-09    0.44632E-18
+    5    4    0.20853E-12    0.10000E+01    0.19533E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    5    4    0.20853E-12    0.10000E+01    0.15752E+03    0.14926E-05    0.16604E-08    0.70339E-18
+    5    4    0.36387E-12    0.10000E+01    0.80645E+05    0.28070E-58    0.47791E-69    0.13238E-70
+    5    4    0.36387E-12    0.10000E+01    0.65036E+05    0.50615E-57    0.14748E-67    0.23859E-69
+    5    4    0.36387E-12    0.10000E+01    0.52449E+05    0.84903E-56    0.49798E-66    0.40024E-68
+    5    4    0.36387E-12    0.10000E+01    0.42297E+05    0.14838E-54    0.16662E-64    0.69955E-67
+    5    4    0.36387E-12    0.10000E+01    0.34111E+05    0.26007E-53    0.55362E-63    0.12262E-65
+    5    4    0.36387E-12    0.10000E+01    0.27509E+05    0.45301E-52    0.18186E-61    0.21359E-64
+    5    4    0.36387E-12    0.10000E+01    0.22184E+05    0.77709E-51    0.57423E-60    0.36639E-63
+    5    4    0.36387E-12    0.10000E+01    0.17891E+05    0.12806E-49    0.16997E-58    0.60378E-62
+    5    4    0.36387E-12    0.10000E+01    0.14428E+05    0.19898E-48    0.47526E-57    0.93819E-61
+    5    4    0.36387E-12    0.10000E+01    0.11635E+05    0.29342E-47    0.12893E-55    0.13835E-59
+    5    4    0.36387E-12    0.10000E+01    0.93834E+04    0.41948E-46    0.34617E-54    0.19778E-58
+    5    4    0.36387E-12    0.10000E+01    0.75673E+04    0.59204E-45    0.92729E-53    0.27914E-57
+    5    4    0.36387E-12    0.10000E+01    0.61026E+04    0.83234E-44    0.24831E-51    0.39245E-56
+    5    4    0.36387E-12    0.10000E+01    0.49215E+04    0.11692E-42    0.66489E-50    0.55125E-55
+    5    4    0.36387E-12    0.10000E+01    0.39689E+04    0.16420E-41    0.17803E-48    0.77420E-54
+    5    4    0.36387E-12    0.10000E+01    0.32008E+04    0.72522E-39    0.15415E-45    0.34194E-51
+    5    4    0.36387E-12    0.10000E+01    0.25813E+04    0.53001E-30    0.25826E-36    0.24990E-42
+    5    4    0.36387E-12    0.10000E+01    0.20817E+04    0.10053E-13    0.21850E-19    0.47399E-26
+    5    4    0.36387E-12    0.10000E+01    0.16788E+04    0.33906E-08    0.32227E-13    0.15987E-20
+    5    4    0.36387E-12    0.10000E+01    0.13538E+04    0.72743E-08    0.12238E-12    0.34298E-20
+    5    4    0.36387E-12    0.10000E+01    0.10918E+04    0.15265E-07    0.45628E-12    0.71974E-20
+    5    4    0.36387E-12    0.10000E+01    0.88049E+03    0.31356E-07    0.16798E-11    0.14784E-19
+    5    4    0.36387E-12    0.10000E+01    0.71007E+03    0.63177E-07    0.61169E-11    0.29788E-19
+    5    4    0.36387E-12    0.10000E+01    0.57264E+03    0.12517E-06    0.21763E-10    0.59018E-19
+    5    4    0.36387E-12    0.10000E+01    0.46180E+03    0.24400E-06    0.73197E-10    0.11504E-18
+    5    4    0.36387E-12    0.10000E+01    0.37242E+03    0.46565E-06    0.22319E-09    0.21955E-18
+    5    4    0.36387E-12    0.10000E+01    0.30034E+03    0.86000E-06    0.59864E-09    0.40549E-18
+    5    4    0.36387E-12    0.10000E+01    0.24221E+03    0.15151E-05    0.13978E-08    0.71437E-18
+    5    4    0.36387E-12    0.10000E+01    0.19533E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    5    4    0.36387E-12    0.10000E+01    0.15752E+03    0.23878E-05    0.26562E-08    0.11258E-17
+    5    4    0.63493E-12    0.10000E+01    0.80645E+05    0.33275E-58    0.56632E-69    0.15909E-70
+    5    4    0.63493E-12    0.10000E+01    0.65036E+05    0.59981E-57    0.17477E-67    0.28431E-69
+    5    4    0.63493E-12    0.10000E+01    0.52449E+05    0.10062E-55    0.59019E-66    0.47735E-68
+    5    4    0.63493E-12    0.10000E+01    0.42297E+05    0.17586E-54    0.19748E-64    0.83566E-67
+    5    4    0.63493E-12    0.10000E+01    0.34111E+05    0.30824E-53    0.65617E-63    0.14662E-65
+    5    4    0.63493E-12    0.10000E+01    0.27509E+05    0.53693E-52    0.21555E-61    0.25553E-64
+    5    4    0.63493E-12    0.10000E+01    0.22184E+05    0.92104E-51    0.68060E-60    0.43845E-63
+    5    4    0.63493E-12    0.10000E+01    0.17891E+05    0.15178E-49    0.20146E-58    0.72262E-62
+    5    4    0.63493E-12    0.10000E+01    0.14428E+05    0.23584E-48    0.56330E-57    0.11229E-60
+    5    4    0.63493E-12    0.10000E+01    0.11635E+05    0.34777E-47    0.15281E-55    0.16558E-59
+    5    4    0.63493E-12    0.10000E+01    0.93834E+04    0.49719E-46    0.41030E-54    0.23672E-58
+    5    4    0.63493E-12    0.10000E+01    0.75673E+04    0.70171E-45    0.10991E-52    0.33410E-57
+    5    4    0.63493E-12    0.10000E+01    0.61026E+04    0.98653E-44    0.29431E-51    0.46971E-56
+    5    4    0.63493E-12    0.10000E+01    0.49215E+04    0.13857E-42    0.78806E-50    0.65979E-55
+    5    4    0.63493E-12    0.10000E+01    0.39689E+04    0.19462E-41    0.21101E-48    0.92664E-54
+    5    4    0.63493E-12    0.10000E+01    0.32008E+04    0.85957E-39    0.18271E-45    0.40928E-51
+    5    4    0.63493E-12    0.10000E+01    0.25813E+04    0.62819E-30    0.30610E-36    0.29911E-42
+    5    4    0.63493E-12    0.10000E+01    0.20817E+04    0.11915E-13    0.25898E-19    0.56734E-26
+    5    4    0.63493E-12    0.10000E+01    0.16788E+04    0.40187E-08    0.38197E-13    0.19135E-20
+    5    4    0.63493E-12    0.10000E+01    0.13538E+04    0.86219E-08    0.14505E-12    0.41054E-20
+    5    4    0.63493E-12    0.10000E+01    0.10918E+04    0.18093E-07    0.54080E-12    0.86151E-20
+    5    4    0.63493E-12    0.10000E+01    0.88049E+03    0.37165E-07    0.19910E-11    0.17696E-19
+    5    4    0.63493E-12    0.10000E+01    0.71007E+03    0.74881E-07    0.72501E-11    0.35656E-19
+    5    4    0.63493E-12    0.10000E+01    0.57264E+03    0.14836E-06    0.25794E-10    0.70644E-19
+    5    4    0.63493E-12    0.10000E+01    0.46180E+03    0.28920E-06    0.86757E-10    0.13771E-18
+    5    4    0.63493E-12    0.10000E+01    0.37242E+03    0.55191E-06    0.26454E-09    0.26280E-18
+    5    4    0.63493E-12    0.10000E+01    0.30034E+03    0.10193E-05    0.70954E-09    0.48537E-18
+    5    4    0.63493E-12    0.10000E+01    0.24221E+03    0.17958E-05    0.16567E-08    0.85509E-18
+    5    4    0.63493E-12    0.10000E+01    0.19533E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    5    4    0.63493E-12    0.10000E+01    0.15752E+03    0.28301E-05    0.31483E-08    0.13476E-17
+    5    4    0.11079E-11    0.10000E+01    0.80645E+05    0.30904E-58    0.52383E-69    0.17003E-70
+    5    4    0.11079E-11    0.10000E+01    0.65036E+05    0.55514E-57    0.16181E-67    0.27933E-69
+    5    4    0.11079E-11    0.10000E+01    0.52449E+05    0.93157E-56    0.54681E-66    0.47307E-68
+    5    4    0.11079E-11    0.10000E+01    0.42297E+05    0.16293E-54    0.18304E-64    0.84161E-67
+    5    4    0.11079E-11    0.10000E+01    0.34111E+05    0.28569E-53    0.60830E-63    0.14911E-65
+    5    4    0.11079E-11    0.10000E+01    0.27509E+05    0.49775E-52    0.19985E-61    0.26124E-64
+    5    4    0.11079E-11    0.10000E+01    0.22184E+05    0.85393E-51    0.63104E-60    0.44941E-63
+    5    4    0.11079E-11    0.10000E+01    0.17891E+05    0.14073E-49    0.18679E-58    0.74151E-62
+    5    4    0.11079E-11    0.10000E+01    0.14428E+05    0.21867E-48    0.52229E-57    0.11527E-60
+    5    4    0.11079E-11    0.10000E+01    0.11635E+05    0.32245E-47    0.14169E-55    0.16998E-59
+    5    4    0.11079E-11    0.10000E+01    0.93834E+04    0.46099E-46    0.38043E-54    0.24300E-58
+    5    4    0.11079E-11    0.10000E+01    0.75673E+04    0.65062E-45    0.10191E-52    0.34297E-57
+    5    4    0.11079E-11    0.10000E+01    0.61026E+04    0.91471E-44    0.27288E-51    0.48222E-56
+    5    4    0.11079E-11    0.10000E+01    0.49215E+04    0.12849E-42    0.73069E-50    0.67744E-55
+    5    4    0.11079E-11    0.10000E+01    0.39689E+04    0.18045E-41    0.19565E-48    0.95157E-54
+    5    4    0.11079E-11    0.10000E+01    0.32008E+04    0.79701E-39    0.16941E-45    0.42034E-51
+    5    4    0.11079E-11    0.10000E+01    0.25813E+04    0.58247E-30    0.28382E-36    0.30725E-42
+    5    4    0.11079E-11    0.10000E+01    0.20817E+04    0.11048E-13    0.24013E-19    0.58287E-26
+    5    4    0.11079E-11    0.10000E+01    0.16788E+04    0.37263E-08    0.35417E-13    0.19661E-20
+    5    4    0.11079E-11    0.10000E+01    0.13538E+04    0.79945E-08    0.13450E-12    0.42184E-20
+    5    4    0.11079E-11    0.10000E+01    0.10918E+04    0.16776E-07    0.50145E-12    0.88525E-20
+    5    4    0.11079E-11    0.10000E+01    0.88049E+03    0.34460E-07    0.18461E-11    0.18184E-19
+    5    4    0.11079E-11    0.10000E+01    0.71007E+03    0.69432E-07    0.67226E-11    0.36639E-19
+    5    4    0.11079E-11    0.10000E+01    0.57264E+03    0.13757E-06    0.23918E-10    0.72594E-19
+    5    4    0.11079E-11    0.10000E+01    0.46180E+03    0.26816E-06    0.80444E-10    0.14151E-18
+    5    4    0.11079E-11    0.10000E+01    0.37242E+03    0.51175E-06    0.24529E-09    0.27006E-18
+    5    4    0.11079E-11    0.10000E+01    0.30034E+03    0.94515E-06    0.65791E-09    0.49877E-18
+    5    4    0.11079E-11    0.10000E+01    0.24221E+03    0.16651E-05    0.15362E-08    0.87870E-18
+    5    4    0.11079E-11    0.10000E+01    0.19533E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    5    4    0.11079E-11    0.10000E+01    0.15752E+03    0.26242E-05    0.29192E-08    0.13848E-17
+    5    4    0.19333E-11    0.10000E+01    0.80645E+05    0.24191E-58    0.39834E-69    0.25960E-70
+    5    4    0.19333E-11    0.10000E+01    0.65036E+05    0.42393E-57    0.12381E-67    0.30597E-69
+    5    4    0.19333E-11    0.10000E+01    0.52449E+05    0.71310E-56    0.42061E-66    0.53440E-68
+    5    4    0.19333E-11    0.10000E+01    0.42297E+05    0.12529E-54    0.14118E-64    0.10145E-66
+    5    4    0.19333E-11    0.10000E+01    0.34111E+05    0.22031E-53    0.46986E-63    0.18676E-65
+    5    4    0.19333E-11    0.10000E+01    0.27509E+05    0.38443E-52    0.15448E-61    0.33396E-64
+    5    4    0.19333E-11    0.10000E+01    0.22184E+05    0.66002E-51    0.48793E-60    0.58035E-63
+    5    4    0.19333E-11    0.10000E+01    0.17891E+05    0.10881E-49    0.14444E-58    0.96172E-62
+    5    4    0.19333E-11    0.10000E+01    0.14428E+05    0.16909E-48    0.40387E-57    0.14970E-60
+    5    4    0.19333E-11    0.10000E+01    0.11635E+05    0.24934E-47    0.10956E-55    0.22079E-59
+    5    4    0.19333E-11    0.10000E+01    0.93834E+04    0.35646E-46    0.29417E-54    0.31561E-58
+    5    4    0.19333E-11    0.10000E+01    0.75673E+04    0.50310E-45    0.78802E-53    0.44549E-57
+    5    4    0.19333E-11    0.10000E+01    0.61026E+04    0.70733E-44    0.21102E-51    0.62656E-56
+    5    4    0.19333E-11    0.10000E+01    0.49215E+04    0.99360E-43    0.56508E-50    0.88063E-55
+    5    4    0.19333E-11    0.10000E+01    0.39689E+04    0.13955E-41    0.15131E-48    0.12376E-53
+    5    4    0.19333E-11    0.10000E+01    0.32008E+04    0.61638E-39    0.13102E-45    0.54701E-51
+    5    4    0.19333E-11    0.10000E+01    0.25813E+04    0.45049E-30    0.21952E-36    0.40005E-42
+    5    4    0.19333E-11    0.10000E+01    0.20817E+04    0.85450E-14    0.18574E-19    0.75943E-26
+    5    4    0.19333E-11    0.10000E+01    0.16788E+04    0.28822E-08    0.27395E-13    0.25628E-20
+    5    4    0.19333E-11    0.10000E+01    0.13538E+04    0.61836E-08    0.10403E-12    0.54993E-20
+    5    4    0.19333E-11    0.10000E+01    0.10918E+04    0.12976E-07    0.38787E-12    0.11542E-19
+    5    4    0.19333E-11    0.10000E+01    0.88049E+03    0.26655E-07    0.14280E-11    0.23710E-19
+    5    4    0.19333E-11    0.10000E+01    0.71007E+03    0.53705E-07    0.51999E-11    0.47776E-19
+    5    4    0.19333E-11    0.10000E+01    0.57264E+03    0.10641E-06    0.18500E-10    0.94663E-19
+    5    4    0.19333E-11    0.10000E+01    0.46180E+03    0.20742E-06    0.62223E-10    0.18453E-18
+    5    4    0.19333E-11    0.10000E+01    0.37242E+03    0.39584E-06    0.18973E-09    0.35217E-18
+    5    4    0.19333E-11    0.10000E+01    0.30034E+03    0.73107E-06    0.50889E-09    0.65042E-18
+    5    4    0.19333E-11    0.10000E+01    0.24221E+03    0.12880E-05    0.11882E-08    0.11459E-17
+    5    4    0.19333E-11    0.10000E+01    0.19533E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    5    4    0.19333E-11    0.10000E+01    0.15752E+03    0.20298E-05    0.22580E-08    0.18059E-17
+    5    4    0.33734E-11    0.10000E+01    0.80645E+05    0.18741E-58    0.27125E-69    0.69297E-70
+    5    4    0.33734E-11    0.10000E+01    0.65036E+05    0.29435E-57    0.86520E-68    0.58677E-69
+    5    4    0.33734E-11    0.10000E+01    0.52449E+05    0.49917E-56    0.30033E-66    0.97590E-68
+    5    4    0.33734E-11    0.10000E+01    0.42297E+05    0.89369E-55    0.10197E-64    0.19081E-66
+    5    4    0.33734E-11    0.10000E+01    0.34111E+05    0.15902E-53    0.34153E-63    0.36172E-65
+    5    4    0.33734E-11    0.10000E+01    0.27509E+05    0.27930E-52    0.11264E-61    0.65986E-64
+    5    4    0.33734E-11    0.10000E+01    0.22184E+05    0.48111E-51    0.35624E-60    0.11592E-62
+    5    4    0.33734E-11    0.10000E+01    0.17891E+05    0.79425E-50    0.10550E-58    0.19302E-61
+    5    4    0.33734E-11    0.10000E+01    0.14428E+05    0.12349E-48    0.29497E-57    0.30095E-60
+    5    4    0.33734E-11    0.10000E+01    0.11635E+05    0.18210E-47    0.80012E-56    0.44397E-59
+    5    4    0.33734E-11    0.10000E+01    0.93834E+04    0.26033E-46    0.21484E-54    0.63459E-58
+    5    4    0.33734E-11    0.10000E+01    0.75673E+04    0.36743E-45    0.57557E-53    0.89580E-57
+    5    4    0.33734E-11    0.10000E+01    0.61026E+04    0.51664E-44    0.15416E-51    0.12603E-55
+    5    4    0.33734E-11    0.10000E+01    0.49215E+04    0.72584E-43    0.41287E-50    0.17722E-54
+    5    4    0.33734E-11    0.10000E+01    0.39689E+04    0.10196E-41    0.11058E-48    0.24919E-53
+    5    4    0.33734E-11    0.10000E+01    0.32008E+04    0.45044E-39    0.95765E-46    0.11020E-50
+    5    4    0.33734E-11    0.10000E+01    0.25813E+04    0.32927E-30    0.16048E-36    0.80639E-42
+    5    4    0.33734E-11    0.10000E+01    0.20817E+04    0.62470E-14    0.13581E-19    0.15318E-25
+    5    4    0.33734E-11    0.10000E+01    0.16788E+04    0.21074E-08    0.20033E-13    0.51715E-20
+    5    4    0.33734E-11    0.10000E+01    0.13538E+04    0.45215E-08    0.76078E-13    0.11099E-19
+    5    4    0.33734E-11    0.10000E+01    0.10918E+04    0.94886E-08    0.28364E-12    0.23296E-19
+    5    4    0.33734E-11    0.10000E+01    0.88049E+03    0.19491E-07    0.10443E-11    0.47861E-19
+    5    4    0.33734E-11    0.10000E+01    0.71007E+03    0.39273E-07    0.38026E-11    0.96445E-19
+    5    4    0.33734E-11    0.10000E+01    0.57264E+03    0.77812E-07    0.13529E-10    0.19110E-18
+    5    4    0.33734E-11    0.10000E+01    0.46180E+03    0.15168E-06    0.45503E-10    0.37253E-18
+    5    4    0.33734E-11    0.10000E+01    0.37242E+03    0.28947E-06    0.13875E-09    0.71096E-18
+    5    4    0.33734E-11    0.10000E+01    0.30034E+03    0.53462E-06    0.37215E-09    0.13131E-17
+    5    4    0.33734E-11    0.10000E+01    0.24221E+03    0.94187E-06    0.86894E-09    0.23134E-17
+    5    4    0.33734E-11    0.10000E+01    0.19533E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    5    4    0.33734E-11    0.10000E+01    0.15752E+03    0.14844E-05    0.16513E-08    0.36459E-17
+    5    4    0.58864E-11    0.10000E+01    0.80645E+05    0.18689E-58    0.19563E-69    0.24275E-69
+    5    4    0.58864E-11    0.10000E+01    0.65036E+05    0.22384E-57    0.64768E-68    0.18937E-68
+    5    4    0.58864E-11    0.10000E+01    0.52449E+05    0.37599E-56    0.23344E-66    0.24352E-67
+    5    4    0.58864E-11    0.10000E+01    0.42297E+05    0.69427E-55    0.81214E-65    0.40614E-66
+    5    4    0.58864E-11    0.10000E+01    0.34111E+05    0.12653E-53    0.27613E-63    0.74282E-65
+    5    4    0.58864E-11    0.10000E+01    0.27509E+05    0.22560E-52    0.91771E-62    0.13616E-63
+    5    4    0.58864E-11    0.10000E+01    0.22184E+05    0.39170E-51    0.29119E-60    0.24117E-62
+    5    4    0.58864E-11    0.10000E+01    0.17891E+05    0.64894E-50    0.86313E-59    0.40344E-61
+    5    4    0.58864E-11    0.10000E+01    0.14428E+05    0.10101E-48    0.24133E-57    0.63016E-60
+    5    4    0.58864E-11    0.10000E+01    0.11635E+05    0.14898E-47    0.65454E-56    0.93008E-59
+    5    4    0.58864E-11    0.10000E+01    0.93834E+04    0.21297E-46    0.17576E-54    0.13295E-57
+    5    4    0.58864E-11    0.10000E+01    0.75673E+04    0.30061E-45    0.47100E-53    0.18769E-56
+    5    4    0.58864E-11    0.10000E+01    0.61026E+04    0.42278E-44    0.12620E-51    0.26413E-55
+    5    4    0.58864E-11    0.10000E+01    0.49215E+04    0.59418E-43    0.33813E-50    0.37151E-54
+    5    4    0.58864E-11    0.10000E+01    0.39689E+04    0.83502E-42    0.90597E-49    0.52258E-53
+    5    4    0.58864E-11    0.10000E+01    0.32008E+04    0.36904E-39    0.78492E-46    0.23118E-50
+    5    4    0.58864E-11    0.10000E+01    0.25813E+04    0.26988E-30    0.13159E-36    0.16923E-41
+    5    4    0.58864E-11    0.10000E+01    0.20817E+04    0.51229E-14    0.11142E-19    0.32160E-25
+    5    4    0.58864E-11    0.10000E+01    0.16788E+04    0.17287E-08    0.16439E-13    0.10860E-19
+    5    4    0.58864E-11    0.10000E+01    0.13538E+04    0.37095E-08    0.62430E-13    0.23310E-19
+    5    4    0.58864E-11    0.10000E+01    0.10918E+04    0.77853E-08    0.23276E-12    0.48931E-19
+    5    4    0.58864E-11    0.10000E+01    0.88049E+03    0.15993E-07    0.85695E-12    0.10053E-18
+    5    4    0.58864E-11    0.10000E+01    0.71007E+03    0.32226E-07    0.31205E-11    0.20259E-18
+    5    4    0.58864E-11    0.10000E+01    0.57264E+03    0.63852E-07    0.11102E-10    0.40143E-18
+    5    4    0.58864E-11    0.10000E+01    0.46180E+03    0.12447E-06    0.37341E-10    0.78256E-18
+    5    4    0.58864E-11    0.10000E+01    0.37242E+03    0.23754E-06    0.11386E-09    0.14935E-17
+    5    4    0.58864E-11    0.10000E+01    0.30034E+03    0.43872E-06    0.30539E-09    0.27584E-17
+    5    4    0.58864E-11    0.10000E+01    0.24221E+03    0.77292E-06    0.71307E-09    0.48597E-17
+    5    4    0.58864E-11    0.10000E+01    0.19533E+03    0.12181E-05    0.13551E-08    0.76589E-17
+    5    4    0.58864E-11    0.10000E+01    0.15752E+03    0.12181E-05    0.13551E-08    0.76589E-17
+    5    4    0.10271E-10    0.10000E+01    0.80645E+05    0.28414E-58    0.21332E-69    0.93850E-69
+    5    4    0.10271E-10    0.10000E+01    0.65036E+05    0.25635E-57    0.63461E-68    0.74083E-68
+    5    4    0.10271E-10    0.10000E+01    0.52449E+05    0.37373E-56    0.21989E-66    0.72098E-67
+    5    4    0.10271E-10    0.10000E+01    0.42297E+05    0.65994E-55    0.77353E-65    0.85779E-66
+    5    4    0.10271E-10    0.10000E+01    0.34111E+05    0.12083E-53    0.26771E-63    0.13594E-64
+    5    4    0.10271E-10    0.10000E+01    0.27509E+05    0.21863E-52    0.89939E-62    0.24498E-63
+    5    4    0.10271E-10    0.10000E+01    0.22184E+05    0.38356E-51    0.28676E-60    0.43829E-62
+    5    4    0.10271E-10    0.10000E+01    0.17891E+05    0.63867E-50    0.85127E-59    0.73923E-61
+    5    4    0.10271E-10    0.10000E+01    0.14428E+05    0.99592E-49    0.23804E-57    0.11590E-59
+    5    4    0.10271E-10    0.10000E+01    0.11635E+05    0.14694E-47    0.64554E-56    0.17127E-58
+    5    4    0.10271E-10    0.10000E+01    0.93834E+04    0.21005E-46    0.17336E-54    0.24491E-57
+    5    4    0.10271E-10    0.10000E+01    0.75673E+04    0.29651E-45    0.46472E-53    0.34583E-56
+    5    4    0.10271E-10    0.10000E+01    0.61026E+04    0.41714E-44    0.12457E-51    0.48682E-55
+    5    4    0.10271E-10    0.10000E+01    0.49215E+04    0.58652E-43    0.33394E-50    0.68507E-54
+    5    4    0.10271E-10    0.10000E+01    0.39689E+04    0.82466E-42    0.89520E-49    0.96412E-53
+    5    4    0.10271E-10    0.10000E+01    0.32008E+04    0.36465E-39    0.77597E-46    0.42672E-50
+    5    4    0.10271E-10    0.10000E+01    0.25813E+04    0.26681E-30    0.13016E-36    0.31254E-41
+    5    4    0.10271E-10    0.10000E+01    0.20817E+04    0.50677E-14    0.11028E-19    0.59431E-25
+    5    4    0.10271E-10    0.10000E+01    0.16788E+04    0.17108E-08    0.16274E-13    0.20078E-19
+    5    4    0.10271E-10    0.10000E+01    0.13538E+04    0.36715E-08    0.61808E-13    0.43099E-19
+    5    4    0.10271E-10    0.10000E+01    0.10918E+04    0.77063E-08    0.23045E-12    0.90481E-19
+    5    4    0.10271E-10    0.10000E+01    0.88049E+03    0.15832E-07    0.84843E-12    0.18591E-18
+    5    4    0.10271E-10    0.10000E+01    0.71007E+03    0.31903E-07    0.30895E-11    0.37466E-18
+    5    4    0.10271E-10    0.10000E+01    0.57264E+03    0.63214E-07    0.10992E-10    0.74242E-18
+    5    4    0.10271E-10    0.10000E+01    0.46180E+03    0.12323E-06    0.36970E-10    0.14473E-17
+    5    4    0.10271E-10    0.10000E+01    0.37242E+03    0.23518E-06    0.11273E-09    0.27622E-17
+    5    4    0.10271E-10    0.10000E+01    0.30034E+03    0.43435E-06    0.30236E-09    0.51017E-17
+    5    4    0.10271E-10    0.10000E+01    0.24221E+03    0.76523E-06    0.70598E-09    0.89881E-17
+    5    4    0.10271E-10    0.10000E+01    0.19533E+03    0.12060E-05    0.13416E-08    0.14165E-16
+    5    4    0.10271E-10    0.10000E+01    0.15752E+03    0.12060E-05    0.13416E-08    0.14165E-16
+    5    4    0.17923E-10    0.10000E+01    0.80645E+05    0.56648E-58    0.38644E-69    0.35470E-68
+    5    4    0.17923E-10    0.10000E+01    0.65036E+05    0.45945E-57    0.85717E-68    0.28594E-67
+    5    4    0.17923E-10    0.10000E+01    0.52449E+05    0.51457E-56    0.23653E-66    0.24292E-66
+    5    4    0.17923E-10    0.10000E+01    0.42297E+05    0.73222E-55    0.79180E-65    0.21017E-65
+    5    4    0.17923E-10    0.10000E+01    0.34111E+05    0.12524E-53    0.27667E-63    0.25066E-64
+    5    4    0.17923E-10    0.10000E+01    0.27509E+05    0.22643E-52    0.94110E-62    0.41282E-63
+    5    4    0.17923E-10    0.10000E+01    0.22184E+05    0.40115E-51    0.30205E-60    0.73771E-62
+    5    4    0.17923E-10    0.10000E+01    0.17891E+05    0.67224E-50    0.89880E-59    0.12585E-60
+    5    4    0.17923E-10    0.10000E+01    0.14428E+05    0.10511E-48    0.25146E-57    0.19866E-59
+    5    4    0.17923E-10    0.10000E+01    0.11635E+05    0.15520E-47    0.68193E-56    0.29437E-58
+    5    4    0.17923E-10    0.10000E+01    0.93834E+04    0.22189E-46    0.18315E-54    0.42131E-57
+    5    4    0.17923E-10    0.10000E+01    0.75673E+04    0.31327E-45    0.49114E-53    0.59524E-56
+    5    4    0.17923E-10    0.10000E+01    0.61026E+04    0.44086E-44    0.13171E-51    0.83845E-55
+    5    4    0.17923E-10    0.10000E+01    0.49215E+04    0.62014E-43    0.35327E-50    0.11808E-53
+    5    4    0.17923E-10    0.10000E+01    0.39689E+04    0.87236E-42    0.94748E-49    0.16632E-52
+    5    4    0.17923E-10    0.10000E+01    0.32008E+04    0.38594E-39    0.82169E-46    0.73679E-50
+    5    4    0.17923E-10    0.10000E+01    0.25813E+04    0.28253E-30    0.13790E-36    0.54013E-41
+    5    4    0.17923E-10    0.10000E+01    0.20817E+04    0.53697E-14    0.11691E-19    0.10282E-24
+    5    4    0.17923E-10    0.10000E+01    0.16788E+04    0.18134E-08    0.17257E-13    0.34758E-19
+    5    4    0.17923E-10    0.10000E+01    0.13538E+04    0.38923E-08    0.65542E-13    0.74631E-19
+    5    4    0.17923E-10    0.10000E+01    0.10918E+04    0.81705E-08    0.24438E-12    0.15670E-18
+    5    4    0.17923E-10    0.10000E+01    0.88049E+03    0.16787E-07    0.89972E-12    0.32203E-18
+    5    4    0.17923E-10    0.10000E+01    0.71007E+03    0.33829E-07    0.32763E-11    0.64902E-18
+    5    4    0.17923E-10    0.10000E+01    0.57264E+03    0.67032E-07    0.11656E-10    0.12862E-17
+    5    4    0.17923E-10    0.10000E+01    0.46180E+03    0.13067E-06    0.39205E-10    0.25074E-17
+    5    4    0.17923E-10    0.10000E+01    0.37242E+03    0.24939E-06    0.11954E-09    0.47855E-17
+    5    4    0.17923E-10    0.10000E+01    0.30034E+03    0.46061E-06    0.32064E-09    0.88387E-17
+    5    4    0.17923E-10    0.10000E+01    0.24221E+03    0.81149E-06    0.74866E-09    0.15572E-16
+    5    4    0.17923E-10    0.10000E+01    0.19533E+03    0.12789E-05    0.14227E-08    0.24542E-16
+    5    4    0.17923E-10    0.10000E+01    0.15752E+03    0.12789E-05    0.14227E-08    0.24542E-16
+    5    4    0.31275E-10    0.10000E+01    0.80645E+05    0.12063E-57    0.83710E-69    0.12812E-67
+    5    4    0.31275E-10    0.10000E+01    0.65036E+05    0.97103E-57    0.14703E-67    0.10514E-66
+    5    4    0.31275E-10    0.10000E+01    0.52449E+05    0.89402E-56    0.28699E-66    0.86582E-66
+    5    4    0.31275E-10    0.10000E+01    0.42297E+05    0.93483E-55    0.81520E-65    0.64482E-65
+    5    4    0.31275E-10    0.10000E+01    0.34111E+05    0.13282E-53    0.27885E-63    0.56396E-64
+    5    4    0.31275E-10    0.10000E+01    0.27509E+05    0.23010E-52    0.95921E-62    0.73562E-63
+    5    4    0.31275E-10    0.10000E+01    0.22184E+05    0.40922E-51    0.31085E-60    0.12367E-61
+    5    4    0.31275E-10    0.10000E+01    0.17891E+05    0.69132E-50    0.92896E-59    0.21138E-60
+    5    4    0.31275E-10    0.10000E+01    0.14428E+05    0.10857E-48    0.26021E-57    0.33653E-59
+    5    4    0.31275E-10    0.10000E+01    0.11635E+05    0.16056E-47    0.70587E-56    0.50097E-58
+    5    4    0.31275E-10    0.10000E+01    0.93834E+04    0.22966E-46    0.18963E-54    0.71842E-57
+    5    4    0.31275E-10    0.10000E+01    0.75673E+04    0.32436E-45    0.50874E-53    0.10162E-55
+    5    4    0.31275E-10    0.10000E+01    0.61026E+04    0.45666E-44    0.13651E-51    0.14329E-54
+    5    4    0.31275E-10    0.10000E+01    0.49215E+04    0.64273E-43    0.36638E-50    0.20205E-53
+    5    4    0.31275E-10    0.10000E+01    0.39689E+04    0.90470E-42    0.98325E-49    0.28495E-52
+    5    4    0.31275E-10    0.10000E+01    0.32008E+04    0.40049E-39    0.85323E-46    0.12639E-49
+    5    4    0.31275E-10    0.10000E+01    0.25813E+04    0.29338E-30    0.14329E-36    0.92776E-41
+    5    4    0.31275E-10    0.10000E+01    0.20817E+04    0.55801E-14    0.12157E-19    0.17688E-24
+    5    4    0.31275E-10    0.10000E+01    0.16788E+04    0.18854E-08    0.17951E-13    0.59853E-19
+    5    4    0.31275E-10    0.10000E+01    0.13538E+04    0.40475E-08    0.68180E-13    0.12856E-18
+    5    4    0.31275E-10    0.10000E+01    0.10918E+04    0.84974E-08    0.25422E-12    0.27000E-18
+    5    4    0.31275E-10    0.10000E+01    0.88049E+03    0.17460E-07    0.93596E-12    0.55494E-18
+    5    4    0.31275E-10    0.10000E+01    0.71007E+03    0.35188E-07    0.34083E-11    0.11186E-17
+    5    4    0.31275E-10    0.10000E+01    0.57264E+03    0.69728E-07    0.12126E-10    0.22169E-17
+    5    4    0.31275E-10    0.10000E+01    0.46180E+03    0.13593E-06    0.40784E-10    0.43221E-17
+    5    4    0.31275E-10    0.10000E+01    0.37242E+03    0.25943E-06    0.12436E-09    0.82492E-17
+    5    4    0.31275E-10    0.10000E+01    0.30034E+03    0.47916E-06    0.33355E-09    0.15236E-16
+    5    4    0.31275E-10    0.10000E+01    0.24221E+03    0.84417E-06    0.77882E-09    0.26843E-16
+    5    4    0.31275E-10    0.10000E+01    0.19533E+03    0.13304E-05    0.14800E-08    0.42306E-16
+    5    4    0.31275E-10    0.10000E+01    0.15752E+03    0.13304E-05    0.14800E-08    0.42306E-16
+    5    4    0.54572E-10    0.10000E+01    0.80645E+05    0.25234E-57    0.18000E-68    0.44959E-67
+    5    4    0.54572E-10    0.10000E+01    0.65036E+05    0.20585E-56    0.28613E-67    0.37365E-66
+    5    4    0.54572E-10    0.10000E+01    0.52449E+05    0.17450E-55    0.42515E-66    0.30913E-65
+    5    4    0.54572E-10    0.10000E+01    0.42297E+05    0.14457E-54    0.90371E-65    0.22285E-64
+    5    4    0.54572E-10    0.10000E+01    0.34111E+05    0.15463E-53    0.27677E-63    0.16304E-63
+    5    4    0.54572E-10    0.10000E+01    0.27509E+05    0.23338E-52    0.94408E-62    0.15579E-62
+    5    4    0.54572E-10    0.10000E+01    0.22184E+05    0.40495E-51    0.30921E-60    0.21752E-61
+    5    4    0.54572E-10    0.10000E+01    0.17891E+05    0.68769E-50    0.93042E-59    0.35670E-60
+    5    4    0.54572E-10    0.10000E+01    0.14428E+05    0.10865E-48    0.26129E-57    0.56891E-59
+    5    4    0.54572E-10    0.10000E+01    0.11635E+05    0.16116E-47    0.70939E-56    0.85191E-58
+    5    4    0.54572E-10    0.10000E+01    0.93834E+04    0.23078E-46    0.19069E-54    0.12262E-56
+    5    4    0.54572E-10    0.10000E+01    0.75673E+04    0.32615E-45    0.51194E-53    0.17384E-55
+    5    4    0.54572E-10    0.10000E+01    0.61026E+04    0.45953E-44    0.13749E-51    0.24559E-54
+    5    4    0.54572E-10    0.10000E+01    0.49215E+04    0.64731E-43    0.36933E-50    0.34691E-53
+    5    4    0.54572E-10    0.10000E+01    0.39689E+04    0.91196E-42    0.99207E-49    0.49012E-52
+    5    4    0.54572E-10    0.10000E+01    0.32008E+04    0.40407E-39    0.86163E-46    0.21776E-49
+    5    4    0.54572E-10    0.10000E+01    0.25813E+04    0.29628E-30    0.14484E-36    0.16013E-40
+    5    4    0.54572E-10    0.10000E+01    0.20817E+04    0.56414E-14    0.12302E-19    0.30590E-24
+    5    4    0.54572E-10    0.10000E+01    0.16788E+04    0.19074E-08    0.18172E-13    0.10365E-18
+    5    4    0.54572E-10    0.10000E+01    0.13538E+04    0.40958E-08    0.69028E-13    0.22272E-18
+    5    4    0.54572E-10    0.10000E+01    0.10918E+04    0.86003E-08    0.25739E-12    0.46791E-18
+    5    4    0.54572E-10    0.10000E+01    0.88049E+03    0.17674E-07    0.94764E-12    0.96194E-18
+    5    4    0.54572E-10    0.10000E+01    0.71007E+03    0.35622E-07    0.34508E-11    0.19393E-17
+    5    4    0.54572E-10    0.10000E+01    0.57264E+03    0.70592E-07    0.12277E-10    0.38438E-17
+    5    4    0.54572E-10    0.10000E+01    0.46180E+03    0.13762E-06    0.41293E-10    0.74945E-17
+    5    4    0.54572E-10    0.10000E+01    0.37242E+03    0.26266E-06    0.12591E-09    0.14305E-16
+    5    4    0.54572E-10    0.10000E+01    0.30034E+03    0.48513E-06    0.33772E-09    0.26421E-16
+    5    4    0.54572E-10    0.10000E+01    0.24221E+03    0.85470E-06    0.78854E-09    0.46550E-16
+    5    4    0.54572E-10    0.10000E+01    0.19533E+03    0.13470E-05    0.14985E-08    0.73364E-16
+    5    4    0.54572E-10    0.10000E+01    0.15752E+03    0.13470E-05    0.14985E-08    0.73364E-16
+    5    4    0.95225E-10    0.10000E+01    0.80645E+05    0.51268E-57    0.37287E-68    0.15402E-66
+    5    4    0.95225E-10    0.10000E+01    0.65036E+05    0.42373E-56    0.57885E-67    0.12898E-65
+    5    4    0.95225E-10    0.10000E+01    0.52449E+05    0.35234E-55    0.76406E-66    0.10772E-64
+    5    4    0.95225E-10    0.10000E+01    0.42297E+05    0.26358E-54    0.12224E-64    0.78122E-64
+    5    4    0.95225E-10    0.10000E+01    0.34111E+05    0.21931E-53    0.29261E-63    0.54077E-63
+    5    4    0.95225E-10    0.10000E+01    0.27509E+05    0.25708E-52    0.92531E-62    0.41390E-62
+    5    4    0.95225E-10    0.10000E+01    0.22184E+05    0.40338E-51    0.30252E-60    0.43255E-61
+    5    4    0.95225E-10    0.10000E+01    0.17891E+05    0.67507E-50    0.91750E-59    0.61738E-60
+    5    4    0.95225E-10    0.10000E+01    0.14428E+05    0.10711E-48    0.25882E-57    0.95759E-59
+    5    4    0.95225E-10    0.10000E+01    0.11635E+05    0.15954E-47    0.70403E-56    0.14371E-57
+    5    4    0.95225E-10    0.10000E+01    0.93834E+04    0.22898E-46    0.18948E-54    0.20800E-56
+    5    4    0.95225E-10    0.10000E+01    0.75673E+04    0.32405E-45    0.50929E-53    0.29614E-55
+    5    4    0.95225E-10    0.10000E+01    0.61026E+04    0.45712E-44    0.13695E-51    0.41974E-54
+    5    4    0.95225E-10    0.10000E+01    0.49215E+04    0.64474E-43    0.36837E-50    0.59453E-53
+    5    4    0.95225E-10    0.10000E+01    0.39689E+04    0.90950E-42    0.99070E-49    0.84202E-52
+    5    4    0.95225E-10    0.10000E+01    0.32008E+04    0.40349E-39    0.86148E-46    0.37497E-49
+    5    4    0.95225E-10    0.10000E+01    0.25813E+04    0.29625E-30    0.14501E-36    0.27636E-40
+    5    4    0.95225E-10    0.10000E+01    0.20817E+04    0.56492E-14    0.12334E-19    0.52933E-24
+    5    4    0.95225E-10    0.10000E+01    0.16788E+04    0.19119E-08    0.18232E-13    0.17965E-18
+    5    4    0.95225E-10    0.10000E+01    0.13538E+04    0.41068E-08    0.69261E-13    0.38626E-18
+    5    4    0.95225E-10    0.10000E+01    0.10918E+04    0.86256E-08    0.25827E-12    0.81184E-18
+    5    4    0.95225E-10    0.10000E+01    0.88049E+03    0.17729E-07    0.95091E-12    0.16695E-17
+    5    4    0.95225E-10    0.10000E+01    0.71007E+03    0.35737E-07    0.34627E-11    0.33665E-17
+    5    4    0.95225E-10    0.10000E+01    0.57264E+03    0.70826E-07    0.12320E-10    0.66734E-17
+    5    4    0.95225E-10    0.10000E+01    0.46180E+03    0.13809E-06    0.41436E-10    0.13013E-16
+    5    4    0.95225E-10    0.10000E+01    0.37242E+03    0.26355E-06    0.12634E-09    0.24838E-16
+    5    4    0.95225E-10    0.10000E+01    0.30034E+03    0.48679E-06    0.33888E-09    0.45879E-16
+    5    4    0.95225E-10    0.10000E+01    0.24221E+03    0.85763E-06    0.79125E-09    0.80832E-16
+    5    4    0.95225E-10    0.10000E+01    0.19533E+03    0.13516E-05    0.15036E-08    0.12739E-15
+    5    4    0.95225E-10    0.10000E+01    0.15752E+03    0.13516E-05    0.15036E-08    0.12739E-15
+    5    4    0.16616E-09    0.10000E+01    0.80645E+05    0.10196E-56    0.75049E-68    0.52176E-66
+    5    4    0.16616E-09    0.10000E+01    0.65036E+05    0.85060E-56    0.11675E-66    0.43876E-65
+    5    4    0.16616E-09    0.10000E+01    0.52449E+05    0.70892E-55    0.15034E-65    0.36902E-64
+    5    4    0.16616E-09    0.10000E+01    0.42297E+05    0.51741E-54    0.20566E-64    0.27079E-63
+    5    4    0.16616E-09    0.10000E+01    0.34111E+05    0.37709E-53    0.36450E-63    0.18698E-62
+    5    4    0.16616E-09    0.10000E+01    0.27509E+05    0.33665E-52    0.94287E-62    0.13042E-61
+    5    4    0.16616E-09    0.10000E+01    0.22184E+05    0.42560E-51    0.29330E-60    0.10520E-60
+    5    4    0.16616E-09    0.10000E+01    0.17891E+05    0.66244E-50    0.88979E-59    0.11615E-59
+    5    4    0.16616E-09    0.10000E+01    0.14428E+05    0.10411E-48    0.25247E-57    0.16240E-58
+    5    4    0.16616E-09    0.10000E+01    0.11635E+05    0.15559E-47    0.68942E-56    0.23943E-57
+    5    4    0.16616E-09    0.10000E+01    0.93834E+04    0.22413E-46    0.18601E-54    0.34824E-56
+    5    4    0.16616E-09    0.10000E+01    0.75673E+04    0.31805E-45    0.50099E-53    0.49942E-55
+    5    4    0.16616E-09    0.10000E+01    0.61026E+04    0.44961E-44    0.13498E-51    0.71196E-54
+    5    4    0.16616E-09    0.10000E+01    0.49215E+04    0.63538E-43    0.36373E-50    0.10129E-52
+    5    4    0.16616E-09    0.10000E+01    0.39689E+04    0.89795E-42    0.97991E-49    0.14398E-51
+    5    4    0.16616E-09    0.10000E+01    0.32008E+04    0.39907E-39    0.85350E-46    0.64320E-49
+    5    4    0.16616E-09    0.10000E+01    0.25813E+04    0.29352E-30    0.14392E-36    0.47549E-40
+    5    4    0.16616E-09    0.10000E+01    0.20817E+04    0.56087E-14    0.12267E-19    0.91388E-24
+    5    4    0.16616E-09    0.10000E+01    0.16788E+04    0.19007E-08    0.18148E-13    0.31085E-18
+    5    4    0.16616E-09    0.10000E+01    0.13538E+04    0.40845E-08    0.68948E-13    0.66883E-18
+    5    4    0.16616E-09    0.10000E+01    0.10918E+04    0.85817E-08    0.25712E-12    0.14065E-17
+    5    4    0.16616E-09    0.10000E+01    0.88049E+03    0.17643E-07    0.94670E-12    0.28936E-17
+    5    4    0.16616E-09    0.10000E+01    0.71007E+03    0.35570E-07    0.34474E-11    0.58362E-17
+    5    4    0.16616E-09    0.10000E+01    0.57264E+03    0.70501E-07    0.12265E-10    0.11571E-16
+    5    4    0.16616E-09    0.10000E+01    0.46180E+03    0.13746E-06    0.41252E-10    0.22566E-16
+    5    4    0.16616E-09    0.10000E+01    0.37242E+03    0.26238E-06    0.12579E-09    0.43076E-16
+    5    4    0.16616E-09    0.10000E+01    0.30034E+03    0.48462E-06    0.33738E-09    0.79568E-16
+    5    4    0.16616E-09    0.10000E+01    0.24221E+03    0.85382E-06    0.78775E-09    0.14019E-15
+    5    4    0.16616E-09    0.10000E+01    0.19533E+03    0.13456E-05    0.14970E-08    0.22095E-15
+    5    4    0.16616E-09    0.10000E+01    0.15752E+03    0.13456E-05    0.14970E-08    0.22095E-15
+    5    4    0.28994E-09    0.10000E+01    0.80645E+05    0.19921E-56    0.14763E-67    0.17413E-65
+    5    4    0.28994E-09    0.10000E+01    0.65036E+05    0.16713E-55    0.23120E-66    0.14677E-64
+    5    4    0.28994E-09    0.10000E+01    0.52449E+05    0.14016E-54    0.29971E-65    0.12397E-63
+    5    4    0.28994E-09    0.10000E+01    0.42297E+05    0.10258E-53    0.39104E-64    0.91814E-63
+    5    4    0.28994E-09    0.10000E+01    0.34111E+05    0.71747E-53    0.56529E-63    0.64100E-62
+    5    4    0.28994E-09    0.10000E+01    0.27509E+05    0.53902E-52    0.10912E-61    0.43899E-61
+    5    4    0.28994E-09    0.10000E+01    0.22184E+05    0.51812E-51    0.29142E-60    0.30935E-60
+    5    4    0.28994E-09    0.10000E+01    0.17891E+05    0.67757E-50    0.85595E-59    0.25914E-59
+    5    4    0.28994E-09    0.10000E+01    0.14428E+05    0.10108E-48    0.24333E-57    0.29098E-58
+    5    4    0.28994E-09    0.10000E+01    0.11635E+05    0.15020E-47    0.66852E-56    0.39716E-57
+    5    4    0.28994E-09    0.10000E+01    0.93834E+04    0.21729E-46    0.18124E-54    0.57319E-56
+    5    4    0.28994E-09    0.10000E+01    0.75673E+04    0.30977E-45    0.48994E-53    0.82966E-55
+    5    4    0.28994E-09    0.10000E+01    0.61026E+04    0.43956E-44    0.13240E-51    0.11942E-53
+    5    4    0.28994E-09    0.10000E+01    0.49215E+04    0.62308E-43    0.35770E-50    0.17116E-52
+    5    4    0.28994E-09    0.10000E+01    0.39689E+04    0.88290E-42    0.96591E-49    0.24464E-51
+    5    4    0.28994E-09    0.10000E+01    0.32008E+04    0.39333E-39    0.84315E-46    0.10977E-48
+    5    4    0.28994E-09    0.10000E+01    0.25813E+04    0.28998E-30    0.14251E-36    0.81481E-40
+    5    4    0.28994E-09    0.10000E+01    0.20817E+04    0.55561E-14    0.12179E-19    0.15730E-23
+    5    4    0.28994E-09    0.10000E+01    0.16788E+04    0.18862E-08    0.18037E-13    0.53657E-18
+    5    4    0.28994E-09    0.10000E+01    0.13538E+04    0.40556E-08    0.68540E-13    0.11555E-17
+    5    4    0.28994E-09    0.10000E+01    0.10918E+04    0.85245E-08    0.25562E-12    0.24317E-17
+    5    4    0.28994E-09    0.10000E+01    0.88049E+03    0.17531E-07    0.94121E-12    0.50050E-17
+    5    4    0.28994E-09    0.10000E+01    0.71007E+03    0.35351E-07    0.34274E-11    0.10098E-16
+    5    4    0.28994E-09    0.10000E+01    0.57264E+03    0.70078E-07    0.12194E-10    0.20026E-16
+    5    4    0.28994E-09    0.10000E+01    0.46180E+03    0.13665E-06    0.41013E-10    0.39059E-16
+    5    4    0.28994E-09    0.10000E+01    0.37242E+03    0.26083E-06    0.12506E-09    0.74565E-16
+    5    4    0.28994E-09    0.10000E+01    0.30034E+03    0.48179E-06    0.33542E-09    0.13774E-15
+    5    4    0.28994E-09    0.10000E+01    0.24221E+03    0.84884E-06    0.78317E-09    0.24269E-15
+    5    4    0.28994E-09    0.10000E+01    0.19533E+03    0.13378E-05    0.14883E-08    0.38249E-15
+    5    4    0.28994E-09    0.10000E+01    0.15752E+03    0.13378E-05    0.14883E-08    0.38249E-15
+    5    4    0.50593E-09    0.10000E+01    0.80645E+05    0.38317E-56    0.28504E-67    0.57275E-65
+    5    4    0.50593E-09    0.10000E+01    0.65036E+05    0.32254E-55    0.44882E-66    0.48344E-64
+    5    4    0.50593E-09    0.10000E+01    0.52449E+05    0.27184E-54    0.58844E-65    0.40934E-63
+    5    4    0.50593E-09    0.10000E+01    0.42297E+05    0.20057E-53    0.76683E-64    0.30501E-62
+    5    4    0.50593E-09    0.10000E+01    0.34111E+05    0.13991E-52    0.10218E-62    0.21528E-61
+    5    4    0.50593E-09    0.10000E+01    0.27509E+05    0.98171E-52    0.15437E-61    0.14856E-60
+    5    4    0.50593E-09    0.10000E+01    0.22184E+05    0.76524E-51    0.31652E-60    0.10067E-59
+    5    4    0.50593E-09    0.10000E+01    0.17891E+05    0.77326E-50    0.83069E-59    0.70996E-59
+    5    4    0.50593E-09    0.10000E+01    0.14428E+05    0.10053E-48    0.23149E-57    0.60452E-58
+    5    4    0.50593E-09    0.10000E+01    0.11635E+05    0.14395E-47    0.63941E-56    0.68382E-57
+    5    4    0.50593E-09    0.10000E+01    0.93834E+04    0.20805E-46    0.17476E-54    0.93282E-56
+    5    4    0.50593E-09    0.10000E+01    0.75673E+04    0.29856E-45    0.47546E-53    0.13520E-54
+    5    4    0.50593E-09    0.10000E+01    0.61026E+04    0.42632E-44    0.12910E-51    0.19720E-53
+    5    4    0.50593E-09    0.10000E+01    0.49215E+04    0.60731E-43    0.35013E-50    0.28598E-52
+    5    4    0.50593E-09    0.10000E+01    0.39689E+04    0.86395E-42    0.94850E-49    0.41226E-51
+    5    4    0.50593E-09    0.10000E+01    0.32008E+04    0.38617E-39    0.83035E-46    0.18618E-48
+    5    4    0.50593E-09    0.10000E+01    0.25813E+04    0.28560E-30    0.14078E-36    0.13895E-39
+    5    4    0.50593E-09    0.10000E+01    0.20817E+04    0.54913E-14    0.12073E-19    0.26978E-23
+    5    4    0.50593E-09    0.10000E+01    0.16788E+04    0.18684E-08    0.17904E-13    0.92358E-18
+    5    4    0.50593E-09    0.10000E+01    0.13538E+04    0.40203E-08    0.68047E-13    0.19912E-17
+    5    4    0.50593E-09    0.10000E+01    0.10918E+04    0.84550E-08    0.25380E-12    0.41938E-17
+    5    4    0.50593E-09    0.10000E+01    0.88049E+03    0.17395E-07    0.93456E-12    0.86371E-17
+    5    4    0.50593E-09    0.10000E+01    0.71007E+03    0.35086E-07    0.34032E-11    0.17433E-16
+    5    4    0.50593E-09    0.10000E+01    0.57264E+03    0.69565E-07    0.12108E-10    0.34581E-16
+    5    4    0.50593E-09    0.10000E+01    0.46180E+03    0.13566E-06    0.40723E-10    0.67458E-16
+    5    4    0.50593E-09    0.10000E+01    0.37242E+03    0.25897E-06    0.12417E-09    0.12879E-15
+    5    4    0.50593E-09    0.10000E+01    0.30034E+03    0.47836E-06    0.33304E-09    0.23792E-15
+    5    4    0.50593E-09    0.10000E+01    0.24221E+03    0.84282E-06    0.77762E-09    0.41920E-15
+    5    4    0.50593E-09    0.10000E+01    0.19533E+03    0.13283E-05    0.14777E-08    0.66070E-15
+    5    4    0.50593E-09    0.10000E+01    0.15752E+03    0.13283E-05    0.14777E-08    0.66070E-15
+    5    4    0.88282E-09    0.10000E+01    0.80645E+05    0.72625E-56    0.54145E-67    0.18571E-64
+    5    4    0.88282E-09    0.10000E+01    0.65036E+05    0.61252E-55    0.85554E-66    0.15690E-63
+    5    4    0.88282E-09    0.10000E+01    0.52449E+05    0.51793E-54    0.11317E-64    0.13306E-62
+    5    4    0.88282E-09    0.10000E+01    0.42297E+05    0.38476E-53    0.14903E-63    0.99518E-62
+    5    4    0.88282E-09    0.10000E+01    0.34111E+05    0.27049E-52    0.19561E-62    0.70808E-61
+    5    4    0.88282E-09    0.10000E+01    0.27509E+05    0.18724E-51    0.26148E-61    0.49459E-60
+    5    4    0.88282E-09    0.10000E+01    0.22184E+05    0.13198E-50    0.40971E-60    0.33604E-59
+    5    4    0.88282E-09    0.10000E+01    0.17891E+05    0.10557E-49    0.85731E-59    0.22349E-58
+    5    4    0.88282E-09    0.10000E+01    0.14428E+05    0.10875E-48    0.21983E-57    0.15662E-57
+    5    4    0.88282E-09    0.10000E+01    0.11635E+05    0.13959E-47    0.60154E-56    0.13527E-56
+    5    4    0.88282E-09    0.10000E+01    0.93834E+04    0.19685E-46    0.16599E-54    0.15645E-55
+    5    4    0.88282E-09    0.10000E+01    0.75673E+04    0.28370E-45    0.45630E-53    0.21737E-54
+    5    4    0.88282E-09    0.10000E+01    0.61026E+04    0.40884E-44    0.12487E-51    0.31937E-53
+    5    4    0.88282E-09    0.10000E+01    0.49215E+04    0.58701E-43    0.34063E-50    0.47051E-52
+    5    4    0.88282E-09    0.10000E+01    0.39689E+04    0.84008E-42    0.92691E-49    0.68719E-51
+    5    4    0.88282E-09    0.10000E+01    0.32008E+04    0.37727E-39    0.81460E-46    0.31331E-48
+    5    4    0.88282E-09    0.10000E+01    0.25813E+04    0.28019E-30    0.13866E-36    0.23558E-39
+    5    4    0.88282E-09    0.10000E+01    0.20817E+04    0.54118E-14    0.11942E-19    0.46078E-23
+    5    4    0.88282E-09    0.10000E+01    0.16788E+04    0.18466E-08    0.17741E-13    0.15848E-17
+    5    4    0.88282E-09    0.10000E+01    0.13538E+04    0.39772E-08    0.67444E-13    0.34212E-17
+    5    4    0.88282E-09    0.10000E+01    0.10918E+04    0.83700E-08    0.25158E-12    0.72126E-17
+    5    4    0.88282E-09    0.10000E+01    0.88049E+03    0.17228E-07    0.92641E-12    0.14865E-16
+    5    4    0.88282E-09    0.10000E+01    0.71007E+03    0.34762E-07    0.33736E-11    0.30018E-16
+    5    4    0.88282E-09    0.10000E+01    0.57264E+03    0.68937E-07    0.12002E-10    0.59561E-16
+    5    4    0.88282E-09    0.10000E+01    0.46180E+03    0.13446E-06    0.40367E-10    0.11621E-15
+    5    4    0.88282E-09    0.10000E+01    0.37242E+03    0.25668E-06    0.12308E-09    0.22189E-15
+    5    4    0.88282E-09    0.10000E+01    0.30034E+03    0.47416E-06    0.33013E-09    0.40991E-15
+    5    4    0.88282E-09    0.10000E+01    0.24221E+03    0.83543E-06    0.77082E-09    0.72227E-15
+    5    4    0.88282E-09    0.10000E+01    0.19533E+03    0.13167E-05    0.14648E-08    0.11384E-14
+    5    4    0.88282E-09    0.10000E+01    0.15752E+03    0.13167E-05    0.14648E-08    0.11384E-14
+    5    4    0.15405E-08    0.10000E+01    0.80645E+05    0.13569E-55    0.10131E-66    0.59374E-64
+    5    4    0.15405E-08    0.10000E+01    0.65036E+05    0.11459E-54    0.16042E-65    0.50201E-63
+    5    4    0.15405E-08    0.10000E+01    0.52449E+05    0.97090E-54    0.21347E-64    0.42616E-62
+    5    4    0.15405E-08    0.10000E+01    0.42297E+05    0.72469E-53    0.28403E-63    0.31952E-61
+    5    4    0.15405E-08    0.10000E+01    0.34111E+05    0.51369E-52    0.37562E-62    0.22858E-60
+    5    4    0.15405E-08    0.10000E+01    0.27509E+05    0.35755E-51    0.48537E-61    0.16130E-59
+    5    4    0.15405E-08    0.10000E+01    0.22184E+05    0.24504E-50    0.64807E-60    0.11110E-58
+    5    4    0.15405E-08    0.10000E+01    0.17891E+05    0.17216E-49    0.10350E-58    0.73852E-58
+    5    4    0.15405E-08    0.10000E+01    0.14428E+05    0.13928E-48    0.21882E-57    0.48283E-57
+    5    4    0.15405E-08    0.10000E+01    0.11635E+05    0.14512E-47    0.56223E-56    0.33958E-56
+    5    4    0.15405E-08    0.10000E+01    0.93834E+04    0.18726E-46    0.15488E-54    0.30138E-55
+    5    4    0.15405E-08    0.10000E+01    0.75673E+04    0.26586E-45    0.43122E-53    0.35961E-54
+    5    4    0.15405E-08    0.10000E+01    0.61026E+04    0.38635E-44    0.11944E-51    0.51044E-53
+    5    4    0.15405E-08    0.10000E+01    0.49215E+04    0.56095E-43    0.32872E-50    0.75994E-52
+    5    4    0.15405E-08    0.10000E+01    0.39689E+04    0.81005E-42    0.90033E-49    0.11291E-50
+    5    4    0.15405E-08    0.10000E+01    0.32008E+04    0.36627E-39    0.79537E-46    0.52197E-48
+    5    4    0.15405E-08    0.10000E+01    0.25813E+04    0.27357E-30    0.13608E-36    0.39665E-39
+    5    4    0.15405E-08    0.10000E+01    0.20817E+04    0.53149E-14    0.11783E-19    0.78338E-23
+    5    4    0.15405E-08    0.10000E+01    0.16788E+04    0.18203E-08    0.17541E-13    0.27102E-17
+    5    4    0.15405E-08    0.10000E+01    0.13538E+04    0.39247E-08    0.66705E-13    0.58590E-17
+    5    4    0.15405E-08    0.10000E+01    0.10918E+04    0.82664E-08    0.24886E-12    0.12366E-16
+    5    4    0.15405E-08    0.10000E+01    0.88049E+03    0.17025E-07    0.91642E-12    0.25505E-16
+    5    4    0.15405E-08    0.10000E+01    0.71007E+03    0.34365E-07    0.33372E-11    0.51532E-16
+    5    4    0.15405E-08    0.10000E+01    0.57264E+03    0.68168E-07    0.11873E-10    0.10228E-15
+    5    4    0.15405E-08    0.10000E+01    0.46180E+03    0.13298E-06    0.39930E-10    0.19960E-15
+    5    4    0.15405E-08    0.10000E+01    0.37242E+03    0.25388E-06    0.12175E-09    0.38115E-15
+    5    4    0.15405E-08    0.10000E+01    0.30034E+03    0.46900E-06    0.32655E-09    0.70417E-15
+    5    4    0.15405E-08    0.10000E+01    0.24221E+03    0.82636E-06    0.76245E-09    0.12408E-14
+    5    4    0.15405E-08    0.10000E+01    0.19533E+03    0.13024E-05    0.14489E-08    0.19555E-14
+    5    4    0.15405E-08    0.10000E+01    0.15752E+03    0.13024E-05    0.14489E-08    0.19555E-14
+    5    4    0.26880E-08    0.10000E+01    0.80645E+05    0.24992E-55    0.18678E-66    0.18650E-63
+    5    4    0.26880E-08    0.10000E+01    0.65036E+05    0.21123E-54    0.29616E-65    0.15779E-62
+    5    4    0.26880E-08    0.10000E+01    0.52449E+05    0.17921E-53    0.39561E-64    0.13405E-61
+    5    4    0.26880E-08    0.10000E+01    0.42297E+05    0.13418E-52    0.53044E-63    0.10067E-60
+    5    4    0.26880E-08    0.10000E+01    0.34111E+05    0.95718E-52    0.70949E-62    0.72286E-60
+    5    4    0.26880E-08    0.10000E+01    0.27509E+05    0.67241E-51    0.91980E-61    0.51389E-59
+    5    4    0.26880E-08    0.10000E+01    0.22184E+05    0.46185E-50    0.11652E-59    0.35861E-58
+    5    4    0.26880E-08    0.10000E+01    0.17891E+05    0.31130E-49    0.15539E-58    0.24234E-57
+    5    4    0.26880E-08    0.10000E+01    0.14428E+05    0.21746E-48    0.25368E-57    0.15843E-56
+    5    4    0.26880E-08    0.10000E+01    0.11635E+05    0.17844E-47    0.55019E-56    0.10343E-55
+    5    4    0.26880E-08    0.10000E+01    0.93834E+04    0.19054E-46    0.14402E-54    0.74182E-55
+    5    4    0.26880E-08    0.10000E+01    0.75673E+04    0.25101E-45    0.40213E-53    0.68099E-54
+    5    4    0.26880E-08    0.10000E+01    0.61026E+04    0.36156E-44    0.11303E-51    0.83806E-53
+    5    4    0.26880E-08    0.10000E+01    0.49215E+04    0.53069E-43    0.31517E-50    0.12128E-51
+    5    4    0.26880E-08    0.10000E+01    0.39689E+04    0.77586E-42    0.87145E-49    0.18252E-50
+    5    4    0.26880E-08    0.10000E+01    0.32008E+04    0.35426E-39    0.77538E-46    0.85904E-48
+    5    4    0.26880E-08    0.10000E+01    0.25813E+04    0.26667E-30    0.13353E-36    0.66245E-39
+    5    4    0.26880E-08    0.10000E+01    0.20817E+04    0.52198E-14    0.11639E-19    0.13256E-22
+    5    4    0.26880E-08    0.10000E+01    0.16788E+04    0.17961E-08    0.17370E-13    0.46201E-17
+    5    4    0.26880E-08    0.10000E+01    0.13538E+04    0.38773E-08    0.66073E-13    0.10001E-16
+    5    4    0.26880E-08    0.10000E+01    0.10918E+04    0.81744E-08    0.24654E-12    0.21132E-16
+    5    4    0.26880E-08    0.10000E+01    0.88049E+03    0.16847E-07    0.90791E-12    0.43621E-16
+    5    4    0.26880E-08    0.10000E+01    0.71007E+03    0.34022E-07    0.33061E-11    0.88184E-16
+    5    4    0.26880E-08    0.10000E+01    0.57264E+03    0.67506E-07    0.11762E-10    0.17509E-15
+    5    4    0.26880E-08    0.10000E+01    0.46180E+03    0.13171E-06    0.39556E-10    0.34174E-15
+    5    4    0.26880E-08    0.10000E+01    0.37242E+03    0.25148E-06    0.12061E-09    0.65263E-15
+    5    4    0.26880E-08    0.10000E+01    0.30034E+03    0.46459E-06    0.32348E-09    0.12058E-14
+    5    4    0.26880E-08    0.10000E+01    0.24221E+03    0.81859E-06    0.75528E-09    0.21246E-14
+    5    4    0.26880E-08    0.10000E+01    0.19533E+03    0.12902E-05    0.14353E-08    0.33485E-14
+    5    4    0.26880E-08    0.10000E+01    0.15752E+03    0.12902E-05    0.14353E-08    0.33485E-14
+    5    4    0.46905E-08    0.10000E+01    0.80645E+05    0.45427E-55    0.33978E-66    0.58068E-63
+    5    4    0.46905E-08    0.10000E+01    0.65036E+05    0.38421E-54    0.53924E-65    0.49156E-62
+    5    4    0.46905E-08    0.10000E+01    0.52449E+05    0.32627E-53    0.72221E-64    0.41785E-61
+    5    4    0.46905E-08    0.10000E+01    0.42297E+05    0.24481E-52    0.97359E-63    0.31422E-60
+    5    4    0.46905E-08    0.10000E+01    0.34111E+05    0.17543E-51    0.13150E-61    0.22622E-59
+    5    4    0.46905E-08    0.10000E+01    0.27509E+05    0.12425E-50    0.17270E-60    0.16168E-58
+    5    4    0.46905E-08    0.10000E+01    0.22184E+05    0.86243E-50    0.21872E-59    0.11398E-57
+    5    4    0.46905E-08    0.10000E+01    0.17891E+05    0.58137E-49    0.27353E-58    0.78338E-57
+    5    4    0.46905E-08    0.10000E+01    0.14428E+05    0.38646E-48    0.36933E-57    0.52238E-56
+    5    4    0.46905E-08    0.10000E+01    0.11635E+05    0.27106E-47    0.62165E-56    0.34081E-55
+    5    4    0.46905E-08    0.10000E+01    0.93834E+04    0.22786E-46    0.13869E-54    0.22501E-54
+    5    4    0.46905E-08    0.10000E+01    0.75673E+04    0.25062E-45    0.37026E-53    0.16495E-53
+    5    4    0.46905E-08    0.10000E+01    0.61026E+04    0.33758E-44    0.10471E-51    0.15615E-52
+    5    4    0.46905E-08    0.10000E+01    0.49215E+04    0.49311E-43    0.29674E-50    0.19784E-51
+    5    4    0.46905E-08    0.10000E+01    0.39689E+04    0.73011E-42    0.83179E-49    0.29134E-50
+    5    4    0.46905E-08    0.10000E+01    0.32008E+04    0.33784E-39    0.74767E-46    0.13928E-47
+    5    4    0.46905E-08    0.10000E+01    0.25813E+04    0.25708E-30    0.12988E-36    0.10952E-38
+    5    4    0.46905E-08    0.10000E+01    0.20817E+04    0.50832E-14    0.11412E-19    0.22321E-22
+    5    4    0.46905E-08    0.10000E+01    0.16788E+04    0.17595E-08    0.17082E-13    0.78530E-17
+    5    4    0.46905E-08    0.10000E+01    0.13538E+04    0.38033E-08    0.65002E-13    0.17013E-16
+    5    4    0.46905E-08    0.10000E+01    0.10918E+04    0.80267E-08    0.24257E-12    0.35980E-16
+    5    4    0.46905E-08    0.10000E+01    0.88049E+03    0.16555E-07    0.89333E-12    0.74328E-16
+    5    4    0.46905E-08    0.10000E+01    0.71007E+03    0.33449E-07    0.32529E-11    0.15034E-15
+    5    4    0.46905E-08    0.10000E+01    0.57264E+03    0.66391E-07    0.11572E-10    0.29859E-15
+    5    4    0.46905E-08    0.10000E+01    0.46180E+03    0.12956E-06    0.38916E-10    0.58287E-15
+    5    4    0.46905E-08    0.10000E+01    0.37242E+03    0.24739E-06    0.11865E-09    0.11132E-14
+    5    4    0.46905E-08    0.10000E+01    0.30034E+03    0.45705E-06    0.31823E-09    0.20566E-14
+    5    4    0.46905E-08    0.10000E+01    0.24221E+03    0.80532E-06    0.74300E-09    0.36237E-14
+    5    4    0.46905E-08    0.10000E+01    0.19533E+03    0.12693E-05    0.14119E-08    0.57110E-14
+    5    4    0.46905E-08    0.10000E+01    0.15752E+03    0.12693E-05    0.14119E-08    0.57110E-14
+    5    4    0.81846E-08    0.10000E+01    0.80645E+05    0.81612E-55    0.61105E-66    0.26230E-62
+    5    4    0.81846E-08    0.10000E+01    0.65036E+05    0.69082E-54    0.97056E-65    0.22226E-61
+    5    4    0.81846E-08    0.10000E+01    0.52449E+05    0.58717E-53    0.13029E-63    0.18910E-60
+    5    4    0.81846E-08    0.10000E+01    0.42297E+05    0.44142E-52    0.17646E-62    0.14246E-59
+    5    4    0.81846E-08    0.10000E+01    0.34111E+05    0.31758E-51    0.24052E-61    0.10292E-58
+    5    4    0.81846E-08    0.10000E+01    0.27509E+05    0.22670E-50    0.32136E-60    0.74029E-58
+    5    4    0.81846E-08    0.10000E+01    0.22184E+05    0.15965E-49    0.41791E-59    0.52817E-57
+    5    4    0.81846E-08    0.10000E+01    0.17891E+05    0.10999E-48    0.53393E-58    0.37081E-56
+    5    4    0.81846E-08    0.10000E+01    0.14428E+05    0.74486E-48    0.69678E-57    0.25546E-55
+    5    4    0.81846E-08    0.10000E+01    0.11635E+05    0.51031E-47    0.10018E-55    0.17313E-54
+    5    4    0.81846E-08    0.10000E+01    0.93834E+04    0.37725E-46    0.17522E-54    0.11596E-53
+    5    4    0.81846E-08    0.10000E+01    0.75673E+04    0.33136E-45    0.38891E-53    0.77647E-53
+    5    4    0.81846E-08    0.10000E+01    0.61026E+04    0.36711E-44    0.10182E-51    0.54474E-52
+    5    4    0.81846E-08    0.10000E+01    0.49215E+04    0.48759E-43    0.28435E-50    0.45191E-51
+    5    4    0.81846E-08    0.10000E+01    0.39689E+04    0.70352E-42    0.80168E-49    0.49921E-50
+    5    4    0.81846E-08    0.10000E+01    0.32008E+04    0.32604E-39    0.72690E-46    0.21881E-47
+    5    4    0.81846E-08    0.10000E+01    0.25813E+04    0.25011E-30    0.12724E-36    0.17408E-38
+    5    4    0.81846E-08    0.10000E+01    0.20817E+04    0.49905E-14    0.11246E-19    0.36889E-22
+    5    4    0.81846E-08    0.10000E+01    0.16788E+04    0.17353E-08    0.16861E-13    0.13201E-16
+    5    4    0.81846E-08    0.10000E+01    0.13538E+04    0.37511E-08    0.64173E-13    0.28489E-16
+    5    4    0.81846E-08    0.10000E+01    0.10918E+04    0.79186E-08    0.23949E-12    0.60191E-16
+    5    4    0.81846E-08    0.10000E+01    0.88049E+03    0.16336E-07    0.88191E-12    0.12433E-15
+    5    4    0.81846E-08    0.10000E+01    0.71007E+03    0.33013E-07    0.32111E-11    0.25151E-15
+    5    4    0.81846E-08    0.10000E+01    0.57264E+03    0.65532E-07    0.11422E-10    0.49953E-15
+    5    4    0.81846E-08    0.10000E+01    0.46180E+03    0.12788E-06    0.38411E-10    0.97502E-15
+    5    4    0.81846E-08    0.10000E+01    0.37242E+03    0.24420E-06    0.11711E-09    0.18618E-14
+    5    4    0.81846E-08    0.10000E+01    0.30034E+03    0.45115E-06    0.31408E-09    0.34390E-14
+    5    4    0.81846E-08    0.10000E+01    0.24221E+03    0.79490E-06    0.73331E-09    0.60584E-14
+    5    4    0.81846E-08    0.10000E+01    0.19533E+03    0.12528E-05    0.13935E-08    0.95472E-14
+    5    4    0.81846E-08    0.10000E+01    0.15752E+03    0.12528E-05    0.13935E-08    0.95472E-14
+    5    4    0.14282E-07    0.10000E+01    0.80645E+05    0.13919E-54    0.10439E-65    0.36585E-61
+    5    4    0.14282E-07    0.10000E+01    0.65036E+05    0.11798E-53    0.16602E-64    0.31050E-60
+    5    4    0.14282E-07    0.10000E+01    0.52449E+05    0.10042E-52    0.22360E-63    0.26457E-59
+    5    4    0.14282E-07    0.10000E+01    0.42297E+05    0.75697E-52    0.30477E-62    0.19985E-58
+    5    4    0.14282E-07    0.10000E+01    0.34111E+05    0.54756E-51    0.42026E-61    0.14509E-57
+    5    4    0.14282E-07    0.10000E+01    0.27509E+05    0.39489E-50    0.57410E-60    0.10523E-56
+    5    4    0.14282E-07    0.10000E+01    0.22184E+05    0.28344E-49    0.77604E-59    0.76135E-56
+    5    4    0.14282E-07    0.10000E+01    0.17891E+05    0.20179E-48    0.10477E-57    0.54676E-55
+    5    4    0.14282E-07    0.10000E+01    0.14428E+05    0.14330E-47    0.14437E-56    0.38937E-54
+    5    4    0.14282E-07    0.10000E+01    0.11635E+05    0.10325E-46    0.20984E-55    0.27543E-53
+    5    4    0.14282E-07    0.10000E+01    0.93834E+04    0.77759E-46    0.33617E-54    0.19375E-52
+    5    4    0.14282E-07    0.10000E+01    0.75673E+04    0.63890E-45    0.62160E-53    0.13530E-51
+    5    4    0.14282E-07    0.10000E+01    0.61026E+04    0.60098E-44    0.13468E-51    0.93431E-51
+    5    4    0.14282E-07    0.10000E+01    0.49215E+04    0.66226E-43    0.33060E-50    0.63630E-50
+    5    4    0.14282E-07    0.10000E+01    0.39689E+04    0.83349E-42    0.87129E-49    0.43077E-49
+    5    4    0.14282E-07    0.10000E+01    0.32008E+04    0.35813E-39    0.76588E-46    0.95785E-47
+    5    4    0.14282E-07    0.10000E+01    0.25813E+04    0.26524E-30    0.13200E-36    0.43005E-38
+    5    4    0.14282E-07    0.10000E+01    0.20817E+04    0.52084E-14    0.11528E-19    0.76061E-22
+    5    4    0.14282E-07    0.10000E+01    0.16788E+04    0.17941E-08    0.17199E-13    0.25744E-16
+    5    4    0.14282E-07    0.10000E+01    0.13538E+04    0.38560E-08    0.65408E-13    0.49517E-16
+    5    4    0.14282E-07    0.10000E+01    0.10918E+04    0.81115E-08    0.24399E-12    0.98423E-16
+    5    4    0.14282E-07    0.10000E+01    0.88049E+03    0.16698E-07    0.89830E-12    0.19696E-15
+    5    4    0.14282E-07    0.10000E+01    0.71007E+03    0.33697E-07    0.32705E-11    0.39170E-15
+    5    4    0.14282E-07    0.10000E+01    0.57264E+03    0.66831E-07    0.11633E-10    0.77040E-15
+    5    4    0.14282E-07    0.10000E+01    0.46180E+03    0.13035E-06    0.39120E-10    0.14945E-14
+    5    4    0.14282E-07    0.10000E+01    0.37242E+03    0.24883E-06    0.11927E-09    0.28419E-14
+    5    4    0.14282E-07    0.10000E+01    0.30034E+03    0.45961E-06    0.31988E-09    0.52344E-14
+    5    4    0.14282E-07    0.10000E+01    0.24221E+03    0.80972E-06    0.74686E-09    0.92030E-14
+    5    4    0.14282E-07    0.10000E+01    0.19533E+03    0.12761E-05    0.14192E-08    0.14485E-13
+    5    4    0.14282E-07    0.10000E+01    0.15752E+03    0.12761E-05    0.14192E-08    0.14485E-13
+    5    4    0.24920E-07    0.10000E+01    0.80645E+05    0.23815E-54    0.17870E-65    0.10646E-60
+    5    4    0.24920E-07    0.10000E+01    0.65036E+05    0.20195E-53    0.28429E-64    0.90380E-60
+    5    4    0.24920E-07    0.10000E+01    0.52449E+05    0.17194E-52    0.38319E-63    0.77028E-59
+    5    4    0.24920E-07    0.10000E+01    0.42297E+05    0.12970E-51    0.52297E-62    0.58211E-58
+    5    4    0.24920E-07    0.10000E+01    0.34111E+05    0.93923E-51    0.72250E-61    0.42294E-57
+    5    4    0.24920E-07    0.10000E+01    0.27509E+05    0.67848E-50    0.98927E-60    0.30713E-56
+    5    4    0.24920E-07    0.10000E+01    0.22184E+05    0.48799E-49    0.13392E-58    0.22264E-55
+    5    4    0.24920E-07    0.10000E+01    0.17891E+05    0.34789E-48    0.18016E-57    0.16037E-54
+    5    4    0.24920E-07    0.10000E+01    0.14428E+05    0.24640E-47    0.24410E-56    0.11467E-53
+    5    4    0.24920E-07    0.10000E+01    0.11635E+05    0.17512E-46    0.33970E-55    0.81521E-53
+    5    4    0.24920E-07    0.10000E+01    0.93834E+04    0.12709E-45    0.50017E-54    0.57676E-52
+    5    4    0.24920E-07    0.10000E+01    0.75673E+04    0.96865E-45    0.81625E-53    0.40548E-51
+    5    4    0.24920E-07    0.10000E+01    0.61026E+04    0.81035E-44    0.15493E-51    0.28220E-50
+    5    4    0.24920E-07    0.10000E+01    0.49215E+04    0.78194E-43    0.34519E-50    0.19353E-49
+    5    4    0.24920E-07    0.10000E+01    0.39689E+04    0.88633E-42    0.86583E-49    0.13059E-48
+    5    4    0.24920E-07    0.10000E+01    0.32008E+04    0.35959E-39    0.74827E-46    0.27771E-46
+    5    4    0.24920E-07    0.10000E+01    0.25813E+04    0.26112E-30    0.12896E-36    0.10865E-37
+    5    4    0.24920E-07    0.10000E+01    0.20817E+04    0.51432E-14    0.11331E-19    0.16502E-21
+    5    4    0.24920E-07    0.10000E+01    0.16788E+04    0.17767E-08    0.16939E-13    0.52040E-16
+    5    4    0.24920E-07    0.10000E+01    0.13538E+04    0.38062E-08    0.64428E-13    0.92320E-16
+    5    4    0.24920E-07    0.10000E+01    0.10918E+04    0.79962E-08    0.24033E-12    0.17422E-15
+    5    4    0.24920E-07    0.10000E+01    0.88049E+03    0.16452E-07    0.88473E-12    0.33825E-15
+    5    4    0.24920E-07    0.10000E+01    0.71007E+03    0.33194E-07    0.32206E-11    0.66133E-15
+    5    4    0.24920E-07    0.10000E+01    0.57264E+03    0.65827E-07    0.11455E-10    0.12880E-14
+    5    4    0.24920E-07    0.10000E+01    0.46180E+03    0.12838E-06    0.38516E-10    0.24841E-14
+    5    4    0.24920E-07    0.10000E+01    0.37242E+03    0.24505E-06    0.11742E-09    0.47067E-14
+    5    4    0.24920E-07    0.10000E+01    0.30034E+03    0.45258E-06    0.31491E-09    0.86493E-14
+    5    4    0.24920E-07    0.10000E+01    0.24221E+03    0.79730E-06    0.73525E-09    0.15185E-13
+    5    4    0.24920E-07    0.10000E+01    0.19533E+03    0.12565E-05    0.13972E-08    0.23878E-13
+    5    4    0.24920E-07    0.10000E+01    0.15752E+03    0.12565E-05    0.13972E-08    0.23878E-13
+    5    4    0.43485E-07    0.10000E+01    0.80645E+05    0.40431E-54    0.30351E-65    0.30695E-60
+    5    4    0.43485E-07    0.10000E+01    0.65036E+05    0.34297E-53    0.48297E-64    0.26064E-59
+    5    4    0.43485E-07    0.10000E+01    0.52449E+05    0.29210E-52    0.65146E-63    0.22219E-58
+    5    4    0.43485E-07    0.10000E+01    0.42297E+05    0.22046E-51    0.89013E-62    0.16797E-57
+    5    4    0.43485E-07    0.10000E+01    0.34111E+05    0.15981E-50    0.12319E-60    0.12212E-56
+    5    4    0.43485E-07    0.10000E+01    0.27509E+05    0.11563E-49    0.16911E-59    0.88780E-56
+    5    4    0.43485E-07    0.10000E+01    0.22184E+05    0.83350E-49    0.22960E-58    0.64465E-55
+    5    4    0.43485E-07    0.10000E+01    0.17891E+05    0.59576E-48    0.30926E-57    0.46551E-54
+    5    4    0.43485E-07    0.10000E+01    0.14428E+05    0.42250E-47    0.41679E-56    0.33401E-53
+    5    4    0.43485E-07    0.10000E+01    0.11635E+05    0.29910E-46    0.56834E-55    0.23844E-52
+    5    4    0.43485E-07    0.10000E+01    0.93834E+04    0.21348E-45    0.79709E-54    0.16950E-51
+    5    4    0.43485E-07    0.10000E+01    0.75673E+04    0.15604E-44    0.11874E-52    0.11983E-50
+    5    4    0.43485E-07    0.10000E+01    0.61026E+04    0.12028E-43    0.19803E-51    0.83971E-50
+    5    4    0.43485E-07    0.10000E+01    0.49215E+04    0.10269E-42    0.38804E-50    0.58065E-49
+    5    4    0.43485E-07    0.10000E+01    0.39689E+04    0.10216E-41    0.89263E-49    0.39440E-48
+    5    4    0.43485E-07    0.10000E+01    0.32008E+04    0.37711E-39    0.74085E-46    0.83070E-46
+    5    4    0.43485E-07    0.10000E+01    0.25813E+04    0.26201E-30    0.12640E-36    0.30250E-37
+    5    4    0.43485E-07    0.10000E+01    0.20817E+04    0.51369E-14    0.11153E-19    0.39794E-21
+    5    4    0.43485E-07    0.10000E+01    0.16788E+04    0.17750E-08    0.16708E-13    0.11463E-15
+    5    4    0.43485E-07    0.10000E+01    0.13538E+04    0.37767E-08    0.63556E-13    0.18396E-15
+    5    4    0.43485E-07    0.10000E+01    0.10918E+04    0.79093E-08    0.23705E-12    0.32161E-15
+    5    4    0.43485E-07    0.10000E+01    0.88049E+03    0.16250E-07    0.87252E-12    0.59405E-15
+    5    4    0.43485E-07    0.10000E+01    0.71007E+03    0.32763E-07    0.31756E-11    0.11271E-14
+    5    4    0.43485E-07    0.10000E+01    0.57264E+03    0.64945E-07    0.11292E-10    0.21568E-14
+    5    4    0.43485E-07    0.10000E+01    0.46180E+03    0.12663E-06    0.37967E-10    0.41163E-14
+    5    4    0.43485E-07    0.10000E+01    0.37242E+03    0.24165E-06    0.11574E-09    0.77500E-14
+    5    4    0.43485E-07    0.10000E+01    0.30034E+03    0.44625E-06    0.31039E-09    0.14186E-13
+    5    4    0.43485E-07    0.10000E+01    0.24221E+03    0.78606E-06    0.72466E-09    0.24845E-13
+    5    4    0.43485E-07    0.10000E+01    0.19533E+03    0.12387E-05    0.13770E-08    0.39015E-13
+    5    4    0.43485E-07    0.10000E+01    0.15752E+03    0.12387E-05    0.13770E-08    0.39015E-13
+    5    4    0.75878E-07    0.10000E+01    0.80645E+05    0.68127E-54    0.51161E-65    0.88361E-60
+    5    4    0.75878E-07    0.10000E+01    0.65036E+05    0.57809E-53    0.81434E-64    0.75048E-59
+    5    4    0.75878E-07    0.10000E+01    0.52449E+05    0.49248E-52    0.10991E-62    0.63987E-58
+    5    4    0.75878E-07    0.10000E+01    0.42297E+05    0.37189E-51    0.15034E-61    0.48391E-57
+    5    4    0.75878E-07    0.10000E+01    0.34111E+05    0.26983E-50    0.20841E-60    0.35203E-56
+    5    4    0.75878E-07    0.10000E+01    0.27509E+05    0.19551E-49    0.28680E-59    0.25616E-55
+    5    4    0.75878E-07    0.10000E+01    0.22184E+05    0.14125E-48    0.39068E-58    0.18628E-54
+    5    4    0.75878E-07    0.10000E+01    0.17891E+05    0.10125E-47    0.52785E-57    0.13481E-53
+    5    4    0.75878E-07    0.10000E+01    0.14428E+05    0.72013E-47    0.71149E-56    0.97013E-53
+    5    4    0.75878E-07    0.10000E+01    0.11635E+05    0.51013E-46    0.96280E-55    0.69500E-52
+    5    4    0.75878E-07    0.10000E+01    0.93834E+04    0.36198E-45    0.13180E-53    0.49604E-51
+    5    4    0.75878E-07    0.10000E+01    0.75673E+04    0.25929E-44    0.18575E-52    0.35234E-50
+    5    4    0.75878E-07    0.10000E+01    0.61026E+04    0.19049E-43    0.28012E-51    0.24837E-49
+    5    4    0.75878E-07    0.10000E+01    0.49215E+04    0.14850E-42    0.47945E-50    0.17306E-48
+    5    4    0.75878E-07    0.10000E+01    0.39689E+04    0.12981E-41    0.97439E-49    0.11861E-47
+    5    4    0.75878E-07    0.10000E+01    0.32008E+04    0.42189E-39    0.74867E-46    0.25103E-45
+    5    4    0.75878E-07    0.10000E+01    0.25813E+04    0.27057E-30    0.12384E-36    0.88954E-37
+    5    4    0.75878E-07    0.10000E+01    0.20817E+04    0.51954E-14    0.10909E-19    0.10517E-20
+    5    4    0.75878E-07    0.10000E+01    0.16788E+04    0.17853E-08    0.16369E-13    0.27645E-15
+    5    4    0.75878E-07    0.10000E+01    0.13538E+04    0.37483E-08    0.62269E-13    0.39984E-15
+    5    4    0.75878E-07    0.10000E+01    0.10918E+04    0.77987E-08    0.23221E-12    0.63409E-15
+    5    4    0.75878E-07    0.10000E+01    0.88049E+03    0.15971E-07    0.85446E-12    0.10868E-14
+    5    4    0.75878E-07    0.10000E+01    0.71007E+03    0.32147E-07    0.31090E-11    0.19614E-14
+    5    4    0.75878E-07    0.10000E+01    0.57264E+03    0.63667E-07    0.11053E-10    0.36382E-14
+    5    4    0.75878E-07    0.10000E+01    0.46180E+03    0.12406E-06    0.37156E-10    0.68138E-14
+    5    4    0.75878E-07    0.10000E+01    0.37242E+03    0.23667E-06    0.11326E-09    0.12684E-13
+    5    4    0.75878E-07    0.10000E+01    0.30034E+03    0.43693E-06    0.30371E-09    0.23059E-13
+    5    4    0.75878E-07    0.10000E+01    0.24221E+03    0.76949E-06    0.70904E-09    0.40216E-13
+    5    4    0.75878E-07    0.10000E+01    0.19533E+03    0.12124E-05    0.13473E-08    0.63007E-13
+    5    4    0.75878E-07    0.10000E+01    0.15752E+03    0.12124E-05    0.13473E-08    0.63007E-13
+    5    4    0.13240E-06    0.10000E+01    0.80645E+05    0.11404E-53    0.85668E-65    0.25322E-59
+    5    4    0.13240E-06    0.10000E+01    0.65036E+05    0.96793E-53    0.13639E-63    0.21511E-58
+    5    4    0.13240E-06    0.10000E+01    0.52449E+05    0.82480E-52    0.18419E-62    0.18344E-57
+    5    4    0.13240E-06    0.10000E+01    0.42297E+05    0.62312E-51    0.25218E-61    0.13877E-56
+    5    4    0.13240E-06    0.10000E+01    0.34111E+05    0.45248E-50    0.35009E-60    0.10101E-55
+    5    4    0.13240E-06    0.10000E+01    0.27509E+05    0.32828E-49    0.48286E-59    0.73558E-55
+    5    4    0.13240E-06    0.10000E+01    0.22184E+05    0.23764E-48    0.65988E-58    0.53560E-54
+    5    4    0.13240E-06    0.10000E+01    0.17891E+05    0.17084E-47    0.89483E-57    0.38835E-53
+    5    4    0.13240E-06    0.10000E+01    0.14428E+05    0.12191E-46    0.12092E-55    0.28019E-52
+    5    4    0.13240E-06    0.10000E+01    0.11635E+05    0.86581E-46    0.16341E-54    0.20134E-51
+    5    4    0.13240E-06    0.10000E+01    0.93834E+04    0.61408E-45    0.22149E-53    0.14420E-50
+    5    4    0.13240E-06    0.10000E+01    0.75673E+04    0.43644E-44    0.30344E-52    0.10284E-49
+    5    4    0.13240E-06    0.10000E+01    0.61026E+04    0.31304E-43    0.42957E-51    0.72851E-49
+    5    4    0.13240E-06    0.10000E+01    0.49215E+04    0.23095E-42    0.65819E-50    0.51095E-48
+    5    4    0.13240E-06    0.10000E+01    0.39689E+04    0.18255E-41    0.11641E-48    0.35324E-47
+    5    4    0.13240E-06    0.10000E+01    0.32008E+04    0.51870E-39    0.79438E-46    0.75453E-45
+    5    4    0.13240E-06    0.10000E+01    0.25813E+04    0.29610E-30    0.12290E-36    0.26623E-36
+    5    4    0.13240E-06    0.10000E+01    0.20817E+04    0.54210E-14    0.10650E-19    0.29473E-20
+    5    4    0.13240E-06    0.10000E+01    0.16788E+04    0.18320E-08    0.15990E-13    0.71848E-15
+    5    4    0.13240E-06    0.10000E+01    0.13538E+04    0.37558E-08    0.60820E-13    0.95204E-15
+    5    4    0.13240E-06    0.10000E+01    0.10918E+04    0.77175E-08    0.22673E-12    0.13632E-14
+    5    4    0.13240E-06    0.10000E+01    0.88049E+03    0.15704E-07    0.83394E-12    0.21232E-14
+    5    4    0.13240E-06    0.10000E+01    0.71007E+03    0.31502E-07    0.30331E-11    0.35552E-14
+    5    4    0.13240E-06    0.10000E+01    0.57264E+03    0.62272E-07    0.10780E-10    0.62622E-14
+    5    4    0.13240E-06    0.10000E+01    0.46180E+03    0.12121E-06    0.36231E-10    0.11346E-13
+    5    4    0.13240E-06    0.10000E+01    0.37242E+03    0.23106E-06    0.11042E-09    0.20695E-13
+    5    4    0.13240E-06    0.10000E+01    0.30034E+03    0.42638E-06    0.29608E-09    0.37165E-13
+    5    4    0.13240E-06    0.10000E+01    0.24221E+03    0.75067E-06    0.69119E-09    0.64346E-13
+    5    4    0.13240E-06    0.10000E+01    0.19533E+03    0.11825E-05    0.13134E-08    0.10041E-12
+    5    4    0.13240E-06    0.10000E+01    0.15752E+03    0.11825E-05    0.13134E-08    0.10041E-12
+    5    4    0.23103E-06    0.10000E+01    0.80645E+05    0.18975E-53    0.14259E-64    0.72279E-59
+    5    4    0.23103E-06    0.10000E+01    0.65036E+05    0.16110E-52    0.22706E-63    0.61412E-58
+    5    4    0.23103E-06    0.10000E+01    0.52449E+05    0.13731E-51    0.30679E-62    0.52377E-57
+    5    4    0.23103E-06    0.10000E+01    0.42297E+05    0.10377E-50    0.42038E-61    0.39633E-56
+    5    4    0.23103E-06    0.10000E+01    0.34111E+05    0.75410E-50    0.58435E-60    0.28861E-55
+    5    4    0.23103E-06    0.10000E+01    0.27509E+05    0.54775E-49    0.80761E-59    0.21034E-54
+    5    4    0.23103E-06    0.10000E+01    0.22184E+05    0.39722E-48    0.11070E-57    0.15333E-53
+    5    4    0.23103E-06    0.10000E+01    0.17891E+05    0.28631E-47    0.15065E-56    0.11136E-52
+    5    4    0.23103E-06    0.10000E+01    0.14428E+05    0.20497E-46    0.20424E-55    0.80524E-52
+    5    4    0.23103E-06    0.10000E+01    0.11635E+05    0.14604E-45    0.27647E-54    0.58017E-51
+    5    4    0.23103E-06    0.10000E+01    0.93834E+04    0.10378E-44    0.37378E-53    0.41677E-50
+    5    4    0.23103E-06    0.10000E+01    0.75673E+04    0.73641E-44    0.50587E-52    0.29825E-49
+    5    4    0.23103E-06    0.10000E+01    0.61026E+04    0.52300E-43    0.69261E-51    0.21219E-48
+    5    4    0.23103E-06    0.10000E+01    0.49215E+04    0.37503E-42    0.98657E-50    0.14965E-47
+    5    4    0.23103E-06    0.10000E+01    0.39689E+04    0.27810E-41    0.15449E-48    0.10424E-46
+    5    4    0.23103E-06    0.10000E+01    0.32008E+04    0.70661E-39    0.91177E-46    0.22480E-44
+    5    4    0.23103E-06    0.10000E+01    0.25813E+04    0.35265E-30    0.12560E-36    0.79729E-36
+    5    4    0.23103E-06    0.10000E+01    0.20817E+04    0.59552E-14    0.10398E-19    0.85184E-20
+    5    4    0.23103E-06    0.10000E+01    0.16788E+04    0.19452E-08    0.15572E-13    0.19675E-14
+    5    4    0.23103E-06    0.10000E+01    0.13538E+04    0.38328E-08    0.59201E-13    0.24536E-14
+    5    4    0.23103E-06    0.10000E+01    0.10918E+04    0.77028E-08    0.22058E-12    0.32212E-14
+    5    4    0.23103E-06    0.10000E+01    0.88049E+03    0.15487E-07    0.81082E-12    0.45361E-14
+    5    4    0.23103E-06    0.10000E+01    0.71007E+03    0.30868E-07    0.29475E-11    0.69003E-14
+    5    4    0.23103E-06    0.10000E+01    0.57264E+03    0.60800E-07    0.10471E-10    0.11249E-13
+    5    4    0.23103E-06    0.10000E+01    0.46180E+03    0.11810E-06    0.35182E-10    0.19288E-13
+    5    4    0.23103E-06    0.10000E+01    0.37242E+03    0.22484E-06    0.10720E-09    0.33935E-13
+    5    4    0.23103E-06    0.10000E+01    0.30034E+03    0.41456E-06    0.28742E-09    0.59599E-13
+    5    4    0.23103E-06    0.10000E+01    0.24221E+03    0.72950E-06    0.67094E-09    0.10182E-12
+    5    4    0.23103E-06    0.10000E+01    0.19533E+03    0.11488E-05    0.12748E-08    0.15773E-12
+    5    4    0.23103E-06    0.10000E+01    0.15752E+03    0.11488E-05    0.12748E-08    0.15773E-12
+    5    4    0.40314E-06    0.10000E+01    0.80645E+05    0.31405E-53    0.23606E-64    0.20559E-58
+    5    4    0.40314E-06    0.10000E+01    0.65036E+05    0.26668E-52    0.37597E-63    0.17471E-57
+    5    4    0.40314E-06    0.10000E+01    0.52449E+05    0.22735E-51    0.50821E-62    0.14903E-56
+    5    4    0.40314E-06    0.10000E+01    0.42297E+05    0.17189E-50    0.69689E-61    0.11279E-55
+    5    4    0.40314E-06    0.10000E+01    0.34111E+05    0.12499E-49    0.96983E-60    0.82172E-55
+    5    4    0.40314E-06    0.10000E+01    0.27509E+05    0.90878E-49    0.13428E-58    0.59925E-54
+    5    4    0.40314E-06    0.10000E+01    0.22184E+05    0.66009E-48    0.18453E-57    0.43727E-53
+    5    4    0.40314E-06    0.10000E+01    0.17891E+05    0.47689E-47    0.25198E-56    0.31805E-52
+    5    4    0.40314E-06    0.10000E+01    0.14428E+05    0.34244E-46    0.34279E-55    0.23042E-51
+    5    4    0.40314E-06    0.10000E+01    0.11635E+05    0.24478E-45    0.46527E-54    0.16641E-50
+    5    4    0.40314E-06    0.10000E+01    0.93834E+04    0.17444E-44    0.62961E-53    0.11985E-49
+    5    4    0.40314E-06    0.10000E+01    0.75673E+04    0.12394E-43    0.84906E-52    0.86030E-49
+    5    4    0.40314E-06    0.10000E+01    0.61026E+04    0.87794E-43    0.11454E-50    0.61430E-48
+    5    4    0.40314E-06    0.10000E+01    0.49215E+04    0.62188E-42    0.15674E-49    0.43531E-47
+    5    4    0.40314E-06    0.10000E+01    0.39689E+04    0.44565E-41    0.22544E-48    0.30518E-46
+    5    4    0.40314E-06    0.10000E+01    0.32008E+04    0.10504E-38    0.11578E-45    0.66379E-44
+    5    4    0.40314E-06    0.10000E+01    0.25813E+04    0.46382E-30    0.13557E-36    0.23733E-35
+    5    4    0.40314E-06    0.10000E+01    0.20817E+04    0.70378E-14    0.10191E-19    0.24925E-19
+    5    4    0.40314E-06    0.10000E+01    0.16788E+04    0.21754E-08    0.15118E-13    0.55577E-14
+    5    4    0.40314E-06    0.10000E+01    0.13538E+04    0.40371E-08    0.57411E-13    0.66930E-14
+    5    4    0.40314E-06    0.10000E+01    0.10918E+04    0.78192E-08    0.21371E-12    0.82782E-14
+    5    4    0.40314E-06    0.10000E+01    0.88049E+03    0.15392E-07    0.78493E-12    0.10712E-13
+    5    4    0.40314E-06    0.10000E+01    0.71007E+03    0.30319E-07    0.28512E-11    0.14751E-13
+    5    4    0.40314E-06    0.10000E+01    0.57264E+03    0.59324E-07    0.10124E-10    0.21808E-13
+    5    4    0.40314E-06    0.10000E+01    0.46180E+03    0.11479E-06    0.34001E-10    0.34456E-13
+    5    4    0.40314E-06    0.10000E+01    0.37242E+03    0.21805E-06    0.10358E-09    0.57091E-13
+    5    4    0.40314E-06    0.10000E+01    0.30034E+03    0.40149E-06    0.27767E-09    0.96351E-13
+    5    4    0.40314E-06    0.10000E+01    0.24221E+03    0.70590E-06    0.64813E-09    0.16056E-12
+    5    4    0.40314E-06    0.10000E+01    0.19533E+03    0.11111E-05    0.12314E-08    0.24532E-12
+    5    4    0.40314E-06    0.10000E+01    0.15752E+03    0.11111E-05    0.12314E-08    0.24532E-12
+    5    4    0.70346E-06    0.10000E+01    0.80645E+05    0.51728E-53    0.38892E-64    0.58301E-58
+    5    4    0.70346E-06    0.10000E+01    0.65036E+05    0.43936E-52    0.61953E-63    0.49549E-57
+    5    4    0.70346E-06    0.10000E+01    0.52449E+05    0.37462E-51    0.83777E-62    0.42270E-56
+    5    4    0.70346E-06    0.10000E+01    0.42297E+05    0.28332E-50    0.11496E-60    0.32000E-55
+    5    4    0.70346E-06    0.10000E+01    0.34111E+05    0.20614E-49    0.16014E-59    0.23321E-54
+    5    4    0.70346E-06    0.10000E+01    0.27509E+05    0.15002E-48    0.22207E-58    0.17017E-53
+    5    4    0.70346E-06    0.10000E+01    0.22184E+05    0.10912E-47    0.30590E-57    0.12428E-52
+    5    4    0.70346E-06    0.10000E+01    0.17891E+05    0.78995E-47    0.41897E-56    0.90514E-52
+    5    4    0.70346E-06    0.10000E+01    0.14428E+05    0.56878E-46    0.57180E-55    0.65689E-51
+    5    4    0.70346E-06    0.10000E+01    0.11635E+05    0.40782E-45    0.77846E-54    0.47537E-50
+    5    4    0.70346E-06    0.10000E+01    0.93834E+04    0.29150E-44    0.10559E-52    0.34317E-49
+    5    4    0.70346E-06    0.10000E+01    0.75673E+04    0.20763E-43    0.14247E-51    0.24698E-48
+    5    4    0.70346E-06    0.10000E+01    0.61026E+04    0.14721E-42    0.19129E-50    0.17693E-47
+    5    4    0.70346E-06    0.10000E+01    0.49215E+04    0.10390E-41    0.25700E-49    0.12589E-46
+    5    4    0.70346E-06    0.10000E+01    0.39689E+04    0.73324E-41    0.35200E-48    0.88744E-46
+    5    4    0.70346E-06    0.10000E+01    0.32008E+04    0.16568E-38    0.16271E-45    0.19446E-43
+    5    4    0.70346E-06    0.10000E+01    0.25813E+04    0.66879E-30    0.15902E-36    0.70094E-35
+    5    4    0.70346E-06    0.10000E+01    0.20817E+04    0.90724E-14    0.10114E-19    0.73079E-19
+    5    4    0.70346E-06    0.10000E+01    0.16788E+04    0.26075E-08    0.14642E-13    0.15944E-13
+    5    4    0.70346E-06    0.10000E+01    0.13538E+04    0.44669E-08    0.55467E-13    0.18893E-13
+    5    4    0.70346E-06    0.10000E+01    0.10918E+04    0.81785E-08    0.20614E-12    0.22606E-13
+    5    4    0.70346E-06    0.10000E+01    0.88049E+03    0.15544E-07    0.75615E-12    0.27658E-13
+    5    4    0.70346E-06    0.10000E+01    0.71007E+03    0.29991E-07    0.27440E-11    0.35158E-13
+    5    4    0.70346E-06    0.10000E+01    0.57264E+03    0.57987E-07    0.97356E-11    0.47185E-13
+    5    4    0.70346E-06    0.10000E+01    0.46180E+03    0.11143E-06    0.32682E-10    0.67530E-13
+    5    4    0.70346E-06    0.10000E+01    0.37242E+03    0.21082E-06    0.99533E-10    0.10267E-12
+    5    4    0.70346E-06    0.10000E+01    0.30034E+03    0.38726E-06    0.26677E-09    0.16238E-12
+    5    4    0.70346E-06    0.10000E+01    0.24221E+03    0.67992E-06    0.62260E-09    0.25891E-12
+    5    4    0.70346E-06    0.10000E+01    0.19533E+03    0.10694E-05    0.11828E-08    0.38552E-12
+    5    4    0.70346E-06    0.10000E+01    0.15752E+03    0.10694E-05    0.11828E-08    0.38552E-12
+    5    4    0.12275E-05    0.10000E+01    0.80645E+05    0.84841E-53    0.63803E-64    0.16488E-57
+    5    4    0.12275E-05    0.10000E+01    0.65036E+05    0.72075E-52    0.10165E-62    0.14015E-56
+    5    4    0.12275E-05    0.10000E+01    0.52449E+05    0.61464E-51    0.13751E-61    0.11957E-55
+    5    4    0.12275E-05    0.10000E+01    0.42297E+05    0.46499E-50    0.18880E-60    0.90538E-55
+    5    4    0.12275E-05    0.10000E+01    0.34111E+05    0.33848E-49    0.26324E-59    0.66004E-54
+    5    4    0.12275E-05    0.10000E+01    0.27509E+05    0.24653E-48    0.36554E-58    0.48187E-53
+    5    4    0.12275E-05    0.10000E+01    0.22184E+05    0.17954E-47    0.50457E-57    0.35220E-52
+    5    4    0.12275E-05    0.10000E+01    0.17891E+05    0.13021E-46    0.69290E-56    0.25680E-51
+    5    4    0.12275E-05    0.10000E+01    0.14428E+05    0.93982E-46    0.94846E-55    0.18665E-50
+    5    4    0.12275E-05    0.10000E+01    0.11635E+05    0.67574E-45    0.12951E-53    0.13532E-49
+    5    4    0.12275E-05    0.10000E+01    0.93834E+04    0.48441E-44    0.17618E-52    0.97887E-49
+    5    4    0.12275E-05    0.10000E+01    0.75673E+04    0.34603E-43    0.23827E-51    0.70616E-48
+    5    4    0.12275E-05    0.10000E+01    0.61026E+04    0.24592E-42    0.31998E-50    0.50730E-47
+    5    4    0.12275E-05    0.10000E+01    0.49215E+04    0.17367E-41    0.42722E-49    0.36227E-46
+    5    4    0.12275E-05    0.10000E+01    0.39689E+04    0.12196E-40    0.57159E-48    0.25658E-45
+    5    4    0.12275E-05    0.10000E+01    0.32008E+04    0.27016E-38    0.24765E-45    0.56578E-43
+    5    4    0.12275E-05    0.10000E+01    0.25813E+04    0.10323E-29    0.20646E-36    0.20545E-34
+    5    4    0.12275E-05    0.10000E+01    0.20817E+04    0.12730E-13    0.10322E-19    0.21365E-18
+    5    4    0.12275E-05    0.10000E+01    0.16788E+04    0.33828E-08    0.14179E-13    0.46005E-13
+    5    4    0.12275E-05    0.10000E+01    0.13538E+04    0.52878E-08    0.53423E-13    0.54247E-13
+    5    4    0.12275E-05    0.10000E+01    0.10918E+04    0.89720E-08    0.19793E-12    0.63995E-13
+    5    4    0.12275E-05    0.10000E+01    0.88049E+03    0.16159E-07    0.72458E-12    0.76068E-13
+    5    4    0.12275E-05    0.10000E+01    0.71007E+03    0.30128E-07    0.26256E-11    0.92073E-13
+    5    4    0.12275E-05    0.10000E+01    0.57264E+03    0.57059E-07    0.93065E-11    0.11506E-12
+    5    4    0.12275E-05    0.10000E+01    0.46180E+03    0.10832E-06    0.31221E-10    0.15059E-12
+    5    4    0.12275E-05    0.10000E+01    0.37242E+03    0.20347E-06    0.95046E-10    0.20822E-12
+    5    4    0.12275E-05    0.10000E+01    0.30034E+03    0.37220E-06    0.25468E-09    0.30229E-12
+    5    4    0.12275E-05    0.10000E+01    0.24221E+03    0.65188E-06    0.59431E-09    0.45079E-12
+    5    4    0.12275E-05    0.10000E+01    0.19533E+03    0.10239E-05    0.11290E-08    0.64295E-12
+    5    4    0.12275E-05    0.10000E+01    0.15752E+03    0.10239E-05    0.11290E-08    0.64295E-12
+    5    4    0.21419E-05    0.10000E+01    0.80645E+05    0.13869E-52    0.10432E-63    0.46363E-57
+    5    4    0.21419E-05    0.10000E+01    0.65036E+05    0.11784E-51    0.16622E-62    0.39413E-56
+    5    4    0.21419E-05    0.10000E+01    0.52449E+05    0.10051E-50    0.22493E-61    0.33630E-55
+    5    4    0.21419E-05    0.10000E+01    0.42297E+05    0.76056E-50    0.30899E-60    0.25468E-54
+    5    4    0.21419E-05    0.10000E+01    0.34111E+05    0.55388E-49    0.43116E-59    0.18572E-53
+    5    4    0.21419E-05    0.10000E+01    0.27509E+05    0.40370E-48    0.59945E-58    0.13565E-52
+    5    4    0.21419E-05    0.10000E+01    0.22184E+05    0.29432E-47    0.82894E-57    0.99214E-52
+    5    4    0.21419E-05    0.10000E+01    0.17891E+05    0.21380E-46    0.11410E-55    0.72412E-51
+    5    4    0.21419E-05    0.10000E+01    0.14428E+05    0.15464E-45    0.15660E-54    0.52702E-50
+    5    4    0.21419E-05    0.10000E+01    0.11635E+05    0.11146E-44    0.21442E-53    0.38268E-49
+    5    4    0.21419E-05    0.10000E+01    0.93834E+04    0.80119E-44    0.29253E-52    0.27733E-48
+    5    4    0.21419E-05    0.10000E+01    0.75673E+04    0.57393E-43    0.39680E-51    0.20048E-47
+    5    4    0.21419E-05    0.10000E+01    0.61026E+04    0.40906E-42    0.53418E-50    0.14439E-46
+    5    4    0.21419E-05    0.10000E+01    0.49215E+04    0.28959E-41    0.71308E-49    0.10344E-45
+    5    4    0.21419E-05    0.10000E+01    0.39689E+04    0.20342E-40    0.94600E-48    0.73561E-45
+    5    4    0.21419E-05    0.10000E+01    0.32008E+04    0.44742E-38    0.39664E-45    0.16308E-42
+    5    4    0.21419E-05    0.10000E+01    0.25813E+04    0.16618E-29    0.29575E-36    0.59597E-34
+    5    4    0.21419E-05    0.10000E+01    0.20817E+04    0.19136E-13    0.11131E-19    0.61942E-18
+    5    4    0.21419E-05    0.10000E+01    0.16788E+04    0.47414E-08    0.13861E-13    0.13230E-12
+    5    4    0.21419E-05    0.10000E+01    0.13538E+04    0.67892E-08    0.51642E-13    0.15616E-12
+    5    4    0.21419E-05    0.10000E+01    0.10918E+04    0.10550E-07    0.19019E-12    0.18364E-12
+    5    4    0.21419E-05    0.10000E+01    0.88049E+03    0.17669E-07    0.69379E-12    0.21601E-12
+    5    4    0.21419E-05    0.10000E+01    0.71007E+03    0.31273E-07    0.25085E-11    0.25574E-12
+    5    4    0.21419E-05    0.10000E+01    0.57264E+03    0.57252E-07    0.88784E-11    0.30753E-12
+    5    4    0.21419E-05    0.10000E+01    0.46180E+03    0.10643E-06    0.29758E-10    0.38004E-12
+    5    4    0.21419E-05    0.10000E+01    0.37242E+03    0.19744E-06    0.90543E-10    0.48803E-12
+    5    4    0.21419E-05    0.10000E+01    0.30034E+03    0.35854E-06    0.24254E-09    0.65365E-12
+    5    4    0.21419E-05    0.10000E+01    0.24221E+03    0.62529E-06    0.56586E-09    0.90448E-12
+    5    4    0.21419E-05    0.10000E+01    0.19533E+03    0.97995E-06    0.10748E-08    0.12211E-11
+    5    4    0.21419E-05    0.10000E+01    0.15752E+03    0.97995E-06    0.10748E-08    0.12211E-11
+    5    4    0.37375E-05    0.10000E+01    0.80645E+05    0.22587E-52    0.16992E-63    0.13048E-56
+    5    4    0.37375E-05    0.10000E+01    0.65036E+05    0.19194E-51    0.27078E-62    0.11093E-55
+    5    4    0.37375E-05    0.10000E+01    0.52449E+05    0.16373E-50    0.36652E-61    0.94661E-55
+    5    4    0.37375E-05    0.10000E+01    0.42297E+05    0.12392E-49    0.50372E-60    0.71698E-54
+    5    4    0.37375E-05    0.10000E+01    0.34111E+05    0.90284E-49    0.70338E-59    0.52298E-53
+    5    4    0.37375E-05    0.10000E+01    0.27509E+05    0.65845E-48    0.97900E-58    0.38213E-52
+    5    4    0.37375E-05    0.10000E+01    0.22184E+05    0.48052E-47    0.13560E-56    0.27967E-51
+    5    4    0.37375E-05    0.10000E+01    0.17891E+05    0.34956E-46    0.18703E-55    0.20430E-50
+    5    4    0.37375E-05    0.10000E+01    0.14428E+05    0.25331E-45    0.25730E-54    0.14887E-49
+    5    4    0.37375E-05    0.10000E+01    0.11635E+05    0.18299E-44    0.35320E-53    0.10825E-48
+    5    4    0.37375E-05    0.10000E+01    0.93834E+04    0.13185E-43    0.48320E-52    0.78575E-48
+    5    4    0.37375E-05    0.10000E+01    0.75673E+04    0.94706E-43    0.65747E-51    0.56909E-47
+    5    4    0.37375E-05    0.10000E+01    0.61026E+04    0.67702E-42    0.88801E-50    0.41078E-46
+    5    4    0.37375E-05    0.10000E+01    0.49215E+04    0.48079E-41    0.11885E-48    0.29510E-45
+    5    4    0.37375E-05    0.10000E+01    0.39689E+04    0.33860E-40    0.15754E-47    0.21063E-44
+    5    4    0.37375E-05    0.10000E+01    0.32008E+04    0.74434E-38    0.65181E-45    0.46916E-42
+    5    4    0.37375E-05    0.10000E+01    0.25813E+04    0.27305E-29    0.45527E-36    0.17239E-33
+    5    4    0.37375E-05    0.10000E+01    0.20817E+04    0.30082E-13    0.12958E-19    0.17921E-17
+    5    4    0.37375E-05    0.10000E+01    0.16788E+04    0.70552E-08    0.13724E-13    0.38074E-12
+    5    4    0.37375E-05    0.10000E+01    0.13538E+04    0.94036E-08    0.50006E-13    0.45095E-12
+    5    4    0.37375E-05    0.10000E+01    0.10918E+04    0.13403E-07    0.18199E-12    0.53148E-12
+    5    4    0.37375E-05    0.10000E+01    0.88049E+03    0.20604E-07    0.65949E-12    0.62467E-12
+    5    4    0.37375E-05    0.10000E+01    0.71007E+03    0.33954E-07    0.23751E-11    0.73503E-12
+    5    4    0.37375E-05    0.10000E+01    0.57264E+03    0.59005E-07    0.83864E-11    0.87099E-12
+    5    4    0.37375E-05    0.10000E+01    0.46180E+03    0.10596E-06    0.28069E-10    0.10479E-11
+    5    4    0.37375E-05    0.10000E+01    0.37242E+03    0.19235E-06    0.85335E-10    0.12915E-11
+    5    4    0.37375E-05    0.10000E+01    0.30034E+03    0.34478E-06    0.22848E-09    0.16403E-11
+    5    4    0.37375E-05    0.10000E+01    0.24221E+03    0.59671E-06    0.53291E-09    0.21414E-11
+    5    4    0.37375E-05    0.10000E+01    0.19533E+03    0.93131E-06    0.10121E-08    0.27522E-11
+    5    4    0.37375E-05    0.10000E+01    0.15752E+03    0.93131E-06    0.10121E-08    0.27522E-11
+    5    4    0.65217E-05    0.10000E+01    0.80645E+05    0.36671E-52    0.27593E-63    0.36528E-56
+    5    4    0.65217E-05    0.10000E+01    0.65036E+05    0.31167E-51    0.43976E-62    0.31057E-55
+    5    4    0.65217E-05    0.10000E+01    0.52449E+05    0.26589E-50    0.59539E-61    0.26504E-54
+    5    4    0.65217E-05    0.10000E+01    0.42297E+05    0.20129E-49    0.81861E-60    0.20078E-53
+    5    4    0.65217E-05    0.10000E+01    0.34111E+05    0.14670E-48    0.11438E-58    0.14648E-52
+    5    4    0.65217E-05    0.10000E+01    0.27509E+05    0.10705E-47    0.15935E-57    0.10707E-51
+    5    4    0.65217E-05    0.10000E+01    0.22184E+05    0.78191E-47    0.22102E-56    0.78403E-51
+    5    4    0.65217E-05    0.10000E+01    0.17891E+05    0.56953E-46    0.30542E-55    0.57320E-50
+    5    4    0.65217E-05    0.10000E+01    0.14428E+05    0.41339E-45    0.42105E-54    0.41810E-49
+    5    4    0.65217E-05    0.10000E+01    0.11635E+05    0.29922E-44    0.57930E-53    0.30441E-48
+    5    4    0.65217E-05    0.10000E+01    0.93834E+04    0.21608E-43    0.79454E-52    0.22127E-47
+    5    4    0.65217E-05    0.10000E+01    0.75673E+04    0.15559E-42    0.10843E-50    0.16052E-46
+    5    4    0.65217E-05    0.10000E+01    0.61026E+04    0.11154E-41    0.14696E-49    0.11610E-45
+    5    4    0.65217E-05    0.10000E+01    0.49215E+04    0.79470E-41    0.19743E-48    0.83609E-45
+    5    4    0.65217E-05    0.10000E+01    0.39689E+04    0.56164E-40    0.26240E-47    0.59866E-44
+    5    4    0.65217E-05    0.10000E+01    0.32008E+04    0.12377E-37    0.10829E-44    0.13389E-41
+    5    4    0.65217E-05    0.10000E+01    0.25813E+04    0.45247E-29    0.73319E-36    0.49429E-33
+    5    4    0.65217E-05    0.10000E+01    0.20817E+04    0.48558E-13    0.16671E-19    0.51404E-17
+    5    4    0.65217E-05    0.10000E+01    0.16788E+04    0.10957E-07    0.14100E-13    0.10879E-11
+    5    4    0.65217E-05    0.10000E+01    0.13538E+04    0.13896E-07    0.49355E-13    0.12939E-11
+    5    4    0.65217E-05    0.10000E+01    0.10918E+04    0.18456E-07    0.17561E-12    0.15313E-11
+    5    4    0.65217E-05    0.10000E+01    0.88049E+03    0.26088E-07    0.62829E-12    0.18058E-11
+    5    4    0.65217E-05    0.10000E+01    0.71007E+03    0.39556E-07    0.22461E-11    0.21278E-11
+    5    4    0.65217E-05    0.10000E+01    0.57264E+03    0.64063E-07    0.78970E-11    0.25157E-11
+    5    4    0.65217E-05    0.10000E+01    0.46180E+03    0.10916E-06    0.26365E-10    0.30018E-11
+    5    4    0.65217E-05    0.10000E+01    0.37242E+03    0.19127E-06    0.80040E-10    0.36394E-11
+    5    4    0.65217E-05    0.10000E+01    0.30034E+03    0.33529E-06    0.21412E-09    0.45060E-11
+    5    4    0.65217E-05    0.10000E+01    0.24221E+03    0.57250E-06    0.49919E-09    0.56955E-11
+    5    4    0.65217E-05    0.10000E+01    0.19533E+03    0.88696E-06    0.94778E-09    0.70971E-11
+    5    4    0.65217E-05    0.10000E+01    0.15752E+03    0.88696E-06    0.94778E-09    0.70971E-11
+    5    4    0.11380E-04    0.10000E+01    0.80645E+05    0.59349E-52    0.44663E-63    0.10061E-55
+    5    4    0.11380E-04    0.10000E+01    0.65036E+05    0.50446E-51    0.71187E-62    0.85548E-55
+    5    4    0.11380E-04    0.10000E+01    0.52449E+05    0.43041E-50    0.96401E-61    0.73012E-54
+    5    4    0.11380E-04    0.10000E+01    0.42297E+05    0.32590E-49    0.13259E-59    0.55314E-53
+    5    4    0.11380E-04    0.10000E+01    0.34111E+05    0.23759E-48    0.18537E-58    0.40364E-52
+    5    4    0.11380E-04    0.10000E+01    0.27509E+05    0.17347E-47    0.25847E-57    0.29513E-51
+    5    4    0.11380E-04    0.10000E+01    0.22184E+05    0.12679E-46    0.35894E-56    0.21621E-50
+    5    4    0.11380E-04    0.10000E+01    0.17891E+05    0.92457E-46    0.49683E-55    0.15817E-49
+    5    4    0.11380E-04    0.10000E+01    0.14428E+05    0.67209E-45    0.68619E-54    0.11548E-48
+    5    4    0.11380E-04    0.10000E+01    0.11635E+05    0.48733E-44    0.94602E-53    0.84164E-48
+    5    4    0.11380E-04    0.10000E+01    0.93834E+04    0.35262E-43    0.13005E-51    0.61253E-47
+    5    4    0.11380E-04    0.10000E+01    0.75673E+04    0.25446E-42    0.17798E-50    0.44497E-46
+    5    4    0.11380E-04    0.10000E+01    0.61026E+04    0.18290E-41    0.24203E-49    0.32237E-45
+    5    4    0.11380E-04    0.10000E+01    0.49215E+04    0.13072E-40    0.32641E-48    0.23264E-44
+    5    4    0.11380E-04    0.10000E+01    0.39689E+04    0.92724E-40    0.43563E-47    0.16702E-43
+    5    4    0.11380E-04    0.10000E+01    0.32008E+04    0.20511E-37    0.18023E-44    0.37481E-41
+    5    4    0.11380E-04    0.10000E+01    0.25813E+04    0.75049E-29    0.12073E-35    0.13891E-32
+    5    4    0.11380E-04    0.10000E+01    0.20817E+04    0.79368E-13    0.23645E-19    0.14451E-16
+    5    4    0.11380E-04    0.10000E+01    0.16788E+04    0.17458E-07    0.15467E-13    0.30497E-11
+    5    4    0.11380E-04    0.10000E+01    0.13538E+04    0.21483E-07    0.50777E-13    0.36417E-11
+    5    4    0.11380E-04    0.10000E+01    0.10918E+04    0.27168E-07    0.17361E-12    0.43282E-11
+    5    4    0.11380E-04    0.10000E+01    0.88049E+03    0.35872E-07    0.60660E-12    0.51263E-11
+    5    4    0.11380E-04    0.10000E+01    0.71007E+03    0.50180E-07    0.21385E-11    0.60635E-11
+    5    4    0.11380E-04    0.10000E+01    0.57264E+03    0.74958E-07    0.74568E-11    0.71859E-11
+    5    4    0.11380E-04    0.10000E+01    0.46180E+03    0.11913E-06    0.24777E-10    0.85713E-11
+    5    4    0.11380E-04    0.10000E+01    0.37242E+03    0.19804E-06    0.75014E-10    0.10344E-10
+    5    4    0.11380E-04    0.10000E+01    0.30034E+03    0.33488E-06    0.20037E-09    0.12679E-10
+    5    4    0.11380E-04    0.10000E+01    0.24221E+03    0.55884E-06    0.46668E-09    0.15788E-10
+    5    4    0.11380E-04    0.10000E+01    0.19533E+03    0.85469E-06    0.88562E-09    0.19359E-10
+    5    4    0.11380E-04    0.10000E+01    0.15752E+03    0.85469E-06    0.88562E-09    0.19359E-10
+    5    4    0.19857E-04    0.10000E+01    0.80645E+05    0.95563E-52    0.71925E-63    0.26622E-55
+    5    4    0.19857E-04    0.10000E+01    0.65036E+05    0.81237E-51    0.11465E-61    0.22638E-54
+    5    4    0.19857E-04    0.10000E+01    0.52449E+05    0.69317E-50    0.15529E-60    0.19322E-53
+    5    4    0.19857E-04    0.10000E+01    0.42297E+05    0.52495E-49    0.21366E-59    0.14640E-52
+    5    4    0.19857E-04    0.10000E+01    0.34111E+05    0.38282E-48    0.29884E-58    0.10685E-51
+    5    4    0.19857E-04    0.10000E+01    0.27509E+05    0.27961E-47    0.41700E-57    0.78141E-51
+    5    4    0.19857E-04    0.10000E+01    0.22184E+05    0.20452E-46    0.57974E-56    0.57267E-50
+    5    4    0.19857E-04    0.10000E+01    0.17891E+05    0.14928E-45    0.80358E-55    0.41917E-49
+    5    4    0.19857E-04    0.10000E+01    0.14428E+05    0.10865E-44    0.11117E-53    0.30624E-48
+    5    4    0.19857E-04    0.10000E+01    0.11635E+05    0.78906E-44    0.15354E-52    0.22338E-47
+    5    4    0.19857E-04    0.10000E+01    0.93834E+04    0.57193E-43    0.21151E-51    0.16273E-46
+    5    4    0.19857E-04    0.10000E+01    0.75673E+04    0.41355E-42    0.29017E-50    0.11835E-45
+    5    4    0.19857E-04    0.10000E+01    0.61026E+04    0.29794E-41    0.39580E-49    0.85855E-45
+    5    4    0.19857E-04    0.10000E+01    0.49215E+04    0.21355E-40    0.53581E-48    0.62062E-44
+    5    4    0.19857E-04    0.10000E+01    0.39689E+04    0.15201E-39    0.71830E-47    0.44651E-43
+    5    4    0.19857E-04    0.10000E+01    0.32008E+04    0.33759E-37    0.29854E-44    0.10047E-40
+    5    4    0.19857E-04    0.10000E+01    0.25813E+04    0.12388E-28    0.19994E-35    0.37348E-32
+    5    4    0.19857E-04    0.10000E+01    0.20817E+04    0.12998E-12    0.36056E-19    0.38866E-16
+    5    4    0.19857E-04    0.10000E+01    0.16788E+04    0.28125E-07    0.18597E-13    0.81845E-11
+    5    4    0.19857E-04    0.10000E+01    0.13538E+04    0.34058E-07    0.56051E-13    0.98046E-11
+    5    4    0.19857E-04    0.10000E+01    0.10918E+04    0.41823E-07    0.18021E-12    0.11696E-10
+    5    4    0.19857E-04    0.10000E+01    0.88049E+03    0.52702E-07    0.60482E-12    0.13906E-10
+    5    4    0.19857E-04    0.10000E+01    0.71007E+03    0.69133E-07    0.20790E-11    0.16512E-10
+    5    4    0.19857E-04    0.10000E+01    0.57264E+03    0.95689E-07    0.71382E-11    0.19632E-10
+    5    4    0.19857E-04    0.10000E+01    0.46180E+03    0.14075E-06    0.23502E-10    0.23460E-10
+    5    4    0.19857E-04    0.10000E+01    0.37242E+03    0.21866E-06    0.70779E-10    0.28297E-10
+    5    4    0.19857E-04    0.10000E+01    0.30034E+03    0.35113E-06    0.18848E-09    0.34561E-10
+    5    4    0.19857E-04    0.10000E+01    0.24221E+03    0.56540E-06    0.43821E-09    0.42737E-10
+    5    4    0.19857E-04    0.10000E+01    0.19533E+03    0.84656E-06    0.83075E-09    0.51972E-10
+    5    4    0.19857E-04    0.10000E+01    0.15752E+03    0.84656E-06    0.83075E-09    0.51972E-10
+    5    4    0.34650E-04    0.10000E+01    0.80645E+05    0.16347E-51    0.12304E-62    0.50702E-55
+    5    4    0.34650E-04    0.10000E+01    0.65036E+05    0.13897E-50    0.19613E-61    0.43115E-54
+    5    4    0.34650E-04    0.10000E+01    0.52449E+05    0.11858E-49    0.26566E-60    0.36799E-53
+    5    4    0.34650E-04    0.10000E+01    0.42297E+05    0.89806E-49    0.36554E-59    0.27882E-52
+    5    4    0.34650E-04    0.10000E+01    0.34111E+05    0.65494E-48    0.51133E-58    0.20350E-51
+    5    4    0.34650E-04    0.10000E+01    0.27509E+05    0.47842E-47    0.71363E-57    0.14884E-50
+    5    4    0.34650E-04    0.10000E+01    0.22184E+05    0.34999E-46    0.99236E-56    0.10908E-49
+    5    4    0.34650E-04    0.10000E+01    0.17891E+05    0.25551E-45    0.13759E-54    0.79855E-49
+    5    4    0.34650E-04    0.10000E+01    0.14428E+05    0.18603E-44    0.19041E-53    0.58348E-48
+    5    4    0.34650E-04    0.10000E+01    0.11635E+05    0.13514E-43    0.26309E-52    0.42569E-47
+    5    4    0.34650E-04    0.10000E+01    0.93834E+04    0.97987E-43    0.36258E-51    0.31016E-46
+    5    4    0.34650E-04    0.10000E+01    0.75673E+04    0.70882E-42    0.49769E-50    0.22562E-45
+    5    4    0.34650E-04    0.10000E+01    0.61026E+04    0.51093E-41    0.67931E-49    0.16372E-44
+    5    4    0.34650E-04    0.10000E+01    0.49215E+04    0.36643E-40    0.92037E-48    0.11838E-43
+    5    4    0.34650E-04    0.10000E+01    0.39689E+04    0.26103E-39    0.12351E-46    0.85206E-43
+    5    4    0.34650E-04    0.10000E+01    0.32008E+04    0.58025E-37    0.51393E-44    0.19182E-40
+    5    4    0.34650E-04    0.10000E+01    0.25813E+04    0.21308E-28    0.34445E-35    0.71349E-32
+    5    4    0.34650E-04    0.10000E+01    0.20817E+04    0.22331E-12    0.61382E-19    0.74254E-16
+    5    4    0.34650E-04    0.10000E+01    0.16788E+04    0.48181E-07    0.30191E-13    0.15630E-10
+    5    4    0.34650E-04    0.10000E+01    0.13538E+04    0.58212E-07    0.89076E-13    0.18736E-10
+    5    4    0.34650E-04    0.10000E+01    0.10918E+04    0.71153E-07    0.28154E-12    0.22365E-10
+    5    4    0.34650E-04    0.10000E+01    0.88049E+03    0.88956E-07    0.93357E-12    0.26614E-10
+    5    4    0.34650E-04    0.10000E+01    0.71007E+03    0.11532E-06    0.31836E-11    0.31624E-10
+    5    4    0.34650E-04    0.10000E+01    0.57264E+03    0.15716E-06    0.10876E-10    0.37626E-10
+    5    4    0.34650E-04    0.10000E+01    0.46180E+03    0.22716E-06    0.35698E-10    0.44986E-10
+    5    4    0.34650E-04    0.10000E+01    0.37242E+03    0.34703E-06    0.10732E-09    0.54266E-10
+    5    4    0.34650E-04    0.10000E+01    0.30034E+03    0.54958E-06    0.28549E-09    0.66249E-10
+    5    4    0.34650E-04    0.10000E+01    0.24221E+03    0.87594E-06    0.66335E-09    0.81836E-10
+    5    4    0.34650E-04    0.10000E+01    0.19533E+03    0.13033E-05    0.12571E-08    0.99389E-10
+    5    4    0.34650E-04    0.10000E+01    0.15752E+03    0.13033E-05    0.12571E-08    0.99389E-10
+    5    4    0.60462E-04    0.10000E+01    0.80645E+05    0.28525E-51    0.21470E-62    0.88473E-55
+    5    4    0.60462E-04    0.10000E+01    0.65036E+05    0.24249E-50    0.34223E-61    0.75234E-54
+    5    4    0.60462E-04    0.10000E+01    0.52449E+05    0.20692E-49    0.46356E-60    0.64213E-53
+    5    4    0.60462E-04    0.10000E+01    0.42297E+05    0.15671E-48    0.63785E-59    0.48653E-52
+    5    4    0.60462E-04    0.10000E+01    0.34111E+05    0.11428E-47    0.89224E-58    0.35510E-51
+    5    4    0.60462E-04    0.10000E+01    0.27509E+05    0.83482E-47    0.12452E-56    0.25971E-50
+    5    4    0.60462E-04    0.10000E+01    0.22184E+05    0.61070E-46    0.17316E-55    0.19035E-49
+    5    4    0.60462E-04    0.10000E+01    0.17891E+05    0.44585E-45    0.24009E-54    0.13934E-48
+    5    4    0.60462E-04    0.10000E+01    0.14428E+05    0.32460E-44    0.33226E-53    0.10181E-47
+    5    4    0.60462E-04    0.10000E+01    0.11635E+05    0.23581E-43    0.45907E-52    0.74280E-47
+    5    4    0.60462E-04    0.10000E+01    0.93834E+04    0.17098E-42    0.63268E-51    0.54122E-46
+    5    4    0.60462E-04    0.10000E+01    0.75673E+04    0.12368E-41    0.86843E-50    0.39369E-45
+    5    4    0.60462E-04    0.10000E+01    0.61026E+04    0.89154E-41    0.11854E-48    0.28567E-44
+    5    4    0.60462E-04    0.10000E+01    0.49215E+04    0.63940E-40    0.16060E-47    0.20657E-43
+    5    4    0.60462E-04    0.10000E+01    0.39689E+04    0.45548E-39    0.21551E-46    0.14868E-42
+    5    4    0.60462E-04    0.10000E+01    0.32008E+04    0.10125E-36    0.89677E-44    0.33471E-40
+    5    4    0.60462E-04    0.10000E+01    0.25813E+04    0.37182E-28    0.60104E-35    0.12450E-31
+    5    4    0.60462E-04    0.10000E+01    0.20817E+04    0.38967E-12    0.10711E-18    0.12957E-15
+    5    4    0.60462E-04    0.10000E+01    0.16788E+04    0.84073E-07    0.52681E-13    0.27274E-10
+    5    4    0.60462E-04    0.10000E+01    0.13538E+04    0.10158E-06    0.15543E-12    0.32693E-10
+    5    4    0.60462E-04    0.10000E+01    0.10918E+04    0.12416E-06    0.49128E-12    0.39026E-10
+    5    4    0.60462E-04    0.10000E+01    0.88049E+03    0.15522E-06    0.16290E-11    0.46439E-10
+    5    4    0.60462E-04    0.10000E+01    0.71007E+03    0.20122E-06    0.55551E-11    0.55182E-10
+    5    4    0.60462E-04    0.10000E+01    0.57264E+03    0.27423E-06    0.18977E-10    0.65655E-10
+    5    4    0.60462E-04    0.10000E+01    0.46180E+03    0.39638E-06    0.62291E-10    0.78497E-10
+    5    4    0.60462E-04    0.10000E+01    0.37242E+03    0.60555E-06    0.18726E-09    0.94691E-10
+    5    4    0.60462E-04    0.10000E+01    0.30034E+03    0.95898E-06    0.49816E-09    0.11560E-09
+    5    4    0.60462E-04    0.10000E+01    0.24221E+03    0.15285E-05    0.11575E-08    0.14280E-09
+    5    4    0.60462E-04    0.10000E+01    0.19533E+03    0.22741E-05    0.21936E-08    0.17343E-09
+    5    4    0.60462E-04    0.10000E+01    0.15752E+03    0.22741E-05    0.21936E-08    0.17343E-09
+    5    4    0.10550E-03    0.10000E+01    0.80645E+05    0.49774E-51    0.37464E-62    0.15438E-54
+    5    4    0.10550E-03    0.10000E+01    0.65036E+05    0.42313E-50    0.59718E-61    0.13128E-53
+    5    4    0.10550E-03    0.10000E+01    0.52449E+05    0.36106E-49    0.80889E-60    0.11205E-52
+    5    4    0.10550E-03    0.10000E+01    0.42297E+05    0.27344E-48    0.11130E-58    0.84896E-52
+    5    4    0.10550E-03    0.10000E+01    0.34111E+05    0.19942E-47    0.15569E-57    0.61963E-51
+    5    4    0.10550E-03    0.10000E+01    0.27509E+05    0.14567E-46    0.21729E-56    0.45318E-50
+    5    4    0.10550E-03    0.10000E+01    0.22184E+05    0.10656E-45    0.30216E-55    0.33214E-49
+    5    4    0.10550E-03    0.10000E+01    0.17891E+05    0.77798E-45    0.41895E-54    0.24314E-48
+    5    4    0.10550E-03    0.10000E+01    0.14428E+05    0.56641E-44    0.57978E-53    0.17766E-47
+    5    4    0.10550E-03    0.10000E+01    0.11635E+05    0.41147E-43    0.80105E-52    0.12961E-46
+    5    4    0.10550E-03    0.10000E+01    0.93834E+04    0.29835E-42    0.11040E-50    0.94439E-46
+    5    4    0.10550E-03    0.10000E+01    0.75673E+04    0.21582E-41    0.15154E-49    0.68697E-45
+    5    4    0.10550E-03    0.10000E+01    0.61026E+04    0.15557E-40    0.20684E-48    0.49848E-44
+    5    4    0.10550E-03    0.10000E+01    0.49215E+04    0.11157E-39    0.28023E-47    0.36046E-43
+    5    4    0.10550E-03    0.10000E+01    0.39689E+04    0.79479E-39    0.37606E-46    0.25944E-42
+    5    4    0.10550E-03    0.10000E+01    0.32008E+04    0.17667E-36    0.15648E-43    0.58406E-40
+    5    4    0.10550E-03    0.10000E+01    0.25813E+04    0.64880E-28    0.10488E-34    0.21725E-31
+    5    4    0.10550E-03    0.10000E+01    0.20817E+04    0.67995E-12    0.18690E-18    0.22609E-15
+    5    4    0.10550E-03    0.10000E+01    0.16788E+04    0.14670E-06    0.91926E-13    0.47591E-10
+    5    4    0.10550E-03    0.10000E+01    0.13538E+04    0.17724E-06    0.27122E-12    0.57048E-10
+    5    4    0.10550E-03    0.10000E+01    0.10918E+04    0.21665E-06    0.85725E-12    0.68099E-10
+    5    4    0.10550E-03    0.10000E+01    0.88049E+03    0.27086E-06    0.28425E-11    0.81033E-10
+    5    4    0.10550E-03    0.10000E+01    0.71007E+03    0.35111E-06    0.96933E-11    0.96290E-10
+    5    4    0.10550E-03    0.10000E+01    0.57264E+03    0.47852E-06    0.33114E-10    0.11456E-09
+    5    4    0.10550E-03    0.10000E+01    0.46180E+03    0.69166E-06    0.10869E-09    0.13697E-09
+    5    4    0.10550E-03    0.10000E+01    0.37242E+03    0.10566E-05    0.32676E-09    0.16523E-09
+    5    4    0.10550E-03    0.10000E+01    0.30034E+03    0.16734E-05    0.86926E-09    0.20171E-09
+    5    4    0.10550E-03    0.10000E+01    0.24221E+03    0.26671E-05    0.20198E-08    0.24918E-09
+    5    4    0.10550E-03    0.10000E+01    0.19533E+03    0.39682E-05    0.38277E-08    0.30262E-09
+    5    4    0.10550E-03    0.10000E+01    0.15752E+03    0.39682E-05    0.38277E-08    0.30262E-09
+    5    4    0.18409E-03    0.10000E+01    0.80645E+05    0.86853E-51    0.65372E-62    0.26938E-54
+    5    4    0.18409E-03    0.10000E+01    0.65036E+05    0.73834E-50    0.10420E-60    0.22907E-53
+    5    4    0.18409E-03    0.10000E+01    0.52449E+05    0.63002E-49    0.14115E-59    0.19552E-52
+    5    4    0.18409E-03    0.10000E+01    0.42297E+05    0.47714E-48    0.19421E-58    0.14814E-51
+    5    4    0.18409E-03    0.10000E+01    0.34111E+05    0.34797E-47    0.27167E-57    0.10812E-50
+    5    4    0.18409E-03    0.10000E+01    0.27509E+05    0.25419E-46    0.37915E-56    0.79078E-50
+    5    4    0.18409E-03    0.10000E+01    0.22184E+05    0.18595E-45    0.52724E-55    0.57957E-49
+    5    4    0.18409E-03    0.10000E+01    0.17891E+05    0.13575E-44    0.73104E-54    0.42427E-48
+    5    4    0.18409E-03    0.10000E+01    0.14428E+05    0.98835E-44    0.10117E-52    0.31001E-47
+    5    4    0.18409E-03    0.10000E+01    0.11635E+05    0.71799E-43    0.13978E-51    0.22617E-46
+    5    4    0.18409E-03    0.10000E+01    0.93834E+04    0.52061E-42    0.19264E-50    0.16479E-45
+    5    4    0.18409E-03    0.10000E+01    0.75673E+04    0.37660E-41    0.26442E-49    0.11987E-44
+    5    4    0.18409E-03    0.10000E+01    0.61026E+04    0.27146E-40    0.36092E-48    0.86982E-44
+    5    4    0.18409E-03    0.10000E+01    0.49215E+04    0.19469E-39    0.48899E-47    0.62897E-43
+    5    4    0.18409E-03    0.10000E+01    0.39689E+04    0.13869E-38    0.65620E-46    0.45270E-42
+    5    4    0.18409E-03    0.10000E+01    0.32008E+04    0.30829E-36    0.27305E-43    0.10191E-39
+    5    4    0.18409E-03    0.10000E+01    0.25813E+04    0.11321E-27    0.18301E-34    0.37908E-31
+    5    4    0.18409E-03    0.10000E+01    0.20817E+04    0.11865E-11    0.32612E-18    0.39451E-15
+    5    4    0.18409E-03    0.10000E+01    0.16788E+04    0.25599E-06    0.16041E-12    0.83043E-10
+    5    4    0.18409E-03    0.10000E+01    0.13538E+04    0.30928E-06    0.47326E-12    0.99545E-10
+    5    4    0.18409E-03    0.10000E+01    0.10918E+04    0.37804E-06    0.14958E-11    0.11883E-09
+    5    4    0.18409E-03    0.10000E+01    0.88049E+03    0.47263E-06    0.49601E-11    0.14140E-09
+    5    4    0.18409E-03    0.10000E+01    0.71007E+03    0.61267E-06    0.16914E-10    0.16802E-09
+    5    4    0.18409E-03    0.10000E+01    0.57264E+03    0.83498E-06    0.57782E-10    0.19991E-09
+    5    4    0.18409E-03    0.10000E+01    0.46180E+03    0.12069E-05    0.18966E-09    0.23901E-09
+    5    4    0.18409E-03    0.10000E+01    0.37242E+03    0.18438E-05    0.57018E-09    0.28832E-09
+    5    4    0.18409E-03    0.10000E+01    0.30034E+03    0.29199E-05    0.15168E-08    0.35198E-09
+    5    4    0.18409E-03    0.10000E+01    0.24221E+03    0.46539E-05    0.35244E-08    0.43480E-09
+    5    4    0.18409E-03    0.10000E+01    0.19533E+03    0.69242E-05    0.66791E-08    0.52805E-09
+    5    4    0.18409E-03    0.10000E+01    0.15752E+03    0.69242E-05    0.66791E-08    0.52805E-09
+    5    4    0.32123E-03    0.10000E+01    0.80645E+05    0.15155E-50    0.11407E-61    0.47006E-54
+    5    4    0.32123E-03    0.10000E+01    0.65036E+05    0.12884E-49    0.18183E-60    0.39972E-53
+    5    4    0.32123E-03    0.10000E+01    0.52449E+05    0.10994E-48    0.24629E-59    0.34116E-52
+    5    4    0.32123E-03    0.10000E+01    0.42297E+05    0.83258E-48    0.33889E-58    0.25849E-51
+    5    4    0.32123E-03    0.10000E+01    0.34111E+05    0.60719E-47    0.47405E-57    0.18867E-50
+    5    4    0.32123E-03    0.10000E+01    0.27509E+05    0.44354E-46    0.66160E-56    0.13799E-49
+    5    4    0.32123E-03    0.10000E+01    0.22184E+05    0.32447E-45    0.92001E-55    0.10113E-48
+    5    4    0.32123E-03    0.10000E+01    0.17891E+05    0.23688E-44    0.12756E-53    0.74032E-48
+    5    4    0.32123E-03    0.10000E+01    0.14428E+05    0.17246E-43    0.17653E-52    0.54094E-47
+    5    4    0.32123E-03    0.10000E+01    0.11635E+05    0.12528E-42    0.24391E-51    0.39465E-46
+    5    4    0.32123E-03    0.10000E+01    0.93834E+04    0.90842E-42    0.33614E-50    0.28755E-45
+    5    4    0.32123E-03    0.10000E+01    0.75673E+04    0.65714E-41    0.46140E-49    0.20917E-44
+    5    4    0.32123E-03    0.10000E+01    0.61026E+04    0.47367E-40    0.62978E-48    0.15178E-43
+    5    4    0.32123E-03    0.10000E+01    0.49215E+04    0.33971E-39    0.85326E-47    0.10975E-42
+    5    4    0.32123E-03    0.10000E+01    0.39689E+04    0.24200E-38    0.11450E-45    0.78994E-42
+    5    4    0.32123E-03    0.10000E+01    0.32008E+04    0.53794E-36    0.47646E-43    0.17783E-39
+    5    4    0.32123E-03    0.10000E+01    0.25813E+04    0.19755E-27    0.31933E-34    0.66147E-31
+    5    4    0.32123E-03    0.10000E+01    0.20817E+04    0.20703E-11    0.56907E-18    0.68840E-15
+    5    4    0.32123E-03    0.10000E+01    0.16788E+04    0.44668E-06    0.27990E-12    0.14491E-09
+    5    4    0.32123E-03    0.10000E+01    0.13538E+04    0.53967E-06    0.82581E-12    0.17370E-09
+    5    4    0.32123E-03    0.10000E+01    0.10918E+04    0.65965E-06    0.26102E-11    0.20735E-09
+    5    4    0.32123E-03    0.10000E+01    0.88049E+03    0.82470E-06    0.86550E-11    0.24673E-09
+    5    4    0.32123E-03    0.10000E+01    0.71007E+03    0.10691E-05    0.29514E-10    0.29318E-09
+    5    4    0.32123E-03    0.10000E+01    0.57264E+03    0.14570E-05    0.10083E-09    0.34883E-09
+    5    4    0.32123E-03    0.10000E+01    0.46180E+03    0.21060E-05    0.33095E-09    0.41706E-09
+    5    4    0.32123E-03    0.10000E+01    0.37242E+03    0.32173E-05    0.99493E-09    0.50310E-09
+    5    4    0.32123E-03    0.10000E+01    0.30034E+03    0.50951E-05    0.26467E-08    0.61418E-09
+    5    4    0.32123E-03    0.10000E+01    0.24221E+03    0.81208E-05    0.61498E-08    0.75869E-09
+    5    4    0.32123E-03    0.10000E+01    0.19533E+03    0.12082E-04    0.11655E-07    0.92142E-09
+    5    4    0.32123E-03    0.10000E+01    0.15752E+03    0.12082E-04    0.11655E-07    0.92142E-09
diff --git a/wrfv2_fire/share/Makefile b/wrfv2_fire/share/Makefile
index 69f1f7e6..18562952 100644
--- a/wrfv2_fire/share/Makefile
+++ b/wrfv2_fire/share/Makefile
@@ -59,6 +59,7 @@ OBJS3   =                               \
         landread.o			\
         track_driver.o                  \
         track_input.o                   \
+        module_trajectory.o             \
         bobrand.o                       \
         wrf_timeseries.o                \
         track_driver.o                  \
diff --git a/wrfv2_fire/share/dfi.F b/wrfv2_fire/share/dfi.F
index 41d8ebf2..f3777e9e 100644
--- a/wrfv2_fire/share/dfi.F
+++ b/wrfv2_fire/share/dfi.F
@@ -1,3 +1,18 @@
+! sed -e "s/grid%mu/gridmu/g" -e "s/grid%Mu/gridMu/g" dfi.F | cpp -DHYBRID_COORD | sed -e "s/gridmu/grid%mu/g" -e "s/gridMu/grid%Mu/g" >> dfi.next
+#if ( HYBRID_COORD==1 )
+#  define gridmu_2(...) (grid%c1h(k)*XXPC2HXX(__VA_ARGS__))
+#  define XXPC2HXX(...) grid%mu_2(__VA_ARGS__)
+
+#  define gridmub(...) (grid%c1h(k)*XXPCBHXX(__VA_ARGS__)+grid%c2h(k))
+#  define XXPCBHXX(...) grid%mub(__VA_ARGS__)
+
+#  define gridMu_2(...) (grid%c1f(k)*XXPC2FXX(__VA_ARGS__))
+#  define XXPC2FXX(...) grid%Mu_2(__VA_ARGS__)
+
+#  define gridMub(...) (grid%c1f(k)*XXPCBFXX(__VA_ARGS__)+grid%c2f(k))
+#  define XXPCBFXX(...) grid%Mub(__VA_ARGS__)
+#endif
+
    SUBROUTINE dfi_accumulate( grid )
 
       USE module_domain, ONLY : domain
@@ -25,7 +40,7 @@ SUBROUTINE dfi_accumulate( grid )
       hn = grid%hcoeff(grid%itimestep+1)
 
       ! accumulate dynamic variables
-       grid%dfi_mu(:,:)    = grid%dfi_mu(:,:)    + grid%mu_2(:,:)    * hn
+       grid%dfi_mu(:,:)    = grid%dfi_mu(:,:)    + grid%MU_2(:,:)    * hn
        grid%dfi_u(:,:,:)   = grid%dfi_u(:,:,:)   + grid%u_2(:,:,:)   * hn
        grid%dfi_v(:,:,:)   = grid%dfi_v(:,:,:)   + grid%v_2(:,:,:)   * hn
        grid%dfi_w(:,:,:)   = grid%dfi_w(:,:,:)   + grid%w_2(:,:,:)   * hn
@@ -414,17 +429,14 @@ END SUBROUTINE start_domain
       !tgs  After start_domain moist and scalar arrays are fully dimentioned,
       !and initial values should be restored here if grid%dfi_savehydmeteors .EQ. 1:
     IF ( grid%dfi_savehydmeteors .EQ. 1 ) then
-        n_moist = num_moist
 !       print *,'FWD n_moist,PARAM_FIRST_SCALAR,P_QV,P_QC,P_QR,P_QI,P_QS,P_QG', &
 !                n_moist,PARAM_FIRST_SCALAR,P_QV,P_QC,P_QR,P_QI,P_QS,P_QG
 !       print *,'FWD num_scalar,P_QNC,P_QNI,P_QNR,P_QNWFA,P_QNIFA',P_QNC,P_QNI,P_QNR,P_QNWFA,P_QNIFA
+        n_moist = num_moist
          DO nm=PARAM_FIRST_SCALAR+1,n_moist
              grid%moist(:,:,:,nm)=grid%dfi_moist(:,:,:,nm)
          ENDDO
-        n_scalar = num_scalar - 1
-         DO ns=PARAM_FIRST_SCALAR,n_scalar
-             grid%scalar(:,:,:,ns) = grid%dfi_scalar(:,:,:,ns)
-         ENDDO
+        grid%scalar(:,:,:,:) = grid%dfi_scalar(:,:,:,:)
     ENDIF
 
    END SUBROUTINE dfi_fwd_init
@@ -663,7 +675,7 @@ SUBROUTINE dfi_array_reset( grid )
       ! divide by total DFI coefficient
 
 #if (EM_CORE == 1)
-      grid%mu_2(:,:)    = grid%dfi_mu(:,:)      / grid%hcoeff_tot
+      grid%MU_2(:,:)    = grid%dfi_mu(:,:)      / grid%hcoeff_tot
       grid%u_2(:,:,:)   = grid%dfi_u(:,:,:)     / grid%hcoeff_tot
       grid%v_2(:,:,:)   = grid%dfi_v(:,:,:)     / grid%hcoeff_tot
       grid%w_2(:,:,:)   = grid%dfi_w(:,:,:)     / grid%hcoeff_tot
@@ -751,7 +763,6 @@ SUBROUTINE dfi_array_reset( grid )
 !    print *,'In dfi_array_reset - restore initial hydrometeors'
 !      grid%moist(:,:,:,:)      = grid%dfi_moist(:,:,:,:)    !tgs
         n_moist  = num_moist
-        n_scalar = num_scalar-1
       if (grid%dfi_stage .EQ. DFI_BCK) then
 !tgs - backward integration changed only QV
         n_moist        = P_QV
@@ -760,9 +771,7 @@ SUBROUTINE dfi_array_reset( grid )
          DO nm=PARAM_FIRST_SCALAR+1,n_moist
              grid%moist(:,:,:,nm)=grid%dfi_moist(:,:,:,nm)
          ENDDO
-         DO ns=PARAM_FIRST_SCALAR,n_scalar
-             grid%scalar(:,:,:,ns) = grid%dfi_scalar(:,:,:,ns)
-         ENDDO
+        grid%scalar(:,:,:,:)     = grid%dfi_scalar(:,:,:,:)
 
        if(grid%dfi_stage .EQ. DFI_FWD) then
 !tgs change QV to restore initial RH field after the diabatic DFI
@@ -1044,13 +1053,13 @@ SUBROUTINE dfi_save_arrays( grid )
       ! save hydrometeor and scalar fields 
     IF ( grid%dfi_savehydmeteors .EQ. 1 ) then    !tgs
 !    print *,'In dfi_save_arrays - save initial hydrometeors'
-        n_moist = num_moist
 !       print *,'SAVE n_moist,PARAM_FIRST_SCALAR,P_QV,P_QC,P_QR,P_QI,P_QS,P_QG', &
 !                n_moist,PARAM_FIRST_SCALAR,P_QV,P_QC,P_QR,P_QI,P_QS,P_QG
+        n_moist = num_moist
          DO nm=PARAM_FIRST_SCALAR+1,n_moist
              grid%dfi_moist(:,:,:,nm)=max(0.,grid%moist(:,:,:,nm))
          ENDDO
-         grid%dfi_scalar(:,:,:,:) = max(0.,grid%scalar(:,:,:,:))
+        grid%dfi_scalar(:,:,:,:) = max(0.,grid%scalar(:,:,:,:))
     ENDIF
 
        if(grid%dfi_stage .EQ. DFI_BCK) then
@@ -3290,6 +3299,7 @@ SUBROUTINE rebalance_dfi ( grid  &
       REAL :: p_surf ,  pd_surf, p_surf_int , pb_int , ht_hold
       REAL :: qvf , qvf1 , qvf2, qtot
       REAL :: pfu, pfd, phm
+      REAL :: z0, z1, z2, w1, w2
 
       !  Local domain indices and counters.
 
@@ -3300,7 +3310,7 @@ SUBROUTINE rebalance_dfi ( grid  &
                                      ims, ime, jms, jme, kms, kme, &
                                      its, ite, jts, jte, kts, kte, &
                                      ips, ipe, jps, jpe, kps, kpe, &
-                                     i, j, k, ispe, ktf
+                                     i, j, k, kk, ispe, ktf
 
       SELECT CASE ( model_data_order )
          CASE ( DATA_ORDER_ZXY )
@@ -3367,50 +3377,53 @@ SUBROUTINE rebalance_dfi ( grid  &
                !  Integrate the hydrostatic equation (from the RHS of the bigstep vertical momentum
                !  equation) down from the top to get the pressure perturbation.  First get the pressure
                !  perturbation, moisture, and inverse density (total and perturbation) at the top-most level.
-               k = kte-1
+               kk = kte-1
+               k=kk+1
 
                qtot = 0.
                DO ispe=PARAM_FIRST_SCALAR,n_moist
-                 qtot = qtot + 0.5*(moist(i,k,j,ispe)+moist(i,k,j,ispe))
+                 qtot = qtot + 0.5*(moist(i,kk,j,ispe)+moist(i,kk,j,ispe))
                ENDDO
                qvf2 = 1./(1.+qtot)
                qvf1 = qtot*qvf2
 
-               grid%p(i,k,j) = - 0.5*(grid%mu_2(i,j)+qvf1*grid%mub(i,j))/grid%rdnw(k)/qvf2
-               qvf = 1.+rvovrd*moist(i,k,j,P_QV)
-               grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf*         &
-                      (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
-               grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
-               grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
+               grid%p(i,kk,j) = - 0.5*(grid%Mu_2(i,j)+qvf1*grid%Mub(i,j))/grid%rdnw(kk)/qvf2
+               qvf = 1.+rvovrd*moist(i,kk,j,P_QV)
+               grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf*         &
+                      (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
+               grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
+               grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
 
                !  Now, integrate down the column to compute the pressure perturbation, and diagnose the two
                !  inverse density fields (total and perturbation).
 
-           DO k=kte-2,1,-1
+           DO kk=kte-2,1,-1
+               k = kk + 1
                qtot = 0.
                DO ispe=PARAM_FIRST_SCALAR,n_moist
-               qtot = qtot + 0.5*(  moist(i,k  ,j,ispe) + moist(i,k+1,j,ispe) )
+               qtot = qtot + 0.5*(  moist(i,kk  ,j,ispe) + moist(i,kk+1,j,ispe) )
                ENDDO
                qvf2 = 1./(1.+qtot)
                qvf1 = qtot*qvf2
-               grid%p(i,k,j) = grid%p(i,k+1,j) - (grid%mu_2(i,j) +       &
-                               qvf1*grid%mub(i,j))/qvf2/grid%rdn(k+1)
-               qvf = 1. + rvovrd*moist(i,k,j,P_QV)
-               grid%alt(i,k,j) = (r_d/p1000mb)*(grid%t_2(i,k,j)+t0)*qvf* &
-                           (((grid%p(i,k,j)+grid%pb(i,k,j))/p1000mb)**cvpm)
-               grid%al(i,k,j) = grid%alt(i,k,j) - grid%alb(i,k,j)
-               grid%p_hyd(i,k,j) = grid%p(i,k,j) + grid%pb(i,k,j)
+               grid%p(i,kk,j) = grid%p(i,kk+1,j) - (grid%Mu_2(i,j) +       &
+                               qvf1*grid%Mub(i,j))/qvf2/grid%rdn(kk+1)
+               qvf = 1. + rvovrd*moist(i,kk,j,P_QV)
+               grid%alt(i,kk,j) = (r_d/p1000mb)*(grid%t_2(i,kk,j)+t0)*qvf* &
+                           (((grid%p(i,kk,j)+grid%pb(i,kk,j))/p1000mb)**cvpm)
+               grid%al(i,kk,j) = grid%alt(i,kk,j) - grid%alb(i,kk,j)
+               grid%p_hyd(i,kk,j) = grid%p(i,kk,j) + grid%pb(i,kk,j)
            ENDDO
 
                !  This is the hydrostatic equation used in the model after the small timesteps.  In
                !  the model, grid%al (inverse density) is computed from the geopotential.
 
                IF (grid%hypsometric_opt == 1) THEN
-                  DO k  = 2,kte
-                     grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) - &
-                                   grid%dnw(k-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,k-1,j) &
-                                 + grid%mu_2(i,j)*grid%alb(i,k-1,j) )
-                     grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j)
+                  DO kk  = 2,kte
+                     k = kk - 1 
+                     grid%ph_2(i,kk,j) = grid%ph_2(i,kk-1,j) - &
+                                   grid%dnw(kk-1) * ( (grid%mub(i,j)+grid%mu_2(i,j))*grid%al(i,kk-1,j) &
+                                 + grid%mu_2(i,j)*grid%alb(i,kk-1,j) )
+                     grid%ph0(i,kk,j) = grid%ph_2(i,kk,j) + grid%phb(i,kk,j)
                   END DO
                ELSE IF (grid%hypsometric_opt == 2) THEN
                 ! Alternative hydrostatic eq.: dZ = -al*p*dLOG(p), where p is
@@ -3421,9 +3434,15 @@ SUBROUTINE rebalance_dfi ( grid  &
 
                   grid%ph_2(i,1,j) = grid%phb(i,1,j)
                   DO k = 2,kte
+#if  !( HYBRID_COORD==1 )
                      pfu = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k)   + grid%p_top
                      pfd = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znw(k-1) + grid%p_top
                      phm = ( grid%mub(i,j)+grid%mu_2(i,j))*grid%znu(k-1) + grid%p_top
+#elif ( HYBRID_COORD==1 )
+                     pfu = grid%c3f(k  )*(grid%MUB(i,j)+grid%MU_2(i,j)) + grid%c4f(k  ) + grid%p_top
+                     pfd = grid%c3f(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j)) + grid%c4f(k-1) + grid%p_top
+                     phm = grid%c3h(k-1)*(grid%MUB(i,j)+grid%MU_2(i,j)) + grid%c4h(k-1) + grid%p_top
+#endif
                      grid%ph_2(i,k,j) = grid%ph_2(i,k-1,j) + grid%alt(i,k-1,j)*phm*LOG(pfd/pfu)
                   END DO
 
@@ -3431,7 +3450,18 @@ SUBROUTINE rebalance_dfi ( grid  &
                      grid%ph_2(i,k,j) = grid%ph_2(i,k,j) - grid%phb(i,k,j)
                   END DO
 
+                  DO k = 1,kte
+                     grid%ph0(i,k,j) = grid%ph_2(i,k,j) + grid%phb(i,k,j)
+                  END DO
+
                END IF
+! update surface pressure PSFC:
+                  z0 = grid%ph0(i,1,j)/g
+                  z1 = 0.5*(grid%ph0(i,1,j)+grid%ph0(i,2,j))/g
+                  z2 = 0.5*(grid%ph0(i,2,j)+grid%ph0(i,3,j))/g
+                  w1 = (z0 - z2)/(z1 - z2)
+                  w2 = 1. - w1
+                  grid%psfc(i,j) = w1*(grid%p(i,1,j)+grid%pb(i,1,j))+w2*(grid%p(i,2,j)+grid%pb(i,2,j))
 
          ENDDO  !i
         ENDDO  !j
diff --git a/wrfv2_fire/share/input_wrf.F b/wrfv2_fire/share/input_wrf.F
index e4ad69ae..84441ffa 100644
--- a/wrfv2_fire/share/input_wrf.F
+++ b/wrfv2_fire/share/input_wrf.F
@@ -97,6 +97,11 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
 
     CHARACTER (LEN=256) :: a_message
 
+    !  Bundle up the fatal errors in one piece at the end of the file.
+
+    INTEGER :: count_fatal_error
+
+
 
 !
 !
@@ -112,7 +117,11 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
 
     CALL modify_io_masks ( grid%id )   ! this adjusts the I/O masks according to the users run-time specs, if any
 
+    !  Initializations for error checking
+
     ierr = 0
+    count_fatal_error = 0
+
 
     CALL get_ijk_from_grid (  grid ,                        &
                               ids, ide, jds, jde, kds, kde,    &
@@ -122,8 +131,9 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
 ! If this was not a training read (dry run) check for erroneous values.
     CALL wrf_inquire_filename ( fid , fname , filestate , ierr )
     IF ( ierr /= 0 ) THEN
-      WRITE(wrf_err_message,*)'module_io_wrf: input_wrf: wrf_inquire_filename Status = ',ierr
-      CALL wrf_error_fatal( wrf_err_message )
+      WRITE(wrf_err_message,*)'---- ERROR: module_io_wrf: input_wrf: wrf_inquire_filename Status = ',ierr
+      CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+      count_fatal_error = count_fatal_error + 1
     ENDIF
 
     WRITE(wrf_err_message,*)'input_wrf: filestate = ',filestate
@@ -339,7 +349,10 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
        ierr = max( ierr, ierr3 )
        CALL wrf_get_dom_ti_integer ( fid , 'BOTTOM-TOP_GRID_DIMENSION' ,   kde_compare , 1 , icnt , ierr3 )
        ierr = max( ierr, ierr3 )
-       IF ( ierr3 .NE. 0 ) CALL wrf_error_fatal( 'wrf_get_dom_ti_integer getting dimension information from dataset' )
+       IF ( ierr3 .NE. 0 ) THEN
+          CALL wrf_debug ( 0, '---- ERROR: wrf_get_dom_ti_integer getting dimension information from dataset' )
+          count_fatal_error = count_fatal_error + 1
+       END IF
 
 #if (EM_CORE == 1)
 
@@ -358,7 +371,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
              CALL wrf_message(wrf_err_message)
              WRITE(wrf_err_message,*)'dx and dy from namelist ',config_flags%dx,config_flags%dy
              CALL wrf_message(wrf_err_message)
-             CALL wrf_error_fatal( 'DX and DY do not match comparing namelist to the input file' )
+             CALL wrf_debug ( 0, '---- ERROR: DX and DY do not match comparing namelist to the input file' )
+             count_fatal_error = count_fatal_error + 1
           END IF
        END IF
 #endif
@@ -401,7 +415,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
           CALL wrf_message(wrf_err_message)
        END IF
        IF ( ierr .NE. 0 ) THEN
-          CALL wrf_error_fatal( 'Nest start locations do not match: namelist.input vs gridded input file' )
+          CALL wrf_debug ( 0, '---- ERROR: Nest start locations do not match: namelist.input vs gridded input file' )
+          count_fatal_error = count_fatal_error + 1
        END IF
     END IF
 #endif
@@ -564,7 +579,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
         call wrf_message(wrf_err_message)
         WRITE(wrf_err_message,'("input files : NUM_LAND_CAT = ",I10, " (from geogrid selections).")') num_land_cat_compare
         call wrf_message(wrf_err_message)
-        call wrf_error_fatal("Mismatch between namelist and wrf input files for dimension NUM_LAND_CAT")
+        CALL wrf_debug ( 0, '---- ERROR: Mismatch between namelist and wrf input files for dimension NUM_LAND_CAT')
+        count_fatal_error = count_fatal_error + 1
       endif
     ENDIF
 
@@ -580,7 +596,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
 
 #if (EM_CORE == 1)
           IF ( itmp .EQ. 1 ) THEN
-             call wrf_error_fatal("NUM_METGRID_SOIL_LEVELS must be greater than 1")
+             CALL wrf_debug ( 0, "---- ERROR: NUM_METGRID_SOIL_LEVELS must be greater than 1")
+             count_fatal_error = count_fatal_error + 1
           END IF
 #endif
           WRITE(wrf_err_message,*)'input_wrf: global attribute NUM_METGRID_SOIL_LEVELS returns ', itmp
@@ -595,7 +612,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
              WRITE(wrf_err_message,'("input files : NUM_METGRID_SOIL_LEVELS = ",I10, " (from met_nmm files).")') itmp
 #endif
              call wrf_message(wrf_err_message)
-             call wrf_error_fatal("Mismatch between namelist and global attribute NUM_METGRID_SOIL_LEVELS")
+             CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute NUM_METGRID_SOIL_LEVELS")
+             count_fatal_error = count_fatal_error + 1
           END IF
        END IF
     END IF
@@ -615,12 +633,14 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
           call wrf_message(wrf_err_message)
           WRITE(wrf_err_message,'("input files : EROSION_DIM = ",I10, " (from met_em files).")') itmp
           call wrf_message(wrf_err_message)
-          call wrf_error_fatal("Mismatch between namelist and global attribute EROSION_DIM")
+          CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute EROSION_DIM")
+          count_fatal_error = count_fatal_error + 1
        END IF
     END IF
 #endif
 #endif
 
+#if ( DA_CORE != 1 )
     ! Test here to check that config_flags%sf_surface_physics in namelist
     ! is equal to what is in the global attributes of the wrfinput files
 
@@ -640,13 +660,79 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
                 call wrf_message(wrf_err_message)
                 WRITE(wrf_err_message,'("input files : SF_SURFACE_PHYSICS = ",I10, " (from wrfinput files).")') itmp
                 call wrf_message(wrf_err_message)
-                call wrf_error_fatal("Mismatch between namelist and global attribute SF_SURFACE_PHYSICS")
+                CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute SF_SURFACE_PHYSICS")
+                count_fatal_error = count_fatal_error + 1
              END IF
           END IF
        END IF
     END IF
 
 
+    ! Test here to check that config_flags%gwd_opt in namelist
+    ! is equal to what is in the global attributes of the wrfinput files
+
+    IF ( switch .EQ. input_only  ) THEN
+       CALL wrf_get_dom_ti_integer ( fid, 'GWD_OPT', itmp, 1, icnt, ierr )
+       IF ( ierr .EQ. 0 ) THEN
+          WRITE(wrf_err_message,*)'input_wrf: global attribute GWD_OPT returns ', itmp
+          CALL wrf_debug ( 300 , wrf_err_message )
+          IF ( config_flags%gwd_opt /= itmp ) THEN
+             call wrf_message("----------------- ERROR -------------------")
+             WRITE(wrf_err_message,'("namelist    : gwd_opt            = ",I10)') config_flags%gwd_opt
+             call wrf_message(wrf_err_message)
+             WRITE(wrf_err_message,'("input files : GWD_OPT            = ",I10, " (from wrfinput files).")') itmp
+             call wrf_message(wrf_err_message)
+             call wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute GWD_OPT")
+             count_fatal_error = count_fatal_error + 1
+          END IF
+       END IF
+    END IF
+#endif
+
+#if ( ( EM_CORE == 1 ) && ( DA_CORE != 1 ) )
+    ! Test here to check that config_flags%sf_ocean_physics in namelist
+    ! is equal to what is in the global attributes of the wrfinput files
+
+    IF ( switch .EQ. input_only  ) THEN
+       CALL wrf_get_dom_ti_integer ( fid, 'SF_OCEAN_PHYSICS', itmp, 1, icnt, ierr )
+       IF ( ierr .EQ. 0 ) THEN
+          WRITE(wrf_err_message,*)'input_wrf: global attribute SF_OCEAN_PHYSICS returns ', itmp
+          CALL wrf_debug ( 300 , wrf_err_message )
+          IF ( config_flags%sf_ocean_physics /= itmp ) THEN
+             call wrf_message("----------------- ERROR -------------------")
+             WRITE(wrf_err_message,'("namelist    : sf_ocean_physics   = ",I10)') config_flags%sf_ocean_physics
+             call wrf_message(wrf_err_message)
+             WRITE(wrf_err_message,'("input files : SF_OCEAN_PHYSICS   = ",I10, " (from wrfinput files).")') itmp
+             call wrf_message(wrf_err_message)
+             call wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute SF_OCEAN_PHYSICS")
+             count_fatal_error = count_fatal_error + 1
+          END IF
+       END IF
+    END IF
+#endif
+
+#if ( DA_CORE != 1 )
+    ! Test here to check that config_flags%sf_urban_physics in namelist
+    ! is equal to what is in the global attributes of the wrfinput files
+
+    IF ( switch .EQ. input_only  ) THEN
+       CALL wrf_get_dom_ti_integer ( fid, 'SF_URBAN_PHYSICS', itmp, 1, icnt, ierr )
+       IF ( ierr .EQ. 0 ) THEN
+          WRITE(wrf_err_message,*)'input_wrf: global attribute SF_URBAN_PHYSICS returns ', itmp
+          CALL wrf_debug ( 300 , wrf_err_message )
+          IF ( config_flags%sf_urban_physics /= itmp ) THEN
+             call wrf_message("----------------- ERROR -------------------")
+             WRITE(wrf_err_message,'("namelist    : sf_urban_physics   = ",I10)') config_flags%sf_urban_physics
+             call wrf_message(wrf_err_message)
+             WRITE(wrf_err_message,'("input files : SF_URBAN_PHYSICS   = ",I10, " (from wrfinput files).")') itmp
+             call wrf_message(wrf_err_message)
+             call wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute SF_URBAN_PHYSICS")
+             count_fatal_error = count_fatal_error + 1
+          END IF
+       END IF
+    END IF
+#endif
+
     CALL wrf_get_dom_ti_integer ( fid , 'ISWATER' ,  config_flags%iswater , 1 , icnt , ierr )
     WRITE(wrf_err_message,*)'input_wrf: wrf_get_dom_ti_integer for ISWATER returns ',config_flags%iswater
     CALL wrf_debug ( 300 , wrf_err_message )
@@ -742,9 +828,12 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
        IF ( ( ide .NE. ide_compare    ) .OR. &
             ( kde .NE. kde_compare    ) .OR. &
             ( jde .NE. jde_compare    ) ) THEN
-          WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH:  namelist ide,jde,kde=',ide,jde,kde,&
-                                  '; input data ide,jde,kde=',ide_compare , jde_compare , kde_compare
-          CALL wrf_error_fatal( wrf_err_message )
+          WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH:  namelist   ide,jde,kde=',ide,jde,kde
+          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+          WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH:  input file ide,jde,kde=',ide_compare , jde_compare , kde_compare
+          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+          CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and input file dimensions" )
+          count_fatal_error = count_fatal_error + 1
        ENDIF
 
     ELSE IF ( switch .EQ. auxinput1_only ) THEN
@@ -754,10 +843,12 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
        IF ( ( ide                             .NE. ide_compare ) .OR. &
             ( config_flags%num_metgrid_levels .NE. kde_compare ) .OR. &
             ( jde                             .NE. jde_compare ) ) THEN
-         WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH:  ',&
-                                 'namelist ide,jde,num_metgrid_levels=',ide,jde,config_flags%num_metgrid_levels,&
-                                 '; input data ide,jde,num_metgrid_levels=',ide_compare , jde_compare , kde_compare
-         CALL wrf_error_fatal( wrf_err_message )
+          WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH:  namelist   ide,jde,num_metgrid_levels=',ide,jde,config_flags%num_metgrid_levels
+          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+          WRITE(wrf_err_message,*)'input_wrf.F: SIZE MISMATCH:  input file ide,jde,kde               =',ide_compare , jde_compare , kde_compare
+          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+          CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and input file dimensions" )
+          count_fatal_error = count_fatal_error + 1
        ENDIF
     ENDIF
 
@@ -789,10 +880,12 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
                  '; input data ide,jde,num_metgrid_levels=',ide_compare , jde_compare , kde_compare
                 IF (ide-1 .eq. ide_compare .AND. jde-1 .EQ. jde_compare) THEN
                   CALL wrf_message(wrf_err_message)
-                  CALL wrf_error_fatal( "appears that the vertical dimension is wrong - quitting" )
+                  CALL wrf_debug ( 0, "---- ERROR: appears that the vertical dimension is wrong - quitting" )
+                  count_fatal_error = count_fatal_error + 1
                 ELSE
                   CALL wrf_message(wrf_err_message)
-                  CALL wrf_error_fatal( "appears that I or J dimensions are wrong - quitting" )
+                  CALL wrf_debug ( 0, "---- ERROR: appears that I or J dimensions are wrong - quitting" )
+                  count_fatal_error = count_fatal_error + 1
                 ENDIF
          ENDIF
        ENDIF
@@ -814,7 +907,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
              call wrf_message(wrf_err_message)
              WRITE(wrf_err_message,'("input files : HYPSOMETRIC_OPT = ",I10, " (from wrfinput files).")') itmp
              call wrf_message(wrf_err_message)
-             call wrf_error_fatal("Mismatch between namelist and global attribute HYPSOMETRIC_OPT")
+             CALL wrf_debug ( 0, "---- ERROR: Mismatch between namelist and global attribute HYPSOMETRIC_OPT")
+             count_fatal_error = count_fatal_error + 1
           END IF
        ELSE
           ! For WRFDA backward compatibility.  If hypsometric_opt is not defined in the fg file, it is
@@ -906,12 +1000,14 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
     IF ( ierr .NE. 0 .AND. ierr .NE. WRF_WARN_NOTSUPPORTED .AND. ierr .NE. WRF_WARN_DRYRUN_READ ) THEN
       CALL wrf_message ( TRIM(wrf_err_message ) )
       IF ( switch .EQ. boundary_only ) THEN
-        WRITE(wrf_err_message,*) ' ... May have run out of valid boundary conditions in file ',TRIM(fname)
-        CALL wrf_error_fatal( TRIM(wrf_err_message) )
+        WRITE(wrf_err_message,*) '---- ERROR: Ran out of valid boundary conditions in file ',TRIM(fname)
+        CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+        count_fatal_error = count_fatal_error + 1
       ELSE
 #if ( NMM_CORE != 1 )
-        WRITE(wrf_err_message,*) '... Could not find matching time in input file ',TRIM(fname)
-        CALL wrf_error_fatal( TRIM(wrf_err_message) )
+        WRITE(wrf_err_message,*) '---- ERROR: Could not find matching time in input file ',TRIM(fname)
+        CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+        count_fatal_error = count_fatal_error + 1
 #endif
       ENDIF
     ELSE IF ( ierr .NE. WRF_WARN_NOTSUPPORTED .AND. ierr .NE. WRF_WARN_DRYRUN_READ) THEN
@@ -996,7 +1092,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
               DO WHILE ( ( currentTime .GE. grid%next_bdy_time ) .AND. ( icount < 10000 ) ) 
                   CALL wrf_get_next_time(fid, current_date , ierr)
                   IF ( ierr .NE. 0 ) THEN
-                     CALL wrf_error_fatal ( 'Cannot find a valid time to start the LBC during this restart, likely ran out of time periods to test' )
+                     CALL wrf_debug ( 0, '---- ERROR: Cannot find a valid time to start the LBC during this restart, likely ran out of time periods to test' )
+                     count_fatal_error = count_fatal_error + 1
                   END IF
                   CALL wrf_get_dom_td_char ( fid , 'THISBDYTIME' ,  current_date(1:19), this_datestr , ierr )
                   CALL wrf_get_dom_td_char ( fid , 'NEXTBDYTIME' ,  current_date(1:19), next_datestr , ierr )
@@ -1021,7 +1118,8 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
                      CALL wrf_debug ( 0 , TRIM(wrf_err_message ) )
                      CALL wrf_debug ( 0 , 'LBC is now correctly positioned for requested restart time' )
                   ELSE
-                     CALL wrf_error_fatal ( 'Problems backing up in the LBC file to find startig location for restart' )
+                     CALL wrf_debug ( 0, '---- ERROR: Problems backing up in the LBC file to find starting location for restart' )
+                     count_fatal_error = count_fatal_error + 1
                   END IF
               END IF
           END IF
@@ -1061,6 +1159,15 @@ SUBROUTINE input_wrf ( fid , grid , config_flags , switch , ierr )
     n_ref_m = 0
 #endif
 
+    !  This test should go after all of the metadata is input, and before the gridded input is ingested.
+     
+    IF ( count_fatal_error .GT. 0 ) THEN
+       WRITE (wrf_err_message, FMT='(A,I6, A)') 'NOTE:  ', count_fatal_error, ' namelist vs input data inconsistencies found.'
+       CALL wrf_message ( wrf_err_message )
+       WRITE (wrf_err_message, FMT='(A,I6, A)') 'NOTE:  Please check and reset these options'
+       CALL wrf_error_fatal ( wrf_err_message )
+    END IF
+
     IF ( (first_input   .LE. switch .AND. switch .LE. last_input) .OR. &
          (first_history .LE. switch .AND. switch .LE. last_history) .OR. &
          switch .EQ. restart_only    ) THEN
diff --git a/wrfv2_fire/share/interp_fcn.F b/wrfv2_fire/share/interp_fcn.F
index ac9a0d33..0a0f4c94 100644
--- a/wrfv2_fire/share/interp_fcn.F
+++ b/wrfv2_fire/share/interp_fcn.F
@@ -281,6 +281,226 @@ END SUBROUTINE interp_fcn_blint
 
 !=========================================================================
 
+! Overlapping linear horizontal iterpolation for longitude
+
+   SUBROUTINE interp_fcn_blint_ll    ( cfld_inp,                                 &  ! CD field
+                              cids, cide, ckds, ckde, cjds, cjde,   &
+                              cims, cime, ckms, ckme, cjms, cjme,   &
+                              cits, cite, ckts, ckte, cjts, cjte,   &
+                              nfld,                                 &  ! ND field
+                              nids, nide, nkds, nkde, njds, njde,   &
+                              nims, nime, nkms, nkme, njms, njme,   &
+                              nits, nite, nkts, nkte, njts, njte,   &
+                              shw,                                  &  ! stencil half width for interp
+                              imask,                                &  ! interpolation mask
+                              xstag, ystag,                         &  ! staggering of field
+                              ipos, jpos,                           &  ! Position of lower left of nest in CD
+                              nri, nrj,                             &  ! Nest ratio, i- and j-directions
+                              clat_in, nlat_in,                     & ! CG, FG latitude
+                              cinput_from_file, ninput_from_file )    ! CG, FG T/F input from file
+
+     IMPLICIT NONE
+
+     INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
+                            cims, cime, ckms, ckme, cjms, cjme,   &
+                            cits, cite, ckts, ckte, cjts, cjte,   &
+                            nids, nide, nkds, nkde, njds, njde,   &
+                            nims, nime, nkms, nkme, njms, njme,   &
+                            nits, nite, nkts, nkte, njts, njte,   &
+                            shw,                                  &
+                            ipos, jpos,                           &
+                            nri, nrj
+     LOGICAL, INTENT(IN) :: xstag, ystag
+
+     REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld_inp, cfld
+     REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
+     REAL, DIMENSION ( cims:cime,            cjms:cjme ) :: clat_in
+     REAL, DIMENSION ( nims:nime,            njms:njme ) :: nlat_in
+     INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
+     LOGICAL :: cinput_from_file, ninput_from_file
+
+     ! Local
+
+     INTEGER ci, cj, ck, ni, nj, nk, istag, jstag, ioff, joff, i, j, k
+     REAL :: wx, wy, cfld_ll, cfld_lr, cfld_ul, cfld_ur
+     REAL :: cxp0, cxp1, nx, cyp0, cyp1, ny
+     LOGICAL :: probably_by_dateline
+     REAL :: max_lon, min_lon
+     LOGICAL :: probably_by_pole
+     REAL :: max_lat, min_lat
+
+     !  Fortran functions.  Yes, yes, I know, probably pretty slow.
+
+     REAL, EXTERNAL :: nest_loc_of_cg
+     INTEGER, EXTERNAL :: compute_CGLL
+
+     !  This stag stuff is to keep us away from the outer most row
+     !  and column for the unstaggered directions.  We are going to 
+     !  consider "U" an xstag variable and "V" a ystag variable.  The
+     !  vertical staggering is handled in the actual arguments.  The
+     !  ckte and nkte are the ending vertical dimensions for computations
+     !  for this particular variable.
+
+     IF ( xstag ) THEN
+        istag = 0 
+        ioff  = 1
+     ELSE
+        istag = 1
+        ioff  = 0
+     END IF
+
+     IF ( ystag ) THEN
+        jstag = 0 
+        joff  = 1
+     ELSE
+        jstag = 1
+        joff  = 0
+     END IF
+
+     !  If this is a projection where the nest is over the pole, and
+     !  we are using the parent to interpolate the longitudes, then 
+     !  we are going to have longitude troubles.  If this is the case,
+     !  stop the model right away.
+
+     probably_by_pole = .FALSE.
+     max_lat = -90
+     min_lat = +90
+     DO nj = njts, MIN(njde-jstag,njte)
+        DO ni = nits, MIN(nide-istag,nite)
+           max_lat = MAX ( nlat_in(ni,nj) , max_lat )       
+           min_lat = MIN ( nlat_in(ni,nj) , min_lat )       
+        END DO
+     END DO
+
+     IF ( ( max_lat .GT. 85 ) .OR. ( ABS(min_lat) .GT. 85 ) ) THEN
+        probably_by_pole = .TRUE.
+     END IF
+
+     IF ( ( probably_by_pole ) .AND. ( .NOT. ninput_from_file ) ) THEN
+        CALL wrf_error_fatal ( 'Nest over the pole, single input domain, longitudes will be wrong' )
+     END IF
+
+     !  Initialize to NOT being by dateline.
+
+     probably_by_dateline = .FALSE.
+     max_lon = -180
+     min_lon = +180
+     DO nj = njts, MIN(njde-jstag,njte)
+        cj = compute_CGLL ( nj , jpos , nrj , jstag )
+        DO ni = nits, MIN(nide-istag,nite)
+           ci = compute_CGLL ( ni , ipos , nri , istag )
+           max_lon = MAX ( cfld_inp(ci,1,cj) , max_lon )       
+           min_lon = MIN ( cfld_inp(ci,1,cj) , min_lon )       
+        END DO
+     END DO
+
+     IF ( max_lon - min_lon .GT. 300 ) THEN
+        probably_by_dateline = .TRUE.
+     END IF
+
+     !  Load "continuous" longitude across the date line
+
+     DO cj = MIN(cjts-1,cjms), MAX(cjte+1,cjme)
+       DO ci = MIN(cits-1,cims), MAX(cite+1,cime)
+         IF ( ( cfld_inp(ci,ckts,cj) .LT. 0 ) .AND. ( probably_by_dateline ) ) THEN
+           cfld(ci,ckts,cj) = 360 + cfld_inp(ci,ckts,cj)
+         ELSE
+           cfld(ci,ckts,cj) =       cfld_inp(ci,ckts,cj)
+         END IF
+       END DO
+     END DO
+
+     !  Loop over each j-index on this tile for the nested domain.
+
+     j_loop : DO nj = njts, MIN(njde-jstag,njte)
+
+        !  This is the lower-left j-index of the CG.
+
+        !  Example is 3:1 ratio, mass-point staggering.  We have listed six CG values
+        !  as an example: A, B, C, D, E, F.  For a 3:1 ratio, each of these CG cells has
+        !  nine associated FG points.
+        !  |=========|=========|=========|
+        !  | -  -  - | -  -  - | -  -  - |
+        !  |         |         |         |
+        !  | -  D  - | -  E  - | -  F  - |
+        !  |         |         |         |
+        !  | 1  2  3 | 4  5  6 | 7  8  9 |
+        !  |=========|=========|=========|
+        !  | -  -  - | -  -  - | -  -  - |
+        !  |         |         |         |
+        !  | -  A  - | -  B  - | -  C  - |
+        !  |         |         |         |
+        !  | -  -  - | -  -  - | -  -  - |
+        !  |=========|=========|=========|
+        !  To interpolate to FG point 4, we will use CG points: A, B, D, E.  It is adequate to
+        !  find the lower left point.  The lower left (LL) point for "4" is "A".  Below
+        !  are a few more points.
+        !  2 => A
+        !  3 => A
+        !  4 => A
+        !  5 => B
+        !  6 => B
+        !  7 => B
+
+        cj = compute_CGLL ( nj , jpos , nrj , jstag )
+        ny = REAL(nj)
+        cyp0 = nest_loc_of_cg ( cj   , jpos , nrj , joff ) 
+        cyp1 = nest_loc_of_cg ( cj+1 , jpos , nrj , joff ) 
+
+        !  What is the weighting for this CG point to the FG point, j-weight only.
+
+        wy = ( cyp1 - ny ) / ( cyp1 - cyp0 )
+
+        !  Vertical dim of the nest domain.
+
+        k_loop : DO nk = nkts, nkte
+
+          !  Loop over each i-index on this tile for the nested domain.
+
+           i_loop : DO ni = nits, MIN(nide-istag,nite)
+
+              IF ( imask ( ni, nj ) .EQ. 1 ) THEN
+ 
+                 !  The coarse grid location that is to the lower left of the FG point.
+   
+                 ci = compute_CGLL ( ni , ipos , nri , istag )
+                 nx = REAL(ni)
+                 cxp0 = nest_loc_of_cg ( ci   , ipos , nri , ioff ) 
+                 cxp1 = nest_loc_of_cg ( ci+1 , ipos , nri , ioff ) 
+   
+                 wx = ( cxp1 - nx ) / ( cxp1 - cxp0 )
+   
+                 !  The four surrounding CG values.
+   
+                 cfld_ll = cfld(ci  ,nk,cj  )
+                 cfld_lr = cfld(ci+1,nk,cj  )
+                 cfld_ul = cfld(ci  ,nk,cj+1)
+                 cfld_ur = cfld(ci+1,nk,cj+1)
+
+                 !  Bilinear interpolation in horizontal.
+
+                 nfld( ni , nk , nj ) =     wy  * ( cfld_ll * wx + cfld_lr * (1.-wx) ) + &
+                                        (1.-wy) * ( cfld_ul * wx + cfld_ur * (1.-wx) )
+
+              END IF
+           END DO i_loop
+        END DO    k_loop
+     END DO       j_loop
+
+     !  Put nested longitude back into the -180 to 180 range.
+
+     DO nj = njts, MIN(njde-jstag,njte)
+        DO ni = nits, MIN(nide-istag,nite)
+           IF ( nfld(ni,nkts,nj) .GT. 180 ) THEN
+              nfld(ni,nkts,nj) = -360 + nfld(ni,nkts,nj)
+           END IF
+        END DO
+    END DO
+
+   END SUBROUTINE interp_fcn_blint_ll
+
+!=========================================================================
+
 ! Lagrange interpolating polynomials, set up as a quadratic, with an average of
 ! the overlap.
 
@@ -531,7 +751,8 @@ SUBROUTINE interp_fcn_lagr ( cfld,                                 &  ! CD field
 
                  !  Value at "*"
 
-                 nfld(ni,nk,nj) = lagrange_quad_avg ( ny, cym1, cyp0, cyp1, cyp2, nfld_m1, nfld_p0, nfld_p1, nfld_p2 )
+                 nfld(ni,nk,nj) = lagrange_quad_avg ( ny, cym1, cyp0, cyp1,    &
+                                                      cyp2, nfld_m1, nfld_p0, nfld_p1, nfld_p2 )
 
               END IF
 
@@ -1167,9 +1388,6 @@ FUNCTION v_interp_col ( cfld_orig , cprs_orig , ckms , ckme , ckte , nprs, ni, n
          END IF
       END DO
 
-print *,'Hey we should not be here'
-print *,'nest pres to find = ',nprs
-print *,'column of cg pres = ',cprs
       CALL wrf_error_fatal ( 'ERROR -- vertical interpolation for nest interp cannot find trapping pressures' )
    
    END FUNCTION v_interp_col
@@ -5799,5 +6017,350 @@ SUBROUTINE interp_mask_soil ( enable,                  &  ! says whether to allo
       deallocate (icount_land)
 
    END SUBROUTINE interp_mask_soil
+ 
+!=========================================================================
+
+! Lagrange interpolating polynomials, set up as a quadratic, with an average of
+! the overlap.  Specifically for longitude near the date line.
+
+   SUBROUTINE interp_fcn_lagr_ll ( cfld_inp,                          &  ! CD field
+                                cids, cide, ckds, ckde, cjds, cjde,   &
+                                cims, cime, ckms, ckme, cjms, cjme,   &
+                                cits, cite, ckts, ckte, cjts, cjte,   &
+                                nfld,                                 &  ! ND field
+                                nids, nide, nkds, nkde, njds, njde,   &
+                                nims, nime, nkms, nkme, njms, njme,   &
+                                nits, nite, nkts, nkte, njts, njte,   &
+                                shw,                                  &  !  stencil half width for interp
+                                imask,                                &  !  interpolation mask
+                                xstag, ystag,                         &  !  staggering of field
+                                ipos, jpos,                           &  !  Position of lower left of nest in CD
+                                nri, nrj,                             & ! Nest ratio, i- and j-directions
+                                clat_in, nlat_in,                     & ! CG, FG latitude
+                                cinput_from_file, ninput_from_file )    ! CG, FG T/F input from file
+
+     IMPLICIT NONE
+
+     INTEGER, INTENT(IN) :: cids, cide, ckds, ckde, cjds, cjde,   &
+                            cims, cime, ckms, ckme, cjms, cjme,   &
+                            cits, cite, ckts, ckte, cjts, cjte,   &
+                            nids, nide, nkds, nkde, njds, njde,   &
+                            nims, nime, nkms, nkme, njms, njme,   &
+                            nits, nite, nkts, nkte, njts, njte,   &
+                            shw,                                  &
+                            ipos, jpos,                           &
+                            nri, nrj
+     LOGICAL, INTENT(IN) :: xstag, ystag
+
+     REAL, DIMENSION ( cims:cime, ckms:ckme, cjms:cjme ) :: cfld_inp, cfld
+     REAL, DIMENSION ( nims:nime, nkms:nkme, njms:njme ) :: nfld
+     REAL, DIMENSION ( cims:cime,            cjms:cjme ) :: clat_in
+     REAL, DIMENSION ( nims:nime,            njms:njme ) :: nlat_in
+     INTEGER, DIMENSION ( nims:nime, njms:njme ) :: imask
+     LOGICAL :: cinput_from_file, ninput_from_file
+
+     ! Local
+
+     INTEGER ci, cj, ck, ni, nj, nk, istag, jstag, i, j, k
+     REAL :: nx, x0, x1, x2, x3, x
+     REAL :: ny, y0, y1, y2, y3
+     REAL :: cxm1, cxp0, cxp1, cxp2, nfld_m1, nfld_p0, nfld_p1, nfld_p2
+     REAL :: cym1, cyp0, cyp1, cyp2
+     INTEGER :: ioff, joff
+     LOGICAL :: probably_by_dateline
+     REAL :: max_lon, min_lon
+     LOGICAL :: probably_by_pole
+     REAL :: max_lat, min_lat
+
+     !  Fortran functions.
+
+     REAL, EXTERNAL :: lagrange_quad_avg
+     REAL, EXTERNAL :: nest_loc_of_cg
+     INTEGER, EXTERNAL :: compute_CGLL
+
+     !  This stag stuff is to keep us away from the outer most row
+     !  and column for the unstaggered directions.  We are going to 
+     !  consider "U" an xstag variable and "V" a ystag variable.  The
+     !  vertical staggering is handled in the actual arguments.  The
+     !  ckte and nkte are the ending vertical dimensions for computations
+     !  for this particular variable.
+
+     !  The ioff and joff are offsets due to the staggering.  It is a lot
+     !  simpler with ioff and joff if 
+     !  u var => ioff=1
+     !  v var => joff=1
+     !  otherwise zero.
+     !  Note that is OPPOSITE of the istag, jstag vars.  The stag variables are
+     !  used for the domain dimensions, the offset guys are used in the 
+     !  determination of grid points between the CG and FG
+
+     IF ( xstag ) THEN
+        istag = 0 
+        ioff  = 1
+     ELSE
+        istag = 1
+        ioff  = 0
+     END IF
+
+     IF ( ystag ) THEN
+        jstag = 0 
+        joff  = 1
+     ELSE
+        jstag = 1
+        joff  = 0
+     END IF
+
+     !  If this is a projection where the nest is over the pole, and
+     !  we are using the parent to interpolate the longitudes, then 
+     !  we are going to have longitude troubles.  If this is the case,
+     !  stop the model right away.
+
+     probably_by_pole = .FALSE.
+     max_lat = -90
+     min_lat = +90
+     DO nj = njts, MIN(njde-jstag,njte)
+        DO ni = nits, MIN(nide-istag,nite)
+           max_lat = MAX ( nlat_in(ni,nj) , max_lat )       
+           min_lat = MIN ( nlat_in(ni,nj) , min_lat )       
+        END DO
+     END DO
+
+     IF ( ( max_lat .GT. 85 ) .OR. ( ABS(min_lat) .GT. 85 ) ) THEN
+        probably_by_pole = .TRUE.
+     END IF
+
+     IF ( ( probably_by_pole ) .AND. ( .NOT. ninput_from_file ) ) THEN
+        CALL wrf_error_fatal ( 'Nest over the pole, single input domain, longitudes will be wrong' )
+     END IF
+
+     !  Initialize to NOT being by dateline.
+
+     probably_by_dateline = .FALSE.
+     max_lon = -180
+     min_lon = +180
+     DO nj = njts, MIN(njde-jstag,njte)
+        cj = compute_CGLL ( nj , jpos , nrj , jstag )
+        DO ni = nits, MIN(nide-istag,nite)
+           ci = compute_CGLL ( ni , ipos , nri , istag )
+           max_lon = MAX ( cfld_inp(ci,1,cj) , max_lon )       
+           min_lon = MIN ( cfld_inp(ci,1,cj) , min_lon )       
+        END DO
+     END DO
+
+     IF ( max_lon - min_lon .GT. 300 ) THEN
+        probably_by_dateline = .TRUE.
+     END IF
+
+     !  Load "continuous" longitude across the date line
+
+     DO cj = MIN(cjts-1,cjms), MAX(cjte+1,cjme)
+       DO ci = MIN(cits-1,cims), MAX(cite+1,cime)
+         IF ( ( cfld_inp(ci,ckts,cj) .LT. 0 ) .AND. ( probably_by_dateline ) ) THEN
+           cfld(ci,ckts,cj) = 360 + cfld_inp(ci,ckts,cj)
+         ELSE
+           cfld(ci,ckts,cj) =       cfld_inp(ci,ckts,cj)
+         END IF
+       END DO
+     END DO
+
+     !  Loop over each j-index on this tile for the nested domain.
+
+     j_loop : DO nj = njts, MIN(njde-jstag,njte)
+
+        !  This is the lower-left j-index of the CG.
+
+        !  Example is 3:1 ratio, mass-point staggering.  We have listed sixteen CG values
+        !  as an example: A through P.  For a 3:1 ratio, each of these CG cells has
+        !  nine associated FG points.
+
+        !  |=========|=========|=========|=========|
+        !  | -  -  - | -  -  - | -  -  - | -  -  - |
+        !  |         |         |         |         |
+        !  | -  M  - | -  N  d | -  O  - | -  P  - |
+        !  |         |         |         |         |
+        !  | -  -  - | -  -  - | -  -  - | -  -  - |
+        !  |=========|=========|=========|=========|
+        !  | -  -  - | -  -  - | -  -  - | -  -  - |
+        !  |         |         |         |         |
+        !  | -  I  - | -  J  c | -  K  - | -  L  - |
+        !  |         |         |         |         |
+        !  | -  -  - | -  -  - | -  -  - | -  -  - |
+        !  |=========|=========|=========|=========|
+        !  | -  1  2 | 3  4  5 | 6  7  8 | -  -  - |
+        !  |         |         |         |         |
+        !  | -  E  - | -  F  b | -  G  - | -  H  - |
+        !  |         |         |         |         |
+        !  | -  -  - | -  -  - | -  -  - | -  -  - |
+        !  |=========|=========|=========|=========|
+        !  | -  -  - | -  -  - | -  -  - | -  -  - |
+        !  |         |         |         |         |
+        !  | -  A  - | -  B  a | -  C  - | -  D  - |
+        !  |         |         |         |         |
+        !  | -  -  - | -  -  - | -  -  - | -  -  - |
+        !  |=========|=========|=========|=========|
+
+        !  To interpolate to FG point 4, 5, or 6 we will use CG points: A through P.  It is
+        !  sufficient to find the lower left corner of a 4-point interpolation, and then extend 
+        !  each side by one unit.
+
+        !  Here are the lower left hand corners of the following FG points:
+        !  1 => E
+        !  2 => E
+        !  3 => E
+        !  4 => F
+        !  5 => F
+        !  6 => F
+        !  7 => G
+        !  8 => G
+
+        cj = compute_CGLL ( nj , jpos , nrj , jstag )
+
+        !  Vertical dim of the nest domain.
+
+        k_loop : DO nk = nkts, nkte
+
+          !  Loop over each i-index on this tile for the nested domain.
+
+           i_loop : DO ni = nits, MIN(nide-istag,nite)
+ 
+              !  The coarse grid location that is to the lower left of the FG point.
+
+              ci = compute_CGLL ( ni , ipos , nri , istag )
+
+              !  To interpolate to point "*" (look in grid cell "F"):
+              !  1. Use ABC to get a quadratic valid at "a"
+              !     Use BCD to get a quadratic valid at "a"
+              !     Average these to get the final value for "a"
+              !  2. Use EFG to get a quadratic valid at "b"
+              !     Use FGH to get a quadratic valid at "b"
+              !     Average these to get the final value for "b"
+              !  3. Use IJK to get a quadratic valid at "c"
+              !     Use JKL to get a quadratic valid at "c"
+              !     Average these to get the final value for "c"
+              !  4. Use MNO to get a quadratic valid at "d"
+              !     Use NOP to get a quadratic valid at "d"
+              !     Average these to get the final value for "d"
+              !  5. Use abc to get a quadratic valid at "*"
+              !     Use bcd to get a quadratic valid at "*"
+              !     Average these to get the final value for "*"
+
+              !  |=========|=========|=========|=========|
+              !  | -  -  - | -  -  - | -  -  - | -  -  - |
+              !  |         |         |         |         |
+              !  | -  M  - | -  N  d | -  O  - | -  P  - |
+              !  |         |         |         |         |
+              !  | -  -  - | -  -  - | -  -  - | -  -  - |
+              !  |=========|=========|=========|=========|
+              !  | -  -  - | -  -  - | -  -  - | -  -  - |
+              !  |         |         |         |         |
+              !  | -  I  - | -  J  c | -  K  - | -  L  - |
+              !  |         |         |         |         |
+              !  | -  -  - | -  -  - | -  -  - | -  -  - |
+              !  |=========|=========|=========|=========|
+              !  | -  -  - | -  -  * | -  -  - | -  -  - |
+              !  |         |         |         |         |
+              !  | -  E  - | -  F  b | -  G  - | -  H  - |
+              !  |         |         |         |         |
+              !  | -  -  - | -  -  - | -  -  - | -  -  - |
+              !  |=========|=========|=========|=========|
+              !  | -  -  - | -  -  - | -  -  - | -  -  - |
+              !  |         |         |         |         |
+              !  | -  A  - | -  B  a | -  C  - | -  D  - |
+              !  |         |         |         |         |
+              !  | -  -  - | -  -  - | -  -  - | -  -  - |
+              !  |=========|=========|=========|=========|
+
+              !  Overlapping quadratic interpolation.
+
+              IF ( imask ( ni, nj ) .EQ. 1 ) THEN
+
+                 !  I-direction location of "*"
+
+                 nx = REAL(ni)
+
+                 !  I-direction location of "A", "E", "I", "M"
+
+                 cxm1 = nest_loc_of_cg ( ci-1 , ipos , nri , ioff ) 
+
+                 !  I-direction location of "B", "F", "J", "N"
+
+                 cxp0 = nest_loc_of_cg ( ci   , ipos , nri , ioff ) 
+
+                 !  I-direction location of "C", "G", "K", "O"
+
+                 cxp1 = nest_loc_of_cg ( ci+1 , ipos , nri , ioff ) 
+
+                 !  I-direction location of "D", "H", "L", "P"
+
+                 cxp2 = nest_loc_of_cg ( ci+2 , ipos , nri , ioff ) 
+
+                 !  Value at "a"
+
+                 nfld_m1 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2, &
+                                               cfld(ci-1,nk,cj-1), cfld(ci+0,nk,cj-1), &
+                                               cfld(ci+1,nk,cj-1), cfld(ci+2,nk,cj-1) )
+
+                 !  Value at "b"
+
+                 nfld_p0 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2,  &
+                                               cfld(ci-1,nk,cj+0), cfld(ci+0,nk,cj+0), &
+                                               cfld(ci+1,nk,cj+0), cfld(ci+2,nk,cj+0) )
+
+                 !  Value at "c"
+
+                 nfld_p1 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2,  &
+                                               cfld(ci-1,nk,cj+1), cfld(ci+0,nk,cj+1), &
+                                               cfld(ci+1,nk,cj+1), cfld(ci+2,nk,cj+1) )
+
+                 !  Value at "d"
+
+                 nfld_p2 = lagrange_quad_avg ( nx, cxm1, cxp0, cxp1, cxp2,  &
+                                               cfld(ci-1,nk,cj+2), cfld(ci+0,nk,cj+2), &
+                                               cfld(ci+1,nk,cj+2), cfld(ci+2,nk,cj+2) )
+
+                 !  J-direction location of "*"
+
+                ny = REAL(nj)
+
+                 !  J-direction location of "A", "B", "C", "D"
+
+                 cym1 = nest_loc_of_cg ( cj-1 , jpos , nrj , joff ) 
+
+                 !  J-direction location of "E", "F", "G", "H" 
+
+                 cyp0 = nest_loc_of_cg ( cj   , jpos , nrj , joff ) 
+
+                 !  J-direction location of "I", "J", "K", "L"
+
+                cyp1 = nest_loc_of_cg ( cj+1 , jpos , nrj , joff ) 
+
+                 !  J-direction location of "M", "N", "O", "P"
+
+                 cyp2 = nest_loc_of_cg ( cj+2 , jpos , nrj , joff ) 
+
+                 !  Value at "*"
+
+                 nfld(ni,nk,nj) = lagrange_quad_avg ( ny, cym1, cyp0, cyp1,  &
+                                                      cyp2, nfld_m1, nfld_p0, nfld_p1, nfld_p2 )
+
+             END IF
+
+           END DO i_loop
+        END DO    k_loop
+     END DO       j_loop
+
+     !  Put nested longitude back into the -180 to 180 range.
+
+     DO nj = njts, MIN(njde-jstag,njte)
+        DO ni = nits, MIN(nide-istag,nite)
+           IF ( nfld(ni,nkts,nj) .GT. 180 ) THEN
+              nfld(ni,nkts,nj) = -360 + nfld(ni,nkts,nj)
+           END IF
+        END DO
+    END DO
+
+   END SUBROUTINE interp_fcn_lagr_ll
 #endif 
 ! End of third block of ARW-only routines
+
+ 
diff --git a/wrfv2_fire/share/mediation_integrate.F b/wrfv2_fire/share/mediation_integrate.F
index 73a09541..603780db 100644
--- a/wrfv2_fire/share/mediation_integrate.F
+++ b/wrfv2_fire/share/mediation_integrate.F
@@ -93,9 +93,19 @@ SUBROUTINE med_before_solve_io ( grid , config_flags )
      IF ( .FALSE.) THEN
        rc = 1  ! dummy statement
      ELSE IF( WRFU_AlarmIsRinging( grid%alarms( ialarm ), rc=rc ) ) THEN
-       IF ( grid%dfi_stage == DFI_FST .OR. grid%dfi_opt == DFI_NODFI ) THEN
-          CALL med_hist_out ( grid , ialarm, config_flags )
-       END IF
+!----------------------------------------------------------------------
+! RASM Climate Diagnostics - JR, AS, MS  - October 2016
+!----------------------------------------------------------------------
+       IF  ( (ialarm .EQ.  AUXHIST5_ALARM) .AND. (config_flags%restart) .AND. ( currTime .EQ. startTime ) ) THEN
+         !  no AVG history output on the first time of the restart
+       ELSE IF  ( (ialarm .EQ.  AUXHIST6_ALARM) .AND. (config_flags%restart) .AND. ( currTime .EQ. startTime ) ) THEN
+         !  no DIURNAL history output on the first time of the restart
+       ELSE IF ( grid%dfi_stage == DFI_FST .OR. grid%dfi_opt == DFI_NODFI ) THEN
+         CALL med_hist_out ( grid , ialarm, config_flags )
+       ENDIF
+!----------------------------------------------------------------------
+! end RASM Climate Diagnostics
+!----------------------------------------------------------------------
        CALL WRFU_AlarmRingerOff( grid%alarms( ialarm ), rc=rc )
      ENDIF
    ENDDO
@@ -530,7 +540,7 @@ END SUBROUTINE wrf_tsin
        !  adjust temp and qv
 
        CALL adjust_tempqv ( nest%mub , nest%mub_save , &
-                            nest%znw , nest%p_top , &
+                            nest%c3h , nest%c4h , nest%znw , nest%p_top , &
                             nest%t_2 , nest%p , nest%moist(ims,kms,jms,P_QV) , &
                             ids , ide , jds , jde , kds , kde , &
                             ims , ime , jms , jme , kms , kme , &
@@ -1726,7 +1736,7 @@ SUBROUTINE med_hist_out ( grid , stream, config_flags )
 
    END SELECT
    IF ( wrf_dm_on_monitor() ) THEN
-     WRITE ( message , FMT = '("Writing ",A30," for domain ",I8)' )TRIM(fname),grid%id
+     WRITE ( message , FMT = '("Writing ",A," for domain ",I8)' )TRIM(fname),grid%id
      CALL end_timing ( TRIM(message) )
    END IF
 
@@ -2164,6 +2174,27 @@ SUBROUTINE open_hist_w ( grid , config_flags, stream, alarm_id, &
    IF ( adjust ) THEN 
      CALL adjust_io_timestr( grid%io_intervals( alarm_id ), CT, ST, timestr )
    ENDIF
+#if (DA_CORE != 1 && NMM_CORE != 1)
+!----------------------------------------------------------------------
+! RASM Climate Diagnostics - JR, AS, MS  - October 2016
+!----------------------------------------------------------------------
+   IF( alarm_id .EQ. AUXHIST5_ALARM .AND. config_flags%mean_diag .EQ. 1 ) THEN
+      WRITE(message, *) "RASM STATS: MEAN AUXHIST5 oid=", oid, " fname=", trim(fname), " alarmI_id=", alarm_id, " Time_outNow=", timestr
+      CALL wrf_debug(200,  message )
+      WRITE(message, *) "RASM STATS: MEAN AUXHIST5 Time_outbefore =...", trim(grid%OUTDATE_MEAN)
+      CALL wrf_debug(200,  message )
+      timestr = grid%OUTDATE_MEAN  
+   ELSE IF( alarm_id .EQ. AUXHIST6_ALARM .AND. config_flags%diurnal_diag .EQ. 1 ) THEN
+      WRITE(message, *) "RASM STATS: DIURNAL AUXHIST6 oid=", oid, " fname=", trim(fname), " alarmI_id=", alarm_id, " Time_outNow=", timestr
+      CALL wrf_debug(200,  message )
+      WRITE(message, *) "RASM STATS: DIURNAL AUXHIST6 Time_outbefore =...", trim(grid%OUTDATE_DIURN)
+      CALL wrf_debug(200,  message )
+      timestr = grid%OUTDATE_DIURN 
+   ENDIF
+!----------------------------------------------------------------------
+! end RASM Climate Diagnostics
+!----------------------------------------------------------------------
+#endif
    CALL construct_filename2a ( fname , hist_outname, &
                                grid%id , 2 , timestr )
    stream_l = stream-auxhist1_only+1
diff --git a/wrfv2_fire/share/module_bc.F b/wrfv2_fire/share/module_bc.F
index 7b494fff..47e0af86 100644
--- a/wrfv2_fire/share/module_bc.F
+++ b/wrfv2_fire/share/module_bc.F
@@ -1,3 +1,14 @@
+#if ( HYBRID_COORD==1 )
+#define mu_2(...) (c1(k)*XXPC2XX(__VA_ARGS__))
+#define XXPC2XX(...) mu_2(__VA_ARGS__)
+
+#define mub(...) (c1(k)*XXPCBXX(__VA_ARGS__)+c2(k))
+#define XXPCBXX(...) mub(__VA_ARGS__)
+
+#define mu(...) (c1(k)*XXPCXX(__VA_ARGS__)+c2(k))
+#define XXPCXX(...) mu(__VA_ARGS__)
+#endif
+
 !WRF:MODEL_LAYER:BOUNDARY
 !
 
@@ -1591,7 +1602,8 @@ END SUBROUTINE spec_bdytend
 !------------------------------------------------------------------------
    SUBROUTINE spec_bdytend_perturb   ( field_tend,                   &
                                        field_tend_perturb,           &
-                                       mu_2, mub, variable_in,       &
+                                       mu_2, mub, c1, c2,            &
+                                       variable_in,                  &
                                        msf, config_flags,            & 
                                        spec_bdy_width, spec_zone,    &
                                        kme_stoch,                    & ! stoch  dims
@@ -1620,6 +1632,7 @@ SUBROUTINE spec_bdytend_perturb   ( field_tend,                   &
       REAL,  DIMENSION( ims:ime ,                 jms:jme ), INTENT(IN   )   :: mu_2	
       REAL,  DIMENSION( ims:ime ,                 jms:jme ), INTENT(IN   )   :: mub
       REAL,  DIMENSION( ims:ime ,                 jms:jme ), INTENT(IN   )   :: msf
+      REAL,  DIMENSION(           kms:kme                 ), INTENT(IN   )   :: c1, c2
 	  
       TYPE( grid_config_rec_type ) config_flags
 
@@ -1648,7 +1661,6 @@ SUBROUTINE spec_bdytend_perturb   ( field_tend,                   &
       IF (variable == 'u') itf = min(ite,ide)
       IF (variable == 'v') jbe = jde
       IF (variable == 'v') jtf = min(jte,jde)
-      IF (variable == 't') ktf = kte
       IF (variable == 'h') ktf = kte
 
       IF (jts - jbs .lt. spec_zone) THEN
@@ -2094,7 +2106,7 @@ SUBROUTINE spec_bdyupdate(  field,      &
 
    END SUBROUTINE spec_bdyupdate
 !------------------------------------------------------------------------
-   SUBROUTINE spec_bdy_final   ( field, mu, msf,                       &
+   SUBROUTINE spec_bdy_final   ( field, mu, c1, c2, msf,               &
                                 field_bdy_xs, field_bdy_xe,            &
                                 field_bdy_ys, field_bdy_ye,            &
                                 field_bdy_tend_xs, field_bdy_tend_xe,  &
@@ -2129,6 +2141,7 @@ SUBROUTINE spec_bdy_final   ( field, mu, msf,                       &
 
       REAL,  DIMENSION( ims:ime , kms:kme , jms:jme ), INTENT(INOUT) :: field
       REAL,  DIMENSION( ims:ime , jms:jme), INTENT(IN   ) :: mu, msf
+      REAL,  DIMENSION( kms:kme ), INTENT(IN   ) :: c1, c2
       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_xs, field_bdy_xe
       REAL,  DIMENSION( ims:ime , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_ys, field_bdy_ye
       REAL,  DIMENSION( jms:jme , kds:kde , spec_bdy_width ), INTENT(IN   ) :: field_bdy_tend_xs, field_bdy_tend_xe
@@ -2162,8 +2175,7 @@ SUBROUTINE spec_bdy_final   ( field, mu, msf,                       &
       IF (variable == 'u') itf = min(ite,ide)
       IF (variable == 'v') jbe = jde
       IF (variable == 'v') jtf = min(jte,jde)
-      IF (variable == 't') ktf = kte
-      IF (variable == 'm') ktf = kte
+      IF (variable == 'm') ktf = kde
       IF (variable == 'h') ktf = kde
       IF (variable == 'w') ktf = kde
 
diff --git a/wrfv2_fire/share/module_check_a_mundo.F b/wrfv2_fire/share/module_check_a_mundo.F
index 4a28ece4..b58f8947 100644
--- a/wrfv2_fire/share/module_check_a_mundo.F
+++ b/wrfv2_fire/share/module_check_a_mundo.F
@@ -6,15 +6,23 @@ MODULE module_check_a_mundo
 !
 ! Contains subroutines that check the consistency of some namelist 
 ! settings. Some namelist settings depend on other values in the 
-! namelist. These subroutines reset the dependent values and write
-! a message to stdout instead of detecting a fatal error and abort-
-! ing on a parameter mis-match.  This works around depending on the
-! user to set these specific settings in the namelist.
+! namelist. The routine check_nml_consistency can detect quite a 
+! few fatal inconsistencies. These are all bundled up as a convenience.
+! The fatal errors are reported, and after the routine completes, then
+! a single call to wrf_error_fatal is issued. The setup_physics_suite routine
+! has only one fatal call, so that routine does not need this user-
+! friendly concept of bundling errors. The set_physics_rconfigs 
+! routine does not detect any problems that would result in a fatal
+! error, so the bundling of errors is also not required there.
 !
-!   SUBROUTINE check_nml_consistency  :
+!   SUBROUTINE check_nml_consistency :
 !      Check namelist settings for consistency
 !
-!   SUBROUTINE set_physics_rconfigs:
+!   SUBROUTINE setup_physics_suite : 
+!      Interpret user setting as referring to which supported schemes
+!      Currently: conus and tropical
+!
+!   SUBROUTINE set_physics_rconfigs :
 !      Check namelist settings that determine memory allocations.
 !
 !
@@ -31,7 +39,7 @@ MODULE module_check_a_mundo
 
 !=======================================================================
 
-   SUBROUTINE  check_nml_consistency
+   SUBROUTINE check_nml_consistency
  
 !
 !
@@ -45,6 +53,8 @@ SUBROUTINE  check_nml_consistency
       LOGICAL , EXTERNAL :: wrf_dm_on_monitor
       INTEGER :: i, j, oops, d1_value
       LOGICAL :: km_opt_already_done , diff_opt_already_done
+      INTEGER :: count_opt
+
 !TWG2015
 !
 !FASDAS
@@ -53,14 +63,12 @@ SUBROUTINE  check_nml_consistency
 !
 !END FASDAS
 !
-      LOGICAL :: fatal_error
       INTEGER :: count_fatal_error
 
 !-----------------------------------------------------------------------
 ! Set up the WRF Hydro namelist option to allow dynamic allocation of
 ! variables.
 !-----------------------------------------------------------------------
-   fatal_error = .false.
    count_fatal_error = 0
 #ifdef WRF_HYDRO
    model_config_rec % wrf_hydro = 1
@@ -96,9 +104,7 @@ SUBROUTINE  check_nml_consistency
            ( model_config_rec % damp_opt    .EQ. 2 ) ) THEN
          CALL wrf_message ( "The use_theta_m option may not be paired with damp_opt=2." )
          wrf_err_message = '--- ERROR: Either turn off use_theta_m, or select a different damp_opt option'
-       !  CALL wrf_error_fatal ( TRIM(wrf_err_message) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
       END IF
 
@@ -106,9 +112,7 @@ SUBROUTINE  check_nml_consistency
            ( model_config_rec % rad_nudge   .EQ. 1 ) ) THEN
          CALL wrf_message ( "The use_theta_m option may not be paired with rad_nudge=1." )
          wrf_err_message = '--- ERROR: Either turn off use_theta_m, or turn off the rad_nudge option'
-      !   CALL wrf_error_fatal ( TRIM(wrf_err_message) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
       END IF
 
@@ -152,9 +156,7 @@ SUBROUTINE  check_nml_consistency
       IF ( ( model_config_rec %   km_opt(1) .EQ. -1 ) .OR. &
            ( model_config_rec % diff_opt(1) .EQ. -1 ) ) THEN
             wrf_err_message = '--- ERROR: Both km_opt and diff_opt need to be set in the namelist.input file.'
-       !  CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
       END IF
 
@@ -174,9 +176,7 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: Chosen microphysics scheme cannot run with WRF-NMM '
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Fix mp_physics in namelist.input '
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       ENDDO
@@ -192,9 +192,7 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: sf_surface_physics must be equal for all domains '
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Fix sf_surface_physics in namelist.input '
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       ENDDO
@@ -210,9 +208,7 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: sf_sfclay_physics must be equal for all domains '
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Fix sf_sfclay_physics in namelist.input '
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       ENDDO
@@ -247,9 +243,7 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: ra_lw_physics must be equal for all domains '
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Fix ra_lw_physics in namelist.input '
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       ENDDO
@@ -260,9 +254,7 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: ra_sw_physics must be equal for all domains '
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Fix ra_sw_physics in namelist.input '
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       ENDDO
@@ -276,9 +268,7 @@ SUBROUTINE  check_nml_consistency
               ( model_config_rec % time_step .EQ. -1 ) ) THEN
 
             wrf_err_message = '--- ERROR: Known problem.  time_step must be set to a positive integer'
-         !       CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
 
          END IF
@@ -293,9 +283,7 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: bl_pbl_physics must be equal for all domains (or = zero)'
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Fix bl_pbl_physics in namelist.input '
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       ENDDO
@@ -312,13 +300,30 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: cu_physics must be equal for all domains (or = zero)'
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Fix cu_physics in namelist.input '
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       ENDDO
 
+
+#if ( defined NO_GAMMA_SUPPORT )
+!-----------------------------------------------------------------------
+! GF CU scheme requires an intrinsic gamma function. This is a 2008
+! feature that not all compilers yet support.
+!-----------------------------------------------------------------------
+
+      GF_test : DO i = 1, model_config_rec % max_dom
+         IF ( model_config_rec % cu_physics(i) .EQ. GFSCHEME ) THEN
+            wrf_err_message = '--- ERROR: cu_physics GF uses an intrinsic gamma function that is not available with this compiler'
+            CALL wrf_message ( TRIM( wrf_err_message ) )
+            wrf_err_message = '--- Change compilers, or change cu_physics option in the namelist.input file.'
+            CALL wrf_message ( TRIM( wrf_err_message ) )
+            count_fatal_error = count_fatal_error + 1
+            EXIT GF_test
+         END IF
+      ENDDO GF_test
+#endif
+
 !-----------------------------------------------------------------------
 ! If fractional_seaice = 0, and tice2tsk_if2cold = .true, nothing will happen
 !-----------------------------------------------------------------------
@@ -341,9 +346,7 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: If fine_input_stream /= 0, io_form_auxinput2 must be /= 0'
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Set io_form_auxinput2 in the time_control namelist (probably to 2).'
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       ENDDO
@@ -376,28 +379,6 @@ SUBROUTINE  check_nml_consistency
          model_config_rec%sf_urban_physics(i) = d1_value
       END DO
 
-!-----------------------------------------------------------------------
-! Check for consistency in the Noah-MP options
-!-----------------------------------------------------------------------
-
-      DO i = 1, model_config_rec % max_dom
-         IF ( model_config_rec%sf_surface_physics(i) == NOAHMPSCHEME ) THEN
-
-            ! Noah-MP does not work with the urban schemes
-
-            IF ( model_config_rec%sf_urban_physics(i) /= 0 ) THEN
-               WRITE(wrf_err_message, '(" --- ERROR:   Noah-MP LSM scheme (sf_surface_physics==", I2, ")")') NOAHMPSCHEME
-               CALL wrf_message ( TRIM ( wrf_err_message ) )
-               WRITE(wrf_err_message, '("              does not work with urban physics schemes")')
-         !      CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
-            ENDIF
-
-         END IF
-      END DO
-
 !------------------------------------------------------------------------
 ! Mills (2011) sea-ice albedo treatment only for Noah LSM and Noah-MP LSM
 !------------------------------------------------------------------------
@@ -410,9 +391,7 @@ SUBROUTINE  check_nml_consistency
                CALL wrf_message ( TRIM ( wrf_err_message ) )
                write (wrf_err_message, '("              sf_surface_physics == ", I2, " (Noah) or ", I2, " (Noah-MP).")') &
                LSMSCHEME, NOAHMPSCHEME
-         !      call wrf_error_fatal ( TRIM ( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
 
             END IF
@@ -435,9 +414,7 @@ SUBROUTINE  check_nml_consistency
             WRITE(wrf_err_message, '("              does not work with NMM ")')
             CALL wrf_message ( TRIM ( wrf_err_message ) )
             WRITE(wrf_err_message, '("Select a different LSM scheme ")')
-         !   CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       END DO
@@ -460,10 +437,8 @@ SUBROUTINE  check_nml_consistency
                wrf_err_message = '             and should not be changed from their default value for SPPT' 
                CALL wrf_message ( wrf_err_message )
                wrf_err_message = '--- ERROR: If you really want to modify "kminforct" etc.,  edit module_check a_mundo.'
-         !      CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+               CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+               count_fatal_error = count_fatal_error + 1
            endif
          endif
    ENDDO
@@ -476,14 +451,33 @@ SUBROUTINE  check_nml_consistency
                CALL wrf_message ( wrf_err_message )
                wrf_err_message = '             and should not be changed from their default value for RAND_PERTURB' 
                CALL wrf_message ( wrf_err_message )
-               wrf_err_message = ' ABORT. If you really want to modify "kminforct" etc.,  edit module_check a_mundo.'
-         !      CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+               wrf_err_message = '--- ERROR: If you really want to modify "kminforct" etc.,  edit module_check a_mundo.'
+               CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+               count_fatal_error = count_fatal_error + 1
            endif
          endif
    ENDDO
+   DO i = 1, model_config_rec % max_dom
+         IF (( model_config_rec % spp_conv(i) .ne. 0).or.( model_config_rec % spp_pbl(i) .ne. 0).or. (model_config_rec % spp_lsm(i) .ne. 0)  & 
+           .or. ( model_config_rec % spp(i) .ne. 0))  then
+           model_config_rec % spp_on=1
+           IF (( model_config_rec%KMINFORCT .ne. 1) .or. (model_config_rec%KMAXFORCT .ne. 1000000) .or.   & 
+               ( model_config_rec%LMINFORCT .ne. 1) .or. (model_config_rec%LMAXFORCT .ne. 1000000)) then    
+               wrf_err_message = '--- Warning: the namelist parameter "kminforct" etc are for SKEBS only'
+               CALL wrf_message ( wrf_err_message )
+               wrf_err_message = '             and should not be changed from their default value for RAND_PERTURB' 
+               CALL wrf_message ( wrf_err_message )
+               wrf_err_message = '--- ERROR: If you really want to modify "kminforct" etc.,  edit module_check a_mundo.'
+               CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+               count_fatal_error = count_fatal_error + 1
+           endif
+         endif
+         IF ( model_config_rec % spp(i) .ne. 0)  then
+           model_config_rec % spp_conv=1
+           model_config_rec % spp_pbl=1
+           model_config_rec % spp_lsm=1
+         endif
+   ENDDO
    DO i = 1, model_config_rec % max_dom
          IF ( model_config_rec % stoch_vertstruc_opt(i) ==1 )  then
            model_config_rec % skebs_vertstruc=1       ! parameter stoch_vertstruc_opt is being replaced with skebs_vertstruc
@@ -549,9 +543,7 @@ SUBROUTINE  check_nml_consistency
 
 #if (WRF_CHEM != 1)
       wrf_err_message = '--- ERROR: This option is only for WRF_CHEM.'
-    !  CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
 #endif
 
@@ -565,9 +557,7 @@ SUBROUTINE  check_nml_consistency
       IF ( .NOT. model_config_rec % have_bcs_chem(1) ) THEN
             wrf_err_message = '--- ERROR: This perturb_chem_bdy option needs '// &
                               'have_bcs_chem = .true. in chem.'
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
       ENDIF
 #endif
@@ -586,6 +576,15 @@ SUBROUTINE  check_nml_consistency
          model_config_rec%num_traj = 0 
    END IF
 
+#elif( NMM_CORE == 1 )
+!----------------------------------------------------------------------------
+! If NMM core and trajectories are on then halt.
+!----------------------------------------------------------------------------
+   IF ( model_config_rec%traj_opt /= 0 ) THEN
+         wrf_err_message = 'Trajectories not supported in NMM core '
+         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+         count_fatal_error = count_fatal_error + 1
+   END IF
 #endif
 
 #if (EM_CORE == 1)
@@ -617,9 +616,7 @@ SUBROUTINE  check_nml_consistency
          wrf_err_message = '--- ERROR: bl_pbl_physics must be set to 1 for cu_physics = 11 '
          CALL wrf_message ( wrf_err_message )
          wrf_err_message = '--- Fix bl_pbl_physics in namelist.input OR use another cu_physics option '
-        ! CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
       END IF
 
@@ -658,13 +655,40 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: If sst_update /= 0, io_form_auxinput4 must be /= 0'
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Set io_form_auxinput4 in the time_control namelist (probably to 2).'
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       END IF
 
+!-----------------------------------------------------------------------
+! If sst_update = 1, we need to make sure that two nml items are set:
+!   1. io_form_auxinput4 = 2 (only for one domain)
+!   2. auxinput4_interval = NON-ZERO (just check most coarse domain)
+!-----------------------------------------------------------------------
+
+      IF ( model_config_rec%sst_update .EQ. 1 ) THEN
+         IF ( model_config_rec%io_form_auxinput4 .EQ. 0 ) THEN
+            wrf_err_message = '--- ERROR: If sst_update /= 0, io_form_auxinput4 must be /= 0'
+            CALL wrf_debug ( 0, TRIM(wrf_err_message) )
+            wrf_err_message = '--- Set io_form_auxinput4 in the time_control namelist (probably to 2).'
+            CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+            count_fatal_error = count_fatal_error + 1
+         END IF
+
+         IF ( ( model_config_rec%auxinput4_interval(1)   .EQ. 0 ) .AND. & 
+              ( model_config_rec%auxinput4_interval_y(1) .EQ. 0 ) .AND. & 
+              ( model_config_rec%auxinput4_interval_d(1) .EQ. 0 ) .AND. & 
+              ( model_config_rec%auxinput4_interval_h(1) .EQ. 0 ) .AND. & 
+              ( model_config_rec%auxinput4_interval_m(1) .EQ. 0 ) .AND. & 
+              ( model_config_rec%auxinput4_interval_s(1) .EQ. 0 ) ) THEN
+            wrf_err_message = '--- ERROR: If sst_update /= 0, one of the auxinput4_interval settings must be /= 0'
+            CALL wrf_debug ( 0, TRIM(wrf_err_message) )
+            wrf_err_message = '--- Set auxinput4_interval_s to the same value as interval_seconds (usually a pretty good guess).'
+            CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+            count_fatal_error = count_fatal_error + 1
+         END IF
+      END IF
+
 !-----------------------------------------------------------------------
 ! The qndropsource relies on the flag PROGN (when not running chemistry)
 ! and is always allocated when running WRF Chem.
@@ -693,9 +717,7 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: If grid_sfdda >= 1, then grid_fdda must also = 1 for that domain '
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Change grid_fdda or grid_sfdda in namelist.input '
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       ENDDO
@@ -803,9 +825,7 @@ SUBROUTINE  check_nml_consistency
 !------------------------------------------------------------------------
        IF ( model_config_rec%rinblw(1) .EQ. -1 ) THEN
             wrf_err_message = '--- ERROR: rinblw needs to be set in the namelist.input file.'
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
        END IF
     END IF 
@@ -825,7 +845,8 @@ SUBROUTINE  check_nml_consistency
 !     IF (model_config_rec%fasdas(i) .EQ. 1 ) THEN
 !       IF (model_config_rec%grid_sfdda(i) .EQ. 0) THEN
 !        wrf_err_message = '--- ERROR: sfdda needs to be set in the namelist.input file to run FASDAS.'
-!        CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
+!        CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+!        count_fatal_error = count_fatal_error + 1
 !       END IF
 !     END IF 
      END DO
@@ -914,46 +935,45 @@ SUBROUTINE  check_nml_consistency
       ENDDO
 
 !-----------------------------------------------------------------------
-!  gwd_opt = 1 only works with YSU & MYNN PBL.
+! Make sure icloud_bl is only used when MYNN is chosen.
 !-----------------------------------------------------------------------
 
       oops = 0
       DO i = 1, model_config_rec % max_dom
-         IF (model_config_rec%gwd_opt == 1 ) THEN
-            IF ( (model_config_rec%bl_pbl_physics(i) .EQ. YSUSCHEME ) .OR. &
-                 (model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME2 ) .OR. &
-                 (model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME3) ) THEN
-                !NO PROBLEM
-            ELSE
-               model_config_rec%gwd_opt = 0
-               oops = oops + 1
-            END IF
+         IF ( model_config_rec%icloud_bl .eq. 1) THEN
+           IF ( model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME2 .OR. &
+                model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME3 ) THEN
+              !CORRECTLY CONFIGURED
+           ELSE
+              model_config_rec%icloud_bl = 0
+              oops = oops + 1
+           END IF
          END IF
       ENDDO      ! Loop over domains
       IF ( oops .GT. 0 ) THEN
-         wrf_err_message = '--- NOTE: bl_pbl_physics /= 1,5,6 implies gwd_opt cannot be 1, resetting'
+         wrf_err_message = 'Need MYNN PBL for icloud_bl = 1, resetting to 0'
          CALL wrf_message ( wrf_err_message )
       END IF
 
 !-----------------------------------------------------------------------
-! Make sure icloud_bl is only used when MYNN is chosen.
+! Make sure microphysics option without QICE array cannot be used with icloud=3
 !-----------------------------------------------------------------------
 
       oops = 0
       DO i = 1, model_config_rec % max_dom
-         IF ( model_config_rec%icloud_bl .eq. 1) THEN
-           IF ( model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME2 .OR. &
-                model_config_rec%bl_pbl_physics(i) .EQ. MYNNPBLSCHEME3 ) THEN
-              !CORRECTLY CONFIGURED
-           ELSE
-              model_config_rec%icloud_bl = 0
-              oops = oops + 1
+         IF ( model_config_rec%icloud .eq. 3) THEN
+           IF ( model_config_rec%mp_physics(i) .EQ. WSM3SCHEME .OR. &
+                model_config_rec%mp_physics(i) .EQ. KESSLERSCHEME ) THEN
+                oops = oops + 1
            END IF
          END IF
       ENDDO      ! Loop over domains
       IF ( oops .GT. 0 ) THEN
-         wrf_err_message = 'Need MYNN PBL for icloud_bl = 1, resetting to 0'
+         wrf_err_message = '--- ERROR: Need microphysics schemes with QICE array for icloud = 3'
+         CALL wrf_message ( wrf_err_message )
+         wrf_err_message = '--- Choose a microphysics scheme other than WSM3 and Kessler'
          CALL wrf_message ( wrf_err_message )
+         count_fatal_error = count_fatal_error + 1
       END IF
 
 !-----------------------------------------------------------------------
@@ -968,9 +988,7 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: If grid_fdda /= 0, io_form_gfdda must be /= 0'
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Set io_form_gfdda in the time_control namelist (probably to 2).'
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       END IF
@@ -981,9 +999,7 @@ SUBROUTINE  check_nml_consistency
             wrf_err_message = '--- ERROR: If grid_sfdda /= 0, io_form_sgfdda must be /= 0'
             CALL wrf_message ( wrf_err_message )
             wrf_err_message = '--- Set io_form_sgfdda in the time_control namelist (probably to 2).'
-         !   CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
          END IF
       END IF
@@ -1005,10 +1021,8 @@ SUBROUTINE  check_nml_consistency
                wrf_err_message = '--- ERROR: provide: auxhist23_interval (max_dom) and io_form_auxhist23'
                CALL wrf_message ( wrf_err_message )
                wrf_err_message = '--- Add supporting IO for stream 23 for pressure-level diags'
-         !      CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+               CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+               count_fatal_error = count_fatal_error + 1
             END IF
          END DO
          DO i = 1, model_config_rec % max_dom
@@ -1038,10 +1052,8 @@ SUBROUTINE  check_nml_consistency
                wrf_err_message = '--- ERROR: provide: auxhist22_interval (max_dom) and io_form_auxhist22'
                CALL wrf_message ( wrf_err_message )
                wrf_err_message = '--- Add supporting IO for stream 22 for height-level diags'
-         !      CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+               CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+               count_fatal_error = count_fatal_error + 1
             END IF
          END DO
          DO i = 1, model_config_rec % max_dom
@@ -1053,6 +1065,88 @@ SUBROUTINE  check_nml_consistency
          END DO
       END IF
 
+!-----------------------------------------------------------------------
+! For RASM Diagnostics
+! -verify that only one time interval is specified
+! -change the intervals to values used in RASM Diagnotics
+! -verify that a time interval has been set
+!-----------------------------------------------------------------------
+
+! 1. Only one time interval type specified
+
+      DO i = 1, model_config_rec % max_dom
+         count_opt = 0
+         IF ( model_config_rec%mean_diag_interval_s (i) .GT. 0 ) THEN
+            count_opt = count_opt + 1
+         END IF 
+         IF ( model_config_rec%mean_diag_interval_m (i) .GT. 0 ) THEN
+            count_opt = count_opt + 1
+         END IF 
+         IF ( model_config_rec%mean_diag_interval_h (i) .GT. 0 ) THEN
+            count_opt = count_opt + 1
+         END IF 
+         IF ( model_config_rec%mean_diag_interval_d (i) .GT. 0 ) THEN
+            count_opt = count_opt + 1
+         END IF 
+         IF ( model_config_rec%mean_diag_interval_mo(i) .GT. 0 ) THEN
+            count_opt = count_opt + 1
+         END IF 
+         IF ( model_config_rec%mean_diag_interval   (i) .GT. 0 ) THEN
+            count_opt = count_opt + 1
+         END IF 
+         IF ( count_opt .GT. 1 ) THEN
+            wrf_err_message = '--- ERROR:  Only use one of: mean_diag_interval, _s, _m, _h, _d, _mo '
+            CALL wrf_message ( wrf_err_message )
+            count_fatal_error = count_fatal_error + 1
+         END IF
+      END DO
+
+! 2. Put canonical intervals into RASM expected form
+
+      DO i = 1, model_config_rec % max_dom
+         IF ( model_config_rec%mean_diag_interval_s (i) .GT. 0 ) THEN
+            model_config_rec%mean_interval(i) = model_config_rec%mean_diag_interval_s (i)
+            model_config_rec%mean_freq = 1
+         END IF 
+         IF ( model_config_rec%mean_diag_interval_m (i) .GT. 0 ) THEN
+            model_config_rec%mean_interval(i) = model_config_rec%mean_diag_interval_m (i)
+            model_config_rec%mean_freq = 2
+         END IF 
+         IF ( model_config_rec%mean_diag_interval_h (i) .GT. 0 ) THEN
+            model_config_rec%mean_interval(i) = model_config_rec%mean_diag_interval_h (i)
+            model_config_rec%mean_freq = 3
+         END IF 
+         IF ( model_config_rec%mean_diag_interval_d (i) .GT. 0 ) THEN
+            model_config_rec%mean_interval(i) = model_config_rec%mean_diag_interval_d (i)
+            model_config_rec%mean_freq = 4
+         END IF 
+         IF ( model_config_rec%mean_diag_interval_mo(i) .GT. 0 ) THEN
+            model_config_rec%mean_interval(i) = model_config_rec%mean_diag_interval_mo(i)
+            model_config_rec%mean_freq = 5
+         END IF 
+         IF ( model_config_rec%mean_diag_interval   (i) .GT. 0 ) THEN
+            model_config_rec%mean_interval(i) = model_config_rec%mean_diag_interval   (i)
+            model_config_rec%mean_freq = 2
+         END IF 
+      END DO
+
+! 3. If requested, need an interval.
+
+      IF ( model_config_rec%mean_diag .EQ. 1 ) THEN
+         count_opt = 0
+         DO i = 1, model_config_rec % max_dom
+            IF ( model_config_rec%mean_interval   (i) .GT. 0 ) THEN
+               count_opt = count_opt + 1
+            END IF 
+         END DO
+         IF ( count_opt .LT. 1 ) THEN
+            wrf_err_message = '--- ERROR:  mean_diag = 1, but no computation interval given'
+            CALL wrf_message ( wrf_err_message )
+            wrf_err_message = '            Use one of: mean_diag_interval, _s, _m, _h, _d, _mo '
+            CALL wrf_message ( wrf_err_message )
+            count_fatal_error = count_fatal_error + 1
+         END IF
+      END IF
 
 !-----------------------------------------------------------------------
 ! For nwp_diagnostics = 1, history_interval must be used.           
@@ -1063,12 +1157,24 @@ SUBROUTINE  check_nml_consistency
          wrf_err_message = '--- ERROR:  nwp_diagnostics requires the use of "history_interval" namelist.'
          CALL wrf_message ( wrf_err_message )
          wrf_err_message = '---         Replace interval variable with "history_interval".'
-        ! CALL wrf_error_fatal ( wrf_err_message )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
       END IF
 
+!-----------------------------------------------------------------------
+! If hailcast_opt = 1, horizontal grid spacing must be 4 km or finer.
+!-----------------------------------------------------------------------
+      DO i = 1, model_config_rec % max_dom
+         IF ( ( model_config_rec%hailcast_opt(i) .NE. 0 ) .AND. &
+              ( model_config_rec%dx(i) .GT. 4000 ) ) THEN
+            wrf_err_message = '--- WARNING:  hailcast_opt requires a grid-spacing of 4 km or finer.'
+            CALL wrf_message ( wrf_err_message )
+            wrf_err_message = '---          hailcast_opt is now 0.'
+            CALL wrf_message ( wrf_err_message )
+            model_config_rec%hailcast_opt(i) = 0
+         ENDIF
+      ENDDO
+
 !-----------------------------------------------------------------------
 ! Name change in the namelist.input file.  We used to only have the
 ! ocean mixed layer option (omlcall=1).  With the addition of a 3D ocean,
@@ -1080,9 +1186,7 @@ SUBROUTINE  check_nml_consistency
          wrf_err_message = '--- ERROR:  The namelist.input variable "omlcall" has been renamed.'
          CALL wrf_message ( wrf_err_message )
          wrf_err_message = '---         Replace "omlcall" with the new name "sf_ocean_physics".'
-         !CALL wrf_error_fatal ( wrf_err_message )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
       END IF
 
@@ -1094,7 +1198,7 @@ SUBROUTINE  check_nml_consistency
 
       IF ( model_config_rec%use_adaptive_time_step ) THEN
          IF ( ( model_config_rec%cu_physics(1) .EQ. BMJSCHEME     ) .OR. &
-              ( model_config_rec%cu_physics(1) .EQ. MESO_SAS     ) .OR. &
+              ( model_config_rec%cu_physics(1) .EQ. SCALESASSCHEME) .OR. &
               ( model_config_rec%cu_physics(1) .EQ. SASSCHEME     ) .OR. &
               ( model_config_rec%cu_physics(1) .EQ. OSASSCHEME    ) .OR. &
               ( model_config_rec%cu_physics(1) .EQ. NSASSCHEME    ) .OR. &
@@ -1122,10 +1226,8 @@ SUBROUTINE  check_nml_consistency
             model_config_rec%time_step_dfi = model_config_rec%time_step
             IF ( model_config_rec%time_step_dfi .EQ. -1 ) THEN
                wrf_err_message = '--- ERROR: DFI Timestep or standard WRF time step must be specified.'
-         !      CALL wrf_error_fatal ( wrf_err_message )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+               CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+               count_fatal_error = count_fatal_error + 1
             END IF
          END IF
       END IF
@@ -1166,10 +1268,8 @@ SUBROUTINE  check_nml_consistency
                 wrf_err_message = '---          Grell (G3) CU scheme' 
                 CALL wrf_message ( wrf_err_message )
                 wrf_err_message = '---          Grell-Devenyi (GD) CU scheme' 
-         !       CALL wrf_error_fatal ( wrf_err_message )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+            CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+            count_fatal_error = count_fatal_error + 1
           END IF
          END IF
        END DO
@@ -1191,10 +1291,8 @@ SUBROUTINE  check_nml_consistency
                 wrf_err_message = '---          Multi-scale Kain-Fritsch (cu_physics=11)' 
                 CALL wrf_message ( wrf_err_message )
                 wrf_err_message = '---          old Kain-Fritsch (cu_physics=99)' 
-         !       CALL wrf_error_fatal ( wrf_err_message )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+            CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+            count_fatal_error = count_fatal_error + 1
           END IF
          END IF
        END DO
@@ -1239,17 +1337,13 @@ SUBROUTINE  check_nml_consistency
          IF ( ( model_config_rec%bl_pbl_physics(i) .EQ. TEMFPBLSCHEME ) .AND. &
               ( model_config_rec%sf_sfclay_physics(i) .NE. TEMFSFCSCHEME ) )  THEN
             wrf_err_message = '--- ERROR: Using bl_pbl_physics=10 requires sf_sfclay_physics=10 '
-         !   CALL wrf_error_fatal ( TRIM(wrf_err_message) )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+            CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+            count_fatal_error = count_fatal_error + 1
          ELSEIF ( ( model_config_rec%bl_pbl_physics(i) .NE. TEMFPBLSCHEME ) .AND. &
                   ( model_config_rec%sf_sfclay_physics(i) .EQ. TEMFSFCSCHEME ) ) THEN
             wrf_err_message = '--- ERROR: Using sf_sfclay_physics=10 requires bl_pbl_physics=10 '
-         !   CALL wrf_error_fatal ( TRIM(wrf_err_message) )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+            CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+            count_fatal_error = count_fatal_error + 1
          END IF
       ENDDO      ! Loop over domains
 
@@ -1260,9 +1354,7 @@ SUBROUTINE  check_nml_consistency
       IF ( model_config_rec%tmn_update .EQ. 1 .AND. &
            model_config_rec%lagday .EQ. 1 ) THEN 
            wrf_err_message = '--- ERROR: Using tmn_update=1 requires lagday=150 '
-         !  CALL wrf_error_fatal ( TRIM(wrf_err_message) )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
       END IF
 
@@ -1274,10 +1366,8 @@ SUBROUTINE  check_nml_consistency
          IF ( ( model_config_rec%bl_pbl_physics(i) .EQ. TEMFPBLSCHEME ) .AND. &
               (model_config_rec%dfi_opt .NE. DFI_NODFI) )  THEN
             wrf_err_message = '--- ERROR: DFI not available for bl_pbl_physics=10 '
-         !   CALL wrf_error_fatal ( TRIM(wrf_err_message) )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+            CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+            count_fatal_error = count_fatal_error + 1
          END IF
       ENDDO      ! Loop over domains
 
@@ -1307,9 +1397,7 @@ SUBROUTINE  check_nml_consistency
          wrf_err_message = '--- ERROR: However, the WRF CLM scheme was not compiled in WRF.'
          CALL wrf_debug ( 0, TRIM(wrf_err_message) )
          wrf_err_message = '--- ERROR: Please place the -DWRF_USE_CLM option in configure.wrf file, and recompile.'
-         ! CALL wrf_error_fatal ( wrf_err_message )
          CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
          count_fatal_error = count_fatal_error + 1
       END IF
 #endif
@@ -1350,6 +1438,37 @@ SUBROUTINE  check_nml_consistency
          CALL wrf_message ( wrf_err_message )
       END IF
 
+!-----------------------------------------------------------------------
+!  The hybrid vertical coordinate does not work with vertical refinement.
+!-----------------------------------------------------------------------
+     DO i=1,model_config_rec%max_dom
+        IF ((model_config_rec%vert_refine_method(i) .EQ. 2) .AND. (model_config_rec%hybrid_opt .EQ. 2)) THEN
+           WRITE(wrf_err_message,'(A)') '--- ERROR: The hybrid vertical coordinate does not work with vertical refinement.'
+           CALL wrf_message( wrf_err_message )
+           count_fatal_error = count_fatal_error + 1
+        ENDIF
+     END DO 
+
+!-----------------------------------------------------------------------
+!  The hybrid vertical coordinate (HVC) namelist.input option (hybrid_opt=2) 
+!  requires the code to be built with the HVC code enabled.  This is a run-time
+!  test to make sure the correct compile-time capabilities are available.
+!-----------------------------------------------------------------------
+#if ( HYBRID_COORD==1 )
+#else
+     IF (model_config_rec%hybrid_opt .NE. 0) THEN
+        WRITE(wrf_err_message,'(A)') '--- ERROR: The code was not built with hybrid vertical coordinate enabled'
+        CALL wrf_message( wrf_err_message )
+        WRITE(wrf_err_message,'(A)') '---        Either set hybrid_opt=0 in the namelist.input file, or '
+        CALL wrf_message( wrf_err_message )
+        WRITE(wrf_err_message,'(A)') '---        re-compile with the hybrid vertical coordinate enabled'       
+        CALL wrf_message( wrf_err_message )
+        WRITE(wrf_err_message,'(A)') '---        For example: clean -a ; configure -hyb ; compile em_real '
+        CALL wrf_message( wrf_err_message )
+        count_fatal_error = count_fatal_error + 1
+     ENDIF
+#endif
+
 !-----------------------------------------------------------------------
 !  DJW Check that we're not using ndown and vertical nesting.
 !-----------------------------------------------------------------------
@@ -1368,10 +1487,8 @@ SUBROUTINE  check_nml_consistency
          DO j=1,model_config_rec%max_dom
            IF ((model_config_rec%vert_refine_method(i) .NE. model_config_rec%vert_refine_method(j)) .AND. (model_config_rec%vert_refine_method(j) .NE. 0)) THEN
              write(wrf_err_message,'(A,I1,A,I2,A,I1,A,I2,A)') '--- ERROR: vert_refine_method differs on grid ids ',model_config_rec%grid_id(i),' and ',model_config_rec%grid_id(j),'. Only one type of vertical grid nesting can be used at a time.'
-         !    CALL wrf_error_fatal( wrf_err_message )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+              CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+              count_fatal_error = count_fatal_error + 1
            ENDIF
          ENDDO
        ENDIF
@@ -1388,10 +1505,8 @@ SUBROUTINE  check_nml_consistency
               IF ((i .NE. j) .AND. (model_config_rec%parent_id(i) .EQ. model_config_rec%grid_id(j))) THEN
                 IF (model_config_rec%e_vert(i) .NE. model_config_rec%e_vert(j)) THEN
                   write(wrf_err_message,'(A,I2,A,I2,A)') '--- ERROR: e_vert differs on grid ids ',model_config_rec%grid_id(i),' and ',model_config_rec%grid_id(j),'. Set vert_refine_method or make e_vert consistent.'
-         !         CALL wrf_error_fatal( wrf_err_message )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+                  CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+                  count_fatal_error = count_fatal_error + 1
                 ENDIF
               ENDIF
             ENDDO
@@ -1408,10 +1523,8 @@ SUBROUTINE  check_nml_consistency
         IF ((model_config_rec%parent_id(i) .EQ. 0) .OR. (model_config_rec%parent_id(i) .EQ. model_config_rec%grid_id(i))) THEN
           IF (model_config_rec%vert_refine_method(i) .NE. 0) THEN
             write(wrf_err_message,'(A,I1,A,I2,A)') '--- ERROR: vert_refine_method=',model_config_rec%vert_refine_method(i),' for grid_id=',model_config_rec%grid_id(i),', must be 0 for a non-nested domain.'
-         !   CALL wrf_error_fatal( wrf_err_message )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+            CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+            count_fatal_error = count_fatal_error + 1
           ENDIF
         ENDIF
       ENDDO
@@ -1424,10 +1537,8 @@ SUBROUTINE  check_nml_consistency
           j = model_config_rec%parent_id(i)
           IF (MOD(model_config_rec%e_vert(i)-1, model_config_rec%e_vert(j)-1) .NE. 0) THEN
             write(wrf_err_message,'(A,I2,A,I2,A)') "--- ERROR: grid_id=",i," and parent (grid_id=",j,") have incompatible e_vert's for vertical nesting with integer refinement."
-         !   CALL wrf_error_fatal ( wrf_err_message )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+            CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+            count_fatal_error = count_fatal_error + 1
           ENDIF
         ENDIF
       ENDDO
@@ -1447,15 +1558,23 @@ SUBROUTINE  check_nml_consistency
              !  We are OK, I just hate writing backwards / negative / convoluted if tests 
              !  that are not easily comprehensible.
           ELSE
-            wrf_err_message = '--- ERROR: vert_refine_method=2 only works with either RRTM or RRTMG'
-         !   CALL wrf_error_fatal ( wrf_err_message )
-         CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
-         fatal_error = .true.
-         count_fatal_error = count_fatal_error + 1
+            wrf_err_message = '--- ERROR: vert_refine_method=2 only works with ra_lw_physics=1 (RRTM) and ra_sw_physics=1 (Dudhia)'
+            CALL wrf_debug ( 0, TRIM( wrf_err_message ) )
+            count_fatal_error = count_fatal_error + 1
           END IF 
         END IF
       END DO
 
+!-----------------------------------------------------------------------
+! This WRF version does not support trajectories on a global domain
+!-----------------------------------------------------------------------
+      IF (  model_config_rec % polar(1) .AND. &
+            model_config_rec % fft_filter_lat .LT. 90. .AND. &
+            model_config_rec % traj_opt .NE. 0 ) THEN
+         CALL wrf_debug ( 0, '--- ERROR: Trajectories not supported on global domain' )
+         count_fatal_error = count_fatal_error + 1
+      END IF
+
 !-----------------------------------------------------------------------
 !  Remapping namelist variables for gridded and surface fdda to aux streams 9 and 10.
 !  Relocated here so that the remappings are after checking the namelist for inconsistencies.
@@ -1514,14 +1633,209 @@ SUBROUTINE  check_nml_consistency
          CALL wrf_message ( wrf_err_message )
       END IF
 
-      IF ( fatal_error ) THEN
-      WRITE (wrf_err_message, FMT='(A,I6, A)') 'NOTE:  ', count_fatal_error, &
+      IF ( count_fatal_error .GT. 0 ) THEN
+         WRITE (wrf_err_message, FMT='(A,I6, A)') 'NOTE:  ', count_fatal_error, &
                                             ' namelist settings are wrong. Please check and reset these options'
-                                                         
-      CALL wrf_error_fatal ( wrf_err_message )
+         CALL wrf_error_fatal (  wrf_err_message  )
       END IF
 
-   END SUBROUTINE 
+   END SUBROUTINE check_nml_consistency
+
+!=======================================================================
+
+   SUBROUTINE setup_physics_suite
+
+!
+!
+! Based on the selection of physics suite provided in the namelist, sets the
+! values of other namelist options (mp_physics, cu_physics, ra_lw_physics,
+! ra_sw_physics, bl_pbl_physics, sf_sfclay_physics, and sf_surface_physics)
+! to reflect that suite.
+!
+!
+
+      USE module_domain, ONLY : change_to_lower_case
+
+      IMPLICIT NONE
+#if ( EM_CORE == 1 )
+
+      INTEGER :: i
+      INTEGER :: max_dom
+      LOGICAL :: have_mods
+      INTEGER, DIMENSION( max_domains ) :: orig_mp_physics, orig_cu_physics, orig_ra_lw_physics, orig_ra_sw_physics, &
+                                           orig_bl_pbl_physics, orig_sf_sfclay_physics, orig_sf_surface_physics
+      CHARACTER, DIMENSION( max_domains ) :: modified_mp_option, modified_cu_option, modified_ra_lw_option, modified_ra_sw_option, &
+                                             modified_bl_pbl_option, modified_sf_sfclay_option, modified_sf_surface_option
+      CHARACTER (LEN=256) :: physics_suite_lowercase
+      CHARACTER (LEN=32) :: formatstring
+
+      max_dom = model_config_rec % max_dom
+
+      !
+      ! Save physics selections as given by the user to later determine if the
+      ! user has overridden any options
+      !
+      modified_mp_option(1:max_dom) = ' '
+      orig_mp_physics(1:max_dom) = model_config_rec % mp_physics(1:max_dom)
+
+      modified_cu_option(1:max_dom) = ' '
+      orig_cu_physics(1:max_dom) = model_config_rec % cu_physics(1:max_dom)
+
+      modified_ra_lw_option(1:max_dom) = ' '
+      orig_ra_lw_physics(1:max_dom) = model_config_rec % ra_lw_physics(1:max_dom)
+
+      modified_ra_sw_option(1:max_dom) = ' '
+      orig_ra_sw_physics(1:max_dom) = model_config_rec % ra_sw_physics(1:max_dom)
+
+      modified_bl_pbl_option(1:max_dom) = ' '
+      orig_bl_pbl_physics(1:max_dom) = model_config_rec % bl_pbl_physics(1:max_dom)
+
+      modified_sf_sfclay_option(1:max_dom) = ' '
+      orig_sf_sfclay_physics(1:max_dom) = model_config_rec % sf_sfclay_physics(1:max_dom)
+
+      modified_sf_surface_option(1:max_dom) = ' '
+      orig_sf_surface_physics(1:max_dom) = model_config_rec % sf_surface_physics(1:max_dom)
+
+      CALL change_to_lower_case(trim(model_config_rec % physics_suite), physics_suite_lowercase)
+
+      !
+      ! If physics suite is 'none', we can return early
+      !
+      IF ( trim(physics_suite_lowercase) == 'none' ) THEN
+         CALL wrf_message ('*************************************')
+         CALL wrf_message ('No physics suite selected.')
+         CALL wrf_message ('Physics options will be used directly from the namelist.')
+         CALL wrf_message ('*************************************')
+         RETURN
+      END IF
+
+      CALL wrf_message ('*************************************')
+      CALL wrf_message ('Configuring physics suite '''//trim(physics_suite_lowercase)//'''')
+      CALL wrf_message ('')
+
+      !
+      ! Set options based on the suite selection
+      !
+      SELECT CASE ( trim(physics_suite_lowercase) )
+
+      !
+      ! CONUS suite
+      !
+      CASE ('conus')
+         DO i = 1, max_dom
+
+            IF ( model_config_rec % cu_physics(i) == -1 ) model_config_rec % cu_physics(i) = TIEDTKESCHEME               ! Tiedtke
+            IF ( model_config_rec % mp_physics(i) == -1 ) model_config_rec % mp_physics(i) = THOMPSON                    ! Thompson
+            IF ( model_config_rec % ra_lw_physics(i) == -1 ) model_config_rec % ra_lw_physics(i) = RRTMG_LWSCHEME        ! RRTMG LW
+            IF ( model_config_rec % ra_sw_physics(i) == -1 ) model_config_rec % ra_sw_physics(i) = RRTMG_SWSCHEME        ! RRTMG SW
+            IF ( model_config_rec % bl_pbl_physics(i) == -1 ) model_config_rec % bl_pbl_physics(i) = MYJPBLSCHEME        ! MYJ
+            IF ( model_config_rec % sf_sfclay_physics(i) == -1 ) model_config_rec % sf_sfclay_physics(i) = MYJSFCSCHEME  ! MYJ
+            IF ( model_config_rec % sf_surface_physics(i) == -1 ) model_config_rec % sf_surface_physics(i) = LSMSCHEME   ! Noah
+
+         END DO
+
+      !
+      ! Tropical suite
+      !
+      CASE ('tropical')
+         DO i = 1, max_dom
+
+            IF ( model_config_rec % cu_physics(i) == -1 ) model_config_rec % cu_physics(i) = NTIEDTKESCHEME              ! New Tiedtke
+            IF ( model_config_rec % mp_physics(i) == -1 ) model_config_rec % mp_physics(i) = WSM6SCHEME                  ! WSM6
+            IF ( model_config_rec % ra_lw_physics(i) == -1 ) model_config_rec % ra_lw_physics(i) = RRTMG_LWSCHEME        ! RRTMG LW
+            IF ( model_config_rec % ra_sw_physics(i) == -1 ) model_config_rec % ra_sw_physics(i) = RRTMG_SWSCHEME        ! RRTMG SW
+            IF ( model_config_rec % bl_pbl_physics(i) == -1 ) model_config_rec % bl_pbl_physics(i) = YSUSCHEME           ! YSU
+            IF ( model_config_rec % sf_sfclay_physics(i) == -1 ) model_config_rec % sf_sfclay_physics(i) = SFCLAYSCHEME  ! MM5
+            IF ( model_config_rec % sf_surface_physics(i) == -1 ) model_config_rec % sf_surface_physics(i) = LSMSCHEME   ! Noah
+
+         END DO
+
+      CASE DEFAULT
+         CALL wrf_error_fatal ( 'Unrecognized physics suite' )
+
+      END SELECT
+
+      WRITE (formatstring, '(A,I3,A)') '(A21,', max_dom, '(I6,A1))'
+
+      !
+      ! Print microphysics options
+      !
+      WHERE (model_config_rec % mp_physics(1:max_dom) == orig_mp_physics(1:max_dom)) modified_mp_option(1:max_dom) = '*'
+      WRITE (wrf_err_message, FMT=TRIM(formatstring)) 'mp_physics: ', &
+                                                    (model_config_rec % mp_physics(i), modified_mp_option(i), i=1,max_dom)
+      CALL wrf_message (wrf_err_message)
+
+      !
+      ! Print cumulus options
+      !
+      WHERE (model_config_rec % cu_physics(1:max_dom) == orig_cu_physics(1:max_dom)) modified_cu_option(1:max_dom) = '*'
+      WRITE (wrf_err_message, FMT=TRIM(formatstring)) 'cu_physics: ', &
+                                                    (model_config_rec % cu_physics(i), modified_cu_option(i), i=1,max_dom)
+      CALL wrf_message (wrf_err_message)
+
+      !
+      ! Print LW radiation options
+      !
+      WHERE (model_config_rec % ra_lw_physics(1:max_dom) == orig_ra_lw_physics(1:max_dom)) modified_ra_lw_option(1:max_dom) = '*'
+      WRITE (wrf_err_message, FMT=TRIM(formatstring)) 'ra_lw_physics: ', &
+                                                    (model_config_rec % ra_lw_physics(i), modified_ra_lw_option(i), i=1,max_dom)
+      CALL wrf_message (wrf_err_message)
+
+      !
+      ! Print SW radiation options
+      !
+      WHERE (model_config_rec % ra_sw_physics(1:max_dom) == orig_ra_sw_physics(1:max_dom)) modified_ra_sw_option(1:max_dom) = '*'
+      WRITE (wrf_err_message, FMT=TRIM(formatstring)) 'ra_sw_physics: ', &
+                                                    (model_config_rec % ra_sw_physics(i), modified_ra_sw_option(i), i=1,max_dom)
+      CALL wrf_message (wrf_err_message)
+
+      !
+      ! Print boundary layer options
+      !
+      WHERE (model_config_rec % bl_pbl_physics(1:max_dom) == orig_bl_pbl_physics(1:max_dom)) modified_bl_pbl_option(1:max_dom) = '*'
+      WRITE (wrf_err_message, FMT=TRIM(formatstring)) 'bl_pbl_physics: ', &
+                                                    (model_config_rec % bl_pbl_physics(i), modified_bl_pbl_option(i), i=1,max_dom)
+      CALL wrf_message (wrf_err_message)
+
+      !
+      ! Print surface layer options
+      !
+      WHERE (model_config_rec % sf_sfclay_physics(1:max_dom) == orig_sf_sfclay_physics(1:max_dom)) &
+            modified_sf_sfclay_option(1:max_dom) = '*'
+      WRITE (wrf_err_message, FMT=TRIM(formatstring)) &
+            'sf_sfclay_physics: ', (model_config_rec % sf_sfclay_physics(i), modified_sf_sfclay_option(i), i=1,max_dom)
+      CALL wrf_message (wrf_err_message)
+
+      !
+      ! Print surface options
+      !
+      WHERE (model_config_rec % sf_surface_physics(1:max_dom) == orig_sf_surface_physics(1:max_dom)) &
+            modified_sf_surface_option(1:max_dom) = '*'
+      WRITE (wrf_err_message, FMT=TRIM(formatstring)) &
+            'sf_surface_physics: ', (model_config_rec % sf_surface_physics(i), modified_sf_surface_option(i), i=1,max_dom)
+      CALL wrf_message (wrf_err_message)
+ 
+      !
+      ! Print footnote if any physics schemes were overridden by the user
+      !
+      have_mods = ANY (modified_mp_option(1:max_dom) == '*') &
+             .OR. ANY (modified_cu_option(1:max_dom) == '*') &
+             .OR. ANY (modified_ra_lw_option(1:max_dom) == '*') &
+             .OR. ANY (modified_ra_sw_option(1:max_dom) == '*') &
+             .OR. ANY (modified_bl_pbl_option(1:max_dom) == '*') &
+             .OR. ANY (modified_sf_sfclay_option(1:max_dom) == '*') &
+             .OR. ANY (modified_sf_surface_option(1:max_dom) == '*')
+
+      IF (have_mods) THEN
+         CALL wrf_message ('')
+         CALL wrf_message ('(* = option overrides suite setting)')
+      END IF
+
+      CALL wrf_message ('*************************************')
+
+#endif
+
+   END SUBROUTINE setup_physics_suite
 
 !=======================================================================
 
diff --git a/wrfv2_fire/share/module_interp_nmm.F b/wrfv2_fire/share/module_interp_nmm.F
index e1f56fc5..8a0a5573 100644
--- a/wrfv2_fire/share/module_interp_nmm.F
+++ b/wrfv2_fire/share/module_interp_nmm.F
@@ -102,7 +102,7 @@ module module_interp_nmm
   implicit none
 
   private
-  public :: interp_T_PD_Q, find_kpres
+  public :: find_kpres
 
   public :: nmm_interp_pd, nmm_keep_pd, nmm_method_linear
 
@@ -1296,7 +1296,7 @@ subroutine n2c_massikj (&
 
              if(nk>1) then
                 cfield(i,k,j) = &
-                     NGRABIKJ(nfield,ni,nk,nj)   * weight + &
+                     NGRABIKJ(nfield,ni,nk,nj) * weight + &
 ! pjj/cray - source line limit in Cray compiler
              NGRABIKJ(nfield,ni,nk-1,nj) &
              * (1.0-weight)
@@ -1528,7 +1528,9 @@ subroutine n2c_fulldom  (                  &
     integer, dimension(nkde-1,nite-nits+1) :: iinfo
     integer :: nx,nz,k,i,a,j, istart,iend,jstart,jend, ni,nj,jprint,itest,jtest
     character*255 :: message
-    logical bad
+    logical bad, warned
+
+    warned=.false. ! allow one P>PSTD message
 
     nx=min(cide-2,cite)-max(cids+1,cits)+1
     nz=ckde-ckds+1
@@ -1574,7 +1576,7 @@ subroutine n2c_fulldom  (                  &
        call interp_T_PD_Q(nmm_method_linear, nmm_keep_pd, nx,nz, &
             deta1,deta2,eta1,eta2,ptop,pdtop, kpres, &
             inFIS,icFIS, inPINT,icPINT, inT0, icT, inPD,icPD, inQ,icQ, &
-            iinfo, winfo)
+            iinfo, winfo, warned)
 
        ! Step 3: Copy back from reordered arrays to final nest arrays:
 
@@ -1652,7 +1654,9 @@ subroutine n2c_fulldom_new (               &
     integer, dimension(kpres+1,nite-nits+1) :: iinfo
     integer :: nx,nz,k,i,a,j, istart,iend,jstart,jend, ni,nj,jprint,itest,jtest
     character*255 :: message
-    logical bad
+    logical bad, warned
+
+    warned=.false. ! Allow one P>PSTD message
 
     nx=min(cide-2,cite)-max(cids+1,cits)+1
     nz=ckde-ckds+1
@@ -1698,7 +1702,7 @@ subroutine n2c_fulldom_new (               &
        call interp_T_PD_Q_kpres(nmm_method_linear, nmm_keep_pd, nx,nz, &
             deta1,deta2,eta1,eta2,ptop,pdtop, kpres, kpres+2, &
             inFIS,icFIS, inPINT,icPINT, inT0, icT, inPD,icPD, inQ,icQ, &
-            iinfo, winfo)
+            iinfo, winfo, warned)
 
        ! Step 3: Copy back from reordered arrays to final nest arrays:
 
@@ -1800,6 +1804,9 @@ subroutine c2b_fulldom  (II,JJ,W1,W2,W3,W4,&
     real, dimension(nkde-1,2*(nite-nits+5)+2*(njte-njts+5)) :: inT,inQ,icT,icQ,winfo
     integer, dimension(nkde-1,2*(nite-nits+5)+2*(njte-njts+5)) :: iinfo
     real, dimension(nkde,2*(nite-nits+5)+2*(njte-njts+5)) :: inPINT,icPINT
+    logical :: warned
+
+    warned=.false. ! Allow one P>PSTD message
 
     nx=min(nide-1,nite)-max(nids,nits)+1
     nz=nkde-nkds+1
@@ -1879,7 +1886,7 @@ subroutine c2b_fulldom  (II,JJ,W1,W2,W3,W4,&
     call interp_T_PD_Q_kpres(nmm_method_linear, nmm_interp_pd, used,nz, &
          deta1,deta2,eta1,eta2,ptop,pdtop, kpres, nz, &
          icFIS,inFIS, icPINT,inPINT, icT, inT, icPD,inPD, icQ,inQ, &
-         iinfo, winfo)
+         iinfo, winfo, warned)
 
     used1=used
     used=0
@@ -2010,6 +2017,9 @@ subroutine c2b_fulldom_new  (II,JJ,W1,W2,W3,W4,&
     real, dimension(kpres+1,2*(nite-nits+5)+2*(njte-njts+5)) :: inT,inQ,icT,icQ,winfo
     integer, dimension(kpres+1,2*(nite-nits+5)+2*(njte-njts+5)) :: iinfo
     real, dimension(kpres+2,2*(nite-nits+5)+2*(njte-njts+5)) :: inPINT,icPINT
+    logical :: warned
+
+    warned=.false. ! Allow one P>PSTD message
 
     nx=min(nide-1,nite)-max(nids,nits)+1
     nz=nkde-nkds+1
@@ -2089,7 +2099,7 @@ subroutine c2b_fulldom_new  (II,JJ,W1,W2,W3,W4,&
     call interp_T_PD_Q_kpres(nmm_method_linear, nmm_interp_pd, used,nz, &
          deta1,deta2,eta1,eta2,ptop,pdtop, kpres, kpres+2, &
          icFIS,inFIS, icPINT,inPINT, icT, inT, icPD,inPD, icQ,inQ, &
-         iinfo, winfo)
+         iinfo, winfo, warned)
 
     used1=used
     used=0
@@ -2242,7 +2252,9 @@ subroutine c2n_fulldom  (II,JJ,W1,W2,W3,W4,&
 
     real :: pdcheck
     integer :: i,j,k,a, nx,nz,used
-    logical :: badbad
+    logical :: badbad, warned
+
+    warned=.false. ! Allow one P>PSTD message
 
     nx=min(nide-1,nite)-max(nids,nits)+1
     nz=nkde-nkds+1
@@ -2290,7 +2302,7 @@ subroutine c2n_fulldom  (II,JJ,W1,W2,W3,W4,&
           call interp_T_PD_Q(nmm_method_linear, nmm_interp_pd, used,nz, &
                deta1,deta2,eta1,eta2,ptop,pdtop,kpres, &
                icFIS,inFIS, icPINT,inPINT, icT, inT, icPD,inPD, icQ,inQ, &
-               iinfo, winfo)
+               iinfo, winfo, warned)
        endif
 
        ! Step 3: Copy back from reordered arrays to final nest arrays:
@@ -2351,7 +2363,7 @@ end subroutine c2n_fulldom
   subroutine interp_T_PD_Q(method, pd_interp, nx, nz, &
        deta1,deta2, eta1,eta2, ptop,pdtop, kpres,     &
        fisA,fisB, pintA,pintB, tA,tB, pdA,pdB, qA,qB, &
-       iinfo, winfo)
+       iinfo, winfo, warned)
     implicit none
 
     integer, intent(in) :: pd_interp,method, kpres
@@ -2371,6 +2383,7 @@ subroutine interp_T_PD_Q(method, pd_interp, nx, nz, &
     ! calls later on:
     real, intent(out) :: winfo(nz-1,nx)
     integer, intent(out) :: iinfo(nz-1,nx)
+    logical, intent(inout) :: warned
 
     ! ==================== Local variables ====================
 
@@ -2396,8 +2409,6 @@ subroutine interp_T_PD_Q(method, pd_interp, nx, nz, &
     !! Step 1: calculate near-surface values !!!!!!!!!!!!!!!!!!!!!
     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-
-
     pstd1=p_ref ! pstd(1) from base_state_parent
     ! pstd(2) from base_state_parent:
     pstd2=eta1(2)*pdtop + eta2(2)*(p_ref-pdtop-ptop) + ptop
@@ -2451,8 +2462,12 @@ subroutine interp_T_PD_Q(method, pd_interp, nx, nz, &
              ! unrealistically high.  Follow base_state_parent method:
              ! when this happens, assign input pressure to output 
              ! pressure.
-             WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
-             WRITE(0,*)'PINT(1),PD(1),PSTD(1)',pintA(1,ix),pdA(ix),p_ref
+             if(.not.warned) then
+                call wrf_message2('WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD')
+                write(message,*) 'PINT(1),PD(1),PSTD(1)',pintA(1,ix),pdA(ix),p_ref
+                call wrf_message2(message)
+                warned=.true.
+             endif
              pdB(ix)=pdA(ix)
              cycle xloop
           endif
@@ -2659,7 +2674,7 @@ end subroutine interp_T_PD_Q
   subroutine interp_T_PD_Q_kpres(method, pd_interp, nx, nz, &
        deta1,deta2, eta1,eta2, ptop,pdtop, kpres, nz2,     &
        fisA,fisB, pintA,pintB, tA,tB, pdA,pdB, qA,qB, &
-       iinfo, winfo)
+       iinfo, winfo, warned)
     implicit none
 
     integer, intent(in) :: pd_interp,method, kpres, nz2
@@ -2680,6 +2695,8 @@ subroutine interp_T_PD_Q_kpres(method, pd_interp, nx, nz, &
     real, intent(out) :: winfo(nz2-1,nx)
     integer, intent(out) :: iinfo(nz2-1,nx)
 
+    logical, intent(inout) :: warned
+
     ! ==================== Local variables ====================
 
     character*255 :: message
@@ -2759,8 +2776,12 @@ subroutine interp_T_PD_Q_kpres(method, pd_interp, nx, nz, &
              ! unrealistically high.  Follow base_state_parent method:
              ! when this happens, assign input pressure to output 
              ! pressure.
-             WRITE(0,*)'WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD'
-             WRITE(0,*)'PINT(1),PD(1),PSTD(1)',pintA(1,ix),pdA(ix),p_ref
+             if(.not.warned) then
+                call wrf_message2('WARNING: NESTED DOMAIN PRESSURE AT LOWEST LEVEL HIGHER THAN PSTD')
+                WRITE(message,*) 'PINT(1),PD(1),PSTD(1)',pintA(1,ix),pdA(ix),p_ref
+                call wrf_message2(message)
+                warned=.true.
+             endif
              pdB(ix)=pdA(ix)
              cycle xloop
           endif
diff --git a/wrfv2_fire/share/module_soil_pre.F b/wrfv2_fire/share/module_soil_pre.F
index 82158919..3be0e8c4 100644
--- a/wrfv2_fire/share/module_soil_pre.F
+++ b/wrfv2_fire/share/module_soil_pre.F
@@ -1154,6 +1154,7 @@ SUBROUTINE init_soil_depth_3 ( zs , dzs , num_soil_layers )
       INTEGER, INTENT(IN) :: num_soil_layers
 
       REAL, DIMENSION(1:num_soil_layers), INTENT(OUT)  ::  zs,dzs
+      REAL, DIMENSION(1:num_soil_layers)               ::  zs2
 
       INTEGER                   ::      l
 
@@ -1169,10 +1170,19 @@ SUBROUTINE init_soil_depth_3 ( zs , dzs , num_soil_layers )
       zs  = (/ 0.00 , 0.05 , 0.20 , 0.40 , 1.60 , 3.00 /)
      ELSEIF ( num_soil_layers .EQ. 9) THEN
       zs  = (/ 0.00 , 0.01 , 0.04 , 0.10 , 0.30, 0.60, 1.00 , 1.60, 3.00 /)
-!test3 in ppt      zs  = (/ 0.00 , 0.005 , 0.02 , 0.10 , 0.30, 0.60, 1.00 , 1.60, 3.00 /)
-!      zs  = (/ 0.00 , 0.05 , 0.20 , 0.40 , 0.60, 1.00, 1.60 , 2.20, 3.00 /)
+!     zs  = (/ 0.00 , 0.005 , 0.02 , 0.10 , 0.30, 0.60, 1.00 , 1.60, 3.00 /)
      ENDIF
 
+      zs2(1) = 0.
+      zs2(2) = (zs(2) + zs(1))*0.5
+      dzs(1) = zs2(2) - zs2(1)
+     do l = 2, num_soil_layers - 1
+      zs2(l) = (zs(l+1) + zs(l)) * 0.5
+      dzs(l) = zs2(l) - zs2(l-1)
+     enddo
+      zs2(num_soil_layers) = zs(num_soil_layers)
+      dzs(num_soil_layers) = zs2(num_soil_layers) - zs2(num_soil_layers-1)
+
       IF ( num_soil_layers .EQ. 4 .OR. num_soil_layers .EQ. 5 ) THEN
          write (message, FMT='(A)') 'The RUC LSM uses 6, 9 or more levels.  Change this in the namelist.'
          CALL wrf_error_fatal ( message )
@@ -1830,7 +1840,8 @@ SUBROUTINE init_soil_3_real ( tsk , tmn , smois , tslb , &
 
       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(IN) :: tmn
       REAL , DIMENSION(ims:ime,jms:jme) , INTENT(INOUT) :: tsk
-      REAL , DIMENSION(num_soil_layers) :: zs , dzs
+      REAL , DIMENSION(ims:ime,jms:jme) :: smtotn, smtotr, smtotn_1m, smtotr_1m
+      REAL , DIMENSION(num_soil_layers) :: zs , dzs, factorsm
 
       REAL , DIMENSION(ims:ime,num_soil_layers,jms:jme) , INTENT(OUT) :: tslb , smois
 
@@ -1910,6 +1921,18 @@ SUBROUTINE init_soil_3_real ( tsk , tmn , smois , tslb , &
          END DO innerm
       END DO outerm
 
+      if( flag_soil_levels .ne. 1) then
+           write(message, FMT='(A)') ' from Noah to RUC - compute Noah bucket'
+           CALL wrf_message ( message )
+! Compute Noah sil moisture bucket
+               DO j = jts , MIN(jde-1,jte)
+                  DO i = its , MIN(ide-1,ite)
+                  smtotn(i,j)=sm_input(i,2,j)*0.1 + sm_input(i,3,j)*0.2 + sm_input(i,4,j)*0.7 + sm_input(i,5,j)*1.
+                  smtotn_1m(i,j)=sm_input(i,2,j)*0.1 + sm_input(i,3,j)*0.2 + sm_input(i,4,j)*0.7
+                  END DO
+               END DO
+      endif
+
       IF ( flag_soil_layers == 1 ) THEN
       DO j = jts , MIN(jde-1,jte)
          DO i = its , MIN(ide-1,ite)
@@ -2031,6 +2054,65 @@ SUBROUTINE init_soil_3_real ( tsk , tmn , smois , tslb , &
       END DO z_wantm_2
 
       END IF
+
+      if( flag_soil_levels .ne. 1) then
+           write(message, FMT='(A)') ' from Noah to RUC - compute RUC bucket'
+           CALL wrf_message ( message )
+      DO j = jts , MIN(jde-1,jte)
+         DO i = its , MIN(ide-1,ite)
+               smtotr(i,j)=0.
+               smtotr_1m(i,j)=0.
+               do k=1,num_soil_layers-1 
+                  smtotr(i,j)=smtotr(i,j) + smois(i,k,j) *dzs(k)
+               enddo
+               do k=1,num_soil_layers-2
+                  smtotr_1m(i,j)=smtotr_1m(i,j) + smois(i,k,j) *dzs(k)
+               enddo
+
+        IF ( landmask(i,j) > 0.5) then
+! land
+! initialize factor
+       do k=1,num_soil_layers
+          factorsm(k)=1.
+       enddo
+! Correct RUC soil moisture to match Noah bucket
+!   print *,'1-m Buckets: RUC and Noah',i,j,smtotr_1m(i,j),0.77*smtotr_1m(i,j),smtotn_1m(i,j)
+!   print *,'Buckets: RUC and Noah',i,j,smtotr(i,j),smtotn(i,j)
+!        print *,'before smois=',i,j,smois(i,:,j)
+          do k=1,num_soil_layers-1 
+            smois(i,k,j) = max(0.02,smois(i,k,j)*smtotn(i,j)/(0.9*smtotr(i,j)))
+          enddo
+!        print *,'after smois=',i,j,smois(i,:,j)
+! Compute RUC bucket after correction
+            smtotr(i,j) = 0.
+          do k=1,num_soil_layers-1
+            smtotr(i,j)=smtotr(i,j) + smois(i,k,j) *dzs(k)
+          enddo
+!     print *,'Buckets after correction: RUC and Noah at',i,j,smtotr(i,j),smtotn(i,j)
+   if( smois(i,2,j) > smois(i,1,j) .and. smois(i,3,j) > smois(i,2,j)) then
+! typical for daytime, no recent precip
+          factorsm(1) = 0.75
+          factorsm(2) = 0.8 
+          factorsm(3) = 0.85
+          factorsm(4) = 0.9
+          factorsm(5) = 0.95
+    endif
+   do k=1,num_soil_layers-1
+      smois(i,k,j) = factorsm(k) * smois(i,k,j)
+   enddo
+
+!        print *,'1 - after smois=',i,j,smois(i,:,j)
+            smtotr(i,j) = 0.
+          do k=1,num_soil_layers-1
+            smtotr(i,j)=smtotr(i,j) + smois(i,k,j) *dzs(k)
+          enddo
+!     print *,'1 - Buckets after correction: RUC and Noah at',i,j,smtotr(i,j),smtotn(i,j)
+        ENDIF ! land
+         END DO
+      END DO
+
+      endif ! flag_soil_levels
+
       !  Over water, put in reasonable values for soil temperature and moisture.  These won't be
       !  used, but they will make a more continuous plot.
 
diff --git a/wrfv2_fire/share/module_trajectory.F b/wrfv2_fire/share/module_trajectory.F
new file mode 100644
index 00000000..ed739fa3
--- /dev/null
+++ b/wrfv2_fire/share/module_trajectory.F
@@ -0,0 +1,3053 @@
+   
+   module module_trajectory
+
+   use module_driver_constants,  only : max_domains
+#if( EM_CORE == 1 )
+   use module_state_description, only : num_chem
+#endif
+#if( NMM_CORE == 1 )
+   CONTAINS
+
+   subroutine trajectory_init( grid, config_flags, &
+                               ims,ime, jms,jme, kms,kme )
+
+   use module_domain
+   use module_configure,         only : grid_config_rec_type
+
+!-----------------------------------------------------------------------------
+!  dummy arguments
+!-----------------------------------------------------------------------------
+   integer, intent(in)      :: ims,ime, jms,jme, kms,kme
+   type(domain), intent(inout)            :: grid
+   type(grid_config_rec_type), intent(in) :: config_flags
+
+   end subroutine trajectory_init
+
+   subroutine trajectory_driver( grid )
+
+   use module_domain
+
+!-----------------------------------------------------------------------------
+!  dummy arguments
+!-----------------------------------------------------------------------------
+   type(domain), intent(in) :: grid
+
+   end subroutine trajectory_driver
+
+#elif( EM_CORE == 1 )
+
+   implicit none
+
+   private
+   public :: trajectory_init
+#ifdef NETCDF
+   public :: trajectory_driver
+   public :: trajectory_dchm_tstep_init
+   public :: trajectory_dchm_tstep_set
+#endif
+   public :: traject
+   public :: traj_cnt
+
+   integer, parameter :: vals_max = 1000
+   integer, parameter :: traj_max = 1000
+   integer, parameter :: var_max  = 100
+   integer, parameter :: pkg_max  = 6
+   integer, parameter :: dyn_max  = 8
+   integer, parameter :: chm_pkg  = 1
+   integer, parameter :: hyd_pkg  = 2
+   integer, parameter :: trc_pkg  = 3
+   integer, parameter :: dyn_pkg  = 4
+   integer, parameter :: msc_pkg  = 5
+   integer, parameter :: dchm_pkg = 6
+   real, parameter    :: missing_val = -9999.
+   real, parameter    :: zero_val    = 0.
+   
+   integer :: n_dom        ! domain count
+   integer, pointer :: n_vals                         ! wrking count of time points in buffer
+   integer, target  :: n_vals_dm(max_domains)         ! count of time points in buffer per domain
+   integer, target  :: n_dchm_dm(max_domains)         ! count of dchm variables in  buffer per domain
+   integer, allocatable, target :: num_msc_dm(:)      ! number misc species
+   integer, allocatable, target :: dchm_buf_ndx_dm(:,:)  ! dchm buffer indices
+   integer, pointer :: dchm_buf_ndx(:)
+   integer :: offset       ! into variable arrays
+
+   type default
+     character(len=19) :: start_time
+     character(len=19) :: stop_time
+     character(len=32) :: chm_name(var_max)
+     character(len=32) :: hyd_name(var_max)
+     character(len=32) :: trc_name(var_max)
+     character(len=32) :: dyn_name(var_max)
+     character(len=32) :: msc_name(var_max)
+     character(len=32) :: dchm_name(var_max)
+   end type default
+
+   type base
+     real    :: lon
+     real    :: lat
+     real    :: lev
+     real    :: x, y
+     real    :: traj_var(var_max)
+     integer :: n_chm_var
+     integer :: n_ct_var
+     integer :: n_hyd_var
+     integer :: n_trc_var
+     integer :: n_dyn_var
+     integer :: n_msc_var
+     integer :: n_dchm_var
+     integer :: chm_ndx(var_max)
+     integer :: hyd_ndx(var_max)
+     integer :: trc_ndx(var_max)
+     integer :: dyn_ndx(var_max)
+     integer :: msc_ndx(var_max)
+     integer :: dchm_ndx(var_max)
+     character(len=19) :: start_time
+     character(len=19) :: stop_time
+     character(len=32) :: chm_spc(var_max)
+     character(len=32) :: hyd_spc(var_max)
+     character(len=32) :: trc_spc(var_max)
+     character(len=32) :: dyn_var(var_max)
+     character(len=32) :: msc_var(var_max)
+     character(len=32) :: dchm_spc(var_max)
+     logical :: in_dom
+     logical :: in_patch
+     logical :: is_stationary
+     logical :: z_is_agl
+     logical :: chm_is_gas(var_max)
+   end type base
+
+   type buffer
+     real    :: trj_i(vals_max)
+     real    :: trj_j(vals_max)
+     real    :: trj_k(vals_max)
+     real    :: trj_lons(vals_max)
+     real    :: trj_lats(vals_max)
+     real, allocatable :: chm_vals(:,:)
+     real, allocatable :: trc_vals(:,:)
+     real, allocatable :: hyd_vals(:,:)
+     real, allocatable :: dyn_vals(:,:)
+     real, allocatable :: msc_vals(:,:)
+     real, allocatable :: dchm_vals(:,:)
+     character(len=19) :: times(vals_max)
+   end type buffer
+
+   type statevar
+     character(len=80) :: Varname
+     character(len=80) :: Description
+     character(len=80) :: Units
+     character(len=10) :: MemOrd
+     character(len=10) :: Stagger
+     integer           :: Ndim
+     real, pointer     :: rfield_2d(:,:)
+     real, pointer     :: rfield_3d(:,:,:)
+   end type statevar
+
+   integer,    allocatable           :: traj_cnt(:)
+   type(base), allocatable, target   :: traject(:,:)
+   type(base), pointer               :: trjects(:)
+   type(buffer), allocatable, target :: trj_buff(:,:)
+   type(buffer), pointer             :: trj_pbf(:)
+   type(statevar), allocatable, target :: St_Vars_dm(:,:)
+   type(statevar), pointer             :: St_Vars(:)
+
+   real, allocatable  :: dchm_buff(:,:,:,:)
+
+   character(len=256) :: dyn_var_lst(dyn_max)
+   character(len=32)  :: dyn_var_desc_att(dyn_max)
+   character(len=32)  :: dyn_var_unit_att(dyn_max)
+   character(len=4)   :: pkg_tag(pkg_max) = (/ 'chm ', 'hyd ', 'trc ', 'dyn ', 'msc ', 'dchm' /)
+
+   logical                      :: do_chemstep
+   logical, allocatable, target :: pkg_has_vars_dm(:,:,:)
+   logical, pointer             :: pkg_has_vars(:,:)
+   logical, allocatable, target :: trj_msk_dm(:,:,:,:)
+   logical, pointer             :: trj_msk(:,:)
+   logical, allocatable, target :: St_Vars_msk_dm(:,:)
+   logical, pointer             :: St_Vars_msk(:)
+   logical, allocatable, target :: dchm_msk_dm(:,:)
+   logical, pointer             :: dchm_msk(:)
+   logical, allocatable         :: is_initialized(:)
+   logical, allocatable         :: dm_has_traj(:)
+
+   CONTAINS
+
+   subroutine trajectory_init( grid, config_flags, &
+                               ims,ime, jms,jme, kms,kme )
+
+   use module_domain
+   use module_llxy,              only : proj_info, latlon_to_ij
+   use module_configure,         only : grid_config_rec_type
+   use module_state_description, only : no_trajectory, param_first_scalar, num_chem, num_moist, num_tracer
+   use module_scalar_tables,     only : chem_dname_table, moist_dname_table, tracer_dname_table
+   use module_model_constants,   only : g
+   use module_domain_type,       only : fieldlist
+#ifdef DM_PARALLEL
+   use module_dm,                only : wrf_dm_sum_integer, wrf_dm_max_real
+#endif
+
+!-----------------------------------------------------------------------------
+!  dummy arguments
+!-----------------------------------------------------------------------------
+   integer, intent(in)      :: ims,ime, jms,jme, kms,kme
+   type(domain), intent(inout)            :: grid
+   type(grid_config_rec_type), intent(in) :: config_flags
+
+!-----------------------------------------------------------------------------
+!  local variables
+!-----------------------------------------------------------------------------
+   integer :: astat
+   integer :: dm
+   integer, pointer :: num_msc      ! number misc species
+   integer, pointer :: n_dchm       ! number dchm buffer species
+   integer :: ierr, ios
+   integer :: i, j, k, k1, m, m1, m2
+   integer :: i_end, j_end, u_lim
+   integer :: n, pkg, trj
+   integer :: n_traj, n_traj_1
+   integer :: p_size
+   integer :: unitno
+   integer :: ids,ide, jds,jde, kds,kde
+   integer :: ips,ipe, jps,jpe, kps,kpe
+   integer :: dbg_lvl
+   integer :: target
+   integer :: n_def_var(pkg_max)
+   real    :: x, y
+   real    :: z_dm_bot, z_dm_top
+   real    :: z(kms:kme-1)
+   real    :: z_at_w(ims:ime,kms:kme,jms:jme)
+   character(len=256), allocatable :: msc_tbl(:)
+   character(len=32)  :: var_name
+   character(len=128) :: filename
+   character(len=256) :: err_mes
+   character(len=32)  :: wrk_var_name
+   character(len=32)  :: wrk_chr(var_max)
+   character(len=32)  :: wrk_def_name(var_max)
+   logical :: exists
+   logical :: is_root_proc
+   logical :: rstrt
+   logical :: mask(var_max)
+   logical :: trj_mask(traj_max)
+
+   type(grid_config_rec_type) :: config_temp
+   type(proj_info)            :: proj
+
+   type(default) :: traj_def
+   type(base)    :: traj_type(traj_max)
+
+   logical, external :: wrf_dm_on_monitor
+   integer, external :: get_unused_unit
+
+   namelist / traj_spec /    traj_type
+   namelist / traj_default / traj_def
+
+#ifndef NETCDF
+   call wrf_error_fatal( 'trajectory_init: requires netcdf' )
+#endif
+
+   offset = param_first_scalar - 1
+
+   if( .not. allocated( dm_has_traj ) ) then
+     call nl_get_max_dom( 1,n_dom )
+     allocate( dm_has_traj(n_dom),traj_cnt(n_dom),stat=astat )
+     if( astat /= 0 ) then
+       write(err_mes,'(''trajectory_init('',i2.2,''): failed to allocate dm_has_traj,traj_cnt; error = '',i6)') dm,astat
+       call wrf_error_fatal( trim( err_mes  ) )
+     endif
+     traj_cnt(:) = 0
+   endif
+
+!-----------------------------------------------------------------------------
+!  check for trajectory option
+!-----------------------------------------------------------------------------
+   if( grid%traj_opt == no_trajectory ) then
+     write(err_mes,'(''trajectory_init('',i2.2,''): traj_opt = no_trajectory'')') grid%id
+     call wrf_message( trim(err_mes) )
+     dm_has_traj(:) = .false.
+     return
+   endif
+
+!-----------------------------------------------------------------------------
+!  domain requests trajectories
+!-----------------------------------------------------------------------------
+   dm = grid%id
+   if( .not. config_flags%dm_has_traj ) then
+     write(err_mes,'(''trajectory_init('',i2.2,''): no trajectory calculation for domain '',i2.2)') dm,dm
+     call wrf_message( trim( err_mes ) )
+     dm_has_traj(dm) = .false.
+     return
+   else
+     dm_has_traj(dm) = .true.
+   endif
+
+!-----------------------------------------------------------------------------
+!  set domain count, restarting?
+!-----------------------------------------------------------------------------
+   call nl_get_restart( dm,rstrt )
+   if( .not. allocated( traject ) ) then
+!-----------------------------------------------------------------------------
+!  allocate module variables
+!-----------------------------------------------------------------------------
+     allocate( traject(traj_max,n_dom), &
+               pkg_has_vars_dm(traj_max,pkg_max,n_dom), &
+               num_msc_dm(n_dom), is_initialized(n_dom),stat=astat )
+     if( astat /= 0 ) then
+       write(err_mes,'(''trajectory_init('',i2.2,''): failed to allocate traject...num_msc_dm; error = '',i6)') dm,astat
+       call wrf_error_fatal( trim( err_mes  ) )
+     endif
+     is_initialized(:) = .false.
+   endif
+
+   if( is_initialized(dm) ) then
+     return
+   endif
+
+   trjects => traject(:,dm)
+
+   call get_ijk_from_grid( grid ,                   &
+                           ids, ide, jds, jde, kds, kde, &
+                           n,n,  n,n, n,n,          &
+                           ips, ipe, jps, jpe, kps, kpe    )
+
+   n_vals      => n_vals_dm(dm)
+   n_vals      = 0
+   is_root_proc = wrf_dm_on_monitor()
+   pkg_has_vars => pkg_has_vars_dm(:,:,dm)
+
+   dyn_var_lst(1:dyn_max)      = (/ 'p       ', 'T       ', 'z       ', 'u       ', &
+                                    'v       ', 'w       ', 'rainprod', 'evapprod' /)
+   dyn_var_unit_att(1:dyn_max) = (/ 'hPa', 'K  ', 'm  ', 'm/s', 'm/s', 'm/s', 's-1', 's-1' /)
+   dyn_var_desc_att(1:dyn_max) = (/ 'pressure            ', 'temperature         ', 'height              ', &
+                                    'x wind component    ', 'y wind component    ', 'z wind component    ', &
+                                    'rain production rate', 'rain evap rate      ' /)
+!-----------------------------------------------------------------------------
+!  master proc
+!-----------------------------------------------------------------------------
+!master_proc: &
+!   if( is_root_proc ) then
+      write(filename,'(''wrfinput_traj_d'',i2.2)',iostat=ios) dm
+      if( ios /= 0 ) then
+        write(err_mes,'(''trajectory_init('',i2.2,''): failed to set filename: error = '',i6)') dm,ios
+        call wrf_error_fatal( trim( err_mes  ) )
+      endif
+      inquire( file=trim(filename),exist=exists )
+input_file: &
+      if( exists ) then
+        unitno = get_unused_unit()
+        if( unitno <= 0 ) then
+          call wrf_error_fatal( 'trajectory_init: failed to get unit number' )
+        endif
+!-----------------------------------------------------------------------------
+!  open file
+!-----------------------------------------------------------------------------
+        open( unit = unitno,file=trim(filename),iostat=ios )
+        if( ios /= 0 ) then
+          write(err_mes,'(''trajectory_init('',i2.2,''): failed to open '',a,''; error = '',i6)') dm,trim(filename),ios
+          call wrf_error_fatal( trim( err_mes  ) )
+        endif
+!-----------------------------------------------------------------------------
+!  initialize trajectories
+!-----------------------------------------------------------------------------
+        traj_def%start_time = ' '
+        traj_def%stop_time  = ' '
+        traj_def%chm_name(:) = ' '
+        traj_def%hyd_name(:) = ' '
+        traj_def%trc_name(:) = ' '
+        traj_def%dyn_name(:) = ' '
+        traj_def%msc_name(:) = ' '
+        traj_def%dchm_name(:) = ' '
+
+        do trj = 1,traj_max
+          traj_type(trj)%start_time = ' '
+          traj_type(trj)%stop_time  = ' '
+          traj_type(trj)%chm_spc(:) = ' '
+          traj_type(trj)%dchm_spc(:) = ' '
+          traj_type(trj)%hyd_spc(:) = ' '
+          traj_type(trj)%trc_spc(:) = ' '
+          traj_type(trj)%dyn_var(:) = ' '
+          traj_type(trj)%msc_var(:) = ' '
+          traj_type(trj)%chm_ndx(:) = 0
+          traj_type(trj)%hyd_ndx(:) = 0
+          traj_type(trj)%trc_ndx(:) = 0
+          traj_type(trj)%dyn_ndx(:) = 0
+          traj_type(trj)%msc_ndx(:) = 0
+          traj_type(trj)%dchm_ndx(:) = 0
+          traj_type(trj)%n_chm_var = 0 ; traj_type(trj)%n_ct_var = 0
+          traj_type(trj)%n_hyd_var = 0 ; traj_type(trj)%n_trc_var = 0 
+          traj_type(trj)%n_dyn_var = 0 ; traj_type(trj)%n_msc_var = 0
+          traj_type(trj)%n_dchm_var = 0
+          traj_type(trj)%is_stationary = .false.
+          traj_type(trj)%chm_is_gas(:) = .true.
+          traj_type(trj)%z_is_agl      = .true.
+          traj_type(trj)%lon           = missing_val
+          traj_type(trj)%lat           = missing_val
+          traj_type(trj)%lev           = missing_val
+        end do
+!-----------------------------------------------------------------------------
+!  read file
+!-----------------------------------------------------------------------------
+        read(unit=unitno,nml=traj_default,iostat=ios)
+        if( ios /= 0 ) then
+          close( unit=unitno )
+          write(err_mes,'(''trajectory_init('',i2.2,''): failed to read '',a,''; error = '',i6)') dm,trim(filename),ios
+          call wrf_error_fatal( trim( err_mes  ) )
+        endif
+        read(unit=unitno,nml=traj_spec,iostat=ios)
+        if( ios /= 0 ) then
+          close( unit=unitno )
+          write(err_mes,'(''trajectory_init('',i2.2,''): failed to read '',a,''; error = '',i6)') dm,trim(filename),ios
+          call wrf_error_fatal( trim( err_mes  ) )
+        endif
+        close( unit=unitno )
+      else input_file
+        write(err_mes,'(''trajectory_init('',i2.2,''): no '',a,'' file'')') dm,trim(filename)
+        call wrf_message( trim( err_mes ) )
+        traj_cnt(dm) = 0
+        return
+      endif input_file
+
+!-----------------------------------------------------------------------------
+!  process the namelist input
+!-----------------------------------------------------------------------------
+      do pkg = 1,pkg_max
+        select case( trim(pkg_tag(pkg)) )
+          case( 'chm' )
+            wrk_def_name(:) = traj_def%chm_name(:)
+          case( 'dchm' )
+            wrk_def_name(:) = traj_def%dchm_name(:)
+          case( 'hyd' )
+            wrk_def_name(:) = traj_def%hyd_name(:)
+          case( 'trc' )
+            wrk_def_name(:) = traj_def%trc_name(:)
+          case( 'dyn' )
+            wrk_def_name(:) = traj_def%dyn_name(:)
+          case( 'msc' )
+            wrk_def_name(:) = traj_def%msc_name(:)
+        end select
+        do m = 1,var_max
+          if( wrk_def_name(m) == ' ' ) then
+            exit
+          endif
+        end do
+        n_def_var(pkg) = m - 1
+      end do
+
+      if( traj_def%start_time /= ' ' ) then
+        write(err_mes,'(''trajectory_init('',i2.2,''): default start time = '',a)') dm,traj_def%start_time
+        call wrf_message( trim(err_mes) )
+      endif
+      if( traj_def%stop_time /= ' ' ) then
+        write(err_mes,'(''trajectory_init('',i2.2,''): default stop  time = '',a)') dm,traj_def%stop_time
+        call wrf_message( trim(err_mes) )
+      endif
+
+      do pkg = 1,pkg_max
+        if( n_def_var(pkg) > 0 ) then
+          write(*,*) ' '
+          write(*,'(''trajectory_init('',i2.2,''): default '',a,'' variables'')') dm,pkg_tag(pkg)
+          select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+            case( 'chm' )
+              wrk_def_name(:) = traj_def%chm_name(:)
+            case( 'dchm' )
+              wrk_def_name(:) = traj_def%dchm_name(:)
+#endif
+            case( 'hyd' )
+              wrk_def_name(:) = traj_def%hyd_name(:)
+            case( 'trc' )
+              wrk_def_name(:) = traj_def%trc_name(:)
+            case( 'dyn' )
+              wrk_def_name(:) = traj_def%dyn_name(:)
+            case( 'msc' )
+              wrk_def_name(:) = traj_def%msc_name(:)
+          end select
+          write(*,*) wrk_def_name(:n_def_var(pkg))
+        endif
+      end do
+
+      do n_traj = 1,traj_max
+        if( traj_type(n_traj)%lon == missing_val .or. &
+            traj_type(n_traj)%lat == missing_val .or. &
+            traj_type(n_traj)%lev == missing_val ) then
+          exit
+        endif
+      end do
+      n_traj = n_traj - 1
+
+has_trajectories: &
+      if( n_traj > 0 ) then
+!-----------------------------------------------------------------------------
+!  set individual trajectories to default if specified
+!-----------------------------------------------------------------------------
+        if( traj_def%start_time /= ' ' ) then
+          do trj = 1,n_traj
+            if( traj_type(trj)%start_time == ' ' ) then
+              traj_type(trj)%start_time = traj_def%start_time
+            endif
+          end do
+        endif
+        if( traj_def%stop_time /= ' ' ) then
+          do trj = 1,n_traj
+            if( traj_type(trj)%stop_time == ' ' ) then
+              traj_type(trj)%stop_time = traj_def%stop_time
+            endif
+          end do
+        endif
+
+        do pkg = 1,pkg_max
+          select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+            case( 'chm' )
+              wrk_def_name(:) = traj_def%chm_name(:)
+            case( 'dchm' )
+              wrk_def_name(:) = traj_def%dchm_name(:)
+#endif
+            case( 'hyd' )
+              wrk_def_name(:) = traj_def%hyd_name(:)
+            case( 'trc' )
+              wrk_def_name(:) = traj_def%trc_name(:)
+            case( 'dyn' )
+              wrk_def_name(:) = traj_def%dyn_name(:)
+            case( 'msc' )
+              wrk_def_name(:) = traj_def%msc_name(:)
+          end select
+          do trj = 1,n_traj
+            select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+              case( 'chm' )
+                wrk_var_name = traj_type(trj)%chm_spc(1)
+              case( 'dchm' )
+                wrk_var_name = traj_type(trj)%dchm_spc(1)
+#endif
+              case( 'hyd' )
+                wrk_var_name = traj_type(trj)%hyd_spc(1)
+              case( 'trc' )
+                wrk_var_name = traj_type(trj)%trc_spc(1)
+              case( 'dyn' )
+                wrk_var_name = traj_type(trj)%dyn_var(1)
+              case( 'msc' )
+                wrk_var_name = traj_type(trj)%msc_var(1)
+            end select
+            if( wrk_var_name == ' ' ) then
+              m1 = n_def_var(pkg)
+              select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+                case( 'chm' )
+                  traj_type(trj)%chm_spc(:m1) = traj_def%chm_name(:m1)
+                case( 'dchm' )
+                  traj_type(trj)%dchm_spc(:m1) = traj_def%dchm_name(:m1)
+#endif
+                case( 'hyd' )
+                  traj_type(trj)%hyd_spc(:m1) = traj_def%hyd_name(:m1)
+                case( 'trc' )
+                  traj_type(trj)%trc_spc(:m1) = traj_def%trc_name(:m1)
+                case( 'dyn' )
+                  traj_type(trj)%dyn_var(:m1) = traj_def%dyn_name(:m1)
+                case( 'msc' )
+                  traj_type(trj)%msc_var(:m1) = traj_def%msc_name(:m1)
+              end select
+            endif
+          end do
+        end do
+!-----------------------------------------------------------------------------
+!  scan registry real, 2d, 3d variables
+!-----------------------------------------------------------------------------
+        call reg_scan( grid )
+        num_msc => num_msc_dm(dm)
+
+        call get_wrf_debug_level( dbg_lvl )
+        if( dbg_lvl > 200 ) then
+          write(*,*) ' '
+          write(*,'(''trajectory_init('',i2.2,''): Registry 2d,3d variables'')') dm
+          do n = 1,num_msc
+            write(*,*) trim(St_Vars(n)%varname)
+          end do
+          n = count( St_Vars(:num_msc)%Stagger == 'X' )
+          if( n > 0 ) then
+            write(*,*) ' '
+            write(*,*) 'Registry 2d,3d variables with staggered X'
+            do n = 1,num_msc
+              if( St_Vars(n)%Stagger == 'X' ) then
+                write(*,*) trim(St_Vars(n)%varname)
+              endif
+            end do
+          endif
+          n = count( St_Vars(:num_msc)%Stagger == 'Y' )
+          if( n > 0 ) then
+            write(*,*) ' '
+            write(*,*) 'trajectory_init: Registry 2d,3d variables with staggered Y'
+            do n = 1,num_msc
+              if( St_Vars(n)%Stagger == 'Y' ) then
+                write(*,*) trim(St_Vars(n)%varname)
+              endif
+            end do
+          endif
+          n = count( St_Vars(:num_msc)%Stagger == 'Z' )
+          if( n > 0 ) then
+            write(*,*) ' '
+            write(*,*) 'trajectory_init: Registry 2d,3d variables with staggered Z'
+            do n = 1,num_msc
+              if( St_Vars(n)%Stagger == 'Z' ) then
+                write(*,*) trim(St_Vars(n)%varname)
+              endif
+            end do
+          endif
+        endif
+!-----------------------------------------------------------------------------
+!  get variable counts
+!-----------------------------------------------------------------------------
+        do trj = 1,n_traj
+          if( num_chem > 1 ) then
+#if( WRF_CHEM == 1 )
+            call get_var_cnt( traj_type(trj)%n_chm_var, traj_type(trj)%chm_spc )
+            call get_var_cnt( traj_type(trj)%n_dchm_var, traj_type(trj)%dchm_spc )
+#endif
+          else
+            traj_type(trj)%n_chm_var  = 0
+            traj_type(trj)%n_dchm_var = 0
+          endif
+          if( num_moist > 1 ) then
+            call get_var_cnt( traj_type(trj)%n_hyd_var, traj_type(trj)%hyd_spc )
+          else
+            traj_type(trj)%n_hyd_var = 0
+          endif
+          if( num_tracer > 1 ) then
+            call get_var_cnt( traj_type(trj)%n_trc_var, traj_type(trj)%trc_spc )
+          else
+            traj_type(trj)%n_trc_var = 0
+          endif
+          if( num_msc > 1 ) then
+            call get_var_cnt( traj_type(trj)%n_msc_var, traj_type(trj)%msc_var )
+          else
+            traj_type(trj)%n_msc_var = 0
+          endif
+          call get_var_cnt( traj_type(trj)%n_dyn_var, traj_type(trj)%dyn_var )
+        end do
+
+        if( any( traj_type(:n_traj)%n_msc_var > 0 ) ) then
+          allocate( msc_tbl(num_msc),stat=astat )
+          if( astat /= 0 ) then
+            call wrf_error_fatal( 'trajectory_init: failed to find allocate msc_tbl' )
+          endif
+          do m = 1,num_msc
+            msc_tbl(m) = trim( St_Vars(m)%Varname )
+          end do
+        endif
+!-----------------------------------------------------------------------------
+!  check for trajectory variables in simulation
+!-----------------------------------------------------------------------------
+        do trj = 1,n_traj
+#if( WRF_CHEM == 1 )
+          if( num_chem > 1 ) then
+            if( traj_type(trj)%n_chm_var > 0 ) then
+              mask(:) = .false.
+              call scan_vars( traj_type(trj)%n_chm_var, traj_type(trj)%chm_spc, traj_type(trj)%chm_ndx, &
+                              num_chem, chem_dname_table(dm,:), &
+                              traj_type(trj)%chm_is_gas, 'chm' )
+            endif
+            if( traj_type(trj)%n_dchm_var > 0 ) then
+              mask(:) = .false.
+              call scan_vars( traj_type(trj)%n_dchm_var, traj_type(trj)%dchm_spc, traj_type(trj)%dchm_ndx, &
+                              num_chem, chem_dname_table(dm,:), &
+                              traj_type(trj)%chm_is_gas, 'chm' )
+            endif
+          endif
+#endif
+          if( traj_type(trj)%n_hyd_var > 0 .and. num_moist > 1 ) then
+            mask(:) = .false.
+            call scan_vars( traj_type(trj)%n_hyd_var, traj_type(trj)%hyd_spc, traj_type(trj)%hyd_ndx, &
+                            num_moist, moist_dname_table(dm,:), &
+                            traj_type(trj)%chm_is_gas, 'hyd' )
+          endif
+          if( traj_type(trj)%n_trc_var > 0 .and. num_tracer > 1 ) then
+            mask(:) = .false.
+            call scan_vars( traj_type(trj)%n_trc_var, traj_type(trj)%trc_spc, traj_type(trj)%trc_ndx, &
+                            num_tracer, tracer_dname_table(dm,:), &
+                            traj_type(trj)%chm_is_gas, 'trc' )
+          endif
+          if( traj_type(trj)%n_dyn_var > 0 ) then
+            mask(:) = .false.
+            call scan_vars( traj_type(trj)%n_dyn_var, traj_type(trj)%dyn_var, traj_type(trj)%dyn_ndx, &
+                            dyn_max, dyn_var_lst(:), &
+                            traj_type(trj)%chm_is_gas, 'dyn' )
+          endif
+          if( traj_type(trj)%n_msc_var > 0 ) then
+            mask(:) = .false.
+            call scan_vars( traj_type(trj)%n_msc_var, traj_type(trj)%msc_var, traj_type(trj)%msc_ndx, &
+                            num_msc, msc_tbl(:), &
+                            traj_type(trj)%chm_is_gas, 'msc' )
+          endif
+        end do
+
+        do trj = 1,n_traj
+          if( traj_type(trj)%n_msc_var > 0 ) then
+            do m = 1,traj_type(trj)%n_msc_var
+              St_Vars_msk(traj_type(trj)%msc_ndx(m)-offset) = .true.
+            end do
+          endif
+        end do
+        m = count( St_Vars_msk(:num_msc) )
+
+        if( allocated( msc_tbl ) ) then
+          deallocate( msc_tbl )
+        endif
+
+!-----------------------------------------------------------------------------
+!  remove trajectories with no variables
+!-----------------------------------------------------------------------------
+        n_traj_1 = count( (traj_type(:n_traj)%n_chm_var + traj_type(:n_traj)%n_hyd_var &
+                           + traj_type(:n_traj)%n_trc_var + traj_type(:n_traj)%n_dyn_var &
+                           + traj_type(:n_traj)%n_msc_var + traj_type(:n_traj)%n_dchm_var) > 0 )
+        if( n_traj_1 > 0 ) then
+          if( n_traj_1 /= n_traj ) then
+            trj_mask(1:n_traj) = traj_type(1:n_traj)%in_dom
+            m = 1
+            do trj = 1,n_traj
+              if( trj_mask(trj) ) then
+                if( trj /= m ) then
+                  traj_type(m) = traj_type(trj)
+                  m = m + 1
+                endif
+              endif
+            end do
+            n_traj = n_traj_1
+          endif
+        else
+          dm_has_traj(dm) = .false.
+          return
+        endif
+!-----------------------------------------------------------------------------
+!  allocate buffer type
+!-----------------------------------------------------------------------------
+        if( is_root_proc ) then
+          if( dm == 1 ) then
+            allocate( trj_buff(traj_max,n_dom),stat=astat )
+            if( astat /= 0 ) then
+              write(err_mes,'(''trajectory_init: failed to allocate traj_buff; error = '',i6)') astat
+              call wrf_error_fatal( trim( err_mes  ) )
+            endif
+          endif
+          trj_pbf => trj_buff(:,dm)
+        endif
+      endif has_trajectories
+!   endif master_proc
+#if( WRF_CHEM == 1 )
+!-----------------------------------------------------------------------------
+!   for dchm package make sure dchm_ndx is ordered list
+!-----------------------------------------------------------------------------
+    do trj = 1,n_traj
+      n = traj_type(trj)%n_dchm_var
+      if( n > 0 .and.  any( traj_type(trj)%dchm_ndx(1:n-1) > traj_type(trj)%dchm_ndx(2:n) ) ) then
+        trj_mask(:num_chem) = .false. 
+        do m = 1,n
+          trj_mask(traj_type(trj)%dchm_ndx(m)) = .true. 
+        end do
+        traj_type(trj)%dchm_ndx(:n) = pack( (/ (m,m=1,num_chem) /),trj_mask(:num_chem) )
+        do m = 1,n
+          m1 = traj_type(trj)%dchm_ndx(m)
+          traj_type(trj)%dchm_spc(m) = trim(chem_dname_table(dm,m1))
+        end do
+      endif
+    end do
+#endif
+!-----------------------------------------------------------------------------
+!  if initial run, overwrite existing grid trajectory variables
+!-----------------------------------------------------------------------------
+#ifdef DM_PARALLEL
+!  call wrf_dm_bcast_integer( n_traj,1 )
+!  if( n_traj > 0 ) then
+!    p_size = (5+var_max)*RWORDSIZE + (2+var_max)*LWORDSIZE &
+!           + (5+4*var_max)*IWORDSIZE + 4*32*var_max + 38
+!    do trj = 1,n_traj
+!      call wrf_dm_bcast_bytes( traj_type(trj),p_size )
+!    end do
+!  endif
+#endif
+!  call wrf_abort( 'Debugging' )
+is_cold_start: &
+   if( .not. rstrt ) then
+!-----------------------------------------------------------------------------
+!  calc and check trajectory start point
+!-----------------------------------------------------------------------------
+has_trajectories_a: &
+     if( n_traj > 0 ) then
+       config_temp = config_flags
+       call trajmapproj( grid, config_temp, proj )
+       i_end = min(ipe,ide-1)
+       j_end = min(jpe,jde-1)
+       do j = jps,j_end
+         do k = kps,kpe
+           z_at_w(ips:i_end,k,j) = (grid%ph_2(ips:i_end,k,j) + grid%phb(ips:i_end,k,j))/g
+         end do
+       end do
+!-----------------------------------------------------------------------------
+!  first check x,y
+!-----------------------------------------------------------------------------
+traj_loop: &
+       do trj = 1,n_traj
+         if( traj_type(trj)%lat /= missing_val .and. &
+             traj_type(trj)%lon /= missing_val ) then
+           call latlon_to_ij( proj, traj_type(trj)%lat, traj_type(trj)%lon, x, y )
+           traj_type(trj)%in_dom = &
+                  (x >= real(ids) .and. x <= real(ide-1) .and. &
+                   y >= real(jds) .and. y <= real(jde-1))
+#ifdef SW_DEBUG
+          write(err_mes,'(''trajectory_init('',i2.2,''): x,y = '',1p,2g15.7)') dm,x,y
+          call wrf_debug( 0,trim(err_mes) )
+#endif
+         else
+           traj_type(trj)%in_dom = .false.
+         endif
+#ifdef SW_DEBUG
+         write(err_mes,'(''trajectory_init('',i2.2,''): traj '',i4,'' in dom  = '',l)') dm,trj,traj_type(trj)%in_dom
+         call wrf_debug( 0,trim(err_mes) )
+#endif
+!-----------------------------------------------------------------------------
+!  then check z
+!-----------------------------------------------------------------------------
+is_in_domain: &
+         if( traj_type(trj)%in_dom ) then
+           i = nint( x )
+           j = nint( y )
+           traj_type(trj)%in_patch = &
+                  (i >= ips .and. i <= min(ipe,ide-1) .and. &
+                   j >= jps .and. j <= min(jpe,jde-1))
+is_in_patch: &
+           if( traj_type(trj)%in_patch ) then
+             k1 = kde - 1
+             if( traj_type(trj)%z_is_agl ) then
+               traj_type(trj)%lev = traj_type(trj)%lev + z_at_w(i,kds,j)
+             endif
+             z_dm_bot = z_at_w(i,kds,j)
+             z_dm_top = z_at_w(i,k1,j)
+             write(err_mes,'(''trajectory_init('',i2.2,''): traj '',i3.3,'' i,j,z_bot,z_top,lev = '',2i4,1p3g15.7)') &
+                dm,trj,i,j,z_dm_bot,z_dm_top,traj_type(trj)%lev
+             call wrf_debug( 0,trim(err_mes) )
+             if( traj_type(trj)%lev >= z_dm_bot .and. &
+                 traj_type(trj)%lev <= z_dm_top ) then
+               traj_type(trj)%in_dom = .true.
+               traj_type(trj)%x      = x
+               traj_type(trj)%y      = y
+             else
+               traj_type(trj)%in_dom = .false.
+             endif
+           else is_in_patch
+             traj_type(trj)%x = missing_val
+             traj_type(trj)%y = missing_val
+           endif is_in_patch
+         endif is_in_domain
+       end do traj_loop
+       n_traj_1 = count( traj_type(:n_traj)%in_dom )
+     else has_trajectories_a
+       n_traj_1 = 0
+     endif has_trajectories_a
+
+!-----------------------------------------------------------------------------
+!  remove out of domain trajectories
+!-----------------------------------------------------------------------------
+     write(err_mes,'(''trajectory_init('',i2.2,''): traj cnt = '',2i6)') dm,n_traj_1,n_traj
+     call wrf_debug( 0,trim(err_mes) )
+     if( n_traj_1 /= n_traj ) then
+       trj_mask(1:n_traj) = traj_type(1:n_traj)%in_dom
+       m = 1
+       do trj = 1,n_traj
+         if( trj_mask(trj) ) then
+           if( trj /= m ) then
+             traj_type(m) = traj_type(trj)
+             m = m + 1
+           endif
+         endif
+       end do
+       n_traj = n_traj_1
+     endif
+
+has_trajectories_b: &
+     if( n_traj_1 > 0 ) then
+       grid%traj_i(:) = missing_val
+       grid%traj_j(:) = missing_val
+       grid%traj_k(:) = missing_val
+       grid%traj_long(:) = missing_val
+       grid%traj_lat(:)  = missing_val
+!-----------------------------------------------------------------------------
+!  set initial trajectory spatial coordinates
+!-----------------------------------------------------------------------------
+       k1 = kde - 1
+       do trj = 1,n_traj
+         if( traj_type(trj)%in_patch ) then
+           grid%traj_i(trj) = traj_type(trj)%x
+           grid%traj_j(trj) = traj_type(trj)%y
+           grid%traj_long(trj) = traj_type(trj)%lon
+           grid%traj_lat(trj)  = traj_type(trj)%lat
+           i = nint( traj_type(trj)%x )
+           j = nint( traj_type(trj)%y )
+!          z(kds:k1) = .5*(z_at_w(i,kds:k1,j) + z_at_w(i,kds+1:k1+1,j))
+           z(kds:k1) = z_at_w(i,kds:k1,j)
+           do k = kds+1,k1
+             if( traj_type(trj)%lev <= z(k) ) then
+               grid%traj_k(trj) = real(k - 1) &
+                              + (traj_type(trj)%lev - z(k-1))/(z(k) - z(k-1))
+               exit
+             endif
+           end do
+           write(err_mes,'(''trajectory_init('',i2.2,''): trj,k,z(k-1:k),traj_k = '',2i3,1p3g15.7)') &
+              dm,trj,k,z(k-1:k),grid%traj_k(trj)
+           call wrf_debug( 0,trim(err_mes) )
+         endif
+       end do
+     else has_trajectories_b
+       dm_has_traj(dm) = .false.
+       return
+     endif has_trajectories_b
+   else is_cold_start
+     if( n_traj > 0 ) then
+       call set_in_dom
+     else
+       traj_cnt(dm) = n_traj
+       return
+     endif
+   endif is_cold_start
+
+!-----------------------------------------------------------------------------
+!  transfer from local variable to module variable
+!-----------------------------------------------------------------------------
+   traj_cnt(dm) = n_traj
+   do trj = 1,n_traj
+     trjects(trj) = traj_type(trj)
+   end do
+!-----------------------------------------------------------------------------
+!  create netcdf trajectory file
+!-----------------------------------------------------------------------------
+   if( .not. rstrt ) then
+     do trj = 1,n_traj
+#ifdef DM_PARALLEL
+       grid%traj_i(trj) = wrf_dm_max_real( grid%traj_i(trj) )
+       grid%traj_j(trj) = wrf_dm_max_real( grid%traj_j(trj) )
+       grid%traj_k(trj) = wrf_dm_max_real( grid%traj_k(trj) )
+       grid%traj_long(trj) = wrf_dm_max_real( grid%traj_long(trj) )
+       grid%traj_lat(trj)  = wrf_dm_max_real( grid%traj_lat(trj) )
+#else
+       grid%traj_i(trj) = grid%traj_i(trj)
+       grid%traj_j(trj) = grid%traj_j(trj)
+       grid%traj_k(trj) = grid%traj_k(trj)
+       grid%traj_long(trj) = grid%traj_long(trj)
+       grid%traj_lat(trj)  = grid%traj_lat(trj)
+#endif
+     end do
+   endif
+
+   do pkg = 1,pkg_max
+     select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+       case( 'chm' )
+         pkg_has_vars(:n_traj,pkg) = trjects(:n_traj)%n_chm_var > 0
+       case( 'dchm' )
+         pkg_has_vars(:n_traj,pkg) = trjects(:n_traj)%n_dchm_var > 0
+#endif
+       case( 'hyd' )
+         pkg_has_vars(:n_traj,pkg) = trjects(:n_traj)%n_hyd_var > 0
+       case( 'trc' )
+         pkg_has_vars(:n_traj,pkg) = trjects(:n_traj)%n_trc_var > 0
+       case( 'dyn' )
+         pkg_has_vars(:n_traj,pkg) = trjects(:n_traj)%n_dyn_var > 0
+       case( 'msc' )
+         pkg_has_vars(:n_traj,pkg) = trjects(:n_traj)%n_msc_var > 0
+     end select
+   end do
+
+#if( WRF_CHEM == 1 )
+!-----------------------------------------------------------------------------
+!  setup for  dchm buffer
+!-----------------------------------------------------------------------------
+   n_dchm_dm(dm) = 0
+   if( any( pkg_has_vars(:n_traj,dchm_pkg) ) ) then
+     if( .not. allocated( dchm_msk_dm ) ) then
+       allocate( dchm_msk_dm(num_chem,n_dom),stat=astat )
+       if( astat /= 0 ) then
+         write(err_mes,'(''trajectory_init('',i2.2,''): failed to allocate dchm_msk_dm; error = '',i6)') dm,astat
+         call wrf_error_fatal( trim( err_mes  ) )
+       endif
+     endif
+     if( .not. allocated( dchm_buf_ndx_dm ) ) then
+       allocate( dchm_buf_ndx_dm(num_chem,n_dom),stat=astat )
+       if( astat /= 0 ) then
+         write(err_mes,'(''trajectory_init('',i2.2,''): failed to allocate dchm_buf_ndx_dm; error = '',i6)') dm,astat
+         call wrf_error_fatal( trim( err_mes  ) )
+       endif
+     endif
+     n_dchm   => n_dchm_dm(dm)
+     dchm_msk => dchm_msk_dm(:,dm)
+     dchm_msk(:) = .false.
+     dchm_buf_ndx => dchm_buf_ndx_dm(:,dm)
+     dchm_buf_ndx(:) = 0
+     do trj = 1,n_traj
+       do m = 1,trjects(trj)%n_dchm_var
+         dchm_msk(trjects(trj)%dchm_ndx(m)) = .true.
+       end do
+     end do
+     n_dchm = count( dchm_msk )
+     dchm_buf_ndx(:n_dchm) = pack( (/ (m,m=1,num_chem) /),dchm_msk(:num_chem) )
+     do trj = 1,n_traj
+       if( trjects(trj)%n_dchm_var > 0 ) then
+         do m1 = 1,trjects(trj)%n_dchm_var
+           target = trjects(trj)%dchm_ndx(m1)
+           do m2 = 1,n_dchm
+             if( target == dchm_buf_ndx(m2) ) then
+               trjects(trj)%dchm_ndx(m1) = m2 + offset
+               exit
+             endif
+           end do
+         end do
+       endif
+     end do
+   endif
+#endif
+
+master_proc_a: &
+   if( is_root_proc ) then
+     if( dm == 1 ) then
+       n = max(num_chem,num_moist,num_tracer,num_msc+offset,dyn_max+offset)
+       if( n  > offset .and. .not. allocated(trj_msk_dm) ) then
+         allocate( trj_msk_dm(traj_max,n,pkg_max,n_dom),stat=astat )
+         if( astat /= 0 ) then
+           write(err_mes,'(''trajectory_init: failed to allocate trj_msk_dm; error = '',i6)') astat
+           call wrf_error_fatal( trim( err_mes  ) )
+         endif
+         trj_msk_dm(:,:,:,:) = .false.
+       endif
+     endif
+is_initial: &
+     if( .not. is_initialized(dm) ) then
+!-----------------------------------------------------------------------------
+!  allocate buffer arrays
+!-----------------------------------------------------------------------------
+trj_loop: &
+       do trj = 1,n_traj
+pkg_loop:  do pkg = 1,pkg_max
+             astat = 0
+             select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+               case( 'chm' )
+                 trj_msk => trj_msk_dm(:,:,chm_pkg,dm)
+                 m1 = trjects(trj)%n_chm_var
+                 if( m1 > 0 ) then
+                   allocate( trj_pbf(trj)%chm_vals(vals_max,m1),stat=astat)
+                   do m = 1,m1
+                     trj_msk(trj,trjects(trj)%chm_ndx(m)) = trjects(trj)%in_dom
+                   end do
+                 endif
+               case( 'dchm' )
+                 trj_msk => trj_msk_dm(:,:,dchm_pkg,dm)
+                 m1 = trjects(trj)%n_dchm_var
+                 if( m1 > 0 ) then
+                   allocate( trj_pbf(trj)%dchm_vals(vals_max,m1),stat=astat)
+                   do m = 1,m1
+                     trj_msk(trj,trjects(trj)%dchm_ndx(m)) = trjects(trj)%in_dom
+                   end do
+                 endif
+#endif
+               case( 'hyd' )
+                 trj_msk => trj_msk_dm(:,:,hyd_pkg,dm)
+                 m1 = trjects(trj)%n_hyd_var
+                 if( m1 > 0 ) then
+                   allocate( trj_pbf(trj)%hyd_vals(vals_max,m1),stat=astat)
+                   do m = 1,m1
+                     trj_msk(trj,trjects(trj)%hyd_ndx(m)) = trjects(trj)%in_dom
+                   end do
+                 endif
+               case( 'trc' )
+                 trj_msk => trj_msk_dm(:,:,trc_pkg,dm)
+                 m1 = trjects(trj)%n_trc_var
+                 if( m1 > 0 ) then
+                   allocate( trj_pbf(trj)%trc_vals(vals_max,m1),stat=astat)
+                   do m = 1,m1
+                     trj_msk(trj,trjects(trj)%trc_ndx(m)) = trjects(trj)%in_dom
+                   end do
+                 endif
+               case( 'dyn' )
+                 trj_msk => trj_msk_dm(:,:,dyn_pkg,dm)
+                 m1 = trjects(trj)%n_dyn_var
+                 if( m1 > 0 ) then
+                   allocate( trj_pbf(trj)%dyn_vals(vals_max,m1),stat=astat)
+                   do m = 1,m1
+                     trj_msk(trj,trjects(trj)%dyn_ndx(m)) = trjects(trj)%in_dom
+                   end do
+                 endif
+               case( 'msc' )
+                 trj_msk => trj_msk_dm(:,:,msc_pkg,dm)
+                 m1 = trjects(trj)%n_msc_var
+                 if( m1 > 0 ) then
+                   allocate( trj_pbf(trj)%msc_vals(vals_max,m1),stat=astat)
+                   do m = 1,m1
+                     trj_msk(trj,trjects(trj)%msc_ndx(m)) = trjects(trj)%in_dom
+                   end do
+                 endif
+             end select
+             if( astat /= 0 ) then
+               write(err_mes,'(''trajectory_init: failed to allocate buffer%'',a,''; error = '',i6)') &
+                   pkg_tag(pkg),astat
+               call wrf_error_fatal( trim( err_mes  ) )
+             endif
+           end do pkg_loop
+       end do trj_loop
+
+       do pkg = 1,pkg_max
+         select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+           case( 'chm' )
+             trj_msk => trj_msk_dm(:,:,chm_pkg,dm)
+             u_lim = num_chem
+           case( 'dchm' )
+             trj_msk => trj_msk_dm(:,:,dchm_pkg,dm)
+             u_lim = num_chem
+#endif
+           case( 'hyd' )
+             trj_msk => trj_msk_dm(:,:,hyd_pkg,dm)
+             u_lim = num_moist
+           case( 'trc' )
+             trj_msk => trj_msk_dm(:,:,trc_pkg,dm)
+             u_lim = num_tracer
+           case( 'dyn' )
+             trj_msk => trj_msk_dm(:,:,dyn_pkg,dm)
+             u_lim = dyn_max + offset
+           case( 'msc' )
+             trj_msk => trj_msk_dm(:,:,msc_pkg,dm)
+             u_lim = num_msc + offset
+         end select
+         do trj = 1,n_traj
+           trj_msk(trj,1) = any( trj_msk(trj,param_first_scalar:u_lim) )
+         end do
+       end do
+       is_initialized(dm) = .true.
+       if( .not. rstrt ) then
+         call trajectory_create_file( grid, n_traj )
+       endif
+     endif is_initial
+   endif master_proc_a
+#ifdef DM_PARALLEL
+   call wrf_dm_bcast_logical( is_initialized,n_dom )
+#endif
+
+   CONTAINS
+
+   subroutine reg_scan( grid )
+
+   use module_domain_type, only : domain, fieldlist
+
+!-----------------------------------------------------------------------------
+!  dummy arguments
+!-----------------------------------------------------------------------------
+   type(domain), intent(in) :: grid
+
+   integer, parameter :: nVerbotten = 8
+!-----------------------------------------------------------------------------
+!  local variables
+!-----------------------------------------------------------------------------
+   integer         :: astat
+   integer         :: cnt
+   integer         :: dm, dm_ndx
+   integer         :: m, n
+   type(fieldlist), pointer :: p
+   logical         :: valid
+   type(statevar), allocatable :: St_Vars_wrk(:,:)
+   logical, allocatable :: St_Vars_msk_wrk(:,:)
+   character(len=80) :: tstring
+   character(len=9) :: Verbotten(nVerbotten) = (/ 'zx       ', 'zy       ', &
+                                                  'RUNDGTEN ', 'RVNDGTEN ', &
+                                                  'U_NDG_OLD', 'V_NDG_OLD', &
+                                                  'U_NDG_NEW', 'V_NDG_NEW'/)
+
+!-----------------------------------------------------------------------------
+!  just get the count
+!-----------------------------------------------------------------------------
+   dm = grid%id
+   p => grid%head_statevars%next ; cnt = 0
+   do while( associated(p) )
+     valid = (p%Type == 'R' .or. p%Type == 'r') .and. &
+             (p%Ndim == 3 .or. (p%Ndim == 4 .and. p%scalar_array))
+     if( valid ) then
+       valid = p%MemoryOrder(:3) == 'XZY' .and. (p%em2 == kde-1 .or. p%em2 == kde)
+       if( valid ) then
+         if( p%Ndim == 3 ) then
+           do m = 1,nVerbotten
+             if( trim(Verbotten(m)) == trim(p%Varname) ) then
+               valid = .false.
+               exit
+             endif
+           enddo
+           if( valid ) then
+             cnt = cnt + 1
+           endif
+         elseif( p%Ndim == 4 ) then
+           do n = param_first_scalar,p%num_table(dm)
+             valid = .true.
+             do m = 1,nVerbotten
+               tstring = trim(Verbotten(m))
+               call upcase( tstring )
+               if( trim(tstring) == trim(p%dname_table(dm,n)) ) then
+                 valid = .false.
+                 exit
+               endif
+             enddo
+             if( valid ) then
+               cnt = cnt + 1
+             endif
+           enddo
+         endif
+       endif
+     endif
+     p => p%next
+   end do
+
+   write(*,'(''reg_scan('',i2.2,''): found '',i4,'' state variables '')') dm,cnt
+
+!-----------------------------------------------------------------------------
+!  now allocate and set St_Vars
+!-----------------------------------------------------------------------------
+   num_msc_dm(dm) = cnt
+   if( cnt > 0 ) then
+     if( .not. allocated( St_Vars_dm ) ) then
+       allocate( St_Vars_dm(cnt,n_dom),St_Vars_msk_dm(cnt,n_dom),stat=astat )
+       if( astat /= 0 ) then
+         call wrf_error_fatal( 'reg_scan: failed to allocate St_Vars,St_Vars_msk' )
+       endif
+     elseif( cnt > maxval(num_msc_dm(1:dm-1)) ) then
+       n = size( St_vars_dm,dim=1 )
+       allocate( St_Vars_wrk(n,dm-1),St_Vars_msk_wrk(n,dm-1),stat=astat )
+       if( astat /= 0 ) then
+         call wrf_error_fatal( 'reg_scan: failed to allocate St_Vars,St_Vars_msk wrk arrays' )
+       endif
+       do dm_ndx = 1,dm-1
+         do m = 1,n
+           St_Vars_wrk(m,dm_ndx) = St_Vars_dm(m,dm_ndx)
+           St_Vars_msk_wrk(m,dm_ndx) = St_Vars_msk_dm(m,dm_ndx)
+         end do
+       end do
+       deallocate( St_vars_dm,St_Vars_msk_dm )
+       allocate( St_Vars_dm(cnt,n_dom),St_Vars_msk_dm(cnt,n_dom),stat=astat )
+       if( astat /= 0 ) then
+         call wrf_error_fatal( 'reg_scan: failed to allocate St_Vars,St_Vars_msk' )
+       endif
+       do dm_ndx = 1,dm-1
+         do m = 1,n
+           St_Vars_dm(m,dm_ndx) = St_Vars_wrk(m,dm_ndx)
+           St_Vars_msk_dm(m,dm_ndx) = St_Vars_msk_wrk(m,dm_ndx)
+         end do
+       end do
+       deallocate( St_vars_wrk,St_Vars_msk_wrk )
+     endif
+
+     St_Vars     => St_Vars_dm(:,dm)
+     St_Vars_msk => St_Vars_msk_dm(:,dm)
+
+     St_Vars_msk(:cnt) = .false.
+     p => grid%head_statevars%next ; cnt = 0
+
+     do while( associated(p) )
+       valid = (p%Type == 'R' .or. p%Type == 'r') .and. &
+               (p%Ndim == 3 .or. (p%Ndim == 4 .and. p%scalar_array))
+       if( valid ) then
+         valid = p%MemoryOrder(:3) == 'XZY' .and. (p%em2 == kde-1 .or. p%em2 == kde)
+         if( valid ) then
+           if( p%Ndim == 3 ) then
+             do m = 1,nVerbotten
+               if( trim(Verbotten(m)) == trim(p%Varname) ) then
+                 valid = .false.
+                 exit
+               endif
+             enddo
+             if( valid ) then
+               cnt = cnt + 1
+               St_Vars(cnt)%Varname = p%Varname 
+               St_Vars(cnt)%Description = p%Description 
+               St_Vars(cnt)%Units   = p%Units 
+               St_Vars(cnt)%MemOrd  = p%MemoryOrder 
+               St_Vars(cnt)%Stagger = p%Stagger
+               St_Vars(cnt)%Ndim = p%Ndim 
+               St_Vars(cnt)%rfield_3d => p%rfield_3d
+             endif
+           elseif( p%Ndim == 4 ) then
+             do n = param_first_scalar,p%num_table(dm)
+               valid = .true.
+               do m = 1,nVerbotten
+                 tstring = trim(Verbotten(m))
+                 call upcase( tstring )
+                 if( trim(tstring) == trim(p%dname_table(dm,n)) ) then
+                   valid = .false.
+                   exit
+                 endif
+               enddo
+               if( valid ) then
+                 cnt = cnt + 1
+                 St_Vars(cnt)%Varname = trim(p%dname_table(dm,n))
+                 St_Vars(cnt)%Description = p%Description 
+                 St_Vars(cnt)%Units   = p%Units 
+                 St_Vars(cnt)%MemOrd  = p%MemoryOrder 
+                 St_Vars(cnt)%Stagger = p%Stagger
+                 St_Vars(cnt)%Ndim = 3
+                 St_Vars(cnt)%rfield_3d => p%rfield_4d(:,:,:,p%index_table(n,dm))
+               endif
+             enddo
+           endif
+         endif
+       endif
+       p => p%next
+     end do
+   endif
+
+   end subroutine reg_scan
+
+   subroutine get_var_cnt( n_vars, vars )
+
+!-----------------------------------------------------------------------------
+!  dummy arguments
+!-----------------------------------------------------------------------------
+   integer, intent(inout) :: n_vars
+   character(len=32), intent(inout)  :: vars(:)
+
+   mask(:) = vars(:) /= ' '
+   wrk_chr(:) = ' '
+   m1 = 0
+   do n = 1,var_max
+     if( mask(n) ) then
+       m1 = m1 + 1
+       wrk_chr(m1) = vars(n)
+     endif
+   end do
+
+   n_vars  = count( wrk_chr(:) /= ' ' )
+   vars(:) = wrk_chr(:)
+
+   end subroutine get_var_cnt
+
+   subroutine scan_vars( n_vars, vars, var_ndx, n_tbl, tbl, &
+                         is_gas, var_type )
+
+!-----------------------------------------------------------------------------
+!  dummy arguments
+!-----------------------------------------------------------------------------
+   integer, intent(inout) :: n_vars
+   integer, intent(in)    :: n_tbl
+   integer, intent(inout) :: var_ndx(:)
+   logical, intent(inout) :: is_gas(:)
+   character(len=*), intent(in)      :: var_type
+   character(len=32), intent(inout)  :: vars(:)
+   character(len=256), intent(in)    :: tbl(:)
+
+!-----------------------------------------------------------------------------
+!  local variables
+!-----------------------------------------------------------------------------
+   integer :: ml
+   integer :: ndx(var_max)
+
+var_loop: &
+   do n = 1,n_vars
+     var_name = vars(n)
+     if( trim(var_type) == 'chm' ) then
+       i = index( '(a)', var_name )
+       if( i == 0 ) then
+         i = index( '(A)', var_name )
+       endif
+       if( i > 0 ) then
+         is_gas(n) = .false.
+         var_name(i:) = ' '
+         vars(n)(i:)  = ' '
+       endif
+     endif
+     if( trim(var_type) == 'dyn' .or. trim(var_type) == 'msc' ) then
+       ml = 1
+     else
+       ml = param_first_scalar
+     endif
+!    if( trim(var_type) /= 'dyn' ) then
+!      ml = param_first_scalar
+!    else
+!      ml = 1
+!    endif
+     do m1 = ml,n_tbl
+       if( trim(var_name) == trim(tbl(m1)) ) then
+         mask(n) = .true.
+         ndx(n)  = m1
+         exit
+       endif 
+     end do
+     if( .not. mask(n) ) then
+       write(err_mes,'(''scan_vars('',i2.2,''): '',a,'' not in '',a,'' opt'')') dm,trim(var_name),var_type
+       call wrf_message( trim(err_mes) )
+     endif
+   end do var_loop
+
+   if( trim(var_type) == 'dyn' .or. trim(var_type) == 'msc' ) then
+     ndx(1:n_vars) = ndx(1:n_vars) + offset
+   endif
+
+   wrk_chr(:) = ' '
+   m1 = 0
+   do n = 1,var_max
+     if( mask(n) ) then
+       m1 = m1 + 1
+       wrk_chr(m1) = vars(n)
+     endif
+   end do
+
+   var_ndx(:count(mask)) = pack( ndx(:),mask=mask)
+   vars(:) = wrk_chr(:)
+   n_vars  = count( mask )
+
+   end subroutine scan_vars
+
+   subroutine set_in_dom
+
+!-----------------------------------------------------------------------------
+!  local variables
+!-----------------------------------------------------------------------------
+   integer :: ncid
+   integer :: ios
+   integer :: time_id
+   integer :: varid
+   integer :: time_ndx
+
+   real    :: traj_i(n_traj)
+   real    :: traj_j(n_traj)
+   real    :: traj_k(n_traj)
+
+   character(len=256) :: err_mes
+   character(len=256) :: filename
+
+include 'netcdf.inc'
+
+!---------------------------------------------------------------------
+!  open netcdf file
+!---------------------------------------------------------------------
+   write(filename,'(''wrfout_traj_d'',i2.2)',iostat=ios) dm
+   if( ios /= 0 ) then
+     write(err_mes,'(''set_in_dom: failed to set filename: error = '',i6)') ios
+     call wrf_error_fatal( trim( err_mes  ) )
+   endif
+   ios = nf_open( trim(filename), nf_nowrite, ncid )
+   if( ios /= 0 ) then
+     write(err_mes,'(''set_in_dom: failed to open '',a,'': error = '',i6)') trim(filename),ios
+     call wrf_error_fatal( trim( err_mes  ) )
+   endif
+
+!---------------------------------------------------------------------
+!  get current time index
+!---------------------------------------------------------------------
+   err_mes = 'set_in_dom: failed to get time id'
+   call handle_ncerr( nf_inq_dimid( ncid, 'time', time_id ),trim(err_mes) )
+   err_mes = 'set_in_dom: failed to get time dimension'
+   call handle_ncerr( nf_inq_dimlen( ncid, time_id, time_ndx ),trim(err_mes) )
+
+!---------------------------------------------------------------------
+!  read in last traj_{i,j,k} variables
+!---------------------------------------------------------------------
+   err_mes = 'set_in_dom: failed to get traj_i id'
+   call handle_ncerr( nf_inq_varid( ncid, 'traj_i', varid ),trim(err_mes) )
+   err_mes = 'set_in_dom: failed to get traj_i'
+   call handle_ncerr( nf_get_vara_real( ncid, varid, (/ 1,time_ndx /), (/ n_traj,1 /), &
+                                        traj_i ),trim(err_mes) )
+   err_mes = 'set_in_dom: failed to get traj_j id'
+   call handle_ncerr( nf_inq_varid( ncid, 'traj_j', varid ),trim(err_mes) )
+   err_mes = 'set_in_dom: failed to get traj_j'
+   call handle_ncerr( nf_get_vara_real( ncid, varid, (/ 1,time_ndx /), (/ n_traj,1 /), &
+                                        traj_j ),trim(err_mes) )
+   err_mes = 'set_in_dom: failed to get traj_k id'
+   call handle_ncerr( nf_inq_varid( ncid, 'traj_k', varid ),trim(err_mes) )
+   err_mes = 'set_in_dom: failed to get traj_k'
+   call handle_ncerr( nf_get_vara_real( ncid, varid, (/ 1,time_ndx /), (/ n_traj,1 /), &
+                                        traj_k ),trim(err_mes) )
+   traj_type(1:n_traj)%in_dom = traj_i(1:n_traj) /= missing_val .and.  traj_j(1:n_traj) /= missing_val &
+                                                                .and.  traj_k(1:n_traj) /= missing_val
+
+   ios = nf_close( ncid )
+
+   end subroutine set_in_dom
+
+   end subroutine trajectory_init
+
+#ifdef NETCDF
+   subroutine trajectory_driver( grid )
+
+#ifdef DM_PARALLEL
+   use module_dm, only : &
+                  local_communicator, mytask, ntasks, ntasks_x, ntasks_y                   &
+                 ,local_communicator_periodic, wrf_dm_max_real, wrf_dm_max_int
+   use module_comm_dm, only : halo_em_chem_e_3_sub, halo_em_moist_e_3_sub
+   use module_comm_dm, only : halo_em_tracer_e_3_sub
+#endif
+   use module_domain
+   use module_date_time
+   use module_state_description, only : num_chem
+   use module_state_description, only : num_moist, num_tracer, param_first_scalar
+
+!-----------------------------------------------------------------------------
+!  dummy arguments
+!-----------------------------------------------------------------------------
+   type(domain), intent(in) :: grid
+
+!-----------------------------------------------------------------------------
+!  local variables
+!-----------------------------------------------------------------------------
+   integer :: ims,ime, jms,jme, kms,kme
+   integer :: ids,ide, jds,jde, kds,kde
+   integer :: ips,ipe, jps,jpe, kps,kpe
+   integer :: dm
+   integer :: j, k
+   integer :: il, iu, ios, jl, ju, kl, ku
+   integer :: m, mu, n, ndx, n_vars, n_traj
+   integer :: pkg_var_cnt(traj_max)
+   integer :: ncid
+   integer :: pkg, trj
+   integer :: n_msc_buf
+   integer :: num_chem_sav
+   integer, pointer :: num_msc      ! number misc species
+   integer, pointer :: n_dchm       ! number dchm buffer species
+   integer, pointer :: dchm_buf_ndx(:)
+   integer :: St_Vars_ndx
+   integer, allocatable :: St_Vars_buf_ndx(:)
+#ifndef DM_PARALLEL
+   integer :: mytask
+#endif
+   integer :: traj_proc(traj_max), glb_traj_proc(traj_max)
+   real :: dchm_fill_val(traj_max)
+   real :: x, y, zi
+   real :: delsx, delsy, o_delsx, o_delsy
+   real :: delsz, o_delsz
+   real :: max_conc
+   real :: horz_conc(2)
+   real, pointer :: traj_conc(:)
+   real, target  :: traj_val(var_max,traj_max)
+   real, pointer :: wrk4d(:,:,:,:)
+   real, allocatable, target :: chem(:,:,:,:)
+   real, allocatable, target :: moist(:,:,:,:)
+   real, allocatable, target :: tracer(:,:,:,:)
+   character(len=19)  :: current_timestr, next_timestr
+   character(len=32)  :: var_name(var_max)
+   character(len=256) :: err_mes
+   logical :: has_dchm
+   logical :: is_root_proc
+   logical :: is_in_patch_gap
+   logical :: flsh_buff
+   logical :: found
+   logical :: traj_is_active(traj_max)
+   logical :: pkg_is_active(traj_max,pkg_max)
+   logical, pointer :: pkg_has_vars(:,:)
+
+   logical, external :: wrf_dm_on_monitor
+
+   type(WRFU_Time) :: current_time, next_time
+   type(WRFU_Time) :: start_time, stop_time
+
+include 'netcdf.inc'
+
+#ifndef DM_PARALLEL
+   mytask = 0
+#endif
+   dm = grid%id
+   n_traj = traj_cnt(dm)
+has_trajectories: &
+   if( dm_has_traj(dm) .and. n_traj > 0 ) then
+     St_Vars => St_Vars_dm(:,dm)
+     St_Vars_msk => St_Vars_msk_dm(:,dm)
+     num_msc => num_msc_dm(dm)
+     trjects => traject(:,dm)
+     n_vals  => n_vals_dm(dm)
+     is_root_proc = wrf_dm_on_monitor()
+     if( is_root_proc ) then
+       trj_pbf => trj_buff(:,dm)
+     endif
+     has_dchm = any( trjects(:n_traj)%n_dchm_var > 0 )
+     if( has_dchm ) then
+       n_dchm => n_dchm_dm(dm)
+       dchm_buf_ndx => dchm_buf_ndx_dm(:,dm)
+     endif
+
+     call get_ijk_from_grid( grid ,                   &
+                             ids, ide, jds, jde, kds, kde,    &
+                             ims, ime, jms, jme, kms, kme,    &
+                             ips, ipe, jps, jpe, kps, kpe    )
+
+!-----------------------------------------------------------------------------
+!  is trajectory in time interval?
+!-----------------------------------------------------------------------------
+     call domain_clock_get( grid, current_time=current_time, current_timestr=current_timestr)
+     call geth_newdate( next_timestr, current_timestr, int(grid%dt) )
+     call wrf_atotime( next_timestr(1:19), next_time )
+     do trj = 1,n_traj
+       call wrf_atotime( traject(trj,dm)%start_time(1:19), start_time )
+       call wrf_atotime( traject(trj,dm)%stop_time(1:19), stop_time )
+       traj_is_active(trj) = next_time .ge. start_time .and. next_time .le. stop_time
+     end do
+!-----------------------------------------------------------------------------
+!  is trajectory in domain?
+!-----------------------------------------------------------------------------
+     pkg_has_vars => pkg_has_vars_dm(:,:,dm)
+     do trj = 1,n_traj
+       if( traj_is_active(trj) ) then
+         trjects(trj)%in_dom = grid%traj_i(trj) >= real(ids) .and. grid%traj_i(trj) <= real(ide-1)
+         if( trjects(trj)%in_dom ) then
+           trjects(trj)%in_dom = grid%traj_j(trj) >= real(jds) .and. grid%traj_j(trj) <= real(jde-1)
+         endif
+         if( trjects(trj)%in_dom ) then
+           trjects(trj)%in_dom = grid%traj_k(trj) >= real(kps) .and. grid%traj_k(trj) <= real( min( kpe,kde-1 ) )
+         endif
+         traj_is_active(trj) = trjects(trj)%in_dom
+       endif
+     end do
+     do pkg = 1,pkg_max
+       pkg_is_active(:n_traj,pkg) = traj_is_active(:n_traj) .and. pkg_has_vars(:n_traj,pkg)
+     end do
+!-----------------------------------------------------------------------------
+!  check whether this is a chemistry time step
+!-----------------------------------------------------------------------------
+     dchm_fill_val(:n_traj) = missing_val
+     if( .not. do_chemstep ) then
+       do trj = 1,n_traj
+         if( pkg_is_active(trj,dchm_pkg) ) then
+           dchm_fill_val(trj) = zero_val
+         endif
+       end do
+       pkg_is_active(:n_traj,dchm_pkg) = .false.
+     endif
+!-----------------------------------------------------------------------------
+!  is trajectory in mpi process?
+!-----------------------------------------------------------------------------
+     traj_proc(:n_traj) = -1
+     do trj = 1,n_traj
+       if( traj_is_active(trj) ) then
+         trjects(trj)%in_patch = grid%traj_i(trj) >= real(ips) .and. grid%traj_i(trj) <= real( min( ipe,ide-1 ) )
+         if( trjects(trj)%in_patch ) then
+           trjects(trj)%in_patch = grid%traj_j(trj) >= real(jps) .and. grid%traj_j(trj) <= real( min( jpe,jde-1 ) )
+         endif
+         if( trjects(trj)%in_patch ) then
+           trjects(trj)%in_patch = grid%traj_k(trj) >= real(kps) .and. grid%traj_k(trj) <= real( min( kpe,kde-1 ) )
+         endif
+         if( trjects(trj)%in_patch ) then
+           traj_proc(trj) = mytask + 1
+         else
+           traj_proc(trj) = 0
+         endif
+       endif
+     end do
+#ifdef DM_PARALLEL
+     do trj = 1,n_traj
+       glb_traj_proc(trj) = wrf_dm_max_int( traj_proc(trj) )
+     end do
+#else
+     glb_traj_proc(1:n_traj) = traj_proc(1:n_traj)
+#endif
+!-----------------------------------------------------------------------------
+!  any trajectories in "gap" between patches?
+!-----------------------------------------------------------------------------
+     do trj = 1,n_traj
+       if( traj_is_active(trj) .and. glb_traj_proc(trj) == 0 ) then
+         trjects(trj)%in_patch = grid%traj_i(trj) >= real(ips) .and. grid%traj_i(trj) <= real( min( ipe+1,ide-1 ) )
+         if( trjects(trj)%in_patch ) then
+           trjects(trj)%in_patch = grid%traj_j(trj) >= real(jps) .and. grid%traj_j(trj) <= real( min( jpe+1,jde-1 ) )
+         endif
+         if( trjects(trj)%in_patch ) then
+           trjects(trj)%in_patch = grid%traj_k(trj) >= real(kps) .and. grid%traj_k(trj) <= real( min( kme,kde-1 ) )
+         endif
+         if( trjects(trj)%in_patch ) then
+           traj_proc(trj) = mytask + 1
+         else
+           traj_proc(trj) = 0
+         endif
+         if( traj_proc(trj) /= 0 ) then
+           call wrf_debug( 0,'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^')
+           write(err_mes,'(''Gapper '',i5,''; x,y,zi = '',1p,3g15.7)') trj,grid%traj_i(trj),grid%traj_j(trj),grid%traj_k(trj)
+           call wrf_debug( 0,trim(err_mes) )
+           write(err_mes,'(''Gapper ips,ipe,jps,jpe = '',4i5)') ips,ipe,jps,jpe
+           call wrf_debug( 0,trim(err_mes) )
+           call wrf_debug( 0,'^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^')
+         endif
+       endif
+     end do
+
+!-----------------------------------------------------------------------------
+!  buffer traj time and position
+!-----------------------------------------------------------------------------
+     if( is_root_proc ) then
+       n_vals = n_vals + 1
+       if( grid%itimestep > 0 ) then
+         trj_pbf(:n_traj)%times(n_vals) = next_timestr
+       else
+         trj_pbf(:n_traj)%times(n_vals) = current_timestr
+       endif
+       do trj = 1,n_traj
+         trj_pbf(trj)%trj_i(n_vals) = grid%traj_i(trj)
+         trj_pbf(trj)%trj_j(n_vals) = grid%traj_j(trj)
+         trj_pbf(trj)%trj_k(n_vals) = grid%traj_k(trj)
+         trj_pbf(trj)%trj_lons(n_vals) = grid%traj_long(trj)
+         trj_pbf(trj)%trj_lats(n_vals) = grid%traj_lat(trj)
+       end do
+     endif
+
+     do trj = 1,n_traj
+       traj_val(:,trj) = missing_val
+     end do
+
+pkg_loop: &
+     do pkg = 1,pkg_max 
+pkg_has_active_traj: &
+       if( any( pkg_is_active(:n_traj,pkg) ) ) then
+!-----------------------------------------------------------------------------
+!  allocate working data array
+!-----------------------------------------------------------------------------
+         select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+           case( 'chm' )
+             allocate( chem(ims:ime,kms:kme,jms:jme,num_chem),stat=ios )
+           case( 'dchm' )
+             if( n_dchm > 0 ) then
+               allocate( chem(ims:ime,kms:kme,jms:jme,n_dchm+offset),stat=ios )
+             endif
+#endif
+           case( 'hyd' )
+             allocate( moist(ims:ime,kms:kme,jms:jme,num_moist),stat=ios )
+           case( 'trc' )
+             allocate( tracer(ims:ime,kms:kme,jms:jme,num_tracer),stat=ios )
+           case( 'dyn' )
+             allocate( chem(ims:ime,kms:kme,jms:jme,dyn_max+offset+2),stat=ios )
+           case( 'msc' )
+             m = count( St_Vars_msk(:num_msc) )
+             if( m > 0 ) then
+               allocate( chem(ims:ime,kms:kme,jms:jme,m+offset), &
+                         St_Vars_buf_ndx(m+offset),stat=ios )
+             endif
+           case default
+             ios = 0
+         end select
+         if( ios /= 0 ) then
+           write(err_mes,'(''trajectory_driver: failed to allocate wrk4d: error = '',i6)') ios
+           call wrf_error_fatal( trim( err_mes  ) )
+         endif
+         select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+           case( 'chm' )
+             do m = 1,num_chem
+               do j = jps,jpe
+                 do k = kps,kpe
+                   chem(ips:ipe,k,j,m) = grid%chem(ips:ipe,k,j,m)
+                 end do
+               end do
+             end do
+           case( 'dchm' )
+             do m = param_first_scalar,n_dchm+offset
+               do j = jps,jpe
+                 do k = kps,kpe
+                   chem(ips:ipe,k,j,m) = dchm_buff(ips:ipe,k,j,m)
+                 end do
+               end do
+             end do
+#endif
+           case( 'hyd' )
+             do m = 1,num_moist
+               do j = jps,jpe
+                 do k = kps,kpe
+                   moist(ips:ipe,k,j,m) = grid%moist(ips:ipe,k,j,m)
+                 end do
+               end do
+             end do
+           case( 'trc' )
+             do m = 1,num_tracer
+               do j = jps,jpe
+                 do k = kps,kpe
+                   tracer(ips:ipe,k,j,m) = grid%tracer(ips:ipe,k,j,m)
+                 end do
+               end do
+             end do
+           case( 'dyn' )
+             call pack_dyn_vals
+           case( 'msc' )
+             n_msc_buf = 1
+             do m = 1,num_msc
+               if( St_Vars_msk(m) ) then
+                 n_msc_buf = n_msc_buf + 1
+                 St_Vars_buf_ndx(n_msc_buf) = m
+                 do j = jps,jpe
+                   do k = kps,kpe
+                     chem(ips:ipe,k,j,n_msc_buf) = St_Vars(m)%rfield_3d(ips:ipe,k,j)
+                   end do
+                 end do
+               endif
+             end do
+         end select
+#ifdef DM_PARALLEL
+!-----------------------------------------------------------------------------
+!  any trajectories in "gap" between patches?
+!-----------------------------------------------------------------------------
+             is_in_patch_gap = any( glb_traj_proc(:n_traj) == 0 .and. pkg_is_active(:n_traj,pkg) )
+             if( is_in_patch_gap ) then
+!              write(err_mes,'(''glb_traj_proc mask = '',10i5)') glb_traj_proc(:n_traj)
+!              call wrf_debug( 0,trim(err_mes) )
+               select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+                 case( 'chm' )
+#      include "HALO_EM_CHEM_E_3.inc"
+                 case( 'dchm' )
+                   num_chem_sav = num_chem
+                   num_chem     = n_dchm
+#      include "HALO_EM_CHEM_E_3.inc"
+                   num_chem = num_chem_sav
+#endif
+                 case( 'hyd' )
+#      include "HALO_EM_MOIST_E_3.inc"
+                 case( 'trc' )
+#      include "HALO_EM_TRACER_E_3.inc"
+                 case( 'dyn' )
+                   num_chem_sav = num_chem
+                   num_chem     = dyn_max + offset + 2
+#      include "HALO_EM_CHEM_E_3.inc"
+                   num_chem = num_chem_sav
+                 case( 'msc' )
+                   num_chem_sav = num_chem
+                   num_chem     = n_msc_buf
+#      include "HALO_EM_CHEM_E_3.inc"
+                   num_chem = num_chem_sav
+               end select
+             endif
+#endif
+
+traj_loop: &
+         do trj = 1,n_traj
+           select case( trim(pkg_tag(pkg)) )
+             case( 'chm' )
+               n_vars = traject(trj,dm)%n_chm_var
+             case( 'hyd' )
+               n_vars = traject(trj,dm)%n_hyd_var
+             case( 'trc' )
+               n_vars = traject(trj,dm)%n_trc_var
+             case( 'dyn' )
+               n_vars = traject(trj,dm)%n_dyn_var
+             case( 'msc' )
+               n_vars = traject(trj,dm)%n_msc_var
+             case( 'dchm' )
+               n_vars = traject(trj,dm)%n_dchm_var
+           end select
+pkg_is_active_in_traj: &
+           if( pkg_is_active(trj,pkg) ) then
+             select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+               case( 'chm', 'dchm' )
+                 wrk4d => chem
+#endif
+               case( 'dyn', 'msc' )
+                 wrk4d => chem
+               case( 'hyd' )
+                 wrk4d => moist
+               case( 'trc' )
+                 wrk4d => tracer
+             end select
+in_patch:    if( traj_proc(trj) == mytask+1 ) then
+               x = grid%traj_i(trj)
+               y = grid%traj_j(trj)
+               zi = grid%traj_k(trj)
+               il = int( x ) ; iu = il + 1
+               jl = int( y ) ; ju = jl + 1
+               kl = int( zi ) ; ku = kl + 1
+               delsx = x - floor(x) ; o_delsx = 1. - delsx
+               delsy = y - floor(y) ; o_delsy = 1. - delsy
+               delsz = zi - floor(zi) ; o_delsz = 1. - delsz
+var_loop:      do n = 1,n_vars
+                 found = .true.
+                 select case( trim(pkg_tag(pkg)) )
+                   case( 'chm' )
+                     ndx = traject(trj,dm)%chm_ndx(n)
+                   case( 'hyd' )
+                     ndx = traject(trj,dm)%hyd_ndx(n)
+                   case( 'trc' )
+                     ndx = traject(trj,dm)%trc_ndx(n)
+                   case( 'dyn' )
+                     ndx = 1
+                     call set_dyn_vals
+                   case( 'msc' )
+                     found = .false.
+                     St_Vars_ndx = trjects(trj)%msc_ndx(n) - offset
+                     do ndx = param_first_scalar,n_msc_buf
+                       if( St_Vars_ndx == St_Vars_buf_ndx(ndx) ) then
+                         found = .true.
+                         exit
+                       endif
+                     end do
+                     if( found ) then
+                       call set_msc_vals
+                     endif
+                     ndx = 1
+                   case( 'dchm' )
+                     ndx = trjects(trj)%dchm_ndx(n)
+                 end select
+                 if( found ) then
+                   horz_conc(1) = o_delsx*o_delsy*wrk4d(il,kl,jl,ndx) + o_delsy*delsx*wrk4d(iu,kl,jl,ndx) &
+                                + delsy*o_delsx*wrk4d(il,kl,ju,ndx) + delsx*delsy*wrk4d(iu,kl,ju,ndx)
+                   horz_conc(2) = o_delsx*o_delsy*wrk4d(il,ku,jl,ndx) + o_delsy*delsx*wrk4d(iu,ku,jl,ndx) &
+                                + delsy*o_delsx*wrk4d(il,ku,ju,ndx) + delsx*delsy*wrk4d(iu,ku,ju,ndx)
+                   traject(trj,dm)%traj_var(n) = delsz*horz_conc(2) + o_delsz*horz_conc(1)
+                 else
+                   traject(trj,dm)%traj_var(n) = missing_val
+                 endif
+               end do var_loop
+             else in_patch
+               traject(trj,dm)%traj_var(:n_vars) = missing_val
+             endif in_patch
+             traj_conc => traj_val(:,trj)
+             do n = 1,n_vars
+#ifdef DM_PARALLEL
+               max_conc = wrf_dm_max_real( traject(trj,dm)%traj_var(n) )
+#else
+               max_conc = traject(trj,dm)%traj_var(n)
+#endif
+               if( is_root_proc ) then
+                 traj_conc(n) = max_conc
+               endif
+             end do
+           else pkg_is_active_in_traj
+             if( is_root_proc .and. n_vars > 0 ) then
+               traj_conc => traj_val(:,trj)
+               traj_conc(:n_vars) = missing_val
+             endif
+           endif pkg_is_active_in_traj
+!-----------------------------------------------------------------------------
+!  buffer traj chm,trc,hyb,msc,dchm variables
+!-----------------------------------------------------------------------------
+           if( is_root_proc .and. n_vars > 0 ) then
+             select case( pkg_tag(pkg) )
+#if( WRF_CHEM == 1 )
+               case( 'chm' )
+                 trj_pbf(trj)%chm_vals(n_vals,:n_vars) = traj_conc(:n_vars)
+               case( 'dchm' )
+                 trj_pbf(trj)%dchm_vals(n_vals,:n_vars) = traj_conc(:n_vars)
+#endif
+               case( 'hyd' )
+                 trj_pbf(trj)%hyd_vals(n_vals,:n_vars) = traj_conc(:n_vars)
+               case( 'trc' )
+                 trj_pbf(trj)%trc_vals(n_vals,:n_vars) = traj_conc(:n_vars)
+               case( 'dyn' )
+                 trj_pbf(trj)%dyn_vals(n_vals,:n_vars) = traj_conc(:n_vars)
+               case( 'msc' )
+                 trj_pbf(trj)%msc_vals(n_vals,:n_vars) = traj_conc(:n_vars)
+             end select
+           endif
+         end do traj_loop
+         if( allocated( chem ) ) then
+           deallocate( chem )
+         endif
+         if( allocated( moist ) ) then
+           deallocate( moist )
+         endif
+         if( allocated( tracer ) ) then
+           deallocate( tracer )
+         endif
+         if( allocated( St_Vars_buf_ndx ) ) then
+           deallocate( St_Vars_buf_ndx )
+         endif
+         if( pkg == dchm_pkg .and. allocated( dchm_buff ) ) then
+           deallocate( dchm_buff )
+         endif
+       else pkg_has_active_traj
+         if( is_root_proc ) then
+           do trj = 1,n_traj
+             select case( trim(pkg_tag(pkg)) )
+#if( WRF_CHEM == 1 )
+               case( 'chm' )
+                 n_vars = traject(trj,dm)%n_chm_var
+               case( 'dchm' )
+                 n_vars = traject(trj,dm)%n_dchm_var
+#endif
+               case( 'hyd' )
+                 n_vars = traject(trj,dm)%n_hyd_var
+               case( 'trc' )
+                 n_vars = traject(trj,dm)%n_trc_var
+               case( 'dyn' )
+                 n_vars = traject(trj,dm)%n_dyn_var
+               case( 'msc' )
+                 n_vars = traject(trj,dm)%n_msc_var
+             end select
+             if( n_vars > 0 ) then
+               select case( pkg_tag(pkg) )
+#if( WRF_CHEM == 1 )
+                 case( 'chm' )
+                   trj_pbf(trj)%chm_vals(n_vals,:n_vars) = missing_val
+                 case( 'dchm' )
+                   trj_pbf(trj)%dchm_vals(n_vals,:n_vars) = dchm_fill_val(trj)
+#endif
+                 case( 'hyd' )
+                   trj_pbf(trj)%hyd_vals(n_vals,:n_vars) = missing_val
+                 case( 'trc' )
+                   trj_pbf(trj)%trc_vals(n_vals,:n_vars) = missing_val
+                 case( 'dyn' )
+                   trj_pbf(trj)%dyn_vals(n_vals,:n_vars) = missing_val
+                 case( 'msc' )
+                   trj_pbf(trj)%msc_vals(n_vals,:n_vars) = missing_val
+               end select
+             endif
+           end do
+         endif
+       endif pkg_has_active_traj
+     end do pkg_loop
+!-----------------------------------------------------------------------------
+!  output trajectory buffer
+!-----------------------------------------------------------------------------
+     if( is_root_proc ) then
+       flsh_buff = n_vals == vals_max .or. domain_last_time_step( grid )
+       if( flsh_buff ) then
+         call trajectory_write_file( n_traj, n_vals, dm )
+       endif
+     endif
+   endif has_trajectories
+
+   CONTAINS
+
+   subroutine pack_dyn_vals
+
+   integer :: mp1
+
+   do m = 1,dyn_max+2
+     mp1 = m + 1
+     select case( m )
+       case( 1 )
+         do j = jps,jpe
+           do k = kps,kpe
+             chem(ips:ipe,k,j,mp1) = grid%p(ips:ipe,k,j)
+           end do
+         end do
+       case( 2 )
+         do j = jps,jpe
+           do k = kps,kpe
+             chem(ips:ipe,k,j,mp1) = grid%t_2(ips:ipe,k,j)
+           end do
+         end do
+       case( 3 )
+         do j = jps,jpe
+           do k = kps,kpe
+             chem(ips:ipe,k,j,mp1) = grid%pb(ips:ipe,k,j)
+           end do
+         end do
+       case( 4 )
+         do j = jps,jpe
+           do k = kps,kpe
+             chem(ips:ipe,k,j,mp1) = grid%u_2(ips:ipe,k,j)
+           end do
+         end do
+       case( 5 )
+         do j = jps,jpe
+           do k = kps,kpe
+             chem(ips:ipe,k,j,mp1) = grid%v_2(ips:ipe,k,j)
+           end do
+         end do
+       case( 6 )
+         do j = jps,jpe
+           do k = kps,kpe
+             chem(ips:ipe,k,j,mp1) = grid%w_2(ips:ipe,k,j)
+           end do
+         end do
+       case( 7 )
+         do j = jps,jpe
+           do k = kps,kpe
+             chem(ips:ipe,k,j,mp1) = grid%ph_2(ips:ipe,k,j)
+           end do
+         end do
+       case( 8 )
+         do j = jps,jpe
+           do k = kps,kpe
+             chem(ips:ipe,k,j,mp1) = grid%phb(ips:ipe,k,j)
+           end do
+         end do
+#if( WRF_CHEM == 1 )
+       case( 9 )
+         do j = jps,jpe
+           do k = kps,kpe
+             chem(ips:ipe,k,j,mp1) = grid%rainprod(ips:ipe,k,j)
+           end do
+         end do
+       case( 10 )
+         do j = jps,jpe
+           do k = kps,kpe
+             chem(ips:ipe,k,j,mp1) = grid%evapprod(ips:ipe,k,j)
+           end do
+         end do
+#endif
+     end select
+   end do
+
+   end subroutine pack_dyn_vals
+
+   subroutine set_dyn_vals
+
+   use module_model_constants, only : g, t0, p1000mb, rcp
+
+   integer :: ilp1, iup1, jlp1, jup1, klp1, kup1
+   real    :: ginv, pinv
+
+   select case( traject(trj,dm)%dyn_var(n) )
+     case( 'p' )
+       wrk4d(il,kl,jl,1) = chem(il,kl,jl,2) + chem(il,kl,jl,4)
+       wrk4d(iu,kl,jl,1) = chem(iu,kl,jl,2) + chem(iu,kl,jl,4)
+       wrk4d(il,ku,jl,1) = chem(il,ku,jl,2) + chem(il,ku,jl,4)
+       wrk4d(iu,ku,jl,1) = chem(iu,ku,jl,2) + chem(iu,ku,jl,4)
+       wrk4d(il,kl,ju,1) = chem(il,kl,ju,2) + chem(il,kl,ju,4)
+       wrk4d(iu,kl,ju,1) = chem(iu,kl,ju,2) + chem(iu,kl,ju,4)
+       wrk4d(il,ku,ju,1) = chem(il,ku,ju,2) + chem(il,ku,ju,4)
+       wrk4d(iu,ku,ju,1) = chem(iu,ku,ju,2) + chem(iu,ku,ju,4)
+     case( 'T' )
+       wrk4d(il,kl,jl,1) = chem(il,kl,jl,2) + chem(il,kl,jl,4)
+       wrk4d(iu,kl,jl,1) = chem(iu,kl,jl,2) + chem(iu,kl,jl,4)
+       wrk4d(il,ku,jl,1) = chem(il,ku,jl,2) + chem(il,ku,jl,4)
+       wrk4d(iu,ku,jl,1) = chem(iu,ku,jl,2) + chem(iu,ku,jl,4)
+       wrk4d(il,kl,ju,1) = chem(il,kl,ju,2) + chem(il,kl,ju,4)
+       wrk4d(iu,kl,ju,1) = chem(iu,kl,ju,2) + chem(iu,kl,ju,4)
+       wrk4d(il,ku,ju,1) = chem(il,ku,ju,2) + chem(il,ku,ju,4)
+       wrk4d(iu,ku,ju,1) = chem(iu,ku,ju,2) + chem(iu,ku,ju,4)
+
+       pinv = 1./p1000mb
+       wrk4d(il,kl,jl,1) = (chem(il,kl,jl,3) + t0)*(wrk4d(il,kl,jl,1)*pinv)**rcp
+       wrk4d(iu,kl,jl,1) = (chem(iu,kl,jl,3) + t0)*(wrk4d(iu,kl,jl,1)*pinv)**rcp
+       wrk4d(il,ku,jl,1) = (chem(il,ku,jl,3) + t0)*(wrk4d(il,ku,jl,1)*pinv)**rcp
+       wrk4d(iu,ku,jl,1) = (chem(iu,ku,jl,3) + t0)*(wrk4d(iu,ku,jl,1)*pinv)**rcp
+       wrk4d(il,kl,ju,1) = (chem(il,kl,ju,3) + t0)*(wrk4d(il,kl,ju,1)*pinv)**rcp
+       wrk4d(iu,kl,ju,1) = (chem(iu,kl,ju,3) + t0)*(wrk4d(iu,kl,ju,1)*pinv)**rcp
+       wrk4d(il,ku,ju,1) = (chem(il,ku,ju,3) + t0)*(wrk4d(il,ku,ju,1)*pinv)**rcp
+       wrk4d(iu,ku,ju,1) = (chem(iu,ku,ju,3) + t0)*(wrk4d(iu,ku,ju,1)*pinv)**rcp
+     case( 'z' )
+       klp1 = kl + 1 ; kup1 = ku + 1
+       ginv = 1./g
+       wrk4d(il,kl,jl,1) = .5*(chem(il,kl,jl,8) + chem(il,klp1,jl,8) &
+                               + chem(il,kl,jl,9) + chem(il,klp1,jl,9))*ginv
+       wrk4d(iu,kl,jl,1) = .5*(chem(iu,kl,jl,8) + chem(iu,klp1,jl,8) &
+                               + chem(iu,kl,jl,9) + chem(iu,klp1,jl,9))*ginv
+       wrk4d(il,ku,jl,1) = .5*(chem(il,ku,jl,8) + chem(il,kup1,jl,8) &
+                               + chem(il,ku,jl,9) + chem(il,kup1,jl,9))*ginv
+       wrk4d(iu,ku,jl,1) = .5*(chem(iu,ku,jl,8) + chem(iu,kup1,jl,8) &
+                               + chem(iu,ku,jl,9) + chem(iu,kup1,jl,9))*ginv
+       wrk4d(il,kl,ju,1) = .5*(chem(il,kl,ju,8) + chem(il,klp1,ju,8) &
+                               + chem(il,kl,ju,9) + chem(il,klp1,ju,9))*ginv
+       wrk4d(iu,kl,ju,1) = .5*(chem(iu,kl,ju,8) + chem(iu,klp1,ju,8) &
+                               + chem(iu,kl,ju,9) + chem(iu,klp1,ju,9))*ginv
+       wrk4d(il,ku,ju,1) = .5*(chem(il,ku,ju,8) + chem(il,kup1,ju,8) &
+                               + chem(il,ku,ju,9) + chem(il,kup1,ju,9))*ginv
+       wrk4d(iu,ku,ju,1) = .5*(chem(iu,ku,ju,8) + chem(iu,kup1,ju,8) &
+                               + chem(iu,ku,ju,9) + chem(iu,kup1,ju,9))*ginv
+     case( 'u' )
+       ilp1 = il + 1 ; iup1 = iu + 1
+       wrk4d(il,kl,jl,1) = .5*(chem(il,kl,jl,5) + chem(ilp1,kl,jl,5))
+       wrk4d(iu,kl,jl,1) = .5*(chem(iu,kl,jl,5) + chem(iup1,kl,jl,5))
+       wrk4d(il,ku,jl,1) = .5*(chem(il,ku,jl,5) + chem(ilp1,ku,jl,5))
+       wrk4d(iu,ku,jl,1) = .5*(chem(iu,ku,jl,5) + chem(iup1,ku,jl,5))
+       wrk4d(il,kl,ju,1) = .5*(chem(il,kl,ju,5) + chem(ilp1,kl,ju,5))
+       wrk4d(iu,kl,ju,1) = .5*(chem(iu,kl,ju,5) + chem(iup1,kl,ju,5))
+       wrk4d(il,ku,ju,1) = .5*(chem(il,ku,ju,5) + chem(ilp1,ku,ju,5))
+       wrk4d(iu,ku,ju,1) = .5*(chem(iu,ku,ju,5) + chem(iup1,ku,ju,5))
+     case( 'v' )
+       jlp1 = jl + 1 ; jup1 = ju + 1
+       wrk4d(il,kl,jl,1) = .5*(chem(il,kl,jl,6) + chem(il,kl,jlp1,6))
+       wrk4d(iu,kl,jl,1) = .5*(chem(iu,kl,jl,6) + chem(iu,kl,jlp1,6))
+       wrk4d(il,ku,jl,1) = .5*(chem(il,ku,jl,6) + chem(il,ku,jlp1,6))
+       wrk4d(iu,ku,jl,1) = .5*(chem(iu,ku,jl,6) + chem(iu,ku,jlp1,6))
+       wrk4d(il,kl,ju,1) = .5*(chem(il,kl,ju,6) + chem(il,kl,jup1,6))
+       wrk4d(iu,kl,ju,1) = .5*(chem(iu,kl,ju,6) + chem(iu,kl,jup1,6))
+       wrk4d(il,ku,ju,1) = .5*(chem(il,ku,ju,6) + chem(il,ku,jup1,6))
+       wrk4d(iu,ku,ju,1) = .5*(chem(iu,ku,ju,6) + chem(iu,ku,jup1,6))
+     case( 'w' )
+       klp1 = kl + 1 ; kup1 = ku + 1
+       wrk4d(il,kl,jl,1) = .5*(chem(il,kl,jl,7) + chem(il,klp1,jl,7))
+       wrk4d(iu,kl,jl,1) = .5*(chem(iu,kl,jl,7) + chem(iu,klp1,jl,7))
+       wrk4d(il,ku,jl,1) = .5*(chem(il,ku,jl,7) + chem(il,kup1,jl,7))
+       wrk4d(iu,ku,jl,1) = .5*(chem(iu,ku,jl,7) + chem(iu,kup1,jl,7))
+       wrk4d(il,kl,ju,1) = .5*(chem(il,kl,ju,7) + chem(il,klp1,ju,7))
+       wrk4d(iu,kl,ju,1) = .5*(chem(iu,kl,ju,7) + chem(iu,klp1,ju,7))
+       wrk4d(il,ku,ju,1) = .5*(chem(il,ku,ju,7) + chem(il,kup1,ju,7))
+       wrk4d(iu,ku,ju,1) = .5*(chem(iu,ku,ju,7) + chem(iu,kup1,ju,7))
+#if( WRF_CHEM == 1 )
+     case( 'rainprod' )
+       wrk4d(il,kl,jl,1) = chem(il,kl,jl,10)
+       wrk4d(iu,kl,jl,1) = chem(iu,kl,jl,10)
+       wrk4d(il,ku,jl,1) = chem(il,ku,jl,10)
+       wrk4d(iu,ku,jl,1) = chem(iu,ku,jl,10)
+       wrk4d(il,kl,ju,1) = chem(il,kl,ju,10)
+       wrk4d(iu,kl,ju,1) = chem(iu,kl,ju,10)
+       wrk4d(il,ku,ju,1) = chem(il,ku,ju,10)
+       wrk4d(iu,ku,ju,1) = chem(iu,ku,ju,10)
+     case( 'evapprod' )
+       wrk4d(il,kl,jl,1) = chem(il,kl,jl,11)
+       wrk4d(iu,kl,jl,1) = chem(iu,kl,jl,11)
+       wrk4d(il,ku,jl,1) = chem(il,ku,jl,11)
+       wrk4d(iu,ku,jl,1) = chem(iu,ku,jl,11)
+       wrk4d(il,kl,ju,1) = chem(il,kl,ju,11)
+       wrk4d(iu,kl,ju,1) = chem(iu,kl,ju,11)
+       wrk4d(il,ku,ju,1) = chem(il,ku,ju,11)
+       wrk4d(iu,ku,ju,1) = chem(iu,ku,ju,11)
+#endif
+   end select
+
+   end subroutine set_dyn_vals
+
+   subroutine set_msc_vals
+
+   integer :: ilp1, iup1, jlp1, jup1, klp1, kup1
+
+   select case( trim(St_Vars(St_Vars_ndx)%Stagger) )
+     case( 'X' )
+       ilp1 = il + 1 ; iup1 = iu + 1
+       wrk4d(il,kl,jl,1) = .5*(chem(il,kl,jl,ndx) + chem(ilp1,kl,jl,ndx))
+       wrk4d(iu,kl,jl,1) = .5*(chem(iu,kl,jl,ndx) + chem(iup1,kl,jl,ndx))
+       wrk4d(il,ku,jl,1) = .5*(chem(il,ku,jl,ndx) + chem(ilp1,ku,jl,ndx))
+       wrk4d(iu,ku,jl,1) = .5*(chem(iu,ku,jl,ndx) + chem(iup1,ku,jl,ndx))
+       wrk4d(il,kl,ju,1) = .5*(chem(il,kl,ju,ndx) + chem(ilp1,kl,ju,ndx))
+       wrk4d(iu,kl,ju,1) = .5*(chem(iu,kl,ju,ndx) + chem(iup1,kl,ju,ndx))
+       wrk4d(il,ku,ju,1) = .5*(chem(il,ku,ju,ndx) + chem(ilp1,ku,ju,ndx))
+       wrk4d(iu,ku,ju,1) = .5*(chem(iu,ku,ju,ndx) + chem(iup1,ku,ju,ndx))
+     case( 'Y' )
+       jlp1 = jl + 1 ; jup1 = ju + 1
+       wrk4d(il,kl,jl,1) = .5*(chem(il,kl,jl,ndx) + chem(il,kl,jlp1,ndx))
+       wrk4d(iu,kl,jl,1) = .5*(chem(iu,kl,jl,ndx) + chem(iu,kl,jlp1,ndx))
+       wrk4d(il,ku,jl,1) = .5*(chem(il,ku,jl,ndx) + chem(il,ku,jlp1,ndx))
+       wrk4d(iu,ku,jl,1) = .5*(chem(iu,ku,jl,ndx) + chem(iu,ku,jlp1,ndx))
+       wrk4d(il,kl,ju,1) = .5*(chem(il,kl,ju,ndx) + chem(il,kl,jup1,ndx))
+       wrk4d(iu,kl,ju,1) = .5*(chem(iu,kl,ju,ndx) + chem(iu,kl,jup1,ndx))
+       wrk4d(il,ku,ju,1) = .5*(chem(il,ku,ju,ndx) + chem(il,ku,jup1,ndx))
+       wrk4d(iu,ku,ju,1) = .5*(chem(iu,ku,ju,ndx) + chem(iu,ku,jup1,ndx))
+     case( 'Z' )
+       klp1 = kl + 1 ; kup1 = ku + 1
+       wrk4d(il,kl,jl,1) = .5*(chem(il,kl,jl,ndx) + chem(il,klp1,jl,ndx))
+       wrk4d(iu,kl,jl,1) = .5*(chem(iu,kl,jl,ndx) + chem(iu,klp1,jl,ndx))
+       wrk4d(il,ku,jl,1) = .5*(chem(il,ku,jl,ndx) + chem(il,kup1,jl,ndx))
+       wrk4d(iu,ku,jl,1) = .5*(chem(iu,ku,jl,ndx) + chem(iu,kup1,jl,ndx))
+       wrk4d(il,kl,ju,1) = .5*(chem(il,kl,ju,ndx) + chem(il,klp1,ju,ndx))
+       wrk4d(iu,kl,ju,1) = .5*(chem(iu,kl,ju,ndx) + chem(iu,klp1,ju,ndx))
+       wrk4d(il,ku,ju,1) = .5*(chem(il,ku,ju,ndx) + chem(il,kup1,ju,ndx))
+       wrk4d(iu,ku,ju,1) = .5*(chem(iu,ku,ju,ndx) + chem(iu,kup1,ju,ndx))
+     case default
+       wrk4d(il,kl,jl,1) = chem(il,kl,jl,ndx)
+       wrk4d(iu,kl,jl,1) = chem(iu,kl,jl,ndx)
+       wrk4d(il,ku,jl,1) = chem(il,ku,jl,ndx)
+       wrk4d(iu,ku,jl,1) = chem(iu,ku,jl,ndx)
+       wrk4d(il,kl,ju,1) = chem(il,kl,ju,ndx)
+       wrk4d(iu,kl,ju,1) = chem(iu,kl,ju,ndx)
+       wrk4d(il,ku,ju,1) = chem(il,ku,ju,ndx)
+       wrk4d(iu,ku,ju,1) = chem(iu,ku,ju,ndx)
+   end select
+
+   end subroutine set_msc_vals
+
+   end subroutine trajectory_driver
+
+   subroutine trajectory_dchm_tstep_init( grid, is_chemstep )
+!-----------------------------------------------------------------------------
+!  initialize dchm buffer
+!-----------------------------------------------------------------------------
+   use module_domain, only : domain, get_ijk_from_grid
+   use module_state_description, only : num_chem
+
+!-----------------------------------------------------------------------------
+!  dummy arguments
+!-----------------------------------------------------------------------------
+   logical, intent(in)      :: is_chemstep
+   type(domain), intent(in) :: grid
+
+!-----------------------------------------------------------------------------
+!  local variables
+!-----------------------------------------------------------------------------
+   integer :: astat
+   integer :: j, k, m
+   integer :: chm_ndx
+   integer :: dm
+   integer :: ims,ime, jms,jme, kms,kme
+   integer :: ids,ide, jds,jde, kds,kde
+   integer :: ips,ipe, jps,jpe, kps,kpe
+   integer, pointer :: n_dchm       ! number dchm buffer species
+   integer, pointer :: dchm_buf_ndx(:)
+   character(len=256) :: err_mes
+
+   do_chemstep = is_chemstep
+
+   if( is_chemstep ) then
+     dm = grid%id
+     n_dchm => n_dchm_dm(dm)
+     if( n_dchm > 0 ) then
+       call get_ijk_from_grid( grid ,                   &
+                               ids, ide, jds, jde, kds, kde,    &
+                               ims, ime, jms, jme, kms, kme,    &
+                               ips, ipe, jps, jpe, kps, kpe    )
+       if( allocated( dchm_buff ) ) then
+         deallocate( dchm_buff )
+       endif
+       allocate( dchm_buff(ims:ime,kms:kme,jms:jme,n_dchm+offset),stat=astat )
+       if( astat /= 0 ) then
+         write(err_mes,'(''trajectory_dchm_tstep_init('',i2.2,''): failed to allocate wrk4d: error = '',i6)') dm,astat
+         call wrf_error_fatal( trim( err_mes  ) )
+       endif
+       dchm_buf_ndx => dchm_buf_ndx_dm(:,dm)
+       do m = 1,n_dchm
+         chm_ndx = dchm_buf_ndx(m)
+         do j = jps,jpe
+           do k = kps,kpe
+             dchm_buff(ips:ipe,k,j,m+offset) = grid%chem(ips:ipe,k,j,chm_ndx)
+           end do
+         end do
+       end do
+     endif
+   endif
+
+   end subroutine trajectory_dchm_tstep_init
+
+   subroutine trajectory_dchm_tstep_set( grid )
+!-----------------------------------------------------------------------------
+!  set dchm buffer
+!-----------------------------------------------------------------------------
+   use module_domain, only : domain, get_ijk_from_grid
+   use module_state_description, only : num_chem
+
+!-----------------------------------------------------------------------------
+!  dummy arguments
+!-----------------------------------------------------------------------------
+   type(domain), intent(in) :: grid
+
+!-----------------------------------------------------------------------------
+!  local variables
+!-----------------------------------------------------------------------------
+   integer :: j, k, m, mp1
+   integer :: chm_ndx
+   integer :: dm
+   integer :: ims,ime, jms,jme, kms,kme
+   integer :: ids,ide, jds,jde, kds,kde
+   integer :: ips,ipe, jps,jpe, kps,kpe
+   integer, pointer :: n_dchm       ! number dchm buffer species
+   integer, pointer :: dchm_buf_ndx(:)
+
+   dm = grid%id
+   n_dchm => n_dchm_dm(dm)
+   if( n_dchm > 0 ) then
+     call get_ijk_from_grid( grid ,                   &
+                             ids, ide, jds, jde, kds, kde,    &
+                             ims, ime, jms, jme, kms, kme,    &
+                             ips, ipe, jps, jpe, kps, kpe    )
+     dchm_buf_ndx => dchm_buf_ndx_dm(:,dm)
+     do m = 1,n_dchm
+       mp1 = m + offset
+       chm_ndx = dchm_buf_ndx(m)
+       do j = jps,jpe
+         do k = kps,kpe
+           dchm_buff(ips:ipe,k,j,mp1) = grid%chem(ips:ipe,k,j,chm_ndx) - dchm_buff(ips:ipe,k,j,mp1)
+         end do
+       end do
+     end do
+   endif
+
+   end subroutine trajectory_dchm_tstep_set
+
+   subroutine trajectory_create_file( grid, n_traj )
+!-----------------------------------------------------------------------------
+!  create trajectory netcdf file
+!-----------------------------------------------------------------------------
+   use module_domain
+   use module_state_description, only : param_first_scalar, num_chem, num_moist, num_tracer
+   use module_scalar_tables,     only : chem_dname_table, moist_dname_table, tracer_dname_table
+
+!-----------------------------------------------------------------------------
+!  dummy arguments
+!-----------------------------------------------------------------------------
+   integer, intent(in)       :: n_traj
+   type(domain), intent(in)  :: grid
+
+!-----------------------------------------------------------------------------
+!  local variables
+!-----------------------------------------------------------------------------
+   integer :: dm
+   integer :: ncid, ios
+   integer :: traj_dim, time_dim, Times_dim
+   integer :: varid
+   integer, pointer :: num_msc
+   integer :: var_dims(2)
+   integer :: m, n, trj, pkg
+   character(len=10)  :: coord_name(5) = (/ 'traj_i    ', 'traj_j    ', 'traj_k    ', &
+                                            'traj_long ', 'traj_lat  ' /)
+   character(len=256) :: filename
+   character(len=256) :: var_name
+   character(len=256) :: err_mes
+   character(len=256) :: description
+   character(len=256) :: units
+
+   logical, external :: wrf_dm_on_monitor
+
+include 'netcdf.inc'
+
+master_proc: &
+   if( wrf_dm_on_monitor() ) then
+     dm = grid%id
+     write(filename,'(''wrfout_traj_d'',i2.2)',iostat=ios) dm
+     if( ios /= 0 ) then
+       write(err_mes,'(''trajectory_create_file: failed to set filename: error = '',i6)') ios
+       call wrf_error_fatal( trim( err_mes  ) )
+     endif
+!    ios = nf_create( trim(filename), or(nf_clobber,nf_netcdf4), ncid )
+     ios = nf_create( trim(filename), nf_clobber, ncid )
+     if( ios /= nf_noerr ) then
+       write(err_mes,'(''trajectory_create_file: failed to create '',a,'': error = '',i6)') trim(filename),ios
+       call wrf_error_fatal( trim( err_mes  ) )
+     endif
+!-----------------------------------------------------------------------------
+!  define dimensions
+!-----------------------------------------------------------------------------
+     err_mes = 'trajectory_create_file: failed to create traj dimension'
+     call handle_ncerr( nf_def_dim( ncid, 'traj', n_traj, traj_dim ), trim(err_mes) )
+     err_mes = 'trajectory_create_file: failed to create time dimension'
+     call handle_ncerr( nf_def_dim( ncid, 'time', nf_unlimited, time_dim ), trim(err_mes) )
+     err_mes = 'trajectory_create_file: failed to create Times dimension'
+     call handle_ncerr( nf_def_dim( ncid, 'DateStrLen', 19, Times_dim ), trim(err_mes) )
+!-----------------------------------------------------------------------------
+!  define variables
+!-----------------------------------------------------------------------------
+     var_dims(:) = (/ Times_dim,time_dim /)
+     err_mes = 'trajectory_create_file: failed to create Times variable'
+     call handle_ncerr( nf_def_var( ncid, 'Times', nf_char, 2, var_dims, varid ), trim(err_mes) )
+
+!-----------------------------------------------------------------------------
+!  first the coordinate variables
+!-----------------------------------------------------------------------------
+     var_dims(:) = (/ traj_dim,time_dim /)
+     do m = 1,5
+       var_name = coord_name(m)
+       err_mes = 'trajectory_create_file: failed to create ' // trim(var_name) // ' variable'
+       call handle_ncerr( nf_def_var( ncid, trim(var_name), nf_real, 2, var_dims, varid ), trim(err_mes) )
+     end do
+!-----------------------------------------------------------------------------
+!  then the species variables
+!-----------------------------------------------------------------------------
+     num_msc => num_msc_dm(dm)
+pgk_loop: &
+     do pkg = 1,pkg_max
+       select case( pkg_tag(pkg) )
+         case( 'chm' )
+           trj_msk => trj_msk_dm(:,:,chm_pkg,dm)
+           if( any( trj_msk(:n_traj,1) ) ) then
+             call def_vars( 'chm' )
+           endif
+         case( 'hyd' )
+           trj_msk => trj_msk_dm(:,:,hyd_pkg,dm)
+           if( any( trj_msk(:n_traj,1) ) ) then
+             call def_vars( 'hyd' )
+           endif
+         case( 'trc' )
+           trj_msk => trj_msk_dm(:,:,trc_pkg,dm)
+           if( any( trj_msk(:n_traj,1) ) ) then
+             call def_vars( 'trc' )
+           endif
+         case( 'dyn' )
+           trj_msk => trj_msk_dm(:,:,dyn_pkg,dm)
+           if( any( trj_msk(:n_traj,1) ) ) then
+             call def_vars( 'dyn' )
+           endif
+         case( 'msc' )
+           trj_msk => trj_msk_dm(:,:,msc_pkg,dm)
+           if( any( trj_msk(:n_traj,1) ) ) then
+             call def_vars( 'msc' )
+           endif
+         case( 'dchm' )
+           trj_msk => trj_msk_dm(:,:,dchm_pkg,dm)
+           if( any( trj_msk(:n_traj,1) ) ) then
+             call def_vars( 'dchm' )
+           endif
+       end select
+     end do pgk_loop
+
+     err_mes = 'trajectory_create_file: failed to end definition for file ' // trim(filename)
+     call handle_ncerr( nf_enddef( ncid ), trim(err_mes) )
+     err_mes = 'trajectory_create_file: failed to close file ' // trim(filename)
+     call handle_ncerr( nf_close( ncid ), trim(err_mes) )
+   endif master_proc
+
+   CONTAINS
+
+   subroutine def_vars( var_type )
+
+   character(len=*), intent(in)  :: var_type
+
+   integer :: m, ndx, trj
+   integer, pointer  :: n_dchm
+   character(len=32) :: spc_name
+
+   select case( var_type )
+     case( 'chm' )
+       trj_msk => trj_msk_dm(:,:,chm_pkg,dm)
+       do n = param_first_scalar,num_chem
+         if( any( trj_msk(:n_traj,n) ) ) then
+           spc_name = chem_dname_table(dm,n)
+           write(var_name,'(a,''_traj'')') trim(spc_name)
+           err_mes = 'def_vars: failed to create ' // trim(var_name) // ' variable'
+           call handle_ncerr( nf_def_var( ncid, trim(var_name), nf_real, 2, var_dims, varid ), trim(err_mes) )
+           description = trim(var_name) // ' mixing ratio'
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'description', len_trim(description), description ), trim(err_mes) )
+           units = 'ppmv'
+trj_loop:  do trj = 1,n_traj
+             if( trj_msk(trj,n) ) then
+               do m = 1,trjects(trj)%n_chm_var
+                 if( trim(trjects(trj)%chm_spc(m)) == trim(spc_name) ) then
+                   if( .not. trjects(trj)%chm_is_gas(m) ) then
+                     units = 'ug/kg-dryair'
+                   endif
+                   exit trj_loop
+                 endif
+               end do
+               exit trj_loop
+             endif
+           end do trj_loop
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'units', len_trim(units), units ), trim(err_mes) )
+         endif
+       end do
+     case( 'hyd' )
+       trj_msk => trj_msk_dm(:,:,hyd_pkg,dm)
+       do n = param_first_scalar,num_moist
+         if( any( trj_msk(:n_traj,n) ) ) then
+           write(var_name,'(a,''_traj'')') trim(moist_dname_table(dm,n))
+           err_mes = 'def_vars: failed to create ' // trim(var_name) // ' variable'
+           call handle_ncerr( nf_def_var( ncid, trim(var_name), nf_real, 2, var_dims, varid ), trim(err_mes) )
+           description = trim(var_name) // ' mixing ratio'
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'description', len_trim(description), description ), trim(err_mes) )
+           units = 'ug/kg-dryair'
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'units', len_trim(units), units ), trim(err_mes) )
+         endif
+       end do
+     case( 'trc' )
+       trj_msk => trj_msk_dm(:,:,trc_pkg,dm)
+       do n = param_first_scalar,num_tracer
+         if( any( trj_msk(:n_traj,n) ) ) then
+           write(var_name,'(a,''_traj'')') trim(tracer_dname_table(dm,n))
+           err_mes = 'def_vars: failed to create ' // trim(var_name) // ' variable'
+           call handle_ncerr( nf_def_var( ncid, trim(var_name), nf_real, 2, var_dims, varid ), trim(err_mes) )
+           description = trim(var_name) // ' mixing ratio'
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'description', len_trim(description), description ), trim(err_mes) )
+           units = ' '
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'units', len_trim(units), units ), trim(err_mes) )
+         endif
+       end do
+     case( 'dyn' )
+       trj_msk => trj_msk_dm(:,:,dyn_pkg,dm)
+       do n = param_first_scalar,dyn_max + offset
+         if( any( trj_msk(:n_traj,n) ) ) then
+           write(var_name,'(a,''_traj'')') trim(dyn_var_lst(n-1))
+           err_mes = 'def_vars: failed to create ' // trim(var_name) // ' variable'
+           call handle_ncerr( nf_def_var( ncid, trim(var_name), nf_real, 2, var_dims, varid ), trim(err_mes) )
+           description = trim(dyn_var_desc_att(n-1))
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'description', len_trim(description), description ), trim(err_mes) )
+           units = trim(dyn_var_unit_att(n-1))
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'units', len_trim(units), units ), trim(err_mes) )
+         endif
+       end do
+     case( 'msc' )
+       trj_msk => trj_msk_dm(:,:,msc_pkg,dm)
+       do n = param_first_scalar,num_msc + offset
+         if( any( trj_msk(:n_traj,n) ) ) then
+           write(var_name,'(a,''_traj'')') trim(St_Vars(n-1)%Varname)
+           err_mes = 'def_vars: failed to create ' // trim(var_name) // ' variable'
+           call handle_ncerr( nf_def_var( ncid, trim(var_name), nf_real, 2, var_dims, varid ), trim(err_mes) )
+           description = trim(St_Vars(n-1)%Description)
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'description', len_trim(description), description ), trim(err_mes) )
+           units = trim(St_Vars(n-1)%Units)
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'units', len_trim(units), units ), trim(err_mes) )
+         endif
+       end do
+     case( 'dchm' )
+       trj_msk => trj_msk_dm(:,:,dchm_pkg,dm)
+       n_dchm  => n_dchm_dm(dm)
+       dchm_buf_ndx => dchm_buf_ndx_dm(:,dm)
+       do n = 1,n_dchm
+         if( any( trj_msk(:n_traj,n+offset) ) ) then
+           ndx = dchm_buf_ndx(n)
+           spc_name = 'dchm_' // trim(chem_dname_table(dm,ndx))
+           write(var_name,'(a,''_traj'')') trim(spc_name)
+           err_mes = 'def_vars: failed to create ' // trim(var_name) // ' variable'
+           call handle_ncerr( nf_def_var( ncid, trim(var_name), nf_real, 2, var_dims, varid ), trim(err_mes) )
+           description = trim(var_name) // ' mixing ratio'
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'description', len_trim(description), description ), trim(err_mes) )
+           units = 'ppmv'
+           call handle_ncerr( nf_put_att_text( ncid, varid, 'units', len_trim(units), units ), trim(err_mes) )
+         endif
+       end do
+   end select
+
+   end subroutine def_vars
+
+   end subroutine trajectory_create_file
+
+   subroutine trajectory_write_file( n_traj, n_vals, dm )
+!-----------------------------------------------------------------------------
+!  create trajectory netcdf file
+!-----------------------------------------------------------------------------
+   use module_domain
+   use module_state_description, only : param_first_scalar, num_chem, num_moist, num_tracer
+   use module_scalar_tables,     only : chem_dname_table, moist_dname_table, tracer_dname_table
+
+!-----------------------------------------------------------------------------
+!  dummy arguments
+!-----------------------------------------------------------------------------
+   integer, intent(in)        :: n_traj
+   integer, intent(inout)     :: n_vals
+   integer, intent(in)        :: dm
+
+!-----------------------------------------------------------------------------
+!  local variables
+!-----------------------------------------------------------------------------
+   integer :: ncid
+   integer :: astat, ios
+   integer :: time_id
+   integer :: varid
+   integer :: l, m, n, trj, pkg, spc, spcp1
+   integer :: time_ndx
+   integer :: buf_ndx
+   integer :: ndx
+   integer, pointer :: num_msc      ! number misc species
+   integer, pointer :: n_dchm       ! total number of dchm species in domain
+   real, allocatable :: holder(:,:)
+   character(len=10)  :: coord_name(5) = (/ 'traj_i    ', 'traj_j    ', 'traj_k    ', &
+                                            'traj_long ', 'traj_lat  ' /)
+   character(len=256) :: var_name
+   character(len=256) :: err_mes
+   character(len=256) :: filename
+   character(len=256) :: spcname
+
+   logical :: found
+
+include 'netcdf.inc'
+
+!---------------------------------------------------------------------
+!  open netcdf file
+!---------------------------------------------------------------------
+   write(filename,'(''wrfout_traj_d'',i2.2)',iostat=ios) dm
+   if( ios /= 0 ) then
+     write(err_mes,'(''trajectory_write_file: failed to set filename: error = '',i6)') ios
+     call wrf_error_fatal( trim( err_mes  ) )
+   endif
+   ios = nf_open( trim(filename), nf_write, ncid )
+   if( ios /= 0 ) then
+     write(err_mes,'(''trajectory_write_file: failed to open '',a,'': error = '',i6)') trim(filename),ios
+     call wrf_error_fatal( trim( err_mes  ) )
+   endif
+
+!---------------------------------------------------------------------
+!  allocate wrking array
+!---------------------------------------------------------------------
+   allocate( holder(n_traj,n_vals),stat=astat )
+   if( astat /= 0 ) then
+     write(err_mes,'(''trajectory_write_file: failed to allocate holder; error = '',i6)') astat
+     call wrf_error_fatal( trim( err_mes  ) )
+   endif
+
+!---------------------------------------------------------------------
+!  get current time index
+!---------------------------------------------------------------------
+   err_mes = 'trajectory_write_file: failed to get time id'
+   call handle_ncerr( nf_inq_dimid( ncid, 'time', time_id ),trim(err_mes) )
+   err_mes = 'trajectory_write_file: failed to get time dimension'
+   call handle_ncerr( nf_inq_dimlen( ncid, time_id, time_ndx ),trim(err_mes) )
+   time_ndx = time_ndx + 1
+
+!---------------------------------------------------------------------
+!  write out trajectory times
+!---------------------------------------------------------------------
+   err_mes = 'trajectory_write_file: failed to get Times id'
+   call handle_ncerr( nf_inq_varid( ncid, 'Times', varid ),trim(err_mes) )
+   err_mes = 'trajectory_write_file: failed to write Times'
+   call handle_ncerr( nf_put_vara_text( ncid, varid, (/ 1,time_ndx /), (/ 19,n_vals /), trj_pbf(1)%times(:n_vals) ), trim(err_mes) )
+
+!---------------------------------------------------------------------
+!  write out trajectory coordinates
+!---------------------------------------------------------------------
+coord_loop: &
+   do l = 1,5
+     var_name = coord_name(l)
+     err_mes = 'trajectory_write_file: failed to get '// trim(var_name) // ' id'
+     call handle_ncerr( nf_inq_varid( ncid, trim(var_name), varid ),trim(err_mes) )
+     select case( l )
+       case( 1 )
+         do n = 1,n_traj
+           holder(n,:n_vals) = trj_pbf(n)%trj_i(:n_vals)
+         end do
+       case( 2 )
+         do n = 1,n_traj
+           holder(n,:n_vals) = trj_pbf(n)%trj_j(:n_vals)
+         end do
+       case( 3 )
+         do n = 1,n_traj
+           holder(n,:n_vals) = trj_pbf(n)%trj_k(:n_vals)
+         end do
+       case( 4 )
+         do n = 1,n_traj
+           holder(n,:n_vals) = trj_pbf(n)%trj_lons(:n_vals)
+         end do
+       case( 5 )
+         do n = 1,n_traj
+           holder(n,:n_vals) = trj_pbf(n)%trj_lats(:n_vals)
+         end do
+       end select
+       err_mes = 'trajectory_write_file: failed to write ' // trim(var_name)
+       call handle_ncerr( nf_put_vara_real( ncid, varid, (/ 1,time_ndx /), (/ n_traj,n_vals /), &
+                                            holder ), trim(err_mes) )
+   end do coord_loop
+
+   St_Vars => St_Vars_dm(:,dm)
+   St_Vars_msk => St_Vars_msk_dm(:,dm)
+   num_msc => num_msc_dm(dm)
+!---------------------------------------------------------------------
+!  write out trajectory variables
+!---------------------------------------------------------------------
+pkg_loop: &
+   do pkg = 1,pkg_max
+     select case( pkg_tag(pkg) )
+       case( 'chm' )
+         trj_msk => trj_msk_dm(:,:,chm_pkg,dm)
+         do spc = param_first_scalar,num_chem
+           if( any( trj_msk(:n_traj,spc) ) ) then
+             holder(:,:) = missing_val
+             do trj = 1,n_traj
+               if( trj_msk(trj,spc) ) then
+                 buf_ndx = get_spc_buf_ndx( trjects(trj)%n_chm_var, trjects(trj)%chm_spc, chem_dname_table(dm,spc) )
+                 if( buf_ndx > 0 ) then
+                   holder(trj,:n_vals) = trj_pbf(trj)%chm_vals(:n_vals,buf_ndx)
+                 endif
+               endif
+             end do
+             write(var_name,'(a,''_traj'')') trim(chem_dname_table(dm,spc))
+             err_mes = 'trajectory_write_file: failed to get '// trim(var_name) // ' id'
+             call handle_ncerr( nf_inq_varid( ncid, trim(var_name), varid ),trim(err_mes) )
+             err_mes = 'trajectory_write_file: failed to write ' // trim(var_name)
+             call handle_ncerr( nf_put_vara_real( ncid, varid, (/ 1,time_ndx /), (/ n_traj,n_vals /), &
+                                                  holder ),trim(err_mes) )
+           endif
+         end do
+       case( 'hyd' )
+         trj_msk => trj_msk_dm(:,:,hyd_pkg,dm)
+         do spc = param_first_scalar,num_moist
+           if( any( trj_msk(:n_traj,spc) ) ) then
+             holder(:,:) = missing_val
+             do trj = 1,n_traj
+               if( trj_msk(trj,spc) ) then
+                 buf_ndx = get_spc_buf_ndx( trjects(trj)%n_hyd_var, trjects(trj)%hyd_spc, moist_dname_table(dm,spc) )
+                 if( buf_ndx > 0 ) then
+                   holder(trj,:n_vals) = trj_pbf(trj)%hyd_vals(:n_vals,buf_ndx)
+                 endif
+               endif
+             end do
+             write(var_name,'(a,''_traj'')') trim(moist_dname_table(dm,spc))
+             err_mes = 'trajectory_write_file: failed to get '// trim(var_name) // ' id'
+             call handle_ncerr( nf_inq_varid( ncid, trim(var_name), varid ),trim(err_mes) )
+             err_mes = 'trajectory_write_file: failed to write ' // trim(var_name)
+             call handle_ncerr( nf_put_vara_real( ncid, varid, (/ 1,time_ndx /), (/ n_traj,n_vals /), &
+                                                  holder ),trim(err_mes) )
+           endif
+         end do
+       case( 'trc' )
+         trj_msk => trj_msk_dm(:,:,trc_pkg,dm)
+         do spc = param_first_scalar,num_tracer
+           if( any( trj_msk(:n_traj,spc) ) ) then
+             holder(:,:) = missing_val
+             do trj = 1,n_traj
+               if( trj_msk(trj,spc) ) then
+                 buf_ndx = get_spc_buf_ndx( trjects(trj)%n_trc_var, trjects(trj)%trc_spc, tracer_dname_table(dm,spc) )
+                 if( buf_ndx > 0 ) then
+                   holder(trj,:n_vals) = trj_pbf(trj)%trc_vals(:n_vals,buf_ndx)
+                 endif
+               endif
+             end do
+             write(var_name,'(a,''_traj'')') trim(tracer_dname_table(dm,spc))
+             err_mes = 'trajectory_write_file: failed to get '// trim(var_name) // ' id'
+             call handle_ncerr( nf_inq_varid( ncid, trim(var_name), varid ),trim(err_mes) )
+             err_mes = 'trajectory_write_file: failed to write ' // trim(var_name)
+             call handle_ncerr( nf_put_vara_real( ncid, varid, (/ 1,time_ndx /), (/ n_traj,n_vals /), &
+                                                  holder ),trim(err_mes) )
+           endif
+         end do
+       case( 'dyn' )
+         trj_msk => trj_msk_dm(:,:,dyn_pkg,dm)
+         do spc = param_first_scalar,dyn_max+offset
+           if( any( trj_msk(:n_traj,spc) ) ) then
+             holder(:,:) = missing_val
+             do trj = 1,n_traj
+               if( trj_msk(trj,spc) ) then
+                 buf_ndx = get_spc_buf_ndx( trjects(trj)%n_dyn_var, trjects(trj)%dyn_var, dyn_var_lst(spc-offset) )
+                 if( buf_ndx > 0 ) then
+                   holder(trj,:n_vals) = trj_pbf(trj)%dyn_vals(:n_vals,buf_ndx)
+                 endif
+               endif
+             end do
+             write(var_name,'(a,''_traj'')') trim(dyn_var_lst(spc-offset))
+             err_mes = 'trajectory_write_file: failed to get '// trim(var_name) // ' id'
+             call handle_ncerr( nf_inq_varid( ncid, trim(var_name), varid ),trim(err_mes) )
+             err_mes = 'trajectory_write_file: failed to write ' // trim(var_name)
+             call handle_ncerr( nf_put_vara_real( ncid, varid, (/ 1,time_ndx /), (/ n_traj,n_vals /), &
+                                                  holder ),trim(err_mes) )
+           endif
+         end do
+       case( 'msc' )
+         trj_msk => trj_msk_dm(:,:,msc_pkg,dm)
+         do spc = param_first_scalar,num_msc+offset
+           if( any( trj_msk(:n_traj,spc) ) ) then
+             holder(:,:) = missing_val
+             do trj = 1,n_traj
+               if( trj_msk(trj,spc) ) then
+                 found = .false.
+                 do buf_ndx = 1,traject(trj,dm)%n_msc_var
+                   if( traject(trj,dm)%msc_ndx(buf_ndx) == spc ) then
+                     found = .true.
+                     exit
+                   endif
+                 end do
+                 if( found ) then
+                   holder(trj,:n_vals) = trj_pbf(trj)%msc_vals(:n_vals,buf_ndx)
+                 endif
+               endif
+             end do
+             write(var_name,'(a,''_traj'')') trim(St_Vars(spc-offset)%Varname)
+             err_mes = 'trajectory_write_file: failed to get '// trim(var_name) // ' id'
+             call handle_ncerr( nf_inq_varid( ncid, trim(var_name), varid ),trim(err_mes) )
+             err_mes = 'trajectory_write_file: failed to write ' // trim(var_name)
+             call handle_ncerr( nf_put_vara_real( ncid, varid, (/ 1,time_ndx /), (/ n_traj,n_vals /), &
+                                                  holder ),trim(err_mes) )
+           endif
+         end do
+       case( 'dchm' )
+         dchm_buf_ndx => dchm_buf_ndx_dm(:,dm)
+         trj_msk => trj_msk_dm(:,:,dchm_pkg,dm)
+         n_dchm  => n_dchm_dm(dm)
+         do spc = 1,n_dchm
+           spcp1 = spc + 1
+           if( any( trj_msk(:n_traj,spcp1) ) ) then
+             holder(:,:) = missing_val
+             do trj = 1,n_traj
+               if( trj_msk(trj,spcp1) ) then
+                 buf_ndx = get_dchm_buf_ndx( trjects(trj)%n_dchm_var, trjects(trj)%dchm_ndx, spcp1 )
+                 if( buf_ndx > 0 ) then
+                   holder(trj,:n_vals) = trj_pbf(trj)%dchm_vals(:n_vals,buf_ndx)
+                 endif
+               endif
+             end do
+             ndx = dchm_buf_ndx(spc)
+             var_name = 'dchm_' // trim(chem_dname_table(dm,ndx)) // '_traj'
+!            write(var_name,'(a,''_traj'')') trim(chem_dname_table(dm,ndx))
+             err_mes = 'trajectory_write_file: failed to get '// trim(var_name) // ' id'
+             call handle_ncerr( nf_inq_varid( ncid, trim(var_name), varid ),trim(err_mes) )
+             err_mes = 'trajectory_write_file: failed to write ' // trim(var_name)
+             call handle_ncerr( nf_put_vara_real( ncid, varid, (/ 1,time_ndx /), (/ n_traj,n_vals /), &
+                                                  holder ),trim(err_mes) )
+           endif
+         end do
+     end select
+   end do pkg_loop
+
+   n_vals = 0
+
+   ios = nf_close( ncid )
+
+   if( allocated( holder ) ) then
+     deallocate( holder )
+   endif
+
+   end subroutine trajectory_write_file
+
+   integer function get_spc_buf_ndx( ncnt, list, match_name )
+
+   integer, intent(in)          :: ncnt
+   character(len=*), intent(in) :: match_name
+   character(len=*), intent(in) :: list(:)
+
+   integer :: spc
+
+   get_spc_buf_ndx = -1
+   do spc = 1,ncnt
+     if( trim(match_name) == trim(list(spc)) ) then
+       get_spc_buf_ndx = spc
+       exit
+     endif
+   end do
+
+   end function get_spc_buf_ndx
+
+   integer function get_dchm_buf_ndx( ncnt, list, match_ndx )
+
+   integer, intent(in)          :: ncnt
+   integer, intent(in)          :: match_ndx
+   integer, intent(in)          :: list(:)
+
+   integer :: spc
+
+   get_dchm_buf_ndx = -1
+   do spc = 1,ncnt
+     if( match_ndx == list(spc) ) then
+       get_dchm_buf_ndx = spc
+       exit
+     endif
+   end do
+
+   end function get_dchm_buf_ndx
+
+   subroutine handle_ncerr( ret, mes )
+!---------------------------------------------------------------------
+!	... netcdf error handling routine
+!---------------------------------------------------------------------
+!---------------------------------------------------------------------
+!	... dummy arguments
+!---------------------------------------------------------------------
+   integer, intent(in) :: ret
+   character(len=*), intent(in) :: mes
+
+include 'netcdf.inc'
+
+   if( ret /= nf_noerr ) then
+      call wrf_message( trim(mes) )
+      call wrf_message( trim(nf_strerror(ret)) )
+      call wrf_abort
+   endif
+
+   end subroutine handle_ncerr
+#endif
+
+   subroutine trajmapproj (grid,config_flags,ts_proj)
+
+   use module_domain
+   use module_llxy
+   use module_configure, only : grid_config_rec_type, model_config_rec
+   use module_dm, only : wrf_dm_min_real
+
+   IMPLICIT NONE
+
+
+!------------------------------------------------------------------------
+! Arguments
+!------------------------------------------------------------------------
+   TYPE(domain), INTENT(IN) :: grid
+   TYPE(grid_config_rec_type) , INTENT(IN)  :: config_flags
+   TYPE(PROJ_INFO), INTENT(out) :: ts_proj
+
+!------------------------------------------------------------------------
+! Local variables
+!------------------------------------------------------------------------
+   REAL :: ts_rx, ts_ry, ts_xlat, ts_xlong, ts_hgt
+   REAL :: known_lat, known_lon
+
+   INTEGER :: ids, ide, jds, jde, kds, kde,        &
+              ims, ime, jms, jme, kms, kme,        &
+              ips, ipe, jps, jpe, kps, kpe
+
+   TYPE (grid_config_rec_type)               :: config_flags_temp
+
+   config_flags_temp = config_flags
+
+   call get_ijk_from_grid ( grid ,                               &
+                            ids, ide, jds, jde, kds, kde,        &
+                            ims, ime, jms, jme, kms, kme,        &
+                            ips, ipe, jps, jpe, kps, kpe )
+
+   call model_to_grid_config_rec ( grid%id , model_config_rec , config_flags_temp )
+
+
+!------------------------------------------------------------------------
+! Set up map transformation structure
+!------------------------------------------------------------------------
+   call map_init( ts_proj )
+
+   IF (ips <= 1 .AND. 1 <= ipe .AND. jps <= 1 .AND. 1 <= jpe) THEN
+      known_lat = grid%xlat(1,1)
+      known_lon = grid%xlong(1,1)
+   ELSE
+      known_lat = 9999.
+      known_lon = 9999.
+   END IF
+   known_lat = wrf_dm_min_real(known_lat)
+   known_lon = wrf_dm_min_real(known_lon)
+
+
+   select case( config_flags%map_proj )
+!------------------------------------------------------------------------
+! Mercator
+!------------------------------------------------------------------------
+     case( PROJ_MERC )
+       call map_set(PROJ_MERC, ts_proj,               &
+                    truelat1 = config_flags%truelat1, &
+                    lat1     = known_lat,             &
+                    lon1     = known_lon,             &
+                    knowni   = 1.,                    &
+                    knownj   = 1.,                    &
+                    dx       = config_flags%dx)
+!------------------------------------------------------------------------
+! Lambert conformal
+!------------------------------------------------------------------------
+     case( PROJ_LC )
+       call map_set(PROJ_LC, ts_proj,                  &
+                    truelat1 = config_flags%truelat1,  &
+                    truelat2 = config_flags%truelat2,  &
+                    stdlon   = config_flags%stand_lon, &
+                    lat1     = known_lat,              &
+                    lon1     = known_lon,              &
+                    knowni   = 1.,                     &
+                    knownj   = 1.,                     &
+                    dx       = config_flags%dx)
+!------------------------------------------------------------------------
+! Polar stereographic
+!------------------------------------------------------------------------
+     case( PROJ_PS )
+       call map_set(PROJ_PS, ts_proj,                  &
+                    truelat1 = config_flags%truelat1,  &
+                    stdlon   = config_flags%stand_lon, &
+                    lat1     = known_lat,              &
+                    lon1     = known_lon,              &
+                    knowni   = 1.,                     &
+                    knownj   = 1.,                     &
+                    dx       = config_flags%dx)
+!------------------------------------------------------------------------
+! Cassini (global ARW)
+!------------------------------------------------------------------------
+     case( PROJ_CASSINI )
+       call map_set(PROJ_CASSINI, ts_proj,                            &
+                    latinc   = grid%dy*360.0/(2.0*EARTH_RADIUS_M*PI), &
+                    loninc   = grid%dx*360.0/(2.0*EARTH_RADIUS_M*PI), &
+                    lat1     = known_lat,                             &
+                    lon1     = known_lon,                             &
+! We still need to get POLE_LAT and POLE_LON metadata variables before
+!   this will work for rotated poles.
+                    lat0     = 90.0,                                  &
+                    lon0     = 0.0,                                   &
+                    knowni   = 1.,                                    &
+                    knownj   = 1.,                                    &
+                    stdlon   = config_flags%stand_lon)
+!------------------------------------------------------------------------
+! Rotated latitude-longitude
+!------------------------------------------------------------------------
+     case( PROJ_ROTLL )
+       call map_set(PROJ_ROTLL, ts_proj,                      &
+                    ixdim    = grid%e_we-1,                   &
+                    jydim    = grid%e_sn-1,                   &
+                    phi      = real(grid%e_sn-2)*grid%dy/2.0, &
+                    lambda   = real(grid%e_we-2)*grid%dx,     &
+                    lat1     = config_flags%cen_lat,          &
+                    lon1     = config_flags%cen_lon,          &
+                    latinc   = grid%dy,                       &
+                    loninc   = grid%dx,                       &
+                    stagger  = HH)
+   end select
+
+   end subroutine trajmapproj
+
+   subroutine UPCASE( lstring )
+!----------------------------------------------------------------------
+!       ... Convert character string lstring to upper case
+!----------------------------------------------------------------------
+   implicit none
+
+!-----------------------------------------------------------------------
+!	... Dummy args
+!-----------------------------------------------------------------------
+   character(len=*), intent(inout) ::  lstring
+
+!-----------------------------------------------------------------------
+!	... Local variables
+!-----------------------------------------------------------------------
+   integer :: i
+
+   do i = 1,LEN_TRIM( lstring )
+     if( ICHAR(lstring(i:i)) >= 97 .and.  ICHAR(lstring(i:i)) <= 122 ) then
+       lstring(i:i) = CHAR(ICHAR(lstring(i:i)) - 32)
+     end if
+   end do
+
+   end subroutine UPCASE
+
+#endif
+
+   end module module_trajectory
diff --git a/wrfv2_fire/share/output_wrf.F b/wrfv2_fire/share/output_wrf.F
index 88e81913..f065888b 100644
--- a/wrfv2_fire/share/output_wrf.F
+++ b/wrfv2_fire/share/output_wrf.F
@@ -39,9 +39,9 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
     INTEGER km_opt, diff_opt, damp_opt,  &
             mp_physics, ra_lw_physics, ra_sw_physics, sf_sfclay_physics, &
             sf_surface_physics, bl_pbl_physics, cu_physics, hypsometric_opt, sf_lake_physics, &
-            use_theta_m, use_maxw_level, use_trop_level
+            use_theta_m, use_maxw_level, use_trop_level,hybrid_opt, gwd_opt
     INTEGER swint_opt, aer_type,aer_aod550_opt,aer_angexp_opt,aer_ssa_opt,aer_asy_opt, aer_opt
-    REAL    aer_aod550_val,aer_angexp_val,aer_ssa_val,aer_asy_val
+    REAL    aer_aod550_val,aer_angexp_val,aer_ssa_val,aer_asy_val,etac
     REAL    khdif, kvdif, swrad_scat, dampcoef,radt,bldt,cudt
     REAL    dt, adapt_dt_start, adapt_dt_min, adapt_dt_max
     INTEGER sf_urban_physics, w_damping, smooth_option, feedback, surface_input_source, sst_update
@@ -153,8 +153,8 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
     call nl_get_aer_asy_opt        ( grid%id,  aer_asy_opt        )
     call nl_get_aer_aod550_val     ( grid%id,  aer_aod550_val     )
     call nl_get_aer_angexp_val     ( grid%id,  aer_angexp_val     )
-    call nl_get_aer_ssa_opt        ( grid%id,  aer_ssa_val        )
-    call nl_get_aer_asy_opt        ( grid%id,  aer_asy_val        )
+    call nl_get_aer_ssa_val        ( grid%id,  aer_ssa_val        )
+    call nl_get_aer_asy_val        ( grid%id,  aer_asy_val        )
     call nl_get_sf_lake_physics    ( grid%id,  sf_lake_physics    )
 
 #if (EM_CORE == 1)
@@ -162,6 +162,7 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
     adapt_dt_min = grid%min_time_step
     adapt_dt_max = grid%max_time_step
     adapt_dt_start = grid%starting_time_step
+    call nl_get_gwd_opt            ( grid%id,  gwd_opt            )
 #endif
 
 ! add nml variables in 2.2
@@ -194,6 +195,14 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
     CALL nl_get_ysu_topdown_pblmix  ( grid%id , ysu_topdown_pblmix )
     CALL nl_get_grav_settling  ( grid%id , grav_settling )
 
+#if ( HYBRID_COORD==1 )
+    CALL nl_get_hybrid_opt ( 1       , hybrid_opt )
+    CALL nl_get_etac       ( 1       , etac )
+    IF ( hybrid_opt .EQ. 0 ) THEN
+       etac = 0.
+    END IF
+#endif
+
     IF ( grid_fdda == 1 ) THEN
     CALL nl_get_fgdt       ( grid%id , fgdt )
     CALL nl_get_guv        ( grid%id , guv )
@@ -648,10 +657,13 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
          CALL wrf_put_dom_ti_integer ( fid, 'USE_MAXW_LEVEL', use_maxw_level , 1 , ierr )
          CALL wrf_put_dom_ti_integer ( fid, 'USE_TROP_LEVEL', use_trop_level , 1 , ierr )
       END IF
+    ibuf(1) = gwd_opt
+    CALL wrf_put_dom_ti_integer ( fid, 'GWD_OPT' ,  ibuf , 1 , ierr )
+    CALL wrf_put_dom_ti_integer ( fid, 'SF_URBAN_PHYSICS', sf_urban_physics , 1 , ierr )
+    CALL wrf_put_dom_ti_integer ( fid, 'SF_OCEAN_PHYSICS', config_flags%sf_ocean_physics     , 1 , ierr ) 
 #endif
 
       IF ( switch .EQ. history_only ) THEN
-      CALL wrf_put_dom_ti_integer ( fid, 'SF_URBAN_PHYSICS', sf_urban_physics , 1 , ierr )
       CALL wrf_put_dom_ti_integer ( fid, 'SHCU_PHYSICS',     config_flags%shcu_physics , 1 , ierr ) 
       CALL wrf_put_dom_ti_integer ( fid, 'MFSHCONV',         config_flags%mfshconv , 1 , ierr ) 
       CALL wrf_put_dom_ti_integer ( fid, 'FEEDBACK', feedback , 1 , ierr )
@@ -737,7 +749,6 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
       CALL wrf_put_dom_ti_real      ( fid, 'BUCKET_MM',   config_flags%bucket_mm   , 1 , ierr ) 
       CALL wrf_put_dom_ti_real      ( fid, 'BUCKET_J',    config_flags%bucket_J    , 1 , ierr ) 
       CALL wrf_put_dom_ti_real      ( fid, 'PREC_ACC_DT', config_flags%prec_acc_dt , 1 , ierr ) 
-      CALL wrf_put_dom_ti_integer   ( fid, 'SF_OCEAN_PHYSICS',     config_flags%sf_ocean_physics     , 1 , ierr ) 
       CALL wrf_put_dom_ti_integer   ( fid, 'ISFTCFLX',    config_flags%isftcflx    , 1 , ierr ) 
       CALL wrf_put_dom_ti_integer   ( fid, 'ISHALLOW',    config_flags%ishallow    , 1 , ierr ) 
       CALL wrf_put_dom_ti_integer   ( fid, 'ISFFLX',      config_flags%isfflx      , 1 , ierr ) 
@@ -932,6 +943,18 @@ SUBROUTINE output_wrf ( fid , grid , config_flags, switch , ierr )
         CALL wrf_put_dom_td_char ( fid , 'NEXTBDYTIME' ,  current_date(1:19), next_datestr(1:19), ierr )
     ENDIF
 
+    !  Add the hybrid vertical coordinate metadata.
+
+#if (EM_CORE == 1)
+# if ! ( HYBRID_COORD==1 )
+    CALL wrf_put_dom_ti_integer ( fid , 'HYBRID_OPT',          -1  , 1 , ierr )
+    CALL wrf_put_dom_ti_real    ( fid , 'ETAC'      ,           0. , 1 , ierr )
+# else
+    CALL wrf_put_dom_ti_integer ( fid , 'HYBRID_OPT',  hybrid_opt  , 1 , ierr )
+    CALL wrf_put_dom_ti_real    ( fid , 'ETAC'      ,  etac        , 1 , ierr )
+# endif
+#endif
+
     ! added grib2-specific metadata:  Todd Hutchinson 8/21/2005
     IF ( use_package( io_form ) == IO_GRIB2 ) THEN
       CALL wrf_put_dom_ti_integer ( fid , 'BACKGROUND_PROC_ID' , config_flags%background_proc_id , 1 , ierr )
diff --git a/wrfv2_fire/share/solve_interface.F b/wrfv2_fire/share/solve_interface.F
index fcdef177..be8d72cd 100644
--- a/wrfv2_fire/share/solve_interface.F
+++ b/wrfv2_fire/share/solve_interface.F
@@ -8,6 +8,9 @@ SUBROUTINE solve_interface ( grid )
    USE module_driver_constants
    USE module_configure
    USE module_wrf_error
+#if( EM_CORE == 1 )
+   USE module_trajectory, only : trajectory_driver
+#endif
 
    IMPLICIT NONE
 
@@ -30,6 +33,7 @@ SUBROUTINE solve_interface ( grid )
    TYPE (grid_config_rec_type)   :: config_flags
 
    INTEGER     :: idum1, idum2
+   CHARACTER(len=256) :: dbg_msg
 
    CALL model_to_grid_config_rec ( grid%id , model_config_rec , config_flags )
    CALL set_scalar_indices_from_config ( grid%id , idum1 , idum2 )
@@ -52,6 +56,17 @@ SUBROUTINE solve_interface ( grid )
    ENDIF
 # endif
 #endif
+
+# if ( EM_CORE == 1 )
+   if( grid%traj_opt /= no_trajectory ) then
+     write(dbg_msg,'(''solve_xface('',i2.2,''): Before call to trajectory_driver'')') grid%id
+     call wrf_debug( 200,trim(dbg_msg) )
+     call trajectory_driver( grid )
+     write(dbg_msg,'(''solve_xface('',i2.2,''): After  call to trajectory_driver'')') grid%id
+     call wrf_debug( 200,trim(dbg_msg) )
+   endif
+# endif
+
 #if (NMM_CORE == 1)
    CALL solve_nmm  ( grid , config_flags   &
 !
diff --git a/wrfv2_fire/test/em_fire/README.txt b/wrfv2_fire/test/em_fire/README.txt
index 5901ee7e..e2e1aeba 100644
--- a/wrfv2_fire/test/em_fire/README.txt
+++ b/wrfv2_fire/test/em_fire/README.txt
@@ -1,14 +1,19 @@
-The fire test problems are in subdirectories. At the moment, these are
+There are currently two fire test cases - hill_simple and two_fires.  
+The files necessary for running these are in the top-level em_fire/
+directory.  To run a fire case, it will be necessary to have files
+named 'namelist.input' and 'input_sounding' in the em_fire/ directory.
+If you wish to use one of the provided test cases,
+you will need to link them to their generic names
+(for example, for the two_fires case):
 
-small
-nested
-fireflux
+ln -sf namelist.input_two_fires namelist.input
+ln -sf input_sounding_two_fires input_sounding
 
-If you want to make your own test case subdirectory, all you need to do 
-is to create soft links for ideal.exe and wrf.exe pointing the the parent 
-directory, and to create the files namelist.input and input_sounding 
-(best by modifying a copy from another subdirectory).
+Currently the default namelist.input is linked to the hill_simple case.
+
+If you want to make your own test case, you will simply need to 
+create the files namelist.input and input_sounding that will
+correspond to your case.
+(best by modifying a copy from another case)
 
-Do not just copy one of the existing subdirectories, the soft links might not 
-be copied properly.
 
diff --git a/wrfv2_fire/test/em_fire/hill_simple/input_sounding b/wrfv2_fire/test/em_fire/input_sounding_hill_simple
similarity index 100%
rename from wrfv2_fire/test/em_fire/hill_simple/input_sounding
rename to wrfv2_fire/test/em_fire/input_sounding_hill_simple
diff --git a/wrfv2_fire/test/em_fire/two_fires/input_sounding b/wrfv2_fire/test/em_fire/input_sounding_two_fires
similarity index 100%
rename from wrfv2_fire/test/em_fire/two_fires/input_sounding
rename to wrfv2_fire/test/em_fire/input_sounding_two_fires
diff --git a/wrfv2_fire/test/em_fire/hill_simple/namelist.fire b/wrfv2_fire/test/em_fire/namelist.fire_hill_simple
similarity index 100%
rename from wrfv2_fire/test/em_fire/hill_simple/namelist.fire
rename to wrfv2_fire/test/em_fire/namelist.fire_hill_simple
diff --git a/wrfv2_fire/test/em_fire/two_fires/namelist.fire b/wrfv2_fire/test/em_fire/namelist.fire_two_fires
similarity index 100%
rename from wrfv2_fire/test/em_fire/two_fires/namelist.fire
rename to wrfv2_fire/test/em_fire/namelist.fire_two_fires
diff --git a/wrfv2_fire/test/em_fire/namelist.input b/wrfv2_fire/test/em_fire/namelist.input
new file mode 120000
index 00000000..cad76ec6
--- /dev/null
+++ b/wrfv2_fire/test/em_fire/namelist.input
@@ -0,0 +1 @@
+namelist.input_hill_simple
\ No newline at end of file
diff --git a/wrfv2_fire/test/em_fire/hill_simple/namelist.input b/wrfv2_fire/test/em_fire/namelist.input_hill_simple
similarity index 100%
rename from wrfv2_fire/test/em_fire/hill_simple/namelist.input
rename to wrfv2_fire/test/em_fire/namelist.input_hill_simple
diff --git a/wrfv2_fire/test/em_fire/two_fires/namelist.input b/wrfv2_fire/test/em_fire/namelist.input_two_fires
similarity index 100%
rename from wrfv2_fire/test/em_fire/two_fires/namelist.input
rename to wrfv2_fire/test/em_fire/namelist.input_two_fires
diff --git a/wrfv2_fire/test/em_hill2d_x/extras/input_sounding-U=10,N=0.01 b/wrfv2_fire/test/em_hill2d_x/extras/input_sounding-U=10,N=0.01
new file mode 100644
index 00000000..7556e89b
--- /dev/null
+++ b/wrfv2_fire/test/em_hill2d_x/extras/input_sounding-U=10,N=0.01
@@ -0,0 +1,602 @@
+   1000.000     288.00        0.00
+      0.00      288.00        0.00       10.00        0.00
+     50.00      288.15        0.00       10.00        0.00
+    100.00      288.29        0.00       10.00        0.00
+    150.00      288.44        0.00       10.00        0.00
+    200.00      288.59        0.00       10.00        0.00
+    250.00      288.74        0.00       10.00        0.00
+    300.00      288.88        0.00       10.00        0.00
+    350.00      289.03        0.00       10.00        0.00
+    400.00      289.18        0.00       10.00        0.00
+    450.00      289.32        0.00       10.00        0.00
+    500.00      289.47        0.00       10.00        0.00
+    550.00      289.62        0.00       10.00        0.00
+    600.00      289.77        0.00       10.00        0.00
+    650.00      289.92        0.00       10.00        0.00
+    700.00      290.06        0.00       10.00        0.00
+    750.00      290.21        0.00       10.00        0.00
+    800.00      290.36        0.00       10.00        0.00
+    850.00      290.51        0.00       10.00        0.00
+    900.00      290.66        0.00       10.00        0.00
+    950.00      290.80        0.00       10.00        0.00
+   1000.00      290.95        0.00       10.00        0.00
+   1050.00      291.10        0.00       10.00        0.00
+   1100.00      291.25        0.00       10.00        0.00
+   1150.00      291.40        0.00       10.00        0.00
+   1200.00      291.55        0.00       10.00        0.00
+   1250.00      291.69        0.00       10.00        0.00
+   1300.00      291.84        0.00       10.00        0.00
+   1350.00      291.99        0.00       10.00        0.00
+   1400.00      292.14        0.00       10.00        0.00
+   1450.00      292.29        0.00       10.00        0.00
+   1500.00      292.44        0.00       10.00        0.00
+   1550.00      292.59        0.00       10.00        0.00
+   1600.00      292.74        0.00       10.00        0.00
+   1650.00      292.89        0.00       10.00        0.00
+   1700.00      293.04        0.00       10.00        0.00
+   1750.00      293.19        0.00       10.00        0.00
+   1800.00      293.34        0.00       10.00        0.00
+   1850.00      293.49        0.00       10.00        0.00
+   1900.00      293.63        0.00       10.00        0.00
+   1950.00      293.78        0.00       10.00        0.00
+   2000.00      293.93        0.00       10.00        0.00
+   2050.00      294.08        0.00       10.00        0.00
+   2100.00      294.23        0.00       10.00        0.00
+   2150.00      294.38        0.00       10.00        0.00
+   2200.00      294.53        0.00       10.00        0.00
+   2250.00      294.68        0.00       10.00        0.00
+   2300.00      294.84        0.00       10.00        0.00
+   2350.00      294.99        0.00       10.00        0.00
+   2400.00      295.14        0.00       10.00        0.00
+   2450.00      295.29        0.00       10.00        0.00
+   2500.00      295.44        0.00       10.00        0.00
+   2550.00      295.59        0.00       10.00        0.00
+   2600.00      295.74        0.00       10.00        0.00
+   2650.00      295.89        0.00       10.00        0.00
+   2700.00      296.04        0.00       10.00        0.00
+   2750.00      296.19        0.00       10.00        0.00
+   2800.00      296.34        0.00       10.00        0.00
+   2850.00      296.49        0.00       10.00        0.00
+   2900.00      296.64        0.00       10.00        0.00
+   2950.00      296.80        0.00       10.00        0.00
+   3000.00      296.95        0.00       10.00        0.00
+   3050.00      297.10        0.00       10.00        0.00
+   3100.00      297.25        0.00       10.00        0.00
+   3150.00      297.40        0.00       10.00        0.00
+   3200.00      297.55        0.00       10.00        0.00
+   3250.00      297.71        0.00       10.00        0.00
+   3300.00      297.86        0.00       10.00        0.00
+   3350.00      298.01        0.00       10.00        0.00
+   3400.00      298.16        0.00       10.00        0.00
+   3450.00      298.31        0.00       10.00        0.00
+   3500.00      298.47        0.00       10.00        0.00
+   3550.00      298.62        0.00       10.00        0.00
+   3600.00      298.77        0.00       10.00        0.00
+   3650.00      298.92        0.00       10.00        0.00
+   3700.00      299.07        0.00       10.00        0.00
+   3750.00      299.23        0.00       10.00        0.00
+   3800.00      299.38        0.00       10.00        0.00
+   3850.00      299.53        0.00       10.00        0.00
+   3900.00      299.69        0.00       10.00        0.00
+   3950.00      299.84        0.00       10.00        0.00
+   4000.00      299.99        0.00       10.00        0.00
+   4050.00      300.14        0.00       10.00        0.00
+   4100.00      300.30        0.00       10.00        0.00
+   4150.00      300.45        0.00       10.00        0.00
+   4200.00      300.60        0.00       10.00        0.00
+   4250.00      300.76        0.00       10.00        0.00
+   4300.00      300.91        0.00       10.00        0.00
+   4350.00      301.06        0.00       10.00        0.00
+   4400.00      301.22        0.00       10.00        0.00
+   4450.00      301.37        0.00       10.00        0.00
+   4500.00      301.53        0.00       10.00        0.00
+   4550.00      301.68        0.00       10.00        0.00
+   4600.00      301.83        0.00       10.00        0.00
+   4650.00      301.99        0.00       10.00        0.00
+   4700.00      302.14        0.00       10.00        0.00
+   4750.00      302.29        0.00       10.00        0.00
+   4800.00      302.45        0.00       10.00        0.00
+   4850.00      302.60        0.00       10.00        0.00
+   4900.00      302.76        0.00       10.00        0.00
+   4950.00      302.91        0.00       10.00        0.00
+   5000.00      303.07        0.00       10.00        0.00
+   5050.00      303.22        0.00       10.00        0.00
+   5100.00      303.38        0.00       10.00        0.00
+   5150.00      303.53        0.00       10.00        0.00
+   5200.00      303.69        0.00       10.00        0.00
+   5250.00      303.84        0.00       10.00        0.00
+   5300.00      304.00        0.00       10.00        0.00
+   5350.00      304.15        0.00       10.00        0.00
+   5400.00      304.31        0.00       10.00        0.00
+   5450.00      304.46        0.00       10.00        0.00
+   5500.00      304.62        0.00       10.00        0.00
+   5550.00      304.77        0.00       10.00        0.00
+   5600.00      304.93        0.00       10.00        0.00
+   5650.00      305.08        0.00       10.00        0.00
+   5700.00      305.24        0.00       10.00        0.00
+   5750.00      305.39        0.00       10.00        0.00
+   5800.00      305.55        0.00       10.00        0.00
+   5850.00      305.71        0.00       10.00        0.00
+   5900.00      305.86        0.00       10.00        0.00
+   5950.00      306.02        0.00       10.00        0.00
+   6000.00      306.17        0.00       10.00        0.00
+   6050.00      306.33        0.00       10.00        0.00
+   6100.00      306.49        0.00       10.00        0.00
+   6150.00      306.64        0.00       10.00        0.00
+   6200.00      306.80        0.00       10.00        0.00
+   6250.00      306.95        0.00       10.00        0.00
+   6300.00      307.11        0.00       10.00        0.00
+   6350.00      307.27        0.00       10.00        0.00
+   6400.00      307.42        0.00       10.00        0.00
+   6450.00      307.58        0.00       10.00        0.00
+   6500.00      307.74        0.00       10.00        0.00
+   6550.00      307.90        0.00       10.00        0.00
+   6600.00      308.05        0.00       10.00        0.00
+   6650.00      308.21        0.00       10.00        0.00
+   6700.00      308.37        0.00       10.00        0.00
+   6750.00      308.52        0.00       10.00        0.00
+   6800.00      308.68        0.00       10.00        0.00
+   6850.00      308.84        0.00       10.00        0.00
+   6900.00      309.00        0.00       10.00        0.00
+   6950.00      309.15        0.00       10.00        0.00
+   7000.00      309.31        0.00       10.00        0.00
+   7050.00      309.47        0.00       10.00        0.00
+   7100.00      309.63        0.00       10.00        0.00
+   7150.00      309.79        0.00       10.00        0.00
+   7200.00      309.94        0.00       10.00        0.00
+   7250.00      310.10        0.00       10.00        0.00
+   7300.00      310.26        0.00       10.00        0.00
+   7350.00      310.42        0.00       10.00        0.00
+   7400.00      310.58        0.00       10.00        0.00
+   7450.00      310.73        0.00       10.00        0.00
+   7500.00      310.89        0.00       10.00        0.00
+   7550.00      311.05        0.00       10.00        0.00
+   7600.00      311.21        0.00       10.00        0.00
+   7650.00      311.37        0.00       10.00        0.00
+   7700.00      311.53        0.00       10.00        0.00
+   7750.00      311.69        0.00       10.00        0.00
+   7800.00      311.85        0.00       10.00        0.00
+   7850.00      312.00        0.00       10.00        0.00
+   7900.00      312.16        0.00       10.00        0.00
+   7950.00      312.32        0.00       10.00        0.00
+   8000.00      312.48        0.00       10.00        0.00
+   8050.00      312.64        0.00       10.00        0.00
+   8100.00      312.80        0.00       10.00        0.00
+   8150.00      312.96        0.00       10.00        0.00
+   8200.00      313.12        0.00       10.00        0.00
+   8250.00      313.28        0.00       10.00        0.00
+   8300.00      313.44        0.00       10.00        0.00
+   8350.00      313.60        0.00       10.00        0.00
+   8400.00      313.76        0.00       10.00        0.00
+   8450.00      313.92        0.00       10.00        0.00
+   8500.00      314.08        0.00       10.00        0.00
+   8550.00      314.24        0.00       10.00        0.00
+   8600.00      314.40        0.00       10.00        0.00
+   8650.00      314.56        0.00       10.00        0.00
+   8700.00      314.72        0.00       10.00        0.00
+   8750.00      314.88        0.00       10.00        0.00
+   8800.00      315.04        0.00       10.00        0.00
+   8850.00      315.20        0.00       10.00        0.00
+   8900.00      315.36        0.00       10.00        0.00
+   8950.00      315.52        0.00       10.00        0.00
+   9000.00      315.69        0.00       10.00        0.00
+   9050.00      315.85        0.00       10.00        0.00
+   9100.00      316.01        0.00       10.00        0.00
+   9150.00      316.17        0.00       10.00        0.00
+   9200.00      316.33        0.00       10.00        0.00
+   9250.00      316.49        0.00       10.00        0.00
+   9300.00      316.65        0.00       10.00        0.00
+   9350.00      316.81        0.00       10.00        0.00
+   9400.00      316.98        0.00       10.00        0.00
+   9450.00      317.14        0.00       10.00        0.00
+   9500.00      317.30        0.00       10.00        0.00
+   9550.00      317.46        0.00       10.00        0.00
+   9600.00      317.62        0.00       10.00        0.00
+   9650.00      317.78        0.00       10.00        0.00
+   9700.00      317.95        0.00       10.00        0.00
+   9750.00      318.11        0.00       10.00        0.00
+   9800.00      318.27        0.00       10.00        0.00
+   9850.00      318.43        0.00       10.00        0.00
+   9900.00      318.60        0.00       10.00        0.00
+   9950.00      318.76        0.00       10.00        0.00
+  10000.00      318.92        0.00       10.00        0.00
+  10050.00      319.08        0.00       10.00        0.00
+  10100.00      319.25        0.00       10.00        0.00
+  10150.00      319.41        0.00       10.00        0.00
+  10200.00      319.57        0.00       10.00        0.00
+  10250.00      319.74        0.00       10.00        0.00
+  10300.00      319.90        0.00       10.00        0.00
+  10350.00      320.06        0.00       10.00        0.00
+  10400.00      320.22        0.00       10.00        0.00
+  10450.00      320.39        0.00       10.00        0.00
+  10500.00      320.55        0.00       10.00        0.00
+  10550.00      320.72        0.00       10.00        0.00
+  10600.00      320.88        0.00       10.00        0.00
+  10650.00      321.04        0.00       10.00        0.00
+  10700.00      321.21        0.00       10.00        0.00
+  10750.00      321.37        0.00       10.00        0.00
+  10800.00      321.53        0.00       10.00        0.00
+  10850.00      321.70        0.00       10.00        0.00
+  10900.00      321.86        0.00       10.00        0.00
+  10950.00      322.03        0.00       10.00        0.00
+  11000.00      322.19        0.00       10.00        0.00
+  11050.00      322.35        0.00       10.00        0.00
+  11100.00      322.52        0.00       10.00        0.00
+  11150.00      322.68        0.00       10.00        0.00
+  11200.00      322.85        0.00       10.00        0.00
+  11250.00      323.01        0.00       10.00        0.00
+  11300.00      323.18        0.00       10.00        0.00
+  11350.00      323.34        0.00       10.00        0.00
+  11400.00      323.51        0.00       10.00        0.00
+  11450.00      323.67        0.00       10.00        0.00
+  11500.00      323.84        0.00       10.00        0.00
+  11550.00      324.00        0.00       10.00        0.00
+  11600.00      324.17        0.00       10.00        0.00
+  11650.00      324.33        0.00       10.00        0.00
+  11700.00      324.50        0.00       10.00        0.00
+  11750.00      324.66        0.00       10.00        0.00
+  11800.00      324.83        0.00       10.00        0.00
+  11850.00      325.00        0.00       10.00        0.00
+  11900.00      325.16        0.00       10.00        0.00
+  11950.00      325.33        0.00       10.00        0.00
+  12000.00      325.49        0.00       10.00        0.00
+  12050.00      325.66        0.00       10.00        0.00
+  12100.00      325.83        0.00       10.00        0.00
+  12150.00      325.99        0.00       10.00        0.00
+  12200.00      326.16        0.00       10.00        0.00
+  12250.00      326.32        0.00       10.00        0.00
+  12300.00      326.49        0.00       10.00        0.00
+  12350.00      326.66        0.00       10.00        0.00
+  12400.00      326.82        0.00       10.00        0.00
+  12450.00      326.99        0.00       10.00        0.00
+  12500.00      327.16        0.00       10.00        0.00
+  12550.00      327.32        0.00       10.00        0.00
+  12600.00      327.49        0.00       10.00        0.00
+  12650.00      327.66        0.00       10.00        0.00
+  12700.00      327.82        0.00       10.00        0.00
+  12750.00      327.99        0.00       10.00        0.00
+  12800.00      328.16        0.00       10.00        0.00
+  12850.00      328.33        0.00       10.00        0.00
+  12900.00      328.49        0.00       10.00        0.00
+  12950.00      328.66        0.00       10.00        0.00
+  13000.00      328.83        0.00       10.00        0.00
+  13050.00      329.00        0.00       10.00        0.00
+  13100.00      329.16        0.00       10.00        0.00
+  13150.00      329.33        0.00       10.00        0.00
+  13200.00      329.50        0.00       10.00        0.00
+  13250.00      329.67        0.00       10.00        0.00
+  13300.00      329.84        0.00       10.00        0.00
+  13350.00      330.01        0.00       10.00        0.00
+  13400.00      330.17        0.00       10.00        0.00
+  13450.00      330.34        0.00       10.00        0.00
+  13500.00      330.51        0.00       10.00        0.00
+  13550.00      330.68        0.00       10.00        0.00
+  13600.00      330.85        0.00       10.00        0.00
+  13650.00      331.02        0.00       10.00        0.00
+  13700.00      331.19        0.00       10.00        0.00
+  13750.00      331.35        0.00       10.00        0.00
+  13800.00      331.52        0.00       10.00        0.00
+  13850.00      331.69        0.00       10.00        0.00
+  13900.00      331.86        0.00       10.00        0.00
+  13950.00      332.03        0.00       10.00        0.00
+  14000.00      332.20        0.00       10.00        0.00
+  14050.00      332.37        0.00       10.00        0.00
+  14100.00      332.54        0.00       10.00        0.00
+  14150.00      332.71        0.00       10.00        0.00
+  14200.00      332.88        0.00       10.00        0.00
+  14250.00      333.05        0.00       10.00        0.00
+  14300.00      333.22        0.00       10.00        0.00
+  14350.00      333.39        0.00       10.00        0.00
+  14400.00      333.56        0.00       10.00        0.00
+  14450.00      333.73        0.00       10.00        0.00
+  14500.00      333.90        0.00       10.00        0.00
+  14550.00      334.07        0.00       10.00        0.00
+  14600.00      334.24        0.00       10.00        0.00
+  14650.00      334.41        0.00       10.00        0.00
+  14700.00      334.58        0.00       10.00        0.00
+  14750.00      334.75        0.00       10.00        0.00
+  14800.00      334.92        0.00       10.00        0.00
+  14850.00      335.09        0.00       10.00        0.00
+  14900.00      335.26        0.00       10.00        0.00
+  14950.00      335.43        0.00       10.00        0.00
+  15000.00      335.61        0.00       10.00        0.00
+  15050.00      335.78        0.00       10.00        0.00
+  15100.00      335.95        0.00       10.00        0.00
+  15150.00      336.12        0.00       10.00        0.00
+  15200.00      336.29        0.00       10.00        0.00
+  15250.00      336.46        0.00       10.00        0.00
+  15300.00      336.63        0.00       10.00        0.00
+  15350.00      336.81        0.00       10.00        0.00
+  15400.00      336.98        0.00       10.00        0.00
+  15450.00      337.15        0.00       10.00        0.00
+  15500.00      337.32        0.00       10.00        0.00
+  15550.00      337.49        0.00       10.00        0.00
+  15600.00      337.67        0.00       10.00        0.00
+  15650.00      337.84        0.00       10.00        0.00
+  15700.00      338.01        0.00       10.00        0.00
+  15750.00      338.18        0.00       10.00        0.00
+  15800.00      338.35        0.00       10.00        0.00
+  15850.00      338.53        0.00       10.00        0.00
+  15900.00      338.70        0.00       10.00        0.00
+  15950.00      338.87        0.00       10.00        0.00
+  16000.00      339.05        0.00       10.00        0.00
+  16050.00      339.22        0.00       10.00        0.00
+  16100.00      339.39        0.00       10.00        0.00
+  16150.00      339.56        0.00       10.00        0.00
+  16200.00      339.74        0.00       10.00        0.00
+  16250.00      339.91        0.00       10.00        0.00
+  16300.00      340.08        0.00       10.00        0.00
+  16350.00      340.26        0.00       10.00        0.00
+  16400.00      340.43        0.00       10.00        0.00
+  16450.00      340.60        0.00       10.00        0.00
+  16500.00      340.78        0.00       10.00        0.00
+  16550.00      340.95        0.00       10.00        0.00
+  16600.00      341.13        0.00       10.00        0.00
+  16650.00      341.30        0.00       10.00        0.00
+  16700.00      341.47        0.00       10.00        0.00
+  16750.00      341.65        0.00       10.00        0.00
+  16800.00      341.82        0.00       10.00        0.00
+  16850.00      342.00        0.00       10.00        0.00
+  16900.00      342.17        0.00       10.00        0.00
+  16950.00      342.35        0.00       10.00        0.00
+  17000.00      342.52        0.00       10.00        0.00
+  17050.00      342.70        0.00       10.00        0.00
+  17100.00      342.87        0.00       10.00        0.00
+  17150.00      343.05        0.00       10.00        0.00
+  17200.00      343.22        0.00       10.00        0.00
+  17250.00      343.40        0.00       10.00        0.00
+  17300.00      343.57        0.00       10.00        0.00
+  17350.00      343.75        0.00       10.00        0.00
+  17400.00      343.92        0.00       10.00        0.00
+  17450.00      344.10        0.00       10.00        0.00
+  17500.00      344.27        0.00       10.00        0.00
+  17550.00      344.45        0.00       10.00        0.00
+  17600.00      344.62        0.00       10.00        0.00
+  17650.00      344.80        0.00       10.00        0.00
+  17700.00      344.97        0.00       10.00        0.00
+  17750.00      345.15        0.00       10.00        0.00
+  17800.00      345.33        0.00       10.00        0.00
+  17850.00      345.50        0.00       10.00        0.00
+  17900.00      345.68        0.00       10.00        0.00
+  17950.00      345.86        0.00       10.00        0.00
+  18000.00      346.03        0.00       10.00        0.00
+  18050.00      346.21        0.00       10.00        0.00
+  18100.00      346.38        0.00       10.00        0.00
+  18150.00      346.56        0.00       10.00        0.00
+  18200.00      346.74        0.00       10.00        0.00
+  18250.00      346.92        0.00       10.00        0.00
+  18300.00      347.09        0.00       10.00        0.00
+  18350.00      347.27        0.00       10.00        0.00
+  18400.00      347.45        0.00       10.00        0.00
+  18450.00      347.62        0.00       10.00        0.00
+  18500.00      347.80        0.00       10.00        0.00
+  18550.00      347.98        0.00       10.00        0.00
+  18600.00      348.16        0.00       10.00        0.00
+  18650.00      348.33        0.00       10.00        0.00
+  18700.00      348.51        0.00       10.00        0.00
+  18750.00      348.69        0.00       10.00        0.00
+  18800.00      348.87        0.00       10.00        0.00
+  18850.00      349.04        0.00       10.00        0.00
+  18900.00      349.22        0.00       10.00        0.00
+  18950.00      349.40        0.00       10.00        0.00
+  19000.00      349.58        0.00       10.00        0.00
+  19050.00      349.76        0.00       10.00        0.00
+  19100.00      349.94        0.00       10.00        0.00
+  19150.00      350.11        0.00       10.00        0.00
+  19200.00      350.29        0.00       10.00        0.00
+  19250.00      350.47        0.00       10.00        0.00
+  19300.00      350.65        0.00       10.00        0.00
+  19350.00      350.83        0.00       10.00        0.00
+  19400.00      351.01        0.00       10.00        0.00
+  19450.00      351.19        0.00       10.00        0.00
+  19500.00      351.37        0.00       10.00        0.00
+  19550.00      351.55        0.00       10.00        0.00
+  19600.00      351.72        0.00       10.00        0.00
+  19650.00      351.90        0.00       10.00        0.00
+  19700.00      352.08        0.00       10.00        0.00
+  19750.00      352.26        0.00       10.00        0.00
+  19800.00      352.44        0.00       10.00        0.00
+  19850.00      352.62        0.00       10.00        0.00
+  19900.00      352.80        0.00       10.00        0.00
+  19950.00      352.98        0.00       10.00        0.00
+  20000.00      353.16        0.00       10.00        0.00
+  20050.00      353.34        0.00       10.00        0.00
+  20100.00      353.52        0.00       10.00        0.00
+  20150.00      353.70        0.00       10.00        0.00
+  20200.00      353.88        0.00       10.00        0.00
+  20250.00      354.06        0.00       10.00        0.00
+  20300.00      354.24        0.00       10.00        0.00
+  20350.00      354.43        0.00       10.00        0.00
+  20400.00      354.61        0.00       10.00        0.00
+  20450.00      354.79        0.00       10.00        0.00
+  20500.00      354.97        0.00       10.00        0.00
+  20550.00      355.15        0.00       10.00        0.00
+  20600.00      355.33        0.00       10.00        0.00
+  20650.00      355.51        0.00       10.00        0.00
+  20700.00      355.69        0.00       10.00        0.00
+  20750.00      355.87        0.00       10.00        0.00
+  20800.00      356.06        0.00       10.00        0.00
+  20850.00      356.24        0.00       10.00        0.00
+  20900.00      356.42        0.00       10.00        0.00
+  20950.00      356.60        0.00       10.00        0.00
+  21000.00      356.78        0.00       10.00        0.00
+  21050.00      356.96        0.00       10.00        0.00
+  21100.00      357.15        0.00       10.00        0.00
+  21150.00      357.33        0.00       10.00        0.00
+  21200.00      357.51        0.00       10.00        0.00
+  21250.00      357.69        0.00       10.00        0.00
+  21300.00      357.88        0.00       10.00        0.00
+  21350.00      358.06        0.00       10.00        0.00
+  21400.00      358.24        0.00       10.00        0.00
+  21450.00      358.42        0.00       10.00        0.00
+  21500.00      358.61        0.00       10.00        0.00
+  21550.00      358.79        0.00       10.00        0.00
+  21600.00      358.97        0.00       10.00        0.00
+  21650.00      359.16        0.00       10.00        0.00
+  21700.00      359.34        0.00       10.00        0.00
+  21750.00      359.52        0.00       10.00        0.00
+  21800.00      359.71        0.00       10.00        0.00
+  21850.00      359.89        0.00       10.00        0.00
+  21900.00      360.07        0.00       10.00        0.00
+  21950.00      360.26        0.00       10.00        0.00
+  22000.00      360.44        0.00       10.00        0.00
+  22050.00      360.62        0.00       10.00        0.00
+  22100.00      360.81        0.00       10.00        0.00
+  22150.00      360.99        0.00       10.00        0.00
+  22200.00      361.18        0.00       10.00        0.00
+  22250.00      361.36        0.00       10.00        0.00
+  22300.00      361.54        0.00       10.00        0.00
+  22350.00      361.73        0.00       10.00        0.00
+  22400.00      361.91        0.00       10.00        0.00
+  22450.00      362.10        0.00       10.00        0.00
+  22500.00      362.28        0.00       10.00        0.00
+  22550.00      362.47        0.00       10.00        0.00
+  22600.00      362.65        0.00       10.00        0.00
+  22650.00      362.84        0.00       10.00        0.00
+  22700.00      363.02        0.00       10.00        0.00
+  22750.00      363.21        0.00       10.00        0.00
+  22800.00      363.39        0.00       10.00        0.00
+  22850.00      363.58        0.00       10.00        0.00
+  22900.00      363.76        0.00       10.00        0.00
+  22950.00      363.95        0.00       10.00        0.00
+  23000.00      364.13        0.00       10.00        0.00
+  23050.00      364.32        0.00       10.00        0.00
+  23100.00      364.51        0.00       10.00        0.00
+  23150.00      364.69        0.00       10.00        0.00
+  23200.00      364.88        0.00       10.00        0.00
+  23250.00      365.06        0.00       10.00        0.00
+  23300.00      365.25        0.00       10.00        0.00
+  23350.00      365.44        0.00       10.00        0.00
+  23400.00      365.62        0.00       10.00        0.00
+  23450.00      365.81        0.00       10.00        0.00
+  23500.00      366.00        0.00       10.00        0.00
+  23550.00      366.18        0.00       10.00        0.00
+  23600.00      366.37        0.00       10.00        0.00
+  23650.00      366.56        0.00       10.00        0.00
+  23700.00      366.74        0.00       10.00        0.00
+  23750.00      366.93        0.00       10.00        0.00
+  23800.00      367.12        0.00       10.00        0.00
+  23850.00      367.30        0.00       10.00        0.00
+  23900.00      367.49        0.00       10.00        0.00
+  23950.00      367.68        0.00       10.00        0.00
+  24000.00      367.87        0.00       10.00        0.00
+  24050.00      368.05        0.00       10.00        0.00
+  24100.00      368.24        0.00       10.00        0.00
+  24150.00      368.43        0.00       10.00        0.00
+  24200.00      368.62        0.00       10.00        0.00
+  24250.00      368.81        0.00       10.00        0.00
+  24300.00      368.99        0.00       10.00        0.00
+  24350.00      369.18        0.00       10.00        0.00
+  24400.00      369.37        0.00       10.00        0.00
+  24450.00      369.56        0.00       10.00        0.00
+  24500.00      369.75        0.00       10.00        0.00
+  24550.00      369.94        0.00       10.00        0.00
+  24600.00      370.12        0.00       10.00        0.00
+  24650.00      370.31        0.00       10.00        0.00
+  24700.00      370.50        0.00       10.00        0.00
+  24750.00      370.69        0.00       10.00        0.00
+  24800.00      370.88        0.00       10.00        0.00
+  24850.00      371.07        0.00       10.00        0.00
+  24900.00      371.26        0.00       10.00        0.00
+  24950.00      371.45        0.00       10.00        0.00
+  25000.00      371.64        0.00       10.00        0.00
+  25050.00      371.83        0.00       10.00        0.00
+  25100.00      372.02        0.00       10.00        0.00
+  25150.00      372.21        0.00       10.00        0.00
+  25200.00      372.40        0.00       10.00        0.00
+  25250.00      372.59        0.00       10.00        0.00
+  25300.00      372.78        0.00       10.00        0.00
+  25350.00      372.97        0.00       10.00        0.00
+  25400.00      373.16        0.00       10.00        0.00
+  25450.00      373.35        0.00       10.00        0.00
+  25500.00      373.54        0.00       10.00        0.00
+  25550.00      373.73        0.00       10.00        0.00
+  25600.00      373.92        0.00       10.00        0.00
+  25650.00      374.11        0.00       10.00        0.00
+  25700.00      374.30        0.00       10.00        0.00
+  25750.00      374.49        0.00       10.00        0.00
+  25800.00      374.68        0.00       10.00        0.00
+  25850.00      374.87        0.00       10.00        0.00
+  25900.00      375.06        0.00       10.00        0.00
+  25950.00      375.26        0.00       10.00        0.00
+  26000.00      375.45        0.00       10.00        0.00
+  26050.00      375.64        0.00       10.00        0.00
+  26100.00      375.83        0.00       10.00        0.00
+  26150.00      376.02        0.00       10.00        0.00
+  26200.00      376.21        0.00       10.00        0.00
+  26250.00      376.41        0.00       10.00        0.00
+  26300.00      376.60        0.00       10.00        0.00
+  26350.00      376.79        0.00       10.00        0.00
+  26400.00      376.98        0.00       10.00        0.00
+  26450.00      377.17        0.00       10.00        0.00
+  26500.00      377.37        0.00       10.00        0.00
+  26550.00      377.56        0.00       10.00        0.00
+  26600.00      377.75        0.00       10.00        0.00
+  26650.00      377.94        0.00       10.00        0.00
+  26700.00      378.14        0.00       10.00        0.00
+  26750.00      378.33        0.00       10.00        0.00
+  26800.00      378.52        0.00       10.00        0.00
+  26850.00      378.72        0.00       10.00        0.00
+  26900.00      378.91        0.00       10.00        0.00
+  26950.00      379.10        0.00       10.00        0.00
+  27000.00      379.30        0.00       10.00        0.00
+  27050.00      379.49        0.00       10.00        0.00
+  27100.00      379.68        0.00       10.00        0.00
+  27150.00      379.88        0.00       10.00        0.00
+  27200.00      380.07        0.00       10.00        0.00
+  27250.00      380.26        0.00       10.00        0.00
+  27300.00      380.46        0.00       10.00        0.00
+  27350.00      380.65        0.00       10.00        0.00
+  27400.00      380.85        0.00       10.00        0.00
+  27450.00      381.04        0.00       10.00        0.00
+  27500.00      381.23        0.00       10.00        0.00
+  27550.00      381.43        0.00       10.00        0.00
+  27600.00      381.62        0.00       10.00        0.00
+  27650.00      381.82        0.00       10.00        0.00
+  27700.00      382.01        0.00       10.00        0.00
+  27750.00      382.21        0.00       10.00        0.00
+  27800.00      382.40        0.00       10.00        0.00
+  27850.00      382.60        0.00       10.00        0.00
+  27900.00      382.79        0.00       10.00        0.00
+  27950.00      382.99        0.00       10.00        0.00
+  28000.00      383.18        0.00       10.00        0.00
+  28050.00      383.38        0.00       10.00        0.00
+  28100.00      383.57        0.00       10.00        0.00
+  28150.00      383.77        0.00       10.00        0.00
+  28200.00      383.97        0.00       10.00        0.00
+  28250.00      384.16        0.00       10.00        0.00
+  28300.00      384.36        0.00       10.00        0.00
+  28350.00      384.55        0.00       10.00        0.00
+  28400.00      384.75        0.00       10.00        0.00
+  28450.00      384.95        0.00       10.00        0.00
+  28500.00      385.14        0.00       10.00        0.00
+  28550.00      385.34        0.00       10.00        0.00
+  28600.00      385.54        0.00       10.00        0.00
+  28650.00      385.73        0.00       10.00        0.00
+  28700.00      385.93        0.00       10.00        0.00
+  28750.00      386.13        0.00       10.00        0.00
+  28800.00      386.32        0.00       10.00        0.00
+  28850.00      386.52        0.00       10.00        0.00
+  28900.00      386.72        0.00       10.00        0.00
+  28950.00      386.91        0.00       10.00        0.00
+  29000.00      387.11        0.00       10.00        0.00
+  29050.00      387.31        0.00       10.00        0.00
+  29100.00      387.51        0.00       10.00        0.00
+  29150.00      387.70        0.00       10.00        0.00
+  29200.00      387.90        0.00       10.00        0.00
+  29250.00      388.10        0.00       10.00        0.00
+  29300.00      388.30        0.00       10.00        0.00
+  29350.00      388.50        0.00       10.00        0.00
+  29400.00      388.69        0.00       10.00        0.00
+  29450.00      388.89        0.00       10.00        0.00
+  29500.00      389.09        0.00       10.00        0.00
+  29550.00      389.29        0.00       10.00        0.00
+  29600.00      389.49        0.00       10.00        0.00
+  29650.00      389.69        0.00       10.00        0.00
+  29700.00      389.88        0.00       10.00        0.00
+  29750.00      390.08        0.00       10.00        0.00
+  29800.00      390.28        0.00       10.00        0.00
+  29850.00      390.48        0.00       10.00        0.00
+  29900.00      390.68        0.00       10.00        0.00
+  29950.00      390.88        0.00       10.00        0.00
+  30000.00      391.08        0.00       10.00        0.00
diff --git a/wrfv2_fire/test/em_hill2d_x/extras/input_sounding-U=15,N=0.01 b/wrfv2_fire/test/em_hill2d_x/extras/input_sounding-U=15,N=0.01
new file mode 100644
index 00000000..9fb0e788
--- /dev/null
+++ b/wrfv2_fire/test/em_hill2d_x/extras/input_sounding-U=15,N=0.01
@@ -0,0 +1,602 @@
+   1000.000     288.00        0.00
+      0.00      288.00        0.00       15.00        0.00
+     50.00      288.15        0.00       15.00        0.00
+    100.00      288.29        0.00       15.00        0.00
+    150.00      288.44        0.00       15.00        0.00
+    200.00      288.59        0.00       15.00        0.00
+    250.00      288.74        0.00       15.00        0.00
+    300.00      288.88        0.00       15.00        0.00
+    350.00      289.03        0.00       15.00        0.00
+    400.00      289.18        0.00       15.00        0.00
+    450.00      289.32        0.00       15.00        0.00
+    500.00      289.47        0.00       15.00        0.00
+    550.00      289.62        0.00       15.00        0.00
+    600.00      289.77        0.00       15.00        0.00
+    650.00      289.92        0.00       15.00        0.00
+    700.00      290.06        0.00       15.00        0.00
+    750.00      290.21        0.00       15.00        0.00
+    800.00      290.36        0.00       15.00        0.00
+    850.00      290.51        0.00       15.00        0.00
+    900.00      290.66        0.00       15.00        0.00
+    950.00      290.80        0.00       15.00        0.00
+   1000.00      290.95        0.00       15.00        0.00
+   1050.00      291.10        0.00       15.00        0.00
+   1100.00      291.25        0.00       15.00        0.00
+   1150.00      291.40        0.00       15.00        0.00
+   1200.00      291.55        0.00       15.00        0.00
+   1250.00      291.69        0.00       15.00        0.00
+   1300.00      291.84        0.00       15.00        0.00
+   1350.00      291.99        0.00       15.00        0.00
+   1400.00      292.14        0.00       15.00        0.00
+   1450.00      292.29        0.00       15.00        0.00
+   1500.00      292.44        0.00       15.00        0.00
+   1550.00      292.59        0.00       15.00        0.00
+   1600.00      292.74        0.00       15.00        0.00
+   1650.00      292.89        0.00       15.00        0.00
+   1700.00      293.04        0.00       15.00        0.00
+   1750.00      293.19        0.00       15.00        0.00
+   1800.00      293.34        0.00       15.00        0.00
+   1850.00      293.49        0.00       15.00        0.00
+   1900.00      293.63        0.00       15.00        0.00
+   1950.00      293.78        0.00       15.00        0.00
+   2000.00      293.93        0.00       15.00        0.00
+   2050.00      294.08        0.00       15.00        0.00
+   2100.00      294.23        0.00       15.00        0.00
+   2150.00      294.38        0.00       15.00        0.00
+   2200.00      294.53        0.00       15.00        0.00
+   2250.00      294.68        0.00       15.00        0.00
+   2300.00      294.84        0.00       15.00        0.00
+   2350.00      294.99        0.00       15.00        0.00
+   2400.00      295.14        0.00       15.00        0.00
+   2450.00      295.29        0.00       15.00        0.00
+   2500.00      295.44        0.00       15.00        0.00
+   2550.00      295.59        0.00       15.00        0.00
+   2600.00      295.74        0.00       15.00        0.00
+   2650.00      295.89        0.00       15.00        0.00
+   2700.00      296.04        0.00       15.00        0.00
+   2750.00      296.19        0.00       15.00        0.00
+   2800.00      296.34        0.00       15.00        0.00
+   2850.00      296.49        0.00       15.00        0.00
+   2900.00      296.64        0.00       15.00        0.00
+   2950.00      296.80        0.00       15.00        0.00
+   3000.00      296.95        0.00       15.00        0.00
+   3050.00      297.10        0.00       15.00        0.00
+   3100.00      297.25        0.00       15.00        0.00
+   3150.00      297.40        0.00       15.00        0.00
+   3200.00      297.55        0.00       15.00        0.00
+   3250.00      297.71        0.00       15.00        0.00
+   3300.00      297.86        0.00       15.00        0.00
+   3350.00      298.01        0.00       15.00        0.00
+   3400.00      298.16        0.00       15.00        0.00
+   3450.00      298.31        0.00       15.00        0.00
+   3500.00      298.47        0.00       15.00        0.00
+   3550.00      298.62        0.00       15.00        0.00
+   3600.00      298.77        0.00       15.00        0.00
+   3650.00      298.92        0.00       15.00        0.00
+   3700.00      299.07        0.00       15.00        0.00
+   3750.00      299.23        0.00       15.00        0.00
+   3800.00      299.38        0.00       15.00        0.00
+   3850.00      299.53        0.00       15.00        0.00
+   3900.00      299.69        0.00       15.00        0.00
+   3950.00      299.84        0.00       15.00        0.00
+   4000.00      299.99        0.00       15.00        0.00
+   4050.00      300.14        0.00       15.00        0.00
+   4100.00      300.30        0.00       15.00        0.00
+   4150.00      300.45        0.00       15.00        0.00
+   4200.00      300.60        0.00       15.00        0.00
+   4250.00      300.76        0.00       15.00        0.00
+   4300.00      300.91        0.00       15.00        0.00
+   4350.00      301.06        0.00       15.00        0.00
+   4400.00      301.22        0.00       15.00        0.00
+   4450.00      301.37        0.00       15.00        0.00
+   4500.00      301.53        0.00       15.00        0.00
+   4550.00      301.68        0.00       15.00        0.00
+   4600.00      301.83        0.00       15.00        0.00
+   4650.00      301.99        0.00       15.00        0.00
+   4700.00      302.14        0.00       15.00        0.00
+   4750.00      302.29        0.00       15.00        0.00
+   4800.00      302.45        0.00       15.00        0.00
+   4850.00      302.60        0.00       15.00        0.00
+   4900.00      302.76        0.00       15.00        0.00
+   4950.00      302.91        0.00       15.00        0.00
+   5000.00      303.07        0.00       15.00        0.00
+   5050.00      303.22        0.00       15.00        0.00
+   5100.00      303.38        0.00       15.00        0.00
+   5150.00      303.53        0.00       15.00        0.00
+   5200.00      303.69        0.00       15.00        0.00
+   5250.00      303.84        0.00       15.00        0.00
+   5300.00      304.00        0.00       15.00        0.00
+   5350.00      304.15        0.00       15.00        0.00
+   5400.00      304.31        0.00       15.00        0.00
+   5450.00      304.46        0.00       15.00        0.00
+   5500.00      304.62        0.00       15.00        0.00
+   5550.00      304.77        0.00       15.00        0.00
+   5600.00      304.93        0.00       15.00        0.00
+   5650.00      305.08        0.00       15.00        0.00
+   5700.00      305.24        0.00       15.00        0.00
+   5750.00      305.39        0.00       15.00        0.00
+   5800.00      305.55        0.00       15.00        0.00
+   5850.00      305.71        0.00       15.00        0.00
+   5900.00      305.86        0.00       15.00        0.00
+   5950.00      306.02        0.00       15.00        0.00
+   6000.00      306.17        0.00       15.00        0.00
+   6050.00      306.33        0.00       15.00        0.00
+   6100.00      306.49        0.00       15.00        0.00
+   6150.00      306.64        0.00       15.00        0.00
+   6200.00      306.80        0.00       15.00        0.00
+   6250.00      306.95        0.00       15.00        0.00
+   6300.00      307.11        0.00       15.00        0.00
+   6350.00      307.27        0.00       15.00        0.00
+   6400.00      307.42        0.00       15.00        0.00
+   6450.00      307.58        0.00       15.00        0.00
+   6500.00      307.74        0.00       15.00        0.00
+   6550.00      307.90        0.00       15.00        0.00
+   6600.00      308.05        0.00       15.00        0.00
+   6650.00      308.21        0.00       15.00        0.00
+   6700.00      308.37        0.00       15.00        0.00
+   6750.00      308.52        0.00       15.00        0.00
+   6800.00      308.68        0.00       15.00        0.00
+   6850.00      308.84        0.00       15.00        0.00
+   6900.00      309.00        0.00       15.00        0.00
+   6950.00      309.15        0.00       15.00        0.00
+   7000.00      309.31        0.00       15.00        0.00
+   7050.00      309.47        0.00       15.00        0.00
+   7100.00      309.63        0.00       15.00        0.00
+   7150.00      309.79        0.00       15.00        0.00
+   7200.00      309.94        0.00       15.00        0.00
+   7250.00      310.10        0.00       15.00        0.00
+   7300.00      310.26        0.00       15.00        0.00
+   7350.00      310.42        0.00       15.00        0.00
+   7400.00      310.58        0.00       15.00        0.00
+   7450.00      310.73        0.00       15.00        0.00
+   7500.00      310.89        0.00       15.00        0.00
+   7550.00      311.05        0.00       15.00        0.00
+   7600.00      311.21        0.00       15.00        0.00
+   7650.00      311.37        0.00       15.00        0.00
+   7700.00      311.53        0.00       15.00        0.00
+   7750.00      311.69        0.00       15.00        0.00
+   7800.00      311.85        0.00       15.00        0.00
+   7850.00      312.00        0.00       15.00        0.00
+   7900.00      312.16        0.00       15.00        0.00
+   7950.00      312.32        0.00       15.00        0.00
+   8000.00      312.48        0.00       15.00        0.00
+   8050.00      312.64        0.00       15.00        0.00
+   8100.00      312.80        0.00       15.00        0.00
+   8150.00      312.96        0.00       15.00        0.00
+   8200.00      313.12        0.00       15.00        0.00
+   8250.00      313.28        0.00       15.00        0.00
+   8300.00      313.44        0.00       15.00        0.00
+   8350.00      313.60        0.00       15.00        0.00
+   8400.00      313.76        0.00       15.00        0.00
+   8450.00      313.92        0.00       15.00        0.00
+   8500.00      314.08        0.00       15.00        0.00
+   8550.00      314.24        0.00       15.00        0.00
+   8600.00      314.40        0.00       15.00        0.00
+   8650.00      314.56        0.00       15.00        0.00
+   8700.00      314.72        0.00       15.00        0.00
+   8750.00      314.88        0.00       15.00        0.00
+   8800.00      315.04        0.00       15.00        0.00
+   8850.00      315.20        0.00       15.00        0.00
+   8900.00      315.36        0.00       15.00        0.00
+   8950.00      315.52        0.00       15.00        0.00
+   9000.00      315.69        0.00       15.00        0.00
+   9050.00      315.85        0.00       15.00        0.00
+   9100.00      316.01        0.00       15.00        0.00
+   9150.00      316.17        0.00       15.00        0.00
+   9200.00      316.33        0.00       15.00        0.00
+   9250.00      316.49        0.00       15.00        0.00
+   9300.00      316.65        0.00       15.00        0.00
+   9350.00      316.81        0.00       15.00        0.00
+   9400.00      316.98        0.00       15.00        0.00
+   9450.00      317.14        0.00       15.00        0.00
+   9500.00      317.30        0.00       15.00        0.00
+   9550.00      317.46        0.00       15.00        0.00
+   9600.00      317.62        0.00       15.00        0.00
+   9650.00      317.78        0.00       15.00        0.00
+   9700.00      317.95        0.00       15.00        0.00
+   9750.00      318.11        0.00       15.00        0.00
+   9800.00      318.27        0.00       15.00        0.00
+   9850.00      318.43        0.00       15.00        0.00
+   9900.00      318.60        0.00       15.00        0.00
+   9950.00      318.76        0.00       15.00        0.00
+  10000.00      318.92        0.00       15.00        0.00
+  10050.00      319.08        0.00       15.00        0.00
+  10100.00      319.25        0.00       15.00        0.00
+  10150.00      319.41        0.00       15.00        0.00
+  10200.00      319.57        0.00       15.00        0.00
+  10250.00      319.74        0.00       15.00        0.00
+  10300.00      319.90        0.00       15.00        0.00
+  10350.00      320.06        0.00       15.00        0.00
+  10400.00      320.22        0.00       15.00        0.00
+  10450.00      320.39        0.00       15.00        0.00
+  10500.00      320.55        0.00       15.00        0.00
+  10550.00      320.72        0.00       15.00        0.00
+  10600.00      320.88        0.00       15.00        0.00
+  10650.00      321.04        0.00       15.00        0.00
+  10700.00      321.21        0.00       15.00        0.00
+  10750.00      321.37        0.00       15.00        0.00
+  10800.00      321.53        0.00       15.00        0.00
+  10850.00      321.70        0.00       15.00        0.00
+  10900.00      321.86        0.00       15.00        0.00
+  10950.00      322.03        0.00       15.00        0.00
+  11000.00      322.19        0.00       15.00        0.00
+  11050.00      322.35        0.00       15.00        0.00
+  11100.00      322.52        0.00       15.00        0.00
+  11150.00      322.68        0.00       15.00        0.00
+  11200.00      322.85        0.00       15.00        0.00
+  11250.00      323.01        0.00       15.00        0.00
+  11300.00      323.18        0.00       15.00        0.00
+  11350.00      323.34        0.00       15.00        0.00
+  11400.00      323.51        0.00       15.00        0.00
+  11450.00      323.67        0.00       15.00        0.00
+  11500.00      323.84        0.00       15.00        0.00
+  11550.00      324.00        0.00       15.00        0.00
+  11600.00      324.17        0.00       15.00        0.00
+  11650.00      324.33        0.00       15.00        0.00
+  11700.00      324.50        0.00       15.00        0.00
+  11750.00      324.66        0.00       15.00        0.00
+  11800.00      324.83        0.00       15.00        0.00
+  11850.00      325.00        0.00       15.00        0.00
+  11900.00      325.16        0.00       15.00        0.00
+  11950.00      325.33        0.00       15.00        0.00
+  12000.00      325.49        0.00       15.00        0.00
+  12050.00      325.66        0.00       15.00        0.00
+  12100.00      325.83        0.00       15.00        0.00
+  12150.00      325.99        0.00       15.00        0.00
+  12200.00      326.16        0.00       15.00        0.00
+  12250.00      326.32        0.00       15.00        0.00
+  12300.00      326.49        0.00       15.00        0.00
+  12350.00      326.66        0.00       15.00        0.00
+  12400.00      326.82        0.00       15.00        0.00
+  12450.00      326.99        0.00       15.00        0.00
+  12500.00      327.16        0.00       15.00        0.00
+  12550.00      327.32        0.00       15.00        0.00
+  12600.00      327.49        0.00       15.00        0.00
+  12650.00      327.66        0.00       15.00        0.00
+  12700.00      327.82        0.00       15.00        0.00
+  12750.00      327.99        0.00       15.00        0.00
+  12800.00      328.16        0.00       15.00        0.00
+  12850.00      328.33        0.00       15.00        0.00
+  12900.00      328.49        0.00       15.00        0.00
+  12950.00      328.66        0.00       15.00        0.00
+  13000.00      328.83        0.00       15.00        0.00
+  13050.00      329.00        0.00       15.00        0.00
+  13100.00      329.16        0.00       15.00        0.00
+  13150.00      329.33        0.00       15.00        0.00
+  13200.00      329.50        0.00       15.00        0.00
+  13250.00      329.67        0.00       15.00        0.00
+  13300.00      329.84        0.00       15.00        0.00
+  13350.00      330.01        0.00       15.00        0.00
+  13400.00      330.17        0.00       15.00        0.00
+  13450.00      330.34        0.00       15.00        0.00
+  13500.00      330.51        0.00       15.00        0.00
+  13550.00      330.68        0.00       15.00        0.00
+  13600.00      330.85        0.00       15.00        0.00
+  13650.00      331.02        0.00       15.00        0.00
+  13700.00      331.19        0.00       15.00        0.00
+  13750.00      331.35        0.00       15.00        0.00
+  13800.00      331.52        0.00       15.00        0.00
+  13850.00      331.69        0.00       15.00        0.00
+  13900.00      331.86        0.00       15.00        0.00
+  13950.00      332.03        0.00       15.00        0.00
+  14000.00      332.20        0.00       15.00        0.00
+  14050.00      332.37        0.00       15.00        0.00
+  14100.00      332.54        0.00       15.00        0.00
+  14150.00      332.71        0.00       15.00        0.00
+  14200.00      332.88        0.00       15.00        0.00
+  14250.00      333.05        0.00       15.00        0.00
+  14300.00      333.22        0.00       15.00        0.00
+  14350.00      333.39        0.00       15.00        0.00
+  14400.00      333.56        0.00       15.00        0.00
+  14450.00      333.73        0.00       15.00        0.00
+  14500.00      333.90        0.00       15.00        0.00
+  14550.00      334.07        0.00       15.00        0.00
+  14600.00      334.24        0.00       15.00        0.00
+  14650.00      334.41        0.00       15.00        0.00
+  14700.00      334.58        0.00       15.00        0.00
+  14750.00      334.75        0.00       15.00        0.00
+  14800.00      334.92        0.00       15.00        0.00
+  14850.00      335.09        0.00       15.00        0.00
+  14900.00      335.26        0.00       15.00        0.00
+  14950.00      335.43        0.00       15.00        0.00
+  15000.00      335.61        0.00       15.00        0.00
+  15050.00      335.78        0.00       15.00        0.00
+  15100.00      335.95        0.00       15.00        0.00
+  15150.00      336.12        0.00       15.00        0.00
+  15200.00      336.29        0.00       15.00        0.00
+  15250.00      336.46        0.00       15.00        0.00
+  15300.00      336.63        0.00       15.00        0.00
+  15350.00      336.81        0.00       15.00        0.00
+  15400.00      336.98        0.00       15.00        0.00
+  15450.00      337.15        0.00       15.00        0.00
+  15500.00      337.32        0.00       15.00        0.00
+  15550.00      337.49        0.00       15.00        0.00
+  15600.00      337.67        0.00       15.00        0.00
+  15650.00      337.84        0.00       15.00        0.00
+  15700.00      338.01        0.00       15.00        0.00
+  15750.00      338.18        0.00       15.00        0.00
+  15800.00      338.35        0.00       15.00        0.00
+  15850.00      338.53        0.00       15.00        0.00
+  15900.00      338.70        0.00       15.00        0.00
+  15950.00      338.87        0.00       15.00        0.00
+  16000.00      339.05        0.00       15.00        0.00
+  16050.00      339.22        0.00       15.00        0.00
+  16100.00      339.39        0.00       15.00        0.00
+  16150.00      339.56        0.00       15.00        0.00
+  16200.00      339.74        0.00       15.00        0.00
+  16250.00      339.91        0.00       15.00        0.00
+  16300.00      340.08        0.00       15.00        0.00
+  16350.00      340.26        0.00       15.00        0.00
+  16400.00      340.43        0.00       15.00        0.00
+  16450.00      340.60        0.00       15.00        0.00
+  16500.00      340.78        0.00       15.00        0.00
+  16550.00      340.95        0.00       15.00        0.00
+  16600.00      341.13        0.00       15.00        0.00
+  16650.00      341.30        0.00       15.00        0.00
+  16700.00      341.47        0.00       15.00        0.00
+  16750.00      341.65        0.00       15.00        0.00
+  16800.00      341.82        0.00       15.00        0.00
+  16850.00      342.00        0.00       15.00        0.00
+  16900.00      342.17        0.00       15.00        0.00
+  16950.00      342.35        0.00       15.00        0.00
+  17000.00      342.52        0.00       15.00        0.00
+  17050.00      342.70        0.00       15.00        0.00
+  17100.00      342.87        0.00       15.00        0.00
+  17150.00      343.05        0.00       15.00        0.00
+  17200.00      343.22        0.00       15.00        0.00
+  17250.00      343.40        0.00       15.00        0.00
+  17300.00      343.57        0.00       15.00        0.00
+  17350.00      343.75        0.00       15.00        0.00
+  17400.00      343.92        0.00       15.00        0.00
+  17450.00      344.10        0.00       15.00        0.00
+  17500.00      344.27        0.00       15.00        0.00
+  17550.00      344.45        0.00       15.00        0.00
+  17600.00      344.62        0.00       15.00        0.00
+  17650.00      344.80        0.00       15.00        0.00
+  17700.00      344.97        0.00       15.00        0.00
+  17750.00      345.15        0.00       15.00        0.00
+  17800.00      345.33        0.00       15.00        0.00
+  17850.00      345.50        0.00       15.00        0.00
+  17900.00      345.68        0.00       15.00        0.00
+  17950.00      345.86        0.00       15.00        0.00
+  18000.00      346.03        0.00       15.00        0.00
+  18050.00      346.21        0.00       15.00        0.00
+  18100.00      346.38        0.00       15.00        0.00
+  18150.00      346.56        0.00       15.00        0.00
+  18200.00      346.74        0.00       15.00        0.00
+  18250.00      346.92        0.00       15.00        0.00
+  18300.00      347.09        0.00       15.00        0.00
+  18350.00      347.27        0.00       15.00        0.00
+  18400.00      347.45        0.00       15.00        0.00
+  18450.00      347.62        0.00       15.00        0.00
+  18500.00      347.80        0.00       15.00        0.00
+  18550.00      347.98        0.00       15.00        0.00
+  18600.00      348.16        0.00       15.00        0.00
+  18650.00      348.33        0.00       15.00        0.00
+  18700.00      348.51        0.00       15.00        0.00
+  18750.00      348.69        0.00       15.00        0.00
+  18800.00      348.87        0.00       15.00        0.00
+  18850.00      349.04        0.00       15.00        0.00
+  18900.00      349.22        0.00       15.00        0.00
+  18950.00      349.40        0.00       15.00        0.00
+  19000.00      349.58        0.00       15.00        0.00
+  19050.00      349.76        0.00       15.00        0.00
+  19100.00      349.94        0.00       15.00        0.00
+  19150.00      350.11        0.00       15.00        0.00
+  19200.00      350.29        0.00       15.00        0.00
+  19250.00      350.47        0.00       15.00        0.00
+  19300.00      350.65        0.00       15.00        0.00
+  19350.00      350.83        0.00       15.00        0.00
+  19400.00      351.01        0.00       15.00        0.00
+  19450.00      351.19        0.00       15.00        0.00
+  19500.00      351.37        0.00       15.00        0.00
+  19550.00      351.55        0.00       15.00        0.00
+  19600.00      351.72        0.00       15.00        0.00
+  19650.00      351.90        0.00       15.00        0.00
+  19700.00      352.08        0.00       15.00        0.00
+  19750.00      352.26        0.00       15.00        0.00
+  19800.00      352.44        0.00       15.00        0.00
+  19850.00      352.62        0.00       15.00        0.00
+  19900.00      352.80        0.00       15.00        0.00
+  19950.00      352.98        0.00       15.00        0.00
+  20000.00      353.16        0.00       15.00        0.00
+  20050.00      353.34        0.00       15.00        0.00
+  20100.00      353.52        0.00       15.00        0.00
+  20150.00      353.70        0.00       15.00        0.00
+  20200.00      353.88        0.00       15.00        0.00
+  20250.00      354.06        0.00       15.00        0.00
+  20300.00      354.24        0.00       15.00        0.00
+  20350.00      354.43        0.00       15.00        0.00
+  20400.00      354.61        0.00       15.00        0.00
+  20450.00      354.79        0.00       15.00        0.00
+  20500.00      354.97        0.00       15.00        0.00
+  20550.00      355.15        0.00       15.00        0.00
+  20600.00      355.33        0.00       15.00        0.00
+  20650.00      355.51        0.00       15.00        0.00
+  20700.00      355.69        0.00       15.00        0.00
+  20750.00      355.87        0.00       15.00        0.00
+  20800.00      356.06        0.00       15.00        0.00
+  20850.00      356.24        0.00       15.00        0.00
+  20900.00      356.42        0.00       15.00        0.00
+  20950.00      356.60        0.00       15.00        0.00
+  21000.00      356.78        0.00       15.00        0.00
+  21050.00      356.96        0.00       15.00        0.00
+  21100.00      357.15        0.00       15.00        0.00
+  21150.00      357.33        0.00       15.00        0.00
+  21200.00      357.51        0.00       15.00        0.00
+  21250.00      357.69        0.00       15.00        0.00
+  21300.00      357.88        0.00       15.00        0.00
+  21350.00      358.06        0.00       15.00        0.00
+  21400.00      358.24        0.00       15.00        0.00
+  21450.00      358.42        0.00       15.00        0.00
+  21500.00      358.61        0.00       15.00        0.00
+  21550.00      358.79        0.00       15.00        0.00
+  21600.00      358.97        0.00       15.00        0.00
+  21650.00      359.16        0.00       15.00        0.00
+  21700.00      359.34        0.00       15.00        0.00
+  21750.00      359.52        0.00       15.00        0.00
+  21800.00      359.71        0.00       15.00        0.00
+  21850.00      359.89        0.00       15.00        0.00
+  21900.00      360.07        0.00       15.00        0.00
+  21950.00      360.26        0.00       15.00        0.00
+  22000.00      360.44        0.00       15.00        0.00
+  22050.00      360.62        0.00       15.00        0.00
+  22100.00      360.81        0.00       15.00        0.00
+  22150.00      360.99        0.00       15.00        0.00
+  22200.00      361.18        0.00       15.00        0.00
+  22250.00      361.36        0.00       15.00        0.00
+  22300.00      361.54        0.00       15.00        0.00
+  22350.00      361.73        0.00       15.00        0.00
+  22400.00      361.91        0.00       15.00        0.00
+  22450.00      362.10        0.00       15.00        0.00
+  22500.00      362.28        0.00       15.00        0.00
+  22550.00      362.47        0.00       15.00        0.00
+  22600.00      362.65        0.00       15.00        0.00
+  22650.00      362.84        0.00       15.00        0.00
+  22700.00      363.02        0.00       15.00        0.00
+  22750.00      363.21        0.00       15.00        0.00
+  22800.00      363.39        0.00       15.00        0.00
+  22850.00      363.58        0.00       15.00        0.00
+  22900.00      363.76        0.00       15.00        0.00
+  22950.00      363.95        0.00       15.00        0.00
+  23000.00      364.13        0.00       15.00        0.00
+  23050.00      364.32        0.00       15.00        0.00
+  23100.00      364.51        0.00       15.00        0.00
+  23150.00      364.69        0.00       15.00        0.00
+  23200.00      364.88        0.00       15.00        0.00
+  23250.00      365.06        0.00       15.00        0.00
+  23300.00      365.25        0.00       15.00        0.00
+  23350.00      365.44        0.00       15.00        0.00
+  23400.00      365.62        0.00       15.00        0.00
+  23450.00      365.81        0.00       15.00        0.00
+  23500.00      366.00        0.00       15.00        0.00
+  23550.00      366.18        0.00       15.00        0.00
+  23600.00      366.37        0.00       15.00        0.00
+  23650.00      366.56        0.00       15.00        0.00
+  23700.00      366.74        0.00       15.00        0.00
+  23750.00      366.93        0.00       15.00        0.00
+  23800.00      367.12        0.00       15.00        0.00
+  23850.00      367.30        0.00       15.00        0.00
+  23900.00      367.49        0.00       15.00        0.00
+  23950.00      367.68        0.00       15.00        0.00
+  24000.00      367.87        0.00       15.00        0.00
+  24050.00      368.05        0.00       15.00        0.00
+  24100.00      368.24        0.00       15.00        0.00
+  24150.00      368.43        0.00       15.00        0.00
+  24200.00      368.62        0.00       15.00        0.00
+  24250.00      368.81        0.00       15.00        0.00
+  24300.00      368.99        0.00       15.00        0.00
+  24350.00      369.18        0.00       15.00        0.00
+  24400.00      369.37        0.00       15.00        0.00
+  24450.00      369.56        0.00       15.00        0.00
+  24500.00      369.75        0.00       15.00        0.00
+  24550.00      369.94        0.00       15.00        0.00
+  24600.00      370.12        0.00       15.00        0.00
+  24650.00      370.31        0.00       15.00        0.00
+  24700.00      370.50        0.00       15.00        0.00
+  24750.00      370.69        0.00       15.00        0.00
+  24800.00      370.88        0.00       15.00        0.00
+  24850.00      371.07        0.00       15.00        0.00
+  24900.00      371.26        0.00       15.00        0.00
+  24950.00      371.45        0.00       15.00        0.00
+  25000.00      371.64        0.00       15.00        0.00
+  25050.00      371.83        0.00       15.00        0.00
+  25100.00      372.02        0.00       15.00        0.00
+  25150.00      372.21        0.00       15.00        0.00
+  25200.00      372.40        0.00       15.00        0.00
+  25250.00      372.59        0.00       15.00        0.00
+  25300.00      372.78        0.00       15.00        0.00
+  25350.00      372.97        0.00       15.00        0.00
+  25400.00      373.16        0.00       15.00        0.00
+  25450.00      373.35        0.00       15.00        0.00
+  25500.00      373.54        0.00       15.00        0.00
+  25550.00      373.73        0.00       15.00        0.00
+  25600.00      373.92        0.00       15.00        0.00
+  25650.00      374.11        0.00       15.00        0.00
+  25700.00      374.30        0.00       15.00        0.00
+  25750.00      374.49        0.00       15.00        0.00
+  25800.00      374.68        0.00       15.00        0.00
+  25850.00      374.87        0.00       15.00        0.00
+  25900.00      375.06        0.00       15.00        0.00
+  25950.00      375.26        0.00       15.00        0.00
+  26000.00      375.45        0.00       15.00        0.00
+  26050.00      375.64        0.00       15.00        0.00
+  26100.00      375.83        0.00       15.00        0.00
+  26150.00      376.02        0.00       15.00        0.00
+  26200.00      376.21        0.00       15.00        0.00
+  26250.00      376.41        0.00       15.00        0.00
+  26300.00      376.60        0.00       15.00        0.00
+  26350.00      376.79        0.00       15.00        0.00
+  26400.00      376.98        0.00       15.00        0.00
+  26450.00      377.17        0.00       15.00        0.00
+  26500.00      377.37        0.00       15.00        0.00
+  26550.00      377.56        0.00       15.00        0.00
+  26600.00      377.75        0.00       15.00        0.00
+  26650.00      377.94        0.00       15.00        0.00
+  26700.00      378.14        0.00       15.00        0.00
+  26750.00      378.33        0.00       15.00        0.00
+  26800.00      378.52        0.00       15.00        0.00
+  26850.00      378.72        0.00       15.00        0.00
+  26900.00      378.91        0.00       15.00        0.00
+  26950.00      379.10        0.00       15.00        0.00
+  27000.00      379.30        0.00       15.00        0.00
+  27050.00      379.49        0.00       15.00        0.00
+  27100.00      379.68        0.00       15.00        0.00
+  27150.00      379.88        0.00       15.00        0.00
+  27200.00      380.07        0.00       15.00        0.00
+  27250.00      380.26        0.00       15.00        0.00
+  27300.00      380.46        0.00       15.00        0.00
+  27350.00      380.65        0.00       15.00        0.00
+  27400.00      380.85        0.00       15.00        0.00
+  27450.00      381.04        0.00       15.00        0.00
+  27500.00      381.23        0.00       15.00        0.00
+  27550.00      381.43        0.00       15.00        0.00
+  27600.00      381.62        0.00       15.00        0.00
+  27650.00      381.82        0.00       15.00        0.00
+  27700.00      382.01        0.00       15.00        0.00
+  27750.00      382.21        0.00       15.00        0.00
+  27800.00      382.40        0.00       15.00        0.00
+  27850.00      382.60        0.00       15.00        0.00
+  27900.00      382.79        0.00       15.00        0.00
+  27950.00      382.99        0.00       15.00        0.00
+  28000.00      383.18        0.00       15.00        0.00
+  28050.00      383.38        0.00       15.00        0.00
+  28100.00      383.57        0.00       15.00        0.00
+  28150.00      383.77        0.00       15.00        0.00
+  28200.00      383.97        0.00       15.00        0.00
+  28250.00      384.16        0.00       15.00        0.00
+  28300.00      384.36        0.00       15.00        0.00
+  28350.00      384.55        0.00       15.00        0.00
+  28400.00      384.75        0.00       15.00        0.00
+  28450.00      384.95        0.00       15.00        0.00
+  28500.00      385.14        0.00       15.00        0.00
+  28550.00      385.34        0.00       15.00        0.00
+  28600.00      385.54        0.00       15.00        0.00
+  28650.00      385.73        0.00       15.00        0.00
+  28700.00      385.93        0.00       15.00        0.00
+  28750.00      386.13        0.00       15.00        0.00
+  28800.00      386.32        0.00       15.00        0.00
+  28850.00      386.52        0.00       15.00        0.00
+  28900.00      386.72        0.00       15.00        0.00
+  28950.00      386.91        0.00       15.00        0.00
+  29000.00      387.11        0.00       15.00        0.00
+  29050.00      387.31        0.00       15.00        0.00
+  29100.00      387.51        0.00       15.00        0.00
+  29150.00      387.70        0.00       15.00        0.00
+  29200.00      387.90        0.00       15.00        0.00
+  29250.00      388.10        0.00       15.00        0.00
+  29300.00      388.30        0.00       15.00        0.00
+  29350.00      388.50        0.00       15.00        0.00
+  29400.00      388.69        0.00       15.00        0.00
+  29450.00      388.89        0.00       15.00        0.00
+  29500.00      389.09        0.00       15.00        0.00
+  29550.00      389.29        0.00       15.00        0.00
+  29600.00      389.49        0.00       15.00        0.00
+  29650.00      389.69        0.00       15.00        0.00
+  29700.00      389.88        0.00       15.00        0.00
+  29750.00      390.08        0.00       15.00        0.00
+  29800.00      390.28        0.00       15.00        0.00
+  29850.00      390.48        0.00       15.00        0.00
+  29900.00      390.68        0.00       15.00        0.00
+  29950.00      390.88        0.00       15.00        0.00
+  30000.00      391.08        0.00       15.00        0.00
diff --git a/wrfv2_fire/test/em_hill2d_x/extras/input_sounding-layers-20mps b/wrfv2_fire/test/em_hill2d_x/extras/input_sounding-layers-20mps
new file mode 100644
index 00000000..22d523be
--- /dev/null
+++ b/wrfv2_fire/test/em_hill2d_x/extras/input_sounding-layers-20mps
@@ -0,0 +1,602 @@
+   1000.000     288.00        0.00
+      0.00      288.00        0.00        0.00        0.00
+     50.00      288.15        0.00        0.00        0.00
+    100.00      288.29        0.00        0.00        0.00
+    150.00      288.44        0.00        0.00        0.00
+    200.00      288.59        0.00        0.00        0.00
+    250.00      288.73        0.00        0.00        0.00
+    300.00      288.88        0.00        0.00        0.00
+    350.00      289.03        0.00        0.00        0.00
+    400.00      289.18        0.00        0.00        0.00
+    450.00      289.32        0.00        0.00        0.00
+    500.00      289.47        0.00        0.00        0.00
+    550.00      289.62        0.00        0.00        0.00
+    600.00      289.77        0.00        0.00        0.00
+    650.00      289.91        0.00        0.00        0.00
+    700.00      290.06        0.00        0.00        0.00
+    750.00      290.21        0.00        0.00        0.00
+    800.00      290.36        0.00        0.00        0.00
+    850.00      290.51        0.00        0.00        0.00
+    900.00      290.65        0.00        0.00        0.00
+    950.00      290.80        0.00        0.00        0.00
+   1000.00      290.95        0.00        0.00        0.00
+   1050.00      291.10        0.00        0.00        0.00
+   1100.00      291.25        0.00        0.00        0.00
+   1150.00      291.40        0.00        0.00        0.00
+   1200.00      291.54        0.00        0.00        0.00
+   1250.00      291.69        0.00        0.00        0.00
+   1300.00      291.84        0.00        0.00        0.00
+   1350.00      291.99        0.00        0.00        0.00
+   1400.00      292.14        0.00        0.00        0.00
+   1450.00      292.29        0.00        0.00        0.00
+   1500.00      292.44        0.00        0.00        0.00
+   1550.00      292.59        0.00        0.00        0.00
+   1600.00      292.74        0.00        0.00        0.00
+   1650.00      292.89        0.00        0.00        0.00
+   1700.00      293.03        0.00        0.00        0.00
+   1750.00      293.18        0.00        0.00        0.00
+   1800.00      293.33        0.00        0.00        0.00
+   1850.00      293.48        0.00        0.00        0.00
+   1900.00      293.63        0.00        0.00        0.00
+   1950.00      293.78        0.00        0.00        0.00
+   2000.00      293.93        0.00        0.00        0.00
+   2050.00      294.08        0.00        0.00        0.00
+   2100.00      294.23        0.00        0.00        0.00
+   2150.00      294.38        0.00        0.00        0.00
+   2200.00      294.53        0.00        0.00        0.00
+   2250.00      294.68        0.00        0.00        0.00
+   2300.00      294.83        0.00        0.00        0.00
+   2350.00      294.98        0.00        0.00        0.00
+   2400.00      295.13        0.00        0.00        0.00
+   2450.00      295.28        0.00        0.00        0.00
+   2500.00      295.43        0.00        0.00        0.00
+   2550.00      295.59        0.00        0.00        0.00
+   2600.00      295.74        0.00        0.00        0.00
+   2650.00      295.89        0.00        0.00        0.00
+   2700.00      296.04        0.00        0.00        0.00
+   2750.00      296.19        0.00        0.00        0.00
+   2800.00      296.34        0.00        0.00        0.00
+   2850.00      296.49        0.00        0.00        0.00
+   2900.00      296.64        0.00        0.00        0.00
+   2950.00      296.79        0.00        0.00        0.00
+   3000.00      296.94        0.00        0.00        0.00
+   3050.00      297.10        0.00        0.00        0.00
+   3100.00      297.25        0.00        0.00        0.00
+   3150.00      297.40        0.00        0.00        0.00
+   3200.00      297.55        0.00        0.00        0.00
+   3250.00      297.70        0.00        0.00        0.00
+   3300.00      297.85        0.00        0.00        0.00
+   3350.00      298.01        0.00        0.00        0.00
+   3400.00      298.16        0.00        0.00        0.00
+   3450.00      298.31        0.00        0.00        0.00
+   3500.00      298.46        0.00        0.00        0.00
+   3550.00      298.61        0.00        0.00        0.00
+   3600.00      298.77        0.00        0.00        0.00
+   3650.00      298.92        0.00        0.00        0.00
+   3700.00      299.07        0.00        0.00        0.00
+   3750.00      299.22        0.00        0.00        0.00
+   3800.00      299.38        0.00        0.00        0.00
+   3850.00      299.53        0.00        0.00        0.00
+   3900.00      299.68        0.00        0.00        0.00
+   3950.00      299.83        0.00        0.00        0.00
+   4000.00      299.99        0.00        0.00        0.00
+   4050.00      300.14        0.00        0.00        0.00
+   4100.00      300.29        0.00        0.00        0.00
+   4150.00      300.45        0.00        0.00        0.00
+   4200.00      300.60        0.00        0.00        0.00
+   4250.00      300.75        0.00        0.00        0.00
+   4300.00      300.91        0.00        0.00        0.00
+   4350.00      301.06        0.00        0.00        0.00
+   4400.00      301.21        0.00        0.00        0.00
+   4450.00      301.37        0.00        0.00        0.00
+   4500.00      301.52        0.00        0.00        0.00
+   4550.00      301.67        0.00        0.00        0.00
+   4600.00      301.83        0.00        0.00        0.00
+   4650.00      301.98        0.00        0.00        0.00
+   4700.00      302.14        0.00        0.00        0.00
+   4750.00      302.29        0.00        0.00        0.00
+   4800.00      302.44        0.00        0.00        0.00
+   4850.00      302.60        0.00        0.00        0.00
+   4900.00      302.75        0.00        0.00        0.00
+   4950.00      302.91        0.00        0.00        0.00
+   5000.00      303.06        0.00        0.00        0.00
+   5050.00      303.22        0.00        0.00        0.00
+   5100.00      303.37        0.00        0.00        0.00
+   5150.00      303.52        0.00        0.00        0.00
+   5200.00      303.68        0.00        0.00        0.00
+   5250.00      303.83        0.00        0.00        0.00
+   5300.00      303.99        0.00        0.00        0.00
+   5350.00      304.14        0.00        0.00        0.00
+   5400.00      304.30        0.00        0.00        0.00
+   5450.00      304.45        0.00        0.00        0.00
+   5500.00      304.61        0.00        0.00        0.00
+   5550.00      304.76        0.00        0.00        0.00
+   5600.00      304.92        0.00        0.00        0.00
+   5650.00      305.08        0.00        0.00        0.00
+   5700.00      305.23        0.00        0.00        0.00
+   5750.00      305.39        0.00        0.00        0.00
+   5800.00      305.54        0.00        0.00        0.00
+   5850.00      305.70        0.00        0.00        0.00
+   5900.00      305.85        0.00        0.00        0.00
+   5950.00      306.01        0.00        0.00        0.00
+   6000.00      306.17        0.00        0.00        0.00
+   6050.00      306.32        0.00        0.25        0.00
+   6100.00      306.48        0.00        0.50        0.00
+   6150.00      306.63        0.00        0.75        0.00
+   6200.00      306.79        0.00        1.00        0.00
+   6250.00      306.95        0.00        1.25        0.00
+   6300.00      307.10        0.00        1.50        0.00
+   6350.00      307.26        0.00        1.75        0.00
+   6400.00      307.42        0.00        2.00        0.00
+   6450.00      307.57        0.00        2.25        0.00
+   6500.00      307.73        0.00        2.50        0.00
+   6550.00      307.89        0.00        2.75        0.00
+   6600.00      308.04        0.00        3.00        0.00
+   6650.00      308.20        0.00        3.25        0.00
+   6700.00      308.36        0.00        3.50        0.00
+   6750.00      308.52        0.00        3.75        0.00
+   6800.00      308.67        0.00        4.00        0.00
+   6850.00      308.83        0.00        4.25        0.00
+   6900.00      308.99        0.00        4.50        0.00
+   6950.00      309.15        0.00        4.75        0.00
+   7000.00      309.30        0.00        5.00        0.00
+   7050.00      309.46        0.00        5.25        0.00
+   7100.00      309.62        0.00        5.50        0.00
+   7150.00      309.78        0.00        5.75        0.00
+   7200.00      309.93        0.00        6.00        0.00
+   7250.00      310.09        0.00        6.25        0.00
+   7300.00      310.25        0.00        6.50        0.00
+   7350.00      310.41        0.00        6.75        0.00
+   7400.00      310.57        0.00        7.00        0.00
+   7450.00      310.73        0.00        7.25        0.00
+   7500.00      310.88        0.00        7.50        0.00
+   7550.00      311.04        0.00        7.75        0.00
+   7600.00      311.20        0.00        8.00        0.00
+   7650.00      311.36        0.00        8.25        0.00
+   7700.00      311.52        0.00        8.50        0.00
+   7750.00      311.68        0.00        8.75        0.00
+   7800.00      311.84        0.00        9.00        0.00
+   7850.00      312.00        0.00        9.25        0.00
+   7900.00      312.15        0.00        9.50        0.00
+   7950.00      312.31        0.00        9.75        0.00
+   8000.00      312.47        0.00       10.00        0.00
+   8050.00      312.63        0.00       10.25        0.00
+   8100.00      312.79        0.00       10.50        0.00
+   8150.00      312.95        0.00       10.75        0.00
+   8200.00      313.11        0.00       11.00        0.00
+   8250.00      313.27        0.00       11.25        0.00
+   8300.00      313.43        0.00       11.50        0.00
+   8350.00      313.59        0.00       11.75        0.00
+   8400.00      313.75        0.00       12.00        0.00
+   8450.00      313.91        0.00       12.25        0.00
+   8500.00      314.07        0.00       12.50        0.00
+   8550.00      314.23        0.00       12.75        0.00
+   8600.00      314.39        0.00       13.00        0.00
+   8650.00      314.55        0.00       13.25        0.00
+   8700.00      314.71        0.00       13.50        0.00
+   8750.00      314.87        0.00       13.75        0.00
+   8800.00      315.03        0.00       14.00        0.00
+   8850.00      315.19        0.00       14.25        0.00
+   8900.00      315.35        0.00       14.50        0.00
+   8950.00      315.51        0.00       14.75        0.00
+   9000.00      315.67        0.00       15.00        0.00
+   9050.00      315.84        0.00       15.25        0.00
+   9100.00      316.00        0.00       15.50        0.00
+   9150.00      316.16        0.00       15.75        0.00
+   9200.00      316.32        0.00       16.00        0.00
+   9250.00      316.48        0.00       16.25        0.00
+   9300.00      316.64        0.00       16.50        0.00
+   9350.00      316.80        0.00       16.75        0.00
+   9400.00      316.96        0.00       17.00        0.00
+   9450.00      317.13        0.00       17.25        0.00
+   9500.00      317.29        0.00       17.50        0.00
+   9550.00      317.45        0.00       17.75        0.00
+   9600.00      317.61        0.00       18.00        0.00
+   9650.00      317.77        0.00       18.25        0.00
+   9700.00      317.94        0.00       18.50        0.00
+   9750.00      318.10        0.00       18.75        0.00
+   9800.00      318.26        0.00       19.00        0.00
+   9850.00      318.42        0.00       19.25        0.00
+   9900.00      318.58        0.00       19.50        0.00
+   9950.00      318.75        0.00       19.75        0.00
+  10000.00      319.40        0.00       20.00        0.00
+  10050.00      320.05        0.00       20.00        0.00
+  10100.00      320.70        0.00       20.00        0.00
+  10150.00      321.36        0.00       20.00        0.00
+  10200.00      322.01        0.00       20.00        0.00
+  10250.00      322.67        0.00       20.00        0.00
+  10300.00      323.33        0.00       20.00        0.00
+  10350.00      323.99        0.00       20.00        0.00
+  10400.00      324.65        0.00       20.00        0.00
+  10450.00      325.31        0.00       20.00        0.00
+  10500.00      325.98        0.00       20.00        0.00
+  10550.00      326.64        0.00       20.00        0.00
+  10600.00      327.31        0.00       20.00        0.00
+  10650.00      327.98        0.00       20.00        0.00
+  10700.00      328.65        0.00       20.00        0.00
+  10750.00      329.32        0.00       20.00        0.00
+  10800.00      329.99        0.00       20.00        0.00
+  10850.00      330.66        0.00       20.00        0.00
+  10900.00      331.34        0.00       20.00        0.00
+  10950.00      332.01        0.00       20.00        0.00
+  11000.00      332.69        0.00       20.00        0.00
+  11050.00      333.37        0.00       20.00        0.00
+  11100.00      334.05        0.00       20.00        0.00
+  11150.00      334.73        0.00       20.00        0.00
+  11200.00      335.41        0.00       20.00        0.00
+  11250.00      336.10        0.00       20.00        0.00
+  11300.00      336.78        0.00       20.00        0.00
+  11350.00      337.47        0.00       20.00        0.00
+  11400.00      338.16        0.00       20.00        0.00
+  11450.00      338.85        0.00       20.00        0.00
+  11500.00      339.54        0.00       20.00        0.00
+  11550.00      340.24        0.00       20.00        0.00
+  11600.00      340.93        0.00       20.00        0.00
+  11650.00      341.63        0.00       20.00        0.00
+  11700.00      342.32        0.00       20.00        0.00
+  11750.00      343.02        0.00       20.00        0.00
+  11800.00      343.72        0.00       20.00        0.00
+  11850.00      344.42        0.00       20.00        0.00
+  11900.00      345.13        0.00       20.00        0.00
+  11950.00      345.83        0.00       20.00        0.00
+  12000.00      346.54        0.00       20.00        0.00
+  12050.00      347.24        0.00       20.00        0.00
+  12100.00      347.95        0.00       20.00        0.00
+  12150.00      348.66        0.00       20.00        0.00
+  12200.00      349.37        0.00       20.00        0.00
+  12250.00      350.09        0.00       20.00        0.00
+  12300.00      350.80        0.00       20.00        0.00
+  12350.00      351.52        0.00       20.00        0.00
+  12400.00      352.23        0.00       20.00        0.00
+  12450.00      352.95        0.00       20.00        0.00
+  12500.00      353.67        0.00       20.00        0.00
+  12550.00      354.40        0.00       20.00        0.00
+  12600.00      355.12        0.00       20.00        0.00
+  12650.00      355.84        0.00       20.00        0.00
+  12700.00      356.57        0.00       20.00        0.00
+  12750.00      357.30        0.00       20.00        0.00
+  12800.00      358.03        0.00       20.00        0.00
+  12850.00      358.76        0.00       20.00        0.00
+  12900.00      359.49        0.00       20.00        0.00
+  12950.00      360.22        0.00       20.00        0.00
+  13000.00      360.96        0.00       20.00        0.00
+  13050.00      361.70        0.00       20.00        0.00
+  13100.00      362.43        0.00       20.00        0.00
+  13150.00      363.17        0.00       20.00        0.00
+  13200.00      363.91        0.00       20.00        0.00
+  13250.00      364.66        0.00       20.00        0.00
+  13300.00      365.40        0.00       20.00        0.00
+  13350.00      366.15        0.00       20.00        0.00
+  13400.00      366.89        0.00       20.00        0.00
+  13450.00      367.64        0.00       20.00        0.00
+  13500.00      368.39        0.00       20.00        0.00
+  13550.00      369.14        0.00       20.00        0.00
+  13600.00      369.90        0.00       20.00        0.00
+  13650.00      370.65        0.00       20.00        0.00
+  13700.00      371.41        0.00       20.00        0.00
+  13750.00      372.17        0.00       20.00        0.00
+  13800.00      372.93        0.00       20.00        0.00
+  13850.00      373.69        0.00       20.00        0.00
+  13900.00      374.45        0.00       20.00        0.00
+  13950.00      375.22        0.00       20.00        0.00
+  14000.00      375.98        0.00       20.00        0.00
+  14050.00      376.75        0.00       20.00        0.00
+  14100.00      377.52        0.00       20.00        0.00
+  14150.00      378.29        0.00       20.00        0.00
+  14200.00      379.06        0.00       20.00        0.00
+  14250.00      379.83        0.00       20.00        0.00
+  14300.00      380.61        0.00       20.00        0.00
+  14350.00      381.39        0.00       20.00        0.00
+  14400.00      382.16        0.00       20.00        0.00
+  14450.00      382.94        0.00       20.00        0.00
+  14500.00      383.72        0.00       20.00        0.00
+  14550.00      384.51        0.00       20.00        0.00
+  14600.00      385.29        0.00       20.00        0.00
+  14650.00      386.08        0.00       20.00        0.00
+  14700.00      386.87        0.00       20.00        0.00
+  14750.00      387.66        0.00       20.00        0.00
+  14800.00      388.45        0.00       20.00        0.00
+  14850.00      389.24        0.00       20.00        0.00
+  14900.00      390.03        0.00       20.00        0.00
+  14950.00      390.83        0.00       20.00        0.00
+  15000.00      391.63        0.00       20.00        0.00
+  15050.00      392.43        0.00       20.00        0.00
+  15100.00      393.23        0.00       20.00        0.00
+  15150.00      394.03        0.00       20.00        0.00
+  15200.00      394.84        0.00       20.00        0.00
+  15250.00      395.64        0.00       20.00        0.00
+  15300.00      396.45        0.00       20.00        0.00
+  15350.00      397.26        0.00       20.00        0.00
+  15400.00      398.07        0.00       20.00        0.00
+  15450.00      398.88        0.00       20.00        0.00
+  15500.00      399.70        0.00       20.00        0.00
+  15550.00      400.51        0.00       20.00        0.00
+  15600.00      401.33        0.00       20.00        0.00
+  15650.00      402.15        0.00       20.00        0.00
+  15700.00      402.97        0.00       20.00        0.00
+  15750.00      403.79        0.00       20.00        0.00
+  15800.00      404.61        0.00       20.00        0.00
+  15850.00      405.44        0.00       20.00        0.00
+  15900.00      406.27        0.00       20.00        0.00
+  15950.00      407.10        0.00       20.00        0.00
+  16000.00      407.93        0.00       20.00        0.00
+  16050.00      408.76        0.00       20.00        0.00
+  16100.00      409.59        0.00       20.00        0.00
+  16150.00      410.43        0.00       20.00        0.00
+  16200.00      411.27        0.00       20.00        0.00
+  16250.00      412.11        0.00       20.00        0.00
+  16300.00      412.95        0.00       20.00        0.00
+  16350.00      413.79        0.00       20.00        0.00
+  16400.00      414.64        0.00       20.00        0.00
+  16450.00      415.48        0.00       20.00        0.00
+  16500.00      416.33        0.00       20.00        0.00
+  16550.00      417.18        0.00       20.00        0.00
+  16600.00      418.03        0.00       20.00        0.00
+  16650.00      418.88        0.00       20.00        0.00
+  16700.00      419.74        0.00       20.00        0.00
+  16750.00      420.60        0.00       20.00        0.00
+  16800.00      421.45        0.00       20.00        0.00
+  16850.00      422.31        0.00       20.00        0.00
+  16900.00      423.18        0.00       20.00        0.00
+  16950.00      424.04        0.00       20.00        0.00
+  17000.00      424.90        0.00       20.00        0.00
+  17050.00      425.77        0.00       20.00        0.00
+  17100.00      426.64        0.00       20.00        0.00
+  17150.00      427.51        0.00       20.00        0.00
+  17200.00      428.38        0.00       20.00        0.00
+  17250.00      429.26        0.00       20.00        0.00
+  17300.00      430.13        0.00       20.00        0.00
+  17350.00      431.01        0.00       20.00        0.00
+  17400.00      431.89        0.00       20.00        0.00
+  17450.00      432.77        0.00       20.00        0.00
+  17500.00      433.66        0.00       20.00        0.00
+  17550.00      434.54        0.00       20.00        0.00
+  17600.00      435.43        0.00       20.00        0.00
+  17650.00      436.32        0.00       20.00        0.00
+  17700.00      437.21        0.00       20.00        0.00
+  17750.00      438.10        0.00       20.00        0.00
+  17800.00      438.99        0.00       20.00        0.00
+  17850.00      439.89        0.00       20.00        0.00
+  17900.00      440.79        0.00       20.00        0.00
+  17950.00      441.69        0.00       20.00        0.00
+  18000.00      442.59        0.00       20.00        0.00
+  18050.00      443.49        0.00       20.00        0.00
+  18100.00      444.40        0.00       20.00        0.00
+  18150.00      445.30        0.00       20.00        0.00
+  18200.00      446.21        0.00       20.00        0.00
+  18250.00      447.12        0.00       20.00        0.00
+  18300.00      448.04        0.00       20.00        0.00
+  18350.00      448.95        0.00       20.00        0.00
+  18400.00      449.87        0.00       20.00        0.00
+  18450.00      450.78        0.00       20.00        0.00
+  18500.00      451.70        0.00       20.00        0.00
+  18550.00      452.63        0.00       20.00        0.00
+  18600.00      453.55        0.00       20.00        0.00
+  18650.00      454.48        0.00       20.00        0.00
+  18700.00      455.40        0.00       20.00        0.00
+  18750.00      456.33        0.00       20.00        0.00
+  18800.00      457.26        0.00       20.00        0.00
+  18850.00      458.20        0.00       20.00        0.00
+  18900.00      459.13        0.00       20.00        0.00
+  18950.00      460.07        0.00       20.00        0.00
+  19000.00      461.01        0.00       20.00        0.00
+  19050.00      461.95        0.00       20.00        0.00
+  19100.00      462.89        0.00       20.00        0.00
+  19150.00      463.84        0.00       20.00        0.00
+  19200.00      464.78        0.00       20.00        0.00
+  19250.00      465.73        0.00       20.00        0.00
+  19300.00      466.68        0.00       20.00        0.00
+  19350.00      467.64        0.00       20.00        0.00
+  19400.00      468.59        0.00       20.00        0.00
+  19450.00      469.55        0.00       20.00        0.00
+  19500.00      470.50        0.00       20.00        0.00
+  19550.00      471.46        0.00       20.00        0.00
+  19600.00      472.43        0.00       20.00        0.00
+  19650.00      473.39        0.00       20.00        0.00
+  19700.00      474.36        0.00       20.00        0.00
+  19750.00      475.33        0.00       20.00        0.00
+  19800.00      476.30        0.00       20.00        0.00
+  19850.00      477.27        0.00       20.00        0.00
+  19900.00      478.24        0.00       20.00        0.00
+  19950.00      479.22        0.00       20.00        0.00
+  20000.00      480.20        0.00       20.00        0.00
+  20050.00      481.18        0.00       20.00        0.00
+  20100.00      482.16        0.00       20.00        0.00
+  20150.00      483.14        0.00       20.00        0.00
+  20200.00      484.13        0.00       20.00        0.00
+  20250.00      485.12        0.00       20.00        0.00
+  20300.00      486.11        0.00       20.00        0.00
+  20350.00      487.10        0.00       20.00        0.00
+  20400.00      488.09        0.00       20.00        0.00
+  20450.00      489.09        0.00       20.00        0.00
+  20500.00      490.09        0.00       20.00        0.00
+  20550.00      491.09        0.00       20.00        0.00
+  20600.00      492.09        0.00       20.00        0.00
+  20650.00      493.09        0.00       20.00        0.00
+  20700.00      494.10        0.00       20.00        0.00
+  20750.00      495.11        0.00       20.00        0.00
+  20800.00      496.12        0.00       20.00        0.00
+  20850.00      497.13        0.00       20.00        0.00
+  20900.00      498.14        0.00       20.00        0.00
+  20950.00      499.16        0.00       20.00        0.00
+  21000.00      500.18        0.00       20.00        0.00
+  21050.00      501.20        0.00       20.00        0.00
+  21100.00      502.22        0.00       20.00        0.00
+  21150.00      503.25        0.00       20.00        0.00
+  21200.00      504.28        0.00       20.00        0.00
+  21250.00      505.30        0.00       20.00        0.00
+  21300.00      506.34        0.00       20.00        0.00
+  21350.00      507.37        0.00       20.00        0.00
+  21400.00      508.41        0.00       20.00        0.00
+  21450.00      509.44        0.00       20.00        0.00
+  21500.00      510.48        0.00       20.00        0.00
+  21550.00      511.52        0.00       20.00        0.00
+  21600.00      512.57        0.00       20.00        0.00
+  21650.00      513.61        0.00       20.00        0.00
+  21700.00      514.66        0.00       20.00        0.00
+  21750.00      515.71        0.00       20.00        0.00
+  21800.00      516.77        0.00       20.00        0.00
+  21850.00      517.82        0.00       20.00        0.00
+  21900.00      518.88        0.00       20.00        0.00
+  21950.00      519.94        0.00       20.00        0.00
+  22000.00      521.00        0.00       20.00        0.00
+  22050.00      522.06        0.00       20.00        0.00
+  22100.00      523.13        0.00       20.00        0.00
+  22150.00      524.19        0.00       20.00        0.00
+  22200.00      525.26        0.00       20.00        0.00
+  22250.00      526.33        0.00       20.00        0.00
+  22300.00      527.41        0.00       20.00        0.00
+  22350.00      528.49        0.00       20.00        0.00
+  22400.00      529.56        0.00       20.00        0.00
+  22450.00      530.64        0.00       20.00        0.00
+  22500.00      531.73        0.00       20.00        0.00
+  22550.00      532.81        0.00       20.00        0.00
+  22600.00      533.90        0.00       20.00        0.00
+  22650.00      534.99        0.00       20.00        0.00
+  22700.00      536.08        0.00       20.00        0.00
+  22750.00      537.18        0.00       20.00        0.00
+  22800.00      538.27        0.00       20.00        0.00
+  22850.00      539.37        0.00       20.00        0.00
+  22900.00      540.47        0.00       20.00        0.00
+  22950.00      541.57        0.00       20.00        0.00
+  23000.00      542.68        0.00       20.00        0.00
+  23050.00      543.79        0.00       20.00        0.00
+  23100.00      544.90        0.00       20.00        0.00
+  23150.00      546.01        0.00       20.00        0.00
+  23200.00      547.12        0.00       20.00        0.00
+  23250.00      548.24        0.00       20.00        0.00
+  23300.00      549.36        0.00       20.00        0.00
+  23350.00      550.48        0.00       20.00        0.00
+  23400.00      551.60        0.00       20.00        0.00
+  23450.00      552.73        0.00       20.00        0.00
+  23500.00      553.86        0.00       20.00        0.00
+  23550.00      554.99        0.00       20.00        0.00
+  23600.00      556.12        0.00       20.00        0.00
+  23650.00      557.26        0.00       20.00        0.00
+  23700.00      558.39        0.00       20.00        0.00
+  23750.00      559.53        0.00       20.00        0.00
+  23800.00      560.67        0.00       20.00        0.00
+  23850.00      561.82        0.00       20.00        0.00
+  23900.00      562.96        0.00       20.00        0.00
+  23950.00      564.11        0.00       20.00        0.00
+  24000.00      565.27        0.00       20.00        0.00
+  24050.00      566.42        0.00       20.00        0.00
+  24100.00      567.57        0.00       20.00        0.00
+  24150.00      568.73        0.00       20.00        0.00
+  24200.00      569.89        0.00       20.00        0.00
+  24250.00      571.06        0.00       20.00        0.00
+  24300.00      572.22        0.00       20.00        0.00
+  24350.00      573.39        0.00       20.00        0.00
+  24400.00      574.56        0.00       20.00        0.00
+  24450.00      575.73        0.00       20.00        0.00
+  24500.00      576.91        0.00       20.00        0.00
+  24550.00      578.09        0.00       20.00        0.00
+  24600.00      579.27        0.00       20.00        0.00
+  24650.00      580.45        0.00       20.00        0.00
+  24700.00      581.63        0.00       20.00        0.00
+  24750.00      582.82        0.00       20.00        0.00
+  24800.00      584.01        0.00       20.00        0.00
+  24850.00      585.20        0.00       20.00        0.00
+  24900.00      586.39        0.00       20.00        0.00
+  24950.00      587.59        0.00       20.00        0.00
+  25000.00      588.79        0.00       20.00        0.00
+  25050.00      589.99        0.00       20.00        0.00
+  25100.00      591.20        0.00       20.00        0.00
+  25150.00      592.40        0.00       20.00        0.00
+  25200.00      593.61        0.00       20.00        0.00
+  25250.00      594.82        0.00       20.00        0.00
+  25300.00      596.04        0.00       20.00        0.00
+  25350.00      597.25        0.00       20.00        0.00
+  25400.00      598.47        0.00       20.00        0.00
+  25450.00      599.69        0.00       20.00        0.00
+  25500.00      600.92        0.00       20.00        0.00
+  25550.00      602.14        0.00       20.00        0.00
+  25600.00      603.37        0.00       20.00        0.00
+  25650.00      604.60        0.00       20.00        0.00
+  25700.00      605.84        0.00       20.00        0.00
+  25750.00      607.08        0.00       20.00        0.00
+  25800.00      608.31        0.00       20.00        0.00
+  25850.00      609.56        0.00       20.00        0.00
+  25900.00      610.80        0.00       20.00        0.00
+  25950.00      612.05        0.00       20.00        0.00
+  26000.00      613.30        0.00       20.00        0.00
+  26050.00      614.55        0.00       20.00        0.00
+  26100.00      615.80        0.00       20.00        0.00
+  26150.00      617.06        0.00       20.00        0.00
+  26200.00      618.32        0.00       20.00        0.00
+  26250.00      619.58        0.00       20.00        0.00
+  26300.00      620.84        0.00       20.00        0.00
+  26350.00      622.11        0.00       20.00        0.00
+  26400.00      623.38        0.00       20.00        0.00
+  26450.00      624.65        0.00       20.00        0.00
+  26500.00      625.93        0.00       20.00        0.00
+  26550.00      627.20        0.00       20.00        0.00
+  26600.00      628.48        0.00       20.00        0.00
+  26650.00      629.77        0.00       20.00        0.00
+  26700.00      631.05        0.00       20.00        0.00
+  26750.00      632.34        0.00       20.00        0.00
+  26800.00      633.63        0.00       20.00        0.00
+  26850.00      634.92        0.00       20.00        0.00
+  26900.00      636.22        0.00       20.00        0.00
+  26950.00      637.52        0.00       20.00        0.00
+  27000.00      638.82        0.00       20.00        0.00
+  27050.00      640.12        0.00       20.00        0.00
+  27100.00      641.43        0.00       20.00        0.00
+  27150.00      642.74        0.00       20.00        0.00
+  27200.00      644.05        0.00       20.00        0.00
+  27250.00      645.36        0.00       20.00        0.00
+  27300.00      646.68        0.00       20.00        0.00
+  27350.00      648.00        0.00       20.00        0.00
+  27400.00      649.32        0.00       20.00        0.00
+  27450.00      650.65        0.00       20.00        0.00
+  27500.00      651.98        0.00       20.00        0.00
+  27550.00      653.31        0.00       20.00        0.00
+  27600.00      654.64        0.00       20.00        0.00
+  27650.00      655.98        0.00       20.00        0.00
+  27700.00      657.32        0.00       20.00        0.00
+  27750.00      658.66        0.00       20.00        0.00
+  27800.00      660.00        0.00       20.00        0.00
+  27850.00      661.35        0.00       20.00        0.00
+  27900.00      662.70        0.00       20.00        0.00
+  27950.00      664.05        0.00       20.00        0.00
+  28000.00      665.41        0.00       20.00        0.00
+  28050.00      666.76        0.00       20.00        0.00
+  28100.00      668.13        0.00       20.00        0.00
+  28150.00      669.49        0.00       20.00        0.00
+  28200.00      670.85        0.00       20.00        0.00
+  28250.00      672.22        0.00       20.00        0.00
+  28300.00      673.60        0.00       20.00        0.00
+  28350.00      674.97        0.00       20.00        0.00
+  28400.00      676.35        0.00       20.00        0.00
+  28450.00      677.73        0.00       20.00        0.00
+  28500.00      679.11        0.00       20.00        0.00
+  28550.00      680.50        0.00       20.00        0.00
+  28600.00      681.89        0.00       20.00        0.00
+  28650.00      683.28        0.00       20.00        0.00
+  28700.00      684.67        0.00       20.00        0.00
+  28750.00      686.07        0.00       20.00        0.00
+  28800.00      687.47        0.00       20.00        0.00
+  28850.00      688.87        0.00       20.00        0.00
+  28900.00      690.28        0.00       20.00        0.00
+  28950.00      691.69        0.00       20.00        0.00
+  29000.00      693.10        0.00       20.00        0.00
+  29050.00      694.51        0.00       20.00        0.00
+  29100.00      695.93        0.00       20.00        0.00
+  29150.00      697.35        0.00       20.00        0.00
+  29200.00      698.77        0.00       20.00        0.00
+  29250.00      700.20        0.00       20.00        0.00
+  29300.00      701.63        0.00       20.00        0.00
+  29350.00      703.06        0.00       20.00        0.00
+  29400.00      704.50        0.00       20.00        0.00
+  29450.00      705.93        0.00       20.00        0.00
+  29500.00      707.38        0.00       20.00        0.00
+  29550.00      708.82        0.00       20.00        0.00
+  29600.00      710.27        0.00       20.00        0.00
+  29650.00      711.72        0.00       20.00        0.00
+  29700.00      713.17        0.00       20.00        0.00
+  29750.00      714.62        0.00       20.00        0.00
+  29800.00      716.08        0.00       20.00        0.00
+  29850.00      717.54        0.00       20.00        0.00
+  29900.00      719.01        0.00       20.00        0.00
+  29950.00      720.47        0.00       20.00        0.00
+  30000.00      721.95        0.00       20.00        0.00
diff --git a/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-100m_hill-10mps-N^2=0.0001-30km_deep-20km_damping-dampcoef=0.1-etac=0.2 b/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-100m_hill-10mps-N^2=0.0001-30km_deep-20km_damping-dampcoef=0.1-etac=0.2
new file mode 100644
index 00000000..5959edfd
--- /dev/null
+++ b/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-100m_hill-10mps-N^2=0.0001-30km_deep-20km_damping-dampcoef=0.1-etac=0.2
@@ -0,0 +1,103 @@
+ &time_control
+ run_days                            = 0,
+ run_hours                           = 5,
+ run_minutes                         = 0,
+ run_seconds                         = 0,
+ start_year                          = 0001,
+ start_month                         = 01,
+ start_day                           = 01,
+ start_hour                          = 00,
+ start_minute                        = 00,
+ start_second                        = 00,
+ end_year                            = 0001,
+ end_month                           = 01,
+ end_day                             = 01,
+ end_hour                            = 10,
+ end_minute                          = 00,
+ end_second                          = 00,
+ history_interval                    = 60,
+ frames_per_outfile                  = 1,
+ restart                             = .false.,
+ restart_interval                    = 120,
+ io_form_history                     = 2
+ io_form_restart                     = 2
+ io_form_input                       = 2
+ io_form_boundary                    = 2
+ debug_level                         = 0
+ /
+
+ &domains
+ time_step                           = 20,
+ time_step_fract_num                 = 0,
+ time_step_fract_den                 = 1,
+ max_dom                             = 1,
+ s_we                                = 1,
+ e_we                                = 202,
+ s_sn                                = 1,
+ e_sn                                = 3,
+ s_vert                              = 1,
+ e_vert                              = 41,
+ dx                                  = 2000,
+ dy                                  = 2000,
+ ztop                                = 30000.,
+ /
+
+ &physics
+ mp_physics                          = 0,
+ ra_lw_physics                       = 0,
+ ra_sw_physics                       = 0,
+ radt                                = 0,
+ sf_sfclay_physics                   = 0,
+ sf_surface_physics                  = 0,
+ bl_pbl_physics                      = 0,
+ bldt                                = 0,
+ cu_physics                          = 0,
+ cudt                                = 0,
+ num_soil_layers                     = 5,
+ /
+
+ &fdda
+ /
+
+ &dynamics
+ rk_ord                              = 3,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 1,      1,      1,
+ damp_opt                            = 3,
+ zdamp                               = 20000.,
+ dampcoef                            = .1,
+ khdif                               = 00,
+ kvdif                               = 0,
+ smdiv                               = 0.1,
+ emdiv                               = 0.01,
+ epssm                               = 0.1,
+ time_step_sound                     = 6,
+ h_mom_adv_order                     = 5,
+ v_mom_adv_order                     = 3,
+ h_sca_adv_order                     = 5,
+ v_sca_adv_order                     = 3,
+ non_hydrostatic                     = .true.,
+ hybrid_opt                          = 2,
+ etac                                = 0.2,
+ /
+
+ &bdy_control
+ periodic_x                          = .false.,
+ symmetric_xs                        = .false.,
+ symmetric_xe                        = .false.,
+ open_xs                             = .true., 
+ open_xe                             = .true.,
+ periodic_y                          = .true.,
+ symmetric_ys                        = .false.,
+ symmetric_ye                        = .false.,
+ open_ys                             = .false.,
+ open_ye                             = .false.,
+ /
+
+ &grib2
+ /
+
+ &namelist_quilt
+ nio_tasks_per_group = 0,
+ nio_groups = 1,
+ /
diff --git a/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-700m_hill-15mps-n^2=0.0001-25km_deep-15km_damping-dampcoef=0.08-etac=0.2 b/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-700m_hill-15mps-n^2=0.0001-25km_deep-15km_damping-dampcoef=0.08-etac=0.2
new file mode 100644
index 00000000..34d1281b
--- /dev/null
+++ b/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-700m_hill-15mps-n^2=0.0001-25km_deep-15km_damping-dampcoef=0.08-etac=0.2
@@ -0,0 +1,103 @@
+ &time_control
+ run_days                            = 0,
+ run_hours                           = 5,
+ run_minutes                         = 0,
+ run_seconds                         = 0,
+ start_year                          = 0001,
+ start_month                         = 01,
+ start_day                           = 01,
+ start_hour                          = 00,
+ start_minute                        = 00,
+ start_second                        = 00,
+ end_year                            = 0001,
+ end_month                           = 01,
+ end_day                             = 01,
+ end_hour                            = 10,
+ end_minute                          = 00,
+ end_second                          = 00,
+ history_interval                    = 60,
+ frames_per_outfile                  = 1,
+ restart                             = .false.,
+ restart_interval                    = 120,
+ io_form_history                     = 2
+ io_form_restart                     = 2
+ io_form_input                       = 2
+ io_form_boundary                    = 2
+ debug_level                         = 0
+ /
+
+ &domains
+ time_step                           = 20,
+ time_step_fract_num                 = 0,
+ time_step_fract_den                 = 1,
+ max_dom                             = 1,
+ s_we                                = 1,
+ e_we                                = 202,
+ s_sn                                = 1,
+ e_sn                                = 3,
+ s_vert                              = 1,
+ e_vert                              = 41,
+ dx                                  = 2000,
+ dy                                  = 2000,
+ ztop                                = 25000.,
+ /
+
+ &physics
+ mp_physics                          = 0,
+ ra_lw_physics                       = 0,
+ ra_sw_physics                       = 0,
+ radt                                = 0,
+ sf_sfclay_physics                   = 0,
+ sf_surface_physics                  = 0,
+ bl_pbl_physics                      = 0,
+ bldt                                = 0,
+ cu_physics                          = 0,
+ cudt                                = 0,
+ num_soil_layers                     = 5,
+ /
+
+ &fdda
+ /
+
+ &dynamics
+ rk_ord                              = 3,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 1,      1,      1,
+ damp_opt                            = 3,
+ zdamp                               = 15000.,
+ dampcoef                            = .08,
+ khdif                               = 00,
+ kvdif                               = 0,
+ smdiv                               = 0.1,
+ emdiv                               = 0.01,
+ epssm                               = 0.1,
+ time_step_sound                     = 6,
+ h_mom_adv_order                     = 5,
+ v_mom_adv_order                     = 3,
+ h_sca_adv_order                     = 5,
+ v_sca_adv_order                     = 3,
+ non_hydrostatic                     = .true.,
+ hybrid_opt                          = 2,
+ etac                                = 0.2,
+ /
+
+ &bdy_control
+ periodic_x                          = .false.,
+ symmetric_xs                        = .false.,
+ symmetric_xe                        = .false.,
+ open_xs                             = .true., 
+ open_xe                             = .true.,
+ periodic_y                          = .true.,
+ symmetric_ys                        = .false.,
+ symmetric_ye                        = .false.,
+ open_ys                             = .false.,
+ open_ye                             = .false.,
+ /
+
+ &grib2
+ /
+
+ &namelist_quilt
+ nio_tasks_per_group = 0,
+ nio_groups = 1,
+ /
diff --git a/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL b/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL
new file mode 100644
index 00000000..eb7f5310
--- /dev/null
+++ b/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL
@@ -0,0 +1,103 @@
+ &time_control
+ run_days                            = 0,
+ run_hours                           = 10,
+ run_minutes                         = 0,
+ run_seconds                         = 0,
+ start_year                          = 0001,
+ start_month                         = 01,
+ start_day                           = 01,
+ start_hour                          = 00,
+ start_minute                        = 00,
+ start_second                        = 00,
+ end_year                            = 0001,
+ end_month                           = 01,
+ end_day                             = 01,
+ end_hour                            = 10,
+ end_minute                          = 00,
+ end_second                          = 00,
+ history_interval                    = 60,
+ frames_per_outfile                  = 1,
+ restart                             = .false.,
+ restart_interval                    = 120,
+ io_form_history                     = 2
+ io_form_restart                     = 2
+ io_form_input                       = 2
+ io_form_boundary                    = 2
+ debug_level                         = 0
+ /
+
+ &domains
+ time_step                           = 20,
+ time_step_fract_num                 = 0,
+ time_step_fract_den                 = 1,
+ max_dom                             = 1,
+ s_we                                = 1,
+ e_we                                = 202,
+ s_sn                                = 1,
+ e_sn                                = 3,
+ s_vert                              = 1,
+ e_vert                              = 41,
+ dx                                  = 2000,
+ dy                                  = 2000,
+ ztop                                = 30000.,
+ /
+
+ &physics
+ mp_physics                          = 0,
+ ra_lw_physics                       = 0,
+ ra_sw_physics                       = 0,
+ radt                                = 0,
+ sf_sfclay_physics                   = 0,
+ sf_surface_physics                  = 0,
+ bl_pbl_physics                      = 0,
+ bldt                                = 0,
+ cu_physics                          = 0,
+ cudt                                = 0,
+ num_soil_layers                     = 5,
+ /
+
+ &fdda
+ /
+
+ &dynamics
+ rk_ord                              = 3,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 1,      1,      1,
+ damp_opt                            = 3,
+ zdamp                               = 20000.,
+ dampcoef                            = .1,
+ khdif                               = 00,
+ kvdif                               = 0,
+ smdiv                               = 0.1,
+ emdiv                               = 0.01,
+ epssm                               = 0.1,
+ time_step_sound                     = 6,
+ h_mom_adv_order                     = 5,
+ v_mom_adv_order                     = 3,
+ h_sca_adv_order                     = 5,
+ v_sca_adv_order                     = 3,
+ non_hydrostatic                     = .true.,
+ hybrid_opt                          = 2,
+ etac                                = 0.2,
+ /
+
+ &bdy_control
+ periodic_x                          = .false.,
+ symmetric_xs                        = .false.,
+ symmetric_xe                        = .false.,
+ open_xs                             = .true., 
+ open_xe                             = .true.,
+ periodic_y                          = .true.,
+ symmetric_ys                        = .false.,
+ symmetric_ye                        = .false.,
+ open_ys                             = .false.,
+ open_ye                             = .false.,
+ /
+
+ &grib2
+ /
+
+ &namelist_quilt
+ nio_tasks_per_group = 0,
+ nio_groups = 1,
+ /
diff --git a/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL-51 b/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL-51
new file mode 100644
index 00000000..5f248e75
--- /dev/null
+++ b/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL-51
@@ -0,0 +1,103 @@
+ &time_control
+ run_days                            = 0,
+ run_hours                           = 10,
+ run_minutes                         = 0,
+ run_seconds                         = 0,
+ start_year                          = 0001,
+ start_month                         = 01,
+ start_day                           = 01,
+ start_hour                          = 00,
+ start_minute                        = 00,
+ start_second                        = 00,
+ end_year                            = 0001,
+ end_month                           = 01,
+ end_day                             = 01,
+ end_hour                            = 10,
+ end_minute                          = 00,
+ end_second                          = 00,
+ history_interval                    = 60,
+ frames_per_outfile                  = 1,
+ restart                             = .false.,
+ restart_interval                    = 120,
+ io_form_history                     = 2
+ io_form_restart                     = 2
+ io_form_input                       = 2
+ io_form_boundary                    = 2
+ debug_level                         = 0
+ /
+
+ &domains
+ time_step                           = 20,
+ time_step_fract_num                 = 0,
+ time_step_fract_den                 = 1,
+ max_dom                             = 1,
+ s_we                                = 1,
+ e_we                                = 202,
+ s_sn                                = 1,
+ e_sn                                = 3,
+ s_vert                              = 1,
+ e_vert                              = 51,
+ dx                                  = 2000,
+ dy                                  = 2000,
+ ztop                                = 25000.,
+ /
+
+ &physics
+ mp_physics                          = 0,
+ ra_lw_physics                       = 0,
+ ra_sw_physics                       = 0,
+ radt                                = 0,
+ sf_sfclay_physics                   = 0,
+ sf_surface_physics                  = 0,
+ bl_pbl_physics                      = 0,
+ bldt                                = 0,
+ cu_physics                          = 0,
+ cudt                                = 0,
+ num_soil_layers                     = 5,
+ /
+
+ &fdda
+ /
+
+ &dynamics
+ rk_ord                              = 3,
+ diff_opt                            = 2,      2,      2,
+ km_opt                              = 1,      1,      1,
+ damp_opt                            = 3,
+ zdamp                               = 15000.,
+ dampcoef                            = .08,
+ khdif                               = 00,
+ kvdif                               = 0,
+ smdiv                               = 0.1,
+ emdiv                               = 0.01,
+ epssm                               = 0.1,
+ time_step_sound                     = 6,
+ h_mom_adv_order                     = 5,
+ v_mom_adv_order                     = 3,
+ h_sca_adv_order                     = 5,
+ v_sca_adv_order                     = 3,
+ non_hydrostatic                     = .true.,
+ hybrid_opt                          = 2,
+ etac                                = 0.2,
+ /
+
+ &bdy_control
+ periodic_x                          = .false.,
+ symmetric_xs                        = .false.,
+ symmetric_xe                        = .false.,
+ open_xs                             = .true., 
+ open_xe                             = .true.,
+ periodic_y                          = .true.,
+ symmetric_ys                        = .false.,
+ symmetric_ye                        = .false.,
+ open_ys                             = .false.,
+ open_ye                             = .false.,
+ /
+
+ &grib2
+ /
+
+ &namelist_quilt
+ nio_tasks_per_group = 0,
+ nio_groups = 1,
+ /
diff --git a/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL-schar b/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL-schar
new file mode 100644
index 00000000..2953b336
--- /dev/null
+++ b/wrfv2_fire/test/em_hill2d_x/extras/namelist.input-HILL-schar
@@ -0,0 +1,103 @@
+ &time_control
+ run_days                            = 0,
+ run_hours                           = 20,
+ run_minutes                         = 0,
+ run_seconds                         = 0,
+ start_year                          = 0001,
+ start_month                         = 01,
+ start_day                           = 01,
+ start_hour                          = 00,
+ start_minute                        = 00,
+ start_second                        = 00,
+ end_year                            = 0001,
+ end_month                           = 01,
+ end_day                             = 01,
+ end_hour                            = 10,
+ end_minute                          = 00,
+ end_second                          = 00,
+ history_interval                    = 60,
+ frames_per_outfile                  = 1,
+ restart                             = .false.,
+ restart_interval                    = 120,
+ io_form_history                     = 2
+ io_form_restart                     = 2
+ io_form_input                       = 2
+ io_form_boundary                    = 2
+ debug_level                         = 0
+ /
+
+ &domains
+ time_step                           = 10,
+ time_step_fract_num                 = 0,
+ time_step_fract_den                 = 1,
+ max_dom                             = 1,
+ s_we                                = 1,
+ e_we                                = 202,
+ s_sn                                = 1,
+ e_sn                                = 3,
+ s_vert                              = 1,
+ e_vert                              = 41,
+ dx                                  = 1000,
+ dy                                  = 1000,
+ ztop                                = 20000.,
+ /
+
+ &physics
+ mp_physics                          = 0,
+ ra_lw_physics                       = 0,
+ ra_sw_physics                       = 0,
+ radt                                = 0,
+ sf_sfclay_physics                   = 0,
+ sf_surface_physics                  = 0,
+ bl_pbl_physics                      = 0,
+ bldt                                = 0,
+ cu_physics                          = 0,
+ cudt                                = 0,
+ num_soil_layers                     = 5,
+ /
+
+ &fdda
+ /
+
+ &dynamics
+ rk_ord                              = 3,
+ diff_opt                            = 0,      2,      2,
+ km_opt                              = 1,      1,      1,
+ damp_opt                            = 0,
+ zdamp                               = 0.,
+ dampcoef                            = .08,
+ khdif                               = 00,
+ kvdif                               = 0,
+ smdiv                               = 0.1,
+ emdiv                               = 0.01,
+ epssm                               = 0.1,
+ time_step_sound                     = 6,
+ h_mom_adv_order                     = 5,
+ v_mom_adv_order                     = 3,
+ h_sca_adv_order                     = 5,
+ v_sca_adv_order                     = 3,
+ non_hydrostatic                     = .true.,
+ hybrid_opt                          = 2,
+ etac                                = 0.2,
+ /
+
+ &bdy_control
+ periodic_x                          = .false.,
+ symmetric_xs                        = .false.,
+ symmetric_xe                        = .false.,
+ open_xs                             = .true., 
+ open_xe                             = .true.,
+ periodic_y                          = .true.,
+ symmetric_ys                        = .false.,
+ symmetric_ye                        = .false.,
+ open_ys                             = .false.,
+ open_ye                             = .false.,
+ /
+
+ &grib2
+ /
+
+ &namelist_quilt
+ nio_tasks_per_group = 0,
+ nio_groups = 1,
+ /
diff --git a/wrfv2_fire/test/em_real/.gitignore b/wrfv2_fire/test/em_real/.gitignore
new file mode 100644
index 00000000..0d6de210
--- /dev/null
+++ b/wrfv2_fire/test/em_real/.gitignore
@@ -0,0 +1,27 @@
+# This is the top-level .gitignore file for the "test/em_real" directory     #
+#                                                                            #
+# Filenames and wildcards added below will not be tracked by git in this     #
+# directory. Note that these rules will be supplemented by rules in the      #
+# top-level .gitignore file                                                  #
+#                                                                            #
+# The ignored files in this directory should include the files that are      #
+# linked in by the Makefile from the "run" directory at compile time. Thus,  #
+# this file may require ongoing maintenance as new capabilities are added.   #
+#                                                                            #
+# USE CAUTION WHEN ADDING WILDCARDS THAT YOU DO NOT IMPACT VERSIONED FILES   #
+##############################################################################
+CAM*
+CCN_ACTIVATE.BIN
+CLM*
+ETAMPNEW_DATA*
+*.TBL
+*DATA
+aerosol*
+*s_0_03_0_9
+*.asc
+grib2map.tbl
+gribmap.txt
+ozone*formatted
+tr49t67
+tr49t85
+tr67t85
diff --git a/wrfv2_fire/test/em_real/examples.namelist b/wrfv2_fire/test/em_real/examples.namelist
index 8ef7877f..aeb0b3a7 100755
--- a/wrfv2_fire/test/em_real/examples.namelist
+++ b/wrfv2_fire/test/em_real/examples.namelist
@@ -11,7 +11,7 @@ Note, this is not a namelist.input file. Find what interests you, and cut and pa
  lowest_lev_from_sfc                 = .false.
  use_levels_below_ground             = .true.
  use_surface                         = .true.
- lagrange_order                      = 1
+ lagrange_order                      = 2
  force_sfc_in_vinterp                = 1
  zap_close_levels                    = 500
  sfcp_to_sfcp                        = .false.
@@ -111,7 +111,7 @@ Note, this is not a namelist.input file. Find what interests you, and cut and pa
  /
 
  &domains
- time_step_dfi                       = 60.
+ time_step_dfi                       = 60
 
 ** Using gridded nudging option (note this is a separate namelist record) for
    upperair nudging
@@ -404,11 +404,11 @@ for z_levels means AGL, so -500 is 500 m AGL, and 10000 is 10 km).
  salinity is ocean_s (ppt).
 
  ocean_levels                        = 30,
- ocean_z                             =        5,        15,        25,        35,        45,        55,
-                                             65,        75,        85,        95,       105,       115,
-                                            125,       135,       145,       155,       165,       175,
-                                            185,       195,       210,       230,       250,       270,
-                                            290,       310,       330,       350,       370,       390
+ ocean_z                             =       5.,       15.,       25.,       35.,       45.,       55.,
+                                            65.,       75.,       85.,       95.,      105.,      115.,
+                                           125.,      135.,      145.,      155.,      165.,      175.,
+                                           185.,      195.,      210.,      230.,      250.,      270.,
+                                           290.,      310.,      330.,      350.,      370.,      390.
  ocean_t                             = 302.3493,  302.3493,  302.3493,  302.1055,  301.9763,  301.6818,
                                        301.2220,  300.7531,  300.1200,  299.4778,  298.7443,  297.9194,
                                        297.0883,  296.1443,  295.1941,  294.1979,  293.1558,  292.1136,
@@ -541,3 +541,71 @@ which can be changed by the user for sensitivity testing purposes.
  rBinSize            = 0.0001,0.0001,0.0001,
  minDeepFreq         = 0.333, 0.333, 0.333,
  minShallowFreq      = 0.01,  0.01,  0.01, 
+
+
+** To write out an input file during the model simulation.
+
+&time_control
+ write_input                         = .TRUE.,
+ inputout_interval_m                 = 60, 60, 60
+ input_outname                       = "wrfinput_out_d_"
+ inputout_begin_h                    = 3, 6, 6
+ inputout_end_h                      = 9, 6, 6
+
+** To use climatological data in Thompson microphysics option 28: in addition to
+process additional data in metgrid, use these:
+
+&domains
+ wif_input_opt                       = 1
+ num_wif_levels                      = 30
+
+&physics
+ mp_physics                          = 28,    28,    28,
+ use_aero_icbc                       = .true.
+
+
+** The hybrid vertical coordinate (HVC) requires three pieces:
+1. The WRF and real codes must be built with HVC activated (./configure -hyb)
+2. The eta location (etac) at which the eta levels higher up in the atmosphere
+   become isobaric must be defined (suggested default in Registry).
+3. The run-time option to select the HVC (hybrid_opt, default is OFF): 
+&dynamics
+ hybrid_opt          = 2,
+ etac                = 0.2,
+
+** New mechanism to specify physics:
+
+&physics
+ physics_suite = 'CONUS'
+
+which is equivalent to
+
+ mp_physics         = 8,
+ cu_physics         = 6,
+ ra_lw_physics      = 4,
+ ra_sw_physics      = 4,
+ bl_pbl_physics     = 2,
+ sf_sfclay_physics  = 2,
+ sf_surface_physics = 2,
+
+&physics
+ physics_suite = 'TROPICAL'
+
+which is equivalent to
+
+ mp_physics         = 6,
+ cu_physics         = 16,
+ ra_lw_physics      = 4,
+ ra_sw_physics      = 4,
+ bl_pbl_physics     = 1,
+ sf_sfclay_physics  = 91,
+ sf_surface_physics = 2,
+
+
+To overwrite the cu_physics option for a second nest, set 
+
+ &physics
+ physics_suite                       = 'tropical'
+ cu_physics                          = -1,    -1,     0,
+ ...
+
diff --git a/wrfv2_fire/test/em_real/namelist.input b/wrfv2_fire/test/em_real/namelist.input
index f1ff2ee8..b0f27585 100755
--- a/wrfv2_fire/test/em_real/namelist.input
+++ b/wrfv2_fire/test/em_real/namelist.input
@@ -52,20 +52,11 @@
  /
 
  &physics
- mp_physics                          = 3,     3,     3,
- ra_lw_physics                       = 1,     1,     1,
- ra_sw_physics                       = 1,     1,     1,
+ physics_suite                       = 'CONUS'
  radt                                = 30,    30,    30,
- sf_sfclay_physics                   = 1,     1,     1,
- sf_surface_physics                  = 2,     2,     2,
- bl_pbl_physics                      = 1,     1,     1,
  bldt                                = 0,     0,     0,
- cu_physics                          = 1,     1,     0,
  cudt                                = 5,     5,     5,
- isfflx                              = 1,
- ifsnow                              = 1,
  icloud                              = 1,
- surface_input_source                = 3,
  num_soil_layers                     = 4,
  num_land_cat                        = 21,
  sf_urban_physics                    = 0,     0,     0,
@@ -89,6 +80,7 @@
  non_hydrostatic                     = .true., .true., .true.,
  moist_adv_opt                       = 1,      1,      1,     
  scalar_adv_opt                      = 1,      1,      1,     
+ gwd_opt                             = 1,
  /
 
  &bdy_control
diff --git a/wrfv2_fire/test/em_real/namelist.input.4km b/wrfv2_fire/test/em_real/namelist.input.4km
index 22479cb1..0018bdd5 100755
--- a/wrfv2_fire/test/em_real/namelist.input.4km
+++ b/wrfv2_fire/test/em_real/namelist.input.4km
@@ -52,7 +52,7 @@
  /
 
  &physics
- mp_physics                          = 6,     6,     6,
+ mp_physics                          = 8,     8,     8,
  ra_lw_physics                       = 4,     4,     4,
  ra_sw_physics                       = 4,     4,     4,
  radt                                = 10,    10,    10,
@@ -60,12 +60,10 @@
  sf_surface_physics                  = 2,     2,     2,
  bl_pbl_physics                      = 1,     1,     1,
  bldt                                = 0,     0,     0,
+ ysu_topdown_pblmix                  = 1,
  cu_physics                          = 0,     0,     0,
  cudt                                = 0,     0,     0,
- isfflx                              = 1,
- ifsnow                              = 0,
  icloud                              = 1,
- surface_input_source                = 3,
  num_soil_layers                     = 4,
  num_land_cat                        = 21,
  sf_urban_physics                    = 0,     0,     0,
@@ -87,8 +85,8 @@
  khdif                               = 0,      0,      0,
  kvdif                               = 0,      0,      0,
  non_hydrostatic                     = .true., .true., .true.,
- moist_adv_opt                       = 1,      1,      1,     
- scalar_adv_opt                      = 1,      1,      1,     
+ moist_adv_opt                       = 2,      2,      2,
+ scalar_adv_opt                      = 2,      2,      2,
  /
 
  &bdy_control
diff --git a/wrfv2_fire/test/em_real/namelist.input.global b/wrfv2_fire/test/em_real/namelist.input.global
index aa938c20..b8484980 100755
--- a/wrfv2_fire/test/em_real/namelist.input.global
+++ b/wrfv2_fire/test/em_real/namelist.input.global
@@ -49,27 +49,23 @@
  parent_grid_ratio                   = 1,     5,     5,
  parent_time_step_ratio              = 1,     5,     5,
  feedback                            = 1,
- smooth_option                       = 00
+ smooth_option                       = 0,
  /
 
  &physics
  mp_physics                          = 3,     3,     3,
- ra_lw_physics                       = 1,     1,     1,
- ra_sw_physics                       = 1,     1,     1,
+ ra_lw_physics                       = 4,     4,     4,
+ ra_sw_physics                       = 4,     4,     4,
  radt                                = 30,    30,    30,
  sf_sfclay_physics                   = 1,     1,     1,
- sf_surface_physics                  = 1,     1,     1,
+ sf_surface_physics                  = 2,     2,     2,
  bl_pbl_physics                      = 1,     1,     1,
  bldt                                = 0,     0,     0,
- cu_physics                          = 1,     1,     0,
- cudt                                = 5,     5,     5,
- isfflx                              = 1,
- ifsnow                              = 0,
+ cu_physics                          = 16,   16,     0,
+ cudt                                = 0,     0,     0,
  icloud                              = 1,
- surface_input_source                = 3,
- num_soil_layers                     = 5,
+ num_soil_layers                     = 4,
  num_land_cat                        = 21,
- mp_zero_out                         = 0,
  /
 
  &fdda
@@ -91,6 +87,7 @@
  tke_adv_opt                         = 0,      0,      0,     
  fft_filter_lat                      = 45.,
  w_damping                           = 1,
+ gwd_opt                             = 1,
  /
 
  &bdy_control
diff --git a/wrfv2_fire/test/em_real/namelist.input.jan00 b/wrfv2_fire/test/em_real/namelist.input.jan00
index 8b97a646..9b61b3b9 100755
--- a/wrfv2_fire/test/em_real/namelist.input.jan00
+++ b/wrfv2_fire/test/em_real/namelist.input.jan00
@@ -52,7 +52,7 @@
  /
 
  &physics
- mp_physics                          = 3,     3,     3,
+ mp_physics                          = 5,     5,     5,
  ra_lw_physics                       = 4,     4,     4,
  ra_sw_physics                       = 4,     4,     4,
  radt                                = 30,    30,    30,
@@ -62,18 +62,11 @@
  bldt                                = 0,     0,     0,
  cu_physics                          = 1,     1,     0,
  cudt                                = 5,     5,     5,
- isfflx                              = 1,
- ifsnow                              = 0,
  icloud                              = 1,
- surface_input_source                = 3,
+ cu_rad_feedback                     = .true.,.true.,.false.,
  num_soil_layers                     = 4,
  num_land_cat                        = 21,
  sf_urban_physics                    = 0,     0,     0,
- maxiens                             = 1,
- maxens                              = 3,
- maxens2                             = 3,
- maxens3                             = 16,
- ensdim                              = 144,
  /
 
  &fdda
@@ -86,7 +79,7 @@
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
- damp_opt                            = 0,
+ damp_opt                            = 3,
  zdamp                               = 5000.,  5000.,  5000.,
  dampcoef                            = 0.2,    0.2,    0.2
  khdif                               = 0,      0,      0,
@@ -94,6 +87,7 @@
  non_hydrostatic                     = .true., .true., .true.,
  moist_adv_opt                       = 1,      1,      1,     
  scalar_adv_opt                      = 1,      1,      1,     
+ gwd_opt                             = 1,
  /
 
  &bdy_control
diff --git a/wrfv2_fire/test/em_real/namelist.input.jun01 b/wrfv2_fire/test/em_real/namelist.input.jun01
index b3227982..065054cd 100755
--- a/wrfv2_fire/test/em_real/namelist.input.jun01
+++ b/wrfv2_fire/test/em_real/namelist.input.jun01
@@ -52,7 +52,7 @@
  /
 
  &physics
- mp_physics                          = 6,     6,     6,
+ mp_physics                          = 8,     8,     8,
  ra_lw_physics                       = 4,     4,     4,
  ra_sw_physics                       = 4,     4,     4,
  radt                                = 10,    10,    10,
@@ -62,10 +62,8 @@
  bldt                                = 0,     0,     0,
  cu_physics                          = 1,     0,     0,
  cudt                                = 5,     5,     5,
- isfflx                              = 1,
- ifsnow                              = 0,
  icloud                              = 1,
- surface_input_source                = 3,
+ cu_rad_feedback                     = .true.,.false.,.f.,
  num_soil_layers                     = 4,
  num_land_cat                        = 21,
  sf_urban_physics                    = 0,     0,     0,
@@ -81,7 +79,7 @@
  diff_6th_opt                        = 0,      0,      0,
  diff_6th_factor                     = 0.12,   0.12,   0.12,
  base_temp                           = 290.
- damp_opt                            = 0,
+ damp_opt                            = 3,
  zdamp                               = 5000.,  5000.,  5000.,
  dampcoef                            = 0.2,    0.2,    0.2
  khdif                               = 0,      0,      0,
@@ -89,6 +87,7 @@
  non_hydrostatic                     = .true., .true., .true.,
  moist_adv_opt                       = 1,      1,      1,     
  scalar_adv_opt                      = 1,      1,      1,     
+ gwd_opt                             = 1,
  /
 
  &bdy_control
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/README.NMM.TROPICAL_CYCLONE b/wrfv2_fire/test/nmm_tropical_cyclone/README.NMM.TROPICAL_CYCLONE
index 078db4a6..177cb8a7 100644
--- a/wrfv2_fire/test/nmm_tropical_cyclone/README.NMM.TROPICAL_CYCLONE
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/README.NMM.TROPICAL_CYCLONE
@@ -1,5 +1,5 @@
 README.Idealized_HWRF
-Last updated:  May 2013
+Last updated:  Nov 2016
 
 This README file provides a short overview of the HWRF idealized tropical cyclone test case. For details, please refer to the HWRF user’s guide and scientific documentation at http://www.dtcenter.org/HurrWRF/users/docs/index.php.
 
@@ -15,8 +15,9 @@ The default initial ambient base state assumes a f-plane at the latitude of 12.5
 
 The lateral boundary conditions used in the HWRF idealized simulation are the same as  used in real data cases. This inevitably leads to some reflection when gravity waves emanating from the vortex reach the outer domain lateral boundaries.
 
+The landfalling option is selected in the namelist file land.nml.  The default is to NOT include landfall.  The land strip can be configured to move underneath of the idealized storm (which remains centered), either east-to-west or west-to-east.  The landfall option must be used with the GFDL slab land surface model.
 
-The idealized simulation is configured  for the operational HWRF triple nested domain configuration with grid spacing at 27-, 9-, and 3-km.  All the operational atmospheric physics, as well as the supported experimental physics options in HWRF, can be used in  the idealized HWRF framework.
+The idealized simulation is configured  for the operational HWRF triple nested domain configuration with grid spacing at 18-, 6-, and 2-km.  All the operational atmospheric physics, as well as the supported experimental physics options in HWRF, can be used in  the idealized HWRF framework.
 
 
 
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/land.nml b/wrfv2_fire/test/nmm_tropical_cyclone/land.nml
new file mode 100644
index 00000000..81193c80
--- /dev/null
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/land.nml
@@ -0,0 +1,22 @@
+&init_land
+mvland = .false.		!true=land or false=only ocean
+imin = 260			!setup the land strip for motion
+imax = 288
+jmin = 0
+jmax = 576
+logic_temp = .false.		!true=initial surface temperature thru s_temp. false=default (first level tmp)
+s_temp = 308.0			!initial surface temperature for the land strip
+VEG_ID = 19			!land surface vegetaion parameter ID. refer VEGPARM.TBL
+SOIL_ID = 1			!land surface soil parameter ID. refer SOILPARM.TBL
+/
+
+¶m_land
+DIRN = 1			!1=W-E direction, 2=E-W direction
+VEG_ID = 19			!same as above. Has to be set. Do not leave it blank
+SOIL_ID = 1			!same as above. Has to be set. Do not leave it blank
+land_emiss = 0.90		!emissivity for radiation phys. Refer VEGPARM.TBL for indicative values (0-1)
+land_albedo = 0.25		!albedo for radiation physics. Refer VEGPARM.TBL for indicative values (0-1)
+land_vgfrac = 0.20              !vegetation fraction (0-0.99)
+land_z0 = 0.01			!surface roughness. Refer VEGPARM.TBL
+land_smc = 0.02			!soil moisture. Refer SOILPARM.TBL
+/
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/namelist.input b/wrfv2_fire/test/nmm_tropical_cyclone/namelist.input
index 7159c97c..1e97653f 100644
--- a/wrfv2_fire/test/nmm_tropical_cyclone/namelist.input
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/namelist.input
@@ -1,13 +1,13 @@
  &time_control
- start_year                          = 2008, 2008, 2008,
- start_month                         = 09, 09, 09,
- start_day                           = 06, 06, 06,
+ start_year                          = 2012, 2012, 2012,
+ start_month                         = 10, 10, 10,
+ start_day                           = 26, 26, 26,
  start_hour                          = 12, 12, 12,
  start_minute                        = 00,      00,     00,
  start_second                        = 00,      00,     00,
- end_year                            = 2008, 2008, 2008,
- end_month                           = 09, 09, 09,
- end_day                             = 11, 11, 11,
+ end_year                            = 2012, 2012, 2012,
+ end_month                           = 10, 10, 10,
+ end_day                             = 31, 31, 31,
  end_hour                            = 12, 12, 12,
  end_minute                          = 00, 00, 00,
  end_second                          = 00,      00,     00,
@@ -29,20 +29,21 @@
  auxinput1_inname                    = "met_nmm.d."
  debug_level                         = 1
  override_restart_timers             = T
+ nocolons			     = T
  /
 
  &fdda
  /
 
  &domains
- time_step                           = 45,
- time_step_fract_num                 = 0,
- time_step_fract_den                 = 1,
+ time_step                           = 38,
+ time_step_fract_num                 = 4,
+ time_step_fract_den                 = 7,
  max_dom                             = 3,
  s_we                                = 1,             1,        1,
- e_we                                = 216,         106,       198,
+ e_we                                = 288,         142,       265,
  s_sn                                = 1,             1,        1,
- e_sn                                = 432,         204,       354,
+ e_sn                                = 576,         274,       472,
  s_vert                              = 1,             1,	1,
  e_vert                              = 61,   61,    61,
  dx                                  = 0.135,      .045,   .015,
@@ -57,11 +58,11 @@
  parent_id                           = 0,              1,	2,
  parent_grid_ratio                   = 1,              3,	3,
  parent_time_step_ratio              = 1,              3,	3,
- i_parent_start                      = 0,             90,	20,
- j_parent_start                      = 0,            182,	45,
+ i_parent_start                      = 0,            125,	27,
+ j_parent_start                      = 0,            243,	57,
  feedback                            = 1,
  num_moves                           = -99
- num_metgrid_levels                  = 27,
+ num_metgrid_levels                  = 22,
  p_top_requested                     =  200.0,
  ptsgm                               = 15000,
   eta_levels = 1.0, 0.995253, 0.990479, 0.985679, 0.980781, 0.975782, 0.970684, 0.965486, 0.960187, 0.954689, 0.948991, 0.943093, 0.936895, 0.930397, 0.923599, 0.916402, 0.908404, 0.899507, 0.888811, 0.876814, 0.862914, 0.847114, 0.829314, 0.809114, 0.786714, 0.762114, 0.735314, 0.706714, 0.676614, 0.645814, 0.614214, 0.582114, 0.549714, 0.517114, 0.484394, 0.451894, 0.419694, 0.388094, 0.356994, 0.326694, 0.297694, 0.270694, 0.245894, 0.223694, 0.203594, 0.185494, 0.169294, 0.154394, 0.140494, 0.127094, 0.114294, 0.101894, 0.089794, 0.078094, 0.066594, 0.055294, 0.044144, 0.033054, 0.022004, 0.010994, 0.0,
@@ -70,11 +71,11 @@
 /
  &physics
  num_soil_layers                     = 4,
- mp_physics                          = 85,           85,	85,
- ra_lw_physics                       = 98,          98,		98,
- ra_sw_physics                       = 98,          98,		98,
+ mp_physics                          = 5,           5,	5,
+ ra_lw_physics                       = 4,          4,		4,
+ ra_sw_physics                       = 4,          4,		4,
  sf_sfclay_physics                   = 88,          88,    	88,
- sf_surface_physics                  = 88,          88,		88,
+ sf_surface_physics                  = 2,          2,		2,
  bl_pbl_physics                      = 3,          3,		3,
  cu_physics                          = 84,         84,		0,
  mommix                              = 1.0,       1.0,		1.0,
@@ -84,18 +85,18 @@
  h_diff                              = 1.0,        1.0,		1.0,
  gwd_opt                             = 2, 0,		0,
  sfenth                              = 0.0,        0.0,		0.0,
- nrads                               =  80,240,720    ,
- nradl                               =  80,240,720    ,
+ nrads                               =  28,84,252    ,
+ nradl                               =  28,84,252    ,
  nphs                                =       2,6,6    ,
  ncnvc                               =       2,6,6    ,
 
- movemin                             =  3,6,12         ,
+ ntrack                              =  7,7,14         ,
 
 ! IMPORTANT: dt*nphs*movemin for domain 2 and 3 must be 540 and 180, respectively
 !            AND the history output times (10800, 10800, 3600) must be
 !            divisible by dt*nphs*movemin for domains 1, 2 and 3
 
- gfs_alpha                           =  0.7,0.7,0.7     ,
+ gfs_alpha                           = -1.0, -1.0, -1.0    ,
  sas_pgcon                           =  0.55,0.2,0.2 ,
 sas_mass_flux     = 0.5,0.5,0.5, 
  co2tf                               = 1,
@@ -103,6 +104,16 @@ sas_mass_flux     = 0.5,0.5,0.5,
 
 ! Disable nest movement at certain intervals to prevent junk in the output files:
  nomove_freq                         = 0.0,      6.0,      6.0, ! hours
+  tg_option = 1,
+  ntornado = 2, 5, 15,
+  ens_pblamp = 0.2,
+  ens_random_seed = 99,
+  ens_sasamp = 50.0,
+  icloud = 3,
+  icoef_sf = 2, 2, 2,
+  lcurr_sf = F, F, F,
+  pert_pbl = F,
+  pert_sas = F,
 /
 
  &dynamics
@@ -119,12 +130,12 @@ sas_mass_flux     = 0.5,0.5,0.5,
  specified                           = .true. /
 
  &namelist_quilt 
-
+ poll_servers                        = T,
  nio_tasks_per_group                 = 0,
  nio_groups                          = 1 /
 
  &logging
-  compute_slaves_silent=.true.
+  compute_tasks_silent=.true.
   io_servers_silent=.true.
   stderr_logging=0
  /
diff --git a/wrfv2_fire/test/nmm_tropical_cyclone/namelist.wps b/wrfv2_fire/test/nmm_tropical_cyclone/namelist.wps
index 0334ae10..e69b2286 100644
--- a/wrfv2_fire/test/nmm_tropical_cyclone/namelist.wps
+++ b/wrfv2_fire/test/nmm_tropical_cyclone/namelist.wps
@@ -1,27 +1,29 @@
 &share
  wrf_core = 'NMM',
- max_dom = 2,
- start_date = '2008-09-06_12:00:00',
- end_date   = '2008-09-11_12:00:00',
+ max_dom = 3,
+ start_date = '2012-10-26_12:00:00',
+ end_date   = '2012-10-31_12:00:00',
  interval_seconds = 432000
  io_form_geogrid = 2,
+ nocolons = T,
 /
 
 &geogrid
- parent_id         =   1,   1,
- parent_grid_ratio =   1,   3,
- i_parent_start    =   1,  78,
- j_parent_start    =   1,  96,
- e_we              =  160,  80,
- e_sn              =  310, 134,
- geog_data_res     = '30s','30s',
- dx = 0.18,
- dy = 0.18,
+ parent_id         =   1,   1, 2,
+ parent_grid_ratio =   1,   3, 3,
+ i_parent_start    =   1,  10, 10,
+ j_parent_start    =   1,  10, 10,
+ e_we              =  288, 142, 265,
+ e_sn              =  576, 274, 472,
+ geog_data_res     = '2m','2m', '2m',
+ dx = 0.135,
+ dy = 0.135,
  map_proj = 'rotated_ll',
  ref_lat   =  21.0,
  ref_lon   =  287.250,
  stand_lon =  287.250,
- geog_data_path = '/scratch1/portfolios/BMC/dtc-hwrf/Shaowu.Bao/WPS_GEOG'
+ geog_data_path = '/glade/p/ral/jnt/tools/geog/'
+ opt_geogrid_tbl_path = "./",
 /
 
 &ungrib
@@ -32,6 +34,7 @@
 &metgrid
  fg_name = 'new_GFS',
  io_form_metgrid = 2,
+ opt_metgrid_tbl_path = "./",
 /
 
 &mod_levs
diff --git a/wrfv2_fire/tools/any_updates_in_registry.csh b/wrfv2_fire/tools/any_updates_in_registry.csh
new file mode 100755
index 00000000..9dc5da34
--- /dev/null
+++ b/wrfv2_fire/tools/any_updates_in_registry.csh
@@ -0,0 +1,85 @@
+#!/bin/csh
+
+unalias rm cp
+
+#	Easy way to get this hash is to do a "git log README" in the top WRFV3 directory
+
+set LAST_RELEASE_HASH = a98c4ada98934ef0
+
+if ( -e newbies ) then
+	rm -rf newbies
+endif
+touch newbies
+
+pushd ../Registry >& /dev/null
+set Registry_files = `ls -1 Registry* registry*`
+popd >& /dev/null
+
+foreach f ( $Registry_files )
+	if ( ( $f == Registry.CONVERT ) || \
+	     ( $f == Registry.EM_COMMON.var ) || \
+	     ( $f == Registry.NMM ) || \
+	     ( $f == registry.chem ) || \
+	     ( $f == registry.tracker ) || \
+	     ( $f == registry.var ) || \
+	     ( $f == registry.var_chem ) || \
+	     ( $f == Registry ) ) then
+	else
+
+		#	Check existend of file within last release
+
+		git diff ${LAST_RELEASE_HASH}:Registry/$f -- ../Registry/$f >& /dev/null
+		set OK = $status
+		if ( $OK == 0 ) then
+
+			#	Yep, it existed, process the diffs
+
+			git diff ${LAST_RELEASE_HASH}:Registry/$f -- ../Registry/$f >& ad.${f}.txt
+
+			#	Check if this is an empty file
+
+			ls -ls ad.${f}.txt | grep " 0 " >& /dev/null
+			set ZERO_SIZED = $status
+			if ( $ZERO_SIZED == 0 ) then
+
+				#	Empty file, remove it from consideration
+
+				rm -rf ad.${f}.txt
+			else
+
+				#	Check for new rconfig entries
+
+				grep "^+" ad.${f}.txt | grep -i rconfig >& /dev/null
+				set NEW_STUFF = $status
+				if ( $NEW_STUFF == 0 ) then
+
+					#	Yep, found some rconfigs with a leading plus, international sign of adding something or other
+
+					echo " "
+					echo processing $f
+
+					#	Check to see if this new rconfig is talked about in the README.namelist
+
+					foreach g ( `grep "^+" ad.${f}.txt | grep -i rconfig | awk '{print $3}' ` )
+					
+						grep -iq $g ../run/README.namelist
+						set ALREADY_DESCRIBED = $status
+
+						if ( $ALREADY_DESCRIBED != 0 ) then
+							echo $g is not described in README.namelist
+						endif
+					end
+
+					
+				endif
+				
+			endif
+
+		else
+		
+			#	Nope, did not previously exist.  New file needs to handled separately
+
+			echo $f >> newbies
+		endif
+	endif
+end
diff --git a/wrfv2_fire/tools/commit_form.txt b/wrfv2_fire/tools/commit_form.txt
index f55173ee..76f9fc8f 100644
--- a/wrfv2_fire/tools/commit_form.txt
+++ b/wrfv2_fire/tools/commit_form.txt
@@ -1,20 +1,21 @@
-TYPE: bug fix, enhancement, new feature, feature removed, no impact, text only
+The first line should be a single-line "purpose" for this change
 
-KEYWORDS: 5 to 10 words related to commit
+TYPE: choose one of [bug fix, enhancement, new feature, feature removed, no impact, text only]
 
-SOURCE: Either "developer's name (affiliation)" .XOR. "internal" for a WRF Dev committee member
-
-PURPOSE: single line, usually one sentence
+KEYWORDS: 5 to 10 words related to commit, separated by commas
 
-DESCRIPTION OF CHANGES: 
-Paragraph describing problem, solution, and required changes.
+SOURCE: Either "developer's name (affiliation)" .XOR. "internal" for a WRF Dev committee member
 
-LIST OF MODIFIED FILES (annotated if not obvious, not required to be on a single line): 
+DESCRIPTION OF CHANGES: One or more paragraphs describing problem, solution, and required changes.
 
-TESTS CONDUCTED (explicitly state mandatory, voluntary, and assigned tests, not required to be on a single line):
+LIST OF MODIFIED FILES: list of changed files (use `git diff --name-status master` to get formatted list)
 
+TESTS CONDUCTED: Explicitly state if a WTF and or other tests were run, or are pending. For more complicated changes please be explicit!
 
+------------------------------------------------------------------
 
+For github pull requests, the beginning single-line "purpose" should be entered in the title line
+See https://github.com/wrf-model/WRF/wiki/Changes-to-the-WRF-code-from-start-to-finish for examples
 
 Description of commit types:
 - "bug fix" 
diff --git a/wrfv2_fire/tools/fortran_2008_gamma_test.F b/wrfv2_fire/tools/fortran_2008_gamma_test.F
new file mode 100644
index 00000000..aa6659f6
--- /dev/null
+++ b/wrfv2_fire/tools/fortran_2008_gamma_test.F
@@ -0,0 +1,7 @@
+      PROGRAM test_2008_gamma
+      IMPLICIT NONE
+      REAL :: x , y
+      x = 4
+      y = gamma ( x ) 
+      print *,'gamma(',x,') = ',y
+      END PROGRAM test_2008_gamma
diff --git a/wrfv2_fire/tools/gen_allocs.c b/wrfv2_fire/tools/gen_allocs.c
index 13164a57..685b126e 100644
--- a/wrfv2_fire/tools/gen_allocs.c
+++ b/wrfv2_fire/tools/gen_allocs.c
@@ -44,7 +44,7 @@ gen_alloc1 ( char * dirname )
   get_count_for_alloc( &Domain, &numguys , stats) ;  /* howmany deez guys? */
   fprintf(stderr,"Registry INFO variable counts: 0d %d 1d %d 2d %d 3d %d\n",stats[0],stats[1],stats[2],stats[3]) ; 
   fprintf(fp,"#if 1\n") ;
-  gen_alloc2( fp , "grid%", &Domain, &startpiece , &iguy, &fraction, numguys, FRAC, 1 ) ;
+  gen_alloc2( fp , "grid%", NULL, &Domain, &startpiece , &iguy, &fraction, numguys, FRAC, 1 ) ;
   fprintf(fp,"#endif\n") ;
   close_the_file( fp ) ;
   return(0) ;
@@ -77,13 +77,14 @@ int
 nolistthese( char * ) ;
 
 int
-gen_alloc2 ( FILE * fp , char * structname , node_t * node, int *j, int *iguy, int *fraction, int numguys, int frac, int sw ) /* 1 = allocate, 2 = just count */
+gen_alloc2 ( FILE * fp , char * structname , char * structname2 , node_t * node, int *j, int *iguy, int *fraction, int numguys, int frac, int sw ) /* 1 = allocate, 2 = just count */
 {
   node_t * p ;
   int tag ;
   char post[NAMELEN], post_for_count[NAMELEN] ;
   char fname[NAMELEN], dname[NAMELEN], dname_tmp[NAMELEN] ;
   char x[NAMELEN] ;
+  char x2[NAMELEN], fname2[NAMELEN] ;
   char dimname[3][NAMELEN] ;
   char tchar ;
   unsigned int *io_mask ;
@@ -217,10 +218,15 @@ if ( tag == 1 )
         } else {
           strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
         }
+        if ( structname2 != NULL ) {
+          sprintf(fname2,"%s%s",structname2,fname) ;
+        } else {
+          strcpy(fname2,fname) ;
+        }
 
 /* check for errors in memory allocation */
 
-       if ( ! p->boundary_array ) { fprintf(fp,"IF(okay_to_alloc.AND.in_use_for_config(id,'%s')",fname) ; } 
+       if ( ! p->boundary_array ) { fprintf(fp,"IF(okay_to_alloc.AND.in_use_for_config(id,'%s')",fname2) ; }
        else                       { fprintf(fp,"IF(.TRUE.") ; }
 
        if ( ! ( p->node_kind & FOURD ) && sw == 1 &&
@@ -475,7 +481,8 @@ if ( tag == 1 )
       if ( p->type->type_type == DERIVED )
       {
         sprintf(x,"%s%s%%",structname,p->name ) ;
-        gen_alloc2(fp,x, p->type, j, iguy, fraction, numguys, 1, sw) ;
+        sprintf(x2,"%s%%",p->name ) ;
+        gen_alloc2(fp,x, x2, p->type, j, iguy, fraction, numguys, 1, sw) ;
       }
     }
   } /* fraction loop */
@@ -502,7 +509,7 @@ gen_alloc_count1 ( char * dirname )
   else                       { sprintf(fname,"%s",fn) ; }
   if ((fp = fopen( fname , "w" )) == NULL ) return(1) ;
   print_warning(fp,fname) ;
-  gen_alloc2( fp , "grid%", &Domain, 0 ) ;
+  gen_alloc2( fp , "grid%", NULL, &Domain, 0 ) ;
   close_the_file( fp ) ;
   return(0) ;
 }
diff --git a/wrfv2_fire/tools/gen_scalar_indices.c b/wrfv2_fire/tools/gen_scalar_indices.c
index 6c66c578..5836659a 100644
--- a/wrfv2_fire/tools/gen_scalar_indices.c
+++ b/wrfv2_fire/tools/gen_scalar_indices.c
@@ -12,6 +12,7 @@
 #include "registry.h"
 #include "data.h"
 
+#define NULLCHARPTR   (char *) 0
 
 int
 gen_scalar_indices ( char * dirname )
@@ -116,6 +117,7 @@ gen_scalar_indices1 ( FILE * fp, FILE ** fp2 )
   node_t * p, * memb , * pkg, * rconfig, * fourd, *x ; 
   char * c , *pos1, *pos2 ;
   char assoc_namelist_var[NAMELEN], assoc_namelist_choice[NAMELEN], assoc_4d[NAMELEN_LONG], fname[NAMELEN_LONG] ;
+  char fname2[NAMELEN], tmp1[NAMELEN], tmp2[NAMELEN] ;
   char scalars_str[NAMELEN_LONG] ;
   char * scalars ;
   int i ;
@@ -151,7 +153,7 @@ gen_scalar_indices1 ( FILE * fp, FILE ** fp2 )
           if ( (fourd=get_4d_entry( assoc_4d )) != NULL || !strcmp( assoc_4d, "state" ) ) {
             for ( c = strtok_rentr(NULL,",",&pos2) ; c != NULL ; c = strtok_rentr(NULL,",",&pos2) )
             {
-              if ( fourd != NULL && ( ( x = get_entry( c , fourd->members )) != NULL ) ) {
+              if ( fourd != NULL && ( ( x = get_entry_r( c , NULL, fourd->members )) != NULL ) ) {
                 fprintf(fp,"   IF ( %s_index_table( PARAM_%s , idomain ) .lt. 1 ) THEN\n",assoc_4d,c) ;
                 fprintf(fp,"     %s_num_table(idomain) = %s_num_table(idomain) + 1\n",assoc_4d,assoc_4d) ;
                 fprintf(fp,"     P_%s = %s_num_table(idomain)\n",c,assoc_4d) ;
@@ -165,7 +167,7 @@ gen_scalar_indices1 ( FILE * fp, FILE ** fp2 )
                   /* set io_mask accordingly for gen_wrf_io to know that it should generate i/o for _b and _bt */
                   /* arrays */
                   sprintf(fourd_bnd,"%s_b",assoc_4d) ;
-                  if ( get_entry( fourd_bnd  ,Domain.fields) != NULL ) {
+                  if ( get_entry_r( fourd_bnd, NULL, Domain.fields) != NULL ) {
                      x->boundary = 1 ;
                   }
                 }
@@ -181,7 +183,7 @@ gen_scalar_indices1 ( FILE * fp, FILE ** fp2 )
                 }
 
                 fprintf(fp,"   F_%s = .TRUE.\n",c) ;
-              } else if ((p = get_entry( c , Domain.fields )) != NULL ) {
+              } else if ((p = get_entry_r( c , NULL, Domain.fields )) != NULL ) {
                 int tag, fo  ;
                 for ( tag = 1 ; tag <= p->ntl ; tag++ )
                   {
@@ -190,11 +192,25 @@ gen_scalar_indices1 ( FILE * fp, FILE ** fp2 )
                   } else {
                     strcpy(fname,field_name(t4,p,(p->ntl>1)?tag:0)) ;
                   }
-                  make_lower_case(fname)  ;
+                  if ( strchr (c, '%') != NULLCHARPTR ) {
+                    strcpy(fname2,c) ;
+                  } else {
+                    sprintf(tmp1,"%s_tend",p->name) ;
+                    sprintf(tmp2,"%s_old",p->name) ;
+                    if ( !strcmp(c, tmp1) ) {
+                      strcpy(fname2,tmp1) ;
+                    } else if ( !strcmp(c, tmp2) ) {
+                      strcpy(fname2,tmp2) ;
+                    } else {
+                      strcpy(fname2,fname) ;
+                    }
+                  }
+
+                  make_lower_case(fname2)  ;
 
-                  fo = fname[0]-'a' ;
+                  fo = fname2[0]-'a' ;
 
-                  fprintf(fp2[fo],"IF(TRIM(vname).EQ.'%s')THEN\n",fname) ;
+                  fprintf(fp2[fo],"IF(TRIM(vname).EQ.'%s')THEN\n",fname2) ;
                   fprintf(fp2[fo],"  IF(uses.EQ.0)THEN\n");
                   fprintf(fp2[fo],"    in_use = model_config_rec%%%s%s.EQ.%s\n",assoc_namelist_var,(atoi(rconfig->nentries)!=1)?"(id)":"",assoc_namelist_choice) ;
                   fprintf(fp2[fo],"    uses = 1\n") ;
diff --git a/wrfv2_fire/tools/non_ascii_finder.F b/wrfv2_fire/tools/non_ascii_finder.F
new file mode 100644
index 00000000..c5d97451
--- /dev/null
+++ b/wrfv2_fire/tools/non_ascii_finder.F
@@ -0,0 +1,240 @@
+! To remove the DOS carriage returns from Windows machines:
+! perl -pi -e 's/\r\n|\n|\r/\n/g'   file-to-convert  # Convert to UNIX
+! This program is not required for that.
+! For completeness, from stackoverflow:
+! perl -pi -e 's/\r\n|\n|\r/\r\n/g' file-to-convert  # Convert to DOS
+!
+! The purpose of this program is to scan through all of the 
+! lines of a Fortran file to detect if there are any character
+! codes (excluding the ubiquitously used tab character) outside
+! the range of 32 to 127 (the standard printable ASCII character 
+! set).
+
+! The "Fortran 2003 Handbook" (Adams et al. 2009), in section 3.1.1,
+! lists the standard Fortran character set, which is consistent 
+! with the restriction of the ASCII character codes from 32 
+! through 127 (inclusive).
+
+! So far during source code testing, all of the special characters 
+! outside of the ASCII printable character range have been used 
+! within comments.  The WRF model strips comments before passing 
+! the code through to the compiler.  These characters can 
+! occasionally get introduced with physics routines when variable 
+! names or units use special characters (superscripts, squared 
+! terms, hats, etc), or when short- or long-dashes are used in 
+! citing references.  Again, these sources are typical of 
+! information that could be provided in a comment without 
+! impacting the code to be built.
+
+! How to build the finder program: 
+! gfortran -ffree-form non_ascii_finder.F
+
+! usage:
+! ./a.out -v|-V file.F
+
+! Typically, the program is run twice.  
+
+! 1) The program is run the first time with the verbose flag 
+! (mandatory) set to "-v".  Output only occurs when the input file 
+! contains at least one offending character.  In this case, the 
+! output is the file name containing the offending character.
+
+! 2) Once the list of problematic files is assembled, the program 
+! is re-run with verbose flag set to "-V".  For each file processed, 
+! the program outputs the line of source code that contains the 
+! offending character(s), and also output the line number (to help
+! the user find the string).
+
+! Here is an example of the two step usage before all of the offending
+! characters were removed.  From the top WRF directory:
+
+! 
+! find . -name \*.F -exec tools/a.out -v {} \; 
+
+! 
+! ./chem/module_cam_mam_newnuc.F
+! ./chem/module_gocart_dmsemis.F
+! ./chem/module_gocart_seasalt.F
+! ./chem/module_mozcart_wetscav.F
+! ./chem/module_sea_salt_emis.F
+! ./dyn_em/module_sfs_driver.F
+! ./dyn_em/module_sfs_nba.F
+! ./frame/module_cpl.F
+! ./hydro/Routing/module_gw_gw2d.F
+! ./phys/module_bl_mfshconvpbl.F
+! ./phys/module_gocart_seasalt.F
+! ./phys/module_ltng_cpmpr92z.F
+! ./phys/module_ltng_crmpr92.F
+! ./phys/module_ltng_iccg.F
+! ./phys/module_mp_nssl_2mom.F
+! ./phys/module_mp_wdm6.F
+! ./phys/module_sf_bem.F
+! ./phys/module_sf_bep.F
+! ./phys/module_sf_bep_bem.F
+! ./tools/non_ascii_finder.F
+! ./var/convertor/wave2grid_kma/pvchkdv.F
+
+! The manufactured list of files (shown above) can be processed
+! individually, now with the "-V" flag:
+
+! 
+! tools/a.out -V ./tools/non_ascii_finder.F
+
+! 
+! ./non_ascii_finder.F
+! Found something on line #          25
+! !   --> this line has a problem with the superscript numeral 2: [W/m^2]
+! Character #           69  is a ?, which is character code          194
+! ./non_ascii_finder.F
+! Found something on line #          25
+! !   --> this line has a problem with the superscript numeral 2: [W/m^2]
+! Character #           70  is a ?, which is character code          178
+! Troubles, with            2  lines.
+! File uses character codes outside the standard ASCII range of           32  to          127
+
+! As a test, running the executable on this file will locate that
+!   --> this line has a problem with the superscript numeral 2: [W/m²]
+
+PROGRAM non_ascii_finder
+
+   IMPLICIT NONE
+
+   INTEGER , PARAMETER :: MAX_LENGTH  = 256
+   INTEGER , PARAMETER :: FIRST_VALID =  32
+   INTEGER , PARAMETER :: LAST_VALID  = 127
+   INTEGER , PARAMETER :: TAB         =   9
+   INTEGER , PARAMETER :: input_unit  =  10
+
+   !  Information from a single line of the input file.
+
+   CHARACTER (len=MAX_LENGTH) :: input_string
+   CHARACTER (LEN=1  ) :: test_variable
+
+   !  The name of the input file (the file that will be
+   !  opened and read).
+
+   CHARACTER (LEN=MAX_LENGTH) :: filename
+   INTEGER :: filename_length
+
+   INTEGER :: num_args
+
+   CHARACTER (LEN=MAX_LENGTH) :: verbose_arg
+   INTEGER :: arg_len
+   INTEGER :: verbose  ! from input -v  0=typical for "find" output, just a filename when there are troubles
+                       ! from input -V  1=typical for single file searching, specifically: what lines need fixing
+                       ! from input -VV 2=typical for debugging this program
+
+   INTEGER :: status
+   INTEGER :: ind
+   INTEGER :: line_count, problem_line_count
+
+   !  Get the command line info.
+
+   num_args = COMMAND_ARGUMENT_COUNT()
+
+   !  Do we have enough arguments, we want two.
+
+   IF ( num_args .NE. 2 ) THEN
+      PRINT *,'Usage:'
+      PRINT *,'./a.out  '
+      PRINT *,'where  is either -v or -V'
+      PRINT *,'      -v: outputs the filename only iff offending characters were found'
+      PRINT *,'      -V: outputs the line(s) containing the offending characters'
+      PRINT *,'where  is a Fortran source file'
+      PRINT *,' '
+      PRINT *,'For more information, please read the comments at the top of '
+      PRINT *,"this program's source code: tools/non_ascii_finder.F"
+      STOP 1
+   END IF
+
+   CALL GET_COMMAND_ARGUMENT ( NUMBER=1, VALUE=verbose_arg, LENGTH=arg_len, STATUS=status )
+
+   IF ( status .NE. 0 ) THEN
+      PRINT *,'The verbose switch is either "-v" or "-V"'
+      STOP 2
+   END IF
+
+   IF      ( verbose_arg(1:3) .EQ. "-VV" ) THEN
+      verbose = 2      
+   ELSE IF ( verbose_arg(1:2) .EQ. "-v"  ) THEN
+      verbose = 0      
+   ELSE IF ( verbose_arg(1:2) .EQ. "-V"  ) THEN
+      verbose = 1      
+   ELSE
+      PRINT *,'The verbose switch is either "-v" or "-V"'
+      PRINT *,'Entered: ',verbose_arg(1:arg_len)
+      STOP 3
+   END IF 
+
+   CALL GET_COMMAND_ARGUMENT ( NUMBER=2, VALUE=filename, LENGTH=filename_length, STATUS=status )
+
+   IF ( status .EQ. 0 ) THEN
+      OPEN ( UNIT     = input_unit     , &
+             FILE     = TRIM(filename) , & 
+             ACCESS   = 'SEQUENTIAL'   , &
+             ACTION   = 'READ'         , &
+             FORM     = 'FORMATTED'    , &
+             POSITION = 'ASIS'         , &
+             STATUS   = 'OLD'          , &
+             IOSTAT   = status           )
+   END IF
+
+   IF ( status .NE. 0 ) THEN
+      PRINT *,'Hmmm, troubles trying to open ',TRIM(filename),' for READ.'
+      STOP 4
+   END IF
+
+   !  Initializations
+
+   line_count = 1
+   problem_line_count = 0
+
+   !  Loop over each line of the input file.
+
+   big_read_loop : DO 
+
+      DO ind = 1 , MAX_LENGTH
+         input_string(ind:ind) = ' '
+      END DO      
+      READ (input_unit,FMT='(A)',IOSTAT=status) input_string
+
+      IF ( status < 0 ) THEN
+         IF ( verbose .EQ. 2 ) THEN
+            PRINT *,TRIM(filename),', End of file after attempting to read line #',line_count
+         END IF
+         EXIT big_read_loop
+      END IF
+
+      DO ind = 1 , MAX_LENGTH
+         IF ( ( ( ICHAR(input_string(ind:ind)) .LT. FIRST_VALID ) .OR. &
+                ( ICHAR(input_string(ind:ind)) .GT. LAST_VALID  ) ) .AND. &
+                ( ICHAR(input_string(ind:ind)) .NE. TAB         ) ) THEN
+            problem_line_count = problem_line_count + 1
+            IF ( verbose .EQ. 0 ) THEN
+            ELSE 
+               PRINT *,TRIM(filename)
+               PRINT *,'Found something on line #',line_count
+               PRINT *,TRIM(input_string)
+               PRINT *,'Character # ',ind,' is a ',input_string(ind:ind),', which is character code ',ICHAR(input_string(ind:ind))
+            END IF
+         END IF
+      END DO
+
+      line_count = line_count + 1 
+
+   END DO big_read_loop
+
+   !  What actually happened for this file, let us find out.
+
+   IF      ( problem_line_count .EQ. 0 ) THEN
+      IF ( verbose .EQ. 2 ) THEN
+         PRINT *,'OK, File uses only ASCII character codes from ',FIRST_VALID,' through',LAST_VALID
+      END IF
+   ELSE IF ( verbose .EQ. 1 ) THEN
+      PRINT *,'Troubles, with ',problem_line_count,' lines.'
+      PRINT *,'File uses character codes outside the standard ASCII range of ',FIRST_VALID,' to ',LAST_VALID
+   ELSE IF ( verbose .EQ. 0 ) THEN
+      PRINT *,TRIM(filename) ! , problem_line_count
+   END IF
+
+END PROGRAM non_ascii_finder
diff --git a/wrfv2_fire/tools/protos.h b/wrfv2_fire/tools/protos.h
index 976bdfea..234920f2 100644
--- a/wrfv2_fire/tools/protos.h
+++ b/wrfv2_fire/tools/protos.h
@@ -67,7 +67,7 @@ char * get_typename_i(int i) ;
 
 int gen_alloc ( char * dirname ) ;
 int gen_alloc1 ( char * dirname ) ;
-int gen_alloc2 ( FILE * fp , char * structname , node_t * node, int *j, int *iguy, int *fraction, int numguys, int frac, int sw );
+int gen_alloc2 ( FILE * fp , char * structname , char * structname2 , node_t * node, int *j, int *iguy, int *fraction, int numguys, int frac, int sw );
 
 int gen_module_state_description ( char * dirname ) ;
 int gen_module_state_description1 ( FILE * fp , node_t * node ) ;
diff --git a/wrfv2_fire/tools/test_nml_domains.csh b/wrfv2_fire/tools/test_nml_domains.csh
new file mode 100755
index 00000000..112c2646
--- /dev/null
+++ b/wrfv2_fire/tools/test_nml_domains.csh
@@ -0,0 +1,159 @@
+#!/bin/csh
+
+unalias cp rm 
+
+#	This script needs know where the Registry directory is
+#	located and also namelist.input file to review.
+
+#	No arguments, maybe this is a simple default location.
+#	Make a few educated guesses
+
+set OK = 1
+if (${#argv} == 0 ) then
+
+	#	Is this the WRFV3/run directory
+	
+	if      ( ( -d ../Registry ) && ( -f namelist.input ) ) then
+		set Reg_Dir = ../Registry
+		set NML_File = namelist.input 
+		set OK = 0
+	
+	#	Is this the WRFV3/test/em_* directory
+	
+	else if ( ( -d ../../Registry ) && ( -f namelist.input ) ) then
+		set Reg_Dir = ../../Registry
+		set NML_File = namelist.input 
+		set OK = 0
+
+	endif
+endif
+
+if ( $OK != 0 ) then
+	if (${#argv} != 2) then
+		echo "usage: $0 Full_path/Registry Full_path/namelist.input"
+		exit ( 1 )
+	else
+		set Reg_Dir = $argv[1]
+		set NML_File = $argv[2]
+	endif
+endif
+
+#	Check that the input arguments are OK: Registry
+
+if ( -d $Reg_Dir ) then
+	if ( -e ${Reg_Dir}/Registry.EM_COMMON ) then
+		#	noop
+	else
+		echo Cannot find the expected Registry files in the $Reg_Dir directory
+		exit ( 3 )
+	endif
+else
+	echo $Reg_Dir is not a valid directory
+	exit ( 2 )
+endif
+
+#	Check that the input arguments are OK: namelist.input
+
+if ( -e $NML_File ) then
+	grep -iq time_control $NML_File
+	set OK_time_control = $status
+	grep -iq domains      $NML_File
+	set OK_domains      = $status
+	grep -iq physics      $NML_File
+	set OK_physics      = $status
+	grep -iq dynamics     $NML_File
+	set OK_dynamics     = $status
+	if ( ( $OK_time_control == 0 ) && \
+	     ( $OK_domains      == 0 ) && \
+	     ( $OK_physics      == 0 ) && \
+	     ( $OK_dynamics     == 0 ) )then
+	else
+		echo "The supplied namelist.input file does not seem to have the necessary NML records"
+		exit ( 5 )
+	endif
+else
+	echo "Cannot find the namelist.input file specified: $NML_File"
+	exit ( 4 )
+endif
+
+#	Get a list of all possible variables in the Registry directory
+#	that have max_domains, and all variables that have only a single
+#	domain of info
+
+if ( -e list_of_all_max_dom_vars ) then
+	rm -rf list_of_all_max_dom_vars
+endif
+touch list_of_all_max_dom_vars
+
+if ( -e list_of_all_one_dom_vars ) then
+	rm -rf list_of_all_one_dom_vars
+endif
+touch list_of_all_one_dom_vars
+
+foreach f ( $Reg_Dir/Registry.* $Reg_Dir/registry.* )
+	grep -i ^rconfig $f | grep -i  max_domains | awk '{print $3}' >> list_of_all_max_dom_vars
+	grep -i ^rconfig $f | grep -vi max_        | awk '{print $3}' >> list_of_all_one_dom_vars
+end
+
+#	Pick up the KNOWN namelist variable max_dom
+
+foreach f ( $Reg_Dir/Registry.* $Reg_Dir/registry.* )
+	grep -i ^rconfig $f | grep -iw max_dom     | awk '{print $3}' >> list_of_all_one_dom_vars
+end
+
+sort -u list_of_all_max_dom_vars > list_of_all_max_dom_vars_sorted
+sort -u list_of_all_one_dom_vars > list_of_all_one_dom_vars_sorted
+
+#	Check the namelist, record by record. Ignore commented out portions,
+#	and ignore parts outside of the first "/" namelist record closing character.
+
+sed -e 's/\!.*//' $NML_File > .nml_no_comments
+awk '/&/,/\//' .nml_no_comments > .nml_no_comments-within_record_marks
+grep "=" .nml_no_comments-within_record_marks > .nml_no_comments-within_record_marks-has_equals
+sed -e 's/=/ /' .nml_no_comments-within_record_marks-has_equals > .nml_no_comments-within_record_marks-has_equals-no_equals
+sed -e 's/,/ /g' .nml_no_comments-within_record_marks-has_equals-no_equals > .nml_no_comments-within_record_marks-has_equals-no_equals-no_commas
+grep -v '\&' .nml_no_comments-within_record_marks-has_equals-no_equals-no_commas | grep -v '\/' > .nml_no_comments-within_record_marks-has_equals-no_equals-no_commas-no_record_marks
+awk '{print $1     }' .nml_no_comments-within_record_marks-has_equals-no_equals-no_commas-no_record_marks > .var_list_only
+awk '{print $1 , NF}' .nml_no_comments-within_record_marks-has_equals-no_equals-no_commas-no_record_marks > .var_list_num_fields
+
+#	How many domains are we trying to use
+
+grep -iwq max_dom .nml_no_comments-within_record_marks-has_equals-no_equals-no_commas-no_record_marks
+set OK = $status
+if ( $OK != 0 ) then
+	echo "The number of domains needs to be specified in the namelist.input file: max_dom"
+	exit ( 6 )
+else
+	set max_dom = `grep -iw max_dom .nml_no_comments-within_record_marks-has_equals-no_equals-no_commas-no_record_marks | awk '{print $2}'`
+endif
+
+foreach v ( `cat .var_list_only` )
+	set num_fields = `grep -iw $v .var_list_num_fields | awk '{print $2}'`
+
+	#	Is this a single variable, or does the var have an entry for each domain
+
+	grep -iwq $v list_of_all_one_dom_vars_sorted
+	set OK1 = $status
+	grep -iwq $v list_of_all_max_dom_vars_sorted
+	set OK2 = $status
+
+	if ( $OK1 == 0 ) then
+		if ( $num_fields > 2 ) then
+			echo "The $v variable should have only one entry: FATAL"
+		endif
+	else if ( $OK2 == 0 ) then
+                if ( `expr $num_fields - 1` < $max_dom ) then
+                        echo "The $v variable should have entries for each domain: BE CAREFUL"
+                endif 
+	else if ( ( $OK1 != 0 ) && ( $OK2 != 0 ) ) then
+		echo "The $v variable is not in any Registry: Problem if you just modified $v in the namelist.input file"
+	endif
+end
+
+#	Whack the temporary files.
+
+set dummy_files = ( .nml_no_comments .nml_no_comments-within_record_marks .nml_no_comments-within_record_marks-has_equals .nml_no_comments-within_record_marks-has_equals-no_equals .nml_no_comments-within_record_marks-has_equals-no_equals-no_commas .nml_no_comments-within_record_marks-has_equals-no_equals-no_commas-no_record_marks .var_list_num_fields .var_list_only .var_list list_of_all_max_dom_vars list_of_all_max_dom_vars_sorted list_of_all_one_dom_vars list_of_all_one_dom_vars_sorted )
+
+foreach f ( $dummy_files ) 
+	rm -rf $f
+end
diff --git a/wrfv2_fire/tools/update_fork.pl b/wrfv2_fire/tools/update_fork.pl
new file mode 100755
index 00000000..1970a0e6
--- /dev/null
+++ b/wrfv2_fire/tools/update_fork.pl
@@ -0,0 +1,71 @@
+#!/usr/bin/perl -w
+
+# Script for easily updating your fork of the main WRF repository
+#
+# Author: Michael Kavulich, September 2016
+# No rights reserved, this script may be used, copied, or modified for any purpose
+#
+# Instructions:
+# 1. Clone your fork of the repository (if you already have a local clone of your fork this is optional)
+#      git clone https://your_username@github.com/your_username/WRF.git
+# 2. Enter the directory of the local clone of your fork
+#      cd WRF
+# 3. Run this script from within the directory structure of your local clone of your fork
+#      ./update_fork.pl
+#    You will be asked to enter your Github username: enter it and hit "return".
+# 4. If all went well, you should see one of two different messages at the end:
+#    - If your fork is already up-to-date, you should see "Already up-to-date."
+#    - If your fork is not up-to-date, this script initiates a fast-forward merge to bring your fork up-to-date with the
+#      master of the main repository (https://github.com/wrf-model/WRF). Near the end git will print a line of statistics
+#      describing what changed, which will look something like this:
+#         19 files changed, 27 insertions(+), 27 deletions(-)
+#      followed by a few more lines and this final message:
+#         Branch master set up to track remote branch master from origin.
+
+# Notes:
+# - This is a preliminary version of what will hopefully be a more detailed script in the future. This one only performs fast-forward merges.
+
+use strict;
+
+my $username;
+my $go_on = "";
+
+# First off: check if we are on master, and quit if we are not. We want the branch switch to be transparent to users
+my $curr_branch = `git rev-parse --abbrev-ref HEAD`;
+chomp $curr_branch;
+die "\nERROR ERROR ERROR:\nYou are currently on the branch $curr_branch\n\nThis script must be run from the master branch.\n\nCheck out the master branch, then run this script, then check out your working branch $curr_branch when the update is finished\n\n" unless $curr_branch eq "master";
+
+
+# Prompt user for their username
+print "Please enter your Github username:\n";
+   while ($go_on eq "") {
+      $go_on = ;
+      chop($go_on);
+      if ($go_on eq "") {
+         print "Please enter your Github username:\n";
+      } else {
+         $username = $go_on;
+      }
+   }
+
+print "Username = $username\n";
+my $main_repo = "https://$username\@github.com/wrf-model/WRF.git";
+my $fork = "https://$username\@github.com/$username/WRF.git";
+
+# Set main repository as a remote repository named "upstream", per standard git conventions
+print "\nStep 1: Setting main repository as a remote repository named 'upstream'\n\n";
+! system("git", "remote", "rm", "upstream") or warn "If you see \"error: Could not remove config section 'remote.upstream'\" this is normal! Don't panic!\n";
+! system("git", "remote", "add", "upstream", $main_repo) or die "Can not add main repository '$main_repo' for merging: $!\n";
+
+# Set the "push" url for "upstream" to be the user's fork, to avoid accidentally pushing to the main repository
+print "\nStep 2: Setting the 'push' url for 'upstream' to the user's fork, to avoid accidentally pushing to the main repository\n\n";
+! system("git", "remote", "set-url", "--push", "upstream", $fork) or die "Can not add set push repository '$fork': $!\n";
+
+# Checkout master, fetch "upstream" commits, and perform a fastforward merge
+print "\nStep 3: Fetching 'upstream' commits, and performing fastforward merge\n\n";
+! system("git", "fetch", "upstream", "master") or die "Can not fetch upstream changes from : $!\nSomething has gone seriously wrong! Perhaps you don't have internet access?\n";
+! system("git", "merge", "--ff-only", "upstream/master") or die "\nCan not perform fastforward merge from upstream/master: $!\n\nTroubleshooting info:\n\n 1. If you receive a message 'fatal: 'upstream/master' does not point to a commit', your git version may be too old. On yellowstone, try `module load git`\n 2. If you receive a message' fatal: Not possible to fast-forward, aborting.', you have likely made local changes to the master branch of your fork. All work should be done on branches of your fork, not the master!\n";
+
+# Finally, push updated master to the Github copy of your fork:
+print "\nStep 4: Pushing updated master to fork\n\n";
+! system("git", "push", "-u", "origin", "master") or die "\nCan not push updates to origin/master : $!\n";

From b8c9db649349393a7feb1b73a658aee8ad8ba404 Mon Sep 17 00:00:00 2001
From: "Theodore M. Giannaros" <37264065+tmgiannaros@users.noreply.github.com>
Date: Mon, 12 Mar 2018 01:27:16 +0200
Subject: [PATCH 05/15] Update registry.fire to comply with SFIRE

---
 wrfv2_fire/Registry/registry.fire | 171 +++++++++++++++++++++++-------
 1 file changed, 130 insertions(+), 41 deletions(-)

diff --git a/wrfv2_fire/Registry/registry.fire b/wrfv2_fire/Registry/registry.fire
index a092b7bf..e9461d98 100644
--- a/wrfv2_fire/Registry/registry.fire
+++ b/wrfv2_fire/Registry/registry.fire
@@ -1,37 +1,35 @@
 #
 # ----------------------------------------
-#  begin fire variables and configuration
+#  SFIRE variables and configuration
 # ----------------------------------------
 #
-# declare fire package and choose which fire scheme
+# Fire package definition and selection 
 #
 #   
 #         name>          namelist choice>          state vars>
 # 
-package   fire_sfire    ifire==2                    -             state:nfuel_cat,zsf,tign_g,rthfrten,rqvfrten,grnhfx,grnqfx,canhfx,canqfx,lfn,fuel_frac,fire_area,uf,vf,fgrnhfx,fgrnqfx,fcanhfx,fcanhfx,fcanqfx,ros,fxlong,fxlat,fuel_time,bbb,betafl,phiwc,r_0,fgip,ischap,lfn_hist,lfn_time,avg_fuel_frac,uah,vah
+package   fire_sfire    ifire==2                    -             state:nfuel_cat,zsf,tign_g,rthfrten,rqvfrten,grnhfx,grnqfx,canhfx,canqfx,lfn,lfn_out,fuel_frac,fire_area,uf,vf,fgrnhfx,fgrnqfx,fcanhfx,fcanhfx,fcanqfx,ros,fxlong,fxlat,fuel_time,bbb,phiwc,phisc,r_0,fgip,ischap,fz0,fwh,unit_fxlong,unit_fxlat,ndwi,ndvi,fmc_g,fmc_gc,fndwi
 
-# level function history support
-dimspec   ign   2           constant=1      z    i_lfn_history
-state     real  lfn_hist    *i{ign}*j   fire   1    Z   i012hr     "LFN_HIST"    "level function history" "1"
-state     real  lfn_time    {ign}       fire   1    -   i012hr     "LFN_TIME"    "level function history time" "s"
-
-
-# fire variables on fire grid
+# SFIRE input variables on fire grid
 #
 #
-state real nfuel_cat *i*j fire 1 z i012hr "NFUEL_CAT" "fuel data" +state real nfuel_cat *i*j fire 1 z i012hr "NFUEL_CAT" "fuel data" state real zsf *i*j fire 1 z i012hr "ZSF" "height of surface above sea level" "m" state real dzdxf *i*j fire 1 z i012hr "DZDXF" "surface gradient x" "1" state real dzdyf *i*j fire 1 z i012hr "DZDYF" "surface gradient y" "1" -state real tign_g *i*j fire 1 z hr "TIGN_G" "ignition time on ground" "s" +state real fire_hfx *i*j fire 1 z i012hr "FIRE_HFX" "observed fire heat flux" "W/m^2" -# fire variables on atm grid +# SFIRE input variables on atmospheric grid +# +# Satellite remote sensing derived variables +state real ndwi ij fire 1 z i012hr "NDWI" "Normalized Difference Water Index" "1" +state real ndvi ij fire 1 z i012hr "NDVI" "Normalized Difference Vegetation Index" "1" # -# outputs to atm model +# SFIRE output tendencies to atmospheric grid (temperature & humidity) state real rthfrten ikj fire 1 z hr "RTHFRTEN" "temperature tendency" "K/s" state real rqvfrten ikj fire 1 z hr "RQVFRTEN" "humidity tendency" -# diagnostics only +# Diagnostics and preserved intermediate variables state real avg_fuel_frac ij fire 1 z hr "AVG_FUEL_FRAC" "fuel remaining averaged to atmospheric grid" "1" state real grnhfx ij fire 1 z hr "GRNHFX" "heat flux from ground fire" "W/m^2" state real grnqfx ij fire 1 z hr "GRNQFX" "moisture flux from ground fire" "W/m^2" @@ -40,39 +38,100 @@ state real canqfx ij fire 1 z hr "CANQFX" state real uah ij fire 1 X hr "UAH" "wind at fire_wind_height" "m/s" state real vah ij fire 1 Y hr "VAH" "wind at fire_wind_height" "m/s" -# sfire variables on fire grid -# (also using tign_g,zs,z_at_w,dz8w,nfuel_cat,fluxes,zsf) +# SFIRE variables on fire grid +# (also using inputs: zs,z_at_w,dz8w,nfuel_cat,zsf) # -state real lfn *i*j fire 1 z hr "LFN" "level function" "1" -state real fuel_frac *i*j fire 1 z hr "FUEL_FRAC" "fuel remaining" "1" +state real tign_g *i*j fire 1 z i102hr "TIGN_G" "ignition time on ground" "s" +state real tign_in *i*j fire 1 z hr "TIGN_IN" "minimal ignition time on ground" "s" +state real lfn *i*j fire 1 z i102hr "LFN" "level function" "1" +state real lfn_out *i*j fire 1 z r "LFN_OUT" "level function at time step end, for halo" "1" +state real fuel_frac *i*j fire 1 z i102hr "FUEL_FRAC" "fuel remaining" "1" +state real fmc_g *i*j fire 1 z i102hr "FMC_G" "fuel moisture contents" "1" state real fire_area *i*j fire 1 z hr "FIRE_AREA" "fraction of cell area on fire" "1" +state real fuel_frac_burnt *i*j fire 1 z hr "FUEL_FRAC_BURNT" "fraction of fuel burnt in timestep" "1" state real uf *i*j fire 1 z hr "UF" "fire wind" "m/s" state real vf *i*j fire 1 z hr "VF" "fire wind" "m/s" state real fgrnhfx *i*j fire 1 z hr "FGRNHFX" "heat flux from ground fire" "W/m^2" state real fgrnqfx *i*j fire 1 z hr "FGRNQFX" "moisture flux from ground fire" "W/m^2" state real fcanhfx *i*j fire 1 z hr "FCANHFX" "heat flux from crown fire" "W/m^2" state real fcanqfx *i*j fire 1 z hr "FCANQFX" "moisture flux from crown fire" "W/m^2" -state real ros *i*j fire 1 z hr "ROS" "rate of spread" "m/s" +state real fndwi *i*j fire 1 z i102hr "FNDWI" "Normalized Difference Water Index on fire grid" "1" + +# Fuel moisture model variables and configuration +dimspec num_fmc - namelist=nfmc z fuel_moisture_classes +dimspec num_fmep - constant=2 z fuel_moisture_extended_parameters +rconfig integer nfmc namelist,fire 1 5 - "nfmc" "number of fuel moisture classes" +state real fmc_gc i{num_fmc}j fire 1 z ihr "FMC_GC" "fuel moisture contents by class" "1" +state real fmep i{num_fmep}j fire 1 z ihr "FMEP" "fuel moisture extended model parameters" "1" +state real fmc_equi i{num_fmc}j fire 1 z hr "FMC_EQUI" "fuel moisture contents by class equilibrium (diagnostics only)" "1" +state real fmc_lag i{num_fmc}j fire 1 z hr "FMC_TEND" "fuel moisture contents by class time lag (diagnostics only)" "h" +state real rain_old ij fire 1 z hr "RAIN_OLD" "previous value of accumulated rain" "mm" +state real t2_old ij fire 1 z hr "T2_OLD" "previous value of air temperature at 2m" "K" +state real q2_old ij fire 1 z hr "Q2_OLD" "previous value of 2m specific humidity" "kg/kg" +state real psfc_old ij fire 1 z hr "PSFC_OLD" "previous value of surface pressure" "Pa" +state real rh_fire ij fire 1 z hr "RH_FIRE" "relative humidity at the surface" "1" +state real fmoist_lasttime - fire - - hr "FMOIST_LASTTIME" "last time the moisture model was run" "s" +state real fmoist_nexttime - fire - - hr "FMOIST_NEXTTIME" "next time the moisture model will run" "s" +rconfig logical fmoist_run namelist,fire max_domains .false. hr "run moisture model (on the atmospheric grid), output to fmc_gc" +rconfig logical fmoist_interp namelist,fire max_domains .false. hr "interpolate moisture from the model or the input to fuels on the fire grid" +rconfig logical fmoist_only namelist,fire max_domains .false. hr "only run moisture model, skip fire" +rconfig integer fmoist_freq namelist,fire max_domains 0 hr "fmoist_freq" "frequency to run moisture model 0: use fmoist_dt, k>0: every k timesteps" "1" +rconfig integer kfmc_ndwi namelist,fire 1 0 hr "KFMC_NDWI" number of moisture class to update from NDWI, or zero" +rconfig integer fndwi_from_ndwi namelist,fire 1 1 hr "FNDWI_FROM_NDWI" "number of moisture class to update from NDWI, or zero" +rconfig real fmoist_dt namelist,fire max_domains 600 hr "fmoist_dt " "moisture model time step" "s" +rconfig real fmep_decay_tlag namelist,fire 1 0.01 hr "fmep_decay_tlag" "time constant of assimilated adjustments of equilibria decay" "1" + +# Halos for fuel moisture model +halo HALO_FIRE_MFG dyn_em 24:fmc_g +halo HALO_FIRE_MAG dyn_em 8:fmc_gc +halo HALO_FIRE_NDWI dyn_em 8:ndwi -# constant data arrays -state real fxlong *i*j fire 1 z ihr "FXLONG" "longitude of midpoints of fire cells" "degrees" -state real fxlat *i*j fire 1 z ihr "FXLAT" "latitude of midpoints of fire cells" "degrees" +# Diagnostics +# For the simulated fire +state real ros *i*j fire 1 z hr "ROS" "rate of spread in the normal direction to the fireline" "m/s" +state real flineint *i*j fire 1 z hr "FLINEINT" "fireline intensity" "W/m" +state real flineint2 *i*j fire 1 z hr "FLINEINT2" "alternative fireline intensity" "J/m/s^2" +# For fire risk rating - independent on any simulated fire +state real f_ros0 *i*j fire 1 z hr "F_ROS0" "base rate of spread in all directions" "m/s" +state real f_rosx *i*j fire 1 z hr "F_ROSX" "X component of the spread vector driven by wind and slope" "m/s" +state real f_rosy *i*j fire 1 z hr "F_ROSY" "Y component of the spread vector driven by wind and slope" "m/s" +state real f_ros *i*j fire 1 z hr "F_ROS" "max spread rate in any direction" "m/s" +state real f_int *i*j fire 1 z hr "F_INT" "fire reaction intensity for risk rating, without fire" "J/m^2/s" +state real f_lineint *i*j fire 1 z hr "F_LINEINT" "Byram fireline intensity for risk rating, without fire" "J/m/s" +state real f_lineint2 *i*j fire 1 z hr "F_LINEINT2" "alternative fireline intensity for risk rating, without fire" "J/m/s^2" +state real f_ros11 *i*j fire 1 z hr "F_ROS11" "rate of spread in the direction to node (i-2)+1,(j-2)+1" "m/s" +state real f_ros12 *i*j fire 1 z hr "F_ROS12" "rate of spread in the direction to node (i-2)+1,(j-2)+2" "m/s" +state real f_ros13 *i*j fire 1 z hr "F_ROS13" "rate of spread in the direction to node (i-2)+1,(j-2)+3" "m/s" +state real f_ros21 *i*j fire 1 z hr "F_ROS21" "rate of spread in the direction to node (i-2)+2,(j-2)+1" "m/s" +state real f_ros23 *i*j fire 1 z hr "F_ROS23" "rate of spread in the direction to node (i-2)+2,(j-2)+3" "m/s" +state real f_ros31 *i*j fire 1 z hr "F_ROS31" "rate of spread in the direction to node (i-2)+3,(j-2)+1" "m/s" +state real f_ros32 *i*j fire 1 z hr "F_ROS32" "rate of spread in the direction to node (i-2)+3,(j-2)+2" "m/s" +state real f_ros33 *i*j fire 1 z hr "F_ROS33" "rate of spread in the direction to node (i-2)+3,(j-2)+3" "m/s" + +# Constant data arrays +state real fxlong *i*j fire 1 z i012hr "FXLONG" "longitude of midpoints of fire cells, or grid coordinate in ideal" "degrees" +state real fxlat *i*j fire 1 z i012hr "FXLAT" "latitude of midpoints of fire cells, or grid coordinate in ideal" "degrees" +state real unit_fxlong - - - - hr "UNIT_FXLONG" "length of 1 unit in fxlong" "m" +state real unit_fxlat - - - - hr "UNIT_FXLAT" "length of 1 unit in fxlat" "m" state real fuel_time *i*j fire 1 z hr "FUEL_TIME" "fuel" state real bbb *i*j fire 1 z hr "BBB" "fuel" -state real betafl *i*j fire 1 z hr "BETAFL" "fuel" +state real phisc *i*j fire 1 z hr "PHISC" "fuel" state real phiwc *i*j fire 1 z hr "PHIWC" "fuel" state real r_0 *i*j fire 1 z hr "R_0" "fuel" state real fgip *i*j fire 1 z hr "FGIP" "fuel" +state real fz0 *i*j fire 1 z hr "FZ0" "fuel roughness height" +state real fwh *i*j fire 1 z hr "FWH" "fuel fire wind height" state real ischap *i*j fire 1 z hr "ISCHAP" "fuel" # -# fire configure namelist variables +# SFIRE configuration (namelist parameters) # #
rconfig integer ifire namelist,fire max_domains 0 rconfig integer fire_boundary_guard namelist,fire max_domains 2 - "fire_boundary_guard" "cells to stop when fire close to domain boundary" -# ignition for sfire -rconfig integer fire_num_ignitions namelist,fire max_domains 0 - "fire_num_ignitions" "number of ignition lines" +# Fire ignition parameters +rconfig integer fire_num_ignitions namelist,fire max_domains 0 - "fire_num_ignitions" "number of ignition lines" +rconfig integer fire_ignition_clamp namelist,fire max_domains 0 - "fire_ignition_clamp" "1 = clamp ignition to grid"" rconfig real fire_ignition_ros1 namelist,fire max_domains 0.01 - "fire_ignition_ros1" "rate of spread during ignition" "m/s" rconfig real fire_ignition_start_lon1 namelist,fire max_domains 0. - "fire_ignition_start_long1" "long coord of start of ignition line" "deg" rconfig real fire_ignition_start_lat1 namelist,fire max_domains 0. - "fire_ignition_start_lat1" "lat coord of start of ignition line" "deg" @@ -133,7 +192,9 @@ rconfig real fire_ignition_start_x5 namelist,fire max_domains rconfig real fire_ignition_start_y5 namelist,fire max_domains 0. - "fire_ignition_start_y5" "y coord of start of ignition line" "m" rconfig real fire_ignition_end_x5 namelist,fire max_domains 0. - "fire_ignition_end_x5" "x coord of end of ignition line" "m" rconfig real fire_ignition_end_y5 namelist,fire max_domains 0. - "fire_ignition_end_y5" "y coord of end of ignition line" "m" -# variables from old cawfe code +rconfig real fire_perimeter_time namelist,fire max_domains 0. - "fire_perimeter_time" "if >0, replay history from tign_g array until this time" "s" +rconfig real fire_tign_in_time namelist,fire max_domains 0. - "fire_tign_in_time" "if >0, ignite from given tign array until this time" "s" +# Variables from old CAWFE code rconfig real fire_lat_init namelist,fire max_domains 0. - "fire_lat_init" "latitude to start fire" "degrees" rconfig real fire_lon_init namelist,fire max_domains 0. - "fire_lon_init" "longitude to start fire" "degrees" rconfig real fire_ign_time namelist,fire max_domains 0. - "fire_ign_time" "time when fire should be ignited" "min" @@ -142,31 +203,58 @@ rconfig integer fire_sprd_mdl namelist,fire max_domains rconfig real fire_crwn_hgt namelist,fire max_domains 15. - "fire_crwn_hgt" "height that heat from crown fire is released" "m" rconfig real fire_ext_grnd namelist,fire max_domains 50. - "fire_ext_grnd" "extinction depth of sfc fire heat" "m" rconfig real fire_ext_crwn namelist,fire max_domains 50. - "fire_ext_crwn" "extinction depth of crown fire heat" "m" -rconfig real fire_wind_height namelist,fire max_domains 6.096 - "fire_wind_height" "height of uah,vah wind in fire spread formula" "m" +rconfig integer fire_wind_log_interp namelist,fire max_domains 4 - "fire_wind_log_interp" "1 = fz0/fwh from fuel categores, 2=fz0 const rom z0,3=fz0 interp from z0, 4=interpolation on atm mesh and wind reduction" "" +rconfig integer fire_use_windrf namelist,fire max_domains 0 - "fire_use_windrf" "only for fire_wind_log_interp.ne.4: 0=ignore windrf, 1=multiply wind by windrf, 2=set fwh from windrf, 3=adjust fwh for z0" "" rconfig integer fire_fuel_read namelist,fire max_domains -1 - "fire_fuel_read" "fuel categories are set by: if 0, uniform; if 1, user-presc; if 2, read from file" "" +rconfig integer fire_fmc_read namelist,fire max_domains 1 - "fire_fmc_read" "fuel moisture: 0 not set use wrfinput, 1 from namelist.fire, 2 read from file in ideal" "" rconfig integer fire_fuel_cat namelist,fire max_domains 1 - "fire_fuel_cat" "fuel category if ifuelread=0" "" -# sfire switches +# SFIRE switches rconfig integer fire_print_msg namelist,fire max_domains 0 - "fire_write_msg" "write fire statistics, 0 no writes, 1+ for more" "" rconfig integer fire_print_file namelist,fire max_domains 0 - "fire_write_file" "write fire output text files, 0 no writes, 1+ for more" "" -# method selection` +rconfig logical fire_restart namelist,fire max_domains .false. - "fire_restart" "restart run, do not initialize state" "" +rconfig integer fire_time_step_ratio namelist,fire max_domains 1 - "fire_time_step_ratio" "number of fire time steps per atmospheric step" "" +rconfig integer fire_debug_hook_sec namelist,fire max_domains 0 - "fire_debug_hook_sec" "number of seconds to sleep in loop waiting fot debugger to attach" "s" + +# SFIRE method selection rconfig integer fire_fuel_left_method namelist,fire max_domains 1 - "fire_fuel_left_method" "1 or 2, compute fuel_left" "" +rconfig integer fire_update_fuel_frac namelist,fire max_domains 1 - "fire_update_fuel_frac" "1 normal, 2 burner" "" rconfig integer fire_fuel_left_irl namelist,fire max_domains 2 - "fire_fuel_left_irl" "submesh to compute fuel lwft, even, at least 2" "" rconfig integer fire_fuel_left_jrl namelist,fire max_domains 2 - "fire_fuel_left_jrl" "submesh to compute fuel lwft, even, at least 2" "" rconfig real fire_back_weight namelist,fire max_domains 0.5 - "fire_back_weight" "RK timestepping coefficient, 0=forward, 0.5=Heun" "1" rconfig integer fire_grows_only namelist,fire max_domains 1 - "fire_grows_only" "if >0 level set function cannot increase = fire can only grow" "1" rconfig integer fire_upwinding namelist,fire max_domains 3 - "fire_upwinding" "upwind normal spread: 1=standard, 2=godunov, 3=eno, 4=sethian" "1" -rconfig integer fire_upwind_split namelist,fire max_domains 0 - "fire_upwind_split" "1=upwind advection separately from normal direction spread" "1" rconfig real fire_viscosity namelist,fire max_domains 0.4 - "fire_viscosity" "artificial viscosity in level set method" "1" rconfig real fire_lfn_ext_up namelist,fire max_domains 1.0 - "fire_lfn_ext_up" "0.=extend level set function at boundary by reflection, 1.=always up" "1" rconfig integer fire_topo_from_atm namelist,fire max_domains 1 - "fire_topo_from_atm" "0 = do nothing, 1 = populate ZSF by interpolating from atmosphere" "1" rconfig integer fire_advection namelist,fire max_domains 1 - "fire_advection" "0 = fire spread computed from normal wind speed/slope, 1 = fireline particle speed projected on normal" "0" -# experiments + +# Variables and switches for experiments +# Stand-alone SFIRE model rconfig integer fire_test_steps namelist,fire max_domains 0 - "fire_test_steps" ">0 = on first call, do specified number of steps and terminate (testing only)" "1" +# stopped fire - defunct, leaving for compatibily with existing namelist.input files rconfig real fire_const_time namelist,fire max_domains -1. - "fire_const_time" "time from ignition to freeze fire, <0 never" "s" rconfig real fire_const_grnhfx namelist,fire max_domains 0. - "fire_const_grnhfx" "if both >=0, the amount of constant heat flux" "1" rconfig real fire_const_grnqfx namelist,fire max_domains 0. - "fire_const_grnqfx" "if both >=0, the amount of constant heat flux" "1" +# Input heat flux +rconfig integer fire_hfx_given namelist,fire max_domains 0 - "fire_hfx_given" "0=no, run normally, 1=from wrfinput, 2=from file input_hfx in ideal, 3=by parameters" "" +rconfig integer fire_hfx_num_lines namelist,fire max_domains 0 - "fire_hfx_num_lines" "number of heatflux parameter sets defining the heaflux lines" "" +rconfig real fire_hfx_latent_part namelist,fire max_domains 0.084 - "fire_hfx_latent_part" "proportion of the given heat flux released as latent, the rest is sensible" "1" +rconfig real fire_hfx_value1 namelist,fire max_domains 0. - "fire_hfx_value1" "heatflux values used in setting by parameters" "W/m^2" +rconfig real fire_hfx_start_time1 namelist,fire max_domains 0. - "fire_hfx_start_time1" "time from start of run when artificial heatlux begins full value" "s" +rconfig real fire_hfx_end_time1 namelist,fire max_domains 0. - "fire_hfx_end_time1" "ending time for heatflux from beginning of run" "s" +rconfig real fire_hfx_trans_time1 namelist,fire max_domains 0. - "fire_hfx_trans_time1" "transition time for heatflux from 1% to 100%" "s" +rconfig real fire_hfx_radius1 namelist,fire max_domains 0. - "fire_hfx_radius1" "radius of the heatflux circles" "m" +rconfig real fire_hfx_start_x1 namelist,fire max_domains 0. - "fire_hfx_start_x1" "point for the center of the heatflux circle" "m" +rconfig real fire_hfx_end_x1 namelist,fire max_domains 0. - "fire_hfx_end_x1" "end point for the center of the heatflux circle" "m" +rconfig real fire_hfx_start_lat1 namelist,fire max_domains 0. - "fire_hfx_start_lat1" "start point for the center of the heatflux circle" "degrees" +rconfig real fire_hfx_end_lat1 namelist,fire max_domains 0. - "fire_hfx_end_lat1" "end point for the center of the heatflux circle" "degrees" +rconfig real fire_hfx_start_y1 namelist,fire max_domains 0. - "fire_hfx_start_y1" "radius of the heatflux circle" "m" +rconfig real fire_hfx_end_y1 namelist,fire max_domains 0. - "fire_hfx_end_y1" "end point for the center of the heatflux circle" "m" +rconfig real fire_hfx_start_lon1 namelist,fire max_domains 0. - "fire_hfx_start_lon1" "start point for the center of the heatflux circle" "degrees" +rconfig real fire_hfx_end_lon1 namelist,fire max_domains 0. - "fire_hfx_end_lon1" "end point for the center of the heatflux circle" "degrees" +# rconfig real fire_atm_feedback namelist,fire max_domains 1. - "fire_atm_feedback" "the heat fluxes to the atmosphere are multiplied by this" "1" -rconfig integer fire_mountain_type namelist,fire max_domains 0 - "fire_mountain_type" "in ideal: 0=none, 1=COS hill, 2=EW ridge, 3=NS ridge" "1" +rconfig integer fire_mountain_type namelist,fire max_domains 0 - "fire_mountain_type" "in ideal: 0=none, 1=COS hill, 2=EW ridge, 3=NS ridge" "1" rconfig real fire_mountain_height namelist,fire max_domains 500. - "fire_mountain_height" "ideal mountain height" "m" rconfig real fire_mountain_start_x namelist,fire max_domains 100. - "fire_mountain_start_x" "x coord of start of the mountain" "m" rconfig real fire_mountain_start_y namelist,fire max_domains 100. - "fire_mountain_start_y" "y coord of start of the mountain" "m" @@ -177,25 +265,25 @@ rconfig real xrad_perturbation namelist,fire max_domains rconfig real yrad_perturbation namelist,fire max_domains 0. - "yrad_perturbation" "horizontal radius of the perturbation in N-S direction" "m" rconfig real zrad_perturbation namelist,fire max_domains 0. - "zrad_perturbation" "vertical radius of the perturbation (bubble) direction" "m" rconfig real hght_perturbation namelist,fire max_domains 0. - "hght_perturbation" "height at which the perturbation (bubble) will be suspended" "m" -# grid stretching +# Grid streching rconfig logical stretch_grd namelist,fire max_domains .true. - "stretch_grd" "vertical grid stretching (on/off)" "" rconfig logical stretch_hyp namelist,fire max_domains .false. - "stretch_hyp" "hyperbolic tang grid stretching (more levels at the surface)" "" rconfig real z_grd_scale namelist,fire max_domains 0.40 - "z_grd_scale" "zscale parameter for hyperbolic grid streching" "m" -# surface initialization +# Surface initialization rconfig logical sfc_full_init namelist,fire max_domains .false. - "sfc_full_init" "full surface initialization (on/off)" "" rconfig integer sfc_lu_index namelist,fire max_domains 28 - "sfc_lu_index" "USGS landuse index definig sfc record from LANDUSE.TBL" "" rconfig real sfc_tsk namelist,fire max_domains 285.0 - "sfc_tsk" "surface skin temperature (TSK)" "K" rconfig real sfc_tmn namelist,fire max_domains 285.0 - "sfc_tmn" "soil temperature at lower boundary (TMN)" "K" -# landuse data from files - overwrite constants +# Landuse data from files - overwrite constants rconfig logical fire_read_lu namelist,fire max_domains .false. - "fire_read_lu" "read land use data from file input_lu" "" rconfig logical fire_read_tsk namelist,fire max_domains .false. - "fire_read_tsk" "read file input_tsk" "" rconfig logical fire_read_tmn namelist,fire max_domains .false. - "fire_read_tmn" "read file input_tmn" "" -# topography data from files +# Topography data from files rconfig logical fire_read_atm_ht namelist,fire max_domains .false. - "fire_read_atm_ht" "read terrain height on atm mesh from file" "" rconfig logical fire_read_fire_ht namelist,fire max_domains .false. - "fire_read_fire_ht" "read terrain height on fire mesh from file" "" rconfig logical fire_read_atm_grad namelist,fire max_domains .false. - "fire_read_atm_grad" "read terrain gradient on atm mesh from file" "" rconfig logical fire_read_fire_grad namelist,fire max_domains .false. - "fire_read_fire_grad" "read terrain gradient on fire mesh from file" "" -# additional data required by Noah LSM scheme +# Additional data required by Noah LSM scheme rconfig real sfc_vegfra namelist,fire max_domains 0.5 - "sfc_vegfra" "vegetation fraction" "" rconfig real sfc_canwat namelist,fire max_domains 0 - "sfc_canwat" "canopy water" "" rconfig integer sfc_ivgtyp namelist,fire max_domains 18 - "sfc_ivgtyp" "dominant vegetation category in the LSM scheme" "" @@ -204,6 +292,7 @@ rconfig integer sfc_isltyp namelist,fire max_domains # Fire halo descriptions # halo HALO_FIRE_LFN dyn_em 24:lfn +halo HALO_FIRE_LFN_OUT dyn_em 8:lfn_out halo HALO_FIRE_TIGN dyn_em 8:tign_g halo HALO_FIRE_HT dyn_em 8:ht halo HALO_FIRE_PHB dyn_em 8:phb @@ -213,10 +302,10 @@ halo HALO_FIRE_WIND_F dyn_em 12:uf,vf halo HALO_FIRE_LONGLAT dyn_em 24:xlong,xlat halo HALO_FIRE_WIND_A dyn_em 8:u_2,v_2 halo HALO_FIRE_ZSF dyn_em 24:zsf -halo HALO_FIRE_FUEL dyn_em 8:fuel_frac,fuel_time,bbb,betafl,phiwc,r_0,fgip,ischap,nfuel_cat,dzdxf,dzdyf +halo HALO_FIRE_FUEL dyn_em 8:fuel_frac,fuel_time,bbb,phiwc,phisc,r_0,fgip,ischap,nfuel_cat,dzdxf,dzdyf,fz0,fwh # # ---------------------------------------- -# end fire variables and configuration +# End SFIRE variables and configuration # ---------------------------------------- ## From 4df522bf3ecec6d92bed0ccd74207d885c0e29a7 Mon Sep 17 00:00:00 2001 From: "Theodore M. Giannaros" <37264065+tmgiannaros@users.noreply.github.com> Date: Thu, 22 Mar 2018 21:12:25 +0200 Subject: [PATCH 06/15] Update start_em.F Modifications to allow for calling the SFIRE driver module. --- wrfv2_fire/dyn_em/start_em.F | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/wrfv2_fire/dyn_em/start_em.F b/wrfv2_fire/dyn_em/start_em.F index 848c4fb8..4d384beb 100644 --- a/wrfv2_fire/dyn_em/start_em.F +++ b/wrfv2_fire/dyn_em/start_em.F @@ -45,7 +45,9 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & USE module_llxy, ONLY : proj_cassini USE module_physics_init USE module_lightning_driver, ONLY : lightning_init - USE module_fr_fire_driver_wrf, ONLY : fire_driver_em_init + ! TMG: Replace with SFIRE module & subr + ! SFIRE: Subr for initializing the SFIRE model + USE module_fr_sfire_driver_wrf, ONLY : sfire_driver_em_init USE module_stoch, ONLY : setup_rand_perturb, rand_seed, update_stoch, initialize_stoch USE module_trajectory, ONLY : trajectory_init #if (WRF_CHEM == 1) @@ -2057,15 +2059,17 @@ SUBROUTINE start_domain_em ( grid, allowed_to_read & ENDIF -! FIRE -if(config_flags%ifire.eq.2)then +! TMG: Replace with SFIRE subr +! SFIRE: Call initialization subr +if ( config_flags%ifire.eq.2 ) then - call fire_driver_em_init ( grid , config_flags & - ,ids,ide, kds,kde, jds,jde & - ,ims,ime, kms,kme, jms,jme & - ,ips,ipe, kps,kpe, jps,jpe ) + CALL sfire_driver_em_init ( grid , config_flags & + ,ids,ide, kds,kde, jds,jde & + ,ims,ime, kms,kme, jms,jme & + ,ips,ipe, kps,kpe, jps,jpe ) + + CALL wrf_debug ( 0 , 'start_domain_em: After call to sfire_driver_em_init' ) - CALL wrf_debug ( 100 , 'start_domain_em: After call to fire_driver_em_init' ) endif if( grid%traj_opt /= no_trajectory ) then From ed214effade72737fc6b7e0013af749d871ea297 Mon Sep 17 00:00:00 2001 From: "Theodore M. Giannaros" <37264065+tmgiannaros@users.noreply.github.com> Date: Thu, 22 Mar 2018 21:27:35 +0200 Subject: [PATCH 07/15] Update module_first_rk_step_part1.F Modifications to allow for using the SFIRE model. --- wrfv2_fire/dyn_em/module_first_rk_step_part1.F | 18 ++++++------------ 1 file changed, 6 insertions(+), 12 deletions(-) diff --git a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F index 655422ac..6d187a4e 100644 --- a/wrfv2_fire/dyn_em/module_first_rk_step_part1.F +++ b/wrfv2_fire/dyn_em/module_first_rk_step_part1.F @@ -42,7 +42,9 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & USE module_cumulus_driver, ONLY : cumulus_driver USE module_shallowcu_driver, ONLY : shallowcu_driver USE module_pbl_driver, ONLY : pbl_driver - USE module_fr_fire_driver_wrf, ONLY : fire_driver_em_step + ! TMG: Replace with SFIRE module & subr + ! SFIRE: Subr for advancing the SFIRE model + USE module_fr_sfire_driver_wrf, ONLY : sfire_driver_em_step USE module_fddagd_driver, ONLY : fddagd_driver USE module_em, ONLY : init_zero_tendency USE module_force_scm @@ -1012,28 +1014,20 @@ SUBROUTINE first_rk_step_part1 ( grid , config_flags & BENCH_END(pbl_driver_tim) !***** -! fire - +! SFIRE ! Jan Mandel's call to SFIRE IF ((grid%sr_x > 0 .OR. grid%sr_y > 0) .AND. config_flags%ifire == 2) THEN BENCH_START(fire_driver_tim) if(config_flags%ifire.eq.2)then - ! initialization moved to start_em:start_domain_em -! if(grid%initestep.eq.1) & -! call fire_driver_em_init ( grid , config_flags & -! ,ids,ide, kds,kde, jds,jde & -! ,ims,ime, kms,kme, jms,jme & -! ,ips,ipe, kps,kpe, jps,jpe ) - ! one timestep of the fire model - call fire_driver_em_step ( grid , config_flags & + call sfire_driver_em_step ( grid , config_flags & ,ids,ide, kds,kde, jds,jde & ,ims,ime, kms,kme, jms,jme & ,ips,ipe, kps,kpe, jps,jpe & ,grid%rho,grid%z_at_w,dz8w) endif - + BENCH_END(fire_driver_tim) ENDIF From c7edbfb62254ad58dd4c0cfbfac6530e9873a948 Mon Sep 17 00:00:00 2001 From: "Theodore M. Giannaros" <37264065+tmgiannaros@users.noreply.github.com> Date: Thu, 22 Mar 2018 21:34:08 +0200 Subject: [PATCH 08/15] Update depend.dyn_em Modifications targeting the compilation of SFIRE (dependencies). --- wrfv2_fire/dyn_em/depend.dyn_em | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/wrfv2_fire/dyn_em/depend.dyn_em b/wrfv2_fire/dyn_em/depend.dyn_em index 03833ef9..fec8f641 100644 --- a/wrfv2_fire/dyn_em/depend.dyn_em +++ b/wrfv2_fire/dyn_em/depend.dyn_em @@ -120,7 +120,7 @@ module_initialize_fire.o : \ ../share/module_model_constants.o \ ../share/module_bc.o \ module_init_utilities.o \ - ../phys/module_fr_fire_util.o + ../phys/module_fr_sfire_util.o module_initialize_quarter_ss.o : \ ../frame/module_domain.o \ @@ -245,7 +245,7 @@ start_em.o: module_bc_em.o \ ../phys/module_physics_init.o \ ../phys/module_diag_pld.o \ ../phys/module_diag_zld.o \ - ../phys/module_fr_fire_driver_wrf.o \ + ../phys/module_fr_sfire_driver_wrf.o \ $(CF) solve_em.o: module_small_step_em.o \ @@ -287,7 +287,7 @@ module_first_rk_step_part1.o : \ ../phys/module_cumulus_driver.o \ ../phys/module_shallowcu_driver.o \ ../phys/module_pbl_driver.o \ - ../phys/module_fr_fire_driver_wrf.o \ + ../phys/module_fr_sfire_driver_wrf.o \ ../frame/module_comm_dm.o \ ../phys/module_fddagd_driver.o @@ -324,4 +324,3 @@ adapt_timestep_em.o: \ # ../chem/module_input_chem_data.o # End of DEPENDENCIES for dyn_em - From f9017a57dd27379d8469e84ad6b45d7bde5ef964 Mon Sep 17 00:00:00 2001 From: "Theodore M. Giannaros" <37264065+tmgiannaros@users.noreply.github.com> Date: Thu, 22 Mar 2018 21:44:58 +0200 Subject: [PATCH 09/15] Update module_initialize_fire.F Modifications for using the SFIRE mode. Important! The capability for hybrid coordinates (new feature in WRFV3.9) has not been incorporated! --- wrfv2_fire/dyn_em/module_initialize_fire.F | 99 ++++++++++++++++------ 1 file changed, 72 insertions(+), 27 deletions(-) diff --git a/wrfv2_fire/dyn_em/module_initialize_fire.F b/wrfv2_fire/dyn_em/module_initialize_fire.F index 7fe293ca..666b3ee3 100644 --- a/wrfv2_fire/dyn_em/module_initialize_fire.F +++ b/wrfv2_fire/dyn_em/module_initialize_fire.F @@ -27,8 +27,11 @@ MODULE module_initialize_ideal #ifdef DM_PARALLEL USE module_dm #endif - USE module_fr_fire_util, ONLY: continue_at_boundary,crash,read_array_2d_real, & - read_array_2d_integer,interpolate_2d,set_ideal_coord + ! TMG: Replace with SFIRE module & subr + ! SFIRE: Utilities and main SFIRE driver + USE module_fr_sfire_util, ONLY: continue_at_boundary,crash,read_array_2d_real, & + interpolate_2d,set_ideal_coord,print_2d_stats + USE module_fr_sfire_driver, ONLY: set_flags CONTAINS @@ -55,7 +58,7 @@ SUBROUTINE init_domain ( grid ) CALL init_domain_rk( grid & ! -#include "actual_new_args.inc" +#include ! ) @@ -65,7 +68,7 @@ END SUBROUTINE init_domain SUBROUTINE init_domain_rk ( grid & ! -# include "dummy_new_args.inc" +# include ! ) IMPLICIT NONE @@ -73,7 +76,7 @@ SUBROUTINE init_domain_rk ( grid & ! Input data. TYPE (domain), POINTER :: grid -# include "dummy_new_decl.inc" +# include TYPE (grid_config_rec_type) :: config_flags @@ -119,11 +122,13 @@ SUBROUTINE init_domain_rk ( grid & ifts,ifte, kfts,kfte, jfts,jfte REAL :: mtn_ht, mtn_max, mtn_x, mtn_y, mtn_z, grad_max + REAL :: tign_max,tign_min REAL :: mtn_axs, mtn_ays, mtn_axe, mtn_aye REAL :: mtn_fxs, mtn_fys, mtn_fxe, mtn_fye REAL :: mtn_xs, mtn_ys, mtn_xe, mtn_ye REAL :: fdx,fdy ! fire mesh step INTEGER:: ir,jr ! refinement factors + REAL :: minhfx,maxhfx,totheat logical have_fire_ht,have_fire_grad,have_atm_grad @@ -239,8 +244,12 @@ SUBROUTINE init_domain_rk ( grid & END DO END DO +! ***** fire + write(6,*) '*************************************' + + call set_flags(config_flags) + !AK/ak surface initialization latitude, longitude, landuse index from from LANDUSE.TBL skin temperature and soil temperature -write(6,*) '*************************************' IF (sfc_init) THEN DO j = jts, jte DO i = its, ite @@ -352,23 +361,6 @@ SUBROUTINE init_domain_rk ( grid & grid%rdnw(k) = 1./grid%dnw(k) grid%znu(k) = 0.5*(grid%znw(k+1)+grid%znw(k)) ENDDO - - IF ( config_flags%hybrid_opt .NE. 0 ) THEN - call wrf_error_fatal ( '--- ERROR: Hybrid Vertical Coordinate option not supported with this idealized case' ) - END IF - grid%hybrid_opt = 0 - - DO k=1, kde - grid%c3f(k) = grid%znw(k) - grid%c4f(k) = 0. - grid%c3h(k) = grid%znu(k) - grid%c4h(k) = 0. - grid%c1f(k) = 1. - grid%c2f(k) = 0. - grid%c1h(k) = 1. - grid%c2h(k) = 0. - ENDDO - DO k=2, kde-1 grid%dn(k) = 0.5*(grid%dnw(k)+grid%dnw(k-1)) grid%rdn(k) = 1./grid%dn(k) @@ -419,7 +411,8 @@ SUBROUTINE init_domain_rk ( grid & ifms,ifme, jfms,jfme,kfms,kfme, & ifts,ifte, jfts,jfte,kfts,kfte) - write (6,*)' ******** SFIRE ideal initialization ********' +IF ((grid%sr_x > 0 .OR. grid%sr_y > 0) .AND. config_flags%ifire == 2) THEN + write (6,*)' ******** SFIRE ideal initialization start ********' ! fire grid step size fdx = grid%dx/grid%sr_x @@ -459,8 +452,36 @@ SUBROUTINE init_domain_rk ( grid & ENDDO ENDDO - if(config_flags%fire_fuel_read.eq.2) & + if(config_flags%fire_fmc_read.eq.2) then + write(6,*)'Reading fuel moisture from file input_fmc_g' + call read_array_2d_real ('input_fmc_g',grid%fmc_g, ifds,ifde,jfds,jfde,ifms,ifme,jfms,jfme) + endif + + + if(config_flags%fire_fuel_read.eq.2) then + write(6,*)'Reading fuel map from file input_fc' call read_array_2d_real('input_fc',grid%nfuel_cat,ifds,ifde,jfds,jfde,ifms,ifme,jfms,jfme) + endif + + if(config_flags%fire_hfx_given.eq.2) then + write(6,*)'Reading given heat flux from file input_hfx' + call read_array_2d_real('input_hfx',grid%fire_hfx,ifds,ifde,jfds,jfde,ifms,ifme,jfms,jfme) + maxhfx=-huge(maxhfx) + minhfx=huge(minhfx) + totheat=0. + do j=jfds,jfde + do i=ifds,ifde + minhfx = max(minhfx,grid%fire_hfx(i,j)) + maxhfx = max(maxhfx,grid%fire_hfx(i,j)) + totheat = totheat + grid%fire_hfx(i,j)*fdx*fdy + enddo + enddo + write(6,*)'Given heat flux min ',minhfx,' max ',maxhfx,' W/m^2' + write(6,*)'Total heat ',totheat,' W' + if(minhfx<0.)call crash('Heat flux must be nonnegative number') + endif + + have_fire_grad=.false. @@ -634,6 +655,30 @@ SUBROUTINE init_domain_rk ( grid & ENDDO write(6, *)' Max terrain height on the fire mesh ',mtn_max write(6, *)' Max terrain gradient on the fire mesh ',grad_max + +! JM read ignition time from file if we are replaying fire history up to the specified time + write(6,*)'fire_perimeter_time= ',config_flags%fire_perimeter_time,' fire_tign_in_time=',config_flags%fire_tign_in_time + if(config_flags%fire_perimeter_time > 0. .or. config_flags%fire_tign_in_time > 0.)then + write(6,*)'Reading ignition times from file input_tign_g' + call read_array_2d_real('input_tign_g',grid%tign_g,ifds,ifde,jfds,jfde,ifms,ifme,jfms,jfme) + tign_max = -huge(tign_max) + tign_min = huge(tign_min) + k=0 + do j=jfds,jfde + do i=ifds,ifde + tign_max=max(tign_max,grid%tign_g(i,j)) + tign_min=min(tign_min,grid%tign_g(i,j)) + if(grid%tign_g(i,j) < config_flags%fire_perimeter_time) k=k+1 + enddo + enddo + write(6,*)'min max ignition time given ',tign_min,tign_max + write(6,*)k,real(k)/((ifde-ifds+1)*(jfde-jfds+1)),'% cells ignited at time ', & + max(config_flags%fire_perimeter_time,config_flags%fire_tign_in_time) + endif + write (6,*)' ******** SFIRE ideal initialization complete ********' +else + write (6,*)' ******** SFIRE ideal initialization skipped ********' +endif ! the rest of initialization dependent on the atmosphere grid terrain height set @@ -747,7 +792,7 @@ SUBROUTINE init_domain_rk ( grid & grid%ph_1(i,1,j) = 0. DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) @@ -808,7 +853,7 @@ SUBROUTINE init_domain_rk ( grid & ! rebalance hydrostatically DO k = 2,kte - grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (grid%dnw(k-1))*( & + grid%ph_1(i,k,j) = grid%ph_1(i,k-1,j) - (1./grid%rdnw(k-1))*( & (grid%mub(i,j)+grid%mu_1(i,j))*grid%al(i,k-1,j)+ & grid%mu_1(i,j)*grid%alb(i,k-1,j) ) From a1148868f31d7d62eccf768ad7325391e15fbca7 Mon Sep 17 00:00:00 2001 From: "Theodore M. Giannaros" <37264065+tmgiannaros@users.noreply.github.com> Date: Thu, 22 Mar 2018 22:04:41 +0200 Subject: [PATCH 10/15] Add SFIRE modules --- wrfv2_fire/phys/module_fr_sfire_atm.F | 2220 +++++++++++++++++ wrfv2_fire/phys/module_fr_sfire_core.F | 2290 ++++++++++++++++++ wrfv2_fire/phys/module_fr_sfire_driver.F | 1675 +++++++++++++ wrfv2_fire/phys/module_fr_sfire_driver_wrf.F | 291 +++ wrfv2_fire/phys/module_fr_sfire_model.F | 711 ++++++ wrfv2_fire/phys/module_fr_sfire_phys.F | 1767 ++++++++++++++ wrfv2_fire/phys/module_fr_sfire_util.F | 1742 +++++++++++++ 7 files changed, 10696 insertions(+) create mode 100644 wrfv2_fire/phys/module_fr_sfire_atm.F create mode 100644 wrfv2_fire/phys/module_fr_sfire_core.F create mode 100644 wrfv2_fire/phys/module_fr_sfire_driver.F create mode 100644 wrfv2_fire/phys/module_fr_sfire_driver_wrf.F create mode 100644 wrfv2_fire/phys/module_fr_sfire_model.F create mode 100644 wrfv2_fire/phys/module_fr_sfire_phys.F create mode 100644 wrfv2_fire/phys/module_fr_sfire_util.F diff --git a/wrfv2_fire/phys/module_fr_sfire_atm.F b/wrfv2_fire/phys/module_fr_sfire_atm.F new file mode 100644 index 00000000..b205e095 --- /dev/null +++ b/wrfv2_fire/phys/module_fr_sfire_atm.F @@ -0,0 +1,2220 @@ +!WRF:MEDIATION_LAYER:FIRE_MODEL + +!*** Jan Mandel August 2007 - February 2010 +!*** email: Jan.Mandel@gmail.com + +! Routines dealing with the atmosphere + +module module_fr_sfire_atm + +use module_model_constants, only: cp,xlv,g +use module_fr_sfire_phys, only: fire_wind_height,have_fuel_cats,fcz0,fcwh,nfuelcats,no_fuel_cat,no_fuel_cat2,windrf +use module_fr_sfire_util +USE module_dm , only : wrf_dm_sum_reals + + +use module_fr_sfire_phys, only: mfuelcats, nfuelcats ! for emissions +USE module_state_description, only: num_tracer +use module_fr_sfire_phys, only: fuel_name + +#ifdef WRF_CHEM +USE module_state_description, only: num_chem +USE module_configure, only: & +p_co, & +p_ch4, & +p_h2, & +p_no, & +p_no2, & +p_so2, & +p_nh3, & +p_p25, & +p_p25i, & +p_p25j, & +p_oc1, & +p_oc2, & +p_bc1, & +p_bc2, & +p_ald, & +p_csl, & +p_eth, & +p_hc3, & +p_hc5, & +p_hcho, & +p_iso, & +p_ket, & +p_mgly, & +p_ol2, & +p_olt, & +p_oli, & +p_ora2,& +p_tol, & +p_xyl, & +p_bigalk, & +p_bigene, & +p_c10h16, & +p_c2h4, & +p_c2h5oh, & +p_c2h6, & +p_c3h6, & +p_c3h8, & +p_ch3cooh, & +p_ch3oh, & +p_cres, & +p_glyald, & +! p_hyac, & +p_isopr, & +p_macr, & +p_mek, & +p_mvk, & +p_smoke ! tracer smoke exists only with CHEM +#endif + +USE module_state_description, only: & +p_tr17_1, & +p_tr17_2, & +p_tr17_3, & +p_tr17_4, & +p_tr17_5, & +p_tr17_6, & +p_tr17_7, & +p_tr17_8 + +implicit none + +#ifndef WRF_CHEM +integer, parameter, private:: num_chem=0 +#endif + +logical, save :: have_wind_log_interpolation = .false. ! status + +! emission tables +REAL, dimension(mfuelcats), save:: & +co=0., & +ch4=0., & +h2=0., & +no=0., & +no2=0., & +so2=0., & +nh3=0., & +oc1=0., & +oc2=0., & +bc1=0., & +bc2=0., & +ald=0., & +csl=0., & +eth=0., & +hc3=0., & +p25=0., & +p25i=0., & +p25j=0., & +hc5=0., & +hcho=0., & +iso=0., & +ket=0., & +mgly=0., & +ol2=0., & +olt=0., & +oli=0., & +ora2=0.,& +tol=0., & +xyl=0., & +bigalk=0., & +bigene=0., & +c10h16=0., & +c2h4=0., & +c2h5oh=0., & +c2h6=0., & +c3h6=0., & +c3h8=0., & +ch3cooh=0., & +ch3oh=0., & +cres=0., & +glyald=0., & +! hyac=0., & +isopr=0., & +macr=0., & +mek=0., & +mvk=0., & +smoke=0., & +tr17_1=0., & +tr17_2=0., & +tr17_3=0., & +tr17_4=0., & +tr17_5=0., & +tr17_6=0., & +tr17_7=0., & +tr17_8=0. + +real, parameter:: & ! reciprocal molecular weights (mol/g) + imw_co = 1./28.010,& + imw_ch4 = 1./16.04,& + imw_h2 = 1./2.016,& + imw_no = 1./30.006,& + imw_no2 = 1./46.006,& + imw_so2 = 1./64.066,& + imw_nh3 = 1./17.031 + +real, parameter:: mw_air=28.97 ! molecular weight of air g/mol + +! should be declared in the registry and stored in the state in future because of restarts + +real, pointer, save, dimension(:)::c_chem +real, pointer, save, dimension(:)::c_fuel +real, pointer, save, dimension(:)::c_tracer +logical, save:: emis_read = .false. +integer, save:: msglevel =1,printsums=0 ! when to print sums +integer, parameter:: line=5 ! number of species, emissions, etc. per line + +contains + +! chem arrays are chem tracer +! indices p_species are generated in inc/scalar_indices.inc and included in frame/module_configure.F + +subroutine read_emissions_table(chem_opt,tracer_opt) + implicit none + integer, intent(in)::chem_opt,tracer_opt + logical, external:: wrf_dm_on_monitor + external::wrf_dm_bcast_integer , wrf_dm_bcast_real + integer, dimension(10)::compatible_chem_opt + integer:: iounit,ierr,i + character(len=128)::msg + namelist/emissions/ compatible_chem_opt, printsums, & +co, & +ch4, & +h2, & +no, & +no2, & +so2, & +nh3, & +p25, & +p25i, & +p25j, & +oc1, & +oc2, & +bc1, & +bc2, & +ald, & +csl, & +eth, & +hc3, & +hc5, & +hcho, & +iso, & +ket, & +mgly, & +ol2, & +olt, & +oli, & +ora2,& +tol, & +xyl, & +bigalk, & +bigene, & +c10h16, & +c2h4, & +c2h5oh, & +c2h6, & +c3h6, & +c3h8, & +ch3cooh, & +ch3oh, & +cres, & +glyald, & +! hyac, & +isopr, & +macr, & +mek, & +mvk, & +smoke, & +tr17_1, & +tr17_2, & +tr17_3, & +tr17_4, & +tr17_5, & +tr17_6, & +tr17_7, & +tr17_8 + +!$ if (OMP_GET_THREAD_NUM() .ne. 0)then +!$ call crash('read_emissions_table: must be called from master thread') +!$ endif + +IF ( wrf_dm_on_monitor() ) THEN + ! we are the master task + + iounit=open_text_file('namelist.fire_emissions','read') + compatible_chem_opt=0 + read(iounit,emissions,iostat=ierr) + if(ierr.ne.0)call crash('read_emissions_table: error reading namelist emissions in file namelist.fire_emissions') + CLOSE(iounit) + write(msg,'(a,i3,a)')'reading emissions table for',nfuelcats,' fuel categories' + call message(msg,level=0) + if (.not.any(compatible_chem_opt.eq.chem_opt))then + write(msg,'(a,i4,a)')'read_emissions_table: chem_opt=',chem_opt,' not between given compatible_chem_opt in namelist.fire_emissions' + call message(msg,level=0) + write(msg,'(a,10i4)')'compatible_chem_opt=', compatible_chem_opt + call message(msg,level=0) + call crash('chem_opt in namelist.input is not consistent with namelist.fire_emissions') + endif +ENDIF +call wrf_dm_bcast_integer(printsums, 1) +call wrf_dm_bcast_real(co, nfuelcats) +call wrf_dm_bcast_real(ch4, nfuelcats) +call wrf_dm_bcast_real(h2, nfuelcats) +call wrf_dm_bcast_real(no, nfuelcats) +call wrf_dm_bcast_real(no2, nfuelcats) +call wrf_dm_bcast_real(so2, nfuelcats) +call wrf_dm_bcast_real(nh3, nfuelcats) +call wrf_dm_bcast_real(p25, nfuelcats) +call wrf_dm_bcast_real(p25i, nfuelcats) +call wrf_dm_bcast_real(p25j, nfuelcats) +call wrf_dm_bcast_real(oc1, nfuelcats) +call wrf_dm_bcast_real(oc2, nfuelcats) +call wrf_dm_bcast_real(bc1, nfuelcats) +call wrf_dm_bcast_real(bc2, nfuelcats) +call wrf_dm_bcast_real(ald, nfuelcats) +call wrf_dm_bcast_real(csl, nfuelcats) +call wrf_dm_bcast_real(eth, nfuelcats) +call wrf_dm_bcast_real(hc3, nfuelcats) +call wrf_dm_bcast_real(hc5, nfuelcats) +call wrf_dm_bcast_real(hcho, nfuelcats) +call wrf_dm_bcast_real(iso, nfuelcats) +call wrf_dm_bcast_real(ket, nfuelcats) +call wrf_dm_bcast_real(mgly, nfuelcats) +call wrf_dm_bcast_real(ol2, nfuelcats) +call wrf_dm_bcast_real(olt, nfuelcats) +call wrf_dm_bcast_real(oli, nfuelcats) +call wrf_dm_bcast_real(ora2,nfuelcats) +call wrf_dm_bcast_real(tol, nfuelcats) +call wrf_dm_bcast_real(xyl, nfuelcats) +call wrf_dm_bcast_real(bigalk, nfuelcats) +call wrf_dm_bcast_real(bigene, nfuelcats) +call wrf_dm_bcast_real(c10h16, nfuelcats) +call wrf_dm_bcast_real(c2h4, nfuelcats) +call wrf_dm_bcast_real(c2h5oh, nfuelcats) +call wrf_dm_bcast_real(c2h6, nfuelcats) +call wrf_dm_bcast_real(c3h6, nfuelcats) +call wrf_dm_bcast_real(c3h8, nfuelcats) +call wrf_dm_bcast_real(ch3cooh, nfuelcats) +call wrf_dm_bcast_real(ch3oh, nfuelcats) +call wrf_dm_bcast_real(cres, nfuelcats) +call wrf_dm_bcast_real(glyald, nfuelcats) +! call wrf_dm_bcast_real(hyac, nfuelcats) +call wrf_dm_bcast_real(isopr, nfuelcats) +call wrf_dm_bcast_real(macr, nfuelcats) +call wrf_dm_bcast_real(mek, nfuelcats) +call wrf_dm_bcast_real(mvk, nfuelcats) +call wrf_dm_bcast_real(smoke, nfuelcats) +call wrf_dm_bcast_real(tr17_1, nfuelcats) +call wrf_dm_bcast_real(tr17_2, nfuelcats) +call wrf_dm_bcast_real(tr17_3, nfuelcats) +call wrf_dm_bcast_real(tr17_4, nfuelcats) +call wrf_dm_bcast_real(tr17_5, nfuelcats) +call wrf_dm_bcast_real(tr17_6, nfuelcats) +call wrf_dm_bcast_real(tr17_7, nfuelcats) +call wrf_dm_bcast_real(tr17_8, nfuelcats) + +if(fire_print_msg .ge. msglevel .and.printsums .gt. 0)then + ! should be stored in the registry future because of restarts + write(msg,'(3(a,i3,1x))')'allocating c_chem size',num_chem,'c_tracer size',num_tracer,'c_fuel size',nfuelcats + call message(msg,level=2) + if(num_chem>0)then + allocate(c_chem(num_chem)) + c_chem=0. ! cumulative burnt + endif + if(num_tracer>0)then + allocate(c_tracer(num_tracer)) + c_tracer=0. ! cumulative burnt + endif + allocate(c_fuel(nfuelcats)) + c_fuel=0. ! total per timestep, rate burnt, cumulative burnt + write(msg,'(a,i3,a,i3)')'allocated c_chem size',size(c_chem),' c_fuel size',size(c_fuel) + call message(msg,level=2) +endif + +emis_read=.true. + +end subroutine read_emissions_table + +subroutine add_fire_emissions(chem_opt,tracer_opt,dt,dx,dy, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jtfs,jfte, & + ids,ide,kds,kde,jds,jde, & + ims,ime,kms,kme,jms,jme, & + its,ite,kts,kte,jts,jte, & + rho,dz8w, & ! input on atmosphere mesh + fgip, fuel_frac_burnt, nfuel_cat, & ! input on fire mesh + chem,tracer) ! output + + +implicit none + +!*** purpose +! average fire emissions from fire mesh to coarser atmosphereic mesh and add to chemistry arrays + +!*** arguments +! the dimensions are in cells, not nodes! + +! input +integer, intent(in)::chem_opt,tracer_opt +real, intent(in):: dt,dx,dy ! time step & mesh spacing +integer, intent(in)::its,ite,kts,kte,jts,jte,ims,ime,kms,kme,jms,jme &! atm grid dims + ,ids,ide,kds,kde,jds,jde +integer, intent(in)::ifts,ifte,jtfs,jfte,ifms,ifme,jfms,jfme ! fire grid dims +real, intent(in)::rho(ims:ime,kms:kme,jms:jme), & ! air density kg/m^3 + dz8w(ims:ime,kms:kme,jms:jme) ! layer height +real, intent(in), dimension(ifms:ifme,jfms:jfme):: fgip, & ! initial fuel load kg/m^2 + fuel_frac_burnt, & ! fuel fraction burned this step kg/kg + nfuel_cat ! fuel category (Anderson= 1 to 13) +! update +real, intent(inout)::chem(ims:ime,kms:kme,jms:jme,num_chem),tracer(ims:ime,kms:kme,jms:jme,num_tracer) + +!*** local +integer:: i,i_f,j,j_f,ir,jr,isz1,isz2,jsz1,jsz2,ioff,joff,ibase,jbase,cat,k1,areaw,m,k,k_p,errors +real::fuel_burnt,vol,air,conv, avgw,emis +character(len=128)msg + +real, dimension(mfuelcats)::s_fuel,t_fuel,r_fuel ! total per timestep, rate burnt +#ifdef WRF_CHEM +real, dimension(num_chem) ::s_chem,t_chem,r_chem ! total per timestep, rate burnt +real, dimension(num_chem) ::a_chem,g_chem ! concentration in ground level 1 +integer, parameter:: chem_np=46 +integer:: chem_pointers(chem_np) +character(len=8)::chem_names(chem_np) +#endif +real, dimension(num_tracer) ::s_tracer,t_tracer,r_tracer ! total per timestep, rate burnt + +integer, parameter:: tracer_np=8 +integer:: tracer_pointers(tracer_np) +character(len=8)::tracer_names(tracer_np) + +!*** executable + +!check mesh dimensions and domain dimensions +call check_mesh_2dim(its,ite,jts,jte,ims,ime,jms,jme) +call check_mesh_2dim(ifts,ifte,jtfs,jfte,ifms,ifme,jfms,jfme) + +if(.not.emis_read)call crash('add_fire_emissions: read_emissions_table must be called first') +write(msg,'(a,i3,a,i3,a,i3)')'add_fire_emissions: chem_opt=',chem_opt,' species ',num_chem,' tracers',num_tracer +call message(msg) + +#ifdef WRF_CHEM +chem_pointers= (/ & +p_co, & +p_ch4, & +p_h2, & +p_no, & +p_no2, & +p_so2, & +p_nh3, & +p_p25, & +p_p25i, & +p_p25j, & +p_oc1, & +p_oc2, & +p_bc1, & +p_bc2, & +p_ald, & +p_csl, & +p_eth, & +p_hc3, & +p_hc5, & +p_hcho, & +p_iso, & +p_ket, & +p_mgly, & +p_ol2, & +p_olt, & +p_oli, & +p_ora2,& +p_tol, & +p_xyl, & +p_bigalk, & +p_bigene, & +p_c10h16, & +p_c2h4, & +p_c2h5oh, & +p_c2h6, & +p_c3h6, & +p_c3h8, & +p_ch3cooh, & +p_ch3oh, & +p_cres, & +p_glyald, & +! p_hyac, & +p_isopr, & +p_macr, & +p_mek, & +p_mvk, & +p_smoke /) + +chem_names= (/ & +'co ', & +'ch4 ', & +'h2 ', & +'no ', & +'no2 ', & +'so2 ', & +'nh3 ', & +'p25 ', & +'p25i ', & +'p25j ', & +'oc1 ', & +'oc2 ', & +'bc1 ', & +'bc2 ', & +'ald ', & +'csl ', & +'eth ', & +'hc3 ', & +'hc5 ', & +'hcho ', & +'iso ', & +'ket ', & +'mgly ', & +'ol2 ', & +'olt ', & +'oli ', & +'ora2 ',& +'tol ', & +'xyl ', & +'bigalk ', & +'bigene ', & +'c10h16 ', & +'c2h4 ', & +'c2h5oh ', & +'c2h6 ', & +'c3h6 ', & +'c3h8 ', & +'ch3cooh ', & +'ch3oh ', & +'cres ', & +'glyald ', & +! 'hyac ', & +'isopr ', & +'macr ', & +'mek ', & +'mvk ', & +'smoke ' /) + +call check_pointers('chem',chem,chem_names,chem_pointers) +#endif + +tracer_pointers= (/ & +p_tr17_1, & +p_tr17_2, & +p_tr17_3, & +p_tr17_4, & +p_tr17_5, & +p_tr17_6, & +p_tr17_7, & +p_tr17_8 /) + +tracer_names= (/ & +'tr17_1 ', & +'tr17_2 ', & +'tr17_3 ', & +'tr17_4 ', & +'tr17_5 ', & +'tr17_6 ', & +'tr17_7 ', & +'tr17_8 ' /) + +call check_pointers('tracer',tracer,tracer_names,tracer_pointers) + +! compute mesh sizes +isz1 = ite-its+1 +jsz1 = jte-jts+1 +isz2 = ifte-ifts+1 +jsz2 = jfte-jtfs+1 + + +! check mesh sizes +if(isz1.le.0.or.jsz1.le.0.or.isz2.le.0.or.jsz2.le.0)then + call message('all mesh sizes must be positive',level=0) + goto 9 +endif + +! compute mesh ratios +ir=isz2/isz1 +jr=jsz2/jsz1 + +if(isz2.ne.isz1*ir .or. jsz2.ne.jsz1*jr)then + call message('input mesh size must be multiple of output mesh size',level=0) + goto 9 +endif + +avgw = 1.0/(ir*jr) ! averaging weight = 1/number of fire cells per atm cell + +! initialize emissions statistics per timestep +#ifdef WRF_CHEM +t_chem = 0. +#endif +t_fuel = 0. +do i=1,num_tracer + t_tracer(i)=0. +enddo + +! conversion fuel_burnt kg/m^2 -> chem_X 1e6*mol/mol +! emis_X(g/kg)*fuel_burnt(kg/m^2)/mw_X(g/mol) = emissions (mol/m^2) +! rho(kg/m^3)*dz8w(m))/mw_air(28.97e-3 kg/mol) = dry air in the 1st layer (mol/m^2) + +k1 = kts +write(msg,'(a,i3)')'Fire emissions inserted into atmosphere level',k1 +call message(msg,level=msglevel) + +#ifdef WRF_CHEM +if(fire_print_msg .ge. msglevel .and.printsums .gt. 0)then + ! sum ground concentrations and check for nans + a_chem=0.0 + g_chem=0.0 + errors=0 + do j=jts,jte + do k=1,chem_np + k_p=chem_pointers(k) + do i=its,ite + if(chem(i,k1,j,k_p ).ne.chem(i,k1,j,k_p ))errors=errors+1 + a_chem(k_p)=a_chem(k_p)+chem(i,k1,j,k_p ) + enddo + enddo + enddo + if(errors>0)call crash('NaN before chem update') + call wrf_dm_sum_reals(a_chem,g_chem) + call message('Layer1 raw sums before adding fire emissions',level=msglevel) + do i=1,chem_np,line + m=min(i+line-1,chem_np) + write(msg,80)'Emissions ',(trim(chem_names(j)),j=i,m) + call message(msg,level=msglevel) + write(msg,81)'Layer1 beg',(g_chem(chem_pointers(j)),j=i,m) + call message(msg,level=msglevel) + call message(' ',level=msglevel) + enddo +endif +#endif + +do j=max(jds+1,jts),min(jte,jde-1) ! safe distance from domain boundary + jbase=jtfs+jr*(j-jts) ! indexing + do i=max(ids+1,its),min(ite,ide-1) + ibase=ifts+ir*(i-its) ! indexing + !air = 1e6*mw_air/rho(i,kds,j) ! 1e6*mw_air/air density + !vol = avgw/dz8w(i,kds,j) ! averaging volume factor / 1st layer depth + + do joff=0,jr-1 + j_f=joff+jbase + do ioff=0,ir-1 + i_f=ioff+ibase + + + !*** fire cell (i_f,j_f) contributes to atmosphere cell (i,j) at ground level + + fuel_burnt = fgip(i_f,j_f) * fuel_frac_burnt(i_f,j_f) ! kg/m^2 + cat = nfuel_cat(i_f, j_f) ! usually 1 to 13 + + if(cat.lt.no_fuel_cat)t_fuel(cat)=t_fuel(cat) + fuel_burnt + + + !*** chem compounds emissions given in g/kg + + ! fuel_burnt kg/m^2 * table g/kg -> ppmv = 1e6*mol/mol in 1st layer +!AK rho is in kg/m3 so the conversion factor must be scaled by a 1000 to match +!emissions in grams +! conv = avgw*1e6*mw_air/(rho(i,k1,j)*dz8w(i,k1,j)) + conv = avgw*1e3*mw_air/(rho(i,k1,j)*dz8w(i,k1,j)) +#ifdef WRF_CHEM + + emis=co (cat)*fuel_burnt ! emission from fire cell in g/m^2 + t_chem(p_co) = t_chem(p_co) + emis ! add to total + ! if(isnan(chem(i,k1,j,p_co )))call crash('NaN before') + chem(i,k1,j,p_co )=chem(i,k1,j,p_co ) + emis*conv*imw_co ! add to chem + ! if(isnan(chem(i,k1,j,p_co )))call crash('NaN after') + + emis=ch4 (cat)*fuel_burnt ! emission from fire cell in g/m^2 + t_chem(p_ch4) = t_chem(p_ch4) + emis ! add to total + chem(i,k1,j,p_ch4 )=chem(i,k1,j,p_ch4 ) + emis*conv*imw_ch4 ! add to chem + + emis=h2 (cat)*fuel_burnt ! emission from fire cell in g/m^2 + t_chem(p_h2) = t_chem(p_h2) + emis ! add to total + chem(i,k1,j,p_h2 )=chem(i,k1,j,p_h2 ) + emis*conv*imw_h2 ! add to chem + + emis=no (cat)*fuel_burnt ! emission from fire cell in g/m^2 + t_chem(p_no) = t_chem(p_no) + emis ! add to total + chem(i,k1,j,p_no )=chem(i,k1,j,p_no ) + emis*conv*imw_no ! add to chem + + emis=no2 (cat)*fuel_burnt ! emission from fire cell in g/m^2 + t_chem(p_no2) = t_chem(p_no2) + emis ! add to total + chem(i,k1,j,p_no2 )=chem(i,k1,j,p_no2 ) + emis*conv*imw_no2 ! add to chem + + emis=so2 (cat)*fuel_burnt ! emission from fire cell in g/m^2 + t_chem(p_so2) = t_chem(p_so2) + emis ! ads to total + chem(i,k1,j,p_so2 )=chem(i,k1,j,p_so2 ) + emis*conv*imw_so2 ! add to chem + + emis=nh3 (cat)*fuel_burnt ! emission from fire cell in g/m^2 + t_chem(p_nh3) = t_chem(p_nh3) + emis ! add to total + chem(i,k1,j,p_nh3 )=chem(i,k1,j,p_nh3 ) + emis*conv*imw_nh3 ! add to chem + + + !*** other emissions already given in mol/kg + ! fuel_burnt kg/m^2 * table mol/kg -> ppmv = 1e6*mol/mol in 1st layer dry air in 1st layer + + ! same conversion factor but we will not divide by the molecular weight of the compound + ! conv = avgw*1e6*mw_air/(rho(i,kds,j)*dz8w(i,kds,j)) + + emis=ald (cat)*fuel_burnt ! emission from fire cell + t_chem(p_ald) = t_chem(p_ald) + emis ! add to total + chem(i,k1,j,p_ald )=chem(i,k1,j,p_ald )+emis*conv + + emis=csl (cat)*fuel_burnt ! emission from fire cell + t_chem(p_csl) = t_chem(p_csl) + emis ! add to total + chem(i,k1,j,p_csl )=chem(i,k1,j,p_csl )+emis*conv + + emis=eth (cat)*fuel_burnt ! emission from fire cell + t_chem(p_eth) = t_chem(p_eth) + emis ! add to total + chem(i,k1,j,p_eth )=chem(i,k1,j,p_eth )+emis*conv + + emis=hc3 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_hc3) = t_chem(p_hc3) + emis ! add to total + chem(i,k1,j,p_hc3 )=chem(i,k1,j,p_hc3 )+emis*conv + + emis=hc5 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_hc5) = t_chem(p_hc5) + emis ! add to total + chem(i,k1,j,p_hc5 )=chem(i,k1,j,p_hc5 )+emis*conv + + emis=hcho (cat)*fuel_burnt ! emission from fire cell + t_chem(p_hcho) = t_chem(p_hcho) + emis ! add to total + chem(i,k1,j,p_hcho)=chem(i,k1,j,p_hcho)+emis*conv + + emis=iso (cat)*fuel_burnt ! emission from fire cell + t_chem(p_iso) = t_chem(p_iso) + emis ! add to total + chem(i,k1,j,p_iso )=chem(i,k1,j,p_iso )+emis*conv + + emis=ket (cat)*fuel_burnt ! emission from fire cell + t_chem(p_ket) = t_chem(p_ket) + emis ! add to total + chem(i,k1,j,p_ket )=chem(i,k1,j,p_ket )+emis*conv + + emis=mgly (cat)*fuel_burnt ! emission from fire cell + t_chem(p_mgly) = t_chem(p_mgly) + emis ! add to total + chem(i,k1,j,p_mgly)=chem(i,k1,j,p_mgly)+emis*conv + + emis=ol2 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_ol2) = t_chem(p_ol2) + emis ! add to total + chem(i,k1,j,p_ol2 )=chem(i,k1,j,p_ol2 )+emis*conv + + emis=olt (cat)*fuel_burnt ! emission from fire cell + t_chem(p_olt) = t_chem(p_olt) + emis ! add to total + chem(i,k1,j,p_olt )=chem(i,k1,j,p_olt )+emis*conv + + emis=oli (cat)*fuel_burnt ! emission from fire cell + t_chem(p_oli) = t_chem(p_oli) + emis ! add to total + chem(i,k1,j,p_oli )=chem(i,k1,j,p_oli )+emis*conv + + emis=ora2 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_ora2) = t_chem(p_ora2) + emis ! add to total + chem(i,k1,j,p_ora2)=chem(i,k1,j,p_ora2)+emis*conv + + emis=tol (cat)*fuel_burnt ! emission from fire cell + t_chem(p_tol) = t_chem(p_tol) + emis ! add to total + chem(i,k1,j,p_tol )=chem(i,k1,j,p_tol )+emis*conv + + emis=xyl (cat)*fuel_burnt ! emission from fire cell + t_chem(p_xyl) = t_chem(p_xyl) + emis ! add to total + chem(i,k1,j,p_xyl )=chem(i,k1,j,p_xyl )+emis*conv + + emis=bigalk (cat)*fuel_burnt ! emission from fire cell + t_chem(p_bigalk) = t_chem(p_bigalk) + emis ! add to total + chem(i,k1,j,p_bigalk )=chem(i,k1,j,p_bigalk )+emis*conv + + emis=bigene (cat)*fuel_burnt ! emission from fire cell + t_chem(p_bigene) = t_chem(p_bigene) + emis ! add to total + chem(i,k1,j,p_bigene )=chem(i,k1,j,p_bigene )+emis*conv + + emis=c10h16 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_c10h16) = t_chem(p_c10h16) + emis ! add to total + chem(i,k1,j,p_c10h16 )=chem(i,k1,j,p_c10h16 )+emis*conv + + emis=c2h4 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_c2h4) = t_chem(p_c2h4) + emis ! add to total + chem(i,k1,j,p_c2h4 )=chem(i,k1,j,p_c2h4 )+emis*conv + + emis=c2h5oh (cat)*fuel_burnt ! emission from fire cell + t_chem(p_c2h5oh) = t_chem(p_c2h5oh) + emis ! add to total + chem(i,k1,j,p_c2h5oh )=chem(i,k1,j,p_c2h5oh )+emis*conv + + emis=c2h6 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_c2h6) = t_chem(p_c2h6) + emis ! add to total + chem(i,k1,j,p_c2h6 )=chem(i,k1,j,p_c2h6 )+emis*conv + + emis=c3h6 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_c3h6) = t_chem(p_c3h6) + emis ! add to total + chem(i,k1,j,p_c3h6 )=chem(i,k1,j,p_c3h6 )+emis*conv + + emis=c3h8 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_c3h8) = t_chem(p_c3h8) + emis ! add to total + chem(i,k1,j,p_c3h8 )=chem(i,k1,j,p_c3h8 )+emis*conv + + emis=ch3cooh (cat)*fuel_burnt ! emission from fire cell + t_chem(p_ch3cooh) = t_chem(p_ch3cooh) + emis ! add to total + chem(i,k1,j,p_ch3cooh )=chem(i,k1,j,p_ch3cooh )+emis*conv + + emis=ch3oh (cat)*fuel_burnt ! emission from fire cell + t_chem(p_ch3oh) = t_chem(p_ch3oh) + emis ! add to total + chem(i,k1,j,p_ch3oh )=chem(i,k1,j,p_ch3oh )+emis*conv + + emis=cres (cat)*fuel_burnt ! emission from fire cell + t_chem(p_cres) = t_chem(p_cres) + emis ! add to total + chem(i,k1,j,p_cres )=chem(i,k1,j,p_cres )+emis*conv + + emis=glyald (cat)*fuel_burnt ! emission from fire cell + t_chem(p_glyald) = t_chem(p_glyald) + emis ! add to total + chem(i,k1,j,p_glyald )=chem(i,k1,j,p_glyald )+emis*conv + + emis=isopr (cat)*fuel_burnt ! emission from fire cell + t_chem(p_isopr) = t_chem(p_isopr) + emis ! add to total + chem(i,k1,j,p_isopr )=chem(i,k1,j,p_isopr )+emis*conv + + emis=macr (cat)*fuel_burnt ! emission from fire cell + t_chem(p_macr) = t_chem(p_macr) + emis ! add to total + chem(i,k1,j,p_macr )=chem(i,k1,j,p_macr )+emis*conv + + emis=mek (cat)*fuel_burnt ! emission from fire cell + t_chem(p_mek) = t_chem(p_mek) + emis ! add to total + chem(i,k1,j,p_mek )=chem(i,k1,j,p_mek )+emis*conv + + emis=mvk (cat)*fuel_burnt ! emission from fire cell + t_chem(p_mvk) = t_chem(p_mvk) + emis ! add to total + chem(i,k1,j,p_mvk )=chem(i,k1,j,p_mvk )+emis*conv + + ! aerosols + ! fuel_burnt kg/m^2 * table g/kg -> ug/kg dry air in 1st layer + + ! see also chem/emissions_driver.F line 515 + + conv = avgw*1e6/(rho(i,k1,j)*dz8w(i,k1,j)) + + emis=p25 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_p25) = t_chem(p_p25) + emis ! add to total + chem(i,k1,j,p_p25 )=chem(i,k1,j,p_p25 )+emis*conv + + emis=p25i (cat)*fuel_burnt ! emission from fire cell + t_chem(p_p25i) = t_chem(p_p25i) + emis ! add to total + chem(i,k1,j,p_p25i )=chem(i,k1,j,p_p25i )+emis*conv + + emis=p25j (cat)*fuel_burnt ! emission from fire cell + t_chem(p_p25j) = t_chem(p_p25j) + emis ! add to total + chem(i,k1,j,p_p25j )=chem(i,k1,j,p_p25j )+emis*conv + + emis=oc1 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_oc1 ) = t_chem(p_oc1 ) + emis ! add to total + chem(i,k1,j,p_oc1 )=chem(i,k1,j,p_oc1 )+emis*conv + + emis=oc2 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_oc2 ) = t_chem(p_oc2 ) + emis ! add to total + chem(i,k1,j,p_oc2 )=chem(i,k1,j,p_oc2 )+emis*conv + + emis=bc1 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_bc1 ) = t_chem(p_bc1 ) + emis ! add to total + chem(i,k1,j,p_bc1 )=chem(i,k1,j,p_bc1 )+emis*conv + + emis=bc2 (cat)*fuel_burnt ! emission from fire cell + t_chem(p_bc2 ) = t_chem(p_bc2 ) + emis ! add to total + chem(i,k1,j,p_bc2 )=chem(i,k1,j,p_bc2 )+emis*conv +#endif + if (num_tracer >0)then + + ! treat tracers exactly the same as aerosols, emissions g/kg fuel burned, tracer concentration ug/kg dry air + conv = avgw*1e6/(rho(i,k1,j)*dz8w(i,k1,j)) + + emis=tr17_1 (cat)*fuel_burnt ! emission from fire cell + t_tracer(p_tr17_1) = t_tracer(p_tr17_1) + emis ! add to total + tracer(i,k1,j,p_tr17_1 )=tracer(i,k1,j,p_tr17_1 )+emis*conv + + emis=tr17_2 (cat)*fuel_burnt ! emission from fire cell + t_tracer(p_tr17_2) = t_tracer(p_tr17_2) + emis ! add to total + tracer(i,k1,j,p_tr17_2 )=tracer(i,k1,j,p_tr17_2 )+emis*conv + + emis=tr17_3 (cat)*fuel_burnt ! emission from fire cell + t_tracer(p_tr17_3) = t_tracer(p_tr17_3) + emis ! add to total + tracer(i,k1,j,p_tr17_3 )=tracer(i,k1,j,p_tr17_3 )+emis*conv + + emis=tr17_4 (cat)*fuel_burnt ! emission from fire cell + t_tracer(p_tr17_4) = t_tracer(p_tr17_4) + emis ! add to total + tracer(i,k1,j,p_tr17_4 )=tracer(i,k1,j,p_tr17_4 )+emis*conv + + emis=tr17_5 (cat)*fuel_burnt ! emission from fire cell + t_tracer(p_tr17_5) = t_tracer(p_tr17_5) + emis ! add to total + tracer(i,k1,j,p_tr17_5 )=tracer(i,k1,j,p_tr17_5 )+emis*conv + + emis=tr17_6 (cat)*fuel_burnt ! emission from fire cell + t_tracer(p_tr17_6) = t_tracer(p_tr17_6) + emis ! add to total + tracer(i,k1,j,p_tr17_6 )=tracer(i,k1,j,p_tr17_6 )+emis*conv + + emis=tr17_7 (cat)*fuel_burnt ! emission from fire cell + t_tracer(p_tr17_7) = t_tracer(p_tr17_7) + emis ! add to total + tracer(i,k1,j,p_tr17_7 )=tracer(i,k1,j,p_tr17_7 )+emis*conv + + emis=tr17_8 (cat)*fuel_burnt ! emission from fire cell + t_tracer(p_tr17_8) = t_tracer(p_tr17_8) + emis ! add to total + tracer(i,k1,j,p_tr17_8 )=tracer(i,k1,j,p_tr17_8 )+emis*conv + endif + enddo + enddo + enddo +enddo + +#ifdef WRF_CHEM +if(fire_print_msg .ge. msglevel .and.printsums .gt. 0)then + ! sum ground concentrations and check for nans + a_chem=0.0 + g_chem=0.0 + errors=0 + do j=jts,jte + do k=1,chem_np + k_p=chem_pointers(k) + do i=its,ite + if(chem(i,k1,j,k_p ).ne.chem(i,k1,j,k_p ))errors=errors+1 + a_chem(k_p)=a_chem(k_p)+chem(i,k1,j,k_p ) + enddo + enddo + enddo + if(errors>0)call crash('NaN after chem update') + call wrf_dm_sum_reals(a_chem,g_chem) + call message('Layer1 raw sums after adding fire emissions',level=msglevel) + do i=1,chem_np,line + m=min(i+line-1,chem_np) + write(msg,80)'Emissions ',(trim(chem_names(j)),j=i,m) + call message(msg,level=msglevel) + write(msg,81)'Layer1 end',(g_chem(chem_pointers(j)),j=i,m) + call message(msg,level=msglevel) + call message(' ',level=msglevel) + enddo +endif +#endif + +if(fire_print_msg .ge. msglevel .and.printsums .gt. 0)then + ! sum over processes and add to cumulative sums + + ! fuel burned + call wrf_dm_sum_reals(t_fuel,s_fuel) + ! scale + s_fuel = s_fuel*dx*dy + ! get rates + r_fuel = s_fuel/dt + ! add to cumulative totals + if(size(c_fuel).ne.nfuelcats)call crash('add_fire_emissions: bad size c_fuel') + c_fuel = c_fuel + s_fuel + +#ifdef WRF_CHEM + call wrf_dm_sum_reals(a_chem,g_chem) + ! chem + call wrf_dm_sum_reals(t_chem,s_chem) + s_chem = s_chem*dx*dy + r_chem = s_chem/dt + if(size(c_chem).ne.num_chem)call crash('add_fire_emissions: bad size c_chem') + c_chem = c_chem + s_chem + + call message('Total emissions in g or mol per the table',level=msglevel) + do i=1,chem_np,line + m=min(i+line-1,chem_np) + write(msg,80)'Emissions ',(trim(chem_names(j)),j=i,m) + call message(msg,level=msglevel) + write(msg,81)'Cumulative',(c_chem(chem_pointers(j)),j=i,m) + call message(msg,level=msglevel) + write(msg,81)'Rate per s',(r_chem(chem_pointers(j)),j=i,m) + call message(msg,level=msglevel) + call message(' ',level=msglevel) + enddo +#endif + + if(num_tracer >0)then + ! tracer + call wrf_dm_sum_reals(t_tracer,s_tracer) + s_tracer = s_tracer*dx*dy + r_tracer = s_tracer/dt + if(size(c_tracer).ne.num_tracer)call crash('add_fire_emissions: bad size c_tracer') + c_tracer = c_tracer + s_tracer + + call message('Total emissions in g',level=msglevel) + do i=1,tracer_np,line + m=min(i+line-1,tracer_np) + write(msg,80)'Emissions ',(trim(tracer_names(j)),j=i,m) + call message(msg,level=msglevel) + write(msg,81)'Cumulative',(c_tracer(tracer_pointers(j)),j=i,m) + call message(msg,level=msglevel) + write(msg,81)'Rate per s',(r_tracer(tracer_pointers(j)),j=i,m) + call message(msg,level=msglevel) + call message(' ',level=msglevel) + enddo + endif + + + do cat=1,nfuelcats + if(c_fuel(cat) > 0.)then + write(msg,83)fuel_name(cat),' burned',c_fuel(cat),'kg, rate',r_fuel(cat),' kg/s' + call message(msg,level=msglevel) + endif + enddo + write(msg,83)'Total fuel',' burned',sum(c_fuel),'kg, rate',sum(r_fuel),' kg/s' + call message(msg,level=msglevel) + +endif +80 format(a,8a11) +81 format(a,8e11.3) +83 format(a30,a,g14.4,a,g14.4,a,a) + +return + +9 continue +!$OMP CRITICAL(SFIRE_ATM_CRIT) +write(msg,91)ifts,ifte,jtfs,jfte,ifms,ifme,jfms,jfme +call message(msg,level=0) +write(msg,91)its,ite,jts,jte,ims,ime,jms,jme +call message(msg,level=0) +write(msg,92)'input mesh size:',isz2,jsz2 +call message(msg,level=0) +91 format('dimensions: ',8i8) +write(msg,92)'output mesh size:',isz1,jsz1 +call message(msg,level=0) +92 format(a,2i8) +!$OMP END CRITICAL(SFIRE_ATM_CRIT) +call crash('add_fire_emissions: bad mesh sizes') + +end subroutine add_fire_emissions + +! +!*** +! + +subroutine check_pointers(array_name,array,pointer_names,pointers) +implicit none + +!*** arguments +character(len=*)::array_name +real, dimension(:,:,:,:)::array +character(len=*), dimension(:)::pointer_names +integer, dimension(:)::pointers + +!*** local +integer::np,i,m,j +character(len=256)::msg + +!** executable +np=ubound(pointers,1) + + +993 format(3a,4(1x,i3,':',i3)) +!$OMP CRITICAL(SFIRE_ATM_CRIT) +write(msg,993)'array ',array_name,' has dimensions ',& + lbound(array,1),ubound(array,1), & + lbound(array,2),ubound(array,2), & + lbound(array,3),ubound(array,3), & + lbound(array,4),ubound(array,4) +call message(msg) + +do i=1,np,line + m=min(i+line-1,np) + write(msg,'(a,8(1x,a8))')'Species',(trim(pointer_names(j)),j=i,m) + call message(msg,level=msglevel) + write(msg,'(a,8i9)') 'Pointer',(pointers(j),j=i,m) + call message(msg,level=msglevel) + call message(' ') +enddo + +if(maxval(pointers) > ubound(array,4) .or. minval(pointers) < lbound(array,4))then + write(msg,'(3a)')'add_fire_emissions: a ',array_name,' pointer is out of bounds' + call crash(msg) +endif +!$OMP END CRITICAL(SFIRE_ATM_CRIT) +end subroutine check_pointers + + +! +!*** +! + + +SUBROUTINE fire_tendency( & + ids,ide, kds,kde, jds,jde, & ! dimensions + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + grnhfx,grnqfx,canhfx,canqfx, & ! heat fluxes summed up to atm grid + alfg,alfc,z1can, & ! coeffients, properties, geometry + zs,z_at_w,dz8w,mu,rho, & + rthfrten,rqvfrten) ! theta and Qv tendencies + +! This routine is atmospheric physics +! it does NOT go into module_fr_sfire_phys because it is not fire physics + +! taken from the code by Ned Patton, only order of arguments change to the convention here +! --- this routine takes fire generated heat and moisture fluxes and +! calculates their influence on the theta and water vapor +! --- note that these tendencies are valid at the Arakawa-A location + + IMPLICIT NONE + +! --- incoming variables + + INTEGER , INTENT(in) :: ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte + + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: grnhfx,grnqfx ! W/m^2 + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: canhfx,canqfx ! W/m^2 + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: zs ! topography (m abv sealvl) + REAL, INTENT(in), DIMENSION( ims:ime,jms:jme ) :: mu ! dry air mass (Pa) + + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: z_at_w ! m abv sealvl + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: dz8w ! dz across w-lvl + REAL, INTENT(in), DIMENSION( ims:ime,kms:kme,jms:jme ) :: rho ! density + + REAL, INTENT(in) :: alfg ! extinction depth ground fire heat (m) + REAL, INTENT(in) :: alfc ! extinction depth crown fire heat (m) + REAL, INTENT(in) :: z1can ! height of crown fire heat release (m) + +! --- outgoing variables + + REAL, INTENT(out), DIMENSION( ims:ime,kms:kme,jms:jme ) :: & + rthfrten, & ! theta tendency from fire (in mass units) + rqvfrten ! Qv tendency from fire (in mass units) +! --- local variables + + INTEGER :: i,j,k + INTEGER :: i_st,i_en, j_st,j_en, k_st,k_en + + REAL :: cp_i + REAL :: rho_i + REAL :: xlv_i + REAL :: z_w + REAL :: fact_g, fact_c + REAL :: alfg_i, alfc_i + + REAL, DIMENSION( its:ite,kts:kte,jts:jte ) :: hfx,qfx + +!! character(len=128)::msg + + + do j=jts,jte + do k=kts,min(kte+1,kde) + do i=its,ite + rthfrten(i,k,j)=0. + rqvfrten(i,k,j)=0. + enddo + enddo + enddo + + +! --- set some local constants + + + cp_i = 1./cp ! inverse of specific heat + xlv_i = 1./xlv ! inverse of latent heat + alfg_i = 1./alfg + alfc_i = 1./alfc + +!!write(msg,'(8e11.3)')cp,cp_i,xlv,xlv_i,alfg,alfc,z1can +!!call message(msg) + + call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,grnhfx,'fire_tendency:grnhfx') + call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,grnqfx,'fire_tendency:grnqfx') + +! --- set loop indicies : note that + + i_st = MAX(its,ids+1) + i_en = MIN(ite,ide-1) + k_st = kts + k_en = MIN(kte,kde-1) + j_st = MAX(jts,jds+1) + j_en = MIN(jte,jde-1) + +! --- distribute fluxes + + DO j = j_st,j_en + DO k = k_st,k_en + DO i = i_st,i_en + + ! --- set z (in meters above ground) + + z_w = z_at_w(i,k,j) - zs(i,j) ! should be zero when k=k_st + + ! --- heat flux + + fact_g = cp_i * EXP( - alfg_i * z_w ) + IF ( z_w < z1can ) THEN + fact_c = cp_i + ELSE + fact_c = cp_i * EXP( - alfc_i * (z_w - z1can) ) + END IF + hfx(i,k,j) = fact_g * grnhfx(i,j) + fact_c * canhfx(i,j) + +!! write(msg,2)i,k,j,z_w,grnhfx(i,j),hfx(i,k,j) +!!2 format('hfx:',3i4,6e11.3) +!! call message(msg) + + ! --- vapor flux + + fact_g = xlv_i * EXP( - alfg_i * z_w ) + IF (z_w < z1can) THEN + fact_c = xlv_i + ELSE + fact_c = xlv_i * EXP( - alfc_i * (z_w - z1can) ) + END IF + qfx(i,k,j) = fact_g * grnqfx(i,j) + fact_c * canqfx(i,j) + +!! if(hfx(i,k,j).ne.0. .or. qfx(i,k,j) .ne. 0.)then +!! write(msg,1)i,k,j,hfx(i,k,j),qfx(i,k,j) +!!1 format('tend:',3i6,2e11.3) +!! call message(msg) +! endif + + END DO + END DO + END DO + +! --- add flux divergence to tendencies +! +! multiply by dry air mass (mu) to eliminate the need to +! call sr. calculate_phy_tend (in dyn_em/module_em.F) + + ! print *,'fire_tendency:',i_st,i_en,j_st,j_en + DO j = j_st,j_en + DO k = k_st,k_en-1 + DO i = i_st,i_en + + rho_i = 1./rho(i,k,j) + + rthfrten(i,k,j) = - mu(i,j) * rho_i * (hfx(i,k+1,j)-hfx(i,k,j)) / dz8w(i,k,j) + rqvfrten(i,k,j) = - mu(i,j) * rho_i * (qfx(i,k+1,j)-qfx(i,k,j)) / dz8w(i,k,j) + + ! print *,i,j,k,rthfrten(i,k,j) + + END DO + END DO + END DO + + call print_3d_stats(its,ite,kts,kte,jts,jte,ims,ime,kms,kme,jms,jme,rthfrten,'fire_tendency:rthfrten') + call print_3d_stats(its,ite,kts,kte,jts,jte,ims,ime,kms,kme,jms,jme,rqvfrten,'fire_tendency:rqvfrten') + + RETURN + +END SUBROUTINE fire_tendency + +! +!*** +! +subroutine interpolate_atm2fire(id, & ! for debug output, <= 0 no output + ids,ide, kds,kde, jds,jde, & ! atm grid dimensions + ims,ime, kms,kme, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifps, ifpe, jfps, jfpe, & ! fire patch bounds + ifts,ifte,jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + u_frame, v_frame, & ! velocity frame correction + u,v, & ! atm grid arrays in + ph,phb, & + z0,zs, & + uah,vah, & + uf,vf) ! fire grid arrays out + +implicit none +! Jan Mandel, October 2010 +!*** purpose: interpolate winds and height + +!*** arguments +integer, intent(in)::id +integer, intent(in):: & + ids,ide, kds,kde, jds,jde, & ! atm domain bounds + ims,ime, kms,kme, jms,jme, & ! atm memory bounds + ips,ipe,jps,jpe, & + its,ite,jts,jte, & ! atm tile bounds + ifds, ifde, jfds, jfde, & ! fire domain bounds + ifms, ifme, jfms, jfme, & ! fire memory bounds + ifps, ifpe, jfps, jfpe, & ! fire patch bounds + ifts,ifte,jfts,jfte, & ! fire tile bounds + ir,jr ! atm/fire grid refinement ratio +real, intent(in):: u_frame, v_frame ! velocity frame correction +real,intent(in),dimension(ims:ime,kms:kme,jms:jme)::& + u,v, & ! atm wind velocity, staggered + ph,phb ! geopotential +real,intent(in),dimension(ims:ime,jms:jme)::& + z0, & ! roughness height + zs ! terrain height +real,intent(out),dimension(ims:ime,jms:jme)::& + uah, & ! atm wind at fire_wind_height, diagnostics + vah ! +real,intent(out), dimension(ifms:ifme,jfms:jfme)::& + uf,vf ! wind velocity fire grid nodes + + +!*** local +character(len=256)::msg +#define TDIMS its-2,ite+2,jts-2,jte+2 +real, dimension(its-2:ite+2,jts-2:jte+2):: ua,va ! atm winds, interpolated over height, still staggered grid +real, dimension(its-2:ite+2,kds:kde,jts-2:jte+2):: altw,altub,altvb,hgtu,hgtv ! altitudes +integer:: i,j,k,ifts1,ifte1,jfts1,jfte1,ite1,jte1 +integer::itst,itet,jtst,jtet,itsu,iteu,jtsu,jteu,itsv,itev,jtsv,jtev +integer::kdmax,its1,jts1,ips1,jps1 +integer::itsou,iteou,jtsou,jteou,itsov,iteov,jtsov,jteov +real:: ground,loght,loglast,logz0,logfwh,ht,zr +real::r_nan +integer::i_nan +equivalence (i_nan,r_nan) + +!*** executable + +! debug init local arrays +i_nan=2147483647 +ua=r_nan +va=r_nan +altw=r_nan +altub=r_nan +hgtu=r_nan +hgtv=r_nan + + +if(kds.ne.1)then +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) + write(msg,*)'WARNING: bottom index kds=',kds,' should be 1?' + call message(msg) +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) +endif + +! ^ j +! ------------ | +! | | ----> i +! u p | +! | | nodes in cell (i,j) +! ------v----- view from top +! +! v(ide,jde+1) +! -------x------ +! | | +! | | +! u(ide,jde) x x x u(ide+1,jde) +! | p(ide,hde) | +! | | p=ph,phb,z0,... +! -------x------ +! v(ide,jde) +! +! staggered values set u(ids:ide+1,jds:jde) v(ids:ide,jds:jde+1) +! p=ph+phb set at (ids:ide,jds:jde) +! location of u(i,j) needs p(i-1,j) and p(i,j) +! location of v(i,j) needs p(i,j-1) and p(i,j) +! *** NOTE need HALO in ph, phb +! so we can compute only u(ids+1:ide,jds:jde) v(ids:ide,jds+1,jde) +! unless we extend p at the boundary +! but because we care about the fire way in the inside it does not matter +! if the fire gets close to domain boundary the simulation is over anyway + + ite1=snode(ite,ide,1) + jte1=snode(jte,jde,1) + ! do this in any case to check for nans + ! TGIANNAROS +! print*, 'Before stopping?' + call print_3d_stats(its,ite1,kds,kde,jts,jte,ims,ime,kms,kme,jms,jme,u,'wind U in') + call print_3d_stats(its,ite,kds,kde,jts,jte1,ims,ime,kms,kme,jms,jme,v,'wind V in') + + if(fire_print_msg.gt.0)then +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) + write(msg,'(a,f7.2,a)')'interpolate_atm2fire: log-interpolation of wind to',fire_wind_height,' m' + call message(msg) +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) + endif + +! indexing + +! for w + itst=ifval(ids.eq.its,its,its-1) + itet=ifval(ide.eq.ite,ite,ite+1) + jtst=ifval(jds.ge.jts,jts,jts-1) + jtet=ifval(jde.eq.jte,jte,jte+1) + +! for u + itsu=ifval(ids.eq.its,its+1,its) ! staggered direction + iteu=ifval(ide.eq.ite,ite,ite+1) ! staggered direction + jtsu=ifval(jds.ge.jts,jts,jts-1) + jteu=ifval(jde.eq.jte,jte,jte+1) + +! for v + jtsv=ifval(jds.eq.jts,jts+1,jts) ! staggered direction + jtev=ifval(jde.eq.jte,jte,jte+1) ! staggered direction + itsv=ifval(ids.ge.its,its,its-1) + itev=ifval(ide.eq.ite,ite,ite+1) + + +if(fire_print_msg.ge.1)then +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) + write(msg,7001)'atm input ','tile',its,ite,jts,jte + call message(msg) + write(msg,7001)'altw ','tile',itst,itet,jtst,jtet + call message(msg) +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) +endif +7001 format(a,' dimensions ',a4,':',i6,' to ',i6,' by ',i6,' to ',i6) + +!********************************************************** +!* * +!* find the altitude of the w points * +!* * +!********************************************************** +!! in future, replace by z8w & test if the same + + kdmax=kde-1 ! max layer to interpolate from, can be less + + do j = jtst,jtet + do k=kds,kdmax+1 + do i = itst,itet + altw(i,k,j) = (ph(i,k,j)+phb(i,k,j))/g ! altitude of the bottom w-point + enddo + enddo + enddo + +! values at u points +if(fire_print_msg.ge.1)then +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) + write(msg,7001)'u interp at','tile',itsu,iteu,jtsu,jteu + call message(msg) +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) +endif + +!********************************************************** +!* * +!* interpolate the altitude from w points to u points * +!* * +!********************************************************** + + do j = jtsu,jteu + do k=kds,kdmax+1 + do i = itsu,iteu + altub(i,k,j)= 0.5*(altw(i-1,k,j)+altw(i,k,j)) ! altitude of the bottom point under u-point + enddo + enddo + do k=kds,kdmax + do i = itsu,iteu + hgtu(i,k,j) = 0.5*(altub(i,k,j)+altub(i,k+1,j)) - altub(i,kds,j) ! height of the u-point above the ground + enddo + enddo + enddo + +! values at v points +if(fire_print_msg.ge.1)then +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) + write(msg,7001)'v interp at','tile',itsv,itev,jtsv,jtev + call message(msg) +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) +endif + +!********************************************************** +!* * +!* interpolate the altitude from w points to v points * +!* * +!********************************************************** + + do j = jtsv,jtev + do k=kds,kdmax+1 + do i = itsv,itev + altvb(i,k,j)= 0.5*(altw(i,k,j-1)+altw(i,k,j)) ! altitude of the bottom point under v-point + enddo + enddo + do k=kds,kdmax + do i = itsv,itev + hgtv(i,k,j) = 0.5*(altvb(i,k,j)+altvb(i,k+1,j)) - altvb(i,kds,j) ! height of the v-point above the ground + enddo + enddo + enddo + +#ifdef DEBUG_OUT + call write_array_m3(itsu,iteu,kds,kdmax,jtsu,jteu,its-2,ite+2,kds,kde,jts-2,jte+2,altub,'altub',id) + call write_array_m3(itsv,itev,kds,kdmax,jtsv,jtev,its-2,ite+2,kds,kde,jts-2,jte+2,altvb,'altvb',id) + call write_array_m3(itsu,iteu,kds,kdmax,jtsu,jteu,its-2,ite+2,kds,kde,jts-2,jte+2,hgtu,'hgtu',id) + call write_array_m3(itsv,itev,kds,kdmax,jtsv,jtev,its-2,ite+2,kds,kde,jts-2,jte+2,hgtv,'hgtv',id) +#endif + + logfwh = log(fire_wind_height) + +!********************************************************** +!* * +!* interpolate u vertically to fire_wind_height * +!* * +!********************************************************** + + ! interpolate u, staggered in X + + do j = jtsu,jteu ! compute on domain by 1 smaller, otherwise z0 and ph not available + do i = itsu,iteu ! compute with halo 2 + zr = 0.5*(z0(i,j)+z0(i-1,j)) ! interpolated roughness length under this u point + if(fire_wind_height > zr)then ! + do k=kds,kdmax + ht = hgtu(i,k,j) ! height of this u point above the ground + if( .not. ht < fire_wind_height) then ! found layer k this point is in + loght = log(ht) + if(k.eq.kds)then ! first layer, log linear interpolation from 0 at zr + logz0 = log(zr) + ua(i,j)= u(i,k,j)*(logfwh-logz0)/(loght-logz0) + else ! log linear interpolation + loglast=log(hgtu(i,k-1,j)) + ua(i,j)= u(i,k-1,j) + (u(i,k,j) - u(i,k-1,j)) * ( logfwh - loglast) / (loght - loglast) + endif + goto 10 + endif + if(k.eq.kdmax)then ! last layer, still not high enough + ua(i,j)=u(i,k,j) + endif + enddo +10 continue + else ! roughness higher than the fire wind height + ua(i,j)=0. + endif + enddo + enddo + + +!********************************************************** +!* * +!* interpolate v vertically to fire_wind_height * +!* * +!********************************************************** + + ! interpolate v, staggered in Y + + do j = jtsv,jtev + do i = itsv,itev + zr = 0.5*(z0(i,j-1)+z0(i,j)) ! roughness length under this v point + if(fire_wind_height > zr)then ! + do k=kds,kdmax + ht = hgtv(i,k,j) ! height of this u point above the ground + if( .not. ht < fire_wind_height) then ! found layer k this point is in + loght = log(ht) + if(k.eq.kds)then ! first layer, log linear interpolation from 0 at zr + logz0 = log(zr) + va(i,j)= v(i,k,j)*(logfwh-logz0)/(loght-logz0) + else ! log linear interpolation + loglast=log(hgtv(i,k-1,j)) + va(i,j)= v(i,k-1,j) + (v(i,k,j) - v(i,k-1,j)) * ( logfwh - loglast) / (loght - loglast) + endif + goto 11 + endif + if(k.eq.kdmax)then ! last layer, still not high enough + va(i,j)=v(i,k,j) + endif + enddo +11 continue + else ! roughness higher than the fire wind height + va(i,j)=0. + endif + enddo + enddo + +#ifdef DEBUG_OUT +! store the output for diagnostics + do j = jts,jte1 + do i = its,ite1 + uah(i,j)=ua(i,j) + vah(i,j)=va(i,j) + enddo + enddo + + call write_array_m(its,ite1,jts,jte,ims,ime,jms,jme,uah,'uah_n',id) ! no reflection + call write_array_m(its,ite,jts,jte1,ims,ime,jms,jme,vah,'vah_n',id) +#endif + +!********************************************************** +!* * +!* interpolate ua,va vertically to the fire mesh * +!* * +!********************************************************** + + + ips1 = ifval(ips.eq.ids,ips+1,ips) + call continue_at_boundary(1,1,0., & ! x direction + TDIMS, &! memory dims atm grid tile + ids+1,ide,jds,jde, & ! domain dims - where u defined + ips1,ipe,jps,jpe, & ! patch dims + itsu,iteu,jtsu,jteu, & ! tile dims - in nonextended direction one beyond if at patch boundary but not domain + itsou,iteou,jtsou,jteou, & ! out, where set + ua) ! array + + jps1 = ifval(jps.eq.jds,jps+1,jps) + call continue_at_boundary(1,1,0., & ! y direction + TDIMS, & ! memory dims atm grid tile + ids,ide,jds+1,jde, & ! domain dims - where v wind defined + ips,ipe,jps1,jpe, & ! patch dims + itsv,itev,jtsv,jtev, & ! tile dims + itsov,iteov,jtsov,jteov, & ! where set + va) ! array + +! store the output for diagnostics + do j = jts,jte1 + do i = its,ite1 + uah(i,j)=ua(i,j) + vah(i,j)=va(i,j) + enddo + enddo + +#ifdef DEBUG_OUT + call write_array_m(itsou,iteou,jtsou,jteou,TDIMS,ua,'ua',id) + call write_array_m(itsov,iteov,jtsov,jteov,TDIMS,va,'va',id) +#endif + +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) + ! don't have all values valid, don't check + write(msg,12)'atm mesh wind U at',fire_wind_height,' m' + call print_2d_stats(itsou,iteou,jtsou,jteou,TDIMS,ua,msg) + write(msg,12)'atm mesh wind V at',fire_wind_height,' m' + call print_2d_stats(itsov,iteov,jtsov,jteov,TDIMS,va,msg) +12 format(a,f6.2,a) + call print_2d_stats(its,ite1,jts,jte,ims,ime,jms,jme,uah,'UAH') + call print_2d_stats(its,ite,jts,jte1,ims,ime,jms,jme,vah,'VAH') + !call write_array_m(its,ite1,jts,jte,ims,ime,jms,jme,uah,'uah',id) + !call write_array_m(its,ite,jts,jte1,ims,ime,jms,jme,vah,'vah',id) +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) + +! --------------- +! | F | F | F | F | Example of atmospheric and fire grid with +! |-------|-------| ir=jr=4. +! | F | F | F | F | Winds are given at the midpoints of the sides of the atmosphere grid, +! ua------z-------| interpolated to midpoints of the cells of the fine fire grid F. +! | F | F | F | F | This is (1,1) cell of atmosphere grid, and [*] is the (1,1) cell of the fire grid. +! |---------------| ua(1,1) <--> uf(0.5,2.5) +! | * | F | F | F | va(1,1) <--> vf(2.5,0.5) +! -------va------ za(1,1) <--> zf(2.5,2.5) +! +! ^ x2 +! | --------va(1,2)--------- +! | | | | Example of atmospheric and fire grid with +! | | | | ir=jr=1. +! | | za,zf | Winds are given at the midpoints of the sides of the atmosphere grid, +! | ua(1,1)----uf,vf-----ua(2,1) interpolated to midpoints of the cells of the (the same) fire grid +! | | (1,1) | ua(1,1) <--> uf(0.5,1) +! | | | | va(1,1) <--> vf(1,0.5) +! | | | | za(1,1) <--> zf(1,1) +! | --------va(1,1)--------- +! |--------------------> x1 +! +! Meshes are aligned by the lower left cell of the domain. Then in the above figure +! u = node with the ua component of the wind at (ids,jds), midpoint of side +! v = node with the va component of the wind at (ids,jds), midpoint of side +! * = fire grid node at (ifds,jfds) +! z = node with height, midpoint of cell +! +! ua(ids,jds)=uf(ifds-0.5,jfds+jr*0.5-0.5) = uf(ifds-0.5,jfds+(jr-1)*0.5) +! va(ids,jds)=vf(ifds+ir*0.5-0.5,jfds-0.5) = vf(ifds+(ir-1)*0.5,jfds-0.5) +! za(ids,jds)=zf(ifds+ir*0.5-0.5,jfds+jr*0.5-0.5) = zf(ifds+(ir-1)*0.5,jfds+(jr-1)*0.5) + + ! ifts1=max(snode(ifts,ifps,-1),ifds) ! go 1 beyond patch boundary but not at domain boundary + ! ifte1=min(snode(ifte,ifpe,+1),ifde) + ! jfts1=max(snode(jfts,jfps,-1),jfds) + ! jfte1=min(snode(jfte,jfpe,+1),jfde) + + call interpolate_2d( & + TDIMS, & ! memory dims atm grid tile + itsou,iteou,jtsou,jteou,& ! where set + ifms,ifme,jfms,jfme, & ! array dims fire grid + ifts,ifte,jfts,jfte,& ! dimensions on the fire grid to interpolate to + ir,jr, & ! refinement ratio + real(ids),real(jds),ifds-0.5,jfds+(jr-1)*0.5, & ! line up by lower left corner of domain + ua, & ! in atm grid + uf) ! out fire grid + + call interpolate_2d( & + TDIMS, & ! memory dims atm grid tile + itsov,iteov,jtsov,jteov,& ! where set + ifms,ifme,jfms,jfme, & ! array dims fire grid + ifts,ifte,jfts,jfte,& ! dimensions on the fire grid to interpolate to + ir,jr, & ! refinement ratio + real(ids),real(jds),ifds+(ir-1)*0.5,jfds-0.5, & ! line up by lower left corner of domain + va, & ! in atm grid + vf) ! out fire grid + +call print_2d_stats_vec(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,uf,vf,'fire wind (m/s)') +! call print_2d_stats_vec(ifts1,ifte1,jfts1,jfte1,ifms,ifme,jfms,jfme,uf,vf,'fire wind extended') +#ifdef DEBUG_OUT + call write_array_m(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,uf,'uf1',id) + call write_array_m(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,vf,'vf1',id) + ! call write_array_m(ifts1,ifte1,jfts1,jfte1,ifms,ifme,jfms,jfme,uf,'uf1',id) + ! call write_array_m(ifts1,ifte1,jfts1,jfte1,ifms,ifme,jfms,jfme,vf,'vf1',id) +#endif + +return + +end subroutine interpolate_atm2fire + +subroutine apply_windrf( & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + nfuel_cat,uf,vf) +integer:: & + ifms, ifme, jfms, jfme, & ! fire memory bounds + ifts, ifte, jfts, jfte ! fire tile bounds +real,intent(in),dimension(ifms:ifme,jfms:jfme)::nfuel_cat +real,intent(inout),dimension(ifms:ifme,jfms:jfme)::uf,vf +!*** local + integer::i,j,k +!*** executable + + do j = jfts,jfte + do i = ifts,ifte + k=int( nfuel_cat(i,j) ) + if(k.lt.no_fuel_cat)then + uf(i,j)=uf(i,j)*windrf(k) + vf(i,j)=vf(i,j)*windrf(k) + else + uf(i,j)=0. + vf(i,j)=0. + endif + enddo + enddo + +end subroutine apply_windrf + +! +!*** +! + +subroutine setup_wind_log_interpolation( & + ids,ide, jds,jde, & ! atm grid dimensions + ims,ime, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifts, ifte, jfts, jfte, & + ir,jr, & ! atm/fire grid ratio + z0, & ! atm grid arrays in + nfuel_cat, & ! fire array in + fz0,fwh) ! fire arrays out +!*** arguments +integer, intent(in):: & + ids,ide, jds,jde, & ! atm domain bounds + ims,ime, jms,jme, & ! atm memory bounds + ips,ipe,jps,jpe, & + its,ite,jts,jte, & ! atm tile bounds + ifds, ifde, jfds, jfde, & ! fire domain bounds + ifms, ifme, jfms, jfme, & ! fire memory bounds + ifts, ifte, jfts, jfte, & ! fire tile bounds + ir,jr ! atm/fire grid refinement ratio +real,intent(in),dimension(ims:ime,jms:jme)::z0 ! landuse roughness length +real,intent(in),dimension(ifms:ifme,jfms:jfme)::nfuel_cat ! fuel category +real,intent(out),dimension(ifms:ifme,jfms:jfme)::& + fz0, & ! roughness height + fwh ! height to read the wind from +!*** local +integer::i,j,ii,jj,k,id=0 +character(len=128)::msg +real::r +!*** executable + + if(.not.have_fuel_cats)call crash('setup_wind_log_interpolation: fuel categories not yet set') + + select case(fire_wind_log_interp) + + case(1) + call message('fire_wind_log_interp=1: log interpolation on fire mesh, roughness and wind height from fuel categories') + do j=jfts,jfte + do i=ifts,ifte + k = int(nfuel_cat(i,j)) + if(k.ge.no_fuel_cat.and.k.le.no_fuel_cat2)then ! no fuel + fz0(i,j)=-1. + fwh(i,j)=-1. + elseif(k < 1 .or. k > nfuelcats) then +!$OMP CRITICAL(SFIRE_ATM_CRIT) + write(msg,*)'i,j,nfuel_cat,nfuelcats=',i,j,k,nfuelcats +!$OMP END CRITICAL(SFIRE_ATM_CRIT) + call message(msg) + call crash('setup_wind_log_interpolation: fuel category out of bounds') + else + fz0(i,j)=fcz0(k) + fwh(i,j)=fcwh(k) + endif + enddo + enddo + + case(2) + call message('fire_wind_log_interp=2: log interpolation on fire mesh' // & + 'piecewise constant roughness from landuse, constant fire_wind_height') + do j=jts,jte + do i=its,ite + do jj=(j-1)*jr+1,(j-1)*jr+jr + do ii=(i-1)*ir+1,(i-1)*ir+ir + fz0(ii,jj)=z0(i,j) + enddo + enddo + enddo + enddo + do j=jfts,jfte + do i=ifts,ifte + k = int(nfuel_cat(i,j)) + if(k.lt.no_fuel_cat)then ! no fuel, interpolation does not matter + fwh(i,j)=fcwh(k) + else + fz0(i,j)=-1. + fwh(i,j)=-1. + endif + enddo + enddo + + case(3) + call message('fire_wind_log_interp=3: log interpolation on fire mesh,' // & + ' interpolated roughness from landuse, constant fire_wind_height') + call interpolate_z2fire(id,1, & ! for debug output, <= 0 no output + ids,ide, jds,jde, & ! atm grid dimensions + ims,ime, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifts,ifte,jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + z0, & ! atm grid arrays in + fz0) ! fire grid arrays out + do j=jfts,jfte + do i=ifts,ifte + k = int(nfuel_cat(i,j)) + if(k.ne.no_fuel_cat)then ! no fuel, interpolation does not matter + fwh(i,j)=fcwh(k) + else + fz0(i,j)=-1. + fwh(i,j)=-1. + endif + enddo + enddo + + case(4) + call message('fire_wind_log_interp=4: log interpolation on atmospheric' // & + ' mesh, roughness from landuse, constant fire_wind_height') + return + + case default + !$OMP CRITICAL(SFIRE_ATM_CRIT) + write(msg,*)'setup_wind_log_interpolation: invalid fire_wind_log_interp=',fire_wind_log_interp + !$OMP END CRITICAL(SFIRE_ATM_CRIT) + call crash('msg') + + end select + + select case(fire_use_windrf) + + case(0) + call message('setup_wind_log_interpolation: not using wind reduction factors') + + case(1) + call message('setup_wind_log_interpolation: multiplying wind by reduction factors') + + case(2) + call message('setup_wind_log_interpolation: resetting wind interpolation height from wind reduction factors') + do j=jfts,jfte + do i=ifts,ifte + k = int(nfuel_cat(i,j)) + if(k.ne.no_fuel_cat)then + fwh(i,j) = fz0(i,j) ** (1.-windrf(k)) * fire_wind_height ** windrf(k) ! GMD paper eq. (26) + + if (.not. fz0(i,j) > 0. .or. .not. fwh(i,j) > fz0(i,j))then +!$OMP CRITICAL(SFIRE_ATM_CRIT) + write(msg,*)'category ',k,'windrf=',windrf(k),' fire_wind_height=',fire_wind_height + call message(msg,level=-1) + write(msg,*)'i=',i,' j=',j,' fz0(i,j)=',fz0(i,j),' fwh(i,j)=',fwh(i,j) + call message(msg,level=-1) +!$OMP END CRITICAL(SFIRE_ATM_CRIT) + call crash('setup_wind_log_interpolation: must have fwh > fz0 > 0') + endif + + endif + enddo + enddo + + case(3) + if(fire_wind_log_interp.eq.2.or.fire_wind_log_interp.eq.3)then + call message('setup_wind_log_interpolation: adjusting wind interpolation height for LANDUSE roughness height') + do j=jfts,jfte + do i=ifts,ifte + k = int(nfuel_cat(i,j)) + if(k.lt.no_fuel_cat)then + r = log(fcwh(k)/fcz0(k))/log(fire_wind_height/fcz0(k))! GMD paper eq. (25) + fwh(i,j) = fz0(i,j) ** (1.-r) * fire_wind_height ** r ! GMD paper eq. (26) + + if (.not. fz0(i,j) > 0. .or. .not. fwh(i,j) > fz0(i,j))then +!$OMP CRITICAL(SFIRE_ATM_CRIT) + write(msg,*)'category ',k, 'roughness ',fcz0(k),' midflame height ',fcwh(k),' fire_wind_height=',fire_wind_height + call message(msg,level=-1) + write(msg,*)'computed wind reduction factor ',r + call message(msg,level=-1) + write(msg,*)'i=',i,' j=',j,' fz0(i,j)=',fz0(i,j),' fwh(i,j)=',fwh(i,j) + call message(msg,level=-1) +!$OMP END CRITICAL(SFIRE_ATM_CRIT) + call crash('setup_wind_log_interpolation: must have fwh > fz0 > 0') + endif + + endif + enddo + enddo + else + call message('setup_wind_log_interpolation: not using wind reduction factors') + endif + + case default + !$OMP CRITICAL(SFIRE_ATM_CRIT) + write(msg,*)'setup_wind_log_interpolation: invalid fire_use_windrf=',fire_use_windrf + !$OMP END CRITICAL(SFIRE_ATM_CRIT) + call crash('msg') + + end select + +! consistency check + do j=jfts,jfte + do i=ifts,ifte + k = int(nfuel_cat(i,j)) + if(k.lt.no_fuel_cat)then + if (.not. fz0(i,j) > 0. .or. .not. fwh(i,j) > fz0(i,j))then +!$OMP CRITICAL(SFIRE_ATM_CRIT) + write(msg,*)'i=',i,' j=',j,' fz0(i,j)=',fz0(i,j),' fwh(i,j)=',fwh(i,j) + call message(msg,level=-1) +!$OMP END CRITICAL(SFIRE_ATM_CRIT) + call crash('setup_wind_log_interpolation: must have fwh > fz0 > 0') + endif + else + if(.not.fwh(i,j)<0.)then +!$OMP CRITICAL(SFIRE_ATM_CRIT) + write(msg,*)'i=',i,' j=',j,' fz0(i,j)=',fz0(i,j),' fwh(i,j)=',fwh(i,j) + call message(msg,level=-1) +!$OMP END CRITICAL(SFIRE_ATM_CRIT) + call crash('setup_wind_log_interpolation: no fuel must be signalled by fwh<0') + endif + endif + enddo + enddo + + have_wind_log_interpolation = .true. + + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fz0,'setup_wind_log:fz0') + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fz0,'setup_wind_log:fwh') + +end subroutine setup_wind_log_interpolation + +! +!*** +! + +subroutine interpolate_wind2fire_height(id, & ! to identify debugging prints and files if needed + ids,ide, kds,kde, jds,jde, & ! atm grid dimensions + ims,ime, kms,kme, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifps, ifpe, jfps, jfpe, & ! fire patch bounds + ifts,ifte,jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + u_frame, v_frame, & ! velocity frame correction + u,v,ph,phb, & ! input atmospheric arrays + fz0,fwh, & ! input fire arrays + uf,vf) ! output fire arrays + + implicit none +!*** arguments +integer, intent(in):: id, & ! debug identification + ids,ide, kds,kde, jds,jde, & ! atm domain bounds + ims,ime, kms,kme, jms,jme, & ! atm memory bounds + ips,ipe,jps,jpe, & + its,ite,jts,jte, & ! atm tile bounds + ifds, ifde, jfds, jfde, & ! fire domain bounds + ifms, ifme, jfms, jfme, & ! fire memory bounds + ifps, ifpe, jfps, jfpe, & ! fire patch bounds + ifts,ifte,jfts,jfte, & ! fire tile bounds + ir,jr ! atm/fire grid refinement ratio +real, intent(in):: u_frame, v_frame ! velocity frame correction +real,intent(in),dimension(ims:ime,kms:kme,jms:jme)::& + u,v, & ! atm wind velocity, staggered + ph,phb ! geopotential +real,intent(in),dimension(ifms:ifme,jfms:jfme)::& + fz0, & ! roughness height + fwh ! height to read the wind from +real,intent(out),dimension(ifms:ifme,jfms:jfme)::& + uf, & ! atm wind at fire_wind_height, diagnostics + vf ! + +!*** local + integer:: i,j,k,jcb,jcm,icb,icm,kdmax,kmin,kmax + integer::itst,itet,jtst,jtet + integer::iftst,iftet,jftst,jftet + real:: wjcb,wjcm,wicb,wicm,ht,i_g,loght,zr,ht_last,logwh,wh,loght_last,uk,vk,uk1,vk1,z0,logz0 + real, dimension (its-1:ite+1,kds:kde,jts-1:jte+1):: z + character(len=128)::msg + +!*** executable + + if(.not. have_wind_log_interpolation) call crash('interpolate_wind2fire_height: wind_log_interpolation must be set up first') + + ! print *,'interpolate_wind2fire_height start, id=',id + + kdmax=kde-1 ! max layer to use + +! find the altitude of atm cell centers + +! index bounds for cell centers - need to go one beyond if at end of tile but not domain + itst=ifval(ids.eq.its,its,its-1) + itet=ifval(ide.eq.ite,ite,ite+1) + jtst=ifval(jds.ge.jts,jts,jts-1) + jtet=ifval(jde.eq.jte,jte,jte+1) + + ! print *,'its, ite, jts, jte =',its, ite, jts, jte + ! print *,'itst, itet, jtst, jtet=',itst, itet, jtst, jtet + +! get altitudes + i_g = 1./g + do j = jtst,jtet + do k=kds,kdmax+1 + do i = itst,itet + z(i,k,j) = (ph(i,k,j)+phb(i,k,j))*i_g ! altitude of the bottom w-point + + ! print *,'i,k,j=',i,k,j,'ph, phb, z=',ph(i,k,j),phb(i,k,j),z(i,k,j) + + enddo + enddo + do k=kds,kdmax + do i = itst,itet + z(i,k,j) = (z(i,k,j)+z(i,k+1,j))*0.5 - z(i,kds,j) ! height of the cell center + enddo + enddo + enddo + +! index bounds for fire mesh cell centers +! to prevent setting values from uninitialized memory + iftst=ifval(ifds.eq.ifts,ifts+ir/2,ifts) + iftet=ifval(ifde.eq.ifte,ifte-ir/2,ifte) + jftst=ifval(jfds.ge.jfts,jfts+jr/2,jfts) + jftet=ifval(jfde.eq.jfte,jfte-jr/2,jfte) + + ! print *,'iftst, iftet, jftst, jftet=',iftst, iftet, jftst, jftet + +! zero out first, to prevent unitialized values on strips along domain boundaries +! it would be faster but longer code to do just cleanup loop on the strips + do j = jfts,jfte + do i = ifts,ifte + uf(i,j)=0. + vf(i,j)=0. + enddo + enddo + +! vertical and horizontal interpolation + + kmin=kde ! init stats + kmax=kds + + loop_j: do j = jftst,jftet + call coarse(j,jr,-2,jcb,wjcb) ! get interpolation coefficients from the boundary + call coarse(j,jr,ir,jcm,wjcm) ! get interpolation coefficients from the midpoint + loop_i: do i = iftst,iftet + call coarse(i,ir,-2,icb,wicb) ! get interpolation coefficients from the boundary + call coarse(i,ir,ir,icm,wicm) ! get interpolation coefficients from the midpoint + z0 = fz0(i,j) ! roughness length + wh = fwh(i,j) ! wind height + + ! print *,'i=',i,' j=',j,' icb=',icb,' jcb=',jcb,' z0=',z0,' wh=',wh + + + if( wh > z0 .and. z0 > 0)then + + ht_last=z0 ! initialize starting height of this layer + loop_k: do k=kds,kdmax ! search for layer k such that ht(k-1)<=wh roughness height > 0') + +contains + +real function interpolate_h(ims,ime,kms,kme,jms,jme,ic,kc,jc,wic,wjc,a) +!*** purpose: bilinear interpolation from a(ic:ic+1,k,jc:jc+1) with weights wicm wjcm + implicit none +!*** arguments + integer, intent(in)::ims,ime,jms,kms,kme,jme,ic,kc,jc + real, intent(in)::wic,wjc,a(ims:ime,kms:kme,jms:jme) +!*** executable + interpolate_h = & + a(ic,kc,jc) *wic *wjc + & + a(ic,kc,jc+1) *wic *(1.-wjc) + & + a(ic+1,kc,jc) *(1.-wic)*wjc + & + a(ic+1,kc,jc+1)*(1.-wic)*(1.-wjc) +end function interpolate_h + + +subroutine coarse(ix,nr,ia,ic,w) +!*** find coarse mesh index and interpolation weight +!*** arguments + implicit none + integer, intent(in)::ix,nr,ia + integer, intent(out)::ic + real, intent(out)::w +!*** description +! given fine mesh with nr cells for each coarse mesh cell and such that +! coarse mesh node 1 is aligned with the fine mesh at (na+1)/2 +! for fine mesh node ix find its coarse mesh coordinate c and return +! ic=floor(c), the index of the nearest coarse mesh node below +! w =1-(c-ic), the interpolation weight from coarse mesh node ic to fine mesh node ix +! +! Intended use: +! fine mesh nodes are always at the middle of their cells +! +! the alignment when the coarse nodes are on the boundary of coarse cells: +! |---1---|---2---|.......|--nr---| fine mesh +! 1-------------------------------2 coarse mesh +! ia = -2 because coarse node 1 is aligned with the fine mesh at -1/2 = (-2 + 1)/2 +! +! the alignment when the coarse node is at the midpoint of coarse cell: +! |---1---|---2---|---3---|---4---| fine mesh, here nr=4 +! |---------------1---------------| coarse mesh +! ia = nr because coarse node 1 is aligned with the fine mesh at (nr + 1)/2 +! here, (4 + 1)/2 = 2.5 +! + +!*** local + real:: c,a + +!*** executable + + a = (ia + 1)*0.5 ! the location on the fine grid where coarse node 1 is aligned + c = 1 + (ix - a)/nr ! coarse mesh coordinate of ix + ic= floor(c) ! nearest coarse node to the left + w = (1 + ic) - c ! interpolation weight, 1-(c-ic) + +end subroutine coarse + +end subroutine interpolate_wind2fire_height + +!#ifdef WRF_CHEM +subroutine fire_emission( & + tracer_opt, & + ids,ide, kds,kde, jds,jde, & ! domain dimensions + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & + rho,dz8w, & + grnhfx, & ! input variables from fire model + tracer ) ! output emissions array +use module_state_description , only: num_tracer, p_tr17_1 +#ifdef WRF_CHEM +use module_state_description , only: p_smoke +#endif + integer, intent(in)::tracer_opt + INTEGER , INTENT(in) :: ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte + + real,intent(in),dimension( ims:ime,jms:jme ) :: grnhfx + real,intent(inout),dimension( ims:ime,kms:kme,jms:jme,num_tracer ) :: tracer + real,intent(in),dimension( ims:ime,kms:kme,jms:jme ) :: rho,dz8w + + integer::i,j,k,l + character(len=128)::msg + real::t,s + + ! just a dumb placeholder + k=kds ! dump into surface layer + + select case(tracer_opt) + case(0) + return ! no tracers + case(1) +#ifdef WRF_CHEM + l=p_smoke +#else + call crash('fire_emission: tracer_opt=1 requires WRF-Chem') +#endif + case(2) + l=p_tr17_1 + case default + call crash('fire_emission: tracer_opt not supported') + end select + + if(num_tracer= 1)then + write(msg,'(a,4i6,a,e13.4,a,i4)')'Tile ',its,ite,jts,jte,' added ',s,' total to tracer',l + call message(msg,level=0) + endif +!$OMP END CRITICAL(SFIRE_ATM_CRIT) +end subroutine fire_emission +!#endif + + +end module module_fr_sfire_atm diff --git a/wrfv2_fire/phys/module_fr_sfire_core.F b/wrfv2_fire/phys/module_fr_sfire_core.F new file mode 100644 index 00000000..2e091d5c --- /dev/null +++ b/wrfv2_fire/phys/module_fr_sfire_core.F @@ -0,0 +1,2290 @@ +! +!*** Jan Mandel August-October 2007 email: jmandel@ucar.edu or Jan.Mandel@gmail.com +! +! With contributions by Minjeong Kim. +#define DEBUG_OUT +#define DEBUG_PRINT +!#define DEBUG_OUT_FUEL_LEFT + +module module_fr_sfire_core + +use module_fr_sfire_phys, only: fire_params , fire_ros +use module_fr_sfire_util + +implicit none + +! The mathematical core of the fire spread model. No physical constants here. +! +! subroutine sfire_core: only this routine should be called from the outside. +! subroutine fuel_left: compute remaining fuel from time of ignition. +! subroutine prop_ls: propagation of curve in normal direction. + + +contains + +! +!**************************************** +! + +subroutine init_no_fire(& + ifds,ifde,jfds,jfde, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + fdx,fdy,time_start,dt, & ! scalars in + fuel_frac,fire_area,lfn,tign_in, & !arrays out + tign) ! arrays inout +implicit none + +!*** purpose: initialize model to no fire + +!*** arguments +integer, intent(in):: ifds,ifde,jfds,jfde ! fire domain bounds +integer, intent(in):: ifts,ifte,jfts,jfte ! fire tile bounds +integer, intent(in):: ifms,ifme,jfms,jfme ! array bounds +real, intent(in) :: fdx,fdy,time_start,dt ! mesh spacing, time +real, intent(out), dimension (ifms:ifme,jfms:jfme) :: & + fuel_frac,fire_area,lfn, & ! model state + tign_in +real, intent(inout), dimension (ifms:ifme,jfms:jfme) :: & + tign ! model state, on input values tign_in + +!*** calls +intrinsic epsilon + +!*** local +integer:: i,j +real:: lfn_init,time_init,time_now +character(len=128):: msg + +time_now = time_start+dt +time_init = time_start+2*dt ! could be time_start+dt if not for rounding errors +lfn_init = 2*max((ifde-ifds+1)*fdx,(jfde-jfds+1)*fdy) ! more than domain diameter + +call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme, tign,'init_no_fire start: tign') + +if (fire_perimeter_time > 0. .and. fire_tign_in_time > 0.)then + call crash('fire_perimeter_time > 0 and fire_tign_in_time > 0') +endif + +if(fire_perimeter_time > 0.)then + call message('init_no_fire: using given ignition time to replay history',level=1) + do j=jfts,jfte + do i=ifts,ifte + fuel_frac(i,j)=1. ! fuel at start is 1 by definition + fire_area(i,j)=0. ! nothing burning + lfn(i,j) = tign(i,j)-time_now ! use specified ignition time as level set function + enddo + enddo +elseif(fire_tign_in_time > 0.)then + call message('init_no_fire: using ignition from given max fire arrival time',level=1) + do j=jfts,jfte + do i=ifts,ifte + tign_in(i,j)=tign(i,j) + fuel_frac(i,j)=1. ! fuel at start is 1 by definition + fire_area(i,j)=0. ! nothing burning + lfn(i,j) = tign_in(i,j)-time_now ! use specified ignition time as level set function + enddo + enddo + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme, tign_in,'init_no_fire: tign_in') +else + call message('init_no_fire: setting state to no fire',level=1) + do j=jfts,jfte + do i=ifts,ifte + fuel_frac(i,j)=1. ! fuel at start is 1 by definition + fire_area(i,j)=0. ! nothing burning + tign(i,j) = time_init ! ignition in future + lfn(i,j) = lfn_init ! no fire + enddo + enddo +endif + +call check_lfn_tign('init_no_fire',time_now,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn, tign) +call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme, tign,'init_no_fire: tign') +call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme, tign,'init_no_fire: lfn') + +do j=jfts,jfte + do i=ifts,ifte + if(.not.lfn(i,j) > 0.)then + write(msg,*)'i,j=',i,j,' tign=',tign(i,j),' <= time_now =',time_now + call message(msg,level=0) + call crash('init_no_fire: ignition time must be after the end of the first time step') + endif + enddo +enddo + +end subroutine init_no_fire + +! +!****************** +! + +subroutine ignite_from_tign_in( & + ifds,ifde,jfds,jfde, & ! fire domain dims - the whole domain + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + start_ts,end_ts, & + tign_in, & + lfn,tign,ignited) +implicit none +!*** purpose: ignite from given gridded ignition times +!*** arguments +integer, intent(in):: ifds,ifde,jfds,jfde ! fire domain bounds +integer, intent(in):: ifts,ifte,jfts,jfte ! fire tile bounds +integer, intent(in):: ifms,ifme,jfms,jfme ! array bounds +real, intent(in):: start_ts,end_ts ! the time step start and end +real, intent(in), dimension (ifms:ifme,jfms:jfme) :: tign_in ! the given ignition time +real, intent(inout), dimension (ifms:ifme,jfms:jfme) :: & + lfn, tign ! level function, ignition time (state) +integer, intent(out)::ignited +!*** global +! fire_tign_in_time +!*** local +integer:: i,j +real:: lfn_old + +!*** executable +ignited=0 +if(.not. start_ts < fire_tign_in_time)return ! too late, nothing to do + +call check_lfn_tign('ignite_from_tign_in start',end_ts,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn, tign) + +do j=jfts,jfte + do i=ifts,ifte + if (.not. tign_in(i,j)>end_ts )then + lfn_old = lfn(i,j) + tign(i,j)=min(tign(i,j), tign_in(i,j)) + lfn(i,j)=min(lfn(i,j),tign(i,j)-end_ts) + call check_lfn_tign_ij(i,j,'ignite_from_tign_in',end_ts,lfn(i,j),tign(i,j)) + if(lfn_old > 0 .and. .not. lfn(i,j) > 0.) ignited = ignited + 1 + endif + enddo +enddo + + +call check_lfn_tign('ignite_from_tign_in end',end_ts,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn, tign) +call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme, tign,'init_no_fire: tign') +call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme, tign,'init_no_fire: lfn') + +end subroutine ignite_from_tign_in + + + +subroutine ignite_fire( ifds,ifde,jfds,jfde, & ! fire domain dims - the whole domain + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + ignition_line, & + start_ts,end_ts, & + coord_xf,coord_yf, & + unit_xf,unit_yf, & + lfn,tign,ignited) +implicit none + +!*** purpose: ignite a circular/line fire + +!*** description +! ignite fire in the region within radius r from the line (sx,sy) to (ex,ey). +! the coordinates of nodes are given as the arrays coord_xf and coord_yf +! r is given in m +! one unit of coord_xf is unit_xf m +! one unit of coord_yf is unit_yf m +! so a node (i,j) will be ignited iff for some (x,y) on the line +! || ( (coord_xf(i,j) - x)*unit_xf , (coord_yf(i,j) - y)*unit_yf ) || <= r + + +!*** arguments +integer, intent(in):: ifds,ifde,jfds,jfde ! fire domain bounds +integer, intent(in):: ifts,ifte,jfts,jfte ! fire tile bounds +integer, intent(in):: ifms,ifme,jfms,jfme ! array bounds +type(line_type), intent(in):: ignition_line ! description of the ignition line +real, intent(in):: start_ts,end_ts ! the time step start and end +real, dimension(ifms:ifme, jfms:jfme), intent(in):: & + coord_xf,coord_yf ! node coordinates +real, intent(in):: unit_xf,unit_yf ! coordinate units in m +real, intent(inout), dimension (ifms:ifme,jfms:jfme) :: & + lfn, tign ! level function, ignition time (state) +integer, intent(out):: ignited ! number of nodes newly ignited + +!*** local +integer:: i,j +real::lfn_new,tign_new,time_ign,ax,ay,rels,rele,d +! real:: lfn_new_chk,tign_new_chk,tmperr +real:: sx,sy ! start of ignition line, from lower left corner +real:: ex,ey ! end of ignition line, or zero +real:: st,et ! start and end of time of the ignition line +character(len=128):: msg +real::cx2,cy2,dmax,axmin,axmax,aymin,aymax,dmin +real:: start_x,start_y ! start of ignition line, from lower left corner +real:: end_x,end_y ! end of ignition line, or zero +real:: radius ! all within the radius of the line will ignite +real:: start_time,end_time ! the ignition time for the start and the end of the line +real:: ros,tos ! ignition rate and time of spread +integer:: msglevel=4,smsg=2 ! print at this level +real:: lfn_min + +!*** executable + +call check_lfn_tign('ignite_fire start',end_ts,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn, tign) + +! copy ignition line fields to local variables +start_x = ignition_line%start_x ! x coordinate of the ignition line start point (m, or long/lat) +start_y = ignition_line%start_y ! y coordinate of the ignition line start point +end_x = ignition_line%end_x ! x coordinate of the ignition line end point +end_y = ignition_line%end_y ! y coordinate of the ignition line end point +start_time = ignition_line%start_time ! ignition time for the start point from simulation start (s) +end_time = ignition_line%end_time! ignition time for the end poin from simulation start (s) +radius = ignition_line%radius ! all within this radius ignites immediately +ros = ignition_line%ros ! rate of spread + + +tos = radius/ros ! time of spread to the given radius +st = start_time ! the start time of ignition considered in this time step +et = min(end_ts,end_time) ! the end time of the ignition segment in this time step + +ignited = 0 +! this should be called whenever (start_ts, end_ts) \subset (start_time, end_time + tos) +if(start_ts>et+tos .or. end_ts end_ts )then +!$OMP CRITICAL(SFIRE_CORE_CRIT) + write(msg,'(a,2i6,a,f11.6,a,2f11.6,a)')'WARNING ',i,j, & + ' fixing ignition time ',tign(i,j),' outside of the time step [',start_ts,end_ts,']' + call message (msg) +!$OMP END CRITICAL(SFIRE_CORE_CRIT) + tign(i,j) = min(max(tign(i,j),start_ts),end_ts) + endif + endif + lfn(i,j)=min(lfn(i,j),lfn_new) ! update the level set function + if(fire_print_msg.ge.msglevel)then +!$OMP CRITICAL(SFIRE_CORE_CRIT) + write(msg,*)'IGN3 i,j=',i,j,' lfn(i,j)=',lfn(i,j),' tign(i,j)=',tign(i,j) + call message(msg,level=msglevel) +!$OMP END CRITICAL(SFIRE_CORE_CRIT) + endif + call check_lfn_tign_ij(i,j,'ignite_fire end',end_ts,lfn(i,j),tign(i,j)) + enddo +enddo +! write(msg,*)'ignite_fire: max error ',tmperr +! call message(msg) +call check_lfn_tign("ignite_fire end:",end_ts,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn, tign) +if(fire_print_msg .ge. smsg)then +lfn_min=huge(lfn_min) +do j=jfts,jfte + do i=ifts,ifte + lfn_min=min(lfn_min,lfn(i,j)) + enddo +enddo +!$OMP CRITICAL(SFIRE_CORE_CRIT) +write(msg,'(a,2g13.2,a,g10.2,a,g10.2)')'IGN units ',unit_xf,unit_yf,' m max dist ',dmax,' min',dmin +call message(msg,level=smsg) +write(msg,'(a,f6.1,a,f8.1,a,i10,a,g10.2)')'IGN radius ',radius,' time of spread',tos, & + ' ignited nodes',ignited,' lfn min',lfn_min +call message(msg,level=smsg) +!$OMP END CRITICAL(SFIRE_CORE_CRIT) +endif +end subroutine ignite_fire + +! +!*** +! + +subroutine check_lfn_tign(s,time_now,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn, tign) +!*** purpose: check consistency of lfn and ignition +implicit none +!*** arguments +character(len=*),intent(in)::s ! for print +real, intent(in)::time_now ! end of timestep = time_now +integer, intent(in):: ifts,ifte,jfts,jfte ! fire tile bounds +integer, intent(in):: ifms,ifme,jfms,jfme ! array bounds +real, intent(in), dimension (ifms:ifme,jfms:jfme) :: & + lfn, tign ! level function, ignition time (state) +!*** local +integer:: i,j +character(len=128)::msg +!*** executable + +do j=jfts,jfte + do i=ifts,ifte + call check_lfn_tign_ij(i,j,s,time_now,lfn(i,j),tign(i,j)) + enddo +enddo + +!$OMP CRITICAL(SFIRE_CORE_CRIT) +write(msg,'(a,f9.2,1x,a)')'check_lfn_tign OK',time_now,s +!$OMP END CRITICAL(SFIRE_CORE_CRIT) +call message(msg) + +end subroutine check_lfn_tign + +subroutine check_lfn_tign_ij(i,j,s,time_now,lfnij,tignij) +!*** purpose: check consistency of lfn and ignition +implicit none +!*** arguments +integer, intent(in)::i,j ! indices +character(len=*),intent(in)::s ! for print +real, intent(in)::time_now ! end of timestep = time_now +real, intent(in):: lfnij, tignij ! level function, ignition time (state) +!*** local +character(len=128):: msg +!*** executable + +if(.not. lfnij<0. .and. tignij=0 and tign= |s-e|/2 the nearest point is one of the endpoints + ! the computation work also for the case when s=e exactly or approximately + ! + ! + ! a + ! /| \ + ! s---m-c--e + ! + ! |m-c| = |a-m| cos (a-m,e-s) + ! = |a-m| (a-m).(e-s))/(|a-m|*|e-s|) +!*** local + real:: mx,my,dam2,dames,am_es,cos2,dmc2,mcrel,mid_t,dif_t,des2,cx,cy + character(len=128):: msg + integer::msglevel=4 +!*** executable + +11 format('IGN ',6(a,g17.7,1x)) +12 format('IGN ',4(a,2g13.7,1x)) + + ! midpoint m = (mx,my) + mx = (sx + ex)*0.5 + my = (sy + ey)*0.5 + dam2=(ax-mx)*(ax-mx)*cx2+(ay-my)*(ay-my)*cy2 ! |a-m|^2 + des2 = (ex-sx)*(ex-sx)*cx2+(ey-sy)*(ey-sy)*cy2 ! des2 = |e-s|^2 + dames = dam2*des2 + am_es=(ax-mx)*(ex-sx)*cx2+(ay-my)*(ey-sy)*cy2 ! am_es = (a-m).(e-s) + if(dames>0)then + cos2 = (am_es*am_es)/dames ! cos2 = cos^2 (a-m,e-s) + else ! point a already is the midpoint + cos2 = 0. + endif + dmc2 = dam2*cos2 ! dmc2 = |m-c|^2 + if(4.*dmc2 < des2)then ! if |m-c|<=|e-s|/2 + ! d = sqrt(max(dam2 - dmc2,0.)) ! d=|a-m|^2 - |m-c|^2, guard rounding + mcrel = sign(sqrt(4.*dmc2/des2),am_es) ! relative distance of c from m + elseif(am_es>0)then ! if cos > 0, closest is e + mcrel = 1.0 + else ! closest is s + mcrel = -1.0 + endif + cx = (ex + sx)*0.5 + mcrel*(ex - sx)*0.5 ! interpolate to c by going from m + cy = (ey + sy)*0.5 + mcrel*(ey - sy)*0.5 ! interpolate to c by going from m + d=sqrt((ax-cx)*(ax-cx)*cx2+(ay-cy)*(ay-cy)*cy2) ! |a-c|^2 + t = (et + st)*0.5 + mcrel*(et - st)*0.5 ! interpolate to c by going from m + if(fire_print_msg.ge.msglevel)then +!$OMP CRITICAL(SFIRE_CORE_CRIT) + write(msg,12)'find nearest to [',ax,ay,'] from [',sx,sy,'] [',ex,ey,']' ! DEB + call message(msg,level=msglevel) + write(msg,12)'end times',st,et,' scale squared',cx2,cy2 ! DEB + call message(msg,level=msglevel) + write(msg,11)'nearest at mcrel=',mcrel,'from the midpoint, t=',t ! DEB + call message(msg,level=msglevel) + write(msg,12)'nearest is [',cx,cy,'] d=',d ! DEB + call message(msg,level=msglevel) + write(msg,11)'dam2=',dam2,'des2=',des2,'dames=',dames + call message(msg,level=msglevel) + write(msg,11)'am_es=',am_es,'cos2=',cos2,'dmc2=',dmc2 ! DEB + call message(msg) +!$OMP END CRITICAL(SFIRE_CORE_CRIT) + endif +END SUBROUTINE nearest + + +! +!********************** +! + +subroutine fuel_left( & + ifds,ifde,jfds,jfde, & + ims,ime,jms,jme, & + its,ite,jts,jte, & + ifs,ife,jfs,jfe, & + lfn, tign, fuel_time, time_now, fuel_frac, fire_area) +implicit none + +!*** purpose: determine fraction of fuel remaining +!*** NOTE: because variables are cell centered, need halo/sync width 1 before + +!*** Jan Mandel August 2007 email: jmandel@ucar.edu or Jan.Mandel@gmail.com + +!*** arguments + +integer, intent(in) ::ifds,ifde,jfds,jfde,its,ite,jts,jte,ims,ime & + ,jms,jme,ifs,ife,jfs,jfe +real, intent(in), dimension(ims:ime,jms:jme)::lfn,tign,fuel_time +real, intent(in):: time_now +real, intent(out), dimension(ifs:ife,jfs:jfe)::fuel_frac +real, intent(out), dimension(ims:ime,jms:jme):: fire_area + +! ims,ime,jms,jme in memory dimensions +! its,ite,jts,jte in tile dimensions (cells where fuel_frac computed) +! ifs,ife,jfs,jfe in fuel_frac memory dimensions +! lfn in level function, at nodes at midpoints of cells +! tign in ignition time, at nodes at nodes at midpoints of cells +! fuel_time in time constant of fuel, per cell +! time_now in time now +! fuel_frac out fraction of fuel remaining, per cell +! fire_area out fraction of cell area on fire + +!*** local + +integer::i,j,ir,jr,icl,jcl,isubcl,jsubcl,i2,j2,ii,jj,its1,jts1,ite1,jte1 +real::fmax,frat,helpsum1,helpsum2,fuel_left_ff,fire_area_ff,rx,ry,tignf(2,2) +real,dimension(3,3)::tff,lff +! help variables instead of arrays fuel_left_f and fire_area_f +real::lffij,lffi1j,lffij1,lffi1j1,tifij,tifi1j,tifij1,tifi1j1,tx,ty,txx,tyy +! variables for calculation instead of lff(i,j) and tif(i,j)is lffij,tifij etc..#define IFCELLS (ite-its+1)*fuel_left_irl +#define JFCELLS (jte-jts+1)*fuel_left_jrl +character(len=128)::msg +integer::m,omp_get_thread_num + + +call check_mesh_2dim(its-1,ite+1,jts-1,jte+1,ims,ime,jms,jme) +call check_mesh_2dim(its,ite,jts,jte,ifs,ife,jfs,jfe) +call check_lfn_tign('fuel_left start',time_now,its,ite,jts,jte,ims,ime,jms,jme,lfn, tign) + +! refinement +ir=fuel_left_irl +jr=fuel_left_jrl + +if ((ir.ne.2).or.(jr.ne.2)) then + call crash('fuel_left: ir.ne.2 or jr.ne.2 ') +endif + +rx=1./ir +ry=1./jr + +! interpolate level set function to finer grid +#ifdef DEBUG_OUT_FUEL_LEFT + call write_array_m(1,IFCELLS+1,1,JFCELLS+1,1,IFCELLS+1,1,JFCELLS+1,lff,'lff',0) + call write_array_m(1,IFCELLS+1,1,JFCELLS+1,1,IFCELLS+1,1,JFCELLS+1,tif,'tif',0) +#endif + +! +! example for ir=2: +! +! | coarse cell | +! its-1 its ite ite+1 +! -------X------------|-----.-----X-----.-----|--........----|----------X----------|---------X +! fine node 1 2 3 2*(ite-its+1) +! fine cell 1 2 cell 2*(ite-its+1) + + + +! Loop over cells in Tile +! Changes made by Volodymyr Kondratenko 09/24/2009 +its1=max(its,ifds+1) +ite1=min(ite,ifde-1) +jts1=max(jts,jfds+1) +jte1=min(jte,jfde-1) + +! jm: initialize fuel_frac - we do not compute it near the domain boundary becau!se we cannot interpolate! +do j=jts,jte + do i=its,ite + fuel_frac(i,j)=1. + fire_area(i,j)=0. + enddo +enddo + +do icl=its1,ite1 + do jcl=jts1,jte1 + helpsum1=0 + helpsum2=0 + + call tign_lfn_interpolation(time_now,icl,jcl,ims,ime,jms,jme, & + tign,lfn,tff,lff) + + do isubcl=1,ir + do jsubcl=1,jr + if(fuel_left_method.eq.1)then + call fuel_left_cell_1( fuel_left_ff, fire_area_ff, & + lff(isubcl,jsubcl),lff(isubcl,jsubcl+1),lff(isubcl+1,jsubcl),lff(isubcl+1,jsubcl+1), & + tff(isubcl,jsubcl),tff(isubcl,jsubcl+1),tff(isubcl+1,jsubcl),tff(isubcl+1,jsubcl+1), & + time_now, fuel_time(icl,jcl)) + elseif(fuel_left_method.eq.2)then + call fuel_left_cell_2( fuel_left_ff, fire_area_ff, & + lff(isubcl,jsubcl),lff(isubcl,jsubcl+1),lff(isubcl+1,jsubcl),lff(isubcl+1,jsubcl+1), & + tff(isubcl,jsubcl),tff(isubcl,jsubcl+1),tff(isubcl+1,jsubcl),tff(isubcl+1,jsubcl+1), & + time_now, fuel_time(icl,jcl)) +! dont forget to change fire_area_ff here + else + call crash('fuel_left: unknown fuel_left_method') + endif + + ! consistency check + if(fire_area_ff.lt.-1e-6 .or. & + (fire_area_ff.eq.0. .and. fuel_left_ff.lt.1.-1e-6))then +!$OMP CRITICAL(SFIRE_CORE_CRIT) + write(msg,'(a,2i6,2(a,f11.8))')'fuel_left: at node',i,j, & + ' of refined mesh fuel burnt',1-fuel_left_ff,' fire area',fire_area_ff +!$OMP END CRITICAL(SFIRE_CORE_CRIT) + call crash(msg) + endif + + helpsum1=helpsum1+fuel_left_ff + helpsum2=helpsum2+fire_area_ff + ! write(*,*)icl,jcl,isubcl,jsubcl,fuel_left_ff,fire_area_ff + enddo + enddo + ! write(*,*)icl,jcl,helpsum1,helpsum2 + fuel_frac(icl,jcl)=helpsum1 / (ir*jr) ! multiply by weight for averaging over coarse cell + fire_area(icl,jcl)=helpsum2 / (ir*jr) ! multiply by weight for averaging over coarse cell + enddo +enddo + + + +#ifdef DEBUG_OUT_FUEL_LEFT + call write_array_m(its,ite,jts,jte,ims,ime,jms,jme,fire_area,'fire_area',0) + call write_array_m(its,ite,jts,jte,ims,ime,jms,jme,fuel_frac,'fuel_frac',0) + call write_array_m(1,IFCELLS,1,JFCELLS,1,IFCELLS,1,JFCELLS,fuel_left_f,'fuel_left_f',0) + call write_array_m(1,IFCELLS,1,JFCELLS,1,IFCELLS,1,JFCELLS,fire_area_f,'fire_area_f',0) +#endif + +! consistency check after sum +!fmax=0 +!do j=jts,jte +! do i=its,ite +! if(fire_area(i,j).eq.0.)then +! if(fuel_frac(i,j).lt.1.-1e-6)then +!!$OMP CRITICAL(SFIRE_CORE_CRIT) +! write(msg,'(a,2i6,2(a,f11.8))')'fuel_left: at node',i,j, & +! ' fuel burnt',1-fuel_frac(i,j),' but fire area',fire_area(i,j) +!!$OMP END CRITICAL(SFIRE_CORE_CRIT) +! call crash(msg) +! endif +! else +! frat=(1-fuel_frac(i,j))/fire_area(i,j) +! fmax=max(fmax,frat) +! endif +! enddo +!enddo +!$OMP CRITICAL(SFIRE_CORE_CRIT) +write(msg,'(a,4i6,a,e15.7)')'fuel_left: tile',its,ite,jts,jte,' max fuel burnt/area',fmax +!$OMP END CRITICAL(SFIRE_CORE_CRIT) +call message(msg) + +return + + +end subroutine fuel_left + +! +!************************ +! + + +! +!************************* +!Subroutine that is calculating tign and lfn of four endpoints of the subcell +! that is located at isubcl,jsubcl of the cell -(icl,jcl) +! +subroutine tign_lfn_interpolation(time_now,icl,jcl,ims,ime,jms,jme, & + tign,lfn,tff,lff) +real, intent(in):: time_now ! not ignited nodes will have tign set to >= time_now +integer, intent(in) :: icl,jcl +integer, intent(in) :: ims,ime,jms,jme ! memory dimensions of all arrays +real, intent(in), dimension(ims:ime,jms:jme)::lfn,tign +real, intent(out),dimension(3,3)::tff,lff + +! | | | +! -(3,1)-------------(3,2)-------------(3,3) +! | | | +! | (2,1) | (2,2) | +! | | | +! | | | +! | | | +! | | | +! (2,1)--------node-(icl,jcl)---------(2,3)-----------(icl,jcl+1)-------------| +! | sub-node (2,2) | +! | | | +! | (1,1) | (1,2) | each fire mesh cell is decomposed in 4 +! | | | tff,lff is computed at the nodes of +! | | | the subcells, numbered (1,1)...(3,3) +! (1,1)-------------(1,2)-------------(1,3)-- +! | | | +! + +!********************** + +! Direct calculation tif and lff, avoiding big auxiliary arrays, just for case ir=jr=2 +! Checking whether icl or jcl is on the boundary + + call tign_lfn_four_pnts_interp(tign(icl-1,jcl-1),tign(icl-1,jcl),tign(icl,jcl-1), & + tign(icl,jcl),lfn(icl-1,jcl-1),lfn(icl-1,jcl), & + lfn(icl,jcl-1),lfn(icl,jcl),lff(1,1),tff(1,1),time_now) + + call tign_lfn_line_interp(tign(icl-1,jcl),tign(icl,jcl),lfn(icl-1,jcl),lfn(icl,jcl), & + lff(1,2),tff(1,2),time_now) + + + call tign_lfn_four_pnts_interp(tign(icl-1,jcl),tign(icl-1,jcl+1),tign(icl,jcl), & + tign(icl,jcl+1),lfn(icl-1,jcl),lfn(icl-1,jcl+1), & + lfn(icl,jcl),lfn(icl,jcl+1),lff(1,3),tff(1,3),time_now) + + call tign_lfn_line_interp(tign(icl,jcl-1),tign(icl,jcl),lfn(icl,jcl-1),lfn(icl,jcl), & + lff(2,1),tff(2,1),time_now) + + lff(2,2)=lfn(icl,jcl) + tff(2,2)=tign(icl,jcl) + + call tign_lfn_line_interp(tign(icl,jcl+1),tign(icl,jcl),lfn(icl,jcl+1),lfn(icl,jcl), & + lff(2,3),tff(2,3),time_now) + + call tign_lfn_four_pnts_interp(tign(icl,jcl-1),tign(icl,jcl),tign(icl+1,jcl-1), & + tign(icl+1,jcl),lfn(icl,jcl-1),lfn(icl,jcl), & + lfn(icl+1,jcl-1),lfn(icl+1,jcl),lff(3,1),tff(3,1),time_now) + + call tign_lfn_line_interp(tign(icl+1,jcl),tign(icl,jcl),lfn(icl+1,jcl),lfn(icl,jcl), & + lff(3,2),tff(3,2),time_now) + + call tign_lfn_four_pnts_interp(tign(icl,jcl),tign(icl,jcl+1),tign(icl+1,jcl), & + tign(icl+1,jcl+1),lfn(icl,jcl),lfn(icl,jcl+1), & + lfn(icl+1,jcl),lfn(icl+1,jcl+1),lff(3,3),tff(3,3),time_now) + +end subroutine tign_lfn_interpolation + +! +!************************ +! + +subroutine tign_lfn_line_interp(tign1,tign2,lfn1,lfn2,lfn_subcl,tign_subcl,time_now) +!***purpose: computes time of ignition of the point(*_subcl) that lies on the line +! between two points, whose lfn and tign is known + +!*** arguments +! +real,intent(in) :: tign1,tign2 ! ignition times at the two endpoints +real,intent(in) :: lfn1,lfn2 ! level set function at the two endpoints +real,intent(in) :: time_now ! tign>=time_now => no fire +real,intent(out) :: lfn_subcl,tign_subcl ! interpolated to midpoint + +! Case 1: both points are on fire -> tign is interpolated linearly +! Case 2: both points are not on fire -> tign_subcl=time_now, not burning +! Case 3: One point is not fire, another is not -> tign_subcl set from +! the equation tign - time_now = c*lfn, where the proportionality +! constant is found from the values of tign and lfn at the burning endpoint. +! In particular, lfn(x)=0 implies tign(x)=time_now, so the representations of +! the fireline by lfn and tign are consistent. +! This is a special case of Case 3 from subroutine tign_lfn_four_pnts_interp. + +!*** local +real :: c + +!*** executable + +! check consistency of inputs +call check_lfn_tign_ij(0,1,'tign_lfn_line_interp',time_now,lfn1,tign1) +call check_lfn_tign_ij(0,2,'tign_lfn_line_interp',time_now,lfn2,tign2) + +lfn_subcl=0.5*(lfn1+lfn2) ! interpolate lfn linearly + +if (.not. lfn_subcl < 0.) then ! never test floats on equality + tign_subcl=time_now ! midpoint not on fire => none on fire +elseif ((lfn1 < 0.).AND.(lfn2 < 0.)) then + tign_subcl=0.5*(tign1+tign2) ! both on fire, interpolate linearly +else ! one is on fire one is not + if (lfn1 < 0) then ! 1 is on fire, 2 is not + c = (tign1-time_now)/lfn1 + elseif (lfn2 < 0) then + c = (tign2-time_now)/lfn2 + else + call crash('tign_lfn_line_interp: one of lfn1 or lfn2 should be < 0') + endif + if( c < 0.)call crash('tign_lfn_line_interp: bad ignition times, c<0') + tign_subcl=c*lfn_subcl+time_now; +endif +end subroutine tign_lfn_line_interp +! +!************************ +! + +subroutine tign_lfn_four_pnts_interp(tign1,tign2,tign3,tign4, & + lfn1,lfn2,lfn3,lfn4,lfn_subcl,tign_subcl,time_now) + +!***purpose: computes time of ignition of the point(*_subcl) that lies on the middle +! of square with given 4 points on its ends, whose lfn and tign is known +! since lfn is interpolated linearly, lfn_subcl is known + +!***arguments +real,intent(in) :: tign1,tign2,tign3,tign4 ! time of ignition of all corner points +real,intent(in) :: lfn1,lfn2,lfn3,lfn4 ! lfn of central and all corner points +real,intent(in) :: time_now +real,intent(out) :: lfn_subcl,tign_subcl + +! Case 1: all 4 points are on fire -> tign is interpolated linearly +! tign_subcl=0.25*(tign1+tign2+tign3+tign4) +! Case 2: all points are not on fire -> subcl - not burning +! Case 3: some points are on fire, others are not +! Here we assume that when lfn(x)=0 -> tign(x)=time_now (values interpolated to point x) +! For this case, tign of central point is approximated by +! tign~=c*lfn+time_now, which for our case is +! tign_subcl~=c*lfn_subcl+time_now +! where c is computed by least squares from the values at the points that are on fire +! +! sum(c*lfn(Ai)+time_now-tign(Ai))^2 ---> min +! for all lfn(Ai)<0 +! +! solution for 'c' would be +! +! sum(lfn(Ai)*lfn(Ai) +! c= ------------------------------, both sums are over Ai, s.t lfn(Ai)<0 +! sum(tign(Ai)-time_now)*lfn(Ai) +! + + +real :: a,b,c,err +err=0.0001 + +call check_lfn_tign_ij(0,1,'tign_lfn_four_pnts_interp',time_now,lfn1,tign1) +call check_lfn_tign_ij(0,2,'tign_lfn_four_pnts_interp',time_now,lfn2,tign2) +call check_lfn_tign_ij(0,3,'tign_lfn_four_pnts_interp',time_now,lfn3,tign3) +call check_lfn_tign_ij(0,4,'tign_lfn_four_pnts_interp',time_now,lfn4,tign4) + +lfn_subcl=0.25*(lfn1+lfn2+lfn3+lfn4) + +if(.not. lfn_subcl < 0.) then ! midpoint not on fire, most frequent + ! Case 2 + tign_subcl=time_now +elseif((lfn1 < 0.).AND.(lfn2 < 0.).AND.(lfn3 < 0.).AND.(lfn4 < 0.)) then + ! Case 1 + tign_subcl=0.25*(tign1+tign2+tign3+tign4) ! all on fire, interpolate +else ! some on fire + ! Case 3 + ! tign_subcl~=c*lfn_subcl+time_now + a=0; + b=0; + if (lfn1 < 0.) then + a=a+lfn1*lfn1 + b=b+(tign1-time_now)*lfn1 + endif + if (lfn2 < 0.) then + a=a+lfn2*lfn2 + b=b+(tign2-time_now)*lfn2 + endif + if (lfn3 < 0.) then + a=a+lfn3*lfn3 + b=b+(tign3-time_now)*lfn3 + endif + if (lfn4 < 0.) then + a=a+lfn4*lfn4 + b=b+(tign4-time_now)*lfn4 + endif + if (.not. a>0.) call crash('tign_lfn_four_pnts_interp: none of lfn < 0') + if( b < 0.)call crash('tign_lfn_four_pnts_interp: bad ignition times, b<0') ! can have 0 because of rounding + c=b/a; + tign_subcl=c*lfn_subcl+time_now; +endif + +end subroutine tign_lfn_four_pnts_interp + + +! +!************************ +! + + +subroutine fuel_left_cell_1( fuel_frac_left, fire_frac_area, & + lfn00,lfn01,lfn10,lfn11, & + tign00,tign01,tign10,tign11,& + time_now, fuel_time_cell) +!*** purpose: compute the fuel fraction left in one cell +implicit none +!*** arguments +real, intent(out):: fuel_frac_left, fire_frac_area ! +real, intent(in)::lfn00,lfn01,lfn10,lfn11 ! level set function at 4 corners of the cell +real, intent(in)::tign00,tign01,tign10,tign11! ignition time at the 4 corners of the cell +real, intent(in)::time_now ! the time now +real, intent(in)::fuel_time_cell ! time to burns off to 1/e +!*** Description +! The area burning is given by the condition L <= 0, where the function P is +! interpolated from lfn(i,j) +! +! The time since ignition is the function T, interpolated in from tign(i,j)-time_now. +! The values of tign(i,j) where lfn(i,j)>=0 are ignored, tign(i,j)=0 is taken +! when lfn(i,j)=0. +! +! The function computes an approxmation of the integral +! +! +! /\ +! | +! fuel_frac_left = 1 - | 1 - exp(-T(x,y)/fuel_time_cell)) dxdy +! | +! \/ +! 0=0), then fuel_frac(i,j)=1. +! Because of symmetries, the result should not depend on the mesh spacing dx dy +! so dx=1 and dy=1 assumed. +! +! Example: +! +! lfn<0 lfn>0 +! (0,1) -----O--(1,1) O = points on the fireline, T=tnow +! | \ | A = the burning area for computing +! | \| fuel_frac(i,j) +! | A O +! | | +! | | +! (0,0)---------(1,0) +! lfn<0 lfn<0 +! +! Approximations allowed: +! The fireline can be approximated by straight line(s). +! When all cell is burning, approximation by 1 point Gaussian quadrature is OK. +! +! Requirements: +! 1. The output should be a continuous function of the arrays lfn and +! tign whenever lfn(i,j)=0 implies tign(i,j)=tnow. +! 2. The output should be invariant to the symmetries of the input in each cell. +! 3. Arbitrary combinations of the signs of lfn(i,j) should work. +! 4. The result should be at least 1st order accurate in the sense that it is +! exact if the time from ignition is a linear function. +! +! If time from ignition is approximated by polynomial in the burnt +! region of the cell, this is integral of polynomial times exponential +! over a polygon, which can be computed exactly. +! +! Requirement 4 is particularly important when there is a significant decrease +! of the fuel fraction behind the fireline on the mesh scale, because the +! rate of fuel decrease right behind the fireline is much larger +! (exponential...). This will happen when +! +! change of time from ignition within one mesh cell / fuel_time_cell is not << 1 +! +! This is the same as +! +! mesh cell size +! X = ------------------------- is not << 1 +! fireline speed * fuel_time_cell +! +! +! When X is large then the fuel burnt in one timestep in the cell is +! approximately proportional to length of fireline in that cell. +! +! When X is small then the fuel burnt in one timestep in the cell is +! approximately proportional to the area of the burning region. +! + +!*** calls +intrinsic tiny + +!*** local +real::ps,aps,area,ta,out +real::t00,t01,t10,t11 +real,parameter::safe=tiny(aps) +character(len=128)::msg + +! the following algorithm is a very crude approximation + +! minus time since ignition, 0 if no ignition yet +! it is possible to have 0 in fire region when ignitin time falls in +! inside the time step because lfn is updated at the beginning of the time step + +t00=tign00-time_now +if(lfn00>0. .or. t00>0.)t00=0. +t01=tign01-time_now +if(lfn01>0. .or. t01>0.)t01=0. +t10=tign10-time_now +if(lfn10>0. .or. t10>0.)t10=0. +t11=tign11-time_now +if(lfn11>0. .or. t11>0.)t11=0. + +! approximate burning area, between 0 and 1 +ps = lfn00+lfn01+lfn10+lfn11 +aps = abs(lfn00)+abs(lfn01)+abs(lfn10)+abs(lfn11) +aps=max(aps,safe) +area =(-ps/aps+1.)/2. +area = max(area,0.) ! make sure area is between 0 and 1 +area = min(area,1.) + +! average negative time since ignition +ta=0.25*(t00+t01+t10+t11) + +! exp decay in the burning area +out=1. +!if(area>0.)out=1. - area*(1. - exp(ta/fuel_time_cell)) +if(area>0)out=area*exp(ta/fuel_time_cell) + (1. - area) + +if(out>1.)then +!$OMP CRITICAL(SFIRE_CORE_CRIT) + write(msg,*)'out=',out,'>1 area=',area,' ta=',ta + call message(msg) + write(msg,*)'tign=',tign00,tign01,tign10,tign11,' time_now=',time_now +!$OMP END CRITICAL(SFIRE_CORE_CRIT) + call message(msg) + !call message('WARNING: fuel_left_cell_1: fuel fraction > 1') + call crash('fuel_left_cell_1: fuel fraction > 1') +endif + +!out = max(out,0.) ! make sure out is between 0 and 1 +!out = min(out,1.) + +fuel_frac_left = out +fire_frac_area = area + +end subroutine fuel_left_cell_1 + +! +!**************************************** +! +! function calculation fuel_frac made by Volodymyr Kondratenko on the base of +! the Matlab code made by Jan Mandel and the fortran port by Minjeong Kim + +subroutine fuel_left_cell_2( fuel_frac_left, fire_frac_area, & + lfn00,lfn01,lfn10,lfn11, & + tign00,tign01,tign10,tign11,& + time_now, fuel_time_cell) +!*** purpose: compute the fuel fraction left in one cell +implicit none +!*** arguments +real, intent(out):: fuel_frac_left, fire_frac_area ! +real, intent(in)::lfn00,lfn01,lfn10,lfn11 ! level set function at 4 corners of the cell +real, intent(in)::tign00,tign01,tign10,tign11! ignition time at the 4 corners of the cell +real, intent(in)::time_now ! the time now +real, intent(in)::fuel_time_cell ! burns time to 1/e +!*** Description +! The burning area is given by the condition L <= 0, where the function L is +! interpolated from lfn(i,j) +! +! The time since ignition is the function T, interpolated in from tign(i,j)-time_now. +! The values of tign(i,j) where lfn(i,j)>=0 are ignored, tign(i,j)=0 is taken +! when lfn(i,j)=0. +! +! The function computes an approxmation of the integral +! +! +! /\ +! | +! fuel_frac_left = 1 - | 1 - exp(-T(x,y)/fuel_time_cell)) dxdy +! | +! \/ +! 0=0), then fuel_frac(i,j)=1. +! Because of symmetries, the result should not depend on the mesh spacing dx dy +! so dx=1 and dy=1 assumed. +! +! Example: +! +! lfn<0 lfn>0 +! (0,1) -----O--(1,1) O = points on the fireline, T=tnow +! | \ | A = the burning area for computing +! | \| fuel_frac(i,j) +! | A O +! | | +! | | +! (0,0)---------(1,0) +! lfn<0 lfn<0 +! +! Approximations allowed: +! The fireline can be approximated by straight line(s). +! When all cell is burning, approximation by 1 point Gaussian quadrature is OK. +! +! Requirements: +! 1. The output should be a continuous function of the arrays lfn and +! tign whenever lfn(i,j)=0 implies tign(i,j)=tnow. +! 2. The output should be invariant to the symmetries of the input in each cell. +! 3. Arbitrary combinations of the signs of lfn(i,j) should work. +! 4. The result should be at least 1st order accurate in the sense that it is +! exact if the time from ignition is a linear function. +! +! If time from ignition is approximated by polynomial in the burnt +! region of the cell, this is integral of polynomial times exponential +! over a polygon, which can be computed exactly. +! +! Requirement 4 is particularly important when there is a significant decrease +! of the fuel fraction behind the fireline on the mesh scale, because the +! rate of fuel decrease right behind the fireline is much larger +! (exponential...). This will happen when +! +! change of time from ignition within one mesh cell * fuel speed is not << 1 +! +! This is the same as +! +! mesh cell size*fuel_speed +! ------------------------- is not << 1 +! fireline speed +! +! +! When X is large then the fuel burnt in one timestep in the cell is +! approximately proportional to length of fireline in that cell. +! +! When X is small then the fuel burnt in one timestep in the cell is +! approximately proportional to the area of the burning region. + +!*** calls +intrinsic tiny +#define DREAL real(kind=8) +!*** local +DREAL::ps,aps,area,ta,out +DREAL::t00,t01,t10,t11 +DREAL,parameter::safe=tiny(aps) +DREAL::dx,dy ! mesh sizes +integer::i,j,k + +DREAL,dimension(3)::u + +DREAL::tweight,tdist +integer::kk,ll,ss +DREAL::rnorm +DREAL,dimension(8,2)::xylist,xytlist +DREAL,dimension(8)::tlist,llist,xt +DREAL,dimension(5)::xx,yy +DREAL,dimension(5)::lfn,tign + +integer:: npoint +DREAL::tt,x0,y0,xts,xte,yts,yte,xt1,xt2 +DREAL::lfn0,lfn1,dist,nr,s,errQ,ae,ce,ceae,a0,a1,a2,d,cet +DREAL::s1,s2,s3 +DREAL::upper,lower,ah,ch,aa,cc,aupp,cupp,alow,clow +DREAL,dimension(2,2)::mQ +DREAL,dimension(2)::ut +character(len=128)::msg + +!calls +intrinsic epsilon + +DREAL, parameter:: zero=0.,one=1.,eps=epsilon(zero) + +!!!! For finite differences by VK +DREAL::tign_middle,dt_dx,dt_dy,lfn_middle,a,b,c +DREAL:: alg_err + +!*** executable + +call crash('fuel_left_method=2 not working, please use fuel_left_method=1') + +! check consistency +call check_lfn_tign_ij(0,0,'fuel_left_cell_2',time_now,lfn00,tign00) +call check_lfn_tign_ij(0,1,'fuel_left_cell_2',time_now,lfn01,tign01) +call check_lfn_tign_ij(1,0,'fuel_left_cell_2',time_now,lfn10,tign10) +call check_lfn_tign_ij(1,1,'fuel_left_cell_2',time_now,lfn11,tign11) + +alg_err=0 +dx=1 +dy=1 +t00=time_now-tign00 +if(lfn00>=0. .or. t00<0.)t00=0. +t01=time_now-tign01 +if(lfn01>=0. .or. t01<0.)t01=0. +t10=time_now-tign10 +if(lfn10>=0. .or. t10<0.)t10=0. +t11=time_now-tign11 +if(lfn11>=0. .or. t11<0.)t11=0. + +! approximate burning area, between 0 and 1 +! was taken from fuel_left_cell_1 made by Jan, will need to be changed +ps = lfn00+lfn01+lfn10+lfn11 +aps = abs(lfn00)+abs(lfn01)+abs(lfn10)+abs(lfn11) +aps=max(aps,safe) +area =(-ps/aps+1.)/2. +area = max(area,zero) ! make sure area is between 0 and 1 +area = min(area,one) + +!*** case0 Do nothing +if ( lfn00>=0 .and. lfn10>=0 .and. lfn01>=0 .and. lfn11>=0 ) then + out = 1.0 ! fuel_left, no burning + area= 0. +!*** case4 all four coners are burning +else if (lfn00<=0 .and. lfn10<=0 .and. lfn01<=0 .and. lfn11<=0) then +! All burning +! T=u(1)*x+u(2)*y+u(3) +! t(0,0)=tign(1,1) +! t(0,fd(2))=tign(1,2) +! t(fd(1),0)=tign(2,1) +! t(fd(1),fd(2))=tign(2,2) +! t(g/2,h/2)=sum(tign(i,i))/4 +! dt/dx=(1/2h)*(t10-t00+t11-t01) +! dt/dy=(1/2h)*(t01-t00+t11-t10) +! approximate T(x,y)=u(1)*x+u(2)*y+u(3) Using finite differences +! t(x,y)=t(h/2,h/2)+(x-h/2)*dt/dx+(y-h/2)*dt/dy +! u(1)=dt/dx +! u(2)=dt/dy +! u(3)=t(h/2,h/2)-h/2(dt/dx+dt/dy) + + tign_middle=(t00+t01+t10+t11)/4 + + ! since mesh_size is 1 we replace fd(1) and fd(2) by 1 + dt_dx=(t10-t00+t11-t01)/2 + dt_dy=(t01-t00+t11-t10)/2 + + u(1)=dt_dx + u(2)=dt_dy + u(3)=tign_middle-(dt_dx+dt_dy)/2 + +! integrate +u(1)=-u(1)/fuel_time_cell +u(2)=-u(2)/fuel_time_cell +u(3)=-u(3)/fuel_time_cell + s1=u(1) + s2=u(2) + out=exp(u(3))*intexp(s1)*intexp(s2) + area=1 + if ( out<0 .or. out>1.0 ) then + call message('WARNING: fuel_left_cell: case all burning: out should be between 0 and 1') + end if +!*** case 1,2,3- other cases +!*** part of cell is burning +else + ! set xx, yy for the coner points + ! move these values out of i and j loop to speed up + ! comments for xx, yy - make center [0,0], cyclic, counterclockwise + ! comments for lfn,tign - cyclic, counterclockwise + xx(1) = -0.5 + xx(2) = 0.5 + xx(3) = 0.5 + xx(4) = -0.5 + xx(5) = -0.5 + yy(1) = -0.5 + yy(2) = -0.5 + yy(3) = 0.5 + yy(4) = 0.5 + yy(5) = -0.5 + lfn(1)=lfn00 + lfn(2)=lfn10 + lfn(3)=lfn11 + lfn(4)=lfn01 + lfn(5)=lfn00 + tign(1)=t00 + tign(2)=t10 + tign(3)=t11 + tign(4)=t01 + tign(5)=t00 + npoint = 0 ! number of points in polygon + + do k=1,4 + lfn0=lfn(k ) + lfn1=lfn(k+1) + if ( lfn0 <= 0.0 ) then + npoint = npoint + 1 + xylist(npoint,1)=xx(k) ! add corner to list + xylist(npoint,2)=yy(k) + tlist(npoint)=-tign(k) ! time since ignition + llist(npoint)=lfn0 + end if + if ( lfn0*lfn1 < 0 ) then + npoint = npoint + 1 +! coordinates of intersection of the fire line with segment k k+1 +! lfn(t)=lfn0+t*(lfn1-lfn0)=0 + tt=lfn0/(lfn0-lfn1) + x0=xx(k)+( xx(k+1)-xx(k) )*tt + y0=yy(k)+( yy(k+1)-yy(k) )*tt + xylist(npoint,1)=x0 + xylist(npoint,2)=y0 + tlist(npoint)=0 ! now at ignition + llist(npoint)=0 ! on fireline + end if + end do + + ! make the list circular and trim to size + tlist(npoint+1)=tlist(1) + llist(npoint+1)=llist(1) + xylist(npoint+1,1)=xylist(1,1) + xylist(npoint+1,2)=xylist(1,2) + +! approximate L(x,y)=u(1)*x+u(2)*y+u(3) + lfn_middle=(lfn00+lfn01+lfn10+lfn11)/4 + dt_dx=(lfn10-lfn00+lfn11-lfn01)/2 + dt_dy=(lfn01-lfn00+lfn11-lfn10)/2 + u(1)=dt_dx + u(2)=dt_dy + u(3)=lfn_middle-(dt_dx+dt_dy)/2 +! finding the coefficient c, reminder we work over one subcell only +! T(x,y)=c*L(x,y)+time_now + a=0 + b=0 + + if (lfn00 <= 0) then + a=a+lfn00*lfn00 + if (t00 < 0) then + call crash('fuel_burnt_fd: tign(i1) should be less then time_now') + else + b=b+t00*lfn00 + end if + end if + + + if (lfn01 <= 0) then + a=a+lfn01*lfn01 + if (t01< 0) then + call crash('fuel_burnt_fd: tign(i1) should be less then time_now') + else + b=b+t01*lfn01 + end if + end if + + + if (lfn10<=0) then + a=a+lfn10*lfn10 + if (t10<0) then + call crash('fuel_burnt_fd: tign(i1) should be less then time_now') + else + b=b+t10*lfn10 + end if + end if + + if (lfn11<=0) then + a=a+lfn11*lfn11 + if (t11<0) then + call crash('fuel_burnt_fd: tign(i1) should be less then time_now') + else + b=b+t11*lfn11 + end if + end if + + + if (a==0) then + call crash('fuel_burnt_fd: if c is on fire then one of cells should be on fire') + end if + c=b/a + u(1)=u(1)*c + u(2)=u(2)*c + u(3)=u(3)*c + + ! rotate to gradient on x only + nr = sqrt(u(1)**2+u(2)**2) + if(.not.nr.gt.eps)then + out=1. + goto 900 + endif + c = u(1)/nr + s = u(2)/nr +! rotation such that Q*u(1:2)-[something;0] + mQ(1,1)=c + mQ(1,2)=s + mQ(2,1)=-s + mQ(2,2)=c + ! mat vec multiplication + call matvec(mQ,2,2,u,3,ut,2,2,2) + errQ = ut(2) ! should be zero + ae = -ut(1)/fuel_time_cell + ce = -u(3)/fuel_time_cell ! -T(xt,yt)/fuel_time=ae*xt+ce + cet=ce!keep ce for later + call matmatp(xylist,8,2,mQ,2,2,xytlist,8,2,npoint+1,2,2) + call sortxt( xytlist, 8,2, xt,8,npoint ) !sort ascending in x + out=0.0 + aupp=0.0 + cupp=0.0 + alow=0.0 + clow=0.0 + do k=1,npoint-1 + xt1=xt(k) + xt2=xt(k+1) + upper=0 + lower=0 + ah=0 + ch=0 + if ( xt2-xt1 > eps*100 ) then +! slice of nonzero width +! find slice height as h=ah*x+ch + do ss=1,npoint ! pass counterclockwise + xts=xytlist(ss,1) ! start point of the line + yts=xytlist(ss,2) + xte=xytlist(ss+1,1) ! end point of the line + yte=xytlist(ss+1,2) + + if ( (xts>xt1 .and. xte>xt1) .or. & + (xtsxt1 .and. xte>xt1) + end do ! ss + ce=cet !use stored ce +!shift small amounts exp(-**) to avoid negative fuel burnt + if (ae*xt1+ce > 0 ) then + ce=ce-(ae*xt1+ce)! + end if + if (ae*xt2+ce > 0) then + ce=ce-(ae*xt2+ce) + end if + + ah = aupp-alow + ch = cupp-clow + ! integrate (ah*x+ch)*(1-exp(ae*x+ce) from xt1 to xt2 + ! numerically sound for ae->0, ae -> infty + ! this can be important for different model scales + ! esp. if someone runs the model in single precision!! + ! s1=int((ah*x+ch),x,xt1,xt2) + s1 = (xt2-xt1)*((1./2.)*ah*(xt2+xt1)+ch) + ! s2=int((ch)*(-exp(ae*x+ce)),x,xt1,xt2) + ceae=ce/ae; + s2 = -ch*exp(ae*(xt1+ceae))*(xt2-xt1)*intexp(ae*(xt2-xt1)) + ! s3=int((ah*x)*(-exp(ae*x+ce)),x,xt1,xt2) + ! s3=int((ah*x)*(-exp(ae*(x+ceae))),x,xt1,xt2) + ! expand in Taylor series around ae=0 + ! collect(expand(taylor(int(x*(-exp(ae*(x+ceae))),x,xt1,xt2)*ae^2,ae,4)/ae^2),ae) + ! =(1/8*xt1^4+1/3*xt1^3*ceae+1/4*xt1^2*ceae^2-1/8*xt2^4-1/3*xt2^3*ceae-1/4*xt2^2*ceae^2)*ae^2 + ! + (-1/3*xt2^3-1/2*xt2^2*ceae+1/3*xt1^3+1/2*xt1^2*ceae)*ae + ! + 1/2*xt1^2-1/2*xt2^2 + ! + ! coefficient at ae^2 in the expansion, after some algebra + a2=(xt1-xt2)*((1./4.)*(xt1+xt2)*ceae**2+(1./3.)* & + (xt1**2+xt1*xt2+xt2**2)*ceae+(1./8.)* & + (xt1**3+xt1*(xt2**2)+xt1**2*xt2+xt2**3)) + d=(ae**4)*a2 + + if (abs(d)>eps) then + ! since ae*xt1+ce<=0 ae*xt2+ce<=0 all fine for large ae + ! for ae, ce -> 0 rounding error approx eps/ae^2 + s3=( exp(ae*(xt1+ceae))*(ae*xt1-1)-& + exp(ae*(xt2+ceae))*(ae*xt2-1) )/(ae**2) + + !we do not worry about rounding as xt1 -> xt2, then s3 -> 0 + else + ! coefficient at ae^1 in the expansion + a1=(xt1-xt2)*((1./2.)*ceae*(xt1+xt2)+(1./3.)*& + (xt1**2+xt1*xt2+xt2**2)) + ! coefficient at ae^0 in the expansion for ae->0 + a0=(1./2.)*(xt1-xt2)*(xt1+xt2) + s3=a0+a1*ae+a2*ae**2; ! approximate the integral + end if + + s3=ah*s3 + out=out+s1+s2+s3 + if(out<0. .or. out>1.) then + write(msg,'(a,g14.4,a)')'WARNING::fuel_fraction ',out,' should be between 0 and 1' + end if!print + if(out.ne.out.or..not.out.le.huge(out).or..not.out.ge.-huge(out)) call crash('fuel_fraction out is not a valid number') + + end if + end do ! k + + out=1-out !fuel_left +end if ! if case0, elseif case4 ,else case123 + +900 continue +fuel_frac_left = out +fire_frac_area= area +if(isnotfinite(fuel_frac_left)) call crash('fuel_frac_left is not a valid number') +if(isnotfinite(fire_frac_area)) call crash('fire_frac_area is not a valid number') +end subroutine fuel_left_cell_2 + + + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +real function intexp(ab) +implicit none +DREAL::ab +!calls +intrinsic epsilon + +real, parameter:: zero=0.,one=1.,eps=epsilon(zero) + +!eps = 2.2204*(10.0**(-8))!from matlab +if ( eps < abs(ab)**3/6. ) then + intexp=(exp(ab)-1)/ab + else + intexp=1+ab/2. +end if +end function intexp +! +!**************************************** +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +!**************************************** +! + + +! +!**************************************** + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +subroutine sortxt(xytlist,nrow,ncolumn,xt,nxt,nvec) +implicit none +integer::nrow,ncolumn,nxt,nvec +DREAL,dimension(nrow,ncolumn)::xytlist +DREAL,dimension(nxt)::xt + +integer::i,j +DREAL::temp + +do i=1,nvec + xt(i)=xytlist(i,1) +end do + +do i=1,nvec-1 + do j=i+1,nvec + if ( xt(i) > xt(j) ) then + temp = xt(i) + xt(i)=xt(j) + xt(j)=temp + end if + end do +end do + +end subroutine sortxt +! +!**************************************** +! +subroutine matvec(A,m,n,V,nv,out,nout,nrow,ncolumn) +implicit none +integer::m,n,nv,nout,nrow,ncolumn +DREAL,dimension(m,n)::A ! allocated m by n +DREAL,dimension(nv)::V ! allocated nv +DREAL,dimension(nout)::out! allocated nout + +integer::i,j + +do i=1,nrow + out(i)=0.0 + do j=1,ncolumn + out(i)=out(i)+A(i,j)*V(j) + end do +end do +end subroutine +! +!**************************************** +! +subroutine matmatp(A,mA,nA,B,mB,nB,C,mC,nC,nrow,ncolumn,nP) +implicit none +integer::mA,nA,mB,nB,mC,nC,nrow,ncolumn,nP +DREAL,dimension(mA,nA)::A ! allocated m by n +DREAL,dimension(mB,nB)::B ! allocated m by n +DREAL,dimension(mC,nC)::C ! allocated m by n +integer::i,j,k +do i=1,nrow + do j=1,ncolumn + C(i,j)=0.0 + do k=1,nP + C(i,j)=C(i,j)+A(i,k)*B(j,k) ! B' + end do +end do +end do +end subroutine + +! +!**************************************** +! + +subroutine prop_ls( id, & ! for debug + ipart, & ! 1:compute lfn_out 2:tign & speedcheck + ids,ide,jds,jde, & ! domain dims + ims,ime,jms,jme, & ! memory dims + ips,ipe,jps,jpe, & ! patch - nodes owned by this process + its,ite,jts,jte, & ! tile dims + ts,dt,dx,dy, & ! scalars in + tbound, & ! scalars out + lfn_in,lfn_out,tign,ros, & ! arrays inout + fp & + ) +implicit none + +!*** purpose: advance level function in time + +! Jan Mandel August 2007 - February 2008 + +!*** description +! +! Propagation of closed curve by a level function method. The level function +! lfn is defined by its values at the nodes of a rectangular grid. +! The area where lfn < 0 is inside the curve. The curve is +! described implicitly by lfn=0. Points where the curve intersects gridlines +! can be found by linear interpolation from nodes. +! +! The level function is advanced from time ts to time ts + dt. +! +! The level function should be initialized to (an approximation of) the signed +! distance from the curve. If the initial curve is a circle, the initial level +! function is simply the distance from the center minus the radius. +! +! The curve moves outside with speed given by function speed_func. +! +! Method: Godunov/ENO method for the normal motion. The timestep is checked for +! CFL condition. For a straight segment in a constant field and locally linear +! level function, the method reduces to the exact normal motion. The advantage of +! the level set method is that it treats automatically special cases such as +! the curve approaching itself and merging components of the area inside the curve. +! +! Based on S. Osher and R. Fedkiw, Level set methods and dynamic implicit surfaces, +! Springer, 2003, Sec. 6.4, as implemented in toolboxLS for Matlab by +! I. Mitchell, A toolbox of Level Set Methods (Version 1.1), TR-2007-11, +! Dept. Computer Science, University of British Columbia, 2007 +! http://www.cs.ubc.ca/\~mitchell/Toolbo\LS +! + +!*** arguments + +! id in unique identification for prints and dumps +! ipart in 1:compute lfn_out 2:tign & speedcheck +! *** must call halo on lfn_out between part 1 and part 2*** +! ids,ide,jds,jde in domain dimensions +! ims,ime,jms,jme in memory dimensions +! its,ite,jts,jte in tile dimensions +! ts in start time +! dt in time step +! dx,dy in grid spacing +! tbound out bound on stable time step from CFL condition, if tbound>=dt then OK +! lfn_in,lfn_out inout,out the level set function at nodes +! tign inout the ignition time at nodes + +! The dimensions are cell-based, the nodal value is associated with the south-west corner. +! The whole computation is on domain indices ids:ide+1,jds:jde+1. +! +! The region where new lfn and tign are computed is the tile its:ite,jts:jte +! except when the tile is at domain upper boundary, an extra band of points is added: +! if ite=ide then region goes up to ite+1, if jte=jde then region goes up to jte+1. + +! The time step requires values from 2 rows of nodes beyond the region except when at the +! domain boundary one-sided derivatives are used. This is implemented by extending the input +! beyond the domain boundary so sufficient memory bounds must be allocated. +! The update on all tiles can be done in parallel. To avoid the race condition (different regions +! of the same array updated by different threads), the in and out versions of the +! arrays lft and tign are distinct. If the time step dt is larger +! that the returned tbound, the routine should be called again with timestep td<=tbound, and then +! having distinct inputs and outputs comes handy. + +!*** calls +! +! tend_ls +! + +integer,intent(in)::id,ipart,ims,ime,jms,jme,ids,ide,jds,jde,its,ite,jts,jte,ips,ipe,jps,jpe +real,dimension(ims:ime,jms:jme),intent(inout)::lfn_in,tign +real,dimension(ims:ime,jms:jme),intent(out)::lfn_out,ros +real,intent(in)::dx,dy,ts,dt +real,intent(out)::tbound +type(fire_params),intent(in)::fp + +!*** local +! arrays +#define IMTS its-1 +#define IMTE ite+1 +#define JMTS jts-1 +#define JMTE jte+1 +real,dimension(IMTS:IMTE,JMTS:JMTE):: tend, lfn1 ! region-sized with halo +! scalars +real::grad2,rr,tbound2,a,a1 ! a=0 euler, a=0.5 heun + +real::gradx,grady,aspeed,err,aerr,time_future,time_now +real::tmp,t0,t1,t2 +integer::ihs,ihe,jhs,jhe +integer::ihs2,ihe2,jhs2,jhe2 +integer::itso,iteo,jtso,jteo +integer::i,j,its1,ite1,jts1,jte1,k,kk,id1 +character(len=128)::msg +integer::nfirenodes,nfireline,ierrx +real::sum_err,min_err,max_err,sum_aerr,min_aerr,max_aerr + +! constants +integer,parameter :: mstep=1000, printl=1 +real, parameter:: zero=0.,one=1.,eps=epsilon(zero),tol=100*eps, & + safe=2.,rmin=safe*tiny(zero),rmax=huge(zero)/safe + +! f90 intrinsic function + +intrinsic max,min,sqrt,nint,epsilon,tiny,huge + +!*** executable + +!$OMP CRITICAL(SFIRE_CORE_CRIT) +write(msg,'(a,i6,a,i2,4(a,i5))')'prop_ls:',id,' part',ipart,' tile',its,':',ite,',',jts,':',jte +!$OMP END CRITICAL(SFIRE_CORE_CRIT) +call message(msg) + +if (ipart==1)then +! lfn_in -> lfn_out + + call check_lfn_tign('prop_ls start',ts,its,ite,jts,jte,ims,ime,jms,jme,lfn_in,tign) + + a=fire_back_weight ! from module_fr_sfire_util + a1=1. - a + + ! tend = F(lfn) + + ihs2=max(its-2,ids) ! need lfn two beyond the tile but not outside the domain + ihe2=min(ite+2,ide) + jhs2=max(jts-2,jds) + jhe2=min(jte+2,jde) + + ihs=max(its-1,ids) ! compute tend one beyond the tile but not outside the domain + ihe=min(ite+1,ide) + jhs=max(jts-1,jds) + jhe=min(jte+1,jde) + + +#ifdef DEBUG_OUT + call write_array_m(ihs,ihe,jhs,jhe,ims,ime,jms,jme,lfn_in,'lfn_in',id) +#endif + + ! check array dimensions + call check_mesh_2dim(ihs2,ihe2,jhs2,jhe2,ims,ime,jms,jme) + call print_2d_stats(ihs2,ihe2,jhs2,jhe2,ims,ime,jms,jme,lfn_in,'prop_ls: lfn in') + + ! NOTE: tend_ls will extrapolate to one node strip at domain boundaries + ! so that it can compute gradient at domain boundaries. + ! To avoid copying, lfn_in is declared inout. + ! At tile boundaries that are not domain boundaries values of lfn_in two nodes + ! outside of the tile are needed. + id1 = id ! for debug prints + if(id1.ne.0)id1=id1+1000 + call tend_ls( id1, & + ims,ime,jms,jme, & ! memory dims for lfn_in + IMTS,IMTE,JMTS,JMTE, & ! memory dims for tend + ids,ide,jds,jde, & ! domain dims - where lfn exists + ips,ipe,jps,jpe, & ! patch - nodes owned by this process + ihs,ihe,jhs,jhe, & ! where tend computed + ims,ime,jms,jme, & ! memory dims for ros + its,ite,jts,jte, & ! tile dims - where to set ros + ts,dt,dx,dy, & ! scalars in + lfn_in, & ! arrays in + tbound, & ! scalars out + tend, ros, & ! arrays out + fp & ! params +) + +#ifdef DEBUG_OUT + call write_array_m(ihs,ihe,jhs,jhe,IMTS,IMTE,JMTS,JMTE,tend,'tend1',id) +#endif + + ! Euler method, the half-step, same region as ted + do j=jhs,jhe + do i=ihs,ihe + lfn1(i,j) = lfn_in(i,j) + dt*tend(i,j) + enddo + enddo + + call print_2d_stats(ihs,ihe,jhs,jhe,IMTS,IMTE,JMTS,JMTE,lfn1,'prop_ls: lfn1') + ! tend = F(lfn1) on the tile (not beyond) + + if(id1.ne.0)id1=id1+1000 + call tend_ls( id1,& + IMTS,IMTE,JMTS,JMTE, & ! memory dims for lfn + IMTS,IMTE,JMTS,JMTE, & ! memory dims for tend + ids,ide,jds,jde, & ! domain dims - where lfn exists + ips,ipe,jps,jpe, & ! patch - nodes owned by this process + its,ite,jts,jte, & ! tile dims - where is tend computed + ims,ime,jms,jme, & ! memory dims for ros + its,ite,jts,jte, & ! tile dims - where is ros set + ts+dt,dt,dx,dy, & ! scalars in + lfn1, & ! arrays in + tbound2, & ! scalars out + tend,ros, & ! arrays out + fp & +) + +#ifdef DEBUG_OUT + call write_array_m(its,ite,jts,jte,IMTS,IMTE,JMTS,JMTE,tend,'tend2',id) +#endif + + call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme, ros,'prop_ls: ros') + call print_2d_stats(its,ite,jts,jte,IMTS,IMTE,JMTS,JMTE,tend,'prop_ls: tend2') + + tbound=min(tbound,tbound2) + +!$OMP CRITICAL(SFIRE_CORE_CRIT) + write(msg,'(a,f10.2,4(a,f7.2))')'prop_ls: time',ts,' dt=',dt,' bound',min(tbound,999.99), & + ' dx=',dx,' dy=',dy +!$OMP END CRITICAL(SFIRE_CORE_CRIT) + call message(msg) + if(dt>tbound)then +!$OMP CRITICAL(SFIRE_CORE_CRIT) + write(msg,'(2(a,f10.2))')'prop_ls: WARNING: time step ',dt, & + ' > bound =',tbound +!$OMP END CRITICAL(SFIRE_CORE_CRIT) + call message(msg) + endif + + ! combine lfn1 and lfn_in + dt*tend -> lfn_out + + do j=jts,jte + do i=its,ite + lfn_out(i,j) = a1*lfn1(i,j) + a*(lfn_in(i,j) + dt*tend(i,j)) + lfn_out(i,j) = min(lfn_out(i,j),lfn_in(i,j)) ! fire area can only increase + enddo + enddo + +elseif(ipart==2)then + + call continue_at_boundary(1,1,zero, & !ext + ims,ime,jms,jme, & ! memory dims + ids,ide,jds,jde, & ! domain - nodes where lfn defined + ips,ipe,jps,jpe, & ! patch - nodes owned by this process + its,ite,jts,jte, & ! tile - nodes update by this thread + itso,iteo,jtso,jteo, & ! where set now + lfn_out ) ! array + + ! copy to use consistently old values + do j=jts,jte + do i=its,ite + lfn1(i,j)=lfn_out(i,j) + enddo + enddo + + !fix up lfn_out - no new local minima + do j=jts,jte + do i=its,ite + t0=min(lfn_in(i+1,j),lfn_in(i-1,j),lfn_in(i,j+1),lfn_in(i,j-1)) + t1=min(lfn1(i+1,j),lfn1(i-1,j),lfn1(i,j+1),lfn1(i,j-1)) + if(.not.t0>lfn_in(i,j) .and. t1>lfn_out(i,j))then + if(fire_print_msg>2)then +!$OMP CRITICAL(SFIRE_CORE_CRIT) + write(msg,'(a,2i6)')'prop_ls: new local min',i,j + call message(msg) + write(msg,'((a,g13.5,1x))') & + 'prop_ls: new local min',lfn_out(i,j),'fixed to',t1,'incr',t1-lfn_in(i,j) + call message(msg) +!$OMP END CRITICAL(SFIRE_CORE_CRIT) + endif + lfn_out(i,j)=t1 + endif + enddo + enddo + + ! compute ignition time by interpolation + ! the node was not burning at start but it is burning at end + ! interpolate from the level functions at start and at end + ! lfn_in is the level set function value at time ts + ! lfn_out is the level set function value at time ts+dt + ! 0 is the level set function value at time tign(i,j) + ! thus assuming the level function is approximately linear => + ! tign(i,j)= ts + ((ts + td) - ts) * lfn_in / (lfn_in - lfn_out) + ! = ts + dt * lfn_in / (lfn_in - lfn_out) + ! = (ts + dt) + dt * lfn_out / (lfn_in - lfn_out) + ! the second form is better because we want make sure tign < ts+dt (used only for lfn_out < 0) + + time_now=ts+dt + time_future=ts+2*dt + do j=jts,jte + do i=its,ite + call check_lfn_tign_ij(i,j,'prop_ls before',ts,lfn_in(i,j),tign(i,j)) + if (lfn_out(i,j) < 0. ) then ! now on fire + if( .not. lfn_in(i,j) < 0) then ! was not before, set ignition time by interpolation + tign(i,j) = time_now + dt * lfn_out(i,j) / (lfn_in(i,j) - lfn_out(i,j)) + ! tmp = max(tmp,abs(ts + dt * lfn_in(i,j) / (lfn_in(i,j) - lfn_out(i,j)) - tign(i,j))) + endif ! was already burning, leave ignition time unchanged + else ! set the ignition time outside of burning region + tign(i,j)=time_future + endif + call check_lfn_tign_ij(i,j,'prop_ls after',time_now,lfn_out(i,j),tign(i,j)) + ! lfn_out(i,j) = max(lfn_out(i,j),-100.0) ! stability fix + enddo + enddo + ! write(msg,*)'prop_ls: tign err',tmp + ! call message(msg) + + ! check local speed error and stats + ! may not work correctly in parallel + ! init stats + nfirenodes=0 + nfireline=0 + sum_err=0. + min_err=rmax + max_err=rmin + sum_aerr=0. + min_aerr=rmax + max_aerr=rmin + its1=its+1 + jts1=jts+1 + ite1=ite-1 + jte1=jte-1 + ! loop over right inside of the domain + ! cannot use values outside of the domain, would have to reflect and that + ! would change lfn_out + ! cannot use values outside of tile, not synchronized yet + ! so in parallel mode the statistics is not accurate + do j=jts1,jte1 + do i=its1,ite1 + if(lfn_out(i,j)>0.0)then ! a point out of burning region + if(lfn_out(i+1,j)<=0.or.lfn_out(i,j+1)<=0.or. & ! neighbor in burning region + lfn_out(i-1,j)<=0.or.lfn_out(i,j-1)<=0)then ! point next to fireline + gradx=(lfn_out(i+1,j)-lfn_out(i-1,j))/(2.0*dx) ! central differences + grady=(lfn_out(i,j+1)-lfn_out(i,j-1))/(2.0*dy) + grad2=sqrt(gradx*gradx+grady*grady) + aspeed = (lfn_in(i,j)-lfn_out(i,j))/(dt*max(grad2,rmin)) + rr = speed_func(gradx,grady,dx,dy,i,j,fp,ierrx,msg) + err=aspeed-rr + sum_err=sum_err+err + min_err=min(min_err,err) + max_err=max(max_err,err) + aerr=abs(err) + sum_aerr=sum_aerr+aerr + min_aerr=min(min_aerr,aerr) + max_aerr=max(max_aerr,aerr) + nfireline=nfireline+1 + endif + else + nfirenodes=nfirenodes+1 + endif + enddo + enddo +!$OMP CRITICAL(SFIRE_CORE_CRIT) + write(msg,'(2(a,i6,f8.4))')'prop_ls: nodes burning',nfirenodes, & + (100.*nfirenodes)/((ite1-its1+1)*(jte1-jts1+1)),'% next to fireline',nfireline +!$OMP END CRITICAL(SFIRE_CORE_CRIT) + call message(msg) +! if(nfireline>0)then +! call print_stat_line('speed error',its1,ite1,jts1,jte1,min_err,max_err,sum_err/nfireline) +! call print_stat_line('abs(speed error)',its1,ite1,jts1,jte1,min_aerr,max_aerr,sum_aerr/nfireline) +! endif + + ! check if the fire did not get to the domain boundary + do k=-1,1,2 + ! do kk=1,(boundary_guard*(ide-ids+1))/100 ! in % + do kk=1,boundary_guard ! measured in cells + i=ids+k*kk + if(i.ge.its.and.i.le.ite)then + do j=jts,jte + if(lfn_out(i,j)<=0.)goto 9 + enddo + endif + enddo + ! do kk=1,(boundary_guard*(jde-jds+1))/100 + do kk=1,boundary_guard ! measured in cells + j=jds+k*kk + if(j.ge.jts.and.j.le.jte)then + do i=its,ite + if(lfn_out(i,j)<=0.)goto 9 + enddo + endif + enddo + enddo + goto 10 +9 continue +!$OMP CRITICAL(SFIRE_CORE_CRIT) + write(msg,'(a,i2,a,2i8)')'prop_ls: fire',boundary_guard, & + ' cells from domain boundary at node ',i,j +!$OMP END CRITICAL(SFIRE_CORE_CRIT) + call message(msg) + call crash('prop_ls: increase the fire region') +10 continue + + call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme, lfn_out,'prop_ls: lfn out') + call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme, tign,'prop_ls: tign out') + + call check_lfn_tign('prop_ls end',ts+dt,its,ite,jts,jte,ims,ime,jms,jme,lfn_out, tign) + +else + call crash('prop_ls: ipart must be 1 or 2') +endif +end subroutine prop_ls + +! +!***************************** +! + +subroutine tend_ls( id, & + lims,lime,ljms,ljme, & ! memory dims for lfn + tims,time,tjms,tjme, & ! memory dims for tend + ids,ide,jds,jde, & ! domain - nodes where lfn defined + ips,ipe,jps,jpe, & ! patch - nodes owned by this process + ints,inte,jnts,jnte, & ! region - nodes where tend computed + ims,ime,jms,jme, & ! memory dims for ros + its,ite,jts,jte, & ! tile dims - where is ros set + t,dt,dx,dy, & ! scalars in + lfn, & ! arrays in + tbound, & ! scalars out + tend, ros, & ! arrays out + fp & +) + +implicit none +! purpose +! compute the right hand side of the level set equation + +!*** arguments +integer,intent(in)::id,lims,lime,ljms,ljme,tims,time,tjms,tjme +integer,intent(in)::ims,ime,jms,jme,its,ite,jts,jte +integer, intent(in)::ids,ide,jds,jde,ints,inte,jnts,jnte,ips,ipe,jps,jpe +real,intent(in)::t ! time +real,intent(in)::dt,dx,dy ! mesh step +real,dimension(lims:lime,ljms:ljme),intent(inout)::lfn ! level set function +real,intent(out)::tbound ! max allowed time step +real,dimension(tims:time,tjms:tjme),intent(out)::tend ! tendency (rhs of the level set pde) +real,dimension(ims:ime,jms:jme),intent(out)::ros ! rate of spread +type(fire_params),intent(in)::fp + +!*** local +real:: te,diffLx,diffLy,diffRx,diffRy, & + diffCx,diffCy,diff2x,diff2y,grad,rr, & + ros_back,ros_wind,ros_slope,advx,advy,scale,nvx,nvy,speed +integer::i,j,itso,iteo,jtso,jteo,ierrx,nerr +character(len=128)msg,msg2 + +! constants +real, parameter:: eps=epsilon(0.0) +!intrinsic epsilon +real, parameter:: zero=0.,one=1.,tol=100*eps, & + safe=2.,rmin=safe*tiny(zero),rmax=huge(zero)/safe + + +! f90 intrinsic function + +intrinsic max,min,sqrt,nint,tiny,huge + +!*** executable + + ! check array dimensions + call check_mesh_2dim(ints-1,inte+1,jnts-1,jnte+1,lims,lime,ljms,ljme) + call check_mesh_2dim(ints,inte,jnts,jnte,tims,time,tjms,tjme) + + call continue_at_boundary(1,1,fire_lfn_ext_up, & !extend by extrapolation but never down + lims,lime,ljms,ljme, & ! memory dims + ids,ide,jds,jde, & ! domain - nodes where lfn defined + ips,ipe,jps,jpe, & ! patch - nodes owned by this process + ints,inte,jnts,jnte, & ! tile - nodes update by this thread + itso,iteo,jtso,jteo, & ! where set now + lfn) ! array + + call print_2d_stats(itso,iteo,jtso,jteo,lims,lime,ljms,ljme, & + lfn,'tend_ls: lfn cont') + +#ifdef DEBUG_OUT + call write_array_m(ints-1,inte+1,jnts-1,jnte+1,lims,lime,ljms,ljme,lfn,'tend_lfn_in',id) +#endif + + nerr=0 + tbound=0 + do j=jnts,jnte + do i=ints,inte + ! one sided differences + diffRx = (lfn(i+1,j)-lfn(i,j))/dx + diffLx = (lfn(i,j)-lfn(i-1,j))/dx + diffRy = (lfn(i,j+1)-lfn(i,j))/dy + diffLy = (lfn(i,j)-lfn(i,j-1))/dy + diffCx = diffLx+diffRx ! TWICE CENTRAL DIFFERENCE + diffCy = diffLy+diffRy + + !upwinding - select right or left derivative + select case(fire_upwinding) + case(0) ! none + grad=sqrt(diffCx**2 + diffCy**2) + case(1) ! standard + diff2x=select_upwind(diffLx,diffRx) + diff2y=select_upwind(diffLy,diffRy) + grad=sqrt(diff2x*diff2x + diff2y*diff2y) + case(2) ! godunov per osher/fedkiw + diff2x=select_godunov(diffLx,diffRx) + diff2y=select_godunov(diffLy,diffRy) + grad=sqrt(diff2x*diff2x + diff2y*diff2y) + case(3) ! eno + diff2x=select_eno(diffLx,diffRx) + diff2y=select_eno(diffLy,diffRy) + grad=sqrt(diff2x*diff2x + diff2y*diff2y) + case(4) ! Sethian - twice stronger pushdown of bumps + grad=sqrt(max(diffLx,0.)**2+min(diffRx,0.)**2 & + + max(diffLy,0.)**2+min(diffRy,0.)**2) + case default + grad=0. + end select + + ! normal direction, from central differences + scale=sqrt(diffCx*diffCx+diffCy*diffCy+eps) + nvx=diffCx/scale + nvy=diffCy/scale + + ! wind speed in direction of spread + ! speed = vx(i,j)*nvx + vy(i,j)*nvy + + + ! get rate of spread from wind speed and slope + + call fire_ros(ros_back,ros_wind,ros_slope, & + nvx,nvy,i,j,fp,ierrx,msg2) + nerr = nerr + ierrx + + rr=ros_back + ros_wind + ros_slope + if(fire_grows_only.gt.0)rr=max(rr,0.) + + ! set ros for output + if(i.ge.its.and.i.le.ite.and.j.ge.jts.and.j.le.jte)ros(i,j)=rr + + ! get rate of spread + te = -rr*grad ! normal term + + ! cfl condition + if (grad > 0.) then + tbound = max(tbound,rr*(abs(diff2x)/dx+abs(diff2y)/dy)/grad) + endif + + ! add numerical viscosity + te=te + fire_viscosity*abs(rr)*((diffRx-diffLx)+(diffRy-diffLy)) + + tend(i,j)=te + enddo + enddo + + if(nerr>0)then +!$OMP CRITICAL(SFIRE_CORE_CRIT) + write(msg,'(a,i6,1x,a)')'tend_ls:',nerr,'messages in rate of spread computations. Last message:' +!$OMP END CRITICAL(SFIRE_CORE_CRIT) + call warning(msg) + call warning(msg2) + endif + + call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme, ros,'tend_ls: ros') + call print_2d_stats(ints,inte,jnts,jnte,tims,time,tjms,tjme, & + tend,'tend_ls: tend out') + + ! the final CFL bound + tbound = 1/(tbound+tol) + +end subroutine tend_ls + +! +!************************** +! + +real function select_upwind(diffLx,diffRx) +implicit none +real, intent(in):: diffLx, diffRx +real diff2x + +! upwind differences, L or R if bith same sign, otherwise zero + +diff2x=0 +if (diffLx>0.and.diffRx>0.)diff2x=diffLx +if (diffLx<0.and.diffRx<0.)diff2x=diffRx + +select_upwind=diff2x +end function select_upwind + + +! +!************************** +! + + +real function select_godunov(diffLx,diffRx) +implicit none +real, intent(in):: diffLx, diffRx +real diff2x,diffCx + +! Godunov scheme: upwind differences, L or R or none +! always test on > or < never = , much faster because of IEEE +! central diff >= 0 => take left diff if >0, ortherwise 0 +! central diff <= 0 => take right diff if <0, ortherwise 0 + +diff2x=0 +diffCx=diffRx+diffLx +if (diffLx>0.and..not.diffCx<0)diff2x=diffLx +if (diffRx<0.and. diffCx<0)diff2x=diffRx + +select_godunov=diff2x +end function select_godunov + +! +!************************** +! + +real function select_eno(diffLx,diffRx) +implicit none +real, intent(in):: diffLx, diffRx +real diff2x + +! 1st order ENO scheme + +! diffLx <= 0 and diffRx <= 0: diffRx +! diffLx >= 0 and diffRx >= 0: diffLx +! diffLx >= 0 and diffRx <= 0: +! diffRx + diffLx <= 0: diffRx +! diffRx + diffLx > 0: diffLx + + +if (.not.diffLx>0 .and. .not.diffRx>0)then + diff2x=diffRx +elseif(.not.diffLx<0 .and. .not.diffRx<0)then + diff2x=diffLx +elseif(.not.diffLx<0 .and. .not.diffRx>0)then + if(.not. abs(diffRx) < abs(diffLx))then + diff2x=diffRx + else + diff2x=diffLx + endif +else + diff2x=0. +endif + +select_eno=diff2x +end function select_eno + +! +!************************** +! + +real function speed_func(diffCx,diffCy,dx,dy,i,j,fp,ierrx,msg) +!*** purpose +! the level set method speed function +implicit none +!*** arguments +real, intent(in)::diffCx,diffCy ! x and y coordinates of the direction of propagation +real, intent(in)::dx,dy ! x and y coordinates of the direction of propagation +integer, intent(in)::i,j ! indices of the node to compute the speed at +type(fire_params),intent(in)::fp +integer, intent(out)::ierrx +character(len=*), intent(out)::msg +!*** local +real::scale,nvx,nvy,r +real::ros_back , ros_wind , ros_slope +real, parameter:: eps=epsilon(0.0) +!*** executable + ! normal direction, from central differences + scale=sqrt(diffCx*diffCx+diffCy*diffCy+eps) + nvx=diffCx/scale + nvy=diffCy/scale + + ! get rate of spread from wind speed and slope + + call fire_ros(ros_back,ros_wind,ros_slope, & + nvx,nvy,i,j,fp,ierrx,msg) + + r=ros_back + ros_wind + ros_slope + if(fire_grows_only.gt.0)r=max(r,0.) + speed_func=r + +end function speed_func + +end module module_fr_sfire_core diff --git a/wrfv2_fire/phys/module_fr_sfire_driver.F b/wrfv2_fire/phys/module_fr_sfire_driver.F new file mode 100644 index 00000000..010ef69e --- /dev/null +++ b/wrfv2_fire/phys/module_fr_sfire_driver.F @@ -0,0 +1,1675 @@ + +! SFIRE - Spread fire model in WRF-Fire +! +!*** Jan Mandel August 2007 - March 2011 +!*** email: Jan.Mandel@gmail.com + +! For support please subscribe to the wrf-fire mailing list at NCAR at +! http://mailman.ucar.edu/mailman/listinfo/wrf-fire +! or go to http://www.openwfm.org/wiki/WRF-Fire_user_support + +! Current drafts of the technical documentation and +! user's guide can be found at + +! http://www.openwfm.org/wiki/WRF-Fire_documentation +! http://www.openwfm.org/wiki/WRF-Fire_publications + +! This module is the only entry point from WRF-ARW to the wildland +! fire model. The call to sfire_driver advances the fire model by +! one timestep. The fire model inputs the wind and outputs +! temperature and humidity tendencies. The fire model also inputs a +! number of constant arrays (fuel data, topography). Additional +! arguments are model state (for data assimilation) and constant arrays +! the model gives to WRF for safekeeping because it is not allowed +! to save anything. + +! This code as of mid-2011 is described in [1]. If you use this code, +! please acknowledge our work by citing [1]. +! Thank you. + +! Acknowledgements +! +! The fire physics code is adapted from the CAWFE code [2]. +! The coupling with WRF is adapted from a code by Ned Patton, +! coupling a Fortran 90 port of the CAWFE fire module to WRF [3]. +! Support of refined fire grids in WRF was provided by John Michalakes. +! Jonathan D. Beezley has set up and maintained the WRF build and +! execution environment, provided software engineering infrastructure +! including synchronization with the WRF repository, and was responsibe +! for all aspects of WRF modification. UCD students Minjeong Kim and +! Volodymyr Kondratenko have contributed to the implementation of the +! fire propagation by the level set method. + +! Refefences +! +! [1] Jan Mandel, Jonathan D. Beezley, and Adam K. Kochanski, "Coupled +! atmosphere-wildland fire modeling with WRF 3.3 and SFIRE 2011, +! Geoscientific Model Development (GMD) 4, 591-610, 2011. +! doi:10.5194/gmd-4-591-2011 +! +! [2] T. L. Clark, J. Coen, and D. Latham, Description of a coupled +! atmosphere-fire model, Intl. J. Wildland Fire, vol. 13, pp. 49-64, +! 2004 +! +! [3] Edward G. Patton and Janice L. Coen, WRF-Fire: A Coupled +! Atmosphere-Fire Module for WRF, Preprints of Joint MM5/Weather +! Research and Forecasting Model Users' Workshop, Boulder, CO, +! June 22-25, 2004, pp. 221-223, NCAR +! +! --------------------------------------------- +! +! CURRENT ACTIVITY +! +! For current activity and development trends please check out +! http://ccm.ucdenver.edu/wiki/User:Jmandel/blog +! http://www.openwfm.org/wiki/WRF-Fire_development_notes +! + +module module_fr_sfire_driver +! use this module for standalone call, you only need to provide some mock-up wrf modules + +use module_fr_sfire_model, only: sfire_model +use module_fr_sfire_phys, only: fire_params, init_fuel_cats, fuel_moisture, & + advance_moisture, moisture_classes, & + fire_rate_of_spread +use module_fr_sfire_atm, only: apply_windrf,interpolate_wind2fire_height,interpolate_atm2fire, & + interpolate_z2fire,setup_wind_log_interpolation +use module_fr_sfire_util +!use module_fr_sfire_util, only: lines_type,fire_max_lines +! Driver layer modules +#ifdef DM_PARALLEL + USE module_dm , ONLY : ntasks_x,ntasks_y,local_communicator,mytask,ntasks,wrf_dm_sum_reals + USE module_comm_dm , ONLY : halo_fire_fuel_sub, halo_fire_tign_sub, halo_fire_wind_f_sub, & +halo_fire_wind_a_sub, halo_fire_ph_sub, halo_fire_zsf_sub, halo_fire_longlat_sub, & +halo_fire_phb_sub, halo_fire_z0_sub, halo_fire_lfn_sub, HALO_FIRE_LFN_OUT_sub, & +HALO_FIRE_MAG_sub, HALO_FIRE_MFG_sub, halo_fire_ndwi_sub +#endif +use module_fr_sfire_atm, only: read_emissions_table, add_fire_emissions + + +! WRF dependencies +USE module_domain, only: domain +USE module_configure, only: grid_config_rec_type +use module_model_constants, only: reradius, & ! 1/earth radiusw + pi2 ! 2*pi + +implicit none + + +private +public sfire_driver_em,use_atm_vars,set_flags, & + set_fp_from_grid, fire_ignition_convert +public ifun_beg, ifun_step, ifun_end + +logical:: use_atm_vars=.true. ! interpolate wind from atm mesh and average output fluxes back +logical:: interpolate_long_lat=.true. ! get fxlong fxlat by interpolation + +logical:: fmoist_run, fmoist_interp, fire_run ! which kind of model to run overall + +integer, parameter:: ifun_beg=1, ifun_step=3, ifun_end=6 + +contains + +! to write debugging information +#define DEBUG_OUT + +subroutine sfire_driver_em ( grid , config_flags & + ,time_step_start,dt & + ,fire_ifun_start,fire_ifun_end,tsteps & + ,ids,ide, kds,kde, jds,jde & + ,ims,ime, kms,kme, jms,jme & + ,ips,ipe, kps,kpe, jps,jpe & + ,ifds,ifde, jfds,jfde & + ,ifms,ifme, jfms,jfme & + ,ifps,ifpe, jfps,jfpe & + ,rho,z_at_w,dz8w & +) + +!*** purpose: driver from grid structure + + + + implicit none +!*** arguments + TYPE(domain) , TARGET :: grid ! state + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags ! namelist + real, intent(in):: time_step_start, dt + integer, intent(in):: fire_ifun_start,fire_ifun_end,tsteps ! driver cycle controls + integer, intent(in):: & + ids,ide, kds,kde, jds,jde, & + ims,ime, kms,kme, jms,jme, & + ips,ipe, kps,kpe, jps,jpe, & + ifds,ifde, jfds,jfde, & + ifms,ifme, jfms,jfme, & + ifps,ifpe, jfps,jfpe + real,dimension(ims:ime, kms:kme, jms:jme),intent(in), optional::rho,z_at_w,dz8w + +!*** local + TYPE(lines_type):: ignition, hfx + ! TMG added k + integer::fire_ifun,ir,jr,istep,itimestep,i,ipe1,kpe1,jpe1,j,k + logical::restart,replay + real:: corner_ll,corner_ul,corner_ur,corner_lr, max_u, max_v, max_w, max_rho, min_rho + character(len=128)msg + type(fire_params)::fp + real:: moisture_time + + logical:: run_advance_moisture,run_fuel_moisture, moisture_initializing + real:: dt_moisture + + + +!*** executable + + call sfire_debug_hook(config_flags%fire_debug_hook_sec) + call time_start + if(fire_ifun_start.le.1)call print_id ! print id only once, during initialization + + +! **** THE FOLLOWING REALLY SHOULD BE DONE ONCE NOT EVERY TIMESTEP + +! populate our structures from wrf + + call set_fp_from_grid(grid,fp) + +! copy configuration flags to sfire internal structures + call set_flags(config_flags) + + + ! get ignition data + call fire_ignition_convert (config_flags,ignition, & + grid%fxlong, grid%fxlat, & + ifds,ifde, jfds,jfde, & + ifms,ifme, jfms,jfme, & + ifps,ifpe, jfps,jfpe ) + call fire_hfx_convert (config_flags,hfx) + +! store computed mesh units + grid%unit_fxlong = ignition%unit_fxlong + grid%unit_fxlat = ignition%unit_fxlat + + +#ifndef SFIRE_STANDALONE + +! see what we got from wrf +!! need to replace ipe by min(ide-1,ipe) and similarly jpe + + if(fire_print_msg.ge.2 .and. fire_ifun_start .gt. 1)then + + ipe1=min(ide-1,ipe) + jpe1=min(jde-1,jpe) + kpe1=kpe-1 + +! TMG +! do j=jps,jpe1 +! do k=kps,kpe1 +! do i=ips,ipe1 +! print*, 'Before fun_real j, k, i ', grid%u_2(i,k,j), grid%t2(i,j) +! enddo +! enddo +! enddo + + max_u=fun_real(REAL_AMAX, & + ims,ime,kms,kme,jms,jme, & ! memory dims + ids,ide,kds,kde,jds,jde, & ! domain dims + ips,ipe1,kps,kpe1,jps,jpe1, & ! patch or tile dims + 1,0,0, & ! staggering + grid%u_2,grid%u_2) + + max_v=fun_real(REAL_AMAX, & + ims,ime,kms,kme,jms,jme, & ! memory dims + ids,ide,kds,kde,jds,jde, & ! domain dims + ips,ipe1,kps,kpe1,jps,jpe1, & ! patch or tile dims + 0,0,1, & ! staggering + grid%v_2,grid%v_2) + + max_w=fun_real(REAL_AMAX, & + ims,ime,kms,kme,jms,jme, & ! memory dims + ids,ide,kds,kde,jds,jde, & ! domain dims + ips,ipe1,kps,kpe1,jps,jpe1, & ! patch or tile dims + 0,1,0, & ! staggering + grid%w_2,grid%w_2) + + !write(msg,93)time_step_start,'Maximal u v w wind',max_u,max_v,max_w,'m/s' + !call message(msg,0) + !write(msg,92)time_step_start,'Min and max rho ',min_rho,max_rho,'kg/m^3' + !call message(msg,0) + + write(msg,91)time_step_start,'Maximal u wind ',max_u,'m/s' + call message(msg,0) + write(msg,91)time_step_start,'Maximal v wind ',max_v,'m/s' + call message(msg,0) + write(msg,91)time_step_start,'Maximal w wind ',max_w,'m/s' + call message(msg,0) + + if (present(rho)) then + + max_rho=fun_real(REAL_MAX, & + ims,ime,kms,kme,jms,jme, & ! memory dims + ids,ide,kds,kde,jds,jde, & ! domain dims + ips,ipe1,kps,kpe1,jps,jpe1, & ! patch or tile dims + 0,0,0, & ! staggering + rho,rho) + + min_rho=fun_real(REAL_MIN, & + ims,ime,kms,kme,jms,jme, & ! memory dims + ids,ide,kds,kde,jds,jde, & ! domain dims + ips,ipe1,kps,kpe1,jps,jpe1, & ! patch or tile dims + 0,0,0, & ! staggering + rho,rho) + + + write(msg,91)time_step_start,'Minimal rho ',min_rho,'kg/m^3' + call message(msg,0) + write(msg,91)time_step_start,'Maximal rho ',max_rho,'kg/m^3' + call message(msg,0) + + endif + + +93 format('Time ',f11.3,' s ',a,3e12.3,1x,a) +92 format('Time ',f11.3,' s ',a,2e12.3,1x,a) +91 format('Time ',f11.3,' s ',a,e12.3,1x,a) + + + endif +#endif + + + ! refinement r + ir=grid%sr_x ! refinement ratio + jr=grid%sr_y + write(msg,'(a,2i4)')'fire mesh refinement ratios', ir,jr + call message(msg) + if(ir.le.0.or.jr.le.0)then + call crash('fire mesh refinement ratio must be positive') + endif + itimestep=grid%itimestep + restart=config_flags%restart .or. config_flags%cycling .or. config_flags%fire_restart ! skip state initialization + replay= time_step_start+dt .le. config_flags%fire_perimeter_time + + + + ! **** moisture model + + ! decide what to run - moisture, interpolation, or fire model itself + fmoist_run = config_flags%fmoist_run + fmoist_interp = config_flags%fmoist_interp + if(fire_fmc_read.ne.0.and.fmoist_run)call crash('fmoist_run=T requires fire_fmc_read=0') + fire_run = .not. config_flags%fmoist_only + + !decide what to run + moisture_time = time_step_start + run_advance_moisture = .false. ! default + run_fuel_moisture = .false. ! default + moisture_initializing = fire_ifun_start < 3 + + + + if(fmoist_run)then + if(moisture_initializing)then + if(fire_ifun_end>2)call crash('initialization must be run separately') + grid%fmoist_lasttime=moisture_time ! initialize the last time the model has run to start of run + grid%fmoist_nexttime=moisture_time + call message('moisture initialization') + run_advance_moisture = .true. + else ! regular timestep + if(config_flags%fmoist_freq > 0)then ! regular timestep. go by multiples? + if(mod(grid%itimestep,config_flags%fmoist_freq) .eq. 0)then + write(msg,'(a,i10,a,i10)')'moisture model runs because timestep ',grid%itimestep,' is a multiple of ',config_flags%fmoist_freq + call message(msg) + run_advance_moisture = .true. + endif + else + if(.not. moisture_time < grid%fmoist_nexttime) then ! no, by time interval + write(msg,'(a,f12.2,a)')'moisture model runs because time ',grid%fmoist_nexttime,'s has arrived' + call message(msg) + run_advance_moisture = .true. + endif + endif + if(run_advance_moisture)then ! decide on timing + dt_moisture = moisture_time - grid%fmoist_lasttime ! Time since moisture model run the last time. Should be long. + grid%fmoist_lasttime = moisture_time + if(config_flags%fmoist_freq > 0)then + write(msg,'(a,f12.2,a,i10,a)')'moisture time step is ',dt_moisture,'s running every ',config_flags%fmoist_freq,' steps' + call message(msg) + else + grid%fmoist_nexttime = moisture_time + config_flags%fmoist_dt + write(msg,'(a,f12.2,a,f12.2,a)')'moisture time step is ',dt_moisture,'s next run at ',grid%fmoist_nexttime,'s' + call message(msg) + endif + if(fmoist_interp)then + call message('moisture interpolation to fuels will run because moisture model does') + run_fuel_moisture=.true. + endif + endif + endif + elseif(itimestep.eq.1.and.fmoist_interp)then + call message('initializing, moisture interpolation to fuels will run from input data') + run_fuel_moisture=.true. + endif + +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) + write(msg,'(a,i1,a,i1,a,l1,a,l1)') & + 'sfire_driver_em: ifun from ',fire_ifun_start,' to ',fire_ifun_end, & + ' restart=',restart,' replay=',replay +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) + call message(msg) + + do istep=0,tsteps ! istep >0 is for testing only, exit after the first call + itimestep = grid%itimestep + istep ! in the first call, do fire_test_steps steps of the fire model + + do fire_ifun=fire_ifun_start,fire_ifun_end + + ! 1 = moisture_initialize run pass 1: interpolate height to zsf=terrain + ! 2 = initialize run pass 2: set fuel data, terrain gradient + ! 3 = initialize timestep: interpolate winds, check for ignition, time step on moisture model + ! 4 = do one timestep + ! 5 = copy timestep output to input + ! 6 = compute output fluxes + +#ifdef DM_PARALLEL + + if(fire_run)then + + if(fire_ifun.eq.1)then + +! halo exchange on topography +#include "HALO_FIRE_LONGLAT.inc" +!! if(fire_topo_from_atm.eq.1)then +!!#include "HALO_FIRE_HT.inc" +!! endif +! base geopotential and roughness +#include "HALO_FIRE_PHB.inc" +#include "HALO_FIRE_Z0.inc" + if(kfmc_ndwi > 0 .and. fndwi_from_ndwi .eq.1)then +#include "HALO_FIRE_NDWI.inc" + endif + + elseif(fire_ifun.eq.2)then +! halo exchange on zsf width 2 +#include "HALO_FIRE_ZSF.inc" + + if(replay)then + call message('replay, halo exchange on lfn and tign') +#include "HALO_FIRE_LFN.inc" +#include "HALO_FIRE_TIGN.inc" + endif + if(config_flags%chem_opt>0 .or. config_flags%tracer_opt > 0)then + ! need reading fuel categories first + call read_emissions_table(config_flags%chem_opt,config_flags%tracer_opt) + endif + + elseif(fire_ifun.eq.3)then +! halo exchange on atm winds and geopotential, width 1 for interpolation +#include "HALO_FIRE_WIND_A.inc" +#include "HALO_FIRE_PH.inc" + + elseif(fire_ifun.eq.4)then +! halo exchange on fire winds width 2 for a 2-step RK method +#include "HALO_FIRE_WIND_F.inc" + + if(run_fuel_moisture)then + ! have interpolated to the fire grid +#include "HALO_FIRE_MFG.inc" + endif + + elseif(fire_ifun.eq.5)then +#include "HALO_FIRE_LFN_OUT.inc" + + elseif(fire_ifun.eq.6)then +! computing fuel_left needs ignition time from neighbors + call message('halo exchange on lfn width 2 and tign') +#include "HALO_FIRE_TIGN.inc" +#include "HALO_FIRE_LFN.inc" + + endif + endif +#endif + ! print *,'dt: ',dt,grid%dt,' diff ', dt-grid%dt + ! need domain by 1 smaller, in last row.col winds are not set properly + call sfire_driver_phys ( & + fire_ifun, & + ids,ide-1, kds,kde, jds,jde-1, & + ims,ime, kms,kme, jms,jme, & + ips,min(ipe,ide-1), kps,kpe, jps,min(jpe,jde-1), & + ifds,ifde-ir, jfds,jfde-jr, & + ifms,ifme, jfms,jfme, & + ifps,min(ifpe,ifde-ir), jfps,min(jfpe,jfde-jr), & + ir,jr, & ! atm/fire grid ratio + grid%num_tiles, & ! atm grid tiling + grid%i_start,min(grid%i_end,ide-1), & + grid%j_start,min(grid%j_end,jde-1), & + itimestep,restart,replay,config_flags%fire_fuel_read,config_flags%fire_fuel_cat, & ! in scalars + time_step_start,dt,grid%dx,grid%dy, & + grid%u_frame,grid%v_frame, & + config_flags%fire_ext_grnd,config_flags%fire_ext_crwn,config_flags%fire_crwn_hgt, & + ignition,hfx, & ! lines + grid%u_2,grid%v_2, & ! atm arrays in + grid%ph_2,grid%phb, & ! geopotential + grid%z0, & ! roughness height + grid%ht, & ! terrain height + grid%xlong,grid%xlat, & ! coordinates of atm grid centers, for ignition location + grid%tign_in, & + grid%lfn,grid%tign_g,grid%fuel_frac, & ! state arrays, fire grid + grid%fire_area, & ! redundant, for display, fire grid + grid%fuel_frac_burnt, & + grid%lfn_out, & ! work - one timestep + grid%avg_fuel_frac, & ! out redundant arrays, atm grid + grid%grnhfx,grid%grnqfx,grid%canhfx,grid%canqfx, & ! out redundant arrays, atm grid + grid%uah,grid%vah, & + grid%fgrnhfx,grid%fgrnqfx,grid%fcanhfx,grid%fcanqfx, & ! out redundant arrays, atm grid + grid%ros,grid%flineint,grid%flineint2, & ! diagnostic variables + grid%f_ros0,grid%f_rosx,grid%f_rosy,grid%f_ros,& ! fire risk spread + grid%f_int,grid%f_lineint,grid%f_lineint2, & ! fire risk intensities + grid%f_ros11,grid%f_ros12,grid%f_ros13,grid%f_ros21, & ! fire spread in nodal directions + grid%f_ros23,grid%f_ros31,grid%f_ros32,grid%f_ros33, & ! fire spread in nodal directions + grid%fxlong,grid%fxlat, & + grid%fire_hfx, & ! + grid%nfuel_cat, & ! input, or internal for safekeeping + grid%fuel_time, & + grid%fz0, grid%fwh, & + fp, & ! structure with pointers passed to spread rate calculation + config_flags%nfmc, & ! moisture model variables start + run_advance_moisture,run_fuel_moisture,dt_moisture, & ! moisture model control + config_flags%fmep_decay_tlag, & ! moisture extended model assim. diffs decay time lag + grid%rainc, grid%rainnc, & ! accumulated rain from different sources + grid%t2, grid%q2, grid%psfc, & ! temperature (K), vapor contents (kg/kg), pressure (Pa) at the surface + grid%rain_old, & ! previous value of accumulated rain + grid%t2_old, grid%q2_old, grid%psfc_old, & ! previous values of the atmospheric state at surface + grid%rh_fire, & ! relative humidity, diagnostics + grid%fmc_gc, & ! fuel moisture fields updated, by class, assumed set to something reasonable + grid%fmep, & ! fuel moisture extended model parameters + grid%fmc_equi, & ! fuel moisture fields updated, by class, equilibrium diagnostic + grid%fmc_lag, & ! fuel moisture fields updated, by class, tendency diagnostic + fp%fmc_g, & ! write-only alias. need to exit before using fp again + grid%ndwi, & + grid%fndwi) + + +#ifdef DM_PARALLEL + if(fire_run)then + if(fire_ifun.eq.2)then +! halo exchange on all fuel data width 2 +#include "HALO_FIRE_FUEL.inc" +! fire state was initialized + call message('halo exchange on lfn width 2') +#include "HALO_FIRE_LFN.inc" + endif + if(run_fuel_moisture)then + if(fire_ifun.eq.3)then + ! prepare for interpolation to the fire grid +#include "HALO_FIRE_MAG.inc" + endif + endif + endif +#endif + + if(fire_ifun.eq.6)then + if(config_flags%chem_opt>0 .or. config_flags%tracer_opt>0)then + if(.not.(present(rho).and.present(dz8w)))then + call crash('sfire_driver_em: must have rho and dz8w to call add_fire_emissions') + endif + call add_fire_emissions( & + config_flags%chem_opt,config_flags%tracer_opt,dt,grid%dx,grid%dy, & + ifms,ifme,jfms,jfme, & + ifps,ifpe,jfps,jfpe, & ! use patch instead of tile + ids,ide,kds,kde,jds,jde, & + ims,ime,kms,kme,jms,jme, & + ips,ipe,kps,kpe,jps,jpe, & + rho,dz8w, & ! from atmosphere state + grid%fgip, grid%fuel_frac_burnt, grid%nfuel_cat, & ! from fire state + grid%chem,grid%tracer) ! update/output + endif + endif + + + enddo + enddo + + if(tsteps>0)call crash('sfire_driver_em: test run of uncoupled fire model completed') + call time_end('sfire') + +end subroutine sfire_driver_em + +! +!******************* +! + +subroutine sfire_driver_phys (ifun, & + ids,ide, kds,kde, jds,jde, & ! atm grid dimensions + ims,ime, kms,kme, jms,jme, & + ips,ipe, kps,kpe, jps,jpe, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifps, ifpe, jfps, jfpe, & ! fire patch in - will use smaller + ir,jr, & ! atm/fire grid ratio + num_tiles,i_start,i_end,j_start,j_end, & ! atm grid tiling + itimestep,restart,replay,ifuelread,nfuel_cat0, & ! in scalars + time_step_start,dt,dx,dy, & ! in scalars + u_frame,v_frame, & + fire_ext_grnd,fire_ext_crwn,fire_crwn_hgt, & + ignition,hfx, & ! lines + u,v, & ! in arrays, atm grid + ph,phb, & + z0,zs, & + xlong,xlat, & + tign_in, & + lfn,tign,fuel_frac, & ! state arrays, fire grid + fire_area, & ! redundant state, fire grid + fuel_frac_burnt, & + lfn_out, & ! out level set function + avg_fuel_frac, & + grnhfx,grnqfx,canhfx,canqfx, & ! out redundant arrays, atm grid + uah,vah, & ! out atm grid + fgrnhfx,fgrnqfx,fcanhfx,fcanqfx, & ! out redundant arrays, fire grid + ros,flineint,flineint2, & ! diagnostic variables + f_ros0,f_rosx,f_rosy,f_ros, & ! fire risk spread + f_int,f_lineint,f_lineint2, & ! fire risk intensities + f_ros11,f_ros12,f_ros13,f_ros21, & ! fire spread in nodal directions + f_ros23,f_ros31,f_ros32,f_ros33, & ! fire spread in nodal directions + fxlong,fxlat, & ! + fire_hfx, & ! + nfuel_cat, & ! in array, data, fire grid, or constant internal + fuel_time, & ! save constant internal data, fire grid + fz0,fwh, & + fp, & ! fire params + nfmc, & ! number of fuel moisture classes + run_advance_moisture,run_fuel_moisture,dt_moisture,& ! moisture model control + fmep_decay_tlag, & ! moist. extended model assim. diffs time lag + rainc,rainnc, & ! accumulated rain from different sources + t2, q2, psfc, & ! temperature (K), vapor contents (kg/kg), pressure (Pa) at the surface + rain_old, & ! previous value of accumulated rain + t2_old, q2_old, psfc_old, & ! previous values of the atmospheric state at surface + rh_fire, & ! relative humidity, diagnostics + fmc_gc, & ! fuel moisture fields updated, by class, assumed set to something reasonable + fmep, & ! fuel moisture extended model parameters + fmc_equi, & ! fuel moisture fields updated, by class equilibrium diagnostic + fmc_lag, & ! fuel moisture fields updated, by class tendency diagnostic + fmc_g, & ! fuel moisture, alias of fp%fmc_g + ndwi, & + fndwi) ! ndwi on fire grid + + +implicit none + +!*** arguments + +integer, intent(in)::ifun, & + ids,ide, kds,kde, jds,jde, & ! atm domain bounds + ims,ime, kms,kme, jms,jme, & ! atm memory bounds + ips,ipe, kps,kpe, jps,jpe, & ! atm patch bounds + ifds, ifde, jfds, jfde, & ! fire domain bounds + ifms, ifme, jfms, jfme, & ! fire memory bounds + ifps, ifpe, jfps, jfpe, & ! fire patch bounds + ir,jr, & ! atm/fire grid refinement ratio + nfmc, & ! number of fuel moisture classes + itimestep, & ! number of this timestep + ifuelread, & ! how to initialize nfuel_cat: + ! -1=not at all, done outside + ! 0=from nfuel_cat0 + ! 1=from altitude + ! 2=from file + nfuel_cat0, & ! fuel category to initialize everything to + num_tiles ! number of tiles + +logical, intent(in)::restart,replay + +integer,dimension(num_tiles),intent(in) :: i_start,i_end,j_start,j_end ! atm grid tiling + +real, intent(in):: & + time_step_start, & ! time step start + dt, & ! time step length + dx,dy, & ! atm grid step + u_frame,v_frame, & ! velocity offset + fire_crwn_hgt, & ! lowest height crown fire heat is released (m) + fire_ext_grnd, & ! extinction depth of ground fire heat (m) + fire_ext_crwn ! and for the canopy (m) + + +TYPE (lines_type), intent(inout):: ignition,hfx + +real,intent(in),dimension(ims:ime,kms:kme,jms:jme)::u,v, & ! wind velocity (m/s) (staggered atm grid) + ph, phb ! geopotential (w-points atm grid) +real,intent(in),dimension(ims:ime, jms:jme):: z0, & ! roughness height + zs ! terrain height +real,intent(out),dimension(ims:ime,jms:jme)::& + uah, & ! atm wind at fire_wind_height, diagnostics + vah ! atm wind at fire_wind_height, diagnostics + +real, dimension(ims:ime, jms:jme), intent(inout)::xlong, xlat, ndwi ! inout because of extension at bdry + +real, intent(inout), dimension(ifms:ifme,jfms:jfme):: & ! fuel data; can be also set inside (cell based, fire grid) + fz0,fwh, & + nfuel_cat,fndwi + +real, intent(inout), dimension(ifms:ifme, jfms:jfme):: & + tign_in, & + lfn,tign,fuel_frac, & ! state: level function, ign time, fuel left + lfn_out ! fire wind velocities + +real, intent(out), dimension(ifms:ifme, jfms:jfme):: & + fire_area, & ! fraction of each cell burning + fuel_frac_burnt + +real, intent(out), dimension(ims:ime, jms:jme):: & ! redundant arrays, for display purposes only (atm grid) + avg_fuel_frac, & ! average fuel fraction + grnhfx, & ! heat flux from ground fire (W/m^2) + grnqfx, & ! moisture flux from ground fire (W/m^2) + canhfx, & ! heat flux from crown fire (W/m^2) + canqfx ! moisture flux from crown fire (W/m^2) + +real, intent(out), dimension(ifms:ifme, jfms:jfme):: & ! redundant arrays, for display only, fire grid + fgrnhfx, & ! heat flux from ground fire (W/m^2) + fgrnqfx, & ! moisture flux from ground fire (W/m^2) + fcanhfx, & ! heat flux from crown fire (W/m^2) + fcanqfx, & ! moisture flux from crown fire (W/m^2) + ros,flineint,flineint2, & ! diagnostic variables + f_ros0,f_rosx,f_rosy,f_ros, & ! fire risk spread + f_int,f_lineint,f_lineint2, & ! fire risk intensities + f_ros11,f_ros12,f_ros13,f_ros21, & ! fire spread in nodal directions + f_ros23,f_ros31,f_ros32,f_ros33 ! fire spread in nodal directions + + +! moisture model arguments +logical, intent(in)::run_advance_moisture,run_fuel_moisture +real, intent(in)::dt_moisture +real, intent(in)::fmep_decay_tlag +real, intent(in), dimension(ims:ime,jms:jme):: t2, q2, psfc, rainc, rainnc +real, intent(inout), dimension(ims:ime,jms:jme):: t2_old, q2_old, psfc_old, rain_old +real, intent(out),dimension(ims:ime,jms:jme):: rh_fire +real, intent(inout), dimension(ims:ime,nfmc,jms:jme):: fmc_gc +real, intent(inout), dimension(ims:ime,2,jms:jme):: fmep +real, intent(out), dimension(ims:ime,nfmc,jms:jme):: fmc_equi,fmc_lag +real, intent(inout), dimension(ifms:ifme,jfms:jfme):: fmc_g + + + +! ***** data (constant in time) ***** + +real, dimension(ifms:ifme, jfms:jfme), intent(inout)::fxlong,fxlat, & ! fire mesh coordinates + fire_hfx +real, intent(out), dimension(ifms:ifme, jfms:jfme)::fuel_time ! fire params arrays + +type(fire_params),intent(inout)::fp + +!*** local +real :: dxf,dyf,time_start,latm, s +integer :: its,ite,jts,jte,kts,kte, & ! tile + ij,i,j,k,id,pid,ipe1,jpe1,ite1,jte1, & + ii,jj, & + ifts,ifte,jfts,jfte ! fire tile +character(len=128)::msg +character(len=3)::kk +real, parameter::zero=0. + +!*** executable + +! time - assume dt does not change +! time_start = (itimestep-1) * dt ! timestep 1 starts at 0 +! print *,'time_start: ',time_start,time_step_start,' diff ', time_start-time_step_start +time_start = time_step_start ! use the time passed from wrf + +! fire mesh step +dxf=dx/ir +dyf=dy/jr + + +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) +write(msg,'(a,i5)')'sfire_driver_phys stage ',ifun +call message(msg) +write(msg,'(a,2f15.6)')'atmosphere mesh step:',dx,dy +call message(msg) +write(msg,'(a,2f15.6)')'fire mesh step: ',dxf,dyf +call message(msg) +write(msg,7001)'atm domain ','ids',ids,ide,jds,jde +call message(msg) +write(msg,7001)'atm memory ','ims',ims,ime,jms,jme +call message(msg) +write(msg,7001)'atm patch ','ips',ips,ipe,jps,jpe +call message(msg) +write(msg,7001)'fire domain ','ifds',ifds,ifde,jfds,jfde +call message(msg) +write(msg,7001)'fire memory ','ifms',ifms,ifme,jfms,jfme +call message(msg) +write(msg,7001)'fire patch ','ifps',ifps,ifpe,jfps,jfpe +call message(msg) +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) + +! check mesh dimensions +call check_fmesh(ids,ide,ifds,ifde,ir,'id') ! check if atm and fire grids line up +call check_fmesh(jds,jde,jfds,jfde,jr,'jd') +call check_fmesh(ips,ipe,ifps,ifpe,ir,'ip') +call check_fmesh(jps,jpe,jfps,jfpe,jr,'jp') +call check_mesh_2dim(ips,ipe,jps,jpe,ims,ime,jms,jme) ! check if atm patch fits in atm array +call check_mesh_2dim(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme) ! check if fire patch fits in fire array +call check_mesh_2dim(ips,ipe,jps,jpe,ids,ide,jds,jde) ! check if atm patch fits in atm domain +call check_mesh_2dim(ifps,ifpe,jfps,jfpe,ifds,ifde,jfds,jfde) ! check if fire patch fits in fire domain + +pid=0 +if(fire_print_file.gt.0)then + if(itimestep.le.fire_print_file.or.mod(itimestep,fire_print_file).eq.0)pid=itimestep ! print 1-fire_print_file then every fire_print_file-th +endif + + +if(ifun.eq.1)then + call init_fuel_cats(fmoist_run .or. fmoist_interp) ! properties of fuel categories and moisture classes from namelist.fire +endif + +if(ifun.eq.3)then + call print_chsum(itimestep,ims,ime,kms,kme,jms,jme,ids,ide,kds,kde,jds,jde,ips,ipe,kps,kpe,jps,jpe,1,0,0,u,'u') + call print_chsum(itimestep,ims,ime,kms,kme,jms,jme,ids,ide,kds,kde,jds,jde,ips,ipe,kps,kpe,jps,jpe,0,0,1,v,'v') + call print_chsum(itimestep,ims,ime,kms,kme,jms,jme,ids,ide,kds,kde,jds,jde,ips,ipe,kps,kpe,jps,jpe,0,1,0,ph,'ph') +endif + +call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,lfn,'lfn') +call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,tign,'tign') + + +! fake atm tile bounds +kts=kps +kte=kpe + +! staggered atm patch bounds +ipe1=ifval(ipe.eq.ide,ipe+1,ipe) +jpe1=ifval(jpe.eq.jde,jpe+1,jpe) + +! set up fire tiles & interpolate to fire grid +!$OMP PARALLEL DO PRIVATE(ij,its,ite,jts,jte,ite1,jte1,ifts,ifte,jfts,jfte,msg,id) & +!$OMP SCHEDULE(STATIC) +do ij=1,num_tiles + + id = ifval(pid.ne.0,pid+(ij-1)*10000,0) ! for print + + ! set up tile bounds + its = i_start(ij) ! start atmospheric tile in i + ite = i_end(ij) ! end atmospheric tile in i + jts = j_start(ij) ! start atmospheric tile in j + jte = j_end(ij) ! end atmospheric tile in j + ifts= (its-ids)*ir+ifds ! start fire tile in i + ifte= (ite-ids+1)*ir+ifds-1 ! end fire tile in i + jfts= (jts-jds)*jr+jfds ! start fire tile in j + jfte= (jte-jds+1)*jr+jfds-1 ! end fire tile in j + +! staggered atm tile bounds + ite1=ifval(ite.eq.ide,ite+1,ite) + jte1=ifval(jte.eq.jde,jte+1,jte) + +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) + write(msg,'(a,i3,1x,a,i7,1x,a,i3)')'tile=',ij,' id=',id,' ifun=',ifun + call message(msg) + write(msg,7001)'atm tile ','its',its,ite,jts,jte + call message(msg) + write(msg,7001)'fire tile ','ifts',ifts,ifte,jfts,jfte + call message(msg) +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) + + ! check the tiles + call check_mesh_2dim(its,ite,jts,jte,ips,ipe,jps,jpe) ! check if atm tile fits in atm patch + call check_mesh_2dim(ifts,ifte,jfts,jfte,ifps,ifpe,jfps,jfpe) ! check if fire tile fits in fire patch + call check_mesh_2dim(ifts-2,ifte+2,jfts-2,jfte+2,ifms,ifme,jfms,jfme)! check if fire node tile fits in memory + + +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) + write(msg,'(a,i6,a,2(f15.6,a))')'time step',itimestep,' at',time_start,' duration',dt,'s' + call message(msg) + 7001 format(a,' dimensions ',a4,':',i6,' to ',i6,' by ',i6,' to ',i6) + write(msg,'(a,2i9)')'refinement ratio:',ir,jr +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) + + if(run_advance_moisture)then + if(ifun.eq.3)then + + ! one timestep of the moisture model + call message('advance_moisture start') + call advance_moisture( & + itimestep.eq.1, & ! initialize? + ims,ime, jms,jme, & ! memory dimensions + its,ite, jts,jte, & ! tile dimensions + nfmc, & ! number of moisture fields + dt_moisture, & ! moisture model time step + fmep_decay_tlag, & ! moisture extended model assim. diffs decay tlag + rainc, rainnc, & ! accumulated rain + t2, q2, psfc, & ! temperature (K), vapor contents (kg/kg), pressure (Pa) at the surface + rain_old, & ! previous value of accumulated rain + t2_old, q2_old, psfc_old, & ! previous values of the atmospheric state at surface + rh_fire, & ! relative humidity, diagnostics + fmc_gc, & ! fuel moisture fields updated, by class, assumed set to something reasonable + fmep, & ! fuel moisture extended model parameters + fmc_equi, & ! fuel moisture fields updated, by class equilibrium diagnostic + fmc_lag & ! fuel moisture fields updated, by class tendency diagnostic + ) + call message('advance_moisture end') + endif + endif + + if(fire_run)then + + if(ifun.eq.2)then ! interpolate + + if(restart)then + + call message('restart - interpolation skipped') + + else + if(kfmc_ndwi > 0 .and. fndwi_from_ndwi .eq.1)then + call print_2d_stats(ips,ipe,jps,jpe,ims,ime,jms,jme,fndwi,'driver:ndwi') + call interpolate_z2fire(id,0, & ! for debug output, <= 0 no output, extend strip + ids,ide, jds,jde, & ! atm grid dimensions + ims,ime, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifts,ifte,jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + ndwi, & ! atm grid arrays in + fndwi) ! fire grid arrays out + call print_2d_stats(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fndwi,'driver:fndwi') + endif +! +! call print_2d_stats(ips,ipe,jps,jpe,ims,ime,jms,jme,zs,'driver:zs') +! +! ! interpolate terrain height +! if(fire_topo_from_atm.eq.1)then +! call interpolate_z2fire(id,1, & ! for debug output, <= 0 no output +! ids,ide, jds,jde, & ! atm grid dimensions +! ims,ime, jms,jme, & +! ips,ipe,jps,jpe, & +! its,ite,jts,jte, & +! ifds, ifde, jfds, jfde, & ! fire grid dimensions +! ifms, ifme, jfms, jfme, & +! ifts,ifte,jfts,jfte, & +! ir,jr, & ! atm/fire grid ratio +! zs, & ! atm grid arrays in +! fp%zsf) ! fire grid arrays out +! else +!!$OMP CRITICAL(SFIRE_DRIVER_CRIT) +! write(msg,'(a,i3,a)')'fire_topo_from_atm=',fire_topo_from_atm,' assuming ZSF set, interpolation skipped' +!!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) +! endif + + if(ignition%longlat .eq.0)then + ! set ideal fire mesh coordinates - used for ignition only + ! do not forget to set unit_fxlong, unit_fxlat outside of parallel loop + !call set_ideal_coord( dxf,dyf, & + ! ifds,ifde,jfds,jfde, & + ! ifms,ifme,jfms,jfme, & + ! ifts,ifte,jfts,jfte, & + ! fxlong,fxlat ) + !call set_ideal_coord( dx,dy, & + ! ids,ide,jds,jde, & + ! ims,ime,jms,jme, & + ! its,ite,jts,jte, & + ! xlong,xlat ) + elseif(use_atm_vars)then + ! assume halo xlong xlat + ! interpolate nodal coordinates + +#ifdef DEBUG_OUT + call write_array_m(its,ite,jts,jte,ims,ime,jms,jme,xlat,'xlat',id) + call write_array_m(its,ite,jts,jte,ims,ime,jms,jme,xlong,'xlong',id) +#endif + + if (interpolate_long_lat)then + call message('Intepolating node longitude and latitude to fire mesh') + call interpolate_z2fire(id,1, & ! for debug output, <= 0 no output + ids,ide, jds,jde, & ! atm grid dimensions + ims,ime, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifts,ifte,jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + xlat, & ! atm grid arrays in + fxlat) ! fire grid arrays out + + call interpolate_z2fire(id,1, & ! for debug output, <= 0 no output + ids,ide, jds,jde, & ! atm grid dimensions + ims,ime, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifts,ifte,jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + xlong, & ! atm grid arrays in + fxlong) ! fire grid arrays out + endif + + ! after the loop where zsf created exited and all synced + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fp%zsf,'driver_phys:zsf') + + ! cannot initialize moisture model because T2 Q2 PSFC are not set yet + endif + endif + + elseif(ifun.eq.3)then ! interpolate winds to the fire grid + + if(use_atm_vars)then + + call write_array_m(its,ite,jts,jte,ims,ime,jms,jme,z0,'z0',id) + call write_array_m3(its,ite1,kts,kde-1,jts,jte,ims,ime,kms,kme,jms,jme,u,'u_2',id) + call write_array_m3(its,ite,kts,kde-1,jts,jte1,ims,ime,kms,kme,jms,jme,v,'v_2',id) + call write_array_m3(its,ite,kts,kde,jts,jte,ims,ime,kms,kme,jms,jme,ph,'ph_2',id) + call write_array_m3(its,ite,kts,kde,jts,jte,ims,ime,kms,kme,jms,jme,phb,'phb',id) + + if(fire_wind_log_interp.eq.4)then + call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,z0,'driver_phys:z0') + call interpolate_atm2fire(id, & ! flag for debug output + ids,ide, kds,kde, jds,jde, & ! atm grid dimensions + ims,ime, kms,kme, jms,jme, & + ips,ipe, jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifps, ifpe, jfps, jfpe, & ! fire patch bounds + ifts, ifte, jfts, jfte, & + ir,jr, & ! atm/fire grid ratio + u_frame, v_frame, & ! velocity frame correction + u,v, & ! 3D atm grid arrays in + ph,phb, & + z0,zs, & ! 2D atm grid arrays in + uah,vah, & ! 2D atm grid out + fp%vx,fp%vy) ! fire grid arrays out + + call apply_windrf( & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + nfuel_cat,fp%vx,fp%vy) + + else + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fz0,'driver_phys:fz0') + call interpolate_wind2fire_height(id, & ! to identify debugging prints and files if needed + ids,ide, kds,kde, jds,jde, & ! atm grid dimensions + ims,ime, kms,kme, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifps, ifpe, jfps, jfpe, & ! fire patch bounds + ifts,ifte,jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + u_frame, v_frame, & ! velocity frame correction + u,v,ph,phb, & ! input atmospheric arrays + fz0,fwh, & ! input fire arrays + fp%vx,fp%vy) ! output fire arrays + + if(fire_use_windrf.eq.1)then + call apply_windrf( & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + nfuel_cat,fp%vx,fp%vy) + endif + + endif + + + endif + + elseif(ifun.eq.4)then + + ! interpolate and compute weighted average to get the fuel moisture + !! print *,'ifun=4, run_fuel_moisture=',run_fuel_moisture + if(run_fuel_moisture)then + call message('fuel_moisture start') + call fuel_moisture( & + id, & ! for prints and maybe file names + nfmc, & + ids,ide, jds,jde, & ! atm grid dimensions + ims,ime, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifts,ifte,jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + nfuel_cat, & ! fuel data + fndwi, & ! satellite sensing interpolated on fire grid + fmc_gc, & ! moisture contents by class on atmospheric grid + fmc_g & ! weighted fuel moisture contents on fire grid + ) + call message('fuel_moisture end') + endif + + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fmc_g,'driver_phys:fmc_g') + endif + + + + call sfire_model (id,ifun,restart,replay, & + run_fuel_moisture, & ! if fuel moisture needs to be updated + ifuelread,nfuel_cat0, & ! initialize fuel categories + ifds,ifde,jfds,jfde, & ! fire domain dims + ifms,ifme,jfms,jfme, & ! fire memory dims + ifps,ifpe,jfps,jfpe, & + ifts,ifte,jfts,jfte, & ! fire patch dims + time_start,dt, & ! time and increment + dxf,dyf, & ! fire mesh spacing + ignition,hfx, & ! description of ignition lines + fxlong,fxlat, & ! fire mesh coordinates + fire_hfx, & ! given heat flux + tign_in, & ! given igntion time + lfn,lfn_out,tign,fuel_frac, & ! state: level function, ign time, fuel left + fire_area, & ! output: fraction of cell burning + fuel_frac_burnt, & ! output: fuel fraction burned in this step + fgrnhfx,fgrnqfx, & ! output: heat fluxes + ros,flineint,flineint2, & ! diagnostic variables + f_ros0,f_rosx,f_rosy,f_ros, & ! fire risk spread + f_int,f_lineint,f_lineint2, & ! fire risk intensities + nfuel_cat, & ! fuel data per point + fuel_time,fwh,fz0, & ! save derived internal data + fp & ! fire coefficients + ) + + if(ifun.eq.2)then + call setup_wind_log_interpolation( & + ids,ide, jds,jde, & ! atm grid dimensions + ims,ime, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifts,ifte,jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + z0, & ! atm grid arrays in + nfuel_cat, & ! fuel data per point + fz0,fwh) ! fire arrays out + + + elseif(ifun.eq.6)then + + + ! populate the rate of spread in the 8 directions + do j=jfts,jfte + do i=ifts,ifte + f_ros11(i,j)=fire_rate_of_spread( dxf*(1-2), dyf*(1-2), i,j,fp) + f_ros12(i,j)=fire_rate_of_spread( dxf*(1-2), dyf*(2-2), i,j,fp) + f_ros13(i,j)=fire_rate_of_spread( dxf*(1-2), dyf*(3-2), i,j,fp) + f_ros21(i,j)=fire_rate_of_spread( dxf*(2-2), dyf*(1-2), i,j,fp) + f_ros23(i,j)=fire_rate_of_spread( dxf*(2-2), dyf*(3-2), i,j,fp) + f_ros31(i,j)=fire_rate_of_spread( dxf*(3-2), dyf*(1-2), i,j,fp) + f_ros32(i,j)=fire_rate_of_spread( dxf*(3-2), dyf*(2-2), i,j,fp) + f_ros33(i,j)=fire_rate_of_spread( dxf*(3-2), dyf*(3-2), i,j,fp) + enddo + enddo + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,f_ros11,'driver_phys:f_ros11') + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,f_ros12,'driver_phys:f_ros12') + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,f_ros13,'driver_phys:f_ros13') + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,f_ros21,'driver_phys:f_ros21') + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,f_ros23,'driver_phys:f_ros23') + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,f_ros31,'driver_phys:f_ros31') + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,f_ros32,'driver_phys:f_ros32') + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,f_ros33,'driver_phys:f_ros33') + + ! heat fluxes into the atmosphere + + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,ros,'sfire_driver:ros') + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fgrnhfx,'sfire_driver:fgrnhfx') + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fgrnqfx,'sfire_driver:fgrnqfx') + + ! sum the fluxes over atm cells + if(use_atm_vars)then + call sum_2d_cells( & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + fuel_frac, & + ims, ime, jms, jme, & + its,ite,jts,jte, & + avg_fuel_frac) + call sum_2d_cells( & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + fgrnhfx, & + ims, ime, jms, jme, & + its,ite,jts,jte, & + grnhfx) +!comment out the next call to get results as before commit 55fd92051196b796891b60cb7ec1c4bdb8800078 + call sum_2d_cells( & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + fgrnqfx, & + ims, ime, jms, jme, & + its,ite,jts,jte, & + grnqfx) + +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) + write(msg,'(a,f6.3)')'fire-atmosphere feedback scaling ',fire_atm_feedback +!$OMP end CRITICAL(SFIRE_DRIVER_CRIT) + call message(msg) + s = 1./(ir*jr) + do j=jts,jte + do i=its,ite + ! scale ground fluxes to get the averages + avg_fuel_frac(i,j)=avg_fuel_frac(i,j)*s + grnhfx(i,j)=fire_atm_feedback*grnhfx(i,j)*s + grnqfx(i,j)=fire_atm_feedback*grnqfx(i,j)*s + ! we do not have canopy fluxes yet... + canhfx(i,j)=0 + canqfx(i,j)=0 + enddo + enddo + + call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,grnhfx,'fire_driver:grnhfx') + call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,grnqfx,'fire_driver:grnqfx') + endif + + endif ! ifun=6 + endif + +enddo ! tiles +!$OMP END PARALLEL DO + +#ifdef DEBUG_OUT +if(ifun.eq.1)then + if(pid.ne.0)then + call write_array_m(ips,ipe,jps,jpe,ims,ime,jms,jme,zs,'zs',pid) + call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fp%zsf,'zsf',pid) + endif +endif +#endif + +if (ifun.eq.3)then + call print_3d_stats_by_slice(ips,ipe,1,moisture_classes,jps,jpe,ims,ime,1,nfmc,jms,jme,fmc_gc,'fmc_gc') + call print_chsum(itimestep,ims,ime,1,nfmc,jms,jme,ids,ide,1,moisture_classes,jds,jde,ips,ipe,1,moisture_classes,jps,jpe,0,0,0,fmc_gc,'fmc_gc') +endif + +if (ifun.eq.4)then + + call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,fmc_g,'fmc_g') + !call print_chsum(itimestep,ims,ime,1,1,jms,jme,ids,ide,1,1,jds,jde,ips,ipe,1,1,jps,jpe,1,0,0,uah,'uah') + !call print_chsum(itimestep,ims,ime,1,1,jms,jme,ids,ide,1,1,jds,jde,ips,ipe,1,1,jps,jpe,0,0,1,vah,'vah') + call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,fp%vx,'uf') + call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,fp%vy,'vf') + call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,lfn,'lfn') + call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,tign,'tign') + +#ifdef DEBUG_OUT + if(pid.gt.0)then + ! call write_array_m(ips,ipe1,jps,jpe,ims,ime,jms,jme,uah,'uah',pid) + ! call write_array_m(ips,ipe,jps,jpe1,ims,ime,jms,jme,vah,'vah',pid) + call write_array_m(ips,ipe,jps,jpe,ims,ime,jms,jme,grnhfx,'grnhfx',pid) + call write_array_m(ips,ipe,jps,jpe,ims,ime,jms,jme,grnqfx,'grnqfx',pid) + call write_array_m3(ips,ipe1,kds,kde+1,jps,jpe,ims,ime,kms,kme,jms,jme,u,'u',pid) + call write_array_m3(ips,ipe,kds,kde+1,jps,jpe1,ims,ime,kms,kme,jms,jme,v,'v',pid) + call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fp%vx,'uf',pid) + call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fp%vy,'vf',pid) + endif +#endif +endif + +if(ifun.eq.5)then +#ifdef DEBUG_OUT + if(pid.gt.0)then + call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,lfn,'lfn',pid) + call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,tign,'tign',pid) + endif +#endif +endif + +if(ifun.eq.6)then + call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,fgrnhfx,'fgrnhfx') + call print_chsum(itimestep,ifms,ifme,1,1,jfms,jfme,ifds,ifde,1,1,jfds,jfde,ifps,ifpe,1,1,jfps,jfpe,0,0,0,fgrnqfx,'fgrnqfx') + call print_chsum(itimestep,ims,ime,1,1,jms,jme,ids,ide,1,1,jds,jde,ips,ipe,1,1,jps,jpe,0,0,0,grnhfx,'grnhfx') + call print_chsum(itimestep,ims,ime,1,1,jms,jme,ids,ide,1,1,jds,jde,ips,ipe,1,1,jps,jpe,0,0,0,grnqfx,'grnqfx') +#ifdef DEBUG_OUT + if(pid.gt.0)then + call write_array_m(ips,ipe,jps,jpe,ims,ime,jms,jme,grnhfx,'grnhfx',pid) + call write_array_m(ips,ipe,jps,jpe,ims,ime,jms,jme,grnqfx,'grnqfx',pid) + call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fuel_frac,'fuel_frac',pid) + call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fgrnhfx,'fgrnhfx',pid) + call write_array_m(ifps,ifpe,jfps,jfpe,ifms,ifme,jfms,jfme,fgrnqfx,'fgrnqfx',pid) + endif +#endif +endif + +end subroutine sfire_driver_phys + +! +!*** +! + +subroutine check_fmesh(ids,ide,ifds,ifde,ir,s) +!*** purpose: check if fire and atm meshes line up +implicit none +!*** arguments +integer, intent(in)::ids,ide,ifds,ifde,ir +character(len=*),intent(in)::s +!*** local +character(len=128)msg +!*** executable +if ((ide-ids+1)*ir.ne.(ifde-ifds+1))then +!$OMP CRITICAL(SFIRE_DRIVER_CRIT) + write(msg,1)s,ids,ide,ifds,ifde,ir +1 format('module_fr_sfire_driver: incompatible bounds ',a,' atm ',i5,':',i5,' fire ',i5,':',i5,' ratio ',i3) +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) + call crash(msg) +endif +end subroutine check_fmesh + +subroutine fire_ignition_convert (config_flags,ignition, & + fxlong, fxlat, & + ifds,ifde, jfds,jfde, & + ifms,ifme, jfms,jfme, & + ifps,ifpe, jfps,jfpe ) + implicit none +! create ignition arrays from scalar flags +!*** arguments + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + TYPE (lines_type), INTENT(OUT):: ignition ! any values from input discarded + integer::ifds,ifde, jfds,jfde, & + ifms,ifme, jfms,jfme, & + ifps,ifpe, jfps,jfpe + real, dimension(ifms:ifme,jfms:jfme):: fxlong,fxlat +!*** local + integer::i,j,ii,jj + logical:: real,ideal + character(len=128)msg + real:: corner_longlat(2,2,2), corner_longlat_1(8), corner_longlat_2(8),lon(2),lat(2) + real, dimension(2,2):: corner_long,corner_lat ! coordinates of fire mesh corner cells + +!*** executable + + + ignition%max_lines=5 ! number of lines that have entries in the namelist + ignition%num_lines=config_flags%fire_num_ignitions + + ! this is only until I figure out how to input arrays through the namelist... + if(fire_max_lines.lt.ignition%max_lines)call crash('fire_max_lines too small') + + ! figure out which kind of coordinates from the first given + ideal=config_flags%fire_ignition_start_x1 .ne.0. .or. config_flags%fire_ignition_start_y1 .ne. 0. + real=config_flags%fire_ignition_start_lon1 .ne. 0. .or. config_flags%fire_ignition_start_lat1 .ne. 0. + if(ideal)call message('Using ideal ignition coordinates, m from the lower left domain corner') + if(real)call message('Using real ignition coordinates, longitude and latitude') + if(ideal.and.real)call crash('Only one of the ideal or real coordinates may be given') + + ignition%longlat=0 ! default, if no ignition + if(ideal)then + ! use values from _x and _y variables + ignition%longlat=0 + ignition%line(1)%start_x=config_flags%fire_ignition_start_x1 + ignition%line(1)%start_y=config_flags%fire_ignition_start_y1 + ignition%line(1)%end_x=config_flags%fire_ignition_end_x1 + ignition%line(1)%end_y=config_flags%fire_ignition_end_y1 + ignition%line(2)%start_x=config_flags%fire_ignition_start_x2 + ignition%line(2)%start_y=config_flags%fire_ignition_start_y2 + ignition%line(2)%end_x=config_flags%fire_ignition_end_x2 + ignition%line(2)%end_y=config_flags%fire_ignition_end_y2 + ignition%line(3)%start_x=config_flags%fire_ignition_start_x3 + ignition%line(3)%start_y=config_flags%fire_ignition_start_y3 + ignition%line(3)%end_x=config_flags%fire_ignition_end_x3 + ignition%line(3)%end_y=config_flags%fire_ignition_end_y3 + ignition%line(4)%start_x=config_flags%fire_ignition_start_x4 + ignition%line(4)%start_y=config_flags%fire_ignition_start_y4 + ignition%line(4)%end_x=config_flags%fire_ignition_end_x4 + ignition%line(4)%end_y=config_flags%fire_ignition_end_y4 + ignition%line(5)%start_x=config_flags%fire_ignition_start_x5 + ignition%line(5)%start_y=config_flags%fire_ignition_start_y5 + ignition%line(5)%end_x=config_flags%fire_ignition_end_x5 + ignition%line(5)%end_y=config_flags%fire_ignition_end_y5 + endif + if(real)then + ! use values from _long and _lat + ignition%longlat=1 + ignition%line(1)%start_x=config_flags%fire_ignition_start_lon1 + ignition%line(1)%start_y=config_flags%fire_ignition_start_lat1 + ignition%line(1)%end_x=config_flags%fire_ignition_end_lon1 + ignition%line(1)%end_y=config_flags%fire_ignition_end_lat1 + ignition%line(2)%start_x=config_flags%fire_ignition_start_lon2 + ignition%line(2)%start_y=config_flags%fire_ignition_start_lat2 + ignition%line(2)%end_x=config_flags%fire_ignition_end_lon2 + ignition%line(2)%end_y=config_flags%fire_ignition_end_lat2 + ignition%line(3)%start_x=config_flags%fire_ignition_start_lon3 + ignition%line(3)%start_y=config_flags%fire_ignition_start_lat3 + ignition%line(3)%end_x=config_flags%fire_ignition_end_lon3 + ignition%line(3)%end_y=config_flags%fire_ignition_end_lat3 + ignition%line(4)%start_x=config_flags%fire_ignition_start_lon4 + ignition%line(4)%start_y=config_flags%fire_ignition_start_lat4 + ignition%line(4)%end_x=config_flags%fire_ignition_end_lon4 + ignition%line(4)%end_y=config_flags%fire_ignition_end_lat4 + ignition%line(5)%start_x=config_flags%fire_ignition_start_lon5 + ignition%line(5)%start_y=config_flags%fire_ignition_start_lat5 + ignition%line(5)%end_x=config_flags%fire_ignition_end_lon5 + ignition%line(5)%end_y=config_flags%fire_ignition_end_lat5 + endif + ! common to both cases + ignition%line(1)%ros=config_flags%fire_ignition_ros1 + ignition%line(1)%radius=config_flags%fire_ignition_radius1 + ignition%line(1)%start_time=config_flags%fire_ignition_start_time1 + ignition%line(1)%end_time=config_flags%fire_ignition_end_time1 + ignition%line(2)%ros=config_flags%fire_ignition_ros2 + ignition%line(2)%radius=config_flags%fire_ignition_radius2 + ignition%line(2)%start_time=config_flags%fire_ignition_start_time2 + ignition%line(2)%end_time=config_flags%fire_ignition_end_time2 + ignition%line(3)%ros=config_flags%fire_ignition_ros3 + ignition%line(3)%radius=config_flags%fire_ignition_radius3 + ignition%line(3)%start_time=config_flags%fire_ignition_start_time3 + ignition%line(3)%end_time=config_flags%fire_ignition_end_time3 + ignition%line(4)%ros=config_flags%fire_ignition_ros4 + ignition%line(4)%radius=config_flags%fire_ignition_radius4 + ignition%line(4)%start_time=config_flags%fire_ignition_start_time4 + ignition%line(4)%end_time=config_flags%fire_ignition_end_time4 + ignition%line(5)%ros=config_flags%fire_ignition_ros5 + ignition%line(5)%radius=config_flags%fire_ignition_radius5 + ignition%line(5)%start_time=config_flags%fire_ignition_start_time5 + ignition%line(5)%end_time=config_flags%fire_ignition_end_time5 + + call postprocess_lines(ignition,'ros',config_flags) + +! get the coordinates of the corner cells + corner_longlat=0. + if(ifds.eq.ifps.and.jfds.eq.jfps)then + corner_longlat(1,1,1)=fxlong(ifps,jfps) + corner_longlat(1,1,2)=fxlat(ifps,jfps) + endif + if(ifds.eq.ifps.and.jfde.eq.jfpe)then + corner_longlat(1,2,1)=fxlong(ifps,jfpe) + corner_longlat(1,2,2)=fxlat(ifps,jfpe) + endif + if(ifde.eq.ifpe.and.jfds.eq.jfps)then + corner_longlat(2,1,1)=fxlong(ifpe,jfps) + corner_longlat(2,1,2)=fxlat(ifpe,jfps) + endif + if(ifde.eq.ifpe.and.jfde.eq.jfpe)then + corner_longlat(2,2,1)=fxlong(ifpe,jfpe) + corner_longlat(2,2,2)=fxlat(ifpe,jfpe) + endif + corner_longlat_1=reshape(corner_longlat,(/8/)) +#ifdef DM_PARALLEL + call wrf_dm_sum_reals(corner_longlat_1,corner_longlat_2) +#else + corner_longlat_2=corner_longlat_1 +#endif + corner_longlat=reshape(corner_longlat_2,(/2,2,2/)) + corner_long=corner_longlat(1:2,1:2,1) + corner_lat=corner_longlat(1:2,1:2,2) + if(fire_print_msg.ge.2)then + do i=1,2 + do j=1,2 + write(msg,'(a,2i2,a,2f14.8)')'corner',i,j,' coordinates ',corner_long(i,j),corner_lat(i,j) + call message(msg) + enddo + enddo + endif + lon(1)=(corner_long(1,1)+corner_long(1,2))/2. + lon(2)=(corner_long(2,1)+corner_long(2,2))/2. + lat(1)=(corner_lat(1,1)+corner_lat(2,1))/2. + lat(2)=(corner_lat(1,2)+corner_lat(2,2))/2. + if(fire_print_msg.ge.2)then + write(msg,'(4(a,f14.8))')'coordinates ',lon(1),':',lon(2),',',lat(1),':',lat(2) + call message(msg) + endif + + do i=1,ignition%num_lines + call check_ignition_coordinate(ignition%line(i)%start_x,lon(1),lon(2)) + call check_ignition_coordinate(ignition%line(i)%start_y,lat(1),lat(2)) + call check_ignition_coordinate(ignition%line(i)%end_x,lon(1),lon(2)) + call check_ignition_coordinate(ignition%line(i)%end_y,lat(1),lat(2)) + enddo + + if (fire_ignition_clamp>0) then + do i=1,ignition%num_lines + call clamp_to_grid(ignition%line(i)%start_x,lon(1),lon(2),ifds,ifde,ignition%line(i)%start_x,ii) + call clamp_to_grid(ignition%line(i)%start_y,lat(1),lat(2),jfds,jfde,ignition%line(i)%start_y,jj) + call display_clamp + call clamp_to_grid(ignition%line(i)%end_x,lon(1),lon(2),ifds,ifde,ignition%line(i)%end_x,ii) + call clamp_to_grid(ignition%line(i)%end_y,lat(1),lat(2),jfds,jfde,ignition%line(i)%end_y,jj) + call display_clamp + ! for now, ii jj ignored. In future replace by fxlong(ii,jj), fxlat(ii,jj) to guard against rounding + enddo + endif + contains + subroutine display_clamp + character(len=128)::msg + real::d1,d2 + if(ii>=ifps.and.ii<=ifpe.and.jj>=jfps.and.jj<=jfpe)then + write(msg,'(a,2f14.8,a,2i6)')'grid node ',fxlong(ii,jj),fxlat(ii,jj),' index',ii,jj + call message(msg) + endif + end subroutine display_clamp + end subroutine fire_ignition_convert + + subroutine check_ignition_coordinate(x,x1,x2) +!*** arguments + real, intent(in)::x,x1,x2 + character(len=128)::msg + if (.not.(x>x1 .and. x lines%line(i)%end_time)then + call crash('start time may not be after end time') + endif + enddo +!$OMP END CRITICAL(SFIRE_DRIVER_CRIT) + endif +end subroutine postprocess_lines + + +subroutine fire_hfx_convert (config_flags,hfx) + implicit none +! create heat flux line(s) from scalar flags +!*** arguments + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + TYPE (lines_type), INTENT(OUT):: hfx ! any values from input discarded +!*** local + integer::i + logical:: real,ideal + real::lat_ctr,lon_ctr + character(len=128)msg +!*** executable + ! this is only until I figure out how to input arrays through the namelist... + hfx%num_lines=config_flags%fire_hfx_num_lines + if(fire_max_lines.lt.hfx%num_lines)call crash('fire_max_lines too small') + + ! figure out which kind of coordinates from the first given + ideal=config_flags%fire_hfx_start_x1 .ne.0. .or. config_flags%fire_hfx_start_y1 .ne. 0. + real=config_flags%fire_hfx_start_lon1 .ne. 0. .or. config_flags%fire_hfx_start_lat1 .ne. 0. + if(ideal)call message('Using ideal heat flux line coordinates, m from the lower left domain corner') + if(real)call message('Using real heat flux line coordinates, longitude and latitude') + if(ideal.and.real)call crash('Only one of the ideal or real coordinates may be given') + + hfx%longlat=0 ! default, if no ignition + if(ideal)then + ! use values from _x and _y variables + hfx%longlat=0 + hfx%line(1)%start_x=config_flags%fire_hfx_start_x1 + hfx%line(1)%start_y=config_flags%fire_hfx_start_y1 + hfx%line(1)%end_x=config_flags%fire_hfx_end_x1 + hfx%line(1)%end_y=config_flags%fire_hfx_end_y1 + endif + if(real)then + ! use values from _long and _lat + hfx%longlat=1 + hfx%line(1)%start_x=config_flags%fire_hfx_start_lon1 + hfx%line(1)%start_y=config_flags%fire_hfx_start_lat1 + hfx%line(1)%end_x=config_flags%fire_hfx_end_lon1 + hfx%line(1)%end_y=config_flags%fire_hfx_end_lat1 + endif + ! common to both cases + hfx%line(1)%radius=config_flags%fire_hfx_radius1 + hfx%line(1)%start_time=config_flags%fire_hfx_start_time1 + hfx%line(1)%end_time=config_flags%fire_hfx_end_time1 + hfx%line(1)%trans_time=config_flags%fire_hfx_trans_time1 + hfx%line(1)%hfx_value=config_flags%fire_hfx_value1 + + call postprocess_lines(hfx,'hfx',config_flags) + +end subroutine fire_hfx_convert + +subroutine set_flags(config_flags) +USE module_configure +implicit none +TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags +! copy flags from wrf to module_fr_sfire_util +! for instructions how to add a flag see the top of module_fr_sfire_util.F + +fire_perimeter_time = config_flags%fire_perimeter_time +fire_tign_in_time = config_flags%fire_tign_in_time +fire_print_msg = config_flags%fire_print_msg +fire_print_file = config_flags%fire_print_file +fuel_left_method = config_flags%fire_fuel_left_method +fuel_left_irl = config_flags%fire_fuel_left_irl +fuel_left_jrl = config_flags%fire_fuel_left_jrl +fire_atm_feedback = config_flags%fire_atm_feedback +fire_hfx_given = config_flags%fire_hfx_given +fire_hfx_num_lines = config_flags%fire_hfx_num_lines +fire_hfx_latent_part = config_flags%fire_hfx_latent_part +fire_update_fuel_frac = config_flags%fire_update_fuel_frac +boundary_guard = config_flags%fire_boundary_guard +fire_back_weight = config_flags%fire_back_weight +fire_grows_only = config_flags%fire_grows_only +fire_upwinding = config_flags%fire_upwinding +fire_viscosity = config_flags%fire_viscosity +fire_lfn_ext_up = config_flags%fire_lfn_ext_up +fire_test_steps = config_flags%fire_test_steps +!fire_topo_from_atm = config_flags%fire_topo_from_atm +fire_advection = config_flags%fire_advection +fire_wind_log_interp = config_flags%fire_wind_log_interp +fire_use_windrf = config_flags%fire_use_windrf +fire_fmc_read = config_flags%fire_fmc_read +fire_ignition_clamp = config_flags%fire_ignition_clamp +kfmc_ndwi = config_flags%kfmc_ndwi +fndwi_from_ndwi = config_flags%fndwi_from_ndwi + +end subroutine set_flags + +! +!***************************** +! + + +subroutine set_fp_from_grid(grid,fp) + implicit none + type(domain),intent(in)::grid + type(fire_params),intent(out)::fp + + ! pointers to be passed to fire spread formulas + fp%vx => grid%uf ! fire winds + fp%vy => grid%vf ! fire winds + fp%zsf => grid%zsf ! terrain height + fp%dzdxf => grid%dzdxf ! terrain grad + fp%dzdyf => grid%dzdyf ! terrain grad + fp%bbb => grid%bbb ! spread formula coeff + fp%phisc => grid%phisc ! spread formula coeff + fp%phiwc => grid%phiwc ! spread formula coeff + fp%r_0 => grid%r_0 ! spread formula coeff + fp%fgip => grid%fgip ! spread formula coeff + fp%ischap => grid%ischap ! spread formula coeff + fp%fuel_time => grid%fuel_time ! time for fuel to burn to 1/e + fp%fmc_g => grid%fmc_g ! fuel moisture, ground + fp%nfuel_cat => grid%nfuel_cat ! fuel category + + +end subroutine set_fp_from_grid + + +subroutine print_id +character(len=128)::id,msg +#include "sfire_id.inc" +msg=id +call message(msg,level=1) +end subroutine print_id + +end module module_fr_sfire_driver diff --git a/wrfv2_fire/phys/module_fr_sfire_driver_wrf.F b/wrfv2_fire/phys/module_fr_sfire_driver_wrf.F new file mode 100644 index 00000000..2010b72b --- /dev/null +++ b/wrfv2_fire/phys/module_fr_sfire_driver_wrf.F @@ -0,0 +1,291 @@ +! WRF:MEDIATION_LAYER:FIRE_MODEL + +! This is WRF interface driver for SFIRE, the fire module in WRF-Fire. +! Please see module_fr_sfire_driver.F for acknowledgements. + + +#define DEBUG_OUT + +module module_fr_sfire_driver_wrf +! wrf-specific driver + +use module_fr_sfire_driver +use module_fr_sfire_atm +USE module_utility, only: WRFU_TimeInterval,WRFU_TimeIntervalGet, WRFU_SUCCESS +implicit none + +contains + +subroutine sfire_driver_em_init (grid , config_flags & + ,ids,ide, kds,kde, jds,jde & + ,ims,ime, kms,kme, jms,jme & + ,ips,ipe, kps,kpe, jps,jpe) + + ! stub to call sfire_driver_em with irun=0 and omit last 3 args + + USE module_domain , only: domain , get_ijk_from_subgrid , & + domain_get_time_since_sim_start , & + domain_get_time_step + USE module_configure , only : grid_config_rec_type + implicit none + + TYPE(domain) , TARGET :: grid ! data + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + integer, intent(in):: & + ids,ide, kds,kde, jds,jde & + ,ims,ime, kms,kme, jms,jme & + ,ips,ipe, kps,kpe, jps,jpe + + ! local + integer :: & ! fire mesh sizes + ifds,ifde, kfds,kfde, jfds,jfde, & + ifms,ifme, kfms,kfme, jfms,jfme, & + ifps,ifpe, kfps,kfpe, jfps,jfpe + real::time_step_start, dt ! dummies, avoid uninitialized + ! dummies + + call message('sfire_driver_em_init: SFIRE initialization start') + + ! get fire mesh dimensions + CALL get_ijk_from_subgrid ( grid , & + ifds,ifde, jfds,jfde,kfds,kfde, & + ifms,ifme, jfms,jfme,kfms,kfme, & + ifps,ifpe, jfps,jfpe,kfps,kfpe) + + ! times in seconds + time_step_start=TimeInterval2Sec(domain_get_time_since_sim_start(grid)) + dt=TimeInterval2Sec(domain_get_time_step(grid)) + + call sfire_driver_em ( grid , config_flags & + ,time_step_start,dt & + ,ifun_beg,ifun_step-1,0 & ! ifun start, end, test steps + ,ids,ide, kds,kde, jds,jde & + ,ims,ime, kms,kme, jms,jme & + ,ips,ipe, kps,kpe, jps,jpe & + ,ifds,ifde, jfds,jfde & + ,ifms,ifme, jfms,jfme & + ,ifps,ifpe, jfps,jfpe & + ) + + call message('sfire_driver_em_init: SFIRE initialization complete') + +end subroutine sfire_driver_em_init + +! +!*** +! + +subroutine sfire_driver_em_step (grid , config_flags & + ,ids,ide, kds,kde, jds,jde & + ,ims,ime, kms,kme, jms,jme & + ,ips,ipe, kps,kpe, jps,jpe & + ,rho,z_at_w,dz8w ) + + ! stub to call sfire_driver_em + + USE module_domain, only: domain , get_ijk_from_subgrid , & + domain_get_time_since_sim_start , & + domain_get_time_step + USE module_configure , only : grid_config_rec_type + USE module_fr_sfire_util, only : fire_test_steps + USE module_state_description, only: num_tracer +#ifdef WRF_CHEM + USE module_state_description, only: num_chem +#endif + implicit none + + TYPE(domain) , TARGET :: grid ! data + TYPE (grid_config_rec_type) , INTENT(IN) :: config_flags + integer, intent(in):: & + ids,ide, kds,kde, jds,jde & + ,ims,ime, kms,kme, jms,jme & + ,ips,ipe, kps,kpe, jps,jpe + real,dimension(ims:ime, kms:kme, jms:jme),intent(in)::rho,z_at_w,dz8w + + + ! local + integer :: & ! fire mesh sizes + ifds,ifde, kfds,kfde, jfds,jfde, & + ifms,ifme, kfms,kfme, jfms,jfme, & + ifps,ifpe, kfps,kfpe, jfps,jfpe + integer :: its,ite,jts,jte,kts,kte ! atm tile + integer:: ij, ipe1,jpe1,kpe1 + real::time_step_start,dt + + integer::fire_time_step_ratio,itime_step,i,j,k + real,dimension( ips:ipe , jps:jpe ) :: grnhfx_save, grnqfx_save, & + canhfx_save, canqfx_save + character(len=128)::msg + + ! executable + + call message('sfire_driver_em_step: SFIRE step start') + + ! times in seconds + + ! get fire time step refinement from namelist + fire_time_step_ratio=config_flags%fire_time_step_ratio + + if(fire_time_step_ratio.lt.1)then + call crash('fire_time_step_ratio must be >= 1') + endif + + time_step_start=TimeInterval2Sec(domain_get_time_since_sim_start(grid)) + dt=TimeInterval2Sec(domain_get_time_step(grid))/fire_time_step_ratio + + + ! get fire mesh dimensions + CALL get_ijk_from_subgrid ( grid , & + ifds,ifde, jfds,jfde,kfds,kfde, & + ifms,ifme, jfms,jfme,kfms,kfme, & + ifps,ifpe, jfps,jfpe,kfps,kfpe) + + ! save fluxes for tendency + grnhfx_save(:,:)=0. + grnqfx_save(:,:)=0. + canhfx_save(:,:)=0. + canqfx_save(:,:)=0. + + ! ignore last row in domain, not set properly + ! done below when setting ite,jte + ipe1 = min(ipe,ide-1) + jpe1 = min(jpe,jde-1) + kpe1=kpe-1 + + ! TMG +! do j=jps,jpe1 +! do k=kps,kpe1 +! do i=ips,ipe1 +! print*, 'sfire_driver_wrf j, k, i ', grid%u_2(i,k,j), grid%t2(i,j) +! enddo +! enddo +! enddo + + ! fire time step loop + do itime_step = 1,fire_time_step_ratio + + call sfire_driver_em ( grid , config_flags & + ,time_step_start,dt & + ,ifun_step,ifun_end,fire_test_steps & + ,ids,ide, kds,kde, jds,jde & + ,ims,ime, kms,kme, jms,jme & + ,ips,ipe, kps,kpe, jps,jpe & + ,ifds,ifde, jfds,jfde & + ,ifms,ifme, jfms,jfme & + ,ifps,ifpe, jfps,jfpe & + ,rho,z_at_w,dz8w & + ) + + ! accumulate fluxes for atmospheric tendency + do j=jps,jpe1 + do i=ips,ipe1 + grnhfx_save(i,j)=grnhfx_save(i,j) + grid%grnhfx(i,j) + grnqfx_save(i,j)=grnqfx_save(i,j) + grid%grnqfx(i,j) + canhfx_save(i,j)=canhfx_save(i,j) + grid%canhfx(i,j) + canqfx_save(i,j)=canqfx_save(i,j) + grid%canqfx(i,j) + enddo + enddo + + time_step_start=time_step_start+dt + enddo + + ! copy fluxes back to grid structure + do j=jps,jpe1 + do i=ips,ipe1 + grid%grnhfx(i,j)=grnhfx_save(i,j)/fire_time_step_ratio + grid%grnqfx(i,j)=grnqfx_save(i,j)/fire_time_step_ratio + grid%canhfx(i,j)=canhfx_save(i,j)/fire_time_step_ratio + grid%canqfx(i,j)=canqfx_save(i,j)/fire_time_step_ratio + enddo + enddo + + + call print_chsum(0,ims,ime,kms,kme,jms,jme,ids,ide,kds,kde,jds,jde,ips,ipe1,kps,kpe1,jps,jpe1,0,0,0,z_at_w,'z_at_w') + call print_chsum(0,ims,ime,kms,kme,jms,jme,ids,ide,kds,kde,jds,jde,ips,ipe1,kps,kpe1,jps,jpe1,0,0,0,dz8w,'dz8w') + call print_chsum(0,ims,ime,kms,kme,jms,jme,ids,ide,kds,kde,jds,jde,ips,ipe1,kps,kpe1,jps,jpe1,0,0,0,rho,'rho') + call print_chsum(0,ims,ime,1,1,jms,jme,ids,ide,1,1,jds,jde,ips,ipe1,1,1,jps,jpe1,0,0,0,grid%mut,'mu') + call print_3d_stats(ips,ipe1,kps,kpe1,jps,jpe1,ims,ime,kms,kme,jms,jme,rho,'rho') + call print_3d_stats(ips,ipe1,kps,kpe1,jps,jpe1,ims,ime,kms,kme,jms,jme,z_at_w,'z_at_w') + call print_3d_stats(ips,ipe1,kps,kpe1,jps,jpe1,ims,ime,kms,kme,jms,jme,dz8w,'dz8w') + + ! --- add heat and moisture fluxes to tendency variables by postulated decay + do ij=1,grid%num_tiles + ! SFIRE works on domain by 1 smaller, in last row&col winds are not set properly + its = grid%i_start(ij) ! start atmospheric tile in i + ite = min(grid%i_end(ij),ide-1) ! end atmospheric tile in i + jts = grid%j_start(ij) ! start atmospheric tile in j + jte = min(grid%j_end(ij),jde-1) ! end atmospheric tile in j + kts=kds + kte=kde + + call fire_tendency( & + ids,ide-1, kds,kde, jds,jde-1, & ! domain dimensions + ims,ime, kms,kme, jms,jme, & + its,ite, kts,kte, jts,jte, & ! + grid%grnhfx,grid%grnqfx,grid%canhfx,grid%canqfx, & ! fluxes on atm grid + config_flags%fire_ext_grnd,config_flags%fire_ext_crwn,config_flags%fire_crwn_hgt, & + grid%ht,z_at_w,dz8w,grid%mut,rho, & + grid%rthfrten,grid%rqvfrten) ! out + + enddo + +#ifdef WRF_CHEM + + write(msg,991)lbound(grid%chem,4),ubound(grid%chem,4) +991 format('chem array dimensions ',i3,':',i3) + call message(msg) + write(msg,992)num_chem, config_flags%chem_opt +992 format('number of chem species:',i4,' chem_opt=',i3) + call message(msg) + +#endif + + write(msg,993)lbound(grid%tracer,4),ubound(grid%tracer,4) +993 format('tracer array dimensions ',i3,':',i3) + call message(msg) + write(msg,994)num_tracer,config_flags%tracer_opt +994 format('number of tracers:',i3,' tracer_opt=',i3) + call message(msg) + + + ! fire emission source for wrf chem +! if(config_flags%tracer_opt>0)then +! call fire_emission( & +! config_flags%tracer_opt, & +! ids,ide-1, kds,kde, jds,jde-1, & ! domain dimensions +! ims,ime, kms,kme, jms,jme, & +! its,ite, kts,kte, jts,jte, & +! rho,dz8w, & +! grid%grnhfx, & ! fire input variables +! grid%tracer) ! emission output +! endif + + ! debug print to compare + + call print_3d_stats(its,ite,kts,kte,jts,jte,ims,ime,kms,kme,jms,jme,grid%rthfrten,'fire_driver_phys:rthfrten') + call print_3d_stats(its,ite,kts,kte,jts,jte,ims,ime,kms,kme,jms,jme,grid%rqvfrten,'fire_driver_phys:rqvfrten') + + call message('sfire_driver_em_step: SFIRE step complete') + +end subroutine sfire_driver_em_step + +double precision function TimeInterval2Sec(time) +! convert ESMF_Timeinterval type to seconds +! has double precision type just in case it is needed in future +! will silently convert to single precition on use. + TYPE(WRFU_TimeInterval), intent(in) :: time +! local + integer::rc,S,Sn,Sd +! executable + call WRFU_TimeIntervalGet(time,S=S,Sd=Sd,Sn=Sn,rc=rc) + if(rc.ne.WRFU_SUCCESS)call crash('TimeInterval2Sec: WRFU_TimeIntervalGet failed') + ! print *,'WRFU_TimeIntervalGet returned S=',S,'Sn=',Sn,'Sd=',Sd + if(Sd.ne.0)then + TimeInterval2Sec=dble(S)+dble(Sn)/dble(Sd) + else + TimeInterval2Sec=dble(S) + endif +end function TimeInterval2Sec + +end module module_fr_sfire_driver_wrf + diff --git a/wrfv2_fire/phys/module_fr_sfire_model.F b/wrfv2_fire/phys/module_fr_sfire_model.F new file mode 100644 index 00000000..49abd5c1 --- /dev/null +++ b/wrfv2_fire/phys/module_fr_sfire_model.F @@ -0,0 +1,711 @@ +! +#define DEBUG_OUT + +module module_fr_sfire_model + +use module_fr_sfire_core +use module_fr_sfire_util +use module_fr_sfire_phys + +implicit none + +contains + +subroutine sfire_model ( & + id, & ! unique number for prints and debug + ifun, & ! what to do see below + restart,replay, & ! use existing state, prescribe spread + run_fuel_moisture, & ! if need update fuel moisture in pass 4 + ifuelread,nfuel_cat0, & ! initialize fuel categories + ifds,ifde,jfds,jfde, & ! fire domain dims - the whole domain + ifms,ifme,jfms,jfme, & ! fire memory dims - how declared + ifps,ifpe,jfps,jfpe, & ! patch - nodes owned by this process + ifts,ifte,jfts,jfte, & ! fire tile dims - this thread + time_start,dt, & ! time and increment + fdx,fdy, & ! fire mesh spacing, + ignition,hfx, & ! small array of ignition line descriptions + coord_xf,coord_yf, & ! fire mesh coordinates + fire_hfx, & ! input: given heat flux, or set inside + tign_in, & ! ignition time, if given + lfn,lfn_out,tign,fuel_frac,fire_area, & ! state: level function, ign time, fuel left, area burning + fuel_frac_burnt, & ! output: fuel fraction burnt in this timestep + fgrnhfx,fgrnqfx, & ! output: heat fluxes + ros,flineint,flineint2, & ! diagnostic variables + f_ros0,f_rosx,f_rosy,f_ros, & ! fire risk spread + f_int,f_lineint,f_lineint2, & ! fire risk intensities + nfuel_cat, & ! fuel data per point + fuel_time,fwh,fz0, & ! save derived internal data + fp & +) + +! This subroutine implements the fire spread model. +! All quantities are on the fire grid. It inputs +! winds given on the nodes of the fire grid +! and outputs the heat fluxes on the cells of the fire grid. +! This subroutine has no knowledge of any atmospheric model. +! This code was written to conform with the WRF parallelism model, however it +! does not depend on it. It can be called with domain equal to tile. +! Wind and height must be given on 1 more node beyond the domain bounds. +! The subroutine changes only array entries of the arguments in the tile. +! Upon exit with ifun=2 (time step), lfn_out is to be copied into lfn by the caller. +! When this subroutine is used on separate tiles that make a domain the value, the +! it uses lfn on a strip of width 2 from neighboring tiles. +! +! All computation is done on one tile. +! +! This subroutine is intended to be called in a loop like +! +! +! do ifun=1,6 (if initizalize run, otherwise 3,6) +! start parallel loop over tiles +! if ifun=1, set z and fuel data +! if ifun=3, set the wind arrays +! call sfire_model(....) +! end parallel loop over tiles +! +! +! if ifun=0 +! halo exchange on z width 2 +! halo exchange on fuel data width 1 +! endif +! +! if ifun=3, halo exchange on winds width 2 +! +! enddo + +implicit none + +!*** arguments + +! control switches +integer, intent(in) :: id +integer, intent(in) :: ifun ! 1 = initialize run pass 1 + ! 2 = initialize run pass 2 + ! 3 = initialize timestep + ! 4 = do one timestep + ! 5 = copy timestep output to input + ! 6 = compute output fluxes +logical, intent(in):: restart ! if true, use existing state +logical, intent(in):: replay ! if true, use tign_g for level set +logical, intent(in)::run_fuel_moisture ! +! scalar data +integer, intent(in) :: ifuelread,nfuel_cat0 ! for set_fire_params +integer, intent(in) :: ifds,ifde,jfds,jfde,& ! fire domain bounds + ifps,ifpe,jfps,jfpe ! patch - nodes owned by this process +integer, intent(in) :: ifts,ifte,jfts,jfte ! fire tile bounds +integer, intent(in) :: ifms,ifme,jfms,jfme ! fire memory array bounds +REAL,INTENT(in) :: time_start,dt ! starting time, time step +REAL,INTENT(in) :: fdx,fdy ! spacing of the fire mesh +! array data +type(lines_type), intent(in):: ignition,hfx ! descriptions of ignition lines and hfx lines +real, dimension(ifms:ifme, jfms:jfme), intent(in):: & + coord_xf,coord_yf ! node coordinates +real, dimension(ifms:ifme, jfms:jfme), intent(inout):: & + fire_hfx ! given heat flux + +real, dimension(ifms:ifme, jfms:jfme), intent(inout):: tign_in ! given ignition times +! state +REAL, INTENT(inout), dimension(ifms:ifme,jfms:jfme):: & + lfn , & ! level function: fire is where lfn<0 (node) + tign , & ! absolute time of ignition (node) + fuel_frac ! fuel fraction (node), currently redundant + +REAL, INTENT(out), dimension(ifms:ifme,jfms:jfme):: & + fire_area, & ! fraction of each cell burning + fuel_frac_burnt ! fuel fraction burned in this timestep + +! output +REAL, INTENT(out), dimension(ifms:ifme,jfms:jfme):: & + lfn_out, & ! + fgrnhfx,fgrnqfx, & ! heat fluxes J/m^2/s (cell) + ros,flineint,flineint2, & ! diagnostic variables + f_ros0,f_rosx,f_rosy,f_ros, & ! fire risk spread + f_int,f_lineint,f_lineint2 ! fire risk intensities + + +! constant arrays - set at initialization +real, intent(inout), dimension(ifms:ifme, jfms:jfme)::nfuel_cat ! cell based, data, constant +real,intent(inout),dimension(ifms:ifme,jfms:jfme):: fuel_time,fwh,fz0 +type(fire_params),intent(inout)::fp + +!*** local + +integer :: xifms,xifme,xjfms,xjfme ! memory bounds for pass-through arguments to normal spread +real, dimension(ifts:ifte,jfts:jfte)::fuel_frac_end +integer::ignited,ig,i,j,itso,iteo,jtso,jteo +real::tbound,err,erri,errj,maxgrad,grad,tfa,thf,mhf,tqf,mqf,aw,mw,t +character(len=128)::msg +logical:: freeze_fire +real::fireline_mask=0. + +!*** executable + +call check_mesh_2dim(ifts-1,ifte+1,jfts-1,jfte+1,ifms,ifme,jfms,jfme) + +xifms=ifms ! dimensions for the include file +xifme=ifme +xjfms=jfms +xjfme=jfme + + +! init flags +freeze_fire = fire_hfx_given .ne. 0 + + +if(ifun.eq.1)then ! do nothing, init pass 1 is outside only +! !$OMP SINGLE +!! done in driver now +! call init_fuel_cats ! initialize fuel subsystem +! !$OMP END SINGLE + if(replay) then + ! when starting replay, recompute lfn and fuel_frac + call message('replay, setting the level set function',level=1) + do j=jfts,jfte + do i=ifts,ifte + lfn(i,j) = tign(i,j) - time_start ! <0 if burning at the end of the time step + enddo + enddo + endif + call check_lfn_tign('starting replay',time_start,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn,tign) +elseif(ifun.eq.2)then + ! initialize all arrays that the model will not change later + + ! assuming halo on zsf done + ! extrapolate on 1 row of cells beyond the domain boundary + ! including on the halo regions + + call continue_at_boundary(1,1,0., & ! do x direction or y direction + ifms,ifme,jfms,jfme, & ! memory dims + ifds,ifde,jfds,jfde, & ! domain dims + ifps,ifpe,jfps,jfpe, & ! patch dims - winds defined up to +1 + ifts,ifte,jfts,jfte, & ! tile dims + itso,iteo,jtso,jteo, & ! where set now + fp%zsf) ! array + +! compute the gradients once for all + err=0. + maxgrad=0. + do j=jfts,jfte + do i=ifts,ifte + erri = fp%dzdxf(i,j) - (fp%zsf(i+1,j)-fp%zsf(i-1,j))/(2.*fdx) + errj = fp%dzdyf(i,j) - (fp%zsf(i,j+1)-fp%zsf(i,j-1))/(2.*fdy) + err=max(err,abs(erri),abs(errj)) + grad=sqrt(fp%dzdxf(i,j)**2+fp%dzdyf(i,j)**2) + maxgrad=max(maxgrad,grad) + enddo + enddo +!$OMP CRITICAL(SFIRE_MODEL_CRIT) + write(msg,*)'max gradient ',maxgrad,' max error against zsf',err +!$OMP END CRITICAL(SFIRE_MODEL_CRIT) + call message(msg) + + call set_nfuel_cat( & ! also on restart + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + ifuelread,nfuel_cat0,& + fp%zsf,nfuel_cat) ! better not use the extrapolated zsf!! + + ! uses nfuel_cat to set the other fuel data arrays + ! needs zsf on halo width 1 to compute the terrain gradient + call set_fire_params( & ! also on restart + ifds,ifde,jfds,jfde, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + fdx,fdy,nfuel_cat0, & + nfuel_cat,fuel_time, & + fp) + + ! initialize model state to no fire / set tign_in + if(.not.restart)then + call init_no_fire ( & + ifds,ifde,jfds,jfde, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + fdx,fdy,time_start,dt, & + fuel_frac,fire_area,lfn,tign_in,tign) + + endif + + if(replay) then + call message('replay, recomputing fuel fraction') + call check_lfn_tign('recomputing fuel fraction',time_start,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn,tign) + call fuel_left( & + ifds,ifde,jfds,jfde, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + ifms,ifme,jfms,jfme, & + lfn,tign,fuel_time,time_start,fuel_frac,fire_area) !fuel_frac is global + endif + +elseif(ifun.eq.3)then ! ignition if so specified + + +elseif (ifun.eq.4) then ! do the timestep + + call check_lfn_tign('time step start',time_start,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn, tign) + if(run_fuel_moisture)then + ! uses nfuel_cat to set the other fuel data arrays + ! needs zsf on halo width 1 to compute the terrain gradient + call set_fire_params( & ! also on restart + ifds,ifde,jfds,jfde, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + fdx,fdy,nfuel_cat0, & + nfuel_cat,fuel_time, & + fp) + endif + + if(fire_print_msg.ge.stat_lev)then + aw=fun_real(RNRM_SUM, & + ifms,ifme,1,1,jfms,jfme, & ! memory dims + ifds,ifde,1,1,jfds,jfde, & ! domain dims + ifts,ifte,1,1,jfts,jfte, & ! patch or tile dims + 0,0,0, & ! staggering + fp%vx,fp%vy)/((ifde-ifds+1)*(jfde-jfds+1)) + mw=fun_real(RNRM_MAX, & + ifms,ifme,1,1,jfms,jfme, & ! memory dims + ifds,ifde,1,1,jfds,jfde, & ! domain dims + ifts,ifte,1,1,jfts,jfte, & ! patch or tile dims + 0,0,0, & ! staggering + fp%vx,fp%vy) +!$OMP MASTER + write(msg,91)time_start,'Average surface wind',aw,'m/s' + call message(msg,stat_lev) + write(msg,91)time_start,'Maximum surface wind',mw,'m/s' + call message(msg,stat_lev) +!$OMP END MASTER + endif + +! compute fuel fraction at start +! call fuel_left( & +! ifms,ifme,jfms,jfme, & +! ifts,ifte,jfts,jfte, & +! ifms,ifme,jfms,jfme, & +! lfn,tign,fuel_time,time_start,fuel_frac,fire_area) ! fuel frac is shared + + call print_2d_stats(ifts,ifte,jfts,jfte, & + ifms,ifme,jfms,jfme, & + fuel_frac,'model: fuel_frac start') + + ! advance the model from time_start to time_start+dt + ! return the fuel fraction burnt this call in each fire cell + ! will call module_fr_sfire_speed::normal_spread for propagation speed + ! We cannot simply compute the spread rate here because that will change with the + ! angle of the wind and the direction of propagation, thus it is done in subroutine + ! normal_spread at each fire time step. Instead, we pass arguments that + ! the speed function may use as fp. + +! propagate level set function in time +! set lfn_out tign +! lfn does not change, tign has no halos + + if(.not. freeze_fire)then + if(.not.replay) then + call prop_ls(id,1, & + ifds,ifde,jfds,jfde, & ! fire domain dims - the whole domain + ifms,ifme,jfms,jfme, & + ifps,ifpe,jfps,jfpe, & ! patch - nodes owned by this process + ifts,ifte,jfts,jfte, & + time_start,dt,fdx,fdy,tbound, & + lfn,lfn_out,tign,ros, fp & + ) + else + do j=jfts,jfte + do i=ifts,ifte + lfn_out(i,j) = tign(i,j) - (time_start + dt) ! <0 if burning at the end of the time step + enddo + enddo + endif + else + call message('sfire_model: EXPERIMENTAL: skipping fireline propagation') + + endif + + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme, ros,'model: ros') + +elseif (ifun.eq.5) then ! copy the result of timestep back to input + ! this cannot be done in the time step itself because of race condition + ! some thread may still be using lfn as input in their tile halo + + ! fix lfn_out if needed and compute tign + if(.not. freeze_fire)then + if(.not.replay) then + call prop_ls(id,2, & + ifds,ifde,jfds,jfde, & ! fire domain dims - the whole domain + ifms,ifme,jfms,jfme, & + ifps,ifpe,jfps,jfpe, & ! patch - nodes owned by this process + ifts,ifte,jfts,jfte, & + time_start,dt,fdx,fdy,tbound, & + lfn,lfn_out,tign,ros, fp & + ) + endif + endif + + call check_lfn_tign('time step end',time_start+dt,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn_out, tign) + + if(.not. freeze_fire)then + do j=jfts,jfte + do i=ifts,ifte + lfn(i,j)=lfn_out(i,j) + ! if want to try timestep again treat tign the same way here + ! even if tign does not need a halo + enddo + enddo + + call check_lfn_tign('before ignition',time_start+dt,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn, tign) + + ! check for ignitions + if( fire_tign_in_time > 0.) then + if (ignition%num_lines > 0) then + call crash('ignition from lines and from tign_in are not compatible') + endif + call ignite_from_tign_in( & + ifds,ifde,jfds,jfde, & ! fire domain dims - the whole domain + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + time_start,time_start+dt, & + tign_in, & + lfn,tign,ignited) + call check_lfn_tign('after ignite_from_tign_in',time_start+dt,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn, tign) + endif + + + do ig = 1,ignition%num_lines + +! for now, check for ignition every time step... +! if(ignition%line(ig)%end_time>=time_start.and.ignition%line(ig)%start_time0. .and. lfn(i-1,j)>0. .and. lfn(i,j-1)>0. .and. lfn(i,j)>0. .and. & + lfn(i+1,j+1)>0. .and. lfn(i+1,j)>0. .and. lfn(i,j+1)>0. ) .or. & + (lfn(i-1,j-1)<0. .and. lfn(i-1,j)<0. .and. lfn(i,j-1)<0. .and. lfn(i,j)<0. .and. & + lfn(i+1,j+1)<0. .and. lfn(i+1,j)<0. .and. lfn(i,j+1)<0. ) .or. & + i.eq.ifds .or. i .eq. ifde .or. j.eq.jfds .or. j.eq.jfde) then + ros(i,j)=fireline_mask + flineint(i,j)=fireline_mask + flineint2(i,j)=fireline_mask + endif + enddo + enddo + endif + + call fire_risk(fp, & + ifms,ifme,jfms,jfme, & ! memory dims + ifts,ifte,jfts,jfte, & ! tile dims + nfuel_cat, & ! + f_ros0,f_rosx,f_rosy,f_ros, & ! fire spread + f_int,f_lineint,f_lineint2) ! fire intensities for danger rating + + + select case(fire_hfx_given) + + case(0) ! normal + + ! compute the heat fluxes from the fuel burned + ! needs lfn and tign from neighbors so halo must be updated before +!$OMP CRITICAL(SFIRE_MODEL_CRIT) + write(msg,*)'time_start=',time_start,' dt=',dt,' before fuel_left' +!$OMP END CRITICAL(SFIRE_MODEL_CRIT) + call message(msg) + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn,'model: lfn') + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,tign,'model: tign') + call check_lfn_tign('before fuel_left',time_start+dt,ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,lfn, tign) + + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fuel_time,'model: fuel_time') + + if(fire_update_fuel_frac.eq.1)then + ! run model the normal way + call fuel_left(& + ifds,ifde,jfds,jfde, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + ifts,ifte,jfts,jfte, & + lfn,tign,fuel_time,time_start+dt,fuel_frac_end,fire_area) !fuel_frac_end is private and tile based + + call print_2d_stats(ifts,ifte,jfts,jfte,ifts,ifte,jfts,jfte,fuel_frac_end,'model: fuel_frac end') + + do j=jfts,jfte + do i=ifts,ifte + t = min(fuel_frac(i,j),fuel_frac_end(i,j)) ! do not allow fuel fraction to increase, in case of approximation error + fuel_frac_burnt(i,j)=fuel_frac(i,j)-t ! fuel lost this timestep + fuel_frac(i,j)=t ! copy new value to state array + enddo + enddo + elseif(fire_update_fuel_frac.eq.2)then + do j=jfts,jfte + do i=ifts,ifte + if(lfn(i,j)<0.)then + fuel_frac_burnt(i,j) = dt / fuel_time(i,j) + else + fuel_frac_burnt(i,j) = 0. + endif + enddo + enddo + else + call crash('fire_update_fuel_frac value not supported') + endif + + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fuel_frac_burnt,'model: fuel_frac burned') + + call heat_fluxes(dt,fp, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + ifms,ifme,jfms,jfme, & ! fuel_frac_burned has standard memory dimensions + fp%fgip, & + fuel_frac_burnt, & ! + fgrnhfx,fgrnqfx) !out + + case (1, 2) +!$OMP CRITICAL(SFIRE_MODEL_CRIT) + write(msg,*)"model: expecting fire_hfx to be set in WRF, from wrfinput or wrfrst files" + call message(msg) +!$OMP END CRITICAL(SFIRE_MODEL_CRIT) + + do j=jfts,jfte + do i=ifts,ifte + fgrnhfx(i,j) = (1. - fire_hfx_latent_part)*fire_hfx(i,j) + fgrnqfx(i,j) = fire_hfx_latent_part *fire_hfx(i,j) + enddo + enddo + + case (3) + + call message('artificial heat flux from parameters given in namelist.input') + + call param_hfx( time_start, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + coord_xf,coord_yf, & + hfx, & + fire_area,fgrnhfx,fgrnqfx) + + case default + call crash('bad fire_hfx_given') + end select + + ! this should run in any case + + if(fire_print_msg.ge.stat_lev)then + tfa=fun_real(REAL_SUM, & + ifms,ifme,1,1,jfms,jfme, & ! memory dims + ifds,ifde,1,1,jfds,jfde, & ! domain dims + ifts,ifte,1,1,jfts,jfte, & ! patch or tile dims + 0,0,0, & ! staggering + fire_area,fire_area) * fdx * fdy + thf=fun_real(REAL_SUM, & + ifms,ifme,1,1,jfms,jfme, & ! memory dims + ifds,ifde,1,1,jfds,jfde, & ! domain dims + ifts,ifte,1,1,jfts,jfte, & ! patch or tile dims + 0,0,0, & ! staggering + fgrnhfx,fgrnhfx) * fdx * fdy + mhf=fun_real(REAL_MAX, & + ifms,ifme,1,1,jfms,jfme, & ! memory dims + ifds,ifde,1,1,jfds,jfde, & ! domain dims + ifts,ifte,1,1,jfts,jfte, & ! patch or tile dims + 0,0,0, & ! staggering + fgrnhfx,fgrnhfx) + tqf=fun_real(REAL_SUM, & + ifms,ifme,1,1,jfms,jfme, & ! memory dims + ifds,ifde,1,1,jfds,jfde, & ! domain dims + ifts,ifte,1,1,jfts,jfte, & ! patch or tile dims + 0,0,0, & ! staggering + fgrnqfx,fgrnqfx) * fdx * fdy + mqf=fun_real(REAL_MAX, & + ifms,ifme,1,1,jfms,jfme, & ! memory dims + ifds,ifde,1,1,jfds,jfde, & ! domain dims + ifts,ifte,1,1,jfts,jfte, & ! patch or tile dims + 0,0,0, & ! staggering + fgrnqfx,fgrnqfx) +!$OMP MASTER + write(msg,91)time_start,'Fire area ',tfa,'m^2' + call message(msg,stat_lev) + write(msg,91)time_start,'Heat output ',thf,'W' + call message(msg,stat_lev) + write(msg,91)time_start,'Max heat flux ',mhf,'W/m^2' + call message(msg,stat_lev) + write(msg,91)time_start,'Latent heat output ',tqf,'W' + call message(msg,stat_lev) + write(msg,91)time_start,'Max latent heat flux',mqf,'W/m^2' + call message(msg,stat_lev) +!$OMP END MASTER +91 format('Time ',f11.3,' s ',a,e12.3,1x,a) + endif + + + call print_2d_stats(ifts,ifte,jfts,jfte, & + ifms,ifme,jfms,jfme, & + fgrnhfx,'model: heat flux(J/m^2/s)') + +else +!$OMP CRITICAL(SFIRE_MODEL_CRIT) + write(msg,*)'sfire_model: bad ifun=',ifun +!$OMP END CRITICAL(SFIRE_MODEL_CRIT) + call crash(msg) +endif + +end subroutine sfire_model + + subroutine param_hfx( time_now,& + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + coord_xf,coord_yf, & + hfx, & + fire_area,fgrnhfx,fgrnqfx) +!*** generate artifical heat flux from a parametric description +!*** arguments + real, intent(in)::time_now + integer, intent(in):: & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte + type(lines_type), intent(in)::hfx + real, dimension(ifms:ifme,jfms:jfme), intent(in)::coord_xf,coord_yf ! nodal coordinates + real, dimension(ifms:ifme,jfms:jfme), intent(out)::fire_area,fgrnhfx,fgrnqfx ! the imposed heat flux + character(len=128):: msg +!*** local + integer::i,j,k,nfa,ncells + real:: d2,ax,ay,hfrac,fa,thfx,t,r,radius + real, parameter:: sigma_mult=3. ! 3 gives drop to 1% in trans. time from gaussian kernel + real:: maxspeed=100 ! max speed how the circle can move + + do j=jfts,jfte ! zero out the outputs + do i=ifts,ifte + fire_area(i,j)=0 + fgrnhfx(i,j) = 0. + fgrnqfx(i,j) = 0. + enddo + enddo + + do k=1,hfx%num_lines + if(hfx%line(k)%radius > 0.)then + ! processing heatflux line i + ! find the time multiplier + t = max(hfx%line(k)%start_time - time_now, time_now - hfx%line(k)%end_time) + if(t > 0.)then ! postitive distance from the time interval + r = t / hfx%line(k)%trans_time ! position in the transition - 1 is at transition distance + hfrac = exp(-(sigma_mult * r)**2/2.) ! gaussian kernel + else + hfrac = 1.0 + endif + + + ! find the coordinates of the center of the heat flux circle now + ax = safe_prop(time_now, & + hfx%line(k)%start_time,& + hfx%line(k)%end_time,& + hfx%line(k)%start_x,& + hfx%line(k)%end_x, & + hfx%unit_fxlong*maxspeed) + ay = safe_prop(time_now,& + hfx%line(k)%start_time,& + hfx%line(k)%end_time,& + hfx%line(k)%start_y,& + hfx%line(k)%end_y, & + hfx%unit_fxlat*maxspeed) + + radius=hfx%line(k)%radius + +!$OMP CRITICAL(SFIRE_MODEL_CRIT) + write(msg,*)'hfx line ',i,' at ',time_now,'s ',hfrac,' of max ', hfx%line(k)%hfx_value + call message(msg) + write(msg,*)'center ',ax,ay,' radius ',radius + call message(msg) +!$OMP END CRITICAL(SFIRE_MODEL_CRIT) + + nfa=0 + ncells=0 + do j=jfts,jfte + do i=ifts,ifte + ! distance squared from the center + d2 = (hfx%unit_fxlong*(ax - coord_xf(i,j)))**2 + (hfx%unit_fxlat*(ay - coord_yf(i,j)))**2 + if(d2 < radius**2)then + fa=1. + else + fa=0. + endif + ! set heat fluxes + thfx= hfx%line(k)%hfx_value * hfrac * fa ! total heat flux at this point + fgrnhfx(i,j)= fgrnhfx(i,j) + (1.-fire_hfx_latent_part) * thfx + fgrnqfx(i,j)= fgrnqfx(i,j) + fire_hfx_latent_part * thfx + ! set fire area + fire_area(i,j) = max(fire_area(i,j),fa) + ! set stats + nfa=nfa+fa; + ncells=ncells+1 + enddo + enddo + +!$OMP CRITICAL(SFIRE_MODEL_CRIT) + write(msg,*)'Number of cells in fire area in this tile ',nfa,' ',(100.*nfa)/ncells,' %' + call message(msg) +!$OMP END CRITICAL(SFIRE_MODEL_CRIT) + + endif + enddo + end subroutine param_hfx + + + +real function safe_prop(t,t1,t2,x1,x2,ms) +! return x between x1 and x2 in the same proportion as is t between t1 and t2, safe in the case when t1=t2 and x1=x2 +! safe_prop = x1 + (t-t1)*(x2-x1)/(t2-t1) +! future: abs((x2-x1)/(t2-t1)) capped at ms but still return x1 when t=t1 and x2 when t=t2 +real, intent(in)::t,t1,t2,x1,x2,ms +real:: p,x + if(t2 < t1)call crash('safe_prop: must have t2>t1') + if(.not.ms>0.)call crash('safe_prop: must have ms>0') + if(t1 .eq. t2)then + if(x1.eq.x2)then + x=x1 + else + call crash('safe_prop: infinite speed') + endif + else + p = (t - t1)/(t2 - t1) ! 0 at t1, 1 at t2 + x = x1*(1.-p) + x2*p + endif + safe_prop=x +end function safe_prop +! +!***************** +! + +end module module_fr_sfire_model diff --git a/wrfv2_fire/phys/module_fr_sfire_phys.F b/wrfv2_fire/phys/module_fr_sfire_phys.F new file mode 100644 index 00000000..4cbb42fa --- /dev/null +++ b/wrfv2_fire/phys/module_fr_sfire_phys.F @@ -0,0 +1,1767 @@ +! + +!*** Jan Mandel August-October 2007 email: jmandel@ucar.edu or Jan.Mandel@gmail.com +! +! This file contains parts copied and/or adapted from earlier codes by +! Terry Clark, Janice Coen, Don Latham, and Net Patton. + +module module_fr_sfire_phys + +use module_model_constants, only: cp,xlv +use module_fr_sfire_util + +implicit none +PRIVATE + + +type fire_params +real,pointer,dimension(:,:):: vx,vy ! wind velocity (m/s) +real,pointer,dimension(:,:):: zsf ! terrain height (m) +real,pointer,dimension(:,:):: dzdxf,dzdyf ! terrain grad (1) +real,pointer,dimension(:,:):: bbb,phisc,phiwc,r_0 ! spread formula coefficients +real,pointer,dimension(:,:):: fgip ! init mass of surface fuel (kg/m^2) +real,pointer,dimension(:,:):: ischap ! 1 if chapparal +real,pointer,dimension(:,:):: fuel_time ! time to burn to 1/e (s) +real,pointer,dimension(:,:):: fmc_g ! fuel moisture contents, ground (1) +real,pointer,dimension(:,:):: nfuel_cat ! fuel category (integer values) +end type fire_params + +! subroutines and functions +PUBLIC:: init_fuel_cats,fire_ros,heat_fluxes,set_nfuel_cat,set_fire_params, & +write_fuels_m,fire_risk,fire_intensity,fuel_moisture,advance_moisture,fuel_name,& +fire_rate_of_spread + +! types +public:: fire_params + +! variables +PUBLIC:: fire_wind_height,fcz0,fcwh,have_fuel_cats,nfuelcats,no_fuel_cat,no_fuel_cat2,windrf,moisture_classes +PUBLIC:: mfuelcats +! NOTE: fcwh and fcz0 are called fwh and fz0 in read/write statements + + +! moisture behavior, see Mandel et al EGU 2012 + +!! To add moisture classes: +! 1. change parameter max_moisture_classes below +! 2. change the default of nfmc to the same value in Registry/registry.fire +! 3. add the appropriate lines real::fmc_gw= +! 4. add dfault + +!*** dimensions + INTEGER, PARAMETER :: mfuelcats = 30 ! max number of fuel categories + integer, parameter::max_moisture_classes=5 +!*** + + integer, parameter::zm=max_moisture_classes - 3 + integer:: moisture_classes=3 + real, dimension(max_moisture_classes):: drying_lag,wetting_lag,saturation_moisture,saturation_rain, & + rain_threshold,rec_drying_lag_sec,rec_wetting_lag_sec + integer, dimension(max_moisture_classes):: drying_model,wetting_model,fmc_gc_initialization + ! relative weights of moisture class for each fuel category + integer::itmp + CHARACTER (len=80), DIMENSION(max_moisture_classes), save :: moisture_class_name + real, dimension(mfuelcats):: & ! should sum up to one + fmc_gw01=(/ (1.0, itmp=1,mfuelcats) /), & + fmc_gw02=(/ (0.0, itmp=1,mfuelcats) /), & + fmc_gw03=(/ (0.0, itmp=1,mfuelcats) /), & + fmc_gw04=(/ (0.0, itmp=1,mfuelcats) /), & + fmc_gw05=(/ (0.0, itmp=1,mfuelcats) /) + + data moisture_class_name /'1-hour fuel','10-hour fuel','100-hour fuel',zm*'NOT USED'/ + data drying_lag /1., 10., 100. , zm*0./ ! time lag (h) approaching equilibrium moisture + data wetting_lag /14, 140., 1400., zm*0./ ! time lag (h) for approaching saturation in rain + data saturation_moisture /2.5, 2.5, 2.5 , zm*0./ ! saturation moisture contents (1) in rain + data saturation_rain /8.0, 8.0, 8.0 , zm*0./ ! stronger rain matters only in duration (mm/h) + data rain_threshold /0.05, 0.05, 0.05, zm*0 /! rain intensity this small is same as nothing + data drying_model /1, 1, 1, zm*1 / + data wetting_model /1, 1, 1, zm*1 / + data fmc_gc_initialization /2, 2, 2, zm*2 / ! initialization 0=input, 1=from fuelmc_g, 2=from equilibrium + real, dimension(7)::eq_p + data eq_p/ 1.035e-09, & !(3.893e-10, 1.681e-09) ! coefficients of the equilibrium fuel moisture polynomial + -2.62e-07, & !(-4.593e-07, -6.473e-08) ! fitted from the graph in Schroeder and Buck (1970) + 2.507e-05, & !(2.194e-06, 4.795e-05) + -0.001107, & !(-0.002353, 0.000139) + 0.02245, & !(-0.009188, 0.05409) + -0.05901, & !(-0.3721, 0.254) + 3.043/ !(2.17, 3.915) + + ! ========================================================================= + +! Following table copied from module_fr_cawfe_fuel by Ned Patton with minor changes. +! Based on: Clark, T. L., J. L. Coen and D. Latham: 2004, +! "Description of a coupled atmosphere-fire model", +! International Journal of Wildland Fire, 13, 49-63. +! +! edited by Jan Mandel jmandel@ucar.edu September 2007 +! +! - moved all fuel related constants and the initialization subroutine here +! - copied descriptions for fuel categories from fire_sfc.m4 in the original CAWFE code +! This file had to be copied under a new name because packages in wrf physics +! layer are not allowed to call each other. + +!D in col 2 means quantity derived from the others +! +! Scalar constants (data same for all fuel categories): +! HFGL SURFACE FIRE HEAT FLUX THRESHOLD TO IGNITE CANOPY (W/m^2) +! CMBCNST JOULES PER KG OF DRY FUEL +! FUELHEAT FUEL PARTICLE LOW HEAT CONTENT, BTU/LB +! FUELMC_G FUEL PARTICLE (SURFACE) MOISTURE CONTENT +!D BMST RATIO OF LATENT TO SENSIBLE HEAT FROM SFC BURN: +! % of total fuel mass that is water (not quite +! = % fuel moisture). BMST= (H20)/(H20+DRY) +! so BMST = FUELMC_G / (1 + FUELMC_G) where +! FUELMC_G = ground fuel moisture +! +! Data arrays indexed by fuel category: +! FGI INITIAL TOTAL MASS OF SURFACE FUEL (KG/M**2) +! FUELDEPTHM FUEL DEPTH, IN M (CONVERTED TO FT) +! SAVR FUEL PARTICLE SURFACE-AREA-TO-VOLUME RATIO, 1/FT +! GRASS: 3500., 10 hr fuel: 109., 100 hr fuel: 30. +! FUELMCE MOISTURE CONTENT OF EXTINCTION; 0.30 FOR MANY DEAD FUELS; 0.15 FOR GRASS +! FUELDENS OVENDRY PARTICLE DENSITY, LB/FT^3 +! ST FUEL PARTICLE TOTAL MINERAL CONTENT +! SE FUEL PARTICLE EFFECTIVE MINERAL CONTENT +! WEIGHT WEIGHTING PARAMETER THAT DETERMINES THE SLOPE OF THE MASS LOSS CURVE +! RANGES FROM ~5 (FAST BURNUP) TO 1000 ( ~40% DECR OVER 10 MIN). +! FCI_D INITIAL DRY MASS OF CANOPY FUEL +! FCT BURN OUT TIME FOR CANOPY FUEL, AFTER DRY (S) +! ichap 1 if chaparral, 0 if not +!D FCI INITIAL TOTAL MASS OF CANOPY FUEL +!D FCBR FUEL CANOPY BURN RATE (KG/M**2/S) + +! + +! scalar fuel coefficients + REAL, SAVE:: cmbcnst,hfgl,fuelmc_g,fuelmc_c, fire_wind_height +! computed values + REAL, SAVE:: fuelheat + +! defaults, may be changed in init_fuel_cats + DATA cmbcnst / 17.433e+06/ ! J/kg dry fuel + DATA hfgl / 17.e4 / ! W/m^2 + DATA fuelmc_g / 0.08 / ! set = 0 for dry ground fuel + DATA fuelmc_c / 1.00 / ! set = 0 for dry canopy + DATA fire_wind_height/6.096/ ! m, 6.096m Behave, 0 to use fwh in each category +! REAL, PARAMETER :: bmst = fuelmc_g/(1+fuelmc_g) +! REAL, PARAMETER :: fuelheat = cmbcnst * 4.30e-04 ! convert J/kg to BTU/lb +! real, parameter :: xlv = 2.5e6 ! to make it selfcontained +! real, parameter :: cp = 7.*287./2 ! to make it selfcontained + + +! fuel categorytables + INTEGER, PARAMETER :: nf=14 ! fuel cats in data stmts, for fillers only` + INTEGER, SAVE :: nfuelcats = 13 ! number of fuel categories, can be reset from namelist.fire + INTEGER, PARAMETER :: zf = mfuelcats-nf ! number of zero fillers in data stmt + INTEGER, SAVE :: no_fuel_cat = 14 ! special no fuel category outside of 1:nfuelcats + INTEGER, SAVE :: no_fuel_cat2 = 14 ! all categories between no_fuel_cat and no_fuel_cat2 are no fuel + INTEGER, SAVE :: ibeh=1 ! type of spread formula + CHARACTER (len=80), DIMENSION(mfuelcats ), save :: fuel_name + INTEGER, DIMENSION( mfuelcats ), save :: ichap + REAL , DIMENSION( mfuelcats ), save :: windrf,weight,fgi,fci,fci_d,fct,fcbr, & + fueldepthm,fueldens,fuelmce, & + fcwh,fcz0, ffw, & + savr,st,se,adjr0,adjrw,adjrs, & + fmc_gl_stdev,fmc_gl_ndwi_0,fmc_gl_ndwi_rate,fmc_gl_ndwi_stdev + REAL , DIMENSION( mfuelcats , max_moisture_classes), save :: fmc_gw +! ============================================================================= +! Standard 13 fire behavior fuel models (for surface fires), along with some +! estimated canopy properties (for crown fire). +! ============================================================================= + DATA fuel_name / & + 'FUEL MODEL 1: Short grass (1 ft)', & + 'FUEL MODEL 2: Timber (grass and understory)', & + 'FUEL MODEL 3: Tall grass (2.5 ft)', & + 'FUEL MODEL 4: Chaparral (6 ft)', & + 'FUEL MODEL 5: Brush (2 ft) ', & + 'FUEL MODEL 6: Dormant brush, hardwood slash', & + 'FUEL MODEL 7: Southern rough', & + 'FUEL MODEL 8: Closed timber litter', & + 'FUEL MODEL 9: Hardwood litter', & + 'FUEL MODEL 10: Timber (litter + understory)', & + 'FUEL MODEL 11: Light logging slash', & + 'FUEL MODEL 12: Medium logging slash', & + 'FUEL MODEL 13: Heavy logging slash', & + 'FUEL MODEL 14: no fuel', & + zf*' '/ + DATA windrf /0.36, 0.36, 0.44, 0.55, 0.42, 0.44, 0.44, & + 0.36, 0.36, 0.36, 0.36, 0.43, 0.46, 1e-7, zf*0 / ! added jmandel October 2010 + DATA fgi / 0.166, 0.897, 0.675, 2.468, 0.785, 1.345, 1.092, & + 1.121, 0.780, 2.694, 2.582, 7.749, 13.024, 1.e-7, zf*0. / + DATA fueldepthm /0.305, 0.305, 0.762, 1.829, 0.61, 0.762,0.762, & + 0.0610, 0.0610, 0.305, 0.305, 0.701, 0.914, 0.305,zf*0. / + DATA savr / 3500., 2784., 1500., 1739., 1683., 1564., 1562., & + 1889., 2484., 1764., 1182., 1145., 1159., 3500., zf*0. / + DATA fuelmce / 0.12, 0.15, 0.25, 0.20, 0.20, 0.25, 0.40, & + 0.30, 0.25, 0.25, 0.15, 0.20, 0.25, 0.12 , zf*0. / + DATA fueldens / nf * 32., zf*0. / ! 32 if solid, 19 if rotten. + DATA st / nf* 0.0555 , zf*0./ + DATA se / nf* 0.010 , zf*0./ +! ----- Notes on weight: (4) - best fit of Latham data; +! (5)-(7) could be 60-120; (8)-(10) could be 300-1600; +! (11)-(13) could be 300-1600 + DATA weight / 7., 7., 7., 180., 100., 100., 100., & + 900., 900., 900., 900., 900., 900., 7. , zf*0./ +! ----- 1.12083 is 5 tons/acre. 5-50 tons/acre orig., 100-300 after blowdown + DATA fci_d / 0., 0., 0., 1.123, 0., 0., 0., & + 1.121, 1.121, 1.121, 1.121, 1.121, 1.121, 0., zf*0./ + DATA fct / 60., 60., 60., 60., 60., 60., 60., & + 60., 120., 180., 180., 180., 180. , 60. , zf*0. / + DATA ichap / 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 , zf*0/ + DATA fcwh / 6.096, 6.096, 6.096, 6.096, 6.096, 6.096, 6.096, & + 6.096, 6.096, 6.096, 6.096, 6.096, 6.096, 6.096, zf*0. / ! consistent with BEHAVE +! roughness length 0.13*fueldepthm except cat 3 fz0=0.1 for consistency with landuse + ! fz0 = 0.0396,0.0396,0.0991,0.2378,0.0793,0.0991,0.0991, + DATA fcz0 / 0.0396,0.0396,0.1000,0.2378,0.0793,0.0991,0.0991, & + 0.0079,0.0079,0.0396,0.0396,0.0911,0.1188,0.0396, zf * 0. / + !DATA fcwh /0.6 , 0.6, 1.5, 36, 1.2, 1.5, 1.5, & + ! 0.12, 0.12, 0.6, 0.6, 1.38, 1.8, 1.8, zf*0 / ! fuel wind height, added jm 2/23/11 + !DATA fcz0 /0.3, 0.3, 0.75, 18., 0.6, 0.75, 0.75, & + ! 0.06, 0.06, 0.3, 0.3, 0.69, 0.9, 0.9, zf*0 / ! fuel roughness height, added jm 2/23/11 + DATA ffw /nf* 0.9, zf*0/ + DATA fmc_gl_ndwi_0 /nf*0.1, zf*0./ + DATA fmc_gl_ndwi_rate /nf*0.6, zf*0./ + DATA fmc_gl_ndwi_stdev /nf*0.2, zf*0./ + DATA fmc_gl_stdev /nf*0.2, zf*0./ + DATA adjr0 /mfuelcats*1./ + DATA adjrw /mfuelcats*1./ + DATA adjrs /mfuelcats*1./ + + ! ========================================================================= + + logical, save :: have_fuel_cats=.false. + +contains + +subroutine fuel_moisture( & + id, & ! for prints and maybe file names + nfmc, & + ids,ide, jds,jde, & ! atm grid dimensions + ims,ime, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifts,ifte,jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + nfuel_cat, & ! fuel data + fndwi, & ! satellite sensing on fire grid + fmc_gc, & ! moisture contents by class on atmospheric grid + fmc_g & ! weighted fuel moisture contents on fire grid + ) + +implicit none + +!**** arguments +integer, intent(in):: & + id,nfmc, & + ids,ide, jds,jde, & ! atm grid dimensions + ims,ime, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifts,ifte,jfts,jfte, & + ir,jr ! atm/fire grid ratio + + +real,intent(in),dimension(ifms:ifme,jfms:jfme):: nfuel_cat, & ! fuel data + fndwi ! satellite sensing interpolated to fire grid +real,intent(inout),dimension(ims:ime,nfmc,jms:jme):: fmc_gc +real,intent(out),dimension(ifms:ifme,jfms:jfme):: fmc_g ! fuel data + +!**** local +real, dimension(its-1:ite+1,jts-1:jte+1):: fmc_k ! copy of fmc_gc(:,k,:) +real, dimension(ifts:ifte,jfts:jfte):: fmc_f, & ! interpolation of fmc_gc(:,k,:) to the fire grid + nwdi_f ! inerpolation of nwdi to the fire grid +integer::i,j,k,n +integer::ibs,ibe,jbs,jbe +real::f1,w1,w2,f2,fa,fc + +character(len=128)::msg + +call check_mesh_2dim(ifts,ifte,jfts,jfte,ifds,ifde,jfds,jfde) ! check if fire tile fits into domain +call check_mesh_2dim(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme) ! check if fire tile fits into memory + +do j=jfts,jfte + do i=ifts,ifte + fmc_g(i,j)=0. ! initialize sum over classes + enddo +enddo + +! one beyond the tile but not beyond the domain boundary +ibs=max(ids,its-1) +ibe=min(ide,ite+1) +jbs=max(jds,jts-1) +jbe=min(jde,jte+1) + +call check_mesh_2dim(ibs,ibe,jbs,jbe,ims,ime,jms,jme) ! check if tile with halo fits into memory + +do k=1,moisture_classes + + ! copy halo beyond the tile but not beyond the domain boundary + do j=jbs,jbe + do i=ibs,ibe + fmc_k(i,j)=fmc_gc(i,k,j) ! copy slice to 2d array + enddo + enddo + + call print_2d_stats(ibs,ibe,jbs,jbe,its-1,ite+1,jts-1,jte+1,fmc_k,'fuel_moisture: fmc_k') + + ! interpolate moisture contents in the class k to the fire mesh + call interpolate_z2fire(id,0, & ! for debug output, <= 0 no output + ids,ide,jds,jde, & ! atm grid dimensions + its-1,ite+1,jts-1,jte+1, & ! memory dimensions + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifts, ifte, jfts, jfte, & + ifts,ifte, jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + fmc_k, & ! atm grid arrays in + fmc_f) ! fire grid arrays out + + call print_2d_stats(ifts,ifte,jfts,jfte,ifts,ifte,jfts,jfte,fmc_f,'fuel_moisture: fmc_f') + + if(k .eq. kfmc_ndwi)then ! if live moisture, assimilate ndwi + call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fndwi,'fuel_moisture: fndwi') + write(msg,'(a,i4)')'Assimilating NDWI in fuel moisture class ',k + call message(msg) + endif + + ! add moisture contents for class k to the fuel moisture + do j=jfts,jfte + do i=ifts,ifte + n = nfuel_cat(i,j) + if(n > 0)then + if(k .ne. kfmc_ndwi)then + fmc_g(i,j)=fmc_g(i,j)+fmc_gw(n,k)*fmc_f(i,j) ! add to sum over classes + else ! if live moisture, assimilate ndwi + f1=fmc_f(i,j) + w1 = fmc_gl_stdev(n) + w1 = 1./(w1*w1) ! weight of forecast + w2 = fmc_gl_ndwi_stdev(n) + w2 = 1./(w2*w2) ! weight of update + f2 = fmc_gl_ndwi_0(n) + fmc_gl_ndwi_rate(n) * fndwi(i,j) ! from regression + fa = (w1*f1 + w2*f2) / (w1 + w2) ! updated value + fc = fmc_gw(n,k)*fa ! times proportion of live fuel + fmc_g(i,j)=fmc_g(i,j)+fc ! add to sum over classes + ! write(*,*)'NDWI:',i,j,f1,f2,w1,w2,f1,fa,fmc_gw(n,k),fc,fmc_g(i,j) + endif + endif + enddo + enddo + +enddo + +call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fmc_g,'fuel_moisture: fmc_g') + + +end subroutine fuel_moisture + +subroutine advance_moisture( & + initialize, & ! initialize timestepping. true on the first call at time 0, then false + ims,ime, jms,jme, & ! memory dimensions + its,ite, jts,jte, & ! tile dimensions + nfmc, & ! dimension of moisture fields + moisture_dt, & ! timestep = time step time elapsed from the last call + fmep_decay_tlag, & ! moisture extended model assimilated diffs. decay time lag + rainc, rainnc, & ! accumulated rain + t2, q2, psfc, & ! temperature (K), vapor contents (kg/kg), pressure (Pa) at the surface + rain_old, & ! previous value of accumulated rain + t2_old, q2_old, psfc_old, & ! previous values of the atmospheric state at surface + rh_fire, & ! relative humidity at surface, for diagnostic only + fmc_gc, & ! fuel moisture by class, updated + fmep, & ! fuel moisture extended model parameters + fmc_equi, & ! fuel moisture equilibrium by class, for diagnostics only + fmc_lag & ! fuel moisture tendency by classe, for diagnostics only + ) + +implicit none + +!*** arguments +logical, intent(in):: initialize +integer, intent(in):: & + ims,ime, jms,jme, & ! memory dimensions + its,ite, jts,jte, & ! tile dimensions + nfmc ! number of moisture fields +real, intent(in):: moisture_dt, fmep_decay_tlag +real, intent(in), dimension(ims:ime,jms:jme):: t2, q2, psfc, rainc, rainnc +real, intent(inout), dimension(ims:ime,jms:jme):: t2_old, q2_old, psfc_old, rain_old +real, intent(inout), dimension(ims:ime,nfmc,jms:jme):: fmc_gc +real, intent(inout), dimension(ims:ime,2,jms:jme):: fmep +real, intent(out), dimension(ims:ime,nfmc,jms:jme):: fmc_equi, fmc_lag +real, intent(out), dimension(ims:ime,jms:jme)::rh_fire + +!*** global +! fuel properties moisture set by init_fuel_cats + +!*** local +integer:: i,j,k +real::rain_int, T, P, Q, QRS, ES, RH, tend, EMC_d, EMC_w, EMC, R, rain_diff, fmc, rlag, equi, & + d, w, rhmax, rhmin, change, rainmax,rainmin, fmc_old, H, deltaS, deltaE +real, parameter::tol=1e-2 ! relative change larger than that will switch to exponential ode solver +character(len=256)::msg +logical::bad_wrf +integer::msglevel=2 +logical, parameter::check_rh=.false. +integer::check_data=2 ! 0=nothing, 1=replace quietly, 2=warning (also printed if msglevel>2), 3=crash +real::epsilon,Pws,Pw,t2_min,q2_min,psfc_min +real::t2_floor=200. ! minimum allowed temperature (K) +real::q2_floor=1e-8 ! miniumu allowed moisture contents (kg/kg) +real::psfc_floor=1000. ! mimimum allowed surface pressiure (Pa) + + +!*** executable + +! check arguments + +if(msglevel>1)then +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + write(msg,'(a,f10.2,a,i4,a,i4)')'advance_moisture dt=',moisture_dt,'s using ',moisture_classes,' classes from possible ',nfmc +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) + call message(msg,level=2) +endif + +if(moisture_classes > nfmc .or. moisture_classes > max_moisture_classes)then +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + write(msg,*)'advance_moisture: moisture_classes=',moisture_classes, & + ' > nfmc=',nfmc,' or > max_moisture_classes=',max_moisture_classes +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) + call crash(msg) +endif + +call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,t2,'T2') +call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,q2,'Q2') +call print_2d_stats(its,ite,jts,jte,ims,ime,jms,jme,psfc,'PSFC') + +if(initialize) then + call message('advance_moisture: initializing, copying surface variables to old') + call copy2old +else + call print_3d_stats_by_slice(its,ite,1,moisture_classes,jts,jte,ims,ime,1,nfmc,jms,jme,fmc_gc,'before advance fmc_gc') +endif + +if(check_data.ge.2 .or. msglevel.ge.2)then + t2_min = huge(t2_min) + q2_min = huge(q2_min) + psfc_min = huge(psfc_min) + do j=jts,jte + do i=its,ite + t2_min=min(t2(i,j),t2_min) + q2_min=min(q2(i,j),q2_min) + psfc_min=min(psfc(i,j),psfc_min) + enddo + enddo + bad_wrf = ( t2_min 0.)then + rain_int = 3600. * rain_diff / moisture_dt + else + rain_int = 0. + endif + rainmax = max(rainmax,rain_int) + rainmin = min(rainmin,rain_int) + R = rain_int - rain_threshold(k) + + ! average the inputs for second order accuracy + T = 0.5 * (t2_old(i,j) + t2(i,j)) + P = 0.5 * (psfc_old(i,j) + psfc(i,j)) + Q = 0.5 * (q2_old(i,j) + q2(i,j)) + + ! replace nonphysical values by floor + if(check_data .ge. 1)then + T = max(T,t2_floor) + P = max(P,psfc_floor) + Q = max(Q,q2_floor) + endif + + ! compute the relative humidity + ! ES=610.78*exp(17.269*(T-273.161)/(T-35.861)) + ! QRS=0.622*ES/(P-0.378*ES) + ! RH = Q/QRS + ! function rh_from_q from Adam Kochanski following Murphy and Koop, Q.J.R. Meteorol. Soc (2005) 131 1539-1565 eq. (10) + epsilon = 0.622 ! Molecular weight of water (18.02 g/mol) to molecular weight of dry air (28.97 g/mol) + ! vapor pressure [Pa] + Pw=q*P/(epsilon+(1-epsilon)*q); + ! saturation vapor pressure [Pa] + Pws= exp( 54.842763 - 6763.22/T - 4.210 * log(T) + 0.000367*T + & + tanh(0.0415*(T - 218.8)) * (53.878 - 1331.22/T - 9.44523 * log(T) + 0.014025*T)) + !realtive humidity [1] + RH = Pw/Pws + rh_fire(i,j)=RH + rhmax=max(RH,rhmax) + rhmin=min(RH,rhmin) + + deltaE = fmep(i,1,j) + deltaS = fmep(i,2,j) + + if(.not.check_rh)then + RH = min(RH,1.0) + else + if(RH < 0.0 .or. RH > 1.0 .or. RH .ne. RH )then +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + write(msg,'(a,2i6,5(a,f10.2))')'At i,j ',i,j,' RH=',RH, & + ' from T=',T,' P=',P,' Q=',Q + call message(msg) + call crash('Relative humidity must be between 0 and 1, saturated water contents must be >0') +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) + endif + endif + !print *,'ADV_MOIST i=',i,' j=',j,' T=',T,' P=',P,' Q=',Q,' ES=',ES,' QRS=',QRS,' RH=',RH + + if (R > 0.) then + select case(wetting_model(k)) + case(1) ! saturation_moisture=2.5 wetting_lag=14h saturation_rain=8 mm/h calibrated to VanWagner&Pickett 1985 per 24 hours + EMC_w=saturation_moisture(k) + deltaS + EMC_d=saturation_moisture(k) + deltaS + rlag=rec_wetting_lag_sec(k) * (1. - exp(-R/saturation_rain(k))) + end select + else ! not raining + select case(drying_model(k)) + case(1) ! Van Wagner and Pickett (1972, 1985) per Viney (1991) eq (7) (8) + H = RH * 100. + d=0.942*H**0.679 + 0.4994e-4*exp(0.1*H) + 0.18*(21.1+273.15-T)*(1-exp(-0.115*H)) ! equilibrium moisture for drying + w=0.618*H**0.753 + 0.4540e-4*exp(0.1*H) + 0.18*(21.1+273.15-T)*(1-exp(-0.115*H)) ! equilibrium moisture for adsorbtion + if(d.ne.d.or.w.ne.w)call crash('equilibrium moisture calculation failed, result is NaN') + d = d*0.01 + w = w*0.01 + EMC_d = max(max(d,w)+deltaE,0.0) + EMC_w = max(min(d,w)+deltaE,0.0) + rlag=rec_drying_lag_sec(k) + end select + endif + !*** MODELS THAT ARE NOT OF THE EXPONENTIAL TIME LAG KIND + ! ARE RESPONSIBLE FOR THEIR OWN LOGIC, THESE MODELS + ! SHOULD COMPUTE fmc_gc(i,k,j) DIRECTLY AND SET TLAG < 0 + ! + if(rlag > 0.0)then + + if(.not.initialize .or. fmc_gc_initialization(k).eq.0)then ! take old from before, no initialization + fmc_old = fmc_gc(i,k,j) + elseif(fmc_gc_initialization(k).eq.1)then ! from scalar fuelmc_g + fmc_old = fuelmc_g + elseif(fmc_gc_initialization(k).eq.2)then ! from computed equilibrium + fmc_old=0.5*(EMC_d+EMC_w) + else + call crash('bad value of fmc_gc_initialization(k), must be between 0 and 2') + endif + equi = max(min(fmc_old, EMC_d),EMC_w) ! take lower or upper equilibrium value + + change = moisture_dt * rlag + + if(change < tol)then + if(fire_print_msg.ge.3)call message('midpoint method') + fmc = fmc_old + (equi - fmc_old)*change*(1.0 - 0.5*change) ! 2nd order Taylor + else + if(fire_print_msg.ge.3)call message('exponential method') + fmc = fmc_old + (equi - fmc_old)*(1 - exp(-change)) + endif + fmc_gc(i,k,j) = fmc + + ! diagnostics out + fmc_equi(i,k,j)=equi + fmc_lag(i,k,j)=1.0/(3600.0*rlag) + + ! diagnostic prints + if(fire_print_msg.ge.3)then +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + write(msg,*)'i=',i,' j=',j,'EMC_w=',EMC_w,' EMC_d=',EMC_d + call message(msg) + write(msg,*)'fmc_old=',fmc,' equi=',equi,' change=',change,' fmc=',fmc + call message(msg) +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) + endif + + endif + enddo + enddo +enddo + + +! assimilated differences decay +do j=jts,jte + do k=1,2 + do i=its,ite + change = moisture_dt / (fmep_decay_tlag * 3600.) + if(change < tol) then + fmep(i,k,j) = fmep(i,k,j)*(1.0 - change * (1.0 - 0.5 * change)) + else + fmep(i,k,j) = fmep(i,k,j)*exp(-change) + endif + enddo + enddo +enddo + + +if(fire_print_msg.ge.2)then +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + write(msg,2)'Rain intensity min',rainmin, ' max',rainmax,' mm/h' + call message(msg) + if(rainmin <0.)then + call message('WARNING rain accumulation must increase') + endif + write(msg,2)'Relative humidity min',100*rhmin,' max',100*rhmax,'%' + call message(msg) + if(.not.(rhmax<=1.0 .and. rhmin>=0))then + call message('WARNING Relative humidity must be between 0 and 100%') + endif +2 format(2(a,f10.2),a) +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) +endif + +call print_3d_stats_by_slice(its,ite,1,moisture_classes,jts,jte,ims,ime,1,nfmc,jms,jme,fmc_equi,'equilibrium fmc_equi') +call print_3d_stats_by_slice(its,ite,1,moisture_classes,jts,jte,ims,ime,1,nfmc,jms,jme,fmc_lag,'time lag') +call print_3d_stats_by_slice(its,ite,1,moisture_classes,jts,jte,ims,ime,1,nfmc,jms,jme,fmc_gc,'after advance fmc_gc') + +call copy2old + +return + +contains + +subroutine copy2old + +do j=jts,jte + do i=its,ite + rain_old(i,j) = rainc(i,j) + rainnc(i,j) + t2_old(i,j) = t2(i,j) + q2_old(i,j) = q2(i,j) + psfc_old(i,j) = psfc(i,j) + enddo +enddo + +end subroutine copy2old + +subroutine get_equi_moist +end subroutine get_equi_moist + +end subroutine advance_moisture + + +subroutine init_fuel_cats(init_fuel_moisture) +implicit none +!*** purpose: initialize fuel tables and variables by constants +!*** arguments: +logical, intent(in)::init_fuel_moisture +logical, external:: wrf_dm_on_monitor +!$ integer, external:: OMP_GET_THREAD_NUM +!*** local +integer:: i,j,k,ii,iounit,ierr,kk +character(len=128):: msg +REAL , DIMENSION( mfuelcats ) :: fwh, fz0 +!*** executable + +! read +namelist /fuel_scalars/ cmbcnst,hfgl,fuelmc_g,fuelmc_c,nfuelcats,no_fuel_cat,no_fuel_cat2,fire_wind_height,ibeh +namelist /fuel_categories/ fuel_name,windrf,fgi,fueldepthm,savr, & + fuelmce,fueldens,st,se,weight,fci_d,fct,ichap,fwh,fz0,ffw, & + fmc_gl_ndwi_0,fmc_gl_ndwi_rate,fmc_gl_ndwi_stdev, fmc_gl_stdev, & + adjr0,adjrw,adjrs,fmc_gw01,fmc_gw02,fmc_gw03,fmc_gw04,fmc_gw05 + +namelist /moisture/ moisture_classes,drying_lag,wetting_lag,saturation_moisture,saturation_rain,rain_threshold, & + drying_model,wetting_model, moisture_class_name,fmc_gc_initialization + +!$ if (OMP_GET_THREAD_NUM() .ne. 0)then +!$ call crash('init_fuel_cats: must be called from master thread') +!$ endif + +IF ( wrf_dm_on_monitor() ) THEN + ! we are the master task + + ! copy in defaults + fwh=fcwh + fz0=fcz0 + + ! read the file + iounit=open_text_file('namelist.fire','read') + read(iounit,fuel_scalars,iostat=ierr) + if(ierr.ne.0)call crash('init_fuel_cats: error reading namelist fuel_scalars in file namelist.fire') + read(iounit,fuel_categories,iostat=ierr) + if(ierr.ne.0)call crash('init_fuel_cats: error reading namelist fuel_categories in file namelist.fire') + if(init_fuel_moisture)then + read(iounit,moisture,iostat=ierr) + if(ierr.ne.0)call crash('init_fuel_cats: error reading namelist moisture in file namelist.fire') + endif + fmc_gw(1:mfuelcats,1)=fmc_gw01 + fmc_gw(1:mfuelcats,2)=fmc_gw02 + fmc_gw(1:mfuelcats,3)=fmc_gw03 + fmc_gw(1:mfuelcats,4)=fmc_gw04 + fmc_gw(1:mfuelcats,5)=fmc_gw05 + CLOSE(iounit) + + ! copy out to permanent names + fcwh=fwh + fcz0=fz0 + + if (nfuelcats>mfuelcats) then + write(msg,*)'nfuelcats=',nfuelcats,' too large, increase mfuelcats' + call crash(msg) + endif + if (no_fuel_cat >= 1 .and. no_fuel_cat <= nfuelcats)then + write(msg,*)'no_fuel_cat=',no_fuel_cat,' may not be between 1 and nfuelcats=',nfuelcats + call crash(msg) + endif + if (no_fuel_cat > no_fuel_cat2)then + write(msg,*)'no_fuel_cat=',no_fuel_cat,' must not be larger than no_fuel_cat2=',no_fuel_cat2 + call crash(msg) + endif +ENDIF + +! broadcast fuel tables +call wrf_dm_bcast_real(cmbcnst,1) +call wrf_dm_bcast_real(hfgl,1) +call wrf_dm_bcast_real(fuelmc_g,1) +call wrf_dm_bcast_real(fuelmc_c,1) +call wrf_dm_bcast_real(fire_wind_height,1) +call wrf_dm_bcast_integer(nfuelcats,1) +call wrf_dm_bcast_integer(no_fuel_cat,1) +call wrf_dm_bcast_integer(no_fuel_cat2,1) +call wrf_dm_bcast_integer(ibeh,1) +call wrf_dm_bcast_real(windrf, nfuelcats) +call wrf_dm_bcast_real(fgi, nfuelcats) +call wrf_dm_bcast_real(fueldepthm,nfuelcats) +call wrf_dm_bcast_real(savr, nfuelcats) +call wrf_dm_bcast_real(fuelmce, nfuelcats) +call wrf_dm_bcast_real(fueldens, nfuelcats) +call wrf_dm_bcast_real(st, nfuelcats) +call wrf_dm_bcast_real(se, nfuelcats) +call wrf_dm_bcast_real(weight, nfuelcats) +call wrf_dm_bcast_real(fci_d, nfuelcats) +call wrf_dm_bcast_real(fct, nfuelcats) +call wrf_dm_bcast_integer(ichap, nfuelcats) +call wrf_dm_bcast_real(fcwh, nfuelcats) +call wrf_dm_bcast_real(fcz0, nfuelcats) +call wrf_dm_bcast_real(ffw, nfuelcats) +call wrf_dm_bcast_real(adjr0, nfuelcats) +call wrf_dm_bcast_real(adjrw, nfuelcats) +call wrf_dm_bcast_real(adjrs, nfuelcats) +call wrf_dm_bcast_real(fmc_gl_ndwi_0, nfuelcats) +call wrf_dm_bcast_real(fmc_gl_ndwi_rate, nfuelcats) +call wrf_dm_bcast_real(fmc_gl_ndwi_stdev,nfuelcats) +call wrf_dm_bcast_real(fmc_gl_stdev, nfuelcats) +! broadcast moisture tables +call wrf_dm_bcast_integer(moisture_classes,1) +call wrf_dm_bcast_real(drying_lag, max_moisture_classes) +call wrf_dm_bcast_real(wetting_lag, max_moisture_classes) +call wrf_dm_bcast_real(saturation_moisture, max_moisture_classes) +call wrf_dm_bcast_real(saturation_rain, max_moisture_classes) +call wrf_dm_bcast_real(rain_threshold, max_moisture_classes) +call wrf_dm_bcast_integer(drying_model, max_moisture_classes) +call wrf_dm_bcast_integer(wetting_model, max_moisture_classes) +call wrf_dm_bcast_integer(fmc_gc_initialization, max_moisture_classes) +call wrf_dm_bcast_real(fmc_gw, mfuelcats*max_moisture_classes) + +! moisture model derived scalars +do i=1,moisture_classes + rec_drying_lag_sec(i) = 1.0/(3600.0*drying_lag(i)) + rec_wetting_lag_sec(i) = 1.0/(3600.0*wetting_lag(i)) +enddo + +!-------------------------------- fuel model +! compute derived scalars + +fuelheat = cmbcnst * 4.30e-04 ! convert J/kg to BTU/lb + +! compute derived fuel category coefficients + +DO i = 1,nfuelcats + fci(i) = (1.+fuelmc_c)*fci_d(i) + if(fct(i) .ne. 0.)then + fcbr(i) = fci_d(i)/fct(i) ! to avoid division by zero + else + fcbr(i) = 0 + endif +END DO + +! prints + +call message('**********************************************************') +call message('FUEL COEFFICIENTS') +write(msg,8)'cmbcnst ',cmbcnst +call message(msg) +write(msg,8)'hfgl ',hfgl +call message(msg) +write(msg,8)'fuelmc_g ',fuelmc_g +call message(msg) +write(msg,8)'fuelmc_c ',fuelmc_c +call message(msg) +write(msg,8)'fuelheat ',fuelheat +call message(msg) +write(msg,7)'nfuelcats ',nfuelcats +call message(msg) +write(msg,7)'no_fuel_cat',no_fuel_cat +call message(msg) +write(msg,7)'no_fuel_cat2',no_fuel_cat2 +call message(msg) +if(init_fuel_moisture)then + write(msg,7)'moisture_classes',moisture_classes + call message(msg) +endif + +j=1 +7 format(a,5(1x,i8,4x)) +8 format(a,5(1x,g12.5e2)) +9 format(a,5(1x,a)) +10 format(a,i2.2,2x,5(1x,g12.5e2)) +do i=1,nfuelcats,j + k=min(i+j-1,nfuelcats) + call message(' ') + write(msg,7)'CATEGORY ',(ii,ii=i,k) + call message(msg) + write(msg,9)'fuel name ',(trim(fuel_name(ii)),ii=i,k) + call message(msg) + write(msg,8)'fwh ',(fcwh(ii),ii=i,k) + call message(msg) + write(msg,8)'fz0 ',(fcz0(ii),ii=i,k) + call message(msg) + write(msg,8)'windrf ',(windrf(ii),ii=i,k) + call message(msg) + write(msg,8)'fgi ',(fgi(ii),ii=i,k) + call message(msg) + write(msg,8)'fueldepthm',(fueldepthm(ii),ii=i,k) + call message(msg) + write(msg,8)'savr ',(savr(ii),ii=i,k) + call message(msg) + write(msg,8)'fuelmce ',(fuelmce(ii),ii=i,k) + call message(msg) + write(msg,8)'fueldens ',(fueldens(ii),ii=i,k) + call message(msg) + write(msg,8)'st ',(st(ii),ii=i,k) + call message(msg) + write(msg,8)'se ',(se(ii),ii=i,k) + call message(msg) + write(msg,8)'weight ',(weight(ii),ii=i,k) + call message(msg) + write(msg,8)'fci_d ',(fci_d(ii),ii=i,k) + call message(msg) + write(msg,8)'fct ',(fct(ii),ii=i,k) + call message(msg) + write(msg,7)'ichap ',(ichap(ii),ii=i,k) + call message(msg) + write(msg,8)'fci ',(fci(ii),ii=i,k) + call message(msg) + write(msg,8)'fcbr ',(fcbr(ii),ii=i,k) + call message(msg) + write(msg,8)'ffw ',(ffw(ii),ii=i,k) + call message(msg) + write(msg,8)'adjr0 ',(adjr0(ii),ii=i,k) + call message(msg) + write(msg,8)'adjrw ',(adjrw(ii),ii=i,k) + call message(msg) + write(msg,8)'adjrs ',(adjrs(ii),ii=i,k) + call message(msg) + if(init_fuel_moisture)then + do kk=1,moisture_classes + write(msg,10)'fmc_gw',kk,(fmc_gw(ii,kk),ii=i,k) + call message(msg) + enddo + endif + if(kfmc_ndwi>0)then + write(msg,8)'fmc_gl_stdev ',(fmc_gl_stdev(ii),ii=i,k) + call message(msg) + write(msg,8)'fmc_gl_ndwi_0 ',(fmc_gl_ndwi_0(ii),ii=i,k) + call message(msg) + write(msg,8)'fmc_gl_ndwi_rate ',(fmc_gl_ndwi_rate(ii),ii=i,k) + call message(msg) + write(msg,8)'fmc_gl_ndwi_stdev',(fmc_gl_ndwi_stdev(ii),ii=i,k) + call message(msg) + endif +enddo +call message(' ') +call message('**********************************************************') + +if(init_fuel_moisture)then + j=1 + do i=1,moisture_classes,j + k=min(i+j-1,nfuelcats) + call message(' ') + write(msg,7)'FUEL MOISTURE CLASS',(ii,ii=i,k) + call message(msg) + write(msg,9)'moisture class name ',(trim(moisture_class_name(ii)),ii=i,k) + call message(msg) + write(msg,7)'drying_model ',(drying_model(ii),ii=i,k) + call message(msg) + write(msg,8)'drying_lag (h) ',(drying_lag(ii),ii=i,k) + call message(msg) + write(msg,7)'wetting_model ',(wetting_model(ii),ii=i,k) + call message(msg) + write(msg,7)'fmc_gc_initialization ',(fmc_gc_initialization(ii),ii=i,k) + call message(msg) + write(msg,8)'wetting_lag (h) ',(wetting_lag(ii),ii=i,k) + call message(msg) + write(msg,8)'saturation_moisture (1)',(saturation_moisture(ii),ii=i,k) + call message(msg) + write(msg,8)'saturation_rain (mm/h) ',(saturation_rain(ii),ii=i,k) + call message(msg) + write(msg,8)'rain_threshold (mm/h) ',(rain_threshold(ii),ii=i,k) + call message(msg) + enddo + call message(' ') + call message('**********************************************************') + call message(' ') +endif +have_fuel_cats=.true. + +! and print to file +IF ( wrf_dm_on_monitor() ) THEN + call write_fuels_m(61,30.,1.) +ENDIF + + +end subroutine init_fuel_cats + + +subroutine write_fuels_m(nsteps,maxwind,maxslope) +implicit none +integer, intent(in):: nsteps ! number of steps for speed computation +real, intent(in):: maxwind,maxslope ! computer from zero to these + +integer:: iounit,k,j,i,isave +type(fire_params)::fp +real, dimension(1:3,1:nsteps), target::vx,vy,zsf,dzdxf,dzdyf,bbb,phisc,phiwc,r_0,fgip,ischap,fmc_g,wind,nfuel_cat +real, dimension(1:3,1:nsteps)::fuel_time,ros,fwh,fz0 +real::ros_back,ros_wind,ros_slope,propx,propy,r +integer::ierrx +character(len=128)::msg + +if(.not.have_fuel_cats)call crash('write_fuels_m: fuel categories not yet set') + +fp%vx=>vx +fp%vy=>vy +fp%dzdxf=>dzdxf +fp%dzdyf=>dzdyf +fp%bbb=>bbb +fp%phisc=>phisc +fp%phiwc=>phiwc +fp%r_0=>r_0 +fp%fgip=>fgip +fp%ischap=>ischap +fp%fmc_g=>fmc_g +fp%nfuel_cat=>nfuel_cat + +iounit = open_text_file('fuels.m','write') + +10 format('fuel(',i3,').',a,'=',"'",a,"'",';% ',a) +do k=1,nfuelcats + write(iounit,10)k,'fuel_name',trim(fuel_name(k)),'FUEL MODEL NAME' + call write_var(k,'windrf',windrf(k),'WIND REDUCTION FACTOR FROM FCWH TO MIDFLAME HEIGHT' ) + call write_var(k,'fwh',fcwh(k),'WIND HEIGHT TO INTERPOLATE VERTICALLY TO (M)' ) + call write_var(k,'fz0',fcz0(k),'ROUGHNESS LENGTH FOR VERTICAL WIND LOG INTERPOLATION (M)' ) + call write_var(k,'fgi',fgi(k),'INITIAL TOTAL MASS OF SURFACE FUEL (KG/M**2)' ) + call write_var(k,'fueldepthm',fueldepthm(k),'FUEL DEPTH (M)') + call write_var(k,'savr',savr(k),'FUEL PARTICLE SURFACE-AREA-TO-VOLUME RATIO, 1/FT') + call write_var(k,'fuelmce',fuelmce(k),'MOISTURE CONTENT OF EXTINCTION') + call write_var(k,'fueldens',fueldens(k),'OVENDRY PARTICLE DENSITY, LB/FT^3') + call write_var(k,'st',st(k),'FUEL PARTICLE TOTAL MINERAL CONTENT') + call write_var(k,'se',se(k),'FUEL PARTICLE EFFECTIVE MINERAL CONTENT') + call write_var(k,'weight',weight(k),'WEIGHTING PARAMETER THAT DETERMINES THE SLOPE OF THE MASS LOSS CURVE') + call write_var(k,'fci_d',fci_d(k),'INITIAL DRY MASS OF CANOPY FUEL') + call write_var(k,'fct',fct(k),'BURN OUT TIME FOR CANOPY FUEL, AFTER DRY (S)') + call write_var(k,'ichap',float(ichap(k)),'1 if chaparral, 0 if not') + call write_var(k,'fci',fci(k),'INITIAL TOTAL MASS OF CANOPY FUEL') + call write_var(k,'fcbr',fcbr(k),'FUEL CANOPY BURN RATE (KG/M**2/S)') + call write_var(k,'adjr0',adjr0(k),'MULTIPLICATIVE ADJUSTMENT OF BACKING SPREAD RATE') + call write_var(k,'adjrw',adjrw(k),'MULTIPLICATIVE ADJUSTMENT OF WIND CONTRIBUTION TO SPREAD RATE') + call write_var(k,'adjrs',adjrs(k),'MULTIPLICATIVE ADJUSTMENT OF SLOPE CONTRIBUTION TO SPREAD RATE') + call write_var(k,'ffw',ffw(k),'FUEL FRACTION CONSUMED IN THE FLAMING ZONE') + call write_var(k,'hfgl',hfgl,'SURFACE FIRE HEAT FLUX THRESHOLD TO IGNITE CANOPY (W/m^2)') + call write_var(k,'cmbcnst',cmbcnst,'JOULES PER KG OF DRY FUEL') + call write_var(k,'fuelheat',fuelheat,'FUEL PARTICLE LOW HEAT CONTENT, BTU/LB') + call write_var(k,'fuelmc_g',fuelmc_g,'FUEL PARTICLE (SURFACE) MOISTURE CONTENT') + call write_var(k,'fuelmc_c',fuelmc_c,'FUEL PARTICLE (CANOPY) MOISTURE CONTENT') + ! set up fuel arrays + !subroutine set_fire_params( & + ! ifds,ifde,jfds,jfde, & + ! ifms,ifme,jfms,jfme, & + ! ifts,ifte,jfts,jfte, & + ! fdx,fdy,nfuel_cat0, & + ! nfuel_cat,fuel_time, & + ! fp ) + nfuel_cat = k + do j=1,nsteps ! set moisture - must be before set_fire_params + fmc_g(1,j)=fuelmc_g + fmc_g(2,j)=fuelmc_g + fmc_g(3,j)=(fuelmce(k)*(j-1))/(nsteps-2) + enddo + isave=fire_fmc_read + fire_fmc_read=0 + call set_fire_params( & + 1,3,1,nsteps, & + 1,3,1,nsteps, & + 1,3,1,nsteps, & + 0.,0.,k, & + nfuel_cat,fuel_time, & + fp ) + fire_fmc_read=isave + ! set up windspeed slope moisture table + propx=1. + propy=0. + do j=1,nsteps + r=float(j-1)/float(nsteps-1) + ! line 1 varies windspeed (in x direction), zero slope + wind(1,j)=maxwind*r + vx(1,j)=wind(1,j)*windrf(k) + vy(1,j)=0. + dzdxf(1,j)=0. + dzdyf(1,j)=0. + ! line 2 varies slope (in x direction), zero slope + vx(2,j)=0. + vy(2,j)=0. + dzdxf(2,j)=maxslope*r + dzdyf(2,j)=0. + ! line 3 varies moisture, zero slope and wind + vx(3,j)=0. + vy(3,j)=0. + dzdxf(3,j)=0. + dzdyf(3,j)=0. + enddo + do j=1,nsteps + do i=1,3 + call fire_ros(ros_back,ros_wind,ros_slope, & + propx,propy,i,j,fp,ierrx,msg) + ros(i,j)=ros_back+ros_wind+ros_slope + enddo + write(iounit,13)k,'wind',j,wind(1,j),'wind speed at 6.1m' + write(iounit,13)k,'ros_wind',j,ros(1,j),'rate of spread for the wind speed at 6.1m' + write(iounit,13)k,'slope',j,dzdxf(2,j),'slope' + write(iounit,13)k,'ros_slope',j,ros(2,j),'rate of spread for the slope' + write(iounit,13)k,'fmc_g',j,fmc_g(3,j),'fuel moisture content' + write(iounit,13)k,'ros_fmc_g',j,ros(3,j),'rate of spread for the fuel moisture content' + enddo +enddo +13 format('fuel(',i3,').',a,'(',i3,')=',g12.5e2,';% ',a) + +close(iounit) +! stop + +contains + +subroutine write_var(k,name,value,descr) +! write entry for one variable +integer, intent(in)::k +character(len=*), intent(in)::name,descr +real, intent(in)::value +write(iounit,11)k,name,value +write(iounit,12)k,name,descr +11 format('fuel(',i3,').',a,'=',g12.5e2, ';') +12 format('fuel(',i3,').',a,"_descr='",a,"';") +end subroutine write_var + +end subroutine write_fuels_m + +! +!******************* +! + +subroutine set_fire_params( & + ifds,ifde,jfds,jfde, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + fdx,fdy,nfuel_cat0, & + nfuel_cat,fuel_time, & + fp ) + +implicit none + +!*** purpose: Set all fire model params arrays, constant values. + +!*** arguments +integer, intent(in)::ifds,ifde,jfds,jfde ! fire domain bounds +integer, intent(in)::ifts,ifte,jfts,jfte ! fire tile bounds +integer, intent(in)::ifms,ifme,jfms,jfme ! memory array bounds +real, intent(in):: fdx,fdy ! fire mesh spacing +integer,intent(in)::nfuel_cat0 ! default fuel category, if nfuel_cat=0 +real, intent(inout),dimension(ifms:ifme, jfms:jfme)::nfuel_cat ! fuel data +real, intent(out), dimension(ifms:ifme, jfms:jfme)::fuel_time ! fire params arrays +type(fire_params),intent(inout)::fp + +!*** local + +real:: fuelload, fueldepth, rtemp1, rtemp2, & + qig, epsilon, rhob, wn, betaop, e, c, & + xifr, etas, etam, a, gammax, gamma, ratio, ir, & + fuelloadm,fdxinv,fdyinv,betafl, bmst +integer:: i,j,k +integer::nerr +character(len=128)::msg + +!*** executable + +if(.not.have_fuel_cats)call crash('set_fire_params: fuel categories not yet set') + +call print_2d_stats(ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,fp%fmc_g,'set_fire_params: fmc_g') + +nerr=0 +do j=jfts,jfte + do i=ifts,ifte + ! fuel category + k=int( nfuel_cat(i,j) ) + if(k.ge.no_fuel_cat.and.k.le.no_fuel_cat2)then ! no fuel + fp%fgip(i,j)=0. ! no mass + fp%ischap(i,j)=0. + fp%phisc(i,j)=0. ! + fp%bbb(i,j)=1. ! + fuel_time(i,j)=7./0.85 ! does not matter, just what was there before + fp%phiwc(i,j)=0. + fp%r_0(i,j)=0. ! no fuel, no spread. + else + ! if(k.eq.0.and.nfuel_cat0.ge.1.and.nfuel_cat0.le.nfuelcats)then + ! ! replace k=0 by default + ! k=nfuel_cat0 + ! nerr=nerr+1 + ! endif + + if(k.lt.1.or.k.gt.nfuelcats)then +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + write(msg,'(3(a,i5))')'nfuel_cat(', i ,',',j,')=',k +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) + call message(msg) + if(k.eq.0)then + call message('Possibly nfuel_cat is uninitialized on input') + endif + call crash('set_fire_params: fuel category out of bounds') + endif + + fuel_time(i,j)=weight(k)/0.85 ! cell based + + ! do not understand calculations of stime in binit.m4 + ! set fuel time constant: weight=1000=>40% decrease over 10 min + ! fuel decreases as exp(-t/fuel_time) + ! exp(-600*0.85/1000) = approx 0.6 + + fp%ischap(i,j)=ichap(k) + fp%fgip(i,j)=fgi(k) + if(fire_fmc_read.eq.1)then + fp%fmc_g(i,j)=fuelmc_g + endif + ! print *,'fmc_g:',fire_fmc_read,i,j,fp%fmc_g(i,j) + + ! end jm addition + + ! + !*** rest copied from wf2_janice/fire_startup.m4 with minimal changes + ! + + ! ...Settings of fire spread parameters from Rothermel follows. These + ! don't need to be recalculated later. + + bmst = fp%fmc_g(i,j) / (1.+fp%fmc_g(i,j)) + fuelloadm= (1.-bmst) * fgi(k) ! fuelload without moisture + fuelload = fuelloadm * (.3048)**2 * 2.205 ! to lb/ft^2 + fueldepth = fueldepthm(k)/0.3048 ! to ft + betafl = fuelload/(fueldepth * fueldens(k))! packing ratio + betaop = 3.348 * savr(k)**(-0.8189) ! optimum packing ratio + qig = 250. + 1116.*fp%fmc_g(i,j) ! heat of preignition, btu/lb + epsilon = exp(-138./savr(k) ) ! effective heating number + rhob = fuelload/fueldepth ! ovendry bulk density, lb/ft^3 + + c = 7.47 * exp( -0.133 * savr(k)**0.55) ! const in wind coef + fp%bbb(i,j) = 0.02526 * savr(k)**0.54 ! const in wind coef + !if(fire_wind_log_interp .eq. 4 .or. fire_use_windrf .eq. 1) then + ! c = c * windrf(k)**fp%bbb(i,j) ! jm: multiply wind by reduction factor + !endif + e = 0.715 * exp( -3.59e-4 * savr(k)) ! const in wind coef + fp%phiwc(i,j) = c * (betafl/betaop)**(-e) + + ! phis = 5.275 *(fp%betafl(i,j))**(-0.3) *tanphim**2 ! slope factor + fp%phisc(i,j) = 5.275 *(betafl)**(-0.3) ! const in slope coeff + + rtemp2 = savr(k)**1.5 + gammax = rtemp2/(495. + 0.0594*rtemp2) ! maximum rxn vel, 1/min + a = 1./(4.774 * savr(k)**0.1 - 7.27) ! coef for optimum rxn vel + ratio = betafl/betaop + gamma = gammax *(ratio**a) *exp(a*(1.-ratio)) !optimum rxn vel, 1/min + + wn = fuelload/(1 + st(k)) ! net fuel loading, lb/ft^2 + rtemp1 = fp%fmc_g(i,j)/fuelmce(k) + etam = 1.-2.59*rtemp1 +5.11*rtemp1**2 -3.52*rtemp1**3 !moist damp coef + etam = max(etam,0.0) + etas = 0.174* se(k)**(-0.19) ! mineral damping coef + ir = gamma * wn * fuelheat * etam * etas !rxn intensity,btu/ft^2 min + ! jm irm = ir * 1055./( 0.3048**2 * 60.) * 1.e-6 !for mw/m^2 + ! jm: irm set but never used?? + + xifr = exp( (0.792 + 0.681*savr(k)**0.5) & + * (betafl+0.1)) /(192. + 0.2595*savr(k)) ! propagating flux ratio + +! ... r_0 is the spread rate for a fire on flat ground with no wind. + + fp%r_0(i,j) = ir*xifr/(rhob * epsilon *qig) ! default spread rate in ft/min + fp%r_0(i,j) = fp%r_0(i,j) * .00508 ! convert to m/s + fp%phiwc(i,j) = fp%phiwc(i,j) * fp%r_0(i,j) ! premultiply wind coefficient so it can be used additively + fp%phisc(i,j) = fp%phisc(i,j) * fp%r_0(i,j) ! premultiply wind coefficient so it can be used additively + + ! apply adjustments + fp%r_0(i,j) = fp%r_0(i,j) * adjr0(k) + fp%phiwc(i,j) = fp%phiwc(i,j) * adjrw(k) + fp%phisc(i,j) = fp%phisc(i,j) * adjrs(k) + + ! test fmc + if(fp%r_0(i,j) > 1e-6 .and. fp%fmc_g(i,j) > fuelmce(k))then +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + write(msg,'(a,2i6,3(a,e14.6))') 'set_fire_params: at ',i,j,' base rate of spread',fp%r_0(i,j),' moisture ',fp%fmc_g(i,j),'> extinction =',fuelmce(k) + call message(msg,level=0) + write(msg,'(5(a,e14.6))')'rtemp1=',rtemp1,' etam=',etam + call message(msg,level=0) +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) + call warning('propagation above extinction moisture',level=0) + endif + endif + enddo +enddo + +if(nerr.gt.1)then +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + write(msg,'(a,i6,a)')'set_fire_params: WARNING: fuel category 0 replaced in',nerr,' cells' +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) + call message(msg) +endif + +end subroutine set_fire_params + +! +!******************* +! + +subroutine heat_fluxes(dt,fp, & + ifms,ifme,jfms,jfme, & ! memory dims + ifts,ifte,jfts,jfte, & ! tile dims + iffs,iffe,jffs,jffe, & ! fuel_frac_burnt dims + fgip,fuel_frac_burnt, & !in + grnhft,grnqft) !out +implicit none + +!*** purpose +! compute the heat fluxes on the fire grid cells + +!*** arguments +type(fire_params), intent(in)::fp +real, intent(in)::dt ! dt the fire time step (the fire model advances time by this) +integer, intent(in)::ifts,ifte,jfts,jfte,ifms,ifme,jfms,jfme,iffs,iffe,jffs,jffe ! dimensions +real, intent(in),dimension(ifms:ifme,jfms:jfme):: fgip +real, intent(in),dimension(iffs:iffe,jffs:jffe):: fuel_frac_burnt +real, intent(out),dimension(ifms:ifme,jfms:jfme):: grnhft +real, intent(out),dimension(ifms:ifme,jfms:jfme),optional:: grnqft + +!*** local +integer::i,j +real:: dmass,bmst +logical::latent + + +!*** executable +latent = present(grnqft) +do j=jfts,jfte + do i=ifts,ifte + dmass = & ! ground fuel dry mass burnt this call (kg/m^2) + fgip(i,j) & ! init mass from fuel model no (kg/m^2) = fgi(nfuel_cat(i,j) + * fuel_frac_burnt(i,j) ! fraction burned this call (1) + bmst = fp%fmc_g(i,j)/(1.+fp%fmc_g(i,j)) + grnhft(i,j) = (dmass/dt)*(1.-bmst)*cmbcnst ! J/m^2/sec + if(latent)grnqft(i,j) = (bmst+(1.-bmst)*.56)*(dmass/dt)*xlv ! + ! bmst = relative water contents; 0.56 = est. ratio of water from burning + ! xlv = nominal specific latent heat of water J/kg (dependence on temperature ignored) + ! xlv is defined in module_model_constants + enddo +enddo + +end subroutine heat_fluxes + +! +!********************** +! + + +subroutine set_nfuel_cat( & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + ifuelread,nfuel_cat0,zsf,nfuel_cat) + +implicit none + +! set fuel distributions for testing +integer, intent(in):: ifts,ifte,jfts,jfte, & + ifms,ifme,jfms,jfme + +integer, intent(in)::ifuelread,nfuel_cat0 +real, intent(in), dimension(ifms:ifme, jfms:jfme)::zsf +real, intent(out), dimension(ifms:ifme, jfms:jfme)::nfuel_cat + +!*** local + +! parameters to control execution +integer:: i,j,iu1 +real:: t1 +character(len=128)msg + +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + write(msg,'(a,i3)')'set_nfuel_cat: ifuelread=',ifuelread +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) + call message(msg) + +if (ifuelread .eq. -1 .or. ifuelread .eq. 2) then +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + call message('set_nfuel_cat: assuming nfuel_cat initialized already') + call message(msg) +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) +else if (ifuelread .eq. 0) then +! + do j=jfts,jfte + do i=ifts,ifte + nfuel_cat(i,j)=real(nfuel_cat0) + enddo + enddo +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + write(msg,'(a,i3)')'set_nfuel_cat: fuel initialized with category',nfuel_cat0 +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) + call message(msg) + +else if (ifuelread .eq. 1) then +! +! make dependent on altitude (co mountains/forest vs. plains) +! 2000 m : 6562 ft ; 1600 m: 5249 ft + +! ... user defines fuel category spatial variability ! param! + do j=jfts,jfte + do i=ifts,ifte + ! nfuel_cat(i,j)= 2 ! grass with understory ! jm does nothing + !jm t1=zsf(i,j)*slngth/100. + t1 = zsf(i,j) ! this is in m + if(t1.le.1524.)then ! up to 5000 ft + nfuel_cat(i,j)= 3 ! tall grass + else if(t1.ge.1524. .and. t1.le.2073.)then ! 5.0-6.8 kft. + nfuel_cat(i,j)= 2 ! grass with understory + else if(t1.ge.2073..and.t1.le.2438.)then ! 6.8-8.0 kft. + nfuel_cat(i,j)= 8 ! timber litter - 10 (ponderosa) + else if(t1.gt.2438. .and. t1.le. 3354.) then ! 8.0-11.0 kft. +! ... could also be mixed conifer. + nfuel_cat(i,j)= 10 ! timber litter - 8 (lodgepole) + else if(t1.gt.3354. .and. t1.le. 3658.) then ! 11.0-12.0 kft + nfuel_cat(i,j)= 1 ! alpine meadow - 1 + else if(t1.gt.3658. ) then ! > 12.0 kft + nfuel_cat(i,j)= 14 ! no fuel. + endif + enddo + enddo + + call message('set_nfuel_cat: fuel initialized by altitude') +else + + call crash('set_nfuel_cat: bad ifuelread') +endif +! .............end load fuel categories (or constant) here. + +end subroutine set_nfuel_cat + +! +!********************** +! + +real function fire_rate_of_spread(propx, propy, i,j,fp) +! compute rate of spread at grid node (i,j) in the direction (dx,dy) +implicit none +!***arguments +real, intent(in)::propx, propy! direction, need not be normalized +integer, intent(in)::i,j ! node mesh coordinates +type(fire_params),intent(in)::fp + +!*** local +real:: ros_back,ros_wind,ros_slope,nvx,nvy,scale,rr +integer::ierrx ! number of errors +character(len=128)::msg ! error message +!*** executable +scale=sqrt(propx*propx+propy*propy) +if (.not. scale > 0.) scale =1. +nvx=propx/scale +nvy=propy/scale +call fire_ros(ros_back,ros_wind,ros_slope, nvx,nvy,i,j,fp,ierrx,msg) +rr = ros_back+ros_wind+ros_slope +if(fire_grows_only.gt.0)rr=max(rr,0.) +fire_rate_of_spread = rr + +end function fire_rate_of_spread + + + +subroutine fire_ros(ros_back,ros_wind,ros_slope, & +propx,propy,i,j,fp,ierrx,msg) + +implicit none + +! compute the wind speed and slope normal to the fireline and call fire_ros_cawfe + +!*** arguments +real, intent(out)::ros_back,ros_wind,ros_slope ! rate of spread: backing, due to wind, due to slope +real, intent(in)::propx,propy +integer, intent(in)::i,j ! node mesh coordinates +type(fire_params),intent(in)::fp +integer, intent(out)::ierrx +character(len=*), intent(out)::msg + +!*** local +real:: speed, tanphi ! windspeed and slope in the directino normal to the fireline +real::cor_wind,cor_slope,nvx,nvy,scale + +!*** executable + +! make sure normal direction is size 1 +!scale=sqrt(propx*propx+propy*propy)+tiny(scale) +scale=1. +nvx=propx/scale +nvy=propy/scale +if (fire_advection.ne.0) then ! from flags in module_fr_sfire_util + ! wind speed is total speed + speed = sqrt(fp%vx(i,j)*fp%vx(i,j)+ fp%vy(i,j)*fp%vy(i,j))+tiny(speed) + ! slope is total slope + tanphi = sqrt(fp%dzdxf(i,j)*fp%dzdxf(i,j) + fp%dzdyf(i,j)*fp%dzdyf(i,j))+tiny(tanphi) + ! cos of wind and spread, if >0 + cor_wind = max(0.,(fp%vx(i,j)*nvx + fp%vy(i,j)*nvy)/speed) + ! cos of slope and spread, if >0 + cor_slope = max(0., (fp%dzdxf(i,j)*nvx + fp%dzdyf(i,j)*nvy)/tanphi) +else + ! wind speed in spread direction + speed = fp%vx(i,j)*nvx + fp%vy(i,j)*nvy + ! slope in spread direction + tanphi = fp%dzdxf(i,j)*nvx + fp%dzdyf(i,j)*nvy + cor_wind=1. + cor_slope=1. +endif + +call fire_ros_cawfe(ros_back,ros_wind,ros_slope, & +speed,tanphi,cor_wind,cor_slope,i,j,fp,ierrx,msg) + +end subroutine fire_ros + +! +!*** +! + +subroutine fire_ros_cawfe(ros_back,ros_wind,ros_slope, & +speed,tanphi,cor_wind,cor_slope,i,j,fp,ierrx,msg) + +implicit none + +! find rate of spread from wind speed and slope +! copied from wf2_janice +! with the following changes ONLY: +! 0.5*(speed + abs(speed)) -> max(speed,0.) +! index l -> j +! took out some prints +! argument fuelloadm never used?? +! not using nfuel_cat here - cell info was put into arrays passed as arguments +! in include file to avoid transcription errors when used elsewhere +! betaop is absorbed in phiwc, see module_fr_sfire_model/fire_startup +! return the backing, wind, and slope contributions to the rate of spread separately +! because they may be needed to take advantage of known wind and slope vectors. +! They should add up to get the total rate of spread. +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc +! ... calculates fire spread rate with mcarthur formula or Rothermel +! using fuel type of fuel cell +! +! +! m/s =(ft/min) *.3048/60. =(ft/min) * .00508 ! conversion rate +! ft/min = m/s * 2.2369 * 88. = m/s * 196.850 ! conversion rate +! +!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + +!*** arguments +real, intent(out)::ros_back,ros_wind,ros_slope ! rate of spread: backing, due to wind, due to slope +real, intent(in)::speed,tanphi,cor_wind,cor_slope +integer, intent(in)::i,j ! node mesh coordinates +type(fire_params),intent(in)::fp +integer, intent(out)::ierrx +character(len=*), intent(out)::msg + +!*** local +real:: umid, phis, phiw, spdms, umidm, excess, tanphim,ros +real, parameter::ros_max=6. +integer::k + +!*** executable + +ierrx = 0 + +if (.not. fp%ischap(i,j) > 0.) then ! if not chaparral, do not test for .eq. 0 for speed + if (ibeh .eq. 1) then ! use Rothermel formula +! ... if wind is 0 or into fireline, phiw = 0, &this reduces to backing ros. + spdms = max(speed,0.) ! + umidm = min(spdms,30.) ! max input wind spd is 30 m/s !param! + umid = umidm * 196.850 ! m/s to ft/min + ! eqn.: phiw = c * umid**bbb(i,j) * (fp%betafl(i,j)/betaop)**(-e) ! wind coef + ros_wind = fp%phiwc(i,j) * (umid**fp%bbb(i,j)) ! wind coef + tanphim=max(tanphi,0.0) + tanphim=min(tanphim,5.0) ! jm + ! phis = 5.275 *(fp%betafl(i,j))**(-0.3) *tanphim**2 ! slope factor + ros_slope = fp%phisc(i,j) *tanphim**2 ! slope factor + ! rosm = fp%r_0(i,j)*(1. + phiw + phis) * .00508 ! spread rate, m/s + ros_back = fp%r_0(i,j) + elseif(ibeh.eq.2)then ! for testing only, spread rate = wind but not < 0 + ros_back = 0. + ros_wind = max(speed,0.) + ros_slope= 0. + elseif(ibeh.eq.3)then ! for testing only, spread rate = wind but not < 0 + ros_back = 0. + ros_wind = speed + ros_slope= 0. + elseif(ibeh.eq.0)then ! MacArthur formula (Australian) + ! rosm = 0.18*exp(0.8424*max(speed,0.)) + ros_back = 0.18 + ros_wind = 0.18*exp(0.8424*max(speed,0.)) - ros_back + ros_slope =0. + ! note: ros = ros_back + ros_wind + ros_slope + else ! error, but prevent unintialized variables + ! just so that there is something there + ros_back=-999. + ros_wind=-999. + ros_slope=-999. + endif + k = int(fp%nfuel_cat(i,j)) + ros=ros_back+ros_wind+ros_slope + if(ros > 1e-6 .and. fp%fmc_g(i,j) > fuelmce(k))then +!$OMP CRITICAL(SFIRE_PHYS_CRIT) + write(msg,'(a,2i6,3(a,e13.5))') 'fire_ros_cawfe: at ',i,j,' rate of spread',ros,' moisture ',fp%fmc_g(i,j),'> extinction =',fuelmce(k) +!$OMP END CRITICAL(SFIRE_PHYS_CRIT) + ! call warning(msg) + ierrx = 1 + endif +! +else ! chaparral model from Clark et al 2004 +! .... spread rate has no dependency on fuel character, only windspeed. + spdms = max(speed,0.) + ! rosm = 1.2974 * spdms**1.41 ! spread rate, m/s + ! note: backing ros is 0 for chaparral without setting nozero value below + !sp_n=.03333 + ! chaparral backing fire spread rate 0.033 m/s ! param! + !rosm= max(rosm, sp_n) ! no less than backing r.o.s. + + ros_back=.03333 ! chaparral backing fire spread rate 0.033 m/s ! param! + ros_wind = 1.2974 * spdms**1.41 ! spread rate, m/s + ros_wind = max(ros_wind, ros_back)-ros_back + ros_slope =0. + +endif +! multiply by the correction factors (from angle calculations) +ros_wind=ros_wind*cor_wind +ros_slope=ros_slope*cor_slope +! +! ----------note! put an 6 m/s cap on max spread rate ----------- +! rosm= min(rosm, 6.) ! no faster than this cap ! param ! + +excess = ros_back + ros_wind + ros_slope - ros_max + +if (excess > 0.)then + ! take it out of wind and slope in proportion + ros_wind = ros_wind - excess*ros_wind/(ros_wind+ros_slope) + ros_slope = ros_slope - excess*ros_slope/(ros_wind+ros_slope) +endif + + +! ... to rescale to veloc. carried by model, mult x (svel*snorm(1,3))= .1 +!jm: huh ??? +! fire_ros = 0.1*rosm +! +!write(msg,*)i,j,' speed=',speed,' tanphi',tanphi,' ros=',ros_back,ros_wind,ros_slope +!call message(msg) + +return + +contains +real function nrm2(u,v) +real, intent(in)::u,v +nrm2=sqrt(u*u+v*v) +end function nrm2 + +end subroutine fire_ros_cawfe + +subroutine fire_risk(fp, & + ifms,ifme,jfms,jfme, & ! memory dims + ifts,ifte,jfts,jfte, & ! tile dims + nfuel_cat, & + f_ros0,f_rosx,f_rosy,f_ros, & ! fire spread diagnostic variables + f_int,f_lineint,f_lineint2) ! fireline intensities for danger rating + +!*** arguments +type(fire_params), intent(in)::fp +integer, intent(in):: & + ifms,ifme,jfms,jfme, & ! memory dims + ifts,ifte,jfts,jfte ! tile dims +real, intent(in), dimension(ifms:ifme,jfms:jfme) :: nfuel_cat +real, intent(out), dimension(ifms:ifme,jfms:jfme) :: & + f_ros0,f_rosx,f_rosy,f_ros, & ! fire spread diagnostic variables + f_int,f_lineint,f_lineint2 ! fire intensities for danger rating + +!*** local +integer:: i,j,k, ierrx +real:: cor_wind=1.,cor_slope=1.,dt_fake=1. +real:: ros_back,ros_wind,ros_slope,speed,tanphi,front_speed,ros_x,ros_y +character(len=128)::msg + +!*** executable + +do j=jfts,jfte + do i=ifts,ifte +! compute the fire spread rate and vector + + ! wind speed is total speed + speed = sqrt(fp%vx(i,j)*fp%vx(i,j)+ fp%vy(i,j)*fp%vy(i,j))+tiny(speed) + ! slope is total slope + tanphi = sqrt(fp%dzdxf(i,j)*fp%dzdxf(i,j) + fp%dzdyf(i,j)*fp%dzdyf(i,j))+tiny(tanphi) + + call fire_ros_cawfe(ros_back,ros_wind,ros_slope, & + speed,tanphi,cor_wind,cor_slope,i,j,fp, ierrx, msg) + + ros_x = ros_wind * fp%vx(i,j)/speed + ros_slope * fp%dzdxf(i,j)/tanphi ! x direction component + ros_y = ros_wind * fp%vy(i,j)/speed + ros_slope * fp%dzdyf(i,j)/tanphi ! y direction component + +! store to out + f_ros0(i,j) = ros_back ! direction-less spread rate component + f_rosx(i,j) = ros_x + f_rosy(i,j) = ros_y + + ! max fire front speed in this location (m/s) + f_ros(i,j) = ros_back + sqrt(ros_x*ros_x + ros_y*ros_y) + + enddo +enddo + +call fire_intensity(fp, & ! fuel properties + ifms,ifme,jfms,jfme, & ! memory dims + ifts,ifte,jfts,jfte, & ! tile dims + ifms,ifme,jfms,jfme, & ! f_ros dims + f_ros,nfuel_cat, & !in + f_lineint,f_lineint2,f_int) ! fireline intensities out + +end subroutine fire_risk + +! +!*** +! + +subroutine fire_intensity(fp, & ! fuel params + ifms,ifme,jfms,jfme, & ! memory dims + ifts,ifte,jfts,jfte, & ! tile dims + irms,irme,jrms,jrme, & ! memory dims for ros + ros,nfuel_cat, & ! rate of spread in + fibyram,filimit,f_int) ! intensities out + +!*** arguments +type(fire_params), intent(in)::fp +integer, intent(in):: & + ifms,ifme,jfms,jfme, & ! memory dims + ifts,ifte,jfts,jfte, & ! tile dims + irms,irme,jrms,jrme ! memory dims for ros +real, intent(in), dimension(irms:irme,jrms:jrme) :: ros ! in rate of spread +real, intent(in), dimension(ifms:ifme,jfms:jfme) :: nfuel_cat +real, intent(out), dimension(ifms:ifme,jfms:jfme) :: & + fibyram,filimit ! out fireline intensities +real, intent(out), dimension(ifms:ifme,jfms:jfme), optional :: f_int ! fire intensity (J/m^2/s) + +!*** local +integer:: i,j,k +real, dimension(ifts:ifte,jfts:jfte):: rate_frac +real:: dt_fake=1. + +!*** executable + +call heat_fluxes(dt_fake,fp, & + ifms,ifme,jfms,jfme, & ! memory dims + ifts,ifte,jfts,jfte, & ! tile dims + irms,irme,jrms,jrme, & ! ros dims + fp%fgip,ros, & !in + fibyram) !out + +! multiply by fuel fraction consumed in flaming zone for the category +do j=jfts,jfte + do i=ifts,ifte + k=int( nfuel_cat(i,j) ) + fibyram(i,j)=fibyram(i,j)*ffw(k) + enddo +enddo + ! fuel fraction loss per fire front unit length traveled per unit time + ! burn_rate(i,j) = 0.5 * front_speed / fp%fuel_time(i,j) + + ! fireline element of length ds moves in time dt by front_speed * dt covering area ds * dt * front_speed (m^2) + ! after time dt the fuel fraction decrease is 0 at the leading edge and dt/fuel_time at the trailing edge + ! so the average fuel consumption over this zone is 0.5 * dt/fuel_time (1) + ! fuel load is fgip (kg/m^2) + ! and the amount of fuel burned fireline length ds travels over time dt is 0.5 fgip * ds * dt^2 * front_speed/fuel_time (kg) + ! note: dt because 1. it travels more 2. it burns longer + ! fgip*burn_rate_frac(i,j) = (kg/m^2) * (m/s^2) = kg/m/s^2 + + ! http://www.forestencyclopedia.net/p/p487 + ! H = I*w*r = (J/kg) * (kg/m^2) * (m/s) = J/m/s + ! fuel fraction loss per fire front unit length traveled + +do j=jfts,jfte + do i=ifts,ifte + rate_frac(i,j)=0.5*ros(i,j)/fp%fuel_time(i,j) + enddo +enddo + +! multiply by heat contents * fuel load +call heat_fluxes(dt_fake,fp, & + ifms,ifme,jfms,jfme, & ! memory dims + ifts,ifte,jfts,jfte, & ! tile dims + ifts,ifte,jfts,jfte, & ! rate_frac dims + fp%fgip,rate_frac, & !in + filimit) !out + +if(present(f_int))then + do j=jfts,jfte + do i=ifts,ifte + k=int( nfuel_cat(i,j) ) + ! in time tr the fraction of fuel consumed is ffw=1-exp(-tr/fuel_time) + ! giving flame residence time tr = - log(1-ffw)*fuel_time + ! fire intensity is heat contents * fuel load * fraction consumed / flame residence time + ! J/kg * kg/m^2 * 1 / s = J/m^2/s + ! this is averaged over the flame residence time, + rate_frac(i,j)=ffw(k)/(fp%fuel_time(i,j)*(-log(1.-ffw(k)))) + enddo + enddo + + ! multiply by heat contents * fuel load J/m^2 + + call heat_fluxes(dt_fake,fp, & + ifms,ifme,jfms,jfme, & ! memory dims + ifts,ifte,jfts,jfte, & ! tile dims + ifts,ifte,jfts,jfte, & ! rate_frac dims + fp%fgip,rate_frac, & !in + f_int) !out + +endif + +end subroutine fire_intensity + +!*** executable + +end module module_fr_sfire_phys diff --git a/wrfv2_fire/phys/module_fr_sfire_util.F b/wrfv2_fire/phys/module_fr_sfire_util.F new file mode 100644 index 00000000..122a639d --- /dev/null +++ b/wrfv2_fire/phys/module_fr_sfire_util.F @@ -0,0 +1,1742 @@ +! +!*** Jan Mandel August-October 2007 +!*** email: jmandel@ucar.edu or Jan.Mandel@gmail.com or Jan.Mandel@cudenver.edu +! +! This module contains general purpose utilities and WRF wrappers because I want the +! model to be able to run standalone. No physics here. +! Some are dependent on WRF indexing scheme. Some violate WRF conventions but these +! are not called from the WRF dependent code. Some are not called at all. +! + +module module_fr_sfire_util + +! various method selection parameters +! 1. add the parameter and its static default here +! optional: +! 2. add copy from config_flags in module_fr_sfire_driver%%set_flags +! 3. add a line in Registry.EM to define the variable and set default value +! 4. add the variable and value in namelist.input + +! to compile in a hook to attach debugger to a running process. +!#define DEBUG_HOOK + +!use module_domain, only: domain +!use module_model_constants, only: reradius, & ! 1/earth radiusw +! pi2 ! 2*pi +implicit none + +integer,save:: & + fire_print_msg=1, & ! print SFIRE progress + fire_print_file=1, & ! write many files by write_array_m; compile with DEBUG_OUT, do not run in parallel + fuel_left_method=1, & ! 1=simple, 2=exact in linear case + fuel_left_irl=2, & ! refinement for fuel calculation, must be even + fuel_left_jrl=2, & ! currently, 2 only supported + boundary_guard=-1, & ! crash if fire gets this many cells to domain boundary, -1=off + fire_grows_only=1, & ! fire can spread out only (level set functions may not increase) + fire_upwinding=3, & ! upwind normal spread: 1=standard, 2=godunov, 3=eno, 4=sethian + fire_test_steps=0, & ! 0=no fire, 1=normal, >1 = do specified number of steps and terminate (testing only) + fire_topo_from_atm=1, & ! 0 = expect ZSF set correctly on entry, 1 = populate by interploating from atmosphere + fire_advection=0, & ! 0 = fire spread from normal wind/slope (CAWFE), 1 = full speed projected + fire_wind_log_interp=4,& ! kind of vertical log layer wind interpolation, see driver + fire_use_windrf=0, & ! if fire_wind_log_interp.ne.4: 0=ignore wind reduction factors, 1=multiply, 2=use to set fwh + fire_fmc_read=1, & ! fuel moisture: 0 from wrfinput, 1 from namelist.fire, 2 read from file in ideal + fire_ignition_clamp=0, & ! if 1, clamp ignition to grid points + fire_hfx_given=0, & ! "0=no, run normally, 1=from wrfinput, 2=from file input_hfx in ideal, 4=by parameters" "" + fire_hfx_num_lines=1, & ! number of heatflux parameter sets defining the heaflux lines (must be 1) + fire_update_fuel_frac=1,& ! 1 normal, 2 burner + fndwi_from_ndwi=1, & ! interpolate ndwi from atmosphere resolution + kfmc_ndwi=0 ! if>0 , number of the fuel moisture class to update from ndwi + + +real, save:: & + fire_perimeter_time=0.,& ! if >0, set lfn from tign until this time, and read tign_g in ideal + fire_tign_in_time=0., & ! if >0, set ignition time from tign_in until this time, and read tign_in in ideal + fire_atm_feedback=1. , & ! 1 = normal, 0. = one way coupling atmosphere -> fire only + fire_back_weight=0.5, & ! RK parameter, 0 = Euler method, 0.5 = Heun, 1 = fake backward Euler + fire_viscosity=0.4, & ! artificial viscosity + fire_lfn_ext_up=1, & ! 0.=extend level set function at boundary by reflection, 1.=always up + fire_hfx_value=0., & ! heat flux value specified when given by parameterst flux value specified when given by parameters:w + fire_hfx_latent_part=0.084 ! proportion of the given heat flux released as latent, the rest is sensible + + +integer, parameter:: REAL_SUM=10, REAL_MAX=20, REAL_MIN=21, REAL_AMAX=22, RNRM_SUM=30, RNRM_MAX=40 + +! describe one ignition line +type line_type + REAL ros, & ! subscale rate of spread during the ignition process + stop_time, & ! when the ignition process stops from ignition start (s) + wind_red, & ! wind reduction factor at the ignition line + wrdist, & ! distance from the ignition line when the wind reduction stops + wrupwind, & ! use distance interpolated between 0. = nearest 1. = upwind + start_x, & ! x coordinate of the ignition line start point (m, or long/lat) + start_y, & ! y coordinate of the ignition line start point + end_x, & ! x coordinate of the ignition line end point + end_y, & ! y coordinate of the ignition line end point + start_time, & ! time for the start point from simulation start (s) + end_time, & ! time for the end poin from simulation start (s) + trans_time, & ! transition time (s) + radius, & ! thickness of the line + hfx_value ! heat flux value associated with the line +end type line_type + +integer, parameter:: fire_max_lines=5 + +integer:: stat_lev=1 ! print level to print statistics + +! container type for all ignitions and associated scalars +type lines_type + type(line_type):: line(fire_max_lines) ! descriptions of ignition lines + integer:: num_lines, & ! number of lines used + max_lines, & ! max number of lines that can be specified through namelist + longlat ! 0 for ideal, 1 for real + real:: unit_fxlong,unit_fxlat ! degree of longtitude/latitude in m; 1m for ideal +end type lines_type + +contains + +! +!***************************** +! + +logical function isnan(a) +real, intent(in):: a +isnan= (a.ne.a) +return +end function isnan + +logical function isnotfinite(aa) +real, intent(in)::aa +isnotfinite=(aa.ne.aa.or..not.aa.le.huge(aa).or..not.aa.ge.-huge(aa)) +end function isnotfinite + + +subroutine interpolate_z2fire(id, & ! for debug output, <= 0 no output + istrip, & ! width of strip to extrapolate to around domain + ids,ide, jds,jde, & ! atm grid dimensions + ims,ime, jms,jme, & + ips,ipe,jps,jpe, & + its,ite,jts,jte, & + ifds, ifde, jfds, jfde, & ! fire grid dimensions + ifms, ifme, jfms, jfme, & + ifts,ifte,jfts,jfte, & + ir,jr, & ! atm/fire grid ratio + zs, & ! atm grid arrays in + zsf) ! fire grid arrays out + +implicit none +!*** purpose: interpolate height + +!*** arguments +integer, intent(in)::id, & + istrip, & + ids,ide, jds,jde, & ! atm domain bounds + ims,ime,jms,jme, & ! atm memory bounds + ips,ipe,jps,jpe, & + its,ite,jts,jte, & ! atm tile bounds + ifds, ifde, jfds, jfde, & ! fire domain bounds + ifms, ifme, jfms, jfme, & ! fire memory bounds + ifts,ifte,jfts,jfte, & ! fire tile bounds + ir,jr ! atm/fire grid refinement ratio +real, intent(in), dimension(ims:ime, jms:jme):: zs ! terrain height at atm cell centers & ! terrain height +real,intent(out), dimension(ifms:ifme,jfms:jfme)::& + zsf ! terrain height fire grid nodes + + +!*** local +real, dimension(its-2:ite+2,jts-2:jte+2):: za ! terrain height +integer:: i,j,jts1,jte1,its1,ite1,jfts1,jfte1,ifts1,ifte1,itso,jtso,iteo,jteo + +if(istrip.gt.1)call crash('interpolate_z2fire: istrip should be 0 or 1 or less') + +! terrain height + + jts1=max(jts-1,jds) ! lower loop limit by one less when at end of domain + its1=max(its-1,ids) ! ASSUMES THE HALO IS THERE if patch != domain + jte1=min(jte+1,jde) + ite1=min(ite+1,ide) + do j = jts1,jte1 + do i = its1,ite1 + ! copy to local array + za(i,j)=zs(i,j) + enddo + enddo + + call continue_at_boundary(1,1,0., & ! do x direction or y direction + its-2,ite+2,jts-2,jte+2, & ! memory dims + ids,ide,jds,jde, & ! domain dims - winds defined up to +1 + ips,ipe,jps,jpe, & ! patch dims - winds defined up to +1 + its1,ite1,jts1,jte1, & ! tile dims + itso,jtso,iteo,jteo, & + za) ! array + + ! interpolate to tile plus strip along domain boundary if at boundary + jfts1=snode(jfts,jfds,-istrip) ! lower loop limit by one less when at end of domain + ifts1=snode(ifts,ifds,-istrip) + jfte1=snode(jfte,jfde,+istrip) + ifte1=snode(ifte,ifde,+istrip) + + call interpolate_2d( & + its-2,ite+2,jts-2,jte+2, & ! memory dims atm grid tile + its1-1,ite1+1,jts1-1,jte1+1, & ! where atm grid values set + ifms,ifme,jfms,jfme, & ! array dims fire grid + ifts1,ifte1,jfts1,jfte1, & ! dimensions fire grid tile + ir,jr, & ! refinement ratio + real(ids),real(jds),ifds+(ir-1)*0.5,jfds+(jr-1)*0.5, & ! line up by lower left corner of domain + za, & ! in atm grid + zsf) ! out fire grid + +end subroutine interpolate_z2fire + +! +!*********************************************************************** +! +! +!**************** +! +subroutine crash(s) +use module_wrf_error +implicit none +character(len=*), intent(in)::s +character(len=128)msg +msg='crash: '//s +call message(msg,level=0) +!$OMP CRITICAL(SFIRE_MESSAGE_CRIT) +call wrf_error_fatal(msg) +!$OMP END CRITICAL(SFIRE_MESSAGE_CRIT) +end subroutine crash + +! +!**************** +! + +subroutine warning(s,level) +implicit none +!*** arguments +character(len=*), intent(in)::s +character(len=128)::msg +integer,intent(in),optional::level +msg='WARNING:'//s +if(present(level))then + call message(msg,level=level) +else + call message(msg,level=0) +endif +end subroutine warning + + +subroutine message(s,level) +use module_wrf_error +#ifdef _OPENMP +use OMP_LIB +#endif +implicit none +!*** arguments +character(len=*), intent(in)::s +integer,intent(in),optional::level +!*** local +character(len=128)::msg +character(len=118)::t +integer m,mlevel +logical op +!*** executable +if(present(level))then + mlevel=level +else + mlevel=2 ! default message level +endif +if(fire_print_msg.ge.mlevel)then + m=0 +!$OMP CRITICAL(SFIRE_MESSAGE_CRIT) +#ifdef _OPENMP + m=omp_get_thread_num() + t=s + write(msg,'(a6,i3,a1,a118)')'SFIRE:',m,':',t +#else + msg='SFIRE:'//s +#endif + call wrf_message(msg) + !flush(6) ! will not work on intel compiler + !flush(0) +!$OMP END CRITICAL(SFIRE_MESSAGE_CRIT) +endif +end subroutine message + +! +!**************** +! + +subroutine time_start +use module_timing, only:start_timing +implicit none +call start_timing +end subroutine time_start + +subroutine time_end(string) +use module_timing, only:end_timing +implicit none +character(len=*)string +call end_timing(string) +end subroutine time_end + + +integer function open_text_file(filename,rw) +implicit none +character(len=*),intent(in):: filename,rw +!$ integer, external:: OMP_GET_THREAD_NUM +character(len=128):: msg +character(len=1)::act +integer::iounit,ierr +logical::op + +!$ if (OMP_GET_THREAD_NUM() .ne. 0)then +!$ call crash('open_input_text_file: called from parallel loop') +!$ endif + + do iounit=19,99 + inquire(iounit,opened=op) + if(.not.op)goto 1 + enddo + call crash('open_text_file: Cannot find any available I/O unit') +1 continue + act=rw(1:1) + select case (act) + case ('r','R') + OPEN(iounit, FILE=filename,FORM='FORMATTED',STATUS='OLD',ACTION='READ',IOSTAT=ierr) + case ('w','W') + OPEN(iounit, FILE=filename,FORM='FORMATTED',STATUS='UNKNOWN',ACTION='WRITE',IOSTAT=ierr) + case default + write(msg,*)'open_text_file: bad mode ',trim(rw),' for file ',trim(filename) + end select + + if(ierr.ne.0)then + write(msg,*)'open_text_file: Cannot open file ',filename + call crash(msg) + endif + open_text_file=iounit + +end function open_text_file + +! +!**************** +! + + +subroutine set_ideal_coord( dxf,dyf, & + ifds,ifde,jfds,jfde, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte, & + fxlong,fxlat & + ) +implicit none +! arguments +real, intent(in)::dxf,dyf +integer, intent(in):: & + ifds,ifde,jfds,jfde, & + ifms,ifme,jfms,jfme, & + ifts,ifte,jfts,jfte +real, intent(out),dimension(ifms:ifme,jfms:jfme)::fxlong,fxlat +! local +integer::i,j + ! set fake coordinates, in m + do j=jfts,jfte + do i=ifts,ifte + ! uniform mesh, lower left domain corner is (0,0) + fxlong(i,j)=(i-ifds+0.5)*dxf + fxlat (i,j)=(j-jfds+0.5)*dyf + enddo + enddo +end subroutine set_ideal_coord + +! +!**************** +! + + +subroutine continue_at_boundary(ix,iy,bias, & ! do x direction or y direction + ims,ime,jms,jme, & ! memory dims + ids,ide,jds,jde, & ! domain dims + ips,ipe,jps,jpe, & ! patch dims + its,ite,jts,jte, & ! tile dims + itso,iteo,jtso,jteo, & ! tile dims where set + lfn) ! array +implicit none +!*** description +! extend array by one beyond the domain by linear continuation +!*** arguments +integer, intent(in)::ix,iy ! not 0 = do x or y (1 or 2) direction +real,intent(in)::bias ! 0=none, 1.=max +integer, intent(in)::ims,ime,jms,jme, & ! memory dims + ids,ide,jds,jde, & ! domain dims + ips,ipe,jps,jpe, & ! patch dims + its,ite,jts,jte ! tile dims +integer, intent(out)::itso,jtso,iteo,jteo ! where set +real,intent(inout),dimension(ims:ime,jms:jme)::lfn +!*** local +integer i,j +character(len=128)::msg +integer::its1,ite1,jts1,jte1 +integer,parameter::halo=1 ! width of halo region to update +!*** executable +! check if there is space for the extension +call check_mesh_2dim(its-1,ite+1,jts-1,jte+1,ims,ime,jms,jme) +! for dislay only +itso=its +jtso=jts +iteo=ite +jteo=jte +! go halo width beyond if at patch boundary but not at domain boudnary +! assume we have halo need to compute the value we do not have +! the next thread that would conveniently computer the extended values at patch corners +! besides halo may not transfer values outside of the domain +! +its1=its +jts1=jts +ite1=ite +jte1=jte +if(its.eq.ips.and..not.its.eq.ids)its1=its-halo +if(jts.eq.jps.and..not.jts.eq.jds)jts1=jts-halo +if(ite.eq.ipe.and..not.ite.eq.ide)ite1=ite+halo +if(jte.eq.jpe.and..not.jte.eq.jde)jte1=jte+halo +!$OMP CRITICAL(SFIRE_UTIL_CRIT) +write(msg,'(a,2i5,a,f5.2)')'continue_at_boundary: directions',ix,iy,' bias ',bias +call message(msg,level=3) +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) +if(ix.ne.0)then + if(its.eq.ids)then + do j=jts1,jte1 + lfn(ids-1,j)=EX(lfn(ids,j),lfn(ids+1,j)) + enddo + itso=ids-1 + endif + if(ite.eq.ide)then + do j=jts1,jte1 + lfn(ide+1,j)=EX(lfn(ide,j),lfn(ide-1,j)) + enddo + iteo=ide+1 + endif +!$OMP CRITICAL(SFIRE_UTIL_CRIT) + write(msg,'(8(a,i5))')'continue_at_boundary: x:',its,':',ite,',',jts,':',jte,' ->',itso,':',iteo,',',jts1,':',jte1 + call message(msg,level=3) +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) +endif +if(iy.ne.0)then + if(jts.eq.jds)then + do i=its1,ite1 + lfn(i,jds-1)=EX(lfn(i,jds),lfn(i,jds+1)) + enddo + jtso=jds-1 + endif + if(jte.eq.jde)then + do i=its1,ite1 + lfn(i,jde+1)=EX(lfn(i,jde),lfn(i,jde-1)) + enddo + jteo=jde+1 + endif +!$OMP CRITICAL(SFIRE_UTIL_CRIT) + write(msg,'(8(a,i5))')'continue_at_boundary: y:',its,':',ite,',',jts,':',jte,' ->',its1,':',ite1,',',jtso,':',jteo +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) + call message(msg,level=3) +endif +! corners of the domain +if(ix.ne.0.and.iy.ne.0)then + if(its.eq.ids.and.jts.eq.jds)lfn(ids-1,jds-1)=EX(lfn(ids,jds),lfn(ids+1,jds+1)) + if(its.eq.ids.and.jte.eq.jde)lfn(ids-1,jde+1)=EX(lfn(ids,jde),lfn(ids+1,jde-1)) + if(ite.eq.ide.and.jts.eq.jds)lfn(ide+1,jds-1)=EX(lfn(ide,jds),lfn(ide-1,jds+1)) + if(ite.eq.ide.and.jte.eq.jde)lfn(ide+1,jde+1)=EX(lfn(ide,jde),lfn(ide-1,jde-1)) +endif +return +contains +real function EX(a,b) +!*** statement function +real a,b +EX=(1.-bias)*(2.*a-b)+bias*max(2.*a-b,a,b) ! extrapolation, max quarded +end function EX +end subroutine continue_at_boundary + +! +!***************************** +! + +subroutine check_mesh_2dim(ids,ide,jds,jde,ims,ime,jms,jme) +implicit none +integer, intent(in)::ids,ide,jds,jde,ims,ime,jms,jme +character(len=128)msg +if(idsime.or.jdsjme)then +!$OMP CRITICAL(SFIRE_UTIL_CRIT) + write(msg,*)'mesh dimensions: ',ids,ide,jds,jde + call message(msg,level=0) + write(msg,*)'memory dimensions:',ims,ime,jms,jme +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) + call message(msg,level=0) + call crash('check_mesh_2dim: memory dimensions too small') +endif +end subroutine check_mesh_2dim + +! +!**************** +! + +subroutine check_mesh_3dim(ids,ide,kds,kde,jds,jde,ims,ime,kms,kme,jms,jme) +integer, intent(in)::ids,ide,jds,jde,ims,ime,jms,jme,kds,kde,kms,kme +if(idsime.or.jdsjme.or.kdskme) then + call crash('memory dimensions too small') +endif +end subroutine check_mesh_3dim + +! +!**************** +! + +subroutine sum_2d_cells( & + ifms,ifme,jfms,jfme, & + ifts,ifte,jtfs,jfte, & + v2, & ! input + ims,ime,jms,jme, & + its,ite,jts,jte, & + v1) ! output +implicit none + +!*** purpose +! sum cell values in mesh2 to cell values of coarser mesh1 + +!*** arguments +! the dimensions are in cells, not nodes! + +integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme +real, intent(out)::v1(ims:ime,jms:jme) +integer, intent(in)::ifts,ifte,jtfs,jfte,ifms,ifme,jfms,jfme +real, intent(in)::v2(ifms:ifme,jfms:jfme) + +!*** local +integer:: i,i_f,j,j_f,ir,jr,isz1,isz2,jsz1,jsz2,ioff,joff,ibase,jbase +real t +character(len=128)msg + +!*** executable + +!check mesh dimensions and domain dimensions +call check_mesh_2dim(its,ite,jts,jte,ims,ime,jms,jme) +call check_mesh_2dim(ifts,ifte,jtfs,jfte,ifms,ifme,jfms,jfme) + +! compute mesh sizes +isz1 = ite-its+1 +jsz1 = jte-jts+1 +isz2 = ifte-ifts+1 +jsz2 = jfte-jtfs+1 + +! check mesh sizes +if(isz1.le.0.or.jsz1.le.0.or.isz2.le.0.or.jsz2.le.0)then + call message('all mesh sizes must be positive',level=0) + goto 9 +endif + +! compute mesh ratios +ir=isz2/isz1 +jr=jsz2/jsz1 + +if(isz2.ne.isz1*ir .or. jsz2.ne.jsz1*jr)then + call message('input mesh size must be multiple of output mesh size',level=0) + goto 9 +endif + + +! v1 = sum(v2) +do j=jts,jte + jbase=jtfs+jr*(j-jts) + do i=its,ite + ibase=ifts+ir*(i-its) + t=0. + do joff=0,jr-1 + j_f=joff+jbase + do ioff=0,ir-1 + i_f=ioff+ibase + t=t+v2(i_f,j_f) + enddo + enddo + v1(i,j)=t + enddo +enddo + +return + +9 continue +!$OMP CRITICAL(SFIRE_UTIL_CRIT) +write(msg,91)ifts,ifte,jtfs,jfte,ifms,ifme,jfms,jfme +call message(msg,level=0) +write(msg,91)its,ite,jts,jte,ims,ime,jms,jme +call message(msg,level=0) +write(msg,92)'input mesh size:',isz2,jsz2 +call message(msg,level=0) +91 format('dimensions: ',8i8) +write(msg,92)'output mesh size:',isz1,jsz1 +call message(msg,level=0) +92 format(a,2i8) +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) +call crash('sum_2d_cells: bad mesh sizes') + +end subroutine sum_2d_cells + + + +! module_fr_sfire_util%%interpolate_2d +subroutine interpolate_2d( & + ims2,ime2,jms2,jme2, & ! array coarse grid + its2,ite2,jts2,jte2, & ! dimensions coarse grid + ims1,ime1,jms1,jme1, & ! array coarse grid + its1,ite1,jts1,jte1, & ! dimensions fine grid + ir,jr, & ! refinement ratio + rip2,rjp2,rip1,rjp1, & ! (rip2,rjp2) on grid 2 lines up with (rip1,rjp1) on grid 1 + v2, & ! in coarse grid + v1 ) ! out fine grid +implicit none + +!*** purpose +! interpolate nodal values in mesh2 to nodal values in mesh1 +! interpolation runs over the mesh2 region its2:ite2,jts2:jte2 +! only the part of mesh 1 in the region its1:ite1,jts1:jte1 is modified + +!*** arguments + +integer, intent(in)::its1,ite1,jts1,jte1,ims1,ime1,jms1,jme1 +integer, intent(in)::its2,ite2,jts2,jte2,ims2,ime2,jms2,jme2 +integer, intent(in)::ir,jr +real,intent(in):: rjp1,rip1,rjp2,rip2 +real, intent(out)::v1(ims1:ime1,jms1:jme1) +real, intent(in)::v2(ims2:ime2,jms2:jme2) + +!*** local +integer:: i1,i2,j1,j2,is,ie,js,je +real:: tx,ty,rx,ry +real:: rio,rjo +intrinsic::ceiling,floor + +!*** executable + +!check mesh dimensions and domain dimensions +call check_mesh_2dim(its1,ite1,jts1,jte1,ims1,ime1,jms1,jme1) +call check_mesh_2dim(its2,ite2,jts2,jte2,ims2,ime2,jms2,jme2) + +! compute mesh ratios +rx=1./ir +ry=1./jr + +do j2=jts2,jte2-1 ! loop over mesh 2 cells + rjo=rjp1+jr*(j2-rjp2) ! mesh 1 coordinate of the mesh 2 patch start + js=max(jts1,ceiling(rjo)) ! lower bound of mesh 1 patch for this mesh 2 cell + je=min(jte1,floor(rjo)+jr) ! upper bound of mesh 1 patch for this mesh 2 cell + do i2=its2,ite2-1 + rio=rip1+ir*(i2-rip2) + is=max(its1,ceiling(rio)) + ie=min(ite1,floor(rio)+ir) + do j1=js,je + ty = (j1-rjo)*ry + do i1=is,ie + ! in case mesh 1 node lies on the boundary of several mesh 2 cells + ! the result will be written multiple times with the same value + ! up to a rounding error + tx = (i1-rio)*rx + !print *,'coarse ',i2,j2,'to',i2+1,j2+1,' fine ',is,js,' to ',ie,je + v1(i1,j1)= & + (1-tx)*(1-ty)*v2(i2,j2) & + + (1-tx)*ty *v2(i2,j2+1) & + + tx*(1-ty)*v2(i2+1,j2) & + + tx*ty *v2(i2+1,j2+1) + !print *,'coarse ',i2,j2,' fine ',i1,j1, ' offset ',io,jo,' weights ',tx,ty, & + ! 'in ',v2(i2,j2),v2(i2,j2+1),v2(i2+1,j2),v2(i2+1,j2+1),' out ',v1(i1,j1) + !write(*,'(a,2i5,a,2f8.2,a,4f8.2,a,2i5,a,f8.2)') & + !'coarse ',i2,j2,' coord',rio,rjo,' val',v2(i2,j2),v2(i2,j2+1),v2(i2+1,j2),v2(i2+1,j2+1),& + !' fine ',i1,j1,' out ',v1(i1,j1) + enddo + enddo + enddo +enddo + +end subroutine interpolate_2d + +! +!**************** +! + +subroutine interpolate_2d_cells2cells( & + ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2,v2, & ! in + ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1,v1 ) ! out +implicit none + +!*** purpose +! interpolate nodal values in mesh2 to nodal values in mesh1 +! input mesh 2 is coarse output mesh 1 is fine + +!*** arguments + +integer, intent(in)::ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1 +real, intent(out)::v1(ims1:ime1,jms1:jme1) +integer, intent(in)::ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2 +real, intent(in)::v2(ims2:ime2,jms2:jme2) + +! Example with mesh ratio=4. | = cell boundary, x = cell center +! +! mesh2 |-------x-------|-------x-------| +! mesh1 |-x-|-x-|-x-|-x-|-x-|-x-|-x-|-x-| +! + +!*** local +integer:: ir,jr,isz1,isz2,jsz1,jsz2,ip,jp,ih,jh +character(len=128)msg + +!*** executable + +!check mesh dimensions and domain dimensions +call check_mesh_2dim(ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1) +call check_mesh_2dim(ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2) + +! compute mesh sizes +isz1 = ide1-ids1+1 +jsz1 = jde1-jds1+1 +isz2 = ide2-ids2+1 +jsz2 = jde2-jds2+1 + +! check mesh sizes +if(isz1.le.0.or.jsz1.le.0.or.isz2.le.0.or.jsz2.le.0)goto 9 +if(mod(isz1,isz2).ne.0.or.mod(jsz1,jsz2).ne.0)goto 9 + +! compute mesh ratios +ir=isz1/isz2 +jr=jsz1/jsz2 +! +! mesh2 |-------x-------|-------x-------| +! mesh1 |-x-|-x-|-x-|-x-|-x-|-x-|-x-|-x-| + +! mesh2 |-----x-----|-----x-----| rx=3 +! mesh1 |-x-|-x-|-x-|-x-|-x-|-x-| +! i2 1 1 1 2 +! i1 1 2 3 4 5 +! ioff 0 1 2 0 +! tx 0 1/3 2/3 + +! mesh2 |---x---|---x---| rx=2 +! mesh1 |-x-|-x-|-x-|-x-| +! i2 1 1 2 +! i1 2 3 4 +! ioff 0 1 2 +! tx 1/4 3/4 + + +! offset of the last node in the 1st half of the cell +ih=ir/2 +jh=jr/2 +! 0 if coarse cell center coincides with fine, 1 if not +ip=mod(ir+1,2) +jp=mod(jr+1,2) + +call interpolate_2d_w(ip,jp,ih,jh,ir,jr, & + ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2,v2, & ! in + ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1,v1 ) ! out + +return + +9 continue +!$OMP CRITICAL(SFIRE_UTIL_CRIT) +write(msg,91)ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2 +call message(msg,level=0) +write(msg,91)ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1 +call message(msg,level=0) +write(msg,92)'input mesh size:',isz2,jsz2 +call message(msg,level=0) +91 format('dimensions: ',8i8) +write(msg,92)'output mesh size:',isz1,jsz1 +call message(msg,level=0) +92 format(a,2i8) +call crash("module_fr_sfire_util:interpolate_2dmesh_cells: bad mesh sizes") +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) +end subroutine interpolate_2d_cells2cells + +! +!**************** +! + +subroutine interpolate_2d_cells2nodes( & + ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2,v2, & ! in + ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1,v1 ) ! out +implicit none + +!*** purpose +! interpolate nodal values in mesh2 to nodal values in mesh1 +! input mesh 2 is coarse output mesh 1 is fine + +!*** arguments + +integer, intent(in)::ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1 +real, intent(out)::v1(ims1:ime1,jms1:jme1) +integer, intent(in)::ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2 +real, intent(in)::v2(ims2:ime2,jms2:jme2) + +! Example with mesh ratio=4. | = cell boundary, x = cell center +! +! mesh2 |-------x-------|-------x-------| +! mesh1 x-|-x-|-x-|-x-|-x-|-x-|-x-|-x-|-x +! + +!*** local +integer:: ir,jr,isz1,isz2,jsz1,jsz2,ip,jp,ih,jh +character(len=128)msg + +!*** executable + +!check mesh dimensions and domain dimensions +call check_mesh_2dim(ids1,ide1+1,jds1,jde1+1,ims1,ime1,jms1,jme1) +call check_mesh_2dim(ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2) + +! compute mesh sizes +isz1 = ide1-ids1+1 +jsz1 = jde1-jds1+1 +isz2 = ide2-ids2+1 +jsz2 = jde2-jds2+1 + +! check mesh sizes +if(isz1.le.0.or.jsz1.le.0.or.isz2.le.0.or.jsz2.le.0)goto 9 +if(mod(isz1,isz2).ne.0.or.mod(jsz1,jsz2).ne.0)goto 9 + +! compute mesh ratios +ir=isz1/isz2 +jr=jsz1/jsz2 +! +! mesh2 |-------x-------|-------x-------| +! mesh1 x-|-x-|-x-|-x-|-x-|-x-|-x-|-x-|-x + +! mesh2 |-----x-----|-----x-----| rx=3 +! mesh1 x-|-x-|-x-|-x-|-x-|-x-|-x + +! mesh2 |---x---|---x---| rx=2 +! mesh1 x-|-x-|-x-|-x-|-x + +! offset of the last node in the 1st half of the cell +ih=(ir+1)/2 +jh=(jr+1)/2 +! 0 if coarse cell center coincides with fine, 1 if not +ip=mod(ir,2) +jp=mod(jr,2) + + +call interpolate_2d_w(ip,jp,ih,jh,ir,jr, & + ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2,v2, & ! in + ids1,ide1+1,jds1,jde1+1,ims1,ime1,jms1,jme1,v1 ) ! out + + +return +9 continue +!$OMP CRITICAL(SFIRE_UTIL_CRIT) +write(msg,91)ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2 +call message(msg,level=0) +write(msg,91)ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1 +call message(msg,level=0) +write(msg,92)'input mesh size:',isz2,jsz2 +call message(msg,level=0) +91 format('dimensions: ',8i8) +write(msg,92)'output mesh size:',isz1,jsz1 +call message(msg,level=0) +92 format(a,2i8) +call crash("module_fr_sfire_util:interpolate_2d_cells2nodes: bad mesh sizes") +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) +end subroutine interpolate_2d_cells2nodes +! +!**************** +! + +subroutine interpolate_2d_w(ip,jp,ih,jh,ir,jr, & + ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2,v2, & ! in + ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1,v1 ) ! out +implicit none +!*** EXCEPTION: THIS SUBROUTINE IS NEITHER CELL NOR NODE BASED. + +integer, intent(in)::ip,jp,ih,jh,ir,jr +integer, intent(in)::ids1,ide1,jds1,jde1,ims1,ime1,jms1,jme1 +real, intent(out)::v1(ims1:ime1,jms1:jme1) +integer, intent(in)::ids2,ide2,jds2,jde2,ims2,ime2,jms2,jme2 +real, intent(in)::v2(ims2:ime2,jms2:jme2) + +real:: tx,ty,rx,ry,half,xoff,yoff +integer:: i1,i2,j1,j2,ioff,joff +parameter(half=0.5) + +rx=ir +ry=jr + +xoff = ip*half +yoff = jp*half + +! the inside, ids1+ih:ide1-ih,jds1+jh:jde1-jh +do j2=jds2,jde2-1 ! interpolate from nodes j2 and j2+1 + do i2=ids2,ide2-1 + do ioff=0,ir-ip + do joff=0,jr-jp + ! compute fine mesh index + i1=ioff+(ih+ids1)+ir*(i2-ids2) + j1=joff+(jh+jds1)+jr*(j2-jds2) + ! weights + tx = (ioff+xoff)/rx + ty = (joff+yoff)/ry + ! interpolation + v1(i1,j1)= & + (1-tx)*(1-ty)*v2(i2,j2) & + + (1-tx)*ty *v2(i2,j2+1) & + + tx*(1-ty)*v2(i2+1,j2) & + + tx*ty *v2(i2+1,j2+1) + !write(*,'(3(a,2i5),a,2f7.4)')'coarse ',i2,j2,' fine ',i1,j1, & + ! ' offset ',ioff,joff,' weights ',tx,ty + !write(*,'(a,4f7.4,a,f7.4)')'in ',v2(i2,j2),v2(i2,j2+1),v2(i2+1,j2), & + ! v2(i2+1,j2+1),' out ',v1(i1,j1) + enddo + enddo + enddo +enddo + +! extend to the boundary strips from the nearest known +do ioff=0,ih-1 ! top and bottom strips + do j2=jds2,jde2-1 + do joff=0,jr-jp + j1=joff+(jh+jds1)+jr*(j2-jds2) + ! weights + ty = (joff+yoff)/ry + ! interpolation + v1(ids1+ioff,j1)=(1-ty)*v2(ids2,j2)+ty*v2(ids2,j2+1) + v1(ide1-ioff,j1)=(1-ty)*v2(ide2,j2)+ty*v2(ide2,j2+1) + enddo + enddo +enddo +do joff=0,jh-1 ! left and right strips + do i2=ids2,ide2-1 + do ioff=0,ir-ip + i1=ioff+(ih+ids1)+ir*(i2-ids2) + ! weights + tx = (ioff+xoff)/rx + ! interpolation + v1(i1,jds1+joff)=(1-tx)*v2(i2,jds2)+tx*v2(i2+1,jds2) + v1(i1,jde1-joff)=(1-tx)*v2(i2,jde2)+tx*v2(i2+1,jde2) + enddo + enddo +enddo +! extend to the 4 corner squares from the nearest known +do ioff=0,ih-1 + do joff=0,jh-1 + v1(ids1+ioff,jds1+joff)=v2(ids2,jds2) + v1(ide1-ioff,jds1+joff)=v2(ide2,jds2) + v1(ids1+ioff,jde1-joff)=v2(ids2,jde2) + v1(ide1-ioff,jde1-joff)=v2(ide2,jde2) + enddo +enddo +end subroutine interpolate_2d_w + +! +!**************** +! + +real function interp(ids,ide,jds,jde,ims,ime,jms,jme,x,y,v) +implicit none +!*** purpose +! general interpolation in a rectangular + +!*** arguments + +integer, intent(in)::ids,ide,jds,jde,ims,ime,jms,jme +real, intent(in)::x,y,v(ims:ime,jms:jme) +! the mesh is cell based so the used dimension of v is ids:ide+1,jds:jde+1 + +!*** calls +intrinsic floor,min,max + +!*** local +integer i,j +real tx,ty + +! executable + +! indices of the lower left corner of the cell in the mesh that contains (x,y) +i = floor(x) +i=max(min(i,ide),ids) +j = floor(y) +j=max(min(j,jde),jds) + +! the leftover +tx = x - real(i) +ty = y - real(j) + +! interpolate the values +interp = & + (1-tx)*(1-ty)*v(i,j) & + + tx*(1-ty) *v(i+1,j) & + + (1-tx)*ty *v(i,j+1) & + + tx*ty *v(i+1,j+1) + +!print *,'x,y=',x,y,'i1,i2=',i1,j1,'tx,ty=',tx,ty,' interp=',interp +end function interp + +subroutine meshdiffc_2d(ids, ide, jds,jde , & ! mesh area used (in cells, end +1) + ims1,ime1,jms1,jme1, & ! memory dimensiuons + dx,dy, & ! mesh spacing + lfn, & ! input + diffCx,diffCy) ! output +implicit none + +!*** purpose +! central differences on a 2d mesh + +!*** arguments + +integer, intent(in)::ids,ide,jds,jde,ims1,ime1,jms1,jme1 +real, intent(in):: dx,dy +real, intent(in), dimension(ims1:ime1,jms1:jme1):: lfn +real, intent(out), dimension(ims1:ime1,jms1:jme1):: diffCx,diffCy + +!*** local +integer:: i,j +real, dimension(ims1:ime1,jms1:jme1):: diffLx,diffRx,diffLy,diffRy + +! get one-sided differences; dumb but had that already... +call meshdiff_2d(ids, ide, jds,jde , & ! mesh area used (in cells, end +1) + ims1,ime1,jms1,jme1, & ! dimensions of lfn + dx,dy, & ! mesh spacing + lfn, & ! input + diffLx,diffRx,diffLy,diffRy) ! output + +! make into central +do j=jds,jde+1 + do i=ids,ide+1 + diffCx(i,j)=0.5*(diffLx(i,j) + diffRx(i,j)) + diffCy(i,j)=0.5*(diffLy(i,j) + diffRy(i,j)) + enddo +enddo +end subroutine meshdiffc_2d + +subroutine meshdiff_2d(ids, ide, jds,jde , & ! mesh area used (in cells, end +1) + ims1,ime1,jms1,jme1, & ! dimensions of lfn + dx,dy, & ! mesh spacing + lfn, & ! input + diffLx,diffRx,diffLy,diffRy) ! output +implicit none + +!*** purpose +! one-sided differences on a 2d mesh + +!*** arguments + +integer, intent(in)::ids,ide,jds,jde,ims1,ime1,jms1,jme1 +real, intent(in):: dx,dy +real, intent(in), dimension(ims1:ime1,jms1:jme1):: lfn +real, intent(out), dimension(ims1:ime1,jms1:jme1):: diffLx,diffRx,diffLy,diffRy + +!*** local +integer:: i,j +real:: tmpx,tmpy + +!*** executable + + call check_mesh_2dim(ids,ide+1,jds,jde+1,ims1,ime1,jms1,jme1) + + ! the bulk of the work + do j=jds,jde + do i=ids,ide + tmpx = (lfn(i+1,j)-lfn(i,j))/dx + diffLx(i+1,j) = tmpx + diffRx(i,j) = tmpx + tmpy = (lfn(i,j+1)-lfn(i,j))/dy + diffLy(i,j+1) = tmpy + diffRy(i,j) = tmpy + enddo + ! missing values - put there the other one + diffLx(ids,j) = diffLx(ids+1,j) + diffRx(ide+1,j)= diffRx(ide,j) + enddo + ! cleanup + ! j=jde+1 from above loop + do i=ids,ide + tmpx = (lfn(i+1,j)-lfn(i,j))/dx + diffLx(i+1,j) = tmpx + diffRx(i,j) = tmpx + enddo + ! i=ide+1 from above loop + do j=jds,jde + tmpy = (lfn(i,j+1)-lfn(i,j))/dy + diffLy(i,j+1) = tmpy + diffRy(i,j) = tmpy + enddo + ! missing values - put there the other one + ! j=jde+1 from above loop, j=jds:jde done before in main bulk loop + diffLx(ids,j) = diffLx(ids+1,j) + diffRx(ide+1,j) = diffRx(ide,j) + do i=ids,ide+1 + diffLy(i,jds) = diffLy(i,jds+1) + diffRy(i,jde+1) = diffRy(i,jde) + enddo + +end subroutine meshdiff_2d + + + + +real pure function sum_2darray( its,ite,jts,jte, & + ims,ime,jms,jme, & + a) +integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme +real, intent(in)::a(ims:ime,jms:jme) +!*** local +integer:: i,j +real:: t +t=0. +do j=jts,jte + do i=its,ite + t=t+a(i,j) + enddo +enddo +sum_2darray = t +end function sum_2darray + +real pure function max_2darray( its,ite,jts,jte, & + ims,ime,jms,jme, & + a) +integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme +real, intent(in)::a(ims:ime,jms:jme) +!*** local +integer:: i,j +real:: t +t=0. +do j=jts,jte + do i=its,ite + t=max(t,a(i,j)) + enddo +enddo +max_2darray = t +end function max_2darray + +subroutine print_2d_stats_vec(ips,ipe,jps,jpe, & + ims,ime,jms,jme, & + ax,ay,name) +implicit none +integer, intent(in)::ips,ipe,jps,jpe,ims,ime,jms,jme +real, intent(in), dimension(ims:ime,jms:jme)::ax,ay +character(len=*),intent(in)::name +integer:: i,j +real:: t +real:: avg_a,max_a,min_a +character(len=25)::id +id=name +call print_2d_stats(ips,ipe,jps,jpe, & + ims,ime,jms,jme, & + ax,id//'/x ') +call print_2d_stats(ips,ipe,jps,jpe, & + ims,ime,jms,jme, & + ay,id//'/y ') +avg_a=0 +max_a=-huge(max_a) +min_a= huge(min_a) +do j=jps,jpe + do i=ips,ipe + t=sqrt(ax(i,j)**2+ay(i,j)**2) + max_a=max(max_a,t) + min_a=min(min_a,t) + avg_a=avg_a+t + enddo +enddo +avg_a = avg_a/((ipe-ips+1)*(jpe-jps+1)) +call print_stat_line(id//'/sz',ips,ipe,jps,jpe,min_a,max_a,avg_a) +end subroutine print_2d_stats_vec + + +subroutine print_stat_line(name,ips,ipe,jps,jpe,min_a,max_a,avg_a) +!*** encapsulate line with statistics +implicit none +!*** arguments +integer, intent(in)::ips,ipe,jps,jpe +character(len=*),intent(in)::name +real,intent(in)::min_a,max_a,avg_a +!*** local +character(len=128)::msg +character(len=24)::id +!*** executable +if(.not.avg_a.eq.avg_a)then + msg='NaN detected in '//trim(name) + call crash(msg) +endif +if(fire_print_msg.eq.0)return +id=name +!$OMP CRITICAL(SFIRE_UTIL_CRIT) +write(msg,'(a,4i4,3g11.3)')id,ips,ipe,jps,jpe,min_a,max_a,avg_a +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) +call message(msg,level=2) +end subroutine print_stat_line + +subroutine print_3d_stats_by_slice(ips,ipe,kps,kpe,jps,jpe, & + ims,ime,kms,kme,jms,jme, & + a,name) +implicit none +integer, intent(in)::ips,ipe,jps,jpe,ims,ime,jms,jme,kms,kme,kps,kpe +real, intent(in)::a(ims:ime,kms:kme,jms:jme) +character(len=*),intent(in)::name +integer::k +character(len=128)::msg +do k=kps,kpe +! print 3d stats for each horizontal slice separately +!$OMP CRITICAL(SFIRE_UTIL_CRIT) + write(msg,'(i2,1x,a)')k,name +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) + call print_3d_stats(ips,ipe,k,k,jps,jpe, & + ims,ime,kms,kme,jms,jme, & + a,msg) +enddo +end subroutine print_3d_stats_by_slice + + +subroutine print_3d_stats(ips,ipe,kps,kpe,jps,jpe, & + ims,ime,kms,kme,jms,jme, & + a,name) +implicit none +integer, intent(in)::ips,ipe,jps,jpe,ims,ime,jms,jme,kms,kme,kps,kpe +real, intent(in)::a(ims:ime,kms:kme,jms:jme) +character(len=*),intent(in)::name +integer:: i,j,k +real:: avg_a,max_a,min_a,t,aa,bb +character(len=128)::msg +! if(fire_print_msg.eq.0)return +! check for nans in any case +bb=0. +do j=jps,jpe + do k=kps,kpe + do i=ips,ipe + bb=bb+a(i,k,j) + enddo + enddo +enddo +if(bb.eq.bb.and.fire_print_msg.eq.0)return +avg_a=0. +max_a=-huge(max_a) +min_a= huge(min_a) +t=huge(t) +do j=jps,jpe + do k=kps,kpe + do i=ips,ipe + aa=a(i,k,j) + if(aa.ne.aa.or..not.aa.le.t.or..not.aa.ge.-t)goto 9 + max_a=max(max_a,aa) + min_a=min(min_a,aa) + avg_a=avg_a+aa + enddo + enddo +enddo +if(bb.ne.bb)goto 10 ! should never happen +if(fire_print_msg.le.0)return +avg_a = avg_a/((ipe-ips+1)*(jpe-jps+1)*(kpe-kps+1)) +call print_stat_line(name,ips,ipe,jps,jpe,min_a,max_a,avg_a) +return +9 continue +!$OMP CRITICAL(SFIRE_UTIL_CRIT) +write(msg,1)name,i,k,j,aa +call message(msg,level=0) +1 format(a30,'(',i6,',',i6,',',i6,') = ',g13.5) +write(msg,2)'patch dimensions ',ips,ipe,kps,kpe,jps,jpe +call message(msg,level=0) +write(msg,2)'memory dimensions',ims,ime,kms,kme,jms,jme +call message(msg,level=0) +2 format(a,6i8) +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) +call print_stat_line(name,ips,ipe,jps,jpe,aa,aa,aa) +if(aa.ne.aa)goto 10 +msg='Invalid floating point number detected in '//name +call crash(msg) +10 msg='NaN detected in '//name +call crash(msg) +end subroutine print_3d_stats + +subroutine print_2d_stats(ips,ipe,jps,jpe, & + ims,ime,jms,jme, & + a,name) +implicit none +integer, intent(in)::ips,ipe,jps,jpe,ims,ime,jms,jme +real, intent(in)::a(ims:ime,jms:jme) +character(len=*),intent(in)::name +!!character(len=128)::msg +!if(fire_print_msg.eq.0)return +call print_3d_stats(ips,ipe,1,1,jps,jpe, & + ims,ime,1,1,jms,jme, & + a,name) +!!write(msg,'(2a,z16)')name,' address =',loc(a) +!!call message(msg) +end subroutine print_2d_stats + +real pure function avg_2darray( its,ite,jts,jte, & + ims,ime,jms,jme, & + a) +integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme +real, intent(in)::a(ims:ime,jms:jme) +!*** local +!*** executable +avg_2darray = sum_2darray( its,ite,jts,jte, & + ims,ime,jms,jme, & + a)/((ite-its+1)*(jte-jts+1)) +end function avg_2darray + +real pure function avg_2darray_vec( its,ite,jts,jte, & + ims,ime,jms,jme, & + ax,ay) +integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme +real, intent(in), dimension(ims:ime,jms:jme):: ax,ay +!*** local +integer:: i,j +real:: t +t=0. +do j=jts,jte + do i=its,ite + t=t+sqrt(ax(i,j)**2+ay(i,j)**2) + enddo +enddo +t = t/((ite-its+1)*(jte-jts+1)) +avg_2darray_vec = t +end function avg_2darray_vec + + +subroutine print_array(its,ite,jts,jte, & + ims,ime,jms,jme, & + a,name,id) +! debug +!*** arguments +integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme,id +real, intent(in), dimension(ims:ime,jms:jme):: a +character(len=*),intent(in)::name +!**** +integer i,j +character(len=128)::msg +!**** +!$OMP CRITICAL(SFIRE_UTIL_CRIT) +write(msg,*)name,' start ',id,' dim ',its,ite,jts,jte +call message(msg) +do j=jts,jte + do i=its,ite + write(msg,*)i,j,a(i,j) + call message(msg) + enddo +enddo +write(msg,*)name,' end ',id +call message(msg) +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) +end subroutine print_array + +subroutine write_array_m(its,ite,jts,jte, & + ims,ime,jms,jme, & + a,name,id) +! debug +!*** arguments +integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme,id +real, intent(in), dimension(ims:ime,jms:jme):: a +character(len=*),intent(in)::name +!**** +call write_array_m3(its,ite,1,1,jts,jte, & + ims,ime,1,1,jms,jme, & + a,name,id) +end subroutine write_array_m + + +subroutine write_array_m3(its,ite,kts,kte,jts,jte, & + ims,ime,kms,kme,jms,jme, & + a,name,id) +use module_dm + +implicit none +! debug +!*** arguments +integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme,kts,kte,kms,kme,id +real, intent(in), dimension(ims:ime,kms:kme,jms:jme):: a +character(len=*),intent(in)::name +!**** +integer i,j,k,iu,ilen,myproc,nprocs +logical op +character(len=128)::fname,msg +!**** +if(fire_print_file.eq.0.or.id.le.0)return +call check_mesh_2dim(its,ite,jts,jte,ims,ime,jms,jme) +call wrf_get_nproc (nprocs) +call wrf_get_myproc(myproc) + +!$OMP CRITICAL(SFIRE_UTIL_CRIT) +if(nprocs.eq.1)then + write(fname,3)name,'_',id,'.txt' +else + write(fname,4)name,'_',id,'.',myproc,'.txt' +endif + +iu=0 +do i=6,99 + inquire(unit=i,opened=op) + if(.not.op.and.iu.le.0)iu=i +enddo +if(iu.gt.0)open(iu,file=trim(fname),form='formatted',status='unknown') + +if(iu.le.0)call crash('write_array_m: cannot find available fortran unit') + +write(iu,1)real(its) +write(iu,1)real(ite) +write(iu,1)real(jts) +write(iu,1)real(jte) +write(iu,1)real(kts) +write(iu,1)real(kte) +write(iu,1)(((a(i,k,j),i=its,ite),j=jts,jte),k=kts,kte) +close(iu) +write(msg,2)name,'(',its,':',ite,',',jts,':',jte,',', & +kts,':',kte,') -> ',trim(fname) +!$OMP END CRITICAL(SFIRE_UTIL_CRIT) +call message(msg) +return + +1 format(e20.12) +2 format(2a,3(i5,a,i5,a),2a) +3 format(a,a,i8.8,a) +4 format(a,a,i8.8,a,i4.4,a) + + +end subroutine write_array_m3 + +! +!*** +! + +subroutine read_array_2d_real(filename,a,its,ite,jts,jte,ims,ime,jms,jme) +use module_dm +#ifdef _OPENMP +use OMP_LIB +#endif +implicit none +!*** purpose: read a 2D array from a text file +! file format: line 1: array dimensions ni,nj +! following lines: one row of a at a time +! each row may be split between several lines +!*** arguments +integer, intent(in)::its,ite,jts,jte,ims,ime,jms,jme +real, intent(out), dimension(ims:ime,jms:jme):: a +character(len=*),intent(in)::filename +!*** local +integer i,j,ni,nj,mi,mj,nprocs,myproc,mythread,iu +logical op +character(len=128)::fname,msg +!*** executable + +call wrf_get_nproc (nprocs) +call wrf_get_myproc( myproc ) +mythread=0 +#ifdef _OPENMP + mythread=omp_get_thread_num() +#endif +if(nprocs.ne.1.or.myproc.ne.0.or.mythread.ne.0) & + call crash('read_array_2d: parallel execution not supported') + +! print line +mi=ite-its+1 +mj=jte-jts+1 +write(msg,2)'reading array size ',mi,mj,' from file ',trim(filename) +2 format(a,2i6,2a) +call message(msg,level=1) + +! check array index overflow +call check_mesh_2dim(its,ite,jts,jte,ims,ime,jms,jme) + +! find available unit +iu=0 +do i=11,99 + inquire(unit=i,opened=op) + if(.not.op.and.iu.le.0)iu=i +enddo +if(iu.le.0)call crash('read_array_2d: cannot find available fortran unit') + +if(iu.gt.0)open(iu,file=filename,form='formatted',status='old',err=9) +rewind(iu,err=9) + +read(iu,*,err=10)ni,nj +if(ni.ne.mi.or.nj.ne.mj)then + write(msg,'(a,2i6,a,2i6)')'Array dimensions',ni,nj,' in the input file should be ',mi,mj + call message(msg,level=0) + goto 10 +endif +do i=its,ite + read(iu,*,err=10)(a(i,j),j=jts,jte) +enddo +close(iu,err=11) +call print_2d_stats(its,ite,jts,jte, & + ims,ime,jms,jme, & + a,filename) +write(6,*)its,jts,a(its,jts),loc(a(its,jts)) +return + +9 msg='Error opening file '//trim(filename) +call crash(msg) +10 msg='Error reading file '//trim(filename) +call crash(msg) +11 msg='Error closing file '//trim(filename) +call crash(msg) +end subroutine read_array_2d_real + +! +!*** +! + +! general conditional expression +pure integer function ifval(l,i,j) +implicit none +logical, intent(in)::l +integer, intent(in)::i,j +if(l)then + ifval=i +else + ifval=j +endif +end function ifval + +! function to go beyond domain boundary if tile is next to it +pure integer function snode(t,d,i) +implicit none +integer, intent(in)::t,d,i +if(t.ne.d)then + snode=t +else + snode=t+i +endif +end function snode + +subroutine print_chsum( id, & + ims,ime,kms,kme,jms,jme, & ! memory dims + ids,ide,kds,kde,jds,jde, & ! domain dims + ips,ipe,kps,kpe,jps,jpe, & ! patch or tile dims + istag,kstag,jstag, & + a,name) + +#ifdef DM_PARALLEL + USE module_dm , only : wrf_dm_bxor_integer +#endif + +integer, intent(in):: id, & + ims,ime,kms,kme,jms,jme, & ! memory dims + ids,ide,kds,kde,jds,jde, & ! domain dims + ips,ipe,kps,kpe,jps,jpe, & ! patch dims + istag,kstag,jstag +real, intent(in),dimension(ims:ime,kms:kme,jms:jme)::a +character(len=*)::name + +!$ external, logical:: omp_in_parallel +!$ external, integer:: omp_get_thread_num + +!*** local +integer::lsum +integer::i,j,k,n,ipe1,jpe1,kpe1,iel,thread,is,js,ks +integer, save::psum,gsum +real::rel +equivalence(rel,iel) +character(len=256)msg + +if(fire_print_msg.le.0)return + +ipe1=ifval(ipe.eq.ide.and.istag.ne.0,ipe+1,ipe) +kpe1=ifval(kpe.eq.kde.and.kstag.ne.0,kpe+1,kpe) +jpe1=ifval(jpe.eq.jde.and.jstag.ne.0,jpe+1,jpe) +is=ifval(istag.ne.0,1,0) +ks=ifval(kstag.ne.0,1,0) +js=ifval(jstag.ne.0,1,0) + +lsum=0 +do j=jps,jpe1 + do k=kps,kpe1 + do i=ips,ipe1 + rel=a(i,k,j) + lsum=ieor(lsum,iel) + enddo + enddo +enddo + +! get process sum over all threads +thread=0 +!$ thread=omp_get_thread_num() +if(thread.eq.0)psum=0 +!$OMP BARRIER +!$OMP CRITICAL(CHSUM) +psum=ieor(psum,lsum) +!$OMP END CRITICAL(CHSUM) +!$OMP BARRIER + +! get global sum over all processes +if(thread.eq.0)then +#ifdef DM_PARALLEL + gsum = wrf_dm_bxor_integer ( psum ) +#else + gsum = psum +#endif + write(msg,1)id,name,ids,ide+is,kds,kde+ks,jds,jde+js,gsum +1 format(i6,1x,a10,' dims',6i5,' chsum ',z8.8) + call message(msg) +endif + +end subroutine print_chsum + + +real function fun_real(fun, & + ims,ime,kms,kme,jms,jme, & ! memory dims + ids,ide,kds,kde,jds,jde, & ! domain dims + ips,ipe,kps,kpe,jps,jpe, & ! patch or tile dims + istag,kstag,jstag, & ! staggering + a,b) + +#ifdef DM_PARALLEL + USE module_dm , only : wrf_dm_sum_real , wrf_dm_max_real +#endif + +integer, intent(in):: fun, & + ims,ime,kms,kme,jms,jme, & ! memory dims + ids,ide,kds,kde,jds,jde, & ! domain dims + ips,ipe,kps,kpe,jps,jpe, & ! patch dims + istag,kstag,jstag ! staggering +real, intent(in),dimension(ims:ime,kms:kme,jms:jme)::a,b + +!*** local +real::lsum,void +integer::i,j,k,n,ipe1,jpe1,kpe1,iel,thread,is,js,ks +real, save::psum,gsum +real::rel +logical:: dosum,domax,domin +character(len=256)msg + +ipe1=ifval(ipe.eq.ide.and.istag.ne.0,ipe+1,ipe) +kpe1=ifval(kpe.eq.kde.and.kstag.ne.0,kpe+1,kpe) +jpe1=ifval(jpe.eq.jde.and.jstag.ne.0,jpe+1,jpe) +is=ifval(istag.ne.0,1,0) +ks=ifval(kstag.ne.0,1,0) +js=ifval(jstag.ne.0,1,0) + +if(fun.eq.REAL_SUM)then + void=0. + lsum=void + do j=jps,jpe1 + do k=kps,kpe1 + do i=ips,ipe1 + lsum=lsum+a(i,k,j) + enddo + enddo + enddo +elseif(fun.eq.RNRM_SUM)then + void=0. + lsum=void + do j=jps,jpe1 + do k=kps,kpe1 + do i=ips,ipe1 + lsum=lsum+sqrt(a(i,k,j)*a(i,k,j)+b(i,k,j)*b(i,k,j)) + enddo + enddo + enddo +elseif(fun.eq.REAL_MAX)then + void=-huge(lsum) + lsum=void + do j=jps,jpe1 + do k=kps,kpe1 + do i=ips,ipe1 + lsum=max(lsum,a(i,k,j)) + enddo + enddo + enddo +elseif(fun.eq.REAL_AMAX)then +! TMG +print*, 'Checking U wind: ', lsum + void=-huge(lsum) + lsum=void + do j=jps,jpe1 + do k=kps,kpe1 + do i=ips,ipe1 + !print*, 'In fun_real j, k, i ', j, k, i, a(i,k,j) + lsum=max(lsum,abs(a(i,k,j))) + enddo + enddo + enddo +! TMG +!print*, 'fun_real, real_amax after: ', lsum +elseif(fun.eq.REAL_MIN)then + void=huge(lsum) + lsum=void + do j=jps,jpe1 + do k=kps,kpe1 + do i=ips,ipe1 + lsum=min(lsum,a(i,k,j)) + enddo + enddo + enddo +elseif(fun.eq.RNRM_MAX)then + void=0. + lsum=void + do j=jps,jpe1 + do k=kps,kpe1 + do i=ips,ipe1 + lsum=max(lsum,sqrt(a(i,k,j)*a(i,k,j)+b(i,k,j)*b(i,k,j))) + enddo + enddo + enddo +else + call crash('fun_real: bad fun') +endif + +if(lsum.ne.lsum)call message('fun_real: WARNING: NaN detected') + +dosum=fun.eq.REAL_SUM.or.fun.eq.RNRM_SUM +domax=fun.eq.REAL_MAX.or.fun.eq.REAL_AMAX.or.fun.eq.RNRM_MAX +domin=fun.eq.REAL_MIN + +! get process sum over all threads +!$OMP SINGLE +! only one thread should write to shared variable +psum=void +!$OMP END SINGLE +!$OMP BARRIER +! now all threads know psum + +!$OMP CRITICAL(RDSUM) +! each thread adds its own lsum +if(dosum)psum=psum+lsum +if(domax)psum=max(psum,lsum) +if(domin)psum=min(psum,lsum) +!$OMP END CRITICAL(RDSUM) + +! wait till all theads are done +!$OMP BARRIER + +! get global sum over all processes +!$OMP SINGLE +! only one threads will do the mpi communication +#ifdef DM_PARALLEL + if(dosum) gsum = wrf_dm_sum_real ( psum ) + if(domax) gsum = wrf_dm_max_real ( psum ) +#else + gsum = psum +#endif +if(gsum.ne.gsum)call message('fun_real: WARNING: NaN detected') +!$OMP END SINGLE + +!$OMP BARRIER +! now gsum is known to all threads + +fun_real=gsum + +end function fun_real + +subroutine sfire_debug_hook(fire_debug_hook_sec) +integer, intent(in)::fire_debug_hook_sec +#define DEBUG_HOOK +#ifdef DEBUG_HOOK +integer,save:: go=-1 +external:: wrf_dm_bcast_integer +if(go<0)then + go = fire_debug_hook_sec +endif +do while (go .ne. 0) + call sleep(go) + ! set go=0 in debugger to continue + call wrf_dm_bcast_integer(abs(go),1) +enddo +#endif +end subroutine sfire_debug_hook + +end module module_fr_sfire_util + +! this subroutine is outside of any module and f77 style because some debuggers +! notably gdb are terrible with fortran90 + + + From 5ab9c49929de6d5e2918f842d9c18d4d6fa21ed6 Mon Sep 17 00:00:00 2001 From: "Theodore M. Giannaros" <37264065+tmgiannaros@users.noreply.github.com> Date: Thu, 22 Mar 2018 22:07:12 +0200 Subject: [PATCH 11/15] Update Makefile Modifications to instruct the compilation of SFIRE instead of the default FIRE. --- wrfv2_fire/phys/Makefile | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/wrfv2_fire/phys/Makefile b/wrfv2_fire/phys/Makefile index a629af7a..912f387b 100644 --- a/wrfv2_fire/phys/Makefile +++ b/wrfv2_fire/phys/Makefile @@ -176,13 +176,13 @@ MODULES = \ module_diagnostics_driver.o FIRE_MODULES = \ - module_fr_fire_driver.o \ - module_fr_fire_driver_wrf.o \ - module_fr_fire_atm.o \ - module_fr_fire_model.o \ - module_fr_fire_core.o \ - module_fr_fire_phys.o \ - module_fr_fire_util.o + module_fr_sfire_driver.o \ + module_fr_sfire_driver_wrf.o \ + module_fr_sfire_atm.o \ + module_fr_sfire_model.o \ + module_fr_sfire_core.o \ + module_fr_sfire_phys.o \ + module_fr_sfire_util.o DIAGNOSTIC_MODULES_EM = \ module_diag_afwa.o \ From 318ebc964f789bd19bfc160517f0408f4d62073e Mon Sep 17 00:00:00 2001 From: "Theodore M. Giannaros" <37264065+tmgiannaros@users.noreply.github.com> Date: Thu, 22 Mar 2018 22:10:17 +0200 Subject: [PATCH 12/15] Update depend.common Modifications to instruct compilation of SFIRE (dependencies). --- wrfv2_fire/main/depend.common | 39 +++++++++++++++++------------------ 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/wrfv2_fire/main/depend.common b/wrfv2_fire/main/depend.common index 8d0aa812..7cfb2d1c 100644 --- a/wrfv2_fire/main/depend.common +++ b/wrfv2_fire/main/depend.common @@ -797,36 +797,36 @@ module_sf_lake.o : \ ../share/module_model_constants.o -module_fr_fire_driver.o: \ +module_fr_sfire_driver.o: \ ../share/module_model_constants.o \ ../frame/module_comm_dm.o \ - module_fr_fire_phys.o \ - module_fr_fire_model.o \ - module_fr_fire_util.o + module_fr_sfire_phys.o \ + module_fr_sfire_model.o \ + module_fr_sfire_util.o -module_fr_fire_driver_wrf.o: \ +module_fr_sfire_driver_wrf.o: \ ../share/module_model_constants.o \ ../frame/module_comm_dm.o \ - module_fr_fire_driver.o \ - module_fr_fire_atm.o \ - module_fr_fire_util.o + module_fr_sfire_driver.o \ + module_fr_sfire_atm.o \ + module_fr_sfire_util.o -module_fr_fire_atm.o: \ +module_fr_sfire_atm.o: \ ../share/module_model_constants.o \ - module_fr_fire_util.o + module_fr_sfire_util.o -module_fr_fire_model.o: \ - module_fr_fire_core.o \ - module_fr_fire_phys.o \ - module_fr_fire_util.o +module_fr_sfire_model.o: \ + module_fr_sfire_core.o \ + module_fr_sfire_phys.o \ + module_fr_sfire_util.o -module_fr_fire_core.o: \ - module_fr_fire_util.o \ - module_fr_fire_phys.o +module_fr_sfire_core.o: \ + module_fr_sfire_util.o \ + module_fr_sfire_phys.o -module_fr_fire_phys.o: \ +module_fr_sfire_phys.o: \ ../share/module_model_constants.o \ - module_fr_fire_util.o + module_fr_sfire_util.o module_fire_debug_output.o: \ ../frame/module_domain.o \ @@ -1258,4 +1258,3 @@ module_wrf_top.o: ../frame/module_machine.o \ $(ESMF_MOD_DEPENDENCE) # End of DEPENDENCIES for main - From 24c14990899155ae84f053124cc2b2b71619a14c Mon Sep 17 00:00:00 2001 From: "Theodore M. Giannaros" Date: Thu, 22 Mar 2018 22:39:08 +0200 Subject: [PATCH 13/15] WPSV3.9.1 forked from NCAR/WPS --- .DS_Store | Bin 0 -> 10244 bytes WPS/README | 241 + WPS/arch/Config.pl | 322 ++ WPS/arch/configure.defaults | 789 ++++ WPS/arch/fixlinks | 9 + WPS/arch/postamble | 27 + WPS/arch/preamble | 55 + WPS/arch/sourceme_windows.bash | 4 + WPS/arch/sourceme_windows.csh | 4 + WPS/arch/zaplinks | 7 + WPS/clean | 73 + WPS/compile | 164 + WPS/configure | 394 ++ WPS/geogrid/GEOGRID.TBL | 1 + WPS/geogrid/GEOGRID.TBL.ARW | 402 ++ WPS/geogrid/GEOGRID.TBL.ARW.noahmp | 475 ++ WPS/geogrid/GEOGRID.TBL.ARW_CHEM | 402 ++ WPS/geogrid/GEOGRID.TBL.FIRE | 388 ++ WPS/geogrid/GEOGRID.TBL.NMM | 228 + WPS/geogrid/Makefile | 56 + WPS/geogrid/gribmap.txt | 1542 +++++++ WPS/geogrid/src/.gitignore | 3 + WPS/geogrid/src/Makefile | 69 + WPS/geogrid/src/bitarray_module.F | 199 + WPS/geogrid/src/cio.c | 92 + WPS/geogrid/src/constants_module.F | 32 + WPS/geogrid/src/geogrid.F | 148 + WPS/geogrid/src/gridinfo_module.F | 596 +++ WPS/geogrid/src/hash_module.F | 159 + WPS/geogrid/src/interp_module.F | 1376 ++++++ WPS/geogrid/src/list_module.F | 352 ++ WPS/geogrid/src/llxy_module.F | 889 ++++ WPS/geogrid/src/misc_definitions_module.F | 49 + WPS/geogrid/src/module_debug.F | 331 ++ WPS/geogrid/src/module_map_utils.F | 2214 +++++++++ WPS/geogrid/src/module_stringutil.F | 1 + WPS/geogrid/src/output_module.F | 1674 +++++++ WPS/geogrid/src/parallel_module.F | 1045 +++++ WPS/geogrid/src/proc_point_module.F | 939 ++++ WPS/geogrid/src/process_tile_module.F | 2158 +++++++++ WPS/geogrid/src/queue_module.F | 237 + WPS/geogrid/src/read_geogrid.c | 140 + WPS/geogrid/src/smooth_module.F | 587 +++ WPS/geogrid/src/source_data_module.F | 3738 +++++++++++++++ WPS/geogrid/src/wrf_debug.F | 55 + WPS/geogrid/src/write_geogrid.c | 122 + WPS/geogrid/util/ij_to_latlon.F | 81 + WPS/geogrid/util/latlon_to_ij.F | 148 + WPS/geogrid/util/plot_source/a.c | 25 + WPS/geogrid/util/plot_source/plotter.F | 101 + WPS/geogrid/util/plotgrid/Makefile | 40 + WPS/geogrid/util/plotgrid/namelist.wps | 51 + WPS/geogrid/util/plotgrid/src/Makefile | 41 + WPS/geogrid/util/plotgrid/src/cio.c | 1 + .../util/plotgrid/src/gridinfo_module.F | 1 + WPS/geogrid/util/plotgrid/src/input_module.F | 1 + .../plotgrid/src/misc_definitions_module.F | 1 + WPS/geogrid/util/plotgrid/src/module_debug.F | 1 + .../util/plotgrid/src/parallel_module.F | 1 + WPS/geogrid/util/plotgrid/src/plotgrid.F | 406 ++ WPS/geogrid/util/plotgrid/src/queue_module.F | 1 + WPS/geogrid/util/plotgrid/src/wrf_debug.F | 1 + WPS/geogrid/util/plotter.F | 173 + WPS/geogrid/util/retile-cat.c | 658 +++ WPS/geogrid/util/retile-cont.c | 660 +++ WPS/geogrid/util/retile.c | 630 +++ WPS/link_grib.csh | 62 + WPS/metgrid/METGRID.TBL | 1 + WPS/metgrid/METGRID.TBL.AFWA | 772 ++++ WPS/metgrid/METGRID.TBL.ARW | 1036 +++++ WPS/metgrid/METGRID.TBL.ARW.rap | 717 +++ WPS/metgrid/METGRID.TBL.ARW.ruc | 524 +++ WPS/metgrid/METGRID.TBL.NMM | 490 ++ WPS/metgrid/METGRID.TBL.NMM.rap | 525 +++ WPS/metgrid/Makefile | 56 + WPS/metgrid/gribmap.txt | 1542 +++++++ WPS/metgrid/src/.gitignore | 3 + WPS/metgrid/src/Makefile | 89 + WPS/metgrid/src/bitarray_module.F | 1 + WPS/metgrid/src/cio.c | 1 + WPS/metgrid/src/constants_module.F | 1 + WPS/metgrid/src/datatype_module.F | 334 ++ WPS/metgrid/src/gridinfo_module.F | 362 ++ WPS/metgrid/src/input_module.F | 861 ++++ WPS/metgrid/src/interp_module.F | 1 + WPS/metgrid/src/interp_option_module.F | 859 ++++ WPS/metgrid/src/list_module.F | 1 + WPS/metgrid/src/llxy_module.F | 1 + WPS/metgrid/src/met_data_module.F | 20 + WPS/metgrid/src/metgrid.F | 101 + WPS/metgrid/src/minheap_module.F | 207 + WPS/metgrid/src/misc_definitions_module.F | 1 + WPS/metgrid/src/module_date_pack.F | 643 +++ WPS/metgrid/src/module_debug.F | 1 + WPS/metgrid/src/module_map_utils.F | 1 + WPS/metgrid/src/module_mergesort.F | 70 + WPS/metgrid/src/module_stringutil.F | 1 + WPS/metgrid/src/mpas_mesh.F | 310 ++ WPS/metgrid/src/output_module.F | 1 + WPS/metgrid/src/parallel_module.F | 1 + WPS/metgrid/src/process_domain_module.F | 3719 +++++++++++++++ WPS/metgrid/src/queue_module.F | 1 + WPS/metgrid/src/read_met_module.F | 414 ++ WPS/metgrid/src/remapper.F | 1341 ++++++ WPS/metgrid/src/rotate_winds_module.F | 595 +++ WPS/metgrid/src/scan_input.F | 604 +++ WPS/metgrid/src/storage_module.F | 1125 +++++ WPS/metgrid/src/target_mesh.F | 214 + WPS/metgrid/src/wrf_debug.F | 1 + WPS/metgrid/src/write_met_module.F | 408 ++ WPS/namelist.wps | 52 + WPS/namelist.wps.all_options | 103 + WPS/namelist.wps.fire | 56 + WPS/namelist.wps.global | 66 + WPS/namelist.wps.nmm | 34 + WPS/ungrib/.gitignore | 2 + WPS/ungrib/Makefile | 50 + WPS/ungrib/README_LIBS | 24 + WPS/ungrib/Variable_Tables/README | 54 + WPS/ungrib/Variable_Tables/Vtable.AFWAICE | 10 + WPS/ungrib/Variable_Tables/Vtable.AGRMETSNOW | 6 + WPS/ungrib/Variable_Tables/Vtable.AGRMETSOIL | 22 + WPS/ungrib/Variable_Tables/Vtable.AGRMETSOIL2 | 25 + WPS/ungrib/Variable_Tables/Vtable.AGRWRF | 22 + WPS/ungrib/Variable_Tables/Vtable.ARW.UPP | 47 + WPS/ungrib/Variable_Tables/Vtable.ARWp.UPP | 42 + WPS/ungrib/Variable_Tables/Vtable.AVN0P5WRF | 21 + WPS/ungrib/Variable_Tables/Vtable.AWIP | 30 + WPS/ungrib/Variable_Tables/Vtable.CFSR2_web | 29 + WPS/ungrib/Variable_Tables/Vtable.CFSR_mean | 37 + .../Variable_Tables/Vtable.CFSR_press_pgbh06 | 10 + .../Variable_Tables/Vtable.CFSR_sfc_flxf06 | 23 + WPS/ungrib/Variable_Tables/Vtable.ECMWF | 42 + WPS/ungrib/Variable_Tables/Vtable.ECMWF_sigma | 41 + .../Variable_Tables/Vtable.ERA-interim.ml | 42 + .../Variable_Tables/Vtable.ERA-interim.pl | 45 + WPS/ungrib/Variable_Tables/Vtable.GFDL | 19 + WPS/ungrib/Variable_Tables/Vtable.GFS | 70 + WPS/ungrib/Variable_Tables/Vtable.GFSENS | 47 + WPS/ungrib/Variable_Tables/Vtable.GODAS | 15 + WPS/ungrib/Variable_Tables/Vtable.GSM | 33 + WPS/ungrib/Variable_Tables/Vtable.JMAGSM | 18 + WPS/ungrib/Variable_Tables/Vtable.NAM | 50 + WPS/ungrib/Variable_Tables/Vtable.NARR | 52 + WPS/ungrib/Variable_Tables/Vtable.NCEP2 | 38 + WPS/ungrib/Variable_Tables/Vtable.NNRP | 26 + WPS/ungrib/Variable_Tables/Vtable.NOGAPS | 17 + .../Vtable.NOGAPS_needs_GFS_soil | 19 + WPS/ungrib/Variable_Tables/Vtable.NavySST | 7 + .../Variable_Tables/Vtable.RAP.hybrid.ncep | 66 + .../Variable_Tables/Vtable.RAP.pressure.ncep | 34 + .../Variable_Tables/Vtable.RAP.sigma.gsd | 58 + WPS/ungrib/Variable_Tables/Vtable.RUCb | 56 + WPS/ungrib/Variable_Tables/Vtable.RUCp | 22 + WPS/ungrib/Variable_Tables/Vtable.SREF | 41 + WPS/ungrib/Variable_Tables/Vtable.SST | 5 + WPS/ungrib/Variable_Tables/Vtable.TCRP | 44 + .../Variable_Tables/Vtable.UKMO_ENDGame | 33 + .../Variable_Tables/Vtable.UKMO_LANDSEA | 5 + .../Variable_Tables/Vtable.UKMO_no_heights | 28 + WPS/ungrib/Variable_Tables/Vtable.raphrrr | 52 + WPS/ungrib/src/.gitignore | 4 + WPS/ungrib/src/Makefile | 102 + WPS/ungrib/src/build_hdate.F | 42 + WPS/ungrib/src/cio.c | 265 ++ WPS/ungrib/src/datint.F | 308 ++ WPS/ungrib/src/debug_cio.c | 1 + WPS/ungrib/src/file_delete.F | 67 + WPS/ungrib/src/filelist.F | 4 + WPS/ungrib/src/g1print.F | 660 +++ WPS/ungrib/src/g2print.F | 1241 +++++ WPS/ungrib/src/gbytesys.F | 493 ++ WPS/ungrib/src/geth_idts.F | 316 ++ WPS/ungrib/src/geth_newdate.F | 259 ++ WPS/ungrib/src/gribcode.F | 2136 +++++++++ WPS/ungrib/src/gridinfo.F | 42 + WPS/ungrib/src/misc_definitions_module.F | 1 + WPS/ungrib/src/module_datarray.F | 13 + WPS/ungrib/src/module_debug.F | 1 + WPS/ungrib/src/module_stringutil.F | 115 + WPS/ungrib/src/new_storage.F | 496 ++ WPS/ungrib/src/ngl/Makefile | 18 + WPS/ungrib/src/ngl/g2/CHANGES | 133 + WPS/ungrib/src/ngl/g2/Makefile | 75 + WPS/ungrib/src/ngl/g2/README | 84 + WPS/ungrib/src/ngl/g2/addfield.F | 482 ++ WPS/ungrib/src/ngl/g2/addgrid.f | 232 + WPS/ungrib/src/ngl/g2/addlocal.f | 138 + WPS/ungrib/src/ngl/g2/cmplxpack.f | 76 + WPS/ungrib/src/ngl/g2/compack.f | 469 ++ WPS/ungrib/src/ngl/g2/comunpack.f | 325 ++ WPS/ungrib/src/ngl/g2/dec_jpeg2000.c | 152 + WPS/ungrib/src/ngl/g2/dec_png.c | 157 + WPS/ungrib/src/ngl/g2/drstemplates.f | 277 ++ WPS/ungrib/src/ngl/g2/enc_jpeg2000.c | 195 + WPS/ungrib/src/ngl/g2/enc_png.c | 145 + WPS/ungrib/src/ngl/g2/g2grids.f | 320 ++ WPS/ungrib/src/ngl/g2/gb_info.f | 194 + WPS/ungrib/src/ngl/g2/gbytesc.f | 125 + WPS/ungrib/src/ngl/g2/gdt2gds.f | 389 ++ WPS/ungrib/src/ngl/g2/getdim.f | 102 + WPS/ungrib/src/ngl/g2/getfield.f | 829 ++++ WPS/ungrib/src/ngl/g2/getg2i.f | 93 + WPS/ungrib/src/ngl/g2/getg2ir.f | 138 + WPS/ungrib/src/ngl/g2/getgb2.f | 338 ++ WPS/ungrib/src/ngl/g2/getgb2l.f | 234 + WPS/ungrib/src/ngl/g2/getgb2p.f | 223 + WPS/ungrib/src/ngl/g2/getgb2r.f | 305 ++ WPS/ungrib/src/ngl/g2/getgb2rp.f | 189 + WPS/ungrib/src/ngl/g2/getgb2s.f | 491 ++ WPS/ungrib/src/ngl/g2/getidx.f | 156 + WPS/ungrib/src/ngl/g2/getlocal.f | 168 + WPS/ungrib/src/ngl/g2/getpoly.f | 80 + WPS/ungrib/src/ngl/g2/gettemplates.f | 244 + WPS/ungrib/src/ngl/g2/gf_free.f | 202 + WPS/ungrib/src/ngl/g2/gf_getfld.f | 603 +++ WPS/ungrib/src/ngl/g2/gf_unpack1.f | 93 + WPS/ungrib/src/ngl/g2/gf_unpack2.f | 72 + WPS/ungrib/src/ngl/g2/gf_unpack3.f | 189 + WPS/ungrib/src/ngl/g2/gf_unpack4.f | 159 + WPS/ungrib/src/ngl/g2/gf_unpack5.f | 134 + WPS/ungrib/src/ngl/g2/gf_unpack6.f | 88 + WPS/ungrib/src/ngl/g2/gf_unpack7.F | 124 + WPS/ungrib/src/ngl/g2/grib2.doc | 1220 +++++ WPS/ungrib/src/ngl/g2/gribcreate.f | 123 + WPS/ungrib/src/ngl/g2/gribend.f | 126 + WPS/ungrib/src/ngl/g2/gribinfo.f | 243 + WPS/ungrib/src/ngl/g2/gribmod.f | 199 + WPS/ungrib/src/ngl/g2/gridtemplates.f | 488 ++ WPS/ungrib/src/ngl/g2/intmath.f | 260 ++ WPS/ungrib/src/ngl/g2/ixgb2.f | 206 + WPS/ungrib/src/ngl/g2/jpcpack.F | 180 + WPS/ungrib/src/ngl/g2/jpcunpack.F | 68 + WPS/ungrib/src/ngl/g2/makefile_d | 125 + WPS/ungrib/src/ngl/g2/misspack.f | 533 +++ WPS/ungrib/src/ngl/g2/mkieee.f | 117 + WPS/ungrib/src/ngl/g2/mova2i.c | 47 + WPS/ungrib/src/ngl/g2/pack_gp.f | 1179 +++++ WPS/ungrib/src/ngl/g2/params.f | 1019 +++++ WPS/ungrib/src/ngl/g2/params_ecmwf.f | 341 ++ WPS/ungrib/src/ngl/g2/pdstemplates.f | 757 +++ WPS/ungrib/src/ngl/g2/pngpack.F | 163 + WPS/ungrib/src/ngl/g2/pngunpack.F | 72 + WPS/ungrib/src/ngl/g2/putgb2.f | 284 ++ WPS/ungrib/src/ngl/g2/rdieee.f | 80 + WPS/ungrib/src/ngl/g2/realloc.f | 125 + WPS/ungrib/src/ngl/g2/reduce.f | 343 ++ WPS/ungrib/src/ngl/g2/simpack.f | 191 + WPS/ungrib/src/ngl/g2/simunpack.f | 65 + WPS/ungrib/src/ngl/g2/skgb.f | 79 + WPS/ungrib/src/ngl/g2/specpack.f | 124 + WPS/ungrib/src/ngl/g2/specunpack.f | 107 + WPS/ungrib/src/ngl/w3/CHANGES | 40 + WPS/ungrib/src/ngl/w3/Makefile | 49 + WPS/ungrib/src/ngl/w3/README | 21 + WPS/ungrib/src/ngl/w3/bacio.v1.3.c | 571 +++ WPS/ungrib/src/ngl/w3/bacio_module.f | 23 + WPS/ungrib/src/ngl/w3/baciof.f | 524 +++ WPS/ungrib/src/ngl/w3/baciof.h | 11 + WPS/ungrib/src/ngl/w3/clib.h | 27 + WPS/ungrib/src/ngl/w3/errexit.c | 12 + WPS/ungrib/src/ngl/w3/errmsg.f | 29 + WPS/ungrib/src/ngl/w3/fparsei.f | 39 + WPS/ungrib/src/ngl/w3/fparser.f | 39 + WPS/ungrib/src/ngl/w3/gbytes.f | 144 + WPS/ungrib/src/ngl/w3/gbytes_char.f | 127 + WPS/ungrib/src/ngl/w3/getbit.f | 87 + WPS/ungrib/src/ngl/w3/getgb.f | 213 + WPS/ungrib/src/ngl/w3/getgb1r.f | 75 + WPS/ungrib/src/ngl/w3/getgb1re.f | 81 + WPS/ungrib/src/ngl/w3/getgb1s.f | 184 + WPS/ungrib/src/ngl/w3/getgbe.f | 223 + WPS/ungrib/src/ngl/w3/getgbeh.f | 215 + WPS/ungrib/src/ngl/w3/getgbem.f | 275 ++ WPS/ungrib/src/ngl/w3/getgbemh.f | 265 ++ WPS/ungrib/src/ngl/w3/getgbemp.f | 271 ++ WPS/ungrib/src/ngl/w3/getgbens.f | 207 + WPS/ungrib/src/ngl/w3/getgbep.f | 219 + WPS/ungrib/src/ngl/w3/getgbex.f | 233 + WPS/ungrib/src/ngl/w3/getgbexm.f | 284 ++ WPS/ungrib/src/ngl/w3/getgbh.f | 206 + WPS/ungrib/src/ngl/w3/getgbm.f | 271 ++ WPS/ungrib/src/ngl/w3/getgbmh.f | 258 ++ WPS/ungrib/src/ngl/w3/getgbmp.f | 264 ++ WPS/ungrib/src/ngl/w3/getgbp.f | 209 + WPS/ungrib/src/ngl/w3/getgi.f | 88 + WPS/ungrib/src/ngl/w3/getgir.f | 90 + WPS/ungrib/src/ngl/w3/grib1.doc | 1321 ++++++ WPS/ungrib/src/ngl/w3/idsdef.f | 285 ++ WPS/ungrib/src/ngl/w3/instrument.f | 111 + WPS/ungrib/src/ngl/w3/iw3jdn.f | 62 + WPS/ungrib/src/ngl/w3/ixgb.f | 154 + WPS/ungrib/src/ngl/w3/lengds.f | 40 + WPS/ungrib/src/ngl/w3/pdsens.f | 75 + WPS/ungrib/src/ngl/w3/pdseup.f | 110 + WPS/ungrib/src/ngl/w3/putgb.f | 201 + WPS/ungrib/src/ngl/w3/putgbe.f | 213 + WPS/ungrib/src/ngl/w3/putgben.f | 223 + WPS/ungrib/src/ngl/w3/putgbens.f | 167 + WPS/ungrib/src/ngl/w3/putgbex.f | 222 + WPS/ungrib/src/ngl/w3/putgbn.f | 209 + WPS/ungrib/src/ngl/w3/r63w72.f | 125 + WPS/ungrib/src/ngl/w3/sbyte.f | 107 + WPS/ungrib/src/ngl/w3/sbytes.f | 138 + WPS/ungrib/src/ngl/w3/start.f | 2 + WPS/ungrib/src/ngl/w3/summary.f | 2 + WPS/ungrib/src/ngl/w3/w3difdat.f | 55 + WPS/ungrib/src/ngl/w3/w3doxdat.f | 40 + WPS/ungrib/src/ngl/w3/w3fi01.f | 43 + WPS/ungrib/src/ngl/w3/w3fi58.f | 115 + WPS/ungrib/src/ngl/w3/w3fi59.f | 130 + WPS/ungrib/src/ngl/w3/w3fi63.f | 4062 +++++++++++++++++ WPS/ungrib/src/ngl/w3/w3fi68.f | 184 + WPS/ungrib/src/ngl/w3/w3fi71.f | 1768 +++++++ WPS/ungrib/src/ngl/w3/w3fi72.f | 455 ++ WPS/ungrib/src/ngl/w3/w3fi73.f | 99 + WPS/ungrib/src/ngl/w3/w3fi74.f | 426 ++ WPS/ungrib/src/ngl/w3/w3fi75.f | 1596 +++++++ WPS/ungrib/src/ngl/w3/w3fi76.f | 131 + WPS/ungrib/src/ngl/w3/w3fi82.f | 60 + WPS/ungrib/src/ngl/w3/w3fi83.f | 108 + WPS/ungrib/src/ngl/w3/w3fs21.f | 77 + WPS/ungrib/src/ngl/w3/w3fs26.f | 87 + WPS/ungrib/src/ngl/w3/w3locdat.f | 43 + WPS/ungrib/src/ngl/w3/w3log.f | 2 + WPS/ungrib/src/ngl/w3/w3movdat.f | 53 + WPS/ungrib/src/ngl/w3/w3reddat.f | 142 + WPS/ungrib/src/ngl/w3/w3tagb.f | 119 + WPS/ungrib/src/ngl/w3/w3utcdat.f | 67 + WPS/ungrib/src/output.F | 316 ++ WPS/ungrib/src/parse_table.F | 484 ++ WPS/ungrib/src/rd_grib1.F | 647 +++ WPS/ungrib/src/rd_grib2.F | 1178 +++++ WPS/ungrib/src/read_namelist.F | 299 ++ WPS/ungrib/src/rrpr.F | 1399 ++++++ WPS/ungrib/src/swap.F | 18 + WPS/ungrib/src/table.F | 65 + WPS/ungrib/src/ungrib.F | 419 ++ WPS/util/.gitignore | 8 + WPS/util/Makefile | 48 + WPS/util/gfs.ncl | 157 + WPS/util/gfs_old.ncl | 157 + WPS/util/plotfmt.ncl | 215 + WPS/util/plotfmt_nc.ncl | 156 + WPS/util/plotgrids.ncl | 195 + WPS/util/plotgrids_new.ncl | 215 + WPS/util/plotgrids_old.ncl | 135 + WPS/util/src/.gitignore | 3 + WPS/util/src/Makefile | 117 + WPS/util/src/avg_tsfc.F | 123 + WPS/util/src/calc_ecmwf_p.F | 458 ++ WPS/util/src/cio.c | 1 + WPS/util/src/constants_module.F | 1 + WPS/util/src/elev_angle.F | 206 + WPS/util/src/gridinfo_module.F | 1 + WPS/util/src/height_ukmo.F | 274 ++ WPS/util/src/int2nc.F | 281 ++ WPS/util/src/met_data_module.F | 1 + WPS/util/src/misc_definitions_module.F | 1 + WPS/util/src/mod_levs.F | 158 + WPS/util/src/module_date_pack.F | 1 + WPS/util/src/module_debug.F | 1 + WPS/util/src/module_map_utils.F | 1 + WPS/util/src/module_stringutil.F | 1 + WPS/util/src/plotfmt.F | 452 ++ WPS/util/src/plotgrids.F | 740 +++ WPS/util/src/rd_intermediate.F | 115 + WPS/util/src/read_met_module.F | 1 + WPS/util/src/write_met_module.F | 1 + WPS/util/vertical_grid_38_20m_G3.txt | 46 + WPS/util/vertical_grid_50_20m_63km.txt | 58 + WPS/util/vertical_grid_70_20m_80km.txt | 78 + 372 files changed, 99022 insertions(+) create mode 100644 .DS_Store create mode 100644 WPS/README create mode 100644 WPS/arch/Config.pl create mode 100644 WPS/arch/configure.defaults create mode 100755 WPS/arch/fixlinks create mode 100644 WPS/arch/postamble create mode 100644 WPS/arch/preamble create mode 100644 WPS/arch/sourceme_windows.bash create mode 100644 WPS/arch/sourceme_windows.csh create mode 100755 WPS/arch/zaplinks create mode 100755 WPS/clean create mode 100755 WPS/compile create mode 100755 WPS/configure create mode 120000 WPS/geogrid/GEOGRID.TBL create mode 100644 WPS/geogrid/GEOGRID.TBL.ARW create mode 100644 WPS/geogrid/GEOGRID.TBL.ARW.noahmp create mode 100644 WPS/geogrid/GEOGRID.TBL.ARW_CHEM create mode 100755 WPS/geogrid/GEOGRID.TBL.FIRE create mode 100644 WPS/geogrid/GEOGRID.TBL.NMM create mode 100644 WPS/geogrid/Makefile create mode 100644 WPS/geogrid/gribmap.txt create mode 100644 WPS/geogrid/src/.gitignore create mode 100644 WPS/geogrid/src/Makefile create mode 100644 WPS/geogrid/src/bitarray_module.F create mode 100644 WPS/geogrid/src/cio.c create mode 100644 WPS/geogrid/src/constants_module.F create mode 100644 WPS/geogrid/src/geogrid.F create mode 100644 WPS/geogrid/src/gridinfo_module.F create mode 100644 WPS/geogrid/src/hash_module.F create mode 100644 WPS/geogrid/src/interp_module.F create mode 100644 WPS/geogrid/src/list_module.F create mode 100644 WPS/geogrid/src/llxy_module.F create mode 100644 WPS/geogrid/src/misc_definitions_module.F create mode 100644 WPS/geogrid/src/module_debug.F create mode 100644 WPS/geogrid/src/module_map_utils.F create mode 120000 WPS/geogrid/src/module_stringutil.F create mode 100644 WPS/geogrid/src/output_module.F create mode 100644 WPS/geogrid/src/parallel_module.F create mode 100644 WPS/geogrid/src/proc_point_module.F create mode 100644 WPS/geogrid/src/process_tile_module.F create mode 100644 WPS/geogrid/src/queue_module.F create mode 100644 WPS/geogrid/src/read_geogrid.c create mode 100644 WPS/geogrid/src/smooth_module.F create mode 100644 WPS/geogrid/src/source_data_module.F create mode 100644 WPS/geogrid/src/wrf_debug.F create mode 100644 WPS/geogrid/src/write_geogrid.c create mode 100644 WPS/geogrid/util/ij_to_latlon.F create mode 100644 WPS/geogrid/util/latlon_to_ij.F create mode 100644 WPS/geogrid/util/plot_source/a.c create mode 100644 WPS/geogrid/util/plot_source/plotter.F create mode 100755 WPS/geogrid/util/plotgrid/Makefile create mode 100644 WPS/geogrid/util/plotgrid/namelist.wps create mode 100644 WPS/geogrid/util/plotgrid/src/Makefile create mode 120000 WPS/geogrid/util/plotgrid/src/cio.c create mode 120000 WPS/geogrid/util/plotgrid/src/gridinfo_module.F create mode 120000 WPS/geogrid/util/plotgrid/src/input_module.F create mode 120000 WPS/geogrid/util/plotgrid/src/misc_definitions_module.F create mode 120000 WPS/geogrid/util/plotgrid/src/module_debug.F create mode 120000 WPS/geogrid/util/plotgrid/src/parallel_module.F create mode 100644 WPS/geogrid/util/plotgrid/src/plotgrid.F create mode 120000 WPS/geogrid/util/plotgrid/src/queue_module.F create mode 120000 WPS/geogrid/util/plotgrid/src/wrf_debug.F create mode 100644 WPS/geogrid/util/plotter.F create mode 100644 WPS/geogrid/util/retile-cat.c create mode 100644 WPS/geogrid/util/retile-cont.c create mode 100644 WPS/geogrid/util/retile.c create mode 100755 WPS/link_grib.csh create mode 120000 WPS/metgrid/METGRID.TBL create mode 100644 WPS/metgrid/METGRID.TBL.AFWA create mode 100644 WPS/metgrid/METGRID.TBL.ARW create mode 100644 WPS/metgrid/METGRID.TBL.ARW.rap create mode 100644 WPS/metgrid/METGRID.TBL.ARW.ruc create mode 100644 WPS/metgrid/METGRID.TBL.NMM create mode 100644 WPS/metgrid/METGRID.TBL.NMM.rap create mode 100755 WPS/metgrid/Makefile create mode 100644 WPS/metgrid/gribmap.txt create mode 100644 WPS/metgrid/src/.gitignore create mode 100644 WPS/metgrid/src/Makefile create mode 120000 WPS/metgrid/src/bitarray_module.F create mode 120000 WPS/metgrid/src/cio.c create mode 120000 WPS/metgrid/src/constants_module.F create mode 100644 WPS/metgrid/src/datatype_module.F create mode 100644 WPS/metgrid/src/gridinfo_module.F create mode 100644 WPS/metgrid/src/input_module.F create mode 120000 WPS/metgrid/src/interp_module.F create mode 100644 WPS/metgrid/src/interp_option_module.F create mode 120000 WPS/metgrid/src/list_module.F create mode 120000 WPS/metgrid/src/llxy_module.F create mode 100644 WPS/metgrid/src/met_data_module.F create mode 100644 WPS/metgrid/src/metgrid.F create mode 100644 WPS/metgrid/src/minheap_module.F create mode 120000 WPS/metgrid/src/misc_definitions_module.F create mode 100644 WPS/metgrid/src/module_date_pack.F create mode 120000 WPS/metgrid/src/module_debug.F create mode 120000 WPS/metgrid/src/module_map_utils.F create mode 100644 WPS/metgrid/src/module_mergesort.F create mode 120000 WPS/metgrid/src/module_stringutil.F create mode 100644 WPS/metgrid/src/mpas_mesh.F create mode 120000 WPS/metgrid/src/output_module.F create mode 120000 WPS/metgrid/src/parallel_module.F create mode 100644 WPS/metgrid/src/process_domain_module.F create mode 120000 WPS/metgrid/src/queue_module.F create mode 100644 WPS/metgrid/src/read_met_module.F create mode 100644 WPS/metgrid/src/remapper.F create mode 100644 WPS/metgrid/src/rotate_winds_module.F create mode 100644 WPS/metgrid/src/scan_input.F create mode 100644 WPS/metgrid/src/storage_module.F create mode 100644 WPS/metgrid/src/target_mesh.F create mode 120000 WPS/metgrid/src/wrf_debug.F create mode 100644 WPS/metgrid/src/write_met_module.F create mode 100644 WPS/namelist.wps create mode 100644 WPS/namelist.wps.all_options create mode 100755 WPS/namelist.wps.fire create mode 100644 WPS/namelist.wps.global create mode 100644 WPS/namelist.wps.nmm create mode 100644 WPS/ungrib/.gitignore create mode 100644 WPS/ungrib/Makefile create mode 100644 WPS/ungrib/README_LIBS create mode 100644 WPS/ungrib/Variable_Tables/README create mode 100644 WPS/ungrib/Variable_Tables/Vtable.AFWAICE create mode 100644 WPS/ungrib/Variable_Tables/Vtable.AGRMETSNOW create mode 100644 WPS/ungrib/Variable_Tables/Vtable.AGRMETSOIL create mode 100644 WPS/ungrib/Variable_Tables/Vtable.AGRMETSOIL2 create mode 100644 WPS/ungrib/Variable_Tables/Vtable.AGRWRF create mode 100644 WPS/ungrib/Variable_Tables/Vtable.ARW.UPP create mode 100644 WPS/ungrib/Variable_Tables/Vtable.ARWp.UPP create mode 100644 WPS/ungrib/Variable_Tables/Vtable.AVN0P5WRF create mode 100644 WPS/ungrib/Variable_Tables/Vtable.AWIP create mode 100644 WPS/ungrib/Variable_Tables/Vtable.CFSR2_web create mode 100644 WPS/ungrib/Variable_Tables/Vtable.CFSR_mean create mode 100644 WPS/ungrib/Variable_Tables/Vtable.CFSR_press_pgbh06 create mode 100644 WPS/ungrib/Variable_Tables/Vtable.CFSR_sfc_flxf06 create mode 100644 WPS/ungrib/Variable_Tables/Vtable.ECMWF create mode 100644 WPS/ungrib/Variable_Tables/Vtable.ECMWF_sigma create mode 100644 WPS/ungrib/Variable_Tables/Vtable.ERA-interim.ml create mode 100644 WPS/ungrib/Variable_Tables/Vtable.ERA-interim.pl create mode 100644 WPS/ungrib/Variable_Tables/Vtable.GFDL create mode 100644 WPS/ungrib/Variable_Tables/Vtable.GFS create mode 100644 WPS/ungrib/Variable_Tables/Vtable.GFSENS create mode 100644 WPS/ungrib/Variable_Tables/Vtable.GODAS create mode 100644 WPS/ungrib/Variable_Tables/Vtable.GSM create mode 100644 WPS/ungrib/Variable_Tables/Vtable.JMAGSM create mode 100644 WPS/ungrib/Variable_Tables/Vtable.NAM create mode 100644 WPS/ungrib/Variable_Tables/Vtable.NARR create mode 100644 WPS/ungrib/Variable_Tables/Vtable.NCEP2 create mode 100644 WPS/ungrib/Variable_Tables/Vtable.NNRP create mode 100644 WPS/ungrib/Variable_Tables/Vtable.NOGAPS create mode 100644 WPS/ungrib/Variable_Tables/Vtable.NOGAPS_needs_GFS_soil create mode 100644 WPS/ungrib/Variable_Tables/Vtable.NavySST create mode 100644 WPS/ungrib/Variable_Tables/Vtable.RAP.hybrid.ncep create mode 100644 WPS/ungrib/Variable_Tables/Vtable.RAP.pressure.ncep create mode 100644 WPS/ungrib/Variable_Tables/Vtable.RAP.sigma.gsd create mode 100644 WPS/ungrib/Variable_Tables/Vtable.RUCb create mode 100644 WPS/ungrib/Variable_Tables/Vtable.RUCp create mode 100644 WPS/ungrib/Variable_Tables/Vtable.SREF create mode 100644 WPS/ungrib/Variable_Tables/Vtable.SST create mode 100644 WPS/ungrib/Variable_Tables/Vtable.TCRP create mode 100644 WPS/ungrib/Variable_Tables/Vtable.UKMO_ENDGame create mode 100644 WPS/ungrib/Variable_Tables/Vtable.UKMO_LANDSEA create mode 100644 WPS/ungrib/Variable_Tables/Vtable.UKMO_no_heights create mode 100755 WPS/ungrib/Variable_Tables/Vtable.raphrrr create mode 100644 WPS/ungrib/src/.gitignore create mode 100644 WPS/ungrib/src/Makefile create mode 100644 WPS/ungrib/src/build_hdate.F create mode 100644 WPS/ungrib/src/cio.c create mode 100644 WPS/ungrib/src/datint.F create mode 120000 WPS/ungrib/src/debug_cio.c create mode 100644 WPS/ungrib/src/file_delete.F create mode 100644 WPS/ungrib/src/filelist.F create mode 100644 WPS/ungrib/src/g1print.F create mode 100644 WPS/ungrib/src/g2print.F create mode 100644 WPS/ungrib/src/gbytesys.F create mode 100644 WPS/ungrib/src/geth_idts.F create mode 100644 WPS/ungrib/src/geth_newdate.F create mode 100644 WPS/ungrib/src/gribcode.F create mode 100644 WPS/ungrib/src/gridinfo.F create mode 120000 WPS/ungrib/src/misc_definitions_module.F create mode 100644 WPS/ungrib/src/module_datarray.F create mode 120000 WPS/ungrib/src/module_debug.F create mode 100644 WPS/ungrib/src/module_stringutil.F create mode 100644 WPS/ungrib/src/new_storage.F create mode 100644 WPS/ungrib/src/ngl/Makefile create mode 100755 WPS/ungrib/src/ngl/g2/CHANGES create mode 100755 WPS/ungrib/src/ngl/g2/Makefile create mode 100755 WPS/ungrib/src/ngl/g2/README create mode 100755 WPS/ungrib/src/ngl/g2/addfield.F create mode 100755 WPS/ungrib/src/ngl/g2/addgrid.f create mode 100755 WPS/ungrib/src/ngl/g2/addlocal.f create mode 100755 WPS/ungrib/src/ngl/g2/cmplxpack.f create mode 100755 WPS/ungrib/src/ngl/g2/compack.f create mode 100644 WPS/ungrib/src/ngl/g2/comunpack.f create mode 100755 WPS/ungrib/src/ngl/g2/dec_jpeg2000.c create mode 100755 WPS/ungrib/src/ngl/g2/dec_png.c create mode 100755 WPS/ungrib/src/ngl/g2/drstemplates.f create mode 100755 WPS/ungrib/src/ngl/g2/enc_jpeg2000.c create mode 100755 WPS/ungrib/src/ngl/g2/enc_png.c create mode 100755 WPS/ungrib/src/ngl/g2/g2grids.f create mode 100755 WPS/ungrib/src/ngl/g2/gb_info.f create mode 100755 WPS/ungrib/src/ngl/g2/gbytesc.f create mode 100755 WPS/ungrib/src/ngl/g2/gdt2gds.f create mode 100755 WPS/ungrib/src/ngl/g2/getdim.f create mode 100755 WPS/ungrib/src/ngl/g2/getfield.f create mode 100755 WPS/ungrib/src/ngl/g2/getg2i.f create mode 100755 WPS/ungrib/src/ngl/g2/getg2ir.f create mode 100755 WPS/ungrib/src/ngl/g2/getgb2.f create mode 100755 WPS/ungrib/src/ngl/g2/getgb2l.f create mode 100755 WPS/ungrib/src/ngl/g2/getgb2p.f create mode 100755 WPS/ungrib/src/ngl/g2/getgb2r.f create mode 100755 WPS/ungrib/src/ngl/g2/getgb2rp.f create mode 100755 WPS/ungrib/src/ngl/g2/getgb2s.f create mode 100755 WPS/ungrib/src/ngl/g2/getidx.f create mode 100755 WPS/ungrib/src/ngl/g2/getlocal.f create mode 100755 WPS/ungrib/src/ngl/g2/getpoly.f create mode 100755 WPS/ungrib/src/ngl/g2/gettemplates.f create mode 100755 WPS/ungrib/src/ngl/g2/gf_free.f create mode 100755 WPS/ungrib/src/ngl/g2/gf_getfld.f create mode 100755 WPS/ungrib/src/ngl/g2/gf_unpack1.f create mode 100755 WPS/ungrib/src/ngl/g2/gf_unpack2.f create mode 100755 WPS/ungrib/src/ngl/g2/gf_unpack3.f create mode 100755 WPS/ungrib/src/ngl/g2/gf_unpack4.f create mode 100755 WPS/ungrib/src/ngl/g2/gf_unpack5.f create mode 100755 WPS/ungrib/src/ngl/g2/gf_unpack6.f create mode 100755 WPS/ungrib/src/ngl/g2/gf_unpack7.F create mode 100755 WPS/ungrib/src/ngl/g2/grib2.doc create mode 100755 WPS/ungrib/src/ngl/g2/gribcreate.f create mode 100755 WPS/ungrib/src/ngl/g2/gribend.f create mode 100755 WPS/ungrib/src/ngl/g2/gribinfo.f create mode 100755 WPS/ungrib/src/ngl/g2/gribmod.f create mode 100755 WPS/ungrib/src/ngl/g2/gridtemplates.f create mode 100644 WPS/ungrib/src/ngl/g2/intmath.f create mode 100755 WPS/ungrib/src/ngl/g2/ixgb2.f create mode 100755 WPS/ungrib/src/ngl/g2/jpcpack.F create mode 100755 WPS/ungrib/src/ngl/g2/jpcunpack.F create mode 100755 WPS/ungrib/src/ngl/g2/makefile_d create mode 100755 WPS/ungrib/src/ngl/g2/misspack.f create mode 100755 WPS/ungrib/src/ngl/g2/mkieee.f create mode 100755 WPS/ungrib/src/ngl/g2/mova2i.c create mode 100755 WPS/ungrib/src/ngl/g2/pack_gp.f create mode 100755 WPS/ungrib/src/ngl/g2/params.f create mode 100755 WPS/ungrib/src/ngl/g2/params_ecmwf.f create mode 100755 WPS/ungrib/src/ngl/g2/pdstemplates.f create mode 100755 WPS/ungrib/src/ngl/g2/pngpack.F create mode 100755 WPS/ungrib/src/ngl/g2/pngunpack.F create mode 100755 WPS/ungrib/src/ngl/g2/putgb2.f create mode 100755 WPS/ungrib/src/ngl/g2/rdieee.f create mode 100755 WPS/ungrib/src/ngl/g2/realloc.f create mode 100755 WPS/ungrib/src/ngl/g2/reduce.f create mode 100755 WPS/ungrib/src/ngl/g2/simpack.f create mode 100755 WPS/ungrib/src/ngl/g2/simunpack.f create mode 100755 WPS/ungrib/src/ngl/g2/skgb.f create mode 100755 WPS/ungrib/src/ngl/g2/specpack.f create mode 100755 WPS/ungrib/src/ngl/g2/specunpack.f create mode 100755 WPS/ungrib/src/ngl/w3/CHANGES create mode 100644 WPS/ungrib/src/ngl/w3/Makefile create mode 100644 WPS/ungrib/src/ngl/w3/README create mode 100755 WPS/ungrib/src/ngl/w3/bacio.v1.3.c create mode 100644 WPS/ungrib/src/ngl/w3/bacio_module.f create mode 100755 WPS/ungrib/src/ngl/w3/baciof.f create mode 100755 WPS/ungrib/src/ngl/w3/baciof.h create mode 100644 WPS/ungrib/src/ngl/w3/clib.h create mode 100755 WPS/ungrib/src/ngl/w3/errexit.c create mode 100755 WPS/ungrib/src/ngl/w3/errmsg.f create mode 100755 WPS/ungrib/src/ngl/w3/fparsei.f create mode 100755 WPS/ungrib/src/ngl/w3/fparser.f create mode 100755 WPS/ungrib/src/ngl/w3/gbytes.f create mode 100644 WPS/ungrib/src/ngl/w3/gbytes_char.f create mode 100755 WPS/ungrib/src/ngl/w3/getbit.f create mode 100755 WPS/ungrib/src/ngl/w3/getgb.f create mode 100755 WPS/ungrib/src/ngl/w3/getgb1r.f create mode 100755 WPS/ungrib/src/ngl/w3/getgb1re.f create mode 100755 WPS/ungrib/src/ngl/w3/getgb1s.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbe.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbeh.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbem.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbemh.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbemp.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbens.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbep.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbex.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbexm.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbh.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbm.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbmh.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbmp.f create mode 100755 WPS/ungrib/src/ngl/w3/getgbp.f create mode 100755 WPS/ungrib/src/ngl/w3/getgi.f create mode 100755 WPS/ungrib/src/ngl/w3/getgir.f create mode 100755 WPS/ungrib/src/ngl/w3/grib1.doc create mode 100755 WPS/ungrib/src/ngl/w3/idsdef.f create mode 100755 WPS/ungrib/src/ngl/w3/instrument.f create mode 100755 WPS/ungrib/src/ngl/w3/iw3jdn.f create mode 100755 WPS/ungrib/src/ngl/w3/ixgb.f create mode 100755 WPS/ungrib/src/ngl/w3/lengds.f create mode 100755 WPS/ungrib/src/ngl/w3/pdsens.f create mode 100755 WPS/ungrib/src/ngl/w3/pdseup.f create mode 100755 WPS/ungrib/src/ngl/w3/putgb.f create mode 100755 WPS/ungrib/src/ngl/w3/putgbe.f create mode 100755 WPS/ungrib/src/ngl/w3/putgben.f create mode 100755 WPS/ungrib/src/ngl/w3/putgbens.f create mode 100755 WPS/ungrib/src/ngl/w3/putgbex.f create mode 100755 WPS/ungrib/src/ngl/w3/putgbn.f create mode 100755 WPS/ungrib/src/ngl/w3/r63w72.f create mode 100755 WPS/ungrib/src/ngl/w3/sbyte.f create mode 100755 WPS/ungrib/src/ngl/w3/sbytes.f create mode 100644 WPS/ungrib/src/ngl/w3/start.f create mode 100644 WPS/ungrib/src/ngl/w3/summary.f create mode 100755 WPS/ungrib/src/ngl/w3/w3difdat.f create mode 100755 WPS/ungrib/src/ngl/w3/w3doxdat.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi01.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi58.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi59.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi63.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi68.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi71.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi72.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi73.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi74.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi75.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi76.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi82.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fi83.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fs21.f create mode 100755 WPS/ungrib/src/ngl/w3/w3fs26.f create mode 100755 WPS/ungrib/src/ngl/w3/w3locdat.f create mode 100644 WPS/ungrib/src/ngl/w3/w3log.f create mode 100755 WPS/ungrib/src/ngl/w3/w3movdat.f create mode 100755 WPS/ungrib/src/ngl/w3/w3reddat.f create mode 100755 WPS/ungrib/src/ngl/w3/w3tagb.f create mode 100755 WPS/ungrib/src/ngl/w3/w3utcdat.f create mode 100644 WPS/ungrib/src/output.F create mode 100644 WPS/ungrib/src/parse_table.F create mode 100644 WPS/ungrib/src/rd_grib1.F create mode 100644 WPS/ungrib/src/rd_grib2.F create mode 100644 WPS/ungrib/src/read_namelist.F create mode 100644 WPS/ungrib/src/rrpr.F create mode 100644 WPS/ungrib/src/swap.F create mode 100644 WPS/ungrib/src/table.F create mode 100644 WPS/ungrib/src/ungrib.F create mode 100644 WPS/util/.gitignore create mode 100644 WPS/util/Makefile create mode 100644 WPS/util/gfs.ncl create mode 100644 WPS/util/gfs_old.ncl create mode 100644 WPS/util/plotfmt.ncl create mode 100644 WPS/util/plotfmt_nc.ncl create mode 100644 WPS/util/plotgrids.ncl create mode 100644 WPS/util/plotgrids_new.ncl create mode 100644 WPS/util/plotgrids_old.ncl create mode 100644 WPS/util/src/.gitignore create mode 100644 WPS/util/src/Makefile create mode 100644 WPS/util/src/avg_tsfc.F create mode 100644 WPS/util/src/calc_ecmwf_p.F create mode 120000 WPS/util/src/cio.c create mode 120000 WPS/util/src/constants_module.F create mode 100644 WPS/util/src/elev_angle.F create mode 120000 WPS/util/src/gridinfo_module.F create mode 100644 WPS/util/src/height_ukmo.F create mode 100644 WPS/util/src/int2nc.F create mode 120000 WPS/util/src/met_data_module.F create mode 120000 WPS/util/src/misc_definitions_module.F create mode 100644 WPS/util/src/mod_levs.F create mode 120000 WPS/util/src/module_date_pack.F create mode 120000 WPS/util/src/module_debug.F create mode 120000 WPS/util/src/module_map_utils.F create mode 120000 WPS/util/src/module_stringutil.F create mode 100644 WPS/util/src/plotfmt.F create mode 100644 WPS/util/src/plotgrids.F create mode 100644 WPS/util/src/rd_intermediate.F create mode 120000 WPS/util/src/read_met_module.F create mode 120000 WPS/util/src/write_met_module.F create mode 100644 WPS/util/vertical_grid_38_20m_G3.txt create mode 100644 WPS/util/vertical_grid_50_20m_63km.txt create mode 100644 WPS/util/vertical_grid_70_20m_80km.txt diff --git a/.DS_Store b/.DS_Store new file mode 100644 index 0000000000000000000000000000000000000000..428213e4c3d70cd2f8318aa85d9bdeb45d6d928f GIT binary patch literal 10244 zcmeHMYit!o6rOY2!Y-YGDWJRxTv{F#T4+lvPS0mTPV|3ISgiBW%|ff)H?!^1=q<&TLP{h>zrgJ)*;w&k`>FeCSJ|$)7z=zxdpv*?K zyzrfi7nDIyR(rBfNwnYvswhfT6ud14sN$#(dikn7*{7r`PQcrIfY&m3I~0(uWBoyy zoj|pc{?qq>?}6bS5PSD5(n1=3EONU}ZZy*D|IJ@6ihZnezrHa@w|i6sQ2(OH6ZYU z0-2C8z~h6Xv-gyRV@}7=a|v(Uw%b*w&Mg8LqMd5oUk!|VTrOqf>l^Af(amjqViyi+ zb7#_W;_g;6;i7Eg6I^t|#+VatOqjyn#`9tkJC?E|Nwdbb!`4C5ZHYN{sw3`-+_8jX z+l`KEiE6gBCe8gxk!P5xb-U{%l6A6R8|Nw4++t##R+kyVn%!0ln-m2(=-TNCQ-kyF zTD)}ms@nDaJa6Kp$#+n?9bFnvTDvVX(cEnr$@Xm#H)h5SE54_t%W|!#Z8pUt9cEtO zysr08n?8fHnQV62lvzaMg<5MWYVAu|$pf;DIR%XFG_Wt597D8X@b@)cTILrpwnJFz z5+*(kP3xbOH<8mttVHJ#t;xl1D@`da*SV`V?L|CD4XdQfG;Zk4b|h-rN>xQyYP?== z=~6CN$~Ck`%Y$OQ6~Af+j?o~Glr(*O5VFt0bMPWU_7!*)PQocTEus51d;}j$@Lqr~p+5tv4L3p+z8-{XhZ71J zsbq|hi&xH`x_)G+#TdoX**;ou?+Pd4wiDljwTNjlj&$Qh-c7o2TDPIJFlGKniEqTQ z8g9&vB2A+&Ms|kJhLR1rj0KF176b;E5LwY9w*od-$GLxFND;Kh3Rsb*4UI{XjutLr zR0by*AVh3iQc9_eQ8Fk9O+_U}Bgup^YzWngD$3F^OhyZ#T)l>}fncb@lWaM})`{?x z5grwR7O;CYZIBN~U_(L5x5$P%OhPuC3-e)tWW#c(fJ(`R4X{bF;U2KyLCJ;(pa%{~ zHWY#7X~~8s;Wc<&vf-J5fbtofgY%LNzk{oPiw#Gd5{P)88||CnMmCEE(=3=dF%)OY z6&W8Z8LOa>F)q-j2yHVh;<>)R@Rkt zwO9f2G0K|3jk!gPYWl4Lcw}x|2&GUZmvA9uN5PF-kQtjLH%4$NXW(Kk4i4-?b`;!r z82XSM1veg*5Ek5c0$xUTycKR75x5!LCPKP@`5w4w4`ivFL2>@ScJ%-MH(j5f(f5Gw zfq$O|AUhNe)ndQX2ML)&5NGW{ym#R(E|ITKNm&FRH~a{|ggA~b!dv7`pQecSYERdv bq%4klSsdj*^fN#l-1+-|fB*kK-v9pvoS|;2 literal 0 HcmV?d00001 diff --git a/WPS/README b/WPS/README new file mode 100644 index 00000000..99e8cbe8 --- /dev/null +++ b/WPS/README @@ -0,0 +1,241 @@ +WRF Pre-Processing System Version 3.9.1 (17 August 2017) + +http://www2.mmm.ucar.edu/wrf/users/ + +The WRF Pre-Processing System (WPS) is a collection +of Fortran and C programs that provides data used as +input to the real.exe and real_nmm.exe programs. There +are three main programs and a number of auxiliary +programs that are part of WPS. Both the ARW and NMM +dynamical cores in WRF are supported by WPS. + +For questions and help to run the program, please see the +User's Guide at http://www2.mmm.ucar.edu/wrf/users/docs/user_guide_V3/contents.html +and send email to wrfhelp@ucar.edu. + +=================================================== + +Main programs: geogrid.exe, ungrib.exe, metgrid.exe + +Input to the main programs is through the namelist +file "namelist.wps". Each main program has an +exclusive namelist record (named "geogrid", "ungrib", +or "metgrid", respectively), and the three programs +have a group record (named "share") that each program +reads. + +geogrid +------- +1) Defines the model horizontal domain +2) Horizontally interpolates static data to the model +domain +3) Output conforms to the WRF I/O API + +ungrib +------ +1) Decodes Grib Edition 1 and 2 data +2) Uses tables to decide which variables to extract +3) Supports isobaric and generalized vertical coordinates +4) Output is in a non-WRF-I/O-API form, referred to as an + intermediate format + +metgrid +------- +1) Ingest static data and raw meteorological fields +2) Horizontally interpolate meteorological fields to the + model domain +3) Output conforms to WRF I/O API + + + + +Parallelism + +The geogrid and metgrid programs may be run as +distributed memory parallel jobs to reduce the +time-to-solution. These two programs use MPI calls +directly, compared to WRF, which has an abstraction +layer (RSL or RSL_LITE). + + + + +Grib Edition 2 + +The Grib Edition 2 compression requires three libraries +external to the WPS source code: zlib, png, and jasper. +It is recommended that users request support from their +system administrators when installing these packages. +Users can compile the code without these libraries by +selecting the "NO GRIB2" options in the build. + + + + +Building WPS + +Similar to the WRF package, WPS uses a two-step build +mechanism, + ./configure + ./compile +which directs the unix make underneath. +If the user is on a recognized architecture, the +configure script will display a list of available +compile options (usually serial vs parallel, Grib 2 +enabled vs a "NO GRIB2" option). For some OS options, +there are multiple compilers that are supported. + +The configure option lists both "build GRIB2" and +"do not build GRIB2" options. It is suggested that +the first builds be without the GRIB Edition 2 +capability. + +The utility plotting programs requiring NCAR Graphics are not +compiled automatically. Library paths must be set correctly +in configure.wps and then compiled using +./compile plotfmt +./compile plotgrids + + +Running WPS (for serially compiled code) + +geogrid.exe +----------- +- edit namelist.wps (&share and &geogrid sections) +- make sure the correct GEOGRID.TBL is used (ls -l geogrid/GEOGRID.TBL*) +- type 'geogrid.exe' to run +- check output in geogrid.log + +ungrib.exe +---------- +- edit namelist.wps for start_date and end_date, output file prefix + (&share and &ungrib sections) +- link correct Vtable: + ls -l ungrib/Variable_Tables + For example, for NCEP GFS (or AVN, FNL) data, + ln -sf ungrib/Variable_Tables/Vtable.GFS Vtable +- link grib data files: + link_grib.csh /data-directory/file* +- type 'ungrib.exe >& ungrib.out' to run +- check output in ungrib.log and ungrib.out + +metgrid.exe +----------- +- edit namelist.wps (&share and &metgrid sections) +- make sure the correct METGRID.TBL is used (ls -l metgrid/METGRID.TBL*) +- type 'metgrid.exe' to run +- check output in metgrid.log + + +There are a number of utility programs that will be +built in WPS/util/ directory: + +avg_tsfc.exe +------------ +purpose: computes a daily mean of the surface air +temperature, reads the namelist.wps file + +usage: +avg_tsfc.exe + + +g1print.exe +----------- +purpose: read a Grib Edition 1 file, output +information to build a Vtable + +usage: +g1print.exe GRIB1_file + + +g2print.exe +----------- +purpose: read a Grib Edition 2 file, output +information to build a Vtable + +usage: +g2print.exe GRIB2_file + + +mod_levs.exe +------------ +purpose: reduce levels in a intermediate file +so that different GRIB sources may be used +for the initial and lateral boundary time periods + +usage: +mod_levs.exe OLD_intermetdiate:date_string \ + NEW_intermetdiate:date_string +Processes a single file at a time, uses the +pressure levels defined in the namelist.wps file. + +plotfmt.exe +----------- +purpose: generate NCAR Graphics metacode 2d +horizontal plots of each field and level in the +intermediate file + +usage: +plotfmt.exe intermediate_file:date_string + + +plotgrids.exe +------------- +purpose: generate an NCEAR Graphics metacode +plot of the domain locations, one frame with +all of the domain locations plotted, reads the +namelist.wps file to get the domain information + +usage: +plotgrids.exe + + +rd_intermediate.exe +------------------- +purpose: read an intermediate file and print +the information to the screen + +usage: +rd_intermediate.exe intermediate_file:date_string + + + +calc_ecmwf_p.exe +------------------- +purpose: when using ECMWF model data in GRIB format, +computes the 3-d pressure, height, and RH fields from +the output of ungrib.exe, and writes these fields to +a new set of intermediate files to be used in addition +to those produced by ungrib. All times between the start_date +and end_date specified in the &share namelist will be +processed. + +usage: +calc_ecmwf_p.exe + + + +Static Input Data + +The static input data is provided in two tar files: one +contains full resolution data (30", 2', 5' and 10') and the other +contains only 10' low-resolution data. The data may be downloaded +from http://www2.mmm.ucar.edu/wrf/users/download/get_source.html. + + + + +Meteorological Input Data + +The meteorological input data for WPS is the GRIB +Edition 1 GFS data from NCEP. A test data set +(Jan 2000, 24/12Z to 25/12Z) is available from +http://www2.mmm.ucar.edu/wrf/users/download/get_source.html. + + + +Sample WPS output data for WRF + +Samples of the output data from WPS for use in WRF for the +Jan 2000 and June 2001 cases are provided from +http://www2.mmm.ucar.edu/wrf/users/download/get_source.html. diff --git a/WPS/arch/Config.pl b/WPS/arch/Config.pl new file mode 100644 index 00000000..fb04ed95 --- /dev/null +++ b/WPS/arch/Config.pl @@ -0,0 +1,322 @@ +#!/usr/bin/perl +# +# Configuration script for WPS code +# +# Be sure to run as ./configure (to avoid getting a system configure command by mistake) +# There are two (2) reads of the configure.defaults one to present the user with +# the appropriate options for the type of machine, and the OS, and the compiler! + +$sw_perl_path = perl; +$sw_netcdf_path = ""; +$sw_netcdff_lib = ""; +$sw_phdf5_path = ""; +$sw_jasperlib_path = ""; +$sw_jasperinc_path = ""; +$sw_ldflags = ""; +$sw_compileflags = ""; +$sw_os = "ARCH" ; # ARCH will match any +$sw_mach = "ARCH" ; # ARCH will match any +#$sw_compL = ""; +#$sw_compI = ""; +#$sw_fdefs = ""; +#$sw_fc = ""; +#$sw_cc = ""; +#$sw_mpi = ""; + +while(substr( $ARGV[0], 0, 1 ) eq "-") +{ + if(substr( $ARGV[0], 1, 5 ) eq "perl=") + { + $sw_perl_path = substr( $ARGV[0], 6); + } + if(substr( $ARGV[0], 1, 7 ) eq "netcdf=") + { + $sw_netcdf_path = substr( $ARGV[0], 8); + } + if(substr( $ARGV[0], 1, 8 ) eq "netcdff=") + { + $sw_netcdff_lib = substr( $ARGV[0], 9); + } + if(substr( $ARGV[0], 1, 6 ) eq "phdf5=") + { + $sw_phdf5_path = substr( $ARGV[0], 7); + } + if(substr( $ARGV[0], 1, 3 ) eq "os=") + { + $sw_os = substr( $ARGV[0], 4 ); + } + if(substr( $ARGV[0], 1, 5 ) eq "mach=") + { + $sw_mach = substr( $ARGV[0], 6 ); + } + if(substr( $ARGV[0], 1, 8 ) eq "ldflags=") + { + $sw_ldflags = substr( $ARGV[0], 9 ); + # multiple options separated by spaces are passed in from sh script + # separated by ! instead. Replace with spaces here. + $sw_ldflags =~ s/!/ /g ; + } + shift @ARGV; +} # end while + +# The jasper library is required to build Grib2 I/O. User must set +# environment variables JASPERLIB and JASPERINC to paths to library and +# include files to enable this feature prior to running configure. +if($ENV{JASPERLIB} && $ENV{JASPERINC}) +{ + printf "Found Jasper environment variables for GRIB2 support...\n"; + printf(" \$JASPERLIB = %s\n",$ENV{JASPERLIB}); + printf(" \$JASPERINC = %s\n",$ENV{JASPERINC}); + $sw_jasperlib_path = "-L$ENV{JASPERLIB} -ljasper -lpng -lz"; + $sw_jasperinc_path = "-I$ENV{JASPERINC}"; +} +else +{ + + $tmp1 = '/usr/local/jasper'; + if (-e $tmp1) { + $sw_jasperlib_path = '-L/usr/local/jasper/lib -ljasper -L/usr/local/libpng -lpng12 -lpng -L/usr/local/zlib/lib -lz' ; + $sw_jasperinc_path = '-I/usr/local/zlib/include -I/usr/local/jasper/include -I/usr/local/libpng/' ; + printf "\$JASPERLIB or \$JASPERINC not found in environment. Using /usr/local for library paths...\n"; + } + else { + $tmp1 = '/opt/local/lib'; + if (-e $tmp1) { + $sw_jasperlib_path = '-L/opt/local/lib -ljasper -lpng -lz'; + $sw_jasperinc_path = '-I/opt/local/include'; + printf "\$JASPERLIB or \$JASPERINC not found in environment. Using /opt/local for library paths...\n"; + } + else { + $sw_jasperlib_path = '-L/glade/u/home/wrfhelp/UNGRIB_LIBRARIES/lib -ljasper -lpng -lz'; + $sw_jasperinc_path = '-I/glade/u/home/wrfhelp/UNGRIB_LIBRARIES/include'; + printf "\$JASPERLIB or \$JASPERINC not found in environment. Using default values for library paths...\n"; + } + } +} + +$validresponse = 0 ; +# added this from the WRF Config.pl by John M. +@platforms = ('serial', 'serial_NO_GRIB2', 'dmpar', 'dmpar_NO_GRIB2'); +# Display the choices to the user and get selection +until ($validresponse) +{ + printf "------------------------------------------------------------------------\n"; + printf "Please select from among the following supported platforms.\n\n"; + + $opt = 1; + # Read configure.defaults + open CONFIGURE_DEFAULTS, "< ./arch/configure.defaults" + || die "Cannot open ./arch/configure.defaults for reading"; + # first read through the .defaults, user select and a read of all appropriate parms is not done here + while() + { + for $paropt (@platforms) + { + # read all the System/OS/Compiler appropriate selections and present same to user + if(substr($_, 0, 5) eq "#ARCH" && (index($_, $sw_os) >= 0) && (index($_, $sw_mach) >= 0) && (index($_, $paropt) >= 0)) + { + $optstr[$opt] = substr($_,6); + $optstr[$opt] =~ s/^[ ]*//; + $optstr[$opt] =~ s/#.*$//g; + chomp($optstr[$opt]); + $optstr[$opt] = $optstr[$opt]." (".$paropt.")"; + if(substr($optstr[$opt], 0, 4) ne "NULL") + { + printf " %2d. %s\n", $opt, $optstr[$opt]; + $opt++; + } + } + } + } + close CONFIGURE_DEFAULTS; + + $opt --; + + printf "\nEnter selection [%d-%d] : ", 1, $opt; + $response = ; + if($response == -1) {exit;} + if($response >= 1 && $response <= $opt) + { + $validresponse = 1; + } + else + { + printf("\nInvalid response (%d)\n",$response); + } +} + +printf "------------------------------------------------------------------------\n"; +# save user input +$optchoice = $response; + +# this HAS to be opened in 'cat' mode... why? +open CONFIGURE_DEFAULTS, "< ./arch/configure.defaults" || die "cannot Open for writing... configure.defaults: \n"; +$latchon = 0; +while() +{ + if(substr($_, 0, 5) eq "#ARCH" && $latchon == 1) + { + $latchon = 0; + } + if($latchon == 1) + { + $_ =~ s/CONFIGURE_PERL_PATH/$sw_perl_path/g; + $_ =~ s/CONFIGURE_NETCDF_PATH/$sw_netcdf_path/g; + $_ =~ s/CONFIGURE_LDFLAGS/$sw_ldflags/g; + $_ =~ s/CONFIGURE_COMPILEFLAGS/$sw_compileflags/g; + $_ =~ s/CONFIGURE_COMP_L/$sw_compL/g; + $_ =~ s/CONFIGURE_COMP_I/$sw_compI/g; + $_ =~ s/CONFIGURE_FDEFS/$sw_fdefs/g; + $_ =~ s/CONFIGURE_FC/$sw_fc/g; + $_ =~ s/CONFIGURE_CC/$sw_cc/g; + $_ =~ s/CONFIGURE_MPI/$sw_mpi/g; + + # Load the read in parameters from the configure.defaults file + if(!(substr($_, 0, 5) eq "#ARCH")) + { + @machopts = (@machopts, $_); + } + } # end if latchon == 1 + + #----------------------------------------------------------------------------------------------- + # added for the unified WPS build + # init the following for the configure.wps write + + + # now loop through the .defaults again and read the parameters to be written into the configure.wps + for $paropt (@platforms) + { + if(substr($_, 0, 5) eq "#ARCH" && $latchon == 0 && (index( $_, $sw_os) >= 0) && (index( $_, $sw_mach) >= 0) && (index($_, $paropt) >= 0)) + { + # after #ARCH the following reads the rest of the line in the configure.defaults + $x=substr($_,6); + $x=~s/^[ ]*//; + $x =~ s/#.*$//g; + chomp($x); + $x = $x." (".$paropt.")" ; + + if($x eq $optstr[$optchoice]) + { + $latchon = 1; + } + if($latchon == 1) + { + if($paropt eq 'serial') + { + if($ENV{JASPERLIB} && $ENV{JASPERINC}) + { + $sw_compL = $sw_jasperlib_path; + $sw_compI = $sw_jasperinc_path; + } + else + { + $sw_compL = $sw_jasperlib_path; + $sw_compI = $sw_jasperinc_path; +# $sw_compL = "-L/contrib/jasper/lib -L/opt/freeware/lib -ljasper -lpng -lz"; +# $sw_compI = "-I/contrib/libpng/include -I/contrib/zlib/include -I/contrib/jasper/include"; + } + $sw_fdefs = "-DUSE_JPEG2000 -DUSE_PNG"; + $sw_fc = "\$(SFC)"; + $sw_cc = "\$(SCC)"; + $sw_mpi = ""; + } + if($paropt eq 'serial_NO_GRIB2') + { + $sw_compL = ""; + $sw_compI = ""; + $sw_fdefs = ""; + $sw_fc = "\$(SFC)"; + $sw_cc = "\$(SCC)"; + $sw_mpi = ""; + } + if($paropt eq 'dmpar') + { + if($ENV{JASPERLIB} && $ENV{JASPERINC}) + { + $sw_compL = $sw_jasperlib_path; + $sw_compI = $sw_jasperinc_path; + } + else + { + $sw_compL = $sw_jasperlib_path; + $sw_compI = $sw_jasperinc_path; +# $sw_compL = "-L/contrib/jasper/lib -L/opt/freeware/lib -ljasper -lpng -lz"; +# $sw_compI = "-I/contrib/libpng/include -I/contrib/zlib/include -I/contrib/jasper/include"; + } + $sw_fdefs = "-DUSE_JPEG2000 -DUSE_PNG"; + $sw_fc = "\$(DM_FC)"; + $sw_cc = "\$(DM_CC)"; + $sw_mpi = "-D_MPI"; + } + if($paropt eq 'dmpar_NO_GRIB2') + { + $sw_compL = ""; + $sw_compI = ""; + $sw_fdefs = ""; + $sw_fc = "\$(DM_FC)"; + $sw_cc = "\$(DM_CC)"; + $sw_mpi = "-D_MPI"; + } + + ##################################################################################### + } # end if latchon == 1 + } # end if + } # end for +} +close CONFIGURE_DEFAULTS ; + +#printf "\n------------------------------------------------------------------------\n"; +#foreach $f (@machopts) +#{ +# if(substr($f , 0 , 8) eq "external") +# { +# last ; +# } +# print $f; +#} +#printf "--------------------------------------------------------------------------\n"; +#printf "\nYou have chosen: %s\n",$optstr[$optchoice]; +#printf "Listed above are the default options for this platform.\n"; +#printf "Settings are written to the file configure.wps here in the top-level\n"; +#printf "directory. If you wish to change settings, please edit that file.\n"; +#printf "If you wish to change the default options, edit the file:\n\n"; +#printf " arch/configure.defaults\n"; +#printf "\n"; +#printf "------------------------------------------------------------------------\n"; + +open CONFIGURE_WRF, "> configure.wps" || die "cannot Open for writing... configure.wps: \n"; + open ARCH_PREAMBLE, "< arch/preamble" || die "cannot Open for reading... arch/preamble: \n"; + my @preamble; + # apply substitutions to the preamble... + while () + { + if($sw_os eq "CYGWIN_NT") + { + $_ =~ s/^WRF_DIR.*$/COMPILING_ON_CYGWIN_NT = yes/; # will get from environment + } + + $_ =~ s:CONFIGURE_NETCDFF_LIB:$sw_netcdff_lib:g; + @preamble = ( @preamble, $_ ) ; + } + close ARCH_PREAMBLE; + + + print CONFIGURE_WRF @preamble; + close ARCH_PREAMBLE; + printf CONFIGURE_WRF "#\n"; + printf CONFIGURE_WRF "# Settings for %s \n", $optstr[$optchoice]; + printf CONFIGURE_WRF "#\n"; + print CONFIGURE_WRF @machopts; + + open ARCH_POSTAMBLE, "< arch/postamble" || die "cannot open arch/postamble: \n"; + while() + { + $_ =~ s:CONFIGURE_NETCDFF_LIB:$sw_netcdff_lib:g; + print CONFIGURE_WRF; + } + + close ARCH_POSTAMBLE; +close CONFIGURE_WPS; + +printf "Configuration successful. To build the WPS, type: compile\n"; +printf "------------------------------------------------------------------------\n"; diff --git a/WPS/arch/configure.defaults b/WPS/arch/configure.defaults new file mode 100644 index 00000000..72990a63 --- /dev/null +++ b/WPS/arch/configure.defaults @@ -0,0 +1,789 @@ +######################################################################################################################## +#ARCH Linux ppc64 BG bglxf compiler with blxlc # dmpar +# +COMPRESSION_LIBS = -L$(JASPERLIB) -ljasper -lpng -lz +COMPRESSION_INC = -I$(JASPERINC) +NCARG_LIBS = +NCARG_LIBS2 = -L/usr/local/lib64/r4i4 -lncarg -lncarg_gks -lncarg_c \ + -L/usr/X11R6/lib -lX11 +BGL_SYS = /bgl/BlueLight/ppcfloor/bglsys +MPI_INC = -I$(BGL_SYS)/include +MPI_LIB = -L$(BGL_SYS)/lib -lmpich.rts -lmsglayer.rts -lrts.rts -ldevices.rts +FC = blrts_xlf90 +SFC = blrts_xlf90 +CC = blrts_xlc +LD = $(FC) +FFLAGS = -qfree=f90 $(MPI_INC) +F77FLAGS = -qfixed $(MPI_INC) +FNGFLAGS = $(FFLAGS) +LDFLAGS = +SCC = cc +CFLAGS = $(MPI_INC) +# this might be different on different systems but we want the xlf version of cpp, not Linux's +# on frost.ucar.edu +CPP = /opt/ibmcmp/xlf/9.1/exe/cpp -P -traditional +# on NYBlue +CPP = /opt/ibmcmp/xlf/bg/10.1/exe/cpp -P -traditional +CPPFLAGS = -DAIX -DIBM4 -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = + +######################################################################################################################## +#ARCH Linux i486 i586 i686, PGI compiler # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +NCARG_LIBS2 = -L${PGI}/linux86/6.1/lib -lpgftnrtl -lpgc \ + -L/usr/lib/gcc-lib/i386-redhat-linux/3.2.3 -lg2c +SFC = pgf90 +SCC = pgcc +DM_FC = mpif90 +DM_CC = mpicc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -Mfree -byteswapio -O +F77FLAGS = -Mfixed -byteswapio -O +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = -O +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Linux i486 i586 i686, Intel compiler # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = ifort +SCC = icc +DM_FC = mpif90 -f90=ifort +DM_CC = mpicc -cc=icc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -FR -convert big_endian +F77FLAGS = -FI -convert big_endian +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = -w +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Linux i486 i586 i686, g95 # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = g95 +SCC = gcc +DM_FC = mpif90 -f90=g95 +DM_CC = mpicc -cc=gcc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -ffree-form -O -fendian=big +F77FLAGS = -ffixed-form -O -fendian=big +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_DOUBLEUNDERSCORE -DBYTESWAP -DLINUXG95 -DIO_NETCDF -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Linux i486 i586 i686, gfortran # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = gfortran +SCC = gcc +DM_FC = mpif90 -f90=gfortran +DM_CC = mpicc -cc=gcc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -ffree-form -O -fconvert=big-endian -frecord-marker=4 +F77FLAGS = -ffixed-form -O -fconvert=big-endian -frecord-marker=4 +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DBIT32 -DNO_SIGNAL CONFIGURE_MPI +RANLIB = ranlib + +######################################################################################################################## +#ARCH Linux x86_64, gfortran # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = gfortran +SCC = gcc +DM_FC = mpif90 -f90=gfortran +DM_CC = mpicc -cc=gcc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -ffree-form -O -fconvert=big-endian -frecord-marker=4 +F77FLAGS = -ffixed-form -O -fconvert=big-endian -frecord-marker=4 +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DBIT32 -DNO_SIGNAL CONFIGURE_MPI +RANLIB = ranlib + +######################################################################################################################## +#ARCH Linux x86_64, PGI compiler # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +NCARG_LIBS2 = -L${PGI}/linux86-64/5.2/lib -lpgftnrtl -lpgc \ + -L/usr/lib64 -lg2c +SFC = pgf90 +SCC = pgcc +DM_FC = mpif90 +DM_CC = mpicc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -Mfree -byteswapio -O +F77FLAGS = -Mfixed -byteswapio -O +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = -O +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Linux x86_64, PGI compiler, SGI MPT # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +NCARG_LIBS2 = -L${PGI}/linux86-64/5.2/lib -lpgftnrtl -lpgc \ + -L/usr/lib64 -lg2c +SFC = pgf90 +SCC = pgcc +DM_FC = $(SFC) -I$(MPI_ROOT)/include +DM_CC = $(SCC) -I$(MPI_ROOT)/include +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -Mfree -byteswapio -O +F77FLAGS = -Mfixed -byteswapio -O +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = -L$(MPI_ROOT)/lib -lmpi +CFLAGS = -w -O3 +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Linux x86_64, IA64 and Opteron # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = pathf90 +SCC = pathcc +DM_FC = mpif90 -f90=pathf90 +DM_CC = mpicc -cc=pathcc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -freeform -fno-second-underscore -byteswapio -O +F77FLAGS = -byteswapio -fno-second-underscore -O +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = -O +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Linux x86_64, Intel compiler # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = ifort +SCC = icc +DM_FC = mpif90 -f90=ifort +DM_CC = mpicc -cc=icc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -FR -convert big_endian +F77FLAGS = -FI -convert big_endian +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = -w +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Linux x86_64, Intel compiler, SGI MPT # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = ifort +SCC = icc +DM_FC = $(SFC) -I$(MPI_ROOT)/include +DM_CC = $(SCC) -I$(MPI_ROOT)/include +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -FR -convert big_endian +F77FLAGS = -FI -convert big_endian +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = -L$(MPI_ROOT)/lib -lmpi +CFLAGS = -w +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Linux x86_64, Intel compiler, IBM POE # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = ifort +SCC = icc +DM_FC = mpfort +DM_CC = mpcc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -FR -convert big_endian +F77FLAGS = -FI -convert big_endian +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = -w +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Darwin Intel PGI compiler # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = pgf90 +SCC = pgcc +DM_FC = mpif90 +DM_CC = mpicc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -Mfree -byteswapio -O2 +F77FLAGS = -Mfixed -byteswapio -O2 +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = -g +CFLAGS = -O +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 -DMACOS CONFIGURE_MPI +ARFLAGS = +RANLIB = ranlib +CC_TOOLS = + +######################################################################################################################## +#ARCH Darwin Intel PGI compiler; optional DM -f90=pgf90 # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = pgf90 +SCC = pgcc +DM_FC = mpif90 -f90=pgf90 +DM_CC = mpicc -cc=pgcc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -Mfree -byteswapio -O2 +F77FLAGS = -Mfixed -byteswapio -O2 +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = -g +CFLAGS = -O +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 -DMACOS CONFIGURE_MPI +ARFLAGS = +RANLIB = ranlib +CC_TOOLS = + +######################################################################################################################## +#ARCH Darwin Intel Intel compiler # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = ifort +SCC = icc +DM_FC = mpif90 +DM_CC = mpicc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -FR -convert big_endian +F77FLAGS = -FI -convert big_endian +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = -w +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 -DMACOS CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Darwin Intel g95 compiler # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = g95 +SCC = gcc +DM_FC = mpif90 -f90=g95 +DM_CC = mpicc -cc=gcc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -ffree-form -g -fendian=big +F77FLAGS = -ffixed-form -g -fendian=big +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = -g +CFLAGS = -g +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_DOUBLEUNDERSCORE -DBYTESWAP -DIO_NETCDF -DBIT32 -DMACOS CONFIGURE_MPI +ARFLAGS = +RANLIB = ranlib +CC_TOOLS = + +######################################################################################################################## +#ARCH Darwin Intel gfortran/gcc # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = gfortran +SCC = gcc +DM_FC = mpif90 +DM_CC = mpicc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -ffree-form -O -fconvert=big-endian -frecord-marker=4 +F77FLAGS = -ffixed-form -O -fconvert=big-endian -frecord-marker=4 +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DIO_NETCDF -DBIT32 -DMACOS -DNO_SIGNAL CONFIGURE_MPI +ARFLAGS = +RANLIB = ranlib +CC_TOOLS = + +######################################################################################################################## +#ARCH Darwin Intel gfortran/clang # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = gfortran +SCC = clang +DM_FC = mpif90 +DM_CC = mpicc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -ffree-form -O -fconvert=big-endian -frecord-marker=4 +F77FLAGS = -ffixed-form -O -fconvert=big-endian -frecord-marker=4 +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +# For a WRF OpenMP build, add the gomp library for WPS +LDFLAGS = # -lgomp +CFLAGS = +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DIO_NETCDF -DBIT32 -DMACOS -DNO_SIGNAL CONFIGURE_MPI +ARFLAGS = +RANLIB = ranlib +CC_TOOLS = + +######################################################################################################################## +#ARCH Darwin PPC xlf # serial serial_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +NCARG_LIBS = -L$(NCARG_ROOT)/lib -lncarg -lcgm -lncarg_gks -lncarg_c \ + -L/usr/X11R6/lib -lX11 \ + -L/opt/ibmcmp/xlf/8.1/lib -lg2c +SFC = xlf90_r +SCC = gcc-3.3 # NCAR silly thing +SCC = cc +DM_FC = mpif90 -f90=$(SFC) +DM_CC = mpicc -cc=$(SCC) +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -qfree +F77FLAGS = -qfixed +FCSUFFIX = +FNGFLAGS = $(FFLAGS) -qextname +LDFLAGS = -Wl,-stack_size,10000000,-stack_addr,0xc000000 +CFLAGS = -O +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -DAIX -DMACOS -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +RANLIB = ranlib +CC_TOOLS = +#CC = gcc-3.3 # NCAR silly thing + +######################################################################################################################## +#ARCH Darwin PPC xlf gcc3.3 SystemStubs # serial serial_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +NCARG_LIBS = -L$(NCARG_ROOT)/lib -lncarg -lcgm -lncarg_gks -lncarg_c \ + -L/usr/X11R6/lib -lX11 \ + -L/opt/ibmcmp/xlf/8.1/lib -lg2c +SFC = xlf90_r +SCC = gcc-3.3 +DM_FC = mpif90 -f90=$(SFC) +DM_CC = mpicc -cc=$(SCC) +FFLAGS = -qfree +F77FLAGS = -qfixed +FNGFLAGS = $(FFLAGS) -qextname +LDFLAGS = -Wl,-stack_size,10000000,-stack_addr,0xc0000000 -L/usr/lib -lSystemStubs +FC = CONFIGURE_FC +CC = CONFIGURE_CC +CFLAGS = -O +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -DAIX -DMACOS -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +RANLIB = ranlib + +######################################################################################################################## +#ARCH Darwin PPC g95 # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = g95 +SCC = gcc +DM_FC = mpif90 -f90=g95 +DM_CC = mpicc -cc=gcc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -ffree-form -g -fno-second-underscore +F77FLAGS = -ffixed-form -g -fno-second-underscore +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = -g +CFLAGS = -g +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUXG95 -DIO_NETCDF -DBIT32 CONFIGURE_MPI +ARFLAGS = +RANLIB = ranlib +CC_TOOLS = + +######################################################################################################################## +#ARCH AIX # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +NCARG_LIBS = +NCARG_LIBS2 = -L/usr/local/lib64/r4i4 -lncarg -lncarg_gks -lncarg_c \ + -L/usr/X11R6/lib -lX11 -lpng_ncl -lz_ncl +SFC = xlf90_r +SCC = cc +DM_FC = mpxlf90_r +DM_CC = mpcc_r +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +AR = ar +FFLAGS = -qfree=f90 +F77FLAGS = -qfixed +FCSUFFIX = -qsuffix=f=f90 +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = +CPP = /usr/lib/cpp -P -traditional +CPPFLAGS = -DAIX -DIBM4 -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = + +######################################################################################################################## +#ARCH Compaq OSF1 alpha # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = f90 +SCC = cc +DM_FC = mpif90 +DM_CC = mpicc +FC = CONFIGURE_FC +CC = CONFIGURE_FC +LD = $(FC) +FFLAGS = -free -convert big_endian +F77FLAGS = -convert big_endian +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DALPHA -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = + +######################################################################################################################## +#ARCH Linux x86_64 g95 compiler # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = g95 +SCC = gcc +DM_FC = mpif90 -f90=$(SFC) +DM_CC = mpicc -cc=$(SCC) +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -ffree-form -g -fno-second-underscore +F77FLAGS = -ffixed-form -g -fno-second-underscore +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = -g +CFLAGS = -g +CPP = /usr/bin/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUXG95 -DIO_NETCDF -DBIT32 CONFIGURE_MPI +ARFLAGS = + +######################################################################################################################## +#ARCH CYGWIN_NT i686 x86_64 PGI compiler on Windows # serial_NO_GRIB2 dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +#NCARG_LIBS2 = -L${PGI}/linux86/6.1/lib -lpgftnrtl -lpgc \ +# -L/usr/lib/gcc-lib/i386-redhat-linux/3.2.3 -lg2c +WRF_LIB = $(WRF_DIR)/external/io_grib1/libio_grib1.a \ + $(WRF_DIR)/external/io_grib_share/libio_grib_share.a \ + $(WRF_DIR)/external/io_int/libwrfio_int.a \ + $(WRF_DIR)/external/io_netcdf/libwrfio_nf.a \ + $(NETCDF)/lib/libnetcdf.lib +SFC = pgf90 +SCC = pgcc +DM_FC = pgf90 -Mmpi=msmpi +DM_CC = pgcc -Mmpi=msmpi +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -Mfree -g +F77FLAGS = -Mfixed -g +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = -g +CFLAGS = -g +CPP = cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DWIN32 -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = + +######################################################################################################################## +#ARCH SGI IRIX64 # serial serial_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = f90 +SCC = cc +DM_FC = mpif90 +DM_CC = mpicc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -freeform -64 +F77FLAGS = -64 +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = -64 +CFLAGS = -64 +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DSGI -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH SGI Altix 4700 Linux ia64 Intel # dmpar +# +#COMPRESSION_LIBS = -L/contrib/jasper/lib -ljasper \ +# -L/contrib/libpng/lib -lpng \ +# -L/contrib/zlib/lib -lz +#COMPRESSION_INC = -I/contrib/zlib/include \ +# -I/contrib/jasper/include \ +# -I/contrib/libpng/include +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = ifort +SCC = icc +DM_FC = ifort -lmpi +DM_CC = icc -lmpi +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -FR -convert big_endian +F77FLAGS = -FI -convert big_endian +FCSUFFIX = +FNGFLAGS = +LDFLAGS = +CFLAGS = -w +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Sun SunOS # serial serial_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = f90 +SCC = cc +DM_FC = +DM_CC = +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -free +F77FLAGS = +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = -O +CPP = /usr/ccs/lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = + +######################################################################################################################## +#ARCH Cray XE/XC CLE/Linux x86_64, Cray compiler # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = ftn +SCC = gcc +DM_FC = ftn +DM_CC = cc +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -N255 -f free -h byteswapio +F77FLAGS = -N255 -f fixed -h byteswapio +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = -O2 +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH Cray XC CLE/Linux x86_64, Intel compiler # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 +# +COMPRESSION_LIBS = CONFIGURE_COMP_L +COMPRESSION_INC = CONFIGURE_COMP_I +FDEFS = CONFIGURE_FDEFS +SFC = ftn +SCC = cc +DM_FC = $(SFC) +DM_CC = $(SCC) +FC = CONFIGURE_FC +CC = CONFIGURE_CC +LD = $(FC) +FFLAGS = -FR -convert big_endian +F77FLAGS = -FI -convert big_endian +FCSUFFIX = +FNGFLAGS = $(FFLAGS) +LDFLAGS = +CFLAGS = +CPP = /lib/cpp -P -traditional +CPPFLAGS = -D_UNDERSCORE -DBYTESWAP -DLINUX -DIO_NETCDF -DIO_BINARY -DIO_GRIB1 -DBIT32 CONFIGURE_MPI +ARFLAGS = +CC_TOOLS = + +######################################################################################################################## +#ARCH NULL # serial serial_NO_GRIB2 dmpar dmpar_NO_GRIB2 + +#DM_FC = +#DM_CC = +#FC = +#SFC = +#LD = +#RWORDSIZE = +#PROMOTION = +#FCOPTIM = +#FCREDUCEDOPT = +#FCNOOPT = +#FCDEBUG = +#FORMAT_FIXED = +#FORMAT_FREE = +#FCSUFFIX = +#BYTESWAPIO = +#FCBASEOPTS = +#MODULE_SRCH_FLAG = +#TRADFLAG = +#CPP = +#AR = +#FFLAGS = +#F77FLAGS = +#FCSUFFIX = +#FNGFLAGS = +#LDFLAGS = +#CC = +#SCC = +#CFLAGS = +#CPP = +#CPPFLAGS = +#ARFLAGS = +#RANLIB = +#CC_TOOLS = diff --git a/WPS/arch/fixlinks b/WPS/arch/fixlinks new file mode 100755 index 00000000..3c54a249 --- /dev/null +++ b/WPS/arch/fixlinks @@ -0,0 +1,9 @@ +#!/bin/csh -f +set echo +/bin/rm metgrid/src/cio.c +/bin/cp geogrid/src/cio.c metgrid/src/cio.c +/bin/rm ungrib/src/debug_cio.c +/bin/cp geogrid/src/cio.c ungrib/src/debug_cio.c +/bin/rm util/src/cio.c +/bin/cp geogrid/src/cio.c util/src/cio.c + diff --git a/WPS/arch/postamble b/WPS/arch/postamble new file mode 100644 index 00000000..c5dae242 --- /dev/null +++ b/WPS/arch/postamble @@ -0,0 +1,27 @@ +# +# Macros, these should be generic for all machines + +LN = ln -sf +MAKE = make -i -r +RM = /bin/rm -f +CP = /bin/cp +AR = ar ru + +.IGNORE: +.SUFFIXES: .c .f .F .o + +# There is probably no reason to modify these rules + +.c.o: + $(RM) $@ + $(CC) $(CPPFLAGS) $(CFLAGS) -c $< + +.f.o: + $(RM) $@ $*.mod + $(FC) $(F77FLAGS) -c $< $(WRF_INCLUDE) + +.F.o: + $(RM) $@ $*.mod + $(CPP) $(CPPFLAGS) $(FDEFS) $(WRF_INCLUDE) $< > $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(WRF_INCLUDE) +# $(RM) $*.f90 diff --git a/WPS/arch/preamble b/WPS/arch/preamble new file mode 100644 index 00000000..bb1ffea7 --- /dev/null +++ b/WPS/arch/preamble @@ -0,0 +1,55 @@ +# configure.wps +# +# This file was automatically generated by the configure script in the +# top level directory. You may make changes to the settings in this +# file but be aware they will be overwritten each time you run configure. +# Ordinarily, it is necessary to run configure once, when the code is +# first installed. +# +# To permanently change options, change the settings for your platform +# in the file arch/configure.defaults, the preamble, and the postamble - +# then rerun configure. +# + +.SUFFIXES: .F .f .c .o + +SHELL = /bin/sh + +NCARG_LIBS = -L$(NCARG_ROOT)/lib -lncarg -lncarg_gks -lncarg_c \ + -lX11 -lXext -lpng -lz -lcairo -lfontconfig -lpixman-1 \ + -lfreetype -lexpat -lpthread -lbz2 -lXrender -lgfortran -lgcc + +NCARG_LIBS2 = # May be overridden by architecture specific value below + +FDEFS = -DUSE_JPEG2000 -DUSE_PNG + +# Listing of options that are usually independent of machine type. +# When necessary, these are over-ridden by each architecture. + +ARFLAGS = + +PERL = perl + +RANLIB = echo + +WRF_DIR = ../WRFV3 + +WRF_INCLUDE = -I$(WRF_DIR)/external/io_netcdf \ + -I$(WRF_DIR)/external/io_grib_share \ + -I$(WRF_DIR)/external/io_grib1 \ + -I$(WRF_DIR)/external/io_int \ + -I$(WRF_DIR)/inc \ + -I$(NETCDF)/include + +WRF_LIB = -L$(WRF_DIR)/external/io_grib1 -lio_grib1 \ + -L$(WRF_DIR)/external/io_grib_share -lio_grib_share \ + -L$(WRF_DIR)/external/io_int -lwrfio_int \ + -L$(WRF_DIR)/external/io_netcdf -lwrfio_nf \ + -L$(NETCDF)/lib CONFIGURE_NETCDFF_LIB -lnetcdf + +#### Architecture specific settings #### + +COMPRESSION_LIBS = # intentionally left blank, fill in COMPRESSION_LIBS below + +COMPRESSION_INC = # intentionally left blank, fill in COMPRESSION_INC below + diff --git a/WPS/arch/sourceme_windows.bash b/WPS/arch/sourceme_windows.bash new file mode 100644 index 00000000..13f09121 --- /dev/null +++ b/WPS/arch/sourceme_windows.bash @@ -0,0 +1,4 @@ +export WRF_DIR=../../../WRFV3 +export WRF_DIR_PRE=/c/WPS/geogrid/src/ +export UP_ONE=../ + diff --git a/WPS/arch/sourceme_windows.csh b/WPS/arch/sourceme_windows.csh new file mode 100644 index 00000000..88f0ee9b --- /dev/null +++ b/WPS/arch/sourceme_windows.csh @@ -0,0 +1,4 @@ +setenv WRF_DIR ../../../WRFV3 +setenv WRF_DIR_PRE /c/WPS/geogrid/src/ +setenv UP_ONE ../ + diff --git a/WPS/arch/zaplinks b/WPS/arch/zaplinks new file mode 100755 index 00000000..51bf5ed9 --- /dev/null +++ b/WPS/arch/zaplinks @@ -0,0 +1,7 @@ +#!/bin/csh -f +echo do an svn update to restore these as symlinks +set echo +/bin/rm metgrid/src/cio.c +/bin/rm ungrib/src/debug_cio.c +/bin/rm util/src/cio.c + diff --git a/WPS/clean b/WPS/clean new file mode 100755 index 00000000..862376fb --- /dev/null +++ b/WPS/clean @@ -0,0 +1,73 @@ +#!/bin/csh -f + +set DEV_TOP = `pwd` + +set TOUCH = ORIG +if ( ! -e configure.wps ) then + touch configure.wps + set TOUCH = TOUCH +endif + +set nonomatch + +set DIRS = ( geogrid ungrib metgrid ungrib ungrib util util util util util util util util ) +set EXES = ( geogrid ungrib metgrid g1print g2print plotfmt plotgrids mod_levs rd_intermediate avg_tsfc calc_ecmwf_p height_ukmo int2nc ) + +set i = 1 +foreach dir ( $DIRS ) + if ( -d $dir ) then + ( cd $dir ; make -i DEV_TOP="${DEV_TOP}" TARGET="$EXES[$i].exe" clean ) + endif + /bin/rm -f $EXES[$i].exe + if ( $EXES[$i] == "g1print" || $EXES[$i] == "g2print" ) then + /bin/rm -f util/$EXES[$i].exe + endif + @ i ++ +end + +#rm gmeta + +#if ( -e GRIBFILE.AAA ) then +# /bin/rm -f GRIBFILE.[A-Z][A-Z][A-Z] +#endif + +#/bin/rm -f FILE:[0-9][0-9][0-9][0-9]-[0-9][0-9]-[0-9][0-9]_[0-9][0-9] >& /dev/null + +#if ( -e Vtable ) then +# /bin/rm -f Vtable +#endif + +#foreach core ( em nmm ) +# foreach io_form ( nc bin grib ) +# /bin/rm -f geo_${core}.d[0-9][0-9].${io_form} >& /dev/null +# /bin/rm -f met_${core}.d[0-9][0-9].*.${io_form} >& /dev/null +# end +#end + +#if ( -e geogrid.log ) then +# /bin/rm -f geogrid.log +#endif + +#if ( -e metgrid.log ) then +# /bin/rm -f metgrid.log +#endif + +if ( "$1" == '-a' ) then + /bin/rm -rf ./netcdf_links + foreach dir ( $DIRS ) + if ( -d $dir ) then + ( cd $dir ; make -i DEV_TOP="${DEV_TOP}" TARGET="${dir}.exe" superclean >& /dev/null ) + endif + if { test -h ${dir}.exe } then + /bin/rm -f ${dir}.exe + endif + end + if ( ( -e configure.wps ) && ( $TOUCH != TOUCH ) ) then + /bin/cp -p configure.wps configure.wps.backup + /bin/rm -f configure.wps + endif +endif + +if ( ( $TOUCH == TOUCH ) && ( -e configure.wps ) ) then + /bin/rm -f configure.wps +endif diff --git a/WPS/compile b/WPS/compile new file mode 100755 index 00000000..043ba780 --- /dev/null +++ b/WPS/compile @@ -0,0 +1,164 @@ +#!/bin/csh -f + +if ( ! -e configure.wps ) then + echo "Do 'configure' first" + exit ( 1 ) +endif + +if ( ( ! $?NETCDF ) && ( -d netcdf_links ) ) then + setenv NETCDF `pwd`/netcdf_links + setenv temp_netcdf 1 +else + setenv temp_netcdf 0 +endif + +set DEV_TOP = `pwd` +set first_char = `grep ^WRF_DIR configure.wps | awk '{print $3}' | cut -c -1` + + +## test for Cygwin on Windows +grep CYGWIN_NT configure.wps >& /dev/null +if ( $status == 0 ) then + ls -l */*/*cio.c | grep '^l' + if ( $status == 0 ) then + echo Symbolic links are not handled properly by pgcc on Windows. Run arch/fixlinks in this directory and try again. + exit + endif +else + if ( "$first_char" == "/" ) then + set WRF_DIR_PRE = + else + set WRF_DIR_PRE = ${DEV_TOP}/ + endif +endif + +if ( ${#argv} == 0 ) then + set names = ( geogrid ungrib metgrid g1print g2print rd_intermediate mod_levs avg_tsfc calc_ecmwf_p height_ukmo int2nc ) + set NAMES = ( GEOGRID UNGRIB METGRID GRIBUTIL GRIBUTIL UTIL UTIL UTIL UTIL UTIL UTIL ) +else if ( $1 == wps ) then + set names = ( geogrid ungrib metgrid ) + set NAMES = ( GEOGRID UNGRIB METGRID ) +else if ( $1 == util ) then + set names = ( g1print g2print plotfmt rd_intermediate plotgrids mod_levs avg_tsfc calc_ecmwf_p height_ukmo int2nc ) + set NAMES = ( GRIBUTIL GRIBUTIL UTIL UTIL UTIL UTIL UTIL UTIL UTIL UTIL ) +else if ( $1 == geogrid ) then + set names = ( geogrid ) + set NAMES = ( GEOGRID ) +else if ( $1 == ungrib ) then + set names = ( ungrib ) + set NAMES = ( UNGRIB ) +else if ( $1 == metgrid ) then + set names = ( metgrid ) + set NAMES = ( METGRID ) +else if ( $1 == g1print ) then + set names = ( g1print ) + set NAMES = ( GRIBUTIL ) +else if ( $1 == g2print ) then + set names = ( g2print ) + set NAMES = ( GRIBUTIL ) +else if ( $1 == plotfmt ) then + set names = ( plotfmt ) + set NAMES = ( UTIL ) +else if ( $1 == rd_intermediate ) then + set names = ( rd_intermediate ) + set NAMES = ( UTIL ) +else if ( $1 == plotgrids ) then + set names = ( plotgrids ) + set NAMES = ( UTIL ) +else if ( $1 == mod_levs ) then + set names = ( mod_levs ) + set NAMES = ( UTIL ) +else if ( $1 == avg_tsfc ) then + set names = ( avg_tsfc ) + set NAMES = ( UTIL ) +else if ( $1 == calc_ecmwf_p ) then + set names = ( calc_ecmwf_p ) + set NAMES = ( UTIL ) +else if ( $1 == height_ukmo ) then + set names = ( height_ukmo ) + set NAMES = ( UTIL ) +else if ( $1 == int2nc ) then + set names = ( int2nc ) + set NAMES = ( UTIL ) +else + echo "*****" + echo " " + echo "Unrecognized compile target $1." + echo " " + echo "Usage: compile [target]" + echo "where target is one of" + echo " wps" + echo " util" + echo " geogrid" + echo " ungrib" + echo " metgrid" + echo " g1print" + echo " g2print" + echo " plotfmt" + echo " rd_intermediate" + echo " plotgrids" + echo " mod_levs" + echo " avg_tsfc" + echo " calc_ecmwf_p" + echo " height_ukmo" + echo " int2nc" + echo " " + echo " or just run compile with no target to build everything." + echo " " + echo "*****" + exit(1) +endif + +# Print out WPS version, system info, and compiler/version +echo "============================================================================================== " + echo " " + echo Version 3.9 + echo " " + uname -a + echo " " + set comp = ( `grep "^SFC" configure.wps | cut -d"=" -f2-` ) + if ( "$comp[1]" == "gfortran" ) then + gfortran --version + else if ( "$comp[1]" == "pgf90" ) then + pgf90 --version + else if ( "$comp[1]" == "ifort" ) then + ifort -V + else + echo "Not sure how to figure out the version of this compiler: $comp[1]" + endif + echo " " + echo "============================================================================================== " + echo " " + + +echo " " +if ( ${#argv} == 0 ) then + echo "**** Compiling WPS and all utilities ****" +else + echo "**** Compiling $1 ****" +endif +echo " " + +set count = 1 +foreach f ( $names ) + if ("$NAMES[$count]" == "UTIL") then + ( cd util ; make -i -r WRF_DIR_PRE="${WRF_DIR_PRE}" DEV_TOP="${DEV_TOP}" TARGET="${f}.exe" CPP_TARGET="$NAMES[$count]" all ) + else if ("$NAMES[$count]" == "GRIBUTIL") then + ( cd ungrib ; make -i -r WRF_DIR_PRE="${WRF_DIR_PRE}" DEV_TOP="${DEV_TOP}" TARGET="${f}.exe" CPP_TARGET="$NAMES[$count]" all ) + if ( -e ungrib/src/${f}.exe ) then + ( cd util ; ln -sf ../ungrib/src/${f}.exe . ) + endif + else + ( cd $f ; make -i -r WRF_DIR_PRE="${WRF_DIR_PRE}" DEV_TOP="${DEV_TOP}" TARGET="${f}.exe" CPP_TARGET="$NAMES[$count]" all ) + if ( -e ${f}/src/${f}.exe ) then + ln -sf ${f}/src/${f}.exe . + endif + endif + @ count ++ +end + +if ( $temp_netcdf == 1 ) then + unsetenv NETCDF +endif + +exit(0) diff --git a/WPS/configure b/WPS/configure new file mode 100755 index 00000000..903c9ced --- /dev/null +++ b/WPS/configure @@ -0,0 +1,394 @@ +#!/bin/sh + +arg1=$1 + +# Look for netcdf +if test -z "$NETCDF" ; then + for p in /usr/local/netcdf + do + if test -d $p ; then + NETCDF=$p + break + fi + done +fi + +if test -z "$NETCDF" ; then + + if [ `hostname | cut -c 1-2` = "bs" -o \ + `hostname | cut -c 1-2` = "bv" -o \ + `hostname` = "tempest" -o `hostname` = "lightning" ] ; then + echo 'Compiling on an NCAR system with weird paths to NetCDF' + echo 'Setting up a local NetCDF directory with symlinks' + if ( test -d ./netcdf_links ) ; then + echo 'A directory ./netcdf_links already exists. Continuing.' + else + mkdir ./netcdf_links + if [ -z "$OBJECT_MODE" ] ; then + OBJECT_MODE=32 + export OBJECT_MODE + fi + if [ $OBJECT_MODE -ne 64 -a \( `hostname | cut -c 1-2` = "bs" \) ] ; then + ( cd ./netcdf_links ; ln -s /usr/local/lib32/r4i4 ./lib ; \ + ln -s /usr/local/include ./include ) + else + ( cd ./netcdf_links ; ln -s /usr/local/lib64/r4i4 ./lib ; \ + ln -s /usr/local/include ./include ) + fi + fi + NETCDF=`pwd`/netcdf_links + export NETCDF + + + else + bedone="" + if [ -d ./netcdf_links ] ; then + echo '** There is an existing ./netcdf_links file. Should I use? [y]' + read resp + if [ "$resp" = "y" ] ; then + NETCDF=`pwd`/netcdf_links + bedone="yes" + else + echo 'Removing existing ./netcdf_links directory' + /bin/rm -fr ./netcdf_links + fi + else + echo '** WARNING: No path to NETCDF and environment variable NETCDF not set.' + echo '** would you like me to try to fix? [y]' + fi + netcdfipath="" + netcdflpath="" + while [ -z "$bedone" ] ; do + read resp + if [ "$resp" = "y" -o -z "$resp" ] ; then + if [ -d ./netcdf_links ] ; then + echo 'There is already a ./netcdf_links directory. Okay to use links' + echo 'in this directory for NetCDF include and lib dirs? [y]' + read resp + if [ "$resp" = "y" ] ; then + NETCDF=`pwd`/netcdf_links + export NETCDF + bedone="yes" + continue + fi + fi + if [ -z "$netcdfipath" ] ; then + echo 'Enter full path to NetCDF include directory on your system' + read resp + if [ ! -d "$resp" ] ; then + echo "invalid path: $resp. Try again? [y]" ; continue + fi + netcdfipath=$resp + fi + if [ -z "$netcdflpath" ] ; then + echo 'Enter full path to NetCDF library directory on your system' + read resp + if [ ! -d "$resp" ] ; then + echo "invalid path: $resp. Try again? [y]" ; continue + fi + netcdflpath=$resp + fi + + if [ -n "$netcdflpath" -a -n "$netcdfipath" ] ; then + if [ -d ./netcdf_links ] ; then + echo 'Existing ./netcdf_links directory. Okay to remove. [y]' + read resp + if [ "$resp" = "y" ] ; then + /bin/rm -fr ./netcdf_links + fi + fi + mkdir ./netcdf_links + cd ./netcdf_links + ln -s "$netcdfipath" include + ln -s "$netcdflpath" lib + cd .. + echo created new ./netcdf_links directory + /bin/ls -lF ./netcdf_links + NETCDF=`pwd`/netcdf_links + export NETCDF + bedone="yes" + fi + else + bedone="yes" + fi + done + fi +fi + +if [ -n "$NETCDF" ] ; then + echo "Will use NETCDF in dir: $NETCDF" + # for 3.6.2 and greater there might be a second library, libnetcdff.a . Check for this and use + # if available + NETCDFF=" " + if [ -f "$NETCDF/lib/libnetcdff.a" ] ; then + NETCDFF="-lnetcdff" + fi +else + echo "Will configure for use without NetCDF" +fi + + # if the uname command exists, give it a shot and see if + # we can narrow the choices; otherwise, spam 'em + os="ARCH" + mach="ARCH" + type uname > /dev/null +if [ $? -eq 0 ] ; then + os=`uname` + if [ "$os" = "AIX" -o "$os" = "IRIX" -o "$os" = "IRIX64" -o "$os" = "SunOS" -o "$os" = "HP-UX" -o "$os" = "Darwin" ] ; then + mach="ARCH" + else + xxx=`expr "$os" : '\(.........\).*'` + if [ "$xxx" = "CYGWIN_NT" ] ; then + os=$xxx + fi + if [ "$os" = "OSF1" -o "$os" = "Linux" -o "$os" = "UNICOS/mp" -o "$os" = "UNIX_System_V" -o "$os" = "CYGWIN_NT" ] ; then + mach=`uname -m` + else + os="ARCH" + mach="ARCH" + fi + fi +fi + +# Found perl, so proceed with configuration +perl arch/Config.pl -perl=$PERL -netcdf=$NETCDF -netcdff=$NETCDFF -os=$os -mach=$mach + + +#Checking cross-compiling capability for some particular environment +#on Linux and Mac box + +if [ $os = "Linux" -o $os = "Darwin" ]; then + + SFC=`grep '^SFC' configure.wps | awk '{print $3}'` + SCC=`grep '^SCC' configure.wps | awk '{print $3}'` + + SFC="`type $SFC 2>/dev/null | awk '{print $NF}' | sed -e 's/(//g;s/)//g'`" + SCC="`type $SCC 2>/dev/null | awk '{print $NF}' | sed -e 's/(//g;s/)//g'`" + + if [ -e $NETCDF/lib/libnetcdf.a -a "$SFC" != "" -a "$SCC" != "" ]; then + + SFC_MULTI_ABI=0 + SCC_MULTI_ABI=0 + CROSS_COMPILING=0 + + foo=foo_$$ + + echo + echo Testing for NetCDF, C and Fortran compiler + echo + +cat > ${foo}.c < ${foo}.f < /dev/null 2>&1 + SFC_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`" + rm ${foo} ${foo}.o 2> /dev/null + + $SCC -o ${foo} ${foo}.c > /dev/null 2>&1 + SCC_arch="`file ${foo} | grep -o -E '[0-9]{2}-bit|i386'`" + rm ${foo} ${foo}.o 2> /dev/null + + if [ "$SFC_arch" = "" -o "$SCC_arch" = "" ]; then + echo " One of compilers testing failed!" + echo " Please check your compiler" + echo + rm -f ${foo} ${foo}.[cfo] 2> /dev/null + exit + else + cp configure.wps configure.wps.edit + fi + + case $netcdf_arch in + + 32-bit|i386 ) + + if [ "$SFC_arch" = "64-bit" ] ; then + CROSS_COMPILING=1 + $SFC -m32 -o ${foo} ${foo}.f > /dev/null 2>&1 + if [ $? = 0 ]; then + SFC_MULTI_ABI=1 + sed '/^SFC.*=/s/$/ -m32/' configure.wps.edit > configure.wps.tmp + mv configure.wps.tmp configure.wps.edit + fi + fi + if [ "$SCC_arch" = "64-bit" ] ; then + CROSS_COMPILING=1 + $SCC -m32 -o ${foo} ${foo}.c > /dev/null 2>&1 + if [ $? = 0 ]; then + SCC_MULTI_ABI=1 + sed '/^SCC.*=/s/$/ -m32/' configure.wps.edit > configure.wps.tmp + mv configure.wps.tmp configure.wps.edit + fi + fi + + if [ $CROSS_COMPILING -eq 1 ] ; then + echo NOTE: + echo This installation NetCDF is 32-bit + if [ \( $SFC_MULTI_ABI -ne 1 -a "$SFC_arch" = "64-bit" \) \ + -o \( $SCC_MULTI_ABI -ne 1 -a "$SCC_arch" = "64-bit" \) ] ; then + rm configure.wps.edit + echo One of compilers is 64-bit and doesn\'t support cross-compiling. + echo Please check your NETCDF lib and compiler + else + echo -m32 is appended to configure.wps + echo It will be forced to build in 32-bit. + echo If you don\'t want 32-bit binaries, please use 64-bit NetCDF, and re-run the configure script. + fi + fi + ;; + + 64-bit ) + + if [ "$SFC_arch" = "32-bit" -o "$SFC_arch" = "i386" ] ; then + CROSS_COMPILING=1 + $SFC -m64 -o ${foo} ${foo}.f > /dev/null 2>&1 + if [ $? = 0 ]; then + SFC_MULTI_ABI=1 + sed '/^SFC.*=/s/$/ -m64/' configure.wps.edit > configure.wps.tmp + mv configure.wps.tmp configure.wps.edit + fi + fi + if [ "$SCC_arch" = "32-bit" -o "$SCC_arch" = "i386" ] ; then + CROSS_COMPILING=1 + $SCC -m64 -o ${foo} ${foo}.c > /dev/null 2>&1 + if [ $? = 0 ]; then + SCC_MULTI_ABI=1 + sed '/^SCC.*=/s/$/ -m64/' configure.wps.edit > configure.wps.tmp + mv configure.wps.tmp configure.wps.edit + fi + fi + + if [ $CROSS_COMPILING -eq 1 ] ; then + echo NOTE: + echo This installation NetCDF is 64-bit + if [ \( $SFC_MULTI_ABI -ne 1 -a "$SFC_arch" != "64-bit" \) \ + -o \( $SCC_MULTI_ABI -ne 1 -a "$SCC_arch" != "64-bit" \) ]; then + rm configure.wps.edit + echo One of Compilers is 32-bit and doesn\'t support cross-compiling. + echo Please check your NetCDF lib and compiler + else + echo -m64 is appended to configure.wps + echo It will be forced to build in 64-bit. + echo If you don\'t want 64-bit binaries, please use 32-bit NetCDF, and re-run the configure script. + fi + fi + ;; + esac + rm -f ${foo} ${foo}.[cfo] 2> /dev/null + + if [ -e configure.wps.edit ]; then + mv configure.wps.edit configure.wps + fi + + if [ $CROSS_COMPILING -eq 0 ] ; then + echo This installation NetCDF is $netcdf_arch + echo C compiler is $SCC_arch + echo Fortran compiler is $SFC_arch + fi + echo + + # Does our Fortran work with the given NETCDF library. + + /bin/rm -f fort_netcdf.f fort_netcdf +cat > fort_netcdf.f < +#include +#include + +#ifdef _UNDERSCORE +#define cio_set_log_filename cio_set_log_filename_ +#define cio_prints cio_prints_ +#define cio_printf cio_printf_ +#define cio_printi cio_printi_ +#endif +#ifdef _DOUBLEUNDERSCORE +#define cio_set_log_filename cio_set_log_filename__ +#define cio_prints cio_prints__ +#define cio_printf cio_printf__ +#define cio_printi cio_printi__ +#endif + +char * logfilename = 0; +FILE * cio_out = 0; + +void cio_set_log_filename(char * s, int * n) +{ + /* Allow changes to the log filename so long as + * we haven't actually opened the file (and written + * to it). + */ + if (!cio_out && logfilename) + { + free(logfilename); + logfilename = 0; + } + + if (!logfilename) + { + logfilename = (char *)malloc(*n+1); + strncpy(logfilename, s, *n); + logfilename[*n] = '\0'; + } +} + +void cio_printf(int * fd, float * f) +{ + if (!logfilename) return; + + if (*fd != 0) + { + if (!cio_out) cio_out = fopen(logfilename,"w"); + fprintf(cio_out, "%f", *f); + fflush(cio_out); + } + else + { + fprintf(stdout, "%f", *f); + fflush(stdout); + } +} + +void cio_printi(int * fd, int * i) +{ + if (!logfilename) return; + + if (*fd != 0) + { + if (!cio_out) cio_out = fopen(logfilename,"w"); + fprintf(cio_out, "%i", *i); + fflush(cio_out); + } + else + { + fprintf(stdout, "%i", *i); + fflush(stdout); + } +} + +void cio_prints(int * fd, char * s, int * n) +{ + if (!logfilename) return; + + if (*fd != 0) + { + s[*n] = '\0'; + if (!cio_out) cio_out = fopen(logfilename,"w"); + fprintf(cio_out, "%s", s); + fflush(cio_out); + } + else + { + s[*n] = '\0'; + fprintf(stdout, "%s", s); + fflush(stdout); + } +} diff --git a/WPS/geogrid/src/constants_module.F b/WPS/geogrid/src/constants_module.F new file mode 100644 index 00000000..d46abe3b --- /dev/null +++ b/WPS/geogrid/src/constants_module.F @@ -0,0 +1,32 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! MODULE CONSTANTS_MODULE +! +! This module defines constants that are used by other modules +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module constants_module + + real, parameter :: PI = 3.141592653589793 + real, parameter :: OMEGA_E = 7.292e-5 ! Angular rotation rate of the earth + + real, parameter :: DEG_PER_RAD = 180./PI + real, parameter :: RAD_PER_DEG = PI/180. + + ! Mean Earth Radius in m. The value below is consistent + ! with NCEP's routines and grids. + real, parameter :: A_WGS84 = 6378137. + real, parameter :: B_WGS84 = 6356752.314 + real, parameter :: RE_WGS84 = A_WGS84 + real, parameter :: E_WGS84 = 0.081819192 + + real, parameter :: A_NAD83 = 6378137. + real, parameter :: RE_NAD83 = A_NAD83 + real, parameter :: E_NAD83 = 0.0818187034 + + real, parameter :: EARTH_RADIUS_M = 6370000. ! same as MM5 system + real, parameter :: EARTH_CIRC_M = 2.*PI*EARTH_RADIUS_M + + real, parameter :: P0 = 1.0e5 ! Reference surface pressure, Pa + real, parameter :: RD = 287.0 ! Gas constant for dry air + real, parameter :: CP = 1004.0 ! Heat capacity for dry air at const. pressure + +end module constants_module diff --git a/WPS/geogrid/src/geogrid.F b/WPS/geogrid/src/geogrid.F new file mode 100644 index 00000000..956e691d --- /dev/null +++ b/WPS/geogrid/src/geogrid.F @@ -0,0 +1,148 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Program: geogrid +! +! Written by Michael G. Duda +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +program geogrid + + use gridinfo_module + use llxy_module + use list_module + use module_debug + use parallel_module + use process_tile_module + use source_data_module + + implicit none + + ! Local variables + integer :: i, nest_level, temp + logical :: ew_extra_col, sn_extra_row + type(list) :: level_list + + ! Prepare anything necessary to do parallel processing of domains + ! The parallel module should be initialized before any other calls take place + call parallel_start() + + call mprintf(.true.,LOGFILE,' *** Starting program geogrid.exe *** ') + + ! Have the gridinfo module retrieve description of the grid setup + call get_grid_params() + + ! Get information about the source data to be processed + call get_datalist() + + if (gridtype == 'C') then + + ! Tell the llxy module that it can now compute parameters necessary to do + ! transformations for any nest + call compute_nest_locations() + + ! Process all requested domains + do i=1,n_domains + if (grid_is_active(i)) then + call mprintf(.true.,STDOUT,'Processing domain %i of %i', i1=i, i2=n_domains) + call mprintf(.true.,LOGFILE,'Processing domain %i of %i', i1=i, i2=n_domains) + + ! Get information about the source data we will use for this nest + call get_source_params(geog_data_res(i)) + + ! Set transformations in llxy module to be with respect to current nest + call select_domain(i) + + ! Determine which range of indices we will work on + call parallel_get_tile_dims(ixdim(i), jydim(i)) + + if (my_x == nproc_x-1) then ! One more column for U points + ew_extra_col = .true. + else + ew_extra_col = .false. + end if + + if (my_y == nproc_y-1) then ! One more row for V points + sn_extra_row = .true. + else + sn_extra_row = .false. + end if + + ! Process fields for a tile of the current nest + call process_tile(i, gridtype, dyn_opt, & + 1, ixdim(i), 1, jydim(i), & + my_minx, my_maxx, my_miny, my_maxy, & ! These come from parallel_module + ew_extra_col, sn_extra_row) + + ! Print summary of any optional fields that were not processed + call display_optional_field_msgs() + else + call mprintf(.true.,STDOUT,'Skipping domain %i of %i', i1=i, i2=n_domains) + call mprintf(.true.,LOGFILE,'Skipping domain %i of %i', i1=i, i2=n_domains) + end if + end do + + else if (gridtype == 'E') then + + ! Get number of grid points and grid spacing for nest levels + call compute_nest_level_info() + + ! Create list to track NMM nesting levels + call list_init(level_list) + + ! Process all requested domains + do i=1,n_domains + + nest_level = get_nest_level(i) + + if (.not. list_search(level_list, ikey=nest_level, ivalue=temp)) then + call list_insert(level_list, ikey=nest_level, ivalue=nest_level) + + if (nest_level == 1) then + call mprintf(.true.,STDOUT,'Processing coarse domain', i1=nest_level) + call mprintf(.true.,LOGFILE,'Processing coarse domain', i1=nest_level) + else + call mprintf(.true.,STDOUT,'Processing nesting level %i', i1=nest_level-1) + call mprintf(.true.,LOGFILE,'Processing nesting level %i', i1=nest_level-1) + end if + + ! Get information about the source data we will use for this nest + call get_source_params(geog_data_res(i)) + + ! Set transformations in llxy module to be with respect to current nest + call select_domain(nest_level) + + ! Determine which range of indices we will work on + call parallel_get_tile_dims(ixdim(nest_level), jydim(nest_level)) + + sn_extra_row = .false. + ew_extra_col = .false. + + ! Process fields for a tile of the current nest + call process_tile(nest_level, gridtype, dyn_opt, & + 1, ixdim(nest_level), 1, jydim(nest_level), & + my_minx, my_maxx, my_miny, my_maxy, & ! These come from parallel_module + ew_extra_col, sn_extra_row) + + ! Print summary of any optional fields that were not processed + call display_optional_field_msgs() + end if + end do + + ! Free up list that was used for tracking NMM nesting levels + call list_destroy(level_list) + + end if + + ! Free up memory used by list of source data to be processed + call datalist_destroy() + + ! Clean up parallel stuff + call parallel_finish() + + call mprintf(.true.,STDOUT,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!') + call mprintf(.true.,STDOUT,'! Successful completion of geogrid. !') + call mprintf(.true.,STDOUT,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!') + + call mprintf(.true.,LOGFILE,' *** Successful completion of program geogrid.exe *** ') + + stop + +end program geogrid diff --git a/WPS/geogrid/src/gridinfo_module.F b/WPS/geogrid/src/gridinfo_module.F new file mode 100644 index 00000000..b8543192 --- /dev/null +++ b/WPS/geogrid/src/gridinfo_module.F @@ -0,0 +1,596 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! MODULE GRIDINFO_MODULE +! +! This module handles (i.e., acquires, stores, and makes available) all data +! describing the model domains to be processed. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module gridinfo_module + + use constants_module + use misc_definitions_module + use module_debug + + ! Parameters + integer, parameter :: MAX_DOMAINS = 21 + + ! Variables + integer :: iproj_type, n_domains, io_form_output, dyn_opt + integer, dimension(MAX_DOMAINS) :: parent_grid_ratio, parent_id, ixdim, jydim + integer, dimension(MAX_DOMAINS) :: subgrid_ratio_x, subgrid_ratio_y + real :: known_lat, known_lon, pole_lat, pole_lon, stand_lon, truelat1, truelat2, & + known_x, known_y, dxkm, dykm, phi, lambda, ref_lat, ref_lon, ref_x, ref_y, & + dlatdeg, dlondeg + real, dimension(MAX_DOMAINS) :: parent_ll_x, parent_ll_y, parent_ur_x, parent_ur_y + character (len=MAX_FILENAME_LEN) :: geog_data_path, opt_output_from_geogrid_path, opt_geogrid_tbl_path + + character (len=128), dimension(MAX_DOMAINS) :: geog_data_res + character (len=1) :: gridtype + logical :: do_tiled_output + logical, dimension(MAX_DOMAINS) :: grid_is_active + integer :: debug_level + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_grid_params + ! + ! Purpose: This subroutine retrieves all parameters regarding the model domains + ! to be processed by geogrid.exe. This includes map parameters, domain + ! size and location, and nest information. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_grid_params() + + implicit none + + ! Local variables + integer :: i, j, max_dom, funit, io_form_geogrid, interval_seconds + real :: dx, dy, rparent_gridpts + integer, dimension(MAX_DOMAINS) :: i_parent_start, j_parent_start, & + s_we, e_we, s_sn, e_sn, & + start_year, start_month, start_day, start_hour, start_minute, start_second, & + end_year, end_month, end_day, end_hour, end_minute, end_second + character (len=128) :: map_proj + character (len=128), dimension(MAX_DOMAINS) :: start_date, end_date + character (len=3) :: wrf_core + logical :: is_used, nest_outside + logical, dimension(MAX_DOMAINS) :: active_grid + logical :: nocolons + + namelist /share/ wrf_core, max_dom, start_date, end_date, & + start_year, end_year, start_month, end_month, & + start_day, end_day, start_hour, end_hour, & + start_minute, end_minute, start_second, end_second, & + interval_seconds, & + io_form_geogrid, opt_output_from_geogrid_path, & + debug_level, active_grid, & + subgrid_ratio_x, subgrid_ratio_y, & + nocolons + namelist /geogrid/ parent_id, parent_grid_ratio, & + i_parent_start, j_parent_start, s_we, e_we, s_sn, e_sn, & + map_proj, ref_x, ref_y, ref_lat, ref_lon, & + pole_lat, pole_lon, truelat1, truelat2, stand_lon, & + dx, dy, geog_data_res, geog_data_path, opt_geogrid_tbl_path + + ! Set defaults for namelist variables + debug_level = 0 + io_form_geogrid = 2 + wrf_core = 'ARW' + max_dom = 1 + geog_data_path = 'NOT_SPECIFIED' + ref_x = NAN + ref_y = NAN + ref_lat = NAN + ref_lon = NAN + dx = NAN + dy = NAN + map_proj = 'Lambert' + pole_lat = 90.0 + pole_lon = 0.0 + truelat1 = NAN + truelat2 = NAN + stand_lon = NAN + do i=1,MAX_DOMAINS + geog_data_res(i) = 'default' + parent_id(i) = 1 + parent_grid_ratio(i) = INVALID + s_we(i) = 1 + e_we(i) = INVALID + s_sn(i) = 1 + e_sn(i) = INVALID + start_year(i) = 0 + start_month(i) = 0 + start_day(i) = 0 + start_hour(i) = 0 + start_minute(i) = 0 + start_second(i) = 0 + end_year(i) = 0 + end_month(i) = 0 + end_day(i) = 0 + end_hour(i) = 0 + end_minute(i) = 0 + end_second(i) = 0 + start_date(i) = '0000-00-00_00:00:00' + end_date(i) = '0000-00-00_00:00:00' + active_grid(i) = .true. + subgrid_ratio_x(i) = 1 + subgrid_ratio_y(i) = 1 + end do + opt_output_from_geogrid_path = './' + opt_geogrid_tbl_path = 'geogrid/' + interval_seconds = INVALID + nocolons = .false. + + ! Read parameters from Fortran namelist + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + open(funit,file='namelist.wps',status='old',form='formatted',err=1000) + read(funit,share) + read(funit,geogrid) + close(funit) + +! BUG: More properly handle debug_level in module_debug + if (debug_level.gt.100) then + call set_debug_level(DEBUG) + else + call set_debug_level(WARN) + end if + + call mprintf(.true.,LOGFILE,'Using the following namelist variables:') + call mprintf(.true.,LOGFILE,'&SHARE') + call mprintf(.true.,LOGFILE,' WRF_CORE = %s',s1=wrf_core) + call mprintf(.true.,LOGFILE,' MAX_DOM = %i',i1=max_dom) + call mprintf(.true.,LOGFILE,' START_YEAR = %i',i1=start_year(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_year(i)) + end do + call mprintf(.true.,LOGFILE,' START_MONTH = %i',i1=start_month(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_month(i)) + end do + call mprintf(.true.,LOGFILE,' START_DAY = %i',i1=start_day(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_day(i)) + end do + call mprintf(.true.,LOGFILE,' START_HOUR = %i',i1=start_hour(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_hour(i)) + end do + call mprintf(.true.,LOGFILE,' START_MINUTE = %i',i1=start_minute(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_minute(i)) + end do + call mprintf(.true.,LOGFILE,' START_SECOND = %i',i1=start_second(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_second(i)) + end do + call mprintf(.true.,LOGFILE,' END_YEAR = %i',i1=end_year(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_year(i)) + end do + call mprintf(.true.,LOGFILE,' END_MONTH = %i',i1=end_month(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_month(i)) + end do + call mprintf(.true.,LOGFILE,' END_DAY = %i',i1=end_day(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_day(i)) + end do + call mprintf(.true.,LOGFILE,' END_HOUR = %i',i1=end_hour(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_hour(i)) + end do + call mprintf(.true.,LOGFILE,' END_MINUTE = %i',i1=end_minute(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_minute(i)) + end do + call mprintf(.true.,LOGFILE,' END_SECOND = %i',i1=end_second(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_second(i)) + end do + call mprintf(.true.,LOGFILE,' START_DATE = %s',s1=start_date(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %s',s1=start_date(i)) + end do + call mprintf(.true.,LOGFILE,' END_DATE = %s',s1=end_date(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %s',s1=end_date(i)) + end do + call mprintf(.true.,LOGFILE,' INTERVAL_SECONDS = %i',i1=interval_seconds) + call mprintf(.true.,LOGFILE,' IO_FORM_GEOGRID = %i',i1=io_form_geogrid) + call mprintf(.true.,LOGFILE,' OPT_OUTPUT_FROM_GEOGRID_PATH = %s',s1=opt_output_from_geogrid_path) + call mprintf(.true.,LOGFILE,' SUBGRID_RATIO_X = %i',i1=subgrid_ratio_x(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=subgrid_ratio_x(i)) + enddo + call mprintf(.true.,LOGFILE,' SUBGRID_RATIO_Y = %i',i1=subgrid_ratio_y(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=subgrid_ratio_y(i)) + enddo + + call mprintf(.true.,LOGFILE,' DEBUG_LEVEL = %i',i1=debug_level) + call mprintf(.true.,LOGFILE,' ACTIVE_GRID = %l',l1=active_grid(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %l',l1=active_grid(i)) + end do + call mprintf(.true.,LOGFILE,' NOCOLONS = %l',l1=nocolons) + call mprintf(.true.,LOGFILE,'/') + + call mprintf(.true.,LOGFILE,'&GEOGRID') + call mprintf(.true.,LOGFILE,' PARENT_ID = %i',i1=parent_id(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=parent_id(i)) + end do + call mprintf(.true.,LOGFILE,' PARENT_GRID_RATIO = %i',i1=parent_grid_ratio(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=parent_grid_ratio(i)) + end do + call mprintf(.true.,LOGFILE,' I_PARENT_START = %i',i1=i_parent_start(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=i_parent_start(i)) + end do + call mprintf(.true.,LOGFILE,' J_PARENT_START = %i',i1=j_parent_start(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=j_parent_start(i)) + end do + call mprintf(.true.,LOGFILE,' S_WE = %i',i1=s_we(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=s_we(i)) + end do + call mprintf(.true.,LOGFILE,' E_WE = %i',i1=e_we(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=e_we(i)) + end do + call mprintf(.true.,LOGFILE,' S_SN = %i',i1=s_sn(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=s_sn(i)) + end do + call mprintf(.true.,LOGFILE,' E_SN = %i',i1=e_sn(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=e_sn(i)) + end do + call mprintf(.true.,LOGFILE,' GEOG_DATA_RES = %s',s1=geog_data_res(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %s',s1=geog_data_res(i)) + end do + call mprintf(.true.,LOGFILE,' DX = %f',f1=dx) + call mprintf(.true.,LOGFILE,' DY = %f',f1=dy) + call mprintf(.true.,LOGFILE,' MAP_PROJ = %s',s1=map_proj) + call mprintf(.true.,LOGFILE,' POLE_LAT = %f',f1=pole_lat) + call mprintf(.true.,LOGFILE,' POLE_LON = %f',f1=pole_lon) + call mprintf(.true.,LOGFILE,' REF_LAT = %f',f1=ref_lat) + call mprintf(.true.,LOGFILE,' REF_LON = %f',f1=ref_lon) + call mprintf(.true.,LOGFILE,' REF_X = %f',f1=ref_x) + call mprintf(.true.,LOGFILE,' REF_Y = %f',f1=ref_y) + call mprintf(.true.,LOGFILE,' TRUELAT1 = %f',f1=truelat1) + call mprintf(.true.,LOGFILE,' TRUELAT2 = %f',f1=truelat2) + call mprintf(.true.,LOGFILE,' STAND_LON = %f',f1=stand_lon) + call mprintf(.true.,LOGFILE,' GEOG_DATA_PATH = %s',s1=geog_data_path) + call mprintf(.true.,LOGFILE,' OPT_GEOGRID_TBL_PATH = %s',s1=opt_geogrid_tbl_path) + call mprintf(.true.,LOGFILE,'/') + + dxkm = dx + dykm = dy + + known_lat = ref_lat + known_lon = ref_lon + known_x = ref_x + known_y = ref_y + + ! Convert wrf_core to uppercase letters + do i=1,3 + if (ichar(wrf_core(i:i)) >= 97) wrf_core(i:i) = char(ichar(wrf_core(i:i))-32) + end do + + ! Before doing anything else, we must have a valid grid type + gridtype = ' ' + if (wrf_core == 'ARW') then + gridtype = 'C' + dyn_opt = 2 + else if (wrf_core == 'NMM') then + gridtype = 'E' + dyn_opt = 4 + end if + + ! Next, if this is NMM, we need to subtract 1 from the specified E_WE and E_SN; + ! for some reason, these two variables need to be set to 1 larger than they + ! really ought to be in the WRF namelist, so, to be consistent, we will do + ! the same in the WPS namelist + if (gridtype == 'E') then + do i=1,max_dom + e_we(i) = e_we(i) - 1 + e_sn(i) = e_sn(i) - 1 + end do + end if + + call mprintf(gridtype /= 'C' .and. gridtype /= 'E', ERROR, & + 'A valid wrf_core must be specified in the namelist. '// & + 'Currently, only "ARW" and "NMM" are supported.') + + call mprintf(max_dom > MAX_DOMAINS, ERROR, & + 'In namelist, max_dom must be <= %i. To run with more'// & + ' than %i domains, increase the MAX_DOMAINS parameter.', & + i1=MAX_DOMAINS, i2=MAX_DOMAINS) + + ! Every domain must have a valid parent id + do i=2,max_dom + call mprintf(parent_id(i) <= 0 .or. parent_id(i) >= i, ERROR, & + 'In namelist, the parent_id of domain %i must be in '// & + 'the range 1 to %i.', i1=i, i2=i-1) + end do + + ! Check for valid geog_data_path + j=1 + do i=1,len(geog_data_path) + geog_data_path(j:j) = geog_data_path(i:i) + if (geog_data_path(i:i) /= ' ') j = j + 1 + end do + if (geog_data_path(1:1) == ' ') then + call mprintf(.true.,ERROR,'In namelist, geog_data_path must be specified.') + end if + j = len_trim(geog_data_path) + if (j >= MAX_FILENAME_LEN) then + call mprintf(.true.,ERROR, & + 'In namelist, geog_data_path must be strictly less '// & + 'than 128 characters in length.') + else + if (geog_data_path(j:j) /= '/') then + geog_data_path(j+1:j+1) = '/' + end if + end if + + ! Paths need to end with a / + j = len_trim(opt_geogrid_tbl_path) + if (opt_geogrid_tbl_path(j:j) /= '/') then + opt_geogrid_tbl_path(j+1:j+1) = '/' + end if + + j = len_trim(opt_output_from_geogrid_path) + if (opt_output_from_geogrid_path(j:j) /= '/') then + opt_output_from_geogrid_path(j+1:j+1) = '/' + end if + + ! Handle IOFORM+100 to do tiled IO + if (io_form_geogrid > 100) then + do_tiled_output = .true. + io_form_geogrid = io_form_geogrid - 100 + else + do_tiled_output = .false. + end if + + ! Check for valid io_form_geogrid + if ( & +#ifdef IO_BINARY + io_form_geogrid /= BINARY .and. & +#endif +#ifdef IO_NETCDF + io_form_geogrid /= NETCDF .and. & +#endif +#ifdef IO_GRIB1 + io_form_geogrid /= GRIB1 .and. & +#endif + .true. ) then + call mprintf(.true.,WARN,'Valid io_form_geogrid values are:') +#ifdef IO_BINARY + call mprintf(.true.,WARN,' %i (=BINARY)',i1=BINARY) +#endif +#ifdef IO_NETCDF + call mprintf(.true.,WARN,' %i (=NETCDF)',i1=NETCDF) +#endif +#ifdef IO_GRIB1 + call mprintf(.true.,WARN,' %i (=GRIB1)',i1=GRIB1) +#endif + call mprintf(.true.,ERROR,'No valid value for io_form_geogrid was specified in the namelist.') + end if + io_form_output = io_form_geogrid + + ! Convert map_proj to uppercase letters + do i=1,len(map_proj) + if (ichar(map_proj(i:i)) >= 97) map_proj(i:i) = char(ichar(map_proj(i:i))-32) + end do + + ! Assign parameters to module variables + if ((index(map_proj, 'LAMBERT') /= 0) .and. & + (len_trim(map_proj) == len('LAMBERT'))) then + iproj_type = PROJ_LC + + else if ((index(map_proj, 'MERCATOR') /= 0) .and. & + (len_trim(map_proj) == len('MERCATOR'))) then + iproj_type = PROJ_MERC + + else if ((index(map_proj, 'POLAR') /= 0) .and. & + (len_trim(map_proj) == len('POLAR'))) then + iproj_type = PROJ_PS + + else if ((index(map_proj, 'ROTATED_LL') /= 0) .and. & + (len_trim(map_proj) == len('ROTATED_LL'))) then + iproj_type = PROJ_ROTLL + + else if ((index(map_proj, 'LAT-LON') /= 0) .and. & + (len_trim(map_proj) == len('LAT-LON'))) then + iproj_type = PROJ_CASSINI + + else + call mprintf(.true.,ERROR,& + 'In namelist, invalid map_proj specified. Valid '// & + 'projections are "lambert", "mercator", "polar", '// & + '"lat-lon", and "rotated_ll".') + end if + + ! For Cassini / lat-lon projections + if (iproj_type == PROJ_CASSINI) then + + ! If no dx,dy specified, assume global grid + if (dx == NAN .and. dy == NAN) then + dlondeg = 360. / (e_we(1)-s_we(1)) ! Here, we really do not want e_we-s_we+1 + dlatdeg = 180. / (e_sn(1)-s_sn(1)) ! Here, we really do not want e_we-s_we+1 + known_x = 1. + known_y = 1. + known_lon = stand_lon + dlondeg/2. + known_lat = -90. + dlatdeg/2. + dxkm = EARTH_RADIUS_M * PI * 2.0 / (e_we(1)-s_we(1)) + dykm = EARTH_RADIUS_M * PI / (e_sn(1)-s_sn(1)) + + ! If dx,dy specified, however, assume regional grid + else + dlatdeg = dy + dlondeg = dx + dxkm = dlondeg * EARTH_RADIUS_M * PI * 2.0 / 360.0 + dykm = dlatdeg * EARTH_RADIUS_M * PI * 2.0 / 360.0 + if (known_lat == NAN .or. known_lon == NAN) then + call mprintf(.true.,ERROR,'For lat-lon projection, if dx/dy are specified, '// & + 'a regional domain is assumed, and a ref_lat,ref_lon must also be specified') + end if + end if + end if + + ! Manually set truelat2 = truelat1 if truelat2 not specified for Lambert + if (iproj_type == PROJ_LC .and. truelat2 == NAN) then + call mprintf ((truelat1 == NAN), ERROR, "No TRUELAT1 specified for Lambert conformal projection.") + truelat2 = truelat1 + end if + + + n_domains = max_dom + + ! For C grid, let ixdim and jydim be the number of velocity points in + ! each direction; for E grid, we will put the row and column back + ! later; maybe this should be changed to be more clear, though. + do i=1,n_domains + ixdim(i) = e_we(i) - s_we(i) + 1 + jydim(i) = e_sn(i) - s_sn(i) + 1 + end do + + if (gridtype == 'E') then + phi = dykm*real(jydim(1)-1)/2. + lambda = dxkm*real(ixdim(1)-1) + end if + + ! If the user hasn't supplied a known_x and known_y, assume the center of domain 1 + if (gridtype == 'E' .and. (known_x /= NAN .or. known_y /= NAN)) then + call mprintf(.true.,WARN, & + 'Namelist variables ref_x and ref_y cannot be used for NMM grids.'// & + ' (ref_lat, ref_lon) will refer to the center of the coarse grid.') + else if (gridtype == 'C') then + if (known_x == NAN .and. known_y == NAN) then + known_x = ixdim(1) / 2. + known_y = jydim(1) / 2. + else if (known_x == NAN .or. known_y == NAN) then + call mprintf(.true.,ERROR, & + 'In namelist.wps, neither or both of ref_x, ref_y must be specified.') + end if + end if + + ! Checks specific to E grid + if (gridtype == 'E') then + + ! E grid supports only the rotated lat/lon projection + if (iproj_type /= PROJ_ROTLL) then + call mprintf(.true., WARN, & + 'For the NMM core, projection type must be rotated '// & + 'lat/lon (map_proj=rotated_ll)') + call mprintf(.true.,WARN,'Projection will be set to rotated_ll') + iproj_type = PROJ_ROTLL + end if + + ! In the following check, add back the 1 that we had to subtract above + ! for the sake of being consistent with WRF namelist + call mprintf(mod(e_sn(1)+1,2) /= 0, ERROR, & + 'For the NMM core, E_SN must be an even number for grid %i.', i1=1) + + do i=2,n_domains + call mprintf((parent_grid_ratio(i) /= 3), WARN, & + 'For the NMM core, the parent_grid_ratio must be 3 for '// & + 'domain %i. A ratio of 3 will be assumed.', i1=i) + parent_grid_ratio(i) = 3 + end do + + ! Check that nests have an acceptable number of grid points in each dimension +! do i=2,n_domains +! rparent_gridpts = real(ixdim(i)+2)/real(parent_grid_ratio(i)) +! if (floor(rparent_gridpts) /= ceiling(rparent_gridpts)) then +! call mprintf(.true.,ERROR,'For nest %i, e_we must be 3n-2 '// & +! 'for some integer n > 1.', & +! i1=i) +! end if +! rparent_gridpts = real(jydim(i)+2)/real(parent_grid_ratio(i)) +! if (floor(rparent_gridpts) /= ceiling(rparent_gridpts)) then +! call mprintf(.true.,ERROR,'For nest %i, e_sn must be 3n-2 '// & +! 'for some odd integer n > 1.', & +! i1=i) +! end if +! end do + + do i=2,n_domains + parent_ll_x(i) = 1. + parent_ll_y(i) = 1. + end do + + ! Checks specific to C grid + else if (gridtype == 'C') then + + ! C grid does not support the rotated lat/lon projection + call mprintf((iproj_type == PROJ_ROTLL), ERROR, & + 'Rotated lat/lon projection is not supported for the ARW core. '// & + 'Valid projecitons are "lambert", "mercator", "polar", and "lat-lon".') + + ! Check that nests have an acceptable number of grid points in each dimension + do i=2,n_domains + rparent_gridpts = real(ixdim(i)-1)/real(parent_grid_ratio(i)) + if (floor(rparent_gridpts) /= ceiling(rparent_gridpts)) then + call mprintf(.true.,ERROR,'For nest %i, (e_we-s_we+1) must be one greater '// & + 'than an integer multiple of the parent_grid_ratio of %i.', & + i1=i, i2=parent_grid_ratio(i)) + end if + rparent_gridpts = real(jydim(i)-1)/real(parent_grid_ratio(i)) + if (floor(rparent_gridpts) /= ceiling(rparent_gridpts)) then + call mprintf(.true.,ERROR,'For nest %i, (e_sn-s_sn+1) must be one greater '// & + 'than an integer multiple of the parent_grid_ratio of %i.', & + i1=i, i2=parent_grid_ratio(i)) + end if + end do + + ! Check that a nest does not extend outside of its parent grid + nest_outside = .false. + do i=2,n_domains + if (i_parent_start(i) >= ixdim(parent_id(i))) then + call mprintf(.true.,WARN,'Nest %i cannot have i_parent_start outside of parent domain.',i1=i) + nest_outside = .true. + else if (i_parent_start(i) + (ixdim(i) - 1)/parent_grid_ratio(i) > ixdim(parent_id(i))) then + call mprintf(.true.,WARN,'Nest %i extends beyond its parent grid in the west-east direction.',i1=i) + call mprintf(.true.,WARN,' Maximum allowable e_we for current i/j_parent_start is %i.', & + i1=(ixdim(parent_id(i))-i_parent_start(i))*parent_grid_ratio(i)+1 ) + nest_outside = .true. + end if + if (j_parent_start(i) >= jydim(parent_id(i))) then + call mprintf(.true.,WARN,'Nest %i cannot have j_parent_start outside of parent domain.',i1=i) + nest_outside = .true. + else if (j_parent_start(i) + (jydim(i) - 1)/parent_grid_ratio(i) > jydim(parent_id(i))) then + call mprintf(.true.,WARN,'Nest %i extends beyond its parent grid in the south-north direction.',i1=i) + call mprintf(.true.,WARN,' Maximum allowable e_sn for current i/j_parent_start is %i.', & + i1=(jydim(parent_id(i))-j_parent_start(i))*parent_grid_ratio(i)+1 ) + nest_outside = .true. + end if + end do + if (nest_outside) then + call mprintf(.true.,ERROR,'One or more nested domains extend beyond their parent domains.') + end if + + do i=1,n_domains + parent_ll_x(i) = real(i_parent_start(i)) + parent_ll_y(i) = real(j_parent_start(i)) + parent_ur_x(i) = real(i_parent_start(i))+real(ixdim(i))/real(parent_grid_ratio(i))-1. + parent_ur_y(i) = real(j_parent_start(i))+real(jydim(i))/real(parent_grid_ratio(i))-1. + grid_is_active(i) = active_grid(i) + end do + + end if + + return + + 1000 call mprintf(.true.,ERROR,'Error opening file namelist.wps') + + end subroutine get_grid_params + +end module gridinfo_module diff --git a/WPS/geogrid/src/hash_module.F b/WPS/geogrid/src/hash_module.F new file mode 100644 index 00000000..10348da4 --- /dev/null +++ b/WPS/geogrid/src/hash_module.F @@ -0,0 +1,159 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! MODULE HASH_MODULE +! +! Purpose: This module provides a dictionary/hashtable with insert, search, and +! remove routines. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module hash_module + + ! Parameters + integer, parameter :: TABLESIZE=53 ! Number of spaces in the table (the + ! number of linked lists) + + type hashnode + character (len=256) :: entry ! The actual string to be stored + type (hashnode), pointer :: next + end type hashnode + + type hashnode_ptr + type (hashnode), pointer :: p ! Pointer to a list of entries + end type hashnode_ptr + + type hashtable + type (hashnode_ptr), dimension(TABLESIZE) :: table ! The hashtable array + end type hashtable + + contains + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: hash_init + ! + ! Purpose: To initialize a hashtable + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine hash_init(h) + + implicit none + + ! Arguments + type (hashtable), intent(inout) :: h + + ! Local variables + integer :: i + + do i=1,TABLESIZE + nullify(h%table(i)%p) + end do + + end subroutine hash_init + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: hash_insert + ! + ! Purpose: Given a hashtable h and a string to be inserted into the hashtable, + ! this routine adds string to the table. + ! + ! NOTE: If the string already exists in the table, a second copy of the + ! string is added to the table + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine hash_insert(h, string) + + implicit none + + ! Arguments + character (len=256), intent(in) :: string + type (hashtable), intent(inout) :: h + + ! Local variables + integer :: hashval, i + type (hashnode), pointer :: hn + + hashval = 0 + do i=1,len(string) + hashval = hashval + iachar(string(i:i)) + end do + hashval = mod(hashval, TABLESIZE) + 1 + + allocate(hn) + hn%entry = string + hn%next => h%table(hashval)%p + h%table(hashval)%p => hn + + end subroutine hash_insert + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: hash_search + ! + ! Purpose: This function returns TRUE if the specified string was found in the + ! hashtable h, and FALSE otherwise. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function hash_search(h, string) + + implicit none + + ! Arguments + character (len=256), intent(in) :: string + type (hashtable), intent(inout) :: h + + ! Return value + logical :: hash_search + + ! Local variables + integer :: hashval, i + type (hashnode), pointer :: cursor + + hash_search = .false. + + hashval = 0 + do i=1,len(string) + hashval = hashval + iachar(string(i:i)) + end do + hashval = mod(hashval, TABLESIZE) + 1 + + cursor => h%table(hashval)%p + do while(associated(cursor)) + if (cursor%entry == string) then + hash_search = .true. + return + else + cursor => cursor%next + end if + end do + + return + + end function hash_search + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: hash_destroy + ! + ! Purpose: Frees all memory associated with hashtable h. This routine may be + ! used to remove all entries from a hashtable. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine hash_destroy(h) + + implicit none + + ! Arguments + type (hashtable), intent(inout) :: h + + ! Local variables + integer :: i + type (hashnode), pointer :: cursor, cursor_prev + + do i=1,TABLESIZE + cursor => h%table(i)%p + do while(associated(cursor)) + cursor_prev => cursor + cursor => cursor%next + deallocate(cursor_prev) + end do + nullify(h%table(i)%p) + end do + + end subroutine hash_destroy + +end module hash_module diff --git a/WPS/geogrid/src/interp_module.F b/WPS/geogrid/src/interp_module.F new file mode 100644 index 00000000..dd85a67a --- /dev/null +++ b/WPS/geogrid/src/interp_module.F @@ -0,0 +1,1376 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! MODULE INTERP_MODULE +! +! This module provides routines for interpolation. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module interp_module + + use bitarray_module + use misc_definitions_module + use module_debug + use queue_module + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: interp_array_from_string + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function interp_array_from_string(interp_string) + + implicit none + + ! Arguments + character (len=*), intent(in) :: interp_string + + ! Local variables + integer :: j, p1, p2, iend, num_methods + + ! Return value + integer, pointer, dimension(:) :: interp_array_from_string + + ! Get an idea of how many interpolation methods are in the string + ! so we can allocate an appropriately sized array + num_methods = 1 + do j=1,len_trim(interp_string) + if (interp_string(j:j) == '+') num_methods = num_methods + 1 + end do + + allocate(interp_array_from_string(num_methods+1)) + interp_array_from_string = 0 + + iend = len_trim(interp_string) + + p1 = 1 + p2 = index(interp_string(1:iend),'+') + j = 1 + do while(p2 >= p1) + if (index(interp_string(p1:p2-1),'nearest_neighbor') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('nearest_neighbor')) then + interp_array_from_string(j) = N_NEIGHBOR + j = j + 1 + else if (index(interp_string(p1:p2-1),'average_4pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('average_4pt')) then + interp_array_from_string(j) = AVERAGE4 + j = j + 1 + else if (index(interp_string(p1:p2-1),'average_16pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('average_16pt')) then + interp_array_from_string(j) = AVERAGE16 + j = j + 1 + else if (index(interp_string(p1:p2-1),'wt_average_4pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_4pt')) then + interp_array_from_string(j) = W_AVERAGE4 + j = j + 1 + else if (index(interp_string(p1:p2-1),'wt_average_16pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_16pt')) then + interp_array_from_string(j) = W_AVERAGE16 + j = j + 1 + else if (index(interp_string(p1:p2-1),'four_pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('four_pt')) then + interp_array_from_string(j) = FOUR_POINT + j = j + 1 + else if (index(interp_string(p1:p2-1),'sixteen_pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('sixteen_pt')) then + interp_array_from_string(j) = SIXTEEN_POINT + j = j + 1 + else if (index(interp_string(p1:p2-1),'search') /= 0) then + interp_array_from_string(j) = SEARCH + j = j + 1 + else + if (index(interp_string(p1:p2-1),'average_gcell') == 0) & + call mprintf(.true.,WARN,'Unrecognized interpolation method %s.',s1=interp_string(p1:p2-1)) + end if + p1 = p2 + 1 + p2 = index(interp_string(p1:iend),'+') + p1 - 1 + end do + + p2 = iend+1 + if (p1 < iend) then + if (index(interp_string(p1:p2-1),'nearest_neighbor') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('nearest_neighbor')) then + interp_array_from_string(j) = N_NEIGHBOR + j = j + 1 + else if (index(interp_string(p1:p2-1),'average_4pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('average_4pt')) then + interp_array_from_string(j) = AVERAGE4 + j = j + 1 + else if (index(interp_string(p1:p2-1),'average_16pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('average_16pt')) then + interp_array_from_string(j) = AVERAGE16 + j = j + 1 + else if (index(interp_string(p1:p2-1),'wt_average_4pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_4pt')) then + interp_array_from_string(j) = W_AVERAGE4 + j = j + 1 + else if (index(interp_string(p1:p2-1),'wt_average_16pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_16pt')) then + interp_array_from_string(j) = W_AVERAGE16 + j = j + 1 + else if (index(interp_string(p1:p2-1),'four_pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('four_pt')) then + interp_array_from_string(j) = FOUR_POINT + j = j + 1 + else if (index(interp_string(p1:p2-1),'sixteen_pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('sixteen_pt')) then + interp_array_from_string(j) = SIXTEEN_POINT + j = j + 1 + else if (index(interp_string(p1:),'search') /= 0) then + interp_array_from_string(j) = SEARCH + j = j + 1 + else + if (index(interp_string(p1:p2-1),'average_gcell') == 0) & + call mprintf(.true.,WARN,'Unrecognized interpolation method %s.',s1=interp_string(p1:p2-1)) + end if + end if + + return + + end function interp_array_from_string + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: interp_options_from_string + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function interp_options_from_string(interp_string) + + implicit none + + ! Arguments + character (len=*), intent(in) :: interp_string + + ! Local variables + integer :: j, p1, p2, iend, num_methods, istatus + + ! Return value + integer, pointer, dimension(:) :: interp_options_from_string + + ! Get an idea of how many interpolation methods are in the string + ! so we can allocate an appropriately sized array + num_methods = 1 + do j=1,len_trim(interp_string) + if (interp_string(j:j) == '+') num_methods = num_methods + 1 + end do + + allocate(interp_options_from_string(num_methods+1)) + interp_options_from_string(:) = 0 + + iend = len_trim(interp_string) + + p1 = 1 + p2 = index(interp_string(1:iend),'+') + j = 1 + do while(p2 >= p1) + if (index(interp_string(p1:p2-1),'nearest_neighbor') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('nearest_neighbor')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'average_4pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('average_4pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'average_16pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('average_16pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'wt_average_4pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_4pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'wt_average_16pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_16pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'four_pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('four_pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'sixteen_pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('sixteen_pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'search') /= 0) then + call get_search_depth(interp_string(p1:p2-1), interp_options_from_string(j), istatus) + j = j + 1 + else + if (index(interp_string(p1:p2-1),'average_gcell') == 0) & + call mprintf(.true.,WARN,'Unrecognized interpolation method %s.',s1=interp_string(p1:p2-1)) + end if + p1 = p2 + 1 + p2 = index(interp_string(p1:iend),'+') + p1 - 1 + end do + + p2 = iend+1 + if (p1 < iend) then + if (index(interp_string(p1:p2-1),'nearest_neighbor') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('nearest_neighbor')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'average_4pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('average_4pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'average_16pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('average_16pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'wt_average_4pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_4pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'wt_average_16pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('wt_average_16pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'four_pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('four_pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:p2-1),'sixteen_pt') /= 0 .and. & + len_trim(interp_string(p1:p2-1)) == len_trim('sixteen_pt')) then + interp_options_from_string(j) = 0 + j = j + 1 + else if (index(interp_string(p1:),'search') /= 0) then + call get_search_depth(interp_string(p1:), interp_options_from_string(j), istatus) + j = j + 1 + else + if (index(interp_string(p1:p2-1),'average_gcell') == 0) & + call mprintf(.true.,WARN,'Unrecognized interpolation method %s.',s1=interp_string(p1:p2-1)) + end if + end if + + return + + end function interp_options_from_string + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_search_depth + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_search_depth(interp_opt, depth, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + integer, intent(out) :: depth + character (len=*), intent(in) :: interp_opt + + ! Local variables + integer :: i, p1, p2, p + + istatus = 1 + depth = 1200 + + i = index(interp_opt,'search') + if (i /= 0) then + + ! Check for a max search depth + p = index(interp_opt(i:),'+') + if (p == 0) p = len_trim(interp_opt) + p1 = index(interp_opt(i:p),'(') + p2 = index(interp_opt(i:p),')') + if (p1 /= 0 .and. p2 /= 0) then + read(interp_opt(p1+1:p2-1),*,err=1000) depth + else if (p1 == 0 .and. p2 == 0) then + ! keep depth at 1200, no warning + else + call mprintf(.true., WARN, 'Problem with specified search depth '// & + 'for search interp option. Setting max depth to 1200.') + depth = 1200 + end if + end if + istatus = 0 + + return + + 1000 call mprintf(.true., ERROR, 'Search depth option to search interpolator '// & + 'must be an integer value, enclosed in parentheses immediately '// & + 'after keyword "search"') + + end subroutine get_search_depth + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: interp_sequence + ! + ! Purpose: Delegates the actual task of interpolation to specific + ! interpolation routines defined in the module. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive function interp_sequence(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + + implicit none + + ! Arguments + integer, intent(in) :: start_x, start_y, start_z + integer, intent(in) :: end_x, end_y, end_z + integer, intent(in) :: izz ! The z-index of the 2d-array to + ! interpolate within + real, intent(in) :: xx , yy ! The location to interpolate to + real, intent(in) :: msgval + real, intent(in), optional :: maskval + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), intent(in) :: array + integer, intent(in) :: idx + integer, dimension(:), intent(in) :: interp_list + integer, dimension(:), intent(in) :: interp_opts + real, dimension(start_x:end_x, start_y:end_y), intent(in), optional :: mask_array + character (len=1), intent(in), optional :: mask_relational + + ! Return value + real :: interp_sequence + + ! No more interpolation methods to try + if (interp_list(idx) == 0) then + interp_sequence = msgval + return + end if + + if (interp_list(idx) == FOUR_POINT) then + interp_sequence = four_pt(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx+1, mask_relational, maskval, mask_array) + else if (interp_list(idx) == AVERAGE4) then + interp_sequence = four_pt_average(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx+1, mask_relational, maskval, mask_array) + else if (interp_list(idx) == W_AVERAGE4) then + interp_sequence = wt_four_pt_average(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx+1, mask_relational, maskval, mask_array) + else if (interp_list(idx) == N_NEIGHBOR) then + interp_sequence = nearest_neighbor(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx+1, mask_relational, maskval, mask_array) + else if (interp_list(idx) == SIXTEEN_POINT) then + interp_sequence = sixteen_pt(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx+1, mask_relational, maskval, mask_array) + else if (interp_list(idx) == SEARCH) then + interp_sequence = search_extrap(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx+1, mask_relational, maskval, mask_array) + else if (interp_list(idx) == AVERAGE16) then + interp_sequence = sixteen_pt_average(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx+1, mask_relational, maskval, mask_array) + else if (interp_list(idx) == W_AVERAGE16) then + interp_sequence = wt_sixteen_pt_average(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx+1, mask_relational, maskval, mask_array) + end if + + end function interp_sequence + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: nearest_neighbor + ! + ! Purpose: Returns the point nearest to (xx,yy). If (xx,yy) is outside of the + ! array, the point on the edge of the array nearest to (xx,yy) is returned. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive function nearest_neighbor(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + + implicit none + + ! Arguments + integer, intent(in) :: start_x, start_y, start_z + integer, intent(in) :: end_x, end_y, end_z + integer, intent(in) :: izz ! The z-index of the 2d-array to + ! interpolate within + real, intent(in) :: xx , yy ! The location to interpolate to + real, intent(in) :: msgval + real, intent(in), optional :: maskval + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), intent(in) :: array + integer, dimension(:), intent(in) :: interp_list + integer, dimension(:), intent(in) :: interp_opts + integer, intent(in) :: idx + real, dimension(start_x:end_x, start_y:end_y), intent(in), optional :: mask_array + character (len=1), intent(in), optional :: mask_relational + + ! Return value + real :: nearest_neighbor + + ! Local variables + integer :: ix, iy + + ix = nint(xx) + iy = nint(yy) + + ! The first thing to do is to ensure that the point (xx,yy) is within the array + if (ix < start_x .or. ix > end_x) then + nearest_neighbor = msgval + return + end if + + if (iy < start_y .or. iy > end_y) then + nearest_neighbor = msgval + return + end if + + if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then + if (mask_relational == '<' .and. mask_array(ix,iy) < maskval) then + nearest_neighbor = msgval + else if (mask_relational == '>' .and. mask_array(ix,iy) > maskval) then + nearest_neighbor = msgval + else if (mask_relational == ' ' .and. mask_array(ix,iy) == maskval) then + nearest_neighbor = msgval + else + nearest_neighbor = array(ix,iy,izz) + end if + else if (present(mask_array) .and. present(maskval)) then + if (maskval == mask_array(ix,iy)) then + nearest_neighbor = msgval + else + nearest_neighbor = array(ix,iy,izz) + end if + else + nearest_neighbor = array(ix,iy,izz) + end if + + ! If we have a missing value, try the next interpolation method in the sequence + if (nearest_neighbor == msgval) then + nearest_neighbor = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + end if + + end function nearest_neighbor + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: search_extrap + ! + ! Purpose: Returns the point nearest to (xx,yy) that has a non-missing value. + ! If no valid value can be found in the array, msgval is returned. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive function search_extrap(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + + implicit none + + ! Arguments + integer, intent(in) :: start_x, start_y, start_z + integer, intent(in) :: end_x, end_y, end_z + integer, intent(in) :: izz ! The z-index of the 2d-array to search + real, intent(in) :: xx , yy ! The location of the search origin + real, intent(in) :: msgval + real, intent(in), optional :: maskval + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), & + intent(in) :: array + integer, dimension(:), intent(in) :: interp_list + integer, dimension(:), intent(in) :: interp_opts + integer, intent(in) :: idx + real, dimension(start_x:end_x, start_y:end_y), & + intent(in), optional :: mask_array + character (len=1), intent(in), optional :: mask_relational + + ! Return value + real :: search_extrap + + ! Local variables + integer :: i, j + real :: distance + logical :: found_valid + type (bitarray) :: b + type (queue) :: q + type (q_data) :: qdata + + ! We only search if the starting point is within the array + if (nint(xx) < start_x .or. nint(xx) > end_x .or. & + nint(yy) < start_y .or. nint(yy) > end_y) then + search_extrap = msgval + return + end if + + call bitarray_create(b, (end_x-start_x+1), (end_y-start_y+1)) + call q_init(q) + + found_valid = .false. + qdata%x = nint(xx) + qdata%y = nint(yy) + qdata%depth = 0 + call q_insert(q, qdata) + call bitarray_set(b, qdata%x-start_x+1, qdata%y-start_y+1) + + do while (q_isdata(q) .and. (.not. found_valid)) + qdata = q_remove(q) + i = qdata%x + j = qdata%y + + if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then + if (mask_relational == '>' .and. mask_array(i,j) <= maskval .and. array(i,j,izz) /= msgval) then + found_valid = .true. + else if (mask_relational == '<' .and. mask_array(i,j) >= maskval .and. array(i,j,izz) /= msgval) then + found_valid = .true. + else if (mask_relational == ' ' .and. mask_array(i,j) /= maskval .and. array(i,j,izz) /= msgval) then + found_valid = .true. + end if + else if (present(mask_array) .and. present(maskval)) then + if (array(i,j,izz) /= msgval .and. mask_array(i,j) /= maskval) found_valid = .true. + else + if (array(i,j,izz) /= msgval) found_valid = .true. + end if + + if (i-1 >= start_x) then + if (.not. bitarray_test(b, (i-1)-start_x+1, j-start_y+1)) then + if (qdata%depth < interp_opts(idx-1)) then ! idx-1, since idx was incremented before call to this subroutine + qdata%x = i-1 + qdata%y = j + qdata%depth = qdata%depth+1 + call q_insert(q, qdata) + call bitarray_set(b, (i-1)-start_x+1, j-start_y+1) + end if + end if + end if + if (i+1 <= end_x) then + if (.not. bitarray_test(b, (i+1)-start_x+1, j-start_y+1)) then + if (qdata%depth < interp_opts(idx-1)) then ! idx-1, since idx was incremented before call to this subroutine + qdata%x = i+1 + qdata%y = j + qdata%depth = qdata%depth+1 + call q_insert(q, qdata) + call bitarray_set(b, (i+1)-start_x+1, j-start_y+1) + end if + end if + end if + if (j-1 >= start_y) then + if (.not. bitarray_test(b, i-start_x+1, (j-1)-start_y+1)) then + if (qdata%depth < interp_opts(idx-1)) then ! idx-1, since idx was incremented before call to this subroutine + qdata%x = i + qdata%y = j-1 + qdata%depth = qdata%depth+1 + call q_insert(q, qdata) + call bitarray_set(b, i-start_x+1, (j-1)-start_y+1) + end if + end if + end if + if (j+1 <= end_y) then + if (.not. bitarray_test(b, i-start_x+1, (j+1)-start_y+1)) then + if (qdata%depth < interp_opts(idx-1)) then ! idx-1, since idx was incremented before call to this subroutine + qdata%x = i + qdata%y = j+1 + qdata%depth = qdata%depth+1 + call q_insert(q, qdata) + call bitarray_set(b, i-start_x+1, (j+1)-start_y+1) + end if + end if + end if + end do + + if (found_valid) then + distance = (real(i)-xx)*(real(i)-xx)+(real(j)-yy)*(real(j)-yy) + search_extrap = array(i,j,izz) + do while (q_isdata(q)) + qdata = q_remove(q) + if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then + if (mask_relational == '<' .and. mask_array(qdata%x,qdata%y) >= maskval & + .and. array(qdata%x,qdata%y,izz) /= msgval) then + if ((real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) < distance) then + distance = (real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) + search_extrap = array(qdata%x, qdata%y, izz) + end if + else if (mask_relational == '>' .and. mask_array(qdata%x,qdata%y) <= maskval & + .and. array(qdata%x,qdata%y,izz) /= msgval) then + if ((real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) < distance) then + distance = (real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) + search_extrap = array(qdata%x, qdata%y, izz) + end if + else if (mask_relational == ' ' .and. mask_array(qdata%x,qdata%y) /= maskval & + .and. array(qdata%x,qdata%y,izz) /= msgval) then + if ((real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) < distance) then + distance = (real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) + search_extrap = array(qdata%x, qdata%y, izz) + end if + end if + + else if (present(mask_array) .and. present(maskval)) then + if (array(qdata%x,qdata%y,izz) /= msgval .and. mask_array(qdata%x,qdata%y) /= maskval) then + if ((real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) < distance) then + distance = (real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) + search_extrap = array(qdata%x, qdata%y, izz) + end if + end if + + else + if (array(qdata%x,qdata%y,izz) /= msgval) then + if ((real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) < distance) then + distance = (real(qdata%x)-xx)*(real(qdata%x)-xx)+(real(qdata%y)-yy)*(real(qdata%y)-yy) + search_extrap = array(qdata%x, qdata%y, izz) + end if + end if + end if + end do + else + search_extrap = msgval + end if + + call q_destroy(q) + call bitarray_destroy(b) + + end function search_extrap + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: four_pt_average + ! + ! Purpose: Average of four surrounding grid point values + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive function four_pt_average(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + + implicit none + + ! Arguments + integer, intent(in) :: start_x, start_y, start_z + integer, intent(in) :: end_x, end_y, end_z + integer, intent(in) :: izz ! The z-index of the 2d-array to + ! interpolate within + real, intent(in) :: xx, yy ! The location to interpolate to + real, intent(in) :: msgval + real, intent(in), optional :: maskval + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), & + intent(in) :: array + integer, dimension(:), intent(in) :: interp_list + integer, dimension(:), intent(in) :: interp_opts + integer, intent(in) :: idx + real, dimension(start_x:end_x, start_y:end_y), & + intent(in), optional :: mask_array + character (len=1), intent(in), optional :: mask_relational + + ! Return value + real :: four_pt_average + + ! Local variables + integer :: ifx, ify, icx, icy + real :: fxfy, fxcy, cxfy, cxcy + + fxfy = 1.0 + fxcy = 1.0 + cxfy = 1.0 + cxcy = 1.0 + + ifx = floor(xx) + icx = ceiling(xx) + ify = floor(yy) + icy = ceiling(yy) + + ! First, make sure that the point is contained in the source array + if (ifx < start_x .or. icx > end_x .or. & + ify < start_y .or. icy > end_y) then + + ! But if the point is at most half a grid point out, we can + ! still proceed with modified ifx, icx, ify, and icy. + if (xx > real(start_x)-0.5 .and. ifx < start_x) then + ifx = start_x + icx = start_x + else if (xx < real(end_x)+0.5 .and. icx > end_x) then + ifx = end_x + icx = end_x + end if + + if (yy > real(start_y)-0.5 .and. ify < start_y) then + ify = start_y + icy = start_y + else if (yy < real(end_y)+0.5 .and. icy > end_y) then + ify = end_y + icy = end_y + end if + + if (ifx < start_x .or. icx > end_x .or. & + ify < start_y .or. icy > end_y) then + four_pt_average = msgval + return + end if + end if + + if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then + ! we determine which maskval is useable by... if the symbol > is found, then only + ! values less than 'maskval' can be used and if the symbol < is found, + ! then only the values greater than 'maskval' can be used. + if (mask_relational == '>') then + if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) > maskval) fxfy = 0.0 + if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) > maskval) fxcy = 0.0 + if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) > maskval) cxfy = 0.0 + if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) > maskval) cxcy = 0.0 + else if (mask_relational == '<') then + if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) < maskval) fxfy = 0.0 + if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) < maskval) fxcy = 0.0 + if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) < maskval) cxfy = 0.0 + if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) < maskval) cxcy = 0.0 + else !equal + if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) == maskval) fxfy = 0.0 + if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) == maskval) fxcy = 0.0 + if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) == maskval) cxfy = 0.0 + if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) == maskval) cxcy = 0.0 + end if + else if (present(mask_array) .and. present(maskval)) then + if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) == maskval) fxfy = 0.0 + if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) == maskval) fxcy = 0.0 + if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) == maskval) cxfy = 0.0 + if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) == maskval) cxcy = 0.0 + else + if (array(ifx, ify, izz) == msgval) fxfy = 0.0 + if (array(ifx, icy, izz) == msgval) fxcy = 0.0 + if (array(icx, ify, izz) == msgval) cxfy = 0.0 + if (array(icx, icy, izz) == msgval) cxcy = 0.0 + end if + + ! If all four points are missing, try the next interpolation method in the sequence + if (fxfy == 0.0 .and. fxcy == 0.0 .and. cxfy == 0.0 .and. cxcy == 0.0) then + four_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + else + four_pt_average = (fxfy * array(ifx, ify, izz) + & + fxcy * array(ifx, icy, izz) + & + cxfy * array(icx, ify, izz) + & + cxcy * array(icx, icy, izz) ) / (fxfy + fxcy + cxfy + cxcy) + end if + + end function four_pt_average + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: wt_four_pt_average + ! + ! Purpose: Weighted average of four surrounding grid point values + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive function wt_four_pt_average(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + + implicit none + + ! Arguments + integer, intent(in) :: start_x, start_y, start_z + integer, intent(in) :: end_x, end_y, end_z + integer, intent(in) :: izz ! The z-index of the 2d-array to + ! interpolate within + real, intent(in) :: xx, yy ! The location to interpolate to + real, intent(in) :: msgval + real, intent(in), optional :: maskval + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), & + intent(in) :: array + integer, dimension(:), intent(in) :: interp_list + integer, dimension(:), intent(in) :: interp_opts + integer, intent(in) :: idx + real, dimension(start_x:end_x, start_y:end_y), & + intent(in), optional :: mask_array + character (len=1), intent(in), optional :: mask_relational + + ! Return value + real :: wt_four_pt_average + + ! Local variables + integer :: ifx, ify, icx, icy + real :: fxfy, fxcy, cxfy, cxcy + + ifx = floor(xx) + icx = ceiling(xx) + ify = floor(yy) + icy = ceiling(yy) + + fxfy = max(0., 1.0 - sqrt((xx-real(ifx))**2+(yy-real(ify))**2)) + fxcy = max(0., 1.0 - sqrt((xx-real(ifx))**2+(yy-real(icy))**2)) + cxfy = max(0., 1.0 - sqrt((xx-real(icx))**2+(yy-real(ify))**2)) + cxcy = max(0., 1.0 - sqrt((xx-real(icx))**2+(yy-real(icy))**2)) + + ! First, make sure that the point is contained in the source array + if (ifx < start_x .or. icx > end_x .or. & + ify < start_y .or. icy > end_y) then + + ! But if the point is at most half a grid point out, we can + ! still proceed with modified ifx, icx, ify, and icy. + if (xx > real(start_x)-0.5 .and. ifx < start_x) then + ifx = start_x + icx = start_x + else if (xx < real(end_x)+0.5 .and. icx > end_x) then + ifx = end_x + icx = end_x + end if + + if (yy > real(start_y)-0.5 .and. ifx < start_y) then + ify = start_y + icy = start_y + else if (yy < real(end_y)+0.5 .and. icy > end_y) then + ify = end_y + icy = end_y + end if + + if (ifx < start_x .or. icx > end_x .or. & + ify < start_y .or. icy > end_y) then + wt_four_pt_average = msgval + return + end if + end if + + if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then + ! we determine which maskval is useable by... if the symbol > is found, then only + ! values less than 'maskval' can be used and if the symbol < is found, + ! then only the values greater than 'maskval' can be used. + if (mask_relational == '>') then + if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) > maskval) fxfy = 0.0 + if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) > maskval) fxcy = 0.0 + if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) > maskval) cxfy = 0.0 + if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) > maskval) cxcy = 0.0 + else if (mask_relational == '<') then + if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) < maskval) fxfy = 0.0 + if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) < maskval) fxcy = 0.0 + if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) < maskval) cxfy = 0.0 + if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) < maskval) cxcy = 0.0 + else !equal + if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) == maskval) fxfy = 0.0 + if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) == maskval) fxcy = 0.0 + if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) == maskval) cxfy = 0.0 + if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) == maskval) cxcy = 0.0 + end if + else if (present(mask_array) .and. present(maskval)) then + if (array(ifx, ify, izz) == msgval .or. mask_array(ifx,ify) == maskval) fxfy = 0.0 + if (array(ifx, icy, izz) == msgval .or. mask_array(ifx,icy) == maskval) fxcy = 0.0 + if (array(icx, ify, izz) == msgval .or. mask_array(icx,ify) == maskval) cxfy = 0.0 + if (array(icx, icy, izz) == msgval .or. mask_array(icx,icy) == maskval) cxcy = 0.0 + else + if (array(ifx, ify, izz) == msgval) fxfy = 0.0 + if (array(ifx, icy, izz) == msgval) fxcy = 0.0 + if (array(icx, ify, izz) == msgval) cxfy = 0.0 + if (array(icx, icy, izz) == msgval) cxcy = 0.0 + end if + + ! If all four points are missing, try the next interpolation method in the sequence + if (fxfy == 0.0 .and. fxcy == 0.0 .and. cxfy == 0.0 .and. cxcy == 0.0) then + wt_four_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + else + wt_four_pt_average = (fxfy * array(ifx, ify, izz) + & + fxcy * array(ifx, icy, izz) + & + cxfy * array(icx, ify, izz) + & + cxcy * array(icx, icy, izz) ) / (fxfy + fxcy + cxfy + cxcy) + end if + + end function wt_four_pt_average + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: sixteen_pt_average + ! + ! Purpose: Average of sixteen surrounding grid point values + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive function sixteen_pt_average(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + + implicit none + + ! Arguments + integer, intent(in) :: start_x, start_y, start_z + integer, intent(in) :: end_x, end_y, end_z + integer, intent(in) :: izz ! The z-index of the 2d-array to + ! interpolate within + real, intent(in) :: xx , yy ! The location to interpolate to + real, intent(in) :: msgval + real, intent(in), optional :: maskval + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), & + intent(in) :: array + integer, dimension(:), intent(in) :: interp_list + integer, dimension(:), intent(in) :: interp_opts + integer, intent(in) :: idx + real, dimension(start_x:end_x, start_y:end_y), & + intent(in), optional :: mask_array + character (len=1), intent(in), optional :: mask_relational + + ! Return value + real :: sixteen_pt_average + + ! Local variables + integer :: i, j, ifx, ify + real :: sum, sum_weight + real, dimension(4,4) :: weights + + ifx = floor(xx) + ify = floor(yy) + + ! First see whether the point is far enough within the array to + ! allow for a sixteen point average. + if (ifx < start_x+1 .or. ifx > end_x-2 .or. & + ify < start_y+1 .or. ify > end_y-2) then + sixteen_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + return + end if + + sum_weight = 0.0 + do i=1,4 + do j=1,4 + if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then + if (mask_relational == '>' .and. mask_array(ifx+3-i, ify+3-j) > maskval) then + weights(i,j) = 0.0 + else if (mask_relational == '<' .and. mask_array(ifx+3-i, ify+3-j) < maskval) then + weights(i,j) = 0.0 + else if (mask_relational == ' ' .and. mask_array(ifx+3-i, ify+3-j) == maskval) then + weights(i,j) = 0.0 + else + weights(i,j) = 1.0 + end if + if (array(ifx+3-i, ify+3-j, izz) == msgval) weights(i,j) = 0.0 + else if (present(mask_array) .and. present(maskval)) then + if (array(ifx+3-i, ify+3-j, izz) == msgval .or. mask_array(ifx+3-i, ify+3-j) == maskval) then + weights(i,j) = 0.0 + else + weights(i,j) = 1.0 + end if + else + if (array(ifx+3-i, ify+3-j, izz) == msgval) then + weights(i,j) = 0.0 + else + weights(i,j) = 1.0 + end if + end if + + sum_weight = sum_weight + weights(i,j) + + end do + end do + + ! If all points are missing, try the next interpolation method in the sequence + if (sum_weight == 0.0) then + sixteen_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + else + sum = 0.0 + do i=1,4 + do j=1,4 + sum = sum + weights(i,j) * array(ifx+3-i, ify+3-j, izz) + end do + end do + sixteen_pt_average = sum / sum_weight + end if + + end function sixteen_pt_average + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: wt_sixteen_pt_average + ! + ! Purpose: Weighted average of sixteen surrounding grid point values + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive function wt_sixteen_pt_average(xx, yy, izz, array, start_x, end_x, & + start_y, end_y, start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + + implicit none + + ! Arguments + integer, intent(in) :: start_x, start_y, start_z + integer, intent(in) :: end_x, end_y, end_z + integer, intent(in) :: izz ! The z-index of the 2d-array to + ! interpolate within + real, intent(in) :: xx , yy ! The location to interpolate to + real, intent(in) :: msgval + real, intent(in), optional :: maskval + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), & + intent(in) :: array + integer, dimension(:), intent(in) :: interp_list + integer, dimension(:), intent(in) :: interp_opts + integer, intent(in) :: idx + real, dimension(start_x:end_x, start_y:end_y), & + intent(in), optional :: mask_array + character (len=1), intent(in), optional :: mask_relational + + ! Return value + real :: wt_sixteen_pt_average + + ! Local variables + integer :: i, j, ifx, ify + real :: sum, sum_weight + real, dimension(4,4) :: weights + + ifx = floor(xx) + ify = floor(yy) + + ! First see whether the point is far enough within the array to + ! allow for a sixteen point average. + if (ifx < start_x+1 .or. ifx > end_x-2 .or. & + ify < start_y+1 .or. ify > end_y-2) then + wt_sixteen_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + return + end if + + sum_weight = 0.0 + do i=1,4 + do j=1,4 + if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then + if (mask_relational == '>' .and. mask_array(ifx+3-i, ify+3-j) > maskval) then + weights(i,j) = 0.0 + else if (mask_relational == '<' .and. mask_array(ifx+3-i, ify+3-j) < maskval) then + weights(i,j) = 0.0 + else if (mask_relational == ' ' .and. mask_array(ifx+3-i, ify+3-j) == maskval) then + weights(i,j) = 0.0 + else + weights(i,j) = max(0., 2.0 - sqrt((xx-real(ifx+3-i))**2+(yy-real(ify+3-j))**2)) + end if + if (array(ifx+3-i, ify+3-j, izz) == msgval) weights(i,j) = 0.0 + else if (present(mask_array) .and. present(maskval)) then + if (array(ifx+3-i, ify+3-j, izz) == msgval .or. mask_array(ifx+3-i, ify+3-j) == maskval) then + weights(i,j) = 0.0 + else + weights(i,j) = max(0., 2.0 - sqrt((xx-real(ifx+3-i))**2+(yy-real(ify+3-j))**2)) + end if + else + if (array(ifx+3-i, ify+3-j, izz) == msgval) then + weights(i,j) = 0.0 + else + weights(i,j) = max(0., 2.0 - sqrt((xx-real(ifx+3-i))**2+(yy-real(ify+3-j))**2)) + end if + end if + + sum_weight = sum_weight + weights(i,j) + + end do + end do + + ! If all points are missing, try the next interpolation method in the sequence + if (sum_weight == 0.0) then + wt_sixteen_pt_average = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + else + sum = 0.0 + do i=1,4 + do j=1,4 + sum = sum + weights(i,j) * array(ifx+3-i, ify+3-j, izz) + end do + end do + wt_sixteen_pt_average = sum / sum_weight + end if + + end function wt_sixteen_pt_average + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: four_pt + ! + ! Purpose: Bilinear interpolation among four grid values + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive function four_pt(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + + implicit none + + ! Arguments + integer, intent(in) :: start_x, start_y, start_z + integer, intent(in) :: end_x, end_y, end_z + integer, intent(in) :: izz ! The z-index of the 2d-array to + ! interpolate within + real, intent(in) :: xx , yy ! The location to interpolate to + real, intent(in) :: msgval + real, intent(in), optional :: maskval + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), intent(in) :: array + integer, dimension(:), intent(in) :: interp_list + integer, dimension(:), intent(in) :: interp_opts + integer, intent(in) :: idx + real, dimension(start_x:end_x, start_y:end_y), intent(in), optional :: mask_array + character (len=1), intent(in), optional :: mask_relational + + ! Return value + real :: four_pt + + ! Local variables + integer :: min_x, min_y, max_x, max_y + + min_x = floor(xx) + min_y = floor(yy) + max_x = ceiling(xx) + max_y = ceiling(yy) + + if (min_x < start_x .or. max_x > end_x) then + four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + return + end if + + if (min_y < start_y .or. max_y > end_y) then + four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + return + end if + + ! If we have a missing value, try the next interpolation method in the sequence + if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then + ! we determine which maskval is useable by... if the symbol > is found, then only + ! values less than 'maskval' can be used and if the symbol < is found, + ! then only the values greater than 'maskval' can be used. + if (mask_relational == '>' ) then + if (array(min_x,min_y,izz) == msgval .or. mask_array(min_x,min_y) > maskval .or. & + array(max_x,min_y,izz) == msgval .or. mask_array(max_x,min_y) > maskval .or. & + array(min_x,max_y,izz) == msgval .or. mask_array(min_x,max_y) > maskval .or. & + array(max_x,max_y,izz) == msgval .or. mask_array(max_x,max_y) > maskval) then + four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + return + end if + else if (mask_relational == '<' ) then + if (array(min_x,min_y,izz) == msgval .or. mask_array(min_x,min_y) < maskval .or. & + array(max_x,min_y,izz) == msgval .or. mask_array(max_x,min_y) < maskval .or. & + array(min_x,max_y,izz) == msgval .or. mask_array(min_x,max_y) < maskval .or. & + array(max_x,max_y,izz) == msgval .or. mask_array(max_x,max_y) < maskval) then + four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + return + end if + else if (mask_relational == ' ' ) then + if (array(min_x,min_y,izz) == msgval .or. mask_array(min_x,min_y) == maskval .or. & + array(max_x,min_y,izz) == msgval .or. mask_array(max_x,min_y) == maskval .or. & + array(min_x,max_y,izz) == msgval .or. mask_array(min_x,max_y) == maskval .or. & + array(max_x,max_y,izz) == msgval .or. mask_array(max_x,max_y) == maskval) then + four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + return + end if + end if + else if (present(mask_array) .and. present(maskval)) then + if (array(min_x,min_y,izz) == msgval .or. mask_array(min_x,min_y) == maskval .or. & + array(max_x,min_y,izz) == msgval .or. mask_array(max_x,min_y) == maskval .or. & + array(min_x,max_y,izz) == msgval .or. mask_array(min_x,max_y) == maskval .or. & + array(max_x,max_y,izz) == msgval .or. mask_array(max_x,max_y) == maskval) then + four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + end if + else + if (array(min_x,min_y,izz) == msgval .or. & + array(max_x,min_y,izz) == msgval .or. & + array(min_x,max_y,izz) == msgval .or. & + array(max_x,max_y,izz) == msgval ) then + four_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx) + return + end if + end if + + if (min_x == max_x) then + if (min_y == max_y) then + four_pt = array(min_x,min_y,izz) + else + four_pt = array(min_x,min_y,izz)*(real(max_y)-yy) + & + array(min_x,max_y,izz)*(yy-real(min_y)) + end if + else if (min_y == max_y) then + if (min_x == max_x) then + four_pt = array(min_x,min_y,izz) + else + four_pt = array(min_x,min_y,izz)*(real(max_x)-xx) + & + array(max_x,min_y,izz)*(xx-real(min_x)) + end if + else + four_pt = (yy - min_y) * (array(min_x,max_y,izz)*(real(max_x)-xx) + & + array(max_x,max_y,izz)*(xx-real(min_x))) + & + (max_y - yy) * (array(min_x,min_y,izz)*(real(max_x)-xx) + & + array(max_x,min_y,izz)*(xx-real(min_x))); + end if + + end function four_pt + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: sixteen_pt + ! + ! Purpose: Overlapping parabolic interpolation among sixteen grid values + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive function sixteen_pt(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + + implicit none + + ! Arguments + integer, intent(in) :: izz ! z-index of 2d-array to interpolate within + integer, intent(in) :: start_x, start_y, start_z + integer, intent(in) :: end_x, end_y, end_z + real, intent(in) :: xx , yy ! The location to interpolate to + real, intent(in) :: msgval + real, intent(in), optional :: maskval + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), & + intent(in) :: array + integer, dimension(:), intent(in) :: interp_list + integer, dimension(:), intent(in) :: interp_opts + integer, intent(in) :: idx + real, dimension(start_x:end_x, start_y:end_y), & + intent(in), optional :: mask_array + character (len=1), intent(in), optional :: mask_relational + + ! Return value + real :: sixteen_pt + + ! Local variables + integer :: n , i , j , k , kk , l , ll + real :: x , y , a , b , c , d , e , f , g , h + real, dimension(4,4) :: stl + logical :: is_masked + + is_masked = .false. + + if (int(xx) < start_x .or. int(xx) > end_x .or. & + int(yy) < start_y .or. int(yy) > end_y) then + sixteen_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + return + end if + + sixteen_pt = 0.0 + n = 0 + i = int(xx + 0.00001) + j = int(yy + 0.00001) + x = xx - i + y = yy - j + + if ( ( abs(x) > 0.0001 ) .or. ( abs(y) > 0.0001 ) ) then + + loop_1 : do k = 1,4 + kk = i + k - 2 + if ( kk < start_x) then + kk = start_x + else if ( kk > end_x) then + kk = end_x + end if + loop_2 : do l = 1,4 + stl(k,l) = 0. + ll = j + l - 2 + if ( ll < start_y ) then + ll = start_y + else if ( ll > end_y) then + ll = end_y + end if + stl(k,l) = array(kk,ll,izz) + n = n + 1 + if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then + if (mask_relational == '>' .and. mask_array(kk,ll) > maskval) then + is_masked = .true. + else if (mask_relational == '<' .and. mask_array(kk,ll) < maskval) then + is_masked = .true. + else if (mask_relational == ' ' .and. mask_array(kk,ll) == maskval) then + is_masked = .true. + end if + else if (present(mask_array) .and. present(maskval)) then + if (mask_array(kk,ll) == maskval) is_masked = .true. + end if + if ( stl(k,l) == 0. .and. msgval /= 0.) then + stl(k,l) = 1.E-20 + end if + end do loop_2 + end do loop_1 + + ! If we have a missing value, try the next interpolation method in the sequence + if (present(mask_array) .and. present(maskval)) then + do k=1,4 + do l=1,4 + if (stl(k,l) == msgval .or. is_masked) then + sixteen_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx, & + mask_relational, maskval, mask_array) + return + end if + end do + end do + else + do k=1,4 + do l=1,4 + if (stl(k,l) == msgval) then + sixteen_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, & + start_z, end_z, msgval, interp_list, interp_opts, idx) + return + end if + end do + end do + end if + + a = oned(x,stl(1,1),stl(2,1),stl(3,1),stl(4,1)) + b = oned(x,stl(1,2),stl(2,2),stl(3,2),stl(4,2)) + c = oned(x,stl(1,3),stl(2,3),stl(3,3),stl(4,3)) + d = oned(x,stl(1,4),stl(2,4),stl(3,4),stl(4,4)) + sixteen_pt = oned(y,a,b,c,d) + + if (n /= 16) then + e = oned(y,stl(1,1),stl(1,2),stl(1,3),stl(1,4)) + f = oned(y,stl(2,1),stl(2,2),stl(2,3),stl(2,4)) + g = oned(y,stl(3,1),stl(3,2),stl(3,3),stl(3,4)) + h = oned(y,stl(4,1),stl(4,2),stl(4,3),stl(4,4)) + sixteen_pt = (sixteen_pt+oned(x,e,f,g,h)) * 0.5 + end if + + if (sixteen_pt == 1.E-20) sixteen_pt = 0. + + else + if (present(mask_array) .and. present(maskval) .and. present(mask_relational)) then + if (i >= start_x .and. i <= end_x .and. j >= start_y .and. j <= end_y .and. & + mask_relational == '<' .and. mask_array(i,j) >= maskval .and. array(i,j,izz) /= msgval) then + sixteen_pt = array(i,j,izz) + else if (i >= start_x .and. i <= end_x .and. j >= start_y .and. j <= end_y .and. & + mask_relational == '>' .and. mask_array(i,j) <= maskval .and. array(i,j,izz) /= msgval) then + sixteen_pt = array(i,j,izz) + else if (i >= start_x .and. i <= end_x .and. j >= start_y .and. j <= end_y .and. & + mask_relational == ' ' .and. mask_array(i,j) /= maskval .and. array(i,j,izz) /= msgval) then + sixteen_pt = array(i,j,izz) + else + sixteen_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + end if + else if (present(mask_array) .and. present(maskval)) then + if (i >= start_x .and. i <= end_x .and. j >= start_y .and. j <= end_y .and. & + mask_array(i,j) /= maskval .and. array(i,j,izz) /= msgval) then + sixteen_pt = array(i,j,izz) + else + sixteen_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + end if + else + if (i >= start_x .and. i <= end_x .and. j >= start_y .and. j <= end_y .and. array(i,j,izz) /= msgval) then + sixteen_pt = array(i,j,izz) + else + sixteen_pt = interp_sequence(xx, yy, izz, array, start_x, end_x, start_y, end_y, start_z, end_z, & + msgval, interp_list, interp_opts, idx, mask_relational, maskval, mask_array) + end if + end if + end if + + end function sixteen_pt + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: oned + ! + ! Purpose: 1-dimensional overlapping parabolic interpolation + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function oned(x,a,b,c,d) + + implicit none + + ! Arguments + real, intent(in) :: x,a,b,c,d + + ! Return value + real :: oned + + oned = 0. + + if ( x == 0. ) then + oned = b + else if ( x == 1. ) then + oned = c + end if + + if (b*c /= 0.) then + if ( a*d == 0. ) then + if ( ( a == 0 ) .and. ( d == 0 ) ) then + oned = b*(1.0-x)+c*x + else if ( a /= 0. ) then + oned = b+x*(0.5*(c-a)+x*(0.5*(c+a)-b)) + else if ( d /= 0. ) then + oned = c+(1.0-x)*(0.5*(b-d)+(1.0-x)*(0.5*(b+d)-c)) + end if + else + oned = (1.0-x)*(b+x*(0.5*(c-a)+x*(0.5*(c+a)-b)))+x*(c+(1.0-x)*(0.5*(b-d)+(1.0-x)*(0.5*(b+d)-c))) + end if + end if + + end function oned + +end module interp_module diff --git a/WPS/geogrid/src/list_module.F b/WPS/geogrid/src/list_module.F new file mode 100644 index 00000000..f136ac0f --- /dev/null +++ b/WPS/geogrid/src/list_module.F @@ -0,0 +1,352 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! MODULE LIST_MODULE +! +! Purpose: This module implements a list with insert, search, and +! remove routines. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module list_module + + use module_debug + + type list_item + integer :: ikey, ivalue + character (len=128) :: ckey, cvalue + type (list_item), pointer :: next, prev + end type list_item + + type list + integer :: l_len + type (list_item), pointer :: head, tail + end type list + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: list_init + ! + ! Purpose: To initialize a list type + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine list_init(l) + + implicit none + + ! Arguments + type (list), intent(inout) :: l + + nullify(l%head) + nullify(l%tail) + l%l_len = 0 + + end subroutine list_init + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: list_insert + ! + ! Purpose: Given a list l, a key, and a value to be stored with that key, + ! this routine adds (key, value) to the table. + ! + ! NOTE: If the key already exists in the list, a second copy of a list item + ! with that key is added, possibly with a different associated value. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine list_insert(l, ikey, ivalue, ckey, cvalue) + + implicit none + + ! Arguments + integer, intent(in), optional :: ikey, ivalue + character (len=128), intent(in), optional :: ckey, cvalue + type (list), intent(inout) :: l + + ! Local variables + type (list_item), pointer :: lp + + allocate(lp) + nullify(lp%prev) + nullify(lp%next) + if (present(ikey) .and. present(ivalue)) then + lp%ikey = ikey + lp%ivalue = ivalue + else if (present(ckey) .and. present(cvalue)) then + lp%ckey = ckey + lp%cvalue = cvalue + else + call mprintf(.true.,ERROR,'list_insert() called without proper arguments.') + end if + + if (associated(l%tail)) then + l%tail%next => lp + lp%prev => l%tail + l%tail => lp + else + l%tail => lp + l%head => lp + end if + + l%l_len = l%l_len + 1 + + end subroutine list_insert + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: list_get_keys + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function list_get_keys(l) + + implicit none + + ! Arguments + type (list), intent(in) :: l + + ! Return value + type (list_item), pointer, dimension(:) :: list_get_keys + + ! Local variables + integer :: i + type (list_item), pointer :: lp + + allocate(list_get_keys(l%l_len)) + + lp => l%head + + i = 1 + do while (associated(lp)) + list_get_keys(i)%ikey = lp%ikey + list_get_keys(i)%ivalue = lp%ivalue + list_get_keys(i)%ckey = lp%ckey + list_get_keys(i)%cvalue = lp%cvalue + lp => lp%next + i = i + 1 + end do + + return + + end function list_get_keys + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: list_search + ! + ! Purpose: If key k is found in the list, this function returns TRUE and sets + ! value equal to the value stored with k. If the k is not found, this + ! function returns FALSE, and value is undefined. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function list_search(l, ikey, ivalue, ckey, cvalue) + + implicit none + + ! Arguments + integer, intent(in), optional :: ikey + integer, intent(out), optional :: ivalue + character (len=128), intent(in), optional :: ckey + character (len=128), intent(out), optional :: cvalue + type (list), intent(inout) :: l + + ! Return value + logical :: list_search + + ! Local variables + type (list_item), pointer :: lp + + list_search = .false. + + lp => l%head + + do while (associated(lp)) + if (present(ikey) .and. present(ivalue)) then + if (lp%ikey == ikey) then + list_search = .true. + ivalue = lp%ivalue + exit + end if + else if (present(ckey) .and. present(cvalue)) then + if (lp%ckey == ckey) then + list_search = .true. + cvalue = lp%cvalue + exit + end if + else + call mprintf(.true.,ERROR,'list_search() called without proper arguments.') + end if + lp => lp%next + end do + + end function list_search + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: list_get_first_item + ! + ! Purpose: Sets k and v equal to the key and value, respectively, of the + ! first item in the list. The list should be thought of as a queue, so that + ! the first item refers to the least recently inserted item that has not yet + ! been removed or retrieved. This item is also removed from the list before + ! the subroutine returns. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine list_get_first_item(l, ikey, ivalue, ckey, cvalue) + + implicit none + + ! Arguments + integer, intent(out), optional :: ikey, ivalue + character (len=128), intent(out), optional :: ckey, cvalue + type (list), intent(inout) :: l + + ! Local variables + type (list_item), pointer :: lp + + lp => l%head + + if (associated(lp)) then + if (present(ikey) .and. present(ivalue)) then + ikey = lp%ikey + ivalue = lp%ivalue + else if (present(ckey) .and. present(cvalue)) then + ckey = lp%ckey + cvalue = lp%cvalue + else + call mprintf(.true.,ERROR,'list_get_first_item() called without proper arguments.') + end if + l%head => lp%next + if (associated(lp%next)) nullify(lp%next%prev) + deallocate(lp) + l%l_len = l%l_len - 1 + end if + + end subroutine list_get_first_item + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: list_remove + ! + ! Purpose: Deletes the entry with key k from the list. If multiple entries + ! have the specified key, only the first encountered entry is deleted. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine list_remove(l, ikey, ckey) + + implicit none + + ! Arguments + integer, intent(in), optional :: ikey + character (len=128), intent(in), optional :: ckey + type (list), intent(inout) :: l + + ! Local variables + type (list_item), pointer :: lp + + lp => l%head + + do while (associated(lp)) + if (present(ikey)) then + if (lp%ikey == ikey) then + + if (.not. associated(lp%prev)) then + l%head => lp%next + if (.not. associated(l%head)) nullify(l%tail) + if (associated(lp%next)) nullify(lp%next%prev) + deallocate(lp) + else if (.not. associated(lp%next)) then + l%tail => lp%prev + if (.not. associated(l%tail)) nullify(l%head) + if (associated(lp%prev)) nullify(lp%prev%next) + deallocate(lp) + else + lp%prev%next => lp%next + lp%next%prev => lp%prev + deallocate(lp) + end if + l%l_len = l%l_len - 1 + + exit + + end if + + else if (present(ckey)) then + + if (lp%ckey == ckey) then + + if (.not. associated(lp%prev)) then + l%head => lp%next + if (.not. associated(l%head)) nullify(l%tail) + if (associated(lp%next)) nullify(lp%next%prev) + deallocate(lp) + else if (.not. associated(lp%next)) then + l%tail => lp%prev + if (.not. associated(l%tail)) nullify(l%head) + if (associated(lp%prev)) nullify(lp%prev%next) + deallocate(lp) + else + lp%prev%next => lp%next + lp%next%prev => lp%prev + deallocate(lp) + end if + l%l_len = l%l_len - 1 + + exit + + end if + else + call mprintf(.true.,ERROR,'list_remove() called without proper arguments.') + end if + + lp => lp%next + end do + + end subroutine list_remove + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: list_length + ! + ! Purpose: Returns the number of items in the list l. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function list_length(l) + + implicit none + + ! Arguments + type (list), intent(in) :: l + + ! Return value + integer :: list_length + + list_length = l%l_len + + return + + end function list_length + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: list_destroy + ! + ! Purpose: Frees all memory associated with list l. This routine may be + ! used to remove all entries from a list. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine list_destroy(l) + + implicit none + + ! Arguments + type (list), intent(inout) :: l + + ! Local variables + type (list_item), pointer :: lp + + lp => l%head + + do while (associated(lp)) + l%head => lp%next + deallocate(lp) + lp => l%head + end do + + l%l_len = 0 + nullify(l%head) + nullify(l%tail) + + end subroutine list_destroy + +end module list_module diff --git a/WPS/geogrid/src/llxy_module.F b/WPS/geogrid/src/llxy_module.F new file mode 100644 index 00000000..7d482afa --- /dev/null +++ b/WPS/geogrid/src/llxy_module.F @@ -0,0 +1,889 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! MODULE LLXY_MODULE +! +! This module handles transformations between model grid coordinates and +! latitude-longitude coordinates. The actual transformations are done through +! the map_utils module. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module llxy_module + + use gridinfo_module + use list_module + use map_utils + use module_debug + use misc_definitions_module + + ! Parameters + integer, parameter :: MAX_SOURCE_LEVELS = 20 + + ! Variables + integer :: current_nest_number + integer :: SOURCE_PROJ = 0 + ! The following arrays hold values for all available domains + ! NOTE: The entries in the arrays for "domain 0" are used for projection + ! information of user-specified source data + type (proj_info), dimension(-MAX_SOURCE_LEVELS:MAX_DOMAINS) :: proj_stack + + ! The projection and domain that we have computed constants for + integer :: computed_proj = INVALID + integer :: computed_domain = INVALID + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: push_source_projection + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine push_source_projection(iprojection, user_stand_lon, user_truelat1, user_truelat2, & + user_dxkm, user_dykm, user_dlat, user_dlon, user_known_x, & + user_known_y, user_known_lat, user_known_lon, & + user_pole_lat, user_pole_lon, & + user_centerlat, user_centerlon, & + user_centeri, user_centerj, & + earth_radius) + + implicit none + + ! Arguments + integer, intent(in) :: iprojection + real, intent(in) :: user_stand_lon, user_truelat1, user_truelat2, user_dxkm, user_dykm, & + user_dlat, user_dlon, & + user_known_x, user_known_y, user_known_lat, user_known_lon + real, intent(in), optional :: earth_radius + real, intent(in), optional :: user_centerlon, user_centerlat, user_pole_lat, user_pole_lon + real, intent(in), optional :: user_centerj, user_centeri + + + SOURCE_PROJ = SOURCE_PROJ-1 + if (SOURCE_PROJ < -MAX_SOURCE_LEVELS) then + call mprintf(.true.,ERROR,'In push_user_projection(), too many levels of user projections.') + end if + + call map_init(proj_stack(SOURCE_PROJ)) + + if (iprojection == PROJ_LATLON) then + call map_set(iprojection, proj_stack(SOURCE_PROJ), & + lat1=user_known_lat, & + lon1=user_known_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + nxmax=nint(360.0 / user_dlon), & + latinc=user_dlat, & + loninc=user_dlon, & + r_earth=earth_radius) + + else if (iprojection == PROJ_MERC) then + call map_set(iprojection, proj_stack(SOURCE_PROJ), & + truelat1=user_truelat1, & + lat1=user_known_lat, & + lon1=user_known_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + dx=user_dxkm, & + r_earth=earth_radius) + + else if (iprojection == PROJ_CYL) then + call mprintf(.true.,ERROR,'Should not have PROJ_CYL as projection for ' & + //'source data in push_source_projection()') + + else if (iprojection == PROJ_CASSINI) then + + call map_set(iprojection, proj_stack(SOURCE_PROJ), & + latinc=user_dlat, & + loninc=user_dlon, & + stdlon=user_stand_lon, & + lat1=user_centerlat, & + lon1=user_centerlon, & + lat0=user_pole_lat, & + lon0=user_pole_lon, & + knowni=user_centeri, & + knownj=user_centerj, & + r_earth=earth_radius) + + else if (iprojection == PROJ_LC) then + call map_set(iprojection, proj_stack(SOURCE_PROJ), & + truelat1=user_truelat1, & + truelat2=user_truelat2, & + stdlon=user_stand_lon, & + lat1=user_known_lat, & + lon1=user_known_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + dx=user_dxkm, & + r_earth=earth_radius) + + else if (iprojection == PROJ_ALBERS_NAD83) then + call map_set(iprojection, proj_stack(SOURCE_PROJ), & + truelat1=user_truelat1, & + truelat2=user_truelat2, & + stdlon=user_stand_lon, & + lat1=user_known_lat, & + lon1=user_known_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + dx=user_dxkm, & + r_earth=earth_radius) + + else if (iprojection == PROJ_PS) then + call map_set(iprojection, proj_stack(SOURCE_PROJ), & + truelat1=user_truelat1, & + stdlon=user_stand_lon, & + lat1=user_known_lat, & + lon1=user_known_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + dx=user_dxkm, & + r_earth=earth_radius) + + else if (iprojection == PROJ_PS_WGS84) then + call map_set(iprojection, proj_stack(SOURCE_PROJ), & + truelat1=user_truelat1, & + stdlon=user_stand_lon, & + lat1=user_known_lat, & + lon1=user_known_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + dx=user_dxkm, & + r_earth=earth_radius) + + else if (iprojection == PROJ_GAUSS) then + call map_set(iprojection, proj_stack(SOURCE_PROJ), & + lat1=user_known_lat, & + lon1=user_known_lon, & + nxmax=nint(360.0 / user_dlon), & + nlat=nint(user_dlat), & + loninc=user_dlon, & + r_earth=earth_radius) + + else if (iprojection == PROJ_ROTLL) then + ! BUG: Implement this projection. + + end if + + end subroutine push_source_projection + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: pop_source_projection + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine pop_source_projection() + + implicit none + + SOURCE_PROJ = SOURCE_PROJ+1 + + call mprintf((SOURCE_PROJ > 0), ERROR, & + 'In pop_user_projection(), projection stack has overflowed.') + + end subroutine pop_source_projection + + +#ifdef _METGRID + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: set_domain_projection + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine set_domain_projection(iprojection, user_stand_lon, user_truelat1, user_truelat2, & + user_dxkm, user_dykm, user_dlat, user_dlon, & + user_xdim, user_ydim, user_known_x, & + user_known_y, user_known_lat, user_known_lon, & + user_pole_lat, user_pole_lon, earth_radius) + + implicit none + + ! Arguments + integer, intent(in) :: iprojection + integer, intent(in) :: user_xdim, user_ydim + real, intent(in) :: user_stand_lon, user_truelat1, user_truelat2, & + user_dxkm, user_dykm, user_dlat, user_dlon, & + user_known_x, user_known_y, user_known_lat, user_known_lon, & + user_pole_lat, user_pole_lon + real, intent(in), optional :: earth_radius + + current_nest_number = 1 + + call map_init(proj_stack(current_nest_number)) + + if (iprojection == PROJ_LATLON) then + call map_set(iprojection, proj_stack(current_nest_number), & + lat1=user_known_lat, & + lon1=user_known_lon, & + latinc=user_dlat, & + loninc=user_dlon, & + r_earth=earth_radius) + + else if (iprojection == PROJ_MERC) then + call map_set(iprojection, proj_stack(current_nest_number), & + truelat1=user_truelat1, & + lat1=user_known_lat, & + lon1=user_known_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + dx=user_dxkm, & + r_earth=earth_radius) + + else if (iprojection == PROJ_CYL) then + call map_set(iprojection, proj_stack(current_nest_number), & + latinc=user_dlat, & + loninc=user_dlon, & + stdlon=user_stand_lon, & + r_earth=earth_radius) + + else if (iprojection == PROJ_CASSINI) then + call map_set(iprojection, proj_stack(current_nest_number), & + latinc=user_dlat, & + loninc=user_dlon, & + dx=user_dxkm, & + dy=user_dykm, & + stdlon=user_stand_lon, & + lat1=user_known_lat, & + lon1=user_known_lon, & + lat0=user_pole_lat, & + lon0=user_pole_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + r_earth=earth_radius) + + else if (iprojection == PROJ_LC) then + call map_set(iprojection, proj_stack(current_nest_number), & + truelat1=user_truelat1, & + truelat2=user_truelat2, & + stdlon=user_stand_lon, & + lat1=user_known_lat, & + lon1=user_known_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + dx=user_dxkm, & + r_earth=earth_radius) + + else if (iprojection == PROJ_ALBERS_NAD83) then + call map_set(iprojection, proj_stack(current_nest_number), & + truelat1=user_truelat1, & + truelat2=user_truelat2, & + stdlon=user_stand_lon, & + lat1=user_known_lat, & + lon1=user_known_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + dx=user_dxkm, & + r_earth=earth_radius) + + else if (iprojection == PROJ_PS) then + call map_set(iprojection, proj_stack(current_nest_number), & + truelat1=user_truelat1, & + stdlon=user_stand_lon, & + lat1=user_known_lat, & + lon1=user_known_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + dx=user_dxkm, & + r_earth=earth_radius) + + else if (iprojection == PROJ_PS_WGS84) then + call map_set(iprojection, proj_stack(current_nest_number), & + truelat1=user_truelat1, & + stdlon=user_stand_lon, & + lat1=user_known_lat, & + lon1=user_known_lon, & + knowni=user_known_x, & + knownj=user_known_y, & + dx=user_dxkm) + + else if (iprojection == PROJ_GAUSS) then + call map_set(iprojection, proj_stack(current_nest_number), & + lat1=user_known_lat, & + lon1=user_known_lon, & + nlat=nint(user_dlat), & + loninc=user_dlon, & + r_earth=earth_radius) + + else if (iprojection == PROJ_ROTLL) then + call map_set(iprojection, proj_stack(current_nest_number), & + ixdim=user_xdim, & + jydim=user_ydim, & + phi=user_dlat, & + lambda=user_dlon, & + lat1=user_known_lat, & + lon1=user_known_lon, & + stagger=HH, & + latinc=user_dykm, & + loninc=user_dxkm, & + r_earth=earth_radius) + + end if + + end subroutine set_domain_projection +#endif + + +#ifdef _GEOGRID + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: compute_nest_locations + ! + ! Purpose: This routine computes the variables necessary in determining the + ! location of all nests without reference to the parent or coarse domains. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine compute_nest_locations() + + implicit none + + ! Local variables + integer :: i + real :: temp_known_x, temp_known_y, temp_known_lat, temp_known_lon, & + temp_dxkm, temp_dykm, temp_dlat, temp_dlon + + ! Set location of coarse/mother domain + call map_init(proj_stack(1)) + + if (iproj_type == PROJ_LATLON) then + call map_set(iproj_type, proj_stack(1), & + lat1=known_lat, & + lon1=known_lon, & + latinc=dykm, & + loninc=dxkm) + + else if (iproj_type == PROJ_MERC) then + call map_set(iproj_type, proj_stack(1), & + truelat1=truelat1, & + lat1=known_lat, & + lon1=known_lon, & + knowni=known_x, & + knownj=known_y, & + dx=dxkm) + + else if (iproj_type == PROJ_CYL) then + call map_set(iproj_type, proj_stack(1), & + latinc=dlatdeg, & + loninc=dlondeg, & + stdlon=stand_lon) + + else if (iproj_type == PROJ_CASSINI) then + call map_set(iproj_type, proj_stack(1), & + latinc=dlatdeg, & + loninc=dlondeg, & + dx=dxkm, & + dy=dykm, & + stdlon=stand_lon, & + knowni=known_x, & + knownj=known_y, & + lat0=pole_lat, & + lon0=pole_lon, & + lat1=known_lat, & + lon1=known_lon) + + else if (iproj_type == PROJ_LC) then + call map_set(iproj_type, proj_stack(1), & + truelat1=truelat1, & + truelat2=truelat2, & + stdlon=stand_lon, & + lat1=known_lat, & + lon1=known_lon, & + knowni=known_x, & + knownj=known_y, & + dx=dxkm) + + else if (iproj_type == PROJ_ALBERS_NAD83) then + call map_set(iproj_type, proj_stack(1), & + truelat1=truelat1, & + truelat2=truelat2, & + stdlon=stand_lon, & + lat1=known_lat, & + lon1=known_lon, & + knowni=known_x, & + knownj=known_y, & + dx=dxkm) + + else if (iproj_type == PROJ_PS) then + call map_set(iproj_type, proj_stack(1), & + truelat1=truelat1, & + stdlon=stand_lon, & + lat1=known_lat, & + lon1=known_lon, & + knowni=known_x, & + knownj=known_y, & + dx=dxkm) + + else if (iproj_type == PROJ_PS_WGS84) then + call map_set(iproj_type, proj_stack(1), & + truelat1=truelat1, & + stdlon=stand_lon, & + lat1=known_lat, & + lon1=known_lon, & + knowni=known_x, & + knownj=known_y, & + dx=dxkm) + + else if (iproj_type == PROJ_GAUSS) then + call map_set(iproj_type, proj_stack(current_nest_number), & + lat1=known_lat, & + lon1=known_lon, & + nlat=nint(dykm), & + loninc=dxkm) + + else if (iproj_type == PROJ_ROTLL) then + call map_set(iproj_type, proj_stack(1), & + ixdim=ixdim(1), & + jydim=jydim(1), & + phi=phi, & + lambda=lambda, & + lat1=known_lat, & + lon1=known_lon, & + latinc=dykm, & + loninc=dxkm, & + stagger=HH) + + end if + + ! Now we can compute lat/lon <-> x/y for coarse domain + call select_domain(1) + + ! Call a recursive procedure to find the lat/lon of the centerpoint for + ! each domain + do i=2,n_domains + + temp_known_x = real(ixdim(i))/2. + temp_known_y = real(jydim(i))/2. + + call find_known_latlon(i, temp_known_x, temp_known_y, & + temp_known_lat, temp_known_lon, & + temp_dxkm, temp_dykm, temp_dlat, temp_dlon) + + if (iproj_type == PROJ_LATLON) then + call map_set(iproj_type, proj_stack(i), & + lat1=temp_known_lat, & + lon1=temp_known_lon, & + latinc=temp_dlat, & + loninc=temp_dlon) + + else if (iproj_type == PROJ_MERC) then + call map_set(iproj_type, proj_stack(i), & + truelat1=truelat1, & + lat1=temp_known_lat, & + lon1=temp_known_lon, & + knowni=temp_known_x, & + knownj=temp_known_y, & + dx=temp_dxkm) + + else if (iproj_type == PROJ_CYL) then + call mprintf(.true.,ERROR,'Don''t know how to do nesting with PROJ_CYL ' & + //'in compute_nest_locations()') + + else if (iproj_type == PROJ_CASSINI) then + call map_set(iproj_type, proj_stack(i), & + latinc=temp_dlat, & + loninc=temp_dlon, & + dx=temp_dxkm, & + dy=temp_dykm, & + stdlon=stand_lon, & + knowni=temp_known_x, & + knownj=temp_known_y, & + lat0=pole_lat, & + lon0=pole_lon, & + lat1=temp_known_lat, & + lon1=temp_known_lon) + + else if (iproj_type == PROJ_LC) then + call map_set(iproj_type, proj_stack(i), & + truelat1=truelat1, & + truelat2=truelat2, & + stdlon=stand_lon, & + lat1=temp_known_lat, & + lon1=temp_known_lon, & + knowni=temp_known_x, & + knownj=temp_known_y, & + dx=temp_dxkm) + + else if (iproj_type == PROJ_ALBERS_NAD83) then + call map_set(iproj_type, proj_stack(i), & + truelat1=truelat1, & + truelat2=truelat2, & + stdlon=stand_lon, & + lat1=temp_known_lat, & + lon1=temp_known_lon, & + knowni=temp_known_x, & + knownj=temp_known_y, & + dx=temp_dxkm) + + else if (iproj_type == PROJ_PS) then + call map_set(iproj_type, proj_stack(i), & + truelat1=truelat1, & + stdlon=stand_lon, & + lat1=temp_known_lat, & + lon1=temp_known_lon, & + knowni=temp_known_x, & + knownj=temp_known_y, & + dx=temp_dxkm) + + else if (iproj_type == PROJ_PS_WGS84) then + call map_set(iproj_type, proj_stack(i), & + truelat1=truelat1, & + stdlon=stand_lon, & + lat1=temp_known_lat, & + lon1=temp_known_lon, & + knowni=temp_known_x, & + knownj=temp_known_y, & + dx=temp_dxkm) + + else if (iproj_type == PROJ_GAUSS) then + call map_set(iproj_type, proj_stack(current_nest_number), & + lat1=temp_known_lat, & + lon1=temp_known_lon, & + nlat=nint(temp_dykm), & + loninc=temp_dxkm) + + else if (iproj_type == PROJ_ROTLL) then + ! BUG: Implement this projection. + + end if + + end do + + end subroutine compute_nest_locations + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: find_known_latlon + ! + ! Purpose: This recursive routine computes the latitude and longitude for a + ! specified x/y location in the given nest number, and also computes the + ! grid spacing + ! + ! NOTE: This routine assumes that xytoll will work correctly for the + ! coarse domain. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive subroutine find_known_latlon(n, rx, ry, rlat, rlon, dx, dy, dlat, dlon) + + implicit none + + ! Arguments + integer, intent(in) :: n + real, intent(in) :: rx, ry + real, intent(out) :: rlat, rlon, dx, dy, dlat, dlon + + ! Local variables + real :: x_in_parent, y_in_parent + + if (n == 1) then ! Stopping case for the recursion + + dx = dxkm + dy = dykm + dlat = dlatdeg + dlon = dlondeg + call ij_to_latlon(proj_stack(current_nest_number), rx, ry, rlat, rlon) + + return + + else ! Recursive case + + x_in_parent = (rx - ((parent_grid_ratio(n)+1.)/2.)) & + / parent_grid_ratio(n) + parent_ll_x(n) + y_in_parent = (ry - ((parent_grid_ratio(n)+1.)/2.)) & + / parent_grid_ratio(n) + parent_ll_y(n) + + call find_known_latlon(parent_id(n), x_in_parent, y_in_parent, rlat, rlon, dx, dy, dlat, dlon) + + dx = dx / parent_grid_ratio(n) + dy = dy / parent_grid_ratio(n) + dlat = dlat / parent_grid_ratio(n) + dlon = dlon / parent_grid_ratio(n) + end if + + end subroutine find_known_latlon + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: compute_nest_level_info + ! + ! Purpose: This routine computes the parameters describing a nesting level for + ! NMM grids. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine compute_nest_level_info() + + implicit none + + ! Local variables + integer :: i, nest_level, temp + type (list) :: level_list + + call list_init(level_list) + + ! Set location of coarse/mother domain + call map_init(proj_stack(1)) + + call map_set(PROJ_ROTLL, proj_stack(1), & + ixdim=ixdim(1), & + jydim=jydim(1), & + phi=phi, & + lambda=lambda, & + lat1=known_lat, & + lon1=known_lon, & + latinc=dykm, & + loninc=dxkm, & + stagger=HH) + + parent_ur_x(1) = real(ixdim(1)) + parent_ur_y(1) = real(jydim(1)) + + do i=2,n_domains + + nest_level = get_nest_level(i) + + if (.not. list_search(level_list, ikey=nest_level, ivalue=temp)) then + + call list_insert(level_list, ikey=nest_level, ivalue=nest_level) + + ixdim(nest_level) = ixdim(1)*(3**(nest_level-1))-(3**(nest_level-1)-1) + jydim(nest_level) = jydim(1)*(3**(nest_level-1))-(3**(nest_level-1)-1) + + parent_ur_x(nest_level) = ixdim(nest_level) + parent_ur_y(nest_level) = jydim(nest_level) + + call map_set(PROJ_ROTLL, proj_stack(nest_level), & + ixdim = ixdim(nest_level), & + jydim = jydim(nest_level), & + phi = phi, & + lambda = lambda, & + lat1=known_lat, & + lon1=known_lon, & + latinc=(dykm/real((3**(nest_level-1)))), & + loninc=(dxkm/real((3**(nest_level-1)))), & + stagger=HH) + end if + + end do + + call list_destroy(level_list) + + end subroutine compute_nest_level_info + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_domain_resolution + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_domain_resolution(dom_dx, dom_dy) + + implicit none + + ! Arguments + real, intent(out) :: dom_dx, dom_dy + + ! The proj_info structure only stores dx, so set both dom_dx and dom_dy to dx + dom_dx = proj_stack(current_nest_number)%dx + dom_dy = proj_stack(current_nest_number)%dx + + end subroutine get_domain_resolution + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_nest_level + ! + ! Purpose: This function returns, given a grid ID number, the nesting level of + ! that domain; the coarse domain is taken to have nesting level 1. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function get_nest_level(i) + + implicit none + + ! Arguments + integer, intent(in) :: i + + ! Local variables + integer :: j + + ! Return value + integer :: get_nest_level + + ! If argument is the coarse domain, return + if (i == 1) then + get_nest_level = 1 + return + end if + + if (i > MAX_DOMAINS) then + call mprintf(.true., ERROR, & + 'get_nest_level() called with invalid grid ID of %i.',i1=i) + end if + + ! If not the coarse domain, then nesting level is at least 2 + ! Yes, this looks silly. But we do not have a grid_id array, so + ! we must check on parent_id + get_nest_level = 2 + + j = i + do while (parent_id(j) /= 1) + j = parent_id(j) + get_nest_level = get_nest_level + 1 + + ! Sanity check + if (get_nest_level > MAX_DOMAINS) then + call mprintf(.true., ERROR, & + 'Spooky nesting setup encountered in get_nest_level().') + end if + end do + + end function get_nest_level +#endif + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: select_domain + ! + ! Purpose: This routine is used to select which nest x/y <-> lat/lon + ! conversions will be with respect to. For example, selecting domain 2 will + ! cause the llxy routine to compute x/y locations with respect to domain 2 + ! given a lat/lon. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine select_domain(domain_num) + + implicit none + + ! Arguments + integer, intent(in) :: domain_num + +#ifdef _GEOGRID + if (domain_num > n_domains) then + call mprintf(.true.,ERROR,'In select_domain(), selected domain is greater than n_domains.') + end if +#endif +#ifdef _METGRID + if (domain_num > 1) then + call mprintf(.true.,ERROR,'In select_domain(), selected domain is greater than 1.') + end if +#endif + + current_nest_number = domain_num + + end subroutine select_domain + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: iget_selected_domain + ! + ! Purpose: This function returns the number of the currently selected nest. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function iget_selected_domain() + + implicit none + + ! Return value + integer :: iget_selected_domain + + iget_selected_domain = current_nest_number + + end function iget_selected_domain + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: lltoxy + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine lltoxy(xlat, xlon, x, y, stagger, comp_ll) + + implicit none + + ! Arguments + integer, intent(in) :: stagger + real, intent(in) :: xlat, xlon + real, intent(out) :: x, y + logical, optional, intent(in) :: comp_ll + + ! Local variables + logical :: save_comp_ll + + ! Account for grid staggering + if (stagger == HH) then + proj_stack(current_nest_number)%stagger = HH + else if (stagger == VV) then + proj_stack(current_nest_number)%stagger = VV + end if + + if (present(comp_ll)) then + save_comp_ll = proj_stack(current_nest_number)%comp_ll + proj_stack(current_nest_number)%comp_ll = comp_ll + end if + + call latlon_to_ij(proj_stack(current_nest_number), xlat, xlon, x, y) + + if (present(comp_ll)) then + proj_stack(current_nest_number)%comp_ll = save_comp_ll + end if + + ! Account for grid staggering + if (stagger == U) then + x = x + 0.5 + else if (stagger == V) then + y = y + 0.5 + else if (stagger == CORNER) then + x = x + 0.5 + y = y + 0.5 + end if + + end subroutine lltoxy + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: lltoxy + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine xytoll(x, y, xlat, xlon, stagger, comp_ll) + + implicit none + + ! Arguments + integer, intent(in) :: stagger + real, intent(in) :: x, y + real, intent(out) :: xlat, xlon + logical, optional, intent(in) :: comp_ll + + ! Local variables + real :: rx, ry + logical :: save_comp_ll + + ! Account for grid staggering; we cannot modify x and y, so modify local + ! copies of them + if (stagger == U) then + rx = x - 0.5 + ry = y + else if (stagger == V) then + rx = x + ry = y - 0.5 + else if (stagger == HH) then + proj_stack(current_nest_number)%stagger = HH + rx = x + ry = y + else if (stagger == VV) then + proj_stack(current_nest_number)%stagger = VV + rx = x + ry = y + else if (stagger == CORNER) then + proj_stack(current_nest_number)%stagger = CORNER + rx = x - 0.5 + ry = y - 0.5 + else + rx = x + ry = y + end if + + if (present(comp_ll)) then + save_comp_ll = proj_stack(current_nest_number)%comp_ll + proj_stack(current_nest_number)%comp_ll = comp_ll + end if + + call ij_to_latlon(proj_stack(current_nest_number), rx, ry, xlat, xlon) + + if (present(comp_ll)) then + proj_stack(current_nest_number)%comp_ll = save_comp_ll + end if + + end subroutine xytoll + +end module llxy_module diff --git a/WPS/geogrid/src/misc_definitions_module.F b/WPS/geogrid/src/misc_definitions_module.F new file mode 100644 index 00000000..bb74249d --- /dev/null +++ b/WPS/geogrid/src/misc_definitions_module.F @@ -0,0 +1,49 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! MODULE MISC_DEFINITIONS_MODULE +! +! This module defines various non-meteorological constants that are used +! by other modules for readability. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module misc_definitions_module + + integer, parameter :: MAX_FILENAME_LEN = 1024 + + real, parameter :: NAN=1.E20 + + real, parameter :: NOT_MASKED = -2., & + MASKED_BOTH = -1., & + MASKED_WATER = 0., & + MASKED_LAND = 1. + + integer, parameter :: OUTSIDE_DOMAIN=1E8, NOT_PROCESSED=1E9, INVALID=1E9 + + integer, parameter :: SIXTEEN_POINT=1, FOUR_POINT=2, N_NEIGHBOR=3, & + AVERAGE4=4, AVERAGE16=5, W_AVERAGE4=6, W_AVERAGE16=7, & + SEARCH=8 + + integer, parameter :: BOTTOM_TOP=1, TOP_BOTTOM=2 + + integer, parameter :: CONTINUOUS=0, CATEGORICAL=1, SP_CONTINUOUS=2 + + integer, parameter :: M=1, U=2, V=3, HH=4, VV=5, CORNER=6 + + integer, parameter :: ONETWOONE=1, SMTHDESMTH=2, SMTHDESMTH_SPECIAL=3 + + integer, parameter :: BINARY=1, NETCDF=2, GRIB1=3, HDF=4 + + integer, parameter :: BIG_ENDIAN=0, LITTLE_ENDIAN=1 + + ! Projection codes for proj_info structure: + INTEGER, PUBLIC, PARAMETER :: PROJ_LATLON = 0 + INTEGER, PUBLIC, PARAMETER :: PROJ_LC = 1 + INTEGER, PUBLIC, PARAMETER :: PROJ_PS = 2 + INTEGER, PUBLIC, PARAMETER :: PROJ_PS_WGS84 = 102 + INTEGER, PUBLIC, PARAMETER :: PROJ_MERC = 3 + INTEGER, PUBLIC, PARAMETER :: PROJ_GAUSS = 4 + INTEGER, PUBLIC, PARAMETER :: PROJ_CYL = 5 + INTEGER, PUBLIC, PARAMETER :: PROJ_CASSINI = 6 + INTEGER, PUBLIC, PARAMETER :: PROJ_ALBERS_NAD83 = 105 + INTEGER, PUBLIC, PARAMETER :: PROJ_ROTLL = 203 + +end module misc_definitions_module diff --git a/WPS/geogrid/src/module_debug.F b/WPS/geogrid/src/module_debug.F new file mode 100644 index 00000000..315ce4d2 --- /dev/null +++ b/WPS/geogrid/src/module_debug.F @@ -0,0 +1,331 @@ +module module_debug + +#ifdef _GEOGRID + use parallel_module +#else +#ifdef _METGRID + use parallel_module +#else + integer, parameter :: IO_NODE = 0 + integer :: my_proc_id = 0 +#endif +#endif + + integer, parameter :: QUIET=-100, LOGFILE=-2, DEBUG=0, INFORM=1, WARN=2, ERROR=3, STDOUT=100 + + integer :: the_debug_level = DEBUG + + logical :: have_set_logname = .false. + + logical :: continuing_line_logfile = .false. + logical :: continuing_line_debug = .false. + logical :: continuing_line_inform = .false. + logical :: continuing_line_warn = .false. + logical :: continuing_line_error = .false. + logical :: continuing_line_stdout = .false. + + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: set_debug_level + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine set_debug_level(ilev) + + implicit none + + ! Arguments + integer, intent(in) :: ilev + + the_debug_level = ilev + + end subroutine set_debug_level + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: mprintf + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine mprintf(assertion, level, fmtstring, & + newline, & + i1, i2, i3, i4, i5, i6, & + f1, f2, f3, f4, f5, f6, & + s1, s2, s3, s4, s5, s6, & + l1, l2, l3, l4, l5, l6) + + implicit none + + ! Arguments + integer, intent(in) :: level + logical, intent(in) :: assertion + character (len=*), intent(in) :: fmtstring + logical, intent(in), optional :: newline + integer, intent(in), optional :: i1, i2, i3, i4, i5, i6 + real, intent(in), optional :: f1, f2, f3, f4, f5, f6 + logical, intent(in), optional :: l1, l2, l3, l4, l5, l6 + character (len=*), intent(in), optional :: s1, s2, s3, s4, s5, s6 + + ! Local variables + integer :: idxi, idxf, idxs, idxl, istart, i, iend, ia + real :: fa + logical :: continuing_line, la + character (len=8) :: cur_date + character (len=10) :: cur_time + character (len=10) :: print_date + character (len=12) :: print_time +!BUG: sa should be as long as the largest string length used anywhere in WPS + character (len=1024) :: sa + character (len=1024) :: ctemp + + if (.not. have_set_logname) then + write(ctemp,'(a)') 'logfile.log' + call cio_set_log_filename(ctemp,len_trim(ctemp)) +#ifdef _GEOGRID + if (nprocs == 1) then + write(ctemp,'(a)') 'geogrid.log' + call cio_set_log_filename(ctemp,len_trim(ctemp)) + else + write(ctemp,'(a,i4.4)') 'geogrid.log.',my_proc_id + call cio_set_log_filename(ctemp,len_trim(ctemp)) + end if +#endif +#ifdef _METGRID + if (nprocs == 1) then + write(ctemp,'(a)') 'metgrid.log' + call cio_set_log_filename(ctemp,len_trim(ctemp)) + else + write(ctemp,'(a,i4.4)') 'metgrid.log.',my_proc_id + call cio_set_log_filename(ctemp,len_trim(ctemp)) + end if +#endif +#ifdef _UNGRIB + write(ctemp,'(a)') 'ungrib.log' + call cio_set_log_filename(ctemp,len_trim(ctemp)) +#endif + have_set_logname = .true. + end if + + idxi = 1 + idxf = 1 + idxs = 1 + idxl = 1 + istart = 1 + iend = len_trim(fmtstring) + +#if (defined _GEOGRID) || (defined _METGRID) + if (assertion .and. (.not. (level == STDOUT .and. my_proc_id /= IO_NODE))) then +#else + if (assertion) then +#endif + + ! If this is a debug message give up if level is not high enough + if (level == DEBUG .and. the_debug_level > DEBUG) return + + if (level /= STDOUT) then + call date_and_time(date=cur_date,time=cur_time) + end if + + if (level == LOGFILE .and. .not.continuing_line_logfile) then + write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8) + write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10) + write(ctemp,'(a)') print_date//' '//print_time//' --- ' + call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- ')) + else if (level == DEBUG .and. .not.continuing_line_debug) then + write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8) + write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10) + write(ctemp,'(a)') print_date//' '//print_time//' --- ' + call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- ')) + write(ctemp,'(a)') 'DEBUG: ' + call cio_prints(1,ctemp,7) + else if (level == INFORM .and. .not.continuing_line_inform) then + write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8) + write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10) + write(ctemp,'(a)') print_date//' '//print_time//' --- ' + call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- ')) + write(ctemp,'(a)') 'INFORM: ' + if (level >= the_debug_level) & + call cio_prints(0,ctemp,8) + call cio_prints(1,ctemp,8) + else if (level == WARN .and. .not.continuing_line_warn) then + write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8) + write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10) + write(ctemp,'(a)') print_date//' '//print_time//' --- ' + call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- ')) + write(ctemp,'(a)') 'WARNING: ' + if (level >= the_debug_level) & + call cio_prints(0,ctemp,9) + call cio_prints(1,ctemp,9) + else if (level == ERROR .and. .not.continuing_line_error) then + write(print_date,'(a10)') cur_date(1:4)//'-'//cur_date(5:6)//'-'//cur_date(7:8) + write(print_time,'(a12)') cur_time(1:2)//':'//cur_time(3:4)//':'//cur_time(5:10) + write(ctemp,'(a)') print_date//' '//print_time//' --- ' + call cio_prints(1,ctemp,len(print_date//' '//print_time//' --- ')) + write(ctemp,'(a)') 'ERROR: ' + if (level >= the_debug_level) & + call cio_prints(0,ctemp,7) + call cio_prints(1,ctemp,7) + end if + + i = index(fmtstring(istart:iend),'%') + do while (i > 0 .and. i < iend) + i = i + istart - 1 + write(ctemp,'(a)') fmtstring(istart:i-1) + if (level >= the_debug_level .and. level /= DEBUG) & + call cio_prints(0,ctemp,i-istart) + if (level /= STDOUT) & + call cio_prints(1,ctemp,i-istart) + + if (fmtstring(i+1:i+1) == '%') then + write(ctemp,'(a)') '%' + if (level >= the_debug_level .and. level /= DEBUG) & + call cio_prints(0,ctemp,1) + if (level /= STDOUT) & + call cio_prints(1,ctemp,1) + + else if (fmtstring(i+1:i+1) == 'i') then + if (idxi == 1 .and. present(i1)) then + ia = i1 + else if (idxi == 2 .and. present(i2)) then + ia = i2 + else if (idxi == 3 .and. present(i3)) then + ia = i3 + else if (idxi == 4 .and. present(i4)) then + ia = i4 + else if (idxi == 5 .and. present(i5)) then + ia = i5 + else if (idxi == 6 .and. present(i6)) then + ia = i6 + end if + + if (level >= the_debug_level .and. level /= DEBUG) & + call cio_printi(0,ia) + if (level /= STDOUT) & + call cio_printi(1,ia) + + idxi = idxi + 1 + + else if (fmtstring(i+1:i+1) == 'f') then + if (idxf == 1 .and. present(f1)) then + fa = f1 + else if (idxf == 2 .and. present(f2)) then + fa = f2 + else if (idxf == 3 .and. present(f3)) then + fa = f3 + else if (idxf == 4 .and. present(f4)) then + fa = f4 + else if (idxf == 5 .and. present(f5)) then + fa = f5 + else if (idxf == 6 .and. present(f6)) then + fa = f6 + end if + + if (level >= the_debug_level .and. level /= DEBUG) & + call cio_printf(0,fa) + if (level /= STDOUT) & + call cio_printf(1,fa) + + idxf = idxf + 1 + + else if (fmtstring(i+1:i+1) == 's') then + if (idxs == 1 .and. present(s1)) then + sa = s1 + else if (idxs == 2 .and. present(s2)) then + sa = s2 + else if (idxs == 3 .and. present(s3)) then + sa = s3 + else if (idxs == 4 .and. present(s4)) then + sa = s4 + else if (idxs == 5 .and. present(s5)) then + sa = s5 + else if (idxs == 6 .and. present(s6)) then + sa = s6 + end if + + write(ctemp,'(a)') trim(sa) + if (level >= the_debug_level .and. level /= DEBUG) & + call cio_prints(0,ctemp,len_trim(ctemp)) + if (level /= STDOUT) & + call cio_prints(1,ctemp,len_trim(ctemp)) + idxs = idxs + 1 + + else if (fmtstring(i+1:i+1) == 'l') then + if (idxl == 1 .and. present(l1)) then + la = l1 + else if (idxl == 2 .and. present(l2)) then + la = l2 + else if (idxl == 3 .and. present(l3)) then + la = l3 + else if (idxl == 4 .and. present(l4)) then + la = l4 + else if (idxl == 5 .and. present(l5)) then + la = l5 + else if (idxl == 6 .and. present(l6)) then + la = l6 + end if + + if (la) then + write(ctemp,'(a)') '.TRUE.' + else + write(ctemp,'(a)') '.FALSE.' + end if + if (level >= the_debug_level .and. level /= DEBUG) & + call cio_prints(0,ctemp,len_trim(ctemp)) + if (level /= STDOUT) & + call cio_prints(1,ctemp,len_trim(ctemp)) + idxl = idxl + 1 + + end if + + istart = i+2 + i = index(fmtstring(istart:iend),'%') + end do + + continuing_line = .false. + if (present(newline)) then + if (.not.newline) then + continuing_line = .true. + end if + end if + + if (continuing_line) then + write(ctemp,'(a)') fmtstring(istart:iend) + else + write(ctemp,'(a)') fmtstring(istart:iend)//achar(10) ! Add newline character 0xA + end if + + if (level == LOGFILE) then + continuing_line_logfile = continuing_line + else if (level == DEBUG) then + continuing_line_debug = continuing_line + else if (level == INFORM) then + continuing_line_inform = continuing_line + else if (level == WARN) then + continuing_line_warn = continuing_line + else if (level == ERROR) then + continuing_line_error = continuing_line + else if (level == STDOUT) then + continuing_line_stdout = continuing_line + end if + + if (level >= the_debug_level .and. level /= DEBUG) & + call cio_prints(0,ctemp,iend-istart+2) + if (level /= STDOUT) & + call cio_prints(1,ctemp,iend-istart+2) + + if (level == ERROR) then +#ifdef _GEOGRID + call parallel_abort() +#endif +#ifdef _METGRID + call parallel_abort() +#endif + stop + end if + + end if + + + end subroutine mprintf + +end module module_debug diff --git a/WPS/geogrid/src/module_map_utils.F b/WPS/geogrid/src/module_map_utils.F new file mode 100644 index 00000000..998c73ab --- /dev/null +++ b/WPS/geogrid/src/module_map_utils.F @@ -0,0 +1,2214 @@ +MODULE map_utils + +! Module that defines constants, data structures, and +! subroutines used to convert grid indices to lat/lon +! and vice versa. +! +! SUPPORTED PROJECTIONS +! --------------------- +! Cylindrical Lat/Lon (code = PROJ_LATLON) +! Mercator (code = PROJ_MERC) +! Lambert Conformal (code = PROJ_LC) +! Gaussian (code = PROJ_GAUSS) +! Polar Stereographic (code = PROJ_PS) +! Rotated Lat/Lon (code = PROJ_ROTLL) +! +! REMARKS +! ------- +! The routines contained within were adapted from routines +! obtained from NCEP's w3 library. The original NCEP routines were less +! flexible (e.g., polar-stereo routines only supported truelat of 60N/60S) +! than what we needed, so modifications based on equations in Hoke, Hayes, and +! Renninger (AFGWC/TN/79-003) were added to improve the flexibility. +! Additionally, coding was improved to F90 standards and the routines were +! combined into this module. +! +! ASSUMPTIONS +! ----------- +! Grid Definition: +! For mercator, lambert conformal, and polar-stereographic projections, +! the routines within assume the following: +! +! 1. Grid is dimensioned (i,j) where i is the East-West direction, +! positive toward the east, and j is the north-south direction, +! positive toward the north. +! 2. Origin is at (1,1) and is located at the southwest corner, +! regardless of hemispere. +! 3. Grid spacing (dx) is always positive. +! 4. Values of true latitudes must be positive for NH domains +! and negative for SH domains. +! +! For the latlon and Gaussian projection, the grid origin may be at any +! of the corners, and the deltalat and deltalon values can be signed to +! account for this using the following convention: +! Origin Location Deltalat Sign Deltalon Sign +! --------------- ------------- ------------- +! SW Corner + + +! NE Corner - - +! NW Corner - + +! SE Corner + - +! +! Data Definitions: +! 1. Any arguments that are a latitude value are expressed in +! degrees north with a valid range of -90 -> 90 +! 2. Any arguments that are a longitude value are expressed in +! degrees east with a valid range of -180 -> 180. +! 3. Distances are in meters and are always positive. +! 4. The standard longitude (stdlon) is defined as the longitude +! line which is parallel to the grid's y-axis (j-direction), along +! which latitude increases (NOT the absolute value of latitude, but +! the actual latitude, such that latitude increases continuously +! from the south pole to the north pole) as j increases. +! 5. One true latitude value is required for polar-stereographic and +! mercator projections, and defines at which latitude the +! grid spacing is true. For lambert conformal, two true latitude +! values must be specified, but may be set equal to each other to +! specify a tangent projection instead of a secant projection. +! +! USAGE +! ----- +! To use the routines in this module, the calling routines must have the +! following statement at the beginning of its declaration block: +! USE map_utils +! +! The use of the module not only provides access to the necessary routines, +! but also defines a structure of TYPE (proj_info) that can be used +! to declare a variable of the same type to hold your map projection +! information. It also defines some integer parameters that contain +! the projection codes so one only has to use those variable names rather +! than remembering the acutal code when using them. The basic steps are +! as follows: +! +! 1. Ensure the "USE map_utils" is in your declarations. +! 2. Declare the projection information structure as type(proj_info): +! TYPE(proj_info) :: proj +! 3. Populate your structure by calling the map_set routine: +! CALL map_set(code,lat1,lon1,knowni,knownj,dx,stdlon,truelat1,truelat2,proj) +! where: +! code (input) = one of PROJ_LATLON, PROJ_MERC, PROJ_LC, PROJ_PS, +! PROJ_GAUSS, or PROJ_ROTLL +! lat1 (input) = Latitude of grid origin point (i,j)=(1,1) +! (see assumptions!) +! lon1 (input) = Longitude of grid origin +! knowni (input) = origin point, x-location +! knownj (input) = origin point, y-location +! dx (input) = grid spacing in meters (ignored for LATLON projections) +! stdlon (input) = Standard longitude for PROJ_PS and PROJ_LC, +! deltalon (see assumptions) for PROJ_LATLON, +! ignored for PROJ_MERC +! truelat1 (input) = 1st true latitude for PROJ_PS, PROJ_LC, and +! PROJ_MERC, deltalat (see assumptions) for PROJ_LATLON +! truelat2 (input) = 2nd true latitude for PROJ_LC, +! ignored for all others. +! proj (output) = The structure of type (proj_info) that will be fully +! populated after this call +! +! 4. Now that the proj structure is populated, you may call either +! of the following routines: +! +! latlon_to_ij(proj, lat, lon, i, j) +! ij_to_latlon(proj, i, j, lat, lon) +! +! It is incumbent upon the calling routine to determine whether or +! not the values returned are within your domain's bounds. All values +! of i, j, lat, and lon are REAL values. +! +! +! REFERENCES +! ---------- +! Hoke, Hayes, and Renninger, "Map Preojections and Grid Systems for +! Meteorological Applications." AFGWC/TN-79/003(Rev), Air Weather +! Service, 1985. +! +! NCAR MM5v3 Modeling System, REGRIDDER program, module_first_guess_map.F +! NCEP routines w3fb06, w3fb07, w3fb08, w3fb09, w3fb11, w3fb12 +! +! HISTORY +! ------- +! 27 Mar 2001 - Original Version +! Brent L. Shaw, NOAA/FSL (CSU/CIRA) +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + use constants_module + use misc_definitions_module + use module_debug + + ! Define some private constants + INTEGER, PRIVATE, PARAMETER :: HIGH = 8 + + TYPE proj_info + + INTEGER :: code ! Integer code for projection TYPE + INTEGER :: nlat ! For Gaussian -- number of latitude points + ! north of the equator + INTEGER :: nlon ! + ! + INTEGER :: nxmin ! Starting x-coordinate of periodic, regular lat/lon dataset + INTEGER :: nxmax ! Ending x-coordinate of periodic, regular lat/lon dataset + INTEGER :: ixdim ! For Rotated Lat/Lon -- number of mass points + ! in an odd row + INTEGER :: jydim ! For Rotated Lat/Lon -- number of rows + INTEGER :: stagger ! For Rotated Lat/Lon -- mass or velocity grid + REAL :: phi ! For Rotated Lat/Lon -- domain half-extent in + ! degrees latitude + REAL :: lambda ! For Rotated Lat/Lon -- domain half-extend in + ! degrees longitude + REAL :: lat1 ! SW latitude (1,1) in degrees (-90->90N) + REAL :: lon1 ! SW longitude (1,1) in degrees (-180->180E) + REAL :: lat0 ! For Cassini, latitude of projection pole + REAL :: lon0 ! For Cassini, longitude of projection pole + REAL :: dx ! Grid spacing in meters at truelats, used + ! only for ps, lc, and merc projections + REAL :: dy ! Grid spacing in meters at truelats, used + ! only for ps, lc, and merc projections + REAL :: latinc ! Latitude increment for cylindrical lat/lon + REAL :: loninc ! Longitude increment for cylindrical lat/lon + ! also the lon increment for Gaussian grid + REAL :: dlat ! Lat increment for lat/lon grids + REAL :: dlon ! Lon increment for lat/lon grids + REAL :: stdlon ! Longitude parallel to y-axis (-180->180E) + REAL :: truelat1 ! First true latitude (all projections) + REAL :: truelat2 ! Second true lat (LC only) + REAL :: hemi ! 1 for NH, -1 for SH + REAL :: cone ! Cone factor for LC projections + REAL :: polei ! Computed i-location of pole point + REAL :: polej ! Computed j-location of pole point + REAL :: rsw ! Computed radius to SW corner + REAL :: rebydx ! Earth radius divided by dx + REAL :: knowni ! X-location of known lat/lon + REAL :: knownj ! Y-location of known lat/lon + REAL :: re_m ! Radius of spherical earth, meters + REAL :: rho0 ! For Albers equal area + REAL :: nc ! For Albers equal area + REAL :: bigc ! For Albers equal area + LOGICAL :: init ! Flag to indicate if this struct is + ! ready for use + LOGICAL :: wrap ! For Gaussian -- flag to indicate wrapping + ! around globe? + LOGICAL :: comp_ll ! Work in computational lat/lon space for Cassini + REAL, POINTER, DIMENSION(:) :: gauss_lat ! Latitude array for Gaussian grid + + END TYPE proj_info + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + CONTAINS + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE map_init(proj) + ! Initializes the map projection structure to missing values + + IMPLICIT NONE + TYPE(proj_info), INTENT(INOUT) :: proj + + proj%lat1 = -999.9 + proj%lon1 = -999.9 + proj%lat0 = -999.9 + proj%lon0 = -999.9 + proj%dx = -999.9 + proj%dy = -999.9 + proj%latinc = -999.9 + proj%loninc = -999.9 + proj%stdlon = -999.9 + proj%truelat1 = -999.9 + proj%truelat2 = -999.9 + proj%phi = -999.9 + proj%lambda = -999.9 + proj%ixdim = -999 + proj%jydim = -999 + proj%stagger = HH + proj%nlat = 0 + proj%nlon = 0 + proj%nxmin = 1 + proj%nxmax = 43200 + proj%hemi = 0.0 + proj%cone = -999.9 + proj%polei = -999.9 + proj%polej = -999.9 + proj%rsw = -999.9 + proj%knowni = -999.9 + proj%knownj = -999.9 + proj%re_m = EARTH_RADIUS_M + proj%init = .FALSE. + proj%wrap = .FALSE. + proj%rho0 = 0. + proj%nc = 0. + proj%bigc = 0. + proj%comp_ll = .FALSE. + nullify(proj%gauss_lat) + + END SUBROUTINE map_init + + + SUBROUTINE map_set(proj_code, proj, lat1, lon1, lat0, lon0, knowni, knownj, dx, dy, latinc, & + loninc, stdlon, truelat1, truelat2, nlat, nlon, ixdim, jydim, nxmin, nxmax, & + stagger, phi, lambda, r_earth) + ! Given a partially filled proj_info structure, this routine computes + ! polei, polej, rsw, and cone (if LC projection) to complete the + ! structure. This allows us to eliminate redundant calculations when + ! calling the coordinate conversion routines multiple times for the + ! same map. + ! This will generally be the first routine called when a user wants + ! to be able to use the coordinate conversion routines, and it + ! will call the appropriate subroutines based on the + ! proj%code which indicates which projection type this is. + + IMPLICIT NONE + + ! Declare arguments + INTEGER, INTENT(IN) :: proj_code + INTEGER, INTENT(IN), OPTIONAL :: nlat + INTEGER, INTENT(IN), OPTIONAL :: nlon + INTEGER, INTENT(IN), OPTIONAL :: ixdim + INTEGER, INTENT(IN), OPTIONAL :: jydim + INTEGER, INTENT(IN), OPTIONAL :: nxmin + INTEGER, INTENT(IN), OPTIONAL :: nxmax + INTEGER, INTENT(IN), OPTIONAL :: stagger + REAL, INTENT(IN), OPTIONAL :: latinc + REAL, INTENT(IN), OPTIONAL :: loninc + REAL, INTENT(IN), OPTIONAL :: lat1 + REAL, INTENT(IN), OPTIONAL :: lon1 + REAL, INTENT(IN), OPTIONAL :: lat0 + REAL, INTENT(IN), OPTIONAL :: lon0 + REAL, INTENT(IN), OPTIONAL :: dx + REAL, INTENT(IN), OPTIONAL :: dy + REAL, INTENT(IN), OPTIONAL :: stdlon + REAL, INTENT(IN), OPTIONAL :: truelat1 + REAL, INTENT(IN), OPTIONAL :: truelat2 + REAL, INTENT(IN), OPTIONAL :: knowni + REAL, INTENT(IN), OPTIONAL :: knownj + REAL, INTENT(IN), OPTIONAL :: phi + REAL, INTENT(IN), OPTIONAL :: lambda + REAL, INTENT(IN), OPTIONAL :: r_earth + TYPE(proj_info), INTENT(OUT) :: proj + + INTEGER :: iter + REAL :: dummy_lon1 + REAL :: dummy_lon0 + REAL :: dummy_stdlon + + ! First, verify that mandatory parameters are present for the specified proj_code + IF ( proj_code == PROJ_LC ) THEN + IF ( .NOT.PRESENT(truelat1) .OR. & + .NOT.PRESENT(truelat2) .OR. & + .NOT.PRESENT(lat1) .OR. & + .NOT.PRESENT(lon1) .OR. & + .NOT.PRESENT(knowni) .OR. & + .NOT.PRESENT(knownj) .OR. & + .NOT.PRESENT(stdlon) .OR. & + .NOT.PRESENT(dx) ) THEN + PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code + PRINT '(A)', ' truelat1, truelat2, lat1, lon1, knowni, knownj, stdlon, dx' + call mprintf(.true.,ERROR,'MAP_INIT') + END IF + ELSE IF ( proj_code == PROJ_PS ) THEN + IF ( .NOT.PRESENT(truelat1) .OR. & + .NOT.PRESENT(lat1) .OR. & + .NOT.PRESENT(lon1) .OR. & + .NOT.PRESENT(knowni) .OR. & + .NOT.PRESENT(knownj) .OR. & + .NOT.PRESENT(stdlon) .OR. & + .NOT.PRESENT(dx) ) THEN + PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code + PRINT '(A)', ' truelat1, lat1, lon1, knonwi, knownj, stdlon, dx' + call mprintf(.true.,ERROR,'MAP_INIT') + END IF + ELSE IF ( proj_code == PROJ_PS_WGS84 ) THEN + IF ( .NOT.PRESENT(truelat1) .OR. & + .NOT.PRESENT(lat1) .OR. & + .NOT.PRESENT(lon1) .OR. & + .NOT.PRESENT(knowni) .OR. & + .NOT.PRESENT(knownj) .OR. & + .NOT.PRESENT(stdlon) .OR. & + .NOT.PRESENT(dx) ) THEN + PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code + PRINT '(A)', ' truelat1, lat1, lon1, knonwi, knownj, stdlon, dx' + call mprintf(.true.,ERROR,'MAP_INIT') + END IF + ELSE IF ( proj_code == PROJ_ALBERS_NAD83 ) THEN + IF ( .NOT.PRESENT(truelat1) .OR. & + .NOT.PRESENT(truelat2) .OR. & + .NOT.PRESENT(lat1) .OR. & + .NOT.PRESENT(lon1) .OR. & + .NOT.PRESENT(knowni) .OR. & + .NOT.PRESENT(knownj) .OR. & + .NOT.PRESENT(stdlon) .OR. & + .NOT.PRESENT(dx) ) THEN + PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code + PRINT '(A)', ' truelat1, truelat2, lat1, lon1, knonwi, knownj, stdlon, dx' + call mprintf(.true.,ERROR,'MAP_INIT') + END IF + ELSE IF ( proj_code == PROJ_MERC ) THEN + IF ( .NOT.PRESENT(truelat1) .OR. & + .NOT.PRESENT(lat1) .OR. & + .NOT.PRESENT(lon1) .OR. & + .NOT.PRESENT(knowni) .OR. & + .NOT.PRESENT(knownj) .OR. & + .NOT.PRESENT(dx) ) THEN + PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code + PRINT '(A)', ' truelat1, lat1, lon1, knowni, knownj, dx' + call mprintf(.true.,ERROR,'MAP_INIT') + END IF + ELSE IF ( proj_code == PROJ_LATLON ) THEN + IF ( .NOT.PRESENT(latinc) .OR. & + .NOT.PRESENT(loninc) .OR. & + .NOT.PRESENT(knowni) .OR. & + .NOT.PRESENT(knownj) .OR. & + .NOT.PRESENT(lat1) .OR. & + .NOT.PRESENT(lon1) ) THEN + PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code + PRINT '(A)', ' latinc, loninc, knowni, knownj, lat1, lon1' + call mprintf(.true.,ERROR,'MAP_INIT') + END IF + ELSE IF ( proj_code == PROJ_CYL ) THEN + IF ( .NOT.PRESENT(latinc) .OR. & + .NOT.PRESENT(loninc) .OR. & + .NOT.PRESENT(stdlon) ) THEN + PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code + PRINT '(A)', ' latinc, loninc, stdlon' + call mprintf(.true.,ERROR,'MAP_INIT') + END IF + ELSE IF ( proj_code == PROJ_CASSINI ) THEN + IF ( .NOT.PRESENT(latinc) .OR. & + .NOT.PRESENT(loninc) .OR. & + .NOT.PRESENT(lat1) .OR. & + .NOT.PRESENT(lon1) .OR. & + .NOT.PRESENT(lat0) .OR. & + .NOT.PRESENT(lon0) .OR. & + .NOT.PRESENT(knowni) .OR. & + .NOT.PRESENT(knownj) .OR. & + .NOT.PRESENT(stdlon) ) THEN + PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code + PRINT '(A)', ' latinc, loninc, lat1, lon1, knowni, knownj, lat0, lon0, stdlon' + call mprintf(.true.,ERROR,'MAP_INIT') + END IF + ELSE IF ( proj_code == PROJ_GAUSS ) THEN + IF ( .NOT.PRESENT(nlat) .OR. & + .NOT.PRESENT(lat1) .OR. & + .NOT.PRESENT(lon1) .OR. & + .NOT.PRESENT(loninc) ) THEN + PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code + PRINT '(A)', ' nlat, lat1, lon1, loninc' + call mprintf(.true.,ERROR,'MAP_INIT') + END IF + ELSE IF ( proj_code == PROJ_ROTLL ) THEN + IF ( .NOT.PRESENT(ixdim) .OR. & + .NOT.PRESENT(jydim) .OR. & + .NOT.PRESENT(phi) .OR. & + .NOT.PRESENT(lambda) .OR. & + .NOT.PRESENT(lat1) .OR. & + .NOT.PRESENT(lon1) .OR. & + .NOT.PRESENT(stagger) ) THEN + PRINT '(A,I2)', 'The following are mandatory parameters for projection code : ', proj_code + PRINT '(A)', ' ixdim, jydim, phi, lambda, lat1, lon1, stagger' + call mprintf(.true.,ERROR,'MAP_INIT') + END IF + ELSE + PRINT '(A,I2)', 'Unknown projection code: ', proj_code + call mprintf(.true.,ERROR,'MAP_INIT') + END IF + + ! Check for validity of mandatory variables in proj + IF ( PRESENT(lat1) ) THEN + IF ( ABS(lat1) .GT. 90. ) THEN + PRINT '(A)', 'Latitude of origin corner required as follows:' + PRINT '(A)', ' -90N <= lat1 < = 90.N' + call mprintf(.true.,ERROR,'MAP_INIT') + ENDIF + ENDIF + + IF ( PRESENT(lon1) ) THEN + dummy_lon1 = lon1 + IF ( ABS(dummy_lon1) .GT. 180.) THEN + iter = 0 + DO WHILE (ABS(dummy_lon1) > 180. .AND. iter < 10) + IF (dummy_lon1 < -180.) dummy_lon1 = dummy_lon1 + 360. + IF (dummy_lon1 > 180.) dummy_lon1 = dummy_lon1 - 360. + iter = iter + 1 + END DO + IF (abs(dummy_lon1) > 180.) THEN + PRINT '(A)', 'Longitude of origin required as follows:' + PRINT '(A)', ' -180E <= lon1 <= 180W' + call mprintf(.true.,ERROR,'MAP_INIT') + ENDIF + ENDIF + ENDIF + + IF ( PRESENT(lon0) ) THEN + dummy_lon0 = lon0 + IF ( ABS(dummy_lon0) .GT. 180.) THEN + iter = 0 + DO WHILE (ABS(dummy_lon0) > 180. .AND. iter < 10) + IF (dummy_lon0 < -180.) dummy_lon0 = dummy_lon0 + 360. + IF (dummy_lon0 > 180.) dummy_lon0 = dummy_lon0 - 360. + iter = iter + 1 + END DO + IF (abs(dummy_lon0) > 180.) THEN + PRINT '(A)', 'Longitude of pole required as follows:' + PRINT '(A)', ' -180E <= lon0 <= 180W' + call mprintf(.true.,ERROR,'MAP_INIT') + ENDIF + ENDIF + ENDIF + + IF ( PRESENT(dx) ) THEN + IF ((dx .LE. 0.).AND.(proj_code .NE. PROJ_LATLON)) THEN + PRINT '(A)', 'Require grid spacing (dx) in meters be positive!' + call mprintf(.true.,ERROR,'MAP_INIT') + ENDIF + ENDIF + + IF ( PRESENT(stdlon) ) THEN + dummy_stdlon = stdlon + IF ((ABS(dummy_stdlon) > 180.).AND.(proj_code /= PROJ_MERC)) THEN + iter = 0 + DO WHILE (ABS(dummy_stdlon) > 180. .AND. iter < 10) + IF (dummy_stdlon < -180.) dummy_stdlon = dummy_stdlon + 360. + IF (dummy_stdlon > 180.) dummy_stdlon = dummy_stdlon - 360. + iter = iter + 1 + END DO + IF (abs(dummy_stdlon) > 180.) THEN + PRINT '(A)', 'Need orientation longitude (stdlon) as: ' + PRINT '(A)', ' -180E <= stdlon <= 180W' + call mprintf(.true.,ERROR,'MAP_INIT') + ENDIF + ENDIF + ENDIF + + IF ( PRESENT(truelat1) ) THEN + IF (ABS(truelat1).GT.90.) THEN + PRINT '(A)', 'Set true latitude 1 for all projections!' + call mprintf(.true.,ERROR,'MAP_INIT') + ENDIF + ENDIF + + CALL map_init(proj) + proj%code = proj_code + IF ( PRESENT(lat1) ) proj%lat1 = lat1 + IF ( PRESENT(lon1) ) proj%lon1 = dummy_lon1 + IF ( PRESENT(lat0) ) proj%lat0 = lat0 + IF ( PRESENT(lon0) ) proj%lon0 = dummy_lon0 + IF ( PRESENT(latinc) ) proj%latinc = latinc + IF ( PRESENT(loninc) ) proj%loninc = loninc + IF ( PRESENT(knowni) ) proj%knowni = knowni + IF ( PRESENT(knownj) ) proj%knownj = knownj + IF ( PRESENT(nxmin) ) proj%nxmin = nxmin + IF ( PRESENT(nxmax) ) proj%nxmax = nxmax + IF ( PRESENT(dx) ) proj%dx = dx + IF ( PRESENT(dy) ) THEN + proj%dy = dy + ELSE IF ( PRESENT(dx) ) THEN + proj%dy = dx + END IF + IF ( PRESENT(stdlon) ) proj%stdlon = dummy_stdlon + IF ( PRESENT(truelat1) ) proj%truelat1 = truelat1 + IF ( PRESENT(truelat2) ) proj%truelat2 = truelat2 + IF ( PRESENT(nlat) ) proj%nlat = nlat + IF ( PRESENT(nlon) ) proj%nlon = nlon + IF ( PRESENT(ixdim) ) proj%ixdim = ixdim + IF ( PRESENT(jydim) ) proj%jydim = jydim + IF ( PRESENT(stagger) ) proj%stagger = stagger + IF ( PRESENT(phi) ) proj%phi = phi + IF ( PRESENT(lambda) ) proj%lambda = lambda + IF ( PRESENT(r_earth) ) proj%re_m = r_earth + + IF ( PRESENT(dx) ) THEN + IF ( (proj_code == PROJ_LC) .OR. (proj_code == PROJ_PS) .OR. & + (proj_code == PROJ_PS_WGS84) .OR. (proj_code == PROJ_ALBERS_NAD83) .OR. & + (proj_code == PROJ_MERC) ) THEN + proj%dx = dx + IF (truelat1 .LT. 0.) THEN + proj%hemi = -1.0 + ELSE + proj%hemi = 1.0 + ENDIF + proj%rebydx = proj%re_m / dx + ENDIF + ENDIF + + pick_proj: SELECT CASE(proj%code) + + CASE(PROJ_PS) + CALL set_ps(proj) + + CASE(PROJ_PS_WGS84) + CALL set_ps_wgs84(proj) + + CASE(PROJ_ALBERS_NAD83) + CALL set_albers_nad83(proj) + + CASE(PROJ_LC) + IF (ABS(proj%truelat2) .GT. 90.) THEN + proj%truelat2=proj%truelat1 + ENDIF + CALL set_lc(proj) + + CASE (PROJ_MERC) + CALL set_merc(proj) + + CASE (PROJ_LATLON) + + CASE (PROJ_GAUSS) + CALL set_gauss(proj) + + CASE (PROJ_CYL) + CALL set_cyl(proj) + + CASE (PROJ_CASSINI) + CALL set_cassini(proj) + + CASE (PROJ_ROTLL) + + END SELECT pick_proj + proj%init = .TRUE. + + RETURN + + END SUBROUTINE map_set + + + SUBROUTINE latlon_to_ij(proj, lat, lon, i, j) + ! Converts input lat/lon values to the cartesian (i,j) value + ! for the given projection. + + IMPLICIT NONE + TYPE(proj_info), INTENT(IN) :: proj + REAL, INTENT(IN) :: lat + REAL, INTENT(IN) :: lon + REAL, INTENT(OUT) :: i + REAL, INTENT(OUT) :: j + + IF (.NOT.proj%init) THEN + PRINT '(A)', 'You have not called map_set for this projection!' + call mprintf(.true.,ERROR,'LATLON_TO_IJ') + ENDIF + + SELECT CASE(proj%code) + + CASE(PROJ_LATLON) + CALL llij_latlon(lat,lon,proj,i,j) + + CASE(PROJ_MERC) + CALL llij_merc(lat,lon,proj,i,j) + + CASE(PROJ_PS) + CALL llij_ps(lat,lon,proj,i,j) + + CASE(PROJ_PS_WGS84) + CALL llij_ps_wgs84(lat,lon,proj,i,j) + + CASE(PROJ_ALBERS_NAD83) + CALL llij_albers_nad83(lat,lon,proj,i,j) + + CASE(PROJ_LC) + CALL llij_lc(lat,lon,proj,i,j) + + CASE(PROJ_GAUSS) + CALL llij_gauss(lat,lon,proj,i,j) + + CASE(PROJ_CYL) + CALL llij_cyl(lat,lon,proj,i,j) + + CASE(PROJ_CASSINI) + CALL llij_cassini(lat,lon,proj,i,j) + + CASE(PROJ_ROTLL) + CALL llij_rotlatlon(lat,lon,proj,i,j) + + CASE DEFAULT + PRINT '(A,I2)', 'Unrecognized map projection code: ', proj%code + call mprintf(.true.,ERROR,'LATLON_TO_IJ') + + END SELECT + + RETURN + + END SUBROUTINE latlon_to_ij + + + SUBROUTINE ij_to_latlon(proj, i, j, lat, lon) + ! Computes geographical latitude and longitude for a given (i,j) point + ! in a grid with a projection of proj + + IMPLICIT NONE + TYPE(proj_info),INTENT(IN) :: proj + REAL, INTENT(IN) :: i + REAL, INTENT(IN) :: j + REAL, INTENT(OUT) :: lat + REAL, INTENT(OUT) :: lon + + IF (.NOT.proj%init) THEN + PRINT '(A)', 'You have not called map_set for this projection!' + call mprintf(.true.,ERROR,'IJ_TO_LATLON') + ENDIF + SELECT CASE (proj%code) + + CASE (PROJ_LATLON) + CALL ijll_latlon(i, j, proj, lat, lon) + + CASE (PROJ_MERC) + CALL ijll_merc(i, j, proj, lat, lon) + + CASE (PROJ_PS) + CALL ijll_ps(i, j, proj, lat, lon) + + CASE (PROJ_PS_WGS84) + CALL ijll_ps_wgs84(i, j, proj, lat, lon) + + CASE (PROJ_ALBERS_NAD83) + CALL ijll_albers_nad83(i, j, proj, lat, lon) + + CASE (PROJ_LC) + CALL ijll_lc(i, j, proj, lat, lon) + + CASE (PROJ_CYL) + CALL ijll_cyl(i, j, proj, lat, lon) + + CASE (PROJ_CASSINI) + CALL ijll_cassini(i, j, proj, lat, lon) + + CASE (PROJ_ROTLL) + CALL ijll_rotlatlon(i, j, proj, lat, lon) + + CASE DEFAULT + PRINT '(A,I2)', 'Unrecognized map projection code: ', proj%code + call mprintf(.true.,ERROR,'IJ_TO_LATLON') + + END SELECT + RETURN + END SUBROUTINE ij_to_latlon + + + SUBROUTINE set_ps(proj) + ! Initializes a polar-stereographic map projection from the partially + ! filled proj structure. This routine computes the radius to the + ! southwest corner and computes the i/j location of the pole for use + ! in llij_ps and ijll_ps. + IMPLICIT NONE + + ! Declare args + TYPE(proj_info), INTENT(INOUT) :: proj + + ! Local vars + REAL :: ala1 + REAL :: alo1 + REAL :: reflon + REAL :: scale_top + + ! Executable code + reflon = proj%stdlon + 90. + + ! Compute numerator term of map scale factor + scale_top = 1. + proj%hemi * SIN(proj%truelat1 * rad_per_deg) + + ! Compute radius to lower-left (SW) corner + ala1 = proj%lat1 * rad_per_deg + proj%rsw = proj%rebydx*COS(ala1)*scale_top/(1.+proj%hemi*SIN(ala1)) + + ! Find the pole point + alo1 = (proj%lon1 - reflon) * rad_per_deg + proj%polei = proj%knowni - proj%rsw * COS(alo1) + proj%polej = proj%knownj - proj%hemi * proj%rsw * SIN(alo1) + + RETURN + + END SUBROUTINE set_ps + + + SUBROUTINE llij_ps(lat,lon,proj,i,j) + ! Given latitude (-90 to 90), longitude (-180 to 180), and the + ! standard polar-stereographic projection information via the + ! public proj structure, this routine returns the i/j indices which + ! if within the domain range from 1->nx and 1->ny, respectively. + + IMPLICIT NONE + + ! Delcare input arguments + REAL, INTENT(IN) :: lat + REAL, INTENT(IN) :: lon + TYPE(proj_info),INTENT(IN) :: proj + + ! Declare output arguments + REAL, INTENT(OUT) :: i !(x-index) + REAL, INTENT(OUT) :: j !(y-index) + + ! Declare local variables + + REAL :: reflon + REAL :: scale_top + REAL :: ala + REAL :: alo + REAL :: rm + + ! BEGIN CODE + + reflon = proj%stdlon + 90. + + ! Compute numerator term of map scale factor + + scale_top = 1. + proj%hemi * SIN(proj%truelat1 * rad_per_deg) + + ! Find radius to desired point + ala = lat * rad_per_deg + rm = proj%rebydx * COS(ala) * scale_top/(1. + proj%hemi *SIN(ala)) + alo = (lon - reflon) * rad_per_deg + i = proj%polei + rm * COS(alo) + j = proj%polej + proj%hemi * rm * SIN(alo) + + RETURN + + END SUBROUTINE llij_ps + + + SUBROUTINE ijll_ps(i, j, proj, lat, lon) + + ! This is the inverse subroutine of llij_ps. It returns the + ! latitude and longitude of an i/j point given the projection info + ! structure. + + IMPLICIT NONE + + ! Declare input arguments + REAL, INTENT(IN) :: i ! Column + REAL, INTENT(IN) :: j ! Row + TYPE (proj_info), INTENT(IN) :: proj + + ! Declare output arguments + REAL, INTENT(OUT) :: lat ! -90 -> 90 north + REAL, INTENT(OUT) :: lon ! -180 -> 180 East + + ! Local variables + REAL :: reflon + REAL :: scale_top + REAL :: xx,yy + REAL :: gi2, r2 + REAL :: arccos + + ! Begin Code + + ! Compute the reference longitude by rotating 90 degrees to the east + ! to find the longitude line parallel to the positive x-axis. + reflon = proj%stdlon + 90. + + ! Compute numerator term of map scale factor + scale_top = 1. + proj%hemi * SIN(proj%truelat1 * rad_per_deg) + + ! Compute radius to point of interest + xx = i - proj%polei + yy = (j - proj%polej) * proj%hemi + r2 = xx**2 + yy**2 + + ! Now the magic code + IF (r2 .EQ. 0.) THEN + lat = proj%hemi * 90. + lon = reflon + ELSE + gi2 = (proj%rebydx * scale_top)**2. + lat = deg_per_rad * proj%hemi * ASIN((gi2-r2)/(gi2+r2)) + arccos = ACOS(xx/SQRT(r2)) + IF (yy .GT. 0) THEN + lon = reflon + deg_per_rad * arccos + ELSE + lon = reflon - deg_per_rad * arccos + ENDIF + ENDIF + + ! Convert to a -180 -> 180 East convention + IF (lon .GT. 180.) lon = lon - 360. + IF (lon .LT. -180.) lon = lon + 360. + + RETURN + + END SUBROUTINE ijll_ps + + + SUBROUTINE set_ps_wgs84(proj) + ! Initializes a polar-stereographic map projection (WGS84 ellipsoid) + ! from the partially filled proj structure. This routine computes the + ! radius to the southwest corner and computes the i/j location of the + ! pole for use in llij_ps and ijll_ps. + + IMPLICIT NONE + + ! Arguments + TYPE(proj_info), INTENT(INOUT) :: proj + + ! Local variables + real :: h, mc, tc, t, rho + + h = proj%hemi + + mc = cos(h*proj%truelat1*rad_per_deg)/sqrt(1.0-(E_WGS84*sin(h*proj%truelat1*rad_per_deg))**2.0) + tc = sqrt(((1.0-sin(h*proj%truelat1*rad_per_deg))/(1.0+sin(h*proj%truelat1*rad_per_deg)))* & + (((1.0+E_WGS84*sin(h*proj%truelat1*rad_per_deg))/(1.0-E_WGS84*sin(h*proj%truelat1*rad_per_deg)))**E_WGS84 )) + + ! Find the i/j location of reference lat/lon with respect to the pole of the projection + t = sqrt(((1.0-sin(h*proj%lat1*rad_per_deg))/(1.0+sin(h*proj%lat1*rad_per_deg)))* & + (((1.0+E_WGS84*sin(h*proj%lat1*rad_per_deg))/(1.0-E_WGS84*sin(h*proj%lat1*rad_per_deg)) )**E_WGS84 ) ) + rho = h * (A_WGS84 / proj%dx) * mc * t / tc + proj%polei = rho * sin((h*proj%lon1 - h*proj%stdlon)*rad_per_deg) + proj%polej = -rho * cos((h*proj%lon1 - h*proj%stdlon)*rad_per_deg) + + RETURN + + END SUBROUTINE set_ps_wgs84 + + + SUBROUTINE llij_ps_wgs84(lat,lon,proj,i,j) + ! Given latitude (-90 to 90), longitude (-180 to 180), and the + ! standard polar-stereographic projection information via the + ! public proj structure, this routine returns the i/j indices which + ! if within the domain range from 1->nx and 1->ny, respectively. + + IMPLICIT NONE + + ! Arguments + REAL, INTENT(IN) :: lat + REAL, INTENT(IN) :: lon + REAL, INTENT(OUT) :: i !(x-index) + REAL, INTENT(OUT) :: j !(y-index) + TYPE(proj_info),INTENT(IN) :: proj + + ! Local variables + real :: h, mc, tc, t, rho + + h = proj%hemi + + mc = cos(h*proj%truelat1*rad_per_deg)/sqrt(1.0-(E_WGS84*sin(h*proj%truelat1*rad_per_deg))**2.0) + tc = sqrt(((1.0-sin(h*proj%truelat1*rad_per_deg))/(1.0+sin(h*proj%truelat1*rad_per_deg)))* & + (((1.0+E_WGS84*sin(h*proj%truelat1*rad_per_deg))/(1.0-E_WGS84*sin(h*proj%truelat1*rad_per_deg)))**E_WGS84 )) + + t = sqrt(((1.0-sin(h*lat*rad_per_deg))/(1.0+sin(h*lat*rad_per_deg))) * & + (((1.0+E_WGS84*sin(h*lat*rad_per_deg))/(1.0-E_WGS84*sin(h*lat*rad_per_deg)))**E_WGS84)) + + ! Find the x/y location of the requested lat/lon with respect to the pole of the projection + rho = (A_WGS84 / proj%dx) * mc * t / tc + i = h * rho * sin((h*lon - h*proj%stdlon)*rad_per_deg) + j = h *(-rho)* cos((h*lon - h*proj%stdlon)*rad_per_deg) + + ! Get i/j relative to reference i/j + i = proj%knowni + (i - proj%polei) + j = proj%knownj + (j - proj%polej) + + RETURN + + END SUBROUTINE llij_ps_wgs84 + + + SUBROUTINE ijll_ps_wgs84(i, j, proj, lat, lon) + + ! This is the inverse subroutine of llij_ps. It returns the + ! latitude and longitude of an i/j point given the projection info + ! structure. + + implicit none + + ! Arguments + REAL, INTENT(IN) :: i ! Column + REAL, INTENT(IN) :: j ! Row + REAL, INTENT(OUT) :: lat ! -90 -> 90 north + REAL, INTENT(OUT) :: lon ! -180 -> 180 East + TYPE (proj_info), INTENT(IN) :: proj + + ! Local variables + real :: h, mc, tc, t, rho, x, y + real :: chi, a, b, c, d + + h = proj%hemi + x = (i - proj%knowni + proj%polei) + y = (j - proj%knownj + proj%polej) + + mc = cos(h*proj%truelat1*rad_per_deg)/sqrt(1.0-(E_WGS84*sin(h*proj%truelat1*rad_per_deg))**2.0) + tc = sqrt(((1.0-sin(h*proj%truelat1*rad_per_deg))/(1.0+sin(h*proj%truelat1*rad_per_deg))) * & + (((1.0+E_WGS84*sin(h*proj%truelat1*rad_per_deg))/(1.0-E_WGS84*sin(h*proj%truelat1*rad_per_deg)))**E_WGS84 )) + + rho = sqrt((x*proj%dx)**2.0 + (y*proj%dx)**2.0) + t = rho * tc / (A_WGS84 * mc) + + lon = h*proj%stdlon*rad_per_deg + h*atan2(h*x,h*(-y)) + + chi = PI/2.0-2.0*atan(t) + a = 1./2.*E_WGS84**2. + 5./24.*E_WGS84**4. + 1./40.*E_WGS84**6. + 73./2016.*E_WGS84**8. + b = 7./24.*E_WGS84**4. + 29./120.*E_WGS84**6. + 54113./40320.*E_WGS84**8. + c = 7./30.*E_WGS84**6. + 81./280.*E_WGS84**8. + d = 4279./20160.*E_WGS84**8. + + lat = chi + sin(2.*chi)*(a + cos(2.*chi)*(b + cos(2.*chi)*(c + d*cos(2.*chi)))) + lat = h * lat + + lat = lat*deg_per_rad + lon = lon*deg_per_rad + + RETURN + + END SUBROUTINE ijll_ps_wgs84 + + + SUBROUTINE set_albers_nad83(proj) + ! Initializes an Albers equal area map projection (NAD83 ellipsoid) + ! from the partially filled proj structure. This routine computes the + ! radius to the southwest corner and computes the i/j location of the + ! pole for use in llij_albers_nad83 and ijll_albers_nad83. + + IMPLICIT NONE + + ! Arguments + TYPE(proj_info), INTENT(INOUT) :: proj + + ! Local variables + real :: h, m1, m2, q1, q2, theta, q, sinphi + + h = proj%hemi + + m1 = cos(h*proj%truelat1*rad_per_deg)/sqrt(1.0-(E_NAD83*sin(h*proj%truelat1*rad_per_deg))**2.0) + m2 = cos(h*proj%truelat2*rad_per_deg)/sqrt(1.0-(E_NAD83*sin(h*proj%truelat2*rad_per_deg))**2.0) + + sinphi = sin(proj%truelat1*rad_per_deg) + q1 = (1.0-E_NAD83**2.0) * & + ((sinphi/(1.0-(E_NAD83*sinphi)**2.0)) - 1.0/(2.0*E_NAD83) * log((1.0-E_NAD83*sinphi)/(1.0+E_NAD83*sinphi))) + + sinphi = sin(proj%truelat2*rad_per_deg) + q2 = (1.0-E_NAD83**2.0) * & + ((sinphi/(1.0-(E_NAD83*sinphi)**2.0)) - 1.0/(2.0*E_NAD83) * log((1.0-E_NAD83*sinphi)/(1.0+E_NAD83*sinphi))) + + if (proj%truelat1 == proj%truelat2) then + proj%nc = sin(proj%truelat1*rad_per_deg) + else + proj%nc = (m1**2.0 - m2**2.0) / (q2 - q1) + end if + + proj%bigc = m1**2.0 + proj%nc*q1 + + ! Find the i/j location of reference lat/lon with respect to the pole of the projection + sinphi = sin(proj%lat1*rad_per_deg) + q = (1.0-E_NAD83**2.0) * & + ((sinphi/(1.0-(E_NAD83*sinphi)**2.0)) - 1.0/(2.0*E_NAD83) * log((1.0-E_NAD83*sinphi)/(1.0+E_NAD83*sinphi))) + + proj%rho0 = h * (A_NAD83 / proj%dx) * sqrt(proj%bigc - proj%nc * q) / proj%nc + theta = proj%nc*(proj%lon1 - proj%stdlon)*rad_per_deg + + proj%polei = proj%rho0 * sin(h*theta) + proj%polej = proj%rho0 - proj%rho0 * cos(h*theta) + + RETURN + + END SUBROUTINE set_albers_nad83 + + + SUBROUTINE llij_albers_nad83(lat,lon,proj,i,j) + ! Given latitude (-90 to 90), longitude (-180 to 180), and the + ! standard projection information via the + ! public proj structure, this routine returns the i/j indices which + ! if within the domain range from 1->nx and 1->ny, respectively. + + IMPLICIT NONE + + ! Arguments + REAL, INTENT(IN) :: lat + REAL, INTENT(IN) :: lon + REAL, INTENT(OUT) :: i !(x-index) + REAL, INTENT(OUT) :: j !(y-index) + TYPE(proj_info),INTENT(IN) :: proj + + ! Local variables + real :: h, q, rho, theta, sinphi + + h = proj%hemi + + sinphi = sin(h*lat*rad_per_deg) + + ! Find the x/y location of the requested lat/lon with respect to the pole of the projection + q = (1.0-E_NAD83**2.0) * & + ((sinphi/(1.0-(E_NAD83*sinphi)**2.0)) - 1.0/(2.0*E_NAD83) * log((1.0-E_NAD83*sinphi)/(1.0+E_NAD83*sinphi))) + + rho = h * (A_NAD83 / proj%dx) * sqrt(proj%bigc - proj%nc * q) / proj%nc + theta = proj%nc * (h*lon - h*proj%stdlon)*rad_per_deg + + i = h*rho*sin(theta) + j = h*proj%rho0 - h*rho*cos(theta) + + ! Get i/j relative to reference i/j + i = proj%knowni + (i - proj%polei) + j = proj%knownj + (j - proj%polej) + + RETURN + + END SUBROUTINE llij_albers_nad83 + + + SUBROUTINE ijll_albers_nad83(i, j, proj, lat, lon) + + ! This is the inverse subroutine of llij_albers_nad83. It returns the + ! latitude and longitude of an i/j point given the projection info + ! structure. + + implicit none + + ! Arguments + REAL, INTENT(IN) :: i ! Column + REAL, INTENT(IN) :: j ! Row + REAL, INTENT(OUT) :: lat ! -90 -> 90 north + REAL, INTENT(OUT) :: lon ! -180 -> 180 East + TYPE (proj_info), INTENT(IN) :: proj + + ! Local variables + real :: h, q, rho, theta, beta, x, y + real :: a, b, c + + h = proj%hemi + + x = (i - proj%knowni + proj%polei) + y = (j - proj%knownj + proj%polej) + + rho = sqrt(x**2.0 + (proj%rho0 - y)**2.0) + theta = atan2(x, proj%rho0-y) + + q = (proj%bigc - (rho*proj%nc*proj%dx/A_NAD83)**2.0) / proj%nc + + beta = asin(q/(1.0 - log((1.0-E_NAD83)/(1.0+E_NAD83))*(1.0-E_NAD83**2.0)/(2.0*E_NAD83))) + a = 1./3.*E_NAD83**2. + 31./180.*E_NAD83**4. + 517./5040.*E_NAD83**6. + b = 23./360.*E_NAD83**4. + 251./3780.*E_NAD83**6. + c = 761./45360.*E_NAD83**6. + + lat = beta + a*sin(2.*beta) + b*sin(4.*beta) + c*sin(6.*beta) + + lat = h*lat*deg_per_rad + lon = proj%stdlon + theta*deg_per_rad/proj%nc + + RETURN + + END SUBROUTINE ijll_albers_nad83 + + + SUBROUTINE set_lc(proj) + ! Initialize the remaining items in the proj structure for a + ! lambert conformal grid. + + IMPLICIT NONE + + TYPE(proj_info), INTENT(INOUT) :: proj + + REAL :: arg + REAL :: deltalon1 + REAL :: tl1r + REAL :: ctl1r + + ! Compute cone factor + CALL lc_cone(proj%truelat1, proj%truelat2, proj%cone) + + ! Compute longitude differences and ensure we stay out of the + ! forbidden "cut zone" + deltalon1 = proj%lon1 - proj%stdlon + IF (deltalon1 .GT. +180.) deltalon1 = deltalon1 - 360. + IF (deltalon1 .LT. -180.) deltalon1 = deltalon1 + 360. + + ! Convert truelat1 to radian and compute COS for later use + tl1r = proj%truelat1 * rad_per_deg + ctl1r = COS(tl1r) + + ! Compute the radius to our known lower-left (SW) corner + proj%rsw = proj%rebydx * ctl1r/proj%cone * & + (TAN((90.*proj%hemi-proj%lat1)*rad_per_deg/2.) / & + TAN((90.*proj%hemi-proj%truelat1)*rad_per_deg/2.))**proj%cone + + ! Find pole point + arg = proj%cone*(deltalon1*rad_per_deg) + proj%polei = proj%hemi*proj%knowni - proj%hemi * proj%rsw * SIN(arg) + proj%polej = proj%hemi*proj%knownj + proj%rsw * COS(arg) + + RETURN + + END SUBROUTINE set_lc + + + SUBROUTINE lc_cone(truelat1, truelat2, cone) + + ! Subroutine to compute the cone factor of a Lambert Conformal projection + + IMPLICIT NONE + + ! Input Args + REAL, INTENT(IN) :: truelat1 ! (-90 -> 90 degrees N) + REAL, INTENT(IN) :: truelat2 ! " " " " " + + ! Output Args + REAL, INTENT(OUT) :: cone + + ! Locals + + ! BEGIN CODE + + ! First, see if this is a secant or tangent projection. For tangent + ! projections, truelat1 = truelat2 and the cone is tangent to the + ! Earth's surface at this latitude. For secant projections, the cone + ! intersects the Earth's surface at each of the distinctly different + ! latitudes + IF (ABS(truelat1-truelat2) .GT. 0.1) THEN + cone = ALOG10(COS(truelat1*rad_per_deg)) - & + ALOG10(COS(truelat2*rad_per_deg)) + cone = cone /(ALOG10(TAN((45.0 - ABS(truelat1)/2.0) * rad_per_deg)) - & + ALOG10(TAN((45.0 - ABS(truelat2)/2.0) * rad_per_deg))) + ELSE + cone = SIN(ABS(truelat1)*rad_per_deg ) + ENDIF + + RETURN + + END SUBROUTINE lc_cone + + + SUBROUTINE ijll_lc( i, j, proj, lat, lon) + + ! Subroutine to convert from the (i,j) cartesian coordinate to the + ! geographical latitude and longitude for a Lambert Conformal projection. + + ! History: + ! 25 Jul 01: Corrected by B. Shaw, NOAA/FSL + ! + IMPLICIT NONE + + ! Input Args + REAL, INTENT(IN) :: i ! Cartesian X coordinate + REAL, INTENT(IN) :: j ! Cartesian Y coordinate + TYPE(proj_info),INTENT(IN) :: proj ! Projection info structure + + ! Output Args + REAL, INTENT(OUT) :: lat ! Latitude (-90->90 deg N) + REAL, INTENT(OUT) :: lon ! Longitude (-180->180 E) + + ! Locals + REAL :: inew + REAL :: jnew + REAL :: r + REAL :: chi,chi1,chi2 + REAL :: r2 + REAL :: xx + REAL :: yy + + ! BEGIN CODE + + chi1 = (90. - proj%hemi*proj%truelat1)*rad_per_deg + chi2 = (90. - proj%hemi*proj%truelat2)*rad_per_deg + + ! See if we are in the southern hemispere and flip the indices + ! if we are. + inew = proj%hemi * i + jnew = proj%hemi * j + + ! Compute radius**2 to i/j location + xx = inew - proj%polei + yy = proj%polej - jnew + r2 = (xx*xx + yy*yy) + r = SQRT(r2)/proj%rebydx + + ! Convert to lat/lon + IF (r2 .EQ. 0.) THEN + lat = proj%hemi * 90. + lon = proj%stdlon + ELSE + + ! Longitude + lon = proj%stdlon + deg_per_rad * ATAN2(proj%hemi*xx,yy)/proj%cone + lon = AMOD(lon+360., 360.) + + ! Latitude. Latitude determined by solving an equation adapted + ! from: + ! Maling, D.H., 1973: Coordinate Systems and Map Projections + ! Equations #20 in Appendix I. + + IF (chi1 .EQ. chi2) THEN + chi = 2.0*ATAN( ( r/TAN(chi1) )**(1./proj%cone) * TAN(chi1*0.5) ) + ELSE + chi = 2.0*ATAN( (r*proj%cone/SIN(chi1))**(1./proj%cone) * TAN(chi1*0.5)) + ENDIF + lat = (90.0-chi*deg_per_rad)*proj%hemi + + ENDIF + + IF (lon .GT. +180.) lon = lon - 360. + IF (lon .LT. -180.) lon = lon + 360. + + RETURN + + END SUBROUTINE ijll_lc + + + SUBROUTINE llij_lc( lat, lon, proj, i, j) + + ! Subroutine to compute the geographical latitude and longitude values + ! to the cartesian x/y on a Lambert Conformal projection. + + IMPLICIT NONE + + ! Input Args + REAL, INTENT(IN) :: lat ! Latitude (-90->90 deg N) + REAL, INTENT(IN) :: lon ! Longitude (-180->180 E) + TYPE(proj_info),INTENT(IN) :: proj ! Projection info structure + + ! Output Args + REAL, INTENT(OUT) :: i ! Cartesian X coordinate + REAL, INTENT(OUT) :: j ! Cartesian Y coordinate + + ! Locals + REAL :: arg + REAL :: deltalon + REAL :: tl1r + REAL :: rm + REAL :: ctl1r + + + ! BEGIN CODE + + ! Compute deltalon between known longitude and standard lon and ensure + ! it is not in the cut zone + deltalon = lon - proj%stdlon + IF (deltalon .GT. +180.) deltalon = deltalon - 360. + IF (deltalon .LT. -180.) deltalon = deltalon + 360. + + ! Convert truelat1 to radian and compute COS for later use + tl1r = proj%truelat1 * rad_per_deg + ctl1r = COS(tl1r) + + ! Radius to desired point + rm = proj%rebydx * ctl1r/proj%cone * & + (TAN((90.*proj%hemi-lat)*rad_per_deg/2.) / & + TAN((90.*proj%hemi-proj%truelat1)*rad_per_deg/2.))**proj%cone + + arg = proj%cone*(deltalon*rad_per_deg) + i = proj%polei + proj%hemi * rm * SIN(arg) + j = proj%polej - rm * COS(arg) + + ! Finally, if we are in the southern hemisphere, flip the i/j + ! values to a coordinate system where (1,1) is the SW corner + ! (what we assume) which is different than the original NCEP + ! algorithms which used the NE corner as the origin in the + ! southern hemisphere (left-hand vs. right-hand coordinate?) + i = proj%hemi * i + j = proj%hemi * j + + RETURN + END SUBROUTINE llij_lc + + + SUBROUTINE set_merc(proj) + + ! Sets up the remaining basic elements for the mercator projection + + IMPLICIT NONE + TYPE(proj_info), INTENT(INOUT) :: proj + REAL :: clain + + + ! Preliminary variables + + clain = COS(rad_per_deg*proj%truelat1) + proj%dlon = proj%dx / (proj%re_m * clain) + + ! Compute distance from equator to origin, and store in the + ! proj%rsw tag. + + proj%rsw = 0. + IF (proj%lat1 .NE. 0.) THEN + proj%rsw = (ALOG(TAN(0.5*((proj%lat1+90.)*rad_per_deg))))/proj%dlon + ENDIF + + RETURN + + END SUBROUTINE set_merc + + + SUBROUTINE llij_merc(lat, lon, proj, i, j) + + ! Compute i/j coordinate from lat lon for mercator projection + + IMPLICIT NONE + REAL, INTENT(IN) :: lat + REAL, INTENT(IN) :: lon + TYPE(proj_info),INTENT(IN) :: proj + REAL,INTENT(OUT) :: i + REAL,INTENT(OUT) :: j + REAL :: deltalon + + deltalon = lon - proj%lon1 + IF (deltalon .LT. -180.) deltalon = deltalon + 360. + IF (deltalon .GT. 180.) deltalon = deltalon - 360. + i = proj%knowni + (deltalon/(proj%dlon*deg_per_rad)) + j = proj%knownj + (ALOG(TAN(0.5*((lat + 90.) * rad_per_deg)))) / & + proj%dlon - proj%rsw + + RETURN + + END SUBROUTINE llij_merc + + + SUBROUTINE ijll_merc(i, j, proj, lat, lon) + + ! Compute the lat/lon from i/j for mercator projection + + IMPLICIT NONE + REAL,INTENT(IN) :: i + REAL,INTENT(IN) :: j + TYPE(proj_info),INTENT(IN) :: proj + REAL, INTENT(OUT) :: lat + REAL, INTENT(OUT) :: lon + + + lat = 2.0*ATAN(EXP(proj%dlon*(proj%rsw + j-proj%knownj)))*deg_per_rad - 90. + lon = (i-proj%knowni)*proj%dlon*deg_per_rad + proj%lon1 + IF (lon.GT.180.) lon = lon - 360. + IF (lon.LT.-180.) lon = lon + 360. + RETURN + + END SUBROUTINE ijll_merc + + + SUBROUTINE llij_latlon(lat, lon, proj, i, j) + + ! Compute the i/j location of a lat/lon on a LATLON grid. + IMPLICIT NONE + REAL, INTENT(IN) :: lat + REAL, INTENT(IN) :: lon + TYPE(proj_info), INTENT(IN) :: proj + REAL, INTENT(OUT) :: i + REAL, INTENT(OUT) :: j + + REAL :: deltalat + REAL :: deltalon + + ! Compute deltalat and deltalon as the difference between the input + ! lat/lon and the origin lat/lon + deltalat = lat - proj%lat1 + deltalon = lon - proj%lon1 + + ! Compute i/j + i = deltalon/proj%loninc + j = deltalat/proj%latinc + + i = i + proj%knowni + j = j + proj%knownj + + if ( i < real(proj%nxmin)-0.5 ) i = i + real(proj%nxmax - proj%nxmin + 1) + if ( i >= real(proj%nxmax)+0.5 ) i = i - real(proj%nxmax - proj%nxmin + 1) + + RETURN + + END SUBROUTINE llij_latlon + + + SUBROUTINE ijll_latlon(i, j, proj, lat, lon) + + ! Compute the lat/lon location of an i/j on a LATLON grid. + IMPLICIT NONE + REAL, INTENT(IN) :: i + REAL, INTENT(IN) :: j + TYPE(proj_info), INTENT(IN) :: proj + REAL, INTENT(OUT) :: lat + REAL, INTENT(OUT) :: lon + + REAL :: i_work, j_work + REAL :: deltalat + REAL :: deltalon + + i_work = i + if ( i < real(proj%nxmin)-0.5 ) i_work = i + real(proj%nxmax - proj%nxmin + 1) + if ( i >= real(proj%nxmax)+0.5 ) i_work = i - real(proj%nxmax - proj%nxmin + 1) + + i_work = i_work - proj%knowni + j_work = j - proj%knownj + + ! Compute deltalat and deltalon + deltalat = j_work*proj%latinc + deltalon = i_work*proj%loninc + + lat = proj%lat1 + deltalat + lon = proj%lon1 + deltalon + + RETURN + + END SUBROUTINE ijll_latlon + + + SUBROUTINE set_cyl(proj) + + implicit none + + ! Arguments + type(proj_info), intent(inout) :: proj + + proj%hemi = 1.0 + + END SUBROUTINE set_cyl + + + SUBROUTINE llij_cyl(lat, lon, proj, i, j) + + implicit none + + ! Arguments + real, intent(in) :: lat, lon + real, intent(out) :: i, j + type(proj_info), intent(in) :: proj + + ! Local variables + real :: deltalat + real :: deltalon + + ! Compute deltalat and deltalon as the difference between the input + ! lat/lon and the origin lat/lon + deltalat = lat - proj%lat1 +! deltalon = lon - proj%stdlon + deltalon = lon - proj%lon1 + + if (deltalon < 0.) deltalon = deltalon + 360. + if (deltalon > 360.) deltalon = deltalon - 360. + + ! Compute i/j + i = deltalon/proj%loninc + j = deltalat/proj%latinc + + i = i + proj%knowni + j = j + proj%knownj + + if (i <= 0.) i = i + 360./proj%loninc + if (i > 360./proj%loninc) i = i - 360./proj%loninc + + END SUBROUTINE llij_cyl + + + SUBROUTINE ijll_cyl(i, j, proj, lat, lon) + + implicit none + + ! Arguments + real, intent(in) :: i, j + real, intent(out) :: lat, lon + type(proj_info), intent(in) :: proj + + ! Local variables + real :: deltalat + real :: deltalon + real :: i_work, j_work + + i_work = i - proj%knowni + j_work = j - proj%knownj + + if (i_work < 0.) i_work = i_work + 360./proj%loninc + if (i_work >= 360./proj%loninc) i_work = i_work - 360./proj%loninc + + ! Compute deltalat and deltalon + deltalat = j_work*proj%latinc + deltalon = i_work*proj%loninc + + lat = deltalat + proj%lat1 +! lon = deltalon + proj%stdlon + lon = deltalon + proj%lon1 + + if (lon < -180.) lon = lon + 360. + if (lon > 180.) lon = lon - 360. + + END SUBROUTINE ijll_cyl + + + SUBROUTINE set_cassini(proj) + + implicit none + + ! Arguments + type(proj_info), intent(inout) :: proj + + ! Local variables + real :: comp_lat, comp_lon + logical :: global_domain + + proj%hemi = 1.0 + + ! Try to determine whether this domain has global coverage + if (abs(proj%lat1 - proj%latinc/2. + 90.) < 0.001 .and. & + abs(mod(proj%lon1 - proj%loninc/2. - proj%stdlon,360.)) < 0.001) then + global_domain = .true. + else + global_domain = .false. + end if + + if (abs(proj%lat0) /= 90. .and. .not.global_domain) then + call rotate_coords(proj%lat1,proj%lon1,comp_lat,comp_lon,proj%lat0,proj%lon0,proj%stdlon,-1) + comp_lon = comp_lon + proj%stdlon + proj%lat1 = comp_lat + proj%lon1 = comp_lon + end if + + END SUBROUTINE set_cassini + + + SUBROUTINE llij_cassini(lat, lon, proj, i, j) + + implicit none + + ! Arguments + real, intent(in) :: lat, lon + real, intent(out) :: i, j + type(proj_info), intent(in) :: proj + + ! Local variables + real :: comp_lat, comp_lon + + ! Convert geographic to computational lat/lon + if ( (abs(proj%lat0) /= 90.) .and. (.not. proj%comp_ll) ) then + call rotate_coords(lat,lon,comp_lat,comp_lon,proj%lat0,proj%lon0,proj%stdlon,-1) + comp_lon = comp_lon + proj%stdlon + else + comp_lat = lat + comp_lon = lon + end if + + ! Convert computational lat/lon to i/j + call llij_cyl(comp_lat, comp_lon, proj, i, j) + + END SUBROUTINE llij_cassini + + + SUBROUTINE ijll_cassini(i, j, proj, lat, lon) + + implicit none + + ! Arguments + real, intent(in) :: i, j + real, intent(out) :: lat, lon + type(proj_info), intent(in) :: proj + + ! Local variables + real :: comp_lat, comp_lon + + ! Convert i/j to computational lat/lon + call ijll_cyl(i, j, proj, comp_lat, comp_lon) + + ! Convert computational to geographic lat/lon + if ( (abs(proj%lat0) /= 90.) .and. (.not. proj%comp_ll) ) then + comp_lon = comp_lon - proj%stdlon + call rotate_coords(comp_lat,comp_lon,lat,lon,proj%lat0,proj%lon0,proj%stdlon,1) + else + lat = comp_lat + lon = comp_lon + end if + + END SUBROUTINE ijll_cassini + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Purpose: Converts between computational and geographic lat/lon for Cassini + ! + ! Notes: This routine was provided by Bill Skamarock, 2007-03-27 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE rotate_coords(ilat,ilon,olat,olon,lat_np,lon_np,lon_0,direction) + + IMPLICIT NONE + + REAL, INTENT(IN ) :: ilat, ilon + REAL, INTENT( OUT) :: olat, olon + REAL, INTENT(IN ) :: lat_np, lon_np, lon_0 + INTEGER, INTENT(IN ), OPTIONAL :: direction + ! >=0, default : computational -> geographical + ! < 0 : geographical -> computational + + REAL :: rlat, rlon + REAL :: phi_np, lam_np, lam_0, dlam + REAL :: sinphi, cosphi, coslam, sinlam + + ! Convert all angles to radians + phi_np = lat_np * rad_per_deg + lam_np = lon_np * rad_per_deg + lam_0 = lon_0 * rad_per_deg + rlat = ilat * rad_per_deg + rlon = ilon * rad_per_deg + + IF (PRESENT(direction)) THEN + IF (direction < 0) THEN + ! The equations are exactly the same except for one small difference + ! with respect to longitude ... + dlam = PI - lam_0 + ELSE + dlam = lam_np + END IF + ELSE + dlam = lam_np + END IF + sinphi = COS(phi_np)*COS(rlat)*COS(rlon-dlam) + SIN(phi_np)*SIN(rlat) + cosphi = SQRT(1.-sinphi*sinphi) + coslam = SIN(phi_np)*COS(rlat)*COS(rlon-dlam) - COS(phi_np)*SIN(rlat) + sinlam = COS(rlat)*SIN(rlon-dlam) + IF ( cosphi /= 0. ) THEN + coslam = coslam/cosphi + sinlam = sinlam/cosphi + END IF + olat = deg_per_rad*ASIN(sinphi) + olon = deg_per_rad*(ATAN2(sinlam,coslam)-dlam-lam_0+lam_np) + ! Both of my F90 text books prefer the DO-EXIT form, and claim it is faster + ! when optimization is turned on (as we will always do...) + DO + IF (olon >= -180.) EXIT + olon = olon + 360. + END DO + DO + IF (olon <= 180.) EXIT + olon = olon - 360. + END DO + + END SUBROUTINE rotate_coords + + + SUBROUTINE llij_rotlatlon(lat, lon, proj, i_real, j_real) + + IMPLICIT NONE + + ! Arguments + REAL, INTENT(IN) :: lat, lon + REAL :: i, j + REAL, INTENT(OUT) :: i_real, j_real + TYPE (proj_info), INTENT(IN) :: proj + + ! Local variables + INTEGER :: ii,imt,jj,jmt,k,krows,ncol,nrow,iri + REAL(KIND=HIGH) :: dphd,dlmd !Grid increments, degrees + REAL(KIND=HIGH) :: glatd !Geographic latitude, positive north + REAL(KIND=HIGH) :: glond !Geographic longitude, positive west + REAL(KIND=HIGH) :: col,d1,d2,d2r,dlm,dlm1,dlm2,dph,glat,glon, & + pi,r2d,row,tlat,tlat1,tlat2, & + tlon,tlon1,tlon2,tph0,tlm0,x,y,z + + glatd = lat + glond = -lon + + dphd = proj%phi/REAL((proj%jydim-1)/2) + dlmd = proj%lambda/REAL(proj%ixdim-1) + + pi = ACOS(-1.0) + d2r = pi/180. + r2d = 1./d2r + + imt = 2*proj%ixdim-1 + jmt = proj%jydim/2+1 + + glat = glatd*d2r + glon = glond*d2r + dph = dphd*d2r + dlm = dlmd*d2r + tph0 = proj%lat1*d2r + tlm0 = -proj%lon1*d2r + + x = COS(tph0)*COS(glat)*COS(glon-tlm0)+SIN(tph0)*SIN(glat) + y = -COS(glat)*SIN(glon-tlm0) + z = COS(tph0)*SIN(glat)-SIN(tph0)*COS(glat)*COS(glon-tlm0) + tlat = r2d*ATAN(z/SQRT(x*x+y*y)) + tlon = r2d*ATAN(y/x) + + row = tlat/dphd+jmt + col = tlon/dlmd+proj%ixdim + + if ( (row - INT(row)) .gt. 0.999) then + row = row + 0.0002 + else if ( (col - INT(col)) .gt. 0.999) then + col = col + 0.0002 + end if + + nrow = INT(row) + ncol = INT(col) + +! nrow = NINT(row) +! ncol = NINT(col) + + tlat = tlat*d2r + tlon = tlon*d2r + + IF (proj%stagger == HH) THEN + + IF (mod(nrow,2) .eq. 0) then + i_real = col / 2.0 + ELSE + i_real = col / 2.0 + 0.5 + ENDIF + j_real=row + + + IF ((abs(MOD(nrow,2)) == 1 .AND. abs(MOD(ncol,2)) == 1) .OR. & + (MOD(nrow,2) == 0 .AND. MOD(ncol,2) == 0)) THEN + + tlat1 = (nrow-jmt)*dph + tlat2 = tlat1+dph + tlon1 = (ncol-proj%ixdim)*dlm + tlon2 = tlon1+dlm + + dlm1 = tlon-tlon1 + dlm2 = tlon-tlon2 + d1 = ACOS(COS(tlat)*COS(tlat1)*COS(dlm1)+SIN(tlat)*SIN(tlat1)) + d2 = ACOS(COS(tlat)*COS(tlat2)*COS(dlm2)+SIN(tlat)*SIN(tlat2)) + + IF (d1 > d2) THEN + nrow = nrow+1 + ncol = ncol+1 + END IF + + ELSE + tlat1 = (nrow+1-jmt)*dph + tlat2 = tlat1-dph + tlon1 = (ncol-proj%ixdim)*dlm + tlon2 = tlon1+dlm + dlm1 = tlon-tlon1 + dlm2 = tlon-tlon2 + d1 = ACOS(COS(tlat)*COS(tlat1)*COS(dlm1)+SIN(tlat)*SIN(tlat1)) + d2 = ACOS(COS(tlat)*COS(tlat2)*COS(dlm2)+SIN(tlat)*SIN(tlat2)) + + IF (d1 < d2) THEN + nrow = nrow+1 + ELSE + ncol = ncol+1 + END IF + END IF + + ELSE IF (proj%stagger == VV) THEN + + IF (mod(nrow,2) .eq. 0) then + i_real = col / 2.0 + 0.5 + ELSE + i_real = col / 2.0 + ENDIF + j_real=row + + IF ((MOD(nrow,2) == 0 .AND. abs(MOD(ncol,2)) == 1) .OR. & + (abs(MOD(nrow,2)) == 1 .AND. MOD(ncol,2) == 0)) THEN + tlat1 = (nrow-jmt)*dph + tlat2 = tlat1+dph + tlon1 = (ncol-proj%ixdim)*dlm + tlon2 = tlon1+dlm + dlm1 = tlon-tlon1 + dlm2 = tlon-tlon2 + d1 = ACOS(COS(tlat)*COS(tlat1)*COS(dlm1)+SIN(tlat)*SIN(tlat1)) + d2 = ACOS(COS(tlat)*COS(tlat2)*COS(dlm2)+SIN(tlat)*SIN(tlat2)) + + IF (d1 > d2) THEN + nrow = nrow+1 + ncol = ncol+1 + END IF + + ELSE + tlat1 = (nrow+1-jmt)*dph + tlat2 = tlat1-dph + tlon1 = (ncol-proj%ixdim)*dlm + tlon2 = tlon1+dlm + dlm1 = tlon-tlon1 + dlm2 = tlon-tlon2 + d1 = ACOS(COS(tlat)*COS(tlat1)*COS(dlm1)+SIN(tlat)*SIN(tlat1)) + d2 = ACOS(COS(tlat)*COS(tlat2)*COS(dlm2)+SIN(tlat)*SIN(tlat2)) + + IF (d1 < d2) THEN + nrow = nrow+1 + ELSE + ncol = ncol+1 + END IF + END IF + END IF + + +!!! Added next line as a Kludge - not yet understood why needed + if (ncol .le. 0) ncol=ncol-1 + + jj = nrow + ii = ncol/2 + + IF (proj%stagger == HH) THEN + IF (abs(MOD(jj,2)) == 1) ii = ii+1 + ELSE IF (proj%stagger == VV) THEN + IF (MOD(jj,2) == 0) ii=ii+1 + END IF + + i = REAL(ii) + j = REAL(jj) + + END SUBROUTINE llij_rotlatlon + + + SUBROUTINE ijll_rotlatlon(i, j, proj, lat,lon) + + IMPLICIT NONE + + ! Arguments + REAL, INTENT(IN) :: i, j + REAL, INTENT(OUT) :: lat, lon + TYPE (proj_info), INTENT(IN) :: proj + + ! Local variables + INTEGER :: ih,jh + REAL :: jj + INTEGER :: midcol,midrow,ncol,iadd1,iadd2,imt,jh2,knrow,krem,kv,nrow + REAL :: dphd,dlmd !Grid increments, degrees + REAL(KIND=HIGH) :: arg1,arg2,d2r,fctr,glatr,glatd,glond,pi, & + r2d,tlatd,tlond,tlatr,tlonr,tlm0,tph0 + REAL :: col + + jj = j + if ( (j - INT(j)) .gt. 0.999) then + jj = j + 0.0002 + endif + + jh = INT(jj) + + dphd = proj%phi/REAL((proj%jydim-1)/2) + dlmd = proj%lambda/REAL(proj%ixdim-1) + + pi = ACOS(-1.0) + d2r = pi/180. + r2d = 1./d2r + tph0 = proj%lat1*d2r + tlm0 = -proj%lon1*d2r + + midrow = (proj%jydim+1)/2 + midcol = proj%ixdim + + col = 2*i-1+abs(MOD(jh+1,2)) + tlatd = (jj-midrow)*dphd + tlond = (col-midcol)*dlmd + + IF (proj%stagger == VV) THEN + if (mod(jh,2) .eq. 0) then + tlond = tlond - DLMD + else + tlond = tlond + DLMD + end if + END IF + + tlatr = tlatd*d2r + tlonr = tlond*d2r + arg1 = SIN(tlatr)*COS(tph0)+COS(tlatr)*SIN(tph0)*COS(tlonr) + glatr = ASIN(arg1) + + glatd = glatr*r2d + + arg2 = COS(tlatr)*COS(tlonr)/(COS(glatr)*COS(tph0))-TAN(glatr)*TAN(tph0) + IF (ABS(arg2) > 1.) arg2 = ABS(arg2)/arg2 + fctr = 1. + IF (tlond > 0.) fctr = -1. + + glond = tlm0*r2d+fctr*ACOS(arg2)*r2d + + lat = glatd + lon = -glond + + IF (lon .GT. +180.) lon = lon - 360. + IF (lon .LT. -180.) lon = lon + 360. + + END SUBROUTINE ijll_rotlatlon + + + SUBROUTINE set_gauss(proj) + + IMPLICIT NONE + + ! Argument + type (proj_info), intent(inout) :: proj + + ! Initialize the array that will hold the Gaussian latitudes. + + IF ( ASSOCIATED( proj%gauss_lat ) ) THEN + DEALLOCATE ( proj%gauss_lat ) + END IF + + ! Get the needed space for our array. + + ALLOCATE ( proj%gauss_lat(proj%nlat*2) ) + + ! Compute the Gaussian latitudes. + + CALL gausll( proj%nlat*2 , proj%gauss_lat ) + + ! Now, these could be upside down from what we want, so let's check. + ! We take advantage of the equatorial symmetry to remove any sort of + ! array re-ordering. + + IF ( ABS(proj%gauss_lat(1) - proj%lat1) .GT. 0.01 ) THEN + proj%gauss_lat = -1. * proj%gauss_lat + END IF + + ! Just a sanity check. + + IF ( ABS(proj%gauss_lat(1) - proj%lat1) .GT. 0.01 ) THEN + PRINT '(A)','Oops, something is not right with the Gaussian latitude computation.' + PRINT '(A,F8.3,A)','The input data gave the starting latitude as ',proj%lat1,'.' + PRINT '(A,F8.3,A)','This routine computed the starting latitude as +-',ABS(proj%gauss_lat(1)),'.' + PRINT '(A,F8.3,A)','The difference is larger than 0.01 degrees, which is not expected.' + call mprintf(.true.,ERROR,'Gaussian_latitude_computation') + END IF + + END SUBROUTINE set_gauss + + + SUBROUTINE gausll ( nlat , lat_sp ) + + IMPLICIT NONE + + INTEGER :: nlat , i + REAL (KIND=HIGH) , PARAMETER :: pi = 3.141592653589793 + REAL (KIND=HIGH) , DIMENSION(nlat) :: cosc , gwt , sinc , colat , wos2 , lat + REAL , DIMENSION(nlat) :: lat_sp + + CALL lggaus(nlat, cosc, gwt, sinc, colat, wos2) + + DO i = 1, nlat + lat(i) = ACOS(sinc(i)) * 180._HIGH / pi + IF (i.gt.nlat/2) lat(i) = -lat(i) + END DO + + lat_sp = REAL(lat) + + END SUBROUTINE gausll + + + SUBROUTINE lggaus( nlat, cosc, gwt, sinc, colat, wos2 ) + + IMPLICIT NONE + + ! LGGAUS finds the Gaussian latitudes by finding the roots of the + ! ordinary Legendre polynomial of degree NLAT using Newton's + ! iteration method. + + ! On entry: + integer NLAT ! the number of latitudes (degree of the polynomial) + + ! On exit: for each Gaussian latitude + ! COSC - cos(colatitude) or sin(latitude) + ! GWT - the Gaussian weights + ! SINC - sin(colatitude) or cos(latitude) + ! COLAT - the colatitudes in radians + ! WOS2 - Gaussian weight over sin**2(colatitude) + + REAL (KIND=HIGH) , DIMENSION(nlat) :: cosc , gwt , sinc , colat , wos2 + REAL (KIND=HIGH) , PARAMETER :: pi = 3.141592653589793 + + ! Convergence criterion for iteration of cos latitude + + REAL , PARAMETER :: xlim = 1.0E-14 + + INTEGER :: nzero, i, j + REAL (KIND=HIGH) :: fi, fi1, a, b, g, gm, gp, gt, delta, c, d + + ! The number of zeros between pole and equator + + nzero = nlat/2 + + ! Set first guess for cos(colat) + + DO i=1,nzero + cosc(i) = SIN( (i-0.5)*pi/nlat + pi*0.5 ) + END DO + + ! Constants for determining the derivative of the polynomial + fi = nlat + fi1 = fi+1.0 + a = fi*fi1 / SQRT(4.0*fi1*fi1-1.0) + b = fi1*fi / SQRT(4.0*fi*fi-1.0) + + ! Loop over latitudes, iterating the search for each root + + DO i=1,nzero + j=0 + + ! Determine the value of the ordinary Legendre polynomial for + ! the current guess root + + DO + CALL lgord( g, cosc(i), nlat ) + + ! Determine the derivative of the polynomial at this point + + CALL lgord( gm, cosc(i), nlat-1 ) + CALL lgord( gp, cosc(i), nlat+1 ) + gt = (cosc(i)*cosc(i)-1.0) / (a*gp-b*gm) + + ! Update the estimate of the root + + delta = g*gt + cosc(i) = cosc(i) - delta + + ! If convergence criterion has not been met, keep trying + + j = j+1 + IF( ABS(delta).GT.xlim ) CYCLE + + ! Determine the Gaussian weights + + c = 2.0 *( 1.0-cosc(i)*cosc(i) ) + CALL lgord( d, cosc(i), nlat-1 ) + d = d*d*fi*fi + gwt(i) = c *( fi-0.5 ) / d + EXIT + + END DO + + END DO + + ! Determine the colatitudes and sin(colat) and weights over sin**2 + + DO i=1,nzero + colat(i)= ACOS(cosc(i)) + sinc(i) = SIN(colat(i)) + wos2(i) = gwt(i) /( sinc(i)*sinc(i) ) + END DO + + ! If NLAT is odd, set values at the equator + + IF( MOD(nlat,2) .NE. 0 ) THEN + i = nzero+1 + cosc(i) = 0.0 + c = 2.0 + CALL lgord( d, cosc(i), nlat-1 ) + d = d*d*fi*fi + gwt(i) = c *( fi-0.5 ) / d + colat(i)= pi*0.5 + sinc(i) = 1.0 + wos2(i) = gwt(i) + END IF + + ! Determine the southern hemisphere values by symmetry + + DO i=nlat-nzero+1,nlat + cosc(i) =-cosc(nlat+1-i) + gwt(i) = gwt(nlat+1-i) + colat(i)= pi-colat(nlat+1-i) + sinc(i) = sinc(nlat+1-i) + wos2(i) = wos2(nlat+1-i) + END DO + + END SUBROUTINE lggaus + + + SUBROUTINE lgord( f, cosc, n ) + + IMPLICIT NONE + + ! LGORD calculates the value of an ordinary Legendre polynomial at a + ! specific latitude. + + ! On entry: + ! cosc - COS(colatitude) + ! n - the degree of the polynomial + + ! On exit: + ! f - the value of the Legendre polynomial of degree N at + ! latitude ASIN(cosc) + + REAL (KIND=HIGH) :: s1, c4, a, b, fk, f, cosc, colat, c1, fn, ang + INTEGER :: n, k + + ! Determine the colatitude + + colat = ACOS(cosc) + + c1 = SQRT(2.0_HIGH) + DO k=1,n + c1 = c1 * SQRT( 1.0 - 1.0/(4*k*k) ) + END DO + + fn = n + ang= fn * colat + s1 = 0.0 + c4 = 1.0 + a =-1.0 + b = 0.0 + DO k=0,n,2 + IF (k.eq.n) c4 = 0.5 * c4 + s1 = s1 + c4 * COS(ang) + a = a + 2.0 + b = b + 1.0 + fk = k + ang= colat * (fn-fk-2.0) + c4 = ( a * (fn-b+1.0) / ( b * (fn+fn-a) ) ) * c4 + END DO + + f = s1 * c1 + + END SUBROUTINE lgord + + + SUBROUTINE llij_gauss (lat, lon, proj, i, j) + + IMPLICIT NONE + + REAL , INTENT(IN) :: lat, lon + REAL , INTENT(OUT) :: i, j + TYPE (proj_info), INTENT(IN) :: proj + + INTEGER :: n , n_low + LOGICAL :: found = .FALSE. + REAL :: diff_1 , diff_nlat + + ! The easy one first, get the x location. The calling routine has already made + ! sure that the necessary assumptions concerning the sign of the deltalon and the + ! relative east/west'ness of the longitude and the starting longitude are consistent + ! to allow this easy computation. + + i = ( lon - proj%lon1 ) / proj%loninc + 1. + + ! Since this is a global data set, we need to be concerned about wrapping the + ! fields around the globe. + +! IF ( ( proj%loninc .GT. 0 ) .AND. & +! ( FLOOR((lon-proj%lon1)/proj%loninc) + 1 .GE. proj%ixdim ) .AND. & +! ( lon + proj%loninc .GE. proj%lon1 + 360 ) ) THEN +!! BUG: We may need to set proj%wrap, but proj is intent(in) +!! WHAT IS THIS USED FOR? +!! proj%wrap = .TRUE. +! i = proj%ixdim +! ELSE IF ( ( proj%loninc .LT. 0 ) .AND. & +! ( FLOOR((lon-proj%lon1)/proj%loninc) + 1 .GE. proj%ixdim ) .AND. & +! ( lon + proj%loninc .LE. proj%lon1 - 360 ) ) THEN +! ! BUG: We may need to set proj%wrap, but proj is intent(in) +! ! WHAT IS THIS USED FOR? +! ! proj%wrap = .TRUE. +! i = proj%ixdim +! END IF + + ! Yet another quicky test, can we find bounding values? If not, then we may be + ! dealing with putting data to a polar projection, so just give them them maximal + ! value for the location. This is an OK assumption for the interpolation across the + ! top of the pole, given how close the longitude lines are. + + IF ( ABS(lat) .GT. ABS(proj%gauss_lat(1)) ) THEN + + diff_1 = lat - proj%gauss_lat(1) + diff_nlat = lat - proj%gauss_lat(proj%nlat*2) + + IF ( ABS(diff_1) .LT. ABS(diff_nlat) ) THEN + j = 1 + ELSE + j = proj%nlat*2 + END IF + + ! If the latitude is between the two bounding values, we have to search and interpolate. + + ELSE + + DO n = 1 , proj%nlat*2 -1 + IF ( ( proj%gauss_lat(n) - lat ) * ( proj%gauss_lat(n+1) - lat ) .LE. 0 ) THEN + found = .TRUE. + n_low = n + EXIT + END IF + END DO + + ! Everything still OK? + + IF ( .NOT. found ) THEN + PRINT '(A)','Troubles in river city. No bounding values of latitude found in the Gaussian routines.' + call mprintf(.true.,ERROR,'Gee_no_bounding_lats_Gaussian') + END IF + + j = ( ( proj%gauss_lat(n_low) - lat ) * ( n_low + 1 ) + & + ( lat - proj%gauss_lat(n_low+1) ) * ( n_low ) ) / & + ( proj%gauss_lat(n_low) - proj%gauss_lat(n_low+1) ) + + END IF + + if ( i < real(proj%nxmin)-0.5 ) i = i + real(proj%nxmax - proj%nxmin + 1) + if ( i >= real(proj%nxmax)+0.5 ) i = i - real(proj%nxmax - proj%nxmin + 1) + + END SUBROUTINE llij_gauss + +END MODULE map_utils diff --git a/WPS/geogrid/src/module_stringutil.F b/WPS/geogrid/src/module_stringutil.F new file mode 120000 index 00000000..305c294e --- /dev/null +++ b/WPS/geogrid/src/module_stringutil.F @@ -0,0 +1 @@ +../../ungrib/src/module_stringutil.F \ No newline at end of file diff --git a/WPS/geogrid/src/output_module.F b/WPS/geogrid/src/output_module.F new file mode 100644 index 00000000..5eb0584f --- /dev/null +++ b/WPS/geogrid/src/output_module.F @@ -0,0 +1,1674 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! MODULE OUTPUT_MODULE +! +! This module handles the output of the fields that are generated by the main +! geogrid routines. This output may include output to a console and output to +! the WRF I/O API. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module output_module + + use parallel_module + use gridinfo_module + use misc_definitions_module + use module_debug +#ifdef IO_BINARY + use module_internal_header_util +#endif + + integer, parameter :: MAX_DIMENSIONS = 3 + +#ifdef _GEOGRID + ! Information about fields that will be written + integer :: NUM_AUTOMATIC_FIELDS ! Set later, but very near to a parameter +#endif + + integer :: NUM_FIELDS + + type field_info + integer :: ndims, istagger + integer, dimension(MAX_DIMENSIONS) :: dom_start, mem_start, patch_start + integer, dimension(MAX_DIMENSIONS) :: dom_end, mem_end, patch_end + integer :: sr_x, sr_y + real, pointer, dimension(:,:,:) :: rdata_arr + + character (len=128), dimension(MAX_DIMENSIONS) :: dimnames + character (len=128) :: fieldname, mem_order, stagger, units, descr + end type field_info + + type (field_info), pointer, dimension(:) :: fields + + ! WRF I/O API related variables + integer :: handle + + contains + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: output_init + ! + ! Purpose: To initialize the output module. Such initialization may include + ! opening an X window, and making initialization calls to an I/O API. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine output_init(nest_number, title, datestr, grid_type, dynopt, & + corner_lats, corner_lons, & + start_dom_1, end_dom_1, start_dom_2, end_dom_2, & + start_patch_1, end_patch_1, start_patch_2, end_patch_2, & + start_mem_1, end_mem_1, start_mem_2, end_mem_2, & + extra_col, extra_row) + +#ifdef _GEOGRID + use llxy_module + use source_data_module +#endif + + implicit none + + ! Arguments + integer, intent(in) :: nest_number, dynopt, & + start_dom_1, end_dom_1, start_dom_2, end_dom_2, & + start_patch_1, end_patch_1, start_patch_2, end_patch_2, & + start_mem_1, end_mem_1, start_mem_2, end_mem_2 + real, dimension(16), intent(in) :: corner_lats, corner_lons + logical, intent(in) :: extra_col, extra_row + character (len=1), intent(in) :: grid_type + character (len=19), intent(in) :: datestr + character (len=*), intent(in) :: title + +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" + + ! Local variables + integer :: i, istatus, save_domain, comm_1, comm_2 + integer :: sp1, ep1, sp2, ep2, ep1_stag, ep2_stag + integer :: ngeo_flags + integer :: num_land_cat, min_land_cat, max_land_cat + real :: dx, dy, cen_lat, cen_lon, moad_cen_lat + character (len=128) :: coption, temp_fldname + character (len=128), dimension(1) :: geo_flags + character (len=MAX_FILENAME_LEN) :: output_fname + logical :: supports_training, supports_3d_fields +#ifdef _GEOGRID + character (len=128) :: output_flag +#endif + + call init_output_fields(nest_number, grid_type, & + start_dom_1, end_dom_1, start_dom_2, end_dom_2, & + start_patch_1, end_patch_1, start_patch_2, end_patch_2, & + start_mem_1, end_mem_1, start_mem_2, end_mem_2, & + extra_col, extra_row) + + if (my_proc_id == IO_NODE .or. do_tiled_output) then + istatus = 0 +#ifdef IO_BINARY + if (io_form_output == BINARY) call ext_int_ioinit('sysdep info', istatus) +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) call ext_ncd_ioinit('sysdep info', istatus) +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) call ext_gr1_ioinit('sysdep info', istatus) +#endif + call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioinit') + + ! Find out what this implementation of WRF I/O API supports + istatus = 0 +#ifdef IO_BINARY + if (io_form_output == BINARY) coption = 'REQUIRE' +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) call ext_ncd_inquiry('OPEN_COMMIT_WRITE',coption,istatus) +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) call ext_gr1_inquiry('OPEN_COMMIT_WRITE',coption,istatus) +#endif + call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_inquiry') + + if (index(coption,'ALLOW') /= 0) then + supports_training = .false. + else if (index(coption,'REQUIRE') /= 0) then + supports_training = .true. + else if (index(coption,'NO') /= 0) then + supports_training = .false. + end if + + istatus = 0 +#ifdef IO_BINARY + if (io_form_output == BINARY) coption = 'YES' +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) call ext_ncd_inquiry('SUPPORT_3D_FIELDS',coption,istatus) +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) call ext_gr1_inquiry('SUPPORT_3D_FIELDS',coption,istatus) +#endif + call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_inquiry') + + if (index(coption,'YES') /= 0) then + supports_3d_fields = .true. + else if (index(coption,'NO') /= 0) then + supports_3d_fields = .false. +! BUG: What if we have no plans to write 3-d fields? We should take this into account. + call mprintf(.true.,ERROR,'WRF I/O API implementation does NOT support 3-d fields.') + end if + + comm_1 = 1 + comm_2 = 1 + +#ifdef _GEOGRID + output_fname = ' ' + if (grid_type == 'C') then +#ifdef IO_BINARY + if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d .int' +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d .nc' +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d .grib' +#endif + i = len_trim(opt_output_from_geogrid_path) + write(output_fname(i+9:i+10),'(i2.2)') nest_number + else if (grid_type == 'E') then + if (nest_number == 1) then +#ifdef IO_BINARY + if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d .int' +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d .nc' +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d .grib' +#endif + i = len_trim(opt_output_from_geogrid_path) + write(output_fname(i+10:i+11),'(i2.2)') nest_number + else +#ifdef IO_BINARY + if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l .int' +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l .nc' +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l .grib' +#endif + i = len_trim(opt_output_from_geogrid_path) + write(output_fname(i+15:i+16),'(i2.2)') nest_number-1 + end if + end if + + if (nprocs > 1 .and. do_tiled_output) then + write(output_fname(len_trim(output_fname)+1:len_trim(output_fname)+5), '(a1,i4.4)') & + '_', my_proc_id + end if +#endif + +#ifdef _METGRID + output_fname = ' ' + if (grid_type == 'C') then +#ifdef IO_BINARY + if (io_form_output == BINARY) then + output_fname = trim(opt_output_from_metgrid_path)//'met_em.d .'//trim(datestr)//'.int' + end if +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) then + output_fname = trim(opt_output_from_metgrid_path)//'met_em.d .'//trim(datestr)//'.nc' + end if +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) then + output_fname = trim(opt_output_from_metgrid_path)//'met_em.d .'//trim(datestr)//'.grib' + end if +#endif + i = len_trim(opt_output_from_metgrid_path) + write(output_fname(i+9:i+10),'(i2.2)') nest_number + else if (grid_type == 'E') then +#ifdef IO_BINARY + if (io_form_output == BINARY) then + output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d .'//trim(datestr)//'.int' + end if +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) then + output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d .'//trim(datestr)//'.nc' + end if +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) then + output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d .'//trim(datestr)//'.grib' + end if +#endif + i = len_trim(opt_output_from_metgrid_path) + write(output_fname(i+10:i+11),'(i2.2)') nest_number + end if + + if (nprocs > 1 .and. do_tiled_output) then + write(output_fname(len_trim(output_fname)+1:len_trim(output_fname)+5), '(a1,i4.4)') & + '_', my_proc_id + end if +#endif + end if + + call parallel_bcast_logical(supports_training) + + ! If the implementation requires or supports open_for_write begin/commit semantics + if (supports_training) then + + if (my_proc_id == IO_NODE .or. do_tiled_output) then + istatus = 0 +#ifdef IO_BINARY + if (io_form_output == BINARY) then + call ext_int_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) then + call ext_ncd_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) then + call ext_gr1_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus) + end if +#endif + call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_open_for_write_begin.') + end if + + do i=1,NUM_FIELDS + + allocate(fields(i)%rdata_arr(fields(i)%mem_start(1):fields(i)%mem_end(1), & + fields(i)%mem_start(2):fields(i)%mem_end(2), & + fields(i)%mem_start(3):fields(i)%mem_end(3))) + + call write_field(fields(i)%mem_start(1), fields(i)%mem_end(1), fields(i)%mem_start(2), & + fields(i)%mem_end(2), fields(i)%mem_start(3), fields(i)%mem_end(3), & + trim(fields(i)%fieldname), datestr, fields(i)%rdata_arr, is_training=.true.) + + deallocate(fields(i)%rdata_arr) + + end do + + if (my_proc_id == IO_NODE .or. do_tiled_output) then + istatus = 0 +#ifdef IO_BINARY + if (io_form_output == BINARY) call ext_int_open_for_write_commit(handle, istatus) +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) call ext_ncd_open_for_write_commit(handle, istatus) +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) call ext_gr1_open_for_write_commit(handle, istatus) +#endif + call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_write_commit') + end if + + else ! No training required + + if (my_proc_id == IO_NODE .or. do_tiled_output) then + istatus = 0 +#ifdef IO_BINARY + if (io_form_output == BINARY) then + call ext_int_open_for_write(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) then + call ext_ncd_open_for_write(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) then + call mprintf(.true.,ERROR,'In output_init(), GRIB1 requires begin/commit open sequence.') + end if +#endif + call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_open_for_write_begin') + end if + + end if + +#ifdef _GEOGRID + sp1 = start_patch_1 + ep1 = end_patch_1 + sp2 = start_patch_2 + ep2 = end_patch_2 + + if (grid_type == 'C') then + if (extra_col .or. (my_proc_id == IO_NODE .and. .not. do_tiled_output)) then + ep1_stag = ep1 + 1 + else + ep1_stag = ep1 + end if + if (extra_row .or. (my_proc_id == IO_NODE .and. .not. do_tiled_output)) then + ep2_stag = ep2 + 1 + else + ep2_stag = ep2 + end if + else if (grid_type == 'E') then + ep1 = ep1 + ep2 = ep2 + ep1_stag = ep1 + ep2_stag = ep2 + end if + + if (grid_type == 'C') then + dx = proj_stack(nest_number)%dx + dy = proj_stack(nest_number)%dy + + save_domain = iget_selected_domain() + + ! Note: In the following, we use ixdim/2 rather than (ixdim+1)/2 because + ! the i/j coordinates given to xytoll must be with respect to the + ! mass grid, and ixdim and jydim are the full grid dimensions. + + ! Get MOAD_CEN_LAT + call select_domain(1) + call xytoll(real(ixdim(1))/2.,real(jydim(1))/2., moad_cen_lat, cen_lon, M) + + ! Get CEN_LAT and CEN_LON for this nest + call select_domain(nest_number) + call xytoll(real(ixdim(nest_number))/2.,real(jydim(nest_number))/2., cen_lat, cen_lon, M) + + call select_domain(save_domain) + + ngeo_flags = 1 + geo_flags(1) = 'FLAG_MF_XY' + else if (grid_type == 'E') then + dx = dxkm / 3**(nest_number-1) ! For NMM, nest_number is really nesting level + dy = dykm / 3**(nest_number-1) + moad_cen_lat = 0. + cen_lat=known_lat + cen_lon=known_lon + + ngeo_flags = 0 + end if + + write(temp_fldname,'(a)') 'LANDUSEF' + call get_max_categories(temp_fldname, min_land_cat, max_land_cat, istatus) + num_land_cat = max_land_cat - min_land_cat + 1 + + ! We may now write global attributes to the file + call write_global_attrs(title, datestr, grid_type, dynopt, ixdim(nest_number), jydim(nest_number), & + 0, sp1, ep1, sp1, ep1_stag, sp2, ep2, sp2, ep2_stag, & + iproj_type, source_mminlu, num_land_cat, source_iswater, source_islake, & + source_isice, source_isurban, source_isoilwater, nest_number, & + parent_id(nest_number), & + nint(parent_ll_x(nest_number)), nint(parent_ll_y(nest_number)), & + nint(parent_ur_x(nest_number)), nint(parent_ur_y(nest_number)), & + dx, dy, cen_lat, moad_cen_lat, & + cen_lon, stand_lon, truelat1, truelat2, pole_lat, pole_lon, & + parent_grid_ratio(nest_number), & + subgrid_ratio_x(nest_number), subgrid_ratio_y(nest_number), & + corner_lats, corner_lons, flags=geo_flags, nflags=ngeo_flags) + + do i=1,NUM_FIELDS + call get_output_flag(trim(fields(i)%fieldname), output_flag, istatus) + if (istatus == 0) then + if (my_proc_id == IO_NODE .or. do_tiled_output) then + call ext_put_dom_ti_integer_scalar(trim(output_flag), 1) + end if + end if + end do +#endif + + end subroutine output_init + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: init_output_fields + ! + ! Purpose: To fill in structures describing each of the fields that will be + ! written to the I/O API + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine init_output_fields(nest_num, grid_type, & + start_dom_1, end_dom_1, start_dom_2, end_dom_2, & + start_patch_1, end_patch_1, start_patch_2, end_patch_2, & + start_mem_1, end_mem_1, start_mem_2, end_mem_2, & + extra_col, extra_row) + + + ! Modules +#ifdef _GEOGRID + use source_data_module +#endif +#ifdef _METGRID + use storage_module +#endif + use parallel_module + + implicit none + + ! Arguments + integer, intent(in) :: nest_num + integer, intent(in) :: start_dom_1, end_dom_1, start_dom_2, end_dom_2, & + start_patch_1, end_patch_1, start_patch_2, end_patch_2, & + start_mem_1, end_mem_1, start_mem_2, end_mem_2 + logical, intent(in) :: extra_col, extra_row + character (len=1), intent(in) :: grid_type + +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" + + ! Local variables + integer :: i, istagger, ifieldstatus, & + nfields, min_category, max_category + integer :: lhalo_width, rhalo_width, bhalo_width, thalo_width + integer :: ndims + integer :: optstatus + character (len=128) :: fieldname + character (len=128) :: derived_from + character (len=128) :: memorder, units, description + character (len=128), dimension(3) :: dimnames + integer :: sr_x, sr_y + + ! + ! First find out how many fields there are + ! + call reset_next_field() + + ifieldstatus = 0 + nfields = 0 + optstatus = 0 + do while (ifieldstatus == 0) + + call get_next_output_fieldname(nest_num, fieldname, ndims, & + min_category, max_category, & + istagger, memorder, dimnames, & + units, description, sr_x, sr_y, & + derived_from, ifieldstatus) +#ifdef _GEOGRID + if (len_trim(derived_from) > 0) then + call get_source_opt_status(trim(derived_from), 0, optstatus) + else + call get_source_opt_status(trim(fieldname), 0, optstatus) + end if +#endif + + if (ifieldstatus == 0 .and. optstatus == 0) then + nfields = nfields + 1 + end if + end do + +#ifdef _METGRID + NUM_FIELDS = nfields +#endif + +#ifdef _GEOGRID + if (grid_type == 'C') NUM_AUTOMATIC_FIELDS = 28 + if (grid_type == 'E') NUM_AUTOMATIC_FIELDS = 7 + + NUM_FIELDS = nfields+NUM_AUTOMATIC_FIELDS + allocate(fields(NUM_FIELDS)) + + ! Automatic fields will always be on the non-refined grid + sr_x=1 + sr_y=1 + + ! + ! There are some fields that will always be computed + ! Initialize those fields first, followed by all user-specified fields + ! + if (grid_type == 'C') then + fields(1)%fieldname = 'XLAT_M' + fields(1)%units = 'degrees latitude' + fields(1)%descr = 'Latitude on mass grid' + + fields(2)%fieldname = 'XLONG_M' + fields(2)%units = 'degrees longitude' + fields(2)%descr = 'Longitude on mass grid' + + fields(3)%fieldname = 'XLAT_V' + fields(3)%units = 'degrees latitude' + fields(3)%descr = 'Latitude on V grid' + + fields(4)%fieldname = 'XLONG_V' + fields(4)%units = 'degrees longitude' + fields(4)%descr = 'Longitude on V grid' + + fields(5)%fieldname = 'XLAT_U' + fields(5)%units = 'degrees latitude' + fields(5)%descr = 'Latitude on U grid' + + fields(6)%fieldname = 'XLONG_U' + fields(6)%units = 'degrees longitude' + fields(6)%descr = 'Longitude on U grid' + + fields(7)%fieldname = 'CLAT' + fields(7)%units = 'degrees latitude' + fields(7)%descr = 'Computational latitude on mass grid' + + fields(8)%fieldname = 'CLONG' + fields(8)%units = 'degrees longitude' + fields(8)%descr = 'Computational longitude on mass grid' + + fields(9)%fieldname = 'MAPFAC_M' + fields(9)%units = 'none' + fields(9)%descr = 'Mapfactor on mass grid' + + fields(10)%fieldname = 'MAPFAC_V' + fields(10)%units = 'none' + fields(10)%descr = 'Mapfactor on V grid' + + fields(11)%fieldname = 'MAPFAC_U' + fields(11)%units = 'none' + fields(11)%descr = 'Mapfactor on U grid' + + fields(12)%fieldname = 'MAPFAC_MX' + fields(12)%units = 'none' + fields(12)%descr = 'Mapfactor (x-dir) on mass grid' + + fields(13)%fieldname = 'MAPFAC_VX' + fields(13)%units = 'none' + fields(13)%descr = 'Mapfactor (x-dir) on V grid' + + fields(14)%fieldname = 'MAPFAC_UX' + fields(14)%units = 'none' + fields(14)%descr = 'Mapfactor (x-dir) on U grid' + + fields(15)%fieldname = 'MAPFAC_MY' + fields(15)%units = 'none' + fields(15)%descr = 'Mapfactor (y-dir) on mass grid' + + fields(16)%fieldname = 'MAPFAC_VY' + fields(16)%units = 'none' + fields(16)%descr = 'Mapfactor (y-dir) on V grid' + + fields(17)%fieldname = 'MAPFAC_UY' + fields(17)%units = 'none' + fields(17)%descr = 'Mapfactor (y-dir) on U grid' + + fields(18)%fieldname = 'E' + fields(18)%units = '-' + fields(18)%descr = 'Coriolis E parameter' + + fields(19)%fieldname = 'F' + fields(19)%units = '-' + fields(19)%descr = 'Coriolis F parameter' + + fields(20)%fieldname = 'SINALPHA' + fields(20)%units = 'none' + fields(20)%descr = 'Sine of rotation angle' + + fields(21)%fieldname = 'COSALPHA' + fields(21)%units = 'none' + fields(21)%descr = 'Cosine of rotation angle' + + fields(22)%fieldname = 'LANDMASK' + fields(22)%units = 'none' + fields(22)%descr = 'Landmask : 1=land, 0=water' + + fields(23)%fieldname = 'XLAT_C' + fields(23)%units = 'degrees latitude' + fields(23)%descr = 'Latitude at grid cell corners' + + fields(24)%fieldname = 'XLONG_C' + fields(24)%units = 'degrees longitude' + fields(24)%descr = 'Longitude at grid cell corners' + + fields(25)%fieldname = 'SINALPHA_U' + fields(25)%units = 'none' + fields(25)%descr = 'Sine of rotation angle on U grid' + + fields(26)%fieldname = 'COSALPHA_U' + fields(26)%units = 'none' + fields(26)%descr = 'Cosine of rotation angle on U grid' + + fields(27)%fieldname = 'SINALPHA_V' + fields(27)%units = 'none' + fields(27)%descr = 'Sine of rotation angle on V grid' + + fields(28)%fieldname = 'COSALPHA_V' + fields(28)%units = 'none' + fields(28)%descr = 'Cosine of rotation angle on V grid' + + else if (grid_type == 'E') then + fields(1)%fieldname = 'XLAT_M' + fields(1)%units = 'degrees latitude' + fields(1)%descr = 'Latitude on mass grid' + + fields(2)%fieldname = 'XLONG_M' + fields(2)%units = 'degrees longitude' + fields(2)%descr = 'Longitude on mass grid' + + fields(3)%fieldname = 'XLAT_V' + fields(3)%units = 'degrees latitude' + fields(3)%descr = 'Latitude on velocity grid' + + fields(4)%fieldname = 'XLONG_V' + fields(4)%units = 'degrees longitude' + fields(4)%descr = 'Longitude on velocity grid' + + fields(5)%fieldname = 'E' + fields(5)%units = '-' + fields(5)%descr = 'Coriolis E parameter' + + fields(6)%fieldname = 'F' + fields(6)%units = '-' + fields(6)%descr = 'Coriolis F parameter' + + fields(7)%fieldname = 'LANDMASK' + fields(7)%units = 'none' + fields(7)%descr = 'Landmask : 1=land, 0=water' + + end if + + ! + ! General defaults for "always computed" fields + ! + do i=1,NUM_AUTOMATIC_FIELDS + fields(i)%ndims = 2 + fields(i)%dom_start(1) = start_dom_1 + fields(i)%dom_start(2) = start_dom_2 + fields(i)%dom_start(3) = 1 + fields(i)%mem_start(1) = start_mem_1 + fields(i)%mem_start(2) = start_mem_2 + fields(i)%mem_start(3) = 1 + fields(i)%patch_start(1) = start_patch_1 + fields(i)%patch_start(2) = start_patch_2 + fields(i)%patch_start(3) = 1 + fields(i)%dom_end(1) = end_dom_1 + fields(i)%dom_end(2) = end_dom_2 + fields(i)%dom_end(3) = 1 + fields(i)%mem_end(1) = end_mem_1 + fields(i)%mem_end(2) = end_mem_2 + fields(i)%mem_end(3) = 1 + fields(i)%patch_end(1) = end_patch_1 + fields(i)%patch_end(2) = end_patch_2 + fields(i)%patch_end(3) = 1 + fields(i)%dimnames(3) = ' ' + fields(i)%mem_order = 'XY' + fields(i)%stagger = 'M' + fields(i)%sr_x = 1 + fields(i)%sr_y = 1 + if (grid_type == 'C') then + fields(i)%istagger = M + else if (grid_type == 'E') then + fields(i)%istagger = HH + end if + fields(i)%dimnames(1) = 'west_east' + fields(i)%dimnames(2) = 'south_north' + end do + + ! + ! Perform adjustments to metadata for non-mass-staggered "always computed" fields + ! + if (grid_type == 'C') then + ! Lat V + if (extra_row) then + fields(3)%dom_end(2) = fields(3)%dom_end(2) + 1 + fields(3)%mem_end(2) = fields(3)%mem_end(2) + 1 + fields(3)%patch_end(2) = fields(3)%patch_end(2) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(3)%dom_end(2) = fields(3)%dom_end(2) + 1 + end if + fields(3)%dimnames(2) = 'south_north_stag' + fields(3)%stagger = 'V' + fields(3)%istagger = V + + ! Lon V + if (extra_row) then + fields(4)%dom_end(2) = fields(4)%dom_end(2) + 1 + fields(4)%mem_end(2) = fields(4)%mem_end(2) + 1 + fields(4)%patch_end(2) = fields(4)%patch_end(2) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(4)%dom_end(2) = fields(4)%dom_end(2) + 1 + end if + fields(4)%dimnames(2) = 'south_north_stag' + fields(4)%stagger = 'V' + fields(4)%istagger = V + + ! Lat U + if (extra_col) then + fields(5)%dom_end(1) = fields(5)%dom_end(1) + 1 + fields(5)%mem_end(1) = fields(5)%mem_end(1) + 1 + fields(5)%patch_end(1) = fields(5)%patch_end(1) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(5)%dom_end(1) = fields(5)%dom_end(1) + 1 + end if + fields(5)%dimnames(1) = 'west_east_stag' + fields(5)%stagger = 'U' + fields(5)%istagger = U + + ! Lon U + if (extra_col) then + fields(6)%dom_end(1) = fields(6)%dom_end(1) + 1 + fields(6)%mem_end(1) = fields(6)%mem_end(1) + 1 + fields(6)%patch_end(1) = fields(6)%patch_end(1) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(6)%dom_end(1) = fields(6)%dom_end(1) + 1 + end if + fields(6)%dimnames(1) = 'west_east_stag' + fields(6)%stagger = 'U' + fields(6)%istagger = U + + ! Mapfac V + if (extra_row) then + fields(10)%dom_end(2) = fields(10)%dom_end(2) + 1 + fields(10)%mem_end(2) = fields(10)%mem_end(2) + 1 + fields(10)%patch_end(2) = fields(10)%patch_end(2) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(10)%dom_end(2) = fields(10)%dom_end(2) + 1 + end if + fields(10)%dimnames(2) = 'south_north_stag' + fields(10)%stagger = 'V' + fields(10)%istagger = V + + ! Mapfac U + if (extra_col) then + fields(11)%dom_end(1) = fields(11)%dom_end(1) + 1 + fields(11)%mem_end(1) = fields(11)%mem_end(1) + 1 + fields(11)%patch_end(1) = fields(11)%patch_end(1) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(11)%dom_end(1) = fields(11)%dom_end(1) + 1 + end if + fields(11)%dimnames(1) = 'west_east_stag' + fields(11)%stagger = 'U' + fields(11)%istagger = U + + ! Mapfac V-X + if (extra_row) then + fields(13)%dom_end(2) = fields(13)%dom_end(2) + 1 + fields(13)%mem_end(2) = fields(13)%mem_end(2) + 1 + fields(13)%patch_end(2) = fields(13)%patch_end(2) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(13)%dom_end(2) = fields(13)%dom_end(2) + 1 + end if + fields(13)%dimnames(2) = 'south_north_stag' + fields(13)%stagger = 'V' + fields(13)%istagger = V + + ! Mapfac U-X + if (extra_col) then + fields(14)%dom_end(1) = fields(14)%dom_end(1) + 1 + fields(14)%mem_end(1) = fields(14)%mem_end(1) + 1 + fields(14)%patch_end(1) = fields(14)%patch_end(1) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(14)%dom_end(1) = fields(14)%dom_end(1) + 1 + end if + fields(14)%dimnames(1) = 'west_east_stag' + fields(14)%stagger = 'U' + fields(14)%istagger = U + + ! Mapfac V-Y + if (extra_row) then + fields(16)%dom_end(2) = fields(16)%dom_end(2) + 1 + fields(16)%mem_end(2) = fields(16)%mem_end(2) + 1 + fields(16)%patch_end(2) = fields(16)%patch_end(2) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(16)%dom_end(2) = fields(16)%dom_end(2) + 1 + end if + fields(16)%dimnames(2) = 'south_north_stag' + fields(16)%stagger = 'V' + fields(16)%istagger = V + + ! Mapfac U-Y + if (extra_col) then + fields(17)%dom_end(1) = fields(17)%dom_end(1) + 1 + fields(17)%mem_end(1) = fields(17)%mem_end(1) + 1 + fields(17)%patch_end(1) = fields(17)%patch_end(1) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(17)%dom_end(1) = fields(17)%dom_end(1) + 1 + end if + fields(17)%dimnames(1) = 'west_east_stag' + fields(17)%stagger = 'U' + fields(17)%istagger = U + + ! Lat (unstaggered) + if (extra_row) then + fields(23)%dom_end(2) = fields(23)%dom_end(2) + 1 + fields(23)%mem_end(2) = fields(23)%mem_end(2) + 1 + fields(23)%patch_end(2) = fields(23)%patch_end(2) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(23)%dom_end(2) = fields(23)%dom_end(2) + 1 + end if + if (extra_col) then + fields(23)%dom_end(1) = fields(23)%dom_end(1) + 1 + fields(23)%mem_end(1) = fields(23)%mem_end(1) + 1 + fields(23)%patch_end(1) = fields(23)%patch_end(1) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(23)%dom_end(1) = fields(23)%dom_end(1) + 1 + end if + fields(23)%dimnames(1) = 'west_east_stag' + fields(23)%dimnames(2) = 'south_north_stag' + fields(23)%stagger = 'CORNER' + fields(23)%istagger = CORNER + + ! Lon (unstaggered) + if (extra_row) then + fields(24)%dom_end(2) = fields(24)%dom_end(2) + 1 + fields(24)%mem_end(2) = fields(24)%mem_end(2) + 1 + fields(24)%patch_end(2) = fields(24)%patch_end(2) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(24)%dom_end(2) = fields(24)%dom_end(2) + 1 + end if + if (extra_col) then + fields(24)%dom_end(1) = fields(24)%dom_end(1) + 1 + fields(24)%mem_end(1) = fields(24)%mem_end(1) + 1 + fields(24)%patch_end(1) = fields(24)%patch_end(1) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(24)%dom_end(1) = fields(24)%dom_end(1) + 1 + end if + fields(24)%dimnames(1) = 'west_east_stag' + fields(24)%dimnames(2) = 'south_north_stag' + fields(24)%stagger = 'CORNER' + fields(24)%istagger = CORNER + + ! SINALPHA on U + if (extra_col) then + fields(25)%dom_end(1) = fields(25)%dom_end(1) + 1 + fields(25)%mem_end(1) = fields(25)%mem_end(1) + 1 + fields(25)%patch_end(1) = fields(25)%patch_end(1) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(25)%dom_end(1) = fields(25)%dom_end(1) + 1 + end if + fields(25)%dimnames(1) = 'west_east_stag' + fields(25)%stagger = 'U' + fields(25)%istagger = U + + ! COSALPHA on U + if (extra_col) then + fields(26)%dom_end(1) = fields(26)%dom_end(1) + 1 + fields(26)%mem_end(1) = fields(26)%mem_end(1) + 1 + fields(26)%patch_end(1) = fields(26)%patch_end(1) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(26)%dom_end(1) = fields(26)%dom_end(1) + 1 + end if + fields(26)%dimnames(1) = 'west_east_stag' + fields(26)%stagger = 'U' + fields(26)%istagger = U + + ! SINALPHA on V + if (extra_row) then + fields(27)%dom_end(2) = fields(27)%dom_end(2) + 1 + fields(27)%mem_end(2) = fields(27)%mem_end(2) + 1 + fields(27)%patch_end(2) = fields(27)%patch_end(2) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(27)%dom_end(2) = fields(27)%dom_end(2) + 1 + end if + fields(27)%dimnames(2) = 'south_north_stag' + fields(27)%stagger = 'V' + fields(27)%istagger = V + + ! COSALPHA on V + if (extra_row) then + fields(28)%dom_end(2) = fields(28)%dom_end(2) + 1 + fields(28)%mem_end(2) = fields(28)%mem_end(2) + 1 + fields(28)%patch_end(2) = fields(28)%patch_end(2) + 1 + else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(28)%dom_end(2) = fields(28)%dom_end(2) + 1 + end if + fields(28)%dimnames(2) = 'south_north_stag' + fields(28)%stagger = 'V' + fields(28)%istagger = V + + else if (grid_type == 'E') then + ! Lat V + fields(3)%stagger = 'V' + fields(3)%istagger = VV + + ! Lon V + fields(4)%stagger = 'V' + fields(4)%istagger = VV + + end if +#endif + + ! + ! Now set up the field_info structure for each user-specified field + ! + call reset_next_field() + + ifieldstatus = 0 +#ifdef _GEOGRID + nfields = NUM_AUTOMATIC_FIELDS+1 +#endif +#ifdef _METGRID + allocate(fields(NUM_FIELDS)) + nfields = 1 +#endif + + optstatus = 0 + do while (ifieldstatus == 0) !{ + call get_next_output_fieldname(nest_num, fieldname, ndims, & + min_category, max_category, & + istagger, memorder, dimnames, & + units, description, sr_x, sr_y, & + derived_from, ifieldstatus) +#ifdef _GEOGRID + if (len_trim(derived_from) > 0) then + call get_source_opt_status(trim(derived_from), 0, optstatus) + else + call get_source_opt_status(trim(fieldname), 0, optstatus) + end if +#endif + + + if (ifieldstatus == 0 .and. optstatus == 0) then !{ + + fields(nfields)%ndims = ndims + fields(nfields)%fieldname = fieldname + fields(nfields)%istagger = istagger + if (istagger == M) then + fields(nfields)%stagger = 'M' + else if (istagger == U) then + fields(nfields)%stagger = 'U' + else if (istagger == V) then + fields(nfields)%stagger = 'V' + else if (istagger == HH) then + fields(nfields)%stagger = 'M' + else if (istagger == VV) then + fields(nfields)%stagger = 'V' + else if (istagger == CORNER) then + fields(nfields)%stagger = 'CORNER' + end if + fields(nfields)%mem_order = memorder + fields(nfields)%dimnames(1) = dimnames(1) + fields(nfields)%dimnames(2) = dimnames(2) + fields(nfields)%dimnames(3) = dimnames(3) + fields(nfields)%units = units + fields(nfields)%descr = description + + fields(nfields)%dom_start(1) = start_dom_1 + fields(nfields)%dom_start(2) = start_dom_2 + fields(nfields)%dom_start(3) = min_category + fields(nfields)%mem_start(1) = start_mem_1 + fields(nfields)%mem_start(2) = start_mem_2 + fields(nfields)%mem_start(3) = min_category + fields(nfields)%patch_start(1) = start_patch_1 + fields(nfields)%patch_start(2) = start_patch_2 + fields(nfields)%patch_start(3) = min_category + + fields(nfields)%dom_end(1) = end_dom_1 + fields(nfields)%dom_end(2) = end_dom_2 + fields(nfields)%dom_end(3) = max_category + fields(nfields)%mem_end(1) = end_mem_1 + fields(nfields)%mem_end(2) = end_mem_2 + fields(nfields)%mem_end(3) = max_category + fields(nfields)%patch_end(1) = end_patch_1 + fields(nfields)%patch_end(2) = end_patch_2 + fields(nfields)%patch_end(3) = max_category + + fields(nfields)%sr_x=sr_x + fields(nfields)%sr_y=sr_y + + if (extra_col .and. (istagger == U .or. istagger == CORNER .or. sr_x > 1)) then !{ + fields(nfields)%dom_end(1) = fields(nfields)%dom_end(1) + 1 + fields(nfields)%mem_end(1) = fields(nfields)%mem_end(1) + 1 + fields(nfields)%patch_end(1) = fields(nfields)%patch_end(1) + 1 + else if ((istagger == U .or. istagger == CORNER .or. sr_x > 1) & + .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(nfields)%dom_end(1)=fields(nfields)%dom_end(1) + 1 + end if !} + + if (extra_row .and. (istagger == V .or. istagger == CORNER .or. sr_y > 1)) then !{ + fields(nfields)%dom_end(2) = fields(nfields)%dom_end(2) + 1 + fields(nfields)%mem_end(2) = fields(nfields)%mem_end(2) + 1 + fields(nfields)%patch_end(2) = fields(nfields)%patch_end(2) + 1 + else if ((istagger == V .or. istagger == CORNER .or. sr_y > 1) & + .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then + fields(nfields)%dom_end(2)=fields(nfields)%dom_end(2) + 1 + end if !} + +#ifdef _METGRID + lhalo_width = start_patch_1 - start_mem_1 ! Halo width on left of patch + rhalo_width = end_mem_1 - end_patch_1 ! Halo width on right of patch + bhalo_width = start_patch_2 - start_mem_2 ! Halo width on bottom of patch + thalo_width = end_mem_2 - end_patch_2 ! Halo width on top of patch +#else + lhalo_width = 0 + rhalo_width = 0 + bhalo_width = 0 + thalo_width = 0 +#endif + + if (sr_x > 1) then + fields(nfields)%mem_start(1) = (fields(nfields)%mem_start(1) + lhalo_width - 1)*sr_x + 1 - lhalo_width + fields(nfields)%patch_start(1) = (fields(nfields)%patch_start(1) - 1)*sr_x + 1 + fields(nfields)%dom_start(1) = (fields(nfields)%dom_start(1) - 1)*sr_x + 1 + + fields(nfields)%mem_end(1) = (fields(nfields)%mem_end(1) - rhalo_width)*sr_x + rhalo_width + fields(nfields)%patch_end(1) = (fields(nfields)%patch_end(1) )*sr_x + fields(nfields)%dom_end(1) = (fields(nfields)%dom_end(1) )*sr_x + endif + + if (sr_y > 1) then + fields(nfields)%mem_start(2) = (fields(nfields)%mem_start(2) + bhalo_width - 1)*sr_y + 1 - bhalo_width + fields(nfields)%patch_start(2) = (fields(nfields)%patch_start(2) - 1)*sr_y + 1 + fields(nfields)%dom_start(2) = (fields(nfields)%dom_start(2) - 1)*sr_y + 1 + + fields(nfields)%mem_end(2) = (fields(nfields)%mem_end(2) - thalo_width)*sr_y + thalo_width + fields(nfields)%patch_end(2) = (fields(nfields)%patch_end(2) )*sr_y + fields(nfields)%dom_end(2) = (fields(nfields)%dom_end(2) )*sr_y + endif + + + nfields = nfields + 1 + + end if ! the next field given by get_next_fieldname() is valid } + + end do ! for each user-specified field } + + end subroutine init_output_fields + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: write_field + ! + ! Purpose: This routine writes the provided field to any output devices or APIs + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine write_field(start_mem_i, end_mem_i, & + start_mem_j, end_mem_j, & + start_mem_k, end_mem_k, & + cname, datestr, real_array, is_training) + + implicit none + + ! Arguments + integer, intent(in) :: start_mem_i, end_mem_i, start_mem_j, end_mem_j, start_mem_k, end_mem_k + real, target, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j, start_mem_k:end_mem_k), & + intent(in) :: real_array + logical, intent(in), optional :: is_training + character (len=19), intent(in) :: datestr + character (len=*), intent(in) :: cname + +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" + + ! Local variables + integer :: i + integer :: istatus, comm_1, comm_2, domain_desc + integer, dimension(3) :: sd, ed, sp, ep, sm, em + real, pointer, dimension(:,:,:) :: real_dom_array + logical :: allocated_real_locally + + allocated_real_locally = .false. + + ! If we are running distributed memory and need to gather all tiles onto a single processor for output + if (nprocs > 1 .and. .not. do_tiled_output) then + do i=1,NUM_FIELDS + if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. & + (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then + istatus = 0 + + ! For the gather routines below, the IO_NODE should give the full domain dimensions, but the + ! memory and patch dimensions should indicate what the processor already has in its patch_array. + ! This is because an array with dimensions of the full domain will be allocated, and the patch_array + ! will be copied from local memory into the full domain array in the area specified by the patch + ! dimensions. + sd = fields(i)%dom_start + ed = fields(i)%dom_end + sp = fields(i)%patch_start + ep = fields(i)%patch_end + sm = fields(i)%mem_start + em = fields(i)%mem_end + + allocate(real_dom_array(sd(1):ed(1),sd(2):ed(2),sd(3):ed(3))) + allocated_real_locally = .true. + call gather_whole_field_r(real_array, & + sm(1), em(1), sm(2), em(2), sm(3), em(3), & + sp(1), ep(1), sp(2), ep(2), sp(3), ep(3), & + real_dom_array, & + sd(1), ed(1), sd(2), ed(2), sd(3), ed(3)) + exit + end if + end do + else + do i=1,NUM_FIELDS + if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. & + (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then + istatus = 0 + real_dom_array => real_array + exit + end if + end do + end if + + ! Now a write call is only done if each processor writes its own file, or if we are the IO_NODE + if (my_proc_id == IO_NODE .or. do_tiled_output) then + comm_1 = 1 + comm_2 = 1 + domain_desc = 0 + + do i=1,NUM_FIELDS + if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. & + (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then + + ! Here, the output array has dimensions of the full grid if it was gathered together + ! from all processors + if (my_proc_id == IO_NODE .and. nprocs > 1 .and. .not. do_tiled_output) then + sd = fields(i)%dom_start + ed = fields(i)%dom_end + sm = sd + em = ed + sp = sd + ep = ed + ! If we are writing one file per processor, then each processor only writes out the + ! part of the domain that it has in memory + else +! BUG: Shouldn't we set sd/ed to be domain_start/domain_end? +! Maybe not, since patch is already adjusted for staggering; but maybe so, and also adjust +! for staggering if it is alright to pass true domain dimensions to write_field. + sd = fields(i)%patch_start + ed = fields(i)%patch_end + sp = fields(i)%patch_start + ep = fields(i)%patch_end + sm = fields(i)%mem_start + em = fields(i)%mem_end + end if + + istatus = 0 +#ifdef IO_BINARY + if (io_form_output == BINARY) then + call ext_int_write_field(handle, datestr, trim(fields(i)%fieldname), & + real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), & + trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) then + call ext_ncd_write_field(handle, datestr, trim(fields(i)%fieldname), & + real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), & + trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) then + call ext_gr1_write_field(handle, datestr, trim(fields(i)%fieldname), & + real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), & + trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus) + end if +#endif + call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_write_field') + + if (present(is_training)) then + if (is_training) then +#ifdef IO_BINARY + if (io_form_output == BINARY) then + call ext_int_put_var_ti_char(handle, 'units', & + trim(fields(i)%fieldname), trim(fields(i)%units), istatus) + call ext_int_put_var_ti_char(handle, 'description', & + trim(fields(i)%fieldname), trim(fields(i)%descr), istatus) + call ext_int_put_var_ti_char(handle, 'stagger', & + trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus) + call ext_int_put_var_ti_integer(handle,'sr_x', & + trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus) + call ext_int_put_var_ti_integer(handle,'sr_y', & + trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) then + call ext_ncd_put_var_ti_char(handle, 'units', & + trim(fields(i)%fieldname), trim(fields(i)%units), istatus) + call ext_ncd_put_var_ti_char(handle, 'description', & + trim(fields(i)%fieldname), trim(fields(i)%descr), istatus) + call ext_ncd_put_var_ti_char(handle, 'stagger', & + trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus) + call ext_ncd_put_var_ti_integer(handle,'sr_x', & + trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus) + call ext_ncd_put_var_ti_integer(handle,'sr_y', & + trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) then + call ext_gr1_put_var_ti_char(handle, 'units', & + trim(fields(i)%fieldname), trim(fields(i)%units), istatus) + call ext_gr1_put_var_ti_char(handle, 'description', & + trim(fields(i)%fieldname), trim(fields(i)%descr), istatus) + call ext_gr1_put_var_ti_char(handle, 'stagger', & + trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus) + call ext_gr1_put_var_ti_integer(handle,'sr_x', & + trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus) + call ext_gr1_put_var_ti_integer(handle,'sr_y', & + trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus) + end if +#endif + end if + end if + exit + end if + end do + + end if + + if (allocated_real_locally) deallocate(real_dom_array) + + end subroutine write_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: write_global_attrs + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine write_global_attrs(title, start_date, grid_type, dyn_opt, & + west_east_dim, south_north_dim, bottom_top_dim, & + we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, & + sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, & + map_proj, cmminlu, num_land_cat, is_water, is_lake, is_ice, & + is_urban, i_soilwater, grid_id, parent_id, & + i_parent_start, j_parent_start, i_parent_end, j_parent_end, & + dx, dy, cen_lat, moad_cen_lat, cen_lon, & + stand_lon, truelat1, truelat2, pole_lat, pole_lon, & + parent_grid_ratio, sr_x, sr_y, corner_lats, corner_lons, & + num_metgrid_soil_levs, & + flags, nflags, flag_excluded_middle) + + implicit none + + ! Arguments + integer, intent(in) :: dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, & + we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, & + sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, & + map_proj, is_water, is_lake, is_ice, is_urban, i_soilwater, & + grid_id, parent_id, i_parent_start, j_parent_start, & + i_parent_end, j_parent_end, parent_grid_ratio, sr_x, sr_y, num_land_cat + integer, intent(in), optional :: num_metgrid_soil_levs + integer, intent(in), optional :: nflags + integer, intent(in), optional :: flag_excluded_middle + real, intent(in) :: dx, dy, cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, & + pole_lat, pole_lon + real, dimension(16), intent(in) :: corner_lats, corner_lons + character (len=*), intent(in) :: title, start_date, grid_type + character (len=128), intent(in) :: cmminlu + character (len=128), dimension(:), intent(in), optional :: flags + + ! Local variables + integer :: local_we_patch_s, local_we_patch_s_stag, & + local_we_patch_e, local_we_patch_e_stag, & + local_sn_patch_s, local_sn_patch_s_stag, & + local_sn_patch_e, local_sn_patch_e_stag + integer :: i + real, dimension(16) :: local_corner_lats, local_corner_lons + + local_we_patch_s = we_patch_s + local_we_patch_s_stag = we_patch_s_stag + local_we_patch_e = we_patch_e + local_we_patch_e_stag = we_patch_e_stag + local_sn_patch_s = sn_patch_s + local_sn_patch_s_stag = sn_patch_s_stag + local_sn_patch_e = sn_patch_e + local_sn_patch_e_stag = sn_patch_e_stag + local_corner_lats = corner_lats + local_corner_lons = corner_lons + + if (nprocs > 1) then + + if (.not. do_tiled_output) then + call parallel_bcast_int(local_we_patch_s, processors(0, 0)) + call parallel_bcast_int(local_we_patch_s_stag, processors(0, 0)) + call parallel_bcast_int(local_sn_patch_s, processors(0, 0)) + call parallel_bcast_int(local_sn_patch_s_stag, processors(0, 0)) + + call parallel_bcast_int(local_we_patch_e, processors(nproc_x-1, nproc_y-1)) + call parallel_bcast_int(local_we_patch_e_stag, processors(nproc_x-1, nproc_y-1)) + call parallel_bcast_int(local_sn_patch_e, processors(nproc_x-1, nproc_y-1)) + call parallel_bcast_int(local_sn_patch_e_stag, processors(nproc_x-1, nproc_y-1)) + end if + + call parallel_bcast_real(local_corner_lats(1), processors(0, 0)) + call parallel_bcast_real(local_corner_lats(2), processors(0, nproc_y-1)) + call parallel_bcast_real(local_corner_lats(3), processors(nproc_x-1, nproc_y-1)) + call parallel_bcast_real(local_corner_lats(4), processors(nproc_x-1, 0)) + call parallel_bcast_real(local_corner_lats(5), processors(0, 0)) + call parallel_bcast_real(local_corner_lats(6), processors(0, nproc_y-1)) + call parallel_bcast_real(local_corner_lats(7), processors(nproc_x-1, nproc_y-1)) + call parallel_bcast_real(local_corner_lats(8), processors(nproc_x-1, 0)) + call parallel_bcast_real(local_corner_lats(9), processors(0, 0)) + call parallel_bcast_real(local_corner_lats(10), processors(0, nproc_y-1)) + call parallel_bcast_real(local_corner_lats(11), processors(nproc_x-1, nproc_y-1)) + call parallel_bcast_real(local_corner_lats(12), processors(nproc_x-1, 0)) + call parallel_bcast_real(local_corner_lats(13), processors(0, 0)) + call parallel_bcast_real(local_corner_lats(14), processors(0, nproc_y-1)) + call parallel_bcast_real(local_corner_lats(15), processors(nproc_x-1, nproc_y-1)) + call parallel_bcast_real(local_corner_lats(16), processors(nproc_x-1, 0)) + + call parallel_bcast_real(local_corner_lons(1), processors(0, 0)) + call parallel_bcast_real(local_corner_lons(2), processors(0, nproc_y-1)) + call parallel_bcast_real(local_corner_lons(3), processors(nproc_x-1, nproc_y-1)) + call parallel_bcast_real(local_corner_lons(4), processors(nproc_x-1, 0)) + call parallel_bcast_real(local_corner_lons(5), processors(0, 0)) + call parallel_bcast_real(local_corner_lons(6), processors(0, nproc_y-1)) + call parallel_bcast_real(local_corner_lons(7), processors(nproc_x-1, nproc_y-1)) + call parallel_bcast_real(local_corner_lons(8), processors(nproc_x-1, 0)) + call parallel_bcast_real(local_corner_lons(9), processors(0, 0)) + call parallel_bcast_real(local_corner_lons(10), processors(0, nproc_y-1)) + call parallel_bcast_real(local_corner_lons(11), processors(nproc_x-1, nproc_y-1)) + call parallel_bcast_real(local_corner_lons(12), processors(nproc_x-1, 0)) + call parallel_bcast_real(local_corner_lons(13), processors(0, 0)) + call parallel_bcast_real(local_corner_lons(14), processors(0, nproc_y-1)) + call parallel_bcast_real(local_corner_lons(15), processors(nproc_x-1, nproc_y-1)) + call parallel_bcast_real(local_corner_lons(16), processors(nproc_x-1, 0)) + end if + + if (my_proc_id == IO_NODE .or. do_tiled_output) then + + call ext_put_dom_ti_char ('TITLE', title) + call ext_put_dom_ti_char ('SIMULATION_START_DATE', start_date) + call ext_put_dom_ti_integer_scalar('WEST-EAST_GRID_DIMENSION', west_east_dim) + call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_GRID_DIMENSION', south_north_dim) + call ext_put_dom_ti_integer_scalar('BOTTOM-TOP_GRID_DIMENSION', bottom_top_dim) + call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_UNSTAG', local_we_patch_s) + call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_UNSTAG', local_we_patch_e) + call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_STAG', local_we_patch_s_stag) + call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_STAG', local_we_patch_e_stag) + call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_UNSTAG', local_sn_patch_s) + call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_UNSTAG', local_sn_patch_e) + call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_STAG', local_sn_patch_s_stag) + call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_STAG', local_sn_patch_e_stag) + call ext_put_dom_ti_char ('GRIDTYPE', grid_type) + call ext_put_dom_ti_real_scalar ('DX', dx) + call ext_put_dom_ti_real_scalar ('DY', dy) + call ext_put_dom_ti_integer_scalar('DYN_OPT', dyn_opt) + call ext_put_dom_ti_real_scalar ('CEN_LAT', cen_lat) + call ext_put_dom_ti_real_scalar ('CEN_LON', cen_lon) + call ext_put_dom_ti_real_scalar ('TRUELAT1', truelat1) + call ext_put_dom_ti_real_scalar ('TRUELAT2', truelat2) + call ext_put_dom_ti_real_scalar ('MOAD_CEN_LAT', moad_cen_lat) + call ext_put_dom_ti_real_scalar ('STAND_LON', stand_lon) + call ext_put_dom_ti_real_scalar ('POLE_LAT', pole_lat) + call ext_put_dom_ti_real_scalar ('POLE_LON', pole_lon) + call ext_put_dom_ti_real_vector ('corner_lats', local_corner_lats, 16) + call ext_put_dom_ti_real_vector ('corner_lons', local_corner_lons, 16) + call ext_put_dom_ti_integer_scalar('MAP_PROJ', map_proj) + call ext_put_dom_ti_char ('MMINLU', trim(cmminlu)) + call ext_put_dom_ti_integer_scalar('NUM_LAND_CAT', num_land_cat) + call ext_put_dom_ti_integer_scalar('ISWATER', is_water) + call ext_put_dom_ti_integer_scalar('ISLAKE', is_lake) + call ext_put_dom_ti_integer_scalar('ISICE', is_ice) + call ext_put_dom_ti_integer_scalar('ISURBAN', is_urban) + call ext_put_dom_ti_integer_scalar('ISOILWATER', i_soilwater) + call ext_put_dom_ti_integer_scalar('grid_id', grid_id) + call ext_put_dom_ti_integer_scalar('parent_id', parent_id) + call ext_put_dom_ti_integer_scalar('i_parent_start', i_parent_start) + call ext_put_dom_ti_integer_scalar('j_parent_start', j_parent_start) + call ext_put_dom_ti_integer_scalar('i_parent_end', i_parent_end) + call ext_put_dom_ti_integer_scalar('j_parent_end', j_parent_end) + call ext_put_dom_ti_integer_scalar('parent_grid_ratio', parent_grid_ratio) + call ext_put_dom_ti_integer_scalar('sr_x',sr_x) + call ext_put_dom_ti_integer_scalar('sr_y',sr_y) +#ifdef _METGRID + if (present(num_metgrid_soil_levs)) then + call ext_put_dom_ti_integer_scalar('NUM_METGRID_SOIL_LEVELS', num_metgrid_soil_levs) + end if + call ext_put_dom_ti_integer_scalar('FLAG_METGRID', 1) + if (present(flag_excluded_middle)) then + call ext_put_dom_ti_integer_scalar('FLAG_EXCLUDED_MIDDLE', flag_excluded_middle) + end if +#endif + + if (present(nflags) .and. present(flags)) then + do i=1,nflags + if (flags(i) /= ' ') then + call ext_put_dom_ti_integer_scalar(trim(flags(i)), 1) + end if + end do + end if + + end if + + end subroutine write_global_attrs + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: ext_put_dom_ti_integer + ! + ! Purpose: Write a domain time-independent integer attribute to output. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ext_put_dom_ti_integer_scalar(var_name, var_value) + + implicit none + + ! Arguments + integer, intent(in) :: var_value + character (len=*), intent(in) :: var_name + + ! Local variables + integer :: istatus + +#ifdef IO_BINARY + if (io_form_output == BINARY) then + call ext_int_put_dom_ti_integer(handle, trim(var_name), & + var_value, & + 1, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) then + call ext_ncd_put_dom_ti_integer(handle, trim(var_name), & + var_value, & + 1, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) then + call ext_gr1_put_dom_ti_integer(handle, trim(var_name), & + var_value, & + 1, istatus) + end if +#endif + + call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute') + + end subroutine ext_put_dom_ti_integer_scalar + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: ext_put_dom_ti_integer + ! + ! Purpose: Write a domain time-independent integer attribute to output. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ext_put_dom_ti_integer_vector(var_name, var_value, n) + + implicit none + + ! Arguments + integer, intent(in) :: n + integer, dimension(n), intent(in) :: var_value + character (len=*), intent(in) :: var_name + + ! Local variables + integer :: istatus + +#ifdef IO_BINARY + if (io_form_output == BINARY) then + call ext_int_put_dom_ti_integer(handle, trim(var_name), & + var_value, & + n, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) then + call ext_ncd_put_dom_ti_integer(handle, trim(var_name), & + var_value, & + n, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) then + call ext_gr1_put_dom_ti_integer(handle, trim(var_name), & + var_value, & + n, istatus) + end if +#endif + + call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute') + + end subroutine ext_put_dom_ti_integer_vector + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: ext_put_dom_ti_real + ! + ! Purpose: Write a domain time-independent real attribute to output. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ext_put_dom_ti_real_scalar(var_name, var_value) + + implicit none + + ! Arguments + real, intent(in) :: var_value + character (len=*), intent(in) :: var_name + + ! Local variables + integer :: istatus + +#ifdef IO_BINARY + if (io_form_output == BINARY) then + call ext_int_put_dom_ti_real(handle, trim(var_name), & + var_value, & + 1, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) then + call ext_ncd_put_dom_ti_real(handle, trim(var_name), & + var_value, & + 1, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) then + call ext_gr1_put_dom_ti_real(handle, trim(var_name), & + var_value, & + 1, istatus) + end if +#endif + + call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute') + + end subroutine ext_put_dom_ti_real_scalar + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: ext_put_dom_ti_real + ! + ! Purpose: Write a domain time-independent real attribute to output. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ext_put_dom_ti_real_vector(var_name, var_value, n) + + implicit none + + ! Arguments + integer, intent(in) :: n + real, dimension(n), intent(in) :: var_value + character (len=*), intent(in) :: var_name + + ! Local variables + integer :: istatus + +#ifdef IO_BINARY + if (io_form_output == BINARY) then + call ext_int_put_dom_ti_real(handle, trim(var_name), & + var_value, & + n, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) then + call ext_ncd_put_dom_ti_real(handle, trim(var_name), & + var_value, & + n, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) then + call ext_gr1_put_dom_ti_real(handle, trim(var_name), & + var_value, & + n, istatus) + end if +#endif + + call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute') + + end subroutine ext_put_dom_ti_real_vector + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: ext_put_dom_ti_char + ! + ! Purpose: Write a domain time-independent character attribute to output. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ext_put_dom_ti_char(var_name, var_value) + + implicit none + + ! Arguments + character (len=*), intent(in) :: var_name, var_value + + ! Local variables + integer :: istatus + +#ifdef IO_BINARY + if (io_form_output == BINARY) then + call ext_int_put_dom_ti_char(handle, trim(var_name), & + trim(var_value), & + istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) then + call ext_ncd_put_dom_ti_char(handle, trim(var_name), & + trim(var_value), & + istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) then + call ext_gr1_put_dom_ti_char(handle, trim(var_name), & + trim(var_value), & + istatus) + end if +#endif + + call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute') + + end subroutine ext_put_dom_ti_char + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: output_close + ! + ! Purpose: Finalizes all output. This may include closing windows, calling I/O + ! API termination routines, or closing files. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine output_close() + + implicit none + + ! Local variables + integer :: istatus + + if (my_proc_id == IO_NODE .or. do_tiled_output) then + + istatus = 0 +#ifdef IO_BINARY + if (io_form_output == BINARY) call ext_int_ioclose(handle, istatus) +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) call ext_ncd_ioclose(handle, istatus) +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) call ext_gr1_ioclose(handle, istatus) +#endif + call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioclose') + + istatus = 0 +#ifdef IO_BINARY + if (io_form_output == BINARY) call ext_int_ioexit(istatus) +#endif +#ifdef IO_NETCDF + if (io_form_output == NETCDF) call ext_ncd_ioexit(istatus) +#endif +#ifdef IO_GRIB1 + if (io_form_output == GRIB1) call ext_gr1_ioexit(istatus) +#endif + call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioexit') + + end if + + if (associated(fields)) deallocate(fields) + + end subroutine output_close + +end module output_module diff --git a/WPS/geogrid/src/parallel_module.F b/WPS/geogrid/src/parallel_module.F new file mode 100644 index 00000000..dc7c5b89 --- /dev/null +++ b/WPS/geogrid/src/parallel_module.F @@ -0,0 +1,1045 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! MODULE PARALLEL_MODULE +! +! This module provides routines for parallelizing. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module parallel_module + +#ifdef _MPI +include 'mpif.h' +#endif + + integer, parameter :: IO_NODE = 0 + + integer, parameter :: HALO_WIDTH = 3 + + integer, pointer, dimension(:,:) :: processors, & + proc_minx, proc_maxx, & + proc_miny, proc_maxy + integer :: nprocs, & + my_proc_id, & + nproc_x, nproc_y, & + my_x, my_y, & + my_minx, my_miny, my_maxx, my_maxy, & + comm + + + contains + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: parallel_start + ! + ! Purpose: For MPI, the purpose of this routine is to basically set up + ! a communicator for a rectangular mesh, and determine how many processors + ! in the x and y directions there will be. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine parallel_start() + + implicit none + + ! Arguments + + ! Local variables +#ifdef _MPI + integer :: mpi_rank, mpi_size + integer :: mpi_ierr + integer, dimension(2) :: dims, coords + integer :: rectangle, myleft, myright, mytop, mybottom + integer :: mini, m, n + logical, dimension(2) :: periods + + ! Find out our rank and the total number of processors + call MPI_Init(mpi_ierr) + call MPI_Comm_rank(MPI_COMM_WORLD, mpi_rank, mpi_ierr) + call MPI_Comm_size(MPI_COMM_WORLD, mpi_size, mpi_ierr) + + comm = MPI_COMM_WORLD + + nprocs = mpi_size + my_proc_id = mpi_rank + + ! Code from RSL to get number of procs in m and n directions + mini = 2*nprocs + nproc_x = 1 + nproc_y = nprocs + do m = 1, nprocs + if ( mod( nprocs, m ) == 0 ) then + n = nprocs / m + if ( abs(m-n) < mini ) then + mini = abs(m-n) + nproc_x = m + nproc_y = n + end if + end if + end do + + ! Calculate which patch current processor will work on + my_x = mod(mpi_rank,nproc_x) + my_y = mpi_rank / nproc_x + +#else + comm = 0 + my_proc_id = IO_NODE + nprocs = 1 + my_x = 0 + my_y = 0 + nproc_x = 1 + nproc_y = 1 +#endif + + nullify(processors) + nullify(proc_minx) + nullify(proc_maxx) + nullify(proc_miny) + nullify(proc_maxy) + + end subroutine parallel_start + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: parallel_get_tile_dims + ! + ! Purpose: To compute the starting and ending indices of the patch that the + ! calling processor is to work on. When there are multiple processors, + ! appropriate data structures describing the range of indices being + ! worked on by other processors are also allocated and filled + ! (processors, proc_minx, proc_maxx, proc_miny, proc_maxy). + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine parallel_get_tile_dims(idim, jdim) + + implicit none + + ! Arguments + integer, intent(in) :: idim, jdim + + ! Local variables +#ifdef _MPI + integer :: i, j, ix, iy, px, py + integer, dimension(2) :: buffer + integer :: mpi_ierr + integer, dimension(MPI_STATUS_SIZE) :: mpi_stat + + ! + ! Determine starting and ending grid points in x and y direction that we will work on + ! + ! NOTE: + ! For now, copy code from RSL_LITE's module_dm.F until build mechanism to link + ! WRF and WPS code is worked out more. + ! Eventually, it would probably be best to use module_dm code without copying + ! + my_minx = -1 + j = 1 + do i = 1, idim + call task_for_point(i, j, 1, idim, 1, jdim, nproc_x, nproc_y, px, py) + if ( px == my_x ) then + my_maxx = i + if ( my_minx == -1 ) my_minx = i + end if + end do + + my_miny = -1 + i = 1 + do j = 1, jdim + call task_for_point(i, j, 1, idim, 1, jdim, nproc_x, nproc_y, px, py) + if ( py == my_y ) then + my_maxy = j + if ( my_miny == -1 ) my_miny = j + end if + end do + + ! Create space to hold information about which other processors are + ! working on which parts of the domain + allocate(processors(0:nproc_x-1, 0:nproc_y-1)) + allocate(proc_minx(0:nproc_x-1, 0:nproc_y-1)) + allocate(proc_miny(0:nproc_x-1, 0:nproc_y-1)) + allocate(proc_maxx(0:nproc_x-1, 0:nproc_y-1)) + allocate(proc_maxy(0:nproc_x-1, 0:nproc_y-1)) + + ! Exchange information with other processors + if (my_proc_id == IO_NODE) then + processors(my_x, my_y) = my_proc_id + do i=1,nprocs-1 + call MPI_Recv(buffer, 2, MPI_INTEGER, i, MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + processors(buffer(1), buffer(2)) = mpi_stat(MPI_SOURCE) + end do + else + buffer(1) = my_x + buffer(2) = my_y + call MPI_Send(buffer, 2, MPI_INTEGER, 0, my_proc_id, comm, mpi_ierr) + end if + + do ix=0,nproc_x-1 + do iy=0,nproc_y-1 + call parallel_bcast_int(processors(ix,iy), IO_NODE) + end do + end do + + proc_minx(my_x, my_y) = my_minx + proc_maxx(my_x, my_y) = my_maxx + proc_miny(my_x, my_y) = my_miny + proc_maxy(my_x, my_y) = my_maxy + + do ix=0,nproc_x-1 + do iy=0,nproc_y-1 + call parallel_bcast_int(proc_minx(ix,iy), processors(ix,iy)) + call parallel_bcast_int(proc_maxx(ix,iy), processors(ix,iy)) + call parallel_bcast_int(proc_miny(ix,iy), processors(ix,iy)) + call parallel_bcast_int(proc_maxy(ix,iy), processors(ix,iy)) + end do + end do + +#else + allocate(processors(0:nproc_x-1, 0:nproc_y-1)) + allocate(proc_minx(0:nproc_x-1, 0:nproc_y-1)) + allocate(proc_miny(0:nproc_x-1, 0:nproc_y-1)) + allocate(proc_maxx(0:nproc_x-1, 0:nproc_y-1)) + allocate(proc_maxy(0:nproc_x-1, 0:nproc_y-1)) + + processors(0,0) = IO_NODE + proc_minx(0,0) = 1 + proc_miny(0,0) = 1 + proc_maxx(0,0) = idim + proc_maxy(0,0) = jdim + my_minx = 1 + my_maxx = idim + my_miny = 1 + my_maxy = jdim + +#endif + + end subroutine parallel_get_tile_dims + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Copied from RSL_LITE's task_for_point.c until a good way can be found to + ! get the build mechanism to use the original code in RSL_LITE. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine task_for_point(i_p, j_p, ids_p, ide_p, jds_p, jde_p, npx, npy, px, py) + + implicit none + + ! Arguments + integer, intent(in) :: i_p, j_p, ids_p, ide_p, jds_p, jde_p, npx, npy + integer, intent(out) :: px, py + + ! Local variables + integer :: a, b, rem, idim, jdim, i, j, ids, jds, ide, jde + + i = i_p - 1 + j = j_p - 1 + ids = ids_p - 1 + jds = jds_p - 1 + ide = ide_p - 1 + jde = jde_p - 1 + + idim = ide-ids+1 + jdim = jde-jds+1 + + i = max(i,ids) + i = min(i,ide) + rem = mod(idim, npx) + a = ( rem / 2 ) * ( (idim / npx) + 1 ) + b = a + ( npx - rem ) * ( idim / npx ) + if ( i-ids < a ) then + px = (i-ids) / ( (idim / npx) + 1 ) + else if ( i-ids < b ) then + px = ( a / ( (idim / npx) + 1 ) ) + (i-a-ids) / ( ( b - a ) / ( npx - rem ) ) + else + px = ( a / ( (idim / npx) + 1 ) ) + (b-a-ids) / ( ( b - a ) / ( npx - rem ) ) + & + (i-b-ids) / ( ( idim / npx ) + 1 ) + end if + + j = max(j,jds) + j = min(j,jde) + rem = mod(jdim, npy) + a = ( rem / 2 ) * ( (jdim / npy) + 1 ) + b = a + ( npy - rem ) * ( jdim / npy ) + if ( j-jds < a ) then + py = (j-jds) / ( (jdim / npy) + 1 ) + else if ( j-jds < b ) then + py = ( a / ( (jdim / npy) + 1 ) ) + (j-a-jds) / ( ( b - a ) / ( npy - rem ) ) + else + py = ( a / ( (jdim / npy) + 1 ) ) + (b-a-jds) / ( ( b - a ) / ( npy - rem ) ) + & + (j-b-jds) / ( ( jdim / npy ) + 1 ) + end if + + end subroutine task_for_point + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: gather_whole_field_i + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine gather_whole_field_i(patch_array, ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3, & + domain_array, ds1, de1, ds2, de2, ds3, de3) + + implicit none + + ! Arguments + integer, intent(in) :: ps1, pe1, ps2, pe2, ps3, pe3, & + ms1, me1, ms2, me2, ms3, me3, & + ds1, de1, ds2, de2, ds3, de3 + integer, dimension(ms1:me1,ms2:me2,ms3:me3), intent(in) :: patch_array + integer, dimension(ds1:de1,ds2:de2,ds3:de3), intent(inout) :: domain_array + + ! Local variables +#ifdef _MPI + integer :: i, ii, j, jj, kk + integer, dimension(2) :: idims, jdims + integer :: mpi_ierr + integer, dimension(MPI_STATUS_SIZE) :: mpi_stat + + if (my_proc_id == IO_NODE) then + + do j=0,nproc_y-1 + do i=0,nproc_x-1 + if (processors(i,j) /= IO_NODE) then + call MPI_Recv(jdims, 2, MPI_INTEGER, processors(i,j), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + call MPI_Recv(idims, 2, MPI_INTEGER, processors(i,j), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + do kk=ds3,de3 +! BUG: Check on mpi_stat and mpi_ierr + call MPI_Recv(domain_array(idims(1):idims(2),jdims(1):jdims(2),kk), & + (idims(2)-idims(1)+1)*(jdims(2)-jdims(1)+1), & + MPI_INTEGER, processors(i,j), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + else + domain_array(ps1:pe1,ps2:pe2,ps3:pe3) = patch_array(ps1:pe1,ps2:pe2,ps3:pe3) + end if + end do + end do + + else + + jdims(1) = ps2 + jdims(2) = pe2 + call MPI_Send(jdims, 2, MPI_INTEGER, 0, my_proc_id, comm, mpi_ierr) + idims(1) = ps1 + idims(2) = pe1 + call MPI_Send(idims, 2, MPI_INTEGER, 0, my_proc_id, comm, mpi_ierr) + do kk=ps3,pe3 + call MPI_Send(patch_array(ps1:pe1,ps2:pe2,kk), (pe1-ps1+1)*(pe2-ps2+1), MPI_INTEGER, 0, my_proc_id, comm, mpi_ierr) +! BUG: Check on mpi_ierr + end do + end if +#endif + + end subroutine gather_whole_field_i + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: gather_whole_field_r + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine gather_whole_field_r(patch_array, ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3, & + domain_array, ds1, de1, ds2, de2, ds3, de3) + + implicit none + + ! Arguments + integer, intent(in) :: ps1, pe1, ps2, pe2, ps3, pe3, & + ms1, me1, ms2, me2, ms3, me3, & + ds1, de1, ds2, de2, ds3, de3 + real, dimension(ms1:me1,ms2:me2,ms3:me3), intent(in) :: patch_array + real, dimension(ds1:de1,ds2:de2,ds3:de3), intent(inout) :: domain_array + + ! Local variables +#ifdef _MPI + integer :: i, ii, j, jj, kk + integer, dimension(2) :: idims, jdims + integer :: mpi_ierr + integer, dimension(MPI_STATUS_SIZE) :: mpi_stat + + if (my_proc_id == IO_NODE) then + + do j=0,nproc_y-1 + do i=0,nproc_x-1 + if (processors(i,j) /= IO_NODE) then + call MPI_Recv(jdims, 2, MPI_INTEGER, processors(i,j), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + call MPI_Recv(idims, 2, MPI_INTEGER, processors(i,j), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + do kk=ds3,de3 +! BUG: Check on mpi_stat and mpi_ierr + call MPI_Recv(domain_array(idims(1):idims(2),jdims(1):jdims(2),kk), & + (idims(2)-idims(1)+1)*(jdims(2)-jdims(1)+1), & + MPI_REAL, processors(i,j), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + else + domain_array(ps1:pe1,ps2:pe2,ps3:pe3) = patch_array(ps1:pe1,ps2:pe2,ps3:pe3) + end if + end do + end do + + else + + jdims(1) = ps2 + jdims(2) = pe2 + call MPI_Send(jdims, 2, MPI_INTEGER, 0, my_proc_id, comm, mpi_ierr) + idims(1) = ps1 + idims(2) = pe1 + call MPI_Send(idims, 2, MPI_INTEGER, 0, my_proc_id, comm, mpi_ierr) + do kk=ps3,pe3 + call MPI_Send(patch_array(ps1:pe1,ps2:pe2,kk), (pe1-ps1+1)*(pe2-ps2+1), MPI_REAL, 0, my_proc_id, comm, mpi_ierr) +! BUG: Check on mpi_ierr + end do + end if +#endif + + end subroutine gather_whole_field_r + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: scatter_whole_field_i + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine scatter_whole_field_i(patch_array, ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3, & + domain_array, ds1, de1, ds2, de2, ds3, de3) + + implicit none + + ! Arguments + integer, intent(in) :: ps1, pe1, ps2, pe2, ps3, pe3, & + ms1, me1, ms2, me2, ms3, me3, & + ds1, de1, ds2, de2, ds3, de3 + integer, dimension(ms1:me1,ms2:me2,ms3:me3), intent(inout) :: patch_array + integer, dimension(ds1:de1,ds2:de2,ds3:de3), intent(in) :: domain_array + + ! Local variables +#ifdef _MPI + integer :: i, ii, j, jj, kk + integer, dimension(2) :: idims, jdims + integer :: mpi_ierr + integer, dimension(MPI_STATUS_SIZE) :: mpi_stat + + if (my_proc_id == IO_NODE) then + + do j=0,nproc_y-1 + do i=0,nproc_x-1 + if (processors(i,j) /= IO_NODE) then + call MPI_Recv(jdims, 2, MPI_INTEGER, processors(i,j), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + call MPI_Recv(idims, 2, MPI_INTEGER, processors(i,j), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + do kk=ds3,de3 +! BUG: Check on mpi_stat and mpi_ierr + call MPI_Send(domain_array(idims(1):idims(2),jdims(1):jdims(2),kk), & + (idims(2)-idims(1)+1)*(jdims(2)-jdims(1)+1), & + MPI_INTEGER, processors(i,j), my_proc_id, comm, mpi_ierr) + end do + else + patch_array(ps1:pe1,ps2:pe2,ps3:pe3) = domain_array(ps1:pe1,ps2:pe2,ps3:pe3) + end if + end do + end do + + else + + jdims(1) = ps2 + jdims(2) = pe2 + call MPI_Send(jdims, 2, MPI_INTEGER, 0, my_proc_id, comm, mpi_ierr) + idims(1) = ps1 + idims(2) = pe1 + call MPI_Send(idims, 2, MPI_INTEGER, 0, my_proc_id, comm, mpi_ierr) + do kk=ps3,pe3 + call MPI_Recv(patch_array(ps1:pe1,ps2:pe2,kk), (pe1-ps1+1)*(pe2-ps2+1), & + MPI_INTEGER, 0, MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) +! BUG: Check on mpi_ierr + end do + end if +#endif + + end subroutine scatter_whole_field_i + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: scatter_whole_field_r + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine scatter_whole_field_r(patch_array, ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3, & + domain_array, ds1, de1, ds2, de2, ds3, de3) + + implicit none + + ! Arguments + integer, intent(in) :: ps1, pe1, ps2, pe2, ps3, pe3, & + ms1, me1, ms2, me2, ms3, me3, & + ds1, de1, ds2, de2, ds3, de3 + real, dimension(ms1:me1,ms2:me2,ms3:me3), intent(inout) :: patch_array + real, dimension(ds1:de1,ds2:de2,ds3:de3), intent(in) :: domain_array + + ! Local variables +#ifdef _MPI + integer :: i, ii, j, jj, kk + integer, dimension(2) :: idims, jdims + integer :: mpi_ierr + integer, dimension(MPI_STATUS_SIZE) :: mpi_stat + + if (my_proc_id == IO_NODE) then + + do j=0,nproc_y-1 + do i=0,nproc_x-1 + if (processors(i,j) /= IO_NODE) then + call MPI_Recv(jdims, 2, MPI_INTEGER, processors(i,j), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + call MPI_Recv(idims, 2, MPI_INTEGER, processors(i,j), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + do kk=ds3,de3 +! BUG: Check on mpi_stat and mpi_ierr + call MPI_Send(domain_array(idims(1):idims(2),jdims(1):jdims(2),kk), & + (idims(2)-idims(1)+1)*(jdims(2)-jdims(1)+1), & + MPI_REAL, processors(i,j), my_proc_id, comm, mpi_ierr) + end do + else + patch_array(ps1:pe1,ps2:pe2,ps3:pe3) = domain_array(ps1:pe1,ps2:pe2,ps3:pe3) + end if + end do + end do + + else + + jdims(1) = ps2 + jdims(2) = pe2 + call MPI_Send(jdims, 2, MPI_INTEGER, 0, my_proc_id, comm, mpi_ierr) + idims(1) = ps1 + idims(2) = pe1 + call MPI_Send(idims, 2, MPI_INTEGER, 0, my_proc_id, comm, mpi_ierr) + do kk=ps3,pe3 + call MPI_Recv(patch_array(ps1:pe1,ps2:pe2,kk), (pe1-ps1+1)*(pe2-ps2+1), & + MPI_REAL, 0, MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) +! BUG: Check on mpi_ierr + end do + end if +#endif + + end subroutine scatter_whole_field_r + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: exchange_halo_r + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine exchange_halo_r(patch_array, & + ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3) + + implicit none + + ! Arguments + integer, intent(in) :: ps1, pe1, ps2, pe2, ps3, pe3, & + ms1, me1, ms2, me2, ms3, me3 + real, dimension(ms1:me1,ms2:me2,ms3:me3), intent(inout) :: patch_array + + ! Local variables +#ifdef _MPI + integer :: jj, kk + integer :: mpi_ierr + integer, dimension(MPI_STATUS_SIZE) :: mpi_stat + + ! + ! Get left edge of halo + ! + if (my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=ms2,me2 + call MPI_Send(patch_array(pe1-HALO_WIDTH+1:pe1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x+1,my_y), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_x /= 0) then + do kk=ps3,pe3 + do jj=ms2,me2 + call MPI_Recv(patch_array(ms1:ms1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x-1,my_y), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get right edge of halo + ! + if (my_x /= 0) then + do kk=ps3,pe3 + do jj=ms2,me2 + call MPI_Send(patch_array(ps1:ps1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x-1,my_y), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=ms2,me2 + call MPI_Recv(patch_array(me1-HALO_WIDTH+1:me1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x+1,my_y), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get bottom edge of halo + ! + if (my_y /= (nproc_y - 1)) then + do kk=ps3,pe3 + do jj=pe2-HALO_WIDTH+1,pe2 + call MPI_Send(patch_array(ms1:me1,jj,kk), (me1-ms1+1), MPI_REAL, & + processors(my_x,my_y+1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= 0) then + do kk=ps3,pe3 + do jj=ms2,ms2+HALO_WIDTH-1 + call MPI_Recv(patch_array(ms1:me1,jj,kk), (me1-ms1+1), MPI_REAL, & + processors(my_x,my_y-1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get top edge of halo + ! + if (my_y /= 0) then + do kk=ps3,pe3 + do jj=ps2,ps2+HALO_WIDTH-1 + call MPI_Send(patch_array(ms1:me1,jj,kk), (me1-ms1+1), MPI_REAL, & + processors(my_x,my_y-1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= (nproc_y - 1)) then + do kk=ps3,pe3 + do jj=me2-HALO_WIDTH+1,me2 + call MPI_Recv(patch_array(ms1:me1,jj,kk), (me1-ms1+1), MPI_REAL, & + processors(my_x,my_y+1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get lower-right corner of halo + ! + if (my_y /= (nproc_y - 1) .and. my_x /= 0) then + do kk=ps3,pe3 + do jj=pe2-HALO_WIDTH+1,pe2 + call MPI_Send(patch_array(ps1:ps1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x-1,my_y+1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= 0 .and. my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=ms2,ms2+HALO_WIDTH-1 + call MPI_Recv(patch_array(me1-HALO_WIDTH+1:me1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x+1,my_y-1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get upper-left corner of halo + ! + if (my_y /= 0 .and. my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=ps2,ps2+HALO_WIDTH-1 + call MPI_Send(patch_array(pe1-HALO_WIDTH+1:pe1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x+1,my_y-1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= (nproc_y - 1) .and. my_x /= 0) then + do kk=ps3,pe3 + do jj=me2-HALO_WIDTH+1,me2 + call MPI_Recv(patch_array(ms1:ms1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x-1,my_y+1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get upper-right corner of halo + ! + if (my_y /= 0 .and. my_x /= 0) then + do kk=ps3,pe3 + do jj=ps2,ps2+HALO_WIDTH-1 + call MPI_Send(patch_array(ps1:ps1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x-1,my_y-1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= (nproc_y - 1) .and. my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=me2-HALO_WIDTH+1,me2 + call MPI_Recv(patch_array(me1-HALO_WIDTH+1:me1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x+1,my_y+1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get lower-left corner of halo + ! + if (my_y /= (nproc_y - 1) .and. my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=pe2-HALO_WIDTH+1,pe2 + call MPI_Send(patch_array(pe1-HALO_WIDTH+1:pe1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x+1,my_y+1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= 0 .and. my_x /= 0) then + do kk=ps3,pe3 + do jj=ms2,ms2+HALO_WIDTH-1 + call MPI_Recv(patch_array(ms1:ms1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_REAL, & + processors(my_x-1,my_y-1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if +#endif + + end subroutine exchange_halo_r + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: exchange_halo_i + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine exchange_halo_i(patch_array, & + ms1, me1, ms2, me2, ms3, me3, & + ps1, pe1, ps2, pe2, ps3, pe3) + + implicit none + + ! Arguments + integer, intent(in) :: ps1, pe1, ps2, pe2, ps3, pe3, & + ms1, me1, ms2, me2, ms3, me3 + integer, dimension(ms1:me1,ms2:me2,ms3:me3), intent(inout) :: patch_array + + ! Local variables +#ifdef _MPI + integer :: jj, kk + integer :: mpi_ierr + integer, dimension(MPI_STATUS_SIZE) :: mpi_stat + + ! + ! Get left edge of halo + ! + if (my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=ms2,me2 + call MPI_Send(patch_array(pe1-HALO_WIDTH+1:pe1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x+1,my_y), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_x /= 0) then + do kk=ps3,pe3 + do jj=ms2,me2 + call MPI_Recv(patch_array(ms1:ms1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x-1,my_y), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get right edge of halo + ! + if (my_x /= 0) then + do kk=ps3,pe3 + do jj=ms2,me2 + call MPI_Send(patch_array(ps1:ps1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x-1,my_y), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=ms2,me2 + call MPI_Recv(patch_array(me1-HALO_WIDTH+1:me1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x+1,my_y), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get bottom edge of halo + ! + if (my_y /= (nproc_y - 1)) then + do kk=ps3,pe3 + do jj=pe2-HALO_WIDTH+1,pe2 + call MPI_Send(patch_array(ms1:me1,jj,kk), (me1-ms1+1), MPI_INTEGER, & + processors(my_x,my_y+1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= 0) then + do kk=ps3,pe3 + do jj=ms2,ms2+HALO_WIDTH-1 + call MPI_Recv(patch_array(ms1:me1,jj,kk), (me1-ms1+1), MPI_INTEGER, & + processors(my_x,my_y-1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get top edge of halo + ! + if (my_y /= 0) then + do kk=ps3,pe3 + do jj=ps2,ps2+HALO_WIDTH-1 + call MPI_Send(patch_array(ms1:me1,jj,kk), (me1-ms1+1), MPI_INTEGER, & + processors(my_x,my_y-1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= (nproc_y - 1)) then + do kk=ps3,pe3 + do jj=me2-HALO_WIDTH+1,me2 + call MPI_Recv(patch_array(ms1:me1,jj,kk), (me1-ms1+1), MPI_INTEGER, & + processors(my_x,my_y+1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get lower-right corner of halo + ! + if (my_y /= (nproc_y - 1) .and. my_x /= 0) then + do kk=ps3,pe3 + do jj=pe2-HALO_WIDTH+1,pe2 + call MPI_Send(patch_array(ps1:ps1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x-1,my_y+1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= 0 .and. my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=ms2,ms2+HALO_WIDTH-1 + call MPI_Recv(patch_array(me1-HALO_WIDTH+1:me1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x+1,my_y-1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get upper-left corner of halo + ! + if (my_y /= 0 .and. my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=ps2,ps2+HALO_WIDTH-1 + call MPI_Send(patch_array(pe1-HALO_WIDTH+1:pe1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x+1,my_y-1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= (nproc_y - 1) .and. my_x /= 0) then + do kk=ps3,pe3 + do jj=me2-HALO_WIDTH+1,me2 + call MPI_Recv(patch_array(ms1:ms1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x-1,my_y+1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get upper-right corner of halo + ! + if (my_y /= 0 .and. my_x /= 0) then + do kk=ps3,pe3 + do jj=ps2,ps2+HALO_WIDTH-1 + call MPI_Send(patch_array(ps1:ps1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x-1,my_y-1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= (nproc_y - 1) .and. my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=me2-HALO_WIDTH+1,me2 + call MPI_Recv(patch_array(me1-HALO_WIDTH+1:me1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x+1,my_y+1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if + + ! + ! Get lower-left corner of halo + ! + if (my_y /= (nproc_y - 1) .and. my_x /= (nproc_x - 1)) then + do kk=ps3,pe3 + do jj=pe2-HALO_WIDTH+1,pe2 + call MPI_Send(patch_array(pe1-HALO_WIDTH+1:pe1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x+1,my_y+1), my_proc_id, comm, mpi_ierr) + end do + end do + end if + if (my_y /= 0 .and. my_x /= 0) then + do kk=ps3,pe3 + do jj=ms2,ms2+HALO_WIDTH-1 + call MPI_Recv(patch_array(ms1:ms1+HALO_WIDTH-1,jj,kk), HALO_WIDTH, MPI_INTEGER, & + processors(my_x-1,my_y-1), MPI_ANY_TAG, comm, mpi_stat, mpi_ierr) + end do + end do + end if +#endif + + end subroutine exchange_halo_i + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: parallel_bcast_logical + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine parallel_bcast_logical(lval) + + implicit none + + ! Argument + logical, intent(inout) :: lval + + ! Local variables +#ifdef _MPI + integer :: mpi_ierr + + call MPI_Bcast(lval, 1, MPI_LOGICAL, IO_NODE, comm, mpi_ierr) +#endif + + end subroutine parallel_bcast_logical + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: parallel_bcast_int + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine parallel_bcast_int(ival, from_whom) + + implicit none + + ! Argument + integer, intent(inout) :: ival + integer, intent(in), optional :: from_whom + + ! Local variables +#ifdef _MPI + integer :: mpi_ierr + + if (present(from_whom)) then + call MPI_Bcast(ival, 1, MPI_INTEGER, from_whom, comm, mpi_ierr) + else + call MPI_Bcast(ival, 1, MPI_INTEGER, IO_NODE, comm, mpi_ierr) + end if +#endif + + end subroutine parallel_bcast_int + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: parallel_bcast_real + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine parallel_bcast_real(rval, from_whom) + + implicit none + + ! Argument + real, intent(inout) :: rval + integer, intent(in), optional :: from_whom + + ! Local variables +#ifdef _MPI + integer :: mpi_ierr + + if (present(from_whom)) then + call MPI_Bcast(rval, 1, MPI_REAL, from_whom, comm, mpi_ierr) + else + call MPI_Bcast(rval, 1, MPI_REAL, IO_NODE, comm, mpi_ierr) + end if +#endif + + end subroutine parallel_bcast_real + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: parallel_bcast_char + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine parallel_bcast_char(cval, n, from_whom) + + implicit none + + ! Argument + integer, intent(in) :: n + character (len=n), intent(inout) :: cval + integer, intent(in), optional :: from_whom + + ! Local variables +#ifdef _MPI + integer :: mpi_ierr + + if (present(from_whom)) then + call MPI_Bcast(cval, n, MPI_CHARACTER, from_whom, comm, mpi_ierr) + else + call MPI_Bcast(cval, n, MPI_CHARACTER, IO_NODE, comm, mpi_ierr) + end if +#endif + + end subroutine parallel_bcast_char + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: parallel_finish + ! + ! Purpose: Free up, deallocate, and for MPI, finalize. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine parallel_finish() + + implicit none + + ! Arguments + + ! Local variables +#ifdef _MPI + integer :: mpi_ierr + + call MPI_Finalize(mpi_ierr) +#endif + + if (associated(processors)) deallocate(processors) + if (associated(proc_minx)) deallocate(proc_minx) + if (associated(proc_maxx)) deallocate(proc_maxx) + if (associated(proc_miny)) deallocate(proc_miny) + if (associated(proc_maxy)) deallocate(proc_maxy) + + end subroutine parallel_finish + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: parallel_abort + ! + ! Purpose: Terminate everything + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine parallel_abort() + + implicit none + + ! Arguments + + ! Local variables +#ifdef _MPI + integer :: mpi_ierr, mpi_errcode + + call MPI_Abort(MPI_COMM_WORLD, mpi_errcode, mpi_ierr) +#endif + + stop + + end subroutine parallel_abort + +end module parallel_module diff --git a/WPS/geogrid/src/proc_point_module.F b/WPS/geogrid/src/proc_point_module.F new file mode 100644 index 00000000..95a9e78e --- /dev/null +++ b/WPS/geogrid/src/proc_point_module.F @@ -0,0 +1,939 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Module: proc_point_module +! +! Purpose: This module provides routines that produce a value for a model grid +! point in two ways. If the field for which a value is being calculated is +! a continuous field, this module provided functionality to interpolate +! from the source array to the specified point. If the field is a categorical +! field, this module provided functionality to accumulate the values of all +! source points whose nearest model gridpoint is the specified point. +! Routines are also provided that help the caller determine an optimized +! order in which to process the model grid points. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module proc_point_module + + ! Modules + use bitarray_module + use hash_module + use misc_definitions_module + use module_debug + use source_data_module + + ! Information about which tile is in memory + integer :: src_min_x, src_max_x, src_min_y, src_max_y, src_min_z, src_max_z, src_npts_bdr + integer :: src_level + character (len=128) :: src_fieldname + character (len=256) :: src_fname + + ! Source tiles + real, pointer, dimension(:,:,:) :: src_array + + ! Hash to track which tiles we have already processed + type (hashtable) :: h_table + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: proc_point_init + ! + ! Purpose: Initialize the module. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine proc_point_init() + + implicit none + + ! Initialize module variables + src_min_x = INVALID + src_min_y = INVALID + src_min_z = INVALID + src_max_x = INVALID + src_max_y = INVALID + src_max_z = INVALID + src_fieldname = ' ' + src_fname = ' ' + nullify(src_array) + + call hash_init(h_table) + + end subroutine proc_point_init + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: proc_point_shutdown + ! + ! Purpose: Do any cleanup work. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine proc_point_shutdown() + + implicit none + + ! Effectively reset the hash table that tracks which tiles have been processed + ! by removing all entries + call hash_destroy(h_table) + + if (associated(src_array)) deallocate(src_array) + + src_min_x = INVALID + src_min_y = INVALID + src_min_z = INVALID + src_max_x = INVALID + src_max_y = INVALID + src_max_z = INVALID + src_fieldname = ' ' + src_fname = ' ' + + end subroutine proc_point_shutdown + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: accum_categorical + ! + ! Purpose: Count the number of source points in each category whose nearest + ! neighbor is the specified model grid point. + ! + ! NOTE: When processing the source tile, those source points that are + ! closest to a different model grid point will be added to the totals for + ! such grid points; thus, an entire source tile will be processed at a time. + ! This routine really processes for all model grid points that are + ! within a source tile, and not just for a single grid point. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine accum_categorical(xlat, xlon, istagger, array, & + start_i, end_i, start_j, end_j, & + start_k, end_k, fieldname, processed_pts, & + new_pts, ilevel, msgval, maskval, sr_x, sr_y) + + use llxy_module + use bitarray_module + + implicit none + + ! Arguments + integer, intent(in) :: start_i, end_i, start_j, end_j, start_k, end_k, & + istagger, ilevel + real, intent(in) :: xlat, xlon, msgval, maskval + real, dimension(start_i:end_i, start_j:end_j, start_k:end_k), intent(inout) :: array + character (len=128), intent(in) :: fieldname + type (bitarray), intent(inout) :: processed_pts, new_pts + integer, intent(in), optional :: sr_x, sr_y + + ! Local variables + integer :: istatus, i, j + integer :: current_domain, k + integer, pointer, dimension(:,:,:) :: where_maps_to + real :: rlat, rlon + real :: rarea + real :: rsr_x, rsr_y + + rlat = xlat + if (xlon >= 180.) then + rlon = xlon - 360. + else + rlon = xlon + end if + + rsr_x = 1.0 + rsr_y = 1.0 + if (present(sr_x)) rsr_x = real(sr_x) + if (present(sr_y)) rsr_y = real(sr_y) + + ! Assume source data is on unstaggered grid; specify M for istagger argument + call get_data_tile(rlat, rlon, ilevel, fieldname, & + src_fname, src_array, src_min_x, src_max_x, src_min_y, & + src_max_y, src_min_z, src_max_z, src_npts_bdr, & + istatus) + + src_fieldname = fieldname + src_level = ilevel + + call hash_insert(h_table, src_fname) + + if (istatus /= 0) return + + allocate(where_maps_to(src_min_x:src_max_x,src_min_y:src_max_y,2)) + do i=src_min_x,src_max_x + do j=src_min_y,src_max_y + where_maps_to(i,j,1) = NOT_PROCESSED + end do + end do + + call process_categorical_block(src_array, istagger, where_maps_to, & + src_min_x+src_npts_bdr, src_min_y+src_npts_bdr, src_min_z, & + src_max_x-src_npts_bdr, src_max_y-src_npts_bdr, src_max_z, & + array, start_i, end_i, start_j, end_j, start_k, end_k, & + processed_pts, new_pts, ilevel, rsr_x, rsr_y, msgval, maskval) + + ! If a grid cell has less than half of its area covered by data from this source, + ! then clear the cell and let another source fill in the cell + if (ilevel > 1) then + do i=start_i,end_i + do j=start_j,end_j + if (bitarray_test(new_pts, i-start_i+1, j-start_j+1) .and. & + .not. bitarray_test(processed_pts, i-start_i+1, j-start_j+1)) then + rarea = 0. + do k=start_k,end_k + rarea = rarea + array(i,j,k) + end do + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + if (proj_stack(current_nest_number)%dx < 0.) then + rarea = rarea * (proj_stack(current_nest_number)%latinc*111000.)**2.0 + else + rarea = rarea * proj_stack(current_nest_number)%dx**2.0 + end if + call select_domain(current_domain) + if (proj_stack(current_nest_number)%dx < 0.) then + if ((proj_stack(current_nest_number)%latinc*111000.)**2.0 > 2.0*rarea) then + do k=start_k,end_k + array(i,j,k) = 0. + end do + call bitarray_clear(new_pts, i-start_i+1, j-start_j+1) + end if + else + if (proj_stack(current_nest_number)%dx**2.0 > 2.0*rarea) then + do k=start_k,end_k + array(i,j,k) = 0. + end do + call bitarray_clear(new_pts, i-start_i+1, j-start_j+1) + end if + end if + end if + end do + end do + end if + + deallocate(where_maps_to) + + end subroutine accum_categorical + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: process_categorical_block + ! + ! Purpose: To recursively process a subarray of categorical data, assigning + ! the points in a block to their nearest grid point. The nearest neighbor + ! may be estimated in some cases; for example, if the four corners of a + ! subarray all have the same nearest grid point, all elements in the + ! subarray are assigned to that grid point. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive subroutine process_categorical_block(tile_array, istagger, where_maps_to, & + min_i, min_j, min_k, max_i, max_j, max_k, dst_array, & + start_x, end_x, start_y, end_y, start_z, end_z, & + processed_pts, new_pts, ilevel, sr_x, sr_y, & + msgval, maskval, mask_array) + + use llxy_module + + implicit none + + ! Arguments + integer, intent(in) :: min_i, min_j, min_k, max_i, max_j, max_k, istagger, & + start_x, end_x, start_y, end_y, start_z, end_z, ilevel + integer, dimension(src_min_x:src_max_x,src_min_y:src_max_y,2), intent(inout) :: where_maps_to + real, intent(in) :: sr_x, sr_y, msgval, maskval + real, dimension(src_min_x:src_max_x,src_min_y:src_max_y,src_min_z:src_max_z), intent(in) :: tile_array + real, dimension(start_x:end_x,start_y:end_y,start_z:end_z), intent(inout) :: dst_array + real, dimension(src_min_x:src_max_x,src_min_y:src_max_y), intent(in), optional :: mask_array + type (bitarray), intent(inout) :: processed_pts, new_pts + + ! Local variables + integer :: x_dest, y_dest, i, j, k, center_i, center_j, current_domain + real :: lat_corner, lon_corner, rx, ry + + ! Compute the model grid point that the corners of the rectangle to be + ! processed map to + ! Lower-left corner + if (where_maps_to(min_i,min_j,1) == NOT_PROCESSED) then + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(min_i), real(min_j), lat_corner, lon_corner, M) + call select_domain(current_domain) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx-1.0) * sr_x + 1.0 + ry = (ry-1.0) * sr_y + 1.0 + if (real(start_x) <= rx .and. rx <= real(end_x) .and. real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(min_i,min_j,1) = nint(rx) + where_maps_to(min_i,min_j,2) = nint(ry) + else + where_maps_to(min_i,min_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! Upper-left corner + if (where_maps_to(min_i,max_j,1) == NOT_PROCESSED) then + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(min_i), real(max_j), lat_corner, lon_corner, M) + call select_domain(current_domain) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx-1.0) * sr_x + 1.0 + ry = (ry-1.0) * sr_y + 1.0 + if (real(start_x) <= rx .and. rx <= real(end_x) .and. real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(min_i,max_j,1) = nint(rx) + where_maps_to(min_i,max_j,2) = nint(ry) + else + where_maps_to(min_i,max_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! Upper-right corner + if (where_maps_to(max_i,max_j,1) == NOT_PROCESSED) then + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(max_i), real(max_j), lat_corner, lon_corner, M) + call select_domain(current_domain) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx-1.0) * sr_x + 1.0 + ry = (ry-1.0) * sr_y + 1.0 + if (real(start_x) <= rx .and. rx <= real(end_x) .and. real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(max_i,max_j,1) = nint(rx) + where_maps_to(max_i,max_j,2) = nint(ry) + else + where_maps_to(max_i,max_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! Lower-right corner + if (where_maps_to(max_i,min_j,1) == NOT_PROCESSED) then + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(max_i), real(min_j), lat_corner, lon_corner, M) + call select_domain(current_domain) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx-1.0) * sr_x + 1.0 + ry = (ry-1.0) * sr_y + 1.0 + if (real(start_x) <= rx .and. rx <= real(end_x) .and. real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(max_i,min_j,1) = nint(rx) + where_maps_to(max_i,min_j,2) = nint(ry) + else + where_maps_to(max_i,min_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! If all four corners map to same model grid point, accumulate the + ! entire rectangle + if (where_maps_to(min_i,min_j,1) == where_maps_to(min_i,max_j,1) .and. & + where_maps_to(min_i,min_j,1) == where_maps_to(max_i,max_j,1) .and. & + where_maps_to(min_i,min_j,1) == where_maps_to(max_i,min_j,1) .and. & + where_maps_to(min_i,min_j,2) == where_maps_to(min_i,max_j,2) .and. & + where_maps_to(min_i,min_j,2) == where_maps_to(max_i,max_j,2) .and. & + where_maps_to(min_i,min_j,2) == where_maps_to(max_i,min_j,2) .and. & + where_maps_to(min_i,min_j,1) /= OUTSIDE_DOMAIN) then + x_dest = where_maps_to(min_i,min_j,1) + y_dest = where_maps_to(min_i,min_j,2) + + ! If this grid point was already given a value from higher-priority source data, + ! there is nothing to do. + if (.not. bitarray_test(processed_pts, x_dest-start_x+1, y_dest-start_y+1)) then + + ! If this grid point has never been given a value by this level of source data, + ! initialize the point + if (.not. bitarray_test(new_pts, x_dest-start_x+1, y_dest-start_y+1)) then + do k=start_z,end_z + dst_array(x_dest,y_dest,k) = 0. + end do + end if + + ! Count all the points whose nearest neighbor is this grid point + if (present(mask_array)) then + do i=min_i,max_i + do j=min_j,max_j + ! Ignore masked/missing values in the source data + if ((tile_array(i,j,min_k) /= msgval) .and. & + (mask_array(i,j) /= maskval)) then + if (int(tile_array(i,j,min_k)) >= start_z .and. int(tile_array(i,j,min_k)) <= end_z) then + dst_array(x_dest,y_dest,int(tile_array(i,j,min_k))) = & + dst_array(x_dest,y_dest,int(tile_array(i,j,min_k))) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + else + call mprintf(.true., WARN, 'In source tile %s, point (%i, %i) has '// & + 'an invalid category of %i', & + s1=trim(src_fname), i1=i, i2=j, i3=int(tile_array(i,j,min_k))) + end if + end if + end do + end do + else + do i=min_i,max_i + do j=min_j,max_j + ! Ignore masked/missing values in the source data + if (tile_array(i,j,min_k) /= msgval) then + if (int(tile_array(i,j,min_k)) >= start_z .and. int(tile_array(i,j,min_k)) <= end_z) then + dst_array(x_dest,y_dest,int(tile_array(i,j,min_k))) = & + dst_array(x_dest,y_dest,int(tile_array(i,j,min_k))) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + else + call mprintf(.true., WARN, 'In source tile %s, point (%i, %i) '// & + 'has an invalid category of %i', & + s1=trim(src_fname), i1=i, i2=j, i3=int(tile_array(i,j,min_k))) + end if + end if + end do + end do + end if + + end if + + ! Rectangle is a square of four points, and we can simply deal with each of the points + else if (((max_i - min_i + 1) <= 2) .and. ((max_j - min_j + 1) <= 2)) then + do i=min_i,max_i + do j=min_j,max_j + x_dest = where_maps_to(i,j,1) + y_dest = where_maps_to(i,j,2) + + if (x_dest /= OUTSIDE_DOMAIN) then + + if (.not. bitarray_test(processed_pts, x_dest-start_x+1, y_dest-start_y+1)) then + if (.not. bitarray_test(new_pts, x_dest-start_x+1, y_dest-start_y+1)) then + do k=start_z,end_z + dst_array(x_dest,y_dest,k) = 0. + end do + end if + + ! Ignore masked/missing values + if (present(mask_array)) then + if ((tile_array(i,j,min_k) /= msgval) .and. & + (mask_array(i,j) /= maskval)) then + if (int(tile_array(i,j,min_k)) >= start_z .and. int(tile_array(i,j,min_k)) <= end_z) then + dst_array(x_dest,y_dest,int(tile_array(i,j,min_k))) = & + dst_array(x_dest,y_dest,int(tile_array(i,j,min_k))) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + else + call mprintf(.true., WARN, 'In source tile %s, point (%i, %i) has '// & + 'an invalid category of %i', & + s1=trim(src_fname), i1=i, i2=j, i3=int(tile_array(i,j,min_k))) + end if + end if + else + if (tile_array(i,j,min_k) /= msgval) then + if (int(tile_array(i,j,min_k)) >= start_z .and. int(tile_array(i,j,min_k)) <= end_z) then + dst_array(x_dest,y_dest,int(tile_array(i,j,min_k))) = & + dst_array(x_dest,y_dest,int(tile_array(i,j,min_k))) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + else + call mprintf(.true., WARN, 'In source tile %s, point (%i, %i) has '// & + 'an invalid category of %i', & + s1=trim(src_fname), i1=i, i2=j, i3=int(tile_array(i,j,min_k))) + end if + end if + end if + end if + + end if + end do + end do + + ! Not all corners map to the same grid point, and the rectangle contains more than + ! four points + else + center_i = (max_i + min_i)/2 + center_j = (max_j + min_j)/2 + + ! Recursively process lower-left rectangle + call process_categorical_block(tile_array, istagger, where_maps_to, min_i, min_j, min_k, center_i, & + center_j, max_k, dst_array, start_x, end_x, start_y, end_y, start_z, end_z, processed_pts, & + new_pts, ilevel, sr_x, sr_y, msgval, maskval, mask_array) + + ! Recursively process lower-right rectangle + if (center_i < max_i) then + call process_categorical_block(tile_array, istagger, where_maps_to, center_i+1, min_j, min_k, max_i, & + center_j, max_k, dst_array, start_x, end_x, start_y, end_y, start_z, end_z, processed_pts, & + new_pts, ilevel, sr_x, sr_y, msgval, maskval, mask_array) + end if + + ! Recursively process upper-left rectangle + if (center_j < max_j) then + call process_categorical_block(tile_array, istagger, where_maps_to, min_i, center_j+1, min_k, center_i, & + max_j, max_k, dst_array, start_x, end_x, start_y, end_y, start_z, end_z, processed_pts, & + new_pts, ilevel, sr_x, sr_y, msgval, maskval, mask_array) + end if + + ! Recursively process upper-right rectangle + if (center_i < max_i .and. center_j < max_j) then + call process_categorical_block(tile_array, istagger, where_maps_to, center_i+1, center_j+1, min_k, max_i, & + max_j, max_k, dst_array, start_x, end_x, start_y, end_y, start_z, end_z, processed_pts, & + new_pts, ilevel, sr_x, sr_y, msgval, maskval, mask_array) + end if + end if + + end subroutine process_categorical_block + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: accum_continuous + ! + ! Purpose: Sum up all of the source data points whose nearest neighbor in the + ! model grid is the specified model grid point. + ! + ! NOTE: When processing the source tile, those source points that are + ! closest to a different model grid point will be added to the totals for + ! such grid points; thus, an entire source tile will be processed at a time. + ! This routine really processes for all model grid points that are + ! within a source tile, and not just for a single grid point. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine accum_continuous(xlat, xlon, istagger, array, n, & + start_i, end_i, start_j, end_j, & + start_k, end_k, fieldname, processed_pts, & + new_pts, ilevel, msgval, maskval, sr_x, sr_y) + + implicit none + + ! Arguments + integer, intent(in) :: start_i, end_i, start_j, end_j, start_k, end_k, & + istagger, ilevel + real, intent(in) :: xlat, xlon, msgval, maskval + real, dimension(start_i:end_i, start_j:end_j, start_k:end_k), intent(inout) :: array, n + character (len=128), intent(in) :: fieldname + type (bitarray), intent(inout) :: processed_pts, new_pts + integer, intent(in), optional :: sr_x, sr_y + + ! Local variables + integer :: istatus, i, j + integer, pointer, dimension(:,:,:) :: where_maps_to + real :: rlat, rlon + real :: rsr_x, rsr_y + + rlat = xlat + if (xlon >= 180.) then + rlon = xlon - 360. + else + rlon = xlon + end if + + rsr_x = 1.0 + rsr_y = 1.0 + if (present(sr_x)) rsr_x = real(sr_x) + if (present(sr_y)) rsr_y = real(sr_y) + + ! Assume source data is on unstaggered grid; specify M for istagger argument + call get_data_tile(rlat, rlon, ilevel, fieldname, & + src_fname, src_array, src_min_x, src_max_x, src_min_y, & + src_max_y, src_min_z, src_max_z, src_npts_bdr, & + istatus) + + src_fieldname = fieldname + src_level = ilevel + + call hash_insert(h_table, src_fname) + + if (istatus /= 0) then + src_min_x = INVALID + src_min_y = INVALID + src_max_x = INVALID + src_max_y = INVALID + return + end if + + allocate(where_maps_to(src_min_x:src_max_x,src_min_y:src_max_y,2)) + do i=src_min_x,src_max_x + do j=src_min_y,src_max_y + where_maps_to(i,j,1) = NOT_PROCESSED + end do + end do + + call process_continuous_block(src_array, istagger, where_maps_to, & + src_min_x+src_npts_bdr, src_min_y+src_npts_bdr, src_min_z, & + src_max_x-src_npts_bdr, src_max_y-src_npts_bdr, src_max_z, & + array, n, start_i, end_i, start_j, end_j, start_k, end_k, & + processed_pts, new_pts, ilevel, rsr_x, rsr_y, msgval, maskval) + + deallocate(where_maps_to) + + end subroutine accum_continuous + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: process_continuous_block + ! + ! Purpose: To recursively process a subarray of continuous data, adding the + ! points in a block to the sum for their nearest grid point. The nearest + ! neighbor may be estimated in some cases; for example, if the four corners + ! of a subarray all have the same nearest grid point, all elements in the + ! subarray are added to that grid point. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive subroutine process_continuous_block(tile_array, istagger, where_maps_to, & + min_i, min_j, min_k, max_i, max_j, max_k, dst_array, n, & + start_x, end_x, start_y, end_y, start_z, end_z, & + processed_pts, new_pts, ilevel, sr_x, sr_y, & + msgval, maskval, mask_array) + + use llxy_module + + implicit none + + ! Arguments + integer, intent(in) :: min_i, min_j, min_k, max_i, max_j, max_k, istagger, & + start_x, end_x, start_y, end_y, start_z, end_z, ilevel + integer, dimension(src_min_x:src_max_x,src_min_y:src_max_y,2), intent(inout) :: where_maps_to + real, intent(in) :: sr_x, sr_y, msgval, maskval + real, dimension(src_min_x:src_max_x,src_min_y:src_max_y,src_min_z:src_max_z), intent(in) :: tile_array + real, dimension(start_x:end_x,start_y:end_y,start_z:end_z), intent(inout) :: dst_array, n + real, dimension(src_min_x:src_max_x,src_min_y:src_max_y), intent(in), optional :: mask_array + type (bitarray), intent(inout) :: processed_pts, new_pts + + ! Local variables + integer :: x_dest, y_dest, i, j, k, center_i, center_j, current_domain + real :: lat_corner, lon_corner, rx, ry + + ! Compute the model grid point that the corners of the rectangle to be + ! processed map to + ! Lower-left corner + if (where_maps_to(min_i,min_j,1) == NOT_PROCESSED) then + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(min_i), real(min_j), lat_corner, lon_corner, M) + call select_domain(current_domain) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx-1.0) * sr_x + 1.0 + ry = (ry-1.0) * sr_y + 1.0 + if (real(start_x) <= rx .and. rx <= real(end_x) .and. real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(min_i,min_j,1) = nint(rx) + where_maps_to(min_i,min_j,2) = nint(ry) + else + where_maps_to(min_i,min_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! Upper-left corner + if (where_maps_to(min_i,max_j,1) == NOT_PROCESSED) then + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(min_i), real(max_j), lat_corner, lon_corner, M) + call select_domain(current_domain) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx-1.0) * sr_x + 1.0 + ry = (ry-1.0) * sr_y + 1.0 + if (real(start_x) <= rx .and. rx <= real(end_x) .and. real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(min_i,max_j,1) = nint(rx) + where_maps_to(min_i,max_j,2) = nint(ry) + else + where_maps_to(min_i,max_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! Upper-right corner + if (where_maps_to(max_i,max_j,1) == NOT_PROCESSED) then + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(max_i), real(max_j), lat_corner, lon_corner, M) + call select_domain(current_domain) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx-1.0) * sr_x + 1.0 + ry = (ry-1.0) * sr_y + 1.0 + if (real(start_x) <= rx .and. rx <= real(end_x) .and. real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(max_i,max_j,1) = nint(rx) + where_maps_to(max_i,max_j,2) = nint(ry) + else + where_maps_to(max_i,max_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! Lower-right corner + if (where_maps_to(max_i,min_j,1) == NOT_PROCESSED) then + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(max_i), real(min_j), lat_corner, lon_corner, M) + call select_domain(current_domain) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx-1.0) * sr_x + 1.0 + ry = (ry-1.0) * sr_y + 1.0 + if (real(start_x) <= rx .and. rx <= real(end_x) .and. real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(max_i,min_j,1) = nint(rx) + where_maps_to(max_i,min_j,2) = nint(ry) + else + where_maps_to(max_i,min_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! If all four corners map to same model grid point, accumulate the + ! entire rectangle + if (where_maps_to(min_i,min_j,1) == where_maps_to(min_i,max_j,1) .and. & + where_maps_to(min_i,min_j,1) == where_maps_to(max_i,max_j,1) .and. & + where_maps_to(min_i,min_j,1) == where_maps_to(max_i,min_j,1) .and. & + where_maps_to(min_i,min_j,2) == where_maps_to(min_i,max_j,2) .and. & + where_maps_to(min_i,min_j,2) == where_maps_to(max_i,max_j,2) .and. & + where_maps_to(min_i,min_j,2) == where_maps_to(max_i,min_j,2) .and. & + where_maps_to(min_i,min_j,1) /= OUTSIDE_DOMAIN) then + x_dest = where_maps_to(min_i,min_j,1) + y_dest = where_maps_to(min_i,min_j,2) + + ! If this grid point was already given a value from higher-priority source data, + ! there is nothing to do. + if (.not. bitarray_test(processed_pts, x_dest-start_x+1, y_dest-start_y+1)) then + + ! If this grid point has never been given a value by this level of source data, + ! initialize the point + if (.not. bitarray_test(new_pts, x_dest-start_x+1, y_dest-start_y+1)) then + do k=min_k,max_k + dst_array(x_dest,y_dest,k) = 0. + end do + end if + + ! Sum all the points whose nearest neighbor is this grid point + if (present(mask_array)) then + do i=min_i,max_i + do j=min_j,max_j + do k=min_k,max_k + ! Ignore masked/missing values in the source data + if ((tile_array(i,j,k) /= msgval) .and. & + (mask_array(i,j) /= maskval)) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + end if + end do + end do + end do + else + do i=min_i,max_i + do j=min_j,max_j + do k=min_k,max_k + ! Ignore masked/missing values in the source data + if (tile_array(i,j,k) /= msgval) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + end if + end do + end do + end do + end if + + end if + + ! Rectangle is a square of four points, and we can simply deal with each of the points + else if (((max_i - min_i + 1) <= 2) .and. ((max_j - min_j + 1) <= 2)) then + do i=min_i,max_i + do j=min_j,max_j + x_dest = where_maps_to(i,j,1) + y_dest = where_maps_to(i,j,2) + + if (x_dest /= OUTSIDE_DOMAIN) then + + if (.not. bitarray_test(processed_pts, x_dest-start_x+1, y_dest-start_y+1)) then + if (.not. bitarray_test(new_pts, x_dest-start_x+1, y_dest-start_y+1)) then + do k=min_k,max_k + dst_array(x_dest,y_dest,k) = 0. + end do + end if + + if (present(mask_array)) then + do k=min_k,max_k + ! Ignore masked/missing values + if ((tile_array(i,j,k) /= msgval) .and. & + (mask_array(i,j) /= maskval)) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + end if + end do + else + do k=min_k,max_k + ! Ignore masked/missing values + if (tile_array(i,j,k) /= msgval) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + end if + end do + end if + end if + + end if + end do + end do + + ! Not all corners map to the same grid point, and the rectangle contains more than + ! four points + else + center_i = (max_i + min_i)/2 + center_j = (max_j + min_j)/2 + + ! Recursively process lower-left rectangle + call process_continuous_block(tile_array, istagger, where_maps_to, min_i, min_j, min_k, center_i, & + center_j, max_k, dst_array, n, start_x, end_x, start_y, end_y, start_z, end_z, processed_pts, & + new_pts, ilevel, sr_x, sr_y, msgval, maskval, mask_array) + + ! Recursively process lower-right rectangle + if (center_i < max_i) then + call process_continuous_block(tile_array, istagger, where_maps_to, center_i+1, min_j, min_k, max_i, & + center_j, max_k, dst_array, n, start_x, end_x, start_y, end_y, start_z, end_z, processed_pts, & + new_pts, ilevel, sr_x, sr_y, msgval, maskval, mask_array) + end if + + ! Recursively process upper-left rectangle + if (center_j < max_j) then + call process_continuous_block(tile_array, istagger, where_maps_to, min_i, center_j+1, min_k, center_i, & + max_j, max_k, dst_array, n, start_x, end_x, start_y, end_y, start_z, end_z, processed_pts, & + new_pts, ilevel, sr_x, sr_y, msgval, maskval, mask_array) + end if + + ! Recursively process upper-right rectangle + if (center_i < max_i .and. center_j < max_j) then + call process_continuous_block(tile_array, istagger, where_maps_to, center_i+1, center_j+1, min_k, max_i, & + max_j, max_k, dst_array, n, start_x, end_x, start_y, end_y, start_z, end_z, processed_pts, & + new_pts, ilevel, sr_x, sr_y, msgval, maskval, mask_array) + end if + + end if + + end subroutine process_continuous_block + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_point + ! + ! Purpose: For a specified lat/lon and level, return the value of the field + ! interpolated to or nearest the lat/lon. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function get_point(xlat, xlon, lvl, fieldname, & + ilevel, interp_type, interp_opts, msgval) + + ! Modules + use interp_module + use llxy_module + + implicit none + + ! Arguments + integer, intent(in) :: lvl, ilevel + real, intent(in) :: xlat, xlon, msgval + character (len=128), intent(in) :: fieldname + integer, dimension(:), intent(in) :: interp_type + integer, dimension(:), intent(in) :: interp_opts + + ! Return value + real :: get_point + + ! Local variables + integer :: istatus, current_domain + real :: rlat, rlon, rx, ry + + rlat = xlat + if (xlon >= 180.) then + rlon = xlon - 360. + else + rlon = xlon + end if + + ! If tile is in memory, interpolate + if (ilevel == src_level .and. is_point_in_tile(rlat, rlon, ilevel) .and. fieldname == src_fieldname) then + + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call lltoxy(rlat, rlon, rx, ry, M) ! Assume source data on unstaggered grid + call select_domain(current_domain) + + get_point = interp_sequence(rx, ry, lvl, src_array, src_min_x, src_max_x, src_min_y, & + src_max_y, src_min_z, src_max_z, msgval, interp_type, interp_opts, 1) + + else + + call get_data_tile(rlat, rlon, ilevel, fieldname, & + src_fname, src_array, src_min_x, src_max_x, src_min_y, & + src_max_y, src_min_z, src_max_z, src_npts_bdr, & + istatus) + + src_fieldname = fieldname + src_level = ilevel + + if (istatus /= 0) then + get_point = msgval + return + end if + + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call lltoxy(rlat, rlon, rx, ry, M) ! Assume source data on unstaggered grid + call select_domain(current_domain) + + get_point = interp_sequence(rx, ry, lvl, src_array, src_min_x, src_max_x, src_min_y, & + src_max_y, src_min_z, src_max_z, msgval, interp_type, interp_opts, 1) + end if + + return + + end function get_point + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: have_processed_tile + ! + ! Purpose: This funtion returns .true. if the tile of data for + ! the specified field has already been processed, and .false. otherwise. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function have_processed_tile(xlat, xlon, fieldname, ilevel) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + real, intent(in) :: xlat, xlon + character (len=128), intent(in) :: fieldname + + ! Return value + logical :: have_processed_tile + + ! Local variables + integer :: istatus + character (len=256) :: test_fname + + call get_tile_fname(test_fname, xlat, xlon, ilevel, fieldname, istatus) + have_processed_tile = hash_search(h_table, test_fname) + + return + + end function have_processed_tile + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: is_point_in_tile + ! + ! Purpose: Returns whether the specified lat/lon could be processed + ! without incurring a file access. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function is_point_in_tile(xlat, xlon, ilevel) + + use llxy_module + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + real, intent(in) :: xlat, xlon + + ! Return value + logical :: is_point_in_tile + + ! Local variables + integer :: current_domain + real :: rlat, rlon, rx, ry + + rlat = xlat + if (xlon >= 180.) then + rlon = xlon - 360. + else + rlon = xlon + end if + + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call lltoxy(rlat, rlon, rx, ry, M) + call select_domain(current_domain) + + ! if (real(src_min_x+src_npts_bdr) <= rx .and. rx <= real(src_max_x-src_npts_bdr) .and. & + ! real(src_min_y+src_npts_bdr) <= ry .and. ry <= real(src_max_y-src_npts_bdr)) then +! BUG 2006-06-01 +! if (src_min_x+src_npts_bdr <= ceiling(rx) .and. floor(rx) <= src_max_x-src_npts_bdr .and. & +! src_min_y+src_npts_bdr <= ceiling(ry) .and. floor(ry) <= src_max_y-src_npts_bdr) then + if (src_min_x+src_npts_bdr <= floor(rx+0.5) .and. ceiling(rx-0.5) <= src_max_x-src_npts_bdr .and. & + src_min_y+src_npts_bdr <= floor(ry+0.5) .and. ceiling(ry-0.5) <= src_max_y-src_npts_bdr) then + is_point_in_tile = .true. + else + is_point_in_tile = .false. + end if + + return + + end function is_point_in_tile + +end module proc_point_module diff --git a/WPS/geogrid/src/process_tile_module.F b/WPS/geogrid/src/process_tile_module.F new file mode 100644 index 00000000..ccb718b7 --- /dev/null +++ b/WPS/geogrid/src/process_tile_module.F @@ -0,0 +1,2158 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Module: process_tile +! +! Description: +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module process_tile_module + + use module_debug + + + contains + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: process_tile + ! + ! Purpose: To process a tile, whose lower-left corner is at + ! (tile_i_min, tile_j_min) and whose upper-right corner is at + ! (tile_i_max, tile_j_max), of the model grid given by which_domain + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine process_tile(which_domain, grid_type, dynopt, & + dummy_start_dom_i, dummy_end_dom_i, & + dummy_start_dom_j, dummy_end_dom_j, & + dummy_start_patch_i, dummy_end_patch_i, & + dummy_start_patch_j, dummy_end_patch_j, & + extra_col, extra_row) + + use bitarray_module + use hash_module + use llxy_module + use misc_definitions_module + use output_module + use smooth_module + use source_data_module + + implicit none + + ! Arguments + integer, intent(in) :: which_domain, dynopt, & + dummy_start_dom_i, dummy_end_dom_i, dummy_start_dom_j, dummy_end_dom_j, & + dummy_start_patch_i, dummy_end_patch_i, dummy_start_patch_j, dummy_end_patch_j + logical, intent(in) :: extra_col, extra_row + character (len=1), intent(in) :: grid_type + + ! Local variables + integer :: i, j, k, kk, istatus, ifieldstatus, idomcatstatus, field_count + integer :: min_category, max_category, min_level, max_level, & + smth_opt, smth_passes, num_landmask_categories + integer :: start_dom_i, end_dom_i, start_dom_j, end_dom_j, end_dom_stag_i, end_dom_stag_j + integer :: start_patch_i, end_patch_i, start_patch_j, end_patch_j, end_patch_stag_i, end_patch_stag_j + integer :: start_mem_i, end_mem_i, start_mem_j, end_mem_j, end_mem_stag_i, end_mem_stag_j + integer :: sm1, em1, sm2, em2 + integer :: istagger + integer, dimension(MAX_LANDMASK_CATEGORIES) :: landmask_value + real :: sum, dominant, msg_fill_val, topo_flag_val, mass_flag, land_total, water_total + real, dimension(16) :: corner_lats, corner_lons + real, pointer, dimension(:,:) :: xlat_array, xlon_array, & + xlat_array_u, xlon_array_u, & + xlat_array_v, xlon_array_v, & + xlat_array_corner, xlon_array_corner, & + clat_array, clon_array, & + xlat_array_subgrid, xlon_array_subgrid, & + f_array, e_array, & + mapfac_array_m_x, mapfac_array_u_x, mapfac_array_v_x, & + mapfac_array_m_y, mapfac_array_u_y, mapfac_array_v_y, & + mapfac_array_x_subgrid, mapfac_array_y_subgrid, & + sina_array, cosa_array + real, pointer, dimension(:,:) :: xlat_ptr, xlon_ptr, mapfac_ptr_x, mapfac_ptr_y, landmask, dominant_field + real, pointer, dimension(:,:,:) :: field, slp_field + logical :: is_water_mask, only_save_dominant, halt_on_missing + character (len=19) :: datestr + character (len=128) :: fieldname, gradname, domname, landmask_name + character (len=256) :: temp_string + type (bitarray) :: processed_domain + type (hashtable) :: processed_fieldnames + character (len=128), dimension(2) :: dimnames + integer :: sub_x, sub_y + integer :: opt_status + + ! Probably not all of these nullify statements are needed... + nullify(xlat_array) + nullify(xlon_array) + nullify(xlat_array_u) + nullify(xlon_array_u) + nullify(xlat_array_v) + nullify(xlon_array_v) + nullify(xlat_array_corner) + nullify(xlon_array_corner) + nullify(clat_array) + nullify(clon_array) + nullify(xlat_array_subgrid) + nullify(xlon_array_subgrid) + nullify(f_array) + nullify(e_array) + nullify(mapfac_array_m_x) + nullify(mapfac_array_u_x) + nullify(mapfac_array_v_x) + nullify(mapfac_array_m_y) + nullify(mapfac_array_u_y) + nullify(mapfac_array_v_y) + nullify(mapfac_array_x_subgrid) + nullify(mapfac_array_y_subgrid) + nullify(sina_array) + nullify(cosa_array) + nullify(xlat_ptr) + nullify(xlon_ptr) + nullify(mapfac_ptr_x) + nullify(mapfac_ptr_y) + nullify(landmask) + nullify(dominant_field) + nullify(field) + nullify(slp_field) + + datestr = '0000-00-00_00:00:00' + field_count = 0 + mass_flag=1.0 + + ! The following pertains primarily to the C grid + ! Determine whether only (n-1)th rows/columns should be computed for variables + ! on staggered grid. In a distributed memory situation, not every tile should + ! have only (n-1)th rows/columns computed, or we end up with (n-k) + ! rows/columns when there are k patches in the y/x direction + if (extra_col) then + start_patch_i = dummy_start_patch_i ! The seemingly pointless renaming of start + end_patch_i = dummy_end_patch_i - 1 ! naming convention with modified end_patch variables, + end_patch_stag_i = dummy_end_patch_i ! variables is so that we can maintain consistent + ! which are marked as intent(in) + start_mem_i = start_patch_i - HALO_WIDTH + end_mem_i = end_patch_i + HALO_WIDTH + end_mem_stag_i = end_patch_stag_i + HALO_WIDTH + else + start_patch_i = dummy_start_patch_i + end_patch_i = dummy_end_patch_i + end_patch_stag_i = dummy_end_patch_i + + start_mem_i = start_patch_i - HALO_WIDTH + end_mem_i = end_patch_i + HALO_WIDTH + end_mem_stag_i = end_patch_stag_i + HALO_WIDTH + end if + + if (extra_row) then + start_patch_j = dummy_start_patch_j + end_patch_j = dummy_end_patch_j - 1 + end_patch_stag_j = dummy_end_patch_j + + start_mem_j = start_patch_j - HALO_WIDTH + end_mem_j = end_patch_j + HALO_WIDTH + end_mem_stag_j = end_patch_stag_j + HALO_WIDTH + else + start_patch_j = dummy_start_patch_j + end_patch_j = dummy_end_patch_j + end_patch_stag_j = dummy_end_patch_j + + start_mem_j = start_patch_j - HALO_WIDTH + end_mem_j = end_patch_j + HALO_WIDTH + end_mem_stag_j = end_patch_stag_j + HALO_WIDTH + end if + + start_dom_i = dummy_start_dom_i + if (grid_type == 'C') then + end_dom_i = dummy_end_dom_i - 1 + end_dom_stag_i = dummy_end_dom_i + else if (grid_type == 'E') then + end_dom_i = dummy_end_dom_i + end_dom_stag_i = dummy_end_dom_i + end if + + start_dom_j = dummy_start_dom_j + if (grid_type == 'C') then + end_dom_j = dummy_end_dom_j - 1 + end_dom_stag_j = dummy_end_dom_j + else if (grid_type == 'E') then + end_dom_j = dummy_end_dom_j + end_dom_stag_j = dummy_end_dom_j + end if + + ! Allocate arrays to hold all lat/lon fields; these will persist for the duration of + ! the process_tile routine + ! For C grid, we have M, U, and V points + ! For E grid, we have only M and V points + allocate(xlat_array(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + allocate(xlon_array(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + allocate(xlat_array_v(start_mem_i:end_mem_i, start_mem_j:end_mem_stag_j)) + allocate(xlon_array_v(start_mem_i:end_mem_i, start_mem_j:end_mem_stag_j)) + if (grid_type == 'C') then + allocate(xlat_array_u(start_mem_i:end_mem_stag_i, start_mem_j:end_mem_j)) + allocate(xlon_array_u(start_mem_i:end_mem_stag_i, start_mem_j:end_mem_j)) + allocate(clat_array(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + allocate(clon_array(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + allocate(xlat_array_corner(start_mem_i:end_mem_stag_i, start_mem_j:end_mem_stag_j)) + allocate(xlon_array_corner(start_mem_i:end_mem_stag_i, start_mem_j:end_mem_stag_j)) + end if + nullify(xlat_array_subgrid) + nullify(xlon_array_subgrid) + nullify(mapfac_array_x_subgrid) + nullify(mapfac_array_y_subgrid) + + ! Initialize hash table to track which fields have been processed + call hash_init(processed_fieldnames) + + ! + ! Calculate lat/lon for every point in the tile (XLAT and XLON) + ! The xlat_array and xlon_array arrays will be used in processing other fields + ! + call mprintf(.true.,STDOUT,' Processing XLAT and XLONG') + + if (grid_type == 'C') then + call get_lat_lon_fields(xlat_array, xlon_array, start_mem_i, & + start_mem_j, end_mem_i, end_mem_j, M) + call get_lat_lon_fields(xlat_array_v, xlon_array_v, start_mem_i, & + start_mem_j, end_mem_i, end_mem_stag_j, V) + call get_lat_lon_fields(xlat_array_u, xlon_array_u, start_mem_i, & + start_mem_j, end_mem_stag_i, end_mem_j, U) + call get_lat_lon_fields(xlat_array_corner, xlon_array_corner, start_mem_i, & + start_mem_j, end_mem_stag_i, end_mem_stag_j, CORNER) + call get_lat_lon_fields(clat_array, clon_array, start_mem_i, & + start_mem_j, end_mem_i, end_mem_j, M, comp_ll=.true.) + + corner_lats(1) = xlat_array(start_patch_i,start_patch_j) + corner_lats(2) = xlat_array(start_patch_i,end_patch_j) + corner_lats(3) = xlat_array(end_patch_i,end_patch_j) + corner_lats(4) = xlat_array(end_patch_i,start_patch_j) + + corner_lats(5) = xlat_array_u(start_patch_i,start_patch_j) + corner_lats(6) = xlat_array_u(start_patch_i,end_patch_j) + corner_lats(7) = xlat_array_u(end_patch_stag_i,end_patch_j) + corner_lats(8) = xlat_array_u(end_patch_stag_i,start_patch_j) + + corner_lats(9) = xlat_array_v(start_patch_i,start_patch_j) + corner_lats(10) = xlat_array_v(start_patch_i,end_patch_stag_j) + corner_lats(11) = xlat_array_v(end_patch_i,end_patch_stag_j) + corner_lats(12) = xlat_array_v(end_patch_i,start_patch_j) + + call xytoll(real(start_patch_i)-0.5, real(start_patch_j)-0.5, corner_lats(13), corner_lons(13), M) + call xytoll(real(start_patch_i)-0.5, real(end_patch_j)+0.5, corner_lats(14), corner_lons(14), M) + call xytoll(real(end_patch_i)+0.5, real(end_patch_j)+0.5, corner_lats(15), corner_lons(15), M) + call xytoll(real(end_patch_i)+0.5, real(start_patch_j)-0.5, corner_lats(16), corner_lons(16), M) + + corner_lons(1) = xlon_array(start_patch_i,start_patch_j) + corner_lons(2) = xlon_array(start_patch_i,end_patch_j) + corner_lons(3) = xlon_array(end_patch_i,end_patch_j) + corner_lons(4) = xlon_array(end_patch_i,start_patch_j) + + corner_lons(5) = xlon_array_u(start_patch_i,start_patch_j) + corner_lons(6) = xlon_array_u(start_patch_i,end_patch_j) + corner_lons(7) = xlon_array_u(end_patch_stag_i,end_patch_j) + corner_lons(8) = xlon_array_u(end_patch_stag_i,start_patch_j) + + corner_lons(9) = xlon_array_v(start_patch_i,start_patch_j) + corner_lons(10) = xlon_array_v(start_patch_i,end_patch_stag_j) + corner_lons(11) = xlon_array_v(end_patch_i,end_patch_stag_j) + corner_lons(12) = xlon_array_v(end_patch_i,start_patch_j) + + else if (grid_type == 'E') then + call get_lat_lon_fields(xlat_array, xlon_array, start_mem_i, & + start_mem_j, end_mem_i, end_mem_j, HH) + call get_lat_lon_fields(xlat_array_v, xlon_array_v, start_mem_i, & + start_mem_j, end_mem_i, end_mem_stag_j, VV) + + corner_lats(1) = xlat_array(start_patch_i,start_patch_j) + corner_lats(2) = xlat_array(start_patch_i,end_patch_j) + corner_lats(3) = xlat_array(end_patch_i,end_patch_j) + corner_lats(4) = xlat_array(end_patch_i,start_patch_j) + + corner_lats(5) = xlat_array_v(start_patch_i,start_patch_j) + corner_lats(6) = xlat_array_v(start_patch_i,end_patch_stag_j) + corner_lats(7) = xlat_array_v(end_patch_i,end_patch_stag_j) + corner_lats(8) = xlat_array_v(end_patch_i,start_patch_j) + + corner_lats(9) = 0.0 + corner_lats(10) = 0.0 + corner_lats(11) = 0.0 + corner_lats(12) = 0.0 + + corner_lats(13) = 0.0 + corner_lats(14) = 0.0 + corner_lats(15) = 0.0 + corner_lats(16) = 0.0 + + corner_lons(1) = xlon_array(start_patch_i,start_patch_j) + corner_lons(2) = xlon_array(start_patch_i,end_patch_j) + corner_lons(3) = xlon_array(end_patch_i,end_patch_j) + corner_lons(4) = xlon_array(end_patch_i,start_patch_j) + + corner_lons(5) = xlon_array_v(start_patch_i,start_patch_j) + corner_lons(6) = xlon_array_v(start_patch_i,end_patch_stag_j) + corner_lons(7) = xlon_array_v(end_patch_i,end_patch_stag_j) + corner_lons(8) = xlon_array_v(end_patch_i,start_patch_j) + + corner_lons(9) = 0.0 + corner_lons(10) = 0.0 + corner_lons(11) = 0.0 + corner_lons(12) = 0.0 + + corner_lons(13) = 0.0 + corner_lons(14) = 0.0 + corner_lons(15) = 0.0 + corner_lons(16) = 0.0 + + end if + + ! Initialize the output module now that we have the corner point lats/lons + call output_init(which_domain, 'OUTPUT FROM GEOGRID V3.9.1', '0000-00-00_00:00:00', grid_type, dynopt, & + corner_lats, corner_lons, & + start_dom_i, end_dom_i, start_dom_j, end_dom_j, & + start_patch_i, end_patch_i, start_patch_j, end_patch_j, & + start_mem_i, end_mem_i, start_mem_j, end_mem_j, & + extra_col, extra_row) + + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, & + 'XLAT_M', datestr, real_array = xlat_array) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, & + 'XLONG_M', datestr, real_array = xlon_array) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_stag_j, 1, 1, & + 'XLAT_V', datestr, real_array = xlat_array_v) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_stag_j, 1, 1, & + 'XLONG_V', datestr, real_array = xlon_array_v) + if (grid_type == 'C') then + call write_field(start_mem_i, end_mem_stag_i, start_mem_j, end_mem_j, 1, 1, & + 'XLAT_U', datestr, real_array = xlat_array_u) + call write_field(start_mem_i, end_mem_stag_i, start_mem_j, end_mem_j, 1, 1, & + 'XLONG_U', datestr, real_array = xlon_array_u) + call write_field(start_mem_i, end_mem_stag_i, start_mem_j, end_mem_stag_j, 1, 1, & + 'XLAT_C', datestr, real_array = xlat_array_corner) + call write_field(start_mem_i, end_mem_stag_i, start_mem_j, end_mem_stag_j, 1, 1, & + 'XLONG_C', datestr, real_array = xlon_array_corner) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, & + 'CLAT', datestr, real_array = clat_array) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, & + 'CLONG', datestr, real_array = clon_array) + + if (associated(clat_array)) deallocate(clat_array) + if (associated(clon_array)) deallocate(clon_array) + + end if + + + ! + ! Calculate map factor for current domain + ! + if (grid_type == 'C') then + call mprintf(.true.,STDOUT,' Processing MAPFAC') + + allocate(mapfac_array_m_x(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + allocate(mapfac_array_m_y(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + call get_map_factor(xlat_array, xlon_array, mapfac_array_m_x, mapfac_array_m_y, start_mem_i, & + start_mem_j, end_mem_i, end_mem_j) +! Global WRF uses map scale factors in X and Y directions, but "regular" WRF uses a single MSF +! on each staggering. In the case of regular WRF, we can assume that MAPFAC_MX = MAPFAC_MY = MAPFAC_M, +! and so we can simply write MAPFAC_MX as the MAPFAC_M field. Ultimately, when global WRF is +! merged into the WRF trunk, we will need only two map scale factor fields for each staggering, +! in the x and y directions, and these will be the same in the case of non-Cassini projections + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, 'MAPFAC_M', & + datestr, real_array = mapfac_array_m_x) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, 'MAPFAC_MX', & + datestr, real_array = mapfac_array_m_x) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, 'MAPFAC_MY', & + datestr, real_array = mapfac_array_m_y) + + allocate(mapfac_array_v_x(start_mem_i:end_mem_i, start_mem_j:end_mem_stag_j)) + allocate(mapfac_array_v_y(start_mem_i:end_mem_i, start_mem_j:end_mem_stag_j)) + call get_map_factor(xlat_array_v, xlon_array_v, mapfac_array_v_x, mapfac_array_v_y, start_mem_i, & + start_mem_j, end_mem_i, end_mem_stag_j) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_stag_j, 1, 1, 'MAPFAC_V', & + datestr, real_array = mapfac_array_v_x) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_stag_j, 1, 1, 'MAPFAC_VX', & + datestr, real_array = mapfac_array_v_x) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_stag_j, 1, 1, 'MAPFAC_VY', & + datestr, real_array = mapfac_array_v_y) + + allocate(mapfac_array_u_x(start_mem_i:end_mem_stag_i, start_mem_j:end_mem_j)) + allocate(mapfac_array_u_y(start_mem_i:end_mem_stag_i, start_mem_j:end_mem_j)) + call get_map_factor(xlat_array_u, xlon_array_u, mapfac_array_u_x, mapfac_array_u_y, start_mem_i, & + start_mem_j, end_mem_stag_i, end_mem_j) + call write_field(start_mem_i, end_mem_stag_i, start_mem_j, end_mem_j, 1, 1, 'MAPFAC_U', & + datestr, real_array = mapfac_array_u_x) + call write_field(start_mem_i, end_mem_stag_i, start_mem_j, end_mem_j, 1, 1, 'MAPFAC_UX', & + datestr, real_array = mapfac_array_u_x) + call write_field(start_mem_i, end_mem_stag_i, start_mem_j, end_mem_j, 1, 1, 'MAPFAC_UY', & + datestr, real_array = mapfac_array_u_y) + + end if + + + ! + ! Coriolis parameters (E and F) + ! + call mprintf(.true.,STDOUT,' Processing F and E') + + allocate(f_array(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + allocate(e_array(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + + call get_coriolis_parameters(xlat_array, f_array, e_array, & + start_mem_i, start_mem_j, end_mem_i, end_mem_j) + + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, 'E', & + datestr, real_array = e_array) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, 'F', & + datestr, real_array = f_array) + + if (associated(f_array)) deallocate(f_array) + if (associated(e_array)) deallocate(e_array) + + + ! + ! Rotation angle (SINALPHA and COSALPHA) + ! + if (grid_type == 'C') then + call mprintf(.true.,STDOUT,' Processing ROTANG') + + ! Mass-staggered points + allocate(sina_array(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + allocate(cosa_array(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + + call get_rotang(xlat_array, xlon_array, cosa_array, sina_array, & + start_mem_i, start_mem_j, end_mem_i, end_mem_j) + + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, 'SINALPHA', & + datestr, real_array = sina_array) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, 'COSALPHA', & + datestr, real_array = cosa_array) + + if (associated(sina_array)) deallocate(sina_array) + if (associated(cosa_array)) deallocate(cosa_array) + + ! U-staggered points + allocate(sina_array(start_mem_i:end_mem_stag_i, start_mem_j:end_mem_j)) + allocate(cosa_array(start_mem_i:end_mem_stag_i, start_mem_j:end_mem_j)) + + call get_rotang(xlat_array_u, xlon_array_u, cosa_array, sina_array, & + start_mem_i, start_mem_j, end_mem_stag_i, end_mem_j) + + call write_field(start_mem_i, end_mem_stag_i, start_mem_j, end_mem_j, 1, 1, 'SINALPHA_U', & + datestr, real_array = sina_array) + call write_field(start_mem_i, end_mem_stag_i, start_mem_j, end_mem_j, 1, 1, 'COSALPHA_U', & + datestr, real_array = cosa_array) + + if (associated(sina_array)) deallocate(sina_array) + if (associated(cosa_array)) deallocate(cosa_array) + + ! V-staggered points + allocate(sina_array(start_mem_i:end_mem_i, start_mem_j:end_mem_stag_j)) + allocate(cosa_array(start_mem_i:end_mem_i, start_mem_j:end_mem_stag_j)) + + call get_rotang(xlat_array_v, xlon_array_v, cosa_array, sina_array, & + start_mem_i, start_mem_j, end_mem_i, end_mem_stag_j) + + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_stag_j, 1, 1, 'SINALPHA_V', & + datestr, real_array = sina_array) + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_stag_j, 1, 1, 'COSALPHA_V', & + datestr, real_array = cosa_array) + + if (associated(sina_array)) deallocate(sina_array) + if (associated(cosa_array)) deallocate(cosa_array) + end if + + ! Every field up until now should probably just be processed regardless of what the user + ! has specified for fields to be processed. + ! Hereafter, we process user-specified fields + + ! + ! First process the field that we will derive a landmask from + ! + call get_landmask_field(geog_data_res(which_domain), landmask_name, is_water_mask, landmask_value, istatus) + + do kk=1,MAX_LANDMASK_CATEGORIES + if (landmask_value(kk) == INVALID) then + num_landmask_categories = kk-1 + exit + end if + end do + if (kk > MAX_LANDMASK_CATEGORIES) num_landmask_categories = MAX_LANDMASK_CATEGORIES + + if (istatus /= 0) then + call mprintf(.true.,WARN,'No field specified for landmask calculation. Will set landmask=1 at every grid point.') + + allocate(landmask(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + landmask = 1. + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, 'LANDMASK', & + datestr, landmask) + + else + + allocate(landmask(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + landmask = 1. + + call mprintf(.true.,STDOUT,' Processing %s', s1=trim(landmask_name)) + + call get_missing_fill_value(landmask_name, msg_fill_val, istatus) + if (istatus /= 0) msg_fill_val = NAN + + call get_halt_on_missing(landmask_name, halt_on_missing, istatus) + if (istatus /= 0) halt_on_missing = .false. + + ! Do we calculate a dominant category for this field? + call get_domcategory_name(landmask_name, domname, only_save_dominant, idomcatstatus) + + temp_string = ' ' + temp_string(1:128) = landmask_name + call hash_insert(processed_fieldnames, temp_string) + + call get_max_categories(landmask_name, min_category, max_category, istatus) + allocate(field(start_mem_i:end_mem_i, start_mem_j:end_mem_j, min_category:max_category)) + + if (.not. only_save_dominant) then + field_count = field_count + 1 + call mprintf(.true.,LOGFILE,'Processing field %i of %i (%s)', & + i1=field_count,i2=NUM_FIELDS-NUM_AUTOMATIC_FIELDS,s1=landmask_name) + else + field_count = field_count + 1 + call mprintf(.true.,LOGFILE,'Processing field %i of %i (%s)', & + i1=field_count,i2=NUM_FIELDS-NUM_AUTOMATIC_FIELDS,s1=domname) + end if + + if (grid_type == 'C') then + call calc_field(landmask_name, field, xlat_array, xlon_array, M, & + start_mem_i, end_mem_i, start_mem_j, end_mem_j, & + min_category, max_category, processed_domain, 1, landmask=landmask, sr_x=1, sr_y=1) + else if (grid_type == 'E') then + call calc_field(landmask_name, field, xlat_array, xlon_array, HH, & + start_mem_i, end_mem_i, start_mem_j, end_mem_j, & + min_category, max_category, processed_domain, 1, landmask=landmask, sr_x=1, sr_y=1) + end if + + ! If user wants to halt when a missing value is found in output field, check now + if (halt_on_missing) then + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + ! Only need to examine k=1 + if (field(i,j,1) == msg_fill_val) then + call mprintf(.true.,ERROR,' Missing value encountered in output field. Quitting.') + end if + end do + end do + end if + + ! Find fractions + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + sum = 0. + do k=min_category,max_category + sum = sum + field(i,j,k) + end do + if (sum > 0.0) then + do k=min_category,max_category + field(i,j,k) = field(i,j,k) / sum + end do + else + do k=min_category,max_category + field(i,j,k) = msg_fill_val + end do + end if + end do + end do + + if (is_water_mask) then + call mprintf(.true.,STDOUT,' Calculating landmask from %s ( WATER =', & + newline=.false.,s1=trim(landmask_name)) + else + call mprintf(.true.,STDOUT,' Calculating landmask from %s ( LAND =', & + newline=.false.,s1=trim(landmask_name)) + end if + do k = 1, num_landmask_categories + call mprintf(.true.,STDOUT,' %i',newline=.false.,i1=landmask_value(k)) + if (k == num_landmask_categories) call mprintf(.true.,STDOUT,')') + end do + + ! Calculate landmask + if (is_water_mask) then + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + water_total = -1. + do k=1,num_landmask_categories + if (landmask_value(k) >= min_category .and. landmask_value(k) <= max_category) then + if (field(i,j,landmask_value(k)) /= msg_fill_val) then + if (water_total < 0.) water_total = 0. + water_total = water_total + field(i,j,landmask_value(k)) + else + water_total = -1. + exit + end if + end if + end do + if (water_total >= 0.0) then + if (water_total < 0.50) then + landmask(i,j) = 1. + else + landmask(i,j) = 0. + end if + else + landmask(i,j) = -1. + end if + end do + end do + else + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + land_total = -1. + do k=1,num_landmask_categories + if (landmask_value(k) >= min_category .and. landmask_value(k) <= max_category) then + if (field(i,j,landmask_value(k)) /= msg_fill_val) then + if (land_total < 0.) land_total = 0. + land_total = land_total + field(i,j,landmask_value(k)) + else + land_total = -1. + exit + end if + end if + end do + if (land_total >= 0.0) then + if (land_total > 0.50) then + landmask(i,j) = 1. + else + landmask(i,j) = 0. + end if + else + landmask(i,j) = -1. + end if + end do + end do + end if + + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, 'LANDMASK', & + datestr, landmask) + + ! If we should only save the dominant category, then no need to write out fractional field + if (.not.only_save_dominant .or. (idomcatstatus /= 0)) then + + ! Finally, we may be asked to smooth the fractional field + call get_smooth_option(landmask_name, smth_opt, smth_passes, istatus) + if (istatus == 0) then + + if (grid_type == 'C') then + if (smth_opt == ONETWOONE) then + call one_two_one(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + start_mem_i, end_mem_i, & + start_mem_j, end_mem_j, & + min_category, max_category, & + smth_passes, msg_fill_val) + else if (smth_opt == SMTHDESMTH) then + call smth_desmth(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + start_mem_i, end_mem_i, & + start_mem_j, end_mem_j, & + min_category, max_category, & + smth_passes, msg_fill_val) + else if (smth_opt == SMTHDESMTH_SPECIAL) then + call smth_desmth_special(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + start_mem_i, end_mem_i, & + start_mem_j, end_mem_j, & + min_category, max_category, & + smth_passes, msg_fill_val) + end if + else if (grid_type == 'E') then + if (smth_opt == ONETWOONE) then + call one_two_one_egrid(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + start_mem_i, end_mem_i, & + start_mem_j, end_mem_j, & + min_category, max_category, & + smth_passes, msg_fill_val, 1.0) + else if (smth_opt == SMTHDESMTH) then + call smth_desmth_egrid(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + start_mem_i, end_mem_i, & + start_mem_j, end_mem_j, & + min_category, max_category, & + smth_passes, msg_fill_val, 1.0) + else if (smth_opt == SMTHDESMTH_SPECIAL) then + call mprintf(.true.,WARN,'smth-desmth_special is not currently implemented for NMM. '// & + 'No smoothing will be done.') + end if + end if + + end if + + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, & + min_category, max_category, trim(landmask_name), & + datestr, real_array=field) + end if + + if (idomcatstatus == 0) then + allocate(dominant_field(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) + + if (.not. only_save_dominant) then + field_count = field_count + 1 + call mprintf(.true.,LOGFILE,'Processing field %i of %i (%s)', & + i1=field_count,i2=NUM_FIELDS-NUM_AUTOMATIC_FIELDS,s1=domname) + end if + + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + if ((landmask(i,j) == 1. .and. is_water_mask) .or. & + (landmask(i,j) == 0. .and. .not.is_water_mask)) then + dominant = 0. + dominant_field(i,j) = real(min_category-1) + do k=min_category,max_category + do kk=1,num_landmask_categories + if (k == landmask_value(kk)) exit + end do + if (field(i,j,k) > dominant .and. kk > num_landmask_categories) then + dominant_field(i,j) = real(k) + dominant = field(i,j,k) + end if + end do + else + dominant = 0. + dominant_field(i,j) = real(min_category-1) + do k=min_category,max_category + do kk=1,num_landmask_categories + if (field(i,j,k) > dominant .and. k == landmask_value(kk)) then + dominant_field(i,j) = real(k) + dominant = field(i,j,k) + end if + end do + end do + end if + end do + end do + + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, trim(domname), & + datestr, dominant_field) + + deallocate(dominant_field) + end if + + deallocate(field) + end if + + ! + ! Now process all other fields specified by the user + ! + call reset_next_field() + ifieldstatus = 0 + do while (ifieldstatus == 0) + call get_next_fieldname(fieldname, ifieldstatus) + + ! There is another field in the GEOGRID.TBL file + if (ifieldstatus == 0) then + temp_string(1:128) = fieldname + + call get_source_opt_status(fieldname, 0, opt_status) + + ! If this field is still to be processed + if (.not. hash_search(processed_fieldnames, temp_string) .and. opt_status == 0) then + + call hash_insert(processed_fieldnames, temp_string) + call mprintf(.true.,STDOUT,' Processing %s', s1=trim(fieldname)) + + call get_output_stagger(fieldname, istagger, istatus) + dimnames(:) = 'null' + call get_subgrid_dim_name(which_domain, fieldname, dimnames, & + sub_x, sub_y, istatus) + + if (istagger == M .or. (sub_x > 1) .or. (sub_y > 1)) then + sm1 = start_mem_i + em1 = end_mem_i + sm2 = start_mem_j + em2 = end_mem_j + xlat_ptr => xlat_array + xlon_ptr => xlon_array + mapfac_ptr_x => mapfac_array_m_x + mapfac_ptr_y => mapfac_array_m_y + else if (istagger == U) then ! In the case that extra_cols = .false. + sm1 = start_mem_i ! we should have that end_mem_stag is + em1 = end_mem_stag_i ! the same as end_mem, so we do not need + sm2 = start_mem_j ! to check extra_cols or extra rows here + em2 = end_mem_j + xlat_ptr => xlat_array_u + xlon_ptr => xlon_array_u + mapfac_ptr_x => mapfac_array_u_x + mapfac_ptr_y => mapfac_array_u_y + else if (istagger == V) then + sm1 = start_mem_i + em1 = end_mem_i + sm2 = start_mem_j + em2 = end_mem_stag_j + xlat_ptr => xlat_array_v + xlon_ptr => xlon_array_v + mapfac_ptr_x => mapfac_array_v_x + mapfac_ptr_y => mapfac_array_v_y + else if (istagger == HH) then ! E grid + sm1 = start_mem_i + em1 = end_mem_i + sm2 = start_mem_j + em2 = end_mem_j + xlat_ptr => xlat_array + xlon_ptr => xlon_array + mapfac_ptr_x => mapfac_array_m_x + mapfac_ptr_y => mapfac_array_m_y + else if (istagger == VV) then ! E grid + sm1 = start_mem_i + em1 = end_mem_i + sm2 = start_mem_j + em2 = end_mem_stag_j + xlat_ptr => xlat_array_v + xlon_ptr => xlon_array_v + mapfac_ptr_x => mapfac_array_v_x + mapfac_ptr_y => mapfac_array_v_y + end if + + if (sub_x > 1) then + sm1 = (start_mem_i - 1)*sub_x + 1 + if (extra_col) then + em1 = (end_mem_i + 1)*sub_x + else + em1 = (end_mem_i )*sub_x + end if + end if + if (sub_y > 1)then + sm2 = (start_mem_j - 1)*sub_y + 1 + if (extra_row) then + em2 = (end_mem_j + 1)*sub_y + else + em2 = (end_mem_j )*sub_y + end if + end if + +!BUG: This should probably be moved up to where other lat/lon fields are calculated, and we should +! just determine whether we will have any subgrids or not at that point + if ((sub_x > 1) .or. (sub_y > 1)) then +! if (associated(xlat_array_subgrid)) deallocate(xlat_array_subgrid) +! if (associated(xlon_array_subgrid)) deallocate(xlon_array_subgrid) +! if (associated(mapfac_array_x_subgrid)) deallocate(mapfac_array_x_subgrid) +! if (associated(mapfac_array_y_subgrid)) deallocate(mapfac_array_y_subgrid) + allocate(xlat_array_subgrid(sm1:em1,sm2:em2)) + allocate(xlon_array_subgrid(sm1:em1,sm2:em2)) + allocate(mapfac_array_x_subgrid(sm1:em1,sm2:em2)) + allocate(mapfac_array_y_subgrid(sm1:em1,sm2:em2)) + call get_lat_lon_fields(xlat_array_subgrid, xlon_array_subgrid, & + sm1, sm2, em1, em2, M, sub_x=sub_x, sub_y=sub_y) + xlat_ptr => xlat_array_subgrid + xlon_ptr => xlon_array_subgrid + call get_map_factor(xlat_ptr, xlon_ptr, mapfac_array_x_subgrid, & + mapfac_array_y_subgrid, sm1, sm2, em1, em2) + mapfac_ptr_x => mapfac_array_x_subgrid + mapfac_ptr_y => mapfac_array_y_subgrid + end if + + call get_missing_fill_value(fieldname, msg_fill_val, istatus) + if (istatus /= 0) msg_fill_val = NAN + + call get_halt_on_missing(fieldname, halt_on_missing, istatus) + if (istatus /= 0) halt_on_missing = .false. + + ! Destination field type is CONTINUOUS + if (iget_fieldtype(fieldname,istatus) == CONTINUOUS) then + call get_max_levels(fieldname, min_level, max_level, istatus) + allocate(field(sm1:em1, sm2:em2, min_level:max_level)) + + field_count = field_count + 1 + call mprintf(.true.,LOGFILE,'Processing field %i of %i (%s)', & + i1=field_count,i2=NUM_FIELDS-NUM_AUTOMATIC_FIELDS,s1=fieldname) + + if ((sub_x > 1) .or. (sub_y > 1)) then + call calc_field(fieldname, field, xlat_ptr, xlon_ptr, istagger, & + sm1, em1, sm2, em2, min_level, max_level, & + processed_domain, 1, sr_x=sub_x, sr_y=sub_y) + else + call calc_field(fieldname, field, xlat_ptr, xlon_ptr, istagger, & + sm1, em1, sm2, em2, min_level, max_level, & + processed_domain, 1, landmask=landmask, sr_x=sub_x, sr_y=sub_y) + end if + + ! If user wants to halt when a missing value is found in output field, check now + if (halt_on_missing) then + do i=sm1, em1 + do j=sm2, em2 + ! Only need to examine k=1 + if (field(i,j,1) == msg_fill_val) then + call mprintf(.true.,ERROR,' Missing value encountered in output field. Quitting.') + end if + end do + end do + end if + + ! We may be asked to smooth the fractional field + call get_smooth_option(fieldname, smth_opt, smth_passes, istatus) + if (istatus == 0) then + + if (grid_type == 'C') then + if (smth_opt == ONETWOONE) then + call one_two_one(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + sm1, em1, & + sm2, em2, & + min_level, max_level, & + smth_passes, msg_fill_val) + else if (smth_opt == SMTHDESMTH) then + call smth_desmth(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + sm1, em1, & + sm2, em2, & + min_level, max_level, & + smth_passes, msg_fill_val) + else if (smth_opt == SMTHDESMTH_SPECIAL) then + call smth_desmth_special(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + sm1, em1, & + sm2, em2, & + min_level, max_level, & + smth_passes, msg_fill_val) + end if + + else if (grid_type == 'E') then + + if (trim(fieldname) == 'HGT_M' ) then + topo_flag_val=1.0 + mass_flag=1.0 + else if (trim(fieldname) == 'HGT_V') then + topo_flag_val=1.0 + mass_flag=0.0 + else + topo_flag_val=0.0 + end if + + if (smth_opt == ONETWOONE) then + call one_two_one_egrid(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + sm1, em1, & + sm2, em2, & + min_level, max_level, & + smth_passes, topo_flag_val, mass_flag) + else if (smth_opt == SMTHDESMTH) then + call smth_desmth_egrid(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + sm1, em1, & + sm2, em2, & + min_level, max_level, & + smth_passes, topo_flag_val, mass_flag) + else if (smth_opt == SMTHDESMTH_SPECIAL) then + call mprintf(.true.,WARN,'smth-desmth_special is not currently implemented for NMM. '// & + 'No smoothing will be done.') + end if + + end if + + end if + + call write_field(sm1, em1, sm2, em2, & + min_level, max_level, trim(fieldname), datestr, real_array=field) + + ! Do we calculate directional derivatives from this field? + call get_dfdx_name(fieldname, gradname, istatus) + if (istatus == 0) then + allocate(slp_field(sm1:em1,sm2:em2,min_level:max_level)) + + field_count = field_count + 1 + call mprintf(.true.,LOGFILE,'Processing field %i of %i (%s)', & + i1=field_count,i2=NUM_FIELDS-NUM_AUTOMATIC_FIELDS,s1=gradname) + + if (grid_type == 'C') then + call calc_dfdx(field, slp_field, sm1, sm2, min_level, em1, em2, max_level, mapfac_ptr_x) + else if (grid_type == 'E') then + call calc_dfdx(field, slp_field, sm1, sm2, min_level, em1, em2, max_level) + end if + call write_field(sm1, em1, sm2, em2, & + min_level, max_level, trim(gradname), datestr, real_array=slp_field) + deallocate(slp_field) + end if + call get_dfdy_name(fieldname, gradname, istatus) + if (istatus == 0) then + allocate(slp_field(sm1:em1,sm2:em2,min_level:max_level)) + + field_count = field_count + 1 + call mprintf(.true.,LOGFILE,'Processing field %i of %i (%s)', & + i1=field_count,i2=NUM_FIELDS-NUM_AUTOMATIC_FIELDS,s1=gradname) + + if (grid_type == 'C') then + call calc_dfdy(field, slp_field, sm1, sm2, min_level, em1, em2, max_level, mapfac_ptr_y) + else if (grid_type == 'E') then + call calc_dfdy(field, slp_field, sm1, sm2, min_level, em1, em2, max_level) + end if + call write_field(sm1, em1, sm2, em2, & + min_level, max_level, trim(gradname), datestr, real_array=slp_field) + deallocate(slp_field) + end if + + deallocate(field) + + ! Destination field type is CATEGORICAL + else + call get_max_categories(fieldname, min_category, max_category, istatus) + allocate(field(sm1:em1, sm2:em2, min_category:max_category)) + + ! Do we calculate a dominant category for this field? + call get_domcategory_name(fieldname, domname, only_save_dominant, idomcatstatus) + + if (.not. only_save_dominant) then + field_count = field_count + 1 + call mprintf(.true.,LOGFILE,'Processing field %i of %i (%s)', & + i1=field_count,i2=NUM_FIELDS-NUM_AUTOMATIC_FIELDS,s1=fieldname) + else + field_count = field_count + 1 + call mprintf(.true.,LOGFILE,'Processing field %i of %i (%s)', & + i1=field_count,i2=NUM_FIELDS-NUM_AUTOMATIC_FIELDS,s1=domname) + end if + + if ((sub_x > 1) .or. (sub_y > 1)) then + call calc_field(fieldname, field, xlat_ptr, xlon_ptr, istagger, & + sm1, em1, sm2, em2, min_category, max_category, & + processed_domain, 1, sr_x=sub_x, sr_y=sub_y) + else + call calc_field(fieldname, field, xlat_ptr, xlon_ptr, istagger, & + sm1, em1, sm2, em2, min_category, max_category, & + processed_domain, 1, landmask=landmask, sr_x=sub_x, sr_y=sub_y) + end if + + ! If user wants to halt when a missing value is found in output field, check now + if (halt_on_missing) then + do i=sm1, em1 + do j=sm2, em2 + ! Only need to examine k=1 + if (field(i,j,1) == msg_fill_val) then + call mprintf(.true.,ERROR,' Missing value encountered in output field. Quitting.') + end if + end do + end do + end if + + ! Find fractions + do i=sm1, em1 + do j=sm2, em2 + sum = 0. + do k=min_category,max_category + sum = sum + field(i,j,k) + end do + if (sum > 0.0) then + do k=min_category,max_category + field(i,j,k) = field(i,j,k) / sum + end do + else + do k=min_category,max_category + field(i,j,k) = msg_fill_val + end do + end if + end do + end do + + ! If we should only save the dominant category, then no need to write out fractional field + if (.not.only_save_dominant .or. (idomcatstatus /= 0)) then + + ! Finally, we may be asked to smooth the fractional field + call get_smooth_option(fieldname, smth_opt, smth_passes, istatus) + if (istatus == 0) then + if (grid_type == 'C') then + if (smth_opt == ONETWOONE) then + call one_two_one(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + sm1, em1, & + sm2, em2, & + min_category, max_category, & + smth_passes, msg_fill_val) + else if (smth_opt == SMTHDESMTH) then + call smth_desmth(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + sm1, em1, & + sm2, em2, & + min_category, max_category, & + smth_passes, msg_fill_val) + else if (smth_opt == SMTHDESMTH_SPECIAL) then + call smth_desmth_special(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + sm1, em1, & + sm2, em2, & + min_category, max_category, & + smth_passes, msg_fill_val) + end if + else if (grid_type == 'E') then + if (smth_opt == ONETWOONE) then + call one_two_one_egrid(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + sm1, em1, & + sm2, em2, & + min_category, max_category, & + smth_passes, msg_fill_val, 1.0) + else if (smth_opt == SMTHDESMTH) then + call smth_desmth_egrid(field, & + start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + sm1, em1, & + sm2, em2, & + min_category, max_category, & + smth_passes, msg_fill_val, 1.0) + else if (smth_opt == SMTHDESMTH_SPECIAL) then + call mprintf(.true.,WARN,'smth-desmth_special is not currently implemented for NMM. '// & + 'No smoothing will be done.') + end if + end if + end if + + call write_field(sm1, em1, sm2, em2, & + min_category, max_category, trim(fieldname), datestr, real_array=field) + end if + + if (idomcatstatus == 0) then + call mprintf(.true.,STDOUT,' Processing %s', s1=trim(domname)) + allocate(dominant_field(sm1:em1, sm2:em2)) + + if (.not. only_save_dominant) then + field_count = field_count + 1 + call mprintf(.true.,LOGFILE,'Processing field %i of %i (%s)', & + i1=field_count,i2=NUM_FIELDS-NUM_AUTOMATIC_FIELDS,s1=domname) + end if + + do i=sm1, em1 + do j=sm2, em2 + dominant = 0. + dominant_field(i,j) = real(min_category-1) + do k=min_category,max_category + if (field(i,j,k) > dominant .and. field(i,j,k) /= msg_fill_val) then + dominant_field(i,j) = real(k) + dominant = field(i,j,k) + ! else + ! dominant_field(i,j) = nint(msg_fill_val) +! Maybe we should put an else clause here to set the category equal to the missing fill value? +! BUG: The problem here seems to be that, when we set a fraction equal to the missing fill value +! above, if the last fractional index we process here has been filled, we think that the dominant +! category should be set to the missing fill value. Perhaps we could do some check to only +! assign the msg_fill_val if no other valid category has been assigned? But this may still not +! work if the missing fill value is something like 0.5. Somehow use bitarrays, perhaps, to remember +! which points are missing and which just happen to have the missing fill value? + end if + end do + if (dominant_field(i,j) == real(min_category-1)) dominant_field(i,j) = msg_fill_val + end do + end do + call write_field(sm1, em1, sm2, em2, 1, 1, & + trim(domname), datestr, dominant_field) + deallocate(dominant_field) + end if + + deallocate(field) + + if ((sub_x > 1) .or. (sub_y > 1)) then + if (associated(xlat_array_subgrid)) deallocate(xlat_array_subgrid) + if (associated(xlon_array_subgrid)) deallocate(xlon_array_subgrid) + if (associated(mapfac_array_x_subgrid)) deallocate(mapfac_array_x_subgrid) + if (associated(mapfac_array_y_subgrid)) deallocate(mapfac_array_y_subgrid) + end if + + end if + + end if + end if + + end do + + ! Close output + call output_close() + + call hash_destroy(processed_fieldnames) + + ! Free up memory + if (associated(xlat_array)) deallocate(xlat_array) + if (associated(xlon_array)) deallocate(xlon_array) + if (grid_type == 'C') then + if (associated(xlat_array_u)) deallocate(xlat_array_u) + if (associated(xlon_array_u)) deallocate(xlon_array_u) + if (associated(xlat_array_corner)) deallocate(xlat_array_corner) + if (associated(xlon_array_corner)) deallocate(xlon_array_corner) + if (associated(mapfac_array_u_x)) deallocate(mapfac_array_u_x) + if (associated(mapfac_array_u_y)) deallocate(mapfac_array_u_y) + end if + if (associated(xlat_array_v)) deallocate(xlat_array_v) + if (associated(xlon_array_v)) deallocate(xlon_array_v) + if (associated(mapfac_array_m_x)) deallocate(mapfac_array_m_x) + if (associated(mapfac_array_m_y)) deallocate(mapfac_array_m_y) + if (associated(mapfac_array_v_x)) deallocate(mapfac_array_v_x) + if (associated(mapfac_array_v_y)) deallocate(mapfac_array_v_y) + if (associated(landmask)) deallocate(landmask) + if (associated(xlat_array_subgrid)) deallocate(xlat_array_subgrid) + if (associated(xlon_array_subgrid)) deallocate(xlon_array_subgrid) + if (associated(mapfac_array_x_subgrid)) deallocate(mapfac_array_x_subgrid) + if (associated(mapfac_array_y_subgrid)) deallocate(mapfac_array_y_subgrid) + + nullify(xlat_ptr) + nullify(xlon_ptr) + + end subroutine process_tile + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: calc_field + ! + ! Purpose: This routine fills in the "field" array with interpolated source + ! data. When multiple resolutions of source data are available, an appropriate + ! resolution is chosen automatically. The specified field may either be a + ! continuous field or a categorical field. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive subroutine calc_field(fieldname, field, xlat_array, xlon_array, istagger, & + start_i, end_i, start_j, end_j, start_k, end_k, & + processed_domain, ilevel, landmask, sr_x, sr_y) + + use bitarray_module + use interp_module + use llxy_module + use misc_definitions_module + use proc_point_module + use queue_module + use source_data_module + + implicit none + + ! Arguments + integer, intent(in) :: start_i, end_i, start_j, end_j, start_k, end_k, ilevel, istagger + real, dimension(start_i:end_i, start_j:end_j), intent(in) :: xlat_array, xlon_array + real, dimension(start_i:end_i, start_j:end_j, start_k:end_k), intent(inout) :: field + real, dimension(start_i:end_i, start_j:end_j), intent(in), optional :: landmask + integer, intent(in), optional :: sr_x, sr_y + character (len=128), intent(in) :: fieldname + type (bitarray), intent(inout) :: processed_domain + + ! Local variables + integer :: start_src_k, end_src_k + integer :: i, j, k, ix, iy, itype + integer :: user_iproj, istatus + integer :: opt_status + real :: mask_val + real :: temp + real :: scale_factor + real :: msg_val, msg_fill_val, threshold, src_dx, src_dy, dom_dx, dom_dy + real :: user_stand_lon, user_truelat1, user_truelat2, user_dxkm, user_dykm, & + user_known_x, user_known_y, user_known_lat, user_known_lon + real, pointer, dimension(:,:,:) :: data_count + integer, pointer, dimension(:) :: interp_type + integer, pointer, dimension(:) :: interp_opts + character (len=128) :: interp_string + type (bitarray) :: bit_domain, level_domain + type (queue) :: point_queue, tile_queue + type (q_data) :: current_pt + + nullify(data_count) + nullify(interp_type) + nullify(interp_opts) + + ! If this is the first trip through this routine, we need to allocate the bit array that + ! will persist through all recursive calls, tracking which grid points have been assigned + ! a value. + if (ilevel == 1) call bitarray_create(processed_domain, end_i-start_i+1, end_j-start_j+1) + + ! Find out if this "priority level" (given by ilevel) exists + call check_priority_level(fieldname, ilevel, istatus) + + ! A bad status indicates that that no data for priority level ilevel is available, and thus, that + ! no further levels will be specified. We are done processing for this level. + if (istatus /= 0) then + if (ilevel == 1) call bitarray_destroy(processed_domain) + return + end if + + ! Before proceeding with processing for this level, though, process for the next highest priority level + ! of source data + call calc_field(fieldname, field, xlat_array, xlon_array, istagger, start_i, end_i, & + start_j, end_j, start_k, end_k, processed_domain, ilevel+1, landmask, sr_x, sr_y) + + ! At this point, all levels of source data with higher priority have been processed, and we can assign + ! values to all grid points that have not already been given values from higher-priority data + + call get_source_opt_status(fieldname, ilevel, opt_status) + if (opt_status == 0) then + + ! Find out the projection of the data for this "priority level" (given by ilevel) + call get_data_projection(fieldname, user_iproj, user_stand_lon, user_truelat1, user_truelat2, & + user_dxkm, user_dykm, user_known_x, user_known_y, user_known_lat, & + user_known_lon, ilevel, istatus) + + ! A good status indicates that there is data for this priority level, so we store the projection + ! of that data on a stack. The projection will be on the top of the stack (and hence will be + ! the "active" projection) once all higher-priority levels have been processed + call push_source_projection(user_iproj, user_stand_lon, user_truelat1, user_truelat2, & + user_dxkm, user_dykm, user_dykm, user_dxkm, user_known_x, user_known_y, & + user_known_lat, user_known_lon) + + ! Initialize point processing module + call proc_point_init() + + ! Initialize queues + call q_init(point_queue) + call q_init(tile_queue) + + ! Determine whether we will be processing categorical data or continuous data + itype = iget_source_fieldtype(fieldname, ilevel, istatus) + call get_interp_option(fieldname, ilevel, interp_string, istatus) + interp_type => interp_array_from_string(interp_string) + interp_opts => interp_options_from_string(interp_string) + + ! Also, check whether we will be using the cell averaging interpolator for continuous fields + if (index(interp_string,'average_gcell') /= 0 .and. itype == CONTINUOUS) then + call get_gcell_threshold(interp_string, threshold, istatus) + if (istatus == 0) then + call get_source_resolution(fieldname, ilevel, src_dx, src_dy, istatus) + if (istatus == 0) then + call get_domain_resolution(dom_dx, dom_dy) + if (gridtype == 'C') then + if (threshold*max(src_dx,src_dy)*111. <= max(dom_dx,dom_dy)/1000.) then + itype = SP_CONTINUOUS + allocate(data_count(start_i:end_i,start_j:end_j,start_k:end_k)) + data_count = 0. + end if + else if (gridtype == 'E') then + if (max(src_dx,src_dy) >= threshold*max(dom_dx,dom_dy)) then + itype = SP_CONTINUOUS + allocate(data_count(start_i:end_i,start_j:end_j,start_k:end_k)) + data_count = 0. + end if + end if + end if + end if + end if + + call get_missing_value(fieldname, ilevel, msg_val, istatus) + if (istatus /= 0) msg_val = NAN + call get_missing_fill_value(fieldname, msg_fill_val, istatus) + if (istatus /= 0) msg_fill_val = NAN + + call get_masked_value(fieldname, ilevel, mask_val, istatus) + if (istatus /= 0) mask_val = -1. + + if (itype == CONTINUOUS .or. itype == SP_CONTINUOUS) then + call get_source_levels(fieldname, ilevel, start_src_k, end_src_k, istatus) + if (istatus /= 0) return + end if + + ! Initialize bitarray used to track which points have been visited and assigned values while + ! processing *this* priority level of data + call bitarray_create(bit_domain, end_i-start_i+1, end_j-start_j+1) + call bitarray_create(level_domain, end_i-start_i+1, end_j-start_j+1) + + ! Begin by placing a point in the tile_queue + current_pt%lat = xlat_array(start_i,start_j) + current_pt%lon = xlon_array(start_i,start_j) + current_pt%x = start_i + current_pt%y = start_j + call q_insert(tile_queue, current_pt) + + ! While there are still grid points in tiles that have not yet been processed + do while (q_isdata(tile_queue)) + + ! Take a point from the outer queue and place it in the point_queue for processing + current_pt = q_remove(tile_queue) + + ! If this level of data is categorical (i.e., is given as an array of category indices), + ! then first try to process the entire tile in one call to accum_categorical. Any grid + ! points that are not given values by accum_categorical and that lie within the current + ! tile of source data are individually assigned values in the inner loop + if (itype == CATEGORICAL) then + + ! Have we already visited this point? If so, this tile has already been processed by + ! accum_categorical. + if (.not. bitarray_test(bit_domain, current_pt%x-start_i+1, current_pt%y-start_j+1)) then + call q_insert(point_queue, current_pt) + if (.not. have_processed_tile(current_pt%lat, current_pt%lon, fieldname, ilevel)) then + call accum_categorical(current_pt%lat, current_pt%lon, istagger, field, & + start_i, end_i, start_j, end_j, start_k, end_k, & + fieldname, processed_domain, level_domain, & + ilevel, msg_val, mask_val, sr_x, sr_y) +! BUG: Where do we mask out those points that are on land/water when masked=land/water is set? + end if + call bitarray_set(bit_domain, current_pt%x-start_i+1, current_pt%y-start_j+1) + end if + + else if (itype == SP_CONTINUOUS) then + + ! Have we already visited this point? If so, this tile has already been processed by + ! accum_continuous. + if (.not. bitarray_test(bit_domain, current_pt%x-start_i+1, current_pt%y-start_j+1)) then + call q_insert(point_queue, current_pt) + if (.not. have_processed_tile(current_pt%lat, current_pt%lon, fieldname, ilevel)) then + call accum_continuous(current_pt%lat, current_pt%lon, istagger, field, data_count, & + start_i, end_i, start_j, end_j, start_k, end_k, & + fieldname, processed_domain, level_domain, & + ilevel, msg_val, mask_val, sr_x, sr_y) +! BUG: Where do we mask out those points that are on land/water when masked=land/water is set? + end if + call bitarray_set(bit_domain, current_pt%x-start_i+1, current_pt%y-start_j+1) + end if + + else if (itype == CONTINUOUS) then + + ! Have we already visited this point? If so, the tile containing this point has already been + ! processed in the inner loop. + if (.not. bitarray_test(bit_domain, current_pt%x-start_i+1, current_pt%y-start_j+1)) then + call q_insert(point_queue, current_pt) + call bitarray_set(bit_domain, current_pt%x-start_i+1, current_pt%y-start_j+1) + end if + + end if + + ! This inner loop, where all grid points contained in the current source tile are processed + do while (q_isdata(point_queue)) + current_pt = q_remove(point_queue) + ix = current_pt%x + iy = current_pt%y + + ! Process the current point + if (itype == CONTINUOUS .or. itype == SP_CONTINUOUS) then + + ! Have we already assigned this point a value from this priority level? + if (.not. bitarray_test(level_domain, ix-start_i+1, iy-start_j+1)) then + + ! If the point was already assigned a value from a higher-priority level, no + ! need to assign a new value + if (bitarray_test(processed_domain, ix-start_i+1, iy-start_j+1)) then + call bitarray_set(level_domain, ix-start_i+1, iy-start_j+1) + + ! Otherwise, need to assign values from this level of source data if we can + else + if (present(landmask) .and. (istagger == M .or. istagger == HH)) then + if (landmask(ix,iy) /= mask_val) then + do k=start_src_k,end_src_k + temp = get_point(current_pt%lat, current_pt%lon, k, & + fieldname, ilevel, interp_type, interp_opts, msg_val) + if (temp /= msg_val) then + field(ix, iy, k) = temp + call bitarray_set(level_domain, ix-start_i+1, iy-start_j+1) + if (itype == SP_CONTINUOUS) data_count(ix, iy, k) = 1.0 + else + field(ix, iy, k) = msg_fill_val + end if + end do + else + do k=start_k,end_k + field(ix,iy,k) = msg_fill_val + end do + end if + else + do k=start_src_k,end_src_k + temp = get_point(current_pt%lat, current_pt%lon, k, & + fieldname, ilevel, interp_type, interp_opts, msg_val) + if (temp /= msg_val) then + field(ix, iy, k) = temp + call bitarray_set(level_domain, ix-start_i+1, iy-start_j+1) + if (itype == SP_CONTINUOUS) data_count(ix, iy, k) = 1.0 + else + field(ix, iy, k) = msg_fill_val + end if + end do + end if + end if + end if + + else if (itype == CATEGORICAL) then + + ! Have we already assigned this point a value from this priority level? + if (.not.bitarray_test(level_domain, ix-start_i+1, iy-start_j+1)) then + + ! If the point was already assigned a value from a higher-priority level, no + ! need to assign a new value + if (bitarray_test(processed_domain, ix-start_i+1, iy-start_j+1)) then + call bitarray_set(level_domain, ix-start_i+1, iy-start_j+1) + + ! Otherwise, the point was apparently not given a value when accum_categorical + ! was called for the current tile, and we need to assign values from this + ! level of source data if we can + else + if (present(landmask) .and. (istagger == M .or. istagger == HH)) then + if (landmask(ix,iy) /= mask_val) then + temp = get_point(current_pt%lat, current_pt%lon, 1, & + fieldname, ilevel, interp_type, interp_opts, msg_val) + + do k=start_k,end_k + field(ix,iy,k) = 0. + end do + + if (temp /= msg_val) then + if (int(temp) >= start_k .and. int(temp) <= end_k) then + field(ix, iy, int(temp)) = field(ix, iy, int(temp)) + 1. + else + call mprintf(.true.,WARN,' Attempted to assign an invalid category '// & + '%i to grid point (%i, %i)', i1=int(temp), i2=ix, i3=iy) + end if + call bitarray_set(level_domain, ix-start_i+1, iy-start_j+1) + end if + + else + do k=start_k,end_k + field(ix,iy,k) = 0. + end do + end if + else + temp = get_point(current_pt%lat, current_pt%lon, 1, & + fieldname, ilevel, interp_type, interp_opts, msg_val) + + do k=start_k,end_k + field(ix,iy,k) = 0. + end do + + if (temp /= msg_val) then + if (int(temp) >= start_k .and. int(temp) <= end_k) then + field(ix, iy, int(temp)) = field(ix, iy, int(temp)) + 1. + else + call mprintf(.true.,WARN,' Attempted to assign an invalid category '// & + '%i to grid point (%i, %i)', i1=int(temp), i2=ix, i3=iy) + end if + call bitarray_set(level_domain, ix-start_i+1, iy-start_j+1) + end if + end if + end if + end if + + end if + + ! Scan neighboring points, adding them to the appropriate queue based on whether they + ! are in the current tile or not + if (iy > start_j) then + if (ix > start_i) then + + ! Neighbor with relative position (-1,-1) + call process_neighbor(ix-1, iy-1, bit_domain, point_queue, tile_queue, & + xlat_array, xlon_array, start_i, end_i, start_j, end_j, ilevel) + end if + + ! Neighbor with relative position (0,-1) + call process_neighbor(ix, iy-1, bit_domain, point_queue, tile_queue, & + xlat_array, xlon_array, start_i, end_i, start_j, end_j, ilevel) + + if (ix < end_i) then + + ! Neighbor with relative position (+1,-1) + call process_neighbor(ix+1, iy-1, bit_domain, point_queue, tile_queue, & + xlat_array, xlon_array, start_i, end_i, start_j, end_j, ilevel) + end if + end if + + if (ix > start_i) then + + ! Neighbor with relative position (-1,0) + call process_neighbor(ix-1, iy, bit_domain, point_queue, tile_queue, & + xlat_array, xlon_array, start_i, end_i, start_j, end_j, ilevel) + end if + + if (ix < end_i) then + + ! Neighbor with relative position (+1,0) + call process_neighbor(ix+1, iy, bit_domain, point_queue, tile_queue, & + xlat_array, xlon_array, start_i, end_i, start_j, end_j, ilevel) + end if + + if (iy < end_j) then + if (ix > start_i) then + + ! Neighbor with relative position (-1,+1) + call process_neighbor(ix-1, iy+1, bit_domain, point_queue, tile_queue, & + xlat_array, xlon_array, start_i, end_i, start_j, end_j, ilevel) + end if + + ! Neighbor with relative position (0,+1) + call process_neighbor(ix, iy+1, bit_domain, point_queue, tile_queue, & + xlat_array, xlon_array, start_i, end_i, start_j, end_j, ilevel) + if (ix < end_i) then + + ! Neighbor with relative position (+1,+1) + call process_neighbor(ix+1, iy+1, bit_domain, point_queue, tile_queue, & + xlat_array, xlon_array, start_i, end_i, start_j, end_j, ilevel) + end if + end if + + end do + + end do + + if (itype == SP_CONTINUOUS) then + itype = CONTINUOUS + if (present(landmask) .and. (istagger == M .or. istagger == HH)) then + do j=start_j,end_j + do i=start_i,end_i + if (landmask(i,j) /= mask_val) then + do k=start_k,end_k + if (data_count(i,j,k) > 0.) then + field(i,j,k) = field(i,j,k) / data_count(i,j,k) + else + if (.not.bitarray_test(processed_domain, i-start_i+1, j-start_j+1)) then + field(i,j,k) = msg_fill_val + end if + end if + end do + else + if (.not.bitarray_test(processed_domain, i-start_i+1, j-start_j+1)) then + do k=start_k,end_k + field(i,j,k) = msg_fill_val + end do + end if + end if + end do + end do + else + do k=start_k,end_k + do j=start_j,end_j + do i=start_i,end_i + if (data_count(i,j,k) > 0.) then + field(i,j,k) = field(i,j,k) / data_count(i,j,k) + else + if (.not.bitarray_test(processed_domain, i-start_i+1, j-start_j+1)) then + field(i,j,k) = msg_fill_val + end if + end if + end do + end do + end do + end if + deallocate(data_count) + + else if (itype == CATEGORICAL) then + if (present(landmask) .and. (istagger == M .or. istagger == HH)) then + do j=start_j,end_j + do i=start_i,end_i + if (landmask(i,j) == mask_val) then + do k=start_k,end_k + field(i,j,k) = 0. + end do + end if + end do + end do + end if + end if + + deallocate(interp_type) + deallocate(interp_opts) + + + ! We may need to scale this field by a constant + call get_field_scale_factor(fieldname, ilevel, scale_factor, istatus) + if (istatus == 0) then + do i=start_i, end_i + do j=start_j, end_j + if (bitarray_test(level_domain,i-start_i+1,j-start_j+1) .and. & + .not. bitarray_test(processed_domain,i-start_i+1,j-start_j+1)) then + do k=start_k,end_k + if (field(i,j,k) /= msg_fill_val) then + field(i,j,k) = field(i,j,k) * scale_factor + end if + end do + end if + end do + end do + end if + + + ! Now add the points that were assigned values at this priority level to the complete array + ! of points that have been assigned values + call bitarray_merge(processed_domain, level_domain) + + call bitarray_destroy(bit_domain) + call bitarray_destroy(level_domain) + call q_destroy(point_queue) + call q_destroy(tile_queue) + call proc_point_shutdown() + + ! Remove the projection of the current level of source data from the stack, thus "activating" + ! the projection of the next highest level + call pop_source_projection() + + else + call mprintf(.true.,STDOUT,' Important note: could not open input dataset for priority level %i, '// & + 'but this level is optional.', i1=ilevel) + call mprintf(.true.,LOGFILE,' Important note: could not open input dataset for priority level %i, '// & + 'but this level is optional.', i1=ilevel) + end if + + ! If this is the last level of the recursion, we can also deallocate processed_domain + if (ilevel == 1) call bitarray_destroy(processed_domain) + + end subroutine calc_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_lat_lon_fields + ! + ! Purpose: To calculate the latitude and longitude for every gridpoint in the + ! tile of the model domain. The caller may specify that the grid for which + ! values are computed is staggered or unstaggered using the "stagger" + ! argument. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_lat_lon_fields(xlat_arr, xlon_arr, start_mem_i, & + start_mem_j, end_mem_i, end_mem_j, stagger, comp_ll, & + sub_x, sub_y) + + use llxy_module + use misc_definitions_module + + implicit none + + ! Arguments + integer, intent(in) :: start_mem_i, start_mem_j, end_mem_i, & + end_mem_j, stagger + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j), intent(out) :: xlat_arr, xlon_arr + logical, optional, intent(in) :: comp_ll + integer, optional, intent(in) :: sub_x, sub_y + + ! Local variables + integer :: i, j + real :: rx, ry + + rx = 1.0 + ry = 1.0 + if (present(sub_x)) rx = real(sub_x) + if (present(sub_y)) ry = real(sub_y) + + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + call xytoll(real(i-1)/rx+1.0, real(j-1)/ry+1.0, & + xlat_arr(i,j), xlon_arr(i,j), stagger, comp_ll=comp_ll) + end do + end do + + end subroutine get_lat_lon_fields + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_map_factor + ! + ! Purpose: Given the latitude field, this routine calculates map factors for + ! the grid points of the specified domain. For different grids (e.g., C grid, + ! E grid), the latitude array should provide the latitudes of the points for + ! which map factors are to be calculated. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_map_factor(xlat_arr, xlon_arr, mapfac_arr_x, mapfac_arr_y, & + start_mem_i, start_mem_j, end_mem_i, end_mem_j) + + use constants_module + use gridinfo_module + use misc_definitions_module + use map_utils + + implicit none + + ! Arguments + integer, intent(in) :: start_mem_i, start_mem_j, end_mem_i, end_mem_j + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j), intent(in) :: xlat_arr, xlon_arr + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j), intent(out) :: mapfac_arr_x + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j), intent(out) :: mapfac_arr_y + + ! Local variables + integer :: i, j + real :: n, colat, colat0, colat1, colat2, comp_lat, comp_lon + + ! + ! Equations for map factor given in Principles of Meteorological Analysis, + ! Walter J. Saucier, pp. 32-33 + ! + + ! Lambert conformal projection + if (iproj_type == PROJ_LC) then + if (truelat1 /= truelat2) then + colat1 = rad_per_deg*(90.0 - truelat1) + colat2 = rad_per_deg*(90.0 - truelat2) + n = (log(sin(colat1)) - log(sin(colat2))) & + / (log(tan(colat1/2.0)) - log(tan(colat2/2.0))) + + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + colat = rad_per_deg*(90.0 - xlat_arr(i,j)) + mapfac_arr_x(i,j) = sin(colat2)/sin(colat)*(tan(colat/2.0)/tan(colat2/2.0))**n + mapfac_arr_y(i,j) = mapfac_arr_x(i,j) + end do + end do + + else + colat0 = rad_per_deg*(90.0 - truelat1) + + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + colat = rad_per_deg*(90.0 - xlat_arr(i,j)) + mapfac_arr_x(i,j) = sin(colat0)/sin(colat)*(tan(colat/2.0)/tan(colat0/2.0))**cos(colat0) + mapfac_arr_y(i,j) = mapfac_arr_x(i,j) + end do + end do + + end if + + ! Polar stereographic projection + else if (iproj_type == PROJ_PS) then + + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + mapfac_arr_x(i,j) = (1.0 + sin(rad_per_deg*abs(truelat1)))/(1.0 + sin(rad_per_deg*sign(1.,truelat1)*xlat_arr(i,j))) + mapfac_arr_y(i,j) = mapfac_arr_x(i,j) + end do + end do + + ! Mercator projection + else if (iproj_type == PROJ_MERC) then + colat0 = rad_per_deg*(90.0 - truelat1) + + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + colat = rad_per_deg*(90.0 - xlat_arr(i,j)) + mapfac_arr_x(i,j) = sin(colat0) / sin(colat) + mapfac_arr_y(i,j) = mapfac_arr_x(i,j) + end do + end do + + ! Global cylindrical projection + else if (iproj_type == PROJ_CYL) then + + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + if (abs(xlat_arr(i,j)) == 90.0) then + mapfac_arr_x(i,j) = 0. ! MSF actually becomes infinite at poles, but + ! the values should never be used there; by + ! setting to 0, we hope to induce a "divide + ! by zero" error if they are + else + mapfac_arr_x(i,j) = 1.0 / cos(xlat_arr(i,j)*rad_per_deg) + end if + mapfac_arr_y(i,j) = 1.0 + end do + end do + + ! Rotated global cylindrical projection + else if (iproj_type == PROJ_CASSINI) then + + if (abs(pole_lat) == 90.) then + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + if (abs(xlat_arr(i,j)) >= 90.0) then + mapfac_arr_x(i,j) = 0. ! MSF actually becomes infinite at poles, but + ! the values should never be used there; by + ! setting to 0, we hope to induce a "divide + ! by zero" error if they are + else + mapfac_arr_x(i,j) = 1.0 / cos(xlat_arr(i,j)*rad_per_deg) + end if + mapfac_arr_y(i,j) = 1.0 + end do + end do + else + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + call rotate_coords(xlat_arr(i,j),xlon_arr(i,j), & + comp_lat, comp_lon, & + pole_lat, pole_lon, stand_lon, & + -1) + if (abs(comp_lat) >= 90.0) then + mapfac_arr_x(i,j) = 0. ! MSF actually becomes infinite at poles, but + ! the values should never be used there; by + ! setting to 0, we hope to induce a "divide + ! by zero" error if they are + else + mapfac_arr_x(i,j) = 1.0 / cos(comp_lat*rad_per_deg) + end if + mapfac_arr_y(i,j) = 1.0 + end do + end do + end if + + else if (iproj_type == PROJ_ROTLL) then + + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + mapfac_arr_x(i,j) = 1.0 + mapfac_arr_y(i,j) = 1.0 + end do + end do + + end if + + end subroutine get_map_factor + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_coriolis_parameters + ! + ! Purpose: To calculate the Coriolis parameters f and e for every gridpoint in + ! the tile of the model domain + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_coriolis_parameters(xlat_arr, f, e, & + start_mem_i, start_mem_j, end_mem_i, end_mem_j) + + use constants_module + + implicit none + + ! Arguments + integer, intent(in) :: start_mem_i, start_mem_j, end_mem_i, end_mem_j + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j), intent(in) :: xlat_arr + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j), intent(out) :: f, e + + ! Local variables + integer :: i, j + + do i=start_mem_i, end_mem_i + do j=start_mem_j, end_mem_j + + f(i,j) = 2.0*OMEGA_E*sin(rad_per_deg*xlat_arr(i,j)) + e(i,j) = 2.0*OMEGA_E*cos(rad_per_deg*xlat_arr(i,j)) + + end do + end do + + end subroutine get_coriolis_parameters + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_rotang + ! + ! Purpose: To calculate the sine and cosine of rotation angle. + ! + ! NOTES: The formulas used in this routine come from those in the + ! vecrot_rotlat() routine of the original WRF SI. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_rotang(xlat_arr, xlon_arr, cosa, sina, & + start_mem_i, start_mem_j, end_mem_i, end_mem_j) + + use constants_module + use gridinfo_module + + implicit none + + ! Arguments + integer, intent(in) :: start_mem_i, start_mem_j, end_mem_i, end_mem_j + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j), intent(in) :: xlat_arr, xlon_arr + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j), intent(out) :: cosa, sina + + ! Local variables + integer :: i, j + real :: alpha, d_lon + + do i=start_mem_i, end_mem_i + do j=start_mem_j+1, end_mem_j-1 + d_lon = xlon_arr(i,j+1)-xlon_arr(i,j-1) + if (d_lon > 180.) then + d_lon = d_lon - 360. + else if (d_lon < -180.) then + d_lon = d_lon + 360. + end if + + alpha = atan2(-cos(xlat_arr(i,j)*RAD_PER_DEG) * (d_lon*RAD_PER_DEG), & + ((xlat_arr(i,j+1)-xlat_arr(i,j-1))*RAD_PER_DEG)) + sina(i,j) = sin(alpha) + cosa(i,j) = cos(alpha) + end do + end do + + do i=start_mem_i, end_mem_i + d_lon = xlon_arr(i,start_mem_j+1)-xlon_arr(i,start_mem_j) + if (d_lon > 180.) then + d_lon = d_lon - 360. + else if (d_lon < -180.) then + d_lon = d_lon + 360. + end if + + alpha = atan2(-cos(xlat_arr(i,start_mem_j)*RAD_PER_DEG) * (d_lon*RAD_PER_DEG), & + ((xlat_arr(i,start_mem_j+1)-xlat_arr(i,start_mem_j))*RAD_PER_DEG)) + sina(i,start_mem_j) = sin(alpha) + cosa(i,start_mem_j) = cos(alpha) + end do + + do i=start_mem_i, end_mem_i + d_lon = xlon_arr(i,end_mem_j)-xlon_arr(i,end_mem_j-1) + if (d_lon > 180.) then + d_lon = d_lon - 360. + else if (d_lon < -180.) then + d_lon = d_lon + 360. + end if + + alpha = atan2(-cos(xlat_arr(i,end_mem_j)*RAD_PER_DEG) * (d_lon*RAD_PER_DEG), & + ((xlat_arr(i,end_mem_j)-xlat_arr(i,end_mem_j-1))*RAD_PER_DEG)) + sina(i,end_mem_j) = sin(alpha) + cosa(i,end_mem_j) = cos(alpha) + end do + + end subroutine get_rotang + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: process_neighbor + ! + ! Purpose: This routine, give the x/y location of a point, determines whether + ! the point has already been processed, and if not, which processing queue + ! the point should be placed in. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine process_neighbor(ix, iy, bit_domain, point_queue, tile_queue, & + xlat_array, xlon_array, & + start_i, end_i, start_j, end_j, ilevel) + + use bitarray_module + use misc_definitions_module + use proc_point_module + use queue_module + + implicit none + + ! Arguments + integer, intent(in) :: ix, iy, start_i, end_i, start_j, end_j, ilevel + real, dimension(start_i:end_i, start_j:end_j), intent(in) :: xlat_array, xlon_array + type (bitarray), intent(inout) :: bit_domain + type (queue), intent(inout) :: point_queue, tile_queue + + ! Local variables + type (q_data) :: process_pt + logical :: is_in_tile + + ! If the point has already been visited, no need to do anything more. + if (.not. bitarray_test(bit_domain, ix-start_i+1, iy-start_j+1)) then + + ! Create a queue item for the current point + process_pt%lat = xlat_array(ix,iy) + process_pt%lon = xlon_array(ix,iy) + process_pt%x = ix + process_pt%y = iy + + is_in_tile = is_point_in_tile(process_pt%lat, process_pt%lon, ilevel) + + ! If the point is in the current tile, add it to the list of points + ! to be processed in the inner loop + if (is_in_tile) then + call q_insert(point_queue, process_pt) + call bitarray_set(bit_domain, ix-start_i+1, iy-start_j+1) + + ! Otherwise, we will process this point later. Add it to the list for + ! the outer loop. + else + call q_insert(tile_queue, process_pt) + end if + + end if + + end subroutine process_neighbor + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: calc_dfdy + ! + ! Purpose: This routine calculates df/dy for the field in src_arr, and places + ! the result in dst_array. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine calc_dfdy(src_arr, dst_arr, start_mem_i, start_mem_j, start_mem_k, & + end_mem_i, end_mem_j, end_mem_k, mapfac) + + ! Modules + use gridinfo_module + + implicit none + + ! Arguments + integer, intent(in) :: start_mem_i, start_mem_j, start_mem_k, end_mem_i, end_mem_j, end_mem_k + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j,start_mem_k:end_mem_k), intent(in) :: src_arr + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j,start_mem_k:end_mem_k), intent(out) :: dst_arr + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j), intent(in), optional :: mapfac + + ! Local variables + integer :: i, j, k + + if (present(mapfac)) then + do k=start_mem_k,end_mem_k + do i=start_mem_i, end_mem_i + do j=start_mem_j+1, end_mem_j-1 + dst_arr(i,j,k) = (src_arr(i,j+1,k) - src_arr(i,j-1,k))/(2.*dykm*mapfac(i,j)) + end do + end do + + do i=start_mem_i, end_mem_i + dst_arr(i,start_mem_j,k) = (src_arr(i,start_mem_j+1,k) - src_arr(i,start_mem_j,k))/(dykm*mapfac(i,j)) + end do + + do i=start_mem_i, end_mem_i + dst_arr(i,end_mem_j,k) = (src_arr(i,end_mem_j,k) - src_arr(i,end_mem_j-1,k))/(dykm*mapfac(i,j)) + end do + end do + else + do k=start_mem_k,end_mem_k + do i=start_mem_i, end_mem_i + do j=start_mem_j+1, end_mem_j-1 + dst_arr(i,j,k) = (src_arr(i,j+1,k) - src_arr(i,j-1,k))/(2.*dykm) + end do + end do + + do i=start_mem_i, end_mem_i + dst_arr(i,start_mem_j,k) = (src_arr(i,start_mem_j+1,k) - src_arr(i,start_mem_j,k))/(dykm) + end do + + do i=start_mem_i, end_mem_i + dst_arr(i,end_mem_j,k) = (src_arr(i,end_mem_j,k) - src_arr(i,end_mem_j-1,k))/(dykm) + end do + end do + end if + + end subroutine calc_dfdy + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: calc_dfdx + ! + ! Purpose: This routine calculates df/dx for the field in src_arr, and places + ! the result in dst_array. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine calc_dfdx(src_arr, dst_arr, start_mem_i, start_mem_j, & + start_mem_k, end_mem_i, end_mem_j, end_mem_k, mapfac) + + ! Modules + use gridinfo_module + + implicit none + + ! Arguments + integer, intent(in) :: start_mem_i, start_mem_j, start_mem_k, end_mem_i, end_mem_j, end_mem_k + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j, start_mem_k:end_mem_k), intent(in) :: src_arr + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j, start_mem_k:end_mem_k), intent(out) :: dst_arr + real, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j), intent(in), optional :: mapfac + + ! Local variables + integer :: i, j, k + + if (present(mapfac)) then + do k=start_mem_k, end_mem_k + do i=start_mem_i+1, end_mem_i-1 + do j=start_mem_j, end_mem_j + dst_arr(i,j,k) = (src_arr(i+1,j,k) - src_arr(i-1,j,k))/(2.*dxkm*mapfac(i,j)) + end do + end do + + do j=start_mem_j, end_mem_j + dst_arr(start_mem_i,j,k) = (src_arr(start_mem_i+1,j,k) - src_arr(start_mem_i,j,k))/(dxkm*mapfac(i,j)) + end do + + do j=start_mem_j, end_mem_j + dst_arr(end_mem_i,j,k) = (src_arr(end_mem_i,j,k) - src_arr(end_mem_i-1,j,k))/(dxkm*mapfac(i,j)) + end do + end do + else + do k=start_mem_k, end_mem_k + do i=start_mem_i+1, end_mem_i-1 + do j=start_mem_j, end_mem_j + dst_arr(i,j,k) = (src_arr(i+1,j,k) - src_arr(i-1,j,k))/(2.*dxkm) + end do + end do + + do j=start_mem_j, end_mem_j + dst_arr(start_mem_i,j,k) = (src_arr(start_mem_i+1,j,k) - src_arr(start_mem_i,j,k))/(dxkm) + end do + + do j=start_mem_j, end_mem_j + dst_arr(end_mem_i,j,k) = (src_arr(end_mem_i,j,k) - src_arr(end_mem_i-1,j,k))/(dxkm) + end do + end do + end if + + end subroutine calc_dfdx + +end module process_tile_module diff --git a/WPS/geogrid/src/queue_module.F b/WPS/geogrid/src/queue_module.F new file mode 100644 index 00000000..790d91e5 --- /dev/null +++ b/WPS/geogrid/src/queue_module.F @@ -0,0 +1,237 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Module: queue_module +! +! Description: This module implements a queue of user-defined data types and +! a set of routines related to the maintenance and manipulation of the queue. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +module queue_module + + use module_debug + + type q_data ! The user-defined datatype to store in the queue +#ifdef _GEOGRID + real :: lat, lon + integer :: x, y + integer :: depth ! Used by 'search' interpolation method +#endif +#ifdef _METGRID + integer :: x, y + integer :: sr_x, sr_y + character (len=128) :: units, description, stagger + integer :: depth ! Used by 'search' interpolation method +#endif + end type q_data + + type q_item ! Wrapper for item to be stored in the queue + type (q_data) :: data + type (q_item), pointer :: next + end type q_item + + type queue ! The queue object, defined by a head and tail pointer + type (q_item), pointer :: head, tail + integer :: length + end type queue + + + contains + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: q_init + ! + ! Purpose: To initialize a queue + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine q_init(q) + + implicit none + + ! Arguments + type (queue), intent(inout) :: q + + nullify(q%head) + nullify(q%tail) + q%length = 0 + + end subroutine q_init + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: q_insert + ! + ! Purpose: To insert an item in the tail of the queue + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine q_insert(q, qitem) + + implicit none + + ! Arguments + type (queue), intent(inout) :: q + type (q_data), intent(in) :: qitem + + ! Local variables + type (q_item), pointer :: newitem + + allocate(newitem) + newitem%data = qitem + nullify(newitem%next) + if (.not.associated(q%tail)) then + q%head=>newitem + q%tail=>newitem + else + q%tail%next=>newitem + q%tail=>newitem + end if + + q%length = q%length + 1 + + end subroutine q_insert + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: q_isdata + ! + ! Purpose: This function returns FALSE if the queue is empty and TRUE otherwise + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function q_isdata(q) + + implicit none + + ! Arguments + type (queue), intent(in) :: q + + ! Local variables + logical :: q_isdata + + q_isdata = .false. + + if (associated(q%head) .and. (q%length >= 1)) then + q_isdata = .true. + end if + + end function q_isdata + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: q_peek + ! + ! Purpose: To return the item in the head of the queue, without + ! actually removing the item + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function q_peek(q) + + implicit none + + ! Arguments + type (queue), intent(in) :: q + + ! Local variables + type (q_data) :: q_peek + + if (associated(q%head)) then + q_peek = q%head%data + else + call mprintf(.true.,ERROR,'q_peek(): Trying to peek at an empty queue') + end if + + end function q_peek + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: q_length + ! + ! Purpose: To return the number of items currently in the queue + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function q_length(q) + + implicit none + + ! Arguments + type (queue), intent(in) :: q + + ! Local variables + ! type (q_item), pointer :: cursor + integer :: q_length + + q_length = q%length + + ! USE THE FOLLOWING TO COUNT THE LENGTH BY ACTUALLY TRAVERSING THE LINKED LIST + ! REPRESENTATION OF THE QUEUE + ! if (associated(q%head)) then + ! q_length = q_length + 1 + ! cursor=>q%head + ! do while(associated(cursor%next)) + ! cursor=>cursor%next + ! q_length = q_length + 1 + ! end do + ! end if + + end function q_length + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: q_remove + ! + ! Purpose: To return the item stored at the head of the queue + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function q_remove(q) + + implicit none + + ! Arguments + type (queue), intent(inout) :: q + + ! Local variables + type (q_data) :: q_remove + type (q_item), pointer :: cursor + + if (associated(q%head)) then + if (associated(q%head%next)) then + cursor=>q%head%next + q_remove = q%head%data + deallocate(q%head) + q%head=>cursor + else + q_remove = q%head%data + deallocate(q%head) + nullify(q%head) + nullify(q%tail) + end if + q%length = q%length - 1 + else + call mprintf(.true.,ERROR,'q_remove(): Trying to remove from an empty queue') + end if + + end function q_remove + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: q_destroy + ! + ! Purpose: To free all memory allocated by the queue, thus destroying any + ! items that have not been removed + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine q_destroy(q) + + implicit none + + ! Arguments + type (queue), intent(inout) :: q + + ! Local variables + type (q_item), pointer :: cursor + + q%length = 0 + + if (associated(q%head)) then + do while(associated(q%head%next)) + cursor=>q%head + q%head=>q%head%next + deallocate(cursor) + end do + deallocate(q%head) + end if + + end subroutine q_destroy + +end module queue_module diff --git a/WPS/geogrid/src/read_geogrid.c b/WPS/geogrid/src/read_geogrid.c new file mode 100644 index 00000000..219f8e99 --- /dev/null +++ b/WPS/geogrid/src/read_geogrid.c @@ -0,0 +1,140 @@ +/* File: read_geogrid.c + + Sample subroutine to read an array from the geogrid binary format. + + Notes: Depending on the compiler and compiler flags, the name of + the read_geogrid() routine may need to be adjusted with respect + to the number of trailing underscores when calling from Fortran. + + Michael G. Duda, NCAR/MMM +*/ + +#include +#include +#include + +#ifdef _UNDERSCORE +#define read_geogrid read_geogrid_ +#endif +#ifdef _DOUBLEUNDERSCORE +#define read_geogrid read_geogrid__ +#endif + +#define BIG_ENDIAN 0 +#define LITTLE_ENDIAN 1 + +int read_geogrid( + char * fname, /* The name of the file to read from */ + int * len, /* The length of the filename */ + float * rarray, /* The array to be filled */ + int * nx, /* x-dimension of the array */ + int * ny, /* y-dimension of the array */ + int * nz, /* z-dimension of the array */ + int * isigned, /* 0=unsigned data, 1=signed data */ + int * endian, /* 0=big endian, 1=little endian */ + float * scalefactor, /* value to multiply array elements by before truncation to integers */ + int * wordsize, /* number of bytes to use for each array element */ + int * status) +{ + size_t i, cnt, narray; + int ival; + int A2, B2; + int A3, B3, C3; + int A4, B4, C4, D4; + unsigned char * c; + char local_fname[1024]; + FILE * bfile; + + *status = 0; + + narray = (size_t)(*nx) * (size_t)(*ny) * (size_t)(*nz); + + /* Make a null-terminated local copy of the filename */ + strncpy(local_fname,fname,*len); + local_fname[*len]='\0'; + + /* Attempt to open file for reading */ + if (!(bfile = fopen(local_fname,"rb"))) + { + *status = 1; + return 1; + } + + /* Allocate memory to hold bytes from file and read data */ + c = (unsigned char *)malloc(sizeof(unsigned char)*(*wordsize) * narray); + cnt = fread((void *)c, sizeof(unsigned char), narray*(size_t)(*wordsize), bfile); + + fclose(bfile); + + if (cnt == 0) + { + *status = 1; + return 1; + } + + /* + Set up byte offsets for each wordsize depending on byte order. + A, B, C, D give the offsets of the LSB through MSB (i.e., for + word ABCD, A=MSB, D=LSB) in the array from the beginning of a word + */ + if (*endian == BIG_ENDIAN) { + A2 = 0; B2 = 1; + A3 = 0; B3 = 1; C3 = 2; + A4 = 0; B4 = 1; C4 = 2; D4 = 3; + } + else { + B2 = 0; A2 = 1; + C3 = 0; B3 = 1; A3 = 2; + D4 = 0; C4 = 1; B4 = 2; A4 = 3; + } + + /* Convert words from native byte order */ + switch(*wordsize) { + case 1: + for(i=0; i (1 << 7))) ival -= (1 << 8); + rarray[i] = (float)ival; + } + break; + + case 2: + for(i=0; i (1 << 15))) ival -= (1 << 16); + rarray[i] = (float)ival; + } + break; + + case 3: + for(i=0; i (1 << 23))) ival -= (1 << 24); + rarray[i] = (float)ival; + } + break; + + case 4: + for(i=0; i (1 << 31))) ival -= (1 << 32); + rarray[i] = (float)ival; + } + break; + } + + free(c); + + /* Scale real-valued array by scalefactor */ + if (*scalefactor != 1.0) + { + for (i=0; i= 0.) then + array(ix,iy,iz) = orig_array(ix,iy,iz) + end if + end do + end do + end do + + deallocate(scratch) + deallocate(orig_array) + + end subroutine smth_desmth_special + + + ! + ! Smoothing routines for E-grid, contributed by Matthew Pyle + ! + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: one_two_one_egrid + ! + ! Purpose: Apply the 1-2-1 smoother from the MM5 program TERRAIN + ! (found in smth121.F) to array. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine one_two_one_egrid(array, start_dom_x, end_dom_x, start_dom_y, end_dom_y, & + start_x, end_x, start_y, end_y, start_z, end_z, npass, msgval, hflag) + + implicit none + + ! Arguments + integer, intent(in) :: start_dom_x, start_dom_y, start_x, start_y, start_z + integer, intent(in) :: end_dom_x, end_dom_y, end_x, end_y, end_z + integer, intent(in) :: npass + real, intent(in) :: msgval, hflag + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), intent(inout) :: array + + ! Local variables + integer :: ix, iy, iz, ipass + real, pointer, dimension(:,:,:) :: scratch + integer, dimension(start_y:end_y) :: ihe, ihw, istart + + allocate(scratch(start_x:end_x, start_y:end_y, start_z:end_z)) + + do iy=start_y,end_y + if (hflag == 1.0) then + ihe(iy) = abs(mod(iy+1,2)) + ihw(iy) = ihe(iy)-1 + else + ! assign ive,ivw equivs to ihe,ihw + ihe(iy) = abs(mod(iy,2)) + ihw(iy) = ihe(iy)-1 + end if + end do + + do iy=start_y,end_y + if (hflag == 1.0) then + if (mod(iy,2) == 0) then + istart(iy) = start_x + else + istart(iy) = start_x+1 + end if + else ! v points + if (abs(mod(iy,2)) == 1) then + istart(iy) = start_x + else + istart(iy) = start_x+1 + end if + end if + end do + + do ipass=1,npass + + do iy=start_y,end_y + do ix=start_x,end_x + scratch(ix,iy,1) = array(ix,iy,1) ! for points used in 2nd computation but not defined in 1st computation + end do + end do + + ! SW-NE direction + do iy=start_y+1,end_y-1 + do ix=istart(iy),end_x-1 + do iz=start_z,end_z + if ( (msgval == 1.0 .and. array(ix,iy,iz) /= 0.) .or. msgval /= 1.0) then + scratch(ix,iy,iz) = 0.50*array(ix,iy,iz)+ & + 0.25*(array(ix+ihw(iy),iy-1,iz)+array(ix+ihe(iy),iy+1,iz)) + end if + end do + end do + end do + + ! NW-SE direction + do iy=start_y+1,end_y-1 + do ix=istart(iy),end_x-1 + do iz=start_z,end_z + if ( (msgval == 1.0 .and. array(ix,iy,iz) /= 0.) .or. msgval /= 1.0) then + array(ix,iy,iz) = 0.50*scratch(ix,iy,iz)+ & + 0.25*(scratch(ix+ihe(iy),iy-1,iz)+scratch(ix+ihw(iy),iy+1,iz)) + end if + end do + end do + end do + + call exchange_halo_r(array, & + start_x, end_x, start_y, end_y, start_z, end_z, & + start_dom_x, end_dom_x, start_dom_y, end_dom_y, start_z, end_z) + + end do + + deallocate(scratch) + + end subroutine one_two_one_egrid + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: smth_desmth_egrid_old + ! + ! Purpose: Apply the smoother-desmoother for E grid + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine smth_desmth_egrid_old(array, start_dom_x, end_dom_x, start_dom_y, end_dom_y, & + start_x, end_x, start_y, end_y, start_z, end_z, npass, msgval, hflag) + + implicit none + + ! Arguments + integer, intent(in) :: start_dom_x, start_dom_y, start_x, start_y, start_z + integer, intent(in) :: end_dom_x, end_dom_y, end_x, end_y, end_z + integer, intent(in) :: npass + real, intent(in) :: msgval, hflag + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), & + intent(inout) :: array + + ! Local variables + integer :: ix, iy, iz, ipass + real, pointer, dimension(:,:,:) :: scratch + integer, dimension(start_y:end_y) :: ihe, ihw, istart + real, parameter:: cenwgt = 1.52 + real, parameter:: endwgt = 0.13 + + allocate(scratch(start_x:end_x, start_y:end_y, start_z:end_z)) + + do iy=start_y,end_y + if (hflag == 1.0) then + ihe(iy) = abs(mod(iy+1,2)) + ihw(iy) = ihe(iy)-1 + else + ! assign ive,ivw equivs to ihe,ihw + ihe(iy) = abs(mod(iy,2)) + ihw(iy) = ihe(iy)-1 + end if + end do + + do iy=start_y,end_y + if (hflag == 1.0) then + if (mod(iy,2) == 0) then + istart(iy) = start_x + else + istart(iy) = start_x+1 + endif + else ! v points + if (abs(mod(iy,2)) == 1) then + istart(iy) = start_x + else + istart(iy) = start_x+1 + endif + endif + end do + + do ipass=1,npass + + ! + ! Smoothing pass + ! + + do iy=start_y,end_y + do ix=start_x,end_x + scratch(ix,iy,1) = array(ix,iy,1) + end do + end do + + do iy=start_y+1,end_y-1 + do ix=istart(iy),end_x-1 + do iz=start_z,end_z + if ( (msgval == 1.0 .and. array(ix,iy,iz) /= 0.) .or. msgval /= 1.0) then + scratch(ix,iy,iz) = 0.50*array(ix,iy,iz)+ & + 0.125*(array(ix+ihw(iy),iy-1,iz)+array(ix+ihe(iy),iy+1,iz)+ & + array(ix+ihw(iy),iy+1,iz)+array(ix+ihe(iy),iy-1,iz)) + end if + end do + end do + end do + + + ! + ! Desmoothing pass + ! + + do iy=start_y+2,end_y-2 + do ix=istart(iy),end_x-1 + do iz=start_z,end_z + if ( (msgval == 1.0 .and. scratch(ix,iy,iz) /= 0.) .or. msgval /= 1.0) then + array(ix,iy,iz) = cenwgt*scratch(ix,iy,iz) - & + endwgt*(scratch(ix+ihw(iy),iy-1,iz)+scratch(ix+ihe(iy),iy+1,iz) + & + scratch(ix+ihw(iy),iy+1,iz)+scratch(ix+ihe(iy),iy-1,iz)) + end if + end do + end do + end do + + end do + + deallocate(scratch) + + end subroutine smth_desmth_egrid_old + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: smth_desmth_egrid + ! + ! Purpose: Apply the smoother-desmoother for E grid + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine smth_desmth_egrid(array, start_dom_x, end_dom_x, start_dom_y, end_dom_y, & + start_x, end_x, start_y, end_y, start_z, end_z, npass, msgval, hflag) + + implicit none + + ! Arguments + integer, intent(in) :: start_dom_x, start_dom_y, start_x, start_y, start_z + integer, intent(in) :: end_dom_x, end_dom_y, end_x, end_y, end_z + integer, intent(in) :: npass + real, intent(in) :: msgval, hflag + real, dimension(start_x:end_x, start_y:end_y, start_z:end_z), & + intent(inout) :: array + + ! Local variables + integer :: ix, iy, iz, ipass + real, pointer, dimension(:,:,:) :: scratch + integer, dimension(start_y:end_y) :: ihe, ihw, istart + real, parameter :: cenwgt = 1.52 + real, parameter :: endwgt = 0.26 + + allocate(scratch(start_x:end_x, start_y:end_y, start_z:end_z)) + + do iy=start_y,end_y + + if (hflag .eq. 1.0) then + ihe(iy)=abs(mod(iy+1,2)) + ihw(iy)=ihe(iy)-1 + + ! assign ive,ivw equivs to ihe,ihw + else + ihe(iy)=abs(mod(iy,2)) + ihw(iy)=ihe(iy)-1 + + end if + + end do + + do iy=start_y,end_y + + if (hflag .eq. 1.0) then + if (mod(iy,2) .eq. 0) then + istart(iy)=start_x + else + istart(iy)=start_x+1 + endif + + else ! v points + if (abs(mod(iy,2)) .eq. 1) then + istart(iy)=start_x + else + istart(iy)=start_x+1 + end if + + end if + + end do + + + do ipass=1,npass + + ! + ! Smoothing pass + ! + + do iy=start_y,end_y + do ix=start_x,end_x + scratch(ix,iy,1)=array(ix,iy,1) ! for points used in 2nd computation but + ! not defined in 1st + end do + end do + + ! SW-NE direction + do iy=start_y+1,end_y-1 + do ix=istart(iy),end_x-1 + do iz=start_z,end_z + if ( (msgval .eq. 1.0 .and. array(ix,iy,iz) .ne. 0.) .or. msgval .ne. 1.0) then + scratch(ix,iy,iz) = 0.50*array(ix,iy,iz)+ & + 0.25*(array(ix+ihw(iy),iy-1,iz)+array(ix+ihe(iy),iy+1,iz)) + end if + end do + end do + end do + + ! NW-SE direction + do iy=start_y+1,end_y-1 + do ix=istart(iy),end_x-1 + do iz=start_z,end_z + if ( (msgval .eq. 1.0 .and. array(ix,iy,iz) .ne. 0.) .or. msgval .ne. 1.0) then + array(ix,iy,iz) = 0.50*scratch(ix,iy,iz)+ & + 0.25*(scratch(ix+ihe(iy),iy-1,iz)+scratch(ix+ihw(iy),iy+1,iz)) + end if + end do + end do + end do + + call exchange_halo_r(array, & + start_x, end_x, start_y, end_y, start_z, end_z, & + start_dom_x, end_dom_x, start_dom_y, end_dom_y, start_z, end_z) + + + + ! + ! Desmoothing pass + ! + + ! SW-NE direction + do iy=start_y+2,end_y-2 + do ix=istart(iy),end_x-1 + do iz=start_z,end_z + if ( (msgval .eq. 1.0 .and. array(ix,iy,iz) .ne. 0.) .or. msgval .ne. 1.0) then + scratch(ix,iy,iz) = cenwgt*array(ix,iy,iz) - & + endwgt*(array(ix+ihw(iy),iy-1,iz)+array(ix+ihe(iy),iy+1,iz)) + end if + end do + end do + end do + + ! NW-SE direction + do iy=start_y+2,end_y-2 + do ix=istart(iy),end_x-1 + do iz=start_z,end_z + if ( (msgval .eq. 1.0 .and. array(ix,iy,iz) .ne. 0.) .or. msgval .ne. 1.0) then + array(ix,iy,iz) = cenwgt*scratch(ix,iy,iz) - & + endwgt*(scratch(ix+ihe(iy),iy-1,iz)+scratch(ix+ihw(iy),iy+1,iz)) + end if + end do + end do + end do + + call exchange_halo_r(array, & + start_x, end_x, start_y, end_y, start_z, end_z, & + start_dom_x, end_dom_x, start_dom_y, end_dom_y, start_z, end_z) + + end do + + deallocate(scratch) + + end subroutine smth_desmth_egrid + +end module smooth_module diff --git a/WPS/geogrid/src/source_data_module.F b/WPS/geogrid/src/source_data_module.F new file mode 100644 index 00000000..6f9a1cd1 --- /dev/null +++ b/WPS/geogrid/src/source_data_module.F @@ -0,0 +1,3738 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Module: source_data_module +! +! Description: +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module source_data_module + + use hash_module + use list_module + use module_debug + use misc_definitions_module + + ! Parameters + integer, parameter :: RETURN_LANDMASK = 0, & + RETURN_DOMCAT_LM = 1, & + RETURN_DFDX_LM = 2, & + RETURN_DFDY_LM = 3, & + RETURN_FIELDNAME = 4, & + RETURN_DOMCAT = 5, & + RETURN_DFDX = 6, & + RETURN_DFDY = 7 + integer, parameter :: MAX_LANDMASK_CATEGORIES = 100 + + ! Module variables + integer :: num_entries + integer :: next_field = 1 + integer :: output_field_state = RETURN_LANDMASK + character (len=128) :: last_output_fieldname = '' + integer, pointer, dimension(:) :: source_proj, source_wordsize, source_endian, source_fieldtype, & + source_dest_fieldtype, source_priority, source_tile_x, source_tile_y, & + source_tile_z, source_tile_z_start, source_tile_z_end, source_tile_bdr, & + source_category_min, source_category_max, source_smooth_option, & + source_smooth_passes, source_output_stagger, source_row_order, & + source_filename_digits + integer :: source_iswater, source_islake, source_isice, source_isurban, source_isoilwater + real, pointer, dimension(:) :: source_dx, source_dy, source_known_x, source_known_y, & + source_known_lat, source_known_lon, source_masked, source_truelat1, source_truelat2, & + source_stdlon, source_scale_factor, source_missing_value, source_fill_missing + character (len=128), pointer, dimension(:) :: source_fieldname, source_path, source_interp_string, & + source_dominant_category, source_dominant_only, source_dfdx, source_dfdy, & + source_z_dim_name, source_units, source_descr, source_output_flag, source_res + character (len=128) :: source_mminlu + logical, pointer, dimension(:) :: is_proj, is_wordsize, is_endian, is_fieldtype, & + is_dest_fieldtype, is_priority, is_tile_x, is_tile_y, is_tile_z, & + is_tile_z_start, is_tile_z_end, is_tile_bdr, is_category_min, & + is_category_max, is_masked, & + is_dx, is_dy, is_known_x, is_known_y, & + is_known_lat, is_known_lon, is_truelat1, is_truelat2, is_stdlon, & + is_scale_factor, is_fieldname, is_path, is_dominant_category, & + is_dominant_only, is_dfdx, is_dfdy, is_z_dim_name, & + is_smooth_option, is_smooth_passes, is_signed, is_missing_value, & + is_fill_missing, is_halt_missing, is_output_stagger, is_row_order, & + is_units, is_descr, is_subgrid, is_output_flag, is_optional, is_not_found + + type (list), pointer, dimension(:) :: source_res_path, source_interp_option, source_landmask_land, & + source_landmask_water + type (hashtable) :: bad_files ! Track which files produce errors when we try to open them + type (hashtable) :: duplicate_fnames ! Remember which output fields we have returned + + + contains + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_datalist + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_datalist() + + use gridinfo_module + use stringutil + + implicit none + + ! Parameters + integer, parameter :: BUFSIZE = 256 + + ! Local variables + integer :: nparams, idx, eos, ispace, comma, i, j, funit + logical :: have_specification, is_used + character (len=128) :: res_string, path_string, interp_string, landmask_string + character (len=BUFSIZE) :: buffer + + nparams = 0 + num_entries = 0 + + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + open(funit,file=trim(opt_geogrid_tbl_path)//'GEOGRID.TBL',form='formatted',status='old',err=1000) + + ! + ! We will first go through the file to determine how many field + ! specifications there are + ! + 10 read(funit,'(a)',end=20,err=1001) buffer + call despace(buffer) + + ! Is this line a comment? + if (buffer(1:1) == '#') then + + ! Are we beginning a new field specification? + else if (index(buffer,'=====') /= 0) then + if (nparams > 0) num_entries = num_entries + 1 + nparams = 0 + + else + eos = index(buffer,'#') + if (eos /= 0) buffer(eos:BUFSIZE) = ' ' + + ! Does this line contain at least one parameter specification? + if (index(buffer,'=') /= 0) then + nparams = nparams + 1 + end if + end if + go to 10 + + 20 rewind(funit) + + ! In case the last entry ended without a ======== line + if (nparams > 0) num_entries = num_entries + 1 + + call mprintf(.true.,STDOUT,'Parsed %i entries in GEOGRID.TBL', i1=num_entries) + + ! + ! Now that we know how many fields the user has specified, allocate + ! the properly sized arrays + ! + allocate(source_wordsize(num_entries)) + allocate(source_endian(num_entries)) + allocate(source_fieldtype(num_entries)) + allocate(source_dest_fieldtype(num_entries)) + allocate(source_proj(num_entries)) + allocate(source_priority(num_entries)) + allocate(source_dx(num_entries)) + allocate(source_dy(num_entries)) + allocate(source_known_x(num_entries)) + allocate(source_known_y(num_entries)) + allocate(source_known_lat(num_entries)) + allocate(source_known_lon(num_entries)) + allocate(source_truelat1(num_entries)) + allocate(source_truelat2(num_entries)) + allocate(source_stdlon(num_entries)) + allocate(source_fieldname(num_entries)) + allocate(source_path(num_entries)) + allocate(source_interp_string(num_entries)) + allocate(source_tile_x(num_entries)) + allocate(source_tile_y(num_entries)) + allocate(source_tile_z(num_entries)) + allocate(source_tile_z_start(num_entries)) + allocate(source_tile_z_end(num_entries)) + allocate(source_filename_digits(num_entries)) + allocate(source_category_min(num_entries)) + allocate(source_category_max(num_entries)) + allocate(source_tile_bdr(num_entries)) + allocate(source_masked(num_entries)) + allocate(source_output_stagger(num_entries)) + allocate(source_row_order(num_entries)) + allocate(source_dominant_category(num_entries)) + allocate(source_dominant_only(num_entries)) + allocate(source_dfdx(num_entries)) + allocate(source_dfdy(num_entries)) + allocate(source_scale_factor(num_entries)) + allocate(source_z_dim_name(num_entries)) + allocate(source_units(num_entries)) + allocate(source_descr(num_entries)) + allocate(source_res(num_entries)) + allocate(source_smooth_option(num_entries)) + allocate(source_smooth_passes(num_entries)) + allocate(source_missing_value(num_entries)) + allocate(source_fill_missing(num_entries)) + allocate(source_res_path(num_entries)) + allocate(source_interp_option(num_entries)) + allocate(source_landmask_land(num_entries)) + allocate(source_landmask_water(num_entries)) + allocate(source_output_flag(num_entries)) + do i=1,num_entries + call list_init(source_res_path(i)) + call list_init(source_interp_option(i)) + call list_init(source_landmask_land(i)) + call list_init(source_landmask_water(i)) + end do + + allocate(is_wordsize(num_entries)) + allocate(is_endian(num_entries)) + allocate(is_fieldtype(num_entries)) + allocate(is_dest_fieldtype(num_entries)) + allocate(is_proj(num_entries)) + allocate(is_priority(num_entries)) + allocate(is_dx(num_entries)) + allocate(is_dy(num_entries)) + allocate(is_known_x(num_entries)) + allocate(is_known_y(num_entries)) + allocate(is_known_lat(num_entries)) + allocate(is_known_lon(num_entries)) + allocate(is_truelat1(num_entries)) + allocate(is_truelat2(num_entries)) + allocate(is_stdlon(num_entries)) + allocate(is_fieldname(num_entries)) + allocate(is_path(num_entries)) + allocate(is_tile_x(num_entries)) + allocate(is_tile_y(num_entries)) + allocate(is_tile_z(num_entries)) + allocate(is_tile_z_start(num_entries)) + allocate(is_tile_z_end(num_entries)) + allocate(is_category_min(num_entries)) + allocate(is_category_max(num_entries)) + allocate(is_tile_bdr(num_entries)) + allocate(is_masked(num_entries)) + allocate(is_halt_missing(num_entries)) + allocate(is_output_stagger(num_entries)) + allocate(is_row_order(num_entries)) + allocate(is_dominant_category(num_entries)) + allocate(is_dominant_only(num_entries)) + allocate(is_dfdx(num_entries)) + allocate(is_dfdy(num_entries)) + allocate(is_scale_factor(num_entries)) + allocate(is_z_dim_name(num_entries)) + allocate(is_units(num_entries)) + allocate(is_descr(num_entries)) + allocate(is_smooth_option(num_entries)) + allocate(is_smooth_passes(num_entries)) + allocate(is_signed(num_entries)) + allocate(is_missing_value(num_entries)) + allocate(is_fill_missing(num_entries)) + allocate(is_subgrid(num_entries)) + allocate(is_output_flag(num_entries)) + allocate(is_optional(num_entries)) + allocate(is_not_found(num_entries)) + + source_wordsize=0 + source_endian=0 + source_fieldtype=0 + source_dest_fieldtype=0 + source_proj=0 + source_priority=0 + source_dx=0 + source_dy=0 + source_known_x=0 + source_known_y=0 + source_known_lat=0 + source_known_lon=0 + source_truelat1=0 + source_truelat2=0 + source_stdlon=0 + source_fieldname=' ' + source_path=' ' + source_interp_string=' ' + source_tile_x=0 + source_tile_y=0 + source_tile_z=0 + source_tile_z_start=0 + source_tile_z_end=0 + source_filename_digits=5 + source_category_min=0 + source_category_max=0 + source_tile_bdr=0 + source_masked=0 + source_output_stagger=0 + source_row_order=0 + source_dominant_category=' ' + source_dominant_only=' ' + source_dfdx=' ' + source_dfdy=' ' + source_scale_factor=0 + source_z_dim_name=' ' + source_units=' ' + source_descr=' ' + source_res=' ' + source_smooth_option=0 + source_smooth_passes=0 + source_missing_value=0 + source_fill_missing=0 + source_output_flag=' ' + + is_wordsize=.false. + is_endian=.false. + is_fieldtype=.false. + is_dest_fieldtype=.false. + is_proj=.false. + is_priority=.false. + is_dx=.false. + is_dy=.false. + is_known_x=.false. + is_known_y=.false. + is_known_lat=.false. + is_known_lon=.false. + is_truelat1=.false. + is_truelat2=.false. + is_stdlon=.false. + is_fieldname=.false. + is_path=.false. + is_tile_x=.false. + is_tile_y=.false. + is_tile_z=.false. + is_tile_z_start=.false. + is_tile_z_end=.false. + is_category_min=.false. + is_category_max=.false. + is_tile_bdr=.false. + is_masked=.false. + is_halt_missing=.false. + is_output_stagger=.false. + is_row_order=.false. + is_dominant_category=.false. + is_dominant_only=.false. + is_dfdx=.false. + is_dfdy=.false. + is_scale_factor=.false. + is_z_dim_name=.false. + is_units=.false. + is_descr=.false. + is_smooth_option=.false. + is_smooth_passes=.false. + is_signed=.false. + is_missing_value=.false. + is_fill_missing=.false. + is_subgrid=.false. + is_output_flag=.false. + is_optional=.false. + is_not_found=.false. + + ! This is the default value of source_mminlu + ! If this default is changed then you must also modify the variable + ! default_mminlu in get_source_params + write(source_mminlu,'(a4)') 'USGS' + source_iswater = 16 + source_islake = -1 + source_isice = 24 + source_isurban = 1 + source_isoilwater = 14 + + ! + ! Actually read and save the specifications + ! + nparams = 0 + i = 1 + 30 buffer = ' ' + read(funit,'(a)',end=40,err=1001) buffer + call despace(buffer) + + ! Is this line a comment? + if (buffer(1:1) == '#') then + ! Do nothing. + + ! Are we beginning a new field specification? + else if (index(buffer,'=====') /= 0) then !{ + if (nparams > 0) i = i + 1 + nparams = 0 + if (i <= num_entries) then +!BUG: Are these initializations needed now that we've added initializations for +! all options after their initial allocation above? + is_path(i) = .false. + is_masked(i) = .false. + is_halt_missing(i) = .false. + is_output_stagger(i) = .false. + is_dominant_category(i) = .false. + is_dominant_only(i) = .false. + is_dfdx(i) = .false. + is_dfdy(i) = .false. + is_dest_fieldtype(i) = .false. + is_priority(i) = .false. + is_z_dim_name(i) = .false. + is_smooth_option(i) = .false. + is_smooth_passes(i) = .false. + is_fill_missing(i) = .false. + is_subgrid(i) = .false. + is_output_flag(i) = .false. + is_optional(i) = .false. + end if + + else + ! Check whether the current line is a comment + if (buffer(1:1) /= '#') then + have_specification = .true. + else + have_specification = .false. + end if + + ! If only part of the line is a comment, just turn the comment into spaces + eos = index(buffer,'#') + if (eos /= 0) buffer(eos:BUFSIZE) = ' ' + + do while (have_specification) !{ + + ! If this line has no semicolon, it may contain a single specification, + ! so we set have_specification = .false. to prevent the line from being + ! processed again and "pretend" that the last character was a semicolon + eos = index(buffer,';') + if (eos == 0) then + have_specification = .false. + eos = BUFSIZE + end if + + idx = index(buffer(1:eos-1),'=') + + if (idx /= 0) then !{ + nparams = nparams + 1 + + if (index('name',trim(buffer(1:idx-1))) /= 0) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + is_fieldname(i) = .true. + source_fieldname(i) = ' ' + source_fieldname(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('priority',trim(buffer(1:idx-1))) /= 0) then + is_priority(i) = .true. + read(buffer(idx+1:eos-1),'(i10)') source_priority(i) + + else if (index('dest_type',trim(buffer(1:idx-1))) /= 0) then + if (index('continuous',trim(buffer(idx+1:eos-1))) /= 0) then + is_dest_fieldtype(i) = .true. + source_dest_fieldtype(i) = CONTINUOUS + else if (index('categorical',trim(buffer(idx+1:eos-1))) /= 0) then + is_dest_fieldtype(i) = .true. + source_dest_fieldtype(i) = CATEGORICAL + end if + + else if (index('interp_option',trim(buffer(1:idx-1))) /= 0) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + interp_string = ' ' + interp_string(1:ispace-idx-1) = buffer(idx+1:ispace-1) + ispace = index(interp_string,':') + if (ispace /= 0) then + write(res_string,'(a)') interp_string(1:ispace-1) + else + res_string = 'default' + end if + write(interp_string,'(a)') trim(interp_string(ispace+1:128)) + if (list_search(source_interp_option(i), ckey=res_string, cvalue=interp_string)) then + call mprintf(.true., WARN, & + 'In GEOGRID.TBL entry %i, multiple interpolation methods are '// & + 'given for resolution %s. %s will be used.', & + i1=i, s1=trim(res_string), s2=trim(interp_string)) + else + call list_insert(source_interp_option(i), ckey=res_string, cvalue=interp_string) + end if + + else if (index('smooth_option',trim(buffer(1:idx-1))) /= 0) then + if ((index('1-2-1',trim(buffer(idx+1:eos-1))) /= 0) .and. & + (len_trim(buffer(idx+1:eos-1)) == len('1-2-1'))) then + is_smooth_option(i) = .true. + source_smooth_option(i) = ONETWOONE + else if ((index('smth-desmth',trim(buffer(idx+1:eos-1))) /= 0) .and. & + (len_trim(buffer(idx+1:eos-1)) == len('smth-desmth'))) then + is_smooth_option(i) = .true. + source_smooth_option(i) = SMTHDESMTH + else if ((index('smth-desmth_special',trim(buffer(idx+1:eos-1))) /= 0) .and. & + (len_trim(buffer(idx+1:eos-1)) == len('smth-desmth_special'))) then + is_smooth_option(i) = .true. + source_smooth_option(i) = SMTHDESMTH_SPECIAL + end if + + else if (index('smooth_passes',trim(buffer(1:idx-1))) /= 0) then + is_smooth_passes(i) = .true. + read(buffer(idx+1:eos-1),'(i10)') source_smooth_passes(i) + + else if (index('rel_path',trim(buffer(1:idx-1))) /= 0) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + path_string = ' ' + path_string(1:ispace-idx-1) = buffer(idx+1:ispace-1) + if (path_string(ispace-idx-1:ispace-idx-1) /= '/') & + path_string(ispace-idx:ispace-idx) = '/' + if (path_string(1:1) == '/') then + path_string(1:127) = path_string(2:128) + path_string(128:128) = ' ' + end if + ispace = index(path_string,':') + if (ispace /= 0) then + write(res_string,'(a)') path_string(1:ispace-1) + else + res_string = 'default' + end if + write(path_string,'(a)') trim(geog_data_path)//trim(path_string(ispace+1:128)) + if (list_search(source_res_path(i), ckey=res_string, cvalue=path_string)) then + call mprintf(.true., WARN, & + 'In GEOGRID.TBL entry %i, multiple paths are given for '// & + 'resolution %s. %s will be used.', & + i1=i, s1=trim(res_string), s2=trim(path_string)) + else + call list_insert(source_res_path(i), ckey=res_string, cvalue=path_string) + end if + + else if (index('abs_path',trim(buffer(1:idx-1))) /= 0) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + path_string = ' ' + path_string(1:ispace-idx-1) = buffer(idx+1:ispace-1) + if (path_string(ispace-idx-1:ispace-idx-1) /= '/') & + path_string(ispace-idx:ispace-idx) = '/' + ispace = index(path_string,':') + if (ispace /= 0) then + write(res_string,'(a)') path_string(1:ispace-1) + else + res_string = 'default' + end if + write(path_string,'(a)') trim(path_string(ispace+1:128)) + if (list_search(source_res_path(i), ckey=res_string, cvalue=path_string)) then + call mprintf(.true., WARN, & + 'In GEOGRID.TBL entry %i, multiple paths are given for '// & + 'resolution %s. %s will be used.', & + i1=i, s1=trim(res_string), s2=trim(path_string)) + else + call list_insert(source_res_path(i), ckey=res_string, cvalue=path_string) + end if + + else if (index('output_stagger',trim(buffer(1:idx-1))) /= 0) then + if (index('M',trim(buffer(idx+1:eos-1))) /= 0) then + is_output_stagger(i) = .true. + source_output_stagger(i) = M + else if (index('U',trim(buffer(idx+1:eos-1))) /= 0) then + is_output_stagger(i) = .true. + source_output_stagger(i) = U + else if (index('V',trim(buffer(idx+1:eos-1))) /= 0) then + is_output_stagger(i) = .true. + source_output_stagger(i) = V + else if (index('HH',trim(buffer(idx+1:eos-1))) /= 0) then + is_output_stagger(i) = .true. + source_output_stagger(i) = HH + else if (index('VV',trim(buffer(idx+1:eos-1))) /= 0) then + is_output_stagger(i) = .true. + source_output_stagger(i) = VV + end if + + else if ((index('landmask_water',trim(buffer(1:idx-1))) /= 0) .and. & + (len_trim(buffer(1:idx-1)) == 14)) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + landmask_string = ' ' + landmask_string(1:ispace-idx-1) = buffer(idx+1:ispace-1) + ispace = index(landmask_string,':') + if (ispace /= 0) then + write(res_string,'(a)') landmask_string(1:ispace-1) + else + res_string = 'default' + end if + write(landmask_string,'(a)') trim(landmask_string(ispace+1:128)) + if (list_search(source_landmask_water(i), ckey=res_string, cvalue=landmask_string)) then + call mprintf(.true., WARN, & + 'In GEOGRID.TBL entry %i, multiple landmask category specifications are given for '// & + 'resolution %s. %s will be used.', & + i1=i, s1=trim(res_string), s2=trim(landmask_string)) + else + call list_insert(source_landmask_water(i), ckey=res_string, cvalue=landmask_string) + end if + + else if ((index('landmask_land',trim(buffer(1:idx-1))) /= 0) .and. & + (len_trim(buffer(1:idx-1)) == 13)) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + landmask_string = ' ' + landmask_string(1:ispace-idx-1) = buffer(idx+1:ispace-1) + ispace = index(landmask_string,':') + if (ispace /= 0) then + write(res_string,'(a)') landmask_string(1:ispace-1) + else + res_string = 'default' + end if + write(landmask_string,'(a)') trim(landmask_string(ispace+1:128)) + if (list_search(source_landmask_land(i), ckey=res_string, cvalue=landmask_string)) then + call mprintf(.true., WARN, & + 'In GEOGRID.TBL entry %i, multiple landmask category specifications are given for '// & + 'resolution %s. %s will be used.', & + i1=i, s1=trim(res_string), s2=trim(landmask_string)) + else + call list_insert(source_landmask_land(i), ckey=res_string, cvalue=landmask_string) + end if + + else if ((index('masked',trim(buffer(1:idx-1))) /= 0) .and. & + (len_trim(buffer(1:idx-1)) == 6)) then + if (index('water',trim(buffer(idx+1:eos-1))) /= 0) then + is_masked(i) = .true. + source_masked(i) = 0. + else if (index('land',trim(buffer(idx+1:eos-1))) /= 0) then + is_masked(i) = .true. + source_masked(i) = 1. + end if + + else if (index('fill_missing',trim(buffer(1:idx-1))) /= 0) then + is_fill_missing(i) = .true. + read(buffer(idx+1:eos-1),*) source_fill_missing(i) + + else if (index('halt_on_missing',trim(buffer(1:idx-1))) /= 0) then + if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then + is_halt_missing(i) = .true. + else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then + is_halt_missing(i) = .false. + end if + + else if (index('dominant_category',trim(buffer(1:idx-1))) /= 0) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + is_dominant_category(i) = .true. + source_dominant_category(i) = ' ' + source_dominant_category(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('dominant_only',trim(buffer(1:idx-1))) /= 0) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + is_dominant_only(i) = .true. + source_dominant_only(i) = ' ' + source_dominant_only(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('df_dx',trim(buffer(1:idx-1))) /= 0) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + is_dfdx(i) = .true. + source_dfdx(i) = ' ' + source_dfdx(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('df_dy',trim(buffer(1:idx-1))) /= 0) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + is_dfdy(i) = .true. + source_dfdy(i) = ' ' + source_dfdy(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('z_dim_name',trim(buffer(1:idx-1))) /= 0) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + is_z_dim_name(i) = .true. + source_z_dim_name(i) = ' ' + source_z_dim_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('subgrid',trim(buffer(1:idx-1))) /= 0) then + if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then + is_subgrid(i) = .true. + else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then + is_subgrid(i) = .false. + end if + + else if (index('flag_in_output',trim(buffer(1:idx-1))) /= 0) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + is_output_flag(i) = .true. + source_output_flag(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('optional',trim(buffer(1:idx-1))) /= 0) then + if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then + is_optional(i) = .true. + else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then + is_subgrid(i) = .false. + end if + + else + call mprintf(.true., WARN, 'In GEOGRID.TBL, unrecognized option %s in '// & + 'entry %i.',i1=idx, s1=buffer(i:idx-1)) + + end if + + end if !} index(buffer(1:eos-1),'=') /= 0 + + buffer = buffer(eos+1:BUFSIZE) + end do ! while eos /= 0 } + + end if !} index(buffer, '=====') /= 0 + go to 30 + + 40 close(funit) + + ! Check the user specifications for gross errors + if ( .not. check_data_specification() ) then + call datalist_destroy() + call mprintf(.true.,ERROR,'Errors were found in either index files or GEOGRID.TBL.') + end if + + call hash_init(bad_files) + + return + + 1000 call mprintf(.true.,ERROR,'Could not open GEOGRID.TBL') + + 1001 call mprintf(.true.,ERROR,'Encountered error while reading GEOGRID.TBL') + + end subroutine get_datalist + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_source_params + ! + ! Purpose: For each field, this routine reads in the metadata in the index file + ! for the first available resolution of data specified by res_string. Also + ! based on res_string, this routine sets the interpolation sequence for the + ! field. This routine should be called prior to processing a field for each + ! domain. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_source_params(res_string) + + use stringutil + + implicit none + + ! Parameters + integer, parameter :: BUFSIZE = 256 + + ! Arguments + character (len=128), intent(in) :: res_string + + ! Local variables + integer :: idx, i, is, ie, ispace, eos, iquoted, funit, iostatus + character (len=128) :: temp_data, temp_interp + character (len=256) :: test_fname + character (len=BUFSIZE) :: buffer + logical :: have_specification, is_used + logical :: landusef_already_found + character (len=128) :: cur_mminlu, previous_mminlu + character (len=128), parameter :: default_mminlu = 'USGS' + logical :: mminlu_found_in_this_entry + landusef_already_found = .FALSE. + previous_mminlu = 'NOT_YET_SET' + + ! For each entry in the GEOGRID.TBL file + ENTRY_LOOP: do idx=1,num_entries + mminlu_found_in_this_entry = .FALSE. + + ! Initialize metadata + is_wordsize(idx) = .false. + is_endian(idx) = .false. + is_row_order(idx) = .false. + is_fieldtype(idx) = .false. + is_proj(idx) = .false. + is_dx(idx) = .false. + is_dy(idx) = .false. + is_known_x(idx) = .false. + is_known_y(idx) = .false. + is_known_lat(idx) = .false. + is_known_lon(idx) = .false. + is_truelat1(idx) = .false. + is_truelat2(idx) = .false. + is_stdlon(idx) = .false. + is_tile_x(idx) = .false. + is_tile_y(idx) = .false. + is_tile_z(idx) = .false. + is_tile_z_start(idx) = .false. + is_tile_z_end(idx) = .false. + is_category_min(idx) = .false. + is_category_max(idx) = .false. + is_tile_bdr(idx) = .false. + is_fieldname(idx) = .false. + is_scale_factor(idx) = .false. + is_units(idx) = .false. + is_descr(idx) = .false. + is_signed(idx) = .false. + is_missing_value(idx) = .false. + is_not_found(idx) = .false. + + + ! Set the interpolator sequence for the field to be the first value in res_string that matches + ! the resolution keyword for an interp_sequence specification + is = 1 + ie = index(res_string(is:128),'+') - 1 + if (ie <= 0) ie = 128 + temp_interp = res_string(is:ie) + do while (.not. list_search(source_interp_option(idx), ckey=temp_interp, cvalue=source_interp_string(idx)) & + .and. is <= 128) + call mprintf(.true., INFORM, 'For %s, couldn''t find interpolator sequence for '// & + 'resolution %s.', & + s1=trim(source_fieldname(idx)), s2=trim(temp_interp)) + is = ie+2 + ie = is + index(res_string(is:128),'+') - 2 + if (ie - is <= 0) ie = 128 + temp_interp = res_string(is:ie) + end do + + if (is > 128) then + temp_interp = 'default' + if (list_search(source_interp_option(idx), ckey=temp_interp, cvalue=source_interp_string(idx))) then + call mprintf(.true., INFORM, 'Using default interpolator sequence for %s.', & + s1=trim(source_fieldname(idx))) + else + if (is_optional(idx)) then + is_not_found(idx) = .true. + call mprintf(.true., INFORM, 'Could not find interpolator sequence for requested resolution '// & + 'for this entry of %s in GEOGRID.TBL and no default interpolator was specified.',& + s1=trim(source_fieldname(idx))) + call mprintf(.true., INFORM, 'This entry in GEOGRID.TBL of %s is optional and will not be '// & + 'processed. However, there may be other entries for %s in GEOGRID.TBL and ' // & + 'thus this field may yet be processed.', s1=trim(source_fieldname(idx)), & + s2=trim(source_fieldname(idx))) + cycle ENTRY_LOOP + else + call mprintf(.true., ERROR, 'Could not find interpolator sequence for requested resolution for %s.'// & + ' The sources specified in namelist.wps is not listed in GEOGRID.TBL.', & + s1=trim(source_fieldname(idx))) + end if + end if + else + call mprintf(.true., INFORM, 'Using %s interpolator sequence for %s.', & + s1=temp_interp, s2=trim(source_fieldname(idx))) + end if + + ! Set the data source for the field to be the first value in res_string that matches + ! the resolution keyword for an abs_path or rel_path specification + is = 1 + ie = index(res_string(is:128),'+') - 1 + if (ie <= 0) ie = 128 + temp_data = res_string(is:ie) + do while (.not. list_search(source_res_path(idx), ckey=temp_data, cvalue=source_path(idx)) & + .and. is <= 128) + call mprintf(.true., INFORM, 'For %s, couldn''t find %s data source.', & + s1=trim(source_fieldname(idx)), s2=trim(temp_data)) + is = ie+2 + ie = is + index(res_string(is:128),'+') - 2 + if (ie - is <= 0) ie = 128 + temp_data = res_string(is:ie) + end do + + if (is > 128) then + temp_data = 'default' + if (list_search(source_res_path(idx), ckey=temp_data, cvalue=source_path(idx))) then + call mprintf(.true., INFORM, 'Using default data source for %s.', & + s1=trim(source_fieldname(idx))) + else + call mprintf(.true., ERROR, 'Could not find data resolution for requested resolution for %s. '// & + 'The source specified in namelist.wps is not listed in GEOGRID.TBL.', & + s1=trim(source_fieldname(idx))) + end if + else + call mprintf(.true., INFORM, 'Using %s data source for %s.', & + s1=temp_data, s2=trim(source_fieldname(idx))) + end if + source_res(idx) = temp_data + + call mprintf(trim(temp_data) /= trim(temp_interp),WARN,'For %s, using %s data source with %s interpolation sequence.', & + s1=source_fieldname(idx), s2=temp_data, s3=temp_interp) + + write(test_fname, '(a)') trim(source_path(idx))//'index' + + ! + ! Open the index file for the data source for this field, and read in metadata specs + ! + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + open(funit,file=trim(test_fname),form='formatted',status='old',iostat=iostatus) + if (iostatus /= 0) then + if (is_optional(idx)) then + is_not_found(idx) = .true. + call mprintf(.true.,INFORM,'Could not read ''index'' file %s for field %s', s1=trim(test_fname), & + s2=trim(source_fieldname(idx))) + call mprintf(.true.,INFORM,'This field is optional and will not be processed.') + else + call mprintf(.true.,ERROR,'Could not open %s', s1=trim(test_fname)) + end if + + cycle ENTRY_LOOP + + end if + + 30 buffer = ' ' + read(funit,'(a)',end=40, err=1001) buffer + call despace(buffer) + + ! Is this line a comment? + if (buffer(1:1) == '#') then + ! Do nothing. + + else + have_specification = .true. + + ! If only part of the line is a comment, just turn the comment into spaces + eos = index(buffer,'#') + if (eos /= 0) buffer(eos:BUFSIZE) = ' ' + + do while (have_specification) !{ + + ! If this line has no semicolon, it may contain a single specification, + ! so we set have_specification = .false. to prevent the line from being + ! processed again and pretend that the last character was a semicolon + eos = index(buffer,';') + if (eos == 0) then + have_specification = .false. + eos = BUFSIZE + end if + + i = index(buffer(1:eos-1),'=') + + if (i /= 0) then !{ + + if (index('projection',trim(buffer(1:i-1))) /= 0) then + if (index('lambert',trim(buffer(i+1:eos-1))) /= 0) then + is_proj(idx) = .true. + source_proj(idx) = PROJ_LC + else if (index('polar_wgs84',trim(buffer(i+1:eos-1))) /= 0 .and. & + len_trim('polar_wgs84') == len_trim(buffer(i+1:eos-1))) then + is_proj(idx) = .true. + source_proj(idx) = PROJ_PS_WGS84 + else if (index('albers_nad83',trim(buffer(i+1:eos-1))) /= 0 .and. & + len_trim('albers_nad83') == len_trim(buffer(i+1:eos-1))) then + is_proj(idx) = .true. + source_proj(idx) = PROJ_ALBERS_NAD83 + else if (index('polar',trim(buffer(i+1:eos-1))) /= 0 .and. & + len_trim('polar') == len_trim(buffer(i+1:eos-1))) then + is_proj(idx) = .true. + source_proj(idx) = PROJ_PS + else if (index('mercator',trim(buffer(i+1:eos-1))) /= 0) then + is_proj(idx) = .true. + source_proj(idx) = PROJ_MERC + else if (index('regular_ll',trim(buffer(i+1:eos-1))) /= 0) then + is_proj(idx) = .true. + source_proj(idx) = PROJ_LATLON + end if + + else if (index('type',trim(buffer(1:i-1))) /= 0) then + if (index('continuous',trim(buffer(i+1:eos-1))) /= 0) then + is_fieldtype(idx) = .true. + source_fieldtype(idx) = CONTINUOUS + else if (index('categorical',trim(buffer(i+1:eos-1))) /= 0) then + is_fieldtype(idx) = .true. + source_fieldtype(idx) = CATEGORICAL + end if + + else if (index('signed',trim(buffer(1:i-1))) /= 0) then + if (index('yes',trim(buffer(i+1:eos-1))) /= 0) then + is_signed(idx) = .true. + else if (index('no',trim(buffer(i+1:eos-1))) /= 0) then + is_signed(idx) = .false. + end if + + else if (index('units',trim(buffer(1:i-1))) /= 0) then + ispace = i+1 + iquoted = 0 + do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1)) + if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2) + ispace = ispace + 1 + end do + is_units(idx) = .true. + source_units(idx) = ' ' + if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1 + if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1 + source_units(idx)(1:ispace-i) = buffer(i+1:ispace-1) + + else if (index('description',trim(buffer(1:i-1))) /= 0) then + ispace = i+1 + iquoted = 0 + do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1)) + if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2) + ispace = ispace + 1 + end do + is_descr(idx) = .true. + source_descr(idx) = ' ' + if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1 + if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1 + source_descr(idx)(1:ispace-i) = buffer(i+1:ispace-1) + + else if (index('mminlu',trim(buffer(1:i-1))) /= 0) then + ispace = i+1 + iquoted = 0 + do while (((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) .or. (iquoted == 1)) + if (buffer(ispace:ispace) == '"' .or. buffer(ispace:ispace) == '''') iquoted = mod(iquoted+1,2) + ispace = ispace + 1 + end do + if (buffer(i+1:i+1) == '"' .or. buffer(i+1:i+1) == '''') i = i + 1 + if (buffer(ispace-1:ispace-1) == '"' .or. buffer(ispace-1:ispace-1) == '''') ispace = ispace - 1 + source_mminlu(1:ispace-i) = buffer(i+1:ispace-1) + mminlu_found_in_this_entry = .TRUE. + + else if (index('iswater',trim(buffer(1:i-1))) /= 0) then + read(buffer(i+1:eos-1),*) source_iswater + + else if (index('islake',trim(buffer(1:i-1))) /= 0) then + read(buffer(i+1:eos-1),*) source_islake + + else if (index('isice',trim(buffer(1:i-1))) /= 0) then + read(buffer(i+1:eos-1),*) source_isice + + else if (index('isurban',trim(buffer(1:i-1))) /= 0) then + read(buffer(i+1:eos-1),*) source_isurban + + else if (index('isoilwater',trim(buffer(1:i-1))) /= 0) then + read(buffer(i+1:eos-1),*) source_isoilwater + + else if (index('dx',trim(buffer(1:i-1))) /= 0) then + is_dx(idx) = .true. + read(buffer(i+1:eos-1),*) source_dx(idx) + + else if (index('dy',trim(buffer(1:i-1))) /= 0) then + is_dy(idx) = .true. + read(buffer(i+1:eos-1),*) source_dy(idx) + + else if (index('known_x',trim(buffer(1:i-1))) /= 0) then + is_known_x(idx) = .true. + read(buffer(i+1:eos-1),*) source_known_x(idx) + + else if (index('known_y',trim(buffer(1:i-1))) /= 0) then + is_known_y(idx) = .true. + read(buffer(i+1:eos-1),*) source_known_y(idx) + + else if (index('known_lat',trim(buffer(1:i-1))) /= 0) then + is_known_lat(idx) = .true. + read(buffer(i+1:eos-1),*) source_known_lat(idx) + + else if (index('known_lon',trim(buffer(1:i-1))) /= 0) then + is_known_lon(idx) = .true. + read(buffer(i+1:eos-1),*) source_known_lon(idx) + + else if (index('stdlon',trim(buffer(1:i-1))) /= 0) then + is_stdlon(idx) = .true. + read(buffer(i+1:eos-1),*) source_stdlon(idx) + + else if (index('truelat1',trim(buffer(1:i-1))) /= 0) then + is_truelat1(idx) = .true. + read(buffer(i+1:eos-1),*) source_truelat1(idx) + + else if (index('truelat2',trim(buffer(1:i-1))) /= 0) then + is_truelat2(idx) = .true. + read(buffer(i+1:eos-1),*) source_truelat2(idx) + + else if (index('wordsize',trim(buffer(1:i-1))) /= 0) then + is_wordsize(idx) = .true. + read(buffer(i+1:eos-1),'(i10)') source_wordsize(idx) + + else if (index('endian',trim(buffer(1:i-1))) /= 0) then + if (index('big',trim(buffer(i+1:eos-1))) /= 0) then + is_endian(idx) = .true. + source_endian(idx) = BIG_ENDIAN + else if (index('little',trim(buffer(i+1:eos-1))) /= 0) then + is_endian(idx) = .true. + source_endian(idx) = LITTLE_ENDIAN + else + call mprintf(.true.,WARN,'Invalid value for keyword ''endian'' '// & + 'specified in index file. BIG_ENDIAN will be used.') + end if + + else if (index('row_order',trim(buffer(1:i-1))) /= 0) then + if (index('bottom_top',trim(buffer(i+1:eos-1))) /= 0) then + is_row_order(idx) = .true. + source_row_order(idx) = BOTTOM_TOP + else if (index('top_bottom',trim(buffer(i+1:eos-1))) /= 0) then + is_row_order(idx) = .true. + source_row_order(idx) = TOP_BOTTOM + end if + + else if (index('tile_x',trim(buffer(1:i-1))) /= 0) then + is_tile_x(idx) = .true. + read(buffer(i+1:eos-1),'(i10)') source_tile_x(idx) + + else if (index('tile_y',trim(buffer(1:i-1))) /= 0) then + is_tile_y(idx) = .true. + read(buffer(i+1:eos-1),'(i10)') source_tile_y(idx) + + else if (index('tile_z',trim(buffer(1:i-1))) /= 0) then + is_tile_z(idx) = .true. + read(buffer(i+1:eos-1),'(i10)') source_tile_z(idx) + + else if (index('tile_z_start',trim(buffer(1:i-1))) /= 0) then + is_tile_z_start(idx) = .true. + read(buffer(i+1:eos-1),'(i10)') source_tile_z_start(idx) + + else if (index('tile_z_end',trim(buffer(1:i-1))) /= 0) then + is_tile_z_end(idx) = .true. + read(buffer(i+1:eos-1),'(i10)') source_tile_z_end(idx) + + else if (index('filename_digits',trim(buffer(1:i-1))) /= 0) then + read(buffer(i+1:eos-1),'(i10)') source_filename_digits(idx) + + else if (index('category_min',trim(buffer(1:i-1))) /= 0) then + is_category_min(idx) = .true. + read(buffer(i+1:eos-1),'(i10)') source_category_min(idx) + + else if (index('category_max',trim(buffer(1:i-1))) /= 0) then + is_category_max(idx) = .true. + read(buffer(i+1:eos-1),'(i10)') source_category_max(idx) + + else if (index('tile_bdr',trim(buffer(1:i-1))) /= 0) then + is_tile_bdr(idx) = .true. + read(buffer(i+1:eos-1),'(i10)') source_tile_bdr(idx) + + else if (index('missing_value',trim(buffer(1:i-1))) /= 0) then + is_missing_value(idx) = .true. + read(buffer(i+1:eos-1),*) source_missing_value(idx) + + else if (index('scale_factor',trim(buffer(1:i-1))) /= 0) then + is_scale_factor(idx) = .true. + read(buffer(i+1:eos-1),*) source_scale_factor(idx) + + else + call mprintf(.true., WARN, 'In %s, unrecognized option %s in entry %i.', & + s1=trim(test_fname), s2=buffer(i:i-1), i1=i) + + end if + + end if !} index(buffer(1:eos-1),'=') /= 0 + + buffer = buffer(eos+1:BUFSIZE) + end do ! while eos /= 0 } + + end if !} index(buffer, '=====') /= 0 + + go to 30 + + 40 close(funit) + + !Make sure we do not use two sources of land use data that use different + !categories (e.g., USGS categories for some and NLCD2006 for others) + if( trim(source_fieldname(idx)) .eq. 'LANDUSEF' ) then + !If mminlu was defined for the current LANDUSEF entry then store that as the + !current value, otherwise use the default value + if( mminlu_found_in_this_entry ) then + cur_mminlu = source_mminlu + else + cur_mminlu = default_mminlu + end if + !If a previous entry in GEOGRID.TBL already read in LANDUSEF + if ( landusef_already_found ) then + !Check mminlu string found for previous LANDUSEF entry to see if it matches the current entry + if ( previous_mminlu .ne. cur_mminlu ) then + if( mminlu_found_in_this_entry ) then !Current entry DID have an MMINLU setting + !Previous LANDUSEF entry used default mminlu (either explicitly specified mminlu that is the + !default or did not specify anything and defaulted to this value) + if ( previous_mminlu .ne. default_mminlu ) then + call mprintf(.true., ERROR, 'MMINLU values differ among input fields. Based on reading '// & + '%s using entry %i from GEOGRID.TBL mminlu = %s but a previous GEOGRID.TBL ' // & + 'entry resulted in mminlu being set to to %s', & + s1=trim(source_fieldname(idx)),i1=idx,s2=trim(cur_mminlu), & + s3=trim(previous_mminlu)) + !Previous LANDUSEF entry did NOT use default mminlu + else + call mprintf(.true., ERROR, 'MMINLU values differ among input fields. Based on reading '// & + '%s using entry %i from GEOGRID.TBL mminlu = %s but a previous GEOGRID.TBL '// & + 'entry resulted in mminlu being set to (or defaulting to) %s.', & + s1=trim(source_fieldname(idx)),i1=idx, & + s2=trim(cur_mminlu), s3=trim(previous_mminlu)) + end if !If previous LANDUSEF entry used default MMINLU + !Current entry did not have an MMINLU setting + else + call mprintf(.true., ERROR, 'MMINLU values differ among input fields. Reading %s using ' // & + 'entry %i from GEOGRID.TBL did not set mminlu, and thus the default value ' // & + 'of %s is assumed. However, mminlu was previously set to %s', & + s1=trim(source_fieldname(idx)),i1=idx,s2=trim(cur_mminlu), & + s3=trim(previous_mminlu)) + end if !If the current entry explicitly set MMINLU + end if !If MMINLU associated with previous LANDUSEF entry matches current LANDUSEF entry + end if !If previous GEOGRID.TBL entry already read in LANDUSEF + + landusef_already_found = .TRUE. + previous_mminlu = cur_mminlu + end if + + end do ENTRY_LOOP + + return + + 1001 call mprintf(.true.,ERROR,'Encountered error while reading %s', s1=trim(test_fname)) + + end subroutine get_source_params + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: datalist_destroy() + ! + ! Purpose: This routine deallocates any memory that was allocated by the + ! get_datalist() subroutine. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine datalist_destroy() + + implicit none + + ! Local variables + integer :: i + + if (associated(source_wordsize)) then + deallocate(source_wordsize) + deallocate(source_endian) + deallocate(source_fieldtype) + deallocate(source_dest_fieldtype) + deallocate(source_proj) + deallocate(source_priority) + deallocate(source_dx) + deallocate(source_dy) + deallocate(source_known_x) + deallocate(source_known_y) + deallocate(source_known_lat) + deallocate(source_known_lon) + deallocate(source_truelat1) + deallocate(source_truelat2) + deallocate(source_stdlon) + deallocate(source_fieldname) + deallocate(source_path) + deallocate(source_interp_string) + deallocate(source_tile_x) + deallocate(source_tile_y) + deallocate(source_tile_z) + deallocate(source_tile_z_start) + deallocate(source_tile_z_end) + deallocate(source_filename_digits) + deallocate(source_tile_bdr) + deallocate(source_category_min) + deallocate(source_category_max) + deallocate(source_masked) + deallocate(source_output_stagger) + deallocate(source_row_order) + deallocate(source_dominant_category) + deallocate(source_dominant_only) + deallocate(source_dfdx) + deallocate(source_dfdy) + deallocate(source_scale_factor) + deallocate(source_z_dim_name) + deallocate(source_smooth_option) + deallocate(source_smooth_passes) + deallocate(source_units) + deallocate(source_descr) + deallocate(source_res) + deallocate(source_missing_value) + deallocate(source_fill_missing) + do i=1,num_entries + call list_destroy(source_res_path(i)) + call list_destroy(source_interp_option(i)) + call list_destroy(source_landmask_land(i)) + call list_destroy(source_landmask_water(i)) + end do + deallocate(source_res_path) + deallocate(source_interp_option) + deallocate(source_landmask_land) + deallocate(source_landmask_water) + deallocate(source_output_flag) + + deallocate(is_wordsize) + deallocate(is_endian) + deallocate(is_fieldtype) + deallocate(is_dest_fieldtype) + deallocate(is_proj) + deallocate(is_priority) + deallocate(is_dx) + deallocate(is_dy) + deallocate(is_known_x) + deallocate(is_known_y) + deallocate(is_known_lat) + deallocate(is_known_lon) + deallocate(is_truelat1) + deallocate(is_truelat2) + deallocate(is_stdlon) + deallocate(is_fieldname) + deallocate(is_path) + deallocate(is_tile_x) + deallocate(is_tile_y) + deallocate(is_tile_z) + deallocate(is_tile_z_start) + deallocate(is_tile_z_end) + deallocate(is_tile_bdr) + deallocate(is_category_min) + deallocate(is_category_max) + deallocate(is_masked) + deallocate(is_halt_missing) + deallocate(is_output_stagger) + deallocate(is_row_order) + deallocate(is_dominant_category) + deallocate(is_dominant_only) + deallocate(is_dfdx) + deallocate(is_dfdy) + deallocate(is_scale_factor) + deallocate(is_z_dim_name) + deallocate(is_smooth_option) + deallocate(is_smooth_passes) + deallocate(is_signed) + deallocate(is_units) + deallocate(is_descr) + deallocate(is_missing_value) + deallocate(is_fill_missing) + deallocate(is_subgrid) + deallocate(is_output_flag) + deallocate(is_optional) + deallocate(is_not_found) + end if + + call hash_destroy(bad_files) + + end subroutine datalist_destroy + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: reset_next_field + ! + ! Purpose: To reset the pointer to the next field in the list of fields + ! specified by the user. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine reset_next_field() + + implicit none + + next_field = 1 + + end subroutine reset_next_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_next_fieldname + ! + ! Purpose: Calling this routine results in field_name being set to the name of + ! the field currently pointed to. If istatus /= 0 upon return, an error + ! occurred, and the value of field_name is undefined. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_next_fieldname(field_name, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + character (len=128), intent(out) :: field_name + + istatus = 1 + + if (next_field <= num_entries) then + + field_name = source_fieldname(next_field) + next_field = next_field + 1 + istatus = 0 + + end if + + end subroutine get_next_fieldname + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_next_output_fieldname + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive subroutine get_next_output_fieldname(nest_num, field_name, ndims, & + min_cat, max_cat, istagger, memorder, & + dimnames, units, description, sr_x, sr_y, & + derived_from, istatus) + + use gridinfo_module + + implicit none + +#include "wrf_io_flags.h" + + ! Arguments + integer, intent(in) :: nest_num + integer, intent(out) :: istatus, ndims, istagger, min_cat, max_cat + integer, intent(out) :: sr_x, sr_y + character (len=128), intent(out) :: memorder, field_name, units, description, derived_from + character (len=128), dimension(3), intent(out) :: dimnames + + ! Local variables + integer :: temp_fieldtype + integer, dimension(MAX_LANDMASK_CATEGORIES) :: landmask + logical :: is_water_mask, is_dom_only + character (len=128) :: domcat_name, dfdx_name, dfdy_name + character (len=256) :: temphash + + istatus = 1 + + if (output_field_state == RETURN_LANDMASK) then + call hash_init(duplicate_fnames) + call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus) + derived_from = '' + last_output_fieldname(1:128) = field_name(1:128) + if (istatus == 0) then + temphash(129:256) = ' ' + temphash(1:128) = field_name(1:128) + call hash_insert(duplicate_fnames, temphash) + call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus) + ! We will only save the dominant category + if (is_dom_only .and. (istatus == 0)) then + output_field_state = RETURN_DOMCAT_LM + call get_next_output_fieldname(nest_num, field_name, ndims, & + min_cat, max_cat, istagger, & + memorder, dimnames, units, description, & + sr_x, sr_y, derived_from, istatus) + return + else + ndims = 2 + min_cat = 1 + max_cat = 1 + temp_fieldtype = iget_fieldtype(field_name, istatus) + if (istatus == 0) then + if (temp_fieldtype == CONTINUOUS) then + call get_max_levels(field_name, min_cat, max_cat, istatus) + else if (temp_fieldtype == CATEGORICAL) then + call get_max_categories(field_name, min_cat, max_cat, istatus) + end if + if (max_cat - min_cat > 0) ndims = 3 + end if + call get_output_stagger(field_name, istagger, istatus) + if (istagger == M) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + else if (istagger == U) then + dimnames(1) = 'west_east_stag' + dimnames(2) = 'south_north' + else if (istagger == V) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north_stag' + else if (istagger == HH) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + else if (istagger == VV) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + end if + if (ndims == 2) then + memorder = 'XY ' + dimnames(3) = ' ' + else if (ndims == 3) then + memorder = 'XYZ' + call get_z_dim_name(field_name, dimnames(3), istatus) + istatus = 0 + else + memorder = ' ' + dimnames(3) = ' ' + end if + call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus) + call get_source_units(field_name, 1, units, istatus) + if (istatus /= 0) units = '-' + call get_source_descr(field_name, 1, description, istatus) + if (istatus /= 0) description = '-' + istatus = 0 + output_field_state = RETURN_DOMCAT_LM + end if + else + output_field_state = RETURN_FIELDNAME + call get_next_output_fieldname(nest_num, field_name, ndims, & + min_cat, max_cat, istagger, & + memorder, dimnames, units, description, & + sr_x, sr_y, derived_from, istatus) + return + end if + + else if (output_field_state == RETURN_FIELDNAME) then + call get_next_fieldname(field_name, istatus) + derived_from = '' + last_output_fieldname(1:128) = field_name(1:128) + temphash(129:256) = ' ' + temphash(1:128) = field_name(1:128) + if (istatus == 0 .and. (.not. hash_search(duplicate_fnames, temphash))) then + call hash_insert(duplicate_fnames, temphash) + call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus) + ! We will only save the dominant category + if (is_dom_only .and. (istatus == 0)) then + output_field_state = RETURN_DOMCAT + call get_next_output_fieldname(nest_num, field_name, ndims, & + min_cat, max_cat, istagger, & + memorder, dimnames, units, description, & + sr_x, sr_y, derived_from, istatus) + return + + ! Return the fractional field + else + ndims = 2 + min_cat = 1 + max_cat = 1 + temp_fieldtype = iget_fieldtype(field_name, istatus) + if (istatus == 0) then + if (temp_fieldtype == CONTINUOUS) then + call get_max_levels(field_name, min_cat, max_cat, istatus) + else if (temp_fieldtype == CATEGORICAL) then + call get_max_categories(field_name, min_cat, max_cat, istatus) + end if + if (max_cat - min_cat > 0) ndims = 3 + end if + call get_output_stagger(field_name, istagger, istatus) + if (istagger == M) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + else if (istagger == U) then + dimnames(1) = 'west_east_stag' + dimnames(2) = 'south_north' + else if (istagger == V) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north_stag' + else if (istagger == HH) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + else if (istagger == VV) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + end if + if (ndims == 2) then + memorder = 'XY ' + dimnames(3) = ' ' + else if (ndims == 3) then + memorder = 'XYZ' + call get_z_dim_name(field_name, dimnames(3), istatus) + istatus = 0 + else + memorder = ' ' + dimnames(3) = ' ' + end if + call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus) + call get_source_units(field_name, 1, units, istatus) + if (istatus /= 0) units = '-' + call get_source_descr(field_name, 1, description, istatus) + if (istatus /= 0) description = '-' + istatus = 0 + output_field_state = RETURN_DOMCAT + end if + else if (istatus /= 0) then + output_field_state = RETURN_LANDMASK + call hash_destroy(duplicate_fnames) + return + else if (hash_search(duplicate_fnames, temphash)) then + call get_next_output_fieldname(nest_num, field_name, ndims, & + min_cat, max_cat, istagger, & + memorder, dimnames, units, description, & + sr_x, sr_y, derived_from, istatus) + return + end if + + else if (output_field_state == RETURN_DOMCAT .or. & + output_field_state == RETURN_DOMCAT_LM ) then + derived_from = last_output_fieldname + if (output_field_state == RETURN_DOMCAT) then + next_field = next_field - 1 + call get_next_fieldname(field_name, istatus) + else + call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus) + end if + if (istatus == 0) then + call get_domcategory_name(field_name, domcat_name, is_dom_only, istatus) + if (istatus == 0) then + ndims = 2 + min_cat = 1 + max_cat = 1 + call get_output_stagger(field_name, istagger, istatus) + if (istagger == M) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + else if (istagger == U) then + dimnames(1) = 'west_east_stag' + dimnames(2) = 'south_north' + else if (istagger == V) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north_stag' + else if (istagger == HH) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + else if (istagger == VV) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + end if + dimnames(3) = ' ' + memorder = 'XY ' + + call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus) + field_name = domcat_name + units = 'category' + description = 'Dominant category' + if (output_field_state == RETURN_DOMCAT) then + output_field_state = RETURN_DFDX + else + output_field_state = RETURN_DFDX_LM + end if + else + if (output_field_state == RETURN_DOMCAT) then + output_field_state = RETURN_DFDX + else + output_field_state = RETURN_DFDX_LM + end if + call get_next_output_fieldname(nest_num, field_name, ndims, & + min_cat, max_cat, istagger, & + memorder, dimnames, units, description, & + sr_x, sr_y, derived_from, istatus) + return + end if + else + call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DOMCAT, '// & + 'but no field name is found.') + end if + + else if (output_field_state == RETURN_DFDX .or. & + output_field_state == RETURN_DFDX_LM) then + derived_from = last_output_fieldname + if (output_field_state == RETURN_DFDX) then + next_field = next_field - 1 + call get_next_fieldname(field_name, istatus) + else + call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus) + end if + if (istatus == 0) then + call get_dfdx_name(field_name, dfdx_name, istatus) + if (istatus == 0) then + ndims = 2 + min_cat = 1 + max_cat = 1 + temp_fieldtype = iget_fieldtype(field_name, istatus) + if (istatus == 0) then + if (temp_fieldtype == CONTINUOUS) then + call get_max_levels(field_name, min_cat, max_cat, istatus) + else if (temp_fieldtype == CATEGORICAL) then + call get_max_categories(field_name, min_cat, max_cat, istatus) + end if + if (max_cat - min_cat > 0) ndims = 3 + end if + call get_output_stagger(field_name, istagger, istatus) + if (istagger == M) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + else if (istagger == U) then + dimnames(1) = 'west_east_stag' + dimnames(2) = 'south_north' + else if (istagger == V) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north_stag' + else if (istagger == HH) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + else if (istagger == VV) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + end if + if (ndims == 2) then + memorder = 'XY ' + dimnames(3) = ' ' + else if (ndims == 3) then + memorder = 'XYZ' + call get_z_dim_name(field_name, dimnames(3), istatus) + istatus = 0 + else + memorder = ' ' + dimnames(3) = ' ' + end if +!---------- B. Kosovic 2016-10-28 ---- Changes begin +! The following two lines of code are in the wrong place resulting in +! incorrect size of the dfdx array on the nested domain(s) +! field_name = dfdx_name +! units = '-' + + call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus) +! Correct location of the two lines of code is below (see also dfdy) + field_name = dfdx_name + units = '-' +!---------- B. Kosovic 2016-10-28 ----- End of changes + description = 'df/dx' + if (output_field_state == RETURN_DFDX) then + output_field_state = RETURN_DFDY + else + output_field_state = RETURN_DFDY_LM + end if + else + if (output_field_state == RETURN_DFDX) then + output_field_state = RETURN_DFDY + else + output_field_state = RETURN_DFDY_LM + end if + call get_next_output_fieldname(nest_num, field_name, ndims, & + min_cat, max_cat, istagger, & + memorder, dimnames, units, description, & + sr_x, sr_y, derived_from, istatus) + return + end if + else + call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DFDX, '// & + 'but no field name is found.') + end if + + else if (output_field_state == RETURN_DFDY .or. & + output_field_state == RETURN_DFDY_LM) then + derived_from = last_output_fieldname + if (output_field_state == RETURN_DFDY) then + next_field = next_field - 1 + call get_next_fieldname(field_name, istatus) + else + call get_landmask_field(geog_data_res(nest_num), field_name, is_water_mask, landmask, istatus) + end if + if (istatus == 0) then + call get_dfdy_name(field_name, dfdy_name, istatus) + if (istatus == 0) then + ndims = 2 + min_cat = 1 + max_cat = 1 + temp_fieldtype = iget_fieldtype(field_name, istatus) + if (istatus == 0) then + if (temp_fieldtype == CONTINUOUS) then + call get_max_levels(field_name, min_cat, max_cat, istatus) + else if (temp_fieldtype == CATEGORICAL) then + call get_max_categories(field_name, min_cat, max_cat, istatus) + end if + if (max_cat - min_cat > 0) ndims = 3 + end if + call get_output_stagger(field_name, istagger, istatus) + if (istagger == M) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + else if (istagger == U) then + dimnames(1) = 'west_east_stag' + dimnames(2) = 'south_north' + else if (istagger == V) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north_stag' + else if (istagger == HH) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + else if (istagger == VV) then + dimnames(1) = 'west_east' + dimnames(2) = 'south_north' + end if + if (ndims == 2) then + memorder = 'XY ' + dimnames(3) = ' ' + else if (ndims == 3) then + memorder = 'XYZ' + call get_z_dim_name(field_name, dimnames(3), istatus) + istatus = 0 + else + memorder = ' ' + dimnames(3) = ' ' + end if + + call get_subgrid_dim_name(nest_num, field_name, dimnames(1:2), sr_x, sr_y, istatus) + field_name = dfdy_name + units = '-' + description = 'df/dy' + output_field_state = RETURN_FIELDNAME + else + output_field_state = RETURN_FIELDNAME + call get_next_output_fieldname(nest_num, field_name, ndims, & + min_cat, max_cat, istagger, & + memorder, dimnames, units, description, & + sr_x, sr_y, derived_from, istatus) + return + end if + else + call mprintf(.true., ERROR, 'get_next_output_fieldname(): In state DFDY, but no '// & + 'field name is found.') + end if + + end if + + end subroutine get_next_output_fieldname + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_landmask_field + ! + ! Purpose: To return the name of the field from which the landmask is to be + ! computed. If no error occurs, is_water_mask is .true. if the landmask + ! value specifies the value of water, and .false. if the landmask value + ! specifies the value of land. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_landmask_field(res_string, landmask_name, is_water_mask, landmask, istatus) + + implicit none + + ! Arguments + character (len=128), intent(in) :: res_string + integer, dimension(:), intent(out) :: landmask + integer, intent(out) :: istatus + logical, intent(out) :: is_water_mask + character (len=128), intent(out) :: landmask_name + + ! Local variables + integer :: j + integer :: ilen + integer :: idx + integer :: is, ie, sos, eos, comma + character (len=128) :: temp_res, mask_cat_string + + istatus = 1 + + do idx=1,num_entries + + if (list_length(source_landmask_land(idx)) > 0) then + is = 1 + ie = index(res_string(is:128),'+') - 1 + if (ie <= 0) ie = 128 + temp_res = res_string(is:ie) + do while (.not. list_search(source_landmask_land(idx), ckey=temp_res, cvalue=mask_cat_string) & + .and. is <= 128) + is = ie+2 + ie = is + index(res_string(is:128),'+') - 2 + if (ie - is <= 0) ie = 128 + temp_res = res_string(is:ie) + end do + + if (is > 128) then + temp_res = 'default' + if (list_search(source_landmask_land(idx), ckey=temp_res, cvalue=mask_cat_string)) then + is_water_mask = .false. + landmask_name = source_fieldname(idx) + istatus = 0 + end if + else + is_water_mask = .false. + landmask_name = source_fieldname(idx) + istatus = 0 + end if + + end if + + ! Note: The following cannot be an else-if, since different resolutions of data may + ! specify, alternately, a land or a water mask, and in general we need to search + ! both lists + + if (list_length(source_landmask_water(idx)) > 0) then + is = 1 + ie = index(res_string(is:128),'+') - 1 + if (ie <= 0) ie = 128 + temp_res = res_string(is:ie) + do while (.not. list_search(source_landmask_water(idx), ckey=temp_res, cvalue=mask_cat_string) & + .and. is <= 128) + is = ie+2 + ie = is + index(res_string(is:128),'+') - 2 + if (ie - is <= 0) ie = 128 + temp_res = res_string(is:ie) + end do + + if (is > 128) then + temp_res = 'default' + if (list_search(source_landmask_water(idx), ckey=temp_res, cvalue=mask_cat_string)) then + is_water_mask = .true. + landmask_name = source_fieldname(idx) + istatus = 0 + end if + else + is_water_mask = .true. + landmask_name = source_fieldname(idx) + istatus = 0 + end if + end if + + if (istatus == 0) then + j = 1 + sos = 0 + eos = 128 + comma = index(mask_cat_string(sos+1:eos-1),',') + do while (comma > 0 .and. j < MAX_LANDMASK_CATEGORIES) + read(mask_cat_string(sos+1:sos+comma-1),'(i10)') landmask(j) + sos = sos + comma + comma = index(mask_cat_string(sos+1:eos-1),',') + j = j + 1 + end do + read(mask_cat_string(sos+1:eos-1),'(i10)') landmask(j) + j = j + 1 + if (j <= MAX_LANDMASK_CATEGORIES) then ! Terminate list with a flag value + landmask(j) = INVALID + end if + exit + end if + + end do + + end subroutine get_landmask_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_missing_value + ! + ! Pupose: Return the value used in the source data to indicate missing data. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_missing_value(fieldnm, ilevel, rmissing, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + real, intent(out) :: rmissing + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. & + (source_priority(idx) == ilevel)) then + + if (is_missing_value(idx)) then + rmissing = source_missing_value(idx) + istatus = 0 + exit + end if + + end if + end do + + end subroutine get_missing_value + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_source_units + ! + ! Pupose: Return a string giving the units of the specified source data. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_source_units(fieldnm, ilevel, cunits, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + character (len=128), intent(in) :: fieldnm + character (len=128), intent(out) :: cunits + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. & + (source_priority(idx) == ilevel)) then + + if (is_units(idx)) then + cunits = source_units(idx) + istatus = 0 + exit + end if + + end if + end do + + end subroutine get_source_units + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_source_descr + ! + ! Pupose: Return a string giving a description of the specified source data. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_source_descr(fieldnm, ilevel, descr, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + character (len=128), intent(in) :: fieldnm + character (len=128), intent(out) :: descr + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. & + (source_priority(idx) == ilevel)) then + + if (is_units(idx)) then + descr = source_descr(idx) + istatus = 0 + exit + end if + + end if + end do + + end subroutine get_source_descr + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_missing_fill_value + ! + ! Pupose: Return the value to fill missing points with. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_missing_fill_value(fieldnm, rmissing, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + real, intent(out) :: rmissing + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) ) then + + if (is_fill_missing(idx)) then + rmissing = source_fill_missing(idx) + istatus = 0 + exit + end if + + end if + end do + + end subroutine get_missing_fill_value + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_halt_on_missing + ! + ! Pupose: Returns 1 if the program should halt upon encountering a missing + ! value in the final output field, and 0 otherwise. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_halt_on_missing(fieldnm, halt, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + logical, intent(out) :: halt + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + istatus = 0 + halt = .false. + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) ) then + + if (is_halt_missing(idx)) halt = .true. + + end if + end do + + end subroutine get_halt_on_missing + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_masked_value + ! + ! Pupose: If the field is to be masked by the landmask, returns 0 if the field + ! is masked over water and 1 if the field is masked over land. If no mask is + ! to be applied, -1 is returned. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_masked_value(fieldnm, ilevel, masked, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + real, intent(out) :: masked + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + istatus = 0 + masked = -1. + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. & + (source_priority(idx) == ilevel)) then + + if (is_masked(idx)) then + masked = source_masked(idx) + exit + end if + + end if + end do + + end subroutine get_masked_value + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_max_levels + ! + ! Purpose: Returns the number of levels for the field given by fieldnm. + ! The number of levels will generally be specified for continuous fields, + ! whereas min/max category will generally be specified for categorical ones. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_max_levels(fieldnm, min_level, max_level, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: min_level, max_level, istatus + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + logical :: have_found_field + + have_found_field = .false. + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + + if (is_dest_fieldtype(idx) .and. (source_dest_fieldtype(idx) /= CONTINUOUS)) then + call mprintf(.true., WARN, 'In GEOGRID.TBL, destination field type for %s is '// & + 'not continuous and min/max levels specified.', s1=trim(fieldnm)) + end if + if (.not. have_found_field) then + if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then + have_found_field = .true. + istatus = 0 + min_level = source_tile_z_start(idx) + max_level = source_tile_z_end(idx) + else if (is_tile_z(idx)) then + have_found_field = .true. + istatus = 0 + min_level = 1 + max_level = source_tile_z(idx) + end if + + if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then + if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// & + 'and tile_z_end specified for entry %i.',i1=idx) + end if + end if + else + if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then + if (source_tile_z_start(idx) < min_level) min_level = source_tile_z_start(idx) + if (source_tile_z_end(idx) > max_level) max_level = source_tile_z_end(idx) + else if (is_tile_z(idx)) then + if (min_level > 1) min_level = 1 + if (source_tile_z(idx) > max_level) max_level = source_tile_z(idx) + end if + + if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then + if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// & + 'and tile_z_end specified for entry %i.',i1=idx) + end if + end if + end if + + end if + end do + + end subroutine get_max_levels + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_source_levels + ! + ! Purpose: Return the min and max z-index for the source data for fieldname + ! at a specified priority level (compared with the min/max level over + ! all priority levels, as given by get_max_levels). + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_source_levels(fieldnm, ilevel, min_level, max_level, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: min_level, max_level, istatus + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (ilevel == source_priority(idx)) then + + if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then + istatus = 0 + min_level = source_tile_z_start(idx) + max_level = source_tile_z_end(idx) + else if (is_tile_z(idx)) then + istatus = 0 + min_level = 1 + max_level = source_tile_z(idx) + end if + + if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then + if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start '// & + 'and tile_z_end specified for entry %i.',i1=idx) + end if + end if + + end if + end if + end do + + end subroutine get_source_levels + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_max_categories + ! + ! Purpose: Returns the minimum category and the maximum category for the field + ! given by fieldnm. + ! Min/max category will generally be specified for categorical fields, + ! whereas the number of levels will generally be specified for continuous + ! fields. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_max_categories(fieldnm, min_category, max_category, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: min_category, max_category, istatus + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + logical :: have_found_field + + have_found_field = .false. + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + + if (is_dest_fieldtype(idx) .and. (source_dest_fieldtype(idx) /= CATEGORICAL)) then + call mprintf(.true., WARN, & + 'In GEOGRID.TBL, cannot get min/max categories for continuous '// & + 'field %s at entry %i. Perhaps the user has requested to '// & + 'perform a strange operation on the field.', s1=trim(fieldnm), i1=idx) + end if + if (.not. have_found_field) then + if (is_category_min(idx) .and. is_category_max(idx)) then + have_found_field = .true. + istatus = 0 + min_category = source_category_min(idx) + max_category = source_category_max(idx) + else if (is_category_min(idx) .or. is_category_max(idx)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category and '// & + 'max_category specified for entry %i.',i1=idx) + end if + else + if (is_category_min(idx) .and. is_category_max(idx)) then + if (source_category_min(idx) < min_category) min_category = source_category_min(idx) + if (source_category_max(idx) > max_category) max_category = source_category_max(idx) + else if (is_category_min(idx) .or. is_category_max(idx)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category and '// & + 'max_category specified for entry %i.',i1=idx) + end if + end if + + end if + end do + + end subroutine get_max_categories + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_source_categories + ! + ! Purpose: Return the min and max category for the source data for fieldname + ! at a specified priority level (compared with the min/max category over + ! all priority levels, as given by get_max_categories). + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_source_categories(fieldnm, ilevel, min_category, max_category, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: min_category, max_category, istatus + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (ilevel == source_priority(idx)) then + + if (is_category_min(idx) .and. is_category_max(idx)) then + istatus = 0 + min_category = source_category_min(idx) + max_category = source_category_max(idx) + else if (is_category_min(idx) .or. is_category_max(idx)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of min_category '// & + 'and max_category specified for entry %i.',i1=idx) + end if + + end if + end if + end do + + end subroutine get_source_categories + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_domcategory_name + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_domcategory_name(fieldnm, domcat_name, ldominant_only, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + logical, intent(out) :: ldominant_only + character (len=128), intent(in) :: fieldnm + character (len=128), intent(out) :: domcat_name + + ! Local variables + integer :: idx + + istatus = 1 + ldominant_only = .false. + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + + if (is_dominant_category(idx)) then + domcat_name = source_dominant_category(idx) + istatus = 0 + if (is_dominant_only(idx)) then + call mprintf(.true., WARN, 'In GEOGRID.TBL, both dominant_category and '// & + 'dominant_only are specified in entry %i. Using specification '// & + 'for dominant_category.',i1=idx) + is_dominant_only(idx) = .false. + end if + exit + + else if (is_dominant_only(idx)) then + domcat_name = source_dominant_only(idx) + ldominant_only = .true. + istatus = 0 + exit + end if + + end if + end do + + end subroutine get_domcategory_name + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_dfdx_name + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_dfdx_name(fieldnm, dfdx_name, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + character (len=128), intent(in) :: fieldnm + character (len=128), intent(out) :: dfdx_name + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + + if (is_dfdx(idx)) then + dfdx_name = source_dfdx(idx) + istatus = 0 + exit + end if + + end if + end do + + end subroutine get_dfdx_name + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_dfdy_name + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_dfdy_name(fieldnm, dfdy_name, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + character (len=128), intent(in) :: fieldnm + character (len=128), intent(out) :: dfdy_name + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + + if (is_dfdy(idx)) then + dfdy_name = source_dfdy(idx) + istatus = 0 + exit + end if + + end if + end do + + end subroutine get_dfdy_name + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_z_dim_name + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_z_dim_name(fieldnm, z_dim, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + character (len=128), intent(in) :: fieldnm + character (len=128), intent(out) :: z_dim + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (is_z_dim_name(idx)) then + z_dim = source_z_dim_name(idx) + istatus = 0 + exit + end if + end if + end do + + end subroutine get_z_dim_name + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_field_scale_factor + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_field_scale_factor(fieldnm, ilevel, scale_factor, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + real, intent(out) :: scale_factor + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm)) .and. & + (ilevel == source_priority(idx))) then + + if (is_scale_factor(idx)) then + scale_factor = source_scale_factor(idx) + istatus = 0 + end if + + end if + end do + + end subroutine get_field_scale_factor + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_output_stagger + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_output_stagger(fieldnm, istagger, istatus) + + use gridinfo_module + + implicit none + + ! Arguments + integer, intent(out) :: istatus, istagger + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + istatus = 1 + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + + if (is_output_stagger(idx)) then + istatus = 0 + istagger = source_output_stagger(idx) + exit + else + if (gridtype == 'C') then + istatus = 0 + istagger = M + exit + else if (gridtype == 'E') then + istatus = 0 + istagger = HH + exit + end if + end if + + end if + end do + + end subroutine get_output_stagger + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_subgrid_dim_name + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_subgrid_dim_name(nest_num, field_name, dimnames, & + sub_x, sub_y, istatus) + + use gridinfo_module + + implicit none + integer, intent(in) :: nest_num + integer, intent(out) :: sub_x, sub_y, istatus + character(len=128), intent(in) :: field_name + character(len=128), dimension(2), intent(inout) :: dimnames + integer :: idx, nlen + + sub_x = 1 + sub_y = 1 + + istatus = 0 + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(field_name)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(field_name))) then + if (is_subgrid(idx)) then + istatus = 0 + if (is_output_stagger(idx)) then + call mprintf(.true.,ERROR,'Cannot use subgrids on variables with staggered grids') + end if + dimnames(1) = trim(dimnames(1))//"_subgrid" + dimnames(2) = trim(dimnames(2))//"_subgrid" + sub_x = subgrid_ratio_x(nest_num) + sub_y = subgrid_ratio_y(nest_num) + end if + end if + end do + + end subroutine get_subgrid_dim_name + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_output_flag + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_output_flag(fieldnm, output_flag, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + character (len=*), intent(in) :: fieldnm + character (len=128), intent(out) :: output_flag + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + + if (is_output_flag(idx)) then + output_flag = source_output_flag(idx) + istatus = 0 + exit + end if + + end if + end do + + end subroutine get_output_flag + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_interp_option + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_interp_option(fieldnm, ilevel, interp_opt, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + character (len=128), intent(in) :: fieldnm + character (len=128), intent(out) :: interp_opt + + ! Local variables + integer :: idx + + istatus = 1 + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (ilevel == source_priority(idx)) then + + interp_opt = source_interp_string(idx) + istatus = 0 + exit + + end if + end if + end do + + end subroutine get_interp_option + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_gcel_threshold + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_gcell_threshold(interp_opt, threshold, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + real, intent(out) :: threshold + character (len=128), intent(in) :: interp_opt + + ! Local variables + integer :: i, p1, p2 + + istatus = 1 + threshold = 1.0 + + i = index(interp_opt,'average_gcell') + if (i /= 0) then + ! Move the "average_gcell" option to the beginning +! if (i /= 1) then +! p1 = +! end if + + ! Check for a threshold + p1 = index(interp_opt(i:128),'(') + p2 = index(interp_opt(i:128),')') + if (p1 /= 0 .and. p2 /= 0) then + read(interp_opt(p1+1:p2-1),*,err=1000) threshold + else + call mprintf(.true., WARN, 'Problem with specified threshold '// & + 'for average_gcell interp option. Setting threshold to 0.0.') + threshold = 0.0 + end if + end if + istatus = 0 + + return + + 1000 call mprintf(.true., ERROR, 'Threshold option to average_gcell interpolator '// & + 'must be a real number, enclosed in parentheses immediately '// & + 'after keyword "average_gcell"') + + end subroutine get_gcell_threshold + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_smooth_option + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_smooth_option(fieldnm, smooth_opt, smooth_passes, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus, smooth_opt, smooth_passes + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + + if (is_smooth_option(idx)) then + istatus = 0 + smooth_opt = source_smooth_option(idx) + + if (is_smooth_passes(idx)) then + smooth_passes = source_smooth_passes(idx) + else + smooth_passes = 1 + end if + + exit + end if + + end if + end do + + end subroutine get_smooth_option + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: iget_fieldtype + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function iget_fieldtype(fieldnm, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + ! Return value + integer :: iget_fieldtype + + istatus = 1 + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + + if (is_dest_fieldtype(idx)) then + iget_fieldtype = source_dest_fieldtype(idx) + istatus = 0 + exit + end if + + end if + end do + + end function iget_fieldtype + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: iget_source_fieldtype + ! + ! Purpose: Given a resolution, in degrees, and the name of a field, this + ! function returns the type (categorical, continuous, etc.) of the source + ! data that will be used. This may, in general, depend on the field name + ! and the resolution; for example, near 30 second resolution, land use data + ! may come from a categorical field, whereas for lower resolutions, it may + ! come from arrays of land use fractions for each category. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function iget_source_fieldtype(fieldnm, ilevel, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + character (len=128), intent(in) :: fieldnm + + ! Return value + integer :: iget_source_fieldtype + + ! Local variables + integer :: idx + + ! Find information about the source tiles for the specified fieldname + istatus = 1 + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (ilevel == source_priority(idx)) then + istatus = 0 + iget_source_fieldtype = source_fieldtype(idx) + exit + end if + end if + end do + + end function iget_source_fieldtype + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_data_tile + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_data_tile(xlat, xlon, ilevel, field_name, & + file_name, array, start_x_dim, end_x_dim, start_y_dim, & + end_y_dim, start_z_dim, end_z_dim, npts_bdr, & + istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + integer, intent(out) :: start_x_dim, end_x_dim, & + start_y_dim, end_y_dim, & + start_z_dim, end_z_dim, & + npts_bdr + real, intent(in) :: xlat, xlon ! Location that tile should contain + real, pointer, dimension(:,:,:) :: array ! The array to be allocated by this routine + character (len=128), intent(in) :: field_name + character (len=256), intent(out) :: file_name + + ! Local variables + integer :: j, k + integer :: local_wordsize, local_endian, sign_convention, irow_order, strlen + integer :: xdim,ydim,zdim + real :: scalefac + real, allocatable, dimension(:) :: temprow + + call get_tile_fname(file_name, xlat, xlon, ilevel, field_name, istatus) + + if (index(file_name, 'OUTSIDE') /= 0) then + istatus = 1 + return + else if (hash_search(bad_files, file_name)) then + istatus = 1 + return + end if + + call get_tile_dimensions(xlat, xlon, start_x_dim, end_x_dim, start_y_dim, end_y_dim, & + start_z_dim, end_z_dim, npts_bdr, local_wordsize, local_endian, & + sign_convention, ilevel, field_name, istatus) + + xdim = (end_x_dim-start_x_dim+1) + ydim = (end_y_dim-start_y_dim+1) + zdim = (end_z_dim-start_z_dim+1) + + if (associated(array)) deallocate(array) + allocate(array(xdim,ydim,zdim)) + + call get_row_order(field_name, ilevel, irow_order, istatus) + if (istatus /= 0) irow_order = BOTTOM_TOP + + call s_len(file_name,strlen) + + scalefac = 1.0 + + call read_geogrid(file_name, strlen, array, xdim, ydim, zdim, & + sign_convention, local_endian, scalefac, local_wordsize, istatus) + + if (irow_order == TOP_BOTTOM) then + allocate(temprow(xdim)) + do k=1,zdim + do j=1,ydim + if (ydim-j+1 <= j) exit + temprow(1:xdim) = array(1:xdim,j,k) + array(1:xdim,j,k) = array(1:xdim,ydim-j+1,k) + array(1:xdim,ydim-j+1,k) = temprow(1:xdim) + end do + end do + deallocate(temprow) + end if + + if (istatus /= 0) then + start_x_dim = INVALID + start_y_dim = INVALID + end_x_dim = INVALID + end_y_dim = INVALID + + call hash_insert(bad_files, file_name) + end if + + end subroutine get_data_tile + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_row_order + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_row_order(fieldnm, ilevel, irow_order, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + character (len=128), intent(in) :: fieldnm + integer, intent(out) :: irow_order, istatus + + ! Local variables + integer :: idx + + istatus = 1 + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (ilevel == source_priority(idx)) then + if (is_row_order(idx)) then + irow_order = source_row_order(idx) + istatus = 0 + exit + end if + end if + end if + end do + + end subroutine get_row_order + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_tile_dimensions + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_tile_dimensions(xlat, xlon, start_x_dim, end_x_dim, start_y_dim, end_y_dim, & + start_z_dim, end_z_dim, npts_bdr, bytes_per_datum, endianness, & + sign_convention, ilevel, fieldnm, istatus) + + use llxy_module + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: start_x_dim, end_x_dim, & + start_y_dim, end_y_dim, & + start_z_dim, end_z_dim, & + npts_bdr, & + bytes_per_datum, endianness, & + sign_convention, istatus + real, intent(in) :: xlat, xlon + character (len=128), intent(in) :: fieldnm + + ! Local variables + integer :: idx, current_domain + real :: rx, ry + + istatus = 1 + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (ilevel == source_priority(idx)) then + istatus = 0 + exit + end if + end if + end do + + if (istatus /= 0) then + start_x_dim = 1 + start_y_dim = 1 + start_z_dim = 1 + end_x_dim = 1 + end_y_dim = 1 + end_z_dim = 1 + bytes_per_datum = 0 + return + end if + + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call lltoxy(xlat, xlon, rx, ry, M) + call select_domain(current_domain) + + start_x_dim = source_tile_x(idx) * nint(real(floor((rx-0.5) / real(source_tile_x(idx))))) + 1 + end_x_dim = start_x_dim + source_tile_x(idx) - 1 + + start_y_dim = source_tile_y(idx) * nint(real(floor((ry-0.5) / real(source_tile_y(idx))))) + 1 + end_y_dim = start_y_dim + source_tile_y(idx) - 1 + + if (is_tile_z_start(idx) .and. is_tile_z_end(idx)) then + start_z_dim = source_tile_z_start(idx) + end_z_dim = source_tile_z_end(idx) + else if (is_tile_z(idx)) then + start_z_dim = 1 + end_z_dim = source_tile_z(idx) + end if + + if (.not. (is_tile_z_start(idx) .and. is_tile_z_end(idx))) then + if (is_tile_z_start(idx) .or. is_tile_z_end(idx)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, only one of tile_z_start and '// & + 'tile_z_end specified for entry %i.',i1=idx) + end if + end if + + if (is_tile_bdr(idx)) then + npts_bdr = source_tile_bdr(idx) + else + npts_bdr = 0 + end if + + start_x_dim = start_x_dim - npts_bdr + end_x_dim = end_x_dim + npts_bdr + start_y_dim = start_y_dim - npts_bdr + end_y_dim = end_y_dim + npts_bdr + + if (is_wordsize(idx)) then + bytes_per_datum = source_wordsize(idx) + else + bytes_per_datum = 1 + call mprintf(.true.,ERROR,'In GEOGRID.TBL, no wordsize specified for data in entry %i.',i1=idx) + end if + + if (is_endian(idx)) then + endianness = source_endian(idx) + else + endianness = BIG_ENDIAN + end if + + if (is_signed(idx)) then + sign_convention = 1 + else + sign_convention = 0 + end if + + end subroutine get_tile_dimensions + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_tile_fname + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_tile_fname(test_fname, xlat, xlon, ilevel, fieldname, istatus) + + use llxy_module + use gridinfo_module + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + real, intent(in) :: xlat, xlon + character (len=*), intent(in) :: fieldname + character (len=256), intent(out) :: test_fname + + ! Local variables + integer :: current_domain, idx + real :: rx, ry + + istatus = 1 + write(test_fname, '(a)') 'TILE.OUTSIDE.DOMAIN' + + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldname)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldname))) then + if (ilevel == source_priority(idx)) then + istatus = 0 + exit + end if + end if + end do + + if (istatus /= 0) return + + current_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call lltoxy(xlat, xlon, rx, ry, M) + call select_domain(current_domain) + +! rx = real(source_tile_x(idx)) * real(floor((rx-0.5*source_dx(idx))/ real(source_tile_x(idx)))) + 1.0 +! ry = real(source_tile_y(idx)) * real(floor((ry-0.5*source_dy(idx))/ real(source_tile_y(idx)))) + 1.0 + rx = real(source_tile_x(idx)) * real(floor((rx-0.5) / real(source_tile_x(idx)))) + 1.0 + ry = real(source_tile_y(idx)) * real(floor((ry-0.5) / real(source_tile_y(idx)))) + 1.0 + + if (rx > 0. .and. ry > 0.) then + select case(source_filename_digits(idx)) + case (5) + write(test_fname, '(a,i5.5,a1,i5.5,a1,i5.5,a1,i5.5)') trim(source_path(idx)), & + nint(rx),'-',nint(rx)+source_tile_x(idx)-1,'.',nint(ry),'-',nint(ry)+source_tile_y(idx)-1 + case (6) + write(test_fname, '(a,i6.6,a1,i6.6,a1,i6.6,a1,i6.6)') trim(source_path(idx)), & + nint(rx),'-',nint(rx)+source_tile_x(idx)-1,'.',nint(ry),'-',nint(ry)+source_tile_y(idx)-1 + case default + call mprintf(.true., ERROR, 'In GEOGRID.TBL, for index file of data at '// & + 'entry %i, filename_digits must be either 5 or 6.', i1=idx) + istatus = 1 + return + end select + end if + + end subroutine get_tile_fname + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_source_resolution + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_source_resolution(fieldnm, ilevel, src_dx, src_dy, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + real, intent(out) :: src_dx, src_dy + character (len=*), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + istatus = 1 + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (ilevel == source_priority(idx)) then + if (is_dx(idx) .and. is_dy(idx)) then + src_dx = source_dx(idx) + src_dy = source_dy(idx) + if (source_proj(idx) /= PROJ_LATLON) then + src_dx = src_dx / 111000. + src_dy = src_dy / 111000. + end if + istatus = 0 + exit + end if + end if + end if + end do + + end subroutine get_source_resolution + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: check_priority_level + ! + ! Purpose: Determines whether there exists the specified priority level for + ! the specified field. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine check_priority_level(fieldnm, ilevel, istatus) + + implicit none + + ! Arguments + character (len=*), intent(in) :: fieldnm + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + + ! Local variables + integer :: idx + + istatus = 1 + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (ilevel == source_priority(idx)) then + istatus = 0 + end if + end if + end do + + end subroutine check_priority_level + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_data_projection + ! + ! Purpose: To acquire the parameters necessary in defining the grid on which + ! the user-specified data for field 'fieldnm' are given. + ! + ! NOTES: If the routine successfully acquires values for all necessary + ! parameters, istatus is set to 0. In case of an error, + ! OR IF THE USER HAS NOT SPECIFIED A TILE OF DATA FOR FIELDNM, + ! istatus is set to 1. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_data_projection(fieldnm, iproj, stand_lon, truelat1, truelat2, & + dxkm, dykm, known_x, known_y, known_lat, known_lon, ilevel, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: ilevel + integer, intent(out) :: iproj, istatus + real, intent(out) :: stand_lon, truelat1, truelat2, dxkm, dykm, & + known_x, known_y, known_lat, known_lon + character (len=*), intent(in) :: fieldnm + + ! Local variables + integer :: idx + + istatus = 1 + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (ilevel == source_priority(idx)) then + istatus = 0 + if (is_proj(idx)) then + iproj = source_proj(idx) + else + iproj = 1 + call mprintf(.true., ERROR, & + 'In GEOGRID.TBL, no specification for projection in entry %i.',i1=idx) + end if + if (is_known_x(idx)) then + known_x = source_known_x(idx) + else + known_x = 1. + call mprintf(.true., ERROR, & + 'In GEOGRID.TBL, no specification for known_x in entry %i.',i1=idx) + end if + if (is_known_y(idx)) then + known_y = source_known_y(idx) + else + known_y = 1. + call mprintf(.true., ERROR, & + 'In GEOGRID.TBL, no specification for known_y in entry %i.',i1=idx) + end if + if (is_known_lat(idx)) then + known_lat = source_known_lat(idx) + else + known_lat = 1. + call mprintf(.true., ERROR, & + 'In GEOGRID.TBL, no specification for known_lat in entry %i.',i1=idx) + end if + if (is_known_lon(idx)) then + known_lon = source_known_lon(idx) + else + known_lon = 1. + call mprintf(.true., ERROR, & + 'In GEOGRID.TBL, no specification for known_lon in entry %i.',i1=idx) + end if + if (is_truelat1(idx)) then + truelat1 = source_truelat1(idx) + else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then + truelat1 = 1. + call mprintf(.true., WARN, & + 'In GEOGRID.TBL, no specification for truelat1 in entry %i.',i1=idx) + end if + if (is_truelat2(idx)) then + truelat2 = source_truelat2(idx) + else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then + truelat2 = 1. + call mprintf(.true., WARN, & + 'In GEOGRID.TBL, no specification for truelat2 in entry %i.',i1=idx) + end if + if (is_stdlon(idx)) then + stand_lon = source_stdlon(idx) + else if (is_proj(idx) .and. source_proj(idx) /= PROJ_LATLON) then + stand_lon = 1. + call mprintf(.true., WARN, & + 'In GEOGRID.TBL, no specification for stdlon in entry %i.',i1=idx) + end if + if (is_dx(idx)) then + dxkm = source_dx(idx) + else + dxkm = 1. + call mprintf(.true., ERROR, & + 'In GEOGRID.TBL, no specification for dx in entry %i.',i1=idx) + end if + if (is_dy(idx)) then + dykm = source_dy(idx) + else + dykm = 1. + call mprintf(.true., ERROR, & + 'In GEOGRID.TBL, no specification for dy in entry %i.',i1=idx) + end if + exit + end if + end if + end do + + end subroutine get_data_projection + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_source_opt_status + ! + ! Purpose: Determines whether a field is optional and can be skipped + ! + ! If ilevel is specified as 0, the return value, istatus, will be 0 if + ! any priority level is available for the field, and 1 otherwise. Otherwise, + ! istatus will be set to 0 only if the specified priority level for + ! the field is available. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_source_opt_status(fieldnm, ilevel, istatus) + + implicit none + + ! Arguments + character (len=*), intent(in) :: fieldnm + integer, intent(in) :: ilevel + integer, intent(out) :: istatus + + ! Local variables + integer :: idx + + + ! Any priority level is available + if (ilevel == 0) then + istatus = 1 + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (.not. is_not_found(idx)) then + istatus = 0 + exit + end if + end if + end do + + ! Only the specified level is to be checked + else + istatus = 0 + do idx=1,num_entries + if ((index(source_fieldname(idx),trim(fieldnm)) /= 0) .and. & + (len_trim(source_fieldname(idx)) == len_trim(fieldnm))) then + if (ilevel == source_priority(idx)) then + if (is_not_found(idx)) then + istatus = 1 + exit + end if + end if + end if + end do + end if + + end subroutine get_source_opt_status + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: check_data_specification + ! + ! Purpose: To check for obvious errors in the user source data specifications. + ! Returns .true. if specification passes all checks, and .false. otherwise. + ! For failing checks, diagnostic messages are printed. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function check_data_specification( ) + + implicit none + + ! Return value + logical :: check_data_specification + + ! Local variables + integer :: i, j, istatus + integer, pointer, dimension(:) :: priorities + real :: rmissing + logical :: begin_priority, halt + character (len=128) :: cur_name + + check_data_specification = .false. + + ! Check that each specification has a name, priority level, and path + do i=1,num_entries + if (.not. is_fieldname(i)) then + call mprintf(.true., ERROR, & + 'In GEOGRID.TBL, specification %i does not have a name.',i1=i) + end if + if (.not. is_priority(i)) then + call mprintf(.true., ERROR, & + 'In GEOGRID.TBL, specification %i does not have a priority.',i1=i) + end if + if (list_length(source_res_path(i)) == 0) then + call mprintf(.true., ERROR, & + 'In GEOGRID.TBL, no path (relative or absolute) is specified '// & + 'for entry %i.',i1=i) + end if + end do + + ! The fill_missing and halt_on_missing options are mutually exclusive + do i=1,num_entries + call get_halt_on_missing(source_fieldname(i), halt, istatus) + call get_missing_fill_value(source_fieldname(i), rmissing, istatus) + if (halt .and. (istatus == 0)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, the halt_on_missing and fill_missing '// & + 'options are mutually exclusive, but both are given for field %s', & + s1=trim(source_fieldname(i))) + end if + end do + + ! Check that the field from which landmask is calculated is not output on a staggering + do i=1,num_entries + if (list_length(source_landmask_land(i)) > 0 .or. list_length(source_landmask_water(i)) > 0) then + if (is_output_stagger(i)) then + if (source_output_stagger(i) /= M) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be derived from '// & + 'a field that is computed on a staggered grid at entry %i.',i1=i) + end if + end if + end if + end do + + ! Also check that any field that is to be masked by the landmask is not output on a staggering + do i=1,num_entries + if (is_masked(i) .and. is_output_stagger(i)) then + if (source_output_stagger(i) /= M) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be used with '// & + 'a field that is computed on a staggered grid at entry %i.',i1=i) + end if + end if + end do + + allocate(priorities(num_entries)) + + ! Now check that priorities for each source are unique and in the interval [1,n], n <= num_entries + do i=1,num_entries + priorities = 0 + cur_name = source_fieldname(i) + do j=1,num_entries + if (source_fieldname(j) == cur_name) then + + if (source_priority(j) > num_entries .or. source_priority(j) < 1) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, priorities for %s do not '// & + 'form a sequence 1,2,...,n.', s1=trim(cur_name)) + + else + if (priorities(source_priority(j)) == 1) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, more than one entry for %s '// & + 'has priority %i.', s1=trim(cur_name), i1=source_priority(j)) + + else + priorities(source_priority(j)) = 1 + end if + end if + + end if + end do + + begin_priority = .false. + do j=num_entries,1,-1 + if (.not.begin_priority .and. priorities(j) == 1) then + begin_priority = .true. + else if (begin_priority .and. priorities(j) == 0) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, no entry for %s has '// & + 'priority %i, but an entry has priority %i.', & + s1=trim(cur_name), i1=j, i2=j+1) + end if + end do + end do + + deallocate(priorities) + + ! Units must match for all priority levels of a field + do i=1,num_entries + if (source_priority(i) == 1) then + do j=1,num_entries + if ((source_fieldname(i) == source_fieldname(j)) .and. & + (source_units(i) /= source_units(j))) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, units for %s at entry %i '// & + 'do not match units at entry %i (%s)', & + s1=trim(source_fieldname(i)), i1=j, i2=i, s2=trim(source_units(i))) + end if + end do + end if + end do + + ! Make sure that user has not asked to calculate landmask from a continuous field + do i=1,num_entries + if (is_dest_fieldtype(i)) then + if (source_dest_fieldtype(i) == CONTINUOUS) then + if (list_length(source_landmask_water(i)) > 0 .or. list_length(source_landmask_land(i)) > 0) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, landmask cannot be '// & + 'calculated from a continuous destination field at entry %i.',i1=i) + end if + end if + end if + end do + + ! If either min_category or max_category is specified, then both must be specified + do i=1,num_entries + if (is_category_min(i) .or. is_category_max(i)) then + if (.not. is_category_min(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, for index file of data at '// & + 'entry %i, category_max is specified, but category_min is '// & + 'not. Both must be specified.',i1=i) + else if (.not. is_category_max(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, for index file of data at '// & + 'entry %i, category_min is specified, but category_max is '// & + 'not. Both must be specified.',i1=i) + end if + end if + end do + + ! For continuous data, (category_max - category_min + 1) should equal tile_z + do i=1,num_entries + if (is_fieldtype(i)) then + if (source_fieldtype(i) == CONTINUOUS) then + if (is_category_max(i) .and. is_category_min(i) .and. is_tile_z(i)) then + if (source_tile_z(i) /= (source_category_max(i) - source_category_min(i) + 1)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, tile_z must equal '// & + '(category_max - category_min + 1) at entry %i.',i1=i) + end if + else if (is_category_max(i) .and. is_category_min(i) .and. & + is_tile_z_start(i) .and. is_tile_z_end(i)) then + if (source_tile_z_end(i) /= source_category_max(i) .or. & + source_tile_z_start(i) /= source_category_min(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, tile_z_end must equal '// & + 'category_max, and tile_z_start must equal category_min '// & + 'at entry %i.',i1=i) + end if + end if + end if + end if + end do + + ! Make sure that user has not named a dominant category or computed slope field + ! the same as a fractional field + do i=1,num_entries + if (source_dominant_category(i) == source_fieldname(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category cannot have '// & + 'the same name as the field at entry %i.',i1=i) + end if + + do j=1,num_entries + if (.not. is_dominant_only(i)) then + if (is_dfdx(j)) then + if (source_dfdx(j) == source_fieldname(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, field name at entry %i '// & + 'cannot have the same name as the slope field df_dx at entry %i.', & + i1=i, i2=j) + end if + end if + if (is_dfdy(j)) then + if (source_dfdy(j) == source_fieldname(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, field name at entry %i '// & + 'cannot have the same name as the slope field df_dy at entry %i.', & + i1=i, i2=j) + end if + end if + if (is_dfdx(j) .and. is_dominant_category(i)) then + if (source_dfdx(j) == source_dominant_category(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// & + 'entry %i cannot have the same name as the slope field df_dx '// & + 'at entry %i.',i1=i, i2=j) + end if + end if + if (is_dfdy(j) .and. is_dominant_category(i)) then + if (source_dfdy(j) == source_dominant_category(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// & + 'entry %i cannot have the same name as the slope field '// & + 'df_dy at entry %i.',i1=i, i2=j) + end if + end if + else + if (is_dfdx(j)) then + if (source_dfdx(j) == source_dominant_only(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// & + 'entry %i cannot have the same name as the slope field '// & + 'df_dx at entry %i.',i1=i, i2=j) + end if + end if + if (is_dfdy(j)) then + if (source_dfdy(j) == source_dominant_only(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant field name at '// & + 'entry %i cannot have the same name as the slope field '// & + 'df_dy at entry %i.',i1=i, i2=j) + end if + end if + end if + if (i /= j) then + if (is_dfdx(i)) then + if (is_dfdx(j)) then + if (source_dfdx(j) == source_dfdx(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dx at '// & + 'entry %i cannot have the same name as the slope '// & + 'field df_dx at entry %i.',i1=i, i2=j) + end if + end if + if (is_dfdy(j)) then + if (source_dfdy(j) == source_dfdx(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dx at '// & + 'entry %i cannot have the same name as the slope field '// & + 'df_dy at entry %i.',i1=i, i2=j) + end if + end if + end if + if (is_dfdy(i)) then + if (is_dfdx(j)) then + if (source_dfdx(j) == source_dfdy(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dy at '// & + 'entry %i cannot have the same name as the slope field '// & + 'df_dx at entry %i.',i1=i, i2=j) + end if + end if + if (is_dfdy(j)) then + if (source_dfdy(j) == source_dfdy(i)) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, slope field df_dy at '// & + 'entry %i cannot have the same name as the slope field '// & + 'df_dy at entry %i.',i1=i, i2=j) + end if + end if + end if + if (is_dominant_category(i)) then + if (source_dominant_category(i) == source_fieldname(j)) then ! Possible exception + if (.not. (is_dominant_only(j) .and. (source_dominant_category(i) /= source_dominant_only(j)))) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at '// & + 'entry %i cannot have the same name as the field at '// & + 'entry %i.',i1=i, i2=j) + end if + else if (is_dominant_category(j) .and. & + (source_dominant_category(i) == source_dominant_category(j))) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at entry '// & + '%i cannot have the same name as dominant category at '// & + 'entry %i.',i1=i, i2=j) + else if (is_dominant_only(j) .and. & + (source_dominant_category(i) == source_dominant_only(j))) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant category at '// & + 'entry %i cannot have the same name as dominant_only '// & + 'category at entry %i.',i1=i, i2=j) + end if + else if (is_dominant_only(i)) then + if (source_dominant_only(i) == source_fieldname(j)) then ! Possible exception + if (.not. (is_dominant_only(j) .and. (source_dominant_only(i) /= source_dominant_only(j)))) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// & + 'at entry %i cannot have the same name as the field at '// & + 'entry %i.',i1=i, i2=j) + end if + else if (is_dominant_category(j) .and. & + (source_dominant_only(i) == source_dominant_category(j))) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// & + 'at entry %i cannot have the same name as dominant '// & + 'category at entry %i.',i1=i, i2=j) + else if (is_dominant_only(j) .and. & + (source_dominant_only(i) == source_dominant_only(j))) then + call mprintf(.true., ERROR, 'In GEOGRID.TBL, dominant_only category '// & + 'at entry %i cannot have the same name as dominant_only '// & + 'category at entry %i.',i1=i, i2=j) + end if + end if + end if + end do + end do + + check_data_specification = .true. + + end function check_data_specification + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: s_len + ! + ! Purpose: This routine receives a fortran string, and returns the number of + ! characters in the string before the first "space" is encountered. It + ! considers ascii characters 33 to 126 to be valid characters, and ascii + ! 0 to 32, and 127 to be "space" characters. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine s_len(string, s_length) + + implicit none + + ! Arguments + character (len=*), intent(in) :: string + integer, intent(out) :: s_length + + ! Local variables + integer :: i, len_str, aval + logical :: space + + space = .false. + i = 1 + len_str = len(string) + s_length = len_str + do while ((i .le. len_str) .and. (.not. space)) + aval = ichar(string(i:i)) + if ((aval .lt. 33) .or. (aval .gt. 126)) then + s_length = i - 1 + space = .true. + endif + i = i + 1 + enddo + + end subroutine s_len + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: display_optional_field_msgs + ! + ! Purpose: This routine prints out information regarding any optional fields + ! in the GEOGRID.TBL file that were not found at run-time and were + ! skipped. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine display_optional_field_msgs() + + implicit none + + integer :: idx + logical :: do_prints + + + do_prints = .false. + + do idx=1,num_entries + if (is_optional(idx) .and. is_not_found(idx)) then + do_prints = .true. + exit + end if + end do + + if (do_prints) then + call mprintf(.true., STDOUT, ' ') + call mprintf(.true., STDOUT, ' Optional fields not processed by geogrid:') + call mprintf(.true., LOGFILE, 'Optional fields not processed by geogrid:') + + do idx=1,num_entries + if (is_optional(idx) .and. is_not_found(idx)) then + call mprintf(.true., STDOUT, ' %s (priority=%i, resolution=''%s'', path=''%s'')', s1=source_fieldname(idx), & + i1=source_priority(idx), s2=source_res(idx), s3=source_path(idx)) + call mprintf(.true., LOGFILE, ' %s (priority=%i, resolution=''%s'', path=''%s'')', s1=source_fieldname(idx), & + i1=source_priority(idx), s2=source_res(idx), s3=source_path(idx)) + end if + end do + + call mprintf(.true., STDOUT, ' ') + end if + + end subroutine display_optional_field_msgs + +end module source_data_module diff --git a/WPS/geogrid/src/wrf_debug.F b/WPS/geogrid/src/wrf_debug.F new file mode 100644 index 00000000..91660f2d --- /dev/null +++ b/WPS/geogrid/src/wrf_debug.F @@ -0,0 +1,55 @@ +subroutine wrf_debug(i, msg) + + use gridinfo_module + + implicit none + + ! Arguments + integer, intent(in) :: i + character (len=*), intent(in) :: msg + + if (debug_level > 0) then + write(6,*) 'WRF_DEBUG:'//msg + end if + +end subroutine wrf_debug + + +subroutine wrf_message(msg) + + implicit none + + ! Arguments + character (len=*), intent(in) :: msg + + write(6,*) 'WRF_MESSAGE:'//msg + +end subroutine wrf_message + + +subroutine wrf_error_fatal(msg) + + implicit none + + ! Arguments + character (len=*), intent(in) :: msg + + write(6,*) 'WRF_ERROR_FATAL:'//msg + + stop + +end subroutine wrf_error_fatal + + +subroutine wrf_error_fatal3(msg) + + implicit none + + ! Arguments + character (len=*), intent(in) :: msg + + write(6,*) 'WRF_ERROR_FATAL:'//msg + + stop + +end subroutine wrf_error_fatal3 diff --git a/WPS/geogrid/src/write_geogrid.c b/WPS/geogrid/src/write_geogrid.c new file mode 100644 index 00000000..f615682c --- /dev/null +++ b/WPS/geogrid/src/write_geogrid.c @@ -0,0 +1,122 @@ +/* File: write_geogrid.c + + Sample subroutine to write an array into the geogrid binary format. + + Side effects: Upon completion, a file named 00001-.00001- is + created, where is the argument nx and is the argument ny, + both in i5.5 format. + + Notes: Depending on the compiler and compiler flags, the name of + the write_geogrid() routine may need to be adjusted with respect + to the number of trailing underscores when calling from Fortran. + + Michael G. Duda, NCAR/MMM +*/ + +#include +#include +#include + +#ifdef _UNDERSCORE +#define write_geogrid write_geogrid_ +#endif +#ifdef _DOUBLEUNDERSCORE +#define write_geogrid write_geogrid__ +#endif + +#define BIG_ENDIAN 0 +#define LITTLE_ENDIAN 1 + +int write_geogrid( + float * rarray, /* The array to be written */ + int * nx, /* x-dimension of the array */ + int * ny, /* y-dimension of the array */ + int * nz, /* z-dimension of the array */ + int * isigned, /* 0=unsigned data, 1=signed data */ + int * endian, /* 0=big endian, 1=little endian */ + float * scalefactor, /* value to divide array elements by before truncation to integers */ + int * wordsize ) /* number of bytes to use for each array element */ +{ + int i, narray; + int A2, B2; + int A3, B3, C3; + int A4, B4, C4, D4; + unsigned int * iarray; + unsigned char * barray; + char fname[24]; + FILE * bfile; + + narray = (*nx) * (*ny) * (*nz); + + iarray = (unsigned int *)malloc(sizeof(int) * narray); + barray = (unsigned char *)malloc(sizeof(unsigned char) * narray * (*wordsize)); + + /* Scale real-valued array by scalefactor and convert to integers */ + for (i=0; i> 8) & 0xff); + barray[(*wordsize)*i+B2] = (unsigned char)( iarray[i] & 0xff); + } + break; + + case 3: + for(i=0; i> 16) & 0xff); + barray[(*wordsize)*i+B3] = (unsigned char)((iarray[i] >> 8) & 0xff); + barray[(*wordsize)*i+C3] = (unsigned char)( iarray[i] & 0xff); + } + break; + + case 4: + for(i=0; i> 24) & 0xff); + barray[(*wordsize)*i+B4] = (unsigned char)((iarray[i] >> 16) & 0xff); + barray[(*wordsize)*i+C4] = (unsigned char)((iarray[i] >> 8) & 0xff); + barray[(*wordsize)*i+D4] = (unsigned char)( iarray[i] & 0xff); + } + break; + } + + sprintf(fname,"%5.5i-%5.5i.%5.5i-%5.5i",1,*nx,1,*ny); + + /* Write array to file */ + bfile = fopen(fname,"wb"); + fwrite(barray,sizeof(unsigned char),narray*(*wordsize),bfile); + fclose(bfile); + + free(iarray); + free(barray); + + return 0; +} diff --git a/WPS/geogrid/util/ij_to_latlon.F b/WPS/geogrid/util/ij_to_latlon.F new file mode 100644 index 00000000..bec58bfa --- /dev/null +++ b/WPS/geogrid/util/ij_to_latlon.F @@ -0,0 +1,81 @@ +subroutine xytoll(rx,ry,lat,lon,stagger) + + implicit none + + ! Arguments + integer, intent(in) :: stagger + real, intent(in) :: rx, ry + real, intent(out) :: lat, lon + + ! Local variables + integer :: ih,jh + integer :: midcol,midrow,ncol,iadd1,iadd2,imt,jh2,knrow,krem,kv,nrow + real :: dphd,dlmd !Grid increments, degrees + real :: arg1,arg2,d2r,fctr,glatr,glatd,glond,pi, & + r2d,tlatd,tlond,tlatr,tlonr,tlm0,tph0 + + ih = nint(rx) + jh = nint(ry) + + dphd = phi/real((jydim(current_nest_number)-1)/2) + dlmd = lambda/real(ixdim(current_nest_number)-1) + + pi = dacos(-1.0) + d2r = pi/180. + r2d = 1./d2r + tph0 = known_lat*d2r + tlm0 = known_lon*d2r + + midrow = (jydim(current_nest_number)+1)/2 + midcol = ixdim(current_nest_number) + + if (stagger == HH) then + ncol = 2*ih-1+mod(jh+1,2) + tlatd = (jh-midrow)*dphd + tlond = (ncol-midcol)*dlmd + else if (stagger == VV) then + imt = 2*ixdim(current_nest_number)-1 + jh2 = jh/2 + iadd1 = 0 + iadd2 = 0 + + if (2*jh2 == jh) then + iadd1 = -1 + iadd2 = ixdim(current_nest_number)-1 + end if + + kv = (jh2+iadd1)*imt+iadd2+ih + + nrow = 2*((kv-1)/imt) + knrow = imt*nrow/2 + krem = kv-knrow + + if (krem <= ixdim(current_nest_number)-1) then + nrow = nrow+1 + ncol = 2*krem + else + nrow = nrow+2 + ncol = 2*(krem-ixdim(current_nest_number))+1 + end if + tlatd = (nrow-(jydim(current_nest_number)+1)/2)*dphd + tlond = (ncol-ixdim(current_nest_number))*dlmd + end if + + tlatr = tlatd*d2r + tlonr = tlond*d2r + arg1 = sin(tlatr)*cos(tph0)+cos(tlatr)*sin(tph0)*cos(tlonr) + glatr = asin(arg1) + + glatd = glatr*r2d + + arg2 = dcos(tlatr)*dcos(tlonr)/(dcos(glatr)*dcos(tph0))-dtan(glatr)*dtan(tph0) + if (abs(arg2) > 1.) arg2 = abs(arg2)/arg2 + fctr = 1. + if (tlond > 0.) fctr = -1. + + glond = known_lon+fctr*dacos(arg2)*r2d + + xlat = glatd + xlon = glond + +end subroutine xytoll diff --git a/WPS/geogrid/util/latlon_to_ij.F b/WPS/geogrid/util/latlon_to_ij.F new file mode 100644 index 00000000..0c9c2221 --- /dev/null +++ b/WPS/geogrid/util/latlon_to_ij.F @@ -0,0 +1,148 @@ +subroutine lltoxy(lat,lon,rx,ry,stagger) + + implicit none + + ! Arguments + integer, intent(in) :: stagger + real, intent(in) :: lat, lon + real, intent(out) :: rx, ry + + ! Local variables + real :: dphd,dlmd !Grid increments, degrees + integer :: ii,imt,jj,jmt,k,krows,ncol,nrow + real :: glatd !Geographic latitude, positive north + real :: glond !Geographic longitude, positive west + real :: col,d1,d2,d2r,dlm,dlm1,dlm2,dph,glat,glon, & + pi,r2d,row,tlat,tlat1,tlat2, & + tlon,tlon1,tlon2,tph0,tlm0,x,y,z + + glatd = lat + glond = lon + + dphd = phi/real((jydim(current_nest_number)-1)/2) + dlmd = lambda/real(ixdim(current_nest_number)-1) + + pi = dacos(-1.0) + d2r = pi/180. + r2d = 1./d2r + + imt = 2*ixdim(current_nest_number)-1 + jmt = jydim(current_nest_number)/2+1 + + glat = glatd*d2r + glon = glond*d2r + dph = dphd*d2r + dlm = dlmd*d2r + tph0 = known_lat*d2r + tlm0 = known_lon*d2r + + x = cos(tph0)*cos(glat)*cos(glon-tlm0)+sin(tph0)*sin(glat) + y = -cos(glat)*sin(glon-tlm0) + z = cos(tph0)*sin(glat)-sin(tph0)*cos(glat)*cos(glon-tlm0) + tlat = r2d*atan(z/sqrt(x*x+y*y)) + tlon = r2d*atan(y/x) + + row = tlat/dphd+jmt + col = tlon/dlmd+ixdim(current_nest_number) + nrow = int(row) + ncol = int(col) + tlat = tlat*d2r + tlon = tlon*d2r + + if (stagger == HH) then + + if ((mod(nrow,2) == 1 .and. mod(ncol,2) == 1) .or. & + (mod(nrow,2) == 0 .and. mod(ncol,2) == 0)) then + tlat1 = (nrow-jmt)*dph + tlat2 = tlat1+dph + tlon1 = (ncol-ixdim(current_nest_number))*dlm + tlon2 = tlon1+dlm + dlm1 = tlon-tlon1 + dlm2 = tlon-tlon2 + d1 = acos(cos(tlat)*cos(tlat1)*cos(dlm1)+sin(tlat)*sin(tlat1)) + d2 = acos(cos(tlat)*cos(tlat2)*cos(dlm2)+sin(tlat)*sin(tlat2)) + + if (d1 > d2) then + nrow = nrow+1 + ncol = ncol+1 + end if + + else + tlat1 = (nrow+1-jmt)*dph + tlat2 = tlat1-dph + tlon1 = (ncol-ixdim(current_nest_number))*dlm + tlon2 = tlon1+dlm + dlm1 = tlon-tlon1 + dlm2 = tlon-tlon2 + d1 = acos(cos(tlat)*cos(tlat1)*cos(dlm1)+sin(tlat)*sin(tlat1)) + d2 = acos(cos(tlat)*cos(tlat2)*cos(dlm2)+sin(tlat)*sin(tlat2)) + + if (d1 < d2) then + nrow = nrow+1 + else + ncol = ncol+1 + end if + end if + + else if (stagger == VV) then + + if ((mod(nrow,2) == 0 .and. mod(ncol,2) == 1) .or. & + (mod(nrow,2) == 1 .and. mod(ncol,2) == 0)) then + tlat1 = (nrow-jmt)*dph + tlat2 = tlat1+dph + tlon1 = (ncol-ixdim(current_nest_number))*dlm + tlon2 = tlon1+dlm + dlm1 = tlon-tlon1 + dlm2 = tlon-tlon2 + d1 = acos(cos(tlat)*cos(tlat1)*cos(dlm1)+sin(tlat)*sin(tlat1)) + d2 = acos(cos(tlat)*cos(tlat2)*cos(dlm2)+sin(tlat)*sin(tlat2)) + + if (d1 > d2) then + nrow = nrow+1 + ncol = ncol+1 + end if + + else + tlat1 = (nrow+1-jmt)*dph + tlat2 = tlat1-dph + tlon1 = (ncol-ixdim(current_nest_number))*dlm + tlon2 = tlon1+dlm + dlm1 = tlon-tlon1 + dlm2 = tlon-tlon2 + d1 = acos(cos(tlat)*cos(tlat1)*cos(dlm1)+sin(tlat)*sin(tlat1)) + d2 = acos(cos(tlat)*cos(tlat2)*cos(dlm2)+sin(tlat)*sin(tlat2)) + + if (d1 < d2) then + nrow = nrow+1 + else + ncol = ncol+1 + end if + end if + end if + + jj = nrow + ii = ncol/2 + if (stagger == HH) then + if (mod(jj,2) == 1) ii = ii+1 + krows = ((nrow-1)/2)*imt + if (mod(nrow,2) == 1) then + k = krows+(ncol+1)/2 + else + k = krows+ixdim(current_nest_number)+ncol/2 + end if + + else if (stagger == VV) then + if (mod(jj,2) == 0) ii=ii+1 + + krows = ((nrow-1)/2)*imt + if (mod(nrow,2) == 1) then + k = krows+ncol/2 + else + k = krows+ixdim(current_nest_number)-1+(ncol+1)/2 + end if + end if + + rx = real(ii) + ry = real(jj) + +end subroutine lltoxy diff --git a/WPS/geogrid/util/plot_source/a.c b/WPS/geogrid/util/plot_source/a.c new file mode 100644 index 00000000..92472d15 --- /dev/null +++ b/WPS/geogrid/util/plot_source/a.c @@ -0,0 +1,25 @@ +#include + +#define N1 1200 + +int main(int argc, char ** argv) +{ + FILE * a; + unsigned char * data; + int i, j; + int data1[N1*N1]; + + data = (unsigned char *)malloc(N1*N1); + a = fopen(argv[1],"r"); + fread(data, 1, N1*N1, a); + fclose(a); + + for(i=0; i $*.f90 + $(FC) $(FFLAGS) -c $*.f90 $(INCLUDEPATH) + rm -f $*.f90 + +all: plotgrid.exe + +plotgrid.exe: $(OBJS) + $(FC) $(LDFLAGS) -o $@ $(OBJS) $(WRF_DIR)/frame/pack_utils.o $(WRF_DIR)/frame/module_machine.o $(WRF_DIR)/frame/module_internal_header_util.o -L$(NETCDF)/lib -I$(NETCDF)/include -I$(WRF_DIR)/external/io_grib1 -I$(WRF_DIR)/external/io_int -I$(WRF_DIR)/external/io_netcdf -L$(WRF_DIR)/external/io_netcdf -L$(WRF_DIR)/external/io_grib1 -L$(WRF_DIR)/external/io_int -lwrfio_nf -lwrfio_int -lio_grib1 -lnetcdf + +plotgrid.o: input_module.o plotgrid.F + +input_module.o: gridinfo_module.o misc_definitions_module.o module_debug.o parallel_module.o queue_module.o input_module.F + +module_debug.o: cio.o parallel_module.o module_debug.F + +gridinfo_module.o: misc_definitions_module.o module_debug.o gridinfo_module.F + +clean: + rm -f $(OBJS) *.mod + +clobber: + make clean; rm -f plotgrid.exe diff --git a/WPS/geogrid/util/plotgrid/src/cio.c b/WPS/geogrid/util/plotgrid/src/cio.c new file mode 120000 index 00000000..39765102 --- /dev/null +++ b/WPS/geogrid/util/plotgrid/src/cio.c @@ -0,0 +1 @@ +../../../src/cio.c \ No newline at end of file diff --git a/WPS/geogrid/util/plotgrid/src/gridinfo_module.F b/WPS/geogrid/util/plotgrid/src/gridinfo_module.F new file mode 120000 index 00000000..9c1a34cd --- /dev/null +++ b/WPS/geogrid/util/plotgrid/src/gridinfo_module.F @@ -0,0 +1 @@ +../../../../metgrid/src/gridinfo_module.F \ No newline at end of file diff --git a/WPS/geogrid/util/plotgrid/src/input_module.F b/WPS/geogrid/util/plotgrid/src/input_module.F new file mode 120000 index 00000000..576bb9aa --- /dev/null +++ b/WPS/geogrid/util/plotgrid/src/input_module.F @@ -0,0 +1 @@ +../../../../metgrid/src/input_module.F \ No newline at end of file diff --git a/WPS/geogrid/util/plotgrid/src/misc_definitions_module.F b/WPS/geogrid/util/plotgrid/src/misc_definitions_module.F new file mode 120000 index 00000000..83f3eef5 --- /dev/null +++ b/WPS/geogrid/util/plotgrid/src/misc_definitions_module.F @@ -0,0 +1 @@ +../../../src/misc_definitions_module.F \ No newline at end of file diff --git a/WPS/geogrid/util/plotgrid/src/module_debug.F b/WPS/geogrid/util/plotgrid/src/module_debug.F new file mode 120000 index 00000000..1b4cc46b --- /dev/null +++ b/WPS/geogrid/util/plotgrid/src/module_debug.F @@ -0,0 +1 @@ +../../../src/module_debug.F \ No newline at end of file diff --git a/WPS/geogrid/util/plotgrid/src/parallel_module.F b/WPS/geogrid/util/plotgrid/src/parallel_module.F new file mode 120000 index 00000000..040755e0 --- /dev/null +++ b/WPS/geogrid/util/plotgrid/src/parallel_module.F @@ -0,0 +1 @@ +../../../src/parallel_module.F \ No newline at end of file diff --git a/WPS/geogrid/util/plotgrid/src/plotgrid.F b/WPS/geogrid/util/plotgrid/src/plotgrid.F new file mode 100644 index 00000000..90610347 --- /dev/null +++ b/WPS/geogrid/util/plotgrid/src/plotgrid.F @@ -0,0 +1,406 @@ +program plotgrid + + use input_module + + implicit none + + external ulpr + + integer :: n, i, j, nx, ny + integer :: istatus, start_mem_i, end_mem_i, start_mem_j, end_mem_j, & + start_mem_k, end_mem_k, dyn_opt, & + west_east_dim, south_north_dim, bottom_top_dim, map_proj, is_water, num_land_cat, & + is_ice, is_urban, isoilwater, grid_id, parent_id, i_parent_start, j_parent_start, & + i_parent_end, j_parent_end, parent_grid_ratio, & + we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, & + sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag + real :: width, height + real :: dx, dy, cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, pole_lat, pole_lon + real :: start_r, start_g, start_b, end_r, end_g, end_b + real :: ll_lat, ll_lon, ur_lat, ur_lon + real :: left, right, bottom, top, maxter, minter + real :: rotang + real, dimension(16) :: corner_lats, corner_lons + real, dimension(10000) :: xcs, ycs + integer, dimension(10) :: iai, iag + integer, dimension(400000) :: iam + integer, allocatable, dimension(:,:) :: lu + real, allocatable, dimension(:,:) :: xlat, xlon, ter + real, dimension(122000) :: rwrk + real, pointer, dimension(:,:,:) :: real_array + character (len=3) :: memorder + character (len=25) :: crotang + character (len=25) :: units + character (len=46) :: desc + character (len=128) :: init_date, cname, stagger, cunits, cdesc, title, startdate, grid_type, mminlu + character (len=128), dimension(3) :: dimnames + + call getarg(1,crotang) + read (crotang,'(f)') rotang + + write(6,*) 'Plotting with rotation angle ',rotang + + call opngks + + call gopwk(13, 41, 3) + + call gscr(1, 0, 1.00, 1.00, 1.00) + call gscr(1, 1, 0.00, 0.00, 0.00) + call gscr(1, 2, 0.25, 0.25, 0.25) + call gscr(1, 3, 1.00, 1.00, 0.50) + call gscr(1, 4, 0.50, 1.00, 0.50) + call gscr(1, 5, 1.00, 1.00, 0.00) + call gscr(1, 6, 1.00, 1.00, 0.00) + call gscr(1, 7, 0.50, 1.00, 0.50) + call gscr(1, 8, 1.00, 1.00, 0.50) + call gscr(1, 9, 0.50, 1.00, 0.50) + call gscr(1,10, 0.50, 1.00, 0.50) + call gscr(1,11, 1.00, 1.00, 0.50) + call gscr(1,12, 0.00, 1.00, 0.00) + call gscr(1,13, 0.00, 0.50, 0.00) + call gscr(1,14, 0.00, 1.00, 0.00) + call gscr(1,15, 0.00, 0.50, 0.00) + call gscr(1,16, 0.00, 1.00, 0.00) + call gscr(1,17, 0.50, 0.50, 1.00) + call gscr(1,18, 0.00, 1.00, 0.00) + call gscr(1,19, 0.00, 1.00, 0.00) + call gscr(1,20, 0.75, 0.75, 0.75) + call gscr(1,21, 0.75, 0.75, 0.75) + call gscr(1,22, 0.00, 0.50, 0.00) + call gscr(1,23, 0.75, 0.75, 0.75) + call gscr(1,24, 0.75, 0.75, 0.75) + call gscr(1,25, 1.00, 1.00, 1.00) + + start_r = 0.00 + end_r = 0.50 + start_g = 1.00 + end_g = 0.25 + start_b = 0.00 + end_b = 0.00 + do i=26,76 + call gscr(1,i,start_r+((end_r-start_r)/50.)*real(i-26),start_g+((end_g-start_g)/50.)*real(i-26),start_b+((end_b-start_b)/50.)*real(i-26)) + end do + + start_r = 0.50 + end_r = 1.00 + start_g = 0.25 + end_g = 1.00 + start_b = 0.00 + end_b = 1.00 + do i=77,126 + call gscr(1,i,start_r+((end_r-start_r)/50.)*real(i-77),start_g+((end_g-start_g)/50.)*real(i-77),start_b+((end_b-start_b)/50.)*real(i-77)) + end do + + start_r = 0.80 + end_r = 1.00 + start_g = 0.80 + end_g = 1.00 + start_b = 0.80 + end_b = 1.00 + do i=127,176 + call gscr(1,i,start_r+((end_r-start_r)/50.)*real(i-127),start_g+((end_g-start_g)/50.)*real(i-127),start_b+((end_b-start_b)/50.)*real(i-127)) + end do + + call get_namelist_params() + + do n=1,max_dom + call input_init(n, istatus) + if (istatus /= 0) then + write(6,*) ' ' + write(6,*) 'Error: Could not open domain01 file.' + write(6,*) ' ' + stop + end if + + call read_global_attrs(title, init_date, grid_type, dyn_opt, & + west_east_dim, south_north_dim, bottom_top_dim, & + we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, & + sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, & + map_proj, mminlu, num_land_cat, is_water, & + is_ice, is_urban, isoilwater, grid_id, parent_id, i_parent_start, j_parent_start, & + i_parent_end, j_parent_end, dx, dy, cen_lat, moad_cen_lat, cen_lon, & + stand_lon, truelat1, truelat2, pole_lat, pole_lon, parent_grid_ratio, & + corner_lats, corner_lons) + + istatus = 0 + do while (istatus == 0) + call read_next_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, & + start_mem_k, end_mem_k, cname, cunits, cdesc, & + memorder, stagger, dimnames, real_array, istatus) + if (istatus == 0) then + + if (index(cname, 'XLAT_M') /= 0) then + nx = end_mem_i - start_mem_i + 1 + ny = end_mem_j - start_mem_j + 1 + allocate(xlat(nx,ny)) + xlat = real_array(:,:,1) + else if (index(cname, 'XLONG_M') /= 0) then + nx = end_mem_i - start_mem_i + 1 + ny = end_mem_j - start_mem_j + 1 + allocate(xlon(nx,ny)) + xlon = real_array(:,:,1) + else if (index(cname, 'LU_INDEX') /= 0) then + nx = end_mem_i - start_mem_i + 1 + ny = end_mem_j - start_mem_j + 1 + allocate(lu(nx,ny)) + lu = nint(real_array(:,:,1)) + end if + end if + end do + + call input_close() + + ll_lat = xlat(1,1) + ll_lon = xlon(1,1) + ur_lat = xlat(nx,ny) + ur_lon = xlon(nx,ny) +! if (ur_lon < 0.) ur_lon = ur_lon + 360.0 + + if (n == 1) then + left = 0.0 + right = 1.0 + bottom = 0.0 + top = 1.0 + call mappos(left,right,bottom,top) + + call mapstc('OU','CO') + + call maproj('CE', cen_lat, cen_lon, rotang) +! call maproj('LC', truelat1, stand_lon, truelat2) +! call maproj('ST', cen_lat, cen_lon, stand_lon) + call mapset('CO', ll_lat, ll_lon, ur_lat, ur_lon) + call mapint() + end if + + call mpsetr('GR', 10.0) + + call maptrn(ll_lat, ll_lon, left, bottom) + call maptrn(ur_lat, ur_lon, right, top) + + width = 1.02*(right-left)/real(nx) + height = 1.02*(top-bottom)/real(ny) + + do j=1,ny + do i=1,nx + call map_square(xlat(i,j), xlon(i,j), width, height, lu(i,j)+1) + end do + end do + + if (n > 1) then + call gsplci(0) + call lined(left-width/2.,bottom-height/2.,left-width/2.,top+height/2.) + call lined(left-width/2.,top+height/2.,right+width/2.,top+height/2.) + call lined(right+width/2.,top+height/2.,right+width/2.,bottom-height/2.) + call lined(right+width/2.,bottom-height/2.,left-width/2.,bottom-height/2.) + call sflush() + call gsplci(1) + end if + + deallocate(xlat) + deallocate(xlon) + deallocate(lu) + end do + + call mplndr('Earth..3',4) + + call arinam (iam,400000) + call mapbla (iam) + call arpram (iam,0,0,0) + + call mapgrm (iam,xcs,ycs,10000,iai,iag,10,ulpr) + + call frame() + + do n=1,max_dom + call input_init(n, istatus) + if (istatus /= 0) then + write(6,*) ' ' + write(6,*) 'Error: Could not open domain01 file.' + write(6,*) ' ' + stop + end if + + call read_global_attrs(title, init_date, grid_type, dyn_opt, & + west_east_dim, south_north_dim, bottom_top_dim, & + we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, & + sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, & + map_proj, mminlu, num_land_cat, is_water, & + is_ice, is_urban, isoilwater, grid_id, parent_id, i_parent_start, j_parent_start, & + i_parent_end, j_parent_end, dx, dy, cen_lat, moad_cen_lat, cen_lon, & + stand_lon, truelat1, truelat2, pole_lat, pole_lon, parent_grid_ratio, & + corner_lats, corner_lons) + + istatus = 0 + do while (istatus == 0) + call read_next_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, & + start_mem_k, end_mem_k, cname, cunits, cdesc, & + memorder, stagger, dimnames, real_array, istatus) + if (istatus == 0) then + + if (index(cname, 'XLAT_M') /= 0) then + nx = end_mem_i - start_mem_i + 1 + ny = end_mem_j - start_mem_j + 1 + allocate(xlat(nx,ny)) + xlat = real_array(:,:,1) + else if (index(cname, 'XLONG_M') /= 0) then + nx = end_mem_i - start_mem_i + 1 + ny = end_mem_j - start_mem_j + 1 + allocate(xlon(nx,ny)) + xlon = real_array(:,:,1) + else if (index(cname, 'HGT_M') /= 0) then + nx = end_mem_i - start_mem_i + 1 + ny = end_mem_j - start_mem_j + 1 + allocate(ter(nx,ny)) + ter = real_array(:,:,1) + else if (index(cname, 'LU_INDEX') /= 0) then + nx = end_mem_i - start_mem_i + 1 + ny = end_mem_j - start_mem_j + 1 + allocate(lu(nx,ny)) + lu = nint(real_array(:,:,1)) + end if + end if + end do + + call input_close() + + ll_lat = xlat(1,1) + ll_lon = xlon(1,1) + ur_lat = xlat(nx,ny) + ur_lon = xlon(nx,ny) + + if (n == 1) then + left = 0.0 + right = 1.0 + bottom = 0.0 + top = 1.0 + call mappos(left,right,bottom,top) + + call mapstc('OU','CO') + + call maproj('CE', cen_lat, cen_lon, rotang) +! call maproj('LC', truelat1, stand_lon, truelat2) +! call maproj('ST', cen_lat, cen_lon, stand_lon) + call mapset('CO', ll_lat, ll_lon, ur_lat, ur_lon) + call mapint() + + maxter = -10000. + minter = 10000. + do j=1,ny + do i=1,nx + if (ter(i,j) > maxter) maxter = ter(i,j) + if (ter(i,j) < minter) minter = ter(i,j) + end do + end do +! maxter = 3348.42 + end if + + call maptrn(ll_lat, ll_lon, left, bottom) + call maptrn(ur_lat, ur_lon, right, top) + + width = 1.02*(right-left)/real(nx) + height = 1.02*(top-bottom)/real(ny) + + do j=1,ny + do i=1,nx + if (lu(i,j) == 16) then + ter(i,j) = ((ter(i,j)-minter) * 99.)/(maxter-minter) + 26. + call map_square(xlat(i,j), xlon(i,j), width, height, 17) + else if (lu(i,j) == 1) then + ter(i,j) = ((ter(i,j)-minter) * 99.)/(maxter-minter) + 26. + call map_square(xlat(i,j), xlon(i,j), width, height, 2) + else if (lu(i,j) == 24) then + ter(i,j) = ((ter(i,j)-minter) * 50.)/(3500.0-minter) + 127. + call map_square(xlat(i,j), xlon(i,j), width, height, nint(ter(i,j))) + else + ter(i,j) = ((ter(i,j)-minter) * 99.)/(maxter-minter) + 26. + call map_square(xlat(i,j), xlon(i,j), width, height, nint(ter(i,j))) + end if + end do + end do + + if (n > 1) then + call gsplci(0) + call lined(left-width/2.,bottom-height/2.,left-width/2.,top+height/2.) + call lined(left-width/2.,top+height/2.,right+width/2.,top+height/2.) + call lined(right+width/2.,top+height/2.,right+width/2.,bottom-height/2.) + call lined(right+width/2.,bottom-height/2.,left-width/2.,bottom-height/2.) + call sflush() + call gsplci(1) + end if + + deallocate(xlat) + deallocate(xlon) + deallocate(ter) + deallocate(lu) + end do + + call mplndr('Earth..3',4) + + call arinam (iam,400000) + call mapbla (iam) + call arpram (iam,0,0,0) + + call mapgrm (iam,xcs,ycs,10000,iai,iag,10,ulpr) + + call gclwk(13) + + call clsgks + + + stop + +end program plotgrid + + +subroutine map_square(rlat, rlon, width, height, colr) + + implicit none + + ! Arguments + real :: rlat, rlon, width, height + integer :: colr + + ! Local variables + real :: u, v + real, dimension(4) :: xra, yra + real, dimension(2000) :: dst + integer, dimension(3000) :: ind + + call maptrn(rlat, rlon, u, v) + + xra(1) = u-(width/2.) + xra(2) = u+(width/2.) + xra(3) = u+(width/2.) + xra(4) = u-(width/2.) + + yra(1) = v-(height/2.) + yra(2) = v-(height/2.) + yra(3) = v+(height/2.) + yra(4) = v+(height/2.) + + call sfsgfa(xra, yra, 4, dst, 2000, ind, 3000, colr) + +end subroutine map_square + + +subroutine ulpr(xcs,ycs,ncs,iai,iag,nai) + + implicit none + + integer, external :: mapaci + + integer :: ncs, nai + integer, dimension(nai) :: iai, iag + real, dimension(ncs) :: xcs, ycs + + integer :: itm + + if (iai(1) >= 0 .and.iai(2) >= 0) then + itm = max0(iai(1),iai(2)) + if (mapaci(itm) == 1) then + if (ncs.gt.150) print * , 'ulpr - ncs too big - ',ncs + call gpl(ncs,xcs,ycs) + end if + end if + +end subroutine ulpr diff --git a/WPS/geogrid/util/plotgrid/src/queue_module.F b/WPS/geogrid/util/plotgrid/src/queue_module.F new file mode 120000 index 00000000..94eaf9dd --- /dev/null +++ b/WPS/geogrid/util/plotgrid/src/queue_module.F @@ -0,0 +1 @@ +../../../src/queue_module.F \ No newline at end of file diff --git a/WPS/geogrid/util/plotgrid/src/wrf_debug.F b/WPS/geogrid/util/plotgrid/src/wrf_debug.F new file mode 120000 index 00000000..5a325db4 --- /dev/null +++ b/WPS/geogrid/util/plotgrid/src/wrf_debug.F @@ -0,0 +1 @@ +../../../src/wrf_debug.F \ No newline at end of file diff --git a/WPS/geogrid/util/plotter.F b/WPS/geogrid/util/plotter.F new file mode 100644 index 00000000..f79bdc54 --- /dev/null +++ b/WPS/geogrid/util/plotter.F @@ -0,0 +1,173 @@ +program plotter + + implicit none + + integer :: nx, ny + integer :: i, j + real :: start_r, start_g, start_b, end_r, end_g, end_b + real :: lu, val, xlat, xlon, left, right, bottom, top, maxter, minter + + call opngks + + call gopwk(13, 41, 3) + + call gscr(1, 0, 1.00, 1.00, 1.00) + call gscr(1, 1, 0.00, 0.00, 0.00) + call gscr(1, 2, 0.25, 0.25, 0.25) + call gscr(1, 3, 1.00, 1.00, 0.50) + call gscr(1, 4, 0.50, 1.00, 0.50) + call gscr(1, 5, 1.00, 1.00, 0.00) + call gscr(1, 6, 1.00, 1.00, 0.00) + call gscr(1, 7, 0.50, 1.00, 0.50) + call gscr(1, 8, 1.00, 1.00, 0.50) + call gscr(1, 9, 0.50, 1.00, 0.50) + call gscr(1,10, 0.50, 1.00, 0.50) + call gscr(1,11, 1.00, 1.00, 0.50) + call gscr(1,12, 0.00, 1.00, 0.00) + call gscr(1,13, 0.00, 0.50, 0.00) + call gscr(1,14, 0.00, 1.00, 0.00) + call gscr(1,15, 0.00, 0.50, 0.00) + call gscr(1,16, 0.00, 1.00, 0.00) + call gscr(1,17, 0.50, 0.50, 1.00) + call gscr(1,18, 0.00, 1.00, 0.00) + call gscr(1,19, 0.00, 1.00, 0.00) + call gscr(1,20, 0.75, 0.75, 0.75) + call gscr(1,21, 0.75, 0.75, 0.75) + call gscr(1,22, 0.00, 0.50, 0.00) + call gscr(1,23, 0.75, 0.75, 0.75) + call gscr(1,24, 0.75, 0.75, 0.75) + call gscr(1,25, 1.00, 1.00, 1.00) + + start_r = 0.00 + end_r = 0.50 + start_g = 1.00 + end_g = 0.25 + start_b = 0.00 + end_b = 0.00 + do i=26,76 + call gscr(1,i,start_r+((end_r-start_r)/50.)*real(i-26),start_g+((end_g-start_g)/50.)*real(i-26),start_b+((end_b-start_b)/50.)*real(i-26)) + end do + + start_r = 0.50 + end_r = 1.00 + start_g = 0.25 + end_g = 1.00 + start_b = 0.00 + end_b = 1.00 + do i=77,126 + call gscr(1,i,start_r+((end_r-start_r)/50.)*real(i-77),start_g+((end_g-start_g)/50.)*real(i-77),start_b+((end_b-start_b)/50.)*real(i-77)) + end do + + nx = 5324 + ny = 3344 + + left = 0.1 + right = 0.9 + bottom = 0.1 + top = 0.9 + call mappos(left,right,bottom,top) + call mapstc('OU','US') + call maproj('LC', 30., -98.00, 60.) + call mapset('CO', 20.144764, -122.505325, 48.201309, -59.35916) + call mapint() + + open(42,file='lu.dat',form='formatted') + open(43,file='lat.dat',form='formatted') + open(44,file='lon.dat',form='formatted') + + do j=1,ny + do i=1,nx + read(42,*) val + read(43,*) xlat + read(44,*) xlon + call map_square(xlat, xlon, (right-left)/real(nx), (top-bottom)/real(nx), nint(val)+1) + end do + end do + + close(42) + close(43) + close(44) + + call maplot() + + call frame() + + open(41,file='lu.dat',form='formatted') + open(42,file='ter.dat',form='formatted') + open(43,file='lat.dat',form='formatted') + open(44,file='lon.dat',form='formatted') + maxter = -1000. + minter = 10000. + do j=1,ny + do i=1,nx + read(42,*) val + if (val > maxter) maxter = val + if (val < minter) minter = val + end do + end do + + rewind(42) + + do j=1,ny + do i=1,nx + read(41,*) lu + read(42,*) val + read(43,*) xlat + read(44,*) xlon + val = ((val-minter) * 99.)/(maxter-minter) + 26. + if (nint(lu) == 16) then + call map_square(xlat, xlon, (right-left)/real(nx), (top-bottom)/real(nx), 17) + else if (nint(lu) == 1) then + call map_square(xlat, xlon, (right-left)/real(nx), (top-bottom)/real(nx), 2) + else + call map_square(xlat, xlon, (right-left)/real(nx), (top-bottom)/real(nx), nint(val)) + end if + end do + end do + + close(41) + close(42) + close(43) + close(44) + + call maplot() + + call gclwk(13) + + call clsgks + +end program plotter + + +subroutine map_square(rlat, rlon, width, height, colr) + + implicit none + + ! Arguments + real :: rlat, rlon, width, height + integer :: colr + + ! Local variables + real :: u, v + real, dimension(4) :: xra, yra + real, dimension(2000) :: dst + integer, dimension(3000) :: ind + + call maptrn(rlat, rlon, u, v) + + u = u + (width/2.) + v = v + (height/2.) + + xra(1) = u-(width/2.) + xra(2) = u+(width/2.) + xra(3) = u+(width/2.) + xra(4) = u-(width/2.) + + yra(1) = v-(height/2.) + yra(2) = v-(height/2.) + yra(3) = v+(height/2.) + yra(4) = v+(height/2.) + + call sfsgfa(xra, yra, 4, dst, 2000, ind, 3000, colr) + +end subroutine map_square diff --git a/WPS/geogrid/util/retile-cat.c b/WPS/geogrid/util/retile-cat.c new file mode 100644 index 00000000..c2b77f0c --- /dev/null +++ b/WPS/geogrid/util/retile-cat.c @@ -0,0 +1,658 @@ +#include +#include +#include +#include +#include +#include +#include + +#define MSG_FLAG 0x80000001 + +#define N_BYTES 1 +#define IN_TILE_DEGREES_LON 10.0 +#define IN_TILE_DEGREES_LAT 10.0 +#define IN_TILE_PTS_X 1200 +#define IN_TILE_PTS_Y 1200 +#define OUT_TILE_DEGREES_LON 20.0 +#define OUT_TILE_DEGREES_LAT 20.0 +#define OUT_TILE_PTS_X 600 +#define OUT_TILE_PTS_Y 600 +#define HALO_WIDTH 0 +#define ZDIM 1 +#define NCATS 24 +#define CATMIN 1 + +#define CACHESIZE 12 + +int **** data_cache = NULL; +char ** fname_cache = NULL; +int * lru = NULL; + +int *** supertile = NULL; +int supertile_min_x = 999999; +int supertile_min_y = 999999; + +void free_newtile(int *** x) +{ + int i, j, k; + + for(i=0; i least) + { + least = lru[k]; + least_idx = k; + } + } + + if (data_cache[least_idx] == NULL) + { + data_cache[least_idx] = localptr; + fname_cache[least_idx] = fname; + lru[least_idx] = 0; + } + else + { + free_newtile(data_cache[least_idx]); + data_cache[least_idx] = localptr; + free(fname_cache[least_idx]); + fname_cache[least_idx] = fname; + lru[least_idx] = 0; + } + + retval = localptr; + return retval; +} + +void build_supertile(int i, int j) +{ + int ii, jj, kk; + int doflip; + int *** newtile; + + if (i < 0) + i = i + IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (i >= IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON)) + i = i - IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (j < 0) + j = j + IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + if (j >= IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT)) + j = j - IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + + if (supertile == NULL) + { + supertile = (int ***)malloc(sizeof(int **)*3*IN_TILE_PTS_X); + for(ii=0; ii<3*IN_TILE_PTS_X; ii++) + { + supertile[ii] = (int **)malloc(sizeof(int *)*3*IN_TILE_PTS_Y); + for(jj=0; jj<3*IN_TILE_PTS_Y; jj++) + { + supertile[ii][jj] = (int *)malloc(sizeof(int)*ZDIM); + } + } + } + + supertile_min_x = (i / IN_TILE_PTS_X)*IN_TILE_PTS_X; + supertile_min_y = (j / IN_TILE_PTS_Y)*IN_TILE_PTS_Y; + + /* Get tile containing (i,j) from cache*/ + /* Get surrounding tiles from cache */ + + /* Lower-left */ + ii = i - IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + doflip = 0; + jj = j - IN_TILE_PTS_Y; + if (jj < 0) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(180./IN_TILE_DEGREES_LAT)*IN_TILE_PTS_Y) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(180./IN_TILE_DEGREES_LAT)*IN_TILE_PTS_Y) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X) ii -= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + doflip = 0; + jj = j - IN_TILE_PTS_Y; + if (jj < 0) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X) ii -= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + jj = j; + newtile = get_tile_from_cache(ii, jj); + for(ii=0; ii= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X) ii -= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + doflip = 0; + jj = j + IN_TILE_PTS_Y; + if (jj >= (int)(180./IN_TILE_DEGREES_LAT)*IN_TILE_PTS_Y) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON)) + i = i - IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (j < 0) + j = j + IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + if (j >= IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT)) + j = j - IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + + i_src = i % IN_TILE_PTS_X + IN_TILE_PTS_X; + j_src = j % IN_TILE_PTS_Y + IN_TILE_PTS_Y; + + /* Interpolate values from supertile */ + for(ii=0; ii 0) return sum/n; + else return 0; +*/ +} + +int is_in_supertile(int i, int j) +{ + if (i < 0) + i = i + IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (i >= IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON)) + i = i - IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (j < 0) + j = j + IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + if (j >= IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT)) + j = j - IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + + /* Check whether (i,j) is in the interior of supertile */ + if ((i >= supertile_min_x) && (i < supertile_min_x+IN_TILE_PTS_X) && + (j >= supertile_min_y) && (j < supertile_min_y+IN_TILE_PTS_Y)) + return 1; + else + return 0; +} + +int main(int argc, char ** argv) +{ + int tile_x, tile_y, input_x, input_y, temp_x, temp_y, temp; + int i, j, k, z, ii, jj; + int i_src, j_src; + int *** intdata; + int * num_cats; + int out_fd; + int ir_rel; + float r_rel; + unsigned char * outdata; + char out_filename[256]; + + r_rel = (float)IN_TILE_PTS_X/(float)OUT_TILE_PTS_X*OUT_TILE_DEGREES_LON/IN_TILE_DEGREES_LON; + ir_rel = (int)rint(r_rel); + + /* Allocate memory to hold a single output tile */ + intdata = (int ***)malloc(sizeof(int **)*(OUT_TILE_PTS_X+2*HALO_WIDTH)); + for(i=0; i<(OUT_TILE_PTS_X+2*HALO_WIDTH); i++) + { + intdata[i] = (int **)malloc(sizeof(int *)*(OUT_TILE_PTS_Y+2*HALO_WIDTH)); + for(j=0; j<(OUT_TILE_PTS_Y+2*HALO_WIDTH); j++) + { + intdata[i][j] = (int *)malloc(sizeof(int)*ZDIM); + } + } + + num_cats = (int *)malloc(sizeof(int)*NCATS); + + /* Allocate output buffer */ + outdata = (unsigned char *)malloc((OUT_TILE_PTS_X+2*HALO_WIDTH)*(OUT_TILE_PTS_Y+2*HALO_WIDTH)*ZDIM*N_BYTES); + + for(tile_x=0; tile_x= temp) + { + temp = num_cats[k]; + intdata[ii+HALO_WIDTH][jj+HALO_WIDTH][0] = k+CATMIN; + } + } + } + } + } + + } + } + } + + /* Write out the data */ + for(i=0; i<(OUT_TILE_PTS_X+2*HALO_WIDTH); i++) + { + for(j=0; j<(OUT_TILE_PTS_Y+2*HALO_WIDTH); j++) + { + for(z=0; z> (8*(N_BYTES-k-1)); + } + } + } + } + write(out_fd,(void *)outdata,(OUT_TILE_PTS_X+2*HALO_WIDTH)*(OUT_TILE_PTS_Y+2*HALO_WIDTH)*ZDIM*N_BYTES); + close(out_fd); + printf("Wrote file %s\n",out_filename); + } + } + + free(num_cats); + + /* Deallocate memory */ + for(i=0; i<(OUT_TILE_PTS_X+2*HALO_WIDTH); i++) + { + for(j=0; j<(OUT_TILE_PTS_Y+2*HALO_WIDTH); j++) + { + free(intdata[i][j]); + } + free(intdata[i]); + } + free(intdata); + + + return 0; +} diff --git a/WPS/geogrid/util/retile-cont.c b/WPS/geogrid/util/retile-cont.c new file mode 100644 index 00000000..bbbcd64a --- /dev/null +++ b/WPS/geogrid/util/retile-cont.c @@ -0,0 +1,660 @@ +#include +#include +#include +#include +#include +#include +#include + +#define MSG_FLAG 0x80000001 + +#define N_BYTES 1 +#define IN_TILE_DEGREES_LON 10.0 +#define IN_TILE_DEGREES_LAT 10.0 +#define IN_TILE_PTS_X 1200 +#define IN_TILE_PTS_Y 1200 +#define OUT_TILE_DEGREES_LON 20.0 +#define OUT_TILE_DEGREES_LAT 20.0 +#define OUT_TILE_PTS_X 600 +#define OUT_TILE_PTS_Y 600 +#define HALO_WIDTH 0 +#define ZDIM 1 +#define OUT_ZDIM 24 +#define NCATS 24 +#define CATMIN 1 + +#define CACHESIZE 12 + +int **** data_cache = NULL; +char ** fname_cache = NULL; +int * lru = NULL; + +int *** supertile = NULL; +int supertile_min_x = 999999; +int supertile_min_y = 999999; + +void free_newtile(int *** x) +{ + int i, j, k; + + for(i=0; i least) + { + least = lru[k]; + least_idx = k; + } + } + + if (data_cache[least_idx] == NULL) + { + data_cache[least_idx] = localptr; + fname_cache[least_idx] = fname; + lru[least_idx] = 0; + } + else + { + free_newtile(data_cache[least_idx]); + data_cache[least_idx] = localptr; + free(fname_cache[least_idx]); + fname_cache[least_idx] = fname; + lru[least_idx] = 0; + } + + retval = localptr; + return retval; +} + +void build_supertile(int i, int j) +{ + int ii, jj, kk; + int doflip; + int *** newtile; + + if (i < 0) + i = i + IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (i >= IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON)) + i = i - IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (j < 0) + j = j + IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + if (j >= IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT)) + j = j - IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + + if (supertile == NULL) + { + supertile = (int ***)malloc(sizeof(int **)*3*IN_TILE_PTS_X); + for(ii=0; ii<3*IN_TILE_PTS_X; ii++) + { + supertile[ii] = (int **)malloc(sizeof(int *)*3*IN_TILE_PTS_Y); + for(jj=0; jj<3*IN_TILE_PTS_Y; jj++) + { + supertile[ii][jj] = (int *)malloc(sizeof(int)*ZDIM); + } + } + } + + supertile_min_x = (i / IN_TILE_PTS_X)*IN_TILE_PTS_X; + supertile_min_y = (j / IN_TILE_PTS_Y)*IN_TILE_PTS_Y; + + /* Get tile containing (i,j) from cache*/ + /* Get surrounding tiles from cache */ + + /* Lower-left */ + ii = i - IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + doflip = 0; + jj = j - IN_TILE_PTS_Y; + if (jj < 0) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(180./IN_TILE_DEGREES_LAT)*IN_TILE_PTS_Y) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(180./IN_TILE_DEGREES_LAT)*IN_TILE_PTS_Y) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X) ii -= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + doflip = 0; + jj = j - IN_TILE_PTS_Y; + if (jj < 0) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X) ii -= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + jj = j; + newtile = get_tile_from_cache(ii, jj); + for(ii=0; ii= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X) ii -= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + doflip = 0; + jj = j + IN_TILE_PTS_Y; + if (jj >= (int)(180./IN_TILE_DEGREES_LAT)*IN_TILE_PTS_Y) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON)) + i = i - IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (j < 0) + j = j + IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + if (j >= IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT)) + j = j - IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + + i_src = i % IN_TILE_PTS_X + IN_TILE_PTS_X; + j_src = j % IN_TILE_PTS_Y + IN_TILE_PTS_Y; + + /* Interpolate values from supertile */ + for(ii=0; ii 0) return sum/n; + else return 0; +*/ +} + +int is_in_supertile(int i, int j) +{ + if (i < 0) + i = i + IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (i >= IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON)) + i = i - IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (j < 0) + j = j + IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + if (j >= IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT)) + j = j - IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + + /* Check whether (i,j) is in the interior of supertile */ + if ((i >= supertile_min_x) && (i < supertile_min_x+IN_TILE_PTS_X) && + (j >= supertile_min_y) && (j < supertile_min_y+IN_TILE_PTS_Y)) + return 1; + else + return 0; +} + +int main(int argc, char ** argv) +{ + int tile_x, tile_y, input_x, input_y, temp_x, temp_y, temp; + int i, j, k, z, ii, jj; + int i_src, j_src; + int *** intdata; + int * num_cats; + int out_fd; + int ir_rel; + float r_rel; + unsigned char * outdata; + char out_filename[256]; + + r_rel = (float)IN_TILE_PTS_X/(float)OUT_TILE_PTS_X*OUT_TILE_DEGREES_LON/IN_TILE_DEGREES_LON; + ir_rel = (int)rint(r_rel); + + /* Allocate memory to hold a single output tile */ + intdata = (int ***)malloc(sizeof(int **)*(OUT_TILE_PTS_X+2*HALO_WIDTH)); + for(i=0; i<(OUT_TILE_PTS_X+2*HALO_WIDTH); i++) + { + intdata[i] = (int **)malloc(sizeof(int *)*(OUT_TILE_PTS_Y+2*HALO_WIDTH)); + for(j=0; j<(OUT_TILE_PTS_Y+2*HALO_WIDTH); j++) + { + intdata[i][j] = (int *)malloc(sizeof(int)*OUT_ZDIM); + } + } + + num_cats = (int *)malloc(sizeof(int)*NCATS); + + /* Allocate output buffer */ + outdata = (unsigned char *)malloc((OUT_TILE_PTS_X+2*HALO_WIDTH)*(OUT_TILE_PTS_Y+2*HALO_WIDTH)*OUT_ZDIM*N_BYTES); + + for(tile_x=0; tile_x 0) + intdata[ii+HALO_WIDTH][jj+HALO_WIDTH][k] = (int)(100.0*(float)num_cats[k]/(float)temp); + else + intdata[ii+HALO_WIDTH][jj+HALO_WIDTH][k] = CATMIN-1; + } + } + } + } + + } + } + } + + /* Write out the data */ + for(i=0; i<(OUT_TILE_PTS_X+2*HALO_WIDTH); i++) + { + for(j=0; j<(OUT_TILE_PTS_Y+2*HALO_WIDTH); j++) + { + for(z=0; z> (8*(N_BYTES-k-1)); + } + } + } + } + write(out_fd,(void *)outdata,(OUT_TILE_PTS_X+2*HALO_WIDTH)*(OUT_TILE_PTS_Y+2*HALO_WIDTH)*OUT_ZDIM*N_BYTES); + close(out_fd); + printf("Wrote file %s\n",out_filename); + } + } + + free(num_cats); + + /* Deallocate memory */ + for(i=0; i<(OUT_TILE_PTS_X+2*HALO_WIDTH); i++) + { + for(j=0; j<(OUT_TILE_PTS_Y+2*HALO_WIDTH); j++) + { + free(intdata[i][j]); + } + free(intdata[i]); + } + free(intdata); + + + return 0; +} diff --git a/WPS/geogrid/util/retile.c b/WPS/geogrid/util/retile.c new file mode 100644 index 00000000..df055515 --- /dev/null +++ b/WPS/geogrid/util/retile.c @@ -0,0 +1,630 @@ +#include +#include +#include +#include +#include +#include +#include + +#define MSG_FLAG 0x80000001 + +#define N_BYTES 1 +#define IN_TILE_DEGREES_LON 180.0 +#define IN_TILE_DEGREES_LAT 180.0 +#define IN_TILE_PTS_X 1250 +#define IN_TILE_PTS_Y 1250 +#define OUT_TILE_DEGREES_LON 180.0 +#define OUT_TILE_DEGREES_LAT 180.0 +#define OUT_TILE_PTS_X 1250 +#define OUT_TILE_PTS_Y 1250 +#define HALO_WIDTH 3 +#define ZDIM 12 + +#define CACHESIZE 12 + +int **** data_cache = NULL; +char ** fname_cache = NULL; +int * lru = NULL; + +int *** supertile = NULL; +int supertile_min_x = 999999; +int supertile_min_y = 999999; + +void free_newtile(int *** x) +{ + int i, j, k; + + for(i=0; i least) + { + least = lru[k]; + least_idx = k; + } + } + + if (data_cache[least_idx] == NULL) + { + data_cache[least_idx] = localptr; + fname_cache[least_idx] = fname; + lru[least_idx] = 0; + } + else + { + free_newtile(data_cache[least_idx]); + data_cache[least_idx] = localptr; + free(fname_cache[least_idx]); + fname_cache[least_idx] = fname; + lru[least_idx] = 0; + } + + retval = localptr; + return retval; +} + +void build_supertile(int i, int j) +{ + int ii, jj, kk; + int doflip; + int *** newtile; + + if (i < 0) + i = i + IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (i >= IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON)) + i = i - IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (j < 0) + j = j + IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + if (j >= IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT)) + j = j - IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + + if (supertile == NULL) + { + supertile = (int ***)malloc(sizeof(int **)*3*IN_TILE_PTS_X); + for(ii=0; ii<3*IN_TILE_PTS_X; ii++) + { + supertile[ii] = (int **)malloc(sizeof(int *)*3*IN_TILE_PTS_Y); + for(jj=0; jj<3*IN_TILE_PTS_Y; jj++) + { + supertile[ii][jj] = (int *)malloc(sizeof(int)*ZDIM); + } + } + } + + supertile_min_x = (i / IN_TILE_PTS_X)*IN_TILE_PTS_X; + supertile_min_y = (j / IN_TILE_PTS_Y)*IN_TILE_PTS_Y; + + /* Get tile containing (i,j) from cache*/ + /* Get surrounding tiles from cache */ + + /* Lower-left */ + ii = i - IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + doflip = 0; + jj = j - IN_TILE_PTS_Y; + if (jj < 0) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(180./IN_TILE_DEGREES_LAT)*IN_TILE_PTS_Y) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(180./IN_TILE_DEGREES_LAT)*IN_TILE_PTS_Y) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X) ii -= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + doflip = 0; + jj = j - IN_TILE_PTS_Y; + if (jj < 0) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X) ii -= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + jj = j; + newtile = get_tile_from_cache(ii, jj); + for(ii=0; ii= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X) ii -= (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + doflip = 0; + jj = j + IN_TILE_PTS_Y; + if (jj >= (int)(180./IN_TILE_DEGREES_LAT)*IN_TILE_PTS_Y) + { + doflip = 1; + jj = j; + ii -= (int)(180./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + if (ii < 0) ii += (int)(360./IN_TILE_DEGREES_LON)*IN_TILE_PTS_X; + } + newtile = get_tile_from_cache(ii, jj); + if (doflip) + { + for(ii=0; ii= IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON)) + i = i - IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (j < 0) + j = j + IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + if (j >= IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT)) + j = j - IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + + i_src = i % IN_TILE_PTS_X + IN_TILE_PTS_X; + j_src = j % IN_TILE_PTS_Y + IN_TILE_PTS_Y; + + /* Interpolate values from supertile */ + sum = 0; + n = 0; + for(ii=i_src; ii<=i_src+irad; ii++) + { + for(jj=j_src; jj<=j_src+irad; jj++) + { + sum += supertile[ii][jj][k]; + n++; + } + } + + if (n > 0) return sum/n; + else return 0; +} + +int is_in_supertile(int i, int j) +{ + if (i < 0) + i = i + IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (i >= IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON)) + i = i - IN_TILE_PTS_X*(int)(360./IN_TILE_DEGREES_LON); + if (j < 0) + j = j + IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + if (j >= IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT)) + j = j - IN_TILE_PTS_Y*(int)(180./IN_TILE_DEGREES_LAT); + + /* Check whether (i,j) is in the interior of supertile */ + if ((i >= supertile_min_x) && (i < supertile_min_x+IN_TILE_PTS_X) && + (j >= supertile_min_y) && (j < supertile_min_y+IN_TILE_PTS_Y)) + return 1; + else + return 0; +} + +int main(int argc, char ** argv) +{ + int tile_x, tile_y, input_x, input_y, temp_x, temp_y; + int i, j, k, z, ii, jj; + int i_src, j_src; + int *** intdata; + int out_fd; + int ir_rel; + float r_rel; + unsigned char * outdata; + char out_filename[256]; + + r_rel = (float)IN_TILE_PTS_X/(float)OUT_TILE_PTS_X*OUT_TILE_DEGREES_LON/IN_TILE_DEGREES_LON; + ir_rel = (int)rint(r_rel); + + /* Allocate memory to hold a single output tile */ + intdata = (int ***)malloc(sizeof(int **)*(OUT_TILE_PTS_X+2*HALO_WIDTH)); + for(i=0; i<(OUT_TILE_PTS_X+2*HALO_WIDTH); i++) + { + intdata[i] = (int **)malloc(sizeof(int *)*(OUT_TILE_PTS_Y+2*HALO_WIDTH)); + for(j=0; j<(OUT_TILE_PTS_Y+2*HALO_WIDTH); j++) + { + intdata[i][j] = (int *)malloc(sizeof(int)*ZDIM); + } + } + + /* Allocate output buffer */ + outdata = (unsigned char *)malloc((OUT_TILE_PTS_X+2*HALO_WIDTH)*(OUT_TILE_PTS_Y+2*HALO_WIDTH)*ZDIM*N_BYTES); + + for(tile_x=0; tile_x> (8*(N_BYTES-k-1)); + } + } + } + } + write(out_fd,(void *)outdata,(OUT_TILE_PTS_X+2*HALO_WIDTH)*(OUT_TILE_PTS_Y+2*HALO_WIDTH)*ZDIM*N_BYTES); + close(out_fd); + printf("Wrote file %s\n",out_filename); + } + } + + /* Deallocate memory */ + for(i=0; i<(OUT_TILE_PTS_X+2*HALO_WIDTH); i++) + { + for(j=0; j<(OUT_TILE_PTS_Y+2*HALO_WIDTH); j++) + { + free(intdata[i][j]); + } + free(intdata[i]); + } + free(intdata); + + + return 0; +} diff --git a/WPS/link_grib.csh b/WPS/link_grib.csh new file mode 100755 index 00000000..e087015e --- /dev/null +++ b/WPS/link_grib.csh @@ -0,0 +1,62 @@ +#!/bin/csh -f + +set alpha = ( A B C D E F G H I J K L M N O P Q R S T U V W X Y Z ) +set i1 = 1 +set i2 = 1 +set i3 = 1 + +if ( ( ${#argv} == 1 ) || ( ( ${#argv} == 2 ) && ( ${2} == "." ) ) ) then + + rm -f GRIBFILE.??? >& /dev/null + + foreach f ( ${1}* ) + + ln -sf ${f} GRIBFILE.$alpha[$i3]$alpha[$i2]$alpha[$i1] + @ i1 ++ + + if ( $i1 > 26 ) then + set i1 = 1 + @ i2 ++ + if ( $i2 > 26 ) then + set i2 = 1 + @ i3 ++ + if ( $i3 > 26 ) then + echo "RAN OUT OF GRIB FILE SUFFIXES!" + endif + endif + endif + + end +else if ( ${#argv} > 1 ) then + + rm -f GRIBFILE.??? >& /dev/null + + foreach f ( $* ) + + if ( $f != "." ) then + ln -sf ${f} GRIBFILE.$alpha[$i3]$alpha[$i2]$alpha[$i1] + @ i1 ++ + + if ( $i1 > 26 ) then + set i1 = 1 + @ i2 ++ + if ( $i2 > 26 ) then + set i2 = 1 + @ i3 ++ + if ( $i3 > 26 ) then + echo "RAN OUT OF GRIB FILE SUFFIXES!" + endif + endif + endif + endif + + end +else if ( ${#argv} == 0 ) then + echo " " + echo " " + echo " Please provide some GRIB data to link" + echo " usage: $0 path_to_grib_data/grib_data_root" + echo " " + echo " " +endif + diff --git a/WPS/metgrid/METGRID.TBL b/WPS/metgrid/METGRID.TBL new file mode 120000 index 00000000..739ff050 --- /dev/null +++ b/WPS/metgrid/METGRID.TBL @@ -0,0 +1 @@ +METGRID.TBL.ARW \ No newline at end of file diff --git a/WPS/metgrid/METGRID.TBL.AFWA b/WPS/metgrid/METGRID.TBL.AFWA new file mode 100644 index 00000000..84b0a807 --- /dev/null +++ b/WPS/metgrid/METGRID.TBL.AFWA @@ -0,0 +1,772 @@ +======================================== +name=ST + z_dim_name=num_st_layers + derived=yes +# IF + fill_lev = 10 : ST000010(200100) + fill_lev = 40 : ST010040(200100) + fill_lev = 100 : ST040100(200100) + fill_lev = 200 : ST100200(200100) +# ELSE IF + fill_lev = 10 : ST000010(200100) + fill_lev = 200 : ST010200(200100) +# ELSE + fill_lev = 7 : ST000007(200100) + fill_lev = 28 : ST007028(200100) + fill_lev = 100 : ST028100(200100) + fill_lev = 289 : ST100289(200100) +======================================== +name=SM + z_dim_name=num_sm_layers + derived=yes +# IF + fill_lev = 10 : SM000010(200100) + fill_lev = 40 : SM010040(200100) + fill_lev = 100 : SM040100(200100) + fill_lev = 200 : SM100200(200100) +# ELSE IF + fill_lev = 10: SM000010(200100) + fill_lev = 200 : SM010200(200100) +# ELSE + fill_lev = 7 : SM000007(200100) + fill_lev = 28 : SM007028(200100) + fill_lev = 100 : SM028100(200100) + fill_lev = 289 : SM100289(200100) +======================================== +name=SW + z_dim_name=num_sw_layers + derived=yes +# IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010040(200100) + fill_lev = 3 : SW040100(200100) + fill_lev = 4 : SW100200(200100) +# ELSE IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010200(200100) +======================================== +name=SOIL_LAYERS + derived=yes + z_dim_name=num_st_layers + flag_in_output=FLAG_SOIL_LAYERS + fill_lev=all:vertical_index; level_template=ST +======================================== +name=SOILM + z_dim_name=num_soilm_levels + derived=yes + fill_lev = 0 : SOILM000(200100) + fill_lev = 5 : SOILM005(200100) + fill_lev = 20 : SOILM020(200100) + fill_lev = 40 : SOILM040(200100) + fill_lev = 160 : SOILM160(200100) + fill_lev = 300 : SOILM300(200100) +======================================== +name=SOILT + z_dim_name=num_soilt_levels + derived=yes + fill_lev = 0 : SOILT000(200100) + fill_lev = 5 : SOILT005(200100) + fill_lev = 20 : SOILT020(200100) + fill_lev = 40 : SOILT040(200100) + fill_lev = 160 : SOILT160(200100) + fill_lev = 300 : SOILT300(200100) +======================================== +name=SOIL_LEVELS + derived=yes + z_dim_name=num_soilt_levels + flag_in_output=FLAG_SOIL_LEVELS + fill_lev=all:vertical_index; level_template=SOILT +======================================== +name=PRES + z_dim_name=num_metgrid_levels + derived=yes + mandatory=yes # MUST HAVE THIS FIELD + fill_lev=all:PRESSURE + fill_lev=200100:PSFC(200100) + fill_lev=all:vertical_index; level_template=TT +======================================== +name=AGRLSEA + interp_option=nearest_neighbor + output=no +======================================== +name=AVNLSEA + interp_option=nearest_neighbor + output=no +======================================== +name=LANDSEA + interp_option=nearest_neighbor + fill_missing=-1. + fill_lev=200100:LANDMASK(1) +======================================== +name=XICE ; output_name=SEAICE # If we get XICE, use entry from SEAICE and + # write the field out as SEAICE +======================================== +name=SEAICE + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + fill_missing=0. +======================================== +name=ICEMASK + interp_option=nearest_neighbor + output=no +======================================== +name=ICEFRAC + interp_option=four_pt+average_4pt + interp_mask=ICEMASK(1) + masked=land + fill_missing=0. + flag_in_output=FLAG_ICEFRAC +======================================== +name=ICEDEPTH + interp_option=four_pt+average_4pt + interp_mask=ICEMASK(1) + masked=land + fill_missing=0. + flag_in_output=FLAG_ICEDEPTH +======================================== +name=H0ML + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + fill_missing=0. +======================================== +name=SKINTEMP + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + mandatory=yes # MUST HAVE THIS FIELD + masked=both + interp_land_mask = LANDSEA(1) + interp_water_mask = LANDSEA(0) + fill_missing=0. +======================================== +name=PSFC + interp_option=four_pt+average_4pt + fill_lev=200100:const(200100.) + flag_in_output=FLAG_PSFC +======================================== +name=VEGCAT + interp_option=nearest_neighbor + fill_missing=0. + flag_in_output=FLAG_VEGCAT +======================================== +name=CANWAT + interp_option=four_pt + fill_missing=0. +======================================== +name=CANWAT; from_input=FILE + interp_option=four_pt+average_4pt+average_16pt + interp_mask=AVNLSEA(0) + fill_missing=0. +======================================== +name=CANWAT; from_input=AGR + interp_option=four_pt+average_4pt+average_16pt + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=0. +======================================== +name=SOILCAT + interp_option=nearest_neighbor + fill_missing=0. + flag_in_output=FLAG_SOILCAT +======================================== +name=SW000010; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW000010 +======================================== +name=SW010040; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW010040 +======================================== +name=SW040100; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW040100 +======================================== +name=SW100200; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW100200 +======================================== +name=SW010200; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW010200 +======================================== +name=SM000010; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM000010 +======================================== +name=SM010040; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM010040 +======================================== +name=SM040100; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM040100 +======================================== +name=SM100200; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM100200 +======================================== +name=SM010200; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM010200 +======================================== +name=ST000010; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST000010 +======================================== +name=ST010040; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST010040 +======================================== +name=ST040100; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST040100 +======================================== +name=ST100200; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST100200 +======================================== +name=ST010200; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST010200 +======================================== +name=SM000007; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM000007 +======================================== +name=SM007028; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM007028 +======================================== +name=SM028100; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM028100 +======================================== +name=SM100289; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM100289 +======================================== +name=ST000007; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST000007 +======================================== +name=ST007028; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST007028 +======================================== +name=ST028100; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST028100 +======================================== +name=ST100289; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST100289 +======================================== +name=SW000010; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW000010 +======================================== +name=SW010040; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW010040 +======================================== +name=SW040100; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW040100 +======================================== +name=SW100200; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW100200 +======================================== +name=SW010200; from_input=AGR + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW010200 +======================================== +name=SM000010; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM000010 +======================================== +name=SM010040; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM010040 +======================================== +name=SM040100; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM040100 +======================================== +name=SM100200; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM100200 +======================================== +name=SM010200; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM010200 +======================================== +name=ST000010; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST000010 +======================================== +name=ST010040; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST010040 +======================================== +name=ST040100; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST040100 +======================================== +name=ST100200; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST100200 +======================================== +name=ST010200; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST010200 +======================================== +name=SM000007; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM000007 +======================================== +name=SM007028; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM007028 +======================================== +name=SM028100; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM028100 +======================================== +name=SM100289; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM100289 +======================================== +name=ST000007; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST000007 +======================================== +name=ST007028; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST007028 +======================================== +name=ST028100; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST028100 +======================================== +name=ST100289; from_input=LSM + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=AVNLSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST100289 +======================================== +name=SOILM000 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM000 +======================================== +name=SOILM005 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM005 +======================================== +name=SOILM020 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM020 +======================================== +name=SOILM040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM040 +======================================== +name=SOILM160 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM160 +======================================== +name=SOILM300 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM300 +======================================== +name=SOILT000 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT000 +======================================== +name=SOILT005 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT005 +======================================== +name=SOILT020 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT020 +======================================== +name=SOILT040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT040 +======================================== +name=SOILT160 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT160 +======================================== +name=SOILT300 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT300 +======================================== +name=PMSL + interp_option=sixteen_pt+four_pt+average_4pt + flag_in_output=FLAG_SLP +======================================== +name=RH + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=SPECHUMD + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) +======================================== +name=TAVGSFC + interp_option=four_pt + fill_missing=0. + fill_lev=200100:TT(200100) + flag_in_output=FLAG_TAVGSFC +======================================== +name=T ; output_name=TT # If we get T, use entry from TT and + # write the field out as TT +======================================== +name=TT + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=U ; output_name=UU # If we get U, use entry from UU and + # write the field out as UU +======================================== +name=UU + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_u_field=yes + output_stagger=U + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=V ; output_name=VV # If we get V, use entry from VV and + # write the field out as VV +======================================== +name=VV + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_v_field=yes + output_stagger=V + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=SST + interp_option=sixteen_pt+four_pt + fill_missing=0. + missing_value=-1.E30 + flag_in_output=FLAG_SST +======================================== +name=QV + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QV +======================================== +name=QR + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QR +======================================== +name=QC + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QC +======================================== +name=QI + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QI +======================================== +name=QS + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QS +======================================== +name=QG + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QG +======================================== +name=QNI + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QNI +======================================== +name=VPTMP + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) +======================================== +name=PRESSURE + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:PSFC(200100) +======================================== +name=GHT + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:SOILHGT(200100) + fill_lev=200100:HGT_M(1) +======================================== +name=HGTT + output=no + interp_option=nearest_neighbor +======================================== +name=SNOW + interp_option=four_pt+average_4pt+average_16pt + masked=water + fill_missing=0. + flag_in_output=FLAG_SNOW +======================================== +name=SNOW; from_input=LSM + interp_option=four_pt+average_4pt+average_16pt + masked=water + interp_mask=AVNLSEA(0) + fill_missing=0. + flag_in_output=FLAG_SNOW +======================================== +name=SNOW;from_input=AGR + interp_option=four_pt+average_4pt+average_16pt + masked=water + interp_mask=AGRLSEA(0) + missing_value=-1.E30 + fill_missing=0. + flag_in_output=FLAG_SNOW +======================================== +name=SOILHGT + interp_option=four_pt+average_4pt + flag_in_output=FLAG_SOILHGT +======================================== +name=SNOWH; from_input=FILE + interp_option=four_pt+average_4pt+average_16pt + interp_mask=AVNLSEA(0) + fill_missing=0. + flag_in_output=FLAG_SNOWH +======================================== +name=SNOWH; from_input=AGR + interp_option=four_pt+average_4pt+average_16pt + interp_mask=AGRLSEA(0) + fill_missing=0. + missing_value=-1.E30 + flag_in_output=FLAG_SNOWH +======================================== diff --git a/WPS/metgrid/METGRID.TBL.ARW b/WPS/metgrid/METGRID.TBL.ARW new file mode 100644 index 00000000..b73fdf1b --- /dev/null +++ b/WPS/metgrid/METGRID.TBL.ARW @@ -0,0 +1,1036 @@ +======================================== +name=ST + z_dim_name=num_st_layers + derived=yes +# IF + fill_lev = 10 : ST000010(200100) + fill_lev = 40 : ST010040(200100) + fill_lev = 100 : ST040100(200100) + fill_lev = 200 : ST100200(200100) +# ELSE IF + fill_lev = 10 : ST000010(200100) + fill_lev = 35 : ST010035(200100) + fill_lev = 100 : ST035100(200100) + fill_lev = 300 : ST100300(200100) +# ELSE IF + fill_lev = 10 : ST000010(200100) + fill_lev = 200 : ST010200(200100) +# ELSE + fill_lev = 7 : ST000007(200100) + fill_lev = 28 : ST007028(200100) + fill_lev = 100 : ST028100(200100) + fill_lev = 289 : ST100289(200100) +======================================== +name=SM + z_dim_name=num_sm_layers + derived=yes +# IF + fill_lev = 10 : SM000010(200100) + fill_lev = 40 : SM010040(200100) + fill_lev = 100 : SM040100(200100) + fill_lev = 200 : SM100200(200100) +# ELSE IF + fill_lev = 10 : SM000010(200100) + fill_lev = 35 : SM010035(200100) + fill_lev = 100 : SM035100(200100) + fill_lev = 300 : SM100300(200100) +# ELSE IF + fill_lev = 10: SM000010(200100) + fill_lev = 200 : SM010200(200100) +# ELSE + fill_lev = 7 : SM000007(200100) + fill_lev = 28 : SM007028(200100) + fill_lev = 100 : SM028100(200100) + fill_lev = 289 : SM100289(200100) +======================================== +name=SW + z_dim_name=num_sw_layers + derived=yes +# IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010040(200100) + fill_lev = 3 : SW040100(200100) + fill_lev = 4 : SW100200(200100) +# ELSE IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010200(200100) +======================================== +name=SOIL_LAYERS + derived=yes + z_dim_name=num_st_layers + flag_in_output=FLAG_SOIL_LAYERS + fill_lev=all:vertical_index; level_template=ST +======================================== +name=SOILM + z_dim_name=num_soilm_levels + derived=yes + fill_lev = 0 : SOILM000(200100) + fill_lev = 5 : SOILM005(200100) + fill_lev = 20 : SOILM020(200100) + fill_lev = 40 : SOILM040(200100) + fill_lev = 160 : SOILM160(200100) + fill_lev = 300 : SOILM300(200100) +# HRRR + fill_lev = 1 : SOILM001(200100) + fill_lev = 4 : SOILM004(200100) + fill_lev = 10 : SOILM010(200100) + fill_lev = 30 : SOILM030(200100) + fill_lev = 60 : SOILM060(200100) + fill_lev = 100 : SOILM100(200100) +======================================== +name=SOILT + z_dim_name=num_soilt_levels + derived=yes + fill_lev = 0 : SOILT000(200100) + fill_lev = 5 : SOILT005(200100) + fill_lev = 20 : SOILT020(200100) + fill_lev = 40 : SOILT040(200100) + fill_lev = 160 : SOILT160(200100) + fill_lev = 300 : SOILT300(200100) + fill_lev = 49 : SOILT050(200100) + fill_lev = 51 : SOILT050(200100) +#HRRR + fill_lev = 1 : SOILT001(200100) + fill_lev = 4 : SOILT004(200100) + fill_lev = 10 : SOILT010(200100) + fill_lev = 30 : SOILT030(200100) + fill_lev = 60 : SOILT060(200100) + fill_lev = 100 : SOILT100(200100) +======================================== +name=SOIL_LEVELS + derived=yes + z_dim_name=num_soilt_levels + flag_in_output=FLAG_SOIL_LEVELS + fill_lev=all:vertical_index; level_template=SOILT +======================================== +name=PRES + z_dim_name=num_metgrid_levels + derived=yes + mandatory=yes # MUST HAVE THIS FIELD + fill_lev=all:PRESSURE + fill_lev=200100:PSFC(200100) + fill_lev=all:vertical_index; level_template=TT +======================================== +name=LANDSEA + interp_option=nearest_neighbor + fill_missing=-1. + fill_lev=200100:LANDMASK(1) +======================================== +name=XICE ; output_name=SEAICE # If we get XICE, use entry from SEAICE and + # write the field out as SEAICE +======================================== +name=SEAICE + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + missing_value=-1.E30 + fill_missing=0. +======================================== +name=SNOW + interp_option=four_pt+average_4pt + masked=water + interp_mask=LANDSEA(0) + fill_missing=0. + flag_in_output=FLAG_SNOW +======================================== +name=SKINTEMP +mpas_name=skintemp + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=both + interp_land_mask = LANDSEA(1) + interp_water_mask = LANDSEA(0) + fill_missing=0. +======================================== +name=PSFC +mpas_name=surface_pressure + interp_option=four_pt+average_4pt + fill_lev=200100:const(200100.) + flag_in_output=FLAG_PSFC +======================================== +name=VEGCAT + interp_option=nearest_neighbor + fill_missing=0. + flag_in_output=FLAG_VEGCAT +======================================== +name=CANWAT + interp_option=four_pt + fill_missing=0. +======================================== +name=SOILCAT + interp_option=nearest_neighbor + fill_missing=0. + flag_in_output=FLAG_SOILCAT +======================================== +name=SW000010 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW000010 +======================================== +name=SW010040 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW010040 +======================================== +name=SW040100 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW040100 +======================================== +name=SW100200 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW100200 +======================================== +name=SW010200 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW010200 +======================================== +name=SM000010 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM000010 +======================================== +name=SM010035 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM010035 +======================================== +name=SM010040 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM010040 +======================================== +name=SM035100 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM035100 +======================================== +name=SM040100 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM040100 +======================================== +name=SM100200 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM100200 +======================================== +name=SM100300 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM100300 +======================================== +name=SM010200 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM010200 +======================================== +name=ST000010 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST000010 +======================================== +name=ST010035 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST010035 +======================================== +name=ST010040 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST010040 +======================================== +name=ST035100 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST035100 +======================================== +name=ST040100 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST040100 +======================================== +name=ST100200 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST100200 +======================================== +name=ST100300 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST100300 +======================================== +name=ST010200 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST010200 +======================================== +name=SM000007 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM000007 +======================================== +name=SM007028 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM007028 +======================================== +name=SM028100 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM028100 +======================================== +name=SM100289 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM100289 +======================================== +name=ST000007 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST000007 +======================================== +name=ST007028 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST007028 +======================================== +name=ST028100 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST028100 +======================================== +name=ST100289 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST100289 +======================================== +name=SOILM000 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM000 +======================================== +name=SOILM001 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM001 +======================================== +name=SOILM004 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM004 +======================================== +name=SOILM005 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM005 +======================================== +name=SOILM010 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM010 +======================================== +name=SOILM020 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM020 +======================================== +name=SOILM030 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM030 +======================================== +name=SOILM040 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM040 +======================================== +name=SOILM060 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM060 +======================================== +name=SOILM100 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM100 +======================================== +name=SOILM160 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM160 +======================================== +name=SOILM300 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM300 +======================================== +name=SOILT000 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT000 +======================================== +name=SOILT001 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT001 +======================================== +name=SOILT004 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT004 +======================================== +name=SOILT005 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT005 +======================================== +name=SOILT010 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT010 +======================================== +name=SOILT020 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT020 +======================================== +name=SOILT030 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT030 +======================================== +name=SOILT040 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT040 +======================================== +name=SOILT060 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT060 +======================================== +name=SOILT100 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT100 +======================================== +name=SOILT160 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT160 +======================================== +name=SOILT300 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT300 +======================================== +name=SOILT050 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT050 +======================================== +name=PMSL +mpas_name=mslp + interp_option=sixteen_pt+four_pt+average_4pt + flag_in_output=FLAG_SLP +======================================== +name=RH + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=SPECHUMD + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + missing_value=-1.E30 + fill_lev=200100:const(-1) + flag_in_output=FLAG_SH +======================================== +name=SPECCLDL + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + missing_value=-1.E30 + fill_lev=200100:const(-1) + flag_in_output=FLAG_SPECCLDL +======================================== +name=SPECCLDF + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + missing_value=-1.E30 + fill_lev=200100:const(-1) + flag_in_output=FLAG_SPECCLDF +======================================== +name=TAVGSFC + interp_option=four_pt + fill_missing=0. + fill_lev=200100:TT(200100) + flag_in_output=FLAG_TAVGSFC +======================================== +name=T ; output_name=TT # If we get T, use entry from TT and + # write the field out as TT +======================================== +name=TT +mpas_name=theta + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=U ; output_name=UU # If we get U, use entry from UU and + # write the field out as UU +======================================== +name=UU +mpas_name=uReconstructZonal + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_u_field=yes + output_stagger=U + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=V ; output_name=VV # If we get V, use entry from VV and + # write the field out as VV +======================================== +name=VV +mpas_name=uReconstructMeridional + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_v_field=yes + output_stagger=V + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=SST + interp_option=sixteen_pt+four_pt + fill_missing=0. + missing_value=-1.E30 + flag_in_output=FLAG_SST +======================================== +name=QV +mpas_name=qv + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QV +======================================== +name=QR +mpas_name=qr + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QR +======================================== +name=QC +mpas_name=qc + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QC +======================================== +name=QI +mpas_name=qi + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QI +======================================== +name=QS +mpas_name=qs + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QS +======================================== +name=QG +mpas_name=qg + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QG +======================================== +name=QNI +mpas_name=ni + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QNI +======================================== +name=QNC + output=no + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QNC +======================================== +name=QNR +mpas_name=nr + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QNR +======================================== +name=VPTMP + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) +======================================== +name=PRESSURE +mpas_name=pressure + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:PSFC(200100) +======================================== +name=PRHO + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:PSFC(200100) + flag_in_output=FLAG_PRHO +======================================== +name=GHT +mpas_name=zgrid + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:SOILHGT(200100) + fill_lev=200100:HGT_M(1) +======================================== +name=HGTT + output=no + interp_option=nearest_neighbor +======================================== +name=SNOWH + interp_option=four_pt+average_4pt + masked=water + interp_mask=LANDSEA(0) + fill_missing=0. + flag_in_output=FLAG_SNOWH +======================================== +name=SOILHGT + interp_option=four_pt+average_4pt + flag_in_output=FLAG_SOILHGT +======================================== +name=H0ML + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + fill_missing=0. +======================================== +name=TMOML + interp_option=nearest_neighbor +# interp_option=sixteen_pt+four_pt+wt_average_4pt+search + masked=land + interp_mask=landmask(1) + missing_value=200. + fill_missing=-20. +======================================== +name=T0 + interp_option=four_pt+average_4pt+search + masked=land + interp_mask=landmask(1) + missing_value=200. + fill_missing=-20. +======================================== +name=QNWFA_JAN ; output_name=W_WIF_JAN +======================================== +name=W_WIF_JAN + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNWFA_FEB ; output_name=W_WIF_FEB +======================================== +name=W_WIF_FEB + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNWFA_MAR ; output_name=W_WIF_MAR +======================================== +name=W_WIF_MAR + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNWFA_APR ; output_name=W_WIF_APR +======================================== +name=W_WIF_APR + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNWFA_MAY ; output_name=W_WIF_MAY +======================================== +name=W_WIF_MAY + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNWFA_JUN ; output_name=W_WIF_JUN +======================================== +name=W_WIF_JUN + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNWFA_JUL ; output_name=W_WIF_JUL +======================================== +name=W_WIF_JUL + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNWFA_AUG ; output_name=W_WIF_AUG +======================================== +name=W_WIF_AUG + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNWFA_SEP ; output_name=W_WIF_SEP +======================================== +name=W_WIF_SEP + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNWFA_OCT ; output_name=W_WIF_OCT +======================================== +name=W_WIF_OCT + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNWFA_NOV ; output_name=W_WIF_NOV +======================================== +name=W_WIF_NOV + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNWFA_DEC ; output_name=W_WIF_DEC +======================================== +name=W_WIF_DEC + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt + flag_in_output=FLAG_QNWFA +======================================== +name=QNIFA_JAN ; output_name=I_WIF_JAN +======================================== +name=I_WIF_JAN + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA_FEB ; output_name=I_WIF_FEB +======================================== +name=I_WIF_FEB + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA_MAR ; output_name=I_WIF_MAR +======================================== +name=I_WIF_MAR + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA_APR ; output_name=I_WIF_APR +======================================== +name=I_WIF_APR + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA_MAY ; output_name=I_WIF_MAY +======================================== +name=I_WIF_MAY + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA_JUN ; output_name=I_WIF_JUN +======================================== +name=I_WIF_JUN + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA_JUL ; output_name=I_WIF_JUL +======================================== +name=I_WIF_JUL + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA_AUG ; output_name=I_WIF_AUG +======================================== +name=I_WIF_AUG + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA_SEP ; output_name=I_WIF_SEP +======================================== +name=I_WIF_SEP + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA_OCT ; output_name=I_WIF_OCT +======================================== +name=I_WIF_OCT + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA_NOV ; output_name=I_WIF_NOV +======================================== +name=I_WIF_NOV + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA_DEC ; output_name=I_WIF_DEC +======================================== +name=I_WIF_DEC + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt + flag_in_output=FLAG_QNIFA +======================================== +name=P_WIF_JAN + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=P_WIF_FEB + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=P_WIF_MAR + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=P_WIF_APR + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=P_WIF_MAY + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=P_WIF_JUN + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=P_WIF_JUL + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=P_WIF_AUG + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=P_WIF_SEP + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=P_WIF_OCT + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=P_WIF_NOV + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=P_WIF_DEC + z_dim_name=num_wif_levels + interp_option=four_pt+average_4pt +======================================== +name=UTROP + interp_option=four_pt + is_u_field=yes + output_stagger=U + flag_in_output=FLAG_UTROP +======================================== +name=VTROP + interp_option=four_pt + is_v_field=yes + output_stagger=V + flag_in_output=FLAG_VTROP +======================================== +name=TTROP + interp_option=four_pt + flag_in_output=FLAG_TTROP +======================================== +name=PTROP + interp_option=four_pt + flag_in_output=FLAG_PTROP +======================================== +name=PTROPNN + interp_option=nearest_neighbor + flag_in_output=FLAG_PTROPNN +======================================== +name=HGTTROP + interp_option=four_pt + flag_in_output=FLAG_HGTTROP +======================================== +name=UMAXW + interp_option=four_pt + is_u_field=yes + output_stagger=U + flag_in_output=FLAG_UMAXW +======================================== +name=VMAXW + interp_option=four_pt + is_v_field=yes + output_stagger=V + flag_in_output=FLAG_VMAXW +======================================== +name=TMAXW + interp_option=four_pt + flag_in_output=FLAG_TMAXW +======================================== +name=PMAXW + interp_option=four_pt + flag_in_output=FLAG_PMAXW +======================================== +name=PMAXWNN + interp_option=nearest_neighbor + flag_in_output=FLAG_PMAXWNN +======================================== +name=HGTMAXW + interp_option=four_pt + flag_in_output=FLAG_HGTMAXW +======================================== +name=QNWFA + z_dim_name=num_qnwfa_levels + interp_option=four_pt+average_4pt +======================================== +name=QNIFA + z_dim_name=num_qnwfa_levels + interp_option=four_pt+average_4pt +======================================== +# This entry is only used for MPAS data +name=smois +mpas_name=smois + output=no + masked=water + fill_missing=1. +======================================== +# This entry is only used for MPAS data +name=tslb +mpas_name=tslb + output=no + masked=water + fill_missing=1. +======================================== diff --git a/WPS/metgrid/METGRID.TBL.ARW.rap b/WPS/metgrid/METGRID.TBL.ARW.rap new file mode 100644 index 00000000..cb2ae765 --- /dev/null +++ b/WPS/metgrid/METGRID.TBL.ARW.rap @@ -0,0 +1,717 @@ +======================================== +name=ST + z_dim_name=num_st_layers + derived=yes +# IF + fill_lev = 10 : ST000010(200100) + fill_lev = 40 : ST010040(200100) + fill_lev = 100 : ST040100(200100) + fill_lev = 200 : ST100200(200100) +# ELSE IF + fill_lev = 10 : ST000010(200100) + fill_lev = 35 : ST010035(200100) + fill_lev = 100 : ST035100(200100) + fill_lev = 289 : ST100289(200100) +# ELSE IF + fill_lev = 10 : ST000010(200100) + fill_lev = 200 : ST010200(200100) +# ELSE + fill_lev = 7 : ST000007(200100) + fill_lev = 28 : ST007028(200100) + fill_lev = 100 : ST028100(200100) + fill_lev = 289 : ST100289(200100) +======================================== +name=SM + z_dim_name=num_sm_layers + derived=yes +# IF + fill_lev = 10 : SM000010(200100) + fill_lev = 40 : SM010040(200100) + fill_lev = 100 : SM040100(200100) + fill_lev = 200 : SM100200(200100) +# ELSE IF + fill_lev = 10 : SM000010(200100) + fill_lev = 35 : SM010035(200100) + fill_lev = 100 : SM035100(200100) + fill_lev = 289 : SM100289(200100) +# ELSE IF + fill_lev = 10: SM000010(200100) + fill_lev = 200 : SM010200(200100) +# ELSE + fill_lev = 7 : SM000007(200100) + fill_lev = 28 : SM007028(200100) + fill_lev = 100 : SM028100(200100) + fill_lev = 289 : SM100289(200100) +======================================== +name=SW + z_dim_name=num_sw_layers + derived=yes +# IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010040(200100) + fill_lev = 3 : SW040100(200100) + fill_lev = 4 : SW100200(200100) +# ELSE IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010200(200100) +======================================== +name=SOIL_LAYERS + derived=yes + z_dim_name=num_st_layers + flag_in_output=FLAG_SOIL_LAYERS + fill_lev=all:vertical_index; level_template=ST +======================================== +name=SOILM + z_dim_name=num_soilm_levels + derived=yes +# IF + fill_lev = 0 : SOILM000(200100) + fill_lev = 1 : SOILM001(200100) + fill_lev = 4 : SOILM004(200100) + fill_lev = 10 : SOILM010(200100) + fill_lev = 30 : SOILM030(200100) + fill_lev = 60 : SOILM060(200100) + fill_lev = 100 : SOILM100(200100) + fill_lev = 160 : SOILM160(200100) + fill_lev = 300 : SOILM300(200100) +# ELSE IF + fill_lev = 0 : SOILM000(200100) + fill_lev = 5 : SOILM005(200100) + fill_lev = 20 : SOILM020(200100) + fill_lev = 40 : SOILM040(200100) + fill_lev = 160 : SOILM160(200100) + fill_lev = 300 : SOILM300(200100) +======================================== +name=SOILT + z_dim_name=num_soilt_levels + derived=yes +# IF + fill_lev = 0 : SOILT000(200100) + fill_lev = 1 : SOILT001(200100) + fill_lev = 4 : SOILT004(200100) + fill_lev = 10 : SOILT010(200100) + fill_lev = 30 : SOILT030(200100) + fill_lev = 60 : SOILT060(200100) + fill_lev = 100 : SOILT100(200100) + fill_lev = 160 : SOILT160(200100) + fill_lev = 300 : SOILT300(200100) +# ELSE IF + fill_lev = 0 : SOILT000(200100) + fill_lev = 5 : SOILT005(200100) + fill_lev = 20 : SOILT020(200100) + fill_lev = 40 : SOILT040(200100) + fill_lev = 160 : SOILT160(200100) + fill_lev = 300 : SOILT300(200100) + fill_lev = 49 : SOILT050(200100) + fill_lev = 51 : SOILT050(200100) +======================================== +name=SOIL_LEVELS + derived=yes + z_dim_name=num_soilt_levels + flag_in_output=FLAG_SOIL_LEVELS + fill_lev=all:vertical_index; level_template=SOILT +======================================== +name=PRES + z_dim_name=num_metgrid_levels + derived=yes + mandatory=yes # MUST HAVE THIS FIELD + fill_lev=all:PRESSURE + fill_lev=200100:PSFC(200100) + fill_lev=all:vertical_index; level_template=TT +======================================== +name=LANDSEA + interp_option=nearest_neighbor + fill_missing=-1. + fill_lev=200100:LANDMASK(1) +======================================== +name=XICE ; output_name=SEAICE # If we get XICE, use entry from SEAICE and + # write the field out as SEAICE +======================================== +name=SEAICE + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + fill_missing=0. +======================================== +name=H0ML + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + fill_missing=0. +======================================== +name=SNOW + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. + flag_in_output=FLAG_SNOW +======================================== +name=SNOH + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. + flag_in_output=FLAG_SNOH +======================================== +name=SKINTEMP + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + mandatory=yes # MUST HAVE THIS FIELD + masked=both +# interp_land_mask = LANDSEA(1) + interp_water_mask = SOILM000(1) + fill_missing=0. +======================================== +name=PSFC + interp_option=four_pt+average_4pt + fill_lev=200100:const(200100.) + flag_in_output=FLAG_PSFC +======================================== +name=VEGCAT + interp_option=nearest_neighbor + fill_missing=0. + flag_in_output=FLAG_VEGCAT +======================================== +name=CANWAT + interp_option=four_pt + fill_missing=0. +======================================== +name=SOILCAT + interp_option=nearest_neighbor + fill_missing=0. + flag_in_output=FLAG_SOILCAT +======================================== +name=SW000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW000010 +======================================== +name=SW010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW010040 +======================================== +name=SW040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW040100 +======================================== +name=SW100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW100200 +======================================== +name=SW010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SW010200 +======================================== +name=SM000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM000010 +======================================== +name=SM010035 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM010035 +======================================== +name=SM010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM010040 +======================================== +name=SM035100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM035100 +======================================== +name=SM040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM040100 +======================================== +name=SM100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM100200 +======================================== +name=SM010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM010200 +======================================== +name=ST000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST000010 +======================================== +name=ST010035 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST010035 +======================================== +name=ST010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST010040 +======================================== +name=ST035100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST035100 +======================================== +name=ST040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST040100 +======================================== +name=ST100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST100200 +======================================== +name=ST010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST010200 +======================================== +name=SM000007 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM000007 +======================================== +name=SM007028 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM007028 +======================================== +name=SM028100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM028100 +======================================== +name=SM100289 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=1. + flag_in_output=FLAG_SM100289 +======================================== +name=ST000007 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST000007 +======================================== +name=ST007028 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST007028 +======================================== +name=ST028100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST028100 +======================================== +name=ST100289 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + missing_value=-1.E30 + fill_missing=285. + flag_in_output=FLAG_ST100289 +======================================== +name=SOILM000 + interp_option=four_pt+average_4pt+search + masked=water +# interp_mask=LANDSEA(0) + missing_value=1. + fill_missing=1. + flag_in_output=FLAG_SOILM000 +======================================== +name=SOILM001 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM001 +======================================== +name=SOILM004 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM004 +======================================= +name=SOILM010 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM010 +======================================== +name=SOILM030 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM030 +======================================== +name=SOILM060 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM060 +======================================== +name=SOILM100 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM100 +======================================== +name=SOILM005 + interp_option=four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM005 +======================================== +name=SOILM020 + interp_option=four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM020 +======================================== +name=SOILM040 + interp_option=four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM040 +======================================== +name=SOILM160 + interp_option=four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM160 +======================================== +name=SOILM300 + interp_option=four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM300 +======================================== +name=SOILT000 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT000 +======================================== +name=SOILT001 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT001 +======================================== +name=SOILT004 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT004 +======================================== +name=SOILT010 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT010 +======================================== +name=SOILT030 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT030 +======================================== +name=SOILT060 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT060 +======================================== +name=SOILT100 + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT100 +======================================== +name=SOILT005 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT005 +======================================== +name=SOILT020 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT020 +======================================== +name=SOILT040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT040 +======================================== +name=SOILT160 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT160 +======================================== +name=SOILT300 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT300 +======================================== +name=SOILT050 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT050 +======================================== +name=PMSL + interp_option=sixteen_pt+four_pt+average_4pt + flag_in_output=FLAG_SLP +======================================== +name=RH + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=SPECHUMD + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + missing_value=-1.E30 + fill_lev=200100:const(-1) + flag_in_output=FLAG_SH +======================================== +name=TAVGSFC + interp_option=four_pt + fill_missing=0. + fill_lev=200100:TT(200100) + flag_in_output=FLAG_TAVGSFC +======================================== +name=T ; output_name=TT # If we get T, use entry from TT and + # write the field out as TT +======================================== +name=TT + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=U ; output_name=UU # If we get U, use entry from UU and + # write the field out as UU +======================================== +name=UU + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_u_field=yes + output_stagger=U + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=V ; output_name=VV # If we get V, use entry from VV and + # write the field out as VV +======================================== +name=VV + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_v_field=yes + output_stagger=V + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=SST + interp_option=sixteen_pt+four_pt + fill_missing=0. + flag_in_output=FLAG_SST +======================================== +name=QV + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QV +======================================== +name=QR + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QR +======================================== +name=QC + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QC +======================================== +name=QI + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QI +======================================== +name=QS + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QS +======================================== +name=QG + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QG +======================================== +name=QNI + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QNI +======================================== +name=QNR + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QNR +======================================== +name=VPTMP + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) +======================================== +name=PRESSURE + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:PSFC(200100) +======================================== +name=GHT + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:SOILHGT(200100) + fill_lev=200100:HGT_M(1) +======================================== +name=HGTT + output=no + interp_option=nearest_neighbor +======================================== +name=SNOWH + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. + flag_in_output=FLAG_SNOWH +======================================== +name=SOILHGT + interp_option=four_pt+average_4pt + flag_in_output=FLAG_SOILHGT +======================================== +name=RHOSN + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. +======================================== +name=TSNOW + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. +======================================== +name=QVG + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. +======================================== diff --git a/WPS/metgrid/METGRID.TBL.ARW.ruc b/WPS/metgrid/METGRID.TBL.ARW.ruc new file mode 100644 index 00000000..c53410d0 --- /dev/null +++ b/WPS/metgrid/METGRID.TBL.ARW.ruc @@ -0,0 +1,524 @@ +======================================== +name=ST + z_dim_name=num_st_layers + derived=yes +# IF + fill_lev = 10 : ST000010(200100) + fill_lev = 40 : ST010040(200100) + fill_lev = 100 : ST040100(200100) + fill_lev = 200 : ST100200(200100) +# ELSE IF + fill_lev = 10 : ST000010(200100) + fill_lev = 200 : ST010200(200100) +# ELSE + fill_lev = 7 : ST000007(200100) + fill_lev = 28 : ST007028(200100) + fill_lev = 100 : ST028100(200100) + fill_lev = 289 : ST100289(200100) +======================================== +name=SM + z_dim_name=num_sm_layers + derived=yes +# IF + fill_lev = 10 : SM000010(200100) + fill_lev = 40 : SM010040(200100) + fill_lev = 100 : SM040100(200100) + fill_lev = 200 : SM100200(200100) +# ELSE IF + fill_lev = 10: SM000010(200100) + fill_lev = 200 : SM010200(200100) +# ELSE + fill_lev = 7 : SM000007(200100) + fill_lev = 28 : SM007028(200100) + fill_lev = 100 : SM028100(200100) + fill_lev = 289 : SM100289(200100) +======================================== +name=SW + z_dim_name=num_sw_layers + derived=yes +# IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010040(200100) + fill_lev = 3 : SW040100(200100) + fill_lev = 4 : SW100200(200100) +# ELSE IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010200(200100) +======================================== +name=SOIL_LAYERS + derived=yes + z_dim_name=num_st_layers + flag_in_output=FLAG_SOIL_LAYERS + fill_lev=all:vertical_index; level_template=ST +======================================== +name=SOILM + z_dim_name=num_soilm_levels + derived=yes + fill_lev = 0 : SOILM000(200100) + fill_lev = 5 : SOILM005(200100) + fill_lev = 20 : SOILM020(200100) + fill_lev = 40 : SOILM040(200100) + fill_lev = 160 : SOILM160(200100) + fill_lev = 300 : SOILM300(200100) +======================================== +name=SOILT + z_dim_name=num_soilt_levels + derived=yes + fill_lev = 0 : SOILT000(200100) + fill_lev = 5 : SOILT005(200100) + fill_lev = 20 : SOILT020(200100) + fill_lev = 40 : SOILT040(200100) + fill_lev = 160 : SOILT160(200100) + fill_lev = 300 : SOILT300(200100) +======================================== +name=SOIL_LEVELS + derived=yes + z_dim_name=num_soilt_levels + flag_in_output=FLAG_SOIL_LEVELS + fill_lev=all:vertical_index; level_template=SOILT +======================================== +name=PRES + z_dim_name=num_metgrid_levels + derived=yes + mandatory=yes # MUST HAVE THIS FIELD + fill_lev=all:PRESSURE + fill_lev=200100:PSFC(200100) + fill_lev=all:vertical_index; level_template=TT +======================================== +name=LANDSEA + interp_option=nearest_neighbor + fill_missing=-1. + fill_lev=200100:LANDMASK(1) +======================================== +name=XICE ; output_name=SEAICE # If we get XICE, use entry from SEAICE and + # write the field out as SEAICE +======================================== +name=SEAICE + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + fill_missing=0. +======================================== +name=H0ML + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + fill_missing=0. +======================================== +name=SNOW + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. + flag_in_output=FLAG_SNOW +======================================== +name=SKINTEMP + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + masked=both +# interp_land_mask = LANDSEA(1) + interp_water_mask = SOILM000(1) + fill_missing=0. +======================================== +name=PSFC + interp_option=four_pt+average_4pt + fill_lev=200100:const(200100.) + flag_in_output=FLAG_PSFC +======================================== +name=VEGCAT + interp_option=nearest_neighbor + fill_missing=0. + flag_in_output=FLAG_VEGCAT +======================================== +name=CANWAT + interp_option=four_pt + fill_missing=0. +======================================== +name=SOILCAT + interp_option=nearest_neighbor + fill_missing=0. + flag_in_output=FLAG_SOILCAT +======================================== +name=SW000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW000010 +======================================== +name=SW010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW010040 +======================================== +name=SW040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW040100 +======================================== +name=SW100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW100200 +======================================== +name=SW010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW010200 +======================================== +name=SM000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM000010 +======================================== +name=SM010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM010040 +======================================== +name=SM040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM040100 +======================================== +name=SM100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM100200 +======================================== +name=SM010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM010200 +======================================== +name=ST000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST000010 +======================================== +name=ST010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST010040 +======================================== +name=ST040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST040100 +======================================== +name=ST100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST100200 +======================================== +name=ST010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST010200 +======================================== +name=SM000007 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM000007 +======================================== +name=SM007028 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM007028 +======================================== +name=SM028100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM028100 +======================================== +name=SM100289 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM100289 +======================================== +name=ST000007 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST000007 +======================================== +name=ST007028 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST007028 +======================================== +name=ST028100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST028100 +======================================== +name=ST100289 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST100289 +======================================== +name=SOILM000 + interp_option=four_pt+average_4pt+search + masked=water +# interp_mask=LANDSEA(0) + missing_value=1. + fill_missing=1. + flag_in_output=FLAG_SOILM000 +======================================== +name=SOILM005 + interp_option=four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM005 +======================================== +name=SOILM020 + interp_option=four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM020 +======================================== +name=SOILM040 + interp_option=four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM040 +======================================== +name=SOILM160 + interp_option=four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM160 +======================================== +name=SOILM300 + interp_option=four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM300 +======================================== +name=SOILT000 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT000 +======================================== +name=SOILT005 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT005 +======================================== +name=SOILT020 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT020 +======================================== +name=SOILT040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT040 +======================================== +name=SOILT160 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT160 +======================================== +name=SOILT300 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT300 +======================================== +name=PMSL + interp_option=sixteen_pt+four_pt+average_4pt + flag_in_output=FLAG_SLP +======================================== +name=RH + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=TAVGSFC + interp_option=four_pt + fill_missing=0. + fill_lev=200100:TT(200100) + flag_in_output=FLAG_TAVGSFC +======================================== +name=T ; output_name=TT # If we get T, use entry from TT and + # write the field out as TT +======================================== +name=TT + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=U ; output_name=UU # If we get U, use entry from UU and + # write the field out as UU +======================================== +name=UU + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_u_field=yes + output_stagger=U + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=V ; output_name=VV # If we get V, use entry from VV and + # write the field out as VV +======================================== +name=VV + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_v_field=yes + output_stagger=V + fill_missing=0. + fill_lev=200100:const(-1.E30) +======================================== +name=SST + interp_option=sixteen_pt+four_pt + fill_missing=0. + missing_value=-1.E30 + flag_in_output=FLAG_SST +======================================== +name=QV + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QV +======================================== +name=QR + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QR +======================================== +name=QC + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QC +======================================== +name=QI + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QI +======================================== +name=QS + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QS +======================================== +name=QG + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QG +======================================== +name=QNI + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QNI +======================================== +name=VPTMP + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) +======================================== +name=PRESSURE + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:PSFC(200100) +======================================== +name=GHT + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:SOILHGT(200100) + fill_lev=200100:HGT_M(1) +======================================== +name=HGTT + output=no + interp_option=nearest_neighbor +======================================== +name=SNOWH + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. + flag_in_output=FLAG_SNOWH +======================================== +name=SOILHGT + interp_option=four_pt+average_4pt + flag_in_output=FLAG_SOILHGT +======================================== +name=RHOSN + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. +======================================== +name=TSNOW + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. +======================================== +name=QVG + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. +======================================== diff --git a/WPS/metgrid/METGRID.TBL.NMM b/WPS/metgrid/METGRID.TBL.NMM new file mode 100644 index 00000000..1bba703c --- /dev/null +++ b/WPS/metgrid/METGRID.TBL.NMM @@ -0,0 +1,490 @@ +======================================== +name=STC_WPS + z_dim_name=num_st_levels + derived=yes +# IF + fill_lev = 1 : ST000010(200100) + fill_lev = 2 : ST010040(200100) + fill_lev = 3 : ST040100(200100) + fill_lev = 4 : ST100200(200100) +# ELSE IF + fill_lev = 1 : ST000010(200100) + fill_lev = 2 : ST010200(200100) +# ELSE + fill_lev = 1 : ST000007(200100) + fill_lev = 2 : ST007028(200100) + fill_lev = 3 : ST028100(200100) + fill_lev = 4 : ST100255(200100) +======================================== +name=SMC_WPS + z_dim_name=num_sm_levels + derived=yes +# IF + fill_lev = 1 : SM000010(200100) + fill_lev = 2 : SM010040(200100) + fill_lev = 3 : SM040100(200100) + fill_lev = 4 : SM100200(200100) +# ELSE IF + fill_lev = 1 : SM000010(200100) + fill_lev = 2 : SM010200(200100) +# ELSE + fill_lev = 1 : SM000007(200100) + fill_lev = 2 : SM007028(200100) + fill_lev = 3 : SM028100(200100) + fill_lev = 4 : SM100255(200100) +======================================== +name=SW + z_dim_name=num_sw_levels + derived=yes +# IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010040(200100) + fill_lev = 3 : SW040100(200100) + fill_lev = 4 : SW100200(200100) +# ELSE IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010200(200100) +======================================== +name=SOILM + z_dim_name=num_soilm_levels + derived=yes + fill_lev = 1 : SOILM000(200100) + fill_lev = 2 : SOILM005(200100) + fill_lev = 3 : SOILM020(200100) + fill_lev = 4 : SOILM040(200100) + fill_lev = 5 : SOILM160(200100) + fill_lev = 6 : SOILM300(200100) +======================================== +name=SOILT + z_dim_name=num_soilt_levels + derived=yes + fill_lev = 1 : SOILT000(200100) + fill_lev = 2 : SOILT005(200100) + fill_lev = 3 : SOILT020(200100) + fill_lev = 4 : SOILT040(200100) + fill_lev = 5 : SOILT160(200100) + fill_lev = 6 : SOILT300(200100) +======================================== +name=PRES + z_dim_name=num_metgrid_levels + derived=yes + mandatory=yes # MUST HAVE THIS FIELD + fill_lev=all:PRESSURE + fill_lev=200100:PSFC(200100) + fill_lev=all:vertical_index; level_template=TT +======================================== +name=LANDSEA + interp_option=nearest_neighbor + fill_missing=-1. + fill_lev=200100:LANDMASK(1) +======================================== +name=SEAICE + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + fill_missing=0. +======================================== +name=H0ML + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + fill_missing=0. +======================================== +name=SNOW + interp_option=four_pt+average_4pt + masked=water + interp_mask=LANDSEA(0) + fill_missing=0. +======================================== +name=SKINTEMP + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + mandatory=yes # MUST HAVE THIS FIELD + masked=both + interp_land_mask = LANDSEA(1) + interp_water_mask = LANDSEA(0) + fill_missing=0. +======================================== +name=PSFC + interp_option=four_pt+average_4pt + fill_lev=200100:const(200100.) + flag_in_output=FLAG_PSFC +======================================== +name=VEGCAT + interp_option=nearest_neighbor + fill_missing=0. +======================================== +name=CANWAT + interp_option=four_pt + fill_missing=0. +======================================== +name=SOILCAT + interp_option=nearest_neighbor + fill_missing=0. +======================================== +name=SW000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW000010 +======================================== +name=SW010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW010040 +======================================== +name=SW040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW040100 +======================================== +name=SW100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW100200 +======================================== +name=SW010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW010200 +======================================== +name=SM000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM000010 +======================================== +name=SM010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM010040 +======================================== +name=SM040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM040100 +======================================== +name=SM100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM100200 +======================================== +name=SM010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM010200 +======================================== +name=ST000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST000010 +======================================== +name=ST010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST010040 +======================================== +name=ST040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST040100 +======================================== +name=ST100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST100200 +======================================== +name=ST010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST010200 +======================================== +name=SM000007 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM000007 +======================================== +name=SM007028 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM007028 +======================================== +name=SM028100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM028100 +======================================== +name=SM100255 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM100255 +======================================== +name=ST000007 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST000007 +======================================== +name=ST007028 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST007028 +======================================== +name=ST028100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST028100 +======================================== +name=ST100255 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST100255 +======================================== +name=SOILM000 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM000 +======================================== +name=SOILM005 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM005 +======================================== +name=SOILM020 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM020 +======================================== +name=SOILM040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM040 +======================================== +name=SOILM160 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM160 +======================================== +name=SOILM300 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM300 +======================================== +name=SOILT000 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT000 +======================================== +name=SOILT005 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT005 +======================================== +name=SOILT020 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT020 +======================================== +name=SOILT040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT040 +======================================== +name=SOILT160 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT160 +======================================== +name=SOILT300 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_SOILT300 +======================================== +name=PMSL + interp_option=sixteen_pt+four_pt+average_4pt +======================================== +name=RH + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) +======================================== +name=TAVGSFC + interp_option=four_pt + fill_missing=0. + fill_lev=200100:TT(200100) + flag_in_output=FLAG_TAVGSFC +======================================== +name=T ; output_name=TT # If we get T, use entry from TT and + # write the field out as TT +======================================== +name=TT + mandatory=yes # MUST HAVE THIS FIELD + interp_option=four_pt+average_4pt + fill_missing=0. +======================================== +name=U ; output_name=UU # If we get U, use entry from UU and + # write the field out as UU +======================================== +name=UU + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_u_field=yes + output_stagger=VV + fill_missing=0. +======================================== +name=V ; output_name=VV # If we get V, use entry from VV and + # write the field out as VV +======================================== +name=VV + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_v_field=yes + output_stagger=VV + fill_missing=0. +======================================== +name=SST + interp_option=sixteen_pt+four_pt + masked=land + fill_missing=0. + missing_value=-1.E30 + flag_in_output=FLAG_SST +======================================== +name=QV + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QV +======================================== +name=QR + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QR +======================================== +name=QC + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QC +======================================== +name=QI + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QI +======================================== +name=QS + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) +======================================== +name=QG + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QG +======================================== +name=VPTMP + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) +======================================== +name=PRESSURE + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:PSFC(200100) +======================================== +name=GHT + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:SOILHGT(200100) + fill_lev=200100:HGT_M(1) +======================================== +name=HGTT + output=no + interp_option=nearest_neighbor +======================================== +name=WEASD + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. +======================================== +name=SNOWH + interp_option=four_pt+average_4pt + masked=water + interp_mask=LANDSEA(0) + fill_missing=0. + flag_in_output=FLAG_SNOWH +======================================== +name=SOILHGT + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. + flag_in_output=FLAG_SOILHGT +======================================== diff --git a/WPS/metgrid/METGRID.TBL.NMM.rap b/WPS/metgrid/METGRID.TBL.NMM.rap new file mode 100644 index 00000000..0565575c --- /dev/null +++ b/WPS/metgrid/METGRID.TBL.NMM.rap @@ -0,0 +1,525 @@ +======================================== +name=STC_WPS + z_dim_name=num_st_levels + derived=yes +# IF + fill_lev = 1 : ST000010(200100) + fill_lev = 2 : ST010040(200100) + fill_lev = 3 : ST040100(200100) + fill_lev = 4 : ST100200(200100) +# ELSE IF + fill_lev = 1 : ST000010(200100) + fill_lev = 2 : ST010200(200100) +# ELSE + fill_lev = 1 : ST000007(200100) + fill_lev = 2 : ST007028(200100) + fill_lev = 3 : ST028100(200100) + fill_lev = 4 : ST100255(200100) +======================================== +name=SMC_WPS + z_dim_name=num_sm_levels + derived=yes +# IF + fill_lev = 1 : SM000010(200100) + fill_lev = 2 : SM010040(200100) + fill_lev = 3 : SM040100(200100) + fill_lev = 4 : SM100200(200100) +# ELSE IF + fill_lev = 1 : SM000010(200100) + fill_lev = 2 : SM010200(200100) +# ELSE + fill_lev = 1 : SM000007(200100) + fill_lev = 2 : SM007028(200100) + fill_lev = 3 : SM028100(200100) + fill_lev = 4 : SM100255(200100) +======================================== +name=SW + z_dim_name=num_sw_levels + derived=yes +# IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010040(200100) + fill_lev = 3 : SW040100(200100) + fill_lev = 4 : SW100200(200100) +# ELSE IF + fill_lev = 1 : SW000010(200100) + fill_lev = 2 : SW010200(200100) +======================================== +name=SOILM + z_dim_name=num_soilm_levels + derived=yes + fill_lev = 1 : SOILM000(200100) + fill_lev = 2 : SOILM005(200100) + fill_lev = 3 : SOILM020(200100) + fill_lev = 4 : SOILM040(200100) + fill_lev = 5 : SOILM160(200100) + fill_lev = 6 : SOILM300(200100) +======================================== +name=SOILT + z_dim_name=num_soilt_levels + derived=yes + fill_lev = 1 : SOILT000(200100) + fill_lev = 2 : SOILT005(200100) + fill_lev = 3 : SOILT020(200100) + fill_lev = 4 : SOILT040(200100) + fill_lev = 5 : SOILT160(200100) + fill_lev = 6 : SOILT300(200100) +======================================== +name=PRES + z_dim_name=num_metgrid_levels + derived=yes + mandatory=yes # MUST HAVE THIS FIELD + fill_lev=all:PRESSURE + fill_lev=200100:PSFC(200100) + fill_lev=all:vertical_index; level_template=TT +======================================== +name=LANDSEA + interp_option=nearest_neighbor + fill_missing=-1. + fill_lev=200100:LANDMASK(1) +======================================== +name=XICE ; output_name=SEAICE # If we get XICE, use entry from SEAICE and + # write the field out as SEAICE +======================================== +name=SEAICE + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + fill_missing=0. +======================================== +name=H0ML + interp_option=four_pt+average_4pt + interp_mask=LANDSEA(1) + masked=land + fill_missing=0. +======================================== +name=SNOW + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. + flag_in_output=FLAG_SNOW +======================================== +name=SNOH + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. + flag_in_output=FLAG_SNOH +======================================== +name=SKINTEMP + interp_option=sixteen_pt+four_pt+wt_average_4pt+wt_average_16pt+search + mandatory=yes # MUST HAVE THIS FIELD + masked=both +# interp_land_mask = LANDSEA(1) + interp_water_mask = SOILM000(1) + fill_missing=0. +======================================== +name=PSFC + interp_option=four_pt+average_4pt + fill_lev=200100:const(200100.) + flag_in_output=FLAG_PSFC +======================================== +name=VEGCAT + interp_option=nearest_neighbor + fill_missing=0. +======================================== +name=CANWAT + interp_option=four_pt + fill_missing=0. +======================================== +name=SOILCAT + interp_option=nearest_neighbor + fill_missing=0. +======================================== +name=SW000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW000010 +======================================== +name=SW010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW010040 +======================================== +name=SW040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW040100 +======================================== +name=SW100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW100200 +======================================== +name=SW010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SW010200 +======================================== +name=SM000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM000010 +======================================== +name=SM010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM010040 +======================================== +name=SM040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM040100 +======================================== +name=SM100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM100200 +======================================== +name=SM010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM010200 +======================================== +name=ST000010 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST000010 +======================================== +name=ST010040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST010040 +======================================== +name=ST040100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST040100 +======================================== +name=ST100200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST100200 +======================================== +name=ST010200 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST010200 +======================================== +name=SM000007 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM000007 +======================================== +name=SM007028 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM007028 +======================================== +name=SM028100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM028100 +======================================== +name=SM100255 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SM100255 +======================================== +name=ST000007 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST000007 +======================================== +name=ST007028 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST007028 +======================================== +name=ST028100 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST028100 +======================================== +name=ST100255 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=285. + flag_in_output=FLAG_ST100255 +======================================== +name=SOILM000 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=LANDSEA(0) + fill_missing=1. + flag_in_output=FLAG_SOILM000 +======================================== +name=SOILM005 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM005 +======================================== +name=SOILM020 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM020 +======================================== +name=SOILM040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM040 +======================================== +name=SOILM160 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM160 +======================================== +name=SOILM300 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=1. + flag_in_output=FLAG_SOILM300 +======================================== +name=SOILT000 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT000 +======================================== +name=SOILT005 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT005 +======================================== +name=SOILT020 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT020 +======================================== +name=SOILT040 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT040 +======================================== +name=SOILT160 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT160 +======================================== +name=SOILT300 + interp_option=sixteen_pt+four_pt+average_4pt+search + masked=water + interp_mask=SOILM000(1) + fill_missing=285. + flag_in_output=FLAG_SOILT300 +======================================== +name=PMSL + interp_option=sixteen_pt+four_pt+average_4pt +======================================== +name=RH + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) +======================================== +name=TAVGSFC + interp_option=four_pt + fill_missing=0. + fill_lev=200100:TT(200100) + flag_in_output=FLAG_TAVGSFC +======================================== +name=T ; output_name=TT # If we get T, use entry from TT and + # write the field out as TT +======================================== +name=TT + mandatory=yes # MUST HAVE THIS FIELD + interp_option=four_pt+average_4pt + fill_missing=0. +======================================== +name=U ; output_name=UU # If we get U, use entry from UU and + # write the field out as UU +======================================== +name=UU + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_u_field=yes + output_stagger=VV + fill_missing=0. +======================================== +name=V ; output_name=VV # If we get V, use entry from VV and + # write the field out as VV +======================================== +name=VV + mandatory=yes # MUST HAVE THIS FIELD + interp_option=sixteen_pt+four_pt+average_4pt + is_v_field=yes + output_stagger=VV + fill_missing=0. +======================================== +name=SST + interp_option=sixteen_pt+four_pt + masked=land + fill_missing=0. + missing_value=-1.E30 + flag_in_output=FLAG_SST +======================================== +name=QV + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QV +======================================== +name=QR + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QR +======================================== +name=QC + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QC +======================================== +name=QI + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QI +======================================== +name=QS + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) +======================================== +name=QG + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QG +======================================== +name=QNI + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QNI +======================================== +name=QNR + interp_option=four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) + flag_in_output=FLAG_QNR +======================================== +name=VPTMP + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:const(0.) +======================================== +name=PRESSURE + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:PSFC(200100) +======================================== +name=GHT + interp_option=sixteen_pt+four_pt+average_4pt + fill_missing=0. + fill_lev=200100:SOILHGT(200100) + fill_lev=200100:HGT_M(1) +======================================== +name=HGTT + output=no + interp_option=nearest_neighbor +======================================== +name=WEASD + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. +======================================== +name=SNOWH + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. + flag_in_output=FLAG_SNOWH +======================================== +name=SOILHGT + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. + flag_in_output=FLAG_SOILHGT +======================================== +name=RHOSN + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. +======================================== +name=TSNOW + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. +======================================== +name=QVG + interp_option=four_pt+average_4pt + masked=water + fill_missing=0. +======================================== diff --git a/WPS/metgrid/Makefile b/WPS/metgrid/Makefile new file mode 100755 index 00000000..32d3e647 --- /dev/null +++ b/WPS/metgrid/Makefile @@ -0,0 +1,56 @@ +# WPS component makefile + +include ../configure.wps + +bad_idea: + clear ; + @echo " " + @echo " " + @echo "go up a directory and type 'compile' to build WPS" + @echo " " + @echo " " + +all: + @if [ -e $(WRF_DIR_PRE)$(WRF_DIR)/frame/module_internal_header_util.o ] ; then \ + ( cd src ; \ + if [ "$(COMPILING_ON_CYGWIN_NT)" = yes ] ; then \ + WRF_DIR2=$(WRF_DIR) ; \ + else \ + WRF_DIR2=$(WRF_DIR_PRE)$(WRF_DIR) ; \ + fi ; \ + $(MAKE) $(TARGET) \ + WRF_DIR="$$WRF_DIR2" \ + FC="$(FC)" \ + CC="$(CC)" \ + CPP="$(CPP)" \ + FFLAGS="$(FFLAGS)" \ + CFLAGS="$(CFLAGS)" \ + LDFLAGS="$(LDFLAGS)" \ + CPPFLAGS="$(CPPFLAGS) -D_$(CPP_TARGET)" ) ; \ + if [ -e $(TARGET) ] ; then \ + $(RM) $(TARGET) ; \ + fi ; \ + if [ -e ../$(TARGET) ] ; then \ + $(RM) ../$(TARGET) ; \ + fi ; \ + if [ -e src/$(TARGET) ] ; then \ + $(LN) src/$(TARGET) . ; \ + fi ; \ + else \ + echo " " ; \ + echo " ***************************************************************************************" ; \ + echo " Error : Not building metgrid. Check whether WRF is compiled in $(WRF_DIR_PRE)$(WRF_DIR)" ; \ + echo " ***************************************************************************************" ; \ + echo " " ; \ + fi + +clean: + if [ -e $(TARGET) ] ; then \ + $(RM) $(TARGET) ; \ + fi + if [ -e ../$(TARGET) ] ; then \ + $(RM) ../$(TARGET) ; \ + fi + ( cd src ; $(MAKE) clean ) + +superclean: clean diff --git a/WPS/metgrid/gribmap.txt b/WPS/metgrid/gribmap.txt new file mode 100644 index 00000000..ad23f9b2 --- /dev/null +++ b/WPS/metgrid/gribmap.txt @@ -0,0 +1,1542 @@ +-1:255:255:2 +0:var0:undefined:: +1:PRES:Pressure [Pa]:P,PSFC:2 +2:PRMSL:Pressure reduced to MSL [Pa]:PMSL:2 +3:PTEND:Pressure tendency [Pa/s]:: +4:PVORT:Pot. vorticity [km^2/kg/s]:: +5:ICAHT:ICAO Standard Atmosphere Reference Height [M]:: +6:GP:Geopotential [m^2/s^2]:PHP:3 +7:HGT:Geopotential height [gpm]:SOILHGT:2 +8:DIST:Geometric height [m]:HGT:4 +9:HSTDV:Std dev of height [m]:: +10:TOZNE:Total ozone [Dobson]:: +11:TMP:Temp. [K]:T2,TSK:2 +12:VTMP:Virtual temp. [K]:: +13:POT:Potential temp. [K]:TH2,THZ0,T:4 +14:EPOT:Pseudo-adiabatic pot. temp. [K]:: +15:TMAX:Max. temp. [K]:: +16:TMIN:Min. temp. [K]:: +17:DPT:Dew point temp. [K]:: +18:DEPR:Dew point depression [K]:: +19:LAPR:Lapse rate [K/m]:: +20:VIS:Visibility [m]:: +21:RDSP1:Radar spectra (1) [non-dim]:: +22:RDSP2:Radar spectra (2) [non-dim]:: +23:RDSP3:Radar spectra (3) [non-dim]:: +24:PLI:Parcel lifted index (to 500 hPa) [K]:: +25:TMPA:Temp. anomaly [K]:: +26:PRESA:Pressure anomaly [Pa]:: +27:GPA:Geopotential height anomaly [gpm]:: +28:WVSP1:Wave spectra (1) [non-dim]:: +29:WVSP2:Wave spectra (2) [non-dim]:: +30:WVSP3:Wave spectra (3) [non-dim]:: +31:WDIR:Wind direction [deg]:: +32:WIND:Wind speed [m/s]:: +33:UGRD:u wind [m/s]:U,U10,UZ0:3 +34:VGRD:v wind [m/s]:V,V10,VZ0:3 +35:STRM:Stream function [m^2/s]:: +36:VPOT:Velocity potential [m^2/s]:: +37:MNTSF:Montgomery stream function [m^2/s^2]:: +38:SGCVV:Sigma coord. vertical velocity [/s]:WW:5 +39:VVEL:Pressure vertical velocity [Pa/s]:: +40:DZDT:Geometric vertical velocity [m/s]:W:5 +41:ABSV:Absolute vorticity [/s]:: +42:ABSD:Absolute divergence [/s]:: +43:RELV:Relative vorticity [/s]:: +44:RELD:Relative divergence [/s]:: +45:VUCSH:Vertical u shear [/s]:: +46:VVCSH:Vertical v shear [/s]:: +47:DIRC:Direction of current [deg]:: +48:SPC:Speed of current [m/s]:: +49:UOGRD:u of current [m/s]:: +50:VOGRD:v of current [m/s]:: +51:SPFH:Specific humidity [kg/kg]:QSFC:5 +52:RH:Relative humidity [%]:: +53:MIXR:Humidity mixing ratio [kg/kg]:QVAPOR,Q2,QVG:6 +54:PWAT:Precipitable water [kg/m^2]:: +55:VAPP:Vapor pressure [Pa]:: +56:SATD:Saturation deficit [Pa]:: +57:EVP:Evaporation [kg/m^2]:SFCEVP:3 +58:CICE:Cloud Ice [kg/m^2]:: +59:PRATE:Precipitation rate [kg/m^2/s]:: +60:TSTM:Thunderstorm probability [%]:: +61:APCP:Total precipitation [kg/m^2]:: +62:NCPCP:Large scale precipitation [kg/m^2]:NCPCP:2 +63:ACPCP:Convective precipitation [kg/m^2]:ACPCP:2 +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s]:: +65:WEASD:Accum. snow [kg/m^2]:WEASD:2 +66:SNOD:Snow depth [m]:SNOWH:4 +67:MIXHT:Mixed layer depth [m]:: +68:TTHDP:Transient thermocline depth [m]:: +69:MTHD:Main thermocline depth [m]:: +70:MTHA:Main thermocline anomaly [m]:: +71:TCDC:Total cloud cover [%]:CLDFRA:2 +72:CDCON:Convective cloud cover [%]:: +73:LCDC:Low level cloud cover [%]:: +74:MCDC:Mid level cloud cover [%]:: +75:HCDC:High level cloud cover [%]:: +76:CWAT:Cloud water [kg/m^2]:: +77:BLI:Best lifted index (to 500 hPa) [K]:: +78:SNOC:Convective snow [kg/m^2]:: +79:SNOL:Large scale snow [kg/m^2]:: +80:WTMP:Water temp. [K]:SST:2 +81:LAND:Land cover (land=1;sea=0) [fraction]:LANDMASK:1 +82:DSLM:Deviation of sea level from mean [m]:: +83:SFCR:Surface roughness [m]:ZNT:6 +84:ALBDO:Albedo [%]:ALBEDO:2 +85:TSOIL:Soil temp. [K]:TSLB:2 +86:SOILM:Soil moisture content [kg/m^2]:SMSTOT:2 +87:VEG:Vegetation [%]:VEGFRA:2 +88:SALTY:Salinity [kg/kg]:: +89:DEN:Density [kg/m^3]:: +90:WATR:Water runoff [kg/m^2]:: +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction]:XICE:1 +92:ICETK:Ice thickness [m]:: +93:DICED:Direction of ice drift [deg]:: +94:SICED:Speed of ice drift [m/s]:: +95:UICE:u of ice drift [m/s]:: +96:VICE:v of ice drift [m/s]:: +97:ICEG:Ice growth rate [m/s]:: +98:ICED:Ice divergence [/s]:: +99:SNOM:Snow melt [kg/m^2]:: +100:HTSGW:Sig height of wind waves and swell [m]:: +101:WVDIR:Direction of wind waves [deg]:: +102:WVHGT:Sig height of wind waves [m]:: +103:WVPER:Mean period of wind waves [s]:: +104:SWDIR:Direction of swell waves [deg]:: +105:SWELL:Sig height of swell waves [m]:: +106:SWPER:Mean period of swell waves [s]:: +107:DIRPW:Primary wave direction [deg]:: +108:PERPW:Primary wave mean period [s]:: +109:DIRSW:Secondary wave direction [deg]:: +110:PERSW:Secondary wave mean period [s]:: +111:NSWRS:Net short wave (surface) [W/m^2]:: +112:NLWRS:Net long wave (surface) [W/m^2]:: +113:NSWRT:Net short wave (top) [W/m^2]:: +114:NLWRT:Net long wave (top) [W/m^2]:: +115:LWAVR:Long wave [W/m^2]:: +116:SWAVR:Short wave [W/m^2]:: +117:GRAD:Global radiation [W/m^2]:: +118:BRTMP:Brightness temperature [K]:: +119:LWRAD:Radiance with respect to wave no. [W/m/sr]:: +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr]:: +121:LHTFL:Latent heat flux [W/m^2]:LH:4 +122:SHTFL:Sensible heat flux [W/m^2]:: +123:BLYDP:Boundary layer dissipation [W/m^2]:: +124:UFLX:Zonal momentum flux [N/m^2]:: +125:VFLX:Meridional momentum flux [N/m^2]:: +126:WMIXE:Wind mixing energy [J]:: +127:IMGD:Image data []:: +128:MSLSA:Mean sea level pressure (Std Atm) [Pa]:: +129:MSLMA:Mean sea level pressure (MAPS) [Pa]:: +130:LU_INDEX:Land Use Category:LU_INDEX:1 +131:DN:DNW values [dimensionless]:DNW:4 +132:SOILW:Volumetric soil moisture [fraction]:SMOIS:4 +133:XLAND:Land cover (land=1;sea=0) [fraction]:XLAND:1 +134:ZNW:Eta values [dimensionless]:ZNW:4 +135:GP_BASE:Base-state geopotential [m^2/s^2]:PHB:3 +136:GP_PERT:Perturbation geopotential [m^2/s^2]:PH:4 +137:CFN:CFN from WRF [?]:CFN:3 +138:CFN:CFN1 from WRF [?]:CFN1:3 +139:MU_BASE:Base-state dry air mass in column [Pa]:MUB:2 +140:MU_PERT:Perturbation dry air mass in column [Pa]:MU:2 +141:MU_INIT:Initial dry air mass in column [Pa]:MU0:2 +142:P_BASE:Base-state pressure [Pa]:PB:2 +143:DN:DN values [dimensionless]:DN:4 +144:SOILW:Volumetric soil moisture [fraction]:SMOIS:4 +145:RDNW:Inverse DNW values [dimensionless]:RDNW:3 +146:RDN:Inverse DN values [dimensionless]:RDN:3 +147:FNP:Lower weight for vertical stretching [dimensionless]:FNP:3 +148:FNM:Upper weight for vertical stretching [dimensionless]:FNM:3 +149:ZNU:Eta values [dimensionless]:ZNU:4 +150:ZETATOP:ZETA at model top [dimensionless]:ZETATOP:3 +151:PTOP:Pressure at model top [Pa]:P_TOP:3 +152:TIMESTEP:Timestep number:ITIMESTEP:3 +153:CLWMR:Cloud water [kg/kg]:QCLOUD,QCG:8 +154:var154:undefined:: +155:GFLUX:Ground heat flux [W/m^2]:HFX:4 +156:RAINBL:Acc. precip. over Boundary Layer time step [kg/m^2]:RAINBL:2 +157:var157:undefined:: +158:TKE:Turbulent kinetic energy [J/kg]:TKE:3 +159:TKE_MYJ:MYJ Turbulent kinetic energy [J/kg]:TKE_MYJ:3 +160:SOILL:Liquid volumetric soil moisture (non-frozen) [fraction]:SH2O:6 +161:var157:undefined:: +162:var157:undefined:: +163:var157:undefined:: +164:var157:undefined:: +165:var157:undefined:: +166:var157:undefined:: +167:var157:undefined:: +168:var157:undefined:: +169:var157:undefined:: +170:RWMR:Rain water mixing ratio [kg/kg]:QRAIN:5 +171:SNMR:Snow mixing ratio [kg/kg]:QSNOW:5 +172:RESM:Time weight constant for small steps:RESM:3 +173:RDX:Inverse X Grid Length [1/km]:RDX:9 +174:RDY:Inverse Y Grid Length [1/km]:RDY:9 +175:MLYNO:Model layer number (from bottom up) [non-dim]:NEST_POS: +176:NLAT:Latitude (-90 to +90) [deg]:XLAT:4 +177:ELON:East longitude (0-360) [deg]:XLONG:4 +178:ICMR:Ice mixing ratio [kg/kg]:QICE:5 +179:GRMR:Graupel mixing ratio:QGRAUP:5 +180:QNI:Ice Crystal Number Concentration:QNI:0 +181:ZS:Depth of soil layer (midpoint) [m]:ZS:3 +182:DZS:Thickness of soil layer [m]:DZS:3 +183:SINALPHA:Local sine of map rotation:SINALPHA:4 +184:COSALPHA:Local cosine of map rotation:COSALPHA:4 +185:TURB:Turbulence SIGMET/AIRMET [non-dim]:: +186:EPSTS:EPSTS in WRF [?]:EPSTS:3 +187:var187:undefined:: +188:AKMS:Surface Exchange for Momentum [m/s]:AKMS:3 +189:MAPFAC_M:Map Scale Factor [dimensionless]:MAPFAC_M:7 +190:MAPFAC_U:Map Scale Factor [dimensionless]:MAPFAC_U:7 +191:MAPFAC_V:Map Scale Factor [dimensionless]:MAPFAC_V:7 +192:GRDFLX:Ground Heat Flux [W m-2]:GRDFLX:3 +193:RMOL:Reciprical of Monin-Ohukhov length:RMOL:4 +194:var194:undefined:: +195:var195:undefined:: +196:var196:undefined:: +197:var197:undefined:: +198:var198:undefined:: +199:var199:undefined:: +200:var200:undefined:: +201:var201:undefined:: +202:SNOWCU:Cumulative Snow [cm]:SNOWCU,ACSNOW:2 +203:ACSNOM:Accumulated Melted Snow [cm]:ACSNOM:2 +204:DSWRF:Downward short wave flux [W/m^2]:SWDOWN:3 +205:DLWRF:Downward long wave flux [W/m^2]:GLW:3 +206:GSW:Net short wave flux [w/m^2]:GSW:3 +207:MSTAV:Moisture availability [%]:SMSTAV:4 +208:SFEXC:Exchange coefficient [m/s]:SFCEXC:5 +209:AKHS:Exchange coefficient for heat [m/s]:AKHS:5 +210:SOILCAT:Soil Category:SOILCAT:1 +211:VEGCAT:Vegetation Categore:VEGCAT:1 +212:TOPOSTDV:Standard Deviation of Topography:TOPOSTDV:3 +213:TOPOSLPX:Sub-gridscale mean topographic slope in x-direction:TOPOSLPX:6 +214:TOPOSLPY:Sub-gridscale mean topographic slope in y-direction:TOPOSLPY:6 +215:SLOPECAT:Topographical Categorical Slope:SLOPECAT:1 +216:LANDUSEF:Land use categorical fraction on mass grid:LANDUSEF:3 +217:SOILCTOP:Top layer soil type as a categorical fraction:SOILCTOP:3 +218:SOILCBOT:Top layer soil type as a categorical fraction:SOILCBOT:3 +219:var219:undefined:: +220:var220:undefined:: +221:HPBL:Planetary boundary layer height [m]:PBLH:2 +222:var222:undefined:: +223:CNWAT:Plant canopy surface water [kg/m^2]:CANWAT:8 +224:SOTYP:Soil type (Zobler) [0..9]:ISLTYP:1 +225:VGTYP:Vegetation type (as in SiB) [0..13]:IVGTYP:1 +226:var226:undefined:: +227:CSLAT:Coriolis sine latitude term:F:6 +228:CCLAT:Coriolis cosine latitude term:E:6 +229:CF1:Second-order extrapolation constant 1:CF1:5 +230:CF2:Second-order extrapolation constant 2:CF2:5 +231:CF3:Second-order extrapolation constant 3:CF3:5 +232:var232:undefined:: +233:var233:undefined:: +234:BGRUN:Baseflow-groundwater runoff [kg/m^2]:UDROFF:4 +235:SSRUN:Storm surface runoff [kg/m^2]:SFROFF:4 +236:SNOW:Snow Water Equivalent [kg/m^2]:SNOW:2 +237:var237:undefined:: +238:SNOWC:Snow cover [%]:SNOWC:1 +239:var239:undefined:: +240:QFX:Upward moisture flux [kg/(m^s)]:QFX:8 +241:var241:undefined:: +242:var242:undefined:: +243:var243:undefined:: +244:var244:undefined:: +245:var245:undefined:: +246:var246:undefined:: +247:NPRATE:Non-convective Precip Rate[kg/m^2/s]:RAINNCV:7 +248:CPRATE:Convective Precip Rate[kg/m^2/s]:RAINCV:7 +249:TMN:Ground Reservoir Temperature [K]:TMN:3 +250:var250:undefined:: +251:var251:undefined:: +252:var252:undefined:: +253:TNCPCP:Cumulative Large scale precipitation [kg/m^2]:RAINNC:3 +254:TACPCP:Cumulative Convective precipitation [kg/m^2]:RAINC:3 +255:var255:undefined:: +-1:255:255:3 +0:var0:undefined:: +1:PRES:Pressure [Pa]:: +2:PRMSL:Pressure reduced to MSL [Pa]:: +3:PTEND:Pressure tendency [Pa/s]:: +4:PVORT:Pot. vorticity [km^2/kg/s]:: +5:ICAHT:ICAO Standard Atmosphere Reference Height [M]:: +6:GP:Geopotential [m^2/s^2]:: +7:HGT:Geopotential height [gpm]:: +8:DIST:Geometric height [m]:: +9:HSTDV:Std dev of height [m]:: +10:TOZNE:Total ozone [Dobson]:: +11:TMP:Temp. [K]:: +12:VTMP:Virtual temp. [K]:: +13:POT:Potential temp. [K]:: +14:EPOT:Pseudo-adiabatic pot. temp. [K]:: +15:TMAX:Max. temp. [K]:: +16:TMIN:Min. temp. [K]:: +17:DPT:Dew point temp. [K]:: +18:DEPR:Dew point depression [K]:: +19:LAPR:Lapse rate [K/m]:: +20:VIS:Visibility [m]:: +21:RDSP1:Radar spectra (1) [non-dim]:: +22:RDSP2:Radar spectra (2) [non-dim]:: +23:RDSP3:Radar spectra (3) [non-dim]:: +24:PLI:Parcel lifted index (to 500 hPa) [K]:: +25:TMPA:Temp. anomaly [K]:: +26:PRESA:Pressure anomaly [Pa]:: +27:GPA:Geopotential height anomaly [gpm]:: +28:WVSP1:Wave spectra (1) [non-dim]:: +29:WVSP2:Wave spectra (2) [non-dim]:: +30:WVSP3:Wave spectra (3) [non-dim]:: +31:WDIR:Wind direction [deg]:: +32:WIND:Wind speed [m/s]:: +33:UGRD:u wind [m/s]:: +34:VGRD:v wind [m/s]:: +35:STRM:Stream function [m^2/s]:: +36:VPOT:Velocity potential [m^2/s]:: +37:MNTSF:Montgomery stream function [m^2/s^2]:: +38:SGCVV:Sigma coord. vertical velocity [/s]:: +39:VVEL:Pressure vertical velocity [Pa/s]:: +40:DZDT:Geometric vertical velocity [m/s]:: +41:ABSV:Absolute vorticity [/s]:: +42:ABSD:Absolute divergence [/s]:: +43:RELV:Relative vorticity [/s]:: +44:RELD:Relative divergence [/s]:: +45:VUCSH:Vertical u shear [/s]:: +46:VVCSH:Vertical v shear [/s]:: +47:DIRC:Direction of current [deg]:: +48:SPC:Speed of current [m/s]:: +49:UOGRD:u of current [m/s]:: +50:VOGRD:v of current [m/s]:: +51:SPFH:Specific humidity [kg/kg]:: +52:RH:Relative humidity [%]:: +53:MIXR:Humidity mixing ratio [kg/kg]:: +54:PWAT:Precipitable water [kg/m^2]:: +55:VAPP:Vapor pressure [Pa]:: +56:SATD:Saturation deficit [Pa]:: +57:EVP:Evaporation [kg/m^2]:: +58:CICE:Cloud Ice [kg/m^2]:: +59:PRATE:Precipitation rate [kg/m^2/s]:: +60:TSTM:Thunderstorm probability [%]:: +61:APCP:Total precipitation [kg/m^2]:: +62:NCPCP:Large scale precipitation [kg/m^2]:: +63:ACPCP:Convective precipitation [kg/m^2]:: +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s]:: +65:WEASD:Accum. snow [kg/m^2]:: +66:SNOD:Snow depth [m]:: +67:MIXHT:Mixed layer depth [m]:: +68:TTHDP:Transient thermocline depth [m]:: +69:MTHD:Main thermocline depth [m]:: +70:MTHA:Main thermocline anomaly [m]:: +71:TCDC:Total cloud cover [%]:: +72:CDCON:Convective cloud cover [%]:: +73:LCDC:Low level cloud cover [%]:: +74:MCDC:Mid level cloud cover [%]:: +75:HCDC:High level cloud cover [%]:: +76:CWAT:Cloud water [kg/m^2]:: +77:BLI:Best lifted index (to 500 hPa) [K]:: +78:SNOC:Convective snow [kg/m^2]:: +79:SNOL:Large scale snow [kg/m^2]:: +80:WTMP:Water temp. [K]:: +81:LAND:Land cover (land=1;sea=0) [fraction]:: +82:DSLM:Deviation of sea level from mean [m]:: +83:SFCR:Surface roughness [m]:: +84:ALBDO:Albedo [%]:: +85:TSOIL:Soil temp. [K]:: +86:SOILM:Soil moisture content [kg/m^2]:: +87:VEG:Vegetation [%]:: +88:SALTY:Salinity [kg/kg]:: +89:DEN:Density [kg/m^3]:: +90:WATR:Water runoff [kg/m^2]:: +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction]:: +92:ICETK:Ice thickness [m]:: +93:DICED:Direction of ice drift [deg]:: +94:SICED:Speed of ice drift [m/s]:: +95:UICE:u of ice drift [m/s]:: +96:VICE:v of ice drift [m/s]:: +97:ICEG:Ice growth rate [m/s]:: +98:ICED:Ice divergence [/s]:: +99:SNOM:Snow melt [kg/m^2]:: +100:HTSGW:Sig height of wind waves and swell [m]:: +101:WVDIR:Direction of wind waves [deg]:: +102:WVHGT:Sig height of wind waves [m]:: +103:WVPER:Mean period of wind waves [s]:: +104:SWDIR:Direction of swell waves [deg]:: +105:SWELL:Sig height of swell waves [m]:: +106:SWPER:Mean period of swell waves [s]:: +107:DIRPW:Primary wave direction [deg]:: +108:PERPW:Primary wave mean period [s]:: +109:DIRSW:Secondary wave direction [deg]:: +110:PERSW:Secondary wave mean period [s]:: +111:NSWRS:Net short wave (surface) [W/m^2]:: +112:NLWRS:Net long wave (surface) [W/m^2]:: +113:NSWRT:Net short wave (top) [W/m^2]:: +114:NLWRT:Net long wave (top) [W/m^2]:: +115:LWAVR:Long wave [W/m^2]:: +116:SWAVR:Short wave [W/m^2]:: +117:GRAD:Global radiation [W/m^2]:: +118:BRTMP:Brightness temperature [K]:: +119:LWRAD:Radiance with respect to wave no. [W/m/sr]:: +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr]:: +121:LHTFL:Latent heat flux [W/m^2]:: +122:SHTFL:Sensible heat flux [W/m^2]:: +123:BLYDP:Boundary layer dissipation [W/m^2]:: +124:UFLX:Zonal momentum flux [N/m^2]:: +125:VFLX:Meridional momentum flux [N/m^2]:: +126:WMIXE:Wind mixing energy [J]:: +127:IMGD:Image data []:: +128:STEP_NUMBER::STEP_NUMBER:1 +129:DTS:Small Timestep:DTS:1 +130:DTSEPS:Time Weight Constant for Small Steps:DTSEPS:1 +131:FCX:Relaxation Term for Boundary Zone:FCX:5 +132:GCX:Second relaxation term for boundary Zone:GCX:5 +133:DTBC:Time since boundary read:DTBC:1 +134:SHDMAX:Annual MAX veg fraction:SHDMAX:4 +135:SHDMIN:Annual MIN veg fraction:SHDMIN:4 +136:SNOALB:Annual MAX snow albedor in fraction:SNOALB:4 +137:FNDSNOWH::FNDSNOWH:1 +138:TOTSWDN:Radiation State Variable:TOTSWDN:4 +139:TOTLWDN:Radiation State Variable:TOTLWDN:4 +140:RSWTOA:Radiation State Variable:RSWTOA:4 +141:RLWTOA:Radiation State Variable:RLWTOA:4 +142:CZMEAN:Radiation State Variable:CZMEAN:4 +143:CFRACL:Radiation State Variable:CFRACL:4 +144:CFRACM:Radiation State Variable:CFRACM:4 +145:CFRACH:Radiation State Variable:CFRACH:4 +146:ACFRST:Radiation State Variable:ACFRST:4 +147:NCFRST:Radiation State Variable:NCFRST:4 +148:ACFRCV:Radiation State Variable:ACFRCV:4 +149:NCFRCV:Radiation State Variable:NCFRCV:4 +150:FNDSOILW::FNDSOILW:1 +151:U_FRAME:FRAME X WIND [m/s]:U_FRAME:4 +152:V_FRAME:FRAME Y WIND [m/s]:V_FRAME:4 +153:ALBBCK:Background Albedo:ALBBCK:4 +154:U_BASE:Base State X Wind in Idealized Cases:U_BASE:3 +155:V_BASE:Base State Y Wind in Idealized Cases:V_BASE:3 +156:QV_BASE:Base State QV in Idealized Cases:QV_BASE:5 +157:Z_BASE:Base State Height in Idealized Cases:Z_BASE:5 +158:T_BASE:Base State T in Idealized Cases:T_BASE:2 +159:var159:undefined:: +160:TSOIL1:Soil temp. 0-10 cm [K]:ST000010:2 +161:TSOIL2:Soil temp. 10-40 cm [K]:ST010040:2 +162:TSOIL3:Soil temp. 40-100 cm [K]:ST040100:2 +163:TSOIL4:Soil temp. 100-200 cm [K]:ST100200:2 +164:SOILM1:Soil moisture content 0-10 cm [kg/m^2]:SM000010:2 +165:SOILM2:Soil moisture content 10-40 cm [kg/m^2]:SM010040:2 +166:SOILM3:Soil moisture content 40-100 cm [kg/m^2]:SM040100:2 +167:SOILM4:Soil moisture content 100-200 cm [kg/m^2]:SM100200:2 +168:var168:undefined:: +169:var169:undefined:: +170:var170:undefined:: +171:var171:undefined:: +172:var172:undefined:: +173:var173:undefined:: +174:var174:undefined:: +175:var175:undefined:: +176:var176:undefined:: +177:var177:undefined:: +178:var178:undefined:: +179:var179:undefined:: +180:var180:undefined:: +181:var181:undefined:: +182:var182:undefined:: +183:var183:undefined:: +184:var184:undefined:: +185:var185:undefined:: +186:var186:undefined:: +187:var187:undefined:: +188:var188:undefined:: +189:var189:undefined:: +190:var190:undefined:: +191:var191:undefined:: +192:var192:undefined:: +193:var193:undefined:: +194:var194:undefined:: +195:var195:undefined:: +196:var196:undefined:: +197:var197:undefined:: +198:var198:undefined:: +199:var199:undefined:: +200:var200:undefined:: +201:var201:undefined:: +202:var202:undefined:: +203:var203:undefined:: +204:var204:undefined:: +205:var205:undefined:: +206:var206:undefined:: +207:var207:undefined:: +208:var208:undefined:: +209:var209:undefined:: +210:var210:undefined:: +211:var211:undefined:: +212:var212:undefined:: +213:var213:undefined:: +214:var214:undefined:: +215:var215:undefined:: +216:var216:undefined:: +217:var217:undefined:: +218:var218:undefined:: +219:var219:undefined:: +220:var220:undefined:: +221:var221:undefined:: +222:var222:undefined:: +223:LAT_LL_T:Lower Left Latitude of temp point [deg]:LAT_LL_T:4 +224:LAT_UL_T:Lower Left Latitude of temp point [deg]:LAT_UL_T:4 +225:LAT_UR_T:Lower Left Latitude of temp point [deg]:LAT_UR_T:4 +226:LAT_LR_T:Lower Left Latitude of temp point [deg]:LAT_LR_T:4 +227:LAT_LL_U:Lower Left Latitude of u point [deg]:LAT_LL_U:4 +228:LAT_UL_U:Lower Left Latitude of u point [deg]:LAT_UL_U:4 +229:LAT_UR_U:Lower Left Latitude of u point [deg]:LAT_UR_U:4 +230:LAT_LR_U:Lower Left Latitude of u point [deg]:LAT_LR_U:4 +231:LAT_LL_V:Lower Left Latitude of v point [deg]:LAT_LL_V:4 +232:LAT_UL_V:Lower Left Latitude of v point [deg]:LAT_UL_V:4 +233:LAT_UR_V:Lower Left Latitude of v point [deg]:LAT_UR_V:4 +234:LAT_LR_V:Lower Left Latitude of v point [deg]:LAT_LR_V:4 +235:LAT_LL_D:Lower Left Latitude of massless point [deg]:LAT_LL_D:4 +236:LAT_UL_D:Lower Left Latitude of massless point [deg]:LAT_UL_D:4 +237:LAT_UR_D:Lower Left Latitude of massless point [deg]:LAT_UR_D:4 +238:LAT_LR_D:Lower Left Latitude of massless point [deg]:LAT_LR_D:4 +239:LON_LL_T:Lower Left Longitude of temp point [deg]:LON_LL_T:4 +240:LON_UL_T:Lower Left Longitude of temp point [deg]:LON_UL_T:4 +241:LON_UR_T:Lower Left Longitude of temp point [deg]:LON_UR_T:4 +242:LON_LR_T:Lower Left Longitude of temp point [deg]:LON_LR_T:4 +243:LON_LL_U:Lower Left Longitude of u point [deg]:LON_LL_U:4 +244:LON_UL_U:Lower Left Longitude of u point [deg]:LON_UL_U:4 +245:LON_UR_U:Lower Left Longitude of u point [deg]:LON_UR_U:4 +246:LON_LR_U:Lower Left Longitude of u point [deg]:LON_LR_U:4 +247:LON_LL_V:Lower Left Longitude of v point [deg]:LON_LL_V:4 +248:LON_UL_V:Lower Left Longitude of v point [deg]:LON_UL_V:4 +249:LON_UR_V:Lower Left Longitude of v point [deg]:LON_UR_V:4 +250:LON_LR_V:Lower Left Longitude of v point [deg]:LON_LR_V:4 +251:LON_LL_D:Lower Left Longitude of massless point [deg]:LON_LL_D:4 +252:LON_UL_D:Lower Left Longitude of massless point [deg]:LON_UL_D:4 +253:LON_UR_D:Lower Left Longitude of massless point [deg]:LON_UR_D:4 +254:LON_LR_D:Lower Left Longitude of massless point [deg]:LON_LR_D:4 +255:var255:undefined:: +-1:255:255:4 +0:var0:undefined:: +1:PRES:Pressure [Pa]:: +2:PRMSL:Pressure reduced to MSL [Pa]:: +3:PTEND:Pressure tendency [Pa/s]:: +4:PVORT:Pot. vorticity [km^2/kg/s]:: +5:ICAHT:ICAO Standard Atmosphere Reference Height [M]:: +6:GP:Geopotential [m^2/s^2]:: +7:HGT:Geopotential height [gpm]:: +8:DIST:Geometric height [m]:: +9:HSTDV:Std dev of height [m]:: +10:TOZNE:Total ozone [Dobson]:: +11:TMP:Temp. [K]:: +12:VTMP:Virtual temp. [K]:: +13:POT:Potential temp. [K]:: +14:EPOT:Pseudo-adiabatic pot. temp. [K]:: +15:TMAX:Max. temp. [K]:: +16:TMIN:Min. temp. [K]:: +17:DPT:Dew point temp. [K]:: +18:DEPR:Dew point depression [K]:: +19:LAPR:Lapse rate [K/m]:: +20:VIS:Visibility [m]:: +21:RDSP1:Radar spectra (1) [non-dim]:: +22:RDSP2:Radar spectra (2) [non-dim]:: +23:RDSP3:Radar spectra (3) [non-dim]:: +24:PLI:Parcel lifted index (to 500 hPa) [K]:: +25:TMPA:Temp. anomaly [K]:: +26:PRESA:Pressure anomaly [Pa]:: +27:GPA:Geopotential height anomaly [gpm]:: +28:WVSP1:Wave spectra (1) [non-dim]:: +29:WVSP2:Wave spectra (2) [non-dim]:: +30:WVSP3:Wave spectra (3) [non-dim]:: +31:WDIR:Wind direction [deg]:: +32:WIND:Wind speed [m/s]:: +33:UGRD:u wind [m/s]:: +34:VGRD:v wind [m/s]:: +35:STRM:Stream function [m^2/s]:: +36:VPOT:Velocity potential [m^2/s]:: +37:MNTSF:Montgomery stream function [m^2/s^2]:: +38:SGCVV:Sigma coord. vertical velocity [/s]:: +39:VVEL:Pressure vertical velocity [Pa/s]:: +40:DZDT:Geometric vertical velocity [m/s]:: +41:ABSV:Absolute vorticity [/s]:: +42:ABSD:Absolute divergence [/s]:: +43:RELV:Relative vorticity [/s]:: +44:RELD:Relative divergence [/s]:: +45:VUCSH:Vertical u shear [/s]:: +46:VVCSH:Vertical v shear [/s]:: +47:DIRC:Direction of current [deg]:: +48:SPC:Speed of current [m/s]:: +49:UOGRD:u of current [m/s]:: +50:VOGRD:v of current [m/s]:: +51:SPFH:Specific humidity [kg/kg]:: +52:RH:Relative humidity [%]:: +53:MIXR:Humidity mixing ratio [kg/kg]:: +54:PWAT:Precipitable water [kg/m^2]:: +55:VAPP:Vapor pressure [Pa]:: +56:SATD:Saturation deficit [Pa]:: +57:EVP:Evaporation [kg/m^2]:: +58:CICE:Cloud Ice [kg/m^2]:: +59:PRATE:Precipitation rate [kg/m^2/s]:: +60:TSTM:Thunderstorm probability [%]:: +61:APCP:Total precipitation [kg/m^2]:: +62:NCPCP:Large scale precipitation [kg/m^2]:: +63:ACPCP:Convective precipitation [kg/m^2]:: +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s]:: +65:WEASD:Accum. snow [kg/m^2]:: +66:SNOD:Snow depth [m]:: +67:MIXHT:Mixed layer depth [m]:: +68:TTHDP:Transient thermocline depth [m]:: +69:MTHD:Main thermocline depth [m]:: +70:MTHA:Main thermocline anomaly [m]:: +71:TCDC:Total cloud cover [%]:: +72:CDCON:Convective cloud cover [%]:: +73:LCDC:Low level cloud cover [%]:: +74:MCDC:Mid level cloud cover [%]:: +75:HCDC:High level cloud cover [%]:: +76:CWAT:Cloud water [kg/m^2]:: +77:BLI:Best lifted index (to 500 hPa) [K]:: +78:SNOC:Convective snow [kg/m^2]:: +79:SNOL:Large scale snow [kg/m^2]:: +80:WTMP:Water temp. [K]:: +81:LAND:Land cover (land=1;sea=0) [fraction]:: +82:DSLM:Deviation of sea level from mean [m]:: +83:SFCR:Surface roughness [m]:: +84:ALBDO:Albedo [%]:: +85:TSOIL:Soil temp. [K]:: +86:SOILM:Soil moisture content [kg/m^2]:: +87:VEG:Vegetation [%]:: +88:SALTY:Salinity [kg/kg]:: +89:DEN:Density [kg/m^3]:: +90:WATR:Water runoff [kg/m^2]:: +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction]:: +92:ICETK:Ice thickness [m]:: +93:DICED:Direction of ice drift [deg]:: +94:SICED:Speed of ice drift [m/s]:: +95:UICE:u of ice drift [m/s]:: +96:VICE:v of ice drift [m/s]:: +97:ICEG:Ice growth rate [m/s]:: +98:ICED:Ice divergence [/s]:: +99:SNOM:Snow melt [kg/m^2]:: +100:HTSGW:Sig height of wind waves and swell [m]:: +101:WVDIR:Direction of wind waves [deg]:: +102:WVHGT:Sig height of wind waves [m]:: +103:WVPER:Mean period of wind waves [s]:: +104:SWDIR:Direction of swell waves [deg]:: +105:SWELL:Sig height of swell waves [m]:: +106:SWPER:Mean period of swell waves [s]:: +107:DIRPW:Primary wave direction [deg]:: +108:PERPW:Primary wave mean period [s]:: +109:DIRSW:Secondary wave direction [deg]:: +110:PERSW:Secondary wave mean period [s]:: +111:NSWRS:Net short wave (surface) [W/m^2]:: +112:NLWRS:Net long wave (surface) [W/m^2]:: +113:NSWRT:Net short wave (top) [W/m^2]:: +114:NLWRT:Net long wave (top) [W/m^2]:: +115:LWAVR:Long wave [W/m^2]:: +116:SWAVR:Short wave [W/m^2]:: +117:GRAD:Global radiation [W/m^2]:: +118:BRTMP:Brightness temperature [K]:: +119:LWRAD:Radiance with respect to wave no. [W/m/sr]:: +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr]:: +121:LHTFL:Latent heat flux [W/m^2]:: +122:SHTFL:Sensible heat flux [W/m^2]:: +123:BLYDP:Boundary layer dissipation [W/m^2]:: +124:UFLX:Zonal momentum flux [N/m^2]:: +125:VFLX:Meridional momentum flux [N/m^2]:: +126:WMIXE:Wind mixing energy [J]:: +127:IMGD:Image data []:: +128:RU_BXS::RU_BXS:1 +129:RU_BXE::RU_BXE:1 +130:RU_BYS::RU_BYS:1 +131:RU_BYE::RU_BYE:1 +132:RU_BTXS::RU_BTXS:6 +133:RU_BTXE::RU_BTXE:6 +134:RU_BTYS::RU_BTYS:6 +135:RU_BTYE::RU_BTYE:6 +136:RV_BXS::RV_BXS:1 +137:RV_BXE::RV_BXE:1 +138:RV_BYS::RV_BYS:1 +139:RV_BYE::RV_BYE:1 +140:RV_BTXS::RV_BTXS:6 +141:RV_BTXE::RV_BTXE:6 +142:RV_BTYS::RV_BTYS:6 +143:RV_BTYE::RV_BTYE:6 +144:RW_BXS::RW_BXS:1 +145:RW_BXE::RW_BXE:1 +146:RW_BYS::RW_BYS:1 +147:RW_BYE::RW_BYE:1 +148:RW_BTXS::RW_BTXS:6 +149:RW_BTXE::RW_BTXE:6 +150:RW_BTYS::RW_BTYS:6 +151:RW_BTYE::RW_BTYE:6 +152:PH_BXS::PH_BXS:-1 +153:PH_BXE::PH_BXE:-1 +154:PH_BYS::PH_BYS:-1 +155:PH_BYE::PH_BYE:-1 +156:PH_BTXS::PH_BTXS:4 +157:PH_BTXE::PH_BTXE:4 +158:PH_BTYS::PH_BTYS:4 +159:PH_BTYE::PH_BTYE:4 +160:T_BXS::T_BXS:1 +161:T_BXE::T_BXE:1 +162:T_BYS::T_BYS:1 +163:T_BYE::T_BYE:1 +164:T_BTXS::T_BTXS:6 +165:T_BTXE::T_BTXE:6 +166:T_BTYS::T_BTYS:6 +167:T_BTYE::T_BTYE:6 +168:MU_BXS::MU_BXS:4 +169:MU_BXE::MU_BXE:4 +170:MU_BYS::MU_BYS:4 +171:MU_BYE::MU_BYE:4 +172:MU_BTXS::MU_BTXS:9 +173:MU_BTXE::MU_BTXE:9 +174:MU_BTYS::MU_BTYS:9 +175:MU_BTYE::MU_BTYE:9 +176:RQV_BXS::RQV_BXS:4 +177:RQV_BXE::RQV_BXE:4 +178:RQV_BYS::RQV_BYS:4 +179:RQV_BYE::RQV_BYE:4 +180:RQV_BTXS::RQV_BTXS:10 +181:RQV_BTXE::RQV_BTXE:10 +182:RQV_BTYS::RQV_BTYS:10 +183:RQV_BTYE::RQV_BTYE:10 +184:RQC_BXS::RQC_BXS:4 +185:RQC_BXE::RQC_BXE:4 +186:RQC_BYS::RQC_BYS:4 +187:RQC_BYE::RQC_BYE:4 +188:RQC_BTXS::RQC_BTXS:10 +189:RQC_BTXE::RQC_BTXE:10 +190:RQC_BTYS::RQC_BTYS:10 +191:RQC_BTYE::RQC_BTYE:10 +192:RQR_BXS::RQR_BXS:4 +193:RQR_BXE::RQR_BXE:4 +194:RQR_BYS::RQR_BYS:4 +195:RQR_BYE::RQR_BYE:4 +196:RQR_BTXS::RQR_BTXS:10 +197:RQR_BTXE::RQR_BTXE:10 +198:RQR_BTYS::RQR_BTYS:10 +199:RQR_BTYE::RQR_BTYE:10 +200:RQI_BXS::RQI_BXS:4 +201:RQI_BXE::RQI_BXE:4 +202:RQI_BYS::RQI_BYS:4 +203:RQI_BYE::RQI_BYE:4 +204:RQI_BTXS::RQI_BTXS:10 +205:RQI_BTXE::RQI_BTXE:10 +206:RQI_BTYS::RQI_BTYS:10 +207:RQI_BTYE::RQI_BTYE:10 +208:RQS_BXS::RQS_BXS:4 +209:RQS_BXE::RQS_BXE:4 +210:RQS_BYS::RQS_BYS:4 +211:RQS_BYE::RQS_BYE:4 +212:RQS_BTXS::RQS_BTXS:10 +213:RQS_BTXE::RQS_BTXE:10 +214:RQS_BTYS::RQS_BTYS:10 +215:RQS_BTYE::RQS_BTYE:10 +216:RQG_BXS::RQG_BXS:4 +217:RQG_BXE::RQG_BXE:4 +218:RQG_BYS::RQG_BYS:4 +219:RQG_BYE::RQG_BYE:4 +220:RQG_BTXS::RQG_BTXS:10 +221:RQG_BTXE::RQG_BTXE:10 +222:RQG_BTYS::RQG_BTYS:10 +223:RQG_BTYE::RQG_BTYE:10 +224:var224:undefined:: +225:var225:undefined:: +226:var226:undefined:: +227:var227:undefined:: +228:var228:undefined:: +229:var229:undefined:: +230:var230:undefined:: +231:var231:undefined:: +232:var232:undefined:: +233:var233:undefined:: +234:var234:undefined:: +235:var235:undefined:: +236:var236:undefined:: +237:var237:undefined:: +238:var238:undefined:: +239:var239:undefined:: +240:var240:undefined:: +241:var241:undefined:: +242:var242:undefined:: +243:var243:undefined:: +244:var244:undefined:: +245:var245:undefined:: +246:var246:undefined:: +247:var247:undefined:: +248:var248:undefined:: +249:var249:undefined:: +250:var250:undefined:: +251:var251:undefined:: +252:var252:undefined:: +253:var253:undefined:: +254:var254:undefined:: +255:var255:undefined +-1:255:255:5 +0:var0:undefined:: +1:PRES:Pressure [Pa]:: +2:PRMSL:Pressure reduced to MSL [Pa]:: +3:PTEND:Pressure tendency [Pa/s]:: +4:PVORT:Pot. vorticity [km^2/kg/s]:: +5:ICAHT:ICAO Standard Atmosphere Reference Height [M]:: +6:GP:Geopotential [m^2/s^2]:: +7:HGT:Geopotential height [gpm]:: +8:DIST:Geometric height [m]:: +9:HSTDV:Std dev of height [m]:: +10:TOZNE:Total ozone [Dobson]:: +11:TMP:Temp. [K]:: +12:VTMP:Virtual temp. [K]:: +13:POT:Potential temp. [K]:: +14:EPOT:Pseudo-adiabatic pot. temp. [K]:: +15:TMAX:Max. temp. [K]:: +16:TMIN:Min. temp. [K]:: +17:DPT:Dew point temp. [K]:: +18:DEPR:Dew point depression [K]:: +19:LAPR:Lapse rate [K/m]:: +20:VIS:Visibility [m]:: +21:RDSP1:Radar spectra (1) [non-dim]:: +22:RDSP2:Radar spectra (2) [non-dim]:: +23:RDSP3:Radar spectra (3) [non-dim]:: +24:PLI:Parcel lifted index (to 500 hPa) [K]:: +25:TMPA:Temp. anomaly [K]:: +26:PRESA:Pressure anomaly [Pa]:: +27:GPA:Geopotential height anomaly [gpm]:: +28:WVSP1:Wave spectra (1) [non-dim]:: +29:WVSP2:Wave spectra (2) [non-dim]:: +30:WVSP3:Wave spectra (3) [non-dim]:: +31:WDIR:Wind direction [deg]:: +32:WIND:Wind speed [m/s]:: +33:UGRD:u wind [m/s]:: +34:VGRD:v wind [m/s]:: +35:STRM:Stream function [m^2/s]:: +36:VPOT:Velocity potential [m^2/s]:: +37:MNTSF:Montgomery stream function [m^2/s^2]:: +38:SGCVV:Sigma coord. vertical velocity [/s]:: +39:VVEL:Pressure vertical velocity [Pa/s]:: +40:DZDT:Geometric vertical velocity [m/s]:: +41:ABSV:Absolute vorticity [/s]:: +42:ABSD:Absolute divergence [/s]:: +43:RELV:Relative vorticity [/s]:: +44:RELD:Relative divergence [/s]:: +45:VUCSH:Vertical u shear [/s]:: +46:VVCSH:Vertical v shear [/s]:: +47:DIRC:Direction of current [deg]:: +48:SPC:Speed of current [m/s]:: +49:UOGRD:u of current [m/s]:: +50:VOGRD:v of current [m/s]:: +51:SPFH:Specific humidity [kg/kg]:: +52:RH:Relative humidity [%]:: +53:MIXR:Humidity mixing ratio [kg/kg]:: +54:PWAT:Precipitable water [kg/m^2]:: +55:VAPP:Vapor pressure [Pa]:: +56:SATD:Saturation deficit [Pa]:: +57:EVP:Evaporation [kg/m^2]:: +58:CICE:Cloud Ice [kg/m^2]:: +59:PRATE:Precipitation rate [kg/m^2/s]:: +60:TSTM:Thunderstorm probability [%]:: +61:APCP:Total precipitation [kg/m^2]:: +62:NCPCP:Large scale precipitation [kg/m^2]:: +63:ACPCP:Convective precipitation [kg/m^2]:: +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s]:: +65:WEASD:Accum. snow [kg/m^2]:: +66:SNOD:Snow depth [m]:: +67:MIXHT:Mixed layer depth [m]:: +68:TTHDP:Transient thermocline depth [m]:: +69:MTHD:Main thermocline depth [m]:: +70:MTHA:Main thermocline anomaly [m]:: +71:TCDC:Total cloud cover [%]:: +72:CDCON:Convective cloud cover [%]:: +73:LCDC:Low level cloud cover [%]:: +74:MCDC:Mid level cloud cover [%]:: +75:HCDC:High level cloud cover [%]:: +76:CWAT:Cloud water [kg/m^2]:: +77:BLI:Best lifted index (to 500 hPa) [K]:: +78:SNOC:Convective snow [kg/m^2]:: +79:SNOL:Large scale snow [kg/m^2]:: +80:WTMP:Water temp. [K]:: +81:LAND:Land cover (land=1;sea=0) [fraction]:: +82:DSLM:Deviation of sea level from mean [m]:: +83:SFCR:Surface roughness [m]:: +84:ALBDO:Albedo [%]:: +85:TSOIL:Soil temp. [K]:: +86:SOILM:Soil moisture content [kg/m^2]:: +87:VEG:Vegetation [%]:: +88:SALTY:Salinity [kg/kg]:: +89:DEN:Density [kg/m^3]:: +90:WATR:Water runoff [kg/m^2]:: +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction]:: +92:ICETK:Ice thickness [m]:: +93:DICED:Direction of ice drift [deg]:: +94:SICED:Speed of ice drift [m/s]:: +95:UICE:u of ice drift [m/s]:: +96:VICE:v of ice drift [m/s]:: +97:ICEG:Ice growth rate [m/s]:: +98:ICED:Ice divergence [/s]:: +99:SNOM:Snow melt [kg/m^2]:: +100:HTSGW:Sig height of wind waves and swell [m]:: +101:WVDIR:Direction of wind waves [deg]:: +102:WVHGT:Sig height of wind waves [m]:: +103:WVPER:Mean period of wind waves [s]:: +104:SWDIR:Direction of swell waves [deg]:: +105:SWELL:Sig height of swell waves [m]:: +106:SWPER:Mean period of swell waves [s]:: +107:DIRPW:Primary wave direction [deg]:: +108:PERPW:Primary wave mean period [s]:: +109:DIRSW:Secondary wave direction [deg]:: +110:PERSW:Secondary wave mean period [s]:: +111:NSWRS:Net short wave (surface) [W/m^2]:: +112:NLWRS:Net long wave (surface) [W/m^2]:: +113:NSWRT:Net short wave (top) [W/m^2]:: +114:NLWRT:Net long wave (top) [W/m^2]:: +115:LWAVR:Long wave [W/m^2]:: +116:SWAVR:Short wave [W/m^2]:: +117:GRAD:Global radiation [W/m^2]:: +118:BRTMP:Brightness temperature [K]:: +119:LWRAD:Radiance with respect to wave no. [W/m/sr]:: +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr]:: +121:LHTFL:Latent heat flux [W/m^2]:: +122:SHTFL:Sensible heat flux [W/m^2]:: +123:BLYDP:Boundary layer dissipation [W/m^2]:: +124:UFLX:Zonal momentum flux [N/m^2]:: +125:VFLX:Meridional momentum flux [N/m^2]:: +126:WMIXE:Wind mixing energy [J]:: +127:IMGD:Image data []:: +128:var128:undefined:: +129:PH0:Initial geopotential:PH0:1 +130:T_INIT:initial potential temperature:T_INIT:2 +131:AL:inverse perturbation density [m3 kg-1]:AL:4 +132:ALT:inverse density [m3 kg-1]:ALT:4 +133:SMFR3D:soil ice:SMFR3D:2 +134:KEEPFR3DFLAG:Flag - 1. Frozen Soil Yes, 0 - NO:KEEPFR3DFLAG:1 +135:CT:COUNTERGRADIENT TERM [K]:CT:2 +136:Z0:Background Roughness Length [m]:Z0:6 +137:KPBL:Level of PBL TOP:KPBL:1 +138:HTOP:Top of convection level:HTOP:1 +139:HBOT:Bottom of Convection Level:HBOT:1 +140:CUPPT:Accmulated Convective Rain Since Last Call to the Radiation:CUPPT:4 +141:F_ICE_PHY:Fraction of Ice:F_ICE_PHY:2 +142:F_RAIN_PHY:Fraction of Rain:F_RAIN_PHY:2 +143:F_RIMEF_PHY:Mass Ratio of Rimed Ice:F_RIMEF_PHY:2 +144:H_DIABATIC:Previous Timestep Condensational Heating:H_DIABATIC:9 +145:RTHCUTEN:COUPLED THETA TENDENCY DUE TO CUMULUS SCHEME [Pa K s-1]:RTHCUTEN:4 +146:RQVCUTEN:COUPLED Q_V TEND DUE TO CUMULUS SCHEME [Pa kg kg-1 s-1]:RQVCUTEN:4 +147:RQRCUTEN:COUPLED Q_R TEND DUE TO CUMULUS SCHEME [Pa kg kg-1 s-1]:RQRCUTEN:4 +148:RQCCUTEN:COUPLED Q_C TEND DUE TO CUMULUS SCHEME [Pa kg kg-1 s-1]:RQCCUTEN:4 +149:RQSCUTEN:COUPLED Q_S TEND DUE TO CUMULUS SCHEME [Pa kg kg-1 s-1]:RQSCUTEN:4 +150:RQICUTEN:COUPLED Q_I TEND DUE TO CUMULUS SCHEME [Pa kg kg-1 s-1]:RQICUTEN:4 +151:W0AVG:AVERAGE VERTICAL VELOCITY FOR KF CUMULUS SCHEME [m s-1]:W0AVG:6 +152:NCA:COUNTER OF THE CLOUD RELAXATION TIME IN KF CUMULUS SCHEME:NCA:0 +153:MASS_FLUX:DOWNDRAFT MASS FLUX FOR IN GRELL CUMULUS SCHEME [mb/hr]:MASS_FLUX:4 +154:APR_GR:PRECIP FROM CLOSURE OLD_GRELL [mm/hr]:APR_GR:4 +155:APR_W:PRECIP FROM CLOSURE W:APR_W:4 +156:APR_MC:PRECIP FROM CLOSURE KRISH MV [mm/hr]:APR_MC:4 +157:APR_ST:PRECIP FROM CLOSURE STABILITY [mm/hr]:APR_ST:4 +158:APR_AS:PRECIP FROM CLOSURE AS-TYPE [mm/hr]:APR_AS:4 +159:var159:undefined:: +160:APR_CAPMA:PRECIP FROM MAX CAP [mm/hr]:APR_CAPMA:4 +161:APR_CAPME:PRECIP FROM MEAN CAP [mm/hr]:APR_CAPME:4 +162:APR_CAPMI:PRECIP FROM MIN CAP [mm/hr]:APR_CAPMI:4 +163:XF_ENS:MASS FLUX PDF IN GRELL CUMULUS SCHEME[mb/hr]:XF_ENS:4 +164:PR_ENS:PRECIP RATE PDF IN GRELL CUMULUS SCHEME [mb/hr]:PR_ENS:4 +165:STEPCU:NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN CONVECTION CALLS:STEPCU:1 +166:RTHRATEN:COUPLED THETA TENDENCY DUE TO RADIATION [Pa K s-1]:RTHRATEN:4 +167:RTHRATLW:COUPLED THETA TENDENCY DUE TO LONG WAVE RADIATION [Pa K s-1]:RTHRATLW:7 +168:RTHRATSW:COUPLED THETA TENDENCY DUE TO SHORT WAVE RADIATION [Pa K s-1]:RTHRATSW:7 +169:CLDFRA:CLOUD FRACTION:CLDFRA:2 +170:RUBLTEN:COUPLED X WIND TENDENCY DUE TO PBL PARAMETERIZATION [Pa m s-2]:RUBLTEN:4 +171:RVBLTEN:COUPLED Y WIND TENDENCY DUE TO PBL PARAMETERIZATION [Pa m s-2]:RVBLTEN:4 +172:RTHBLTEN:COUPLED THETA TENDENCY DUE TO PBL PARAMETERIZATION [Pa K s-1]:RTHBLTEN:4 +173:RQVBLTEN:COUPLED Q_V TENDENCY DUE TO PBL PARAMETERIZATION [Pa kg kg-1 s-1]:RQVBLTEN:6 +174:RQCBLTEN:COUPLED Q_C TENDENCY DUE TO PBL PARAMETERIZATION [Pa kg kg-1 s-1]:RQCBLTEN:6 +175:RQIBLTEN:COUPLED Q_I TENDENCY DUE TO PBL PARAMETERIZATION [Pa kg kg-1 s-1]:RQIBLTEN:6 +176:UST:U* IN SIMILARITY THEORY [m s-1]:UST:4 +177:CAPG:HEAT CAPACITY FOR SOIL [j K-1 m-3]:CAPG:3 +178:THC:THERMAL INERTIA [Cal cm-1 K-1 s-0.5]:THC:3 +179:FLHC:SURFACE EXCHANGE COEFFICIENT FOR HEAT:FLHC:3 +180:FLQC:SURFACE EXCHANGE COEFFICIENT FOR MOISTURE:FLQC:6 +181:QSG:SURFACE SATURATION WATER VAPOR MIXING RATIO [kg kg-1]:QSG:6 +182:SOILT1:TEMPERATURE INSIDE SNOW [K]:SOILT1:2 +183:TSNAV:AVERAGE SNOW TEMPERATURE [C]:TSNAV:2 +184:MAVAIL:SURFACE MOISTURE AVAILABLITY:MAVAIL:4 +185:TKESFCF:TKE AT THE SURFACE [m2/s2]:TKESFCF:3 +186:STEPBL:NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN PBL CALLS:STEPBL:1 +187:TAUCLDI:CLOUD OPTICAL THICKNESS FOR ICE:TAUCLDI:2 +188:TAUCLDC:CLOUD OPTICAL THICKNESS FOR WATER:TAUCLDC:2 +189:RTHFTEN:TEMPERATURE TENDENCY USED IN GRELL CUMULUS SCHEME [K/s]:RTHFTEN:6 +190:RQVFTEN:MOISTURE TENDENCY USED IN GRELL CUMULUS SCHEME [kg/s]:RQVFTEN:6 +191:EMISS:SURFACE EMISSIVITY:EMISS:4 +192:CLDEFI:Precipitation efficiency in BMJ Scheme:CLDEFI:4 +193:STEPRA:NUMBER OF FUNDAMENTAL TIMESTEPS BETWEEN RADIATION CALLS:STEPRA:1 +194:MOL:T* in Similarity Theory [K]:MOL:3 +195:ALB:??:ALB:4 +196:U_1:Restart Parm:U_1:3 +197:U_2:Restart Parm:U_2:3 +198:V_1:Restart Parm:V_1:3 +199:V_2:Restart Parm:V_2:3 +200:W_1:Restart Parm:W_1:5 +201:W_2:Restart Parm:W_2:5 +202:PH_1:Restart Parm:PH_1:4 +203:PH_2:Restart Parm:PH_2:4 +204:T_1:Restart Parm:T_1:3 +205:T_2:Restart Parm:T_2:3 +206:MU_1:Restart Parm:MU_1:2 +207:MU_2:Restart Parm:MU_2:2 +208:TKE_1:Restart Parm:TKE_1:3 +209:TKE_2:Restart Parm:TKE_2:3 +210:QVAPOR_1:Restart Parm:QVAPOR_1:6 +211:QVAPOR_2:Restart Parm:QVAPOR_2:6 +212:QCLOUD_1:Restart Parm:QCLOUD_1:6 +213:QCLOUD_2:Restart Parm:QCLOUD_2:6 +214:QRAIN_1:Restart Parm:QRAIN_1:6 +215:QRAIN_2:Restart Parm:QRAIN_2:6 +216:QICE_1:Restart Parm:QICE_1:6 +217:QICE_2:Restart Parm:QICE_2:6 +218:QSNOW_1:Restart Parm:QSNOW_1:6 +219:QSNOW_2:Restart Parm:QSNOW_2:6 +220:QGRAUP_1:Restart Parm:QGRAUP_1:6 +221:QGRAUP_2:Restart Parm:QGRAUP_2:6 +222:QZ0:Specific humidity at roughness length [kg/kg]:QZ0:5 +223:TBPVS_STATE:STATE FOR ETAMPNEW MICROPHYSICS:TBPVS_STATE:3 +224:TBPVS0_STATE:STATE FOR ETAMPNEW MICROPHYSICS:TBPVS0_STATE:3 +225:MP_RESTART_STATE:STATE VECTOR FOR MICROPHYSICS RESTARTS:MP_RESTART_STATE:3 +226:IMICROGRAM:flag 0/1 0=mixratio, 1=mcrograms/m3":IMICROGRAM:1 +227:MASS_AER_WATER:aerosol liquid water content:MASS_AER_WATER:6 +228:MASS_AER_DRY:dry aerosol mass:MASS_AER_DRY:6 +229:EXCH_H:EXCHANGE COEFFICIENTS:EXCH_H:3 +230:var230:undefined:: +231:var231:undefined:: +232:var232:undefined:: +233:var233:undefined:: +234:var234:undefined:: +235:var235:undefined:: +236:var236:undefined:: +237:var237:undefined:: +238:var238:undefined:: +239:var239:undefined:: +240:var240:undefined:: +241:var241:undefined:: +242:var242:undefined:: +243:var243:undefined:: +244:var244:undefined:: +245:var245:undefined:: +246:var246:undefined:: +247:var247:undefined:: +248:var248:undefined:: +249:var249:undefined:: +250:var250:undefined:: +251:var251:undefined:: +252:var252:undefined:: +253:var253:undefined:: +254:var254:undefined:: +255:var255:undefined:: +-1:7:-1:129 +0:var0:undefined +1:PRES:Pressure [Pa] +2:PRMSL:Pressure reduced to MSL [Pa] +3:PTEND:Pressure tendency [Pa/s] +4:PVORT:Pot. vorticity [km^2/kg/s] +5:ICAHT:ICAO Standard Atmosphere Reference Height [M] +6:GP:Geopotential [m^2/s^2] +7:HGT:Geopotential height [gpm] +8:DIST:Geometric height [m] +9:HSTDV:Std dev of height [m] +10:TOZNE:Total ozone [Dobson] +11:TMP:Temp. [K] +12:VTMP:Virtual temp. [K] +13:POT:Potential temp. [K] +14:EPOT:Pseudo-adiabatic pot. temp. [K] +15:TMAX:Max. temp. [K] +16:TMIN:Min. temp. [K] +17:DPT:Dew point temp. [K] +18:DEPR:Dew point depression [K] +19:LAPR:Lapse rate [K/m] +20:VIS:Visibility [m] +21:RDSP1:Radar spectra (1) [non-dim] +22:RDSP2:Radar spectra (2) [non-dim] +23:RDSP3:Radar spectra (3) [non-dim] +24:PLI:Parcel lifted index (to 500 hPa) [K] +25:TMPA:Temp. anomaly [K] +26:PRESA:Pressure anomaly [Pa] +27:GPA:Geopotential height anomaly [gpm] +28:WVSP1:Wave spectra (1) [non-dim] +29:WVSP2:Wave spectra (2) [non-dim] +30:WVSP3:Wave spectra (3) [non-dim] +31:WDIR:Wind direction [deg] +32:WIND:Wind speed [m/s] +33:UGRD:u wind [m/s] +34:VGRD:v wind [m/s] +35:STRM:Stream function [m^2/s] +36:VPOT:Velocity potential [m^2/s] +37:MNTSF:Montgomery stream function [m^2/s^2] +38:SGCVV:Sigma coord. vertical velocity [/s] +39:VVEL:Pressure vertical velocity [Pa/s] +40:DZDT:Geometric vertical velocity [m/s] +41:ABSV:Absolute vorticity [/s] +42:ABSD:Absolute divergence [/s] +43:RELV:Relative vorticity [/s] +44:RELD:Relative divergence [/s] +45:VUCSH:Vertical u shear [/s] +46:VVCSH:Vertical v shear [/s] +47:DIRC:Direction of current [deg] +48:SPC:Speed of current [m/s] +49:UOGRD:u of current [m/s] +50:VOGRD:v of current [m/s] +51:SPFH:Specific humidity [kg/kg] +52:RH:Relative humidity [%] +53:MIXR:Humidity mixing ratio [kg/kg] +54:PWAT:Precipitable water [kg/m^2] +55:VAPP:Vapor pressure [Pa] +56:SATD:Saturation deficit [Pa] +57:EVP:Evaporation [kg/m^2] +58:CICE:Cloud Ice [kg/m^2] +59:PRATE:Precipitation rate [kg/m^2/s] +60:TSTM:Thunderstorm probability [%] +61:APCP:Total precipitation [kg/m^2] +62:NCPCP:Large scale precipitation [kg/m^2] +63:ACPCP:Convective precipitation [kg/m^2] +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s] +65:WEASD:Accum. snow [kg/m^2] +66:SNOD:Snow depth [m] +67:MIXHT:Mixed layer depth [m] +68:TTHDP:Transient thermocline depth [m] +69:MTHD:Main thermocline depth [m] +70:MTHA:Main thermocline anomaly [m] +71:TCDC:Total cloud cover [%] +72:CDCON:Convective cloud cover [%] +73:LCDC:Low level cloud cover [%] +74:MCDC:Mid level cloud cover [%] +75:HCDC:High level cloud cover [%] +76:CWAT:Cloud water [kg/m^2] +77:BLI:Best lifted index (to 500 hPa) [K] +78:SNOC:Convective snow [kg/m^2] +79:SNOL:Large scale snow [kg/m^2] +80:WTMP:Water temp. [K] +81:LAND:Land cover (land=1;sea=0) [fraction] +82:DSLM:Deviation of sea level from mean [m] +83:SFCR:Surface roughness [m] +84:ALBDO:Albedo [%] +85:TSOIL:Soil temp. [K] +86:SOILM:Soil moisture content [kg/m^2] +87:VEG:Vegetation [%] +88:SALTY:Salinity [kg/kg] +89:DEN:Density [kg/m^3] +90:WATR:Water runoff [kg/m^2] +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction] +92:ICETK:Ice thickness [m] +93:DICED:Direction of ice drift [deg] +94:SICED:Speed of ice drift [m/s] +95:UICE:u of ice drift [m/s] +96:VICE:v of ice drift [m/s] +97:ICEG:Ice growth rate [m/s] +98:ICED:Ice divergence [/s] +99:SNOM:Snow melt [kg/m^2] +100:HTSGW:Sig height of wind waves and swell [m] +101:WVDIR:Direction of wind waves [deg] +102:WVHGT:Sig height of wind waves [m] +103:WVPER:Mean period of wind waves [s] +104:SWDIR:Direction of swell waves [deg] +105:SWELL:Sig height of swell waves [m] +106:SWPER:Mean period of swell waves [s] +107:DIRPW:Primary wave direction [deg] +108:PERPW:Primary wave mean period [s] +109:DIRSW:Secondary wave direction [deg] +110:PERSW:Secondary wave mean period [s] +111:NSWRS:Net short wave (surface) [W/m^2] +112:NLWRS:Net long wave (surface) [W/m^2] +113:NSWRT:Net short wave (top) [W/m^2] +114:NLWRT:Net long wave (top) [W/m^2] +115:LWAVR:Long wave [W/m^2] +116:SWAVR:Short wave [W/m^2] +117:GRAD:Global radiation [W/m^2] +118:BRTMP:Brightness temperature [K] +119:LWRAD:Radiance with respect to wave no. [W/m/sr] +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr] +121:LHTFL:Latent heat flux [W/m^2] +122:SHTFL:Sensible heat flux [W/m^2] +123:BLYDP:Boundary layer dissipation [W/m^2] +124:UFLX:Zonal momentum flux [N/m^2] +125:VFLX:Meridional momentum flux [N/m^2] +126:WMIXE:Wind mixing energy [J] +127:IMGD:Image data [] +128:PAOT:Probability anomaly of temp [%] +129:PAOP:Probability anomaly of precip [%] +130:var130:undefined +131:FRAIN:Rain fraction of total liquid water [] +132:FICE:Ice fraction of total condensate [] +133:FRIME:Rime factor [] +134:CUEFI:Convective cloud efficiency [] +135:TCOND:Total condensate [kg/kg] +136:TCOLW:Total column cloud water [kg/m/m] +137:TCOLI:Total column cloud ice [kg/m/m] +138:TCOLR:Total column rain [kg/m/m] +139:TCOLS:Total column snow [kg/m/m] +140:TCOLC:Total column condensate [kg/m/m] +141:PLPL:Pressure of level from which parcel was lifted [Pa] +142:HLPL:Height of level from which parcel was lifted [Pa] +143:var143:undefined +144:var144:undefined +145:var145:undefined +146:var146:undefined +147:var147:undefined +148:var148:undefined +149:var149:undefined +150:var150:undefined +151:var151:undefined +152:var152:undefined +153:var153:undefined +154:var154:undefined +155:var155:undefined +156:var156:undefined +157:var157:undefined +158:var158:undefined +159:var159:undefined +160:var160:undefined +161:var161:undefined +162:var162:undefined +163:var163:undefined +164:var164:undefined +165:var165:undefined +166:var166:undefined +167:var167:undefined +168:var168:undefined +169:var169:undefined +170:ELRDI:Ellrod Index +171:TSEC:Seconds prior to initial reference time [sec] +172:var172:undefined +173:var173:undefined +174:var174:undefined +175:var175:undefined +176:var176:undefined +177:var177:undefined +178:var178:undefined +179:var179:undefined +180:OZCON:Ozone concentration [ppb] +181:OZCAT:Categorical ozone concentration [?] +182:KH:vertical heat eddy diffusivity [m^2/s] +183:var183:undefined +184:var184:undefined +185:var185:undefined +186:var186:undefined +187:var187:undefined +188:var188:undefined +189:var189:undefined +190:var190:undefined +191:var191:undefined +192:var192:undefined +193:var193:undefined +194:var194:undefined +195:var195:undefined +196:var196:undefined +197:var197:undefined +198:var198:undefined +199:var199:undefined +200:var200:undefined +201:var201:undefined +202:var202:undefined +203:var203:undefined +204:var204:undefined +205:var205:undefined +206:var206:undefined +207:var207:undefined +208:var208:undefined +209:var209:undefined +210:var210:undefined +211:var211:undefined +212:var212:undefined +213:var213:undefined +214:var214:undefined +215:var215:undefined +216:var216:undefined +217:var217:undefined +218:var218:undefined +219:var219:undefined +220:var220:undefined +221:var221:undefined +222:var222:undefined +223:var223:undefined +224:var224:undefined +225:var225:undefined +226:var226:undefined +227:var227:undefined +228:var228:undefined +229:var229:undefined +230:var230:undefined +231:var231:undefined +232:var232:undefined +233:var233:undefined +234:var234:undefined +235:var235:undefined +236:var236:undefined +237:var237:undefined +238:var238:undefined +239:var239:undefined +240:var240:undefined +241:var241:undefined +242:var242:undefined +243:var243:undefined +244:var244:undefined +245:var245:undefined +246:var246:undefined +247:var247:undefined +248:var248:undefined +249:var249:undefined +250:var250:undefined +251:var251:undefined +252:var252:undefined +253:var253:undefined +254:var254:undefined +255:var255:undefined +-1:7:-1:130 +0:var0:undefined +1:PRES:Pressure [Pa] +2:PRMSL:Pressure reduced to MSL [Pa] +3:PTEND:Pressure tendency [Pa/s] +4:PVORT:Pot. vorticity [km^2/kg/s] +5:ICAHT:ICAO Standard Atmosphere Reference Height [M] +6:GP:Geopotential [m^2/s^2] +7:HGT:Geopotential height [gpm] +8:DIST:Geometric height [m] +9:HSTDV:Std dev of height [m] +10:TOZNE:Total ozone [Dobson] +11:TMP:Temp. [K] +12:VTMP:Virtual temp. [K] +13:POT:Potential temp. [K] +14:EPOT:Pseudo-adiabatic pot. temp. [K] +15:TMAX:Max. temp. [K] +16:TMIN:Min. temp. [K] +17:DPT:Dew point temp. [K] +18:DEPR:Dew point depression [K] +19:LAPR:Lapse rate [K/m] +20:VIS:Visibility [m] +21:RDSP1:Radar spectra (1) [non-dim] +22:RDSP2:Radar spectra (2) [non-dim] +23:RDSP3:Radar spectra (3) [non-dim] +24:PLI:Parcel lifted index (to 500 hPa) [K] +25:TMPA:Temp. anomaly [K] +26:PRESA:Pressure anomaly [Pa] +27:GPA:Geopotential height anomaly [gpm] +28:WVSP1:Wave spectra (1) [non-dim] +29:WVSP2:Wave spectra (2) [non-dim] +30:WVSP3:Wave spectra (3) [non-dim] +31:WDIR:Wind direction [deg] +32:WIND:Wind speed [m/s] +33:UGRD:u wind [m/s] +34:VGRD:v wind [m/s] +35:STRM:Stream function [m^2/s] +36:VPOT:Velocity potential [m^2/s] +37:MNTSF:Montgomery stream function [m^2/s^2] +38:SGCVV:Sigma coord. vertical velocity [/s] +39:VVEL:Pressure vertical velocity [Pa/s] +40:DZDT:Geometric vertical velocity [m/s] +41:ABSV:Absolute vorticity [/s] +42:ABSD:Absolute divergence [/s] +43:RELV:Relative vorticity [/s] +44:RELD:Relative divergence [/s] +45:VUCSH:Vertical u shear [/s] +46:VVCSH:Vertical v shear [/s] +47:DIRC:Direction of current [deg] +48:SPC:Speed of current [m/s] +49:UOGRD:u of current [m/s] +50:VOGRD:v of current [m/s] +51:SPFH:Specific humidity [kg/kg] +52:RH:Relative humidity [%] +53:MIXR:Humidity mixing ratio [kg/kg] +54:PWAT:Precipitable water [kg/m^2] +55:VAPP:Vapor pressure [Pa] +56:SATD:Saturation deficit [Pa] +57:EVP:Evaporation [kg/m^2] +58:CICE:Cloud Ice [kg/m^2] +59:PRATE:Precipitation rate [kg/m^2/s] +60:TSTM:Thunderstorm probability [%] +61:APCP:Total precipitation [kg/m^2] +62:NCPCP:Large scale precipitation [kg/m^2] +63:ACPCP:Convective precipitation [kg/m^2] +64:SRWEQ:Snowfall rate water equiv. [kg/m^2/s] +65:WEASD:Accum. snow [kg/m^2] +66:SNOD:Snow depth [m] +67:MIXHT:Mixed layer depth [m] +68:TTHDP:Transient thermocline depth [m] +69:MTHD:Main thermocline depth [m] +70:MTHA:Main thermocline anomaly [m] +71:TCDC:Total cloud cover [%] +72:CDCON:Convective cloud cover [%] +73:LCDC:Low level cloud cover [%] +74:MCDC:Mid level cloud cover [%] +75:HCDC:High level cloud cover [%] +76:CWAT:Cloud water [kg/m^2] +77:BLI:Best lifted index (to 500 hPa) [K] +78:SNOC:Convective snow [kg/m^2] +79:SNOL:Large scale snow [kg/m^2] +80:WTMP:Water temp. [K] +81:LAND:Land cover (land=1;sea=0) [fraction] +82:DSLM:Deviation of sea level from mean [m] +83:SFCR:Surface roughness [m] +84:ALBDO:Albedo [%] +85:TSOIL:Soil temp. [K] +86:SOILM:Soil moisture content [kg/m^2] +87:VEG:Vegetation [%] +88:SALTY:Salinity [kg/kg] +89:DEN:Density [kg/m^3] +90:WATR:Water runoff [kg/m^2] +91:ICEC:Ice concentration (ice=1;no ice=0) [fraction] +92:ICETK:Ice thickness [m] +93:DICED:Direction of ice drift [deg] +94:SICED:Speed of ice drift [m/s] +95:UICE:u of ice drift [m/s] +96:VICE:v of ice drift [m/s] +97:ICEG:Ice growth rate [m/s] +98:ICED:Ice divergence [/s] +99:SNOM:Snow melt [kg/m^2] +100:HTSGW:Sig height of wind waves and swell [m] +101:WVDIR:Direction of wind waves [deg] +102:WVHGT:Sig height of wind waves [m] +103:WVPER:Mean period of wind waves [s] +104:SWDIR:Direction of swell waves [deg] +105:SWELL:Sig height of swell waves [m] +106:SWPER:Mean period of swell waves [s] +107:DIRPW:Primary wave direction [deg] +108:PERPW:Primary wave mean period [s] +109:DIRSW:Secondary wave direction [deg] +110:PERSW:Secondary wave mean period [s] +111:NSWRS:Net short wave (surface) [W/m^2] +112:NLWRS:Net long wave (surface) [W/m^2] +113:NSWRT:Net short wave (top) [W/m^2] +114:NLWRT:Net long wave (top) [W/m^2] +115:LWAVR:Long wave [W/m^2] +116:SWAVR:Short wave [W/m^2] +117:GRAD:Global radiation [W/m^2] +118:BRTMP:Brightness temperature [K] +119:LWRAD:Radiance with respect to wave no. [W/m/sr] +120:SWRAD:Radiance with respect ot wave len. [W/m^3/sr] +121:LHTFL:Latent heat flux [W/m^2] +122:SHTFL:Sensible heat flux [W/m^2] +123:BLYDP:Boundary layer dissipation [W/m^2] +124:UFLX:Zonal momentum flux [N/m^2] +125:VFLX:Meridional momentum flux [N/m^2] +126:WMIXE:Wind mixing energy [J] +127:IMGD:Image data [] +128:var128:undefined +129:var129:undefined +130:var130:undefined +131:var131:undefined +132:var132:undefined +133:var133:undefined +134:var134:undefined +135:var135:undefined +136:var136:undefined +137:var137:undefined +138:var138:undefined +139:var139:undefined +140:var140:undefined +141:var141:undefined +142:var142:undefined +143:CSNOW:Categorical snow [yes=1;no=0] +144:SOILW:Volumetric soil moisture (frozen + liquid) [fraction] +145:PEVPR:Potential evaporation rate [W/m^2] +146:VEGT:Vegetation canopy temperature [K] +147:BARET:Bare soil surface skin temperature [K] +148:AVSFT:Average surface skin temperature [K] +149:RADT:Effective radiative skin temperature [K] +150:SSTOR:Surface water storage [Kg/m^2] +151:LSOIL:Liquid soil moisture content (non-frozen) [Kg/m^2] +152:EWATR:Open water evaporation (standing water) [W/m^2] +153:var153:undefined +154:var154:undefined +155:GFLUX:Ground Heat Flux [W/m^2] +156:CIN:Convective inhibition [J/Kg] +157:CAPE:Convective available potential energy [J/Kg] +158:TKE:Turbulent Kinetic Energy [J/Kg] +159:MXSALB:Maximum snow albedo [%] +160:SOILL:Liquid volumetric soil moisture (non-frozen) [fraction] +161:ASNOW:Frozen precipitation (e.g. snowfall) [Kg/m^2] +162:ARAIN:Liquid precipitation (rainfall) [Kg/m^2] +163:GWREC:Groundwater recharge [Kg/m^2] +164:QREC:Flood plain recharge [Kg/m^2] +165:SNOWT:Snow temperature, depth-avg [K] +166:VBDSF:Visible beam downward solar flux [W/m^2] +167:VDDSF:Visible diffuse downward solar flux [W/m^2] +168:NBDSF:Near IR beam downward solar flux [W/m^2] +169:NDDSF:Near IR diffuse downward solar flux [W/m^2] +170:SNFALB:Snow-free albedo [%] +171:RLYRS:Number of soil layers in root zone [non-dim] +172:MFLX:Momentum flux [N/m^2] +173:var173:undefined +174:var174:undefined +175:var175:undefined +176:NLAT:Latitude (-90 to +90) [deg] +177:ELON:East longitude (0-360) [deg] +178:var178:undefined +179:ACOND:Aerodynamic conductance [m/s] +180:SNOAG:Snow age [s] +181:CCOND:Canopy conductance [m/s] +182:LAI:Leaf area index (0-9) [non-dim] +183:SFCRH:Roughness length for heat [m] +184:SALBD:Snow albedo (over snow cover area only) [%] +185:var185:undefined +186:var186:undefined +187:NDVI:Normalized Difference Vegetation Index [] +188:DRIP:Canopy drip [Kg/m^2] +189:var189:undefined +190:var190:undefined +191:var191:undefined +192:var192:undefined +193:var193:undefined +194:var194:undefined +195:var195:undefined +196:var196:undefined +197:var197:undefined +198:SBSNO:Sublimation (evaporation from snow) [W/m^2] +199:EVBS:Direct evaporation from bare soil [W/m^2] +200:EVCW:Canopy water evaporation [W/m^2] +201:var201:undefined +202:var202:undefined +203:RSMIN:Minimal stomatal resistance [s/m] +204:DSWRF:Downward shortwave radiation flux [W/m^2] +205:DLWRF:Downward longwave radiation flux [W/m^2] +206:var206:undefined +207:MSTAV:Moisture availability [%] +208:SFEXC:Exchange coefficient [(Kg/m^3)(m/s)] +209:var209:undefined +210:TRANS:Transpiration [W/m^2] +211:USWRF:Upward short wave radiation flux [W/m^2] +212:ULWRF:Upward long wave radiation flux [W/m^2] +213:var213:undefined +214:var214:undefined +215:var215:undefined +216:var216:undefined +217:var217:undefined +218:var218:undefined +219:WILT:Wilting point [fraction] +220:FLDCP:Field Capacity [fraction] +221:var221:undefined +222:SLTYP:Surface slope type [Index] +223:CNWAT:Plant canopy surface water [Kg/m^2] +224:SOTYP:Soil type [Index] +225:VGTYP:Vegetation type [Index] +226:BMIXL:Blackadars mixing length scale [m] +227:AMIXL:Asymptotic mixing length scale [m] +228:PEVAP:Potential evaporation [Kg/m^2] +229:SNOHF:Snow phase-change heat flux [W/m^2] +230:SMREF:Transpiration stress-onset (soil moisture) [fraction] +231:SMDRY:Direct evaporation cease (soil moisture) [fraction] +232:var232:undefined +233:var233:undefined +234:BGRUN:Subsurface runoff (baseflow) [Kg/m^2] +235:SSRUN:Surface runoff (non-infiltrating) [Kg/m^2] +236:var236:undefined +237:var237:undefined +238:SNOWC:Snow cover [%] +239:SNOT:Snow temperature [K] +240:POROS:Soil porosity [fraction] +241:var241:undefined +242:var242:undefined +243:var243:undefined +244:var244:undefined +245:var245:undefined +246:RCS:Solar parameter in canopy conductance [fraction] +247:RCT:Temperature parameter in canopy conductance [fraction] +248:RCQ:Humidity parameter in canopy conductance [fraction] +249:RCSOL:Soil moisture parameter in canopy conductance [fraction] +250:var250:undefined +251:var251:undefined +252:CD:Surface drag coefficient [non-dim] +253:FRICV:Surface friction velocity [m/s] +254:RI:Richardson number [non-dim] +255:var255:undefined diff --git a/WPS/metgrid/src/.gitignore b/WPS/metgrid/src/.gitignore new file mode 100644 index 00000000..7062b4c5 --- /dev/null +++ b/WPS/metgrid/src/.gitignore @@ -0,0 +1,3 @@ +*.f90 +*.o +*.mod diff --git a/WPS/metgrid/src/Makefile b/WPS/metgrid/src/Makefile new file mode 100644 index 00000000..e99bed3f --- /dev/null +++ b/WPS/metgrid/src/Makefile @@ -0,0 +1,89 @@ +include ../../configure.wps + +OBJS = cio.o wrf_debug.o bitarray_module.o constants_module.o datatype_module.o module_stringutil.o gridinfo_module.o metgrid.o input_module.o interp_module.o interp_option_module.o list_module.o llxy_module.o met_data_module.o minheap_module.o misc_definitions_module.o module_date_pack.o module_debug.o module_map_utils.o module_mergesort.o output_module.o parallel_module.o process_domain_module.o queue_module.o read_met_module.o rotate_winds_module.o storage_module.o write_met_module.o scan_input.o mpas_mesh.o target_mesh.o remapper.o + +all: + clear ; + @echo " " + @echo "go up two directories and type compile to build WPS" + @echo " " + @echo " " + +metgrid.exe: $(OBJS) + $(FC) $(LDFLAGS) -o $@ $(OBJS) \ + $(WRF_DIR)/frame/module_driver_constants.o \ + $(WRF_DIR)/frame/pack_utils.o $(WRF_DIR)/frame/module_machine.o \ + $(WRF_DIR)/frame/module_internal_header_util.o \ + $(WRF_INCLUDE) \ + $(WRF_LIB) \ + $(MPI_LIB) + +bitarray_module.o: module_debug.o + +cio.o: + +constants_module.o: + +datatype_module.o: bitarray_module.o module_debug.o + +module_stringutil.o: + +gridinfo_module.o: misc_definitions_module.o module_debug.o + +metgrid.o: gridinfo_module.o interp_option_module.o module_debug.o parallel_module.o process_domain_module.o + +input_module.o: gridinfo_module.o misc_definitions_module.o parallel_module.o queue_module.o + +interp_module.o: bitarray_module.o misc_definitions_module.o module_debug.o queue_module.o + +interp_option_module.o: list_module.o misc_definitions_module.o module_debug.o module_stringutil.o + +list_module.o: module_debug.o + +llxy_module.o: gridinfo_module.o module_map_utils.o module_debug.o misc_definitions_module.o + +met_data_module.o: + +minheap_module.o: datatype_module.o + +misc_definitions_module.o: + +module_date_pack.o: module_debug.o + +module_debug.o: parallel_module.o + +module_map_utils.o: constants_module.o misc_definitions_module.o module_debug.o + +module_mergesort.o: + +output_module.o: gridinfo_module.o misc_definitions_module.o module_debug.o parallel_module.o storage_module.o + +parallel_module.o: + +process_domain_module.o: module_date_pack.o bitarray_module.o gridinfo_module.o input_module.o interp_module.o interp_option_module.o list_module.o llxy_module.o misc_definitions_module.o module_debug.o module_mergesort.o output_module.o parallel_module.o read_met_module.o rotate_winds_module.o storage_module.o scan_input.o mpas_mesh.o target_mesh.o remapper.o + +queue_module.o: module_debug.o + +read_met_module.o: constants_module.o misc_definitions_module.o module_debug.o met_data_module.o + +rotate_winds_module.o: bitarray_module.o constants_module.o llxy_module.o misc_definitions_module.o module_debug.o + +storage_module.o: datatype_module.o minheap_module.o misc_definitions_module.o module_debug.o parallel_module.o module_stringutil.o + +wrf_debug.o: gridinfo_module.o cio.o + +write_met_module.o: misc_definitions_module.o module_debug.o met_data_module.o + +scan_input.o: + +mpas_mesh.o: scan_input.o + +target_mesh.o: + +remapper.o: scan_input.o mpas_mesh.o target_mesh.o + +clean: + $(RM) $(OBJS) *.f90 *.mod + $(RM) metgrid.exe + +superclean: clean diff --git a/WPS/metgrid/src/bitarray_module.F b/WPS/metgrid/src/bitarray_module.F new file mode 120000 index 00000000..63df80dc --- /dev/null +++ b/WPS/metgrid/src/bitarray_module.F @@ -0,0 +1 @@ +../../geogrid/src/bitarray_module.F \ No newline at end of file diff --git a/WPS/metgrid/src/cio.c b/WPS/metgrid/src/cio.c new file mode 120000 index 00000000..63c8e771 --- /dev/null +++ b/WPS/metgrid/src/cio.c @@ -0,0 +1 @@ +../../geogrid/src/cio.c \ No newline at end of file diff --git a/WPS/metgrid/src/constants_module.F b/WPS/metgrid/src/constants_module.F new file mode 120000 index 00000000..1b38c903 --- /dev/null +++ b/WPS/metgrid/src/constants_module.F @@ -0,0 +1 @@ +../../geogrid/src/constants_module.F \ No newline at end of file diff --git a/WPS/metgrid/src/datatype_module.F b/WPS/metgrid/src/datatype_module.F new file mode 100644 index 00000000..17120a8e --- /dev/null +++ b/WPS/metgrid/src/datatype_module.F @@ -0,0 +1,334 @@ +module datatype_module + + use bitarray_module + use module_debug + + ! Return values for comparison functions primary_cmp() and secondary_cmp() + integer, parameter :: LESS = -1, & + EQUAL = 0, & + GREATER = 1, & + NOT_EQUAL = 2 + + type header_info + integer :: version + + ! YYYY?MM?DD?HH?mm?ss + character (len=32) :: date + logical :: time_dependent, mask_field, constant_field + + ! Set = 0 if this is an analysis. + real :: forecast_hour + + ! AVN, GFS, ETA???, ARW, NMM, AGRMET, NAM, RUC, SST + character (len=32) :: fg_source + + character (len=128) :: field + character (len=128) :: units + character (len=128) :: description + + ! PRESSURE, SIGMA, NATIVE, HYBRID + character (len=32) :: vertical_coord + integer :: vertical_level + + ! XY, YX - ENOUGH INFO? + character (len=32) :: array_order + integer, dimension(2) :: dim1, dim2 + + logical :: is_wind_grid_rel + logical :: array_has_missing_values + + integer :: sr_x, sr_y + end type header_info + + type map_info + ! Mercator, Polar Stereographic, Lambert, Gaussian, Lat Lon + character (len=32) :: projection + + integer :: projection_flag + + ! For ARW: M, U, or V; for NMM: H or V + integer :: stagger + + real :: knownlat, knownlon, deltalat, deltalon + real :: deltax, deltay, xlonc, truelat1, truelat2 + real :: lat1, lon1 + end type map_info + + ! This is the datatype that is understood by data_storage module + type fg_input + ! BEGIN any types we want to keep and use for sorting in storage module + type (header_info) :: header + type (map_info) :: map + ! END any types we want to keep and use for sorting in storage module + + real, dimension(:,:), pointer :: r_arr !!!!! REQUIRED !!!!! + type (bitarray), pointer :: valid_mask, modified_mask + end type fg_input + + ! This type is used for the nodes of the secondary linked lists, the ones that + ! actually store data + type data_node + type (fg_input) :: fg_data + + type (data_node), pointer :: next, prev + integer, dimension(2) :: field_shape + + ! If non-zero, the array is actually stored in a Fortran unit + integer :: filenumber + + ! The following two are used by heaps + integer :: last_used + integer :: heap_index + end type data_node + + ! This type is used for the nodes in the primary linked lists, and thus has head + ! and tail pointers for secondary linked lists + type head_node + type (fg_input) :: fg_data + type (head_node), pointer :: next, prev + type (data_node), pointer :: fieldlist_head, fieldlist_tail + end type head_node + + + contains + + + ! Compares two fg_input types; returns EQUAL if the two should + ! belong to the same secondary linked list, and NOT_EQUAL otherwise + function primary_cmp(a, b) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a, b + + ! Return value + integer :: primary_cmp + +! if ((a%header%date == b%header%date) .and. & +! (a%header%forecast_hour == b%header%forecast_hour) .and. & +! (a%header%fg_source == b%header%fg_source) .and. & +! (a%header%field == b%header%field)) then + if (a%header%field == b%header%field) then + primary_cmp = EQUAL + else + primary_cmp = NOT_EQUAL + end if + + end function primary_cmp + + + ! Compares two fg_input types; returns EQUAL if the two belong + ! at the same position in a secondary linked list, LESS if "a" belongs + ! after "b", and GREATER if "a" belongs before "b" + function secondary_cmp(a, b) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a, b + + ! Return value + integer :: secondary_cmp + +! BUG: Eventually, we only want to sort pressure-level data this way, and +! all others the opposite way, as in the else case below. + if (a%header%time_dependent .or. a%header%constant_field) then + if (a%header%vertical_level > b%header%vertical_level) then + secondary_cmp = LESS + else if (a%header%vertical_level == b%header%vertical_level) then + secondary_cmp = EQUAL + else + secondary_cmp = GREATER + end if + + else + if (a%header%vertical_level < b%header%vertical_level) then + secondary_cmp = LESS + else if (a%header%vertical_level == b%header%vertical_level) then + secondary_cmp = EQUAL + else + secondary_cmp = GREATER + end if + end if + + end function secondary_cmp + + + ! Duplicates an fg_input type + subroutine dup(src, dst) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: src + type (fg_input), intent(out) :: dst + + dst%header = src%header + dst%map = src%map + dst%r_arr => src%r_arr + dst%valid_mask => src%valid_mask + dst%modified_mask => src%modified_mask + + end subroutine dup + + + function is_time_dependent(a) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a + + ! Return value + logical :: is_time_dependent + + is_time_dependent = a%header%time_dependent + + end function is_time_dependent + + + function is_mask_field(a) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a + + ! Return value + logical :: is_mask_field + + is_mask_field = a%header%mask_field + + end function is_mask_field + + + function is_constant_field(a) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a + + ! Return value + logical :: is_constant_field + + is_constant_field = a%header%constant_field + + end function is_constant_field + + + ! Returns the vertical level of an fg_input type + function get_level(a) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a + + ! Return value + integer :: get_level + + get_level = a%header%vertical_level + + end function get_level + + + ! Returns the description string of an fg_input type + function get_description(a) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a + + ! Return value + character (len=128) :: get_description + + get_description = a%header%description + + end function get_description + + + ! Returns the units string of an fg_input type + function get_units(a) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a + + ! Return value + character (len=128) :: get_units + + get_units = a%header%units + + end function get_units + + + ! Returns the field staggering an fg_input type + function get_staggering(a) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a + + ! Return value + integer :: get_staggering + + get_staggering = a%map%stagger + + end function get_staggering + + + ! Returns the fieldname string of an fg_input type + function get_fieldname(a) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a + + ! Return value + character (len=128) :: get_fieldname + + get_fieldname = a%header%field + + end function get_fieldname + + + ! Gives starting and ending indices for a field + subroutine get_dims(a, start_mem_1, end_mem_1, start_mem_2, end_mem_2) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a + integer, intent(out) :: start_mem_1, end_mem_1, start_mem_2, end_mem_2 + + start_mem_1 = a%header%dim1(1) + end_mem_1 = a%header%dim1(2) + start_mem_2 = a%header%dim2(1) + end_mem_2 = a%header%dim2(2) + + end subroutine get_dims + + + ! Prints relevant information from the headers of an fg_input type; mainly + ! used for debugging + subroutine print_header(a) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: a + + call mprintf(.true.,DEBUG,'FIELD : %s',s1=trim(a%header%field)) + call mprintf(.true.,DEBUG,'DATE : %s',s1=trim(a%header%date)) + call mprintf(.true.,DEBUG,'SOURCE : %s',s1=trim(a%header%fg_source)) + call mprintf(.true.,DEBUG,'FCST HR: %f',f1=a%header%forecast_hour) + + end subroutine print_header + +end module datatype_module diff --git a/WPS/metgrid/src/gridinfo_module.F b/WPS/metgrid/src/gridinfo_module.F new file mode 100644 index 00000000..b1243cf7 --- /dev/null +++ b/WPS/metgrid/src/gridinfo_module.F @@ -0,0 +1,362 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! MODULE GRIDINFO_MODULE +! +! This module handles (i.e., acquires, stores, and makes available) all data +! describing the model domains to be processed. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module gridinfo_module + + use misc_definitions_module + use module_debug + + ! Parameters + integer, parameter :: MAX_DOMAINS = 21 + + ! Variables + integer :: interval_seconds, max_dom, io_form_input, io_form_output, debug_level + integer, dimension(MAX_DOMAINS) :: subgrid_ratio_x, subgrid_ratio_y + integer :: process_only_bdy + character (len=MAX_FILENAME_LEN) :: opt_output_from_geogrid_path, & + opt_output_from_metgrid_path, opt_metgrid_tbl_path + character (len=128), dimension(MAX_DOMAINS) :: start_date, end_date + character (len=MAX_FILENAME_LEN), dimension(MAX_DOMAINS) :: fg_name, constants_name + logical :: do_tiled_input, do_tiled_output, nocolons + logical, dimension(MAX_DOMAINS) :: grid_is_active + character (len=1) :: gridtype + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_namelist_params + ! + ! Purpose: Read namelist parameters. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_namelist_params() + + implicit none + + ! Local variables + integer :: i, io_form_geogrid, io_form_metgrid + integer, dimension(MAX_DOMAINS) :: start_year, start_month, start_day, start_hour, start_minute, start_second, & + end_year, end_month, end_day, end_hour, end_minute, end_second + logical, dimension(MAX_DOMAINS) :: active_grid + integer :: funit + logical :: is_used + character (len=3) :: wrf_core + + namelist /share/ wrf_core, max_dom, start_date, end_date, & + start_year, end_year, start_month, end_month, & + start_day, end_day, start_hour, end_hour, & + start_minute, end_minute, start_second, end_second, & + interval_seconds, io_form_geogrid, opt_output_from_geogrid_path, & + debug_level, active_grid, nocolons, & + subgrid_ratio_x, subgrid_ratio_y + namelist /metgrid/ io_form_metgrid, fg_name, constants_name, process_only_bdy, opt_output_from_metgrid_path, & + opt_metgrid_tbl_path + + ! Set defaults + io_form_geogrid = 2 + io_form_metgrid = 2 + max_dom = 1 + wrf_core = 'ARW' + debug_level = 0 + nocolons = .false. + do i=1,MAX_DOMAINS + fg_name(i) = '*' + constants_name(i) = '*' + start_year(i) = 0 + start_month(i) = 0 + start_day(i) = 0 + start_hour(i) = 0 + start_minute(i) = 0 + start_second(i) = 0 + end_year(i) = 0 + end_month(i) = 0 + end_day(i) = 0 + end_hour(i) = 0 + end_minute(i) = 0 + end_second(i) = 0 + start_date(i) = '0000-00-00_00:00:00' + end_date(i) = '0000-00-00_00:00:00' + active_grid(i) = .true. + subgrid_ratio_x(i) = 1 + subgrid_ratio_y(i) = 1 + end do + process_only_bdy = 0 + opt_output_from_geogrid_path = './' + opt_output_from_metgrid_path = './' + opt_metgrid_tbl_path = 'metgrid/' + interval_seconds = INVALID + + ! Read parameters from Fortran namelist + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + open(funit,file='namelist.wps',status='old',form='formatted',err=1000) + read(funit,share) + read(funit,metgrid) + close(funit) + +! BUG: Better handle debug_level in module_debug + if ( debug_level .gt. 100 ) then + call set_debug_level(DEBUG) + else + call set_debug_level(WARN) + end if + + call mprintf(.true.,LOGFILE,'Using the following namelist variables:') + call mprintf(.true.,LOGFILE,'&SHARE') + call mprintf(.true.,LOGFILE,' WRF_CORE = %s',s1=wrf_core) + call mprintf(.true.,LOGFILE,' MAX_DOM = %i',i1=max_dom) + call mprintf(.true.,LOGFILE,' START_YEAR = %i',i1=start_year(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_year(i)) + end do + call mprintf(.true.,LOGFILE,' START_MONTH = %i',i1=start_month(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_month(i)) + end do + call mprintf(.true.,LOGFILE,' START_DAY = %i',i1=start_day(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_day(i)) + end do + call mprintf(.true.,LOGFILE,' START_HOUR = %i',i1=start_hour(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_hour(i)) + end do + call mprintf(.true.,LOGFILE,' START_MINUTE = %i',i1=start_minute(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_minute(i)) + end do + call mprintf(.true.,LOGFILE,' START_SECOND = %i',i1=start_second(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=start_second(i)) + end do + call mprintf(.true.,LOGFILE,' END_YEAR = %i',i1=end_year(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_year(i)) + end do + call mprintf(.true.,LOGFILE,' END_MONTH = %i',i1=end_month(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_month(i)) + end do + call mprintf(.true.,LOGFILE,' END_DAY = %i',i1=end_day(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_day(i)) + end do + call mprintf(.true.,LOGFILE,' END_HOUR = %i',i1=end_hour(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_hour(i)) + end do + call mprintf(.true.,LOGFILE,' END_MINUTE = %i',i1=end_minute(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_minute(i)) + end do + call mprintf(.true.,LOGFILE,' END_SECOND = %i',i1=end_second(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=end_second(i)) + end do + call mprintf(.true.,LOGFILE,' START_DATE = %s',s1=start_date(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %s',s1=start_date(i)) + end do + call mprintf(.true.,LOGFILE,' END_DATE = %s',s1=end_date(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %s',s1=end_date(i)) + end do + call mprintf(.true.,LOGFILE,' INTERVAL_SECONDS = %i',i1=interval_seconds) + call mprintf(.true.,LOGFILE,' IO_FORM_GEOGRID = %i',i1=io_form_geogrid) + call mprintf(.true.,LOGFILE,' OPT_OUTPUT_FROM_GEOGRID_PATH = %s',s1=opt_output_from_geogrid_path) + call mprintf(.true.,LOGFILE,' SUBGRID_RATIO_X = %i',i1=subgrid_ratio_x(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=subgrid_ratio_x(i)) + enddo + call mprintf(.true.,LOGFILE,' SUBGRID_RATIO_Y = %i',i1=subgrid_ratio_y(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %i',i1=subgrid_ratio_y(i)) + enddo + call mprintf(.true.,LOGFILE,' DEBUG_LEVEL = %i',i1=debug_level) + call mprintf(.true.,LOGFILE,' ACTIVE_GRID = %l',l1=active_grid(1)) + do i=2,max_dom + call mprintf(.true.,LOGFILE,' = %l',l1=active_grid(i)) + end do + call mprintf(.true.,LOGFILE,' NOCOLONS = %l',l1=nocolons) + call mprintf(.true.,LOGFILE,'/') + + call mprintf(.true.,LOGFILE,'&METGRID') + do i=1,MAX_DOMAINS + if (i == 1) then + if (fg_name(i) == '*') then + call mprintf(.true.,LOGFILE,' FG_NAME = ') + else + call mprintf(.true.,LOGFILE,' FG_NAME = %s',s1=fg_name(i)) + end if + else + if (fg_name(i) == '*') exit + call mprintf(.true.,LOGFILE,' = %s',s1=fg_name(i)) + end if + end do + do i=1,MAX_DOMAINS + if (i == 1) then + if (constants_name(i) == '*') then + call mprintf(.true.,LOGFILE,' CONSTANTS_NAME = ') + else + call mprintf(.true.,LOGFILE,' CONSTANTS_NAME = %s',s1=constants_name(i)) + end if + else + if (constants_name(i) == '*') exit + call mprintf(.true.,LOGFILE,' = %s',s1=constants_name(i)) + end if + end do + call mprintf(.true.,LOGFILE,' IO_FORM_METGRID = %i',i1=io_form_metgrid) + call mprintf(.true.,LOGFILE,' PROCESS_ONLY_BDY = %i',i1=process_only_bdy) + call mprintf(.true.,LOGFILE,' OPT_OUTPUT_FROM_METGRID_PATH = %s',s1=opt_output_from_metgrid_path) + call mprintf(.true.,LOGFILE,' OPT_METGRID_TBL_PATH = %s',s1=opt_metgrid_tbl_path) + call mprintf(.true.,LOGFILE,'/') + + + ! Convert wrf_core to uppercase letters + do i=1,3 + if (ichar(wrf_core(i:i)) >= ichar('a') .and. ichar(wrf_core(i:i)) <= ichar('z') ) & + wrf_core(i:i) = char(ichar(wrf_core(i:i))-ichar('a')+ichar('A')) + end do + + ! Before doing anything else, we must have a valid grid type + gridtype = ' ' + if (wrf_core == 'ARW') then + gridtype = 'C' + else if (wrf_core == 'NMM') then + gridtype = 'E' + end if + + call mprintf(gridtype /= 'C' .and. gridtype /= 'E', ERROR, & + 'A valid wrf_core must be specified in the namelist. '// & + 'Currently, only "ARW" and "NMM" are supported.') + + call mprintf(max_dom > MAX_DOMAINS, ERROR, & + 'In namelist, max_dom must be <= %i. To run with more'// & + ' than %i domains, increase the MAX_DOMAINS parameter.', & + i1=MAX_DOMAINS, i2=MAX_DOMAINS) + + call mprintf(gridtype /= 'C' .and. process_only_bdy /= 0, ERROR, & + 'The use of process_only_bdy is only currently supported in the "ARW" core. '// & + 'For "NMM", please set process_only_bdy to 0 in the namelist.') + + ! Handle IO_FORM+100 + if (io_form_geogrid > 100) then + io_form_geogrid = io_form_geogrid - 100 + do_tiled_input = .true. + else + do_tiled_input = .false. + end if + if (io_form_metgrid > 100) then + io_form_metgrid = io_form_metgrid - 100 + do_tiled_output = .true. + else + do_tiled_output = .false. + end if + + ! Check for valid io_form_geogrid + if ( & +#ifdef IO_BINARY + io_form_geogrid /= BINARY .and. & +#endif +#ifdef IO_NETCDF + io_form_geogrid /= NETCDF .and. & +#endif +#ifdef IO_GRIB1 + io_form_geogrid /= GRIB1 .and. & +#endif + .true. ) then + call mprintf(.true.,WARN,'Valid io_form_geogrid values are:') +#ifdef IO_BINARY + call mprintf(.true.,WARN,' %i (=BINARY)',i1=BINARY) +#endif +#ifdef IO_NETCDF + call mprintf(.true.,WARN,' %i (=NETCDF)',i1=NETCDF) +#endif +#ifdef IO_GRIB1 + call mprintf(.true.,WARN,' %i (=GRIB1)',i1=GRIB1) +#endif + call mprintf(.true.,ERROR,'No valid value for io_form_geogrid was specified in the namelist.') + end if + io_form_input = io_form_geogrid + + ! Check for valid io_form_metgrid + if ( & +#ifdef IO_BINARY + io_form_metgrid /= BINARY .and. & +#endif +#ifdef IO_NETCDF + io_form_metgrid /= NETCDF .and. & +#endif +#ifdef IO_GRIB1 + io_form_metgrid /= GRIB1 .and. & +#endif + .true. ) then + call mprintf(.true.,WARN,'Valid io_form_metgrid values are:') +#ifdef IO_BINARY + call mprintf(.true.,WARN,' %i (=BINARY)',i1=BINARY) +#endif +#ifdef IO_NETCDF + call mprintf(.true.,WARN,' %i (=NETCDF)',i1=NETCDF) +#endif +#ifdef IO_GRIB1 + call mprintf(.true.,WARN,' %i (=GRIB1)',i1=GRIB1) +#endif + call mprintf(.true.,ERROR,'No valid value for io_form_metgrid was specified in the namelist.') + end if + io_form_output = io_form_metgrid + + if (start_date(1) == '0000-00-00_00:00:00') then + do i=1,max_dom + ! Build starting date string + write(start_date(i), '(i4.4,a1,i2.2,a1,i2.2,a1,i2.2,a1,i2.2,a1,i2.2)') & + start_year(i),'-',start_month(i),'-',start_day(i),'_',start_hour(i),':',start_minute(i),':',start_second(i) + + ! Build ending date string + write(end_date(i), '(i4.4,a1,i2.2,a1,i2.2,a1,i2.2,a1,i2.2,a1,i2.2)') & + end_year(i),'-',end_month(i),'-',end_day(i),'_',end_hour(i),':',end_minute(i),':',end_second(i) + end do + end if + + + ! Paths need to end with a / + i = len_trim(opt_metgrid_tbl_path) + if (opt_metgrid_tbl_path(i:i) /= '/') then + opt_metgrid_tbl_path(i+1:i+1) = '/' + end if + + i = len_trim(opt_output_from_geogrid_path) + if (opt_output_from_geogrid_path(i:i) /= '/') then + opt_output_from_geogrid_path(i+1:i+1) = '/' + end if + + i = len_trim(opt_output_from_metgrid_path) + if (opt_output_from_metgrid_path(i:i) /= '/') then + opt_output_from_metgrid_path(i+1:i+1) = '/' + end if + + + ! Blank strings should be set to flag values + do i=1,max_dom + if (len_trim(constants_name(i)) == 0) then + constants_name(i) = '*' + end if + if (len_trim(fg_name(i)) == 0) then + fg_name(i) = '*' + end if + end do + + do i=1,max_dom + grid_is_active(i) = active_grid(i) + end do + + return + + 1000 call mprintf(.true.,ERROR,'Error opening file namelist.wps') + + end subroutine get_namelist_params + +end module gridinfo_module diff --git a/WPS/metgrid/src/input_module.F b/WPS/metgrid/src/input_module.F new file mode 100644 index 00000000..01456484 --- /dev/null +++ b/WPS/metgrid/src/input_module.F @@ -0,0 +1,861 @@ +module input_module + + use gridinfo_module + use misc_definitions_module + use module_debug +#ifdef IO_BINARY + use module_internal_header_util +#endif + use parallel_module + use queue_module + + type (queue) :: unit_desc + + ! WRF I/O API related variables + integer :: handle + + integer :: num_calls + + character (len=1) :: internal_gridtype + + contains + + + subroutine input_init(nest_number, istatus) + + implicit none + + ! Arguments + integer, intent(in) :: nest_number + integer, intent(out) :: istatus + +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" + + ! Local variables + integer :: i + integer :: comm_1, comm_2 + character (len=MAX_FILENAME_LEN) :: input_fname + + istatus = 0 + + if (my_proc_id == IO_NODE .or. do_tiled_input) then + +#ifdef IO_BINARY + if (io_form_input == BINARY) call ext_int_ioinit('sysdep info', istatus) +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) call ext_ncd_ioinit('sysdep info', istatus) +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) call ext_gr1_ioinit('sysdep info', istatus) +#endif + call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_ioinit') + + comm_1 = 1 + comm_2 = 1 + input_fname = ' ' + if (gridtype == 'C') then +#ifdef IO_BINARY + if (io_form_input == BINARY) input_fname = trim(opt_output_from_geogrid_path)//'geo_em.d .int' +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) input_fname = trim(opt_output_from_geogrid_path)//'geo_em.d .nc' +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) input_fname = trim(opt_output_from_geogrid_path)//'geo_em.d .grib' +#endif + i = len_trim(opt_output_from_geogrid_path) + write(input_fname(i+9:i+10),'(i2.2)') nest_number + else if (gridtype == 'E') then +#ifdef IO_BINARY + if (io_form_input == BINARY) input_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d .int' +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) input_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d .nc' +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) input_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d .grib' +#endif + i = len_trim(opt_output_from_geogrid_path) + write(input_fname(i+10:i+11),'(i2.2)') nest_number + end if + + if (nprocs > 1 .and. do_tiled_input) then + write(input_fname(len_trim(input_fname)+1:len_trim(input_fname)+5), '(a1,i4.4)') & + '_', my_proc_id + end if + + istatus = 0 +#ifdef IO_BINARY + if (io_form_input == BINARY) & + call ext_int_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus) +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) & + call ext_ncd_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus) +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) & + call ext_gr1_open_for_read(trim(input_fname), comm_1, comm_2, 'sysdep info', handle, istatus) +#endif + call mprintf((istatus /= 0),ERROR,'Couldn''t open file %s for input.',s1=input_fname) + + call q_init(unit_desc) + + end if ! (my_proc_id == IO_NODE .or. do_tiled_input) + + num_calls = 0 + + end subroutine input_init + + + subroutine read_next_field(start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + start_patch_k, end_patch_k, & + cname, cunits, cdesc, memorder, stagger, & + dimnames, sr_x, sr_y, real_array, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: start_patch_i, end_patch_i, & + start_patch_j, end_patch_j, & + start_patch_k, end_patch_k, & + sr_x, sr_y + real, pointer, dimension(:,:,:) :: real_array + character (len=*), intent(out) :: cname, memorder, stagger, cunits, cdesc + character (len=128), dimension(3), intent(inout) :: dimnames + integer, intent(inout) :: istatus + +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" + + ! Local variables + integer :: ndim, wrftype + integer :: sm1, em1, sm2, em2, sm3, em3, sp1, ep1, sp2, ep2, sp3, ep3 + integer, dimension(3) :: domain_start, domain_end, temp + real, pointer, dimension(:,:,:) :: real_domain + character (len=20) :: datestr + type (q_data) :: qd + + if (my_proc_id == IO_NODE .or. do_tiled_input) then + + if (num_calls == 0) then +#ifdef IO_BINARY + if (io_form_input == BINARY) call ext_int_get_next_time(handle, datestr, istatus) +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) call ext_ncd_get_next_time(handle, datestr, istatus) +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) call ext_gr1_get_next_time(handle, datestr, istatus) +#endif + end if + + num_calls = num_calls + 1 + +#ifdef IO_BINARY + if (io_form_input == BINARY) call ext_int_get_next_var(handle, cname, istatus) +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) call ext_ncd_get_next_var(handle, cname, istatus) +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) call ext_gr1_get_next_var(handle, cname, istatus) +#endif + end if + + if (nprocs > 1 .and. .not. do_tiled_input) call parallel_bcast_int(istatus) + if (istatus /= 0) return + + if (my_proc_id == IO_NODE .or. do_tiled_input) then + + istatus = 0 +#ifdef IO_BINARY + if (io_form_input == BINARY) then + call ext_int_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) then + call ext_ncd_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus) + call ext_ncd_get_var_ti_integer(handle, 'sr_x', & + trim(cname), temp(1), 1, temp(3), istatus) + call ext_ncd_get_var_ti_integer(handle, 'sr_y', & + trim(cname), temp(2), 1, temp(3), istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) then + call ext_gr1_get_var_info(handle, cname, ndim, memorder, stagger, domain_start, domain_end, wrftype, istatus) + call ext_gr1_get_var_ti_integer(handle, 'sr_x', & + trim(cname), temp(1), 1, temp(3), istatus) + call ext_gr1_get_var_ti_integer(handle, 'sr_y', & + trim(cname), temp(2), 1, temp(3), istatus) + end if +#endif + + call mprintf((istatus /= 0),ERROR,'In read_next_field(), problems with ext_pkg_get_var_info()') + + start_patch_i = domain_start(1) + start_patch_j = domain_start(2) + end_patch_i = domain_end(1) + end_patch_j = domain_end(2) + if (ndim == 3) then + start_patch_k = domain_start(3) + end_patch_k = domain_end(3) + else + domain_start(3) = 1 + domain_end(3) = 1 + start_patch_k = 1 + end_patch_k = 1 + end if + + nullify(real_domain) + + allocate(real_domain(start_patch_i:end_patch_i, start_patch_j:end_patch_j, start_patch_k:end_patch_k)) +#ifdef IO_BINARY + if (io_form_input == BINARY) then + call ext_int_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, WRF_REAL, & + 1, 1, 0, memorder, stagger, & + dimnames, domain_start, domain_end, domain_start, domain_end, & + domain_start, domain_end, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) then + call ext_ncd_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, WRF_REAL, & + 1, 1, 0, memorder, stagger, & + dimnames, domain_start, domain_end, domain_start, domain_end, & + domain_start, domain_end, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) then + call ext_gr1_read_field(handle, '0000-00-00_00:00:00', cname, real_domain, WRF_REAL, & + 1, 1, 0, memorder, stagger, & + dimnames, domain_start, domain_end, domain_start, domain_end, & + domain_start, domain_end, istatus) + end if +#endif + + call mprintf((istatus /= 0),ERROR,'In read_next_field(), got error code %i.', i1=istatus) + + if (io_form_input == BINARY) then + qd = q_remove(unit_desc) + cunits = qd%units + cdesc = qd%description + stagger = qd%stagger + sr_x = qd%sr_x + sr_y = qd%sr_y + else + cunits = ' ' + cdesc = ' ' + stagger = ' ' + sr_x = temp(1) + sr_y = temp(2) + +#ifdef IO_NETCDF + if (io_form_input == NETCDF) then + call ext_ncd_get_var_ti_char(handle, 'units', cname, cunits, istatus) + call ext_ncd_get_var_ti_char(handle, 'description', cname, cdesc, istatus) + call ext_ncd_get_var_ti_char(handle, 'stagger', cname, stagger, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) then + call ext_gr1_get_var_ti_char(handle, 'units', cname, cunits, istatus) + call ext_gr1_get_var_ti_char(handle, 'description', cname, cdesc, istatus) + call ext_gr1_get_var_ti_char(handle, 'stagger', cname, stagger, istatus) + end if +#endif + end if + + end if ! (my_proc_id == IO_NODE .or. do_tiled_input) + + if (nprocs > 1 .and. .not. do_tiled_input) then + call parallel_bcast_char(cname, len(cname)) + call parallel_bcast_char(cunits, len(cunits)) + call parallel_bcast_char(cdesc, len(cdesc)) + call parallel_bcast_char(memorder, len(memorder)) + call parallel_bcast_char(stagger, len(stagger)) + call parallel_bcast_char(dimnames(1), 128) + call parallel_bcast_char(dimnames(2), 128) + call parallel_bcast_char(dimnames(3), 128) + call parallel_bcast_int(domain_start(3)) + call parallel_bcast_int(domain_end(3)) + call parallel_bcast_int(sr_x) + call parallel_bcast_int(sr_y) + + sp1 = my_minx + ep1 = my_maxx - 1 + sp2 = my_miny + ep2 = my_maxy - 1 + sp3 = domain_start(3) + ep3 = domain_end(3) + + if (internal_gridtype == 'C') then + if (my_x /= nproc_x - 1 .or. stagger == 'U' .or. stagger == 'CORNER' .or. sr_x > 1) then + ep1 = ep1 + 1 + end if + if (my_y /= nproc_y - 1 .or. stagger == 'V' .or. stagger == 'CORNER' .or. sr_y > 1) then + ep2 = ep2 + 1 + end if + else if (internal_gridtype == 'E') then + ep1 = ep1 + 1 + ep2 = ep2 + 1 + end if + + if (sr_x > 1) then + sp1 = (sp1-1)*sr_x+1 + ep1 = ep1 *sr_x + end if + if (sr_y > 1) then + sp2 = (sp2-1)*sr_y+1 + ep2 = ep2 *sr_y + end if + + sm1 = sp1 + em1 = ep1 + sm2 = sp2 + em2 = ep2 + sm3 = sp3 + em3 = ep3 + + start_patch_i = sp1 + end_patch_i = ep1 + start_patch_j = sp2 + end_patch_j = ep2 + start_patch_k = sp3 + end_patch_k = ep3 + + allocate(real_array(sm1:em1,sm2:em2,sm3:em3)) + if (my_proc_id /= IO_NODE) then + allocate(real_domain(1,1,1)) + domain_start(1) = 1 + domain_start(2) = 1 + domain_start(3) = 1 + domain_end(1) = 1 + domain_end(2) = 1 + domain_end(3) = 1 + end if + call scatter_whole_field_r(real_array, & + sm1, em1, sm2, em2, sm3, em3, & + sp1, ep1, sp2, ep2, sp3, ep3, & + real_domain, & + domain_start(1), domain_end(1), & + domain_start(2), domain_end(2), & + domain_start(3), domain_end(3)) + deallocate(real_domain) + + else + + real_array => real_domain + + end if + + end subroutine read_next_field + + subroutine read_global_attrs(title, start_date, grid_type, dyn_opt, & + west_east_dim, south_north_dim, bottom_top_dim, & + we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, & + sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, & + map_proj, mminlu, num_land_cat, is_water, is_lake, is_ice, is_urban, & + isoilwater, grid_id, parent_id, i_parent_start, j_parent_start, & + i_parent_end, j_parent_end, dx, dy, cen_lat, moad_cen_lat, cen_lon, & + stand_lon, truelat1, truelat2, pole_lat, pole_lon, parent_grid_ratio, & + corner_lats, corner_lons, sr_x, sr_y) + + implicit none + + ! Arguments + integer, intent(out) :: dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, map_proj, & + is_water, is_lake, we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag, & + sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag, & + is_ice, is_urban, isoilwater, grid_id, parent_id, i_parent_start, j_parent_start, & + i_parent_end, j_parent_end, parent_grid_ratio, sr_x, sr_y, num_land_cat + real, intent(out) :: dx, dy, cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, & + pole_lat, pole_lon + real, dimension(16), intent(out) :: corner_lats, corner_lons + character (len=128), intent(out) :: title, start_date, grid_type, mminlu + + ! Local variables + integer :: istatus, i + real :: wps_version + character (len=128) :: cunits, cdesc, cstagger + integer, dimension(3) :: sr + type (q_data) :: qd + + if (my_proc_id == IO_NODE .or. do_tiled_input) then + +#ifdef IO_BINARY + if (io_form_input == BINARY) then + istatus = 0 + do while (istatus == 0) + cunits = ' ' + cdesc = ' ' + cstagger = ' ' + sr = 0 + call ext_int_get_var_ti_char(handle, 'units', 'VAR', cunits, istatus) + + if (istatus == 0) then + call ext_int_get_var_ti_char(handle, 'description', 'VAR', cdesc, istatus) + + if (istatus == 0) then + call ext_int_get_var_ti_char(handle, 'stagger', 'VAR', cstagger, istatus) + + if (istatus == 0) then + call ext_int_get_var_ti_integer(handle, 'sr_x', 'VAR', sr(1), 1, sr(3), istatus) + + if (istatus == 0) then + call ext_int_get_var_ti_integer(handle, 'sr_y', 'VAR', sr(2), 1, sr(3), istatus) + + qd%units = cunits + qd%description = cdesc + qd%stagger = cstagger + qd%sr_x = sr(1) + qd%sr_y = sr(2) + call q_insert(unit_desc, qd) + + end if + end if + end if + end if + end do + end if +#endif + + call ext_get_dom_ti_char ('TITLE', title) + if (index(title,'GEOGRID V3.9.1') /= 0) then + wps_version = 3.91 + else if (index(title,'GEOGRID V3.9.0.1') /= 0) then + wps_version = 3.901 + else if (index(title,'GEOGRID V3.9') /= 0) then + wps_version = 3.9 + else if (index(title,'GEOGRID V3.8.1') /= 0) then + wps_version = 3.81 + else if (index(title,'GEOGRID V3.8') /= 0) then + wps_version = 3.8 + else if (index(title,'GEOGRID V3.7.1') /= 0) then + wps_version = 3.71 + else if (index(title,'GEOGRID V3.7') /= 0) then + wps_version = 3.7 + else if (index(title,'GEOGRID V3.6.1') /= 0) then + wps_version = 3.61 + else if (index(title,'GEOGRID V3.6') /= 0) then + wps_version = 3.6 + else if (index(title,'GEOGRID V3.5.1') /= 0) then + wps_version = 3.51 + else if (index(title,'GEOGRID V3.5') /= 0) then + wps_version = 3.5 + else if (index(title,'GEOGRID V3.4.1') /= 0) then + wps_version = 3.41 + else if (index(title,'GEOGRID V3.4') /= 0) then + wps_version = 3.4 + else if (index(title,'GEOGRID V3.3.1') /= 0) then + wps_version = 3.31 + else if (index(title,'GEOGRID V3.3') /= 0) then + wps_version = 3.3 + else if (index(title,'GEOGRID V3.2.1') /= 0) then + wps_version = 3.21 + else if (index(title,'GEOGRID V3.2') /= 0) then + wps_version = 3.2 + else if (index(title,'GEOGRID V3.1.1') /= 0) then + wps_version = 3.11 + else if (index(title,'GEOGRID V3.1') /= 0) then + wps_version = 3.1 + else if (index(title,'GEOGRID V3.0.1') /= 0) then + wps_version = 3.01 + else + wps_version = 3.0 + end if + call mprintf(.true.,DEBUG,'Reading static data from WPS version %f', f1=wps_version) + call ext_get_dom_ti_char ('SIMULATION_START_DATE', start_date) + call ext_get_dom_ti_integer_scalar('WEST-EAST_GRID_DIMENSION', west_east_dim) + call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_GRID_DIMENSION', south_north_dim) + call ext_get_dom_ti_integer_scalar('BOTTOM-TOP_GRID_DIMENSION', bottom_top_dim) + call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_START_UNSTAG', we_patch_s) + call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_END_UNSTAG', we_patch_e) + call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_START_STAG', we_patch_s_stag) + call ext_get_dom_ti_integer_scalar('WEST-EAST_PATCH_END_STAG', we_patch_e_stag) + call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_UNSTAG', sn_patch_s) + call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_UNSTAG', sn_patch_e) + call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_STAG', sn_patch_s_stag) + call ext_get_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_STAG', sn_patch_e_stag) + call ext_get_dom_ti_char ('GRIDTYPE', grid_type) + call ext_get_dom_ti_real_scalar ('DX', dx) + call ext_get_dom_ti_real_scalar ('DY', dy) + call ext_get_dom_ti_integer_scalar('DYN_OPT', dyn_opt) + call ext_get_dom_ti_real_scalar ('CEN_LAT', cen_lat) + call ext_get_dom_ti_real_scalar ('CEN_LON', cen_lon) + call ext_get_dom_ti_real_scalar ('TRUELAT1', truelat1) + call ext_get_dom_ti_real_scalar ('TRUELAT2', truelat2) + call ext_get_dom_ti_real_scalar ('MOAD_CEN_LAT', moad_cen_lat) + call ext_get_dom_ti_real_scalar ('STAND_LON', stand_lon) + call ext_get_dom_ti_real_scalar ('POLE_LAT', pole_lat) + call ext_get_dom_ti_real_scalar ('POLE_LON', pole_lon) + call ext_get_dom_ti_real_vector ('corner_lats', corner_lats, 16) + call ext_get_dom_ti_real_vector ('corner_lons', corner_lons, 16) + call ext_get_dom_ti_integer_scalar('MAP_PROJ', map_proj) + call ext_get_dom_ti_char ('MMINLU', mminlu) + if ( wps_version >= 3.01 ) then + call ext_get_dom_ti_integer_scalar('NUM_LAND_CAT', num_land_cat) + else + num_land_cat = 24 + end if + call ext_get_dom_ti_integer_scalar('ISWATER', is_water) + if ( wps_version >= 3.01 ) then + call ext_get_dom_ti_integer_scalar('ISLAKE', is_lake) + else + is_lake = -1 + end if + call ext_get_dom_ti_integer_scalar('ISICE', is_ice) + call ext_get_dom_ti_integer_scalar('ISURBAN', is_urban) + call ext_get_dom_ti_integer_scalar('ISOILWATER', isoilwater) + call ext_get_dom_ti_integer_scalar('grid_id', grid_id) + call ext_get_dom_ti_integer_scalar('parent_id', parent_id) + call ext_get_dom_ti_integer_scalar('i_parent_start', i_parent_start) + call ext_get_dom_ti_integer_scalar('j_parent_start', j_parent_start) + call ext_get_dom_ti_integer_scalar('i_parent_end', i_parent_end) + call ext_get_dom_ti_integer_scalar('j_parent_end', j_parent_end) + call ext_get_dom_ti_integer_scalar('parent_grid_ratio', parent_grid_ratio) + call ext_get_dom_ti_integer_scalar('sr_x', sr_x) + call ext_get_dom_ti_integer_scalar('sr_y', sr_y) + + end if + + + if (nprocs > 1 .and. .not. do_tiled_input) then + + call parallel_bcast_char(title, len(title)) + call parallel_bcast_char(start_date, len(start_date)) + call parallel_bcast_char(grid_type, len(grid_type)) + call parallel_bcast_int(west_east_dim) + call parallel_bcast_int(south_north_dim) + call parallel_bcast_int(bottom_top_dim) + call parallel_bcast_int(we_patch_s) + call parallel_bcast_int(we_patch_e) + call parallel_bcast_int(we_patch_s_stag) + call parallel_bcast_int(we_patch_e_stag) + call parallel_bcast_int(sn_patch_s) + call parallel_bcast_int(sn_patch_e) + call parallel_bcast_int(sn_patch_s_stag) + call parallel_bcast_int(sn_patch_e_stag) + call parallel_bcast_int(sr_x) + call parallel_bcast_int(sr_y) + + ! Must figure out patch dimensions from info in parallel module +! we_patch_s = my_minx +! we_patch_s_stag = my_minx +! we_patch_e = my_maxx - 1 +! sn_patch_s = my_miny +! sn_patch_s_stag = my_miny +! sn_patch_e = my_maxy - 1 +! +! if (trim(grid_type) == 'C') then +! if (my_x /= nproc_x - 1) then +! we_patch_e_stag = we_patch_e + 1 +! end if +! if (my_y /= nproc_y - 1) then +! sn_patch_e_stag = sn_patch_e + 1 +! end if +! else if (trim(grid_type) == 'E') then +! we_patch_e = we_patch_e + 1 +! sn_patch_e = sn_patch_e + 1 +! we_patch_e_stag = we_patch_e +! sn_patch_e_stag = sn_patch_e +! end if + + call parallel_bcast_real(dx) + call parallel_bcast_real(dy) + call parallel_bcast_int(dyn_opt) + call parallel_bcast_real(cen_lat) + call parallel_bcast_real(cen_lon) + call parallel_bcast_real(truelat1) + call parallel_bcast_real(truelat2) + call parallel_bcast_real(pole_lat) + call parallel_bcast_real(pole_lon) + call parallel_bcast_real(moad_cen_lat) + call parallel_bcast_real(stand_lon) + do i=1,16 + call parallel_bcast_real(corner_lats(i)) + call parallel_bcast_real(corner_lons(i)) + end do + call parallel_bcast_int(map_proj) + call parallel_bcast_char(mminlu, len(mminlu)) + call parallel_bcast_int(is_water) + call parallel_bcast_int(is_lake) + call parallel_bcast_int(is_ice) + call parallel_bcast_int(is_urban) + call parallel_bcast_int(isoilwater) + call parallel_bcast_int(grid_id) + call parallel_bcast_int(parent_id) + call parallel_bcast_int(i_parent_start) + call parallel_bcast_int(i_parent_end) + call parallel_bcast_int(j_parent_start) + call parallel_bcast_int(j_parent_end) + call parallel_bcast_int(parent_grid_ratio) + end if + + internal_gridtype = grid_type + + end subroutine read_global_attrs + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: ext_get_dom_ti_integer + ! + ! Purpose: Read a domain time-independent integer attribute from input. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ext_get_dom_ti_integer_scalar(var_name, var_value, suppress_errors) + + implicit none + + ! Arguments + integer, intent(out) :: var_value + character (len=*), intent(in) :: var_name + logical, intent(in), optional :: suppress_errors + + ! Local variables + integer :: istatus, outcount + +#ifdef IO_BINARY + if (io_form_input == BINARY) then + call ext_int_get_dom_ti_integer(handle, trim(var_name), & + var_value, & + 1, outcount, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) then + call ext_ncd_get_dom_ti_integer(handle, trim(var_name), & + var_value, & + 1, outcount, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) then + call ext_gr1_get_dom_ti_integer(handle, trim(var_name), & + var_value, & + 1, outcount, istatus) + end if +#endif + + if (present(suppress_errors)) then + call mprintf((istatus /= 0 .and. .not.suppress_errors),ERROR,'Error while reading domain time-independent attribute.') + else + call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.') + end if + + end subroutine ext_get_dom_ti_integer_scalar + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: ext_get_dom_ti_integer + ! + ! Purpose: Read a domain time-independent integer attribute from input. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ext_get_dom_ti_integer_vector(var_name, var_value, n) + + implicit none + + ! Arguments + integer, intent(in) :: n + integer, dimension(n), intent(out) :: var_value + character (len=*), intent(in) :: var_name + + ! Local variables + integer :: istatus, outcount + +#ifdef IO_BINARY + if (io_form_input == BINARY) then + call ext_int_get_dom_ti_integer(handle, trim(var_name), & + var_value, & + n, outcount, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) then + call ext_ncd_get_dom_ti_integer(handle, trim(var_name), & + var_value, & + n, outcount, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) then + call ext_gr1_get_dom_ti_integer(handle, trim(var_name), & + var_value, & + n, outcount, istatus) + end if +#endif + + call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.') + + end subroutine ext_get_dom_ti_integer_vector + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: ext_get_dom_ti_real + ! + ! Purpose: Read a domain time-independent real attribute from input. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ext_get_dom_ti_real_scalar(var_name, var_value) + + implicit none + + ! Arguments + real, intent(out) :: var_value + character (len=*), intent(in) :: var_name + + ! Local variables + integer :: istatus, outcount + +#ifdef IO_BINARY + if (io_form_input == BINARY) then + call ext_int_get_dom_ti_real(handle, trim(var_name), & + var_value, & + 1, outcount, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) then + call ext_ncd_get_dom_ti_real(handle, trim(var_name), & + var_value, & + 1, outcount, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) then + call ext_gr1_get_dom_ti_real(handle, trim(var_name), & + var_value, & + 1, outcount, istatus) + end if +#endif + + call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.') + + end subroutine ext_get_dom_ti_real_scalar + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: ext_get_dom_ti_real + ! + ! Purpose: Read a domain time-independent real attribute from input. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ext_get_dom_ti_real_vector(var_name, var_value, n) + + implicit none + + ! Arguments + integer, intent(in) :: n + real, dimension(n), intent(out) :: var_value + character (len=*), intent(in) :: var_name + + ! Local variables + integer :: istatus, outcount + +#ifdef IO_BINARY + if (io_form_input == BINARY) then + call ext_int_get_dom_ti_real(handle, trim(var_name), & + var_value, & + n, outcount, istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) then + call ext_ncd_get_dom_ti_real(handle, trim(var_name), & + var_value, & + n, outcount, istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) then + call ext_gr1_get_dom_ti_real(handle, trim(var_name), & + var_value, & + n, outcount, istatus) + end if +#endif + + call mprintf((istatus /= 0),ERROR,'Error while reading domain time-independent attribute.') + + end subroutine ext_get_dom_ti_real_vector + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: ext_get_dom_ti_char + ! + ! Purpose: Read a domain time-independent character attribute from input. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ext_get_dom_ti_char(var_name, var_value) + + implicit none + + ! Arguments + character (len=*), intent(in) :: var_name + character (len=128), intent(out) :: var_value + + ! Local variables + integer :: istatus + +#ifdef IO_BINARY + if (io_form_input == BINARY) then + call ext_int_get_dom_ti_char(handle, trim(var_name), & + var_value, & + istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) then + call ext_ncd_get_dom_ti_char(handle, trim(var_name), & + var_value, & + istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) then + call ext_gr1_get_dom_ti_char(handle, trim(var_name), & + var_value, & + istatus) + end if +#endif + + call mprintf((istatus /= 0),ERROR,'Error in reading domain time-independent attribute') + + end subroutine ext_get_dom_ti_char + + + subroutine input_close() + + implicit none + + ! Local variables + integer :: istatus + + istatus = 0 + if (my_proc_id == IO_NODE .or. do_tiled_input) then +#ifdef IO_BINARY + if (io_form_input == BINARY) then + call ext_int_ioclose(handle, istatus) + call ext_int_ioexit(istatus) + end if +#endif +#ifdef IO_NETCDF + if (io_form_input == NETCDF) then + call ext_ncd_ioclose(handle, istatus) + call ext_ncd_ioexit(istatus) + end if +#endif +#ifdef IO_GRIB1 + if (io_form_input == GRIB1) then + call ext_gr1_ioclose(handle, istatus) + call ext_gr1_ioexit(istatus) + end if +#endif + end if + + call q_destroy(unit_desc) + + end subroutine input_close + +end module input_module diff --git a/WPS/metgrid/src/interp_module.F b/WPS/metgrid/src/interp_module.F new file mode 120000 index 00000000..745370b3 --- /dev/null +++ b/WPS/metgrid/src/interp_module.F @@ -0,0 +1 @@ +../../geogrid/src/interp_module.F \ No newline at end of file diff --git a/WPS/metgrid/src/interp_option_module.F b/WPS/metgrid/src/interp_option_module.F new file mode 100644 index 00000000..b300e57f --- /dev/null +++ b/WPS/metgrid/src/interp_option_module.F @@ -0,0 +1,859 @@ +module interp_option_module + + use gridinfo_module + use list_module + use misc_definitions_module + use module_debug + use stringutil + + integer, parameter :: BUFSIZE=128 + + integer :: num_entries + integer, pointer, dimension(:) :: output_stagger + real, pointer, dimension(:) :: masked, fill_missing, missing_value, & + interp_mask_val, interp_land_mask_val, interp_water_mask_val + logical, pointer, dimension(:) :: output_this_field, is_u_field, is_v_field, is_derived_field, is_mandatory + character (len=128), pointer, dimension(:) :: fieldname, interp_method, v_interp_method, & + interp_mask, interp_land_mask, interp_water_mask, & + flag_in_output, output_name, from_input, z_dim_name, level_template, & + mpas_name + character (len=1), pointer, dimension(:) :: interp_mask_relational, interp_land_mask_relational, interp_water_mask_relational + type (list), pointer, dimension(:) :: fill_lev_list + type (list) :: flag_in_output_list + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: read_interp_table + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine read_interp_table() + + ! Local variables + integer :: i, p1, p2, idx, eos, ispace, funit, istatus, nparams, s1, s2 + logical :: is_used, have_specification + character (len=128) :: lev_string, fill_string, flag_string, flag_val + character (len=BUFSIZE) :: buffer + + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + + nparams = 0 + num_entries = 0 + + open(funit, file=trim(opt_metgrid_tbl_path)//'METGRID.TBL', form='formatted', status='old', err=1001) + istatus = 0 + do while (istatus == 0) + read(funit, '(a)', iostat=istatus) buffer + if (istatus == 0) then + call despace(buffer) + + ! Is this line a comment? + if (buffer(1:1) == '#') then + + ! Are we beginning a new field specification? + else if (index(buffer,'=====') /= 0) then + if (nparams > 0) num_entries = num_entries + 1 + nparams = 0 + + else + eos = index(buffer,'#') + if (eos /= 0) buffer(eos:BUFSIZE) = ' ' + + ! Does this line contain at least one parameter specification? + if (index(buffer,'=') /= 0) then + nparams = nparams + 1 + end if + end if + + end if + end do + + rewind(funit) + + ! Allocate one extra array element to act as the default +! BUG: Maybe this will not be necessary if we move to a module with query routines for +! parsing the METGRID.TBL + num_entries = num_entries + 1 + + allocate(fieldname(num_entries)) + allocate(mpas_name(num_entries)) + allocate(interp_method(num_entries)) + allocate(v_interp_method(num_entries)) + allocate(masked(num_entries)) + allocate(fill_missing(num_entries)) + allocate(missing_value(num_entries)) + allocate(fill_lev_list(num_entries)) + allocate(interp_mask(num_entries)) + allocate(interp_land_mask(num_entries)) + allocate(interp_water_mask(num_entries)) + allocate(interp_mask_val(num_entries)) + allocate(interp_land_mask_val(num_entries)) + allocate(interp_water_mask_val(num_entries)) + allocate(interp_mask_relational(num_entries)) + allocate(interp_land_mask_relational(num_entries)) + allocate(interp_water_mask_relational(num_entries)) + allocate(level_template(num_entries)) + allocate(flag_in_output(num_entries)) + allocate(output_name(num_entries)) + allocate(from_input(num_entries)) + allocate(z_dim_name(num_entries)) + allocate(output_stagger(num_entries)) + allocate(output_this_field(num_entries)) + allocate(is_u_field(num_entries)) + allocate(is_v_field(num_entries)) + allocate(is_derived_field(num_entries)) + allocate(is_mandatory(num_entries)) + + ! + ! Set default values + ! + do i=1,num_entries + fieldname(i) = ' ' + mpas_name(i) = ' ' + flag_in_output(i) = ' ' + output_name(i) = ' ' + from_input(i) = '*' + z_dim_name(i) = 'num_metgrid_levels' + interp_method(i) = 'nearest_neighbor' + v_interp_method(i) = 'linear_log_p' + masked(i) = NOT_MASKED + fill_missing(i) = NAN + missing_value(i) = NAN + call list_init(fill_lev_list(i)) + interp_mask(i) = ' ' + interp_land_mask(i) = ' ' + interp_water_mask(i) = ' ' + interp_mask_val(i) = NAN + interp_land_mask_val(i) = NAN + interp_water_mask_val(i) = NAN + interp_mask_relational(i) = ' ' + interp_land_mask_relational(i) = ' ' + interp_water_mask_relational(i) = ' ' + level_template(i) = ' ' + if (gridtype == 'C') then + output_stagger(i) = M + else if (gridtype == 'E') then + output_stagger(i) = HH + end if + output_this_field(i) = .true. + is_u_field(i) = .false. + is_v_field(i) = .false. + is_derived_field(i) = .false. + is_mandatory(i) = .false. + end do + call list_init(flag_in_output_list) + + i = 1 + istatus = 0 + nparams = 0 + + do while (istatus == 0) + buffer = ' ' + read(funit, '(a)', iostat=istatus) buffer + if (istatus == 0) then + call despace(buffer) + + ! Is this line a comment? + if (buffer(1:1) == '#') then + ! Do nothing. + + ! Are we beginning a new field specification? + else if (index(buffer,'=====') /= 0) then !{ + if (nparams > 0) i = i + 1 + nparams = 0 + + else + ! Check whether the current line is a comment + if (buffer(1:1) /= '#') then + have_specification = .true. + else + have_specification = .false. + end if + + ! If only part of the line is a comment, just turn the comment into spaces + eos = index(buffer,'#') + if (eos /= 0) buffer(eos:BUFSIZE) = ' ' + + do while (have_specification) !{ + + ! If this line has no semicolon, it may contain a single specification, + ! so we set have_specification = .false. to prevent the line from being + ! processed again and "pretend" that the last character was a semicolon + eos = index(buffer,';') + if (eos == 0) then + have_specification = .false. + eos = BUFSIZE + end if + + idx = index(buffer(1:eos-1),'=') + + if (idx /= 0) then !{ + nparams = nparams + 1 + + if (index('name',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('name') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + fieldname(i) = ' ' + fieldname(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('mpas_name',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('mpas_name') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + mpas_name(i) = ' ' + mpas_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('from_input',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('from_input') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + from_input(i) = ' ' + from_input(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('z_dim_name',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('z_dim_name') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + z_dim_name(i) = ' ' + z_dim_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('output_stagger',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('output_stagger') == len_trim(buffer(1:idx-1))) then + if (index('M',trim(buffer(idx+1:eos-1))) /= 0) then + output_stagger(i) = M + else if (index('U',trim(buffer(idx+1:eos-1))) /= 0) then + output_stagger(i) = U + else if (index('V',trim(buffer(idx+1:eos-1))) /= 0) then + output_stagger(i) = V + else if (index('HH',trim(buffer(idx+1:eos-1))) /= 0) then + output_stagger(i) = HH + else if (index('VV',trim(buffer(idx+1:eos-1))) /= 0) then + output_stagger(i) = VV + end if + + else if (index('output',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('output') == len_trim(buffer(1:idx-1))) then + if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then + output_this_field(i) = .true. + else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then + output_this_field(i) = .false. + end if + + else if (index('is_u_field',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('is_u_field') == len_trim(buffer(1:idx-1))) then + if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then + is_u_field(i) = .true. + else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then + is_u_field(i) = .false. + end if + + else if (index('is_v_field',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('is_v_field') == len_trim(buffer(1:idx-1))) then + if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then + is_v_field(i) = .true. + else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then + is_v_field(i) = .false. + end if + + else if (index('derived',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('derived') == len_trim(buffer(1:idx-1))) then + if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then + is_derived_field(i) = .true. + else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then + is_derived_field(i) = .false. + end if + + else if (index('mandatory',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('mandatory') == len_trim(buffer(1:idx-1))) then + if (index('yes',trim(buffer(idx+1:eos-1))) /= 0) then + is_mandatory(i) = .true. + else if (index('no',trim(buffer(idx+1:eos-1))) /= 0) then + is_mandatory(i) = .false. + end if + + else if (index('interp_option',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('interp_option') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + interp_method(i) = ' ' + interp_method(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('vertical_interp_option',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('vertical_interp_option') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + v_interp_method(i) = ' ' + v_interp_method(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('level_template',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('level_template') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + level_template(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('interp_mask',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('interp_mask') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + p1 = index(buffer(idx+1:ispace-1),'(') + p2 = index(buffer(idx+1:ispace-1),')') + s1 = index(buffer(idx+1:ispace-1),'<') + s2 = index(buffer(idx+1:ispace-1),'>') + if (p1 == 0 .or. p2 == 0) then + call mprintf(.true.,WARN, & + 'Problem in specifying interp_mask flag. Setting masked flag to 0.') + interp_mask(i) = ' ' + interp_mask(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + interp_mask_val(i) = 0 + else + ! Parenthesis found; additionally, there may be a relational symbol + if ((s1 /= 0) .OR. (s2 /= 0)) then + if (s1 > 0) then + interp_mask_relational(i) = buffer(idx+s1:idx+s1) + else if (s2 > 0) then + interp_mask_relational(i) = buffer(idx+s2:idx+s2) + end if + interp_mask(i) = ' ' + interp_mask(i)(1:p1) = buffer(idx+1:idx+p1-1) + read(buffer(idx+p1+2:idx+p2-1),*,err=1000) interp_mask_val(i) + else + ! No relational symbol + interp_mask(i) = ' ' + interp_mask(i)(1:p1) = buffer(idx+1:idx+p1-1) + read(buffer(idx+p1+1:idx+p2-1),*,err=1000) interp_mask_val(i) + end if + end if + + else if (index('interp_land_mask',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('interp_land_mask') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + p1 = index(buffer(idx+1:ispace-1),'(') + p2 = index(buffer(idx+1:ispace-1),')') + s1 = index(buffer(idx+1:ispace-1),'<') + s2 = index(buffer(idx+1:ispace-1),'>') + if (p1 == 0 .or. p2 == 0) then + call mprintf(.true.,WARN, & + 'Problem in specifying interp_land_mask flag. Setting masked flag to 0.') + interp_land_mask(i) = ' ' + interp_land_mask(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + interp_land_mask_val(i) = 0 + else + ! Parenthesis found; additionally, there may be a relational symbol + if ((s1 /= 0) .OR. (s2 /= 0)) then + if (s1 > 0) then + interp_land_mask_relational(i) = buffer(idx+s1:idx+s1) + else if (s2 > 0) then + interp_land_mask_relational(i) = buffer(idx+s2:idx+s2) + end if + interp_land_mask(i) = ' ' + interp_land_mask(i)(1:p1) = buffer(idx+1:idx+p1-1) + read(buffer(idx+p1+2:idx+p2-1),*,err=1000) interp_land_mask_val(i) + else + ! No relational symbol + interp_land_mask(i) = ' ' + interp_land_mask(i)(1:p1) = buffer(idx+1:idx+p1-1) + read(buffer(idx+p1+1:idx+p2-1),*,err=1000) interp_land_mask_val(i) + end if + end if + + else if (index('interp_water_mask',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('interp_water_mask') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + p1 = index(buffer(idx+1:ispace-1),'(') + p2 = index(buffer(idx+1:ispace-1),')') + s1 = index(buffer(idx+1:ispace-1),'<') + s2 = index(buffer(idx+1:ispace-1),'>') + if (p1 == 0 .or. p2 == 0) then + call mprintf(.true.,WARN, & + 'Problem in specifying interp_water_mask flag. Setting masked flag to 0.') + interp_water_mask(i) = ' ' + interp_water_mask(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + interp_water_mask_val(i) = 0 + else + ! Parenthesis found; additionally, there may be a relational symbol + if ((s1 /= 0) .OR. (s2 /= 0)) then + if (s1 > 0) then + interp_water_mask_relational(i) = buffer(idx+s1:idx+s1) + else if (s2 > 0) then + interp_water_mask_relational(i) = buffer(idx+s2:idx+s2) + end if + interp_water_mask(i) = ' ' + interp_water_mask(i)(1:p1) = buffer(idx+1:idx+p1-1) + read(buffer(idx+p1+2:idx+p2-1),*,err=1000) interp_water_mask_val(i) + else + ! No relational symbol + interp_water_mask(i) = ' ' + interp_water_mask(i)(1:p1) = buffer(idx+1:idx+p1-1) + read(buffer(idx+p1+1:idx+p2-1),*,err=1000) interp_water_mask_val(i) + end if + end if + + else if (index('masked',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('masked') == len_trim(buffer(1:idx-1))) then + if (index('water',trim(buffer(idx+1:eos-1))) /= 0) then + masked(i) = MASKED_WATER + else if (index('land',trim(buffer(idx+1:eos-1))) /= 0) then + masked(i) = MASKED_LAND + else if (index('both',trim(buffer(idx+1:eos-1))) /= 0) then + masked(i) = MASKED_BOTH + end if + + else if (index('flag_in_output',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('flag_in_output') == len_trim(buffer(1:idx-1))) then + flag_string = ' ' + flag_string(1:eos-idx-1) = buffer(idx+1:eos-1) + if (list_search(flag_in_output_list, ckey=flag_string, cvalue=flag_val)) then + call mprintf(.true.,WARN, 'In METGRID.TBL, %s is given as a flag more than once.', & + s1=flag_string) + flag_in_output(i)(1:eos-idx-1) = buffer(idx+1:eos-1) + else + flag_in_output(i)(1:eos-idx-1) = buffer(idx+1:eos-1) + write(flag_val,'(i1)') 1 + call list_insert(flag_in_output_list, ckey=flag_string, cvalue=flag_val) + end if + + else if (index('output_name',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('output_name') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + output_name(i) = ' ' + output_name(i)(1:ispace-idx) = buffer(idx+1:ispace-1) + + else if (index('fill_missing',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('fill_missing') == len_trim(buffer(1:idx-1))) then + read(buffer(idx+1:eos-1),*) fill_missing(i) + + else if (index('missing_value',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('missing_value') == len_trim(buffer(1:idx-1))) then + read(buffer(idx+1:eos-1),*) missing_value(i) + + else if (index('fill_lev',trim(buffer(1:idx-1))) /= 0 .and. & + len_trim('fill_lev') == len_trim(buffer(1:idx-1))) then + ispace = idx+1 + do while ((ispace < eos) .and. (buffer(ispace:ispace) /= ' ')) + ispace = ispace + 1 + end do + fill_string = ' ' + fill_string(1:ispace-idx-1) = buffer(idx+1:ispace-1) + ispace = index(fill_string,':') + if (ispace /= 0) then + write(lev_string,'(a)') fill_string(1:ispace-1) + else + write(lev_string,'(a)') 'all' + end if + write(fill_string,'(a)') trim(fill_string(ispace+1:128)) + fill_string(128-ispace:128) = ' ' + call list_insert(fill_lev_list(i), ckey=lev_string, cvalue=fill_string) + + else + call mprintf(.true.,WARN, 'In METGRID.TBL, unrecognized option %s in entry %i.', s1=buffer(1:idx-1), i1=idx) + end if + + end if !} index(buffer(1:eos-1),'=') /= 0 + +! BUG: If buffer has non-whitespace characters but no =, then maybe a wrong specification? + + buffer = buffer(eos+1:BUFSIZE) + end do ! while eos /= 0 } + + end if !} index(buffer, '=====') /= 0 + + end if + end do + + call check_table_specs() + + close(funit) + + return + + 1000 call mprintf(.true.,ERROR,'The mask value of the interp_mask specification must '// & + 'be a real value, enclosed in parentheses immediately after the field name.') + + 1001 call mprintf(.true.,ERROR,'Could not open file METGRID.TBL') + 1002 call mprintf(.true.,ERROR,'Symbol expected < >. Check METGRID.TBL for missing symbol or erroreous entry') + + end subroutine read_interp_table + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: check_table_specs + ! + ! Pupose: Perform basic consistency and sanity checks on the METGRID.TBL + ! entries supplied by the user. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine check_table_specs() + + implicit none + + ! Local variables + integer :: i + + do i=1,num_entries + + ! For C grid, U field must be on U staggering, and V field must be on + ! V staggering; for E grid, U and V must be on VV staggering. + if (gridtype == 'C') then + if (is_u_field(i) .and. output_stagger(i) /= U) then + call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind U-component field '// & + 'must be interpolated to the U staggered grid points.',i1=i) + else if (is_v_field(i) .and. output_stagger(i) /= V) then + call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind V-component field '// & + 'must be interpolated to the V staggered grid points.',i1=i) + end if + + if (output_stagger(i) == VV) then + call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, VV is not a valid output staggering for ARW.',i1=i) + else if (output_stagger(i) == HH) then + call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, HH is not a valid output staggering for ARW.',i1=i) + end if + + if (masked(i) /= NOT_MASKED .and. output_stagger(i) /= M) then + call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, staggered output field '// & + 'cannot use the ''masked'' option.',i1=i) + end if + + else if (gridtype == 'E') then + if (is_u_field(i) .and. output_stagger(i) /= VV) then + call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind U-component field '// & + 'must be interpolated to the V staggered grid points.',i1=i) + else if (is_v_field(i) .and. output_stagger(i) /= VV) then + call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, the wind V-component field '// & + 'must be interpolated to the V staggered grid points.',i1=i) + end if + + if (output_stagger(i) == M) then + call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, M is not a valid output staggering for NMM.',i1=i) + else if (output_stagger(i) == U) then + call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, U is not a valid output staggering for NMM.',i1=i) + else if (output_stagger(i) == V) then + call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, V is not a valid output staggering for NMM.',i1=i) + end if + + if (masked(i) /= NOT_MASKED .and. output_stagger(i) /= HH) then + call mprintf(.true.,ERROR,'In entry %i of METGRID.TBL, staggered output field '// & + 'cannot use the ''masked'' option.',i1=i) + end if + end if + + end do + + end subroutine check_table_specs + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_z_dim_name + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_z_dim_name(fldname, zdim_name) + + implicit none + + ! Arguments + character (len=*), intent(in) :: fldname + character (len=32), intent(out) :: zdim_name + + ! Local variables + integer :: i + + zdim_name = z_dim_name(num_entries)(1:32) + do i=1,num_entries + if (trim(fldname) == trim(fieldname(i))) then + zdim_name = z_dim_name(i)(1:32) + exit + end if + end do + + end subroutine get_z_dim_name + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: mpas_name_to_idx + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function mpas_name_to_idx(mpasname) result(idx) + + implicit none + + ! Arguments + character (len=*), intent(in) :: mpasname + + ! Return value + integer :: idx + + ! Local variables + integer :: i + + idx = 0 + do i=1,num_entries + if (trim(mpasname) == trim(mpas_name(i))) then + idx = i + exit + end if + end do + + end function mpas_name_to_idx + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: mpas_to_intermediate_name + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function mpas_to_intermediate_name(mpasname) result(intermediate_name) + + implicit none + + ! Arguments + character (len=*), intent(in) :: mpasname + + ! Return value + character (len=128) :: intermediate_name + + ! Local variables + integer :: i + + intermediate_name = fieldname(num_entries) + do i=1,num_entries + if (trim(mpasname) == trim(mpas_name(i))) then + intermediate_name = fieldname(i) + exit + end if + end do + + end function mpas_to_intermediate_name + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: mpas_output_stagger + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function mpas_output_stagger(mpasname) result(istagger) + + implicit none + + ! Arguments + character (len=*), intent(in) :: mpasname + + ! Return value + integer :: istagger + + ! Local variables + integer :: i + + istagger = M + do i=1,num_entries + if (trim(mpasname) == trim(mpas_name(i))) then + istagger = output_stagger(i) + exit + end if + end do + + end function mpas_output_stagger + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_gcell_threshold + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_gcell_threshold(interp_opt, threshold, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + real, intent(out) :: threshold + character (len=128), intent(in) :: interp_opt + + ! Local variables + integer :: i, p1, p2 + + istatus = 1 + threshold = 1.0 + + i = index(interp_opt,'average_gcell') + if (i /= 0) then + + ! Check for a threshold + p1 = index(interp_opt(i:128),'(') + p2 = index(interp_opt(i:128),')') + if (p1 /= 0 .and. p2 /= 0) then + read(interp_opt(p1+1:p2-1),*,err=1000) threshold + else + call mprintf(.true.,WARN, 'Problem in specifying threshold for average_gcell interp option. Setting threshold to 1.0') + threshold = 1.0 + end if + end if + istatus = 0 + + return + +1000 call mprintf(.true.,ERROR, & + 'Threshold option to average_gcell interpolator must be a real number, '// & + 'enclosed in parentheses immediately after keyword "average_gcell"') + + end subroutine get_gcell_threshold + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_constant_fill_lev + ! + ! Pupose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_constant_fill_lev(fill_opt, fill_const, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + real, intent(out) :: fill_const + character (len=128), intent(in) :: fill_opt + + ! Local variables + integer :: i, p1, p2 + + istatus = 1 + fill_const = NAN + + i = index(fill_opt,'const') + if (i /= 0) then + + ! Check for a threshold + p1 = index(fill_opt(i:128),'(') + p2 = index(fill_opt(i:128),')') + if (p1 /= 0 .and. p2 /= 0) then + read(fill_opt(p1+1:p2-1),*,err=1000) fill_const + else + call mprintf(.true.,WARN, 'Problem in specifying fill_lev constant. Setting fill_const to %f', f1=NAN) + fill_const = NAN + end if + istatus = 0 + end if + + return + +1000 call mprintf(.true.,ERROR, & + 'Constant option to fill_lev must be a real number, enclosed in parentheses '// & + 'immediately after keyword "const"') + + end subroutine get_constant_fill_lev + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_fill_src_level + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_fill_src_level(fill_opt, fill_src, fill_src_level) + + implicit none + + ! Arguments + integer, intent(out) :: fill_src_level + character (len=128), intent(in) :: fill_opt + character (len=128), intent(out) :: fill_src + + ! Local variables + integer :: p1, p2 + + ! Check for a level in parentheses + p1 = index(fill_opt,'(') + p2 = index(fill_opt,')') + if (p1 /= 0 .and. p2 /= 0) then + read(fill_opt(p1+1:p2-1),*,err=1000) fill_src_level + fill_src = ' ' + write(fill_src,'(a)') fill_opt(1:p1-1) + else + fill_src_level = 1 + fill_src = fill_opt + end if + + return + +1000 call mprintf(.true.,ERROR, & + 'For fill_lev specification, level in source field must be an integer, '// & + 'enclosed in parentheses immediately after the fieldname') + + end subroutine get_fill_src_level + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: interp_option_destroy + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine interp_option_destroy() + + implicit none + + ! Local variables + integer :: i + + deallocate(fieldname) + deallocate(from_input) + deallocate(z_dim_name) + deallocate(interp_method) + deallocate(v_interp_method) + deallocate(masked) + deallocate(fill_missing) + deallocate(missing_value) + do i=1,num_entries + call list_destroy(fill_lev_list(i)) + end do + deallocate(fill_lev_list) + deallocate(interp_mask) + deallocate(interp_land_mask) + deallocate(interp_water_mask) + deallocate(interp_mask_val) + deallocate(interp_land_mask_val) + deallocate(interp_water_mask_val) + deallocate(interp_mask_relational) + deallocate(interp_land_mask_relational) + deallocate(interp_water_mask_relational) + deallocate(level_template) + deallocate(flag_in_output) + deallocate(output_name) + deallocate(output_stagger) + deallocate(output_this_field) + deallocate(is_u_field) + deallocate(is_v_field) + deallocate(is_derived_field) + deallocate(is_mandatory) + call list_destroy(flag_in_output_list) + + end subroutine interp_option_destroy + +end module interp_option_module diff --git a/WPS/metgrid/src/list_module.F b/WPS/metgrid/src/list_module.F new file mode 120000 index 00000000..34e5b45b --- /dev/null +++ b/WPS/metgrid/src/list_module.F @@ -0,0 +1 @@ +../../geogrid/src/list_module.F \ No newline at end of file diff --git a/WPS/metgrid/src/llxy_module.F b/WPS/metgrid/src/llxy_module.F new file mode 120000 index 00000000..0e5f9c55 --- /dev/null +++ b/WPS/metgrid/src/llxy_module.F @@ -0,0 +1 @@ +../../geogrid/src/llxy_module.F \ No newline at end of file diff --git a/WPS/metgrid/src/met_data_module.F b/WPS/metgrid/src/met_data_module.F new file mode 100644 index 00000000..10ed885e --- /dev/null +++ b/WPS/metgrid/src/met_data_module.F @@ -0,0 +1,20 @@ +module met_data_module + + ! Derived types + type met_data + integer :: version, nx, ny, iproj + real :: xfcst, xlvl, startlat, startlon, starti, startj, & + deltalat, deltalon, dx, dy, xlonc, & + centerlat, centerlon, & + pole_lat, pole_lon, & + truelat1, truelat2, earth_radius + real, pointer, dimension(:,:) :: slab + logical :: is_wind_grid_rel + character (len=9) :: field + character (len=24) :: hdate + character (len=25) :: units + character (len=32) :: map_source + character (len=46) :: desc + end type met_data + +end module met_data_module diff --git a/WPS/metgrid/src/metgrid.F b/WPS/metgrid/src/metgrid.F new file mode 100644 index 00000000..477e8546 --- /dev/null +++ b/WPS/metgrid/src/metgrid.F @@ -0,0 +1,101 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Program metgrid +! +! First version: Michael Duda -- January 2006 +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +program metgrid + + use gridinfo_module + use interp_option_module + use module_debug + use parallel_module + use process_domain_module + + implicit none + + ! Local variables + integer :: n + logical :: extra_row, extra_col + + ! + ! Do general setup + ! + + ! Initialize parallel stuff + call parallel_start() + + call mprintf(.true.,LOGFILE,' *** Starting program metgrid.exe *** ') + + ! Get info about how many nests there are to process, etc. + call get_namelist_params() + + ! Having determined which processor we are, which grid type we are, and where + ! our patch is located in the domain, we can determine if U or V staggered + ! fields will have one more row or column than the M staggered fields + if (gridtype == 'C') then + if (my_x == nproc_x-1) then + extra_col = .true. + else + extra_col = .false. + end if + + if (my_y == nproc_y-1) then + extra_row = .true. + else + extra_row = .false. + end if + else if (gridtype == 'E') then + extra_col = .false. + extra_row = .false. + end if + + ! Get info about which interpolators should be used with each field + call read_interp_table() + + ! + ! Now begin the processing work, looping over all domains to be processed + ! + + if (gridtype == 'C') then + + do n=1,max_dom + + if (grid_is_active(n)) then + call mprintf(.true.,STDOUT,'Processing domain %i of %i', i1=n, i2=max_dom) + call mprintf(.true.,LOGFILE,'Processing domain %i of %i', i1=n, i2=max_dom) + + call process_domain(n, extra_row, extra_col) + else + call mprintf(.true.,STDOUT,'Skipping domain %i of %i', i1=n, i2=max_dom) + call mprintf(.true.,LOGFILE,'Skipping domain %i of %i', i1=n, i2=max_dom) + end if + + end do ! Loop over max_dom + + else if (gridtype == 'E') then + + call mprintf(.true.,STDOUT,'Processing coarse domain only for NMM.') + call mprintf(.true.,LOGFILE,'Processing coarse domain only for NMM.') + + call process_domain(1, extra_row, extra_col) + + end if + + + ! + ! Clean up and quit. + ! + + call interp_option_destroy() + + call parallel_finish() + + call mprintf(.true.,STDOUT,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!') + call mprintf(.true.,STDOUT,'! Successful completion of metgrid. !') + call mprintf(.true.,STDOUT,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!') + + call mprintf(.true.,LOGFILE,' *** Successful completion of program metgrid.exe *** ') + + stop + +end program metgrid diff --git a/WPS/metgrid/src/minheap_module.F b/WPS/metgrid/src/minheap_module.F new file mode 100644 index 00000000..6daf071d --- /dev/null +++ b/WPS/metgrid/src/minheap_module.F @@ -0,0 +1,207 @@ +! Implements a heap using an array; top of the heap is the item +! with minimum key value +module minheap_module + + use datatype_module + use module_debug + + ! Maximum heap size -- maybe make this magically dynamic somehow? + integer, parameter :: HEAPSIZE = 10000 + + ! Type of item to be stored in the heap + type heap_object + type (data_node), pointer :: object + end type heap_object + + ! The heap itself + type (heap_object), allocatable, dimension(:) :: heap + + ! Index of last item in the heap + integer :: end_of_heap + + contains + + + ! Initialize the heap; current functionality can be had without + ! the need for init function, but we may want more things later + subroutine init_heap() + + implicit none + + end_of_heap = 0 + allocate(heap(HEAPSIZE)) + + end subroutine init_heap + + + subroutine heap_destroy() + + implicit none + + deallocate(heap) + + end subroutine heap_destroy + + + subroutine add_to_heap(x) + + implicit none + + ! Arguments + type (data_node), pointer :: x + + ! Local variables + integer :: idx, parent + + call mprintf((end_of_heap == HEAPSIZE),ERROR, 'add_to_heap(): Maximum heap size exceeded') + + end_of_heap = end_of_heap + 1 + idx = end_of_heap + heap(idx)%object => x + heap(idx)%object%heap_index = idx + + do while (idx > 1) + parent = floor(real(idx)/2.) + if (heap(idx)%object%last_used < heap(parent)%object%last_used) then + heap(idx)%object => heap(parent)%object + heap(idx)%object%heap_index = idx + heap(parent)%object => x + heap(parent)%object%heap_index = parent + idx = parent + else + idx = 1 + end if + end do + + end subroutine add_to_heap + + + subroutine remove_index(idx) + + implicit none + + ! Arguments + integer, intent(in) :: idx + + ! Local variables + integer :: indx, left, right + type (data_node), pointer :: temp + + heap(idx)%object => heap(end_of_heap)%object + heap(idx)%object%heap_index = idx + end_of_heap = end_of_heap - 1 + + indx = idx + + do while (indx <= end_of_heap) + left = indx*2 + right = indx*2+1 + if (right <= end_of_heap) then + if (heap(right)%object%last_used < heap(left)%object%last_used) then + if (heap(right)%object%last_used < heap(indx)%object%last_used) then + temp => heap(indx)%object + heap(indx)%object => heap(right)%object + heap(indx)%object%heap_index = indx + heap(right)%object => temp + heap(right)%object%heap_index = right + indx = right + else + indx = end_of_heap + 1 + end if + else + if (heap(left)%object%last_used < heap(indx)%object%last_used) then + temp => heap(indx)%object + heap(indx)%object => heap(left)%object + heap(indx)%object%heap_index = indx + heap(left)%object => temp + heap(left)%object%heap_index = left + indx = left + else + indx = end_of_heap + 1 + end if + end if + else if (left <= end_of_heap) then + if (heap(left)%object%last_used < heap(indx)%object%last_used) then + temp => heap(indx)%object + heap(indx)%object => heap(left)%object + heap(indx)%object%heap_index = indx + heap(left)%object => temp + heap(left)%object%heap_index = left + indx = left + else + indx = end_of_heap + 1 + end if + else + indx = end_of_heap + 1 + end if + end do + + end subroutine remove_index + + + subroutine get_min(x) + + implicit none + + ! Arguments + type (data_node), pointer :: x + + ! Local variables + integer :: idx, left, right + type (data_node), pointer :: temp + + call mprintf((end_of_heap <= 0),ERROR, 'get_min(): No items left in the heap.') + + x => heap(1)%object + + heap(1)%object => heap(end_of_heap)%object + heap(1)%object%heap_index = 1 + end_of_heap = end_of_heap - 1 + idx = 1 + + do while (idx <= end_of_heap) + left = idx*2 + right = idx*2+1 + if (right <= end_of_heap) then + if (heap(right)%object%last_used < heap(left)%object%last_used) then + if (heap(right)%object%last_used < heap(idx)%object%last_used) then + temp => heap(idx)%object + heap(idx)%object => heap(right)%object + heap(idx)%object%heap_index = idx + heap(right)%object => temp + heap(right)%object%heap_index = right + idx = right + else + idx = end_of_heap + 1 + end if + else + if (heap(left)%object%last_used < heap(idx)%object%last_used) then + temp => heap(idx)%object + heap(idx)%object => heap(left)%object + heap(idx)%object%heap_index = idx + heap(left)%object => temp + heap(left)%object%heap_index = left + idx = left + else + idx = end_of_heap + 1 + end if + end if + else if (left <= end_of_heap) then + if (heap(left)%object%last_used < heap(idx)%object%last_used) then + temp => heap(idx)%object + heap(idx)%object => heap(left)%object + heap(idx)%object%heap_index = idx + heap(left)%object => temp + heap(left)%object%heap_index = left + idx = left + else + idx = end_of_heap + 1 + end if + else + idx = end_of_heap + 1 + end if + end do + + end subroutine get_min + +end module minheap_module diff --git a/WPS/metgrid/src/misc_definitions_module.F b/WPS/metgrid/src/misc_definitions_module.F new file mode 120000 index 00000000..d50acad4 --- /dev/null +++ b/WPS/metgrid/src/misc_definitions_module.F @@ -0,0 +1 @@ +../../geogrid/src/misc_definitions_module.F \ No newline at end of file diff --git a/WPS/metgrid/src/module_date_pack.F b/WPS/metgrid/src/module_date_pack.F new file mode 100644 index 00000000..82d8cc03 --- /dev/null +++ b/WPS/metgrid/src/module_date_pack.F @@ -0,0 +1,643 @@ +MODULE date_pack + +! This module is able to perform three date and time functions: + +! 1. geth_idts (ndate, odate, idts) +! Get the time period between two dates. + +! 2. geth_newdate ( ndate, odate, idts) +! Get the new date based on the old date and a time difference. + +! 3. split_date_char ( date , century_year , month , day , hour , minute , second ) +! Given the date, return the integer components. + +use module_debug + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE geth_idts (ndate, odate, idts) + + IMPLICIT NONE + + ! From 2 input mdates ('YYYY-MM-DD HH:MM:SS.ffff'), + ! compute the time difference. + + ! on entry - ndate - the new hdate. + ! odate - the old hdate. + + ! on exit - idts - the change in time in seconds. + + CHARACTER (LEN=*) , INTENT(INOUT) :: ndate, odate + INTEGER , INTENT(OUT) :: idts + + ! Local Variables + + ! yrnew - indicates the year associated with "ndate" + ! yrold - indicates the year associated with "odate" + ! monew - indicates the month associated with "ndate" + ! moold - indicates the month associated with "odate" + ! dynew - indicates the day associated with "ndate" + ! dyold - indicates the day associated with "odate" + ! hrnew - indicates the hour associated with "ndate" + ! hrold - indicates the hour associated with "odate" + ! minew - indicates the minute associated with "ndate" + ! miold - indicates the minute associated with "odate" + ! scnew - indicates the second associated with "ndate" + ! scold - indicates the second associated with "odate" + ! i - loop counter + ! mday - a list assigning the number of days in each month + + CHARACTER (LEN=24) :: tdate + INTEGER :: olen, nlen + INTEGER :: yrnew, monew, dynew, hrnew, minew, scnew + INTEGER :: yrold, moold, dyold, hrold, miold, scold + INTEGER :: mday(12), i, newdys, olddys + LOGICAL :: npass, opass + INTEGER :: isign + + IF (odate.GT.ndate) THEN + isign = -1 + tdate=ndate + ndate=odate + odate=tdate + ELSE + isign = 1 + END IF + + ! Assign the number of days in a months + + mday( 1) = 31 + mday( 2) = 28 + mday( 3) = 31 + mday( 4) = 30 + mday( 5) = 31 + mday( 6) = 30 + mday( 7) = 31 + mday( 8) = 31 + mday( 9) = 30 + mday(10) = 31 + mday(11) = 30 + mday(12) = 31 + + ! Break down old hdate into parts + + hrold = 0 + miold = 0 + scold = 0 + olen = LEN(odate) + + READ(odate(1:4), '(I4)') yrold + READ(odate(6:7), '(I2)') moold + READ(odate(9:10), '(I2)') dyold + IF (olen.GE.13) THEN + READ(odate(12:13),'(I2)') hrold + IF (olen.GE.16) THEN + READ(odate(15:16),'(I2)') miold + IF (olen.GE.19) THEN + READ(odate(18:19),'(I2)') scold + END IF + END IF + END IF + + ! Break down new hdate into parts + + hrnew = 0 + minew = 0 + scnew = 0 + nlen = LEN(ndate) + + READ(ndate(1:4), '(I4)') yrnew + READ(ndate(6:7), '(I2)') monew + READ(ndate(9:10), '(I2)') dynew + IF (nlen.GE.13) THEN + READ(ndate(12:13),'(I2)') hrnew + IF (nlen.GE.16) THEN + READ(ndate(15:16),'(I2)') minew + IF (nlen.GE.19) THEN + READ(ndate(18:19),'(I2)') scnew + END IF + END IF + END IF + + ! Check that the dates make sense. + + npass = .true. + opass = .true. + + ! Check that the month of NDATE makes sense. + + IF ((monew.GT.12).or.(monew.LT.1)) THEN + PRINT*, 'GETH_IDTS: Month of NDATE = ', monew + npass = .false. + END IF + + ! Check that the month of ODATE makes sense. + + IF ((moold.GT.12).or.(moold.LT.1)) THEN + PRINT*, 'GETH_IDTS: Month of ODATE = ', moold + opass = .false. + END IF + + ! Check that the day of NDATE makes sense. + + IF (monew.ne.2) THEN + ! ...... For all months but February + IF ((dynew.GT.mday(monew)).or.(dynew.LT.1)) THEN + PRINT*, 'GETH_IDTS: Day of NDATE = ', dynew + npass = .false. + END IF + ELSE IF (monew.eq.2) THEN + ! ...... For February + IF ((dynew.GT.nfeb(yrnew)).OR.(dynew.LT.1)) THEN + PRINT*, 'GETH_IDTS: Day of NDATE = ', dynew + npass = .false. + END IF + END IF + + ! Check that the day of ODATE makes sense. + + IF (moold.ne.2) THEN + ! ...... For all months but February + IF ((dyold.GT.mday(moold)).or.(dyold.LT.1)) THEN + PRINT*, 'GETH_IDTS: Day of ODATE = ', dyold + opass = .false. + END IF + ELSE IF (moold.eq.2) THEN + ! ....... For February + IF ((dyold.GT.nfeb(yrold)).or.(dyold.LT.1)) THEN + PRINT*, 'GETH_IDTS: Day of ODATE = ', dyold + opass = .false. + END IF + END IF + + ! Check that the hour of NDATE makes sense. + + IF ((hrnew.GT.23).or.(hrnew.LT.0)) THEN + PRINT*, 'GETH_IDTS: Hour of NDATE = ', hrnew + npass = .false. + END IF + + ! Check that the hour of ODATE makes sense. + + IF ((hrold.GT.23).or.(hrold.LT.0)) THEN + PRINT*, 'GETH_IDTS: Hour of ODATE = ', hrold + opass = .false. + END IF + + ! Check that the minute of NDATE makes sense. + + IF ((minew.GT.59).or.(minew.LT.0)) THEN + PRINT*, 'GETH_IDTS: Minute of NDATE = ', minew + npass = .false. + END IF + + ! Check that the minute of ODATE makes sense. + + IF ((miold.GT.59).or.(miold.LT.0)) THEN + PRINT*, 'GETH_IDTS: Minute of ODATE = ', miold + opass = .false. + END IF + + ! Check that the second of NDATE makes sense. + + IF ((scnew.GT.59).or.(scnew.LT.0)) THEN + PRINT*, 'GETH_IDTS: SECOND of NDATE = ', scnew + npass = .false. + END IF + + ! Check that the second of ODATE makes sense. + + IF ((scold.GT.59).or.(scold.LT.0)) THEN + PRINT*, 'GETH_IDTS: Second of ODATE = ', scold + opass = .false. + END IF + + IF (.not. npass) THEN + call mprintf(.true.,ERROR,'Screwy NDATE: %s',s1=ndate(1:nlen)) + END IF + + IF (.not. opass) THEN + call mprintf(.true.,ERROR,'Screwy ODATE: %s',s1=odate(1:olen)) + END IF + + ! Date Checks are completed. Continue. + + ! Compute number of days from 1 January ODATE, 00:00:00 until ndate + ! Compute number of hours from 1 January ODATE, 00:00:00 until ndate + ! Compute number of minutes from 1 January ODATE, 00:00:00 until ndate + + newdys = 0 + DO i = yrold, yrnew - 1 + newdys = newdys + (365 + (nfeb(i)-28)) + END DO + + IF (monew .GT. 1) THEN + mday(2) = nfeb(yrnew) + DO i = 1, monew - 1 + newdys = newdys + mday(i) + END DO + mday(2) = 28 + END IF + + newdys = newdys + dynew-1 + + ! Compute number of hours from 1 January ODATE, 00:00:00 until odate + ! Compute number of minutes from 1 January ODATE, 00:00:00 until odate + + olddys = 0 + + IF (moold .GT. 1) THEN + mday(2) = nfeb(yrold) + DO i = 1, moold - 1 + olddys = olddys + mday(i) + END DO + mday(2) = 28 + END IF + + olddys = olddys + dyold-1 + + ! Determine the time difference in seconds + + idts = (newdys - olddys) * 86400 + idts = idts + (hrnew - hrold) * 3600 + idts = idts + (minew - miold) * 60 + idts = idts + (scnew - scold) + + IF (isign .eq. -1) THEN + tdate=ndate + ndate=odate + odate=tdate + idts = idts * isign + END IF + + END SUBROUTINE geth_idts + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE geth_newdate (ndate, odate, idt) + + IMPLICIT NONE + + ! From old date ('YYYY-MM-DD HH:MM:SS.ffff') and + ! delta-time, compute the new date. + + ! on entry - odate - the old hdate. + ! idt - the change in time + + ! on exit - ndate - the new hdate. + + INTEGER , INTENT(IN) :: idt + CHARACTER (LEN=*) , INTENT(OUT) :: ndate + CHARACTER (LEN=*) , INTENT(IN) :: odate + + + ! Local Variables + + ! yrold - indicates the year associated with "odate" + ! moold - indicates the month associated with "odate" + ! dyold - indicates the day associated with "odate" + ! hrold - indicates the hour associated with "odate" + ! miold - indicates the minute associated with "odate" + ! scold - indicates the second associated with "odate" + + ! yrnew - indicates the year associated with "ndate" + ! monew - indicates the month associated with "ndate" + ! dynew - indicates the day associated with "ndate" + ! hrnew - indicates the hour associated with "ndate" + ! minew - indicates the minute associated with "ndate" + ! scnew - indicates the second associated with "ndate" + + ! mday - a list assigning the number of days in each month + + ! i - loop counter + ! nday - the integer number of days represented by "idt" + ! nhour - the integer number of hours in "idt" after taking out + ! all the whole days + ! nmin - the integer number of minutes in "idt" after taking out + ! all the whole days and whole hours. + ! nsec - the integer number of minutes in "idt" after taking out + ! all the whole days, whole hours, and whole minutes. + + INTEGER :: nlen, olen + INTEGER :: yrnew, monew, dynew, hrnew, minew, scnew, frnew + INTEGER :: yrold, moold, dyold, hrold, miold, scold, frold + INTEGER :: mday(12), nday, nhour, nmin, nsec, nfrac, i, ifrc + LOGICAL :: opass + CHARACTER (LEN=10) :: hfrc + CHARACTER (LEN=1) :: sp + ! INTEGER, EXTERNAL :: nfeb ! in the same module now + + ! Assign the number of days in a months + + mday( 1) = 31 + mday( 2) = 28 + mday( 3) = 31 + mday( 4) = 30 + mday( 5) = 31 + mday( 6) = 30 + mday( 7) = 31 + mday( 8) = 31 + mday( 9) = 30 + mday(10) = 31 + mday(11) = 30 + mday(12) = 31 + + ! Break down old hdate into parts + + hrold = 0 + miold = 0 + scold = 0 + frold = 0 + olen = LEN(odate) + IF (olen.GE.11) THEN + sp = odate(11:11) + else + sp = ' ' + END IF + + ! Use internal READ statements to convert the CHARACTER string + ! date into INTEGER components. + + READ(odate(1:4), '(I4)') yrold + READ(odate(6:7), '(I2)') moold + READ(odate(9:10), '(I2)') dyold + IF (olen.GE.13) THEN + READ(odate(12:13),'(I2)') hrold + IF (olen.GE.16) THEN + READ(odate(15:16),'(I2)') miold + IF (olen.GE.19) THEN + READ(odate(18:19),'(I2)') scold + IF (olen.GT.20) THEN + READ(odate(21:olen),'(I2)') frold + END IF + END IF + END IF + END IF + + ! Set the number of days in February for that year. + + mday(2) = nfeb(yrold) + + ! Check that ODATE makes sense. + + opass = .TRUE. + + ! Check that the month of ODATE makes sense. + + IF ((moold.GT.12).or.(moold.LT.1)) THEN + WRITE(*,*) 'GETH_NEWDATE: Month of ODATE = ', moold + opass = .FALSE. + END IF + + ! Check that the day of ODATE makes sense. + + IF ((dyold.GT.mday(moold)).or.(dyold.LT.1)) THEN + WRITE(*,*) 'GETH_NEWDATE: Day of ODATE = ', dyold + opass = .FALSE. + END IF + + ! Check that the hour of ODATE makes sense. + + IF ((hrold.GT.23).or.(hrold.LT.0)) THEN + WRITE(*,*) 'GETH_NEWDATE: Hour of ODATE = ', hrold + opass = .FALSE. + END IF + + ! Check that the minute of ODATE makes sense. + + IF ((miold.GT.59).or.(miold.LT.0)) THEN + WRITE(*,*) 'GETH_NEWDATE: Minute of ODATE = ', miold + opass = .FALSE. + END IF + + ! Check that the second of ODATE makes sense. + + IF ((scold.GT.59).or.(scold.LT.0)) THEN + WRITE(*,*) 'GETH_NEWDATE: Second of ODATE = ', scold + opass = .FALSE. + END IF + + ! Check that the fractional part of ODATE makes sense. + + + IF (.not.opass) THEN + call mprintf(.true.,ERROR,'GETH_NEWDATE: Crazy ODATE: %s %i',s1=odate(1:olen),i1=olen) + END IF + + ! Date Checks are completed. Continue. + + + ! Compute the number of days, hours, minutes, and seconds in idt + + IF (olen.GT.20) THEN !idt should be in fractions of seconds + ifrc = olen-20 + ifrc = 10**ifrc + nday = ABS(idt)/(86400*ifrc) + nhour = MOD(ABS(idt),86400*ifrc)/(3600*ifrc) + nmin = MOD(ABS(idt),3600*ifrc)/(60*ifrc) + nsec = MOD(ABS(idt),60*ifrc)/(ifrc) + nfrac = MOD(ABS(idt), ifrc) + ELSE IF (olen.eq.19) THEN !idt should be in seconds + ifrc = 1 + nday = ABS(idt)/86400 ! Integer number of days in delta-time + nhour = MOD(ABS(idt),86400)/3600 + nmin = MOD(ABS(idt),3600)/60 + nsec = MOD(ABS(idt),60) + nfrac = 0 + ELSE IF (olen.eq.16) THEN !idt should be in minutes + ifrc = 1 + nday = ABS(idt)/1440 ! Integer number of days in delta-time + nhour = MOD(ABS(idt),1440)/60 + nmin = MOD(ABS(idt),60) + nsec = 0 + nfrac = 0 + ELSE IF (olen.eq.13) THEN !idt should be in hours + ifrc = 1 + nday = ABS(idt)/24 ! Integer number of days in delta-time + nhour = MOD(ABS(idt),24) + nmin = 0 + nsec = 0 + nfrac = 0 + ELSE IF (olen.eq.10) THEN !idt should be in days + ifrc = 1 + nday = ABS(idt)/24 ! Integer number of days in delta-time + nhour = 0 + nmin = 0 + nsec = 0 + nfrac = 0 + ELSE + call mprintf(.true.,ERROR,'GETH_NEWDATE: Strange length for ODATE: %i',i1=olen) + END IF + + IF (idt.GE.0) THEN + + frnew = frold + nfrac + IF (frnew.GE.ifrc) THEN + frnew = frnew - ifrc + nsec = nsec + 1 + END IF + + scnew = scold + nsec + IF (scnew .GE. 60) THEN + scnew = scnew - 60 + nmin = nmin + 1 + END IF + + minew = miold + nmin + IF (minew .GE. 60) THEN + minew = minew - 60 + nhour = nhour + 1 + END IF + + hrnew = hrold + nhour + IF (hrnew .GE. 24) THEN + hrnew = hrnew - 24 + nday = nday + 1 + END IF + + dynew = dyold + monew = moold + yrnew = yrold + DO i = 1, nday + dynew = dynew + 1 + IF (dynew.GT.mday(monew)) THEN + dynew = dynew - mday(monew) + monew = monew + 1 + IF (monew .GT. 12) THEN + monew = 1 + yrnew = yrnew + 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb(yrnew) + END IF + END IF + END DO + + ELSE IF (idt.LT.0) THEN + + frnew = frold - nfrac + IF (frnew .LT. 0) THEN + frnew = frnew + ifrc + nsec = nsec - 1 + END IF + + scnew = scold - nsec + IF (scnew .LT. 00) THEN + scnew = scnew + 60 + nmin = nmin + 1 + END IF + + minew = miold - nmin + IF (minew .LT. 00) THEN + minew = minew + 60 + nhour = nhour + 1 + END IF + + hrnew = hrold - nhour + IF (hrnew .LT. 00) THEN + hrnew = hrnew + 24 + nday = nday + 1 + END IF + + dynew = dyold + monew = moold + yrnew = yrold + DO i = 1, nday + dynew = dynew - 1 + IF (dynew.eq.0) THEN + monew = monew - 1 + IF (monew.eq.0) THEN + monew = 12 + yrnew = yrnew - 1 + ! If the year changes, recompute the number of days in February + mday(2) = nfeb(yrnew) + END IF + dynew = mday(monew) + END IF + END DO + END IF + + ! Now construct the new mdate + + nlen = LEN(ndate) + + IF (nlen.GT.20) THEN + WRITE(ndate(1:19),19) yrnew, monew, dynew, hrnew, minew, scnew + WRITE(hfrc,'(I10)') frnew+1000000000 + ndate = ndate(1:19)//'.'//hfrc(31-nlen:10) + + ELSE IF (nlen.eq.19.or.nlen.eq.20) THEN + WRITE(ndate(1:19),19) yrnew, monew, dynew, hrnew, minew, scnew + 19 format(I4.4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2) + IF (nlen.eq.20) ndate = ndate(1:19)//'.' + + ELSE IF (nlen.eq.16) THEN + WRITE(ndate,16) yrnew, monew, dynew, hrnew, minew + 16 format(I4.4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2) + + ELSE IF (nlen.eq.13) THEN + WRITE(ndate,13) yrnew, monew, dynew, hrnew + 13 format(I4.4,'-',I2.2,'-',I2.2,'_',I2.2) + + ELSE IF (nlen.eq.10) THEN + WRITE(ndate,10) yrnew, monew, dynew + 10 format(I4.4,'-',I2.2,'-',I2.2) + + END IF + + IF (olen.GE.11) ndate(11:11) = sp + + END SUBROUTINE geth_newdate + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + FUNCTION nfeb ( year ) RESULT (num_days) + + ! Compute the number of days in February for the given year + + IMPLICIT NONE + + INTEGER :: year + INTEGER :: num_days + +#ifdef NO_LEAP_CALENDAR + num_days = 28 ! February always has 28 days for No Leap Calendar ... +#else + num_days = 28 ! By default, February has 28 days ... + IF (MOD(year,4).eq.0) THEN + num_days = 29 ! But every four years, it has 29 days ... + IF (MOD(year,100).eq.0) THEN + num_days = 28 ! Except every 100 years, when it has 28 days ... + IF (MOD(year,400).eq.0) THEN + num_days = 29 ! Except every 400 years, when it has 29 days. + END IF + END IF + END IF +#endif + + END FUNCTION nfeb + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE split_date_char ( date , century_year , month , day , hour , minute , second ) + + IMPLICIT NONE + + ! Input data. + + CHARACTER(LEN=19) , INTENT(IN) :: date + + ! Output data. + + INTEGER , INTENT(OUT) :: century_year , month , day , hour , minute , second + + READ(date,FMT='( I4.4)') century_year + READ(date,FMT='( 5X,I2.2)') month + READ(date,FMT='( 8X,I2.2)') day + READ(date,FMT='(11X,I2.2)') hour + READ(date,FMT='(14X,I2.2)') minute + READ(date,FMT='(17X,I2.2)') second + + END SUBROUTINE split_date_char + +END MODULE date_pack diff --git a/WPS/metgrid/src/module_debug.F b/WPS/metgrid/src/module_debug.F new file mode 120000 index 00000000..3a5a2ea5 --- /dev/null +++ b/WPS/metgrid/src/module_debug.F @@ -0,0 +1 @@ +../../geogrid/src/module_debug.F \ No newline at end of file diff --git a/WPS/metgrid/src/module_map_utils.F b/WPS/metgrid/src/module_map_utils.F new file mode 120000 index 00000000..58d1a4fd --- /dev/null +++ b/WPS/metgrid/src/module_map_utils.F @@ -0,0 +1 @@ +../../geogrid/src/module_map_utils.F \ No newline at end of file diff --git a/WPS/metgrid/src/module_mergesort.F b/WPS/metgrid/src/module_mergesort.F new file mode 100644 index 00000000..7a5c2dda --- /dev/null +++ b/WPS/metgrid/src/module_mergesort.F @@ -0,0 +1,70 @@ +module module_mergesort + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: mergesort + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive subroutine mergesort(array, n1, n2) + + implicit none + + ! Arguments + integer, intent(in) :: n1, n2 + integer, dimension(n1:n2), intent(inout) :: array + + ! Local variables + integer :: i, j, k + real :: rtemp + real, dimension(1:n2-n1+1) :: temp + + if (n1 >= n2) return + + if (n2 - n1 == 1) then + if (array(n1) < array(n2)) then + rtemp = array(n1) + array(n1) = array(n2) + array(n2) = rtemp + end if + return + end if + + call mergesort(array(n1:n1+(n2-n1+1)/2), n1, n1+(n2-n1+1)/2) + call mergesort(array(n1+((n2-n1+1)/2)+1:n2), n1+((n2-n1+1)/2)+1, n2) + + i = n1 + j = n1 + ((n2-n1+1)/2) + 1 + k = 1 + do while (i <= n1+(n2-n1+1)/2 .and. j <= n2) + if (array(i) > array(j)) then + temp(k) = array(i) + k = k + 1 + i = i + 1 + else + temp(k) = array(j) + k = k + 1 + j = j + 1 + end if + end do + + if (i <= n1+(n2-n1+1)/2) then + do while (i <= n1+(n2-n1+1)/2) + temp(k) = array(i) + i = i + 1 + k = k + 1 + end do + else + do while (j <= n2) + temp(k) = array(j) + j = j + 1 + k = k + 1 + end do + end if + + array(n1:n2) = temp(1:k-1) + + end subroutine mergesort + +end module module_mergesort diff --git a/WPS/metgrid/src/module_stringutil.F b/WPS/metgrid/src/module_stringutil.F new file mode 120000 index 00000000..305c294e --- /dev/null +++ b/WPS/metgrid/src/module_stringutil.F @@ -0,0 +1 @@ +../../ungrib/src/module_stringutil.F \ No newline at end of file diff --git a/WPS/metgrid/src/mpas_mesh.F b/WPS/metgrid/src/mpas_mesh.F new file mode 100644 index 00000000..b21302d2 --- /dev/null +++ b/WPS/metgrid/src/mpas_mesh.F @@ -0,0 +1,310 @@ +module mpas_mesh + + use scan_input + + type mpas_mesh_type + logical :: valid = .false. + integer :: nCells = 0 + integer :: nVertices = 0 + integer :: nEdges = 0 + integer :: maxEdges = 0 + integer, dimension(:), pointer :: landmask => null() + integer, dimension(:), pointer :: nEdgesOnCell => null() + integer, dimension(:,:), pointer :: cellsOnCell => null() + integer, dimension(:,:), pointer :: verticesOnCell => null() + integer, dimension(:,:), pointer :: cellsOnVertex => null() + integer, dimension(:,:), pointer :: edgesOnCell => null() + integer, dimension(:,:), pointer :: cellsOnEdge => null() + real, dimension(:), pointer :: latCell => null() + real, dimension(:), pointer :: lonCell => null() + real, dimension(:), pointer :: latVertex => null() + real, dimension(:), pointer :: lonVertex => null() + real, dimension(:), pointer :: latEdge => null() + real, dimension(:), pointer :: lonEdge => null() + end type mpas_mesh_type + + + contains + + + integer function mpas_mesh_setup(mesh_filename, mesh) result(stat) + + implicit none + + character (len=*), intent(in) :: mesh_filename + type (mpas_mesh_type), intent(out) :: mesh + + type (input_handle_type) :: handle + type (input_field_type) :: field + + stat = 0 + + if (scan_input_open(mesh_filename, handle) /= 0) then + stat = 1 + return + end if + + ! + ! nEdgesOnCell + ! + if (scan_input_for_field(handle, 'nEdgesOnCell', field) /= 0) then + stat = 1 + return + end if + + mesh % nCells = field % dimlens(1) + mesh % nVertices = 2 * (mesh % nCells - 2) + mesh % nEdges = 3 * (mesh % nCells - 2) + + stat = scan_input_read_field(field) + allocate(mesh % nEdgesOnCell(mesh % nCells)) + mesh % nEdgesOnCell(:) = field % array1i(:) + stat = scan_input_free_field(field) + + ! + ! landmask + ! + if (scan_input_for_field(handle, 'landmask', field) == 0) then + stat = scan_input_read_field(field) + allocate(mesh % landmask(mesh % nCells)) + mesh % landmask(:) = field % array1i(:) + stat = scan_input_free_field(field) + else ! no landmask available + allocate(mesh % landmask(mesh % nCells)) + mesh % landmask(:) = 1 + end if + + ! + ! cellsOnCell + ! + if (scan_input_for_field(handle, 'cellsOnCell', field) /= 0) then + stat = 1 + return + end if + + mesh % maxEdges = field % dimlens(1) + + stat = scan_input_read_field(field) + allocate(mesh % cellsOnCell(mesh % maxEdges, mesh % nCells)) + mesh % cellsOnCell(:,:) = field % array2i(:,:) + stat = scan_input_free_field(field) + + ! + ! verticesOnCell + ! + if (scan_input_for_field(handle, 'verticesOnCell', field) /= 0) then + stat = 1 + return + end if + + stat = scan_input_read_field(field) + allocate(mesh % verticesOnCell(mesh % maxEdges, mesh % nCells)) + mesh % verticesOnCell(:,:) = field % array2i(:,:) + stat = scan_input_free_field(field) + + ! + ! cellsOnVertex + ! + if (scan_input_for_field(handle, 'cellsOnVertex', field) /= 0) then + stat = 1 + return + end if + + stat = scan_input_read_field(field) + allocate(mesh % cellsOnVertex(3, mesh % nVertices)) + mesh % cellsOnVertex(:,:) = field % array2i(:,:) + stat = scan_input_free_field(field) + + ! + ! edgesOnCell + ! + if (scan_input_for_field(handle, 'edgesOnCell', field) /= 0) then + stat = 1 + return + end if + + stat = scan_input_read_field(field) + allocate(mesh % edgesOnCell(mesh % maxEdges, mesh % nCells)) + mesh % edgesOnCell(:,:) = field % array2i(:,:) + stat = scan_input_free_field(field) + + ! + ! cellsOnEdge + ! + if (scan_input_for_field(handle, 'cellsOnEdge', field) /= 0) then + stat = 1 + return + end if + + stat = scan_input_read_field(field) + allocate(mesh % cellsOnEdge(2, mesh % nEdges)) + mesh % cellsOnEdge(:,:) = field % array2i(:,:) + stat = scan_input_free_field(field) + + ! + ! latCell + ! + if (scan_input_for_field(handle, 'latCell', field) /= 0) then + stat = 1 + return + end if + + stat = scan_input_read_field(field) + allocate(mesh % latCell(mesh % nCells)) + if (field % xtype == FIELD_TYPE_REAL) then + mesh % latCell(:) = field % array1r(:) + else if (field % xtype == FIELD_TYPE_DOUBLE) then + mesh % latCell(:) = real(field % array1d(:)) + end if + stat = scan_input_free_field(field) + + ! + ! lonCell + ! + if (scan_input_for_field(handle, 'lonCell', field) /= 0) then + stat = 1 + return + end if + + stat = scan_input_read_field(field) + allocate(mesh % lonCell(mesh % nCells)) + if (field % xtype == FIELD_TYPE_REAL) then + mesh % lonCell(:) = field % array1r(:) + else if (field % xtype == FIELD_TYPE_DOUBLE) then + mesh % lonCell(:) = real(field % array1d(:)) + end if + stat = scan_input_free_field(field) + + ! + ! latVertex + ! + if (scan_input_for_field(handle, 'latVertex', field) /= 0) then + stat = 1 + return + end if + + stat = scan_input_read_field(field) + allocate(mesh % latVertex(mesh % nVertices)) + if (field % xtype == FIELD_TYPE_REAL) then + mesh % latVertex(:) = field % array1r(:) + else if (field % xtype == FIELD_TYPE_DOUBLE) then + mesh % latVertex(:) = real(field % array1d(:)) + end if + stat = scan_input_free_field(field) + + ! + ! lonVertex + ! + if (scan_input_for_field(handle, 'lonVertex', field) /= 0) then + stat = 1 + return + end if + + stat = scan_input_read_field(field) + allocate(mesh % lonVertex(mesh % nVertices)) + if (field % xtype == FIELD_TYPE_REAL) then + mesh % lonVertex(:) = field % array1r(:) + else if (field % xtype == FIELD_TYPE_DOUBLE) then + mesh % lonVertex(:) = real(field % array1d(:)) + end if + stat = scan_input_free_field(field) + + ! + ! latEdge + ! + if (scan_input_for_field(handle, 'latEdge', field) /= 0) then + stat = 1 + return + end if + + stat = scan_input_read_field(field) + allocate(mesh % latEdge(mesh % nEdges)) + if (field % xtype == FIELD_TYPE_REAL) then + mesh % latEdge(:) = field % array1r(:) + else if (field % xtype == FIELD_TYPE_DOUBLE) then + mesh % latEdge(:) = real(field % array1d(:)) + end if + stat = scan_input_free_field(field) + + ! + ! lonEdge + ! + if (scan_input_for_field(handle, 'lonEdge', field) /= 0) then + stat = 1 + return + end if + + stat = scan_input_read_field(field) + allocate(mesh % lonEdge(mesh % nEdges)) + if (field % xtype == FIELD_TYPE_REAL) then + mesh % lonEdge(:) = field % array1r(:) + else if (field % xtype == FIELD_TYPE_DOUBLE) then + mesh % lonEdge(:) = real(field % array1d(:)) + end if + stat = scan_input_free_field(field) + + stat = scan_input_close(handle) + + mesh % valid = .true. + + end function mpas_mesh_setup + + + integer function mpas_mesh_free(mesh) result(stat) + + implicit none + + type (mpas_mesh_type), intent(inout) :: mesh + + + stat = 0 + + mesh % valid = .false. + mesh % nCells = 0 + mesh % nVertices = 0 + mesh % nEdges = 0 + mesh % maxEdges = 0 + + if (associated(mesh % landmask)) then + deallocate(mesh % landmask) + end if + if (associated(mesh % nEdgesOnCell)) then + deallocate(mesh % nEdgesOnCell) + end if + if (associated(mesh % cellsOnCell)) then + deallocate(mesh % cellsOnCell) + end if + if (associated(mesh % verticesOnCell)) then + deallocate(mesh % verticesOnCell) + end if + if (associated(mesh % cellsOnVertex)) then + deallocate(mesh % cellsOnVertex) + end if + if (associated(mesh % edgesOnCell)) then + deallocate(mesh % edgesOnCell) + end if + if (associated(mesh % cellsOnEdge)) then + deallocate(mesh % cellsOnEdge) + end if + if (associated(mesh % latCell)) then + deallocate(mesh % latCell) + end if + if (associated(mesh % lonCell)) then + deallocate(mesh % lonCell) + end if + if (associated(mesh % latVertex)) then + deallocate(mesh % latVertex) + end if + if (associated(mesh % lonVertex)) then + deallocate(mesh % lonVertex) + end if + if (associated(mesh % latEdge)) then + deallocate(mesh % latEdge) + end if + if (associated(mesh % lonEdge)) then + deallocate(mesh % lonEdge) + end if + + end function mpas_mesh_free + +end module mpas_mesh diff --git a/WPS/metgrid/src/output_module.F b/WPS/metgrid/src/output_module.F new file mode 120000 index 00000000..b96322f8 --- /dev/null +++ b/WPS/metgrid/src/output_module.F @@ -0,0 +1 @@ +../../geogrid/src/output_module.F \ No newline at end of file diff --git a/WPS/metgrid/src/parallel_module.F b/WPS/metgrid/src/parallel_module.F new file mode 120000 index 00000000..513a89ea --- /dev/null +++ b/WPS/metgrid/src/parallel_module.F @@ -0,0 +1 @@ +../../geogrid/src/parallel_module.F \ No newline at end of file diff --git a/WPS/metgrid/src/process_domain_module.F b/WPS/metgrid/src/process_domain_module.F new file mode 100644 index 00000000..e54718d7 --- /dev/null +++ b/WPS/metgrid/src/process_domain_module.F @@ -0,0 +1,3719 @@ +module process_domain_module + + use mpas_mesh + use target_mesh + use remapper + + type (mpas_mesh_type), save :: mpas_source_mesh + type (target_mesh_type), save :: wrf_target_mesh_m, wrf_target_mesh_u, wrf_target_mesh_v + type (remap_info_type), save :: remap_info_m, remap_info_u, remap_info_v + real, dimension(:,:), allocatable, target :: xlat_rad, xlon_rad, xlat_u_rad, xlon_u_rad, xlat_v_rad, xlon_v_rad + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: process_domain + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine process_domain(n, extra_row, extra_col) + + use date_pack + use gridinfo_module + use interp_option_module + use misc_definitions_module + use module_debug + use storage_module + + implicit none + + ! Arguments + integer, intent(in) :: n + logical, intent(in) :: extra_row, extra_col + + ! Local variables + integer :: istatus + integer :: i, t, dyn_opt, & + we_dom_s, we_dom_e, sn_dom_s, sn_dom_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e, & + idiff, n_times, & + west_east_dim, south_north_dim, bottom_top_dim, map_proj, & + is_water, is_lake, is_ice, is_urban, i_soilwater, & + grid_id, parent_id, i_parent_start, j_parent_start, & + i_parent_end, j_parent_end, parent_grid_ratio, sub_x, sub_y, num_land_cat, process_bdy_width + real :: cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, & + dom_dx, dom_dy, pole_lat, pole_lon + real, dimension(16) :: corner_lats, corner_lons + real, pointer, dimension(:,:) :: landmask + real, pointer, dimension(:,:) :: xlat, xlon, xlat_u, xlon_u, xlat_v, xlon_v + logical, allocatable, dimension(:) :: got_this_field, got_const_field + character (len=19) :: valid_date, temp_date + character (len=128) :: title, mminlu + character (len=128), allocatable, dimension(:) :: output_flags, td_output_flags + character (len=128), dimension(:), pointer :: geogrid_flags + + ! CWH Initialize local pointer variables + nullify(landmask) + nullify(xlat) + nullify(xlon) + nullify(xlat_u) + nullify(xlon_u) + nullify(xlat_v) + nullify(xlon_v) + nullify(geogrid_flags) + + ! Compute number of times that we will process + call geth_idts(end_date(n), start_date(n), idiff) + call mprintf((idiff < 0),ERROR,'Ending date is earlier than starting date in namelist for domain %i.', i1=n) + + n_times = idiff / interval_seconds + + ! Check that the interval evenly divides the range of times to process + call mprintf((mod(idiff, interval_seconds) /= 0),WARN, & + 'In namelist, interval_seconds does not evenly divide '// & + '(end_date - start_date) for domain %i. Only %i time periods '// & + 'will be processed.', i1=n, i2=n_times) + + ! Initialize the storage module + call mprintf(.true.,LOGFILE,'Initializing storage module') + call storage_init() + + ! + ! Do time-independent processing + ! + call get_static_fields(n, dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, map_proj, & + we_dom_s, we_dom_e, sn_dom_s, sn_dom_e, & + we_patch_s, we_patch_e, & + we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, & + sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e, & + mminlu, num_land_cat, is_water, is_lake, is_ice, is_urban, i_soilwater, & + grid_id, parent_id, & + i_parent_start, j_parent_start, i_parent_end, j_parent_end, & + parent_grid_ratio, sub_x, sub_y, & + cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, & + pole_lat, pole_lon, dom_dx, dom_dy, landmask, xlat, xlon, xlat_u, xlon_u, & + xlat_v, xlon_v, corner_lats, corner_lons, title, geogrid_flags) + + + allocate(output_flags(num_entries)) + allocate(got_const_field(num_entries)) + + do i=1,num_entries + output_flags(i) = ' ' + got_const_field(i) = .false. + end do + + ! This call is to process the constant met fields (SST or SEAICE, for example) + ! That we process constant fields is indicated by the first argument + call process_single_met_time(.true., temp_date, n, extra_row, extra_col, xlat, xlon, & + xlat_u, xlon_u, xlat_v, xlon_v, landmask, & + title, dyn_opt, & + west_east_dim, south_north_dim, & + we_dom_s, we_dom_e, sn_dom_s, sn_dom_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e, & + got_const_field, & + map_proj, mminlu, num_land_cat, is_water, is_lake, is_ice, is_urban, i_soilwater, & + grid_id, parent_id, i_parent_start, & + j_parent_start, i_parent_end, j_parent_end, dom_dx, dom_dy, & + cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, & + pole_lat, pole_lon, parent_grid_ratio, sub_x, sub_y, & + corner_lats, corner_lons, output_flags, geogrid_flags, 0) + + ! + ! Begin time-dependent processing + ! + + allocate(td_output_flags(num_entries)) + allocate(got_this_field (num_entries)) + + ! Loop over all times to be processed for this domain + do t=0,n_times + + call geth_newdate(valid_date, trim(start_date(n)), t*interval_seconds) + temp_date = ' ' + + if (mod(interval_seconds,3600) == 0) then + write(temp_date,'(a13)') valid_date(1:10)//'_'//valid_date(12:13) + else if (mod(interval_seconds,60) == 0) then + write(temp_date,'(a16)') valid_date(1:10)//'_'//valid_date(12:16) + else + write(temp_date,'(a19)') valid_date(1:10)//'_'//valid_date(12:19) + end if + + call mprintf(.true.,STDOUT, ' Processing %s', s1=trim(temp_date)) + call mprintf(.true.,LOGFILE, 'Preparing to process output time %s', s1=temp_date) + + do i=1,num_entries + td_output_flags(i) = output_flags(i) + got_this_field(i) = got_const_field(i) + end do + + if (t > 0) then + process_bdy_width = process_only_bdy + else + process_bdy_width = 0 + end if + + call process_single_met_time(.false., temp_date, n, extra_row, extra_col, xlat, xlon, & + xlat_u, xlon_u, xlat_v, xlon_v, landmask, & + title, dyn_opt, & + west_east_dim, south_north_dim, & + we_dom_s, we_dom_e, sn_dom_s, sn_dom_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e, & + got_this_field, & + map_proj, mminlu, num_land_cat, is_water, is_lake, is_ice, is_urban, i_soilwater, & + grid_id, parent_id, i_parent_start, & + j_parent_start, i_parent_end, j_parent_end, dom_dx, dom_dy, & + cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, & + pole_lat, pole_lon, parent_grid_ratio, sub_x, sub_y, & + corner_lats, corner_lons, td_output_flags, geogrid_flags, process_bdy_width) + + end do ! Loop over n_times + + + deallocate(td_output_flags) + deallocate(got_this_field) + + deallocate(output_flags) + deallocate(got_const_field) + + if (associated(geogrid_flags)) deallocate(geogrid_flags) + + call storage_delete_all() + + istatus = mpas_mesh_free(mpas_source_mesh) + + if (allocated(xlat_rad)) deallocate(xlat_rad) + if (allocated(xlon_rad)) deallocate(xlon_rad) + if (allocated(xlat_u_rad)) deallocate(xlat_u_rad) + if (allocated(xlon_u_rad)) deallocate(xlon_u_rad) + if (allocated(xlat_v_rad)) deallocate(xlat_v_rad) + if (allocated(xlon_v_rad)) deallocate(xlon_v_rad) + istatus = target_mesh_free(wrf_target_mesh_m) + istatus = target_mesh_free(wrf_target_mesh_u) + istatus = target_mesh_free(wrf_target_mesh_v) + + istatus = remap_info_free(remap_info_m) + istatus = remap_info_free(remap_info_u) + istatus = remap_info_free(remap_info_v) + + end subroutine process_domain + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_static_fields + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_static_fields(n, dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, & + map_proj, & + we_dom_s, we_dom_e, sn_dom_s, sn_dom_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e, & + mminlu, num_land_cat, is_water, is_lake, is_ice, is_urban, i_soilwater, & + grid_id, parent_id, & + i_parent_start, j_parent_start, i_parent_end, j_parent_end, & + parent_grid_ratio, sub_x, sub_y, & + cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, & + pole_lat, pole_lon, dom_dx, dom_dy, landmask, xlat, xlon, xlat_u, xlon_u, & + xlat_v, xlon_v, corner_lats, corner_lons, title, geogrid_flags) + + use gridinfo_module + use input_module + use llxy_module + use parallel_module + use storage_module + use module_debug + use list_module + + implicit none + + ! Arguments + integer, intent(in) :: n + integer, intent(inout) :: dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, & + map_proj, & + we_dom_s, we_dom_e, sn_dom_s, sn_dom_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e, & + is_water, is_lake, is_ice, is_urban, i_soilwater, grid_id, parent_id, & + i_parent_start, j_parent_start, i_parent_end, j_parent_end, & + parent_grid_ratio, sub_x, sub_y, num_land_cat + real, pointer, dimension(:,:) :: landmask + real, intent(inout) :: cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, & + dom_dx, dom_dy, pole_lat, pole_lon + real, pointer, dimension(:,:) :: xlat, xlon, xlat_u, xlon_u, xlat_v, xlon_v + real, dimension(16), intent(out) :: corner_lats, corner_lons + character (len=128), intent(inout) :: title, mminlu + character (len=128), dimension(:), pointer :: geogrid_flags + + ! Local variables + integer :: istatus, i, j, k, sp1, ep1, sp2, ep2, sp3, ep3, & + lh_mult, rh_mult, bh_mult, th_mult, subx, suby + integer :: we_mem_subgrid_s, we_mem_subgrid_e, & + sn_mem_subgrid_s, sn_mem_subgrid_e + integer :: we_patch_subgrid_s, we_patch_subgrid_e, & + sn_patch_subgrid_s, sn_patch_subgrid_e + real, pointer, dimension(:,:,:) :: real_array + character (len=3) :: memorder + character (len=128) :: grid_type, datestr, cname, stagger, cunits, cdesc, ctemp + character (len=128), dimension(3) :: dimnames + type (fg_input) :: field + type (list) :: static_list, flag_list + type (list_item), dimension(:), pointer :: static_list_array + + call list_init(static_list) + + ! CWH Initialize local pointer variables + nullify(real_array) + + ! Initialize the input module to read static input data for this domain + call mprintf(.true.,LOGFILE,'Opening static input file.') + call input_init(n, istatus) + call mprintf((istatus /= 0),ERROR, 'input_init(): Error opening input for domain %i.', i1=n) + + ! Read global attributes from the static data input file + call mprintf(.true.,LOGFILE,'Reading static global attributes.') + call read_global_attrs(title, datestr, grid_type, dyn_opt, west_east_dim, & + south_north_dim, bottom_top_dim, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + map_proj, mminlu, num_land_cat, & + is_water, is_lake, is_ice, is_urban, i_soilwater, & + grid_id, parent_id, i_parent_start, & + j_parent_start, i_parent_end, j_parent_end, dom_dx, dom_dy, & + cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, & + truelat2, pole_lat, pole_lon, parent_grid_ratio, & + corner_lats, corner_lons, sub_x, sub_y) + + we_dom_s = 1 + sn_dom_s = 1 + if (grid_type(1:1) == 'C') then + we_dom_e = west_east_dim - 1 + sn_dom_e = south_north_dim - 1 + else if (grid_type(1:1) == 'E') then + we_dom_e = west_east_dim + sn_dom_e = south_north_dim + end if + + ! Given the full dimensions of this domain, find out the range of indices + ! that will be worked on by this processor. This information is given by + ! my_minx, my_miny, my_maxx, my_maxy + call parallel_get_tile_dims(west_east_dim, south_north_dim) + + ! Must figure out patch dimensions from info in parallel module + if (nprocs > 1 .and. .not. do_tiled_input) then + + we_patch_s = my_minx + we_patch_stag_s = my_minx + we_patch_e = my_maxx - 1 + sn_patch_s = my_miny + sn_patch_stag_s = my_miny + sn_patch_e = my_maxy - 1 + + if (gridtype == 'C') then + if (my_x /= nproc_x - 1) then + we_patch_e = we_patch_e + 1 + we_patch_stag_e = we_patch_e + else + we_patch_stag_e = we_patch_e + 1 + end if + if (my_y /= nproc_y - 1) then + sn_patch_e = sn_patch_e + 1 + sn_patch_stag_e = sn_patch_e + else + sn_patch_stag_e = sn_patch_e + 1 + end if + else if (gridtype == 'E') then + we_patch_e = we_patch_e + 1 + sn_patch_e = sn_patch_e + 1 + we_patch_stag_e = we_patch_e + sn_patch_stag_e = sn_patch_e + end if + + end if + + ! Compute multipliers for halo width; these must be 0/1 + if (my_x /= 0) then + lh_mult = 1 + else + lh_mult = 0 + end if + if (my_x /= (nproc_x-1)) then + rh_mult = 1 + else + rh_mult = 0 + end if + if (my_y /= 0) then + bh_mult = 1 + else + bh_mult = 0 + end if + if (my_y /= (nproc_y-1)) then + th_mult = 1 + else + th_mult = 0 + end if + + we_mem_s = we_patch_s - HALO_WIDTH*lh_mult + we_mem_e = we_patch_e + HALO_WIDTH*rh_mult + sn_mem_s = sn_patch_s - HALO_WIDTH*bh_mult + sn_mem_e = sn_patch_e + HALO_WIDTH*th_mult + we_mem_stag_s = we_patch_stag_s - HALO_WIDTH*lh_mult + we_mem_stag_e = we_patch_stag_e + HALO_WIDTH*rh_mult + sn_mem_stag_s = sn_patch_stag_s - HALO_WIDTH*bh_mult + sn_mem_stag_e = sn_patch_stag_e + HALO_WIDTH*th_mult + + ! Initialize a proj_info type for the destination grid projection. This will + ! primarily be used for rotating Earth-relative winds to grid-relative winds + call set_domain_projection(map_proj, stand_lon, truelat1, truelat2, & + dom_dx, dom_dy, dom_dx, dom_dy, west_east_dim, & + south_north_dim, real(west_east_dim)/2., & + real(south_north_dim)/2.,cen_lat, cen_lon, & + cen_lat, cen_lon) + + ! Read static fields using the input module; we know that there are no more + ! fields to be read when read_next_field() returns a non-zero status. + istatus = 0 + do while (istatus == 0) + call read_next_field(sp1, ep1, sp2, ep2, sp3, ep3, cname, cunits, cdesc, & + memorder, stagger, dimnames, subx, suby, & + real_array, istatus) + if (istatus == 0) then + + call mprintf(.true.,LOGFILE, 'Read in static field %s.',s1=cname) + call list_insert(static_list, ckey=cname, cvalue=cname) + + ! We will also keep copies in core of the lat/lon arrays, for use in + ! interpolation of the met fields to the model grid. + ! For now, we assume that the lat/lon arrays will have known field names + if (index(cname, 'XLAT_M') /= 0 .and. & + len_trim(cname) == len_trim('XLAT_M')) then + allocate(xlat(we_mem_s:we_mem_e,sn_mem_s:sn_mem_e)) + xlat(we_patch_s:we_patch_e,sn_patch_s:sn_patch_e) = real_array(:,:,1) + call exchange_halo_r(xlat, & + we_mem_s, we_mem_e, sn_mem_s, sn_mem_e, 1, 1, & + we_patch_s, we_patch_e, sn_patch_s, sn_patch_e, 1, 1) + + else if (index(cname, 'XLONG_M') /= 0 .and. & + len_trim(cname) == len_trim('XLONG_M')) then + allocate(xlon(we_mem_s:we_mem_e,sn_mem_s:sn_mem_e)) + xlon(we_patch_s:we_patch_e,sn_patch_s:sn_patch_e) = real_array(:,:,1) + call exchange_halo_r(xlon, & + we_mem_s, we_mem_e, sn_mem_s, sn_mem_e, 1, 1, & + we_patch_s, we_patch_e, sn_patch_s, sn_patch_e, 1, 1) + + else if (index(cname, 'XLAT_U') /= 0 .and. & + len_trim(cname) == len_trim('XLAT_U')) then + allocate(xlat_u(we_mem_stag_s:we_mem_stag_e,sn_mem_s:sn_mem_e)) + xlat_u(we_patch_stag_s:we_patch_stag_e,sn_patch_s:sn_patch_e) = real_array(:,:,1) + call exchange_halo_r(xlat_u, & + we_mem_stag_s, we_mem_stag_e, sn_mem_s, sn_mem_e, 1, 1, & + we_patch_stag_s, we_patch_stag_e, sn_patch_s, sn_patch_e, 1, 1) + + else if (index(cname, 'XLONG_U') /= 0 .and. & + len_trim(cname) == len_trim('XLONG_U')) then + allocate(xlon_u(we_mem_stag_s:we_mem_stag_e,sn_mem_s:sn_mem_e)) + xlon_u(we_patch_stag_s:we_patch_stag_e,sn_patch_s:sn_patch_e) = real_array(:,:,1) + call exchange_halo_r(xlon_u, & + we_mem_stag_s, we_mem_stag_e, sn_mem_s, sn_mem_e, 1, 1, & + we_patch_stag_s, we_patch_stag_e, sn_patch_s, sn_patch_e, 1, 1) + + else if (index(cname, 'XLAT_V') /= 0 .and. & + len_trim(cname) == len_trim('XLAT_V')) then + allocate(xlat_v(we_mem_s:we_mem_e,sn_mem_stag_s:sn_mem_stag_e)) + xlat_v(we_patch_s:we_patch_e,sn_patch_stag_s:sn_patch_stag_e) = real_array(:,:,1) + call exchange_halo_r(xlat_v, & + we_mem_s, we_mem_e, sn_mem_stag_s, sn_mem_stag_e, 1, 1, & + we_patch_s, we_patch_e, sn_patch_stag_s, sn_patch_stag_e, 1, 1) + + else if (index(cname, 'XLONG_V') /= 0 .and. & + len_trim(cname) == len_trim('XLONG_V')) then + allocate(xlon_v(we_mem_s:we_mem_e,sn_mem_stag_s:sn_mem_stag_e)) + xlon_v(we_patch_s:we_patch_e,sn_patch_stag_s:sn_patch_stag_e) = real_array(:,:,1) + call exchange_halo_r(xlon_v, & + we_mem_s, we_mem_e, sn_mem_stag_s, sn_mem_stag_e, 1, 1, & + we_patch_s, we_patch_e, sn_patch_stag_s, sn_patch_stag_e, 1, 1) + + else if (index(cname, 'LANDMASK') /= 0 .and. & + len_trim(cname) == len_trim('LANDMASK')) then + allocate(landmask(we_mem_s:we_mem_e,sn_mem_s:sn_mem_e)) + landmask(we_patch_s:we_patch_e,sn_patch_s:sn_patch_e) = real_array(:,:,1) + call exchange_halo_r(landmask, & + we_mem_s, we_mem_e, sn_mem_s, sn_mem_e, 1, 1, & + we_patch_s, we_patch_e, sn_patch_s, sn_patch_e, 1, 1) + + end if + + if (subx > 1) then + we_mem_subgrid_s = (we_mem_s + HALO_WIDTH*lh_mult - 1)*subx - HALO_WIDTH*lh_mult + 1 + we_mem_subgrid_e = (we_mem_e + (1-rh_mult) - HALO_WIDTH*rh_mult )*subx + HALO_WIDTH*rh_mult + we_patch_subgrid_s = (we_patch_s - 1)*subx + 1 + we_patch_subgrid_e = (we_patch_e + (1-rh_mult) )*subx + end if + if (suby > 1) then + sn_mem_subgrid_s = (sn_mem_s + HALO_WIDTH*bh_mult - 1)*suby - HALO_WIDTH*bh_mult + 1 + sn_mem_subgrid_e = (sn_mem_e + (1-th_mult) - HALO_WIDTH*th_mult )*suby + HALO_WIDTH*th_mult + sn_patch_subgrid_s = (sn_patch_s - 1)*suby + 1 + sn_patch_subgrid_e = (sn_patch_e + (1-th_mult) )*suby + end if + + ! Having read in a field, we write each level individually to the + ! storage module; levels will be reassembled later on when they + ! are written. + do k=sp3,ep3 + field%header%sr_x=subx + field%header%sr_y=suby + field%header%version = 1 + field%header%date = start_date(n) + field%header%time_dependent = .false. + field%header%mask_field = .false. + field%header%constant_field = .false. + field%header%forecast_hour = 0.0 + field%header%fg_source = 'geogrid_model' + field%header%field = cname + field%header%units = cunits + field%header%description = cdesc + field%header%vertical_coord = dimnames(3) + field%header%vertical_level = k + field%header%array_order = memorder + field%header%is_wind_grid_rel = .true. + field%header%array_has_missing_values = .false. + if (gridtype == 'C') then + if (subx > 1 .or. suby > 1) then + field%map%stagger = M + field%header%dim1(1) = we_mem_subgrid_s + field%header%dim1(2) = we_mem_subgrid_e + field%header%dim2(1) = sn_mem_subgrid_s + field%header%dim2(2) = sn_mem_subgrid_e + else if (trim(stagger) == 'M') then + field%map%stagger = M + field%header%dim1(1) = we_mem_s + field%header%dim1(2) = we_mem_e + field%header%dim2(1) = sn_mem_s + field%header%dim2(2) = sn_mem_e + else if (trim(stagger) == 'U') then + field%map%stagger = U + field%header%dim1(1) = we_mem_stag_s + field%header%dim1(2) = we_mem_stag_e + field%header%dim2(1) = sn_mem_s + field%header%dim2(2) = sn_mem_e + else if (trim(stagger) == 'V') then + field%map%stagger = V + field%header%dim1(1) = we_mem_s + field%header%dim1(2) = we_mem_e + field%header%dim2(1) = sn_mem_stag_s + field%header%dim2(2) = sn_mem_stag_e + else if (trim(stagger) == 'CORNER') then + field%map%stagger = CORNER + field%header%dim1(1) = we_mem_stag_s + field%header%dim1(2) = we_mem_stag_e + field%header%dim2(1) = sn_mem_stag_s + field%header%dim2(2) = sn_mem_stag_e + end if + else if (gridtype == 'E') then + if (trim(stagger) == 'M') then + field%map%stagger = HH + else if (trim(stagger) == 'V') then + field%map%stagger = VV + end if + field%header%dim1(1) = we_mem_s + field%header%dim1(2) = we_mem_e + field%header%dim2(1) = sn_mem_s + field%header%dim2(2) = sn_mem_e + end if + + allocate(field%valid_mask) + + if (subx > 1 .or. suby > 1) then + allocate(field%r_arr(we_mem_subgrid_s:we_mem_subgrid_e,& + sn_mem_subgrid_s:sn_mem_subgrid_e)) + field%r_arr(we_patch_subgrid_s:we_patch_subgrid_e,sn_patch_subgrid_s:sn_patch_subgrid_e) = & + real_array(sp1:ep1,sp2:ep2,k) + call exchange_halo_r(field%r_arr, & + we_mem_subgrid_s, we_mem_subgrid_e, sn_mem_subgrid_s, sn_mem_subgrid_e, 1, 1, & + we_patch_subgrid_s, we_patch_subgrid_e, sn_patch_subgrid_s, sn_patch_subgrid_e, 1, 1) + call bitarray_create(field%valid_mask, & + (we_mem_subgrid_e-we_mem_subgrid_s)+1, & + (sn_mem_subgrid_e-sn_mem_subgrid_s)+1) + do j=1,(sn_mem_subgrid_e-sn_mem_subgrid_s)+1 + do i=1,(we_mem_subgrid_e-we_mem_subgrid_s)+1 + call bitarray_set(field%valid_mask, i, j) + end do + end do + + else if (field%map%stagger == M .or. & + field%map%stagger == HH .or. & + field%map%stagger == VV) then + allocate(field%r_arr(we_mem_s:we_mem_e,& + sn_mem_s:sn_mem_e)) + field%r_arr(we_patch_s:we_patch_e,sn_patch_s:sn_patch_e) = real_array(sp1:ep1,sp2:ep2,k) + call exchange_halo_r(field%r_arr, & + we_mem_s, we_mem_e, sn_mem_s, sn_mem_e, 1, 1, & + we_patch_s, we_patch_e, sn_patch_s, sn_patch_e, 1, 1) + call bitarray_create(field%valid_mask, & + (we_mem_e-we_mem_s)+1, & + (sn_mem_e-sn_mem_s)+1) + do j=1,(sn_mem_e-sn_mem_s)+1 + do i=1,(we_mem_e-we_mem_s)+1 + call bitarray_set(field%valid_mask, i, j) + end do + end do + else if (field%map%stagger == U) then + allocate(field%r_arr(we_mem_stag_s:we_mem_stag_e,& + sn_mem_s:sn_mem_e)) + field%r_arr(we_patch_stag_s:we_patch_stag_e,sn_patch_s:sn_patch_e) = real_array(sp1:ep1,sp2:ep2,k) + call exchange_halo_r(field%r_arr, & + we_mem_stag_s, we_mem_stag_e, sn_mem_s, sn_mem_e, 1, 1, & + we_patch_stag_s, we_patch_stag_e, sn_patch_s, sn_patch_e, 1, 1) + call bitarray_create(field%valid_mask, & + (we_mem_stag_e-we_mem_stag_s)+1, & + (sn_mem_e-sn_mem_s)+1) + do j=1,(sn_mem_e-sn_mem_s)+1 + do i=1,(we_mem_stag_e-we_mem_stag_s)+1 + call bitarray_set(field%valid_mask, i, j) + end do + end do + else if (field%map%stagger == V) then + allocate(field%r_arr(we_mem_s:we_mem_e,& + sn_mem_stag_s:sn_mem_stag_e)) + field%r_arr(we_patch_s:we_patch_e,sn_patch_stag_s:sn_patch_stag_e) = real_array(sp1:ep1,sp2:ep2,k) + call exchange_halo_r(field%r_arr, & + we_mem_s, we_mem_e, sn_mem_stag_s, sn_mem_stag_e, 1, 1, & + we_patch_s, we_patch_e, sn_patch_stag_s, sn_patch_stag_e, 1, 1) + call bitarray_create(field%valid_mask, & + (we_mem_e-we_mem_s)+1, & + (sn_mem_stag_e-sn_mem_stag_s)+1) + do j=1,(sn_mem_stag_e-sn_mem_stag_s)+1 + do i=1,(we_mem_e-we_mem_s)+1 + call bitarray_set(field%valid_mask, i, j) + end do + end do + else if (field%map%stagger == CORNER) then + allocate(field%r_arr(we_mem_stag_s:we_mem_stag_e,& + sn_mem_stag_s:sn_mem_stag_e)) + field%r_arr(we_patch_stag_s:we_patch_stag_e,sn_patch_stag_s:sn_patch_stag_e) = real_array(sp1:ep1,sp2:ep2,k) + call exchange_halo_r(field%r_arr, & + we_mem_stag_s, we_mem_stag_e, sn_mem_stag_s, sn_mem_stag_e, 1, 1, & + we_patch_stag_s, we_patch_stag_e, sn_patch_stag_s, sn_patch_stag_e, 1, 1) + call bitarray_create(field%valid_mask, & + (we_mem_stag_e-we_mem_stag_s)+1, & + (sn_mem_stag_e-sn_mem_stag_s)+1) + do j=1,(sn_mem_stag_e-sn_mem_stag_s)+1 + do i=1,(we_mem_stag_e-we_mem_stag_s)+1 + call bitarray_set(field%valid_mask, i, j) + end do + end do + end if + + nullify(field%modified_mask) + + call storage_put_field(field) + + end do + + end if ! if (istatus == 0) + end do ! do while (istatus == 0) + + static_list_array => list_get_keys(static_list) + call list_init(flag_list) + do i=1,size(static_list_array) + istatus = 0 + ctemp = 'FLAG_'//trim(static_list_array(i)%ckey) + call ext_get_dom_ti_integer_scalar(ctemp, istatus, suppress_errors=.true.) + if (istatus == 1) call list_insert(flag_list, ckey=ctemp, cvalue=ctemp) + end do + deallocate(static_list_array) + call list_destroy(static_list) + + ! Done reading all static fields for this domain + call input_close() + + static_list_array => list_get_keys(flag_list) + allocate(geogrid_flags(size(static_list_array))) + do i=1,size(static_list_array) + geogrid_flags(i) = static_list_array(i)%ckey + end do + deallocate(static_list_array) + + call list_destroy(flag_list) + + end subroutine get_static_fields + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: process_single_met_time + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine process_single_met_time(do_const_processing, & + temp_date, n, extra_row, extra_col, xlat, xlon, & + xlat_u, xlon_u, xlat_v, xlon_v, landmask, & + title, dyn_opt, & + west_east_dim, south_north_dim, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e, & + got_this_field, & + map_proj, mminlu, num_land_cat, is_water, is_lake, is_ice, is_urban, i_soilwater, & + grid_id, parent_id, i_parent_start, & + j_parent_start, i_parent_end, j_parent_end, dom_dx, dom_dy, & + cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, & + pole_lat, pole_lon, parent_grid_ratio, sub_x, sub_y, & + corner_lats, corner_lons, output_flags, geogrid_flags, process_bdy_width) + + use bitarray_module + use gridinfo_module + use interp_module + use interp_option_module + use llxy_module + use misc_definitions_module + use module_debug + use output_module + use parallel_module + use read_met_module + use rotate_winds_module + use storage_module + + implicit none + + ! Arguments + logical, intent(in) :: do_const_processing + integer, intent(in) :: n, dyn_opt, west_east_dim, south_north_dim, map_proj, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e, & + is_water, is_lake, is_ice, is_urban, i_soilwater, & + grid_id, parent_id, i_parent_start, j_parent_start, & + i_parent_end, j_parent_end, parent_grid_ratio, sub_x, sub_y, num_land_cat, & + process_bdy_width +! BUG: Should we be passing these around as pointers, or just declare them as arrays? + real, pointer, dimension(:,:) :: landmask + real, intent(in) :: dom_dx, dom_dy, cen_lat, moad_cen_lat, cen_lon, stand_lon, & + truelat1, truelat2, pole_lat, pole_lon + real, dimension(16), intent(in) :: corner_lats, corner_lons + real, pointer, dimension(:,:) :: xlat, xlon, xlat_u, xlon_u, xlat_v, xlon_v + logical, intent(in) :: extra_row, extra_col + logical, dimension(:), intent(inout) :: got_this_field + character (len=19), intent(in) :: temp_date + character (len=128), intent(in) :: mminlu + character (len=128), dimension(:), intent(inout) :: output_flags + character (len=128), dimension(:), pointer :: geogrid_flags + +! BUG: Move this constant to misc_definitions_module? +integer, parameter :: BDR_WIDTH = 3 + + ! Local variables + integer :: istatus, fg_idx, idx, idxt, i, j, bottom_top_dim, & + sm1, em1, sm2, em2, sm3, em3, & + sp1, ep1, sp2, ep2, sp3, ep3, & + sd1, ed1, sd2, ed2, sd3, ed3, & + u_idx + integer :: nmet_flags + integer :: num_metgrid_soil_levs + integer, pointer, dimension(:) :: soil_levels + real :: rx, ry + integer, pointer, dimension(:) :: u_levels, v_levels + real, pointer, dimension(:,:,:) :: real_array + character (len=19) :: output_date + character (len=128) :: cname, title + character (len=MAX_FILENAME_LEN) :: input_name + character (len=128), allocatable, dimension(:) :: met_flags + type (fg_input) :: field, u_field, v_field + type (met_data) :: fg_data + + ! CWH Initialize local pointer variables + nullify(soil_levels) + nullify(u_levels) + nullify(v_levels) + nullify(real_array) + + + ! For this time, we need to process all first-guess filename roots. When we + ! hit a root containing a '*', we assume we have hit the end of the list + fg_idx = 1 + if (do_const_processing) then + input_name = constants_name(fg_idx) + else + input_name = fg_name(fg_idx) + end if + do while (input_name /= '*') + + call mprintf(.true.,STDOUT, ' %s', s1=input_name) + call mprintf(.true.,LOGFILE, 'Getting input fields from %s', s1=input_name) + + if (index(input_name, 'mpas:') == 1) then + call process_mpas_fields(input_name, do_const_processing, temp_date, fg_data, got_this_field, & + landmask, process_bdy_width, & + u_field, v_field, & + dom_dx, dom_dy, & + xlat, xlon, xlat_u, xlon_u, xlat_v, xlon_v, & + output_flags, west_east_dim, south_north_dim, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e ) + else + call process_intermediate_fields(input_name, do_const_processing, temp_date, fg_data, got_this_field, & + landmask, process_bdy_width, & + u_field, v_field, & + dom_dx, dom_dy, & + xlat, xlon, xlat_u, xlon_u, xlat_v, xlon_v, & + output_flags, west_east_dim, south_north_dim, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e ) + end if + + fg_idx = fg_idx + 1 + if (do_const_processing) then + input_name = constants_name(fg_idx) + else + input_name = fg_name(fg_idx) + end if + end do ! while (input_name /= '*') + + ! + ! Rotate winds from earth-relative to grid-relative + ! + + call storage_get_levels(u_field, u_levels) + call storage_get_levels(v_field, v_levels) + + if (associated(u_levels) .and. associated(v_levels)) then + u_idx = 1 + do u_idx = 1, size(u_levels) + u_field%header%vertical_level = u_levels(u_idx) + call storage_get_field(u_field, istatus) + v_field%header%vertical_level = v_levels(u_idx) + call storage_get_field(v_field, istatus) + + if (gridtype == 'C') then + call met_to_map(u_field%r_arr, u_field%valid_mask, & + v_field%r_arr, v_field%valid_mask, & + we_mem_stag_s, sn_mem_s, & + we_mem_stag_e, sn_mem_e, & + we_mem_s, sn_mem_stag_s, & + we_mem_e, sn_mem_stag_e, & + xlon_u, xlon_v, xlat_u, xlat_v) + else if (gridtype == 'E') then + call met_to_map_nmm(u_field%r_arr, u_field%valid_mask, & + v_field%r_arr, v_field%valid_mask, & + we_mem_s, sn_mem_s, & + we_mem_e, sn_mem_e, & + xlat_v, xlon_v) + end if + + end do + + deallocate(u_levels) + deallocate(v_levels) + + end if + + if (do_const_processing) return + + ! + ! Now that we have all degribbed fields, we build a 3-d pressure field, and fill in any + ! missing levels in the other 3-d fields + ! + call mprintf(.true.,LOGFILE,'Filling missing levels.') + call fill_missing_levels(output_flags) + + call mprintf(.true.,LOGFILE,'Creating derived fields.') + call create_derived_fields(gridtype, fg_data%hdate, fg_data%xfcst, & + we_mem_s, we_mem_e, sn_mem_s, sn_mem_e, & + we_mem_stag_s, we_mem_stag_e, sn_mem_stag_s, sn_mem_stag_e, & + got_this_field, output_flags) + + ! + ! Derive some MPAS fields from others, e.g., TT from theta and pressure + ! + call derive_mpas_fields() + + ! + ! Check that every mandatory field was found in input data + ! + do i=1,num_entries + if (is_mandatory(i) .and. .not. got_this_field(i)) then + call mprintf(.true.,ERROR,'The mandatory field %s was not found in any input data.',s1=fieldname(i)) + end if + end do + + ! + ! Before we begin to write fields, if debug_level is set high enough, we + ! write a table of which fields are available at which levels to the + ! metgrid.log file, and then we check to see if any fields are not + ! completely covered with data. + ! + call storage_print_fields() + call find_missing_values() + + ! + ! All of the processing is now done for this time period for this domain; + ! now we simply output every field from the storage module. + ! + + title = 'OUTPUT FROM METGRID V3.9.1' + + ! Initialize the output module for this domain and time + call mprintf(.true.,LOGFILE,'Initializing output module.') + output_date = temp_date + if ( .not. nocolons ) then + if (len_trim(temp_date) == 13) then + output_date(14:19) = ':00:00' + else if (len_trim(temp_date) == 16) then + output_date(17:19) = ':00' + end if + else + if (len_trim(temp_date) == 13) then + output_date(14:19) = '_00_00' + else if (len_trim(temp_date) == 16) then + output_date(17:19) = '_00' + end if + endif + + call output_init(n, title, output_date, gridtype, dyn_opt, & + corner_lats, corner_lons, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + we_patch_s, we_patch_e, sn_patch_s, sn_patch_e, & + we_mem_s, we_mem_e, sn_mem_s, sn_mem_e, & + extra_col, extra_row) + + call get_bottom_top_dim(bottom_top_dim) + + ! Add in a flag to tell real that we have seven new msf fields + nmet_flags = num_entries + 1 + if (associated(geogrid_flags)) nmet_flags = nmet_flags + size(geogrid_flags) + allocate(met_flags(nmet_flags)) + do i=1,num_entries + met_flags(i) = output_flags(i) + end do + if (gridtype == 'C') then + met_flags(num_entries+1) = 'FLAG_MF_XY' + else + met_flags(num_entries+1) = ' ' + end if + if (associated(geogrid_flags)) then + do i=1,size(geogrid_flags) + met_flags(num_entries+1+i) = geogrid_flags(i) + end do + end if + + ! Find out how many soil levels or layers we have; this assumes a field named ST + field % header % field = 'ST' + nullify(soil_levels) + call storage_get_levels(field, soil_levels) + + if (.not. associated(soil_levels)) then + field % header % field = 'SOILT' + nullify(soil_levels) + call storage_get_levels(field, soil_levels) + end if + + if (.not. associated(soil_levels)) then + field % header % field = 'STC_WPS' + nullify(soil_levels) + call storage_get_levels(field, soil_levels) + end if + + if (associated(soil_levels)) then + num_metgrid_soil_levs = size(soil_levels) + deallocate(soil_levels) + else + num_metgrid_soil_levs = 0 + end if + + ! First write out global attributes + call mprintf(.true.,LOGFILE,'Writing global attributes to output.') + call write_global_attrs(title, output_date, gridtype, dyn_opt, west_east_dim, & + south_north_dim, bottom_top_dim, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + map_proj, mminlu, num_land_cat, & + is_water, is_lake, is_ice, is_urban, i_soilwater, & + grid_id, parent_id, i_parent_start, & + j_parent_start, i_parent_end, j_parent_end, dom_dx, dom_dy, & + cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, & + pole_lat, pole_lon, parent_grid_ratio, sub_x, sub_y, & + corner_lats, corner_lons, num_metgrid_soil_levs, & + met_flags, nmet_flags, process_bdy_width) + + deallocate(met_flags) + + call reset_next_field() + + istatus = 0 + + ! Now loop over all output fields, writing each to the output module + do while (istatus == 0) + call get_next_output_field(cname, real_array, & + sm1, em1, sm2, em2, sm3, em3, istatus) + if (istatus == 0) then + + call mprintf(.true.,LOGFILE,'Writing field %s to output.',s1=cname) + call write_field(sm1, em1, sm2, em2, sm3, em3, & + cname, output_date, real_array) + deallocate(real_array) + + end if + + end do + + call mprintf(.true.,LOGFILE,'Closing output file.') + call output_close() + + ! Free up memory used by met fields for this valid time + call storage_delete_all_td() + + end subroutine process_single_met_time + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: process_intermediate_fields + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine process_intermediate_fields(input_name, do_const_processing, temp_date, fg_data, got_this_field, & + landmask, process_bdy_width, & + u_field, v_field, & + dom_dx, dom_dy, & + xlat, xlon, xlat_u, xlon_u, xlat_v, xlon_v, & + output_flags, west_east_dim, south_north_dim, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e ) + + use bitarray_module + use gridinfo_module + use interp_module + use interp_option_module + use llxy_module + use misc_definitions_module + use module_debug + use output_module + use parallel_module + use read_met_module + use rotate_winds_module + use storage_module + + implicit none + +! BUG: Move this constant to misc_definitions_module? +integer, parameter :: BDR_WIDTH = 3 + + character (len=*), intent(inout) :: input_name + logical, intent(in) :: do_const_processing + character (len=*), intent(in) :: temp_date + type (met_data), intent(inout) :: fg_data + logical, dimension(:), intent(inout) :: got_this_field + real, pointer, dimension(:,:) :: landmask + integer, intent(in) :: process_bdy_width + type (fg_input), intent(inout) :: u_field, v_field + character (len=128), dimension(:), intent(inout) :: output_flags + real, intent(in) :: dom_dx, dom_dy + real, pointer, dimension(:,:) :: xlat, xlon, xlat_u, xlon_u, xlat_v, xlon_v + integer, intent(in) :: west_east_dim, south_north_dim, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e + + integer :: istatus + integer :: idx, idxt, u_idx + integer :: iqstatus + real :: threshold + real, pointer, dimension(:,:) :: halo_slab => null() + integer, pointer, dimension(:) :: u_levels => null() + integer, pointer, dimension(:) :: v_levels => null() + integer :: bdr_wdth + logical :: do_gcell_interp + type (fg_input) :: field + + + ! Do a first pass through this fg source to get all mask fields used + ! during interpolation + call get_interp_masks(trim(input_name), do_const_processing, temp_date) + + istatus = 0 + + ! Initialize the module for reading in the met fields + call read_met_init(trim(input_name), do_const_processing, temp_date, istatus) + + if (istatus == 0) then + + ! Process all fields and levels from the current file; read_next_met_field() + ! will return a non-zero status when there are no more fields to be read. + do while (istatus == 0) + + call read_next_met_field(fg_data, istatus) + + if (istatus == 0) then + + ! Find index into fieldname, interp_method, masked, and fill_missing + ! of the current field + idxt = num_entries + 1 + do idx=1,num_entries + if ((index(fieldname(idx), trim(fg_data%field)) /= 0) .and. & + (len_trim(fieldname(idx)) == len_trim(fg_data%field))) then + + got_this_field(idx) = .true. + + if (index(input_name,trim(from_input(idx))) /= 0 .or. & + (from_input(idx) == '*' .and. idxt == num_entries + 1)) then + idxt = idx + end if + + end if + end do + idx = idxt + if (idx > num_entries) idx = num_entries ! The last entry is a default + + ! Do we need to rename this field? + if (output_name(idx) /= ' ') then + fg_data%field = output_name(idx)(1:9) + + idxt = num_entries + 1 + do idx=1,num_entries + if ((index(fieldname(idx), trim(fg_data%field)) /= 0) .and. & + (len_trim(fieldname(idx)) == len_trim(fg_data%field))) then + + got_this_field(idx) = .true. + + if (index(input_name,trim(from_input(idx))) /= 0 .or. & + (from_input(idx) == '*' .and. idxt == num_entries + 1)) then + idxt = idx + end if + + end if + end do + idx = idxt + if (idx > num_entries) idx = num_entries ! The last entry is a default + end if + + ! Do a simple check to see whether this is a global dataset + ! Note that we do not currently support regional Gaussian grids + if ((fg_data%iproj == PROJ_LATLON .and. abs(fg_data%nx * fg_data%deltalon - 360.) < 0.0001) & + .or. (fg_data%iproj == PROJ_GAUSS)) then + bdr_wdth = BDR_WIDTH + allocate(halo_slab(1-BDR_WIDTH:fg_data%nx+BDR_WIDTH,1:fg_data%ny)) + + halo_slab(1:fg_data%nx, 1:fg_data%ny) = & + fg_data%slab(1:fg_data%nx, 1:fg_data%ny) + + halo_slab(1-BDR_WIDTH:0, 1:fg_data%ny) = & + fg_data%slab(fg_data%nx-BDR_WIDTH+1:fg_data%nx, 1:fg_data%ny) + + halo_slab(fg_data%nx+1:fg_data%nx+BDR_WIDTH, 1:fg_data%ny) = & + fg_data%slab(1:BDR_WIDTH, 1:fg_data%ny) + + deallocate(fg_data%slab) + else + bdr_wdth = 0 + halo_slab => fg_data%slab + nullify(fg_data%slab) + end if + + call mprintf(.true.,LOGFILE,'Processing %s at level %f.',s1=fg_data%field,f1=fg_data%xlvl) + + call push_source_projection(fg_data%iproj, fg_data%xlonc, fg_data%truelat1, & + fg_data%truelat2, fg_data%dx, fg_data%dy, fg_data%deltalat, & + fg_data%deltalon, fg_data%starti, fg_data%startj, & + fg_data%startlat, fg_data%startlon, & + fg_data%pole_lat, fg_data%pole_lon, & + fg_data%centerlat, fg_data%centerlon, & + real(fg_data%nx+1)/2., real(fg_data%ny+1)/2., & + earth_radius=fg_data%earth_radius*1000.) + + ! Initialize fg_input structure to store the field + field%header%version = 1 + field%header%date = fg_data%hdate//' ' + if (do_const_processing) then + field%header%time_dependent = .false. + field%header%constant_field = .true. + else + field%header%time_dependent = .true. + field%header%constant_field = .false. + end if + field%header%forecast_hour = fg_data%xfcst + field%header%fg_source = 'FG' + field%header%field = ' ' + field%header%field(1:9) = fg_data%field + field%header%units = ' ' + field%header%units(1:25) = fg_data%units + field%header%description = ' ' + field%header%description(1:46) = fg_data%desc + call get_z_dim_name(fg_data%field,field%header%vertical_coord) + field%header%vertical_level = nint(fg_data%xlvl) + field%header%sr_x = 1 + field%header%sr_y = 1 + field%header%array_order = 'XY ' + field%header%is_wind_grid_rel = fg_data%is_wind_grid_rel + field%header%array_has_missing_values = .false. + nullify(field%r_arr) + nullify(field%valid_mask) + nullify(field%modified_mask) + + if (output_this_field(idx) .and. flag_in_output(idx) /= ' ') then + output_flags(idx) = flag_in_output(idx) + end if + + ! If we should not output this field, just list it as a mask field + if (output_this_field(idx)) then + field%header%mask_field = .false. + else + field%header%mask_field = .true. + end if + + ! + ! Before actually doing any interpolation to the model grid, we must check + ! whether we will be using the average_gcell interpolator that averages all + ! source points in each model grid cell + ! + do_gcell_interp = .false. + if (index(interp_method(idx),'average_gcell') /= 0) then + + call get_gcell_threshold(interp_method(idx), threshold, istatus) + if (istatus == 0) then + if (fg_data%dx == 0. .and. fg_data%dy == 0. .and. & + fg_data%deltalat /= 0. .and. fg_data%deltalon /= 0.) then + fg_data%dx = abs(fg_data%deltalon) + fg_data%dy = abs(fg_data%deltalat) + else +! BUG: Need to more correctly handle dx/dy in meters. + fg_data%dx = fg_data%dx / 111000. ! Convert meters to approximate degrees + fg_data%dy = fg_data%dy / 111000. + end if + if (gridtype == 'C') then + if (threshold*max(fg_data%dx,fg_data%dy)*111. <= max(dom_dx,dom_dy)/1000.) & + do_gcell_interp = .true. + else if (gridtype == 'E') then + if (threshold*max(fg_data%dx,fg_data%dy) <= max(dom_dx,dom_dy)) & + do_gcell_interp = .true. + end if + end if + end if + + ! Interpolate to U staggering + if (output_stagger(idx) == U) then + + call storage_query_field(field, iqstatus) + if (iqstatus == 0) then + call storage_get_field(field, iqstatus) + call mprintf((iqstatus /= 0),ERROR,'Queried field %s at level %i and found it,'// & + ' but could not get data.',s1=fg_data%field,i1=nint(fg_data%xlvl)) + if (associated(field%modified_mask)) then + call bitarray_destroy(field%modified_mask) + nullify(field%modified_mask) + end if + else + allocate(field%valid_mask) + call bitarray_create(field%valid_mask, we_mem_stag_e-we_mem_stag_s+1, sn_mem_e-sn_mem_s+1) + end if + + ! Save a copy of the fg_input structure for the U field so that we can find it later + if (is_u_field(idx)) call dup(field, u_field) + + allocate(field%modified_mask) + call bitarray_create(field%modified_mask, we_mem_stag_e-we_mem_stag_s+1, sn_mem_e-sn_mem_s+1) + + if (do_const_processing .or. field%header%time_dependent) then + call interp_met_field(input_name, fg_data%field, U, M, & + field, xlat_u, xlon_u, we_mem_stag_s, we_mem_stag_e, sn_mem_s, sn_mem_e, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + halo_slab, 1-bdr_wdth, fg_data%nx+bdr_wdth, 1, fg_data%ny, bdr_wdth, do_gcell_interp, & + field%modified_mask, process_bdy_width) + else + call mprintf(.true.,INFORM,' - already processed this field from constant file.') + end if + + ! Interpolate to V staggering + else if (output_stagger(idx) == V) then + + call storage_query_field(field, iqstatus) + if (iqstatus == 0) then + call storage_get_field(field, iqstatus) + call mprintf((iqstatus /= 0),ERROR,'Queried field %s at level %i and found it,'// & + ' but could not get data.',s1=fg_data%field,i1=nint(fg_data%xlvl)) + if (associated(field%modified_mask)) then + call bitarray_destroy(field%modified_mask) + nullify(field%modified_mask) + end if + else + allocate(field%valid_mask) + call bitarray_create(field%valid_mask, we_mem_e-we_mem_s+1, sn_mem_stag_e-sn_mem_stag_s+1) + end if + + ! Save a copy of the fg_input structure for the V field so that we can find it later + if (is_v_field(idx)) call dup(field, v_field) + + allocate(field%modified_mask) + call bitarray_create(field%modified_mask, we_mem_e-we_mem_s+1, sn_mem_stag_e-sn_mem_stag_s+1) + + if (do_const_processing .or. field%header%time_dependent) then + call interp_met_field(input_name, fg_data%field, V, M, & + field, xlat_v, xlon_v, we_mem_s, we_mem_e, sn_mem_stag_s, sn_mem_stag_e, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + halo_slab, 1-bdr_wdth, fg_data%nx+bdr_wdth, 1, fg_data%ny, bdr_wdth, do_gcell_interp, & + field%modified_mask, process_bdy_width) + else + call mprintf(.true.,INFORM,' - already processed this field from constant file.') + end if + + ! Interpolate to VV staggering + else if (output_stagger(idx) == VV) then + + call storage_query_field(field, iqstatus) + if (iqstatus == 0) then + call storage_get_field(field, iqstatus) + call mprintf((iqstatus /= 0),ERROR,'Queried field %s at level %i and found it,'// & + ' but could not get data.',s1=fg_data%field,i1=nint(fg_data%xlvl)) + if (associated(field%modified_mask)) then + call bitarray_destroy(field%modified_mask) + nullify(field%modified_mask) + end if + else + allocate(field%valid_mask) + call bitarray_create(field%valid_mask, we_mem_e-we_mem_s+1, sn_mem_e-sn_mem_s+1) + end if + + ! Save a copy of the fg_input structure for the U field so that we can find it later + if (is_u_field(idx)) call dup(field, u_field) + + ! Save a copy of the fg_input structure for the V field so that we can find it later + if (is_v_field(idx)) call dup(field, v_field) + + allocate(field%modified_mask) + call bitarray_create(field%modified_mask, we_mem_e-we_mem_s+1, sn_mem_e-sn_mem_s+1) + + if (do_const_processing .or. field%header%time_dependent) then + call interp_met_field(input_name, fg_data%field, VV, M, & + field, xlat_v, xlon_v, we_mem_s, we_mem_e, sn_mem_s, sn_mem_e, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + halo_slab, 1-bdr_wdth, fg_data%nx+bdr_wdth, 1, fg_data%ny, bdr_wdth, do_gcell_interp, & + field%modified_mask, process_bdy_width) + else + call mprintf(.true.,INFORM,' - already processed this field from constant file.') + end if + + ! All other fields interpolated to M staggering for C grid, H staggering for E grid + else + + call storage_query_field(field, iqstatus) + if (iqstatus == 0) then + call storage_get_field(field, iqstatus) + call mprintf((iqstatus /= 0),ERROR,'Queried field %s at level %i and found it,'// & + ' but could not get data.',s1=fg_data%field,i1=nint(fg_data%xlvl)) + if (associated(field%modified_mask)) then + call bitarray_destroy(field%modified_mask) + nullify(field%modified_mask) + end if + else + allocate(field%valid_mask) + call bitarray_create(field%valid_mask, we_mem_e-we_mem_s+1, sn_mem_e-sn_mem_s+1) + end if + + allocate(field%modified_mask) + call bitarray_create(field%modified_mask, we_mem_e-we_mem_s+1, sn_mem_e-sn_mem_s+1) + + if (do_const_processing .or. field%header%time_dependent) then + if (gridtype == 'C') then + call interp_met_field(input_name, fg_data%field, M, M, & + field, xlat, xlon, we_mem_s, we_mem_e, sn_mem_s, sn_mem_e, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + halo_slab, 1-bdr_wdth, fg_data%nx+bdr_wdth, 1, fg_data%ny, bdr_wdth, do_gcell_interp, & + field%modified_mask, process_bdy_width, landmask) + + else if (gridtype == 'E') then + call interp_met_field(input_name, fg_data%field, HH, M, & + field, xlat, xlon, we_mem_s, we_mem_e, sn_mem_s, sn_mem_e, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + halo_slab, 1-bdr_wdth, fg_data%nx+bdr_wdth, 1, fg_data%ny, bdr_wdth, do_gcell_interp, & + field%modified_mask, process_bdy_width, landmask) + end if + else + call mprintf(.true.,INFORM,' - already processed this field from constant file.') + end if + + end if + + call bitarray_merge(field%valid_mask, field%modified_mask) + + deallocate(halo_slab) + + ! Store the interpolated field + call storage_put_field(field) + + call pop_source_projection() + + end if + end do + + call read_met_close() + + call push_source_projection(fg_data%iproj, fg_data%xlonc, fg_data%truelat1, & + fg_data%truelat2, fg_data%dx, fg_data%dy, fg_data%deltalat, & + fg_data%deltalon, fg_data%starti, fg_data%startj, & + fg_data%startlat, fg_data%startlon, & + fg_data%pole_lat, fg_data%pole_lon, & + fg_data%centerlat, fg_data%centerlon, & + real(fg_data%nx+1)/2., real(fg_data%ny+1)/2., & + earth_radius=fg_data%earth_radius*1000.) + + ! + ! If necessary, rotate winds to earth-relative for this fg source + ! + + call storage_get_levels(u_field, u_levels) + call storage_get_levels(v_field, v_levels) + + if (associated(u_levels) .and. associated(v_levels)) then + u_idx = 1 + do u_idx = 1, size(u_levels) + u_field%header%vertical_level = u_levels(u_idx) + call storage_get_field(u_field, istatus) + v_field%header%vertical_level = v_levels(u_idx) + call storage_get_field(v_field, istatus) + + if (associated(u_field%modified_mask) .and. & + associated(v_field%modified_mask)) then + + if (u_field%header%is_wind_grid_rel) then + if (gridtype == 'C') then + call map_to_met(u_field%r_arr, u_field%modified_mask, & + v_field%r_arr, v_field%modified_mask, & + we_mem_stag_s, sn_mem_s, & + we_mem_stag_e, sn_mem_e, & + we_mem_s, sn_mem_stag_s, & + we_mem_e, sn_mem_stag_e, & + xlon_u, xlon_v, xlat_u, xlat_v) + else if (gridtype == 'E') then + call map_to_met_nmm(u_field%r_arr, u_field%modified_mask, & + v_field%r_arr, v_field%modified_mask, & + we_mem_s, sn_mem_s, & + we_mem_e, sn_mem_e, & + xlat_v, xlon_v) + end if + end if + + call bitarray_destroy(u_field%modified_mask) + call bitarray_destroy(v_field%modified_mask) + nullify(u_field%modified_mask) + nullify(v_field%modified_mask) + call storage_put_field(u_field) + call storage_put_field(v_field) + end if + + end do + + deallocate(u_levels) + deallocate(v_levels) + + end if + + call pop_source_projection() + + else + if (do_const_processing) then + call mprintf(.true.,WARN,'Couldn''t open file %s for input.',s1=input_name) + else + call mprintf(.true.,WARN,'Couldn''t open file %s for input.',s1=trim(input_name)//':'//trim(temp_date)) + end if + end if + + end subroutine process_intermediate_fields + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: process_mpas_fields + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine process_mpas_fields(input_name, do_const_processing, temp_date, fg_data, got_this_field, & + landmask, process_bdy_width, & + u_field, v_field, & + dom_dx, dom_dy, & + xlat, xlon, xlat_u, xlon_u, xlat_v, xlon_v, & + output_flags, west_east_dim, south_north_dim, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e ) + + use bitarray_module + use gridinfo_module + use interp_module + use interp_option_module + use read_met_module + use llxy_module + use misc_definitions_module + use module_debug + use output_module + use parallel_module + use rotate_winds_module + use storage_module + use scan_input + use mpas_mesh + + implicit none + +! BUG: Move this constant to misc_definitions_module? +integer, parameter :: BDR_WIDTH = 3 + + character (len=*), intent(inout) :: input_name + logical, intent(in) :: do_const_processing + character (len=*), intent(in) :: temp_date + type (met_data), intent(inout) :: fg_data + logical, dimension(:), intent(inout) :: got_this_field + real, pointer, dimension(:,:) :: landmask + integer, intent(in) :: process_bdy_width + type (fg_input), intent(inout) :: u_field, v_field + character (len=128), dimension(:), intent(inout) :: output_flags + real, intent(in) :: dom_dx, dom_dy + real, pointer, dimension(:,:) :: xlat, xlon, xlat_u, xlon_u, xlat_v, xlon_v + integer, intent(in) :: west_east_dim, south_north_dim, & + we_domain_s, we_domain_e, sn_domain_s, sn_domain_e, & + we_patch_s, we_patch_e, we_patch_stag_s, we_patch_stag_e, & + sn_patch_s, sn_patch_e, sn_patch_stag_s, sn_patch_stag_e, & + we_mem_s, we_mem_e, we_mem_stag_s, we_mem_stag_e, & + sn_mem_s, sn_mem_e, sn_mem_stag_s, sn_mem_stag_e + + real, parameter :: deg2rad = asin(1.0) / 90.0 + + integer :: i, j, k + integer :: idx + integer :: istat + integer :: strlen + character (len=MAX_FILENAME_LEN) :: mpas_filename + integer :: nRecords + type (input_handle_type) :: mpas_handle + type (input_field_type) :: mpas_field + type (target_field_type) :: wrf_field + type (fg_input) :: field_to_store + + strlen = len_trim(input_name) + if (do_const_processing) then + write(mpas_filename,'(a)') input_name(6:strlen) + else + write(mpas_filename,'(a)') input_name(6:strlen)//'.'//trim(temp_date)//'.nc' + end if + call mprintf(.true.,LOGFILE,'Processing MPAS fields from file %s',s1=mpas_filename) + + ! + ! If we do not already have mesh information, get that now... + ! + if (.not. mpas_source_mesh % valid) then + if (mpas_mesh_setup(mpas_filename, mpas_source_mesh) /= 0) then + call mprintf(.true.,ERROR, 'Error setting up MPAS mesh %s with scan_input_open', s1=mpas_filename) + end if + end if + + ! + ! If we have not already defined the WRF grid, do that now... + ! + if (.not. wrf_target_mesh_m % valid) then + allocate(xlat_rad(size(xlat,1), size(xlat,2))) + allocate(xlon_rad(size(xlat,1), size(xlat,2))) + xlat_rad(:,:) = xlat(:,:) * deg2rad + xlon_rad(:,:) = xlon(:,:) * deg2rad + call mprintf(.true.,LOGFILE,'Need to set up WRF target mass-grid') + if (target_mesh_setup(wrf_target_mesh_m, lat2d=xlat_rad, lon2d=xlon_rad) /= 0) then + call mprintf(.true.,ERROR, 'Error setting up WRF target grid') + end if + + call mprintf(.true.,LOGFILE,'Also computing remapping weights...') + if (remap_info_setup(mpas_source_mesh, wrf_target_mesh_m, remap_info_m) /= 0) then + call mprintf(.true.,ERROR, 'Error computing remapping weights from MPAS to WRF grid') + end if + else + call mprintf(.true.,LOGFILE,'Already set up WRF target mass-grid') + end if + + if (.not. wrf_target_mesh_u % valid) then + allocate(xlat_u_rad(size(xlat_u,1), size(xlat_u,2))) + allocate(xlon_u_rad(size(xlat_u,1), size(xlat_u,2))) + xlat_u_rad(:,:) = xlat_u(:,:) * deg2rad + xlon_u_rad(:,:) = xlon_u(:,:) * deg2rad + call mprintf(.true.,LOGFILE,'Need to set up WRF target U-grid') + if (target_mesh_setup(wrf_target_mesh_u, lat2d=xlat_u_rad, lon2d=xlon_u_rad) /= 0) then + call mprintf(.true.,ERROR, 'Error setting up WRF target grid') + end if + + call mprintf(.true.,LOGFILE,'Also computing remapping weights...') + if (remap_info_setup(mpas_source_mesh, wrf_target_mesh_u, remap_info_u) /= 0) then + call mprintf(.true.,ERROR, 'Error computing remapping weights from MPAS to WRF grid') + end if + else + call mprintf(.true.,LOGFILE,'Already set up WRF target U-grid') + end if + + if (.not. wrf_target_mesh_v % valid) then + allocate(xlat_v_rad(size(xlat_v,1), size(xlat_v,2))) + allocate(xlon_v_rad(size(xlat_v,1), size(xlat_v,2))) + xlat_v_rad(:,:) = xlat_v(:,:) * deg2rad + xlon_v_rad(:,:) = xlon_v(:,:) * deg2rad + call mprintf(.true.,LOGFILE,'Need to set up WRF target V-grid') + if (target_mesh_setup(wrf_target_mesh_v, lat2d=xlat_v_rad, lon2d=xlon_v_rad) /= 0) then + call mprintf(.true.,ERROR, 'Error setting up WRF target grid') + end if + + call mprintf(.true.,LOGFILE,'Also computing remapping weights...') + if (remap_info_setup(mpas_source_mesh, wrf_target_mesh_v, remap_info_v) /= 0) then + call mprintf(.true.,ERROR, 'Error computing remapping weights from MPAS to WRF grid') + end if + else + call mprintf(.true.,LOGFILE,'Already set up WRF target V-grid') + end if + + + if (scan_input_open(mpas_filename, mpas_handle, nRecords) /= 0) then + call mprintf(.true.,ERROR, 'Error opening %s with scan_input_open', s1=mpas_filename) + end if + + + ! Initialize fg_input structure to store the field + field_to_store%header%version = 1 + field_to_store%header%date = '?' + if (do_const_processing) then + field_to_store%header%time_dependent = .false. + field_to_store%header%constant_field = .true. + else + field_to_store%header%time_dependent = .true. + field_to_store%header%constant_field = .false. + end if + field_to_store%header%forecast_hour = 0.0 + field_to_store%header%fg_source = 'MPAS' + field_to_store%header%field = ' ' + field_to_store%header%field(1:9) = '?' + field_to_store%header%units = ' ' + field_to_store%header%units(1:25) = '?' + field_to_store%header%description = ' ' + field_to_store%header%description(1:46) = '?' + field_to_store%header%vertical_coord = 'z_dim_name' + field_to_store%header%vertical_level = 0 + field_to_store%header%sr_x = 1 + field_to_store%header%sr_y = 1 + field_to_store%header%array_order = 'XY ' + field_to_store%header%is_wind_grid_rel = .false. + field_to_store%header%array_has_missing_values = .false. + nullify(field_to_store%r_arr) + nullify(field_to_store%valid_mask) + nullify(field_to_store%modified_mask) + + ! If we should not output this field, just list it as a mask field +!??? if (output_this_field(idx)) then + field_to_store%header%mask_field = .false. +!??? else +!??? field%header%mask_field = .true. +!??? end if + + + do while (scan_input_next_field(mpas_handle, mpas_field) == 0) + + if (can_remap_field(mpas_field)) then + + ! Here, rename a few MPAS fields that would be difficult to treat + ! with METGRID.TBL options; principally, these are surface fields + ! that have different names from their upper-air counterparts. + if (trim(mpas_field % name) == 'u10') then + mpas_field % name = 'uReconstructZonal' + else if (trim(mpas_field % name) == 'v10') then + mpas_field % name = 'uReconstructMeridional' + else if (trim(mpas_field % name) == 'q2') then + mpas_field % name = 'qv' + else if (trim(mpas_field % name) == 't2m') then + mpas_field % name = 'theta' + end if + + ! Mark this MPAS field as "gotten" for any later checks + ! on mandatory fields + idx = mpas_name_to_idx(trim(mpas_field % name)) + if (idx > 0) then + got_this_field(idx) = .true. + if (output_this_field(idx) .and. flag_in_output(idx) /= ' ') then + output_flags(idx) = flag_in_output(idx) + end if + else + istat = scan_input_free_field(mpas_field) + cycle + end if + + istat = scan_input_read_field(mpas_field, frame=1) + + field_to_store%map%stagger = mpas_output_stagger(mpas_field % name) + if (field_to_store%map%stagger == M) then + field_to_store%header%dim1(1) = we_mem_s + field_to_store%header%dim1(2) = we_mem_e + field_to_store%header%dim2(1) = sn_mem_s + field_to_store%header%dim2(2) = sn_mem_e + if (idx > 0) then + if (masked(idx) == MASKED_WATER) then + istat = remap_field(remap_info_m, mpas_field, wrf_field, masked=.true.) + else + istat = remap_field(remap_info_m, mpas_field, wrf_field, masked=.false.) + end if + else + istat = remap_field(remap_info_m, mpas_field, wrf_field, masked=.false.) + end if + else if (field_to_store%map%stagger == U) then + field_to_store%header%dim1(1) = we_mem_stag_s + field_to_store%header%dim1(2) = we_mem_stag_e + field_to_store%header%dim2(1) = sn_mem_s + field_to_store%header%dim2(2) = sn_mem_e + istat = remap_field(remap_info_u, mpas_field, wrf_field) + else if (field_to_store%map%stagger == V) then + field_to_store%header%dim1(1) = we_mem_s + field_to_store%header%dim1(2) = we_mem_e + field_to_store%header%dim2(1) = sn_mem_stag_s + field_to_store%header%dim2(2) = sn_mem_stag_e + istat = remap_field(remap_info_v, mpas_field, wrf_field) + else + call mprintf(.true.,ERROR, 'Cannot handle requested output stagger %i for MPAS field %s ...', & + i1=field_to_store%map%stagger, s1=trim(mpas_field % name)) + end if + + if (wrf_field % ndims == 3 .and. trim(wrf_field % dimnames(1)) == 'nVertLevels') then ! 3-d MPAS atmosphere field + field_to_store % header % field = mpas_to_intermediate_name(mpas_field % name) + + ! If no match in the METGRID.TBL was found for this MPAS field, just use the MPAS name + if (len_trim(field_to_store % header % field) == 0) then + field_to_store % header % field = trim(mpas_field % name) + end if + + field_to_store % header % vertical_coord = 'num_mpas_levels' + do k=1,wrf_field % dimlens(1) + allocate(field_to_store % r_arr(wrf_field % dimlens(2), wrf_field % dimlens(3))) + allocate(field_to_store % valid_mask) + call bitarray_create(field_to_store % valid_mask, wrf_field % dimlens(2), wrf_field % dimlens(3)) + do j=1,wrf_field % dimlens(3) + do i=1,wrf_field % dimlens(2) + call bitarray_set(field_to_store % valid_mask, i, j) + end do + end do + field_to_store % header % vertical_level = k + + if (wrf_field % xtype == FIELD_TYPE_REAL) then + field_to_store % r_arr(:,:) = wrf_field % array3r(k,:,:) + else if (wrf_field % xtype == FIELD_TYPE_DOUBLE) then + field_to_store % r_arr(:,:) = wrf_field % array3d(k,:,:) + end if + + ! The u_field and v_field are used later by calling code to + ! determine which fields represent the x- and y-components of + ! horizonal wind velocity for the purposes of wind rotation + if (trim(mpas_field % name) == 'uReconstructZonal') then + call dup(field_to_store, u_field) + end if + if (trim(mpas_field % name) == 'uReconstructMeridional') then + call dup(field_to_store, v_field) + end if + + call storage_put_field(field_to_store) + end do + + else if (wrf_field % ndims == 3 .and. trim(wrf_field % dimnames(1)) == 'nVertLevelsP1') then ! 3-d MPAS atmosphere field + field_to_store % header % field = mpas_to_intermediate_name(mpas_field % name) + + ! If no match in the METGRID.TBL was found for this MPAS field, just use the MPAS name + if (len_trim(field_to_store % header % field) == 0) then + field_to_store % header % field = trim(mpas_field % name) + end if + + ! Handle surface level + field_to_store % header % vertical_coord = 'none' + allocate(field_to_store % r_arr(wrf_field % dimlens(2), wrf_field % dimlens(3))) + allocate(field_to_store % valid_mask) + call bitarray_create(field_to_store % valid_mask, wrf_field % dimlens(2), wrf_field % dimlens(3)) + do j=1,wrf_field % dimlens(3) + do i=1,wrf_field % dimlens(2) + call bitarray_set(field_to_store % valid_mask, i, j) + end do + end do + field_to_store % header % vertical_level = 200100.0 + + if (wrf_field % xtype == FIELD_TYPE_REAL) then + field_to_store % r_arr(:,:) = wrf_field % array3r(1,:,:) + else if (wrf_field % xtype == FIELD_TYPE_DOUBLE) then + field_to_store % r_arr(:,:) = wrf_field % array3d(1,:,:) + end if + + call storage_put_field(field_to_store) + + ! Handle all other layers + field_to_store % header % vertical_coord = 'num_mpas_levels' + do k=1,wrf_field % dimlens(1) - 1 + allocate(field_to_store % r_arr(wrf_field % dimlens(2), wrf_field % dimlens(3))) + allocate(field_to_store % valid_mask) + call bitarray_create(field_to_store % valid_mask, wrf_field % dimlens(2), wrf_field % dimlens(3)) + do j=1,wrf_field % dimlens(3) + do i=1,wrf_field % dimlens(2) + call bitarray_set(field_to_store % valid_mask, i, j) + end do + end do + field_to_store % header % vertical_level = k + + ! Average to layer midpoint + if (wrf_field % xtype == FIELD_TYPE_REAL) then + field_to_store % r_arr(:,:) = 0.5 * (wrf_field % array3r(k,:,:) + wrf_field % array3r(k+1,:,:)) + else if (wrf_field % xtype == FIELD_TYPE_DOUBLE) then + field_to_store % r_arr(:,:) = 0.5 * (wrf_field % array3d(k,:,:) + wrf_field % array3d(k+1,:,:)) + end if + + call storage_put_field(field_to_store) + end do + + ! Special case: zgrid field also provides SOILHGT + if (trim(mpas_field % name) == 'zgrid') then + field_to_store % header % field = 'SOILHGT' + + allocate(field_to_store % r_arr(wrf_field % dimlens(2), wrf_field % dimlens(3))) + allocate(field_to_store % valid_mask) + call bitarray_create(field_to_store % valid_mask, wrf_field % dimlens(2), wrf_field % dimlens(3)) + do j=1,wrf_field % dimlens(3) + do i=1,wrf_field % dimlens(2) + call bitarray_set(field_to_store % valid_mask, i, j) + end do + end do + field_to_store % header % vertical_level = 200100.0 + + if (wrf_field % xtype == FIELD_TYPE_REAL) then + field_to_store % r_arr(:,:) = wrf_field % array3r(1,:,:) + else if (wrf_field % xtype == FIELD_TYPE_DOUBLE) then + field_to_store % r_arr(:,:) = wrf_field % array3d(1,:,:) + end if + + call storage_put_field(field_to_store) + + do idx=1,num_entries + if (trim(fieldname(idx)) == 'SOILHGT') then + got_this_field(idx) = .true. + if (output_this_field(idx) .and. flag_in_output(idx) /= ' ') then + output_flags(idx) = flag_in_output(idx) + end if + exit + end if + end do + end if + + else if (wrf_field % ndims == 3 .and. trim(wrf_field % dimnames(1)) == 'nSoilLevels') then ! 3-d MPAS soil field + + field_to_store % header % vertical_coord = 'none' + if (trim(mpas_field % name) == 'tslb') then + do k=1,wrf_field % dimlens(1) + if (k == 1) then + field_to_store % header % field = 'ST000010' + else if (k == 2) then + field_to_store % header % field = 'ST010040' + else if (k == 3) then + field_to_store % header % field = 'ST040100' + else if (k == 4) then + field_to_store % header % field = 'ST100200' + else + call mprintf(.true.,ERROR, 'Too many soil layers in MPAS soil field %s ...', s1=trim(mpas_field % name)) + end if + allocate(field_to_store % r_arr(wrf_field % dimlens(2), wrf_field % dimlens(3))) + allocate(field_to_store % valid_mask) + call bitarray_create(field_to_store % valid_mask, wrf_field % dimlens(2), wrf_field % dimlens(3)) + do j=1,wrf_field % dimlens(3) + do i=1,wrf_field % dimlens(2) + call bitarray_set(field_to_store % valid_mask, i, j) + end do + end do + field_to_store % header % vertical_level = 200100.0 + + if (wrf_field % xtype == FIELD_TYPE_REAL) then + field_to_store % r_arr(:,:) = wrf_field % array3r(k,:,:) + else if (wrf_field % xtype == FIELD_TYPE_DOUBLE) then + field_to_store % r_arr(:,:) = wrf_field % array3d(k,:,:) + end if + + if (idx > 0) then + if (masked(idx) == MASKED_WATER) then + where (landmask(:,:) == 0) field_to_store % r_arr(:,:) = fill_missing(idx) + end if + end if + + call storage_put_field(field_to_store) + end do + else if (trim(mpas_field % name) == 'smois') then + do k=1,wrf_field % dimlens(1) + if (k == 1) then + field_to_store % header % field = 'SM000010' + else if (k == 2) then + field_to_store % header % field = 'SM010040' + else if (k == 3) then + field_to_store % header % field = 'SM040100' + else if (k == 4) then + field_to_store % header % field = 'SM100200' + else + call mprintf(.true.,ERROR, 'Too many soil layers in MPAS soil field %s ...', s1=trim(mpas_field % name)) + end if + allocate(field_to_store % r_arr(wrf_field % dimlens(2), wrf_field % dimlens(3))) + allocate(field_to_store % valid_mask) + call bitarray_create(field_to_store % valid_mask, wrf_field % dimlens(2), wrf_field % dimlens(3)) + do j=1,wrf_field % dimlens(3) + do i=1,wrf_field % dimlens(2) + call bitarray_set(field_to_store % valid_mask, i, j) + end do + end do + field_to_store % header % vertical_level = 200100.0 + + if (wrf_field % xtype == FIELD_TYPE_REAL) then + field_to_store % r_arr(:,:) = wrf_field % array3r(k,:,:) + else if (wrf_field % xtype == FIELD_TYPE_DOUBLE) then + field_to_store % r_arr(:,:) = wrf_field % array3d(k,:,:) + end if + + if (idx > 0) then + if (masked(idx) == MASKED_WATER) then + where (landmask(:,:) == 0) field_to_store % r_arr(:,:) = fill_missing(idx) + end if + end if + + call storage_put_field(field_to_store) + end do + else + call mprintf(.true.,WARN, 'Skipping unknown MPAS soil field %s ...', s1=trim(mpas_field % name)) + end if + + else if (wrf_field % ndims == 2) then ! 2-d MPAS field + field_to_store % header % field = mpas_to_intermediate_name(mpas_field % name) + + ! If no match in the METGRID.TBL was found for this MPAS field, just use the MPAS name + if (len_trim(field_to_store % header % field) == 0) then + field_to_store % header % field = trim(mpas_field % name) + end if + + field_to_store % header % vertical_coord = 'none' + allocate(field_to_store % r_arr(wrf_field % dimlens(1), wrf_field % dimlens(2))) + allocate(field_to_store % valid_mask) + call bitarray_create(field_to_store % valid_mask, wrf_field % dimlens(1), wrf_field % dimlens(2)) + do j=1,wrf_field % dimlens(2) + do i=1,wrf_field % dimlens(1) + call bitarray_set(field_to_store % valid_mask, i, j) + end do + end do + field_to_store % header % vertical_level = 200100.0 + + if (wrf_field % xtype == FIELD_TYPE_REAL) then + field_to_store % r_arr(:,:) = wrf_field % array2r(:,:) + else if (wrf_field % xtype == FIELD_TYPE_DOUBLE) then + field_to_store % r_arr(:,:) = wrf_field % array2d(:,:) + end if + + if (idx > 0) then + if (masked(idx) == MASKED_WATER) then + where (landmask(:,:) == 0) field_to_store % r_arr(:,:) = fill_missing(idx) + end if + end if + + call storage_put_field(field_to_store) + end if + + istat = free_target_field(wrf_field) + end if + + istat = scan_input_free_field(mpas_field) + end do + + if (scan_input_close(mpas_handle) /= 0) then + call mprintf(.true.,ERROR, 'Error closing %s with scan_input_close', s1=mpas_filename) + end if + + end subroutine process_mpas_fields + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: derive_mpas_fields + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine derive_mpas_fields() + + use bitarray_module + use gridinfo_module + use interp_module + use interp_option_module + use read_met_module + use llxy_module + use misc_definitions_module + use module_debug + use output_module + use parallel_module + use rotate_winds_module + use storage_module + use scan_input + use mpas_mesh + use constants_module + + implicit none + + integer :: k + integer :: istatus + integer, pointer, dimension(:) :: theta_levels => null() + integer, pointer, dimension(:) :: pressure_levels => null() + real, pointer, dimension(:,:) :: exner => null() + type (fg_input) :: theta_field + type (fg_input) :: pressure_field + + ! + ! Derive TT from theta and pressure + ! + theta_field%header%time_dependent = .true. + theta_field%header%constant_field = .false. + theta_field%header%field = 'TT' + theta_field%header%vertical_level = 0 + nullify(theta_field%r_arr) + nullify(theta_field%valid_mask) + nullify(theta_field%modified_mask) + + pressure_field%header%time_dependent = .true. + pressure_field%header%constant_field = .false. + pressure_field%header%field = 'PRESSURE' + pressure_field%header%vertical_level = 0 + nullify(pressure_field%r_arr) + nullify(pressure_field%valid_mask) + nullify(pressure_field%modified_mask) + + call storage_get_levels(theta_field, theta_levels) + call storage_get_levels(pressure_field, pressure_levels) + + if (associated(theta_levels) .and. associated(pressure_levels)) then +! call mprintf(.true.,LOGFILE, 'Computing MPAS TT field from theta and pressure...') + + if (size(theta_levels) == size(pressure_levels)) then + do k = 1, size(theta_levels) + theta_field % header % vertical_level = theta_levels(k) + call storage_get_field(theta_field, istatus) + if (trim(theta_field % header % fg_source) /= 'MPAS') then + cycle + end if + if (istatus /= 0) then + call mprintf(.true.,ERROR, 'Could not get MPAS theta field at level %i', i1=theta_levels(k)) + return + end if + + pressure_field % header % vertical_level = pressure_levels(k) + call storage_get_field(pressure_field, istatus) + if (trim(pressure_field % header % fg_source) /= 'MPAS') then + cycle + end if + if (istatus /= 0) then + call mprintf(.true.,ERROR, 'Could not get MPAS pressure field at level %i', i1=theta_levels(k)) + return + end if + + ! Compute temperature + call mprintf(.true.,LOGFILE, 'Computing TT at level %i for MPAS dataset', i1=theta_levels(k)) + if (.not. associated(exner)) then + allocate(exner(size(theta_field % r_arr, 1), size(theta_field % r_arr, 2))) + end if + exner(:,:) = (pressure_field % r_arr(:,:) / P0)**(RD/CP) + theta_field % r_arr(:,:) = theta_field % r_arr(:,:) * exner(:,:) + + call storage_put_field(theta_field) + end do +! else +! call mprintf(.true.,ERROR, 'The MPAS theta and pressure fields do not have the same number of levels!') + end if + + deallocate(theta_levels) + deallocate(pressure_levels) + if (associated(exner)) then + deallocate(exner) + end if + end if + + end subroutine derive_mpas_fields + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_interp_masks + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_interp_masks(fg_prefix, is_constants, fg_date) + + use interp_option_module + use read_met_module + use storage_module + + implicit none + + ! Arguments + logical, intent(in) :: is_constants + character (len=*), intent(in) :: fg_prefix, fg_date + +! BUG: Move this constant to misc_definitions_module? +integer, parameter :: BDR_WIDTH = 3 + + ! Local variables + integer :: i, istatus, idx, idxt + type (fg_input) :: mask_field + type (met_data) :: fg_data + + istatus = 0 + + call read_met_init(fg_prefix, is_constants, fg_date, istatus) + + do while (istatus == 0) + + call read_next_met_field(fg_data, istatus) + + if (istatus == 0) then + + ! Find out which METGRID.TBL entry goes with this field + idxt = num_entries + 1 + do idx=1,num_entries + if ((index(fieldname(idx), trim(fg_data%field)) /= 0) .and. & + (len_trim(fieldname(idx)) == len_trim(fg_data%field))) then + + if (index(fg_prefix,trim(from_input(idx))) /= 0 .or. & + (from_input(idx) == '*' .and. idxt == num_entries + 1)) then + idxt = idx + end if + + end if + end do + idx = idxt + if (idx > num_entries) idx = num_entries ! The last entry is a default + + ! Do we need to rename this field? + if (output_name(idx) /= ' ') then + fg_data%field = output_name(idx)(1:9) + + idxt = num_entries + 1 + do idx=1,num_entries + if ((index(fieldname(idx), trim(fg_data%field)) /= 0) .and. & + (len_trim(fieldname(idx)) == len_trim(fg_data%field))) then + + if (index(fg_prefix,trim(from_input(idx))) /= 0 .or. & + (from_input(idx) == '*' .and. idxt == num_entries + 1)) then + idxt = idx + end if + + end if + end do + idx = idxt + if (idx > num_entries) idx = num_entries ! The last entry is a default + end if + + do i=1,num_entries + if (interp_mask(i) /= ' ' .and. (trim(interp_mask(i)) == trim(fg_data%field))) then + + mask_field%header%version = 1 + mask_field%header%date = ' ' + mask_field%header%date = fg_date + if (is_constants) then + mask_field%header%time_dependent = .false. + mask_field%header%constant_field = .true. + else + mask_field%header%time_dependent = .true. + mask_field%header%constant_field = .false. + end if + mask_field%header%mask_field = .true. + mask_field%header%forecast_hour = 0. + mask_field%header%fg_source = 'degribbed met data' + mask_field%header%field = trim(fg_data%field)//'.mask' + mask_field%header%units = '-' + mask_field%header%description = '-' + mask_field%header%vertical_coord = 'none' + mask_field%header%vertical_level = 1 + mask_field%header%sr_x = 1 + mask_field%header%sr_y = 1 + mask_field%header%array_order = 'XY' + mask_field%header%dim1(1) = 1 + mask_field%header%dim1(2) = fg_data%nx + mask_field%header%dim2(1) = 1 + mask_field%header%dim2(2) = fg_data%ny + mask_field%header%is_wind_grid_rel = .true. + mask_field%header%array_has_missing_values = .false. + mask_field%map%stagger = M + + ! Do a simple check to see whether this is a global lat/lon dataset + ! Note that we do not currently support regional Gaussian grids + if ((fg_data%iproj == PROJ_LATLON .and. abs(fg_data%nx * fg_data%deltalon - 360.) < 0.0001) & + .or. (fg_data%iproj == PROJ_GAUSS)) then + allocate(mask_field%r_arr(1-BDR_WIDTH:fg_data%nx+BDR_WIDTH,1:fg_data%ny)) + + mask_field%r_arr(1:fg_data%nx, 1:fg_data%ny) = & + fg_data%slab(1:fg_data%nx, 1:fg_data%ny) + + mask_field%r_arr(1-BDR_WIDTH:0, 1:fg_data%ny) = & + fg_data%slab(fg_data%nx-BDR_WIDTH+1:fg_data%nx, 1:fg_data%ny) + + mask_field%r_arr(fg_data%nx+1:fg_data%nx+BDR_WIDTH, 1:fg_data%ny) = & + fg_data%slab(1:BDR_WIDTH, 1:fg_data%ny) + + else + allocate(mask_field%r_arr(1:fg_data%nx,1:fg_data%ny)) + mask_field%r_arr = fg_data%slab + end if + + nullify(mask_field%valid_mask) + nullify(mask_field%modified_mask) + + call storage_put_field(mask_field) + + exit + + end if + end do + + if (associated(fg_data%slab)) deallocate(fg_data%slab) + + end if + + end do + + call read_met_close() + + end subroutine get_interp_masks + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: interp_met_field + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine interp_met_field(input_name, short_fieldnm, ifieldstagger, istagger, & + field, xlat, xlon, sm1, em1, sm2, em2, & + sd1, ed1, sd2, ed2, & + slab, minx, maxx, miny, maxy, bdr, do_gcell_interp, & + new_pts, process_bdy_width, landmask) + + use bitarray_module + use interp_module + use interp_option_module + use llxy_module + use misc_definitions_module + use storage_module + + implicit none + + ! Arguments + integer, intent(in) :: ifieldstagger, istagger, & + sm1, em1, sm2, em2, & + sd1, ed1, sd2, ed2, & + minx, maxx, miny, maxy, bdr, & + process_bdy_width + real, dimension(minx:maxx,miny:maxy), intent(in) :: slab + real, dimension(sm1:em1,sm2:em2), intent(in) :: xlat, xlon + real, dimension(sm1:em1,sm2:em2), intent(in), optional :: landmask + logical, intent(in) :: do_gcell_interp + character (len=9), intent(in) :: short_fieldnm + character (len=MAX_FILENAME_LEN), intent(in) :: input_name + type (fg_input), intent(inout) :: field + type (bitarray), intent(inout) :: new_pts + + ! Local variables + integer :: i, j, idx, idxt, orig_selected_proj, interp_mask_status, & + interp_land_mask_status, interp_water_mask_status, process_width + integer, pointer, dimension(:) :: interp_array, interp_opts + real :: rx, ry, temp + real, pointer, dimension(:,:) :: data_count + type (fg_input) :: mask_field, mask_water_field, mask_land_field + !BPR BEGIN + real, dimension(sm1:em1,sm2:em2) :: r_arr_cur_source + !BPR END + + ! CWH Initialize local pointer variables + nullify(interp_array) + nullify(interp_opts) + nullify(data_count) + + ! Find index into fieldname, interp_method, masked, and fill_missing + ! of the current field + idxt = num_entries + 1 + do idx=1,num_entries + if ((index(fieldname(idx), trim(short_fieldnm)) /= 0) .and. & + (len_trim(fieldname(idx)) == len_trim(short_fieldnm))) then + if (index(input_name,trim(from_input(idx))) /= 0 .or. & + (from_input(idx) == '*' .and. idxt == num_entries + 1)) then + idxt = idx + end if + end if + end do + idx = idxt + if (idx > num_entries) then + call mprintf(.true.,WARN,'Entry in METGRID.TBL not found for field %s. '// & + 'Default options will be used for this field!', s1=short_fieldnm) + idx = num_entries ! The last entry is a default + end if + + if (process_bdy_width == 0) then + process_width = max(ed1-sd1+1, ed2-sd2+1) + else + process_width = process_bdy_width + ! Add two extra rows/cols to accommodate staggered fields: one extra row/col for + ! averaging to mass points in real, and one beyond that for averaging during + ! wind rotation + if (ifieldstagger /= M) process_width = process_width + 2 + end if + + field%header%dim1(1) = sm1 + field%header%dim1(2) = em1 + field%header%dim2(1) = sm2 + field%header%dim2(2) = em2 + field%map%stagger = ifieldstagger + if (.not. associated(field%r_arr)) then + allocate(field%r_arr(sm1:em1,sm2:em2)) + end if + + interp_mask_status = 1 + interp_land_mask_status = 1 + interp_water_mask_status = 1 + + if (interp_mask(idx) /= ' ') then + mask_field%header%version = 1 + mask_field%header%forecast_hour = 0. + mask_field%header%field = trim(interp_mask(idx))//'.mask' + mask_field%header%vertical_coord = 'none' + mask_field%header%vertical_level = 1 + + call storage_get_field(mask_field, interp_mask_status) + + end if + if (interp_land_mask(idx) /= ' ') then + mask_land_field%header%version = 1 + mask_land_field%header%forecast_hour = 0. + mask_land_field%header%field = trim(interp_land_mask(idx))//'.mask' + mask_land_field%header%vertical_coord = 'none' + mask_land_field%header%vertical_level = 1 + + call storage_get_field(mask_land_field, interp_land_mask_status) + + end if + if (interp_water_mask(idx) /= ' ') then + mask_water_field%header%version = 1 + mask_water_field%header%forecast_hour = 0. + mask_water_field%header%field = trim(interp_water_mask(idx))//'.mask' + mask_water_field%header%vertical_coord = 'none' + mask_water_field%header%vertical_level = 1 + + call storage_get_field(mask_water_field, interp_water_mask_status) + + end if + + interp_array => interp_array_from_string(interp_method(idx)) + interp_opts => interp_options_from_string(interp_method(idx)) + + + ! + ! Interpolate using average_gcell interpolation method + ! + if (do_gcell_interp) then + !BPR BEGIN + !If a lower priority source of the current field has already been read + !in, the results of that input are currently in field%r_arr + !Pass COPY of field%r_arr into accum_continous because in accum_continuous + !it will set the input variable to zero over points covered by the + !current source and then determine the appropriate value to place at + !that point. This will overwrite data already put in field%r_arr by + !lower priority sources. + !This is problematic if the current source results in missing values + !over parts of the area covered by the current source where a lower + !priority source has already provided a value. In this case, if one + !passes in field%r_arr, it will overwrite the value provided by the + !lower priority source with zero. + r_arr_cur_source = field%r_arr + !BPR END + allocate(data_count(sm1:em1,sm2:em2)) + data_count = 0. + + if (interp_mask_status == 0) then + call accum_continuous(slab, & + minx, maxx, miny, maxy, 1, 1, bdr, & + !BPR BEGIN + !Pass COPY of field%r_arr instead of field%r_arr itself + !field%r_arr, data_count, & + r_arr_cur_source, data_count, & + !BPR END + sm1, em1, sm2, em2, 1, 1, & + istagger, & + new_pts, missing_value(idx), interp_mask_val(idx), interp_mask_relational(idx), mask_field%r_arr) + else + call accum_continuous(slab, & + minx, maxx, miny, maxy, 1, 1, bdr, & + !BPR BEGIN + !Pass COPY of field%r_arr instead of field%r_arr itself + !field%r_arr, data_count, & + r_arr_cur_source, data_count, & + !BPR END + sm1, em1, sm2, em2, 1, 1, & + istagger, & + new_pts, missing_value(idx), -1.) ! The -1 is the maskval, but since we + ! we do not give an optional mask, no + ! no need to worry about -1s in data + end if + + orig_selected_proj = iget_selected_domain() + call select_domain(SOURCE_PROJ) + do j=sm2,em2 + do i=sm1,em1 + + if (abs(i - sd1) >= process_width .and. (abs(i - ed1) >= process_width) .and. & + abs(j - sd2) >= process_width .and. (abs(j - ed2) >= process_width)) then + field%r_arr(i,j) = fill_missing(idx) + call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + cycle + end if + + if (present(landmask)) then + + if (landmask(i,j) /= masked(idx)) then + if (data_count(i,j) > 0.) then + !BPR BEGIN + !accum_continuous is now passed a copy of field%r_arr (r_arr_cur_source) + !instead of field%r_arr itself so that it does not set + !field%r_arr to zero where the input source is marked as missing + !field%r_arr(i,j) = field%r_arr(i,j) / data_count(i,j) + field%r_arr(i,j) = r_arr_cur_source(i,j) / data_count(i,j) + !BPR END + call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + else + + if (interp_mask_status == 0) then + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx), & + mask_relational=interp_mask_relational(idx), & + mask_val=interp_mask_val(idx), mask_field=mask_field%r_arr) + else + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx)) + end if + + if (temp /= missing_value(idx)) then + field%r_arr(i,j) = temp + call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + end if + + end if + else + field%r_arr(i,j) = fill_missing(idx) + call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + end if + + if (.not. bitarray_test(new_pts, i-sm1+1, j-sm2+1) .and. & + .not. bitarray_test(field%valid_mask, i-sm1+1, j-sm2+1)) then + field%r_arr(i,j) = fill_missing(idx) + + ! Assume that if missing fill value is other than default, then user has asked + ! to fill in any missing values, and we can consider this point to have + ! received a valid value + if (fill_missing(idx) /= NAN) call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + end if + + else + + if (data_count(i,j) > 0.) then + !BPR BEGIN + !accum_continuous is now passed a copy of field%r_arr (r_arr_cur_source) + !instead of field%r_arr itself so that it does not set + !field%r_arr to zero where the input source is marked as missing + !field%r_arr(i,j) = field%r_arr(i,j) / data_count(i,j) + field%r_arr(i,j) = r_arr_cur_source(i,j) / data_count(i,j) + !BPR END + call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + else + + if (interp_mask_status == 0) then + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx), & + mask_relational=interp_mask_relational(idx), & + mask_val=interp_mask_val(idx), mask_field=mask_field%r_arr) + else + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx)) + end if + + if (temp /= missing_value(idx)) then + field%r_arr(i,j) = temp + call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + end if + + end if + + if (.not. bitarray_test(new_pts, i-sm1+1, j-sm2+1) .and. & + .not. bitarray_test(field%valid_mask, i-sm1+1, j-sm2+1)) then + field%r_arr(i,j) = fill_missing(idx) + + ! Assume that if missing fill value is other than default, then user has asked + ! to fill in any missing values, and we can consider this point to have + ! received a valid value + if (fill_missing(idx) /= NAN) call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + end if + + end if + + end do + end do + call select_domain(orig_selected_proj) + deallocate(data_count) + + ! + ! No average_gcell interpolation method + ! + else + + orig_selected_proj = iget_selected_domain() + call select_domain(SOURCE_PROJ) + do j=sm2,em2 + do i=sm1,em1 + + if (abs(i - sd1) >= process_width .and. (abs(i - ed1) >= process_width) .and. & + abs(j - sd2) >= process_width .and. (abs(j - ed2) >= process_width)) then + field%r_arr(i,j) = fill_missing(idx) + call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + cycle + end if + + if (present(landmask)) then + + if (masked(idx) == MASKED_BOTH) then + + if (landmask(i,j) == 0) then ! WATER POINT + + if (interp_land_mask_status == 0) then + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx), & + mask_relational=interp_land_mask_relational(idx), & + mask_val=interp_land_mask_val(idx), mask_field=mask_land_field%r_arr) + else + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx)) + end if + + else if (landmask(i,j) == 1) then ! LAND POINT + + if (interp_water_mask_status == 0) then + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx), & + mask_relational=interp_water_mask_relational(idx), & + mask_val=interp_water_mask_val(idx), mask_field=mask_water_field%r_arr) + else + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx)) + end if + + end if + + else if (landmask(i,j) /= masked(idx)) then + + if (interp_mask_status == 0) then + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx), & + mask_relational=interp_mask_relational(idx), & + mask_val=interp_mask_val(idx), mask_field=mask_field%r_arr) + else + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx)) + end if + + else + temp = missing_value(idx) + end if + + ! No landmask for this field + else + + if (interp_mask_status == 0) then + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx), & + mask_relational=interp_mask_relational(idx), & + mask_val=interp_mask_val(idx), mask_field=mask_field%r_arr) + else + temp = interp_to_latlon(xlat(i,j), xlon(i,j), istagger, interp_array, interp_opts, slab, & + minx, maxx, miny, maxy, bdr, missing_value(idx)) + end if + + end if + + if (temp /= missing_value(idx)) then + field%r_arr(i,j) = temp + call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + else if (present(landmask)) then + if (landmask(i,j) == masked(idx)) then + field%r_arr(i,j) = fill_missing(idx) + call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + end if + end if + + if (.not. bitarray_test(new_pts, i-sm1+1, j-sm2+1) .and. & + .not. bitarray_test(field%valid_mask, i-sm1+1, j-sm2+1)) then + field%r_arr(i,j) = fill_missing(idx) + + ! Assume that if missing fill value is other than default, then user has asked + ! to fill in any missing values, and we can consider this point to have + ! received a valid value + if (fill_missing(idx) /= NAN) call bitarray_set(new_pts, i-sm1+1, j-sm2+1) + end if + + end do + end do + call select_domain(orig_selected_proj) + end if + + deallocate(interp_array) + deallocate(interp_opts) + + end subroutine interp_met_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: interp_to_latlon + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function interp_to_latlon(rlat, rlon, istagger, interp_method_list, interp_opt_list, slab, & + minx, maxx, miny, maxy, bdr, source_missing_value, & + mask_field, mask_relational, mask_val) + + use interp_module + use llxy_module + + implicit none + + ! Arguments + integer, intent(in) :: minx, maxx, miny, maxy, bdr, istagger + integer, dimension(:), intent(in) :: interp_method_list + integer, dimension(:), intent(in) :: interp_opt_list + real, intent(in) :: rlat, rlon, source_missing_value + real, dimension(minx:maxx,miny:maxy), intent(in) :: slab + real, intent(in), optional :: mask_val + real, dimension(minx:maxx,miny:maxy), intent(in), optional :: mask_field + character(len=1), intent(in), optional :: mask_relational + + ! Return value + real :: interp_to_latlon + + ! Local variables + real :: rx, ry + + interp_to_latlon = source_missing_value + + call lltoxy(rlat, rlon, rx, ry, istagger) + if (rx >= minx+bdr-0.5 .and. rx <= maxx-bdr+0.5) then + if (present(mask_field) .and. present(mask_val) .and. present (mask_relational)) then + interp_to_latlon = interp_sequence(rx, ry, 1, slab, minx, maxx, miny, maxy, 1, 1, source_missing_value, & + interp_method_list, interp_opt_list, 1, mask_relational, mask_val, mask_field) + else if (present(mask_field) .and. present(mask_val)) then + interp_to_latlon = interp_sequence(rx, ry, 1, slab, minx, maxx, miny, maxy, 1, 1, source_missing_value, & + interp_method_list, interp_opt_list, 1, maskval=mask_val, mask_array=mask_field) + else + interp_to_latlon = interp_sequence(rx, ry, 1, slab, minx, maxx, miny, maxy, 1, 1, source_missing_value, & + interp_method_list, interp_opt_list, 1) + end if + else + interp_to_latlon = source_missing_value + end if + + if (interp_to_latlon == source_missing_value) then + + ! Try a lon in the range 0. to 360.; all lons in the xlon + ! array should be in the range -180. to 180. + if (rlon < 0.) then + call lltoxy(rlat, rlon+360., rx, ry, istagger) + if (rx >= minx+bdr-0.5 .and. rx <= maxx-bdr+0.5) then + if (present(mask_field) .and. present(mask_val) .and. present(mask_relational)) then + interp_to_latlon = interp_sequence(rx, ry, 1, slab, minx, maxx, miny, maxy, & + 1, 1, source_missing_value, & + interp_method_list, interp_opt_list, 1, & + mask_relational, mask_val, mask_field) + else if (present(mask_field) .and. present(mask_val)) then + interp_to_latlon = interp_sequence(rx, ry, 1, slab, minx, maxx, miny, maxy, & + 1, 1, source_missing_value, & + interp_method_list, interp_opt_list, 1, & + maskval=mask_val, mask_array=mask_field) + else + interp_to_latlon = interp_sequence(rx, ry, 1, slab, minx, maxx, miny, maxy, & + 1, 1, source_missing_value, & + interp_method_list, interp_opt_list, 1) + end if + else + interp_to_latlon = source_missing_value + end if + + end if + + end if + + return + + end function interp_to_latlon + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_bottom_top_dim + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_bottom_top_dim(bottom_top_dim) + + use interp_option_module + use list_module + use storage_module + + implicit none + + ! Arguments + integer, intent(out) :: bottom_top_dim + + ! Local variables + integer :: i, j + integer, pointer, dimension(:) :: field_levels + character (len=32) :: z_dim + type (fg_input), pointer, dimension(:) :: headers + type (list) :: temp_levels + + !CWH Initialize local pointer variables + nullify(field_levels) + nullify(headers) + + ! Initialize a list to store levels that are found for 3-d fields + call list_init(temp_levels) + + ! Get a list of all time-dependent fields (given by their headers) from + ! the storage module + call storage_get_td_headers(headers) + + ! + ! Given headers of all fields, we first build a list of all possible levels + ! for 3-d met fields (excluding sea-level, though). + ! + do i=1,size(headers) + call get_z_dim_name(headers(i)%header%field, z_dim) + + ! We only want to consider 3-d met fields + if (z_dim(1:18) == 'num_metgrid_levels') then + + ! Find out what levels the current field has + call storage_get_levels(headers(i), field_levels) + do j=1,size(field_levels) + + ! If this level has not yet been encountered, add it to our list + if (.not. list_search(temp_levels, ikey=field_levels(j), ivalue=field_levels(j))) then + if (field_levels(j) /= 201300) then + call list_insert(temp_levels, ikey=field_levels(j), ivalue=field_levels(j)) + end if + end if + + end do + + deallocate(field_levels) + + end if + + end do + + bottom_top_dim = list_length(temp_levels) + + call list_destroy(temp_levels) + deallocate(headers) + + end subroutine get_bottom_top_dim + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: fill_missing_levels + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine fill_missing_levels(output_flags) + + use interp_option_module + use list_module + use module_debug + use module_mergesort + use storage_module + + implicit none + + ! Arguments + character (len=128), dimension(:), intent(inout) :: output_flags + + ! Local variables + integer :: i, ii, j, ix, jx, k, lower, upper, temp, istatus + integer, pointer, dimension(:) :: union_levels, field_levels + real, pointer, dimension(:) :: r_union_levels + character (len=128) :: clevel + type (fg_input) :: lower_field, upper_field, new_field, search_field + type (fg_input), pointer, dimension(:) :: headers, all_headers + type (list) :: temp_levels + type (list_item), pointer, dimension(:) :: keys + + ! CWH Initialize local pointer variables + nullify(union_levels) + nullify(field_levels) + nullify(r_union_levels) + nullify(headers) + nullify(all_headers) + nullify(keys) + + ! Initialize a list to store levels that are found for 3-d fields + call list_init(temp_levels) + + ! Get a list of all fields (given by their headers) from the storage module + call storage_get_td_headers(headers) + call storage_get_all_headers(all_headers) + + ! + ! Given headers of all fields, we first build a list of all possible levels + ! for 3-d met fields (excluding sea-level, though). + ! + do i=1,size(headers) + + ! Find out what levels the current field has + call storage_get_levels(headers(i), field_levels) + do j=1,size(field_levels) + + ! If this level has not yet been encountered, add it to our list + if (.not. list_search(temp_levels, ikey=field_levels(j), ivalue=field_levels(j))) then + if (field_levels(j) /= 201300) then + call list_insert(temp_levels, ikey=field_levels(j), ivalue=field_levels(j)) + end if + end if + + end do + + deallocate(field_levels) + + end do + + if (list_length(temp_levels) > 0) then + + ! + ! With all possible levels stored in a list, get an array of levels, sorted + ! in decreasing order + ! + i = 0 + allocate(union_levels(list_length(temp_levels))) + do while (list_length(temp_levels) > 0) + i = i + 1 + call list_get_first_item(temp_levels, ikey=union_levels(i), ivalue=temp) + end do + call mergesort(union_levels, 1, size(union_levels)) + + allocate(r_union_levels(size(union_levels))) + do i=1,size(union_levels) + r_union_levels(i) = real(union_levels(i)) + end do + + ! + ! With a sorted, complete list of levels, we need + ! to go back and fill in missing levels for each 3-d field + ! + do i=1,size(headers) + + ! + ! Find entry in METGRID.TBL for this field, if one exists; if it does, then the + ! entry may tell us how to get values for the current field at the missing level + ! + do ii=1,num_entries + if (fieldname(ii) == headers(i)%header%field) exit + end do + if (ii <= num_entries) then + call dup(headers(i),new_field) + nullify(new_field%valid_mask) + nullify(new_field%modified_mask) + call fill_field(new_field, ii, output_flags, r_union_levels) + end if + + end do + + deallocate(union_levels) + deallocate(r_union_levels) + deallocate(headers) + + call storage_get_td_headers(headers) + + ! + ! Now we may need to vertically interpolate to missing values in 3-d fields + ! + do i=1,size(headers) + + call storage_get_levels(headers(i), field_levels) + + ! If this isn't a 3-d array, nothing to do + if (size(field_levels) > 1) then + + do k=1,size(field_levels) + call dup(headers(i),search_field) + search_field%header%vertical_level = field_levels(k) + call storage_get_field(search_field,istatus) + if (istatus == 0) then + JLOOP: do jx=search_field%header%dim2(1),search_field%header%dim2(2) + ILOOP: do ix=search_field%header%dim1(1),search_field%header%dim1(2) + if (.not. bitarray_test(search_field%valid_mask, & + ix-search_field%header%dim1(1)+1, & + jx-search_field%header%dim2(1)+1)) then + + call dup(search_field, lower_field) + do lower=k-1,1,-1 + lower_field%header%vertical_level = field_levels(lower) + call storage_get_field(lower_field,istatus) + if (bitarray_test(lower_field%valid_mask, & + ix-search_field%header%dim1(1)+1, & + jx-search_field%header%dim2(1)+1)) & + exit + + end do + + call dup(search_field, upper_field) + do upper=k+1,size(field_levels) + upper_field%header%vertical_level = field_levels(upper) + call storage_get_field(upper_field,istatus) + if (bitarray_test(upper_field%valid_mask, & + ix-search_field%header%dim1(1)+1, & + jx-search_field%header%dim2(1)+1)) & + exit + + end do + if (upper <= size(field_levels) .and. lower >= 1) then + search_field%r_arr(ix,jx) = real(abs(field_levels(upper)-field_levels(k))) & + / real(abs(field_levels(upper)-field_levels(lower))) & + * lower_field%r_arr(ix,jx) & + + real(abs(field_levels(k)-field_levels(lower))) & + / real(abs(field_levels(upper)-field_levels(lower))) & + * upper_field%r_arr(ix,jx) + call bitarray_set(search_field%valid_mask, & + ix-search_field%header%dim1(1)+1, & + jx-search_field%header%dim2(1)+1) + end if + end if + end do ILOOP + end do JLOOP + else + call mprintf(.true.,ERROR, & + 'This is bad, could not get %s at level %i.', & + s1=trim(search_field%header%field), i1=field_levels(k)) + end if + end do + + end if + + deallocate(field_levels) + + end do + + end if + + call list_destroy(temp_levels) + deallocate(all_headers) + deallocate(headers) + + end subroutine fill_missing_levels + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: create_derived_fields + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine create_derived_fields(arg_gridtype, hdate, xfcst, & + we_mem_s, we_mem_e, sn_mem_s, sn_mem_e, & + we_mem_stag_s, we_mem_stag_e, sn_mem_stag_s, sn_mem_stag_e, & + created_this_field, output_flags) + + use interp_option_module + use list_module + use module_mergesort + use storage_module + + implicit none + + ! Arguments + integer, intent(in) :: we_mem_s, we_mem_e, sn_mem_s, sn_mem_e, & + we_mem_stag_s, we_mem_stag_e, sn_mem_stag_s, sn_mem_stag_e + real, intent(in) :: xfcst + logical, dimension(:), intent(inout) :: created_this_field + character (len=1), intent(in) :: arg_gridtype + character (len=24), intent(in) :: hdate + character (len=128), dimension(:), intent(inout) :: output_flags + + ! Local variables + integer :: idx, i, j, istatus + type (fg_input) :: field + + ! Initialize fg_input structure to store the field + field%header%version = 1 + field%header%date = hdate//' ' + field%header%time_dependent = .true. + field%header%mask_field = .false. + field%header%constant_field = .false. + field%header%forecast_hour = xfcst + field%header%fg_source = 'Derived from FG' + field%header%field = ' ' + field%header%units = ' ' + field%header%description = ' ' + field%header%vertical_level = 0 + field%header%sr_x = 1 + field%header%sr_y = 1 + field%header%array_order = 'XY ' + field%header%is_wind_grid_rel = .true. + field%header%array_has_missing_values = .false. + nullify(field%r_arr) + nullify(field%valid_mask) + nullify(field%modified_mask) + + ! + ! Check each entry in METGRID.TBL to see whether it is a derive field + ! + do idx=1,num_entries + if (is_derived_field(idx)) then + + created_this_field(idx) = .true. + + call mprintf(.true.,INFORM,'Going to create the field %s',s1=fieldname(idx)) + + ! Intialize more fields in storage structure + field%header%field = fieldname(idx) + call get_z_dim_name(fieldname(idx),field%header%vertical_coord) + field%map%stagger = output_stagger(idx) + if (arg_gridtype == 'E') then + field%header%dim1(1) = we_mem_s + field%header%dim1(2) = we_mem_e + field%header%dim2(1) = sn_mem_s + field%header%dim2(2) = sn_mem_e + else if (arg_gridtype == 'C') then + if (output_stagger(idx) == M) then + field%header%dim1(1) = we_mem_s + field%header%dim1(2) = we_mem_e + field%header%dim2(1) = sn_mem_s + field%header%dim2(2) = sn_mem_e + else if (output_stagger(idx) == U) then + field%header%dim1(1) = we_mem_stag_s + field%header%dim1(2) = we_mem_stag_e + field%header%dim2(1) = sn_mem_s + field%header%dim2(2) = sn_mem_e + else if (output_stagger(idx) == V) then + field%header%dim1(1) = we_mem_s + field%header%dim1(2) = we_mem_e + field%header%dim2(1) = sn_mem_stag_s + field%header%dim2(2) = sn_mem_stag_e + end if + end if + + call fill_field(field, idx, output_flags) + + end if + end do + + + end subroutine create_derived_fields + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: fill_field + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine fill_field(field, idx, output_flags, all_level_list) + + use interp_option_module + use list_module + use module_mergesort + use storage_module + + implicit none + + ! Arguments + integer, intent(in) :: idx + type (fg_input), intent(inout) :: field + character (len=128), dimension(:), intent(inout) :: output_flags + real, dimension(:), intent(in), optional :: all_level_list + + ! Local variables + integer :: i, j, istatus, isrclevel + integer, pointer, dimension(:) :: all_list + real :: rfillconst, rlevel, rsrclevel + type (fg_input) :: query_field + type (list_item), pointer, dimension(:) :: keys + character (len=128) :: asrcname + logical :: filled_all_lev + + !CWH Initialize local pointer variables + nullify(all_list) + nullify(keys) + + filled_all_lev = .false. + + ! + ! Get a list of all levels to be filled for this field + ! + keys => list_get_keys(fill_lev_list(idx)) + + do i=1,list_length(fill_lev_list(idx)) + + ! + ! First handle a specification for levels "all" + ! + if (trim(keys(i)%ckey) == 'all') then + + ! We only want to fill all levels if we haven't already filled "all" of them + if (.not. filled_all_lev) then + + filled_all_lev = .true. + + query_field%header%time_dependent = .true. + query_field%header%field = ' ' + nullify(query_field%r_arr) + nullify(query_field%valid_mask) + nullify(query_field%modified_mask) + + ! See if we are filling this level with a constant + call get_constant_fill_lev(keys(i)%cvalue, rfillconst, istatus) + if (istatus == 0) then + if (present(all_level_list)) then + do j=1,size(all_level_list) + call create_level(field, real(all_level_list(j)), idx, output_flags, rfillconst=rfillconst) + end do + else + query_field%header%field = level_template(idx) + nullify(all_list) + call storage_get_levels(query_field, all_list) + if (associated(all_list)) then + do j=1,size(all_list) + call create_level(field, real(all_list(j)), idx, output_flags, rfillconst=rfillconst) + end do + deallocate(all_list) + end if + end if + + ! Else see if we are filling this level with a constant equal + ! to the value of the level + else if (trim(keys(i)%cvalue) == 'vertical_index') then + if (present(all_level_list)) then + do j=1,size(all_level_list) + call create_level(field, real(all_level_list(j)), idx, output_flags, & + rfillconst=real(all_level_list(j))) + end do + else + query_field%header%field = level_template(idx) + nullify(all_list) + call storage_get_levels(query_field, all_list) + if (associated(all_list)) then + do j=1,size(all_list) + call create_level(field, real(all_list(j)), idx, output_flags, rfillconst=real(all_list(j))) + end do + deallocate(all_list) + end if + end if + + ! Else, we assume that it is a field from which we are copying levels + else + if (present(all_level_list)) then + do j=1,size(all_level_list) + call create_level(field, real(all_level_list(j)), idx, output_flags, & + asrcname=keys(i)%cvalue, rsrclevel=real(all_level_list(j))) + end do + else + query_field%header%field = keys(i)%cvalue ! Use same levels as source field, not level_template + nullify(all_list) + call storage_get_levels(query_field, all_list) + if (associated(all_list)) then + do j=1,size(all_list) + call create_level(field, real(all_list(j)), idx, output_flags, & + asrcname=keys(i)%cvalue, rsrclevel=real(all_list(j))) + end do + deallocate(all_list) + + else + + ! If the field doesn't have any levels (or does not exist) then we have not + ! really filled all levels at this point. + filled_all_lev = .false. + end if + end if + + end if + end if + + ! + ! Handle individually specified levels + ! + else + + read(keys(i)%ckey,*) rlevel + + ! See if we are filling this level with a constant + call get_constant_fill_lev(keys(i)%cvalue, rfillconst, istatus) + if (istatus == 0) then + call create_level(field, rlevel, idx, output_flags, rfillconst=rfillconst) + + ! Otherwise, we are filling from another level + else + call get_fill_src_level(keys(i)%cvalue, asrcname, isrclevel) + rsrclevel = real(isrclevel) + call create_level(field, rlevel, idx, output_flags, & + asrcname=asrcname, rsrclevel=rsrclevel) + + end if + end if + end do + + if (associated(keys)) deallocate(keys) + + end subroutine fill_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: create_level + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine create_level(field_template, rlevel, idx, output_flags, & + rfillconst, asrcname, rsrclevel) + + use storage_module + use interp_option_module + + implicit none + + ! Arguments + type (fg_input), intent(inout) :: field_template + real, intent(in) :: rlevel + integer, intent(in) :: idx + character (len=128), dimension(:), intent(inout) :: output_flags + real, intent(in), optional :: rfillconst, rsrclevel + character (len=128), intent(in), optional :: asrcname + + ! Local variables + integer :: i, j, istatus + integer :: sm1,em1,sm2,em2 + type (fg_input) :: query_field + + ! + ! Check to make sure optional arguments are sane + ! + if (present(rfillconst) .and. (present(asrcname) .or. present(rsrclevel))) then + call mprintf(.true.,ERROR,'A call to create_level() cannot be given specifications '// & + 'for both a constant fill value and a source level.') + + else if ((present(asrcname) .and. .not. present(rsrclevel)) .or. & + (.not. present(asrcname) .and. present(rsrclevel))) then + call mprintf(.true.,ERROR,'Neither or both of optional arguments asrcname and '// & + 'rsrclevel must be specified to subroutine create_level().') + + else if (.not. present(rfillconst) .and. & + .not. present(asrcname) .and. & + .not. present(rsrclevel)) then + call mprintf(.true.,ERROR,'A call to create_level() must be given either a specification '// & + 'for a constant fill value or a source level.') + end if + + query_field%header%time_dependent = .true. + query_field%header%field = field_template%header%field + query_field%header%vertical_level = rlevel + nullify(query_field%r_arr) + nullify(query_field%valid_mask) + nullify(query_field%modified_mask) + + call storage_query_field(query_field, istatus) + if (istatus == 0) then + call mprintf(.true.,INFORM,'%s at level %f already exists; leaving it alone.', & + s1=field_template%header%field, f1=rlevel) + return + end if + + sm1 = field_template%header%dim1(1) + em1 = field_template%header%dim1(2) + sm2 = field_template%header%dim2(1) + em2 = field_template%header%dim2(2) + + ! + ! Handle constant fill value case + ! + if (present(rfillconst)) then + + field_template%header%vertical_level = rlevel + allocate(field_template%r_arr(sm1:em1,sm2:em2)) + allocate(field_template%valid_mask) + allocate(field_template%modified_mask) + call bitarray_create(field_template%valid_mask, em1-sm1+1, em2-sm2+1) + call bitarray_create(field_template%modified_mask, em1-sm1+1, em2-sm2+1) + + field_template%r_arr = rfillconst + + do j=sm2,em2 + do i=sm1,em1 + call bitarray_set(field_template%valid_mask, i-sm1+1, j-sm2+1) + end do + end do + + call storage_put_field(field_template) + + if (output_this_field(idx) .and. flag_in_output(idx) /= ' ') then + output_flags(idx) = flag_in_output(idx) + end if + + ! + ! Handle source field and source level case + ! + else if (present(asrcname) .and. present(rsrclevel)) then + + query_field%header%field = ' ' + query_field%header%field = asrcname + query_field%header%vertical_level = rsrclevel + + ! Check to see whether the requested source field exists at the requested level + call storage_query_field(query_field, istatus) + + if (istatus == 0) then + + ! Read in requested field at requested level + call storage_get_field(query_field, istatus) + if ((query_field%header%dim1(1) /= field_template%header%dim1(1)) .or. & + (query_field%header%dim1(2) /= field_template%header%dim1(2)) .or. & + (query_field%header%dim2(1) /= field_template%header%dim2(1)) .or. & + (query_field%header%dim2(2) /= field_template%header%dim2(2))) then + call mprintf(.true.,ERROR,'Dimensions for %s do not match those of %s. This is '// & + 'probably because the staggerings of the fields do not match.', & + s1=query_field%header%field, s2=field_template%header%field) + end if + + field_template%header%vertical_level = rlevel + allocate(field_template%r_arr(sm1:em1,sm2:em2)) + allocate(field_template%valid_mask) + allocate(field_template%modified_mask) + call bitarray_create(field_template%valid_mask, em1-sm1+1, em2-sm2+1) + call bitarray_create(field_template%modified_mask, em1-sm1+1, em2-sm2+1) + + field_template%r_arr = query_field%r_arr + + ! We should retain information about which points in the field are valid + do j=sm2,em2 + do i=sm1,em1 + if (bitarray_test(query_field%valid_mask, i-sm1+1, j-sm2+1)) then + call bitarray_set(field_template%valid_mask, i-sm1+1, j-sm2+1) + end if + end do + end do + + call storage_put_field(field_template) + + if (output_this_field(idx) .and. flag_in_output(idx) /= ' ') then + output_flags(idx) = flag_in_output(idx) + end if + + else + call mprintf(.true.,INFORM,'Couldn''t find %s at level %f to fill level %f of %s.', & + s1=asrcname,f1=rsrclevel,f2=rlevel,s2=field_template%header%field) + end if + + end if + + end subroutine create_level + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: accum_continuous + ! + ! Purpose: Sum up all of the source data points whose nearest neighbor in the + ! model grid is the specified model grid point. + ! + ! NOTE: When processing the source tile, those source points that are + ! closest to a different model grid point will be added to the totals for + ! such grid points; thus, an entire source tile will be processed at a time. + ! This routine really processes for all model grid points that are + ! within a source tile, and not just for a single grid point. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine accum_continuous(src_array, & + src_min_x, src_max_x, src_min_y, src_max_y, src_min_z, src_max_z, bdr_width, & + dst_array, n, & + start_i, end_i, start_j, end_j, start_k, end_k, & + istagger, & + new_pts, msgval, maskval, mask_relational, mask_array, sr_x, sr_y) + + use bitarray_module + use misc_definitions_module + + implicit none + + ! Arguments + integer, intent(in) :: start_i, end_i, start_j, end_j, start_k, end_k, istagger, & + src_min_x, src_max_x, src_min_y, src_max_y, src_min_z, src_max_z, bdr_width + real, intent(in) :: maskval, msgval + real, dimension(src_min_x:src_max_x, src_min_y:src_max_y, src_min_z:src_max_z), intent(in) :: src_array + real, dimension(start_i:end_i, start_j:end_j, start_k:end_k), intent(inout) :: dst_array, n + real, dimension(src_min_x:src_max_x, src_min_y:src_max_y), intent(in), optional :: mask_array + integer, intent(in), optional :: sr_x, sr_y + type (bitarray), intent(inout) :: new_pts + character(len=1), intent(in), optional :: mask_relational + + ! Local variables + integer :: i, j + integer, pointer, dimension(:,:,:) :: where_maps_to + real :: rsr_x, rsr_y + + rsr_x = 1.0 + rsr_y = 1.0 + if (present(sr_x)) rsr_x = real(sr_x) + if (present(sr_y)) rsr_y = real(sr_y) + + allocate(where_maps_to(src_min_x:src_max_x,src_min_y:src_max_y,2)) + do i=src_min_x,src_max_x + do j=src_min_y,src_max_y + where_maps_to(i,j,1) = NOT_PROCESSED + end do + end do + + call process_continuous_block(src_array, where_maps_to, & + src_min_x, src_min_y, src_min_z, src_max_x, src_max_y, src_max_z, & + src_min_x+bdr_width, src_min_y, src_min_z, & + src_max_x-bdr_width, src_max_y, src_max_z, & + dst_array, n, start_i, end_i, start_j, end_j, start_k, end_k, & + istagger, & + new_pts, rsr_x, rsr_y, msgval, maskval, mask_relational, mask_array) + + deallocate(where_maps_to) + + end subroutine accum_continuous + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: process_continuous_block + ! + ! Purpose: To recursively process a subarray of continuous data, adding the + ! points in a block to the sum for their nearest grid point. The nearest + ! neighbor may be estimated in some cases; for example, if the four corners + ! of a subarray all have the same nearest grid point, all elements in the + ! subarray are added to that grid point. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + recursive subroutine process_continuous_block(tile_array, where_maps_to, & + src_min_x, src_min_y, src_min_z, src_max_x, src_max_y, src_max_z, & + min_i, min_j, min_k, max_i, max_j, max_k, & + dst_array, n, & + start_x, end_x, start_y, end_y, start_z, end_z, & + istagger, & + new_pts, sr_x, sr_y, msgval, maskval, mask_relational, mask_array) + + use bitarray_module + use llxy_module + use misc_definitions_module + + implicit none + + ! Arguments + integer, intent(in) :: min_i, min_j, min_k, max_i, max_j, max_k, & + src_min_x, src_min_y, src_min_z, src_max_x, src_max_y, src_max_z, & + start_x, end_x, start_y, end_y, start_z, end_z, istagger + integer, dimension(src_min_x:src_max_x,src_min_y:src_max_y,2), intent(inout) :: where_maps_to + real, intent(in) :: sr_x, sr_y, maskval, msgval + real, dimension(src_min_x:src_max_x,src_min_y:src_max_y,src_min_z:src_max_z), intent(in) :: tile_array + real, dimension(src_min_x:src_max_x,src_min_y:src_max_y), intent(in), optional :: mask_array + real, dimension(start_x:end_x,start_y:end_y,start_z:end_z), intent(inout) :: dst_array, n + type (bitarray), intent(inout) :: new_pts + character(len=1), intent(in), optional :: mask_relational + + ! Local variables + integer :: orig_selected_domain, x_dest, y_dest, i, j, k, center_i, center_j + real :: lat_corner, lon_corner, rx, ry + + ! Compute the model grid point that the corners of the rectangle to be + ! processed map to + ! Lower-left corner + if (where_maps_to(min_i,min_j,1) == NOT_PROCESSED) then + orig_selected_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(min_i), real(min_j), lat_corner, lon_corner, istagger) + call select_domain(1) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx - 1.0)*sr_x + 1.0 + ry = (ry - 1.0)*sr_y + 1.0 + call select_domain(orig_selected_domain) + if (real(start_x) <= rx .and. rx <= real(end_x) .and. & + real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(min_i,min_j,1) = nint(rx) + where_maps_to(min_i,min_j,2) = nint(ry) + else + where_maps_to(min_i,min_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! Upper-left corner + if (where_maps_to(min_i,max_j,1) == NOT_PROCESSED) then + orig_selected_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(min_i), real(max_j), lat_corner, lon_corner, istagger) + call select_domain(1) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx - 1.0)*sr_x + 1.0 + ry = (ry - 1.0)*sr_y + 1.0 + call select_domain(orig_selected_domain) + if (real(start_x) <= rx .and. rx <= real(end_x) .and. & + real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(min_i,max_j,1) = nint(rx) + where_maps_to(min_i,max_j,2) = nint(ry) + else + where_maps_to(min_i,max_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! Upper-right corner + if (where_maps_to(max_i,max_j,1) == NOT_PROCESSED) then + orig_selected_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(max_i), real(max_j), lat_corner, lon_corner, istagger) + call select_domain(1) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx - 1.0)*sr_x + 1.0 + ry = (ry - 1.0)*sr_y + 1.0 + call select_domain(orig_selected_domain) + if (real(start_x) <= rx .and. rx <= real(end_x) .and. & + real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(max_i,max_j,1) = nint(rx) + where_maps_to(max_i,max_j,2) = nint(ry) + else + where_maps_to(max_i,max_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! Lower-right corner + if (where_maps_to(max_i,min_j,1) == NOT_PROCESSED) then + orig_selected_domain = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call xytoll(real(max_i), real(min_j), lat_corner, lon_corner, istagger) + call select_domain(1) + call lltoxy(lat_corner, lon_corner, rx, ry, istagger) + rx = (rx - 1.0)*sr_x + 1.0 + ry = (ry - 1.0)*sr_y + 1.0 + call select_domain(orig_selected_domain) + if (real(start_x) <= rx .and. rx <= real(end_x) .and. & + real(start_y) <= ry .and. ry <= real(end_y)) then + where_maps_to(max_i,min_j,1) = nint(rx) + where_maps_to(max_i,min_j,2) = nint(ry) + else + where_maps_to(max_i,min_j,1) = OUTSIDE_DOMAIN + end if + end if + + ! If all four corners map to same model grid point, accumulate the + ! entire rectangle + if (where_maps_to(min_i,min_j,1) == where_maps_to(min_i,max_j,1) .and. & + where_maps_to(min_i,min_j,1) == where_maps_to(max_i,max_j,1) .and. & + where_maps_to(min_i,min_j,1) == where_maps_to(max_i,min_j,1) .and. & + where_maps_to(min_i,min_j,2) == where_maps_to(min_i,max_j,2) .and. & + where_maps_to(min_i,min_j,2) == where_maps_to(max_i,max_j,2) .and. & + where_maps_to(min_i,min_j,2) == where_maps_to(max_i,min_j,2) .and. & + where_maps_to(min_i,min_j,1) /= OUTSIDE_DOMAIN) then + x_dest = where_maps_to(min_i,min_j,1) + y_dest = where_maps_to(min_i,min_j,2) + + ! If this grid point was already given a value from higher-priority source data, + ! there is nothing to do. +! if (.not. bitarray_test(processed_pts, x_dest-start_x+1, y_dest-start_y+1)) then + + ! If this grid point has never been given a value by this level of source data, + ! initialize the point + if (.not. bitarray_test(new_pts, x_dest-start_x+1, y_dest-start_y+1)) then + do k=min_k,max_k + dst_array(x_dest,y_dest,k) = 0. + end do + end if + + ! Sum all the points whose nearest neighbor is this grid point + if (present(mask_array) .and. present(mask_relational)) then + do i=min_i,max_i + do j=min_j,max_j + do k=min_k,max_k + ! Ignore masked/missing values in the source data + if (tile_array(i,j,k) /= msgval) then + if (mask_relational == ' ' .and. mask_array(i,j) /= maskval) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + else if (mask_relational == '<' .and. mask_array(i,j) >= maskval) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + else if (mask_relational == '>' .and. mask_array(i,j) <= maskval) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + end if + end if + end do + end do + end do + else if (present(mask_array)) then + do i=min_i,max_i + do j=min_j,max_j + do k=min_k,max_k + ! Ignore masked/missing values in the source data + if ((tile_array(i,j,k) /= msgval) .and. & + (mask_array(i,j) /= maskval)) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + end if + end do + end do + end do + else + do i=min_i,max_i + do j=min_j,max_j + do k=min_k,max_k + ! Ignore masked/missing values in the source data + if ((tile_array(i,j,k) /= msgval)) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + end if + end do + end do + end do + end if + +! end if + + ! Rectangle is a square of four points, and we can simply deal with each of the points + else if (((max_i - min_i + 1) <= 2) .and. ((max_j - min_j + 1) <= 2)) then + do i=min_i,max_i + do j=min_j,max_j + x_dest = where_maps_to(i,j,1) + y_dest = where_maps_to(i,j,2) + + if (x_dest /= OUTSIDE_DOMAIN) then + +! if (.not. bitarray_test(processed_pts, x_dest-start_x+1, y_dest-start_y+1)) then + if (.not. bitarray_test(new_pts, x_dest-start_x+1, y_dest-start_y+1)) then + do k=min_k,max_k + dst_array(x_dest,y_dest,k) = 0. + end do + end if + + if (present(mask_array) .and. present(mask_relational)) then + do k=min_k,max_k + ! Ignore masked/missing values + if (tile_array(i,j,k) /= msgval) then + if (mask_relational == ' ' .and. mask_array(i,j) /= maskval) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + else if (mask_relational == '<' .and. mask_array(i,j) >= maskval) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + else if (mask_relational == '>' .and. mask_array(i,j) <= maskval) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + end if + end if + end do + else if (present(mask_array)) then + do k=min_k,max_k + ! Ignore masked/missing values + if ((tile_array(i,j,k) /= msgval) .and. & + (mask_array(i,j) /= maskval)) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + end if + end do + else + do k=min_k,max_k + ! Ignore masked/missing values + if ((tile_array(i,j,k) /= msgval)) then + dst_array(x_dest,y_dest,k) = dst_array(x_dest,y_dest,k) + tile_array(i,j,k) + n(x_dest,y_dest,k) = n(x_dest,y_dest,k) + 1.0 + call bitarray_set(new_pts, x_dest-start_x+1, y_dest-start_y+1) + end if + end do + end if +! end if + + end if + end do + end do + + ! Not all corners map to the same grid point, and the rectangle contains more than + ! four points + else + center_i = (max_i + min_i)/2 + center_j = (max_j + min_j)/2 + + ! Recursively process lower-left rectangle + call process_continuous_block(tile_array, where_maps_to, & + src_min_x, src_min_y, src_min_z, & + src_max_x, src_max_y, src_max_z, & + min_i, min_j, min_k, & + center_i, center_j, max_k, & + dst_array, n, & + start_x, end_x, start_y, end_y, start_z, end_z, & + istagger, & + new_pts, sr_x, sr_y, msgval, maskval, mask_relational, mask_array) + + if (center_i < max_i) then + ! Recursively process lower-right rectangle + call process_continuous_block(tile_array, where_maps_to, & + src_min_x, src_min_y, src_min_z, & + src_max_x, src_max_y, src_max_z, & + center_i+1, min_j, min_k, max_i, & + center_j, max_k, & + dst_array, n, & + start_x, end_x, start_y, & + end_y, start_z, end_z, & + istagger, & + new_pts, sr_x, sr_y, msgval, maskval, mask_relational, mask_array) + end if + + if (center_j < max_j) then + ! Recursively process upper-left rectangle + call process_continuous_block(tile_array, where_maps_to, & + src_min_x, src_min_y, src_min_z, & + src_max_x, src_max_y, src_max_z, & + min_i, center_j+1, min_k, center_i, & + max_j, max_k, & + dst_array, n, & + start_x, end_x, start_y, & + end_y, start_z, end_z, & + istagger, & + new_pts, sr_x, sr_y, msgval, maskval, mask_relational, mask_array) + end if + + if (center_i < max_i .and. center_j < max_j) then + ! Recursively process upper-right rectangle + call process_continuous_block(tile_array, where_maps_to, & + src_min_x, src_min_y, src_min_z, & + src_max_x, src_max_y, src_max_z, & + center_i+1, center_j+1, min_k, max_i, & + max_j, max_k, & + dst_array, n, & + start_x, end_x, start_y, & + end_y, start_z, end_z, & + istagger, & + new_pts, sr_x, sr_y, msgval, maskval, mask_relational, mask_array) + end if + end if + + end subroutine process_continuous_block + +end module process_domain_module diff --git a/WPS/metgrid/src/queue_module.F b/WPS/metgrid/src/queue_module.F new file mode 120000 index 00000000..10acd4de --- /dev/null +++ b/WPS/metgrid/src/queue_module.F @@ -0,0 +1 @@ +../../geogrid/src/queue_module.F \ No newline at end of file diff --git a/WPS/metgrid/src/read_met_module.F b/WPS/metgrid/src/read_met_module.F new file mode 100644 index 00000000..269ebb91 --- /dev/null +++ b/WPS/metgrid/src/read_met_module.F @@ -0,0 +1,414 @@ +module read_met_module + + use constants_module + use module_debug + use misc_definitions_module + use met_data_module + + ! State variables? + integer :: input_unit + character (len=MAX_FILENAME_LEN) :: filename + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: read_met_init + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine read_met_init(fg_source, source_is_constant, datestr, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + logical, intent(in) :: source_is_constant + character (len=*), intent(in) :: fg_source + character (len=*), intent(in) :: datestr + + ! Local variables + integer :: io_status + logical :: is_used + + istatus = 0 + + ! 1) BUILD FILENAME BASED ON TIME + filename = ' ' + if (.not. source_is_constant) then + write(filename, '(a)') trim(fg_source)//':'//trim(datestr) + else + write(filename, '(a)') trim(fg_source) + end if + + ! 2) OPEN FILE + do input_unit=10,100 + inquire(unit=input_unit, opened=is_used) + if (.not. is_used) exit + end do + call mprintf((input_unit > 100),ERROR,'In read_met_init(), couldn''t find an available Fortran unit.') + open(unit=input_unit, file=trim(filename), status='old', form='unformatted', iostat=io_status) + + if (io_status > 0) istatus = 1 + + return + + + end subroutine read_met_init + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: read_next_met_field + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine read_next_met_field(fg_data, istatus) + + implicit none + + ! Arguments + type (met_data), intent(inout) :: fg_data + integer, intent(out) :: istatus + + ! Local variables + character (len=8) :: startloc + + istatus = 1 + + ! 1) READ FORMAT VERSION + read(unit=input_unit,err=1001,end=1001) fg_data % version + + ! PREGRID + if (fg_data % version == 3) then + + read(unit=input_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + fg_data % iproj + + fg_data % map_source = ' ' + + if (fg_data % field == 'HGT ') fg_data % field = 'GHT ' + + fg_data % starti = 1.0 + fg_data % startj = 1.0 + + ! Cylindrical equidistant + if (fg_data % iproj == 0) then + fg_data % iproj = PROJ_LATLON + read(unit=input_unit,err=1001,end=1001) fg_data % startlat, & + fg_data % startlon, & + fg_data % deltalat, & + fg_data % deltalon + + ! Mercator + else if (fg_data % iproj == 1) then + fg_data % iproj = PROJ_MERC + read(unit=input_unit,err=1001,end=1001) fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % truelat1 + + ! Lambert conformal + else if (fg_data % iproj == 3) then + fg_data % iproj = PROJ_LC + read(unit=input_unit,err=1001,end=1001) fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1, & + fg_data % truelat2 + + ! Polar stereographic + else if (fg_data % iproj == 5) then + fg_data % iproj = PROJ_PS + read(unit=input_unit,err=1001,end=1001) fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1 + + ! ????????? + else + call mprintf(.true.,ERROR,'Unrecognized projection code %i when reading from %s', & + i1=fg_data % iproj, s1=filename) + + end if + + fg_data % earth_radius = EARTH_RADIUS_M / 1000. + +#if (defined _GEOGRID) || (defined _METGRID) + fg_data % dx = fg_data % dx * 1000. + fg_data % dy = fg_data % dy * 1000. + + if (fg_data % xlonc > 180.) fg_data % xlonc = fg_data%xlonc - 360. + + if (fg_data % startlon > 180.) fg_data % startlon = fg_data%startlon - 360. + + if (fg_data % startlat < -90.) fg_data % startlat = -90. + if (fg_data % startlat > 90.) fg_data % startlat = 90. +#endif + + fg_data % is_wind_grid_rel = .true. + + allocate(fg_data % slab(fg_data % nx, fg_data % ny)) + read(unit=input_unit,err=1001,end=1001) fg_data % slab + + istatus = 0 + + ! GRIB_PREP + else if (fg_data % version == 4) then + + read(unit=input_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % map_source, & + fg_data % field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + fg_data % iproj + + if (fg_data % field == 'HGT ') fg_data % field = 'GHT ' + + ! Cylindrical equidistant + if (fg_data % iproj == 0) then + fg_data % iproj = PROJ_LATLON + read(unit=input_unit,err=1001,end=1001) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % deltalat, & + fg_data % deltalon + + ! Mercator + else if (fg_data % iproj == 1) then + fg_data % iproj = PROJ_MERC + read(unit=input_unit,err=1001,end=1001) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % truelat1 + + ! Lambert conformal + else if (fg_data % iproj == 3) then + fg_data % iproj = PROJ_LC + read(unit=input_unit,err=1001,end=1001) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1, & + fg_data % truelat2 + + ! Polar stereographic + else if (fg_data % iproj == 5) then + fg_data % iproj = PROJ_PS + read(unit=input_unit,err=1001,end=1001) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1 + + ! ????????? + else + call mprintf(.true.,ERROR,'Unrecognized projection code %i when reading from %s', & + i1=fg_data % iproj, s1=filename) + + end if + + if (startloc == 'CENTER ') then + fg_data % starti = real(fg_data % nx)/2. + fg_data % startj = real(fg_data % ny)/2. + else if (startloc == 'SWCORNER') then + fg_data % starti = 1.0 + fg_data % startj = 1.0 + end if + + fg_data % earth_radius = EARTH_RADIUS_M / 1000. + +#if (defined _GEOGRID) || (defined _METGRID) + fg_data % dx = fg_data % dx * 1000. + fg_data % dy = fg_data % dy * 1000. + + if (fg_data % xlonc > 180.) fg_data % xlonc = fg_data % xlonc - 360. + + if (fg_data % startlon > 180.) fg_data % startlon = fg_data % startlon - 360. + + if (fg_data % startlat < -90.) fg_data % startlat = -90. + if (fg_data % startlat > 90.) fg_data % startlat = 90. +#endif + + fg_data % is_wind_grid_rel = .true. + + allocate(fg_data % slab(fg_data % nx, fg_data % ny)) + read(unit=input_unit,err=1001,end=1001) fg_data % slab + + istatus = 0 + + ! WPS + else if (fg_data % version == 5) then + + read(unit=input_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % map_source, & + fg_data % field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + fg_data % iproj + + if (fg_data % field == 'HGT ') fg_data % field = 'GHT ' + + ! Cylindrical equidistant + if (fg_data % iproj == 0) then + fg_data % iproj = PROJ_LATLON + read(unit=input_unit,err=1001,end=1001) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % deltalat, & + fg_data % deltalon, & + fg_data % earth_radius + + ! Mercator + else if (fg_data % iproj == 1) then + fg_data % iproj = PROJ_MERC + read(unit=input_unit,err=1001,end=1001) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % truelat1, & + fg_data % earth_radius + + ! Lambert conformal + else if (fg_data % iproj == 3) then + fg_data % iproj = PROJ_LC + read(unit=input_unit,err=1001,end=1001) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1, & + fg_data % truelat2, & + fg_data % earth_radius + + ! Gaussian + else if (fg_data % iproj == 4) then + fg_data % iproj = PROJ_GAUSS + read(unit=input_unit,err=1001,end=1001) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % deltalat, & + fg_data % deltalon, & + fg_data % earth_radius + + ! Polar stereographic + else if (fg_data % iproj == 5) then + fg_data % iproj = PROJ_PS + read(unit=input_unit,err=1001,end=1001) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1, & + fg_data % earth_radius + + ! CASSINI + else if (fg_data % iproj == 6) then + fg_data % iproj = PROJ_CASSINI + read(unit=input_unit,err=1001,end=1001) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % centerlat, & + fg_data % centerlon, & + fg_data % earth_radius + + if ( fg_data % centerlat > 0. ) then + fg_data % pole_lat = 90. - fg_data % centerlat + fg_data % pole_lon = 180. + fg_data % xlonc = -fg_data % centerlon + else + fg_data % pole_lat = 90. + fg_data % centerlat + fg_data % pole_lon = 0. + fg_data % xlonc = 180. - fg_data % centerlon + end if + fg_data % deltalon = fg_data % dx + fg_data % deltalat = fg_data % dy + + ! ????????? + else + call mprintf(.true.,ERROR,'Unrecognized projection code %i when reading from %s', & + i1=fg_data % iproj, s1=filename) + + end if + + if (startloc == 'CENTER ') then + fg_data % starti = real(fg_data % nx)/2. + fg_data % startj = real(fg_data % ny)/2. + else if (startloc == 'SWCORNER') then + fg_data % starti = 1.0 + fg_data % startj = 1.0 + end if + +#if (defined _GEOGRID) || (defined _METGRID) + fg_data % dx = fg_data % dx * 1000. + fg_data % dy = fg_data % dy * 1000. + + if (fg_data % xlonc > 180.) fg_data % xlonc = fg_data % xlonc - 360. + + if (fg_data % startlon > 180.) fg_data % startlon = fg_data % startlon - 360. + + if (fg_data % startlat < -90.) fg_data % startlat = -90. + if (fg_data % startlat > 90.) fg_data % startlat = 90. +#endif + + read(unit=input_unit,err=1001,end=1001) fg_data % is_wind_grid_rel + + allocate(fg_data % slab(fg_data % nx, fg_data % ny)) + read(unit=input_unit,err=1001,end=1001) fg_data % slab + + istatus = 0 + + else + call mprintf(.true.,ERROR,'Didn''t recognize format version of data in %s.\n'// & + 'Found version %i but expected either 3, 4, or 5. This could be an endian problem.', & + s1=filename, i1=fg_data % version) + end if + + return + + 1001 return + + end subroutine read_next_met_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: read_met_close + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine read_met_close() + + implicit none + + close(unit=input_unit) + filename = 'UNINITIALIZED_FILENAME' + + end subroutine read_met_close + +end module read_met_module diff --git a/WPS/metgrid/src/remapper.F b/WPS/metgrid/src/remapper.F new file mode 100644 index 00000000..b18a2a01 --- /dev/null +++ b/WPS/metgrid/src/remapper.F @@ -0,0 +1,1341 @@ +module remapper + + use mpas_mesh + use scan_input, only : input_field_type, FIELD_TYPE_REAL, FIELD_TYPE_DOUBLE, FIELD_TYPE_INTEGER + use target_mesh + + integer, parameter :: max_queue_length = 2700 ! should be at least (earth circumference / minimum grid distance) + integer, parameter :: max_dictionary_size = 82000 ! should be at least (nCells/32) + + integer :: queue_head = 0 + integer :: queue_tail = 0 + integer :: queue_size = 0 + integer, dimension(0:max_queue_length-1) :: queue_array + + integer :: int_size = 32 + integer, dimension(max_dictionary_size) :: dictionary_array + + + type remap_info_type + integer :: method = -1 + type (mpas_mesh_type), pointer :: src_mesh + type (target_mesh_type), pointer :: dst_mesh + + ! For nearest-neighbor + integer, dimension(:,:), pointer :: nearestCell => null() + integer, dimension(:,:), pointer :: nearestVertex => null() + integer, dimension(:,:), pointer :: nearestEdge => null() + + ! For Wachspress interpolation + real, dimension(:,:,:), pointer :: cellWeights => null() + real, dimension(:,:,:), pointer :: vertexWeights => null() + real, dimension(:,:,:), pointer :: edgeWeights => null() + integer, dimension(:,:,:), pointer :: sourceCells => null() + integer, dimension(:,:,:), pointer :: sourceVertices => null() + integer, dimension(:,:,:), pointer :: sourceEdges => null() + + ! For masked interpolation + real, dimension(:,:,:), pointer :: cellMaskedWeights => null() + integer, dimension(:,:,:), pointer :: sourceMaskedCells => null() + end type remap_info_type + + + type target_field_type + character (len=64) :: name + integer :: ndims = -1 + integer :: xtype = -1 + logical :: isTimeDependent = .false. + integer, dimension(:), pointer :: dimlens => null() + character (len=64), dimension(:), pointer :: dimnames => null() + + ! Members to store field data + real :: array0r + real, dimension(:), pointer :: array1r => null() + real, dimension(:,:), pointer :: array2r => null() + real, dimension(:,:,:), pointer :: array3r => null() + real, dimension(:,:,:,:), pointer :: array4r => null() + double precision :: array0d + double precision, dimension(:), pointer :: array1d => null() + double precision, dimension(:,:), pointer :: array2d => null() + double precision, dimension(:,:,:), pointer :: array3d => null() + double precision, dimension(:,:,:,:), pointer :: array4d => null() + integer :: array0i + integer, dimension(:), pointer :: array1i => null() + integer, dimension(:,:), pointer :: array2i => null() + integer, dimension(:,:,:), pointer :: array3i => null() + integer, dimension(:,:,:,:), pointer :: array4i => null() + end type target_field_type + + + private :: nearest_cell, & + nearest_vertex, & + sphere_distance, & + mpas_arc_length, & + mpas_triangle_signed_area_sphere, & + mpas_wachspress_coordinates, & + convert_lx, & + index2d + + + contains + + + integer function remap_info_setup(src_mesh, dst_mesh, remap_info) result(stat) + + implicit none + + type (mpas_mesh_type), intent(in), target :: src_mesh + type (target_mesh_type), intent(in), target :: dst_mesh + type (remap_info_type), intent(out) :: remap_info + + integer :: idx + integer :: j + integer :: nn + integer :: ix, iy + integer :: irank + real :: sumWeights + real, dimension(:,:), allocatable :: vertCoords + real, dimension(3) :: pointInterp + + stat = 0 + + remap_info % method = 1 + remap_info % src_mesh => src_mesh + remap_info % dst_mesh => dst_mesh + + ! + ! For nearest neighbor + ! + allocate(remap_info % nearestCell(dst_mesh % nlon, dst_mesh % nlat)) + allocate(remap_info % nearestVertex(dst_mesh % nlon, dst_mesh % nlat)) + allocate(remap_info % nearestEdge(dst_mesh % nlon, dst_mesh % nlat)) + + irank = dst_mesh % irank + + idx = 1 + do iy=1,dst_mesh % nlat + do ix=1,dst_mesh % nlon + idx = nearest_cell(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), idx, & + src_mesh % nCells, src_mesh % maxEdges, & + src_mesh % nEdgesOnCell, src_mesh % cellsOnCell, src_mesh % latCell, src_mesh % lonCell) + remap_info % nearestCell(ix, iy) = idx + end do + end do + + idx = 1 + do iy=1,dst_mesh % nlat + do ix=1,dst_mesh % nlon + idx = nearest_vertex(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), idx, & + src_mesh % nCells, src_mesh % nVertices, src_mesh % maxEdges, 3, & + src_mesh % nEdgesOnCell, src_mesh % verticesOnCell, & + src_mesh % cellsOnVertex, src_mesh % latCell, src_mesh % lonCell, & + src_mesh % latVertex, src_mesh % lonVertex ) + remap_info % nearestVertex(ix, iy) = idx + end do + end do + + idx = 1 + do iy=1,dst_mesh % nlat + do ix=1,dst_mesh % nlon + idx = nearest_vertex(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), idx, & + src_mesh % nCells, src_mesh % nEdges, src_mesh % maxEdges, 2, & + src_mesh % nEdgesOnCell, src_mesh % edgesOnCell, & + src_mesh % cellsOnEdge, src_mesh % latCell, src_mesh % lonCell, & + src_mesh % latEdge, src_mesh % lonEdge ) + remap_info % nearestEdge(ix, iy) = idx + end do + end do + + + ! + ! For Wachspress interpolation + ! + allocate(vertCoords(3,3)) + + allocate(remap_info % cellWeights(3, dst_mesh % nlon, dst_mesh % nlat)) + allocate(remap_info % sourceCells(3, dst_mesh % nlon, dst_mesh % nlat)) + + idx = 1 + do iy=1,dst_mesh % nlat + do ix=1,dst_mesh % nlon + idx = nearest_vertex(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), idx, & + src_mesh % nCells, src_mesh % nVertices, src_mesh % maxEdges, 3, & + src_mesh % nEdgesOnCell, src_mesh % verticesOnCell, & + src_mesh % cellsOnVertex, src_mesh % latCell, src_mesh % lonCell, & + src_mesh % latVertex, src_mesh % lonVertex ) + remap_info % sourceCells(:,ix,iy) = src_mesh % cellsOnVertex(:,idx) + pointInterp(:) = convert_lx(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), 6371229.0) + do j=1,3 + vertCoords(:,j) = convert_lx(src_mesh % latCell(src_mesh % cellsOnVertex(j,idx)), & + src_mesh % lonCell(src_mesh % cellsOnVertex(j,idx)), & + 6371229.0) + end do + remap_info % cellWeights(:,ix,iy) = mpas_wachspress_coordinates(3, vertCoords, pointInterp) + end do + end do + + deallocate(vertCoords) + + + allocate(vertCoords(3,src_mesh % maxEdges)) + + allocate(remap_info % vertexWeights(src_mesh % maxEdges, dst_mesh % nlon, dst_mesh % nlat)) + allocate(remap_info % sourceVertices(src_mesh % maxEdges, dst_mesh % nlon, dst_mesh % nlat)) + + idx = 1 + do iy=1,dst_mesh % nlat + do ix=1,dst_mesh % nlon + idx = nearest_cell(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), idx, & + src_mesh % nCells, src_mesh % maxEdges, & + src_mesh % nEdgesOnCell, src_mesh % cellsOnCell, src_mesh % latCell, src_mesh % lonCell) + nn = src_mesh % nEdgesOnCell(idx) + remap_info % sourceVertices(:,ix,iy) = 1 + remap_info % sourceVertices(1:nn,ix,iy) = src_mesh % verticesOnCell(1:nn,idx) + pointInterp(:) = convert_lx(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), 6371229.0) + do j=1,nn + vertCoords(:,j) = convert_lx(src_mesh % latVertex(src_mesh % verticesOnCell(j,idx)), & + src_mesh % lonVertex(src_mesh % verticesOnCell(j,idx)), & + 6371229.0) + end do + remap_info % vertexWeights(:,ix,iy) = 0.0 + remap_info % vertexWeights(1:nn,ix,iy) = mpas_wachspress_coordinates(3, vertCoords(:,1:nn), pointInterp) + end do + end do + + deallocate(vertCoords) + + + allocate(vertCoords(3,src_mesh % maxEdges)) + + allocate(remap_info % edgeWeights(src_mesh % maxEdges, dst_mesh % nlon, dst_mesh % nlat)) + allocate(remap_info % sourceEdges(src_mesh % maxEdges, dst_mesh % nlon, dst_mesh % nlat)) + + idx = 1 + do iy=1,dst_mesh % nlat + do ix=1,dst_mesh % nlon + idx = nearest_cell(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), idx, & + src_mesh % nCells, src_mesh % maxEdges, & + src_mesh % nEdgesOnCell, src_mesh % cellsOnCell, src_mesh % latCell, src_mesh % lonCell) + nn = src_mesh % nEdgesOnCell(idx) + remap_info % sourceEdges(:,ix,iy) = 1 + remap_info % sourceEdges(1:nn,ix,iy) = src_mesh % edgesOnCell(1:nn,idx) + pointInterp(:) = convert_lx(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), 6371229.0) + do j=1,nn + vertCoords(:,j) = convert_lx(src_mesh % latEdge(src_mesh % edgesOnCell(j,idx)), & + src_mesh % lonEdge(src_mesh % edgesOnCell(j,idx)), & + 6371229.0) + end do + remap_info % edgeWeights(:,ix,iy) = 0.0 + remap_info % edgeWeights(1:nn,ix,iy) = mpas_wachspress_coordinates(3, vertCoords(:,1:nn), pointInterp) + end do + end do + + deallocate(vertCoords) + + + ! + ! For masked interpolation + ! + allocate(vertCoords(3,3)) + + allocate(remap_info % cellMaskedWeights(3, dst_mesh % nlon, dst_mesh % nlat)) + allocate(remap_info % sourceMaskedCells(3, dst_mesh % nlon, dst_mesh % nlat)) + + idx = 1 + do iy=1,dst_mesh % nlat + do ix=1,dst_mesh % nlon + idx = nearest_vertex(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), idx, & + src_mesh % nCells, src_mesh % nVertices, src_mesh % maxEdges, 3, & + src_mesh % nEdgesOnCell, src_mesh % verticesOnCell, & + src_mesh % cellsOnVertex, src_mesh % latCell, src_mesh % lonCell, & + src_mesh % latVertex, src_mesh % lonVertex ) + remap_info % sourceMaskedCells(:,ix,iy) = src_mesh % cellsOnVertex(:,idx) + pointInterp(:) = convert_lx(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), 6371229.0) + do j=1,3 + vertCoords(:,j) = convert_lx(src_mesh % latCell(src_mesh % cellsOnVertex(j,idx)), & + src_mesh % lonCell(src_mesh % cellsOnVertex(j,idx)), & + 6371229.0) + end do + remap_info % cellMaskedWeights(:,ix,iy) = mpas_wachspress_coordinates(3, vertCoords, pointInterp) + sumWeights = 0.0 + do j=1,3 + if (src_mesh % landmask(remap_info % sourceMaskedCells(j,ix,iy)) == 1) then + sumWeights = sumWeights + remap_info % cellMaskedWeights(j,ix,iy) + else + remap_info % cellMaskedWeights(j,ix,iy) = 0.0 + end if + end do + if (sumWeights > 0.0) then + remap_info % cellMaskedWeights(:,ix,iy) = remap_info % cellMaskedWeights(:,ix,iy) / sumWeights + else + idx = nearest_cell(dst_mesh % lats(index2d(irank,ix),iy), dst_mesh % lons(ix,index2d(irank,iy)), & + remap_info % sourceMaskedCells(1,ix,iy), & + src_mesh % nCells, src_mesh % maxEdges, & + src_mesh % nEdgesOnCell, src_mesh % cellsOnCell, src_mesh % latCell, src_mesh % lonCell) + call search_for_cells(src_mesh % nCells, src_mesh % maxEdges, src_mesh % nEdgesOnCell, src_mesh % cellsOnCell, & + src_mesh % landmask, dst_mesh % lats(index2d(irank,ix),iy), & + dst_mesh % lons(ix,index2d(irank,iy)), & + src_mesh % latCell, src_mesh % lonCell, idx, remap_info % sourceMaskedCells(:,ix,iy), & + remap_info % cellMaskedWeights(:,ix,iy)) + end if + end do + end do + + deallocate(vertCoords) + + end function remap_info_setup + + + integer function remap_info_free(remap_info) result(stat) + + implicit none + + type (remap_info_type), intent(inout) :: remap_info + + + stat = 0 + + remap_info % method = -1 + nullify(remap_info % src_mesh) + nullify(remap_info % dst_mesh) + + if (associated(remap_info % nearestCell)) then + deallocate(remap_info % nearestCell) + end if + if (associated(remap_info % nearestVertex)) then + deallocate(remap_info % nearestVertex) + end if + if (associated(remap_info % nearestEdge)) then + deallocate(remap_info % nearestEdge) + end if + if (associated(remap_info % cellWeights)) then + deallocate(remap_info % cellWeights) + end if + if (associated(remap_info % vertexWeights)) then + deallocate(remap_info % vertexWeights) + end if + if (associated(remap_info % edgeWeights)) then + deallocate(remap_info % edgeWeights) + end if + if (associated(remap_info % sourceCells)) then + deallocate(remap_info % sourceCells) + end if + if (associated(remap_info % sourceVertices)) then + deallocate(remap_info % sourceVertices) + end if + if (associated(remap_info % sourceEdges)) then + deallocate(remap_info % sourceEdges) + end if + if (associated(remap_info % cellMaskedWeights)) then + deallocate(remap_info % cellMaskedWeights) + end if + if (associated(remap_info % sourceMaskedCells)) then + deallocate(remap_info % sourceMaskedCells) + end if + + end function remap_info_free + + + logical function can_remap_field(field) + + implicit none + + type (input_field_type), intent(in) :: field + + integer :: decompDim + + + can_remap_field = .true. + + if (field % xtype /= FIELD_TYPE_INTEGER .and. & + field % xtype /= FIELD_TYPE_REAL .and. & + field % xtype /= FIELD_TYPE_DOUBLE) then + can_remap_field = .false. + return + end if + + if (field % ndims == 0 .or. & + (field % ndims == 1 .and. field % isTimeDependent)) then + can_remap_field = .false. + return + end if + + decompDim = field % ndims + if (field % isTimeDependent) then + decompDim = decompDim - 1 + end if + + if (trim(field % dimnames(decompDim)) /= 'nCells' .and. & + trim(field % dimnames(decompDim)) /= 'nVertices' .and. & + trim(field % dimnames(decompDim)) /= 'nEdges') then + + can_remap_field = .false. + return + end if + + end function can_remap_field + + + integer function remap_field_dryrun(remap_info, src_field, dst_field) result(stat) + + implicit none + + type (remap_info_type), intent(in) :: remap_info + type (input_field_type), intent(in) :: src_field + type (target_field_type), intent(out) :: dst_field + + integer :: idim + + stat = 0 + + dst_field % name = src_field % name + dst_field % xtype = src_field % xtype + if (src_field % isTimeDependent) then + ! Single horizontal dimension becomes two horizontal dimensions, nlat and nlon, + ! but the time dimension is not counted in the target field + dst_field % ndims = src_field % ndims + else + ! Single horizontal dimension becomes two horizontal dimensions, nlat and nlon + dst_field % ndims = src_field % ndims + 1 + end if + allocate(dst_field % dimnames(dst_field % ndims)) + allocate(dst_field % dimlens(dst_field % ndims)) + dst_field % isTimeDependent = src_field % isTimeDependent + do idim=1,dst_field % ndims-2 + dst_field % dimlens(idim) = src_field % dimlens(idim) + dst_field % dimnames(idim) = src_field % dimnames(idim) + end do + + dst_field % dimlens(dst_field % ndims-1) = remap_info % dst_mesh % nlon + dst_field % dimnames(dst_field % ndims-1) = 'nLons' + dst_field % dimlens(dst_field % ndims) = remap_info % dst_mesh % nlat + dst_field % dimnames(dst_field % ndims) = 'nLats' + + end function remap_field_dryrun + + + integer function remap_field(remap_info, src_field, dst_field, masked) result(stat) + + implicit none + + type (remap_info_type), intent(in) :: remap_info + type (input_field_type), intent(in) :: src_field + type (target_field_type), intent(out) :: dst_field + logical, intent(in), optional :: masked + + integer :: decompDim + integer :: idim + integer :: j + integer :: iy, ix + logical :: local_masked + integer, dimension(:,:), pointer :: nearestIndex + integer, dimension(:,:,:), pointer :: sourceNodes + real, dimension(:,:,:), pointer :: nodeWeights + + stat = 0 + + decompDim = src_field % ndims + if (src_field % isTimeDependent) then + decompDim = decompDim - 1 + end if + + local_masked = .false. + if (present(masked)) then + local_masked = masked + end if + + if (trim(src_field % dimnames(decompDim)) == 'nCells') then + nearestIndex => remap_info % nearestCell + if (local_masked) then + sourceNodes => remap_info % sourceMaskedCells + nodeWeights => remap_info % cellMaskedWeights + else + sourceNodes => remap_info % sourceCells + nodeWeights => remap_info % cellWeights + end if + else if (trim(src_field % dimnames(decompDim)) == 'nVertices') then + nearestIndex => remap_info % nearestVertex + sourceNodes => remap_info % sourceVertices + nodeWeights => remap_info % vertexWeights + else if (trim(src_field % dimnames(decompDim)) == 'nEdges') then + nearestIndex => remap_info % nearestEdge + sourceNodes => remap_info % sourceEdges + nodeWeights => remap_info % edgeWeights + else + write(0,*) 'Remap exception: unhandled decomposed dim' + stat = 1 + return + end if + + dst_field % name = src_field % name + dst_field % xtype = src_field % xtype + if (src_field % isTimeDependent) then + ! Single horizontal dimension becomes two horizontal dimensions, nlat and nlon, + ! but the time dimension is not counted in the target field + dst_field % ndims = src_field % ndims + else + ! Single horizontal dimension becomes two horizontal dimensions, nlat and nlon + dst_field % ndims = src_field % ndims + 1 + end if + allocate(dst_field % dimnames(dst_field % ndims)) + allocate(dst_field % dimlens(dst_field % ndims)) + dst_field % isTimeDependent = src_field % isTimeDependent + do idim=1,dst_field % ndims-2 + dst_field % dimlens(idim) = src_field % dimlens(idim) + dst_field % dimnames(idim) = src_field % dimnames(idim) + end do + dst_field % dimlens(dst_field % ndims-1) = remap_info % dst_mesh % nlon + dst_field % dimnames(dst_field % ndims-1) = 'nLons' + dst_field % dimlens(dst_field % ndims) = remap_info % dst_mesh % nlat + dst_field % dimnames(dst_field % ndims) = 'nLats' + + if (src_field % xtype == FIELD_TYPE_REAL) then + if (dst_field % ndims == 2) then + allocate(dst_field % array2r(dst_field % dimlens(1), & + dst_field % dimlens(2))) +#ifdef NEAREST_NEIGHBOR + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array2r(ix,iy) = src_field % array1r(nearestIndex(ix,iy)) + end do + end do +#else + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array2r(ix,iy) = 0.0 + do j=1,size(sourceNodes, dim=1) + dst_field % array2r(ix,iy) = dst_field % array2r(ix,iy) + & + nodeWeights(j,ix,iy) & + * src_field % array1r(sourceNodes(j,ix,iy)) + end do + end do + end do +#endif + else if (dst_field % ndims == 3) then + allocate(dst_field % array3r(dst_field % dimlens(1), & + dst_field % dimlens(2), & + dst_field % dimlens(3))) +#ifdef NEAREST_NEIGHBOR + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array3r(:,ix,iy) = src_field % array2r(:,nearestIndex(ix,iy)) + end do + end do +#else + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array3r(:,ix,iy) = 0.0 + do j=1,3 + dst_field % array3r(:,ix,iy) = dst_field % array3r(:,ix,iy) + & + nodeWeights(j,ix,iy) & + * src_field % array2r(:,sourceNodes(j,ix,iy)) + end do + end do + end do +#endif + else if (dst_field % ndims == 4) then + allocate(dst_field % array4r(dst_field % dimlens(1), & + dst_field % dimlens(2), & + dst_field % dimlens(3), & + dst_field % dimlens(4))) +#ifdef NEAREST_NEIGHBOR + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array4r(:,:,ix,iy) = src_field % array3r(:,:,nearestIndex(ix,iy)) + end do + end do +#endif + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array4r(:,:,ix,iy) = 0.0 + do j=1,3 + dst_field % array4r(:,:,ix,iy) = dst_field % array4r(:,:,ix,iy) + & + remap_info % cellWeights(j,ix,iy) & + * src_field % array3r(:,:,remap_info % sourceCells(j,ix,iy)) + end do + end do + end do + else + write(0,*) 'Remap exception: unhandled dimension for real ', dst_field % ndims + end if + else if (src_field % xtype == FIELD_TYPE_DOUBLE) then + if (dst_field % ndims == 2) then + allocate(dst_field % array2d(dst_field % dimlens(1), & + dst_field % dimlens(2))) +#ifdef NEAREST_NEIGHBOR + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array2d(ix,iy) = src_field % array1d(nearestIndex(ix,iy)) + end do + end do +#endif + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array2d(ix,iy) = 0.0 + do j=1,size(sourceNodes, dim=1) + dst_field % array2d(ix,iy) = dst_field % array2d(ix,iy) + & + nodeWeights(j,ix,iy) & + * src_field % array1d(sourceNodes(j,ix,iy)) + end do + end do + end do + else if (dst_field % ndims == 3) then + allocate(dst_field % array3d(dst_field % dimlens(1), & + dst_field % dimlens(2), & + dst_field % dimlens(3))) +#ifdef NEAREST_NEIGHBOR + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array3d(:,ix,iy) = src_field % array2d(:,nearestIndex(ix,iy)) + end do + end do +#endif + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array3d(:,ix,iy) = 0.0 + do j=1,3 + dst_field % array3d(:,ix,iy) = dst_field % array3d(:,ix,iy) + & + remap_info % cellWeights(j,ix,iy) & + * src_field % array2d(:,remap_info % sourceCells(j,ix,iy)) + end do + end do + end do + else if (dst_field % ndims == 4) then + allocate(dst_field % array4d(dst_field % dimlens(1), & + dst_field % dimlens(2), & + dst_field % dimlens(3), & + dst_field % dimlens(4))) +#ifdef NEAREST_NEIGHBOR + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array4d(:,:,ix,iy) = src_field % array3d(:,:,nearestIndex(ix,iy)) + end do + end do +#endif + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array4d(:,:,ix,iy) = 0.0 + do j=1,3 + dst_field % array4d(:,:,ix,iy) = dst_field % array4d(:,:,ix,iy) + & + remap_info % cellWeights(j,ix,iy) & + * src_field % array3d(:,:,remap_info % sourceCells(j,ix,iy)) + end do + end do + end do + else + write(0,*) 'Remap exception: unhandled dimension for dbl ', dst_field % ndims + end if + else if (src_field % xtype == FIELD_TYPE_INTEGER) then + if (dst_field % ndims == 2) then + allocate(dst_field % array2i(dst_field % dimlens(1), & + dst_field % dimlens(2))) + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array2i(ix,iy) = src_field % array1i(nearestIndex(ix,iy)) + end do + end do + else if (dst_field % ndims == 3) then + allocate(dst_field % array3i(dst_field % dimlens(1), & + dst_field % dimlens(2), & + dst_field % dimlens(3))) + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array3i(:,ix,iy) = src_field % array2i(:,nearestIndex(ix,iy)) + end do + end do + else if (dst_field % ndims == 4) then + allocate(dst_field % array4i(dst_field % dimlens(1), & + dst_field % dimlens(2), & + dst_field % dimlens(3), & + dst_field % dimlens(4))) + do iy=1,size(nearestIndex, dim=2) + do ix=1,size(nearestIndex, dim=1) + dst_field % array4i(:,:,ix,iy) = src_field % array3i(:,:,nearestIndex(ix,iy)) + end do + end do + else + write(0,*) 'Remap exception: unhandled dimension for int ', dst_field % ndims + end if + else + write(0,*) 'Remap exception: unhandled type' + end if + + end function remap_field + + + integer function remap_get_target_latitudes(remap_info, lat_field) result(stat) + + implicit none + + type (remap_info_type), intent(in) :: remap_info + type (target_field_type), intent(out) :: lat_field + + real, parameter :: rad2deg = 90.0 / asin(1.0) + + stat = 0 + + + lat_field % name = 'lat' + lat_field % xtype = FIELD_TYPE_REAL + lat_field % ndims = 1 + lat_field % isTimeDependent = .false. + + allocate(lat_field % dimnames(lat_field % ndims)) + allocate(lat_field % dimlens(lat_field % ndims)) + + lat_field % dimnames(1) = 'nLats' + lat_field % dimlens(1) = remap_info % dst_mesh % nlat + + allocate(lat_field % array1r(lat_field % dimlens(1))) + lat_field % array1r(:) = remap_info % dst_mesh % lats(1,:) * rad2deg + + end function remap_get_target_latitudes + + + integer function remap_get_target_longitudes(remap_info, lon_field) result(stat) + + implicit none + + type (remap_info_type), intent(in) :: remap_info + type (target_field_type), intent(out) :: lon_field + + real, parameter :: rad2deg = 90.0 / asin(1.0) + + stat = 0 + + + lon_field % name = 'lon' + lon_field % xtype = FIELD_TYPE_REAL + lon_field % ndims = 1 + lon_field % isTimeDependent = .false. + + allocate(lon_field % dimnames(lon_field % ndims)) + allocate(lon_field % dimlens(lon_field % ndims)) + + lon_field % dimnames(1) = 'nLons' + lon_field % dimlens(1) = remap_info % dst_mesh % nlon + + allocate(lon_field % array1r(lon_field % dimlens(1))) + lon_field % array1r(:) = remap_info % dst_mesh % lons(:,1) * rad2deg + + end function remap_get_target_longitudes + + + integer function free_target_field(field) result(stat) + + implicit none + + type (target_field_type), intent(inout) :: field + + stat = 0 + + if (associated(field % dimlens)) then + deallocate(field % dimlens) + end if + if (associated(field % dimnames)) then + deallocate(field % dimnames) + end if + + if (associated(field % array1r)) then + deallocate(field % array1r) + end if + if (associated(field % array2r)) then + deallocate(field % array2r) + end if + if (associated(field % array3r)) then + deallocate(field % array3r) + end if + if (associated(field % array4r)) then + deallocate(field % array4r) + end if + + if (associated(field % array1d)) then + deallocate(field % array1d) + end if + if (associated(field % array2d)) then + deallocate(field % array2d) + end if + if (associated(field % array3d)) then + deallocate(field % array3d) + end if + if (associated(field % array4d)) then + deallocate(field % array4d) + end if + + if (associated(field % array1i)) then + deallocate(field % array1i) + end if + if (associated(field % array2i)) then + deallocate(field % array2i) + end if + if (associated(field % array3i)) then + deallocate(field % array3i) + end if + if (associated(field % array4i)) then + deallocate(field % array4i) + end if + + end function free_target_field + + + integer function nearest_cell(target_lat, target_lon, start_cell, nCells, maxEdges, & + nEdgesOnCell, cellsOnCell, latCell, lonCell) + + implicit none + + real, intent(in) :: target_lat, target_lon + integer, intent(in) :: start_cell + integer, intent(in) :: nCells, maxEdges + integer, dimension(nCells), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells), intent(in) :: cellsOnCell + real, dimension(nCells), intent(in) :: latCell, lonCell + + integer :: i + integer :: iCell + integer :: current_cell + real :: current_distance, d + real :: nearest_distance + + nearest_cell = start_cell + current_cell = -1 + + do while (nearest_cell /= current_cell) + current_cell = nearest_cell + current_distance = sphere_distance(latCell(current_cell), lonCell(current_cell), target_lat, & + target_lon, 1.0) + nearest_cell = current_cell + nearest_distance = current_distance + do i = 1, nEdgesOnCell(current_cell) + iCell = cellsOnCell(i,current_cell) + if (iCell <= nCells) then + d = sphere_distance(latCell(iCell), lonCell(iCell), target_lat, target_lon, 1.0) + if (d < nearest_distance) then + nearest_cell = iCell + nearest_distance = d + end if + end if + end do + end do + + end function nearest_cell + + + integer function nearest_vertex( target_lat, target_lon, & + start_vertex, & + nCells, nVertices, maxEdges, vertexDegree, & + nEdgesOnCell, verticesOnCell, & + cellsOnVertex, latCell, lonCell, & + latVertex, lonVertex ) + + implicit none + + real, intent(in) :: target_lat, target_lon + integer, intent(in) :: start_vertex + integer, intent(in) :: nCells, nVertices, maxEdges, vertexDegree + integer, dimension(nCells), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells), intent(in) :: verticesOnCell + integer, dimension(vertexDegree,nVertices), intent(in) :: cellsOnVertex + real, dimension(nCells), intent(in) :: latCell, lonCell + real, dimension(nVertices), intent(in) :: latVertex, lonVertex + + + integer :: i, cell1, cell2, cell3, iCell + integer :: iVtx + integer :: current_vertex + real :: cell1_dist, cell2_dist, cell3_dist + real :: current_distance, d + real :: nearest_distance + + nearest_vertex = start_vertex + current_vertex = -1 + + do while (nearest_vertex /= current_vertex) + current_vertex = nearest_vertex + current_distance = sphere_distance(latVertex(current_vertex), lonVertex(current_vertex), & + target_lat, target_lon, 1.0) + nearest_vertex = current_vertex + nearest_distance = current_distance + cell1 = cellsOnVertex(1,current_vertex) + cell1_dist = sphere_distance(latCell(cell1), lonCell(cell1), target_lat, target_lon, 1.0) + cell2 = cellsOnVertex(2,current_vertex) + cell2_dist = sphere_distance(latCell(cell2), lonCell(cell2), target_lat, target_lon, 1.0) + if (vertexDegree == 3) then + cell3 = cellsOnVertex(3,current_vertex) + cell3_dist = sphere_distance(latCell(cell3), lonCell(cell3), target_lat, target_lon, 1.0) + end if + if (vertexDegree == 3) then + if (cell1_dist < cell2_dist) then + if (cell1_dist < cell3_dist) then + iCell = cell1 + else + iCell = cell3 + end if + else + if (cell2_dist < cell3_dist) then + iCell = cell2 + else + iCell = cell3 + end if + end if + else + if (cell1_dist < cell2_dist) then + iCell = cell1 + else + iCell = cell2 + end if + end if + do i = 1, nEdgesOnCell(iCell) + iVtx = verticesOnCell(i,iCell) + d = sphere_distance(latVertex(iVtx), lonVertex(iVtx), target_lat, target_lon, 1.0) + if (d < nearest_distance) then + nearest_vertex = iVtx + nearest_distance = d + end if + end do + end do + + end function nearest_vertex + + + real function sphere_distance(lat1, lon1, lat2, lon2, radius) + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Compute the great-circle distance between (lat1, lon1) and (lat2, lon2) on a + ! sphere with given radius. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + implicit none + + real, intent(in) :: lat1, lon1, lat2, lon2, radius + + real :: arg1 + + arg1 = sqrt( sin(0.5*(lat2-lat1))**2 + & + cos(lat1)*cos(lat2)*sin(0.5*(lon2-lon1))**2 ) + sphere_distance = 2.*radius*asin(arg1) + + end function sphere_distance + + + !*********************************************************************** + ! + ! function mpas_wachspress_coordinates + ! + !> \brief Compute the barycentric Wachspress coordinates for a polygon + !> \author Phillip Wolfram + !> \date 01/26/2015 + !> \details + !> Computes the barycentric Wachspress coordinates for a polygon with nVertices + !> points in R3, vertCoords for a particular pointInterp with normalized radius. + !> Follows Gillette, A., Rand, A., Bajaj, C., 2011. + !> Error estimates for generalized barycentric interpolation. + !> Advances in computational mathematics 37 (3), 417–439. + !> Optimized version of mpas_wachspress_coordinates uses optional cached B_i areas + !------------------------------------------------------------------------ + function mpas_wachspress_coordinates(nVertices, vertCoords, pointInterp, areaBin) + + implicit none + + ! input points + integer, intent(in) :: nVertices + real, dimension(3, nVertices), intent(in) :: vertCoords + real, dimension(3), intent(in) :: pointInterp + real, dimension(nVertices), optional, intent(in) :: areaBin + + ! output + real, dimension(nVertices) :: mpas_wachspress_coordinates + + ! computational intermediates + real, dimension(nVertices) :: wach ! The wachpress area-product + real :: wach_total ! The wachpress total weight + integer :: i, j ! Loop indices + integer :: im1, i0, ip1 ! im1 = (i-1), i0 = i, ip1 = (i+1) + + ! triangle areas to compute wachspress coordinate + real, dimension(nVertices) :: areaA + real, dimension(nVertices) :: areaB + + real :: radiusLocal + + radiusLocal = sqrt(sum(vertCoords(:,1)**2)) + + if (.not. present(areaBin)) then + ! compute areas + do i = 1, nVertices + ! compute first area B_i + ! get vertex indices + im1 = mod(nVertices + i - 2, nVertices) + 1 + i0 = mod(nVertices + i - 1, nVertices) + 1 + ip1 = mod(nVertices + i , nVertices) + 1 + + ! precompute B_i areas + ! always the same because B_i independent of xp,yp,zp + ! (COULD CACHE AND USE RESULT FROM ARRAY FOR FURTHER OPTIMIZATION) + areaB(i) = mpas_triangle_signed_area_sphere(vertCoords(:, im1), vertCoords(:, i0), vertCoords(:, ip1), radiusLocal) + end do + else + ! assign areas + do i = 1, nVertices + areaB(i) = areaBin(i) + end do + end if + + ! compute areas + do i = 1, nVertices + ! compute first area B_i + ! get vertex indices + im1 = mod(nVertices + i - 2, nVertices) + 1 + i0 = mod(nVertices + i - 1, nVertices) + 1 + ip1 = mod(nVertices + i , nVertices) + 1 + + ! compute A_ij areas + ! must be computed each time + areaA(i0) = mpas_triangle_signed_area_sphere(pointInterp, vertCoords(:, i0), vertCoords(:, ip1), radiusLocal) + + ! precomputed B_i areas, cached + end do + + + ! for each vertex compute wachpress coordinate + do i = 1, nVertices + wach(i) = areaB(i) + do j = (i + 1), (i + nVertices - 2) + i0 = mod(nVertices + j - 1, nVertices) + 1 + ! accumulate products for A_ij subareas + wach(i) = wach(i) * areaA(i0) + end do + end do + + ! get summed weights for normalization + wach_total = 0 + do i = 1, nVertices + wach_total = wach_total + wach(i) + end do + + ! compute lambda + mpas_wachspress_coordinates= 0.0 + do i = 1, nVertices + mpas_wachspress_coordinates(i) = wach(i)/wach_total + end do + + end function mpas_wachspress_coordinates + + + !*********************************************************************** + ! + ! routine mpas_triangle_signed_area_sphere + ! + !> \brief Calculates area of a triangle on a sphere + !> \author Matthew Hoffman + !> \date 13 January 2015 + !> \details + !> This routine calculates the area of a triangle on the surface of a sphere. + !> Uses the spherical analog of Heron's formula. + !> Copied from mesh generator. A CCW winding angle is positive. + !----------------------------------------------------------------------- + real function mpas_triangle_signed_area_sphere(a, b, c, radius) + + implicit none + + !----------------------------------------------------------------- + ! input variables + !----------------------------------------------------------------- + real, dimension(3), intent(in) :: a, b, c !< Input: 3d (x,y,z) points forming the triangle in which to calculate the bary weights + real, intent(in) :: radius !< sphere radius + + !----------------------------------------------------------------- + ! local variables + !----------------------------------------------------------------- + real :: ab, bc, ca, semiperim, tanqe + real, dimension(3) :: ablen, aclen, Dlen + + ab = mpas_arc_length(a(1), a(2), a(3), b(1), b(2), b(3))/radius + bc = mpas_arc_length(b(1), b(2), b(3), c(1), c(2), c(3))/radius + ca = mpas_arc_length(c(1), c(2), c(3), a(1), a(2), a(3))/radius + semiperim = 0.5 * (ab + bc + ca) + + tanqe = sqrt(max(0.0,tan(0.5 * semiperim) * tan(0.5 * (semiperim - ab)) & + * tan(0.5 * (semiperim - bc)) * tan(0.5 * (semiperim - ca)))) + + mpas_triangle_signed_area_sphere = 4.0 * radius * radius * atan(tanqe) + + ! computing correct signs (in similar fashion to mpas_sphere_angle) + ablen(1) = b(1) - a(1) + ablen(2) = b(2) - a(2) + ablen(3) = b(3) - a(3) + + aclen(1) = c(1) - a(1) + aclen(2) = c(2) - a(2) + aclen(3) = c(3) - a(3) + + dlen(1) = (ablen(2) * aclen(3)) - (ablen(3) * aclen(2)) + dlen(2) = -((ablen(1) * aclen(3)) - (ablen(3) * aclen(1))) + dlen(3) = (ablen(1) * aclen(2)) - (ablen(2) * aclen(1)) + + if ((Dlen(1)*a(1) + Dlen(2)*a(2) + Dlen(3)*a(3)) < 0.0) then + mpas_triangle_signed_area_sphere = -mpas_triangle_signed_area_sphere + end if + + end function mpas_triangle_signed_area_sphere + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! FUNCTION MPAS_ARC_LENGTH + ! + ! Returns the length of the great circle arc from A=(ax, ay, az) to + ! B=(bx, by, bz). It is assumed that both A and B lie on the surface of the + ! same sphere centered at the origin. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + real function mpas_arc_length(ax, ay, az, bx, by, bz) + + implicit none + + real, intent(in) :: ax, ay, az, bx, by, bz + + real :: r, c + real :: cx, cy, cz + + cx = bx - ax + cy = by - ay + cz = bz - az + + r = sqrt(ax*ax + ay*ay + az*az) + c = sqrt(cx*cx + cy*cy + cz*cz) + + mpas_arc_length = r * 2.0 * asin(c/(2.0*r)) + + end function mpas_arc_length + + + function convert_lx(lat, lon, radius) result(vec) + + implicit none + + real, intent(in) :: lat, lon, radius + + real, dimension(3) :: vec + + vec(1) = radius * cos(lon) * cos(lat) + vec(2) = radius * sin(lon) * cos(lat) + vec(3) = radius * sin(lat) + + end function convert_lx + + + subroutine search_for_cells(nCells, maxEdges, nEdgesOnCell, cellsOnCell, cellMask, & + targetLat, targetLon, latCell, lonCell, & + startIdx, sourceMaskedCells, cellMaskedWeights) + + implicit none + + integer, intent(in) :: nCells + integer, intent(in) :: maxEdges + integer, dimension(nCells), intent(in) :: nEdgesOnCell + integer, dimension(maxEdges,nCells), intent(in) :: cellsOnCell + integer, dimension(nCells), intent(in) :: cellMask + real, intent(in) :: targetLat + real, intent(in) :: targetLon + real, dimension(nCells), intent(in) :: latCell + real, dimension(nCells), intent(in) :: lonCell + integer, intent(in) :: startIdx + integer, dimension(3), intent(inout) :: sourceMaskedCells + real, dimension(3), intent(inout) :: cellMaskedWeights + + integer :: i + integer :: scan_cell + integer :: neighbor + integer :: unscanned + logical :: no_more_queueing + real :: d, d_min + + ! + ! Reset data structures + ! + call queue_reset() + call dictionary_reset() + + no_more_queueing = .false. + unscanned = 0 + + d_min = 1000.0 + + sourceMaskedCells(:) = 1 + cellMaskedWeights(:) = 0.0 + + ! + ! Insert the origin cell into the queue for processing + ! + call queue_insert(startIdx) + call dictionary_insert(startIdx) + + do while (queue_size > 0) + scan_cell = queue_remove() + + ! + ! Each cell index removed from the queue represents a unique grid cell + ! that falls within the specified radius of the origin point + ! Here, we can do any processing we like for these cells + ! + if (cellMask(scan_cell) == 1) then + d = sphere_distance(targetLat, targetLon, latCell(scan_cell), lonCell(scan_cell), 1.0) + if (d < d_min) then + d_min = d + sourceMaskedCells(1) = scan_cell + cellMaskedWeights(1) = 1.0 + if (.not. no_more_queueing) then + unscanned = queue_size + end if + no_more_queueing = .true. + end if + end if + + ! + ! Add any neighbors of scan_cell within specified radius to the queue for processing + ! + if (.not. no_more_queueing .or. unscanned > 0) then + do i=1,nEdgesOnCell(scan_cell) + neighbor = cellsOnCell(i,scan_cell) + if (.not. dictionary_search(neighbor)) then + call queue_insert(neighbor) + call dictionary_insert(neighbor) + end if + end do + end if + + if (no_more_queueing) then + unscanned = unscanned - 1 + end if + + end do + + end subroutine search_for_cells + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Insert a new integer into the queue + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine queue_insert(i) + + implicit none + + integer, intent(in) :: i + + if (queue_size == max_queue_length) then + write(0,*) 'Error: queue overrun' + return + end if + queue_size = queue_size + 1 + queue_array(queue_head) = i + queue_head = mod(queue_head + 1, max_queue_length) + + end subroutine queue_insert + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Remove the oldest integer from the queue + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + integer function queue_remove() + + implicit none + + if (queue_size <= 0) then + write(0,*) 'Error: queue underrun' + queue_remove = -1 + return + end if + queue_size = queue_size - 1 + queue_remove = queue_array(queue_tail) + queue_tail = mod(queue_tail + 1, max_queue_length) + + end function queue_remove + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Reset the queue to an empty state + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine queue_reset() + + implicit none + + queue_head = 0 + queue_tail = 0 + queue_size = 0 + + end subroutine queue_reset + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Insert an integer into the dictionary + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine dictionary_insert(i) + + implicit none + + integer, intent(in) :: i + + integer :: n_integer + integer :: n_bit + + n_integer = ((i-1) / int_size) + 1 + n_bit = mod((i-1), int_size) + + if (n_integer > max_dictionary_size) then + write(0,*) 'Error: dictionary insert out of bounds' + return + end if + + dictionary_array(n_integer) = ibset(dictionary_array(n_integer), n_bit) + + end subroutine dictionary_insert + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Search for an integer in the dictionary + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + logical function dictionary_search(i) + + implicit none + + integer, intent(in) :: i + + integer :: n_integer + integer :: n_bit + + n_integer = ((i-1) / int_size) + 1 + n_bit = mod((i-1), int_size) + + if (n_integer > max_dictionary_size) then + write(0,*) 'Error: dictionary search out of bounds' + dictionary_search = .false. + return + end if + + dictionary_search = btest(dictionary_array(n_integer), n_bit) + + end function dictionary_search + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Reset the dictionary to an empty state + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine dictionary_reset() + + implicit none + + dictionary_array(:) = 0 + + end subroutine dictionary_reset + + + function index2d(irank, idx) result(i) + + implicit none + + integer, intent(in) :: irank, idx + + integer :: i + + i = irank * (idx - 1) + 1 + + end function index2d + +end module remapper diff --git a/WPS/metgrid/src/rotate_winds_module.F b/WPS/metgrid/src/rotate_winds_module.F new file mode 100644 index 00000000..8ce07ce0 --- /dev/null +++ b/WPS/metgrid/src/rotate_winds_module.F @@ -0,0 +1,595 @@ +module rotate_winds_module + + use bitarray_module + use constants_module + use llxy_module + use misc_definitions_module + use module_debug + + integer :: orig_selected_projection + + contains + + ! + ! ARW Wind Rotation Code + ! + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: map_to_met ! + ! ! + ! Purpose: Rotate grid-relative winds to Earth-relative winds ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine map_to_met(u, u_mask, v, v_mask, & + us1, us2, ue1, ue2, & + vs1, vs2, ve1, ve2, & + xlon_u, xlon_v, xlat_u, xlat_v) + + implicit none + + ! Arguments + integer, intent(in) :: us1, us2, ue1, ue2, vs1, vs2, ve1, ve2 + real, pointer, dimension(:,:) :: u, v, xlon_u, xlon_v, xlat_u, xlat_v + type (bitarray), intent(in) :: u_mask, v_mask + + orig_selected_projection = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call metmap_xform(u, u_mask, v, v_mask, & + us1, us2, ue1, ue2, & + vs1, vs2, ve1, ve2, & + xlon_u, xlon_v, xlat_u, xlat_v, 1) + call select_domain(orig_selected_projection) + + end subroutine map_to_met + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: met_to_map ! + ! ! + ! Purpose: Rotate Earth-relative winds to grid-relative winds ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine met_to_map(u, u_mask, v, v_mask, & + us1, us2, ue1, ue2, & + vs1, vs2, ve1, ve2, & + xlon_u, xlon_v, xlat_u, xlat_v) + + implicit none + + ! Arguments + integer, intent(in) :: us1, us2, ue1, ue2, vs1, vs2, ve1, ve2 + real, pointer, dimension(:,:) :: u, v, xlon_u, xlon_v, xlat_u, xlat_v + type (bitarray), intent(in) :: u_mask, v_mask + + orig_selected_projection = iget_selected_domain() + call select_domain(1) + call metmap_xform(u, u_mask, v, v_mask, & + us1, us2, ue1, ue2, & + vs1, vs2, ve1, ve2, & + xlon_u, xlon_v, xlat_u, xlat_v, -1) + call select_domain(orig_selected_projection) + + end subroutine met_to_map + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: metmap_xform ! + ! ! + ! Purpose: Do the actual work of rotating winds for C grid. ! + ! If idir= 1, rotate grid-relative winds to Earth-relative winds ! + ! If idir=-1, rotate Earth-relative winds to grid-relative winds ! + ! ! + ! ASSUMPTIONS: 1) MEMORY ORDER IS XY. ! + ! 2) U ARRAY HAS ONE MORE COLUMN THAN THE V ARRAY, AND V ARRAY ! + ! HAS ONE MORE ROW THAN U ARRAY. ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine metmap_xform(u, u_mask, v, v_mask, & + us1, us2, ue1, ue2, vs1, vs2, ve1, ve2, & + xlon_u, xlon_v, xlat_u, xlat_v, idir) + + implicit none + + ! Arguments + integer, intent(in) :: us1, us2, ue1, ue2, vs1, vs2, ve1, ve2, idir + real, pointer, dimension(:,:) :: u, v, xlon_u, xlon_v, xlat_u, xlat_v + type (bitarray), intent(in) :: u_mask, v_mask + + ! Local variables + integer :: i, j + real :: u_weight, v_weight + real :: u_map, v_map, alpha, diff + real, pointer, dimension(:,:) :: u_new, v_new, u_mult, v_mult + logical :: do_last_col_u, do_last_row_u, do_last_col_v, do_last_row_v + + ! If the proj_info structure has not been initialized, we don't have + ! information about the projection and standard longitude. + if (proj_stack(current_nest_number)%init) then + + ! Only rotate winds for Lambert conformal, polar stereographic, or Cassini + if ((proj_stack(current_nest_number)%code == PROJ_LC) .or. & + (proj_stack(current_nest_number)%code == PROJ_PS) .or. & + (proj_stack(current_nest_number)%code == PROJ_CASSINI)) then + call mprintf((idir == 1),LOGFILE,'Rotating map winds to earth winds.') + call mprintf((idir == -1),LOGFILE,'Rotating earth winds to grid winds') + + allocate(u_mult(us1:ue1,us2:ue2)) + allocate(v_mult(vs1:ve1,vs2:ve2)) + + do j=us2,ue2 + do i=us1,ue1 + if (bitarray_test(u_mask, i-us1+1, j-us2+1)) then + u_mult(i,j) = 1. + else + u_mult(i,j) = 0. + end if + end do + end do + + do j=vs2,ve2 + do i=vs1,ve1 + if (bitarray_test(v_mask, i-vs1+1, j-vs2+1)) then + v_mult(i,j) = 1. + else + v_mult(i,j) = 0. + end if + end do + end do + + if (ue1-us1 == ve1-vs1) then + do_last_col_u = .false. + do_last_col_v = .true. + else + do_last_col_u = .true. + do_last_col_v = .false. + end if + + if (ue2-us2 == ve2-vs2) then + do_last_row_u = .true. + do_last_row_v = .false. + else + do_last_row_u = .false. + do_last_row_v = .true. + end if + + ! Create arrays to hold rotated winds + allocate(u_new(us1:ue1, us2:ue2)) + allocate(v_new(vs1:ve1, vs2:ve2)) + + ! Rotate U field + do j=us2,ue2 + do i=us1,ue1 + + diff = idir * (xlon_u(i,j) - proj_stack(current_nest_number)%stdlon) + if (diff > 180.) then + diff = diff - 360. + else if (diff < -180.) then + diff = diff + 360. + end if + + ! Calculate the rotation angle, alpha, in radians + if (proj_stack(current_nest_number)%code == PROJ_LC) then + alpha = diff * proj_stack(current_nest_number)%cone * rad_per_deg * proj_stack(current_nest_number)%hemi + else if (proj_stack(current_nest_number)%code == PROJ_CASSINI) then + if (j == ue2) then + diff = xlon_u(i,j)-xlon_u(i,j-1) + if (diff > 180.) then + diff = diff - 360. + else if (diff < -180.) then + diff = diff + 360. + end if + alpha = atan2( (-cos(xlat_u(i,j)*rad_per_deg) * diff*rad_per_deg), & + (xlat_u(i,j)-xlat_u(i,j-1))*rad_per_deg & + ) + else if (j == us2) then + diff = xlon_u(i,j+1)-xlon_u(i,j) + if (diff > 180.) then + diff = diff - 360. + else if (diff < -180.) then + diff = diff + 360. + end if + alpha = atan2( (-cos(xlat_u(i,j)*rad_per_deg) * diff*rad_per_deg), & + (xlat_u(i,j+1)-xlat_u(i,j))*rad_per_deg & + ) + else + diff = xlon_u(i,j+1)-xlon_u(i,j-1) + if (diff > 180.) then + diff = diff - 360. + else if (diff < -180.) then + diff = diff + 360. + end if + alpha = atan2( (-cos(xlat_u(i,j)*rad_per_deg) * diff*rad_per_deg), & + (xlat_u(i,j+1)-xlat_u(i,j-1))*rad_per_deg & + ) + end if + else + alpha = diff * rad_per_deg * proj_stack(current_nest_number)%hemi + end if + + v_weight = 0. + + ! On C grid, take U_ij, and get V value at the same lat/lon + ! by averaging the four surrounding V points + if (bitarray_test(u_mask, i-us1+1, j-us2+1)) then + u_map = u(i,j) + if (i == us1) then + if (j == ue2 .and. do_last_row_u) then + v_weight = v_mult(i,j) + v_map = v(i,j)*v_mult(i,j) + else + v_weight = v_mult(i,j) + v_mult(i,j+1) + v_map = v(i,j)*v_mult(i,j) + v(i,j+1)*v_mult(i,j+1) + end if + else if (i == ue1 .and. do_last_col_u) then + if (j == ue2 .and. do_last_row_u) then + v_weight = v_mult(i-1,j) + v_map = v(i-1,j) + else + v_weight = v_mult(i-1,j) + v_mult(i-1,j+1) + v_map = v(i-1,j)*v_mult(i-1,j) + v(i-1,j+1)*v_mult(i-1,j+1) + end if + else if (j == ue2 .and. do_last_row_u) then + v_weight = v_mult(i-1,j-1) + v_mult(i,j-1) + v_map = v(i-1,j-1)*v_mult(i-1,j-1) + v(i,j-1)*v_mult(i,j-1) + else + v_weight = v_mult(i-1,j) + v_mult(i-1,j+1) + v_mult(i,j) + v_mult(i,j+1) + v_map = v(i-1,j)*v_mult(i-1,j) + v(i-1,j+1)*v_mult(i-1,j+1) + v(i,j)*v_mult(i,j) + v(i,j+1)*v_mult(i,j+1) + end if + if (v_weight > 0.) then + u_new(i,j) = cos(alpha)*u_map + sin(alpha)*v_map/v_weight + else + u_new(i,j) = u(i,j) + end if + else + u_new(i,j) = u(i,j) + end if + + end do + end do + + ! Rotate V field + do j=vs2,ve2 + do i=vs1,ve1 + + diff = idir * (xlon_v(i,j) - proj_stack(current_nest_number)%stdlon) + if (diff > 180.) then + diff = diff - 360. + else if (diff < -180.) then + diff = diff + 360. + end if + + if (proj_stack(current_nest_number)%code == PROJ_LC) then + alpha = diff * proj_stack(current_nest_number)%cone * rad_per_deg * proj_stack(current_nest_number)%hemi + else if (proj_stack(current_nest_number)%code == PROJ_CASSINI) then + if (j == ve2) then + diff = xlon_v(i,j)-xlon_v(i,j-1) + if (diff > 180.) then + diff = diff - 360. + else if (diff < -180.) then + diff = diff + 360. + end if + alpha = atan2( (-cos(xlat_v(i,j)*rad_per_deg) * diff*rad_per_deg), & + (xlat_v(i,j)-xlat_v(i,j-1))*rad_per_deg & + ) + else if (j == vs2) then + diff = xlon_v(i,j+1)-xlon_v(i,j) + if (diff > 180.) then + diff = diff - 360. + else if (diff < -180.) then + diff = diff + 360. + end if + alpha = atan2( (-cos(xlat_v(i,j)*rad_per_deg) * diff*rad_per_deg), & + (xlat_v(i,j+1)-xlat_v(i,j))*rad_per_deg & + ) + else + diff = xlon_v(i,j+1)-xlon_v(i,j-1) + if (diff > 180.) then + diff = diff - 360. + else if (diff < -180.) then + diff = diff + 360. + end if + alpha = atan2( (-cos(xlat_v(i,j)*rad_per_deg) * diff*rad_per_deg), & + (xlat_v(i,j+1)-xlat_v(i,j-1))*rad_per_deg & + ) + end if + else + alpha = diff * rad_per_deg * proj_stack(current_nest_number)%hemi + end if + + u_weight = 0. + + if (bitarray_test(v_mask, i-vs1+1, j-vs2+1)) then + v_map = v(i,j) + if (j == vs2) then + if (i == ve1 .and. do_last_col_v) then + u_weight = u_mult(i,j) + u_map = u(i,j)*u_mult(i,j) + else + u_weight = u_mult(i,j) + u_mult(i+1,j) + u_map = u(i,j)*u_mult(i,j) + u(i+1,j)*u_mult(i+1,j) + end if + else if (j == ve2 .and. do_last_row_v) then + if (i == ve1 .and. do_last_col_v) then + u_weight = u_mult(i,j-1) + u_map = u(i,j-1)*u_mult(i,j-1) + else + u_weight = u_mult(i,j-1) + u_mult(i+1,j-1) + u_map = u(i,j-1)*u_mult(i,j-1) + u(i+1,j-1)*u_mult(i+1,j-1) + end if + else if (i == ve1 .and. do_last_col_v) then + u_weight = u_mult(i,j) + u_mult(i,j-1) + u_map = u(i,j)*u_mult(i,j) + u(i,j-1)*u_mult(i,j-1) + else + u_weight = u_mult(i,j-1) + u_mult(i,j) + u_mult(i+1,j-1) + u_mult(i+1,j) + u_map = u(i,j-1)*u_mult(i,j-1) + u(i,j)*u_mult(i,j) + u(i+1,j-1)*u_mult(i+1,j-1) + u(i+1,j)*u_mult(i+1,j) + end if + if (u_weight > 0.) then + v_new(i,j) = -sin(alpha)*u_map/u_weight + cos(alpha)*v_map + else + v_new(i,j) = v(i,j) + end if + else + v_new(i,j) = v(i,j) + end if + + end do + end do + + ! Copy rotated winds back into argument arrays + u = u_new + v = v_new + + deallocate(u_new) + deallocate(v_new) + deallocate(u_mult) + deallocate(v_mult) + end if + + else + call mprintf(.true.,ERROR,'In metmap_xform(), uninitialized proj_info structure.') + end if + + end subroutine metmap_xform + + + ! + ! NMM Wind Rotation Code + ! + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: map_to_met_nmm ! + ! ! + ! Purpose: Rotate grid-relative winds to Earth-relative winds ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine map_to_met_nmm(u, u_mask, v, v_mask, & + vs1, vs2, ve1, ve2, & + xlat_v, xlon_v) + + implicit none + + ! Arguments + integer, intent(in) :: vs1, vs2, ve1, ve2 + real, pointer, dimension(:,:) :: u, v, xlat_v, xlon_v + type (bitarray), intent(in) :: u_mask, v_mask + + orig_selected_projection = iget_selected_domain() + call select_domain(SOURCE_PROJ) + call metmap_xform_nmm(u, u_mask, v, v_mask, & + vs1, vs2, ve1, ve2, & + xlat_v, xlon_v, 1) + call select_domain(orig_selected_projection) + + end subroutine map_to_met_nmm + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: met_to_map_nmm ! + ! ! + ! Purpose: Rotate Earth-relative winds to grid-relative winds ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine met_to_map_nmm(u, u_mask, v, v_mask, & + vs1, vs2, ve1, ve2, & + xlat_v, xlon_v) + + implicit none + + ! Arguments + integer, intent(in) :: vs1, vs2, ve1, ve2 + real, pointer, dimension(:,:) :: u, v, xlat_v, xlon_v + type (bitarray), intent(in) :: u_mask, v_mask + + orig_selected_projection = iget_selected_domain() + call select_domain(1) + call metmap_xform_nmm(u, u_mask, v, v_mask, & + vs1, vs2, ve1, ve2, & + xlat_v, xlon_v, -1) + call select_domain(orig_selected_projection) + + end subroutine met_to_map_nmm + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: metmap_xform_nmm ! + ! ! + ! Purpose: Do the actual work of rotating winds for E grid. ! + ! If idir= 1, rotate grid-relative winds to Earth-relative winds ! + ! If idir=-1, rotate Earth-relative winds to grid-relative winds ! + ! ! + ! ASSUMPTIONS: 1) MEMORY ORDER IS XY. ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine metmap_xform_nmm(u, u_mask, v, v_mask, & + vs1, vs2, ve1, ve2, & + xlat_v, xlon_v, idir) + + implicit none + + ! Arguments + integer, intent(in) :: vs1, vs2, ve1, ve2, idir + real, pointer, dimension(:,:) :: u, v, xlat_v, xlon_v + type (bitarray), intent(in) :: u_mask, v_mask + + ! Local variables + integer :: i, j + real :: u_map, v_map, diff, alpha + real :: phi0, lmbd0, big_denominator, relm, rlat_v,rlon_v, clontemp + real :: sin_phi0, cos_phi0, cos_alpha, sin_alpha + real, pointer, dimension(:,:) :: u_new, v_new + + + ! If the proj_info structure has not been initialized, we don't have + ! information about the projection and standard longitude. + if (proj_stack(current_nest_number)%init) then + + if (proj_stack(current_nest_number)%code == PROJ_ROTLL) then + + call mprintf((idir == 1),LOGFILE,'Rotating map winds to earth winds.') + call mprintf((idir == -1),LOGFILE,'Rotating earth winds to grid winds') + + ! Create arrays to hold rotated winds + allocate(u_new(vs1:ve1, vs2:ve2)) + allocate(v_new(vs1:ve1, vs2:ve2)) + + phi0 = proj_stack(current_nest_number)%lat1 * rad_per_deg + + clontemp= proj_stack(current_nest_number)%lon1 + + if (clontemp .lt. 0.) then + lmbd0 = (clontemp + 360.) * rad_per_deg + else + lmbd0 = (clontemp) * rad_per_deg + endif + + sin_phi0 = sin(phi0) + cos_phi0 = cos(phi0) + + do j=vs2,ve2 + do i=vs1,ve1 + + ! Calculate the sine and cosine of rotation angle + rlat_v = xlat_v(i,j) * rad_per_deg + rlon_v = xlon_v(i,j) * rad_per_deg + relm = rlon_v - lmbd0 + big_denominator = cos(asin( & + cos_phi0 * sin(rlat_v) - & + sin_phi0 * cos(rlat_v) * cos(relm) & + ) ) + + sin_alpha = sin_phi0 * sin(relm) / & + big_denominator + + cos_alpha = (cos_phi0 * cos(rlat_v) + & + sin_phi0 * sin(rlat_v) * cos(relm)) / & + big_denominator + + ! Rotate U field + if (bitarray_test(u_mask, i-vs1+1, j-vs2+1)) then + u_map = u(i,j) + if (bitarray_test(v_mask, i-vs1+1, j-vs2+1)) then + v_map = v(i,j) + else + v_map = 0. + end if + + u_new(i,j) = cos_alpha*u_map + idir*sin_alpha*v_map + else + u_new(i,j) = u(i,j) + end if + + ! Rotate V field + if (bitarray_test(v_mask, i-vs1+1, j-vs2+1)) then + v_map = v(i,j) + if (bitarray_test(u_mask, i-vs1+1, j-vs2+1)) then + u_map = u(i,j) + else + u_map = 0. + end if + + v_new(i,j) = -idir*sin_alpha*u_map + cos_alpha*v_map + else + v_new(i,j) = v(i,j) + end if + + end do + end do + + ! Copy rotated winds back into argument arrays + u = u_new + v = v_new + + deallocate(u_new) + deallocate(v_new) + + ! Only rotate winds for Lambert conformal, polar stereographic, or Cassini + else if ((proj_stack(current_nest_number)%code == PROJ_LC) .or. & + (proj_stack(current_nest_number)%code == PROJ_PS) .or. & + (proj_stack(current_nest_number)%code == PROJ_CASSINI)) then + + call mprintf((idir == 1),LOGFILE,'Rotating map winds to earth winds.') + call mprintf((idir == -1),LOGFILE,'Rotating earth winds to grid winds') + + ! Create arrays to hold rotated winds + allocate(u_new(vs1:ve1, vs2:ve2)) + allocate(v_new(vs1:ve1, vs2:ve2)) + + do j=vs2,ve2 + do i=vs1,ve1 + + diff = idir * (xlon_v(i,j) - proj_stack(current_nest_number)%stdlon) + if (diff > 180.) then + diff = diff - 360. + else if (diff < -180.) then + diff = diff + 360. + end if + + ! Calculate the rotation angle, alpha, in radians + if (proj_stack(current_nest_number)%code == PROJ_LC) then + alpha = diff * proj_stack(current_nest_number)%cone * & + rad_per_deg * proj_stack(current_nest_number)%hemi + else + alpha = diff * rad_per_deg * proj_stack(current_nest_number)%hemi + end if + + ! Rotate U field + if (bitarray_test(u_mask, i-vs1+1, j-vs2+1)) then + u_map = u(i,j) + if (bitarray_test(v_mask, i-vs1+1, j-vs2+1)) then + v_map = v(i,j) + else + v_map = 0. + end if + + u_new(i,j) = cos(alpha)*u_map + idir*sin(alpha)*v_map + else + u_new(i,j) = u(i,j) + end if + + ! Rotate V field + if (bitarray_test(v_mask, i-vs1+1, j-vs2+1)) then + v_map = v(i,j) + if (bitarray_test(u_mask, i-vs1+1, j-vs2+1)) then + u_map = u(i,j) + else + u_map = 0. + end if + + v_new(i,j) = -idir*sin(alpha)*u_map + cos(alpha)*v_map + else + v_new(i,j) = v(i,j) + end if + + end do + end do + + ! Copy rotated winds back into argument arrays + u = u_new + v = v_new + + deallocate(u_new) + deallocate(v_new) + + end if + + else + call mprintf(.true.,ERROR,'In metmap_xform_nmm(), uninitialized proj_info structure.') + end if + + end subroutine metmap_xform_nmm + +end module rotate_winds_module diff --git a/WPS/metgrid/src/scan_input.F b/WPS/metgrid/src/scan_input.F new file mode 100644 index 00000000..030e86a9 --- /dev/null +++ b/WPS/metgrid/src/scan_input.F @@ -0,0 +1,604 @@ +module scan_input + + use netcdf + + type input_handle_type + integer :: ncid + integer :: num_vars = 0 + integer :: current_var = 0 + integer, dimension(:), pointer :: varids => null() + integer :: unlimited_dimid + end type input_handle_type + + type input_field_type + character (len=64) :: name + logical :: isTimeDependent = .false. + integer :: varid = -1 + integer :: xtype = -1 + integer :: ndims = -1 + character (len=64), dimension(:), pointer :: dimnames + integer, dimension(:), pointer :: dimlens + integer, dimension(:), pointer :: dimids + type (input_handle_type), pointer :: file_handle + + ! Members to store field data + real :: array0r + real, dimension(:), pointer :: array1r => null() + real, dimension(:,:), pointer :: array2r => null() + real, dimension(:,:,:), pointer :: array3r => null() + real, dimension(:,:,:,:), pointer :: array4r => null() + double precision :: array0d + double precision, dimension(:), pointer :: array1d => null() + double precision, dimension(:,:), pointer :: array2d => null() + double precision, dimension(:,:,:), pointer :: array3d => null() + double precision, dimension(:,:,:,:), pointer :: array4d => null() + integer :: array0i + integer, dimension(:), pointer :: array1i => null() + integer, dimension(:,:), pointer :: array2i => null() + integer, dimension(:,:,:), pointer :: array3i => null() + end type input_field_type + + integer, parameter :: FIELD_TYPE_UNSUPPORTED = -1, & + FIELD_TYPE_REAL = 1, & + FIELD_TYPE_DOUBLE = 2, & + FIELD_TYPE_INTEGER = 3, & + FIELD_TYPE_CHARACTER = 4 + + + contains + + + integer function scan_input_open(filename, handle, nRecords) result(stat) + + implicit none + + character (len=*), intent(in) :: filename + type (input_handle_type), intent(out) :: handle + integer, intent(out), optional :: nRecords + + integer :: i + + stat = 0 + + stat = nf90_open(trim(filename), NF90_NOWRITE, handle % ncid) + if (stat /= NF90_NOERR) then + stat = 1 + return + end if + + stat = nf90_inquire(handle % ncid, nVariables=handle % num_vars) + if (stat /= NF90_NOERR) then + stat = 1 + return + end if + + allocate(handle % varids(handle % num_vars)) + +#ifdef HAVE_NF90_INQ_VARIDS + stat = nf90_inq_varids(handle % ncid, handle % num_vars, handle % varids) + if (stat /= NF90_NOERR) then + stat = 1 + return + end if +#else + ! Newer versions of the netCDF4 library (perhaps newer than 4.2.0?) + ! provide a function to return a list of all variable IDs in a file; if + ! we are using an older version of the netCDF library, we can apparently + ! assume that the variable IDs are numbered 1 through nVars. + ! See http://www.unidata.ucar.edu/software/netcdf/docs/tutorial_ncids.html + do i=1,handle % num_vars + handle % varids(i) = i + end do +#endif + + stat = nf90_inquire(handle % ncid, unlimitedDimId=handle % unlimited_dimid) + if (stat /= NF90_NOERR) then + stat = 1 + return + end if + + if (present(nRecords)) then + stat = nf90_inquire_dimension(handle % ncid, handle % unlimited_dimid, len=nRecords) + if (stat /= NF90_NOERR) then + stat = 1 + return + end if + + ! In case we have an input file that no time-varying records but + ! does have time-invariant fields, set nRecords = 1 so that we can + ! at least extract these fields + if ((nRecords == 0) .and. (handle % num_vars > 0)) then + nRecords = 1 + end if + end if + + handle % current_var = 1 + + end function scan_input_open + + + integer function scan_input_close(handle) result(stat) + + implicit none + + type (input_handle_type), intent(inout) :: handle + + + stat = 0 + + stat = nf90_close(handle % ncid) + if (stat /= NF90_NOERR) then + stat = 1 + end if + + if (associated(handle % varids)) then + deallocate(handle % varids) + end if + handle % current_var = 0 + + end function scan_input_close + + + integer function scan_input_rewind(handle) result(stat) + + implicit none + + type (input_handle_type), intent(inout) :: handle + + + stat = 0 + + handle % current_var = 1 + + end function scan_input_rewind + + + integer function scan_input_next_field(handle, field) result(stat) + + implicit none + + type (input_handle_type), intent(inout), target :: handle + type (input_field_type), intent(out) :: field + + integer :: idim + + + stat = 0 + + if (handle % current_var < 1 .or. handle % current_var > handle % num_vars) then + stat = 1 + return + end if + + field % varid = handle % varids(handle % current_var) + stat = nf90_inquire_variable(handle % ncid, field % varid, & + name=field % name, & + xtype=field % xtype, & + ndims=field % ndims) + if (stat /= NF90_NOERR) then + stat = 1 + return + end if + + if (field % xtype == NF90_FLOAT) then + field % xtype = FIELD_TYPE_REAL + else if (field % xtype == NF90_DOUBLE) then + field % xtype = FIELD_TYPE_DOUBLE + else if (field % xtype == NF90_INT) then + field % xtype = FIELD_TYPE_INTEGER + else if (field % xtype == NF90_CHAR) then + field % xtype = FIELD_TYPE_CHARACTER + else + field % xtype = FIELD_TYPE_UNSUPPORTED + end if + + allocate(field % dimids(field % ndims)) + + stat = nf90_inquire_variable(handle % ncid, field % varid, & + dimids=field % dimids) + if (stat /= NF90_NOERR) then + stat = 1 + deallocate(field % dimids) + return + end if + + allocate(field % dimlens(field % ndims)) + allocate(field % dimnames(field % ndims)) + + do idim=1,field % ndims + stat = nf90_inquire_dimension(handle % ncid, field % dimids(idim), & + name=field % dimnames(idim), & + len=field % dimlens(idim)) + if (field % dimids(idim) == handle % unlimited_dimid) then + field % isTimeDependent = .true. + end if + end do + + field % file_handle => handle + + handle % current_var = handle % current_var + 1 + + end function scan_input_next_field + + + integer function scan_input_for_field(handle, fieldname, field) result(stat) + + implicit none + + type (input_handle_type), intent(inout), target :: handle + character (len=*), intent(in) :: fieldname + type (input_field_type), intent(out) :: field + + integer :: idim + + stat = 0 + + stat = nf90_inq_varid(handle % ncid, trim(fieldname), field % varid) + if (stat /= NF90_NOERR) then + stat = 1 + return + end if + + stat = nf90_inquire_variable(handle % ncid, field % varid, & + name=field % name, & + xtype=field % xtype, & + ndims=field % ndims) + if (stat /= NF90_NOERR) then + stat = 1 + return + end if + + if (field % xtype == NF90_FLOAT) then + field % xtype = FIELD_TYPE_REAL + else if (field % xtype == NF90_DOUBLE) then + field % xtype = FIELD_TYPE_DOUBLE + else if (field % xtype == NF90_INT) then + field % xtype = FIELD_TYPE_INTEGER + else if (field % xtype == NF90_CHAR) then + field % xtype = FIELD_TYPE_CHARACTER + else + field % xtype = FIELD_TYPE_UNSUPPORTED + end if + + allocate(field % dimids(field % ndims)) + + stat = nf90_inquire_variable(handle % ncid, field % varid, & + dimids=field % dimids) + if (stat /= NF90_NOERR) then + stat = 1 + deallocate(field % dimids) + return + end if + + allocate(field % dimlens(field % ndims)) + allocate(field % dimnames(field % ndims)) + + do idim=1,field % ndims + stat = nf90_inquire_dimension(handle % ncid, field % dimids(idim), & + name=field % dimnames(idim), & + len=field % dimlens(idim)) + if (field % dimids(idim) == handle % unlimited_dimid) then + field % isTimeDependent = .true. + end if + end do + + field % file_handle => handle + + end function scan_input_for_field + + + integer function scan_input_read_field(field, frame) result(stat) + + implicit none + + type (input_field_type), intent(inout) :: field + integer, intent(in), optional :: frame + + integer :: local_frame + integer, dimension(5) :: start, count + real, dimension(1) :: temp1r + double precision, dimension(1) :: temp1d + integer, dimension(1) :: temp1i + + + stat = 0 + + local_frame = 1 + if (present(frame)) then + local_frame = frame + end if + + if (field % xtype == FIELD_TYPE_REAL) then + if (field % ndims == 0 .or. (field % ndims == 1 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = local_frame + count(1) = 1 + stat = nf90_get_var(field % file_handle % ncid, field % varid, temp1r, & + start=start(1:1), count=count(1:1)) + field % array0r = temp1r(1) + else + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array0r) + end if + else if (field % ndims == 1 .or. (field % ndims == 2 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = 1 + count(1) = field % dimlens(1) + start(2) = local_frame + count(2) = 1 + allocate(field % array1r(count(1))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1r, & + start=start(1:2), count=count(1:2)) + else + allocate(field % array1r(field%dimlens(1))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1r) + end if + else if (field % ndims == 2 .or. (field % ndims == 3 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = 1 + count(1) = field % dimlens(1) + start(2) = 1 + count(2) = field % dimlens(2) + start(3) = local_frame + count(3) = 1 + allocate(field % array2r(count(1),count(2))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2r, & + start=start(1:3), count=count(1:3)) + else + allocate(field % array2r(field%dimlens(1),field%dimlens(2))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2r) + end if + else if (field % ndims == 3 .or. (field % ndims == 4 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = 1 + count(1) = field % dimlens(1) + start(2) = 1 + count(2) = field % dimlens(2) + start(3) = 1 + count(3) = field % dimlens(3) + start(4) = local_frame + count(4) = 1 + allocate(field % array3r(count(1),count(2),count(3))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3r, & + start=start(1:4), count=count(1:4)) + else + allocate(field % array3r(field%dimlens(1),field%dimlens(2),field%dimlens(3))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3r) + end if + else if (field % ndims == 4 .or. (field % ndims == 5 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = 1 + count(1) = field % dimlens(1) + start(2) = 1 + count(2) = field % dimlens(2) + start(3) = 1 + count(3) = field % dimlens(3) + start(4) = 1 + count(4) = field % dimlens(4) + start(5) = local_frame + count(5) = 1 + allocate(field % array4r(count(1),count(2),count(3),count(4))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array4r, & + start=start(1:5), count=count(1:5)) + else + allocate(field % array4r(field%dimlens(1),field%dimlens(2),field%dimlens(3),field%dimlens(4))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array4r) + end if + end if + else if (field % xtype == FIELD_TYPE_DOUBLE) then + if (field % ndims == 0 .or. (field % ndims == 1 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = local_frame + count(1) = 1 + stat = nf90_get_var(field % file_handle % ncid, field % varid, temp1d, & + start=start(1:1), count=count(1:1)) + field % array0d = temp1d(1) + else + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array0d) + end if + else if (field % ndims == 1 .or. (field % ndims == 2 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = 1 + count(1) = field % dimlens(1) + start(2) = local_frame + count(2) = 1 + allocate(field % array1d(count(1))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1d, & + start=start(1:2), count=count(1:2)) + else + allocate(field % array1d(field%dimlens(1))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1d) + end if + else if (field % ndims == 2 .or. (field % ndims == 3 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = 1 + count(1) = field % dimlens(1) + start(2) = 1 + count(2) = field % dimlens(2) + start(3) = local_frame + count(3) = 1 + allocate(field % array2d(count(1),count(2))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2d, & + start=start(1:3), count=count(1:3)) + else + allocate(field % array2d(field%dimlens(1),field%dimlens(2))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2d) + end if + else if (field % ndims == 3 .or. (field % ndims == 4 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = 1 + count(1) = field % dimlens(1) + start(2) = 1 + count(2) = field % dimlens(2) + start(3) = 1 + count(3) = field % dimlens(3) + start(4) = local_frame + count(4) = 1 + allocate(field % array3d(count(1),count(2),count(3))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3d, & + start=start(1:4), count=count(1:4)) + else + allocate(field % array3d(field%dimlens(1),field%dimlens(2),field%dimlens(3))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3d) + end if + else if (field % ndims == 4 .or. (field % ndims == 5 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = 1 + count(1) = field % dimlens(1) + start(2) = 1 + count(2) = field % dimlens(2) + start(3) = 1 + count(3) = field % dimlens(3) + start(4) = 1 + count(4) = field % dimlens(4) + start(5) = local_frame + count(5) = 1 + allocate(field % array4d(count(1),count(2),count(3),count(4))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array4d, & + start=start(1:5), count=count(1:5)) + else + allocate(field % array4d(field%dimlens(1),field%dimlens(2),field%dimlens(3),field%dimlens(4))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array4d) + end if + end if + + else if (field % xtype == FIELD_TYPE_INTEGER) then + if (field % ndims == 0 .or. (field % ndims == 1 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = local_frame + count(1) = 1 + stat = nf90_get_var(field % file_handle % ncid, field % varid, temp1i, & + start=start(1:1), count=count(1:1)) + field % array0i = temp1i(1) + else + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array0i) + end if + else if (field % ndims == 1 .or. (field % ndims == 2 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = 1 + count(1) = field % dimlens(1) + start(2) = local_frame + count(2) = 1 + allocate(field % array1i(count(1))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1i, & + start=start(1:2), count=count(1:2)) + else + allocate(field % array1i(field%dimlens(1))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array1i) + end if + else if (field % ndims == 2 .or. (field % ndims == 3 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = 1 + count(1) = field % dimlens(1) + start(2) = 1 + count(2) = field % dimlens(2) + start(3) = local_frame + count(3) = 1 + allocate(field % array2i(count(1),count(2))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2i, & + start=start(1:3), count=count(1:3)) + else + allocate(field % array2i(field%dimlens(1),field%dimlens(2))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array2i) + end if + else if (field % ndims == 3 .or. (field % ndims == 4 .and. field % isTimeDependent)) then + if (field % isTimeDependent) then + start(1) = 1 + count(1) = field % dimlens(1) + start(2) = 1 + count(2) = field % dimlens(2) + start(3) = 1 + count(3) = field % dimlens(3) + start(4) = local_frame + count(4) = 1 + allocate(field % array3i(count(1),count(2),count(3))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3i, & + start=start(1:4), count=count(1:4)) + else + allocate(field % array3i(field%dimlens(1),field%dimlens(2),field%dimlens(3))) + stat = nf90_get_var(field % file_handle % ncid, field % varid, field % array3i) + end if + end if + + else if (field % xtype == FIELD_TYPE_CHARACTER) then + write(0,*) ' ' + write(0,*) 'Processing of character fields is not supported; skipping read of field '//trim(field % name) + write(0,*) ' ' + + else + write(0,*) ' ' + write(0,*) 'Unsupported type; skipping read of field '//trim(field % name) + write(0,*) ' ' + end if + + if (stat /= NF90_NOERR) then + write(0,*) ' ' + write(0,*) 'NetCDF error: reading '//trim(field % name)//' returned ', stat + write(0,*) ' ' + stat = 1 + else + stat = 0 + end if + + end function scan_input_read_field + + + integer function scan_input_free_field(field) result(stat) + + implicit none + + type (input_field_type), intent(inout) :: field + + + stat = 0 + + if (associated(field % dimids)) then + deallocate(field % dimids) + end if + if (associated(field % dimlens)) then + deallocate(field % dimlens) + end if + if (associated(field % dimnames)) then + deallocate(field % dimnames) + end if + + if (associated(field % array1r)) then + deallocate(field % array1r) + end if + if (associated(field % array2r)) then + deallocate(field % array2r) + end if + if (associated(field % array3r)) then + deallocate(field % array3r) + end if + if (associated(field % array4r)) then + deallocate(field % array4r) + end if + + if (associated(field % array1d)) then + deallocate(field % array1d) + end if + if (associated(field % array2d)) then + deallocate(field % array2d) + end if + if (associated(field % array3d)) then + deallocate(field % array3d) + end if + if (associated(field % array4d)) then + deallocate(field % array4d) + end if + + if (associated(field % array1i)) then + deallocate(field % array1i) + end if + if (associated(field % array2i)) then + deallocate(field % array2i) + end if + if (associated(field % array3i)) then + deallocate(field % array3i) + end if + + nullify(field % file_handle) + + end function scan_input_free_field + +end module scan_input diff --git a/WPS/metgrid/src/storage_module.F b/WPS/metgrid/src/storage_module.F new file mode 100644 index 00000000..a3340094 --- /dev/null +++ b/WPS/metgrid/src/storage_module.F @@ -0,0 +1,1125 @@ +module storage_module + + use datatype_module + use minheap_module + use misc_definitions_module + use module_debug + use parallel_module + + ! Maximum umber of words to keep in memory at a time + ! THIS MUST BE AT LEAST AS LARGE AS THE SIZE OF THE LARGEST ARRAY TO BE STORED + integer, parameter :: MEMSIZE_MAX = 1E9 + + ! Name (when formatted as i9.9) of next file to be used as array storage + integer :: next_filenumber = 1 + + ! Time counter used by policy for evicting arrays to Fortran units + integer :: global_time = 0 + + ! Current memory usage of module + integer :: memsize = 0 + + ! Primary head and tail pointers + type (head_node), pointer :: head => null() + type (head_node), pointer :: tail => null() + + ! Pointer for get_next_output_fieldname + type (head_node), pointer :: next_output_field => null() + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_init + ! + ! Purpose: Initialize the storage module. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_init() + + implicit none + + call init_heap() + + end subroutine storage_init + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: reset_next_field + ! + ! Purpose: Sets the next field to the first available field + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine reset_next_field() + + implicit none + + next_output_field => head + + end subroutine reset_next_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_put_field + ! + ! Purpose: Stores an fg_input type. Upon return, IT MUST NOT BE ASSUMED that + ! store_me contains valid data, since all such data may have been written + ! to a Fortran unit + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_put_field(store_me) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: store_me + + ! Local variables + integer :: funit + logical :: is_used + character (len=64) :: fname + type (head_node), pointer :: name_cursor + type (data_node), pointer :: data_cursor + type (data_node), pointer :: newnode + type (data_node), pointer :: evictnode + + !CWH Initialize local pointer variables + nullify(evictnode) !MGD initialization for evictnode should not be necessary + + ! We'll first see if there is already a list for this fieldname + name_cursor => head + do while (associated(name_cursor)) + if (primary_cmp(name_cursor%fg_data, store_me) == EQUAL) exit + name_cursor => name_cursor%next + end do + + ! If not, create a new node in the primary list + if (.not. associated(name_cursor)) then + allocate(name_cursor) + call dup(store_me, name_cursor%fg_data) + nullify(name_cursor%fg_data%r_arr) + nullify(name_cursor%fg_data%valid_mask) + nullify(name_cursor%fg_data%modified_mask) + nullify(name_cursor%fieldlist_head) + nullify(name_cursor%fieldlist_tail) + nullify(name_cursor%prev) + name_cursor%next => head + if (.not. associated(head)) tail => name_cursor + head => name_cursor + else + if ((name_cursor%fg_data%header%time_dependent .and. .not. store_me%header%time_dependent) .or. & + (.not. name_cursor%fg_data%header%time_dependent .and. store_me%header%time_dependent)) then + call mprintf(.true.,ERROR,'Cannot combine time-independent data with '// & + 'time-dependent data for field %s',s1=store_me%header%field) + end if + end if + + ! At this point, name_cursor points to a valid head node for fieldname + data_cursor => name_cursor%fieldlist_head + do while ( associated(data_cursor) ) + if ((secondary_cmp(store_me, data_cursor%fg_data) == LESS) .or. & + (secondary_cmp(store_me, data_cursor%fg_data) == EQUAL)) exit + data_cursor => data_cursor%next + end do + + if (associated(data_cursor)) then + if (secondary_cmp(store_me, data_cursor%fg_data) == EQUAL) then + if (data_cursor%filenumber > 0) then +! BUG: Might need to deal with freeing up a file +call mprintf(.true.,WARN,'WE NEED TO FREE THE FILE ASSOCIATED WITH DATA_CURSOR') +call mprintf(.true.,WARN,'PLEASE REPORT THIS BUG TO THE DEVELOPER!') + end if + data_cursor%fg_data%r_arr => store_me%r_arr + data_cursor%fg_data%valid_mask => store_me%valid_mask + data_cursor%fg_data%modified_mask => store_me%modified_mask + return + end if + end if + + allocate(newnode) + call dup(store_me, newnode%fg_data) + + newnode%field_shape = shape(newnode%fg_data%r_arr) + memsize = memsize + size(newnode%fg_data%r_arr) + newnode%last_used = global_time + global_time = global_time + 1 + newnode%filenumber = 0 + call add_to_heap(newnode) + + do while (memsize > MEMSIZE_MAX) + call get_min(evictnode) + evictnode%filenumber = next_filenumber + next_filenumber = next_filenumber + 1 + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + memsize = memsize - size(evictnode%fg_data%r_arr) + write(fname,'(i9.9,a2,i3.3)') evictnode%filenumber,'.p',my_proc_id + open(funit,file=trim(fname),form='unformatted',status='unknown') + write(funit) evictnode%fg_data%r_arr + close(funit) + deallocate(evictnode%fg_data%r_arr) + end do + + ! Inserting node at the tail of list + if (.not. associated(data_cursor)) then + newnode%prev => name_cursor%fieldlist_tail + nullify(newnode%next) + + ! List is actually empty + if (.not. associated(name_cursor%fieldlist_head)) then + name_cursor%fieldlist_head => newnode + name_cursor%fieldlist_tail => newnode + else + name_cursor%fieldlist_tail%next => newnode + name_cursor%fieldlist_tail => newnode + end if + + ! Inserting node at the head of list + else if ((secondary_cmp(name_cursor%fieldlist_head%fg_data, newnode%fg_data) == GREATER) .or. & + (secondary_cmp(name_cursor%fieldlist_head%fg_data, newnode%fg_data) == EQUAL)) then + nullify(newnode%prev) + newnode%next => name_cursor%fieldlist_head + name_cursor%fieldlist_head%prev => newnode + name_cursor%fieldlist_head => newnode + + ! Inserting somewhere in the middle of the list + else + newnode%prev => data_cursor%prev + newnode%next => data_cursor + data_cursor%prev%next => newnode + data_cursor%prev => newnode + end if + + end subroutine storage_put_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_get_field + ! + ! Purpose: Retrieves an fg_input type from storage; if the fg_input type whose + ! header matches the header of get_me does not exist, istatus = 1 upon + ! return; if the requested fg_input type is found, istatus = 0 + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_get_field(get_me, istatus) + + implicit none + + ! Arguments + type (fg_input), intent(inout) :: get_me + integer, intent(out) :: istatus + + ! Local variables + integer :: funit + logical :: is_used + character (len=64) :: fname + type (head_node), pointer :: name_cursor + type (data_node), pointer :: data_cursor + type (data_node), pointer :: evictnode + + !CWH Initialize local pointer variables + nullify(evictnode) !MGD initialization for evictnodeshould not be necessary + + global_time = global_time + 1 + + istatus = 1 + + ! We'll first see if there is already a list for this fieldname + name_cursor => head + do while (associated(name_cursor)) + if (primary_cmp(name_cursor%fg_data, get_me) == EQUAL) exit + name_cursor => name_cursor%next + end do + + if (.not. associated(name_cursor)) return + + ! At this point, name_cursor points to a valid head node for fieldname + data_cursor => name_cursor%fieldlist_head + do while ( associated(data_cursor) ) + if (secondary_cmp(get_me, data_cursor%fg_data) == EQUAL) then + call dup(data_cursor%fg_data, get_me) + + ! Before deciding whether we need to write an array to disk, first consider + ! that reading the requested array will use memory + if (data_cursor%filenumber > 0) then + memsize = memsize + data_cursor%field_shape(1)*data_cursor%field_shape(2) + end if + + ! If we exceed our memory limit, we need to evict + do while (memsize > MEMSIZE_MAX) + call get_min(evictnode) + evictnode%filenumber = next_filenumber + next_filenumber = next_filenumber + 1 + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + memsize = memsize - size(evictnode%fg_data%r_arr) + write(fname,'(i9.9,a2,i3.3)') evictnode%filenumber,'.p',my_proc_id + open(funit,file=trim(fname),form='unformatted',status='unknown') + write(funit) evictnode%fg_data%r_arr + close(funit) + deallocate(evictnode%fg_data%r_arr) + end do + + ! Get requested array + if (data_cursor%filenumber > 0) then + data_cursor%last_used = global_time + global_time = global_time + 1 + call add_to_heap(data_cursor) + write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + open(funit,file=trim(fname),form='unformatted',status='old') + allocate(data_cursor%fg_data%r_arr(data_cursor%field_shape(1),data_cursor%field_shape(2))) + read(funit) data_cursor%fg_data%r_arr + get_me%r_arr => data_cursor%fg_data%r_arr + close(funit,status='delete') + data_cursor%filenumber = 0 + else + get_me%r_arr => data_cursor%fg_data%r_arr + + call remove_index(data_cursor%heap_index) + data_cursor%last_used = global_time + global_time = global_time + 1 + call add_to_heap(data_cursor) + end if + + istatus = 0 + return + end if + data_cursor => data_cursor%next + end do + + end subroutine storage_get_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_query_field + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_query_field(get_me, istatus) + + implicit none + + ! Arguments + type (fg_input), intent(inout) :: get_me + integer, intent(out) :: istatus + + ! Local variables + type (head_node), pointer :: name_cursor + type (data_node), pointer :: data_cursor + + istatus = 1 + + ! We'll first see if there is already a list for this fieldname + name_cursor => head + do while (associated(name_cursor)) + if (primary_cmp(name_cursor%fg_data, get_me) == EQUAL) exit + name_cursor => name_cursor%next + end do + + if (.not. associated(name_cursor)) return + + ! At this point, name_cursor points to a valid head node for fieldname + data_cursor => name_cursor%fieldlist_head + do while ( associated(data_cursor) ) + if (secondary_cmp(get_me, data_cursor%fg_data) == EQUAL) then + get_me%r_arr => data_cursor%fg_data%r_arr + get_me%valid_mask => data_cursor%fg_data%valid_mask + get_me%modified_mask => data_cursor%fg_data%modified_mask + istatus = 0 + return + end if + data_cursor => data_cursor%next + end do + + end subroutine storage_query_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_next_output_fieldname + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_next_output_fieldname(nest_num, field_name, ndims, & + min_level, max_level, & + istagger, mem_order, dim_names, units, description, & + sr_x, sr_y, derived_from, & + istatus) + + implicit none + + ! Arguments + integer, intent(in) :: nest_num + integer, intent(out) :: ndims, min_level, max_level, istagger, istatus + integer, intent(out) :: sr_x, sr_y + character (len=128), intent(out) :: field_name, mem_order, units, description, derived_from + character (len=128), dimension(3), intent(out) :: dim_names + +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" + + ! Local variables + type (data_node), pointer :: data_cursor + + istatus = 1 + + derived_from = '' + + if (.not. associated(next_output_field)) return + + min_level = 1 + max_level = 0 + ndims = 2 + + do while (max_level == 0 .and. associated(next_output_field)) + + data_cursor => next_output_field%fieldlist_head + if (associated(data_cursor)) then + if (.not. is_mask_field(data_cursor%fg_data)) then + do while ( associated(data_cursor) ) + istatus = 0 + max_level = max_level + 1 + data_cursor => data_cursor%next + end do + end if + end if + + if (max_level == 0) next_output_field => next_output_field%next + end do + + if (max_level > 0 .and. associated(next_output_field)) then + + if (max_level > 1) ndims = 3 + if (ndims == 2) then + mem_order = 'XY ' + dim_names(3) = ' ' + else + mem_order = 'XYZ' + if (is_time_dependent(next_output_field%fg_data)) then + dim_names(3) = ' ' + dim_names(3)(1:32) = next_output_field%fg_data%header%vertical_coord + else + write(dim_names(3),'(a11,i4.4)') 'z-dimension', max_level + end if + end if + field_name = get_fieldname(next_output_field%fg_data) + istagger = get_staggering(next_output_field%fg_data) + if (istagger == M .or. istagger == HH .or. istagger == VV) then + dim_names(1) = 'west_east' + dim_names(2) = 'south_north' + else if (istagger == U) then + dim_names(1) = 'west_east_stag' + dim_names(2) = 'south_north' + else if (istagger == V) then + dim_names(1) = 'west_east' + dim_names(2) = 'south_north_stag' + else if (istagger == CORNER) then + dim_names(1) = 'west_east_stag' + dim_names(2) = 'south_north_stag' + else + dim_names(1) = 'i-dimension' + dim_names(2) = 'j-dimension' + end if + units = get_units(next_output_field%fg_data) + description = get_description(next_output_field%fg_data) + call get_subgrid_dim_name(nest_num, field_name, dim_names(1:2), & + sr_x, sr_y, istatus) + + next_output_field => next_output_field%next + end if + + end subroutine get_next_output_fieldname + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_subgrid_dim_name + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_subgrid_dim_name(nest_num, field_name, dimnames, & + sub_x, sub_y, istatus) + + use gridinfo_module + + implicit none + + ! Arguments + integer, intent(in) :: nest_num + integer, intent(out) :: sub_x, sub_y, istatus + character(len=128), intent(in) :: field_name + character(len=128), dimension(2), intent(inout) :: dimnames + + ! Local variables + integer :: idx, nlen + + sub_x = next_output_field%fg_data%header%sr_x + sub_y = next_output_field%fg_data%header%sr_y + + if (sub_x > 1) then + dimnames(1) = trim(dimnames(1))//"_subgrid" + end if + if (sub_y > 1) then + dimnames(2) = trim(dimnames(2))//"_subgrid" + end if + + istatus = 0 + + end subroutine get_subgrid_dim_name + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: get_next_output_field + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine get_next_output_field(field_name, r_array, & + start_i, end_i, start_j, end_j, min_level, max_level, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: start_i, end_i, start_j, end_j, min_level, max_level, istatus + real, pointer, dimension(:,:,:) :: r_array + character (len=128), intent(out) :: field_name + +#include "wrf_io_flags.h" +#include "wrf_status_codes.h" + + ! Local variables + integer :: k + type (data_node), pointer :: data_cursor + type (fg_input) :: temp_field + + istatus = 1 + + if (.not. associated(next_output_field)) return + + min_level = 1 + max_level = 0 + + do while (max_level == 0 .and. associated(next_output_field)) + + data_cursor => next_output_field%fieldlist_head + if (associated(data_cursor)) then + if (.not. is_mask_field(data_cursor%fg_data)) then + do while ( associated(data_cursor) ) + istatus = 0 + max_level = max_level + 1 + data_cursor => data_cursor%next + end do + end if + end if + + if (max_level == 0) next_output_field => next_output_field%next + end do + + if (max_level > 0 .and. associated(next_output_field)) then + + start_i = 1 + end_i = next_output_field%fieldlist_head%field_shape(1) + start_j = 1 + end_j = next_output_field%fieldlist_head%field_shape(2) + + allocate(r_array(next_output_field%fieldlist_head%field_shape(1), & + next_output_field%fieldlist_head%field_shape(2), & + max_level) ) + + k = 1 + data_cursor => next_output_field%fieldlist_head + do while ( associated(data_cursor) ) + call dup(data_cursor%fg_data, temp_field) + call storage_get_field(temp_field, istatus) + r_array(:,:,k) = temp_field%r_arr + k = k + 1 + data_cursor => data_cursor%next + end do + + field_name = get_fieldname(next_output_field%fg_data) + + next_output_field => next_output_field%next + end if + + end subroutine get_next_output_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_delete_field + ! + ! Purpose: Deletes the stored fg_input type whose header matches delete_me + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_delete_field(delete_me) + + implicit none + + ! Arguments + type (fg_input), intent(in) :: delete_me + + ! Local variables + integer :: funit + logical :: is_used + character (len=64) :: fname + type (head_node), pointer :: name_cursor + type (data_node), pointer :: data_cursor + + ! We'll first see if there is a list for this fieldname + name_cursor => head + do while (associated(name_cursor)) + if (primary_cmp(name_cursor%fg_data, delete_me) == EQUAL) exit + name_cursor => name_cursor%next + end do + + if (.not. associated(name_cursor)) return + + ! At this point, name_cursor points to a valid head node for fieldname + data_cursor => name_cursor%fieldlist_head + do while ( associated(data_cursor) ) + if (secondary_cmp(delete_me, data_cursor%fg_data) == EQUAL) then + + if (data_cursor%filenumber > 0) then + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id + open(funit,file=trim(fname),form='unformatted',status='old') + close(funit,status='delete') + else + call remove_index(data_cursor%heap_index) + memsize = memsize - size(data_cursor%fg_data%r_arr) + deallocate(data_cursor%fg_data%r_arr) + end if + if (associated(data_cursor%fg_data%valid_mask)) call bitarray_destroy(data_cursor%fg_data%valid_mask) + nullify(data_cursor%fg_data%valid_mask) + if (associated(data_cursor%fg_data%modified_mask)) call bitarray_destroy(data_cursor%fg_data%modified_mask) + nullify(data_cursor%fg_data%modified_mask) + + ! Only item in the list + if (.not. associated(data_cursor%next) .and. & + .not. associated(data_cursor%prev)) then + nullify(name_cursor%fieldlist_head) + nullify(name_cursor%fieldlist_tail) + deallocate(data_cursor) +! DO WE REMOVE THIS HEADER NODE AT THIS POINT? + return + + ! Head of the list + else if (.not. associated(data_cursor%prev)) then + name_cursor%fieldlist_head => data_cursor%next + nullify(data_cursor%next%prev) + deallocate(data_cursor) + return + + ! Tail of the list + else if (.not. associated(data_cursor%next)) then + name_cursor%fieldlist_tail => data_cursor%prev + nullify(data_cursor%prev%next) + deallocate(data_cursor) + return + + ! Middle of the list + else + data_cursor%prev%next => data_cursor%next + data_cursor%next%prev => data_cursor%prev + deallocate(data_cursor) + return + + end if + + end if + data_cursor => data_cursor%next + end do + + end subroutine storage_delete_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_delete_all_td + ! + ! Purpose: Deletes the stored time-dependent data + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_delete_all_td() + + implicit none + + ! Local variables + integer :: funit + logical :: is_used + character (len=64) :: fname + type (head_node), pointer :: name_cursor + type (data_node), pointer :: data_cursor, next_cursor + + ! We'll first see if there is a list for this fieldname + name_cursor => head + do while (associated(name_cursor)) + + data_cursor => name_cursor%fieldlist_head + do while ( associated(data_cursor) ) + if ( is_time_dependent(data_cursor%fg_data) ) then + + if (data_cursor%filenumber > 0) then + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id + open(funit,file=trim(fname),form='unformatted',status='old') + close(funit,status='delete') + else + call remove_index(data_cursor%heap_index) + memsize = memsize - size(data_cursor%fg_data%r_arr) + deallocate(data_cursor%fg_data%r_arr) + end if + if (associated(data_cursor%fg_data%valid_mask)) call bitarray_destroy(data_cursor%fg_data%valid_mask) + nullify(data_cursor%fg_data%valid_mask) + if (associated(data_cursor%fg_data%modified_mask)) call bitarray_destroy(data_cursor%fg_data%modified_mask) + nullify(data_cursor%fg_data%modified_mask) + + ! We should handle individual cases, that way we can deal with a list + ! that has both time independent and time dependent nodes in it. + + ! Only item in the list + if (.not. associated(data_cursor%next) .and. & + .not. associated(data_cursor%prev)) then + next_cursor => null() + nullify(name_cursor%fieldlist_head) + nullify(name_cursor%fieldlist_tail) + deallocate(data_cursor) +! DO WE REMOVE THIS HEADER NODE AT THIS POINT? + + ! Head of the list + else if (.not. associated(data_cursor%prev)) then + name_cursor%fieldlist_head => data_cursor%next + next_cursor => data_cursor%next + nullify(data_cursor%next%prev) + deallocate(data_cursor) + + ! Tail of the list + else if (.not. associated(data_cursor%next)) then +! THIS CASE SHOULD PROBABLY NOT OCCUR + name_cursor%fieldlist_tail => data_cursor%prev + next_cursor => null() + nullify(data_cursor%prev%next) + deallocate(data_cursor) + + ! Middle of the list + else +! THIS CASE SHOULD PROBABLY NOT OCCUR + next_cursor => data_cursor%next + data_cursor%prev%next => data_cursor%next + data_cursor%next%prev => data_cursor%prev + deallocate(data_cursor) + + end if + + end if + data_cursor => next_cursor + end do + + name_cursor => name_cursor%next + end do + + end subroutine storage_delete_all_td + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_get_levels + ! + ! Purpose: Returns a list of all levels for the field indicated in the_header. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_get_levels(the_header, list) + + implicit none + + ! Arguments + integer, pointer, dimension(:) :: list + type (fg_input), intent(in) :: the_header + + ! Local variables + integer :: n + type (head_node), pointer :: name_cursor + type (data_node), pointer :: data_cursor + + if (associated(list)) deallocate(list) + nullify(list) + + ! We'll first see if there is a list for this header + name_cursor => head + do while (associated(name_cursor)) + if (primary_cmp(name_cursor%fg_data, the_header) == EQUAL) exit + name_cursor => name_cursor%next + end do + + if (.not. associated(name_cursor)) return + + n = 0 + ! At this point, name_cursor points to a valid head node for fieldname + data_cursor => name_cursor%fieldlist_head + do while ( associated(data_cursor) ) + n = n + 1 + if (.not. associated(data_cursor%next)) exit + data_cursor => data_cursor%next + end do + + if (n > 0) allocate(list(n)) + + n = 1 + do while ( associated(data_cursor) ) + list(n) = get_level(data_cursor%fg_data) + n = n + 1 + data_cursor => data_cursor%prev + end do + + end subroutine storage_get_levels + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_delete_all + ! + ! Purpose: Deletes all data, both time-independent and time-dependent. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_delete_all() + + implicit none + + ! Local variables + integer :: funit + logical :: is_used + character (len=64) :: fname + type (head_node), pointer :: name_cursor + type (data_node), pointer :: data_cursor + + ! We'll first see if there is already a list for this fieldname + name_cursor => head + do while (associated(name_cursor)) + + if (associated(name_cursor%fieldlist_head)) then + data_cursor => name_cursor%fieldlist_head + do while ( associated(data_cursor) ) + name_cursor%fieldlist_head => data_cursor%next + + if (data_cursor%filenumber > 0) then + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + write(fname,'(i9.9,a2,i3.3)') data_cursor%filenumber,'.p',my_proc_id + open(funit,file=trim(fname),form='unformatted',status='old') + close(funit,status='delete') + else + call remove_index(data_cursor%heap_index) + memsize = memsize - size(data_cursor%fg_data%r_arr) + deallocate(data_cursor%fg_data%r_arr) + end if + if (associated(data_cursor%fg_data%valid_mask)) call bitarray_destroy(data_cursor%fg_data%valid_mask) + nullify(data_cursor%fg_data%valid_mask) + if (associated(data_cursor%fg_data%modified_mask)) call bitarray_destroy(data_cursor%fg_data%modified_mask) + nullify(data_cursor%fg_data%modified_mask) + + deallocate(data_cursor) + data_cursor => name_cursor%fieldlist_head + end do + end if + + head => name_cursor%next + deallocate(name_cursor) + name_cursor => head + end do + + nullify(head) + nullify(tail) + + call heap_destroy() + + end subroutine storage_delete_all + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_get_all_headers + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_get_all_headers(header_list) + + implicit none + + ! Arguments + type (fg_input), pointer, dimension(:) :: header_list + + ! Local variables + integer :: nheaders + type (head_node), pointer :: name_cursor + + nullify(header_list) + + ! First find out how many time-dependent headers there are + name_cursor => head + nheaders = 0 + do while (associated(name_cursor)) + if (associated(name_cursor%fieldlist_head)) then + if (.not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then + nheaders = nheaders + 1 + end if + end if + name_cursor => name_cursor%next + end do + + allocate(header_list(nheaders)) + + name_cursor => head + nheaders = 0 + do while (associated(name_cursor)) + if (associated(name_cursor%fieldlist_head)) then + if (.not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then + nheaders = nheaders + 1 + call dup(name_cursor%fieldlist_head%fg_data, header_list(nheaders)) + end if + end if + name_cursor => name_cursor%next + end do + + end subroutine storage_get_all_headers + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_get_all_td_headers + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_get_td_headers(header_list) + + implicit none + + ! Arguments + type (fg_input), pointer, dimension(:) :: header_list + + ! Local variables + integer :: nheaders + type (head_node), pointer :: name_cursor + + nullify(header_list) + + ! First find out how many time-dependent headers there are + name_cursor => head + nheaders = 0 + do while (associated(name_cursor)) + if (associated(name_cursor%fieldlist_head)) then + if (is_time_dependent(name_cursor%fieldlist_head%fg_data) .and. & + .not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then + nheaders = nheaders + 1 + end if + end if + name_cursor => name_cursor%next + end do + + allocate(header_list(nheaders)) + + name_cursor => head + nheaders = 0 + do while (associated(name_cursor)) + if (associated(name_cursor%fieldlist_head)) then + if (is_time_dependent(name_cursor%fieldlist_head%fg_data) .and. & + .not. is_mask_field(name_cursor%fieldlist_head%fg_data)) then + nheaders = nheaders + 1 + call dup(name_cursor%fieldlist_head%fg_data, header_list(nheaders)) + end if + end if + name_cursor => name_cursor%next + end do + + end subroutine storage_get_td_headers + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_print_fields + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_print_fields() + + use list_module + use stringutil + + implicit none + + ! Local variables + integer :: i, j, k, lmax, n_fields, n_levels, max_levels, itemp + logical, allocatable, dimension(:,:) :: field_has_level + integer, allocatable, dimension(:) :: all_levels + integer, pointer, dimension(:) :: ilevels + character (len=128), allocatable, dimension(:) :: fieldname_list + character (len=9) :: ctemp + type (fg_input), pointer, dimension(:) :: header_list + + type (list) :: all_levs + + !CWH Initialize local pointer variables + nullify(ilevels) + nullify(header_list) !MGD initialization for header_list should not be necessary + + call list_init(all_levs) + call storage_get_td_headers(header_list) + n_fields = size(header_list) + + allocate(fieldname_list(n_fields)) + + max_levels = 0 + + do i=1,n_fields + fieldname_list(i) = header_list(i)%header%field + call storage_get_levels(header_list(i), ilevels) + do j=1,size(ilevels) + if (.not. list_search(all_levs, ikey=ilevels(j), ivalue=itemp)) then + call list_insert(all_levs, ikey=ilevels(j), ivalue=ilevels(j)) + end if + end do + n_levels = size(ilevels) + if (n_levels > max_levels) max_levels = n_levels + if (associated(ilevels)) deallocate(ilevels) + end do + + max_levels = list_length(all_levs) + + allocate(all_levels(max_levels)) + allocate(field_has_level(n_fields,max_levels)) + + field_has_level(:,:) = .false. + + lmax = 0 + do i=1,n_fields + call storage_get_levels(header_list(i), ilevels) + n_levels = size(ilevels) + do j=1,n_levels + do k=1,lmax + if (all_levels(k) == ilevels(j)) exit + end do + if (k > lmax) then + all_levels(k) = ilevels(j) + lmax = lmax + 1 + end if + field_has_level(i,k) = .true. + end do + if (associated(ilevels)) deallocate(ilevels) + end do + + call mprintf(.true.,DEBUG,' .',newline=.false.) + do i=1,n_fields + write(ctemp,'(a9)') fieldname_list(i)(1:9) + call right_justify(ctemp,9) + call mprintf(.true.,DEBUG,ctemp,newline=.false.) + end do + call mprintf(.true.,DEBUG,' ',newline=.true.) + do j=1,max_levels + write(ctemp,'(i9)') all_levels(j) + call mprintf(.true.,DEBUG,'%s ',s1=ctemp,newline=.false.) + do i=1,n_fields + if (field_has_level(i,j)) then + call mprintf(.true.,DEBUG,' X',newline=.false.) + else + call mprintf(.true.,DEBUG,' -',newline=.false.) + end if + end do + call mprintf(.true.,DEBUG,' ',newline=.true.) + end do + + deallocate(all_levels) + deallocate(field_has_level) + deallocate(fieldname_list) + deallocate(header_list) + + call list_destroy(all_levs) + + end subroutine storage_print_fields + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: find_missing_values + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine find_missing_values() + + implicit none + + ! Local variables + integer :: i, j + logical :: found_missing + type (head_node), pointer :: name_cursor + type (data_node), pointer :: data_cursor + + found_missing = .false. + + name_cursor => head + do while (associated(name_cursor)) + + if (associated(name_cursor%fieldlist_head)) then + data_cursor => name_cursor%fieldlist_head + do while ( associated(data_cursor) ) + if (.not. associated(data_cursor%fg_data%valid_mask)) then + call mprintf(.true.,INFORM, & + 'Field %s does not have a valid mask and will not be checked for missing values', & + s1=data_cursor%fg_data%header%field) + else + ILOOP: do i=1,data_cursor%fg_data%header%dim1(2)-data_cursor%fg_data%header%dim1(1)+1 + JLOOP: do j=1,data_cursor%fg_data%header%dim2(2)-data_cursor%fg_data%header%dim2(1)+1 + if (.not. bitarray_test(data_cursor%fg_data%valid_mask,i,j)) then + found_missing = .true. + call mprintf(.true.,WARN,'Field %s has missing values at level %i at (i,j)=(%i,%i)', & + s1=data_cursor%fg_data%header%field, & + i1=data_cursor%fg_data%header%vertical_level, & + i2=i+data_cursor%fg_data%header%dim1(1)-1, & + i3=j+data_cursor%fg_data%header%dim2(1)-1) + exit ILOOP + end if + end do JLOOP + end do ILOOP + end if + data_cursor => data_cursor%next + end do + end if + + name_cursor => name_cursor%next + end do + + call mprintf(found_missing,ERROR,'Missing values encountered in interpolated fields. Stopping.') + + end subroutine find_missing_values + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: storage_print_headers + ! + ! Purpose: + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine storage_print_headers() + + implicit none + + ! Local variables + type (head_node), pointer :: name_cursor + type (data_node), pointer :: data_cursor + + call mprintf(.true.,DEBUG,'>>>> STORED FIELDS <<<<') + call mprintf(.true.,DEBUG,'=======================') + + ! We'll first see if there is already a list for this fieldname + name_cursor => head + do while (associated(name_cursor)) + call print_header(name_cursor%fg_data) + + if (associated(name_cursor%fieldlist_head)) then + data_cursor => name_cursor%fieldlist_head + do while ( associated(data_cursor) ) + call mprintf(.true.,DEBUG,' - %i', i1=get_level(data_cursor%fg_data)) + call mprintf(.true.,DEBUG,' ') + data_cursor => data_cursor%next + end do + end if + + name_cursor => name_cursor%next + end do + + end subroutine storage_print_headers + +end module storage_module diff --git a/WPS/metgrid/src/target_mesh.F b/WPS/metgrid/src/target_mesh.F new file mode 100644 index 00000000..91023c40 --- /dev/null +++ b/WPS/metgrid/src/target_mesh.F @@ -0,0 +1,214 @@ +module target_mesh + + type target_mesh_type + logical :: valid = .false. + integer :: irank = 0 + integer :: nLat = 0 + integer :: nLon = 0 + real :: startLat = 0.0 + real :: endLat = 0.0 + real :: startLon = 0.0 + real :: endLon = 0.0 + real, dimension(:,:), pointer :: lats => null() + real, dimension(:,:), pointer :: lons => null() + end type target_mesh_type + + + contains + + + integer function target_mesh_setup(mesh, lat2d, lon2d) result(stat) + + implicit none + + type (target_mesh_type), intent(out) :: mesh + real, dimension(:,:), target, optional :: lat2d + real, dimension(:,:), target, optional :: lon2d + + integer :: i, j + integer :: iostatus + integer :: eqIdx + real :: delta + logical :: exists + character (len=64) :: spec + real, parameter :: pi_const = 2.0 * asin(1.0) + + stat = 0 + + ! + ! If 2-d arrays of latitude and longitude are provided, we can just + ! point to those arrays rather than generate lat/lon values based on + ! a specified target domain + ! + if (present(lat2d) .and. present(lon2d)) then + + mesh % irank = 1 + mesh % nLat = size(lat2d,2) + mesh % nLon = size(lon2d,1) + mesh % lats => lat2d + mesh % lons => lon2d + mesh % valid = .true. + + return + end if + + + ! + ! Try to parse nLat, nLon from target_domain file + ! + inquire(file='target_domain', exist=exists) + if (exists) then + write(0,*) ' ' + write(0,*) 'Reading target domain specification from file ''target_domain''' + + mesh % startLat = -90.0 + mesh % endLat = 90.0 + mesh % startLon = -180.0 + mesh % endLon = 180.0 + mesh % nLat = 360 + mesh % nLon = 720 + + open(22, file='target_domain', form='formatted') + read(22,fmt='(a)',iostat=iostatus) spec + j = 1 + do while (iostatus >= 0) + call despace(spec) + eqIdx = index(spec, '=') + if (eqIdx /= 0) then + if (spec(1:eqIdx-1) == 'nlat') then + read(spec(eqIdx+1:len_trim(spec)),fmt=*) mesh % nLat + write(0,*) 'Setting nlat = ', mesh % nLat + else if (spec(1:eqIdx-1) == 'nlon') then + read(spec(eqIdx+1:len_trim(spec)),fmt=*) mesh % nLon + write(0,*) 'Setting nlon = ', mesh % nLon + else if (spec(1:eqIdx-1) == 'startlat') then + read(spec(eqIdx+1:len_trim(spec)),fmt=*) mesh % startLat + write(0,*) 'Setting startlat = ', mesh % startLat + else if (spec(1:eqIdx-1) == 'endlat') then + read(spec(eqIdx+1:len_trim(spec)),fmt=*) mesh % endLat + write(0,*) 'Setting endlat = ', mesh % endLat + else if (spec(1:eqIdx-1) == 'startlon') then + read(spec(eqIdx+1:len_trim(spec)),fmt=*) mesh % startLon + write(0,*) 'Setting startlon = ', mesh % startLon + else if (spec(1:eqIdx-1) == 'endlon') then + read(spec(eqIdx+1:len_trim(spec)),fmt=*) mesh % endLon + write(0,*) 'Setting endlon = ', mesh % endLon + else + write(0,*) 'Unrecognized keyword on line ', j, ' of file ''target_domain'': '//spec(1:eqIdx-1) + stat = 1 + close(22) + return + end if + else + write(0,*) 'Syntax error on line ', j, ' of file ''target_domain'': ''='' not found' + stat = 1 + close(22) + return + end if + read(22,fmt='(a)',iostat=iostatus) spec + j = j + 1 + end do + close(22) + else + write(0,*) ' ' + write(0,*) 'Target domain specification file ''target_domain'' not found.' + write(0,*) 'Default 0.5-degree global target domain will be used.' + write(0,*) ' ' + + mesh % startLat = -90.0 + mesh % endLat = 90.0 + mesh % startLon = -180.0 + mesh % endLon = 180.0 + mesh % nLat = 360 + mesh % nLon = 720 + end if + + + allocate(mesh % lats(1, mesh % nLat)) + allocate(mesh % lons(mesh % nLon, 1)) + + delta = (mesh % endLat - mesh % startLat) / real(mesh % nLat) + do i=0,mesh % nLat-1 + mesh % lats(1,i+1) = mesh % startLat + 0.5 * delta + real(i) * delta + mesh % lats(1,i+1) = mesh % lats(1,i+1) * pi_const / 180.0 + end do + + delta = (mesh % endLon - mesh % startLon) / real(mesh % nLon) + do i=0,mesh % nLon-1 + mesh % lons(i+1,1) = mesh % startLon + 0.5 * delta + real(i) * delta + mesh % lons(i+1,1) = mesh % lons(i+1,1) * pi_const / 180.0 + end do + + mesh % valid = .true. + + end function target_mesh_setup + + + integer function target_mesh_free(mesh) result(stat) + + implicit none + + type (target_mesh_type), intent(inout) :: mesh + + + stat = 0 + + mesh % valid = .false. + mesh % nLat = 0 + mesh % nLon = 0 + mesh % startLat = 0.0 + mesh % endLat = 0.0 + mesh % startLon = 0.0 + mesh % endLon = 0.0 + + ! + ! When irank == 0, we allocated the lats and lons arrays + ! internally and should therefore deallocate them + ! + if (mesh % irank == 0) then + if (associated(mesh % lats)) deallocate(mesh % lats) + if (associated(mesh % lons)) deallocate(mesh % lons) + end if + + end function target_mesh_free + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: despace + ! + ! Purpose: Remove all space and tab characters from a string, thus + ! compressing the string to the left. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine despace(string) + + implicit none + + ! Arguments + character (len=*), intent(inout) :: string + + ! Local variables + integer :: i, j, length, iquoted + + length = len(string) + + iquoted = 0 + j = 1 + do i=1,length + ! Check for a quote mark + if (string(i:i) == '"' .or. string(i:i) == '''') iquoted = mod(iquoted+1,2) + + ! Check for non-space, non-tab character, or if we are inside quoted + ! text + if ((string(i:i) /= ' ' .and. string(i:i) /= achar(9)) .or. iquoted == 1) then + string(j:j) = string(i:i) + j = j + 1 + end if + end do + + do i=j,length + string(i:i) = ' ' + end do + + end subroutine despace + +end module target_mesh diff --git a/WPS/metgrid/src/wrf_debug.F b/WPS/metgrid/src/wrf_debug.F new file mode 120000 index 00000000..a2872c95 --- /dev/null +++ b/WPS/metgrid/src/wrf_debug.F @@ -0,0 +1 @@ +../../geogrid/src/wrf_debug.F \ No newline at end of file diff --git a/WPS/metgrid/src/write_met_module.F b/WPS/metgrid/src/write_met_module.F new file mode 100644 index 00000000..ffdba350 --- /dev/null +++ b/WPS/metgrid/src/write_met_module.F @@ -0,0 +1,408 @@ +module write_met_module + + use module_debug + use misc_definitions_module + use met_data_module + + ! State variables? + integer :: output_unit + character (len=MAX_FILENAME_LEN) :: met_out_filename + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: write_met_init + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine write_met_init(fg_source, source_is_constant, datestr, istatus) + + implicit none + + ! Arguments + integer, intent(out) :: istatus + logical, intent(in) :: source_is_constant + character (len=*), intent(in) :: fg_source + character (len=*), intent(in) :: datestr + + ! Local variables + integer :: io_status + logical :: is_used + + istatus = 0 + + ! 1) BUILD FILENAME BASED ON TIME + met_out_filename = ' ' + if (.not. source_is_constant) then + write(met_out_filename, '(a)') trim(fg_source)//':'//trim(datestr) + else + write(met_out_filename, '(a)') trim(fg_source) + end if + + ! 2) OPEN FILE + do output_unit=10,100 + inquire(unit=output_unit, opened=is_used) + if (.not. is_used) exit + end do + call mprintf((output_unit > 100),ERROR,'In write_met_init(), couldn''t find an available Fortran unit.') + open(unit=output_unit, file=trim(met_out_filename), status='unknown', form='unformatted', iostat=io_status) + + if (io_status > 0) istatus = 1 + + return + + + end subroutine write_met_init + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: write_next_met_field + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine write_next_met_field(fg_data, istatus) + + implicit none + + ! Arguments + type (met_data), intent(in) :: fg_data + integer, intent(out) :: istatus + + ! Local variables + character (len=8) :: startloc + character (len=9) :: local_field + + istatus = 1 + + ! 1) WRITE FORMAT VERSION + write(unit=output_unit) fg_data % version + + local_field = fg_data % field + if (local_field == 'GHT ') local_field = 'HGT ' + + ! PREGRID + if (fg_data % version == 3) then + + ! Cylindrical equidistant + if (fg_data % iproj == PROJ_LATLON) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 0 + write(unit=output_unit) fg_data % startlat, & + fg_data % startlon, & + fg_data % deltalat, & + fg_data % deltalon + + ! Mercator + else if (fg_data % iproj == PROJ_MERC) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 1 + write(unit=output_unit) fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % truelat1 + + ! Lambert conformal + else if (fg_data % iproj == PROJ_LC) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 3 + write(unit=output_unit) fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1, & + fg_data % truelat2 + + ! Polar stereographic + else if (fg_data % iproj == PROJ_PS) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 5 + write(unit=output_unit) fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1 + + ! ????????? + else + call mprintf(.true.,ERROR,'Unrecognized projection code %i when reading from %s.', & + i1=fg_data % iproj,s1=met_out_filename) + + end if + + write(unit=output_unit) fg_data % slab + + istatus = 0 + + ! GRIB_PREP + else if (fg_data % version == 4) then + + if (fg_data % starti == 1.0 .and. fg_data % startj == 1.0) then + startloc='SWCORNER' + else + startloc='CENTER ' + end if + + ! Cylindrical equidistant + if (fg_data % iproj == PROJ_LATLON) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % map_source, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 0 + write(unit=output_unit) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % deltalat, & + fg_data % deltalon + + ! Mercator + else if (fg_data % iproj == PROJ_MERC) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % map_source, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 1 + write(unit=output_unit) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % truelat1 + + ! Lambert conformal + else if (fg_data % iproj == PROJ_LC) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % map_source, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 3 + write(unit=output_unit) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1, & + fg_data % truelat2 + + ! Polar stereographic + else if (fg_data % iproj == PROJ_PS) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % map_source, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 5 + write(unit=output_unit) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1 + + ! ????????? + else + call mprintf(.true.,ERROR,'Unrecognized projection code %i when reading from %s.', & + i1=fg_data % iproj,s1=met_out_filename) + + end if + + write(unit=output_unit) fg_data % slab + + istatus = 0 + + ! WPS + else if (fg_data % version == 5) then + + if (fg_data % starti == 1.0 .and. fg_data % startj == 1.0) then + startloc='SWCORNER' + else + startloc='CENTER ' + end if + + ! Cylindrical equidistant + if (fg_data % iproj == PROJ_LATLON) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % map_source, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 0 + write(unit=output_unit) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % deltalat, & + fg_data % deltalon, & + fg_data % earth_radius + + ! Mercator + else if (fg_data % iproj == PROJ_MERC) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % map_source, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 1 + write(unit=output_unit) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % truelat1, & + fg_data % earth_radius + + ! Lambert conformal + else if (fg_data % iproj == PROJ_LC) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % map_source, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 3 + write(unit=output_unit) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1, & + fg_data % truelat2, & + fg_data % earth_radius + + ! Gaussian + else if (fg_data % iproj == PROJ_GAUSS) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % map_source, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 4 + write(unit=output_unit) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % deltalat, & + fg_data % deltalon, & + fg_data % earth_radius + + ! Polar stereographic + else if (fg_data % iproj == PROJ_PS) then + write(unit=output_unit) fg_data % hdate, & + fg_data % xfcst, & + fg_data % map_source, & + local_field, & + fg_data % units, & + fg_data % desc, & + fg_data % xlvl, & + fg_data % nx, & + fg_data % ny, & + 5 + write(unit=output_unit) startloc, & + fg_data % startlat, & + fg_data % startlon, & + fg_data % dx, & + fg_data % dy, & + fg_data % xlonc, & + fg_data % truelat1, & + fg_data % earth_radius + + ! ????????? + else + call mprintf(.true.,ERROR,'Unrecognized projection code %i when reading from %s.', & + i1=fg_data % iproj,s1=met_out_filename) + + end if + + write(unit=output_unit) fg_data % is_wind_grid_rel + + write(unit=output_unit) fg_data % slab + + istatus = 0 + + else + call mprintf(.true.,ERROR,'Didn''t recognize format number %i.', i1=fg_data % version) + end if + + return + + end subroutine write_next_met_field + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: write_met_close + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine write_met_close() + + implicit none + + close(unit=output_unit) + met_out_filename = 'UNINITIALIZED_FILENAME' + + end subroutine write_met_close + +end module write_met_module diff --git a/WPS/namelist.wps b/WPS/namelist.wps new file mode 100644 index 00000000..8c2273d0 --- /dev/null +++ b/WPS/namelist.wps @@ -0,0 +1,52 @@ +&share + wrf_core = 'ARW', + max_dom = 2, + start_date = '2006-08-16_12:00:00','2006-08-16_12:00:00', + end_date = '2006-08-16_18:00:00','2006-08-16_12:00:00', + interval_seconds = 21600 + io_form_geogrid = 2, +/ + +&geogrid + parent_id = 1, 1, + parent_grid_ratio = 1, 3, + i_parent_start = 1, 31, + j_parent_start = 1, 17, + e_we = 74, 112, + e_sn = 61, 97, + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT NOTE !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! The default datasets used to produce the HGT_M, GREENFRAC, + ! and LU_INDEX/LANDUSEF fields have changed in WPS v3.8. The HGT_M field + ! is now interpolated from 30-arc-second USGS GMTED2010, the GREENFRAC + ! field is interpolated from MODIS FPAR, and the LU_INDEX/LANDUSEF fields + ! are interpolated from 21-class MODIS. + ! + ! To match the output given by the default namelist.wps in WPS v3.7.1, + ! the following setting for geog_data_res may be used: + ! + ! geog_data_res = 'gtopo_10m+usgs_10m+nesdis_greenfrac+10m','gtopo_2m+usgs_2m+nesdis_greenfrac+2m', + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT NOTE !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + geog_data_res = 'default','default', + dx = 30000, + dy = 30000, + map_proj = 'lambert', + ref_lat = 34.83, + ref_lon = -81.03, + truelat1 = 30.0, + truelat2 = 60.0, + stand_lon = -98.0, + geog_data_path = '/glade/p/work/wrfhelp/WPS_GEOG/' +/ + +&ungrib + out_format = 'WPS', + prefix = 'FILE', +/ + +&metgrid + fg_name = 'FILE' + io_form_metgrid = 2, +/ diff --git a/WPS/namelist.wps.all_options b/WPS/namelist.wps.all_options new file mode 100644 index 00000000..5b90b635 --- /dev/null +++ b/WPS/namelist.wps.all_options @@ -0,0 +1,103 @@ +&share + wrf_core = 'ARW', + max_dom = 2, + start_date = '2006-08-16_12:00:00','2006-08-16_12:00:00', + end_date = '2006-08-16_18:00:00','2006-08-16_12:00:00', + interval_seconds = 21600 + active_grid = .true., .true., + subgrid_ratio_x = 1 + subgrid_ratio_y = 1 + io_form_geogrid = 2, + opt_output_from_geogrid_path = './', + debug_level = 0 +/ + start_date = '2000-01-24_12:00:00','2000-01-24_12:00:00', + end_date = '2000-01-25_12:00:00','2000-01-24_12:00:00', + start_year = 2006, 2006, + start_month = 08, 08, + start_day = 16, 16, + start_hour = 12, 12, + start_minute = 00, 00, + start_second = 00, 00, + end_year = 2006, 2006, + end_month = 08, 08, + end_day = 16, 16, + end_hour = 18, 12, + end_minute = 00, 00, + end_second = 00, 00, + +&geogrid + parent_id = 1, 1, + parent_grid_ratio = 1, 3, + i_parent_start = 1, 31, + j_parent_start = 1, 17, + s_we = 1, 1, + e_we = 74, 112, + s_sn = 1, 1, + e_sn = 61, 97, + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT NOTE !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! The default datasets used to produce the HGT_M, GREENFRAC, + ! and LU_INDEX/LANDUSEF fields have changed in WPS v3.8. The HGT_M field + ! is now interpolated from 30-arc-second USGS GMTED2010, the GREENFRAC + ! field is interpolated from MODIS FPAR, and the LU_INDEX/LANDUSEF fields + ! are interpolated from 21-class MODIS. + ! + ! To match the output given by the default namelist.wps.all_options + ! in WPS v3.7.1, the following setting for geog_data_res may be used: + ! + ! geog_data_res = 'gtopo_10m+usgs_10m+nesdis_greenfrac+10m','gtopo_2m+usgs_2m+nesdis_greenfrac+2m', + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT NOTE !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + geog_data_res = 'default','default', + dx = 30000, + dy = 30000, + map_proj = 'lambert', + ref_lat = 34.83, + ref_lon = -81.03, + ref_x = 37.0, + ref_y = 30.5, + truelat1 = 30.0, + truelat2 = 60.0, + stand_lon = -98.0, + geog_data_path = '/glade/p/work/wrfhelp/WPS_GEOG/' + opt_geogrid_tbl_path = 'geogrid/' +/ + geog_data_res = 'modis_lakes+10m','modis_lakes+2m', + geog_data_res = 'usgs_lakes+10m','usgs_lakes+2m', + +&ungrib + out_format = 'WPS', + prefix = 'FILE', +/ + +&metgrid + fg_name = 'FILE' + constants_name = './TAVGSFC' + io_form_metgrid = 2, + opt_output_from_metgrid_path = './', + opt_metgrid_tbl_path = 'metgrid/', + process_only_bdy = 5, +/ + +&mod_levs + press_pa = 201300 , 200100 , 100000 , + 95000 , 90000 , + 85000 , 80000 , + 75000 , 70000 , + 65000 , 60000 , + 55000 , 50000 , + 45000 , 40000 , + 35000 , 30000 , + 25000 , 20000 , + 15000 , 10000 , + 5000 , 1000 +/ + +&plotfmt + ix = 100 + jx = 100 + ioff = 30 + joff = 30 +/ diff --git a/WPS/namelist.wps.fire b/WPS/namelist.wps.fire new file mode 100755 index 00000000..348660e3 --- /dev/null +++ b/WPS/namelist.wps.fire @@ -0,0 +1,56 @@ +&share + wrf_core = 'ARW', + max_dom = 1, + start_date = '2005-08-28_12:00:00','2008-05-19_12:00:00','2008-05-19_12:00:00','2008-05-19_12:00:00','2008-05-19_12:00:00','2008-05-19_12:00:00', + end_date = '2005-08-28_18:00:00','2008-05-19_18:00:00','2008-05-19_18:00:00','2008-05-19_18:00:00','2008-05-19_18:00:00','2008-05-19_18:00:00', + interval_seconds = 21600 + io_form_geogrid = 2, + subgrid_ratio_x = 10, + subgrid_ratio_y = 10, +/ + +&geogrid + parent_id = 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, + parent_grid_ratio = 1, 3, 3, 3, 3, 3, 3, 3, 3, 3, + i_parent_start = 1, 15, 15, 15, 15, 15, 15, 15, 15, 15, + j_parent_start = 1, 15, 15, 15, 15, 15, 15, 15, 15, 15, + e_we = 43, 43, 43, 43, 43, 43, 43, 43, 43, 43, + e_sn = 43, 43, 43, 43, 43, 43, 43, 43, 43, 43, + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT NOTE !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! The default datasets used to produce the HGT_M, GREENFRAC, + ! and LU_INDEX/LANDUSEF fields have changed in WPS v3.8. The HGT_M field + ! is now interpolated from 30-arc-second USGS GMTED2010, the GREENFRAC + ! field is interpolated from MODIS FPAR, and the LU_INDEX/LANDUSEF fields + ! are interpolated from 21-class MODIS. + ! + ! To match the output given by the default namelist.wps.fire in WPS v3.7.1, + ! the following setting for geog_data_res may be used: + ! + ! geog_data_res = 'gtopo_30s+usgs_30s+nesdis_greenfrac+30s','gtopo_2m+usgs_2m+nesdis_greenfrac+2m', [repeat the previous string...] + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT NOTE !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + geog_data_res = 'default','default','default','default','default','default','default','default','default','default', + + geog_data_res = '30s','2m','2m','2m','2m','2m','2m','2m','2m','2m', + dx = 60, + dy = 60, + map_proj = 'lambert', + ref_lat = 39.70537, + ref_lon = -107.2907, + truelat1 = 39.338, + truelat2 = 39.338, + stand_lon = -106.807, + geog_data_path = '/glade/p/work/wrfhelp/WPS_GEOG/' +/ + +&ungrib + out_format = 'WPS', + prefix = 'FILE', +/ + +&metgrid + fg_name = 'FILE' + io_form_metgrid = 2, +/ diff --git a/WPS/namelist.wps.global b/WPS/namelist.wps.global new file mode 100644 index 00000000..ba8d16f1 --- /dev/null +++ b/WPS/namelist.wps.global @@ -0,0 +1,66 @@ +&share + wrf_core = 'ARW', + max_dom = 2, + start_date = '2006-08-16_12:00:00','2006-08-16_12:00:00', + end_date = '2006-08-16_12:00:00','2006-08-16_12:00:00', + interval_seconds = 21600 + io_form_geogrid = 2, +/ + +&geogrid + parent_id = 1, 1, + parent_grid_ratio = 1, 3, + i_parent_start = 1, 31, + j_parent_start = 1, 17, + e_we = 129, 127, + e_sn = 65, 64, + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT NOTE !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! The default datasets used to produce the HGT_M, GREENFRAC, + ! and LU_INDEX/LANDUSEF fields have changed in WPS v3.8. The HGT_M field + ! is now interpolated from 30-arc-second USGS GMTED2010, the GREENFRAC + ! field is interpolated from MODIS FPAR, and the LU_INDEX/LANDUSEF fields + ! are interpolated from 21-class MODIS. + ! + ! To match the output given by the default namelist.wps.global in WPS v3.7.1, + ! the following setting for geog_data_res may be used: + ! + ! geog_data_res = 'gtopo_10m+usgs_10m+nesdis_greenfrac+10m','gtopo_10mm+usgs_10m+nesdis_greenfrac+10m', + ! + !!!!!!!!!!!!!!!!!!!!!!!!!!!! IMPORTANT NOTE !!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! + geog_data_res = 'default','default', + map_proj = 'lat-lon', + stand_lon = 0. + pole_lat = 90.0 + pole_lon = 0.0 + geog_data_path = '/glade/p/work/wrfhelp/WPS_GEOG/' +/ + ref_lat = 45.0 + ref_lon = -98 + dx = 1.0 + dy = 1.0 + +&ungrib + out_format = 'WPS', + prefix = 'FILE', +/ + +&metgrid + fg_name = 'FILE' + io_form_metgrid = 2, +/ + +&mod_levs + press_pa = 201300 , 200100 , 100000 , + 95000 , 90000 , + 85000 , 80000 , + 75000 , 70000 , + 65000 , 60000 , + 55000 , 50000 , + 45000 , 40000 , + 35000 , 30000 , + 25000 , 20000 , + 15000 , 10000 , + 5000 , 1000 +/ diff --git a/WPS/namelist.wps.nmm b/WPS/namelist.wps.nmm new file mode 100644 index 00000000..4fae4724 --- /dev/null +++ b/WPS/namelist.wps.nmm @@ -0,0 +1,34 @@ +&share + wrf_core = 'NMM', + max_dom = 1, + start_date = '2005-01-23_00:00:00', + end_date = '2005-01-24_00:00:00', + interval_seconds = 10800 + io_form_geogrid = 2, +/ + +&geogrid + parent_id = 1, 1, + parent_grid_ratio = 1, 3, + i_parent_start = 1, 17, + j_parent_start = 1, 31, + e_we = 56, 58, + e_sn = 92, 100, + geog_data_res = '5m', '2m', + dx = 0.096290, + dy = 0.096011, + map_proj = 'rotated_ll', + ref_lat = 42.00, + ref_lon = -71.00, + geog_data_path = '/glade/p/work/wrfhelp/WPS_GEOG/' +/ + +&ungrib + out_format = 'WPS', + prefix = 'FILE', +/ + +&metgrid + fg_name = 'FILE' + io_form_metgrid = 2, +/ diff --git a/WPS/ungrib/.gitignore b/WPS/ungrib/.gitignore new file mode 100644 index 00000000..d5df9f81 --- /dev/null +++ b/WPS/ungrib/.gitignore @@ -0,0 +1,2 @@ +g1print.exe +g2print.exe diff --git a/WPS/ungrib/Makefile b/WPS/ungrib/Makefile new file mode 100644 index 00000000..c94c0c24 --- /dev/null +++ b/WPS/ungrib/Makefile @@ -0,0 +1,50 @@ +include $(DEV_TOP)/configure.wps + +bad_idea: + clear + @echo ' *************** ' + @echo " " + @echo " " + @echo "Go up a directory and type 'compile'" + @echo " " + @echo " " + @echo ' *************** ' + +all: + ( cd src/ngl ; $(MAKE) DEV_TOP="$(DEV_TOP)" CC="$(SCC)" FC="$(SFC)" RANLIB="$(RANLIB)" all ) + ( cd src ; \ + if [ "$(COMPILING_ON_CYGWIN_NT)" = yes ] ; then \ + WRF_DIR2=$(WRF_DIR) ; \ + else \ + WRF_DIR2=$(WRF_DIR_PRE)$(WRF_DIR) ; \ + fi ; \ + $(MAKE) $(TARGET) \ + WRF_DIR="$$WRF_DIR2" \ + FC="$(SFC)" \ + CC="$(CC)" \ + CPP="$(CPP)" \ + FFLAGS="$(FFLAGS)" \ + CFLAGS="$(CFLAGS)" \ + LDFLAGS="$(LDFLAGS)" \ + CPPFLAGS="$(CPPFLAGS) -D_$(CPP_TARGET)" ) + if [ -h $(TARGET) ] ; then \ + $(RM) $(TARGET) ; \ + fi ; \ + if [ -h ../$(TARGET) ] ; then \ + $(RM) ../$(TARGET) ; \ + fi ; \ + if [ -e src/$(TARGET) ] ; then \ + $(LN) src/$(TARGET) . ; \ + fi + +clean: + ( cd src/ngl ; $(MAKE) DEV_TOP="$(DEV_TOP)" clean ) + if [ -h $(TARGET) ] ; then \ + $(RM) $(TARGET) ; \ + fi + if [ -h ../$(TARGET) ] ; then \ + $(RM) ../$(TARGET) ; \ + fi + ( cd src ; $(MAKE) clean ) + +superclean: clean diff --git a/WPS/ungrib/README_LIBS b/WPS/ungrib/README_LIBS new file mode 100644 index 00000000..9bada77a --- /dev/null +++ b/WPS/ungrib/README_LIBS @@ -0,0 +1,24 @@ +Support routines for grib2 compression: + + + +These have been incorporated into the WPS code: + +g2lib from http://www.nco.ncep.noaa.gov/pmb/codes/GRIB2/ + version 1.0.7.1 (3/29/06) + +w3lib from http://www.nco.ncep.noaa.gov/pmb/codes/GRIB2/ + version 1.1 (3/29/06) + + + +These are external libraries that are assumed available: + +jasper from http://www.ece.uvic.ca/~mdadams/jasper/ + (called jpeg2000 here) (3/24/06) + +zlib from http://www.zlib.net + version 1.2.3 (3/30/06) + +libpng from http://www.libpng.org/pub/png/libpng.html + version 1.2.8 (3/30/06) diff --git a/WPS/ungrib/Variable_Tables/README b/WPS/ungrib/Variable_Tables/README new file mode 100644 index 00000000..ce33c88e --- /dev/null +++ b/WPS/ungrib/Variable_Tables/README @@ -0,0 +1,54 @@ + + Listing of Vtables + +Vtable.AFWAICE U.S. Air Force Weather Agency ice fields. +Vtable.AGRMETSNOW U.S. Air Force Weather Agency Agricultural Meteorology fields (not publically available) +Vtable.AGRMETSOIL +Vtable.AGRMETSOIL2 +Vtable.AGRWRF + +Vtable.ARW WRF-ARW +Vtable.ARWp +Vtable.AVN0P5WRF Grib 1 legacy Vtable for 0.5 degree NCEP AVN +Vtable.AWIP Grib 1 legacy Vtable for NCEP NGM 'AWIPS' grid + +Vtable.CFSR2_web Climate Forecast System Reanalysis 2 +Vtable.CFSR_mean Climate Forecast System Reanalysis Monthly mean from NOMADS. +Vtable.CFSR_press_pgbh06 CFSR pressure-level output from NCAR +Vtable.CFSR_sfc_flxf06 CFSR surface fields from NCAR + +Vtable.ECMWF ECMWF files. Note that there is a wide variety of content in files called 'ECMWF output'. + This Vtable is a general table for pressure-level output. +Vtable.ECMWF_sigma ECMWF sigma-level output +Vtable.ERA-interim.ml ERA interim model level +Vtable.ERA-interim.ml.SSTMSKD Masked SST +Vtable.ERA-interim.pl ERA interim pressure level output +Vtable.ERA-interim.pl.SSTMSKD Masked SST + +Vtable.GFDL Grib 1 legacy Vtable for NOAA GFDL +Vtable.GFS NCEP Global Forecast System (can also be used for GDAS, FNL, AVN files) +Vtable.GFS+TROP NCEP GFS including the 10 tropopause / max wind level fields +Vtable.GFSENS NCEP GFS ensemble files (GEFS) +Vtable.GODAS NCEP's Global Ocean data assimilation system +Vtable.GSM +Vtable.JMAGSM Japanese Meteorological Agency Global Spectral Model +Vtable.NAM NCEP North American Mesoscale model +Vtable.NARR NCEP North American Regional Reanalysis +Vtable.NCEP2 NCEP/DOE Reanalysis (Reanalysis-2) (also called R2, CDAS2, NCEP2) +Vtable.NNRP NCEP/NCAR Reanalysis Project (Grib 1) +Vtable.NOGAPS U.S. Navy NOGAPS model +Vtable.NOGAPS_needs_GFS_soil +Vtable.NavySST Grib 1 legacy Vtable for SST fields. +Vtable.RAP.hybrid.ncep NCEP Rapid Refresh (ARW) intepolated to hybrid levels (presumably for backward compatibility with RUC) +Vtable.RAP.pressure.ncep NCEP Rapid Refresh (ARW) pressure level output +Vtable.RAP.sigma.gsd NCEP Rapid Refresh (ARW) run by NOAA GSD +Vtable.RUCb NCEP RUC hybrid-level output +Vtable.RUCp NCEP RUC pressure-level output +Vtable.SST Generic Vtable for SST files +Vtable.TCRP Twentieth Century Global Reanalysis Version 2 +Vtable.UKMO_ENDGame U.K. Met Office model +Vtable.UKMO_LANDSEA +Vtable.UKMO_no_heights + + +Updated 12 Aug 2014 diff --git a/WPS/ungrib/Variable_Tables/Vtable.AFWAICE b/WPS/ungrib/Variable_Tables/Vtable.AFWAICE new file mode 100644 index 00000000..51fdb7fb --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.AFWAICE @@ -0,0 +1,10 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid | +Param| Type |Level1|Level2| Name | Units | Description | +-----+------+------+------+----------+---------+---------------------------------+ + 91 | 1 | 0 | | ICEMASK | flag | Ice mask flag | + 128 | 1 | 0 | | ICEFRAC | fraction| Ice fraction | + 129 | 1 | 0 | | ICEAGE | days | Ice age | +-----+------+------+------+----------+---------+---------------------------------+ +# +# Vtable for AFWA Ice fields. Grib 1 only. + diff --git a/WPS/ungrib/Variable_Tables/Vtable.AGRMETSNOW b/WPS/ungrib/Variable_Tables/Vtable.AGRMETSNOW new file mode 100644 index 00000000..5d471379 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.AGRMETSNOW @@ -0,0 +1,6 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 65 | 1 | 0 | | SNOW | kg m-2 | Water Equivalent Snow Depth | + 66 | 1 | 0 | | SNOWH | m | Height of Snow on Ground (Depth of Snow) | +-----+------+------+------+----------+----------+------------------------------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.AGRMETSOIL b/WPS/ungrib/Variable_Tables/Vtable.AGRMETSOIL new file mode 100644 index 00000000..2e2c6dfa --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.AGRMETSOIL @@ -0,0 +1,22 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+---------------------------------------------+ + 201 | 112 | 0 | 10 | SM000010 | fraction | Soil Moisture of 0-10 cm ground layer | + 201 | 112 | 10 | 40 | SM010040 | fraction | Soil Moisture of 10-40 cm ground layer | + 201 | 112 | 40 | 100 | SM040100 | fraction | Soil Moisture of 40-100 cm ground layer | + 201 | 112 | 100 | 200 | SM100200 | fraction | Soil Moisture of 100-200 cm ground layer | + 201 | 112 | 10 | 200 | SM010200 | fraction | Soil Moisture of 10-200 cm ground layer | + 211 | 112 | 0 | 10 | SW000010 | fraction | Soil Moisture (Liquid) of 0-10 cm ground | + 211 | 112 | 10 | 40 | SW010040 | fraction | Soil Moisture (Liquid) of 10-40 cm ground | + 211 | 112 | 40 | 100 | SW040100 | fraction | Soil Moisture (Liquid) of 40-100 cm ground | + 211 | 112 | 100 | 200 | SW100200 | fraction | Soil Moisture (Liquid) of 100-200 cm ground | + 211 | 112 | 10 | 200 | SW010200 | fraction | Soil Moisture (Liquid) of 10-200 cm ground | + 85 | 112 | 0 | 10 | ST000010 | K | T of 0-10 cm ground layer | + 85 | 112 | 10 | 40 | ST010040 | K | T of 10-40 cm ground layer | + 85 | 112 | 40 | 100 | ST040100 | K | T of 40-100 cm ground layer | + 85 | 112 | 100 | 200 | ST100200 | K | T of 100-200 cm ground layer | + 85 | 112 | 10 | 200 | ST010200 | K | T of 10-200 cm ground layer | + 81 | 1 | 0 | | LANDSEA | 0/1 Flag | Land/Sea flag | + 161 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | + 207 | 1 | 0 | | CANWAT | kg m-2 | Canopy Moisture Content | +-----+------+------+------+----------+----------+---------------------------------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.AGRMETSOIL2 b/WPS/ungrib/Variable_Tables/Vtable.AGRMETSOIL2 new file mode 100644 index 00000000..ce9eec2f --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.AGRMETSOIL2 @@ -0,0 +1,25 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+---------------------------------------------+ + 201 | 112 | 0 | 10 | SM000010 | fraction | Soil Moisture of 0-10 cm ground layer | + 201 | 112 | 10 | 40 | SM010040 | fraction | Soil Moisture of 10-40 cm ground layer | + 201 | 112 | 40 | 100 | SM040100 | fraction | Soil Moisture of 40-100 cm ground layer | + 201 | 112 | 100 | 200 | SM100200 | fraction | Soil Moisture of 100-200 cm ground layer | + 201 | 112 | 10 | 200 | SM010200 | fraction | Soil Moisture of 10-200 cm ground layer | + 211 | 112 | 0 | 10 | SW000010 | fraction | Soil Moisture (Liquid) of 0-10 cm ground | + 211 | 112 | 10 | 40 | SW010040 | fraction | Soil Moisture (Liquid) of 10-40 cm ground | + 211 | 112 | 40 | 100 | SW040100 | fraction | Soil Moisture (Liquid) of 40-100 cm ground | + 211 | 112 | 100 | 200 | SW100200 | fraction | Soil Moisture (Liquid) of 100-200 cm ground | + 211 | 112 | 10 | 200 | SW010200 | fraction | Soil Moisture (Liquid) of 10-200 cm ground | + 85 | 112 | 0 | 10 | ST000010 | K | T of 0-10 cm ground layer | + 85 | 112 | 10 | 40 | ST010040 | K | T of 10-40 cm ground layer | + 85 | 112 | 40 | 100 | ST040100 | K | T of 40-100 cm ground layer | + 85 | 112 | 100 | 200 | ST100200 | K | T of 100-200 cm ground layer | + 85 | 112 | 10 | 200 | ST010200 | K | T of 10-200 cm ground layer | + 81 | 1 | 0 | | LANDSEA | 0/1 Flag | Land/Sea flag | + 161 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | + 205 | 1 | 0 | | SOILINDX | category | Soil Category | + 207 | 1 | 0 | | CANWAT | kg m-2 | Canopy Moisture Content | + 212 | 1 | 0 | | LAND USE | category | Land Use and Vegetation Category | + 213 | 1 | 0 | | GREENFRC | % | Green Vegetation Fraction | +-----+------+------+------+----------+----------+---------------------------------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.AGRWRF b/WPS/ungrib/Variable_Tables/Vtable.AGRWRF new file mode 100644 index 00000000..9df39f26 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.AGRWRF @@ -0,0 +1,22 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 65 | 1 | 0 | | SNOW | kg m-2 | Water Equivalent of Accum Snow Depth | + 66 | 1 | 0 | | SNOWH | m | Snow Depth | + 85 | 112 | 0 | 10 | ST000010 | K | T of 0-10 cm ground layer | + 85 | 112 | 10 | 40 | ST010040 | K | T of 10-40 cm ground layer | + 85 | 112 | 40 |100 | ST040100 | K | T of 40-100 cm ground layer | + 85 | 112 | 100 |200 | ST100200 | K | T of 100-200 cm ground layer | + 201 | 112 | 0 | 10 | SM000010 | | Soil Moisture of 0-10 cm ground layer | + 201 | 112 | 10 | 40 | SM010040 | | Soil Moisture of 10-40 cm ground layer | + 201 | 112 | 40 |100 | SM040100 | | Soil Moisture of 40-100 cm ground layer | + 201 | 112 |100 |200 | SM100200 | | Soil Moisture of 100-200 cm ground layer | + 211 | 112 | 0 | 10 | SW000010 | | Soil Moisture (liquid) of 0-10 cm layer | + 211 | 112 | 10 | 40 | SW010040 | | Soil Moisture (liquid) of 10-40 cm layer | + 211 | 112 | 40 |100 | SW040100 | | Soil Moisture (liquid) of 40-100 layer | + 211 | 112 |100 |200 | SW100200 | | Soil Moisture (liquid) of 100-200 cm lay | + 81 | 1 | 0 | | AGRLSEA | | Land/Sea flag | + 207 | 1 | 0 | | CANWAT | m | Plant Canopy Surface Water | +-----+------+------+------+----------+----------+------------------------------------------+ +# +# AFWA diff --git a/WPS/ungrib/Variable_Tables/Vtable.ARW.UPP b/WPS/ungrib/Variable_Tables/Vtable.ARW.UPP new file mode 100644 index 00000000..44837480 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.ARW.UPP @@ -0,0 +1,47 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+----------+-----------------------------------------+-----------------------+ + 7 | 107 | * | | HGT | m | Height | 0 | 3 | 5 | 104 | + 1 | 107 | * | | PRESSURE | Pa | Pressure | 0 | 3 | 0 | 104 | + 11 | 107 | * | | TT | K | Temperature | 0 | 0 | 0 | 104 | + 51 | 107 | * | | SPECHUMD | kg kg-1 | Specific Humidity | 0 | 1 | 0 | 104 | + 33 | 107 | * | | UU | m s-1 | U | 0 | 2 | 2 | 104 | + 34 | 107 | * | | VV | m s-1 | V | 0 | 2 | 3 | 104 | + 153 | 107 | * | | QC | kg kg-1 | Cloud water mixing ratio | 0 | 1 | 22 | 104 | + 170 | 107 | * | | QR | kg kg-1 | Rain water mixing ratio | 0 | 1 | 24 | 104 | + 58 | 107 | * | | QI | kg kg-1 | Ice mixing ratio | 0 | 6 | 0 | 104 | + 171 | 107 | * | | QS | kg kg-1 | Snow water mixing ratio | 0 | 1 | 25 | 104 | + 179 | 107 | * | | QG | kg kg-1 | Graupel mixing ratio | 0 | 1 | 32 | 104 | + | 107 | * | | RH | % | Relative Humidity | 0 | 1 | | 104 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | Specific Humidity at 2 m | 0 | 1 | 0 | 103 | + | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Snow Temp 5 cm below sfc ( = TSK ) | 0 | 0 | 0 | 1 | + 144 | 1 | 0 | | SOILM000 | kg m-3 | Soil Moist 0 cm below ground | 2 | 0 | 192 | 1 | + 144 | 111 | 5 | | SOILM005 | kg m-3 | Soil Moist 5 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 20 | | SOILM020 | kg m-3 | Soil Moist 20 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 40 | | SOILM040 | kg m-3 | Soil Moist 40 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 160 | | SOILM160 | kg m-3 | Soil Moist 160 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 300 | | SOILM300 | kg m-3 | Soil Moist 300 cm below ground | 2 | 0 | 192 | 106 | + 85 | 1 | 0 | | SOILT000 | K | Soil Temp 0 cm below ground | 2 | 0 | 2 | 1 | + 85 | 111 | 5 | | SOILT005 | K | Soil Temp 5 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 20 | | SOILT020 | K | Soil Temp 20 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 40 | | SOILT040 | K | Soil Temp 40 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 160 | | SOILT160 | K | Soil Temp 160 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 300 | | SOILT300 | K | Soil Temp 300 cm below ground | 2 | 0 | 2 | 106 | + 91 | 1 | 0 | | SEAICE | | Ice flag | 10 | 2 | 0 | 1 | + 223 | 1 | 0 | | CANWAT | kg m-2 | Plant Canopy Surface Water | 2 | 0 | 196 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | +-----+------+------+------+----------+----------+-----------------------------------------+-----------------------+ + + +# Vtable for WRF-ARW output that has been processed by UPP and is on eta/sigma levels and in Grib format +# +# Note that ARW output written directly to Grib format cannot be used by ungrib. WPS cannot process +# ARW output fields such as MU (instead of pressure) and Theta perturbation (instead of temperature). +# diff --git a/WPS/ungrib/Variable_Tables/Vtable.ARWp.UPP b/WPS/ungrib/Variable_Tables/Vtable.ARWp.UPP new file mode 100644 index 00000000..8713ae01 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.ARWp.UPP @@ -0,0 +1,42 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | + 51 | 100 | * | | SPECHUMD | kg kg-1 | | 0 | 1 | 1 | 100 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | + 153 | 100 | * | | QC | kg kg-1 | Cloud water mixing ratio | 0 | 1 | 22 | 105 | + 170 | 100 | * | | QR | kg kg-1 | Rain water mixing ratio | 0 | 1 | 24 | 105 | + 58 | 100 | * | | QI | kg kg-1 | Ice mixing ratio | 0 | 1 | 23 | 105 | + 171 | 100 | * | | QS | kg kg-1 | Snow water mixing ratio | 0 | 1 | 25 | 105 | + 179 | 100 | * | | QG | kg kg-1 | Graupel mixing ratio | 0 | 1 | 32 | 105 | + | 100 | * | | QV | kg kg-1 | QV | 0 | 1 | 2 | 105 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + 52 | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | 1 | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | + 144 | 1 | 0 | | SOILM000 | kg m-3 | Soil Moist 0 cm below ground | 2 | 0 | 192 | 1 | + 144 | 111 | 5 | | SOILM005 | kg m-3 | Soil Moist 5 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 20 | | SOILM020 | kg m-3 | Soil Moist 20 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 40 | | SOILM040 | kg m-3 | Soil Moist 40 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 160 | | SOILM160 | kg m-3 | Soil Moist 160 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 300 | | SOILM300 | kg m-3 | Soil Moist 300 cm below ground | 2 | 0 | 192 | 106 | + 85 | 1 | 0 | | SOILT000 | K | Soil Temp 0 cm below ground | 2 | 0 | 2 | 1 | + 85 | 111 | 5 | | SOILT005 | K | Soil Temp 5 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 20 | | SOILT020 | K | Soil Temp 20 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 40 | | SOILT040 | K | Soil Temp 40 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 160 | | SOILT160 | K | Soil Temp 160 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 300 | | SOILT300 | K | Soil Temp 300 cm below ground | 2 | 0 | 2 | 106 | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | 0 | 0 | 0 | 104 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + +# Vtable for WRF-ARW output that has been processed by UPP and is on pressure levels and in Grib format +# +# Note that ARW output written directly to Grib format cannot be used by ungrib. WPS cannot process +# ARW output fields such as MU (instead of pressure) and Theta perturbation (instead of temperature). +# diff --git a/WPS/ungrib/Variable_Tables/Vtable.AVN0P5WRF b/WPS/ungrib/Variable_Tables/Vtable.AVN0P5WRF new file mode 100644 index 00000000..8f398bb0 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.AVN0P5WRF @@ -0,0 +1,21 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 11 | 100 | * | | TT | K | Temperature | + 33 | 100 | * | | UU | m s-1 | U | + 34 | 100 | * | | VV | m s-1 | V | + 52 | 100 | * | | RH | | Relative Humidity | + 7 | 100 | * | | HGT | m | Height | + 11 | 105 | 2 | | TT | K | Temperature | At 2 m + 52 | 105 | 2 | | RH | % | Relative Humidity | At 2 m + 33 | 105 | 10 | | UU | m s-1 | U | At 10 m + 34 | 105 | 10 | | VV | m s-1 | V | At 10 m + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | + 81 | 1 | 0 | | AVNLSEA | | Land/Sea flag | + 11 | 1 | 0 | | SKINTEMP | K | Skin Temperature over Land Points | + 91 | 1 | 0 | | SEAICE | fraction | Ice flag | +-----+------+------+------+----------+----------+------------------------------------------+ +# +# AFWA diff --git a/WPS/ungrib/Variable_Tables/Vtable.AWIP b/WPS/ungrib/Variable_Tables/Vtable.AWIP new file mode 100644 index 00000000..33148bf1 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.AWIP @@ -0,0 +1,30 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 11 | 100 | * | | TT | K | Temperature | + 33 | 100 | * | | UU | m s-1 | U | + 34 | 100 | * | | VV | m s-1 | V | + | 100 | * | | RH | % | Relative Humidity | + 51 | 100 | * | | SPECHUMD | kg kg-1 | | + 7 | 100 | * | | HGT | m | Height | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | + 130 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | + 65 | 1 | 0 | | SNOW | kg m-2 | Water Equivalent Snow Depth | + 85 | 112 | 0 | 10 | ST000010 | K | T of 0-10 cm ground layer | + 85 | 112 | 10 | 40 | ST010040 | K | T of 10-40 cm ground layer | + 85 | 112 | 40 | 100 | ST040100 | K | T of 40-100 cm ground layer | + 85 | 112 | 100 | 200 | ST100200 | K | T of 100-200 cm ground layer | + 144 | 112 | 0 | 10 | SM000010 | fraction | Soil Moisture of 0-10 cm ground layer | + 144 | 112 | 10 | 40 | SM010040 | fraction | Soil Moisture of 10-40 cm ground layer | + 144 | 112 | 40 | 100 | SM040100 | fraction | Soil Moisture of 40-100 cm ground layer | + 144 | 112 | 100 | 200 | SM100200 | fraction | Soil Moisture of 100-200 cm ground layer | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | + 11 | 1 | 0 | | SKINTEMP | K | Skin Temperature | + 11 | 105 | 2 | | TT | K | Temperature | + | 105 | 2 | | RH | % | Relative Humidity | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | | + 33 | 105 | 10 | | UU | m s-1 | U | + 34 | 105 | 10 | | VV | m s-1 | V | + 91 | 1 | 0 | | SEAICE | 0/1 Flag | Ice flag | + 81 | 1 | 0 | | LANDSEA | 0/1 Flag | Land/Sea flag | +-----+------+------+------+----------+----------+------------------------------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.CFSR2_web b/WPS/ungrib/Variable_Tables/Vtable.CFSR2_web new file mode 100644 index 00000000..6938e53b --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.CFSR2_web @@ -0,0 +1,29 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | + 52 | 100 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | 1 | 103 | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | | 0 | 1 | 0 | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 144 | 112 | 0 | 10 | SM000010 | fraction| Soil Moist 0-10 cm below grn layer (Up) | 2 | 0 | 192 | 106 | + 144 | 112 | 10 | 40 | SM010040 | fraction| Soil Moist 10-40 cm below grn layer | 2 | 0 | 192 | 106 | + 144 | 112 | 40 | 100 | SM040100 | fraction| Soil Moist 40-100 cm below grn layer | 2 | 0 | 192 | 106 | + 144 | 112 | 100 | 200 | SM100200 | fraction| Soil Moist 100-200 cm below gr layer | 2 | 0 | 192 | 106 | + 11 | 112 | 0 | 10 | ST000010 | K | T 0-10 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 10 | 40 | ST010040 | K | T 10-40 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 40 | 100 | ST040100 | K | T 40-100 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 100 | 200 | ST100200 | K | T 100-200 cm below ground layer (Bottom)| 0 | 0 | 0 | 106 | + 91 | 1 | 0 | | SEAICE | proprtn | Ice flag | 10 | 2 | 0 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | 0 | 0 | 0 | 1 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.CFSR_mean b/WPS/ungrib/Variable_Tables/Vtable.CFSR_mean new file mode 100644 index 00000000..26cd5583 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.CFSR_mean @@ -0,0 +1,37 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2|GB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level|PDT| +-----+------+------+------+----------+---------+-----------------------------------------+---------------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | 8 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | 8 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | 8 | + 52 | 100 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | 8 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | 8 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | 8 | + 52 | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | 1 | 103 | 8 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | 8 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | 8 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | 8 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | 8 | + 144 | 112 | 0 | 10 | SM000010 | fraction| Soil Moist 0-10 cm below grn layer (Up) | 2 | 0 | 192 | 106 | 8 | + 144 | 112 | 10 | 40 | SM010040 | fraction| Soil Moist 10-40 cm below grn layer | 2 | 0 | 192 | 106 | 8 | + 144 | 112 | 40 | 100 | SM040100 | fraction| Soil Moist 40-100 cm below grn layer | 2 | 0 | 192 | 106 | 8 | + 144 | 112 | 100 | 200 | SM100200 | fraction| Soil Moist 100-200 cm below gr layer | 2 | 0 | 192 | 106 | 8 | + 144 | 112 | 10 | 200 | SM010200 | fraction| Soil Moist 10-200 cm below gr layer | 2 | 0 | 192 | 106 | 8 | + 11 | 112 | 0 | 10 | ST000010 | K | T 0-10 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | 8 | + 11 | 112 | 10 | 40 | ST010040 | K | T 10-40 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | 8 | + 11 | 112 | 40 | 100 | ST040100 | K | T 40-100 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | 8 | + 11 | 112 | 100 | 200 | ST100200 | K | T 100-200 cm below ground layer (Bottom)| 0 | 0 | 0 | 106 | 8 | + 11 | 112 | 10 | 200 | ST010200 | K | T 10-200 cm below ground layer (Bottom) | 0 | 0 | 0 | 106 | 8 | + 91 | 1 | 0 | | SEAICE | proprtn | Ice flag | 10 | 2 | 0 | 1 | 8 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | 8 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | 8 | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | 0 | 0 | 0 | 1 | 8 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | 8 | + | 1 | 0 | | SNOWH | m | Physical Snow Depth | 0 | 1 | | 1 | 8 | +-----+------+------+------+----------+---------+-----------------------------------------+---------------------------+ +# +# +# +# Read monthly mean CFSR data from nomads. Note the 5th grib2 column indicating PDT8. +# +# e.g. ftp://nomads.ncdc.noaa.gov/CFSR/HP_monthly_means/CCYYMM/pgbh06.gdas.ccyymm.grb2 diff --git a/WPS/ungrib/Variable_Tables/Vtable.CFSR_press_pgbh06 b/WPS/ungrib/Variable_Tables/Vtable.CFSR_press_pgbh06 new file mode 100644 index 00000000..f93f735e --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.CFSR_press_pgbh06 @@ -0,0 +1,10 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | + 52 | 100 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.CFSR_sfc_flxf06 b/WPS/ungrib/Variable_Tables/Vtable.CFSR_sfc_flxf06 new file mode 100644 index 00000000..53b9e026 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.CFSR_sfc_flxf06 @@ -0,0 +1,23 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | 1 | 103 | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | | 0 | 1 | 0 | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 144 | 112 | 0 | 10 | SM000010 | fraction| Soil Moist 0-10 cm below grn layer (Up) | 2 | 0 | 192 | 106 | + 144 | 112 | 10 | 40 | SM010040 | fraction| Soil Moist 10-40 cm below grn layer | 2 | 0 | 192 | 106 | + 144 | 112 | 40 | 100 | SM040100 | fraction| Soil Moist 40-100 cm below grn layer | 2 | 0 | 192 | 106 | + 144 | 112 | 100 | 200 | SM100200 | fraction| Soil Moist 100-200 cm below gr layer | 2 | 0 | 192 | 106 | + 11 | 112 | 0 | 10 | ST000010 | K | T 0-10 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 10 | 40 | ST010040 | K | T 10-40 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 40 | 100 | ST040100 | K | T 40-100 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 100 | 200 | ST100200 | K | T 100-200 cm below ground layer (Bottom)| 0 | 0 | 0 | 106 | + 91 | 1 | 0 | | SEAICE | proprtn | Ice flag | 10 | 2 | 0 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | 0 | 0 | 0 | 1 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.ECMWF b/WPS/ungrib/Variable_Tables/Vtable.ECMWF new file mode 100644 index 00000000..1a54514f --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.ECMWF @@ -0,0 +1,42 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 129 | 100 | * | | GEOPT | m2 s-2 | | + | 100 | * | | HGT | m | Height | + 130 | 100 | * | | TT | K | Temperature | + 131 | 100 | * | | UU | m s-1 | U | + 132 | 100 | * | | VV | m s-1 | V | + 157 | 100 | * | | RH | % | Relative Humidity | + 165 | 1 | 0 | | UU | m s-1 | U At 10 m | + 166 | 1 | 0 | | VV | m s-1 | V At 10 m | + 167 | 1 | 0 | | TT | K | Temperature At 2 m | + 168 | 1 | 0 | | DEWPT | K | | + | 1 | 0 | | RH | % | Relative Humidity At 2 m | + 172 | 1 | 0 | | LANDSEA | 0/1 Flag | Land/Sea flag | + 129 | 1 | 0 | | SOILGEO | m2 s-2 | | + | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | + 134 | 1 | 0 | | PSFC | Pa | Surface Pressure | + 151 | 1 | 0 | | PMSL | Pa | Sea-level Pressure | + 235 | 1 | 0 | | SKINTEMP | K | Sea-Surface Temperature | + 31 | 1 | 0 | | SEAICE | 0/1 Flag | Sea-Ice-Flag | + 34 | 1 | 0 | | SST | K | Sea-Surface Temperature | + 141 | 1 | 0 | | SNOW_EC | m | | + | 1 | 0 | | SNOW | kg m-2 |Water Equivalent of Accumulated Snow Depth| + 139 | 112 | 0 | 7 | ST000007 | K | T of 0-7 cm ground layer | + 170 | 112 | 7 | 28 | ST007028 | K | T of 7-28 cm ground layer | + 183 | 112 | 28 | 100 | ST028100 | K | T of 28-100 cm ground layer | + 236 | 112 | 100 | 255 | ST100289 | K | T of 100-289 cm ground layer | + 39 | 112 | 0 | 7 | SM000007 | fraction | Soil moisture of 0-7 cm ground layer | + 40 | 112 | 7 | 28 | SM007028 | fraction | Soil moisture of 7-28 cm ground layer | + 41 | 112 | 28 | 100 | SM028100 | fraction | Soil moisture of 28-100 cm ground layer | + 42 | 112 | 100 | 255 | SM100289 | fraction | Soil moisture of 100-289 cm ground layer | +-----+------+------+------+----------+----------+------------------------------------------+ +# +# Grib codes are from Table 128 +# http://old.ecmwf.int/publications/manuals/d/gribapi/param/filter=grib1/order=paramId/order_type=asc/p=1/table=128/ +# +# snow depth is converted to the proper units in rrpr.F +# +# Tested on NCAR/RDA ds113.0 dataset. http://rda.ucar.edu/datasets/ds113.0/ +# Note that for ds113.0 there is one surface data file per day and 4 pressure-level files per day. + diff --git a/WPS/ungrib/Variable_Tables/Vtable.ECMWF_sigma b/WPS/ungrib/Variable_Tables/Vtable.ECMWF_sigma new file mode 100644 index 00000000..dff56bb5 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.ECMWF_sigma @@ -0,0 +1,41 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 130 | 109 | * | | TT | K | Temperature | + 131 | 109 | * | | UU | m s-1 | U | + 132 | 109 | * | | VV | m s-1 | V | + 133 | 109 | * | | SPECHUMD | kg kg-1 | Specific humidity | + 152 | 109 | * | | LOGSFP | Pa | Log surface pressure | + 129 | 1 | 0 | | SOILGEO | m | | + | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | + 165 | 1 | 0 | | UU | m s-1 | U | At 10 m + 166 | 1 | 0 | | VV | m s-1 | V | At 10 m + 167 | 1 | 0 | | TT | K | Temperature | At 2 m + 168 | 1 | 0 | | DEWPT | K | | At 2 m + | 1 | 0 | | RH | % | Relative Humidity at 2 m | At 2 m + 172 | 1 | 0 | | LANDSEA | 0/1 Flag | Land/Sea flag | + 134 | 1 | 0 | | PSFC | Pa | Surface Pressure | + 134 | 109 | 1 | | PSFCH | Pa | | + 151 | 1 | 0 | | PMSL | Pa | Sea-level Pressure | + 235 | 1 | 0 | | SKINTEMP | K | Sea-Surface Temperature | + 31 | 1 | 0 | | SEAICE | 0/1 Flag | Sea-Ice-Flag | + 34 | 1 | 0 | | SST | K | Sea-Surface Temperature | + 141 | 1 | 0 | | SNOW_EC | m | | + | 1 | 0 | | SNOW | kg m-2 |Water Equivalent of Accumulated Snow Depth| + 139 | 112 | 0 | 7 | ST000007 | K | T of 0-7 cm ground layer | + 170 | 112 | 7 | 28 | ST007028 | K | T of 7-28 cm ground layer | + 183 | 112 | 28 | 100 | ST028100 | K | T of 28-100 cm ground layer | + 236 | 112 | 100 | 255 | ST100289 | K | T of 100-289 cm ground layer | + 39 | 112 | 0 | 7 | SM000007 | fraction | Soil moisture of 0-7 cm ground layer | + 40 | 112 | 7 | 28 | SM007028 | fraction | Soil moisture of 7-28 cm ground layer | + 41 | 112 | 28 | 100 | SM028100 | fraction | Soil moisture of 28-100 cm ground layer | + 42 | 112 | 100 | 255 | SM100289 | fraction | Soil moisture of 100-289 cm ground layer | +-----+------+------+------+----------+----------+------------------------------------------+ +# +# In ECMWF hybrid-level files surface pressure can either be at the surface or +# hybrid level 1. +# +# Grib codes are from Table 128 +# http://www.ecmwf.int/products/data/technical/GRIB_tables/table_128.html +# +# snow depth is converted to the proper units in rrpr.F diff --git a/WPS/ungrib/Variable_Tables/Vtable.ERA-interim.ml b/WPS/ungrib/Variable_Tables/Vtable.ERA-interim.ml new file mode 100644 index 00000000..ad9077e5 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.ERA-interim.ml @@ -0,0 +1,42 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 130 | 109 | * | | TT | K | Temperature | + 131 | 109 | * | | UU | m s-1 | U | + 132 | 109 | * | | VV | m s-1 | V | + 133 | 109 | * | | SPECHUMD | kg kg-1 | Specific humidity | + 165 | 1 | 0 | | UU | m s-1 | U | At 10 m + 166 | 1 | 0 | | VV | m s-1 | V | At 10 m + 167 | 1 | 0 | | TT | K | Temperature | At 2 m + 168 | 1 | 0 | | DEWPT | K | | At 2 m + | 1 | 0 | | RH | % | Relative Humidity at 2 m | At 2 m + 172 | 1 | 0 | | LANDSEA | 0/1 Flag | Land/Sea flag | + 129 | 1 | 0 | | SOILGEO | m2 s-2 | | + | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | + 134 | 1 | 0 | | PSFC | Pa | Surface Pressure | + 151 | 1 | 0 | | PMSL | Pa | Sea-level Pressure | + 235 | 1 | 0 | | SKINTEMP | K | Sea-Surface Temperature | + 31 | 1 | 0 | | SEAICE | fraction | Sea-Ice-Fraction | + 34 | 1 | 0 | | SST | K | Sea-Surface Temperature | + 33 | 1 | 0 | | SNOW_DEN | kg m-3 | | + 141 | 1 | 0 | | SNOW_EC | m | | + | 1 | 0 | | SNOW | kg m-2 |Water Equivalent of Accumulated Snow Depth| + | 1 | 0 | | SNOWH | m | Physical Snow Depth | + 139 | 112 | 0 | 7 | ST000007 | K | T of 0-7 cm ground layer | + 170 | 112 | 7 | 28 | ST007028 | K | T of 7-28 cm ground layer | + 183 | 112 | 28 | 100 | ST028100 | K | T of 28-100 cm ground layer | + 236 | 112 | 100 | 255 | ST100289 | K | T of 100-289 cm ground layer | + 39 | 112 | 0 | 7 | SM000007 | m3 m-3 | Soil moisture of 0-7 cm ground layer | + 40 | 112 | 7 | 28 | SM007028 | m3 m-3 | Soil moisture of 7-28 cm ground layer | + 41 | 112 | 28 | 100 | SM028100 | m3 m-3 | Soil moisture of 28-100 cm ground layer | + 42 | 112 | 100 | 255 | SM100289 | m3 m-3 | Soil moisture of 100-289 cm ground layer | +-----+------+------+------+----------+----------+------------------------------------------+ +# +# For use with ERA-interim model-level output. +# +# Grib codes are from Table 128 +# http://www.ecmwf.int/services/archive/d/parameters/order=grib_parameter/table=128/ +# +# snow depth is converted to the proper units in rrpr.F +# +# For ERA-interim data at NCAR, use the ml (sc and uv) and sfc sc files. diff --git a/WPS/ungrib/Variable_Tables/Vtable.ERA-interim.pl b/WPS/ungrib/Variable_Tables/Vtable.ERA-interim.pl new file mode 100644 index 00000000..58cdd17a --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.ERA-interim.pl @@ -0,0 +1,45 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 129 | 100 | * | | GEOPT | m2 s-2 | | + | 100 | * | | HGT | m | Height | + 130 | 100 | * | | TT | K | Temperature | + 131 | 100 | * | | UU | m s-1 | U | + 132 | 100 | * | | VV | m s-1 | V | + 157 | 100 | * | | RH | % | Relative Humidity | + 165 | 1 | 0 | | UU | m s-1 | U | At 10 m + 166 | 1 | 0 | | VV | m s-1 | V | At 10 m + 167 | 1 | 0 | | TT | K | Temperature | At 2 m + 168 | 1 | 0 | | DEWPT | K | | At 2 m + | 1 | 0 | | RH | % | Relative Humidity | At 2 m + 172 | 1 | 0 | | LANDSEA | 0/1 Flag | Land/Sea flag | + 129 | 1 | 0 | | SOILGEO | m2 s-2 | | + | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | + 134 | 1 | 0 | | PSFC | Pa | Surface Pressure | + 151 | 1 | 0 | | PMSL | Pa | Sea-level Pressure | + 235 | 1 | 0 | | SKINTEMP | K | Sea-Surface Temperature | + 31 | 1 | 0 | | SEAICE | fraction | Sea-Ice Fraction | + 34 | 1 | 0 | | SST | K | Sea-Surface Temperature | + 33 | 1 | 0 | | SNOW_DEN | kg m-3 | | + 141 | 1 | 0 | | SNOW_EC | m | | + | 1 | 0 | | SNOW | kg m-2 |Water Equivalent of Accumulated Snow Depth| + | 1 | 0 | | SNOWH | m | Physical Snow Depth | + 139 | 112 | 0 | 7 | ST000007 | K | T of 0-7 cm ground layer | + 170 | 112 | 7 | 28 | ST007028 | K | T of 7-28 cm ground layer | + 183 | 112 | 28 | 100 | ST028100 | K | T of 28-100 cm ground layer | + 236 | 112 | 100 | 255 | ST100289 | K | T of 100-289 cm ground layer | + 39 | 112 | 0 | 7 | SM000007 | m3 m-3 | Soil moisture of 0-7 cm ground layer | + 40 | 112 | 7 | 28 | SM007028 | m3 m-3 | Soil moisture of 7-28 cm ground layer | + 41 | 112 | 28 | 100 | SM028100 | m3 m-3 | Soil moisture of 28-100 cm ground layer | + 42 | 112 | 100 | 255 | SM100289 | m3 m-3 | Soil moisture of 100-289 cm ground layer | +-----+------+------+------+----------+----------+------------------------------------------+ +# +# For use with ERA-interim pressure-level output. +# +# Grib codes are from Table 128 +# http://www.ecmwf.int/services/archive/d/parameters/order=grib_parameter/table=128/ +# +# snow depth is converted to the proper units in rrpr.F +# +# For ERA-interim data at NCAR, use the pl (sc and uv) and sfc sc files. + diff --git a/WPS/ungrib/Variable_Tables/Vtable.GFDL b/WPS/ungrib/Variable_Tables/Vtable.GFDL new file mode 100644 index 00000000..f25f11e7 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.GFDL @@ -0,0 +1,19 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid | +Param| Type |Level1|Level2| Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 11 | 100 | * | | TT | K | Temperature | + 33 | 100 | * | | UU | m s-1 | U | + 34 | 100 | * | | VV | m s-1 | V | + 52 | 100 | * | | RH | | Relative Humidity | + 7 | 100 | * | | HGT | m | Height | + 11 | 105 | 2 | | TT | % | Temperature | At 2 m + 52 | 105 | 2 | | RH | % | Relative Humidity | At 2 m + 33 | 105 | 35 | | UU | m s-1 | U | At 10 m + 34 | 105 | 35 | | VV | m s-1 | V | At 10 m + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | + 81 | 1 | 0 | | LANDSEA | | Land/Sea flag | + 8 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | + 11 | 111 | 50 | | SOILT050 | K | Temperature at 50 cm below | +-----+------+------+------+----------+----------+------------------------------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.GFS b/WPS/ungrib/Variable_Tables/Vtable.GFS new file mode 100644 index 00000000..6c44e737 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.GFS @@ -0,0 +1,70 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | + 52 | 100 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + 52 | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | 1 | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | + 144 | 112 | 0 | 10 | SM000010 | fraction| Soil Moist 0-10 cm below grn layer (Up) | 2 | 0 | 192 | 106 | + 144 | 112 | 10 | 40 | SM010040 | fraction| Soil Moist 10-40 cm below grn layer | 2 | 0 | 192 | 106 | + 144 | 112 | 40 | 100 | SM040100 | fraction| Soil Moist 40-100 cm below grn layer | 2 | 0 | 192 | 106 | + 144 | 112 | 100 | 200 | SM100200 | fraction| Soil Moist 100-200 cm below gr layer | 2 | 0 | 192 | 106 | + 144 | 112 | 10 | 200 | SM010200 | fraction| Soil Moist 10-200 cm below gr layer | 2 | 0 | 192 | 106 | + 11 | 112 | 0 | 10 | ST000010 | K | T 0-10 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 10 | 40 | ST010040 | K | T 10-40 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 40 | 100 | ST040100 | K | T 40-100 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 100 | 200 | ST100200 | K | T 100-200 cm below ground layer (Bottom)| 0 | 0 | 0 | 106 | + 85 | 112 | 0 | 10 | ST000010 | K | T 0-10 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | + 85 | 112 | 10 | 40 | ST010040 | K | T 10-40 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | + 85 | 112 | 40 | 100 | ST040100 | K | T 40-100 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | + 85 | 112 | 100 | 200 | ST100200 | K | T 100-200 cm below ground layer (Bottom)| 2 | 0 | 2 | 106 | + 11 | 112 | 10 | 200 | ST010200 | K | T 10-200 cm below ground layer (Bottom) | 0 | 0 | 0 | 106 | + 91 | 1 | 0 | | SEAICE | proprtn | Ice flag | 10 | 2 | 0 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | + 81 | 1 | 0 | | LANDN | proprtn | | 2 | 0 | 218 | 1 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature | 0 | 0 | 0 | 1 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | + | 1 | 0 | | SNOWH | m | Physical Snow Depth | 0 | 1 | | 1 | + 33 | 6 | 0 | | UMAXW | m s-1 | U at max wind | 0 | 2 | 2 | 6 | + 34 | 6 | 0 | | VMAXW | m s-1 | V at max wind | 0 | 2 | 3 | 6 | + 2 | 6 | 0 | | PMAXW | Pa | Pressure of max wind level | 0 | 3 | 0 | 6 | + | 6 | 0 | | PMAXWNN | Pa | PMAXW, used for nearest neighbor interp | 0 | 3 | 0 | 6 | + 2 | 6 | 0 | | TMAXW | K | Temperature at max wind level | 0 | 0 | 0 | 6 | + 7 | 6 | 0 | | HGTMAXW | m | Height of max wind level | 0 | 3 | 5 | 6 | + 33 | 7 | 0 | | UTROP | m s-1 | U at tropopause | 0 | 2 | 2 | 7 | + 34 | 7 | 0 | | VTROP | m s-1 | V at tropopause | 0 | 2 | 3 | 7 | + 2 | 7 | 0 | | PTROP | Pa | Pressure of tropopause | 0 | 3 | 0 | 7 | + | 7 | 0 | | PTROPNN | Pa | PTROP, used for nearest neighbor interp | 0 | 3 | 0 | 7 | + 2 | 7 | 0 | | TTROP | K | Temperature at tropopause | 0 | 0 | 0 | 7 | + 7 | 7 | 0 | | HGTTROP | m | Height of tropopause | 0 | 3 | 5 | 7 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ +# +# Vtable for GFS pressure-level data from the ncep server. +# This version includes fields from the Tropopause and Max Wind levels used by WRF V3.6.1 and later. +# NCEP has used multiple definitions of the soil temperature in their output and the Vtable attempts +# to account for these possibilities. (Definition changed 14 Jan 2015). +# +# ftp://ftpprd.ncep.noaa.gov/pub/data/nccf/com/gfs/prod/gfs.ccyymmddhh/ (note hh at end) +# +# approx. grid hours domain dx notes +# file size no. +# +# gfs.t12z.pgrb2.0p25 220000 Kb 193 3-h to 240-h global 0.25 deg (26 p-levels plus sfc and trop, 1000 to 10 mb). +# gfs.t12z.pgrb2.0p50 68000 Kb 4 3-h to 240-h global 0.5 deg (26 p-levels plus sfc and trop, 1000 to 10 mb). +# +# Prior to 12z 14 January 2015: +# +# gfs.t12z.pgrb2f00 56000 Kb 4 3-h to 192-h global 0.5 deg (26 p-levels plus sfc and trop, 1000 to 10 mb). +# gfs.t12z.pgrbf00.grib2 18000 Kb 3 3-h to 384-h global 1.0 deg (26 p-levels plus sfc and trop, 1000 to 10 mb). +# +# +# As of mid-2017 the GFS provides two land mask fields in the pressure-level output. WPS uses LANDN if available +# and renames it LANDSEA. diff --git a/WPS/ungrib/Variable_Tables/Vtable.GFSENS b/WPS/ungrib/Variable_Tables/Vtable.GFSENS new file mode 100644 index 00000000..bc312c5b --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.GFSENS @@ -0,0 +1,47 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2|GB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level|PDT| +-----+------+------+------+----------+---------+-----------------------------------------+---------------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | 1 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | 1 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | 1 | + 52 | 100 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | 1 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | 1 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | 1 | + 52 | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | 1 | 103 | 1 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | 1 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | 1 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | 1 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | 1 | + 144 | 112 | 0 | 10 | SM000010 | fraction| Soil Moist 0-10 cm below grn layer (Up) | 2 | 0 | 192 | 106 | 1 | + 144 | 112 | 10 | 40 | SM010040 | fraction| Soil Moist 10-40 cm below grn layer | 2 | 0 | 192 | 106 | 1 | + 144 | 112 | 40 | 100 | SM040100 | fraction| Soil Moist 40-100 cm below grn layer | 2 | 0 | 192 | 106 | 1 | + 144 | 112 | 100 | 200 | SM100200 | fraction| Soil Moist 100-200 cm below gr layer | 2 | 0 | 192 | 106 | 1 | + 144 | 112 | 10 | 200 | SM010200 | fraction| Soil Moist 10-200 cm below gr layer | 2 | 0 | 192 | 106 | 1 | + 11 | 112 | 0 | 10 | ST000010 | K | T 0-10 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | 1 | + 11 | 112 | 10 | 40 | ST010040 | K | T 10-40 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | 1 | + 11 | 112 | 40 | 100 | ST040100 | K | T 40-100 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | 1 | + 11 | 112 | 100 | 200 | ST100200 | K | T 100-200 cm below ground layer (Bottom)| 0 | 0 | 0 | 106 | 1 | + 11 | 112 | 10 | 200 | ST010200 | K | T 10-200 cm below ground layer (Bottom) | 0 | 0 | 0 | 106 | 1 | + 85 | 112 | 0 | 10 | ST000010 | K | T 0-10 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | 1 | + 85 | 112 | 10 | 40 | ST010040 | K | T 10-40 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | 1 | + 85 | 112 | 40 | 100 | ST040100 | K | T 40-100 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | 1 | + 85 | 112 | 100 | 200 | ST100200 | K | T 100-200 cm below ground layer (Bottom)| 2 | 0 | 2 | 106 | 1 | + 91 | 1 | 0 | | SEAICE | proprtn | Ice flag | 10 | 2 | 0 | 1 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | 1 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | 0 | 0 | 0 | 1 | 1 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+---------------------------+ +# +# +# GFS Ensemble (Product Definition Template 1) +# the files also contain some PDT 11 fields. +# +# ftp://ftpprd.ncep.noaa.gov/pub/data/nccf/com/gens/prod/gefs.ccyymmdd +# +# approx. grid hours domain dx notes +# file size no. +# +# gep01.txxz.pgrb2fhh 15500 Kb 3 0-h to 384-h global 1 deg 20 ensemble members +# gep01 - gep20 +# NCEP updated the soil temperature fields on 2 December 2015, matching the changes made in January to the operational GFS. diff --git a/WPS/ungrib/Variable_Tables/Vtable.GODAS b/WPS/ungrib/Variable_Tables/Vtable.GODAS new file mode 100644 index 00000000..d3630476 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.GODAS @@ -0,0 +1,15 @@ +GRIB | Level| Level| Level| METGRID | METGRID | METGRID | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 195 | 237 | 0 | 0 | H1ML | m | bottom ocn mixed layer depth | + 195 | 238 | 0 | 0 | H0ML | m | bottom ocn isothermal layer depth | + 13 | 160 | * | | pot | K | potential temperature | + 13 | 160 | 5 | | pot1 | K | potential temperature | + 13 | 160 | 15 | | pot2 | K | potential temperature | + 13 | 160 | 25 | | pot3 | K | potential temperature | + 13 | 160 | 35 | | pot4 | K | potential temperature | + 13 | 160 | 45 | | pot5 | K | potential temperature | + 13 | 160 | 55 | | pot6 | K | potential temperature | +-----+------+------+------+----------+----------+------------------------------------------+ +# +# NCEP's Global Ocean data assimilation system diff --git a/WPS/ungrib/Variable_Tables/Vtable.GSM b/WPS/ungrib/Variable_Tables/Vtable.GSM new file mode 100644 index 00000000..d79a473c --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.GSM @@ -0,0 +1,33 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid | +Param| Type |Level1|Level2| Name | Units | Description | +-----+------+------+------+----------+---------+------------------------------------------+ + 11 | 100 | * | | TT | K | Temperature | + 33 | 100 | * | | UU | m s-1 | U | + 34 | 100 | * | | VV | m s-1 | V | + 52 | 100 | * | | RH | % | Relative Humidity | + 7 | 100 | * | | HGT | m | Height | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | + 144 | 112 | 0 | 10 | SM000010 | fraction| Soil Moisture of 0-10 cm sub_soil layer | + 144 | 112 | 10 | 40 | SM010040 | fraction| Soil Moisture of 10-40 cm sub_soil layer | + 144 | 112 | 40 | 100 | SM040100 | fraction| Soil Moisture of 40-100 cm sub_soil layer| + 144 | 112 | 100 | 200 | SM100200 | fraction| Soil Moisture of 100-200 cm sub_soil lyr | + 144 | 112 | 10 | 200 | SM010200 | fraction| Soil Moisture of 10-200 cm sub_soil layer| + 11 | 112 | 0 | 10 | ST000010 | K | T of 0-10 cm sub_soil layer | + 11 | 112 | 10 | 40 | ST010040 | K | T of 10-40 cm sub_soil layer | + 11 | 112 | 40 | 100 | ST040100 | K | T of 40-100 cm sub_soil layer | + 11 | 112 | 100 | 200 | ST100200 | K | T of 100-200 cm sub_soil layer | + 11 | 112 | 10 | 200 | ST010200 | K | T of 10-200 cm sub_soil layer | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | + | 105 | 2 | | RH | % | Relative Humidity at 2 m | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | + 91 | 1 | 0 | | SEAICE | proprtn | Ice flag | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land,0=sea) | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | + 225 | 1 | 0 | | VEGCAT | Tab4.212| Dominant land use category | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | +-----+------+------+------+----------+---------+------------------------------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.JMAGSM b/WPS/ungrib/Variable_Tables/Vtable.JMAGSM new file mode 100644 index 00000000..f0a76bbd --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.JMAGSM @@ -0,0 +1,18 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | + 52 | 100 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + 52 | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | 1 | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ +# +# +# Japanese Meteorological Agency Global Spectral Model diff --git a/WPS/ungrib/Variable_Tables/Vtable.NAM b/WPS/ungrib/Variable_Tables/Vtable.NAM new file mode 100644 index 00000000..761a1fcb --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.NAM @@ -0,0 +1,50 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | + 52 | 100 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + 52 | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | 1 | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 130 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 192 | 101 | + 144 | 112 | 0 | 10 | SM000010 | fraction| Soil Moist 0-10 cm below grn layer (Up) | 2 | 0 | 192 | 106 | + 144 | 112 | 10 | 40 | SM010040 | fraction| Soil Moist 10-40 cm below grn layer | 2 | 0 | 192 | 106 | + 144 | 112 | 40 | 100 | SM040100 | fraction| Soil Moist 40-100 cm below grn layer | 2 | 0 | 192 | 106 | + 144 | 112 | 100 | 200 | SM100200 | fraction| Soil Moist 100-200 cm below gr layer | 2 | 0 | 192 | 106 | + 85 | 112 | 0 | 10 | ST000010 | K | T 0-10 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | + 85 | 112 | 10 | 40 | ST010040 | K | T 10-40 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | + 85 | 112 | 40 | 100 | ST040100 | K | T 40-100 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | + 85 | 112 | 100 | 200 | ST100200 | K | T 100-200 cm below ground layer (Bottom)| 2 | 0 | 2 | 106 | + 91 | 1 | 0 | | SEAICE | proprtn | Ice flag | 10 | 2 | 0 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land,0=sea in NAM) | 2 | 0 | 0 | 1 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | 0 | 0 | 0 | 1 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | + 66 | 1 | 0 | | SNOWH | m | Snow Depth | 0 | 1 | 11 | 1 | + 223 | 1 | 0 | | CANWAT | kg m-2 | Plant Canopy Surface Water | 2 | 0 | 196 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ +# +# Vtable for NAM pressure-level data from the ncep server. +# +# ftp://ftpprd.ncep.noaa.gov/pub/data/nccf/com/nam/prod/nam.ccyymmdd/ +# +# approx. grid hours domain dx notes +# file size no. +# +# nam.txxz.awip12hh.tm00.grib2 15018 Kb 218 3-h to 84-h conus 12 sfc fields only +# nam.t12z.awphyshh.grb2.tm00 24000 Kb 218 1-h to 36-h conus 12 25-mb (39 levels plus sfc, 1000 to 50 mb) +# 3-h to 84-h +# nam.t12z.awip32hh.tm00.grib2 25000 Kb 221 3-h to 84-h conus 32 25-mb (39 levels plus sfc, 1000 to 50 mb) +# nam.t12z.awip3dhh.tm00.grib2 5500 Kb 212 3-h to 84-h conus 40 25-mb (39 levels plus sfc, 1000 to 50 mb) +# nam.t12z.awp211hh.tm00.grib2 470 Kb 211 6-h to 84-h conus 80 50-mb (19 levels plus sfc, 1000 to 100 mb) +# nam.t12z.grbgrdhh.tm00.grib2 5400 KB 104 3-h to 84-h n amer 90 25-mb (39 levels plus sfc, 1000 to 50 mb) +# nam.t12z.bgrdsfhh.tm00.grib2 40000 Kb nat 1-h to 36-h n amer 12 native b-grid +# nam.t12z.awipakhh.tm00.grib2 4400 Kb 216 3-h to 84-h alaska 45 +# nam.t12z.awp217hh.tm00.grib2 1470 Kb 217 3-h to 84-h alaska 22.5 +# nam.t12z.awiphihh.tm00.grib2 4800 Kb 243 3-h to 84-h hawaii 0.4 deg +# nam.t12z.afwahihh.grb2.tm00 15000 Kb 182 3-h to 84-h hawaii 0.1 deg 25-mb (39 levels plus sfc, 1000 to 50 mb) diff --git a/WPS/ungrib/Variable_Tables/Vtable.NARR b/WPS/ungrib/Variable_Tables/Vtable.NARR new file mode 100644 index 00000000..ca8ef82e --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.NARR @@ -0,0 +1,52 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 11 | 100 | * | | TT | K | Temperature | + 33 | 100 | * | | UU | m s-1 | U | + 34 | 100 | * | | VV | m s-1 | V (from .3D file) | + 51 | 100 | * | | SPECHUMD | kg kg-1 | | + 52 | 100 | * | | RH | % | Relative Humidity | + 7 | 100 | * | | HGT | m | Height | + 11 | 105 | 2 | | TT | K | Temperature (from .flx file) | + 52 | 105 | 2 | | RH | % | Relative Humidity (from .flx file) | + 33 | 105 | 10 | | UU | m s-1 | U (from .flx file) | + 34 | 105 | 10 | | VV | m s-1 | V (from .flx file) | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure (from .sfc file) | + 130 | 102 | 0 | | PMSL | Pa | Sea-level Pressure (from .flx file) | + 65 | 1 | 0 | | SNOW | kg m-2 | Water Equiv of Accum Snow Depth (.sfc) | + 11 | 1 | 0 | | SKINTEMP | K | Sea-Surface Temperature (from .sfc file) | + 223 | 1 | 0 | | CANWAT | kg m-2 | Plant Canopy Surface Water (.sfc file) | + 85 | 112 | 0 | 10 | ST000010 | K | T of 0-10 cm ground layer (.flx file) | + 85 | 112 | 10 | 40 | ST010040 | K | T of 10-40 cm ground layer (.flx file) | + 85 | 112 | 40 |100 | ST040100 | K | T of 40-100 cm ground layer (.flx file) | + 85 | 112 | 100 |200 | ST100200 | K | T of 100-200 cm ground layer (.flx file) | + 144 | 112 | 0 | 10 | SM000010 | fraction | Soil Moisture of 0-10 cm gnd layer (.flx)| + 144 | 112 | 10 | 40 | SM010040 | fraction | Soil Moisture of 10-40 cm ground layer | + 144 | 112 | 40 |100 | SM040100 | fraction | Soil Moisture of 40-100 cm ground layer | + 144 | 112 |100 |200 | SM100200 | fraction | Soil Moisture of 100-200 cm ground layer | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (from .fixed file)| + 7 | 1 | 0 | | SOILHGT | m | Terrain from source analysis | +-----+------+------+------+----------+----------+------------------------------------------+ +# +# +# North American Regional Reanalysis, 32 km (Grid 221), 29 p-levels (1000 - 100 hPa) plus sfc +# +# There is a mismatch between the landmask and the soil moisture fields along the +# western shore of Hudson Bay in the NARR output. To account for this problem, the +# following line should be added to the SM entries in METGRID.TBL +# name= SM000010, SM010040, SM040100, SM100200 +# +# missing_value=-1.e30 +# +# +# http://www.emc.ncep.noaa.gov/mmb/rreanl/ +# http://www.cdc.noaa.gov/cdc/data.narr.html +# +# The last 4 entries in the Vtable (LANDSEA, SOILHGT, SOILCAT, and VEGCAT) can be +# obtained from the fixed files at http://wwwt.emc.ncep.noaa.gov/mmb/rreanl/index.html +# (or from the NCAR archive), then 1) Run ungrib on the .fixed file and an initial time +# of 1979-11-08_00. 2) rename the output file (NARR.CONSTANTS is a good choice; +# i.e. mv FILE:1979-11-08_00 NARR.CONSTANTS) 3) Run ungrib on the .flx, .3D, and .sfc files +# (or your NCDC grib files) 4) Run metgrid with constants_name = NARR.CONSTANTS in the namelist +# +# Note that U and V in NARR output are earth relative diff --git a/WPS/ungrib/Variable_Tables/Vtable.NCEP2 b/WPS/ungrib/Variable_Tables/Vtable.NCEP2 new file mode 100644 index 00000000..3d28707e --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.NCEP2 @@ -0,0 +1,38 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 11 | 100 | * | | TT | K | Temperature | + 33 | 100 | * | | UU | m s-1 | U | + 34 | 100 | * | | VV | m s-1 | V (from pgb file) | + 52 | 100 | * | | RH | % | Relative Humidity | + 7 | 100 | * | | HGT | m | Height | + 11 | 105 | 2 | | TT | K | Temperature (from flx file) | + 52 | 105 | 2 | | RH | % | Relative Humidity (from flx file) | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | | + 33 | 105 | 10 | | UU | m s-1 | U (from flx file) | + 34 | 105 | 10 | | VV | m s-1 | V (from flx file) | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure (from flx file) | + 1 | 102 | 0 | | PMSL | Pa | Sea-level Pressure (from pgb file) | + 65 | 1 | 0 | | SNOW | kg m-2 | Water Equiv of Accum Snow Depth (flx) | + | 1 | 0 | | SNOWH | m | Physical Snow Depth | + 11 | 1 | 0 | | SKINTEMP | K | Sea-Surface Temperature (from flx file) | + 11 | 112 | 0 | 10 | ST000010 | K | T of 0-10 cm ground layer (flx file) | + 11 | 112 | 10 | 200 | ST010200 | K | T of 10-200 cm ground layer (flx file) | + 144 | 112 | 0 | 10 | SM000010 | fraction | Soil Moisture of 0-10 cm gnd layer (flx) | + 144 | 112 | 10 | 200 | SM010200 | fraction | Soil Moisture of 10-200 cm ground layer | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (flx file) | + 7 | 1 | 0 | | SOILHGT | m | Terrain from source analysis (from pgb) | +-----+------+------+------+----------+----------+------------------------------------------+ +# +# +# +# NCEP/DOE Reanalysis (Reanalysis-2) 2.5 degree, 17-levels (1000 to 10 hPa) plus sfc +# also called R2, CDAS2, NCEP2 +# +# Sea-level pressure is incorrectly coded in the grib file (it should be grib code 2 +# not grib code 1). +# +# http://nomad3.ncep.noaa.gov/ncep_data/ +# http://www.cpc.ncep.noaa.gov/products/wesley/reanalysis2/index.html +# http://dss.ucar.edu/datasets/ds091.0/ +# mss:/DSS/DS091.0/ diff --git a/WPS/ungrib/Variable_Tables/Vtable.NNRP b/WPS/ungrib/Variable_Tables/Vtable.NNRP new file mode 100644 index 00000000..54fe9914 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.NNRP @@ -0,0 +1,26 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 11 | 100 | * | | TT | K | Temperature | + 33 | 100 | * | | UU | m s-1 | U | + 34 | 100 | * | | VV | m s-1 | V | + 52 | 100 | * | | RH | | Relative Humidity | + 7 | 100 | * | | HGT | m | Height | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | + 11 | 105 | 2 | | TT | K | Temperature | At 2 m + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | | At 2 m + | 105 | 2 | | RH | | Relative Humidity | At 2 m + 33 | 105 | 10 | | UU | m s-1 | U | At 10 m + 34 | 105 | 10 | | VV | m s-1 | V | At 10 m + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | + 144 | 112 | 0 | 10 | SM000010 | | Soil Moisture of 0-10 cm ground layer | + 144 | 112 | 10 | 200 | SM010200 | | Soil Moisture of 10-200 cm ground layer | + 11 | 112 | 0 | 10 | ST000010 | K | T of 0-10 cm ground layer | + 11 | 112 | 10 | 200 | ST010200 | K | T of 10-200 cm ground layer | + 91 | 1 | 0 | | SEAICE | | Ice flag | + 81 | 1 | 0 | | LANDSEA | | Land/Sea flag | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | + 80 | 1 | 0 | | SST | K | Sea Surface Temperature | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | +-----+------+------+------+----------+----------+------------------------------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.NOGAPS b/WPS/ungrib/Variable_Tables/Vtable.NOGAPS new file mode 100644 index 00000000..fcbc6045 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.NOGAPS @@ -0,0 +1,17 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | + | 100 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | + 18 | 100 | * | | DEPR | K | | 0 | 1 | 1 | 100 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | 1 | 103 | + 18 | 1 | 0 | | DEPR | K | | 0 | 1 | 1 | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.NOGAPS_needs_GFS_soil b/WPS/ungrib/Variable_Tables/Vtable.NOGAPS_needs_GFS_soil new file mode 100644 index 00000000..53ca9c96 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.NOGAPS_needs_GFS_soil @@ -0,0 +1,19 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 144 | 112 | 0 | 10 | SM000010 | kg m-3 | Soil Moist 0-10 cm below grn layer (Up) | 2 | 0 | 192 | 106 | + 144 | 112 | 10 | 40 | SM010040 | kg m-3 | Soil Moist 10-40 cm below grn layer | 2 | 0 | 192 | 106 | + 144 | 112 | 40 | 100 | SM040100 | kg m-3 | Soil Moist 40-100 cm below grn layer | 2 | 0 | 192 | 106 | + 144 | 112 | 100 | 200 | SM100200 | kg m-3 | Soil Moist 100-200 cm below gr layer | 2 | 0 | 192 | 106 | + 144 | 112 | 10 | 200 | SM010200 | kg m-3 | Soil Moist 10-200 cm below gr layer | 2 | 0 | 192 | 106 | + 11 | 112 | 0 | 10 | ST000010 | K | T 0-10 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 10 | 40 | ST010040 | K | T 10-40 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 40 | 100 | ST040100 | K | T 40-100 cm below ground layer (Upper) | 0 | 0 | 0 | 106 | + 11 | 112 | 100 | 200 | ST100200 | K | T 100-200 cm below ground layer (Bottom)| 0 | 0 | 0 | 106 | + 11 | 112 | 10 | 200 | ST010200 | K | T 10-200 cm below ground layer (Bottom) | 0 | 0 | 0 | 106 | + 91 | 1 | 0 | | SEAICE | proprtn | Ice flag | 10 | 2 | 0 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | 0 | 0 | 0 | 1 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.NavySST b/WPS/ungrib/Variable_Tables/Vtable.NavySST new file mode 100644 index 00000000..c9505b5e --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.NavySST @@ -0,0 +1,7 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 80 | 160 | 0 | | SST | K | Sea surface temperature | +-----+------+------+------+----------+----------+------------------------------------------+ +# +# AFWA diff --git a/WPS/ungrib/Variable_Tables/Vtable.RAP.hybrid.ncep b/WPS/ungrib/Variable_Tables/Vtable.RAP.hybrid.ncep new file mode 100644 index 00000000..7bda88ae --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.RAP.hybrid.ncep @@ -0,0 +1,66 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+----------+-----------------------------------------+-----------------------+ + 7 | 109 | * | | HGT | m | Height | 0 | 3 | 5 | 105 | + 1 | 109 | * | | PRESSURE | Pa | Pressure | 0 | 3 | 0 | 105 | + 11 | 109 | * | | TT | K | Temperature | 0 | 0 | 0 | 105 | + 51 | 109 | * | | SPECHUMD | kg kg-1 | Specific Humidity | 0 | 1 | 0 | 105 | + 33 | 109 | * | | UU | m s-1 | U | 0 | 2 | 2 | 105 | + 34 | 109 | * | | VV | m s-1 | V | 0 | 2 | 3 | 105 | + 153 | 109 | * | | QC | kg kg-1 | Cloud water mixing ratio | 0 | 1 | 22 | 105 | + 170 | 109 | * | | QR | kg kg-1 | Rain water mixing ratio | 0 | 1 | 24 | 105 | + 58 | 109 | * | | QI | kg kg-1 | Ice mixing ratio | 0 | 6 | 0 | 105 | + 171 | 109 | * | | QS | kg kg-1 | Snow water mixing ratio | 0 | 1 | 25 | 105 | + 179 | 109 | * | | QG | kg kg-1 | Graupel mixing ratio | 0 | 1 | 32 | 105 | + 148 | 107 | * | | QNR | kg-1 | Rain number concentration | 0 | 3 | 195 | 105 | + 198 | 109 | * | | QNI | kg-1 | Ice number concentration | 0 | 1 | 207 | 105 | + | 109 | * | | RH | % | Relative Humidity | 0 | 1 | | 105 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | Specific Humidity at 2 m | 0 | 1 | 0 | 103 | + | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 129 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 198 | 101 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | + 66 | 1 | 0 | | SNOWH | m | Snow depth | 0 | 1 | 11 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Skin Temp ( = TSK ) | 0 | 0 | 0 | 1 | + 223 | 1 | 0 | | CANWAT | kg m-2 | Plant Canopy Surface Water | 2 | 0 | 196 | 1 | + 144 | 1 | 0 | | SOILM000 | fraction | Soil Moist 0 cm below ground | 2 | 0 | 192 | 1 | + 144 | 111 | 5 | | SOILM005 | fraction | Soil Moist 5 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 20 | | SOILM020 | fraction | Soil Moist 20 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 40 | | SOILM040 | fraction | Soil Moist 40 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 160 | | SOILM160 | fraction | Soil Moist 160 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 300 | | SOILM300 | fraction | Soil Moist 300 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 1 | | SOILM001 | fraction | Soil Moist 1 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 4 | | SOILM004 | fraction | Soil Moist 4 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 10 | | SOILM010 | fraction | Soil Moist 10 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 30 | | SOILM030 | fraction | Soil Moist 30 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 60 | | SOILM060 | fraction | Soil Moist 60 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 100 | | SOILM100 | fraction | Soil Moist 100 cm below ground | 2 | 0 | 192 | 106 | + 85 | 1 | 0 | | SOILT000 | K | Soil Temp 0 cm below ground | 2 | 0 | 2 | 1 | + 85 | 111 | 5 | | SOILT005 | K | Soil Temp 5 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 20 | | SOILT020 | K | Soil Temp 20 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 40 | | SOILT040 | K | Soil Temp 40 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 160 | | SOILT160 | K | Soil Temp 160 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 300 | | SOILT300 | K | Soil Temp 300 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 1 | | SOILT001 | K | Soil Temp 1 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 4 | | SOILT004 | K | Soil Temp 4 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 10 | | SOILT010 | K | Soil Temp 10 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 30 | | SOILT030 | K | Soil Temp 30 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 60 | | SOILT060 | K | Soil Temp 60 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 100 | | SOILT100 | K | Soil Temp 100 cm below ground | 2 | 0 | 2 | 106 | + 91 | 1 | 0 | | SEAICE | | Ice flag | 10 | 2 | 0 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | +-----+------+------+------+----------+----------+-----------------------------------------+-----------------------+ +# +# Vtable for the Rapid refresh (RAP) hybrid-vertical coordinate grib2 files on the ncep server. +# ftp://ftpprd.ncep.noaa.gov/pub/data/nccf/com/rap/prod/rap.ccyymmdd/ +# +# rap.txxz.awp252bgrbfhh.grib2 20km conus 17901 Kb (approx. size) +# rap.txxz.awp130bgrbfhh.grib2 13km conus 34462 Kb +# +# As of 1 June 2016, +# hourly to 18-hours +# Level 1 is near the surface, level 50 is the top. diff --git a/WPS/ungrib/Variable_Tables/Vtable.RAP.pressure.ncep b/WPS/ungrib/Variable_Tables/Vtable.RAP.pressure.ncep new file mode 100644 index 00000000..8f39fed4 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.RAP.pressure.ncep @@ -0,0 +1,34 @@ +GRIB1| Level| From | To | metgrid | metgrid| metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | + 52 | 100 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + | 105 | 2 | | RH | % | Relative Humidity at 2 m (n/a in p file)| 0 | 1 | 1 | 103 | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | | 0 | 1 | 0 | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 129 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 198 | 101 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Temperature at ground sfc (from s file) | 0 | 0 | 0 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ +# +# Vtable for Rapid refresh (RAP) pressure-level data from the ncep server. +# +# Soil fields are in the hybrid-coordinate files. +# +# ftp://ftpprd.ncep.noaa.gov/pub/data/nccf/com/rap/prod/rap.ccyymmdd/ +# approx. size + +# rap.txxz.awp252pgrbfhh.grib2 20km conus (25-mb, 38-level 1000 to 100 mb plus sfc) 6858 Kb +# rap.txxz.awp130pgrbfhh.grib2 13km conus 12228 Kb +# rap.txxz.awip32fhh.grib2 32km N. Amer. 23188 Kb +# rap.txxz.awp200fhh.grib2 16km Puerto Rico 1600 Kb +# rap.txxz.awp242fhh.grib2 11km Alaska 44757 Kb +# +# hourly output to 18-h diff --git a/WPS/ungrib/Variable_Tables/Vtable.RAP.sigma.gsd b/WPS/ungrib/Variable_Tables/Vtable.RAP.sigma.gsd new file mode 100644 index 00000000..26dd19f6 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.RAP.sigma.gsd @@ -0,0 +1,58 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+----------+-----------------------------------------+-----------------------+ + 7 | 107 | * | | HGT | m | Height | 0 | 3 | 5 | 104 | + 1 | 107 | * | | PRESSURE | Pa | Pressure | 0 | 3 | 0 | 104 | + 11 | 107 | * | | TT | K | Temperature | 0 | 0 | 0 | 104 | + 51 | 107 | * | | SPECHUMD | kg kg-1 | Specific Humidity | 0 | 1 | 0 | 104 | + 33 | 107 | * | | UU | m s-1 | U | 0 | 2 | 2 | 104 | + 34 | 107 | * | | VV | m s-1 | V | 0 | 2 | 3 | 104 | + 153 | 107 | * | | QC | kg kg-1 | Cloud water mixing ratio | 0 | 1 | 22 | 104 | + 170 | 107 | * | | QR | kg kg-1 | Rain water mixing ratio | 0 | 1 | 24 | 104 | + 58 | 107 | * | | QI | kg kg-1 | Ice mixing ratio | 0 | 6 | 0 | 104 | + 171 | 107 | * | | QS | kg kg-1 | Snow water mixing ratio | 0 | 1 | 25 | 104 | + 179 | 107 | * | | QG | kg kg-1 | Graupel mixing ratio | 0 | 1 | 32 | 104 | + 148 | 107 | * | | QNR | kg-1 | Rain number concentration | 0 | 3 | 195 | 104 | + 198 | 107 | * | | QNI | kg-1 | Ice number concentration | 0 | 1 | 207 | 104 | + | 107 | * | | RH | % | Relative Humidity | 0 | 1 | | 104 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | Specific Humidity at 2 m | 0 | 1 | 0 | 103 | + | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | + 66 | 1 | 0 | | SNOWH | m | Snow depth | 0 | 1 | 11 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Skin Temp ( = TSK ) | 0 | 0 | 0 | 1 | + 223 | 1 | 0 | | CANWAT | kg m-2 | Plant Canopy Surface Water | 2 | 0 | 196 | 1 | + 144 | 1 | 0 | | SOILM000 | fraction | Soil Moist 0 cm below ground | 2 | 0 | 192 | 1 | + 144 | 111 | 5 | | SOILM005 | fraction | Soil Moist 5 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 20 | | SOILM020 | fraction | Soil Moist 20 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 40 | | SOILM040 | fraction | Soil Moist 40 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 160 | | SOILM160 | fraction | Soil Moist 160 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 300 | | SOILM300 | fraction | Soil Moist 300 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 1 | | SOILM001 | fraction | Soil Moist 1 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 4 | | SOILM004 | fraction | Soil Moist 4 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 10 | | SOILM010 | fraction | Soil Moist 10 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 30 | | SOILM030 | fraction | Soil Moist 30 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 60 | | SOILM060 | fraction | Soil Moist 60 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 100 | | SOILM100 | fraction | Soil Moist 100 cm below ground | 2 | 0 | 192 | 106 | + 85 | 1 | 0 | | SOILT000 | K | Soil Temp 0 cm below ground | 2 | 0 | 2 | 1 | + 85 | 111 | 5 | | SOILT005 | K | Soil Temp 5 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 20 | | SOILT020 | K | Soil Temp 20 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 40 | | SOILT040 | K | Soil Temp 40 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 160 | | SOILT160 | K | Soil Temp 160 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 300 | | SOILT300 | K | Soil Temp 300 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 1 | | SOILT001 | K | Soil Temp 1 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 4 | | SOILT004 | K | Soil Temp 4 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 10 | | SOILT010 | K | Soil Temp 10 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 30 | | SOILT030 | K | Soil Temp 30 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 60 | | SOILT060 | K | Soil Temp 60 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 100 | | SOILT100 | K | Soil Temp 100 cm below ground | 2 | 0 | 2 | 106 | + 91 | 1 | 0 | | SEAICE | | Ice flag | 10 | 2 | 0 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | +-----+------+------+------+----------+----------+-----------------------------------------+-----------------------+ +# +# Vtable for GSD's Rapid refresh grib2 files. Supplied by GSD. +# diff --git a/WPS/ungrib/Variable_Tables/Vtable.RUCb b/WPS/ungrib/Variable_Tables/Vtable.RUCb new file mode 100644 index 00000000..43380e67 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.RUCb @@ -0,0 +1,56 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+----------+-----------------------------------------+-----------------------+ + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 7 | 109 | * | | HGT | m | Height | 0 | 3 | 5 | 105 | + 1 | 109 | * | | PRESSURE | Pa | Pressure | 0 | 3 | 0 | 105 | + 189 | 109 | * | | VPTMP | K | | 0 | 0 | 15 | 105 | + 53 | 109 | * | | QV | kg kg-1 | QV | 0 | 1 | 2 | 105 | + 33 | 109 | * | | UU | m s-1 | U | 0 | 2 | 2 | 105 | + 34 | 109 | * | | VV | m s-1 | V | 0 | 2 | 3 | 105 | + 153 | 109 | * | | QC | kg kg-1 | Cloud water mixing ratio | 0 | 1 | 22 | 105 | + 170 | 109 | * | | QR | kg kg-1 | Rain water mixing ratio | 0 | 1 | 24 | 105 | + 178 | 109 | * | | QI | kg kg-1 | Ice mixing ratio | 0 | 1 | 23 | 105 | + 171 | 109 | * | | QS | kg kg-1 | Snow water mixing ratio | 0 | 1 | 25 | 105 | + 179 | 109 | * | | QG | kg kg-1 | Graupel mixing ratio | 0 | 1 | 32 | 105 | + 198 | 109 | * | | QNI | m-3 | Number concentration for ice particles | 0 | 1 | 207 | 105 | + | 109 | * | | RH | % | Relative Humidity | 0 | 1 | | 105 | + | 109 | * | | TT | K | Temperature | 0 | 0 | | 105 | + 129 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 198 | 101 | + | 1 | 0 | | SNOW | kg m-2 | Water Equivalent Snow Depth | 0 | 1 | | 1 | + 65 | 1 | 0 | | SNOWRUC | m | | 0 | 1 | 13 | 1 | + 66 | 1 | 0 | | SNOWH | m | Snow Depth | 0 | 1 | 11 | 1 | + 89 | 111 | 5 | | RHOSN | kg m-3 | Snow density | 0 | 3 | 10 | 106 | + 11 | 105 | 2 | | TT | K | Temperature | 0 | 0 | 0 | 103 | + | 105 | 2 | | RH | % | Relative Humidity | 0 | 1 | 1 | 103 | + 53 | 105 | 2 | | QV | kg kg-1 | Water vapor mixing ratio at 2 m | 0 | 1 | 2 | 103 | + 33 | 105 | 10 | | UU | m s-1 | U | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V | 0 | 2 | 3 | 103 | + 144 | 1 | 0 | | SM000ruc | fraction | | 2 | 0 | 192 | 1 | + 144 | 111 | 5 | | SM005ruc | fraction | | 2 | 0 | 192 | 106 | + 144 | 111 | 20 | | SM020ruc | fraction | | 2 | 0 | 192 | 106 | + 144 | 111 | 40 | | SM040ruc | fraction | | 2 | 0 | 192 | 106 | + 144 | 111 | 160 | | SM160ruc | fraction | | 2 | 0 | 192 | 106 | + 144 | 111 | 300 | | SM300ruc | fraction | | 2 | 0 | 192 | 106 | + | 1 | 0 | | SOILM000 | fraction | Soil Moist 0 cm below ground | 2 | 0 | 192 | 1 | + | 111 | 5 | | SOILM005 | fraction | Soil Moist 5 cm below ground | 2 | 0 | 192 | 106 | + | 111 | 20 | | SOILM020 | fraction | Soil Moist 20 cm below ground | 2 | 0 | 192 | 106 | + | 111 | 40 | | SOILM040 | fraction | Soil Moist 40 cm below ground | 2 | 0 | 192 | 106 | + | 111 | 160 | | SOILM160 | fraction | Soil Moist 160 cm below ground | 2 | 0 | 192 | 106 | + | 111 | 300 | | SOILM300 | fraction | Soil Moist 300 cm below ground | 2 | 0 | 192 | 106 | + 85 | 1 | 0 | | SOILT000 | K | Soil Temp 0 cm below ground | 2 | 0 | 2 | 1 | + 85 | 111 | 5 | | SOILT005 | K | Soil Temp 5 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 20 | | SOILT020 | K | Soil Temp 20 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 40 | | SOILT040 | K | Soil Temp 40 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 160 | | SOILT160 | K | Soil Temp 160 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 300 | | SOILT300 | K | Soil Temp 300 cm below ground | 2 | 0 | 2 | 106 | + 223 | 1 | 0 | | CANWAT | kg m-2 | Plant Canopy Surface Water | 2 | 0 | 196 | 1 | + 239 | 111 | 5 | | SKINTEMP | K | Snow Temp 5 cm below sfc ( = TSK ) | 0 | 1 | 208 | 106 | + 239 | 111 | 10 | | TSNOW | K | Snow Temp 10 cm below sfc | 0 | 1 | 208 | 106 | + 53 | 1 | 0 | | QVG | kg kg-1 | Water vapor mixing ratio at the surface | 0 | 1 | 2 | 1 | + 91 | 1 | 0 | | SEAICE | | Ice flag | 10 | 2 | 0 | 1 | + 223 | 1 | 0 | | CANWAT | kg m-2 | Plant Canopy Surface Water | 2 | 0 | 196 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | + 224 | 1 | 0 | | SOILCAT | Tab4.213 | Dominant soil type cat. | 2 | 3 | 0 | 1 | + 225 | 1 | 0 | | VEGCAT | Tab4.212 | Dominant land use cat. | 2 | 0 | 198 | 1 | +-----+------+------+------+----------+----------+-----------------------------------------+-----------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.RUCp b/WPS/ungrib/Variable_Tables/Vtable.RUCp new file mode 100644 index 00000000..2c6e4438 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.RUCp @@ -0,0 +1,22 @@ +GRIB1| Level| From | To | metgrid | metgrid| metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | + 52 | 100 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + | 105 | 2 | | RH | % | Relative Humidity at 2 m (n/a in p file)| 0 | 1 | 1 | 103 | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | | 0 | 1 | 0 | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 129 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 198 | 101 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Temperature at ground sfc (from s file) | 0 | 0 | 0 | 1 | + 223 | 1 | 0 | | CANWAT | kg m-2 | Plant Canopy Surface Water | 2 | 0 | 196 | 1 | + 224 | 1 | 0 | | SOILCAT | Tab4.213| Dominant soil type category | 2 | 3 | 0 | 1 | + 225 | 1 | 0 | | VEGCAT | Tab4.212| Dominant land use category | 2 | 0 | 198 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.SREF b/WPS/ungrib/Variable_Tables/Vtable.SREF new file mode 100644 index 00000000..9cecfd39 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.SREF @@ -0,0 +1,41 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2|GB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level|PDT| +-----+------+------+------+----------+---------+-----------------------------------------+---------------------------+ + 11 | 100 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | 1 | + 33 | 100 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | 1 | + 34 | 100 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | 1 | + 52 | 100 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | 1 | + 7 | 100 | * | | HGT | m | Height | 0 | 3 | 5 | 100 | 1 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | 1 | + 52 | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | 1 | 103 | 1 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | 1 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | 1 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | 1 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | 1 | + 144 | 112 | 0 | 10 | SM000010 | fraction| Soil Moist 0-10 cm below grn layer (Up) | 2 | 0 | 192 | 106 | 1 | + 144 | 112 | 10 | 40 | SM010040 | fraction| Soil Moist 10-40 cm below grn layer | 2 | 0 | 192 | 106 | 1 | + 144 | 112 | 40 | 100 | SM040100 | fraction| Soil Moist 40-100 cm below grn layer | 2 | 0 | 192 | 106 | 1 | + 144 | 112 | 100 | 200 | SM100200 | fraction| Soil Moist 100-200 cm below gr layer | 2 | 0 | 192 | 106 | 1 | + 85 | 112 | 0 | 10 | ST000010 | K | T 0-10 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | 1 | + 85 | 112 | 10 | 40 | ST010040 | K | T 10-40 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | 1 | + 85 | 112 | 40 | 100 | ST040100 | K | T 40-100 cm below ground layer (Upper) | 2 | 0 | 2 | 106 | 1 | + 85 | 112 | 100 | 200 | ST100200 | K | T 100-200 cm below ground layer (Bottom)| 2 | 0 | 2 | 106 | 1 | + 91 | 1 | 0 | | SEAICE | proprtn | Ice flag | 10 | 2 | 0 | 1 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | 1 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | 0 | 0 | 0 | 1 | 1 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | 1 | + 223 | 1 | 0 | | CANWAT | kg m-2 | Plant Canopy Surface Water | 2 | 0 | 196 | 1 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+---------------------------+ +# +# Vtable for SREF pressure-level data from the NCEP server. +# +# ftp://ftpprd.ncep.noaa.gov/pub/data/nccf/com/sref/prod/sref.ccyymmdd/hh/pgrb/ +# +# For use with SREF files produced after 15z 21 October 2015 +# +# approx. grid hours domain dx notes +# file size no. +# +# sref_arw.t15z.pgrb132.ctl.f00.grib2 72000 Kb 132 87 conus 16 +# sref_arw.t15z.pgrb212.ctl.f00.grib2 4800 Kb 212 87 conus 40 diff --git a/WPS/ungrib/Variable_Tables/Vtable.SST b/WPS/ungrib/Variable_Tables/Vtable.SST new file mode 100644 index 00000000..5d59a4cf --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.SST @@ -0,0 +1,5 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 1 | 0 | | SST | K | Sea Surface Temperature | 0 | 0 | 0 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.TCRP b/WPS/ungrib/Variable_Tables/Vtable.TCRP new file mode 100644 index 00000000..cfee02e0 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.TCRP @@ -0,0 +1,44 @@ +GRIB | Level| Level| Level| metgrid | metgrid | metgrid | +Code | Code | 1 | 2 | Name | Units | Description | +-----+------+------+------+----------+----------+------------------------------------------+ + 11 | 100 | * | | TT | K | Temperature | + 33 | 100 | * | | UU | m s-1 | U | + 34 | 100 | * | | VV | m s-1 | V (from .prs file) | + 51 | 100 | * | | SPECHUMD | kg kg-1 | | + 52 | 100 | * | | RH | % | Relative Humidity | + 7 | 100 | * | | HGT | m | Height | + 11 | 105 | 2 | | TT | K | Temperature (from .flx file) | + 52 | 105 | 2 | | RH | % | Relative Humidity (from .flx file) | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | | + 33 | 105 | 10 | | UU | m s-1 | U (from .flx file) | + 34 | 105 | 10 | | VV | m s-1 | V (from .flx file) | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure (from .flx file) | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure (from .prs file) | + 65 | 1 | 0 | | SNOW | kg m-2 | Water Equiv of Accum Snow Depth (.flx) | + 11 | 1 | 0 | | SKINTEMP | K | Sea-Surface Temperature (from .flx file) | + 11 | 112 | 0 | 10 | ST000010 | K | T of 0-10 cm ground layer (.flx file) | + 11 | 112 | 10 | 40 | ST010040 | K | T of 10-40 cm ground layer (.flx file) | + 11 | 112 | 40 |100 | ST040100 | K | T of 40-100 cm ground layer (.flx file) | + 11 | 112 | 100 |200 | ST100200 | K | T of 100-200 cm ground layer (.flx file) | + 144 | 112 | 0 | 10 | SM000010 | fraction | Soil Moisture of 0-10 cm gnd layer (.flx)| + 144 | 112 | 10 | 40 | SM010040 | fraction | Soil Moisture of 10-40 cm ground layer | + 144 | 112 | 40 |100 | SM040100 | fraction | Soil Moisture of 40-100 cm ground layer | + 144 | 112 |100 |200 | SM100200 | fraction | Soil Moisture of 100-200 cm ground layer | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (from .flx file) | + 7 | 1 | 0 | | SOILHGT | m | Terrain from source analysis | + 91 | 1 | 0 | | SEAICE | proprtn | Ice flag | +-----+------+------+------+----------+----------+------------------------------------------+ +# +# +# Twentieth Century Global Reanalysis Version 2, 2 deg (Grid 255), 24 p-levels (1000 - 10 hPa) plus sfc +# +# +# http://rda.ucar.edu/datasets/ds131.1/ +# http://www.esrl.noaa.gov/psd/data/20thC_Rean/ +# +# Need to download 2 files, a 3d pressure file and a suface flux file. Note that as for most +# reanalysis data sets the soil variables are 6-hour forecasts. +# +# The Vtable has been tested on the NCAR TCRP files. Modifications may be required for other sources +# +# Note that soil temps are miscoded as '11' instead of '85' diff --git a/WPS/ungrib/Variable_Tables/Vtable.UKMO_ENDGame b/WPS/ungrib/Variable_Tables/Vtable.UKMO_ENDGame new file mode 100644 index 00000000..0e47dbdd --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.UKMO_ENDGame @@ -0,0 +1,33 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level|Templ| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------------+ + 33 | 118 | * | | UU | m s-1 | U | 0 | 2 | 2 | 118 | 1 | + 34 | 118 | * | | VV | m s-1 | V | 0 | 2 | 3 | 118 | 1 | + 11 | 118 | * | | TT | K | Temperature | 0 | 0 | 0 | 118 | 1 | + | 118 | * | | SPECHUMD | kg kg-1 | Specific Humidity | 0 | 1 | 0 | 118 | 1 | + | 118 | * | | SPECCLDL | kg kg-1 | Specific Cloud Liquid Water content | 0 | 1 |253 | 118 | 1 | + 53 | 118 | * | | SPECCLDF | kg kg-1 | Specific Cloud Frozen Water content | 0 | 6 |252 | 118 | 1 | + 1 | 118 | * | | THETA | K | | 0 | 0 | 2 | 118 | 1 | + | 118 | * | | PRESSURE | Pa | Pressure Exner | 0 | 3 | | 118 | 1 | + | 118 | * | | PRHO | Pa | Pressure Rho (u and v) | 0 | 3 | 0 | 118 | 1 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 60 | 1 | 1 | + | 1 | 0 | | SNOWH | m | Physical Snow Depth | 0 | 1 | | 1 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Skin temperature (can use for SST also) | 0 | 0 | 0 | 1 | 1 | + 91 | 1 | 0 | | SEAICE | Fraction| Sea ice coverage fraction | 10 | 2 | 0 | 1 | 1 | + 148 | 1 | 0 | | SOILHGT | m | Topography Elevation | 0 | 3 | 5 | 1 | 1 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | 1 | + 7 | 118 | * | | HGT | m | Height | 0 | 3 | 5 | 118 | 1 | + 2 | 101 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 0 | 101 | 1 | + 33 | 103 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | 1 | + 34 | 103 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | 1 | + 11 | 103 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | 1 | + 86 | 106 | 10 | | SM000010 | fraction| Soil Moist 0-10 cm below grn layer | 2 | 3 | 193 | 106 | 1 | + 86 | 106 | 35 | | SM010035 | fraction| Soil Moist 10-35 cm below grn layer | 2 | 3 | 193 | 106 | 1 | + 86 | 106 | 100 | | SM035100 | fraction| Soil Moist 35-100 cm below grn layer | 2 | 3 | 193 | 106 | 1 | + 86 | 106 | 300 | | SM100300 | fraction| Soil Moist 100-300 cm below gr layer | 2 | 3 | 193 | 106 | 1 | + 85 | 106 | 10 | | ST000010 | K | T 0-10 cm below ground layer | 2 | 3 | 192 | 106 | 1 | + 85 | 106 | 35 | | ST010035 | K | T 10-35 cm below ground layer | 2 | 3 | 192 | 106 | 1 | + 85 | 106 | 100 | | ST035100 | K | T 35-100 cm below ground layer | 2 | 3 | 192 | 106 | 1 | + 85 | 106 | 300 | | ST100300 | K | T 100-300 cm below ground layer | 2 | 3 | 192 | 106 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.UKMO_LANDSEA b/WPS/ungrib/Variable_Tables/Vtable.UKMO_LANDSEA new file mode 100644 index 00000000..50b815df --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.UKMO_LANDSEA @@ -0,0 +1,5 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 81 | 1 | 0 | | LANDSEA | Mask | Land/Sea flag (1=land, 0=sea) | 2 | 0 | 0 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.UKMO_no_heights b/WPS/ungrib/Variable_Tables/Vtable.UKMO_no_heights new file mode 100644 index 00000000..31519a9f --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.UKMO_no_heights @@ -0,0 +1,28 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ + 11 | 109 | * | | TT | K | Temperature | 0 | 0 | 0 | 100 | + 33 | 109 | * | | UU | m s-1 | U | 0 | 2 | 2 | 100 | + 34 | 109 | * | | VV | m s-1 | V | 0 | 2 | 3 | 100 | + 51 | 109 | * | | SPECHUMD | kg kg-1 | | 0 | 1 | 1 | 100 | + | 109 | * | | RH | % | Relative Humidity | 0 | 1 | 1 | 100 | + 1 | 109 | * | | PRESSURE | Pa | Pressure | 0 | 3 | 5 | 100 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + 17 | 105 | 2 | | DEWPT | K | | 0 | 1 | 1 | 103 | + | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | 1 | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 2 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 1 | 101 | + 11 | 1 | 0 | | SKINTEMP | K | Skin Temperature | 0 | 0 | 0 | 103 | + 86 | 106 | 10 | | SM000010 | fraction| Soil Moist 0-10 cm below grn layer | 2 | 3 | 193 | 106 | + 86 | 106 | 35 | | SM010035 | fraction| Soil Moist 10-35 cm below grn layer | 2 | 3 | 193 | 106 | + 86 | 106 | 100 | | SM035100 | fraction| Soil Moist 35-100 cm below grn layer | 2 | 3 | 193 | 106 | + 86 | 106 | 300 | | SM100300 | fraction| Soil Moist 100-300 cm below gr layer | 2 | 3 | 193 | 106 | + 85 | 106 | 10 | | ST000010 | K | T 0-10 cm below ground layer | 2 | 3 | 192 | 106 | + 85 | 106 | 35 | | ST010035 | K | T 10-35 cm below ground layer | 2 | 3 | 192 | 106 | + 85 | 106 | 100 | | ST035100 | K | T 35-100 cm below ground layer | 2 | 3 | 192 | 106 | + 85 | 106 | 300 | | ST100300 | K | T 100-300 cm below ground layer | 2 | 3 | 192 | 106 | + 148 | 1 | 0 | | SOILHGT | m | Topography Elevation | 2 | 0 | 0 | 1 | + 159 | 1 | 0 | | SEAICE | proprtn | Seaice fraction, 0=none, 1=covered | 2 | 0 | 0 | 1 | +-----+------+------+------+----------+---------+-----------------------------------------+-----------------------+ diff --git a/WPS/ungrib/Variable_Tables/Vtable.raphrrr b/WPS/ungrib/Variable_Tables/Vtable.raphrrr new file mode 100755 index 00000000..2c96fd49 --- /dev/null +++ b/WPS/ungrib/Variable_Tables/Vtable.raphrrr @@ -0,0 +1,52 @@ +GRIB1| Level| From | To | metgrid | metgrid | metgrid |GRIB2|GRIB2|GRIB2|GRIB2| +Param| Type |Level1|Level2| Name | Units | Description |Discp|Catgy|Param|Level| +-----+------+------+------+----------+----------+-----------------------------------------+-----------------------+ + 7 | 109 | * | | HGT | m | Height | 0 | 3 | 5 | 105 | + 1 | 109 | * | | PRESSURE | Pa | Pressure | 0 | 3 | 0 | 105 | + 11 | 109 | * | | TT | K | Temperature | 0 | 0 | 0 | 105 | + 51 | 109 | * | | SPECHUMD | kg kg-1 | Specific Humidity | 0 | 1 | 0 | 105 | + 33 | 109 | * | | UU | m s-1 | U | 0 | 2 | 2 | 105 | + 34 | 109 | * | | VV | m s-1 | V | 0 | 2 | 3 | 105 | + 153 | 109 | * | | QC | kg kg-1 | Cloud water mixing ratio | 0 | 1 | 22 | 105 | + 170 | 109 | * | | QR | kg kg-1 | Rain water mixing ratio | 0 | 1 | 24 | 105 | + 58 | 109 | * | | QI | kg kg-1 | Ice mixing ratio | 0 | 6 | 0 | 105 | + 171 | 109 | * | | QS | kg kg-1 | Snow water mixing ratio | 0 | 1 | 25 | 105 | + 179 | 109 | * | | QG | kg kg-1 | Graupel mixing ratio | 0 | 1 | 32 | 105 | + 153 | 109 | * | | QNR | kg-1 | Rain number concentration | 0 | 1 | 100 | 105 | + 255 | 109 | * | | QNC | kg-1 | Cloud number concentration | 0 | 6 | 28 | 105 | + 198 | 109 | * | | QNI | kg-1 | Ice number concentration | 0 | 6 | 29 | 105 | + 157 | 107 | * | | QNWFA | kg-1 | Water-fr. aerosol number concentration | 0 | 13 | 193 | 105 | + 156 | 107 | * | | QNIFA | kg-1 | Ice-fr. aerosol number concentration | 0 | 13 | 192 | 105 | + 11 | 105 | 2 | | TT | K | Temperature at 2 m | 0 | 0 | 0 | 103 | + 51 | 105 | 2 | | SPECHUMD | kg kg-1 | Specific Humidity at 2 m | 0 | 1 | 0 | 103 | + 52 | 105 | 2 | | RH | % | Relative Humidity at 2 m | 0 | 1 | | 103 | + 33 | 105 | 10 | | UU | m s-1 | U at 10 m | 0 | 2 | 2 | 103 | + 34 | 105 | 10 | | VV | m s-1 | V at 10 m | 0 | 2 | 3 | 103 | + 1 | 1 | 0 | | PSFC | Pa | Surface Pressure | 0 | 3 | 0 | 1 | + 129 | 102 | 0 | | PMSL | Pa | Sea-level Pressure | 0 | 3 | 198 | 101 | + 65 | 1 | 0 | | SNOW | kg m-2 | Water equivalent snow depth | 0 | 1 | 13 | 1 | + 66 | 1 | 0 | | SNOWH | m | Snow depth | 0 | 1 | 11 | 1 | + 11 | 1 | 0 | | SKINTEMP | K | Skin Temp ( = TSK ) | 0 | 0 | 0 | 1 | + 223 | 1 | 0 | | CANWAT | kg m-2 | Plant Canopy Surface Water | 2 | 0 | 196 | 1 | + 144 | 111 | 0 | | SOILM000 | fraction | Soil Moist 0 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 1 | | SOILM001 | fraction | Soil Moist 1 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 4 | | SOILM004 | fraction | Soil Moist 4 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 10 | | SOILM010 | fraction | Soil Moist 10 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 30 | | SOILM030 | fraction | Soil Moist 30 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 60 | | SOILM060 | fraction | Soil Moist 60 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 100 | | SOILM100 | fraction | Soil Moist 100 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 160 | | SOILM160 | fraction | Soil Moist 160 cm below ground | 2 | 0 | 192 | 106 | + 144 | 111 | 300 | | SOILM300 | fraction | Soil Moist 300 cm below ground | 2 | 0 | 192 | 106 | + 85 | 111 | 0 | | SOILT000 | K | Soil Temp 0 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 1 | | SOILT001 | K | Soil Temp 1 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 4 | | SOILT004 | K | Soil Temp 4 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 10 | | SOILT010 | K | Soil Temp 10 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 30 | | SOILT030 | K | Soil Temp 30 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 60 | | SOILT060 | K | Soil Temp 60 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 100 | | SOILT100 | K | Soil Temp 100 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 160 | | SOILT160 | K | Soil Temp 160 cm below ground | 2 | 0 | 2 | 106 | + 85 | 111 | 300 | | SOILT300 | K | Soil Temp 300 cm below ground | 2 | 0 | 2 | 106 | + 91 | 1 | 0 | | SEAICE | | Ice flag | 10 | 2 | 0 | 1 | + 81 | 1 | 0 | | LANDSEA | proprtn | Land/Sea flag (1=land, 0 or 2=sea) | 2 | 0 | 0 | 1 | + 7 | 1 | 0 | | SOILHGT | m | Terrain field of source analysis | 0 | 3 | 5 | 1 | +-----+------+------+------+----------+----------+-----------------------------------------+-----------------------+ diff --git a/WPS/ungrib/src/.gitignore b/WPS/ungrib/src/.gitignore new file mode 100644 index 00000000..4afd1076 --- /dev/null +++ b/WPS/ungrib/src/.gitignore @@ -0,0 +1,4 @@ +*.f90 +*.o +*.mod +lib*.a diff --git a/WPS/ungrib/src/Makefile b/WPS/ungrib/src/Makefile new file mode 100644 index 00000000..874ba656 --- /dev/null +++ b/WPS/ungrib/src/Makefile @@ -0,0 +1,102 @@ +include ../../configure.wps + +LIBTARGET = pgu +EXE = ungrib.exe \ + g1print.exe g2print.exe + +OBJS1 = misc_definitions_module.o debug_cio.o module_debug.o module_stringutil.o \ + table.o module_datarray.o gridinfo.o new_storage.o filelist.o \ + ungrib.o output.o rrpr.o \ + rd_grib1.o file_delete.o datint.o rd_grib2.o + +OBJS2 = build_hdate.o geth_newdate.o geth_idts.o swap.o table.o \ + parse_table.o gbytesys.o gribcode.o read_namelist.o cio.o + +all: lib$(LIBTARGET).a $(EXE) + +ungrib.exe: $(OBJS1) lib$(LIBTARGET).a + $(RM) $@ + if [ -z $(COMPILING_ON_CYGWIN_NT) ] ; then \ + $(FC) -o $@ $(LDFLAGS) $(OBJS1) \ + -L./ngl -lw3 -lg2_4 \ + $(COMPRESSION_LIBS) \ + -L. -l$(LIBTARGET) ; \ + else \ + $(FC) -o $@ $(LDFLAGS) $(OBJS1) \ + ./ngl/w3/libw3.a ./ngl/g2/libg2_4.a \ + $(COMPRESSION_LIBS) \ + lib$(LIBTARGET).a ; \ + fi + + +lib$(LIBTARGET).a: $(OBJS2) + $(RM) lib$(LIBTARGET).a + $(AR) lib$(LIBTARGET).a $(OBJS2) + $(RANLIB) lib$(LIBTARGET).a + +g1print.exe: g1print.o gribcode.o module_debug.o debug_cio.o lib$(LIBTARGET).a + $(FC) -o $(@) $(LDFLAGS) g1print.o gribcode.o module_debug.o debug_cio.o lib$(LIBTARGET).a + +g2print.exe: filelist.o gridinfo.o g2print.o + if [ -z $(COMPILING_ON_CYGWIN_NT) ] ; then \ + $(FC) -o $(@) $(LDFLAGS) g2print.o \ + filelist.o gridinfo.o \ + -L. -l$(LIBTARGET) \ + -L./ngl -lw3 -lg2_4 \ + $(COMPRESSION_LIBS) ; \ + else \ + $(FC) -o $(@) $(LDFLAGS) g2print.o \ + filelist.o gridinfo.o \ + lib$(LIBTARGET).a \ + ./ngl/w3/libw3.a ./ngl/g2/libg2_4.a \ + $(COMPRESSION_LIBS) ; \ + fi + +g2print.o: table.o gridinfo.o filelist.o module_datarray.o \ + ngl/g2/gribmod.o ngl/g2/params.o g2print.F + $(CPP) $(CPPFLAGS) $*.F > $*.f90 + $(FC) -c $(FFLAGS) $(FCSUFFIX) $*.f90 -I. -I./ngl/g2 +# $(RM) $*.f90 + +rd_grib2.o: ngl/g2/gribmod.o module_debug.o table.o gridinfo.o ngl/g2/params.o new_storage.o \ + rd_grib2.F + $(CPP) $(CPPFLAGS) $*.F > $*.f90 + $(FC) -c $(F77FLAGS) $(FCSUFFIX) $*.f90 -I. -I./ngl/g2 +# $(RM) $*.f90 + +datint.o: misc_definitions_module.o module_debug.o gridinfo.o new_storage.o datint.F + +module_debug.o: debug_cio.o module_debug.F + +misc_definitions_module.o: misc_definitions_module.F + +file_delete.o: misc_definitions_module.o file_delete.F + +new_storage.o: gridinfo.o new_storage.F + +output.o: misc_definitions_module.o module_debug.o table.o gridinfo.o module_stringutil.o new_storage.o filelist.o output.F + +parse_table.o: module_debug.o table.o parse_table.F + +rd_grib1.o: module_debug.o table.o gridinfo.o module_datarray.o rd_grib1.F + +gribcode.o: module_debug.o gribcode.F + +rrpr.o: misc_definitions_module.o module_debug.o filelist.o gridinfo.o module_stringutil.o table.o new_storage.o rrpr.F + +read_namelist.o: misc_definitions_module.o module_debug.o read_namelist.F + +.F.o: + $(CPP) $(CPPFLAGS) $(FDEFS) $< > $*.f90 + $(FC) -c $(FFLAGS) $*.f90 +# $(RM) $*.f90 + +.c.o: + $(RM) $@ + $(CC) $(CPPFLAGS) $(CFLAGS) -c $< + + +clean: + $(RM) *.o *.i *.f90 *.mod *.M lib$(LIBTARGET).a *exe + +superclean: clean diff --git a/WPS/ungrib/src/build_hdate.F b/WPS/ungrib/src/build_hdate.F new file mode 100644 index 00000000..33c202c2 --- /dev/null +++ b/WPS/ungrib/src/build_hdate.F @@ -0,0 +1,42 @@ + subroutine build_hdate(hdate, iyr, imo, idy, ihr, imi, isc) + +! PURPOSE: +! From the Year, Month, Day, Hour, Minute, and Second values, +! creates a 19-character string representing the date, in the +! format: "YYYY-MM-DD hh:mm:ss" + +! INPUT: + integer iyr ! year (e.g., 1997, 2001) + integer imo ! month (01 - 12) + integer idy ! day of the month (01 - 31) + integer ihr ! hour (00-23) + integer imi ! minute (00-59) + integer isc ! second (00-59) +! OUTPUT: + character*(*) hdate ! 'YYYY-MM-DD hh:mm:ss' + +! LOCAL: + integer i ! Loop counter. + integer hlen ! Length of hdate string + + hlen = len(hdate) + + if (hlen.eq.19) then + write(hdate,19) iyr, imo, idy, ihr, imi, isc + 19 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2,':',i2.2) + + elseif (hlen.eq.16) then + write(hdate,16) iyr, imo, idy, ihr, imi + 16 format(i4,'-',i2.2,'-',i2.2,'_',i2.2,':',i2.2) + + elseif (hlen.eq.13) then + write(hdate,13) iyr, imo, idy, ihr + 13 format(i4,'-',i2.2,'-',i2.2,'_',i2.2) + + elseif (hlen.eq.10) then + write(hdate,10) iyr, imo, idy + 10 format(i4,'-',i2.2,'-',i2.2) + endif + + return + end diff --git a/WPS/ungrib/src/cio.c b/WPS/ungrib/src/cio.c new file mode 100644 index 00000000..30eee8d6 --- /dev/null +++ b/WPS/ungrib/src/cio.c @@ -0,0 +1,265 @@ +/* FILE: cio.c */ +/* C functions to write bytes to UNIX files - called from FORTRAN */ +/* c_open + bn_read + bnwrit + c_close */ +/* bsrfil */ +/* 870417 */ + +#if defined(CRAY) + +#define c_open C_OPEN +#define c_close C_CLOSE +#define bn_read BN_READ +#define bn_seek BN_SEEK + +#endif + +/* length of the char string from the fortran file is 132, plus one for null terminator */ +#define FORT_FILE_LEN 133 + +#ifdef _UNDERSCORE + +#define c_open c_open_ +#define c_close c_close_ +#define bn_read bn_read_ +#define bn_seek bn_seek_ + +#endif + +#ifdef _DOUBLEUNDERSCORE + +#define c_open c_open__ +#define c_close c_close__ +#define bn_read bn_read__ +#define bn_seek bn_seek__ + +#endif + +#include +#include +#include +#include +#ifndef _WIN32 +# include +# include +# include +#endif + +/* ****************************************************************** */ + +c_open(unit, nunit, name, mode, err, oflag) + /* + * unit = Fortran unit number + * nunit = UNIX file descriptor associated with 'unit' + * name = UNIX file name + * mode = 0 : write only - file will be created if it doesn't exist, + - otherwise will be rewritten + = 1 : read only + = 2 : read/write + * err = 0 : no error opening file. + != 0 : Error opening file + * oflag = 0 : no notification if file opened OK (errors are printed) + = 1 : file name and unit number printed (and errors) + = -1 : no print at all (not even errors) + */ + int *unit; + int *nunit; + int *mode; + int *err; + int *oflag; + char name[FORT_FILE_LEN]; +{ + int fd, i; + char fname[FORT_FILE_LEN]; + extern int errno; /* I/O error return */ + + if (*oflag >= 1) + printf("Copen: File = %s\nFortran Unit = %d\n", name, *unit); + + /* strip trailing blanks and add null character to name */ + for (i = 0; name[i] != ' ' && name[i] != '\0' && i < FORT_FILE_LEN; ++i) + fname[i] = name[i]; + fname[i] = '\0'; + +/* if (*mode == 0) WRITE ONLY + printf ("UNIX File descriptor: %d\n", fd = open (fname, O_WRONLY)); + printf ("UNIX File descriptor: %d\n", fd = creat (fname, 0777)); + else if (*mode == 1) READ ONLY + printf ("UNIX File descriptor: %d\n", fd = open (fname, O_RDONLY)); + else READ/WRITE + printf ("UNIX File descriptor: %d\n", fd = open (fname, O_RDWR));*/ + + if (*mode == 0) /* WRITE ONLY */ + fd = creat(fname, 0777); + else if (*mode == 1) /* READ ONLY */ + fd = open(fname, O_RDONLY); + else /* READ/WRITE */ + fd = open(fname, O_RDWR); + if (*oflag >= 1) + printf("UNIX File descriptor: %d\n\n", fd); + + *err = 0; + if (fd == -1) { /* error opening file */ + if (*oflag >= 0){ + printf("Error opening %s Error status: %d\n", fname, errno); + perror("c_open.c"); + }; + *err = errno; + }; + + *nunit = fd; + return (0); +} + +/* ****************************************************************** */ +bn_seek(fd, bread, mode, iprint) + +/* Move the read/write file pointer + fd : Unix file descriptor. + bread : Number of bytes to move the pointer. + mode : How to move the pointer: + = 0 : move the pointer ahead BREAD bytes. + < 0 : move the pointer to location BREAD. + > 0 : move the pointer to the end + BREAD bytes. (?) + iprint : Flag to turn on (iprint = 1) or off (iprint = 0) print. + + Location 0 [bn_seek(fd,0,-1,0)] puts us just before the first byte, + so the next bn_read will get byte 1. +*/ + + int *fd, *bread, *mode, *iprint; + +{ + off_t i, offset; + int how_to_space; + + if (*mode == 0) + how_to_space = SEEK_CUR; + else if (*mode < 0) + how_to_space = SEEK_SET; + else + how_to_space = SEEK_END; + + offset = *bread; + i = lseek(*fd, offset, how_to_space); + if (*iprint != 0) + printf(" lseek return=%d, *mode=%d\n", i, *mode); + + return(0); +} + +/* ****************************************************************** */ + +bn_read(fd, buf, nbuf, bread, ios, idiag) + /* + * fd = UNIX file descriptor number (NOT a Fortran unit) + * buf = area into which to read + * nbuf = number of bytes to read from fd + * bread = number actually read + * ios = error number returned to Fortran: + 1 = End of File + 2 = Error in reading + * idiag : if non-zero, error and EOF messages will be printed + */ + + int *fd, *nbuf, buf[], *bread, *ios, *idiag; +{ + int bytesread; + +/* printf ("BNREAD Fd = %d Nbuf = %d\n", *fd, *nbuf); */ + bytesread = read(*fd, buf, *nbuf); +/* printf ("Bytes %d stat %d\n", bytesread, errno); */ + + if (bytesread == -1) { /* error reading file */ + if (*idiag != 0) + printf("Error reading C unit %d\n", *fd); + perror("bn_read.c"); + *ios = 2; + /* *ios = errno; */ + } else if (bytesread == 0) {/* end-of-file on input */ + if (*idiag != 0) + printf("End of file on C unit %d\n", *fd); + *ios = 1; + /* *ios = errno; */ + } else { /* read OK */ + + /* + * printf ("BNREAD - bytes read = %d Buf = %d %d %d\n", bytesread, + * buf[0], buf[1], buf[2]); + */ + *ios = 0; + }; + + *bread = bytesread; + return(0); +} + +/* ****************************************************************** */ + +bnwrit_(fd, buf, nbuf, bwritten, err, idiag) + int *fd, *nbuf, buf[], *bwritten, *err, *idiag; + + /* + * fd = UNIX file descriptor number (NOT a Fortran unit) buf = area from + * which to write nbuf = number of bytes to write to fd bwritten = number + * actually written err = UNIX error number returned to FORTRAN idiag : if + * non-zero, error and EOF messages will be printed + */ + +{ + int byteswritten; + + /* + * printf ("BNWRIT Fd = %d Nbuf = %d Buf = %d %d %d\n", fd, *nbuf, + * buf[0], buf[1], buf[2]); + */ + byteswritten = write(*fd, buf, *nbuf); + /* printf ("Bytes %d stat %d\n", byteswritten, errno); */ + + *err = 0; + if (byteswritten == -1) { /* error writing file */ + if (*idiag != 0) + printf("Error writing C unit %d\n", *fd); + perror("bnwrit.c"); + *err = errno; + }; + + *bwritten = byteswritten; + return(0); +} + +/* ****************************************************************** */ + +c_close(nunit, iprint, err) +/* +Close a C (UNIX?) file descriptor: + nunit : (INPUT) : The C (UNIX?) file descriptor to close. + iprint : (INPUT) : Print flag ( iprint == 0 : no print on successful close) + ( iprint != 0 : Some printout) + err : (OUTPUT) : Error flag ( err = 0 : Successful close) + ( err = 1 : Error on close) + */ + int *nunit, *iprint, *err; +{ + extern int errno; /* I/O error return */ + int istat; + + if ( *iprint != 0 ) + printf("\n *** CCLOSE : Closing file descriptor: NUNIT = %d \n", + *nunit); + + istat = close(*nunit); + if (istat == 0) { + if ( *iprint != 0 ) + printf(" *** CCLOSE successful: File descriptor: NUNIT = %d \n", + *nunit); + } + else + printf("CCLOSE error: %d : File descriptor NUNIT = %d \n", + istat, *nunit); + + *err = istat; + return(0); +} diff --git a/WPS/ungrib/src/datint.F b/WPS/ungrib/src/datint.F new file mode 100644 index 00000000..3a041059 --- /dev/null +++ b/WPS/ungrib/src/datint.F @@ -0,0 +1,308 @@ +subroutine datint(fuldates, nful, hstart, ntimes, interval, out_format, prefix) +! ! +!*****************************************************************************! +! ! +! interpolate missing data in time +! out_format: requested output format +! ! +!*****************************************************************************! + + use gridinfo + use storage_module + use module_debug + use misc_definitions_module + + implicit none + integer :: nful + integer :: interval + character(len=*), dimension(nful) :: fuldates + character(len=*) :: hstart + integer :: ntimes + + character(len=24) :: hdate = "0000-00-00_00:00:00.0000" + character(len=24) :: hdate_output, jdate + character(len=9) :: field + character(len=25) :: units + character(len=46) :: desc + character(LEN=3) :: out_format + character(LEN=MAX_FILENAME_LEN) :: prefix + real :: xfcst + + real :: level + real, allocatable, dimension(:,:) :: scr2d, bfr2d + integer :: iful, intervala, intervalb, ifv + real :: awt + integer :: itime + +! DATELEN: length of date strings to use for our output file names. + integer :: datelen + +! Decide the length of date strings to use for output file names. +! DATELEN is 13 for hours, 16 for minutes, and 19 for seconds. + if (mod(interval,3600) == 0) then + datelen = 13 + else if (mod(interval, 60) == 0) then + datelen = 16 + else + datelen = 19 + end if + + call mprintf(.true.,STDOUT,"Subroutine DATINT: Interpolating 3-d files to fill in any missing data...") + call mprintf(.true.,LOGFILE,"Subroutine DATINT: Interpolating 3-d files to fill in any missing data...") + + TIMELOOP : do itime = 1, ntimes + call geth_newdate(hdate(1:19), hstart(1:19), (itime-1)*interval) + call mprintf(.true.,STDOUT,"Looking for data at time %s",s1=hdate(1:datelen)) + call mprintf(.true.,LOGFILE,"Looking for data at time %s",s1=hdate(1:datelen)) + do iful = 1, nful + if (fuldates(iful).eq.hdate) then + call mprintf(.true.,STDOUT,"Found file: %s:%s", & + s1=trim(prefix),s2=hdate(1:datelen)) + call mprintf(.true.,LOGFILE,"Found file: %s:%s", & + s1=trim(prefix),s2=hdate(1:datelen)) + cycle TIMELOOP + else if ((fuldates(iful).lt.hdate) .and. & + (fuldates(iful+1).gt.hdate) )then + + call mprintf(.true.,STDOUT,"Found surrounding files: %s: %s and %s: %s", & + s1=trim(prefix),s2=fuldates(iful)(1:datelen), & + s3=trim(prefix),s4=fuldates(iful+1)(1:datelen)) + call mprintf(.true.,LOGFILE,"Found surrounding files: %s: %s and %s: %s", & + s1=trim(prefix),s2=fuldates(iful)(1:datelen), & + s3=trim(prefix),s4=fuldates(iful+1)(1:datelen)) + call mprintf(.true.,STDOUT,"Interpolating to create file: %s: %s", & + s1=trim(prefix),s2=hdate(1:datelen)) + call mprintf(.true.,LOGFILE,"Interpolating to create file: %s: %s", & + s1=trim(prefix),s2=hdate(1:datelen)) + call geth_idts(hdate(1:19), fuldates(iful)(1:19), intervalA) + call mprintf(.true.,STDOUT,"A Time Difference = %f",f1=float(intervalA) / 3600.) + call mprintf(.true.,LOGFILE,"A Time Difference = %f",f1=float(intervalA) / 3600.) + call geth_idts(fuldates(iful+1)(1:19), hdate(1:19), intervalB) + call mprintf(.true.,STDOUT,"B Time Difference = %f",f1=float(intervalB) / 3600.) + call mprintf(.true.,LOGFILE,"B Time Difference = %f",f1=float(intervalB) / 3600.) + AWT = 1. - (float(intervalA)/float(intervalA+intervalB)) + + open(10, file=trim(prefix)//':'//fuldates(iful)(1:datelen), form='unformatted', & + status='old') + call clear_storage + READLOOP1 : do + read(10, end=44) ifv + if ( ifv .eq. 5) then ! WPS + read (10) jdate, xfcst, map%source, field, units, desc, level, & + map%nx, map%ny, map%igrid + select case (map%igrid) + case (0, 4) + read(10) map%startloc, map%lat1, map%lon1, map%dy, map%dx, map%r_earth + case (3) + read (10) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%truelat2, map%r_earth + case (5) + read (10) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%r_earth + case default + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in DATINT 1",i1=map%igrid) + end select + read (10) map%grid_wind + else if ( ifv .eq. 4 ) then ! SI + read (10) jdate, xfcst, map%source, field, units, desc, level, & + map%nx, map%ny, map%igrid + select case (map%igrid) + case (0, 4) + read(10) map%startloc, map%lat1, map%lon1, map%dy, map%dx + case (3) + read (10) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%truelat2 + case (5) + read (10) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1 + case default + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in DATINT 2",i1=map%igrid) + end select + else if ( ifv .eq. 3 ) then ! MM5 + read(10) jdate, xfcst, field, units, desc, level,& + map%nx, map%ny, map%igrid + select case (map%igrid) + case (3) ! lamcon + read (10) map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1, map%truelat2 + case (5) ! Polar Stereographic + read (10) map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1 + case (0, 4) ! lat/lon + read (10) map%lat1, map%lon1, map%dy, map%dx + case (1) ! Mercator + read (10) map%lat1, map%lon1, map%dy, map%dx, map%truelat1 + case default + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in DATINT 3",i1=map%igrid) + end select + else + call mprintf(.true.,ERROR, & + "Unknown out_format: %i in DATINT ",i1=ifv) + endif + allocate(scr2d(map%nx, map%ny)) + read (10) scr2d + call put_storage(nint(level), field, scr2d, map%nx, map%ny) + deallocate(scr2d) + enddo READLOOP1 +44 close(10) + + open(10, file=trim(prefix)//':'//fuldates(iful+1)(1:datelen), status='old', & + form = 'unformatted') + open(11, file=trim(prefix)//':'//hdate(1:datelen), status='new', form='unformatted') + READLOOP2 : do + read (10,END=45) ifv + if ( ifv .eq. 5) then ! WPS + read (10) jdate, xfcst, map%source, field, units, desc, level, & + map%nx, map%ny, map%igrid + select case (map%igrid) + case (0, 4) + read(10) map%startloc, map%lat1, map%lon1, map%dy, map%dx, map%r_earth + case (3) + read (10) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%truelat2, map%r_earth + case (5) + read (10) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%r_earth + case default + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in DATINT ",i1=map%igrid) + end select + read (10) map%grid_wind + else if ( ifv .eq. 4 ) then ! SI + read (10) jdate, xfcst, map%source, field, units, desc, level, & + map%nx, map%ny, map%igrid + select case (map%igrid) + case (0, 4) + read(10) map%startloc, map%lat1, map%lon1, map%dy, map%dx + case (1) + read(10) map%startloc, map%lat1, map%lon1, map%dy, map%dx, map%truelat1 + case (3) + read (10) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%truelat2 + case (5) + read (10) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1 + case default + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in DATINT ",i1=map%igrid) + end select + + else if ( ifv .eq. 3 ) then ! MM5 + read(10) jdate, xfcst, field, units, desc, level,& + map%nx, map%ny, map%igrid + select case (map%igrid) + case (3) ! lamcon + read (10) map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1, map%truelat2 + case (5) ! Polar Stereographic + read (10) map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1 + case (0, 4) ! lat/lon + read (10) map%lat1, map%lon1, map%dy, map%dx + case (1) ! Mercator + read (10) map%lat1, map%lon1, map%dy, map%dx, map%truelat1 + case default + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in DATINT ",i1=map%igrid) + end select + + else + call mprintf(.true.,ERROR, & + "Unknown out_format: %i in DATINT ",i1=ifv) + endif + + allocate(scr2d(map%nx, map%ny)) + read (10) scr2d + if (is_there(nint(level), field)) then + allocate(bfr2d(map%nx,map%ny)) + call get_storage(nint(level), field, bfr2d, map%nx, map%ny) + scr2d = bfr2d * (AWT) + scr2d * (1.-AWT) + hdate_output = hdate + + if (out_format(1:2) .eq. 'SI') then + write(11) ifv + write(11) hdate_output, xfcst, map%source, field, units, desc, & + level, map%nx, map%ny, map%igrid + if (map%igrid == 0 .or. map%igrid == 4) then + write(11) map%startloc, map%lat1, map%lon1, map%dy, map%dx + elseif (map%igrid == 1) then + write(11) map%startloc, map%lat1, map%lon1, map%dy, map%dx, map%truelat1 + elseif (map%igrid == 3) then + write (11) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%truelat2 + elseif (map%igrid == 5) then + write (11) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1 + else + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in DATINT ",i1=map%igrid) + endif + + else if (out_format(1:2) .eq. 'WP') then + write(11) ifv + write(11) hdate_output, xfcst, map%source, field, units, desc, & + level, map%nx, map%ny, map%igrid + if (map%igrid == 0 .or. map%igrid == 4) then + write(11) map%startloc, map%lat1, map%lon1, map%dy, map%dx, & + map%r_earth + elseif (map%igrid == 1) then + write(11) map%startloc, map%lat1, map%lon1, map%dy, map%dx, & + map%truelat1, map%r_earth + elseif (map%igrid == 3) then + write (11) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%truelat2, map%r_earth + elseif (map%igrid == 5) then + write (11) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%r_earth + else + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in DATINT ",i1=map%igrid) + endif + write(11) map%grid_wind + + else if (out_format(1:2) .eq. 'MM') then + write (11) ifv + write (11) hdate_output, xfcst, field, units, Desc, level,& + map%nx, map%ny, map%igrid + if (map%igrid .eq. 3) then ! lamcon + write (11) map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1, map%truelat2 + elseif (map%igrid .eq. 5) then ! Polar Stereographic + write (11) map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1 + elseif (map%igrid .eq. 0 .or. map%igrid .eq. 4)then ! lat/lon + write (11) map%lat1, map%lon1, map%dy, map%dx + elseif (map%igrid.eq.1)then ! Mercator + write (11) map%lat1, map%lon1, map%dy, map%dx, map%truelat1 + else + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in DATINT ",i1=map%igrid) + endif + endif + write(11) scr2d + else + call mprintf(.true.,ERROR, & + "hdate = %s , fuldates = %s %s, Field = %s",s1=hdate,s2=fuldates(iful),s3=fuldates(iful+1),s4=field) + endif + deallocate(scr2d, bfr2d) + enddo READLOOP2 +45 close(10) + close(11) + cycle TIMELOOP + endif + enddo + + call mprintf(.true.,ERROR, & + "Data not found: %s",s1=hdate) + + enddo TIMELOOP + + call mprintf(.true.,STDOUT, & + "End Subroutine DATINT.") + call mprintf(.true.,LOGFILE, & + "End Subroutine DATINT.") + +end subroutine datint diff --git a/WPS/ungrib/src/debug_cio.c b/WPS/ungrib/src/debug_cio.c new file mode 120000 index 00000000..63c8e771 --- /dev/null +++ b/WPS/ungrib/src/debug_cio.c @@ -0,0 +1 @@ +../../geogrid/src/cio.c \ No newline at end of file diff --git a/WPS/ungrib/src/file_delete.F b/WPS/ungrib/src/file_delete.F new file mode 100644 index 00000000..730807fa --- /dev/null +++ b/WPS/ungrib/src/file_delete.F @@ -0,0 +1,67 @@ +subroutine file_delete(hdates, ndates, root, interval) +! Recent changes: ! +! 2001-02-14: ! +! - Allow file names to have date stamps out to minutes or ! +! seconds, if the user requests a time interval (in seconds) ! +! that is evenly divisible into minutes or hours. ! +! INTERVAL is checked for divisibility into 3600 (for hours) ! +! or 60 (for minutes). The local variable DATELEN is set ! +! to be the number of characters to use in our character ! +! dates. Valid values for DATELEN are 13 (for hours), ! +! 16 (for minutes), and 19 (for seconds). ! +! ! +! This change also requires changes to pregrid_grib.F, ! +! output.F, rrpr.F, datint.F ! + + use misc_definitions_module + use module_debug + + implicit none + integer :: ndates + character(len=*), dimension(ndates) :: hdates + character(len=*) :: root + integer :: interval + + logical :: lexist + integer :: idate + character(len=MAX_FILENAME_LEN) :: flnm + +! DATELEN: length of date strings to use for our output file names. + integer :: datelen + +! Decide the length of date strings to use for output file names. +! DATELEN is 13 for hours, 16 for minutes, and 19 for seconds. + if (mod(interval,3600) == 0) then + datelen = 13 + else if (mod(interval, 60) == 0) then + datelen = 16 + else + datelen = 19 + end if + + write(*, '(/,10("*"), /, & + & "Deleting temporary files created by ungrib...",/, & + & 10("*")/)') + call mprintf(.true.,LOGFILE,"**** Deleting temporary files created by ungrib... ") + + do idate = 1, ndates + flnm=trim(root)//hdates(idate)(1:datelen) + write(*, '(A)') 'Deleting file: '//trim(flnm) + call mprintf(.true.,LOGFILE," Deleting file: %s ",s1=trim(flnm)) + + inquire(file=flnm, exist = lexist) + if (lexist) then + open(10, file=flnm, status='old') + close(10, status="DELETE") + else + write(*,'(10x, "File ",A," does not exist.",/)') flnm + call mprintf(.true.,LOGFILE," File %s does not exist ",s1=flnm) + endif + enddo + + write(*, '(/,10("*"), /, & + & "Done deleting temporary files.",/, & + & 10("*")/)') + call mprintf(.true.,LOGFILE,"**** Done deleting temporary files. ") + +end subroutine file_delete diff --git a/WPS/ungrib/src/filelist.F b/WPS/ungrib/src/filelist.F new file mode 100644 index 00000000..f7589bb5 --- /dev/null +++ b/WPS/ungrib/src/filelist.F @@ -0,0 +1,4 @@ +module filelist + character(len=24), dimension(10000) :: filedates = '0000-00-00 00:00:00.0000' + integer :: nfiles = 0 +end module filelist diff --git a/WPS/ungrib/src/g1print.F b/WPS/ungrib/src/g1print.F new file mode 100644 index 00000000..8f5ba15a --- /dev/null +++ b/WPS/ungrib/src/g1print.F @@ -0,0 +1,660 @@ +! +! Print information about a grib1 file. +! Usage: "g1print [-v] [-V] filename" +! +! Originally from gribscan. +! +program g1print + use module_grib + interface + subroutine parse_args(err, a1, h1, i1, l1, a2, h2, i2, l2,& + a3, h3, i3, l3, hlast) + integer :: err + character(len=*) , optional :: a1, a2, a3 + character(len=*), optional :: h1, h2, h3 + integer , optional :: i1, i2, i3 + logical, optional :: l1, l2, l3 + character(len=*), optional :: hlast + end subroutine parse_args + end interface + + character(len=120) :: flnm + character(len=30) :: hopt + real, allocatable, dimension(:) :: datarray + integer :: ierr, igherr + integer :: cc + character(len=100) :: fmt = '(I4,1X, & + & I3,1x, A5,1x, & + & I4, & + & 2(1x,I4),2x,I4.4,2("-",I2.2),"_",I2.2,":",& + & I2.2, 1x, "+", i3.2)' + logical :: ivb = .FALSE. + logical :: idb = .FALSE. + integer :: year + character(len=5) :: field + + flnm = ' ' + call parse_args(ierr, a1='v', l1=ivb, a2='V', l2=idb, hlast=flnm) + if (ierr.ne.0) then + call getarg(0, hopt) + write(*,'(//,"Usage: ", A, " [-v] [-V] file",/)') trim(hopt) + write(*,'(" -v : Print more information about the GRIB records")') + write(*,'(" -V : Print way too much information about the GRIB& + & records")') + write(*,'(" file : GRIB file to read"//)') + stop +! stop + endif + + if (idb) ivb = .TRUE. + + call c_open(idum, munit, flnm, 1, ierr, 1) + + if (.not. ivb) then + write(*,'(52("-"))') + write(*,'(" rec GRIB GRIB Lvl Lvl Lvl Time Fcst")') + write(*,'(" Num Code name Code one two hour")') + write(*,'(52("-"))') + endif + + irec = 0 + call gribget(munit, ierr) + do while (ierr.eq.0) + irec = irec + 1 + call gribheader(0,igherr) + if (igherr /= 0) then + call deallogrib + call gribget(munit, ierr) + cycle + endif + + call fieldname(sec1(2), sec1(3), sec1(4), sec1(7), sec1(24), field) + + if (ivb) then + call gribprint(0) + call gribprint(1) + call gribprint(2) + call gribprint(3) + call gribprint(4) + if (sec2(4).eq.50) then + ndat = (infogrid(1)+1)*(infogrid(2)+1) + else + ndat = (infogrid(1)*infogrid(2)) + endif + allocate(datarray(ndat)) + call gribdata(datarray, ndat) + fldmax = datarray(1) + fldmin = datarray(1) + do j = 1, ndat + if (datarray(j).gt.fldmax) fldmax=datarray(j) + if (datarray(j).lt.fldmin) fldmin=datarray(j) + enddo + write(*,*) " " + write(*,*) " ",field," : " + write(*,'(5x,"Minimum Data Value ",t45,":",g14.5)') fldmin + write(*,'(5x,"Maximum Data Value ",t45,":",g14.5)') fldmax + write(*,'(//,70("*"))') + if (idb) then + print*, 'Datarray = ', Datarray + endif + deallocate(datarray) + else + CC = sec1(22) + year = (cc-1)*100 + sec1(11) + if ( sec1(16) .eq. 254) then + ifcst = sec1(17)/3600. + else + ifcst = sec1(17) + endif + write(*,FMT) irec, sec1(7), field, sec1(8:10), year,sec1(12:15),ifcst + endif + + call deallogrib + + call gribget(munit, ierr) + enddo + if (ierr.eq.1) write(*,'(/,"***** End-Of-File on C unit ", I3,/)') munit + call c_close( munit, 0, ierr) + +end program g1print + +subroutine parse_args(err, a1, h1, i1, l1, a2, h2, i2, l2, a3, h3, i3, l3, & + hlast) + integer :: err + character(len=*) , optional :: a1, a2, a3 + character(len=*), optional :: h1, h2, h3 + integer , optional :: i1, i2, i3 + logical, optional :: l1, l2, l3 + character(len=*), optional :: hlast + + character(len=100) :: hold + integer :: ioff = 0 + + if (present(hlast)) then + ioff = -1 + endif + + err = 0 + + narg = iargc() + numarg = narg + ioff + + i = 1 + LOOP : do while ( i <= numarg) + + ierr = 1 + if (present(i1)) then + call checkiarg(i, a1, i1, ierr) + elseif (present(h1)) then + call checkharg(i, a1, h1, ierr) + elseif (present(l1)) then + call checklarg(i, a1, l1, ierr) + endif + if (ierr.eq.0) cycle LOOP + + if (present(i2)) then + call checkiarg(i, a2, i2, ierr) + elseif (present(h2)) then + call checkharg(i, a2, h2, ierr) + elseif (present(l2)) then + call checklarg(i, a2, l2, ierr) + endif + if (ierr.eq.0) cycle LOOP + + if (present(i3)) then + call checkiarg(i, a3, i3, ierr) + elseif (present(h3)) then + call checkharg(i, a3, h3, ierr) + elseif (present(l3)) then + call checklarg(i, a3, l3, ierr) + endif + if (ierr.eq.0) cycle LOOP + + err = 1 + call getarg(1, hold) + write(*, '("arg = ", A)') trim(hold) + + exit LOOP + + enddo LOOP + + if (present(hlast)) then + if (narg.eq.0) then + err = 1 + else + call getarg(narg, hlast) + endif + endif + +contains + subroutine checkiarg(c, a, i, ierr) + integer :: c + character(len=*) :: a + integer :: i + + character(len=100) :: hold + ierr = 1 + + call getarg(c, hold) + + if ('-'//a.eq.trim(hold)) then + c = c + 1 + call getarg(c, hold) + read(hold, *) i + c = c + 1 + ierr = 0 + elseif ('-'//a .eq. hold(1:len_trim(a)+1)) then + hold = hold(len_trim(a)+2: len(hold)) + read(hold, *) i + c = c + 1 + ierr = 0 + endif + + end subroutine checkiarg + subroutine checkharg(c, a, h, ierr) + integer :: c + character(len=*) :: a + character(len=*) :: h + + character(len=100) :: hold + ierr = 1 + + call getarg(c, hold) + + if ('-'//a.eq.trim(hold)) then + c = c + 1 + call getarg(c, hold) + h = trim(hold) + c = c + 1 + ierr = 0 + elseif ('-'//a .eq. hold(1:len_trim(a)+1)) then + hold = hold(len_trim(a)+2: len(hold)) + h = trim(hold) + c = c + 1 + ierr = 0 + endif + + end subroutine checkharg + + subroutine checklarg(c, a, l, ierr) + integer :: c + character(len=*) :: a + logical :: l + + character(len=100) :: hold + ierr = 1 + + call getarg(c, hold) + if ('-'//a.eq.trim(hold)) then + l = .TRUE. + c = c + 1 + ierr = 0 + endif + + end subroutine checklarg + +end subroutine parse_args + + subroutine fieldname(ptv, centerid, procid, param, subc, field) +! +! This routine contains the tables for the various grib parameters +! Each individual parameter contains the info to identify itself. +! We don't have the complete tables here, just enough for normal wrf use. +! wgrib has more complete NCEP tables. (look in WRFV3/external/io_grib1/WGRIB) +! +! ptv - parameter table version +! centerid - id number ofthe originating center +! procid - process id +! param - parameter number +! subc - sub center +! field - 5-character field name (returned) + + integer, intent(in) :: ptv, centerid, procid, param, subc + logical :: first=.true. + character (len=5), intent(out) :: field + character(len=5) :: table2(255), table129(255), afwa(255), ecmwf(255), & + table130(255), table131(255), table132(255) + common /paramids/ table2, table129, table130, table131, table132, afwa, ecmwf + + field = ' ' + if (first) call init_tables + first = .false. + if ( centerid .eq. 7 .and. ptv .eq. 2 ) then + field = table2(param) + else if ( centerid .eq. 7 .and. ptv .eq. 129 ) then + field = table129(param) + else if ( centerid .eq. 7 .and. ptv .eq. 130 ) then + field = table130(param) + else if ( centerid .eq. 7 .and. ptv .eq. 131 ) then + field = table131(param) + else if ( centerid .eq. 7 .and. ptv .eq. 132 ) then + field = table132(param) + else if ( centerid .eq. 57 ) then + field = afwa(param) + else if ( centerid .eq. 58 .and. ptv .eq. 2 ) then ! navysst + field = table2(param) + else if ( centerid .eq. 59 .and. ptv .eq. 2 ) then ! GSD + field = table2(param) + else if ( centerid .eq. 59 .and. ptv .eq. 129 ) then + field = table129(param) + else if ( centerid .eq. 98 .and. ptv .eq. 128 ) then ! ECMWF + field = ecmwf(param) + else if ( ptv .eq. 2 ) then ! previous default behavior - assume table 2 is ncep table 2 + field = table2(param) + else + field = ' ' + endif + return +end subroutine fieldname +! + subroutine init_tables + character(len=5) :: table2(255), table129(255), afwa(255), ecmwf(255), & + table130(255), table131(255), table132(255) + common /paramids/ table2, table129, table130, table131, table132, afwa, ecmwf + + ! afwa + do i = 1, 127 + afwa(i) = table2(i) + enddo + do i = 128, 254 + afwa(i) = ' ' + enddo + afwa(144) = 'DNWLR' + afwa(145) = 'INSWR' + afwa(155) = 'GDHFX' + afwa(157) = 'XTRAJ' + afwa(158) = 'YTRAJ' + afwa(159) = 'PTRAJ' + afwa(160) = 'TERID' + afwa(161) = 'MDLTN' + afwa(174) = 'SNOWD' + afwa(175) = 'SNOAG' + afwa(176) = 'SNOCL' + afwa(177) = 'VSBLY' + afwa(178) = 'CURWX' + afwa(179) = 'CLAMT' + afwa(180) = 'CLBAS' + afwa(181) = 'CLTOP' + afwa(182) = 'CLTYP' + afwa(183) = 'UTIME' + afwa(184) = 'SRCDT' + afwa(196) = 'EPCDF' + afwa(197) = 'EPALL' + afwa(198) = 'EPGEO' + afwa(199) = 'EPVAL' + afwa(200) = 'SOILR' + afwa(201) = 'SOILW' + afwa(205) = 'TYPSL' + afwa(206) = 'VLASH' + afwa(207) = 'CANWT' + afwa(208) = 'PEVAP' + afwa(209) = 'WNDRN' + afwa(210) = 'RHTMN' + afwa(211) = 'SOILL' + afwa(212) = 'VEGTP' + afwa(213) = 'GREEN' + afwa(234) = 'BGRUN' + afwa(235) = 'SSRUN' + + ! ECMWF +! from http://www.ecmwf.int/services/archive/d/parameters/order=grib_parameter/table=128/ + do i = 1, 254 + ecmwf(i) = ' ' + enddo + ecmwf(1) = 'STRF ' + ecmwf(2) = 'VPOT ' + ecmwf(3) = 'PT ' + ecmwf(4) = 'EQPT ' + ecmwf(5) = 'SEPT ' + ecmwf(8) = 'SRO ' + ecmwf(9) = 'SSRO ' + ecmwf(10) = 'WS ' + ecmwf(26) = 'CL ' + ecmwf(27) = 'CVL ' + ecmwf(28) = 'CVH ' + ecmwf(29) = 'TVL ' + ecmwf(30) = 'TVH ' + ecmwf(31) = 'CI ' + ecmwf(32) = 'ASN ' + ecmwf(33) = 'RSN ' + ecmwf(34) = 'SSTK ' + ecmwf(35) = 'ISTL1' + ecmwf(36) = 'ISTL2' + ecmwf(37) = 'ISTL3' + ecmwf(38) = 'ISTL4' + ecmwf(39) = 'SWVL1' + ecmwf(40) = 'SWVL2' + ecmwf(41) = 'SWVL3' + ecmwf(42) = 'SWVL4' + ecmwf(43) = 'SLT ' + ecmwf(44) = 'ES ' + ecmwf(45) = 'SMLT ' + ecmwf(60) = 'PV ' + ecmwf(74) = 'SDFOR' + ecmwf(75) = 'CRWC ' + ecmwf(76) = 'CSWC ' + ecmwf(77) = 'ETADT' + ecmwf(78) = 'TCLW ' + ecmwf(79) = 'TCIW ' + ecmwf(121) = 'MX2T6' + ecmwf(122) = 'MN2T6' + ecmwf(123) = '10FG6' + ecmwf(124) = 'EMIS ' + ecmwf(127) = 'AT ' + ecmwf(128) = 'BV ' + ecmwf(129) = 'Z ' + ecmwf(130) = 'T ' + ecmwf(131) = 'U ' + ecmwf(132) = 'V ' + ecmwf(133) = 'Q ' + ecmwf(134) = 'SP ' + ecmwf(135) = 'W ' + ecmwf(136) = 'TCW ' + ecmwf(137) = 'TCWV ' + ecmwf(138) = 'VO ' + ecmwf(139) = 'STL1 ' + ecmwf(140) = 'SWL1 ' + ecmwf(141) = 'SD ' + ecmwf(142) = 'LSP ' + ecmwf(143) = 'CP ' + ecmwf(144) = 'SF ' + ecmwf(145) = 'BLD ' + ecmwf(146) = 'SSHF ' + ecmwf(147) = 'SLHF ' + ecmwf(148) = 'CHNK ' + ecmwf(149) = 'SNR ' + ecmwf(150) = 'TNR ' + ecmwf(151) = 'MSL ' + ecmwf(152) = 'LNSP ' + ecmwf(153) = 'SWHR ' + ecmwf(154) = 'LWHR ' + ecmwf(155) = 'D ' + ecmwf(156) = 'GH ' + ecmwf(157) = 'R ' + ecmwf(159) = 'BLH ' + ecmwf(160) = 'SDOR ' + ecmwf(161) = 'ISOR ' + ecmwf(162) = 'ANOR ' + ecmwf(163) = 'SLOR ' + ecmwf(164) = 'TCC ' + ecmwf(165) = '10U ' + ecmwf(166) = '10V ' + ecmwf(167) = '2T ' + ecmwf(168) = '2D ' + ecmwf(169) = 'SSRD ' + ecmwf(170) = 'STL2 ' + ecmwf(171) = 'SWL2 ' + ecmwf(172) = 'LSM ' + ecmwf(173) = 'SR ' + ecmwf(174) = 'AL ' + ecmwf(175) = 'STRD ' + ecmwf(176) = 'SSR ' + ecmwf(177) = 'STR ' + ecmwf(178) = 'TSR ' + ecmwf(179) = 'TTR ' + ecmwf(180) = 'EWSS ' + ecmwf(181) = 'NSSS ' + ecmwf(182) = 'E ' + ecmwf(183) = 'STL3 ' + ecmwf(184) = 'SWL3 ' + ecmwf(185) = 'CCC ' + ecmwf(186) = 'LCC ' + ecmwf(187) = 'MCC ' + ecmwf(188) = 'HCC ' + ecmwf(189) = 'SUND ' + ecmwf(194) = 'BTMP ' + ecmwf(195) = 'LGWS ' + ecmwf(196) = 'MGWS ' + ecmwf(197) = 'GWD ' + ecmwf(198) = 'SRC ' + ecmwf(199) = 'VEG ' + ecmwf(200) = 'VSO ' + ecmwf(201) = 'MX2T ' + ecmwf(202) = 'MN2T ' + ecmwf(203) = 'O3 ' + ecmwf(204) = 'PAW ' + ecmwf(205) = 'RO ' + ecmwf(206) = 'TCO3 ' + ecmwf(207) = '10SI ' + ecmwf(208) = 'TSRC ' + ecmwf(209) = 'TTRC ' + ecmwf(210) = 'SSRC ' + ecmwf(211) = 'STRC ' + ecmwf(212) = 'TISR ' + ecmwf(213) = 'VIMD ' + ecmwf(214) = 'DHR ' + ecmwf(227) = 'CRNH ' + ecmwf(229) = 'IEWS ' + ecmwf(230) = 'INSS ' + ecmwf(231) = 'ISHF ' + ecmwf(232) = 'IE ' + ecmwf(233) = 'ASQ ' + ecmwf(234) = 'LSRH ' + ecmwf(235) = 'SKT ' + ecmwf(236) = 'STL4 ' + ecmwf(237) = 'SWL4 ' + ecmwf(238) = 'TSN ' + ecmwf(239) = 'CSF ' + ecmwf(240) = 'LSF ' + ecmwf(248) = 'CC ' +end subroutine init_tables + + block data ptables + character(len=5) :: table2(255), table129(255), afwa(255), ecmwf(255), & + table130(255), table131(255), table132(255) + common /paramids/ table2, table129, table130, table131, table132, afwa, ecmwf + + data table2 /'PRES','PRMSL','PTEND','PVORT','ICAHT','GP','HGT','DIST',& + 'HSTDV','TOZNE','TMP','VTMP','POT','EPOT','T MAX','T MIN','DPT',& + 'DEPR','LAPR','VIS','RDSP1','RDSP2','RDSP3','PLI','TMP A','PRESA',& + 'GP A','WVSP1','WVSP2','WVSP3','WDIR','WIND','U GRD','V GRD','STRM',& + 'V POT','MNTSF','SGCVV','V VEL','DZDT','ABS V','ABD D','REL V','REL D',& + 'VUCSH','VVCSG','DIR C','SP C','UOGRD','VOGRD','SPF H','R H','MIXR',& + 'P WAT','VAPP','SAT D','EVP','C ICE','PRATE','TSTM','A PCP','NCPCP',& + 'ACPCP','SRWEQ','WEASD','SNO D','MIXHT','TTHDP','MTHD','MTH A','T CDC',& + 'CDCON','L CDC','M CDC','H CDC','C WAT','BLI','SNO C','SNO L','WTMP',& + 'LAND','DSL M','SFC R','ALBDO','TSOIL','SOILM','VEG','SALTY','DEN',& + 'WATR','ICE C','ICETK','DICED','SICED','U ICE','V ICE','ICE G','ICE D',& + 'SNO M','HTSGW','WVDIR','WVHGT','WVPER','SWDIR','SWELL','SWPER','DIRPW',& + 'PERPW','DIRSW','PERSW','NSWRS','NLWRS','NSWRT','NLWRT','LWAVR','SWAVR',& + 'GRAD','BRTMP','LWRAD','SWRAD','LHTFL','SHTFL','BLYDP','U FLX','V FLX',& + 'WMIXE','IMG D',& +! 128-254 for use by originating center. NWS/NCEP Table 2 is coded here. + 'MSLSA','MSLMA','MSLET','LFT X','4LFTX','K X','S X','MCONV','VW SH',& + 'TSLSA','BVF 2','PV MW','CRAIN','CFRZR','CICEP','CSNOW','SOILW',& + 'PEVPR','CWORK','U-GWD','V-GWD','PV','COVMZ','COVTZ','COVTM','CLWMR',& + 'O3MR','GFLUX','CIN','CAPE','TKE','CONDP','CSUSF','CSDSF','CSULF',& + 'CSDLF','CFNSF','CFNLF','VBDSF','VDDSF','NBDSF','NDDSF','RWMR',& + 'SNMR','M FLX','LMH','LMV','MLYNO','NLAT','ELON','ICMR','GRMR','GUST',& + 'LPS X','LPS Y','HGT X','HGT Y','TPFI','TIPD','LTNG','RDRIP','VPTMP','HLCY',& + 'PROB','PROBN','POP','CPOFP','CPOZP','USTM','VSTM','NCIP','EVBS','EVCW',& + 'ICWAT','CWDI','VAFTD','DSWRF','DLWRF','UVI','MSTAV','SFEXC','MIXLY','TRANS',& + 'USWRF','ULWRF','CDLYR','CPRAT','TTDIA','TTRAD','TTPHY','PREIX','TSD1D',& + 'NLGSP','HPBL','5WAVH','CNWAT','SOTYP','VGTYP','BMIXL','AMIXL','PEVAP',& + 'SNOHF','5WAVA','MFLUX','DTRF','UTRF','BGRUN','SSRUN','SIPD','O3TOT',& + 'SNOWC','SNOT','COVTW','LRGHR','CNVHR','CNVMR','SHAHR','SHAMR','VDFHR',& + 'VDFUA','VDFVA','VDFMR','SWHR','LWHR','CD','FRICV','RI',' '/ + data table129 /'PRES','PRMSL','PTEND','PVORT','ICAHT','GP','HGT','DIST',& + 'HSTDV','TOZNE','TMP','VTMP','POT','EPOT','T MAX','T MIN','DPT',& + 'DEPR','LAPR','VIS','RDSP1','RDSP2','RDSP3','PLI','TMP A','PRESA',& + 'GP A','WVSP1','WVSP2','WVSP3','WDIR','WIND','U GRD','V GRD','STRM',& + 'V POT','MNTSF','SGCVV','V VEL','DZDT','ABS V','ABD D','REL V','REL D',& + 'VUCSH','VVCSG','DIR C','SP C','UOGRD','VOGRD','SPF H','R H','MIXR',& + 'P WAT','VAPP','SAT D','EVP','C ICE','PRATE','TSTM','A PCP','NCPCP',& + 'ACPCP','SRWEQ','WEASD','SNO D','MIXHT','TTHDP','MTHD','MTH A','T CDC',& + 'CDCON','L CDC','M CDC','H CDC','C WAT','BLI','SNO C','SNO L','WTMP',& + 'LAND','DSL M','SFC R','ALBDO','TSOIL','SOILM','VEG','SALTY','DEN',& + 'WATR','ICE C','ICETK','DICED','SICED','U ICE','V ICE','ICE G','ICE D',& + 'SNO M','HTSGW','WVDIR','WVHGT','WVPER','SWDIR','SWELL','SWPER','DIRPW',& + 'PERPW','DIRSW','PERSW','NSWRS','NLWRS','NSWRT','NLWRT','LWAVR','SWAVR',& + 'GRAD','BRTMP','LWRAD','SWRAD','LHTFL','SHTFL','BLYDP','U FLX','V FLX',& + 'WMIXE','IMG D',& +! All NCEP tables use the Table 2 values for the first 127 entries +! 128-254 for Table129 + 'PAOT','PAOP','CWR','FRAIN','FICE','FRIME','CUEFI','TCOND','TCOLW',& + 'TCOLI','TCOLR','TCOLS','TCOLC','PLPL','HLPL','CEMS','COPD',& + 'PSIZ','TCWAT','TCICE','WDIF','WSTP','PTAN','PTNN','PTBN','PPAN',& + 'PPNN','PPBN','PMTC','PMTF','AETMP','AEDPT','AESPH','AEUWD','AEVWD',& + 'LPMTF','LIPMF','REFZR','REFZI','REFZC','TCLSW','TCOLM','ELRDI',& + 'TSEC','TSECA','NUM','AEPRS','ICSEV','ICPRB','LAVNI','HAVNI','FLGHT','OZCON',& + 'OZCAT','VEDH','SIGV','EWGT','CICEL','CIVIS','CIFLT','LAVV','LOVV','USCT',& + 'VSCT','LAUV','LOUV','TCHP','DBSS','ODHA','OHC','SSHG','SLTFL','DUVB',& + 'CDUVB','THFLX','UVAR','VVAR','UVVCC','MCLS','LAPP','LOPP',' ','REFO',& + 'REFD','REFC','SBT22','SBT23','SBT24','SBT25','MINRH','MAXRH','CEIL',& + 'PBLRE','SBC23','SBC24','RPRAT','SPRAT','FPRAT','IPRAT','UPHL','SURGE',& + 'ETSRG','RHPW','OZMAX1','OZMAX8','PDMAX1','PDMAX24','MAXREF','MXUPHL','MAXUVV',& + 'MAXDVV','MAXVIG','RETOP','VRATE','TCSRG20','TCSRG30','TCSRG40','TCSRG50','TCSRG60',& + 'TCSRG70','TCSRG80','TCSRG90','HINDX','DIFTEN','PSPCP','MAXUW','MAXVW','255'/ + data table130 /'PRES','PRMSL','PTEND','PVORT','ICAHT','GP','HGT','DIST',& + 'HSTDV','TOZNE','TMP','VTMP','POT','EPOT','T MAX','T MIN','DPT',& + 'DEPR','LAPR','VIS','RDSP1','RDSP2','RDSP3','PLI','TMP A','PRESA',& + 'GP A','WVSP1','WVSP2','WVSP3','WDIR','WIND','U GRD','V GRD','STRM',& + 'V POT','MNTSF','SGCVV','V VEL','DZDT','ABS V','ABD D','REL V','REL D',& + 'VUCSH','VVCSG','DIR C','SP C','UOGRD','VOGRD','SPF H','R H','MIXR',& + 'P WAT','VAPP','SAT D','EVP','C ICE','PRATE','TSTM','A PCP','NCPCP',& + 'ACPCP','SRWEQ','WEASD','SNO D','MIXHT','TTHDP','MTHD','MTH A','T CDC',& + 'CDCON','L CDC','M CDC','H CDC','C WAT','BLI','SNO C','SNO L','WTMP',& + 'LAND','DSL M','SFC R','ALBDO','TSOIL','SOILM','VEG','SALTY','DEN',& + 'WATR','ICE C','ICETK','DICED','SICED','U ICE','V ICE','ICE G','ICE D',& + 'SNO M','HTSGW','WVDIR','WVHGT','WVPER','SWDIR','SWELL','SWPER','DIRPW',& + 'PERPW','DIRSW','PERSW','NSWRS','NLWRS','NSWRT','NLWRT','LWAVR','SWAVR',& + 'GRAD','BRTMP','LWRAD','SWRAD','LHTFL','SHTFL','BLYDP','U FLX','V FLX',& + 'WMIXE','IMG D',& +! Table 130 LSM +! 128-143 not yet assigned + ' ',' ',' ',' ',' ',' ',' ',' ',' ',& + ' ',' ',' ',' ',' ',' ',' ','SOILW',& + 'PEVPR','VEGT ','BARET','AVSFT','RADT','SSTOR','LSOIL','EWATR',' ',& + 'LSPA ','GFLUX','CIN','CAPE','TKE','MXSAL','SOILL','ASNOW','ARAIN',& + 'GWREC','QREC ','SNOWT','VBDSF','VDDSF','NBDSF','NDDSF','SNFALB',& + 'RLYRS','M FLX',' ',' ',' ','NLAT','ELON','FLDCAP','ACOND','SNOAG',& + 'CCOND','LAI','SFCRH','SALBD',' ',' ','NDVI','DRIP','VBSALB','VWSALB',& + 'NBSALB','NWSALB','FRZR','FROZR','TSNOW','MTERH',' ','SBSNO','EVBS','EVCW',& + 'VTCIN','VTCAPE','RSMIN','DSWRF','DLWRF',' ','MSTAV','SFEXC',' ','TRANS',& + 'USWRF','ULWRF',' ',' ',' ',' ',' ',' ','WILT',& + 'FLDCP','HPBL','SLTYP','CNWAT','SOTYP','VGTYP','BMIXL','AMIXL','PEVAP',& + 'SNOHF','SMREF','SMDRY',' ',' ','BGRUN','SSRUN',' ',' ',& + 'SNOWC','SNOT','POROS','SBT112','SBT113','SBT114','SBT115',' ','RCS',& + 'RCT','RCQ','RCSOL',' ',' ','CD','FRICV','RI',' '/ + data table131 /'PRES','PRMSL','PTEND','PVORT','ICAHT','GP','HGT','DIST',& + 'HSTDV','TOZNE','TMP','VTMP','POT','EPOT','T MAX','T MIN','DPT',& + 'DEPR','LAPR','VIS','RDSP1','RDSP2','RDSP3','PLI','TMP A','PRESA',& + 'GP A','WVSP1','WVSP2','WVSP3','WDIR','WIND','U GRD','V GRD','STRM',& + 'V POT','MNTSF','SGCVV','V VEL','DZDT','ABS V','ABD D','REL V','REL D',& + 'VUCSH','VVCSG','DIR C','SP C','UOGRD','VOGRD','SPF H','R H','MIXR',& + 'P WAT','VAPP','SAT D','EVP','C ICE','PRATE','TSTM','A PCP','NCPCP',& + 'ACPCP','SRWEQ','WEASD','SNO D','MIXHT','TTHDP','MTHD','MTH A','T CDC',& + 'CDCON','L CDC','M CDC','H CDC','C WAT','BLI','SNO C','SNO L','WTMP',& + 'LAND','DSL M','SFC R','ALBDO','TSOIL','SOILM','VEG','SALTY','DEN',& + 'WATR','ICE C','ICETK','DICED','SICED','U ICE','V ICE','ICE G','ICE D',& + 'SNO M','HTSGW','WVDIR','WVHGT','WVPER','SWDIR','SWELL','SWPER','DIRPW',& + 'PERPW','DIRSW','PERSW','NSWRS','NLWRS','NSWRT','NLWRT','LWAVR','SWAVR',& + 'GRAD','BRTMP','LWRAD','SWRAD','LHTFL','SHTFL','BLYDP','U FLX','V FLX',& + 'WMIXE','IMG D',& +! Table 131 NARR + 'MSLSA',' ','MSLET','LFT X','4LFTX',' ','PRESN','MCONV','VW SH',& + ' ',' ','PVMWW','CRAIN','CFRZR','CICEP','CSNOW','SOILW',& + 'PEVPR','VEGT ','BARET','AVSFT','RADT','SSTOR','LSOIL','EWATR','CLWMR',& + ' ','GFLUX','CIN','CAPE','TKE','MXSAL','SOILL','ASNOW','ARAIN',& + 'GWREC','QREC ','SNOWT','VBDSF','VDDSF','NBDSF','NDDSF','SNFAL',& + 'RLYRS','M FLX','LMH','LMV','MLYNO','NLAT','ELON','ICMR','ACOND','SNOAG',& + 'CCOND','LAI ','SFCRH','SALBD',' ',' ','NDVI','DRIP','LANDN','HLCY',& + 'NLATN','ELONN',' ','CPOFP',' ','USTM','VSTM','SBSNO','EVBS','EVCW',& + ' ','APCPN','RSMIN','DSWRF','DLWRF','ACPCP','MSTAV','SFEXC',' ','TRANS',& + 'USWRF','ULWRF','CDLYR','CPRAT',' ','TTRAD',' ','HGTN ','WILT ',& + 'FLDCP','HPBL','SLTYP','CNWAT','SOTYP','VGTYP','BMIXL','AMIXL','PEVAP',& + 'SNOHF','SMREF','SMDRY','WVINC','WCINC','BGRUN','SSRUN',' ','WVCON',& + 'SNOWC','SNOT','POROS','WCCON','WVUFL','WVVFL','WCUFL','WCVFL','RCS ',& + 'RCT','RCQ','RCSOL','SWHR','LWHR','CD','FRICV','RI',' '/ + data table132 /'PRES','PRMSL','PTEND','PVORT','ICAHT','GP','HGT','DIST',& + 'HSTDV','TOZNE','TMP','VTMP','POT','EPOT','T MAX','T MIN','DPT',& + 'DEPR','LAPR','VIS','RDSP1','RDSP2','RDSP3','PLI','TMP A','PRESA',& + 'GP A','WVSP1','WVSP2','WVSP3','WDIR','WIND','U GRD','V GRD','STRM',& + 'V POT','MNTSF','SGCVV','V VEL','DZDT','ABS V','ABD D','REL V','REL D',& + 'VUCSH','VVCSG','DIR C','SP C','UOGRD','VOGRD','SPF H','R H','MIXR',& + 'P WAT','VAPP','SAT D','EVP','C ICE','PRATE','TSTM','A PCP','NCPCP',& + 'ACPCP','SRWEQ','WEASD','SNO D','MIXHT','TTHDP','MTHD','MTH A','T CDC',& + 'CDCON','L CDC','M CDC','H CDC','C WAT','BLI','SNO C','SNO L','WTMP',& + 'LAND','DSL M','SFC R','ALBDO','TSOIL','SOILM','VEG','SALTY','DEN',& + 'WATR','ICE C','ICETK','DICED','SICED','U ICE','V ICE','ICE G','ICE D',& + 'SNO M','HTSGW','WVDIR','WVHGT','WVPER','SWDIR','SWELL','SWPER','DIRPW',& + 'PERPW','DIRSW','PERSW','NSWRS','NLWRS','NSWRT','NLWRT','LWAVR','SWAVR',& + 'GRAD','BRTMP','LWRAD','SWRAD','LHTFL','SHTFL','BLYDP','U FLX','V FLX',& + 'WMIXE','IMG D',& +! Table 132 NCEP2 originally the same as table 2, but they diverged. + 'MSLSA','MSLMA','MSLET','LFT X','4LFTX','K X','S X','MCONV','VW SH',& + 'TSLSA','BVF 2','PV MW','CRAIN','CFRZR','CICEP','CSNOW','SOILW',& + 'PEVPR','CWORK','U-GWD','V-GWD','PV',' ',' ',' ','MFXDV',& + ' ','GFLUX','CIN','CAPE','TKE','CONDP','CSUSF','CSDSF','CSULF',& + 'CSDLF','CFNSF','CFNLF','VBDSF','VDDSF','NBDSF','NDDSF','USTR',& + 'VSTR','M FLX','LMH','LMV','SGLYR','NLAT','ELON','UMAS','VMAS','XPRATE',& + 'LPS X','LPS Y','HGT X','HGT Y','STDZ','STDU','STDV','STDQ','STDTP','CBUW',& + 'CBVW','CBUQN','CBVQ','CBTW ','CBQW ','CBMZW','CBTZW','CBTMW','STDRH','SDTZ',& + 'ICWAT','SDTU','SDTV','DSWRF','DLWRF','SDTQ','MSTAV','SFEXC','MIXLY','SDTT',& + 'USWRF','ULWRF','CDLYR','CPRAT','TTDIA','TTRAD','TTPHY','PREIX','TSD1D',& + 'NLGSP','SDTRH','5WAVH','CNWAT','PLTRS','RHCLD','BMIXL','AMIXL','PEVAP',& + 'SNOHF','SNOEV','MFLUX','DTRF','UTRF','BGRUN','SSRUN',' ','O3TOT',& + 'SNOWC','SNOT','GLCR ','LRGHR','CNVHR','CNVMR','SHAHR','SHAMR','VDFHR',& + 'VDFUA','VDFVA','VDFMR','SWHR','LWHR','CD','FRICV','RI',' '/ + + end diff --git a/WPS/ungrib/src/g2print.F b/WPS/ungrib/src/g2print.F new file mode 100644 index 00000000..caebcf8b --- /dev/null +++ b/WPS/ungrib/src/g2print.F @@ -0,0 +1,1241 @@ +!*****************************************************************************! + program g2print ! +! ! + use table + use gridinfo + use filelist + implicit none + interface + subroutine parse_args(err, a1, h1, i1, l1, a2, h2, i2, l2,& + a3, h3, i3, l3, hlast) + integer :: err + character(len=*) , optional :: a1, a2, a3 + character(len=*), optional :: h1, h2, h3 + integer , optional :: i1, i2, i3 + logical, optional :: l1, l2, l3 + character(len=*), optional :: hlast + end subroutine parse_args + end interface + + integer :: nunit1 = 12 + character(LEN=120) :: gribflnm + + integer :: iprint + + integer , parameter :: maxlvl = 150 + + real :: startlat, startlon, deltalat, deltalon + real :: level + character (LEN=9) :: field + character (LEN=3) :: out_format + + logical :: readit + + integer, dimension(255) :: iuarr = 0 + + character (LEN=19) :: HSTART, HEND, HDATE + character(LEN=19) :: hsave = '0000-00-00_00:00:00' + integer :: itime + integer :: ntimes + integer :: interval + integer :: ierr + logical :: ordered_by_date + integer :: debug_level + integer :: grib_version + integer :: vtable_columns + + character(len=30) :: hopt + logical :: ivb = .FALSE. + logical :: idb = .FALSE. + +! ----------------- + + gribflnm = ' ' + call parse_args(ierr, a1='v', l1=ivb, a2='V', l2=idb, hlast=gribflnm) + if (ierr.ne.0) then + call getarg(0, hopt) + write(*,'(//,"Usage: ", A, " [-v] [-V] file",/)') trim(hopt) + write(*,'(" -v : Print more information about the GRIB records")') + write(*,'(" -V : Print way too much information about the GRIB& + & records")') + write(*,'(" file : GRIB file to read"//)') + stop + endif + +! ----------------- +! Determine GRIB Edition number + grib_version=0 + call edition_num(nunit1, trim(gribflnm), grib_version, ierr) + if (ierr.eq.3) STOP 'GRIB file problem' + + + debug_level = 0 + if (ivb) debug_level = 51 + if (idb) debug_level = 101 + write(6,*) 'reading from grib file = ',gribflnm + + LOOP1 : DO + ! At the beginning of LOOP1, we are at a new time period. + ! Clear the storage arrays and associated level information. + + ! If we need to read a new grib record, then read one. + + if (grib_version.ne.2) then +! write(6,*) 'calling r_grib1 with iunit ', nunit1 +! write(6,*) 'flnm = ',gribflnm + write(6,*) 'This is a Grib1 file. Please use g1print.\n' + stop + ! Read one record at a time from GRIB1 (and older Editions) +! call r_grib1(nunit1, gribflnm, level, field, & +! hdate, debug_level, ierr, iuarr, iprint) + else + + ! Read one file of records from GRIB2. + if (debug_level .gt. 100) write(6,*) 'calling r_grib2' + call r_grib2(nunit1, gribflnm, hdate, & + grib_version, debug_level, ierr) + + endif + + if (ierr.eq.1) then + ! We have hit the end of a file. Exit LOOP1. + exit LOOP1 + endif + + enddo LOOP1 + + if (grib_version.ne.2) then + call c_close(iuarr(nunit1), iprint, ierr) + iuarr(nunit1) = 0 + endif + +! And Now we are done: + + print*,' ' + print*,' ' + print*,' Successful completion of g2print ' + +contains + subroutine sort_filedates + implicit none + + integer :: n + logical :: done + if (nfiles > 1) then + done = .FALSE. + do while ( .not. done) + done = .TRUE. + do n = 1, nfiles-1 + if (filedates(n) > filedates(n+1)) then + filedates(size(filedates)) = filedates(n) + filedates(n) = filedates(n+1) + filedates(n+1) = filedates(size(filedates)) + filedates(size(filedates)) = '0000-00-00 00:00:00.0000' + done = .FALSE. + endif + enddo + enddo + endif + end subroutine sort_filedates + +end program g2print + +!*****************************************************************************! + + SUBROUTINE r_grib2(junit, gribflnm, hdate, & + grib_edition, debug_level, ireaderr) + + use grib_mod + use params + use table ! Included to define g2code + use gridinfo ! Included to define map% + + real, allocatable, dimension(:) :: hold_array + parameter(msk1=32000,msk2=4000) + character(len=1),allocatable,dimension(:) :: cgrib + integer :: listsec0(3) + integer :: listsec1(13) + integer year, month, day, hour, minute, second, fcst + character(len=*) :: gribflnm + character(len=*) :: hdate + character(len=8) :: pabbrev + character(len=20) :: labbrev + character(len=80) :: tabbrev + integer :: lskip, lgrib + integer :: junit, itot, icount, iseek + integer :: grib_edition + integer :: i, j, ireaderr, ith + integer :: currlen + logical :: unpack, expand + type(gribfield) :: gfld + real :: level + real :: scale_factor + integer :: iplvl, lvl2 + ! For subroutine output + integer , parameter :: maxlvl = 150 + real , dimension(maxlvl) :: plvl + integer :: nlvl + integer , dimension(maxlvl) :: level_array + logical :: verbose=.false. + logical :: first = .true. + integer :: debug_level + character(len=4) :: tmp4 + character(len=40) :: string + character(len=13) :: pstring = ',t50,":",i14)' + character(len=15) :: rstring = ',t50,":",f14.5)' + character(len=13) :: astring = ',t50,":",a14)' + character(len=15) :: estring = ',t50,":",e14.5)' + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! SET ARGUMENTS + + if (debug_level .gt. 50 ) then + unpack=.true. + else + unpack=.false. + endif + expand=.true. + hdate = '0000-00-00_00:00:00' + ierr=0 + itot=0 + icount=0 + iseek=0 + lskip=0 + lgrib=0 + currlen=0 + ith=1 + scale_factor = 1e6 +! do j = 1,10 +! write(6,'("j = ",i4," level1 = ",i8," level2 = ",i8)') j, & +! level1(j), level2(j) +! enddo + +!/* IOS Return Codes from BACIO: */ +!/* 0 All was well */ +!/* -1 Tried to open read only _and_ write only */ +!/* -2 Tried to read and write in the same call */ +!/* -3 Internal failure in name processing */ +!/* -4 Failure in opening file */ +!/* -5 Tried to read on a write-only file */ +!/* -6 Failed in read to find the 'start' location */ +!/* -7 Tried to write to a read only file */ +!/* -8 Failed in write to find the 'start' location */ +!/* -9 Error in close */ +!/* -10 Read or wrote fewer data than requested */ + +!if ireaderr =1 we have hit the end of a file. +!if ireaderr =2 we have hit the end of all the files. + + + if ( debug_level .gt. 100 ) verbose = .true. + if (verbose) write(6,*) 'begin r_grib2, flnm = ',gribflnm + ! Open a byte-addressable file. + CALL BAOPENR(junit,gribflnm,IOS) + first = .true. + if (verbose) write(6,*) 'back from baopenr, ios = ',ios + if (ios.eq.0) then + VERSION: do + + ! Search opend file for the next GRIB2 messege (record). + if (verbose) write(6,*) 'calling skgb' + call skgb(junit,iseek,msk1,lskip,lgrib) + + ! Check for EOF, or problem + if (lgrib.eq.0) then + exit + endif + + ! Check size, if needed allocate more memory. + if (lgrib.gt.currlen) then + if (allocated(cgrib)) deallocate(cgrib) + allocate(cgrib(lgrib),stat=is) + !print *,'G2 allocate(cgrib(lgrib)) status: ',IS + currlen=lgrib + endif + + ! Read a given number of bytes from unblocked file. + call baread(junit,lskip,lgrib,lengrib,cgrib) + + if (lgrib.ne.lengrib) then + print *,'G2 r_grib2: IO Error.',lgrib,".ne.",lengrib + stop 9 + endif + iseek=lskip+lgrib + icount=icount+1 + + if (verbose) PRINT *,'G2 GRIB MESSAGE ',icount,' starts at',lskip+1 + + ! Unpack GRIB2 field + call gb_info(cgrib,lengrib,listsec0,listsec1, & + numfields,numlocal,maxlocal,ierr) + if (ierr.ne.0) then + write(*,*) ' ERROR querying GRIB2 message = ',ierr + stop 10 + endif + itot=itot+numfields + + grib_edition=listsec0(2) + if (grib_edition.ne.2) then + exit VERSION + endif + + ! Additional print statments for developer. + if (verbose) then + print *,'G2 SECTION 0: ',(listsec0(j),j=1,3) + print *,'G2 SECTION 1: ',(listsec1(j),j=1,13) + print *,'G2 Contains ',numlocal,' Local Sections ', & + ' and ',numfields,' data fields.' + endif + + ! ---- + ! Once per file fill in date, model and projection values. + + if (first) then + first = .false. + + ! Build the 19-character date string, based on GRIB2 header date + ! and time information, including forecast time information: + + n=1 + call gf_getfld(cgrib,lengrib,n,unpack,expand,gfld,ierr) + + if (debug_level .gt. 100 ) then + write(6,*) 'gfld%version = ',gfld%version + if (gfld%discipline .eq. 0) then + string = 'Meteorological products' + else if (gfld%discipline .eq. 1) then + string = 'Hydrological products' + else if (gfld%discipline .eq. 2) then + string = 'Land Surface products' + else + string = 'See code table 0.0' + endif + write(6,*) 'Discipline = ',gfld%discipline,' ',string + write(6,*) 'gfld%idsect(1) = ',gfld%idsect(1) + write(6,*) 'gfld%idsect(2) = ',gfld%idsect(2) + write(6,*) 'gfld%idsect(3) = ',gfld%idsect(3) + write(6,*) 'gfld%idsect(4) = ',gfld%idsect(4) + write(6,*) 'gfld%idsect(5) = ',gfld%idsect(5) + write(6,*) 'gfld%idsect(6) = ',gfld%idsect(6) + write(6,*) 'gfld%idsect(7) = ',gfld%idsect(7) + write(6,*) 'gfld%idsect(8) = ',gfld%idsect(8) + write(6,*) 'gfld%idsect(9) = ',gfld%idsect(9) + write(6,*) 'gfld%idsect(10) = ',gfld%idsect(10) + write(6,*) 'gfld%idsect(11) = ',gfld%idsect(11) + write(6,*) 'gfld%idsect(12) = ',gfld%idsect(12) + write(6,*) 'gfld%idsect(13) = ',gfld%idsect(13) + + write(6,*) 'gfld%idsectlen = ',gfld%idsectlen + write(6,*) 'gfld%locallen = ',gfld%locallen + write(6,*) 'gfld%ifldnum = ',gfld%ifldnum + write(6,*) 'gfld%ngrdpts = ',gfld%ngrdpts + write(6,*) 'gfld%numoct_opt = ',gfld%numoct_opt + write(6,*) 'gfld%interp_opt = ',gfld%interp_opt + + write(6,*) 'gfld%griddef = ',gfld%griddef + if (gfld%igdtnum .eq. 0) then + string = 'Lat/Lon cylindrical equidistant' + else if (gfld%igdtnum .eq. 1) then + string = 'Rotated Lat/Lon' + else if (gfld%igdtnum .eq. 2) then + string = 'Stretched Lat/Lon' + else if (gfld%igdtnum .eq. 20) then + string = 'Polar Stereographic' + else if (gfld%igdtnum .eq. 30) then + string = 'Lambert Conformal' + else if (gfld%igdtnum .eq. 40) then + string = 'Gaussian Lat/Lon' + else if (gfld%igdtnum .eq. 50) then + string = 'Spherical harmonic coefficients' + else + string = 'see code table 3.1' + endif + write(6,*) 'Grid Template number = ',gfld%igdtnum,' ',string + write(6,*) 'gfld%igdtlen = ',gfld%igdtlen + do i = 1, gfld%igdtlen + write(6,*) 'gfld%igdtmpl(',i,') = ',gfld%igdtmpl(i) + enddo + + write(6,*) 'gfld%ipdtnum = ',gfld%ipdtnum + write(6,*) 'gfld%ipdtlen = ',gfld%ipdtlen + if ( gfld%ipdtnum .eq. 0 ) then + do i = 1, gfld%ipdtlen + write(6,*) 'gfld%ipdtmpl(',i,') = ',gfld%ipdtmpl(i) + enddo + endif + write(6,*) 'gfld%num_coord = ',gfld%num_coord + write(6,*) 'gfld%ndpts = ',gfld%ndpts + write(6,*) 'gfld%idrtnum = ',gfld%idrtnum + write(6,*) 'gfld%idrtlen = ',gfld%idrtlen + write(6,*) 'gfld%expanded = ',gfld%expanded + write(6,*) 'gfld%ibmap = ',gfld%ibmap + endif + + year =gfld%idsect(6) !(FOUR-DIGIT) YEAR OF THE DATA + month =gfld%idsect(7) ! MONTH OF THE DATA + day =gfld%idsect(8) ! DAY OF THE DATA + hour =gfld%idsect(9) ! HOUR OF THE DATA + minute=gfld%idsect(10) ! MINUTE OF THE DATA + second=gfld%idsect(11) ! SECOND OF THE DATA + + fcst = 0 + + ! Extract forecast time. + if ( gfld%ipdtmpl(8) .eq. 1 ) then ! time units are hours + fcst = gfld%ipdtmpl(9) + else if ( gfld%ipdtmpl(8) .eq. 0 ) then ! minutes + fcst = gfld%ipdtmpl(9) / 60. + else if ( gfld%ipdtmpl(8) .eq. 2 ) then ! days + fcst = gfld%ipdtmpl(9) * 24. + else + fcst = 999 + endif + + ! Compute valid time. + + if (verbose) then + print *, 'ymd',gfld%idsect(6),gfld%idsect(7),gfld%idsect(8) + print *, 'hhmm ',gfld%idsect(9),gfld%idsect(10) + endif + + call build_hdate(hdate,year,month,day,hour,minute,second) + if (verbose) print *, 'G2 hdate = ',hdate +! call geth_newdate(hdate,hdate,3600*fcst) ! no need for this in print +! print *, 'G2 hdate (fcst?) = ',hdate + + !-- + + ! Indicator of the source (center) of the data. + icenter = gfld%idsect(1) + + ! Indicator of model (or whatever) which generated the data. + iprocess = gfld%ipdtmpl(5) + + + if (icenter.eq.7) then +! Values obtained from http://www.nco.ncep.noaa.gov/pmb/docs/on388/tablea.html +! Note that NCEP recycles process numbers. This may cause labelling issues for +! ancient datasets. + if (iprocess.eq.81) then + map%source = 'NCEP GFS Analysis' + elseif (iprocess.eq.82) then + map%source = 'NCEP GFS GDAS/FNL' + elseif (iprocess.eq.83) then + map%source = 'NCEP HRRR Model' + elseif (iprocess.eq.84) then + map%source = 'NCEP MESO NAM Model' + elseif (iprocess.eq.89) then + map%source = 'NCEP NMM ' + elseif (iprocess.eq.96) then + map%source = 'NCEP GFS Model' + elseif (iprocess.eq.86 .or. iprocess.eq.100) then + map%source = 'NCEP RUC Model' ! 60 km + elseif (iprocess.eq.101) then + map%source = 'NCEP RUC Model' ! 40 km + elseif (iprocess.eq.105) then + if (year .gt. 2011) then + map%source = 'NCEP RAP Model' + else + map%source = 'NCEP RUC Model' ! 20 km + endif + elseif (iprocess.eq.107) then + map%source = 'NCEP GEFS' + elseif (iprocess.eq.109) then + map%source = 'NCEP RTMA' + elseif (iprocess.eq.140) then + map%source = 'NCEP NARR' + elseif (iprocess.eq.44) then + map%source = 'NCEP SST Analysis' + elseif (iprocess.eq.70) then + map%source = 'GFDL Hurricane Model' + elseif (iprocess.eq.80) then + map%source = 'NCEP GFS Ensemble' + elseif (iprocess.eq.107) then ! renumbered as of 23 Feb 2010 + map%source = 'NCEP GFS Ensemble' + elseif (iprocess.eq.111) then + map%source = 'NCEP NMMB Model' + elseif (iprocess.eq.112) then + map%source = 'NCEP WRF-NMM Model' + elseif (iprocess.eq.116) then + map%source = 'NCEP WRF-ARW Model' + elseif (iprocess.eq.129) then + map%source = 'NCEP GODAS' + elseif (iprocess.eq.197) then + map%source = 'NCEP CDAS CFSV2' + elseif (iprocess.eq.25) then + map%source = 'NCEP SNOW COVER ANALYSIS' + else + map%source = 'unknown model from NCEP' + write (6,*) 'unknown NCEP model, iprocess = ',iprocess + end if + else if (icenter .eq. 57) then + if (iprocess .eq. 87) then + map%source = 'AFWA AGRMET' + else + map%source = 'AFWA' + endif + else if (icenter .eq. 58) then + map%source = 'US Navy FNOC' + else if (icenter .eq. 98) then + map%source = 'ECMWF' + else if (icenter .eq. 34) then + map%source = 'JMA' + else if (icenter .eq. 74 .or. icenter .eq. 75 ) then + map%source = 'UKMO' + else + map%source = 'unknown model and orig center' + end if + write (6,*) ' ',map%source + + if (debug_level .le. 50) then + write(6,*) '---------------------------------------------------------------------------------------' + write(6,*) ' rec Prod Cat Param Lvl Lvl Lvl Prod Name Time Fcst' + write(6,*) ' num Disc num code one two Templ hour' + write(6,*) '---------------------------------------------------------------------------------------' + endif + + + !-- + + ! Store information about the grid on which the data is. + ! This stuff gets stored in the MAP variable, as defined in + ! module GRIDINFO. + + map%startloc = 'SWCORNER' + + if (gfld%igdtnum.eq.0) then ! Lat/Lon grid aka Cylindrical Equidistant + map%igrid = 0 + map%nx = gfld%igdtmpl(8) + map%ny = gfld%igdtmpl(9) + map%dx = gfld%igdtmpl(17) + map%dy = gfld%igdtmpl(18) + map%lat1 = gfld%igdtmpl(12) + map%lon1 = gfld%igdtmpl(13) + + if ((gfld%igdtmpl(10) .eq. 0).OR. & + (gfld%igdtmpl(10) .eq. 255)) THEN + ! Scale lat/lon values to 0-180, default range is 1e6. + map%lat1 = map%lat1/scale_factor + map%lon1 = map%lon1/scale_factor + ! Scale dx/dy values to degrees, default range is 1e6. + map%dx = map%dx/scale_factor + map%dy = map%dy/scale_factor + else + ! Basic angle and subdivisions are non-zero (not tested) + map%lat1 = map%lat1 * & + (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + map%lon1 = map%lon1 * & + (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + map%dx = map%dx * & + (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + map%dy = map%dy * & + (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + endif + + elseif (gfld%igdtnum.eq.30) then ! Lambert Conformal Grid + map%igrid = 3 + map%nx = gfld%igdtmpl(8) + map%ny = gfld%igdtmpl(9) + map%lov = gfld%igdtmpl(14) + map%truelat1 = gfld%igdtmpl(19) + map%truelat2 = gfld%igdtmpl(20) + map%dx = gfld%igdtmpl(15) + map%dy = gfld%igdtmpl(16) + map%lat1 = gfld%igdtmpl(10) + map%lon1 = gfld%igdtmpl(11) + + elseif(gfld%igdtnum.eq.40) then ! Gaussian Grid (we will call it lat/lon) + map%igrid = 0 + map%nx = gfld%igdtmpl(8) + map%ny = gfld%igdtmpl(9) + map%dx = gfld%igdtmpl(17) + map%dy = gfld%igdtmpl(18) ! ?not in Grid Definition Template 3.40 doc + map%lat1 = gfld%igdtmpl(12) + map%lon1 = gfld%igdtmpl(13) + + ! Scale dx/dy values to degrees, default range is 1e6. + if (map%dx.gt.10000) then + map%dx = map%dx/scale_factor + endif + if (map%dy.gt.10000) then + map%dy = (map%dy/scale_factor)*(-1) + endif + + ! Scale lat/lon values to 0-180, default range is 1e6. + if (map%lat1.ge.scale_factor) then + map%lat1 = map%lat1/scale_factor + endif + if (map%lon1.ge.scale_factor) then + map%lon1 = map%lon1/scale_factor + endif + print *,'Gaussian Grid: Dx,Dy,lat,lon',map%dx,map%dy, & + map%lat1,map%lon1 + + elseif (gfld%igdtnum.eq.20) then ! Polar-Stereographic Grid. + map%igrid = 5 + map%nx = gfld%igdtmpl(8) + map%ny = gfld%igdtmpl(9) + !map%lov = gfld%igdtmpl(x) ! ?not in Grid Definition Template 3.20 doc + map%truelat1 = 60. + map%truelat2 = 91. + !map%dx = gfld%igdtmpl(x) + !map%dy = gfld%igdtmpl(x) + map%lat1 = gfld%igdtmpl(10) + map%lon1 = gfld%igdtmpl(11) + + else + print*, 'GRIB2 Unknown Projection: ',gfld%igdtnum + print*, 'see Code Table 3.1: Grid Definition Template No' + endif + + call gf_free(gfld) + endif + + ! ---- + + ! Continue to unpack GRIB2 field. + if (debug_level .gt. 100) write(6,*) 'numfields = ',numfields + NUM_FIELDS: do n = 1, numfields +! e.g. U and V would =2, otherwise its usually =1 + call gf_getfld(cgrib,lengrib,n,unpack,expand,gfld,ierr) + if (ierr.ne.0) then + write(*,*) ' ERROR extracting field gf_getfld = ',ierr + cycle + endif + +! ------------------------------------ + ! Additional print information for developer. + pabbrev=param_get_abbrev(gfld%discipline,gfld%ipdtmpl(1), & + gfld%ipdtmpl(2)) + if (debug_level .gt. 50 ) then + print * +! print *,'G2 FIELD ',n + if (n==1) then + write(*,'(/,"GRIB2 SECTION 0 - INDICATOR SECTION:")') + write(*,'(5x,"Discipline"'//pstring) gfld%discipline + write(*,'(5x,"GRIB Edition Number"'//pstring) gfld%version + write(*,'(5x,"GRIB length"'//pstring) lengrib + write(*,'(/,"GRIB2 SECTION 1 - IDENTIFICATION SECTION:")') + write(*,'(5x,"Length of Section"'//pstring) gfld%idsectlen + write(*,'(5x,"Originating Center ID"'//pstring) & + gfld%idsect(1) + write(*,'(5x,"Subcenter ID"'//pstring) gfld%idsect(2) + write(*,'(5x,"GRIB Master Table Version"'//pstring) & + gfld%idsect(3) + write(*,'(5x,"GRIB Local Table Version"'//pstring) & + gfld%idsect(4) + write(*,'(5x,"Significance of Reference Time"'//pstring) & + gfld%idsect(5) + write(*,'(5x,"Year"'//pstring) gfld%idsect(6) + write(*,'(5x,"Month"'//pstring) gfld%idsect(7) + write(*,'(5x,"Day"'//pstring) gfld%idsect(8) + write(*,'(5x,"Hour"'//pstring) gfld%idsect(9) + write(*,'(5x,"Minute"'//pstring) gfld%idsect(10) + write(*,'(5x,"Second"'//pstring) gfld%idsect(11) + write(*,'(5x,"Production Status of data"'//pstring) & + gfld%idsect(12) + write(*,'(5x,"Type of processed data"'//pstring) & + gfld%idsect(13) +! print *,'G2 SECTION 1: ',(gfld%idsect(j),j=1,gfld%idsectlen) + endif + write(*,'(/,"GRIB2 SECTION 2 - LOCAL SECTION:")') + write(*,'(5x,"Length of Section 2"'//pstring) gfld%locallen + if ( associated(gfld%local).AND.gfld%locallen.gt.0 ) then + do j = 1, gfld%locallen + write(*,'(5x,"Local value "'//astring) gfld%local(j) + enddo +! print *,'G2 SECTION 2: ',(gfld%local(j),j=1,gfld%locallen) + endif + write(*,'(/,"GRIB2 SECTION 3 - GRID DEFINITION SECTION:")') +! write(*,'(5x,"Length of Section 3"'//pstring) gfld%unknown + write(*,'(5x,"Source of grid definition"'& + //pstring) gfld%griddef + write(*,'(5x,"Number of grid points"'//pstring) gfld%ngrdpts + write(*,'(5x,"Number of octets for addnl points"'//pstring) & + gfld%numoct_opt + write(*,'(5x,"Interpretation list"'//pstring) & + gfld%interp_opt + write(*,'(5x,"Grid Definition Template Number"'//pstring) & + gfld%igdtnum + if (gfld%igdtnum .eq. 0 .or. gfld%igdtnum .eq. 1 .or. & + gfld%igdtnum .eq. 2 .or. gfld%igdtnum .eq. 3 ) then + if (gfld%igdtnum .eq. 0 ) then + write(*,'(5x,"Lat/Lon or Cylindrical Equidistant Grid")') + else if (gfld%igdtnum .eq. 1 ) then + write(*,'(5x,"Rotated Lat/Lon or Cylind. Equi. Grid")') + else if (gfld%igdtnum .eq. 2 ) then + write(*,'(5x,"Stretched Lat/Lon or Cylind. Equi. Grid")') + else if (gfld%igdtnum .eq. 3 ) then + write(*,'(5x,"Stretched and Rotated Lat/Lon Grid")') + endif + write(*,'(10x,"Shape of the Earth"'//pstring) & + gfld%igdtmpl(1) + write(*,'(10x,"Scale factor of spher. Earth"'//pstring) & + gfld%igdtmpl(2) + write(*,'(10x,"Scaled value of spher. Earth"'//pstring) & + gfld%igdtmpl(3) + write(*,'(10x,"Scale factor of major axis"'//pstring) & + gfld%igdtmpl(4) + write(*,'(10x,"Scaled value of major axis"'//pstring) & + gfld%igdtmpl(5) + write(*,'(10x,"Scale factor of minor axis"'//pstring) & + gfld%igdtmpl(6) + write(*,'(10x,"Scaled value of minor axis"'//pstring) & + gfld%igdtmpl(7) + write(*,'(10x,"Ni - points along a parallel"'//pstring) & + gfld%igdtmpl(8) + write(*,'(10x,"Nj - points along a meridian"'//pstring) & + gfld%igdtmpl(9) + write(*,'(10x,"Basic angle of initial domain"'//pstring)& + gfld%igdtmpl(10) + write(*,'(10x,"Subdivisions of basic angle"'//pstring) & + gfld%igdtmpl(11) + write(*,'(10x,"La1"'//pstring) gfld%igdtmpl(12) + write(*,'(10x,"Lo1"'//pstring) gfld%igdtmpl(13) + write(*,'(10x,"Resolution and Component",t50,":",B14.8)')& + gfld%igdtmpl(14) + write(*,'(10x,"La2"'//pstring) gfld%igdtmpl(15) + write(*,'(10x,"Lo2"'//pstring) gfld%igdtmpl(16) + write(*,'(10x,"Di - i-dir increment"'//pstring) & + gfld%igdtmpl(17) + write(*,'(10x,"Dj - j-dir increment"'//pstring) & + gfld%igdtmpl(18) + write(*,'(10x,"Scanning mode"'//pstring) & + gfld%igdtmpl(19) + if (gfld%igdtnum .eq. 1) then + write(*,'(10x,"Lat of southern pole of project"'//pstring)& + gfld%igdtmpl(20) + write(*,'(10x,"Lon of southern pole of project"'//pstring)& + gfld%igdtmpl(21) + write(*,'(10x,"Angle of rotation of projection"'//pstring)& + gfld%igdtmpl(22) + else if (gfld%igdtnum .eq. 2) then + write(*,'(10x,"Lat of the pole of stretching "'//pstring)& + gfld%igdtmpl(20) + write(*,'(10x,"Lon of the pole of stretching "'//pstring)& + gfld%igdtmpl(21) + write(*,'(10x,"Stretching factor"'//pstring) & + gfld%igdtmpl(22) + else if (gfld%igdtnum .eq. 3) then + write(*,'(10x,"Lat of southern pole of project"'//pstring)& + gfld%igdtmpl(20) + write(*,'(10x,"Lon of southern pole of project"'//pstring)& + gfld%igdtmpl(21) + write(*,'(10x,"Angle of rotation of projection"'//pstring)& + gfld%igdtmpl(22) + write(*,'(10x,"Lat of the pole of stretching "'//pstring)& + gfld%igdtmpl(23) + write(*,'(10x,"Lon of the pole of stretching "'//pstring)& + gfld%igdtmpl(24) + write(*,'(10x,"Stretching factor"'//pstring) & + gfld%igdtmpl(25) + endif + else if (gfld%igdtnum .eq. 10) then + write(*,'(5x,"Mercator Grid")') + else if (gfld%igdtnum .eq. 20 .or. gfld%igdtnum .eq. 30) then + if (gfld%igdtnum .eq. 20) then + write(*,'(5x,"Polar Stereographic Grid")') + else if (gfld%igdtnum .eq. 30) then + write(*,'(5x,"Lambert Conformal Grid")') + endif + write(*,'(10x,"Shape of the Earth"'//pstring) & + gfld%igdtmpl(1) + write(*,'(10x,"Scale factor of spher. Earth"'//pstring) & + gfld%igdtmpl(2) + write(*,'(10x,"Scaled value of spher. Earth"'//pstring) & + gfld%igdtmpl(3) + write(*,'(10x,"Scale factor of major axis"'//pstring) & + gfld%igdtmpl(4) + write(*,'(10x,"Scaled value of major axis"'//pstring) & + gfld%igdtmpl(5) + write(*,'(10x,"Scale factor of minor axis"'//pstring) & + gfld%igdtmpl(6) + write(*,'(10x,"Scaled value of minor axis"'//pstring) & + gfld%igdtmpl(7) + write(*,'(10x,"Nx"'//pstring) gfld%igdtmpl(8) + write(*,'(10x,"Ny"'//pstring) gfld%igdtmpl(9) + write(*,'(10x,"La1"'//pstring) gfld%igdtmpl(10) + write(*,'(10x,"Lo1"'//pstring) gfld%igdtmpl(11) + write(*,'(10x,"Resolution and Component",t50,":",B14.8)')& + gfld%igdtmpl(12) + write(*,'(10x,"LaD"'//pstring) gfld%igdtmpl(13) + write(*,'(10x,"LoV"'//pstring) gfld%igdtmpl(14) + write(*,'(10x,"Dx"'//pstring) gfld%igdtmpl(15) + write(*,'(10x,"Dy"'//pstring) gfld%igdtmpl(16) + write(*,'(10x,"Projection Center Flag"'//pstring) & + gfld%igdtmpl(17) + write(*,'(10x,"Scanning mode"'//pstring) & + gfld%igdtmpl(18) + if (gfld%igdtnum .eq. 30) then + write(*,'(10x,"Latin 1 "'//pstring) & + gfld%igdtmpl(19) + write(*,'(10x,"Latin 2 "'//pstring) & + gfld%igdtmpl(20) + write(*,'(10x,"Lat of southern pole of project"'//pstring)& + gfld%igdtmpl(21) + write(*,'(10x,"Lon of southern pole of project"'//pstring)& + gfld%igdtmpl(22) + endif + else if (gfld%igdtnum .eq. 40 .or. gfld%igdtnum .eq. 41) then + if (gfld%igdtnum .eq. 40) then + write(*,'(5x,"Gaussian Lat/Lon Grid")') + else if (gfld%igdtnum .eq. 41) then + write(*,'(5x,"Rotated Gaussian Lat/Lon Grid")') + else if (gfld%igdtnum .eq. 42) then + write(*,'(5x,"Stretched Gaussian Lat/Lon Grid")') + else if (gfld%igdtnum .eq. 43) then + write(*,'(5x,"Stretched and Rotated Gaussian Lat/Lon ")') + endif + else + do j = 1, gfld%igdtlen + write(*,'(5x,"Grid Definition Template entry "'//pstring) & + gfld%igdtmpl(j) + enddo + endif +! print *,'G2 SECTION 3: ',gfld%griddef,gfld%ngrdpts, & +! gfld%numoct_opt,gfld%interp_opt, & +! gfld%igdtnum +! print *,'G2 GRID TEMPLATE 3.',gfld%igdtnum,': ', & +! (gfld%igdtmpl(j),j=1,gfld%igdtlen) + if ( gfld%num_opt .eq. 0 ) then +! print *,'G2 NO Section 3 List Defining No. of Data Points.' + else + print *,'G2 Section 3 Optional List: ', & + (gfld%list_opt(j),j=1,gfld%num_opt) + endif + write(*,'(/,"GRIB2 SECTION 4 - PRODUCT DEFINITION SECTION:")') +! write(*,'(5x,"Length of Section 4"'//pstring) gfld%unknown + write(*,'(5x,"Product Definition Template Number"'//pstring)& + gfld%ipdtnum + do j = 1, gfld%ipdtlen + write(tmp4,'(i4)') j + string = '(5x,"Template Entry '//tmp4 // '"' + write(*,string//pstring) gfld%ipdtmpl(j) + enddo +! print *,'G2 PRODUCT TEMPLATE 4.',gfld%ipdtnum,': ', & +! (gfld%ipdtmpl(j),j=1,gfld%ipdtlen) + + !call prlevel(gfld%ipdtnum,gfld%ipdtmpl,labbrev) + !call prvtime(gfld%ipdtnum,gfld%ipdtmpl,listsec1,tabbrev) + write(*,'(5x,"Product Abbreviated Name",t50,":",a14)')& + pabbrev +! print *,'G2 TEXT: ',pabbrev,trim(labbrev)," ",trim(tabbrev) + + if ( gfld%num_coord .eq. 0 ) then +! print *,'G2 NO Optional Vertical Coordinate List.' + else + print *,'G2 Section 4 Optional Coordinates: ', & + (gfld%coord_list(j),j=1,gfld%num_coord) + endif +! if ( gfld%ibmap .ne. 255 ) then +! print *,'G2 Num. of Data Points = ',gfld%ndpts, & +! ' with BIT-MAP ',gfld%ibmap +! else +! print *,'G2 Num. of Data Points = ',gfld%ndpts, & +! ' NO BIT-MAP ' +! endif + write(*,'(/,"GRIB2 SECTION 5 - DATA REPRESENTATION SECTION:")') + write(*,'(5x,"Data Representation Template Number"'//pstring)& + gfld%idrtnum + do j = 1, gfld%idrtlen + write(tmp4,'(i4)') j + string = '(5x,"Template Entry '//tmp4 // '"' + write(*,string//pstring) gfld%idrtmpl(j) + enddo +! print *,'G2 DRS TEMPLATE 5.',gfld%idrtnum,': ', & +! (gfld%idrtmpl(j),j=1,gfld%idrtlen) + +! if ( gfld%ipdtnum .eq. 0 ) then +! if (gfld%ipdtmpl(1) .eq. 0 ) then +! write(6,*) 'Temperature' +! else if (gfld%ipdtmpl(1) .eq. 1 ) then +! write(6,*) 'Moisture' +! else if (gfld%ipdtmpl(1) .eq. 2 ) then +! write(6,*) 'Momentum' +! else if (gfld%ipdtmpl(1) .eq. 3 ) then +! write(6,*) 'Mass' +! endif +! endif + + write(*,'(/,"GRIB2 SECTION 6 - BIT-MAP SECTION:")') + write(*,'(5x,"Bit-map indicator"'//pstring) & + gfld%ibmap + + fldmax=gfld%fld(1) + fldmin=gfld%fld(1) + sum=gfld%fld(1) + do j=2,gfld%ndpts + if (gfld%fld(j).gt.fldmax) fldmax=gfld%fld(j) + if (gfld%fld(j).lt.fldmin) fldmin=gfld%fld(j) + sum=sum+gfld%fld(j) + enddo ! gfld%ndpts + + write(*,'(/,"GRIB2 SECTION 7 - DATA SECTION:")') + + if ( fldmax .lt. -1.e10 ) then + write(*,'(5x,"Minimum Data Value "'//estring)& + fldmin + else + write(*,'(5x,"Minimum Data Value "'//rstring)& + fldmin + endif + if ( fldmax .gt. 1.e10 ) then + write(*,'(5x,"Maximum Data Value "'//estring)& + fldmax + else + write(*,'(5x,"Maximum Data Value "'//rstring)& + fldmax + endif +! print *,'G2 Data Values:' +! write(*,fmt='("G2 MIN=",f21.8," AVE=",f21.8, & +! " MAX=",f21.8)') fldmin,sum/gfld%ndpts,fldmax + if (debug_level .gt. 100 ) then + print*, 'gfld%fld = ',gfld%fld +! do j=1,gfld%ndpts +! write(*,*) j, gfld%fld(j) +! enddo + endif + endif ! Additional Print information +! ------------------------------------ + if ( debug_level .le. 50) then + if(gfld%ipdtmpl(10).eq.100) then ! pressure level + level=gfld%ipdtmpl(12) * & + (10. ** (-1. * gfld%ipdtmpl(11))) + else if(gfld%ipdtmpl(10).eq.101 .or.& ! sea level, sfc, or trop + gfld%ipdtmpl(10).eq.1 .or. gfld%ipdtmpl(10).eq.7) then + level = 0 + else if(gfld%ipdtmpl(10).eq.106) then ! below ground sfc is in cm in Vtable + level= 100. * gfld%ipdtmpl(12)*(10.**(-1.*gfld%ipdtmpl(11))) + else + level=gfld%ipdtmpl(12) * 10.** (-1.*gfld%ipdtmpl(11)) + endif + if (gfld%ipdtmpl(13) .eq. 255) then + lvl2 = 0 + else if(gfld%ipdtmpl(10).eq.106) then ! below ground sfc is in cm in Vtable + lvl2 = 100. * gfld%ipdtmpl(15) * 10.** (-1.*gfld%ipdtmpl(14)) + else + lvl2 = gfld%ipdtmpl(15) * 10.** (-1.*gfld%ipdtmpl(14)) + endif +! Account for multiple forecast hours in one file + if (gfld%ipdtnum.eq.0 .or. gfld%ipdtnum.eq.1 .or. gfld%ipdtnum.eq. 8) then + ! Product Definition Template 4.0, 4.1, 4.8 + ! Extract forecast time. + if ( gfld%ipdtmpl(8) .eq. 1 ) then ! time units are hours + fcst = gfld%ipdtmpl(9) + else if ( gfld%ipdtmpl(8) .eq. 0 ) then ! minutes + fcst = gfld%ipdtmpl(9) / 60. + else if ( gfld%ipdtmpl(8) .eq. 2 ) then ! days + fcst = gfld%ipdtmpl(9) * 24. + else + fcst = 999 + endif + endif + + ! Non-standard Product Definition Templates need to be reported + string = ' ' + if ( gfld%ipdtnum .eq. 8 ) then + string = ' PDT4.8' + else if ( gfld%ipdtnum .eq. 1 ) then + string = ' PDT4.1' + endif + write(6,987) itot,gfld%discipline,gfld%ipdtmpl(1), & + gfld%ipdtmpl(2),gfld%ipdtmpl(10),int(level),& + lvl2,gfld%ipdtnum,pabbrev,hdate,fcst,string + 987 format(2i4,i5,i4,i8,i8,i8,i8,3x,a10,a20,i5.2,a10) + + endif + + ! Deallocate arrays decoding GRIB2 record. + call gf_free(gfld) + + enddo NUM_FIELDS + + enddo VERSION ! skgb + + if (debug_level .gt. 50) & + print *, 'G2 total number of fields found = ',itot + + CALL BACLOSE(junit,IOS) + + ireaderr=1 + else + print *,'open status failed because',ios + hdate = '9999-99-99_99:99:99' + ireaderr=2 + endif ! ireaderr check + + END subroutine r_grib2 + +!*****************************************************************************! +! Subroutine edition_num ! +! ! +! Purpose: ! +! Read one record from the input GRIB2 file. Based on the information in ! +! the GRIB2 header and the user-defined Vtable, decide whether the field in! +! the GRIB2 record is one to process or to skip. If the field is one we ! +! want to keep, extract the data from the GRIB2 record, and pass the data ! +! back to the calling routine. ! +! ! +! Argument list: ! +! Input: ! +! JUNIT : "Unit Number" to open and read from. Not really a Fortran ! +! unit number, since we do not do Fortran I/O for the GRIB2 ! +! files. Nor is it a UNIX File Descriptor returned from a C ! +! OPEN statement. It is really just an array index to the ! +! array (IUARR) where the UNIX File Descriptor values are ! +! stored. ! +! GRIB2FILE: File name to open, if it is not already open. ! +! ! +! Output: ! +! GRIB_EDITION: Set to 1 for GRIB and set to 2 for GRIB2 ! +! IERR : Error flag: 0 - no error on read from GRIB2 file. ! +! 1 - Hit the end of the GRIB2 file. ! +! 2 - The file GRIBFLNM we tried to open does ! +! not exist. ! +! Author: Paula McCaslin ! +! NOAA/FSL ! +! Sept 2004 ! +!*****************************************************************************! + + SUBROUTINE edition_num(junit, gribflnm, grib_edition, ireaderr) + + use grib_mod + use params + + parameter(msk1=32000,msk2=4000) + character(len=1),allocatable,dimension(:) :: cgrib + integer :: listsec0(3) + integer :: listsec1(13) + character(len=*) :: gribflnm + integer :: lskip, lgrib + integer :: junit + integer :: grib_edition + integer :: i, j, ireaderr + integer :: currlen + + character(len=4) :: ctemp + character(len=4),parameter :: grib='GRIB',c7777='7777' + +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! SET ARGUMENTS + + itot=0 + icount=0 + iseek=0 + lskip=0 + lgrib=0 + currlen=0 + +!/* IOS Return Codes from BACIO: */ +!/* 0 All was well */ +!/* -1 Tried to open read only _and_ write only */ +!/* -2 Tried to read and write in the same call */ +!/* -3 Internal failure in name processing */ +!/* -4 Failure in opening file */ +!/* -5 Tried to read on a write-only file */ +!/* -6 Failed in read to find the 'start' location */ +!/* -7 Tried to write to a read only file */ +!/* -8 Failed in write to find the 'start' location */ +!/* -9 Error in close */ +!/* -10 Read or wrote fewer data than requested */ + +!if ireaderr =1 we have hit the end of a file. +!if ireaderr =2 we have hit the end of all the files. +!if ireaderr =3 beginning characters 'GRIB' not found + +! write(6,*) 'junit = ',junit,' gribflnm = ',gribflnm + + ! Open a byte-addressable file. + CALL BAOPENR(junit,gribflnm,IOS) ! from w3lib +! write(6,*) 'ios = ',ios + if (ios.eq.0) then + + ! Search opend file for the next GRIB2 messege (record). + call skgb(junit,iseek,msk1,lskip,lgrib) + + ! Check for EOF, or problem + if (lgrib.eq.0) then + write(*,'("\n\tThere is a problem with the input file.")') + write(*,'("\tPerhaps it is not a Grib2 file?\n")') + STOP "Grib2 file or date problem, stopping in edition_num." + endif + + ! Check size, if needed allocate more memory. + if (lgrib.gt.currlen) then + if (allocated(cgrib)) deallocate(cgrib) + allocate(cgrib(lgrib),stat=is) + currlen=lgrib + endif + + ! Read a given number of bytes from unblocked file. + call baread(junit,lskip,lgrib,lengrib,cgrib) + + ! Check for beginning of GRIB message in the first 100 bytes + istart=0 + do j=1,100 + ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3) + if (ctemp.eq.grib ) then + istart=j + exit + endif + enddo + if (istart.eq.0) then + ireaderr=3 + print*, "The beginning 4 characters >GRIB< were not found." + endif + + ! Unpack Section 0 - Indicator Section to extract GRIB edition field + iofst=8*(istart+5) + call gbyte(cgrib,discipline,iofst,8) ! Discipline + iofst=iofst+8 + call gbyte(cgrib,grib_edition,iofst,8) ! GRIB edition number + + print *, 'ungrib - grib edition num', grib_edition + CALL BACLOSE(junit,IOS) + ireaderr=1 + else if (ios .eq. -4) then + print *,'edition_num: unable to open ',gribflnm + stop 'edition_num' + else + print *,'edition_num: open status failed because',ios,gribflnm + ireaderr=2 + endif ! ireaderr check + + END subroutine edition_num +subroutine parse_args(err, a1, h1, i1, l1, a2, h2, i2, l2, a3, h3, i3, l3, & + hlast) + integer :: err + character(len=*) , optional :: a1, a2, a3 + character(len=*), optional :: h1, h2, h3 + integer , optional :: i1, i2, i3 + logical, optional :: l1, l2, l3 + character(len=*), optional :: hlast + + character(len=100) :: hold + integer :: ioff = 0 + + if (present(hlast)) then + ioff = -1 + endif + + err = 0 + + narg = iargc() + numarg = narg + ioff + + i = 1 + LOOP : do while ( i <= numarg) + + ierr = 1 + if (present(i1)) then + call checkiarg(i, a1, i1, ierr) + elseif (present(h1)) then + call checkharg(i, a1, h1, ierr) + elseif (present(l1)) then + call checklarg(i, a1, l1, ierr) + endif + if (ierr.eq.0) cycle LOOP + + if (present(i2)) then + call checkiarg(i, a2, i2, ierr) + elseif (present(h2)) then + call checkharg(i, a2, h2, ierr) + elseif (present(l2)) then + call checklarg(i, a2, l2, ierr) + endif + if (ierr.eq.0) cycle LOOP + + if (present(i3)) then + call checkiarg(i, a3, i3, ierr) + elseif (present(h3)) then + call checkharg(i, a3, h3, ierr) + elseif (present(l3)) then + call checklarg(i, a3, l3, ierr) + endif + if (ierr.eq.0) cycle LOOP + + err = 1 + call getarg(1, hold) + write(*, '("arg = ", A)') trim(hold) + + exit LOOP + + enddo LOOP + + if (present(hlast)) then + if (narg.eq.0) then + err = 1 + else + call getarg(narg, hlast) + endif + endif + +contains + subroutine checkiarg(c, a, i, ierr) + integer :: c + character(len=*) :: a + integer :: i + + character(len=100) :: hold + ierr = 1 + + call getarg(c, hold) + + if ('-'//a.eq.trim(hold)) then + c = c + 1 + call getarg(c, hold) + read(hold, *) i + c = c + 1 + ierr = 0 + elseif ('-'//a .eq. hold(1:len_trim(a)+1)) then + hold = hold(len_trim(a)+2: len(hold)) + read(hold, *) i + c = c + 1 + ierr = 0 + endif + + end subroutine checkiarg + subroutine checkharg(c, a, h, ierr) + integer :: c + character(len=*) :: a + character(len=*) :: h + + character(len=100) :: hold + ierr = 1 + + call getarg(c, hold) + + if ('-'//a.eq.trim(hold)) then + c = c + 1 + call getarg(c, hold) + h = trim(hold) + c = c + 1 + ierr = 0 + elseif ('-'//a .eq. hold(1:len_trim(a)+1)) then + hold = hold(len_trim(a)+2: len(hold)) + h = trim(hold) + c = c + 1 + ierr = 0 + endif + + end subroutine checkharg + + subroutine checklarg(c, a, l, ierr) + integer :: c + character(len=*) :: a + logical :: l + + character(len=100) :: hold + ierr = 1 + + call getarg(c, hold) + if ('-'//a.eq.trim(hold)) then + l = .TRUE. + c = c + 1 + ierr = 0 + endif + + end subroutine checklarg + +end subroutine parse_args + diff --git a/WPS/ungrib/src/gbytesys.F b/WPS/ungrib/src/gbytesys.F new file mode 100644 index 00000000..0f34bfe6 --- /dev/null +++ b/WPS/ungrib/src/gbytesys.F @@ -0,0 +1,493 @@ +!----------------------------------------------------------------------- +! Choice of computers +!----------------------------------------------------------------------- +! +! CRAY XMP,YMP/UNICOS (#define CRAY) +! VAX/VMS (#define VAX) +! Stardent 1500/3000/UNIX (#define STARDENT) +! IBM RS/6000-AIX (#define IBM) +! SUN Sparcstation (#define SUN) +! SGI Silicon Graphics (#define SGI) +! HP 7xx (#define HP) +! DEC ALPHA (#define ALPHA) +! +------------------------------------------------------------------+ +! _ SYSTEM DEPENDENT ROUTINES _ +! _ _ +! _ This module contains short utility routines that are not _ +! _ of the FORTRAN 77 standard and may differ from system to system. _ +! _ These include bit manipulation, I/O, JCL calls, and vector _ +! _ functions. _ +! +------------------------------------------------------------------+ +! +------------------------------------------------------------------+ +! +! DATA SET UTILITY AT LEVEL 003 AS OF 02/25/92 + SUBROUTINE GBYTE_G1(IN,IOUT,ISKIP,NBYTE) +! +! THIS PROGRAM WRITTEN BY..... +! DR. ROBERT C. GAMMILL, CONSULTANT +! NATIONAL CENTER FOR ATMOSPHERIC RESEARCH +! MAY 1972 +! +! CHANGES FOR CRAY Y-MP8/832 +! CRAY CFT77 FORTRAN +! JULY 1992, RUSSELL E. JONES +! NATIONAL WEATHER SERVICE +! +! THIS IS THE FORTRAN VERSION OF GBYTE +! + INTEGER IN(*) + INTEGER IOUT +#if defined (CRAY) || defined (BIT64) + + INTEGER MASKS(64) +! + DATA NBITSW/64/ +! +! MASKS TABLE PUT IN DECIMAL SO IT WILL COMPILE ON ANY 64 BIT +! COMPUTER +! + DATA MASKS / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, & + 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287, & + 1048575, 2097151, 4194303, 8388607, 16777215, 33554431, & + 67108863, 134217727, 268435455, 536870911, 1073741823, & + 2147483647, 4294967295, 8589934591, 17179869183, & + 34359738367, 68719476735, 137438953471, 274877906943, & + 549755813887, 1099511627775, 2199023255551, 4398046511103, & + 8796093022207, 17592186044415, 35184372088831, & + 70368744177663, 140737488355327, 281474976710655, & + 562949953421311, 1125899906842623, 2251799813685247, & + 4503599627370495, 9007199254740991, 18014398509481983, & + 36028797018963967, 72057594037927935, 144115188075855871, & + 288230376151711743, 576460752303423487, 1152921504606846975, & + 2305843009213693951, 4611686018427387903, 9223372036854775807, & + -1/ +#else + INTEGER MASKS(32) +! + DATA NBITSW/32/ +! +! MASKS TABLE PUT IN DECIMAL SO IT WILL COMPILE ON ANY 32 BIT +! COMPUTER +! + DATA MASKS / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, & + 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287, & + 1048575, 2097151, 4194303, 8388607, 16777215, 33554431, & + 67108863, 134217727, 268435455, 536870911, 1073741823, & + 2147483647, -1/ +#endif +! +! NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW +! + ICON = NBITSW - NBYTE + IF (ICON.LT.0) RETURN + MASK = MASKS(NBYTE) +! +! INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IN' THE NEXT BYTE APPEARS. +! + INDEX = ISKIP / NBITSW +! +! II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD. +! + II = MOD(ISKIP,NBITSW) +! +! MOVER SPECIFIES HOW FAR TO THE RIGHT NBYTE MUST BE MOVED IN ORDER +! TO BE RIGHT ADJUSTED. +! + MOVER = ICON - II +! + IF (MOVER.GT.0) THEN + IOUT = IAND(ISHFT(IN(INDEX+1),-MOVER),MASK) +! +! THE BYTE IS SPLIT ACROSS A WORD BREAK. +! + ELSE IF (MOVER.LT.0) THEN + MOVEL = - MOVER + MOVER = NBITSW - MOVEL + IOUT = IAND(IOR(ISHFT(IN(INDEX+1),MOVEL), & + & ISHFT(IN(INDEX+2),-MOVER)),MASK) +! +! THE BYTE IS ALREADY RIGHT ADJUSTED. +! + ELSE + IOUT = IAND(IN(INDEX+1),MASK) + ENDIF +! + RETURN + END +! +! +------------------------------------------------------------------+ + SUBROUTINE GBYTES_G1(IN,IOUT,ISKIP,NBYTE,NSKIP,N) +! +! THIS PROGRAM WRITTEN BY..... +! DR. ROBERT C. GAMMILL, CONSULTANT +! NATIONAL CENTER FOR ATMOSPHERIC RESEARCH +! MAY 1972 +! +! CHANGES FOR CRAY Y-MP8/832 +! CRAY CFT77 FORTRAN +! JULY 1992, RUSSELL E. JONES +! NATIONAL WEATHER SERVICE +! +! THIS IS THE FORTRAN VERSION OF GBYTES. +! + INTEGER IN(*) + INTEGER IOUT(*) +#if defined (CRAY) || defined (BIT64) +!CDIR$ INTEGER=64 + INTEGER MASKS(64) +! + DATA NBITSW/64/ +! +! MASKS TABLE PUT IN DECIMAL SO IT WILL COMPILE ON ANY 64 BIT +! COMPUTER +! + DATA MASKS / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, & + & 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287, & + & 1048575, 2097151, 4194303, 8388607, 16777215, 33554431, & + & 67108863, 134217727, 268435455, 536870911, 1073741823, & + & 2147483647, 4294967295, 8589934591, 17179869183, & + & 34359738367, 68719476735, 137438953471, 274877906943, & + & 549755813887, 1099511627775, 2199023255551, 4398046511103, & + & 8796093022207, 17592186044415, 35184372088831, & + & 70368744177663, 140737488355327, 281474976710655, & + & 562949953421311, 1125899906842623, 2251799813685247, & + & 4503599627370495, 9007199254740991, 18014398509481983, & + & 36028797018963967, 72057594037927935, 144115188075855871, & + & 288230376151711743, 576460752303423487, 1152921504606846975, & + & 2305843009213693951, 4611686018427387903, 9223372036854775807, & + & -1/ +#else + INTEGER MASKS(32) +! + DATA NBITSW/32/ +! +! MASKS TABLE PUT IN DECIMAL SO IT WILL COMPILE ON ANY 32 BIT +! COMPUTER +! + DATA MASKS / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, & + & 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287, & + & 1048575, 2097151, 4194303, 8388607, 16777215, 33554431, & + & 67108863, 134217727, 268435455, 536870911, 1073741823, & + & 2147483647, -1/ +#endif +! +! NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW +! + ICON = NBITSW - NBYTE + IF (ICON.LT.0) RETURN + MASK = MASKS(NBYTE) +! +! INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IN' THE NEXT BYTE APPEARS. +! + INDEX = ISKIP / NBITSW +! +! II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD. +! + II = MOD(ISKIP,NBITSW) +! +! ISTEP IS THE DISTANCE IN BITS FROM THE START OF ONE BYTE TO THE NEXT. +! + ISTEP = NBYTE + NSKIP +! +! IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT. +! + IWORDS = ISTEP / NBITSW +! +! IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS. +! + IBITS = MOD(ISTEP,NBITSW) +! + DO 10 I = 1,N +! +! MOVER SPECIFIES HOW FAR TO THE RIGHT A BYTE MUST BE MOVED IN ORDER +! +! TO BE RIGHT ADJUSTED. +! TO BE RIGHT ADJUSTED. +! + MOVER = ICON - II +! +! THE BYTE IS SPLIT ACROSS A WORD BREAK. +! + IF (MOVER.LT.0) THEN + MOVEL = - MOVER + MOVER = NBITSW - MOVEL + IOUT(I) = IAND(IOR(ISHFT(IN(INDEX+1),MOVEL), & + & ISHFT(IN(INDEX+2),-MOVER)),MASK) +! +! RIGHT ADJUST THE BYTE. +! + ELSE IF (MOVER.GT.0) THEN + IOUT(I) = IAND(ISHFT(IN(INDEX+1),-MOVER),MASK) +! +! THE BYTE IS ALREADY RIGHT ADJUSTED. +! + ELSE + IOUT(I) = IAND(IN(INDEX+1),MASK) + ENDIF +! +! INCREMENT II AND INDEX. +! + II = II + IBITS + INDEX = INDEX + IWORDS + IF (II.GE.NBITSW) THEN + II = II - NBITSW + INDEX = INDEX + 1 + ENDIF +! + 10 CONTINUE + RETURN + END +! +! +------------------------------------------------------------------+ + SUBROUTINE SBYTE_G1(IOUT,IN,ISKIP,NBYTE) +! THIS PROGRAM WRITTEN BY..... +! DR. ROBERT C. GAMMILL, CONSULTANT +! NATIONAL CENTER FOR ATMOSPHERIC RESEARCH +! JULY 1972 +! THIS IS THE FORTRAN VERSIONS OF SBYTE. +! FORTRAN 90 +! AUGUST 1990 RUSSELL E. JONES +! NATIONAL WEATHER SERVICE +! +! USAGE: CALL SBYTE (PCKD,UNPK,INOFST,NBIT) +! +! INPUT ARGUMENT LIST: +! UNPK - NBITS OF THE RIGHT SIDE OF UNPK IS MOVED TO +! ARRAY PCKD. INOFST BITS ARE SKIPPED OVER BEFORE +! THE DATA IS MOVED, NBITS ARE STORED. +! INOFST - A FULLWORD INTEGER SPECIFYING THE INITAL OFFSET +! IN BITS OF THE FIRST BYTE, COUNTED FROM THE +! LEFTMOST BIT IN PCKD. +! NBITS - A FULLWORD INTEGER SPECIFYING THE NUMBER OF BITS +! IN EACH BYTE TO BE PACKED. LEGAL BYTE WIDTHS +! ARE IN THE RANGE 1 - 32. +! OUTPUT ARGUMENT LIST: +! PCKD - THE FULLWORD IN MEMORY TO WHICH PACKING IS TO +! BEGIN STARTING AT BIT INOFST. THE INOSTAT BITS +! ARE NOT ALTERED. +! + INTEGER IN + INTEGER IOUT(*) +#if defined (CRAY) || defined (BIT64) + INTEGER MASKS(64) +! + DATA NBITSW/64/ +! +! MASKS TABLE PUT IN DECIMAL SO IT WILL COMPILE ON ANY 64 BIT +! COMPUTER +! + DATA MASKS / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, & + & 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287, & + & 1048575, 2097151, 4194303, 8388607, 16777215, 33554431, & + & 67108863, 134217727, 268435455, 536870911, 1073741823, & + & 2147483647, 4294967295, 8589934591, 17179869183, & + & 34359738367, 68719476735, 137438953471, 274877906943, & + & 549755813887, 1099511627775, 2199023255551, 4398046511103, & + & 8796093022207, 17592186044415, 35184372088831, & + & 70368744177663, 140737488355327, 281474976710655, & + & 562949953421311, 1125899906842623, 2251799813685247, & + & 4503599627370495, 9007199254740991, 18014398509481983, & + & 36028797018963967, 72057594037927935, 144115188075855871, & + & 288230376151711743, 576460752303423487, 1152921504606846975, & + & 2305843009213693951, 4611686018427387903, 9223372036854775807, & + & -1/ +#else + INTEGER MASKS(32) +! + DATA NBITSW/32/ +! +! MASKS TABLE PUT IN DECIMAL SO IT WILL COMPILE ON ANY 32 BIT +! COMPUTER +! + DATA MASKS / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, & + & 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287, & + & 1048575, 2097151, 4194303, 8388607, 16777215, 33554431, & + & 67108863, 134217727, 268435455, 536870911, 1073741823, & + & 2147483647, -1/ +#endif +! +! NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW +! + ICON = NBITSW - NBYTE + IF (ICON.LT.0) RETURN + MASK = MASKS(NBYTE) +! +! INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED. +! + INDEX = ISKIP / NBITSW +! +! II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT. +! + II = MOD(ISKIP,NBITSW) +! + J = IAND(MASK,IN) + MOVEL = ICON - II +! +! BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT. +! + IF (MOVEL.GT.0) THEN + MSK = ISHFT(MASK,MOVEL) + IOUT(INDEX+1) = IOR(IAND(NOT(MSK),IOUT(INDEX+1)), & + & ISHFT(J,MOVEL)) +! +! THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK. +! + ELSE IF (MOVEL.LT.0) THEN + MSK = MASKS(NBYTE+MOVEL) + IOUT(INDEX+1) = IOR(IAND(NOT(MSK),IOUT(INDEX+1)), & + & ISHFT(J,MOVEL)) + ITEMP = IAND(MASKS(NBITSW+MOVEL),IOUT(INDEX+2)) + IOUT(INDEX+2) = IOR(ITEMP,ISHFT(J,NBITSW+MOVEL)) +! +! BYTE IS TO BE STORED RIGHT-ADJUSTED. +! + ELSE + IOUT(INDEX+1) = IOR(IAND(NOT(MASK),IOUT(INDEX+1)),J) + ENDIF +! + RETURN + END +! +! +------------------------------------------------------------------+ + SUBROUTINE SBYTES_G1(IOUT,IN,ISKIP,NBYTE,NSKIP,N) +! THIS PROGRAM WRITTEN BY..... +! DR. ROBERT C. GAMMILL, CONSULTANT +! NATIONAL CENTER FOR ATMOSPHERIC RESEARCH +! JULY 1972 +! THIS IS THE FORTRAN VERSIONS OF SBYTES. +! +! FORTRAN 90 +! AUGUST 1990 RUSSELL E. JONES +! NATIONAL WEATHER SERVICE +! +! USAGE: CALL SBYTES (PCKD,UNPK,INOFST,NBIT, NSKIP,ITER) +! +! INPUT ARGUMENT LIST: +! UNPK - NBITS OF THE RIGHT SIDE OF EACH WORD OF ARRAY +! UNPK IS MOVED TO ARRAY PCKD. INOFST BITS ARE +! SKIPPED OVER BEFORE THE 1ST DATA IS MOVED, NBITS +! ARE STORED, NSKIP BITS ARE SKIPPED OVER, THE NEXT +! NBITS ARE MOVED, BIT ARE SKIPPED OVER, ETC. UNTIL +! ITER GROUPS OF BITS ARE PACKED. +! INOFST - A FULLWORD INTEGER SPECIFYING THE INITAL OFFSET +! IN BITS OF THE FIRST BYTE, COUNTED FROM THE +! LEFTMOST BIT IN PCKD. +! NBITS - A FULLWORD INTEGER SPECIFYING THE NUMBER OF BITS +! IN EACH BYTE TO BE PACKED. LEGAL BYTE WIDTHS +! ARE IN THE RANGE 1 - 32. +! NSKIP - A FULLWORD INTEGER SPECIFYING THE NUMBER OF BITS +! TO SKIP BETWEEN SUCCESSIVE BYTES. ALL NON-NEGATIVE +! SKIP COUNTS ARE LEGAL. +! ITER - A FULLWORD INTEGER SPECIFYING THE TOTAL NUMBER OF +! BYTES TO BE PACKED, AS CONTROLLED BY INOFST, +! NBIT AND NSKIP ABOVE. ALL NON-NEGATIVE ITERATION +! COUNTS ARE LEGAL. +! +! OUTPUT ARGUMENT LIST: +! PCKD - THE FULLWORD IN MEMORY TO WHICH PACKING IS TO +! BEGIN STARTING AT BIT INOFST. THE INOSTAT BITS +! ARE NOT ALTERED. NSKIP BITS ARE NOT ALTERED. +! + INTEGER IN(*) + INTEGER IOUT(*) +#if defined (CRAY) || defined (BIT64) + INTEGER MASKS(64) +! + DATA NBITSW/64/ +! +! MASKS TABLE PUT IN DECIMAL SO IT WILL COMPILE ON ANY 64 BIT +! COMPUTER +! + DATA MASKS / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, & + & 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287, & + & 1048575, 2097151, 4194303, 8388607, 16777215, 33554431, & + & 67108863, 134217727, 268435455, 536870911, 1073741823, & + & 2147483647, 4294967295, 8589934591, 17179869183, & + & 34359738367, 68719476735, 137438953471, 274877906943, & + & 549755813887, 1099511627775, 2199023255551, 4398046511103, & + & 8796093022207, 17592186044415, 35184372088831, & + & 70368744177663, 140737488355327, 281474976710655, & + & 562949953421311, 1125899906842623, 2251799813685247, & + & 4503599627370495, 9007199254740991, 18014398509481983, & + & 36028797018963967, 72057594037927935, 144115188075855871, & + & 288230376151711743, 576460752303423487, 1152921504606846975, & + & 2305843009213693951, 4611686018427387903, 9223372036854775807, & + & -1/ +#else + INTEGER MASKS(32) +! + DATA NBITSW/32/ +! +! MASKS TABLE PUT IN DECIMAL SO IT WILL COMPILE ON ANY 32 BIT +! COMPUTER +! + DATA MASKS / 1, 3, 7, 15, 31, 63, 127, 255, 511, 1023, 2047, & + & 4095, 8191, 16383, 32767, 65535, 131071, 262143, 524287, & + & 1048575, 2097151, 4194303, 8388607, 16777215, 33554431, & + & 67108863, 134217727, 268435455, 536870911, 1073741823, & + & 2147483647, -1/ +#endif +! +! NBYTE MUST BE LESS THAN OR EQUAL TO NBITSW +! + ICON = NBITSW - NBYTE + IF (ICON.LT.0) RETURN + MASK = MASKS(NBYTE) +! +! INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED. +! + INDEX = ISKIP / NBITSW +! +! II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT. +! + II = MOD(ISKIP,NBITSW) +! +! ISTEP IS THE DISTANCE IN BITS FROM ONE BYTE POSITION TO THE NEXT. +! + ISTEP = NBYTE + NSKIP +! +! IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT. +! + IWORDS = ISTEP / NBITSW +! +! IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS. +! + IBITS = MOD(ISTEP,NBITSW) +! + DO 10 I = 1,N + J = IAND(MASK,IN(I)) + MOVEL = ICON - II +! +! BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT. +! + IF (MOVEL.GT.0) THEN + MSK = ISHFT(MASK,MOVEL) + IOUT(INDEX+1) = IOR(IAND(NOT(MSK),IOUT(INDEX+1)), & + & ISHFT(J,MOVEL)) +! +! THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK. +! + ELSE IF (MOVEL.LT.0) THEN + MSK = MASKS(NBYTE+MOVEL) + IOUT(INDEX+1) = IOR(IAND(NOT(MSK),IOUT(INDEX+1)), & + & ISHFT(J,MOVEL)) + ITEMP = IAND(MASKS(NBITSW+MOVEL),IOUT(INDEX+2)) + IOUT(INDEX+2) = IOR(ITEMP,ISHFT(J,NBITSW+MOVEL)) +! +! BYTE IS TO BE STORED RIGHT-ADJUSTED. +! + ELSE + IOUT(INDEX+1) = IOR(IAND(NOT(MASK),IOUT(INDEX+1)),J) + ENDIF +! + II = II + IBITS + INDEX = INDEX + IWORDS + IF (II.GE.NBITSW) THEN + II = II - NBITSW + INDEX = INDEX + 1 + ENDIF +! +10 CONTINUE +! + RETURN + END diff --git a/WPS/ungrib/src/geth_idts.F b/WPS/ungrib/src/geth_idts.F new file mode 100644 index 00000000..e4c821e3 --- /dev/null +++ b/WPS/ungrib/src/geth_idts.F @@ -0,0 +1,316 @@ + subroutine geth_idts (ndate, odate, idts) + implicit none + +!*********************************************************************** +! +! purpose - from 2 input mdates ('YYYY-MM-DD HH:MM:SS'), compute +! the time difference in seconds. +! +! on entry - ndate - the new hdate. +! odate - the old hdate. +! +! on exit - idts - the change in time in seconds. +! +!*********************************************************************** + + character*(*) ndate, odate + character*19 tdate + integer idts + integer olen, nlen +! +! Local Variables +! +! yrnew - indicates the year associated with "ndate" +! yrold - indicates the year associated with "odate" +! monew - indicates the month associated with "ndate" +! moold - indicates the month associated with "odate" +! dynew - indicates the day associated with "ndate" +! dyold - indicates the day associated with "odate" +! hrnew - indicates the hour associated with "ndate" +! hrold - indicates the hour associated with "odate" +! minew - indicates the minute associated with "ndate" +! miold - indicates the minute associated with "odate" +! scnew - indicates the second associated with "ndate" +! scold - indicates the second associated with "odate" +! i - loop counter +! mday - a list assigning the number of days in each month +! newhrs - the number of hours between "ndate" and 1901 +! whole 24 hour days +! oldhrs - the number of hours between "odate" and 1901 +! + + integer yrnew, monew, dynew, hrnew, minew, scnew + integer yrold, moold, dyold, hrold, miold, scold + integer mday(12), i, newdys, olddys + logical npass, opass + integer isign + +! External function: + integer, external :: nfeb + +!************************* Subroutine Begin ************************** + + if (odate.gt.ndate) then + isign = -1 + tdate=ndate + ndate=odate + odate=tdate + else + isign = 1 + endif + +! +! Assign the number of days in a months +! + + mday( 1) = 31 + mday( 2) = 28 + mday( 3) = 31 + mday( 4) = 30 + mday( 5) = 31 + mday( 6) = 30 + mday( 7) = 31 + mday( 8) = 31 + mday( 9) = 30 + mday(10) = 31 + mday(11) = 30 + mday(12) = 31 + +! +! Break down old hdate into parts +! + hrold = 0 + miold = 0 + scold = 0 + olen = len(odate) + + read(odate(1:4), '(I4)', err=101) yrold + read(odate(6:7), '(I2)', err=101) moold + read(odate(9:10), '(I2)', err=101) dyold + if (olen.ge.13) then + read(odate(12:13),'(I2)', err=101) hrold + if (olen.ge.16) then + read(odate(15:16),'(I2)', err=101) miold + if (olen.ge.19) then + read(odate(18:19),'(I2)', err=101) scold + endif + endif + endif + +! +! Break down new hdate into parts +! + hrnew = 0 + minew = 0 + scnew = 0 + nlen = len(ndate) + + read(ndate(1:4), '(I4)', err=102) yrnew + read(ndate(6:7), '(I2)', err=102) monew + read(ndate(9:10), '(I2)', err=102) dynew + if (nlen.ge.13) then + read(ndate(12:13),'(I2)', err=102) hrnew + if (nlen.ge.16) then + read(ndate(15:16),'(I2)', err=102) minew + if (nlen.ge.19) then + read(ndate(18:19),'(I2)', err=102) scnew + endif + endif + endif + +! +! Check that the dates make sense. +! + npass = .true. + opass = .true. + +! Check that the month of NDATE makes sense. + + if ((monew.gt.12).or.(monew.lt.1)) then + print*, 'GETH_IDTS: Month of NDATE = ', monew + npass = .false. + endif + +! Check that the month of ODATE makes sense. + + if ((moold.gt.12).or.(moold.lt.1)) then + print*, 'GETH_IDTS: Month of ODATE = ', moold + opass = .false. + endif + +! Check that the day of NDATE makes sense. + + if (monew.ne.2) then +! ...... For all months but February + if ((dynew.gt.mday(monew)).or.(dynew.lt.1)) then + print*, 'GETH_IDTS: Day of NDATE = ', dynew + npass = .false. + endif + elseif (monew.eq.2) then +! ...... For February + if ((dynew .gt. nfeb(yrnew)).or.(dynew.lt.1)) then + print*, 'GETH_IDTS: Day of NDATE = ', dynew + npass = .false. + endif + endif + +! Check that the day of ODATE makes sense. + + if (moold.ne.2) then +! ...... For all months but February + if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then + print*, 'GETH_IDTS: Day of ODATE = ', dyold + opass = .false. + endif + elseif (moold.eq.2) then +! ....... For February + if ((dyold .gt. nfeb(yrold)).or.(dyold .lt. 1)) then + print*, 'GETH_IDTS: Day of ODATE = ', dyold + opass = .false. + endif + endif + +! Check that the hour of NDATE makes sense. + + if ((hrnew.gt.23).or.(hrnew.lt.0)) then + print*, 'GETH_IDTS: Hour of NDATE = ', hrnew + npass = .false. + endif + +! Check that the hour of ODATE makes sense. + + if ((hrold.gt.23).or.(hrold.lt.0)) then + print*, 'GETH_IDTS: Hour of ODATE = ', hrold + opass = .false. + endif + +! Check that the minute of NDATE makes sense. + + if ((minew.gt.59).or.(minew.lt.0)) then + print*, 'GETH_IDTS: Minute of NDATE = ', minew + npass = .false. + endif + +! Check that the minute of ODATE makes sense. + + if ((miold.gt.59).or.(miold.lt.0)) then + print*, 'GETH_IDTS: Minute of ODATE = ', miold + opass = .false. + endif +! +! Check that the second of NDATE makes sense. +! + if ((scnew.gt.59).or.(scnew.lt.0)) then + print*, 'GETH_IDTS: SECOND of NDATE = ', scnew + npass = .false. + endif + +! Check that the second of ODATE makes sense. + + if ((scold.gt.59).or.(scold.lt.0)) then + print*, 'GETH_IDTS: Second of ODATE = ', scold + opass = .false. + endif + + if (.not. npass) then + print*, 'Screwy NDATE: ', ndate(1:nlen) + STOP 'Error_ndate' + endif + + if (.not. opass) then + print*, 'Screwy ODATE: ', odate(1:olen) + STOP 'Error_odate' + endif +! +! Date Checks are completed. Continue. +! + +! +! Compute number of days from 1 January ODATE, 00:00:00 until ndate +! Compute number of hours from 1 January ODATE, 00:00:00 until ndate +! Compute number of minutes from 1 January ODATE, 00:00:00 until ndate +! + + newdys = 0 + do i = yrold, yrnew - 1 + newdys = newdys + (365 + (nfeb(i)-28)) + enddo + + if (monew .gt. 1) then + mday(2) = nfeb(yrnew) + do i = 1, monew - 1 + newdys = newdys + mday(i) + enddo + mday(2) = 28 + end if + + newdys = newdys + dynew-1 +! +! Compute number of hours from 1 January ODATE, 00:00:00 until odate +! Compute number of minutes from 1 January ODATE, 00:00:00 until odate +! + + olddys = 0 + + if (moold .gt. 1) then + mday(2) = nfeb(yrold) + do i = 1, moold - 1 + olddys = olddys + mday(i) + enddo + mday(2) = 28 + end if + + olddys = olddys + dyold-1 +! +! Determine the time difference in seconds +! + idts = (newdys - olddys) * 86400 + idts = idts + (hrnew - hrold) * 3600 + idts = idts + (minew - miold) * 60 + idts = idts + (scnew - scold) + + if (isign .eq. -1) then + tdate=ndate + ndate=odate + odate=tdate + idts = idts * isign + endif + + + return + 101 write(6,*) 'Error reading odate. odate = ',odate + write(6,*) 'Most likely an error in namelist.wps' + stop 'geth_idts 101' + 102 write(6,*) 'Error reading ndate. ndate = ',ndate + write(6,*) 'Most likely an error in namelist.wps' + stop 'geth_idts 102' + +!************************** Subroutine End *************************** + + end + integer function nfeb(year) +! +! Compute the number of days in February for the given year. +! + implicit none + integer, intent(in) :: year ! Four-digit year + +#ifdef NO_LEAP_CALENDAR + nfeb = 28 ! February always has 28 days for No Leap Calendar ... +#else + nfeb = 28 ! By default, February has 28 days ... + if (mod(year,4).eq.0) then + nfeb = 29 ! But every four years, it has 29 days ... + if (mod(year,100).eq.0) then + nfeb = 28 ! Except every 100 years, when it has 28 days ... + if (mod(year,400).eq.0) then + nfeb = 29 ! Except every 400 years, when it has 29 days ... + if (mod(year,3600).eq.0) then + nfeb = 28 ! Except every 3600 years, when it has 28 days. + endif + endif + endif + endif +#endif + + end function nfeb diff --git a/WPS/ungrib/src/geth_newdate.F b/WPS/ungrib/src/geth_newdate.F new file mode 100644 index 00000000..4487392a --- /dev/null +++ b/WPS/ungrib/src/geth_newdate.F @@ -0,0 +1,259 @@ + subroutine geth_newdate (ndate, odate, idts) + implicit none + +!********************************************************************** +! +! purpose - from old date ('YYYY-MM-DD*HH:MM:SS') and time in +! seconds, compute the new date. +! +! on entry - odate - the old hdate. +! idts - the change in time in seconds. +! +! on exit - ndate - the new hdate. +! idts - the change in time in seconds. +! +!********************************************************************** + + integer idts + character*(*) ndate, odate + integer nlen, olen + +! +! Local Variables +! +! yrold - indicates the year associated with "odate" +! moold - indicates the month associated with "odate" +! dyold - indicates the day associated with "odate" +! hrold - indicates the hour associated with "odate" +! miold - indicates the minute associated with "odate" +! scold - indicates the second associated with "odate" +! +! yrnew - indicates the year associated with "ndate" +! monew - indicates the month associated with "ndate" +! dynew - indicates the day associated with "ndate" +! hrnew - indicates the hour associated with "ndate" +! minew - indicates the minute associated with "ndate" +! scnew - indicates the second associated with "ndate" +! +! mday - a list assigning the number of days in each month + +! dth - the number of hours represented by "idts" +! i - loop counter +! nday - the integer number of days represented by "idts" +! nhour - the integer number of hours in "idts" after taking out +! all the whole days +! nmin - the integer number of minutes in "idts" after taking out +! all the whole days and whole hours. +! nsec - the integer number of minutes in "idts" after taking out +! all the whole days, whole hours, and whole minutes. +! + + integer yrnew, monew, dynew, hrnew, minew, scnew + integer yrold, moold, dyold, hrold, miold, scold + integer mday(12), nday, nhour, nmin, nsec, i + real dth + logical opass + logical noLeapCalendar + + +!************************* Subroutine Begin ************************* + +! +! Determine whether the routine should use a no-leap year calendar +! + noLeapCalendar = .false. + +#ifdef NO_LEAP_CALENDAR + noLeapCalendar = .true. +#endif + + +! +! Assign the number of days in a months +! + + mday( 1) = 31 + mday( 2) = 28 + mday( 3) = 31 + mday( 4) = 30 + mday( 5) = 31 + mday( 6) = 30 + mday( 7) = 31 + mday( 8) = 31 + mday( 9) = 30 + mday(10) = 31 + mday(11) = 30 + mday(12) = 31 + +! +! Break down old hdate into parts +! + hrold = 0 + miold = 0 + scold = 0 + olen = len(odate) + + read(odate(1:4), '(I4)') yrold + read(odate(6:7), '(I2)') moold + read(odate(9:10), '(I2)') dyold + if (olen.ge.13) then + read(odate(12:13),'(I2)') hrold + if (olen.ge.16) then + read(odate(15:16),'(I2)') miold + if (olen.ge.19) then + read(odate(18:19),'(I2)') scold + endif + endif + endif +! +! Set the number of days in February for that year. +! + mday(2) = 28 + if (.not. noLeapCalendar) then + if (mod(yrold,4).eq.0) then + mday(2) = 29 + if (mod(yrold,100).eq.0) then + mday(2) = 28 + if (mod(yrold,400).eq.0) then + mday(2) = 29 + endif + endif + endif + endif +! +! Check that ODATE makes sense. +! + opass = .TRUE. + +! Check that the month of ODATE makes sense. + + if ((moold.gt.12).or.(moold.lt.1)) then + print*, 'GETH_NEWDATE: Month of ODATE = ', moold + opass = .FALSE. + endif + +! Check that the day of ODATE makes sense. + + if ((dyold.gt.mday(moold)).or.(dyold.lt.1)) then + + ! + ! Send a custom message if any leap-day files if it is a No-Leap Calendar + ! + if (noLeapCalendar .and. (moold .eq. 2) .and. (dyold .eq. 29)) then + print*,'GET_NEWDATE: Using a no-Leap Calendar, but data for 2/29 was found.' + else + print*, 'GET_NEWDATE: Day of ODATE = ', dyold + endif + + opass = .FALSE. + endif + +! Check that the hour of ODATE makes sense. + + if ((hrold.gt.23).or.(hrold.lt.0)) then + print*, 'GET_NEWDATE: Hour of ODATE = ', hrold + opass = .FALSE. + endif + +! Check that the minute of ODATE makes sense. + + if ((miold.gt.59).or.(miold.lt.0)) then + print*, 'GET_NEWDATE: Minute of ODATE = ', miold + opass = .FALSE. + endif + +! Check that the second of ODATE makes sense. + + if ((scold.gt.59).or.(scold.lt.0)) then + print*, 'GET_NEWDATE: Second of ODATE = ', scold + opass = .FALSE. + endif + + if (.not.opass) then + print*, 'Crazy ODATE: ', odate(1:olen), olen + STOP 'Error_odate' +! stop + endif +! +! Date Checks are completed. Continue. +! + +! +! Compute the number of days, hours, minutes, and seconds in idts +! + nday = idts/86400 ! Integer number of days in delta-time + nhour = mod(idts,86400)/3600 + nmin = mod(idts,3600)/60 + nsec = mod(idts,60) + + scnew = scold + nsec + if (scnew .ge. 60) then + scnew = scnew - 60 + nmin = nmin + 1 + end if + minew = miold + nmin + if (minew .ge. 60) then + minew = minew - 60 + nhour = nhour + 1 + end if + hrnew = hrold + nhour + if (hrnew .ge. 24) then + hrnew = hrnew - 24 + nday = nday + 1 + end if + + dynew = dyold + monew = moold + yrnew = yrold + do i = 1, nday + dynew = dynew + 1 + if (dynew.gt.mday(monew)) then + dynew = dynew - mday(monew) + monew = monew + 1 + if (monew .gt. 12) then + monew = 1 + yrnew = yrnew + 1 + + mday(2) = 28 + if (.not. noLeapCalendar) then + if (mod(yrnew,4).eq.0) then + mday(2) = 29 + if (mod(yrnew,100).eq.0) then + mday(2) = 28 + if (mod(yrnew,400).eq.0) then + mday(2) = 29 + endif + endif + endif + endif + + end if + endif + enddo + +! +! Now construct the new mdate +! + nlen = len(ndate) + + if (nlen.ge.19) then + write(ndate,19) yrnew, monew, dynew, hrnew, minew, scnew + 19 format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2,':',I2.2) + + else if (nlen.eq.16) then + write(ndate,16) yrnew, monew, dynew, hrnew, minew + 16 format(I4,'-',I2.2,'-',I2.2,'_',I2.2,':',I2.2) + + else if (nlen.eq.13) then + write(ndate,13) yrnew, monew, dynew, hrnew + 13 format(I4,'-',I2.2,'-',I2.2,'_',I2.2) + + else if (nlen.eq.10) then + write(ndate,10) yrnew, monew, dynew + 10 format(I4,'-',I2.2,'-',I2.2) + + endif + +!************************** Subroutine End ************************** + + end diff --git a/WPS/ungrib/src/gribcode.F b/WPS/ungrib/src/gribcode.F new file mode 100644 index 00000000..40c3e135 --- /dev/null +++ b/WPS/ungrib/src/gribcode.F @@ -0,0 +1,2136 @@ +! ! +!*****************************************************************************! +! ! +! This is a package of subroutines to read GRIB-formatted data. It is still ! +! under continuous development. It will not be able to read every GRIB dataset! +! you give it, but it will read a good many. ! +! ! +! Kevin W. Manning ! +! NCAR/MMM ! +! Summer 1998, and continuing ! +! SDG ! +! ! +!*****************************************************************************! +! ! +! The main user interfaces are: ! +! ! +! SUBROUTINE GRIBGET(NUNIT, IERR) ! +! Read a single GRIB record from UNIX file-descriptor NUNIT into array ! +! GREC. No unpacking of any header or data values is performed. ! +! ! +! SUBROUTINE GRIBREAD(NUNIT, DATA, NDATA, IERR) ! +! Read a single GRIB record from UNIX file-descriptor NUNIT, and unpack ! +! all header and data values into the appropriate arrays. ! +! ! +! SUBROUTINE GRIBHEADER ! +! Unpack the header of a GRIB record ! +! ! +! SUBROUTINE GRIBDATA(DATARRAY, NDAT) ! +! Unpack the data in a GRIB record into array DATARRAY ! +! ! +! SUBROUTINE GRIBPRINT(ISEC) ! +! Print the header information from GRIB section ISEC. ! +! ! +! SUBROUTINE GET_SEC1(KSEC1) ! +! Return the header information from Section 1. ! +! ! +! SUBROUTINE GET_SEC2(KSEC2) ! +! Return the header information from Section 2. ! +! ! +! SUBROUTINE GET_GRIDINFO(IGINFO, GINFO) ! +! Return the grid information of the previously-unpacked GRIB header. ! +! ! +! ! +!*****************************************************************************! +! ! +! ! +! The following arrays have meanings as follows: ! +! ! +! ! +! SEC0: GRIB Header Section 0 information ! +! ! +! 1 : Length of a complete GRIB record ! +! 2 : GRIB Edition number ! +! ! +! ! +! SEC1: GRIB Header Section 1 information ! +! ! +! 1 : Length of GRIB section 1 (bytes) ! +! 2 : Parameter Table Version number ???? ! +! 3 : Center Identifier ???? ! +! 4 : Process Identifier ???? ! +! 5 : Grid ID number for pre-specified grids. ! +! 6 : Binary bitmap flag: ! +! 7 : Parameter ID Number (ON388 Table 2) ! +! 8 : Level type (ON388 Table 3) ! +! 9 : Level value, or top value of a layer ! +! 10 : Bottom value of a layer ( 0 if NA ??) ! +! 11 : Year (00-99) ! +! 12 : Month (01-12) ! +! 13 : Day of the month (01-31) ! +! 14 : Hour (00-23) ! +! 15 : Minute (00-59) ! +! 16 : Forecast time unit: (ON388 Table 4) ! +! 17 : Time period 1: ! +! 18 : Time period 2: ! +! 19 : Time range indicator (ON833 Table 5) ! +! 20 : Number of ?? in an average ?? ! +! 21 : Number of ?? missing from average ?? ! +! 22 : Century (Years 1999 and 2000 are century 20, 2001 is century 21)! +! 23 : Sub-center identifier ?? ! +! 24 : Decimal scale factor for ??? ! +! ! +! ! +! ! +! ! +! ! +! SEC2: GRIB Header Section 2 information ! +! ! +! 1 : Length of GRIB Section 2 ! +! 2 : Number of vertical-coordinate parameters ??? ! +! 3 : Starting-point of the list of vertical-coordinate parameters ?? ! +! 4 : Data-representation type (i.e., grid type) Table ??? ! +! : 0 = ?? ! +! : 3 = Lambert-conformal grid. ! +! : 5 = Polar-stereographic grid. ! +! ! +! if (SEC2(4) == 0) then LATITUDE/LONGITUDE GRID ! +! ! +! INFOGRID/GRIDINFO: ! +! ! +! 1 : I Dimension of the grid ! +! 2 : J Dimension of the grid ! +! 3 : Starting Latitude of the grid. ! +! 4 : Starting Longitude of the grid. ! +! 5 : Resolution and component flags. ! +! 6 : Ending latitude of the grid. ! +! 7 : Ending longitude of the grid. ! +! 8 : Longitudinal increment. ! +! 9 : Latitudinal incriment. ! +! 10 : Scanning mode (bit 3 from Table 8) ! +! 21 : Iscan sign (+1/-1) (bit 1 from Table 8) ! +! 22 : Jscan sign (+1/-1) (bit 2 from Table 8) ! +! ! +! ! +! elseif (SEC2(4) == 3) then LAMBERT CONFORMAL GRID ! +! ! +! INFOGRID/GRIDINFO: ! +! ! +! 1 : I Dimension of the grid ! +! 2 : J Dimension of the grid ! +! 3 : Starting Latitude of the grid. ! +! 4 : Starting Longitude of the grid. ! +! 5 : Resolution and component flags. ! +! 6 : Center longitude of the projection. ! +! 7 : Grid-spacing in the I direction ! +! 8 : Grid-spacing in the J direction ! +! 9 : Projection center ! +! 10 : Scanning mode (bit 3 from Table 8) ! +! 11 : First TRUELAT value. ! +! 12 : Second TRUELAT value. ! +! 13 : Latitude of the southern pole ?? ! +! 14 : Longitude of the southern pole ?? ! +! 21 : Iscan sign (+1/-1) (bit 1 from Table 8) ! +! 22 : Jscan sign (+1/-1) (bit 2 from Table 8) ! +! ! +! if (SEC2(4) == 4) then GAUSSIAN GRID ! +! ! +! INFOGRID/GRIDINFO: ! +! ! +! 1 : I Dimension of the grid ! +! 2 : J Dimension of the grid ! +! 3 : Starting Latitude of the grid. ! +! 4 : Starting Longitude of the grid. ! +! 5 : Resolution and component flags. ! +! 6 : Ending latitude of the grid. ! +! 7 : Ending longitude of the grid. ! +! 8 : Longitudinal increment. ! +! 9 : Number of latitude circles between pole and equator ! +! 10 : Scanning mode (bit 3 from Table 8) ! +! 17 : Original (stored) ending latitude ! +! 18 : Original (stored) starting latitude ! +! 19 : Approximate delta-latitude ! +! 21 : Iscan sign (+1/-1) (bit 1 from Table 8) ! +! 22 : Jscan sign (+1/-1) (bit 2 from Table 8) ! +! ! +! ! +! elseif (SEC2(4) == 5) then POLAR STEREOGRAPHIC GRID ! +! ! +! INFOGRID/GRIDINFO: ! +! ! +! 1 : I Dimension of the grid ! +! 2 : J Dimension of the grid ! +! 3 : Starting Latitude of the grid. ! +! 4 : Starting Longitude of the grid. ! +! 5 : Resolution and component flags. ! +! 6 : Center longitude of the projection. ! +! 7 : Grid-spacing in the I direction ! +! 8 : Grid-spacing in the J direction ! +! 9 : Projection center ! +! 10 : Scanning mode (bit 3 from Table 8) ! +! 21 : Iscan sign (+1/-1) (bit 1 from Table 8) ! +! 22 : Jscan sign (+1/-1) (bit 2 from Table 8) ! +! ! +! elseif (SEC2(4) == 50) then SPHERICAL HARMONIC COEFFICIENTS ! +! ! +! INFOGRID/GRIDINFO: ! +! ! +! 1 : J-pentagonal resolution parameter ! +! 2 : K-pentagonal resolution parameter ! +! 3 : M-pentagonal resolution parameter ! +! 4 : Spectral representation type (ON388 Table 9) ! +! 5 : Coefficient storage mode (ON388 Table 10) ! +! ! +! elseif (SEC2(4) == ?) then ?? ! +! ! +! ! +! SEC3: GRIB Header Section 3 information: ! +! SEC4: GRIB Header Section 4 information: ! +! +! +! +module module_grib +! +! Machine wordsize must be known for the various unpacking routines to work. +! Machine wordsize is set through CPP Directives. +! Use options -DBIT32 (for 32-bit word-size) or -DBIT64 (for 64-bit wordsize) +! for the CPP pass of the compiler. +! +#if defined (BIT32) + integer, parameter :: MWSIZE = 32 ! Machine word size in bits +#elif defined (BIT64) + integer, parameter :: MWSIZE = 64 ! Machine word size in bits +#endif + + +! Array GREC holds a single packed GRIB record (header and all). +! Array BITMAP holds the bitmap (if a bitmap was used). +! +! For some reason, the cray does not like grec to be allocatable. +! +#if defined (CRAY) + integer, dimension(100000) :: grec + integer, dimension(100000) :: bitmap +#else + integer, allocatable, save, dimension(:) :: grec + integer, allocatable, save, dimension(:) :: bitmap +#endif + +! SEC0 holds the Section 0 header information +! SEC1 holds the Section 1 header information +! SEC2 holds the Section 2 header information +! SEC3 holds the Section 3 header information +! SEC4 holds the Section 4 header information +! XEC4 holds floating-point Section 4 header information + + integer, dimension(2) :: sec0 + integer, dimension(100) :: sec1 + integer, dimension(10) :: sec2 + integer, dimension(10) :: sec3 + integer, dimension(10) :: sec4 + real, dimension(1) :: xec4 + + integer :: sevencount = 0 + +! INFOGRID holds integer values defining the grid. +! GRIDINFO holds floating-point values definint the grid + + integer, dimension(40) :: infogrid + real, dimension(40) :: gridinfo + + integer :: ied + real, parameter :: pi = 3.1415926534 + real, parameter :: degran = pi/180. + real, parameter :: raddeg = 1./degran + + real :: glat1, glon1, gclon, gtrue1, gtrue2, grrth, gx1, gy1, gkappa + +contains +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! + integer function gribsize(trec, ilen, ierr) +!-----------------------------------------------------------------------------! +! Return the size of a single GRIB record. ! +! ! +! Input: ! +! TREC: At least a portion of the complete GRIB record. ! +! ILEN: The size of array TREC. ! +! ! +! Output ! +! GRIBSIZE: The size of the full GRIB record ! +! IERR : 0= no errors, 1 = read error +! ! +! Side Effects: ! +! * Module variable IED is set to the GRIB Edition number. ! +! * STOP, if not GRIB Edition 0 or 1 ! +! ! +! Externals ! +! GBYTE ! +! ! +!-----------------------------------------------------------------------------! + implicit none + integer :: ilen + integer, dimension(ilen) :: trec + integer :: isz0 = 32 + integer :: isz1 = 0 + integer :: isz2 = 0 + integer :: isz3 = 0 + integer :: isz4 = 0 + integer :: isz5 = 32 + integer :: iflag + integer :: ierr + character :: pname*132 + + ierr = 0 +! Unpack the GRIB Edition number, located in the eighth byte (bits 57-64) ! +! of array TREC. ! + + call gbyte_g1(trec, ied, 56, 8) + +! GRIB Edition 1 has the size of the whole GRIB record right up front. ! + + if (ied.eq.1) then + ! Grib1 + ! Find the size of the whole GRIB record + call gbyte_g1(trec, gribsize, 32, 24) + +! GRIB Edition 0 does not include the total size, so we have to sum up ! +! the sizes of the individual sections ! + + elseif (ied.eq.0) then + ! Grib old edition + ! Find the size of section 1. + call gbyte_g1(trec, isz1, isz0, 24) + isz1 = isz1 * 8 + call gbyte_g1(trec, iflag, isz0+56, 8) + if ((iflag.eq.128).or.(iflag.eq.192)) then ! section 2 is there + ! Find the size of section 2. + call gbyte_g1(trec, isz2, isz0+isz1, 24) + isz2 = isz2 * 8 + endif + if ((iflag.eq.64).or.(iflag.eq.192)) then ! Section 3 is there + ! Find the size of section 3. + call gbyte_g1(trec, isz3, isz0+isz1+isz2, 24) + isz3 = isz3 * 8 + endif + ! Find the size of section 4. + call gbyte_g1(trec, isz4, isz0+isz1+isz2+isz3, 24) + isz4 = isz4 * 8 + + ! Total the sizes of sections 0 through 5. + gribsize = (isz0+isz1+isz2+isz3+isz4+isz5) / 8 + + elseif (ied.eq.2) then + ! Grib2 + CALL getarg ( 0 , pname ) + write(*,'("*** stopping in gribcode ***\n")') + write(*,'("\tI was expecting a Grib1 file, but this is a Grib2 file.")') + if ( index(pname,'ungrib.exe') .ne. 0 ) then + write(*,'("\tIt is possible this is because your GRIBFILE.XXX files")') + write(*,'("\tare not all of the same type.")') + write(*,'("\tWPS can handle both file types, but a separate ungrib")') + write(*,'("\tjob must be run for each Grib type.\n")') + else + write(*,'("\tUse g2print on Grib2 files\n")') + endif + stop 'gribsize in gribcode' + else + write(*,'("Error trying to read grib edition number in gribsize.")') + write(*,'("Possible corrupt grib file.")') + write(6,*) 'Incorrect edition number = ',ied + write(6,*) 'Skipping the rest of the file and continuing.' + ierr = 1 + endif + end function gribsize +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! + subroutine findgrib(nunit, isize, ierr) + +!-----------------------------------------------------------------------------! +! ! +! Find the string "GRIB", which starts off a GRIB record. ! +! ! +! Input: ! +! NUNIT: The C unit to read from. This should already be opened. ! +! ! +! Output: ! +! ISIZE: The size in bytes of one complete GRIB Record ! +! IERR: Error flag, ! +! 0 : No error or end-of-file on reading ! +! 1 : Hit the end of file ! +! 2 : Error on reading ! +! ! +! Side effects: ! +! * The pointer to C unit NUNIT is set to the beginning of the next ! +! GRIB record. ! +! * The first time FINDGRIB is called, the integer GTEST is set to ! +! a value equivalent to the string 'GRIB' ! +! ! +! Modules: ! +! MODULE_GRIB ! +! ! +! Externals: ! +! BN_READ ! +! BN_SEEK ! +! GRIBSIZE ! +! ! +!-----------------------------------------------------------------------------! + implicit none + integer, intent(in) :: nunit + integer, intent(out) :: isize + integer, intent(out) :: ierr + + integer, parameter :: LENTMP=100 + integer, dimension(lentmp) :: trec + + integer :: isz, itest, icnt + + integer, save :: gtest = 0 + +! Set the integer variable GTEST to hold the integer representation of the +! character string 'GRIB'. This integer variable is later compared to +! integers we read from the GRIB file, to find the beginning of a GRIB record. + + if (gtest.eq.0) then + if (mwsize.eq.32) then + gtest = transfer('GRIB', gtest) + elseif(mwsize.eq.64) then + call gbyte_g1(char(0)//char(0)//char(0)//char(0)//'GRIB', gtest, 0, mwsize) + endif + endif + ierr = 0 + icnt = 0 + + LOOP : DO +! Read LENTMP bytes into holding array TREC. + call bn_read(nunit, trec, lentmp, isz, ierr, 0) + if (ierr.eq.1) then + return + elseif (ierr.eq.2) then + write(*,'("Error reading GRIB: IERR = ", I2)') ierr + return + endif +! Reposition the file pointer back to where we started. + call bn_seek(nunit, -isz, 0, 0) + +! Compare the first four bytes of TREC with the string 'GRIB' stored in +! integer variable GTEST. + if (mwsize.eq.32) then + if (trec(1) == gtest) exit LOOP + elseif (mwsize.eq.64) then + call gbyte_g1(trec, itest, 0, 32) + if (itest == gtest) exit LOOP + endif + +! Advance the file pointer one byte. + call bn_seek(nunit, 1, 0, 0) + icnt = icnt + 1 + if ( icnt .gt. 100000) then ! stop if we cannot find the GRIB string + write(*,'("*** stopping in findgrib in gribcode ***\n")') + write(*,'("\tI could not find the GRIB string in the input file")') + write(*,'("\tafter testing the first 100,000 bytes.")') + write(*,'("\tThe file may be corrupt or it is not a GRIB file.")') + write(*,'("\tPerhaps a gzipped GRIB file or netcdf?\n")') + stop 'findgrib' + endif + + ENDDO LOOP + +!#if defined (DEC) || defined (ALPHA) || defined (alpha) || defined (LINUX) +#ifdef BYTESWAP + call swap4(trec, isz) +#endif + isize = gribsize(trec, isz, ierr) + + end subroutine findgrib +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! + subroutine SGUP_NOBITMAP(datarray, ndat) +! Simple grid-point unpacking + implicit none + + integer :: ndat + real , dimension(ndat) :: datarray + integer, dimension(ndat) :: IX + real :: dfac, bfac + integer :: iskip + + DFAC = 10.**(-sec1(24)) + BFAC = 2.**sec4(7) + if (ied.eq.0) then + iskip = 32 + sec1(1)*8 + sec2(1)*8 + sec3(1)*8 + 11*8 + elseif (ied.eq.1) then + iskip = 64 + sec1(1)*8 + sec2(1)*8 + sec3(1)*8 + 11*8 + endif +! sec4(8) is the number of bits used per datum value. +! If sec4(8) = 255, assume they mean sec4(8) = 0 + if (sec4(8) == 255) then + sec4(8) = 0 + endif +! If sec4(8) is 0, assume datarray is constant value of xec4(1) + + if (sec4(8).eq.0) then + !!! HERE IS THE ORIGINAL NCAR CODE: + ! datarray = xec4(1) + !!! HERE IS WHAT FSL CHANGED IT TO: + datarray = DFAC*xec4(1) + !!! because even though it is a constant value + !!! you still need to scale by the decimal scale factor. + else + !!! FSL developers MOVED THE CALL TO gbytes FROM line 441 ABOVE + !!! BECAUSE IF sec4(8)==0 BEFORE gbytes IS CALLED, THE MASKS ARRAY + !!! IN gbytes WILL BE INDEXED OUT OF BOUNDS. C HARROP 9/16/04 + call gbytes_g1(grec, IX, iskip, sec4(8), 0, ndat) + datarray = DFAC * (xec4(1) + (IX*BFAC)) + endif + end subroutine SGUP_NOBITMAP +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! + + subroutine SGUP_BITMAP(datarray, ndat) +! Simple grid-point unpacking, with a bitmap. + implicit none + + integer :: ndat ! Number of data points in the final grid. + real , dimension(ndat) :: datarray ! Array holding the final unpacked data. + real :: dfac, bfac + integer :: iskip, nbm, i, nn + + integer, allocatable, dimension(:) :: bmdat + +! SEC4(1) : The number of bytes in the whole of GRIB Section 4. +! SEC4(6) : The number of unused bits at the end of GRIB Section 4. +! SEC4(8) : The number of bits per data value. + + datarray = -1.E30 + +! 1) There are fewer than NDAT data values, because a bitmap was used. +! Compute the number of data values (NBM). There are 11 extra bytes +! in the header section 4. NBM equals the total number of data bits (not +! counting the header bits), minus the number of unused buts, and then +! divided by the number of bits per data value. + +! Compute the parameters involved with packing + DFAC = 10.**(-sec1(24)) + BFAC = 2.**sec4(7) + +! If sec4(8) is 0, assume datarray is constant value of xec4(1) scaled by DFAC + + if (sec4(8).eq.0) then + where(bitmap(1:ndat).eq.1) datarray = xec4(1) * DFAC + return + endif + nbm = ((sec4(1)-11)*8-sec4(6))/sec4(8) + allocate(bmdat(nbm)) + +! Set ISKIP to the beginning of the data. + if (ied.eq.0) then + iskip = 32 + sec1(1)*8 + sec2(1)*8 + sec3(1)*8 + 11*8 + elseif (ied.eq.1) then + iskip = 64 + sec1(1)*8 + sec2(1)*8 + sec3(1)*8 + 11*8 + endif + +! Read the data from the GREC array + call gbytes_g1(grec, bmdat, iskip, sec4(8), 0, nbm) +! sec4(8) is the number of bits used per datum value. +! If sec4(8) = 255, assume they mean sec4(8) = 0 + if (sec4(8) == 255) sec4(8) = 0 + +! Unpack the data according to packing parameters DFAC, BFAC, and XEC4(1), +! and masked by the bitmap BITMAP. + nn = 0 + do i = 1, ndat + if (bitmap(i).eq.1) then + nn = nn + 1 + datarray(i) = DFAC * (xec4(1) + (bmdat(nn)*BFAC)) + endif + enddo + +! Deallocate the scratch BMDAT array + deallocate(bmdat) + + end subroutine SGUP_BITMAP +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! + + subroutine CSHUP(pdata, ndat) +! ECMWFs unpacking of ECMWFs Complex Spherical Harmonic packing +! Adapted from ECMWFs GRIBEX package. + implicit none + + integer :: ndat + real , dimension(ndat) :: pdata + integer, dimension(ndat+500) :: IX + + integer :: iskip, isign + integer :: N1, IPOWER, J, K, M, nval + real :: zscale, zref + + integer :: ic, jm, iuc, il2, inum, jn + integer :: inext, ilast, ioff, jrow, index, i, jcol + real :: bval + integer, allocatable, dimension(:) :: iexp, imant + real , dimension(0:400) :: factor + real :: power + integer :: N + + index = -1 + + if (ied.eq.0) then + iskip = 32 + sec1(1)*8 + sec2(1)*8 + sec3(1)*8 + 11*8 + elseif(ied.eq.1) then + iskip = 64 + sec1(1)*8 + sec2(1)*8 + sec3(1)*8 + 11*8 + endif + + call gbyte_g1(grec,N1,iskip,16) + iskip = iskip + 16 + + call gbyte_g1(grec,ipower,iskip,16) + iskip = iskip + 16 + if (ipower.ge.32768) ipower = 32768-ipower + +! Unpack the resolution parameters for the initial (small) truncation: + call gbyte_g1(grec,J,iskip,8) + iskip = iskip + 8 + call gbyte_g1(grec,K,iskip,8) + iskip = iskip + 8 + call gbyte_g1(grec,M,iskip,8) + iskip = iskip + 8 + + zscale = 2.**sec4(7) + + iskip = N1*8 + + nval = NDAT - (J+1)*(J+2) + + call gbytes_g1(grec, ix, iskip, sec4(8), 0, nval) +! sec4(8) is the number of bits used per datum value. +! If sec4(8) = 255, assume they mean sec4(8) = 0 + if (sec4(8) == 255) sec4(8) = 0 + + pdata(1:nval) = (float(ix(1:nval))*zscale)+xec4(1) + + IUC = NDAT+1 + IC = NVAL+1 + DO JM=INFOGRID(1),0,-1 + IL2=MAX(JM,J+1) + INUM=2*(INFOGRID(1)-IL2+1) + pdata(iuc-inum:iuc-1) = pdata(ic-inum:ic-1) + iuc = iuc - inum + ic = ic - inum + IUC = IUC-MAX((IL2-JM)*2,0) + ENDDO + + if (ied.eq.0) then + iskip = 32 + sec1(1)*8 + sec2(1)*8 + sec3(1)*8 + 11*8 + elseif (ied.eq.1) then + iskip = 64 + sec1(1)*8 + sec2(1)*8 + sec3(1)*8 + 18*8 + endif + + allocate(iexp(802)) + allocate(imant(802)) + ilast=j+1 + do jrow=1,ilast + inext = 2*(ilast-jrow+1) + ! extract all the exponents + call gbytes_g1(grec, iexp, iskip, 8, 24, inext) + ! extract all the mantissas + ioff = 8 + call gbytes_g1(grec, imant, iskip+8, 24, 8, inext) + iskip = iskip + inext*32 + + ! Build the real values from mantissas and exponents + bval = 2.**(-24) + i = 0 + do jcol = jrow, infogrid(1)+1 + index = index + 2 + if (ilast.ge.jcol) then + i = i + 1 + if ((iexp(i).eq.128.or.iexp(i).eq.0).and.(imant(i).eq.0)) then + pdata(i) = 0 + else + if (iexp(i).ge.128) then + iexp(i) = iexp(i) - 128 + isign = -1 + else + isign = 1 + endif + pdata(index) = isign*bval*IMANT(i)*16.**(IEXP(i)-64) + i = i + 1 + if (iexp(i).ge.128) then + iexp(i) = iexp(i) - 128 + isign = -1 + else + isign = 1 + endif + pdata(index+1) = isign*bval*IMANT(i)*16.**(IEXP(i)-64) + endif + endif + enddo + enddo + + !Apply power scaling: + + if (ipower.ne.0) then + power = float(ipower) / 1000.0 + factor(0) = 1.0 + do n = 1 , infogrid(1) + if( ipower .ne. 1000 ) then + factor(n) = 1.0 / (n * (n+1) )**power + else + factor(n) = 1.0 / (n * (n + 1)) + endif + enddo + INDEX = -1 + DO M = 0 , J-1 + DO N = M , INFOGRID(1) + INDEX = INDEX + 2 + IF ( N .GE. J ) THEN + PDATA(INDEX:INDEX+1) = PDATA(INDEX:INDEX+1) * FACTOR(N) + ENDIF + ENDDO + ENDDO + DO M = J , INFOGRID(1) + DO N = M , INFOGRID(1) + INDEX = INDEX + 2 + PDATA(INDEX:INDEX+1) = PDATA(INDEX:INDEX+1) * FACTOR(N) + ENDDO + ENDDO + endif + + end subroutine CSHUP +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +! +! +! Trigonometric functions which deal with degrees, rather than radians: +! + real function sind(theta) + real :: theta + sind = sin(theta*degran) + end function sind + real function cosd(theta) + real :: theta + cosd = cos(theta*degran) + end function cosd + real function tand(theta) + real :: theta + tand = tan(theta*degran) + end function tand + real function atand(x) + real :: x + atand = atan(x)*raddeg + end function atand + real function atan2d(x,y) + real :: x,y + atan2d = atan2(x,y)*raddeg + end function atan2d + real function asind(x) + real :: x + asind = asin(x)*raddeg + end function asind + real function acosd(x) + real :: x + acosd = acos(x)*raddeg + end function acosd + +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +end module module_grib +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +subroutine gribget(nunit, ierr) + use module_grib +!-----------------------------------------------------------------------------! +! ! +! Read a single GRIB record, with no unpacking of any header or data fields. ! +! ! +! Input: ! +! NUNIT: C unit number to read from. This should already be open. ! +! ! +! Output: ! +! IERR: Error flag, Non-zero means there was a problem with the read. ! +! ! +! Side Effects: ! +! The array GREC is allocated, and filled with one GRIB record. ! +! The C unit pointer is moved to the end of the GRIB record just read. ! +! ! +! Modules: ! +! MODULE_GRIB ! +! ! +! Externals: ! +! FINDGRIB ! +! BN_READ ! +! ! +!-----------------------------------------------------------------------------! + + implicit none + + integer :: nunit + integer :: ierr + integer :: isz, isize + +! Position the file pointer at the beginning of the GRIB record. + call findgrib(nunit, isize, ierr) + if (ierr.ne.0) return + +! Allocate the GREC array to be able to hold the data + +#if defined (CRAY) +#else + allocate(grec((isize+(mwsize/8-1))/(mwsize/8))) +#endif + +! Read the full GRIB record. + + call bn_read(nunit, grec, isize, isz, ierr, 1) + +!#if defined (DEC) || defined (ALPHA) || defined (alpha) || defined (LINUX) +#ifdef BYTESWAP + call swap4(grec, isz) +#endif + + +end subroutine gribget +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +subroutine gribread(nunit, data, ndata, debug_level, ierr) +!-----------------------------------------------------------------------------! +! Read one grib record, unpack the header and data information. ! +! ! +! Input: ! +! NUNIT: C Unit to read from. ! +! NDATA: Size of array DATA (Should be >= NDAT as computed herein.) ! +! ! +! Output: ! +! DATA: The unpacked data array ! +! IERR: Error flag, non-zero means there was a problem. ! +! ! +! Side Effects: ! +! * Header arrays SEC0, SEC1, SEC2, SEC3, SEC4, XEC4, INFOGRID and ! +! INFOGRID are filled. ! +! * The BITMAP array is filled. ! +! * The C unit pointer is advanced to the end of the GRIB record. ! +! ! +! Modules: ! +! MODULE_GRIB ! +! ! +! Externals: ! +! GRIBGET ! +! GRIBHEADER ! +! GRIBDATA ! +! ! +!-----------------------------------------------------------------------------! + use module_grib + + implicit none + + integer :: nunit + integer :: debug_level + integer :: ierr + real, allocatable, dimension(:) :: datarray + integer :: ndata + real, dimension(ndata) :: data + + integer :: ni, nj + + ierr = 0 + + call gribget(nunit, ierr) + if (ierr.ne.0) return + +! Unpack the header information + + call gribheader(debug_level,ierr) + +! Determine the size of the data array from the information in the header, +! and allocate the array DATARRAY to hold that data. + + if (sec2(4).ne.50) then + ni = infogrid(1) + nj = infogrid(2) + allocate(datarray(ni*nj)) + else + ni = (infogrid(1)+1) * (infogrid(1)+2) + nj = 1 + allocate(datarray(ni*nj)) + endif + +! Unpack the data from the GRIB record, and fill the array DATARRAY. + + call gribdata(datarray, ni*nj) + + data(1:ni*nj) = datarray(1:ni*nj) +#if defined (CRAY) +#else + deallocate(grec, datarray) +#endif + +end subroutine gribread +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +subroutine get_sec1(ksec1) +! Return the GRIB Section 1 header information, which has already been +! unpacked by subroutine GRIBHEADER. + use module_grib + integer, dimension(100) :: ksec1 + ksec1 = sec1 +end subroutine get_sec1 +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +subroutine get_sec2(ksec2) +! Return the GRIB Section 2 header information, which has already been +! unpacked by subroutine GRIBHEADER. + use module_grib + integer, dimension(10) :: ksec2 + ksec2 = sec2 +end subroutine get_sec2 +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +subroutine get_gridinfo(iginfo, ginfo) + use module_grib + integer, dimension(40) :: iginfo + real, dimension(40) :: ginfo + iginfo = infogrid + ginfo = gridinfo +end subroutine get_gridinfo +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +subroutine gribprint(isec) + use module_grib + implicit none + integer :: isec + integer :: ou = 6 + character(len=12) :: string = ',t45,":",i8)' + character(len=15) :: rstring = ',t45,":",f12.5)' + + if (isec.eq.0) then + write(*,'(/,"GRIB SECTION 0:")') + write(ou,'(5x,"Grib Length"'//string) sec0(1) + write(ou,'(5x,"Grib Edition"'//string) sec0(2) + else if (isec.eq.1) then + write(*,'(/,"GRIB SECTION 1:")') + write(ou,'(5x,"Length of PDS"'//string) sec1(1) + write(ou,'(5x,"Parameter Table Version"'//string) sec1(2) + write(ou,'(5x,"Center ID"'//string) sec1(3) + write(ou,'(5x,"Process ID"'//string) sec1(4) + write(ou,'(5x,"Grid ID"'//string) sec1(5) + if (sec1(25) == 1) then + write(ou,'(5x,"Is there a Grid Desc. Section (GDS)?",t45,": Yes")') + else if (sec1(25) == 0) then + write(ou,'(5x,"Is there a Grid Desc. Section (GDS)?",t45,": No")') + else + print*, 'Unrecognized sec1(25): ', sec1(25) + endif + if (sec1(26) == 1) then + write(ou,'(5x,"Is there a Bit Map Section (BMS)?",t45,": Yes")') + else if (sec1(26) == 0) then + write(ou,'(5x,"Is there a Bit Map Section (BMS)?",t45,": No")') + else + print*, 'Unrecognized sec1(26): ', sec1(26) + endif + write(ou,'(5x,"Parameter"'//string) sec1(7) + write(ou,'(5x,"Level type"'//string) sec1(8) + if ( (sec1(8) == 101) .or. (sec1(8) == 104) .or. (sec1(8) == 106) .or. & + (sec1(8) == 108) .or. (sec1(8) == 110) .or. (sec1(8) == 112) .or. & + (sec1(8) == 114) .or. (sec1(8) == 116) .or. (sec1(8) == 120) .or. & + (sec1(8) == 121) .or. (sec1(8) == 128) .or. (sec1(8) == 141) ) then + write(ou,'(5x,"Hgt, pres, etc. of layer top "'//string) sec1(9) + write(ou,'(5x,"Hgt, pres, etc. of layer bottom "'//string) sec1(10) + else + write(ou,'(5x,"Height, pressure, etc "'//string) sec1(9) + endif + write(ou,'(5x,"Year"'//string) sec1(11) + write(ou,'(5x,"Month"'//string) sec1(12) + write(ou,'(5x,"Day"'//string) sec1(13) + write(ou,'(5x,"Hour"'//string) sec1(14) + write(ou,'(5x,"Minute"'//string) sec1(15) + write(ou,'(5x,"Forecast time unit"'//string) sec1(16) + write(ou,'(5x,"P1"'//string) sec1(17) + write(ou,'(5x,"P2"'//string) sec1(18) + write(ou,'(5x,"Time Range Indicator"'//string) sec1(19) + write(ou,'(5x,"Number in Ave?"'//string) sec1(20) + write(ou,'(5x,"Number missing from ave?"'//string) sec1(21) + write(ou,'(5x,"Century"'//string) sec1(22) + write(ou,'(5x,"Sub-center"'//string) sec1(23) + write(ou,'(5x,"Decimal scale factor"'//string) sec1(24) + elseif ((isec.eq.2) .and. ((sec1(6).eq.128).or.(sec1(6).eq.192))) then + write(*,'(/,"GRIB SECTION 2:")') + write(ou,'(5x,"Length of GRID Desc. Section"'//string) sec2(1) + if ((sec2(2) /= 0).or.(sec2(3) /= 0) .or. (sec2(4) /= 0)) then + write(ou,'(5x,"Number of V. Coordinate Parms"'//string) sec2(2) + write(ou,'(5x,"List Starting point"'//string) sec2(3) + write(ou,'(5x,"Data Representation type"'//string) sec2(4) + endif + + if (sec2(4).eq.0) then + write(ou,'(5x,"Cylindrical Equidistant Grid")') + write(ou,'(10x,"NI"'//string) infogrid(1) + write(ou,'(10x,"NJ"'//string) infogrid(2) + write(ou,'(10x,"Lat 1"'//rstring) gridinfo(3) + write(ou,'(10x,"Lon 1"'//rstring) gridinfo(4) + write(ou,'(10x,"Resolution and Component:", t45,":",B8.8)') infogrid(5) + write(ou,'(10x,"Lat NI"'//string) infogrid(6) + write(ou,'(10x,"Lon NJ"'//string) infogrid(7) + write(ou,'(10x,"Delta-Lon"'//string) infogrid(8) + write(ou,'(10x,"Delta-Lat"'//string) infogrid(9) + write(ou,'(10x,"Scanning mode"'//string) infogrid(10) + write(ou,'(10x,"I-Scanning increment"'//string) infogrid(21) + write(ou,'(10x,"J-Scanning increment"'//string) infogrid(22) + + else if (sec2(4).eq.1) then + write(ou,'(5x,"Mercator Grid")') + write(ou,'(10x,"NI"'//string) infogrid(1) + write(ou,'(10x,"NJ"'//string) infogrid(2) + write(ou,'(10x,"Lat 1"'//rstring) gridinfo(3) + write(ou,'(10x,"Lon 1"'//rstring) gridinfo(4) + write(ou,'(10x,"Resolution and Component",t45,":", B8.8)') infogrid(5) + write(ou,'(10x,"Lat NI"'//rstring) gridinfo(6) + write(ou,'(10x,"Lon NJ"'//rstring) gridinfo(7) + write(ou,'(10x,"Dx"'//rstring) gridinfo(8) + write(ou,'(10x,"Dy"'//rstring) gridinfo(9) + write(ou,'(10x,"Scanning mode"'//string) infogrid(10) + write(ou,'(10x,"Latin"'//rstring) gridinfo(11) + write(ou,'(10x,"I-Scanning increment"'//string) infogrid(21) + write(ou,'(10x,"J-Scanning increment"'//string) infogrid(22) + + else if (sec2(4).eq.4) then + write(ou,'(5x,"Gaussian Grid")') + write(ou,'(10x,"NI"'//string) infogrid(1) + write(ou,'(10x,"NJ"'//string) infogrid(2) + write(ou,'(10x,"Original (stored) Lat 1"'//rstring) gridinfo(18) + write(ou,'(10x,"Lat 1"'//rstring) gridinfo(3) + write(ou,'(10x,"Lon 1"'//rstring) gridinfo(4) + write(ou,'(10x,"Resolution and Component",t45,":", B8.8)') infogrid(5) + write(ou,'(10x,"Original (stored) Lat NI"'//rstring) gridinfo(17) + write(ou,'(10x,"Lat NI"'//rstring) gridinfo(6) + write(ou,'(10x,"Lon NJ"'//rstring) gridinfo(7) + write(ou,'(10x,"Delta-Lon"'//rstring) gridinfo(8) + write(ou,'(10x,"Delta-Lat"'//rstring) gridinfo(19) + write(ou,'(10x,"Number of lats (pole - eq)"'//string) infogrid(9) + write(ou,'(10x,"Scanning mode"'//string) infogrid(10) + write(ou,'(10x,"I-Scanning increment"'//string) infogrid(21) + write(ou,'(10x,"J-Scanning increment"'//string) infogrid(22) + elseif (sec2(4).eq.3) then + write(ou,'(5x,"Lambert Conformal Grid")') + write(ou,'(10x,"NI"'//string) infogrid(1) + write(ou,'(10x,"NJ"'//string) infogrid(2) + write(ou,'(10x,"Lat 1"'//string) infogrid(3) + write(ou,'(10x,"Lon 1"'//string) infogrid(4) + write(ou,'(10x,"Resolution and Component",t45,":", B8.8)') infogrid(5) + write(ou,'(10x,"Lov"'//string) infogrid(6) + write(ou,'(10x,"Dx"'//string) infogrid(7) + write(ou,'(10x,"Dy"'//string) infogrid(8) + write(ou,'(10x,"Projection center"'//string) infogrid(9) + write(ou,'(10x,"Scanning mode"'//string) infogrid(10) + write(ou,'(10x,"I-Scanning increment"'//string) infogrid(21) + write(ou,'(10x,"J-Scanning increment"'//string) infogrid(22) + write(ou,'(10x,"Latin 1"'//string) infogrid(11) + write(ou,'(10x,"Latin 2"'//string) infogrid(12) + write(ou,'(10x,"Lat of southern pole"'//string) infogrid(13) + write(ou,'(10x,"Lon of southern pole"'//string) infogrid(14) + elseif (sec2(4).eq.5) then + write(ou,'(5x,"Polar Stereographic Grid")') + write(ou,'(10x,"NI"'//string) infogrid(1) + write(ou,'(10x,"NJ"'//string) infogrid(2) + write(ou,'(10x,"Lat 1"'//string) infogrid(3) + write(ou,'(10x,"Lon 1"'//string) infogrid(4) + write(ou,'(10x,"Resolution and Component", t45,":",B8.8)') infogrid(5) + write(ou,'(10x,"Lov"'//string) infogrid(6) + write(ou,'(10x,"Dx"'//string) infogrid(7) + write(ou,'(10x,"Dy"'//string) infogrid(8) + write(ou,'(10x,"Projection center"'//string) infogrid(9) + write(ou,'(10x,"Scanning mode"'//string) infogrid(10) + write(ou,'(10x,"I-Scanning increment"'//string) infogrid(21) + write(ou,'(10x,"J-Scanning increment"'//string) infogrid(22) + elseif (sec2(4).eq.50) then + write(ou,'(5x,"Spherical harmonic components")') + write(ou,'(10x,"J-Pentagonal resolution parm:"'//string) infogrid(1) + write(ou,'(10x,"K-Pentagonal resolution parm:"'//string) infogrid(2) + write(ou,'(10x,"M-Pentagonal resolution parm:"'//string) infogrid(3) + write(ou,'(10x,"Representation type"'//string) infogrid(4) + write(ou,'(10x,"Coefficient storage mode"'//string) infogrid(5) + endif + elseif ((isec.eq.3) .and. (sec1(26).eq.1)) then + write(*,'(/,"GRIB SECTION 3:")') + write(ou,'(5x,"Length of bit map section"'//string) sec3(1) + write(ou,'(5x,"Number of unused bits"'//string) sec3(2) + write(ou,'(5x,"Numeric"'//string) sec3(3) + + elseif (isec.eq.4) then + write(*,'(/,"GRIB SECTION 4:")') + write(ou,'(5x,"Length of BDS"'//string) sec4(1) + write(ou,'(5x,"0/1: grid-point or sph. harm. data"'//string) sec4(2) + write(ou,'(5x,"0/1: simple or complex packing"'//string) sec4(3) + write(ou,'(5x,"0/1: floating or integer"'//string) sec4(4) + write(ou,'(5x,"0/1: No addl flags or addl flags"'//string) sec4(5) + write(ou,'(5x,"Unused bits"'//string) sec4(6) + write(ou,'(5x,"Binary Scale Factor"'//string) sec4(7) + write(ou,'(5x,"Reference Value", t45, ":", F18.8)') xec4(1) + write(ou,'(5x,"Number of bits for packing"'//string) sec4(8) + endif + +end subroutine gribprint +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +subroutine get_bitmap(bm8, ndat) + use module_grib + integer, dimension(ndat) :: bm8 + if ((sec1(6).eq.64).or.(sec1(6).eq.192)) then + bm8 = bitmap + else + bm8 = 1 + endif +end subroutine get_bitmap +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +subroutine gribxyll(x, y, xlat, xlon) + use module_grib + implicit none + + real , intent(in) :: x, y + real , intent(out) :: xlat, xlon + + real :: r, xkm, ykm, y1 + integer :: iscan, jscan + + if (sec2(4).eq.0) then ! Cylindrical equidistant grid + + xlat = gridinfo(3) + gridinfo(9)*(y-1.) + xlon = gridinfo(4) + gridinfo(8)*(x-1.) + + elseif (sec2(4) == 1) then ! Mercator grid + r = grrth*cosd(gtrue1) + xkm = (x-1.)*gridinfo(8) + ykm = (y-1.)*gridinfo(9) + xlon = gridinfo(4) + (xkm/r)*(180./pi) + y1 = r*alog((1.+sind(gridinfo(3)))/cosd(gridinfo(3)))/gridinfo(9) + xlat = 90. - 2. * atan(exp(-gridinfo(9)*(y+y1-1.)/r))*180./pi + + elseif (sec2(4) == 3) then ! Lambert Conformal grid + gclon = gridinfo(6) + r = sqrt((x-1.+gx1)**2 + (y-1+gy1)**2) + xlat = 90. - 2.*atand(tand(45.-gtrue1/2.)* & + ((r*gkappa*gridinfo(7))/(grrth*sind(90.-gtrue1)))**(1./gkappa)) + xlon = atan2d((x-1.+gx1),-(y-1.+gy1))/gkappa + gclon + + elseif (sec2(4) == 5) then ! Polar Stereographic grid + gclon = gridinfo(6) + r = sqrt((x-1.+gx1)**2 + (y-1+gy1)**2) + xlat = 90. - 2.*atan2d((r*gridinfo(7)),(grrth*(1.+sind(gtrue1)))) + xlon = atan2d((x-1.+gx1),-(y-1.+gy1)) + gclon + + elseif (sec2(4) == 4) then ! Gaussian grid + + xlon = gridinfo(4) + gridinfo(8)*(x-1.) + xlat = gridinfo(3) + gridinfo(19)*(y-1.) + + else + write(*,'("Unrecognized projection:", I10)') sec2(4) + write(*,'("STOP in GRIBXYLL")') + stop + endif + +end subroutine gribxyll +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +subroutine gribllxy(xlat, xlon, x, y) + use module_grib + implicit none + real , intent(in) :: xlat, xlon + real , intent(out) :: x, y + + real :: r, y1 + + if (sec2(4) == 0) then ! Cylindrical Equidistant grid + + x = 1. + (xlon-gridinfo(4)) / gridinfo(9) + y = 1. + (xlat-gridinfo(3)) / gridinfo(8) + + else if (sec2(4) == 1) then ! Mercator grid + + r = grrth*cosd(gtrue1) + x = 1.+( (r/gridinfo(8)) * (xlon-gridinfo(4)) * (pi/180.) ) + y1 = (r/gridinfo(9))*alog((1.+sind(gridinfo(3)))/cosd(gridinfo(3))) + y = 1. + ((r/gridinfo(9))*alog((1.+sind(xlat))/cosd(xlat)))-y1 + + else if (sec2(4) == 3) then ! Lambert Conformal grid + gclon = gridinfo(6) + r = grrth/(gridinfo(7)*gkappa)*sind(90.-gtrue1) * & + (tand(45.-xlat/2.)/tand(45.-gtrue1/2.)) ** gkappa + x = r*sind(gkappa*(xlon-gclon)) - gx1 + 1. + y = -r*cosd(gkappa*(xlon-gclon)) - gy1 + 1. + + elseif (sec2(4) == 5) then ! Polar Stereographic grid + gclon = gridinfo(6) + r = grrth/gridinfo(7) * tand((90.-xlat)/2.) * (1.+sind(gtrue1)) + x = ( r * sind(xlon-gclon)) - gx1 + 1. + y = (-r * cosd(xlon-gclon)) - gy1 + 1. + + else + write(*,'("Unrecognized projection:", I10)') sec2(4) + write(*,'("STOP in GRIBLLXY")') + stop + endif + +end subroutine gribllxy +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +subroutine glccone (fsplat,ssplat,sign,confac) + use module_grib + implicit none + real, intent(in) :: fsplat,ssplat + integer, intent(in) :: sign + real, intent(out) :: confac + if (abs(fsplat-ssplat).lt.1.E-3) then + confac = sind(fsplat) + else + confac = log10(cosd(fsplat))-log10(cosd(ssplat)) + confac = confac/(log10(tand(45.-float(sign)*fsplat/2.))- & + log10(tand(45.-float(sign)*ssplat/2.))) + endif +end subroutine glccone +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! +subroutine gribheader(debug_level,ierr) +! +! IERR non-zero means there was a problem unpacking the grib header. +! + use module_grib + implicit none + integer :: debug_level + integer :: ierr + + integer, parameter :: nsec1 = 24 + + integer, dimension(nsec1) :: & + iw1=(/3,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,2,1,1,1,2/) + integer :: icount, iskip, ibts, nbm, nbz, i9skip, i17skip + + integer :: iman, ichar, isign, iscan + + integer, allocatable, dimension(:) :: bm8 + + real :: r + integer :: isvns + integer :: gsvns = 0 + + if (gsvns.eq.0) then + if (mwsize.eq.32) then + gsvns = transfer('7777', gsvns) + elseif(mwsize.eq.64) then + call gbyte_g1(char(0)//char(0)//char(0)//char(0)//'7777', gsvns, 0, mwsize) + endif + endif + +! Section 0: + sec0(2) = ied + if (ied.eq.1) then + call gbyte_g1(grec, sec0(1), 32, 24) + iskip = 64 + elseif (ied.eq.0) then + sec0(1) = gribsize(grec,200, ierr) + iskip = 32 + endif + +! Section 1: + i9skip = iskip + 80 + i17skip = iskip + 144 + do icount = 1, nsec1 - ((1-ied)*6) + ibts = iw1(icount)*8 + call gbyte_g1(grec, sec1(icount), iskip, ibts) + iskip = iskip + ibts + enddo + if (ied.eq.0) sec1(22) = 20 + ! Sec1 indices 9 and 10 might actually be one value, not two. + ! If this is the case, reread sec1(9), and set sec1(10) to zero: + if ( (sec1(8) == 101) .or. (sec1(8) == 104) .or. (sec1(8) == 106) .or. & + (sec1(8) == 108) .or. (sec1(8) == 110) .or. (sec1(8) == 112) .or. & + (sec1(8) == 114) .or. (sec1(8) == 116) .or. (sec1(8) == 120) .or. & + (sec1(8) == 121) .or. (sec1(8) == 128) .or. (sec1(8) == 141) .or. & + (sec1(8) == 236) ) then + ! No action here. + else + call gbyte_g1(grec, sec1(9), i9skip, 16) + sec1(10) = 0. + endif + + if (sec1(24).ge.32768) sec1(24) = 32768-sec1(24) + + ! If the TIME/RANGE INDICATOR (sec1(19)) indicates that the time P1 + ! is spread over two bytes, then recompute sec1(17) and set sec1(18) + ! to zero. + if (sec1(19) == 10) then + call gbyte_g1(grec, sec1(17), i17skip, 16) + sec1(18) = 0 + endif + + ! Pull out single bits from sec1(6) for the GDS and BMS flags: + sec1(25) = sec1(6)/128 + sec1(26) = mod(sec1(6)/64,2) + +! Section 2: +! if ((sec1(6) == 128) .or. (sec1(6) == 192)) then + if (sec1(25) == 1) then + + if (ied.eq.0) then + iskip = 32 + sec1(1)*8 + elseif (ied.eq.1) then + iskip = 64 + sec1(1)*8 + endif + call gbyte_g1(grec, sec2(1), iskip, 24) + iskip = iskip + 24 + call gbytes_g1(grec, sec2(2), iskip, 8, 0, 3) + iskip = iskip + 8*3 + + if (sec2(4) == 0) then + ! Lat/Lon Grid: + call gbytes_g1(grec, infogrid(1), iskip, 16, 0, 2) + iskip = iskip + 32 + call gbytes_g1(grec, infogrid(3), iskip, 24, 0, 2) + iskip = iskip + 48 + call gbyte_g1(grec, infogrid(5), iskip, 8) + iskip = iskip + 8 + call gbytes_g1(grec, infogrid(6), iskip, 24, 0, 2) + iskip = iskip + 48 + call gbytes_g1(grec, infogrid(8), iskip, 16, 0, 2) + iskip = iskip + 32 + call gbyte_g1(grec, infogrid(21), iskip, 1) + infogrid(21) = 1-(infogrid(21)*2) + iskip = iskip + 1 + call gbyte_g1(grec, infogrid(22), iskip, 1) + infogrid(22) = (infogrid(22)*2)-1 + iskip = iskip + 1 + call gbyte_g1(grec, infogrid(10), iskip, 1) + iskip = iskip + 1 + iskip = iskip + 5 + call gbyte_g1(grec, infogrid(11), iskip, 32) + iskip = iskip + 32 + +!MGD if ( debug_level .gt. 100 ) then +!MGD print *, "lat/lon grib grid info", infogrid(1), infogrid(3), & +!MGD infogrid(5), infogrid(6), infogrid(8), infogrid(21), & +!MGD infogrid(22), infogrid(10), infogrid(11), infogrid(8) +!MGD end if + + infogrid(8) = infogrid(8) * infogrid(21) + infogrid(9) = infogrid(9) * infogrid(22) + + gridinfo(1) = float(infogrid(1)) + gridinfo(2) = float(infogrid(2)) + if (infogrid(3).ge.8388608) infogrid(3) = 8388608 - infogrid(3) + if (infogrid(4).ge.8388608) infogrid(4) = 8388608 - infogrid(4) + gridinfo(3) = float(infogrid(3))*0.001 + gridinfo(4) = infogrid(4) * 0.001 + if (infogrid(6).ge.8388608) infogrid(6) = 8388608 - infogrid(6) + if (infogrid(7).ge.8388608) infogrid(7) = 8388608 - infogrid(7) + gridinfo(6) = infogrid(6) * 0.001 + gridinfo(7) = infogrid(7) * 0.001 + gridinfo(8) = infogrid(8) * 0.001 + gridinfo(9) = infogrid(9) * 0.001 + gridinfo(21) = float(infogrid(21)) + gridinfo(22) = float(infogrid(22)) + elseif (sec2(4) == 1) then ! Mercator grid + ! Number of points in X and Y + call gbytes_g1(grec, infogrid(1), iskip, 16, 0, 2) + iskip = iskip + 32 + ! Starting lat and lon + call gbytes_g1(grec, infogrid(3), iskip, 24, 0, 2) + iskip = iskip + 48 + ! "Resolution and component flags" + call gbyte_g1(grec, infogrid(5), iskip, 8) + iskip = iskip + 8 + ! Ending lat and lon + call gbytes_g1(grec, infogrid(6), iskip, 24, 0, 2) + iskip = iskip + 48 + ! Truelat, 3 bytes + call gbyte_g1(grec, infogrid(11), iskip, 24) + iskip = iskip + 24 + ! "Reserved", i.e., skip a byte + iskip = iskip + 8 + ! Scanning mode flags, first three bits of the next byte + ! and skip the last five bits. + call gbyte_g1(grec, infogrid(21), iskip, 1) + infogrid(21) = 1-(infogrid(21)*2) + iskip = iskip + 1 + call gbyte_g1(grec, infogrid(22), iskip, 1) + infogrid(22) = (infogrid(22)*2)-1 + iskip = iskip + 1 + call gbyte_g1(grec, infogrid(10), iskip, 1) + iskip = iskip + 1 + iskip = iskip + 5 + ! Grid increment in X and Y + call gbytes_g1(grec, infogrid(8), iskip, 24, 0, 2) + iskip = iskip + 48 + ! Done reading map specifications. + ! Now do various conversions: + + gridinfo(1) = float(infogrid(1)) ! ok + gridinfo(2) = float(infogrid(2)) ! ok + + if (infogrid(3) .ge.8388608) infogrid(3) = 8388608 - infogrid(3) + if (infogrid(4) .ge.8388608) infogrid(4) = 8388608 - infogrid(4) + if (infogrid(6) .ge.8388608) infogrid(6) = 8388608 - infogrid(6) + if (infogrid(7) .ge.8388608) infogrid(7) = 8388608 - infogrid(7) + if (infogrid(11).ge.8388608) infogrid(11) = 8388608 - infogrid(11) + gridinfo(3) = infogrid(3) * 0.001 + gridinfo(4) = infogrid(4) * 0.001 + gridinfo(6) = infogrid(6) * 0.001 + gridinfo(7) = infogrid(7) * 0.001 + gridinfo(8) = infogrid(8) * 0.001 + gridinfo(9) = infogrid(9) * 0.001 + gridinfo(11) = infogrid(11) * 0.001 + + gridinfo(21) = infogrid(21) + gridinfo(22) = infogrid(22) + + gridinfo(20) = 6370.949 + grrth = gridinfo(20) + gtrue1 = gridinfo(11) + + elseif (sec2(4) == 3) then + if (ied.eq.0) then + print '(//,"*** Despair ***"//)' + stop + endif +! Lambert Conformal: + call gbytes_g1(grec, infogrid(1), iskip, 16, 0, 2) + iskip = iskip + 32 + call gbytes_g1(grec, infogrid(3), iskip, 24, 0, 2) + iskip = iskip + 48 + if (infogrid(3).ge.8388608) infogrid(3) = 8388608 - infogrid(3) + if (infogrid(4).ge.8388608) infogrid(4) = 8388608 - infogrid(4) + call gbyte_g1(grec, infogrid(5), iskip, 8) + iskip = iskip + 8 + call gbytes_g1(grec, infogrid(6), iskip, 24, 0, 3) + if (infogrid(6).ge.8388608) infogrid(6) = 8388608 - infogrid(6) + iskip = iskip + 72 + call gbyte_g1(grec, infogrid(9), iskip, 8) + iskip = iskip + 8 + call gbyte_g1(grec, infogrid(21), iskip, 1) + infogrid(21) = 1-(infogrid(21)*2) + iskip = iskip + 1 + call gbyte_g1(grec, infogrid(22), iskip, 1) + infogrid(22) = (infogrid(22)*2)-1 + iskip = iskip + 1 + call gbyte_g1(grec, infogrid(10), iskip, 1) + iskip = iskip + 1 + iskip = iskip + 5 + call gbytes_g1(grec, infogrid(11), iskip, 24, 0, 4) + if (infogrid(11).ge.8388608) infogrid(11) = 8388608 - infogrid(11) + if (infogrid(12).ge.8388608) infogrid(12) = 8388608 - infogrid(12) + if (infogrid(13).ge.8388608) infogrid(13) = 8388608 - infogrid(13) + if (infogrid(14).ge.8388608) infogrid(14) = 8388608 - infogrid(14) + iskip = iskip + 96 + call gbyte_g1(grec, infogrid(15), iskip, 16) + iskip = iskip + 16 + + infogrid(7) = infogrid(7) * infogrid(21) + infogrid(8) = infogrid(8) * infogrid(22) + + + gridinfo(1) = float(infogrid(1)) + gridinfo(2) = float(infogrid(2)) + gridinfo(3) = infogrid(3) * 0.001 + gridinfo(4) = infogrid(4) * 0.001 + gridinfo(6) = infogrid(6) * 0.001 + gridinfo(7) = infogrid(7) * 0.001 + gridinfo(8) = infogrid(8) * 0.001 + gridinfo(9) = infogrid(9) * 0.001 + gridinfo(11) = infogrid(11) * 0.001 + gridinfo(12) = infogrid(12) * 0.001 + gridinfo(13) = infogrid(13) * 0.001 + gridinfo(14) = infogrid(14) * 0.001 + + gridinfo(20) = 6370 + ! a priori knowledge: + if (sec1(5).eq.212) then + gridinfo(3) = 12.190 + gridinfo(4) = -133.459 + gridinfo(7) = 40.63525 + gridinfo(8) = 40.63525 + gridinfo(20) = 6370 + endif + +!=============================================================================! +! More a priori knowledge: ! +! Correct some bad lat/lon numbers coded into some RUC headers. ! +! ! + if (sec1(3) == 59) then ! If FSL + if (sec1(4) == 86) then ! and RUC + if (sec1(5) == 255) then + ! Check to correct bad lat/lon numbers. + if (infogrid(3) == 16909) then + infogrid(3) = 16281 + gridinfo(3) = 16.281 + endif + if (infogrid(4) == 236809) then + infogrid(4) = 2338622 + gridinfo(4) = 233.8622 + endif + endif + endif + endif +!=============================================================================! + + + gridinfo(21) = float(infogrid(21)) + gridinfo(22) = float(infogrid(22)) + + ! Map parameters + glat1 = gridinfo(3) + glon1 = gridinfo(4) + gclon = gridinfo(6) + if (gclon.gt.180.) gclon = -(360.-gclon) + if ((gclon<0).and.(glon1>180)) glon1 = glon1-360. + gtrue1 = gridinfo(11) + gtrue2 = gridinfo(12) + grrth = gridinfo(20) + call glccone(gtrue1, gtrue2, 1, gkappa) + r = grrth/(gridinfo(7)*gkappa)*sind(90.-gtrue1) * & + (tand(45.-glat1/2.)/tand(45.-gtrue1/2.)) ** gkappa + gx1 = r*sind(gkappa*(glon1-gclon)) + gy1 = -r*cosd(gkappa*(glon1-gclon)) + + elseif (sec2(4) == 4) then + ! Gaussian Grid: + call gbytes_g1(grec, infogrid(1), iskip, 16, 0, 2) + iskip = iskip + 32 + call gbytes_g1(grec, infogrid(3), iskip, 24, 0, 2) + iskip = iskip + 48 + call gbyte_g1(grec, infogrid(5), iskip, 8) + iskip = iskip + 8 + call gbytes_g1(grec, infogrid(6), iskip, 24, 0, 2) + iskip = iskip + 48 + call gbytes_g1(grec, infogrid(8), iskip, 16, 0, 2) + iskip = iskip + 32 + call gbyte_g1(grec, infogrid(21), iskip, 1) + infogrid(21) = 1-(infogrid(21)*2) + iskip = iskip + 1 + call gbyte_g1(grec, infogrid(22), iskip, 1) + infogrid(22) = (infogrid(22)*2)-1 + iskip = iskip + 1 + call gbyte_g1(grec, infogrid(10), iskip, 1) + iskip = iskip + 1 + iskip = iskip + 5 + call gbyte_g1(grec, infogrid(11), iskip, 32) + iskip = iskip + 32 + + infogrid(8) = infogrid(8) * infogrid(21) + + gridinfo(1) = float(infogrid(1)) + gridinfo(2) = float(infogrid(2)) + if (infogrid(3).ge.8388608) infogrid(3) = 8388608 - infogrid(3) + if (infogrid(4).ge.8388608) infogrid(4) = 8388608 - infogrid(4) + gridinfo(3) = float(infogrid(3))*0.001 + gridinfo(4) = infogrid(4) * 0.001 + if (infogrid(6).ge.8388608) infogrid(6) = 8388608 - infogrid(6) + if (infogrid(7).ge.8388608) infogrid(7) = 8388608 - infogrid(7) + gridinfo(6) = infogrid(6) * 0.001 + gridinfo(7) = infogrid(7) * 0.001 + gridinfo(8) = infogrid(8) * 0.001 + gridinfo(21) = float(infogrid(21)) + gridinfo(22) = float(infogrid(22)) + + ! Compute an approximate delta-latitude and starting latitude. + ! Replace the stored value of starting latitude with approximate one. + gridinfo(18) = gridinfo(3) + infogrid(18) = infogrid(3) + gridinfo(17) = gridinfo(6) + infogrid(17) = infogrid(6) +! call griblgg(infogrid(2), gridinfo(3), gridinfo(19)) +! infogrid(19) = nint(gridinfo(19)*1000.) +! infogrid(3) = nint(gridinfo(3)*1000.) + gridinfo(6) = -gridinfo(3) + infogrid(6) = -infogrid(3) + + elseif (sec2(4) == 5) then +! Polar Stereographic Grid + if (ied.eq.0) then + print '(//,"*** Despair ***"//)' + stop + endif + call gbytes_g1(grec, infogrid(1), iskip, 16, 0, 2) ! NX and NY + iskip = iskip + 32 + call gbytes_g1(grec, infogrid(3), iskip, 24, 0, 2) ! LAT1 and LON1 + iskip = iskip + 48 + call gbyte_g1(grec, infogrid(5), iskip, 8) ! Resolution and Component + iskip = iskip + 8 + call gbytes_g1(grec, infogrid(6), iskip, 24, 0, 3) ! LOV, DX, and DY + iskip = iskip + 72 + call gbyte_g1(grec, infogrid(9), iskip, 8) ! Projection center flag + iskip = iskip + 8 + call gbyte_g1(grec, infogrid(21), iskip, 1) + infogrid(21) = 1-(infogrid(21)*2) + iskip = iskip + 1 + call gbyte_g1(grec, infogrid(22), iskip, 1) + infogrid(22) = (infogrid(22)*2)-1 + iskip = iskip + 1 + call gbyte_g1(grec, infogrid(10), iskip, 1) + iskip = iskip + 1 + iskip = iskip + 5 +! call gbyte_g1(grec, infogrid(11), iskip, 32) ! Set to 0 (reserved) + iskip = iskip + 32 + + if (infogrid(3).ge.8388608) infogrid(3) = 8388608 - infogrid(3) + if (infogrid(4).ge.8388608) infogrid(4) = 8388608 - infogrid(4) + if (infogrid(6).ge.8388608) infogrid(6) = 8388608 - infogrid(6) + + + infogrid(7) = infogrid(7) * infogrid(21) + infogrid(8) = infogrid(8) * infogrid(22) + + gridinfo(1) = float(infogrid(1)) + gridinfo(2) = float(infogrid(2)) + gridinfo(3) = infogrid(3) * 0.001 + gridinfo(4) = infogrid(4) * 0.001 + gridinfo(6) = infogrid(6) * 0.001 + gridinfo(7) = infogrid(7) * 0.001 + gridinfo(8) = infogrid(8) * 0.001 + + gridinfo(20) = 6370 + + ! a priori knowledge: + if (sec1(5).eq.240) then + gridinfo(3) = 22.7736 + gridinfo(4) = -120.376 + gridinfo(7) = 4.7625 + gridinfo(8) = 4.7625 + gridinfo(20) = 6370 + endif + + ! Map parameters + glat1 = gridinfo(3) + glon1 = gridinfo(4) + gclon = gridinfo(6) + if (gclon.gt.180.) gclon = -(360.-gclon) + ! GRIB edition 1 Polar Stereographic grids are true at 60 degrees + ! Which hemisphere depends on infogrid(9), the "Projection Center Flag" + grrth = gridinfo(20) + if (infogrid(9) > 127) then + gtrue1 = -60. + r = grrth/gridinfo(7) * tand((-90.-glat1)/2.) * (1.+sind(-gtrue1)) + gx1 = -r * sind(glon1-gridinfo(6)) + gy1 = -r * cosd(glon1-gridinfo(6)) + else + gtrue1 = 60. + r = grrth/gridinfo(7) * tand((90.-glat1)/2.) * (1.+sind(gtrue1)) + gx1 = r * sind(glon1-gridinfo(6)) + gy1 = -r * cosd(glon1-gridinfo(6)) + endif + + gridinfo(21) = float(infogrid(21)) + gridinfo(22) = float(infogrid(22)) + + elseif (sec2(4) == 50) then +! Spherical harmonic coefficients + if (ied.eq.0) then + print '(//,"*** Despair ***"//)' + stop + endif + call gbytes_g1(grec, infogrid(1), iskip, 16, 0, 3) + iskip = iskip + 48 + call gbytes_g1(grec, infogrid(4), iskip, 8, 0, 2) + iskip = iskip + 16 + + iskip = iskip + 18*8 + + else + call gribprint(0) + call gribprint(1) + call gribprint(2) + call gribprint(3) + call gribprint(4) + write(*,'("Unrecognized grid: ", i8)') sec2(4) + write(*,'("This grid is not currently supported.")') + write(*,'("Write your own program to put the data to the intermediate format")') + stop + endif + + endif + +! Section 3 + if ((sec1(6).eq.64).or.(sec1(6).eq.192)) then + if (ied.eq.0) then + print '(//,"*** Despair ***"//)' + stop + endif + + if (ied.eq.0) then + iskip = 32 + sec1(1)*8 + sec2(1)*8 + elseif (ied.eq.1) then + iskip = 64 + sec1(1)*8 + sec2(1)*8 + endif + call gbyte_g1(grec, sec3(1), iskip, 24) + iskip = iskip + 24 + call gbyte_g1(grec, sec3(2), iskip, 8) + iskip = iskip + 8 + call gbyte_g1(grec, sec3(3), iskip, 16) + iskip = iskip + 16 + +#if defined (CRAY) +#else + allocate(bitmap((sec3(1)-6)*8)) +#endif + allocate(bm8((sec3(1)-6)*8)) + call gbytes_g1(grec, bm8, iskip, 1, 0, (sec3(1)-6)*8) + bitmap(1:size(bm8)) = bm8(1:size(bm8)) + deallocate(bm8) + iskip = iskip + sec3(1)-6 + else + sec3 = 0 + endif + +! Section 4 + if ((sec1(6).eq.128).or.(sec1(6).eq.192)) then + if (ied.eq.0) then + iskip = 32 + sec1(1)*8 + sec2(1)*8 + sec3(1)*8 + elseif (ied.eq.1) then + iskip = 64 + sec1(1)*8 + sec2(1)*8 + sec3(1)*8 + endif + call gbyte_g1(grec, sec4(1), iskip, 24) + if (sec4(1) > (sec0(1) - sec1(1) - sec2(1) - sec3(1) - 4)) then + write(*,'(/,"*** I have good reason to believe that this GRIB record is")') + write(*,'("*** corrupted or miscoded.",/)') + ierr = 1 + return + endif + iskip = iskip + 24 + call gbytes_g1(grec, sec4(2), iskip, 1,0,4) + iskip = iskip + 4 + call gbyte_g1(grec, sec4(6), iskip, 4) + iskip = iskip + 4 +! Get the binary scale factor + call gbyte_g1(grec, isign, iskip, 1) + iskip = iskip + 1 + call gbyte_g1(grec, sec4(7), iskip, 15) + iskip = iskip + 15 + sec4(7) = sec4(7) * (-2*isign+1) +! Get the reference value: + call gbyte_g1(grec, isign, iskip, 1) + iskip = iskip + 1 + isign = -2*isign+1 + call gbyte_g1(grec, ichar, iskip, 7) + iskip = iskip + 7 + call gbyte_g1(grec, iman, iskip, 24) + iskip = iskip + 24 + if ( iman .ne. 0 ) then + xec4(1) = float(isign) * (2.**(-24)) * float(iman) * & + (16.**(ichar-64)) + else + xec4(1) = 0. + endif + + call gbyte_g1(grec,sec4(8), iskip, 8) +! sec4(8) is the number of bits used per datum value. +! If sec4(8) = 255, assume they mean sec4(8) = 0 + if (sec4(8) == 255) sec4(8) = 0 + iskip = iskip + 8 + endif + +! Section 5 + call gbyte_g1(grec, isvns, ((sec0(1)-4)*8), 32) + if (isvns.ne.gsvns) then + write(*, '("End-of-record mark (7777) not found", 2I10)') isvns + write(*, '("Sec0(1) = ", I8, i2)') sec0(1), sevencount + sevencount = sevencount + 1 + if (sevencount > 10) then + write(*,'(//," *** Found more than 10 consecutive bad GRIB records")') + write(*,'(" *** Let''s just stop now.",//)') + write(*,'(" Perhaps the analysis file should have been converted",/,& + &" from COS-Blocked format?",//)') + stop + endif + else + sevencount = 0 + endif + + ierr = 0 + +end subroutine gribheader +! +!=============================================================================! +!=============================================================================! +!=============================================================================! +! + subroutine gribdata(datarray, ndat) + +!-----------------------------------------------------------------------------! +! ! +! Read and unpack the data from a GRIB record. ! +! ! +! Input: ! +! NDAT: The size of the data array we expect to unpack. ! +! ! +! Output: ! +! DATARRAY: The unpacked data from the GRIB record ! +! ! +! Side Effects: ! +! STOP if it cannot unpack the data. ! +! ! +! Externals: ! +! SGUP_BITMAP ! +! SGUP_NOBITMAP ! +! CSHUP ! +! ! +! Modules: ! +! MODULE_GRIB ! +! ! +!-----------------------------------------------------------------------------! + use module_grib + + implicit none + + integer :: ndat + real , dimension(ndat) :: datarray + integer, dimension(ndat) :: IX + + integer :: iskip, nbm + + if (sec4(2) == 0) then ! Grid-point data + if (sec4(3).eq.0) then ! Simple unpacking + if ((sec1(6).eq.64).or.(sec1(6).eq.192)) then ! There is a bitmap + call SGUP_BITMAP(datarray, ndat) + else + call SGUP_NOBITMAP(datarray, ndat) + endif + else + write(*,'(//,"***** No complex unpacking of gridpoint data.")') + write(*,'("***** Option not yet available.",//)') +! write(*,'("***** Complain to mesouser@ucar.edu",//)') + stop + endif + else + if (sec4(3).eq.0) then ! Simple unpacking + write(*,'(//,"***** No simple unpacking of spherical-harmonic coefficients.")') + write(*,'("***** Option not yet available.",//)') +! write(*,'("***** Complain to mesouser@ucar.edu",//)') + stop + elseif (sec4(3).eq.1) then + call CSHUP(datarray, ndat) + endif + endif + +end subroutine gribdata + +subroutine deallogrib +! Deallocates a couple of arrays that may be allocated. + use module_grib +#if defined (CRAY) +#else + if (allocated(grec)) deallocate(grec) + if (allocated(bitmap)) deallocate(bitmap) +#endif +end subroutine deallogrib + +SUBROUTINE gribLGG( NLAT, startlat, deltalat ) + + + implicit none +! +! LGGAUS finds the Gaussian latitudes by finding the roots of the +! ordinary Legendre polynomial of degree NLAT using Newtons +! iteration method. +! +! On entry: + integer NLAT ! the number of latitudes (degree of the polynomial) +! +! On exit: for each Gaussian latitude + + double precision, dimension(NLAT) :: LATG ! Latitude + +! Approximations to a regular latitude grid: + real :: deltalat + real :: startlat + +!----------------------------------------------------------------------- + + integer :: iskip = 15 + double precision :: sum1 = 0. + double precision :: sum2 = 0. + double precision :: sum3 = 0. + double precision :: sum4 = 0. + double precision :: xn + + integer, save :: SAVE_NLAT = -99 + real, save :: save_deltalat = -99. + real, save :: save_startlat = -99. + + double precision, dimension(nlat) :: COSC, SINC + double precision, parameter :: PI = 3.141592653589793 +! +! -convergence criterion for iteration of cos latitude + double precision, parameter :: XLIM = 1.0E-14 + integer :: nzero, i, j + double precision :: fi, fi1, a, b, g, gm, gp, gt, delta, c, d + + if (nlat == save_nlat) then + deltalat = save_deltalat + startlat = save_startlat + return + endif +! +! -the number of zeros between pole and equator + NZERO = NLAT/2 +! +! -set first guess for cos(colat) + DO I=1,NZERO + COSC(I) = SIN( (I-0.5)*PI/NLAT + PI*0.5 ) + ENDDO +! +! -constants for determining the derivative of the polynomial + FI = NLAT + FI1 = FI+1.0 + A = FI*FI1 / SQRT(4.0*FI1*FI1-1.0) + B = FI1*FI / SQRT(4.0*FI*FI-1.0) +! +! -loop over latitudes, iterating the search for each root + DO I=1,NZERO + J=0 +! +! -determine the value of the ordinary Legendre polynomial for +! -the current guess root + LOOP30 : DO + CALL LGORD( G, COSC(I), NLAT ) +! +! -determine the derivative of the polynomial at this point + CALL LGORD( GM, COSC(I), NLAT-1 ) + CALL LGORD( GP, COSC(I), NLAT+1 ) + GT = (COSC(I)*COSC(I)-1.0) / (A*GP-B*GM) +! +! -update the estimate of the root + DELTA = G*GT + COSC(I) = COSC(I) - DELTA +! +! -if convergence criterion has not been met, keep trying + J = J+1 + IF( ABS(DELTA).LE.XLIM ) EXIT LOOP30 + ENDDO LOOP30 + ENDDO +! +! Determine the sin(colat) + SINC(1:NZERO) = SIN(ACOS(COSC(1:NZERO))) +! +! -if NLAT is odd, set values at the equator + IF( MOD(NLAT,2) .NE. 0 ) THEN + I = NZERO+1 + SINC(I) = 1.0 + latg(i) = 0. + END IF + +! Set the latitudes. + + latg(1:NZERO) = dacos(sinc(1:NZERO)) * 180. / pi + +! Determine the southern hemisphere values by symmetry + do i = 1, nzero + latg(nlat-nzero+i) = -latg(nzero+1-i) + enddo + + +! Now that we have the true values, find some approximate values. + + xn = float(nlat-iskip*2) + do i = iskip+1, nlat-iskip + sum1 = sum1 + latg(i)*float(i) + sum2 = sum2 + float(i) + sum3 = sum3 + latg(i) + sum4 = sum4 + float(i)**2 + enddo + + b = (xn*sum1 - sum2*sum3) / (xn*sum4 - sum2**2) + a = (sum3 - b * sum2) / xn + + deltalat = sngl(b) + startlat = sngl(a + b) + + save_nlat = nlat + save_deltalat = deltalat + save_startlat = startlat + +contains + SUBROUTINE LGORD( F, COSC, N ) + implicit none +! +! LGORD calculates the value of an ordinary Legendre polynomial at a +! latitude. +! +! On entry: +! COSC - cos(colatitude) +! N - the degree of the polynomial +! +! On exit: +! F - the value of the Legendre polynomial of degree N at +! latitude asin(COSC) + double precision :: s1, c4, a, b, fk, f, cosc, colat, c1, fn, ang + integer :: n, k + +!------------------------------------------------------------------------ + + colat = acos(cosc) + c1 = sqrt(2.0) + do k=1,n + c1 = c1 * sqrt( 1.0 - 1.0/(4*k*k) ) + enddo + fn = n + ang= fn * colat + s1 = 0.0 + c4 = 1.0 + a =-1.0 + b = 0.0 + do k=0,n,2 + if (k.eq.n) c4 = 0.5 * c4 + s1 = s1 + c4 * cos(ang) + a = a + 2.0 + b = b + 1.0 + fk = k + ang= colat * (fn-fk-2.0) + c4 = ( a * (fn-b+1.0) / ( b * (fn+fn-a) ) ) * c4 + enddo + f = s1 * c1 + end subroutine lgord + +END SUBROUTINE GRIBLGG + +SUBROUTINE REORDER_IT (a, nx, ny, dx, dy, iorder) + + use module_debug + + implicit none + integer :: nx, ny, iorder + integer :: i, j, k, m + real :: dx, dy + real, dimension(nx*ny) :: a, z + + if (iorder .eq. 0 .and. dx .gt. 0. .and. dy .lt. 0) return + k = 0 + call mprintf(.true.,DEBUG, & + "Reordering GRIB array : dx = %f , dy = %f , iorder = %i", & + f1=dx,f2=dy,i1=iorder) + if (iorder .eq. 0 ) then + if ( dx .lt. 0 .and. dy .lt. 0. ) then + do j = 1, ny + do i = nx, 1, -1 + k = k + 1 + m = i * j + z(k) = a(m) + enddo + enddo + else if ( dx .lt. 0 .and. dy .gt. 0. ) then + do j = ny, 1, -1 + do i = nx, 1, -1 + k = k + 1 + m = i * j + z(k) = a(m) + enddo + enddo + else if ( dx .gt. 0 .and. dy .gt. 0. ) then + do j = ny, 1, -1 + do i = 1, nx + k = k + 1 + m = i * j + z(k) = a(m) + enddo + enddo + endif + else + if ( dx .gt. 0 .and. dy .lt. 0. ) then + do i = 1, nx + do j = 1, ny + k = k + 1 + m = i * j + z(k) = a(m) + enddo + enddo + else if ( dx .lt. 0 .and. dy .lt. 0. ) then + do i = nx, 1, -1 + do j = 1, ny + k = k + 1 + m = i * j + z(k) = a(m) + enddo + enddo + else if ( dx .lt. 0 .and. dy .lt. 0. ) then + do i = nx, 1, -1 + do j = ny, 1, -1 + k = k + 1 + m = i * j + z(k) = a(m) + enddo + enddo + else if ( dx .gt. 0 .and. dy .gt. 0. ) then + do i = 1, nx + do j = ny, 1, -1 + k = k + 1 + m = i * j + z(k) = a(m) + enddo + enddo + endif + endif +! now put it back in the 1-d array and reset the dx and dy + do k = 1, nx*ny + a(k) = z(k) + enddo + dx = abs ( dx) + dy = -1 * abs(dy) + return +END SUBROUTINE REORDER_IT diff --git a/WPS/ungrib/src/gridinfo.F b/WPS/ungrib/src/gridinfo.F new file mode 100644 index 00000000..bc9a4fd3 --- /dev/null +++ b/WPS/ungrib/src/gridinfo.F @@ -0,0 +1,42 @@ +!*****************************************************************************! +! MODULE GRIDINFO ! +! ! +! Purpose: ! +! Hold information about the map projection of data we read from the ! +! analysis files. We pass around the grid information through this ! +! module, rather than through argument lists. ! +! ! +! Variable MAP is defined to be of type MAPINFO, where MAPINFO is defined ! +! within this module: ! +! ! +!*****************************************************************************! +module gridinfo + type mapinfo + character (len=32) :: source + integer :: igrid ! Integer referring to the type of map projection: + ! 0 = lat/lon + ! 3 = Lambert Conformal + ! 5 = Polar Stereographic grid. + ! 6 = Cassini grid. + integer :: nx ! Number of points in the X direction. + integer :: ny ! Number of points in the Y direction. + real :: truelat1 ! First true latitude (for Polar Stereo. and Lam. Conf.) + real :: truelat2 ! Second true latitude (for Lambt. Conformal). + real :: lov ! Central longitude of projection (PS and LC). + character (len=8) :: startloc ! "CENTER " or "SWCORNER" + real :: lat1 ! Starting latitude + real :: lon1 ! Starting longitude + real :: lat0 ! central latitude + real :: lon0 ! central longitude + real :: dx ! grid-spacing in the X direction (km or degrees) + real :: dy ! grid-spacing in the Y direction (km or degrees) + ! + ! The following are WPS extensions (intermediate format version 5) + logical :: grid_wind ! Winds are grid_relative (true) or earth-realtive(false) + real :: r_earth ! Radius of a spherical earth + end type mapinfo + + type (mapinfo) :: map + +end module gridinfo + diff --git a/WPS/ungrib/src/misc_definitions_module.F b/WPS/ungrib/src/misc_definitions_module.F new file mode 120000 index 00000000..d50acad4 --- /dev/null +++ b/WPS/ungrib/src/misc_definitions_module.F @@ -0,0 +1 @@ +../../geogrid/src/misc_definitions_module.F \ No newline at end of file diff --git a/WPS/ungrib/src/module_datarray.F b/WPS/ungrib/src/module_datarray.F new file mode 100644 index 00000000..6bb17aea --- /dev/null +++ b/WPS/ungrib/src/module_datarray.F @@ -0,0 +1,13 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! MODULE DATARRAY +! +! Purpose: To make allocatable arrays available to subroutines. +! +! Why? -- We do this so that an array can be allocated within a subroutine, +! and the caller can make use of the array afterward. +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +module datarray + + real, allocatable, dimension(:) :: rdatarray + +end module datarray diff --git a/WPS/ungrib/src/module_debug.F b/WPS/ungrib/src/module_debug.F new file mode 120000 index 00000000..3a5a2ea5 --- /dev/null +++ b/WPS/ungrib/src/module_debug.F @@ -0,0 +1 @@ +../../geogrid/src/module_debug.F \ No newline at end of file diff --git a/WPS/ungrib/src/module_stringutil.F b/WPS/ungrib/src/module_stringutil.F new file mode 100644 index 00000000..d6d23657 --- /dev/null +++ b/WPS/ungrib/src/module_stringutil.F @@ -0,0 +1,115 @@ +module stringutil + +!BUG: STRSIZE should be as large as the longest string length used in WPS + integer, parameter :: STRSIZE = 1024 + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: despace + ! + ! Purpose: Returns a string containing the path to the file specified by s. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + function get_path(s) + + implicit none + + ! Arguments + character (len=*) :: s + + ! Return value + character (len=STRSIZE) :: get_path + + ! Local variables + integer :: n, i + + n = len(s) + + if (n > STRSIZE) then + write(6,*) 'ERROR: Maximum string length exceeded in get_path()' + stop + end if + + write(get_path,'(a)') './' + + do i=n,1,-1 + if (s(i:i) == '/') then + write(get_path,'(a)') s(1:i) + exit + end if + end do + + end function get_path + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: despace + ! + ! Purpose: Remove all space and tab characters from a string, thus compressing + ! the string to the left. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine despace(string) + + implicit none + + ! Arguments + character (len=*), intent(inout) :: string + + ! Local variables + integer :: i, j, length, iquoted + + length = len(string) + + iquoted = 0 + j = 1 + do i=1,length + ! Check for a quote mark + if (string(i:i) == '"' .or. string(i:i) == '''') iquoted = mod(iquoted+1,2) + + ! Check for non-space, non-tab character, or if we are inside quoted text + if ((string(i:i) /= ' ' .and. string(i:i) /= achar(9)) .or. iquoted == 1) then + string(j:j) = string(i:i) + j = j + 1 + end if + end do + + do i=j,length + string(i:i) = ' ' + end do + + end subroutine despace + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: right_justify + ! + ! Purpose: The non-space characters in s are shifted so that they end at + ! position n. The argument s is modified, so if the original string + ! must be preserved, a copy should be passed to right_justify. + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine right_justify(s,n) + + implicit none + + ! Arguments + integer, intent(in) :: n + character (len=*), intent(inout) :: s + + ! Local variables + integer :: i, l + + l = len_trim(s) + + if (l >= n) return + + do i=l,1,-1 + s(i+n-l:i+n-l) = s(i:i) + end do + + do i=1,n-l + s(i:i) = ' ' + end do + + end subroutine right_justify + +end module stringutil diff --git a/WPS/ungrib/src/new_storage.F b/WPS/ungrib/src/new_storage.F new file mode 100644 index 00000000..1651a866 --- /dev/null +++ b/WPS/ungrib/src/new_storage.F @@ -0,0 +1,496 @@ +module storage_module + use gridinfo + use module_debug + implicit none + private + public :: get_storage + public :: get_dims + public :: get_plvls + public :: put_storage + public :: llstor_start + public :: clear_storage + public :: refr_storage + public :: refw_storage + public :: is_there + public :: print_storage + public :: setll + public :: getll + + integer, parameter :: idlen = 8 + integer :: verbose = 0 ! 0 = no prints; 1 = some prints; 2 = more; etc. + + type node2 + character(len=idlen) :: id + real, pointer, dimension(:,:) :: data2d + type(mapinfo) :: data_map + type(node2), pointer :: next + end type node2 + + type node1 + integer :: id + type(node1), pointer :: next + type(node2), pointer :: first + end type node1 + + type(node1), target :: root + type(node1), pointer :: nnode + type(node2), pointer :: current + type(node2), pointer :: hold + type(node1), pointer :: holdnn + + integer, public :: iferr + +contains + + subroutine llstor_start(icode) + implicit none + integer, intent(in) :: icode +! +! First, check to see that the list ICODE has not already been started: +! + nnode => root + SEARCH : do while (associated(nnode%next)) + nnode => nnode%next + if (nnode%id == icode) then + if (verbose.gt.0) write(*,& + '(/,"LLSTOR_START: NNODE EXISTS, not starting ", I8, /)') icode + return + endif + enddo SEARCH +! +! Since it is a new ICODE, add it to the list of lists: +! + allocate(nnode%next) + nnode => nnode%next + nnode%id = icode + if (verbose.gt.0) write(*, '(/,"NNODE%ID = ", I8, /)') nnode%id + allocate(nnode%first) + nnode%first%id = 'Root' + nullify(nnode%first%next) + nullify (nnode%next) + end subroutine llstor_start + + subroutine clear_storage + implicit none + + if (verbose > 0) then + print*, 'Call clear_storage.' + endif + + SEARCH : do + + nnode => root + SCANF : do while (associated(nnode%next)) + holdnn => nnode + nnode => nnode%next + enddo SCANF + if (nnode%id == 0) exit SEARCH + + N2: do + current => nnode%first + do while (associated(current%next)) + hold => current + current => current%next + enddo + if (current%id /= "Root") then + if (associated(current%data2d)) then + if (verbose > 0) then + print*, 'Deallocating and nullifying 2d.', & + nnode%id, current%id + endif + deallocate(current%data2d) + nullify(current%data2d) + endif + endif + nullify(hold%next) + if (current%id == nnode%first%id) then + deallocate(current) + nullify(current) + exit N2 + endif + enddo N2 + nullify(holdnn%next) + + enddo SEARCH + + end subroutine clear_storage + + subroutine find_node1(inname) + implicit none + integer :: inname, name + name = inname + nnode => root + SEARCH : do while (associated(nnode%next)) + nnode => nnode%next + if (nnode%id == name) then + iferr = 0 + return + endif + enddo SEARCH + if (verbose > 0) then + print '("FIND_NODE1: Name not found: ", I8)', name + endif + iferr = 1 + end subroutine find_node1 + + + subroutine get_plvls(plvl, maxlvl, nlvl) + implicit none + integer :: maxlvl, nlvl + real, dimension(maxlvl) :: plvl + integer :: nn + + nnode => root + nlvl = 0 + plvl = -99999 + SEARCH : do while (associated(nnode%next)) + nnode => nnode%next + nlvl = nlvl + 1 + LEVLOOP : do nn = 1, nlvl + if (nnode%id > plvl(nn)) then + plvl(nn+1:maxlvl) = plvl(nn:maxlvl-1) + plvl(nn) = float(nnode%id) + exit LEVLOOP + endif + enddo LEVLOOP + enddo SEARCH + end subroutine get_plvls + + subroutine put_storage(icode, inname, data, idum, jdum) + implicit none + character(len=*) :: inname + character(len=idlen) :: name + integer :: idum, jdum + integer :: icode + real, dimension(:,:) :: data + + name = inname + + if (verbose>0) print*, 'Put Storage: ' + + call find_node1(icode) + if (iferr /= 0) then + call llstor_start(icode) + endif + current => nnode%first + + SEARCH : do while (associated(current%next)) + current => current%next + if (current%id == name) then + current%data2d = data + current%data_map = map + if (verbose.gt.0) write(*,'("PUT_STORAGE: Overwriting ", A,& + &" to ID ", I8, " Value: ", F16.6)') current%id, nnode%id,& + data(1,1) + return + endif + enddo SEARCH + allocate(current%next) + current => current%next + current%id = name + allocate(current%data2d(size(data,1),size(data,2))) + current%data2d = data + current%data_map = map + nullify (current%next) + if (verbose.gt.0) write(*,'("PUT_STORAGE: Writing ", A,& + &" to ID ", I8, " Value: ", F16.6)') current%id, nnode%id, data(1,1) + + end subroutine put_storage + + subroutine refw_storage(icode, name, Pdata, idum, jdum) + implicit none + character(len=*) :: name + integer :: icode + integer :: idum, jdum + real, pointer, dimension(:,:) :: Pdata + + call find_node1(icode) + if (iferr /= 0) then + call llstor_start(icode) + endif + current => nnode%first + + SEARCH : do while (associated(current%next)) + current => current%next + if (current%id == name) then + if (associated(current%data2d)) then + deallocate(current%data2d) + nullify(current%data2d) + endif + current%data2d => Pdata + current%data_map = map + if (verbose.gt.0) write(*,'("REFW_STORAGE: OverWriting ", A,& + &" to ID ", I8, " Value: ", F16.6)') current%id, nnode%id,& + current%data2d(1,1) + return + endif + enddo SEARCH + allocate(current%next) + current => current%next + current%id = name + nullify(current%data2d) + current%data2d => Pdata + current%data_map = map + nullify(current%next) + + if (verbose.gt.0) write(*,'("REFW_STORAGE: Writing ", A,& + &" to ID ", I8, " Value: ", F16.6)') current%id, nnode%id,& + current%data2d(1,1) + + end subroutine refw_storage + + subroutine get_storage(icode, name, data, idum, jdum) + implicit none + character(len=*) :: name + integer :: icode + integer :: idum, jdum + real, dimension(:,:) :: data + + call find_node1(icode) + if (iferr /= 0) then + print*, 'Cannot find code ', icode, ' in routine GET_STORAGE.' + stop 'GET_STORAGE_code' + endif + current => nnode%first + + SEARCH : do while (associated(current%next)) + current => current%next + if (current%id == name) then + data = current%data2d + map = current%data_map + if (verbose.gt.0) write(*,'("GET_STORAGE: READING ", A,& + &" at ID ", I8, " Value: ", F16.6)') current%id, nnode%id,& + & data(1,1) + return + endif + enddo SEARCH + write(*,'("GET_STORAGE : NAME not found: ", A)') name + + end subroutine get_storage + + subroutine refr_storage(icode, name, Pdata, idum, jdum) + implicit none + character(len=*) :: name + integer :: icode + integer :: idum, jdum + real, pointer, dimension(:,:) :: Pdata + + call find_node1(icode) + if (iferr /= 0) then + print*, 'Cannot find code ', icode, ' in routine REFR_STORAGE.' + STOP 'REFR_STORAGE_code' + endif + current => nnode%first + + SEARCH : do while (associated(current%next)) + current => current%next + if (current%id == name) then + Pdata => current%data2d + map = current%data_map + if (verbose.gt.0) write(*,'("REFR_STORAGE: Referencing ", A,& + &" at ID ", I8, " Value: ", F16.6)') current%id, nnode%id,& + Pdata(1,1) + return + endif + enddo SEARCH + print '("REFR_STORAGE : NAME not found: ", A)', name + + end subroutine refr_storage + + subroutine llstor_remove(icode, name) + implicit none + character(len=*) :: name + integer :: icode + + call find_node1(icode) + if (iferr /= 0) then + STOP 'find_node1' + endif + current => nnode%first + + do while (current%id /= name ) + if (.not. associated(current%next)) then + print*, 'Not there : ', name + return + endif + hold => current + current => current%next + enddo + + if (associated(current%data2d)) then + deallocate(current%data2d) + endif + nullify(hold%next) + hold%next => current%next + nullify(current%next) + nullify(current) + + end subroutine llstor_remove + + subroutine get_dims(icode, name) + implicit none + character(len=*) :: name + integer :: icode + + call find_node1(icode) + if (iferr /= 0) then + STOP 'get_dims' + end if + current => nnode%first + + SEARCH : do while (associated(current%next)) + current => current%next + if (current%id == name) then + map = current%data_map + return + endif + enddo SEARCH + + end subroutine get_dims + + subroutine print_storage(icode) + implicit none + integer :: isz + integer, optional :: icode + + if (present(icode)) then + call find_node1(icode) + if (iferr /= 0) then + STOP 'print_storage' + end if +! print '("PRINT_NODE1: id = ", I8)' , nnode%id + call mprintf(.true.,DEBUG,"PRINT_NODE1: id = %i ",i1=nnode%id) + current => nnode%first + +! print* + call mprintf(.true.,DEBUG,' ',newline=.true.) + if (.not. associated(current)) then +! print '("Nothing there.")' + call mprintf(.true.,DEBUG,"Nothing there. ") + return + endif + do while ( associated(current%next)) + if (current%id == 'Root') then +! print*, 'id = ', current%id + call mprintf(.true.,DEBUG," id = %s ",s1=current%id) + elseif (current%id /= 'Root') then + + if (associated(current%data2d)) then + isz = size(current%data2d) +! print*, current%id, ' = ', current%data2d(1,1) + call mprintf(.true.,DEBUG," %s = %f ",s1=current%id,f1=current%data2d(1,1)) + endif + + endif + current => current%next + enddo + if (current%id == 'Root') then +! print*, 'id = ', current%id + call mprintf(.true.,DEBUG," id = %s ",s1=current%id) + elseif (current%id /= 'Root') then + if (associated(current%data2d)) then + isz = size(current%data2d) +! print*, current%id, ' = ', current%data2d(1,1) + call mprintf(.true.,DEBUG," %s = %f ",s1=current%id,f1=current%data2d(1,1)) + endif + endif + current => current%next +! print* + call mprintf(.true.,DEBUG,' ',newline=.true.) + + else + nnode => root + do while (associated(nnode%next)) + nnode => nnode%next +! print '("PRINT_NODE1: id = ", I8)' , nnode%id + call mprintf(.true.,DEBUG,"PRINT_NODE1: id = %i ",i1=nnode%id) + + current => nnode%first + +! print* + call mprintf(.true.,DEBUG,' ',newline=.true.) + if (.not. associated(current)) then +! print '("Nothing there.")' + call mprintf(.true.,DEBUG,"Nothing there. ") + return + endif + do while ( associated(current%next)) + if (current%id == 'Root') then +! print*, 'id = ', current%id + call mprintf(.true.,DEBUG," id = %s ",s1=current%id) + elseif (current%id /= 'Root') then + if (associated(current%data2d)) then + isz = size(current%data2d) +! print*, current%id, ' = ', current%data2d(1,1), isz + call mprintf(.true.,DEBUG," %s = %f isz = %i", & + s1=current%id,f1=current%data2d(1,1),i1=isz) + endif + endif + current => current%next + enddo + if (current%id == 'Root') then +! print*, 'id = ', current%id + call mprintf(.true.,DEBUG," id = %s ",s1=current%id) + elseif (current%id /= 'Root') then + if (associated(current%data2d)) then + isz = size(current%data2d) +! print*, current%id, ' = ', current%data2d(1,1), isz + call mprintf(.true.,DEBUG," %s = %f isz = %i", & + s1=current%id,f1=current%data2d(1,1),i1=isz) + endif + endif + current => current%next +! print* + call mprintf(.true.,DEBUG,' ',newline=.true.) + + enddo + endif + end subroutine print_storage + + logical function is_there(icode, name) RESULT(answer) + implicit none + character(len=*) :: name + integer :: icode + + answer = .FALSE. + + if (verbose > 0) then + write(*,'("Is there ",A," at ", i8, "?")', advance="NO") name, icode + endif + + call find_node1(icode) + if (iferr /= 0) go to 1000 + + current => nnode%first + + SEARCH : do while (associated(current%next)) + current => current%next + if (current%id == name) then + answer = .TRUE. + exit SEARCH + endif + enddo SEARCH + +1000 continue + + if (verbose > 0) then + write(*,*) answer + endif + + + end function is_there + + subroutine setll(ivrb) + implicit none + integer, optional :: ivrb + if (present(ivrb)) verbose = ivrb + end subroutine setll + + subroutine getll(ivrb) + implicit none + integer, optional :: ivrb + if (present(ivrb)) ivrb = verbose + end subroutine getll + +end module storage_module + diff --git a/WPS/ungrib/src/ngl/Makefile b/WPS/ungrib/src/ngl/Makefile new file mode 100644 index 00000000..8a382026 --- /dev/null +++ b/WPS/ungrib/src/ngl/Makefile @@ -0,0 +1,18 @@ +include $(DEV_TOP)/configure.wps + +all: w3/libw3.a g2/libg2_4.a + +w3/libw3.a : + ( cd w3 ; $(MAKE) DEV_TOP="${DEV_TOP}" all ; $(RANLIB) libw3.a ) + $(LN) w3/libw3.a . + +g2/libg2_4.a : + ( cd g2 ; $(MAKE) DEV_TOP="$(DEV_TOP)" all ; $(RANLIB) libg2_4.a ) + $(LN) g2/libg2_4.a . + +clean: + $(RM) *.a + ( cd w3 ; $(MAKE) DEV_TOP="$(DEV_TOP)" clean ) + ( cd g2 ; $(MAKE) DEV_TOP="$(DEV_TOP)" clean ) + +superclean: clean diff --git a/WPS/ungrib/src/ngl/g2/CHANGES b/WPS/ungrib/src/ngl/g2/CHANGES new file mode 100755 index 00000000..de6f9ef1 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/CHANGES @@ -0,0 +1,133 @@ + +g2lib-1.0 - August 2003 - Original version + +g2lib-1.0.1 - October 2003 - Added support for Grid Definition Template 3.31 + Albers Equal Area. + - Added new parameters to the Parameter list in + params.f + - Minor documentation updates. + +g2lib-1.0.2 - February 2004 - Added new parameters in params.f for use with + Quickscat data and Ozone (Air Quality) + +g2lib-1.0.3 - May 2004 - Changed most PDT templates in module pdstemplates to + allow negative surface values. + - Added new routine to gridtemplates and pdstemplates + modules to return number of entries in a specified + template. + - Added New routines, getgb2p getgb2rp, used to request + a packed GRIB2 message from a file. + - New module g2grids can be used to return GDT entries + for a specific grid from a file containing a list of + predefined grids. + +g2lib-1.0.4 - August 2004 - Added functionality to support encoding of + "Missing" data values within the data field when + using Data Representation Templates 5.2 + (complex packing) and 5.3 (complex packing and + spatial differencing). See octets 23 - 31 in DRTs + 5.2 and 5.3 for more info on missing value + management. + - Increased the packing efficiency of Data + Representation Templates 5.2 and 5.3 by adding + MDL/Glahn algorithm for determining effective + groupings. + +g2lib-1.0.5 - December 2004 - WMO approved the JPEG2000 and PNG Data + Representation Templates ( 5.40000 and 5.40010, + respectively ) for operational use. The templates + were assigned WMO values of 5.40 and 5.41, + respectively. Changes were made to the source to + recognize either template number. + - Fixed bug encountered when packing a near constant + field with DRT 5.40 or 5.40000 (JPEG2000). + - Added consistency check, provided by + Arthur Taylor/MDL, used when unpacking Data + Templates 7.2 and 7.3. + - Corrected the documentation for subroutine + addfield in the grib2.doc file. Incorrect + arguments were specified for this routine. + - Corrected bug when packing Secondary missing + values in Data Representation Templates 5.2 and + 5.3. + +g2lib-1.0.6 - April 2005 - Modified the way GETGB2 manages the GRIB2 file + indexes, so that it can be more efficient and + flexible when reading from multiple + GRIB2 files. + - Fixed bug in PUTGB2 that caused data fields to be + encoded incorrectly. + - Added routine gdt2gds that converts grid information + from a GRIB2 Grid Description Section (GDS) and + Grid Definition Template to GRIB1 GDS info. + +g2lib-1.0.7 - April 2005 - Fixed bug causing seg fault when using JPEG2000 + encoding algorithm on a grid with an insanely large + number of data points bitmapped out. + +g2lib-1.0.8 - October 2006 - Modified Product Definition Templates 4.5 and 4.9 + to allow negative scale factors and limits. + - Fixed several rounding error bugs during encoding. + - Added new local parameter conversion entries + +g2lib-1.0.9 - MAY 2007 - Modified Grid Definition Template 3.igds(5)(3.204) + to add Curvilinear Orthogonal grids. + - Added new local parameter conversion entries + +g2lib-1.1.0 -December 2007 - Added new local parameters conversion entries + - Declared the variable rmin,rmax in routine (jpcpack.f + and pngpack.f) with double precision fix bug causing + seg fault when using JPEG2000 encoding algorithm. + +g2lib-1.1.1 -January 2008 - Added new local parameters conversion entries + +g2lib-1.1.7 -August 2008 - Added new local parameters conversion entries + and table 131 + - Added a new Grid Definition Template number + 3.32768 (Added Rotate Lat/Lon E-grid) + +g2lib-1.1.9 -June 2009 - Update Jasper version 1.900.1, libpng-1.2.34 and zlib-1.2.3 + - Allow negative scale factors and limits for Templates 4.5 and 4.9 + - Fixed bug causing seg fault when using PNG 1.2.35 + - Added new local parameters conversion entries + +g2lib-1.2.0 -March 2010 - Fixed bug for checking (LUGB) unit index file + - Modified to increase length of seek (512) + - Added Templates (Satellite Product) 4.31 + - Added Templates (ICAO WAFS) 4.15 + - Added new local parameters conversion entries + - Added Time Range indicator Average (7) + +g2lib-1.2.1 - Aug 2010 - Added new local parameters conversion entries + - Added Templates 4.40,4.41,4.42,4.43 + - Added a new Grid Definition Template number + 3.32769 (Added Rotate Lat/Lon None E-grid) + - Added Type of Ensemble forecast 4 and 192 + - Corrected parameters U/V Max Wind level to use PDT 4.0 + for WAFS product + +g2lib-1.2.2 - Dec 2010 - Added new local parameters conversion entries + - Corrected Templates 4.42,4.43 + +g2lib-1.2.3 - Nov 2011 - Added new local parameters conversion entries + - Fixed bug in PUTGB2 that caused data fields to be + encoded incorrectly. + - Changed variable kprob(1) to kpds(5) in calling + routine param_g1_to_g2 + +g2lib-1.2.4 - Nov 2011 - Added 2 ECMWF parameters (TMAX/TMIN at 2m) conversion entries + +g2lib-1.4.0 - MAY 2012 - Added new parameters conversion entries + - Fixed bug in PUTGB2 that caused segmentation fault + - Added a new Grid Definition Template numbers 4.44, + 4.45, 4.46,4.47,4.48,4.50,4.51,4.91 and 4.32 + - Declared the variable rmin4 in routine misspack.f + - Modified to change voidp to png_voidp in routines dec_png.c + and enc_png.c + +g2lib-2.5.0 - AUG 2013 - Added new parameters conversion entries + - Modified GETIDX to allow users to open same unit file + - Added new Grid Definition Template numbers 3.4,3.5,.3.12, + 3.101, and 3.140 + - Added new Product Definition Template numbers 4.33, 4.34, 4.53,4.54 + diff --git a/WPS/ungrib/src/ngl/g2/Makefile b/WPS/ungrib/src/ngl/g2/Makefile new file mode 100755 index 00000000..9e2c811d --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/Makefile @@ -0,0 +1,75 @@ +include $(DEV_TOP)/configure.wps + +# Make sure one of the following options appears in your CFLAGS +# variable to indicate which system you are on. Used to call +# "C" routines from Fortran. +# -DLINUX, -DLINUXG95, -DSGI, -DHP, -DCRAY90, -DAIX, -DLINUXF90, -DVPP5000 + +# If you want to enable support for PNG or JPEG2000 encoding/decoding, +# you must specify -DUSE_PNG and/or -DUSE_JPEG2000 in the FDEFS variable +# for the Fortran pre-processor +# -DUSE_PNG requires libpng.a and libz.a +# ( and png.h pngconf.h zconf.h zlib.h include files). +# -DUSE_JPEG2000 requires libjasper.a +# ( and all the jasper/*.h include files). +# + +CFLAGS2 = $(CPPFLAGS) $(COMPRESSION_INC) $(FDEFS) -D__64BIT__ +LIB = libg2_4.a + +#-------------------------------------- +# The following was used for XLF on AIX +#DEFS=-DAIX -DHAVE_SYS_TYPES_H=1 +#FC=ncepxlf +#CC=ncepxlc +#CPP=/usr/ccs/lib/cpp -P +#FFLAGS=-O3 -g -qnosave -qarch=auto +#CFLAGS=-O3 -q64 -g -qcpluscmt -qarch=auto $(DEFS) $(INCDIR) +#ARFLAGS=-X64 +#-------------------------------------- +# The following was used for G95 on LINUX +# +#DEFS=-DLINUXG95 +#FC=g95 +#CC=cc +#CPP=cpp -P -C +#MODDIR=. +#FFLAGS=-O3 -g -I $(MODDIR) +#CFLAGS=-O3 $(DEFS) $(INCDIR) +#CFLAGS=-O3 $(DEFS) $(INCDIR) -D__64BIT__ +#ARFLAGS= +#-------------------------------------- + +OBJS = gridtemplates.o pdstemplates.o drstemplates.o gribmod.o realloc.o intmath.o addfield.o \ + addgrid.o addlocal.o getfield.o gb_info.o gf_getfld.o gf_free.o gf_unpack1.o \ + gf_unpack2.o gf_unpack3.o gf_unpack4.o gf_unpack5.o gf_unpack6.o gf_unpack7.o \ + gettemplates.o getlocal.o getdim.o getpoly.o gribcreate.o gribend.o gribinfo.o \ + mkieee.o rdieee.o simpack.o simunpack.o cmplxpack.o compack.o misspack.o pack_gp.o \ + reduce.o comunpack.o specpack.o specunpack.o jpcpack.o jpcunpack.o enc_jpeg2000.o \ + dec_jpeg2000.o pngpack.o pngunpack.o enc_png.o dec_png.o gbytesc.o skgb.o ixgb2.o \ + getidx.o getg2i.o getg2ir.o getgb2s.o getgb2r.o getgb2l.o getgb2.o getgb2p.o getgb2rp.o \ + putgb2.o g2grids.o gdt2gds.o params.o params_ecmwf.o mova2i.o + +all: $(LIB) + +$(LIB): $(OBJS) + $(RM) $@ + $(AR) $(ARFLAGS) $@ $(OBJS) + $(RANLIB) $@ + +clean: + $(RM) $(OBJS) + $(RM) *.a *.M *.mod + +superclean: clean + +.F.o: + $(CPP) $(FDEFS) $*.F > $*.f90 + $(FC) -c $(F77FLAGS) $*.f90 + /bin/rm -f $*.f90 + +.f.o: + $(FC) -c $(F77FLAGS) $*.f + +.c.o: + $(CC) -c $(CFLAGS) $(CFLAGS2) $< diff --git a/WPS/ungrib/src/ngl/g2/README b/WPS/ungrib/src/ngl/g2/README new file mode 100755 index 00000000..7ece751b --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/README @@ -0,0 +1,84 @@ + August 06, 2013 + W/SIB:VUONG + +g2lib Library. + +This library contains Fortran 90 decoder/encoder +routines for GRIB edition 2, as well as indexing/searching +utility routines. The user API for the GRIB2 routines +is described in file "grib2.doc". + +Some Fortran routines call "C" functions, which must +follow a specific symbol naming convention used by your +machine/loader to be linked successfully. +If you are having trouble linking to the C routines +in this library, please make sure the appropriate +machine is defined as an option in the CFLAGS +variable in the makefile. See the first few lines +of the makefile for valid options. +Recompile the library. + +We have added support for PNG and JPEG2000 image compression +algorithms within the GRIB2 standard. If you would like +to compile this library to utilize these GRIB2 Templates, +make sure that -DUSE_PNG and -DUSE_JPEG2000 are specified +in the FDEFS variable in the makefile. You will also need +to download and install the external libraries listed below, +if they are not already installed on your system. + +If you do not wish to bother with the external libs and +don't need PNG and JPEG2000 support, you can remove the +-DUSE_PNG and -DUSE_JPEG2000 flags from the FDEFS variable +in the makefile. + + +------------------------------------------------------------------------------- + + External Libraries: + +libjasper.a - This library is a C implementation of the JPEG-2000 Part-1 + standard (i.e., ISO/IEC 15444-1). This library is required + if JPEG2000 support in GRIB2 is desired. If not, remove + the -DUSE_JPEG2000 option from the FDEFS variable + in the makefile. + + Download version jasper-1.900.1 from the JasPer Project's + home page, http://www.ece.uvic.ca/~mdadams/jasper/. + + More information about JPEG2000 can be found at + http://www.jpeg.org/JPEG2000.html. + +libpng.a This library is a C implementation of the Portable Network + Graphics PNG image compression format. This library is required + if PNG support in GRIB2 is desired. If not, remove + the -DUSE_PNG option from the FDEFS variable + in the makefile. + + If not already installed on your system, download version + libpng-1.2.44 from http://www.libpng.org/pub/png/libpng.html. + + More information about PNG can be found at + http://www.libpng.org/pub/png/. + +libz.a This library contains compression/decompression routines + used by libpng.a for PNG image compression support. + This library is required if PNG support in GRIB2 is desired. + If not, remove the -DUSE_PNG option from the FDEFS variable + in g2lib/makefile. + + If not already installed on your system, download version + zlib-1.2.6 from http://www.gzip.org/zlib/. + +------------------------------------------------------------------------------- + +A note about routine MOVA2I: + +Some routines in this library call subroutine MOVA2I, which is included in +our W3LIB library containing the GRIB1 decoder/encoder routines. If you +are using this library without libw3.a, you will need to compile mova2i.c +(included in this distribution) so it can be added to libg2.a. Just add +the line: + + $(LIB)(mova2i.o) \ + +to the list of routines in the makefile. diff --git a/WPS/ungrib/src/ngl/g2/addfield.F b/WPS/ungrib/src/ngl/g2/addfield.F new file mode 100755 index 00000000..51f6a5c0 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/addfield.F @@ -0,0 +1,482 @@ + subroutine addfield(cgrib,lcgrib,ipdsnum,ipdstmpl,ipdstmplen, + & coordlist,numcoord,idrsnum,idrstmpl, + & idrstmplen,fld,ngrdpts,ibmap,bmap,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: addfield +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-02 +! +! ABSTRACT: This subroutine packs up Sections 4 through 7 for a given field +! and adds them to a GRIB2 message. They are Product Definition Section, +! Data Representation Section, Bit-Map Section and Data Section, +! respectively. +! This routine is used with routines "gribcreate", "addlocal", "addgrid", +! and "gribend" to create a complete GRIB2 message. Subroutine +! gribcreate must be called first to initialize a new GRIB2 message. +! Also, subroutine addgrid must be called after gribcreate and +! before this routine to add the appropriate grid description to +! the GRIB2 message. Also, a call to gribend is required to complete +! GRIB2 message after all fields have been added. +! +! PROGRAM HISTORY LOG: +! 2000-05-02 Gilbert +! 2002-12-17 Gilbert - Added support for new templates using +! PNG and JPEG2000 algorithms/templates. +! 2004-06-22 Gilbert - Added check to determine if packing algorithm failed. +! +! USAGE: CALL addfield(cgrib,lcgrib,ipdsnum,ipdstmpl,ipdstmplen, +! coordlist,numcoord,idrsnum,idrstmpl, +! idrstmplen,fld,ngrdpts,ibmap,bmap,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lcgrib - Maximum length (bytes) of array cgrib. +! ipdsnum - Product Definition Template Number ( see Code Table 4.0) +! ipdstmpl - Contains the data values for the specified Product Definition +! Template ( N=ipdsnum ). Each element of this integer +! array contains an entry (in the order specified) of Product +! Defintion Template 4.N +! ipdstmplen - Max dimension of ipdstmpl() +! coordlist- Array containg floating point values intended to document +! the vertical discretisation associated to model data +! on hybrid coordinate vertical levels. +! numcoord - number of values in array coordlist. +! idrsnum - Data Representation Template Number ( see Code Table 5.0 ) +! idrstmpl - Contains the data values for the specified Data Representation +! Template ( N=idrsnum ). Each element of this integer +! array contains an entry (in the order specified) of Data +! Representation Template 5.N +! Note that some values in this template (eg. reference +! values, number of bits, etc...) may be changed by the +! data packing algorithms. +! Use this to specify scaling factors and order of +! spatial differencing, if desired. +! idrstmplen - Max dimension of idrstmpl() +! fld() - Array of data points to pack. +! ngrdpts - Number of data points in grid. +! i.e. size of fld and bmap. +! ibmap - Bitmap indicator ( see Code Table 6.0 ) +! 0 = bitmap applies and is included in Section 6. +! 1-253 = Predefined bitmap applies +! 254 = Previously defined bitmap applies to this field +! 255 = Bit map does not apply to this product. +! bmap() - Logical*1 array containing bitmap to be added. +! ( if ibmap=0 or ibmap=254) +! +! OUTPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! ierr - Error return code. +! 0 = no error +! 1 = GRIB message was not initialized. Need to call +! routine gribcreate first. +! 2 = GRIB message already complete. Cannot add new section. +! 3 = Sum of Section byte counts does not add to total +! byte count. +! 4 = Previous Section was not 3 or 7. +! 5 = Could not find requested Product Definition Template. +! 6 = Section 3 (GDS) not previously defined in message +! 7 = Tried to use unsupported Data Representationi Template +! 8 = Specified use of a previously defined bitmap, but one +! does not exist in the GRIB message. +! 9 = GDT of one of 5.50 through 5.53 required to pack +! using DRT 5.51 +! 10 = Error packing data field. +! +! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow +! Section 1 or Section 7 in a GRIB2 message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + use pdstemplates + use drstemplates + + character(len=1),intent(inout) :: cgrib(lcgrib) + integer,intent(in) :: ipdsnum,ipdstmpl(*) + integer,intent(in) :: idrsnum,numcoord,ipdstmplen,idrstmplen + integer,intent(in) :: lcgrib,ngrdpts,ibmap + real,intent(in) :: coordlist(numcoord) + real,target,intent(in) :: fld(ngrdpts) + integer,intent(out) :: ierr + integer,intent(inout) :: idrstmpl(*) + logical*1,intent(in) :: bmap(ngrdpts) + + character(len=4),parameter :: grib='GRIB',c7777='7777' + character(len=4):: ctemp + character(len=1),allocatable :: cpack(:) + real,pointer,dimension(:) :: pfld + real(4) :: coordieee(numcoord),re00 + integer(4) :: ire00,allones + integer :: mappds(ipdstmplen),intbmap(ngrdpts),mapdrs(idrstmplen) + integer,parameter :: zero=0,one=1,four=4,five=5,six=6,seven=7 + integer,parameter :: minsize=50000 + integer iofst,ibeg,lencurr,len,mappdslen,mapdrslen,lpos3 + integer width,height,ndpts + integer lensec3,lensec4,lensec5,lensec6,lensec7 + logical issec3,needext,isprevbmap + + ierr=0 + do jj=0,31 + allones=ibset(allones,jj) + enddo +! +! Check to see if beginning of GRIB message exists +! + ctemp=cgrib(1)//cgrib(2)//cgrib(3)//cgrib(4) + if ( ctemp.ne.grib ) then + print *,'addfield: GRIB not found in given message.' + print *,'addfield: Call to routine gribcreate required', + & ' to initialize GRIB messge.' + ierr=1 + return + endif +! +! Get current length of GRIB message +! + call gbyte(cgrib,lencurr,96,32) +! +! Check to see if GRIB message is already complete +! + ctemp=cgrib(lencurr-3)//cgrib(lencurr-2)//cgrib(lencurr-1) + & //cgrib(lencurr) + if ( ctemp.eq.c7777 ) then + print *,'addfield: GRIB message already complete. Cannot', + & ' add new section.' + ierr=2 + return + endif +! +! Loop through all current sections of the GRIB message to +! find the last section number. +! + issec3=.false. + isprevbmap=.false. + len=16 ! length of Section 0 + do + ! Get number and length of next section + iofst=len*8 + call gbyte(cgrib,ilen,iofst,32) + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) + iofst=iofst+8 + ! Check if previous Section 3 exists and save location of + ! the section 3 in case needed later. + if (isecnum.eq.3) then + issec3=.true. + lpos3=len+1 + lensec3=ilen + endif + ! Check if a previous defined bitmap exists + if (isecnum.eq.6) then + call gbyte(cgrib,ibmprev,iofst,8) + iofst=iofst+8 + if ((ibmprev.ge.0).and.(ibmprev.le.253)) isprevbmap=.true. + endif + len=len+ilen + ! Exit loop if last section reached + if ( len.eq.lencurr ) exit + ! If byte count for each section does not match current + ! total length, then there is a problem. + if ( len.gt.lencurr ) then + print *,'addfield: Section byte counts don''t add to total.' + print *,'addfield: Sum of section byte counts = ',len + print *,'addfield: Total byte count in Section 0 = ',lencurr + ierr=3 + return + endif + enddo +! +! Sections 4 through 7 can only be added after section 3 or 7. +! + if ( (isecnum.ne.3) .and. (isecnum.ne.7) ) then + print *,'addfield: Sections 4-7 can only be added after', + & ' Section 3 or 7.' + print *,'addfield: Section ',isecnum,' was the last found in', + & ' given GRIB message.' + ierr=4 + return +! +! Sections 4 through 7 can only be added if section 3 was previously defined. +! + elseif (.not.issec3) then + print *,'addfield: Sections 4-7 can only be added if Section', + & ' 3 was previously included.' + print *,'addfield: Section 3 was not found in', + & ' given GRIB message.' + print *,'addfield: Call to routine addgrid required', + & ' to specify Grid definition.' + ierr=6 + return + endif +! +! Add Section 4 - Product Definition Section +! + ibeg=lencurr*8 ! Calculate offset for beginning of section 4 + iofst=ibeg+32 ! leave space for length of section + call sbyte(cgrib,four,iofst,8) ! Store section number ( 4 ) + iofst=iofst+8 + call sbyte(cgrib,numcoord,iofst,16) ! Store num of coordinate values + iofst=iofst+16 + call sbyte(cgrib,ipdsnum,iofst,16) ! Store Prod Def Template num. + iofst=iofst+16 + ! + ! Get Product Definition Template + ! + call getpdstemplate(ipdsnum,mappdslen,mappds,needext,iret) + if (iret.ne.0) then + ierr=5 + return + endif + ! + ! Extend the Product Definition Template, if necessary. + ! The number of values in a specific template may vary + ! depending on data specified in the "static" part of the + ! template. + ! + if ( needext ) then + call extpdstemplate(ipdsnum,ipdstmpl,mappdslen,mappds) + endif + ! + ! Pack up each input value in array ipdstmpl into the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mappds. + ! + do i=1,mappdslen + nbits=iabs(mappds(i))*8 + if ( (mappds(i).ge.0).or.(ipdstmpl(i).ge.0) ) then + call sbyte(cgrib,ipdstmpl(i),iofst,nbits) + else + call sbyte(cgrib,one,iofst,1) + call sbyte(cgrib,iabs(ipdstmpl(i)),iofst+1,nbits-1) + endif + iofst=iofst+nbits + enddo + ! + ! Add Optional list of vertical coordinate values + ! after the Product Definition Template, if necessary. + ! + if ( numcoord .ne. 0 ) then + call mkieee(coordlist,coordieee,numcoord) + call sbytes(cgrib,coordieee,iofst,32,0,numcoord) + iofst=iofst+(32*numcoord) + endif + ! + ! Calculate length of section 4 and store it in octets + ! 1-4 of section 4. + ! + lensec4=(iofst-ibeg)/8 + call sbyte(cgrib,lensec4,ibeg,32) +! +! Pack Data using appropriate algorithm +! + ! + ! Get Data Representation Template + ! + call getdrstemplate(idrsnum,mapdrslen,mapdrs,needext,iret) + if (iret.ne.0) then + ierr=5 + return + endif + ! + ! contract data field, removing data at invalid grid points, + ! if bit-map is provided with field. + ! + if ( ibmap.eq.0 .OR. ibmap.eq.254 ) then + allocate(pfld(ngrdpts)) + ndpts=0; + do jj=1,ngrdpts + intbmap(jj)=0 + if ( bmap(jj) ) then + intbmap(jj)=1 + ndpts=ndpts+1 + pfld(ndpts)=fld(jj); + endif + enddo + else + ndpts=ngrdpts; + pfld=>fld; + endif + lcpack=0 + nsize=ndpts*4 + if (nsize .lt. minsize) nsize=minsize + allocate(cpack(nsize),stat=istat) + if (idrsnum.eq.0) then ! Simple Packing + call simpack(pfld,ndpts,idrstmpl,cpack,lcpack) + elseif (idrsnum.eq.2.or.idrsnum.eq.3) then ! Complex Packing + call cmplxpack(pfld,ndpts,idrsnum,idrstmpl,cpack,lcpack) + elseif (idrsnum.eq.50) then ! Sperical Harmonic Simple Packing + call simpack(pfld(2),ndpts-1,idrstmpl,cpack,lcpack) + call mkieee(real(pfld(1)),re00,1) ! ensure RE(0,0) value is IEEE format + !call gbyte(re00,idrstmpl(5),0,32) + ire00=transfer(re00,ire00) + idrstmpl(5)=ire00 + elseif (idrsnum.eq.51) then ! Sperical Harmonic Complex Packing + call getpoly(cgrib(lpos3),lensec3,jj,kk,mm) + if (jj.ne.0 .AND. kk.ne.0 .AND. mm.ne.0) then + call specpack(pfld,ndpts,jj,kk,mm,idrstmpl,cpack,lcpack) + else + print *,'addfield: Cannot pack DRT 5.51.' + ierr=9 + return + endif +#ifdef USE_JPEG2000 + elseif (idrsnum.eq.40 .OR. idrsnum.eq.40000) then ! JPEG2000 encoding + if (ibmap.eq.255) then + call getdim(cgrib(lpos3),lensec3,width,height,iscan) + if ( width.eq.0 .OR. height.eq.0 ) then + width=ndpts + height=1 + elseif ( width.eq.allones .OR. height.eq.allones ) then + width=ndpts + height=1 + elseif ( ibits(iscan,5,1) .eq. 1) then ! Scanning mode: bit 3 + itemp=width + width=height + height=itemp + endif + else + width=ndpts + height=1 + endif + lcpack=nsize + call jpcpack(pfld,width,height,idrstmpl,cpack,lcpack) +#endif /* USE_JPEG2000 */ +#ifdef USE_PNG + elseif (idrsnum.eq.41 .OR. idrsnum.eq.40010) then ! PNG encoding + if (ibmap.eq.255) then + call getdim(cgrib(lpos3),lensec3,width,height,iscan) + if ( width.eq.0 .OR. height.eq.0 ) then + width=ndpts + height=1 + elseif ( width.eq.allones .OR. height.eq.allones ) then + width=ndpts + height=1 + elseif ( ibits(iscan,5,1) .eq. 1) then ! Scanning mode: bit 3 + itemp=width + width=height + height=itemp + endif + else + width=ndpts + height=1 + endif + call pngpack(pfld,width,height,idrstmpl,cpack,lcpack) +#endif /* USE_PNG */ + else + print *,'addfield: Data Representation Template 5.',idrsnum, + * ' not yet implemented.' + ierr=7 + return + endif + if ( ibmap.eq.0 .OR. ibmap.eq.254 ) then + deallocate(pfld) + endif + if ( lcpack .lt. 0 ) then + if( allocated(cpack) )deallocate(cpack) + ierr=10 + return + endif + +! +! Add Section 5 - Data Representation Section +! + ibeg=iofst ! Calculate offset for beginning of section 5 + iofst=ibeg+32 ! leave space for length of section + call sbyte(cgrib,five,iofst,8) ! Store section number ( 5 ) + iofst=iofst+8 + call sbyte(cgrib,ndpts,iofst,32) ! Store num of actual data points + iofst=iofst+32 + call sbyte(cgrib,idrsnum,iofst,16) ! Store Data Repr. Template num. + iofst=iofst+16 + ! + ! Pack up each input value in array idrstmpl into the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mapdrs. + ! + do i=1,mapdrslen + nbits=iabs(mapdrs(i))*8 + if ( (mapdrs(i).ge.0).or.(idrstmpl(i).ge.0) ) then + call sbyte(cgrib,idrstmpl(i),iofst,nbits) + else + call sbyte(cgrib,one,iofst,1) + call sbyte(cgrib,iabs(idrstmpl(i)),iofst+1,nbits-1) + endif + iofst=iofst+nbits + enddo + ! + ! Calculate length of section 5 and store it in octets + ! 1-4 of section 5. + ! + lensec5=(iofst-ibeg)/8 + call sbyte(cgrib,lensec5,ibeg,32) + +! +! Add Section 6 - Bit-Map Section +! + ibeg=iofst ! Calculate offset for beginning of section 6 + iofst=ibeg+32 ! leave space for length of section + call sbyte(cgrib,six,iofst,8) ! Store section number ( 6 ) + iofst=iofst+8 + call sbyte(cgrib,ibmap,iofst,8) ! Store Bit Map indicator + iofst=iofst+8 + ! + ! Store bitmap, if supplied + ! + if (ibmap.eq.0) then + call sbytes(cgrib,intbmap,iofst,1,0,ngrdpts) ! Store BitMap + iofst=iofst+ngrdpts + endif + ! + ! If specifying a previously defined bit-map, make sure + ! one already exists in the current GRIB message. + ! + if ((ibmap.eq.254).and.(.not.isprevbmap)) then + print *,'addfield: Requested previously defined bitmap, ', + & ' but one does not exist in the current GRIB message.' + ierr=8 + return + endif + ! + ! Calculate length of section 6 and store it in octets + ! 1-4 of section 6. Pad to end of octect, if necessary. + ! + left=8-mod(iofst,8) + if (left.ne.8) then + call sbyte(cgrib,zero,iofst,left) ! Pad with zeros to fill Octet + iofst=iofst+left + endif + lensec6=(iofst-ibeg)/8 + call sbyte(cgrib,lensec6,ibeg,32) + +! +! Add Section 7 - Data Section +! + ibeg=iofst ! Calculate offset for beginning of section 7 + iofst=ibeg+32 ! leave space for length of section + call sbyte(cgrib,seven,iofst,8) ! Store section number ( 7 ) + iofst=iofst+8 + ! Store Packed Binary Data values, if non-constant field + if (lcpack.ne.0) then + ioctet=iofst/8 + cgrib(ioctet+1:ioctet+lcpack)=cpack(1:lcpack) + iofst=iofst+(8*lcpack) + endif + ! + ! Calculate length of section 7 and store it in octets + ! 1-4 of section 7. + ! + lensec7=(iofst-ibeg)/8 + call sbyte(cgrib,lensec7,ibeg,32) + + if( allocated(cpack) )deallocate(cpack) +! +! Update current byte total of message in Section 0 +! + newlen=lencurr+lensec4+lensec5+lensec6+lensec7 + call sbyte(cgrib,newlen,96,32) + + return + end + diff --git a/WPS/ungrib/src/ngl/g2/addgrid.f b/WPS/ungrib/src/ngl/g2/addgrid.f new file mode 100755 index 00000000..e3e388ef --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/addgrid.f @@ -0,0 +1,232 @@ + subroutine addgrid(cgrib,lcgrib,igds,igdstmpl,igdstmplen, + & ideflist,idefnum,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: addgrid +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-01 +! +! ABSTRACT: This subroutine packs up a Grid Definition Section (Section 3) +! and adds it to a GRIB2 message. +! This routine is used with routines "gribcreate", "addlocal", "addfield", +! and "gribend" to create a complete GRIB2 message. Subroutine +! gribcreate must be called first to initialize a new GRIB2 message. +! +! PROGRAM HISTORY LOG: +! 2000-05-01 Gilbert +! +! USAGE: CALL addgrid(cgrib,lcgrib,igds,igdstmpl,igdstmplen, +! ideflist,idefnum,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lcgrib - Maximum length (bytes) of array cgrib. +! igds - Contains information needed for GRIB Grid Definition Section 3. +! Must be dimensioned >= 5. +! igds(1)=Source of grid definition (see Code Table 3.0) +! igds(2)=Number of grid points in the defined grid. +! igds(3)=Number of octets needed for each +! additional grid points definition. +! Used to define number of +! points in each row ( or column ) for +! non-regular grids. +! = 0, if using regular grid. +! igds(4)=Interpretation of list for optional points +! definition. (Code Table 3.11) +! igds(5)=Grid Definition Template Number (Code Table 3.1) +! igdstmpl - Contains the data values for the specified Grid Definition +! Template ( NN=igds(5) ). Each element of this integer +! array contains an entry (in the order specified) of Grid +! Defintion Template 3.NN +! igdstmplen - Max dimension of igdstmpl() +! ideflist - (Used if igds(3) .ne. 0) This array contains the +! number of grid points contained in each row ( or column ) +! idefnum - (Used if igds(3) .ne. 0) The number of entries +! in array ideflist. i.e. number of rows ( or columns ) +! for which optional grid points are defined. +! +! OUTPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! ierr - Error return code. +! 0 = no error +! 1 = GRIB message was not initialized. Need to call +! routine gribcreate first. +! 2 = GRIB message already complete. Cannot add new section. +! 3 = Sum of Section byte counts doesn't add to total byte count. +! 4 = Previous Section was not 1, 2 or 7. +! 5 = Could not find requested Grid Definition Template. +! +! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow +! Section 1 or Section 7 in a GRIB2 message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + use gridtemplates + + character(len=1),intent(inout) :: cgrib(lcgrib) + integer,intent(in) :: igds(*),igdstmpl(*),ideflist(idefnum) + integer,intent(in) :: lcgrib,idefnum,igdstmplen + integer,intent(out) :: ierr + + character(len=4),parameter :: grib='GRIB',c7777='7777' + character(len=4):: ctemp + integer:: mapgrid(igdstmplen) + integer,parameter :: one=1,three=3 + integer lensec3,iofst,ibeg,lencurr,len,mapgridlen + logical needext + + ierr=0 +! +! Check to see if beginning of GRIB message exists +! + do i=1,4 + if(cgrib(i)/=grib(i:i)) then + print *,'addgrid: GRIB not found in given message.' + print *,'addgrid: Call to routine gribcreate required', + & ' to initialize GRIB messge.' + 10 format('"',4A1,'" /= "GRIB"') + print 10,cgrib(1:4) + ierr=1 + stop 1 + return + endif + enddo +! +! Get current length of GRIB message +! + call gbyte(cgrib,lencurr,96,32) +! +! Check to see if GRIB message is already complete +! + ctemp=cgrib(lencurr-3)//cgrib(lencurr-2)//cgrib(lencurr-1) + & //cgrib(lencurr) + if ( ctemp.eq.c7777 ) then + print *,'addgrid: GRIB message already complete. Cannot', + & ' add new section.' + ierr=2 + return + endif +! +! Loop through all current sections of the GRIB message to +! find the last section number. +! + len=16 ! length of Section 0 + do + ! Get section number and length of next section + iofst=len*8 + call gbyte(cgrib,ilen,iofst,32) + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) + len=len+ilen + ! Exit loop if last section reached + if ( len.eq.lencurr ) exit + ! If byte count for each section doesn't match current + ! total length, then there is a problem. + if ( len.gt.lencurr ) then + print *,'addgrid: Section byte counts don''t add to total.' + print *,'addgrid: Sum of section byte counts = ',len + print *,'addgrid: Total byte count in Section 0 = ',lencurr + ierr=3 + return + endif + enddo +! +! Section 3 can only be added after sections 1, 2 and 7. +! + if ( (isecnum.ne.1) .and. (isecnum.ne.2) .and. + & (isecnum.ne.7) ) then + print *,'addgrid: Section 3 can only be added after Section', + & ' 1, 2 or 7.' + print *,'addgrid: Section ',isecnum,' was the last found in', + & ' given GRIB message.' + ierr=4 + return + endif +! +! Add Section 3 - Grid Definition Section +! + ibeg=lencurr*8 ! Calculate offset for beginning of section 3 + iofst=ibeg+32 ! leave space for length of section + call sbyte(cgrib,three,iofst,8) ! Store section number ( 3 ) + iofst=iofst+8 + call sbyte(cgrib,igds(1),iofst,8) ! Store source of Grid def. + iofst=iofst+8 + call sbyte(cgrib,igds(2),iofst,32) ! Store number of data pts. + iofst=iofst+32 + call sbyte(cgrib,igds(3),iofst,8) ! Store number of extra octets. + iofst=iofst+8 + call sbyte(cgrib,igds(4),iofst,8) ! Store interp. of extra octets. + iofst=iofst+8 + ! if Octet 6 is not equal to zero, Grid Definition Template may + ! not be supplied. + if ( igds(1).eq.0 ) then + call sbyte(cgrib,igds(5),iofst,16) ! Store Grid Def Template num. + else + call sbyte(cgrib,65535,iofst,16) ! Store missing value as Grid Def Template num. + endif + iofst=iofst+16 + ! + ! Get Grid Definition Template + ! + if (igds(1).eq.0) then + call getgridtemplate(igds(5),mapgridlen,mapgrid,needext, + & iret) + if (iret.ne.0) then + ierr=5 + return + endif + ! + ! Extend the Grid Definition Template, if necessary. + ! The number of values in a specific template may vary + ! depending on data specified in the "static" part of the + ! template. + ! + if ( needext ) then + call extgridtemplate(igds(5),igdstmpl,mapgridlen,mapgrid) + endif + else + mapgridlen=0 + endif + ! + ! Pack up each input value in array igdstmpl into the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mapgrid. + ! + do i=1,mapgridlen + nbits=iabs(mapgrid(i))*8 + if ( (mapgrid(i).ge.0).or.(igdstmpl(i).ge.0) ) then + call sbyte(cgrib,igdstmpl(i),iofst,nbits) + else + call sbyte(cgrib,one,iofst,1) + call sbyte(cgrib,iabs(igdstmpl(i)),iofst+1,nbits-1) + endif + iofst=iofst+nbits + enddo + ! + ! If requested, + ! Insert optional list of numbers defining number of points + ! in each row or column. This is used for non regular + ! grids. + ! + if ( igds(3).ne.0 ) then + nbits=igds(3)*8 + call sbytes(cgrib,ideflist,iofst,nbits,0,idefnum) + iofst=iofst+(nbits*idefnum) + endif + ! + ! Calculate length of section 3 and store it in octets + ! 1-4 of section 3. + ! + lensec3=(iofst-ibeg)/8 + call sbyte(cgrib,lensec3,ibeg,32) + +! +! Update current byte total of message in Section 0 +! + call sbyte(cgrib,lencurr+lensec3,96,32) + + return + end + diff --git a/WPS/ungrib/src/ngl/g2/addlocal.f b/WPS/ungrib/src/ngl/g2/addlocal.f new file mode 100755 index 00000000..6c184f31 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/addlocal.f @@ -0,0 +1,138 @@ + subroutine addlocal(cgrib,lcgrib,csec2,lcsec2,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: addlocal +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-01 +! +! ABSTRACT: This subroutine adds a Local Use Section (Section 2) to +! a GRIB2 message. +! This routine is used with routines "gribcreate", "addgrid", "addfield", +! and "gribend" to create a complete GRIB2 message. Subroutine +! gribcreate must be called first to initialize a new GRIB2 message. +! +! PROGRAM HISTORY LOG: +! 2000-05-01 Gilbert +! +! USAGE: CALL addlocal(cgrib,lcgrib,csec2,lcsec2,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lcgrib - Maximum length (bytes) of array cgrib. +! csec2 - Character array containing information to be added to +! Section 2. +! lcsec2 - Number of bytes of character array csec2 to be added to +! Section 2. +! +! OUTPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! ierr - Error return code. +! 0 = no error +! 1 = GRIB message was not initialized. Need to call +! routine gribcreate first. +! 2 = GRIB message already complete. Cannot add new section. +! 3 = Sum of Section byte counts doesn't add to total byte count. +! 4 = Previous Section was not 1 or 7. +! +! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow +! Section 1 or Section 7 in a GRIB2 message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(inout) :: cgrib(lcgrib) + character(len=1),intent(in) :: csec2(lcsec2) + integer,intent(in) :: lcgrib,lcsec2 + integer,intent(out) :: ierr + + character(len=4),parameter :: grib='GRIB',c7777='7777' + character(len=4):: ctemp + integer,parameter :: two=2 + integer lensec2,iofst,ibeg,lencurr,len + + ierr=0 +! +! Check to see if beginning of GRIB message exists +! + ctemp=cgrib(1)//cgrib(2)//cgrib(3)//cgrib(4) + if ( ctemp.ne.grib ) then + print *,'addlocal: GRIB not found in given message.' + print *,'addlocal: Call to routine gribcreate required', + & ' to initialize GRIB messge.' + ierr=1 + return + endif +! +! Get current length of GRIB message +! + call gbyte(cgrib,lencurr,96,32) +! +! Check to see if GRIB message is already complete +! + ctemp=cgrib(lencurr-3)//cgrib(lencurr-2)//cgrib(lencurr-1) + & //cgrib(lencurr) + if ( ctemp.eq.c7777 ) then + print *,'addlocal: GRIB message already complete. Cannot', + & ' add new section.' + ierr=2 + return + endif +! +! Loop through all current sections of the GRIB message to +! find the last section number. +! + len=16 ! length of Section 0 + do + ! Get section number and length of next section + iofst=len*8 + call gbyte(cgrib,ilen,iofst,32) + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) + len=len+ilen + ! Exit loop if last section reached + if ( len.eq.lencurr ) exit + ! If byte count for each section doesn't match current + ! total length, then there is a problem. + if ( len.gt.lencurr ) then + print *,'addlocal: Section byte counts don''t add to total.' + print *,'addlocal: Sum of section byte counts = ',len + print *,'addlocal: Total byte count in Section 0 = ',lencurr + ierr=3 + return + endif + enddo +! +! Section 2 can only be added after sections 1 and 7. +! + if ( (isecnum.ne.1) .and. (isecnum.ne.7) ) then + print *,'addlocal: Section 2 can only be added after Section', + & ' 1 or Section 7.' + print *,'addlocal: Section ',isecnum,' was the last found in', + & ' given GRIB message.' + ierr=4 + return + endif +! +! Add Section 2 - Local Use Section +! + ibeg=lencurr*8 ! Calculate offset for beginning of section 2 + iofst=ibeg+32 ! leave space for length of section + call sbyte(cgrib,two,iofst,8) ! Store section number ( 2 ) + istart=lencurr+5 + cgrib(istart+1:istart+lcsec2)=csec2(1:lcsec2) + ! + ! Calculate length of section 2 and store it in octets + ! 1-4 of section 2. + ! + lensec2=lcsec2+5 ! bytes + call sbyte(cgrib,lensec2,ibeg,32) + +! +! Update current byte total of message in Section 0 +! + call sbyte(cgrib,lencurr+lensec2,96,32) + + return + end + diff --git a/WPS/ungrib/src/ngl/g2/cmplxpack.f b/WPS/ungrib/src/ngl/g2/cmplxpack.f new file mode 100755 index 00000000..dd1be9e1 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/cmplxpack.f @@ -0,0 +1,76 @@ + subroutine cmplxpack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: cmplxpack +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2004-08-27 +! +! ABSTRACT: This subroutine packs up a data field using a complex +! packing algorithm as defined in the GRIB2 documention. It +! supports GRIB2 complex packing templates with or without +! spatial differences (i.e. DRTs 5.2 and 5.3). +! It also fills in GRIB2 Data Representation Template 5.2 or 5.3 +! with the appropriate values. +! +! PROGRAM HISTORY LOG: +! 2004-08-27 Gilbert +! +! USAGE: CALL cmplxpack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack) +! INPUT ARGUMENT LIST: +! fld() - Contains the data values to pack +! ndpts - The number of data values in array fld() +! idrsnum - Data Representation Template number 5.N +! Must equal 2 or 3. +! idrstmpl - Contains the array of values for Data Representation +! Template 5.2 or 5.3 +! (1) = Reference value - ignored on input +! (2) = Binary Scale Factor +! (3) = Decimal Scale Factor +! . +! . +! (7) = Missing value management +! (8) = Primary missing value +! (9) = Secondary missing value +! . +! . +! (17) = Order of Spatial Differencing ( 1 or 2 ) +! . +! . +! +! OUTPUT ARGUMENT LIST: +! idrstmpl - Contains the array of values for Data Representation +! Template 5.3 +! (1) = Reference value - set by compack routine. +! (2) = Binary Scale Factor - unchanged from input +! (3) = Decimal Scale Factor - unchanged from input +! . +! . +! cpack - The packed data field (character*1 array) +! lcpack - length of packed field cpack(). +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: XL Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + integer,intent(in) :: ndpts,idrsnum + real,intent(in) :: fld(ndpts) + character(len=1),intent(out) :: cpack(*) + integer,intent(inout) :: idrstmpl(*) + integer,intent(out) :: lcpack + + + + if ( idrstmpl(7) .eq. 0 ) then ! No internal missing values + call compack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack) + elseif ( idrstmpl(7).eq.1 .OR. idrstmpl(7).eq.2) then + call misspack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack) + else + print *,'cmplxpack: Don:t recognize Missing value option.' + lcpack=-1 + endif + + return + end diff --git a/WPS/ungrib/src/ngl/g2/compack.f b/WPS/ungrib/src/ngl/g2/compack.f new file mode 100755 index 00000000..7f800ebf --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/compack.f @@ -0,0 +1,469 @@ + subroutine compack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: compack +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-06-21 +! +! ABSTRACT: This subroutine packs up a data field using a complex +! packing algorithm as defined in the GRIB2 documention. It +! supports GRIB2 complex packing templates with or without +! spatial differences (i.e. DRTs 5.2 and 5.3). +! It also fills in GRIB2 Data Representation Template 5.2 or 5.3 +! with the appropriate values. +! +! PROGRAM HISTORY LOG: +! 2000-06-21 Gilbert +! 2011-10-24 Boi Vuong Added variable rmin4 for 4 byte float +! +! USAGE: CALL compack(fld,ndpts,idrsnum,idrstmpl,cpack,lcpack) +! INPUT ARGUMENT LIST: +! fld() - Contains the data values to pack +! ndpts - The number of data values in array fld() +! idrsnum - Data Representation Template number 5.N +! Must equal 2 or 3. +! idrstmpl - Contains the array of values for Data Representation +! Template 5.2 or 5.3 +! (1) = Reference value - ignored on input +! (2) = Binary Scale Factor +! (3) = Decimal Scale Factor +! . +! . +! (7) = Missing value management +! (8) = Primary missing value +! (9) = Secondary missing value +! . +! . +! (17) = Order of Spatial Differencing ( 1 or 2 ) +! . +! . +! +! OUTPUT ARGUMENT LIST: +! idrstmpl - Contains the array of values for Data Representation +! Template 5.3 +! (1) = Reference value - set by compack routine. +! (2) = Binary Scale Factor - unchanged from input +! (3) = Decimal Scale Factor - unchanged from input +! . +! . +! cpack - The packed data field (character*1 array) +! lcpack - length of packed field cpack(). +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: XL Fortran 90 +! MACHINE: IBM SP +! +!$$$ + use intmath + implicit none + integer,intent(in) :: ndpts,idrsnum + real,intent(in) :: fld(ndpts) + character(len=1),intent(out) :: cpack(*) + integer,intent(inout) :: idrstmpl(*) + integer,intent(out) :: lcpack + + real :: bscale,dscale + integer :: j,iofst,imin,ival1,ival2,minsd,nbitsd,n + integer :: igmax,nbitsgref,left,iwmax,i,ilmax,kk,ij + integer :: ngwidthref,nbitsgwidth,nglenref,nglenlast + integer :: maxorig,nbitorig,isd,ngroups,itemp,minpk + integer :: kfildo,inc,maxgrps,missopt,miss1,miss2,lg + integer :: ibit,jbit,kbit,novref,lbitref,ier,ng,imax + integer :: nbitsglen + real(4) :: ref,rmin4 + real(8) :: rmin,rmax + + integer(4) :: iref + integer,allocatable :: ifld(:) + integer,allocatable :: jmin(:),jmax(:),lbit(:) + integer,parameter :: zero=0 + integer,allocatable :: gref(:),gwidth(:),glen(:) + integer :: glength,grpwidth + logical :: simple_alg + + simple_alg = .false. + + bscale=2.0**real(-idrstmpl(2)) + dscale=10.0**real(idrstmpl(3)) +! +! Find max and min values in the data +! + if(ndpts>0) then + rmax=fld(1) + rmin=fld(1) + else + rmax=1.0 + rmin=1.0 + endif + do j=2,ndpts + if (fld(j).gt.rmax) rmax=fld(j) + if (fld(j).lt.rmin) rmin=fld(j) + enddo +! +! If max and min values are not equal, pack up field. +! If they are equal, we have a constant field, and the reference +! value (rmin) is the value for each point in the field and +! set nbits to 0. +! + multival: if (rmin.ne.rmax) then + iofst=0 + allocate(ifld(ndpts)) + allocate(gref(ndpts)) + allocate(gwidth(ndpts)) + allocate(glen(ndpts)) + ! + ! Scale original data + ! + if (idrstmpl(2).eq.0) then ! No binary scaling + imin=nint(rmin*dscale) + !imax=nint(rmax*dscale) + rmin=real(imin) + do j=1,ndpts + ifld(j)=max(0,nint(fld(j)*dscale)-imin) + enddo + else ! Use binary scaling factor + rmin=rmin*dscale + !rmax=rmax*dscale + do j=1,ndpts + ifld(j)=max(0,nint(((fld(j)*dscale)-rmin)*bscale)) + enddo + endif + ! + ! Calculate Spatial differences, if using DRS Template 5.3 + ! + alg3: if (idrsnum.eq.3) then ! spatial differences + if (idrstmpl(17).ne.1.and.idrstmpl(17).ne.2) idrstmpl(17)=2 + if (idrstmpl(17).eq.1) then ! first order + ival1=ifld(1) + if(ival1<0) then + print *,'G2: negative ival1',ival1 + stop 101 + endif + do j=ndpts,2,-1 + ifld(j)=ifld(j)-ifld(j-1) + enddo + ifld(1)=0 + elseif (idrstmpl(17).eq.2) then ! second order + ival1=ifld(1) + ival2=ifld(2) + if(ival1<0) then + print *,'G2: negative ival1',ival1 + stop 11 + endif + if(ival2<0) then + print *,'G2: negative ival2',ival2 + stop 12 + endif + do j=ndpts,3,-1 + ifld(j)=ifld(j)-(2*ifld(j-1))+ifld(j-2) + enddo + ifld(1)=0 + ifld(2)=0 + endif + ! + ! subtract min value from spatial diff field + ! + isd=idrstmpl(17)+1 + minsd=minval(ifld(isd:ndpts)) + do j=isd,ndpts + ifld(j)=ifld(j)-minsd + enddo + ! + ! find num of bits need to store minsd and add 1 extra bit + ! to indicate sign + ! + nbitsd=i1log2(abs(minsd))+1 + ! + ! find num of bits need to store ifld(1) ( and ifld(2) + ! if using 2nd order differencing ) + ! + maxorig=ival1 + if (idrstmpl(17).eq.2.and.ival2.gt.ival1) maxorig=ival2 + nbitorig=i1log2(maxorig)+1 + if (nbitorig.gt.nbitsd) nbitsd=nbitorig + ! increase number of bits to even multiple of 8 ( octet ) + if (mod(nbitsd,8).ne.0) nbitsd=nbitsd+(8-mod(nbitsd,8)) + ! + ! Store extra spatial differencing info into the packed + ! data section. + ! + if (nbitsd.ne.0) then + ! pack first original value + if (ival1.ge.0) then + call sbyte(cpack,ival1,iofst,nbitsd) + iofst=iofst+nbitsd + else + call sbyte(cpack,1,iofst,1) + iofst=iofst+1 + call sbyte(cpack,iabs(ival1),iofst,nbitsd-1) + iofst=iofst+nbitsd-1 + endif + if (idrstmpl(17).eq.2) then + ! pack second original value + if (ival2.ge.0) then + call sbyte(cpack,ival2,iofst,nbitsd) + iofst=iofst+nbitsd + else + call sbyte(cpack,1,iofst,1) + iofst=iofst+1 + call sbyte(cpack,iabs(ival2),iofst,nbitsd-1) + iofst=iofst+nbitsd-1 + endif + endif + ! pack overall min of spatial differences + if (minsd.ge.0) then + call sbyte(cpack,minsd,iofst,nbitsd) + iofst=iofst+nbitsd + else + call sbyte(cpack,1,iofst,1) + iofst=iofst+1 + call sbyte(cpack,iabs(minsd),iofst,nbitsd-1) + iofst=iofst+nbitsd-1 + endif + endif + !print *,'SDp ',ival1,ival2,minsd,nbitsd + endif alg3 ! end of spatial diff section + ! + ! Determine Groups to be used. + ! + simplealg: if ( simple_alg ) then + ! set group length to 10 : calculate number of groups + ! and length of last group +! print *,'G2: use simple algorithm' + ngroups=ndpts/10 + glen(1:ngroups)=10 + itemp=mod(ndpts,10) + if (itemp.ne.0) then + ngroups=ngroups+1 + glen(ngroups)=itemp + endif + else + ! Use Dr. Glahn's algorithm for determining grouping. + ! + kfildo=6 + minpk=10 + inc=1 + maxgrps=((ndpts+minpk-1)/minpk) + allocate(jmin(maxgrps)) + allocate(jmax(maxgrps)) + allocate(lbit(maxgrps)) + missopt=0 + call pack_gp(kfildo,ifld,ndpts,missopt,minpk,inc,miss1,miss2, + & jmin,jmax,lbit,glen,maxgrps,ngroups,ibit,jbit, + & kbit,novref,lbitref,ier) + if(ier/=0) then + ! Dr. Glahn's algorithm failed; use simple packing method instead. + 1099 format('G2: fall back to simple algorithm (glahn ier=',I0,& + & ')') + print 1099,ier + ngroups=ndpts/10 + glen(1:ngroups)=10 + itemp=mod(ndpts,10) + if (itemp.ne.0) then + ngroups=ngroups+1 + glen(ngroups)=itemp + endif + elseif(ngroups<1) then + ! Dr. Glahn's algorithm failed; use simple packing method instead. + print *,'Glahn algorithm failed; use simple packing' + ngroups=ndpts/10 + glen(1:ngroups)=10 + itemp=mod(ndpts,10) + if (itemp.ne.0) then + ngroups=ngroups+1 + glen(ngroups)=itemp + endif + else +!print *,'SAGier = ',ier,ibit,jbit,kbit,novref,lbitref + do ng=1,ngroups + glen(ng)=glen(ng)+novref + enddo + deallocate(jmin) + deallocate(jmax) + deallocate(lbit) + endif + endif simplealg + ! + ! For each group, find the group's reference value + ! and the number of bits needed to hold the remaining values + ! + n=1 + do ng=1,ngroups + ! find max and min values of group + gref(ng)=ifld(n) + imax=ifld(n) + j=n+1 + do lg=2,glen(ng) + if (ifld(j).lt.gref(ng)) gref(ng)=ifld(j) + if (ifld(j).gt.imax) imax=ifld(j) + j=j+1 + enddo + ! calc num of bits needed to hold data + if ( gref(ng).ne.imax ) then + gwidth(ng)=i1log2(imax-gref(ng)) + else + gwidth(ng)=0 + endif + ! Subtract min from data + j=n + do lg=1,glen(ng) + ifld(j)=ifld(j)-gref(ng) + j=j+1 + enddo + ! increment fld array counter + n=n+glen(ng) + enddo + ! + ! Find max of the group references and calc num of bits needed + ! to pack each groups reference value, then + ! pack up group reference values + ! + !write(77,*)'GREFS: ',(gref(j),j=1,ngroups) + igmax=maxval(gref(1:ngroups)) + if (igmax.ne.0) then + nbitsgref=i1log2(igmax) + call sbytes(cpack,gref,iofst,nbitsgref,0,ngroups) + itemp=nbitsgref*ngroups + iofst=iofst+itemp + if (mod(itemp,8).ne.0) then + left=8-mod(itemp,8) + call sbyte(cpack,zero,iofst,left) + iofst=iofst+left + endif + else + nbitsgref=0 + endif + ! + ! Find max/min of the group widths and calc num of bits needed + ! to pack each groups width value, then + ! pack up group width values + ! + !write(77,*)'GWIDTHS: ',(gwidth(j),j=1,ngroups) + iwmax=maxval(gwidth(1:ngroups)) + ngwidthref=minval(gwidth(1:ngroups)) + if (iwmax.ne.ngwidthref) then + nbitsgwidth=i1log2(iwmax-ngwidthref) + do i=1,ngroups + gwidth(i)=gwidth(i)-ngwidthref + if(gwidth(i)<0) then + write(0,*) 'i,gw,ngw=',i,gwidth(i),ngwidthref + stop 9 + endif + enddo + call sbytes(cpack,gwidth,iofst,nbitsgwidth,0,ngroups) + itemp=nbitsgwidth*ngroups + iofst=iofst+itemp + ! Pad last octet with Zeros, if necessary, + if (mod(itemp,8).ne.0) then + left=8-mod(itemp,8) + call sbyte(cpack,zero,iofst,left) + iofst=iofst+left + endif + else + nbitsgwidth=0 + gwidth(1:ngroups)=0 + endif + ! + ! Find max/min of the group lengths and calc num of bits needed + ! to pack each groups length value, then + ! pack up group length values + ! + !write(77,*)'GLENS: ',(glen(j),j=1,ngroups) + ilmax=maxval(glen(1:ngroups-1)) + nglenref=minval(glen(1:ngroups-1)) + nglenlast=glen(ngroups) + if (ilmax.ne.nglenref) then + nbitsglen=i1log2(ilmax-nglenref) + do i=1,ngroups-1 + glen(i)=glen(i)-nglenref + if(glen(i)<0) then + write(0,*) 'i,glen(i) = ',i,glen(i) + stop 23 + endif + enddo + call sbytes(cpack,glen,iofst,nbitsglen,0,ngroups) + itemp=nbitsglen*ngroups + iofst=iofst+itemp + ! Pad last octet with Zeros, if necessary, + if (mod(itemp,8).ne.0) then + left=8-mod(itemp,8) + call sbyte(cpack,zero,iofst,left) + iofst=iofst+left + endif + else + nbitsglen=0 + glen(1:ngroups)=0 + endif + ! + ! For each group, pack data values + ! + !write(77,*)'IFLDS: ',(ifld(j),j=1,ndpts) + n=1 + ij=0 + do ng=1,ngroups + glength=glen(ng)+nglenref + if (ng.eq.ngroups ) glength=nglenlast + grpwidth=gwidth(ng)+ngwidthref + !write(77,*)'NGP ',ng,grpwidth,glength,gref(ng) + if ( grpwidth.ne.0 ) then + call sbytes(cpack,ifld(n),iofst,grpwidth,0,glength) + iofst=iofst+(grpwidth*glength) + endif + do kk=1,glength + ij=ij+1 + !write(77,*)'SAG ',ij,fld(ij),ifld(ij),gref(ng),bscale,rmin,dscale + enddo + n=n+glength + enddo + ! Pad last octet with Zeros, if necessary, + if (mod(iofst,8).ne.0) then + left=8-mod(iofst,8) + call sbyte(cpack,zero,iofst,left) + iofst=iofst+left + endif + lcpack=iofst/8 + ! + if ( allocated(ifld) ) deallocate(ifld) + if ( allocated(gref) ) deallocate(gref) + if ( allocated(gwidth) ) deallocate(gwidth) + if ( allocated(glen) ) deallocate(glen) + else ! Constant field ( max = min ) + lcpack=0 + nbitsgref=0 + ngroups=0 + ngwidthref=0 + nbitsgwidth=0 + nglenref=0 + nglenlast=0 + nbitsglen=0 + nbitsd=0 + endif multival + +! +! Fill in ref value and number of bits in Template 5.2 +! + rmin4 = rmin + call mkieee(rmin4,ref,1) ! ensure reference value is IEEE format +! call gbyte(ref,idrstmpl(1),0,32) + iref=transfer(ref,iref) + idrstmpl(1)=iref + idrstmpl(4)=nbitsgref + idrstmpl(5)=0 ! original data were reals + idrstmpl(6)=1 ! general group splitting + idrstmpl(7)=0 ! No internal missing values + idrstmpl(8)=0 ! Primary missing value + idrstmpl(9)=0 ! secondary missing value + idrstmpl(10)=ngroups ! Number of groups + idrstmpl(11)=ngwidthref ! reference for group widths + idrstmpl(12)=nbitsgwidth ! num bits used for group widths + idrstmpl(13)=nglenref ! Reference for group lengths + idrstmpl(14)=1 ! length increment for group lengths + idrstmpl(15)=nglenlast ! True length of last group + idrstmpl(16)=nbitsglen ! num bits used for group lengths + if (idrsnum.eq.3) then + idrstmpl(18)=nbitsd/8 ! num bits used for extra spatial + ! differencing values + endif + + end diff --git a/WPS/ungrib/src/ngl/g2/comunpack.f b/WPS/ungrib/src/ngl/g2/comunpack.f new file mode 100644 index 00000000..05b40735 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/comunpack.f @@ -0,0 +1,325 @@ + subroutine comunpack(cpack,len,lensec,idrsnum,idrstmpl,ndpts, + & fld,ier) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: comunpack +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-06-21 +! +! ABSTRACT: This subroutine unpacks a data field that was packed using a +! complex packing algorithm as defined in the GRIB2 documention, +! using info from the GRIB2 Data Representation Template 5.2 or 5.3. +! Supports GRIB2 complex packing templates with or without +! spatial differences (i.e. DRTs 5.2 and 5.3). +! +! PROGRAM HISTORY LOG: +! 2000-06-21 Gilbert +! 2004-12-29 Gilbert - Added test ( provided by Arthur Taylor/MDL ) +! to verify that group widths and lengths are +! consistent with section length. +! 2016-02-26 update unpacking for template 5.3 +! +! USAGE: CALL comunpack(cpack,len,lensec,idrsnum,idrstmpl,ndpts,fld,ier) +! INPUT ARGUMENT LIST: +! cpack - The packed data field (character*1 array) +! len - length of packed field cpack(). +! lensec - length of section 7 (used for error checking). +! idrsnum - Data Representation Template number 5.N +! Must equal 2 or 3. +! idrstmpl - Contains the array of values for Data Representation +! Template 5.2 or 5.3 +! ndpts - The number of data values to unpack +! +! OUTPUT ARGUMENT LIST: +! fld() - Contains the unpacked data values +! ier - Error return: +! 0 = OK +! 1 = Problem - inconsistent group lengths of widths. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: XL Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cpack(len) + integer,intent(in) :: ndpts,len + integer,intent(in) :: idrstmpl(*) + real,intent(out) :: fld(ndpts) + + integer,allocatable :: ifld(:),ifldmiss(:) + integer(4) :: ieee + integer,allocatable :: gref(:),gwidth(:),glen(:) + real :: ref,bscale,dscale,rmiss1,rmiss2 +! real :: fldo(6045) + integer :: totBit, totLen + + ier=0 + !print *,'IDRSTMPL: ',(idrstmpl(j),j=1,16) + ieee = idrstmpl(1) + call rdieee(ieee,ref,1) + bscale = 2.0**real(idrstmpl(2)) + dscale = 10.0**real(-idrstmpl(3)) + nbitsgref = idrstmpl(4) + itype = idrstmpl(5) + ngroups = idrstmpl(10) + nbitsgwidth = idrstmpl(12) + nbitsglen = idrstmpl(16) + if (idrsnum.eq.3) then + nbitsd=idrstmpl(18)*8 + endif + + ! Constant field + + if (ngroups.eq.0) then + do j=1,ndpts + fld(j)=ref + enddo + return + endif + + iofst=0 + allocate(ifld(ndpts),stat=is) + !print *,'ALLOC ifld: ',is,ndpts + allocate(gref(ngroups),stat=is) + !print *,'ALLOC gref: ',is + allocate(gwidth(ngroups),stat=is) + !print *,'ALLOC gwidth: ',is +! +! Get missing values, if supplied +! + if ( idrstmpl(7).eq.1 ) then + if (itype.eq.0) then + call rdieee(idrstmpl(8),rmiss1,1) + else + rmiss1=real(idrstmpl(8)) + endif + elseif ( idrstmpl(7).eq.2 ) then + if (itype.eq.0) then + call rdieee(idrstmpl(8),rmiss1,1) + call rdieee(idrstmpl(9),rmiss2,1) + else + rmiss1=real(idrstmpl(8)) + rmiss2=real(idrstmpl(9)) + endif + endif + !print *,'RMISSs: ',rmiss1,rmiss2,ref +! +! Extract Spatial differencing values, if using DRS Template 5.3 +! + if (idrsnum.eq.3) then + if (nbitsd.ne.0) then + call gbyte(cpack,ival1,iofst,nbitsd) + iofst=iofst+nbitsd + if (idrstmpl(17).eq.2) then + call gbyte(cpack,ival2,iofst,nbitsd) + iofst=iofst+nbitsd + endif + call gbyte(cpack,isign,iofst,1) + iofst=iofst+1 + call gbyte(cpack,minsd,iofst,nbitsd-1) + iofst=iofst+nbitsd-1 + if (isign.eq.1) minsd=-minsd + else + ival1=0 + ival2=0 + minsd=0 + endif + !print *,'SDu ',ival1,ival2,minsd,nbitsd + endif +! +! Extract Each Group's reference value +! + !print *,'SAG1: ',nbitsgref,ngroups,iofst + if (nbitsgref.ne.0) then + call gbytes(cpack,gref,iofst,nbitsgref,0,ngroups) + itemp=nbitsgref*ngroups + iofst=iofst+(itemp) + if (mod(itemp,8).ne.0) iofst=iofst+(8-mod(itemp,8)) + else + gref(1:ngroups)=0 + endif + !write(78,*)'GREFs: ',(gref(j),j=1,ngroups) +! +! Extract Each Group's bit width +! + !print *,'SAG2: ',nbitsgwidth,ngroups,iofst,idrstmpl(11) + if (nbitsgwidth.ne.0) then + call gbytes(cpack,gwidth,iofst,nbitsgwidth,0,ngroups) + itemp=nbitsgwidth*ngroups + iofst=iofst+(itemp) + if (mod(itemp,8).ne.0) iofst=iofst+(8-mod(itemp,8)) + else + gwidth(1:ngroups)=0 + endif + do j=1,ngroups + gwidth(j)=gwidth(j)+idrstmpl(11) + enddo + !write(78,*)'GWIDTHs: ',(gwidth(j),j=1,ngroups) +! +! Extract Each Group's length (number of values in each group) +! + allocate(glen(ngroups),stat=is) + !print *,'ALLOC glen: ',is + !print *,'SAG3: ',nbitsglen,ngroups,iofst,idrstmpl(14),idrstmpl(13) + if (nbitsglen.ne.0) then + call gbytes(cpack,glen,iofst,nbitsglen,0,ngroups) + itemp=nbitsglen*ngroups + iofst=iofst+(itemp) + if (mod(itemp,8).ne.0) iofst=iofst+(8-mod(itemp,8)) + else + glen(1:ngroups)=0 + endif + do j=1,ngroups + glen(j)=(glen(j)*idrstmpl(14))+idrstmpl(13) + enddo + glen(ngroups)=idrstmpl(15) + !write(78,*)'GLENs: ',(glen(j),j=1,ngroups) + !print *,'GLENsum: ',sum(glen) +! +! Test to see if the group widths and lengths are consistent with number of +! values, and length of section 7. +! + totBit = 0 + totLen = 0 + do j=1,ngroups + totBit = totBit + (gwidth(j)*glen(j)); + totLen = totLen + glen(j); + enddo + if (totLen .NE. ndpts) then + ier=1 + return + endif + if ( (totBit/8) .GT. lensec) then + ier=1 + return + endif +! +! For each group, unpack data values +! + if ( idrstmpl(7).eq.0 ) then ! no missing values + n=1 + do j=1,ngroups + !write(78,*)'NGP ',j,gwidth(j),glen(j),gref(j) + if (gwidth(j).ne.0) then + call gbytes(cpack,ifld(n),iofst,gwidth(j),0,glen(j)) + do k=1,glen(j) + ifld(n)=ifld(n)+gref(j) + n=n+1 + enddo + else + ifld(n:n+glen(j)-1)=gref(j) + n=n+glen(j) + endif + iofst=iofst+(gwidth(j)*glen(j)) + enddo + elseif ( idrstmpl(7).eq.1.OR.idrstmpl(7).eq.2 ) then + ! missing values included + allocate(ifldmiss(ndpts)) + !ifldmiss=0 + n=1 + non=1 + do j=1,ngroups + !print *,'SAGNGP ',j,gwidth(j),glen(j),gref(j) + if (gwidth(j).ne.0) then + msng1=(2**gwidth(j))-1 + msng2=msng1-1 + call gbytes(cpack,ifld(n),iofst,gwidth(j),0,glen(j)) + iofst=iofst+(gwidth(j)*glen(j)) + do k=1,glen(j) + if (ifld(n).eq.msng1) then + ifldmiss(n)=1 + elseif (idrstmpl(7).eq.2.AND.ifld(n).eq.msng2) then + ifldmiss(n)=2 + else + ifldmiss(n)=0 + ifld(non)=ifld(n)+gref(j) + non=non+1 + endif + n=n+1 + enddo + else + msng1=(2**nbitsgref)-1 + msng2=msng1-1 + if (gref(j).eq.msng1) then + ifldmiss(n:n+glen(j)-1)=1 + !ifld(n:n+glen(j)-1)=0 + elseif (idrstmpl(7).eq.2.AND.gref(j).eq.msng2) then + ifldmiss(n:n+glen(j)-1)=2 + !ifld(n:n+glen(j)-1)=0 + else + ifldmiss(n:n+glen(j)-1)=0 + ifld(non:non+glen(j)-1)=gref(j) + non=non+glen(j) + endif + n=n+glen(j) + endif + enddo + endif + !write(78,*)'IFLDs: ',(ifld(j),j=1,ndpts) + + if ( allocated(gref) ) deallocate(gref) + if ( allocated(gwidth) ) deallocate(gwidth) + if ( allocated(glen) ) deallocate(glen) +! +! If using spatial differences, add overall min value, and +! sum up recursively +! + if (idrsnum.eq.3) then ! spatial differencing + if (idrstmpl(17).eq.1) then ! first order + ifld(1)=ival1 + if ( idrstmpl(7).eq.0 ) then ! no missing values + itemp=ndpts + else + itemp=non-1 + endif + do n=2,itemp + ifld(n)=ifld(n)+minsd + ifld(n)=ifld(n)+ifld(n-1) + enddo + elseif (idrstmpl(17).eq.2) then ! second order + ifld(1)=ival1 + ifld(2)=ival2 + if ( idrstmpl(7).eq.0 ) then ! no missing values + itemp=ndpts + else + itemp=non-1 + endif + do n=3,itemp + ifld(n)=ifld(n)+minsd + ifld(n)=ifld(n)+(2*ifld(n-1))-ifld(n-2) + enddo + endif + !write(78,*)'IFLDs: ',(ifld(j),j=1,ndpts) + endif +! +! Scale data back to original form +! + !print *,'SAGT: ',ref,bscale,dscale + if ( idrstmpl(7).eq.0 ) then ! no missing values + do n=1,ndpts + fld(n)=((real(ifld(n))*bscale)+ref)*dscale + !write(78,*)'SAG ',n,fld(n),ifld(n),bscale,ref,1./dscale + enddo + elseif ( idrstmpl(7).eq.1.OR.idrstmpl(7).eq.2 ) then + ! missing values included + non=1 + do n=1,ndpts + if ( ifldmiss(n).eq.0 ) then + fld(n)=((real(ifld(non))*bscale)+ref)*dscale + !print *,'SAG ',n,fld(n),ifld(non),bscale,ref,dscale + non=non+1 + elseif ( ifldmiss(n).eq.1 ) then + fld(n)=rmiss1 + elseif ( ifldmiss(n).eq.2 ) then + fld(n)=rmiss2 + endif + enddo + if ( allocated(ifldmiss) ) deallocate(ifldmiss) + endif + + if ( allocated(ifld) ) deallocate(ifld) + + return + end diff --git a/WPS/ungrib/src/ngl/g2/dec_jpeg2000.c b/WPS/ungrib/src/ngl/g2/dec_jpeg2000.c new file mode 100755 index 00000000..2f9df244 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/dec_jpeg2000.c @@ -0,0 +1,152 @@ +#include +#include +#include +#ifdef USE_JPEG2000 +#include "jasper/jasper.h" +#define JAS_1_700_2 +#endif /* USE_JPEG2000 */ + + +#ifdef __64BIT__ + typedef int g2int; +#else + typedef long g2int; +#endif + +#if defined _UNDERSCORE + #define dec_jpeg2000 dec_jpeg2000_ +#elif defined _DOUBLEUNDERSCORE + #define dec_jpeg2000 dec_jpeg2000__ +#endif + + int dec_jpeg2000(char *injpc,g2int *bufsize,g2int *outfld) +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +* . . . . +* SUBPROGRAM: dec_jpeg2000 Decodes JPEG2000 code stream +* PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-12-02 +* +* ABSTRACT: This Function decodes a JPEG2000 code stream specified in the +* JPEG2000 Part-1 standard (i.e., ISO/IEC 15444-1) using JasPer +* Software version 1.500.4 (or 1.700.2) written by the University of British +* Columbia and Image Power Inc, and others. +* JasPer is available at http://www.ece.uvic.ca/~mdadams/jasper/. +* +* PROGRAM HISTORY LOG: +* 2002-12-02 Gilbert +* +* USAGE: int dec_jpeg2000(char *injpc,g2int *bufsize,g2int *outfld) +* +* INPUT ARGUMENTS: +* injpc - Input JPEG2000 code stream. +* bufsize - Length (in bytes) of the input JPEG2000 code stream. +* +* INPUT ARGUMENTS: +* outfld - Output matrix of grayscale image values. +* +* RETURN VALUES : +* 0 = Successful decode +* -3 = Error decode jpeg2000 code stream. +* -5 = decoded image had multiple color components. +* Only grayscale is expected. +* +* REMARKS: +* +* Requires JasPer Software version 1.500.4 or 1.700.2 +* +* ATTRIBUTES: +* LANGUAGE: C +* MACHINE: IBM SP +* +*$$$*/ + +{ +#ifdef USE_JPEG2000 + int ier; + g2int i,j,k,n; + jas_image_t *image=0; + jas_stream_t *jpcstream,*istream; + jas_image_cmpt_t cmpt,*pcmpt; + char *opts=0; + jas_matrix_t *data; + +/* jas_init(); */ + +/* + * Create jas_stream_t containing input JPEG200 codestream in memory. + */ + + jpcstream=jas_stream_memopen(injpc,*bufsize); + +/* + * Decode JPEG200 codestream into jas_image_t structure. + */ + image=jpc_decode(jpcstream,opts); + if ( image == 0 ) { + printf(" jpc_decode return = %d \n",ier); + return -3; + } + + pcmpt=image->cmpts_[0]; +/* + printf(" SAGOUT DECODE:\n"); + printf(" tlx %d \n",image->tlx_); + printf(" tly %d \n",image->tly_); + printf(" brx %d \n",image->brx_); + printf(" bry %d \n",image->bry_); + printf(" numcmpts %d \n",image->numcmpts_); + printf(" maxcmpts %d \n",image->maxcmpts_); +#ifdef JAS_1_500_4 + printf(" colormodel %d \n",image->colormodel_); +#endif +#ifdef JAS_1_700_2 + printf(" colorspace %d \n",image->clrspc_); +#endif + printf(" inmem %d \n",image->inmem_); + printf(" COMPONENT:\n"); + printf(" tlx %d \n",pcmpt->tlx_); + printf(" tly %d \n",pcmpt->tly_); + printf(" hstep %d \n",pcmpt->hstep_); + printf(" vstep %d \n",pcmpt->vstep_); + printf(" width %d \n",pcmpt->width_); + printf(" height %d \n",pcmpt->height_); + printf(" prec %d \n",pcmpt->prec_); + printf(" sgnd %d \n",pcmpt->sgnd_); + printf(" cps %d \n",pcmpt->cps_); +#ifdef JAS_1_700_2 + printf(" type %d \n",pcmpt->type_); +#endif +*/ + +/* Expecting jpeg2000 image to be grayscale only. + * No color components. + */ + if (image->numcmpts_ != 1 ) { + printf("dec_jpeg2000: Found color image. Grayscale expected.\n"); + return (-5); + } + +/* + * Create a data matrix of grayscale image values decoded from + * the jpeg2000 codestream. + */ + data=jas_matrix_create(jas_image_height(image), jas_image_width(image)); + jas_image_readcmpt(image,0,0,0,jas_image_width(image), + jas_image_height(image),data); +/* + * Copy data matrix to output integer array. + */ + k=0; + for (i=0;iheight_;i++) + for (j=0;jwidth_;j++) + outfld[k++]=data->rows_[i][j]; +/* + * Clean up JasPer work structures. + */ + jas_matrix_destroy(data); + ier=jas_stream_close(jpcstream); + jas_image_destroy(image); + +#endif /* USE_JPEG2000 */ + return 0; + +} diff --git a/WPS/ungrib/src/ngl/g2/dec_png.c b/WPS/ungrib/src/ngl/g2/dec_png.c new file mode 100755 index 00000000..75dee08d --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/dec_png.c @@ -0,0 +1,157 @@ +#include +#include +#include +#ifdef USE_PNG +#include +#include +#endif /* USE_PNG */ + +#ifdef __64BIT__ + typedef int g2int; +#else + typedef long g2int; +#endif + +#if defined _UNDERSCORE + #define dec_png dec_png_ +#elif defined _DOUBLEUNDERSCORE + #define dec_png dec_png__ +#endif + +#ifdef USE_PNG +struct png_stream { + unsigned char *stream_ptr; /* location to write PNG stream */ + g2int stream_len; /* number of bytes written */ +}; +typedef struct png_stream png_stream; + +void user_read_data(png_structp , png_bytep , png_uint_32 ); + +void user_read_data(png_structp png_ptr,png_bytep data, png_uint_32 length) +/* + Custom read function used so that libpng will read a PNG stream + from memory instead of a file on disk. +*/ +{ + char *ptr; + g2int offset; + png_stream *mem; + + mem=(png_stream *)png_get_io_ptr(png_ptr); + ptr=(void *)mem->stream_ptr; + offset=mem->stream_len; +/* printf("SAGrd %ld %ld %x\n",offset,length,ptr); */ + memcpy(data,ptr+offset,length); + mem->stream_len += length; +} +#endif /* USE_PNG */ + + + +int dec_png(unsigned char *pngbuf,g2int *width,g2int *height,char *cout) +{ +#ifdef USE_PNG + int interlace,color,compres,filter,bit_depth; + g2int j,k,n,bytes,clen; + png_structp png_ptr; + png_infop info_ptr,end_info; + png_bytepp row_pointers; + png_stream read_io_ptr; + png_uint_32 h32, w32; + +/* check if stream is a valid PNG format */ + + if ( png_sig_cmp(pngbuf,0,8) != 0) + return (-3); + +/* create and initialize png_structs */ + + png_ptr = png_create_read_struct(PNG_LIBPNG_VER_STRING, (png_voidp)NULL, + NULL, NULL); + if (!png_ptr) + return (-1); + + info_ptr = png_create_info_struct(png_ptr); + if (!info_ptr) + { + png_destroy_read_struct(&png_ptr,(png_infopp)NULL,(png_infopp)NULL); + return (-2); + } + + end_info = png_create_info_struct(png_ptr); + if (!end_info) + { + png_destroy_read_struct(&png_ptr,(png_infopp)info_ptr,(png_infopp)NULL); + return (-2); + } + +/* Set Error callback */ + + if (setjmp(png_jmpbuf(png_ptr))) + { + png_destroy_read_struct(&png_ptr, &info_ptr,&end_info); + return (-3); + } + +/* Initialize info for reading PNG stream from memory */ + + read_io_ptr.stream_ptr=(png_voidp)pngbuf; + read_io_ptr.stream_len=0; + +/* Set new custom read function */ + + png_set_read_fn(png_ptr,(png_voidp)&read_io_ptr,(png_rw_ptr)user_read_data); +/* png_init_io(png_ptr, fptr); */ + +/* Read and decode PNG stream */ + + png_read_png(png_ptr, info_ptr, PNG_TRANSFORM_IDENTITY, NULL); + +/* Get pointer to each row of image data */ + + row_pointers = png_get_rows(png_ptr, info_ptr); + +/* Get image info, such as size, depth, colortype, etc... */ + + /*printf("SAGT:png %d %d %d\n",info_ptr->width,info_ptr->height,info_ptr->bit_depth);*/ +/* (void)png_get_IHDR(png_ptr, info_ptr, (png_uint_32 *)width, (png_uint_32 *)height, + &bit_depth, &color, &interlace, &compres, &filter);*/ + (void)png_get_IHDR(png_ptr, info_ptr, &w32, &h32, + &bit_depth, &color, &interlace, &compres, &filter); + + *height = h32; + *width = w32; + +/* Check if image was grayscale */ + +/* + if (color != PNG_COLOR_TYPE_GRAY ) { + fprintf(stderr,"dec_png: Grayscale image was expected. \n"); + } +*/ + if ( color == PNG_COLOR_TYPE_RGB ) { + bit_depth=24; + } + else if ( color == PNG_COLOR_TYPE_RGB_ALPHA ) { + bit_depth=32; + } +/* Copy image data to output string */ + + n=0; + bytes=bit_depth/8; + clen=(*width)*bytes; + for (j=0;j<*height;j++) { + for (k=0;k +#include +#include +#ifdef USE_JPEG2000 +#include "jasper/jasper.h" +#define JAS_1_700_2 +#endif /* USE_JPEG2000 */ + +#ifdef __64BIT__ + typedef int g2int; +#else + typedef long g2int; +#endif + + +#if defined _UNDERSCORE + #define enc_jpeg2000 enc_jpeg2000_ +#elif defined _DOUBLEUNDERSCORE + #define enc_jpeg2000 enc_jpeg2000__ +#endif + + +int enc_jpeg2000(unsigned char *cin,g2int *pwidth,g2int *pheight,g2int *pnbits, + g2int *ltype, g2int *ratio, g2int *retry, char *outjpc, + g2int *jpclen) +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +* . . . . +* SUBPROGRAM: enc_jpeg2000 Encodes JPEG2000 code stream +* PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-12-02 +* +* ABSTRACT: This Function encodes a grayscale image into a JPEG2000 code stream +* specified in the JPEG2000 Part-1 standard (i.e., ISO/IEC 15444-1) +* using JasPer Software version 1.500.4 (or 1.700.2 ) written by the +* University of British Columbia, Image Power Inc, and others. +* JasPer is available at http://www.ece.uvic.ca/~mdadams/jasper/. +* +* PROGRAM HISTORY LOG: +* 2002-12-02 Gilbert +* 2004-07-20 GIlbert - Added retry argument/option to allow option of +* increasing the maximum number of guard bits to the +* JPEG2000 algorithm. +* +* USAGE: int enc_jpeg2000(unsigned char *cin,g2int *pwidth,g2int *pheight, +* g2int *pnbits, g2int *ltype, g2int *ratio, +* g2int *retry, char *outjpc, g2int *jpclen) +* +* INPUT ARGUMENTS: +* cin - Packed matrix of Grayscale image values to encode. +* pwidth - Pointer to width of image +* pheight - Pointer to height of image +* pnbits - Pointer to depth (in bits) of image. i.e number of bits +* used to hold each data value +* ltype - Pointer to indicator of lossless or lossy compression +* = 1, for lossy compression +* != 1, for lossless compression +* ratio - Pointer to target compression ratio. (ratio:1) +* Used only when *ltype == 1. +* retry - Pointer to option type. +* 1 = try increasing number of guard bits +* otherwise, no additional options +* jpclen - Number of bytes allocated for new JPEG2000 code stream in +* outjpc. +* +* INPUT ARGUMENTS: +* outjpc - Output encoded JPEG2000 code stream +* +* RETURN VALUES : +* > 0 = Length in bytes of encoded JPEG2000 code stream +* -3 = Error decode jpeg2000 code stream. +* -5 = decoded image had multiple color components. +* Only grayscale is expected. +* +* REMARKS: +* +* Requires JasPer Software version 1.500.4 or 1.700.2 +* +* ATTRIBUTES: +* LANGUAGE: C +* MACHINE: IBM SP +* +*$$$*/ +{ + int rwcnt = 0; +#ifdef USE_JPEG2000 + int ier ; + jas_image_t image; + jas_stream_t *jpcstream,*istream; + jas_image_cmpt_t cmpt,*pcmpt; +#define MAXOPTSSIZE 1024 + char opts[MAXOPTSSIZE]; + + g2int width,height,nbits; + width=*pwidth; + height=*pheight; + nbits=*pnbits; +/* + printf(" enc_jpeg2000:width %ld\n",width); + printf(" enc_jpeg2000:height %ld\n",height); + printf(" enc_jpeg2000:nbits %ld\n",nbits); + printf(" enc_jpeg2000:jpclen %ld\n",*jpclen); +*/ +/* jas_init(); */ + +/* + * Set lossy compression options, if requested. + */ + if ( *ltype != 1 ) { + opts[0]=(char)0; + } + else { + snprintf(opts,MAXOPTSSIZE,"mode=real\nrate=%f",1.0/(float)*ratio); + } + if ( *retry == 1 ) { /* option to increase number of guard bits */ + strcat(opts,"\nnumgbits=4"); + } + /* printf("SAGopts: %s\n",opts); */ + +/* + * Initialize the JasPer image structure describing the grayscale + * image to encode into the JPEG2000 code stream. + */ + image.tlx_=0; + image.tly_=0; +#ifdef JAS_1_500_4 + image.brx_=(uint_fast32_t)width; + image.bry_=(uint_fast32_t)height; +#endif +#ifdef JAS_1_700_2 + image.brx_=(jas_image_coord_t)width; + image.bry_=(jas_image_coord_t)height; +#endif + image.numcmpts_=1; + image.maxcmpts_=1; +#ifdef JAS_1_500_4 + image.colormodel_=JAS_IMAGE_CM_GRAY; /* grayscale Image */ +#endif +#ifdef JAS_1_700_2 + image.clrspc_=JAS_CLRSPC_SGRAY; /* grayscale Image */ + image.cmprof_=0; +#endif + image.inmem_=1; + + cmpt.tlx_=0; + cmpt.tly_=0; + cmpt.hstep_=1; + cmpt.vstep_=1; +#ifdef JAS_1_500_4 + cmpt.width_=(uint_fast32_t)width; + cmpt.height_=(uint_fast32_t)height; +#endif +#ifdef JAS_1_700_2 + cmpt.width_=(jas_image_coord_t)width; + cmpt.height_=(jas_image_coord_t)height; + cmpt.type_=JAS_IMAGE_CT_COLOR(JAS_CLRSPC_CHANIND_GRAY_Y); +#endif + cmpt.prec_=nbits; + cmpt.sgnd_=0; + cmpt.cps_=(nbits+7)/8; + + pcmpt=&cmpt; + image.cmpts_=&pcmpt; + +/* + * Open a JasPer stream containing the input grayscale values + */ + istream=jas_stream_memopen((char *)cin,height*width*cmpt.cps_); + cmpt.stream_=istream; + +/* + * Open an output stream that will contain the encoded jpeg2000 + * code stream. + */ + jpcstream=jas_stream_memopen(outjpc,(int)(*jpclen)); + +/* + * Encode image. + */ + ier=jpc_encode(&image,jpcstream,opts); + if ( ier != 0 ) { + printf(" jpc_encode return = %d \n",ier); + return -3; + } +/* + * Clean up JasPer work structures. + */ + rwcnt=jpcstream->rwcnt_; + ier=jas_stream_close(istream); + ier=jas_stream_close(jpcstream); +/* + * Return size of jpeg2000 code stream + */ +#endif /* USE_JPEG2000 */ + return (rwcnt); + +} diff --git a/WPS/ungrib/src/ngl/g2/enc_png.c b/WPS/ungrib/src/ngl/g2/enc_png.c new file mode 100755 index 00000000..cb43f6cc --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/enc_png.c @@ -0,0 +1,145 @@ +#include +#include +#include +#ifdef USE_PNG +#include +#include +#endif /* USE_PNG */ + +#ifdef __64BIT__ + typedef int g2int; +#else + typedef long g2int; +#endif + +#if defined _UNDERSCORE + #define enc_png enc_png_ +#elif defined _DOUBLEUNDERSCORE + #define enc_png enc_png__ +#endif + +#ifdef USE_PNG +struct png_stream { + unsigned char *stream_ptr; /* location to write PNG stream */ + g2int stream_len; /* number of bytes written */ +}; +typedef struct png_stream png_stream; + +void user_write_data(png_structp ,png_bytep , png_uint_32 ); +void user_flush_data(png_structp ); + +void user_write_data(png_structp png_ptr,png_bytep data, png_uint_32 length) +/* + Custom write function used to that libpng will write + to memory location instead of a file on disk +*/ +{ + unsigned char *ptr; + g2int offset; + png_stream *mem; + + mem=(png_stream *)png_get_io_ptr(png_ptr); + ptr=mem->stream_ptr; + offset=mem->stream_len; +/* printf("SAGwr %ld %ld %x\n",offset,length,ptr); */ + /*for (j=offset,k=0;kstream_len += length; +} + + +void user_flush_data(png_structp png_ptr) +/* + Dummy Custom flush function +*/ +{ + int *do_nothing=NULL; +} +#endif /* USE_PNG */ + + +int enc_png(char *data,g2int *width,g2int *height,g2int *nbits,char *pngbuf) +{ + g2int pnglen; +#ifdef USE_PNG + int color_type; + g2int j,bytes,bit_depth; + png_structp png_ptr; + png_infop info_ptr; +/* png_bytep *row_pointers[*height]; */ + png_bytep **row_pointers; + png_stream write_io_ptr; + +/* create and initialize png_structs */ + + png_ptr = png_create_write_struct(PNG_LIBPNG_VER_STRING, (png_voidp)NULL, + NULL, NULL); + if (!png_ptr) + return (-1); + + info_ptr = png_create_info_struct(png_ptr); + if (!info_ptr) + { + png_destroy_write_struct(&png_ptr,(png_infopp)NULL); + return (-2); + } + +/* Set Error callback */ + + if (setjmp(png_jmpbuf(png_ptr))) + { + png_destroy_write_struct(&png_ptr, &info_ptr); + return (-3); + } + +/* Initialize info for writing PNG stream to memory */ + + write_io_ptr.stream_ptr=(png_voidp)pngbuf; + write_io_ptr.stream_len=0; + +/* Set new custom write functions */ + + png_set_write_fn(png_ptr,(png_voidp)&write_io_ptr,(png_rw_ptr)user_write_data, + (png_flush_ptr)user_flush_data); +/* png_init_io(png_ptr, fptr); */ +/* png_set_compression_level(png_ptr, Z_BEST_COMPRESSION); */ + +/* Set the image size, colortype, filter type, etc... */ + +/* printf("SAGTsettingIHDR %d %d %d\n",*width,*height,bit_depth); */ + bit_depth=*nbits; + color_type=PNG_COLOR_TYPE_GRAY; + if (*nbits == 24 ) { + bit_depth=8; + color_type=PNG_COLOR_TYPE_RGB; + } + else if (*nbits == 32 ) { + bit_depth=8; + color_type=PNG_COLOR_TYPE_RGB_ALPHA; + } + png_set_IHDR(png_ptr, info_ptr, *width, *height, + bit_depth, color_type, PNG_INTERLACE_NONE, + PNG_COMPRESSION_TYPE_DEFAULT, PNG_FILTER_TYPE_DEFAULT); + +/* Put image data into the PNG info structure */ + + /*bytes=bit_depth/8;*/ + bytes=*nbits/8; + row_pointers=malloc((*height)*sizeof(png_bytep)); + for (j=0;j<*height;j++) row_pointers[j]=(png_bytep *)(data+(j*(*width)*bytes)); + png_set_rows(png_ptr, info_ptr, (png_bytepp)row_pointers); + +/* Do the PNG encoding, and write out PNG stream */ + + png_write_png(png_ptr, info_ptr, PNG_TRANSFORM_IDENTITY, NULL); + +/* Clean up */ + + png_destroy_write_struct(&png_ptr, &info_ptr); + free(row_pointers); + pnglen=write_io_ptr.stream_len; +#endif /* USE_PNG */ + return pnglen; + +} + diff --git a/WPS/ungrib/src/ngl/g2/g2grids.f b/WPS/ungrib/src/ngl/g2/g2grids.f new file mode 100755 index 00000000..dd97999a --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/g2grids.f @@ -0,0 +1,320 @@ + module g2grids +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! MODULE: g2grids +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2004-04-27 +! +! ABSTRACT: This Fortran Module allows access to predefined GRIB2 Grid +! Definition Templates stored in a file. The GDTs are represented by +! a predefined number or a character abbreviation. +! +! At the first request, all the grid GDT entries in the file associated +! with input Fortran file unit number, lunit, are read into a linked list +! named gridlist. This list is searched for the requested entry. +! +! Users of this Fortran module should only call routines getgridbynum +! and getgridbyname. +! +! The format of the file scanned by routines in this module is as follows. +! Each line contains one Grid entry containing five fields, each separated +! by a colon, ":". The fields are: +! 1) - predefined grid number +! 2) - Up to an 8 character abbreviation +! 3) - Grid Definition Template number +! 4) - Number of entries in the Grid Definition Template +! 5) - A list of values for each entry in the Grid Definition Template. +! +! As an example, this is the entry for the 1x1 GFS global grid +! 3:gbl_1deg: 0:19: 0 0 0 0 0 0 0 360 181 0 0 90000000 0 48 -90000000 359000000 1000000 1000000 0 +! +! Comments can be included in the file by specifying the symbol "#" as the +! first character on the line. These lines are ignored. +! +! +! PROGRAM HISTORY LOG: +! 2004-04-27 Gilbert +! +! USAGE: use g2grids +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + integer,parameter :: MAXTEMP=200 + + type,private :: g2grid + integer :: grid_num + integer :: gdt_num + integer :: gdt_len + integer,dimension(MAXTEMP) :: gridtmpl + character(len=8) :: cdesc + type(g2grid),pointer :: next + end type g2grid + + type(g2grid),pointer,private :: gridlist + integer :: num_grids=0 + + contains + + + integer function readgrids(lunit) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: readgrids +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2001-06-28 +! +! ABSTRACT: This function reads the list of GDT entries in the file +! associated with fortran unit, lunit. All the entries are stored in a +! linked list called gridlist. +! +! PROGRAM HISTORY LOG: +! 2001-06-28 Gilbert +! +! USAGE: number=readgrids(lunit) +! INPUT ARGUMENT LIST: +! lunit - Fortran unit number associated the the GDT file. +! +! RETURNS: The number of Grid Definition Templates read in. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: lunit + + integer,parameter :: linelen=1280 + character(len=8) :: desc + character(len=linelen) :: cline + integer ient,igdtn,igdtmpl(200),igdtlen + integer :: pos1,pos2,pos3,pos4 + + type(g2grid),pointer :: gtemp + type(g2grid),pointer :: prev + integer count + + count=0 + + ! For each line in the file.... + DO + ! Read line into buffer + ! + cline(1:linelen)=' ' + read(lunit,end=999,fmt='(a)') cline + + ! + ! Skip line if commented out + ! + if (cline(1:1).eq.'#') cycle + + ! + ! find positions of delimiters, ":" + ! + pos1=index(cline,':') + cline(pos1:pos1)=';' + pos2=index(cline,':') + cline(pos2:pos2)=';' + pos3=index(cline,':') + cline(pos3:pos3)=';' + pos4=index(cline,':') + if ( pos1.eq.0 .or. pos2.eq.0 .or. pos3.eq.0 .or. + & pos4.eq.0) cycle + + ! + ! Read each of the five fields. + ! + read(cline(1:pos1-1),*) ient + read(cline(pos1+1:pos2-1),*) desc + read(cline(pos2+1:pos3-1),*) igdtn + read(cline(pos3+1:pos4-1),*) igdtlen + read(cline(pos4+1:linelen),*) (igdtmpl(j),j=1,igdtlen) + + ! + ! Allocate new type(g2grid) variable to store the GDT + ! + allocate(gtemp,stat=iom) + count=count+1 + gtemp%grid_num=ient + gtemp%gdt_num=igdtn + gtemp%gdt_len=igdtlen + gtemp%gridtmpl=igdtmpl + gtemp%cdesc=desc + nullify(gtemp%next) ! defines end of linked list. + if ( count .eq. 1 ) then + gridlist => gtemp + else ! make sure previous entry in list + prev%next => gtemp ! points to the new entry, + endif + prev => gtemp + + enddo + + 999 readgrids=count + return + + end function + + + subroutine getgridbynum(lunit,number,igdtn,igdtmpl,iret) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getgridbynum +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2004-04-26 +! +! ABSTRACT: This subroutine searches a file referenced by fortran unit lunit +! for a Grid Definition Template assigned to the requested number. +! The input file format is described at the top of this module. +! +! PROGRAM HISTORY LOG: +! 2004-04-26 Gilbert +! +! USAGE: CALL getgridbynum(lunit,number,igdtn,igdtmpl,iret) +! INPUT ARGUMENT LIST: +! lunit - Unit number of file containing Grid definitions +! number - Grid number of the requested Grid definition +! +! OUTPUT ARGUMENT LIST: +! igdtn - NN, indicating the number of the Grid Definition +! Template 3.NN +! igdtmpl()- An array containing the values of each entry in +! the Grid Definition Template. +! iret - Error return code. +! 0 = no error +! -1 = Undefined Grid number. +! 3 = Could not read any grids from file. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: lunit,number + integer,intent(out) :: igdtn,igdtmpl(*),iret + + type(g2grid),pointer :: tempgrid + + iret=0 + igdtn=-1 + !igdtmpl=0 + + ! + ! If no grids in list, try reading them from the file. + ! + if ( num_grids .eq. 0 ) then + num_grids=readgrids(lunit) + endif + + if ( num_grids .eq. 0 ) then + iret=3 ! problem reading file + return + endif + + tempgrid => gridlist + + ! + ! Search through list + ! + do while ( associated(tempgrid) ) + if ( number .eq. tempgrid%grid_num ) then + igdtn=tempgrid%gdt_num + igdtmpl(1:tempgrid%gdt_len)= + & tempgrid%gridtmpl(1:tempgrid%gdt_len) + return + else + tempgrid => tempgrid%next + endif + enddo + + iret=-1 + return + + end subroutine + + + subroutine getgridbyname(lunit,name,igdtn,igdtmpl,iret) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getgridbyname +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2004-04-26 +! +! ABSTRACT: This subroutine searches a file referenced by fortran unit lunit +! for a Grid Definition Template assigned to the requested name. +! The input file format is described at the top of this module. +! +! PROGRAM HISTORY LOG: +! 2004-04-26 Gilbert +! +! USAGE: CALL getgridbyname(lunit,name,igdtn,igdtmpl,iret) +! INPUT ARGUMENT LIST: +! lunit - Unit number of file containing Grid definitions +! name - Grid name of the requested Grid definition +! +! OUTPUT ARGUMENT LIST: +! igdtn - NN, indicating the number of the Grid Definition +! Template 3.NN +! igdtmpl()- An array containing the values of each entry in +! the Grid Definition Template. +! iret - Error return code. +! 0 = no error +! -1 = Undefined Grid number. +! 3 = Could not read any grids from file. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: lunit + character(len=8),intent(in) :: name + integer,intent(out) :: igdtn,igdtmpl(*),iret + + type(g2grid),pointer :: tempgrid + + iret=0 + igdtn=-1 + !igdtmpl=0 + + ! + ! If no grids in list, try reading them from the file. + ! + if ( num_grids .eq. 0 ) then + num_grids=readgrids(lunit) + endif + + if ( num_grids .eq. 0 ) then + iret=3 ! problem reading file + return + endif + + tempgrid => gridlist + + ! + ! Search through list + ! + do while ( associated(tempgrid) ) + if ( name .eq. tempgrid%cdesc ) then + igdtn=tempgrid%gdt_num + igdtmpl(1:tempgrid%gdt_len)= + & tempgrid%gridtmpl(1:tempgrid%gdt_len) + return + else + tempgrid => tempgrid%next + endif + enddo + + iret=-1 + return + + end subroutine + + + end + diff --git a/WPS/ungrib/src/ngl/g2/gb_info.f b/WPS/ungrib/src/ngl/g2/gb_info.f new file mode 100755 index 00000000..b346eb0f --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gb_info.f @@ -0,0 +1,194 @@ + subroutine gb_info(cgrib,lcgrib,listsec0,listsec1, + & numfields,numlocal,maxlocal,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gb_info +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-25 +! +! ABSTRACT: This subroutine searches through a GRIB2 message and +! returns the number of gridded fields found in the message and +! the number (and maximum size) of Local Use Sections. +! Also various checks are performed +! to see if the message is a valid GRIB2 message. +! +! PROGRAM HISTORY LOG: +! 2000-05-25 Gilbert +! +! USAGE: CALL gb_info(cgrib,lcgrib,listsec0,listsec1, +! & numfields,numlocal,maxlocal,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message in array cgrib. +! +! OUTPUT ARGUMENT LIST: +! listsec0 - Contains information decoded from GRIB Indicator Section 0. +! Must be dimensioned >= 2. +! listsec0(1)=Discipline-GRIB Master Table Number +! (see Code Table 0.0) +! listsec0(2)=GRIB Edition Number (currently 2) +! listsec0(3)=Length of GRIB message +! listsec1 - Contains information read from GRIB Identification Section 1. +! Must be dimensioned >= 13. +! listsec1(1)=Id of orginating centre (Common Code Table C-1) +! listsec1(2)=Id of orginating sub-centre (local table) +! listsec1(3)=GRIB Master Tables Version Number (Code Table 1.0) +! listsec1(4)=GRIB Local Tables Version Number +! listsec1(5)=Significance of Reference Time (Code Table 1.1) +! listsec1(6)=Reference Time - Year (4 digits) +! listsec1(7)=Reference Time - Month +! listsec1(8)=Reference Time - Day +! listsec1(9)=Reference Time - Hour +! listsec1(10)=Reference Time - Minute +! listsec1(11)=Reference Time - Second +! listsec1(12)=Production status of data (Code Table 1.2) +! listsec1(13)=Type of processed data (Code Table 1.3) +! numfields- The number of gridded fieldse found in the GRIB message. +! numlocal - The number of Local Use Sections ( Section 2 ) found in +! the GRIB message. +! maxlocal- The size of the largest Local Use Section ( Section 2 ). +! Can be used to ensure that the return array passed +! to subroutine getlocal is dimensioned large enough. +! ierr - Error return code. +! 0 = no error +! 1 = Beginning characters "GRIB" not found. +! 2 = GRIB message is not Edition 2. +! 3 = Could not find Section 1, where expected. +! 4 = End string "7777" found, but not where expected. +! 5 = End string "7777" not found at end of message. +! 6 = Invalid section number found. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(out) :: listsec0(3),listsec1(13) + integer,intent(out) :: numlocal,numfields,maxlocal,ierr + + character(len=4),parameter :: grib='GRIB',c7777='7777' + character(len=4) :: ctemp + integer,parameter :: zero=0,one=1 + integer,parameter :: mapsec1len=13 + integer,parameter :: + & mapsec1(mapsec1len)=(/ 2,2,1,1,1,2,1,1,1,1,1,1,1 /) + integer iofst,ibeg,istart + + ierr=0 + numlocal=0 + numfields=0 + maxlocal=0 +! +! Check for beginning of GRIB message in the first 100 bytes +! + istart=0 + do j=1,100 + ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3) + if (ctemp.eq.grib ) then + istart=j + exit + endif + enddo + if (istart.eq.0) then + print *,'gb_info: Beginning characters GRIB not found.' + ierr=1 + return + endif +! +! Unpack Section 0 - Indicator Section +! + iofst=8*(istart+5) + call gbyte(cgrib,listsec0(1),iofst,8) ! Discipline + iofst=iofst+8 + call gbyte(cgrib,listsec0(2),iofst,8) ! GRIB edition number + iofst=iofst+8 + iofst=iofst+32 + call gbyte(cgrib,lengrib,iofst,32) ! Length of GRIB message + iofst=iofst+32 + listsec0(3)=lengrib + lensec0=16 + ipos=istart+lensec0 +! +! Currently handles only GRIB Edition 2. +! + if (listsec0(2).ne.2) then + print *,'gb_info: can only decode GRIB edition 2.' + ierr=2 + return + endif +! +! Unpack Section 1 - Identification Section +! + call gbyte(cgrib,lensec1,iofst,32) ! Length of Section 1 + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) ! Section number ( 1 ) + iofst=iofst+8 + if (isecnum.ne.1) then + print *,'gb_info: Could not find section 1.' + ierr=3 + return + endif + ! + ! Unpack each input value in array listsec1 into the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mapsec1. + ! + do i=1,mapsec1len + nbits=mapsec1(i)*8 + call gbyte(cgrib,listsec1(i),iofst,nbits) + iofst=iofst+nbits + enddo + ipos=ipos+lensec1 +! +! Loop through the remaining sections to see if they are valid. +! Also count the number of times Section 2 +! and Section 4 appear. +! + do + ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3) + if (ctemp.eq.c7777 ) then + ipos=ipos+4 + if (ipos.ne.(istart+lengrib)) then + print *,'gb_info: "7777" found, but not where expected.' + ierr=4 + return + endif + exit + endif + iofst=(ipos-1)*8 + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) ! Get Section number + iofst=iofst+8 + ipos=ipos+lensec ! Update beginning of section pointer + if (ipos.gt.(istart+lengrib)) then + print *,'gb_info: "7777" not found at end of GRIB message.' + ierr=5 + return + endif + if ( isecnum.ge.2.AND.isecnum.le.7 ) then + if (isecnum.eq.2) then ! Local Section 2 + ! increment counter for total number of local sections found + numlocal=numlocal+1 + lenposs=lensec-5 + if ( lenposs.gt.maxlocal ) maxlocal=lenposs + elseif (isecnum.eq.4) then + ! increment counter for total number of fields found + numfields=numfields+1 + endif + else + print *,'gb_info: Invalid section number found in GRIB', + & ' message: ',isecnum + ierr=6 + return + endif + + enddo + + return + end + diff --git a/WPS/ungrib/src/ngl/g2/gbytesc.f b/WPS/ungrib/src/ngl/g2/gbytesc.f new file mode 100755 index 00000000..b6af4ed6 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gbytesc.f @@ -0,0 +1,125 @@ + SUBROUTINE GBYTE(IN,IOUT,ISKIP,NBYTE) + character*1 in(*) + integer iout(*) + CALL GBYTES(IN,IOUT,ISKIP,NBYTE,0,1) + RETURN + END + + SUBROUTINE SBYTE(OUT,IN,ISKIP,NBYTE) + character*1 out(*) + integer in(*) + CALL SBYTES(OUT,IN,ISKIP,NBYTE,0,1) + RETURN + END + + SUBROUTINE GBYTES(IN,IOUT,ISKIP,NBYTE,NSKIP,N) +C Get bytes - unpack bits: Extract arbitrary size values from a +C packed bit string, right justifying each value in the unpacked +C array. +C IN = character*1 array input +C IOUT = unpacked array output +C ISKIP = initial number of bits to skip +C NBYTE = number of bits to take +C NSKIP = additional number of bits to skip on each iteration +C N = number of iterations +C v1.1 +C + character*1 in(*) + integer iout(*) + integer tbit, bitcnt + integer, parameter :: ones(8) = (/ 1,3,7,15,31,63,127,255 /) + +c nbit is the start position of the field in bits + nbit = iskip + do i = 1, n + bitcnt = nbyte + index=nbit/8+1 + ibit=mod(nbit,8) + nbit = nbit + nbyte + nskip + +c first byte + tbit = min(bitcnt,8-ibit) + itmp = iand(mov_a2i(in(index)),ones(8-ibit)) + if (tbit.ne.8-ibit) itmp = ishft(itmp,tbit-8+ibit) + index = index + 1 + bitcnt = bitcnt - tbit + +c now transfer whole bytes + do while (bitcnt.ge.8) + itmp = ior(ishft(itmp,8),mov_a2i(in(index))) + bitcnt = bitcnt - 8 + index = index + 1 + enddo + +c get data from last byte + if (bitcnt.gt.0) then + itmp = ior(ishft(itmp,bitcnt),iand(ishft(mov_a2i(in(index)), + 1 -(8-bitcnt)),ones(bitcnt))) + endif + + iout(i) = itmp + enddo + + RETURN + END + + SUBROUTINE SBYTES(OUT,IN,ISKIP,NBYTE,NSKIP,N) +C Store bytes - pack bits: Put arbitrary size values into a +C packed bit string, taking the low order bits from each value +C in the unpacked array. +C IOUT = packed array output +C IN = unpacked array input +C ISKIP = initial number of bits to skip +C NBYTE = number of bits to pack +C NSKIP = additional number of bits to skip on each iteration +C N = number of iterations +C v1.1 +C + character*1 out(*) + integer in(N), bitcnt, tbit + integer, parameter :: ones(8)=(/ 1, 3, 7, 15, 31, 63,127,255/) + +c number bits from zero to ... +c nbit is the last bit of the field to be filled + + nbit = iskip + nbyte - 1 + do i = 1, n + itmp = in(i) + bitcnt = nbyte + index=nbit/8+1 + ibit=mod(nbit,8) + nbit = nbit + nbyte + nskip + +c make byte aligned + if (ibit.ne.7) then + tbit = min(bitcnt,ibit+1) + imask = ishft(ones(tbit),7-ibit) + itmp2 = iand(ishft(itmp,7-ibit),imask) + itmp3 = iand(mov_a2i(out(index)), 255-imask) + out(index) = char(ior(itmp2,itmp3)) + bitcnt = bitcnt - tbit + itmp = ishft(itmp, -tbit) + index = index - 1 + endif + +c now byte aligned + +c do by bytes + do while (bitcnt.ge.8) + out(index) = char(iand(itmp,255)) + itmp = ishft(itmp,-8) + bitcnt = bitcnt - 8 + index = index - 1 + enddo + +c do last byte + + if (bitcnt.gt.0) then + itmp2 = iand(itmp,ones(bitcnt)) + itmp3 = iand(mov_a2i(out(index)), 255-ones(bitcnt)) + out(index) = char(ior(itmp2,itmp3)) + endif + enddo + + return + end diff --git a/WPS/ungrib/src/ngl/g2/gdt2gds.f b/WPS/ungrib/src/ngl/g2/gdt2gds.f new file mode 100755 index 00000000..2d50f220 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gdt2gds.f @@ -0,0 +1,389 @@ + subroutine gdt2gds(igds,igdstmpl,idefnum,ideflist,kgds, + & igrid,iret) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: gdt2gds +C PRGMMR: Gilbert ORG: W/NP11 DATE: 2003-06-17 +C +C ABSTRACT: This routine converts grid information from a GRIB2 +C Grid Description Section as well as its +C Grid Definition Template to GRIB1 GDS info. In addition, +C a check is made to determine if the grid is an NCEP +C predefined grid. +C +C PROGRAM HISTORY LOG: +C 2003-06-17 Gilbert +C 2004-04-27 Gilbert - Added support for gaussian grids. +C 2007-04-16 Vuong - Added Curvilinear Orthogonal grids. +C 2007-05-29 Vuong - Added Rotate Lat/Lon E-grid (203) +C +C USAGE: CALL gdt2gds(igds,igdstmpl,idefnum,ideflist,kgds,igrid,iret) +C INPUT ARGUMENT LIST: +C igds() - Contains information read from the appropriate GRIB Grid +C Definition Section 3 for the field being returned. +C Must be dimensioned >= 5. +C igds(1)=Source of grid definition (see Code Table 3.0) +C igds(2)=Number of grid points in the defined grid. +C igds(3)=Number of octets needed for each +C additional grid points definition. +C Used to define number of +C points in each row ( or column ) for +C non-regular grids. +C = 0, if using regular grid. +C igds(4)=Interpretation of list for optional points +C definition. (Code Table 3.11) +C igds(5)=Grid Definition Template Number (Code Table 3.1) +C igdstmpl() - Grid Definition Template values for GDT 3.igds(5) +C idefnum - The number of entries in array ideflist. +C i.e. number of rows ( or columns ) +C for which optional grid points are defined. +C ideflist() - Optional integer array containing +C the number of grid points contained in each row (or column). +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C kgds() - GRIB1 GDS as described in w3fi63 format. +C igrid - NCEP predefined GRIB1 grid number +C set to 255, if not NCEP grid +C iret - Error return value: +C 0 = Successful +C 1 = Unrecognized GRIB2 GDT number 3.igds(5) +C +C REMARKS: LIST CAVEATS, OTHER HELPFUL HINTS OR INFORMATION +C +C ATTRIBUTES: +C LANGUAGE: INDICATE EXTENSIONS, COMPILER OPTIONS +C MACHINE: IBM SP +C +C$$$ +! + integer,intent(in) :: idefnum + integer,intent(in) :: igds(*),igdstmpl(*),ideflist(*) + integer,intent(out) :: kgds(*),igrid,iret + + integer :: kgds72(200),kgds71(200),idum(200),jdum(200) + + iret=0 + if (igds(5).eq.0) then ! Lat/Lon grid + kgds(1)=0 + kgds(2)=igdstmpl(8) ! Ni + kgds(3)=igdstmpl(9) ! Nj + kgds(4)=igdstmpl(12)/1000 ! Lat of 1st grid point + kgds(5)=igdstmpl(13)/1000 ! Long of 1st grid point + kgds(6)=0 ! resolution and component flags + if (igdstmpl(1)==2 ) kgds(6)=64 + if ( btest(igdstmpl(14),4).OR.btest(igdstmpl(14),5) ) + & kgds(6)=kgds(6)+128 + if ( btest(igdstmpl(14),3) ) kgds(6)=kgds(6)+8 + kgds(7)=igdstmpl(15)/1000 ! Lat of last grid point + kgds(8)=igdstmpl(16)/1000 ! Long of last grid point + kgds(9)=igdstmpl(17)/1000 ! Di + kgds(10)=igdstmpl(18)/1000 ! Dj + kgds(11)=igdstmpl(19) ! Scanning mode + kgds(12)=0 + kgds(13)=0 + kgds(14)=0 + kgds(15)=0 + kgds(16)=0 + kgds(17)=0 + kgds(18)=0 + kgds(19)=0 + kgds(20)=255 + kgds(21)=0 + kgds(22)=0 + ! + ! Process irreg grid stuff, if necessary + ! + if ( idefnum.ne.0 ) then + if ( igdstmpl(8).eq.-1 ) then + kgds(2)=65535 + kgds(9)=65535 + endif + if ( igdstmpl(9).eq.-1 ) then + kgds(3)=65535 + kgds(10)=65535 + endif + kgds(19)=0 + kgds(20)=33 + if ( kgds(1).eq.1.OR.kgds(1).eq.3 ) kgds(20)=43 + kgds(21)=igds(2) ! num of grid points + do j=1,idefnum + kgds(21+j)=ideflist(j) + enddo + endif + elseif (igds(5).eq.10) then ! Mercator grid + kgds(1)=1 ! Grid Definition Template number + kgds(2)=igdstmpl(8) ! Ni + kgds(3)=igdstmpl(9) ! Nj + kgds(4)=igdstmpl(10)/1000 ! Lat of 1st grid point + kgds(5)=igdstmpl(11)/1000 ! Long of 1st grid point + kgds(6)=0 ! resolution and component flags + if (igdstmpl(1)==2 ) kgds(6)=64 + if ( btest(igdstmpl(12),4).OR.btest(igdstmpl(12),5) ) + & kgds(6)=kgds(6)+128 + if ( btest(igdstmpl(12),3) ) kgds(6)=kgds(6)+8 + kgds(7)=igdstmpl(14)/1000 ! Lat of last grid point + kgds(8)=igdstmpl(15)/1000 ! Long of last grid point + kgds(9)=igdstmpl(13)/1000 ! Lat intersects earth + kgds(10)=0 + kgds(11)=igdstmpl(16) ! Scanning mode + kgds(12)=igdstmpl(18)/1000 ! Di + kgds(13)=igdstmpl(19)/1000 ! Dj + kgds(14)=0 + kgds(15)=0 + kgds(16)=0 + kgds(17)=0 + kgds(18)=0 + kgds(19)=0 + kgds(20)=255 + kgds(21)=0 + kgds(22)=0 + elseif (igds(5).eq.30) then ! Lambert Conformal Grid + kgds(1)=3 + kgds(2)=igdstmpl(8) ! Nx + kgds(3)=igdstmpl(9) ! Ny + kgds(4)=igdstmpl(10)/1000 ! Lat of 1st grid point + kgds(5)=igdstmpl(11)/1000 ! Long of 1st grid point + kgds(6)=0 ! resolution and component flags + if (igdstmpl(1)==2 ) kgds(6)=64 + if ( btest(igdstmpl(12),4).OR.btest(igdstmpl(12),5) ) + & kgds(6)=kgds(6)+128 + if ( btest(igdstmpl(12),3) ) kgds(6)=kgds(6)+8 + kgds(7)=igdstmpl(14)/1000 ! Lon of orientation + kgds(8)=igdstmpl(15)/1000 ! Dx + kgds(9)=igdstmpl(16)/1000 ! Dy + kgds(10)=igdstmpl(17) ! Projection Center Flag + kgds(11)=igdstmpl(18) ! Scanning mode + kgds(12)=igdstmpl(19)/1000 ! Lat in 1 + kgds(13)=igdstmpl(20)/1000 ! Lat in 2 + kgds(14)=igdstmpl(21)/1000 ! Lat of S. Pole of projection + kgds(15)=igdstmpl(22)/1000 ! Lon of S. Pole of projection + kgds(16)=0 + kgds(17)=0 + kgds(18)=0 + kgds(19)=0 + kgds(20)=255 + kgds(21)=0 + kgds(22)=0 + elseif (igds(5).eq.40) then ! Gaussian Lat/Lon grid + kgds(1)=4 + kgds(2)=igdstmpl(8) ! Ni + kgds(3)=igdstmpl(9) ! Nj + kgds(4)=igdstmpl(12)/1000 ! Lat of 1st grid point + kgds(5)=igdstmpl(13)/1000 ! Long of 1st grid point + kgds(6)=0 ! resolution and component flags + if (igdstmpl(1)==2 ) kgds(6)=64 + if ( btest(igdstmpl(14),4).OR.btest(igdstmpl(14),5) ) + & kgds(6)=kgds(6)+128 + if ( btest(igdstmpl(14),3) ) kgds(6)=kgds(6)+8 + kgds(7)=igdstmpl(15)/1000 ! Lat of last grid point + kgds(8)=igdstmpl(16)/1000 ! Long of last grid point + kgds(9)=igdstmpl(17)/1000 ! Di + kgds(10)=igdstmpl(18) ! N - Number of parallels + kgds(11)=igdstmpl(19) ! Scanning mode + kgds(12)=0 + kgds(13)=0 + kgds(14)=0 + kgds(15)=0 + kgds(16)=0 + kgds(17)=0 + kgds(18)=0 + kgds(19)=0 + kgds(20)=255 + kgds(21)=0 + kgds(22)=0 + elseif (igds(5).eq.20) then ! Polar Stereographic Grid + kgds(1)=5 + kgds(2)=igdstmpl(8) ! Nx + kgds(3)=igdstmpl(9) ! Ny + kgds(4)=igdstmpl(10)/1000 ! Lat of 1st grid point + kgds(5)=igdstmpl(11)/1000 ! Long of 1st grid point + kgds(6)=0 ! resolution and component flags + if (igdstmpl(1)==2 ) kgds(6)=64 + if ( btest(igdstmpl(12),4).OR.btest(igdstmpl(12),5) ) + & kgds(6)=kgds(6)+128 + if ( btest(igdstmpl(12),3) ) kgds(6)=kgds(6)+8 + kgds(7)=igdstmpl(14)/1000 ! Lon of orientation + kgds(8)=igdstmpl(15)/1000 ! Dx + kgds(9)=igdstmpl(16)/1000 ! Dy + kgds(10)=igdstmpl(17) ! Projection Center Flag + kgds(11)=igdstmpl(18) ! Scanning mode + kgds(12)=0 + kgds(13)=0 + kgds(14)=0 + kgds(15)=0 + kgds(16)=0 + kgds(17)=0 + kgds(18)=0 + kgds(19)=0 + kgds(20)=255 + kgds(21)=0 + kgds(22)=0 + elseif (igds(5).eq.204) then ! Curvilinear Orthogonal + kgds(1)=204 + kgds(2)=igdstmpl(8) ! Ni + kgds(3)=igdstmpl(9) ! Nj + kgds(4)=0 + kgds(5)=0 + kgds(6)=0 ! resolution and component flags + if (igdstmpl(1)==2 ) kgds(6)=64 + if ( btest(igdstmpl(14),4).OR.btest(igdstmpl(14),5) ) + & kgds(6)=kgds(6)+128 + if ( btest(igdstmpl(14),3) ) kgds(6)=kgds(6)+8 + kgds(7)=0 + kgds(8)=0 + kgds(9)=0 + kgds(10)=0 + kgds(11)=igdstmpl(19) ! Scanning mode + kgds(12)=0 + kgds(13)=0 + kgds(14)=0 + kgds(15)=0 + kgds(16)=0 + kgds(17)=0 + kgds(18)=0 + kgds(19)=0 + kgds(20)=255 + kgds(21)=0 + kgds(22)=0 + ! + ! Process irreg grid stuff, if necessary + ! + if ( idefnum.ne.0 ) then + if ( igdstmpl(8).eq.-1 ) then + kgds(2)=65535 + kgds(9)=65535 + endif + if ( igdstmpl(9).eq.-1 ) then + kgds(3)=65535 + kgds(10)=65535 + endif + kgds(19)=0 + kgds(20)=33 + if ( kgds(1).eq.1.OR.kgds(1).eq.3 ) kgds(20)=43 + kgds(21)=igds(2) ! num of grid points + do j=1,idefnum + kgds(21+j)=ideflist(j) + enddo + endif + elseif (igds(5).eq.32768) then ! Rotate Lat/Lon grid + kgds(1)=203 ! Arakawa Staggerred E/B grid + kgds(2)=igdstmpl(8) ! Ni + kgds(3)=igdstmpl(9) ! Nj + kgds(4)=igdstmpl(12)/1000 ! Lat of 1st grid point + kgds(5)=igdstmpl(13)/1000 ! Lon of 1st grid point + kgds(6)=0 ! resolution and component flags + if (igdstmpl(1)==2 ) kgds(6)=64 + if ( btest(igdstmpl(14),4).OR.btest(igdstmpl(14),5) ) + & kgds(6)=kgds(6)+128 + if ( btest(igdstmpl(14),3) ) kgds(6)=kgds(6)+8 + kgds(7)=igdstmpl(15)/1000 ! Lat of last grid point + kgds(8)=igdstmpl(16)/1000 ! Lon of last grid point + kgds(9)=igdstmpl(17)/1000 ! Di + kgds(10)=igdstmpl(18)/1000 ! Dj + kgds(11)=igdstmpl(19) ! Scanning mode + kgds(12)=0 + kgds(13)=0 + kgds(14)=0 + kgds(15)=0 + kgds(16)=0 + kgds(17)=0 + kgds(18)=0 + kgds(19)=0 + kgds(20)=255 + kgds(21)=0 + kgds(22)=0 + ! + ! Process irreg grid stuff, if necessary + ! + if ( idefnum.ne.0 ) then + if ( igdstmpl(8).eq.-1 ) then + kgds(2)=65535 + kgds(9)=65535 + endif + if ( igdstmpl(9).eq.-1 ) then + kgds(3)=65535 + kgds(10)=65535 + endif + kgds(19)=0 + kgds(20)=33 + if ( kgds(1).eq.1.OR.kgds(1).eq.3 ) kgds(20)=43 + kgds(21)=igds(2) ! num of grid points + do j=1,idefnum + kgds(21+j)=ideflist(j) + enddo + endif + elseif (igds(5).eq.32769) then ! Rotate Lat/Lon grid + kgds(1)=205 ! Arakawa Staggerred for Non-E Stagger grid + kgds(2)=igdstmpl(8) ! Ni + kgds(3)=igdstmpl(9) ! Nj + kgds(4)=igdstmpl(12)/1000 ! Lat of 1st grid point + kgds(5)=igdstmpl(13)/1000 ! Lon of 1st grid point + kgds(6)=0 ! resolution and component flags + if (igdstmpl(1)==2 ) kgds(6)=64 + if ( btest(igdstmpl(14),4).OR.btest(igdstmpl(14),5) ) + & kgds(6)=kgds(6)+128 + if ( btest(igdstmpl(14),3) ) kgds(6)=kgds(6)+8 + kgds(7)=igdstmpl(15)/1000 ! Lat of last grid point + kgds(8)=igdstmpl(16)/1000 ! Lon of last grid point + kgds(9)=igdstmpl(17)/1000 ! Di + kgds(10)=igdstmpl(18)/1000 ! Dj + kgds(11)=igdstmpl(19) ! Scanning mode + kgds(12)=igdstmpl(20)/1000 + kgds(13)=igdstmpl(21)/1000 + kgds(14)=0 + kgds(15)=0 + kgds(16)=0 + kgds(17)=0 + kgds(18)=0 + kgds(19)=0 + kgds(20)=255 + kgds(21)=0 + kgds(22)=0 + else + Print *,'gdt2gds: Unrecognized GRIB2 GDT = 3.',igds(5) + iret=1 + kgds(1:22)=0 + return + endif +! +! Can we determine NCEP grid number ? +! + igrid=255 + do j=254,1,-1 + !do j=225,225 + kgds71=0 + kgds72=0 + call w3fi71(j,kgds71,ierr) + if ( ierr.ne.0 ) cycle + ! convert W to E for longitudes + if ( kgds71(3).eq.0 ) then ! lat/lon + if ( kgds71(7).lt.0 ) kgds71(7)=360000+kgds71(7) + if ( kgds71(10).lt.0 ) kgds71(10)=360000+kgds71(10) + elseif ( kgds71(3).eq.1 ) then ! mercator + if ( kgds71(7).lt.0 ) kgds71(7)=360000+kgds71(7) + if ( kgds71(10).lt.0 ) kgds71(10)=360000+kgds71(10) + elseif ( kgds71(3).eq.3 ) then ! lambert conformal + if ( kgds71(7).lt.0 ) kgds71(7)=360000+kgds71(7) + if ( kgds71(9).lt.0 ) kgds71(9)=360000+kgds71(9) + if ( kgds71(18).lt.0 ) kgds71(18)=360000+kgds71(18) + elseif ( kgds71(3).eq.4 ) then ! Guassian lat/lon + if ( kgds71(7).lt.0 ) kgds71(7)=360000+kgds71(7) + if ( kgds71(10).lt.0 ) kgds71(10)=360000+kgds71(10) + elseif ( kgds71(3).eq.5 ) then ! polar stereographic + if ( kgds71(7).lt.0 ) kgds71(7)=360000+kgds71(7) + if ( kgds71(9).lt.0 ) kgds71(9)=360000+kgds71(9) + endif + call r63w72(idum,kgds,jdum,kgds72) + if ( kgds72(3).eq.3 ) kgds72(14)=0 ! lambert conformal fix + if ( kgds72(3).eq.1 ) kgds72(15:18)=0 ! mercator fix + if ( kgds72(3).eq.5 ) kgds72(14:18)=0 ! polar str fix +c print *,' kgds71(',j,')= ', kgds71(1:30) +c print *,' kgds72 = ', kgds72(1:30) + if ( all(kgds71.eq.kgds72) ) then + igrid=j + return + endif + enddo + + return + end diff --git a/WPS/ungrib/src/ngl/g2/getdim.f b/WPS/ungrib/src/ngl/g2/getdim.f new file mode 100755 index 00000000..2e66068a --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getdim.f @@ -0,0 +1,102 @@ + subroutine getdim(csec3,lcsec3,width,height,iscan) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getdim +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-12-11 +! +! ABSTRACT: This subroutine returns the dimensions and scanning mode of +! a grid definition packed in GRIB2 Grid Definition Section 3 format. +! +! PROGRAM HISTORY LOG: +! 2002-12-11 Gilbert +! +! USAGE: CALL getdim(csec3,lcsec3,width,height,iscan) +! INPUT ARGUMENT LIST: +! csec3 - Character array that contains the packed GRIB2 GDS +! lcsec3 - Length (in octets) of section 3 +! +! OUTPUT ARGUMENT LIST: +! width - x (or i) dimension of the grid. +! height - y (or j) dimension of the grid. +! iscan - Scanning mode ( see Code Table 3.4 ) +! +! REMARKS: Returns width and height set to zero, if grid template +! not recognized. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ +! use grib_mod + + character(len=1),intent(in) :: csec3(*) + integer,intent(in) :: lcsec3 + integer,intent(out) :: width,height,iscan + + integer,pointer,dimension(:) :: igdstmpl,list_opt + integer :: igds(5) + integer iofst,igdtlen,num_opt,jerr + + interface + subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl, + & mapgridlen,ideflist,idefnum,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,pointer,dimension(:) :: igdstmpl,ideflist + integer,intent(out) :: igds(5) + integer,intent(out) :: ierr,idefnum + end subroutine gf_unpack3 + end interface + + nullify(igdstmpl,list_opt) + ! + iofst=0 ! set offset to beginning of section + call gf_unpack3(csec3,lcsec3,iofst,igds,igdstmpl, + & igdtlen,list_opt,num_opt,jerr) + if (jerr.eq.0) then + selectcase( igds(5) ) ! Template number + case (0:3) ! Lat/Lon + width=igdstmpl(8) + height=igdstmpl(9) + iscan=igdstmpl(19) + case (10) ! Mercator + width=igdstmpl(8) + height=igdstmpl(9) + iscan=igdstmpl(16) + case (20) ! Polar Stereographic + width=igdstmpl(8) + height=igdstmpl(9) + iscan=igdstmpl(18) + case (30) ! Lambert Conformal + width=igdstmpl(8) + height=igdstmpl(9) + iscan=igdstmpl(18) + case (40:43) ! Gaussian + width=igdstmpl(8) + height=igdstmpl(9) + iscan=igdstmpl(19) + case (90) ! Space View/Orthographic + width=igdstmpl(8) + height=igdstmpl(9) + iscan=igdstmpl(17) + case (110) ! Equatorial Azimuthal + width=igdstmpl(8) + height=igdstmpl(9) + iscan=igdstmpl(16) + case default + width=0 + height=0 + iscan=0 + end select + else + width=0 + height=0 + endif + ! + if (associated(igdstmpl)) deallocate(igdstmpl) + if (associated(list_opt)) deallocate(list_opt) + + return + end diff --git a/WPS/ungrib/src/ngl/g2/getfield.f b/WPS/ungrib/src/ngl/g2/getfield.f new file mode 100755 index 00000000..d22b1e5d --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getfield.f @@ -0,0 +1,829 @@ + subroutine getfield(cgrib,lcgrib,ifldnum,igds,igdstmpl,igdslen, + & ideflist,idefnum,ipdsnum,ipdstmpl,ipdslen, + & coordlist,numcoord,ndpts,idrsnum,idrstmpl, + & idrslen,ibmap,bmap,fld,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getfield +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine returns the Grid Definition, Product Definition, +! Bit-map ( if applicable ), and the unpacked data for a given data +! field. Since there can be multiple data fields packed into a GRIB2 +! message, the calling routine indicates which field is being requested +! with the ifldnum argument. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! +! USAGE: CALL getfield(cgrib,lcgrib,ifldnum,igds,igdstmpl,igdslen, +! & ideflist,idefnum,ipdsnum,ipdstmpl,ipdslen, +! & coordlist,numcoord,ndpts,idrsnum,idrstmpl, +! & idrslen,ibmap,bmap,fld,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! ifldnum - Specifies which field in the GRIB2 message to return. +! +! OUTPUT ARGUMENT LIST: +! igds - Contains information read from the appropriate GRIB Grid +! Definition Section 3 for the field being returned. +! Must be dimensioned >= 5. +! igds(1)=Source of grid definition (see Code Table 3.0) +! igds(2)=Number of grid points in the defined grid. +! igds(3)=Number of octets needed for each +! additional grid points definition. +! Used to define number of +! points in each row ( or column ) for +! non-regular grids. +! = 0, if using regular grid. +! igds(4)=Interpretation of list for optional points +! definition. (Code Table 3.11) +! igds(5)=Grid Definition Template Number (Code Table 3.1) +! igdstmpl - Contains the data values for the specified Grid Definition +! Template ( NN=igds(5) ). Each element of this integer +! array contains an entry (in the order specified) of Grid +! Defintion Template 3.NN +! A safe dimension for this array can be obtained in advance +! from maxvals(2), which is returned from subroutine gribinfo. +! igdslen - Number of elements in igdstmpl(). i.e. number of entries +! in Grid Defintion Template 3.NN ( NN=igds(5) ). +! ideflist - (Used if igds(3) .ne. 0) This array contains the +! number of grid points contained in each row ( or column ). +! (part of Section 3) +! A safe dimension for this array can be obtained in advance +! from maxvals(3), which is returned from subroutine gribinfo. +! idefnum - (Used if igds(3) .ne. 0) The number of entries +! in array ideflist. i.e. number of rows ( or columns ) +! for which optional grid points are defined. +! ipdsnum - Product Definition Template Number ( see Code Table 4.0) +! ipdstmpl - Contains the data values for the specified Product Definition +! Template ( N=ipdsnum ). Each element of this integer +! array contains an entry (in the order specified) of Product +! Defintion Template 4.N +! A safe dimension for this array can be obtained in advance +! from maxvals(4), which is returned from subroutine gribinfo. +! ipdslen - Number of elements in ipdstmpl(). i.e. number of entries +! in Product Defintion Template 4.N ( N=ipdsnum ). +! coordlist- Array containg floating point values intended to document +! the vertical discretisation associated to model data +! on hybrid coordinate vertical levels. (part of Section 4) +! The dimension of this array can be obtained in advance +! from maxvals(5), which is returned from subroutine gribinfo. +! numcoord - number of values in array coordlist. +! ndpts - Number of data points unpacked and returned. +! idrsnum - Data Representation Template Number ( see Code Table 5.0) +! idrstmpl - Contains the data values for the specified Data Representation +! Template ( N=idrsnum ). Each element of this integer +! array contains an entry (in the order specified) of Product +! Defintion Template 5.N +! A safe dimension for this array can be obtained in advance +! from maxvals(6), which is returned from subroutine gribinfo. +! idrslen - Number of elements in idrstmpl(). i.e. number of entries +! in Data Representation Template 5.N ( N=idrsnum ). +! ibmap - Bitmap indicator ( see Code Table 6.0 ) +! 0 = bitmap applies and is included in Section 6. +! 1-253 = Predefined bitmap applies +! 254 = Previously defined bitmap applies to this field +! 255 = Bit map does not apply to this product. +! bmap() - Logical*1 array containing decoded bitmap. ( if ibmap=0 ) +! The dimension of this array can be obtained in advance +! from maxvals(7), which is returned from subroutine gribinfo. +! fld() - Array of ndpts unpacked data points. +! A safe dimension for this array can be obtained in advance +! from maxvals(7), which is returned from subroutine gribinfo. +! ierr - Error return code. +! 0 = no error +! 1 = Beginning characters "GRIB" not found. +! 2 = GRIB message is not Edition 2. +! 3 = The data field request number was not positive. +! 4 = End string "7777" found, but not where expected. +! 6 = GRIB message did not contain the requested number of +! data fields. +! 7 = End string "7777" not found at end of message. +! 9 = Data Representation Template 5.NN not yet implemented. +! 10 = Error unpacking Section 3. +! 11 = Error unpacking Section 4. +! 12 = Error unpacking Section 5. +! 13 = Error unpacking Section 6. +! 14 = Error unpacking Section 7. +! +! REMARKS: Note that subroutine gribinfo can be used to first determine +! how many data fields exist in a given GRIB message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib,ifldnum + integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*) + integer,intent(out) :: ipdsnum,ipdstmpl(*) + integer,intent(out) :: idrsnum,idrstmpl(*) + integer,intent(out) :: ndpts,ibmap,idefnum,numcoord + integer,intent(out) :: ierr + logical*1,intent(out) :: bmap(*) + real,intent(out) :: fld(*),coordlist(*) + + character(len=4),parameter :: grib='GRIB',c7777='7777' + character(len=4) :: ctemp + integer:: listsec0(2) + integer iofst,ibeg,istart + integer(4) :: ieee + logical have3,have4,have5,have6,have7 + + have3=.false. + have4=.false. + have5=.false. + have6=.false. + have7=.false. + ierr=0 + numfld=0 +! +! Check for valid request number +! + if (ifldnum.le.0) then + print *,'getfield: Request for field number must be positive.' + ierr=3 + return + endif +! +! Check for beginning of GRIB message in the first 100 bytes +! + istart=0 + do j=1,100 + ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3) + if (ctemp.eq.grib ) then + istart=j + exit + endif + enddo + if (istart.eq.0) then + print *,'getfield: Beginning characters GRIB not found.' + ierr=1 + return + endif +! +! Unpack Section 0 - Indicator Section +! + iofst=8*(istart+5) + call gbyte(cgrib,listsec0(1),iofst,8) ! Discipline + iofst=iofst+8 + call gbyte(cgrib,listsec0(2),iofst,8) ! GRIB edition number + iofst=iofst+8 + iofst=iofst+32 + call gbyte(cgrib,lengrib,iofst,32) ! Length of GRIB message + iofst=iofst+32 + lensec0=16 + ipos=istart+lensec0 +! +! Currently handles only GRIB Edition 2. +! + if (listsec0(2).ne.2) then + print *,'getfield: can only decode GRIB edition 2.' + ierr=2 + return + endif +! +! Loop through the remaining sections keeping track of the +! length of each. Also keep the latest Grid Definition Section info. +! Unpack the requested field number. +! + do + ! Check to see if we are at end of GRIB message + ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3) + if (ctemp.eq.c7777 ) then + ipos=ipos+4 + ! If end of GRIB message not where expected, issue error + if (ipos.ne.(istart+lengrib)) then + print *,'getfield: "7777" found, but not where expected.' + ierr=4 + return + endif + exit + endif + ! Get length of Section and Section number + iofst=(ipos-1)*8 + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) ! Get Section number + iofst=iofst+8 + !print *,' lensec= ',lensec,' secnum= ',isecnum + ! + ! If found Section 3, unpack the GDS info using the + ! appropriate template. Save in case this is the latest + ! grid before the requested field. + ! + if (isecnum.eq.3) then + iofst=iofst-40 ! reset offset to beginning of section + call unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,igdslen, + & ideflist,idefnum,jerr) + if (jerr.eq.0) then + have3=.true. + else + ierr=10 + return + endif + endif + ! + ! If found Section 4, check to see if this field is the + ! one requested. + ! + if (isecnum.eq.4) then + numfld=numfld+1 + if (numfld.eq.ifldnum) then + iofst=iofst-40 ! reset offset to beginning of section + call unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,ipdslen, + & coordlist,numcoord,jerr) + if (jerr.eq.0) then + have4=.true. + else + ierr=11 + return + endif + endif + endif + ! + ! If found Section 5, check to see if this field is the + ! one requested. + ! + if ((isecnum.eq.5).and.(numfld.eq.ifldnum)) then + iofst=iofst-40 ! reset offset to beginning of section + call unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl, + & idrslen,jerr) + if (jerr.eq.0) then + have5=.true. + else + ierr=12 + return + endif + endif + ! + ! If found Section 6, Unpack bitmap. + ! Save in case this is the latest + ! bitmap before the requested field. + ! + if (isecnum.eq.6) then + iofst=iofst-40 ! reset offset to beginning of section + call unpack6(cgrib,lcgrib,iofst,igds(2),ibmap,bmap,jerr) + if (jerr.eq.0) then + have6=.true. + else + ierr=13 + return + endif + endif + ! + ! If found Section 7, check to see if this field is the + ! one requested. + ! + if ((isecnum.eq.7).and.(numfld.eq.ifldnum)) then + if (idrsnum.eq.0) then + call simunpack(cgrib(ipos+5),lensec-6,idrstmpl,ndpts,fld) + have7=.true. + elseif (idrsnum.eq.2.or.idrsnum.eq.3) then + call comunpack(cgrib(ipos+5),lensec-6,lensec,idrsnum, + & idrstmpl,ndpts,fld,ier) + if ( ier .ne. 0 ) then + ierr=14 + return + endif + have7=.true. + elseif (idrsnum.eq.50) then + call simunpack(cgrib(ipos+5),lensec-6,idrstmpl,ndpts-1, + & fld(2)) + ieee=idrstmpl(5) + call rdieee(ieee,fld(1),1) + have7=.true. + elseif (idrsnum.eq.40 .OR. idrsnum.eq.40000) then + call jpcunpack(cgrib(ipos+5),lensec-5,idrstmpl,ndpts,fld) + have7=.true. + elseif (idrsnum.eq.41 .OR. idrsnum.eq.40010) then + call pngunpack(cgrib(ipos+5),lensec-5,idrstmpl,ndpts,fld) + have7=.true. + else + print *,'getfield: Data Representation Template ',idrsnum, + & ' not yet implemented.' + ierr=9 + return + endif + endif + ! + ! Check to see if we read pass the end of the GRIB + ! message and missed the terminator string '7777'. + ! + ipos=ipos+lensec ! Update beginning of section pointer + if (ipos.gt.(istart+lengrib)) then + print *,'getfield: "7777" not found at end of GRIB message.' + ierr=7 + return + endif + + if (have3.and.have4.and.have5.and.have6.and.have7) return + + enddo + +! +! If exited from above loop, the end of the GRIB message was reached +! before the requested field was found. +! + print *,'getfield: GRIB message contained ',numlocal, + & ' different fields.' + print *,'getfield: The request was for the ',ifldnum, + & ' field.' + ierr=6 + + return + end + + + subroutine unpack3(cgrib,lcgrib,iofst,igds,igdstmpl, + & mapgridlen,ideflist,idefnum,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: unpack3 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine unpacks Section 3 (Grid Definition Section) +! starting at octet 6 of that Section. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! +! USAGE: CALL unpack3(cgrib,lcgrib,lensec,iofst,igds,igdstmpl, +! & mapgridlen,ideflist,idefnum,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! iofst - Bit offset of the beginning of Section 3. +! +! OUTPUT ARGUMENT LIST: +! iofst - Bit offset at the end of Section 3, returned. +! igds - Contains information read from the appropriate GRIB Grid +! Definition Section 3 for the field being returned. +! Must be dimensioned >= 5. +! igds(1)=Source of grid definition (see Code Table 3.0) +! igds(2)=Number of grid points in the defined grid. +! igds(3)=Number of octets needed for each +! additional grid points definition. +! Used to define number of +! points in each row ( or column ) for +! non-regular grids. +! = 0, if using regular grid. +! igds(4)=Interpretation of list for optional points +! definition. (Code Table 3.11) +! igds(5)=Grid Definition Template Number (Code Table 3.1) +! igdstmpl - Contains the data values for the specified Grid Definition +! Template ( NN=igds(5) ). Each element of this integer +! array contains an entry (in the order specified) of Grid +! Defintion Template 3.NN +! mapgridlen- Number of elements in igdstmpl(). i.e. number of entries +! in Grid Defintion Template 3.NN ( NN=igds(5) ). +! ideflist - (Used if igds(3) .ne. 0) This array contains the +! number of grid points contained in each row ( or column ). +! (part of Section 3) +! idefnum - (Used if igds(3) .ne. 0) The number of entries +! in array ideflist. i.e. number of rows ( or columns ) +! for which optional grid points are defined. +! ierr - Error return code. +! 0 = no error +! 5 = "GRIB" message contains an undefined Grid Definition +! Template. +! +! REMARKS: Uses Fortran 90 module gridtemplates. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + use gridtemplates + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*) + integer,intent(out) :: ierr,idefnum + + integer,allocatable :: mapgrid(:) + integer :: mapgridlen,ibyttem + logical needext + + ierr=0 + + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + iofst=iofst+8 ! skip section number + + call gbyte(cgrib,igds(1),iofst,8) ! Get source of Grid def. + iofst=iofst+8 + call gbyte(cgrib,igds(2),iofst,32) ! Get number of grid pts. + iofst=iofst+32 + call gbyte(cgrib,igds(3),iofst,8) ! Get num octets for opt. list + iofst=iofst+8 + call gbyte(cgrib,igds(4),iofst,8) ! Get interpret. for opt. list + iofst=iofst+8 + call gbyte(cgrib,igds(5),iofst,16) ! Get Grid Def Template num. + iofst=iofst+16 + if (igds(1).eq.0) then +! if (igds(1).eq.0.OR.igds(1).eq.255) then ! FOR ECMWF TEST ONLY + allocate(mapgrid(lensec)) + ! Get Grid Definition Template + call getgridtemplate(igds(5),mapgridlen,mapgrid,needext, + & iret) + if (iret.ne.0) then + ierr=5 + return + endif + else +! igdstmpl=-1 + mapgridlen=0 + needext=.false. + endif + ! + ! Unpack each value into array igdstmpl from the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mapgrid. + ! + ibyttem=0 + do i=1,mapgridlen + nbits=iabs(mapgrid(i))*8 + if ( mapgrid(i).ge.0 ) then + call gbyte(cgrib,igdstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,igdstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) igdstmpl(i)=-igdstmpl(i) + endif + iofst=iofst+nbits + ibyttem=ibyttem+iabs(mapgrid(i)) + enddo + ! + ! Check to see if the Grid Definition Template needs to be + ! extended. + ! The number of values in a specific template may vary + ! depending on data specified in the "static" part of the + ! template. + ! + if ( needext ) then + call extgridtemplate(igds(5),igdstmpl,newmapgridlen,mapgrid) + ! Unpack the rest of the Grid Definition Template + do i=mapgridlen+1,newmapgridlen + nbits=iabs(mapgrid(i))*8 + if ( mapgrid(i).ge.0 ) then + call gbyte(cgrib,igdstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,igdstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) igdstmpl(i)=-igdstmpl(i) + endif + iofst=iofst+nbits + ibyttem=ibyttem+iabs(mapgrid(i)) + enddo + mapgridlen=newmapgridlen + endif + ! + ! Unpack optional list of numbers defining number of points + ! in each row or column, if included. This is used for non regular + ! grids. + ! + if ( igds(3).ne.0 ) then + nbits=igds(3)*8 + idefnum=(lensec-14-ibyttem)/igds(3) + call gbytes(cgrib,ideflist,iofst,nbits,0,idefnum) + iofst=iofst+(nbits*idefnum) + else + idefnum=0 + endif + if( allocated(mapgrid) ) deallocate(mapgrid) + return ! End of Section 3 processing + end + + + subroutine unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,mappdslen, + & coordlist,numcoord,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: unpack4 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine unpacks Section 4 (Product Definition Section) +! starting at octet 6 of that Section. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! +! USAGE: CALL unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,mappdslen, +! & coordlist,numcoord,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! iofst - Bit offset of the beginning of Section 4. +! +! OUTPUT ARGUMENT LIST: +! iofst - Bit offset of the end of Section 4, returned. +! ipdsnum - Product Definition Template Number ( see Code Table 4.0) +! ipdstmpl - Contains the data values for the specified Product Definition +! Template ( N=ipdsnum ). Each element of this integer +! array contains an entry (in the order specified) of Product +! Defintion Template 4.N +! mappdslen- Number of elements in ipdstmpl(). i.e. number of entries +! in Product Defintion Template 4.N ( N=ipdsnum ). +! coordlist- Array containg floating point values intended to document +! the vertical discretisation associated to model data +! on hybrid coordinate vertical levels. (part of Section 4) +! numcoord - number of values in array coordlist. +! ierr - Error return code. +! 0 = no error +! 5 = "GRIB" message contains an undefined Product Definition +! Template. +! +! REMARKS: Uses Fortran 90 module pdstemplates. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + use pdstemplates + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + real,intent(out) :: coordlist(*) + integer,intent(out) :: ipdsnum,ipdstmpl(*) + integer,intent(out) :: ierr,numcoord + + real(4),allocatable :: coordieee(:) + integer,allocatable :: mappds(:) + integer :: mappdslen + logical needext + + ierr=0 + + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + iofst=iofst+8 ! skip section number + allocate(mappds(lensec)) + + call gbyte(cgrib,numcoord,iofst,16) ! Get num of coordinate values + iofst=iofst+16 + call gbyte(cgrib,ipdsnum,iofst,16) ! Get Prod. Def Template num. + iofst=iofst+16 + ! Get Product Definition Template + call getpdstemplate(ipdsnum,mappdslen,mappds,needext,iret) + if (iret.ne.0) then + ierr=5 + return + endif + ! + ! Unpack each value into array ipdstmpl from the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mappds. + ! + do i=1,mappdslen + nbits=iabs(mappds(i))*8 + if ( mappds(i).ge.0 ) then + call gbyte(cgrib,ipdstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,ipdstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) ipdstmpl(i)=-ipdstmpl(i) + endif + iofst=iofst+nbits + enddo + ! + ! Check to see if the Product Definition Template needs to be + ! extended. + ! The number of values in a specific template may vary + ! depending on data specified in the "static" part of the + ! template. + ! + if ( needext ) then + call extpdstemplate(ipdsnum,ipdstmpl,newmappdslen,mappds) + ! Unpack the rest of the Product Definition Template + do i=mappdslen+1,newmappdslen + nbits=iabs(mappds(i))*8 + if ( mappds(i).ge.0 ) then + call gbyte(cgrib,ipdstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,ipdstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) ipdstmpl(i)=-ipdstmpl(i) + endif + iofst=iofst+nbits + enddo + mappdslen=newmappdslen + endif + ! + ! Get Optional list of vertical coordinate values + ! after the Product Definition Template, if necessary. + ! + if ( numcoord .ne. 0 ) then + allocate (coordieee(numcoord)) + call gbytes(cgrib,coordieee,iofst,32,0,numcoord) + call rdieee(coordieee,coordlist,numcoord) + deallocate (coordieee) + iofst=iofst+(32*numcoord) + endif + if( allocated(mappds) ) deallocate(mappds) + return ! End of Section 4 processing + end + + + subroutine unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl, + & mapdrslen,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: unpack5 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine unpacks Section 5 (Data Representation Section) +! starting at octet 6 of that Section. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! +! USAGE: CALL unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl, +! mapdrslen,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! iofst - Bit offset of the beginning of Section 5. +! +! OUTPUT ARGUMENT LIST: +! iofst - Bit offset at the end of Section 5, returned. +! ndpts - Number of data points unpacked and returned. +! idrsnum - Data Representation Template Number ( see Code Table 5.0) +! idrstmpl - Contains the data values for the specified Data Representation +! Template ( N=idrsnum ). Each element of this integer +! array contains an entry (in the order specified) of Data +! Representation Template 5.N +! mapdrslen- Number of elements in idrstmpl(). i.e. number of entries +! in Data Representation Template 5.N ( N=idrsnum ). +! ierr - Error return code. +! 0 = no error +! 7 = "GRIB" message contains an undefined Data +! Representation Template. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + use drstemplates + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,intent(out) :: ndpts,idrsnum,idrstmpl(*) + integer,intent(out) :: ierr + +C integer,allocatable :: mapdrs(:) + integer,allocatable :: mapdrs(:) + integer :: mapdrslen + logical needext + + ierr=0 + + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + iofst=iofst+8 ! skip section number + allocate(mapdrs(lensec)) + + call gbyte(cgrib,ndpts,iofst,32) ! Get num of data points + iofst=iofst+32 + call gbyte(cgrib,idrsnum,iofst,16) ! Get Data Rep Template Num. + iofst=iofst+16 + ! Gen Data Representation Template + call getdrstemplate(idrsnum,mapdrslen,mapdrs,needext,iret) + if (iret.ne.0) then + ierr=7 + return + endif + ! + ! Unpack each value into array ipdstmpl from the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mappds. + ! + do i=1,mapdrslen + nbits=iabs(mapdrs(i))*8 + if ( mapdrs(i).ge.0 ) then + call gbyte(cgrib,idrstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,idrstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) idrstmpl(i)=-idrstmpl(i) + endif + iofst=iofst+nbits + enddo + ! + ! Check to see if the Data Representation Template needs to be + ! extended. + ! The number of values in a specific template may vary + ! depending on data specified in the "static" part of the + ! template. + ! + if ( needext ) then + call extdrstemplate(idrsnum,idrstmpl,newmapdrslen,mapdrs) + ! Unpack the rest of the Data Representation Template + do i=mapdrslen+1,newmapdrslen + nbits=iabs(mapdrs(i))*8 + if ( mapdrs(i).ge.0 ) then + call gbyte(cgrib,idrstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,idrstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) idrstmpl(i)=-idrstmpl(i) + endif + iofst=iofst+nbits + enddo + mapdrslen=newmapdrslen + endif + if( allocated(mapdrs) ) deallocate(mapdrs) + return ! End of Section 5 processing + end + + + subroutine unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: unpack6 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine unpacks Section 6 (Bit-Map Section) +! starting at octet 6 of that Section. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! +! USAGE: CALL unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! iofst - Bit offset of the beginning of Section 6. +! ngpts - Number of grid points specified in the bit-map +! +! OUTPUT ARGUMENT LIST: +! iofst - Bit offset at the end of Section 6, returned. +! ibmap - Bitmap indicator ( see Code Table 6.0 ) +! 0 = bitmap applies and is included in Section 6. +! 1-253 = Predefined bitmap applies +! 254 = Previously defined bitmap applies to this field +! 255 = Bit map does not apply to this product. +! bmap() - Logical*1 array containing decoded bitmap. ( if ibmap=0 ) +! ierr - Error return code. +! 0 = no error +! 4 = Unrecognized pre-defined bit-map. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib,ngpts + integer,intent(inout) :: iofst + integer,intent(out) :: ibmap + integer,intent(out) :: ierr + logical*1,intent(out) :: bmap(ngpts) + + integer :: intbmap(ngpts) + + ierr=0 + + iofst=iofst+32 ! skip Length of Section + iofst=iofst+8 ! skip section number + + call gbyte(cgrib,ibmap,iofst,8) ! Get bit-map indicator + iofst=iofst+8 + + if (ibmap.eq.0) then ! Unpack bitmap + call gbytes(cgrib,intbmap,iofst,1,0,ngpts) + iofst=iofst+ngpts + do j=1,ngpts + bmap(j)=.true. + if (intbmap(j).eq.0) bmap(j)=.false. + enddo + elseif (ibmap.eq.254) then ! Use previous bitmap + return + elseif (ibmap.eq.255) then ! No bitmap in message + bmap(1:ngpts)=.true. + else + print *,'unpack6: Predefined bitmap ',ibmap,' not recognized.' + ierr=4 + endif + + return ! End of Section 6 processing + end + diff --git a/WPS/ungrib/src/ngl/g2/getg2i.f b/WPS/ungrib/src/ngl/g2/getg2i.f new file mode 100755 index 00000000..ffaa9b31 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getg2i.f @@ -0,0 +1,93 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETG2I(LUGI,CBUF,NLEN,NNUM,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETG2I READS A GRIB2 INDEX FILE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 +C +C ABSTRACT: READ A GRIB2 INDEX FILE AND RETURN ITS CONTENTS. +C VERSION 1 OF THE INDEX FILE HAS THE FOLLOWING FORMAT: +C 81-BYTE S.LORD HEADER WITH 'GB2IX1' IN COLUMNS 42-47 FOLLOWED BY +C 81-BYTE HEADER WITH NUMBER OF BYTES TO SKIP BEFORE INDEX RECORDS, +C TOTAL LENGTH IN BYTES OF THE INDEX RECORDS, NUMBER OF INDEX RECORDS, +C AND GRIB FILE BASENAME WRITTEN IN FORMAT ('IX1FORM:',3I10,2X,A40). +C EACH FOLLOWING INDEX RECORD CORRESPONDS TO A GRIB MESSAGE +C AND HAS THE INTERNAL FORMAT: +C BYTE 001 - 004: LENGTH OF INDEX RECORD +C BYTE 005 - 008: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE +C BYTE 009 - 012: BYTES TO SKIP IN MESSAGE BEFORE LUS (LOCAL USE) +C SET = 0, IF NO LOCAL USE SECTION IN GRIB2 MESSAGE. +C BYTE 013 - 016: BYTES TO SKIP IN MESSAGE BEFORE GDS +C BYTE 017 - 020: BYTES TO SKIP IN MESSAGE BEFORE PDS +C BYTE 021 - 024: BYTES TO SKIP IN MESSAGE BEFORE DRS +C BYTE 025 - 028: BYTES TO SKIP IN MESSAGE BEFORE BMS +C BYTE 029 - 032: BYTES TO SKIP IN MESSAGE BEFORE DATA SECTION +C BYTE 033 - 040: BYTES TOTAL IN THE MESSAGE +C BYTE 041 - 041: GRIB VERSION NUMBER ( CURRENTLY 2 ) +C BYTE 042 - 042: MESSAGE DISCIPLINE +C BYTE 043 - 044: FIELD NUMBER WITHIN GRIB2 MESSAGE +C BYTE 045 - II: IDENTIFICATION SECTION (IDS) +C BYTE II+1- JJ: GRID DEFINITION SECTION (GDS) +C BYTE JJ+1- KK: PRODUCT DEFINITION SECTION (PDS) +C BYTE KK+1- LL: THE DATA REPRESENTATION SECTION (DRS) +C BYTE LL+1-LL+6: FIRST 6 BYTES OF THE BIT MAP SECTION (BMS) +C +C PROGRAM HISTORY LOG: +C 95-10-31 IREDELL +C 96-10-31 IREDELL AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320 +C 2002-01-03 GILBERT MODIFIED FROM GETGI TO WORK WITH GRIB2 +C +C USAGE: CALL GETG2I(LUGI,CBUF,NLEN,NNUM,IRET) +C INPUT ARGUMENTS: +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C OUTPUT ARGUMENTS: +C CBUF CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS. +C USERS SHOULD FREE MEMORY THAT CBUF POINTS TO +C USING DEALLOCATE(CBUF) WHEN CBUF IS NO LONGER NEEDED. +C NLEN INTEGER TOTAL LENGTH OF ALL INDEX RECORDS +C NNUM INTEGER NUMBER OF INDEX RECORDS +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 2 NOT ENOUGH MEMORY TO HOLD INDEX BUFFER +C 3 ERROR READING INDEX FILE BUFFER +C 4 ERROR READING INDEX FILE HEADER +C +C SUBPROGRAMS CALLED: +C BAREAD BYTE-ADDRESSABLE READ +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF + INTEGER,INTENT(IN) :: LUGI + INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET + CHARACTER CHEAD*162 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF (ASSOCIATED(CBUF)) NULLIFY(CBUF) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + NLEN=0 + NNUM=0 + IRET=4 + CALL BAREAD(LUGI,0,162,LHEAD,CHEAD) + IF(LHEAD.EQ.162.AND.CHEAD(42:47).EQ.'GB2IX1') THEN + READ(CHEAD(82:162),'(8X,3I10,2X,A40)',IOSTAT=IOS) NSKP,NLEN,NNUM + IF(IOS.EQ.0) THEN + + ALLOCATE(CBUF(NLEN),STAT=ISTAT) ! ALLOCATE SPACE FOR CBUF + IF (ISTAT.NE.0) THEN + IRET=2 + RETURN + ENDIF + IRET=0 + CALL BAREAD(LUGI,NSKP,NLEN,LBUF,CBUF) + IF(LBUF.NE.NLEN) IRET=3 + + ENDIF + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/getg2ir.f b/WPS/ungrib/src/ngl/g2/getg2ir.f new file mode 100755 index 00000000..d58ba036 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getg2ir.f @@ -0,0 +1,138 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,NMESS,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETG2IR CREATES AN INDEX OF A GRIB2 FILE +C PRGMMR: GILBERT ORG: W/NP11 DATE: 2002-01-02 +C +C ABSTRACT: READ A GRIB FILE AND RETURN ITS INDEX CONTENTS. +C THE INDEX BUFFER RETURNED CONTAINS INDEX RECORDS WITH THE INTERNAL FORMAT: +C BYTE 001 - 004: LENGTH OF INDEX RECORD +C BYTE 005 - 008: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE +C BYTE 009 - 012: BYTES TO SKIP IN MESSAGE BEFORE LUS (LOCAL USE) +C SET = 0, IF NO LOCAL USE SECTION IN GRIB2 MESSAGE. +C BYTE 013 - 016: BYTES TO SKIP IN MESSAGE BEFORE GDS +C BYTE 017 - 020: BYTES TO SKIP IN MESSAGE BEFORE PDS +C BYTE 021 - 024: BYTES TO SKIP IN MESSAGE BEFORE DRS +C BYTE 025 - 028: BYTES TO SKIP IN MESSAGE BEFORE BMS +C BYTE 029 - 032: BYTES TO SKIP IN MESSAGE BEFORE DATA SECTION +C BYTE 033 - 040: BYTES TOTAL IN THE MESSAGE +C BYTE 041 - 041: GRIB VERSION NUMBER ( CURRENTLY 2 ) +C BYTE 042 - 042: MESSAGE DISCIPLINE +C BYTE 043 - 044: FIELD NUMBER WITHIN GRIB2 MESSAGE +C BYTE 045 - II: IDENTIFICATION SECTION (IDS) +C BYTE II+1- JJ: GRID DEFINITION SECTION (GDS) +C BYTE JJ+1- KK: PRODUCT DEFINITION SECTION (PDS) +C BYTE KK+1- LL: THE DATA REPRESENTATION SECTION (DRS) +C BYTE LL+1-LL+6: FIRST 6 BYTES OF THE BIT MAP SECTION (BMS) +C +C PROGRAM HISTORY LOG: +C 95-10-31 IREDELL +C 96-10-31 IREDELL AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320 +C 2002-01-02 GILBERT MODIFIED FROM GETGIR TO CREATE GRIB2 INDEXES +C +C USAGE: CALL GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM,NMESS,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB FILE +C MSK1 INTEGER NUMBER OF BYTES TO SEARCH FOR FIRST MESSAGE +C MSK2 INTEGER NUMBER OF BYTES TO SEARCH FOR OTHER MESSAGES +C MNUM INTEGER NUMBER OF GRIB MESSAGES TO SKIP (USUALLY 0) +C OUTPUT ARGUMENTS: +C CBUF CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS. +C USERS SHOULD FREE MEMORY THAT CBUF POINTS TO +C USING DEALLOCATE(CBUF) WHEN CBUF IS NO LONGER NEEDED. +C NLEN INTEGER TOTAL LENGTH OF INDEX RECORD BUFFER IN BYTES +C NNUM INTEGER NUMBER OF INDEX RECORDS +C (=0 IF NO GRIB MESSAGES ARE FOUND) +C NMESS LAST GRIB MESSAGE IN FILE SUCCESSFULLY PROCESSED +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 1 NOT ENOUGH MEMORY AVAILABLE TO HOLD FULL INDEX +C BUFFER +C 2 NOT ENOUGH MEMORY TO ALLOCATE INITIAL INDEX BUFFER +C +C SUBPROGRAMS CALLED: +C SKGB SEEK NEXT GRIB MESSAGE +C IXGB2 MAKE INDEX RECORD +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE RE_ALLOC ! NEEDED FOR SUBROUTINE REALLOC + PARAMETER(INIT=50000,NEXT=10000) + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF + INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM + INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUFTMP + INTERFACE ! REQUIRED FOR CBUF POINTER + SUBROUTINE IXGB2(LUGB,LSKIP,LGRIB,CBUF,NUMFLD,MLEN,IRET) + INTEGER,INTENT(IN) :: LUGB,LSKIP,LGRIB + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF + INTEGER,INTENT(OUT) :: NUMFLD,MLEN,IRET + END SUBROUTINE IXGB2 + END INTERFACE +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C INITIALIZE + IRET=0 + IF (ASSOCIATED(CBUF)) NULLIFY(CBUF) + MBUF=INIT + ALLOCATE(CBUF(MBUF),STAT=ISTAT) ! ALLOCATE INITIAL SPACE FOR CBUF + IF (ISTAT.NE.0) THEN + IRET=2 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH FOR FIRST GRIB MESSAGE + ISEEK=0 + CALL SKGB(LUGB,ISEEK,MSK1,LSKIP,LGRIB) + DO M=1,MNUM + IF(LGRIB.GT.0) THEN + ISEEK=LSKIP+LGRIB + CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB) + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET INDEX RECORDS FOR EVERY GRIB MESSAGE FOUND + NLEN=0 + NNUM=0 + NMESS=MNUM + DOWHILE(IRET.EQ.0.AND.LGRIB.GT.0) + CALL IXGB2(LUGB,LSKIP,LGRIB,CBUFTMP,NUMFLD,NBYTES,IRET1) + IF (IRET1.NE.0) PRINT *,' SAGT ',NUMFLD,NBYTES,IRET1 + IF((NBYTES+NLEN).GT.MBUF) THEN ! ALLOCATE MORE SPACE, IF + ! NECESSARY + NEWSIZE=MAX(MBUF+NEXT,MBUF+NBYTES) + CALL REALLOC(CBUF,NLEN,NEWSIZE,ISTAT) + IF ( ISTAT .NE. 0 ) THEN + IRET=1 + RETURN + ENDIF + MBUF=NEWSIZE + ENDIF + ! + ! IF INDEX RECORDS WERE RETURNED IN CBUFTMP FROM IXGB2, + ! COPY CBUFTMP INTO CBUF, THEN DEALLOCATE CBUFTMP WHEN DONE + ! + IF ( ASSOCIATED(CBUFTMP) ) THEN + CBUF(NLEN+1:NLEN+NBYTES)=CBUFTMP(1:NBYTES) + DEALLOCATE(CBUFTMP,STAT=ISTAT) + IF (ISTAT.NE.0) THEN + PRINT *,' deallocating cbuftmp ... ',istat + stop 99 + ENDIF + NULLIFY(CBUFTMP) + NNUM=NNUM+NUMFLD + NLEN=NLEN+NBYTES + NMESS=NMESS+1 + ENDIF + ! LOOK FOR NEXT GRIB MESSAGE + ISEEK=LSKIP+LGRIB + CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB) + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/getgb2.f b/WPS/ungrib/src/ngl/g2/getgb2.f new file mode 100755 index 00000000..847911e1 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getgb2.f @@ -0,0 +1,338 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGB2(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT, + & UNPACK,K,GFLD,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB2 FINDS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB FIELD REQUESTED. +C THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF FIELDS TO SKIP +C AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND +C PRODUCT DEFINTION SECTION PARAMETERS. (A REQUESTED PARAMETER +C OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB FIELD IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE AND UNPACKED. ITS NUMBER IS RETURNED ALONG WITH +C THE ASSOCIATED UNPACKED PARAMETERS. THE BITMAP (IF ANY), +C AND THE DATA VALUES ARE UNPACKED ONLY IF ARGUMENT "UNPACK" IS SET TO +C TRUE. IF THE GRIB FIELD IS NOT FOUND, THEN THE +C RETURN CODE WILL BE NONZERO. +C +C The decoded information for the selected GRIB field +C is returned in a derived type variable, gfld. +C Gfld is of type gribfield, which is defined +C in module grib_mod, so users of this routine will need to include +C the line "USE GRIB_MOD" in their calling routine. Each component of the +C gribfield type is described in the OUTPUT ARGUMENT LIST section below. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C 2002-01-11 GILBERT MODIFIED FROM GETGB AND GETGBM TO WORK WITH GRIB2 +C 2015-11-10 VUONG MODIFIED DOC BLOCK FOR gfld%ngrdpts and gfld%ndpts +C +C USAGE: CALL GETGB2(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT, +C & UNPACK,K,GFLD,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE. +C FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING +C THIS ROUTINE. +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE. +C IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE +C CALLING THIS ROUTINE. +C >0 - READ INDEX FROM INDEX FILE LUGI, IF INDEX DOESN"T +C ALREADY EXIST. +C =0 - TO GET INDEX BUFFER FROM THE GRIB FILE, IF INDEX +C DOESN"T ALREADY EXIST. +C <0 - FORCE REREAD OF INDEX FROM INDEX FILE ABS(LUGI). +C =LUGB - FORCE REGENERATION OF INDEX FROM GRIB2 FILE LUGB. +C J INTEGER NUMBER OF FIELDS TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C JDISC GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD +C ( IF = -1, ACCEPT ANY DISCIPLINE) +C ( SEE CODE TABLE 0.0 ) +C 0 - Meteorological products +C 1 - Hydrological products +C 2 - Land surface products +C 3 - Space products +C 10 - Oceanographic products +C JIDS() INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION +C (=-9999 FOR WILDCARD) +C JIDS(1) = IDENTIFICATION OF ORIGINATING CENTRE +C ( SEE COMMON CODE TABLE C-1 ) +C JIDS(2) = IDENTIFICATION OF ORIGINATING SUB-CENTRE +C JIDS(3) = GRIB MASTER TABLES VERSION NUMBER +C ( SEE CODE TABLE 1.0 ) +C 0 - Experimental +C 1 - Initial operational version number +C JIDS(4) = GRIB LOCAL TABLES VERSION NUMBER +C ( SEE CODE TABLE 1.1 ) +C 0 - Local tables not used +C 1-254 - Number of local tables version used +C JIDS(5) = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2) +C 0 - Analysis +C 1 - Start of forecast +C 2 - Verifying time of forecast +C 3 - Observation time +C JIDS(6) = YEAR ( 4 DIGITS ) +C JIDS(7) = MONTH +C JIDS(8) = DAY +C JIDS(9) = HOUR +C JIDS(10) = MINUTE +C JIDS(11) = SECOND +C JIDS(12) = PRODUCTION STATUS OF PROCESSED DATA +C ( SEE CODE TABLE 1.3 ) +C 0 - Operational products +C 1 - Operational test products +C 2 - Research products +C 3 - Re-analysis products +C JIDS(13) = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 ) +C 0 - Analysis products +C 1 - Forecast products +C 2 - Analysis and forecast products +C 3 - Control forecast products +C 4 - Perturbed forecast products +C 5 - Control and perturbed forecast products +C 6 - Processed satellite observations +C 7 - Processed radar observations +C JPDTN INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N) +C ( IF = -1, DON'T BOTHER MATCHING PDT - ACCEPT ANY ) +C JPDT() INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION +C TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH +C (=-9999 FOR WILDCARD) +C JGDTN INTEGER GRID DEFINITION TEMPLATE NUMBER (M) +C ( IF = -1, DON'T BOTHER MATCHING GDT - ACCEPT ANY ) +C JGDT() INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION +C TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH +C (=-9999 FOR WILDCARD) +C UNPACK LOGICAL VALUE INDICATING WHETHER TO UNPACK BITMAP/DATA +C .TRUE. = UNPACK BITMAP AND DATA VALUES +C .FALSE. = DO NOT UNPACK BITMAP AND DATA VALUES +C +C OUTPUT ARGUMENTS: +C K INTEGER FIELD NUMBER UNPACKED +C gfld - derived type gribfield ( defined in module grib_mod ) +C ( NOTE: See Remarks Section ) +C gfld%version = GRIB edition number ( currently 2 ) +C gfld%discipline = Message Discipline ( see Code Table 0.0 ) +C gfld%idsect() = Contains the entries in the Identification +C Section ( Section 1 ) +C This element is actually a pointer to an array +C that holds the data. +C gfld%idsect(1) = Identification of originating Centre +C ( see Common Code Table C-1 ) +C 7 - US National Weather Service +C gfld%idsect(2) = Identification of originating Sub-centre +C gfld%idsect(3) = GRIB Master Tables Version Number +C ( see Code Table 1.0 ) +C 0 - Experimental +C 1 - Initial operational version number +C gfld%idsect(4) = GRIB Local Tables Version Number +C ( see Code Table 1.1 ) +C 0 - Local tables not used +C 1-254 - Number of local tables version used +C gfld%idsect(5) = Significance of Reference Time (Code Table 1.2) +C 0 - Analysis +C 1 - Start of forecast +C 2 - Verifying time of forecast +C 3 - Observation time +C gfld%idsect(6) = Year ( 4 digits ) +C gfld%idsect(7) = Month +C gfld%idsect(8) = Day +C gfld%idsect(9) = Hour +C gfld%idsect(10) = Minute +C gfld%idsect(11) = Second +C gfld%idsect(12) = Production status of processed data +C ( see Code Table 1.3 ) +C 0 - Operational products +C 1 - Operational test products +C 2 - Research products +C 3 - Re-analysis products +C gfld%idsect(13) = Type of processed data ( see Code Table 1.4 ) +C 0 - Analysis products +C 1 - Forecast products +C 2 - Analysis and forecast products +C 3 - Control forecast products +C 4 - Perturbed forecast products +C 5 - Control and perturbed forecast products +C 6 - Processed satellite observations +C 7 - Processed radar observations +C gfld%idsectlen = Number of elements in gfld%idsect(). +C gfld%local() = Pointer to character array containing contents +C of Local Section 2, if included +C gfld%locallen = length of array gfld%local() +C gfld%ifldnum = field number within GRIB message +C gfld%griddef = Source of grid definition (see Code Table 3.0) +C 0 - Specified in Code table 3.1 +C 1 - Predetermined grid Defined by originating centre +C gfld%ngrdpts = Number of grid points in the defined grid. +C Note that the number of actual data values returned from +C getgb2 (in gfld%ndpts) may be less than this value if a +C logical bitmap is in use with grid points that are being masked out. +C gfld%numoct_opt = Number of octets needed for each +C additional grid points definition. +C Used to define number of +C points in each row ( or column ) for +C non-regular grids. +C = 0, if using regular grid. +C gfld%interp_opt = Interpretation of list for optional points +C definition. (Code Table 3.11) +C gfld%igdtnum = Grid Definition Template Number (Code Table 3.1) +C gfld%igdtmpl() = Contains the data values for the specified Grid +C Definition Template ( NN=gfld%igdtnum ). Each +C element of this integer array contains an entry (in +C the order specified) of Grid Defintion Template 3.NN +C This element is actually a pointer to an array +C that holds the data. +C gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of +C entries in Grid Defintion Template 3.NN +C ( NN=gfld%igdtnum ). +C gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array +C contains the number of grid points contained in +C each row ( or column ). (part of Section 3) +C This element is actually a pointer to an array +C that holds the data. This pointer is nullified +C if gfld%numoct_opt=0. +C gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries +C in array ideflist. i.e. number of rows ( or columns ) +C for which optional grid points are defined. This value +C is set to zero, if gfld%numoct_opt=0. +C gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0) +C gfld%ipdtmpl() = Contains the data values for the specified Product +C Definition Template ( N=gfdl%ipdtnum ). Each element +C of this integer array contains an entry (in the +C order specified) of Product Defintion Template 4.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of +C entries in Product Defintion Template 4.N +C ( N=gfdl%ipdtnum ). +C gfld%coord_list() = Real array containing floating point values +C intended to document the vertical discretisation +C associated to model data on hybrid coordinate +C vertical levels. (part of Section 4) +C This element is actually a pointer to an array +C that holds the data. +C gfld%num_coord = number of values in array gfld%coord_list(). +C gfld%ndpts = Number of data points unpacked and returned. +C Note that this number may be different from the value of +C gfld%ngrdpts if a logical bitmap is in use with grid points +C that are being masked out. +C gfld%idrtnum = Data Representation Template Number +C ( see Code Table 5.0) +C gfld%idrtmpl() = Contains the data values for the specified Data +C Representation Template ( N=gfld%idrtnum ). Each +C element of this integer array contains an entry +C (in the order specified) of Product Defintion +C Template 5.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number +C of entries in Data Representation Template 5.N +C ( N=gfld%idrtnum ). +C gfld%unpacked = logical value indicating whether the bitmap and +C data values were unpacked. If false, +C gfld%bmap and gfld%fld pointers are nullified. +C gfld%expanded = Logical value indicating whether the data field +C was expanded to the grid in the case where a +C bit-map is present. If true, the data points in +C gfld%fld match the grid points and zeros were +C inserted at grid points where data was bit-mapped +C out. If false, the data values in gfld%fld were +C not expanded to the grid and are just a consecutive +C array of data points corresponding to each value of +C "1" in gfld%bmap. +C gfld%ibmap = Bitmap indicator ( see Code Table 6.0 ) +C 0 = bitmap applies and is included in Section 6. +C 1-253 = Predefined bitmap applies +C 254 = Previously defined bitmap applies to this field +C 255 = Bit map does not apply to this product. +C gfld%bmap() = Logical*1 array containing decoded bitmap, +C if ibmap=0 or ibap=254. Otherwise nullified. +C This element is actually a pointer to an array +C that holds the data. +C gfld%fld() = Array of gfld%ndpts unpacked data points. +C This element is actually a pointer to an array +C that holds the data. +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX +C 97 ERROR READING GRIB FILE +C 99 REQUEST NOT FOUND +C OTHER GF_GETFLD GRIB2 UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C GETIDX GET INDEX +C GETGB2S SEARCH INDEX RECORDS +C GETGB2R READ AND UNPACK GRIB RECORD +C GF_FREE FREES MEMORY USED BY GFLD ( SEE REMARKS ) +C +C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C Note that derived type gribfield contains pointers to many +C arrays of data. The memory for these arrays is allocated +C when the values in the arrays are set, to help minimize +C problems with array overloading. Because of this users +C are encouraged to free up this memory, when it is no longer +C needed, by an explicit call to subroutine gf_free. +C ( i.e. CALL GF_FREE(GFLD) ) +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE GRIB_MOD + + INTEGER,INTENT(IN) :: LUGB,LUGI,J,JDISC,JPDTN,JGDTN + INTEGER,DIMENSION(:) :: JIDS(*),JPDT(*),JGDT(*) + LOGICAL,INTENT(IN) :: UNPACK + INTEGER,INTENT(OUT) :: K,IRET + TYPE(GRIBFIELD),INTENT(OUT) :: GFLD + + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF + +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DECLARE INTERFACES (REQUIRED FOR CBUF POINTER) + INTERFACE + SUBROUTINE GETIDX(LUGB,LUGI,CBUF,NLEN,NNUM,IRGI) + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF + INTEGER,INTENT(IN) :: LUGB,LUGI + INTEGER,INTENT(OUT) :: NLEN,NNUM,IRGI + END SUBROUTINE GETIDX + END INTERFACE +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED + IRGI=0 + CALL GETIDX(LUGB,LUGI,CBUF,NLEN,NNUM,IRGI) + IF(IRGI.GT.1) THEN + IRET=96 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH INDEX BUFFER + CALL GETGB2S(CBUF,NLEN,NNUM,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT, + & JK,GFLD,LPOS,IRGS) + IF(IRGS.NE.0) THEN + IRET=99 + CALL GF_FREE(GFLD) + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ LOCAL USE SECTION, IF AVAILABLE + CALL GETGB2L(LUGB,CBUF(LPOS),GFLD,IRET) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND UNPACK GRIB RECORD + IF (UNPACK) THEN + ! NUMFLD=GFLD%IFLDNUM + ! CALL GF_FREE(GFLD) + CALL GETGB2R(LUGB,CBUF(LPOS),GFLD,IRET) + ENDIF + K=JK +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/getgb2l.f b/WPS/ungrib/src/ngl/g2/getgb2l.f new file mode 100755 index 00000000..0705ccfb --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getgb2l.f @@ -0,0 +1,234 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGB2L(LUGB,CINDEX,GFLD,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB2L EXTRACTS LOCAL USE SECTION +C PRGMMR: GILBERT ORG: W/NP11 DATE: 02-05-07 +C +C ABSTRACT: READ AND UNPACK A LOCAL USE SECTION FROM A GRIB2 MESSAGE. +C +C The decoded information for the selected GRIB field +C is returned in a derived type variable, gfld. +C Gfld is of type gribfield, which is defined +C in module grib_mod, so users of this routine will need to include +C the line "USE GRIB_MOD" in their calling routine. Each component of the +C gribfield type is described in the OUTPUT ARGUMENT LIST section below. +C +C PROGRAM HISTORY LOG: +C 2002-05-07 GILBERT +C +C USAGE: CALL GETGB2L(LUGB,CINDEX,GFLD,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C CINDEX INDEX RECORD OF THE GRIB FIELD ( SEE DOCBLOCK OF +C SUBROUTINE IXGB2 FOR DESCRIPTION OF AN INDEX RECORD.) +C OUTPUT ARGUMENTS: +C gfld - derived type gribfield ( defined in module grib_mod ) +C ( NOTE: See Remarks Section ) +C gfld%version = GRIB edition number ( currently 2 ) +C gfld%discipline = Message Discipline ( see Code Table 0.0 ) +C gfld%idsect() = Contains the entries in the Identification +C Section ( Section 1 ) +C This element is actually a pointer to an array +C that holds the data. +C gfld%idsect(1) = Identification of originating Centre +C ( see Common Code Table C-1 ) +C 7 - US National Weather Service +C gfld%idsect(2) = Identification of originating Sub-centre +C gfld%idsect(3) = GRIB Master Tables Version Number +C ( see Code Table 1.0 ) +C 0 - Experimental +C 1 - Initial operational version number +C gfld%idsect(4) = GRIB Local Tables Version Number +C ( see Code Table 1.1 ) +C 0 - Local tables not used +C 1-254 - Number of local tables version used +C gfld%idsect(5) = Significance of Reference Time (Code Table 1.2) +C 0 - Analysis +C 1 - Start of forecast +C 2 - Verifying time of forecast +C 3 - Observation time +C gfld%idsect(6) = Year ( 4 digits ) +C gfld%idsect(7) = Month +C gfld%idsect(8) = Day +C gfld%idsect(9) = Hour +C gfld%idsect(10) = Minute +C gfld%idsect(11) = Second +C gfld%idsect(12) = Production status of processed data +C ( see Code Table 1.3 ) +C 0 - Operational products +C 1 - Operational test products +C 2 - Research products +C 3 - Re-analysis products +C gfld%idsect(13) = Type of processed data ( see Code Table 1.4 ) +C 0 - Analysis products +C 1 - Forecast products +C 2 - Analysis and forecast products +C 3 - Control forecast products +C 4 - Perturbed forecast products +C 5 - Control and perturbed forecast products +C 6 - Processed satellite observations +C 7 - Processed radar observations +C gfld%idsectlen = Number of elements in gfld%idsect(). +C gfld%local() = Pointer to character array containing contents +C of Local Section 2, if included +C gfld%locallen = length of array gfld%local() +C gfld%ifldnum = field number within GRIB message +C gfld%griddef = Source of grid definition (see Code Table 3.0) +C 0 - Specified in Code table 3.1 +C 1 - Predetermined grid Defined by originating centre +C gfld%ngrdpts = Number of grid points in the defined grid. +C gfld%numoct_opt = Number of octets needed for each +C additional grid points definition. +C Used to define number of +C points in each row ( or column ) for +C non-regular grids. +C = 0, if using regular grid. +C gfld%interp_opt = Interpretation of list for optional points +C definition. (Code Table 3.11) +C gfld%igdtnum = Grid Definition Template Number (Code Table 3.1) +C gfld%igdtmpl() = Contains the data values for the specified Grid +C Definition Template ( NN=gfld%igdtnum ). Each +C element of this integer array contains an entry (in +C the order specified) of Grid Defintion Template 3.NN +C This element is actually a pointer to an array +C that holds the data. +C gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of +C entries in Grid Defintion Template 3.NN +C ( NN=gfld%igdtnum ). +C gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array +C contains the number of grid points contained in +C each row ( or column ). (part of Section 3) +C This element is actually a pointer to an array +C that holds the data. This pointer is nullified +C if gfld%numoct_opt=0. +C gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries +C in array ideflist. i.e. number of rows ( or columns ) +C for which optional grid points are defined. This value +C is set to zero, if gfld%numoct_opt=0. +C gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0) +C gfld%ipdtmpl() = Contains the data values for the specified Product +C Definition Template ( N=gfdl%ipdtnum ). Each element +C of this integer array contains an entry (in the +C order specified) of Product Defintion Template 4.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of +C entries in Product Defintion Template 4.N +C ( N=gfdl%ipdtnum ). +C gfld%coord_list() = Real array containing floating point values +C intended to document the vertical discretisation +C associated to model data on hybrid coordinate +C vertical levels. (part of Section 4) +C This element is actually a pointer to an array +C that holds the data. +C gfld%num_coord = number of values in array gfld%coord_list(). +C gfld%ndpts = Number of data points unpacked and returned. +C gfld%idrtnum = Data Representation Template Number +C ( see Code Table 5.0) +C gfld%idrtmpl() = Contains the data values for the specified Data +C Representation Template ( N=gfld%idrtnum ). Each +C element of this integer array contains an entry +C (in the order specified) of Product Defintion +C Template 5.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number +C of entries in Data Representation Template 5.N +C ( N=gfld%idrtnum ). +C gfld%unpacked = logical value indicating whether the bitmap and +C data values were unpacked. If false, +C gfld%bmap and gfld%fld pointers are nullified. +C gfld%ibmap = Bitmap indicator ( see Code Table 6.0 ) +C 0 = bitmap applies and is included in Section 6. +C 1-253 = Predefined bitmap applies +C 254 = Previously defined bitmap applies to this field +C 255 = Bit map does not apply to this product. +C gfld%bmap() = Logical*1 array containing decoded bitmap, +C if ibmap=0 or ibap=254. Otherwise nullified. +C This element is actually a pointer to an array +C that holds the data. +C gfld%fld() = Array of gfld%ndpts unpacked data points. +C This element is actually a pointer to an array +C that holds the data. +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 97 ERROR READING GRIB FILE +C OTHER GF_GETFLD GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C BAREAD BYTE-ADDRESSABLE READ +C GF_GETFLD UNPACK GRIB FIELD +C +C REMARKS: +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB2 ROUTINES ONLY. +C +C Note that derived type gribfield contains pointers to many +C arrays of data. The memory for these arrays is allocated +C when the values in the arrays are set, to help minimize +C problems with array overloading. Because of this users +C are encouraged to free up this memory, when it is no longer +C needed, by an explicit call to subroutine gf_free. +C ( i.e. CALL GF_FREE(GFLD) ) +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE GRIB_MOD + + INTEGER,INTENT(IN) :: LUGB + CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*) + INTEGER,INTENT(OUT) :: IRET + TYPE(GRIBFIELD) :: GFLD + + INTEGER :: LSKIP,SKIP2 + CHARACTER(LEN=1):: CSIZE(4) + CHARACTER(LEN=1),ALLOCATABLE :: CTEMP(:) + + interface + subroutine gf_unpack2(cgrib,lcgrib,iofst,lencsec2,csec2,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,intent(out) :: lencsec2 + integer,intent(out) :: ierr + character(len=1),pointer,dimension(:) :: csec2 + end subroutine gf_unpack2 + end interface +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET INFO + NULLIFY(gfld%local) + IRET=0 + CALL GBYTE(CINDEX,LSKIP,4*8,4*8) + CALL GBYTE(CINDEX,SKIP2,8*8,4*8) + +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND UNPACK LOCAL USE SECTION, IF PRESENT + IF ( SKIP2.NE.0 ) THEN + ISKIP=LSKIP+SKIP2 + CALL BAREAD(LUGB,ISKIP,4,LREAD,CSIZE) ! GET LENGTH OF SECTION + CALL GBYTE(CSIZE,ILEN,0,32) + ALLOCATE(CTEMP(ILEN)) + CALL BAREAD(LUGB,ISKIP,ILEN,LREAD,CTEMP) ! READ IN SECTION + IF (ILEN.NE.LREAD) THEN + IRET=97 + DEALLOCATE(CTEMP) + RETURN + ENDIF + IOFST=0 + CALL GF_UNPACK2(CTEMP,ILEN,IOFST,gfld%locallen, + & gfld%local,ierr) + IF (IERR.NE.0) THEN + IRET=98 + DEALLOCATE(CTEMP) + RETURN + ENDIF + DEALLOCATE(CTEMP) + ELSE + gfld%locallen=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/getgb2p.f b/WPS/ungrib/src/ngl/g2/getgb2p.f new file mode 100755 index 00000000..19d5b800 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getgb2p.f @@ -0,0 +1,223 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGB2P(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT, + & EXTRACT,K,GRIBM,LENG,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB2P FINDS AND EXTRACTS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND AND EXTRACTS A GRIB MESSAGE FROM A FILE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB FIELD REQUESTED. +C THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF FIELDS TO SKIP +C AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND +C PRODUCT DEFINTION SECTION PARAMETERS. (A REQUESTED PARAMETER +C OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB FIELD IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE AND RETURNED. +C IF THE GRIB FIELD IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C 2002-01-11 GILBERT MODIFIED FROM GETGB AND GETGBM TO WORK WITH GRIB2 +C 2003-12-17 GILBERT MODIFIED FROM GETGB2 TO RETURN PACKED GRIB2 MESSAGE. +C +C USAGE: CALL GETGB2P(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT, +C & EXTRACT,K,GRIBM,LENG,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE. +C FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING +C THIS ROUTINE. +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE. +C IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE +C CALLING THIS ROUTINE. +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C J INTEGER NUMBER OF FIELDS TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C JDISC GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD +C ( IF = -1, ACCEPT ANY DISCIPLINE) +C ( SEE CODE TABLE 0.0 ) +C 0 - Meteorological products +C 1 - Hydrological products +C 2 - Land surface products +C 3 - Space products +C 10 - Oceanographic products +C JIDS() INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION +C (=-9999 FOR WILDCARD) +C JIDS(1) = IDENTIFICATION OF ORIGINATING CENTRE +C ( SEE COMMON CODE TABLE C-1 ) +C JIDS(2) = IDENTIFICATION OF ORIGINATING SUB-CENTRE +C JIDS(3) = GRIB MASTER TABLES VERSION NUMBER +C ( SEE CODE TABLE 1.0 ) +C 0 - Experimental +C 1 - Initial operational version number +C JIDS(4) = GRIB LOCAL TABLES VERSION NUMBER +C ( SEE CODE TABLE 1.1 ) +C 0 - Local tables not used +C 1-254 - Number of local tables version used +C JIDS(5) = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2) +C 0 - Analysis +C 1 - Start of forecast +C 2 - Verifying time of forecast +C 3 - Observation time +C JIDS(6) = YEAR ( 4 DIGITS ) +C JIDS(7) = MONTH +C JIDS(8) = DAY +C JIDS(9) = HOUR +C JIDS(10) = MINUTE +C JIDS(11) = SECOND +C JIDS(12) = PRODUCTION STATUS OF PROCESSED DATA +C ( SEE CODE TABLE 1.3 ) +C 0 - Operational products +C 1 - Operational test products +C 2 - Research products +C 3 - Re-analysis products +C JIDS(13) = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 ) +C 0 - Analysis products +C 1 - Forecast products +C 2 - Analysis and forecast products +C 3 - Control forecast products +C 4 - Perturbed forecast products +C 5 - Control and perturbed forecast products +C 6 - Processed satellite observations +C 7 - Processed radar observations +C JPDTN INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N) +C ( IF = -1, DON'T BOTHER MATCHING PDT - ACCEPT ANY ) +C JPDT() INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION +C TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH +C (=-9999 FOR WILDCARD) +C JGDTN INTEGER GRID DEFINITION TEMPLATE NUMBER (M) +C ( IF = -1, DON'T BOTHER MATCHING GDT - ACCEPT ANY ) +C JGDT() INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION +C TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH +C (=-9999 FOR WILDCARD) +C EXTRACT LOGICAL VALUE INDICATING WHETHER TO RETURN A GRIB2 +C MESSAGE WITH JUST THE REQUESTED FIELD, OR THE ENTIRE +C GRIB2 MESSAGE CONTAINING THE REQUESTED FIELD. +C .TRUE. = RETURN GRIB2 MESSAGE CONTAINING ONLY THE REQUESTED +C FIELD. +C .FALSE. = RETURN ENTIRE GRIB2 MESSAGE CONTAINING THE +C REQUESTED FIELD. +C +C OUTPUT ARGUMENTS: +C K INTEGER FIELD NUMBER RETURNED. +C GRIBM RETURNED GRIB MESSAGE. +C LENG LENGTH OF RETURNED GRIB MESSAGE IN BYTES. +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 99 REQUEST NOT FOUND +C +C SUBPROGRAMS CALLED: +C GETG2I READ INDEX FILE +C GETG2IR READ INDEX BUFFER FROM GRIB FILE +C GETGB2S SEARCH INDEX RECORDS +C GETGB2RP READ A PACKED GRIB RECORD +C GF_FREE FREES MEMORY USED BY GFLD ( SEE REMARKS ) +C +C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C Note that derived type gribfield contains pointers to many +C arrays of data. The memory for these arrays is allocated +C when the values in the arrays are set, to help minimize +C problems with array overloading. Because of this users +C are encouraged to free up this memory, when it is no longer +C needed, by an explicit call to subroutine gf_free. +C ( i.e. CALL GF_FREE(GFLD) ) +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE GRIB_MOD + + INTEGER,INTENT(IN) :: LUGB,LUGI,J,JDISC,JPDTN,JGDTN + INTEGER,DIMENSION(:) :: JIDS(*),JPDT(*),JGDT(*) + LOGICAL,INTENT(IN) :: EXTRACT + INTEGER,INTENT(OUT) :: K,IRET,LENG + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM + + TYPE(GRIBFIELD) :: GFLD + + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF + PARAMETER(MSK1=32000,MSK2=4000) + + SAVE CBUF,NLEN,NNUM + DATA LUX/0/ +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DECLARE INTERFACES (REQUIRED FOR CBUF POINTER) + INTERFACE + SUBROUTINE GETG2I(LUGI,CBUF,NLEN,NNUM,IRET) + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF + INTEGER,INTENT(IN) :: LUGI + INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET + END SUBROUTINE GETG2I + SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM, + & NMESS,IRET) + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF + INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM + INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET + END SUBROUTINE GETG2IR + SUBROUTINE GETGB2RP(LUGB,CINDEX,EXTRACT,GRIBM,LENG,IRET) + INTEGER,INTENT(IN) :: LUGB + CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*) + LOGICAL,INTENT(IN) :: EXTRACT + INTEGER,INTENT(OUT) :: LENG,IRET + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM + END SUBROUTINE GETGB2RP + END INTERFACE + +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED + IRGI=0 + IF(LUGI.GT.0.AND.LUGI.NE.LUX) THEN + CALL GETG2I(LUGI,CBUF,NLEN,NNUM,IRGI) + LUX=LUGI + ELSEIF(LUGI.LE.0.AND.LUGB.NE.LUX) THEN + MSKP=0 + CALL GETG2IR(LUGB,MSK1,MSK2,MSKP,CBUF,NLEN,NNUM,NMESS,IRGI) + LUX=LUGB + ENDIF + IF(IRGI.GT.1) THEN + IRET=96 + LUX=0 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH INDEX BUFFER + CALL GETGB2S(CBUF,NLEN,NNUM,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT, + & JK,GFLD,LPOS,IRGS) + IF(IRGS.NE.0) THEN + IRET=99 + CALL GF_FREE(GFLD) + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C EXTRACT GRIB MESSAGE FROM FILE + CALL GETGB2RP(LUGB,CBUF(LPOS:),EXTRACT,GRIBM,LENG,IRET) +! IF ( EXTRACT ) THEN +! PRINT *,'NOT SUPPOSED TO BE HERE.' +! ELSE +! IPOS=(LPOS+3)*8 +! CALL GBYTE(CBUF,ISKIP,IPOS,32) ! BYTES TO SKIP IN FILE +! IPOS=IPOS+(32*8) +! CALL GBYTE(CBUF,LENG,IPOS,32) ! LENGTH OF GRIB MESSAGE +! IF (.NOT. ASSOCIATED(GRIBM)) ALLOCATE(GRIBM(LENG)) +! CALL BAREAD(LUGB,ISKIP,LENG,LREAD,GRIBM) +! IF ( LENG .NE. LREAD ) THEN +! IRET=97 +! CALL GF_FREE(GFLD) +! RETURN +! ENDIF +! ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + K=JK + CALL GF_FREE(GFLD) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/getgb2r.f b/WPS/ungrib/src/ngl/g2/getgb2r.f new file mode 100755 index 00000000..3459338a --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getgb2r.f @@ -0,0 +1,305 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGB2R(LUGB,CINDEX,GFLD,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB2R READS AND UNPACKS A GRIB FIELD +C PRGMMR: GILBERT ORG: W/NP11 DATE: 02-01-15 +C +C ABSTRACT: READ AND UNPACK SECTIONS 6 AND 7 FROM A GRIB2 MESSAGE. +C +C This routine assumes that the "metadata" for this field +C already exists in derived type gribfield. Specifically, +C it requires gfld%ibmap,gfld%ngrdpts,gfld%idrtnum,gfld%idrtmpl, +C and gfld%ndpts. +C +C The decoded information for the selected GRIB field +C is returned in a derived type variable, gfld. +C Gfld is of type gribfield, which is defined +C in module grib_mod, so users of this routine will need to include +C the line "USE GRIB_MOD" in their calling routine. Each component of the +C gribfield type is described in the OUTPUT ARGUMENT LIST section below. +C +C PROGRAM HISTORY LOG: +C 95-10-31 IREDELL +C 2002-01-11 GILBERT MODIFIED FROM GETGB1R TO WORK WITH GRIB2 +C +C USAGE: CALL GETGB2R(LUGB,CINDEX,GFLD,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C CINDEX INDEX RECORD OF THE GRIB FIELD ( SEE DOCBLOCK OF +C SUBROUTINE IXGB2 FOR DESCRIPTION OF AN INDEX RECORD.) +C OUTPUT ARGUMENTS: +C gfld - derived type gribfield ( defined in module grib_mod ) +C ( NOTE: See Remarks Section ) +C gfld%version = GRIB edition number ( currently 2 ) +C gfld%discipline = Message Discipline ( see Code Table 0.0 ) +C gfld%idsect() = Contains the entries in the Identification +C Section ( Section 1 ) +C This element is actually a pointer to an array +C that holds the data. +C gfld%idsect(1) = Identification of originating Centre +C ( see Common Code Table C-1 ) +C 7 - US National Weather Service +C gfld%idsect(2) = Identification of originating Sub-centre +C gfld%idsect(3) = GRIB Master Tables Version Number +C ( see Code Table 1.0 ) +C 0 - Experimental +C 1 - Initial operational version number +C gfld%idsect(4) = GRIB Local Tables Version Number +C ( see Code Table 1.1 ) +C 0 - Local tables not used +C 1-254 - Number of local tables version used +C gfld%idsect(5) = Significance of Reference Time (Code Table 1.2) +C 0 - Analysis +C 1 - Start of forecast +C 2 - Verifying time of forecast +C 3 - Observation time +C gfld%idsect(6) = Year ( 4 digits ) +C gfld%idsect(7) = Month +C gfld%idsect(8) = Day +C gfld%idsect(9) = Hour +C gfld%idsect(10) = Minute +C gfld%idsect(11) = Second +C gfld%idsect(12) = Production status of processed data +C ( see Code Table 1.3 ) +C 0 - Operational products +C 1 - Operational test products +C 2 - Research products +C 3 - Re-analysis products +C gfld%idsect(13) = Type of processed data ( see Code Table 1.4 ) +C 0 - Analysis products +C 1 - Forecast products +C 2 - Analysis and forecast products +C 3 - Control forecast products +C 4 - Perturbed forecast products +C 5 - Control and perturbed forecast products +C 6 - Processed satellite observations +C 7 - Processed radar observations +C gfld%idsectlen = Number of elements in gfld%idsect(). +C gfld%local() = Pointer to character array containing contents +C of Local Section 2, if included +C gfld%locallen = length of array gfld%local() +C gfld%ifldnum = field number within GRIB message +C gfld%griddef = Source of grid definition (see Code Table 3.0) +C 0 - Specified in Code table 3.1 +C 1 - Predetermined grid Defined by originating centre +C gfld%ngrdpts = Number of grid points in the defined grid. +C gfld%numoct_opt = Number of octets needed for each +C additional grid points definition. +C Used to define number of +C points in each row ( or column ) for +C non-regular grids. +C = 0, if using regular grid. +C gfld%interp_opt = Interpretation of list for optional points +C definition. (Code Table 3.11) +C gfld%igdtnum = Grid Definition Template Number (Code Table 3.1) +C gfld%igdtmpl() = Contains the data values for the specified Grid +C Definition Template ( NN=gfld%igdtnum ). Each +C element of this integer array contains an entry (in +C the order specified) of Grid Defintion Template 3.NN +C This element is actually a pointer to an array +C that holds the data. +C gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of +C entries in Grid Defintion Template 3.NN +C ( NN=gfld%igdtnum ). +C gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array +C contains the number of grid points contained in +C each row ( or column ). (part of Section 3) +C This element is actually a pointer to an array +C that holds the data. This pointer is nullified +C if gfld%numoct_opt=0. +C gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries +C in array ideflist. i.e. number of rows ( or columns ) +C for which optional grid points are defined. This value +C is set to zero, if gfld%numoct_opt=0. +C gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0) +C gfld%ipdtmpl() = Contains the data values for the specified Product +C Definition Template ( N=gfdl%ipdtnum ). Each element +C of this integer array contains an entry (in the +C order specified) of Product Defintion Template 4.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of +C entries in Product Defintion Template 4.N +C ( N=gfdl%ipdtnum ). +C gfld%coord_list() = Real array containing floating point values +C intended to document the vertical discretisation +C associated to model data on hybrid coordinate +C vertical levels. (part of Section 4) +C This element is actually a pointer to an array +C that holds the data. +C gfld%num_coord = number of values in array gfld%coord_list(). +C gfld%ndpts = Number of data points unpacked and returned. +C gfld%idrtnum = Data Representation Template Number +C ( see Code Table 5.0) +C gfld%idrtmpl() = Contains the data values for the specified Data +C Representation Template ( N=gfld%idrtnum ). Each +C element of this integer array contains an entry +C (in the order specified) of Product Defintion +C Template 5.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number +C of entries in Data Representation Template 5.N +C ( N=gfld%idrtnum ). +C gfld%unpacked = logical value indicating whether the bitmap and +C data values were unpacked. If false, +C gfld%bmap and gfld%fld pointers are nullified. +C gfld%expanded = Logical value indicating whether the data field +C was expanded to the grid in the case where a +C bit-map is present. If true, the data points in +C gfld%fld match the grid points and zeros were +C inserted at grid points where data was bit-mapped +C out. If false, the data values in gfld%fld were +C not expanded to the grid and are just a consecutive +C array of data points corresponding to each value of +C "1" in gfld%bmap. +C gfld%ibmap = Bitmap indicator ( see Code Table 6.0 ) +C 0 = bitmap applies and is included in Section 6. +C 1-253 = Predefined bitmap applies +C 254 = Previously defined bitmap applies to this field +C 255 = Bit map does not apply to this product. +C gfld%bmap() = Logical*1 array containing decoded bitmap, +C if ibmap=0 or ibap=254. Otherwise nullified. +C This element is actually a pointer to an array +C that holds the data. +C gfld%fld() = Array of gfld%ndpts unpacked data points. +C This element is actually a pointer to an array +C that holds the data. +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 97 ERROR READING GRIB FILE +C OTHER GF_GETFLD GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C BAREAD BYTE-ADDRESSABLE READ +C GF_UNPACK6 UNAPCKS BIT_MAP SECTION +C GF_UNPACK7 UNAPCKS DATA SECTION +C +C REMARKS: +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB2 ROUTINES ONLY. +C +C Note that derived type gribfield contains pointers to many +C arrays of data. The memory for these arrays is allocated +C when the values in the arrays are set, to help minimize +C problems with array overloading. Because of this, users +C are encouraged to free up this memory, when it is no longer +C needed, by an explicit call to subroutine gf_free. +C ( i.e. CALL GF_FREE(GFLD) ) +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE GRIB_MOD + + INTEGER,INTENT(IN) :: LUGB + CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*) + INTEGER,INTENT(OUT) :: IRET + TYPE(GRIBFIELD) :: GFLD + + INTEGER :: LSKIP,SKIP6,SKIP7 + CHARACTER(LEN=1):: CSIZE(4) + CHARACTER(LEN=1),ALLOCATABLE :: CTEMP(:) + real,pointer,dimension(:) :: newfld + + interface + subroutine gf_unpack6(cgrib,lcgrib,iofst,ngpts,ibmap, + & bmap,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib,ngpts + integer,intent(inout) :: iofst + integer,intent(out) :: ibmap + integer,intent(out) :: ierr + logical*1,pointer,dimension(:) :: bmap + end subroutine gf_unpack6 + subroutine gf_unpack7(cgrib,lcgrib,iofst,igdsnum,igdstmpl, + & idrsnum,idrstmpl,ndpts,fld,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib,ndpts,idrsnum,igdsnum + integer,intent(inout) :: iofst + integer,pointer,dimension(:) :: idrstmpl,igdstmpl + integer,intent(out) :: ierr + real,pointer,dimension(:) :: fld + end subroutine gf_unpack7 + end interface +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET INFO + NULLIFY(gfld%bmap,gfld%fld) + IRET=0 + CALL GBYTE(CINDEX,LSKIP,4*8,4*8) + CALL GBYTE(CINDEX,SKIP6,24*8,4*8) + CALL GBYTE(CINDEX,SKIP7,28*8,4*8) + +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND UNPACK BIT_MAP, IF PRESENT + IF ( gfld%ibmap.eq.0.OR.gfld%ibmap.eq.254 ) THEN + ISKIP=LSKIP+SKIP6 + CALL BAREAD(LUGB,ISKIP,4,LREAD,CSIZE) ! GET LENGTH OF SECTION + CALL GBYTE(CSIZE,ILEN,0,32) + ALLOCATE(CTEMP(ILEN)) + CALL BAREAD(LUGB,ISKIP,ILEN,LREAD,CTEMP) ! READ IN SECTION + IF (ILEN.NE.LREAD) THEN + IRET=97 + DEALLOCATE(CTEMP) + RETURN + ENDIF + IOFST=0 + CALL GF_UNPACK6(CTEMP,ILEN,IOFST,gfld%ngrdpts,idum, + & gfld%bmap,ierr) + IF (IERR.NE.0) THEN + IRET=98 + DEALLOCATE(CTEMP) + RETURN + ENDIF + DEALLOCATE(CTEMP) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND UNPACK DATA FIELD + ISKIP=LSKIP+SKIP7 + CALL BAREAD(LUGB,ISKIP,4,LREAD,CSIZE) ! GET LENGTH OF SECTION + CALL GBYTE(CSIZE,ILEN,0,32) + if (ilen.lt.6) ilen=6 + ALLOCATE(CTEMP(ILEN)) + CALL BAREAD(LUGB,ISKIP,ILEN,LREAD,CTEMP) ! READ IN SECTION + IF (ILEN.NE.LREAD) THEN + IRET=97 + DEALLOCATE(CTEMP) + RETURN + ENDIF + IOFST=0 + CALL GF_UNPACK7(CTEMP,ILEN,IOFST,gfld%igdtnum,gfld%igdtmpl, + & gfld%idrtnum,gfld%idrtmpl,gfld%ndpts, + & gfld%fld,ierr) + IF (IERR.NE.0) THEN + IRET=98 + DEALLOCATE(CTEMP) + RETURN + ENDIF + DEALLOCATE(CTEMP) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + ! If bitmap is used with this field, expand data field + ! to grid, if possible. + if ( gfld%ibmap .ne. 255 .AND. associated(gfld%bmap) ) then + allocate(newfld(gfld%ngrdpts)) + !newfld=0.0 + !newfld=unpack(lgfld%fld,lgfld%bmap,newfld) + n=1 + do j=1,gfld%ngrdpts + if ( gfld%bmap(j) ) then + newfld(j)=gfld%fld(n) + n=n+1 + else + newfld(j)=0.0 + endif + enddo + deallocate(gfld%fld); + gfld%fld=>newfld; + gfld%expanded=.true. + else + gfld%expanded=.true. + endif +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/getgb2rp.f b/WPS/ungrib/src/ngl/g2/getgb2rp.f new file mode 100755 index 00000000..0cabeb65 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getgb2rp.f @@ -0,0 +1,189 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGB2RP(LUGB,CINDEX,EXTRACT,GRIBM,LENG,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB2RP EXTRACTS A GRIB MESSAGE FROM A FILE +C PRGMMR: GILBERT ORG: W/NMC23 DATE: 2003-12-31 +C +C ABSTRACT: FIND AND EXTRACTS A GRIB MESSAGE FROM A FILE GIVEN THE +C INDEX FOR THE REQUESTED FIELD. +C THE GRIB MESSAGE RETURNED CAN CONTAIN ONLY THE REQUESTED FIELD +C (EXTRACT=.TRUE.). OR THE COMPLETE GRIB MESSAGE ORIGINALLY CONTAINING +C THE DESIRED FIELD CAN BE RETURNED (EXTRACT=.FALSE.) EVEN IF OTHER +C FIELDS WERE INCLUDED IN THE GRIB MESSAGE. +C IF THE GRIB FIELD IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 2003-12-31 GILBERT +C +C USAGE: CALL GETGB2RP(LUGB,CINDEX,EXTRACT,GRIBM,LENG,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE. +C FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING +C THIS ROUTINE. +C CINDEX INDEX RECORD OF THE GRIB FILE ( SEE DOCBLOCK OF +C SUBROUTINE IXGB2 FOR DESCRIPTION OF AN INDEX RECORD.) +C EXTRACT LOGICAL VALUE INDICATING WHETHER TO RETURN A GRIB2 +C MESSAGE WITH JUST THE REQUESTED FIELD, OR THE ENTIRE +C GRIB2 MESSAGE CONTAINING THE REQUESTED FIELD. +C .TRUE. = RETURN GRIB2 MESSAGE CONTAINING ONLY THE REQUESTED +C FIELD. +C .FALSE. = RETURN ENTIRE GRIB2 MESSAGE CONTAINING THE +C REQUESTED FIELD. +C +C OUTPUT ARGUMENTS: +C GRIBM RETURNED GRIB MESSAGE. +C LENG LENGTH OF RETURNED GRIB MESSAGE IN BYTES. +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 97 ERROR READING GRIB FILE +C +C SUBPROGRAMS CALLED: +C BAREAD BYTE-ADDRESSABLE READ +C +C REMARKS: NONE +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + + INTEGER,INTENT(IN) :: LUGB + CHARACTER(LEN=1),INTENT(IN) :: CINDEX(*) + LOGICAL,INTENT(IN) :: EXTRACT + INTEGER,INTENT(OUT) :: LENG,IRET + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: GRIBM + + INTEGER,PARAMETER :: ZERO=0 + CHARACTER(LEN=1),ALLOCATABLE,DIMENSION(:) :: CSEC2,CSEC6,CSEC7 + CHARACTER(LEN=4) :: Ctemp + + IRET=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C EXTRACT GRIB MESSAGE FROM FILE + IF ( EXTRACT ) THEN + LEN0=16 + LEN8=4 + CALL GBYTE(CINDEX,ISKIP,4*8,4*8) ! BYTES TO SKIP IN FILE + CALL GBYTE(CINDEX,ISKP2,8*8,4*8) ! BYTES TO SKIP FOR section 2 + if ( iskp2 .gt. 0 ) then + CALL BAREAD(LUGB,ISKIP+ISKP2,4,LREAD,ctemp) + CALL GBYTE(Ctemp,LEN2,0,4*8) ! LENGTH OF SECTION 2 + ALLOCATE(csec2(len2)) + CALL BAREAD(LUGB,ISKIP+ISKP2,LEN2,LREAD,csec2) + else + LEN2=0 + endif + CALL GBYTE(CINDEX,LEN1,44*8,4*8) ! LENGTH OF SECTION 1 + IPOS=44+LEN1 + CALL GBYTE(CINDEX,LEN3,IPOS*8,4*8) ! LENGTH OF SECTION 3 + IPOS=IPOS+LEN3 + CALL GBYTE(CINDEX,LEN4,IPOS*8,4*8) ! LENGTH OF SECTION 4 + IPOS=IPOS+LEN4 + CALL GBYTE(CINDEX,LEN5,IPOS*8,4*8) ! LENGTH OF SECTION 5 + IPOS=IPOS+LEN5 + CALL GBYTE(CINDEX,LEN6,IPOS*8,4*8) ! LENGTH OF SECTION 6 + IPOS=IPOS+5 + CALL GBYTE(CINDEX,IBMAP,IPOS*8,1*8) ! Bitmap indicator + IF ( IBMAP .eq. 254 ) THEN + CALL GBYTE(CINDEX,ISKP6,24*8,4*8) ! BYTES TO SKIP FOR section 6 + CALL BAREAD(LUGB,ISKIP+ISKP6,4,LREAD,ctemp) + CALL GBYTE(Ctemp,LEN6,0,4*8) ! LENGTH OF SECTION 6 + ENDIF + ! + ! READ IN SECTION 7 from file + ! + CALL GBYTE(CINDEX,ISKP7,28*8,4*8) ! BYTES TO SKIP FOR section 7 + CALL BAREAD(LUGB,ISKIP+ISKP7,4,LREAD,ctemp) + CALL GBYTE(Ctemp,LEN7,0,4*8) ! LENGTH OF SECTION 7 + ALLOCATE(csec7(len7)) + CALL BAREAD(LUGB,ISKIP+ISKP7,LEN7,LREAD,csec7) + + LENG=LEN0+LEN1+LEN2+LEN3+LEN4+LEN5+LEN6+LEN7+LEN8 + IF (.NOT. ASSOCIATED(GRIBM)) ALLOCATE(GRIBM(LENG)) + + ! Create Section 0 + ! + GRIBM(1)='G' + GRIBM(2)='R' + GRIBM(3)='I' + GRIBM(4)='B' + GRIBM(5)=CHAR(0) + GRIBM(6)=CHAR(0) + GRIBM(7)=CINDEX(42) + GRIBM(8)=CINDEX(41) + GRIBM(9)=CHAR(0) + GRIBM(10)=CHAR(0) + GRIBM(11)=CHAR(0) + GRIBM(12)=CHAR(0) + CALL SBYTE(GRIBM,LENG,12*8,4*8) + ! + ! Copy Section 1 + ! + GRIBM(17:16+LEN1)=CINDEX(45:44+LEN1) + lencur=16+LEN1 + ipos=44+len1 + ! + ! Copy Section 2, if necessary + ! + if ( iskp2 .gt. 0 ) then + GRIBM(lencur+1:lencur+LEN2)=csec2(1:LEN2) + lencur=lencur+LEN2 + endif + ! + ! Copy Sections 3 through 5 + ! + GRIBM(lencur+1:lencur+LEN3+LEN4+LEN5)= + & CINDEX(ipos+1:ipos+LEN3+LEN4+LEN5) + lencur=lencur+LEN3+LEN4+LEN5 + ipos=ipos+LEN3+LEN4+LEN5 + ! + ! Copy Section 6 + ! + if ( LEN6 .eq. 6 .AND. IBMAP .ne. 254 ) then + GRIBM(lencur+1:lencur+LEN6)=CINDEX(ipos+1:ipos+LEN6) + lencur=lencur+LEN6 + else + CALL GBYTE(CINDEX,ISKP6,24*8,4*8) ! BYTES TO SKIP FOR section 6 + CALL BAREAD(LUGB,ISKIP+ISKP6,4,LREAD,ctemp) + CALL GBYTE(Ctemp,LEN6,0,4*8) ! LENGTH OF SECTION 6 + ALLOCATE(csec6(len6)) + CALL BAREAD(LUGB,ISKIP+ISKP6,LEN6,LREAD,csec6) + GRIBM(lencur+1:lencur+LEN6)=csec6(1:LEN6) + lencur=lencur+LEN6 + IF ( allocated(csec6)) DEALLOCATE(csec6) + endif + ! + ! Copy Section 7 + ! + GRIBM(lencur+1:lencur+LEN7)=csec7(1:LEN7) + lencur=lencur+LEN7 + ! + ! Section 8 + ! + GRIBM(lencur+1)='7' + GRIBM(lencur+2)='7' + GRIBM(lencur+3)='7' + GRIBM(lencur+4)='7' + + ! clean up + ! + IF ( allocated(csec2)) DEALLOCATE(csec2) + IF ( allocated(csec7)) deallocate(csec7) + + ELSE ! DO NOT extract field from message : Get entire message + + CALL GBYTE(CINDEX,ISKIP,4*8,4*8) ! BYTES TO SKIP IN FILE + CALL GBYTE(CINDEX,LENG,36*8,4*8) ! LENGTH OF GRIB MESSAGE + IF (.NOT. ASSOCIATED(GRIBM)) ALLOCATE(GRIBM(LENG)) + CALL BAREAD(LUGB,ISKIP,LENG,LREAD,GRIBM) + IF ( LENG .NE. LREAD ) THEN + DEALLOCATE(GRIBM) + NULLIFY(GRIBM) + IRET=97 + RETURN + ENDIF + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/getgb2s.f b/WPS/ungrib/src/ngl/g2/getgb2s.f new file mode 100755 index 00000000..b206afda --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getgb2s.f @@ -0,0 +1,491 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGB2S(CBUF,NLEN,NNUM,J,JDISC,JIDS,JPDTN,JPDT,JGDTN, + & JGDT,K,GFLD,LPOS,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB2S FINDS A GRIB MESSAGE +C PRGMMR: GILBERT ORG: W/NP11 DATE: 02-01-15 +C +C ABSTRACT: FIND A GRIB MESSAGE. +C FIND IN THE INDEX FILE A REFERENCE TO THE GRIB FIELD REQUESTED. +C THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND +C PRODUCT DEFINTION SECTION PARAMETERS. (A REQUESTED PARAMETER +C OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C +C EACH INDEX RECORD HAS THE FOLLOWING FORM: +C BYTE 001 - 004: LENGTH OF INDEX RECORD +C BYTE 005 - 008: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE +C BYTE 009 - 012: BYTES TO SKIP IN MESSAGE BEFORE LUS (LOCAL USE) +C SET = 0, IF NO LOCAL USE SECTION IN GRIB2 MESSAGE. +C BYTE 013 - 016: BYTES TO SKIP IN MESSAGE BEFORE GDS +C BYTE 017 - 020: BYTES TO SKIP IN MESSAGE BEFORE PDS +C BYTE 021 - 024: BYTES TO SKIP IN MESSAGE BEFORE DRS +C BYTE 025 - 028: BYTES TO SKIP IN MESSAGE BEFORE BMS +C BYTE 029 - 032: BYTES TO SKIP IN MESSAGE BEFORE DATA SECTION +C BYTE 033 - 040: BYTES TOTAL IN THE MESSAGE +C BYTE 041 - 041: GRIB VERSION NUMBER ( CURRENTLY 2 ) +C BYTE 042 - 042: MESSAGE DISCIPLINE +C BYTE 043 - 044: FIELD NUMBER WITHIN GRIB2 MESSAGE +C BYTE 045 - II: IDENTIFICATION SECTION (IDS) +C BYTE II+1- JJ: GRID DEFINITION SECTION (GDS) +C BYTE JJ+1- KK: PRODUCT DEFINITION SECTION (PDS) +C BYTE KK+1- LL: THE DATA REPRESENTATION SECTION (DRS) +C BYTE LL+1-LL+6: FIRST 6 BYTES OF THE BIT MAP SECTION (BMS) +C +C Most of the decoded information for the selected GRIB field +C is returned in a derived type variable, gfld. +C Gfld is of type gribfield, which is defined +C in module grib_mod, so users of this routine will need to include +C the line "USE GRIB_MOD" in their calling routine. Each component of the +C gribfield type is described in the OUTPUT ARGUMENT LIST section below. +C Only the unpacked bitmap and data field components are not set by this +C routine. +C +C PROGRAM HISTORY LOG: +C 95-10-31 IREDELL +C 2002-01-02 GILBERT MODIFIED FROM GETG1S TO WORK WITH GRIB2 +C 2011-06-24 VUONG BOI Initialize variable gfld%idsect and gfld%local +C +C USAGE: CALL GETGB2S(CBUF,NLEN,NNUM,J,JDISC,JIDS,JPDTN,JPDT,JGDTN, +C & JGDT,K,GFLD,LPOS,IRET) +C INPUT ARGUMENTS: +C CBUF CHARACTER*1 (NLEN) BUFFER CONTAINING INDEX DATA +C NLEN INTEGER TOTAL LENGTH OF ALL INDEX RECORDS +C NNUM INTEGER NUMBER OF INDEX RECORDS +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C JDISC GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD +C ( IF = -1, ACCEPT ANY DISCIPLINE) +C ( SEE CODE TABLE 0.0 ) +C 0 - Meteorological products +C 1 - Hydrological products +C 2 - Land surface products +C 3 - Space products +C 10 - Oceanographic products +C JIDS() INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION +C (=-9999 FOR WILDCARD) +C JIDS(1) = IDENTIFICATION OF ORIGINATING CENTRE +C ( SEE COMMON CODE TABLE C-1 ) +C JIDS(2) = IDENTIFICATION OF ORIGINATING SUB-CENTRE +C JIDS(3) = GRIB MASTER TABLES VERSION NUMBER +C ( SEE CODE TABLE 1.0 ) +C 0 - Experimental +C 1 - Initial operational version number +C JIDS(4) = GRIB LOCAL TABLES VERSION NUMBER +C ( SEE CODE TABLE 1.1 ) +C 0 - Local tables not used +C 1-254 - Number of local tables version used +C JIDS(5) = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2) +C 0 - Analysis +C 1 - Start of forecast +C 2 - Verifying time of forecast +C 3 - Observation time +C JIDS(6) = YEAR ( 4 DIGITS ) +C JIDS(7) = MONTH +C JIDS(8) = DAY +C JIDS(9) = HOUR +C JIDS(10) = MINUTE +C JIDS(11) = SECOND +C JIDS(12) = PRODUCTION STATUS OF PROCESSED DATA +C ( SEE CODE TABLE 1.3 ) +C 0 - Operational products +C 1 - Operational test products +C 2 - Research products +C 3 - Re-analysis products +C JIDS(13) = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 ) +C 0 - Analysis products +C 1 - Forecast products +C 2 - Analysis and forecast products +C 3 - Control forecast products +C 4 - Perturbed forecast products +C 5 - Control and perturbed forecast products +C 6 - Processed satellite observations +C 7 - Processed radar observations +C JPDTN INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N) +C ( IF = -1, DON'T BOTHER MATCHING PDT ) +C JPDT() INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION +C TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH +C (=-9999 FOR WILDCARD) +C JGDTN INTEGER GRID DEFINITION TEMPLATE NUMBER (M) +C ( IF = -1, DON'T BOTHER MATCHING GDT ) +C JGDT() INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION +C TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH +C (=-9999 FOR WILDCARD) +C OUTPUT ARGUMENTS: +C K INTEGER MESSAGE NUMBER FOUND +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C gfld - derived type gribfield ( defined in module grib_mod ) +C ( NOTE: See Remarks Section ) +C gfld%version = GRIB edition number ( currently 2 ) +C gfld%discipline = Message Discipline ( see Code Table 0.0 ) +C gfld%idsect() = Contains the entries in the Identification +C Section ( Section 1 ) +C This element is actually a pointer to an array +C that holds the data. +C gfld%idsect(1) = Identification of originating Centre +C ( see Common Code Table C-1 ) +C 7 - US National Weather Service +C gfld%idsect(2) = Identification of originating Sub-centre +C gfld%idsect(3) = GRIB Master Tables Version Number +C ( see Code Table 1.0 ) +C 0 - Experimental +C 1 - Initial operational version number +C gfld%idsect(4) = GRIB Local Tables Version Number +C ( see Code Table 1.1 ) +C 0 - Local tables not used +C 1-254 - Number of local tables version used +C gfld%idsect(5) = Significance of Reference Time (Code Table 1.2) +C 0 - Analysis +C 1 - Start of forecast +C 2 - Verifying time of forecast +C 3 - Observation time +C gfld%idsect(6) = Year ( 4 digits ) +C gfld%idsect(7) = Month +C gfld%idsect(8) = Day +C gfld%idsect(9) = Hour +C gfld%idsect(10) = Minute +C gfld%idsect(11) = Second +C gfld%idsect(12) = Production status of processed data +C ( see Code Table 1.3 ) +C 0 - Operational products +C 1 - Operational test products +C 2 - Research products +C 3 - Re-analysis products +C gfld%idsect(13) = Type of processed data ( see Code Table 1.4 ) +C 0 - Analysis products +C 1 - Forecast products +C 2 - Analysis and forecast products +C 3 - Control forecast products +C 4 - Perturbed forecast products +C 5 - Control and perturbed forecast products +C 6 - Processed satellite observations +C 7 - Processed radar observations +C gfld%idsectlen = Number of elements in gfld%idsect(). +C gfld%local() = Pointer to character array containing contents +C of Local Section 2, if included +C gfld%locallen = length of array gfld%local() +C gfld%ifldnum = field number within GRIB message +C gfld%griddef = Source of grid definition (see Code Table 3.0) +C 0 - Specified in Code table 3.1 +C 1 - Predetermined grid Defined by originating centre +C gfld%ngrdpts = Number of grid points in the defined grid. +C gfld%numoct_opt = Number of octets needed for each +C additional grid points definition. +C Used to define number of +C points in each row ( or column ) for +C non-regular grids. +C = 0, if using regular grid. +C gfld%interp_opt = Interpretation of list for optional points +C definition. (Code Table 3.11) +C gfld%igdtnum = Grid Definition Template Number (Code Table 3.1) +C gfld%igdtmpl() = Contains the data values for the specified Grid +C Definition Template ( NN=gfld%igdtnum ). Each +C element of this integer array contains an entry (in +C the order specified) of Grid Defintion Template 3.NN +C This element is actually a pointer to an array +C that holds the data. +C gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of +C entries in Grid Defintion Template 3.NN +C ( NN=gfld%igdtnum ). +C gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array +C contains the number of grid points contained in +C each row ( or column ). (part of Section 3) +C This element is actually a pointer to an array +C that holds the data. This pointer is nullified +C if gfld%numoct_opt=0. +C gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries +C in array ideflist. i.e. number of rows ( or columns ) +C for which optional grid points are defined. This value +C is set to zero, if gfld%numoct_opt=0. +C gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0) +C gfld%ipdtmpl() = Contains the data values for the specified Product +C Definition Template ( N=gfdl%ipdtnum ). Each element +C of this integer array contains an entry (in the +C order specified) of Product Defintion Template 4.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of +C entries in Product Defintion Template 4.N +C ( N=gfdl%ipdtnum ). +C gfld%coord_list() = Real array containing floating point values +C intended to document the vertical discretisation +C associated to model data on hybrid coordinate +C vertical levels. (part of Section 4) +C This element is actually a pointer to an array +C that holds the data. +C gfld%num_coord = number of values in array gfld%coord_list(). +C gfld%ndpts = Number of data points unpacked and returned. +C gfld%idrtnum = Data Representation Template Number +C ( see Code Table 5.0) +C gfld%idrtmpl() = Contains the data values for the specified Data +C Representation Template ( N=gfld%idrtnum ). Each +C element of this integer array contains an entry +C (in the order specified) of Product Defintion +C Template 5.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number +C of entries in Data Representation Template 5.N +C ( N=gfld%idrtnum ). +C gfld%unpacked = logical value indicating whether the bitmap and +C data values were unpacked. If false, +C gfld%bmap and gfld%fld pointers are nullified. +C NOTE: This routine sets this component to .FALSE. +C gfld%ibmap = Bitmap indicator ( see Code Table 6.0 ) +C 0 = bitmap applies and is included in Section 6. +C 1-253 = Predefined bitmap applies +C 254 = Previously defined bitmap applies to this field +C 255 = Bit map does not apply to this product. +C gfld%bmap() = Logical*1 array containing decoded bitmap, +C if ibmap=0 or ibap=254. Otherwise nullified. +C This element is actually a pointer to an array +C that holds the data. +C NOTE: This component is not set by this routine. +C gfld%fld() = Array of gfld%ndpts unpacked data points. +C This element is actually a pointer to an array +C that holds the data. +C NOTE: This component is not set by this routine. +C LPOS STARTING POSITION OF THE FOUND INDEX RECORD WITHIN +C THE COMPLETE INDEX BUFFER, CBUF. +C = 0, IF REQUEST NOT FOUND +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 1 REQUEST NOT FOUND +C +C REMARKS: +C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB2 ROUTINES ONLY. +C +C Note that derived type gribfield contains pointers to many +C arrays of data. The memory for these arrays is allocated +C when the values in the arrays are set, to help minimize +C problems with array overloading. Because of this users +C are encouraged to free up this memory, when it is no longer +C needed, by an explicit call to subroutine gf_free. +C ( i.e. CALL GF_FREE(GFLD) ) +C +C SUBPROGRAMS CALLED: +C GBYTE UNPACK BYTES +C GF_UNPACK1 UNPACK IDS +C GF_UNPACK4 UNPACK PDS +C GF_UNPACK3 UNPACK GDS +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE GRIB_MOD + +! CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF + CHARACTER(LEN=1),INTENT(IN) :: CBUF(NLEN) + INTEGER,INTENT(IN) :: NLEN,NNUM,J,JDISC,JPDTN,JGDTN + INTEGER,DIMENSION(:) :: JIDS(*),JPDT(*),JGDT(*) + INTEGER,INTENT(OUT) :: K,LPOS,IRET + TYPE(GRIBFIELD),INTENT(OUT) :: GFLD + + INTEGER :: KGDS(5) + LOGICAL :: MATCH1,MATCH3,MATCH4 +! INTEGER,POINTER,DIMENSION(:) :: KIDS,KPDT,KGDT +! INTEGER,POINTER,DIMENSION(:) :: IDEF +! REAL,POINTER,DIMENSION(:) :: COORD + + interface + subroutine gf_unpack1(cgrib,lcgrib,iofst,ids,idslen,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,pointer,dimension(:) :: ids + integer,intent(out) :: ierr,idslen + end subroutine gf_unpack1 + subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl, + & mapgridlen,ideflist,idefnum,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,pointer,dimension(:) :: igdstmpl,ideflist + integer,intent(out) :: igds(5) + integer,intent(out) :: ierr,idefnum + end subroutine gf_unpack3 + subroutine gf_unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl, + & mappdslen,coordlist,numcoord,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + real,pointer,dimension(:) :: coordlist + integer,pointer,dimension(:) :: ipdstmpl + integer,intent(out) :: ipdsnum + integer,intent(out) :: ierr,numcoord + end subroutine gf_unpack4 + subroutine gf_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum, + & idrstmpl,mapdrslen,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,intent(out) :: ndpts,idrsnum + integer,pointer,dimension(:) :: idrstmpl + integer,intent(out) :: ierr + end subroutine gf_unpack5 + end interface + +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C INITIALIZE + K=0 + LPOS=0 + IRET=1 + IPOS=0 + nullify(gfld%idsect,gfld%local) + nullify(gfld%list_opt,gfld%igdtmpl,gfld%ipdtmpl) + nullify(gfld%coord_list,gfld%idrtmpl,gfld%bmap,gfld%fld) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH FOR REQUEST + DOWHILE(IRET.NE.0.AND.K.LT.NNUM) + K=K+1 + CALL GBYTE(CBUF,INLEN,IPOS*8,4*8) ! GET LENGTH OF CURRENT + ! INDEX RECORD + IF ( K.LE.J ) THEN ! SKIP THIS INDEX + IPOS=IPOS+INLEN + CYCLE + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C CHECK IF GRIB2 DISCIPLINE IS A MATCH + CALL GBYTE(CBUF,GFLD%DISCIPLINE,(IPOS+41)*8,1*8) + IF ( (JDISC.NE.-1).AND.(JDISC.NE.GFLD%DISCIPLINE) ) THEN + IPOS=IPOS+INLEN + CYCLE + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C CHECK IF IDENTIFICATION SECTION IS A MATCH + MATCH1=.FALSE. + CALL GBYTE(CBUF,LSEC1,(IPOS+44)*8,4*8) ! GET LENGTH OF IDS + IOF=0 + CALL GF_UNPACK1(CBUF(IPOS+45),LSEC1,IOF,GFLD%IDSECT, + & GFLD%IDSECTLEN,ICND) + IF ( ICND.EQ.0 ) THEN + MATCH1=.TRUE. + DO I=1,GFLD%IDSECTLEN + IF ( (JIDS(I).NE.-9999).AND. + & (JIDS(I).NE.GFLD%IDSECT(I)) ) THEN + MATCH1=.FALSE. + EXIT + ENDIF + ENDDO + ENDIF + IF ( .NOT. MATCH1 ) THEN + DEALLOCATE(GFLD%IDSECT) + IPOS=IPOS+INLEN + CYCLE + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C CHECK IF GRID DEFINITION TEMPLATE IS A MATCH + JPOS=IPOS+44+LSEC1 + MATCH3=.FALSE. + CALL GBYTE(CBUF,LSEC3,JPOS*8,4*8) ! GET LENGTH OF GDS + IF ( JGDTN.EQ.-1 ) THEN + MATCH3=.TRUE. + ELSE + CALL GBYTE(CBUF,NUMGDT,(JPOS+12)*8,2*8) ! GET GDT TEMPLATE NO. + IF ( JGDTN.EQ.NUMGDT ) THEN + IOF=0 + CALL GF_UNPACK3(CBUF(JPOS+1),LSEC3,IOF,KGDS,GFLD%IGDTMPL, + & GFLD%IGDTLEN,GFLD%LIST_OPT,GFLD%NUM_OPT,ICND) + IF ( ICND.EQ.0 ) THEN + MATCH3=.TRUE. + DO I=1,GFLD%IGDTLEN + IF ( (JGDT(I).NE.-9999).AND. + & (JGDT(I).NE.GFLD%IGDTMPL(I)) ) THEN + MATCH3=.FALSE. + EXIT + ENDIF + ENDDO +C WHERE ( JGDT(1:GFLD%IGDTLEN).NE.-9999 ) +C & MATCH3=ALL(JGDT(1:GFLD%IGDTLEN).EQ.GFLD%IGDTMPL(1:GFLD%IGDTLEN)) + ENDIF + ENDIF + ENDIF + IF ( .NOT. MATCH3 ) THEN + IF (ASSOCIATED(GFLD%IGDTMPL)) DEALLOCATE(GFLD%IGDTMPL) + IF (ASSOCIATED(GFLD%LIST_OPT)) DEALLOCATE(GFLD%LIST_OPT) + IPOS=IPOS+INLEN + CYCLE + ELSE + GFLD%GRIDDEF=KGDS(1) + GFLD%NGRDPTS=KGDS(2) + GFLD%NUMOCT_OPT=KGDS(3) + GFLD%INTERP_OPT=KGDS(4) + GFLD%IGDTNUM=KGDS(5) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C CHECK IF PRODUCT DEFINITION TEMPLATE IS A MATCH + JPOS=JPOS+LSEC3 + MATCH4=.FALSE. + CALL GBYTE(CBUF,LSEC4,JPOS*8,4*8) ! GET LENGTH OF PDS + IF ( JPDTN.EQ.-1 ) THEN + MATCH4=.TRUE. + ELSE + CALL GBYTE(CBUF,NUMPDT,(JPOS+7)*8,2*8) ! GET PDT TEMPLATE NO. + IF ( JPDTN.EQ.NUMPDT ) THEN + IOF=0 + CALL GF_UNPACK4(CBUF(JPOS+1),LSEC4,IOF,GFLD%IPDTNUM, + & GFLD%IPDTMPL,GFLD%IPDTLEN, + & GFLD%COORD_LIST,GFLD%NUM_COORD,ICND) + IF ( ICND.EQ.0 ) THEN + MATCH4=.TRUE. + DO I=1,GFLD%IPDTLEN + IF ( (JPDT(I).NE.-9999).AND. + & (JPDT(I).NE.GFLD%IPDTMPL(I)) ) THEN + MATCH4=.FALSE. + EXIT + ENDIF + ENDDO +c WHERE ( JPDT.NE.-9999) +c & MATCH4=ALL( JPDT(1:GFLD%IPDTLEN) .EQ. GFLD%IPDTMPL(1:GFLD%IPDTLEN) ) + ENDIF + ENDIF + ENDIF + IF ( .NOT. MATCH4 ) THEN + IF (ASSOCIATED(GFLD%IPDTMPL)) DEALLOCATE(GFLD%IPDTMPL) + IF (ASSOCIATED(GFLD%COORD_LIST)) DEALLOCATE(GFLD%COORD_LIST) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C IF REQUEST IS FOUND +C SET VALUES FOR DERIVED TYPE GFLD AND RETURN + IF(MATCH1.AND.MATCH3.AND.MATCH4) THEN + LPOS=IPOS+1 + CALL GBYTE(CBUF,GFLD%VERSION,(IPOS+40)*8,1*8) + CALL GBYTE(CBUF,GFLD%IFLDNUM,(IPOS+42)*8,2*8) + GFLD%UNPACKED=.FALSE. + JPOS=IPOS+44+LSEC1 + IF ( JGDTN.EQ.-1 ) THEN ! UNPACK GDS, IF NOT DONE BEFORE + IOF=0 + CALL GF_UNPACK3(CBUF(JPOS+1),LSEC3,IOF,KGDS,GFLD%IGDTMPL, + & GFLD%IGDTLEN,GFLD%LIST_OPT,GFLD%NUM_OPT,ICND) + GFLD%GRIDDEF=KGDS(1) + GFLD%NGRDPTS=KGDS(2) + GFLD%NUMOCT_OPT=KGDS(3) + GFLD%INTERP_OPT=KGDS(4) + GFLD%IGDTNUM=KGDS(5) + ENDIF + JPOS=JPOS+LSEC3 + IF ( JPDTN.EQ.-1 ) THEN ! UNPACK PDS, IF NOT DONE BEFORE + IOF=0 + CALL GF_UNPACK4(CBUF(JPOS+1),LSEC4,IOF,GFLD%IPDTNUM, + & GFLD%IPDTMPL,GFLD%IPDTLEN, + & GFLD%COORD_LIST,GFLD%NUM_COORD,ICND) + ENDIF + JPOS=JPOS+LSEC4 + CALL GBYTE(CBUF,LSEC5,JPOS*8,4*8) ! GET LENGTH OF DRS + IOF=0 + CALL GF_UNPACK5(CBUF(JPOS+1),LSEC5,IOF,GFLD%NDPTS, + & GFLD%IDRTNUM,GFLD%IDRTMPL, + & GFLD%IDRTLEN,ICND) + JPOS=JPOS+LSEC5 + CALL GBYTE(CBUF,GFLD%IBMAP,(JPOS+5)*8,1*8) ! GET IBMAP + IRET=0 + ELSE ! PDT DID NOT MATCH + IPOS=IPOS+INLEN + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/getidx.f b/WPS/ungrib/src/ngl/g2/getidx.f new file mode 100755 index 00000000..99689c74 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getidx.f @@ -0,0 +1,156 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETIDX(LUGB,LUGI,CINDEX,NLEN,NNUM,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETIDX FINDS, READS OR GENERATES A GRIB2 INDEX +C PRGMMR: GILBERT ORG: W/NP11 DATE: 2005-03-15 +C +C ABSTRACT: FINDS, READS OR GENERATES A GRIB2 INDEX FOR THE GRIB2 FILE +C ASSOCIATED WITH UNIT LUGB. IF THE INDEX ALREADY EXISTS, IT IS RETURNED. +C OTHERWISE, THE INDEX IS (1) READ FROM AN EXISTING INDEXFILE ASSOCIATED WITH +C UNIT LUGI. OR (2) GENERATED FROM THE GRIB2FILE LUGB ( IF LUGI=0 ). +C USERS CAN FORCE A REGENERATION OF AN INDEX. IF LUGI EQUALS LUGB, THE INDEX +C WILL BE REGENERATED FROM THE DATA IN FILE LUGB. IF LUGI IS LESS THAN +C ZERO, THEN THE INDEX IS RE READ FROM INDEX FILE ABS(LUGI). +C +C PROGRAM HISTORY LOG: +C 2005-03-15 GILBERT +C 2009-07-09 VUONG Fixed bug for checking (LUGB) unit index file +C 2016-03-29 VUONG Restore original getidx.f from version 1.2.3 +C Modified GETIDEX to allow to open range of unit file number up to 9999 +C Added new parameters and new Product Definition Template +C numbers: 4.60, 4.61 +C +C USAGE: CALL GETIDX(LUGB,LUGI,CINDEX,NLEN,NNUM,IRET) +C +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE. +C FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING +C THIS ROUTINE. +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE. +C IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE +C CALLING THIS ROUTINE. +C >0 - READ INDEX FROM INDEX FILE LUGI, IF INDEX DOESN"T +C ALREADY EXIST. +C =0 - TO GET INDEX BUFFER FROM THE GRIB FILE, IF INDEX +C DOESN"T ALREADY EXIST. +C <0 - FORCE REREAD OF INDEX FROM INDEX FILE ABS(LUGI). +C =LUGB - FORCE REGENERATION OF INDEX FROM GRIB2 FILE LUGB. +C +C OUTPUT ARGUMENTS: +C CINDEX CHARACTER*1 POINTER TO A BUFFER THAT CONTAINS INDEX RECORDS. +C NLEN INTEGER TOTAL LENGTH OF ALL INDEX RECORDS +C NNUM INTEGER NUMBER OF INDEX RECORDS +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 90 UNIT NUMBER OUT OF RANGE +C 96 ERROR READING/CREATING INDEX FILE +C +C SUBPROGRAMS CALLED: +C GETG2I READ INDEX FILE +C GETG2IR READ INDEX BUFFER FROM GRIB FILE +C +C REMARKS: +C - Allow file unit numbers in range 0 - 9999 +C the grib index will automatically generate the index file. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + + INTEGER,INTENT(IN) :: LUGB,LUGI + INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CINDEX + + INTEGER,PARAMETER :: MAXIDX=10000 + INTEGER,PARAMETER :: MSK1=32000,MSK2=4000 + + TYPE GINDEX + integer :: nlen + integer :: nnum + character(len=1),pointer,dimension(:) :: cbuf + END TYPE GINDEX + + TYPE(GINDEX),SAVE :: IDXLIST(10000) + + DATA LUX/0/ +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DECLARE INTERFACES (REQUIRED FOR CBUF POINTER) + INTERFACE + SUBROUTINE GETG2I(LUGI,CBUF,NLEN,NNUM,IRET) + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF + INTEGER,INTENT(IN) :: LUGI + INTEGER,INTENT(OUT) :: NLEN,NNUM,IRET + END SUBROUTINE GETG2I + SUBROUTINE GETG2IR(LUGB,MSK1,MSK2,MNUM,CBUF,NLEN,NNUM, + & NMESS,IRET) + CHARACTER(LEN=1),POINTER,DIMENSION(:) :: CBUF + INTEGER,INTENT(IN) :: LUGB,MSK1,MSK2,MNUM + INTEGER,INTENT(OUT) :: NLEN,NNUM,NMESS,IRET + END SUBROUTINE GETG2IR + END INTERFACE + +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED + LUX=0 + IRET=0 + IF ( LUGB.LE.0 .OR. LUGB.GT.9999 ) THEN + PRINT*,' ' + PRINT *,' FILE UNIT NUMBER OUT OF RANGE' + PRINT *,' USE UNIT NUMBERS IN RANGE: 0 - 9999 ' + PRINT*,' ' + IRET=90 + RETURN + ENDIF + IF (LUGI.EQ.LUGB) THEN ! Force regeneration of index from GRIB2 File + IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) ) + & DEALLOCATE(IDXLIST(LUGB)%CBUF) + NULLIFY(IDXLIST(LUGB)%CBUF) + IDXLIST(LUGB)%NLEN=0 + IDXLIST(LUGB)%NNUM=0 + LUX=0 + ENDIF + IF (LUGI.LT.0) THEN ! Force re-read of index from indexfile + ! associated with unit abs(lugi) + IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) ) + & DEALLOCATE(IDXLIST(LUGB)%CBUF) + NULLIFY(IDXLIST(LUGB)%CBUF) + IDXLIST(LUGB)%NLEN=0 + IDXLIST(LUGB)%NNUM=0 + LUX=ABS(LUGI) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C Check if index already exists in memory + IF ( ASSOCIATED( IDXLIST(LUGB)%CBUF ) ) THEN + CINDEX => IDXLIST(LUGB)%CBUF + NLEN = IDXLIST(LUGB)%NLEN + NNUM = IDXLIST(LUGB)%NNUM + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IRGI=0 + IF(LUX.GT.0) THEN + CALL GETG2I(LUX,IDXLIST(LUGB)%CBUF,NLEN,NNUM,IRGI) + ELSEIF(LUX.LE.0) THEN + MSKP=0 + CALL GETG2IR(LUGB,MSK1,MSK2,MSKP,IDXLIST(LUGB)%CBUF, + & NLEN,NNUM,NMESS,IRGI) + ENDIF + IF(IRGI.EQ.0) THEN + CINDEX => IDXLIST(LUGB)%CBUF + IDXLIST(LUGB)%NLEN = NLEN + IDXLIST(LUGB)%NNUM = NNUM + ELSE + NLEN = 0 + NNUM = 0 + PRINT*,' ' + PRINT *,' ERROR READING INDEX FILE ' + PRINT*,' ' + IRET=96 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/getlocal.f b/WPS/ungrib/src/ngl/g2/getlocal.f new file mode 100755 index 00000000..d82180ee --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getlocal.f @@ -0,0 +1,168 @@ + subroutine getlocal(cgrib,lcgrib,localnum,csec2,lcsec2,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getlocal +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-25 +! +! ABSTRACT: This subroutine returns the contents of Section 2 ( Local +! Use Section ) from a GRIB2 message. Since there can be multiple +! occurrences of Section 2 within a GRIB message, the calling routine +! indicates which occurrence is being requested with the localnum argument. +! +! PROGRAM HISTORY LOG: +! 2000-05-25 Gilbert +! +! USAGE: CALL getlocal(cgrib,lcgrib,localnum,csec2,lcsec2,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message in array cgrib. +! localnum - The nth occurrence of Section 2 requested. +! +! OUTPUT ARGUMENT LIST: +! csec2 - Character array containing information read from +! Section 2. +! The dimension of this array can be obtained in advance +! from argument maxlocal, which is returned from subroutine +! gb_info. +! lcsec2 - Number of bytes of character array csec2 read from +! Section 2. +! ierr - Error return code. +! 0 = no error +! 1 = Beginning characters "GRIB" not found. +! 2 = GRIB message is not Edition 2. +! 3 = The section 2 request number was not positive. +! 4 = End string "7777" found, but not where expected. +! 5 = End string "7777" not found at end of message. +! 6 = GRIB message did not contain the requested number of +! Local Use Sections. +! +! REMARKS: Note that subroutine gb_info can be used to first determine +! how many Local Use sections exist in a given GRIB message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib,localnum + character(len=1),intent(out) :: csec2(*) + integer,intent(out) :: lcsec2,ierr + + character(len=4),parameter :: grib='GRIB',c7777='7777' + character(len=4) :: ctemp + integer :: listsec0(2) + integer iofst,ibeg,istart,numlocal + + ierr=0 + numlocal=0 +! +! Check for valid request number +! + if (localnum.le.0) then + print *,'getlocal: Request for local section must be positive.' + ierr=3 + return + endif +! +! Check for beginning of GRIB message in the first 100 bytes +! + istart=0 + do j=1,100 + ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3) + if (ctemp.eq.grib ) then + istart=j + exit + endif + enddo + if (istart.eq.0) then + print *,'getlocal: Beginning characters GRIB not found.' + ierr=1 + return + endif +! +! Unpack Section 0 - Indicator Section +! + iofst=8*(istart+5) + call gbyte(cgrib,listsec0(1),iofst,8) ! Discipline + iofst=iofst+8 + call gbyte(cgrib,listsec0(2),iofst,8) ! GRIB edition number + iofst=iofst+8 + iofst=iofst+32 + call gbyte(cgrib,lengrib,iofst,32) ! Length of GRIB message + iofst=iofst+32 + lensec0=16 + ipos=istart+lensec0 +! +! Currently handles only GRIB Edition 2. +! + if (listsec0(2).ne.2) then + print *,'getlocal: can only decode GRIB edition 2.' + ierr=2 + return + endif +! +! Loop through the remaining sections keeping track of the +! length of each. Also check to see that if the current occurrence +! of Section 2 is the same as the one requested. +! + do + ! Check to see if we are at end of GRIB message + ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3) + if (ctemp.eq.c7777 ) then + ipos=ipos+4 + ! If end of GRIB message not where expected, issue error + if (ipos.ne.(istart+lengrib)) then + print *,'getlocal: "7777" found, but not where expected.' + ierr=4 + return + endif + exit + endif + ! Get length of Section and Section number + iofst=(ipos-1)*8 + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) ! Get Section number + iofst=iofst+8 + ! If found the requested occurrence of Section 2, + ! return the section contents. + if (isecnum.eq.2) then + numlocal=numlocal+1 + if (numlocal.eq.localnum) then + lcsec2=lensec-5 + csec2(1:lcsec2)=cgrib(ipos+5:ipos+lensec-1) + return + endif + endif + ! Check to see if we read pass the end of the GRIB + ! message and missed the terminator string '7777'. + ipos=ipos+lensec ! Update beginning of section pointer + if (ipos.gt.(istart+lengrib)) then + print *,'getlocal: "7777" not found at end of GRIB message.' + ierr=5 + return + endif + + enddo + +! +! If exited from above loop, the end of the GRIB message was reached +! before the requested occurrence of section 2 was found. +! + print *,'getlocal: GRIB message contained ',numlocal, + & ' local sections.' + print *,'getlocal: The request was for the ',localnum, + & ' occurrence.' + ierr=6 + + return + end + + + + + + + diff --git a/WPS/ungrib/src/ngl/g2/getpoly.f b/WPS/ungrib/src/ngl/g2/getpoly.f new file mode 100755 index 00000000..f8d22f3a --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/getpoly.f @@ -0,0 +1,80 @@ + subroutine getpoly(csec3,lcsec3,jj,kk,mm) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getpoly +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-12-11 +! +! ABSTRACT: This subroutine returns the J, K, and M pentagonal resolution +! parameters specified in a GRIB Grid Definition Section used +! spherical harmonic coefficients using GDT 5.50 through 5.53 +! +! PROGRAM HISTORY LOG: +! 2002-12-11 Gilbert +! +! USAGE: CALL getpoly(csec3,lcsec3,jj,kk,mm) +! INPUT ARGUMENT LIST: +! csec3 - Character array that contains the packed GRIB2 GDS +! lcsec3 - Length (in octets) of section 3 +! +! OUTPUT ARGUMENT LIST: +! JJ = J - pentagonal resolution parameter +! KK = K - pentagonal resolution parameter +! MM = M - pentagonal resolution parameter +! +! REMARKS: Returns JJ, KK, and MM set to zero, if grid template +! not recognized. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ +! use grib_mod + + character(len=1),intent(in) :: csec3(*) + integer,intent(in) :: lcsec3 + integer,intent(out) :: jj,kk,mm + + integer,pointer,dimension(:) :: igdstmpl,list_opt + integer :: igds(5) + integer iofst,igdtlen,num_opt,jerr + + interface + subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl, + & mapgridlen,ideflist,idefnum,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,pointer,dimension(:) :: igdstmpl,ideflist + integer,intent(out) :: igds(5) + integer,intent(out) :: ierr,idefnum + end subroutine gf_unpack3 + end interface + + nullify(igdstmpl,list_opt) + ! + iofst=0 ! set offset to beginning of section + call gf_unpack3(csec3,lcsec3,iofst,igds,igdstmpl, + & igdtlen,list_opt,num_opt,jerr) + if (jerr.eq.0) then + selectcase( igds(5) ) ! Template number + case (50:53) ! Spherical harmonic coefficients + jj=igdstmpl(1) + kk=igdstmpl(2) + mm=igdstmpl(3) + case default + jj=0 + kk=0 + mm=0 + end select + else + jj=0 + kk=0 + mm=0 + endif + ! + if (associated(igdstmpl)) deallocate(igdstmpl) + if (associated(list_opt)) deallocate(list_opt) + + return + end diff --git a/WPS/ungrib/src/ngl/g2/gettemplates.f b/WPS/ungrib/src/ngl/g2/gettemplates.f new file mode 100755 index 00000000..d421a1af --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gettemplates.f @@ -0,0 +1,244 @@ + subroutine gettemplates(cgrib,lcgrib,ifldnum,igds,igdstmpl, + & igdslen,ideflist,idefnum,ipdsnum,ipdstmpl, + & ipdslen,coordlist,numcoord,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gettemplates +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine returns the Grid Definition, and +! Product Definition for a given data +! field. Since there can be multiple data fields packed into a GRIB2 +! message, the calling routine indicates which field is being requested +! with the ifldnum argument. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! +! USAGE: CALL gettemplates(cgrib,lcgrib,ifldnum,igds,igdstmpl,igdslen, +! & ideflist,idefnum,ipdsnum,ipdstmpl,ipdslen, +! & coordlist,numcoord,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! ifldnum - Specifies which field in the GRIB2 message to return. +! +! OUTPUT ARGUMENT LIST: +! igds - Contains information read from the appropriate GRIB Grid +! Definition Section 3 for the field being returned. +! Must be dimensioned >= 5. +! igds(1)=Source of grid definition (see Code Table 3.0) +! igds(2)=Number of grid points in the defined grid. +! igds(3)=Number of octets needed for each +! additional grid points definition. +! Used to define number of +! points in each row ( or column ) for +! non-regular grids. +! = 0, if using regular grid. +! igds(4)=Interpretation of list for optional points +! definition. (Code Table 3.11) +! igds(5)=Grid Definition Template Number (Code Table 3.1) +! igdstmpl - Contains the data values for the specified Grid Definition +! Template ( NN=igds(5) ). Each element of this integer +! array contains an entry (in the order specified) of Grid +! Defintion Template 3.NN +! A safe dimension for this array can be obtained in advance +! from maxvals(2), which is returned from subroutine gribinfo. +! igdslen - Number of elements in igdstmpl(). i.e. number of entries +! in Grid Defintion Template 3.NN ( NN=igds(5) ). +! ideflist - (Used if igds(3) .ne. 0) This array contains the +! number of grid points contained in each row ( or column ). +! (part of Section 3) +! A safe dimension for this array can be obtained in advance +! from maxvals(3), which is returned from subroutine gribinfo. +! idefnum - (Used if igds(3) .ne. 0) The number of entries +! in array ideflist. i.e. number of rows ( or columns ) +! for which optional grid points are defined. +! ipdsnum - Product Definition Template Number ( see Code Table 4.0) +! ipdstmpl - Contains the data values for the specified Product Definition +! Template ( N=ipdsnum ). Each element of this integer +! array contains an entry (in the order specified) of Product +! Defintion Template 4.N +! A safe dimension for this array can be obtained in advance +! from maxvals(4), which is returned from subroutine gribinfo. +! ipdslen - Number of elements in ipdstmpl(). i.e. number of entries +! in Product Defintion Template 4.N ( N=ipdsnum ). +! coordlist- Array containg floating point values intended to document +! the vertical discretisation associated to model data +! on hybrid coordinate vertical levels. (part of Section 4) +! The dimension of this array can be obtained in advance +! from maxvals(5), which is returned from subroutine gribinfo. +! numcoord - number of values in array coordlist. +! ierr - Error return code. +! 0 = no error +! 1 = Beginning characters "GRIB" not found. +! 2 = GRIB message is not Edition 2. +! 3 = The data field request number was not positive. +! 4 = End string "7777" found, but not where expected. +! 6 = GRIB message did not contain the requested number of +! data fields. +! 7 = End string "7777" not found at end of message. +! 10 = Error unpacking Section 3. +! 11 = Error unpacking Section 4. +! +! REMARKS: Note that subroutine gribinfo can be used to first determine +! how many data fields exist in the given GRIB message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib,ifldnum + integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*) + integer,intent(out) :: ipdsnum,ipdstmpl(*) + integer,intent(out) :: idefnum,numcoord + integer,intent(out) :: ierr + real,intent(out) :: coordlist(*) + + character(len=4),parameter :: grib='GRIB',c7777='7777' + character(len=4) :: ctemp + integer:: listsec0(2) + integer iofst,ibeg,istart + logical have3,have4 + + have3=.false. + have4=.false. + ierr=0 + numfld=0 +! +! Check for valid request number +! + if (ifldnum.le.0) then + print *,'gettemplates: Request for field number must be ', + & 'positive.' + ierr=3 + return + endif +! +! Check for beginning of GRIB message in the first 100 bytes +! + istart=0 + do j=1,100 + ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3) + if (ctemp.eq.grib ) then + istart=j + exit + endif + enddo + if (istart.eq.0) then + print *,'gettemplates: Beginning characters GRIB not found.' + ierr=1 + return + endif +! +! Unpack Section 0 - Indicator Section +! + iofst=8*(istart+5) + call gbyte(cgrib,listsec0(1),iofst,8) ! Discipline + iofst=iofst+8 + call gbyte(cgrib,listsec0(2),iofst,8) ! GRIB edition number + iofst=iofst+8 + iofst=iofst+32 + call gbyte(cgrib,lengrib,iofst,32) ! Length of GRIB message + iofst=iofst+32 + lensec0=16 + ipos=istart+lensec0 +! +! Currently handles only GRIB Edition 2. +! + if (listsec0(2).ne.2) then + print *,'gettemplates: can only decode GRIB edition 2.' + ierr=2 + return + endif +! +! Loop through the remaining sections keeping track of the +! length of each. Also keep the latest Grid Definition Section info. +! Unpack the requested field number. +! + do + ! Check to see if we are at end of GRIB message + ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3) + if (ctemp.eq.c7777 ) then + ipos=ipos+4 + ! If end of GRIB message not where expected, issue error + if (ipos.ne.(istart+lengrib)) then + print *,'gettemplates: "7777" found, but not where ', + & 'expected.' + ierr=4 + return + endif + exit + endif + ! Get length of Section and Section number + iofst=(ipos-1)*8 + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) ! Get Section number + iofst=iofst+8 + !print *,' lensec= ',lensec,' secnum= ',isecnum + ! + ! If found Section 3, unpack the GDS info using the + ! appropriate template. Save in case this is the latest + ! grid before the requested field. + ! + if (isecnum.eq.3) then + iofst=iofst-40 ! reset offset to beginning of section + call unpack3(cgrib,lcgrib,iofst,igds,igdstmpl,igdslen, + & ideflist,idefnum,jerr) + if (jerr.eq.0) then + have3=.true. + else + ierr=10 + return + endif + endif + ! + ! If found Section 4, check to see if this field is the + ! one requested. + ! + if (isecnum.eq.4) then + numfld=numfld+1 + if (numfld.eq.ifldnum) then + iofst=iofst-40 ! reset offset to beginning of section + call unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,ipdslen, + & coordlist,numcoord,jerr) + if (jerr.eq.0) then + have4=.true. + else + ierr=11 + return + endif + endif + endif + ! + ! Check to see if we read pass the end of the GRIB + ! message and missed the terminator string '7777'. + ! + ipos=ipos+lensec ! Update beginning of section pointer + if (ipos.gt.(istart+lengrib)) then + print *,'gettemplates: "7777" not found at end of GRIB ', + & 'message.' + ierr=7 + return + endif + + if (have3.and.have4) return + + enddo + +! +! If exited from above loop, the end of the GRIB message was reached +! before the requested field was found. +! + print *,'gettemplates: GRIB message contained ',numlocal, + & ' different fields.' + print *,'gettemplates: The request was for the ',ifldnum, + & ' field.' + ierr=6 + + return + end diff --git a/WPS/ungrib/src/ngl/g2/gf_free.f b/WPS/ungrib/src/ngl/g2/gf_free.f new file mode 100755 index 00000000..0cdcb316 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gf_free.f @@ -0,0 +1,202 @@ + subroutine gf_free(gfld) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gf_free +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine frees up memory that was used to store +! array values in derived type gribfield. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! 2012-12-11 Vuong Initialize an undefine pointers +! 2015-10-29 Vuong Deallocate pointers in derived type gribfield +! +! USAGE: CALL gf_free(gfld) +! INPUT ARGUMENT LIST: +! gfld - derived type gribfield ( defined in module grib_mod ) +! +! OUTPUT ARGUMENT LIST: +! gfld - derived type gribfield ( defined in module grib_mod ) +! gfld%version = GRIB edition number +! gfld%discipline = Message Discipline ( see Code Table 0.0 ) +! gfld%idsect() = Contains the entries in the Identification +! Section ( Section 1 ) +! This element is actually a pointer to an array +! that holds the data. +! gfld%idsect(1) = Identification of originating Centre +! ( see Common Code Table C-1 ) +! gfld%idsect(2) = Identification of originating Sub-centre +! gfld%idsect(3) = GRIB Master Tables Version Number +! ( see Code Table 1.0 ) +! gfld%idsect(4) = GRIB Local Tables Version Number +! ( see Code Table 1.1 ) +! gfld%idsect(5) = Significance of Reference Time (Code Table 1.2) +! gfld%idsect(6) = Year ( 4 digits ) +! gfld%idsect(7) = Month +! gfld%idsect(8) = Day +! gfld%idsect(9) = Hour +! gfld%idsect(10) = Minute +! gfld%idsect(11) = Second +! gfld%idsect(12) = Production status of processed data +! ( see Code Table 1.3 ) +! gfld%idsect(13) = Type of processed data ( see Code Table 1.4 ) +! gfld%idsectlen = Number of elements in gfld%idsect(). +! gfld%local() = Pointer to character array containing contents +! of Local Section 2, if included +! gfld%locallen = length of array gfld%local() +! gfld%ifldnum = field number within GRIB message +! gfld%griddef = Source of grid definition (see Code Table 3.0) +! gfld%ngrdpts = Number of grid points in the defined grid. +! gfld%numoct_opt = Number of octets needed for each +! additional grid points definition. +! Used to define number of +! points in each row ( or column ) for +! non-regular grids. +! = 0, if using regular grid. +! gfld%interp_opt = Interpretation of list for optional points +! definition. (Code Table 3.11) +! gfld%igdtnum = Grid Definition Template Number (Code Table 3.1) +! gfld%igdtmpl() = Contains the data values for the specified Grid +! Definition Template ( NN=gfld%igdtnum ). Each +! element of this integer array contains an entry (in +! the order specified) of Grid Defintion Template 3.NN +! This element is actually a pointer to an array +! that holds the data. +! gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of +! entries in Grid Defintion Template 3.NN +! ( NN=gfld%igdtnum ). +! gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array +! contains the number of grid points contained in +! each row ( or column ). (part of Section 3) +! This element is actually a pointer to an array +! that holds the data. This pointer is nullified +! if gfld%numoct_opt=0. +! gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries +! in array ideflist. i.e. number of rows ( or columns ) +! for which optional grid points are defined. This value +! is set to zero, if gfld%numoct_opt=0. +! gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0) +! gfld%ipdtmpl() = Contains the data values for the specified Product +! Definition Template ( N=gfdl%ipdtnum ). Each element +! of this integer array contains an entry (in the +! order specified) of Product Defintion Template 4.N. +! This element is actually a pointer to an array +! that holds the data. +! gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of +! entries in Product Defintion Template 4.N +! ( N=gfdl%ipdtnum ). +! gfld%coord_list() = Real array containing floating point values +! intended to document the vertical discretisation +! associated to model data on hybrid coordinate +! vertical levels. (part of Section 4) +! This element is actually a pointer to an array +! that holds the data. +! gfld%num_coord = number of values in array gfld%coord_list(). +! gfld%ndpts = Number of data points unpacked and returned. +! gfld%idrtnum = Data Representation Template Number +! ( see Code Table 5.0) +! gfld%idrtmpl() = Contains the data values for the specified Data +! Representation Template ( N=gfld%idrtnum ). Each +! element of this integer array contains an entry +! (in the order specified) of Product Defintion +! Template 5.N. +! This element is actually a pointer to an array +! that holds the data. +! gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number +! of entries in Data Representation Template 5.N +! ( N=gfld%idrtnum ). +! gfld%unpacked = logical value indicating whether the bitmap and +! data values were unpacked. If false, gfld%ndpts +! is set to zero, and gfld%bmap and gfld%fld +! pointers are nullified. +! gfld%ibmap = Bitmap indicator ( see Code Table 6.0 ) +! 0 = bitmap applies and is included in Section 6. +! 1-253 = Predefined bitmap applies +! 254 = Previously defined bitmap applies to this field +! 255 = Bit map does not apply to this product. +! gfld%bmap() - Logical*1 array containing decoded bitmap, +! if ibmap=0 or ibap=254. Otherwise nullified. +! This element is actually a pointer to an array +! that holds the data. +! gfld%fld() = Array of gfld%ndpts unpacked data points. +! This element is actually a pointer to an array +! that holds the data. +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + use grib_mod + + type(gribfield) :: gfld + + if (associated(gfld%idsect)) then + deallocate(gfld%idsect) + !deallocate(gfld%idsect,stat=is) + !print *,'gfld%idsect: ',is + endif + nullify(gfld%idsect) + + if (associated(gfld%local)) then + !deallocate(gfld%local) + !deallocate(gfld%local,stat=is) +! print *,'WPS devel team - skipping deallocate - FIX THIS' + !print *,'gfld%local: ',is + endif + nullify(gfld%local) + + if (associated(gfld%list_opt)) then + deallocate(gfld%list_opt) + !deallocate(gfld%list_opt,stat=is) + !print *,'gfld%list_opt: ',is + endif + nullify(gfld%list_opt) + + if (associated(gfld%igdtmpl)) then + deallocate(gfld%igdtmpl) + !deallocate(gfld%igdtmpl,stat=is) + !print *,'gfld%igdtmpl: ',is + endif + nullify(gfld%igdtmpl) + + if (associated(gfld%ipdtmpl)) then + deallocate(gfld%ipdtmpl) + !deallocate(gfld%ipdtmpl,stat=is) + !print *,'gfld%ipdtmpl: ',is + endif + nullify(gfld%ipdtmpl) + + if (associated(gfld%coord_list)) then + deallocate(gfld%coord_list) + !deallocate(gfld%coord_list,stat=is) + !print *,'gfld%coord_list: ',is + endif + nullify(gfld%coord_list) + + if (associated(gfld%idrtmpl)) then + deallocate(gfld%idrtmpl) + !deallocate(gfld%idrtmpl,stat=is) + !print *,'gfld%idrtmpl: ',is + endif + nullify(gfld%idrtmpl) + + if (associated(gfld%bmap)) then + deallocate(gfld%bmap) + !deallocate(gfld%bmap,stat=is) + !print *,'gfld%bmap: ',is + endif + nullify(gfld%bmap) + + if (associated(gfld%fld)) then + deallocate(gfld%fld) + !deallocate(gfld%fld,stat=is) + !print *,'gfld%fld: ',is + endif + nullify(gfld%fld) + + return + end diff --git a/WPS/ungrib/src/ngl/g2/gf_getfld.f b/WPS/ungrib/src/ngl/g2/gf_getfld.f new file mode 100755 index 00000000..6e77070b --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gf_getfld.f @@ -0,0 +1,603 @@ + subroutine gf_getfld(cgrib,lcgrib,ifldnum,unpack,expand,gfld,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gf_getfld +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine returns the Grid Definition, Product Definition, +! Bit-map ( if applicable ), and the unpacked data for a given data +! field. All of the information returned is stored in a derived +! type variable, gfld. Gfld is of type gribfield, which is defined +! in module grib_mod, so users of this routine will need to include +! the line "USE GRIB_MOD" in their calling routine. Each component of the +! gribfield type is described in the OUTPUT ARGUMENT LIST section below. +! +! Since there can be multiple data fields packed into a GRIB2 +! message, the calling routine indicates which field is being requested +! with the ifldnum argument. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! 2002-01-24 Gilbert - Changed to pass back derived type gribfield +! variable through argument list, instead of +! having many different arguments. +! 2004-05-20 Gilbert - Added check to see if previous a bit-map is specified, +! but none was found. +! 2015-10-29 Vuong - Initial all pointers in derive type gribfield +! +! USAGE: CALL gf_getfld(cgrib,lcgrib,ifldnum,unpack,expand,gfld,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! ifldnum - Specifies which field in the GRIB2 message to return. +! unpack - Logical value indicating whether to unpack bitmap/data +! .true. = unpack bitmap and data values +! .false. = do not unpack bitmap and data values +! expand - Boolean value indicating whether the data points should be +! expanded to the correspond grid, if a bit-map is present. +! 1 = if possible, expand data field to grid, inserting zero +! values at gridpoints that are bitmapped out. +! (SEE REMARKS2) +! 0 = do not expand data field, leaving it an array of +! consecutive data points for each "1" in the bitmap. +! This argument is ignored if unpack == 0 OR if the +! returned field does not contain a bit-map. +! +! OUTPUT ARGUMENT LIST: +! gfld - derived type gribfield ( defined in module grib_mod ) +! ( NOTE: See Remarks Section ) +! gfld%version = GRIB edition number ( currently 2 ) +! gfld%discipline = Message Discipline ( see Code Table 0.0 ) +! gfld%idsect() = Contains the entries in the Identification +! Section ( Section 1 ) +! This element is actually a pointer to an array +! that holds the data. +! gfld%idsect(1) = Identification of originating Centre +! ( see Common Code Table C-1 ) +! 7 - US National Weather Service +! gfld%idsect(2) = Identification of originating Sub-centre +! gfld%idsect(3) = GRIB Master Tables Version Number +! ( see Code Table 1.0 ) +! 0 - Experimental +! 1 - Initial operational version number +! gfld%idsect(4) = GRIB Local Tables Version Number +! ( see Code Table 1.1 ) +! 0 - Local tables not used +! 1-254 - Number of local tables version used +! gfld%idsect(5) = Significance of Reference Time (Code Table 1.2) +! 0 - Analysis +! 1 - Start of forecast +! 2 - Verifying time of forecast +! 3 - Observation time +! gfld%idsect(6) = Year ( 4 digits ) +! gfld%idsect(7) = Month +! gfld%idsect(8) = Day +! gfld%idsect(9) = Hour +! gfld%idsect(10) = Minute +! gfld%idsect(11) = Second +! gfld%idsect(12) = Production status of processed data +! ( see Code Table 1.3 ) +! 0 - Operational products +! 1 - Operational test products +! 2 - Research products +! 3 - Re-analysis products +! gfld%idsect(13) = Type of processed data ( see Code Table 1.4 ) +! 0 - Analysis products +! 1 - Forecast products +! 2 - Analysis and forecast products +! 3 - Control forecast products +! 4 - Perturbed forecast products +! 5 - Control and perturbed forecast products +! 6 - Processed satellite observations +! 7 - Processed radar observations +! gfld%idsectlen = Number of elements in gfld%idsect(). +! gfld%local() = Pointer to character array containing contents +! of Local Section 2, if included +! gfld%locallen = length of array gfld%local() +! gfld%ifldnum = field number within GRIB message +! gfld%griddef = Source of grid definition (see Code Table 3.0) +! 0 - Specified in Code table 3.1 +! 1 - Predetermined grid Defined by originating centre +! gfld%ngrdpts = Number of grid points in the defined grid. +! gfld%numoct_opt = Number of octets needed for each +! additional grid points definition. +! Used to define number of +! points in each row ( or column ) for +! non-regular grids. +! = 0, if using regular grid. +! gfld%interp_opt = Interpretation of list for optional points +! definition. (Code Table 3.11) +! gfld%igdtnum = Grid Definition Template Number (Code Table 3.1) +! gfld%igdtmpl() = Contains the data values for the specified Grid +! Definition Template ( NN=gfld%igdtnum ). Each +! element of this integer array contains an entry (in +! the order specified) of Grid Defintion Template 3.NN +! This element is actually a pointer to an array +! that holds the data. +! gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of +! entries in Grid Defintion Template 3.NN +! ( NN=gfld%igdtnum ). +! gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array +! contains the number of grid points contained in +! each row ( or column ). (part of Section 3) +! This element is actually a pointer to an array +! that holds the data. This pointer is nullified +! if gfld%numoct_opt=0. +! gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries +! in array ideflist. i.e. number of rows ( or columns ) +! for which optional grid points are defined. This value +! is set to zero, if gfld%numoct_opt=0. +! gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0) +! gfld%ipdtmpl() = Contains the data values for the specified Product +! Definition Template ( N=gfdl%ipdtnum ). Each element +! of this integer array contains an entry (in the +! order specified) of Product Defintion Template 4.N. +! This element is actually a pointer to an array +! that holds the data. +! gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of +! entries in Product Defintion Template 4.N +! ( N=gfdl%ipdtnum ). +! gfld%coord_list() = Real array containing floating point values +! intended to document the vertical discretisation +! associated to model data on hybrid coordinate +! vertical levels. (part of Section 4) +! This element is actually a pointer to an array +! that holds the data. +! gfld%num_coord = number of values in array gfld%coord_list(). +! gfld%ndpts = Number of data points unpacked and returned. +! gfld%idrtnum = Data Representation Template Number +! ( see Code Table 5.0) +! gfld%idrtmpl() = Contains the data values for the specified Data +! Representation Template ( N=gfld%idrtnum ). Each +! element of this integer array contains an entry +! (in the order specified) of Product Defintion +! Template 5.N. +! This element is actually a pointer to an array +! that holds the data. +! gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number +! of entries in Data Representation Template 5.N +! ( N=gfld%idrtnum ). +! gfld%unpacked = logical value indicating whether the bitmap and +! data values were unpacked. If false, +! gfld%bmap and gfld%fld pointers are nullified. +! gfld%expanded = Logical value indicating whether the data field +! was expanded to the grid in the case where a +! bit-map is present. If true, the data points in +! gfld%fld match the grid points and zeros were +! inserted at grid points where data was bit-mapped +! out. If false, the data values in gfld%fld were +! not expanded to the grid and are just a consecutive +! array of data points corresponding to each value of +! "1" in gfld%bmap. +! gfld%ibmap = Bitmap indicator ( see Code Table 6.0 ) +! 0 = bitmap applies and is included in Section 6. +! 1-253 = Predefined bitmap applies +! 254 = Previously defined bitmap applies to this field +! 255 = Bit map does not apply to this product. +! gfld%bmap() = Logical*1 array containing decoded bitmap, +! if ibmap=0 or ibap=254. Otherwise nullified. +! This element is actually a pointer to an array +! that holds the data. +! gfld%fld() = Array of gfld%ndpts unpacked data points. +! This element is actually a pointer to an array +! that holds the data. +! ierr - Error return code. +! 0 = no error +! 1 = Beginning characters "GRIB" not found. +! 2 = GRIB message is not Edition 2. +! 3 = The data field request number was not positive. +! 4 = End string "7777" found, but not where expected. +! 6 = GRIB message did not contain the requested number of +! data fields. +! 7 = End string "7777" not found at end of message. +! 8 = Unrecognized Section encountered. +! 9 = Data Representation Template 5.NN not yet implemented. +! 15 = Error unpacking Section 1. +! 16 = Error unpacking Section 2. +! 10 = Error unpacking Section 3. +! 11 = Error unpacking Section 4. +! 12 = Error unpacking Section 5. +! 13 = Error unpacking Section 6. +! 14 = Error unpacking Section 7. +! 17 = Previous bitmap specified, but none exists. +! +! REMARKS: Note that derived type gribfield contains pointers to many +! arrays of data. The memory for these arrays is allocated +! when the values in the arrays are set, to help minimize +! problems with array overloading. Because of this users +! are encouraged to free up this memory, when it is no longer +! needed, by an explicit call to subroutine gf_free. +! ( i.e. CALL GF_FREE(GFLD) ) +! +! Subroutine gb_info can be used to first determine +! how many data fields exist in a given GRIB message. +! +! REMARKS2: It may not always be possible to expand a bit-mapped data field. +! If a pre-defined bit-map is used and not included in the GRIB2 +! message itself, this routine would not have the necessary +! information to expand the data. In this case, gfld%expanded would +! would be set to 0 (false), regardless of the value of input +! argument expand. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + use grib_mod + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib,ifldnum + logical,intent(in) :: unpack,expand + type(gribfield),intent(out) :: gfld + integer,intent(out) :: ierr +! integer,intent(out) :: igds(*),igdstmpl(*),ideflist(*) +! integer,intent(out) :: ipdsnum,ipdstmpl(*) +! integer,intent(out) :: idrsnum,idrstmpl(*) +! integer,intent(out) :: ndpts,ibmap,idefnum,numcoord +! logical*1,intent(out) :: bmap(*) +! real,intent(out) :: fld(*),coordlist(*) + + character(len=4),parameter :: grib='GRIB',c7777='7777' + character(len=4) :: ctemp + real,pointer,dimension(:) :: newfld + integer:: listsec0(2),igds(5) + integer iofst,ibeg,istart + integer(4) :: ieee + logical*1,pointer,dimension(:) :: bmpsave + logical have3,have4,have5,have6,have7 + + interface + subroutine gf_unpack1(cgrib,lcgrib,iofst,ids,idslen,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,pointer,dimension(:) :: ids + integer,intent(out) :: ierr,idslen + end subroutine gf_unpack1 + subroutine gf_unpack2(cgrib,lcgrib,iofst,lencsec2,csec2,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,intent(out) :: lencsec2 + integer,intent(out) :: ierr + character(len=1),pointer,dimension(:) :: csec2 + end subroutine gf_unpack2 + subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl, + & mapgridlen,ideflist,idefnum,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,pointer,dimension(:) :: igdstmpl,ideflist + integer,intent(out) :: igds(5) + integer,intent(out) :: ierr,idefnum + end subroutine gf_unpack3 + subroutine gf_unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl, + & mappdslen,coordlist,numcoord,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + real,pointer,dimension(:) :: coordlist + integer,pointer,dimension(:) :: ipdstmpl + integer,intent(out) :: ipdsnum + integer,intent(out) :: ierr,numcoord + end subroutine gf_unpack4 + subroutine gf_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum, + & idrstmpl,mapdrslen,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,intent(out) :: ndpts,idrsnum + integer,pointer,dimension(:) :: idrstmpl + integer,intent(out) :: ierr + end subroutine gf_unpack5 + subroutine gf_unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib,ngpts + integer,intent(inout) :: iofst + integer,intent(out) :: ibmap + integer,intent(out) :: ierr + logical*1,pointer,dimension(:) :: bmap + end subroutine gf_unpack6 + subroutine gf_unpack7(cgrib,lcgrib,iofst,igdsnum,igdstmpl, + & idrsnum,idrstmpl,ndpts,fld,ierr) + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib,ndpts,idrsnum,igdsnum + integer,intent(inout) :: iofst + integer,pointer,dimension(:) :: idrstmpl,igdstmpl + integer,intent(out) :: ierr + real,pointer,dimension(:) :: fld + end subroutine gf_unpack7 + end interface + + have3=.false. + have4=.false. + have5=.false. + have6=.false. + have7=.false. + ierr=0 + numfld=0 + gfld%locallen=0 + nullify(gfld%list_opt,gfld%igdtmpl,gfld%ipdtmpl) + nullify(gfld%coord_list,gfld%idrtmpl,gfld%bmap,gfld%fld) +! +! Check for valid request number +! + if (ifldnum.le.0) then + print *,'gf_getfld: Request for field number must be positive.' + ierr=3 + return + endif +! +! Check for beginning of GRIB message in the first 100 bytes +! + istart=0 + do j=1,100 + ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3) + if (ctemp.eq.grib ) then + istart=j + exit + endif + enddo + if (istart.eq.0) then + print *,'gf_getfld: Beginning characters GRIB not found.' + ierr=1 + return + endif +! +! Unpack Section 0 - Indicator Section +! + iofst=8*(istart+5) + call gbyte(cgrib,listsec0(1),iofst,8) ! Discipline + iofst=iofst+8 + call gbyte(cgrib,listsec0(2),iofst,8) ! GRIB edition number + iofst=iofst+8 + iofst=iofst+32 + call gbyte(cgrib,lengrib,iofst,32) ! Length of GRIB message + iofst=iofst+32 + lensec0=16 + ipos=istart+lensec0 +! +! Currently handles only GRIB Edition 2. +! + if (listsec0(2).ne.2) then + print *,'gf_getfld: can only decode GRIB edition 2.' + ierr=2 + return + endif +! +! Loop through the remaining sections keeping track of the +! length of each. Also keep the latest Grid Definition Section info. +! Unpack the requested field number. +! + do + ! Check to see if we are at end of GRIB message + ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3) + if (ctemp.eq.c7777 ) then + ipos=ipos+4 + ! If end of GRIB message not where expected, issue error + if (ipos.ne.(istart+lengrib)) then + print *,'gf_getfld: "7777" found, but not where expected.' + ierr=4 + return + endif + exit + endif + ! Get length of Section and Section number + iofst=(ipos-1)*8 + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) ! Get Section number + iofst=iofst+8 + !print *,' lensec= ',lensec,' secnum= ',isecnum + ! + ! Check to see if section number is valid + ! + if ( (isecnum.lt.1).OR.(isecnum.gt.7) ) then + print *,'gf_getfld: Unrecognized Section Encountered=',isecnum + ierr=8 + return + endif + ! + ! If found Section 1, decode elements in Identification Section + ! + if (isecnum.eq.1) then + iofst=iofst-40 ! reset offset to beginning of section + call gf_unpack1(cgrib,lcgrib,iofst,gfld%idsect, + & gfld%idsectlen,jerr) + if (jerr.ne.0) then + ierr=15 + return + endif + endif + ! + ! If found Section 2, Grab local section + ! Save in case this is the latest one before the requested field. + ! + if (isecnum.eq.2) then + iofst=iofst-40 ! reset offset to beginning of section + if (associated(gfld%local)) deallocate(gfld%local) + call gf_unpack2(cgrib,lcgrib,iofst,gfld%locallen, + & gfld%local,jerr) + if (jerr.ne.0) then + ierr=16 + return + endif + endif + ! + ! If found Section 3, unpack the GDS info using the + ! appropriate template. Save in case this is the latest + ! grid before the requested field. + ! + if (isecnum.eq.3) then + iofst=iofst-40 ! reset offset to beginning of section + if (associated(gfld%igdtmpl)) deallocate(gfld%igdtmpl) + if (associated(gfld%list_opt)) deallocate(gfld%list_opt) + call gf_unpack3(cgrib,lcgrib,iofst,igds,gfld%igdtmpl, + & gfld%igdtlen,gfld%list_opt,gfld%num_opt,jerr) + if (jerr.eq.0) then + have3=.true. + gfld%griddef=igds(1) + gfld%ngrdpts=igds(2) + gfld%numoct_opt=igds(3) + gfld%interp_opt=igds(4) + gfld%igdtnum=igds(5) + else + ierr=10 + return + endif + endif + ! + ! If found Section 4, check to see if this field is the + ! one requested. + ! + if (isecnum.eq.4) then + numfld=numfld+1 + if (numfld.eq.ifldnum) then + gfld%discipline=listsec0(1) + gfld%version=listsec0(2) + gfld%ifldnum=ifldnum + gfld%unpacked=unpack + gfld%expanded=.false. + iofst=iofst-40 ! reset offset to beginning of section + call gf_unpack4(cgrib,lcgrib,iofst,gfld%ipdtnum, + & gfld%ipdtmpl,gfld%ipdtlen,gfld%coord_list, + & gfld%num_coord,jerr) + if (jerr.eq.0) then + have4=.true. + else + ierr=11 + return + endif + endif + endif + ! + ! If found Section 5, check to see if this field is the + ! one requested. + ! + if ((isecnum.eq.5).and.(numfld.eq.ifldnum)) then + iofst=iofst-40 ! reset offset to beginning of section + call gf_unpack5(cgrib,lcgrib,iofst,gfld%ndpts,gfld%idrtnum, + & gfld%idrtmpl,gfld%idrtlen,jerr) + if (jerr.eq.0) then + have5=.true. + else + ierr=12 + return + endif + endif + ! + ! If found Section 6, Unpack bitmap. + ! Save in case this is the latest + ! bitmap before the requested field. + ! + if (isecnum.eq.6) then + if (unpack) then ! unpack bitmap + iofst=iofst-40 ! reset offset to beginning of section + bmpsave=>gfld%bmap ! save pointer to previous bitmap + call gf_unpack6(cgrib,lcgrib,iofst,gfld%ngrdpts,gfld%ibmap, + & gfld%bmap,jerr) + if (jerr.eq.0) then + have6=.true. + if (gfld%ibmap .eq. 254) then ! use previously specified bitmap + if ( associated(bmpsave) ) then + gfld%bmap=>bmpsave + else + print *,'gf_getfld: Previous bit-map specified,', + & ' but none exists,' + ierr=17 + return + endif + else ! get rid of it + if ( associated(bmpsave) ) deallocate(bmpsave) + endif + else + ierr=13 + return + endif + else ! do not unpack bitmap + call gbyte(cgrib,gfld%ibmap,iofst,8) ! Get BitMap Indicator + have6=.true. + endif + endif + ! + ! If found Section 7, check to see if this field is the + ! one requested. + ! + if ((isecnum.eq.7).and.(numfld.eq.ifldnum).and.unpack) then + iofst=iofst-40 ! reset offset to beginning of section + call gf_unpack7(cgrib,lcgrib,iofst,gfld%igdtnum, + & gfld%igdtmpl,gfld%idrtnum, + & gfld%idrtmpl,gfld%ndpts, + & gfld%fld,jerr) + if (jerr.eq.0) then + have7=.true. + ! If bitmap is used with this field, expand data field + ! to grid, if possible. + if ( gfld%ibmap .ne. 255 .AND. associated(gfld%bmap) ) then + if ( expand ) then + allocate(newfld(gfld%ngrdpts)) + !newfld(1:gfld%ngrdpts)=0.0 + !newfld=unpack(gfld%fld,gfld%bmap,newfld) + n=1 + do j=1,gfld%ngrdpts + if ( gfld%bmap(j) ) then + newfld(j)=gfld%fld(n) + n=n+1 + else + newfld(j)=0.0 + endif + enddo + deallocate(gfld%fld); + gfld%fld=>newfld; + gfld%expanded=.true. + else + gfld%expanded=.false. + endif + else + gfld%expanded=.true. + endif + else + print *,'gf_getfld: return from gf_unpack7 = ',jerr + ierr=14 + return + endif + endif + ! + ! Check to see if we read pass the end of the GRIB + ! message and missed the terminator string '7777'. + ! + ipos=ipos+lensec ! Update beginning of section pointer + if (ipos.gt.(istart+lengrib)) then + print *,'gf_getfld: "7777" not found at end of GRIB message.' + ierr=7 + return + endif + ! + ! If unpacking requested, return when all sections have been + ! processed + ! + if (unpack.and.have3.and.have4.and.have5.and.have6.and.have7) + & return + ! + ! If unpacking is not requested, return when sections + ! 3 through 6 have been processed + ! + if ((.NOT.unpack).and.have3.and.have4.and.have5.and.have6) + & return + + enddo + +! +! If exited from above loop, the end of the GRIB message was reached +! before the requested field was found. +! + print *,'gf_getfld: GRIB message contained ',numlocal, + & ' different fields.' + print *,'gf_getfld: The request was for the ',ifldnum, + & ' field.' + ierr=6 + + return + end + diff --git a/WPS/ungrib/src/ngl/g2/gf_unpack1.f b/WPS/ungrib/src/ngl/g2/gf_unpack1.f new file mode 100755 index 00000000..9b3cb1bf --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gf_unpack1.f @@ -0,0 +1,93 @@ + subroutine gf_unpack1(cgrib,lcgrib,iofst,ids,idslen,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gf_unpack1 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine unpacks Section 1 (Identification Section) +! starting at octet 6 of that Section. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! 2002-01-24 Gilbert - Changed to dynamically allocate arrays +! and to pass pointers to those arrays through +! the argument list. +! +! USAGE: CALL gf_unpack1(cgrib,lcgrib,iofst,ids,idslen,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array containing Section 1 of the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! iofst - Bit offset of the beginning of Section 1. +! +! OUTPUT ARGUMENT LIST: +! iofst - Bit offset at the end of Section 1, returned. +! ids - Pointer to integer array containing information read from +! Section 1, the Identification section. +! ids(1) = Identification of originating Centre +! ( see Common Code Table C-1 ) +! ids(2) = Identification of originating Sub-centre +! ids(3) = GRIB Master Tables Version Number +! ( see Code Table 1.0 ) +! ids(4) = GRIB Local Tables Version Number +! ( see Code Table 1.1 ) +! ids(5) = Significance of Reference Time (Code Table 1.2) +! ids(6) = Year ( 4 digits ) +! ids(7) = Month +! ids(8) = Day +! ids(9) = Hour +! ids(10) = Minute +! ids(11) = Second +! ids(12) = Production status of processed data +! ( see Code Table 1.3 ) +! ids(13) = Type of processed data ( see Code Table 1.4 ) +! idslen - Number of elements in ids(). +! ierr - Error return code. +! 0 = no error +! 6 = memory allocation error +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,pointer,dimension(:) :: ids + integer,intent(out) :: ierr,idslen + + integer,dimension(:) :: mapid(13) + + data mapid /2,2,1,1,1,2,1,1,1,1,1,1,1/ + + ierr=0 + idslen=13 + nullify(ids) + + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + iofst=iofst+8 ! skip section number + ! + ! Unpack each value into array ids from the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mapid. + ! + istat=0 + allocate(ids(idslen),stat=istat) + if (istat.ne.0) then + ierr=6 + nullify(ids) + return + endif + + do i=1,idslen + nbits=mapid(i)*8 + call gbyte(cgrib,ids(i),iofst,nbits) + iofst=iofst+nbits + enddo + + return ! End of Section 1 processing + end diff --git a/WPS/ungrib/src/ngl/g2/gf_unpack2.f b/WPS/ungrib/src/ngl/g2/gf_unpack2.f new file mode 100755 index 00000000..6a18b5f7 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gf_unpack2.f @@ -0,0 +1,72 @@ + subroutine gf_unpack2(cgrib,lcgrib,iofst,lencsec2,csec2,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gf_unpack2 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-04-09 +! +! ABSTRACT: This subroutine unpacks Section 2 (Local Use Section) +! as defined in GRIB Edition 2. +! +! PROGRAM HISTORY LOG: +! 2002-04-09 Gilbert +! +! USAGE: CALL gf_unpack2(cgrib,lcgrib,iofst,lencsec2,csec2,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array containing Section 2 of the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! iofst - Bit offset of the beginning of Section 2. +! +! OUTPUT ARGUMENT LIST: +! iofst - Bit offset at the end of Section 2, returned. +! lencsec2 - Length (in octets) of Local Use data +! csec2() - Pointer to a character*1 array containing local use data +! ierr - Error return code. +! 0 = no error +! 2 = Array passed is not section 2 +! 6 = memory allocation error +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,intent(out) :: lencsec2 + integer,intent(out) :: ierr + character(len=1),pointer,dimension(:) :: csec2 + + ierr=0 + lencsec2=0 + nullify(csec2) + + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + lencsec2=lensec-5 + call gbyte(cgrib,isecnum,iofst,8) ! Get Section Number + iofst=iofst+8 + ipos=(iofst/8)+1 + + if ( isecnum.ne.2 ) then + ierr=6 + print *,'gf_unpack2: Not Section 2 data. ' + return + endif + + allocate(csec2(lencsec2),stat=istat) + if (istat.ne.0) then + ierr=6 + nullify(csec2) + return + endif + + csec2(1:lencsec2)=cgrib(ipos:ipos+lencsec2-1) + iofst=iofst+(lencsec2*8) + + return ! End of Section 2 processing + end + diff --git a/WPS/ungrib/src/ngl/g2/gf_unpack3.f b/WPS/ungrib/src/ngl/g2/gf_unpack3.f new file mode 100755 index 00000000..3ed3268e --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gf_unpack3.f @@ -0,0 +1,189 @@ + subroutine gf_unpack3(cgrib,lcgrib,iofst,igds,igdstmpl, + & mapgridlen,ideflist,idefnum,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gf_unpack3 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine unpacks Section 3 (Grid Definition Section) +! starting at octet 6 of that Section. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! 2002-01-24 Gilbert - Changed to dynamically allocate arrays +! and to pass pointers to those arrays through +! the argument list. +! +! USAGE: CALL gf_unpack3(cgrib,lcgrib,lensec,iofst,igds,igdstmpl, +! & mapgridlen,ideflist,idefnum,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! iofst - Bit offset of the beginning of Section 3. +! +! OUTPUT ARGUMENT LIST: +! iofst - Bit offset at the end of Section 3, returned. +! igds - Contains information read from the appropriate GRIB Grid +! Definition Section 3 for the field being returned. +! Must be dimensioned >= 5. +! igds(1)=Source of grid definition (see Code Table 3.0) +! igds(2)=Number of grid points in the defined grid. +! igds(3)=Number of octets needed for each +! additional grid points definition. +! Used to define number of +! points in each row ( or column ) for +! non-regular grids. +! = 0, if using regular grid. +! igds(4)=Interpretation of list for optional points +! definition. (Code Table 3.11) +! igds(5)=Grid Definition Template Number (Code Table 3.1) +! igdstmpl - Pointer to integer array containing the data values for +! the specified Grid Definition +! Template ( NN=igds(5) ). Each element of this integer +! array contains an entry (in the order specified) of Grid +! Defintion Template 3.NN +! mapgridlen- Number of elements in igdstmpl(). i.e. number of entries +! in Grid Defintion Template 3.NN ( NN=igds(5) ). +! ideflist - (Used if igds(3) .ne. 0) Pointer to integer array containing +! the number of grid points contained in each row ( or column ). +! (part of Section 3) +! idefnum - (Used if igds(3) .ne. 0) The number of entries +! in array ideflist. i.e. number of rows ( or columns ) +! for which optional grid points are defined. +! ierr - Error return code. +! 0 = no error +! 5 = "GRIB" message contains an undefined Grid Definition +! Template. +! 6 = memory allocation error +! +! REMARKS: Uses Fortran 90 module gridtemplates and module re_alloc. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + use gridtemplates + use re_alloc ! needed for subroutine realloc + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,pointer,dimension(:) :: igdstmpl,ideflist + integer,intent(out) :: igds(5) + integer,intent(out) :: ierr,idefnum + + integer,allocatable :: mapgrid(:) + integer :: mapgridlen,ibyttem + logical needext + + ierr=0 + nullify(igdstmpl,ideflist) + + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + iofst=iofst+8 ! skip section number + + call gbyte(cgrib,igds(1),iofst,8) ! Get source of Grid def. + iofst=iofst+8 + call gbyte(cgrib,igds(2),iofst,32) ! Get number of grid pts. + iofst=iofst+32 + call gbyte(cgrib,igds(3),iofst,8) ! Get num octets for opt. list + iofst=iofst+8 + call gbyte(cgrib,igds(4),iofst,8) ! Get interpret. for opt. list + iofst=iofst+8 + call gbyte(cgrib,igds(5),iofst,16) ! Get Grid Def Template num. + iofst=iofst+16 +! if (igds(1).eq.0) then + if (igds(1).eq.0.OR.igds(1).eq.255) then ! FOR ECMWF TEST ONLY + allocate(mapgrid(lensec)) + ! Get Grid Definition Template + call getgridtemplate(igds(5),mapgridlen,mapgrid,needext, + & iret) + if (iret.ne.0) then + ierr=5 + if( allocated(mapgrid) ) deallocate(mapgrid) + return + endif + else +! igdstmpl=-1 + mapgridlen=0 + needext=.false. + endif + ! + ! Unpack each value into array igdstmpl from the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mapgrid. + ! + istat=0 + if (mapgridlen.gt.0) allocate(igdstmpl(mapgridlen),stat=istat) + if (istat.ne.0) then + ierr=6 + nullify(igdstmpl) + if( allocated(mapgrid) ) deallocate(mapgrid) + return + endif + ibyttem=0 + do i=1,mapgridlen + nbits=iabs(mapgrid(i))*8 + if ( mapgrid(i).ge.0 ) then + call gbyte(cgrib,igdstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,igdstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) igdstmpl(i)=-igdstmpl(i) + endif + iofst=iofst+nbits + ibyttem=ibyttem+iabs(mapgrid(i)) + enddo + ! + ! Check to see if the Grid Definition Template needs to be + ! extended. + ! The number of values in a specific template may vary + ! depending on data specified in the "static" part of the + ! template. + ! + if ( needext ) then + call extgridtemplate(igds(5),igdstmpl,newmapgridlen,mapgrid) + ! Unpack the rest of the Grid Definition Template + call realloc(igdstmpl,mapgridlen,newmapgridlen,istat) + do i=mapgridlen+1,newmapgridlen + nbits=iabs(mapgrid(i))*8 + if ( mapgrid(i).ge.0 ) then + call gbyte(cgrib,igdstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,igdstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) igdstmpl(i)=-igdstmpl(i) + endif + iofst=iofst+nbits + ibyttem=ibyttem+iabs(mapgrid(i)) + enddo + mapgridlen=newmapgridlen + endif + if( allocated(mapgrid) ) deallocate(mapgrid) + ! + ! Unpack optional list of numbers defining number of points + ! in each row or column, if included. This is used for non regular + ! grids. + ! + if ( igds(3).ne.0 ) then + nbits=igds(3)*8 + idefnum=(lensec-14-ibyttem)/igds(3) + istat=0 + if (idefnum.gt.0) allocate(ideflist(idefnum),stat=istat) + if (istat.ne.0) then + ierr=6 + nullify(ideflist) + return + endif + call gbytes(cgrib,ideflist,iofst,nbits,0,idefnum) + iofst=iofst+(nbits*idefnum) + else + idefnum=0 + nullify(ideflist) + endif + + return ! End of Section 3 processing + end diff --git a/WPS/ungrib/src/ngl/g2/gf_unpack4.f b/WPS/ungrib/src/ngl/g2/gf_unpack4.f new file mode 100755 index 00000000..9b29dce2 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gf_unpack4.f @@ -0,0 +1,159 @@ + subroutine gf_unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl, + & mappdslen,coordlist,numcoord,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gf_unpack4 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine unpacks Section 4 (Product Definition Section) +! starting at octet 6 of that Section. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! 2002-01-24 Gilbert - Changed to dynamically allocate arrays +! and to pass pointers to those arrays through +! the argument list. +! +! USAGE: CALL gf_unpack4(cgrib,lcgrib,iofst,ipdsnum,ipdstmpl,mappdslen, +! & coordlist,numcoord,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! iofst - Bit offset of the beginning of Section 4. +! +! OUTPUT ARGUMENT LIST: +! iofst - Bit offset of the end of Section 4, returned. +! ipdsnum - Product Definition Template Number ( see Code Table 4.0) +! ipdstmpl - Pointer to integer array containing the data values for +! the specified Product Definition +! Template ( N=ipdsnum ). Each element of this integer +! array contains an entry (in the order specified) of Product +! Defintion Template 4.N +! mappdslen- Number of elements in ipdstmpl(). i.e. number of entries +! in Product Defintion Template 4.N ( N=ipdsnum ). +! coordlist- Pointer to real array containing floating point values +! intended to document +! the vertical discretisation associated to model data +! on hybrid coordinate vertical levels. (part of Section 4) +! numcoord - number of values in array coordlist. +! ierr - Error return code. +! 0 = no error +! 5 = "GRIB" message contains an undefined Product Definition +! Template. +! 6 = memory allocation error +! +! REMARKS: Uses Fortran 90 module pdstemplates and module re_alloc. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + use pdstemplates + use re_alloc ! needed for subroutine realloc + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + real,pointer,dimension(:) :: coordlist + integer,pointer,dimension(:) :: ipdstmpl + integer,intent(out) :: ipdsnum + integer,intent(out) :: ierr,numcoord + + real(4),allocatable :: coordieee(:) + integer,allocatable :: mappds(:) + integer :: mappdslen + logical needext + + ierr=0 + nullify(ipdstmpl,coordlist) + + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + iofst=iofst+8 ! skip section number + allocate(mappds(lensec)) + + call gbyte(cgrib,numcoord,iofst,16) ! Get num of coordinate values + iofst=iofst+16 + call gbyte(cgrib,ipdsnum,iofst,16) ! Get Prod. Def Template num. + iofst=iofst+16 + ! Get Product Definition Template + call getpdstemplate(ipdsnum,mappdslen,mappds,needext,iret) + if (iret.ne.0) then + ierr=5 + if( allocated(mappds) ) deallocate(mappds) + return + endif + ! + ! Unpack each value into array ipdstmpl from the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mappds. + ! + istat=0 + if (mappdslen.gt.0) allocate(ipdstmpl(mappdslen),stat=istat) + if (istat.ne.0) then + ierr=6 + nullify(ipdstmpl) + if( allocated(mappds) ) deallocate(mappds) + return + endif + do i=1,mappdslen + nbits=iabs(mappds(i))*8 + if ( mappds(i).ge.0 ) then + call gbyte(cgrib,ipdstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,ipdstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) ipdstmpl(i)=-ipdstmpl(i) + endif + iofst=iofst+nbits + enddo + ! + ! Check to see if the Product Definition Template needs to be + ! extended. + ! The number of values in a specific template may vary + ! depending on data specified in the "static" part of the + ! template. + ! + if ( needext ) then + call extpdstemplate(ipdsnum,ipdstmpl,newmappdslen,mappds) + call realloc(ipdstmpl,mappdslen,newmappdslen,istat) + ! Unpack the rest of the Product Definition Template + do i=mappdslen+1,newmappdslen + nbits=iabs(mappds(i))*8 + if ( mappds(i).ge.0 ) then + call gbyte(cgrib,ipdstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,ipdstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) ipdstmpl(i)=-ipdstmpl(i) + endif + iofst=iofst+nbits + enddo + mappdslen=newmappdslen + endif + if( allocated(mappds) ) deallocate(mappds) + ! + ! Get Optional list of vertical coordinate values + ! after the Product Definition Template, if necessary. + ! + nullify(coordlist) + if ( numcoord .ne. 0 ) then + allocate (coordieee(numcoord),stat=istat1) + allocate(coordlist(numcoord),stat=istat) + if ((istat1+istat).ne.0) then + ierr=6 + nullify(coordlist) + if( allocated(coordieee) ) deallocate(coordieee) + return + endif + call gbytes(cgrib,coordieee,iofst,32,0,numcoord) + call rdieee(coordieee,coordlist,numcoord) + deallocate (coordieee) + iofst=iofst+(32*numcoord) + endif + + return ! End of Section 4 processing + end + diff --git a/WPS/ungrib/src/ngl/g2/gf_unpack5.f b/WPS/ungrib/src/ngl/g2/gf_unpack5.f new file mode 100755 index 00000000..9a6ee130 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gf_unpack5.f @@ -0,0 +1,134 @@ + subroutine gf_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl, + & mapdrslen,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gf_unpack5 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine unpacks Section 5 (Data Representation Section) +! starting at octet 6 of that Section. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! 2002-01-24 Gilbert - Changed to dynamically allocate arrays +! and to pass pointers to those arrays through +! the argument list. +! +! USAGE: CALL gf_unpack5(cgrib,lcgrib,iofst,ndpts,idrsnum,idrstmpl, +! mapdrslen,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! iofst - Bit offset of the beginning of Section 5. +! +! OUTPUT ARGUMENT LIST: +! iofst - Bit offset at the end of Section 5, returned. +! ndpts - Number of data points unpacked and returned. +! idrsnum - Data Representation Template Number ( see Code Table 5.0) +! idrstmpl - Pointer to an integer array containing the data values for +! the specified Data Representation +! Template ( N=idrsnum ). Each element of this integer +! array contains an entry (in the order specified) of Data +! Representation Template 5.N +! mapdrslen- Number of elements in idrstmpl(). i.e. number of entries +! in Data Representation Template 5.N ( N=idrsnum ). +! ierr - Error return code. +! 0 = no error +! 6 = memory allocation error +! 7 = "GRIB" message contains an undefined Data +! Representation Template. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + use drstemplates + use re_alloc ! needed for subroutine realloc + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(inout) :: iofst + integer,intent(out) :: ndpts,idrsnum + integer,pointer,dimension(:) :: idrstmpl + integer,intent(out) :: ierr + + integer,allocatable :: mapdrs(:) + integer :: mapdrslen + logical needext + + ierr=0 + nullify(idrstmpl) + + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + iofst=iofst+8 ! skip section number + allocate(mapdrs(lensec)) + + call gbyte(cgrib,ndpts,iofst,32) ! Get num of data points + iofst=iofst+32 + call gbyte(cgrib,idrsnum,iofst,16) ! Get Data Rep Template Num. + iofst=iofst+16 + ! Gen Data Representation Template + call getdrstemplate(idrsnum,mapdrslen,mapdrs,needext,iret) + if (iret.ne.0) then + ierr=7 + if( allocated(mapdrs) ) deallocate(mapdrs) + return + endif + ! + ! Unpack each value into array ipdstmpl from the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mappds. + ! + istat=0 + if (mapdrslen.gt.0) allocate(idrstmpl(mapdrslen),stat=istat) + if (istat.ne.0) then + ierr=6 + nullify(idrstmpl) + if( allocated(mapdrs) ) deallocate(mapdrs) + return + endif + do i=1,mapdrslen + nbits=iabs(mapdrs(i))*8 + if ( mapdrs(i).ge.0 ) then + call gbyte(cgrib,idrstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,idrstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) idrstmpl(i)=-idrstmpl(i) + endif + iofst=iofst+nbits + enddo + ! + ! Check to see if the Data Representation Template needs to be + ! extended. + ! The number of values in a specific template may vary + ! depending on data specified in the "static" part of the + ! template. + ! + if ( needext ) then + call extdrstemplate(idrsnum,idrstmpl,newmapdrslen,mapdrs) + call realloc(idrstmpl,mapdrslen,newmapdrslen,istat) + ! Unpack the rest of the Data Representation Template + do i=mapdrslen+1,newmapdrslen + nbits=iabs(mapdrs(i))*8 + if ( mapdrs(i).ge.0 ) then + call gbyte(cgrib,idrstmpl(i),iofst,nbits) + else + call gbyte(cgrib,isign,iofst,1) + call gbyte(cgrib,idrstmpl(i),iofst+1,nbits-1) + if (isign.eq.1) idrstmpl(i)=-idrstmpl(i) + endif + iofst=iofst+nbits + enddo + mapdrslen=newmapdrslen + endif + if( allocated(mapdrs) ) deallocate(mapdrs) + + return ! End of Section 5 processing + end + diff --git a/WPS/ungrib/src/ngl/g2/gf_unpack6.f b/WPS/ungrib/src/ngl/g2/gf_unpack6.f new file mode 100755 index 00000000..f963a509 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gf_unpack6.f @@ -0,0 +1,88 @@ + subroutine gf_unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gf_unpack6 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine unpacks Section 6 (Bit-Map Section) +! starting at octet 6 of that Section. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! 2002-01-24 Gilbert - Changed to dynamically allocate arrays +! and to pass pointers to those arrays through +! the argument list. +! +! USAGE: CALL gf_unpack6(cgrib,lcgrib,iofst,ngpts,ibmap,bmap,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! iofst - Bit offset of the beginning of Section 6. +! ngpts - Number of grid points specified in the bit-map +! +! OUTPUT ARGUMENT LIST: +! iofst - Bit offset at the end of Section 6, returned. +! ibmap - Bitmap indicator ( see Code Table 6.0 ) +! 0 = bitmap applies and is included in Section 6. +! 1-253 = Predefined bitmap applies +! 254 = Previously defined bitmap applies to this field +! 255 = Bit map does not apply to this product. +! bmap() - Pointer to a logical*1 array containing decoded bitmap. +! ( if ibmap=0 ) +! ierr - Error return code. +! 0 = no error +! 4 = Unrecognized pre-defined bit-map. +! 6 = memory allocation error +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib,ngpts + integer,intent(inout) :: iofst + integer,intent(out) :: ibmap + integer,intent(out) :: ierr + logical*1,pointer,dimension(:) :: bmap + + integer :: intbmap(ngpts) + + ierr=0 + nullify(bmap) + + iofst=iofst+32 ! skip Length of Section + iofst=iofst+8 ! skip section number + + call gbyte(cgrib,ibmap,iofst,8) ! Get bit-map indicator + iofst=iofst+8 + + if (ibmap.eq.0) then ! Unpack bitmap + istat=0 + if (ngpts.gt.0) allocate(bmap(ngpts),stat=istat) + if (istat.ne.0) then + ierr=6 + nullify(bmap) + return + endif + call gbytes(cgrib,intbmap,iofst,1,0,ngpts) + iofst=iofst+ngpts + do j=1,ngpts + bmap(j)=.true. + if (intbmap(j).eq.0) bmap(j)=.false. + enddo +! elseif (ibmap.eq.254) then ! Use previous bitmap +! return +! elseif (ibmap.eq.255) then ! No bitmap in message +! bmap(1:ngpts)=.true. +! else +! print *,'gf_unpack6: Predefined bitmap ',ibmap,' not recognized.' +! ierr=4 + endif + + return ! End of Section 6 processing + end + diff --git a/WPS/ungrib/src/ngl/g2/gf_unpack7.F b/WPS/ungrib/src/ngl/g2/gf_unpack7.F new file mode 100755 index 00000000..2c6e8352 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gf_unpack7.F @@ -0,0 +1,124 @@ + subroutine gf_unpack7(cgrib,lcgrib,iofst,igdsnum,igdstmpl, + & idrsnum,idrstmpl,ndpts,fld,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gf_unpack7 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-01-24 +! +! ABSTRACT: This subroutine unpacks GRIB2 Section 7 (Data Section). +! +! PROGRAM HISTORY LOG: +! 2002-01-24 Gilbert +! 2002-12-17 Gilbert - Added support for new templates using +! PNG and JPEG2000 algorithms/templates. +! 2004-12-29 Gilbert - Added check on comunpack return code. +! +! USAGE: CALL gf_unpack7(cgrib,lcgrib,iofst,igdsnum,igdstmpl, +! & idrsnum,idrstmpl,ndpts,fld,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! iofst - Bit offset of the beginning of Section 7. +! igdsnum - Grid Definition Template Number ( see Code Table 3.0) +! (Only required to unpack DRT 5.51) +! igdstmpl - Pointer to an integer array containing the data values for +! the specified Grid Definition +! Template ( N=igdsnum ). Each element of this integer +! array contains an entry (in the order specified) of Grid +! Definition Template 3.N +! (Only required to unpack DRT 5.51) +! idrsnum - Data Representation Template Number ( see Code Table 5.0) +! idrstmpl - Pointer to an integer array containing the data values for +! the specified Data Representation +! Template ( N=idrsnum ). Each element of this integer +! array contains an entry (in the order specified) of Data +! Representation Template 5.N +! ndpts - Number of data points unpacked and returned. +! +! OUTPUT ARGUMENT LIST: +! iofst - Bit offset at the end of Section 7, returned. +! fld() - Pointer to a real array containing the unpacked data field. +! ierr - Error return code. +! 0 = no error +! 4 = Unrecognized Data Representation Template +! 5 = One of GDT 3.50 through 3.53 required to unpack DRT 5.51 +! 6 = memory allocation error +! 7 = corrupt section 7. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib,ndpts,igdsnum,idrsnum + integer,intent(inout) :: iofst + integer,pointer,dimension(:) :: igdstmpl,idrstmpl + integer,intent(out) :: ierr + real,pointer,dimension(:) :: fld + + + ierr=0 + nullify(fld) + + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + iofst=iofst+8 ! skip section number + + ipos=(iofst/8)+1 + istat=0 + allocate(fld(ndpts),stat=istat) + if (istat.ne.0) then + ierr=6 + return + endif + + if (idrsnum.eq.0) then + call simunpack(cgrib(ipos),lensec-5,idrstmpl,ndpts,fld) + elseif (idrsnum.eq.2.or.idrsnum.eq.3) then + call comunpack(cgrib(ipos),lensec-5,lensec,idrsnum,idrstmpl, + & ndpts,fld,ier) + if ( ier .NE. 0 ) then + ierr=7 + return + endif + elseif (idrsnum.eq.50) then ! Spectral simple + call simunpack(cgrib(ipos),lensec-5,idrstmpl,ndpts-1, + & fld(2)) + ieee=idrstmpl(5) + call rdieee(ieee,fld(1),1) + elseif (idrsnum.eq.51) then ! Spectral complex + if (igdsnum.ge.50.AND.igdsnum.le.53) then + call specunpack(cgrib(ipos),lensec-5,idrstmpl,ndpts, + & igdstmpl(1),igdstmpl(2),igdstmpl(3),fld) + else + print *,'gf_unpack7: Cannot use GDT 3.',igdsnum, + & ' to unpack Data Section 5.51.' + ierr=5 + nullify(fld) + return + endif +#ifdef USE_JPEG2000 + elseif (idrsnum.eq.40 .OR. idrsnum.eq.40000) then + call jpcunpack(cgrib(ipos),lensec-5,idrstmpl,ndpts,fld) +#endif /* USE_JPEG2000 */ +#ifdef USE_PNG + elseif (idrsnum.eq.41 .OR. idrsnum.eq.40010) then + call pngunpack(cgrib(ipos),lensec-5,idrstmpl,ndpts,fld) +#endif /* USE_PNG */ + else + print *,'gf_unpack7: Data Representation Template ',idrsnum, + & ' not yet implemented.' + ierr=4 + nullify(fld) + return + endif + + iofst=iofst+(8*lensec) + + return ! End of Section 7 processing + end + diff --git a/WPS/ungrib/src/ngl/g2/grib2.doc b/WPS/ungrib/src/ngl/g2/grib2.doc new file mode 100755 index 00000000..20cedddf --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/grib2.doc @@ -0,0 +1,1220 @@ + GRIB2 USERS GUIDE (FORTRAN 90) + +Contents: + +- Introduction +- GRIB2 Encoding Routines +- GRIB2 Decoding Routines +- Extracting GRIB2 Fields from a GRIB2 file +- GRIB2 Tables/Templates +- GRIB2 Routine Docblocks + +=============================================================================== + + Introduction + +This document briefly describes the routines available for encoding/decoding +GRIB Edition 2 (GRIB2) messages. A basic familiarity with GRIB is assumed. + +A GRIB Edition 2 message is a machine independent format for storing +one or more gridded data fields. Each GRIB2 message consists of the +following sections: + +SECTION 0 - Indicator Section +SECTION 1 - Identification Section +SECTION 2 - (Local Use Section) - optional } +SECTION 3 - Grid Definition Section } } +SECTION 4 - Product Definition Section } } }(repeated) +SECTION 5 - Data Representation Section } }(repeated) } +SECTION 6 - Bit-map Section }(repeated) } } +SECTION 7 - Data Section } } } +SECTION 8 - End Section } } } + +Sequences of GRIB sections 2 to 7, 3 to 7, or sections 4 to 7 may be repeated +within a single GRIB message. All sections within such repeated sequences +must be present and shall appear in the numerical order noted above. +Unrepeated sections remain in effect until redefined. + +The above overview was taken from WMO's FM 92-XII GRIB description +of the experimental GRIB Edition 2 form. + +=============================================================================== + + GRIB2 Encoding Routines + +Since a GRIB2 message can contain gridded fields for many parameters on +a number of different grids, several routines are used to encode a message. +This should give users more flexibility in how to organize data +within one or more GRIB2 messages. + +To start a new GRIB2 message, call subroutine GRIBCREATE. GRIBCREATE +encodes Sections 0 and 1 at the beginning of the message. This routine +must be used to create each message. + +Subroutine ADDLOCAL can be used to add a Local Use Section ( Section 2 ). +Note that section is optional and need not appear in a GRIB2 message. + +Subroutine ADDGRID is used to encode a grid definition into Section 3. +This grid definition defines the geometry of the the data values in the +fields that follow it. ADDGRID can be called again to change the grid +definition describing subsequent data fields. + +Each data field is added to the GRIB2 message using routine ADDFIELD, +which adds Sections 4, 5, 6, and 7 to the message. + +After all desired data fields have been added to the GRIB2 message, a +call to routine GRIBEND is needed to add the final section 8 to the +message and to update the length of the message. A call to GRIBEND +is required for each GRIB2 message. + +Please see the "GRIB2 Routine Docblocks" section below for subroutine +argument usage for the routines mentioned above. + +=============================================================================== + + GRIB2 Decoding Routines + +Subroutine GB_INFO can be used to find out how many Local Use sections +and data fields are contained in a given GRIB2 message. In addition, +this routine also returns the number of octets of the largest Local Use +section in the message. This value can be used to ensure that the +output array of subroutine GETLOCAL ( described below ) is dimensioned +large enough. + +Subroutine GETLOCAL will return the requested occurrence of Section 2 +from a given GRIB2 message. + +GF_GETFLD can be used to get all information pertaining to the nth +data field in the message. The subroutine returns all the unpacked values +for each Section and Template in a Fortran 90 derived type gribfield, +which is defined in module GRIB_MOD. An option exists that lets the +user decide if the subroutine should unpack the Bit-map ( if +applicable ) and the data values or just return the field description +information. +Note that derived type gribfield contains pointers to dynamically +allocated space that holds the contents of all arrays, and users are encouraged +to free up this memory, when it is no longer needed, by an explicit call +to subroutine GF_FREE. + +Please see the "GRIB2 Routine Docblocks" section below for subroutine +argument usage for the routines mentioned above. + +=============================================================================== + + Extracting GRIB2 Fields from a GRIB2 file + +Subroutine GETGB2 can be used to extract a specified field from a file +containing many GRIB2 messages. GETGB2 searches an index to find the +location of the user specified field. The index can be supplied from a +seperate GRIB2 index file, or it can be generated internally. + +The GRIB2 file ( and the index file, if supplied ) must be opened with +a call to subroutine BAOPEN prior to the call to GETGB2. + +The decoded information for the selected GRIB field is returned in a +derived type variable, gfld. Gfld is of type gribfield, which is defined +in module grib_mod, so users of this routine will need to include +the line "USE GRIB_MOD" in their calling routine. Each component of the +gribfield type is described in the OUTPUT ARGUMENT LIST in the docblock +for subroutine GETGB2 below. + +Note that derived type gribfield contains pointers to many arrays of data. +The memory for these arrays is allocated when the values in the arrays +are set, to help minimize problems with array overloading. Because of this, +users are encouraged to free up this memory, when it is no longer +needed, by an explicit call to subroutine GF_FREE. + +Example usage: + + use grib_mod + type(gribfield) :: gfld + integer,dimension(200) :: jids,jpdt,jgdt + logical :: unpack=.true. + ifile=10 + ! Open GRIB2 file + call baopenr(ifile,"filename",iret) + . + ! Set GRIB2 field identification values to search for + jdisc= + jids(?)= + jpdtn= + jpdt(?)= + jgdtn= + jgdt(?)= + + ! Get field from file + call getgb2(ifile,0,j,jdisc,jids,jpdtn,jpdt,jgdtn,jgdt, + & unpack,j,gfld,iret) + + ! Process field ... + firstval=gfld%fld(1) + lastval=gfld%fld(gfld%ndpts) + fldmax=maxval(gfld%fld) + fldmin=minval(gfld%fld) + + ! Free memory when done with field + call gf_free(gfld) + + stop + end + +Please see the "GRIB2 Routine Docblocks" section below for subroutine +argument usage for the routines mentioned above. + +=============================================================================== + + GRIB2 Tables/Templates + +WMO's GRIB2 specification "FM 92-XII GRIB - General Regularly-distributed +Information in Binary Form" contains descriptions of each template +and code table information. This document can be found at +http://www.wmo.ch/web/www/WMOCodes.html +(PDF and MSWord formats are available) + +MDL has made an HTML version of the document available at +http://www.nws.noaa.gov/tdl/iwt/grib2/frameset_grib2.htm. + +=============================================================================== + + GRIB2 Routine Docblocks + +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gribcreate +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-04-28 +! +! ABSTRACT: This subroutine initializes a new GRIB2 message and packs +! GRIB2 sections 0 (Indicator Section) and 1 (Identification Section). +! This routine is used with routines "addlocal", "addgrid", "addfield", +! and "gribend" to create a complete GRIB2 message. Subroutine +! gribcreate must be called first to initialize a new GRIB2 message. +! Also, a call to gribend is required to complete GRIB2 message +! after all fields have been added. +! +! PROGRAM HISTORY LOG: +! 2000-04-28 Gilbert +! +! USAGE: CALL gribcreate(cgrib,lcgrib,listsec0,listsec1,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lcgrib - Maximum length (bytes) of array cgrib. +! listsec0 - Contains information needed for GRIB Indicator Section 0. +! Must be dimensioned >= 2. +! listsec0(1)=Discipline-GRIB Master Table Number +! (see Code Table 0.0) +! listsec0(2)=GRIB Edition Number (currently 2) +! listsec1 - Contains information needed for GRIB Identification Section 1. +! Must be dimensioned >= 13. +! listsec1(1)=Id of orginating centre (Common Code Table C-1) +! listsec1(2)=Id of orginating sub-centre (local table) +! listsec1(3)=GRIB Master Tables Version Number (Code Table 1.0) +! listsec1(4)=GRIB Local Tables Version Number (Code Table 1.1) +! listsec1(5)=Significance of Reference Time (Code Table 1.2) +! listsec1(6)=Reference Time - Year (4 digits) +! listsec1(7)=Reference Time - Month +! listsec1(8)=Reference Time - Day +! listsec1(9)=Reference Time - Hour +! listsec1(10)=Reference Time - Minute +! listsec1(11)=Reference Time - Second +! listsec1(12)=Production status of data (Code Table 1.3) +! listsec1(13)=Type of processed data (Code Table 1.4) +! +! OUTPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! ierr - Error return code. +! 0 = no error +! 1 = Tried to use for version other than GRIB Edition 2 +! +! REMARKS: This routine is intended for use with routines "addlocal", +! "addgrid", "addfield", and "gribend" to create a complete +! GRIB2 message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: addlocal +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-01 +! +! ABSTRACT: This subroutine adds a Local Use Section (Section 2) to +! a GRIB2 message. +! This routine is used with routines "gribcreate", "addgrid", "addfield", +! and "gribend" to create a complete GRIB2 message. Subroutine +! gribcreate must be called first to initialize a new GRIB2 message. +! +! PROGRAM HISTORY LOG: +! 2000-05-01 Gilbert +! +! USAGE: CALL addlocal(cgrib,lcgrib,csec2,lcsec2,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lcgrib - Maximum length (bytes) of array cgrib. +! csec2 - Character array containing information to be added to +! Section 2. +! lcsec2 - Number of bytes of character array csec2 to be added to +! Section 2. +! +! OUTPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! ierr - Error return code. +! 0 = no error +! 1 = GRIB message was not initialized. Need to call +! routine gribcreate first. +! 2 = GRIB message already complete. Cannot add new section. +! 3 = Sum of Section byte counts doesn't add to total byte count. +! 4 = Previous Section was not 1 or 7. +! +! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow +! Section 1 or Section 7 in a GRIB2 message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: addgrid +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-01 +! +! ABSTRACT: This subroutine packs up a Grid Definition Section (Section 3) +! and adds it to a GRIB2 message. +! This routine is used with routines "gribcreate", "addlocal", "addfield", +! and "gribend" to create a complete GRIB2 message. Subroutine +! gribcreate must be called first to initialize a new GRIB2 message. +! +! PROGRAM HISTORY LOG: +! 2000-05-01 Gilbert +! +! USAGE: CALL addgrid(cgrib,lcgrib,igds,igdstmpl,igdstmplen, +! ideflist,idefnum,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lcgrib - Maximum length (bytes) of array cgrib. +! igds - Contains information needed for GRIB Grid Definition Section 3. +! Must be dimensioned >= 5. +! igds(1)=Source of grid definition (see Code Table 3.0) +! igds(2)=Number of grid points in the defined grid. +! igds(3)=Number of octets needed for each +! additional grid points definition. +! Used to define number of +! points in each row ( or column ) for +! non-regular grids. +! = 0, if using regular grid. +! igds(4)=Interpretation of list for optional points +! definition. (Code Table 3.11) +! igds(5)=Grid Definition Template Number (Code Table 3.1) +! igdstmpl - Contains the data values for the specified Grid Definition +! Template ( NN=igds(5) ). Each element of this integer +! array contains an entry (in the order specified) of Grid +! Defintion Template 3.NN +! igdstmplen - Max dimension of igdstmpl() +! ideflist - (Used if igds(3) .ne. 0) This array contains the +! number of grid points contained in each row ( or column ) +! idefnum - (Used if igds(3) .ne. 0) The number of entries +! in array ideflist. i.e. number of rows ( or columns ) +! for which optional grid points are defined. +! +! OUTPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! ierr - Error return code. +! 0 = no error +! 1 = GRIB message was not initialized. Need to call +! routine gribcreate first. +! 2 = GRIB message already complete. Cannot add new section. +! 3 = Sum of Section byte counts doesn't add to total byte count. +! 4 = Previous Section was not 1, 2 or 7. +! 5 = Could not find requested Grid Definition Template. +! +! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow +! Section 1 or Section 7 in a GRIB2 message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: addfield +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-02 +! +! ABSTRACT: This subroutine packs up Sections 4 through 7 for a given field +! and adds them to a GRIB2 message. They are Product Definition Section, +! Data Representation Section, Bit-Map Section and Data Section, +! respectively. +! This routine is used with routines "gribcreate", "addlocal", "addgrid", +! and "gribend" to create a complete GRIB2 message. Subroutine +! gribcreate must be called first to initialize a new GRIB2 message. +! Also, subroutine addgrid must be called after gribcreate and +! before this routine to add the appropriate grid description to +! the GRIB2 message. Also, a call to gribend is required to complete +! GRIB2 message after all fields have been added. +! +! PROGRAM HISTORY LOG: +! 2000-05-02 Gilbert +! 2002-12-17 Gilbert - Added support for new templates using +! PNG and JPEG2000 algorithms/templates. +! 2004-06-22 Gilbert - Added check to determine if packing algorithm failed. +! +! USAGE: CALL addfield(cgrib,lcgrib,ipdsnum,ipdstmpl,ipdstmplen, +! coordlist,numcoord,idrsnum,idrstmpl, +! idrstmplen,fld,ngrdpts,ibmap,bmap,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lcgrib - Maximum length (bytes) of array cgrib. +! ipdsnum - Product Definition Template Number ( see Code Table 4.0) +! ipdstmpl - Contains the data values for the specified Product Definition +! Template ( N=ipdsnum ). Each element of this integer +! array contains an entry (in the order specified) of Product +! Defintion Template 4.N +! ipdstmplen - Max dimension of ipdstmpl() +! coordlist- Array containg floating point values intended to document +! the vertical discretisation associated to model data +! on hybrid coordinate vertical levels. +! numcoord - number of values in array coordlist. +! idrsnum - Data Representation Template Number ( see Code Table 5.0 ) +! idrstmpl - Contains the data values for the specified Data Representation +! Template ( N=idrsnum ). Each element of this integer +! array contains an entry (in the order specified) of Data +! Representation Template 5.N +! Note that some values in this template (eg. reference +! values, number of bits, etc...) may be changed by the +! data packing algorithms. +! Use this to specify scaling factors and order of +! spatial differencing, if desired. +! idrstmplen - Max dimension of idrstmpl() +! fld() - Array of data points to pack. +! ngrdpts - Number of data points in grid. +! i.e. size of fld and bmap. +! ibmap - Bitmap indicator ( see Code Table 6.0 ) +! 0 = bitmap applies and is included in Section 6. +! 1-253 = Predefined bitmap applies +! 254 = Previously defined bitmap applies to this field +! 255 = Bit map does not apply to this product. +! bmap() - Logical*1 array containing bitmap to be added. +! ( if ibmap=0 or ibmap=254) +! +! OUTPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! ierr - Error return code. +! 0 = no error +! 1 = GRIB message was not initialized. Need to call +! routine gribcreate first. +! 2 = GRIB message already complete. Cannot add new section. +! 3 = Sum of Section byte counts doesn't add to total byte count. +! 4 = Previous Section was not 3 or 7. +! 5 = Could not find requested Product Definition Template. +! 6 = Section 3 (GDS) not previously defined in message +! 7 = Tried to use unsupported Data Representationi Template +! 8 = Specified use of a previously defined bitmap, but one +! does not exist in the GRIB message. +! 9 = GDT of one of 5.50 through 5.53 required to pack +! using DRT 5.51 +! 10 = Error packing data field. +! +! REMARKS: Note that the Local Use Section ( Section 2 ) can only follow +! Section 1 or Section 7 in a GRIB2 message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gribend +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-02 +! +! ABSTRACT: This subroutine finalizes a GRIB message after all grids +! and fields have been added. It adds the End Section ( "7777" ) +! to the end of the GRIB message and calculates the length and stores +! it in the appropriate place in Section 0. +! This routine is used with routines "gribcreate", "addlocal", "addgrid", +! and "addfield" to create a complete GRIB2 message. Subroutine +! gribcreate must be called first to initialize a new GRIB2 message. +! +! PROGRAM HISTORY LOG: +! 2000-05-02 Gilbert +! +! USAGE: CALL gribend(cgrib,lcgrib,lengrib,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lcgrib - Maximum length (bytes) of array cgrib. +! +! OUTPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lengrib - Length of the final GRIB2 message in octets (bytes) +! ierr - Error return code. +! 0 = no error +! 1 = GRIB message was not initialized. Need to call +! routine gribcreate first. +! 2 = GRIB message already complete. +! 3 = Sum of Section byte counts doesn't add to total byte count. +! 4 = Previous Section was not 7. +! +! REMARKS: This routine is intended for use with routines "gribcreate", +! "addlocal", "addgrid", and "addfield" to create a complete +! GRIB2 message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gb_info +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-25 +! +! ABSTRACT: This subroutine searches through a GRIB2 message and +! returns the number of gridded fields found in the message and +! the number (and maximum size) of Local Use Sections. +! Also various checks are performed +! to see if the message is a valid GRIB2 message. +! +! PROGRAM HISTORY LOG: +! 2000-05-25 Gilbert +! +! USAGE: CALL gb_info(cgrib,lcgrib,listsec0,listsec1, +! & numfields,numlocal,maxlocal,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message in array cgrib. +! +! OUTPUT ARGUMENT LIST: +! listsec0 - Contains information decoded from GRIB Indicator Section 0. +! Must be dimensioned >= 2. +! listsec0(1)=Discipline-GRIB Master Table Number +! (see Code Table 0.0) +! listsec0(2)=GRIB Edition Number (currently 2) +! listsec0(3)=Length of GRIB message +! listsec1 - Contains information read from GRIB Identification Section 1. +! Must be dimensioned >= 13. +! listsec1(1)=Id of orginating centre (Common Code Table C-1) +! listsec1(2)=Id of orginating sub-centre (local table) +! listsec1(3)=GRIB Master Tables Version Number (Code Table 1.0) +! listsec1(4)=GRIB Local Tables Version Number +! listsec1(5)=Significance of Reference Time (Code Table 1.1) +! listsec1(6)=Reference Time - Year (4 digits) +! listsec1(7)=Reference Time - Month +! listsec1(8)=Reference Time - Day +! listsec1(9)=Reference Time - Hour +! listsec1(10)=Reference Time - Minute +! listsec1(11)=Reference Time - Second +! listsec1(12)=Production status of data (Code Table 1.2) +! listsec1(13)=Type of processed data (Code Table 1.3) +! numfields- The number of gridded fields found in the GRIB message. +! numlocal - The number of Local Use Sections ( Section 2 ) found in +! the GRIB message. +! maxlocal- The size of the largest Local Use Section ( Section 2 ). +! Can be used to ensure that the return array passed +! to subroutine getlocal is dimensioned large enough. +! ierr - Error return code. +! 0 = no error +! 1 = Beginning characters "GRIB" not found. +! 2 = GRIB message is not Edition 2. +! 3 = Could not find Section 1, where expected. +! 4 = End string "7777" found, but not where expected. +! 5 = End string "7777" not found at end of message. +! 6 = Invalid section number found. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getlocal +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-25 +! +! ABSTRACT: This subroutine returns the contents of Section 2 ( Local +! Use Section ) from a GRIB2 message. Since there can be multiple +! occurrences of Section 2 within a GRIB message, the calling routine +! indicates which occurrence is being requested with the localnum argument. +! +! PROGRAM HISTORY LOG: +! 2000-05-25 Gilbert +! +! USAGE: CALL getlocal(cgrib,lcgrib,localnum,csec2,lcsec2,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message in array cgrib. +! localnum - The nth occurrence of Section 2 requested. +! +! OUTPUT ARGUMENT LIST: +! csec2 - Character array containing information read from +! Section 2. +! The dimension of this array can be obtained in advance +! from argument maxlocal, which is returned from subroutine +! gb_info. +! lcsec2 - Number of bytes of character array csec2 read from +! Section 2. +! ierr - Error return code. +! 0 = no error +! 1 = Beginning characters "GRIB" not found. +! 2 = GRIB message is not Edition 2. +! 3 = The section 2 request number was not positive. +! 4 = End string "7777" found, but not where expected. +! 5 = End string "7777" not found at end of message. +! 6 = GRIB message did not contain the requested number of +! Local Use Sections. +! +! REMARKS: Note that subroutine gribinfo can be used to first determine +! how many Local Use sections exist in a given GRIB message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gf_getfld +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine returns the Grid Definition, Product Definition, +! Bit-map ( if applicable ), and the unpacked data for a given data +! field. All of the information returned is stored in a derived +! type variable, gfld. Gfld is of type gribfield, which is defined +! in module grib_mod, so users of this routine will need to include +! the line "USE GRIB_MOD" in their calling routine. Each component of the +! gribfield type is described in the OUTPUT ARGUMENT LIST section below. +! +! Since there can be multiple data fields packed into a GRIB2 +! message, the calling routine indicates which field is being requested +! with the ifldnum argument. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! 2002-01-24 Gilbert - Changed to pass back derived type gribfield +! variable through argument list, instead of +! having many different arguments. +! +! USAGE: CALL gf_getfld(cgrib,lcgrib,ifldnum,unpack,expand,gfld,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message array cgrib. +! ifldnum - Specifies which field in the GRIB2 message to return. +! unpack - Logical value indicating whether to unpack bitmap/data +! .true. = unpack bitmap and data values +! .false. = do not unpack bitmap and data values +! expand - Boolean value indicating whether the data points should be +! expanded to the correspond grid, if a bit-map is present. +! 1 = if possible, expand data field to grid, inserting zero +! values at gridpoints that are bitmapped out. +! (SEE REMARKS2) +! 0 = do not expand data field, leaving it an array of +! consecutive data points for each "1" in the bitmap. +! This argument is ignored if unpack == 0 OR if the +! returned field does not contain a bit-map. +! +! OUTPUT ARGUMENT LIST: +! gfld - derived type gribfield ( defined in module grib_mod ) +! ( NOTE: See Remarks Section ) +! gfld%version = GRIB edition number ( currently 2 ) +! gfld%discipline = Message Discipline ( see Code Table 0.0 ) +! gfld%idsect() = Contains the entries in the Identification +! Section ( Section 1 ) +! This element is actually a pointer to an array +! that holds the data. +! gfld%idsect(1) = Identification of originating Centre +! ( see Common Code Table C-1 ) +! 7 - US National Weather Service +! gfld%idsect(2) = Identification of originating Sub-centre +! gfld%idsect(3) = GRIB Master Tables Version Number +! ( see Code Table 1.0 ) +! 0 - Experimental +! 1 - Initial operational version number +! gfld%idsect(4) = GRIB Local Tables Version Number +! ( see Code Table 1.1 ) +! 0 - Local tables not used +! 1-254 - Number of local tables version used +! gfld%idsect(5) = Significance of Reference Time (Code Table 1.2) +! 0 - Analysis +! 1 - Start of forecast +! 2 - Verifying time of forecast +! 3 - Observation time +! gfld%idsect(6) = Year ( 4 digits ) +! gfld%idsect(7) = Month +! gfld%idsect(8) = Day +! gfld%idsect(9) = Hour +! gfld%idsect(10) = Minute +! gfld%idsect(11) = Second +! gfld%idsect(12) = Production status of processed data +! ( see Code Table 1.3 ) +! 0 - Operational products +! 1 - Operational test products +! 2 - Research products +! 3 - Re-analysis products +! gfld%idsect(13) = Type of processed data ( see Code Table 1.4 ) +! 0 - Analysis products +! 1 - Forecast products +! 2 - Analysis and forecast products +! 3 - Control forecast products +! 4 - Perturbed forecast products +! 5 - Control and perturbed forecast products +! 6 - Processed satellite observations +! 7 - Processed radar observations +! gfld%idsectlen = Number of elements in gfld%idsect(). +! gfld%ifldnum = field number within GRIB message +! gfld%griddef = Source of grid definition (see Code Table 3.0) +! 0 - Specified in Code table 3.1 +! 1 - Predetermined grid Defined by originating centre +! gfld%ngrdpts = Number of grid points in the defined grid. +! gfld%numoct_opt = Number of octets needed for each +! additional grid points definition. +! Used to define number of +! points in each row ( or column ) for +! non-regular grids. +! = 0, if using regular grid. +! gfld%interp_opt = Interpretation of list for optional points +! definition. (Code Table 3.11) +! gfld%igdtnum = Grid Definition Template Number (Code Table 3.1) +! gfld%igdtmpl() = Contains the data values for the specified Grid +! Definition Template ( NN=gfld%igdtnum ). Each +! element of this integer array contains an entry (in +! the order specified) of Grid Defintion Template 3.NN +! This element is actually a pointer to an array +! that holds the data. +! gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of +! entries in Grid Defintion Template 3.NN +! ( NN=gfld%igdtnum ). +! gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array +! contains the number of grid points contained in +! each row ( or column ). (part of Section 3) +! This element is actually a pointer to an array +! that holds the data. This pointer is nullified +! if gfld%numoct_opt=0. +! gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries +! in array ideflist. i.e. number of rows ( or columns ) +! for which optional grid points are defined. This value +! is set to zero, if gfld%numoct_opt=0. +! gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0) +! gfld%ipdtmpl() = Contains the data values for the specified Product +! Definition Template ( N=gfdl%ipdtnum ). Each element +! of this integer array contains an entry (in the +! order specified) of Product Defintion Template 4.N. +! This element is actually a pointer to an array +! that holds the data. +! gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of +! entries in Product Defintion Template 4.N +! ( N=gfdl%ipdtnum ). +! gfld%coord_list() = Real array containing floating point values +! intended to document the vertical discretisation +! associated to model data on hybrid coordinate +! vertical levels. (part of Section 4) +! This element is actually a pointer to an array +! that holds the data. +! gfld%num_coord = number of values in array gfld%coord_list(). +! gfld%ndpts = Number of data points unpacked and returned. +! gfld%idrtnum = Data Representation Template Number +! ( see Code Table 5.0) +! gfld%idrtmpl() = Contains the data values for the specified Data +! Representation Template ( N=gfld%idrtnum ). Each +! element of this integer array contains an entry +! (in the order specified) of Product Defintion +! Template 5.N. +! This element is actually a pointer to an array +! that holds the data. +! gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number +! of entries in Data Representation Template 5.N +! ( N=gfld%idrtnum ). +! gfld%unpacked = logical value indicating whether the bitmap and +! data values were unpacked. If false, +! gfld%bmap and gfld%fld pointers are nullified. +! gfld%expanded = Logical value indicating whether the data field +! was expanded to the grid in the case where a +! bit-map is present. If true, the data points in +! gfld%fld match the grid points and zeros were +! inserted at grid points where data was bit-mapped +! out. If false, the data values in gfld%fld were +! not expanded to the grid and are just a consecutive +! array of data points corresponding to each value of +! "1" in gfld%bmap. +! gfld%ibmap = Bitmap indicator ( see Code Table 6.0 ) +! 0 = bitmap applies and is included in Section 6. +! 1-253 = Predefined bitmap applies +! 254 = Previously defined bitmap applies to this field +! 255 = Bit map does not apply to this product. +! gfld%bmap() = Logical*1 array containing decoded bitmap, +! if ibmap=0 or ibap=254. Otherwise nullified. +! This element is actually a pointer to an array +! that holds the data. +! gfld%fld() = Array of gfld%ndpts unpacked data points. +! This element is actually a pointer to an array +! that holds the data. +! ierr - Error return code. +! 0 = no error +! 1 = Beginning characters "GRIB" not found. +! 2 = GRIB message is not Edition 2. +! 3 = The data field request number was not positive. +! 4 = End string "7777" found, but not where expected. +! 6 = GRIB message did not contain the requested number of +! data fields. +! 7 = End string "7777" not found at end of message. +! 8 = Unrecognized Section encountered. +! 9 = Data Representation Template 5.NN not yet implemented. +! 15 = Error unpacking Section 1. +! 10 = Error unpacking Section 3. +! 11 = Error unpacking Section 4. +! 12 = Error unpacking Section 5. +! 13 = Error unpacking Section 6. +! 14 = Error unpacking Section 7. +! +! REMARKS: Note that derived type gribfield contains pointers to many +! arrays of data. The memory for these arrays is allocated +! when the values in the arrays are set, to help minimize +! problems with array overloading. Because of this users +! are encouraged to free up this memory, when it is no longer +! needed, by an explicit call to subroutine gf_free. +! ( i.e. CALL GF_FREE(GFLD) ) +! +! Subroutine gb_info can be used to first determine +! how many data fields exist in a given GRIB message. +! +! REMARKS2: It may not always be possible to expand a bit-mapped data field. +! If a pre-defined bit-map is used and not included in the GRIB2 +! message itself, this routine would not have the necessary +! information to expand the data. In this case, gfld%expanded would +! would be set to 0 (false), regardless of the value of input +! argument expand. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gf_free +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-26 +! +! ABSTRACT: This subroutine frees up memory that was used to store +! array values in derived type gribfield. +! +! PROGRAM HISTORY LOG: +! 2000-05-26 Gilbert +! +! USAGE: CALL gf_free(gfld) +! INPUT ARGUMENT LIST: +! gfld - derived type gribfield ( defined in module grib_mod ) +! +! OUTPUT ARGUMENT LIST: +! gfld - derived type gribfield ( defined in module grib_mod ) +! gfld%version = GRIB edition number +! gfld%discipline = Message Discipline ( see Code Table 0.0 ) +! gfld%idsect() = Contains the entries in the Identification +! Section ( Section 1 ) +! This element is actually a pointer to an array +! that holds the data. +! gfld%idsect(1) = Identification of originating Centre +! ( see Common Code Table C-1 ) +! gfld%idsect(2) = Identification of originating Sub-centre +! gfld%idsect(3) = GRIB Master Tables Version Number +! ( see Code Table 1.0 ) +! gfld%idsect(4) = GRIB Local Tables Version Number +! ( see Code Table 1.1 ) +! gfld%idsect(5) = Significance of Reference Time (Code Table 1.2) +! gfld%idsect(6) = Year ( 4 digits ) +! gfld%idsect(7) = Month +! gfld%idsect(8) = Day +! gfld%idsect(9) = Hour +! gfld%idsect(10) = Minute +! gfld%idsect(11) = Second +! gfld%idsect(12) = Production status of processed data +! ( see Code Table 1.3 ) +! gfld%idsect(13) = Type of processed data ( see Code Table 1.4 ) +! gfld%idsectlen = Number of elements in gfld%idsect(). +! gfld%ifldnum = field number within GRIB message +! gfld%griddef = Source of grid definition (see Code Table 3.0) +! gfld%ngrdpts = Number of grid points in the defined grid. +! gfld%numoct_opt = Number of octets needed for each +! additional grid points definition. +! Used to define number of +! points in each row ( or column ) for +! non-regular grids. +! = 0, if using regular grid. +! gfld%interp_opt = Interpretation of list for optional points +! definition. (Code Table 3.11) +! gfld%igdtnum = Grid Definition Template Number (Code Table 3.1) +! gfld%igdtmpl() = Contains the data values for the specified Grid +! Definition Template ( NN=gfld%igdtnum ). Each +! element of this integer array contains an entry (in +! the order specified) of Grid Defintion Template 3.NN +! This element is actually a pointer to an array +! that holds the data. +! gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of +! entries in Grid Defintion Template 3.NN +! ( NN=gfld%igdtnum ). +! gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array +! contains the number of grid points contained in +! each row ( or column ). (part of Section 3) +! This element is actually a pointer to an array +! that holds the data. This pointer is nullified +! if gfld%numoct_opt=0. +! gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries +! in array ideflist. i.e. number of rows ( or columns ) +! for which optional grid points are defined. This value +! is set to zero, if gfld%numoct_opt=0. +! gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0) +! gfld%ipdtmpl() = Contains the data values for the specified Product +! Definition Template ( N=gfdl%ipdtnum ). Each element +! of this integer array contains an entry (in the +! order specified) of Product Defintion Template 4.N. +! This element is actually a pointer to an array +! that holds the data. +! gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of +! entries in Product Defintion Template 4.N +! ( N=gfdl%ipdtnum ). +! gfld%coord_list() = Real array containing floating point values +! intended to document the vertical discretisation +! associated to model data on hybrid coordinate +! vertical levels. (part of Section 4) +! This element is actually a pointer to an array +! that holds the data. +! gfld%num_coord = number of values in array gfld%coord_list(). +! gfld%ndpts = Number of data points unpacked and returned. +! gfld%idrtnum = Data Representation Template Number +! ( see Code Table 5.0) +! gfld%idrtmpl() = Contains the data values for the specified Data +! Representation Template ( N=gfld%idrtnum ). Each +! element of this integer array contains an entry +! (in the order specified) of Product Defintion +! Template 5.N. +! This element is actually a pointer to an array +! that holds the data. +! gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number +! of entries in Data Representation Template 5.N +! ( N=gfld%idrtnum ). +! gfld%unpacked = logical value indicating whether the bitmap and +! data values were unpacked. If false, gfld%ndpts +! is set to zero, and gfld%bmap and gfld%fld +! pointers are nullified. +! gfld%expanded = Logical value indicating whether the data field +! was expanded to the grid in the case where a +! bit-map is present. If true, the data points in +! gfld%fld match the grid points and zeros were +! inserted at grid points where data was bit-mapped +! out. If false, the data values in gfld%fld were +! not expanded to the grid and are just a consecutive +! array of data points corresponding to each value of +! "1" in gfld%bmap. +! gfld%ibmap = Bitmap indicator ( see Code Table 6.0 ) +! 0 = bitmap applies and is included in Section 6. +! 1-253 = Predefined bitmap applies +! 254 = Previously defined bitmap applies to this field +! 255 = Bit map does not apply to this product. +! gfld%bmap() - Logical*1 array containing decoded bitmap, +! if ibmap=0 or ibap=254. Otherwise nullified. +! This element is actually a pointer to an array +! that holds the data. +! gfld%fld() = Array of gfld%ndpts unpacked data points. +! This element is actually a pointer to an array +! that holds the data. +! +! REMARKS: +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB2 FINDS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB FIELD REQUESTED. +C THE GRIB FIELD REQUEST SPECIFIES THE NUMBER OF FIELDS TO SKIP +C AND THE UNPACKED IDENTIFICATION SECTION, GRID DEFINITION TEMPLATE AND +C PRODUCT DEFINTION SECTION PARAMETERS. (A REQUESTED PARAMETER +C OF -9999 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB FIELD IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE AND UNPACKED. ITS NUMBER IS RETURNED ALONG WITH +C THE ASSOCIATED UNPACKED PARAMETERS. THE BITMAP (IF ANY), +C AND THE DATA VALUES ARE UNPACKED ONLY IF ARGUMENT "UNPACK" IS SET TO +C TRUE. IF THE GRIB FIELD IS NOT FOUND, THEN THE +C RETURN CODE WILL BE NONZERO. +C +C The decoded information for the selected GRIB field +C is returned in a derived type variable, gfld. +C Gfld is of type gribfield, which is defined +C in module grib_mod, so users of this routine will need to include +C the line "USE GRIB_MOD" in their calling routine. Each component of the +C gribfield type is described in the OUTPUT ARGUMENT LIST section below. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C 2002-01-11 GILBERT MODIFIED FROM GETGB AND GETGBM TO WORK WITH GRIB2 +C +C USAGE: CALL GETGB2(LUGB,LUGI,J,JDISC,JIDS,JPDTN,JPDT,JGDTN,JGDT, +C & UNPACK,K,GFLD,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE. +C FILE MUST BE OPENED WITH BAOPEN OR BAOPENR BEFORE CALLING +C THIS ROUTINE. +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE. +C IF NONZERO, FILE MUST BE OPENED WITH BAOPEN BAOPENR BEFORE +C CALLING THIS ROUTINE. +C >0 - READ INDEX FROM INDEX FILE LUGI, IF INDEX DOESN"T +C ALREADY EXIST. +C =0 - TO GET INDEX BUFFER FROM THE GRIB FILE, IF INDEX +C DOESN"T ALREADY EXIST. +C <0 - FORCE REREAD OF INDEX FROM INDEX FILE ABS(LUGI). +C =LUGB - FORCE REGENERATION OF INDEX FROM GRIB2 FILE LUGB. +C J INTEGER NUMBER OF FIELDS TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C JDISC GRIB2 DISCIPLINE NUMBER OF REQUESTED FIELD +C ( IF = -1, ACCEPT ANY DISCIPLINE) +C ( SEE CODE TABLE 0.0 ) +C 0 - Meteorological products +C 1 - Hydrological products +C 2 - Land surface products +C 3 - Space products +C 10 - Oceanographic products +C JIDS() INTEGER ARRAY OF VALUES IN THE IDENTIFICATION SECTION +C (=-9999 FOR WILDCARD) +C JIDS(1) = IDENTIFICATION OF ORIGINATING CENTRE +C ( SEE COMMON CODE TABLE C-1 ) +C JIDS(2) = IDENTIFICATION OF ORIGINATING SUB-CENTRE +C JIDS(3) = GRIB MASTER TABLES VERSION NUMBER +C ( SEE CODE TABLE 1.0 ) +C 0 - Experimental +C 1 - Initial operational version number +C JIDS(4) = GRIB LOCAL TABLES VERSION NUMBER +C ( SEE CODE TABLE 1.1 ) +C 0 - Local tables not used +C 1-254 - Number of local tables version used +C JIDS(5) = SIGNIFICANCE OF REFERENCE TIME (CODE TABLE 1.2) +C 0 - Analysis +C 1 - Start of forecast +C 2 - Verifying time of forecast +C 3 - Observation time +C JIDS(6) = YEAR ( 4 DIGITS ) +C JIDS(7) = MONTH +C JIDS(8) = DAY +C JIDS(9) = HOUR +C JIDS(10) = MINUTE +C JIDS(11) = SECOND +C JIDS(12) = PRODUCTION STATUS OF PROCESSED DATA +C ( SEE CODE TABLE 1.3 ) +C 0 - Operational products +C 1 - Operational test products +C 2 - Research products +C 3 - Re-analysis products +C JIDS(13) = TYPE OF PROCESSED DATA ( SEE CODE TABLE 1.4 ) +C 0 - Analysis products +C 1 - Forecast products +C 2 - Analysis and forecast products +C 3 - Control forecast products +C 4 - Perturbed forecast products +C 5 - Control and perturbed forecast products +C 6 - Processed satellite observations +C 7 - Processed radar observations +C JPDTN INTEGER PRODUCT DEFINITION TEMPLATE NUMBER (N) +C ( IF = -1, DON'T BOTHER MATCHING PDT - ACCEPT ANY ) +C JPDT() INTEGER ARRAY OF VALUES DEFINING THE PRODUCT DEFINITION +C TEMPLATE 4.N OF THE FIELD FOR WHICH TO SEARCH +C (=-9999 FOR WILDCARD) +C JGDTN INTEGER GRID DEFINITION TEMPLATE NUMBER (M) +C ( IF = -1, DON'T BOTHER MATCHING GDT - ACCEPT ANY ) +C JGDT() INTEGER ARRAY OF VALUES DEFINING THE GRID DEFINITION +C TEMPLATE 3.M OF THE FIELD FOR WHICH TO SEARCH +C (=-9999 FOR WILDCARD) +C UNPACK LOGICAL VALUE INDICATING WHETHER TO UNPACK BITMAP/DATA +C .TRUE. = UNPACK BITMAP AND DATA VALUES +C .FALSE. = DO NOT UNPACK BITMAP AND DATA VALUES +C +C OUTPUT ARGUMENTS: +C K INTEGER FIELD NUMBER UNPACKED +C gfld - derived type gribfield ( defined in module grib_mod ) +C ( NOTE: See Remarks Section ) +C gfld%version = GRIB edition number ( currently 2 ) +C gfld%discipline = Message Discipline ( see Code Table 0.0 ) +C gfld%idsect() = Contains the entries in the Identification +C Section ( Section 1 ) +C This element is actually a pointer to an array +C that holds the data. +C gfld%idsect(1) = Identification of originating Centre +C ( see Common Code Table C-1 ) +C 7 - US National Weather Service +C gfld%idsect(2) = Identification of originating Sub-centre +C gfld%idsect(3) = GRIB Master Tables Version Number +C ( see Code Table 1.0 ) +C 0 - Experimental +C 1 - Initial operational version number +C gfld%idsect(4) = GRIB Local Tables Version Number +C ( see Code Table 1.1 ) +C 0 - Local tables not used +C 1-254 - Number of local tables version used +C gfld%idsect(5) = Significance of Reference Time (Code Table 1.2) +C 0 - Analysis +C 1 - Start of forecast +C 2 - Verifying time of forecast +C 3 - Observation time +C gfld%idsect(6) = Year ( 4 digits ) +C gfld%idsect(7) = Month +C gfld%idsect(8) = Day +C gfld%idsect(9) = Hour +C gfld%idsect(10) = Minute +C gfld%idsect(11) = Second +C gfld%idsect(12) = Production status of processed data +C ( see Code Table 1.3 ) +C 0 - Operational products +C 1 - Operational test products +C 2 - Research products +C 3 - Re-analysis products +C gfld%idsect(13) = Type of processed data ( see Code Table 1.4 ) +C 0 - Analysis products +C 1 - Forecast products +C 2 - Analysis and forecast products +C 3 - Control forecast products +C 4 - Perturbed forecast products +C 5 - Control and perturbed forecast products +C 6 - Processed satellite observations +C 7 - Processed radar observations +C gfld%idsectlen = Number of elements in gfld%idsect(). +C gfld%local() = Pointer to character array containing contents +C of Local Section 2, if included +C gfld%locallen = length of array gfld%local() +C gfld%ifldnum = field number within GRIB message +C gfld%griddef = Source of grid definition (see Code Table 3.0) +C 0 - Specified in Code table 3.1 +C 1 - Predetermined grid Defined by originating centre +C gfld%ngrdpts = Number of grid points in the defined grid. +C gfld%numoct_opt = Number of octets needed for each +C additional grid points definition. +C Used to define number of +C points in each row ( or column ) for +C non-regular grids. +C = 0, if using regular grid. +C gfld%interp_opt = Interpretation of list for optional points +C definition. (Code Table 3.11) +C gfld%igdtnum = Grid Definition Template Number (Code Table 3.1) +C gfld%igdtmpl() = Contains the data values for the specified Grid +C Definition Template ( NN=gfld%igdtnum ). Each +C element of this integer array contains an entry (in +C the order specified) of Grid Defintion Template 3.NN +C This element is actually a pointer to an array +C that holds the data. +C gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of +C entries in Grid Defintion Template 3.NN +C ( NN=gfld%igdtnum ). +C gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array +C contains the number of grid points contained in +C each row ( or column ). (part of Section 3) +C This element is actually a pointer to an array +C that holds the data. This pointer is nullified +C if gfld%numoct_opt=0. +C gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries +C in array ideflist. i.e. number of rows ( or columns ) +C for which optional grid points are defined. This value +C is set to zero, if gfld%numoct_opt=0. +C gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0) +C gfld%ipdtmpl() = Contains the data values for the specified Product +C Definition Template ( N=gfdl%ipdtnum ). Each element +C of this integer array contains an entry (in the +C order specified) of Product Defintion Template 4.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of +C entries in Product Defintion Template 4.N +C ( N=gfdl%ipdtnum ). +C gfld%coord_list() = Real array containing floating point values +C intended to document the vertical discretisation +C associated to model data on hybrid coordinate +C vertical levels. (part of Section 4) +C This element is actually a pointer to an array +C that holds the data. +C gfld%num_coord = number of values in array gfld%coord_list(). +C gfld%ndpts = Number of data points unpacked and returned. +C gfld%idrtnum = Data Representation Template Number +C ( see Code Table 5.0) +C gfld%idrtmpl() = Contains the data values for the specified Data +C Representation Template ( N=gfld%idrtnum ). Each +C element of this integer array contains an entry +C (in the order specified) of Product Defintion +C Template 5.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number +C of entries in Data Representation Template 5.N +C ( N=gfld%idrtnum ). +C gfld%unpacked = logical value indicating whether the bitmap and +C data values were unpacked. If false, +C gfld%bmap and gfld%fld pointers are nullified. +C gfld%expanded = Logical value indicating whether the data field +C was expanded to the grid in the case where a +C bit-map is present. If true, the data points in +C gfld%fld match the grid points and zeros were +C inserted at grid points where data was bit-mapped +C out. If false, the data values in gfld%fld were +C not expanded to the grid and are just a consecutive +C array of data points corresponding to each value of +C "1" in gfld%bmap. +C gfld%ibmap = Bitmap indicator ( see Code Table 6.0 ) +C 0 = bitmap applies and is included in Section 6. +C 1-253 = Predefined bitmap applies +C 254 = Previously defined bitmap applies to this field +C 255 = Bit map does not apply to this product. +C gfld%bmap() = Logical*1 array containing decoded bitmap, +C if ibmap=0 or ibap=254. Otherwise nullified. +C This element is actually a pointer to an array +C that holds the data. +C gfld%fld() = Array of gfld%ndpts unpacked data points. +C This element is actually a pointer to an array +C that holds the data. +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX +C 97 ERROR READING GRIB FILE +C 99 REQUEST NOT FOUND +C OTHER GF_GETFLD GRIB2 UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C GETIDX GET INDEX +C GETGB2S SEARCH INDEX RECORDS +C GETGB2R READ AND UNPACK GRIB RECORD +C GF_FREE FREES MEMORY USED BY GFLD ( SEE REMARKS ) +C +C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C Note that derived type gribfield contains pointers to many +C arrays of data. The memory for these arrays is allocated +C when the values in the arrays are set, to help minimize +C problems with array overloading. Because of this users +C are encouraged to free up this memory, when it is no longer +C needed, by an explicit call to subroutine gf_free. +C ( i.e. CALL GF_FREE(GFLD) ) +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ diff --git a/WPS/ungrib/src/ngl/g2/gribcreate.f b/WPS/ungrib/src/ngl/g2/gribcreate.f new file mode 100755 index 00000000..88547aaa --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gribcreate.f @@ -0,0 +1,123 @@ + subroutine gribcreate(cgrib,lcgrib,listsec0,listsec1,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gribcreate +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-04-28 +! +! ABSTRACT: This subroutine initializes a new GRIB2 message and packs +! GRIB2 sections 0 (Indicator Section) and 1 (Identification Section). +! This routine is used with routines "addlocal", "addgrid", "addfield", +! and "gribend" to create a complete GRIB2 message. Subroutine +! gribcreate must be called first to initialize a new GRIB2 message. +! Also, a call to gribend is required to complete GRIB2 message +! after all fields have been added. +! +! PROGRAM HISTORY LOG: +! 2000-04-28 Gilbert +! +! USAGE: CALL gribcreate(cgrib,lcgrib,listsec0,listsec1,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lcgrib - Maximum length (bytes) of array cgrib. +! listsec0 - Contains information needed for GRIB Indicator Section 0. +! Must be dimensioned >= 2. +! listsec0(1)=Discipline-GRIB Master Table Number +! (see Code Table 0.0) +! listsec0(2)=GRIB Edition Number (currently 2) +! listsec1 - Contains information needed for GRIB Identification Section 1. +! Must be dimensioned >= 13. +! listsec1(1)=Id of orginating centre (Common Code Table C-1) +! listsec1(2)=Id of orginating sub-centre (local table) +! listsec1(3)=GRIB Master Tables Version Number (Code Table 1.0) +! listsec1(4)=GRIB Local Tables Version Number (Code Table 1.1) +! listsec1(5)=Significance of Reference Time (Code Table 1.2) +! listsec1(6)=Reference Time - Year (4 digits) +! listsec1(7)=Reference Time - Month +! listsec1(8)=Reference Time - Day +! listsec1(9)=Reference Time - Hour +! listsec1(10)=Reference Time - Minute +! listsec1(11)=Reference Time - Second +! listsec1(12)=Production status of data (Code Table 1.3) +! listsec1(13)=Type of processed data (Code Table 1.4) +! +! OUTPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! ierr - Error return code. +! 0 = no error +! 1 = Tried to use for version other than GRIB Edition 2 +! +! REMARKS: This routine is intended for use with routines "addlocal", +! "addgrid", "addfield", and "gribend" to create a complete +! GRIB2 message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(inout) :: cgrib(lcgrib) + integer,intent(in) :: listsec0(*),listsec1(*) + integer,intent(in) :: lcgrib + integer,intent(out) :: ierr + + character(len=4),parameter :: grib='GRIB' + integer,parameter :: zero=0,one=1 + integer,parameter :: mapsec1len=13 + integer,parameter :: + & mapsec1(mapsec1len)=(/ 2,2,1,1,1,2,1,1,1,1,1,1,1 /) + integer lensec0,iofst,ibeg + + ierr=0 +! +! Currently handles only GRIB Edition 2. +! + if (listsec0(2).ne.2) then + print *,'gribcreate: can only code GRIB edition 2.' + ierr=1 + return + endif +! +! Pack Section 0 - Indicator Section +! ( except for total length of GRIB message ) +! +! cgrib=' ' + cgrib(1)=grib(1:1) ! Beginning of GRIB message + cgrib(2)=grib(2:2) + cgrib(3)=grib(3:3) + cgrib(4)=grib(4:4) + call sbyte(cgrib,zero,32,16) ! reserved for future use + call sbyte(cgrib,listsec0(1),48,8) ! Discipline + call sbyte(cgrib,listsec0(2),56,8) ! GRIB edition number + lensec0=16 ! bytes (octets) +! +! Pack Section 1 - Identification Section +! + ibeg=lensec0*8 ! Calculate offset for beginning of section 1 + iofst=ibeg+32 ! leave space for length of section + call sbyte(cgrib,one,iofst,8) ! Store section number ( 1 ) + iofst=iofst+8 + ! + ! Pack up each input value in array listsec1 into the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mapsec1. + ! + do i=1,mapsec1len + nbits=mapsec1(i)*8 + call sbyte(cgrib,listsec1(i),iofst,nbits) + iofst=iofst+nbits + enddo + ! + ! Calculate length of section 1 and store it in octets + ! 1-4 of section 1. + ! + lensec1=(iofst-ibeg)/8 + call sbyte(cgrib,lensec1,ibeg,32) +! +! Put current byte total of message into Section 0 +! + call sbyte(cgrib,zero,64,32) + call sbyte(cgrib,lensec0+lensec1,96,32) + + return + end diff --git a/WPS/ungrib/src/ngl/g2/gribend.f b/WPS/ungrib/src/ngl/g2/gribend.f new file mode 100755 index 00000000..c59c0634 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gribend.f @@ -0,0 +1,126 @@ + subroutine gribend(cgrib,lcgrib,lengrib,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gribend +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-02 +! +! ABSTRACT: This subroutine finalizes a GRIB message after all grids +! and fields have been added. It adds the End Section ( "7777" ) +! to the end of the GRIB message and calculates the length and stores +! it in the appropriate place in Section 0. +! This routine is used with routines "gribcreate", "addlocal", "addgrid", +! and "addfield" to create a complete GRIB2 message. Subroutine +! gribcreate must be called first to initialize a new GRIB2 message. +! +! PROGRAM HISTORY LOG: +! 2000-05-02 Gilbert +! +! USAGE: CALL gribend(cgrib,lcgrib,lengrib,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lcgrib - Maximum length (bytes) of array cgrib. +! +! OUTPUT ARGUMENT LIST: +! cgrib - Character array to contain the GRIB2 message +! lengrib - Length of the final GRIB2 message in octets (bytes) +! ierr - Error return code. +! 0 = no error +! 1 = GRIB message was not initialized. Need to call +! routine gribcreate first. +! 2 = GRIB message already complete. +! 3 = Sum of Section byte counts doesn't add to total byte count. +! 4 = Previous Section was not 7. +! +! REMARKS: This routine is intended for use with routines "gribcreate", +! "addlocal", "addgrid", and "addfield" to create a complete +! GRIB2 message. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(inout) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(out) :: lengrib,ierr + + character(len=4),parameter :: grib='GRIB',c7777='7777' + character(len=4):: ctemp + integer iofst,ibeg,lencurr,len + + ierr=0 +! +! Check to see if beginning of GRIB message exists +! + ctemp=cgrib(1)//cgrib(2)//cgrib(3)//cgrib(4) + if ( ctemp.ne.grib ) then + print *,'gribend: GRIB not found in given message.' + ierr=1 + return + endif +! +! Get current length of GRIB message +! + call gbyte(cgrib,lencurr,96,32) +! +! Check to see if GRIB message is already complete +! +! ctemp=cgrib(lencurr-3)//cgrib(lencurr-2)//cgrib(lencurr-1) +! & //cgrib(lencurr) +! if ( ctemp.eq.c7777 ) then +! print *,'gribend: GRIB message already complete.' +! ierr=2 +! return +! endif +! +! Loop through all current sections of the GRIB message to +! find the last section number. +! + len=16 ! Length of Section 0 + do + ! Get number and length of next section + iofst=len*8 + call gbyte(cgrib,ilen,iofst,32) + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) + len=len+ilen + ! Exit loop if last section reached + if ( len.eq.lencurr ) exit + ! If byte count for each section doesn't match current + ! total length, then there is a problem. + if ( len.gt.lencurr ) then + print *,'gribend: Section byte counts don''t add to total.' + print *,'gribend: Sum of section byte counts = ',len + print *,'gribend: Total byte count in Section 0 = ',lencurr + ierr=3 + return + endif + enddo +! +! Can only add End Section (Section 8) after Section 7. +! + if ( isecnum.ne.7 ) then + print *,'gribend: Section 8 can only be added after Section 7.' + print *,'gribend: Section ',isecnum,' was the last found in', + & ' given GRIB message.' + ierr=4 + return + endif +! +! Add Section 8 - End Section +! + cgrib(lencurr+1:lencurr+4)=c7777 + +! +! Update current byte total of message in Section 0 +! + lengrib=lencurr+4 + call sbyte(cgrib,lengrib,96,32) + + return + end + + + + diff --git a/WPS/ungrib/src/ngl/g2/gribinfo.f b/WPS/ungrib/src/ngl/g2/gribinfo.f new file mode 100755 index 00000000..6f77b82a --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gribinfo.f @@ -0,0 +1,243 @@ + subroutine gribinfo(cgrib,lcgrib,listsec0,listsec1, + & numlocal,numfields,maxvals,ierr) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: gribinfo +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-25 +! +! ABSTRACT: This subroutine searches through a GRIB2 message and +! returns the number of Local Use Sections and number of gridded +! fields found in the message. It also performs various checks +! to see if the message is a valid GRIB2 message. +! Last, a list of safe array dimensions is returned for use in +! allocating return arrays from routines getlocal, gettemplates, and +! getfields. (See maxvals and REMARKS) +! +! PROGRAM HISTORY LOG: +! 2000-05-25 Gilbert +! +! USAGE: CALL gribinfo(cgrib,lcgrib,listsec0,listsec1, +! & numlocal,numfields,ierr) +! INPUT ARGUMENT LIST: +! cgrib - Character array that contains the GRIB2 message +! lcgrib - Length (in bytes) of GRIB message in array cgrib. +! +! OUTPUT ARGUMENT LIST: +! listsec0 - Contains information decoded from GRIB Indicator Section 0. +! Must be dimensioned >= 2. +! listsec0(1)=Discipline-GRIB Master Table Number +! (see Code Table 0.0) +! listsec0(2)=GRIB Edition Number (currently 2) +! listsec0(3)=Length of GRIB message +! listsec1 - Contains information read from GRIB Identification Section 1. +! Must be dimensioned >= 13. +! listsec1(1)=Id of orginating centre (Common Code Table C-1) +! listsec1(2)=Id of orginating sub-centre (local table) +! listsec1(3)=GRIB Master Tables Version Number (Code Table 1.0) +! listsec1(4)=GRIB Local Tables Version Number +! listsec1(5)=Significance of Reference Time (Code Table 1.1) +! listsec1(6)=Reference Time - Year (4 digits) +! listsec1(7)=Reference Time - Month +! listsec1(8)=Reference Time - Day +! listsec1(9)=Reference Time - Hour +! listsec1(10)=Reference Time - Minute +! listsec1(11)=Reference Time - Second +! listsec1(12)=Production status of data (Code Table 1.2) +! listsec1(13)=Type of processed data (Code Table 1.3) +! numlocal - The number of Local Use Sections ( Section 2 ) found in +! the GRIB message. +! numfields- The number of gridded fieldse found in the GRIB message. +! maxvals()- The maximum number of elements that could be returned +! in various arrays from this GRIB2 message. (see REMARKS) +! maxvals(1)=max length of local section 2 (for getlocal) +! maxvals(2)=max length of GDS Template (for gettemplates +! and getfield) +! maxvals(3)=max length of GDS Optional list (for getfield) +! maxvals(4)=max length of PDS Template (for gettemplates +! and getfield) +! maxvals(5)=max length of PDS Optional list (for getfield) +! maxvals(6)=max length of DRS Template (for gettemplates +! and getfield) +! maxvals(7)=max number of gridpoints (for getfield) +! ierr - Error return code. +! 0 = no error +! 1 = Beginning characters "GRIB" not found. +! 2 = GRIB message is not Edition 2. +! 3 = Could not find Section 1, where expected. +! 4 = End string "7777" found, but not where expected. +! 5 = End string "7777" not found at end of message. +! +! REMARKS: Array maxvals contains the maximum possible +! number of values that will be returned in argument arrays +! for routines getlocal, gettemplates, and getfields. +! Users can use this info to determine if their arrays are +! dimensioned large enough for the data that may be returned +! from the above routines, or to dynamically allocate arrays +! with a reasonable size. +! NOTE that the actual number of values in these arrays is returned +! from the routines and will likely be less than the values +! calculated by this routine. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cgrib(lcgrib) + integer,intent(in) :: lcgrib + integer,intent(out) :: listsec0(3),listsec1(13),maxvals(7) + integer,intent(out) :: numlocal,numfields,ierr + + character(len=4),parameter :: grib='GRIB',c7777='7777' + character(len=4) :: ctemp + integer,parameter :: zero=0,one=1 + integer,parameter :: mapsec1len=13 + integer,parameter :: + & mapsec1(mapsec1len)=(/ 2,2,1,1,1,2,1,1,1,1,1,1,1 /) + integer iofst,ibeg,istart + + ierr=0 + numlocal=0 + numfields=0 + maxsec2len=1 + maxgdstmpl=1 + maxdeflist=1 + maxpdstmpl=1 + maxcoordlist=1 + maxdrstmpl=1 + maxgridpts=0 +! +! Check for beginning of GRIB message in the first 100 bytes +! + istart=0 + do j=1,100 + ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3) + if (ctemp.eq.grib ) then + istart=j + exit + endif + enddo + if (istart.eq.0) then + print *,'gribinfo: Beginning characters GRIB not found.' + ierr=1 + return + endif +! +! Unpack Section 0 - Indicator Section +! + iofst=8*(istart+5) + call gbyte(cgrib,listsec0(1),iofst,8) ! Discipline + iofst=iofst+8 + call gbyte(cgrib,listsec0(2),iofst,8) ! GRIB edition number + iofst=iofst+8 + iofst=iofst+32 + call gbyte(cgrib,lengrib,iofst,32) ! Length of GRIB message + iofst=iofst+32 + listsec0(3)=lengrib + lensec0=16 + ipos=istart+lensec0 +! +! Currently handles only GRIB Edition 2. +! + if (listsec0(2).ne.2) then + print *,'gribinfo: can only decode GRIB edition 2.' + ierr=2 + return + endif +! +! Unpack Section 1 - Identification Section +! + call gbyte(cgrib,lensec1,iofst,32) ! Length of Section 1 + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) ! Section number ( 1 ) + iofst=iofst+8 + if (isecnum.ne.1) then + print *,'gribinfo: Could not find section 1.' + ierr=3 + return + endif + ! + ! Unpack each input value in array listsec1 into the + ! the appropriate number of octets, which are specified in + ! corresponding entries in array mapsec1. + ! + do i=1,mapsec1len + nbits=mapsec1(i)*8 + call gbyte(cgrib,listsec1(i),iofst,nbits) + iofst=iofst+nbits + enddo + ipos=ipos+lensec1 +! +! Loop through the remaining sections keeping track of the +! length of each. Also count the number of times Section 2 +! and Section 4 appear. +! + do + ctemp=cgrib(ipos)//cgrib(ipos+1)//cgrib(ipos+2)//cgrib(ipos+3) + if (ctemp.eq.c7777 ) then + ipos=ipos+4 + if (ipos.ne.(istart+lengrib)) then + print *,'gribinfo: "7777" found, but not where expected.' + ierr=4 + return + endif + exit + endif + iofst=(ipos-1)*8 + call gbyte(cgrib,lensec,iofst,32) ! Get Length of Section + iofst=iofst+32 + call gbyte(cgrib,isecnum,iofst,8) ! Get Section number + iofst=iofst+8 + ipos=ipos+lensec ! Update beginning of section pointer + if (ipos.gt.(istart+lengrib)) then + print *,'gribinfo: "7777" not found at end of GRIB message.' + ierr=5 + return + endif + if (isecnum.eq.2) then ! Local Section 2 + ! increment counter for total number of local sections found + ! and determine largest Section 2 in message + numlocal=numlocal+1 + lenposs=lensec-5 + if ( lenposs.gt.maxsec2len ) maxsec2len=lenposs + elseif (isecnum.eq.3) then + iofst=iofst+8 ! skip source of grid def. + call gbyte(cgrib,ngdpts,iofst,32) ! Get Num of Grid Points + iofst=iofst+32 + call gbyte(cgrib,nbyte,iofst,8) ! Get Num octets for opt. list + iofst=iofst+8 + if (ngdpts.gt.maxgridpts) maxgridpts=ngdpts + lenposs=lensec-14 + if ( lenposs.gt.maxgdstmpl ) maxgdstmpl=lenposs + if (nbyte.ne.0) then + lenposs=lenposs/nbyte + if ( lenposs.gt.maxdeflist ) maxdeflist=lenposs + endif + elseif (isecnum.eq.4) then + numfields=numfields+1 + call gbyte(cgrib,numcoord,iofst,16) ! Get Num of Coord Values + iofst=iofst+16 + if (numcoord.ne.0) then + if (numcoord.gt.maxcoordlist) maxcoordlist=numcoord + endif + lenposs=lensec-9 + if ( lenposs.gt.maxpdstmpl ) maxpdstmpl=lenposs + elseif (isecnum.eq.5) then + lenposs=lensec-11 + if ( lenposs.gt.maxdrstmpl ) maxdrstmpl=lenposs + endif + + enddo + + maxvals(1)=maxsec2len + maxvals(2)=maxgdstmpl + maxvals(3)=maxdeflist + maxvals(4)=maxpdstmpl + maxvals(5)=maxcoordlist + maxvals(6)=maxdrstmpl + maxvals(7)=maxgridpts + + return + end + diff --git a/WPS/ungrib/src/ngl/g2/gribmod.f b/WPS/ungrib/src/ngl/g2/gribmod.f new file mode 100755 index 00000000..eb532a48 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gribmod.f @@ -0,0 +1,199 @@ + module grib_mod +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! MODULE: grib_mod +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-01-23 +! +! ABSTRACT: This Fortran Module contains the declaration +! of derived type gribfield. +! If variable gfld is declared of type gribfield +! ( i.e. TYPE(GRIBFIELD) :: GFLD ), it would have the following componenets: +! +! gfld%version = GRIB edition number ( currently 2 ) +! gfld%discipline = Message Discipline ( see Code Table 0.0 ) +! gfld%idsect() = Contains the entries in the Identification +! Section ( Section 1 ) +! This element is actually a pointer to an array +! that holds the data. +! gfld%idsect(1) = Identification of originating Centre +! ( see Common Code Table C-1 ) +! 7 - US National Weather Service +! gfld%idsect(2) = Identification of originating Sub-centre +! gfld%idsect(3) = GRIB Master Tables Version Number +! ( see Code Table 1.0 ) +! 0 - Experimental +! 1 - Initial operational version number +! gfld%idsect(4) = GRIB Local Tables Version Number +! ( see Code Table 1.1 ) +! 0 - Local tables not used +! 1-254 - Number of local tables version used +! gfld%idsect(5) = Significance of Reference Time (Code Table 1.2) +! 0 - Analysis +! 1 - Start of forecast +! 2 - Verifying time of forecast +! 3 - Observation time +! gfld%idsect(6) = Year ( 4 digits ) +! gfld%idsect(7) = Month +! gfld%idsect(8) = Day +! gfld%idsect(9) = Hour +! gfld%idsect(10) = Minute +! gfld%idsect(11) = Second +! gfld%idsect(12) = Production status of processed data +! ( see Code Table 1.3 ) +! 0 - Operational products +! 1 - Operational test products +! 2 - Research products +! 3 - Re-analysis products +! gfld%idsect(13) = Type of processed data ( see Code Table 1.4 ) +! 0 - Analysis products +! 1 - Forecast products +! 2 - Analysis and forecast products +! 3 - Control forecast products +! 4 - Perturbed forecast products +! 5 - Control and perturbed forecast products +! 6 - Processed satellite observations +! 7 - Processed radar observations +! gfld%idsectlen = Number of elements in gfld%idsect(). +! gfld%local() = Pointer to character array containing contents +! of Local Section 2, if included +! gfld%locallen = length of array gfld%local() +! gfld%ifldnum = field number within GRIB message +! gfld%griddef = Source of grid definition (see Code Table 3.0) +! 0 - Specified in Code table 3.1 +! 1 - Predetermined grid Defined by originating centre +! gfld%ngrdpts = Number of grid points in the defined grid. +! gfld%numoct_opt = Number of octets needed for each +! additional grid points definition. +! Used to define number of +! points in each row ( or column ) for +! non-regular grids. +! = 0, if using regular grid. +! gfld%interp_opt = Interpretation of list for optional points +! definition. (Code Table 3.11) +! gfld%igdtnum = Grid Definition Template Number (Code Table 3.1) +! gfld%igdtmpl() = Contains the data values for the specified Grid +! Definition Template ( NN=gfld%igdtnum ). Each +! element of this integer array contains an entry (in +! the order specified) of Grid Defintion Template 3.NN +! This element is actually a pointer to an array +! that holds the data. +! gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of +! entries in Grid Defintion Template 3.NN +! ( NN=gfld%igdtnum ). +! gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array +! contains the number of grid points contained in +! each row ( or column ). (part of Section 3) +! This element is actually a pointer to an array +! that holds the data. This pointer is nullified +! if gfld%numoct_opt=0. +! gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries +! in array ideflist. i.e. number of rows ( or columns ) +! for which optional grid points are defined. This value +! is set to zero, if gfld%numoct_opt=0. +! gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0) +! gfld%ipdtmpl() = Contains the data values for the specified Product +! Definition Template ( N=gfdl%ipdtnum ). Each element +! of this integer array contains an entry (in the +! order specified) of Product Defintion Template 4.N. +! This element is actually a pointer to an array +! that holds the data. +! gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of +! entries in Product Defintion Template 4.N +! ( N=gfdl%ipdtnum ). +! gfld%coord_list() = Real array containing floating point values +! intended to document the vertical discretisation +! associated to model data on hybrid coordinate +! vertical levels. (part of Section 4) +! This element is actually a pointer to an array +! that holds the data. +! gfld%num_coord = number of values in array gfld%coord_list(). +! gfld%ndpts = Number of data points unpacked and returned. +! gfld%idrtnum = Data Representation Template Number +! ( see Code Table 5.0) +! gfld%idrtmpl() = Contains the data values for the specified Data +! Representation Template ( N=gfld%idrtnum ). Each +! element of this integer array contains an entry +! (in the order specified) of Product Defintion +! Template 5.N. +! This element is actually a pointer to an array +! that holds the data. +! gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number +! of entries in Data Representation Template 5.N +! ( N=gfld%idrtnum ). +! gfld%unpacked = logical value indicating whether the bitmap and +! data values were unpacked. If false, +! gfld%bmap and gfld%fld pointers are nullified. +! gfld%expanded = Logical value indicating whether the data field +! was expanded to the grid in the case where a +! bit-map is present. If true, the data points in +! gfld%fld match the grid points and zeros were +! inserted at grid points where data was bit-mapped +! out. If false, the data values in gfld%fld were +! not expanded to the grid and are just a consecutive +! array of data points corresponding to each value of +! "1" in gfld%bmap. +! gfld%ibmap = Bitmap indicator ( see Code Table 6.0 ) +! 0 = bitmap applies and is included in Section 6. +! 1-253 = Predefined bitmap applies +! 254 = Previously defined bitmap applies to this field +! 255 = Bit map does not apply to this product. +! gfld%bmap() = Logical*1 array containing decoded bitmap, +! if ibmap=0 or ibap=254. Otherwise nullified. +! This element is actually a pointer to an array +! that holds the data. +! gfld%fld() = Array of gfld%ndpts unpacked data points. +! This element is actually a pointer to an array +! that holds the data. +! +! +! PROGRAM HISTORY LOG: +! 2002-01-23 Gilbert +! 2007-04-24 Vuong - Added GDT 3.204 Curvilinear Orthogonal Grids +! 2008-05-29 Vuong - Added GDT 3.32768 Rotate Lat/Lon E-grid +! 2009-02-17 Vuong - Allow negative scale factors and limits for +! Templates 4.5 and 4.9 +! 2009-12-14 Vuong - Fixed bug in routine getidx.f +! - Modified to increase length of seek(512) +! - Added Templates (Satellite Product) 4.31 +! - Added Templates (ICAO WAFS) 4.15 +! 2013-05-07 Vuong - Initialized all pointers to null() +! 2013-08-29 Vuong - Changed version number 2.5.0 ) +! 2015-11-01 Vuong - Changed version number 2.6.0 +! 2017-18-01 Vuong - Changed version number 3.1.0 +! +! USAGE: use grib_mod +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=12) :: G2_VERSION="g2lib-3.1.0" + + type gribfield + integer :: version,discipline + integer,pointer,dimension(:) :: idsect => null () + integer :: idsectlen + character(len=1),pointer,dimension(:) :: local => null () + integer :: locallen + integer :: ifldnum + integer :: griddef,ngrdpts + integer :: numoct_opt,interp_opt,num_opt + integer,pointer,dimension(:) :: list_opt => null () + integer :: igdtnum,igdtlen + integer,pointer,dimension(:) :: igdtmpl => null () + integer :: ipdtnum,ipdtlen + integer,pointer,dimension(:) :: ipdtmpl => null () + integer :: num_coord + real,pointer,dimension(:) :: coord_list => null () + integer :: ndpts,idrtnum,idrtlen + integer,pointer,dimension(:) :: idrtmpl => null () + logical :: unpacked + logical :: expanded + integer :: ibmap + logical*1,pointer,dimension(:) :: bmap => null () + real,pointer,dimension(:) :: fld => null () + end type gribfield + + end module diff --git a/WPS/ungrib/src/ngl/g2/gridtemplates.f b/WPS/ungrib/src/ngl/g2/gridtemplates.f new file mode 100755 index 00000000..6b5fb4e3 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/gridtemplates.f @@ -0,0 +1,488 @@ + module gridtemplates +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! MODULE: gridtemplates +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-09 +! +! ABSTRACT: This Fortran Module contains info on all the available +! GRIB2 Grid Definition Templates used in Section 3 (GDS). +! Each Template has three parts: The number of entries in the template +! (mapgridlen); A map of the template (mapgrid), which contains the +! number of octets in which to pack each of the template values; and +! a logical value (needext) that indicates whether the Template needs +! to be extended. In some cases the number of entries in a template +! can vary depending upon values specified in the "static" part of +! the template. ( See Template 3.120 as an example ) +! +! This module also contains two subroutines. Subroutine getgridtemplate +! returns the octet map for a specified Template number, and +! subroutine extgridtemplate will calculate the extended octet map +! of an appropriate template given values for the "static" part of the +! template. See docblocks below for the arguments and usage of these +! routines. +! +! NOTE: Array mapgrid contains the number of octets in which the +! corresponding template values will be stored. A negative value in +! mapgrid is used to indicate that the corresponding template entry can +! contain negative values. This information is used later when packing +! (or unpacking) the template data values. Negative data values in GRIB +! are stored with the left most bit set to one, and a negative number +! of octets value in mapgrid() indicates that this possibility should +! be considered. The number of octets used to store the data value +! in this case would be the absolute value of the negative value in +! mapgrid(). +! +! +! PROGRAM HISTORY LOG: +! 2000-05-09 Gilbert +! 2003-09-02 Gilbert - Added GDT 3.31 - Albers Equal Area +! 2007-04-24 Vuong - Added GDT 3.204 Curilinear Orthogonal Grids +! 2008-05-29 Vuong - Added GDT 3.32768 Rotate Lat/Lon E-grid +! 2010-05-10 Vuong - Added GDT 3.32769 Rotate Lat/Lon Non E-Stagger grid +! 2013-08-06 Vuong - Added GDT 3.4,3.5,3.12,3.101,3.140 +! +! USAGE: use gridtemplates +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + integer,parameter :: MAXLEN=200,MAXTEMP=31 + + type gridtemplate + integer :: template_num + integer :: mapgridlen + integer,dimension(MAXLEN) :: mapgrid + logical :: needext + end type gridtemplate + + type(gridtemplate),dimension(MAXTEMP) :: templates + + data templates(1)%template_num /0/ ! Lat/Lon + data templates(1)%mapgridlen /19/ + data templates(1)%needext /.false./ + data (templates(1)%mapgrid(j),j=1,19) + & /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1/ + + data templates(2)%template_num /1/ ! Rotated Lat/Lon + data templates(2)%mapgridlen /22/ + data templates(2)%needext /.false./ + data (templates(2)%mapgrid(j),j=1,22) + & /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,4/ + + data templates(3)%template_num /2/ ! Stretched Lat/Lon + data templates(3)%mapgridlen /22/ + data templates(3)%needext /.false./ + data (templates(3)%mapgrid(j),j=1,22) + & /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,-4/ + + data templates(4)%template_num /3/ ! Stretched & Rotated Lat/Lon + data templates(4)%mapgridlen /25/ + data templates(4)%needext /.false./ + data (templates(4)%mapgrid(j),j=1,25) + & /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,4,-4,4,-4/ + + data templates(5)%template_num /10/ ! Mercator + data templates(5)%mapgridlen /19/ + data templates(5)%needext /.false./ + data (templates(5)%mapgrid(j),j=1,19) + & /1,1,4,1,4,1,4,4,4,-4,4,1,-4,-4,4,1,4,4,4/ + + data templates(6)%template_num /20/ ! Polar Stereographic + data templates(6)%mapgridlen /18/ + data templates(6)%needext /.false./ + data (templates(6)%mapgrid(j),j=1,18) + & /1,1,4,1,4,1,4,4,4,-4,4,1,-4,4,4,4,1,1/ + + data templates(7)%template_num /30/ ! Lambert Conformal + data templates(7)%mapgridlen /22/ + data templates(7)%needext /.false./ + data (templates(7)%mapgrid(j),j=1,22) + & /1,1,4,1,4,1,4,4,4,-4,4,1,-4,4,4,4,1,1,-4,-4,-4,4/ + + data templates(8)%template_num /40/ ! Gaussian Lat/Lon + data templates(8)%mapgridlen /19/ + data templates(8)%needext /.false./ + data (templates(8)%mapgrid(j),j=1,19) + & /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1/ + + data templates(9)%template_num /41/ ! Rotated Gaussian Lat/Lon + data templates(9)%mapgridlen /22/ + data templates(9)%needext /.false./ + data (templates(9)%mapgrid(j),j=1,22) + & /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,4/ + + data templates(10)%template_num /42/ ! Stretched Gaussian Lat/Lon + data templates(10)%mapgridlen /22/ + data templates(10)%needext /.false./ + data (templates(10)%mapgrid(j),j=1,22) + & /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,-4/ + + data templates(11)%template_num /43/ ! Strtchd and Rot'd Gaus Lat/Lon + data templates(11)%mapgridlen /25/ + data templates(11)%needext /.false./ + data (templates(11)%mapgrid(j),j=1,25) + & /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,-4,4,4,-4,4,-4/ + + data templates(12)%template_num /50/ ! Spherical Harmonic Coefficients + data templates(12)%mapgridlen /5/ + data templates(12)%needext /.false./ + data (templates(12)%mapgrid(j),j=1,5) /4,4,4,1,1/ + + data templates(13)%template_num /51/ ! Rotated Spherical Harmonic Coeff + data templates(13)%mapgridlen /8/ + data templates(13)%needext /.false./ + data (templates(13)%mapgrid(j),j=1,8) /4,4,4,1,1,-4,4,4/ + + data templates(14)%template_num /52/ ! Stretch Spherical Harmonic Coeff + data templates(14)%mapgridlen /8/ + data templates(14)%needext /.false./ + data (templates(14)%mapgrid(j),j=1,8) /4,4,4,1,1,-4,4,-4/ + + data templates(15)%template_num /53/ ! Strch and Rot Spher Harm Coeffs + data templates(15)%mapgridlen /11/ + data templates(15)%needext /.false./ + data (templates(15)%mapgrid(j),j=1,11) /4,4,4,1,1,-4,4,4,-4,4,-4/ + + data templates(16)%template_num /90/ ! Space view Perspective + data templates(16)%mapgridlen /21/ + data templates(16)%needext /.false./ + data (templates(16)%mapgrid(j),j=1,21) + & /1,1,4,1,4,1,4,4,4,-4,4,1,4,4,4,4,1,4,4,4,4/ + + data templates(17)%template_num /100/ ! Triangular grid (icosahedron) + data templates(17)%mapgridlen /11/ + data templates(17)%needext /.false./ + data (templates(17)%mapgrid(j),j=1,11) /1,1,2,1,-4,4,4,1,1,1,4/ + + data templates(18)%template_num /110/ ! Equatorial Azimuthal equidistant + data templates(18)%mapgridlen /16/ + data templates(18)%needext /.false./ + data (templates(18)%mapgrid(j),j=1,16) + & /1,1,4,1,4,1,4,4,4,-4,4,1,4,4,1,1/ + + data templates(19)%template_num /120/ ! Azimuth-range + data templates(19)%mapgridlen /7/ + data templates(19)%needext /.true./ + data (templates(19)%mapgrid(j),j=1,7) /4,4,-4,4,4,4,1/ + + data templates(20)%template_num /1000/ ! Cross Section Grid + data templates(20)%mapgridlen /20/ + data templates(20)%needext /.true./ + data (templates(20)%mapgrid(j),j=1,20) + & /1,1,4,1,4,1,4,4,4,4,-4,4,1,4,4,1,2,1,1,2/ + + data templates(21)%template_num /1100/ ! Hovmoller Diagram Grid + data templates(21)%mapgridlen /28/ + data templates(21)%needext /.false./ + data (templates(21)%mapgrid(j),j=1,28) + & /1,1,4,1,4,1,4,4,4,4,-4,4,1,-4,4,1,4,1,-4,1,1,-4,2,1,1,1,1,1/ + + data templates(22)%template_num /1200/ ! Time Section Grid + data templates(22)%mapgridlen /16/ + data templates(22)%needext /.true./ + data (templates(22)%mapgrid(j),j=1,16) + & /4,1,-4,1,1,-4,2,1,1,1,1,1,2,1,1,2/ + + data templates(23)%template_num /31/ ! Albers Equal Area + data templates(23)%mapgridlen /22/ + data templates(23)%needext /.false./ + data (templates(23)%mapgrid(j),j=1,22) + & /1,1,4,1,4,1,4,4,4,-4,4,1,-4,4,4,4,1,1,-4,-4,-4,4/ + + data templates(24)%template_num /204/ ! Curilinear Orthogonal Grids + data templates(24)%mapgridlen /19/ + data templates(24)%needext /.false./ + data (templates(24)%mapgrid(j),j=1,19) + & /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1/ + + data templates(25)%template_num /32768/ ! Rotate Lat/Lon E-grid + data templates(25)%mapgridlen /19/ + data templates(25)%needext /.false./ + data (templates(25)%mapgrid(j),j=1,19) + & /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1/ + + data templates(26)%template_num /32769/ ! Rotate Lat/Lon Non-E Stagger grid + data templates(26)%mapgridlen /21/ + data templates(26)%needext /.false./ + data (templates(26)%mapgrid(j),j=1,21) + & /1,1,4,1,4,1,4,4,4,4,4,-4,4,1,-4,4,4,4,1,4,4/ +! +! GDT 3.4 Added (08/05/2013) +! + data templates(27)%template_num /4/ ! Variable resolution Latitude/Longitude + data templates(27)%mapgridlen /13/ + data templates(27)%needext /.true./ + data (templates(27)%mapgrid(j),j=1,13) + & /1,1,4,1,4,1,4,4,4,4,4,1,1/ +! +! GDT 3.5 Added (08/05/2013) +! + data templates(28)%template_num /5/ ! Variable resolution rotate Latitude/Longitude + data templates(28)%mapgridlen /16/ + data templates(28)%needext /.true./ + data (templates(28)%mapgrid(j),j=1,16) + & /1,1,4,1,4,1,4,4,4,4,4,1,1,-4,4,4/ +! +! GDT 3.12 Added (08/05/2013) +! + data templates(29)%template_num /12/ ! Transverse Mercator + data templates(29)%mapgridlen /22/ + data templates(29)%needext /.false./ + data (templates(29)%mapgrid(j),j=1,22) + & /1,1,4,1,4,1,4,4,4,-4,4,1,-4,4,4,1,4,4,-4,-4,-4,-4/ +! +! GDT 3.101 Added (08/05/2013) +! + data templates(30)%template_num /101/ ! General unstructured grid + data templates(30)%mapgridlen /4/ + data templates(30)%needext /.false./ + data (templates(30)%mapgrid(j),j=1,4) + & /1,4,1,-4/ +! +! GDT 3.140 Added (08/05/2013) +! + data templates(31)%template_num /140/ ! Lambert Azimuthal Equal Area Projection + data templates(31)%mapgridlen /17/ + data templates(31)%needext /.false./ + data (templates(31)%mapgrid(j),j=1,17) + & /1,1,4,1,4,1,4,4,4,-4,4,4,4,1,4,4,1/ + + contains + + + integer function getgridindex(number) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getgridindex +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2001-06-28 +! +! ABSTRACT: This function returns the index of specified Grid +! Definition Template 3.NN (NN=number) in array templates. +! +! PROGRAM HISTORY LOG: +! 2001-06-28 Gilbert +! +! USAGE: index=getgridindex(number) +! INPUT ARGUMENT LIST: +! number - NN, indicating the number of the Grid Definition +! Template 3.NN that is being requested. +! +! RETURNS: Index of GDT 3.NN in array templates, if template exists. +! = -1, otherwise. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: number + + getgridindex=-1 + + do j=1,MAXTEMP + if (number.eq.templates(j)%template_num) then + getgridindex=j + return + endif + enddo + + end function + + + subroutine getgridtemplate(number,nummap,map,needext,iret) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getgridtemplate +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-09 +! +! ABSTRACT: This subroutine returns grid template information for a +! specified Grid Definition Template 3.NN. +! The number of entries in the template is returned along with a map +! of the number of octets occupied by each entry. Also, a flag is +! returned to indicate whether the template would need to be extended. +! +! PROGRAM HISTORY LOG: +! 2000-05-09 Gilbert +! +! USAGE: CALL getgridtemplate(number,nummap,map,needext,iret) +! INPUT ARGUMENT LIST: +! number - NN, indicating the number of the Grid Definition +! Template 3.NN that is being requested. +! +! OUTPUT ARGUMENT LIST: +! nummap - Number of entries in the Template +! map() - An array containing the number of octets that each +! template entry occupies when packed up into the GDS. +! needext - Logical variable indicating whether the Grid Defintion +! Template has to be extended. +! ierr - Error return code. +! 0 = no error +! 1 = Undefine Grid Template number. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: number + integer,intent(out) :: nummap,map(*),iret + logical,intent(out) :: needext + + iret=0 + + index=getgridindex(number) + + if (index.ne.-1) then + nummap=templates(index)%mapgridlen + needext=templates(index)%needext + map(1:nummap)=templates(index)%mapgrid(1:nummap) + else + nummap=0 + needext=.false. + print *,'getgridtemplate: Grid Template ',number, + & ' not defined.' + iret=1 + endif + + end subroutine + + + subroutine extgridtemplate(number,list,nummap,map) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: extgridtemplate +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-09 +! +! ABSTRACT: This subroutine generates the remaining octet map for a +! given Grid Definition Template, if required. Some Templates can +! vary depending on data values given in an earlier part of the +! Template, and it is necessary to know some of the earlier entry +! values to generate the full octet map of the Template. +! +! PROGRAM HISTORY LOG: +! 2000-05-09 Gilbert +! 2013-07-30 Vuong - Added GDT 3.4,3.5,3.12,3.101,3.140 +! +! USAGE: CALL extgridtemplate(number,list,nummap,map) +! INPUT ARGUMENT LIST: +! number - NN, indicating the number of the Grid Definition +! Template 3.NN that is being requested. +! list() - The list of values for each entry in +! the Grid Definition Template. +! +! OUTPUT ARGUMENT LIST: +! nummap - Number of entries in the Template +! map() - An array containing the number of octets that each +! template entry occupies when packed up into the GDS. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: number,list(*) + integer,intent(out) :: nummap,map(*) + + index=getgridindex(number) + if (index.eq.-1) return + + if ( .not. templates(index)%needext ) return + nummap=templates(index)%mapgridlen + map(1:nummap)=templates(index)%mapgrid(1:nummap) + + if ( number.eq.120 ) then + N=list(2) + do i=1,N + map(nummap+1)=2 + map(nummap+2)=-2 + nummap=nummap+2 + enddo + elseif ( number.eq.4 ) then + NI=list(8) + do i=1,NI + map(nummap+1)=4 + nummap=nummap+1 + enddo + NJ=list(9) + do i=1,NJ + map(nummap+1)=-4 + nummap=nummap+1 + enddo + elseif ( number.eq.5 ) then + NI=list(8) + do i=1,NI + map(nummap+1)=4 + nummap=nummap+1 + enddo + NJ=list(9) + do i=1,NJ + map(nummap+1)=-4 + nummap=nummap+1 + enddo + elseif ( number.eq.1000 ) then + N=list(20) + do i=1,N + map(nummap+1)=4 + nummap=nummap+1 + enddo + elseif ( number.eq.1200 ) then + N=list(16) + do i=1,N + map(nummap+1)=4 + nummap=nummap+1 + enddo + endif + + end subroutine + + integer function getgdtlen(number) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getgdtlen +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2004-05-11 +! +! ABSTRACT: This function returns the initial length (number of entries) in +! the "static" part of specified Grid Definition Template 3.number. +! +! PROGRAM HISTORY LOG: +! 2004-05-11 Gilbert +! +! USAGE: CALL getgdtlen(number) +! INPUT ARGUMENT LIST: +! number - NN, indicating the number of the Grid Definition +! Template 3.NN that is being requested. +! +! RETURNS: Number of entries in the "static" part of GDT 3.number +! OR returns 0, if requested template is not found. +! +! REMARKS: If user needs the full length of a specific template that +! contains additional entries based on values set in the "static" part +! of the GDT, subroutine extgridtemplate can be used. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: number + + getgdtlen=0 + + index=getgridindex(number) + + if (index.ne.-1) then + getgdtlen=templates(index)%mapgridlen + endif + + end function + + + end + diff --git a/WPS/ungrib/src/ngl/g2/intmath.f b/WPS/ungrib/src/ngl/g2/intmath.f new file mode 100644 index 00000000..f26b0606 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/intmath.f @@ -0,0 +1,260 @@ + module intmath + implicit none + + interface ilog2 + ! log(x)/log(2) + module procedure ilog2_8 + module procedure ilog2_4 + module procedure ilog2_2 + module procedure ilog2_1 + end interface ilog2 + + interface i1log2 + ! log(x+1)/log(2) unless x=maxint, in which case log(x)/log(2) + module procedure i1log2_8 + module procedure i1log2_4 + module procedure i1log2_2 + module procedure i1log2_1 + end interface i1log2 + + contains + + ! ---------------------------------------------------------------- + + function i1log2_8(ival) + implicit none + integer(kind=8), value :: ival + integer(kind=8)::i1log2_8 + integer(kind=8), parameter :: one=1 + if(ival+one',I0,' (',I0,' = ',F0.10,')') +c$$$ 20 format(Z16,' -- OKAY: ',I0,'=>',I0,' (',I0,' = ',F0.10,')') +c$$$ if(ival+one0) jfld(1)=0 + elseif (idrstmpl(17).eq.2) then ! second order + if(nonmiss==1) then + ival1=jfld(1) + ival2=jfld(1) + elseif(nonmiss<1) then + ival1=1.0 + ival2=1.0 + else + ival1=jfld(1) + ival2=jfld(2) + endif + do j=nonmiss,3,-1 + jfld(j)=jfld(j)-(2*jfld(j-1))+jfld(j-2) + enddo + if(nonmiss>=1) jfld(1)=0 + if(nonmiss>=2) jfld(2)=0 + endif + ! + ! subtract min value from spatial diff field + ! + isd=idrstmpl(17)+1 + minsd=minval(jfld(isd:nonmiss)) + do j=isd,nonmiss + jfld(j)=jfld(j)-minsd + enddo + ! + ! find num of bits need to store minsd and add 1 extra bit + ! to indicate sign + ! + temp=i1log2(abs(minsd)) + nbitsd=ceiling(temp)+1 + ! + ! find num of bits need to store ifld(1) ( and ifld(2) + ! if using 2nd order differencing ) + ! + maxorig=ival1 + if (idrstmpl(17).eq.2.and.ival2.gt.ival1) maxorig=ival2 + temp=i1log2(maxorig) + nbitorig=ceiling(temp)+1 + if (nbitorig.gt.nbitsd) nbitsd=nbitorig + ! increase number of bits to even multiple of 8 ( octet ) + if (mod(nbitsd,8).ne.0) nbitsd=nbitsd+(8-mod(nbitsd,8)) + ! + ! Store extra spatial differencing info into the packed + ! data section. + ! + if (nbitsd.ne.0) then + ! pack first original value + if (ival1.ge.0) then + call sbyte(cpack,ival1,iofst,nbitsd) + iofst=iofst+nbitsd + else + call sbyte(cpack,1,iofst,1) + iofst=iofst+1 + call sbyte(cpack,iabs(ival1),iofst,nbitsd-1) + iofst=iofst+nbitsd-1 + endif + if (idrstmpl(17).eq.2) then + ! pack second original value + if (ival2.ge.0) then + call sbyte(cpack,ival2,iofst,nbitsd) + iofst=iofst+nbitsd + else + call sbyte(cpack,1,iofst,1) + iofst=iofst+1 + call sbyte(cpack,iabs(ival2),iofst,nbitsd-1) + iofst=iofst+nbitsd-1 + endif + endif + ! pack overall min of spatial differences + if (minsd.ge.0) then + call sbyte(cpack,minsd,iofst,nbitsd) + iofst=iofst+nbitsd + else + call sbyte(cpack,1,iofst,1) + iofst=iofst+1 + call sbyte(cpack,iabs(minsd),iofst,nbitsd-1) + iofst=iofst+nbitsd-1 + endif + endif + !print *,'SDp ',ival1,ival2,minsd,nbitsd + endif ! end of spatial diff section + ! + ! Expand non-missing data values to original grid. + ! + miss1=minval(jfld(1:nonmiss))-1 + miss2=miss1-1 + n=0 + do j=1,ndpts + if ( ifldmiss(j).eq.0 ) then + n=n+1 + ifld(j)=jfld(n) + elseif ( ifldmiss(j).eq.1 ) then + ifld(j)=miss1 + elseif ( ifldmiss(j).eq.2 ) then + ifld(j)=miss2 + endif + enddo + if(ndpts<2) simple_alg=.true. + ! + ! Determine Groups to be used. + ! + if ( simple_alg ) then + ! set group length to 10 : calculate number of groups + ! and length of last group + ngroups=ndpts/10 + glen(1:ngroups)=10 + itemp=mod(ndpts,10) + if (itemp.ne.0) then + ngroups=ngroups+1 + glen(ngroups)=itemp + endif + else + ! Use Dr. Glahn's algorithm for determining grouping. + ! + kfildo=6 + minpk=10 + inc=1 + maxgrps=(ndpts/minpk)+1 + allocate(jmin(maxgrps)) + allocate(jmax(maxgrps)) + allocate(lbit(maxgrps)) + call pack_gp(kfildo,ifld,ndpts,missopt,minpk,inc,miss1,miss2, + & jmin,jmax,lbit,glen,maxgrps,ngroups,ibit,jbit, + & kbit,novref,lbitref,ier) + !print *,'SAGier = ',ier,ibit,jbit,kbit,novref,lbitref + do ng=1,ngroups + glen(ng)=glen(ng)+novref + enddo + deallocate(jmin) + deallocate(jmax) + deallocate(lbit) + endif + ! + ! For each group, find the group's reference value (min) + ! and the number of bits needed to hold the remaining values + ! + n=1 + do ng=1,ngroups + ! how many of each type? + num0=count(ifldmiss(n:n+glen(ng)-1) .EQ. 0) + num1=count(ifldmiss(n:n+glen(ng)-1) .EQ. 1) + num2=count(ifldmiss(n:n+glen(ng)-1) .EQ. 2) + if ( num0.eq.0 ) then ! all missing values + if ( num1.eq.0 ) then ! all secondary missing + gref(ng)=-2 + gwidth(ng)=0 + elseif ( num2.eq.0 ) then ! all primary missing + gref(ng)=-1 + gwidth(ng)=0 + else ! both primary and secondary + gref(ng)=0 + gwidth(ng)=1 + endif + else ! contains some non-missing data + ! find max and min values of group + gref(ng)=huge(n) + imax=-1*huge(n) + j=n + do lg=1,glen(ng) + if ( ifldmiss(j).eq.0 ) then + if (ifld(j).lt.gref(ng)) gref(ng)=ifld(j) + if (ifld(j).gt.imax) imax=ifld(j) + endif + j=j+1 + enddo + if (missopt.eq.1) imax=imax+1 + if (missopt.eq.2) imax=imax+2 + ! calc num of bits needed to hold data + if ( gref(ng).ne.imax ) then + temp=i1log2(imax-gref(ng)) + gwidth(ng)=ceiling(temp) + else + gwidth(ng)=0 + endif + endif + ! Subtract min from data + j=n + mtemp=2**gwidth(ng) + do lg=1,glen(ng) + if (ifldmiss(j).eq.0) then ! non-missing + ifld(j)=ifld(j)-gref(ng) + elseif (ifldmiss(j).eq.1) then ! primary missing + ifld(j)=mtemp-1 + elseif (ifldmiss(j).eq.2) then ! secondary missing + ifld(j)=mtemp-2 + endif + j=j+1 + enddo + ! increment fld array counter + n=n+glen(ng) + enddo + ! + ! Find max of the group references and calc num of bits needed + ! to pack each groups reference value, then + ! pack up group reference values + ! + !write(77,*)'GREFS: ',(gref(j),j=1,ngroups) + igmax=maxval(gref(1:ngroups)) + if (missopt.eq.1) igmax=igmax+1 + if (missopt.eq.2) igmax=igmax+2 + if (igmax.ne.0) then + temp=i1log2(igmax) + nbitsgref=ceiling(temp) + ! restet the ref values of any "missing only" groups. + mtemp=2**nbitsgref + do j=1,ngroups + if (gref(j).eq.-1) gref(j)=mtemp-1 + if (gref(j).eq.-2) gref(j)=mtemp-2 + enddo + call sbytes(cpack,gref,iofst,nbitsgref,0,ngroups) + itemp=nbitsgref*ngroups + iofst=iofst+itemp + ! Pad last octet with Zeros, if necessary, + if (mod(itemp,8).ne.0) then + left=8-mod(itemp,8) + call sbyte(cpack,zero,iofst,left) + iofst=iofst+left + endif + else + nbitsgref=0 + endif + ! + ! Find max/min of the group widths and calc num of bits needed + ! to pack each groups width value, then + ! pack up group width values + ! + !write(77,*)'GWIDTHS: ',(gwidth(j),j=1,ngroups) + iwmax=maxval(gwidth(1:ngroups)) + ngwidthref=minval(gwidth(1:ngroups)) + if (iwmax.ne.ngwidthref) then + temp=i1log2(iwmax-ngwidthref) + nbitsgwidth=ceiling(temp) + do i=1,ngroups + gwidth(i)=gwidth(i)-ngwidthref + enddo + call sbytes(cpack,gwidth,iofst,nbitsgwidth,0,ngroups) + itemp=nbitsgwidth*ngroups + iofst=iofst+itemp + ! Pad last octet with Zeros, if necessary, + if (mod(itemp,8).ne.0) then + left=8-mod(itemp,8) + call sbyte(cpack,zero,iofst,left) + iofst=iofst+left + endif + else + nbitsgwidth=0 + gwidth(1:ngroups)=0 + endif + ! + ! Find max/min of the group lengths and calc num of bits needed + ! to pack each groups length value, then + ! pack up group length values + ! + !write(77,*)'GLENS: ',(glen(j),j=1,ngroups) + ilmax=maxval(glen(1:ngroups-1)) + nglenref=minval(glen(1:ngroups-1)) + if(ngroups>0) then + nglenlast=glen(ngroups) + else + nglenlast=0 + endif + if (ilmax.ne.nglenref) then + temp=i1log2(ilmax-nglenref) + nbitsglen=ceiling(temp) + do i=1,ngroups-1 + glen(i)=glen(i)-nglenref + enddo + call sbytes(cpack,glen,iofst,nbitsglen,0,ngroups) + itemp=nbitsglen*ngroups + iofst=iofst+itemp + ! Pad last octet with Zeros, if necessary, + if (mod(itemp,8).ne.0) then + left=8-mod(itemp,8) + call sbyte(cpack,zero,iofst,left) + iofst=iofst+left + endif + else + nbitsglen=0 + glen(1:ngroups)=0 + endif + ! + ! For each group, pack data values + ! + !write(77,*)'IFLDS: ',(ifld(j),j=1,ndpts) + n=1 + ij=0 + do ng=1,ngroups + glength=glen(ng)+nglenref + if (ng.eq.ngroups ) glength=nglenlast + grpwidth=gwidth(ng)+ngwidthref + !write(77,*)'NGP ',ng,grpwidth,glength,gref(ng) + if ( grpwidth.ne.0 ) then + call sbytes(cpack,ifld(n),iofst,grpwidth,0,glength) + iofst=iofst+(grpwidth*glength) + endif + do kk=1,glength + ij=ij+1 + !write(77,*)'SAG ',ij,fld(ij),ifld(ij),gref(ng),bscale,rmin,dscale + enddo + n=n+glength + enddo + ! Pad last octet with Zeros, if necessary, + if (mod(iofst,8).ne.0) then + left=8-mod(iofst,8) + call sbyte(cpack,zero,iofst,left) + iofst=iofst+left + endif + lcpack=iofst/8 + ! + if ( allocated(ifld) ) deallocate(ifld) + if ( allocated(jfld) ) deallocate(jfld) + if ( allocated(ifldmiss) ) deallocate(ifldmiss) + if ( allocated(gref) ) deallocate(gref) + if ( allocated(gwidth) ) deallocate(gwidth) + if ( allocated(glen) ) deallocate(glen) + !else ! Constant field ( max = min ) + ! nbits=0 + ! lcpack=0 + ! nbitsgref=0 + ! ngroups=0 + !endif + +! +! Fill in ref value and number of bits in Template 5.2 +! + rmin4 = rmin + call mkieee(rmin4,ref,1) ! ensure reference value is IEEE format +! call gbyte(ref,idrstmpl(1),0,32) + iref=transfer(ref,iref) + idrstmpl(1)=iref + idrstmpl(4)=nbitsgref + idrstmpl(5)=0 ! original data were reals + idrstmpl(6)=1 ! general group splitting + idrstmpl(10)=ngroups ! Number of groups + idrstmpl(11)=ngwidthref ! reference for group widths + idrstmpl(12)=nbitsgwidth ! num bits used for group widths + idrstmpl(13)=nglenref ! Reference for group lengths + idrstmpl(14)=1 ! length increment for group lengths + idrstmpl(15)=nglenlast ! True length of last group + idrstmpl(16)=nbitsglen ! num bits used for group lengths + if (idrsnum.eq.3) then + idrstmpl(18)=nbitsd/8 ! num bits used for extra spatial + ! differencing values + endif + + return + end diff --git a/WPS/ungrib/src/ngl/g2/mkieee.f b/WPS/ungrib/src/ngl/g2/mkieee.f new file mode 100755 index 00000000..3ba129d3 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/mkieee.f @@ -0,0 +1,117 @@ + subroutine mkieee(a,rieee,num) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: mkieee +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-09 +! +! ABSTRACT: This subroutine stores a list of real values in +! 32-bit IEEE floating point format. +! +! PROGRAM HISTORY LOG: +! 2000-05-09 Gilbert +! +! USAGE: CALL mkieee(a,rieee,num) +! INPUT ARGUMENT LIST: +! a - Input array of floating point values. +! num - Number of floating point values to convert. +! +! OUTPUT ARGUMENT LIST: +! rieee - Output array of floating point values in 32-bit IEEE format. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + real(4),intent(in) :: a(num) + real(4),intent(out) :: rieee(num) + integer,intent(in) :: num + + integer(4) :: ieee + +! Recent versions of the PGI compilers apparently still do not fully support +! the use of all intrinsics in parameter statements, though this is part of +! the F2003 standard. +! real, parameter :: two23=scale(1.0,23) +! real, parameter :: two126=scale(1.0,126) + real :: two23 + real :: two126 + + two23=scale(1.0,23) + two126=scale(1.0,126) + + alog2=alog(2.0) + + do j=1,num + ieee=0 + + if (a(j).eq.0.) then + ieee=0 + rieee(j)=transfer(ieee,rieee(j)) +! write(6,fmt='(f20.10,5x,b32)') a,a +! write(6,fmt='(f20.10,5x,b32)') rieee,rieee + cycle + endif + +! +! Set Sign bit (bit 31 - leftmost bit) +! + if (a(j).lt.0.0) then + ieee=ibset(ieee,31) + atemp=abs(a(j)) + else + ieee=ibclr(ieee,31) + atemp=a(j) + endif +! +! Determine exponent n with base 2 +! + if ( atemp .ge. 1.0 ) then + n = 0 + do while ( 2.0**(n+1) .le. atemp ) + n = n + 1 + enddo + else + n = -1 + do while ( 2.0**n .gt. atemp ) + n = n - 1 + enddo + endif +! n=floor(alog(atemp)/alog2) + !write(6,*) ' logstuff ',alog(atemp)/alog2 + !write(6,*) ' logstuffn ',n + iexp=n+127 + if (n.gt.127) iexp=255 ! overflow + if (n.lt.-127) iexp=0 + ! set exponent bits ( bits 30-23 ) + call mvbits(iexp,0,8,ieee,23) +! +! Determine Mantissa +! + if (iexp.ne.255) then + if (iexp.ne.0) then + atemp=(atemp/(2.0**n))-1.0 + else + atemp=atemp*two126 + endif + imant=nint(atemp*two23) + else + imant=0 + endif + ! set mantissa bits ( bits 22-0 ) + call mvbits(imant,0,23,ieee,0) +! +! Transfer IEEE bit string to real variable +! + rieee(j)=transfer(ieee,rieee(j)) +! write(6,fmt='(f20.10,5x,b32)') a,a +! write(6,fmt='(f20.10,5x,b32)') rieee,rieee + + enddo + + return + end + diff --git a/WPS/ungrib/src/ngl/g2/mova2i.c b/WPS/ungrib/src/ngl/g2/mova2i.c new file mode 100755 index 00000000..f8400ed4 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/mova2i.c @@ -0,0 +1,47 @@ +/*$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: mov_a2i Moves a bit string from a char*1 to int +C PRGMMR: Gilbert ORG: W/NP11 DATE: 02-08-15 +C +C ABSTRACT: This Function copies a bit string from a Character*1 variable +C to an integer variable. It is intended to replace the Fortran Intrinsic +C Function ICHAR, which only supports 0 <= ICHAR(a) <= 127 on the +C IBM SP. If "a" is greater than 127 in the collating sequence, +C ICHAR(a) does not return the expected bit value. +C This function can be used for all values 0 <= ICHAR(a) <= 255. +C +C PROGRAM HISTORY LOG: +C 98-12-15 Gilbert +C +C USAGE: I = mov_a2i(a) +C +C INPUT ARGUMENT : +C +C a - Character*1 variable that holds the bitstring to extract +C +C RETURN ARGUMENT : +C +C mov_a2i - Integer value of the bitstring in character a +C +C REMARKS: +C +C None +C +C ATTRIBUTES: +C LANGUAGE: C +C MACHINE: IBM SP + +C +C$$$i*/ + +#if defined _UNDERSCORE + int mov_a2i_(unsigned char *a) +#elif defined _DOUBLEUNDERSCORE + int mov_a2i__(unsigned char *a) +#else + int mov_a2i(unsigned char *a) +#endif + +{ + return (int)(*a); +} diff --git a/WPS/ungrib/src/ngl/g2/pack_gp.f b/WPS/ungrib/src/ngl/g2/pack_gp.f new file mode 100755 index 00000000..9b868302 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/pack_gp.f @@ -0,0 +1,1179 @@ + SUBROUTINE PACK_GP(KFILDO,IC,NXY,IS523,MINPK,INC,MISSP,MISSS, + 1 JMIN,JMAX,LBIT,NOV,NDG,LX,IBIT,JBIT,KBIT, + 2 NOVREF,LBITREF,IER) +C +C FEBRUARY 1994 GLAHN TDL MOS-2000 +C JUNE 1995 GLAHN MODIFIED FOR LMISS ERROR. +C JULY 1996 GLAHN ADDED MISSS +C FEBRUARY 1997 GLAHN REMOVED 4 REDUNDANT TESTS FOR +C MISSP.EQ.0; INSERTED A TEST TO BETTER +C HANDLE A STRING OF 9999'S +C FEBRUARY 1997 GLAHN ADDED LOOPS TO ELIMINATE TEST FOR +C MISSS WHEN MISSS = 0 +C MARCH 1997 GLAHN CORRECTED FOR SECONDARY MISSING VALUE +C MARCH 1997 GLAHN CORRECTED FOR USE OF LOCAL VALUE +C OF MINPK +C MARCH 1997 GLAHN CORRECTED FOR SECONDARY MISSING VALUE +C MARCH 1997 GLAHN CHANGED CALCULATING NUMBER OF BITS +C THROUGH EXPONENTS TO AN ARRAY (IMPROVED +C OVERALL PACKING PERFORMANCE BY ABOUT +C 35 PERCENT!). ALLOWED 0 BITS FOR +C PACKING JMIN( ), LBIT( ), AND NOV( ). +C MAY 1997 GLAHN A NUMBER OF CHANGES FOR EFFICIENCY. +C MOD FUNCTIONS ELIMINATED AND ONE +C IFTHEN ADDED. JOUNT REMOVED. +C RECOMPUTATION OF BITS NOT MADE UNLESS +C NECESSARY AFTER MOVING POINTS FROM +C ONE GROUP TO ANOTHER. NENDB ADJUSTED +C TO ELIMINATE POSSIBILITY OF VERY +C SMALL GROUP AT THE END. +C ABOUT 8 PERCENT IMPROVEMENT IN +C OVERALL PACKING. ISKIPA REMOVED; +C THERE IS ALWAYS A GROUP B THAT CAN +C BECOME GROUP A. CONTROL ON SIZE +C OF GROUP B (STATEMENT BELOW 150) +C ADDED. ADDED ADDA, AND USE +C OF GE AND LE INSTEAD OF GT AND LT +C IN LOOPS BETWEEN 150 AND 160. +C IBITBS ADDED TO SHORTEN TRIPS +C THROUGH LOOP. +C MARCH 2000 GLAHN MODIFIED FOR GRIB2; CHANGED NAME FROM +C PACKGP +C JANUARY 2001 GLAHN COMMENTS; IER = 706 SUBSTITUTED FOR +C STOPS; ADDED RETURN1; REMOVED STATEMENT +C NUMBER 110; ADDED IER AND * RETURN +C NOVEMBER 2001 GLAHN CHANGED SOME DIAGNOSTIC FORMATS TO +C ALLOW PRINTING LARGER NUMBERS +C NOVEMBER 2001 GLAHN ADDED MISSLX( ) TO PUT MAXIMUM VALUE +C INTO JMIN( ) WHEN ALL VALUES MISSING +C TO AGREE WITH GRIB STANDARD. +C NOVEMBER 2001 GLAHN CHANGED TWO TESTS ON MISSP AND MISSS +C EQ 0 TO TESTS ON IS523. HOWEVER, +C MISSP AND MISSS CANNOT IN GENERAL BE +C = 0. +C NOVEMBER 2001 GLAHN ADDED CALL TO REDUCE; DEFINED ITEST +C BEFORE LOOPS TO REDUCE COMPUTATION; +C STARTED LARGE GROUP WHEN ALL SAME +C VALUE +C DECEMBER 2001 GLAHN MODIFIED AND ADDED A FEW COMMENTS +C JANUARY 2002 GLAHN REMOVED LOOP BEFORE 150 TO DETERMINE +C A GROUP OF ALL SAME VALUE +C JANUARY 2002 GLAHN CHANGED MALLOW FROM 9999999 TO 2**30+1, +C AND MADE IT A PARAMETER +C MARCH 2002 GLAHN ADDED NON FATAL IER = 716, 717; +C REMOVED NENDB=NXY ABOVE 150; +C ADDED IERSAV=0; COMMENTS +C +C PURPOSE +C DETERMINES GROUPS OF VARIABLE SIZE, BUT AT LEAST OF +C SIZE MINPK, THE ASSOCIATED MAX (JMAX( )) AND MIN (JMIN( )), +C THE NUMBER OF BITS NECESSARY TO HOLD THE VALUES IN EACH +C GROUP (LBIT( )), THE NUMBER OF VALUES IN EACH GROUP +C (NOV( )), THE NUMBER OF BITS NECESSARY TO PACK THE JMIN( ) +C VALUES (IBIT), THE NUMBER OF BITS NECESSARY TO PACK THE +C LBIT( ) VALUES (JBIT), AND THE NUMBER OF BITS NECESSARY +C TO PACK THE NOV( ) VALUES (KBIT). THE ROUTINE IS DESIGNED +C TO DETERMINE THE GROUPS SUCH THAT A SMALL NUMBER OF BITS +C IS NECESSARY TO PACK THE DATA WITHOUT EXCESSIVE +C COMPUTATIONS. IF ALL VALUES IN THE GROUP ARE ZERO, THE +C NUMBER OF BITS TO USE IN PACKING IS DEFINED AS ZERO WHEN +C THERE CAN BE NO MISSING VALUES; WHEN THERE CAN BE MISSING +C VALUES, THE NUMBER OF BITS MUST BE AT LEAST 1 TO HAVE +C THE CAPABILITY TO RECOGNIZE THE MISSING VALUE. HOWEVER, +C IF ALL VALUES IN A GROUP ARE MISSING, THE NUMBER OF BITS +C NEEDED IS 0, AND THE UNPACKER RECOGNIZES THIS. +C ALL VARIABLES ARE INTEGER. EVEN THOUGH THE GROUPS ARE +C INITIALLY OF SIZE MINPK OR LARGER, AN ADJUSTMENT BETWEEN +C TWO GROUPS (THE LOOKBACK PROCEDURE) MAY MAKE A GROUP +C SMALLER THAN MINPK. THE CONTROL ON GROUP SIZE IS THAT +C THE SUM OF THE SIZES OF THE TWO CONSECUTIVE GROUPS, EACH OF +C SIZE MINPK OR LARGER, IS NOT DECREASED. WHEN DETERMINING +C THE NUMBER OF BITS NECESSARY FOR PACKING, THE LARGEST +C VALUE THAT CAN BE ACCOMMODATED IN, SAY, MBITS, IS +C 2**MBITS-1; THIS LARGEST VALUE (AND THE NEXT SMALLEST +C VALUE) IS RESERVED FOR THE MISSING VALUE INDICATOR (ONLY) +C WHEN IS523 NE 0. IF THE DIMENSION NDG +C IS NOT LARGE ENOUGH TO HOLD ALL THE GROUPS, THE LOCAL VALUE +C OF MINPK IS INCREASED BY 50 PERCENT. THIS IS REPEATED +C UNTIL NDG WILL SUFFICE. A DIAGNOSTIC IS PRINTED WHENEVER +C THIS HAPPENS, WHICH SHOULD BE VERY RARELY. IF IT HAPPENS +C OFTEN, NDG IN SUBROUTINE PACK SHOULD BE INCREASED AND +C A CORRESPONDING INCREASE IN SUBROUTINE UNPACK MADE. +C CONSIDERABLE CODE IS PROVIDED SO THAT NO MORE CHECKING +C FOR MISSING VALUES WITHIN LOOPS IS DONE THAN NECESSARY; +C THE ADDED EFFICIENCY OF THIS IS RELATIVELY MINOR, +C BUT DOES NO HARM. FOR GRIB2, THE REFERENCE VALUE FOR +C THE LENGTH OF GROUPS IN NOV( ) AND FOR THE NUMBER OF +C BITS NECESSARY TO PACK GROUP VALUES ARE DETERMINED, +C AND SUBTRACTED BEFORE JBIT AND KBIT ARE DETERMINED. +C +C WHEN 1 OR MORE GROUPS ARE LARGE COMPARED TO THE OTHERS, +C THE WIDTH OF ALL GROUPS MUST BE AS LARGE AS THE LARGEST. +C A SUBROUTINE REDUCE BREAKS UP LARGE GROUPS INTO 2 OR +C MORE TO REDUCE TOTAL BITS REQUIRED. IF REDUCE SHOULD +C ABORT, PACK_GP WILL BE EXECUTED AGAIN WITHOUT THE CALL +C TO REDUCE. +C +C DATA SET USE +C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) +C +C VARIABLES IN CALL SEQUENCE +C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT) +C IC( ) = ARRAY TO HOLD DATA FOR PACKING. THE VALUES +C DO NOT HAVE TO BE POSITIVE AT THIS POINT, BUT +C MUST BE IN THE RANGE -2**30 TO +2**30 (THE +C THE VALUE OF MALLOW). THESE INTEGER VALUES +C WILL BE RETAINED EXACTLY THROUGH PACKING AND +C UNPACKING. (INPUT) +C NXY = NUMBER OF VALUES IN IC( ). ALSO TREATED +C AS ITS DIMENSION. (INPUT) +C IS523 = missing value management +C 0=data contains no missing values +C 1=data contains Primary missing values +C 2=data contains Primary and secondary missing values +C (INPUT) +C MINPK = THE MINIMUM SIZE OF EACH GROUP, EXCEPT POSSIBLY +C THE LAST ONE. (INPUT) +C INC = THE NUMBER OF VALUES TO ADD TO AN ALREADY +C EXISTING GROUP IN DETERMINING WHETHER OR NOT +C TO START A NEW GROUP. IDEALLY, THIS WOULD BE +C 1, BUT EACH TIME INC VALUES ARE ATTEMPTED, THE +C MAX AND MIN OF THE NEXT MINPK VALUES MUST BE +C FOUND. THIS IS "A LOOP WITHIN A LOOP," AND +C A SLIGHTLY LARGER VALUE MAY GIVE ABOUT AS GOOD +C RESULTS WITH SLIGHTLY LESS COMPUTATIONAL TIME. +C IF INC IS LE 0, 1 IS USED, AND A DIAGNOSTIC IS +C OUTPUT. NOTE: IT IS EXPECTED THAT INC WILL +C EQUAL 1. THE CODE USES INC PRIMARILY IN THE +C LOOPS STARTING AT STATEMENT 180. IF INC +C WERE 1, THERE WOULD NOT NEED TO BE LOOPS +C AS SUCH. HOWEVER, KINC (THE LOCAL VALUE OF +C INC) IS SET GE 1 WHEN NEAR THE END OF THE DATA +C TO FORESTALL A VERY SMALL GROUP AT THE END. +C (INPUT) +C MISSP = WHEN MISSING POINTS CAN BE PRESENT IN THE DATA, +C THEY WILL HAVE THE VALUE MISSP OR MISSS. +C MISSP IS THE PRIMARY MISSING VALUE AND MISSS +C IS THE SECONDARY MISSING VALUE . THESE MUST +C NOT BE VALUES THAT WOULD OCCUR WITH SUBTRACTING +C THE MINIMUM (REFERENCE) VALUE OR SCALING. +C FOR EXAMPLE, MISSP = 0 WOULD NOT BE ADVISABLE. +C (INPUT) +C MISSS = SECONDARY MISSING VALUE INDICATOR (SEE MISSP). +C (INPUT) +C JMIN(J) = THE MINIMUM OF EACH GROUP (J=1,LX). (OUTPUT) +C JMAX(J) = THE MAXIMUM OF EACH GROUP (J=1,LX). THIS IS +C NOT REALLY NEEDED, BUT SINCE THE MAX OF EACH +C GROUP MUST BE FOUND, SAVING IT HERE IS CHEAP +C IN CASE THE USER WANTS IT. (OUTPUT) +C LBIT(J) = THE NUMBER OF BITS NECESSARY TO PACK EACH GROUP +C (J=1,LX). IT IS ASSUMED THE MINIMUM OF EACH +C GROUP WILL BE REMOVED BEFORE PACKING, AND THE +C VALUES TO PACK WILL, THEREFORE, ALL BE POSITIVE. +C HOWEVER, IC( ) DOES NOT NECESSARILY CONTAIN +C ALL POSITIVE VALUES. IF THE OVERALL MINIMUM +C HAS BEEN REMOVED (THE USUAL CASE), THEN IC( ) +C WILL CONTAIN ONLY POSITIVE VALUES. (OUTPUT) +C NOV(J) = THE NUMBER OF VALUES IN EACH GROUP (J=1,LX). +C (OUTPUT) +C NDG = THE DIMENSION OF JMIN( ), JMAX( ), LBIT( ), AND +C NOV( ). (INPUT) +C LX = THE NUMBER OF GROUPS DETERMINED. (OUTPUT) +C IBIT = THE NUMBER OF BITS NECESSARY TO PACK THE JMIN(J) +C VALUES, J=1,LX. (OUTPUT) +C JBIT = THE NUMBER OF BITS NECESSARY TO PACK THE LBIT(J) +C VALUES, J=1,LX. (OUTPUT) +C KBIT = THE NUMBER OF BITS NECESSARY TO PACK THE NOV(J) +C VALUES, J=1,LX. (OUTPUT) +C NOVREF = REFERENCE VALUE FOR NOV( ). (OUTPUT) +C LBITREF = REFERENCE VALUE FOR LBIT( ). (OUTPUT) +C IER = ERROR RETURN. +C 706 = VALUE WILL NOT PACK IN 30 BITS--FATAL +C 714 = ERROR IN REDUCE--NON-FATAL +C 715 = NGP NOT LARGE ENOUGH IN REDUCE--NON-FATAL +C 716 = MINPK INCEASED--NON-FATAL +C 717 = INC SET = 1--NON-FATAL +C (OUTPUT) +C * = ALTERNATE RETURN WHEN IER NE 0 AND FATAL ERROR. +C +C INTERNAL VARIABLES +C CFEED = CONTAINS THE CHARACTER REPRESENTATION +C OF A PRINTER FORM FEED. +C IFEED = CONTAINS THE INTEGER VALUE OF A PRINTER +C FORM FEED. +C KINC = WORKING COPY OF INC. MAY BE MODIFIED. +C MINA = MINIMUM VALUE IN GROUP A. +C MAXA = MAXIMUM VALUE IN GROUP A. +C NENDA = THE PLACE IN IC( ) WHERE GROUP A ENDS. +C KSTART = THE PLACE IN IC( ) WHERE GROUP A STARTS. +C IBITA = NUMBER OF BITS NEEDED TO HOLD VALUES IN GROUP A. +C MINB = MINIMUM VALUE IN GROUP B. +C MAXB = MAXIMUM VALUE IN GROUP B. +C NENDB = THE PLACE IN IC( ) WHERE GROUP B ENDS. +C IBITB = NUMBER OF BITS NEEDED TO HOLD VALUES IN GROUP B. +C MINC = MINIMUM VALUE IN GROUP C. +C MAXC = MAXIMUM VALUE IN GROUP C. +C KTOTAL = COUNT OF NUMBER OF VALUES IN IC( ) PROCESSED. +C NOUNT = NUMBER OF VALUES ADDED TO GROUP A. +C LMISS = 0 WHEN IS523 = 0. WHEN PACKING INTO A +C SPECIFIC NUMBER OF BITS, SAY MBITS, +C THE MAXIMUM VALUE THAT CAN BE HANDLED IS +C 2**MBITS-1. WHEN IS523 = 1, INDICATING +C PRIMARY MISSING VALUES, THIS MAXIMUM VALUE +C IS RESERVED TO HOLD THE PRIMARY MISSING VALUE +C INDICATOR AND LMISS = 1. WHEN IS523 = 2, +C THE VALUE JUST BELOW THE MAXIMUM (I.E., +C 2**MBITS-2) IS RESERVED TO HOLD THE SECONDARY +C MISSING VALUE INDICATOR AND LMISS = 2. +C LMINPK = LOCAL VALUE OF MINPK. THIS WILL BE ADJUSTED +C UPWARD WHENEVER NDG IS NOT LARGE ENOUGH TO HOLD +C ALL THE GROUPS. +C MALLOW = THE LARGEST ALLOWABLE VALUE FOR PACKING. +C MISLLA = SET TO 1 WHEN ALL VALUES IN GROUP A ARE MISSING. +C THIS IS USED TO DISTINGUISH BETWEEN A REAL +C MINIMUM WHEN ALL VALUES ARE NOT MISSING +C AND A MINIMUM THAT HAS BEEN SET TO ZERO WHEN +C ALL VALUES ARE MISSING. 0 OTHERWISE. +C NOTE THAT THIS DOES NOT DISTINGUISH BETWEEN +C PRIMARY AND SECONDARY MISSINGS WHEN SECONDARY +C MISSINGS ARE PRESENT. THIS MEANS THAT +C LBIT( ) WILL NOT BE ZERO WITH THE RESULTING +C COMPRESSION EFFICIENCY WHEN SECONDARY MISSINGS +C ARE PRESENT. ALSO NOTE THAT A CHECK HAS BEEN +C MADE EARLIER TO DETERMINE THAT SECONDARY +C MISSINGS ARE REALLY THERE. +C MISLLB = SET TO 1 WHEN ALL VALUES IN GROUP B ARE MISSING. +C THIS IS USED TO DISTINGUISH BETWEEN A REAL +C MINIMUM WHEN ALL VALUES ARE NOT MISSING +C AND A MINIMUM THAT HAS BEEN SET TO ZERO WHEN +C ALL VALUES ARE MISSING. 0 OTHERWISE. +C MISLLC = PERFORMS THE SAME FUNCTION FOR GROUP C THAT +C MISLLA AND MISLLB DO FOR GROUPS B AND C, +C RESPECTIVELY. +C IBXX2(J) = POWERS OF 2 +C MINAK = KEEPS TRACK OF THE LOCATION IN IC( ) WHERE THE +C MINIMUM VALUE IN GROUP A IS LOCATED. +C MAXAK = DOES THE SAME AS MINAK, EXCEPT FOR THE MAXIMUM. +C MINBK = THE SAME AS MINAK FOR GROUP B. +C MAXBK = THE SAME AS MAXAK FOR GROUP B. +C MINCK = THE SAME AS MINAK FOR GROUP C. +C MAXCK = THE SAME AS MAXAK FOR GROUP C. +C ADDA = KEEPS TRACK WHETHER OR NOT AN ATTEMPT TO ADD +C POINTS TO GROUP A WAS MADE. IF SO, THEN ADDA +C KEEPS FROM TRYING TO PUT ONE BACK INTO B. +C (LOGICAL) +C IBITBS = KEEPS CURRENT VALUE IF IBITB SO THAT LOOP +C ENDING AT 166 DOESN'T HAVE TO START AT +C IBITB = 0 EVERY TIME. +C MISSLX(J) = MALLOW EXCEPT WHEN A GROUP IS ALL ONE VALUE (AND +C LBIT(J) = 0) AND THAT VALUE IS MISSING. IN +C THAT CASE, MISSLX(J) IS MISSP OR MISSS. THIS +C GETS INSERTED INTO JMIN(J) LATER AS THE +C MISSING INDICATOR; IT CAN'T BE PUT IN UNTIL +C THE END, BECAUSE JMIN( ) IS USED TO CALCULATE +C THE MAXIMUM NUMBER OF BITS (IBITS) NEEDED TO +C PACK JMIN( ). +C 1 2 3 4 5 6 7 X +C +C NON SYSTEM SUBROUTINES CALLED +C NONE +C + PARAMETER (MALLOW=2**30+1) +C + CHARACTER*1 CFEED + LOGICAL ADDA +C + DIMENSION IC(NXY) + DIMENSION JMIN(NDG),JMAX(NDG),LBIT(NDG),NOV(NDG) + DIMENSION MISSLX(NDG) +C MISSLX( ) IS AN AUTOMATIC ARRAY. + INTEGER, PARAMETER :: IBXX2(0:30) = (/ 1, 2, 4, 8, 16, 32, 64, & + & 128, 256, 512, 1024, 2048, 4096, 8192, 16384, 32768, 65536, & + & 131072, 262144, 524288, 1048576, 2097152, 4194304, 8388608, & + & 16777216, 33554432, 67108864, 134217728, 268435456, & + & 536870912, 1073741824 /) +C + + PARAMETER IFEED=12 +C + IER=0 + IERSAV=0 +C CALL TIMPR(KFILDO,KFILDO,'START PACK_GP ') + CFEED=CHAR(IFEED) +C + IRED=0 +C IRED IS A FLAG. WHEN ZERO, REDUCE WILL BE CALLED. +C IF REDUCE ABORTS, IRED = 1 AND IS NOT CALLED. IN +C THIS CASE PACK_GP EXECUTES AGAIN EXCEPT FOR REDUCE. +C + IF(INC.LE.0)THEN + IERSAV=717 +C WRITE(KFILDO,101)INC +C101 FORMAT(/' ****INC ='I8,' NOT CORRECT IN PACK_GP. 1 IS USED.') + ENDIF +C +C THERE WILL BE A RESTART OF PACK_GP IF SUBROUTINE REDUCE +C ABORTS. THIS SHOULD NOT HAPPEN, BUT IF IT DOES, PACK_GP +C WILL COMPLETE WITHOUT SUBROUTINE REDUCE. A NON FATAL +C DIAGNOSTIC RETURN IS PROVIDED. +C + 102 KINC=MAX(INC,1) + LMINPK=MINPK +C +C THERE WILL BE A RESTART AT 105 IS NDG IS NOT LARGE ENOUGH. +C A NON FATAL DIAGNOSTIC RETURN IS PROVIDED. +C + 105 KSTART=1 + KTOTAL=0 + LX=0 + ADDA=.FALSE. + LMISS=0 + IF(IS523.EQ.1)LMISS=1 + IF(IS523.EQ.2)LMISS=2 +C +C ************************************* +C +C THIS SECTION COMPUTES STATISTICS FOR GROUP A. GROUP A IS +C A GROUP OF SIZE LMINPK. +C +C ************************************* +C + IBITA=0 + MINA=MALLOW + MAXA=-MALLOW + MINAK=MALLOW + MAXAK=-MALLOW +C +C FIND THE MIN AND MAX OF GROUP A. THIS WILL INITIALLY BE OF +C SIZE LMINPK (IF THERE ARE STILL LMINPK VALUES IN IC( )), BUT +C WILL INCREASE IN SIZE IN INCREMENTS OF INC UNTIL A NEW +C GROUP IS STARTED. THE DEFINITION OF GROUP A IS DONE HERE +C ONLY ONCE (UPON INITIAL ENTRY), BECAUSE A GROUP B CAN ALWAYS +C BECOME A NEW GROUP A AFTER A IS PACKED, EXCEPT IF LMINPK +C HAS TO BE INCREASED BECAUSE NDG IS TOO SMALL. THEREFORE, +C THE SEPARATE LOOPS FOR MISSING AND NON-MISSING HERE BUYS +C ALMOST NOTHING. +C + NENDA=MIN(KSTART+LMINPK-1,NXY) + IF(NXY-NENDA.LE.LMINPK/2)NENDA=NXY +C ABOVE STATEMENT GUARANTEES THE LAST GROUP IS GT LMINPK/2 BY +C MAKING THE ACTUAL GROUP LARGER. IF A PROVISION LIKE THIS IS +C NOT INCLUDED, THERE WILL MANY TIMES BE A VERY SMALL GROUP +C AT THE END. USE SEPARATE LOOPS FOR MISSING AND NO MISSING +C VALUES FOR EFFICIENCY. +C +C DETERMINE WHETHER THERE IS A LONG STRING OF THE SAME VALUE +C UNLESS NENDA = NXY. THIS MAY ALLOW A LARGE GROUP A TO +C START WITH, AS WITH MISSING VALUES. SEPARATE LOOPS FOR +C MISSING OPTIONS. THIS SECTION IS ONLY EXECUTED ONCE, +C IN DETERMINING THE FIRST GROUP. IT HELPS FOR AN ARRAY +C OF MOSTLY MISSING VALUES OR OF ONE VALUE, SUCH AS +C RADAR OR PRECIP DATA. +C + IF(NENDA.NE.NXY.AND.IC(KSTART).EQ.IC(KSTART+1))THEN +C NO NEED TO EXECUTE IF FIRST TWO VALUES ARE NOT EQUAL. +C + IF(IS523.EQ.0)THEN +C THIS LOOP IS FOR NO MISSING VALUES. +C + DO 111 K=KSTART+1,NXY +C + IF(IC(K).NE.IC(KSTART))THEN + NENDA=MAX(NENDA,K-1) + GO TO 114 + ENDIF +C + 111 CONTINUE +C + NENDA=NXY +C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME. +C + ELSEIF(IS523.EQ.1)THEN +C THIS LOOP IS FOR PRIMARY MISSING VALUES ONLY. +C + DO 112 K=KSTART+1,NXY +C + IF(IC(K).NE.MISSP)THEN +C + IF(IC(K).NE.IC(KSTART))THEN + NENDA=MAX(NENDA,K-1) + GO TO 114 + ENDIF +C + ENDIF +C + 112 CONTINUE +C + NENDA=NXY +C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME. +C + ELSE +C THIS LOOP IS FOR PRIMARY AND SECONDARY MISSING VALUES. +C + DO 113 K=KSTART+1,NXY +C + IF(IC(K).NE.MISSP.AND.IC(K).NE.MISSS)THEN +C + IF(IC(K).NE.IC(KSTART))THEN + NENDA=MAX(NENDA,K-1) + GO TO 114 + ENDIF +C + ENDIF +C + 113 CONTINUE +C + NENDA=NXY +C FALL THROUGH THE LOOP MEANS ALL VALUES ARE THE SAME. + ENDIF +C + ENDIF +C + 114 IF(IS523.EQ.0)THEN +C + DO 115 K=KSTART,NENDA + IF(IC(K).LT.MINA)THEN + MINA=IC(K) + MINAK=K + ENDIF + IF(IC(K).GT.MAXA)THEN + MAXA=IC(K) + MAXAK=K + ENDIF + 115 CONTINUE +C + ELSEIF(IS523.EQ.1)THEN +C + DO 117 K=KSTART,NENDA + IF(IC(K).EQ.MISSP)GO TO 117 + IF(IC(K).LT.MINA)THEN + MINA=IC(K) + MINAK=K + ENDIF + IF(IC(K).GT.MAXA)THEN + MAXA=IC(K) + MAXAK=K + ENDIF + 117 CONTINUE +C + ELSE +C + DO 120 K=KSTART,NENDA + IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 120 + IF(IC(K).LT.MINA)THEN + MINA=IC(K) + MINAK=K + ENDIF + IF(IC(K).GT.MAXA)THEN + MAXA=IC(K) + MAXAK=K + ENDIF + 120 CONTINUE +C + ENDIF +C + KOUNTA=NENDA-KSTART+1 +C +C INCREMENT KTOTAL AND FIND THE BITS NEEDED TO PACK THE A GROUP. +C + KTOTAL=KTOTAL+KOUNTA + MISLLA=0 + IF(MINA.NE.MALLOW)GO TO 125 +C ALL MISSING VALUES MUST BE ACCOMMODATED. + MINA=0 + MAXA=0 + MISLLA=1 + IBITB=0 + IF(IS523.NE.2)GO TO 130 +C WHEN ALL VALUES ARE MISSING AND THERE ARE NO +C SECONDARY MISSING VALUES, IBITA = 0. +C OTHERWISE, IBITA MUST BE CALCULATED. +C + 125 ITEST=MAXA-MINA+LMISS +C + DO 126 IBITA=0,30 + IF(ITEST.LT.IBXX2(IBITA))GO TO 130 +C*** THIS TEST IS THE SAME AS: +C*** IF(MAXA-MINA.LT.IBXX2(IBITA)-LMISS)GO TO 130 + 126 CONTINUE +C +C WRITE(KFILDO,127)MAXA,MINA +C127 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.', +C 1 ' MAXA ='I13,' MINA ='I13,'. ERROR AT 127.') + IER=706 + GO TO 900 +C + 130 CONTINUE +C +C***D WRITE(KFILDO,131)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA +C***D131 FORMAT(' AT 130, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8, +C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3) +C + 133 IF(KTOTAL.GE.NXY)GO TO 200 +C +C ************************************* +C +C THIS SECTION COMPUTES STATISTICS FOR GROUP B. GROUP B IS A +C GROUP OF SIZE LMINPK IMMEDIATELY FOLLOWING GROUP A. +C +C ************************************* +C + 140 MINB=MALLOW + MAXB=-MALLOW + MINBK=MALLOW + MAXBK=-MALLOW + IBITBS=0 + MSTART=KTOTAL+1 +C +C DETERMINE WHETHER THERE IS A LONG STRING OF THE SAME VALUE. +C THIS WORKS WHEN THERE ARE NO MISSING VALUES. +C + NENDB=1 +C + IF(MSTART.LT.NXY)THEN +C + IF(IS523.EQ.0)THEN +C THIS LOOP IS FOR NO MISSING VALUES. +C + DO 145 K=MSTART+1,NXY +C + IF(IC(K).NE.IC(MSTART))THEN + NENDB=K-1 + GO TO 150 + ENDIF +C + 145 CONTINUE +C + NENDB=NXY +C FALL THROUGH THE LOOP MEANS ALL REMAINING VALUES +C ARE THE SAME. + ENDIF +C + ENDIF +C + 150 NENDB=MAX(NENDB,MIN(KTOTAL+LMINPK,NXY)) +C**** 150 NENDB=MIN(KTOTAL+LMINPK,NXY) +C + IF(NXY-NENDB.LE.LMINPK/2)NENDB=NXY +C ABOVE STATEMENT GUARANTEES THE LAST GROUP IS GT LMINPK/2 BY +C MAKING THE ACTUAL GROUP LARGER. IF A PROVISION LIKE THIS IS +C NOT INCLUDED, THERE WILL MANY TIMES BE A VERY SMALL GROUP +C AT THE END. USE SEPARATE LOOPS FOR MISSING AND NO MISSING +C +C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES +C FOR EFFICIENCY. +C + IF(IS523.EQ.0)THEN +C + DO 155 K=MSTART,NENDB + IF(IC(K).LE.MINB)THEN + MINB=IC(K) +C NOTE LE, NOT LT. LT COULD BE USED BUT THEN A +C RECOMPUTE OVER THE WHOLE GROUP WOULD BE NEEDED +C MORE OFTEN. SAME REASONING FOR GE AND OTHER +C LOOPS BELOW. + MINBK=K + ENDIF + IF(IC(K).GE.MAXB)THEN + MAXB=IC(K) + MAXBK=K + ENDIF + 155 CONTINUE +C + ELSEIF(IS523.EQ.1)THEN +C + DO 157 K=MSTART,NENDB + IF(IC(K).EQ.MISSP)GO TO 157 + IF(IC(K).LE.MINB)THEN + MINB=IC(K) + MINBK=K + ENDIF + IF(IC(K).GE.MAXB)THEN + MAXB=IC(K) + MAXBK=K + ENDIF + 157 CONTINUE +C + ELSE +C + DO 160 K=MSTART,NENDB + IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 160 + IF(IC(K).LE.MINB)THEN + MINB=IC(K) + MINBK=K + ENDIF + IF(IC(K).GE.MAXB)THEN + MAXB=IC(K) + MAXBK=K + ENDIF + 160 CONTINUE +C + ENDIF +C + KOUNTB=NENDB-KTOTAL + MISLLB=0 + IF(MINB.NE.MALLOW)GO TO 165 +C ALL MISSING VALUES MUST BE ACCOMMODATED. + MINB=0 + MAXB=0 + MISLLB=1 + IBITB=0 +C + IF(IS523.NE.2)GO TO 170 +C WHEN ALL VALUES ARE MISSING AND THERE ARE NO SECONDARY +C MISSING VALUES, IBITB = 0. OTHERWISE, IBITB MUST BE +C CALCULATED. +C + 165 DO 166 IBITB=IBITBS,30 + IF(MAXB-MINB.LT.IBXX2(IBITB)-LMISS)GO TO 170 + 166 CONTINUE +C +C WRITE(KFILDO,167)MAXB,MINB +C167 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.', +C 1 ' MAXB ='I13,' MINB ='I13,'. ERROR AT 167.') + IER=706 + GO TO 900 +C +C COMPARE THE BITS NEEDED TO PACK GROUP B WITH THOSE NEEDED +C TO PACK GROUP A. IF IBITB GE IBITA, TRY TO ADD TO GROUP A. +C IF NOT, TRY TO ADD A'S POINTS TO B, UNLESS ADDITION TO A +C HAS BEEN DONE. THIS LATTER IS CONTROLLED WITH ADDA. +C + 170 CONTINUE +C +C***D WRITE(KFILDO,171)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA, +C***D 1 MINB,MAXB,IBITB,MISLLB +C***D171 FORMAT(' AT 171, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8, +C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3, +C***D 2 ' MINB ='I8,' MAXB ='I8,' IBITB ='I3,' MISLLB ='I3) +C + IF(IBITB.GE.IBITA)GO TO 180 + IF(ADDA)GO TO 200 +C +C ************************************* +C +C GROUP B REQUIRES LESS BITS THAN GROUP A. PUT AS MANY OF A'S +C POINTS INTO B AS POSSIBLE WITHOUT EXCEEDING THE NUMBER OF +C BITS NECESSARY TO PACK GROUP B. +C +C ************************************* +C + KOUNTS=KOUNTA +C KOUNTA REFERS TO THE PRESENT GROUP A. + MINTST=MINB + MAXTST=MAXB + MINTSTK=MINBK + MAXTSTK=MAXBK +C +C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES +C FOR EFFICIENCY. +C + IF(IS523.EQ.0)THEN +C + DO 1715 K=KTOTAL,KSTART,-1 +C START WITH THE END OF THE GROUP AND WORK BACKWARDS. + IF(IC(K).LT.MINB)THEN + MINTST=IC(K) + MINTSTK=K + ELSEIF(IC(K).GT.MAXB)THEN + MAXTST=IC(K) + MAXTSTK=K + ENDIF + IF(MAXTST-MINTST.GE.IBXX2(IBITB))GO TO 174 +C NOTE THAT FOR THIS LOOP, LMISS = 0. + MINB=MINTST + MAXB=MAXTST + MINBK=MINTSTK + MAXBK=MAXTSTK + KOUNTA=KOUNTA-1 +C THERE IS ONE LESS POINT NOW IN A. + 1715 CONTINUE +C + ELSEIF(IS523.EQ.1)THEN +C + DO 1719 K=KTOTAL,KSTART,-1 +C START WITH THE END OF THE GROUP AND WORK BACKWARDS. + IF(IC(K).EQ.MISSP)GO TO 1718 + IF(IC(K).LT.MINB)THEN + MINTST=IC(K) + MINTSTK=K + ELSEIF(IC(K).GT.MAXB)THEN + MAXTST=IC(K) + MAXTSTK=K + ENDIF + IF(MAXTST-MINTST.GE.IBXX2(IBITB)-LMISS)GO TO 174 +C FOR THIS LOOP, LMISS = 1. + MINB=MINTST + MAXB=MAXTST + MINBK=MINTSTK + MAXBK=MAXTSTK + MISLLB=0 +C WHEN THE POINT IS NON MISSING, MISLLB SET = 0. + 1718 KOUNTA=KOUNTA-1 +C THERE IS ONE LESS POINT NOW IN A. + 1719 CONTINUE +C + ELSE +C + DO 173 K=KTOTAL,KSTART,-1 +C START WITH THE END OF THE GROUP AND WORK BACKWARDS. + IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 1729 + IF(IC(K).LT.MINB)THEN + MINTST=IC(K) + MINTSTK=K + ELSEIF(IC(K).GT.MAXB)THEN + MAXTST=IC(K) + MAXTSTK=K + ENDIF + IF(MAXTST-MINTST.GE.IBXX2(IBITB)-LMISS)GO TO 174 +C FOR THIS LOOP, LMISS = 2. + MINB=MINTST + MAXB=MAXTST + MINBK=MINTSTK + MAXBK=MAXTSTK + MISLLB=0 +C WHEN THE POINT IS NON MISSING, MISLLB SET = 0. + 1729 KOUNTA=KOUNTA-1 +C THERE IS ONE LESS POINT NOW IN A. + 173 CONTINUE +C + ENDIF +C +C AT THIS POINT, KOUNTA CONTAINS THE NUMBER OF POINTS TO CLOSE +C OUT GROUP A WITH. GROUP B NOW STARTS WITH KSTART+KOUNTA AND +C ENDS WITH NENDB. MINB AND MAXB HAVE BEEN ADJUSTED AS +C NECESSARY TO REFLECT GROUP B (EVEN THOUGH THE NUMBER OF BITS +C NEEDED TO PACK GROUP B HAVE NOT INCREASED, THE END POINTS +C OF THE RANGE MAY HAVE). +C + 174 IF(KOUNTA.EQ.KOUNTS)GO TO 200 +C ON TRANSFER, GROUP A WAS NOT CHANGED. CLOSE IT OUT. +C +C ONE OR MORE POINTS WERE TAKEN OUT OF A. RANGE AND IBITA +C MAY HAVE TO BE RECOMPUTED; IBITA COULD BE LESS THAN +C ORIGINALLY COMPUTED. IN FACT, GROUP A CAN NOW CONTAIN +C ONLY ONE POINT AND BE PACKED WITH ZERO BITS +C (UNLESS MISSS NE 0). +C + NOUTA=KOUNTS-KOUNTA + KTOTAL=KTOTAL-NOUTA + KOUNTB=KOUNTB+NOUTA + IF(NENDA-NOUTA.GT.MINAK.AND.NENDA-NOUTA.GT.MAXAK)GO TO 200 +C WHEN THE ABOVE TEST IS MET, THE MIN AND MAX OF THE +C CURRENT GROUP A WERE WITHIN THE OLD GROUP A, SO THE +C RANGE AND IBITA DO NOT NEED TO BE RECOMPUTED. +C NOTE THAT MINAK AND MAXAK ARE NO LONGER NEEDED. + IBITA=0 + MINA=MALLOW + MAXA=-MALLOW +C +C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES +C FOR EFFICIENCY. +C + IF(IS523.EQ.0)THEN +C + DO 1742 K=KSTART,NENDA-NOUTA + IF(IC(K).LT.MINA)THEN + MINA=IC(K) + ENDIF + IF(IC(K).GT.MAXA)THEN + MAXA=IC(K) + ENDIF + 1742 CONTINUE +C + ELSEIF(IS523.EQ.1)THEN +C + DO 1744 K=KSTART,NENDA-NOUTA + IF(IC(K).EQ.MISSP)GO TO 1744 + IF(IC(K).LT.MINA)THEN + MINA=IC(K) + ENDIF + IF(IC(K).GT.MAXA)THEN + MAXA=IC(K) + ENDIF + 1744 CONTINUE +C + ELSE +C + DO 175 K=KSTART,NENDA-NOUTA + IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 175 + IF(IC(K).LT.MINA)THEN + MINA=IC(K) + ENDIF + IF(IC(K).GT.MAXA)THEN + MAXA=IC(K) + ENDIF + 175 CONTINUE +C + ENDIF +C + MISLLA=0 + IF(MINA.NE.MALLOW)GO TO 1750 +C ALL MISSING VALUES MUST BE ACCOMMODATED. + MINA=0 + MAXA=0 + MISLLA=1 + IF(IS523.NE.2)GO TO 177 +C WHEN ALL VALUES ARE MISSING AND THERE ARE NO SECONDARY +C MISSING VALUES IBITA = 0 AS ORIGINALLY SET. OTHERWISE, +C IBITA MUST BE CALCULATED. +C + 1750 ITEST=MAXA-MINA+LMISS +C + DO 176 IBITA=0,30 + IF(ITEST.LT.IBXX2(IBITA))GO TO 177 +C*** THIS TEST IS THE SAME AS: +C*** IF(MAXA-MINA.LT.IBXX2(IBITA)-LMISS)GO TO 177 + 176 CONTINUE +C +C WRITE(KFILDO,1760)MAXA,MINA +C1760 FORMAT(' ****ERROR IN PACK_GP. VALUE WILL NOT PACK IN 30 BITS.', +C 1 ' MAXA ='I13,' MINA ='I13,'. ERROR AT 1760.') + IER=706 + GO TO 900 +C + 177 CONTINUE + GO TO 200 +C +C ************************************* +C +C AT THIS POINT, GROUP B REQUIRES AS MANY BITS TO PACK AS GROUPA. +C THEREFORE, TRY TO ADD INC POINTS TO GROUP A WITHOUT INCREASING +C IBITA. THIS AUGMENTED GROUP IS CALLED GROUP C. +C +C ************************************* +C + 180 IF(MISLLA.EQ.1)THEN + MINC=MALLOW + MINCK=MALLOW + MAXC=-MALLOW + MAXCK=-MALLOW + ELSE + MINC=MINA + MAXC=MAXA + MINCK=MINAK + MAXCK=MINAK + ENDIF +C + NOUNT=0 + IF(NXY-(KTOTAL+KINC).LE.LMINPK/2)KINC=NXY-KTOTAL +C ABOVE STATEMENT CONSTRAINS THE LAST GROUP TO BE NOT LESS THAN +C LMINPK/2 IN SIZE. IF A PROVISION LIKE THIS IS NOT INCLUDED, +C THERE WILL MANY TIMES BE A VERY SMALL GROUP AT THE END. +C +C USE SEPARATE LOOPS FOR MISSING AND NO MISSING VALUES +C FOR EFFICIENCY. SINCE KINC IS USUALLY 1, USING SEPARATE +C LOOPS HERE DOESN'T BUY MUCH. A MISSING VALUE WILL ALWAYS +C TRANSFER BACK TO GROUP A. +C + IF(IS523.EQ.0)THEN +C + DO 185 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY) + IF(IC(K).LT.MINC)THEN + MINC=IC(K) + MINCK=K + ENDIF + IF(IC(K).GT.MAXC)THEN + MAXC=IC(K) + MAXCK=K + ENDIF + NOUNT=NOUNT+1 + 185 CONTINUE +C + ELSEIF(IS523.EQ.1)THEN +C + DO 187 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY) + IF(IC(K).EQ.MISSP)GO TO 186 + IF(IC(K).LT.MINC)THEN + MINC=IC(K) + MINCK=K + ENDIF + IF(IC(K).GT.MAXC)THEN + MAXC=IC(K) + MAXCK=K + ENDIF + 186 NOUNT=NOUNT+1 + 187 CONTINUE +C + ELSE +C + DO 190 K=KTOTAL+1,MIN(KTOTAL+KINC,NXY) + IF(IC(K).EQ.MISSP.OR.IC(K).EQ.MISSS)GO TO 189 + IF(IC(K).LT.MINC)THEN + MINC=IC(K) + MINCK=K + ENDIF + IF(IC(K).GT.MAXC)THEN + MAXC=IC(K) + MAXCK=K + ENDIF + 189 NOUNT=NOUNT+1 + 190 CONTINUE +C + ENDIF +C +C***D WRITE(KFILDO,191)KOUNTA,KTOTAL,MINA,MAXA,IBITA,MISLLA, +C***D 1 MINC,MAXC,NOUNT,IC(KTOTAL),IC(KTOTAL+1) +C***D191 FORMAT(' AT 191, KOUNTA ='I8,' KTOTAL ='I8,' MINA ='I8, +C***D 1 ' MAXA ='I8,' IBITA ='I3,' MISLLA ='I3, +C***D 2 ' MINC ='I8,' MAXC ='I8, +C***D 3 ' NOUNT ='I5,' IC(KTOTAL) ='I9,' IC(KTOTAL+1) =',I9) +C +C IF THE NUMBER OF BITS NEEDED FOR GROUP C IS GT IBITA, +C THEN THIS GROUP A IS A GROUP TO PACK. +C + IF(MINC.EQ.MALLOW)THEN + MINC=MINA + MAXC=MAXA + MINCK=MINAK + MAXCK=MAXAK + MISLLC=1 + GO TO 195 +C WHEN THE NEW VALUE(S) ARE MISSING, THEY CAN ALWAYS +C BE ADDED. +C + ELSE + MISLLC=0 + ENDIF +C + IF(MAXC-MINC.GE.IBXX2(IBITA)-LMISS) GO TO 200 +C +C THE BITS NECESSARY FOR GROUP C HAS NOT INCREASED FROM THE +C BITS NECESSARY FOR GROUP A. ADD THIS POINT(S) TO GROUP A. +C COMPUTE THE NEXT GROUP B, ETC., UNLESS ALL POINTS HAVE BEEN +C USED. +C + 195 KTOTAL=KTOTAL+NOUNT + KOUNTA=KOUNTA+NOUNT + MINA=MINC + MAXA=MAXC + MINAK=MINCK + MAXAK=MAXCK + MISLLA=MISLLC + ADDA=.TRUE. + IF(KTOTAL.GE.NXY)GO TO 200 +C + IF(MINBK.GT.KTOTAL.AND.MAXBK.GT.KTOTAL)THEN + MSTART=NENDB+1 +C THE MAX AND MIN OF GROUP B WERE NOT FROM THE POINTS +C REMOVED, SO THE WHOLE GROUP DOES NOT HAVE TO BE LOOKED +C AT TO DETERMINE THE NEW MAX AND MIN. RATHER START +C JUST BEYOND THE OLD NENDB. + IBITBS=IBITB + NENDB=1 + GO TO 150 + ELSE + GO TO 140 + ENDIF +C +C ************************************* +C +C GROUP A IS TO BE PACKED. STORE VALUES IN JMIN( ), JMAX( ), +C LBIT( ), AND NOV( ). +C +C ************************************* +C + 200 LX=LX+1 + IF(LX.LE.NDG)GO TO 205 + LMINPK=LMINPK+LMINPK/2 +C WRITE(KFILDO,201)NDG,LMINPK,LX +C201 FORMAT(' ****NDG ='I5,' NOT LARGE ENOUGH.', +C 1 ' LMINPK IS INCREASED TO 'I3,' FOR THIS FIELD.'/ +C 2 ' LX = 'I10) + IERSAV=716 + GO TO 105 +C + 205 JMIN(LX)=MINA + JMAX(LX)=MAXA + LBIT(LX)=IBITA + NOV(LX)=KOUNTA + KSTART=KTOTAL+1 +C + IF(MISLLA.EQ.0)THEN + MISSLX(LX)=MALLOW + ELSE + MISSLX(LX)=IC(KTOTAL) +C IC(KTOTAL) WAS THE LAST VALUE PROCESSED. IF MISLLA NE 0, +C THIS MUST BE THE MISSING VALUE FOR THIS GROUP. + ENDIF +C +C***D WRITE(KFILDO,206)MISLLA,IC(KTOTAL),KTOTAL,LX,JMIN(LX),JMAX(LX), +C***D 1 LBIT(LX),NOV(LX),MISSLX(LX) +C***D206 FORMAT(' AT 206, MISLLA ='I2,' IC(KTOTAL) ='I5,' KTOTAL ='I8, +C***D 1 ' LX ='I6,' JMIN(LX) ='I8,' JMAX(LX) ='I8, +C***D 2 ' LBIT(LX) ='I5,' NOV(LX) ='I8,' MISSLX(LX) =',I7) +C + IF(KTOTAL.GE.NXY)GO TO 209 +C +C THE NEW GROUP A WILL BE THE PREVIOUS GROUP B. SET LIMITS, ETC. +C + IBITA=IBITB + MINA=MINB + MAXA=MAXB + MINAK=MINBK + MAXAK=MAXBK + MISLLA=MISLLB + NENDA=NENDB + KOUNTA=KOUNTB + KTOTAL=KTOTAL+KOUNTA + ADDA=.FALSE. + GO TO 133 +C +C ************************************* +C +C CALCULATE IBIT, THE NUMBER OF BITS NEEDED TO HOLD THE GROUP +C MINIMUM VALUES. +C +C ************************************* +C + 209 IBIT=0 +C + DO 220 L=1,LX + 210 IF(JMIN(L).LT.IBXX2(IBIT))GO TO 220 + IBIT=IBIT+1 + GO TO 210 + 220 CONTINUE +C +C INSERT THE VALUE IN JMIN( ) TO BE USED FOR ALL MISSING +C VALUES WHEN LBIT( ) = 0. WHEN SECONDARY MISSING +C VALUES CAN BE PRESENT, LBIT(L) WILL NOT = 0. +C + IF(IS523.EQ.1)THEN +C + DO 226 L=1,LX +C + IF(LBIT(L).EQ.0)THEN +C + IF(MISSLX(L).EQ.MISSP)THEN + JMIN(L)=IBXX2(IBIT)-1 + ENDIF +C + ENDIF +C + 226 CONTINUE +C + ENDIF +C +C ************************************* +C +C CALCULATE JBIT, THE NUMBER OF BITS NEEDED TO HOLD THE BITS +C NEEDED TO PACK THE VALUES IN THE GROUPS. BUT FIND AND +C REMOVE THE REFERENCE VALUE FIRST. +C +C ************************************* +C +C WRITE(KFILDO,228)CFEED,LX +C228 FORMAT(A1,/' *****************************************' +C 1 /' THE GROUP WIDTHS LBIT( ) FOR ',I8,' GROUPS' +C 2 /' *****************************************') +C WRITE(KFILDO,229) (LBIT(J),J=1,MIN(LX,100)) +C229 FORMAT(/' '20I6) +C + LBITREF=LBIT(1) +C + DO 230 K=1,LX + IF(LBIT(K).LT.LBITREF)LBITREF=LBIT(K) + 230 CONTINUE +C + IF(LBITREF.NE.0)THEN +C + DO 240 K=1,LX + LBIT(K)=LBIT(K)-LBITREF + 240 CONTINUE +C + ENDIF +C +C WRITE(KFILDO,241)CFEED,LBITREF +C241 FORMAT(A1,/' *****************************************' +C 1 /' THE GROUP WIDTHS LBIT( ) AFTER REMOVING REFERENCE ', +C 2 I8, +C 3 /' *****************************************') +C WRITE(KFILDO,242) (LBIT(J),J=1,MIN(LX,100)) +C242 FORMAT(/' '20I6) +C + JBIT=0 +C + DO 320 K=1,LX + 310 IF(LBIT(K).LT.IBXX2(JBIT))GO TO 320 + JBIT=JBIT+1 + GO TO 310 + 320 CONTINUE +C +C ************************************* +C +C CALCULATE KBIT, THE NUMBER OF BITS NEEDED TO HOLD THE NUMBER +C OF VALUES IN THE GROUPS. BUT FIND AND REMOVE THE +C REFERENCE FIRST. +C +C ************************************* +C +C WRITE(KFILDO,321)CFEED,LX +C321 FORMAT(A1,/' *****************************************' +C 1 /' THE GROUP SIZES NOV( ) FOR ',I8,' GROUPS' +C 2 /' *****************************************') +C WRITE(KFILDO,322) (NOV(J),J=1,MIN(LX,100)) +C322 FORMAT(/' '20I6) +C + NOVREF=NOV(1) +C + DO 400 K=1,LX + IF(NOV(K).LT.NOVREF)NOVREF=NOV(K) + 400 CONTINUE +C + IF(NOVREF.GT.0)THEN +C + DO 405 K=1,LX + NOV(K)=NOV(K)-NOVREF + 405 CONTINUE +C + ENDIF +C +C WRITE(KFILDO,406)CFEED,NOVREF +C406 FORMAT(A1,/' *****************************************' +C 1 /' THE GROUP SIZES NOV( ) AFTER REMOVING REFERENCE ',I8, +C 2 /' *****************************************') +C WRITE(KFILDO,407) (NOV(J),J=1,MIN(LX,100)) +C407 FORMAT(/' '20I6) +C WRITE(KFILDO,408)CFEED +C408 FORMAT(A1,/' *****************************************' +C 1 /' THE GROUP REFERENCES JMIN( )' +C 2 /' *****************************************') +C WRITE(KFILDO,409) (JMIN(J),J=1,MIN(LX,100)) +C409 FORMAT(/' '20I6) +C + KBIT=0 +C + DO 420 K=1,LX + 410 IF(NOV(K).LT.IBXX2(KBIT))GO TO 420 + KBIT=KBIT+1 + GO TO 410 + 420 CONTINUE +C +C DETERMINE WHETHER THE GROUP SIZES SHOULD BE REDUCED +C FOR SPACE EFFICIENCY. +C + IF(IRED.EQ.0)THEN + CALL REDUCE(KFILDO,JMIN,JMAX,LBIT,NOV,LX,NDG,IBIT,JBIT,KBIT, + 1 NOVREF,IBXX2,IER) +C + IF(IER.EQ.714.OR.IER.EQ.715)THEN +C REDUCE HAS ABORTED. REEXECUTE PACK_GP WITHOUT REDUCE. +C PROVIDE FOR A NON FATAL RETURN FROM REDUCE. + IERSAV=IER + IRED=1 + IER=0 + GO TO 102 + ENDIF +C + ENDIF +C +C CALL TIMPR(KFILDO,KFILDO,'END PACK_GP ') + IF(IERSAV.NE.0)THEN + IER=IERSAV + RETURN + ENDIF +C +C 900 IF(IER.NE.0)RETURN1 +C + 900 RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/params.f b/WPS/ungrib/src/ngl/g2/params.f new file mode 100755 index 00000000..fdf31971 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/params.f @@ -0,0 +1,1019 @@ + module params +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! MODULE: params +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2001-06-05 +! +! ABSTRACT: This Fortran Module contains info on all the available +! GRIB Parameters. +! +! PROGRAM HISTORY LOG: +! 2000-05-11 Gilbert +! 2003-08-07 Gilbert - Added more parameters +! 2003-09-26 Gilbert - Added more parameters +! 2005-11-17 Gordon - Added more parameters for the Wave & Smoke models +! 2007-03-28 Vuong - Added more parameters +! 2007-10-10 Vuong - Added more parameters +! 2008-03-12 Vuong - Added more parameters +! 2008-06-30 Vuong - Reformat entry paramlist from 1 to 173 +! Added more parameters and entire table 131 +! 2008-11-21 Vuong - Added more parameters +! 2009-06-02 Vuong - Added more parameters +! 2009-12-14 Vuong - Correction VEGT(4.2-0-210) +! 2010-07-27 Vuong - Added more parameters +! 2010-12-06 Vuong - Added more parameters +! 2011-05-24 Vuong - Added more parameters +! 2011-09-12 Vuong - Added more parameters +! 2012-09-12 Vuong - Added more parameters and change HINDEX to +! parameter from 3 to 2 and RHPW from Dis 0 cat 19 +! to 1 +! 2013-07-24 Vuong - Added more parameters and Removed +! spaces in abbreviation +! +! 2016-03-30 Vuong - Added parameter Heat Exchange Coefficient (CH) +! +! USAGE: use params +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + integer,parameter :: MAXPARAM=791 + + type gribparam + integer :: g1tblver + integer :: grib1val + integer :: grib2dsc + integer :: grib2cat + integer :: grib2num + character(len=8) :: abbrev + end type gribparam + + type(gribparam),dimension(MAXPARAM) :: paramlist + + data paramlist(1) /gribparam(2,1,0,3,0,'PRES')/ + data paramlist(2) /gribparam(2,2,0,3,1,'PRMSL')/ + data paramlist(3) /gribparam(2,3,0,3,2,'PTEND')/ + data paramlist(4) /gribparam(2,4,0,2,14,'PVORT')/ + data paramlist(5) /gribparam(2,5,0,3,3,'ICAHT')/ + data paramlist(6) /gribparam(2,6,0,3,4,'GP')/ + data paramlist(7) /gribparam(2,7,0,3,5,'HGT')/ + data paramlist(8) /gribparam(2,8,0,3,6,'DIST')/ + data paramlist(9) /gribparam(2,9,0,3,7,'HSTDV')/ + data paramlist(10) /gribparam(2,10,0,14,0,'TOZNE')/ + data paramlist(11) /gribparam(2,11,0,0,0,'TMP')/ + data paramlist(12) /gribparam(2,12,0,0,1,'VTMP')/ + data paramlist(13) /gribparam(2,13,0,0,2,'POT')/ + data paramlist(14) /gribparam(2,14,0,0,3,'EPOT')/ + data paramlist(15) /gribparam(2,15,0,0,4,'TMAX')/ + data paramlist(16) /gribparam(2,16,0,0,5,'TMIN')/ + data paramlist(17) /gribparam(2,17,0,0,6,'DPT')/ + data paramlist(18) /gribparam(2,18,0,0,7,'DEPR')/ + data paramlist(19) /gribparam(2,19,0,0,8,'LAPR')/ + data paramlist(20) /gribparam(2,20,0,19,0,'VIS')/ + data paramlist(21) /gribparam(2,21,0,15,6,'RDSP1')/ + data paramlist(22) /gribparam(2,22,0,15,7,'RDSP2')/ + data paramlist(23) /gribparam(2,23,0,15,8,'RDSP3')/ + data paramlist(24) /gribparam(2,24,0,7,0,'PLI')/ + data paramlist(25) /gribparam(2,25,0,0,9,'TMPA')/ + data paramlist(26) /gribparam(2,26,0,3,8,'PRESA')/ + data paramlist(27) /gribparam(2,27,0,3,9,'GPA')/ + data paramlist(28) /gribparam(2,28,10,0,0,'WVSP1')/ + data paramlist(29) /gribparam(2,29,10,0,1,'WVSP2')/ + data paramlist(30) /gribparam(2,30,10,0,2,'WVSP3')/ + data paramlist(31) /gribparam(2,31,0,2,0,'WDIR')/ + data paramlist(32) /gribparam(2,32,0,2,1,'WIND')/ + data paramlist(33) /gribparam(2,33,0,2,2,'UGRD')/ + data paramlist(34) /gribparam(2,34,0,2,3,'VGRD')/ + data paramlist(35) /gribparam(2,35,0,2,4,'STRM')/ + data paramlist(36) /gribparam(2,36,0,2,5,'VPOT')/ + data paramlist(37) /gribparam(2,37,0,2,6,'MNTSF')/ + data paramlist(38) /gribparam(2,38,0,2,7,'SGCVV')/ + data paramlist(39) /gribparam(2,39,0,2,8,'VVEL')/ + data paramlist(40) /gribparam(2,40,0,2,9,'DZDT')/ + data paramlist(41) /gribparam(2,41,0,2,10,'ABSV')/ + data paramlist(42) /gribparam(2,42,0,2,11,'ABSD')/ + data paramlist(43) /gribparam(2,43,0,2,12,'RELV')/ + data paramlist(44) /gribparam(2,44,0,2,13,'RELD')/ + data paramlist(45) /gribparam(2,45,0,2,15,'VUCSH')/ + data paramlist(46) /gribparam(2,46,0,2,16,'VVCSH')/ + data paramlist(47) /gribparam(2,47,10,1,0,'DIRC')/ + data paramlist(48) /gribparam(2,48,10,1,1,'SPC')/ + data paramlist(49) /gribparam(2,49,10,1,2,'UOGRD')/ + data paramlist(50) /gribparam(2,50,10,1,3,'VOGRD')/ + data paramlist(51) /gribparam(2,51,0,1,0,'SPFH')/ + data paramlist(52) /gribparam(2,52,0,1,1,'RH')/ + data paramlist(53) /gribparam(2,53,0,1,2,'MIXR')/ + data paramlist(54) /gribparam(2,54,0,1,3,'PWAT')/ + data paramlist(55) /gribparam(2,55,0,1,4,'VAPP')/ + data paramlist(56) /gribparam(2,56,0,1,5,'SATD')/ + data paramlist(57) /gribparam(2,57,0,1,6,'EVP')/ + data paramlist(58) /gribparam(2,58,0,6,0,'CICE')/ + data paramlist(59) /gribparam(2,59,0,1,7,'PRATE')/ + data paramlist(60) /gribparam(2,60,0,19,2,'TSTM')/ + data paramlist(61) /gribparam(2,61,0,1,8,'APCP')/ + data paramlist(62) /gribparam(2,62,0,1,9,'NCPCP')/ + data paramlist(63) /gribparam(2,63,0,1,10,'ACPCP')/ + data paramlist(64) /gribparam(2,64,0,1,12,'SRWEQ')/ + data paramlist(65) /gribparam(2,65,0,1,13,'WEASD')/ + data paramlist(66) /gribparam(2,66,0,1,11,'SNOD')/ + data paramlist(67) /gribparam(2,67,0,19,3,'MIXHT')/ + data paramlist(68) /gribparam(2,68,10,4,2,'TTHDP')/ + data paramlist(69) /gribparam(2,69,10,4,0,'MTHD')/ + data paramlist(70) /gribparam(2,70,10,4,1,'MTHA')/ + data paramlist(71) /gribparam(2,71,0,6,1,'TCDC')/ + data paramlist(72) /gribparam(2,72,0,6,2,'CDCON')/ + data paramlist(73) /gribparam(2,73,0,6,3,'LCDC')/ + data paramlist(74) /gribparam(2,74,0,6,4,'MCDC')/ + data paramlist(75) /gribparam(2,75,0,6,5,'HCDC')/ + data paramlist(76) /gribparam(2,76,0,6,6,'CWAT')/ + data paramlist(77) /gribparam(2,77,0,7,1,'BLI')/ + data paramlist(78) /gribparam(2,78,0,1,14,'SNOC')/ + data paramlist(79) /gribparam(2,79,0,1,15,'SNOL')/ + data paramlist(80) /gribparam(2,80,10,3,0,'WTMP')/ + data paramlist(81) /gribparam(2,81,2,0,0,'LAND')/ + data paramlist(82) /gribparam(2,82,10,3,1,'DSLM')/ + data paramlist(83) /gribparam(2,83,2,0,1,'SFCR')/ + data paramlist(84) /gribparam(2,84,0,19,1,'ALBDO')/ + data paramlist(85) /gribparam(2,85,2,0,2,'TSOIL')/ + data paramlist(86) /gribparam(2,86,2,0,3,'SOILM')/ + data paramlist(87) /gribparam(2,87,2,0,4,'VEG')/ + data paramlist(88) /gribparam(2,88,10,4,3,'SALTY')/ + data paramlist(89) /gribparam(2,89,0,3,10,'DEN')/ + data paramlist(90) /gribparam(2,90,2,0,5,'WATR')/ + data paramlist(91) /gribparam(2,91,10,2,0,'ICEC')/ + data paramlist(92) /gribparam(2,92,10,2,1,'ICETK')/ + data paramlist(93) /gribparam(2,93,10,2,2,'DICED')/ + data paramlist(94) /gribparam(2,94,10,2,3,'SICED')/ + data paramlist(95) /gribparam(2,95,10,2,4,'UICE')/ + data paramlist(96) /gribparam(2,96,10,2,5,'VICE')/ + data paramlist(97) /gribparam(2,97,10,2,6,'ICEG')/ + data paramlist(98) /gribparam(2,98,10,2,7,'ICED')/ + data paramlist(99) /gribparam(2,99,0,1,16,'SNOM')/ + data paramlist(100) /gribparam(2,100,10,0,3,'HTSGW')/ + data paramlist(101) /gribparam(2,101,10,0,4,'WVDIR')/ + data paramlist(102) /gribparam(2,102,10,0,5,'WVHGT')/ + data paramlist(103) /gribparam(2,103,10,0,6,'WVPER')/ + data paramlist(104) /gribparam(2,104,10,0,7,'SWDIR')/ + data paramlist(105) /gribparam(2,105,10,0,8,'SWELL')/ + data paramlist(106) /gribparam(2,106,10,0,9,'SWPER')/ + data paramlist(107) /gribparam(2,107,10,0,10,'DIRPW')/ + data paramlist(108) /gribparam(2,108,10,0,11,'PERPW')/ + data paramlist(109) /gribparam(2,109,10,0,12,'DIRSW')/ + data paramlist(110) /gribparam(2,110,10,0,13,'PERSW')/ + data paramlist(111) /gribparam(2,111,0,4,0,'NSWRS')/ + data paramlist(112) /gribparam(2,112,0,5,0,'NLWRS')/ + data paramlist(113) /gribparam(2,113,0,4,1,'NSWRT')/ + data paramlist(114) /gribparam(2,114,0,5,1,'NLWRT')/ + data paramlist(115) /gribparam(2,115,0,5,2,'LWAVR')/ + data paramlist(116) /gribparam(2,116,0,4,2,'SWAVR')/ + data paramlist(117) /gribparam(2,117,0,4,3,'GRAD')/ + data paramlist(118) /gribparam(2,118,0,4,4,'BRTMP')/ + data paramlist(119) /gribparam(2,119,0,4,5,'LWRAD')/ + data paramlist(120) /gribparam(2,120,0,4,6,'SWRAD')/ + data paramlist(121) /gribparam(2,121,0,0,10,'LHTFL')/ + data paramlist(122) /gribparam(2,122,0,0,11,'SHTFL')/ + data paramlist(123) /gribparam(2,123,0,2,20,'BLYDP')/ + data paramlist(124) /gribparam(2,124,0,2,17,'UFLX')/ + data paramlist(125) /gribparam(2,125,0,2,18,'VFLX')/ + data paramlist(126) /gribparam(2,126,0,2,19,'WMIXE')/ + data paramlist(127) /gribparam(2,127,255,255,255,'IMGD')/ +! +! GRIB1 parameters in NCEP Local Table version 2 +! Added 8/07/2003 +! + data paramlist(128) /gribparam(2,229,0,0,192,'SNOHF')/ + data paramlist(129) /gribparam(2,153,0,1,22,'CLWMR')/ + data paramlist(130) /gribparam(2,140,0,1,192,'CRAIN')/ + data paramlist(131) /gribparam(2,141,0,1,193,'CFRZR')/ + data paramlist(132) /gribparam(2,142,0,1,194,'CICEP')/ + data paramlist(133) /gribparam(2,143,0,1,195,'CSNOW')/ + data paramlist(134) /gribparam(2,214,0,1,196,'CPRAT')/ + data paramlist(135) /gribparam(2,135,0,1,197,'MCONV')/ + data paramlist(136) /gribparam(2,194,1,1,193,'CPOFP')/ + data paramlist(137) /gribparam(2,228,0,1,199,'PEVAP')/ + data paramlist(138) /gribparam(2,136,0,2,192,'VWSH')/ + data paramlist(139) /gribparam(2,172,0,2,193,'MFLX')/ + data paramlist(140) /gribparam(2,196,0,2,194,'USTM')/ + data paramlist(141) /gribparam(2,197,0,2,195,'VSTM')/ + data paramlist(142) /gribparam(2,252,0,2,196,'CD')/ + data paramlist(143) /gribparam(2,253,0,2,197,'FRICV')/ + data paramlist(144) /gribparam(2,130,0,3,192,'MSLET')/ + data paramlist(145) /gribparam(2,204,0,4,192,'DSWRF')/ + data paramlist(146) /gribparam(2,211,0,4,193,'USWRF')/ + data paramlist(147) /gribparam(2,205,0,5,192,'DLWRF')/ + data paramlist(148) /gribparam(2,212,0,5,193,'ULWRF')/ + data paramlist(149) /gribparam(2,213,0,6,192,'CDLYR')/ + data paramlist(150) /gribparam(2,132,0,7,193,'4LFTX')/ + data paramlist(151) /gribparam(2,157,0,7,6,'CAPE')/ + data paramlist(152) /gribparam(2,156,0,7,7,'CIN')/ + data paramlist(153) /gribparam(2,190,0,7,8,'HLCY')/ + data paramlist(154) /gribparam(2,131,0,7,192,'LFTX')/ + data paramlist(155) /gribparam(2,158,0,19,11,'TKE')/ + data paramlist(156) /gribparam(2,176,0,191,192,'NLAT')/ + data paramlist(157) /gribparam(2,177,0,191,193,'ELON')/ + data paramlist(158) /gribparam(2,234,1,0,192,'BGRUN')/ + data paramlist(159) /gribparam(2,235,1,0,193,'SSRUN')/ + data paramlist(160) /gribparam(2,144,2,0,192,'SOILW')/ + data paramlist(161) /gribparam(2,155,2,0,193,'GFLUX')/ + data paramlist(162) /gribparam(2,207,2,0,194,'MSTAV')/ + data paramlist(163) /gribparam(2,208,2,0,195,'SFEXC')/ + data paramlist(164) /gribparam(2,223,2,0,196,'CNWAT')/ + data paramlist(165) /gribparam(2,226,2,0,197,'BMIXL')/ + data paramlist(166) /gribparam(2,154,0,14,192,'O3MR')/ + data paramlist(167) /gribparam(2,222,0,3,193,'5WAVH')/ + data paramlist(168) /gribparam(2,145,0,1,200,'PEVPR')/ + data paramlist(169) /gribparam(2,146,0,6,193,'CWORK')/ + data paramlist(170) /gribparam(2,147,0,3,194,'U-GWD')/ + data paramlist(171) /gribparam(2,148,0,3,195,'V-GWD')/ + data paramlist(172) /gribparam(2,221,0,3,196,'HPBL')/ + data paramlist(173) /gribparam(2,230,0,3,197,'5WAVA')/ +! Added 9/26/2003 + data paramlist(174) /gribparam(130,160,2,3,192,'SOILL')/ + data paramlist(175) /gribparam(130,171,2,3,193,'RLYRS')/ + data paramlist(176) /gribparam(130,219,2,0,201,'WILT')/ + data paramlist(177) /gribparam(130,222,2,3,194,'SLTYP')/ + data paramlist(178) /gribparam(2,224,2,3,0,'SOTYP')/ + data paramlist(179) /gribparam(2,225,2,0,198,'VGTYP')/ + data paramlist(180) /gribparam(130,230,2,3,195,'SMREF')/ + data paramlist(181) /gribparam(130,231,2,3,196,'SMDRY')/ + data paramlist(182) /gribparam(2,238,0,1,201,'SNOWC')/ + data paramlist(183) /gribparam(130,240,2,3,197,'POROS')/ + data paramlist(184) /gribparam(129,131,0,1,202,'FRAIN')/ + data paramlist(185) /gribparam(129,132,0,6,199,'FICE')/ + data paramlist(186) /gribparam(129,133,0,1,203,'RIME')/ + data paramlist(187) /gribparam(129,134,0,6,194,'CUEFI')/ + data paramlist(188) /gribparam(129,135,0,6,195,'TCOND')/ + data paramlist(189) /gribparam(129,136,0,6,196,'TCOLW')/ + data paramlist(190) /gribparam(129,137,0,6,197,'TCOLI')/ + data paramlist(191) /gribparam(129,138,0,1,204,'TCOLR')/ + data paramlist(192) /gribparam(129,139,0,1,205,'TCOLS')/ + data paramlist(193) /gribparam(129,140,0,6,198,'TCOLC')/ + data paramlist(194) /gribparam(130,159,0,19,192,'MXSALB')/ + data paramlist(195) /gribparam(130,170,0,19,193,'SNFALB')/ + data paramlist(196) /gribparam(2,170,0,1,24,'RWMR')/ + data paramlist(197) /gribparam(2,171,0,1,25,'SNMR')/ + data paramlist(198) /gribparam(130,181,2,0,199,'CCOND')/ + data paramlist(199) /gribparam(130,203,2,0,200,'RSMIN')/ + data paramlist(200) /gribparam(130,246,2,0,202,'RCS')/ + data paramlist(201) /gribparam(130,247,2,0,203,'RCT')/ + data paramlist(202) /gribparam(130,248,2,0,204,'RCQ')/ + data paramlist(203) /gribparam(130,249,2,0,205,'RCSOL')/ + data paramlist(204) /gribparam(2,254,0,7,194,'RI')/ + data paramlist(205) /gribparam(129,190,3,1,192,'USCT')/ + data paramlist(206) /gribparam(129,191,3,1,193,'VSCT')/ + data paramlist(207) /gribparam(129,171,0,191,194,'TSEC')/ + data paramlist(208) /gribparam(129,180,0,14,193,'OZCON')/ + data paramlist(209) /gribparam(129,181,0,14,194,'OZCAT')/ + data paramlist(210) /gribparam(2,193,1,1,2,'POP')/ + data paramlist(211) /gribparam(2,195,1,1,192,'CPOZP')/ + data paramlist(212) /gribparam(2,180,0,2,22,'GUST')/ +! Added 11/17/2005 - for wave models + data paramlist(213) /gribparam(0,31,0,2,0,'WDIR')/ + data paramlist(214) /gribparam(0,32,0,2,1,'WIND')/ + data paramlist(215) /gribparam(0,33,0,2,2,'UGRD')/ + data paramlist(216) /gribparam(0,34,0,2,3,'VGRD')/ + data paramlist(217) /gribparam(0,100,10,0,3,'HTSGW')/ + data paramlist(218) /gribparam(0,101,10,0,4,'WVDIR')/ + data paramlist(219) /gribparam(0,103,10,0,6,'WVPER')/ + data paramlist(220) /gribparam(0,107,10,0,10,'DIRPW')/ + data paramlist(221) /gribparam(0,108,10,0,11,'PERPW')/ + data paramlist(222) /gribparam(0,109,10,0,12,'DIRSW')/ + data paramlist(223) /gribparam(0,110,10,0,13,'PERSW')/ +! Added 1/26/2006 - + data paramlist(224) /gribparam(129,156,0,13,192,'PMTC')/ + data paramlist(225) /gribparam(129,157,0,13,193,'PMTF')/ + data paramlist(226) /gribparam(3,11,0,0,0,'TMP')/ + data paramlist(227) /gribparam(2,129,0,3,198,'MSLMA')/ + data paramlist(228) /gribparam(129,163,0,13,194,'LPMTF')/ + data paramlist(229) /gribparam(129,164,0,13,195,'LIPMF')/ +! Added 3/6/2006 - For missing GRIB1 to GRIB2 conversions + data paramlist(230) /gribparam(2,178,0,1,23,'ICMR')/ + data paramlist(231) /gribparam(2,179,0,1,32,'GRMR')/ + data paramlist(232) /gribparam(2,186,0,1,206,'TIPD')/ + data paramlist(233) /gribparam(2,187,0,17,192,'LTNG')/ + data paramlist(234) /gribparam(2,188,2,0,206,'RDRIP')/ + data paramlist(235) /gribparam(2,189,0,0,15,'VPTMP')/ + data paramlist(236) /gribparam(2,198,0,1,207,'NCIP')/ + data paramlist(237) /gribparam(2,239,0,1,208,'SNOT')/ + data paramlist(238) /gribparam(2,128,0,3,1,'MSLSA')/ + data paramlist(239) /gribparam(2,137,0,3,199,'TSLSA')/ + data paramlist(240) /gribparam(129,141,0,3,200,'PLPL')/ + data paramlist(241) /gribparam(129,200,0,4,194,'DUVB')/ + data paramlist(242) /gribparam(129,201,0,4,195,'CDUVB')/ + data paramlist(243) /gribparam(2,201,2,0,207,'ICWAT')/ + data paramlist(244) /gribparam(2,209,0,19,204,'MIXLY')/ + data paramlist(245) /gribparam(2,216,0,0,193,'TTRAD')/ + data paramlist(246) /gribparam(129,211,0,16,195,'REFD')/ + data paramlist(247) /gribparam(129,212,0,16,196,'REFC')/ + data paramlist(248) /gribparam(2,161,0,4,196,'CSDSF')/ + data paramlist(249) /gribparam(129,168,0,1,209,'TCLSW')/ + data paramlist(250) /gribparam(129,169,0,1,210,'TCOLM')/ + data paramlist(251) /gribparam(2,181,0,3,201,'LPSX')/ + data paramlist(252) /gribparam(2,182,0,3,202,'LPSY')/ + data paramlist(253) /gribparam(2,183,0,3,203,'HGTX')/ + data paramlist(254) /gribparam(2,184,0,3,204,'HGTY')/ + data paramlist(255) /gribparam(128,254,0,0,194,'REV')/ +! Added 4/20/2007 - For missing GRIB1 to GRIB2 conversions + data paramlist(256) /gribparam(1,91,10,2,0,'ICEC')/ + data paramlist(257) /gribparam(0,49,10,1,2,'UOGRD')/ + data paramlist(258) /gribparam(0,50,10,1,3,'VOGRD')/ + data paramlist(259) /gribparam(0,80,10,3,0,'WTMP')/ + data paramlist(260) /gribparam(0,82,10,3,1,'DSLM')/ + data paramlist(261) /gribparam(0,88,10,4,3,'SALTY')/ + data paramlist(262) /gribparam(1,49,10,1,2,'UOGRD')/ + data paramlist(263) /gribparam(1,50,10,1,3,'VOGRD')/ + data paramlist(264) /gribparam(1,80,10,3,0,'WTMP')/ + data paramlist(265) /gribparam(1,88,10,4,3,'SALTY')/ + data paramlist(266) /gribparam(1,40,0,2,9,'DZDT')/ + data paramlist(267) /gribparam(1,67,0,19,3,'MIXHT')/ + data paramlist(268) /gribparam(3,2,0,3,1,'PRMSL')/ + data paramlist(269) /gribparam(3,7,0,3,5,'HGT')/ + data paramlist(270) /gribparam(128,130,10,3,194,'ELEV')/ + data paramlist(271) /gribparam(129,217,0,1,198,'MINRH')/ + data paramlist(272) /gribparam(129,218,0,1,27,'MAXRH')/ + data paramlist(273) /gribparam(130,161,0,1,29,'ASNOW')/ + data paramlist(274) /gribparam(129,165,0,16,192,'REFZR')/ + data paramlist(275) /gribparam(129,166,0,16,193,'REFZI')/ + data paramlist(276) /gribparam(129,167,0,16,194,'REFZC')/ + data paramlist(277) /gribparam(129,192,0,2,198,'LAUV')/ + data paramlist(278) /gribparam(129,193,0,2,199,'LOUV')/ + data paramlist(279) /gribparam(129,188,0,2,200,'LAVV')/ + data paramlist(280) /gribparam(129,189,0,2,201,'LOVV')/ + data paramlist(281) /gribparam(129,207,0,2,202,'LAPP')/ + data paramlist(282) /gribparam(129,208,0,2,203,'LOPP')/ + data paramlist(283) /gribparam(129,198,10,3,195,'SSHG')/ + data paramlist(284) /gribparam(1,33,0,2,2,'UGRD')/ + data paramlist(285) /gribparam(1,34,0,2,3,'VGRD')/ + data paramlist(286) /gribparam(1,2,0,3,1,'PRMSL')/ + data paramlist(287) /gribparam(1,7,0,3,5,'HGT')/ + data paramlist(288) /gribparam(128,186,10,4,192,'WTMPC')/ + data paramlist(289) /gribparam(128,187,10,4,193,'SALIN')/ + data paramlist(290) /gribparam(128,177,10,3,196,'P2OMLT')/ + data paramlist(291) /gribparam(128,178,10,1,192,'OMLU')/ + data paramlist(292) /gribparam(128,179,10,1,193,'OMLV')/ + data paramlist(293) /gribparam(128,183,10,1,194,'UBARO')/ + data paramlist(294) /gribparam(128,184,10,1,195,'VBARO')/ + data paramlist(295) /gribparam(129,179,0,19,205,'FLGHT')/ + data paramlist(296) /gribparam(129,185,0,19,206,'CICEL')/ + data paramlist(297) /gribparam(129,186,0,19,207,'CIVIS')/ + data paramlist(298) /gribparam(129,187,0,19,208,'CIFLT')/ + data paramlist(299) /gribparam(129,177,0,19,209,'LAVNI')/ + data paramlist(300) /gribparam(129,178,0,19,210,'HAVNI')/ + data paramlist(301) /gribparam(130,189,0,19,211,'SBSALB')/ + data paramlist(302) /gribparam(130,190,0,19,212,'SWSALB')/ + data paramlist(303) /gribparam(130,191,0,19,213,'NBSALB')/ + data paramlist(304) /gribparam(130,192,0,19,214,'NWSALB')/ + data paramlist(305) /gribparam(129,149,10,0,192,'WSTP')/ + data paramlist(306) /gribparam(128,188,0,1,211,'EMNP')/ + data paramlist(307) /gribparam(128,192,0,3,205,'LAYTH')/ + data paramlist(308) /gribparam(129,219,0,6,13,'CEIL')/ + data paramlist(309) /gribparam(129,220,0,19,12,'PBLREG')/ + data paramlist(310) /gribparam(130,179,2,0,228,'ACOND')/ + data paramlist(311) /gribparam(130,198,0,1,212,'SBSNO')/ + data paramlist(312) /gribparam(2,199,2,3,198,'EVBS')/ + data paramlist(313) /gribparam(2,200,2,0,229,'EVCW')/ + data paramlist(314) /gribparam(2,210,2,0,230,'TRANS')/ + data paramlist(315) /gribparam(129,182,0,2,204,'VEDH')/ + data paramlist(320) /gribparam(2,241,0,0,195,'LRGHR')/ + data paramlist(321) /gribparam(2,242,0,0,196,'CNVHR')/ + data paramlist(322) /gribparam(140,168,0,19,20,'ICIP')/ + data paramlist(323) /gribparam(140,169,0,19,20,'ICIP')/ + data paramlist(324) /gribparam(140,170,0,19,21,'CTP')/ + data paramlist(325) /gribparam(140,171,0,19,21,'CTP')/ + data paramlist(326) /gribparam(140,172,0,19,22,'CAT')/ + data paramlist(327) /gribparam(140,173,0,19,22,'CAT')/ + data paramlist(328) /gribparam(140,174,0,6,25,'CBHE')/ + data paramlist(329) /gribparam(140,175,255,255,255,'IMGD')/ + data paramlist(330) /gribparam(140,176,255,255,255,'IMGD')/ + data paramlist(331) /gribparam(140,177,255,255,255,'IMGD')/ + data paramlist(332) /gribparam(140,178,255,255,255,'IMGD')/ + data paramlist(333) /gribparam(140,179,0,3,3,'ICAHT')/ + data paramlist(334) /gribparam(140,180,0,3,3,'ICAHT')/ + data paramlist(335) /gribparam(140,181,255,255,255,'IMGD')/ + data paramlist(336) /gribparam(140,182,255,255,255,'IMGD')/ + data paramlist(337) /gribparam(129,76,0,6,6,'CWAT')/ +! Added 8/24/2007 + data paramlist(338) /gribparam(0,104,10,0,7,'SWDIR')/ + data paramlist(339) /gribparam(0,105,10,0,8,'SWELL')/ + data paramlist(340) /gribparam(0,106,10,0,9,'SWPER')/ + data paramlist(341) /gribparam(0,102,10,0,5,'WVHGT')/ + data paramlist(342) /gribparam(129,213,3,192,0,'SBT122')/ + data paramlist(343) /gribparam(129,214,3,192,1,'SBT123')/ + data paramlist(344) /gribparam(129,215,3,192,2,'SBT124')/ + data paramlist(345) /gribparam(129,216,3,192,3,'SBT126')/ + data paramlist(346) /gribparam(129,221,3,192,4,'SBC123')/ + data paramlist(347) /gribparam(129,222,3,192,5,'SBC124')/ + data paramlist(348) /gribparam(129,228,10,3,192,'SURGE')/ + data paramlist(349) /gribparam(129,229,10,3,193,'ETSRG')/ + data paramlist(350) /gribparam(2,149,0,2,14,'PVORT')/ + data paramlist(351) /gribparam(2,150,0,192,1,'COVMZ')/ + data paramlist(352) /gribparam(2,151,0,192,2,'COVTZ')/ + data paramlist(353) /gribparam(2,152,0,192,3,'COVTM')/ + data paramlist(354) /gribparam(129,202,0,0,197,'THFLX')/ + data paramlist(355) /gribparam(3,33,0,2,2,'UGRD')/ + data paramlist(356) /gribparam(3,34,0,2,3,'VGRD')/ + data paramlist(357) /gribparam(3,40,0,2,9,'DZDT')/ + data paramlist(358) /gribparam(3,124,0,2,17,'UFLX')/ + data paramlist(359) /gribparam(3,125,0,2,18,'VFLX')/ + data paramlist(360) /gribparam(3,8,0,3,6,'DIST')/ + data paramlist(361) /gribparam(3,13,0,0,2,'POT')/ + data paramlist(362) /gribparam(3,88,10,4,3,'SALTY')/ + data paramlist(363) /gribparam(3,49,10,1,2,'UOGRD')/ + data paramlist(364) /gribparam(3,50,10,1,3,'VOGRD')/ + data paramlist(365) /gribparam(2,215,0,0,198,'TTDIA')/ + data paramlist(366) /gribparam(2,217,0,0,199,'TTPHY')/ + data paramlist(367) /gribparam(130,154,2,3,199,'LSPA')/ + data paramlist(368) /gribparam(2,250,0,4,197,'SWHR')/ + data paramlist(369) /gribparam(2,251,0,5,194,'LWHR')/ + data paramlist(370) /gribparam(2,160,0,4,198,'CSUSF')/ + data paramlist(371) /gribparam(2,162,0,5,195,'CSULF')/ + data paramlist(372) /gribparam(2,163,0,5,196,'CSDLF')/ + data paramlist(373) /gribparam(2,164,0,4,199,'CFNSF')/ + data paramlist(374) /gribparam(2,165,0,5,197,'CFNLF')/ + data paramlist(375) /gribparam(2,166,0,4,200,'VBDSF')/ + data paramlist(376) /gribparam(2,167,0,4,201,'VDDSF')/ + data paramlist(377) /gribparam(2,168,0,4,202,'NBDSF')/ + data paramlist(378) /gribparam(2,169,0,4,203,'NDDSF')/ + data paramlist(379) /gribparam(2,206,0,7,196,'UVI')/ + data paramlist(380) /gribparam(2,219,0,0,200,'TSD1D')/ + data paramlist(381) /gribparam(2,220,0,3,206,'NLGSP')/ + data paramlist(382) /gribparam(2,244,0,0,201,'SHAHR')/ + data paramlist(383) /gribparam(2,246,0,0,202,'VDFHR')/ + data paramlist(384) /gribparam(2,243,0,1,213,'CNVMR')/ + data paramlist(385) /gribparam(2,245,0,1,214,'SHAMR')/ + data paramlist(386) /gribparam(2,249,0,1,215,'VDFMR')/ + data paramlist(387) /gribparam(2,247,0,2,208,'VDFUA')/ + data paramlist(388) /gribparam(2,248,0,2,209,'VDFVA')/ + data paramlist(389) /gribparam(3,202,0,7,195,'CWDI')/ + data paramlist(390) /gribparam(2,232,0,4,204,'DTRF')/ + data paramlist(391) /gribparam(2,233,0,4,205,'UTRF')/ + data paramlist(392) /gribparam(2,231,0,6,200,'MFLUX')/ + data paramlist(393) /gribparam(2,202,0,7,195,'CWDI')/ + data paramlist(394) /gribparam(2,203,0,19,232,'VAFTD')/ + data paramlist(395) /gribparam(3,238,0,1,201,'SNOWC')/ + data paramlist(396) /gribparam(3,66,0,1,11,'SNOD')/ + data paramlist(397) /gribparam(2,133,0,7,2,'KX')/ + data paramlist(398) /gribparam(2,134,0,7,5,'SX')/ + data paramlist(399) /gribparam(128,191,10,4,194,'BKENG')/ + data paramlist(400) /gribparam(129,195,10,4,195,'DBSS')/ + data paramlist(401) /gribparam(128,171,10,3,197,'AOHFLX')/ + data paramlist(402) /gribparam(128,180,10,3,198,'ASHFL')/ + data paramlist(403) /gribparam(128,193,10,3,199,'SSTT')/ + data paramlist(404) /gribparam(128,194,10,3,200,'SSST')/ + data paramlist(405) /gribparam(128,190,10,3,201,'KENG')/ + data paramlist(406) /gribparam(128,185,10,4,196,'INTFD')/ + data paramlist(407) /gribparam(129,199,10,3,202,'SLTFL')/ + data paramlist(408) /gribparam(129,197,10,4,197,'OHC')/ + data paramlist(409) /gribparam(2,159,0,1,216,'CONP')/ + data paramlist(410) /gribparam(2,175,0,191,195,'MLYNO')/ + data paramlist(411) /gribparam(129,223,0,1,65,'RPRATE')/ + data paramlist(412) /gribparam(129,224,0,1,66,'SPRATE')/ + data paramlist(413) /gribparam(129,225,0,1,67,'FPRATE')/ + data paramlist(414) /gribparam(129,226,0,1,68,'IPRATE')/ + data paramlist(415) /gribparam(129,227,0,7,197,'UPHL')/ + data paramlist(416) /gribparam(3,87,2,0,4,'VEG')/ + data paramlist(417) /gribparam(129,130,1,1,195,'CWR')/ + data paramlist(418) /gribparam(2,240,0,192,4,'COVTW')/ + data paramlist(419) /gribparam(133,164,0,192,5,'COVZZ')/ + data paramlist(420) /gribparam(133,165,0,192,6,'COVMM')/ + data paramlist(421) /gribparam(133,166,0,192,7,'COVQZ')/ + data paramlist(422) /gribparam(133,167,0,192,8,'COVQM')/ + data paramlist(423) /gribparam(133,168,0,192,9,'COVTVV')/ + data paramlist(424) /gribparam(133,169,0,192,10,'COVQVV')/ + data paramlist(425) /gribparam(133,203,0,192,11,'COVPSPS')/ + data paramlist(426) /gribparam(133,206,0,192,12,'COVQQ')/ + data paramlist(427) /gribparam(133,220,0,192,13,'COVVVVV')/ + data paramlist(428) /gribparam(133,234,0,192,14,'COVTT')/ + data paramlist(429) /gribparam(133,201,0,0,203,'THZ0')/ + data paramlist(430) /gribparam(133,195,0,1,218,'QZ0')/ + data paramlist(431) /gribparam(133,204,0,1,219,'QMAX')/ + data paramlist(432) /gribparam(133,205,0,1,220,'QMIN')/ + data paramlist(433) /gribparam(133,181,0,2,210,'GWDU')/ + data paramlist(434) /gribparam(133,182,0,2,211,'GWDV')/ + data paramlist(435) /gribparam(133,183,0,2,212,'CNVU')/ + data paramlist(436) /gribparam(133,184,0,2,213,'CNVV')/ + data paramlist(437) /gribparam(133,236,0,2,214,'WTEND')/ + data paramlist(438) /gribparam(133,154,0,2,215,'OMGALF')/ + data paramlist(439) /gribparam(133,196,0,2,216,'CNGWDU')/ + data paramlist(440) /gribparam(133,197,0,2,217,'CNGWDV')/ + data paramlist(441) /gribparam(133,202,0,3,207,'CNVUMF')/ + data paramlist(442) /gribparam(133,209,0,3,208,'CNVDMF')/ + data paramlist(443) /gribparam(133,219,0,3,209,'CNVDEMF')/ + data paramlist(444) /gribparam(133,173,0,1,217,'LRGMR')/ + data paramlist(445) /gribparam(133,174,0,14,195,'VDFOZ')/ + data paramlist(446) /gribparam(133,175,0,14,196,'POZ')/ + data paramlist(447) /gribparam(133,188,0,14,197,'TOZ')/ + data paramlist(448) /gribparam(133,139,0,14,198,'POZT')/ + data paramlist(449) /gribparam(133,239,0,14,199,'POZO')/ + data paramlist(450) /gribparam(133,185,2,0,208,'AKHS')/ + data paramlist(451) /gribparam(133,186,2,0,209,'AKMS')/ + data paramlist(452) /gribparam(133,193,0,19,218,'EPSR')/ + data paramlist(453) /gribparam(130,229,0,0,192,'SNOHF')/ + data paramlist(454) /gribparam(129,194,0,0,204,'TCHP')/ +! Added 5/29/2008 + data paramlist(455) /gribparam(2,185,0,19,219,'TPFI')/ + data paramlist(456) /gribparam(130,182,0,7,198,'LAI')/ + data paramlist(457) /gribparam(2,173,0,3,210,'LMH')/ + data paramlist(458) /gribparam(2,174,0,2,218,'LMV')/ +! Added 6/30/2008 Add GRIB1 parameters in Table version 131 + data paramlist(459) /gribparam(131,1,0,3,0,'PRES')/ + data paramlist(460) /gribparam(131,2,0,3,1,'PRMSL')/ + data paramlist(461) /gribparam(131,3,0,3,2,'PTEND')/ + data paramlist(462) /gribparam(131,4,0,2,14,'PVORT')/ + data paramlist(463) /gribparam(131,5,0,3,3,'ICAHT')/ + data paramlist(464) /gribparam(131,6,0,3,4,'GP')/ + data paramlist(465) /gribparam(131,7,0,3,5,'HGT')/ + data paramlist(466) /gribparam(131,8,0,3,6,'DIST')/ + data paramlist(467) /gribparam(131,9,0,3,7,'HSTDV')/ + data paramlist(468) /gribparam(131,10,0,14,0,'TOZNE')/ + data paramlist(469) /gribparam(131,11,0,0,0,'TMP')/ + data paramlist(470) /gribparam(131,12,0,0,1,'VTMP')/ + data paramlist(471) /gribparam(131,13,0,0,2,'POT')/ + data paramlist(472) /gribparam(131,14,0,0,3,'EPOT')/ + data paramlist(473) /gribparam(131,15,0,0,4,'TMAX')/ + data paramlist(474) /gribparam(131,16,0,0,5,'TMIN')/ + data paramlist(475) /gribparam(131,17,0,0,6,'DPT')/ + data paramlist(476) /gribparam(131,18,0,0,7,'DEPR')/ + data paramlist(477) /gribparam(131,19,0,0,8,'LAPR')/ + data paramlist(478) /gribparam(131,20,0,19,0,'VIS')/ + data paramlist(479) /gribparam(131,21,0,15,6,'RDSP1')/ + data paramlist(480) /gribparam(131,22,0,15,7,'RDSP2')/ + data paramlist(481) /gribparam(131,23,0,15,8,'RDSP3')/ + data paramlist(482) /gribparam(131,24,0,7,0,'PLI')/ + data paramlist(483) /gribparam(131,25,0,0,9,'TMPA')/ + data paramlist(484) /gribparam(131,26,0,3,8,'PRESA')/ + data paramlist(485) /gribparam(131,27,0,3,9,'GPA')/ + data paramlist(486) /gribparam(131,28,10,0,0,'WVSP1')/ + data paramlist(487) /gribparam(131,29,10,0,1,'WVSP2')/ + data paramlist(488) /gribparam(131,30,10,0,2,'WVSP3')/ + data paramlist(489) /gribparam(131,31,0,2,0,'WDIR')/ + data paramlist(490) /gribparam(131,32,0,2,1,'WIND')/ + data paramlist(491) /gribparam(131,33,0,2,2,'UGRD')/ + data paramlist(492) /gribparam(131,34,0,2,3,'VGRD')/ + data paramlist(493) /gribparam(131,35,0,2,4,'STRM')/ + data paramlist(494) /gribparam(131,36,0,2,5,'VPOT')/ + data paramlist(495) /gribparam(131,37,0,2,6,'MNTSF')/ + data paramlist(496) /gribparam(131,38,0,2,7,'SGCVV')/ + data paramlist(497) /gribparam(131,39,0,2,8,'VVEL')/ + data paramlist(498) /gribparam(131,40,0,2,9,'DZDT')/ + data paramlist(499) /gribparam(131,41,0,2,10,'ABSV')/ + data paramlist(500) /gribparam(131,42,0,2,11,'ABSD')/ + data paramlist(501) /gribparam(131,43,0,2,12,'RELV')/ + data paramlist(502) /gribparam(131,44,0,2,13,'RELD')/ + data paramlist(503) /gribparam(131,45,0,2,15,'VUCSH')/ + data paramlist(504) /gribparam(131,46,0,2,16,'VVCSH')/ + data paramlist(505) /gribparam(131,47,10,1,0,'DIRC')/ + data paramlist(506) /gribparam(131,48,10,1,1,'SPC')/ + data paramlist(507) /gribparam(131,49,10,1,2,'UOGRD')/ + data paramlist(508) /gribparam(131,50,10,1,3,'VOGRD')/ + data paramlist(509) /gribparam(131,51,0,1,0,'SPFH')/ + data paramlist(510) /gribparam(131,52,0,1,1,'RH')/ + data paramlist(511) /gribparam(131,53,0,1,2,'MIXR')/ + data paramlist(512) /gribparam(131,54,0,1,3,'PWAT')/ + data paramlist(513) /gribparam(131,55,0,1,4,'VAPP')/ + data paramlist(514) /gribparam(131,56,0,1,5,'SATD')/ + data paramlist(515) /gribparam(131,57,0,1,6,'EVP')/ + data paramlist(516) /gribparam(131,58,0,6,0,'CICE')/ + data paramlist(517) /gribparam(131,59,0,1,7,'PRATE')/ + data paramlist(518) /gribparam(131,60,0,19,2,'TSTM')/ + data paramlist(519) /gribparam(131,61,0,1,8,'APCP')/ + data paramlist(520) /gribparam(131,62,0,1,9,'NCPCP')/ + data paramlist(521) /gribparam(131,63,0,1,10,'ACPCP')/ + data paramlist(522) /gribparam(131,64,0,1,12,'SRWEQ')/ + data paramlist(523) /gribparam(131,65,0,1,13,'WEASD')/ + data paramlist(524) /gribparam(131,66,0,1,11,'SNOD')/ + data paramlist(525) /gribparam(131,67,0,19,3,'MIXHT')/ + data paramlist(526) /gribparam(131,68,10,4,2,'TTHDP')/ + data paramlist(527) /gribparam(131,69,10,4,0,'MTHD')/ + data paramlist(528) /gribparam(131,70,10,4,1,'MTHA')/ + data paramlist(529) /gribparam(131,71,0,6,1,'TCDC')/ + data paramlist(530) /gribparam(131,72,0,6,2,'CDCON')/ + data paramlist(531) /gribparam(131,73,0,6,3,'LCDC')/ + data paramlist(532) /gribparam(131,74,0,6,4,'MCDC')/ + data paramlist(533) /gribparam(131,75,0,6,5,'HCDC')/ + data paramlist(534) /gribparam(131,76,0,6,6,'CWAT')/ + data paramlist(535) /gribparam(131,77,0,7,1,'BLI')/ + data paramlist(536) /gribparam(131,78,0,1,14,'SNOC')/ + data paramlist(537) /gribparam(131,79,0,1,15,'SNOL')/ + data paramlist(538) /gribparam(131,80,10,3,0,'WTMP')/ + data paramlist(539) /gribparam(131,81,2,0,0,'LAND')/ + data paramlist(540) /gribparam(131,82,10,3,1,'DSLM')/ + data paramlist(541) /gribparam(131,83,2,0,1,'SFCR')/ + data paramlist(542) /gribparam(131,84,0,19,1,'ALBDO')/ + data paramlist(543) /gribparam(131,85,2,0,2,'TSOIL')/ + data paramlist(544) /gribparam(131,86,2,0,3,'SOILM')/ + data paramlist(545) /gribparam(131,87,2,0,4,'VEG')/ + data paramlist(546) /gribparam(131,88,10,4,3,'SALTY')/ + data paramlist(547) /gribparam(131,89,0,3,10,'DEN')/ + data paramlist(548) /gribparam(131,90,2,0,5,'WATR')/ + data paramlist(549) /gribparam(131,91,10,2,0,'ICEC')/ + data paramlist(550) /gribparam(131,92,10,2,1,'ICETK')/ + data paramlist(551) /gribparam(131,93,10,2,2,'DICED')/ + data paramlist(552) /gribparam(131,94,10,2,3,'SICED')/ + data paramlist(553) /gribparam(131,95,10,2,4,'UICE')/ + data paramlist(554) /gribparam(131,96,10,2,5,'VICE')/ + data paramlist(555) /gribparam(131,97,10,2,6,'ICEG')/ + data paramlist(556) /gribparam(131,98,10,2,7,'ICED')/ + data paramlist(557) /gribparam(131,99,0,1,16,'SNOM')/ + data paramlist(558) /gribparam(131,100,10,0,3,'HTSGW')/ + data paramlist(559) /gribparam(131,101,10,0,4,'WVDIR')/ + data paramlist(560) /gribparam(131,102,10,0,5,'WVHGT')/ + data paramlist(561) /gribparam(131,103,10,0,6,'WVPER')/ + data paramlist(562) /gribparam(131,104,10,0,7,'SWDIR')/ + data paramlist(563) /gribparam(131,105,10,0,8,'SWELL')/ + data paramlist(564) /gribparam(131,106,10,0,9,'SWPER')/ + data paramlist(565) /gribparam(131,107,10,0,10,'DIRPW')/ + data paramlist(566) /gribparam(131,108,10,0,11,'PERPW')/ + data paramlist(567) /gribparam(131,109,10,0,12,'DIRSW')/ + data paramlist(568) /gribparam(131,110,10,0,13,'PERSW')/ + data paramlist(569) /gribparam(131,111,0,4,0,'NSWRS')/ + data paramlist(570) /gribparam(131,112,0,5,0,'NLWRS')/ + data paramlist(571) /gribparam(131,113,0,4,1,'NSWRT')/ + data paramlist(572) /gribparam(131,114,0,5,1,'NLWRT')/ + data paramlist(573) /gribparam(131,115,0,5,2,'LWAVR')/ + data paramlist(574) /gribparam(131,116,0,4,2,'SWAVR')/ + data paramlist(575) /gribparam(131,117,0,4,3,'GRAD')/ + data paramlist(576) /gribparam(131,118,0,4,4,'BRTMP')/ + data paramlist(577) /gribparam(131,119,0,4,5,'LWRAD')/ + data paramlist(578) /gribparam(131,120,0,4,6,'SWRAD')/ + data paramlist(579) /gribparam(131,121,0,0,10,'LHTFL')/ + data paramlist(580) /gribparam(131,122,0,0,11,'SHTFL')/ + data paramlist(581) /gribparam(131,123,0,2,20,'BLYDP')/ + data paramlist(582) /gribparam(131,124,0,2,17,'UFLX')/ + data paramlist(583) /gribparam(131,125,0,2,18,'VFLX')/ + data paramlist(584) /gribparam(131,126,0,2,19,'WMIXE')/ + data paramlist(585) /gribparam(131,127,255,255,255,'IMGD')/ + data paramlist(586) /gribparam(131,128,0,3,1,'MSLSA')/ + data paramlist(587) /gribparam(131,130,0,3,192,'MSLET')/ + data paramlist(588) /gribparam(131,131,0,7,192,'LFTX')/ + data paramlist(589) /gribparam(131,132,0,7,193,'4LFTX')/ + data paramlist(590) /gribparam(131,134,0,3,212,'PRESN')/ + data paramlist(591) /gribparam(131,135,0,1,197,'MCONV')/ + data paramlist(592) /gribparam(131,136,0,2,192,'VWSH')/ + data paramlist(593) /gribparam(131,137,0,2,219,'PVMWW')/ + data paramlist(594) /gribparam(131,140,0,1,192,'CRAIN')/ + data paramlist(595) /gribparam(131,141,0,1,193,'CFRZR')/ + data paramlist(596) /gribparam(131,142,0,1,194,'CICEP')/ + data paramlist(597) /gribparam(131,143,0,1,195,'CSNOW')/ + data paramlist(598) /gribparam(131,144,2,0,192,'SOILW')/ + data paramlist(599) /gribparam(131,145,0,1,200,'PEVPR')/ + data paramlist(600) /gribparam(131,146,2,0,210,'VEGT')/ + data paramlist(601) /gribparam(131,147,2,3,200,'BARET')/ + data paramlist(602) /gribparam(131,148,2,3,201,'AVSFT')/ + data paramlist(603) /gribparam(131,149,2,3,202,'RADT')/ + data paramlist(604) /gribparam(131,150,2,0,211,'SSTOR')/ + data paramlist(605) /gribparam(131,151,2,0,212,'LSOIL')/ + data paramlist(606) /gribparam(131,152,2,0,213,'EWATR')/ + data paramlist(607) /gribparam(131,153,0,1,22,'CLWMR')/ + data paramlist(608) /gribparam(131,155,2,0,193,'GFLUX')/ + data paramlist(609) /gribparam(131,156,0,7,7,'CIN')/ + data paramlist(610) /gribparam(131,157,0,7,6,'CAPE')/ + data paramlist(611) /gribparam(131,158,0,19,11,'TKE')/ + data paramlist(612) /gribparam(131,159,0,19,192,'MXSALB')/ + data paramlist(613) /gribparam(131,160,2,3,192,'SOILL')/ + data paramlist(614) /gribparam(131,161,0,1,29,'ASNOW')/ + data paramlist(615) /gribparam(131,162,0,1,221,'ARAIN')/ + data paramlist(616) /gribparam(131,163,2,0,214,'GWREC')/ + data paramlist(617) /gribparam(131,164,2,0,215,'QREC')/ + data paramlist(618) /gribparam(131,165,0,1,222,'SNOWT')/ + data paramlist(619) /gribparam(131,166,0,4,200,'VBDSF')/ + data paramlist(620) /gribparam(131,167,0,4,201,'VDDSF')/ + data paramlist(621) /gribparam(131,168,0,4,202,'NBDSF')/ + data paramlist(622) /gribparam(131,169,0,4,203,'NDDSF')/ + data paramlist(623) /gribparam(131,170,0,19,193,'SNFALB')/ + data paramlist(624) /gribparam(131,171,2,3,193,'RLYRS')/ + data paramlist(625) /gribparam(131,172,0,2,193,'MFLX')/ + data paramlist(626) /gribparam(131,173,0,3,210,'LMH')/ + data paramlist(627) /gribparam(131,174,0,2,218,'LMV')/ + data paramlist(628) /gribparam(131,175,0,191,195,'MLYNO')/ + data paramlist(629) /gribparam(131,176,0,191,192,'NLAT')/ + data paramlist(630) /gribparam(131,177,0,191,193,'ELON')/ + data paramlist(631) /gribparam(131,178,0,1,23,'ICMR')/ + data paramlist(632) /gribparam(131,179,2,0,228,'ACOND')/ + data paramlist(633) /gribparam(131,180,0,1,17,'SNOAG')/ + data paramlist(634) /gribparam(131,181,2,0,199,'CCOND')/ + data paramlist(635) /gribparam(131,182,0,7,198,'LAI')/ + data paramlist(636) /gribparam(131,183,2,0,216,'SFCRH')/ + data paramlist(637) /gribparam(131,184,0,19,19,'SALBD')/ + data paramlist(638) /gribparam(131,187,2,0,217,'NDVI')/ + data paramlist(639) /gribparam(131,188,2,0,206,'RDRIP')/ + data paramlist(640) /gribparam(131,189,2,0,218,'LANDN')/ + data paramlist(641) /gribparam(131,190,0,7,8,'HLCY')/ + data paramlist(642) /gribparam(131,191,0,191,196,'NLATN')/ + data paramlist(643) /gribparam(131,192,0,191,197,'ELONN')/ + data paramlist(644) /gribparam(131,194,1,1,193,'CPOFP')/ + data paramlist(645) /gribparam(131,196,0,2,194,'USTM')/ + data paramlist(646) /gribparam(131,197,0,2,195,'VSTM')/ + data paramlist(647) /gribparam(131,198,0,1,212,'SBSNO')/ + data paramlist(648) /gribparam(131,199,2,3,198,'EVBS')/ + data paramlist(649) /gribparam(131,200,2,0,229,'EVCW')/ + data paramlist(650) /gribparam(131,202,0,1,223,'APCPN')/ + data paramlist(651) /gribparam(131,203,2,0,200,'RSMIN')/ + data paramlist(652) /gribparam(131,204,0,4,192,'DSWRF')/ + data paramlist(653) /gribparam(131,205,0,5,192,'DLWRF')/ + data paramlist(654) /gribparam(131,206,0,1,224,'ACPCPN')/ + data paramlist(655) /gribparam(131,207,2,0,194,'MSTAV')/ + data paramlist(656) /gribparam(131,208,2,0,195,'SFEXC')/ + data paramlist(657) /gribparam(131,210,2,0,230,'TRANS')/ + data paramlist(658) /gribparam(131,211,0,4,193,'USWRF')/ + data paramlist(659) /gribparam(131,212,0,5,193,'ULWRF')/ + data paramlist(660) /gribparam(131,213,0,6,192,'CDLYR')/ + data paramlist(661) /gribparam(131,214,0,1,196,'CPRAT')/ + data paramlist(662) /gribparam(131,216,0,0,193,'TTRAD')/ + data paramlist(663) /gribparam(131,218,0,3,211,'HGTN')/ + data paramlist(664) /gribparam(131,219,2,0,201,'WILT')/ + data paramlist(665) /gribparam(130,220,2,3,203,'FLDCP')/ + data paramlist(666) /gribparam(131,221,0,3,196,'HPBL')/ + data paramlist(667) /gribparam(131,222,2,3,194,'SLTYP')/ + data paramlist(668) /gribparam(131,223,2,0,196,'CNWAT')/ + data paramlist(669) /gribparam(131,224,2,3,0,'SOTYP')/ + data paramlist(670) /gribparam(131,225,2,0,198,'VGTYP')/ + data paramlist(671) /gribparam(131,226,2,0,197,'BMIXL')/ + data paramlist(672) /gribparam(131,227,2,0,219,'AMIXL')/ + data paramlist(673) /gribparam(131,228,0,1,199,'PEVAP')/ + data paramlist(674) /gribparam(131,229,0,0,192,'SNOHF')/ + data paramlist(675) /gribparam(131,230,2,3,195,'SMREF')/ + data paramlist(676) /gribparam(131,231,2,3,196,'SMDRY')/ + data paramlist(677) /gribparam(131,232,2,0,220,'WVINC')/ + data paramlist(678) /gribparam(131,233,2,0,221,'WCINC')/ + data paramlist(679) /gribparam(131,234,1,0,192,'BGRUN')/ + data paramlist(680) /gribparam(131,235,1,0,193,'SSRUN')/ + data paramlist(681) /gribparam(131,237,2,0,222,'WVCONV')/ + data paramlist(682) /gribparam(131,238,0,1,201,'SNOWC')/ + data paramlist(683) /gribparam(131,239,0,1,208,'SNOT')/ + data paramlist(684) /gribparam(131,240,2,3,197,'POROS')/ + data paramlist(685) /gribparam(131,241,2,0,223,'WCCONV')/ + data paramlist(686) /gribparam(131,242,2,0,224,'WVUFLX')/ + data paramlist(687) /gribparam(131,243,2,0,225,'WVVFLX')/ + data paramlist(688) /gribparam(131,244,2,0,226,'WCUFLX')/ + data paramlist(689) /gribparam(131,245,2,0,227,'WCVFLX')/ + data paramlist(690) /gribparam(131,246,2,0,202,'RCS')/ + data paramlist(691) /gribparam(131,247,2,0,203,'RCT')/ + data paramlist(692) /gribparam(131,248,2,0,204,'RCQ')/ + data paramlist(693) /gribparam(131,249,2,0,205,'RCSOL')/ + data paramlist(694) /gribparam(131,250,0,4,197,'SWHR')/ + data paramlist(695) /gribparam(131,251,0,5,194,'LWHR')/ + data paramlist(696) /gribparam(131,252,0,2,196,'CD')/ + data paramlist(697) /gribparam(131,253,0,2,197,'FRICV')/ + data paramlist(698) /gribparam(131,254,0,7,194,'RI')/ + data paramlist(699) /gribparam(129,62,0,1,9,'NCPCP')/ + data paramlist(700) /gribparam(129,63,0,1,10,'ACPCP')/ + data paramlist(701) /gribparam(131,220,2,3,203,'FLDCP')/ + data paramlist(702) /gribparam(129,231,0,14,200,'OZMAX1')/ + data paramlist(703) /gribparam(129,232,0,14,201,'OZMAX8')/ + data paramlist(704) /gribparam(129,240,0,16,197,'RETOP')/ + data paramlist(705) /gribparam(133,191,0,6,201,'SUNSD')/ + data paramlist(706) /gribparam(129,233,0,14,202,'PDMAX1')/ + data paramlist(707) /gribparam(129,234,0,14,203,'PDMAX24')/ + data paramlist(708) /gribparam(129,242,10,3,242,'TCSRG20')/ + data paramlist(709) /gribparam(129,243,10,3,243,'TCSRG30')/ + data paramlist(710) /gribparam(129,244,10,3,244,'TCSRG40')/ + data paramlist(711) /gribparam(129,245,10,3,245,'TCSRG50')/ + data paramlist(712) /gribparam(129,246,10,3,246,'TCSRG60')/ + data paramlist(713) /gribparam(129,247,10,3,247,'TCSRG70')/ + data paramlist(714) /gribparam(129,248,10,3,248,'TCSRG80')/ + data paramlist(715) /gribparam(129,249,10,3,249,'TCSRG90')/ + data paramlist(716) /gribparam(3,1,0,3,0,'PRES')/ + data paramlist(717) /gribparam(3,52,0,1,1,'RH')/ + data paramlist(718) /gribparam(3,63,0,1,10,'ACPCP')/ + data paramlist(719) /gribparam(3,61,0,1,8,'APCP')/ + data paramlist(720) /gribparam(3,41,0,2,10,'ABSV')/ + data paramlist(721) /gribparam(3,100,10,0,3,'HTSGW')/ + data paramlist(722) /gribparam(3,101,10,0,4,'WVDIR')/ + data paramlist(723) /gribparam(3,103,10,0,6,'WVPER')/ + data paramlist(724) /gribparam(3,104,10,0,7,'SWDIR')/ + data paramlist(725) /gribparam(3,105,10,0,8,'SWELL')/ + data paramlist(726) /gribparam(3,107,10,0,10,'DIRPW')/ + data paramlist(727) /gribparam(3,108,10,0,11,'PERPW')/ + data paramlist(728) /gribparam(3,109,10,0,12,'DIRSW')/ + data paramlist(729) /gribparam(3,110,10,0,13,'PERSW')/ + data paramlist(730) /gribparam(133,192,10,191,1,'MOSF')/ + data paramlist(731) /gribparam(130,193,0,1,225,'FRZR')/ + data paramlist(732) /gribparam(130,194,0,1,227,'FROZR')/ + data paramlist(733) /gribparam(130,195,0,1,241,'TSNOW')/ + data paramlist(734) /gribparam(130,196,2,0,7,'MTERH')/ +! Added 12/06/2010 + data paramlist(735) /gribparam(128,195,10,4,4,'OVHD')/ + data paramlist(736) /gribparam(128,196,10,4,5,'OVSD')/ + data paramlist(737) /gribparam(128,197,10,4,6,'OVMD')/ + data paramlist(738) /gribparam(130,64,0,1,12,'SRWEQ')/ + data paramlist(739) /gribparam(130,241,3,192,6,'SBT112')/ + data paramlist(740) /gribparam(130,242,3,192,7,'SBT113')/ + data paramlist(741) /gribparam(130,243,3,192,8,'SBT114')/ + data paramlist(742) /gribparam(130,244,3,192,9,'SBT115')/ + data paramlist(743) /gribparam(129,235,0,16,198,'MAXREF')/ + data paramlist(744) /gribparam(129,236,0,7,199,'MXUPHL')/ + data paramlist(745) /gribparam(129,237,0,2,220,'MAXUVV')/ + data paramlist(746) /gribparam(129,238,0,2,221,'MAXDVV')/ + data paramlist(747) /gribparam(129,253,0,2,222,'MAXUW')/ + data paramlist(748) /gribparam(129,254,0,2,223,'MAXVW')/ + data paramlist(749) /gribparam(129,241,0,2,224,'VRATE')/ + data paramlist(750) /gribparam(129,250,2,4,2,'HINDEX')/ + data paramlist(751) /gribparam(129,175,0,19,234,'ICSEV')/ + data paramlist(752) /gribparam(129,176,0,19,233,'ICPRB')/ + data paramlist(753) /gribparam(2,236,0,19,217,'SIPD')/ + data paramlist(754) /gribparam(129,230,0,1,242,'RHPW')/ + data paramlist(755) /gribparam(130,206,0,15,3,'VIL')/ + data paramlist(756) /gribparam(255,255,0,20,101,'ATMTK')/ + data paramlist(757) /gribparam(255,255,0,20,102,'AOTK')/ + data paramlist(758) /gribparam(255,255,0,20,103,'SSALBK')/ + data paramlist(759) /gribparam(255,255,0,20,104,'ASYSFK')/ + data paramlist(760) /gribparam(255,255,0,20,105,'AECOEF')/ + data paramlist(761) /gribparam(255,255,0,20,106,'AACOEF')/ + data paramlist(762) /gribparam(255,255,0,20,107,'ALBSAT')/ + data paramlist(763) /gribparam(255,255,0,20,108,'ALBGRD')/ + data paramlist(764) /gribparam(255,255,0,20,109,'ALESAT')/ + data paramlist(765) /gribparam(255,255,0,20,110,'ALEGRD')/ + data paramlist(766) /gribparam(255,255,0,20,9,'WLSMFLX')/ + data paramlist(767) /gribparam(255,255,0,20,10,'WDCPMFLX')/ + data paramlist(768) /gribparam(255,255,0,20,11,'SEDMFLX')/ + data paramlist(769) /gribparam(255,255,0,20,12,'DDMFLX')/ + data paramlist(770) /gribparam(255,255,0,20,13,'TRANHH')/ + data paramlist(771) /gribparam(255,255,0,20,14,'TRSDS')/ + data paramlist(772) /gribparam(255,255,0,20,59,'ANCON')/ +! Added 08/08/2013 + data paramlist(773) /gribparam(131,193,0,0,21,'APTMP')/ + data paramlist(774) /gribparam(131,137,0,17,0,'LTNGSD')/ + data paramlist(775) /gribparam(131,194,0,1,39,'CPOFP')/ +! Added 03/30/2016 + data paramlist(776) /gribparam(128,144,10,3,203,'CH')/ +! Added 04/28/16 for HRRR fields. NCEP hasn't updated this routine in 3 years + data paramlist(777) /gribparam(131,207,2,0,11,'MSTAV')/ + data paramlist(778) /gribparam(129,240,0,16,3,'RETOP')/ + data paramlist(779) /gribparam(131,221,0,3,18,'HPBL')/ + data paramlist(780) /gribparam(2,131,0,7,10,'LFTX')/ + data paramlist(781) /gribparam(2,132,0,7,11,'4LFTX')/ + data paramlist(782) /gribparam(2,212,0,5,4,'ULWRF')/ + data paramlist(783) /gribparam(2,196,0,2,27,'USTM')/ + data paramlist(784) /gribparam(2,197,0,2,28,'VSTM')/ + data paramlist(785) /gribparam(129,255,0,1,74,'TCOLG')/ + data paramlist(786) /gribparam(2,140,0,1,33,'CRAIN')/ + data paramlist(787) /gribparam(2,141,0,1,34,'CFRZR')/ + data paramlist(788) /gribparam(2,142,0,1,35,'CICEP')/ + data paramlist(789) /gribparam(2,143,0,1,36,'CSNOW')/ + data paramlist(790) /gribparam(2,238,0,1,42,'SNOWC')/ + data paramlist(791) /gribparam(2,204,0,4,7,'DSWRF')/ + + contains + + + subroutine param_g1_to_g2(g1val,g1ver,g2disc,g2cat,g2num) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: param_g1_to_g2 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2001-06-05 +! +! ABSTRACT: This subroutine returns the corresponding GRIB2 Discipline +! Category and Number for a given GRIB1 parameter value and table version. +! +! PROGRAM HISTORY LOG: +! 2000-05-11 Gilbert +! +! USAGE: CALL param_g1_to_g2(g1val,g1ver,g2disc,g2cat,g2num) +! INPUT ARGUMENT LIST: +! g1val - GRIB1 parameter number for which discipline is requested +! g1ver - GRIB1 parameter table version number +! +! OUTPUT ARGUMENT LIST: +! g2disc - corresponding GRIB2 Discipline number +! g2cat - corresponding GRIB2 Category number +! g2num - corresponding GRIB2 Parameter number within Category g2cat +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: g1val,g1ver + integer,intent(out) :: g2disc,g2cat,g2num + + g2disc=255 + g2cat=255 + g2num=255 +! for testing +! g2num=g1val +! for testing + + do n=1,MAXPARAM + if (paramlist(n)%grib1val.eq.g1val .AND. + & paramlist(n)%g1tblver.eq.g1ver ) then + g2disc=paramlist(n)%grib2dsc + g2cat=paramlist(n)%grib2cat + g2num=paramlist(n)%grib2num + return + endif + enddo + + print *,'param_g1_to_g2:GRIB1 param ',g1val,' not found.', + & ' for table version ',g1ver + return + end subroutine + + character(len=8) function param_get_abbrev(g2disc,g2cat,g2num) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: param_get_abbrev +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-01-04 +! +! ABSTRACT: This function returns the parameter abbreviation for +! a given GRIB2 Discipline, Category and Parameter number. +! +! PROGRAM HISTORY LOG: +! 2001-06-05 Gilbert +! +! USAGE: abrev=param_get_abbrev(g2disc,g2cat,g2num) +! INPUT ARGUMENT LIST: +! g2disc - GRIB2 discipline number (See Code Table 0.0) +! g2cat - corresponding GRIB2 Category number +! g2num - corresponding GRIB2 Parameter number within Category g2cat +! +! RETURNS: ASCII Paramter Abbreviation +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: g2disc,g2cat,g2num + + param_get_abbrev='UNKNOWN ' + + do n=1,MAXPARAM + if (paramlist(n)%grib2dsc.eq.g2disc.AND. + & paramlist(n)%grib2cat.eq.g2cat.AND. + & paramlist(n)%grib2num.eq.g2num) then + param_get_abbrev=paramlist(n)%abbrev + return + endif + enddo + +! print *,'param_get_abbrev:GRIB2 param ',g2disc,g2cat, +! & g2num,' not found.' + return + end function + + + subroutine param_g2_to_g1(g2disc,g2cat,g2num,g1val,g1ver) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: param_g2_to_g1 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-01-04 +! +! ABSTRACT: This function returns the GRIB 1 parameter number for +! a given GRIB2 Discipline, Category and Parameter number. +! +! PROGRAM HISTORY LOG: +! 2001-06-05 Gilbert +! +! USAGE: call param_g2_to_g1(g2disc,g2cat,g2num,g1val,g1ver) +! INPUT ARGUMENT LIST: +! g2disc - GRIB2 discipline number (See Code Table 0.0) +! g2cat - corresponding GRIB2 Category number +! g2num - corresponding GRIB2 Parameter number within Category g2cat +! +! OUTPUT ARGUMENT LIST: +! g1val - GRIB1 parameter number for which discipline is requested +! g1ver - GRIB1 parameter table version number +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: g2disc,g2cat,g2num + integer,intent(out) :: g1val,g1ver + + g1val=255 + g1ver=255 + +! for testing +! if ( g2disc.eq.255.and.g2cat.eq.255 ) then +! g1val=g2num +! g1ver=2 +! return +! endif +! for testing + + do n=1,MAXPARAM + if (paramlist(n)%grib2dsc.eq.g2disc.AND. + & paramlist(n)%grib2cat.eq.g2cat.AND. + & paramlist(n)%grib2num.eq.g2num) then + g1val=paramlist(n)%grib1val + g1ver=paramlist(n)%g1tblver + return + endif + enddo + + print *,'param_g2_to_g1:GRIB2 param ',g2disc,g2cat, + & g2num,' not found.' + return + end subroutine + + end module diff --git a/WPS/ungrib/src/ngl/g2/params_ecmwf.f b/WPS/ungrib/src/ngl/g2/params_ecmwf.f new file mode 100755 index 00000000..116b5650 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/params_ecmwf.f @@ -0,0 +1,341 @@ + module params_ecmwf +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! MODULE: params_ecmwf +! PRGMMR: Gordon ORG: W/NP11 DATE: 2006-09-07 +! +! ABSTRACT: This Fortran Module contains info on all the available +! ECMWF GRIB Parameters. +! +! PROGRAM HISTORY LOG: +! 2006-09-07 Gordon - Modified from Steve Gilbert's params.f for NCEP GRIB data +! 2007-04-20 Vuong - Add more parameters +! 2007-10-11 Vuong - Add more parameters +! 2011-11-16 Vuong - Add parameters MAX and MIN temperature +! 2013-07-24 Vuong - Removed space in abbreviation +! +! USAGE: use params +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + integer,parameter :: MAXPARAM=179 + + type gribparam + integer :: g1tblver + integer :: grib1val + integer :: grib2dsc + integer :: grib2cat + integer :: grib2num + character(len=8) :: abbrev + end type gribparam + + type(gribparam),dimension(MAXPARAM) :: paramlist + + data paramlist(1) /gribparam(128,1,255,255,255,'STRF')/ + data paramlist(2) /gribparam(128,002,255,255,255,'VPOT')/ + data paramlist(3) /gribparam(128,003,255,255,255,'THTA')/ + data paramlist(4) /gribparam(128,004,255,255,255,'THTE')/ + data paramlist(5) /gribparam(128,005,255,255,255,'THTS')/ + data paramlist(6) /gribparam(128,011,255,255,255,'UDVW')/ + data paramlist(7) /gribparam(128,012,255,255,255,'VDVW')/ + data paramlist(8) /gribparam(128,013,255,255,255,'URTW')/ + data paramlist(9) /gribparam(128,014,255,255,255,'VRTW')/ + data paramlist(10) /gribparam(128,021,255,255,255,'UCTP')/ + data paramlist(11) /gribparam(128,022,255,255,255,'UCLN')/ + data paramlist(12) /gribparam(128,023,255,255,255,'UCDV')/ + data paramlist(13) /gribparam(128,026,255,255,255,'CLAK')/ + data paramlist(14) /gribparam(128,027,255,255,255,'CVEGL')/ + data paramlist(15) /gribparam(128,028,255,255,255,'CVEGH')/ + data paramlist(16) /gribparam(128,029,255,255,255,'TVEGL')/ + data paramlist(17) /gribparam(128,030,255,255,255,'TVEGH')/ + data paramlist(18) /gribparam(128,031,255,255,255,'CSICE')/ + data paramlist(19) /gribparam(128,032,255,255,255,'ASNOW')/ + data paramlist(20) /gribparam(128,033,255,255,255,'RSNOW')/ + data paramlist(21) /gribparam(128,034,255,255,255,'SSTK')/ + data paramlist(22) /gribparam(128,035,255,255,255,'ISTL1')/ + data paramlist(23) /gribparam(128,036,255,255,255,'ISTL2')/ + data paramlist(24) /gribparam(128,037,255,255,255,'ISTL3')/ + data paramlist(25) /gribparam(128,038,255,255,255,'ISTL4')/ + data paramlist(26) /gribparam(128,039,255,255,255,'SWVL1')/ + data paramlist(27) /gribparam(128,040,255,255,255,'SWVL2')/ + data paramlist(28) /gribparam(128,041,255,255,255,'SWVL3')/ + data paramlist(29) /gribparam(128,042,255,255,255,'SWVL4')/ + data paramlist(30) /gribparam(128,043,255,255,255,'SOILT')/ + data paramlist(31) /gribparam(128,044,255,255,255,'ESNOW')/ + data paramlist(32) /gribparam(128,045,255,255,255,'SMLT')/ + data paramlist(33) /gribparam(128,046,255,255,255,'SDUR')/ + data paramlist(34) /gribparam(128,047,255,255,255,'DSRP')/ + data paramlist(35) /gribparam(128,048,255,255,255,'MAGSS')/ + data paramlist(36) /gribparam(128,049,255,255,255,'GUST')/ + data paramlist(37) /gribparam(128,050,255,255,255,'LSPF')/ + data paramlist(38) /gribparam(128,051,255,255,255,'TMXK24')/ + data paramlist(39) /gribparam(128,052,255,255,255,'TMNK24')/ + data paramlist(40) /gribparam(128,053,255,255,255,'MONT')/ + data paramlist(41) /gribparam(128,054,255,255,255,'PRES')/ + data paramlist(42) /gribparam(128,060,255,255,255,'PVOR')/ + data paramlist(43) /gribparam(128,127,255,255,255,'ATIDE')/ + data paramlist(44) /gribparam(128,128,255,255,255,'BVAL')/ + data paramlist(45) /gribparam(128,129,255,255,255,'HGHT')/ + data paramlist(46) /gribparam(128,130,0,0,0,'TMPK')/ + data paramlist(47) /gribparam(128,131,0,2,2,'UWND')/ + data paramlist(48) /gribparam(128,132,0,2,3,'VWND')/ + data paramlist(49) /gribparam(128,133,255,255,255,'SPCH')/ + data paramlist(50) /gribparam(128,134,255,255,255,'PRES')/ + data paramlist(51) /gribparam(128,135,255,255,255,'OMEG')/ + data paramlist(52) /gribparam(128,136,255,255,255,'TCWTR')/ + data paramlist(53) /gribparam(128,137,255,255,255,'TCWV')/ + data paramlist(54) /gribparam(128,138,255,255,255,'VORT')/ + data paramlist(55) /gribparam(128,139,255,255,255,'STL1')/ + data paramlist(56) /gribparam(128,140,255,255,255,'SWL1')/ + data paramlist(57) /gribparam(128,141,255,255,255,'SNOWD')/ + data paramlist(58) /gribparam(128,142,255,255,255,'S--M')/ + data paramlist(59) /gribparam(128,143,255,255,255,'C--M')/ + data paramlist(60) /gribparam(128,144,255,255,255,'SNOW')/ + data paramlist(61) /gribparam(128,145,255,255,255,'BLDS')/ + data paramlist(62) /gribparam(128,146,255,255,255,'SSHF')/ + data paramlist(63) /gribparam(128,147,255,255,255,'SLHF')/ + data paramlist(64) /gribparam(128,148,255,255,255,'CHNK')/ + data paramlist(65) /gribparam(128,149,255,255,255,'SNRAD')/ + data paramlist(66) /gribparam(128,150,255,255,255,'TNRAD')/ + data paramlist(67) /gribparam(128,151,0,3,1,'PMSL')/ + data paramlist(68) /gribparam(128,152,255,255,255,'LNSP')/ + data paramlist(69) /gribparam(128,153,255,255,255,'SWHR')/ + data paramlist(70) /gribparam(128,154,255,255,255,'LWHR')/ + data paramlist(71) /gribparam(128,155,255,255,255,'DIVG')/ + data paramlist(72) /gribparam(128,156,0,3,5,'HGHT')/ + data paramlist(73) /gribparam(128,157,0,1,1,'RELH')/ + data paramlist(74) /gribparam(128,158,255,255,255,'TSPRES')/ + data paramlist(75) /gribparam(128,159,255,255,255,'BLHGHT')/ + data paramlist(76) /gribparam(128,160,255,255,255,'SDOR')/ + data paramlist(77) /gribparam(128,161,255,255,255,'ISOR')/ + data paramlist(78) /gribparam(128,162,255,255,255,'ANOR')/ + data paramlist(79) /gribparam(128,163,255,255,255,'SLOR')/ + data paramlist(80) /gribparam(128,164,0,6,1,'TCLD')/ + data paramlist(81) /gribparam(128,165,0,2,2,'UWND')/ + data paramlist(82) /gribparam(128,166,0,2,3,'VWND')/ + data paramlist(83) /gribparam(128,167,0,0,0,'TMPK')/ + data paramlist(84) /gribparam(128,168,0,0,6,'DWPK')/ + data paramlist(85) /gribparam(128,169,255,255,255,'SSRD')/ + data paramlist(86) /gribparam(128,170,255,255,255,'STL2')/ + data paramlist(87) /gribparam(128,171,255,255,255,'SWL2')/ + data paramlist(88) /gribparam(128,172,255,255,255,'LAND')/ + data paramlist(89) /gribparam(128,173,255,255,255,'SROUGH')/ + data paramlist(90) /gribparam(128,174,255,255,255,'ALBD')/ + data paramlist(91) /gribparam(128,175,255,255,255,'STRD')/ + data paramlist(92) /gribparam(128,176,255,255,255,'SSRAD')/ + data paramlist(93) /gribparam(128,177,255,255,255,'STRAD')/ + data paramlist(94) /gribparam(128,178,255,255,255,'TSRAD')/ + data paramlist(95) /gribparam(128,179,255,255,255,'TTRAD')/ + data paramlist(96) /gribparam(128,180,255,255,255,'EWSS')/ + data paramlist(97) /gribparam(128,181,255,255,255,'NSSS')/ + data paramlist(98) /gribparam(128,182,255,255,255,'EVAP')/ + data paramlist(99) /gribparam(128,183,255,255,255,'STL3')/ + data paramlist(100) /gribparam(128,184,255,255,255,'SWL3')/ + data paramlist(101) /gribparam(128,185,255,255,255,'CCLD')/ + data paramlist(102) /gribparam(128,186,255,255,255,'LCLD')/ + data paramlist(103) /gribparam(128,187,255,255,255,'MCLD')/ + data paramlist(104) /gribparam(128,188,255,255,255,'HCLD')/ + data paramlist(105) /gribparam(128,189,255,255,255,'SUND')/ + data paramlist(106) /gribparam(128,190,255,255,255,'EWOV')/ + data paramlist(107) /gribparam(128,191,255,255,255,'NSOV')/ + data paramlist(108) /gribparam(128,192,255,255,255,'NWOV')/ + data paramlist(109) /gribparam(128,193,255,255,255,'NEOV')/ + data paramlist(110) /gribparam(128,194,255,255,255,'BTMP')/ + data paramlist(111) /gribparam(128,195,255,255,255,'LGWS')/ + data paramlist(112) /gribparam(128,196,255,255,255,'MGWS')/ + data paramlist(113) /gribparam(128,197,255,255,255,'GWDS')/ + data paramlist(114) /gribparam(128,198,255,255,255,'SKRC')/ + data paramlist(115) /gribparam(128,199,255,255,255,'VEGE')/ + data paramlist(116) /gribparam(128,200,255,255,255,'VSGO')/ + data paramlist(117) /gribparam(128,201,0,0,4,'TMXK')/ + data paramlist(118) /gribparam(128,202,0,0,5,'TMNK')/ + data paramlist(119) /gribparam(128,203,255,255,255,'OZMR')/ + data paramlist(120) /gribparam(128,204,255,255,255,'PRAW')/ + data paramlist(121) /gribparam(128,205,255,255,255,'RUNOFF')/ + data paramlist(122) /gribparam(128,206,255,255,255,'TCOZ')/ + data paramlist(123) /gribparam(128,207,255,255,255,'SPED')/ + data paramlist(124) /gribparam(128,208,255,255,255,'TSRC')/ + data paramlist(125) /gribparam(128,209,255,255,255,'TTRC')/ + data paramlist(126) /gribparam(128,210,255,255,255,'SSRC')/ + data paramlist(127) /gribparam(128,211,255,255,255,'STRC')/ + data paramlist(128) /gribparam(128,212,255,255,255,'SINSOL')/ + data paramlist(129) /gribparam(128,214,255,255,255,'DHRAD')/ + data paramlist(130) /gribparam(128,215,255,255,255,'DHVD')/ + data paramlist(131) /gribparam(128,216,255,255,255,'DHCC')/ + data paramlist(132) /gribparam(128,217,255,255,255,'DHLC')/ + data paramlist(133) /gribparam(128,218,255,255,255,'VDZW')/ + data paramlist(134) /gribparam(128,219,255,255,255,'VDMW')/ + data paramlist(135) /gribparam(128,220,255,255,255,'EWGD')/ + data paramlist(136) /gribparam(128,221,255,255,255,'NSGD')/ + data paramlist(137) /gribparam(128,222,255,255,255,'CTZW')/ + data paramlist(138) /gribparam(128,223,255,255,255,'CTMW')/ + data paramlist(139) /gribparam(128,224,255,255,255,'VDHUM')/ + data paramlist(140) /gribparam(128,225,255,255,255,'HTCC')/ + data paramlist(141) /gribparam(128,226,255,255,255,'HTLC')/ + data paramlist(142) /gribparam(128,227,255,255,255,'CRNH')/ + data paramlist(143) /gribparam(128,228,0,1,8,'APCP')/ + data paramlist(144) /gribparam(128,229,255,255,255,'IEWS')/ + data paramlist(145) /gribparam(128,230,255,255,255,'INSS')/ + data paramlist(146) /gribparam(128,231,255,255,255,'ISHF')/ + data paramlist(147) /gribparam(128,232,255,255,255,'MFLUX')/ + data paramlist(148) /gribparam(128,233,255,255,255,'ASHUM')/ + data paramlist(149) /gribparam(128,234,255,255,255,'LSRH')/ + data paramlist(150) /gribparam(128,235,255,255,255,'SKTMP')/ + data paramlist(151) /gribparam(128,236,255,255,255,'STL4')/ + data paramlist(152) /gribparam(128,237,255,255,255,'SWL4')/ + data paramlist(153) /gribparam(128,238,255,255,255,'TSNOW')/ + data paramlist(154) /gribparam(128,239,255,255,255,'CSNOWF')/ + data paramlist(155) /gribparam(128,240,255,255,255,'LSNOWF')/ + data paramlist(156) /gribparam(128,241,255,255,255,'ACLD')/ + data paramlist(157) /gribparam(128,242,255,255,255,'ALWTND')/ + data paramlist(158) /gribparam(128,243,255,255,255,'FALBD')/ + data paramlist(159) /gribparam(128,244,255,255,255,'FSROUGH')/ + data paramlist(160) /gribparam(128,245,255,255,255,'FLSR')/ + data paramlist(161) /gribparam(128,246,255,255,255,'CLWC')/ + data paramlist(162) /gribparam(128,247,255,255,255,'CIWC')/ + data paramlist(163) /gribparam(128,248,255,255,255,'CLOUD')/ + data paramlist(164) /gribparam(128,249,255,255,255,'AIWTND')/ + data paramlist(165) /gribparam(128,250,255,255,255,'ICEAGE')/ + data paramlist(166) /gribparam(128,251,255,255,255,'ATTE')/ + data paramlist(167) /gribparam(128,252,255,255,255,'ATHE')/ + data paramlist(168) /gribparam(128,253,255,255,255,'ATZE')/ + data paramlist(169) /gribparam(128,254,255,255,255,'ATMW')/ + data paramlist(170) /gribparam(128,255,255,255,255,'MISS')/ +! Added 4/20/2007 - For missing GRIB1 to GRIB2 conversions + data paramlist(171) /gribparam(1,33,0,2,2,'UGRD')/ + data paramlist(172) /gribparam(1,34,0,2,3,'VGRD')/ + data paramlist(173) /gribparam(1,2,0,3,1,'PRMSL')/ + data paramlist(174) /gribparam(1,7,0,3,5,'HGT')/ +! Added 10/11/2007- Add more parameters + data paramlist(175) /gribparam(1,11,0,0,0,'TMP')/ + data paramlist(176) /gribparam(1,52,0,1,1,'RH')/ + data paramlist(177) /gribparam(1,41,0,2,10,'ABSV')/ +! Added 11/16/2011- Add more parameters + data paramlist(178) /gribparam(128,121,0,0,4,'TMXK')/ + data paramlist(179) /gribparam(128,122,0,0,5,'TMNK')/ + + contains + + + subroutine param_ecmwf_g1_to_g2(g1val,g1ver,g2disc,g2cat,g2num) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: param_ecmwf_g1_to_g2 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2001-06-05 +! +! ABSTRACT: This subroutine returns the corresponding GRIB2 Discipline +! Category and Number for a given GRIB1 parameter value and table version. +! +! PROGRAM HISTORY LOG: +! 2000-05-11 Gilbert +! +! USAGE: CALL param_ecmwf_g1_to_g2(g1val,g1ver,g2disc,g2cat,g2num) +! INPUT ARGUMENT LIST: +! g1val - GRIB1 parameter number for which discipline is requested +! g1ver - GRIB1 parameter table version number +! +! OUTPUT ARGUMENT LIST: +! g2disc - corresponding GRIB2 Discipline number +! g2cat - corresponding GRIB2 Category number +! g2num - corresponding GRIB2 Parameter number within Category g2cat +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: g1val,g1ver + integer,intent(out) :: g2disc,g2cat,g2num + + g2disc=255 + g2cat=255 + g2num=255 +! for testing +! g2num=g1val +! for testing + + do n=1,MAXPARAM + if ( paramlist(n)%grib1val.eq.g1val .AND. + & paramlist(n)%g1tblver.eq.g1ver ) then + g2disc=paramlist(n)%grib2dsc + g2cat=paramlist(n)%grib2cat + g2num=paramlist(n)%grib2num +c print *,g2disc +c print *,g2cat +c print *,g2num + return + endif + enddo + + print *,'param_ecmwf_g1_to_g2:GRIB1 param ',g1val, + & ' not found.', + & ' for table version ',g1ver + return + end subroutine + + + subroutine param_ecmwf_g2_to_g1(g2disc,g2cat,g2num,g1val,g1ver) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: param_ecmwf_g2_to_g1 +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-01-04 +! +! ABSTRACT: This function returns the GRIB 1 parameter number for +! a given GRIB2 Discipline, Category and Parameter number. +! +! PROGRAM HISTORY LOG: +! 2001-06-05 Gilbert +! +! USAGE: call param_ecmwf_g2_to_g1(g2disc,g2cat,g2num,g1val,g1ver) +! INPUT ARGUMENT LIST: +! g2disc - GRIB2 discipline number (See Code Table 0.0) +! g2cat - corresponding GRIB2 Category number +! g2num - corresponding GRIB2 Parameter number within Category g2cat +! +! OUTPUT ARGUMENT LIST: +! g1val - GRIB1 parameter number for which discipline is requested +! g1ver - GRIB1 parameter table version number +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: g2disc,g2cat,g2num + integer,intent(out) :: g1val,g1ver + + g1val=255 + g1ver=255 + +! for testing +! if ( g2disc.eq.255.and.g2cat.eq.255 ) then +! g1val=g2num +! g1ver=2 +! return +! endif +! for testing + + do n=1,MAXPARAM + if (paramlist(n)%grib2dsc.eq.g2disc.AND. + & paramlist(n)%grib2cat.eq.g2cat.AND. + & paramlist(n)%grib2num.eq.g2num) then + g1val=paramlist(n)%grib1val + g1ver=paramlist(n)%g1tblver + return + endif + enddo + + print *,'param_ecmwf_g2_to_g1:GRIB2 param ',g2disc,g2cat, + & g2num,' not found.' + return + end subroutine + + + end module + diff --git a/WPS/ungrib/src/ngl/g2/pdstemplates.f b/WPS/ungrib/src/ngl/g2/pdstemplates.f new file mode 100755 index 00000000..5d68d1d5 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/pdstemplates.f @@ -0,0 +1,757 @@ + module pdstemplates +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! MODULE: pdstemplates +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-11 +! +! ABSTRACT: This Fortran Module contains info on all the available +! GRIB2 Product Definition Templates used in Section 4 (PDS). +! Each Template has three parts: The number of entries in the template +! (mapgridlen); A map of the template (mapgrid), which contains the +! number of octets in which to pack each of the template values; and +! a logical value (needext) that indicates whether the Template needs +! to be extended. In some cases the number of entries in a template +! can vary depending upon values specified in the "static" part of +! the template. ( See Template 4.3 as an example ) +! +! This module also contains two subroutines. Subroutine getpdstemplate +! returns the octet map for a specified Template number, and +! subroutine extpdstemplate will calculate the extended octet map +! of an appropriate template given values for the "static" part of the +! template. See docblocks below for the arguments and usage of these +! routines. +! +! NOTE: Array mapgrid contains the number of octets in which the +! corresponding template values will be stored. A negative value in +! mapgrid is used to indicate that the corresponding template entry can +! contain negative values. This information is used later when packing +! (or unpacking) the template data values. Negative data values in GRIB +! are stored with the left most bit set to one, and a negative number +! of octets value in mapgrid() indicates that this possibility should +! be considered. The number of octets used to store the data value +! in this case would be the absolute value of the negative value in +! mapgrid(). +! +! +! PROGRAM HISTORY LOG: +! 2000-05-11 Gilbert +! 2001-12-04 Gilbert - Added Templates 4.12, 4.12, 4.14, +! 4.1000, 4.1001, 4.1002, 4.1100 and 4.1101 +! 2009-05-21 VUONG - Allow negative scale factors and limits for +! Templates 4.5 and 4.9 +! 2009-12-14 VUONG - Added Templates (Satellite Product) 4.31 +! Added Templates (ICAO WAFS) 4.15 +! 2010-08-03 VUONG - Added Templates 4.40,4.41,4.42,.4.43 +! 2010-12-08 Vuong - Corrected Product Definition Template 4.42 and 4.43 +! 2012-02-07 Vuong - Added Templates 4.44,4.45,4.46,4.47,4.48,4.50, +! 4.51,4.91,4.32 and 4.52 +! 2013-07-29 Vuong - Corrected 4.91 and added Templates 4.33,4.34,4.53,4.54 +! +! USAGE: use pdstemplates +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + integer,parameter :: MAXLEN=200,MAXTEMP=43 + + type pdstemplate + integer :: template_num + integer :: mappdslen + integer,dimension(MAXLEN) :: mappds + logical :: needext + end type pdstemplate + + type(pdstemplate),dimension(MAXTEMP) :: templates + + data templates(1)%template_num /0/ ! Fcst at Level/Layer + data templates(1)%mappdslen /15/ + data templates(1)%needext /.false./ + data (templates(1)%mappds(j),j=1,15) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/ + + data templates(2)%template_num /1/ ! Ens fcst at level/layer + data templates(2)%mappdslen /18/ + data templates(2)%needext /.false./ + data (templates(2)%mappds(j),j=1,18) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/ + + data templates(3)%template_num /2/ ! Derived Ens fcst at level/layer + data templates(3)%mappdslen /17/ + data templates(3)%needext /.false./ + data (templates(3)%mappds(j),j=1,17) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1/ + + data templates(4)%template_num /3/ ! Ens cluster fcst rect. area + data templates(4)%mappdslen /31/ + data templates(4)%needext /.true./ + data (templates(4)%mappds(j),j=1,31) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,-4,4,4, + & 1,-1,4,-1,4/ + + data templates(5)%template_num /4/ ! Ens cluster fcst circ. area + data templates(5)%mappdslen /30/ + data templates(5)%needext /.true./ + data (templates(5)%mappds(j),j=1,30) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,4,4, + & 1,-1,4,-1,4/ + + data templates(6)%template_num /5/ ! Prob fcst at level/layer + data templates(6)%mappdslen /22/ + data templates(6)%needext /.false./ + data (templates(6)%mappds(j),j=1,22) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,-1,-4,-1,-4/ + + data templates(7)%template_num /6/ ! Percentile fcst at level/layer + data templates(7)%mappdslen /16/ + data templates(7)%needext /.false./ + data (templates(7)%mappds(j),j=1,16) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1/ + + data templates(8)%template_num /7/ ! Error at level/layer + data templates(8)%mappdslen /15/ + data templates(8)%needext /.false./ + data (templates(8)%mappds(j),j=1,15) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/ + + data templates(9)%template_num /8/ ! Ave or Accum at level/layer + data templates(9)%mappdslen /29/ + data templates(9)%needext /.true./ + data (templates(9)%mappds(j),j=1,29) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/ + + data templates(10)%template_num /9/ ! Prob over time interval + data templates(10)%mappdslen /36/ + data templates(10)%needext /.true./ + data (templates(10)%mappds(j),j=1,36) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,-1,-4,-1,-4,2,1,1,1, + & 1,1,1,4,1,1,1,4,1,4/ + + data templates(11)%template_num /10/ ! Percentile over time interval + data templates(11)%mappdslen /30/ + data templates(11)%needext /.true./ + data (templates(11)%mappds(j),j=1,30) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,2,1,1,1,1,1,1,4, + & 1,1,1,4,1,4/ + + data templates(12)%template_num /11/ ! Ens member over time interval + data templates(12)%mappdslen /32/ + data templates(12)%needext /.true./ + data (templates(12)%mappds(j),j=1,32) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,2,1,1,1,1,1,1, + & 4,1,1,1,4,1,4/ + + data templates(13)%template_num /12/ ! Derived Ens fcst over time int + data templates(13)%mappdslen /31/ + data templates(13)%needext /.true./ + data (templates(13)%mappds(j),j=1,31) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1, + & 2,1,1,1,1,1,1,4,1,1,1,4,1,4/ + + data templates(14)%template_num /13/ ! Ens cluster fcst rect. area + data templates(14)%mappdslen /45/ + data templates(14)%needext /.true./ + data (templates(14)%mappds(j),j=1,45) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,-4,4,4, + & 1,-1,4,-1,4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/ + + data templates(15)%template_num /14/ ! Ens cluster fcst circ. area + data templates(15)%mappdslen /44/ + data templates(15)%needext /.true./ + data (templates(15)%mappds(j),j=1,44) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,1,1,1,1,-4,4,4, + & 1,-1,4,-1,4,2,1,1,1,1,1,1,4,1,1,1,4,1,4/ + + data templates(16)%template_num /20/ ! Radar Product + data templates(16)%mappdslen /19/ + data templates(16)%needext /.false./ + data (templates(16)%mappds(j),j=1,19) + & /1,1,1,1,1,-4,4,2,4,2,1,1,1,1,1,2,1,3,2/ + + data templates(17)%template_num /30/ ! Satellite Product + data templates(17)%mappdslen /5/ + data templates(17)%needext /.true./ + data (templates(17)%mappds(j),j=1,5) + & /1,1,1,1,1/ + + data templates(18)%template_num /254/ ! CCITTIA5 Character String + data templates(18)%mappdslen /3/ + data templates(18)%needext /.false./ + data (templates(18)%mappds(j),j=1,3) + & /1,1,4/ + + data templates(19)%template_num /1000/ ! Cross section + data templates(19)%mappdslen /9/ + data templates(19)%needext /.false./ + data (templates(19)%mappds(j),j=1,9) + & /1,1,1,1,1,2,1,1,4/ + + data templates(20)%template_num /1001/ ! Cross section over time + data templates(20)%mappdslen /16/ + data templates(20)%needext /.false./ + data (templates(20)%mappds(j),j=1,16) + & /1,1,1,1,1,2,1,1,4,4,1,1,1,4,1,4/ + + data templates(21)%template_num /1002/ ! Cross section processed time + data templates(21)%mappdslen /15/ + data templates(21)%needext /.false./ + data (templates(21)%mappds(j),j=1,15) + & /1,1,1,1,1,2,1,1,4,1,1,1,4,4,2/ + + data templates(22)%template_num /1100/ ! Hovmoller grid + data templates(22)%mappdslen /15/ + data templates(22)%needext /.false./ + data (templates(22)%mappds(j),j=1,15) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/ + + data templates(23)%template_num /1101/ ! Hovmoller with stat proc + data templates(23)%mappdslen /22/ + data templates(23)%needext /.false./ + data (templates(23)%mappds(j),j=1,22) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,4,1,1,1,4,1,4/ + + data templates(24)%template_num /31/ ! Satellite Product + data templates(24)%mappdslen /5/ + data templates(24)%needext /.true./ + data (templates(24)%mappds(j),j=1,5) + & /1,1,1,1,1/ + + data templates(25)%template_num /15/ ! Ave or Accum at level/layer + data templates(25)%mappdslen /18/ ! For ICAO WAFS products + data templates(25)%needext /.false./ + data (templates(25)%mappds(j),j=1,18) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/ + + data templates(26)%template_num /40/ ! Analysis or Forecast at a horizontal or in a + data templates(26)%mappdslen /16/ ! horizontal layer at a point in time for + data templates(26)%needext /.false./ ! atmospheric chemical constituents + data (templates(26)%mappds(j),j=1,16) + & /1,1,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/ + + data templates(27)%template_num /41/ ! Individual ensemble forecast, control and + data templates(27)%mappdslen /19/ ! perturbed, at horizontal level or + data templates(27)%needext /.false./ ! in a horizontal layer at a point in time for + data (templates(27)%mappds(j),j=1,19) ! atmospheric chemical constituents + & /1,1,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/ + + data templates(28)%template_num /42/ ! Average, Accumulation, and/or extreme values or other + data templates(28)%mappdslen /30/ ! statistically-processed values at horizontal level or + data templates(28)%needext /.true./ ! in a horizontal layer in contnunuous or non-continuous time + data (templates(28)%mappds(j),j=1,30) ! interval for atmospheric chemical constituents + & /1,1,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,2,1,1,1,1,1,1,4, + & 1,1,1,4,1,4/ + + data templates(29)%template_num /43/ ! Individual ensemble forecast, control and + data templates(29)%mappdslen /33/ ! perturbed, at horizontal level or in a horizontal + data templates(29)%needext /.true./ ! layer at a point in a continuous or non-continuous time + data (templates(29)%mappds(j),j=1,33) ! interval for atmospheric chemical constituents + & /1,1,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,2,1,1,1,1,1,1,4, + & 1,1,1,4,1,4/ + + data templates(30)%template_num /44/ ! Analysis or Forecast at a horizontal or in a + data templates(30)%mappdslen /21/ ! horizontal layer at a point in time for + data templates(30)%needext /.false./ ! Aerosol + data (templates(30)%mappds(j),j=1,21) + & /1,1,2,1,-1,-4,-1,-4,1,1,1,2,1,1,2,1,-1,-4,1,-1,-4/ + + data templates(31)%template_num /45/ ! Individual ensemble forecast, control and + data templates(31)%mappdslen /24/ ! perturbed, at horizontal level or in a horizontal + data templates(31)%needext /.false./ ! layer at a point in time for Aerosol + data (templates(31)%mappds(j),j=1,24) + & /1,1,2,1,-1,-4,-1,-4,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/ + + data templates(32)%template_num /46/ ! Ave or Accum or Extreme value at level/layer + data templates(32)%mappdslen /35/ ! in a continuous or non-continuous time interval + data templates(32)%needext /.true./ ! for Aerosol + data (templates(32)%mappds(j),j=1,35) + & /1,1,2,1,-1,-4,-1,-4,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,2,1,1,1,1, + & 1,1,4,1,1,1,4,1,4/ + + data templates(33)%template_num /47/ ! Individual ensemble forecast, control and + data templates(33)%mappdslen /38/ ! perturbed, at horizontal level or in a horizontal + data templates(33)%needext /.true./ ! in a continuous or non-continuous time interval + data (templates(33)%mappds(j),j=1,38) ! for Aerosol + & /1,1,1,2,1,-1,-4,-1,-4,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,2,1, + & 1,1,1,1,1,4,1,1,1,4,1,4/ + + data templates(34)%template_num /51/ ! Categorical forecasts at a horizontal level or + data templates(34)%mappdslen /16/ ! in a horizontal layer at a point in time + data templates(34)%needext /.true./ + data (templates(34)%mappds(j),j=1,16) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1/ +! +! PDT 4.91 +! + data templates(35)%template_num /91/ ! Categorical forecasts at a horizontal level or + data templates(35)%mappdslen /36/ ! in a horizontal layer in a continuous or + data templates(35)%needext /.true./ ! non-continuous time interval + data (templates(35)%mappds(j),j=1,36) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1,-1,-4,-1,-4, + & 2,1,1,1,1,1,1,4,1,1,1,4,1,4/ + + data templates(36)%template_num /32/ ! Analysis or forecast at a horizontal level or + data templates(36)%mappdslen /10/ ! in a horizontal layer at a point in time for + data templates(36)%needext /.true./ ! for simulate (synthetic) Satellite data + data (templates(36)%mappds(j),j=1,10) + & /1,1,1,1,1,2,1,1,4,1/ +! +! PDT 4.48 +! + data templates(37)%template_num /48/ ! Analysis or forecast at a horizontal level or + data templates(37)%mappdslen /26/ ! in a horizontal layer at a point in time for + data templates(37)%needext /.false./ ! Optical Properties of Aerosol + data (templates(37)%mappds(j),j=1,26) + & /1,1,2,1,-1,-4,-1,-4,1,-1,-4,-1,-4,1,1,1,2,1,1,4,1,-1,-4, + & 1,-1,-4/ +! +! PDT 4.50 VALIDATION +! + data templates(38)%template_num /50/ ! Analysis or Forecast of a multi component + data templates(38)%mappdslen /21/ ! parameter or matrix element at a point in time + data templates(38)%needext /.false./ ! + data (templates(38)%mappds(j),j=1,21) + & /1,1,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,4,4,4,4/ +! +! PDT 4.52 VALIDATION +! + data templates(39)%template_num /52/ ! Analysis or forecast of Wave parameters + data templates(39)%mappdslen /15/ ! at the Sea surface at a point in time + data templates(39)%needext /.false./ ! + data (templates(39)%mappds(j),j=1,15) + & /1,1,1,1,1,1,1,1,2,1,1,4,1,-1,-4/ +! +! PDT 4.33 (07/29/2013) +! + data templates(40)%template_num /33/ ! Individual ensemble forecast, control, perturbed, + data templates(40)%mappdslen /18/ ! at a horizontal level or in a horizontal layer + data templates(40)%needext /.true./ ! at a point in time for simulate (synthetic) Satellite data + data (templates(40)%mappds(j),j=1,18) + & /1,1,1,1,1,2,1,1,4,1,2,2,2,-1,-4,1,1,1/ +! +! PDT 4.34 (07/29/2013) +! + data templates(41)%template_num /34/ ! Individual ensemble forecast, control, perturbed, + data templates(41)%mappdslen /32/ ! at a horizontal level or in a horizontal layer, + data templates(41)%needext /.true./ ! in a continuous or non-continuous interval + data (templates(41)%mappds(j),j=1,32) ! for simulate (synthetic) Satellite data + & /1,1,1,1,1,2,1,1,4,1,2,2,2,-1,-4,1,1,1,2,1,1,1, + & 1,1,1,4,1,1,1,4,1,4/ +! +! PDT 4.53 (07/30/2013) +! + data templates(42)%template_num /53/ ! Partitioned parameters at + data templates(42)%mappdslen /19/ ! horizontal level or horizontal layer + data templates(42)%needext /.true./ ! at a point in time + data (templates(42)%mappds(j),j=1,19) + & /1,1,1,1,4,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4/ +! +! PDT 4.54 (07/30/2013) +! + data templates(43)%template_num /54/ ! Individual ensemble forecast, controli and perturbed, + data templates(43)%mappdslen /22/ ! at a horizontal level or in a horizontal layer + data templates(43)%needext /.true./ ! at a point in time for partitioned parameters + data (templates(43)%mappds(j),j=1,22) + & /1,1,1,1,4,2,1,1,1,2,1,1,4,1,-1,-4,1,-1,-4,1,1,1/ + + contains + + integer function getpdsindex(number) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getpdsindex +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2001-06-28 +! +! ABSTRACT: This function returns the index of specified Product +! Definition Template 4.NN (NN=number) in array templates. +! +! PROGRAM HISTORY LOG: +! 2001-06-28 Gilbert +! +! USAGE: index=getpdsindex(number) +! INPUT ARGUMENT LIST: +! number - NN, indicating the number of the Product Definition +! Template 4.NN that is being requested. +! +! RETURNS: Index of PDT 4.NN in array templates, if template exists. +! = -1, otherwise. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: number + + getpdsindex=-1 + + do j=1,MAXTEMP + if (number.eq.templates(j)%template_num) then + getpdsindex=j + return + endif + enddo + + end function + + + subroutine getpdstemplate(number,nummap,map,needext,iret) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getpdstemplate +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-11 +! +! ABSTRACT: This subroutine returns PDS template information for a +! specified Product Definition Template 4.NN. +! The number of entries in the template is returned along with a map +! of the number of octets occupied by each entry. Also, a flag is +! returned to indicate whether the template would need to be extended. +! +! PROGRAM HISTORY LOG: +! 2000-05-11 Gilbert +! 2010-08-03 VUONG - Added Templates 4.40,4.41,4.42,.4.43 +! 2010-12-08 Vuong - Corrected Product Definition Template 4.42 and 4.43 +! 2013-07-29 Vuong - Added Templates 4.48,4.50,4.33,4.34,4.53,4.54 +! +! USAGE: CALL getpdstemplate(number,nummap,map,needext,iret) +! INPUT ARGUMENT LIST: +! number - NN, indicating the number of the Product Definition +! Template 4.NN that is being requested. +! +! OUTPUT ARGUMENT LIST: +! nummap - Number of entries in the Template +! map() - An array containing the number of octets that each +! template entry occupies when packed up into the PDS. +! needext - Logical variable indicating whether the Product Defintion +! Template has to be extended. +! ierr - Error return code. +! 0 = no error +! 1 = Undefine Product Template number. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: number + integer,intent(out) :: nummap,map(*),iret + logical,intent(out) :: needext + + iret=0 + + index=getpdsindex(number) + + if (index.ne.-1) then + nummap=templates(index)%mappdslen + needext=templates(index)%needext + map(1:nummap)=templates(index)%mappds(1:nummap) + else + nummap=0 + needext=.false. + print *,'getpdstemplate: PDS Template ',number, + & ' not defined.' + iret=1 + endif + + end subroutine + + subroutine extpdstemplate(number,list,nummap,map) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: extpdstemplate +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-11 +! +! ABSTRACT: This subroutine generates the remaining octet map for a +! given Product Definition Template, if required. Some Templates can +! vary depending on data values given in an earlier part of the +! Template, and it is necessary to know some of the earlier entry +! values to generate the full octet map of the Template. +! +! PROGRAM HISTORY LOG: +! 2000-05-11 Gilbert +! 2010-08-03 VUONG - Added Templates 4.40,4.41,4.42,.4.43 +! 2010-12-08 Vuong - Corrected Product Definition Template 4.42 and 4.43 +! 2013-07-29 Vuong - Added Templates 4.48,4.50,4.33,4.34,4.53,4.54 +! +! USAGE: CALL extpdstemplate(number,list,nummap,map) +! INPUT ARGUMENT LIST: +! number - NN, indicating the number of the Product Definition +! Template 4.NN that is being requested. +! list() - The list of values for each entry in the +! the Product Definition Template 4.NN. +! +! OUTPUT ARGUMENT LIST: +! nummap - Number of entries in the Template +! map() - An array containing the number of octets that each +! template entry occupies when packed up into the GDS. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: number,list(*) + integer,intent(out) :: nummap,map(*) + + index=getpdsindex(number) + if (index.eq.-1) return + + if ( .not. templates(index)%needext ) return + nummap=templates(index)%mappdslen + map(1:nummap)=templates(index)%mappds(1:nummap) + + if ( number.eq.3 ) then + N=list(27) + do i=1,N + map(nummap+i)=1 + enddo + nummap=nummap+N + elseif ( number.eq.4 ) then + N=list(26) + do i=1,N + map(nummap+i)=1 + enddo + nummap=nummap+N + elseif ( number.eq.8 ) then + if ( list(22).gt.1 ) then + do j=2,list(22) + do k=1,6 + map(nummap+k)=map(23+k) + enddo + nummap=nummap+6 + enddo + endif + elseif ( number.eq.9 ) then + if ( list(29).gt.1 ) then + do j=2,list(29) + do k=1,6 + map(nummap+k)=map(30+k) + enddo + nummap=nummap+6 + enddo + endif + elseif ( number.eq.10 ) then + if ( list(23).gt.1 ) then + do j=2,list(23) + do k=1,6 + map(nummap+k)=map(24+k) + enddo + nummap=nummap+6 + enddo + endif + elseif ( number.eq.11 ) then + if ( list(25).gt.1 ) then + do j=2,list(25) + do k=1,6 + map(nummap+k)=map(26+k) + enddo + nummap=nummap+6 + enddo + endif + elseif ( number.eq.12 ) then + if ( list(24).gt.1 ) then + do j=2,list(24) + do k=1,6 + map(nummap+k)=map(25+k) + enddo + nummap=nummap+6 + enddo + endif + elseif ( number.eq.13 ) then + if ( list(38).gt.1 ) then + do j=2,list(38) + do k=1,6 + map(nummap+k)=map(39+k) + enddo + nummap=nummap+6 + enddo + endif + N=list(27) + do i=1,N + map(nummap+i)=1 + enddo + nummap=nummap+N + elseif ( number.eq.14 ) then + if ( list(37).gt.1 ) then + do j=2,list(37) + do k=1,6 + map(nummap+k)=map(38+k) + enddo + nummap=nummap+6 + enddo + endif + N=list(26) + do i=1,N + map(nummap+i)=1 + enddo + nummap=nummap+N + elseif ( number.eq.30 ) then + do j=1,list(5) + map(nummap+1)=2 + map(nummap+2)=2 + map(nummap+3)=1 + map(nummap+4)=1 + map(nummap+5)=4 + nummap=nummap+5 + enddo + elseif ( number.eq.31 ) then + do j=1,list(5) + map(nummap+1)=2 + map(nummap+2)=2 + map(nummap+3)=2 + map(nummap+4)=1 + map(nummap+5)=4 + nummap=nummap+5 + enddo + elseif ( number.eq.32 ) then + do j=1,list(10) + map(nummap+1)=2 + map(nummap+2)=2 + map(nummap+3)=2 + map(nummap+4)=-1 + map(nummap+5)=-4 + nummap=nummap+5 + enddo + elseif ( number.eq.33 ) then + N=list(10) + do i=1,N + map(nummap+i)=1 + enddo + nummap=nummap+N + elseif ( number.eq.34 ) then + if ( list(25).gt.1 ) then + do j=2,list(25) + do k=1,6 + map(nummap+k)=map(26+k) + enddo + nummap=nummap+6 + enddo + endif + N=list(10) + do i=1,N + map(nummap+i)=1 + enddo + nummap=nummap+N + elseif ( number.eq.42 ) then + if ( list(23).gt.1 ) then + do j=2,list(23) + do k=1,6 + map(nummap+k)=map(24+k) + enddo + nummap=nummap+6 + enddo + endif + elseif ( number.eq.43 ) then + if ( list(26).gt.1 ) then + do j=2,list(26) + do k=1,6 + map(nummap+k)=map(27+k) + enddo + nummap=nummap+6 + enddo + endif + elseif ( number.eq.46 ) then + if ( list(28).gt.1 ) then + do j=2,list(28) + do k=1,6 + map(nummap+k)=map(29+k) + enddo + nummap=nummap+6 + enddo + endif + elseif ( number.eq.47 ) then + if ( list(31).gt.1 ) then + do j=2,list(31) + do k=1,6 + map(nummap+k)=map(32+k) + enddo + nummap=nummap+6 + enddo + endif + elseif ( number.eq.51 ) then + do j=1,list(16) + map(nummap+1)=1 + map(nummap+2)=1 + map(nummap+3)=-1 + map(nummap+4)=-4 + map(nummap+5)=-1 + map(nummap+6)=-4 + nummap=nummap+6 + enddo + elseif ( number.eq.53 ) then + N=list(4) + do i=1,N + map(nummap+i)=1 + enddo + nummap=nummap+N + elseif ( number.eq.54 ) then + N=list(4) + do i=1,N + map(nummap+i)=1 + enddo + nummap=nummap+N + elseif ( number.eq.91 ) then + if ( list(29).gt.1 ) then + do j=2,list(29) + do k=1,6 + map(nummap+k)=map(30+k) + enddo + nummap=nummap+6 + enddo + endif + N=list(16) + do i=1,N + map(nummap+i)=1 + enddo + nummap=nummap+N + endif + + end subroutine + + integer function getpdtlen(number) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: getpdtlen +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2004-05-11 +! +! ABSTRACT: This function returns the initial length (number of entries) in +! the "static" part of specified Product Definition Template 4.number. +! +! PROGRAM HISTORY LOG: +! 2004-05-11 Gilbert +! +! USAGE: CALL getpdtlen(number) +! INPUT ARGUMENT LIST: +! number - NN, indicating the number of the Product Definition +! Template 4.NN that is being requested. +! +! RETURNS: Number of entries in the "static" part of PDT 4.number +! OR returns 0, if requested template is not found. +! +! REMARKS: If user needs the full length of a specific template that +! contains additional entries based on values set in the "static" part +! of the PDT, subroutine extpdstemplate can be used. +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + integer,intent(in) :: number + + getpdtlen=0 + + index=getpdsindex(number) + + if (index.ne.-1) then + getpdtlen=templates(index)%mappdslen + endif + + end function + + end module diff --git a/WPS/ungrib/src/ngl/g2/pngpack.F b/WPS/ungrib/src/ngl/g2/pngpack.F new file mode 100755 index 00000000..cb9d1af8 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/pngpack.F @@ -0,0 +1,163 @@ + subroutine pngpack(fld,width,height,idrstmpl,cpack,lcpack) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: pngpack +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-12-21 +! +! ABSTRACT: This subroutine packs up a data field into PNG image format. +! After the data field is scaled, and the reference value is subtracted out, +! it is treated as a grayscale image and passed to a PNG encoder. +! It also fills in GRIB2 Data Representation Template 5.41 or 5.40010 with the +! appropriate values. +! +! PROGRAM HISTORY LOG: +! 2002-12-21 Gilbert +! +! USAGE: CALL pngpack(fld,width,height,idrstmpl,cpack,lcpack) +! INPUT ARGUMENT LIST: +! fld() - Contains the data values to pack +! width - number of points in the x direction +! height - number of points in the y direction +! idrstmpl - Contains the array of values for Data Representation +! Template 5.41 or 5.40010 +! (1) = Reference value - ignored on input +! (2) = Binary Scale Factor +! (3) = Decimal Scale Factor +! (4) = number of bits for each data value - ignored on input +! (5) = Original field type - currently ignored on input +! Data values assumed to be reals. +! +! OUTPUT ARGUMENT LIST: +! idrstmpl - Contains the array of values for Data Representation +! Template 5.41 or 5.40010 +! (1) = Reference value - set by pngpack routine. +! (2) = Binary Scale Factor - unchanged from input +! (3) = Decimal Scale Factor - unchanged from input +! (4) = Number of bits containing each grayscale pixel value +! (5) = Original field type - currently set = 0 on output. +! Data values assumed to be reals. +! cpack - The packed data field (character*1 array) +! lcpack - length of packed field cpack(). +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: XL Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + integer,intent(in) :: width,height + real,intent(in) :: fld(width*height) + character(len=1),intent(out) :: cpack(*) + integer,intent(inout) :: idrstmpl(*) + integer,intent(out) :: lcpack + + real(4) :: ref,rmin4 + real(8) :: rmin,rmax + integer(4) :: iref + integer :: ifld(width*height) + integer,parameter :: zero=0 + integer :: enc_png + character(len=1),allocatable :: ctemp(:) +#ifdef USE_PNG + + ndpts=width*height + bscale=2.0**real(-idrstmpl(2)) + dscale=10.0**real(idrstmpl(3)) +! +! Find max and min values in the data +! + rmax=fld(1) + rmin=fld(1) + do j=2,ndpts + if (fld(j).gt.rmax) rmax=fld(j) + if (fld(j).lt.rmin) rmin=fld(j) + enddo + maxdif=nint((rmax-rmin)*dscale*bscale) +! +! If max and min values are not equal, pack up field. +! If they are equal, we have a constant field, and the reference +! value (rmin) is the value for each point in the field and +! set nbits to 0. +! + if (rmin.ne.rmax .AND. maxdif.ne.0) then + ! + ! Determine which algorithm to use based on user-supplied + ! binary scale factor and number of bits. + ! + if (idrstmpl(2).eq.0) then + ! + ! No binary scaling and calculate minimum number of + ! bits in which the data will fit. + ! + imin=nint(rmin*dscale) + imax=nint(rmax*dscale) + maxdif=imax-imin + temp=alog(real(maxdif+1))/alog(2.0) + nbits=ceiling(temp) + rmin=real(imin) + ! scale data + do j=1,ndpts + ifld(j)=nint(fld(j)*dscale)-imin + enddo + else + ! + ! Use binary scaling factor and calculate minimum number of + ! bits in which the data will fit. + ! + rmin=rmin*dscale + rmax=rmax*dscale + maxdif=nint((rmax-rmin)*bscale) + temp=alog(real(maxdif+1))/alog(2.0) + nbits=ceiling(temp) + ! scale data + do j=1,ndpts + ifld(j)=nint(((fld(j)*dscale)-rmin)*bscale) + enddo + endif + ! + ! Pack data into full octets, then do PNG encode. + ! and calculate the length of the packed data in bytes + ! + if (nbits.le.8) then + nbits=8 + elseif (nbits.le.16) then + nbits=16 + elseif (nbits.le.24) then + nbits=24 + else + nbits=32 + endif + nbytes=(nbits/8)*ndpts + allocate(ctemp(nbytes)) + call sbytes(ctemp,ifld,0,nbits,0,ndpts) + ! + ! Encode data into PNG Format. + ! + lcpack=enc_png(ctemp,width,height,nbits,cpack) + if (lcpack.le.0) then + print *,'pngpack: ERROR Encoding PNG = ',lcpack + endif + deallocate(ctemp) + + else + nbits=0 + lcpack=0 + endif + +! +! Fill in ref value and number of bits in Template 5.0 +! + rmin4=rmin + call mkieee(rmin4,ref,1) ! ensure reference value is IEEE format +! call gbyte(ref,idrstmpl(1),0,32) + iref=transfer(ref,iref) + idrstmpl(1)=iref + idrstmpl(4)=nbits + idrstmpl(5)=0 ! original data were reals + + +#endif /* USE_PNG */ + return + end diff --git a/WPS/ungrib/src/ngl/g2/pngunpack.F b/WPS/ungrib/src/ngl/g2/pngunpack.F new file mode 100755 index 00000000..52618bc5 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/pngunpack.F @@ -0,0 +1,72 @@ + subroutine pngunpack(cpack,len,idrstmpl,ndpts,fld) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: pngunpack +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-06-21 +! +! ABSTRACT: This subroutine unpacks a data field that was packed into a +! PNG image format +! using info from the GRIB2 Data Representation Template 5.41 or 5.40010. +! +! PROGRAM HISTORY LOG: +! 2000-06-21 Gilbert +! +! USAGE: CALL pngunpack(cpack,len,idrstmpl,ndpts,fld) +! INPUT ARGUMENT LIST: +! cpack - The packed data field (character*1 array) +! len - length of packed field cpack(). +! idrstmpl - Contains the array of values for Data Representation +! Template 5.41 or 5.40010 +! ndpts - The number of data values to unpack +! +! OUTPUT ARGUMENT LIST: +! fld() - Contains the unpacked data values +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: XL Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cpack(len) + integer,intent(in) :: ndpts,len + integer,intent(in) :: idrstmpl(*) + real,intent(out) :: fld(ndpts) + + integer :: ifld(ndpts) + character(len=1),allocatable :: ctemp(:) + integer(4) :: ieee + real :: ref,bscale,dscale + integer :: dec_png,width,height +#ifdef USE_PNG + + ieee = idrstmpl(1) + call rdieee(ieee,ref,1) + bscale = 2.0**real(idrstmpl(2)) + dscale = 10.0**real(-idrstmpl(3)) + nbits = idrstmpl(4) + itype = idrstmpl(5) +! +! if nbits equals 0, we have a constant field where the reference value +! is the data value at each gridpoint +! + if (nbits.ne.0) then + allocate(ctemp(ndpts*4)) + iret=dec_png(cpack,width,height,ctemp) + call gbytes(ctemp,ifld,0,nbits,0,ndpts) + deallocate(ctemp) + do j=1,ndpts + fld(j)=((real(ifld(j))*bscale)+ref)*dscale + enddo + else + do j=1,ndpts + fld(j)=ref + enddo + endif + + +#endif /* USE_PNG */ + return + end diff --git a/WPS/ungrib/src/ngl/g2/putgb2.f b/WPS/ungrib/src/ngl/g2/putgb2.f new file mode 100755 index 00000000..7be3491c --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/putgb2.f @@ -0,0 +1,284 @@ +C----------------------------------------------------------------------- + SUBROUTINE PUTGB2(LUGB,GFLD,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PUTGB2 PACKS AND WRITES A GRIB2 MESSAGE +C PRGMMR: GILBERT ORG: W/NP11 DATE: 2002-04-22 +C +C ABSTRACT: PACKS A SINGLE FIELD INTO A GRIB2 MESSAGE +C AND WRITES OUT THAT MESSAGE TO THE FILE ASSOCIATED WITH UNIT LUGB. +C NOTE THAT FILE/UNIT LUGB SHOULD BE OPENED WOTH A CALL TO +C SUBROUTINE BAOPENW BEFORE THIS ROUTINE IS CALLED. +C +C The information to be packed into the GRIB field +C is stored in a derived type variable, gfld. +C Gfld is of type gribfield, which is defined +C in module grib_mod, so users of this routine will need to include +C the line "USE GRIB_MOD" in their calling routine. Each component of the +C gribfield type is described in the INPUT ARGUMENT LIST section below. +C +C PROGRAM HISTORY LOG: +C 2002-04-22 GILBERT +C 2005-02-28 GILBERT - Changed dimension of array cgrib to be a multiple +C of gfld%ngrdpts instead of gfld%ndpts. +C 2009-03-10 VUONG - Initialize variable coordlist +C 2011-06-09 VUONG - Initialize variable gfld%list_opt +C 2012-02-28 VUONG - Initialize variable ilistopt +C +C USAGE: CALL PUTGB2(LUGB,GFLD,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE. +C FILE MUST BE OPENED WITH BAOPEN OR BAOPENW BEFORE CALLING +C THIS ROUTINE. +C gfld - derived type gribfield ( defined in module grib_mod ) +C ( NOTE: See Remarks Section ) +C gfld%version = GRIB edition number ( currently 2 ) +C gfld%discipline = Message Discipline ( see Code Table 0.0 ) +C gfld%idsect() = Contains the entries in the Identification +C Section ( Section 1 ) +C This element is actually a pointer to an array +C that holds the data. +C gfld%idsect(1) = Identification of originating Centre +C ( see Common Code Table C-1 ) +C 7 - US National Weather Service +C gfld%idsect(2) = Identification of originating Sub-centre +C gfld%idsect(3) = GRIB Master Tables Version Number +C ( see Code Table 1.0 ) +C 0 - Experimental +C 1 - Initial operational version number +C gfld%idsect(4) = GRIB Local Tables Version Number +C ( see Code Table 1.1 ) +C 0 - Local tables not used +C 1-254 - Number of local tables version used +C gfld%idsect(5) = Significance of Reference Time (Code Table 1.2) +C 0 - Analysis +C 1 - Start of forecast +C 2 - Verifying time of forecast +C 3 - Observation time +C gfld%idsect(6) = Year ( 4 digits ) +C gfld%idsect(7) = Month +C gfld%idsect(8) = Day +C gfld%idsect(9) = Hour +C gfld%idsect(10) = Minute +C gfld%idsect(11) = Second +C gfld%idsect(12) = Production status of processed data +C ( see Code Table 1.3 ) +C 0 - Operational products +C 1 - Operational test products +C 2 - Research products +C 3 - Re-analysis products +C gfld%idsect(13) = Type of processed data ( see Code Table 1.4 ) +C 0 - Analysis products +C 1 - Forecast products +C 2 - Analysis and forecast products +C 3 - Control forecast products +C 4 - Perturbed forecast products +C 5 - Control and perturbed forecast products +C 6 - Processed satellite observations +C 7 - Processed radar observations +C gfld%idsectlen = Number of elements in gfld%idsect(). +C gfld%local() = Pointer to character array containing contents +C of Local Section 2, if included +C gfld%locallen = length of array gfld%local() +C gfld%ifldnum = field number within GRIB message +C gfld%griddef = Source of grid definition (see Code Table 3.0) +C 0 - Specified in Code table 3.1 +C 1 - Predetermined grid Defined by originating centre +C gfld%ngrdpts = Number of grid points in the defined grid. +C gfld%numoct_opt = Number of octets needed for each +C additional grid points definition. +C Used to define number of +C points in each row ( or column ) for +C non-regular grids. +C = 0, if using regular grid. +C gfld%interp_opt = Interpretation of list for optional points +C definition. (Code Table 3.11) +C gfld%igdtnum = Grid Definition Template Number (Code Table 3.1) +C gfld%igdtmpl() = Contains the data values for the specified Grid +C Definition Template ( NN=gfld%igdtnum ). Each +C element of this integer array contains an entry (in +C the order specified) of Grid Defintion Template 3.NN +C This element is actually a pointer to an array +C that holds the data. +C gfld%igdtlen = Number of elements in gfld%igdtmpl(). i.e. number of +C entries in Grid Defintion Template 3.NN +C ( NN=gfld%igdtnum ). +C gfld%list_opt() = (Used if gfld%numoct_opt .ne. 0) This array +C contains the number of grid points contained in +C each row ( or column ). (part of Section 3) +C This element is actually a pointer to an array +C that holds the data. This pointer is nullified +C if gfld%numoct_opt=0. +C gfld%num_opt = (Used if gfld%numoct_opt .ne. 0) The number of entries +C in array ideflist. i.e. number of rows ( or columns ) +C for which optional grid points are defined. This value +C is set to zero, if gfld%numoct_opt=0. +C gfdl%ipdtnum = Product Definition Template Number (see Code Table 4.0) +C gfld%ipdtmpl() = Contains the data values for the specified Product +C Definition Template ( N=gfdl%ipdtnum ). Each element +C of this integer array contains an entry (in the +C order specified) of Product Defintion Template 4.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%ipdtlen = Number of elements in gfld%ipdtmpl(). i.e. number of +C entries in Product Defintion Template 4.N +C ( N=gfdl%ipdtnum ). +C gfld%coord_list() = Real array containing floating point values +C intended to document the vertical discretisation +C associated to model data on hybrid coordinate +C vertical levels. (part of Section 4) +C This element is actually a pointer to an array +C that holds the data. +C gfld%num_coord = number of values in array gfld%coord_list(). +C gfld%ndpts = Number of data points unpacked and returned. +C gfld%idrtnum = Data Representation Template Number +C ( see Code Table 5.0) +C gfld%idrtmpl() = Contains the data values for the specified Data +C Representation Template ( N=gfld%idrtnum ). Each +C element of this integer array contains an entry +C (in the order specified) of Product Defintion +C Template 5.N. +C This element is actually a pointer to an array +C that holds the data. +C gfld%idrtlen = Number of elements in gfld%idrtmpl(). i.e. number +C of entries in Data Representation Template 5.N +C ( N=gfld%idrtnum ). +C gfld%unpacked = logical value indicating whether the bitmap and +C data values were unpacked. If false, +C gfld%bmap and gfld%fld pointers are nullified. +C gfld%ibmap = Bitmap indicator ( see Code Table 6.0 ) +C 0 = bitmap applies and is included in Section 6. +C 1-253 = Predefined bitmap applies +C 254 = Previously defined bitmap applies to this field +C 255 = Bit map does not apply to this product. +C gfld%bmap() = Logical*1 array containing decoded bitmap, +C if ibmap=0 or ibap=254. Otherwise nullified. +C This element is actually a pointer to an array +C that holds the data. +C gfld%fld() = Array of gfld%ndpts unpacked data points. +C This element is actually a pointer to an array +C that holds the data. +C +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 2 MEMORY ALLOCATION ERROR +C 10 No Section 1 info available +C 11 No Grid Definition Template info available +C 12 Missing some required data field info +C +C SUBPROGRAMS CALLED: +C gribcreate Start a new grib2 message +C addlocal Add local section to a GRIB2 message +C addgrid Add grid info to a GRIB2 message +C addfield Add data field to a GRIB2 message +C gribend End GRIB2 message +C +C REMARKS: +C +C Note that derived type gribfield contains pointers to many +C arrays of data. The memory for these arrays is allocated +C when the values in the arrays are set, to help minimize +C problems with array overloading. Because of this users +C are encouraged to free up this memory, when it is no longer +C needed, by an explicit call to subroutine gf_free. +C ( i.e. CALL GF_FREE(GFLD) ) +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE GRIB_MOD + + INTEGER,INTENT(IN) :: LUGB + TYPE(GRIBFIELD),INTENT(IN) :: GFLD + INTEGER,INTENT(OUT) :: IRET + + CHARACTER(LEN=1),ALLOCATABLE,DIMENSION(:) :: CGRIB + integer :: listsec0(2) + integer :: igds(5) + real :: coordlist + integer :: ilistopt + + listsec0=(/0,2/) + igds=(/0,0,0,0,0/) + coordlist=0.0 + ilistopt=0 + +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C ALLOCATE ARRAY FOR GRIB2 FIELD + lcgrib=gfld%ngrdpts*4 + allocate(cgrib(lcgrib),stat=is) + if ( is.ne.0 ) then + print *,'putgb2: cannot allocate memory. ',is + iret=2 + endif +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C CREATE NEW MESSAGE + listsec0(1)=gfld%discipline + listsec0(2)=gfld%version + if ( associated(gfld%idsect) ) then + call gribcreate(cgrib,lcgrib,listsec0,gfld%idsect,ierr) + if (ierr.ne.0) then + write(6,*) 'putgb2: ERROR creating new GRIB2 field = ',ierr + endif + else + print *,'putgb2: No Section 1 info available. ' + iret=10 + deallocate(cgrib) + return + endif +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C ADD LOCAL USE SECTION TO GRIB2 MESSAGE + if ( associated(gfld%local).AND.gfld%locallen.gt.0 ) then + call addlocal(cgrib,lcgrib,gfld%local,gfld%locallen,ierr) + if (ierr.ne.0) then + write(6,*) 'putgb2: ERROR adding local info = ',ierr + endif + endif +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C ADD GRID TO GRIB2 MESSAGE + igds(1)=gfld%griddef + igds(2)=gfld%ngrdpts + igds(3)=gfld%numoct_opt + igds(4)=gfld%interp_opt + igds(5)=gfld%igdtnum + if ( associated(gfld%igdtmpl) ) then + call addgrid(cgrib,lcgrib,igds,gfld%igdtmpl,gfld%igdtlen, + & ilistopt,gfld%num_opt,ierr) + if (ierr.ne.0) then + write(6,*) 'putgb2: ERROR adding grid info = ',ierr + endif + else + print *,'putgb2: No GDT info available. ' + iret=11 + deallocate(cgrib) + return + endif +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C ADD DATA FIELD TO GRIB2 MESSAGE + if ( associated(gfld%ipdtmpl).AND. + & associated(gfld%idrtmpl).AND. + & associated(gfld%fld) ) then + call addfield(cgrib,lcgrib,gfld%ipdtnum,gfld%ipdtmpl, + & gfld%ipdtlen,coordlist,gfld%num_coord, + & gfld%idrtnum,gfld%idrtmpl,gfld%idrtlen, + & gfld%fld,gfld%ngrdpts,gfld%ibmap,gfld%bmap, + & ierr) + if (ierr.ne.0) then + write(6,*) 'putgb2: ERROR adding data field = ',ierr + endif + else + print *,'putgb2: Missing some field info. ' + iret=12 + deallocate(cgrib) + return + endif +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C CLOSE GRIB2 MESSAGE AND WRITE TO FILE + call gribend(cgrib,lcgrib,lengrib,ierr) + call wryte(lugb,lengrib,cgrib) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + deallocate(cgrib) + RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/rdieee.f b/WPS/ungrib/src/ngl/g2/rdieee.f new file mode 100755 index 00000000..458cc8fc --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/rdieee.f @@ -0,0 +1,80 @@ + subroutine rdieee(rieee,a,num) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: rdieee +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-05-09 +! +! ABSTRACT: This subroutine reads a list of real values in +! 32-bit IEEE floating point format. +! +! PROGRAM HISTORY LOG: +! 2000-05-09 Gilbert +! +! USAGE: CALL rdieee(rieee,a,num) +! INPUT ARGUMENT LIST: +! rieee - Input array of floating point values in 32-bit IEEE format. +! num - Number of floating point values to convert. +! +! OUTPUT ARGUMENT LIST: +! a - Output array of real values. +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + real(4),intent(in) :: rieee(num) + real,intent(out) :: a(num) + integer,intent(in) :: num + + integer(4) :: ieee + +! Recent versions of the PGI compilers apparently still do not fully support +! the use of all intrinsics in parameter statements, though this is part of +! the F2003 standard. +! real, parameter :: two23=scale(1.0,23) +! real, parameter :: two126=scale(1.0,126) + real :: two23 + real :: two126 + + two23=scale(1.0,-23) + two126=scale(1.0,-126) + + do j=1,num +! +! Transfer IEEE bit string to integer variable +! + ieee=transfer(rieee(j),ieee) +! +! Extract sign bit, exponent, and mantissa +! + isign=ibits(ieee,31,1) + iexp=ibits(ieee,23,8) + imant=ibits(ieee,0,23) + sign=1.0 + if (isign.eq.1) sign=-1.0 + + if ( (iexp.gt.0).and.(iexp.lt.255) ) then + temp=2.0**(iexp-127) + a(j)=sign*temp*(1.0+(two23*real(imant))) + + elseif ( iexp.eq.0 ) then + if ( imant.ne.0 ) then + a(j)=sign*two126*two23*real(imant) + else + a(j)=sign*0.0 + endif + + elseif ( iexp.eq.255 ) then + a(j)=sign*huge(a(j)) + + endif + + enddo + + return + end + diff --git a/WPS/ungrib/src/ngl/g2/realloc.f b/WPS/ungrib/src/ngl/g2/realloc.f new file mode 100755 index 00000000..254ca548 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/realloc.f @@ -0,0 +1,125 @@ + module re_alloc + + interface realloc + module procedure realloc_c1 + module procedure realloc_r + module procedure realloc_i +!! subroutine realloc_c1(c,n,m,istat) +!! character(len=1),pointer,dimension(:) :: c +!! integer :: n,m +!! integer :: istat +!! end subroutine +!! subroutine realloc_r(c,n,m,istat) +!! real,pointer,dimension(:) :: c +!! integer :: n,m +!! integer :: istat +!! end subroutine +!! subroutine realloc_i(c,n,m,istat) +!! integer,pointer,dimension(:) :: c +!! integer :: n,m +!! integer :: istat +!! end subroutine + end interface + + contains + + subroutine realloc_c1(c,n,m,istat) + character(len=1),pointer,dimension(:) :: c + integer,intent(in) :: n,m + integer,intent(out) :: istat + integer :: num + character(len=1),pointer,dimension(:) :: tmp + + istat=0 + if ( (n<0) .OR. (m<=0) ) then + istat=10 + return + endif + + if ( .not. associated(c) ) then + allocate(c(m),stat=istat) ! allocate new memory + return + endif + + tmp=>c ! save pointer to original mem + nullify(c) + allocate(c(m),stat=istat) ! allocate new memory + if ( istat /= 0 ) then + c=>tmp + return + endif + if ( n /= 0 ) then + num=min(n,m) + c(1:num)=tmp(1:num) ! copy data from orig mem to new loc. + endif + deallocate(tmp) ! deallocate original memory + return + end subroutine + + subroutine realloc_r(c,n,m,istat) + real,pointer,dimension(:) :: c + integer,intent(in) :: n,m + integer,intent(out) :: istat + integer :: num + real,pointer,dimension(:) :: tmp + + istat=0 + if ( (n<0) .OR. (m<=0) ) then + istat=10 + return + endif + + if ( .not. associated(c) ) then + allocate(c(m),stat=istat) ! allocate new memory + return + endif + + tmp=>c ! save pointer to original mem + nullify(c) + allocate(c(m),stat=istat) ! allocate new memory + if ( istat /= 0 ) then + c=>tmp + return + endif + if ( n /= 0 ) then + num=min(n,m) + c(1:num)=tmp(1:num) ! copy data from orig mem to new loc. + endif + deallocate(tmp) ! deallocate original memory + return + end subroutine + + subroutine realloc_i(c,n,m,istat) + integer,pointer,dimension(:) :: c + integer,intent(in) :: n,m + integer,intent(out) :: istat + integer :: num + integer,pointer,dimension(:) :: tmp + + istat=0 + if ( (n<0) .OR. (m<=0) ) then + istat=10 + return + endif + + if ( .not. associated(c) ) then + allocate(c(m),stat=istat) ! allocate new memory + return + endif + + tmp=>c ! save pointer to original mem + nullify(c) + allocate(c(m),stat=istat) ! allocate new memory + if ( istat /= 0 ) then + c=>tmp + return + endif + if ( n /= 0 ) then + num=min(n,m) + c(1:num)=tmp(1:num) ! copy data from orig mem to new loc. + endif + deallocate(tmp) ! deallocate original memory + return + end subroutine + + end module re_alloc diff --git a/WPS/ungrib/src/ngl/g2/reduce.f b/WPS/ungrib/src/ngl/g2/reduce.f new file mode 100755 index 00000000..5480fd83 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/reduce.f @@ -0,0 +1,343 @@ + SUBROUTINE REDUCE(KFILDO,JMIN,JMAX,LBIT,NOV,LX,NDG,IBIT,JBIT,KBIT, + 1 NOVREF,IBXX2,IER) +C +C NOVEMBER 2001 GLAHN TDL GRIB2 +C MARCH 2002 GLAHN COMMENT IER = 715 +C MARCH 2002 GLAHN MODIFIED TO ACCOMMODATE LX=1 ON ENTRY +C +C PURPOSE +C DETERMINES WHETHER THE NUMBER OF GROUPS SHOULD BE +C INCREASED IN ORDER TO REDUCE THE SIZE OF THE LARGE +C GROUPS, AND TO MAKE THAT ADJUSTMENT. BY REDUCING THE +C SIZE OF THE LARGE GROUPS, LESS BITS MAY BE NECESSARY +C FOR PACKING THE GROUP SIZES AND ALL THE INFORMATION +C ABOUT THE GROUPS. +C +C THE REFERENCE FOR NOV( ) WAS REMOVED IN THE CALLING +C ROUTINE SO THAT KBIT COULD BE DETERMINED. THIS +C FURNISHES A STARTING POINT FOR THE ITERATIONS IN REDUCE. +C HOWEVER, THE REFERENCE MUST BE CONSIDERED. +C +C DATA SET USE +C KFILDO - UNIT NUMBER FOR OUTPUT (PRINT) FILE. (OUTPUT) +C +C VARIABLES IN CALL SEQUENCE +C KFILDO = UNIT NUMBER FOR OUTPUT (PRINT) FILE. (INPUT) +C JMIN(J) = THE MINIMUM OF EACH GROUP (J=1,LX). IT IS +C POSSIBLE AFTER SPLITTING THE GROUPS, JMIN( ) +C WILL NOT BE THE MINIMUM OF THE NEW GROUP. +C THIS DOESN'T MATTER; JMIN( ) IS REALLY THE +C GROUP REFERENCE AND DOESN'T HAVE TO BE THE +C SMALLEST VALUE. (INPUT/OUTPUT) +C JMAX(J) = THE MAXIMUM OF EACH GROUP (J=1,LX). +C (INPUT/OUTPUT) +C LBIT(J) = THE NUMBER OF BITS NECESSARY TO PACK EACH GROUP +C (J=1,LX). (INPUT/OUTPUT) +C NOV(J) = THE NUMBER OF VALUES IN EACH GROUP (J=1,LX). +C (INPUT/OUTPUT) +C LX = THE NUMBER OF GROUPS. THIS WILL BE INCREASED +C IF GROUPS ARE SPLIT. (INPUT/OUTPUT) +C NDG = THE DIMENSION OF JMIN( ), JMAX( ), LBIT( ), AND +C NOV( ). (INPUT) +C IBIT = THE NUMBER OF BITS NECESSARY TO PACK THE JMIN(J) +C VALUES, J=1,LX. (INPUT) +C JBIT = THE NUMBER OF BITS NECESSARY TO PACK THE LBIT(J) +C VALUES, J=1,LX. (INPUT) +C KBIT = THE NUMBER OF BITS NECESSARY TO PACK THE NOV(J) +C VALUES, J=1,LX. IF THE GROUPS ARE SPLIT, KBIT +C IS REDUCED. (INPUT/OUTPUT) +C NOVREF = REFERENCE VALUE FOR NOV( ). (INPUT) +C IBXX2(J) = 2**J (J=0,30). (INPUT) +C IER = ERROR RETURN. (OUTPUT) +C 0 = GOOD RETURN. +C 714 = PROBLEM IN ALGORITHM. REDUCE ABORTED. +C 715 = NGP NOT LARGE ENOUGH. REDUCE ABORTED. +C NTOTBT(J) = THE TOTAL BITS USED FOR THE PACKING BITS J +C (J=1,30). (INTERNAL) +C NBOXJ(J) = NEW BOXES NEEDED FOR THE PACKING BITS J +C (J=1,30). (INTERNAL) +C NEWBOX(L) = NUMBER OF NEW BOXES (GROUPS) FOR EACH ORIGINAL +C GROUP (L=1,LX) FOR THE CURRENT J. (AUTOMATIC) +C (INTERNAL) +C NEWBOXP(L) = SAME AS NEWBOX( ) BUT FOR THE PREVIOUS J. +C THIS ELIMINATES RECOMPUTATION. (AUTOMATIC) +C (INTERNAL) +C CFEED = CONTAINS THE CHARACTER REPRESENTATION +C OF A PRINTER FORM FEED. (CHARACTER) (INTERNAL) +C IFEED = CONTAINS THE INTEGER VALUE OF A PRINTER +C FORM FEED. (INTERNAL) +C IORIGB = THE ORIGINAL NUMBER OF BITS NECESSARY +C FOR THE GROUP VALUES. (INTERNAL) +C 1 2 3 4 5 6 7 X +C +C NON SYSTEM SUBROUTINES CALLED +C NONE +c + CHARACTER*1 CFEED +C + DIMENSION JMIN(NDG),JMAX(NDG),LBIT(NDG),NOV(NDG) + DIMENSION NEWBOX(NDG),NEWBOXP(NDG) +C NEWBOX( ) AND NEWBOXP( ) ARE AUTOMATIC ARRAYS. + DIMENSION NTOTBT(0:31),NBOXJ(0:31) + DIMENSION IBXX2(0:30) +C + DATA IFEED/12/ +C + IER=0 + IF(LX.EQ.1)GO TO 410 +C IF THERE IS ONLY ONE GROUP, RETURN. +C + CFEED=CHAR(IFEED) +C +C INITIALIZE NUMBER OF NEW BOXES PER GROUP TO ZERO. +C + DO 110 L=1,LX + NEWBOX(L)=0 + 110 CONTINUE +C +C INITIALIZE NUMBER OF TOTAL NEW BOXES PER J TO ZERO. +C + DO 112 J=0,31 + NTOTBT(J)=999999999 + NBOXJ(J)=0 + 112 CONTINUE +C + IORIGB=(IBIT+JBIT+KBIT)*LX +C IBIT = BITS TO PACK THE JMIN( ). +C JBIT = BITS TO PACK THE LBIT( ). +C KBIT = BITS TO PACK THE NOV( ). +C LX = NUMBER OF GROUPS. + NTOTBT(KBIT)=IORIGB +C THIS IS THE VALUE OF TOTAL BITS FOR THE ORIGINAL LX +C GROUPS, WHICH REQUIRES KBITS TO PACK THE GROUP +C LENGHTS. SETTING THIS HERE MAKES ONE LESS LOOPS +C NECESSARY BELOW. +C +C COMPUTE BITS NOW USED FOR THE PARAMETERS DEFINED. +C +C DETERMINE OTHER POSSIBILITES BY INCREASING LX AND DECREASING +C NOV( ) WITH VALUES GREATER THAN THRESHOLDS. ASSUME A GROUP IS +C SPLIT INTO 2 OR MORE GROUPS SO THAT KBIT IS REDUCED WITHOUT +C CHANGING IBIT OR JBIT. +C + JJ=0 +C + DO 200 J=MIN(30,KBIT-1),2,-1 +C VALUES GE KBIT WILL NOT REQUIRE SPLITS. ONCE THE TOTAL +C BITS START INCREASING WITH DECREASING J, STOP. ALSO, THE +C NUMBER OF BITS REQUIRED IS KNOWN FOR KBITS = NTOTBT(KBIT). +C + NEWBOXT=0 +C + DO 190 L=1,LX +C + IF(NOV(L).LT.IBXX2(J))THEN + NEWBOX(L)=0 +C NO SPLITS OR NEW BOXES. + GO TO 190 + ELSE + NOVL=NOV(L) +C + M=(NOV(L)-1)/(IBXX2(J)-1)+1 +C M IS FOUND BY SOLVING THE EQUATION BELOW FOR M: +C (NOV(L)+M-1)/M LT IBXX2(J) +C M GT (NOV(L)-1)/(IBXX2(J)-1) +C SET M = (NOV(L)-1)/(IBXX2(J)-1)+1 + 130 NOVL=(NOV(L)+M-1)/M +C THE +M-1 IS NECESSARY. FOR INSTANCE, 15 WILL FIT +C INTO A BOX 4 BITS WIDE, BUT WON'T DIVIDE INTO +C TWO BOXES 3 BITS WIDE EACH. +C + IF(NOVL.LT.IBXX2(J))THEN + GO TO 185 + ELSE + M=M+1 +C*** WRITE(KFILDO,135)L,NOV(L),NOVL,M,J,IBXX2(J) +C*** 135 FORMAT(/' AT 135--L,NOV(L),NOVL,M,J,IBXX2(J)',6I10) + GO TO 130 + ENDIF +C +C THE ABOVE DO LOOP WILL NEVER COMPLETE. + ENDIF +C + 185 NEWBOX(L)=M-1 + NEWBOXT=NEWBOXT+M-1 + 190 CONTINUE +C + NBOXJ(J)=NEWBOXT + NTOTPR=NTOTBT(J+1) + NTOTBT(J)=(IBIT+JBIT)*(LX+NEWBOXT)+J*(LX+NEWBOXT) +C + IF(NTOTBT(J).GE.NTOTPR)THEN + JJ=J+1 +C THE PLUS IS USED BECAUSE J DECREASES PER ITERATION. + GO TO 250 + ELSE +C +C SAVE THE TOTAL NEW BOXES AND NEWBOX( ) IN CASE THIS +C IS THE J TO USE. +C + NEWBOXTP=NEWBOXT +C + DO 195 L=1,LX + NEWBOXP(L)=NEWBOX(L) + 195 CONTINUE +C +C WRITE(KFILDO,197)NEWBOXT,IBXX2(J) +C197 FORMAT(/' *****************************************' +C 1 /' THE NUMBER OF NEWBOXES PER GROUP OF THE TOTAL', +C 2 I10,' FOR GROUP MAXSIZE PLUS 1 ='I10 +C 3 /' *****************************************') +C WRITE(KFILDO,198) (NEWBOX(L),L=1,LX) +C198 FORMAT(/' '20I6/(' '20I6)) + + ENDIF +C +C205 WRITE(KFILDO,209)KBIT,IORIGB +C209 FORMAT(/' ORIGINAL BITS WITH KBIT OF',I5,' =',I10) +C WRITE(KFILDO,210)(N,N=2,10),(IBXX2(N),N=2,10), +C 1 (NTOTBT(N),N=2,10),(NBOXJ(N),N=2,10), +C 2 (N,N=11,20),(IBXX2(N),N=11,20), +C 3 (NTOTBT(N),N=11,20),(NBOXJ(N),N=11,20), +C 4 (N,N=21,30),(IBXX2(N),N=11,20), +C 5 (NTOTBT(N),N=21,30),(NBOXJ(N),N=21,30) +C210 FORMAT(/' THE TOTAL BYTES FOR MAXIMUM GROUP LENGTHS BY ROW'// +C 1 ' J = THE NUMBER OF BITS PER GROUP LENGTH'/ +C 2 ' IBXX2(J) = THE MAXIMUM GROUP LENGTH PLUS 1 FOR THIS J'/ +C 3 ' NTOTBT(J) = THE TOTAL BITS FOR THIS J'/ +C 4 ' NBOXJ(J) = THE NEW GROUPS FOR THIS J'/ +C 5 4(/10X,9I10)/4(/10I10)/4(/10I10)) +C + 200 CONTINUE +C + 250 PIMP=((IORIGB-NTOTBT(JJ))/FLOAT(IORIGB))*100. +C WRITE(KFILDO,252)PIMP,KBIT,JJ +C252 FORMAT(/' PERCENT IMPROVEMENT =',F6.1, +C 1 ' BY DECREASING GROUP LENGTHS FROM',I4,' TO',I4,' BITS') + IF(PIMP.GE.2.)THEN +C +C WRITE(KFILDO,255)CFEED,NEWBOXTP,IBXX2(JJ) +C255 FORMAT(A1,/' *****************************************' +C 1 /' THE NUMBER OF NEWBOXES PER GROUP OF THE TOTAL', +C 2 I10,' FOR GROUP MAXSIZE PLUS 1 ='I10 +C 2 /' *****************************************') +C WRITE(KFILDO,256) (NEWBOXP(L),L=1,LX) +C256 FORMAT(/' '20I6) +C +C ADJUST GROUP LENGTHS FOR MAXIMUM LENGTH OF JJ BITS. +C THE MIN PER GROUP AND THE NUMBER OF BITS REQUIRED +C PER GROUP ARE NOT CHANGED. THIS MAY MEAN THAT A +C GROUP HAS A MIN (OR REFERENCE) THAT IS NOT ZERO. +C THIS SHOULD NOT MATTER TO THE UNPACKER. +C + LXNKP=LX+NEWBOXTP +C LXNKP = THE NEW NUMBER OF BOXES +C + IF(LXNKP.GT.NDG)THEN +C DIMENSIONS NOT LARGE ENOUGH. PROBABLY AN ERROR +C OF SOME SORT. ABORT. +C WRITE(KFILDO,257)NDG,LXNPK +C 1 2 3 4 5 6 7 X +C257 FORMAT(/' DIMENSIONS OF JMIN, ETC. IN REDUCE =',I8, +C 1 ' NOT LARGE ENOUGH FOR THE EXPANDED NUMBER OF', +C 2 ' GROUPS =',I8,'. ABORT REDUCE.') + IER=715 + GO TO 410 +C AN ABORT CAUSES THE CALLING PROGRAM TO REEXECUTE +C WITHOUT CALLING REDUCE. + ENDIF +C + LXN=LXNKP +C LXN IS THE NUMBER OF THE BOX IN THE NEW SERIES BEING +C FILLED. IT DECREASES PER ITERATION. + IBXX2M1=IBXX2(JJ)-1 +C IBXX2M1 IS THE MAXIMUM NUMBER OF VALUES PER GROUP. +C + DO 300 L=LX,1,-1 +C +C THE VALUES IS NOV( ) REPRESENT THOSE VALUES + NOVREF. +C WHEN VALUES ARE MOVED TO ANOTHER BOX, EACH VALUE +C MOVED TO A NEW BOX REPRESENTS THAT VALUE + NOVREF. +C THIS HAS TO BE CONSIDERED IN MOVING VALUES. +C + IF(NEWBOXP(L)*(IBXX2M1+NOVREF)+NOVREF.GT.NOV(L)+NOVREF)THEN +C IF THE ABOVE TEST IS MET, THEN MOVING IBXX2M1 VALUES +C FOR ALL NEW BOXES WILL LEAVE A NEGATIVE NUMBER FOR +C THE LAST BOX. NOT A TOLERABLE SITUATION. + MOVMIN=(NOV(L)-(NEWBOXP(L))*NOVREF)/NEWBOXP(L) + LEFT=NOV(L) +C LEFT = THE NUMBER OF VALUES TO MOVE FROM THE ORIGINAL +C BOX TO EACH NEW BOX EXCEPT THE LAST. LEFT IS THE +C NUMBER LEFT TO MOVE. + ELSE + MOVMIN=IBXX2M1 +C MOVMIN VALUES CAN BE MOVED FOR EACH NEW BOX. + LEFT=NOV(L) +C LEFT IS THE NUMBER OF VALUES LEFT TO MOVE. + ENDIF +C + IF(NEWBOXP(L).GT.0)THEN + IF((MOVMIN+NOVREF)*NEWBOXP(L)+NOVREF.LE.NOV(L)+NOVREF. + 1 AND.(MOVMIN+NOVREF)*(NEWBOXP(L)+1).GE.NOV(L)+NOVREF)THEN + GO TO 288 + ELSE +C***D WRITE(KFILDO,287)L,MOVMIN,NOVREF,NEWBOXP(L),NOV(L) +C***D287 FORMAT(/' AT 287 IN REDUCE--L,MOVMIN,NOVREF,', +C***D 1 'NEWBOXP(L),NOV(L)',5I12 +C***D 2 ' REDUCE ABORTED.') +C WRITE(KFILDO,2870) +C2870 FORMAT(/' AN ERROR IN REDUCE ALGORITHM. ABORT REDUCE.') + IER=714 + GO TO 410 +C AN ABORT CAUSES THE CALLING PROGRAM TO REEXECUTE +C WITHOUT CALLING REDUCE. + ENDIF +C + ENDIF +C + 288 DO 290 J=1,NEWBOXP(L)+1 + MOVE=MIN(MOVMIN,LEFT) + JMIN(LXN)=JMIN(L) + JMAX(LXN)=JMAX(L) + LBIT(LXN)=LBIT(L) + NOV(LXN)=MOVE + LXN=LXN-1 + LEFT=LEFT-(MOVE+NOVREF) +C THE MOVE OF MOVE VALUES REALLY REPRESENTS A MOVE OF +C MOVE + NOVREF VALUES. + 290 CONTINUE +C + IF(LEFT.NE.-NOVREF)THEN +C*** WRITE(KFILDO,292)L,LXN,MOVE,LXNKP,IBXX2(JJ),LEFT,NOV(L), +C*** 1 MOVMIN +C*** 292 FORMAT(' AT 292 IN REDUCE--L,LXN,MOVE,LXNKP,', +C*** 1 'IBXX2(JJ),LEFT,NOV(L),MOVMIN'/8I12) + ENDIF +C + 300 CONTINUE +C + LX=LXNKP +C LX IS NOW THE NEW NUMBER OF GROUPS. + KBIT=JJ +C KBIT IS NOW THE NEW NUMBER OF BITS REQUIRED FOR PACKING +C GROUP LENGHTS. + ENDIF +C +C WRITE(KFILDO,406)CFEED,LX +C406 FORMAT(A1,/' *****************************************' +C 1 /' THE GROUP SIZES NOV( ) AFTER REDUCTION IN SIZE', +C 2 ' FOR'I10,' GROUPS', +C 3 /' *****************************************') +C WRITE(KFILDO,407) (NOV(J),J=1,LX) +C407 FORMAT(/' '20I6) +C WRITE(KFILDO,408)CFEED,LX +C408 FORMAT(A1,/' *****************************************' +C 1 /' THE GROUP MINIMA JMIN( ) AFTER REDUCTION IN SIZE', +C 2 ' FOR'I10,' GROUPS', +C 3 /' *****************************************') +C WRITE(KFILDO,409) (JMIN(J),J=1,LX) +C409 FORMAT(/' '20I6) +C + 410 RETURN + END + diff --git a/WPS/ungrib/src/ngl/g2/simpack.f b/WPS/ungrib/src/ngl/g2/simpack.f new file mode 100755 index 00000000..db727c70 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/simpack.f @@ -0,0 +1,191 @@ + subroutine simpack(fld,ndpts,idrstmpl,cpack,lcpack) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: simpack +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-06-21 +! +! ABSTRACT: This subroutine packs up a data field using a simple +! packing algorithm as defined in the GRIB2 documention. It +! also fills in GRIB2 Data Representation Template 5.0 with the +! appropriate values. +! +! PROGRAM HISTORY LOG: +! 2000-06-21 Gilbert +! 2011-10-24 Boi Vuong Added variable rmin4 for 4 byte float +! +! USAGE: CALL simpack(fld,ndpts,idrstmpl,cpack,lcpack) +! INPUT ARGUMENT LIST: +! fld() - Contains the data values to pack +! ndpts - The number of data values in array fld() +! idrstmpl - Contains the array of values for Data Representation +! Template 5.0 +! (1) = Reference value - ignored on input +! (2) = Binary Scale Factor +! (3) = Decimal Scale Factor +! (4) = Number of bits used to pack data, if value is +! > 0 and <= 31. +! If this input value is 0 or outside above range +! then the num of bits is calculated based on given +! data and scale factors. +! (5) = Original field type - currently ignored on input +! Data values assumed to be reals. +! +! OUTPUT ARGUMENT LIST: +! idrstmpl - Contains the array of values for Data Representation +! Template 5.0 +! (1) = Reference value - set by simpack routine. +! (2) = Binary Scale Factor - unchanged from input +! (3) = Decimal Scale Factor - unchanged from input +! (4) = Number of bits used to pack data, unchanged from +! input if value is between 0 and 31. +! If this input value is 0 or outside above range +! then the num of bits is calculated based on given +! data and scale factors. +! (5) = Original field type - currently set = 0 on output. +! Data values assumed to be reals. +! cpack - The packed data field (character*1 array) +! lcpack - length of packed field cpack(). +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: XL Fortran 90 +! MACHINE: IBM SP +! +!$$$ + use intmath + integer,intent(in) :: ndpts + real,intent(in) :: fld(ndpts) + character(len=1),intent(out) :: cpack(*) + integer,intent(inout) :: idrstmpl(*) + integer,intent(out) :: lcpack + + real(4) :: ref,rmin4 +C real(8) :: rmin,rmax + + integer(4) :: iref + integer :: ifld(ndpts) + integer,parameter :: zero=0 + + bscale=2.0**real(-idrstmpl(2)) + dscale=10.0**real(idrstmpl(3)) + if (idrstmpl(4).le.0.OR.idrstmpl(4).gt.31) then + nbits=0 + else + nbits=idrstmpl(4) + endif +! +! Find max and min values in the data +! + if(ndpts<1) then + rmin=0 + rmax=0 + else + rmax=fld(1) + rmin=fld(1) + do j=2,ndpts + if (fld(j).gt.rmax) rmax=fld(j) + if (fld(j).lt.rmin) rmin=fld(j) + enddo + endif +! +! If max and min values are not equal, pack up field. +! If they are equal, we have a constant field, and the reference +! value (rmin) is the value for each point in the field and +! set nbits to 0. +! + if (rmin.ne.rmax) then + ! + ! Determine which algorithm to use based on user-supplied + ! binary scale factor and number of bits. + ! + if (nbits.eq.0.AND.idrstmpl(2).eq.0) then + ! + ! No binary scaling and calculate minumum number of + ! bits in which the data will fit. + ! + imin=nint(rmin*dscale) + imax=nint(rmax*dscale) + maxdif=imax-imin + temp=i1log2(maxdif+1) + nbits=ceiling(temp) + rmin=real(imin) + ! scale data + do j=1,ndpts + ifld(j)=nint(fld(j)*dscale)-imin + enddo + elseif (nbits.ne.0.AND.idrstmpl(2).eq.0) then + ! + ! Use minimum number of bits specified by user and + ! adjust binary scaling factor to accomodate data. + ! + rmin=rmin*dscale + rmax=rmax*dscale + maxnum=(2**nbits)-1 + temp=ilog2(nint(real(maxnum)/(rmax-rmin))) + idrstmpl(2)=ceiling(-1.0*temp) + bscale=2.0**real(-idrstmpl(2)) + ! scale data + do j=1,ndpts + ifld(j)=max(0,nint(((fld(j)*dscale)-rmin)*bscale)) + enddo + elseif (nbits.eq.0.AND.idrstmpl(2).ne.0) then + ! + ! Use binary scaling factor and calculate minumum number of + ! bits in which the data will fit. + ! + rmin=rmin*dscale + rmax=rmax*dscale + maxdif=nint((rmax-rmin)*bscale) + temp=i1log2(maxdif) + nbits=ceiling(temp) + ! scale data + do j=1,ndpts + ifld(j)=max(0,nint(((fld(j)*dscale)-rmin)*bscale)) + enddo + elseif (nbits.ne.0.AND.idrstmpl(2).ne.0) then + ! + ! Use binary scaling factor and use minumum number of + ! bits specified by user. Dangerous - may loose + ! information if binary scale factor and nbits not set + ! properly by user. + ! + rmin=rmin*dscale + ! scale data + do j=1,ndpts + ifld(j)=max(0,nint(((fld(j)*dscale)-rmin)*bscale)) + enddo + endif + ! + ! Pack data, Pad last octet with Zeros, if necessary, + ! and calculate the length of the packed data in bytes + ! + call sbytes(cpack,ifld,0,nbits,0,ndpts) + nbittot=nbits*ndpts + left=8-mod(nbittot,8) + if (left.ne.8) then + call sbyte(cpack,zero,nbittot,left) ! Pad with zeros to fill Octet + nbittot=nbittot+left + endif + lcpack=nbittot/8 + + else + !print *,'nbits 0' + nbits=0 + lcpack=0 + endif + +! +! Fill in ref value and number of bits in Template 5.0 +! + rmin4 = rmin + call mkieee(rmin4,ref,1) ! ensure reference value is IEEE format + !print *,'SAGref = ',rmin,ref +! call gbyte(ref,idrstmpl(1),0,32) + iref=transfer(ref,iref) + idrstmpl(1)=iref + idrstmpl(4)=nbits + idrstmpl(5)=0 ! original data were reals + + return + end diff --git a/WPS/ungrib/src/ngl/g2/simunpack.f b/WPS/ungrib/src/ngl/g2/simunpack.f new file mode 100755 index 00000000..612a2835 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/simunpack.f @@ -0,0 +1,65 @@ + subroutine simunpack(cpack,len,idrstmpl,ndpts,fld) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: simunpack +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2000-06-21 +! +! ABSTRACT: This subroutine unpacks a data field that was packed using a +! simple packing algorithm as defined in the GRIB2 documention, +! using info from the GRIB2 Data Representation Template 5.0. +! +! PROGRAM HISTORY LOG: +! 2000-06-21 Gilbert +! +! USAGE: CALL simunpack(cpack,len,idrstmpl,ndpts,fld) +! INPUT ARGUMENT LIST: +! cpack - The packed data field (character*1 array) +! len - length of packed field cpack(). +! idrstmpl - Contains the array of values for Data Representation +! Template 5.0 +! ndpts - The number of data values to unpack +! +! OUTPUT ARGUMENT LIST: +! fld() - Contains the unpacked data values +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: XL Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cpack(len) + integer,intent(in) :: ndpts,len + integer,intent(in) :: idrstmpl(*) + real,intent(out) :: fld(ndpts) + + integer :: ifld(ndpts) + integer(4) :: ieee + real :: ref,bscale,dscale + + ieee = idrstmpl(1) + call rdieee(ieee,ref,1) + bscale = 2.0**real(idrstmpl(2)) + dscale = 10.0**real(-idrstmpl(3)) + nbits = idrstmpl(4) + itype = idrstmpl(5) +! +! if nbits equals 0, we have a constant field where the reference value +! is the data value at each gridpoint +! + if (nbits.ne.0) then + call gbytes(cpack,ifld,0,nbits,0,ndpts) + do j=1,ndpts + fld(j)=((real(ifld(j))*bscale)+ref)*dscale + enddo + else + do j=1,ndpts + fld(j)=ref + enddo + endif + + + return + end diff --git a/WPS/ungrib/src/ngl/g2/skgb.f b/WPS/ungrib/src/ngl/g2/skgb.f new file mode 100755 index 00000000..2de10b04 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/skgb.f @@ -0,0 +1,79 @@ +C----------------------------------------------------------------------- + SUBROUTINE SKGB(LUGB,ISEEK,MSEEK,LSKIP,LGRIB) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: SKGB SEARCH FOR NEXT GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 93-11-22 +C +C ABSTRACT: THIS SUBPROGRAM SEARCHES A FILE FOR THE NEXT GRIB 1 MESSAGE. +C A GRIB 1 MESSAGE IS IDENTIFIED BY ITS INDICATOR SECTION, I.E. +C AN 8-BYTE SEQUENCE WITH 'GRIB' IN BYTES 1-4 AND 1 IN BYTE 8. +C IF FOUND, THE LENGTH OF THE MESSAGE IS DECODED FROM BYTES 5-7. +C THE SEARCH IS DONE OVER A GIVEN SECTION OF THE FILE. +C THE SEARCH IS TERMINATED IF AN EOF OR I/O ERROR IS ENCOUNTERED. +C +C PROGRAM HISTORY LOG: +C 93-11-22 IREDELL +C 95-10-31 IREDELL ADD CALL TO BAREAD +C 97-03-14 IREDELL CHECK FOR '7777' +C 2001-12-05 GILBERT MODIFIED TO ALSO LOOK FOR GRIB2 MESSAGES +C 2009-12-14 VUONG MODIFIED TO INCREASE LENGTH OF SEEK (512) +C +C USAGE: CALL SKGB(LUGB,ISEEK,MSEEK,LSKIP,LGRIB) +C INPUT ARGUMENTS: +C LUGB INTEGER LOGICAL UNIT OF INPUT GRIB FILE +C ISEEK INTEGER NUMBER OF BYTES TO SKIP BEFORE SEARCH +C MSEEK INTEGER MAXIMUM NUMBER OF BYTES TO SEARCH +C OUTPUT ARGUMENTS: +C LSKIP INTEGER NUMBER OF BYTES TO SKIP BEFORE MESSAGE +C LGRIB INTEGER NUMBER OF BYTES IN MESSAGE (0 IF NOT FOUND) +C +C SUBPROGRAMS CALLED: +C BAREAD BYTE-ADDRESSABLE READ +C GBYTE GET INTEGER DATA FROM BYTES +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN +C +C$$$ + PARAMETER(LSEEK=512) + CHARACTER Z(LSEEK) + CHARACTER Z4(4) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + LGRIB=0 + KS=ISEEK + KN=MIN(LSEEK,MSEEK) + KZ=LSEEK +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C LOOP UNTIL GRIB MESSAGE IS FOUND + DOWHILE(LGRIB.EQ.0.AND.KN.GE.8.AND.KZ.EQ.LSEEK) +C READ PARTIAL SECTION + CALL BAREAD(LUGB,KS,KN,KZ,Z) + KM=KZ-8+1 + K=0 +C LOOK FOR 'GRIB...1' IN PARTIAL SECTION + DOWHILE(LGRIB.EQ.0.AND.K.LT.KM) + CALL GBYTE(Z,I4,(K+0)*8,4*8) + CALL GBYTE(Z,I1,(K+7)*8,1*8) + IF(I4.EQ.1196575042.AND.(I1.EQ.1.OR.I1.EQ.2)) THEN +C LOOK FOR '7777' AT END OF GRIB MESSAGE + IF (I1.EQ.1) CALL GBYTE(Z,KG,(K+4)*8,3*8) + IF (I1.EQ.2) CALL GBYTE(Z,KG,(K+12)*8,4*8) + CALL BAREAD(LUGB,KS+K+KG-4,4,K4,Z4) + IF(K4.EQ.4) THEN + CALL GBYTE(Z4,I4,0,4*8) + IF(I4.EQ.926365495) THEN +C GRIB MESSAGE FOUND + LSKIP=KS+K + LGRIB=KG + ENDIF + ENDIF + ENDIF + K=K+1 + ENDDO + KS=KS+KM + KN=MIN(LSEEK,ISEEK+MSEEK-KS) + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/g2/specpack.f b/WPS/ungrib/src/ngl/g2/specpack.f new file mode 100755 index 00000000..eb24c719 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/specpack.f @@ -0,0 +1,124 @@ + subroutine specpack(fld,ndpts,JJ,KK,MM,idrstmpl,cpack,lcpack) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: specpack +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-12-19 +! +! ABSTRACT: This subroutine packs a spectral data field using the complex +! packing algorithm for spherical harmonic data as +! defined in the GRIB2 Data Representation Template 5.51. +! +! PROGRAM HISTORY LOG: +! 2002-12-19 Gilbert +! +! USAGE: CALL specpack(fld,ndpts,JJ,KK,MM,idrstmpl,cpack,lcpack) +! INPUT ARGUMENT LIST: +! fld() - Contains the packed data values +! ndpts - The number of data values to pack +! JJ - J - pentagonal resolution parameter +! KK - K - pentagonal resolution parameter +! MM - M - pentagonal resolution parameter +! idrstmpl - Contains the array of values for Data Representation +! Template 5.51 +! +! OUTPUT ARGUMENT LIST: +! cpack - The packed data field (character*1 array) +! lcpack - length of packed field cpack(). +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: XL Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + real,intent(in) :: fld(ndpts) + integer,intent(in) :: ndpts,JJ,KK,MM + integer,intent(inout) :: idrstmpl(*) + character(len=1),intent(out) :: cpack(*) + integer,intent(out) :: lcpack + + integer :: ifld(ndpts),Ts,tmplsim(5) + real :: bscale,dscale,unpk(ndpts),tfld(ndpts) + real,allocatable :: pscale(:) + + bscale = 2.0**real(-idrstmpl(2)) + dscale = 10.0**real(idrstmpl(3)) + nbits = idrstmpl(4) + Js=idrstmpl(6) + Ks=idrstmpl(7) + Ms=idrstmpl(8) + Ts=idrstmpl(9) + +! +! Calculate Laplacian scaling factors for each possible wave number. +! + allocate(pscale(JJ+MM)) + tscale=real(idrstmpl(5))*1E-6 + do n=Js,JJ+MM + pscale(n)=real(n*(n+1))**(tscale) + enddo +! +! Separate spectral coeffs into two lists; one to contain unpacked +! values within the sub-spectrum Js, Ks, Ms, and the other with values +! outside of the sub-spectrum to be packed. +! + inc=1 + incu=1 + incp=1 + do m=0,MM + Nm=JJ ! triangular or trapezoidal + if ( KK .eq. JJ+MM ) Nm=JJ+m ! rhombodial + Ns=Js ! triangular or trapezoidal + if ( Ks .eq. Js+Ms ) Ns=Js+m ! rhombodial + do n=m,Nm + if (n.le.Ns .AND. m.le.Ms) then ! save unpacked value + unpk(incu)=fld(inc) ! real part + unpk(incu+1)=fld(inc+1) ! imaginary part + inc=inc+2 + incu=incu+2 + else ! Save value to be packed and scale + ! Laplacian scale factor + tfld(incp)=fld(inc)*pscale(n) ! real part + tfld(incp+1)=fld(inc+1)*pscale(n) ! imaginary part + inc=inc+2 + incp=incp+2 + endif + enddo + enddo + + deallocate(pscale) + + incu=incu-1 + if (incu .ne. Ts) then + print *,'specpack: Incorrect number of unpacked values ', + & 'given:',Ts + print *,'specpack: Resetting idrstmpl(9) to ',incu + Ts=incu + endif +! +! Add unpacked values to the packed data array in 32-bit IEEE format +! + call mkieee(unpk,cpack,Ts) + ipos=4*Ts +! +! Scale and pack the rest of the coefficients +! + tmplsim(2)=idrstmpl(2) + tmplsim(3)=idrstmpl(3) + tmplsim(4)=idrstmpl(4) + call simpack(tfld,ndpts-Ts,tmplsim,cpack(ipos+1),lcpack) + lcpack=lcpack+ipos +! +! Fill in Template 5.51 +! + idrstmpl(1)=tmplsim(1) + idrstmpl(2)=tmplsim(2) + idrstmpl(3)=tmplsim(3) + idrstmpl(4)=tmplsim(4) + idrstmpl(9)=Ts + idrstmpl(10)=1 ! Unpacked spectral data is 32-bit IEEE + + return + end diff --git a/WPS/ungrib/src/ngl/g2/specunpack.f b/WPS/ungrib/src/ngl/g2/specunpack.f new file mode 100755 index 00000000..744e5ae6 --- /dev/null +++ b/WPS/ungrib/src/ngl/g2/specunpack.f @@ -0,0 +1,107 @@ + subroutine specunpack(cpack,len,idrstmpl,ndpts,JJ,KK,MM,fld) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: specunpack +! PRGMMR: Gilbert ORG: W/NP11 DATE: 2002-12-19 +! +! ABSTRACT: This subroutine unpacks a spectral data field that was packed +! using the complex packing algorithm for spherical harmonic data as +! defined in the GRIB2 documention, +! using info from the GRIB2 Data Representation Template 5.51. +! +! PROGRAM HISTORY LOG: +! 2002-12-19 Gilbert +! +! USAGE: CALL specunpack(cpack,len,idrstmpl,ndpts,JJ,KK,MM,fld) +! INPUT ARGUMENT LIST: +! cpack - The packed data field (character*1 array) +! len - length of packed field cpack(). +! idrstmpl - Contains the array of values for Data Representation +! Template 5.51 +! ndpts - The number of data values to unpack +! JJ - J - pentagonal resolution parameter +! KK - K - pentagonal resolution parameter +! MM - M - pentagonal resolution parameter +! +! OUTPUT ARGUMENT LIST: +! fld() - Contains the unpacked data values +! +! REMARKS: None +! +! ATTRIBUTES: +! LANGUAGE: XL Fortran 90 +! MACHINE: IBM SP +! +!$$$ + + character(len=1),intent(in) :: cpack(len) + integer,intent(in) :: ndpts,len,JJ,KK,MM + integer,intent(in) :: idrstmpl(*) + real,intent(out) :: fld(ndpts) + + integer :: ifld(ndpts),Ts + integer(4) :: ieee + real :: ref,bscale,dscale,unpk(ndpts) + real,allocatable :: pscale(:) + + ieee = idrstmpl(1) + call rdieee(ieee,ref,1) + bscale = 2.0**real(idrstmpl(2)) + dscale = 10.0**real(-idrstmpl(3)) + nbits = idrstmpl(4) + Js=idrstmpl(6) + Ks=idrstmpl(7) + Ms=idrstmpl(8) + Ts=idrstmpl(9) + + if (idrstmpl(10).eq.1) then ! unpacked floats are 32-bit IEEE + !call gbytes(cpack,ifld,0,32,0,Ts) + call rdieee(cpack,unpk,Ts) ! read IEEE unpacked floats + iofst=32*Ts + call gbytes(cpack,ifld,iofst,nbits,0,ndpts-Ts) ! unpack scaled data +! +! Calculate Laplacian scaling factors for each possible wave number. +! + allocate(pscale(JJ+MM)) + tscale=real(idrstmpl(5))*1E-6 + do n=Js,JJ+MM + pscale(n)=real(n*(n+1))**(-tscale) + enddo +! +! Assemble spectral coeffs back to original order. +! + inc=1 + incu=1 + incp=1 + do m=0,MM + Nm=JJ ! triangular or trapezoidal + if ( KK .eq. JJ+MM ) Nm=JJ+m ! rhombodial + Ns=Js ! triangular or trapezoidal + if ( Ks .eq. Js+Ms ) Ns=Js+m ! rhombodial + do n=m,Nm + if (n.le.Ns .AND. m.le.Ms) then ! grab unpacked value + fld(inc)=unpk(incu) ! real part + fld(inc+1)=unpk(incu+1) ! imaginary part + inc=inc+2 + incu=incu+2 + else ! Calc coeff from packed value + fld(inc)=((real(ifld(incp))*bscale)+ref)* + & dscale*pscale(n) ! real part + fld(inc+1)=((real(ifld(incp+1))*bscale)+ref)* + & dscale*pscale(n) ! imaginary part + inc=inc+2 + incp=incp+2 + endif + enddo + enddo + + deallocate(pscale) + + else + print *,'specunpack: Cannot handle 64 or 128-bit floats.' + fld=0.0 + return + endif + + return + end diff --git a/WPS/ungrib/src/ngl/w3/CHANGES b/WPS/ungrib/src/ngl/w3/CHANGES new file mode 100755 index 00000000..4df1a668 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/CHANGES @@ -0,0 +1,40 @@ + +w3lib-1.1 - August 2003 - Original version + +w3lib-1.2 - July 2004 - Added new grids + +w3lib-1.3 - December 2006 - Added new grids and corrected the LAT/LON increment + +w3lib-1.4 - May 2007 - Update routines (w3fi71.f and w3fi63.f) to add + new data represent type 204 (CURVILINEAR ORTHOGONAL GRID) + and corrected the LAT/LON increment and Added new + grids + +w3lib-1.5 - NOV 2007 - Update routines (w3fi71.f and w3fi63.f) to add + new grids (10, 99, 150, 151,197) and changed grid 198 + from Arkawa Staggered E-grid to Polar Stereographic grid. + +w3lib-1.6 - JAN 2008 - Update routines (w3fi71.f and w3fi63.f) to add + new grids 195 and Changed grid 196 (from Arakawa-E to Mercator) + +w3lib-1.7 - JUN 2009 - Update routines (w3fi63.f) to handle grid 45 + +w3lib-1.8 - JAN 2010 - Update routines (w3fi71.f and w3fi63.f) to add + new grids 139 and 140 + +w3lib-1.9 - AUG 2010 - added new grid 184, 199, 83 and + redefined grid 90 for new rtma conus 1.27-km + redefined grid 91 for new rtma alaska 2.976-km + redefined grid 92 for new rtma alaska 1.488-km + +w3lib-2.0 - Jan 2011 - CHANGED GRID 94 TO ALASKA 6KM STAGGERED B-GRID + CHANGED GRID 95 TO PUERTO RICO 3KM STAGGERED B-GRID + CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID + CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID + CHANGED GRID 97 TO CONUS 4KM STAGGERED B-GRID + CHANGED GRID 99 TO NAM 12KM STAGGERED B-GRID + ADDED GRID 179 (12 KM POLAR STEREOGRAPHIC OVER NORTH AMERICA) + CHANGED GRID 194 TO 3KM MERCATOR GRID OVER PUERTO RICO + CORRECTED LATITUDE OF SW CORNER POINT OF GRID 151 + FIX ALLOCATION OF ARRAY BMS + ADD GRID 205 - ROTATED LAT/LON A,B,C,D STAGGERS diff --git a/WPS/ungrib/src/ngl/w3/Makefile b/WPS/ungrib/src/ngl/w3/Makefile new file mode 100644 index 00000000..a0455f89 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/Makefile @@ -0,0 +1,49 @@ +include $(DEV_TOP)/configure.wps + +LIB = libw3.a + +# Make sure one of the following options appears in your CFLAGS +# variable to indicate which system you are on. +# -DLINUX, -DSGI, -DHP, -DCRAY90, -DIBM4, -DIBM8, -DLINUXF90 + +OBJ_MOD = bacio_module.o + +OBJS = getgb.o getgbmh.o putgbex.o w3fi73.o \ + getgb1r.o getgbmp.o putgbn.o w3fi74.o \ + getgb1re.o getgbp.o r63w72.o w3fi75.o \ + getgb1s.o getgi.o sbyte.o w3fi76.o \ + getgbe.o getgir.o sbytes.o w3fi82.o \ + getgbeh.o idsdef.o w3fi83.o \ + getgbem.o iw3jdn.o w3difdat.o w3fs26.o \ + getgbemh.o ixgb.o w3doxdat.o w3log.o \ + getgbemp.o lengds.o w3fi01.o w3movdat.o \ + getgbens.o pdsens.o w3fi58.o w3reddat.o \ + getgbep.o pdseup.o w3fi59.o w3tagb.o \ + errmsg.o getgbex.o putgb.o w3fi63.o \ + gbytes.o getgbexm.o putgbe.o w3fi68.o \ + gbytes_char.o getgbh.o putgben.o \ + getbit.o getgbm.o putgbens.o w3fi72.o \ + fparsei.o fparser.o instrument.o \ + start.o summary.o w3utcdat.o w3fs21.o \ + w3locdat.o w3fi71.o baciof.o + +OBJS_CC = bacio.v1.3.o errexit.o + +SRC = $(OBJ_MOD:.o=.f) $(OBJS:.o=.f) $(OBJS_CC:.o=.c) + +all: $(LIB) + +$(LIB): $(OBJ_MOD) $(OBJS) $(OBJS_CC) + $(AR) $(ARFLAGS) $(LIB) $(OBJ_MOD) $(OBJS) $(OBJS_CC) + $(RANLIB) $(LIB) + +clean: + $(RM) $(OBJ_MOD) $(OBJS) $(OBJS_CC) *.mod *.a + +.f.o: + $(RM) $*.o + $(FC) $(F77FLAGS) -c $< + +.c.o: + $(RM) $*.o + $(CC) $(CFLAGS) $(CPPFLAGS) -c $< diff --git a/WPS/ungrib/src/ngl/w3/README b/WPS/ungrib/src/ngl/w3/README new file mode 100644 index 00000000..73625310 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/README @@ -0,0 +1,21 @@ + Jul 29, 2004 + W/NP11:SAG + +W3lib Library. + +This library contains Fortran 90 decoder/encoder +routines for GRIB edition 1, general date manipulation +routines, and a Fortran 90 interface to "C" +language I/O routines. The user API for the GRIB1 routines +is described in file "grib1.doc". + +Some Fortran routines call "C" functions, which must +follow a specific symbol naming convention used by your +machine/loader to be linked successfully. +If you are having trouble linking to the routines +in this library, please make sure the appropriate +machine is defined as an option in the CFLAGS +variable in the Makefile. See the first few lines +of the Makefile for valid options. +Recompile the library. + diff --git a/WPS/ungrib/src/ngl/w3/bacio.v1.3.c b/WPS/ungrib/src/ngl/w3/bacio.v1.3.c new file mode 100755 index 00000000..0c30e0a5 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/bacio.v1.3.c @@ -0,0 +1,571 @@ +/* Fortran-callable routines to read and write characther (ba_cio) and */ +/* numeric (banio) data byte addressably */ +/* Robert Grumbine 16 March 1998 */ +/* v1.1: Put diagnostic output under control of define VERBOSE or QUIET */ +/* Add option of non-seeking read/write */ +/* Return code for fewer data read/written than requested */ +/* v1.2: Add cray compatibility 20 April 1998 */ + +#include +#include +#include +#include +#ifndef _WIN32 +# include +#else +# define S_IRWXU 00700 +# define S_IRWXG 00070 +# define S_IRWXO 00007 +#endif +#ifdef MACOS +#include +#else +#include +#endif +#include +#include + +/* Include the C library file for definition/control */ +/* Things that might be changed for new systems are there. */ +/* This source file should not (need to) be edited, merely recompiled */ +#include "clib.h" + + +/* Return Codes: */ +/* 0 All was well */ +/* -1 Tried to open read only _and_ write only */ +/* -2 Tried to read and write in the same call */ +/* -3 Internal failure in name processing */ +/* -4 Failure in opening file */ +/* -5 Tried to read on a write-only file */ +/* -6 Failed in read to find the 'start' location */ +/* -7 Tried to write to a read only file */ +/* -8 Failed in write to find the 'start' location */ +/* -9 Error in close */ +/* -10 Read or wrote fewer data than requested */ + +/* Note: In your Fortran code, call ba_cio, not ba_cio_. */ +/*int ba_cio_(int * mode, int * start, int * size, int * no, int * nactual, */ +/* int * fdes, const char *fname, char *data, int namelen, */ +/* int datanamelen) */ +/* Arguments: */ +/* Mode is the integer specifying operations to be performed */ +/* see the clib.inc file for the values. Mode is obtained */ +/* by adding together the values corresponding to the operations */ +/* The best method is to include the clib.inc file and refer to the */ +/* names for the operations rather than rely on hard-coded values */ +/* Start is the byte number to start your operation from. 0 is the first */ +/* byte in the file, not 1. */ +/* Newpos is the position in the file after a read or write has been */ +/* performed. You'll need this if you're doing 'seeking' read/write */ +/* Size is the size of the objects you are trying to read. Rely on the */ +/* values in the locale.inc file. Types are CHARACTER, INTEGER, REAL, */ +/* COMPLEX. Specify the correct value by using SIZEOF_type, where type */ +/* is one of these. (After having included the locale.inc file) */ +/* no is the number of things to read or write (characters, integers, */ +/* whatever) */ +/* nactual is the number of things actually read or written. Check that */ +/* you got what you wanted. */ +/* fdes is an integer 'file descriptor'. This is not a Fortran Unit Number */ +/* You can use it, however, to refer to files you've previously opened. */ +/* fname is the name of the file. This only needs to be defined when you */ +/* are opening a file. It must be (on the Fortran side) declared as */ +/* CHARACTER*N, where N is a length greater than or equal to the length */ +/* of the file name. CHARACTER*1 fname[80] (for example) will fail. */ +/* data is the name of the entity (variable, vector, array) that you want */ +/* to write data out from or read it in to. The fact that C is declaring */ +/* it to be a char * does not affect your fortran. */ +/* namelen - Do NOT specify this. It is created automagically by the */ +/* Fortran compiler */ +/* datanamelen - Ditto */ + + +/* What is going on here is that although the Fortran caller will always */ +/* be calling ba_cio, the called C routine name will change from system */ +/* to system. */ +#if defined _UNDERSCORE + int ba_cio_ + (int * mode, int * start, int *newpos, int * size, int * no, + int * nactual, int * fdes, const char *fname, char *datary, + int namelen, int datanamelen) { +#elif defined _DOUBLEUNDERSCORE + int ba_cio__ + (int * mode, int * start, int *newpos, int * size, int * no, + int * nactual, int * fdes, const char *fname, char *datary, + int namelen, int datanamelen) { +#else + int ba_cio + (int * mode, int * start, int *newpos, int * size, int * no, + int * nactual, int * fdes, const char *fname, char *datary, + int namelen, int datanamelen) { +#endif + int i, j, jret, seekret; + char *realname, *tempchar; + int tcharval; + size_t count; + +/* Initialization(s) */ + *nactual = 0; + +/* Check for illegal combinations of options */ + if (( BAOPEN_RONLY & *mode) && + ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { + #ifdef VERBOSE + printf("illegal -- trying to open both read only and write only\n"); + #endif + return -1; + } + if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) { + #ifdef VERBOSE + printf("illegal -- trying to both read and write in the same call\n"); + #endif + return -2; + } + +/* This section handles Fortran to C translation of strings so as to */ +/* be able to open the files Fortran is expecting to be opened. */ + #ifdef CRAY90 + namelen = _fcdlen(fcd_fname); + fname = _fcdtocp(fcd_fname); + #endif + if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || + (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || + (BAOPEN_RW & *mode) ) { + #ifdef VERBOSE + printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout); + printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout); + #endif + realname = (char *) malloc( namelen * sizeof(char) ) ; + if (realname == NULL) { + #ifdef VERBOSE + printf("failed to mallocate realname %d = namelen\n", namelen); + fflush(stdout); + #endif + return -3; + } + tempchar = (char *) malloc(sizeof(char) * 1 ) ; + i = 0; + j = 0; + *tempchar = fname[i]; + tcharval = *tempchar; + while (i == j && i < namelen ) { + fflush(stdout); + if ( isgraph(tcharval) ) { + realname[j] = fname[i]; + j += 1; + } + i += 1; + *tempchar = fname[i]; + tcharval = *tempchar; + } + #ifdef VERBOSE + printf("i,j = %d %d\n",i,j); fflush(stdout); + #endif + realname[j] = '\0'; + } + +/* Open files with correct read/write and file permission. */ + if (BAOPEN_RONLY & *mode) { + #ifdef VERBOSE + printf("open read only %s\n", realname); + #endif + *fdes = open(realname, O_RDONLY , S_IRWXU | S_IRWXG | S_IRWXO ); + } + else if (BAOPEN_WONLY & *mode ) { + #ifdef VERBOSE + printf("open write only %s\n", realname); + #endif + *fdes = open(realname, O_WRONLY | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); + } + else if (BAOPEN_WONLY_TRUNC & *mode ) { + #ifdef VERBOSE + printf("open write only with truncation %s\n", realname); + #endif + *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRWXU | S_IRWXG | S_IRWXO ); + } + else if (BAOPEN_WONLY_APPEND & *mode ) { + #ifdef VERBOSE + printf("open write only with append %s\n", realname); + #endif + *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRWXU | S_IRWXG | S_IRWXO ); + } + else if (BAOPEN_RW & *mode) { + #ifdef VERBOSE + printf("open read-write %s\n", realname); + #endif + *fdes = open(realname, O_RDWR | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); + } + else { + #ifdef VERBOSE + printf("no openings\n"); + #endif + } + if (*fdes < 0) { + #ifdef VERBOSE + printf("error in file descriptor! *fdes %d\n", *fdes); + #endif + return -4; + } + else { + #ifdef VERBOSE + printf("file descriptor = %d\n",*fdes ); + #endif + } + + +/* Read data as requested */ + if (BAREAD & *mode && + ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { + #ifdef VERBOSE + printf("Error, trying to read while in write only mode!\n"); + #endif + return -5; + } + else if (BAREAD & *mode ) { + /* Read in some data */ + if (! (*mode & NOSEEK) ) { + seekret = lseek(*fdes, *start, SEEK_SET); + if (seekret == -1) { + #ifdef VERBOSE + printf("error in seeking to %d\n",*start); + #endif + return -6; + } + #ifdef VERBOSE + else { + printf("Seek successful, seek ret %d, start %d\n", seekret, *start); + } + #endif + } + #ifdef CRAY90 + datary = _fcdtocp(fcd_datary); + #endif + if (datary == NULL) { + printf("Massive catastrophe -- datary pointer is NULL\n"); + return -666; + } + #ifdef VERBOSE + printf("file descriptor, datary = %d %d\n", *fdes, (int) datary); + #endif + count = (size_t) *no; + jret = read(*fdes, (void *) datary, count); + if (jret != *no) { + #ifdef VERBOSE + printf("did not read in the requested number of bytes\n"); + printf("read in %d bytes instead of %d \n",jret, *no); + #endif + } + else { + #ifdef VERBOSE + printf("read in %d bytes requested \n", *no); + #endif + } + *nactual = jret; + *newpos = *start + jret; + } +/* Done with reading */ + +/* See if we should be writing */ + if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) { + #ifdef VERBOSE + printf("Trying to write on a read only file \n"); + #endif + return -7; + } + else if ( BAWRITE & *mode ) { + if (! (*mode & NOSEEK) ) { + seekret = lseek(*fdes, *start, SEEK_SET); + if (seekret == -1) { + #ifdef VERBOSE + printf("error in seeking to %d\n",*start); + #endif + return -8; + } + } + #ifdef CRAY90 + datary = _fcdtocp(fcd_datary); + #endif + if (datary == NULL) { + printf("Massive catastrophe -- datary pointer is NULL\n"); + return -666; + } + #ifdef VERBOSE + printf("write file descriptor, datary = %d %d\n", *fdes, (int) datary); + #endif + count = (size_t) *no; + jret = write(*fdes, (void *) datary, count); + if (jret != *no) { + #ifdef VERBOSE + printf("did not write out the requested number of bytes\n"); + printf("wrote %d bytes instead\n", jret); + #endif + *nactual = jret; + *newpos = *start + jret; + } + else { + #ifdef VERBOSE + printf("wrote %d bytes \n", jret); + #endif + *nactual = jret; + *newpos = *start + jret; + } + } +/* Done with writing */ + + +/* Close file if requested */ + if (BACLOSE & *mode ) { + jret = close(*fdes); + if (jret != 0) { + #ifdef VERBOSE + printf("close failed! jret = %d\n",jret); + #endif + return -9; + } + } +/* Done closing */ + +/* Check that if we were reading or writing, that we actually got what */ +/* we expected, else return a -10. Return 0 (success) if we're here */ +/* and weren't reading or writing */ + if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) { + return -10; + } + else { + return 0; + } +} +#if defined _UNDERSCORE + int banio_ + (int * mode, int * start, int *newpos, int * size, int * no, + int * nactual, int * fdes, const char *fname, char *datary, + int namelen ) { +#elif defined _DOUBLEUNDERSCORE + int banio__ + (int * mode, int * start, int *newpos, int * size, int * no, + int * nactual, int * fdes, const char *fname, char *datary, + int namelen ) { +#else + int banio + (int * mode, int * start, int *newpos, int * size, int * no, + int * nactual, int * fdes, const char *fname, char *datary, + int namelen ) { +#endif + int i, j, jret, seekret; + char *realname, *tempchar; + int tcharval; + +/* Initialization(s) */ + *nactual = 0; + +/* Check for illegal combinations of options */ + if (( BAOPEN_RONLY & *mode) && + ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { + #ifdef VERBOSE + printf("illegal -- trying to open both read only and write only\n"); + #endif + return -1; + } + if ( (BAREAD & *mode ) && (BAWRITE & *mode) ) { + #ifdef VERBOSE + printf("illegal -- trying to both read and write in the same call\n"); + #endif + return -2; + } + +/* This section handles Fortran to C translation of strings so as to */ +/* be able to open the files Fortran is expecting to be opened. */ + #ifdef CRAY90 + namelen = _fcdlen(fcd_fname); + fname = _fcdtocp(fcd_fname); + #endif + if ( (BAOPEN_RONLY & *mode) || (BAOPEN_WONLY & *mode) || + (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) || + (BAOPEN_RW & *mode) ) { + #ifdef VERBOSE + printf("Will be opening a file %s %d\n", fname, namelen); fflush(stdout); + printf("Strlen %d namelen %d\n", strlen(fname), namelen); fflush(stdout); + #endif + realname = (char *) malloc( namelen * sizeof(char) ) ; + if (realname == NULL) { + #ifdef VERBOSE + printf("failed to mallocate realname %d = namelen\n", namelen); + fflush(stdout); + #endif + return -3; + } + tempchar = (char *) malloc(sizeof(char) * 1 ) ; + i = 0; + j = 0; + *tempchar = fname[i]; + tcharval = *tempchar; + while (i == j && i < namelen ) { + fflush(stdout); + if ( isgraph(tcharval) ) { + realname[j] = fname[i]; + j += 1; + } + i += 1; + *tempchar = fname[i]; + tcharval = *tempchar; + } + #ifdef VERBOSE + printf("i,j = %d %d\n",i,j); fflush(stdout); + #endif + realname[j] = '\0'; + } + +/* Open files with correct read/write and file permission. */ + if (BAOPEN_RONLY & *mode) { + #ifdef VERBOSE + printf("open read only %s\n", realname); + #endif + *fdes = open(realname, O_RDONLY , S_IRWXU | S_IRWXG | S_IRWXO ); + } + else if (BAOPEN_WONLY & *mode ) { + #ifdef VERBOSE + printf("open write only %s\n", realname); + #endif + *fdes = open(realname, O_WRONLY | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); + } + else if (BAOPEN_WONLY_TRUNC & *mode ) { + #ifdef VERBOSE + printf("open write only with truncation %s\n", realname); + #endif + *fdes = open(realname, O_WRONLY | O_CREAT | O_TRUNC , S_IRWXU | S_IRWXG | S_IRWXO ); + } + else if (BAOPEN_WONLY_APPEND & *mode ) { + #ifdef VERBOSE + printf("open write only with append %s\n", realname); + #endif + *fdes = open(realname, O_WRONLY | O_CREAT | O_APPEND , S_IRWXU | S_IRWXG | S_IRWXO ); + } + else if (BAOPEN_RW & *mode) { + #ifdef VERBOSE + printf("open read-write %s\n", realname); + #endif + *fdes = open(realname, O_RDWR | O_CREAT , S_IRWXU | S_IRWXG | S_IRWXO ); + } + else { + #ifdef VERBOSE + printf("no openings\n"); + #endif + } + if (*fdes < 0) { + #ifdef VERBOSE + printf("error in file descriptor! *fdes %d\n", *fdes); + #endif + return -4; + } + else { + #ifdef VERBOSE + printf("file descriptor = %d\n",*fdes ); + #endif + } + + +/* Read data as requested */ + if (BAREAD & *mode && + ( (BAOPEN_WONLY & *mode) || (BAOPEN_WONLY_TRUNC & *mode) || (BAOPEN_WONLY_APPEND & *mode) ) ) { + #ifdef VERBOSE + printf("Error, trying to read while in write only mode!\n"); + #endif + return -5; + } + else if (BAREAD & *mode ) { + /* Read in some data */ + if (! (*mode & NOSEEK) ) { + seekret = lseek(*fdes, *start, SEEK_SET); + if (seekret == -1) { + #ifdef VERBOSE + printf("error in seeking to %d\n",*start); + #endif + return -6; + } + #ifdef VERBOSE + else { + printf("Seek successful, seek ret %d, start %d\n", seekret, *start); + } + #endif + } + jret = read(*fdes, datary, *no*(*size) ); + if (jret != *no*(*size) ) { + #ifdef VERBOSE + printf("did not read in the requested number of items\n"); + printf("read in %d items of %d \n",jret/(*size), *no); + #endif + *nactual = jret/(*size); + *newpos = *start + jret; + } + #ifdef VERBOSE + printf("read in %d items \n", jret/(*size)); + #endif + *nactual = jret/(*size); + *newpos = *start + jret; + } +/* Done with reading */ + +/* See if we should be writing */ + if ( BAWRITE & *mode && BAOPEN_RONLY & *mode ) { + #ifdef VERBOSE + printf("Trying to write on a read only file \n"); + #endif + return -7; + } + else if ( BAWRITE & *mode ) { + if (! (*mode & NOSEEK) ) { + seekret = lseek(*fdes, *start, SEEK_SET); + if (seekret == -1) { + #ifdef VERBOSE + printf("error in seeking to %d\n",*start); + #endif + return -8; + } + #ifdef VERBOSE + else { + printf("Seek successful, seek ret %d, start %d\n", seekret, *start); + } + #endif + } + jret = write(*fdes, datary, *no*(*size)); + if (jret != *no*(*size)) { + #ifdef VERBOSE + printf("did not write out the requested number of items\n"); + printf("wrote %d items instead\n", jret/(*size) ); + #endif + *nactual = jret/(*size) ; + *newpos = *start + jret; + } + else { + #ifdef VERBOSE + printf("wrote %d items \n", jret/(*size) ); + #endif + *nactual = jret/(*size) ; + *newpos = *start + jret; + } + } +/* Done with writing */ + + +/* Close file if requested */ + if (BACLOSE & *mode ) { + jret = close(*fdes); + if (jret != 0) { + #ifdef VERBOSE + printf("close failed! jret = %d\n",jret); + #endif + return -9; + } + } +/* Done closing */ + +/* Check that if we were reading or writing, that we actually got what */ +/* we expected, else return a -10. Return 0 (success) if we're here */ +/* and weren't reading or writing */ + if ( (*mode & BAREAD || *mode & BAWRITE) && (*nactual != *no) ) { + return -10; + } + else { + return 0; + } +} diff --git a/WPS/ungrib/src/ngl/w3/bacio_module.f b/WPS/ungrib/src/ngl/w3/bacio_module.f new file mode 100644 index 00000000..4b08a0ba --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/bacio_module.f @@ -0,0 +1,23 @@ +C----------------------------------------------------------------------- + MODULE BACIO_MODULE +C$$$ F90-MODULE DOCUMENTATION BLOCK +C +C F90-MODULE: BACIO_MODULE BYTE-ADDRESSABLE I/O MODULE +C PRGMMR: IREDELL ORG: NP23 DATE: 98-06-04 +C +C ABSTRACT: MODULE TO SHARE FILE DESCRIPTORS +C IN THE BYTE-ADDESSABLE I/O PACKAGE. +C +C PROGRAM HISTORY LOG: +C 98-06-04 IREDELL +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + INTEGER,EXTERNAL:: BA_CIO + INTEGER,DIMENSION(999),SAVE:: FD=999*0 + INTEGER,DIMENSION(20),SAVE:: BAOPTS=0 + INCLUDE 'baciof.h' + END + diff --git a/WPS/ungrib/src/ngl/w3/baciof.f b/WPS/ungrib/src/ngl/w3/baciof.f new file mode 100755 index 00000000..a6417c0c --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/baciof.f @@ -0,0 +1,524 @@ +C----------------------------------------------------------------------- + MODULE BACIO_MODULE +C$$$ F90-MODULE DOCUMENTATION BLOCK +C +C F90-MODULE: BACIO_MODULE BYTE-ADDRESSABLE I/O MODULE +C PRGMMR: IREDELL ORG: NP23 DATE: 98-06-04 +C +C ABSTRACT: MODULE TO SHARE FILE DESCRIPTORS +C IN THE BYTE-ADDESSABLE I/O PACKAGE. +C +C PROGRAM HISTORY LOG: +C 98-06-04 IREDELL +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + INTEGER,EXTERNAL:: BA_CIO + INTEGER,DIMENSION(999),SAVE:: FD=999*0 + INTEGER,DIMENSION(20),SAVE:: BAOPTS=0 + INCLUDE 'baciof.h' + END +C----------------------------------------------------------------------- + SUBROUTINE BASETO(NOPT,VOPT) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BASETO BYTE-ADDRESSABLE SET OPTIONS +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: SET OPTIONS FOR BYTE-ADDRESSABLE I/O. +C ALL OPTIONS DEFAULT TO 0. +C OPTION 1: BLOCKED READING OPTION +C IF THE OPTION VALUE IS 1, THEN THE READING IS BLOCKED +C INTO FOUR 4096-BYTE BUFFERS. THIS MAY BE EFFICIENT IF +C THE READS WILL BE REQUESTED IN MUCH SMALLER CHUNKS. +C OTHERWISE, EACH CALL TO BAREAD INITIATES A PHYSICAL READ. +C +C PROGRAM HISTORY LOG: +C 1998-06-04 IREDELL +C +C USAGE: CALL BASETO(NOPT,VOPT) +C INPUT ARGUMENTS: +C NOPT INTEGER OPTION NUMBER +C VOPT INTEGER OPTION VALUE +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE BACIO_MODULE + INTEGER NOPT,VOPT +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(NOPT.GE.1.AND.NOPT.LE.20) BAOPTS(NOPT)=VOPT +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END +C----------------------------------------------------------------------- + SUBROUTINE BAOPEN(LU,CFN,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BAOPEN BYTE-ADDRESSABLE OPEN +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE. +C +C PROGRAM HISTORY LOG: +C 1998-06-04 IREDELL +C +C USAGE: CALL BAOPEN(LU,CFN,IRET) +C INPUT ARGUMENTS: +C LU INTEGER UNIT TO OPEN +C CFN CHARACTER FILENAME TO OPEN +C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C SUBPROGRAMS CALLED: +C BACIO BYTE-ADDRESSABLE I/O C PACKAGE +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE BACIO_MODULE + CHARACTER CFN*(*) + CHARACTER(80) CMSG +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(LU.LT.001.OR.LU.GT.999) THEN + IRET=6 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IRET=BA_CIO(BACIO_OPENRW,IB,JB,1,NB,KA,FD(LU),CFN,A) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END +C----------------------------------------------------------------------- + SUBROUTINE BAOPENR(LU,CFN,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BAOPENR BYTE-ADDRESSABLE OPEN +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR READ ONLY. +C +C PROGRAM HISTORY LOG: +C 1998-06-04 IREDELL +C +C USAGE: CALL BAOPENR(LU,CFN,IRET) +C INPUT ARGUMENTS: +C LU INTEGER UNIT TO OPEN +C CFN CHARACTER FILENAME TO OPEN +C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C SUBPROGRAMS CALLED: +C BACIO BYTE-ADDRESSABLE I/O C PACKAGE +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE BACIO_MODULE + CHARACTER CFN*(*) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(LU.LT.001.OR.LU.GT.999) THEN + IRET=6 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IRET=BA_CIO(BACIO_OPENR,IB,JB,1,NB,KA,FD(LU),CFN,A) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END +C----------------------------------------------------------------------- + SUBROUTINE BAOPENW(LU,CFN,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BAOPENW BYTE-ADDRESSABLE OPEN +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY. +C +C PROGRAM HISTORY LOG: +C 1998-06-04 IREDELL +C +C USAGE: CALL BAOPENW(LU,CFN,IRET) +C INPUT ARGUMENTS: +C LU INTEGER UNIT TO OPEN +C CFN CHARACTER FILENAME TO OPEN +C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C SUBPROGRAMS CALLED: +C BACIO BYTE-ADDRESSABLE I/O C PACKAGE +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE BACIO_MODULE + CHARACTER CFN*(*) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(LU.LT.001.OR.LU.GT.999) THEN + IRET=6 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IRET=BA_CIO(BACIO_OPENW,IB,JB,1,NB,KA,FD(LU),CFN,A) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END +C----------------------------------------------------------------------- + SUBROUTINE BAOPENWT(LU,CFN,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BAOPENWT BYTE-ADDRESSABLE OPEN +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY WITH TRUNCATION. +C +C PROGRAM HISTORY LOG: +C 1998-06-04 IREDELL +C +C USAGE: CALL BAOPENWT(LU,CFN,IRET) +C INPUT ARGUMENTS: +C LU INTEGER UNIT TO OPEN +C CFN CHARACTER FILENAME TO OPEN +C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C SUBPROGRAMS CALLED: +C BACIO BYTE-ADDRESSABLE I/O C PACKAGE +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE BACIO_MODULE + CHARACTER CFN*(*) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(LU.LT.001.OR.LU.GT.999) THEN + IRET=6 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IRET=BA_CIO(BACIO_OPENWT,IB,JB,1,NB,KA,FD(LU),CFN,A) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END +C----------------------------------------------------------------------- + SUBROUTINE BAOPENWA(LU,CFN,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BAOPENWA BYTE-ADDRESSABLE OPEN +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE FOR WRITE ONLY WITH APPEND. +C +C PROGRAM HISTORY LOG: +C 1998-06-04 IREDELL +C +C USAGE: CALL BAOPENWA(LU,CFN,IRET) +C INPUT ARGUMENTS: +C LU INTEGER UNIT TO OPEN +C CFN CHARACTER FILENAME TO OPEN +C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C SUBPROGRAMS CALLED: +C BACIO BYTE-ADDRESSABLE I/O C PACKAGE +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE BACIO_MODULE + CHARACTER CFN*(*) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(LU.LT.001.OR.LU.GT.999) THEN + IRET=6 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IRET=BA_CIO(BACIO_OPENWA,IB,JB,1,NB,KA,FD(LU),CFN,A) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END +C----------------------------------------------------------------------- + SUBROUTINE BACLOSE(LU,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BACLOSE BYTE-ADDRESSABLE CLOSE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: CLOSE A BYTE-ADDRESSABLE FILE. +C +C PROGRAM HISTORY LOG: +C 1998-06-04 IREDELL +C +C USAGE: CALL BACLOSE(LU,IRET) +C INPUT ARGUMENTS: +C LU INTEGER UNIT TO CLOSE +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C SUBPROGRAMS CALLED: +C BACIO BYTE-ADDRESSABLE I/O C PACKAGE +C +C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE BACIO_MODULE +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(LU.LT.001.OR.LU.GT.999) THEN + IRET=6 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IRET=BA_CIO(BACIO_CLOSE,IB,JB,1,NB,KA,FD(LU),CFN,A) + IF(IRET.EQ.0) FD(LU)=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END +C----------------------------------------------------------------------- + SUBROUTINE BAREAD(LU,IB,NB,KA,A) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BAREAD BYTE-ADDRESSABLE READ +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: READ A GIVEN NUMBER OF BYTES FROM AN UNBLOCKED FILE, +C SKIPPING A GIVEN NUMBER OF BYTES. +C THE PHYSICAL I/O IS BLOCKED INTO FOUR 4096-BYTE BUFFERS +C IF THE BYTE-ADDRESSABLE OPTION 1 HAS BEEN SET TO 1 BY BASETO. +C THIS BUFFERED READING IS INCOMPATIBLE WITH NO-SEEK READING. +C +C PROGRAM HISTORY LOG: +C 1998-06-04 IREDELL +C +C USAGE: CALL BAREAD(LU,IB,NB,KA,A) +C INPUT ARGUMENTS: +C LU INTEGER UNIT TO READ +C IB INTEGER NUMBER OF BYTES TO SKIP +C (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING) +C NB INTEGER NUMBER OF BYTES TO READ +C OUTPUT ARGUMENTS: +C KA INTEGER NUMBER OF BYTES ACTUALLY READ +C A CHARACTER*1 (NB) DATA READ +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C SUBPROGRAMS CALLED: +C BACIO BYTE-ADDRESSABLE I/O C PACKAGE +C +C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE BACIO_MODULE + CHARACTER A(NB) + CHARACTER CFN + PARAMETER(NY=4096,MY=4) + INTEGER NS(MY),NN(MY) + CHARACTER Y(NY,MY) + DATA LUX/0/ + SAVE JY,NS,NN,Y,LUX +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(FD(LU).LE.0) THEN + KA=0 + RETURN + ENDIF + IF(IB.LT.0.AND.BAOPTS(1).EQ.1) THEN + KA=0 + RETURN + ENDIF + IF(NB.LE.0) THEN + KA=0 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C UNBUFFERED I/O + IF(BAOPTS(1).NE.1) THEN + IF(IB.GE.0) THEN + IRET=BA_CIO(BACIO_READ,IB,JB,1,NB,KA,FD(LU),CFN,A) + ELSE + IRET=BA_CIO(BACIO_READ+BACIO_NOSEEK,0,JB,1,NB,KA,FD(LU),CFN,A) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C BUFFERED I/O +C GET DATA FROM PREVIOUS CALL IF POSSIBLE + ELSE + KA=0 + IF(LUX.NE.LU) THEN + JY=0 + NS=0 + NN=0 + ELSE + DO I=1,MY + IY=MOD(JY+I-1,MY)+1 + KY=IB+KA-NS(IY) + IF(KA.LT.NB.AND.KY.GE.0.AND.KY.LT.NN(IY)) THEN + K=MIN(NB-KA,NN(IY)-KY) + A(KA+1:KA+K)=Y(KY+1:KY+K,IY) + KA=KA+K + ENDIF + ENDDO + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SET POSITION AND READ BUFFER AND GET DATA + IF(KA.LT.NB) THEN + LUX=ABS(LU) + JY=MOD(JY,MY)+1 + NS(JY)=IB+KA + IRET=BA_CIO(BACIO_READ,NS(JY),JB,1,NY,NN(JY), + & FD(LUX),CFN,Y(1,JY)) + IF(NN(JY).GT.0) THEN + K=MIN(NB-KA,NN(JY)) + A(KA+1:KA+K)=Y(1:K,JY) + KA=KA+K + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C CONTINUE TO READ BUFFER AND GET DATA + DOWHILE(NN(JY).EQ.NY.AND.KA.LT.NB) + JY=MOD(JY,MY)+1 + NS(JY)=NS(JY)+NN(JY) + IRET=BA_CIO(BACIO_READ+BACIO_NOSEEK,NS(JY),JB,1,NY,NN(JY), + & FD(LUX),CFN,Y(1,JY)) + IF(NN(JY).GT.0) THEN + K=MIN(NB-KA,NN(JY)) + A(KA+1:KA+K)=Y(1:K,JY) + KA=KA+K + ENDIF + ENDDO + ENDIF + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END +C----------------------------------------------------------------------- + SUBROUTINE BAWRITE(LU,IB,NB,KA,A) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BAWRITE BYTE-ADDRESSABLE WRITE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: WRITE A GIVEN NUMBER OF BYTES TO AN UNBLOCKED FILE, +C SKIPPING A GIVEN NUMBER OF BYTES. +C +C PROGRAM HISTORY LOG: +C 1998-06-04 IREDELL +C +C USAGE: CALL BAWRITE(LU,IB,NB,KA,A) +C INPUT ARGUMENTS: +C LU INTEGER UNIT TO WRITE +C IB INTEGER NUMBER OF BYTES TO SKIP +C (IF IB<0, THEN THE FILE IS ACCESSED WITH NO SEEKING) +C NB INTEGER NUMBER OF BYTES TO WRITE +C A CHARACTER*1 (NB) DATA TO WRITE +C OUTPUT ARGUMENTS: +C KA INTEGER NUMBER OF BYTES ACTUALLY WRITTEN +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C SUBPROGRAMS CALLED: +C BACIO BYTE-ADDRESSABLE I/O C PACKAGE +C +C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE BACIO_MODULE + CHARACTER A(NB) + CHARACTER CFN +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(FD(LU).LE.0) THEN + KA=0 + RETURN + ENDIF + IF(NB.LE.0) THEN + KA=0 + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(IB.GE.0) THEN + IRET=BA_CIO(BACIO_WRITE,IB,JB,1,NB,KA,FD(LU),CFN,A) + ELSE + IRET=BA_CIO(BACIO_WRITE+BACIO_NOSEEK,0,JB,1,NB,KA,FD(LU),CFN,A) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END +C----------------------------------------------------------------------- + SUBROUTINE WRYTE(LU,NB,A) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: WRYTE WRITE DATA OUT BY BYTES +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: WRITE A GIVEN NUMBER OF BYTES TO AN UNBLOCKED FILE. +C +C PROGRAM HISTORY LOG: +C 92-10-31 IREDELL +C 95-10-31 IREDELL WORKSTATION VERSION +C 1998-06-04 IREDELL BACIO VERSION +C +C USAGE: CALL WRYTE(LU,NB,A) +C INPUT ARGUMENTS: +C LU INTEGER UNIT TO WHICH TO WRITE +C NB INTEGER NUMBER OF BYTES TO WRITE +C A CHARACTER*1 (NB) DATA TO WRITE +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C SUBPROGRAMS CALLED: +C BACIO BYTE-ADDRESSABLE I/O C PACKAGE +C +C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + USE BACIO_MODULE + CHARACTER A(NB) + CHARACTER CFN +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(FD(LU).LE.0) THEN + RETURN + ENDIF + IF(NB.LE.0) THEN + RETURN + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IRET=BA_CIO(BACIO_WRITE+BACIO_NOSEEK,0,JB,1,NB,KA,FD(LU),CFN,A) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/baciof.h b/WPS/ungrib/src/ngl/w3/baciof.h new file mode 100755 index 00000000..4153e27d --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/baciof.h @@ -0,0 +1,11 @@ +! Include file to define variables for Fortran to C interface(s) +! Robert Grumbine 16 March 1998 + INTEGER,PARAMETER:: BACIO_OPENR=1 ! Open file for read only + INTEGER,PARAMETER:: BACIO_OPENW=2 ! Open file for write only + INTEGER,PARAMETER:: BACIO_OPENRW=4 ! Open file for read or write + INTEGER,PARAMETER:: BACIO_CLOSE=8 ! Close file + INTEGER,PARAMETER:: BACIO_READ=16 ! Read from the file + INTEGER,PARAMETER:: BACIO_WRITE=32 ! Write to the file + INTEGER,PARAMETER:: BACIO_NOSEEK=64 ! Start I/O from previous spot + INTEGER,PARAMETER:: BACIO_OPENWT=128 ! Open for write only with truncation + INTEGER,PARAMETER:: BACIO_OPENWA=256 ! Open for write only with append diff --git a/WPS/ungrib/src/ngl/w3/clib.h b/WPS/ungrib/src/ngl/w3/clib.h new file mode 100644 index 00000000..4a43e210 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/clib.h @@ -0,0 +1,27 @@ +/* Include file to define variables for Fortran to C interface(s) */ +/* Robert Grumbine 16 March 1998 */ +/* NOSEEK added 25 March 1998 */ +/* CRAY compatibility added 20 April 1998 */ + +/* The following line should be either undef or define VERBOSE */ +/* The latter gives noisy debugging output, while the former */ +/* relies solely on the return codes */ +#undef VERBOSE + +/* Declare the system type, supported options are: */ +/* LINUX, SGI, HP, CRAY90, IBM4, IBM8, LINUXF90 */ +/* #define IBM4 */ +#include + +/* Do not change things below here yourself */ + +/* IO-related (bacio.c, banio.c) */ +#define BAOPEN_RONLY 1 +#define BAOPEN_WONLY 2 +#define BAOPEN_RW 4 +#define BACLOSE 8 +#define BAREAD 16 +#define BAWRITE 32 +#define NOSEEK 64 +#define BAOPEN_WONLY_TRUNC 128 +#define BAOPEN_WONLY_APPEND 256 diff --git a/WPS/ungrib/src/ngl/w3/errexit.c b/WPS/ungrib/src/ngl/w3/errexit.c new file mode 100755 index 00000000..39a43d6d --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/errexit.c @@ -0,0 +1,12 @@ +#include + +#if defined _UNDERSCORE + void errexit_ (int a) +#elif defined _DOUBLEUNDERSCORE + void errexit__ (int a) +#else + void errexit (int a) +#endif +{ + exit (a); +} diff --git a/WPS/ungrib/src/ngl/w3/errmsg.f b/WPS/ungrib/src/ngl/w3/errmsg.f new file mode 100755 index 00000000..c15a541e --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/errmsg.f @@ -0,0 +1,29 @@ +C----------------------------------------------------------------------- + SUBROUTINE ERRMSG(CMSG) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: ERRMSG WRITE A MESSAGE TO STDERR +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 +C +C ABSTRACT: WRITE A MESSAGE TO STDERR. +C +C PROGRAM HISTORY LOG: +C 95-10-31 IREDELL +C +C USAGE: CALL ERRMSG(CMSG) +C INPUT ARGUMENTS: +C CMSG CHARACTER*(*) MESSAGE TO WRITE +C +C REMARKS: THIS IS A MACHINE-DEPENDENT SUBPROGRAM. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN +C MACHINE: CRAY +C +C$$$ + CHARACTER*(*) CMSG +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + WRITE(0,'(A)') CMSG +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/fparsei.f b/WPS/ungrib/src/ngl/w3/fparsei.f new file mode 100755 index 00000000..dccf3aa1 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/fparsei.f @@ -0,0 +1,39 @@ +C----------------------------------------------------------------------- + SUBROUTINE FPARSEI(CARG,MARG,KARG) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FPARSER PARSE INTEGERS FROM A CHARACTER STRING +C PRGMMR: IREDELL ORG: NP23 DATE:1998-09-03 +C +C ABSTRACT: THIS SUBPROGRAM EXTRACTS INTEGERS FROM A FREE-FORMAT +C CHARACTER STRING. IT IS USEFUL FOR PARSING COMMAND ARGUMENTS. +C +C PROGRAM HISTORY LOG: +C 1998-09-03 IREDELL +C +C USAGE: CALL FPARSEI(CARG,MARG,KARG) +C +C INPUT ARGUMENT LIST: +C CARG - CHARACTER*(*) STRING OF ASCII DIGITS TO PARSE. +C INTEGERS MAY BE SEPARATED BY A COMMA OR BY BLANKS. +C MARG - INTEGER MAXIMUM NUMBER OF INTEGERS TO PARSE. +C +C OUTPUT ARGUMENT LIST: +C KARG - INTEGER (MARG) NUMBERS PARSED. +C (FROM 0 TO MARG VALUES MAY BE RETURNED.) +C +C REMARKS: +C TO DETERMINE THE ACTUAL NUMBER OF INTEGERS FOUND IN THE STRING, +C KARG SHOULD BE SET TO FILL VALUES BEFORE THE CALL TO FPARSEI AND +C THE NUMBER OF NON-FILL VALUES SHOULD BE COUNTED AFTER THE CALL. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + CHARACTER*(*) CARG + INTEGER KARG(MARG) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + READ(CARG,*,IOSTAT=IOS) KARG +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END diff --git a/WPS/ungrib/src/ngl/w3/fparser.f b/WPS/ungrib/src/ngl/w3/fparser.f new file mode 100755 index 00000000..85370ccf --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/fparser.f @@ -0,0 +1,39 @@ +C----------------------------------------------------------------------- + SUBROUTINE FPARSER(CARG,MARG,RARG) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FPARSER PARSE REAL NUMBERS FROM A CHARACTER STRING +C PRGMMR: IREDELL ORG: NP23 DATE:1998-09-03 +C +C ABSTRACT: THIS SUBPROGRAM EXTRACTS REAL NUMBERS FROM A FREE-FORMAT +C CHARACTER STRING. IT IS USEFUL FOR PARSING COMMAND ARGUMENTS. +C +C PROGRAM HISTORY LOG: +C 1998-09-03 IREDELL +C +C USAGE: CALL FPARSER(CARG,MARG,RARG) +C +C INPUT ARGUMENT LIST: +C CARG - CHARACTER*(*) STRING OF ASCII DIGITS TO PARSE. +C REAL NUMBERS MAY BE SEPARATED BY A COMMA OR BY BLANKS. +C MARG - INTEGER MAXIMUM NUMBER OF REAL NUMBERS TO PARSE. +C +C OUTPUT ARGUMENT LIST: +C RARG - REAL (MARG) NUMBERS PARSED. +C (FROM 0 TO MARG VALUES MAY BE RETURNED.) +C +C REMARKS: +C TO DETERMINE THE ACTUAL NUMBER OF REAL NUMBERS FOUND IN THE STRING, +C RARG SHOULD BE SET TO FILL VALUES BEFORE THE CALL TO FPARSER AND +C THE NUMBER OF NON-FILL VALUES SHOULD BE COUNTED AFTER THE CALL. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + CHARACTER*(*) CARG + REAL RARG(MARG) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + READ(CARG,*,IOSTAT=IOS) RARG +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END diff --git a/WPS/ungrib/src/ngl/w3/gbytes.f b/WPS/ungrib/src/ngl/w3/gbytes.f new file mode 100755 index 00000000..1551117d --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/gbytes.f @@ -0,0 +1,144 @@ + SUBROUTINE GBYTES(IPACKD,IUNPKD,NOFF,NBITS,ISKIP,ITER) +C +C THIS PROGRAM WRITTEN BY..... +C DR. ROBERT C. GAMMILL, CONSULTANT +C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH +C MAY 1972 +C +C CHANGES FOR SiliconGraphics IRIS-4D/25 +C SiliconGraphics 3.3 FORTRAN 77 +C MARCH 1991, RUSSELL E. JONES +C NATIONAL WEATHER SERVICE +C +C THIS IS THE FORTRAN VERSION OF GBYTES. +C +C*********************************************************************** +C +C SUBROUTINE GBYTES (IPACKD,IUNPKD,NOFF,NBITS,ISKIP,ITER) +C +C PURPOSE TO UNPACK A SERIES OF BYTES INTO A TARGET +C ARRAY. EACH UNPACKED BYTE IS RIGHT-JUSTIFIED +C IN ITS TARGET WORD, AND THE REMAINDER OF THE +C WORD IS ZERO-FILLED. +C +C USAGE CALL GBYTES (IPACKD,IUNPKD,NOFF,NBITS,NSKIP, +C ITER) +C +C ARGUMENTS +C ON INPUT IPACKD +C THE WORD OR ARRAY CONTAINING THE PACKED +C BYTES. +C +C IUNPKD +C THE ARRAY WHICH WILL CONTAIN THE UNPACKED +C BYTES. +C +C NOFF +C THE INITIAL NUMBER OF BITS TO SKIP, LEFT +C TO RIGHT, IN 'IPACKD' IN ORDER TO LOCATE +C THE FIRST BYTE TO UNPACK. +C +C NBITS +C NUMBER OF BITS IN THE BYTE TO BE UNPACKED. +C MAXIMUM OF 64 BITS ON 64 BIT MACHINE, 32 +C BITS ON 32 BIT MACHINE. +C +C ISKIP +C THE NUMBER OF BITS TO SKIP BETWEEN EACH BYTE +C IN 'IPACKD' IN ORDER TO LOCATE THE NEXT BYTE +C TO BE UNPACKED. +C +C ITER +C THE NUMBER OF BYTES TO BE UNPACKED. +C +C ARGUMENTS +C ON OUTPUT IUNPKD +C CONTAINS THE REQUESTED UNPACKED BYTES. +C*********************************************************************** + + INTEGER IPACKD(*) + + INTEGER IUNPKD(*) + INTEGER MASKS(64) +C + SAVE +C + DATA IFIRST/1/ + IF(IFIRST.EQ.1) THEN + CALL W3FI01(LW) + NBITSW = 8 * LW + JSHIFT = -1 * NINT(ALOG(FLOAT(NBITSW)) / ALOG(2.0)) + MASKS(1) = 1 + DO I=2,NBITSW-1 + MASKS(I) = 2 * MASKS(I-1) + 1 + ENDDO + MASKS(NBITSW) = -1 + IFIRST = 0 + ENDIF +C +C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW +C + ICON = NBITSW - NBITS + IF (ICON.LT.0) RETURN + MASK = MASKS(NBITS) +C +C INDEX TELLS HOW MANY WORDS INTO THE ARRAY 'IPACKD' THE NEXT BYTE +C APPEARS. +C + INDEX = ISHFT(NOFF,JSHIFT) +C +C II TELLS HOW MANY BITS THE BYTE IS FROM THE LEFT SIDE OF THE WORD. +C + II = MOD(NOFF,NBITSW) +C +C ISTEP IS THE DISTANCE IN BITS FROM THE START OF ONE BYTE TO THE NEXT. +C + ISTEP = NBITS + ISKIP +C +C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT. +C + IWORDS = ISTEP / NBITSW +C +C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS. +C + IBITS = MOD(ISTEP,NBITSW) +C + DO 10 I = 1,ITER +C +C MOVER SPECIFIES HOW FAR TO THE RIGHT A BYTE MUST BE MOVED IN ORDER +C +C TO BE RIGHT ADJUSTED. +C + MOVER = ICON - II +C +C THE BYTE IS SPLIT ACROSS A WORD BREAK. +C + IF (MOVER.LT.0) THEN + MOVEL = - MOVER + MOVER = NBITSW - MOVEL + IUNPKD(I) = IAND(IOR(ISHFT(IPACKD(INDEX+1),MOVEL), + & ISHFT(IPACKD(INDEX+2),-MOVER)),MASK) +C +C RIGHT ADJUST THE BYTE. +C + ELSE IF (MOVER.GT.0) THEN + IUNPKD(I) = IAND(ISHFT(IPACKD(INDEX+1),-MOVER),MASK) +C +C THE BYTE IS ALREADY RIGHT ADJUSTED. +C + ELSE + IUNPKD(I) = IAND(IPACKD(INDEX+1),MASK) + ENDIF +C +C INCREMENT II AND INDEX. +C + II = II + IBITS + INDEX = INDEX + IWORDS + IF (II.GE.NBITSW) THEN + II = II - NBITSW + INDEX = INDEX + 1 + ENDIF +C + 10 CONTINUE + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/gbytes_char.f b/WPS/ungrib/src/ngl/w3/gbytes_char.f new file mode 100644 index 00000000..314863fa --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/gbytes_char.f @@ -0,0 +1,127 @@ + SUBROUTINE GBYTEC(IN,IOUT,ISKIP,NBYTE) + character*1 in(*) + integer iout(*) + CALL GBYTESC(IN,IOUT,ISKIP,NBYTE,0,1) + RETURN + END + + SUBROUTINE SBYTEC(OUT,IN,ISKIP,NBYTE) + character*1 out(*) + integer in(*) + CALL SBYTESC(OUT,IN,ISKIP,NBYTE,0,1) + RETURN + END + + SUBROUTINE GBYTESC(IN,IOUT,ISKIP,NBYTE,NSKIP,N) +C Get bytes - unpack bits: Extract arbitrary size values from a +C packed bit string, right justifying each value in the unpacked +C array. +C IN = character*1 array input +C IOUT = unpacked array output +C ISKIP = initial number of bits to skip +C NBYTE = number of bits to take +C NSKIP = additional number of bits to skip on each iteration +C N = number of iterations +C v1.1 +C + character*1 in(*) + integer iout(*) + integer ones(8), tbit, bitcnt + save ones + data ones/1,3,7,15,31,63,127,255/ + +c nbit is the start position of the field in bits + nbit = iskip + do i = 1, n + bitcnt = nbyte + index=nbit/8+1 + ibit=mod(nbit,8) + nbit = nbit + nbyte + nskip + +c first byte + tbit = min(bitcnt,8-ibit) + itmp = iand(mov_a2i(in(index)),ones(8-ibit)) + if (tbit.ne.8-ibit) itmp = ishft(itmp,tbit-8+ibit) + index = index + 1 + bitcnt = bitcnt - tbit + +c now transfer whole bytes + do while (bitcnt.ge.8) + itmp = ior(ishft(itmp,8),mov_a2i(in(index))) + bitcnt = bitcnt - 8 + index = index + 1 + enddo + +c get data from last byte + if (bitcnt.gt.0) then + itmp = ior(ishft(itmp,bitcnt),iand(ishft(mov_a2i(in(index)), + 1 -(8-bitcnt)),ones(bitcnt))) + endif + + iout(i) = itmp + enddo + + RETURN + END + + SUBROUTINE SBYTESC(OUT,IN,ISKIP,NBYTE,NSKIP,N) +C Store bytes - pack bits: Put arbitrary size values into a +C packed bit string, taking the low order bits from each value +C in the unpacked array. +C IOUT = packed array output +C IN = unpacked array input +C ISKIP = initial number of bits to skip +C NBYTE = number of bits to pack +C NSKIP = additional number of bits to skip on each iteration +C N = number of iterations +C v1.1 +C + character*1 out(*) + integer in(N), bitcnt, ones(8), tbit + save ones + data ones/ 1, 3, 7, 15, 31, 63,127,255/ + +c number bits from zero to ... +c nbit is the last bit of the field to be filled + + nbit = iskip + nbyte - 1 + do i = 1, n + itmp = in(i) + bitcnt = nbyte + index=nbit/8+1 + ibit=mod(nbit,8) + nbit = nbit + nbyte + nskip + +c make byte aligned + if (ibit.ne.7) then + tbit = min(bitcnt,ibit+1) + imask = ishft(ones(tbit),7-ibit) + itmp2 = iand(ishft(itmp,7-ibit),imask) + itmp3 = iand(mov_a2i(out(index)), 255-imask) + out(index) = char(ior(itmp2,itmp3)) + bitcnt = bitcnt - tbit + itmp = ishft(itmp, -tbit) + index = index - 1 + endif + +c now byte aligned + +c do by bytes + do while (bitcnt.ge.8) + out(index) = char(iand(itmp,255)) + itmp = ishft(itmp,-8) + bitcnt = bitcnt - 8 + index = index - 1 + enddo + +c do last byte + + if (bitcnt.gt.0) then + itmp2 = iand(itmp,ones(bitcnt)) + itmp3 = iand(mov_a2i(out(index)), 255-ones(bitcnt)) + out(index) = char(ior(itmp2,itmp3)) + endif + enddo + + return + end diff --git a/WPS/ungrib/src/ngl/w3/getbit.f b/WPS/ungrib/src/ngl/w3/getbit.f new file mode 100755 index 00000000..3e4aea6f --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getbit.f @@ -0,0 +1,87 @@ + SUBROUTINE GETBIT(IBM,IBS,IDS,LEN,MG,G,GROUND,GMIN,GMAX,NBIT) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETBIT COMPUTE NUMBER OF BITS AND ROUND FIELD. +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 +C +C ABSTRACT: THE NUMBER OF BITS REQUIRED TO PACK A GIVEN FIELD +C FOR PARTICULAR BINARY AND DECIMAL SCALINGS IS COMPUTED. +C THE FIELD IS ROUNDED OFF TO THE DECIMAL SCALING FOR PACKING. +C THE MINIMUM AND MAXIMUM ROUNDED FIELD VALUES ARE ALSO RETURNED. +C GRIB BITMAP MASKING FOR VALID DATA IS OPTIONALLY USED. +C +C PROGRAM HISTORY LOG: +C 96-09-16 IREDELL +C +C USAGE: CALL GTBITS(IBM,IBS,IDS,LEN,MG,G,GMIN,GMAX,NBIT) +C INPUT ARGUMENT LIST: +C IBM - INTEGER BITMAP FLAG (=0 FOR NO BITMAP) +C IBS - INTEGER BINARY SCALING +C (E.G. IBS=3 TO ROUND FIELD TO NEAREST EIGHTH VALUE) +C IDS - INTEGER DECIMAL SCALING +C (E.G. IDS=3 TO ROUND FIELD TO NEAREST MILLI-VALUE) +C (NOTE THAT IDS AND IBS CAN BOTH BE NONZERO, +C E.G. IDS=1 AND IBS=1 ROUNDS TO THE NEAREST TWENTIETH) +C LEN - INTEGER LENGTH OF THE FIELD AND BITMAP +C MG - INTEGER (LEN) BITMAP IF IBM=1 (0 TO SKIP, 1 TO KEEP) +C G - REAL (LEN) FIELD +C +C OUTPUT ARGUMENT LIST: +C GROUND - REAL (LEN) FIELD ROUNDED TO DECIMAL AND BINARY SCALING +C (SET TO ZERO WHERE BITMAP IS 0 IF IBM=1) +C GMIN - REAL MINIMUM VALID ROUNDED FIELD VALUE +C GMAX - REAL MAXIMUM VALID ROUNDED FIELD VALUE +C NBIT - INTEGER NUMBER OF BITS TO PACK +C +C ATTRIBUTES: +C LANGUAGE: CRAY FORTRAN +C +C$$$ + DIMENSION MG(LEN),G(LEN),GROUND(LEN) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C ROUND FIELD AND DETERMINE EXTREMES WHERE BITMAP IS ON + S=2.**IBS*10.**IDS + IF(IBM.EQ.0) THEN + GROUND(1)=NINT(G(1)*S)/S + GMAX=GROUND(1) + GMIN=GROUND(1) + DO I=2,LEN + GROUND(I)=NINT(G(I)*S)/S + GMAX=MAX(GMAX,GROUND(I)) + GMIN=MIN(GMIN,GROUND(I)) + ENDDO + ELSE + I1=1 + DOWHILE(I1.LE.LEN.AND.MG(I1).EQ.0) + I1=I1+1 + ENDDO + IF(I1.LE.LEN) THEN + DO I=1,I1-1 + GROUND(I)=0. + ENDDO + GROUND(I1)=NINT(G(I1)*S)/S + GMAX=GROUND(I1) + GMIN=GROUND(I1) + DO I=I1+1,LEN + IF(MG(I).NE.0) THEN + GROUND(I)=NINT(G(I)*S)/S + GMAX=MAX(GMAX,GROUND(I)) + GMIN=MIN(GMIN,GROUND(I)) + ELSE + GROUND(I)=0. + ENDIF + ENDDO + ELSE + DO I=1,LEN + GROUND(I)=0. + ENDDO + GMAX=0. + GMIN=0. + ENDIF + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C COMPUTE NUMBER OF BITS + NBIT=LOG((GMAX-GMIN)*S+0.9)/LOG(2.)+1. +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgb.f b/WPS/ungrib/src/ngl/w3/getgb.f new file mode 100755 index 00000000..fac9c3df --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgb.f @@ -0,0 +1,213 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGB(LUGB,LUGI,JF,J,JPDS,JGDS, + & KF,K,KPDS,KGDS,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB FINDS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH +C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), +C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE +C RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGB(LUGB,LUGI,JF,J,JPDS,JGDS, +C & KF,K,KPDS,KGDS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C OUTPUT ARGUMENTS: +C KF INTEGER NUMBER OF DATA POINTS UNPACKED +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT +C F REAL (KF) UNPACKED DATA +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF DATA POINTS GREATER THAN JF +C 99 REQUEST NOT FOUND +C OTHER W3FI63 GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C GETGBM FIND AND UNPACK GRIB MESSAGE +C +C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT +C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF +C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBM AS BELOW, +C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200),KPDS(200),KGDS(200) + LOGICAL*1 LB(JF) + REAL F(JF) + PARAMETER(MBUF=256*1024) + CHARACTER CBUF(MBUF) + SAVE CBUF,NLEN,NNUM,MNUM + DATA LUX/0/ +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED + IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN + LUX=LUGI + JJ=MIN(J,-1-J) + ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN + LUX=LUGB + JJ=MIN(J,-1-J) + ELSE + JJ=J + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C FIND AND UNPACK GRIB MESSAGE + CALL GETGBM(LUGB,LUGI,JF,JJ,JPDS,JGDS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KF,K,KPDS,KGDS,LB,F,IRET) + IF(IRET.EQ.96) LUX=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgb1r.f b/WPS/ungrib/src/ngl/w3/getgb1r.f new file mode 100755 index 00000000..70d335e2 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgb1r.f @@ -0,0 +1,75 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITSS + + ,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB1R READS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 +C +C ABSTRACT: READ AND UNPACK A GRIB MESSAGE. +C +C PROGRAM HISTORY LOG: +C 95-10-31 IREDELL +C 04-07-22 CHUANG ADD PACKING BIT NUMBER NBITSS IN THE ARGUMENT +C LIST BECAUSE ETA GRIB FILES NEED IT TO REPACK GRIB FILE +C USAGE: CALL GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LSKIP INTEGER NUMBER OF BYTES TO SKIP +C LGRIB INTEGER NUMBER OF BYTES TO READ +C OUTPUT ARGUMENTS: +C KF INTEGER NUMBER OF DATA POINTS UNPACKED +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT +C F REAL (KF) UNPACKED DATA +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 97 ERROR READING GRIB FILE +C OTHER W3FI63 GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C BAREAD BYTE-ADDRESSABLE READ +C W3FI63 UNPACK GRIB +C PDSEUP UNPACK PDS EXTENSION +C +C REMARKS: THERE IS NO PROTECTION AGAINST UNPACKING TOO MUCH DATA. +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB ROUTINES ONLY. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER KPDS(200),KGDS(200),KENS(200) + LOGICAL*1 LB(*) + REAL F(*) + INTEGER KPTR(200) + CHARACTER GRIB(LGRIB)*1 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ GRIB RECORD + CALL BAREAD(LUGB,LSKIP,LGRIB,LREAD,GRIB) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C UNPACK GRIB RECORD + IF(LREAD.EQ.LGRIB) THEN + CALL W3FI63(GRIB,KPDS,KGDS,LB,F,KPTR,IRET) + IF(IRET.EQ.0.AND.KPDS(23).EQ.2) THEN + CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,45,GRIB(9)) + ENDIF + ELSE + IRET=97 + ENDIF + NBITSS=KPTR(20) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C RETURN NUMBER OF POINTS + IF(IRET.EQ.0) THEN + KF=KPTR(10) + ELSE + KF=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgb1re.f b/WPS/ungrib/src/ngl/w3/getgb1re.f new file mode 100755 index 00000000..46ad99e1 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgb1re.f @@ -0,0 +1,81 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGB1RE(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS, + & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB1RE READS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 +C +C ABSTRACT: READ AND UNPACK A GRIB MESSAGE. +C +C PROGRAM HISTORY LOG: +C 95-10-31 IREDELL +C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS +C +C USAGE: CALL GETGB1RE(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS, +C & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LSKIP INTEGER NUMBER OF BYTES TO SKIP +C LGRIB INTEGER NUMBER OF BYTES TO READ +C OUTPUT ARGUMENTS: +C KF INTEGER NUMBER OF DATA POINTS UNPACKED +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS +C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS +C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS +C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS +C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT +C F REAL (KF) UNPACKED DATA +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 97 ERROR READING GRIB FILE +C OTHER W3FI63 GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C BAREAD BYTE-ADDRESSABLE READ +C W3FI63 UNPACK GRIB +C PDSEUP UNPACK PDS EXTENSION +C +C REMARKS: THERE IS NO PROTECTION AGAINST UNPACKING TOO MUCH DATA. +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB ROUTINES ONLY. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER KPDS(200),KGDS(200),KENS(200) + INTEGER KPROB(2),KCLUST(16),KMEMBR(80) + REAL XPROB(2) + LOGICAL*1 LB(*) + REAL F(*) + INTEGER KPTR(200) + CHARACTER GRIB(LGRIB)*1 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ GRIB RECORD + CALL BAREAD(LUGB,LSKIP,LGRIB,LREAD,GRIB) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C UNPACK GRIB RECORD + IF(LREAD.EQ.LGRIB) THEN + CALL W3FI63(GRIB,KPDS,KGDS,LB,F,KPTR,IRET) + IF(IRET.EQ.0.AND.KPDS(23).EQ.2) THEN + CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,86,GRIB(9)) + ENDIF + ELSE + IRET=97 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C RETURN NUMBER OF POINTS + IF(IRET.EQ.0) THEN + KF=KPTR(10) + ELSE + KF=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgb1s.f b/WPS/ungrib/src/ngl/w3/getgb1s.f new file mode 100755 index 00000000..af333998 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgb1s.f @@ -0,0 +1,184 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGB1S(CBUF,NLEN,NNUM,J,JPDS,JGDS,JENS, + & K,KPDS,KGDS,KENS,LSKIP,LGRIB,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB1S FINDS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 +C +C ABSTRACT: FIND A GRIB MESSAGE. +C FIND IN THE INDEX FILE A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C +C PROGRAM HISTORY LOG: +C 95-10-31 IREDELL +C +C USAGE: CALL GETGB1S(CBUF,NLEN,NNUM,J,JPDS,JGDS,JENS, +C & K,KPDS,KGDS,KENS,LSKIP,LGRIB,IRET) +C INPUT ARGUMENTS: +C CBUF CHARACTER*1 (NLEN*NNUM) BUFFER CONTAINING INDEX DATA +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C NNUM INTEGER NUMBER OF INDEX RECORDS +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(23)=2) +C (=-1 FOR WILDCARD) +C OUTPUT ARGUMENTS: +C K INTEGER MESSAGE NUMBER FOUND +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C LSKIP INTEGER NUMBER OF BYTES TO SKIP +C LGRIB INTEGER NUMBER OF BYTES TO READ +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 1 REQUEST NOT FOUND +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C THIS SUBPROGRAM IS INTENDED FOR PRIVATE USE BY GETGB ROUTINES ONLY. +C +C SUBPROGRAMS CALLED: +C GBYTE UNPACK BYTES +C FI632 UNPACK PDS +C FI633 UNPACK GDS +C PDSEUP UNPACK PDS EXTENSION +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + CHARACTER CBUF(NLEN*NNUM) + INTEGER JPDS(200),JGDS(200),JENS(200) + INTEGER KPDS(200),KGDS(200),KENS(200) + PARAMETER(LPDS=23,LGDS=22,LENS=5) ! ACTUAL SEARCH RANGES + CHARACTER CPDS(400)*1,CGDS(400)*1 + INTEGER KPTR(200) + INTEGER IPDSP(LPDS),JPDSP(LPDS) + INTEGER IGDSP(LGDS),JGDSP(LGDS) + INTEGER IENSP(LENS),JENSP(LENS) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C COMPRESS REQUEST LISTS + K=J + LSKIP=0 + LGRIB=0 + IRET=1 +C COMPRESS PDS REQUEST + LPDSP=0 + DO I=1,LPDS + IF(JPDS(I).NE.-1) THEN + LPDSP=LPDSP+1 + IPDSP(LPDSP)=I + JPDSP(LPDSP)=JPDS(I) + ENDIF + ENDDO +C COMPRESS GDS REQUEST + LGDSP=0 + IF(JPDS(3).EQ.255) THEN + DO I=1,LGDS + IF(JGDS(I).NE.-1) THEN + LGDSP=LGDSP+1 + IGDSP(LGDSP)=I + JGDSP(LGDSP)=JGDS(I) + ENDIF + ENDDO + ENDIF +C COMPRESS ENS REQUEST + LENSP=0 + IF(JPDS(23).EQ.2) THEN + DO I=1,LENS + IF(JENS(I).NE.-1) THEN + LENSP=LENSP+1 + IENSP(LENSP)=I + JENSP(LENSP)=JENS(I) + ENDIF + ENDDO + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH FOR REQUEST + DOWHILE(IRET.NE.0.AND.K.LT.NNUM) + K=K+1 + LT=0 +C SEARCH FOR PDS REQUEST + IF(LPDSP.GT.0) THEN + CPDS=CHAR(0) + CPDS(1:28)=CBUF((K-1)*NLEN+26:(K-1)*NLEN+53) + NLESS=MAX(184-NLEN,0) + CPDS(29:40-NLESS)=CBUF((K-1)*NLEN+173:(K-1)*NLEN+184-NLESS) + KPTR=0 + CALL GBYTE(CBUF,KPTR(3),(K-1)*NLEN*8+25*8,3*8) + KPDS(18)=1 + CALL GBYTE(CPDS,KPDS(4),7*8,8) + CALL FI632(CPDS,KPTR,KPDS,IRET) + DO I=1,LPDSP + IP=IPDSP(I) + LT=LT+ABS(JPDS(IP)-KPDS(IP)) + ENDDO + ENDIF +C SEARCH FOR GDS REQUEST + IF(LT.EQ.0.AND.LGDSP.GT.0) THEN + CGDS=CHAR(0) + CGDS(1:42)=CBUF((K-1)*NLEN+54:(K-1)*NLEN+95) + NLESS=MAX(320-NLEN,0) + CGDS(43:178-NLESS)=CBUF((K-1)*NLEN+185:(K-1)*NLEN+320-NLESS) + KPTR=0 + CALL FI633(CGDS,KPTR,KGDS,IRET) + DO I=1,LGDSP + IP=IGDSP(I) + LT=LT+ABS(JGDS(IP)-KGDS(IP)) + ENDDO + ENDIF +C SEARCH FOR ENS REQUEST + IF(LT.EQ.0.AND.LENSP.GT.0) THEN + NLESS=MAX(172-NLEN,0) + CPDS(41:100-NLESS)=CBUF((K-1)*NLEN+113:(K-1)*NLEN+172-NLESS) + CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,45,CPDS) + DO I=1,LENSP + IP=IENSP(I) + LT=LT+ABS(JENS(IP)-KENS(IP)) + ENDDO + ENDIF +C RETURN IF REQUEST IS FOUND + IF(LT.EQ.0) THEN + CALL GBYTE(CBUF,LSKIP,(K-1)*NLEN*8,4*8) + CALL GBYTE(CBUF,LGRIB,(K-1)*NLEN*8+20*8,4*8) + IF(LPDSP.EQ.0) THEN + CPDS=CHAR(0) + CPDS(1:28)=CBUF((K-1)*NLEN+26:(K-1)*NLEN+53) + NLESS=MAX(184-NLEN,0) + CPDS(29:40-NLESS)=CBUF((K-1)*NLEN+173:(K-1)*NLEN+184-NLESS) + KPTR=0 + CALL GBYTE(CBUF,KPTR(3),(K-1)*NLEN*8+25*8,3*8) + KPDS(18)=1 + CALL GBYTE(CPDS,KPDS(4),7*8,8) + CALL FI632(CPDS,KPTR,KPDS,IRET) + ENDIF + IF(LGDSP.EQ.0) THEN + CGDS=CHAR(0) + CGDS(1:42)=CBUF((K-1)*NLEN+54:(K-1)*NLEN+95) + NLESS=MAX(320-NLEN,0) + CGDS(43:178-NLESS)=CBUF((K-1)*NLEN+185:(K-1)*NLEN+320-NLESS) + KPTR=0 + CALL FI633(CGDS,KPTR,KGDS,IRET) + ENDIF + IF(KPDS(23).EQ.2.AND.LENSP.EQ.0) THEN + NLESS=MAX(172-NLEN,0) + CPDS(41:100-NLESS)=CBUF((K-1)*NLEN+113:(K-1)*NLEN+172-NLESS) + CALL PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,45,CPDS) + ENDIF + IRET=0 + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbe.f b/WPS/ungrib/src/ngl/w3/getgbe.f new file mode 100755 index 00000000..15695225 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbe.f @@ -0,0 +1,223 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBE(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, + & KF,K,KPDS,KGDS,KENS,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBE FINDS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH +C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), +C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE +C RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGBE(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, +C & KF,K,KPDS,KGDS,KENS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(23)=2) +C (=-1 FOR WILDCARD) +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C OUTPUT ARGUMENTS: +C KF INTEGER NUMBER OF DATA POINTS UNPACKED +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT +C F REAL (KF) UNPACKED DATA +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF DATA POINTS GREATER THAN JF +C 99 REQUEST NOT FOUND +C OTHER W3FI63 GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C GETGBEM FIND AND UNPACK GRIB MESSAGE +C +C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT +C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF +C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEM AS BELOW, +C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200),JENS(200) + INTEGER KPDS(200),KGDS(200),KENS(200) + LOGICAL*1 LB(JF) + REAL F(JF) + PARAMETER(MBUF=256*1024) + CHARACTER CBUF(MBUF) + SAVE CBUF,NLEN,NNUM,MNUM + DATA LUX/0/ +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED + IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN + LUX=LUGI + JJ=MIN(J,-1-J) + ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN + LUX=LUGB + JJ=MIN(J,-1-J) + ELSE + JJ=J + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C FIND AND UNPACK GRIB MESSAGE + CALL GETGBEM(LUGB,LUGI,JF,JJ,JPDS,JGDS,JENS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KF,K,KPDS,KGDS,KENS,LB,F,IRET) + IF(IRET.EQ.96) LUX=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbeh.f b/WPS/ungrib/src/ngl/w3/getgbeh.f new file mode 100755 index 00000000..030bed06 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbeh.f @@ -0,0 +1,215 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBEH(LUGB,LUGI,J,JPDS,JGDS,JENS, + & KG,KF,K,KPDS,KGDS,KENS,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBEH FINDS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS +C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE +C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGBEH(LUGB,LUGI,J,JPDS,JGDS,JENS, +C & KG,KF,K,KPDS,KGDS,KENS,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C (ONLY USED IF LUGI=0) +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(23)=2) +C (=-1 FOR WILDCARD) +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C OUTPUT ARGUMENTS: +C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE +C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 99 REQUEST NOT FOUND +C +C SUBPROGRAMS CALLED: +C GETGBEMH FIND GRIB MESSAGE +C +C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT +C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF +C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEMH AS BELOW, +C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200),JENS(200) + INTEGER KPDS(200),KGDS(200),KENS(200) + PARAMETER(MBUF=256*1024) + CHARACTER CBUF(MBUF) + SAVE CBUF,NLEN,NNUM,MNUM + DATA LUX/0/ +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED + IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN + LUX=LUGI + JJ=MIN(J,-1-J) + ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN + LUX=LUGB + JJ=MIN(J,-1-J) + ELSE + JJ=J + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C FIND AND UNPACK GRIB MESSAGE + CALL GETGBEMH(LUGB,LUGI,JJ,JPDS,JGDS,JENS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KG,KF,K,KPDS,KGDS,KENS,IRET) + IF(IRET.EQ.96) LUX=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbem.f b/WPS/ungrib/src/ngl/w3/getgbem.f new file mode 100755 index 00000000..722870d1 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbem.f @@ -0,0 +1,275 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBEM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KF,K,KPDS,KGDS,KENS,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBEM FINDS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH +C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), +C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE +C RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGBEM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, +C & MBUF,CBUF,NLEN,NNUM,MNUM, +C & KF,K,KPDS,KGDS,KENS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(23)=2) +C (=-1 FOR WILDCARD) +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C (INITIALIZE BY SETTING J=-1) +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C (INITIALIZE BY SETTING J=-1) +C NNUM INTEGER NUMBER OF INDEX RECORDS +C (INITIALIZE BY SETTING J=-1) +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C (INITIALIZE BY SETTING J=-1) +C OUTPUT ARGUMENTS: +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C NNUM INTEGER NUMBER OF INDEX RECORDS +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C KF INTEGER NUMBER OF DATA POINTS UNPACKED +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT +C F REAL (KF) UNPACKED DATA +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF DATA POINTS GREATER THAN JF +C 99 REQUEST NOT FOUND +C OTHER W3FI63 GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C GETGI READ INDEX FILE +C GETGIR READ INDEX BUFFER FROM GRIB FILE +C GETGB1S SEARCH INDEX RECORDS +C GETGB1R READ AND UNPACK GRIB RECORD +C LENGDS RETURN THE LENGTH OF A GRID +C +C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200),JENS(200) + INTEGER KPDS(200),KGDS(200),KENS(200) + CHARACTER CBUF(MBUF) + LOGICAL*1 LB(JF) + REAL F(JF) + PARAMETER(MSK1=32000,MSK2=4000) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE + IF(J.GE.0) THEN + IF(MNUM.GE.0) THEN + IRGI=0 + ELSE + MNUM=-1-MNUM + IRGI=1 + ENDIF + JR=J-MNUM + IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ELSE + MNUM=J + IRGI=1 + IRGS=1 + ENDIF + ELSE + MNUM=-1-J + IRGI=1 + IRGS=1 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND SEARCH NEXT INDEX BUFFER + JR=0 + DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) + IF(LUGI.GT.0) THEN + CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ELSE + CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ENDIF + IF(IRGI.LE.1) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND UNPACK GRIB RECORD + IF(IRGI.GT.1) THEN + IRET=96 + ELSEIF(IRGS.NE.0) THEN + IRET=99 + ELSEIF(LENGDS(KGDS).GT.JF) THEN + IRET=98 + ELSE + CALL GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITSS + + ,IRET) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbemh.f b/WPS/ungrib/src/ngl/w3/getgbemh.f new file mode 100755 index 00000000..deb36ab8 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbemh.f @@ -0,0 +1,265 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBEMH(LUGB,LUGI,J,JPDS,JGDS,JENS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KG,KF,K,KPDS,KGDS,KENS,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBEMH FINDS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS +C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE +C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGBEMH(LUGB,LUGI,J,JPDS,JGDS,JENS, +C & MBUF,CBUF,NLEN,NNUM,MNUM, +C & KG,KF,K,KPDS,KGDS,KENS,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C (ONLY USED IF LUGI=0) +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(23)=2) +C (=-1 FOR WILDCARD) +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C (INITIALIZE BY SETTING J=-1) +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C (INITIALIZE BY SETTING J=-1) +C NNUM INTEGER NUMBER OF INDEX RECORDS +C (INITIALIZE BY SETTING J=-1) +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C (INITIALIZE BY SETTING J=-1) +C OUTPUT ARGUMENTS: +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C NNUM INTEGER NUMBER OF INDEX RECORDS +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE +C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 99 REQUEST NOT FOUND +C +C SUBPROGRAMS CALLED: +C GETGI READ INDEX FILE +C GETGIR READ INDEX BUFFER FROM GRIB FILE +C GETGB1S SEARCH INDEX RECORDS +C LENGDS RETURN THE LENGTH OF A GRID +C +C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200),JENS(200) + INTEGER KPDS(200),KGDS(200),KENS(200) + CHARACTER CBUF(MBUF) + PARAMETER(MSK1=32000,MSK2=4000) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE + IF(J.GE.0) THEN + IF(MNUM.GE.0) THEN + IRGI=0 + ELSE + MNUM=-1-MNUM + IRGI=1 + ENDIF + JR=J-MNUM + IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ELSE + MNUM=J + IRGI=1 + IRGS=1 + ENDIF + ELSE + MNUM=-1-J + IRGI=1 + IRGS=1 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND SEARCH NEXT INDEX BUFFER + JR=0 + DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) + IF(LUGI.GT.0) THEN + CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ELSE + CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ENDIF + IF(IRGI.LE.1) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ GRIB RECORD + IF(IRGI.GT.1) THEN + IRET=96 + ELSEIF(IRGS.NE.0) THEN + IRET=99 + ELSE + KG=LGRIB + KF=LENGDS(KGDS) + IRET=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbemp.f b/WPS/ungrib/src/ngl/w3/getgbemp.f new file mode 100755 index 00000000..b21b83ce --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbemp.f @@ -0,0 +1,271 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBEMP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KG,K,KPDS,KGDS,KENS,G,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBEMP FINDS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED +C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB +C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGBEMP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, +C & MBUF,CBUF,NLEN,NNUM,MNUM, +C & KG,K,KPDS,KGDS,KENS,G,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(23)=2) +C (=-1 FOR WILDCARD) +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C (INITIALIZE BY SETTING J=-1) +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C (INITIALIZE BY SETTING J=-1) +C NNUM INTEGER NUMBER OF INDEX RECORDS +C (INITIALIZE BY SETTING J=-1) +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C (INITIALIZE BY SETTING J=-1) +C OUTPUT ARGUMENTS: +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C NNUM INTEGER NUMBER OF INDEX RECORDS +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C G CHARACTER*1 (KG) GRIB MESSAGE +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF BYTES GREATER THAN JG +C 99 REQUEST NOT FOUND +C +C SUBPROGRAMS CALLED: +C GETGI READ INDEX FILE +C GETGIR READ INDEX BUFFER FROM GRIB FILE +C GETGB1S SEARCH INDEX RECORDS +C BAREAD READ GRIB RECORD +C +C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200),JENS(200) + INTEGER KPDS(200),KGDS(200),KENS(200) + CHARACTER CBUF(MBUF) + CHARACTER G(JG) + PARAMETER(MSK1=32000,MSK2=4000) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE + IF(J.GE.0) THEN + IF(MNUM.GE.0) THEN + IRGI=0 + ELSE + MNUM=-1-MNUM + IRGI=1 + ENDIF + JR=J-MNUM + IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ELSE + MNUM=J + IRGI=1 + IRGS=1 + ENDIF + ELSE + MNUM=-1-J + IRGI=1 + IRGS=1 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND SEARCH NEXT INDEX BUFFER + JR=0 + DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) + IF(LUGI.GT.0) THEN + CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ELSE + CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ENDIF + IF(IRGI.LE.1) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ GRIB RECORD + IF(IRGI.GT.1) THEN + IRET=96 + ELSEIF(IRGS.NE.0) THEN + IRET=99 + ELSEIF(LGRIB.GT.JG) THEN + IRET=98 + ELSE + IRET=97 + CALL BAREAD(LUGB,LSKIP,LGRIB,KG,G) + IF(KG.EQ.LGRIB) IRET=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbens.f b/WPS/ungrib/src/ngl/w3/getgbens.f new file mode 100755 index 00000000..039680ee --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbens.f @@ -0,0 +1,207 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBENS(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, + & KF,K,KPDS,KGDS,KENS,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBENS FINDS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH +C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), +C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE +C RETURN CODE WILL BE NONZERO. +C THIS OBSOLESCENT VERSION HAS BEEN REPLACED BY GETGBE. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGBENS(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, +C & KF,K,KPDS,KGDS,KENS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(23)=2) +C (=-1 FOR WILDCARD) +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C OUTPUT ARGUMENTS: +C KF INTEGER NUMBER OF DATA POINTS UNPACKED +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT +C F REAL (KF) UNPACKED DATA +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF DATA POINTS GREATER THAN JF +C 99 REQUEST NOT FOUND +C OTHER W3FI63 GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C GETGBE FIND AND UNPACK GRIB MESSAGE +C +C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT +C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF +C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEM AS BELOW, +C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200),JENS(200) + INTEGER KPDS(200),KGDS(200),KENS(200) + LOGICAL*1 LB(JF) + REAL F(JF) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + PRINT *,'PLEASE USE GETGBE RATHER THAN GETGBENS' + CALL GETGBE(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, + & KF,K,KPDS,KGDS,KENS,LB,F,IRET) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbep.f b/WPS/ungrib/src/ngl/w3/getgbep.f new file mode 100755 index 00000000..19faea07 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbep.f @@ -0,0 +1,219 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBEP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, + & KG,K,KPDS,KGDS,KENS,G,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBEP FINDS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED +C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB +C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGBEP(LUGB,LUGI,JG,J,JPDS,JGDS,JENS, +C & KG,K,KPDS,KGDS,KENS,G,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(23)=2) +C (=-1 FOR WILDCARD) +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C OUTPUT ARGUMENTS: +C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C G CHARACTER*1 (KG) GRIB MESSAGE +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF BYTES GREATER THAN JG +C 99 REQUEST NOT FOUND +C +C SUBPROGRAMS CALLED: +C GETGBEMP FIND GRIB MESSAGE +C +C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT +C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF +C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEMP AS BELOW, +C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200),JENS(200) + INTEGER KPDS(200),KGDS(200),KENS(200) + CHARACTER G(JG) + PARAMETER(MBUF=256*1024) + CHARACTER CBUF(MBUF) + SAVE CBUF,NLEN,NNUM,MNUM + DATA LUX/0/ +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED + IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN + LUX=LUGI + JJ=MIN(J,-1-J) + ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN + LUX=LUGB + JJ=MIN(J,-1-J) + ELSE + JJ=J + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C FIND AND UNPACK GRIB MESSAGE + CALL GETGBEMP(LUGB,LUGI,JG,JJ,JPDS,JGDS,JENS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KG,K,KPDS,KGDS,KENS,G,IRET) + IF(IRET.EQ.96) LUX=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbex.f b/WPS/ungrib/src/ngl/w3/getgbex.f new file mode 100755 index 00000000..4698b0fa --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbex.f @@ -0,0 +1,233 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBEX(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, + & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, + & LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBEX FINDS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH +C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), +C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE +C RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS +C +C USAGE: CALL GETGBEX(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, +C & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, +C & LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(23)=2) +C (=-1 FOR WILDCARD) +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C OUTPUT ARGUMENTS: +C KF INTEGER NUMBER OF DATA POINTS UNPACKED +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS +C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS +C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS +C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS +C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT +C F REAL (KF) UNPACKED DATA +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF DATA POINTS GREATER THAN JF +C 99 REQUEST NOT FOUND +C OTHER W3FI63 GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C GETGBEXM FIND AND UNPACK GRIB MESSAGE +C +C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT +C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF +C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBEXM AS BELOW, +C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200),JENS(200) + INTEGER KPDS(200),KGDS(200),KENS(200) + INTEGER KPROB(2),KCLUST(16),KMEMBR(80) + REAL XPROB(2) + LOGICAL*1 LB(JF) + REAL F(JF) + PARAMETER(MBUF=256*1024) + CHARACTER CBUF(MBUF) + SAVE CBUF,NLEN,NNUM,MNUM + DATA LUX/0/ +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED + IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN + LUX=LUGI + JJ=MIN(J,-1-J) + ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN + LUX=LUGB + JJ=MIN(J,-1-J) + ELSE + JJ=J + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C FIND AND UNPACK GRIB MESSAGE + CALL GETGBEXM(LUGB,LUGI,JF,JJ,JPDS,JGDS,JENS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, + & LB,F,IRET) + IF(IRET.EQ.96) LUX=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbexm.f b/WPS/ungrib/src/ngl/w3/getgbexm.f new file mode 100755 index 00000000..765c6d5a --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbexm.f @@ -0,0 +1,284 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBEXM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, + & LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBEXM FINDS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH +C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), +C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE +C RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS +C +C USAGE: CALL GETGBEXM(LUGB,LUGI,JF,J,JPDS,JGDS,JENS, +C & MBUF,CBUF,NLEN,NNUM,MNUM, +C & KF,K,KPDS,KGDS,KENS,KPROB,XPROB,KCLUST,KMEMBR, +C & LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C JENS INTEGER (200) ENSEMBLE PDS PARMS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(23)=2) +C (=-1 FOR WILDCARD) +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C (INITIALIZE BY SETTING J=-1) +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C (INITIALIZE BY SETTING J=-1) +C NNUM INTEGER NUMBER OF INDEX RECORDS +C (INITIALIZE BY SETTING J=-1) +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C (INITIALIZE BY SETTING J=-1) +C OUTPUT ARGUMENTS: +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C NNUM INTEGER NUMBER OF INDEX RECORDS +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C KF INTEGER NUMBER OF DATA POINTS UNPACKED +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C KENS INTEGER (200) UNPACKED ENSEMBLE PDS PARMS +C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS +C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS +C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS +C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS +C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT +C F REAL (KF) UNPACKED DATA +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF DATA POINTS GREATER THAN JF +C 99 REQUEST NOT FOUND +C OTHER W3FI63 GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C GETGI READ INDEX FILE +C GETGIR READ INDEX BUFFER FROM GRIB FILE +C GETGB1S SEARCH INDEX RECORDS +C GETGB1RE READ AND UNPACK GRIB RECORD +C LENGDS RETURN THE LENGTH OF A GRID +C +C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200),JENS(200) + INTEGER KPDS(200),KGDS(200),KENS(200) + INTEGER KPROB(2),KCLUST(16),KMEMBR(80) + REAL XPROB(2) + CHARACTER CBUF(MBUF) + LOGICAL*1 LB(JF) + REAL F(JF) + PARAMETER(MSK1=32000,MSK2=4000) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE + IF(J.GE.0) THEN + IF(MNUM.GE.0) THEN + IRGI=0 + ELSE + MNUM=-1-MNUM + IRGI=1 + ENDIF + JR=J-MNUM + IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ELSE + MNUM=J + IRGI=1 + IRGS=1 + ENDIF + ELSE + MNUM=-1-J + IRGI=1 + IRGS=1 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND SEARCH NEXT INDEX BUFFER + JR=0 + DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) + IF(LUGI.GT.0) THEN + CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ELSE + CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ENDIF + IF(IRGI.LE.1) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND UNPACK GRIB RECORD + IF(IRGI.GT.1) THEN + IRET=96 + ELSEIF(IRGS.NE.0) THEN + IRET=99 + ELSEIF(LENGDS(KGDS).GT.JF) THEN + IRET=98 + ELSE + CALL GETGB1RE(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS, + & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbh.f b/WPS/ungrib/src/ngl/w3/getgbh.f new file mode 100755 index 00000000..115dee4a --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbh.f @@ -0,0 +1,206 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBH(LUGB,LUGI,J,JPDS,JGDS, + & KG,KF,K,KPDS,KGDS,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBH FINDS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS +C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE +C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGBH(LUGB,LUGI,J,JPDS,JGDS, +C & KG,KF,K,KPDS,KGDS,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C (ONLY USED IF LUGI=0) +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C OUTPUT ARGUMENTS: +C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE +C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 99 REQUEST NOT FOUND +C +C SUBPROGRAMS CALLED: +C GETGBMH FIND GRIB MESSAGE +C +C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT +C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF +C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBMH AS BELOW, +C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200) + INTEGER KPDS(200),KGDS(200) + PARAMETER(MBUF=256*1024) + CHARACTER CBUF(MBUF) + SAVE CBUF,NLEN,NNUM,MNUM + DATA LUX/0/ +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED + IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN + LUX=LUGI + JJ=MIN(J,-1-J) + ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN + LUX=LUGB + JJ=MIN(J,-1-J) + ELSE + JJ=J + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C FIND AND UNPACK GRIB MESSAGE + CALL GETGBMH(LUGB,LUGI,JJ,JPDS,JGDS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KG,KF,K,KPDS,KGDS,IRET) + IF(IRET.EQ.96) LUX=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbm.f b/WPS/ungrib/src/ngl/w3/getgbm.f new file mode 100755 index 00000000..ce0978b8 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbm.f @@ -0,0 +1,271 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBM(LUGB,LUGI,JF,J,JPDS,JGDS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KF,K,KPDS,KGDS,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBM FINDS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH +C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), +C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE +C RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C 04-07-22 CHUANG ADD NBITSS TO THE ARGUMENT LIST OF GETGB1R THAT +C IS CALLED IN THIS SUBROUTINE +C 10-03-02 WANG INCREASE MSK1 TO 256000000 FOR NEMSIO FILES +C +C USAGE: CALL GETGBM(LUGB,LUGI,JF,J,JPDS,JGDS, +C & MBUF,CBUF,NLEN,NNUM,MNUM, +C & KF,K,KPDS,KGDS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C (INITIALIZE BY SETTING J=-1) +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C (INITIALIZE BY SETTING J=-1) +C NNUM INTEGER NUMBER OF INDEX RECORDS +C (INITIALIZE BY SETTING J=-1) +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C (INITIALIZE BY SETTING J=-1) +C OUTPUT ARGUMENTS: +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C NNUM INTEGER NUMBER OF INDEX RECORDS +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C KF INTEGER NUMBER OF DATA POINTS UNPACKED +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT +C F REAL (KF) UNPACKED DATA +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF DATA POINTS GREATER THAN JF +C 99 REQUEST NOT FOUND +C OTHER W3FI63 GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C GETGI READ INDEX FILE +C GETGIR READ INDEX BUFFER FROM GRIB FILE +C GETGB1S SEARCH INDEX RECORDS +C GETGB1R READ AND UNPACK GRIB RECORD +C LENGDS RETURN THE LENGTH OF A GRID +C +C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200) + INTEGER KPDS(200),KGDS(200) + CHARACTER CBUF(MBUF) + LOGICAL*1 LB(JF) + REAL F(JF) + PARAMETER(MSK1=256000000,MSK2=4000) + INTEGER JENS(200),KENS(200) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE + JENS=-1 + IF(J.GE.0) THEN + IF(MNUM.GE.0) THEN + IRGI=0 + ELSE + MNUM=-1-MNUM + IRGI=1 + ENDIF + JR=J-MNUM + IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ELSE + MNUM=J + IRGI=1 + IRGS=1 + ENDIF + ELSE + MNUM=-1-J + IRGI=1 + IRGS=1 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND SEARCH NEXT INDEX BUFFER + JR=0 + DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) + IF(LUGI.GT.0) THEN + CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ELSE + CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ENDIF + IF(IRGI.LE.1) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND UNPACK GRIB RECORD + IF(IRGI.GT.1) THEN + IRET=96 + ELSEIF(IRGS.NE.0) THEN + IRET=99 + ELSEIF(LENGDS(KGDS).GT.JF) THEN + IRET=98 + ELSE + CALL GETGB1R(LUGB,LSKIP,LGRIB,KF,KPDS,KGDS,KENS,LB,F,NBITSS + + ,IRET) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbmh.f b/WPS/ungrib/src/ngl/w3/getgbmh.f new file mode 100755 index 00000000..6d7f78e8 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbmh.f @@ -0,0 +1,258 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBMH(LUGB,LUGI,J,JPDS,JGDS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KG,KF,K,KPDS,KGDS,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBMH FINDS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN ITS MESSAGE NUMBER IS +C RETURNED ALONG WITH THE UNPACKED PDS AND GDS PARAMETERS. IF THE +C GRIB MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGBMH(LUGB,LUGI,J,JPDS,JGDS, +C & MBUF,CBUF,NLEN,NNUM,MNUM, +C & KG,KF,K,KPDS,KGDS,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C (ONLY USED IF LUGI=0) +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C (INITIALIZE BY SETTING J=-1) +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C (INITIALIZE BY SETTING J=-1) +C NNUM INTEGER NUMBER OF INDEX RECORDS +C (INITIALIZE BY SETTING J=-1) +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C (INITIALIZE BY SETTING J=-1) +C OUTPUT ARGUMENTS: +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C NNUM INTEGER NUMBER OF INDEX RECORDS +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE +C KF INTEGER NUMBER OF DATA POINTS IN THE MESSAGE +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 99 REQUEST NOT FOUND +C +C SUBPROGRAMS CALLED: +C GETGI READ INDEX FILE +C GETGIR READ INDEX BUFFER FROM GRIB FILE +C GETGB1S SEARCH INDEX RECORDS +C LENGDS RETURN THE LENGTH OF A GRID +C +C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200) + INTEGER KPDS(200),KGDS(200) + CHARACTER CBUF(MBUF) + PARAMETER(MSK1=32000,MSK2=4000) + INTEGER JENS(200),KENS(200) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE + JENS=-1 + IF(J.GE.0) THEN + IF(MNUM.GE.0) THEN + IRGI=0 + ELSE + MNUM=-1-MNUM + IRGI=1 + ENDIF + JR=J-MNUM + IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ELSE + MNUM=J + IRGI=1 + IRGS=1 + ENDIF + ELSE + MNUM=-1-J + IRGI=1 + IRGS=1 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND SEARCH NEXT INDEX BUFFER + JR=0 + DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) + IF(LUGI.GT.0) THEN + CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ELSE + CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ENDIF + IF(IRGI.LE.1) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ GRIB RECORD + IF(IRGI.GT.1) THEN + IRET=96 + ELSEIF(IRGS.NE.0) THEN + IRET=99 + ELSE + KG=LGRIB + KF=LENGDS(KGDS) + IRET=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbmp.f b/WPS/ungrib/src/ngl/w3/getgbmp.f new file mode 100755 index 00000000..ca6e1ef1 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbmp.f @@ -0,0 +1,264 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBMP(LUGB,LUGI,JG,J,JPDS,JGDS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KG,K,KPDS,KGDS,G,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBMP FINDS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED +C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB +C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGBMP(LUGB,LUGI,JG,J,JPDS,JGDS, +C & MBUF,CBUF,NLEN,NNUM,MNUM, +C & KG,K,KPDS,KGDS,G,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C MBUF INTEGER LENGTH OF INDEX BUFFER IN BYTES +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C (INITIALIZE BY SETTING J=-1) +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C (INITIALIZE BY SETTING J=-1) +C NNUM INTEGER NUMBER OF INDEX RECORDS +C (INITIALIZE BY SETTING J=-1) +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C (INITIALIZE BY SETTING J=-1) +C OUTPUT ARGUMENTS: +C CBUF CHARACTER*1 (MBUF) INDEX BUFFER +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C NNUM INTEGER NUMBER OF INDEX RECORDS +C MNUM INTEGER NUMBER OF INDEX RECORDS SKIPPED +C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C G CHARACTER*1 (KG) GRIB MESSAGE +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF BYTES GREATER THAN JG +C 99 REQUEST NOT FOUND +C +C SUBPROGRAMS CALLED: +C GETGI READ INDEX FILE +C GETGIR READ INDEX BUFFER FROM GRIB FILE +C GETGB1S SEARCH INDEX RECORDS +C BAREAD READ GRIB RECORD +C +C REMARKS: SPECIFY AN INDEX FILE IF FEASIBLE TO INCREASE SPEED. +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200) + INTEGER KPDS(200),KGDS(200) + CHARACTER CBUF(MBUF) + CHARACTER G(JG) + PARAMETER(MSK1=32000,MSK2=4000) + INTEGER JENS(200),KENS(200) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH PREVIOUS INDEX BUFFER IF POSSIBLE + JENS=-1 + IF(J.GE.0) THEN + IF(MNUM.GE.0) THEN + IRGI=0 + ELSE + MNUM=-1-MNUM + IRGI=1 + ENDIF + JR=J-MNUM + IF(JR.GE.0.AND.(JR.LT.NNUM.OR.IRGI.EQ.0)) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ELSE + MNUM=J + IRGI=1 + IRGS=1 + ENDIF + ELSE + MNUM=-1-J + IRGI=1 + IRGS=1 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ AND SEARCH NEXT INDEX BUFFER + JR=0 + DOWHILE(IRGI.EQ.1.AND.IRGS.EQ.1) + IF(LUGI.GT.0) THEN + CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ELSE + CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRGI) + ENDIF + IF(IRGI.LE.1) THEN + CALL GETGB1S(CBUF,NLEN,NNUM,JR,JPDS,JGDS,JENS, + & KR,KPDS,KGDS,KENS,LSKIP,LGRIB,IRGS) + IF(IRGS.EQ.0) K=KR+MNUM + IF(IRGI.EQ.1.AND.IRGS.EQ.0) MNUM=-1-MNUM + IF(IRGI.EQ.1.AND.IRGS.GT.0) MNUM=MNUM+NNUM + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C READ GRIB RECORD + IF(IRGI.GT.1) THEN + IRET=96 + ELSEIF(IRGS.NE.0) THEN + IRET=99 + ELSEIF(LGRIB.GT.JG) THEN + IRET=98 + ELSE + IRET=97 + CALL BAREAD(LUGB,LSKIP,LGRIB,KG,G) + IF(KG.EQ.LGRIB) IRET=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgbp.f b/WPS/ungrib/src/ngl/w3/getgbp.f new file mode 100755 index 00000000..fdfd486e --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgbp.f @@ -0,0 +1,209 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGBP(LUGB,LUGI,JG,J,JPDS,JGDS, + & KG,K,KPDS,KGDS,G,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGBP FINDS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE. ITS MESSAGE NUMBER IS RETURNED ALONG WITH THE UNPACKED +C PDS AND GDS PARAMETERS AND THE PACKED GRIB MESSAGE. IF THE GRIB +C MESSAGE IS NOT FOUND, THEN THE RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGBP(LUGB,LUGI,JG,J,JPDS,JGDS, +C & KG,K,KPDS,KGDS,G,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JG INTEGER MAXIMUM NUMBER OF BYTES IN THE GRIB MESSAGE +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C OUTPUT ARGUMENTS: +C KG INTEGER NUMBER OF BYTES IN THE GRIB MESSAGE +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C G CHARACTER*1 (KG) GRIB MESSAGE +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF BYTES GREATER THAN JG +C 99 REQUEST NOT FOUND +C +C SUBPROGRAMS CALLED: +C GETGBMP FIND GRIB MESSAGE +C +C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT +C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF +C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBMP AS BELOW, +C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER JPDS(200),JGDS(200),KPDS(200),KGDS(200) + CHARACTER G(JG) + PARAMETER(MBUF=256*1024) + CHARACTER CBUF(MBUF) + SAVE CBUF,NLEN,NNUM,MNUM + DATA LUX/0/ +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE WHETHER INDEX BUFFER NEEDS TO BE INITIALIZED + IF(LUGI.GT.0.AND.(J.LT.0.OR.LUGI.NE.LUX)) THEN + LUX=LUGI + JJ=MIN(J,-1-J) + ELSEIF(LUGI.LE.0.AND.(J.LT.0.OR.LUGB.NE.LUX)) THEN + LUX=LUGB + JJ=MIN(J,-1-J) + ELSE + JJ=J + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C FIND AND UNPACK GRIB MESSAGE + CALL GETGBMP(LUGB,LUGI,JG,JJ,JPDS,JGDS, + & MBUF,CBUF,NLEN,NNUM,MNUM, + & KG,K,KPDS,KGDS,G,IRET) + IF(IRET.EQ.96) LUX=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgi.f b/WPS/ungrib/src/ngl/w3/getgi.f new file mode 100755 index 00000000..0c47dd70 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgi.f @@ -0,0 +1,88 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGI READS A GRIB INDEX FILE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 +C +C ABSTRACT: READ A GRIB INDEX FILE AND RETURN ITS CONTENTS. +C VERSION 1 OF THE INDEX FILE HAS THE FOLLOWING FORMAT: +C 81-BYTE S.LORD HEADER WITH 'GB1IX1' IN COLUMNS 42-47 FOLLOWED BY +C 81-BYTE HEADER WITH NUMBER OF BYTES TO SKIP BEFORE INDEX RECORDS, +C NUMBER OF BYTES IN EACH INDEX RECORD, NUMBER OF INDEX RECORDS, +C AND GRIB FILE BASENAME WRITTEN IN FORMAT ('IX1FORM:',3I10,2X,A40). +C EACH FOLLOWING INDEX RECORD CORRESPONDS TO A GRIB MESSAGE +C AND HAS THE INTERNAL FORMAT: +C BYTE 001-004: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE +C BYTE 005-008: BYTES TO SKIP IN MESSAGE BEFORE PDS +C BYTE 009-012: BYTES TO SKIP IN MESSAGE BEFORE GDS (0 IF NO GDS) +C BYTE 013-016: BYTES TO SKIP IN MESSAGE BEFORE BMS (0 IF NO BMS) +C BYTE 017-020: BYTES TO SKIP IN MESSAGE BEFORE BDS +C BYTE 021-024: BYTES TOTAL IN THE MESSAGE +C BYTE 025-025: GRIB VERSION NUMBER +C BYTE 026-053: PRODUCT DEFINITION SECTION (PDS) +C BYTE 054-095: GRID DEFINITION SECTION (GDS) (OR NULLS) +C BYTE 096-101: FIRST PART OF THE BIT MAP SECTION (BMS) (OR NULLS) +C BYTE 102-112: FIRST PART OF THE BINARY DATA SECTION (BDS) +C BYTE 113-172: (OPTIONAL) BYTES 41-100 OF THE PDS +C BYTE 173-184: (OPTIONAL) BYTES 29-40 OF THE PDS +C BYTE 185-320: (OPTIONAL) BYTES 43-178 OF THE GDS +C +C PROGRAM HISTORY LOG: +C 95-10-31 IREDELL +C 96-10-31 IREDELL AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320 +C +C USAGE: CALL GETGI(LUGI,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) +C INPUT ARGUMENTS: +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C MNUM INTEGER NUMBER OF INDEX RECORDS TO SKIP (USUALLY 0) +C MBUF INTEGER LENGTH OF CBUF IN BYTES +C OUTPUT ARGUMENTS: +C CBUF CHARACTER*1 (MBUF) BUFFER TO RECEIVE INDEX DATA +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C NNUM INTEGER NUMBER OF INDEX RECORDS +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 1 CBUF TOO SMALL TO HOLD INDEX BUFFER +C 2 ERROR READING INDEX FILE BUFFER +C 3 ERROR READING INDEX FILE HEADER +C +C SUBPROGRAMS CALLED: +C BAREAD BYTE-ADDRESSABLE READ +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + CHARACTER CBUF(MBUF) + CHARACTER CHEAD*162 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + NLEN=0 + NNUM=0 + IRET=3 + CALL BAREAD(LUGI,0,162,LHEAD,CHEAD) + IF(LHEAD.EQ.162.AND.CHEAD(42:47).EQ.'GB1IX1') THEN + READ(CHEAD(82:162),'(8X,3I10,2X,A40)',IOSTAT=IOS) NSKP,NLEN,NNUM + IF(IOS.EQ.0) THEN + NSKP=NSKP+MNUM*NLEN + NNUM=NNUM-MNUM + NBUF=NNUM*NLEN + IRET=0 + IF(NBUF.GT.MBUF) THEN + NNUM=MBUF/NLEN + NBUF=NNUM*NLEN + IRET=1 + ENDIF + IF(NBUF.GT.0) THEN + CALL BAREAD(LUGI,NSKP,NBUF,LBUF,CBUF) + IF(LBUF.NE.NBUF) IRET=2 + ENDIF + ENDIF + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/getgir.f b/WPS/ungrib/src/ngl/w3/getgir.f new file mode 100755 index 00000000..e23871ce --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/getgir.f @@ -0,0 +1,90 @@ +C----------------------------------------------------------------------- + SUBROUTINE GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGIR READS A GRIB INDEX FILE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 +C +C ABSTRACT: READ A GRIB FILE AND RETURN ITS INDEX CONTENTS. +C THE INDEX BUFFER RETURNED CONTAINS INDEX RECORDS WITH THE INTERNAL FORMAT: +C BYTE 001-004: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE +C BYTE 005-008: BYTES TO SKIP IN MESSAGE BEFORE PDS +C BYTE 009-012: BYTES TO SKIP IN MESSAGE BEFORE GDS (0 IF NO GDS) +C BYTE 013-016: BYTES TO SKIP IN MESSAGE BEFORE BMS (0 IF NO BMS) +C BYTE 017-020: BYTES TO SKIP IN MESSAGE BEFORE BDS +C BYTE 021-024: BYTES TOTAL IN THE MESSAGE +C BYTE 025-025: GRIB VERSION NUMBER +C BYTE 026-053: PRODUCT DEFINITION SECTION (PDS) +C BYTE 054-095: GRID DEFINITION SECTION (GDS) (OR NULLS) +C BYTE 096-101: FIRST PART OF THE BIT MAP SECTION (BMS) (OR NULLS) +C BYTE 102-112: FIRST PART OF THE BINARY DATA SECTION (BDS) +C BYTE 113-172: (OPTIONAL) BYTES 41-100 OF THE PDS +C BYTE 173-184: (OPTIONAL) BYTES 29-40 OF THE PDS +C BYTE 185-320: (OPTIONAL) BYTES 43-178 OF THE GDS +C +C PROGRAM HISTORY LOG: +C 95-10-31 IREDELL +C 96-10-31 IREDELL AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320 +C +C USAGE: CALL GETGIR(LUGB,MSK1,MSK2,MNUM,MBUF,CBUF,NLEN,NNUM,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB FILE +C MSK1 INTEGER NUMBER OF BYTES TO SEARCH FOR FIRST MESSAGE +C MSK2 INTEGER NUMBER OF BYTES TO SEARCH FOR OTHER MESSAGES +C MNUM INTEGER NUMBER OF INDEX RECORDS TO SKIP (USUALLY 0) +C MBUF INTEGER LENGTH OF CBUF IN BYTES +C OUTPUT ARGUMENTS: +C CBUF CHARACTER*1 (MBUF) BUFFER TO RECEIVE INDEX DATA +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C NNUM INTEGER NUMBER OF INDEX RECORDS +C (=0 IF NO GRIB MESSAGES ARE FOUND) +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 1 CBUF TOO SMALL TO HOLD INDEX DATA +C +C SUBPROGRAMS CALLED: +C SKGB SEEK NEXT GRIB MESSAGE +C IXGB MAKE INDEX RECORD +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + CHARACTER CBUF(MBUF) + PARAMETER(MINDEX=320) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SEARCH FOR FIRST GRIB MESSAGE + ISEEK=0 + CALL SKGB(LUGB,ISEEK,MSK1,LSKIP,LGRIB) + IF(LGRIB.GT.0.AND.MINDEX.LE.MBUF) THEN + CALL IXGB(LUGB,LSKIP,LGRIB,MINDEX,1,NLEN,CBUF) + ELSE + NLEN=MINDEX + ENDIF + DO M=1,MNUM + IF(LGRIB.GT.0) THEN + ISEEK=LSKIP+LGRIB + CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB) + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C MAKE AN INDEX RECORD FOR EVERY GRIB RECORD FOUND + NNUM=0 + IRET=0 + DOWHILE(IRET.EQ.0.AND.LGRIB.GT.0) + IF(NLEN*(NNUM+1).LE.MBUF) THEN + NNUM=NNUM+1 + CALL IXGB(LUGB,LSKIP,LGRIB,NLEN,NNUM,MLEN,CBUF) + ISEEK=LSKIP+LGRIB + CALL SKGB(LUGB,ISEEK,MSK2,LSKIP,LGRIB) + ELSE + IRET=1 + ENDIF + ENDDO +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/grib1.doc b/WPS/ungrib/src/ngl/w3/grib1.doc new file mode 100755 index 00000000..d9e07029 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/grib1.doc @@ -0,0 +1,1321 @@ + GRIB1 USERS GUIDE (FORTRAN 90) + +Contents: + +- Introduction +- GRIB1 Encoding Routines +- GRIB1 Decoding Routine +- Extracting GRIB1 Fields from a GRIB1 file +- GRIB1 Tables +- GRIB1 Routine Docblocks + +=============================================================================== + + Introduction + +This document briefly describes the routines available for encoding/decoding +GRIB Edition 1 messages. A basic familiarity with GRIB is assumed. + +A GRIB message is a machine independent format for storing +one or more gridded data fields. Each GRIB message consists of the +following sections: + +SECTION 0 - Indicator Section +SECTION 1 - Product Definition Section (PDS) +SECTION 2 - Grid Definition Section (GDS) +SECTION 3 - Bit-map Section (Optional) +SECTION 4 - Binary Data Section +SECTION 5 - End Section + +=============================================================================== + + GRIB1 Encoding Routines + +There are several routines that one can use to encode a GRIB1 message. +Subroutine W3FI72 can be used to encode a GRIB1 message which is passed +back to the calling program in a character array. +It is the users responsibility to ensure that the character array that will +hold the packed GRIB1 message has been allocated large enough prior to +calling W3FI72. + +Another option is subroutine PUTGB. PUTGB encodes a GRIB1 message and writes +it to a file. The message is not returned to the calling routine. +The output GRIB1 data file must be opened with a call to subroutine BAOPEN +(or BAOPENW) prior to the call to PUTGB. A call to BACLOSE is recommended at +the end of the program to close the output file properly. + +Example usage: + + integer,dimension(200) :: KPDS,KGDS + logical*1,allocatable :: LB(:) ! bitmap + real,allocatable :: F(:) ! grid point data values + lugb=50 + ! Open GRIB1 file + call baopenw(LUGB,"filename",iret) + + ! Set up bitmap and data field + numpts=?????? + allocate(LB(numpts)) + allocate(F(numpts)) + + ! Set GRIB1 field identification values to encode + KPDS(?)= + KGDS(?)= + + ! pack and write field to file + CALL PUTGB(LUGB,numpts,KPDS,KGDS,LB,F,iret) + + ! Close file ... + call baclose(LUGB,iret) + + stop + end + +There are other similar routines in the PUTGB family that can be used to +encode GRIB1 messages and write them out to a file: +PUTGBEX - Used to encode GRIB1 messages with NCEP PDS + extensions to specify ensemble information. +PUTGN - Allows users to specify a binary scale factor or limit amount of + space each data point should occupy. + +Please see the "GRIB1 Routine Docblocks" section below for subroutine +argument usage for the routines mentioned above. + +=============================================================================== + + GRIB1 Decoding Routine + +Subroutine W3FI63 can be used to decode a given GRIB1 message that resides +in a character array in memory. This routine will return the unpacked values +in the PDS and GDS, a bitmap array, and the unpacked grid point data values. + +It is the users responsibility to ensure that the returned arrays have +been allocated large enough prior to calling W3FI63. + +Please see the "GRIB1 Routine Docblocks" section below for subroutine +argument usage for the routine mentioned above. + +=============================================================================== + + Extracting GRIB1 Fields from a GRIB1 file + +Subroutine GETGB can be used to extract a specified field from a file +containing many GRIB1 messages. GETGB searches an index to find the +location of the user specified field. The index can be supplied from a +separate GRIB1 index file, or it can be generated internally. + +The GRIB1 data file ( and the index file, if supplied ) must be opened with +a call to subroutine BAOPEN prior to the call to GETGB. + +Users can request a particular field by specifying the PDS and GDS +values that they wish to match. GETGB will return the PDS, GDS, bitmap, +and grid point data values. + + +Example usage: + + integer,parameter :: MAXPTS=?????? + integer,dimension(200) :: JPDS,JGDS,KPDS,KGDS + logical*1,dimension(MAXPTS) :: LB ! bitmap + real,dimension(MAXPTS) :: F ! grid point data values + lugb=10 + lugi=0 + ! Open GRIB1 file + call baopenr(LUGB,"filename",iret) + + ! Set GRIB1 field identification values to search for + j=0 ! search from beginning + jpds(?)= + jgds(?)= + + ! Get field from file + CALL GETGB(LUGB,LUGI,MAXPTS,J,JPDS,JGDS, + & KF,K,KPDS,KGDS,LB,F,IRET) + + ! Process field ... + firstval=F(1) + lastval=F(KF) + fldmax=maxval(F) + fldmin=minval(F) + + stop + end + +There are other similar routines in the GETGB family that can be used to +extract data from a GRIB1 file: +GETGBEX - Used to search for and decode GRIB1 messages using NCEP PDS + extensions used to specify ensemble information. +GETGBP - Returns the requested packed GRIB message instead of the unpacked + bitmap and data values. +GETGBH - Returns the full PDS and GDS values of the requested field + without having to unpack the bitmap and grid point data values. + + +Please see the "GRIB1 Routine Docblocks" section below for subroutine +argument usage for the routines mentioned above. + +=============================================================================== + + GRIB1 Tables + +WMO's GRIB1 guide "A GUIDE TO THE CODE FORM FM 92-IX Ext. GRIB" +contains a description of the GRIB1 code form and the master code +table information. This document can be found at +http://www.wmo.ch/web/www/WDM/Guides/Guide-binary.html + +In addition, NCEP Office Note 388 (http://www.nco.ncep.noaa.gov/pmb/docs/on388) +also contains a description of GRIB1 along with master and local NCEP +Code Table values. + +=============================================================================== + + GRIB1 Routine Docblocks + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI72 MAKE A COMPLETE GRIB MESSAGE +C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 +C +C ABSTRACT: MAKES A COMPLETE GRIB MESSAGE FROM A USER SUPPLIED +C ARRAY OF FLOATING POINT OR INTEGER DATA. THE USER HAS THE +C OPTION OF SUPPLYING THE PDS OR AN INTEGER ARRAY THAT WILL BE +C USED TO CREATE A PDS (WITH W3FI68). THE USER MUST ALSO +C SUPPLY OTHER NECESSARY INFO; SEE USAGE SECTION BELOW. +C +C PROGRAM HISTORY LOG: +C 91-05-08 R.E.JONES +C 92-07-01 M. FARLEY ADDED GDS AND BMS LOGIC. PLACED EXISTING +C LOGIC FOR BDS IN A ROUTINE. +C 92-10-02 R.E.JONES ADD ERROR EXIT FOR W3FI73 +C 93-04-30 R.E.JONES REPLACE DO LOOPS TO MOVE CHARACTER DATA +C WITH XMOVEX, USE XSTORE TO ZERO CHARACTER +C ARRAY. MAKE CHANGE SO FLAT FIELD WILL PACK. +C 93-08-06 CAVANAUGH MODIFIED CALL TO W3FI75 +C 93-10-26 CAVANAUGH ADDED CODE TO RESTORE INPUT FIELD TO ORIGINAL +C VALUES IF D-SCALE NOT 0 +C 94-01-27 CAVANAUGH ADDED IGDS ARRAY IN CALL TO W3FI75 TO PROVIDE +C INFORMATION FOR BOUSTROPHEDONIC PROCESSING +C 94-03-03 CAVANAUGH INCREASED SIZE OF GDS ARRAY FOR THIN GRIDS +C 94-05-16 FARLEY CLEANED UP DOCUMENTATION +C 94-11-10 FARLEY INCREASED SIZE OF PFLD/IFLD ARRARYS FROM +C 100K TO 260K FOR .5 DEGREE SST ANAL FIELDS +C 94-12-04 R.E.JONES CHANGE DOCUMENT FOR IPFLAG. +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 98-05-19 Gilbert Increased array dimensions to handle grids +C of up to 500,000 grid points. +C 95-10-31 IREDELL GENERALIZED WORD SIZE +C 98-12-21 Gilbert Replaced Function ICHAR with mova2i. +C 99-02-01 Gilbert Changed the method of zeroing out array KBUF. +C the old method, using W3FI01 and XSTORE was +C incorrect with 4-byte integers and 8-byte reals. +C 2001-06-07 Gilbert Removed calls to xmovex. +C changed IPFLD from integer to character. +C +C USAGE: CALL W3FI72(ITYPE,FLD,IFLD,IBITL, +C & IPFLAG,ID,PDS, +C & IGFLAG,IGRID,IGDS,ICOMP, +C & IBFLAG,IBMAP,IBLEN,IBDSFL, +C & IBDSFL, +C & NPTS,KBUF,ITOT,JERR) +C +C INPUT ARGUMENT LIST: +C ITYPE - 0 = FLOATING POINT DATA SUPPLIED IN ARRAY 'FLD' +C 1 = INTEGER DATA SUPPLIED IN ARRAY 'IFLD' +C FLD - REAL ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE +C CONVERTED TO GRIB FORMAT IF ITYPE=0. +C SEE REMARKS #1 & 2. +C IFLD - INTEGER ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE +C CONVERTED TO GRIB FORMAT IF ITYPE=1. +C SEE REMARKS #1 & 2. +C IBITL - 0 = COMPUTER COMPUTES LENGTH FOR PACKING DATA FROM +C POWER OF 2 (NUMBER OF BITS) BEST FIT OF DATA +C USING 'VARIABLE' BIT PACKER W3FI58. +C 8, 12, ETC. COMPUTER RESCALES DATA TO FIT INTO THAT +C 'FIXED' NUMBER OF BITS USING W3FI59. +C SEE REMARKS #3. +C +C IPFLAG - 0 = MAKE PDS FROM USER SUPPLIED ARRAY (ID) +C 1 = USER SUPPLYING PDS +C NOTE: IF PDS IS GREATER THAN 30, USE IPLFAG=1. +C THE USER COULD CALL W3FI68 BEFORE HE CALLS +C W3FI72. THIS WOULD MAKE THE FIRST 30 BYTES OF +C THE PDS, USER THEN WOULD MAKE BYTES AFTER 30. +C ID - INTEGER ARRAY OF VALUES THAT W3FI68 WILL USE +C TO MAKE AN EDITION 1 PDS IF IPFLAG=0. (SEE THE +C DOCBLOCK FOR W3FI68 FOR LAYOUT OF ARRAY) +C PDS - CHARACTER ARRAY OF VALUES (VALID PDS SUPPLIED +C BY USER) IF IPFLAG=1. LENGTH MAY EXCEED 28 BYTES +C (CONTENTS OF BYTES BEYOND 28 ARE PASSED +C THROUGH UNCHANGED). +C +C IGFLAG - 0 = MAKE GDS BASED ON 'IGRID' VALUE. +C 1 = MAKE GDS FROM USER SUPPLIED INFO IN 'IGDS' +C AND 'IGRID' VALUE. +C SEE REMARKS #4. +C IGRID - # = GRID IDENTIFICATION (TABLE B) +C 255 = IF USER DEFINED GRID; IGDS MUST BE SUPPLIED +C AND IGFLAG MUST =1. +C IGDS - INTEGER ARRAY CONTAINING USER GDS INFO (SAME +C FORMAT AS SUPPLIED BY W3FI71 - SEE DOCKBLOCK FOR +C LAYOUT) IF IGFLAG=1. +C ICOMP - RESOLUTION AND COMPONENT FLAG FOR BIT 5 OF GDS(17) +C 0 = EARTH ORIENTED WINDS +C 1 = GRID ORIENTED WINDS +C +C IBFLAG - 0 = MAKE BIT MAP FROM USER SUPPLIED DATA +C # = BIT MAP PREDEFINED BY CENTER +C SEE REMARKS #5. +C IBMAP - INTEGER ARRAY CONTAINING BIT MAP +C IBLEN - LENGTH OF BIT MAP WILL BE USED TO VERIFY LENGTH +C OF FIELD (ERROR IF IT DOESN'T MATCH). +C +C IBDSFL - INTEGER ARRAY CONTAINING TABLE 11 FLAG INFO +C BDS OCTET 4: +C (1) 0 = GRID POINT DATA +C 1 = SPHERICAL HARMONIC COEFFICIENTS +C (2) 0 = SIMPLE PACKING +C 1 = SECOND ORDER PACKING +C (3) ... SAME VALUE AS 'ITYPE' +C 0 = ORIGINAL DATA WERE FLOATING POINT VALUES +C 1 = ORIGINAL DATA WERE INTEGER VALUES +C (4) 0 = NO ADDITIONAL FLAGS AT OCTET 14 +C 1 = OCTET 14 CONTAINS FLAG BITS 5-12 +C (5) 0 = RESERVED - ALWAYS SET TO 0 +C BYTE 6 OPTION 1 NOT AVAILABLE (AS OF 5-16-93) +C (6) 0 = SINGLE DATUM AT EACH GRID POINT +C 1 = MATRIX OF VALUES AT EACH GRID POINT +C BYTE 7 OPTION 0 WITH SECOND ORDER PACKING N/A (AS OF 5-16-93) +C (7) 0 = NO SECONDARY BIT MAPS +C 1 = SECONDARY BIT MAPS PRESENT +C (8) 0 = SECOND ORDER VALUES HAVE CONSTANT WIDTH +C 1 = SECOND ORDER VALUES HAVE DIFFERENT WIDTHS +C +C OUTPUT ARGUMENT LIST: +C NPTS - NUMBER OF GRIDPOINTS IN ARRAY FLD OR IFLD +C KBUF - ENTIRE GRIB MESSAGE ('GRIB' TO '7777') +C EQUIVALENCE TO INTEGER ARRAY TO MAKE SURE IT +C IS ON WORD BOUNARY. +C ITOT - TOTAL LENGTH OF GRIB MESSAGE IN BYTES +C JERR - = 0, COMPLETED MAKING GRIB FIELD WITHOUT ERROR +C 1, IPFLAG NOT 0 OR 1 +C 2, IGFLAG NOT 0 OR 1 +C 3, ERROR CONVERTING IEEE F.P. NUMBER TO IBM370 F.P. +C 4, W3FI71 ERROR/IGRID NOT DEFINED +C 5, W3FK74 ERROR/GRID REPRESENTATION TYPE NOT VALID +C 6, GRID TOO LARGE FOR PACKER DIMENSION ARRAYS +C SEE AUTOMATION DIVISION FOR REVISION! +C 7, LENGTH OF BIT MAP NOT EQUAL TO SIZE OF FLD/IFLD +C 8, W3FI73 ERROR, ALL VALUES IN IBMAP ARE ZERO +C +C OUTPUT FILES: +C FT06F001 - STANDARD FORTRAN OUTPUT PRINT FILE +C +C SUBPROGRAMS CALLED: +C LIBRARY: +C W3LIB - W3FI58, W3FI59, W3FI68, W3FI71, W3FI73, W3FI74 +C W3FI75, W3FI76 +C FORTRAN 90 INTRINSIC - BIT_SIZE +C +C REMARKS: +C 1) IF BIT MAP TO BE INCLUDED IN MESSAGE, NULL DATA SHOULD +C BE INCLUDED IN FLD OR IFLD. THIS ROUTINE WILL TAKE CARE +C OF 'DISCARDING' ANY NULL DATA BASED ON THE BIT MAP. +C 2) UNITS MUST BE THOSE IN GRIB DOCUMENTATION: NMC O.N. 388 +C OR WMO PUBLICATION 306. +C 3) IN EITHER CASE, INPUT NUMBERS WILL BE MULTIPLIED BY +C '10 TO THE NTH' POWER FOUND IN ID(25) OR PDS(27-28), +C THE D-SCALING FACTOR, PRIOR TO BINARY PACKING. +C 4) ALL NMC PRODUCED GRIB FIELDS WILL HAVE A GRID DEFINITION +C SECTION INCLUDED IN THE GRIB MESSAGE. ID(6) WILL BE +C SET TO '1'. +C - GDS WILL BE BUILT BASED ON GRID NUMBER (IGRID), UNLESS +C IGFLAG=1 (USER SUPPLYING IGDS). USER MUST STILL SUPPLY +C IGRID EVEN IF IGDS PROVIDED. +C 5) IF BIT MAP USED THEN ID(7) OR PDS(8) MUST INDICATE THE +C PRESENCE OF A BIT MAP. +C 6) ARRAY KBUF SHOULD BE EQUIVALENCED TO AN INTEGER VALUE OR +C ARRAY TO MAKE SURE IT IS ON A WORD BOUNDARY. +C 7) SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PUTGB PACKS AND WRITES A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. +C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGB. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL PUTGB(LUGB,KF,KPDS,KGDS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C KF INTEGER NUMBER OF DATA POINTS +C KPDS INTEGER (200) PDS PARAMETERS +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C KGDS INTEGER (200) GDS PARAMETERS +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C LB LOGICAL*1 (KF) BITMAP IF PRESENT +C F REAL (KF) DATA +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C 0 ALL OK +C OTHER W3FI72 GRIB PACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS +C GETBIT GET NUMBER OF BITS AND ROUND DATA +C W3FI72 PACK GRIB +C WRYTE WRITE DATA +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + + + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI63 UNPK GRIB FIELD TO GRIB GRID +C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 +C +C ABSTRACT: UNPACK A GRIB (EDITION 1) FIELD TO THE EXACT GRID +C SPECIFIED IN THE GRIB MESSAGE, ISOLATE THE BIT MAP, AND MAKE +C THE VALUES OF THE PRODUCT DESCRIPTON SECTION (PDS) AND THE +C GRID DESCRIPTION SECTION (GDS) AVAILABLE IN RETURN ARRAYS. +C +C WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN +C RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL. +C +C PROGRAM HISTORY LOG: +C 91-09-13 CAVANAUGH +C 91-11-12 CAVANAUGH MODIFIED SIZE OF ECMWF GRIDS 5-8 +C 91-12-22 CAVANAUGH CORRECTED PROCESSING OF MERCATOR PROJECTIONS +C IN GRID DEFINITION SECTION (GDS) IN +C ROUTINE FI633 +C 92-08-05 CAVANAUGH CORRECTED MAXIMUM GRID SIZE TO ALLOW FOR +C ONE DEGREE BY ONE DEGREE GLOBAL GRIDS +C 92-08-27 CAVANAUGH CORRECTED TYPO ERROR, ADDED CODE TO COMPARE +C TOTAL BYTE SIZE FROM SECTION 0 WITH SUM OF +C SECTION SIZES. +C 92-10-21 CAVANAUGH CORRECTIONS WERE MADE (IN FI634) TO REDUCE +C PROCESSING TIME FOR INTERNATIONAL GRIDS. +C REMOVED A TYPOGRAPHICAL ERROR IN FI635. +C 93-01-07 CAVANAUGH CORRECTIONS WERE MADE (IN FI635) TO +C FACILITATE USE OF THESE ROUTINES ON A PC. +C A TYPOGRAPHICAL ERROR WAS ALSO CORRECTED +C 93-01-13 CAVANAUGH CORRECTIONS WERE MADE (IN FI632) TO +C PROPERLY HANDLE CONDITION WHEN +C TIME RANGE INDICATOR = 10. +C ADDED U.S.GRID 87. +C 93-02-04 CAVANAUGH ADDED U.S.GRIDS 85 AND 86 +C 93-02-26 CAVANAUGH ADDED GRIDS 2, 3, 37 THRU 44,AND +C GRIDS 55, 56, 90, 91, 92, AND 93 TO +C LIST OF U.S. GRIDS. +C 93-04-07 CAVANAUGH ADDED GRIDS 67 THRU 77 TO +C LIST OF U.S. GRIDS. +C 93-04-20 CAVANAUGH INCREASED MAX SIZE TO ACCOMODATE +C GAUSSIAN GRIDS. +C 93-05-26 CAVANAUGH CORRECTED GRID RANGE SELECTION IN FI634 +C FOR RANGES 67-71 & 75-77 +C 93-06-08 CAVANAUGH CORRECTED FI635 TO ACCEPT GRIB MESSAGES +C WITH SECOND ORDER PACKING. ADDED ROUTINE FI636 +C TO PROCESS MESSAGES WITH SECOND ORDER PACKING. +C 93-09-22 CAVANAUGH MODIFIED TO EXTRACT SUB-CENTER NUMBER FROM +C PDS BYTE 26 +C 93-10-13 CAVANAUGH MODIFIED FI634 TO CORRECT GRID SIZES FOR +C GRIDS 204 AND 208 +C 93-10-14 CAVANAUGH INCREASED SIZE OF KGDS TO INCLUDE ENTRIES FOR +C NUMBER OF POINTS IN GRID AND NUMBER OF WORDS +C IN EACH ROW +C 93-12-08 CAVANAUGH CORRECTED TEST FOR EDITION NUMBER INSTEAD +C OF VERSION NUMBER +C 93-12-15 CAVANAUGH MODIFIED SECOND ORDER POINTERS TO FIRST ORDER +C VALUES AND SECOND ORDER VALUES CORRECTLY +C IN ROUTINE FI636 +C 94-03-02 CAVANAUGH ADDED CALL TO W3FI83 WITHIN DECODER. USER +C NO LONGER NEEDS TO MAKE CALL TO THIS ROUTINE +C 94-04-22 CAVANAUGH MODIFIED FI635, FI636 TO PROCESS ROW BY ROW +C SECOND ORDER PACKING, ADDED SCALING CORRECTION +C TO FI635, AND CORRECTED TYPOGRAPHICAL ERRORS +C IN COMMENT FIELDS IN FI634 +C 94-05-17 CAVANAUGH CORRECTED ERROR IN FI633 TO EXTRACT RESOLUTION +C FOR LAMBERT-CONFORMAL GRIDS. ADDED CLARIFYING +C INFORMATION TO DOCBLOCK ENTRIES +C 94-05-25 CAVANAUGH ADDED CODE TO PROCESS COLUMN BY COLUMN AS WELL +C AS ROW BY ROW ORDERING OF SECOND ORDER DATA +C 94-06-27 CAVANAUGH ADDED PROCESSING FOR GRIDS 45, 94 AND 95. +C INCLUDES CONSTRUCTION OF SECOND ORDER BIT MAPS +C FOR THINNED GRIDS IN FI636. +C 94-07-08 CAVANAUGH COMMENTED OUT PRINT OUTS USED FOR DEBUGGING +C 94-09-08 CAVANAUGH ADDED GRIDS 220, 221, 223 FOR FNOC +C 94-11-10 FARLEY INCREASED MXSIZE FROM 72960 TO 260000 +C FOR .5 DEGREE SST ANALYSIS FIELDS +C 94-12-06 R.E.JONES CHANGES IN FI632 FOR PDS GREATER THAN 28 +C 95-02-14 R.E.JONES CORRECT IN FI633 FOR NAVY WAFS GRIB +C 95-03-20 M.BALDWIN FI633 MODIFICATION TO GET +C DATA REP TYPES [KGDS(1)] 201 AND 202 TO WORK. +C 95-04-10 E.ROGERS ADDED GRIDS 96 AND 97 FOR ETA MODEL IN FI634. +C 95-04-26 R.E.JONES FI636 CORECTION FOR 2ND ORDER COMPLEX +C UNPACKING. R +C 95-05-19 R.E.JONES ADDED GRID 215, 20 KM AWIPS GRID +C 95-07-06 R.E.JONES ADDED GAUSSIAN T62, T126 GRID 98, 126 +C 95-10-19 R.E.JONES ADDED GRID 216, 45 KM ETA AWIPS ALASKA GRID +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 96-03-07 R.E.JONES CONTINUE UNPACK WITH KRET ERROR 9 IN FI631. +C 96-08-19 R.E.JONES ADDED MERCATOR GRIDS 8 AND 53, AND GRID 196 +C 97-02-12 W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING +C 98-06-17 IREDELL REMOVED ALTERNATE RETURN IN FI637 +C 98-08-31 IREDELL ELIMINATED NEED FOR MXSIZE +C 98-09-02 Gilbert Corrected error in map size for U.S. Grid 92 +C 98-09-08 BALDWIN ADD DATA REP TYPE [KGDS(1)] 203 +C 01-03-08 ROGERS CHANGED ETA GRIDS 90-97, ADDED ETA GRIDS +C 194, 198. ADDED AWIPS GRIDS 241,242,243, +C 245, 246, 247, 248, AND 250 +C 01-03-19 VUONG ADDED AWIPS GRIDS 238,239,240, AND 244. +C 2001-06-06 GILBERT CHanged gbyte/sbyte calls to refer to +C Wesley Ebisuzaki's endian independent +C versions gbytec/sbytec. +C Removed equivalences. +C 01-05-03 ROGERS ADDED GRID 249 (12KM FOR ALASKA) +C 01-10-10 ROGERS REDEFINED GRID 218 FOR 12 KM ETA +C REDEFINED GRID 192 FOR NEW 32-KM ETA GRID +C 02-03-27 VUONG ADDED RSAS GRID 88 AND AWIPS GRIDS 219, 220, +C 223, 224, 225, 226, 227, 228, 229, 230, 231, +C 232, 233, 234, 235, 251, AND 252 +C 02-08-06 ROGERS REDEFINED GRIDS 90-93,97,194,245-250 FOR THE +C 8KM HI-RES-WINDOW MODEL AND ADD AWIPS GRID 253 +C 2003-06-30 GILBERT SET NEW VALUES IN ARRAY KPTR TO PASS BACK ADDITIONAL +C PACKING INFO. +C KPTR(19) - BINARY SCALE FACTOR +C KPTR(20) - NUM BITS USED TO PACK EACH DATUM +C 2003-06-30 GILBERT ADDED GRIDS 145 and 146 for CMAQ +C and GRID 175 for AWIPS over GUAM. +C 2003-07-08 VUONG ADDED GRIDS 110, 127, 171, 172 AND MODIFIED GRID 170 +C +C USAGE: CALL W3FI63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET) +C INPUT ARGUMENT LIST: +C MSGA - GRIB FIELD - "GRIB" THRU "7777" CHAR*1 +C (MESSAGE CAN BE PRECEDED BY JUNK CHARS) +C +C OUTPUT ARGUMENT LIST: +C DATA - ARRAY CONTAINING DATA ELEMENTS +C KPDS - ARRAY CONTAINING PDS ELEMENTS. (EDITION 1) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C (26-35) - RESERVED +C (36-N) - CONSECUTIVE BYTES EXTRACTED FROM PROGRAM +C DEFINITION SECTION (PDS) OF GRIB MESSAGE +C KGDS - ARRAY CONTAINING GDS ELEMENTS. +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (TYPE 203) +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF CENTER +C (8) - LO(2) LONGITUDE OF CENTER +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. +C (ALWAYS CONSTRUCTED) +C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS +C (1) - TOTAL LENGTH OF GRIB MESSAGE +C (2) - LENGTH OF INDICATOR (SECTION 0) +C (3) - LENGTH OF PDS (SECTION 1) +C (4) - LENGTH OF GDS (SECTION 2) +C (5) - LENGTH OF BMS (SECTION 3) +C (6) - LENGTH OF BDS (SECTION 4) +C (7) - VALUE OF CURRENT BYTE +C (8) - BIT POINTER +C (9) - GRIB START BIT NR +C (10) - GRIB/GRID ELEMENT COUNT +C (11) - NR UNUSED BITS AT END OF SECTION 3 +C (12) - BIT MAP FLAG (COPY OF BMS OCTETS 5,6) +C (13) - NR UNUSED BITS AT END OF SECTION 2 +C (14) - BDS FLAGS (RIGHT ADJ COPY OF OCTET 4) +C (15) - NR UNUSED BITS AT END OF SECTION 4 +C (16) - RESERVED +C (17) - RESERVED +C (18) - RESERVED +C (19) - BINARY SCALE FACTOR +C (20) - NUM BITS USED TO PACK EACH DATUM +C KRET - FLAG INDICATING QUALITY OF COMPLETION +C +C REMARKS: WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN +C RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL. +C +C VALUES FOR RETURN FLAG (KRET) +C KRET = 0 - NORMAL RETURN, NO ERRORS +C = 1 - 'GRIB' NOT FOUND IN FIRST 100 CHARS +C = 2 - '7777' NOT IN CORRECT LOCATION +C = 3 - UNPACKED FIELD IS LARGER THAN 260000 +C = 4 - GDS/ GRID NOT ONE OF CURRENTLY ACCEPTED VALUES +C = 5 - GRID NOT CURRENTLY AVAIL FOR CENTER INDICATED +C = 8 - TEMP GDS INDICATED, BUT GDS FLAG IS OFF +C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID +C =10 - INCORRECT CENTER INDICATOR +C =11 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED. +C PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS +C SHOWN IN OCTETS 4 AND 14. +C =12 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED. +C PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS +C +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ +C 4 AUG 1988 +C W3FI63 +C +C +C GRIB UNPACKING ROUTINE +C +C +C THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID +C TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE +C VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID +C DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS. +C SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT +C INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN +C GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE +C DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER. +C +C THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS: +C +C CALL W3FI63(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET) +C +C INPUT: +C +C MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS +C "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES. +C +C OUTPUT: +C +C KPDS(100) INTEGER*4 +C ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT +C DEFINITION SEC . +C (VERSION 1) +C KPDS(1) - ID OF CENTER +C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1) +C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2) +C KPDS(4) - GDS/BMS FLAG +C BIT DEFINITION +C 25 0 - GDS OMITTED +C 1 - GDS INCLUDED +C 26 0 - BMS OMITTED +C 1 - BMS INCLUDED +C NOTE:- LEFTMOST BIT = 1, +C RIGHTMOST BIT = 32 +C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5) +C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7) +C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL +C KPDS(8) - YEAR INCLUDING CENTURY +C KPDS(9) - MONTH OF YEAR +C KPDS(10) - DAY OF MONTH +C KPDS(11) - HOUR OF DAY +C KPDS(12) - MINUTE OF HOUR +C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB" +C TABLE 8) +C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A) +C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A) +C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A) +C KPDS(17) - NUMBER INCLUDED IN AVERAGE +C KPDS(18) - EDITION NR OF GRIB SPECIFICATION +C KPDS(19) - VERSION NR OF PARAMETER TABLE +C +C KGDS(13) INTEGER*4 +C ARRAY CONTAINING GDS ELEMENTS. +C +C KGDS(1) - DATA REPRESENTATION TYPE +C +C LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10) +C KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE +C CIRCLE +C KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE +C CIRCLE +C KGDS(4) - LA(1) LATITUDE OF ORIGIN +C KGDS(5) - LO(1) LONGITUDE OF ORIGIN +C KGDS(6) - RESOLUTION FLAG +C BIT MEANING +C 25 0 - DIRECTION INCREMENTS NOT +C GIVEN +C 1 - DIRECTION INCREMENTS GIVEN +C KGDS(7) - LA(2) LATITUDE OF EXTREME POINT +C KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT +C KGDS(9) - DI LONGITUDINAL DIRECTION INCREMENT +C KGDS(10) - REGULAR LAT/LON GRID +C DJ - LATITUDINAL DIRECTION +C INCREMENT +C GAUSSIAN GRID +C N - NUMBER OF LATITUDE CIRCLES +C BETWEEN A POLE AND THE EQUATOR +C KGDS(11) - SCANNING MODE FLAG +C BIT MEANING +C 25 0 - POINTS ALONG A LATITUDE +C SCAN FROM WEST TO EAST +C 1 - POINTS ALONG A LATITUDE +C SCAN FROM EAST TO WEST +C 26 0 - POINTS ALONG A MERIDIAN +C SCAN FROM NORTH TO SOUTH +C 1 - POINTS ALONG A MERIDIAN +C SCAN FROM SOUTH TO NORTH +C 27 0 - POINTS SCAN FIRST ALONG +C CIRCLES OF LATITUDE, THEN +C ALONG MERIDIANS +C (FORTRAN: (I,J)) +C 1 - POINTS SCAN FIRST ALONG +C MERIDIANS THEN ALONG +C CIRCLES OF LATITUDE +C (FORTRAN: (J,I)) +C +C POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12) +C KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE +C KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE +C KGDS(4) - LA(1) LATITUDE OF ORIGIN +C KGDS(5) - LO(1) LONGITUDE OF ORIGIN +C KGDS(6) - RESERVED +C KGDS(7) - LOV GRID ORIENTATION +C KGDS(8) - DX - X DIRECTION INCREMENT +C KGDS(9) - DY - Y DIRECTION INCREMENT +C KGDS(10) - PROJECTION CENTER FLAG +C KGDS(11) - SCANNING MODE +C +C SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14) +C KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER +C KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER +C KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER +C KGDS(5) - REPRESENTATION TYPE +C KGDS(6) - COEFFICIENT STORAGE MODE +C +C MERCATOR GRIDS +C KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE +C KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C KGDS(4) - LA(1) LATITUDE OF ORIGIN +C KGDS(5) - LO(1) LONGITUDE OF ORIGIN +C KGDS(6) - RESOLUTION FLAG +C KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT +C KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT +C KGDS(9) - LATIN - LATITUDE OF PROJECTION INTERSECTION +C KGDS(10) - RESERVED +C KGDS(11) - SCANNING MODE FLAG +C KGDS(12) - LONGITUDINAL DIR GRID LENGTH +C KGDS(13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C KGDS(2) - NX NR POINTS ALONG X-AXIS +C KGDS(3) - NY NR POINTS ALONG Y-AXIS +C KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT) +C KGDS(6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C KGDS(7) - LOV - ORIENTATION OF GRID +C KGDS(8) - DX - X-DIR INCREMENT +C KGDS(9) - DY - Y-DIR INCREMENT +C KGDS(10) - PROJECTION CENTER FLAG +C KGDS(11) - SCANNING MODE FLAG +C KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF +C SECANT CONE INTERSECTION +C KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF +C SECANT CONE INTERSECTION +C +C LBMS(*) LOGICAL +C ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE +C PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A +C BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE, +C ONE WILL BE GENERATED AUTOMATICALLY BY THE +C UNPACKING ROUTINE. +C +C +C DATA(*) REAL*4 +C THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS. +C +C NOTE:- 65160 IS MAXIMUN FIELD SIZE ALLOWABLE +C +C KPTR(10) INTEGER*4 +C ARRAY CONTAINING STORAGE FOR THE FOLLOWING +C PARAMETERS. +C +C (1) - UNUSED +C (2) - UNUSED +C (3) - LENGTH OF PDS (IN BYTES) +C (4) - LENGTH OF GDS (IN BYTES) +C (5) - LENGTH OF BMS (IN BYTES) +C (6) - LENGTH OF BDS (IN BYTES) +C (7) - USED BY UNPACKING ROUTINE +C (8) - NUMBER OF DATA POINTS FOR GRID +C (9) - "GRIB" CHARACTERS START IN BYTE NUMBER +C (10) - USED BY UNPACKING ROUTINE +C +C +C KRET INTEGER*4 +C THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR. +C +C 0 - NO ERRORS DETECTED. +C +C 1 - 'GRIB' NOT FOUND IN FIRST 100 +C CHARACTERS. +C +C 2 - '7777' NOT FOUND, EITHER MISSING OR +C TOTAL OF SEC COUNTS OF INDIVIDUAL +C SECTIONS IS INCORRECT. +C +C 3 - UNPACKED FIELD IS LARGER THAN 65160. +C +C 4 - IN GDS, DATA REPRESENTATION TYPE +C NOT ONE OF THE CURRENTLY ACCEPTABLE +C VALUES. SEE "GRIB" TABLE 9. VALUE +C OF INCORRECT TYPE RETURNED IN KGDS(1). +C +C 5 - GRID INDICATED IN KPDS(3) IS NOT +C AVAILABLE FOR THE CENTER INDICATED IN +C KPDS(1) AND NO GDS SENT. +C +C 7 - EDITION INDICATED IN KPDS(18) HAS NOT +C YET BEEN INCLUDED IN THE DECODER. +C +C 8 - GRID IDENTIFICATION = 255 (NOT STANDARD +C GRID) BUT FLAG INDICATING PRESENCE OF +C GDS IS TURNED OFF. NO METHOD OF +C GENERATING PROPER GRID. +C +C 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT +C MATCH STANDARD NUMBER OF POINTS FOR THIS +C GRID (FOR OTHER THAN SPECTRALS). THIS +C WILL OCCUR ONLY IF THE GRID. +C IDENTIFICATION, KPDS(3), AND A +C TRANSMITTED GDS ARE INCONSISTENT. +C +C 10 - CENTER INDICATOR WAS NOT ONE INDICATED +C IN "GRIB" TABLE 1. PLEASE CONTACT AD +C PRODUCTION MANAGEMENT BRANCH (W/NMC42) +C IF THIS ERROR IS ENCOUNTERED. +C +C 11 - BINARY DATA SECTION (BDS) NOT COMPLETELY +C PROCESSED. PROGRAM IS NOT SET TO PROCESS +C FLAG COMBINATIONS AS SHOWN IN +C OCTETS 4 AND 14. +C +C +C LIST OF TEXT MESSAGES FROM CODE +C +C +C W3FI63/FI632 +C +C 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY +C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH +C (W/NMC42)' +C +C 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY +C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH +C (W/NMC42)' +C +C 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL +C OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION, +C PRODUCTION MANAGEMENT BRANCH (W/NMC42)' +C +C 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY +C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH +C (W/NMC42)' +C +C +C W3FI63/FI633 +C +C 'POLAR STEREO PROCESSING NOT AVAILABLE' * +C +C W3FI63/FI634 +C +C 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL +C COEFFICIENTS' +C +C +C W3FI63/FI637 +C +C 'NO CURRENT LISTING OF FNOC GRIDS' * +C +C +C * WILL BE AVAILABLE IN NEXT UPDATE +C *************************************************************** + + + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: GETGB FINDS AND UNPACKS A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: FIND AND UNPACK A GRIB MESSAGE. +C READ A GRIB INDEX FILE (OR OPTIONALLY THE GRIB FILE ITSELF) +C TO GET THE INDEX BUFFER (I.E. TABLE OF CONTENTS) FOR THE GRIB FILE. +C (THE INDEX BUFFER IS SAVED FOR USE BY FUTURE PROSPECTIVE CALLS.) +C FIND IN THE INDEX BUFFER A REFERENCE TO THE GRIB MESSAGE REQUESTED. +C THE GRIB MESSAGE REQUEST SPECIFIES THE NUMBER OF MESSAGES TO SKIP +C AND THE UNPACKED PDS AND GDS PARAMETERS. (A REQUESTED PARAMETER +C OF -1 MEANS TO ALLOW ANY VALUE OF THIS PARAMETER TO BE FOUND.) +C IF THE REQUESTED GRIB MESSAGE IS FOUND, THEN IT IS READ FROM THE +C GRIB FILE AND UNPACKED. ITS MESSAGE NUMBER IS RETURNED ALONG WITH +C THE UNPACKED PDS AND GDS PARAMETERS, THE UNPACKED BITMAP (IF ANY), +C AND THE UNPACKED DATA. IF THE GRIB MESSAGE IS NOT FOUND, THEN THE +C RETURN CODE WILL BE NONZERO. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL MODULARIZED PORTIONS OF CODE INTO SUBPROGRAMS +C AND ALLOWED FOR UNSPECIFIED INDEX FILE +C +C USAGE: CALL GETGB(LUGB,LUGI,JF,J,JPDS,JGDS, +C & KF,K,KPDS,KGDS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C LUGI INTEGER UNIT OF THE UNBLOCKED GRIB INDEX FILE +C (=0 TO GET INDEX BUFFER FROM THE GRIB FILE) +C JF INTEGER MAXIMUM NUMBER OF DATA POINTS TO UNPACK +C J INTEGER NUMBER OF MESSAGES TO SKIP +C (=0 TO SEARCH FROM BEGINNING) +C (<0 TO READ INDEX BUFFER AND SKIP -1-J MESSAGES) +C JPDS INTEGER (200) PDS PARAMETERS FOR WHICH TO SEARCH +C (=-1 FOR WILDCARD) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C JGDS INTEGER (200) GDS PARAMETERS FOR WHICH TO SEARCH +C (ONLY SEARCHED IF JPDS(3)=255) +C (=-1 FOR WILDCARD) +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C OUTPUT ARGUMENTS: +C KF INTEGER NUMBER OF DATA POINTS UNPACKED +C K INTEGER MESSAGE NUMBER UNPACKED +C (CAN BE SAME AS J IN CALLING PROGRAM +C IN ORDER TO FACILITATE MULTIPLE SEARCHES) +C KPDS INTEGER (200) UNPACKED PDS PARAMETERS +C KGDS INTEGER (200) UNPACKED GDS PARAMETERS +C LB LOGICAL*1 (KF) UNPACKED BITMAP IF PRESENT +C F REAL (KF) UNPACKED DATA +C IRET INTEGER RETURN CODE +C 0 ALL OK +C 96 ERROR READING INDEX FILE +C 97 ERROR READING GRIB FILE +C 98 NUMBER OF DATA POINTS GREATER THAN JF +C 99 REQUEST NOT FOUND +C OTHER W3FI63 GRIB UNPACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C GETGBM FIND AND UNPACK GRIB MESSAGE +C +C REMARKS: IN ORDER TO UNPACK GRIB FROM A MULTIPROCESSING ENVIRONMENT +C WHERE EACH PROCESSOR IS ATTEMPTING TO READ FROM ITS OWN PAIR OF +C LOGICAL UNITS, ONE MUST DIRECTLY CALL SUBPROGRAM GETGBM AS BELOW, +C ALLOCATING A PRIVATE COPY OF CBUF, NLEN AND NNUM TO EACH PROCESSOR. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + + + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BAOPEN BYTE-ADDRESSABLE OPEN +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: OPEN A BYTE-ADDRESSABLE FILE. +C +C PROGRAM HISTORY LOG: +C 1998-06-04 IREDELL +C +C USAGE: CALL BAOPEN(LU,CFN,IRET) +C INPUT ARGUMENTS: +C LU INTEGER UNIT TO OPEN +C CFN CHARACTER FILENAME TO OPEN +C (CONSISTING OF NONBLANK PRINTABLE CHARACTERS) +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C SUBPROGRAMS CALLED: +C BACIO BYTE-ADDRESSABLE I/O C PACKAGE +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ + + +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: BACLOSE BYTE-ADDRESSABLE CLOSE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 1998-06-04 +C +C ABSTRACT: CLOSE A BYTE-ADDRESSABLE FILE. +C +C PROGRAM HISTORY LOG: +C 1998-06-04 IREDELL +C +C USAGE: CALL BACLOSE(LU,IRET) +C INPUT ARGUMENTS: +C LU INTEGER UNIT TO CLOSE +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C +C MODULES USED: +C BACIO_MODULE BYTE-ADDRESSABLE I/O FORTRAN INTERFACE +C +C SUBPROGRAMS CALLED: +C BACIO BYTE-ADDRESSABLE I/O C PACKAGE +C +C REMARKS: A BAOPEN MUST HAVE ALREADY BEEN CALLED. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ diff --git a/WPS/ungrib/src/ngl/w3/idsdef.f b/WPS/ungrib/src/ngl/w3/idsdef.f new file mode 100755 index 00000000..ca8862c9 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/idsdef.f @@ -0,0 +1,285 @@ + SUBROUTINE IDSDEF(IPTV,IDS) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IDSDEF SETS DEFAULT DECIMAL SCALINGS +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 +C +C ABSTRACT: SETS DECIMAL SCALINGS DEFAULTS FOR VARIOUS PARAMETERS. +C A DECIMAL SCALING OF -3 MEANS DATA IS PACKED IN KILO-SI UNITS. +C +C PROGRAM HISTORY LOG: +C 92-10-31 IREDELL +C +C USAGE: CALL IDSDEF(IPTV,IDS) +C INPUT ARGUMENTS: +C IPTV PARAMTER TABLE VERSION (ONLY 1 OR 2 IS RECOGNIZED) +C OUTPUT ARGUMENTS: +C IDS INTEGER (255) DECIMAL SCALINGS +C (UNKNOWN DECIMAL SCALINGS WILL NOT BE SET) +C +C ATTRIBUTES: +C LANGUAGE: CRAY FORTRAN +C +C$$$ + DIMENSION IDS(255) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + IF(IPTV.EQ.1.OR.IPTV.EQ.2) THEN + IDS(001)=-1 ! PRESSURE (PA) + IDS(002)=-1 ! SEA-LEVEL PRESSURE (PA) + IDS(003)=3 ! PRESSURE TENDENCY (PA/S) + ! + ! + IDS(006)=-1 ! GEOPOTENTIAL (M2/S2) + IDS(007)=0 ! GEOPOTENTIAL HEIGHT (M) + IDS(008)=0 ! GEOMETRIC HEIGHT (M) + IDS(009)=0 ! STANDARD DEVIATION OF HEIGHT (M) + ! + IDS(011)=1 ! TEMPERATURE (K) + IDS(012)=1 ! VIRTUAL TEMPERATURE (K) + IDS(013)=1 ! POTENTIAL TEMPERATURE (K) + IDS(014)=1 ! PSEUDO-ADIABATIC POTENTIAL TEMPERATURE (K) + IDS(015)=1 ! MAXIMUM TEMPERATURE (K) + IDS(016)=1 ! MINIMUM TEMPERATURE (K) + IDS(017)=1 ! DEWPOINT TEMPERATURE (K) + IDS(018)=1 ! DEWPOINT DEPRESSION (K) + IDS(019)=4 ! TEMPERATURE LAPSE RATE (K/M) + IDS(020)=0 ! VISIBILITY (M) + ! RADAR SPECTRA 1 () + ! RADAR SPECTRA 2 () + ! RADAR SPECTRA 3 () + ! + IDS(025)=1 ! TEMPERATURE ANOMALY (K) + IDS(026)=-1 ! PRESSURE ANOMALY (PA) + IDS(027)=0 ! GEOPOTENTIAL HEIGHT ANOMALY (M) + ! WAVE SPECTRA 1 () + ! WAVE SPECTRA 2 () + ! WAVE SPECTRA 3 () + IDS(031)=0 ! WIND DIRECTION (DEGREES) + IDS(032)=1 ! WIND SPEED (M/S) + IDS(033)=1 ! ZONAL WIND (M/S) + IDS(034)=1 ! MERIDIONAL WIND (M/S) + IDS(035)=-4 ! STREAMFUNCTION (M2/S) + IDS(036)=-4 ! VELOCITY POTENTIAL (M2/S) + IDS(037)=-1 ! MONTGOMERY STREAM FUNCTION (M2/S2) + IDS(038)=8 ! SIGMA VERTICAL VELOCITY (1/S) + IDS(039)=3 ! PRESSURE VERTICAL VELOCITY (PA/S) + IDS(040)=4 ! GEOMETRIC VERTICAL VELOCITY (M/S) + IDS(041)=6 ! ABSOLUTE VORTICITY (1/S) + IDS(042)=6 ! ABSOLUTE DIVERGENCE (1/S) + IDS(043)=6 ! RELATIVE VORTICITY (1/S) + IDS(044)=6 ! RELATIVE DIVERGENCE (1/S) + IDS(045)=4 ! VERTICAL U SHEAR (1/S) + IDS(046)=4 ! VERTICAL V SHEAR (1/S) + IDS(047)=0 ! DIRECTION OF CURRENT (DEGREES) + ! SPEED OF CURRENT (M/S) + ! U OF CURRENT (M/S) + ! V OF CURRENT (M/S) + IDS(051)=4 ! SPECIFIC HUMIDITY (KG/KG) + IDS(052)=0 ! RELATIVE HUMIDITY (PERCENT) + IDS(053)=4 ! HUMIDITY MIXING RATIO (KG/KG) + IDS(054)=1 ! PRECIPITABLE WATER (KG/M2) + IDS(055)=-1 ! VAPOR PRESSURE (PA) + IDS(056)=-1 ! SATURATION DEFICIT (PA) + IDS(057)=1 ! EVAPORATION (KG/M2) + IDS(058)=1 ! CLOUD ICE (KG/M2) + IDS(059)=6 ! PRECIPITATION RATE (KG/M2/S) + IDS(060)=0 ! THUNDERSTORM PROBABILITY (PERCENT) + IDS(061)=1 ! TOTAL PRECIPITATION (KG/M2) + IDS(062)=1 ! LARGE-SCALE PRECIPITATION (KG/M2) + IDS(063)=1 ! CONVECTIVE PRECIPITATION (KG/M2) + IDS(064)=6 ! WATER EQUIVALENT SNOWFALL RATE (KG/M2/S) + IDS(065)=0 ! WATER EQUIVALENT OF SNOW DEPTH (KG/M2) + IDS(066)=2 ! SNOW DEPTH (M) + ! MIXED-LAYER DEPTH (M) + ! TRANSIENT THERMOCLINE DEPTH (M) + ! MAIN THERMOCLINE DEPTH (M) + ! MAIN THERMOCLINE ANOMALY (M) + IDS(071)=0 ! TOTAL CLOUD COVER (PERCENT) + IDS(072)=0 ! CONVECTIVE CLOUD COVER (PERCENT) + IDS(073)=0 ! LOW CLOUD COVER (PERCENT) + IDS(074)=0 ! MIDDLE CLOUD COVER (PERCENT) + IDS(075)=0 ! HIGH CLOUD COVER (PERCENT) + IDS(076)=1 ! CLOUD WATER (KG/M2) + ! + IDS(078)=1 ! CONVECTIVE SNOW (KG/M2) + IDS(079)=1 ! LARGE SCALE SNOW (KG/M2) + IDS(080)=1 ! WATER TEMPERATURE (K) + IDS(081)=0 ! SEA-LAND MASK () + ! DEVIATION OF SEA LEVEL FROM MEAN (M) + IDS(083)=5 ! ROUGHNESS (M) + IDS(084)=1 ! ALBEDO (PERCENT) + IDS(085)=1 ! SOIL TEMPERATURE (K) + IDS(086)=0 ! SOIL WETNESS (KG/M2) + IDS(087)=0 ! VEGETATION (PERCENT) + ! SALINITY (KG/KG) + IDS(089)=4 ! DENSITY (KG/M3) + IDS(090)=1 ! RUNOFF (KG/M2) + IDS(091)=0 ! ICE CONCENTRATION () + ! ICE THICKNESS (M) + IDS(093)=0 ! DIRECTION OF ICE DRIFT (DEGREES) + ! SPEED OF ICE DRIFT (M/S) + ! U OF ICE DRIFT (M/S) + ! V OF ICE DRIFT (M/S) + ! ICE GROWTH (M) + ! ICE DIVERGENCE (1/S) + IDS(099)=1 ! SNOW MELT (KG/M2) + ! SIG HEIGHT OF WAVES AND SWELL (M) + IDS(101)=0 ! DIRECTION OF WIND WAVES (DEGREES) + ! SIG HEIGHT OF WIND WAVES (M) + ! MEAN PERIOD OF WIND WAVES (S) + IDS(104)=0 ! DIRECTION OF SWELL WAVES (DEGREES) + ! SIG HEIGHT OF SWELL WAVES (M) + ! MEAN PERIOD OF SWELL WAVES (S) + IDS(107)=0 ! PRIMARY WAVE DIRECTION (DEGREES) + ! PRIMARY WAVE MEAN PERIOD (S) + IDS(109)=0 ! SECONDARY WAVE DIRECTION (DEGREES) + ! SECONDARY WAVE MEAN PERIOD (S) + IDS(111)=0 ! NET SOLAR RADIATIVE FLUX AT SURFACE (W/M2) + IDS(112)=0 ! NET LONGWAVE RADIATIVE FLUX AT SURFACE (W/M2) + IDS(113)=0 ! NET SOLAR RADIATIVE FLUX AT TOP (W/M2) + IDS(114)=0 ! NET LONGWAVE RADIATIVE FLUX AT TOP (W/M2) + IDS(115)=0 ! NET LONGWAVE RADIATIVE FLUX (W/M2) + IDS(116)=0 ! NET SOLAR RADIATIVE FLUX (W/M2) + IDS(117)=0 ! TOTAL RADIATIVE FLUX (W/M2) + ! + ! + ! + IDS(121)=0 ! LATENT HEAT FLUX (W/M2) + IDS(122)=0 ! SENSIBLE HEAT FLUX (W/M2) + IDS(123)=0 ! BOUNDARY LAYER DISSIPATION (W/M2) + IDS(124)=3 ! U WIND STRESS (N/M2) + IDS(125)=3 ! V WIND STRESS (N/M2) + ! WIND MIXING ENERGY (J) + ! IMAGE DATA () + IDS(128)=-1 ! MEAN SEA-LEVEL PRESSURE (STDATM) (PA) + IDS(129)=-1 ! MEAN SEA-LEVEL PRESSURE (MAPS) (PA) + IDS(130)=-1 ! MEAN SEA-LEVEL PRESSURE (ETA) (PA) + IDS(131)=1 ! SURFACE LIFTED INDEX (K) + IDS(132)=1 ! BEST LIFTED INDEX (K) + IDS(133)=1 ! K INDEX (K) + IDS(134)=1 ! SWEAT INDEX (K) + IDS(135)=10 ! HORIZONTAL MOISTURE DIVERGENCE (KG/KG/S) + IDS(136)=4 ! SPEED SHEAR (1/S) + IDS(137)=3 ! 3-HR PRESSURE TENDENCY (PA/S) + IDS(138)=6 ! BRUNT-VAISALA FREQUENCY SQUARED (1/S2) + IDS(139)=11 ! POTENTIAL VORTICITY (MASS-WEIGHTED) (1/S/M) + IDS(140)=0 ! RAIN MASK () + IDS(141)=0 ! FREEZING RAIN MASK () + IDS(142)=0 ! ICE PELLETS MASK () + IDS(143)=0 ! SNOW MASK () + IDS(144)=3 ! VOLUMETRIC SOIL MOISTURE CONTENT (FRACTION) + IDS(145)=0 ! POTENTIAL EVAPORATION RATE (W/M2) + IDS(146)=0 ! CLOUD WORKFUNCTION (J/KG) + IDS(147)=3 ! U GRAVITY WAVE STRESS (N/M2) + IDS(148)=3 ! V GRAVITY WAVE STRESS (N/M2) + IDS(149)=10 ! POTENTIAL VORTICITY (M2/S/KG) + ! COVARIANCE BETWEEN V AND U (M2/S2) + ! COVARIANCE BETWEEN U AND T (K*M/S) + ! COVARIANCE BETWEEN V AND T (K*M/S) + ! + ! + IDS(155)=0 ! GROUND HEAT FLUX (W/M2) + IDS(156)=0 ! CONVECTIVE INHIBITION (W/M2) + IDS(157)=0 ! CONVECTIVE APE (J/KG) + IDS(158)=0 ! TURBULENT KE (J/KG) + IDS(159)=-1 ! CONDENSATION PRESSURE OF LIFTED PARCEL (PA) + IDS(160)=0 ! CLEAR SKY UPWARD SOLAR FLUX (W/M2) + IDS(161)=0 ! CLEAR SKY DOWNWARD SOLAR FLUX (W/M2) + IDS(162)=0 ! CLEAR SKY UPWARD LONGWAVE FLUX (W/M2) + IDS(163)=0 ! CLEAR SKY DOWNWARD LONGWAVE FLUX (W/M2) + IDS(164)=0 ! CLOUD FORCING NET SOLAR FLUX (W/M2) + IDS(165)=0 ! CLOUD FORCING NET LONGWAVE FLUX (W/M2) + IDS(166)=0 ! VISIBLE BEAM DOWNWARD SOLAR FLUX (W/M2) + IDS(167)=0 ! VISIBLE DIFFUSE DOWNWARD SOLAR FLUX (W/M2) + IDS(168)=0 ! NEAR IR BEAM DOWNWARD SOLAR FLUX (W/M2) + IDS(169)=0 ! NEAR IR DIFFUSE DOWNWARD SOLAR FLUX (W/M2) + ! + ! + IDS(172)=3 ! MOMENTUM FLUX (N/M2) + IDS(173)=0 ! MASS POINT MODEL SURFACE () + IDS(174)=0 ! VELOCITY POINT MODEL SURFACE () + IDS(175)=0 ! SIGMA LAYER NUMBER () + IDS(176)=2 ! LATITUDE (DEGREES) + IDS(177)=2 ! EAST LONGITUDE (DEGREES) + ! + ! + ! + IDS(181)=9 ! X-GRADIENT LOG PRESSURE (1/M) + IDS(182)=9 ! Y-GRADIENT LOG PRESSURE (1/M) + IDS(183)=5 ! X-GRADIENT HEIGHT (M/M) + IDS(184)=5 ! Y-GRADIENT HEIGHT (M/M) + ! + ! + ! + ! + ! + ! + ! + ! + ! + ! + ! + ! + ! + ! + ! + ! + IDS(201)=0 ! ICE-FREE WATER SURCACE (PERCENT) + ! + ! + IDS(204)=0 ! DOWNWARD SOLAR RADIATIVE FLUX (W/M2) + IDS(205)=0 ! DOWNWARD LONGWAVE RADIATIVE FLUX (W/M2) + ! + IDS(207)=0 ! MOISTURE AVAILABILITY (PERCENT) + ! EXCHANGE COEFFICIENT (KG/M2/S) + IDS(209)=0 ! NUMBER OF MIXED LAYER NEXT TO SFC () + ! + IDS(211)=0 ! UPWARD SOLAR RADIATIVE FLUX (W/M2) + IDS(212)=0 ! UPWARD LONGWAVE RADIATIVE FLUX (W/M2) + IDS(213)=0 ! NON-CONVECTIVE CLOUD COVER (PERCENT) + IDS(214)=6 ! CONVECTIVE PRECIPITATION RATE (KG/M2/S) + IDS(215)=7 ! TOTAL DIABATIC HEATING RATE (K/S) + IDS(216)=7 ! TOTAL RADIATIVE HEATING RATE (K/S) + IDS(217)=7 ! TOTAL DIABATIC NONRADIATIVE HEATING RATE (K/S) + IDS(218)=2 ! PRECIPITATION INDEX (FRACTION) + IDS(219)=1 ! STD DEV OF IR T OVER 1X1 DEG AREA (K) + IDS(220)=4 ! NATURAL LOG OF SURFACE PRESSURE OVER 1 KPA () + ! + IDS(222)=0 ! 5-WAVE GEOPOTENTIAL HEIGHT (M) + IDS(223)=1 ! PLANT CANOPY SURFACE WATER (KG/M2) + ! + ! + ! BLACKADARS MIXING LENGTH (M) + ! ASYMPTOTIC MIXING LENGTH (M) + IDS(228)=1 ! POTENTIAL EVAPORATION (KG/M2) + IDS(229)=0 ! SNOW PHASE-CHANGE HEAT FLUX (W/M2) + ! + IDS(231)=3 ! CONVECTIVE CLOUD MASS FLUX (PA/S) + IDS(232)=0 ! DOWNWARD TOTAL RADIATION FLUX (W/M2) + IDS(233)=0 ! UPWARD TOTAL RADIATION FLUX (W/M2) + IDS(224)=1 ! BASEFLOW-GROUNDWATER RUNOFF (KG/M2) + IDS(225)=1 ! STORM SURFACE RUNOFF (KG/M2) + ! + ! + IDS(238)=0 ! SNOW COVER (PERCENT) + IDS(239)=1 ! SNOW TEMPERATURE (K) + ! + IDS(241)=7 ! LARGE SCALE CONDENSATION HEATING RATE (K/S) + IDS(242)=7 ! DEEP CONVECTIVE HEATING RATE (K/S) + IDS(243)=10 ! DEEP CONVECTIVE MOISTENING RATE (KG/KG/S) + IDS(244)=7 ! SHALLOW CONVECTIVE HEATING RATE (K/S) + IDS(245)=10 ! SHALLOW CONVECTIVE MOISTENING RATE (KG/KG/S) + IDS(246)=7 ! VERTICAL DIFFUSION HEATING RATE (KG/KG/S) + IDS(247)=7 ! VERTICAL DIFFUSION ZONAL ACCELERATION (M/S/S) + IDS(248)=7 ! VERTICAL DIFFUSION MERID ACCELERATION (M/S/S) + IDS(249)=10 ! VERTICAL DIFFUSION MOISTENING RATE (KG/KG/S) + IDS(250)=7 ! SOLAR RADIATIVE HEATING RATE (K/S) + IDS(251)=7 ! LONGWAVE RADIATIVE HEATING RATE (K/S) + ! DRAG COEFFICIENT () + ! FRICTION VELOCITY (M/S) + ! RICHARDSON NUMBER () + ! + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/instrument.f b/WPS/ungrib/src/ngl/w3/instrument.f new file mode 100755 index 00000000..0c936f99 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/instrument.f @@ -0,0 +1,111 @@ +!----------------------------------------------------------------------- + SUBROUTINE INSTRUMENT(K,KALL,TTOT,TMIN,TMAX) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! . . . . +! SUBPROGRAM: INSTRUMENT MONITOR WALL-CLOCK TIMES, ETC. +! PRGMMR: IREDELL ORG: NP23 DATE:1998-07-16 +! +! ABSTRACT: THIS SUBPROGRAM IS USEFUL IN INSTRUMENTING A CODE +! BY MONITORING THE NUMBER OF TIMES EACH GIVEN SECTION +! OF A PROGRAM IS INVOKED AS WELL AS THE MINIMUM, MAXIMUM +! AND TOTAL WALL-CLOCK TIME SPENT IN THE GIVEN SECTION. +! +! PROGRAM HISTORY LOG: +! 1998-07-16 IREDELL +! +! USAGE: CALL INSTRUMENT(K,KALL,TTOT,TMIN,TMAX) +! INPUT ARGUMENT LIST: +! K - INTEGER POSITIVE SECTION NUMBER +! OR MAXIMUM SECTION NUMBER IN THE FIRST INVOCATION +! OR ZERO TO RESET ALL WALL-CLOCK STATISTICS +! OR NEGATIVE SECTION NUMBER TO SKIP MONITORING +! AND JUST RETURN STATISTICS. +! +! OUTPUT ARGUMENT LIST: +! KALL - INTEGER NUMBER OF TIMES SECTION IS CALLED +! TTOT - REAL TOTAL SECONDS SPENT IN SECTION +! TMIN - REAL MINIMUM SECONDS SPENT IN SECTION +! TMAX - REAL MAXIMUM SECONDS SPENT IN SECTION +! +! SUBPROGRAMS CALLED: +! W3UTCDAT RETURN THE UTC DATE AND TIME +! W3DIFDAT RETURN A TIME INTERVAL BETWEEN TWO DATES +! +! REMARKS: +! THIS SUBPROGRAM SHOULD NOT BE INVOKED FROM A MULTITASKING REGION. +! NORMALLY, TIME SPENT INSIDE THIS SUBPROGRAM IS NOT COUNTED. +! WALL-CLOCK TIMES ARE KEPT TO THE NEAREST MILLISECOND. +! +! EXAMPLE. +! CALL INSTRUMENT(2,KALL,TTOT,TMIN,TMAX) ! KEEP STATS FOR 2 SUBS +! DO K=1,N +! CALL SUB1 +! CALL INSTRUMENT(1,KALL,TTOT,TMIN,TMAX) ! ACCUM STATS FOR SUB1 +! CALL SUB2 +! CALL INSTRUMENT(2,KALL,TTOT,TMIN,TMAX) ! ACCUM STATS FOR SUB2 +! ENDDO +! PRINT *,'SUB2 STATS: ',KALL,TTOT,TMIN,TMAX +! CALL INSTRUMENT(-1,KALL,TTOT,TMIN,TMAX) ! RETURN STATS FOR SUB1 +! PRINT *,'SUB1 STATS: ',KALL,TTOT,TMIN,TMAX +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! +!$$$ + IMPLICIT NONE + INTEGER,INTENT(IN):: K + INTEGER,INTENT(OUT):: KALL + REAL,INTENT(OUT):: TTOT,TMIN,TMAX + INTEGER,SAVE:: KMAX=0 + INTEGER,DIMENSION(:),ALLOCATABLE,SAVE:: KALLS + REAL,DIMENSION(:),ALLOCATABLE,SAVE:: TTOTS,TMINS,TMAXS + INTEGER,DIMENSION(8),SAVE:: IDAT + INTEGER,DIMENSION(8):: JDAT + REAL,DIMENSION(5):: RINC + INTEGER:: KA +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + KA=ABS(K) +! ALLOCATE MONITORING ARRAYS IF INITIAL INVOCATION + IF(KMAX.EQ.0) THEN + KMAX=K + ALLOCATE(KALLS(KMAX)) + ALLOCATE(TTOTS(KMAX)) + ALLOCATE(TMINS(KMAX)) + ALLOCATE(TMAXS(KMAX)) + KALLS=0 + KA=0 +! OR RESET ALL STATISTICS BACK TO ZERO + ELSEIF(K.EQ.0) THEN + KALLS=0 +! OR COUNT TIME SINCE LAST INVOCATION AGAINST THIS SECTION + ELSEIF(K.GT.0) THEN + CALL W3UTCDAT(JDAT) + CALL W3DIFDAT(JDAT,IDAT,4,RINC) + KALLS(K)=KALLS(K)+1 + IF(KALLS(K).EQ.1) THEN + TTOTS(K)=RINC(4) + TMINS(K)=RINC(4) + TMAXS(K)=RINC(4) + ELSE + TTOTS(K)=TTOTS(K)+RINC(4) + TMINS(K)=MIN(TMINS(K),RINC(4)) + TMAXS(K)=MAX(TMAXS(K),RINC(4)) + ENDIF + ENDIF +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! RETURN STATISTICS + IF(KA.GE.1.AND.KA.LE.KMAX.AND.KALLS(KA).GT.0) THEN + KALL=KALLS(KA) + TTOT=TTOTS(KA) + TMIN=TMINS(KA) + TMAX=TMAXS(KA) + ELSE + KALL=0 + TTOT=0 + TMIN=0 + TMAX=0 + ENDIF +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! KEEP CURRENT TIME FOR NEXT INVOCATION + IF(K.GE.0) CALL W3UTCDAT(IDAT) + END SUBROUTINE INSTRUMENT diff --git a/WPS/ungrib/src/ngl/w3/iw3jdn.f b/WPS/ungrib/src/ngl/w3/iw3jdn.f new file mode 100755 index 00000000..896d6211 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/iw3jdn.f @@ -0,0 +1,62 @@ + FUNCTION IW3JDN(IYEAR,MONTH,IDAY) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IW3JDN COMPUTE JULIAN DAY NUMBER +C AUTHOR: JONES,R.E. ORG: W342 DATE: 87-03-29 +C +C ABSTRACT: COMPUTES JULIAN DAY NUMBER FROM YEAR (4 DIGITS), MONTH, +C AND DAY. IW3JDN IS VALID FOR YEARS 1583 A.D. TO 3300 A.D. +C JULIAN DAY NUMBER CAN BE USED TO COMPUTE DAY OF WEEK, DAY OF +C YEAR, RECORD NUMBERS IN AN ARCHIVE, REPLACE DAY OF CENTURY, +C FIND THE NUMBER OF DAYS BETWEEN TWO DATES. +C +C PROGRAM HISTORY LOG: +C 87-03-29 R.E.JONES +C 89-10-25 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN +C +C USAGE: II = IW3JDN(IYEAR,MONTH,IDAY) +C +C INPUT VARIABLES: +C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES +C ------ --------- ----------------------------------------------- +C IYEAR ARG LIST INTEGER YEAR ( 4 DIGITS) +C MONTH ARG LIST INTEGER MONTH OF YEAR (1 - 12) +C IDAY ARG LIST INTEGER DAY OF MONTH (1 - 31) +C +C OUTPUT VARIABLES: +C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES +C ------ --------- ----------------------------------------------- +C IW3JDN FUNTION INTEGER JULIAN DAY NUMBER +C JAN. 1,1960 IS JULIAN DAY NUMBER 2436935 +C JAN. 1,1987 IS JULIAN DAY NUMBER 2446797 +C +C REMARKS: JULIAN PERIOD WAS DEVISED BY JOSEPH SCALIGER IN 1582. +C JULIAN DAY NUMBER #1 STARTED ON JAN. 1,4713 B.C. THREE MAJOR +C CHRONOLOGICAL CYCLES BEGIN ON THE SAME DAY. A 28-YEAR SOLAR +C CYCLE, A 19-YEAR LUNER CYCLE, A 15-YEAR INDICTION CYCLE, USED +C IN ANCIENT ROME TO REGULATE TAXES. IT WILL TAKE 7980 YEARS +C TO COMPLETE THE PERIOD, THE PRODUCT OF 28, 19, AND 15. +C SCALIGER NAMED THE PERIOD, DATE, AND NUMBER AFTER HIS FATHER +C JULIUS (NOT AFTER THE JULIAN CALENDAR). THIS SEEMS TO HAVE +C CAUSED A LOT OF CONFUSION IN TEXT BOOKS. SCALIGER NAME IS +C SPELLED THREE DIFFERENT WAYS. JULIAN DATE AND JULIAN DAY +C NUMBER ARE INTERCHANGED. A JULIAN DATE IS USED BY ASTRONOMERS +C TO COMPUTE ACCURATE TIME, IT HAS A FRACTION. WHEN TRUNCATED TO +C AN INTEGER IT IS CALLED AN JULIAN DAY NUMBER. THIS FUNCTION +C WAS IN A LETTER TO THE EDITOR OF THE COMMUNICATIONS OF THE ACM +C VOLUME 11 / NUMBER 10 / OCTOBER 1968. THE JULIAN DAY NUMBER +C CAN BE CONVERTED TO A YEAR, MONTH, DAY, DAY OF WEEK, DAY OF +C YEAR BY CALLING SUBROUTINE W3FS26. +C +C ATTRIBUTES: +C LANGUAGE: CRAY CFT77 FORTRAN +C MACHINE: CRAY Y-MP8/864, CRAY Y-MP EL2/256 +C +C$$$ +C + IW3JDN = IDAY - 32075 + & + 1461 * (IYEAR + 4800 + (MONTH - 14) / 12) / 4 + & + 367 * (MONTH - 2 - (MONTH -14) / 12 * 12) / 12 + & - 3 * ((IYEAR + 4900 + (MONTH - 14) / 12) / 100) / 4 + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/ixgb.f b/WPS/ungrib/src/ngl/w3/ixgb.f new file mode 100755 index 00000000..a6887cbc --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/ixgb.f @@ -0,0 +1,154 @@ +C----------------------------------------------------------------------- + SUBROUTINE IXGB(LUGB,LSKIP,LGRIB,NLEN,NNUM,MLEN,CBUF) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: IXGB MAKE INDEX RECORD +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 95-10-31 +C +C ABSTRACT: THIS SUBPROGRAM MAKES ONE INDEX RECORD. +C BYTE 001-004: BYTES TO SKIP IN DATA FILE BEFORE GRIB MESSAGE +C BYTE 005-008: BYTES TO SKIP IN MESSAGE BEFORE PDS +C BYTE 009-012: BYTES TO SKIP IN MESSAGE BEFORE GDS (0 IF NO GDS) +C BYTE 013-016: BYTES TO SKIP IN MESSAGE BEFORE BMS (0 IF NO BMS) +C BYTE 017-020: BYTES TO SKIP IN MESSAGE BEFORE BDS +C BYTE 021-024: BYTES TOTAL IN THE MESSAGE +C BYTE 025-025: GRIB VERSION NUMBER +C BYTE 026-053: PRODUCT DEFINITION SECTION (PDS) +C BYTE 054-095: GRID DEFINITION SECTION (GDS) (OR NULLS) +C BYTE 096-101: FIRST PART OF THE BIT MAP SECTION (BMS) (OR NULLS) +C BYTE 102-112: FIRST PART OF THE BINARY DATA SECTION (BDS) +C BYTE 113-172: (OPTIONAL) BYTES 41-100 OF THE PDS +C BYTE 173-184: (OPTIONAL) BYTES 29-40 OF THE PDS +C BYTE 185-320: (OPTIONAL) BYTES 43-178 OF THE GDS +C +C PROGRAM HISTORY LOG: +C 95-10-31 IREDELL +C 96-10-31 IREDELL AUGMENTED OPTIONAL DEFINITIONS TO BYTE 320 +C +C USAGE: CALL WRGI1R(LUGB,LSKIP,LGRIB,LUGI) +C INPUT ARGUMENTS: +C LUGB INTEGER LOGICAL UNIT OF INPUT GRIB FILE +C LSKIP INTEGER NUMBER OF BYTES TO SKIP BEFORE GRIB MESSAGE +C LGRIB INTEGER NUMBER OF BYTES IN GRIB MESSAGE +C NLEN INTEGER LENGTH OF EACH INDEX RECORD IN BYTES +C NNUM INTEGER INDEX RECORD NUMBER TO MAKE +C OUTPUT ARGUMENTS: +C MLEN INTEGER ACTUAL VALID LENGTH OF INDEX RECORD +C CBUF CHARACTER*1 (MBUF) BUFFER TO RECEIVE INDEX DATA +C +C SUBPROGRAMS CALLED: +C GBYTE GET INTEGER DATA FROM BYTES +C SBYTE STORE INTEGER DATA IN BYTES +C BAREAD BYTE-ADDRESSABLE READ +C +C ATTRIBUTES: +C LANGUAGE: CRAY FORTRAN +C +C$$$ + CHARACTER CBUF(*) + PARAMETER(LINDEX=112,MINDEX=320) + PARAMETER(IXSKP=0,IXSPD=4,IXSGD=8,IXSBM=12,IXSBD=16,IXLEN=20, + & IXVER=24,IXPDS=25,IXGDS=53,IXBMS=95,IXBDS=101, + & IXPDX=112,IXPDW=172,IXGDX=184) + PARAMETER(MXSKP=4,MXSPD=4,MXSGD=4,MXSBM=4,MXSBD=4,MXLEN=4, + & MXVER=1,MXPDS=28,MXGDS=42,MXBMS=6,MXBDS=11, + & MXPDX=60,MXPDW=12,MXGDX=136) + CHARACTER CBREAD(MINDEX),CINDEX(MINDEX) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C INITIALIZE INDEX RECORD AND READ GRIB MESSAGE + MLEN=LINDEX + CINDEX=CHAR(0) + CALL SBYTE(CINDEX,LSKIP,8*IXSKP,8*MXSKP) + CALL SBYTE(CINDEX,LGRIB,8*IXLEN,8*MXLEN) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C PUT PDS IN INDEX RECORD + ISKPDS=8 + IBSKIP=LSKIP + IBREAD=ISKPDS+MXPDS + CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) + IF(LBREAD.NE.IBREAD) RETURN + CINDEX(IXVER+1)=CBREAD(8) + CALL SBYTE(CINDEX,ISKPDS,8*IXSPD,8*MXSPD) + CALL GBYTE(CBREAD,LENPDS,8*ISKPDS,8*3) + CALL GBYTE(CBREAD,INCGDS,8*ISKPDS+8*7+0,1) + CALL GBYTE(CBREAD,INCBMS,8*ISKPDS+8*7+1,1) + ILNPDS=MIN(LENPDS,MXPDS) + CINDEX(IXPDS+1:IXPDS+ILNPDS)=CBREAD(ISKPDS+1:ISKPDS+ILNPDS) + ISKTOT=ISKPDS+LENPDS +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C PUT PDS EXTENSION IN INDEX RECORD + IF(LENPDS.GT.MXPDS) THEN + ISKPDW=ISKPDS+MXPDS + ILNPDW=MIN(LENPDS-MXPDS,MXPDW) + IBSKIP=LSKIP+ISKPDW + IBREAD=ILNPDW + CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) + IF(LBREAD.NE.IBREAD) RETURN + CINDEX(IXPDW+1:IXPDW+ILNPDW)=CBREAD(1:ILNPDW) + ISKPDX=ISKPDS+(MXPDS+MXPDW) + ILNPDX=MIN(LENPDS-(MXPDS+MXPDW),MXPDX) + IBSKIP=LSKIP+ISKPDX + IBREAD=ILNPDX + CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) + IF(LBREAD.NE.IBREAD) RETURN + CINDEX(IXPDX+1:IXPDX+ILNPDX)=CBREAD(1:ILNPDX) + MLEN=MAX(MLEN,IXPDW+ILNPDW,IXPDX+ILNPDX) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C PUT GDS IN INDEX RECORD + IF(INCGDS.NE.0) THEN + ISKGDS=ISKTOT + IBSKIP=LSKIP+ISKGDS + IBREAD=MXGDS + CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) + IF(LBREAD.NE.IBREAD) RETURN + CALL SBYTE(CINDEX,ISKGDS,8*IXSGD,8*MXSGD) + CALL GBYTE(CBREAD,LENGDS,0,8*3) + ILNGDS=MIN(LENGDS,MXGDS) + CINDEX(IXGDS+1:IXGDS+ILNGDS)=CBREAD(1:ILNGDS) + ISKTOT=ISKGDS+LENGDS + IF(LENGDS.GT.MXGDS) THEN + ISKGDX=ISKGDS+MXGDS + ILNGDX=MIN(LENGDS-MXGDS,MXGDX) + IBSKIP=LSKIP+ISKGDX + IBREAD=ILNGDX + CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) + IF(LBREAD.NE.IBREAD) RETURN + CINDEX(IXGDX+1:IXGDX+ILNGDX)=CBREAD(1:ILNGDX) + MLEN=MAX(MLEN,IXGDX+ILNGDX) + ENDIF + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C PUT BMS IN INDEX RECORD + IF(INCBMS.NE.0) THEN + ISKBMS=ISKTOT + IBSKIP=LSKIP+ISKBMS + IBREAD=MXBMS + CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) + IF(LBREAD.NE.IBREAD) RETURN + CALL SBYTE(CINDEX,ISKBMS,8*IXSBM,8*MXSBM) + CALL GBYTE(CBREAD,LENBMS,0,8*3) + ILNBMS=MIN(LENBMS,MXBMS) + CINDEX(IXBMS+1:IXBMS+ILNBMS)=CBREAD(1:ILNBMS) + ISKTOT=ISKBMS+LENBMS + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C PUT BDS IN INDEX RECORD + ISKBDS=ISKTOT + IBSKIP=LSKIP+ISKBDS + IBREAD=MXBDS + CALL BAREAD(LUGB,IBSKIP,IBREAD,LBREAD,CBREAD) + IF(LBREAD.NE.IBREAD) RETURN + CALL SBYTE(CINDEX,ISKBDS,8*IXSBD,8*MXSBD) + CALL GBYTE(CBREAD,LENBDS,0,8*3) + ILNBDS=MIN(LENBDS,MXBDS) + CINDEX(IXBDS+1:IXBDS+ILNBDS)=CBREAD(1:ILNBDS) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C STORE INDEX RECORD + MLEN=MIN(MLEN,NLEN) + NSKIP=NLEN*(NNUM-1) + CBUF(NSKIP+1:NSKIP+MLEN)=CINDEX(1:MLEN) + CBUF(NSKIP+MLEN+1:NSKIP+NLEN)=CHAR(0) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/lengds.f b/WPS/ungrib/src/ngl/w3/lengds.f new file mode 100755 index 00000000..051aed69 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/lengds.f @@ -0,0 +1,40 @@ +C----------------------------------------------------------------------- + FUNCTION LENGDS(KGDS) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: LENGDS RETURN THE LENGTH OF A GRID +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-07-19 +C +C ABSTRACT: GIVEN A GRID DESCRIPTION SECTION (IN W3FI63 FORMAT), +C RETURN ITS SIZE IN TERMS OF NUMBER OF DATA POINTS. +C +C PROGRAM HISTORY LOG: +C 96-07-19 IREDELL +C +C USAGE: CALL LENGDS(KGDS) +C INPUT ARGUMENTS: +C KGDS INTEGER (200) GDS PARAMETERS IN W3FI63 FORMAT +C OUTPUT ARGUMENTS: +C LENGDS INTEGER SIZE OF GRID +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN +C +C$$$ + INTEGER KGDS(200) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SPECIAL CASE OF STAGGERED ETA + IF(KGDS(1).EQ.201) THEN + LENGDS=KGDS(7)*KGDS(8)-KGDS(8)/2 +C SPECIAL CASE OF FILLED ETA + ELSEIF(KGDS(1).EQ.202) THEN + LENGDS=KGDS(7)*KGDS(8) +C SPECIAL CASE OF THINNED WAFS + ELSEIF(KGDS(19).EQ.0.AND.KGDS(20).NE.255) THEN + LENGDS=KGDS(21) +C GENERAL CASE + ELSE + LENGDS=KGDS(2)*KGDS(3) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END diff --git a/WPS/ungrib/src/ngl/w3/pdsens.f b/WPS/ungrib/src/ngl/w3/pdsens.f new file mode 100755 index 00000000..4d79f517 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/pdsens.f @@ -0,0 +1,75 @@ +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: PDSENS.F PACKS GRIB PDS EXTENSION 41- FOR ENSEMBLE +C PRGMMR: RICHARD WOBUS ORG: W/NP20 DATE: 98-09-28 +C +C ABSTRACT: PACKS BRIB PDS EXTENSION STARTING ON BYTE 41 FOR ENSEMBLE +C FORECAST PRODUCTS. FOR FORMAT OF PDS EXTENSION, SEE NMC OFFICE NOTE 38 +C +C PROGRAM HISTORY LOG: +C 95-03-14 ZOLTAN TOTH AND MARK IREDELL +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 98-09-28 WOBUS CORRECTED MEMBER ENTRY, BLANK ALL UNUSED FIELDS +C +C USAGE: CALL PDSENS.F(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) +C INPUT ARGUMENT LIST: +C KENS(5) - BYTES 41-45 (GENERAL SECTION, ALWAYS PRESENT.) +C KPROB(2) - BYTES 46-47 (PROBABILITY SECTION, PRESENT ONLY IF NEEDE +C XPROB(2) - BYTES 48-51&52-55 (PROBABILITY SECTION, IF NEEDED.) +C KCLUST(16)-BYTES 61-76 (CLUSTERING SECTION, IF NEEDED.) +C KMEMBR(80)-BYTES 77-86 (CLUSTER MEMBERSHIP SECTION, IF NEEDED.) +C ILAST - LAST BYTE TO BE PACKED (IF GREATER OR EQUAL TO FIRST BY +C IN ANY OF FOUR SECTIONS ABOVE, WHOLE SECTION IS PACKED. +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C MSGA - FULL PDS SECTION, INCLUDING NEW ENSEMBLE EXTENSION +C +C REMARKS: USE PDSEUP.F FOR UNPACKING PDS ENSEMBLE EXTENSION. +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ +C TESTING GRIB EXTENSION 41- PACKER AND UNPACKER SUBROUTINES +C +CFPP$ NOCONCUR R + SUBROUTINE PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) + INTEGER KENS(5),KPROB(2),KCLUST(16),KMEMBR(80) + DIMENSION XPROB(2) + CHARACTER*1 MSGA(100) + IF(ILAST.LT.41) THEN + GO TO 333 + ENDIF +C PACKING IS DONE IN FOUR SECTIONS ENDING AT BYTE IL + IF(ILAST.GE.41) IL=45 + IF(ILAST.GE.46) IL=55 + IF(ILAST.GE.61) IL=76 + IF(ILAST.GE.77) IL=86 + do i=42,il + CALL SBYTE(MSGA, 0, i*8, 8) + enddo +C CHANGING THE NUMBER OF BYTES (FIRST THREE BYTES IN PDS) + CALL SBYTE(MSGA, IL, 0,24) +C PACKING FIRST SECTION (GENERAL INTORMATION SECTION) + IF(IL.GE.45) CALL SBYTES(MSGA,KENS,40*8,8,0,5) +C PACKING 2ND SECTION (PROBABILITY SECTION) + IF(IL.GE.55) THEN + CALL SBYTES(MSGA,KPROB,45*8,8,0,2) + CALL W3FI01(LW) + CALL W3FI76(XPROB(1),IEXP,IMANT,8*LW) + CALL SBYTE(MSGA,IEXP,47*8,8) + CALL SBYTE(MSGA,IMANT,48*8,24) + CALL W3FI76(XPROB(2),IEXP,IMANT,8*LW) + CALL SBYTE(MSGA,IEXP,51*8,8) + CALL SBYTE(MSGA,IMANT,52*8,24) + ENDIF +C PACKING 3RD SECTION (CLUSTERING INFORMATION) + IF(IL.GE.76) CALL SBYTES(MSGA,KCLUST,60*8,8,0,16) +C PACKING 4TH SECTION (CLUSTER MEMBERSHIP) + IF(IL.GE.86) CALL SBYTES(MSGA,KMEMBR,76*8,1,0,80) +C + 333 CONTINUE + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/pdseup.f b/WPS/ungrib/src/ngl/w3/pdseup.f new file mode 100755 index 00000000..52c6ecd4 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/pdseup.f @@ -0,0 +1,110 @@ +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: PDSEUP.F UNPACKS GRIB PDS EXTENSION 41- FOR ENSEMBLE +C PRGMMR: RICHARD WOBUS ORG: W/NP20 DATE: 98-09-28 +C +C ABSTRACT: UNPACKS GRIB PDS EXTENSION STARTING ON BYTE 41 FOR ENSEMBLE +C FORECAST PRODUCTS. FOR FORMAT OF PDS EXTENSION, SEE NMC OFFICE NOTE 38 +C +C PROGRAM HISTORY LOG: +C 95-03-14 ZOLTAN TOTH AND MARK IREDELL +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 98-09-28 WOBUS CORRECTED MEMBER EXTRACTION +C +C USAGE: CALL PDSENS.F(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) +C INPUT ARGUMENT LIST: +C ILAST - LAST BYTE TO BE UNPACKED (IF GREATER/EQUAL TO FIRST BYT +C IN ANY OF FOUR SECTIONS BELOW, WHOLE SECTION IS PACKED. +C MSGA - FULL PDS SECTION, INCLUDING NEW ENSEMBLE EXTENSION +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C KENS(5) - BYTES 41-45 (GENERAL SECTION, ALWAYS PRESENT.) +C KPROB(2) - BYTES 46-47 (PROBABILITY SECTION, PRESENT ONLY IF NEEDE +C XPROB(2) - BYTES 48-51&52-55 (PROBABILITY SECTION, IF NEEDED.) +C KCLUST(16)-BYTES 61-76 (CLUSTERING SECTION, IF NEEDED.) +C KMEMBR(80)-BYTES 77-86 (CLUSTER MEMBERSHIP SECTION, IF NEEDED.) +C +C REMARKS: USE PDSENS.F FOR PACKING PDS ENSEMBLE EXTENSION. +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: CF77 FORTRAN +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ +C + SUBROUTINE PDSEUP(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,MSGA) + INTEGER KENS(5),KPROB(2),KCLUST(16),KMEMBR(80) + DIMENSION XPROB(2) + INTEGER KREF + CHARACTER*1 MSGA(100) + REAL REFNCE + CHARACTER*1 CKREF(8) + EQUIVALENCE (CKREF(1),KREF,REFNCE) +C CHECKING TOTAL NUMBER OF BYTES IN PDS (IBYTES) + CALL GBYTE(MSGA, IBYTES, 0,24) + IF(ILAST.GT.IBYTES) THEN +C ILAST=IBYTES + GO TO 333 + ENDIF + IF(ILAST.LT.41) THEN + GO TO 333 + ENDIF +C UNPACKING FIRST SECTION (GENERAL INFORMATION) + CALL GBYTES(MSGA,KENS,40*8,8,0,5) +C UNPACKING 2ND SECTION (PROBABILITY SECTION) + IF(ILAST.GE.46) THEN + CALL GBYTES(MSGA,KPROB,45*8,8,0,2) +C +C + CALL GBYTE (MSGA,KREF,47*8,32) + CALL W3FI01(LW) + IF (LW.EQ.4) THEN + CALL GBYTE (CKREF,JSGN,0,1) + CALL GBYTE (CKREF,JEXP,1,7) + CALL GBYTE (CKREF,IFR,8,24) + ELSE + CALL GBYTE (CKREF,JSGN,32,1) + CALL GBYTE (CKREF,JEXP,33,7) + CALL GBYTE (CKREF,IFR,40,24) + ENDIF + IF (IFR.EQ.0) THEN + REFNCE = 0.0 + ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN + REFNCE = 0.0 + ELSE + REFNCE = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) + IF (JSGN.NE.0) REFNCE = - REFNCE + END IF + XPROB(1)=REFNCE +C + CALL GBYTE (MSGA,KREF,51*8,32) + CALL W3FI01(LW) + IF (LW.EQ.4) THEN + CALL GBYTE (CKREF,JSGN,0,1) + CALL GBYTE (CKREF,JEXP,1,7) + CALL GBYTE (CKREF,IFR,8,24) + ELSE + CALL GBYTE (CKREF,JSGN,32,1) + CALL GBYTE (CKREF,JEXP,33,7) + CALL GBYTE (CKREF,IFR,40,24) + ENDIF + IF (IFR.EQ.0) THEN + REFNCE = 0.0 + ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN + REFNCE = 0.0 + ELSE + REFNCE = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) + IF (JSGN.NE.0) REFNCE = - REFNCE + END IF + XPROB(2)=REFNCE + ENDIF +C +C UNPACKING 3RD SECTION (CLUSTERING INFORMATION) + IF(ILAST.GE.61) CALL GBYTES(MSGA,KCLUST,60*8,8,0,16) +C UNPACKING 4TH SECTION (CLUSTERMEMBERSHIP INFORMATION) + IF(ILAST.GE.77) CALL GBYTES(MSGA,KMEMBR,76*8,1,0,80) +C + 333 CONTINUE + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/putgb.f b/WPS/ungrib/src/ngl/w3/putgb.f new file mode 100755 index 00000000..072062da --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/putgb.f @@ -0,0 +1,201 @@ +C----------------------------------------------------------------------- + SUBROUTINE PUTGB(LUGB,KF,KPDS,KGDS,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PUTGB PACKS AND WRITES A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. +C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGB. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 09-10-15 GAYNO INCREASED MAXBIT FROM 16 TO 32 +C +C USAGE: CALL PUTGB(LUGB,KF,KPDS,KGDS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C KF INTEGER NUMBER OF DATA POINTS +C KPDS INTEGER (200) PDS PARAMETERS +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C KGDS INTEGER (200) GDS PARAMETERS +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C LB LOGICAL*1 (KF) BITMAP IF PRESENT +C F REAL (KF) DATA +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C 0 ALL OK +C OTHER W3FI72 GRIB PACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS +C GETBIT GET NUMBER OF BITS AND ROUND DATA +C W3FI72 PACK GRIB +C WRYTE WRITE DATA +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER KPDS(200),KGDS(200) + LOGICAL*1 LB(KF) + REAL F(KF) + PARAMETER(MAXBIT=32) + INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) + REAL FR(KF) + CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET W3FI72 PARAMETERS + CALL R63W72(KPDS,KGDS,IPDS,IGDS) + IBDS=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C COUNT VALID DATA + KBM=KF + IF(IPDS(7).NE.0) THEN + KBM=0 + DO I=1,KF + IF(LB(I)) THEN + IBM(I)=1 + KBM=KBM+1 + ELSE + IBM(I)=0 + ENDIF + ENDDO + IF(KBM.EQ.KF) IPDS(7)=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET NUMBER OF BITS AND ROUND DATA + IF(KBM.EQ.0) THEN + DO I=1,KF + FR(I)=0. + ENDDO + NBIT=0 + ELSE + CALL GETBIT(IPDS(7),0,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) + NBIT=MIN(NBIT,MAXBIT) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C PACK AND WRITE GRIB DATA + CALL W3FI72(0,FR,0,NBIT,0,IPDS,PDS, + & 1,255,IGDS,0,0,IBM,KF,IBDS, + & KFO,GRIB,LGRIB,IRET) + IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/putgbe.f b/WPS/ungrib/src/ngl/w3/putgbe.f new file mode 100755 index 00000000..57b75673 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/putgbe.f @@ -0,0 +1,213 @@ +C----------------------------------------------------------------------- + SUBROUTINE PUTGBE(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PUTGBE PACKS AND WRITES A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. +C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL PUTGBE(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C KF INTEGER NUMBER OF DATA POINTS +C KPDS INTEGER (200) PDS PARAMETERS +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C KGDS INTEGER (200) GDS PARAMETERS +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C KENS INTEGER (200) ENSEMBLE PDS PARMS +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C LB LOGICAL*1 (KF) BITMAP IF PRESENT +C F REAL (KF) DATA +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C 0 ALL OK +C OTHER W3FI72 GRIB PACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS +C GETBIT GET NUMBER OF BITS AND ROUND DATA +C W3FI72 PACK GRIB +C WRYTE WRITE DATA +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER KPDS(200),KGDS(200),KENS(200) + LOGICAL*1 LB(KF) + REAL F(KF) + PARAMETER(MAXBIT=16) + INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) + REAL FR(KF) + CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET W3FI72 PARAMETERS + CALL R63W72(KPDS,KGDS,IPDS,IGDS) + IBDS=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C COUNT VALID DATA + KBM=KF + IF(IPDS(7).NE.0) THEN + KBM=0 + DO I=1,KF + IF(LB(I)) THEN + IBM(I)=1 + KBM=KBM+1 + ELSE + IBM(I)=0 + ENDIF + ENDDO + IF(KBM.EQ.KF) IPDS(7)=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET NUMBER OF BITS AND ROUND DATA + IF(KBM.EQ.0) THEN + DO I=1,KF + FR(I)=0. + ENDDO + NBIT=0 + ELSE + CALL GETBIT(IPDS(7),0,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) + NBIT=MIN(NBIT,MAXBIT) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C CREATE PRODUCT DEFINITION SECTION + CALL W3FI68(IPDS,PDS) + IF(IPDS(24).EQ.2) THEN + ILAST=45 + CALL PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,PDS) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C PACK AND WRITE GRIB DATA + CALL W3FI72(0,FR,0,NBIT,1,IPDS,PDS, + & 1,255,IGDS,0,0,IBM,KF,IBDS, + & KFO,GRIB,LGRIB,IRET) + IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/putgben.f b/WPS/ungrib/src/ngl/w3/putgben.f new file mode 100755 index 00000000..cdae8600 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/putgben.f @@ -0,0 +1,223 @@ +C----------------------------------------------------------------------- + SUBROUTINE PUTGBEN(LUGB,KF,KPDS,KGDS,KENS,IBS,NBITS,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PUTGBEN PACKS AND WRITES A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. +C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 2001-03-16 IREDELL CORRECTED ARGUMENT LIST TO INCLUDE IBS +C +C USAGE: CALL PUTGBEN(LUGB,KF,KPDS,KGDS,KENS,IBS,NBITS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C KF INTEGER NUMBER OF DATA POINTS +C KPDS INTEGER (200) PDS PARAMETERS +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C KGDS INTEGER (200) GDS PARAMETERS +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C KENS INTEGER (200) ENSEMBLE PDS PARMS +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C IBS INTEGER BINARY SCALE FACTOR (0 TO IGNORE) +C NBITS INTEGER NUMBER OF BITS IN WHICH TO PACK (0 TO IGNORE) +C LB LOGICAL*1 (KF) BITMAP IF PRESENT +C F REAL (KF) DATA +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C 0 ALL OK +C OTHER W3FI72 GRIB PACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS +C GETBIT GET NUMBER OF BITS AND ROUND DATA +C W3FI72 PACK GRIB +C WRYTE WRITE DATA +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER KPDS(200),KGDS(200),KENS(200) + LOGICAL*1 LB(KF) + REAL F(KF) + PARAMETER(MAXBIT=16) + INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) + REAL FR(KF) + CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET W3FI72 PARAMETERS + CALL R63W72(KPDS,KGDS,IPDS,IGDS) + IBDS=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C COUNT VALID DATA + KBM=KF + IF(IPDS(7).NE.0) THEN + KBM=0 + DO I=1,KF + IF(LB(I)) THEN + IBM(I)=1 + KBM=KBM+1 + ELSE + IBM(I)=0 + ENDIF + ENDDO + IF(KBM.EQ.KF) IPDS(7)=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET NUMBER OF BITS AND ROUND DATA + IF(NBITS.GT.0) THEN + DO I=1,KF + FR(I)=F(I) + ENDDO + NBIT=NBITS + ELSE + IF(KBM.EQ.0) THEN + DO I=1,KF + FR(I)=0. + ENDDO + NBIT=0 + ELSE + CALL GETBIT(IPDS(7),IBS,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) + NBIT=MIN(NBIT,MAXBIT) + ENDIF + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C CREATE PRODUCT DEFINITION SECTION + CALL W3FI68(IPDS,PDS) + IF(IPDS(24).EQ.2) THEN + ILAST=45 + CALL PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,PDS) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C PACK AND WRITE GRIB DATA + CALL W3FI72(0,FR,0,NBIT,1,IPDS,PDS, + & 1,255,IGDS,0,0,IBM,KF,IBDS, + & KFO,GRIB,LGRIB,IRET) + IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/putgbens.f b/WPS/ungrib/src/ngl/w3/putgbens.f new file mode 100755 index 00000000..6d01c137 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/putgbens.f @@ -0,0 +1,167 @@ +C----------------------------------------------------------------------- + SUBROUTINE PUTGBENS(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PUTGBENS PACKS AND WRITES A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. +C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBENS. +C THIS OBSOLESCENT VERSION HAS BEEN REPLACED BY PUTGBE. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL PUTGBENS(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C KF INTEGER NUMBER OF DATA POINTS +C KPDS INTEGER (200) PDS PARAMETERS +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C KGDS INTEGER (200) GDS PARAMETERS +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C KENS INTEGER (200) ENSEMBLE PDS PARMS +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C LB LOGICAL*1 (KF) BITMAP IF PRESENT +C F REAL (KF) DATA +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C 0 ALL OK +C OTHER W3FI72 GRIB PACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C PUTGBE PACK AND WRITE GRIB MESSAGE +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER KPDS(200),KGDS(200),KENS(200) + LOGICAL*1 LB(KF) + REAL F(KF) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + PRINT *,'PLEASE USE PUTGBE RATHER THAN PUTGBENS' + CALL PUTGBE(LUGB,KF,KPDS,KGDS,KENS,LB,F,IRET) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/putgbex.f b/WPS/ungrib/src/ngl/w3/putgbex.f new file mode 100755 index 00000000..f21413e4 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/putgbex.f @@ -0,0 +1,222 @@ +C----------------------------------------------------------------------- + SUBROUTINE PUTGBEX(LUGB,KF,KPDS,KGDS,KENS, + & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PUTGBE PACKS AND WRITES A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. +C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGBE. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 97-02-11 Y.ZHU INCLUDED PROBABILITY AND CLUSTER ARGUMENTS +C +C USAGE: CALL PUTGBE(LUGB,KF,KPDS,KGDS,KENS, +C & KPROB,XPROB,KCLUST,KMEMBR,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C KF INTEGER NUMBER OF DATA POINTS +C KPDS INTEGER (200) PDS PARAMETERS +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C KGDS INTEGER (200) GDS PARAMETERS +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C KENS INTEGER (200) ENSEMBLE PDS PARMS +C (1) - APPLICATION IDENTIFIER +C (2) - ENSEMBLE TYPE +C (3) - ENSEMBLE IDENTIFIER +C (4) - PRODUCT IDENTIFIER +C (5) - SMOOTHING FLAG +C KPROB INTEGER (2) PROBABILITY ENSEMBLE PARMS +C XPROB REAL (2) PROBABILITY ENSEMBLE PARMS +C KCLUST INTEGER (16) CLUSTER ENSEMBLE PARMS +C KMEMBR INTEGER (8) CLUSTER ENSEMBLE PARMS +C LB LOGICAL*1 (KF) BITMAP IF PRESENT +C F REAL (KF) DATA +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C 0 ALL OK +C OTHER W3FI72 GRIB PACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS +C GETBIT GET NUMBER OF BITS AND ROUND DATA +C W3FI72 PACK GRIB +C WRYTE WRITE DATA +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER KPDS(200),KGDS(200),KENS(200) + INTEGER KPROB(2),KCLUST(16),KMEMBR(80) + REAL XPROB(2) + LOGICAL*1 LB(KF) + REAL F(KF) + PARAMETER(MAXBIT=16) + INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) + REAL FR(KF) + CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET W3FI72 PARAMETERS + CALL R63W72(KPDS,KGDS,IPDS,IGDS) + IBDS=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C COUNT VALID DATA + KBM=KF + IF(IPDS(7).NE.0) THEN + KBM=0 + DO I=1,KF + IF(LB(I)) THEN + IBM(I)=1 + KBM=KBM+1 + ELSE + IBM(I)=0 + ENDIF + ENDDO + IF(KBM.EQ.KF) IPDS(7)=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET NUMBER OF BITS AND ROUND DATA + IF(KBM.EQ.0) THEN + DO I=1,KF + FR(I)=0. + ENDDO + NBIT=0 + ELSE + CALL GETBIT(IPDS(7),0,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) + NBIT=MIN(NBIT,MAXBIT) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C CREATE PRODUCT DEFINITION SECTION + CALL W3FI68(IPDS,PDS) + IF(IPDS(24).EQ.2) THEN + ILAST=86 + CALL PDSENS(KENS,KPROB,XPROB,KCLUST,KMEMBR,ILAST,PDS) + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C PACK AND WRITE GRIB DATA + CALL W3FI72(0,FR,0,NBIT,1,IPDS,PDS, + & 1,255,IGDS,0,0,IBM,KF,IBDS, + & KFO,GRIB,LGRIB,IRET) + IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/putgbn.f b/WPS/ungrib/src/ngl/w3/putgbn.f new file mode 100755 index 00000000..671f1106 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/putgbn.f @@ -0,0 +1,209 @@ +C----------------------------------------------------------------------- + SUBROUTINE PUTGBN(LUGB,KF,KPDS,KGDS,IBS,NBITS,LB,F,IRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: PUTGBN PACKS AND WRITES A GRIB MESSAGE +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 94-04-01 +C +C ABSTRACT: PACK AND WRITE A GRIB MESSAGE. +C THIS SUBPROGRAM IS NEARLY THE INVERSE OF GETGB. +C +C PROGRAM HISTORY LOG: +C 94-04-01 IREDELL +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL PUTGBN(LUGB,KF,KPDS,KGDS,NBITS,LB,F,IRET) +C INPUT ARGUMENTS: +C LUGB INTEGER UNIT OF THE UNBLOCKED GRIB DATA FILE +C KF INTEGER NUMBER OF DATA POINTS +C KPDS INTEGER (200) PDS PARAMETERS +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C KGDS INTEGER (200) GDS PARAMETERS +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C IBS INTEGER BINARY SCALE FACTOR (0 TO IGNORE) +C NBITS INTEGER NUMBER OF BITS IN WHICH TO PACK (0 TO IGNORE) +C LB LOGICAL*1 (KF) BITMAP IF PRESENT +C F REAL (KF) DATA +C OUTPUT ARGUMENTS: +C IRET INTEGER RETURN CODE +C 0 ALL OK +C OTHER W3FI72 GRIB PACKER RETURN CODE +C +C SUBPROGRAMS CALLED: +C R63W72 MAP W3FI63 PARAMETERS ONTO W3FI72 PARAMETERS +C GETBIT GET NUMBER OF BITS AND ROUND DATA +C W3FI72 PACK GRIB +C WRYTE WRITE DATA +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C DO NOT ENGAGE THE SAME LOGICAL UNIT FROM MORE THAN ONE PROCESSOR. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ + INTEGER KPDS(200),KGDS(200) + LOGICAL*1 LB(KF) + REAL F(KF) + PARAMETER(MAXBIT=16) + INTEGER IBM(KF),IPDS(200),IGDS(200),IBDS(200) + REAL FR(KF) + CHARACTER PDS(400),GRIB(1000+KF*(MAXBIT+1)/8) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET W3FI72 PARAMETERS + CALL R63W72(KPDS,KGDS,IPDS,IGDS) + IBDS=0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C COUNT VALID DATA + KBM=KF + IF(IPDS(7).NE.0) THEN + KBM=0 + DO I=1,KF + IF(LB(I)) THEN + IBM(I)=1 + KBM=KBM+1 + ELSE + IBM(I)=0 + ENDIF + ENDDO + IF(KBM.EQ.KF) IPDS(7)=0 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C GET NUMBER OF BITS AND ROUND DATA + IF(NBITS.GT.0) THEN + DO I=1,KF + FR(I)=F(I) + ENDDO + NBIT=NBITS + ELSE + IF(KBM.EQ.0) THEN + DO I=1,KF + FR(I)=0. + ENDDO + NBIT=0 + ELSE + CALL GETBIT(IPDS(7),IBS,IPDS(25),KF,IBM,F,FR,FMIN,FMAX,NBIT) + NBIT=MIN(NBIT,MAXBIT) + ENDIF + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C PACK AND WRITE GRIB DATA + CALL W3FI72(0,FR,0,NBIT,0,IPDS,PDS, + & 1,255,IGDS,0,0,IBM,KF,IBDS, + & KFO,GRIB,LGRIB,IRET) + IF(IRET.EQ.0) CALL WRYTE(LUGB,LGRIB,GRIB) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/r63w72.f b/WPS/ungrib/src/ngl/w3/r63w72.f new file mode 100755 index 00000000..4d52ab96 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/r63w72.f @@ -0,0 +1,125 @@ + SUBROUTINE R63W72(KPDS,KGDS,IPDS,IGDS) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: R63W72 CONVERT W3FI63 PARMS TO W3FI72 PARMS +C PRGMMR: IREDELL ORG: W/NMC23 DATE: 92-10-31 +C +C ABSTRACT: DETERMINES THE INTEGER PDS AND GDS PARAMETERS +C FOR THE GRIB1 PACKING ROUTINE W3FI72 GIVEN THE PARAMETERS +C RETURNED FROM THE GRIB1 UNPACKING ROUTINE W3FI63. +C +C PROGRAM HISTORY LOG: +C 91-10-31 MARK IREDELL +C 96-05-03 MARK IREDELL CORRECTED SOME LEVEL TYPES AND +C SOME DATA REPRESENTATION TYPES +C 97-02-14 MARK IREDELL ONLY ALTERED IPDS(26:27) FOR EXTENDED PDS +C 98-06-01 CHRIS CARUSO Y2K FIX FOR YEAR OF CENTURY +C 2005-05-06 DIANE STOKES RECOGNIZE LEVEL 236 +C +C USAGE: CALL R63W72(KPDS,KGDS,IPDS,IGDS) +C +C INPUT ARGUMENT LIST: +C KPDS - INTEGER (200) PDS PARAMETERS FROM W3FI63 +C KGDS - INTEGER (200) GDS PARAMETERS FROM W3FI63 +C +C OUTPUT ARGUMENT LIST: +C IPDS - INTEGER (200) PDS PARAMETERS FOR W3FI72 +C IGDS - INTEGER (200) GDS PARAMETERS FOR W3FI72 +C +C REMARKS: KGDS AND IGDS EXTEND BEYOND THEIR DIMENSIONS HERE +C IF PL PARAMETERS ARE PRESENT. +C +C ATTRIBUTES: +C LANGUAGE: CRAY FORTRAN +C +C$$$ + DIMENSION KPDS(200),KGDS(200),IPDS(200),IGDS(200) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE PRODUCT DEFINITION SECTION (PDS) PARAMETERS + IF(KPDS(23).NE.2) THEN + IPDS(1)=28 ! LENGTH OF PDS + ELSE + IPDS(1)=45 ! LENGTH OF PDS + ENDIF + IPDS(2)=KPDS(19) ! PARAMETER TABLE VERSION + IPDS(3)=KPDS(1) ! ORIGINATING CENTER + IPDS(4)=KPDS(2) ! GENERATING MODEL + IPDS(5)=KPDS(3) ! GRID DEFINITION + IPDS(6)=MOD(KPDS(4)/128,2) ! GDS FLAG + IPDS(7)=MOD(KPDS(4)/64,2) ! BMS FLAG + IPDS(8)=KPDS(5) ! PARAMETER INDICATOR + IPDS(9)=KPDS(6) ! LEVEL TYPE + IF(KPDS(6).EQ.101.OR.KPDS(6).EQ.104.OR.KPDS(6).EQ.106.OR. + & KPDS(6).EQ.108.OR.KPDS(6).EQ.110.OR.KPDS(6).EQ.112.OR. + & KPDS(6).EQ.114.OR.KPDS(6).EQ.116.OR.KPDS(6).EQ.121.OR. + & KPDS(6).EQ.128.OR.KPDS(6).EQ.141.OR.KPDS(6).EQ.236) THEN + IPDS(10)=MOD(KPDS(7)/256,256) ! LEVEL VALUE 1 + IPDS(11)=MOD(KPDS(7),256) ! LEVEL VALUE 2 + ELSE + IPDS(10)=0 ! LEVEL VALUE 1 + IPDS(11)=KPDS(7) ! LEVEL VALUE 2 + ENDIF + IPDS(12)=KPDS(8) ! YEAR OF CENTURY + IPDS(13)=KPDS(9) ! MONTH + IPDS(14)=KPDS(10) ! DAY + IPDS(15)=KPDS(11) ! HOUR + IPDS(16)=KPDS(12) ! MINUTE + IPDS(17)=KPDS(13) ! FORECAST TIME UNIT + IPDS(18)=KPDS(14) ! TIME RANGE 1 + IPDS(19)=KPDS(15) ! TIME RANGE 2 + IPDS(20)=KPDS(16) ! TIME RANGE INDICATOR + IPDS(21)=KPDS(17) ! NUMBER IN AVERAGE + IPDS(22)=KPDS(20) ! NUMBER MISSING IN AVERAGE + IPDS(23)=KPDS(21) ! CENTURY + IPDS(24)=KPDS(23) ! SUBCENTER + IPDS(25)=KPDS(22) ! DECIMAL SCALING + IF(IPDS(1).GT.28) THEN + IPDS(26)=0 ! PDS BYTE 29 + IPDS(27)=0 ! PDS BYTE 30 + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C DETERMINE GRID DEFINITION SECTION (GDS) PARAMETERS + IGDS(1)=KGDS(19) ! NUMBER OF VERTICAL COORDINATES + IGDS(2)=KGDS(20) ! VERTICAL COORDINATES + IGDS(3)=KGDS(1) ! DATA REPRESENTATION + IGDS(4)=KGDS(2) ! (UNIQUE TO REPRESENTATION) + IGDS(5)=KGDS(3) ! (UNIQUE TO REPRESENTATION) + IGDS(6)=KGDS(4) ! (UNIQUE TO REPRESENTATION) + IGDS(7)=KGDS(5) ! (UNIQUE TO REPRESENTATION) + IGDS(8)=KGDS(6) ! (UNIQUE TO REPRESENTATION) + IGDS(9)=KGDS(7) ! (UNIQUE TO REPRESENTATION) + IGDS(10)=KGDS(8) ! (UNIQUE TO REPRESENTATION) + IGDS(11)=KGDS(9) ! (UNIQUE TO REPRESENTATION) + IGDS(12)=KGDS(10) ! (UNIQUE TO REPRESENTATION) + IGDS(13)=KGDS(11) ! (UNIQUE TO REPRESENTATION) + IGDS(14)=KGDS(12) ! (UNIQUE TO REPRESENTATION) + IGDS(15)=KGDS(13) ! (UNIQUE TO REPRESENTATION) + IGDS(16)=KGDS(14) ! (UNIQUE TO REPRESENTATION) + IGDS(17)=KGDS(15) ! (UNIQUE TO REPRESENTATION) + IGDS(18)=KGDS(16) ! (UNIQUE TO REPRESENTATION) +C EXCEPTIONS FOR LATLON OR GAUSSIAN + IF(KGDS(1).EQ.0.OR.KGDS(1).EQ.4) THEN + IGDS(11)=KGDS(10) + IGDS(12)=KGDS(9) +C EXCEPTIONS FOR MERCATOR + ELSEIF(KGDS(1).EQ.1) THEN + IGDS(11)=KGDS(13) + IGDS(12)=KGDS(12) + IGDS(13)=KGDS(9) + IGDS(14)=KGDS(11) +C EXCEPTIONS FOR LAMBERT CONFORMAL + ELSEIF(KGDS(1).EQ.3) THEN + IGDS(15)=KGDS(12) + IGDS(16)=KGDS(13) + IGDS(17)=KGDS(14) + IGDS(18)=KGDS(15) + ENDIF +C EXTENSION FOR PL PARAMETERS + IF(KGDS(1).EQ.0.AND.KGDS(19).EQ.0.AND.KGDS(20).NE.255) THEN + DO J=1,KGDS(3) + IGDS(18+J)=KGDS(21+J) + ENDDO + ENDIF +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/sbyte.f b/WPS/ungrib/src/ngl/w3/sbyte.f new file mode 100755 index 00000000..d6b91817 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/sbyte.f @@ -0,0 +1,107 @@ + SUBROUTINE SBYTE(IPACKD,IUNPKD,NOFF,NBITS) +C THIS PROGRAM WRITTEN BY..... +C DR. ROBERT C. GAMMILL, CONSULTANT +C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH +C JULY 1972 +C +C THIS IS THE FORTRAN 32 bit VERSION OF SBYTE. +C Changes for SiliconGraphics IRIS-4D/25 +C SiliconGraphics 3.3 FORTRAN 77 +C MARCH 1991 RUSSELL E. JONES +C NATIONAL WEATHER SERVICE +C +C*********************************************************************** +C +C SUBROUTINE SBYTE (IPACKD,IUNPKD,NOFF,NBITS) +C +C PURPOSE GIVEN A BYTE, RIGHT-JUSTIFIED IN A WORD, TO +C PACK THE BYTE INTO A TARGET WORD OR ARRAY. +C BITS SURROUNDING THE BYTE IN THE TARGET +C AREA ARE UNCHANGED. +C +C USAGE CALL SBYTE (IPACKD,IUNPKD,NOFF,NBITS) +C +C ARGUMENTS +C ON INPUT IPACKD +C THE WORD OR ARRAY WHICH WILL CONTAIN THE +C PACKED BYTE. BYTE MAY CROSS WORD BOUNDARIES. +C +C IUNPKD +C THE WORD CONTAINING THE RIGHT-JUSTIFIED BYTE +C TO BE PACKED. +C +C NOFF +C THE NUMBER OF BITS TO SKIP, LEFT TO RIGHT, +C IN 'IPACKD' IN ORDER TO LOCATE WHERE THE +C BYTE IS TO BE PACKED. +C +C NBITS +C NUMBER OF BITS IN THE BYTE TO BE PACKED. +C MAXIMUM OF 64 BITS ON 64 BIT MACHINE, 32 +C BITS ON 32 BIT MACHINE. +C +C ON OUTPUT IPACKD +C WORD OR CONSECUTIVE WORDS CONTAINING THE +C REQUESTED BYTE. +C*********************************************************************** + + INTEGER IUNPKD + INTEGER IPACKD(*) + INTEGER MASKS(64) +C + SAVE +C + DATA IFIRST/1/ + IF(IFIRST.EQ.1) THEN + CALL W3FI01(LW) + NBITSW = 8 * LW + JSHIFT = -1 * NINT(ALOG(FLOAT(NBITSW)) / ALOG(2.0)) + MASKS(1) = 1 + DO I=2,NBITSW-1 + MASKS(I) = 2 * MASKS(I-1) + 1 + ENDDO + MASKS(NBITSW) = -1 + IFIRST = 0 + ENDIF +C +C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW +C + ICON = NBITSW - NBITS + IF (ICON.LT.0) RETURN + MASK = MASKS(NBITS) +C +C INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED. +C + INDEX = ISHFT(NOFF,JSHIFT) +C +C II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT. +C + II = MOD(NOFF,NBITSW) +C + J = IAND(MASK,IUNPKD) + MOVEL = ICON - II +C +C BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT. +C + IF (MOVEL.GT.0) THEN + MSK = ISHFT(MASK,MOVEL) + IPACKD(INDEX+1) = IOR(IAND(NOT(MSK),IPACKD(INDEX+1)), + & ISHFT(J,MOVEL)) +C +C THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK. +C + ELSE IF (MOVEL.LT.0) THEN + MSK = MASKS(NBITS+MOVEL) + IPACKD(INDEX+1) = IOR(IAND(NOT(MSK),IPACKD(INDEX+1)), + & ISHFT(J,MOVEL)) + ITEMP = IAND(MASKS(NBITSW+MOVEL),IPACKD(INDEX+2)) + IPACKD(INDEX+2) = IOR(ITEMP,ISHFT(J,NBITSW+MOVEL)) +C +C BYTE IS TO BE STORED RIGHT-ADJUSTED. +C + ELSE + IPACKD(INDEX+1) = IOR(IAND(NOT(MASK),IPACKD(INDEX+1)),J) + ENDIF +C + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/sbytes.f b/WPS/ungrib/src/ngl/w3/sbytes.f new file mode 100755 index 00000000..d5c501f9 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/sbytes.f @@ -0,0 +1,138 @@ + SUBROUTINE SBYTES(IPACKD,IUNPKD,NOFF,NBITS,ISKIP,ITER) +C THIS PROGRAM WRITTEN BY..... +C DR. ROBERT C. GAMMILL, CONSULTANT +C NATIONAL CENTER FOR ATMOSPHERIC RESEARCH +C JULY 1972 +C THIS IS THE FORTRAN VERSIONS OF SBYTES. +C +C Changes for SiliconGraphics IRIS-4D/25 +C SiliconGraphics 3.3 FORTRAN 77 +C March 1991 RUSSELL E. JONES +C NATIONAL WEATHER SERVICE +C +C*********************************************************************** +C +C SUBROUTINE SBYTE (IPACKD,IUNPKD,NOFF,NBITS,ISKIP,ITER) +C +C PURPOSE GIVEN A BYTE, RIGHT-JUSTIFIED IN A WORD, TO +C PACK THE BYTE INTO A TARGET WORD OR ARRAY. +C BITS SURROUNDING THE BYTE IN THE TARGET +C AREA ARE UNCHANGED. +C +C USAGE CALL SBYTE (IPACKD,IUNPKD,NOFF,NBITS) +C +C ARGUMENTS +C ON INPUT IPACKD +C THE WORD OR ARRAY WHICH WILL CONTAIN THE +C PACKED BYTE. BYTE MAY CROSS WORD BOUNDARIES. +C +C IUNPKD +C THE WORD CONTAINING THE RIGHT-JUSTIFIED BYTE +C TO BE PACKED. +C +C NOFF +C THE NUMBER OF BITS TO SKIP, LEFT TO RIGHT, +C IN 'IPACKD' IN ORDER TO LOCATE WHERE THE +C BYTE IS TO BE PACKED. +C +C NBITS +C NUMBER OF BITS IN THE BYTE TO BE PACKED. +C MAXIMUM OF 64 BITS ON 64 BIT MACHINE, 32 +C BITS ON 32 BIT MACHINE. +C +C ISKIP +C THE NUMBER OF BITS TO SKIP BETWEEN EACH BYTE +C IN 'IUNPKD' IN ORDER TO LOCATE THE NEXT BYTE +C TO BE PACKED. +C +C ITER +C THE NUMBER OF BYTES TO BE PACKED. +C +C ON OUTPUT IPACKD +C WORD OR CONSECUTIVE WORDS CONTAINING THE +C REQUESTED BYTE. +C +C*********************************************************************** + + INTEGER IUNPKD(*) + INTEGER IPACKD(*) + INTEGER MASKS(64) +C + SAVE +C + DATA IFIRST/1/ + IF(IFIRST.EQ.1) THEN + CALL W3FI01(LW) + NBITSW = 8 * LW + JSHIFT = -1 * NINT(ALOG(FLOAT(NBITSW)) / ALOG(2.0)) + MASKS(1) = 1 + DO I=2,NBITSW-1 + MASKS(I) = 2 * MASKS(I-1) + 1 + ENDDO + MASKS(NBITSW) = -1 + IFIRST = 0 + ENDIF +C +C NBITS MUST BE LESS THAN OR EQUAL TO NBITSW +C + ICON = NBITSW - NBITS + IF (ICON.LT.0) RETURN + MASK = MASKS(NBITS) +C +C INDEX TELLS HOW MANY WORDS INTO IOUT THE NEXT BYTE IS TO BE STORED. +C + INDEX = ISHFT(NOFF,JSHIFT) +C +C II TELLS HOW MANY BITS IN FROM THE LEFT SIDE OF THE WORD TO STORE IT. +C + II = MOD(NOFF,NBITSW) +C +C ISTEP IS THE DISTANCE IUNPKD BITS FROM ONE BYTE POSITION TO THE NEXT. +C + ISTEP = NBITS + ISKIP +C +C IWORDS TELLS HOW MANY WORDS TO SKIP FROM ONE BYTE TO THE NEXT. +C + IWORDS = ISTEP / NBITSW +C +C IBITS TELLS HOW MANY BITS TO SKIP AFTER SKIPPING IWORDS. +C + IBITS = MOD(ISTEP,NBITSW) +C + DO 10 I = 1,ITER + J = IAND(MASK,IUNPKD(I)) + MOVEL = ICON - II +C +C BYTE IS TO BE STORED IN MIDDLE OF WORD. SHIFT LEFT. +C + IF (MOVEL.GT.0) THEN + MSK = ISHFT(MASK,MOVEL) + IPACKD(INDEX+1) = IOR(IAND(NOT(MSK),IPACKD(INDEX+1)), + & ISHFT(J,MOVEL)) +C +C THE BYTE IS TO BE SPLIT ACROSS A WORD BREAK. +C + ELSE IF (MOVEL.LT.0) THEN + MSK = MASKS(NBITS+MOVEL) + IPACKD(INDEX+1) = IOR(IAND(NOT(MSK),IPACKD(INDEX+1)), + & ISHFT(J,MOVEL)) + ITEMP = IAND(MASKS(NBITSW+MOVEL),IPACKD(INDEX+2)) + IPACKD(INDEX+2) = IOR(ITEMP,ISHFT(J,NBITSW+MOVEL)) +C +C BYTE IS TO BE STORED RIGHT-ADJUSTED. +C + ELSE + IPACKD(INDEX+1) = IOR(IAND(NOT(MASK),IPACKD(INDEX+1)),J) + ENDIF +C + II = II + IBITS + INDEX = INDEX + IWORDS + IF (II.GE.NBITSW) THEN + II = II - NBITSW + INDEX = INDEX + 1 + ENDIF +C +10 CONTINUE +C + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/start.f b/WPS/ungrib/src/ngl/w3/start.f new file mode 100644 index 00000000..a7a490ee --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/start.f @@ -0,0 +1,2 @@ + subroutine start + end subroutine diff --git a/WPS/ungrib/src/ngl/w3/summary.f b/WPS/ungrib/src/ngl/w3/summary.f new file mode 100644 index 00000000..5d925c87 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/summary.f @@ -0,0 +1,2 @@ + subroutine summary + end subroutine diff --git a/WPS/ungrib/src/ngl/w3/w3difdat.f b/WPS/ungrib/src/ngl/w3/w3difdat.f new file mode 100755 index 00000000..1e76b6e7 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3difdat.f @@ -0,0 +1,55 @@ +!----------------------------------------------------------------------- + subroutine w3difdat(jdat,idat,it,rinc) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! +! SUBPROGRAM: W3DIFDAT RETURN A TIME INTERVAL BETWEEN TWO DATES +! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 +! +! ABSTRACT: THIS SUBPROGRAM RETURNS THE ELAPSED TIME INTERVAL FROM +! AN NCEP ABSOLUTE DATE AND TIME GIVEN IN THE SECOND ARGUMENT UNTIL +! AN NCEP ABSOLUTE DATE AND TIME GIVEN IN THE FIRST ARGUMENT. +! THE OUTPUT TIME INTERVAL IS IN ONE OF SEVEN CANONICAL FORMS +! OF THE NCEP RELATIVE TIME INTERVAL DATA STRUCTURE. +! +! PROGRAM HISTORY LOG: +! 98-01-05 MARK IREDELL +! +! USAGE: CALL W3DIFDAT(JDAT,IDAT,IT,RINC) +! +! INPUT VARIABLES: +! JDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME +! (YEAR, MONTH, DAY, TIME ZONE, +! HOUR, MINUTE, SECOND, MILLISECOND) +! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME +! (YEAR, MONTH, DAY, TIME ZONE, +! HOUR, MINUTE, SECOND, MILLISECOND) +! IT INTEGER RELATIVE TIME INTERVAL FORMAT TYPE +! (-1 FOR FIRST REDUCED TYPE (HOURS ALWAYS POSITIVE), +! 0 FOR SECOND REDUCED TYPE (HOURS CAN BE NEGATIVE), +! 1 FOR DAYS ONLY, 2 FOR HOURS ONLY, 3 FOR MINUTES ONLY, +! 4 FOR SECONDS ONLY, 5 FOR MILLISECONDS ONLY) +! +! OUTPUT VARIABLES: +! RINC REAL (5) NCEP RELATIVE TIME INTERVAL +! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) +! (TIME INTERVAL IS POSITIVE IF JDAT IS LATER THAN IDAT.) +! +! SUBPROGRAMS CALLED: +! IW3JDN COMPUTE JULIAN DAY NUMBER +! W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! +!$$$ + integer jdat(8),idat(8) + real rinc(5) + real rinc1(5) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! difference the days and time and put into canonical form + rinc1(1)=iw3jdn(jdat(1),jdat(2),jdat(3))- + & iw3jdn(idat(1),idat(2),idat(3)) + rinc1(2:5)=jdat(5:8)-idat(5:8) + call w3reddat(it,rinc1,rinc) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end diff --git a/WPS/ungrib/src/ngl/w3/w3doxdat.f b/WPS/ungrib/src/ngl/w3/w3doxdat.f new file mode 100755 index 00000000..b36ad7c2 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3doxdat.f @@ -0,0 +1,40 @@ +!----------------------------------------------------------------------- + subroutine w3doxdat(idat,jdow,jdoy,jday) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! +! SUBPROGRAM: W3DOXDAT RETURN WEEK DAY, YEAR DAY, AND JULIAN DAY +! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 +! +! ABSTRACT: THIS SUBPROGRAM RETURNS THE INTEGER DAY OF WEEK, THE DAY +! OF YEAR, AND JULIAN DAY GIVEN AN NCEP ABSOLUTE DATE AND TIME. +! +! PROGRAM HISTORY LOG: +! 98-01-05 MARK IREDELL +! +! USAGE: CALL W3DOXDAT(IDAT,JDOW,JDOY,JDAY) +! +! INPUT VARIABLES: +! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME +! (YEAR, MONTH, DAY, TIME ZONE, +! HOUR, MINUTE, SECOND, MILLISECOND) +! +! OUTPUT VARIABLES: +! JDOW INTEGER DAY OF WEEK (1-7, WHERE 1 IS SUNDAY) +! JDOY INTEGER DAY OF YEAR (1-366, WHERE 1 IS JANUARY 1) +! JDAY INTEGER JULIAN DAY (DAY NUMBER FROM JAN. 1,4713 B.C.) +! +! SUBPROGRAMS CALLED: +! IW3JDN COMPUTE JULIAN DAY NUMBER +! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! +!$$$ + integer idat(8) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! get julian day and then get day of week and day of year + jday=iw3jdn(idat(1),idat(2),idat(3)) + call w3fs26(jday,jy,jm,jd,jdow,jdoy) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end diff --git a/WPS/ungrib/src/ngl/w3/w3fi01.f b/WPS/ungrib/src/ngl/w3/w3fi01.f new file mode 100755 index 00000000..22df36af --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi01.f @@ -0,0 +1,43 @@ + SUBROUTINE W3FI01(LW) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI01 DETERMINES MACHINE WORD LENGTH IN BYTES +C PRGMMR: KEYSER ORG: W/NMC22 DATE: 06-29-92 +C +C ABSTRACT: DETERMINES THE NUMBER OF BYTES IN A FULL WORD FOR THE +C PARTICULAR MACHINE (IBM OR CRAY). +C +C PROGRAM HISTORY LOG: +C 92-01-10 R. KISTLER (W/NMC23) +C 92-05-22 D. A. KEYSER -- DOCBLOCKED/COMMENTED +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL W3FI01(LW) +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C LW - MACHINE WORD LENGTH IN BYTES +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY, WORKSTATIONS +C +C$$$ +C + CHARACTER*8 CTEST1,CTEST2 + CHARACTER*4 CPRINT(2) +C + INTEGER ITEST1,ITEST2 +C + EQUIVALENCE (CTEST1,ITEST1),(CTEST2,ITEST2) +C + DATA CTEST1/'12345678'/ +C + ITEST2 = ITEST1 + IF (CTEST1 .EQ. CTEST2) THEN + LW = 8 + ELSE + LW = 4 + END IF + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi58.f b/WPS/ungrib/src/ngl/w3/w3fi58.f new file mode 100755 index 00000000..4b6c1774 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi58.f @@ -0,0 +1,115 @@ + SUBROUTINE W3FI58(IFIELD,NPTS,NWORK,NPFLD,NBITS,LEN,KMIN) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK *** +C . . . . +C SUBPROGRAM: W3FI58 - PACK POSITIVE DIFFERENCES IN LEAST BITS +C PRGMMR: ALLARD, R. ORG: NMC411 DATE: JULY 1987 +C +C ABSTRACT: CONVERTS AN ARRAY OF INTEGER NUMBERS INTO AN ARRAY OF +C POSITIVE DIFFERENCES (NUMBER(S) - MINIMUM VALUE) AND PACKS THE +C MAGNITUDE OF EACH DIFFERENCE RIGHT-ADJUSTED INTO THE LEAST +C NUMBER OF BITS THAT HOLDS THE LARGEST DIFFERENCE. +C +C PROGRAM HISTORY LOG: +C 87-09-02 ALLARD +C 88-10-02 R.E.JONES CONVERTED TO CDC CYBER 205 FTN200 FORTRAN +C 90-05-17 R.E.JONES CONVERTED TO CRAY CFT77 FORTRAN +C 90-05-18 R.E.JONES CHANGE NAME VBIMPK TO W3LIB NAME W3FI58 +C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE +C 96-05-14 IREDELL GENERALIZED COMPUTATION OF NBITS +C +C USAGE: CALL W3FI58(IFIELD,NPTS,NWORK,NPFLD,NBITS,LEN,KMIN) +C +C INPUT: +C +C IFIELD - ARRAY OF INTEGER DATA FOR PROCESSING +C NPTS - NUMBER OF DATA VALUES TO PROCESS IN IFIELD (AND NWORK) +C WHERE, NPTS > 0 +C +C OUTPUT: +C +C NWORK - WORK ARRAY WITH INTEGER DIFFERENCE +C NPFLD - ARRAY FOR PACKED DATA +C (USER IS RESPONSIBLE FOR AN ADEQUATE DIMENSION.) +C NBITS - NUMBER OF BITS USED TO PACK DATA WHERE, 0 < NBITS < 32 +C (THE MAXIMUM DIFFERENCE WITHOUT OVERFLOW IS 2**31 -1) +C LEN - NUMBER OF PACKED BYTES IN NPFLD (SET TO 0 IF NO PACKING) +C WHERE, LEN = (NBITS * NPTS + 7) / 8 WITHOUT REMAINDER +C KMIN - MINIMUM VALUE (SUBTRACTED FROM EACH DATUM). IF THIS +C PACKED DATA IS BEING USED FOR GRIB DATA, THE +C PROGRAMER WILL HAVE TO CONVERT THE KMIN VALUE TO AN +C IBM370 32 BIT FLOATING POINT NUMBER. +C +C SUBPROGRAMS CALLED: +C +C W3LIB: SBYTES, SBYTE +C +C EXIT STATES: NONE +C +C NOTE: LEN = 0, NBITS = 0, AND NO PACKING PERFORMED IF +C +C (1) KMAX = KMIN (A CONSTANT FIELD) +C (2) NPTS < 1 (SEE INPUT ARGUMENT) +C +C ATTRIBUTES: +C LANGUAGE: CRAY CFT77 FORTRAN +C MACHINE: CRAY Y-MP8/832 +C +C$$$ +C + INTEGER IFIELD(*) + INTEGER NPFLD(*) + INTEGER NWORK(*) +C + DATA KZERO / 0 / + PARAMETER(ALOG2=0.69314718056) +C +C / / / / / / +C + LEN = 0 + NBITS = 0 + IF (NPTS.LE.0) GO TO 3000 +C +C FIND THE MAX-MIN VALUES IN INTEGER FIELD (IFIELD). +C + KMAX = IFIELD(1) + KMIN = KMAX + DO 1000 I = 2,NPTS + KMAX = MAX(KMAX,IFIELD(I)) + KMIN = MIN(KMIN,IFIELD(I)) + 1000 CONTINUE +C +C IF A CONSTANT FIELD, RETURN WITH NO PACKING AND 'LEN' AND 'NBITS' SET +C TO ZERO. +C + IF (KMAX.EQ.KMIN) GO TO 3000 +C +C DETERMINE LARGEST DIFFERENCE IN IFIELD AND FLOAT (BIGDIF). +C + BIGDIF = KMAX - KMIN +C +C NBITS IS COMPUTED AS THE LEAST INTEGER SUCH THAT +C BIGDIF < 2**NBITS +C + NBITS=LOG(BIGDIF+0.5)/ALOG2+1 +C +C FORM DIFFERENCES IN NWORK ARRAY. +C + DO 2000 K = 1,NPTS + NWORK(K) = IFIELD(K) - KMIN + 2000 CONTINUE +C +C PACK EACH MAGNITUDE IN NBITS (NBITS = THE LEAST POWER OF 2 OR 'N') +C + LEN=(NBITS*NPTS-1)/8+1 + CALL SBYTES(NPFLD,NWORK,0,NBITS,0,NPTS) +C +C ADD ZERO-BITS AT END OF PACKED DATA TO INSURE A BYTE BOUNDARY. +C + NOFF = NBITS * NPTS + NZERO=LEN*8-NOFF + IF(NZERO.GT.0) CALL SBYTE(NPFLD,KZERO,NOFF,NZERO) +C + 3000 CONTINUE + RETURN +C + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi59.f b/WPS/ungrib/src/ngl/w3/w3fi59.f new file mode 100755 index 00000000..a05aa172 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi59.f @@ -0,0 +1,130 @@ + SUBROUTINE W3FI59(FIELD,NPTS,NBITS,NWORK,NPFLD,ISCALE,LEN,RMIN) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI59 FORM AND PACK POSITIVE, SCALED DIFFERENCES +C PRGMMR: ALLARD, R. ORG: NMC41 DATE: 84-08-01 +C +C ABSTRACT: CONVERTS AN ARRAY OF SINGLE PRECISION REAL NUMBERS INTO +C AN ARRAY OF POSITIVE SCALED DIFFERENCES (NUMBER(S) - MINIMUM VALUE), +C IN INTEGER FORMAT AND PACKS THE ARGUMENT-SPECIFIED NUMBER OF +C SIGNIFICANT BITS FROM EACH DIFFERENCE. +C +C PROGRAM HISTORY LOG: +C 84-08-01 ALLARD ORIGINAL AUTHOR +C 90-05-17 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN +C 90-05-18 R.E.JONES CHANGE NAME PAKMAG TO W3LIB NAME W3FI59 +C 93-07-06 R.E.JONES ADD NINT TO DO LOOP 2000 SO NUMBERS ARE +C ROUNDED TO NEAREST INTEGER, NOT TRUNCATED. +C 94-01-05 IREDELL COMPUTATION OF ISCALE FIXED WITH RESPECT TO +C THE 93-07-06 CHANGE. +C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE +C +C USAGE: CALL W3FI59(FIELD,NPTS,NBITS,NWORK,NPFLD,ISCALE,LEN,RMIN) +C INPUT ARGUMENT LIST: +C FIELD - ARRAY OF FLOATING POINT DATA FOR PROCESSING (REAL) +C NPTS - NUMBER OF DATA VALUES TO PROCESS IN FIELD (AND NWORK) +C WHERE, NPTS > 0 +C NBITS - NUMBER OF SIGNIFICANT BITS OF PROCESSED DATA TO BE PACKED +C WHERE, 0 < NBITS < 32+1 +C +C OUTPUT ARGUMENT LIST: +C NWORK - ARRAY FOR INTEGER CONVERSION (INTEGER) +C IF PACKING PERFORMED (SEE NOTE BELOW), THE ARRAY WILL +C CONTAIN THE PRE-PACKED, RIGHT ADJUSTED, SCALED, INTEGER +C DIFFERENCES UPON RETURN TO THE USER. +C (THE USER MAY EQUIVALENCE FIELD AND NWORK. SAME SIZE.) +C NPFLD - ARRAY FOR PACKED DATA (INTEGER) +C (DIMENSION MUST BE AT LEAST (NBITS * NPTS) / 64 + 1 ) +C ISCALE- POWER OF 2 FOR RESTORING DATA, SUCH THAT +C DATUM = (DIFFERENCE * 2**ISCALE) + RMIN +C LEN - NUMBER OF PACKED BYTES IN NPFLD (SET TO 0 IF NO PACKING) +C WHERE, LEN = (NBITS * NPTS + 7) / 8 WITHOUT REMAINDER +C RMIN - MINIMUM VALUE (REFERENCE VALUE SUBTRACTED FROM INPUT DATA) +C THIS IS A CRAY FLOATING POINT NUMBER, IT WILL HAVE TO BE +C CONVERTED TO AN IBM370 32 BIT FLOATING POINT NUMBER AT +C SOME POINT IN YOUR PROGRAM IF YOU ARE PACKING GRIB DATA. +C +C REMARKS: LEN = 0 AND NO PACKING PERFORMED IF +C +C (1) RMAX = RMIN (A CONSTANT FIELD) +C (2) NBITS VALUE OUT OF RANGE (SEE INPUT ARGUMENT) +C (3) NPTS VALUE LESS THAN 1 (SEE INPUT ARGUMENT) +C +C ATTRIBUTES: +C LANGUAGE: CRAY CFT77 FORTRAN +C MACHINE: CRAY C916/256, Y-MP8/864, Y-MP EL92/256, J916/2048 +C +C$$$ +C + REAL FIELD(*) +C + INTEGER NPFLD(*) + INTEGER NWORK(*) +C + DATA KZERO / 0 / +C +C NATURAL LOGARITHM OF 2 AND 0.5 PLUS NOMINAL SAFE EPSILON + PARAMETER(ALOG2=0.69314718056,HPEPS=0.500001) +C +C / / / / / / +C + LEN = 0 + ISCALE = 0 + IF (NBITS.LE.0.OR.NBITS.GT.32) GO TO 3000 + IF (NPTS.LE.0) GO TO 3000 +C +C FIND THE MAX-MIN VALUES IN FIELD. +C + RMAX = FIELD(1) + RMIN = RMAX + DO 1000 K = 2,NPTS + RMAX = AMAX1(RMAX,FIELD(K)) + RMIN = AMIN1(RMIN,FIELD(K)) + 1000 CONTINUE +C +C IF A CONSTANT FIELD, RETURN WITH NO PACKING PERFORMED AND 'LEN' = 0. +C + IF (RMAX.EQ.RMIN) GO TO 3000 +C +C DETERMINE LARGEST DIFFERENCE IN FIELD (BIGDIF). +C + BIGDIF = RMAX - RMIN +C +C ISCALE IS THE POWER OF 2 REQUIRED TO RESTORE THE PACKED DATA. +C ISCALE IS COMPUTED AS THE LEAST INTEGER SUCH THAT +C BIGDIF*2**(-ISCALE) < 2**NBITS-0.5 +C IN ORDER TO ENSURE THAT THE PACKED INTEGERS (COMPUTED IN LOOP 2000 +C WITH THE NEAREST INTEGER FUNCTION) STAY LESS THAN 2**NBITS. +C + ISCALE=NINT(ALOG(BIGDIF/(2.**NBITS-0.5))/ALOG2+HPEPS) +C +C FORM DIFFERENCES, RESCALE, AND CONVERT TO INTEGER FORMAT. +C + TWON = 2.0 ** (-ISCALE) + DO 2000 K = 1,NPTS + NWORK(K) = NINT( (FIELD(K) - RMIN) * TWON ) + 2000 CONTINUE +C +C PACK THE MAGNITUDES (RIGHTMOST NBITS OF EACH WORD). +C + KOFF = 0 + ISKIP = 0 +C +C USE NCAR ARRAY BIT PACKER SBYTES (GBYTES PACKAGE) +C + CALL SBYTES(NPFLD,NWORK,KOFF,NBITS,ISKIP,NPTS) +C +C ADD 7 ZERO-BITS AT END OF PACKED DATA TO INSURE BYTE BOUNDARY. +C USE NCAR WORD BIT PACKER SBYTE +C + NOFF = NBITS * NPTS + CALL SBYTE(NPFLD,KZERO,NOFF,7) +C +C DETERMINE BYTE LENGTH (LEN) OF PACKED FIELD (NPFLD). +C + LEN = (NOFF + 7) / 8 +C + 3000 CONTINUE + RETURN +C + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi63.f b/WPS/ungrib/src/ngl/w3/w3fi63.f new file mode 100755 index 00000000..ea17f45c --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi63.f @@ -0,0 +1,4062 @@ + SUBROUTINE W3FI63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI63 UNPK GRIB FIELD TO GRIB GRID +C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 +C +C ABSTRACT: UNPACK A GRIB (EDITION 1) FIELD TO THE EXACT GRID +C SPECIFIED IN THE GRIB MESSAGE, ISOLATE THE BIT MAP, AND MAKE +C THE VALUES OF THE PRODUCT DESCRIPTON SECTION (PDS) AND THE +C GRID DESCRIPTION SECTION (GDS) AVAILABLE IN RETURN ARRAYS. +C +C WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN +C RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL. +C +C PROGRAM HISTORY LOG: +C 91-09-13 CAVANAUGH +C 91-11-12 CAVANAUGH MODIFIED SIZE OF ECMWF GRIDS 5-8 +C 91-12-22 CAVANAUGH CORRECTED PROCESSING OF MERCATOR PROJECTIONS +C IN GRID DEFINITION SECTION (GDS) IN +C ROUTINE FI633 +C 92-08-05 CAVANAUGH CORRECTED MAXIMUM GRID SIZE TO ALLOW FOR +C ONE DEGREE BY ONE DEGREE GLOBAL GRIDS +C 92-08-27 CAVANAUGH CORRECTED TYPO ERROR, ADDED CODE TO COMPARE +C TOTAL BYTE SIZE FROM SECTION 0 WITH SUM OF +C SECTION SIZES. +C 92-10-21 CAVANAUGH CORRECTIONS WERE MADE (IN FI634) TO REDUCE +C PROCESSING TIME FOR INTERNATIONAL GRIDS. +C REMOVED A TYPOGRAPHICAL ERROR IN FI635. +C 93-01-07 CAVANAUGH CORRECTIONS WERE MADE (IN FI635) TO +C FACILITATE USE OF THESE ROUTINES ON A PC. +C A TYPOGRAPHICAL ERROR WAS ALSO CORRECTED +C 93-01-13 CAVANAUGH CORRECTIONS WERE MADE (IN FI632) TO +C PROPERLY HANDLE CONDITION WHEN +C TIME RANGE INDICATOR = 10. +C ADDED U.S.GRID 87. +C 93-02-04 CAVANAUGH ADDED U.S.GRIDS 85 AND 86 +C 93-02-26 CAVANAUGH ADDED GRIDS 2, 3, 37 THRU 44,AND +C GRIDS 55, 56, 90, 91, 92, AND 93 TO +C LIST OF U.S. GRIDS. +C 93-04-07 CAVANAUGH ADDED GRIDS 67 THRU 77 TO +C LIST OF U.S. GRIDS. +C 93-04-20 CAVANAUGH INCREASED MAX SIZE TO ACCOMODATE +C GAUSSIAN GRIDS. +C 93-05-26 CAVANAUGH CORRECTED GRID RANGE SELECTION IN FI634 +C FOR RANGES 67-71 & 75-77 +C 93-06-08 CAVANAUGH CORRECTED FI635 TO ACCEPT GRIB MESSAGES +C WITH SECOND ORDER PACKING. ADDED ROUTINE FI636 +C TO PROCESS MESSAGES WITH SECOND ORDER PACKING. +C 93-09-22 CAVANAUGH MODIFIED TO EXTRACT SUB-CENTER NUMBER FROM +C PDS BYTE 26 +C 93-10-13 CAVANAUGH MODIFIED FI634 TO CORRECT GRID SIZES FOR +C GRIDS 204 AND 208 +C 93-10-14 CAVANAUGH INCREASED SIZE OF KGDS TO INCLUDE ENTRIES FOR +C NUMBER OF POINTS IN GRID AND NUMBER OF WORDS +C IN EACH ROW +C 93-12-08 CAVANAUGH CORRECTED TEST FOR EDITION NUMBER INSTEAD +C OF VERSION NUMBER +C 93-12-15 CAVANAUGH MODIFIED SECOND ORDER POINTERS TO FIRST ORDER +C VALUES AND SECOND ORDER VALUES CORRECTLY +C IN ROUTINE FI636 +C 94-03-02 CAVANAUGH ADDED CALL TO W3FI83 WITHIN DECODER. USER +C NO LONGER NEEDS TO MAKE CALL TO THIS ROUTINE +C 94-04-22 CAVANAUGH MODIFIED FI635, FI636 TO PROCESS ROW BY ROW +C SECOND ORDER PACKING, ADDED SCALING CORRECTION +C TO FI635, AND CORRECTED TYPOGRAPHICAL ERRORS +C IN COMMENT FIELDS IN FI634 +C 94-05-17 CAVANAUGH CORRECTED ERROR IN FI633 TO EXTRACT RESOLUTION +C FOR LAMBERT-CONFORMAL GRIDS. ADDED CLARIFYING +C INFORMATION TO DOCBLOCK ENTRIES +C 94-05-25 CAVANAUGH ADDED CODE TO PROCESS COLUMN BY COLUMN AS WELL +C AS ROW BY ROW ORDERING OF SECOND ORDER DATA +C 94-06-27 CAVANAUGH ADDED PROCESSING FOR GRIDS 45, 94 AND 95. +C INCLUDES CONSTRUCTION OF SECOND ORDER BIT MAPS +C FOR THINNED GRIDS IN FI636. +C 94-07-08 CAVANAUGH COMMENTED OUT PRINT OUTS USED FOR DEBUGGING +C 94-09-08 CAVANAUGH ADDED GRIDS 220, 221, 223 FOR FNOC +C 94-11-10 FARLEY INCREASED MXSIZE FROM 72960 TO 260000 +C FOR .5 DEGREE SST ANALYSIS FIELDS +C 94-12-06 R.E.JONES CHANGES IN FI632 FOR PDS GREATER THAN 28 +C 95-02-14 R.E.JONES CORRECT IN FI633 FOR NAVY WAFS GRIB +C 95-03-20 M.BALDWIN FI633 MODIFICATION TO GET +C DATA REP TYPES [KGDS(1)] 201 AND 202 TO WORK. +C 95-04-10 E.ROGERS ADDED GRIDS 96 AND 97 FOR ETA MODEL IN FI634. +C 95-04-26 R.E.JONES FI636 CORECTION FOR 2ND ORDER COMPLEX +C UNPACKING. R +C 95-05-19 R.E.JONES ADDED GRID 215, 20 KM AWIPS GRID +C 95-07-06 R.E.JONES ADDED GAUSSIAN T62, T126 GRID 98, 126 +C 95-10-19 R.E.JONES ADDED GRID 216, 45 KM ETA AWIPS ALASKA GRID +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 96-03-07 R.E.JONES CONTINUE UNPACK WITH KRET ERROR 9 IN FI631. +C 96-08-19 R.E.JONES ADDED MERCATOR GRIDS 8 AND 53, AND GRID 196 +C 97-02-12 W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING +C 98-06-17 IREDELL REMOVED ALTERNATE RETURN IN FI637 +C 98-08-31 IREDELL ELIMINATED NEED FOR MXSIZE +C 98-09-02 Gilbert Corrected error in map size for U.S. Grid 92 +C 98-09-08 BALDWIN ADD DATA REP TYPE [KGDS(1)] 203 +C 01-03-08 ROGERS CHANGED ETA GRIDS 90-97, ADDED ETA GRIDS +C 194, 198. ADDED AWIPS GRIDS 241,242,243, +C 245, 246, 247, 248, AND 250 +C 01-03-19 VUONG ADDED AWIPS GRIDS 238,239,240, AND 244 +C 2001-06-06 GILBERT Changed gbyte/sbyte calls to refer to +C Wesley Ebisuzaki's endian independent +C versions gbytec/sbytec. +C Removed equivalences. +C 01-05-03 ROGERS ADDED GRID 249 (12KM FOR ALASKA) +C 01-10-10 ROGERS REDEFINED GRID 218 FOR 12 KM ETA +C REDEFINED GRID 192 FOR NEW 32-KM ETA GRID +C 02-03-27 VUONG ADDED RSAS GRID 88 AND AWIPS GRIDS 219, 220, +C 223, 224, 225, 226, 227, 228, 229, 230, 231, +C 232, 233, 234, 235, 251, AND 252 +C 02-08-06 ROGERS REDEFINED GRIDS 90-93,97,194,245-250 FOR THE +C 8KM HI-RES-WINDOW MODEL AND ADD AWIPS GRID 253 +C 2003-06-30 GILBERT SET NEW VALUES IN ARRAY KPTR TO PASS BACK ADDITIONAL +C PACKING INFO. +C KPTR(19) - BINARY SCALE FACTOR +C KPTR(20) - NUM BITS USED TO PACK EACH DATUM +C 2003-06-30 GILBERT ADDED GRIDS 145 and 146 for CMAQ +C and GRID 175 for AWIPS over GUAM. +C 2003-07-08 VUONG ADDED GRIDS 110, 127, 171, 172 AND MODIFIED GRID 170 +C 2004-09-02 VUONG ADDED AWIPS GRIDS 147, 148, 173 AND 254 +C 2005-01-04 COOKE ADDED AWIPS GRIDS 160 AND 161 +C 2005-03-03 VUONG MOVED GRID 170 TO GRID 174 AND ADD GRID 170 +C 2005-03-21 VUONG ADDED AWIPS GRID 130 +C 2005-10-11 VUONG ADDED AWIPS GRID 163 +C 2006-12-12 VUONG ADDED AWIPS GRID 120 +C 2007-04-12 VUONG ADDED AWIPS 176 AND DATA REP TYPE KGDS(1) 204 +C 2007-06-11 VUONG ADDED NEW GRIDS 11 TO 18 AND 122 TO 125 AND 138 +C AND 180 TO 183 +C 2007-11-06 VUONG CHANGED GRID 198 FROM ARAKAWA STAGGERED E-GRID TO POLAR +C STEREOGRAPGIC GRID ADDED NEW GRID 10, 99, 150, 151, 197 +C 2008-01-17 VUONG ADDED NEW GRID 195 AND CHANGED GRID 196 (ARAKAWA-E TO MERCATOR) +C 2009-05-21 VUONG MODIFIED TO HANDLE GRID 45 +C 2010-05-11 VUONG DATA REP TYPE KGDS(1) 205 +C 2010-02-18 VUONG ADDED GRID 128, 139 AND 140 +C 2010-07-20 GAYNO ADDED ROTATED LAT/LON "A,B,C,D" STAGGERS -> KGDS(1) 205 +C 2010-08-05 VUONG ADDED NEW GRID 184, 199, 83 AND +C REDEFINED GRID 90 FOR NEW RTMA CONUS 1.27-KM +C REDEFINED GRID 91 FOR NEW RTMA ALASKA 2.976-KM +C REDEFINED GRID 92 FOR NEW RTMA ALASKA 1.488-KM +C 2010-09-08 ROGERS CHANGED GRID 94 TO ALASKA 6KM STAGGERED B-GRID +C CHANGED GRID 95 TO PUERTO RICO 3KM STAGGERED B-GRID +C CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID +C CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID +C CHANGED GRID 97 TO CONUS 4KM STAGGERED B-GRID +C CHANGED GRID 99 TO NAM 12KM STAGGERED B-GRID +C ADDED GRID 179 (12 KM POLAR STEREOGRAPHIC OVER NORTH AMERICA) +C CHANGED GRID 194 TO 3KM MERCATOR GRID OVER PUERTO RICO +C CORRECTED LATITUDE OF SW CORNER POINT OF GRID 151 +C 2011-10-12 VUONG ADDED GRID 129, 187, 188, 189 AND 193 +C 2012-04-16 VUONG ADDED NEW GRID 132, 200 +C +C USAGE: CALL W3FI63(MSGA,KPDS,KGDS,KBMS,DATA,KPTR,KRET) +C INPUT ARGUMENT LIST: +C MSGA - GRIB FIELD - "GRIB" THRU "7777" CHAR*1 +C (MESSAGE CAN BE PRECEDED BY JUNK CHARS) +C +C OUTPUT ARGUMENT LIST: +C DATA - ARRAY CONTAINING DATA ELEMENTS +C KPDS - ARRAY CONTAINING PDS ELEMENTS. (EDITION 1) +C (1) - ID OF CENTER +C (2) - GENERATING PROCESS ID NUMBER +C (3) - GRID DEFINITION +C (4) - GDS/BMS FLAG (RIGHT ADJ COPY OF OCTET 8) +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR INCLUDING (CENTURY-1) +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - VERSION NR OF GRIB SPECIFICATION +C (19) - VERSION NR OF PARAMETER TABLE +C (20) - NR MISSING FROM AVERAGE/ACCUMULATION +C (21) - CENTURY OF REFERENCE TIME OF DATA +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER NUMBER +C (24) - PDS BYTE 29, FOR NMC ENSEMBLE PRODUCTS +C 128 IF FORECAST FIELD ERROR +C 64 IF BIAS CORRECTED FCST FIELD +C 32 IF SMOOTHED FIELD +C WARNING: CAN BE COMBINATION OF MORE THAN 1 +C (25) - PDS BYTE 30, NOT USED +C (26-35) - RESERVED +C (36-N) - CONSECUTIVE BYTES EXTRACTED FROM PROGRAM +C DEFINITION SECTION (PDS) OF GRIB MESSAGE +C KGDS - ARRAY CONTAINING GDS ELEMENTS. +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C GAUSSIAN GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - N - NR OF CIRCLES POLE TO EQUATOR +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - NV - NR OF VERT COORD PARAMETERS +C (13) - PV - OCTET NR OF LIST OF VERT COORD PARAMETERS +C OR +C PL - LOCATION OF THE LIST OF NUMBERS OF POINTS IN +C EACH ROW (IF NO VERT COORD PARAMETERS +C ARE PRESENT +C OR +C 255 IF NEITHER ARE PRESENT +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE (RIGHT ADJ COPY OF OCTET 28) +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIT - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C E-STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (TYPE 203) +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF CENTER +C (8) - LO(2) LONGITUDE OF CENTER +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C CURVILINEAR ORTHIGINAL GRID (TYPE 204) +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - RESERVED SET TO 0 +C (5) - RESERVED SET TO 0 +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - RESERVED SET TO 0 +C (8) - RESERVED SET TO 0 +C (9) - RESERVED SET TO 0 +C (10) - RESERVED SET TO 0 +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C ROTATED LAT/LON A,B,C,D-STAGGERED (TYPE 205) +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF FIRST POINT +C (5) - LO(1) LONGITUDE OF FIRST POINT +C (6) - RESOLUTION FLAG (RIGHT ADJ COPY OF OCTET 17) +C (7) - LA(2) LATITUDE OF CENTER +C (8) - LO(2) LONGITUDE OF CENTER +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG (RIGHT ADJ COPY OF OCTET 28) +C (12) - LATITUDE OF LAST POINT +C (13) - LONGITUDE OF LAST POINT +C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. +C (ALWAYS CONSTRUCTED) +C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS +C (1) - TOTAL LENGTH OF GRIB MESSAGE +C (2) - LENGTH OF INDICATOR (SECTION 0) +C (3) - LENGTH OF PDS (SECTION 1) +C (4) - LENGTH OF GDS (SECTION 2) +C (5) - LENGTH OF BMS (SECTION 3) +C (6) - LENGTH OF BDS (SECTION 4) +C (7) - VALUE OF CURRENT BYTE +C (8) - BIT POINTER +C (9) - GRIB START BIT NR +C (10) - GRIB/GRID ELEMENT COUNT +C (11) - NR UNUSED BITS AT END OF SECTION 3 +C (12) - BIT MAP FLAG (COPY OF BMS OCTETS 5,6) +C (13) - NR UNUSED BITS AT END OF SECTION 2 +C (14) - BDS FLAGS (RIGHT ADJ COPY OF OCTET 4) +C (15) - NR UNUSED BITS AT END OF SECTION 4 +C (16) - RESERVED +C (17) - RESERVED +C (18) - RESERVED +C (19) - BINARY SCALE FACTOR +C (20) - NUM BITS USED TO PACK EACH DATUM +C KRET - FLAG INDICATING QUALITY OF COMPLETION +C +C REMARKS: WHEN DECODING IS COMPLETED, DATA AT EACH GRID POINT HAS BEEN +C RETURNED IN THE UNITS SPECIFIED IN THE GRIB MANUAL. +C +C VALUES FOR RETURN FLAG (KRET) +C KRET = 0 - NORMAL RETURN, NO ERRORS +C = 1 - 'GRIB' NOT FOUND IN FIRST 100 CHARS +C = 2 - '7777' NOT IN CORRECT LOCATION +C = 3 - UNPACKED FIELD IS LARGER THAN 260000 +C = 4 - GDS/ GRID NOT ONE OF CURRENTLY ACCEPTED VALUES +C = 5 - GRID NOT CURRENTLY AVAIL FOR CENTER INDICATED +C = 8 - TEMP GDS INDICATED, BUT GDS FLAG IS OFF +C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID +C =10 - INCORRECT CENTER INDICATOR +C =11 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED. +C PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS +C SHOWN IN OCTETS 4 AND 14. +C =12 - BINARY DATA SECTION (BDS) NOT COMPLETELY PROCESSED. +C PROGRAM IS NOT SET TO PROCESS FLAG COMBINATIONS +C +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ +C 4 AUG 1988 +C W3FI63 +C +C +C GRIB UNPACKING ROUTINE +C +C +C THIS ROUTINE WILL UNPACK A 'GRIB' FIELD TO THE EXACT GRID +C TYPE SPECIFIED IN THE MESSAGE, RETURN A BIT MAP AND MAKE THE +C VALUES OF THE PRODUCT DEFINITION SEC (PDS) AND THE GRID +C DESCRIPTION SEC (GDS) AVAILABLE IN RETURN ARRAYS. +C SEE "GRIB - THE WMO FORMAT FOR THE STORAGE OF WEATHER PRODUCT +C INFORMATION AND THE EXCHANGE OF WEATHER PRODUCT MESSAGES IN +C GRIDDED BINARY FORM" DATED JULY 1, 1988 BY JOHN D. STACKPOLE +C DOC, NOAA, NWS, NATIONAL METEOROLOGICAL CENTER. +C +C THE CALL TO THE GRIB UNPACKING ROUTINE IS AS FOLLOWS: +C +C CALL W3FI63(MSGA,KPDS,KGDS,LBMS,DATA,KPTR,KRET) +C +C INPUT: +C +C MSGA = CONTAINS THE GRIB MESSAGE TO BE UNPACKED. CHARACTERS +C "GRIB" MAY BEGIN ANYWHERE WITHIN FIRST 100 BYTES. +C +C OUTPUT: +C +C KPDS(100) INTEGER*4 +C ARRAY TO CONTAIN THE ELEMENTS OF THE PRODUCT +C DEFINITION SEC . +C (VERSION 1) +C KPDS(1) - ID OF CENTER +C KPDS(2) - MODEL IDENTIFICATION (SEE "GRIB" TABLE 1) +C KPDS(3) - GRID IDENTIFICATION (SEE "GRIB" TABLE 2) +C KPDS(4) - GDS/BMS FLAG +C BIT DEFINITION +C 25 0 - GDS OMITTED +C 1 - GDS INCLUDED +C 26 0 - BMS OMITTED +C 1 - BMS INCLUDED +C NOTE:- LEFTMOST BIT = 1, +C RIGHTMOST BIT = 32 +C KPDS(5) - INDICATOR OF PARAMETER (SEE "GRIB" TABLE 5) +C KPDS(6) - TYPE OF LEVEL (SEE "GRIB" TABLES 6 & 7) +C KPDS(7) - HEIGHT,PRESSURE,ETC OF LEVEL +C KPDS(8) - YEAR INCLUDING CENTURY +C KPDS(9) - MONTH OF YEAR +C KPDS(10) - DAY OF MONTH +C KPDS(11) - HOUR OF DAY +C KPDS(12) - MINUTE OF HOUR +C KPDS(13) - INDICATOR OF FORECAST TIME UNIT (SEE "GRIB" +C TABLE 8) +C KPDS(14) - TIME 1 (SEE "GRIB" TABLE 8A) +C KPDS(15) - TIME 2 (SEE "GRIB" TABLE 8A) +C KPDS(16) - TIME RANGE INDICATOR (SEE "GRIB" TABLE 8A) +C KPDS(17) - NUMBER INCLUDED IN AVERAGE +C KPDS(18) - EDITION NR OF GRIB SPECIFICATION +C KPDS(19) - VERSION NR OF PARAMETER TABLE +C +C KGDS(13) INTEGER*4 +C ARRAY CONTAINING GDS ELEMENTS. +C +C KGDS(1) - DATA REPRESENTATION TYPE +C +C LATITUDE/LONGITUDE GRIDS (SEE "GRIB" TABLE 10) +C KGDS(2) - N(I) NUMBER OF POINTS ON LATITUDE +C CIRCLE +C KGDS(3) - N(J) NUMBER OF POINTS ON LONGITUDE +C CIRCLE +C KGDS(4) - LA(1) LATITUDE OF ORIGIN +C KGDS(5) - LO(1) LONGITUDE OF ORIGIN +C KGDS(6) - RESOLUTION FLAG +C BIT MEANING +C 25 0 - DIRECTION INCREMENTS NOT +C GIVEN +C 1 - DIRECTION INCREMENTS GIVEN +C KGDS(7) - LA(2) LATITUDE OF EXTREME POINT +C KGDS(8) - LO(2) LONGITUDE OF EXTREME POINT +C KGDS(9) - DI LONGITUDINAL DIRECTION INCREMENT +C KGDS(10) - REGULAR LAT/LON GRID +C DJ - LATITUDINAL DIRECTION +C INCREMENT +C GAUSSIAN GRID +C N - NUMBER OF LATITUDE CIRCLES +C BETWEEN A POLE AND THE EQUATOR +C KGDS(11) - SCANNING MODE FLAG +C BIT MEANING +C 25 0 - POINTS ALONG A LATITUDE +C SCAN FROM WEST TO EAST +C 1 - POINTS ALONG A LATITUDE +C SCAN FROM EAST TO WEST +C 26 0 - POINTS ALONG A MERIDIAN +C SCAN FROM NORTH TO SOUTH +C 1 - POINTS ALONG A MERIDIAN +C SCAN FROM SOUTH TO NORTH +C 27 0 - POINTS SCAN FIRST ALONG +C CIRCLES OF LATITUDE, THEN +C ALONG MERIDIANS +C (FORTRAN: (I,J)) +C 1 - POINTS SCAN FIRST ALONG +C MERIDIANS THEN ALONG +C CIRCLES OF LATITUDE +C (FORTRAN: (J,I)) +C +C POLAR STEREOGRAPHIC GRIDS (SEE GRIB TABLE 12) +C KGDS(2) - N(I) NR POINTS ALONG LAT CIRCLE +C KGDS(3) - N(J) NR POINTS ALONG LON CIRCLE +C KGDS(4) - LA(1) LATITUDE OF ORIGIN +C KGDS(5) - LO(1) LONGITUDE OF ORIGIN +C KGDS(6) - RESERVED +C KGDS(7) - LOV GRID ORIENTATION +C KGDS(8) - DX - X DIRECTION INCREMENT +C KGDS(9) - DY - Y DIRECTION INCREMENT +C KGDS(10) - PROJECTION CENTER FLAG +C KGDS(11) - SCANNING MODE +C +C SPHERICAL HARMONIC COEFFICIENTS (SEE "GRIB" TABLE 14) +C KGDS(2) - J PENTAGONAL RESOLUTION PARAMETER +C KGDS(3) - K PENTAGONAL RESOLUTION PARAMETER +C KGDS(4) - M PENTAGONAL RESOLUTION PARAMETER +C KGDS(5) - REPRESENTATION TYPE +C KGDS(6) - COEFFICIENT STORAGE MODE +C +C MERCATOR GRIDS +C KGDS(2) - N(I) NR POINTS ON LATITUDE CIRCLE +C KGDS(3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C KGDS(4) - LA(1) LATITUDE OF ORIGIN +C KGDS(5) - LO(1) LONGITUDE OF ORIGIN +C KGDS(6) - RESOLUTION FLAG +C KGDS(7) - LA(2) LATITUDE OF LAST GRID POINT +C KGDS(8) - LO(2) LONGITUDE OF LAST GRID POINT +C KGDS(9) - LATIN - LATITUDE OF PROJECTION INTERSECTION +C KGDS(10) - RESERVED +C KGDS(11) - SCANNING MODE FLAG +C KGDS(12) - LONGITUDINAL DIR GRID LENGTH +C KGDS(13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C KGDS(2) - NX NR POINTS ALONG X-AXIS +C KGDS(3) - NY NR POINTS ALONG Y-AXIS +C KGDS(4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C KGDS(5) - LO1 LON OF ORIGIN (LOWER LEFT) +C KGDS(6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C KGDS(7) - LOV - ORIENTATION OF GRID +C KGDS(8) - DX - X-DIR INCREMENT +C KGDS(9) - DY - Y-DIR INCREMENT +C KGDS(10) - PROJECTION CENTER FLAG +C KGDS(11) - SCANNING MODE FLAG +C KGDS(12) - LATIN 1 - FIRST LAT FROM POLE OF +C SECANT CONE INTERSECTION +C KGDS(13) - LATIN 2 - SECOND LAT FROM POLE OF +C SECANT CONE INTERSECTION +C +C LBMS(*) LOGICAL +C ARRAY TO CONTAIN THE BIT MAP DESCRIBING THE +C PLACEMENT OF DATA IN THE OUTPUT ARRAY. IF A +C BIT MAP IS NOT INCLUDED IN THE SOURCE MESSAGE, +C ONE WILL BE GENERATED AUTOMATICALLY BY THE +C UNPACKING ROUTINE. +C +C +C DATA(*) REAL*4 +C THIS ARRAY WILL CONTAIN THE UNPACKED DATA POINTS. +C +C NOTE:- 65160 IS MAXIMUN FIELD SIZE ALLOWABLE +C +C KPTR(10) INTEGER*4 +C ARRAY CONTAINING STORAGE FOR THE FOLLOWING +C PARAMETERS. +C +C (1) - UNUSED +C (2) - UNUSED +C (3) - LENGTH OF PDS (IN BYTES) +C (4) - LENGTH OF GDS (IN BYTES) +C (5) - LENGTH OF BMS (IN BYTES) +C (6) - LENGTH OF BDS (IN BYTES) +C (7) - USED BY UNPACKING ROUTINE +C (8) - NUMBER OF DATA POINTS FOR GRID +C (9) - "GRIB" CHARACTERS START IN BYTE NUMBER +C (10) - USED BY UNPACKING ROUTINE +C +C +C KRET INTEGER*4 +C THIS VARIABLE WILL CONTAIN THE RETURN INDICATOR. +C +C 0 - NO ERRORS DETECTED. +C +C 1 - 'GRIB' NOT FOUND IN FIRST 100 +C CHARACTERS. +C +C 2 - '7777' NOT FOUND, EITHER MISSING OR +C TOTAL OF SEC COUNTS OF INDIVIDUAL +C SECTIONS IS INCORRECT. +C +C 3 - UNPACKED FIELD IS LARGER THAN 65160. +C +C 4 - IN GDS, DATA REPRESENTATION TYPE +C NOT ONE OF THE CURRENTLY ACCEPTABLE +C VALUES. SEE "GRIB" TABLE 9. VALUE +C OF INCORRECT TYPE RETURNED IN KGDS(1). +C +C 5 - GRID INDICATED IN KPDS(3) IS NOT +C AVAILABLE FOR THE CENTER INDICATED IN +C KPDS(1) AND NO GDS SENT. +C +C 7 - EDITION INDICATED IN KPDS(18) HAS NOT +C YET BEEN INCLUDED IN THE DECODER. +C +C 8 - GRID IDENTIFICATION = 255 (NOT STANDARD +C GRID) BUT FLAG INDICATING PRESENCE OF +C GDS IS TURNED OFF. NO METHOD OF +C GENERATING PROPER GRID. +C +C 9 - PRODUCT OF KGDS(2) AND KGDS(3) DOES NOT +C MATCH STANDARD NUMBER OF POINTS FOR THIS +C GRID (FOR OTHER THAN SPECTRALS). THIS +C WILL OCCUR ONLY IF THE GRID. +C IDENTIFICATION, KPDS(3), AND A +C TRANSMITTED GDS ARE INCONSISTENT. +C +C 10 - CENTER INDICATOR WAS NOT ONE INDICATED +C IN "GRIB" TABLE 1. PLEASE CONTACT AD +C PRODUCTION MANAGEMENT BRANCH (W/NMC42) +C IF THIS ERROR IS ENCOUNTERED. +C +C 11 - BINARY DATA SECTION (BDS) NOT COMPLETELY +C PROCESSED. PROGRAM IS NOT SET TO PROCESS +C FLAG COMBINATIONS AS SHOWN IN +C OCTETS 4 AND 14. +C +C +C LIST OF TEXT MESSAGES FROM CODE +C +C +C W3FI63/FI632 +C +C 'HAVE ENCOUNTERED A NEW GRID FOR NMC, PLEASE NOTIFY +C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH +C (W/NMC42)' +C +C 'HAVE ENCOUNTERED A NEW GRID FOR ECMWF, PLEASE NOTIFY +C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH +C (W/NMC42)' +C +C 'HAVE ENCOUNTERED A NEW GRID FOR U.K. METEOROLOGICAL +C OFFICE, BRACKNELL. PLEASE NOTIFY AUTOMATION DIVISION, +C PRODUCTION MANAGEMENT BRANCH (W/NMC42)' +C +C 'HAVE ENCOUNTERED A NEW GRID FOR FNOC, PLEASE NOTIFY +C AUTOMATION DIVISION, PRODUCTION MANAGEMENT BRANCH +C (W/NMC42)' +C +C +C W3FI63/FI633 +C +C 'POLAR STEREO PROCESSING NOT AVAILABLE' * +C +C W3FI63/FI634 +C +C 'WARNING - BIT MAP MAY NOT BE ASSOCIATED WITH SPHERICAL +C COEFFICIENTS' +C +C +C W3FI63/FI637 +C +C 'NO CURRENT LISTING OF FNOC GRIDS' * +C +C +C * WILL BE AVAILABLE IN NEXT UPDATE +C *************************************************************** +C +C INCOMING MESSAGE HOLDER + CHARACTER*1 MSGA(*) +C BIT MAP + LOGICAL*1 KBMS(*) +C +C ELEMENTS OF PRODUCT DESCRIPTION SEC (PDS) + INTEGER KPDS(*) +C ELEMENTS OF GRID DESCRIPTION SEC (PDS) + INTEGER KGDS(*) +C +C CONTAINER FOR GRIB GRID + REAL DATA(*) +C +C ARRAY OF POINTERS AND COUNTERS + INTEGER KPTR(*) +C +C ***************************************************************** + INTEGER JSGN,JEXP,IFR,NPTS + REAL REALKK,FVAL1,FDIFF1 +C ***************************************************************** +C 1.0 LOCATE BEGINNING OF 'GRIB' MESSAGE +C FIND 'GRIB' CHARACTERS +C 2.0 USE COUNTS IN EACH DESCRIPTION SEC TO DETERMINE +C IF '7777' IS IN PROPER PLACE. +C 3.0 PARSE PRODUCT DEFINITION SECTION. +C 4.0 PARSE GRID DESCRIPTION SEC (IF INCLUDED) +C 5.0 PARSE BIT MAP SEC (IF INCLUDED) +C 6.0 USING INFORMATION FROM PRODUCT DEFINITION, GRID +C DESCRIPTION, AND BIT MAP SECTIONS.. EXTRACT +C DATA AND PLACE INTO PROPER ARRAY. +C ******************************************************************* +C +C MAIN DRIVER +C +C ******************************************************************* + KPTR(10) = 0 +C SEE IF PROPER 'GRIB' KEY EXISTS, THEN +C USING SEC COUNTS, DETERMINE IF '7777' +C IS IN THE PROPER LOCATION +C + CALL FI631(MSGA,KPTR,KPDS,KRET) + IF(KRET.NE.0) THEN + GO TO 900 + END IF +C PRINT *,'FI631 KPTR',(KPTR(I),I=1,16) +C +C PARSE PARAMETERS FROM PRODUCT DESCRIPTION SECTION +C + CALL FI632(MSGA,KPTR,KPDS,KRET) + IF(KRET.NE.0) THEN + GO TO 900 + END IF +C PRINT *,'FI632 KPTR',(KPTR(I),I=1,16) +C +C IF AVAILABLE, EXTRACT NEW GRID DESCRIPTION +C + IF (IAND(KPDS(4),128).NE.0) THEN + CALL FI633(MSGA,KPTR,KGDS,KRET) + IF(KRET.NE.0) THEN + GO TO 900 + END IF +C PRINT *,'FI633 KPTR',(KPTR(I),I=1,16) + END IF +C +C EXTRACT OR GENERATE BIT MAP +C + CALL FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) + IF (KRET.NE.0) THEN + IF (KRET.NE.9) THEN + GO TO 900 + END IF + END IF +C PRINT *,'FI634 KPTR',(KPTR(I),I=1,16) +C +C USING INFORMATION FROM PDS, BMS AND BIT DATA SEC , +C EXTRACT AND SAVE IN GRIB GRID, ALL DATA ENTRIES. +C + IF (KPDS(18).EQ.1) THEN + CALL FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET) + IF (KPTR(3).EQ.50) THEN +C +C PDS EQUAL 50 BYTES +C THEREFORE SOMETHING SPECIAL IS GOING ON +C +C IN THIS CASE 2ND DIFFERENCE PACKING +C NEEDS TO BE UNDONE. +C +C EXTRACT FIRST VALUE FROM BYTE 41-44 PDS +C KPTR(9) CONTAINS OFFSET TO START OF +C GRIB MESSAGE. +C EXTRACT FIRST FIRST-DIFFERENCE FROM BYTES 45-48 PDS +C +C AND EXTRACT SCALE FACTOR (E) TO UNDO 2**E +C THAT WAS APPLIED PRIOR TO 2ND ORDER PACKING +C AND PLACED IN PDS BYTES 49-51 +C FACTOR IS A SIGNED TWO BYTE INTEGER +C +C ALSO NEED THE DECIMAL SCALING FROM PDS(27-28) +C (AVAILABLE IN KPDS(22) FROM UNPACKER) +C TO UNDO THE DECIMAL SCALING APPLIED TO THE +C SECOND DIFFERENCES DURING UNPACKING. +C SECOND DIFFS ALWAYS PACKED WITH 0 DECIMAL SCALE +C BUT UNPACKER DOESNT KNOW THAT. +C +C CALL GBYTE (MSGA,FVAL1,KPTR(9)+384,32) +C +C NOTE INTEGERS, CHARACTERS AND EQUIVALENCES +C DEFINED ABOVE TO MAKE THIS KKK EXTRACTION +C WORK AND LINE UP ON WORD BOUNDARIES +C +C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT +C TO THE FLOATING POINT USED ON YOUR MACHINE. +C + call gbytec(MSGA,JSGN,KPTR(9)+384,1) + call gbytec(MSGA,JEXP,KPTR(9)+385,7) + call gbytec(MSGA,IFR,KPTR(9)+392,24) +C + IF (IFR.EQ.0) THEN + REALKK = 0.0 + ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN + REALKK = 0.0 + ELSE + REALKK = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) + IF (JSGN.NE.0) REALKK = -REALKK + END IF + FVAL1 = REALKK +C +C CALL GBYTE (MSGA,FDIFF1,KPTR(9)+416,32) +C (REPLACED BY FOLLOWING EXTRACTION) +C +C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT +C TO THE FLOATING POINT USED ON YOUR MACHINE. +C + call gbytec(MSGA,JSGN,KPTR(9)+416,1) + call gbytec(MSGA,JEXP,KPTR(9)+417,7) + call gbytec(MSGA,IFR,KPTR(9)+424,24) +C + IF (IFR.EQ.0) THEN + REALKK = 0.0 + ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN + REALKK = 0.0 + ELSE + REALKK = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) + IF (JSGN.NE.0) REALKK = -REALKK + END IF + FDIFF1 = REALKK +C + CALL GBYTEC (MSGA,ISIGN,KPTR(9)+448,1) + CALL GBYTEC (MSGA,ISCAL2,KPTR(9)+449,15) + IF(ISIGN.GT.0) THEN + ISCAL2 = - ISCAL2 + ENDIF +C PRINT *,'DELTA POINT 1-',FVAL1 +C PRINT *,'DELTA POINT 2-',FDIFF1 +C PRINT *,'DELTA POINT 3-',ISCAL2 + NPTS = KPTR(10) +C WRITE (6,FMT='('' 2ND DIFF POINTS IN FIELD = '',/, +C & 10(3X,10F12.2,/))') (DATA(I),I=1,NPTS) +C PRINT *,'DELTA POINT 4-',KPDS(22) + CALL W3FI83 (DATA,NPTS,FVAL1,FDIFF1, + & ISCAL2,KPDS(22),KPDS,KGDS) +C WRITE (6,FMT='('' 2ND DIFF EXPANDED POINTS IN FIELD = '', +C & /,10(3X,10F12.2,/))') (DATA(I),I=1,NPTS) +C WRITE (6,FMT='('' END OF ARRAY IN FIELD = '',/, +C & 10(3X,10F12.2,/))') (DATA(I),I=NPTS-5,NPTS) + END IF + ELSE +C PRINT *,'FI635 NOT PROGRAMMED FOR EDITION NR',KPDS(18) + KRET = 7 + END IF +C + 900 RETURN + END + SUBROUTINE FI631(MSGA,KPTR,KPDS,KRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI631 FIND 'GRIB' CHARS & RESET POINTERS +C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 +C +C ABSTRACT: FIND 'GRIB; CHARACTERS AND SET POINTERS TO THE NEXT +C BYTE FOLLOWING 'GRIB'. IF THEY EXIST EXTRACT COUNTS FROM GDS AND +C BMS. EXTRACT COUNT FROM BDS. DETERMINE IF SUM OF COUNTS ACTUALLY +C PLACES TERMINATOR '7777' AT THE CORRECT LOCATION. +C +C PROGRAM HISTORY LOG: +C 91-09-13 CAVANAUGH +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL FI631(MSGA,KPTR,KPDS,KRET) +C INPUT ARGUMENT LIST: +C MSGA - GRIB FIELD - "GRIB" THRU "7777" +C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS +C (1) - TOTAL LENGTH OF GRIB MESSAGE +C (2) - LENGTH OF INDICATOR (SECTION 0) +C (3) - LENGTH OF PDS (SECTION 1) +C (4) - LENGTH OF GDS (SECTION 2) +C (5) - LENGTH OF BMS (SECTION 3) +C (6) - LENGTH OF BDS (SECTION 4) +C (7) - VALUE OF CURRENT BYTE +C (8) - BIT POINTER +C (9) - GRIB START BIT NR +C (10) - GRIB/GRID ELEMENT COUNT +C (11) - NR UNUSED BITS AT END OF SECTION 3 +C (12) - BIT MAP FLAG +C (13) - NR UNUSED BITS AT END OF SECTION 2 +C (14) - BDS FLAGS +C (15) - NR UNUSED BITS AT END OF SECTION 4 +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C KPDS - ARRAY CONTAINING PDS ELEMENTS. +C (1) - ID OF CENTER +C (2) - MODEL IDENTIFICATION +C (3) - GRID IDENTIFICATION +C (4) - GDS/BMS FLAG +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR OF CENTURY +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C KPTR - SEE INPUT LIST +C KRET - ERROR RETURN +C +C REMARKS: +C ERROR RETURNS +C KRET = 1 - NO 'GRIB' +C 2 - NO '7777' OR MISLOCATED (BY COUNTS) +C +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: HDS9000 +C +C$$$ +C +C INCOMING MESSAGE HOLDER + CHARACTER*1 MSGA(*) +C ARRAY OF POINTERS AND COUNTERS + INTEGER KPTR(*) +C PRODUCT DESCRIPTION SECTION DATA. + INTEGER KPDS(*) +C + INTEGER KRET +C +C ****************************************************************** + KRET = 0 +C ------------------- FIND 'GRIB' KEY + DO 50 I = 0, 839, 8 + CALL GBYTEC (MSGA,MGRIB,I,32) + IF (MGRIB.EQ.1196575042) THEN + KPTR(9) = I + GO TO 60 + END IF + 50 CONTINUE + KRET = 1 + RETURN + 60 CONTINUE +C -------------FOUND 'GRIB' +C SKIP GRIB CHARACTERS +C PRINT *,'FI631 GRIB AT',I + KPTR(8) = KPTR(9) + 32 + CALL GBYTEC (MSGA,ITOTAL,KPTR(8),24) +C HAVE LIFTED WHAT MAY BE A MSG TOTAL BYTE COUNT + IPOINT = KPTR(9) + ITOTAL * 8 - 32 + CALL GBYTEC (MSGA,I7777,IPOINT,32) + IF (I7777.EQ.926365495) THEN +C HAVE FOUND END OF MESSAGE '7777' IN PROPER LOCATION +C MARK AND PROCESS AS GRIB VERSION 1 OR HIGHER +C PRINT *,'FI631 7777 AT',IPOINT + KPTR(8) = KPTR(8) + 24 + KPTR(1) = ITOTAL + KPTR(2) = 8 + CALL GBYTEC (MSGA,KPDS(18),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 + ELSE +C CANNOT FIND END OF GRIB EDITION 1 MESSAGE + KRET = 2 + RETURN + END IF +C ------------------- PROCESS SECTION 1 +C EXTRACT COUNT FROM PDS +C PRINT *,'START OF PDS',KPTR(8) + CALL GBYTEC (MSGA,KPTR(3),KPTR(8),24) + LOOK = KPTR(8) + 56 +C EXTRACT GDS/BMS FLAG + CALL GBYTEC (MSGA,KPDS(4),LOOK,8) + KPTR(8) = KPTR(8) + KPTR(3) * 8 +C PRINT *,'START OF GDS',KPTR(8) + IF (IAND(KPDS(4),128).NE.0) THEN +C EXTRACT COUNT FROM GDS + CALL GBYTEC (MSGA,KPTR(4),KPTR(8),24) + KPTR(8) = KPTR(8) + KPTR(4) * 8 + ELSE + KPTR(4) = 0 + END IF +C PRINT *,'START OF BMS',KPTR(8) + IF (IAND(KPDS(4),64).NE.0) THEN +C EXTRACT COUNT FROM BMS + CALL GBYTEC (MSGA,KPTR(5),KPTR(8),24) + ELSE + KPTR(5) = 0 + END IF + KPTR(8) = KPTR(8) + KPTR(5) * 8 +C PRINT *,'START OF BDS',KPTR(8) +C EXTRACT COUNT FROM BDS + CALL GBYTEC (MSGA,KPTR(6),KPTR(8),24) +C --------------- TEST FOR '7777' +C PRINT *,(KPTR(KJ),KJ=1,10) + KPTR(8) = KPTR(8) + KPTR(6) * 8 +C EXTRACT FOUR BYTES FROM THIS LOCATION +C PRINT *,'FI631 LOOKING FOR 7777 AT',KPTR(8) + CALL GBYTEC (MSGA,K7777,KPTR(8),32) + MATCH = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5) + KPTR(6) + 4 + IF (K7777.NE.926365495.OR.MATCH.NE.KPTR(1)) THEN + KRET = 2 + ELSE +C PRINT *,'FI631 7777 AT',KPTR(8) + IF (KPDS(18).EQ.0) THEN + KPTR(1) = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5) + + * KPTR(6) + 4 + END IF + END IF +C PRINT *,'KPTR',(KPTR(I),I=1,16) + RETURN + END + SUBROUTINE FI632(MSGA,KPTR,KPDS,KRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI632 GATHER INFO FROM PRODUCT DEFINITION SEC +C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 +C +C ABSTRACT: EXTRACT INFORMATION FROM THE PRODUCT DESCRIPTION +C SEC , AND GENERATE LABEL INFORMATION TO PERMIT STORAGE +C IN OFFICE NOTE 84 FORMAT. +C +C PROGRAM HISTORY LOG: +C 91-09-13 CAVANAUGH +C 93-12-08 CAVANAUGH CORRECTED TEST FOR EDITION NUMBER INSTEAD +C OF VERSION NUMBER +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 99-01-20 BALDWIN MODIFIED TO HANDLE GRID 237 +C +C USAGE: CALL FI632(MSGA,KPTR,KPDS,KRET) +C INPUT ARGUMENT LIST: +C MSGA - ARRAY CONTAINING GRIB MESSAGE +C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS +C (1) - TOTAL LENGTH OF GRIB MESSAGE +C (2) - LENGTH OF INDICATOR (SECTION 0) +C (3) - LENGTH OF PDS (SECTION 1) +C (4) - LENGTH OF GDS (SECTION 2) +C (5) - LENGTH OF BMS (SECTION 3) +C (6) - LENGTH OF BDS (SECTION 4) +C (7) - VALUE OF CURRENT BYTE +C (8) - BIT POINTER +C (9) - GRIB START BIT NR +C (10) - GRIB/GRID ELEMENT COUNT +C (11) - NR UNUSED BITS AT END OF SECTION 3 +C (12) - BIT MAP FLAG +C (13) - NR UNUSED BITS AT END OF SECTION 2 +C (14) - BDS FLAGS +C (15) - NR UNUSED BITS AT END OF SECTION 4 +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C KPDS - ARRAY CONTAINING PDS ELEMENTS. +C (1) - ID OF CENTER +C (2) - MODEL IDENTIFICATION +C (3) - GRID IDENTIFICATION +C (4) - GDS/BMS FLAG +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR OF CENTURY +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C (18) - +C (19) - +C (20) - NUMBER MISSING FROM AVGS/ACCUMULATIONS +C (21) - CENTURY +C (22) - UNITS DECIMAL SCALE FACTOR +C (23) - SUBCENTER +C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS +C SEE INPUT LIST +C KRET - ERROR RETURN +C +C REMARKS: +C ERROR RETURN = 0 - NO ERRORS +C = 8 - TEMP GDS INDICATED, BUT NO GDS +C +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: HDS9000 +C +C$$$ +C +C INCOMING MESSAGE HOLDER + CHARACTER*1 MSGA(*) +C +C ARRAY OF POINTERS AND COUNTERS + INTEGER KPTR(*) +C PRODUCT DESCRIPTION SECTION ENTRIES + INTEGER KPDS(*) +C + INTEGER KRET + KRET=0 +C ------------------- PROCESS SECTION 1 + KPTR(8) = KPTR(9) + KPTR(2) * 8 + 24 +C BYTE 4 +C PARAMETER TABLE VERSION NR + CALL GBYTEC (MSGA,KPDS(19),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 5 IDENTIFICATION OF CENTER + CALL GBYTEC (MSGA,KPDS(1),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 6 +C GET GENERATING PROCESS ID NR + CALL GBYTEC (MSGA,KPDS(2),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 7 +C GRID DEFINITION + CALL GBYTEC (MSGA,KPDS(3),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 8 +C GDS/BMS FLAGS +C CALL GBYTEC (MSGA,KPDS(4),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 9 +C INDICATOR OF PARAMETER + CALL GBYTEC (MSGA,KPDS(5),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 10 +C TYPE OF LEVEL + CALL GBYTEC (MSGA,KPDS(6),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 11,12 +C HEIGHT/PRESSURE + CALL GBYTEC (MSGA,KPDS(7),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C BYTE 13 +C YEAR OF CENTURY + CALL GBYTEC (MSGA,KPDS(8),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 14 +C MONTH OF YEAR + CALL GBYTEC (MSGA,KPDS(9),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 15 +C DAY OF MONTH + CALL GBYTEC (MSGA,KPDS(10),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 16 +C HOUR OF DAY + CALL GBYTEC (MSGA,KPDS(11),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 17 +C MINUTE + CALL GBYTEC (MSGA,KPDS(12),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 18 +C INDICATOR TIME UNIT RANGE + CALL GBYTEC (MSGA,KPDS(13),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 19 +C P1 - PERIOD OF TIME + CALL GBYTEC (MSGA,KPDS(14),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 20 +C P2 - PERIOD OF TIME + CALL GBYTEC (MSGA,KPDS(15),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 21 +C TIME RANGE INDICATOR + CALL GBYTEC (MSGA,KPDS(16),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C +C IF TIME RANGE INDICATOR IS 10, P1 IS PACKED IN +C PDS BYTES 19-20 +C + IF (KPDS(16).EQ.10) THEN + KPDS(14) = KPDS(14) * 256 + KPDS(15) + KPDS(15) = 0 + END IF +C BYTE 22,23 +C NUMBER INCLUDED IN AVERAGE + CALL GBYTEC (MSGA,KPDS(17),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C BYTE 24 +C NUMBER MISSING FROM AVERAGES/ACCUMULATIONS + CALL GBYTEC (MSGA,KPDS(20),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 25 +C IDENTIFICATION OF CENTURY + CALL GBYTEC (MSGA,KPDS(21),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 + IF (KPTR(3).GT.25) THEN +C BYTE 26 SUB CENTER NUMBER + CALL GBYTEC (MSGA,KPDS(23),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 + IF (KPTR(3).GE.28) THEN +C BYTE 27-28 +C UNITS DECIMAL SCALE FACTOR + CALL GBYTEC (MSGA,ISIGN,KPTR(8),1) + KPTR(8) = KPTR(8) + 1 + CALL GBYTEC (MSGA,IDEC,KPTR(8),15) + KPTR(8) = KPTR(8) + 15 + IF (ISIGN.GT.0) THEN + KPDS(22) = - IDEC + ELSE + KPDS(22) = IDEC + END IF + ISIZ = KPTR(3) - 28 + IF (ISIZ.LE.12) THEN +C BYTE 29 + CALL GBYTEC (MSGA,KPDS(24),KPTR(8)+8,8) +C BYTE 30 + CALL GBYTEC (MSGA,KPDS(25),KPTR(8)+16,8) +C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE + KPTR(8) = KPTR(8) + ISIZ * 8 + ELSE +C BYTE 29 + CALL GBYTEC (MSGA,KPDS(24),KPTR(8)+8,8) +C BYTE 30 + CALL GBYTEC (MSGA,KPDS(25),KPTR(8)+16,8) +C BYTES 31-40 CURRENTLY RESERVED FOR FUTURE USE + KPTR(8) = KPTR(8) + 12 * 8 +C BYTES 41 - N LOCAL USE DATA + CALL W3FI01(LW) +C MWDBIT = LW * 8 + MWDBIT = bit_size(KPDS) + ISIZ = KPTR(3) - 40 + ITER = ISIZ / LW + IF (MOD(ISIZ,LW).NE.0) ITER = ITER + 1 + CALL GBYTESC (MSGA,KPDS(36),KPTR(8),MWDBIT,0,ITER) + KPTR(8) = KPTR(8) + ISIZ * 8 + END IF + END IF + END IF +C ----------- TEST FOR NEW GRID + IF (IAND(KPDS(4),128).NE.0) THEN + IF (IAND(KPDS(4),64).NE.0) THEN + IF (KPDS(3).NE.255) THEN + IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN + RETURN + ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44)THEN + RETURN + ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN + RETURN + END IF + IF (KPDS(1).EQ.7) THEN + IF (KPDS(3).GE.2.AND.KPDS(3).LE.3) THEN + ELSE IF (KPDS(3).GE.5.AND.KPDS(3).LE.6) THEN + ELSE IF (KPDS(3).EQ.8) THEN + ELSE IF (KPDS(3).EQ.10) THEN + ELSE IF (KPDS(3).GE.27.AND.KPDS(3).LE.34) THEN + ELSE IF (KPDS(3).EQ.50) THEN + ELSE IF (KPDS(3).EQ.53) THEN + ELSE IF (KPDS(3).GE.70.AND.KPDS(3).LE.77) THEN + ELSE IF (KPDS(3).EQ.98) THEN + ELSE IF (KPDS(3).EQ.99) THEN + ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LE.105) THEN + ELSE IF (KPDS(3).EQ.126) THEN + ELSE IF (KPDS(3).EQ.195) THEN + ELSE IF (KPDS(3).EQ.196) THEN + ELSE IF (KPDS(3).EQ.197) THEN + ELSE IF (KPDS(3).EQ.198) THEN + ELSE IF (KPDS(3).GE.200.AND.KPDS(3).LE.237) THEN + ELSE +C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', +C * ' NMC WITHOUT A GRID DESCRIPTION SECTION' +C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' +C PRINT *,' PRODUCTION MANAGEMENT BRANCH' +C PRINT *,' W/NMC42)' + END IF + ELSE IF (KPDS(1).EQ.98) THEN + IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN + ELSE +C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', +C * ' ECMWF WITHOUT A GRID DESCRIPTION SECTION' +C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' +C PRINT *,' PRODUCTION MANAGEMENT BRANCH' +C PRINT *,' W/NMC42)' + END IF + ELSE IF (KPDS(1).EQ.74) THEN + IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN + ELSE IF (KPDS(3).GE.21.AND.KPDS(3).LE.26)THEN + ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN + ELSE IF (KPDS(3).GE.70.AND.KPDS(3).LE.77) THEN + ELSE +C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', +C * ' U.K. MET OFFICE, BRACKNELL', +C * ' WITHOUT A GRID DESCRIPTION SECTION' +C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' +C PRINT *,' PRODUCTION MANAGEMENT BRANCH' +C PRINT *,' W/NMC42)' + END IF + ELSE IF (KPDS(1).EQ.58) THEN + IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN + ELSE +C PRINT *,' HAVE ENCOUNTERED A NEW GRID FOR', +C * ' FNOC WITHOUT A GRID DESCRIPTION SECTION' +C PRINT *,' PLEASE NOTIFY AUTOMATION DIVISION' +C PRINT *,' PRODUCTION MANAGEMENT BRANCH' +C PRINT *,' W/NMC42)' + END IF + END IF + END IF + END IF + END IF + RETURN + END + SUBROUTINE FI633(MSGA,KPTR,KGDS,KRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI633 EXTRACT INFO FROM GRIB-GDS +C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 +C +C ABSTRACT: EXTRACT INFORMATION ON UNLISTED GRID TO ALLOW +C CONVERSION TO OFFICE NOTE 84 FORMAT. +C +C PROGRAM HISTORY LOG: +C 91-09-13 CAVANAUGH +C 95-03-20 M.BALDWIN FI633 MODIFICATION TO GET +C DATA REP TYPES [KGDS(1)] 201 AND 202 TO WORK. +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 98-09-08 BALDWIN ADD DATA REP TYPE [KGDS(1)] 203 +C 07-04-24 VUONG ADD DATA REP TYPE [KGDS(1)] 204 +C 10-07-20 GAYNO ADD DATA REP TYPE [KGDS(1)] 205 +C +C +C USAGE: CALL FI633(MSGA,KPTR,KGDS,KRET) +C INPUT ARGUMENT LIST: +C MSGA - ARRAY CONTAINING GRIB MESSAGE +C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS +C (1) - TOTAL LENGTH OF GRIB MESSAGE +C (2) - LENGTH OF INDICATOR (SECTION 0) +C (3) - LENGTH OF PDS (SECTION 1) +C (4) - LENGTH OF GDS (SECTION 2) +C (5) - LENGTH OF BMS (SECTION 3) +C (6) - LENGTH OF BDS (SECTION 4) +C (7) - VALUE OF CURRENT BYTE +C (8) - BIT POINTER +C (9) - GRIB START BIT NR +C (10) - GRIB/GRID ELEMENT COUNT +C (11) - NR UNUSED BITS AT END OF SECTION 3 +C (12) - BIT MAP FLAG +C (13) - NR UNUSED BITS AT END OF SECTION 2 +C (14) - BDS FLAGS +C (15) - NR UNUSED BITS AT END OF SECTION 4 +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C KGDS - ARRAY CONTAINING GDS ELEMENTS. +C (1) - DATA REPRESENTATION TYPE +C (19) - NUMBER OF VERTICAL COORDINATE PARAMETERS +C (20) - OCTET NUMBER OF THE LIST OF VERTICAL COORDINATE +C PARAMETERS +C OR +C OCTET NUMBER OF THE LIST OF NUMBERS OF POINTS +C IN EACH ROW +C OR +C 255 IF NEITHER ARE PRESENT +C (21) - FOR GRIDS WITH PL, NUMBER OF POINTS IN GRID +C (22) - NUMBER OF WORDS IN EACH ROW +C LATITUDE/LONGITUDE GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG +C (7) - LA(2) LATITUDE OF EXTREME POINT +C (8) - LO(2) LONGITUDE OF EXTREME POINT +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG +C POLAR STEREOGRAPHIC GRIDS +C (2) - N(I) NR POINTS ALONG LAT CIRCLE +C (3) - N(J) NR POINTS ALONG LON CIRCLE +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESERVED +C (7) - LOV GRID ORIENTATION +C (8) - DX - X DIRECTION INCREMENT +C (9) - DY - Y DIRECTION INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE +C SPHERICAL HARMONIC COEFFICIENTS +C (2) - J PENTAGONAL RESOLUTION PARAMETER +C (3) - K " " " +C (4) - M " " " +C (5) - REPRESENTATION TYPE +C (6) - COEFFICIENT STORAGE MODE +C MERCATOR GRIDS +C (2) - N(I) NR POINTS ON LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG +C (7) - LA(2) LATITUDE OF LAST GRID POINT +C (8) - LO(2) LONGITUDE OF LAST GRID POINT +C (9) - LATIN - LATITUDE OF PROJECTION INTERSECTION +C (10) - RESERVED +C (11) - SCANNING MODE FLAG +C (12) - LONGITUDINAL DIR GRID LENGTH +C (13) - LATITUDINAL DIR GRID LENGTH +C LAMBERT CONFORMAL GRIDS +C (2) - NX NR POINTS ALONG X-AXIS +C (3) - NY NR POINTS ALONG Y-AXIS +C (4) - LA1 LAT OF ORIGIN (LOWER LEFT) +C (5) - LO1 LON OF ORIGIN (LOWER LEFT) +C (6) - RESOLUTION (RIGHT ADJ COPY OF OCTET 17) +C (7) - LOV - ORIENTATION OF GRID +C (8) - DX - X-DIR INCREMENT +C (9) - DY - Y-DIR INCREMENT +C (10) - PROJECTION CENTER FLAG +C (11) - SCANNING MODE FLAG +C (12) - LATIN 1 - FIRST LAT FROM POLE OF SECANT CONE INTER +C (13) - LATIN 2 - SECOND LAT FROM POLE OF SECANT CONE INTER +C STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (203 E STAGGER) +C (2) - N(I) NR POINTS ON ROTATED LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON ROTATED LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG +C (7) - LA(2) LATITUDE OF CENTER +C (8) - LO(2) LONGITUDE OF CENTER +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG +C STAGGERED ARAKAWA ROTATED LAT/LON GRIDS (205 A,B,C,D STAGGERS) +C (2) - N(I) NR POINTS ON ROTATED LATITUDE CIRCLE +C (3) - N(J) NR POINTS ON ROTATED LONGITUDE MERIDIAN +C (4) - LA(1) LATITUDE OF ORIGIN +C (5) - LO(1) LONGITUDE OF ORIGIN +C (6) - RESOLUTION FLAG +C (7) - LA(2) LATITUDE OF CENTER +C (8) - LO(2) LONGITUDE OF CENTER +C (9) - DI LONGITUDINAL DIRECTION OF INCREMENT +C (10) - DJ LATITUDINAL DIRECTION INCREMENT +C (11) - SCANNING MODE FLAG +C (12) - LATITUDE OF LAST POINT +C (13) - LONGITUDE OF LAST POINT +C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS +C SEE INPUT LIST +C KRET - ERROR RETURN +C +C REMARKS: +C KRET = 0 +C = 4 - DATA REPRESENTATION TYPE NOT CURRENTLY ACCEPTABLE +C +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: HDS9000 +C +C$$$ +C ************************************************************ +C INCOMING MESSAGE HOLDER + CHARACTER*1 MSGA(*) +C +C ARRAY GDS ELEMENTS + INTEGER KGDS(*) +C ARRAY OF POINTERS AND COUNTERS + INTEGER KPTR(*) +C + INTEGER KRET +C --------------------------------------------------------------- + KRET = 0 +C PROCESS GRID DEFINITION SECTION (IF PRESENT) +C MAKE SURE BIT POINTER IS PROPERLY SET + KPTR(8) = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + 24 + NSAVE = KPTR(8) - 24 +C BYTE 4 +C NV - NR OF VERT COORD PARAMETERS + CALL GBYTEC (MSGA,KGDS(19),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 5 +C PV - LOCATION - SEE FM92 MANUAL + CALL GBYTEC (MSGA,KGDS(20),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTE 6 +C DATA REPRESENTATION TYPE + CALL GBYTEC (MSGA,KGDS(1),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTES 7-32 ARE GRID DEFINITION DEPENDING ON +C DATA REPRESENTATION TYPE + IF (KGDS(1).EQ.0) THEN + GO TO 1000 + ELSE IF (KGDS(1).EQ.1) THEN + GO TO 4000 + ELSE IF (KGDS(1).EQ.2.OR.KGDS(1).EQ.5) THEN + GO TO 2000 + ELSE IF (KGDS(1).EQ.3) THEN + GO TO 5000 + ELSE IF (KGDS(1).EQ.4) THEN + GO TO 1000 +C ELSE IF (KGDS(1).EQ.10) THEN +C ELSE IF (KGDS(1).EQ.14) THEN +C ELSE IF (KGDS(1).EQ.20) THEN +C ELSE IF (KGDS(1).EQ.24) THEN +C ELSE IF (KGDS(1).EQ.30) THEN +C ELSE IF (KGDS(1).EQ.34) THEN + ELSE IF (KGDS(1).EQ.50) THEN + GO TO 3000 +C ELSE IF (KGDS(1).EQ.60) THEN +C ELSE IF (KGDS(1).EQ.70) THEN +C ELSE IF (KGDS(1).EQ.80) THEN + ELSE IF (KGDS(1).EQ.201.OR.KGDS(1).EQ.202.OR. + & KGDS(1).EQ.203.OR.KGDS(1).EQ.204.OR.KGDS(1).EQ.205) THEN + GO TO 1000 + ELSE +C MARK AS GDS/ UNKNOWN DATA REPRESENTATION TYPE + KRET = 4 + RETURN + END IF +C BYTE 33-N VERTICAL COORDINATE PARAMETERS +C ----------- +C BYTES 33-42 EXTENSIONS OF GRID DEFINITION FOR ROTATION +C OR STRETCHING OF THE COORDINATE SYSTEM OR +C LAMBERT CONFORMAL PROJECTION. +C BYTE 43-N VERTICAL COORDINATE PARAMETERS +C ----------- +C BYTES 33-52 EXTENSIONS OF GRID DEFINITION FOR STRETCHED +C AND ROTATED COORDINATE SYSTEM +C BYTE 53-N VERTICAL COORDINATE PARAMETERS +C ----------- +C ************************************************************ +C ------------------- LATITUDE/LONGITUDE GRIDS +C ------------------- ARAKAWA STAGGERED, SEMI-STAGGERED, OR FILLED +C ROTATED LAT/LON GRIDS OR CURVILINEAR ORTHIGINAL GRIDS +C +C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE + 1000 CONTINUE + CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN + CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 11-13 LATITUDE OF ORIGIN + CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(4),8388608).NE.0) THEN + KGDS(4) = IAND(KGDS(4),8388607) * (-1) + END IF +C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN + CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(5),8388608).NE.0) THEN + KGDS(5) = - IAND(KGDS(5),8388607) + END IF +C ------------------- BYTE 17 RESOLUTION FLAG + CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- BYTE 18-20 LATITUDE OF LAST GRID POINT + CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(7),8388608).NE.0) THEN + KGDS(7) = - IAND(KGDS(7),8388607) + END IF +C ------------------- BYTE 21-23 LONGITUDE OF LAST GRID POINT + CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(8),8388608).NE.0) THEN + KGDS(8) = - IAND(KGDS(8),8388607) + END IF +C ------------------- BYTE 24-25 LATITUDINAL DIR INCREMENT + CALL GBYTEC (MSGA,KGDS(9),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 26-27 IF REGULAR LAT/LON GRID +C HAVE LONGIT DIR INCREMENT +C ELSE IF GAUSSIAN GRID +C HAVE NR OF LAT CIRCLES +C BETWEEN POLE AND EQUATOR + CALL GBYTEC (MSGA,KGDS(10),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 28 SCANNING MODE FLAGS + CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 + IF(KGDS(1).EQ.205)THEN +C ------------------- BYTE 29-31 LATITUDE OF LAST GRID POINT + CALL GBYTEC (MSGA,KGDS(12),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(12),8388608).NE.0) THEN + KGDS(12) = - IAND(KGDS(12),8388607) + END IF +C ------------------- BYTE 32-34 LONGITUDE OF LAST GRID POINT + CALL GBYTEC (MSGA,KGDS(13),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(13),8388608).NE.0) THEN + KGDS(13) = - IAND(KGDS(13),8388607) + END IF + ELSE + +C ------------------- BYTE 29-32 RESERVED +C SKIP TO START OF BYTE 33 + CALL GBYTEC (MSGA,KGDS(12),KPTR(8),32) + KPTR(8) = KPTR(8) + 32 + ENDIF +C ------------------- + GO TO 900 +C ****************************************************************** +C ' POLAR STEREO PROCESSING ' +C +C ------------------- BYTE 7-8 NR OF POINTS ALONG X=AXIS + 2000 CONTINUE + CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS + CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 11-13 LATITUDE OF ORIGIN + CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(4),8388608).NE.0) THEN + KGDS(4) = - IAND(KGDS(4),8388607) + END IF +C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN + CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(5),8388608).NE.0) THEN + KGDS(5) = - IAND(KGDS(5),8388607) + END IF +C ------------------- BYTE 17 RESERVED + CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- BYTE 18-20 LOV ORIENTATION OF THE GRID + CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(7),8388608).NE.0) THEN + KGDS(7) = - IAND(KGDS(7),8388607) + END IF +C ------------------- BYTE 21-23 DX - THE X DIRECTION INCREMENT + CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(8),8388608).NE.0) THEN + KGDS(8) = - IAND(KGDS(8),8388607) + END IF +C ------------------- BYTE 24-26 DY - THE Y DIRECTION INCREMENT + CALL GBYTEC (MSGA,KGDS(9),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(9),8388608).NE.0) THEN + KGDS(9) = - IAND(KGDS(9),8388607) + END IF +C ------------------- BYTE 27 PROJECTION CENTER FLAG + CALL GBYTEC (MSGA,KGDS(10),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- BYTE 28 SCANNING MODE + CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- BYTE 29-32 RESERVED +C SKIP TO START OF BYTE 33 + CALL GBYTEC (MSGA,KGDS(12),KPTR(8),32) + KPTR(8) = KPTR(8) + 32 +C +C ------------------- + GO TO 900 +C +C ****************************************************************** +C ------------------- GRID DESCRIPTION FOR SPHERICAL HARMONIC COEFF. +C +C ------------------- BYTE 7-8 J PENTAGONAL RESOLUTION PARAMETER + 3000 CONTINUE + CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 9-10 K PENTAGONAL RESOLUTION PARAMETER + CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 11-12 M PENTAGONAL RESOLUTION PARAMETER + CALL GBYTEC (MSGA,KGDS(4),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 13 REPRESENTATION TYPE + CALL GBYTEC (MSGA,KGDS(5),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- BYTE 14 COEFFICIENT STORAGE MODE + CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- EMPTY FIELDS - BYTES 15 - 32 +C SET TO START OF BYTE 33 + KPTR(8) = KPTR(8) + 18 * 8 + GO TO 900 +C ****************************************************************** +C PROCESS MERCATOR GRIDS +C +C ------------------- BYTE 7-8 NR OF POINTS ALONG LATITUDE CIRCLE + 4000 CONTINUE + CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 9-10 NR OF POINTS ALONG LONG MERIDIAN + CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 11-13 LATITUE OF ORIGIN + CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(4),8388608).NE.0) THEN + KGDS(4) = - IAND(KGDS(4),8388607) + END IF +C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN + CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(5),8388608).NE.0) THEN + KGDS(5) = - IAND(KGDS(5),8388607) + END IF +C ------------------- BYTE 17 RESOLUTION FLAG + CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- BYTE 18-20 LATITUDE OF EXTREME POINT + CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(7),8388608).NE.0) THEN + KGDS(7) = - IAND(KGDS(7),8388607) + END IF +C ------------------- BYTE 21-23 LONGITUDE OF EXTREME POINT + CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(8),8388608).NE.0) THEN + KGDS(8) = - IAND(KGDS(8),8388607) + END IF +C ------------------- BYTE 24-26 LATITUDE OF PROJECTION INTERSECTION + CALL GBYTEC (MSGA,KGDS(9),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(9),8388608).NE.0) THEN + KGDS(9) = - IAND(KGDS(9),8388607) + END IF +C ------------------- BYTE 27 RESERVED + CALL GBYTEC (MSGA,KGDS(10),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- BYTE 28 SCANNING MODE + CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- BYTE 29-31 LONGITUDINAL DIR INCREMENT + CALL GBYTEC (MSGA,KGDS(12),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(12),8388608).NE.0) THEN + KGDS(12) = - IAND(KGDS(12),8388607) + END IF +C ------------------- BYTE 32-34 LATITUDINAL DIR INCREMENT + CALL GBYTEC (MSGA,KGDS(13),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(13),8388608).NE.0) THEN + KGDS(13) = - IAND(KGDS(13),8388607) + END IF +C ------------------- BYTE 35-42 RESERVED +C SKIP TO START OF BYTE 43 + KPTR(8) = KPTR(8) + 8 * 8 +C ------------------- + GO TO 900 +C ****************************************************************** +C PROCESS LAMBERT CONFORMAL +C +C ------------------- BYTE 7-8 NR OF POINTS ALONG X-AXIS + 5000 CONTINUE + CALL GBYTEC (MSGA,KGDS(2),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 9-10 NR OF POINTS ALONG Y-AXIS + CALL GBYTEC (MSGA,KGDS(3),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- BYTE 11-13 LATITUDE OF ORIGIN + CALL GBYTEC (MSGA,KGDS(4),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(4),8388608).NE.0) THEN + KGDS(4) = - IAND(KGDS(4),8388607) + END IF +C ------------------- BYTE 14-16 LONGITUDE OF ORIGIN (LOWER LEFT) + CALL GBYTEC (MSGA,KGDS(5),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(5),8388608).NE.0) THEN + KGDS(5) = - IAND(KGDS(5),8388607) + END IF +C ------------------- BYTE 17 RESOLUTION + CALL GBYTEC (MSGA,KGDS(6),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- BYTE 18-20 LOV -ORIENTATION OF GRID + CALL GBYTEC (MSGA,KGDS(7),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(7),8388608).NE.0) THEN + KGDS(7) = - IAND(KGDS(7),8388607) + END IF +C ------------------- BYTE 21-23 DX - X-DIR INCREMENT + CALL GBYTEC (MSGA,KGDS(8),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 +C ------------------- BYTE 24-26 DY - Y-DIR INCREMENT + CALL GBYTEC (MSGA,KGDS(9),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 +C ------------------- BYTE 27 PROJECTION CENTER FLAG + CALL GBYTEC (MSGA,KGDS(10),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- BYTE 28 SCANNING MODE + CALL GBYTEC (MSGA,KGDS(11),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ------------------- BYTE 29-31 LATIN1 - 1ST LAT FROM POLE + CALL GBYTEC (MSGA,KGDS(12),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(12),8388608).NE.0) THEN + KGDS(12) = - IAND(KGDS(12),8388607) + END IF +C ------------------- BYTE 32-34 LATIN2 - 2ND LAT FROM POLE + CALL GBYTEC (MSGA,KGDS(13),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(13),8388608).NE.0) THEN + KGDS(13) = - IAND(KGDS(13),8388607) + END IF +C ------------------- BYTE 35-37 LATITUDE OF SOUTHERN POLE + CALL GBYTEC (MSGA,KGDS(14),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(14),8388608).NE.0) THEN + KGDS(14) = - IAND(KGDS(14),8388607) + END IF +C ------------------- BYTE 38-40 LONGITUDE OF SOUTHERN POLE + CALL GBYTEC (MSGA,KGDS(15),KPTR(8),24) + KPTR(8) = KPTR(8) + 24 + IF (IAND(KGDS(15),8388608).NE.0) THEN + KGDS(15) = - IAND(KGDS(15),8388607) + END IF +C ------------------- BYTE 41-42 RESERVED + CALL GBYTEC (MSGA,KGDS(16),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ------------------- + 900 CONTINUE +C +C MORE CODE FOR GRIDS WITH PL +C + IF (KGDS(19).EQ.0.OR.KGDS(19).EQ.255) THEN + IF (KGDS(20).NE.255) THEN + ISUM = 0 + KPTR(8) = NSAVE + (KGDS(20) - 1) * 8 + CALL GBYTESC (MSGA,KGDS(22),KPTR(8),16,0,KGDS(3)) + DO 910 J = 1, KGDS(3) + ISUM = ISUM + KGDS(21+J) + 910 CONTINUE + KGDS(21) = ISUM + END IF + END IF + RETURN + END + SUBROUTINE FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI634 EXTRACT OR GENERATE BIT MAP FOR OUTPUT +C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 +C +C ABSTRACT: IF BIT MAP SEC IS AVAILABLE IN GRIB MESSAGE, EXTRACT +C FOR PROGRAM USE, OTHERWISE GENERATE AN APPROPRIATE BIT MAP. +C +C PROGRAM HISTORY LOG: +C 91-09-13 CAVANAUGH +C 91-11-12 CAVANAUGH MODIFIED SIZE OF ECMWF GRIDS 5 - 8. +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 97-02-12 W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING +C 97-09-19 IREDELL VECTORIZED BITMAP DECODER +C 98-09-02 GILBERT CORRECTED ERROR IN MAP SIZE FOR U.S. GRID 92 +C 98-09-08 BALDWIN ADD GRIDS 190,192 +C 99-01-20 BALDWIN ADD GRIDS 236,237 +C 01-10-02 ROGERS REDEFINED GRID #218 FOR 12 KM ETA +C REDEFINED GRID 192 FOR NEW 32-KM ETA GRID +C 2003-06-30 GILBERT ADDED GRIDS 145 and 146 for CMAQ +C and GRID 175 for AWIPS over GUAM. +C 2004-09-02 VUONG ADDED AWIPS GRIDS 147, 148, 173 AND 254 +C 2006-12-12 VUONG ADDED AWIPS GRIDS 120 +C 2007-04-20 VUONG ADDED AWIPS GRIDS 176 +C 2007-06-11 VUONG ADDED AWIPS GRIDS 11 TO 18 AND 122 TO 125 +C AND 180 TO 183 +C 2010-08-05 VUONG ADDED NEW GRID 184, 199, 83 AND +C REDEFINED GRID 90 FOR NEW RTMA CONUS 1.27-KM +C REDEFINED GRID 91 FOR NEW RTMA ALASKA 2.976-KM +C REDEFINED GRID 92 FOR NEW RTMA ALASKA 1.488-KM +C 2012-02-28 VUONG ADDED NEW GRID 200 +C +C USAGE: CALL FI634(MSGA,KPTR,KPDS,KGDS,KBMS,KRET) +C INPUT ARGUMENT LIST: +C MSGA - BUFR MESSAGE +C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS +C (1) - TOTAL LENGTH OF GRIB MESSAGE +C (2) - LENGTH OF INDICATOR (SECTION 0) +C (3) - LENGTH OF PDS (SECTION 1) +C (4) - LENGTH OF GDS (SECTION 2) +C (5) - LENGTH OF BMS (SECTION 3) +C (6) - LENGTH OF BDS (SECTION 4) +C (7) - VALUE OF CURRENT BYTE +C (8) - BIT POINTER +C (9) - GRIB START BIT NR +C (10) - GRIB/GRID ELEMENT COUNT +C (11) - NR UNUSED BITS AT END OF SECTION 3 +C (12) - BIT MAP FLAG +C (13) - NR UNUSED BITS AT END OF SECTION 2 +C (14) - BDS FLAGS +C (15) - NR UNUSED BITS AT END OF SECTION 4 +C KPDS - ARRAY CONTAINING PDS ELEMENTS. +C (1) - ID OF CENTER +C (2) - MODEL IDENTIFICATION +C (3) - GRID IDENTIFICATION +C (4) - GDS/BMS FLAG +C (5) - INDICATOR OF PARAMETER +C (6) - TYPE OF LEVEL +C (7) - HEIGHT/PRESSURE , ETC OF LEVEL +C (8) - YEAR OF CENTURY +C (9) - MONTH OF YEAR +C (10) - DAY OF MONTH +C (11) - HOUR OF DAY +C (12) - MINUTE OF HOUR +C (13) - INDICATOR OF FORECAST TIME UNIT +C (14) - TIME RANGE 1 +C (15) - TIME RANGE 2 +C (16) - TIME RANGE FLAG +C (17) - NUMBER INCLUDED IN AVERAGE +C +C OUTPUT ARGUMENT LIST: +C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. +C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS +C SEE INPUT LIST +C KRET - ERROR RETURN +C +C REMARKS: +C KRET = 0 - NO ERROR +C = 5 - GRID NOT AVAIL FOR CENTER INDICATED +C =10 - INCORRECT CENTER INDICATOR +C =12 - BYTES 5-6 ARE NOT ZERO IN BMS, PREDEFINED BIT MAP +C NOT PROVIDED BY THIS CENTER +C +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: HDS9000 +C +C$$$ +C +C INCOMING MESSAGE HOLDER + CHARACTER*1 MSGA(*) +C +C BIT MAP + LOGICAL*1 KBMS(*) +C +C ARRAY OF POINTERS AND COUNTERS + INTEGER KPTR(*) +C ARRAY OF POINTERS AND COUNTERS + INTEGER KPDS(*) + INTEGER KGDS(*) +C + INTEGER KRET + INTEGER MASK(8) +C ----------------------GRID 21 AND GRID 22 ARE THE SAME + LOGICAL*1 GRD21( 1369) +C ----------------------GRID 23 AND GRID 24 ARE THE SAME + LOGICAL*1 GRD23( 1369) + LOGICAL*1 GRD25( 1368) + LOGICAL*1 GRD26( 1368) +C ----------------------GRID 27 AND GRID 28 ARE THE SAME +C ----------------------GRID 29 AND GRID 30 ARE THE SAME +C ----------------------GRID 33 AND GRID 34 ARE THE SAME + LOGICAL*1 GRD50( 1188) +C -----------------------GRID 61 AND GRID 62 ARE THE SAME + LOGICAL*1 GRD61( 4186) +C -----------------------GRID 63 AND GRID 64 ARE THE SAME + LOGICAL*1 GRD63( 4186) +C LOGICAL*1 GRD70(16380)/16380*.TRUE./ +C ------------------------------------------------------------- + DATA GRD21 /1333*.TRUE.,36*.FALSE./ + DATA GRD23 /.TRUE.,36*.FALSE.,1332*.TRUE./ + DATA GRD25 /1297*.TRUE.,71*.FALSE./ + DATA GRD26 /.TRUE.,71*.FALSE.,1296*.TRUE./ + DATA GRD50/ +C LINE 1-4 + & 7*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE., + & 14*.FALSE.,22*.TRUE.,14*.FALSE.,22*.TRUE.,7*.FALSE., +C LINE 5-8 + & 6*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE., + & 12*.FALSE.,24*.TRUE.,12*.FALSE.,24*.TRUE.,6*.FALSE., +C LINE 9-12 + & 5*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE., + & 10*.FALSE.,26*.TRUE.,10*.FALSE.,26*.TRUE.,5*.FALSE., +C LINE 13-16 + & 4*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE., + & 8*.FALSE.,28*.TRUE., 8*.FALSE.,28*.TRUE.,4*.FALSE., +C LINE 17-20 + & 3*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE., + & 6*.FALSE.,30*.TRUE., 6*.FALSE.,30*.TRUE.,3*.FALSE., +C LINE 21-24 + & 2*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE., + & 4*.FALSE.,32*.TRUE., 4*.FALSE.,32*.TRUE.,2*.FALSE., +C LINE 25-28 + & .FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE., + & 2*.FALSE.,34*.TRUE., 2*.FALSE.,34*.TRUE., .FALSE., +C LINE 29-33 + & 180*.TRUE./ + DATA GRD61 /4096*.TRUE.,90*.FALSE./ + DATA GRD63 /.TRUE.,90*.FALSE.,4095*.TRUE./ + DATA MASK /128,64,32,16,8,4,2,1/ +C +C PRINT *,'FI634' + IF (IAND(KPDS(4),64).EQ.64) THEN +C +C SET UP BIT POINTER +C SECTION 0 SECTION 1 SECTION 2 + KPTR(8) = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8) + 24 +C +C BYTE 4 NUMBER OF UNUSED BITS AT END OF SECTION 3 +C + CALL GBYTEC (MSGA,KPTR(11),KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C +C BYTE 5,6 TABLE REFERENCE IF 0, BIT MAP FOLLOWS +C + CALL GBYTEC (MSGA,KPTR(12),KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C IF TABLE REFERENCE = 0, EXTRACT BIT MAP + IF (KPTR(12).EQ.0) THEN +C CALCULATE NR OF BITS IN BIT MAP + IBITS = (KPTR(5) - 6) * 8 - KPTR(11) + KPTR(10) = IBITS + IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22.OR.KPDS(3).EQ.25. + * OR.KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN +C NORTHERN HEMISPHERE 21, 22, 25, 61, 62 + CALL FI634X(IBITS,KPTR(8),MSGA,KBMS) + IF (KPDS(3).EQ.25) THEN + KADD = 71 + ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN + KADD = 90 + ELSE + KADD = 36 + END IF + DO 25 I = 1, KADD + KBMS(I+IBITS) = .FALSE. + 25 CONTINUE + KPTR(10) = KPTR(10) + KADD + RETURN + ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24.OR.KPDS(3).EQ.26. + * OR.KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN +C SOUTHERN HEMISPHERE 23, 24, 26, 63, 64 + CALL FI634X(IBITS,KPTR(8),MSGA,KBMS) + IF (KPDS(3).EQ.26) THEN + KADD = 72 + ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN + KADD = 91 + ELSE + KADD = 37 + END IF + DO 26 I = 1, KADD + KBMS(I+IBITS) = .FALSE. + 26 CONTINUE + KPTR(10) = KPTR(10) + KADD - 1 + RETURN + ELSE IF (KPDS(3).EQ.50) THEN + KPAD = 7 + KIN = 22 + KBITS = 0 + DO 55 I = 1, 7 + DO 54 J = 1, 4 + DO 51 K = 1, KPAD + KBITS = KBITS + 1 + KBMS(KBITS) = .FALSE. + 51 CONTINUE + CALL FI634X(KIN,KPTR(8),MSGA,KBMS(KBITS+1)) + KPTR(8)=KPTR(8)+KIN + KBITS=KBITS+KIN + DO 53 K = 1, KPAD + KBITS = KBITS + 1 + KBMS(KBITS) = .FALSE. + 53 CONTINUE + 54 CONTINUE + KIN = KIN + 2 + KPAD = KPAD - 1 + 55 CONTINUE + DO 57 II = 1, 5 + CALL FI634X(KIN,KPTR(8),MSGA,KBMS(KBITS+1)) + KPTR(8)=KPTR(8)+KIN + KBITS=KBITS+KIN + 57 CONTINUE + ELSE +C EXTRACT BIT MAP FROM BMS FOR OTHER GRIDS + CALL FI634X(IBITS,KPTR(8),MSGA,KBMS) + END IF + RETURN + ELSE +C PRINT *,'FI634-NO PREDEFINED BIT MAP PROVIDED BY THIS CENTER' + KRET = 12 + RETURN + END IF +C + END IF + KRET = 0 +C ------------------------------------------------------- +C PROCESS NON-STANDARD GRID +C ------------------------------------------------------- + IF (KPDS(3).EQ.255) THEN +C PRINT *,'NON STANDARD GRID, CENTER = ',KPDS(1) + J = KGDS(2) * KGDS(3) + KPTR(10) = J + DO 600 I = 1, J + KBMS(I) = .TRUE. + 600 CONTINUE + RETURN + END IF +C ------------------------------------------------------- +C CHECK INTERNATIONAL SET +C ------------------------------------------------------- + IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22) THEN +C ----- INT'L GRIDS 21, 22 - MAP SIZE 1369 + J = 1369 + KPTR(10) = J + CALL FI637(J,KPDS,KGDS,KRET) + IF(KRET.NE.0) GO TO 820 + DO 3021 I = 1, 1369 + KBMS(I) = GRD21(I) + 3021 CONTINUE + RETURN + ELSE IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24) THEN +C ----- INT'L GRIDS 23, 24 - MAP SIZE 1369 + J = 1369 + KPTR(10) = J + CALL FI637(J,KPDS,KGDS,KRET) + IF(KRET.NE.0) GO TO 820 + DO 3023 I = 1, 1369 + KBMS(I) = GRD23(I) + 3023 CONTINUE + RETURN + ELSE IF (KPDS(3).EQ.25) THEN +C ----- INT'L GRID 25 - MAP SIZE 1368 + J = 1368 + KPTR(10) = J + CALL FI637(J,KPDS,KGDS,KRET) + IF(KRET.NE.0) GO TO 820 + DO 3025 I = 1, 1368 + KBMS(I) = GRD25(I) + 3025 CONTINUE + RETURN + ELSE IF (KPDS(3).EQ.26) THEN +C ----- INT'L GRID 26 - MAP SIZE 1368 + J = 1368 + KPTR(10) = J + CALL FI637(J,KPDS,KGDS,KRET) + IF(KRET.NE.0) GO TO 820 + DO 3026 I = 1, 1368 + KBMS(I) = GRD26(I) + 3026 CONTINUE + RETURN + ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN +C ----- INT'L GRID 37-44 - MAP SIZE 3447 + J = 3447 + GO TO 800 + ELSE IF (KPDS(1).EQ.7.AND.KPDS(3).EQ.50) THEN +C ----- INT'L GRIDS 50 - MAP SIZE 964 + J = 1188 + KPTR(10) = J + CALL FI637(J,KPDS,KGDS,KRET) + IF(KRET.NE.0) GO TO 890 + DO 3050 I = 1, J + KBMS(I) = GRD50(I) + 3050 CONTINUE + RETURN + ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN +C ----- INT'L GRIDS 61, 62 - MAP SIZE 4186 + J = 4186 + KPTR(10) = J + CALL FI637(J,KPDS,KGDS,KRET) + IF(KRET.NE.0) GO TO 820 + DO 3061 I = 1, 4186 + KBMS(I) = GRD61(I) + 3061 CONTINUE + RETURN + ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN +C ----- INT'L GRIDS 63, 64 - MAP SIZE 4186 + J = 4186 + KPTR(10) = J + CALL FI637(J,KPDS,KGDS,KRET) + IF(KRET.NE.0) GO TO 820 + DO 3063 I = 1, 4186 + KBMS(I) = GRD63(I) + 3063 CONTINUE + RETURN + END IF +C ------------------------------------------------------- +C CHECK UNITED STATES SET +C ------------------------------------------------------- + IF (KPDS(1).EQ.7) THEN + IF (KPDS(3).LT.100) THEN + IF (KPDS(3).EQ.1) THEN +C ----- U.S. GRID 1 - MAP SIZE 1679 + J = 1679 + GO TO 800 + END IF + IF (KPDS(3).EQ.2) THEN +C ----- U.S. GRID 2 - MAP SIZE 10512 + J = 10512 + GO TO 800 + ELSE IF (KPDS(3).EQ.3) THEN +C ----- U.S. GRID 3 - MAP SIZE 65160 + J = 65160 + GO TO 800 + ELSE IF (KPDS(3).EQ.4) THEN +C ----- U.S. GRID 4 - MAP SIZE 259920 + J = 259920 + GO TO 800 + ELSE IF (KPDS(3).EQ.5) THEN +C ----- U.S. GRID 5 - MAP SIZE 3021 + J = 3021 + GO TO 800 + ELSE IF (KPDS(3).EQ.6) THEN +C ----- U.S. GRID 6 - MAP SIZE 2385 + J = 2385 + GO TO 800 + ELSE IF (KPDS(3).EQ.8) THEN +C ----- U.S. GRID 8 - MAP SIZE 5104 + J = 5104 + GO TO 800 + ELSE IF (KPDS(3).EQ.10) THEN +C ----- U.S. GRID 10 - MAP SIZE 25020 + J = 25020 + GO TO 800 + ELSE IF (KPDS(3).EQ.11) THEN +C ----- U.S. GRID 11 - MAP SIZE 223920 + J = 223920 + GO TO 800 + ELSE IF (KPDS(3).EQ.12) THEN +C ----- U.S. GRID 12 - MAP SIZE 99631 + J = 99631 + GO TO 800 + ELSE IF (KPDS(3).EQ.13) THEN +C ----- U.S. GRID 13 - MAP SIZE 36391 + J = 36391 + GO TO 800 + ELSE IF (KPDS(3).EQ.14) THEN +C ----- U.S. GRID 14 - MAP SIZE 153811 + J = 153811 + GO TO 800 + ELSE IF (KPDS(3).EQ.15) THEN +C ----- U.S. GRID 15 - MAP SIZE 74987 + J = 74987 + GO TO 800 + ELSE IF (KPDS(3).EQ.16) THEN +C ----- U.S. GRID 16 - MAP SIZE 214268 + J = 214268 + GO TO 800 + ELSE IF (KPDS(3).EQ.17) THEN +C ----- U.S. GRID 17 - MAP SIZE 387136 + J = 387136 + GO TO 800 + ELSE IF (KPDS(3).EQ.18) THEN +C ----- U.S. GRID 18 - MAP SIZE 281866 + J = 281866 + GO TO 800 + ELSE IF (KPDS(3).EQ.27.OR.KPDS(3).EQ.28) THEN +C ----- U.S. GRIDS 27, 28 - MAP SIZE 4225 + J = 4225 + GO TO 800 + ELSE IF (KPDS(3).EQ.29.OR.KPDS(3).EQ.30) THEN +C ----- U.S. GRIDS 29,30 - MAP SIZE 5365 + J = 5365 + GO TO 800 + ELSE IF (KPDS(3).EQ.33.OR.KPDS(3).EQ.34) THEN +C ----- U.S GRID 33, 34 - MAP SIZE 8326 + J = 8326 + GO TO 800 + ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN +C ----- U.S. GRID 37-44 - MAP SIZE 3447 + J = 3447 + GO TO 800 + ELSE IF (KPDS(3).EQ.45) THEN +C ----- U.S. GRID 45 - MAP SIZE 41760 + J = 41760 + GO TO 800 + ELSE IF (KPDS(3).EQ.53) THEN +C ----- U.S. GRID 53 - MAP SIZE 5967 + J = 5967 + GO TO 800 + ELSE IF (KPDS(3).EQ.55.OR.KPDS(3).EQ.56) THEN +C ----- U.S GRID 55, 56 - MAP SIZE 6177 + J = 6177 + GO TO 800 + ELSE IF (KPDS(3).GE.67.AND.KPDS(3).LE.71) THEN +C ----- U.S GRID 67-71 - MAP SIZE 13689 + J = 13689 + GO TO 800 + ELSE IF (KPDS(3).EQ.72) THEN +C ----- U.S GRID 72 - MAP SIZE 406 + J = 406 + GO TO 800 + ELSE IF (KPDS(3).EQ.73) THEN +C ----- U.S GRID 73 - MAP SIZE 13056 + J = 13056 + GO TO 800 + ELSE IF (KPDS(3).EQ.74) THEN +C ----- U.S GRID 74 - MAP SIZE 10800 + J = 10800 + GO TO 800 + ELSE IF (KPDS(3).GE.75.AND.KPDS(3).LE.77) THEN +C ----- U.S GRID 75-77 - MAP SIZE 12321 + J = 12321 + GO TO 800 + ELSE IF (KPDS(3).EQ.83) THEN +C ----- U.S GRID 83 - MAP SIZE 429786 + J = 429786 + GO TO 800 + ELSE IF (KPDS(3).EQ.85.OR.KPDS(3).EQ.86) THEN +C ----- U.S GRID 85,86 - MAP SIZE 32400 + J = 32400 + GO TO 800 + ELSE IF (KPDS(3).EQ.87) THEN +C ----- U.S GRID 87 - MAP SIZE 5022 + J = 5022 + GO TO 800 + ELSE IF (KPDS(3).EQ.88) THEN +C ----- U.S GRID 88 - MAP SIZE 317840 + J = 317840 + GO TO 800 + ELSE IF (KPDS(3).EQ.90) THEN +C ----- U.S GRID 90 - MAP SIZE 11807617 + J = 11807617 + GO TO 800 + ELSE IF (KPDS(3).EQ.91) THEN +C ----- U.S GRID 91 - MAP SIZE 1822145 + J = 1822145 + GO TO 800 + ELSE IF (KPDS(3).EQ.92) THEN +C ----- U.S GRID 92 - MAP SIZE 7283073 + J = 7283073 + GO TO 800 + ELSE IF (KPDS(3).EQ.93) THEN +C ----- U.S GRID 93 - MAP SIZE 111723 + J = 111723 + GO TO 800 + ELSE IF (KPDS(3).EQ.94) THEN +C ----- U.S GRID 94 - MAP SIZE 371875 + J = 371875 + GO TO 800 + ELSE IF (KPDS(3).EQ.95) THEN +C ----- U.S GRID 95 - MAP SIZE 130325 + J = 130325 + GO TO 800 + ELSE IF (KPDS(3).EQ.96) THEN +C ----- U.S GRID 96 - MAP SIZE 209253 + J = 209253 + GO TO 800 + ELSE IF (KPDS(3).EQ.97) THEN +C ----- U.S GRID 97 - MAP SIZE 1508100 + J = 1508100 + GO TO 800 + ELSE IF (KPDS(3).EQ.98) THEN +C ----- U.S GRID 98 - MAP SIZE 18048 + J = 18048 + GO TO 800 + ELSE IF (KPDS(3).EQ.99) THEN +C ----- U.S GRID 99 - MAP SIZE 779385 + J = 779385 + GO TO 800 + END IF + ELSE IF (KPDS(3).GE.100.AND.KPDS(3).LT.200) THEN + IF (KPDS(3).EQ.100) THEN +C ----- U.S. GRID 100 - MAP SIZE 6889 + J = 6889 + GO TO 800 + ELSE IF (KPDS(3).EQ.101) THEN +C ----- U.S. GRID 101 - MAP SIZE 10283 + J = 10283 + GO TO 800 + ELSE IF (KPDS(3).EQ.103) THEN +C ----- U.S. GRID 103 - MAP SIZE 3640 + J = 3640 + GO TO 800 + ELSE IF (KPDS(3).EQ.104) THEN +C ----- U.S. GRID 104 - MAP SIZE 16170 + J = 16170 + GO TO 800 + ELSE IF (KPDS(3).EQ.105) THEN +C ----- U.S. GRID 105 - MAP SIZE 6889 + J = 6889 + GO TO 800 + ELSE IF (KPDS(3).EQ.106) THEN +C ----- U.S. GRID 106 - MAP SIZE 19305 + J = 19305 + GO TO 800 + ELSE IF (KPDS(3).EQ.107) THEN +C ----- U.S. GRID 107 - MAP SIZE 11040 + J = 11040 + GO TO 800 + ELSE IF (KPDS(3).EQ.110) THEN +C ----- U.S. GRID 110 - MAP SIZE 103936 + J = 103936 + GO TO 800 + ELSE IF (KPDS(3).EQ.120) THEN +C ----- U.S. GRID 120 - MAP SIZE 2020800 + J = 2020800 + GO TO 800 + ELSE IF (KPDS(3).EQ.122) THEN +C ----- U.S. GRID 122 - MAP SIZE 162750 + J = 162750 + GO TO 800 + ELSE IF (KPDS(3).EQ.123) THEN +C ----- U.S. GRID 123 - MAP SIZE 100800 + J = 100800 + GO TO 800 + ELSE IF (KPDS(3).EQ.124) THEN +C ----- U.S. GRID 124 - MAP SIZE 75360 + J = 75360 + GO TO 800 + ELSE IF (KPDS(3).EQ.125) THEN +C ----- U.S. GRID 125 - MAP SIZE 102000 + J = 102000 + GO TO 800 + ELSE IF (KPDS(3).EQ.126) THEN +C ----- U.S. GRID 126 - MAP SIZE 72960 + J = 72960 + GO TO 800 + ELSE IF (KPDS(3).EQ.127) THEN +C ----- U.S. GRID 127 - MAP SIZE 294912 + J = 294912 + GO TO 800 + ELSE IF (KPDS(3).EQ.128) THEN +C ----- U.S. GRID 128 - MAP SIZE 663552 + J = 663552 + GO TO 800 + ELSE IF (KPDS(3).EQ.129) THEN +C ----- U.S. GRID 129 - MAP SIZE 1548800 + J = 1548800 + GO TO 800 + ELSE IF (KPDS(3).EQ.130) THEN +C ----- U.S. GRID 130 - MAP SIZE 151987 + J = 151987 + GO TO 800 + ELSE IF (KPDS(3).EQ.132) THEN +C ----- U.S. GRID 132 - MAP SIZE 385441 + J = 385441 + GO TO 800 + ELSE IF (KPDS(3).EQ.138) THEN +C ----- U.S. GRID 138 - MAP SIZE 134784 + J = 134784 + GO TO 800 + ELSE IF (KPDS(3).EQ.139) THEN +C ----- U.S. GRID 139 - MAP SIZE 4160 + J = 4160 + GO TO 800 + ELSE IF (KPDS(3).EQ.140) THEN +C ----- U.S. GRID 140 - MAP SIZE 32437 + J = 32437 + GO TO 800 +C + ELSE IF (KPDS(3).EQ.145) THEN +C ----- U.S. GRID 145 - MAP SIZE 24505 + J = 24505 + GO TO 800 + ELSE IF (KPDS(3).EQ.146) THEN +C ----- U.S. GRID 146 - MAP SIZE 23572 + J = 23572 + GO TO 800 + ELSE IF (KPDS(3).EQ.147) THEN +C ----- U.S. GRID 147 - MAP SIZE 69412 + J = 69412 + GO TO 800 + ELSE IF (KPDS(3).EQ.148) THEN +C ----- U.S. GRID 148 - MAP SIZE 117130 + J = 117130 + GO TO 800 + ELSE IF (KPDS(3).EQ.150) THEN +C ----- U.S. GRID 150 - MAP SIZE 806010 + J = 806010 + GO TO 800 + ELSE IF (KPDS(3).EQ.151) THEN +C ----- U.S. GRID 151 - MAP SIZE 205062 + J = 205062 + GO TO 800 + ELSE IF (KPDS(3).EQ.160) THEN +C ----- U.S. GRID 160 - MAP SIZE 28080 + J = 28080 + GO TO 800 + ELSE IF (KPDS(3).EQ.161) THEN +C ----- U.S. GRID 161 - MAP SIZE 13974 + J = 13974 + GO TO 800 + ELSE IF (KPDS(3).EQ.163) THEN +C ----- U.S. GRID 163 - MAP SIZE 727776 + J = 727776 + GO TO 800 + ELSE IF (KPDS(3).EQ.170) THEN +C ----- U.S. GRID 170 - MAP SIZE 131072 + J = 131072 + GO TO 800 + ELSE IF (KPDS(3).EQ.171) THEN +C ----- U.S. GRID 171 - MAP SIZE 716100 + J = 716100 + GO TO 800 + ELSE IF (KPDS(3).EQ.172) THEN +C ----- U.S. GRID 172 - MAP SIZE 489900 + J = 489900 + GO TO 800 + ELSE IF (KPDS(3).EQ.173) THEN +C ----- U.S. GRID 173 - MAP SIZE 9331200 + J = 9331200 + GO TO 800 + ELSE IF (KPDS(3).EQ.174) THEN +C ----- U.S. GRID 174 - MAP SIZE 4147200 + J = 4147200 + GO TO 800 + ELSE IF (KPDS(3).EQ.175) THEN +C ----- U.S. GRID 175 - MAP SIZE 185704 + J = 185704 + GO TO 800 + ELSE IF (KPDS(3).EQ.176) THEN +C ----- U.S. GRID 176 - MAP SIZE 76845 + J = 76845 + GO TO 800 + ELSE IF (KPDS(3).EQ.179) THEN +C ----- U.S. GRID 179 - MAP SIZE 977132 + J = 977132 + GO TO 800 + ELSE IF (KPDS(3).EQ.180) THEN +C ----- U.S. GRID 180 - MAP SIZE 267168 + J = 267168 + GO TO 800 + ELSE IF (KPDS(3).EQ.181) THEN +C ----- U.S. GRID 181 - MAP SIZE 102860 + J = 102860 + GO TO 800 + ELSE IF (KPDS(3).EQ.182) THEN +C ----- U.S. GRID 182 - MAP SIZE 64218 + J = 64218 + GO TO 800 + ELSE IF (KPDS(3).EQ.183) THEN +C ----- U.S. GRID 183 - MAP SIZE 180144 + J = 180144 + GO TO 800 + ELSE IF (KPDS(3).EQ.184) THEN +C ----- U.S. GRID 184 - MAP SIZE 2953665 + J = 2953665 + GO TO 800 + ELSE IF (KPDS(3).EQ.187) THEN +C ----- U.S. GRID 187 - MAP SIZE 3425565 + J = 3425565 + GO TO 800 + ELSE IF (KPDS(3).EQ.188) THEN +C ----- U.S. GRID 188 - MAP SIZE 563655 + J = 563655 + GO TO 800 + ELSE IF (KPDS(3).EQ.189) THEN +C ----- U.S. GRID 189 - MAP SIZE 560025 + J = 560025 + GO TO 800 + ELSE IF (KPDS(3).EQ.190) THEN +C ----- U.S GRID 190 - MAP SIZE 796590 + J = 796590 + GO TO 800 + ELSE IF (KPDS(3).EQ.192) THEN +C ----- U.S GRID 192 - MAP SIZE 91719 + J = 91719 + GO TO 800 + ELSE IF (KPDS(3).EQ.193) THEN +C ----- U.S GRID 193 - MAP SIZE 1038240 + J = 1038240 + GO TO 800 + ELSE IF (KPDS(3).EQ.194) THEN +C ----- U.S GRID 194 - MAP SIZE 168640 + J = 168640 + GO TO 800 + ELSE IF (KPDS(3).EQ.195) THEN +C ----- U.S. GRID 195 - MAP SIZE 22833 + J = 22833 + GO TO 800 + ELSE IF (KPDS(3).EQ.196) THEN +C ----- U.S. GRID 196 - MAP SIZE 72225 + J = 72225 + GO TO 800 + ELSE IF (KPDS(3).EQ.197) THEN +C ----- U.S. GRID 197 - MAP SIZE 739297 + J = 739297 + GO TO 800 + ELSE IF (KPDS(3).EQ.198) THEN +C ----- U.S. GRID 198 - MAP SIZE 456225 + J = 456225 + GO TO 800 + ELSE IF (KPDS(3).EQ.199) THEN +C ----- U.S. GRID 199 - MAP SIZE 37249 + J = 37249 + GO TO 800 + ELSE IF (IAND(KPDS(4),128).EQ.128) THEN +C ----- U.S. NON-STANDARD GRID + GO TO 895 + END IF + ELSE IF (KPDS(3).GE.200) THEN + IF (KPDS(3).EQ.200) THEN + J = 10152 + GO TO 800 + ELSE IF (KPDS(3).EQ.201) THEN + J = 4225 + GO TO 800 + ELSE IF (KPDS(3).EQ.202) THEN + J = 2795 + GO TO 800 + ELSE IF (KPDS(3).EQ.203.OR.KPDS(3).EQ.205) THEN + J = 1755 + GO TO 800 + ELSE IF (KPDS(3).EQ.204) THEN + J = 6324 + GO TO 800 + ELSE IF (KPDS(3).EQ.206) THEN + J = 2091 + GO TO 800 + ELSE IF (KPDS(3).EQ.207) THEN + J = 1715 + GO TO 800 + ELSE IF (KPDS(3).EQ.208) THEN + J = 783 + GO TO 800 + ELSE IF (KPDS(3).EQ.209) THEN + J = 61325 + GO TO 800 + ELSE IF (KPDS(3).EQ.210) THEN + J = 625 + GO TO 800 + ELSE IF (KPDS(3).EQ.211) THEN + J = 6045 + GO TO 800 + ELSE IF (KPDS(3).EQ.212) THEN + J = 23865 + GO TO 800 + ELSE IF (KPDS(3).EQ.213) THEN + J = 10965 + GO TO 800 + ELSE IF (KPDS(3).EQ.214) THEN + J = 6693 + GO TO 800 + ELSE IF (KPDS(3).EQ.215) THEN + J = 94833 + GO TO 800 + ELSE IF (KPDS(3).EQ.216) THEN + J = 14873 + GO TO 800 + ELSE IF (KPDS(3).EQ.217) THEN + J = 59001 + GO TO 800 + ELSE IF (KPDS(3).EQ.218) THEN + J = 262792 + GO TO 800 + ELSE IF (KPDS(3).EQ.219) THEN + J = 179025 + GO TO 800 + ELSE IF (KPDS(3).EQ.220) THEN + J = 122475 + GO TO 800 + ELSE IF (KPDS(3).EQ.221) THEN + J = 96673 + GO TO 800 + ELSE IF (KPDS(3).EQ.222) THEN + J = 15456 + GO TO 800 + ELSE IF (KPDS(3).EQ.223) THEN + J = 16641 + GO TO 800 + ELSE IF (KPDS(3).EQ.224) THEN + J = 4225 + GO TO 800 + ELSE IF (KPDS(3).EQ.225) THEN + J = 24975 + GO TO 800 + ELSE IF (KPDS(3).EQ.226) THEN + J = 381029 + GO TO 800 + ELSE IF (KPDS(3).EQ.227) THEN + J = 1509825 + GO TO 800 + ELSE IF (KPDS(3).EQ.228) THEN + J = 10512 + GO TO 800 + ELSE IF (KPDS(3).EQ.229) THEN + J = 65160 + GO TO 800 + ELSE IF (KPDS(3).EQ.230) THEN + J = 259920 + GO TO 800 + ELSE IF (KPDS(3).EQ.231) THEN + J = 130320 + GO TO 800 + ELSE IF (KPDS(3).EQ.232) THEN + J = 32760 + GO TO 800 + ELSE IF (KPDS(3).EQ.233) THEN + J = 45216 + GO TO 800 + ELSE IF (KPDS(3).EQ.234) THEN + J = 16093 + GO TO 800 + ELSE IF (KPDS(3).EQ.235) THEN + J = 259200 + GO TO 800 + ELSE IF (KPDS(3).EQ.236) THEN + J = 17063 + GO TO 800 + ELSE IF (KPDS(3).EQ.237) THEN + J = 2538 + GO TO 800 + ELSE IF (KPDS(3).EQ.238) THEN + J = 55825 + GO TO 800 + ELSE IF (KPDS(3).EQ.239) THEN + J = 19065 + GO TO 800 + ELSE IF (KPDS(3).EQ.240) THEN + J = 987601 + GO TO 800 + ELSE IF (KPDS(3).EQ.241) THEN + J = 244305 + GO TO 800 + ELSE IF (KPDS(3).EQ.242) THEN + J = 235025 + GO TO 800 + ELSE IF (KPDS(3).EQ.243) THEN + J = 12726 + GO TO 800 + ELSE IF (KPDS(3).EQ.244) THEN + J = 55825 + GO TO 800 + ELSE IF (KPDS(3).EQ.245) THEN + J = 124992 + GO TO 800 + ELSE IF (KPDS(3).EQ.246) THEN + J = 123172 + GO TO 800 + ELSE IF (KPDS(3).EQ.247) THEN + J = 124992 + GO TO 800 + ELSE IF (KPDS(3).EQ.248) THEN + J = 13635 + GO TO 800 + ELSE IF (KPDS(3).EQ.249) THEN + J = 125881 + GO TO 800 + ELSE IF (KPDS(3).EQ.250) THEN + J = 13635 + GO TO 800 + ELSE IF (KPDS(3).EQ.251) THEN + J = 69720 + GO TO 800 + ELSE IF (KPDS(3).EQ.252) THEN + J = 67725 + GO TO 800 + ELSE IF (KPDS(3).EQ.253) THEN + J = 83552 + GO TO 800 + ELSE IF (KPDS(3).EQ.254) THEN + J = 110700 + GO TO 800 + ELSE IF (IAND(KPDS(4),128).EQ.128) THEN + GO TO 895 + END IF + KRET = 5 + RETURN + END IF + END IF +C ------------------------------------------------------- +C CHECK JAPAN METEOROLOGICAL AGENCY SET +C ------------------------------------------------------- + IF (KPDS(1).EQ.34) THEN + IF (IAND(KPDS(4),128).EQ.128) THEN +C PRINT *,'JMA MAP IS NOT PREDEFINED, THE GDS WILL' +C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3) + GO TO 900 + END IF + END IF +C ------------------------------------------------------- +C CHECK CANADIAN SET +C ------------------------------------------------------- + IF (KPDS(1).EQ.54) THEN + IF (IAND(KPDS(4),128).EQ.128) THEN +C PRINT *,'CANADIAN MAP IS NOT PREDEFINED, THE GDS WILL' +C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3) + GO TO 900 + END IF + END IF +C ------------------------------------------------------- +C CHECK FNOC SET +C ------------------------------------------------------- + IF (KPDS(1).EQ.58) THEN + IF (KPDS(3).EQ.220.OR.KPDS(3).EQ.221) THEN +C FNOC GRID 220, 221 - MAPSIZE 3969 (63 * 63) + J = 3969 + KPTR(10) = J + DO I = 1, J + KBMS(I) = .TRUE. + END DO + RETURN + END IF + IF (KPDS(3).EQ.223) THEN +C FNOC GRID 223 - MAPSIZE 10512 (73 * 144) + J = 10512 + KPTR(10) = J + DO I = 1, J + KBMS(I) = .TRUE. + END DO + RETURN + END IF + IF (IAND(KPDS(4),128).EQ.128) THEN +C PRINT *,'FNOC MAP IS NOT PREDEFINED, THE GDS WILL' +C PRINT *,'BE USED TO UNPACK THE DATA, MAP = ',KPDS(3) + GO TO 900 + END IF + END IF +C ------------------------------------------------------- +C CHECK UKMET SET +C ------------------------------------------------------- + IF (KPDS(1).EQ.74) THEN + IF (IAND(KPDS(4),128).EQ.128) THEN + GO TO 820 + END IF + END IF +C ------------------------------------------------------- +C CHECK ECMWF SET +C ------------------------------------------------------- + IF (KPDS(1).EQ.98) THEN + IF (KPDS(3).GE.1.AND.KPDS(3).LE.12) THEN + IF (KPDS(3).GE.5.AND.KPDS(3).LE.8) THEN + J = 1073 + ELSE + J = 1369 + END IF + KPTR(10) = J + CALL FI637(J,KPDS,KGDS,KRET) + IF(KRET.NE.0) GO TO 810 + KPTR(10) = J ! Reset For Modified J + DO 1000 I = 1, J + KBMS(I) = .TRUE. + 1000 CONTINUE + RETURN + ELSE IF (KPDS(3).GE.13.AND.KPDS(3).LE.16) THEN + J = 361 + KPTR(10) = J + CALL FI637(J,KPDS,KGDS,KRET) + IF(KRET.NE.0) GO TO 810 + DO 1013 I = 1, J + KBMS(I) = .TRUE. + 1013 CONTINUE + RETURN + ELSE IF (IAND(KPDS(4),128).EQ.128) THEN + GO TO 810 + ELSE + KRET = 5 + RETURN + END IF + ELSE +C PRINT *,'CENTER ',KPDS(1),' IS NOT DEFINED' + IF (IAND(KPDS(4),128).EQ.128) THEN +C PRINT *,'GDS WILL BE USED TO UNPACK THE DATA', +C * ' MAP = ',KPDS(3) + GO TO 900 + ELSE + KRET = 10 + RETURN + END IF + END IF +C ======================================= +C + 800 CONTINUE + KPTR(10) = J + CALL FI637 (J,KPDS,KGDS,KRET) + IF(KRET.NE.0) GO TO 801 + DO 2201 I = 1, J + KBMS(I) = .TRUE. + 2201 CONTINUE + RETURN + 801 CONTINUE +C +C ----- THE MAP HAS A GDS, BYTE 7 OF THE (PDS) THE GRID IDENTIFICATION +C ----- IS NOT 255, THE SIZE OF THE GRID IS NOT THE SAME AS THE +C ----- PREDEFINED SIZES OF THE U.S. GRIDS, OR KNOWN GRIDS OF THE +C ----- OF THE OTHER CENTERS. THE GRID CAN BE UNKNOWN, OR FROM AN +C ----- UNKNOWN CENTER, WE WILL USE THE INFORMATION IN THE GDS TO MAKE +C ----- A BIT MAP. +C + 810 CONTINUE +C PRINT *,'ECMWF PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE' + GO TO 895 +C + 820 CONTINUE +C PRINT *,'U.K. MET PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE' + GO TO 895 +C + 890 CONTINUE +C PRINT *,'PREDEFINED MAP SIZE DOES NOT MATCH, I WILL USE' + 895 CONTINUE +C PRINT *,'THE GDS TO UNPACK THE DATA, MAP TYPE = ',KPDS(3) +C + 900 CONTINUE + J = KGDS(2) * KGDS(3) +C AFOS AFOS AFOS SPECIAL CASE +C INVOLVES NEXT SINGLE STATEMENT ONLY + IF (KPDS(3).EQ.211) KRET = 0 + KPTR(10) = J + DO 2203 I = 1, J + KBMS(I) = .TRUE. + 2203 CONTINUE +C PRINT *,'EXIT FI634' + RETURN + END +C----------------------------------------------------------------------- + SUBROUTINE FI634X(NPTS,NSKP,MSGA,KBMS) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI634X EXTRACT BIT MAP +C PRGMMR: IREDELL ORG: W/NP23 DATE: 91-09-19 +C +C ABSTRACT: EXTRACT THE PACKED BITMAP INTO A LOGICAL ARRAY. +C +C PROGRAM HISTORY LOG: +C 97-09-19 IREDELL VECTORIZED BITMAP DECODER +C +C USAGE: CALL FI634X(NPTS,NSKP,MSGA,KBMS) +C INPUT ARGUMENT LIST: +C NPTS - INTEGER NUMBER OF POINTS IN THE BITMAP FIELD +C NSKP - INTEGER NUMBER OF BITS TO SKIP IN GRIB MESSAGE +C MSGA - CHARACTER*1 GRIB MESSAGE +C +C OUTPUT ARGUMENT LIST: +C KBMS - LOGICAL*1 BITMAP +C +C REMARKS: +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: CRAY +C +C$$$ + CHARACTER*1 MSGA(*) + LOGICAL*1 KBMS(NPTS) + INTEGER ICHK(NPTS) +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + CALL GBYTESC(MSGA,ICHK,NSKP,1,0,NPTS) + KBMS=ICHK.NE.0 +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + END + SUBROUTINE FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI635 EXTRACT GRIB DATA ELEMENTS FROM BDS +C PRGMMR: BILL CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 +C +C ABSTRACT: EXTRACT GRIB DATA FROM BINARY DATA SECTION AND PLACE +C INTO OUTPUT ARRAY IN PROPER POSITION. +C +C PROGRAM HISTORY LOG: +C 91-09-13 CAVANAUGH +C 94-04-01 CAVANAUGH MODIFIED CODE TO INCLUDE DECIMAL SCALING WHEN +C CALCULATING THE VALUE OF DATA POINTS SPECIFIED +C AS BEING EQUAL TO THE REFERENCE VALUE +C 94-11-10 FARLEY INCREASED MXSIZE FROM 72960 TO 260000 +C FOR .5 DEGREE SST ANALYSIS FIELDS +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 98-08-31 IREDELL ELIMINATED NEED FOR MXSIZE +C +C USAGE: CALL FI635(MSGA,KPTR,KPDS,KGDS,KBMS,DATA,KRET) +C INPUT ARGUMENT LIST: +C MSGA - ARRAY CONTAINING GRIB MESSAGE +C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS +C (1) - TOTAL LENGTH OF GRIB MESSAGE +C (2) - LENGTH OF INDICATOR (SECTION 0) +C (3) - LENGTH OF PDS (SECTION 1) +C (4) - LENGTH OF GDS (SECTION 2) +C (5) - LENGTH OF BMS (SECTION 3) +C (6) - LENGTH OF BDS (SECTION 4) +C (7) - VALUE OF CURRENT BYTE +C (8) - BIT POINTER +C (9) - GRIB START BIT NR +C (10) - GRIB/GRID ELEMENT COUNT +C (11) - NR UNUSED BITS AT END OF SECTION 3 +C (12) - BIT MAP FLAG +C (13) - NR UNUSED BITS AT END OF SECTION 2 +C (14) - BDS FLAGS +C (15) - NR UNUSED BITS AT END OF SECTION 4 +C (16) - RESERVED +C (17) - RESERVED +C (18) - RESERVED +C (19) - BINARY SCALE FACTOR +C (20) - NUM BITS USED TO PACK EACH DATUM +C KPDS - ARRAY CONTAINING PDS ELEMENTS. +C SEE INITIAL ROUTINE +C KBMS - BITMAP DESCRIBING LOCATION OF OUTPUT ELEMENTS. +C +C OUTPUT ARGUMENT LIST: +C KBDS - INFORMATION EXTRACTED FROM BINARY DATA SECTION +C KBDS(1) - N1 +C KBDS(2) - N2 +C KBDS(3) - P1 +C KBDS(4) - P2 +C KBDS(5) - BIT POINTER TO 2ND ORDER WIDTHS +C KBDS(6) - " " " " " BIT MAPS +C KBDS(7) - " " " FIRST ORDER VALUES +C KBDS(8) - " " " SECOND ORDER VALUES +C KBDS(9) - " " START OF BDS +C KBDS(10) - " " MAIN BIT MAP +C KBDS(11) - BINARY SCALING +C KBDS(12) - DECIMAL SCALING +C KBDS(13) - BIT WIDTH OF FIRST ORDER VALUES +C KBDS(14) - BIT MAP FLAG +C 0 = NO SECOND ORDER BIT MAP +C 1 = SECOND ORDER BIT MAP PRESENT +C KBDS(15) - SECOND ORDER BIT WIDTH +C KBDS(16) - CONSTANT / DIFFERENT WIDTHS +C 0 = CONSTANT WIDTHS +C 1 = DIFFERENT WIDTHS +C KBDS(17) - SINGLE DATUM / MATRIX +C 0 = SINGLE DATUM AT EACH GRID POINT +C 1 = MATRIX OF VALUES AT EACH GRID POINT +C (18-20)- UNUSED +C +C DATA - REAL*4 ARRAY OF GRIDDED ELEMENTS IN GRIB MESSAGE. +C KPTR - ARRAY CONTAINING STORAGE FOR FOLLOWING PARAMETERS +C SEE INPUT LIST +C KRET - ERROR RETURN +C +C REMARKS: +C ERROR RETURN +C 3 = UNPACKED FIELD IS LARGER THAN 65160 +C 6 = DOES NOT MATCH NR OF ENTRIES FOR THIS GRIB/GRID +C 7 = NUMBER OF BITS IN FILL TOO LARGE +C +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: HDS9000 +C +C$$$ +C + CHARACTER*1 MSGA(*) +C + LOGICAL*1 KBMS(*) +C + INTEGER KPDS(*) + INTEGER KGDS(*) + INTEGER KBDS(20) + INTEGER KPTR(*) + INTEGER NRBITS + INTEGER,ALLOCATABLE:: KSAVE(:) + INTEGER KSCALE +C + REAL DATA(*) + REAL REFNCE + REAL SCALE + REAL REALKK +C +C +C CHANGED HEX VALUES TO DECIMAL TO MAKE CODE MORE PORTABLE +C +C ************************************************************* +C PRINT *,'ENTER FI635' +C SET UP BIT POINTER + KPTR(8) = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8) + * + (KPTR(5)*8) + 24 +C ------------- EXTRACT FLAGS +C BYTE 4 + CALL GBYTEC(MSGA,KPTR(14),KPTR(8),4) + KPTR(8) = KPTR(8) + 4 +C --------- NR OF UNUSED BITS IN SECTION 4 + CALL GBYTEC(MSGA,KPTR(15),KPTR(8),4) + KPTR(8) = KPTR(8) + 4 + KEND = KPTR(9) + (KPTR(2)*8) + (KPTR(3)*8) + (KPTR(4)*8) + * + (KPTR(5)*8) + KPTR(6) * 8 - KPTR(15) +C ------------- GET SCALE FACTOR +C BYTES 5,6 +C CHECK SIGN + CALL GBYTEC (MSGA,KSIGN,KPTR(8),1) + KPTR(8) = KPTR(8) + 1 +C GET ABSOLUTE SCALE VALUE + CALL GBYTEC (MSGA,KSCALE,KPTR(8),15) + KPTR(8) = KPTR(8) + 15 + IF (KSIGN.GT.0) THEN + KSCALE = - KSCALE + END IF + SCALE = 2.0**KSCALE + KPTR(19)=KSCALE +C ------------ GET REFERENCE VALUE +C BYTES 7,10 +C CALL GBYTE (MSGA,KREF,KPTR(8),32) + call gbytec(MSGA,JSGN,KPTR(8),1) + call gbytec(MSGA,JEXP,KPTR(8)+1,7) + call gbytec(MSGA,IFR,KPTR(8)+8,24) + KPTR(8) = KPTR(8) + 32 +C +C THE NEXT CODE WILL CONVERT THE IBM370 FLOATING POINT +C TO THE FLOATING POINT USED ON YOUR COMPUTER. +C +C +C PRINT *,109,JSGN,JEXP,IFR +C 109 FORMAT (' JSGN,JEXP,IFR = ',3(1X,Z8)) + IF (IFR.EQ.0) THEN + REFNCE = 0.0 + ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN + REFNCE = 0.0 + ELSE + REFNCE = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) + IF (JSGN.NE.0) REFNCE = - REFNCE + END IF +C PRINT *,'SCALE ',SCALE,' REF VAL ',REFNCE +C ------------- NUMBER OF BITS SPECIFIED FOR EACH ENTRY +C BYTE 11 + CALL GBYTEC (MSGA,KBITS,KPTR(8),8) + KPTR(8) = KPTR(8) + 8 + KBDS(4) = KBITS +C KBDS(13) = KBITS + KPTR(20) = KBITS + IBYT12 = KPTR(8) +C ------------------ IF THERE ARE NO EXTENDED FLAGS PRESENT +C THIS IS WHERE DATA BEGINS AND AND THE PROCESSING +C INCLUDED IN THE FOLLOWING IF...END IF +C WILL BE SKIPPED +C PRINT *,'BASIC FLAGS =',KPTR(14) ,IAND(KPTR(14),1) + IF (IAND(KPTR(14),1).EQ.0) THEN +C PRINT *,'NO EXTENDED FLAGS' + ELSE +C BYTES 12,13 + CALL GBYTEC (MSGA,KOCTET,KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C --------------------------- EXTENDED FLAGS +C BYTE 14 + CALL GBYTEC (MSGA,KXFLAG,KPTR(8),8) +C PRINT *,'HAVE EXTENDED FLAGS',KXFLAG + KPTR(8) = KPTR(8) + 8 + IF (IAND(KXFLAG,16).EQ.0) THEN +C SECOND ORDER VALUES CONSTANT WIDTHS + KBDS(16) = 0 + ELSE +C SECOND ORDER VALUES DIFFERENT WIDTHS + KBDS(16) = 1 + END IF + IF (IAND (KXFLAG,32).EQ.0) THEN +C NO SECONDARY BIT MAP + KBDS(14) = 0 + ELSE +C HAVE SECONDARY BIT MAP + KBDS(14) = 1 + END IF + IF (IAND (KXFLAG,64).EQ.0) THEN +C SINGLE DATUM AT GRID POINT + KBDS(17) = 0 + ELSE +C MATRIX OF VALUES AT GRID POINT + KBDS(17) = 1 + END IF +C ---------------------- NR - FIRST DIMENSION (ROWS) OF EACH MATRIX +C BYTES 15,16 + CALL GBYTEC (MSGA,NR,KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ---------------------- NC - SECOND DIMENSION (COLS) OF EACH MATRIX +C BYTES 17,18 + CALL GBYTEC (MSGA,NC,KPTR(8),16) + KPTR(8) = KPTR(8) + 16 +C ---------------------- NRV - FIRST DIM COORD VALS +C BYTE 19 + CALL GBYTEC (MSGA,NRV,KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ---------------------- NC1 - NR COEFF'S OR VALUES +C BYTE 20 + CALL GBYTEC (MSGA,NC1,KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ---------------------- NCV - SECOND DIM COORD OR VALUE +C BYTE 21 + CALL GBYTEC (MSGA,NCV,KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ---------------------- NC2 - NR COEFF'S OR VALS +C BYTE 22 + CALL GBYTEC (MSGA,NC2,KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ---------------------- KPHYS1 - FIRST DIM PHYSICAL SIGNIF +C BYTE 23 + CALL GBYTEC (MSGA,KPHYS1,KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C ---------------------- KPHYS2 - SECOND DIM PHYSICAL SIGNIF +C BYTE 24 + CALL GBYTEC (MSGA,KPHYS2,KPTR(8),8) + KPTR(8) = KPTR(8) + 8 +C BYTES 25-N + END IF + IF (KBITS.EQ.0) THEN +C HAVE NO BDS ENTRIES, ALL ENTRIES = REFNCE + SCAL10 = 10.0 ** KPDS(22) + SCAL10 = 1.0 / SCAL10 + REFN10 = REFNCE * SCAL10 + KENTRY = KPTR(10) + DO 210 I = 1, KENTRY + DATA(I) = 0.0 + IF (KBMS(I)) THEN + DATA(I) = REFN10 + END IF + 210 CONTINUE + GO TO 900 + END IF +C PRINT *,'KEND ',KEND,' KPTR(8) ',KPTR(8),'KBITS ',KBITS + KNR = (KEND - KPTR(8)) / KBITS +C PRINT *,'NUMBER OF ENTRIES IN DATA ARRAY',KNR +C -------------------- +C CYCLE THRU BDS UNTIL HAVE USED ALL (SPECIFIED NUMBER) +C ENTRIES. +C ------------- UNUSED BITS IN DATA AREA +C NUMBER OF BYTES IN DATA AREA + NRBYTE = KPTR(6) - 11 +C ------------- TOTAL NR OF USABLE BITS + NRBITS = NRBYTE * 8 - KPTR(15) +C ------------- TOTAL NR OF ENTRIES + KENTRY = NRBITS / KBITS +C ALLOCATE KSAVE + ALLOCATE(KSAVE(KENTRY)) +C +C IF (IAND(KPTR(14),2).EQ.0) THEN +C PRINT *,'SOURCE VALUES IN FLOATING POINT' +C ELSE +C PRINT *,'SOURCE VALUES IN INTEGER' +C END IF +C + IF (IAND(KPTR(14),8).EQ.0) THEN +C PRINT *,'PROCESSING GRID POINT DATA' + IF (IAND(KPTR(14),4).EQ.0) THEN +C PRINT *,' WITH SIMPLE PACKING' + IF (IAND(KPTR(14),1).EQ.0) THEN +C PRINT *,' WITH NO ADDITIONAL FLAGS' + GO TO 4000 + ELSE IF (IAND(KPTR(14),1).NE.0) THEN +C PRINT *,' WITH ADDITIONAL FLAGS',KXFLAG + IF (KBDS(17).EQ.0) THEN +C PRINT *,' SINGLE DATUM EACH GRID PT' + IF (KBDS(14).EQ.0) THEN +C PRINT *,' NO SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + ELSE IF (KBDS(14).NE.0) THEN +C PRINT *,' SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + END IF + ELSE IF (KBDS(17).NE.0) THEN +C PRINT *,' MATRIX OF VALS EACH PT' + IF (KBDS(14).EQ.0) THEN +C PRINT *,' NO SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + ELSE IF (KBDS(14).NE.0) THEN +C PRINT *,' SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + END IF + END IF + END IF + ELSE IF (IAND(KPTR(14),4).NE.0) THEN +C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING' + IF (IAND(KPTR(14),1).EQ.0) THEN +C PRINT *,' WITH NO ADDITIONAL FLAGS' + ELSE IF (IAND(KPTR(14),1).NE.0) THEN +C PRINT *,' WITH ADDITIONAL FLAGS' + IF (KBDS(17).EQ.0) THEN +C PRINT *,' SINGLE DATUM AT EACH PT' + IF (KBDS(14).EQ.0) THEN +C PRINT *,' NO SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF +C ROW BY ROW - COL BY COL + CALL FI636 (DATA,MSGA,KBMS, + * REFNCE,KPTR,KPDS,KGDS) + GO TO 900 + ELSE IF (KBDS(14).NE.0) THEN +C PRINT *,' SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + CALL FI636 (DATA,MSGA,KBMS, + * REFNCE,KPTR,KPDS,KGDS) + GO TO 900 + END IF + ELSE IF (KBDS(17).NE.0) THEN +C PRINT *,' MATRIX OF VALS EACH PT' + IF (KBDS(14).EQ.0) THEN +C PRINT *,' NO SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + ELSE IF (KBDS(14).NE.0) THEN +C PRINT *,' SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + END IF + END IF + END IF + END IF + ELSE IF (IAND(KPTR(14),8).NE.0) THEN +C PRINT *,'PROCESSING SPHERICAL HARMONIC COEFFICIENTS' + IF (IAND(KPTR(14),4).EQ.0) THEN +C PRINT *,' WITH SIMPLE PACKING' + IF (IAND(KPTR(14),1).EQ.0) THEN +C PRINT *,' WITH NO ADDITIONAL FLAGS' + GO TO 5000 + ELSE IF (IAND(KPTR(14),1).NE.0) THEN +C PRINT *,' WITH ADDITIONAL FLAGS' + IF (KBDS(17).EQ.0) THEN +C PRINT *,' SINGLE DATUM EACH GRID PT' + IF (KBDS(14).EQ.0) THEN +C PRINT *,' NO SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + ELSE IF (KBDS(14).NE.0) THEN +C PRINT *,' SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + END IF + ELSE IF (KBDS(17).NE.0) THEN +C PRINT *,' MATRIX OF VALS EACH PT' + IF (KBDS(14).EQ.0) THEN +C PRINT *,' NO SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + ELSE IF (KBDS(14).NE.0) THEN +C PRINT *,' SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + END IF + END IF + END IF + ELSE IF (IAND(KPTR(14),4).NE.0) THEN +C COMPLEX/SECOND ORDER PACKING +C PRINT *,' WITH COMPLEX/SECOND ORDER PACKING' + IF (IAND(KPTR(14),1).EQ.0) THEN +C PRINT *,' WITH NO ADDITIONAL FLAGS' + ELSE IF (IAND(KPTR(14),1).NE.0) THEN +C PRINT *,' WITH ADDITIONAL FLAGS' + IF (KBDS(17).EQ.0) THEN +C PRINT *,' SINGLE DATUM EACH GRID PT' + IF (KBDS(14).EQ.0) THEN +C PRINT *,' NO SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + ELSE IF (KBDS(14).NE.0) THEN +C PRINT *,' SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + END IF + ELSE IF (KBDS(17).NE.0) THEN +C PRINT *,' MATRIX OF VALS EACH PT' + IF (KBDS(14).EQ.0) THEN +C PRINT *,' NO SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + ELSE IF (KBDS(14).NE.0) THEN +C PRINT *,' SEC BIT MAP' + IF (KBDS(16).EQ.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES CONSTANT WIDTH' + ELSE IF (KBDS(16).NE.0) THEN +C PRINT *,' SECOND ORDER', +C * ' VALUES DIFFERENT WIDTHS' + END IF + END IF + END IF + END IF + END IF + END IF + IF(ALLOCATED(KSAVE)) DEALLOCATE(KSAVE) +C PRINT *,' NOT PROCESSED - NOT PROCESSED - NOT PROCESSED' + KRET = 11 + RETURN + 4000 CONTINUE +C **************************************************************** +C +C GRID POINT DATA, SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS +C + SCAL10 = 10.0 ** KPDS(22) + SCAL10 = 1.0 / SCAL10 + IF (KPDS(3).EQ.23.OR.KPDS(3).EQ.24.OR.KPDS(3).EQ.26. + * OR.KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN + IF (KPDS(3).EQ.26) THEN + KADD = 72 + ELSE IF (KPDS(3).EQ.63.OR.KPDS(3).EQ.64) THEN + KADD = 91 + ELSE + KADD = 37 + END IF + CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) + KPTR(8) = KPTR(8) + KBITS * KNR + II = 1 + KENTRY = KPTR(10) + DO 4001 I = 1, KENTRY + IF (KBMS(I)) THEN + DATA(I) = (REFNCE+FLOAT(KSAVE(II))*SCALE)*SCAL10 + II = II + 1 + ELSE + DATA(I) = 0.0 + END IF + 4001 CONTINUE + DO 4002 I = 2, KADD + DATA(I) = DATA(1) + 4002 CONTINUE + ELSE IF (KPDS(3).EQ.21.OR.KPDS(3).EQ.22.OR.KPDS(3).EQ.25. + * OR.KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN + CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) + II = 1 + KENTRY = KPTR(10) + DO 4011 I = 1, KENTRY + IF (KBMS(I)) THEN + DATA(I) = (REFNCE + FLOAT(KSAVE(II)) * SCALE) * SCAL10 + II = II + 1 + ELSE + DATA(I) = 0.0 + END IF + 4011 CONTINUE + IF (KPDS(3).EQ.25) THEN + KADD = 71 + ELSE IF (KPDS(3).EQ.61.OR.KPDS(3).EQ.62) THEN + KADD = 90 + ELSE + KADD = 36 + END IF + LASTP = KENTRY - KADD + DO 4012 I = LASTP+1, KENTRY + DATA(I) = DATA(LASTP) + 4012 CONTINUE + ELSE + CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) + II = 1 + KENTRY = KPTR(10) + DO 500 I = 1, KENTRY + IF (KBMS(I)) THEN + DATA(I) = (REFNCE + FLOAT(KSAVE(II)) * SCALE) * SCAL10 + II = II + 1 + ELSE + DATA(I) = 0.0 + END IF + 500 CONTINUE + END IF + GO TO 900 +C ------------- PROCESS SPHERICAL HARMONIC COEFFICIENTS, +C SIMPLE PACKING, FLOATING POINT, NO ADDN'L FLAGS + 5000 CONTINUE +C PRINT *,'CHECK POINT SPECTRAL COEFF' + KPTR(8) = IBYT12 +C CALL GBYTE (MSGA,KKK,KPTR(8),32) + call gbytec(MSGA,JSGN,KPTR(8),1) + call gbytec(MSGA,JEXP,KPTR(8)+1,7) + call gbytec(MSGA,IFR,KPTR(8)+8,24) + KPTR(8) = KPTR(8) + 32 +C +C THE NEXT CODE WILL CONVERT THE IBM370 FOATING POINT +C TO THE FLOATING POINT USED ON YOUR MACHINE. +C + IF (IFR.EQ.0) THEN + REALKK = 0.0 + ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN + REALKK = 0.0 + ELSE + REALKK = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) + IF (JSGN.NE.0) REALKK = -REALKK + END IF + DATA(1) = REALKK + CALL GBYTESC (MSGA,KSAVE,KPTR(8),KBITS,0,KNR) +C -------------- + DO 6000 I = 1, KENTRY + DATA(I+1) = REFNCE + FLOAT(KSAVE(I)) * SCALE + 6000 CONTINUE + 900 CONTINUE + IF(ALLOCATED(KSAVE)) DEALLOCATE(KSAVE) +C PRINT *,'EXIT FI635' + RETURN + END + SUBROUTINE FI636 (DATA,MSGA,KBMS,REFNCE,KPTR,KPDS,KGDS) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI636 PROCESS SECOND ORDER PACKING +C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 92-09-22 +C +C ABSTRACT: PROCESS SECOND ORDER PACKING FROM THE BINARY DATA SECTION +C (BDS) FOR SINGLE DATA ITEMS GRID POINT DATA +C +C PROGRAM HISTORY LOG: +C 93-06-08 CAVANAUGH +C 93-12-15 CAVANAUGH MODIFIED SECOND ORDER POINTERS TO FIRST ORDER +C VALUES AND SECOND ORDER VALUES CORRECTLY. +C 95-04-26 R.E.JONES FI636 CORECTION FOR 2ND ORDER COMPLEX +C UNPACKING. +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL FI636 (DATA,MSGA,KBMS,REFNCE,KPTR,KPDS,KGDS) +C INPUT ARGUMENT LIST: +C +C MSGA - ARRAY CONTAINING GRIB MESSAGE +C REFNCE - REFERENCE VALUE +C KPTR - WORK ARRAY +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C DATA - LOCATION OF OUTPUT ARRAY +C WORKING ARRAY +C KBDS(1) - N1 +C KBDS(2) - N2 +C KBDS(3) - P1 +C KBDS(4) - P2 +C KBDS(5) - BIT POINTER TO 2ND ORDER WIDTHS +C KBDS(6) - " " " " " BIT MAPS +C KBDS(7) - " " " FIRST ORDER VALUES +C KBDS(8) - " " " SECOND ORDER VALUES +C KBDS(9) - " " START OF BDS +C KBDS(10) - " " MAIN BIT MAP +C KBDS(11) - BINARY SCALING +C KBDS(12) - DECIMAL SCALING +C KBDS(13) - BIT WIDTH OF FIRST ORDER VALUES +C KBDS(14) - BIT MAP FLAG +C 0 = NO SECOND ORDER BIT MAP +C 1 = SECOND ORDER BIT MAP PRESENT +C KBDS(15) - SECOND ORDER BIT WIDTH +C KBDS(16) - CONSTANT / DIFFERENT WIDTHS +C 0 = CONSTANT WIDTHS +C 1 = DIFFERENT WIDTHS +C KBDS(17) - SINGLE DATUM / MATRIX +C 0 = SINGLE DATUM AT EACH GRID POINT +C 1 = MATRIX OF VALUES AT EACH GRID POINT +C (18-20)- UNUSED +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: HDS, CRAY +C +C$$$ + REAL DATA(*) + REAL REFN + REAL REFNCE +C + INTEGER KBDS(20) + INTEGER KPTR(*) + character(len=1) BMAP2(1000000) + INTEGER I,IBDS + INTEGER KBIT,IFOVAL,ISOVAL + INTEGER KPDS(*),KGDS(*) +C + LOGICAL*1 KBMS(*) +C + CHARACTER*1 MSGA(*) +C +C ******************* SETUP ****************************** +C PRINT *,'ENTER FI636' +C START OF BMS (BIT POINTER) + DO I = 1,20 + KBDS(I) = 0 + END DO +C BYTE START OF BDS + IBDS = KPTR(2) + KPTR(3) + KPTR(4) + KPTR(5) +C PRINT *,'KPTR(2-5) ',KPTR(2),KPTR(3),KPTR(4),KPTR(5) +C BIT START OF BDS + JPTR = IBDS * 8 +C PRINT *,'JPTR ',JPTR + KBDS(9) = JPTR +C PRINT *,'START OF BDS ',KBDS(9) +C BINARY SCALE VALUE BDS BYTES 5-6 + CALL GBYTEC (MSGA,ISIGN,JPTR+32,1) + CALL GBYTEC (MSGA,KBDS(11),JPTR+33,15) + IF (ISIGN.GT.0) THEN + KBDS(11) = - KBDS(11) + END IF +C PRINT *,'BINARY SCALE VALUE =',KBDS(11) +C EXTRACT REFERENCE VALUE +C CALL GBYTEC(MSGA,JREF,JPTR+48,32) + call gbytec(MSGA,JSGN,KPTR(8),1) + call gbytec(MSGA,JEXP,KPTR(8)+1,7) + call gbytec(MSGA,IFR,KPTR(8)+8,24) + IF (IFR.EQ.0) THEN + REFNCE = 0.0 + ELSE IF (JEXP.EQ.0.AND.IFR.EQ.0) THEN + REFNCE = 0.0 + ELSE + REFNCE = FLOAT(IFR) * 16.0 ** (JEXP - 64 - 6) + IF (JSGN.NE.0) REFNCE = - REFNCE + END IF +C PRINT *,'DECODED REFERENCE VALUE =',REFN,REFNCE +C F O BIT WIDTH + CALL GBYTEC(MSGA,KBDS(13),JPTR+80,8) + JPTR = JPTR + 88 +C AT START OF BDS BYTE 12 +C EXTRACT N1 + CALL GBYTEC (MSGA,KBDS(1),JPTR,16) +C PRINT *,'N1 = ',KBDS(1) + JPTR = JPTR + 16 +C EXTENDED FLAGS + CALL GBYTEC (MSGA,KFLAG,JPTR,8) +C ISOLATE BIT MAP FLAG + IF (IAND(KFLAG,32).NE.0) THEN + KBDS(14) = 1 + ELSE + KBDS(14) = 0 + END IF + IF (IAND(KFLAG,16).NE.0) THEN + KBDS(16) = 1 + ELSE + KBDS(16) = 0 + END IF + IF (IAND(KFLAG,64).NE.0) THEN + KBDS(17) = 1 + ELSE + KBDS(17) = 0 + END IF + JPTR = JPTR + 8 +C EXTRACT N2 + CALL GBYTEC (MSGA,KBDS(2),JPTR,16) +C PRINT *,'N2 = ',KBDS(2) + JPTR = JPTR + 16 +C EXTRACT P1 + CALL GBYTEC (MSGA,KBDS(3),JPTR,16) +C PRINT *,'P1 = ',KBDS(3) + JPTR = JPTR + 16 +C EXTRACT P2 + CALL GBYTEC (MSGA,KBDS(4),JPTR,16) +C PRINT *,'P2 = ',KBDS(4) + JPTR = JPTR + 16 +C SKIP RESERVED BYTE + JPTR = JPTR + 8 +C START OF SECOND ORDER BIT WIDTHS + KBDS(5) = JPTR +C COMPUTE START OF SECONDARY BIT MAP + IF (KBDS(14).NE.0) THEN +C FOR INCLUDED SECONDARY BIT MAP + JPTR = JPTR + (KBDS(3) * 8) + KBDS(6) = JPTR + ELSE +C FOR CONSTRUCTED SECONDARY BIT MAP + KBDS(6) = 0 + END IF +C CREATE POINTER TO START OF FIRST ORDER VALUES + KBDS(7) = KBDS(9) + KBDS(1) * 8 - 8 +C PRINT *,'BIT POINTER TO START OF FOVALS',KBDS(7) +C CREATE POINTER TO START OF SECOND ORDER VALUES + KBDS(8) = KBDS(9) + KBDS(2) * 8 - 8 +C PRINT *,'BIT POINTER TO START OF SOVALS',KBDS(8) +C PRINT *,'KBDS( 1) - N1 ',KBDS( 1) +C PRINT *,'KBDS( 2) - N2 ',KBDS( 2) +C PRINT *,'KBDS( 3) - P1 ',KBDS( 3) +C PRINT *,'KBDS( 4) - P2 ',KBDS( 4) +C PRINT *,'KBDS( 5) - BIT PTR - 2ND ORDER WIDTHS ',KBDS( 5) +C PRINT *,'KBDS( 6) - " " " " BIT MAPS ',KBDS( 6) +C PRINT *,'KBDS( 7) - " " F O VALS ',KBDS( 7) +C PRINT *,'KBDS( 8) - " " S O VALS ',KBDS( 8) +C PRINT *,'KBDS( 9) - " " START OF BDS ',KBDS( 9) +C PRINT *,'KBDS(10) - " " MAIN BIT MAP ',KBDS(10) +C PRINT *,'KBDS(11) - BINARY SCALING ',KBDS(11) +C PRINT *,'KPDS(22) - DECIMAL SCALING ',KPDS(22) +C PRINT *,'KBDS(13) - FO BIT WIDTH ',KBDS(13) +C PRINT *,'KBDS(14) - 2ND ORDER BIT MAP FLAG ',KBDS(14) +C PRINT *,'KBDS(15) - 2ND ORDER BIT WIDTH ',KBDS(15) +C PRINT *,'KBDS(16) - CONSTANT/DIFFERENT WIDTHS ',KBDS(16) +C PRINT *,'KBDS(17) - SINGLE DATUM/MATRIX ',KBDS(17) +C PRINT *,'REFNCE VAL ',REFNCE +C ************************* PROCESS DATA ********************** + IJ = 0 +C ======================================================== + IF (KBDS(14).EQ.0) THEN +C NO BIT MAP, MUST CONSTRUCT ONE + IF (KGDS(2).EQ.65535) THEN + IF (KGDS(20).EQ.255) THEN +C PRINT *,'CANNOT BE USED HERE' + ELSE +C POINT TO PL + LP = KPTR(9) + KPTR(2)*8 + KPTR(3)*8 + KGDS(20)*8 - 8 +C PRINT *,'LP = ',LP + JT = 0 + DO 2000 JZ = 1, KGDS(3) +C GET NUMBER IN CURRENT ROW + CALL GBYTEC (MSGA,NUMBER,LP,16) +C INCREMENT TO NEXT ROW NUMBER + LP = LP + 16 +C PRINT *,'NUMBER IN ROW',JZ,' = ',NUMBER + DO 1500 JQ = 1, NUMBER + IF (JQ.EQ.1) THEN + CALL SBYTEC (BMAP2,1,JT,1) + ELSE + CALL SBYTEC (BMAP2,0,JT,1) + END IF + JT = JT + 1 + 1500 CONTINUE + 2000 CONTINUE + END IF + ELSE + IF (IAND(KGDS(11),32).EQ.0) THEN +C ROW BY ROW +C PRINT *,' ROW BY ROW' + KOUT = KGDS(3) + KIN = KGDS(2) + ELSE +C COL BY COL +C PRINT *,' COL BY COL' + KIN = KGDS(3) + KOUT = KGDS(2) + END IF +C PRINT *,'KIN=',KIN,' KOUT= ',KOUT + DO 200 I = 1, KOUT + DO 150 J = 1, KIN + IF (J.EQ.1) THEN + CALL SBYTEC (BMAP2,1,IJ,1) + ELSE + CALL SBYTEC (BMAP2,0,IJ,1) + END IF + IJ = IJ + 1 + 150 CONTINUE + 200 CONTINUE + END IF + END IF +C ======================================================== +C PRINT 99,(BMAP2(J),J=1,110) +C99 FORMAT ( 10(1X,Z8.8)) +C CALL BINARY (BMAP2,2) +C FOR EACH GRID POINT ENTRY +C + SCALE2 = 2.0**KBDS(11) + SCAL10 = 10.0**KPDS(22) +C PRINT *,'SCALE VALUES - ',SCALE2,SCAL10 + DO 1000 I = 1, KPTR(10) +C GET NEXT MASTER BIT MAP BIT POSITION +C IF NEXT MASTER BIT MAP BIT POSITION IS 'ON' (1) + IF (KBMS(I)) THEN +C WRITE(6,900)I,KBMS(I) +C 900 FORMAT (1X,I4,3X,14HMAIN BIT IS ON,3X,L4) + IF (KBDS(14).NE.0) THEN + CALL GBYTEC (MSGA,KBIT,KBDS(6),1) + ELSE + CALL GBYTEC (BMAP2,KBIT,KBDS(6),1) + END IF +C PRINT *,'KBDS(6) =',KBDS(6),' KBIT =',KBIT + KBDS(6) = KBDS(6) + 1 + IF (KBIT.NE.0) THEN +C PRINT *,' SOB ON' +C GET NEXT FIRST ORDER PACKED VALUE + CALL GBYTEC (MSGA,IFOVAL,KBDS(7),KBDS(13)) + KBDS(7) = KBDS(7) + KBDS(13) +C PRINT *,'FOVAL =',IFOVAL +C GET SECOND ORDER BIT WIDTH + CALL GBYTEC (MSGA,KBDS(15),KBDS(5),8) + KBDS(5) = KBDS(5) + 8 +C PRINT *,KBDS(7)-KBDS(13),' FOVAL =',IFOVAL,' KBDS(5)=', +C * ,KBDS(5), 'ISOWID =',KBDS(15) + ELSE +C PRINT *,' SOB NOT ON' + END IF + ISOVAL = 0 + IF (KBDS(15).EQ.0) THEN +C IF SECOND ORDER BIT WIDTH = 0 +C THEN SECOND ORDER VALUE IS 0 +C SO CALCULATE DATA VALUE FOR THIS POINT +C DATA(I) = (REFNCE + (FLOAT(IFOVAL) * SCALE2)) / SCAL10 + ELSE + CALL GBYTEC (MSGA,ISOVAL,KBDS(8),KBDS(15)) + KBDS(8) = KBDS(8) + KBDS(15) + END IF + DATA(I) = (REFNCE + (FLOAT(IFOVAL + ISOVAL) * + * SCALE2)) / SCAL10 +C PRINT *,I,DATA(I),REFNCE,IFOVAL,ISOVAL,SCALE2,SCAL10 + ELSE +C WRITE(6,901) I,KBMS(I) +C 901 FORMAT (1X,I4,3X,15HMAIN BIT NOT ON,3X,L4) + DATA(I) = 0.0 + END IF +C PRINT *,I,DATA(I),IFOVAL,ISOVAL,KBDS(5),KBDS(15) + 1000 CONTINUE +C ************************************************************** +C PRINT *,'EXIT FI636' + RETURN + END + SUBROUTINE FI637(J,KPDS,KGDS,KRET) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI637 GRIB GRID/SIZE TEST +C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 91-09-13 +C +C ABSTRACT: TO TEST WHEN GDS IS AVAILABLE TO SEE IF SIZE MISMATCH +C ON EXISTING GRIDS (BY CENTER) IS INDICATED +C +C PROGRAM HISTORY LOG: +C 91-09-13 CAVANAUGH +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 97-02-12 W BOSTELMAN CORRECTS ECMWF US GRID 2 PROCESSING +C 98-06-17 IREDELL REMOVED ALTERNATE RETURN +C 99-01-20 BALDWIN MODIFY TO HANDLE GRID 237 +C 09-05-21 VUONG MODIFY TO HANDLE GRID 45 +C +C USAGE: CALL FI637(J,KPDS,KGDS,KRET) +C INPUT ARGUMENT LIST: +C J - SIZE FOR INDICATED GRID +C KPDS - +C KGDS - +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C J - SIZE FOR INDICATED GRID MODIFIED FOR ECMWF-US 2 +C KRET - ERROR RETURN +C (A MISMATCH WAS DETECTED IF KRET IS NOT ZERO) +C +C REMARKS: +C KRET - +C = 9 - GDS INDICATES SIZE MISMATCH WITH STD GRID +C +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 77 +C MACHINE: HDS +C +C$$$ + INTEGER KPDS(*) + INTEGER KGDS(*) + INTEGER J + INTEGER I +C --------------------------------------- +C --------------------------------------- +C IF GDS NOT INDICATED, RETURN +C ---------------------------------------- + KRET=0 + IF (IAND(KPDS(4),128).EQ.0) RETURN +C --------------------------------------- +C GDS IS INDICATED, PROCEED WITH TESTING +C --------------------------------------- + IF (KGDS(2).EQ.65535) THEN + RETURN + END IF + KRET=1 + I = KGDS(2) * KGDS(3) +C --------------------------------------- +C INTERNATIONAL SET +C --------------------------------------- + IF (KPDS(3).GE.21.AND.KPDS(3).LE.26) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.50) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.61.AND.KPDS(3).LE.64) THEN + IF (I.NE.J) THEN + RETURN + END IF +C --------------------------------------- +C TEST ECMWF CONTENT +C --------------------------------------- + ELSE IF (KPDS(1).EQ.98) THEN + KRET = 9 + IF (KPDS(3).GE.1.AND.KPDS(3).LE.16) THEN + IF (I.NE.J) THEN + IF (KPDS(3) .NE. 2) THEN + RETURN + ELSEIF (I .NE. 10512) THEN ! Test for US Grid 2 + RETURN + END IF + J = I ! Set to US Grid 2, 2.5 Global + END IF + ELSE + KRET = 5 + RETURN + END IF +C --------------------------------------- +C U.K. MET OFFICE, BRACKNELL +C --------------------------------------- + ELSE IF (KPDS(1).EQ.74) THEN + KRET = 9 + IF (KPDS(3).GE.25.AND.KPDS(3).LE.26) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE + KRET = 5 + RETURN + END IF +C --------------------------------------- +C CANADA +C --------------------------------------- + ELSE IF (KPDS(1).EQ.54) THEN +C PRINT *,' NO CURRENT LISTING OF CANADIAN GRIDS' + RETURN +C --------------------------------------- +C JAPAN METEOROLOGICAL AGENCY +C --------------------------------------- + ELSE IF (KPDS(1).EQ.34) THEN +C PRINT *,' NO CURRENT LISTING OF JMA GRIDS' + RETURN +C --------------------------------------- +C NAVY - FNOC +C --------------------------------------- + ELSE IF (KPDS(1).EQ.58) THEN + IF (KPDS(3).GE.37.AND.KPDS(3).LE.44) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.220.AND.KPDS(3).LE.221) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.223) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE + KRET = 5 + RETURN + END IF +C --------------------------------------- +C U.S. GRIDS +C --------------------------------------- + ELSE IF (KPDS(1).EQ.7) THEN + KRET = 9 + IF (KPDS(3).GE.1.AND.KPDS(3).LE.6) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.8) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.10) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.11.AND.KPDS(3).LE.18) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.27.AND.KPDS(3).LE.30) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.33.AND.KPDS(3).LE.34) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.37.AND.KPDS(3).LE.45) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.53) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.55.AND.KPDS(3).LE.56) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.67.AND.KPDS(3).LE.77) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.85.AND.KPDS(3).LE.88) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.90.AND.KPDS(3).LE.99) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.100.OR.KPDS(3).EQ.101) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.103.AND.KPDS(3).LE.107) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.110) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.120) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.122.AND.KPDS(3).LE.130) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.132) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.138) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.139) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.140) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.145.AND.KPDS(3).LE.148) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.150.OR.KPDS(3).EQ.151) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.160.OR.KPDS(3).EQ.161) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.163) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.170.AND.KPDS(3).LE.176) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.179.AND.KPDS(3).LE.184) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.187) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.188) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.189) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).EQ.190.OR.KPDS(3).EQ.192) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.193.AND.KPDS(3).LE.199) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE IF (KPDS(3).GE.200.AND.KPDS(3).LE.254) THEN + IF (I.NE.J) THEN + RETURN + END IF + ELSE + KRET = 5 + RETURN + END IF + ELSE + KRET = 10 + RETURN + END IF +C ------------------------------------ +C NORMAL EXIT +C ------------------------------------ + KRET = 0 + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi68.f b/WPS/ungrib/src/ngl/w3/w3fi68.f new file mode 100755 index 00000000..03a7ec3b --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi68.f @@ -0,0 +1,184 @@ + SUBROUTINE W3FI68 (ID, PDS) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI68 CONVERT 25 WORD ARRAY TO GRIB PDS +C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 91-05-14 +C +C ABSTRACT: CONVERTS AN ARRAY OF 25, OR 27 INTEGER WORDS INTO A +C GRIB PRODUCT DEFINITION SECTION (PDS) OF 28 BYTES , OR 30 BYTES. +C IF PDS BYTES > 30, THEY ARE SET TO ZERO. +C +C PROGRAM HISTORY LOG: +C 91-05-08 R.E.JONES +C 92-09-25 R.E.JONES CHANGE TO 25 WORDS OF INPUT, LEVEL +C CAN BE IN TWO WORDS. (10,11) +C 93-01-08 R.E.JONES CHANGE FOR TIME RANGE INDICATOR IF 10, +C STORE TIME P1 IN PDS BYTES 19-20. +C 93-01-26 R.E.JONES CORRECTION FOR FIXED HEIGHT ABOVE +C GROUND LEVEL +C 93-03-29 R.E.JONES ADD SAVE STATEMENT +C 93-06-24 CAVANOUGH MODIFIED PROGRAM TO ALLOW FOR GENERATION +C OF PDS GREATER THAN 28 BYTES (THE DESIRED +C PDS SIZE IS IN ID(1). +C 93-09-30 FARLEY CHANGE TO ALLOW FOR SUBCENTER ID; PUT +C ID(24) INTO PDS(26). +C 93-10-12 R.E.JONES CHANGES FOR ON388 REV. OCT 9,1993, NEW +C LEVELS 125, 200, 201. +C 94-02-23 R.E.JONES TAKE OUT SBYTES, REPLACE WITH DO LOOP +C 94-04-14 R.E.JONES CHANGES FOR ON388 REV. MAR 24,1994, NEW +C LEVELS 115,116. +C 94-12-04 R.E.JONES CHANGE TO ADD ID WORDS 26, 27 FOR PDS +C BYTES 29 AND 30. +C 95-09-07 R.E.JONES CHANGE FOR NEW LEVEL 117, 119. +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 98-06-30 EBISUZAKI LINUX PORT +C 2001-06-05 GILBERT Changed fortran intrinsic function OR() to +C f90 standard intrinsic IOR(). +C 2003-02-25 IREDELL RECOGNIZE LEVEL TYPE 126 +C 2005-05-06 D.C.STOKES RECOGNIZE LEVEL TYPES 235, 237, 238 +C +C USAGE: CALL W3FI68 (ID, PDS) +C INPUT ARGUMENT LIST: +C ID - 25, 27 WORD INTEGER ARRAY +C OUTPUT ARGUMENT LIST: +C PDS - 28 30, OR GREATER CHARACTER PDS FOR EDITION 1 +C +C REMARKS: LAYOUT OF 'ID' ARRAY: +C ID(1) = NUMBER OF BYTES IN PRODUCT DEFINITION SECTION (PDS) +C ID(2) = PARAMETER TABLE VERSION NUMBER +C ID(3) = IDENTIFICATION OF ORIGINATING CENTER +C ID(4) = MODEL IDENTIFICATION (ALLOCATED BY ORIGINATING CENTER) +C ID(5) = GRID IDENTIFICATION +C ID(6) = 0 IF NO GDS SECTION, 1 IF GDS SECTION IS INCLUDED +C ID(7) = 0 IF NO BMS SECTION, 1 IF BMS SECTION IS INCLUDED +C ID(8) = INDICATOR OF PARAMETER AND UNITS (TABLE 2) +C ID(9) = INDICATOR OF TYPE OF LEVEL (TABLE 3) +C ID(10) = VALUE 1 OF LEVEL (0 FOR 1-100,102,103,105,107 +C 109,111,113,115,117,119,125,126,160,200,201, +C 235,237,238 +C LEVEL IS IN ID WORD 11) +C ID(11) = VALUE 2 OF LEVEL +C ID(12) = YEAR OF CENTURY +C ID(13) = MONTH OF YEAR +C ID(14) = DAY OF MONTH +C ID(15) = HOUR OF DAY +C ID(16) = MINUTE OF HOUR (IN MOST CASES SET TO 0) +C ID(17) = FCST TIME UNIT +C ID(18) = P1 PERIOD OF TIME +C ID(19) = P2 PERIOD OF TIME +C ID(20) = TIME RANGE INDICATOR +C ID(21) = NUMBER INCLUDED IN AVERAGE +C ID(22) = NUMBER MISSING FROM AVERAGES +C ID(23) = CENTURY (20, CHANGE TO 21 ON JAN. 1, 2001) +C ID(24) = SUBCENTER IDENTIFICATION +C ID(25) = SCALING POWER OF 10 +C ID(26) = FLAG BYTE, 8 ON/OFF FLAGS +C BIT NUMBER VALUE ID(26) DEFINITION +C 1 0 0 FULL FCST FIELD +C 1 128 FCST ERROR FIELD +C 2 0 0 ORIGINAL FCST FIELD +C 1 64 BIAS CORRECTED FCST FIELD +C 3 0 0 ORIGINAL RESOLUTION RETAINED +C 1 32 SMOOTHED FIELD +C NOTE: ID(26) CAN BE THE SUM OF BITS 1, 2, 3. +C BITS 4-8 NOT USED, SET TO ZERO +C IF ID(1) IS 28, YOU DO NOT NEED ID(26) AND ID(27). +C ID(27) = UNUSED, SET TO 0 SO PDS BYTE 30 IS SET TO ZERO. +C +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: SiliconGraphics 3.5 FORTRAN 77 +C MACHINE: SiliconGraphics IRIS-4D/25, 35, INDIGO, Indy +C LANGUAGE: CRAY CFT77 FORTRAN +C MACHINE: CRAY C916/256, J916/2048 +C +C$$$ +C + INTEGER ID(*) +C + CHARACTER * 1 PDS(*) +C + PDS(1) = CHAR(MOD(ID(1)/65536,256)) + PDS(2) = CHAR(MOD(ID(1)/256,256)) + PDS(3) = CHAR(MOD(ID(1),256)) + PDS(4) = CHAR(ID(2)) + PDS(5) = CHAR(ID(3)) + PDS(6) = CHAR(ID(4)) + PDS(7) = CHAR(ID(5)) + i = 0 + if (ID(6).ne.0) i = i + 128 + if (ID(7).ne.0) i = i + 64 + PDS(8) = char(i) + + PDS(9) = CHAR(ID(8)) + PDS(10) = CHAR(ID(9)) + I9 = ID(9) +C +C TEST TYPE OF LEVEL TO SEE IF LEVEL IS IN TWO +C WORDS OR ONE +C + IF ((I9.GE.1.AND.I9.LE.100).OR.I9.EQ.102.OR. + & I9.EQ.103.OR.I9.EQ.105.OR.I9.EQ.107.OR. + & I9.EQ.109.OR.I9.EQ.111.OR.I9.EQ.113.OR. + & I9.EQ.115.OR.I9.EQ.117.OR.I9.EQ.119.OR. + & I9.EQ.125.OR.I9.EQ.126.OR.I9.EQ.160.OR. + & I9.EQ.200.OR.I9.EQ.201.OR.I9.EQ.235.OR. + & I9.EQ.237.OR.I9.EQ.238) THEN + LEVEL = ID(11) + IF (LEVEL.LT.0) THEN + LEVEL = - LEVEL + LEVEL = IOR(LEVEL,32768) + END IF + PDS(11) = CHAR(MOD(LEVEL/256,256)) + PDS(12) = CHAR(MOD(LEVEL,256)) + ELSE + PDS(11) = CHAR(ID(10)) + PDS(12) = CHAR(ID(11)) + END IF + PDS(13) = CHAR(ID(12)) + PDS(14) = CHAR(ID(13)) + PDS(15) = CHAR(ID(14)) + PDS(16) = CHAR(ID(15)) + PDS(17) = CHAR(ID(16)) + PDS(18) = CHAR(ID(17)) +C +C TEST TIME RANGE INDICATOR (PDS BYTE 21) FOR 10 +C IF SO PUT TIME P1 IN PDS BYTES 19-20. +C + IF (ID(20).EQ.10) THEN + PDS(19) = CHAR(MOD(ID(18)/256,256)) + PDS(20) = CHAR(MOD(ID(18),256)) + ELSE + PDS(19) = CHAR(ID(18)) + PDS(20) = CHAR(ID(19)) + END IF + PDS(21) = CHAR(ID(20)) + PDS(22) = CHAR(MOD(ID(21)/256,256)) + PDS(23) = CHAR(MOD(ID(21),256)) + PDS(24) = CHAR(ID(22)) + PDS(25) = CHAR(ID(23)) + PDS(26) = CHAR(ID(24)) + ISCALE = ID(25) + IF (ISCALE.LT.0) THEN + ISCALE = -ISCALE + ISCALE = IOR(ISCALE,32768) + END IF + PDS(27) = CHAR(MOD(ISCALE/256,256)) + PDS(28) = CHAR(MOD(ISCALE ,256)) + IF (ID(1).GT.28) THEN + PDS(29) = CHAR(ID(26)) + PDS(30) = CHAR(ID(27)) + END IF +C +C SET PDS 31-?? TO ZERO +C + IF (ID(1).GT.30) THEN + K = ID(1) + DO I = 31,K + PDS(I) = CHAR(0) + END DO + END IF +C + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi71.f b/WPS/ungrib/src/ngl/w3/w3fi71.f new file mode 100755 index 00000000..94ff0357 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi71.f @@ -0,0 +1,1768 @@ + SUBROUTINE W3FI71 (IGRID, IGDS, IERR) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI71 MAKE ARRAY USED BY GRIB PACKER FOR GDS +C PRGMMR: R.E.JONES ORG: W/NMC42 DATE: 93-03-26 +C +C ABSTRACT: W3FI71 MAKES A 18, 37, 55, 64, OR 91 WORD INTEGER ARRAY +C USED BY W3FI72 GRIB PACKER TO MAKE THE GRID DESCRIPTION SECTION +C (GDS) - SECTION 2. +C +C PROGRAM HISTORY LOG: +C 92-02-21 R.E.JONES +C 92-07-01 M. FARLEY ADDED REMARKS FOR 'IGDS' ARRAY ELEMENTS. +C ADDED LAMBERT CONFORMAL GRIDS AND ENLARGED +C IDGS ARRAY FROM 14 TO 18 WORDS. +C 92-10-03 R.E.JONES ADDED CORRECTIONS TO AWIPS GRIB TABLES +C 92-10-16 R.E.JONES ADD GAUSSIAN GRID 126 TO TABLES +C 92-10-18 R.E.JONES CORRECTIONS TO LAMBERT CONFORMAL TABLES +C AND OTHER TABLES +C 92-10-19 R.E.JONES ADD GAUSSIAN GRID 98 TO TABLES +C 93-01-25 R.E.JONES ADD ON84 GRIDS 87, 106, 107 TO TABLES +C 93-03-10 R.E.JONES ADD ON84 GRIDS 1, 55, 56 TO TABLES +C 93-03-26 R.E.JONES ADD GRIB GRIDS 2, 3 TO TABLES +C 93-03-29 R.E.JONES ADD SAVE STATEMENT +C 93-06-15 R.E.JONES ADD GRIB GRIDS 37 TO 44 TO TABLES +C 93-09-29 R.E.JONES GAUSSIAN GRID DOCUMENT NOT CORRECT, +C W3FI74 WILL BE CHANGED TO AGREE WITH +C IT. GAUSSIAN GRID 98 TABLE HAS WRONG +C VALUE. +C 93-10-12 R.E.JONES CHANGES FOR ON388 REV. OCT 8,1993 FOR +C GRID 204, 208. +C 93-10-13 R.E.JONES CORRECTION FOR GRIDS 37-44, BYTES 7-8, +C 24-25 SET TO ALL BITS 1 FOR MISSING. +C 93-11-23 R.E.JONES ADD GRIDS 90-93 FOR ETA MODEL +C ADD GRID 4 FOR 720*361 .5 DEG. GRID +C 94-04-12 R.E.JONES CORRECTION FOR GRID 28 +C 94-06-01 R.E.JONES ADD GRID 45, 288*145 1.25 DEG. GRID +C 94-06-22 R.E.JONES ADD GRIDS 94, 95 FOR ETA MODEL +C 95-04-11 R.E.JONES ADD GRIDS 96, 97 FOR ETA MODEL +C 95-05-19 R.E.JONES ADD FROM 20 KM ETA MODEL AWIPS GRID 215 +C 95-10-19 R.E.JONES ADD FROM 20 KM ETA MODEL ALASKA GRID 216 +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 96-05-08 IREDELL CORRECT FIRST LATITUDE FOR GRIDS 27 AND 28 +C 96-07-02 R.E.JONES ADD FROM 10 KM ETA MODEL OLYMPIC GRID 218 +C 96-07-02 R.E.JONES ADD 196 FOR ETA MODEL +C 96-08-15 R.E.JONES ADD O.N. 84 GRID 8 AND 53 AS GRIB GRID 8 +C AND 53 +C 96-11-29 R.E.JONES CORRECTION TO TABLES FOR GRID 21-26, 61-64 +C 97-01-31 IREDELL CORRECT FIRST LATITUDE FOR GRID 30 +C 97-10-20 IREDELL CORRECT LAST LONGITUDE FOR GRID 98 +C 98-07-07 Gilbert Add grids 217 and 219 through 235 +C 98-09-21 BALDWIN ADD GRIDS 190, 192 FOR ETA MODEL +C 99-01-20 BALDWIN ADD GRIDS 236, 237 +C 99-08-18 IREDELL ADD GRID 170 +C 01-03-08 ROGERS CHANGED ETA GRIDS 90-97, ADDED ETA GRIDS +C 194, 198. ADDED AWIPS GRIDS 241,242,243, +C 245, 246, 247, 248, AND 250 +C 01-03-19 VUONG ADDED AWIPS GRIDS 238,239,240, AND 244 +C 01-04-02 VUONG CORRECT LAST LONGITUDE FOR GRID 225 +C 01-05-03 ROGERS ADDED GRID 249 +C 01-10-10 ROGERS REDEFINED 218 FOR 12-KM ETA +C REDEFINED GRID 192 FOR NEW 32-KM ETA GRID +C 02-03-27 VUONG ADDED RSAS GRID 88 AND AWIPS GRIDS 251 AND 252 +C 02-08-06 ROGERS REDEFINED GRIDS 90-93,97,194,245-250 FOR THE +C 8KM HI-RES-WINDOW MODEL AND ADD AWIPS GRID 253 +C 2003-06-30 GILBERT ADDED GRIDS 145 and 146 for CMAQ +C and GRID 175 for AWIPS over GUAM. +C 2003-07-08 VUONG CORRECTED LATITUDE FOR GRID 253 AND 170, ADD GRID +C 110, 127, 171 AND 172 +C 2004-08-05 VUONG CORRECTED LATITUDE FOR GRID 253 +C 2004-09-01 GILBERT Corrected the orientation and projection center flag +C for southern hemisphere grids 28, 172, 220 and 224 +C 2004-09-02 VUONG ADDED GRIDS 147, 148, 173 AND 254 +C 2005-01-04 COOKE Added grids 160, 161 and corrected longitude of orientation for grid 172 +C 2005-03-03 VUONG MOVED GRID 170 TO GRID 174 AND ADD GRID 170 +C 2005-03-21 VUONG ADDED GRIDS 130 +C 2005-09-12 VUONG ADDED GRIDS 163 +C 2006-10-27 VUONG CORRECTED X AND Y-DIRECTION GRID LENGTH FOR GRIDS 252 +C 2006-11-16 VUONG CHANGED THE LONGITUDE FROM NEGATIVE TO POSITIVE DEGREE FOR GRIDS 252 +C 2006-12-12 VUONG CHANGED DATA REPRESENTATION TYPE (OCTET 6) FROM 0 TO 1 FOR GRID 254 +C ADD GRID 120 (CURVILINEAR ORTHOGONAL GRID) +C 2006-12-27 VUONG CORRECTED THE LAT/LON DIRECTION INCREMENT FOR GRID 160 +C 2007-03-21 VUONG CORRECTED THE LAT/LON DIRECTION INCREMENT, RESOULUTION, +C SCANNING MODE FOR GRID 235 AND GRID TYPE 204 FOR GRID 120 +C 2007-04-24 VUONG CORRECTED THE LAT/LON DIRECTION INCREMENT, RESOULUTION, +C FOR GRIDS (219,173,220,171,233,238,239,244,253) AND ADDED +C GRID 176. +C 2007-06-11 VUONG ADDED NEW GRIDS (11,12,13,14,15,16,18,122,123,124,125,138 +C 180, 181, 182, 183) AND CORRECTED THE LAT/LON DIRECTION +C INCREMENT FOR GRID 240. +C 2007-11-06 VUONG CORRECTED THE SCANNING MODE FOR GRIDS (11,12,13,14,15,16,18) +C CHANGED GRID 198 FROM ARAKAWA STAGGERED E-GRID TO POLAR +C STEREOGRAPHIC GRID ADDED NEW GRID 10, 99, 150, 151, 197 +C 2008-01-17 VUONG ADDED NEW GRID 195 AND CHANGED GRID 196 (ARAKAWA-E TO MERCATOR) +C 2010-02-15 VUONG MODIFIED TO CORRECT LATITUDE FOR GRID 151 AND ADDED +C 2010-06-01 VUONG MODIFIED TO CORRECT LATITUDE AND LONGITUDE FOR GRID 196 +C 2010-08-05 VUONG ADDED NEW GRID 184, 199, 83 AND +C REDEFINED GRID 90 FOR NEW RTMA CONUS 1.27-KM +C REDEFINED GRID 91 FOR NEW RTMA ALASKA 2.976-KM +C REDEFINED GRID 92 FOR NEW RTMA ALASKA 1.488-KM +C 2010-09-08 ROGERS CHANGED GRID 94 TO ALASKA 6KM STAGGERED B-GRID +C CHANGED GRID 95 TO PUERTO RICO 3KM STAGGERED B-GRID +C CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID +C CHANGED GRID 96 TO HAWAII 3KM STAGGERED B-GRID +C CHANGED GRID 97 TO CONUS 4KM STAGGERED B-GRID +C CHANGED GRID 99 TO NAM 12KM STAGGERED B-GRID +C ADDED GRID 179 (12 KM POLAR STEREOGRAPHIC OVER NORTH AMERICA) +C CHANGED GRID 194 TO 3KM MERCATOR GRID OVER PUERTO RICO +C CORRECTED LATITUDE OF SW CORNER POINT OF GRID 151 +C 2011-10-12 VUONG ADDED GRID 129, 187, 188, 189 and 193 +C 2012-04-16 VUONG ADDED GRID 132, 200 +C +C USAGE: CALL W3FI71 (IGRID, IGDS, IERR) +C INPUT ARGUMENT LIST: +C IGRID - GRIB GRID NUMBER, OR OFFICE NOTE 84 GRID NUMBER +C +C OUTPUT ARGUMENT LIST: +C IGDS - 18, 37, 55, 64, OR 91 WORD INTEGER ARRAY WITH +C INFORMATION TO MAKE A GRIB GRID DESCRIPTION SECTION. +C IERR - 0 CORRECT EXIT +C 1 GRID TYPE IN IGRID IS NOT IN TABLE +C +C REMARKS: +C 1) OFFICE NOTE GRID TYPE 26 IS 6 IN GRIB, 26 IS AN +C INTERNATIONAL EXCHANGE GRID. +C +C 2) VALUES RETURNED IN 18, 37, 55, 64, OR 91 WORD INTEGER ARRAY +C IGDS VARY DEPENDING ON GRID REPRESENTATION TYPE. +C +C LAT/LON GRID: +C IGDS( 1) = NUMBER OF VERTICAL COORDINATES +C IGDS( 2) = PV, PL OR 255 +C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) +C IGDS( 4) = NO. OF POINTS ALONG A LATITUDE +C IGDS( 5) = NO. OF POINTS ALONG A LONGITUDE MERIDIAN +C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH - IVE) +C IGDS( 7) = LONGITUDE OF ORIGIN (WEST -IVE) +C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) +C IGDS( 9) = LATITUDE OF EXTREME POINT (SOUTH - IVE) +C IGDS(10) = LONGITUDE OF EXTREME POINT (WEST - IVE) +C IGDS(11) = LATITUDE INCREMENT +C IGDS(12) = LONGITUDE INCREMENT +C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) +C IGDS(14) = ... THROUGH ... +C IGDS(18) = ... NOT USED FOR THIS GRID +C IGDS(19) - IGDS(91) FOR GRIDS 37-44, NUMBER OF POINTS +C IN EACH OF 73 ROWS. +C +C GAUSSIAN GRID: +C IGDS( 1) = ... THROUGH ... +C IGDS(10) = ... SAME AS LAT/LON GRID +C IGDS(11) = NUMBER OF LATITUDE LINES BETWEEN A POLE +C AND THE EQUATOR +C IGDS(12) = LONGITUDE INCREMENT +C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) +C IGDS(14) = ... THROUGH ... +C IGDS(18) = ... NOT USED FOR THIS GRID +C +C SPHERICAL HARMONICS: +C IGDS( 1) = NUMBER OF VERTICAL COORDINATES +C IGDS( 2) = PV, PL OR 255 +C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) +C IGDS( 4) = J - PENTAGONAL RESOLUTION PARAMETER +C IGDS( 5) = K - PENTAGONAL RESOLUTION PARAMETER +C IGDS( 6) = M - PENTAGONAL RESOLUTION PARAMETER +C IGDS( 7) = REPRESENTATION TYPE (CODE TABLE 9) +C IGDS( 8) = REPRESENTATION MODE (CODE TABLE 10) +C IGDS( 9) = ... THROUGH ... +C IGDS(18) = ... NOT USED FOR THIS GRID +C +C POLAR STEREOGRAPHIC: +C IGDS( 1) = NUMBER OF VERTICAL COORDINATES +C IGDS( 2) = PV, PL OR 255 +C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) +C IGDS( 4) = NO. OF POINTS ALONG X-AXIS +C IGDS( 5) = NO. OF POINTS ALONG Y-AXIS +C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH -IVE) +C IGDS( 7) = LONGITUTE OF ORIGIN (WEST -IVE) +C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) +C IGDS( 9) = LONGITUDE OF MERIDIAN PARALLEL TO Y-AXIS +C IGDS(10) = X-DIRECTION GRID LENGTH (INCREMENT) +C IGDS(11) = Y-DIRECTION GRID LENGTH (INCREMENT) +C IGDS(12) = PROJECTION CENTER FLAG (0=NORTH POLE ON PLANE, +C 1=SOUTH POLE ON PLANE, +C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) +C IGDS(14) = ... THROUGH ... +C IGDS(18) = .. NOT USED FOR THIS GRID +C +C MERCATOR: +C IGDS( 1) = ... THROUGH ... +C IGDS(12) = ... SAME AS LAT/LON GRID +C IGDS(13) = LATITUDE AT WHICH PROJECTION CYLINDER +C INTERSECTS EARTH +C IGDS(14) = SCANNING MODE FLAGS +C IGDS(15) = ... THROUGH ... +C IGDS(18) = .. NOT USED FOR THIS GRID +C +C LAMBERT CONFORMAL: +C IGDS( 1) = NUMBER OF VERTICAL COORDINATES +C IGDS( 2) = PV, PL OR 255 +C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) +C IGDS( 4) = NO. OF POINTS ALONG X-AXIS +C IGDS( 5) = NO. OF POINTS ALONG Y-AXIS +C IGDS( 6) = LATITUDE OF ORIGIN (SOUTH -IVE) +C IGDS( 7) = LONGITUTE OF ORIGIN (WEST -IVE) +C IGDS( 8) = RESOLUTION FLAG (CODE TABLE 7) +C IGDS( 9) = LONGITUDE OF MERIDIAN PARALLEL TO Y-AXIS +C IGDS(10) = X-DIRECTION GRID LENGTH (INCREMENT) +C IGDS(11) = Y-DIRECTION GRID LENGTH (INCREMENT) +C IGDS(12) = PROJECTION CENTER FLAG (0=NORTH POLE ON PLANE, +C 1=SOUTH POLE ON PLANE, +C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) +C IGDS(14) = NOT USED +C IGDS(15) = FIRST LATITUDE FROM THE POLE AT WHICH THE +C SECANT CONE CUTS THE SPERICAL EARTH +C IGDS(16) = SECOND LATITUDE ... +C IGDS(17) = LATITUDE OF SOUTH POLE (MILLIDEGREES) +C IGDS(18) = LONGITUDE OF SOUTH POLE (MILLIDEGREES) +C +C ARAKAWA SEMI-STAGGERED E-GRID ON ROTATED LAT/LON GRID +C IGDS( 1) = NUMBER OF VERTICAL COORDINATES +C IGDS( 2) = PV, PL OR 255 +C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [201] +C IGDS( 4) = NI - TOTAL NUMBER OF ACTUAL DATA POINTS +C INCLUDED ON GRID +C IGDS( 5) = NJ - DUMMY SECOND DIMENSION; SET=1 +C IGDS( 6) = LA1 - LATITUDE OF FIRST GRID POINT +C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT +C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) +C IGDS( 9) = LA2 - NUMBER OF MASS POINTS ALONG +C SOUTHERNMOST ROW OF GRID +C IGDS(10) = LO2 - NUMBER OF ROWS IN EACH COLUMN +C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT +C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT +C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) +C IGDS(14) = ... THROUGH ... +C IGDS(18) = ... NOT USED FOR THIS GRID (SET TO ZERO) +C +C ARAKAWA FILLED E-GRID ON ROTATED LAT/LON GRID +C IGDS( 1) = NUMBER OF VERTICAL COORDINATES +C IGDS( 2) = PV, PL OR 255 +C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [202] +C IGDS( 4) = NI - TOTAL NUMBER OF ACTUAL DATA POINTS +C INCLUDED ON GRID +C IGDS( 5) = NJ - DUMMY SECOND DIMENTION; SET=1 +C IGDS( 6) = LA1 - LATITUDE LATITUDE OF FIRST GRID POINT +C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT +C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) +C IGDS( 9) = LA2 - NUMBER OF (ZONAL) POINTS IN EACH ROW +C IGDS(10) = LO2 - NUMBER OF (MERIDIONAL) POINTS IN EACH +C COLUMN +C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT +C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT +C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) +C IGDS(14) = ... THROUGH ... +C IGDS(18) = ... NOT USED FOR THIS GRID +C +C ARAKAWA STAGGERED E-GRID ON ROTATED LAT/LON GRID +C IGDS( 1) = NUMBER OF VERTICAL COORDINATES +C IGDS( 2) = PV, PL OR 255 +C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [203] +C IGDS( 4) = NI - NUMBER OF DATA POINTS IN EACH ROW +C IGDS( 5) = NJ - NUMBER OF ROWS +C IGDS( 6) = LA1 - LATITUDE OF FIRST GRID POINT +C IGDS( 7) = LO1 - LONGITUDE OF FIRST GRID POINT +C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) +C IGDS( 9) = LA2 - CENTRAL LATITUDE +C IGDS(10) = LO2 - CENTRAL LONGTITUDE +C IGDS(11) = DI - LONGITUDINAL DIRECTION INCREMENT +C IGDS(12) = DJ - LATITUDINAL DIRECTION INCREMENT +C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) +C IGDS(14) = ... THROUGH ... +C IGDS(18) = ... NOT USED FOR THIS GRID +C +C CURVILINEAR ORTHOGONAL GRID +C IGDS( 1) = NUMBER OF VERTICAL COORDINATES +C IGDS( 2) = PV, PL OR 255 +C IGDS( 3) = DATA REPRESENTATION TYPE (CODE TABLE 6) [204] +C IGDS( 4) = NI - NUMBER OF DATA POINTS IN EACH ROW +C IGDS( 5) = NJ - NUMBER OF ROWS +C IGDS( 6) = RESERVED (SET TO 0) +C IGDS( 7) = RESERVED (SET TO 0) +C IGDS( 8) = RESOLUTION AND COMPONENT FLAG (CODE TABLE 7) +C IGDS( 9) = RESERVED (SET TO 0) +C IGDS(10) = RESERVED (SET TO 0) +C IGDS(11) = RESERVED (SET TO 0) +C IGDS(12) = RESERVED (SET TO 0) +C IGDS(13) = SCANNING MODE FLAGS (CODE TABLE 8) +C IGDS(14) = ... THROUGH ... +C IGDS(18) = ... NOT USED FOR THIS GRID +C +C SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C MACHINE: IBM SP +C +C$$$ +C + INTEGER IGRID + INTEGER IGDS (*) + INTEGER GRD1 (18) + INTEGER GRD2 (18) + INTEGER GRD3 (18) + INTEGER GRD4 (18) + INTEGER GRD5 (18) + INTEGER GRD6 (18) + INTEGER GRD8 (18) + INTEGER GRD10 (18) + INTEGER GRD11 (18) + INTEGER GRD12 (18) + INTEGER GRD13 (18) + INTEGER GRD14 (18) + INTEGER GRD15 (18) + INTEGER GRD16 (18) + INTEGER GRD17 (18) + INTEGER GRD18 (18) + INTEGER GRD21 (55) + INTEGER GRD22 (55) + INTEGER GRD23 (55) + INTEGER GRD24 (55) + INTEGER GRD25 (37) + INTEGER GRD26 (37) + INTEGER GRD27 (18) + INTEGER GRD28 (18) + INTEGER GRD29 (18) + INTEGER GRD30 (18) + INTEGER GRD33 (18) + INTEGER GRD34 (18) + INTEGER GRD37 (91) + INTEGER GRD38 (91) + INTEGER GRD39 (91) + INTEGER GRD40 (91) + INTEGER GRD41 (91) + INTEGER GRD42 (91) + INTEGER GRD43 (91) + INTEGER GRD44 (91) + INTEGER GRD45 (18) + INTEGER GRD53 (18) + INTEGER GRD55 (18) + INTEGER GRD56 (18) + INTEGER GRD61 (64) + INTEGER GRD62 (64) + INTEGER GRD63 (64) + INTEGER GRD64 (64) + INTEGER GRD83 (18) + INTEGER GRD85 (18) + INTEGER GRD86 (18) + INTEGER GRD87 (18) + INTEGER GRD88 (18) + INTEGER GRD90 (18) + INTEGER GRD91 (18) + INTEGER GRD92 (18) + INTEGER GRD93 (18) + INTEGER GRD94 (18) + INTEGER GRD95 (18) + INTEGER GRD96 (18) + INTEGER GRD97 (18) + INTEGER GRD98 (18) + INTEGER GRD99 (18) + INTEGER GRD100(18) + INTEGER GRD101(18) + INTEGER GRD103(18) + INTEGER GRD104(18) + INTEGER GRD105(18) + INTEGER GRD106(18) + INTEGER GRD107(18) + INTEGER GRD110(18) + INTEGER GRD120(18) + INTEGER GRD122(18) + INTEGER GRD123(18) + INTEGER GRD124(18) + INTEGER GRD125(18) + INTEGER GRD126(18) + INTEGER GRD127(18) + INTEGER GRD128(18) + INTEGER GRD129(18) + INTEGER GRD130(18) + INTEGER GRD132(18) + INTEGER GRD138(18) + INTEGER GRD139(18) + INTEGER GRD140(18) + INTEGER GRD145(18) + INTEGER GRD146(18) + INTEGER GRD147(18) + INTEGER GRD148(18) + INTEGER GRD150(18) + INTEGER GRD151(18) + INTEGER GRD160(18) + INTEGER GRD161(18) + INTEGER GRD163(18) + INTEGER GRD170(18) + INTEGER GRD171(18) + INTEGER GRD172(18) + INTEGER GRD173(18) + INTEGER GRD174(18) + INTEGER GRD175(18) + INTEGER GRD176(18) + INTEGER GRD179(18) + INTEGER GRD180(18) + INTEGER GRD181(18) + INTEGER GRD182(18) + INTEGER GRD183(18) + INTEGER GRD184(18) + INTEGER GRD187(18) + INTEGER GRD188(18) + INTEGER GRD189(18) + INTEGER GRD190(18) + INTEGER GRD192(18) + INTEGER GRD193(18) + INTEGER GRD194(18) + INTEGER GRD195(18) + INTEGER GRD196(18) + INTEGER GRD197(18) + INTEGER GRD198(18) + INTEGER GRD199(18) + INTEGER GRD200(18) + INTEGER GRD201(18) + INTEGER GRD202(18) + INTEGER GRD203(18) + INTEGER GRD204(18) + INTEGER GRD205(18) + INTEGER GRD206(18) + INTEGER GRD207(18) + INTEGER GRD208(18) + INTEGER GRD209(18) + INTEGER GRD210(18) + INTEGER GRD211(18) + INTEGER GRD212(18) + INTEGER GRD213(18) + INTEGER GRD214(18) + INTEGER GRD215(18) + INTEGER GRD216(18) + INTEGER GRD217(18) + INTEGER GRD218(18) + INTEGER GRD219(18) + INTEGER GRD220(18) + INTEGER GRD221(18) + INTEGER GRD222(18) + INTEGER GRD223(18) + INTEGER GRD224(18) + INTEGER GRD225(18) + INTEGER GRD226(18) + INTEGER GRD227(18) + INTEGER GRD228(18) + INTEGER GRD229(18) + INTEGER GRD230(18) + INTEGER GRD231(18) + INTEGER GRD232(18) + INTEGER GRD233(18) + INTEGER GRD234(18) + INTEGER GRD235(18) + INTEGER GRD236(18) + INTEGER GRD237(18) + INTEGER GRD238(18) + INTEGER GRD239(18) + INTEGER GRD240(18) + INTEGER GRD241(18) + INTEGER GRD242(18) + INTEGER GRD243(18) + INTEGER GRD244(18) + INTEGER GRD245(18) + INTEGER GRD246(18) + INTEGER GRD247(18) + INTEGER GRD248(18) + INTEGER GRD249(18) + INTEGER GRD250(18) + INTEGER GRD251(18) + INTEGER GRD252(18) + INTEGER GRD253(18) + INTEGER GRD254(18) +C + DATA GRD1 / 0, 255, 1, 73, 23, -48090, 0, 128, 48090, + & 0, 513669,513669, 22500, 64, 0, 0, 0, 0/ + DATA GRD2 / 0, 255, 0, 144, 73, 90000, 0, 128, -90000, + & -2500, 2500, 2500, 0, 0, 0, 0, 0, 0/ + DATA GRD3 / 0, 255, 0, 360,181, 90000, 0, 128, -90000, + & -1000, 1000, 1000, 0, 0, 0, 0, 0, 0/ + DATA GRD4 / 0, 255, 0, 720,361, 90000, 0, 128, -90000, + & -500, 500, 500, 0, 0, 0, 0, 0, 0/ + DATA GRD5 / 0, 255, 5, 53, 57, 7647, -133443, 8, -105000, + & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD6 / 0, 255, 5, 53, 45, 7647, -133443, 8, -105000, + & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD8 / 0, 255, 1, 116, 44, -48670, 3104, 128, 61050, + & 0, 318830, 318830, 22500, 64, 0, 0, 0, 0/ + DATA GRD10 / 0, 255, 0, 180, 139, 64000, 1000, 128, -74000, + & 359000, 1000, 2000, 0, 0, 0, 0, 0, 0/ + DATA GRD11 / 0, 255, 0, 720, 311, 77500, 0, 128, -77500, + & 359500, 500, 500, 0, 0, 0, 0, 0, 0/ + DATA GRD12 / 0, 255, 0, 301, 331, 55000, 260000, 128, 0, + & 310000, 166, 166, 0, 0, 0, 0, 0, 0/ + DATA GRD13 / 0, 255, 0, 241, 151, 50000, 210000, 128, 25000, + & 250000, 166, 166, 0, 0, 0, 0, 0, 0/ + DATA GRD14 / 0, 255, 0, 511, 301, 30000, 130000, 128, -20000, + & 215000, 166, 166, 0, 0, 0, 0, 0, 0/ + DATA GRD15 / 0, 255, 0, 401, 187, 75000, 140000, 128, 44000, + & 240000, 166, 250, 0, 0, 0, 0, 0, 0/ + DATA GRD16 / 0, 255, 0, 548, 391, 74000, 165000, 128, 48000, + & 237933, 66, 133, 0, 0, 0, 0, 0, 0/ + DATA GRD17 / 0, 255, 0, 736, 526, 50000, 195000, 128, 15000, + & 244000, 66, 66, 0, 0, 0, 0, 0, 0/ + DATA GRD18 / 0, 255, 0, 586, 481, 47000, 261000, 128, 15000, + & 300000, 66, 66, 0, 0, 0, 0, 0, 0/ + DATA GRD21 / 0, 33, 0,65535,37, 0, 0, 128, 90000, + & 180000, 2500, 5000, 64, 0, 0, 0, 0, 0, + & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + & 37, 37, 37, 37, 37, 37, 1/ + DATA GRD22 / 0, 33, 0,65535,37, 0, -180000, 128, 90000, + & 0, 2500, 5000, 64, 0, 0, 0, 0, 0, + & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + & 37, 37, 37, 37, 37, 37, 1/ + DATA GRD23 / 0, 33, 0,65535, 37, -90000, 0, 128, 0, + & 180000, 2500, 5000, 64, 0, 0, 0, 0, 0, + & 1, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + & 37, 37, 37, 37, 37, 37, 37/ + DATA GRD24 / 0, 33, 0,65535, 37, -90000, -180000, 128, 0, + & 0, 2500, 5000, 64, 0, 0, 0, 0, 0, + & 1, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + & 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + & 37, 37, 37, 37, 37, 37, 37/ + DATA GRD25 / 0, 33, 0,65535, 19, 0, 0, 128, 90000, + & 355000, 5000, 5000, 64, 0, 0, 0, 0, 0, + & 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, + & 72, 72, 72, 1/ + DATA GRD26 / 0, 33, 0,65535, 19, -90000, 0, 128, 0, + & 355000, 5000, 5000, 64, 0, 0, 0, 0, 0, + & 1, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, 72, + & 72, 72, 72, 72/ + DATA GRD27 / 0, 255, 5, 65, 65, -20826, -125000, 8, -80000, + & 381000, 381000, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD28 / 0, 255, 5, 65, 65, 20826, 145000, 8, -80000, + & 381000, 381000,128, 64, 0, 0, 0, 0, 0/ + DATA GRD29 / 0, 255, 0, 145, 37, 0, 0, 128, 90000, + & 360000, 2500, 2500, 64, 0, 0, 0, 0, 0/ + DATA GRD30 / 0, 255, 0, 145, 37, -90000, 0, 128, 0, + & 360000, 2500, 2500, 64, 0, 0, 0, 0, 0/ + DATA GRD33 / 0, 255, 0, 181, 46, 0, 0, 128, 90000, + & 360000, 2000, 2000, 64, 0, 0, 0, 0, 0/ + DATA GRD34 / 0, 255, 0, 181, 46, -90000, 0, 128, 0, + & 360000, 2000, 2000, 64, 0, 0, 0, 0, 0/ + DATA GRD37 / 0, 33, 0,65535,73, 0, -30000, 128, 90000, + & 60000, 1250,65535, 64, 0, 0, 0, 0, 0, + & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, + & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, + & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, + & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, + & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ + DATA GRD38 / 0, 33, 0,65535,73, 0, 60000, 128, 90000, + & 150000, 1250,65535, 64, 0, 0, 0, 0, 0, + & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, + & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, + & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, + & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, + & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ + DATA GRD39 / 0, 33, 0,65535,73, 0, 150000, 128, 90000, + & -120000, 1250,65535, 64, 0, 0, 0, 0, 0, + & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, + & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, + & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, + & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, + & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ + DATA GRD40 / 0, 33, 0,65535,73, 0, -120000, 128, 90000, + & -30000, 1250,65535, 64, 0, 0, 0, 0, 0, + & 73, 73, 73, 73, 73, 73, 73, 73, 72, 72, 72, 71, 71, 71, 70, + & 70, 69, 69, 68, 67, 67, 66, 65, 65, 64, 63, 62, 61, 60, 60, + & 59, 58, 57, 56, 55, 54, 52, 51, 50, 49, 48, 47, 45, 44, 43, + & 42, 40, 39, 38, 36, 35, 33, 32, 30, 29, 28, 26, 25, 23, 22, + & 20, 19, 17, 16, 14, 12, 11, 9, 8, 6, 5, 3, 2/ + DATA GRD41 / 0, 33, 0,65535,73, -90000, -30000, 128, 0, + & 60000, 1250,65535, 64, 0, 0, 0, 0, 0, + & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, + & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, + & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, + & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, + & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ + DATA GRD42 / 0, 33, 0,65535,73, -90000, 60000, 128, 0, + & 150000, 1250,65535, 64, 0, 0, 0, 0, 0, + & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, + & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, + & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, + & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, + & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ + DATA GRD43 / 0, 33, 0,65535,73, -90000, 150000, 128, 0, + & -120000, 1250,65535, 64, 0, 0, 0, 0, 0, + & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, + & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, + & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, + & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, + & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ + DATA GRD44 / 0, 33, 0,65535,73, -90000, -120000, 128, 0, + & -30000, 1250,65535, 64, 0, 0, 0, 0, 0, + & 2, 3, 5, 6, 8, 9, 11, 12, 14, 16, 17, 19, 20, 22, 23, + & 25, 26, 28, 29, 30, 32, 33, 35, 36, 38, 39, 40, 42, 43, 44, + & 45, 47, 48, 49, 50, 51, 52, 54, 55, 56, 57, 58, 59, 60, 60, + & 61, 62, 63, 64, 65, 65, 66, 67, 67, 68, 69, 69, 70, 70, 71, + & 71, 71, 72, 72, 72, 73, 73, 73, 73, 73, 73, 73, 73/ + DATA GRD45 / 0, 255, 0, 288,145, 90000, 0, 128, -90000, + & -1250, 1250, 1250, 0, 0, 0, 0, 0, 0/ + DATA GRD53 / 0, 255, 1, 117, 51, -61050, 0, 128, 61050, + & 0, 318830, 318830, 22500, 64, 0, 0, 0, 0/ + DATA GRD55 / 0, 255, 5, 87, 71, -10947, -154289, 8, -105000, + & 254000, 254000, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD56 / 0, 255, 5, 87, 71, 7647, -133443, 8, -105000, + & 127000, 127000, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD61 / 0, 33, 0,65535, 46, 0, 0, 128, 90000, + & 180000, 2000, 2000, 64, 0, 0, 0, 0, 0, + & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 1/ + DATA GRD62 / 0, 33, 0,65535, 46, 0, -180000, 128, 90000, + & 0, 2000, 2000, 64, 0, 0, 0, 0, 0, + & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 1/ + DATA GRD63 / 0, 33, 0,65535, 46, 0, -90000, 128, 0, + & 180000, 2000, 2000, 64, 0, 0, 0, 0, 0, + & 1, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 91/ + DATA GRD64 / 0, 33, 0,65535, 46, -90000, -180000, 128, 0, + & 0, 2000, 2000, 64, 0, 0, 0, 0, 0, + & 1, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, 91, + & 91/ + DATA GRD83 / 0, 255,205,758,567, 2228, -140481, 136, 47500, + & -104000, 121,121,64, 53492, -10984, 0, 0, 0/ + DATA GRD85 / 0, 255, 0, 360, 90, 500, 500, 128, 89500, + & 359500, 1000, 1000, 64, 0, 0, 0, 0, 0/ + DATA GRD86 / 0, 255, 0, 360, 90, -89500, 500, 128, -500, + & 359500, 1000, 1000, 64, 0, 0, 0, 0, 0/ + DATA GRD87 / 0, 255, 5, 81, 62, 22876, -120491, 8, -105000, + & 68153, 68153, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD88 / 0, 255, 5, 580,548, 10000, -128000, 8, -105000, + & 15000, 15000, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD90 / 0, 255, 3,4289,2753, 20192, -121554, 8, -95000, + & 1270, 1270, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD91 / 0, 255, 5,1649,1105, 40530, -178571, 8, -150000, + & 2976, 2976, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD92 / 0, 255, 5,3297,2209, 40530, -178571, 8, -150000, + & 1488, 1488, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD93 / 0, 255,203,223,501, 44232, -169996, 136, 63000, + & -150000, 67,66,64, 0, 0, 0, 0, 0/ + DATA GRD94 / 0, 255,205,595,625, 34921, -161663, 136, 54000, + & -106000, 63, 54,64, 83771, -151721, 0, 0, 0/ + DATA GRD95 / 0, 255,205,401,325, 17609, -76327, 136, 54000, + & -106000, 31, 27,64, 18840, -61261, 0, 0, 0/ + DATA GRD96 / 0, 255,205,373,561, 11625, -156339, 136, 54000, + & -106000, 31, 27,64, 30429, -157827, 0, 0, 0/ + DATA GRD97 / 0, 255,205,1371,1100, 15947,-125468, 136, 54000, + & -106000, 42, 36,64,45407,-52390, 0, 0, 0/ + DATA GRD98 / 0, 255, 4, 192, 94, 88542, 0, 128, -88542, + & -1875, 47,1875, 0, 0, 0, 0, 0, 0/ + DATA GRD99 / 0, 255,203,669,1165, -7450, -144140, 136, 54000, + & -106000, 90, 77, 64, 0, 0, 0, 0, 0/ + DATA GRD100/ 0, 255, 5, 83, 83, 17108, -129296, 8, -105000, + & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD101/ 0, 255, 5, 113, 91, 10528, -137146, 8, -105000, + & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD103/ 0, 255, 5, 65, 56, 22405, -121352, 8, -105000, + & 91452, 91452, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD104/ 0, 255, 5, 147,110, -268, -139475, 8, -105000, + & 90755, 90755, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD105/ 0, 255, 5, 83, 83, 17529, -129296, 8, -105000, + & 90755, 90755, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD106/ 0, 255, 5, 165,117, 17533, -129296, 8, -105000, + & 45373, 45373, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD107/ 0, 255, 5, 120, 92, 23438, -120168, 8, -105000, + & 45373, 45373, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD110/ 0, 255, 0, 464,224, 25063, -124938, 128, 52938, + & -67063, 125, 125, 64, 0, 0, 0, 0, 0/ + DATA GRD120/ 0, 255,204,1200,1684, 0, 0, 8, 0, + & 0, 0, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD122/ 0, 255,204, 350, 465, 0, 0, 8, 0, + & 0, 0, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD123/ 0, 255,204, 280, 360, 0, 0, 8, 0, + & 0, 0, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD124/ 0, 255,204, 240, 314, 0, 0, 8, 0, + & 0, 0, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD125/ 0, 255,204, 300, 340, 0, 0, 8, 0, + & 0, 0, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD126/ 0, 255, 4, 384,190, 89277, 0, 128, -89277, + & -938, 95, 938, 0, 0, 0, 0, 0, 0/ + DATA GRD127/ 0, 255, 4, 768,384, 89642, 0, 128, -89642, + & -469, 192, 469, 0, 0, 0, 0, 0, 0/ + DATA GRD128/ 0, 255, 4,1152,576, 89761, 0, 128, -89761, + & -313, 288, 313, 0, 0, 0, 0, 0, 0/ + DATA GRD129/ 0, 255, 4,1760,880, 89844, 0, 128, -89844, + & -205, 440, 205, 0, 0, 0, 0, 0, 0/ + DATA GRD130/ 0, 255, 3, 451,337, 16281, -126138, 8, -95000, + & 13545, 13545, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD132/ 0, 255, 3, 697,553, 1000, -145500, 8, -107000, + & 16232, 16232, 0, 64, 0, 50000, 50000, 0, 0/ + DATA GRD138/ 0, 255, 3, 468,288, 21017, -123282, 8, -97000, + & 12000, 12000, 0, 64, 0, 33000, 45000, 0, 0/ + DATA GRD139/ 0, 255, 3, 80,52, 17721, -161973, 8, -157500, + & 12000, 12000, 0, 64, 0, 19000, 21000, 0, 0/ + DATA GRD140/ 0, 255, 3, 199,163, 53020, -166477, 8, -148600, + & 12000, 12000, 0, 64, 0, 57000, 63000, 0, 0/ + DATA GRD145/ 0, 255, 3, 169,145, 32174, -90159, 8, -79500, + & 12000, 12000, 0, 64, 0, 36000, 46000, 0, 0/ + DATA GRD146/ 0, 255, 3, 166,142, 32353, -89994, 8, -79500, + & 12000, 12000, 0, 64, 0, 36000, 46000, 0, 0/ + DATA GRD147/ 0, 255, 3, 268,259, 24595, -100998, 8, -97000, + & 12000, 12000, 0, 64, 0, 33000, 45000, 0, 0/ + DATA GRD148/ 0, 255, 3, 442,265, 21821, -120628, 8, -97000, + & 12000, 12000, 0, 64, 0, 33000, 45000, 0, 0/ + DATA GRD150/ 0, 255, 0, 401,201, 5000, -100000, 128, 25000, + & -60000, 100, 100, 64, 0, 0, 0, 0, 0/ + DATA GRD151/ 0, 255, 5, 478, 429, -7450, 215860, 8, -110000, + & 33812, 33812, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD160/ 0, 255, 5, 180,156, 19132, -185837, 8, -150000, + & 47625, 47625, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD161/ 0, 255, 0, 137,102, 50750, 271750, 72, -250, + & -19750, 500,500, 0, 0, 0, 0, 0, 0/ + DATA GRD163/ 0, 255, 3,1008,722, 20600, -118300, 8, -95000, + & 5000, 5000, 0, 64, 0, 38000, 38000, 0, 0/ + DATA GRD170/ 0, 255, 4, 512, 256, 89463, 0, 128, -89463, + & -703, 128, 703, 0, 0, 0, 0, 0, 0/ + DATA GRD171/ 0, 255, 5, 770,930, 25032, -119560, 0, -80000, + & 12700, 12700, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD172/ 0, 255, 5, 690,710, -36866, -220194, 0, -260000, + & 12700, 12700, 128, 64, 0, 0, 0, 0, 0/ + DATA GRD173/ 0, 255, 0,4320,2160, 89958, 42, 128, -89958, + & 359958, 83, 83, 0, 0, 0, 0, 0, 0/ + DATA GRD174/ 0, 255, 4,2880,1440, 89938, 62, 72, -89938, + & -62, 125, 125,64, 0, 0, 0, 0, 0/ + DATA GRD175/ 0, 255, 0, 556,334, 0, 130000, 128, 30060, + & 180040, 90, 90, 64, 0, 0, 0, 0, 0/ + DATA GRD176/ 0, 255, 0, 327,235, 49100, -92200, 128, 40910, + & -75900, 35, 50, 0, 0, 0, 0, 0, 0/ + DATA GRD179/ 0, 255, 5,1196,817, -2500, -142500, 8, -100000, + & 12679, 12679, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD180/ 0, 255, 0, 759,352, 55054, -127000, 128, 17146, + & -45136, 108, 108, 0, 0, 0, 0, 0, 0/ + DATA GRD181/ 0, 255, 0, 370,278, 30054, -100000, 128, 138, + & -60148, 108, 108, 0, 0, 0, 0, 0, 0/ + DATA GRD182/ 0, 255, 0, 278,231, 32973, -170000, 128, 8133, + & -140084, 108, 108, 0, 0, 0, 0, 0, 0/ + DATA GRD183/ 0, 255, 0, 648,278, 75054, -200000, 128, 45138, + & -130124, 108, 108, 0, 0, 0, 0, 0, 0/ + DATA GRD184/ 0, 255, 3,2145,1377, 20192, -121554, 8, -95000, + & 2540, 2540, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD187/ 0, 255, 3,2145,1597, 20192, -121554, 8, -95000, + & 2540, 2540, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD188/ 0, 255, 3, 709, 795, 37979, -125958, 8, -95000, + & 2540, 2540, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD189/ 0, 255, 5, 655, 855, 51500, -142500, 8, -135000, + & 1448, 1448, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD190/ 0, 255,205,954,835, -7491, -144134, 136, 54000, + & -106000, 126, 108, 64, 44540, 14802, 0, 0, 0/ + DATA GRD192/ 0, 255,203,237,387, -3441, -148799, 136, 50000, + & -111000, 225,207,64, 0, 0, 0, 0, 0/ + DATA GRD193 / 0, 255, 0, 1440, 721, 90000, 0, 128, -90000, + & -250, 250, 250, 0, 0, 0, 0, 0, 0/ + DATA GRD194/ 0, 255, 1, 544,310, 15000, -75500, 128, 22005, + & -62509, 2500, 2500, 20000, 64, 0, 0, 0, 0/ + DATA GRD195/ 0, 255, 1, 177,129, 16829, -68196, 128, 19747, + & -63972, 2500, 2500, 20000, 64, 0, 0, 0, 0/ + DATA GRD196/ 0, 255, 1, 321,225, 18073, -161525, 136, 23088, + & -153869, 2500, 2500, 20000, 64, 0, 0, 0, 0/ + DATA GRD197/ 0, 255, 3,1073,689, 20192, -121550, 8, -95000, + & 5079, 5079, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD198/ 0, 255, 5, 825, 553, 40530, -178571, 8, -150000, + & 5953, 5953, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD199/ 0, 255, 1, 193,193, 12350, -216313, 128, 16794, + & -211720, 2500, 2500, 20000, 64, 0, 0, 0, 0/ + DATA GRD200/ 0, 255, 3, 108, 94, 16201, 285720, 8, -107000, + & 16232, 16232, 0, 64, 0, 50000, 50000, 0, 0/ + DATA GRD201/ 0, 255, 5, 65, 65, -20826, -150000, 8, -105000, + & 381000, 381000, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD202/ 0, 255, 5, 65, 43, 7838, -141028, 8, -105000, + & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD203/ 0, 255, 5, 45, 39, 19132, -185837, 8, -150000, + & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD204/ 0, 255, 1, 93, 68, -25000, 110000, 128, 60644, + & -109129, 160000, 160000, 20000, 64, 0, 0, 0, 0/ + DATA GRD205/ 0, 255, 5, 45, 39, 616, -84904, 8, -60000, + & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD206/ 0, 255, 3, 51, 41, 22289, -117991, 8, - 95000, + & 81271, 81271, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD207/ 0, 255, 5, 49, 35, 42085, -175641, 8, -150000, + & 95250, 95250, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD208/ 0, 255, 1, 29, 27, 9343, -167315, 128, 28092, + & -145878, 80000, 80000, 20000, 64, 0, 0, 0, 0/ + DATA GRD209/ 0, 255, 3, 275,223, -4850, -151100, 8, -111000, + & 44000, 44000, 0, 64, 0, 45000, 45000, 0, 0/ + DATA GRD210/ 0, 255, 1, 25, 25, 9000, -77000, 128, 26422, + & -58625, 80000, 80000, 20000, 64, 0, 0, 0, 0/ + DATA GRD211/ 0, 255, 3, 93, 65, 12190, -133459, 8, -95000, + & 81271, 81271, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD212/ 0, 255, 3, 185,129, 12190, -133459, 8, -95000, + & 40635, 40635, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD213/ 0, 255, 5, 129, 85, 7838, -141028, 8, -105000, + & 95250, 95250, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD214/ 0, 255, 5, 97, 69, 42085, -175641, 8, -150000, + & 47625, 47625, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD215/ 0, 255, 3, 369,257, 12190, -133459, 8, -95000, + & 20318, 20318, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD216/ 0, 255, 5, 139,107, 30000, -173000, 8, -135000, + & 45000, 45000, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD217/ 0, 255, 5, 277,213, 30000, -173000, 8, -135000, + & 22500, 22500, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD218/ 0, 255, 3, 614,428, 12190, -133459, 8, -95000, + & 12191, 12191, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD219/ 0, 255, 5, 385,465, 25032, -119560, 0, -80000, + & 25400, 25400, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD220/ 0, 255, 5, 345,355, -36866, -220194, 0, -260000, + & 25400, 25400, 128, 64, 0, 0, 0, 0, 0/ + DATA GRD221/ 0, 255, 3, 349,277, 1000, -145500, 8, -107000, + & 32463, 32463, 0, 64, 0, 50000, 50000, 0, 0/ + DATA GRD222/ 0, 255, 3, 138,112, -4850, -151100, 8, -111000, + & 88000, 88000, 0, 64, 0, 45000, 45000, 0, 0/ + DATA GRD223/ 0, 255, 5, 129,129, -20826, -150000, 8, -105000, + & 190500, 190500, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD224/ 0, 255, 5, 65, 65, 20826, 120000, 8, -105000, + & 381000, 381000, 128, 64, 0, 0, 0, 0, 0/ + DATA GRD225/ 0, 255, 1, 185,135, -25000, -250000, 128, 60640, + & -109129, 80000, 80000, 20000, 64, 0, 0, 0, 0/ + DATA GRD226/ 0, 255, 3, 737,513, 12190, -133459, 8, -95000, + & 10159, 10159, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD227/ 0, 255, 3,1473,1025, 12190, -133459, 8, -95000, + & 5079, 5079, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD228/ 0, 255, 0, 144, 73, 90000, 0, 128, -90000, + & -2500, 2500, 2500, 64, 0, 0, 0, 0, 0/ + DATA GRD229/ 0, 255, 0, 360,181, 90000, 0, 128, -90000, + & -1000, 1000, 1000, 64, 0, 0, 0, 0, 0/ + DATA GRD230/ 0, 255, 0, 720,361, 90000, 0, 128, -90000, + & -500, 500, 500, 64, 0, 0, 0, 0, 0/ + DATA GRD231/ 0, 255, 0, 720,181, 0, 0, 128, 90000, + & -500, 500, 500, 64, 0, 0, 0, 0, 0/ + DATA GRD232/ 0, 255, 0, 360, 91, 0, 0, 128, 90000, + & -1000, 1000, 1000, 64, 0, 0, 0, 0, 0/ + DATA GRD233/ 0, 255, 0, 288,157, 78000, 0, 128, -78000, + & -1250, 1000, 1250, 0, 0, 0, 0, 0, 0/ + DATA GRD234/ 0, 255, 0, 133,121, 15000, -98000, 128, -45000, + & -65000, 250, 250, 64, 0, 0, 0, 0, 0/ + DATA GRD235/ 0, 255, 0, 720,360, 89750, 250, 128, -89750, + & -250, 500, 500, 0, 0, 0, 0, 0, 0/ + DATA GRD236/ 0, 255, 3, 151,113, 16281, 233862, 8, -95000, + & 40635, 40635, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD237/ 0, 255, 3, 54, 47, 16201, 285720, 8, -107000, + & 32463, 32463, 0, 64, 0, 50000, 50000, 0, 0/ + DATA GRD238/ 0, 255, 0, 275, 203, 50250, 261750, 128, -250, + & -29750, 250, 250, 0, 0, 0, 0, 0, 0/ + DATA GRD239/ 0, 255, 0, 155, 123, 75250, 159500, 128, 44750, + & -123500, 250, 500, 0, 0, 0, 0, 0, 0/ + DATA GRD240/ 0, 255, 5, 1121, 881, 23098, -119036, 8, -105000, + & 4763, 4763, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD241/ 0, 255, 3, 549,445, -4850, -151100, 8, -111000, + & 22000, 22000, 0, 64, 0, 45000, 45000, 0, 0/ + DATA GRD242/ 0, 255, 5, 553,425, 30000, -173000, 8, -135000, + & 11250, 11250, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD243/ 0, 255, 0, 126,101, 10000, -170000, 128, 50000, + & -120000, 400, 400, 64, 0, 0, 0, 0, 0/ + DATA GRD244/ 0, 255, 0, 275, 203, 50250, 261750, 128, -250, + & -29750, 250, 250, 0, 0, 0, 0, 0, 0/ + DATA GRD245/ 0, 255, 3, 336,372, 22980, -92840, 8, -80000, + & 8000, 8000, 0, 64, 0, 35000, 35000, 0, 0/ + DATA GRD246/ 0, 255, 3, 332,371, 25970, -127973, 8, -115000, + & 8000, 8000, 0, 64, 0, 40000, 40000, 0, 0/ + DATA GRD247/ 0, 255, 3, 336,372, 22980, -110840, 8, -98000, + & 8000, 8000, 0, 64, 0, 35000, 35000, 0, 0/ + DATA GRD248/ 0, 255, 0, 135,101, 14500, -71500, 128, 22000, + & -61450, 75, 75, 64, 0, 0, 0, 0, 0/ + DATA GRD249/ 0, 255, 5, 367,343, 45400, -171600, 8, -150000, + & 9868, 9868, 0, 64, 0, 0, 0, 0, 0/ + DATA GRD250/ 0, 255, 0, 135,101, 16500, -162000, 128, 24000, + & -151950, 75, 75, 64, 0, 0, 0, 0, 0/ + DATA GRD251/ 0, 255, 0, 332,210, 26350, -83050, 128, 47250, + & -49950, 100, 100, 64, 0, 0, 0, 0, 0/ + DATA GRD252/ 0, 255, 3, 301,225, 16281, 233862, 8, 265000, + & 20318, 20318, 0, 64, 0, 25000, 25000, 0, 0/ + DATA GRD253/ 0, 255, 0, 373,224, 60500, 189750, 128, 4750, + & -77250, 250, 250, 0, 0, 0, 0, 0, 0/ + DATA GRD254/ 0, 255, 1, 369,300, -35000, -250000, 128, 60789, + & -109129, 40000,40000, 20000, 64, 0, 0, 0, 0/ +C + IERR = 0 +C + DO 1 I = 1,18 + IGDS(I) = 0 + 1 CONTINUE +C + IF (IGRID.GE.37.AND.IGRID.LE.44) THEN + DO 2 I = 19,91 + IGDS(I) = 0 + 2 CONTINUE + END IF +C + IF (IGRID.GE.21.AND.IGRID.LE.24) THEN + DO I = 19,55 + IGDS(I) = 0 + END DO + END IF +C + IF (IGRID.GE.25.AND.IGRID.LE.26) THEN + DO I = 19,37 + IGDS(I) = 0 + END DO + END IF +C + IF (IGRID.GE.61.AND.IGRID.LE.64) THEN + DO I = 19,64 + IGDS(I) = 0 + END DO + END IF +C + IF (IGRID.EQ.1) THEN + DO 3 I = 1,18 + IGDS(I) = GRD1(I) + 3 CONTINUE +C + ELSE IF (IGRID.EQ.2) THEN + DO 4 I = 1,18 + IGDS(I) = GRD2(I) + 4 CONTINUE +C + ELSE IF (IGRID.EQ.3) THEN + DO 5 I = 1,18 + IGDS(I) = GRD3(I) + 5 CONTINUE +C + ELSE IF (IGRID.EQ.4) THEN + DO 6 I = 1,18 + IGDS(I) = GRD4(I) + 6 CONTINUE +C + ELSE IF (IGRID.EQ.5) THEN + DO 10 I = 1,18 + IGDS(I) = GRD5(I) + 10 CONTINUE +C + ELSE IF (IGRID.EQ.6) THEN + DO 20 I = 1,18 + IGDS(I) = GRD6(I) + 20 CONTINUE +C + ELSE IF (IGRID.EQ.8) THEN + DO I = 1,18 + IGDS(I) = GRD8(I) + END DO +C + ELSE IF (IGRID.EQ.10) THEN + DO I = 1,18 + IGDS(I) = GRD10(I) + END DO +C + ELSE IF (IGRID.EQ.11) THEN + DO I = 1,18 + IGDS(I) = GRD11(I) + END DO +C + ELSE IF (IGRID.EQ.12) THEN + DO I = 1,18 + IGDS(I) = GRD12(I) + END DO +C + ELSE IF (IGRID.EQ.13) THEN + DO I = 1,18 + IGDS(I) = GRD13(I) + END DO +C + ELSE IF (IGRID.EQ.14) THEN + DO I = 1,18 + IGDS(I) = GRD14(I) + END DO +C + ELSE IF (IGRID.EQ.15) THEN + DO I = 1,18 + IGDS(I) = GRD15(I) + END DO +C + ELSE IF (IGRID.EQ.16) THEN + DO I = 1,18 + IGDS(I) = GRD16(I) + END DO +C + ELSE IF (IGRID.EQ.17) THEN + DO I = 1,18 + IGDS(I) = GRD17(I) + END DO +C + ELSE IF (IGRID.EQ.18) THEN + DO I = 1,18 + IGDS(I) = GRD18(I) + END DO +C + ELSE IF (IGRID.EQ.21) THEN + DO 30 I = 1,55 + IGDS(I) = GRD21(I) + 30 CONTINUE +C + ELSE IF (IGRID.EQ.22) THEN + DO 40 I = 1,55 + IGDS(I) = GRD22(I) + 40 CONTINUE +C + ELSE IF (IGRID.EQ.23) THEN + DO 50 I = 1,55 + IGDS(I) = GRD23(I) + 50 CONTINUE +C + ELSE IF (IGRID.EQ.24) THEN + DO 60 I = 1,55 + IGDS(I) = GRD24(I) + 60 CONTINUE +C + ELSE IF (IGRID.EQ.25) THEN + DO 70 I = 1,37 + IGDS(I) = GRD25(I) + 70 CONTINUE +C + ELSE IF (IGRID.EQ.26) THEN + DO 80 I = 1,37 + IGDS(I) = GRD26(I) + 80 CONTINUE +C + ELSE IF (IGRID.EQ.27) THEN + DO 90 I = 1,18 + IGDS(I) = GRD27(I) + 90 CONTINUE +C + ELSE IF (IGRID.EQ.28) THEN + DO 100 I = 1,18 + IGDS(I) = GRD28(I) + 100 CONTINUE +C + ELSE IF (IGRID.EQ.29) THEN + DO 110 I = 1,18 + IGDS(I) = GRD29(I) + 110 CONTINUE +C + ELSE IF (IGRID.EQ.30) THEN + DO 120 I = 1,18 + IGDS(I) = GRD30(I) + 120 CONTINUE +C + ELSE IF (IGRID.EQ.33) THEN + DO 130 I = 1,18 + IGDS(I) = GRD33(I) + 130 CONTINUE +C + ELSE IF (IGRID.EQ.34) THEN + DO 140 I = 1,18 + IGDS(I) = GRD34(I) + 140 CONTINUE +C + ELSE IF (IGRID.EQ.37) THEN + DO 141 I = 1,91 + IGDS(I) = GRD37(I) + 141 CONTINUE +C + ELSE IF (IGRID.EQ.38) THEN + DO 142 I = 1,91 + IGDS(I) = GRD38(I) + 142 CONTINUE +C + ELSE IF (IGRID.EQ.39) THEN + DO 143 I = 1,91 + IGDS(I) = GRD39(I) + 143 CONTINUE +C + ELSE IF (IGRID.EQ.40) THEN + DO 144 I = 1,91 + IGDS(I) = GRD40(I) + 144 CONTINUE +C + ELSE IF (IGRID.EQ.41) THEN + DO 145 I = 1,91 + IGDS(I) = GRD41(I) + 145 CONTINUE +C + ELSE IF (IGRID.EQ.42) THEN + DO 146 I = 1,91 + IGDS(I) = GRD42(I) + 146 CONTINUE +C + ELSE IF (IGRID.EQ.43) THEN + DO 147 I = 1,91 + IGDS(I) = GRD43(I) + 147 CONTINUE +C + ELSE IF (IGRID.EQ.44) THEN + DO 148 I = 1,91 + IGDS(I) = GRD44(I) + 148 CONTINUE +C + ELSE IF (IGRID.EQ.45) THEN + DO 149 I = 1,18 + IGDS(I) = GRD45(I) + 149 CONTINUE +C + ELSE IF (IGRID.EQ.53) THEN + DO I = 1,18 + IGDS(I) = GRD53(I) + END DO +C + ELSE IF (IGRID.EQ.55) THEN + DO 152 I = 1,18 + IGDS(I) = GRD55(I) + 152 CONTINUE +C + ELSE IF (IGRID.EQ.56) THEN + DO 154 I = 1,18 + IGDS(I) = GRD56(I) + 154 CONTINUE +C + ELSE IF (IGRID.EQ.61) THEN + DO 160 I = 1,64 + IGDS(I) = GRD61(I) + 160 CONTINUE +C + ELSE IF (IGRID.EQ.62) THEN + DO 170 I = 1,64 + IGDS(I) = GRD62(I) + 170 CONTINUE +C + ELSE IF (IGRID.EQ.63) THEN + DO 180 I = 1,64 + IGDS(I) = GRD63(I) + 180 CONTINUE +C + ELSE IF (IGRID.EQ.64) THEN + DO 190 I = 1,64 + IGDS(I) = GRD64(I) + 190 CONTINUE +C + ELSE IF (IGRID.EQ.83) THEN + DO I = 1,18 + IGDS(I) = GRD83(I) + ENDDO +C + ELSE IF (IGRID.EQ.85) THEN + DO 192 I = 1,18 + IGDS(I) = GRD85(I) + 192 CONTINUE +C + ELSE IF (IGRID.EQ.86) THEN + DO 194 I = 1,18 + IGDS(I) = GRD86(I) + 194 CONTINUE +C + ELSE IF (IGRID.EQ.87) THEN + DO 195 I = 1,18 + IGDS(I) = GRD87(I) + 195 CONTINUE +C + ELSE IF (IGRID.EQ.88) THEN + DO 2195 I = 1,18 + IGDS(I) = GRD88(I) +2195 CONTINUE +C + ELSE IF (IGRID.EQ.90) THEN + DO 196 I = 1,18 + IGDS(I) = GRD90(I) + 196 CONTINUE +C + ELSE IF (IGRID.EQ.91) THEN + DO 197 I = 1,18 + IGDS(I) = GRD91(I) + 197 CONTINUE +C + ELSE IF (IGRID.EQ.92) THEN + DO 198 I = 1,18 + IGDS(I) = GRD92(I) + 198 CONTINUE +C + ELSE IF (IGRID.EQ.93) THEN + DO 199 I = 1,18 + IGDS(I) = GRD93(I) + 199 CONTINUE +C + ELSE IF (IGRID.EQ.94) THEN + DO 200 I = 1,18 + IGDS(I) = GRD94(I) + 200 CONTINUE +C + ELSE IF (IGRID.EQ.95) THEN + DO 201 I = 1,18 + IGDS(I) = GRD95(I) + 201 CONTINUE +C + ELSE IF (IGRID.EQ.96) THEN + DO 202 I = 1,18 + IGDS(I) = GRD96(I) + 202 CONTINUE +C + ELSE IF (IGRID.EQ.97) THEN + DO 203 I = 1,18 + IGDS(I) = GRD97(I) + 203 CONTINUE +C + ELSE IF (IGRID.EQ.98) THEN + DO 204 I = 1,18 + IGDS(I) = GRD98(I) + 204 CONTINUE +C + ELSE IF (IGRID.EQ.99) THEN + DO I = 1,18 + IGDS(I) = GRD99(I) + ENDDO +C + ELSE IF (IGRID.EQ.100) THEN + DO 205 I = 1,18 + IGDS(I) = GRD100(I) + 205 CONTINUE +C + ELSE IF (IGRID.EQ.101) THEN + DO 210 I = 1,18 + IGDS(I) = GRD101(I) + 210 CONTINUE +C + ELSE IF (IGRID.EQ.103) THEN + DO 220 I = 1,18 + IGDS(I) = GRD103(I) + 220 CONTINUE +C + ELSE IF (IGRID.EQ.104) THEN + DO 230 I = 1,18 + IGDS(I) = GRD104(I) + 230 CONTINUE +C + ELSE IF (IGRID.EQ.105) THEN + DO 240 I = 1,18 + IGDS(I) = GRD105(I) + 240 CONTINUE +C + ELSE IF (IGRID.EQ.106) THEN + DO 242 I = 1,18 + IGDS(I) = GRD106(I) + 242 CONTINUE +C + ELSE IF (IGRID.EQ.107) THEN + DO 244 I = 1,18 + IGDS(I) = GRD107(I) + 244 CONTINUE +C + ELSE IF (IGRID.EQ.110) THEN + DO I = 1,18 + IGDS(I) = GRD110(I) + ENDDO +C + ELSE IF (IGRID.EQ.120) THEN + DO I = 1,18 + IGDS(I) = GRD120(I) + ENDDO +C + ELSE IF (IGRID.EQ.122) THEN + DO I = 1,18 + IGDS(I) = GRD122(I) + ENDDO +C + ELSE IF (IGRID.EQ.123) THEN + DO I = 1,18 + IGDS(I) = GRD123(I) + ENDDO +C + ELSE IF (IGRID.EQ.124) THEN + DO I = 1,18 + IGDS(I) = GRD124(I) + ENDDO +C + ELSE IF (IGRID.EQ.125) THEN + DO I = 1,18 + IGDS(I) = GRD125(I) + ENDDO +C + ELSE IF (IGRID.EQ.126) THEN + DO 245 I = 1,18 + IGDS(I) = GRD126(I) + 245 CONTINUE +C + ELSE IF (IGRID.EQ.127) THEN + DO I = 1,18 + IGDS(I) = GRD127(I) + ENDDO +C + ELSE IF (IGRID.EQ.128) THEN + DO I = 1,18 + IGDS(I) = GRD128(I) + ENDDO +C + ELSE IF (IGRID.EQ.129) THEN + DO I = 1,18 + IGDS(I) = GRD129(I) + ENDDO +C + ELSE IF (IGRID.EQ.130) THEN + DO I = 1,18 + IGDS(I) = GRD130(I) + ENDDO +C + ELSE IF (IGRID.EQ.132) THEN + DO I = 1,18 + IGDS(I) = GRD132(I) + ENDDO +C + ELSE IF (IGRID.EQ.138) THEN + DO I = 1,18 + IGDS(I) = GRD138(I) + ENDDO +C + ELSE IF (IGRID.EQ.139) THEN + DO I = 1,18 + IGDS(I) = GRD139(I) + ENDDO +C + ELSE IF (IGRID.EQ.140) THEN + DO I = 1,18 + IGDS(I) = GRD140(I) + ENDDO +C + ELSE IF (IGRID.EQ.145) THEN + DO I = 1,18 + IGDS(I) = GRD145(I) + ENDDO +C + ELSE IF (IGRID.EQ.146) THEN + DO I = 1,18 + IGDS(I) = GRD146(I) + ENDDO +C + ELSE IF (IGRID.EQ.147) THEN + DO I = 1,18 + IGDS(I) = GRD147(I) + ENDDO +C + ELSE IF (IGRID.EQ.148) THEN + DO I = 1,18 + IGDS(I) = GRD148(I) + ENDDO +C + ELSE IF (IGRID.EQ.150) THEN + DO I = 1,18 + IGDS(I) = GRD150(I) + ENDDO +C + ELSE IF (IGRID.EQ.151) THEN + DO I = 1,18 + IGDS(I) = GRD151(I) + ENDDO +C + ELSE IF (IGRID.EQ.160) THEN + DO I = 1,18 + IGDS(I) = GRD160(I) + ENDDO +C + ELSE IF (IGRID.EQ.161) THEN + DO I = 1,18 + IGDS(I) = GRD161(I) + ENDDO + ELSE IF (IGRID.EQ.163) THEN + DO I = 1,18 + IGDS(I) = GRD163(I) + ENDDO +C + ELSE IF (IGRID.EQ.170) THEN + DO I = 1,18 + IGDS(I) = GRD170(I) + ENDDO +C + ELSE IF (IGRID.EQ.171) THEN + DO I = 1,18 + IGDS(I) = GRD171(I) + ENDDO +C + ELSE IF (IGRID.EQ.172) THEN + DO I = 1,18 + IGDS(I) = GRD172(I) + ENDDO +C + ELSE IF (IGRID.EQ.173) THEN + DO I = 1,18 + IGDS(I) = GRD173(I) + ENDDO +C + ELSE IF (IGRID.EQ.174) THEN + DO I = 1,18 + IGDS(I) = GRD174(I) + ENDDO +C + ELSE IF (IGRID.EQ.175) THEN + DO I = 1,18 + IGDS(I) = GRD175(I) + ENDDO +C + ELSE IF (IGRID.EQ.176) THEN + DO I = 1,18 + IGDS(I) = GRD176(I) + ENDDO +C + ELSE IF (IGRID.EQ.179) THEN + DO I = 1,18 + IGDS(I) = GRD179(I) + ENDDO +C + ELSE IF (IGRID.EQ.180) THEN + DO I = 1,18 + IGDS(I) = GRD180(I) + ENDDO +C + ELSE IF (IGRID.EQ.181) THEN + DO I = 1,18 + IGDS(I) = GRD181(I) + ENDDO +C + ELSE IF (IGRID.EQ.182) THEN + DO I = 1,18 + IGDS(I) = GRD182(I) + ENDDO +C + ELSE IF (IGRID.EQ.183) THEN + DO I = 1,18 + IGDS(I) = GRD183(I) + ENDDO +C + ELSE IF (IGRID.EQ.184) THEN + DO I = 1,18 + IGDS(I) = GRD184(I) + ENDDO +C + ELSE IF (IGRID.EQ.187) THEN + DO I = 1,18 + IGDS(I) = GRD187(I) + ENDDO +C + ELSE IF (IGRID.EQ.188) THEN + DO I = 1,18 + IGDS(I) = GRD188(I) + ENDDO +C + ELSE IF (IGRID.EQ.189) THEN + DO I = 1,18 + IGDS(I) = GRD189(I) + ENDDO +C + ELSE IF (IGRID.EQ.190) THEN + DO 2190 I = 1,18 + IGDS(I) = GRD190(I) + 2190 CONTINUE +C + ELSE IF (IGRID.EQ.192) THEN + DO 2191 I = 1,18 + IGDS(I) = GRD192(I) + 2191 CONTINUE +C + ELSE IF (IGRID.EQ.193) THEN + DO I = 1,18 + IGDS(I) = GRD193(I) + END DO +C + ELSE IF (IGRID.EQ.194) THEN + DO 2192 I = 1,18 + IGDS(I) = GRD194(I) + 2192 CONTINUE +C + ELSE IF (IGRID.EQ.195) THEN + DO I = 1,18 + IGDS(I) = GRD195(I) + END DO +C + ELSE IF (IGRID.EQ.196) THEN + DO 249 I = 1,18 + IGDS(I) = GRD196(I) + 249 CONTINUE +C + ELSE IF (IGRID.EQ.197) THEN + DO I = 1,18 + IGDS(I) = GRD197(I) + END DO +C + ELSE IF (IGRID.EQ.198) THEN + DO 2490 I = 1,18 + IGDS(I) = GRD198(I) + 2490 CONTINUE +C + ELSE IF (IGRID.EQ.199) THEN + DO I = 1,18 + IGDS(I) = GRD199(I) + END DO +C + ELSE IF (IGRID.EQ.200) THEN + DO I = 1,18 + IGDS(I) = GRD200(I) + END DO +C + ELSE IF (IGRID.EQ.201) THEN + DO 250 I = 1,18 + IGDS(I) = GRD201(I) + 250 CONTINUE +C + ELSE IF (IGRID.EQ.202) THEN + DO 260 I = 1,18 + IGDS(I) = GRD202(I) + 260 CONTINUE +C + ELSE IF (IGRID.EQ.203) THEN + DO 270 I = 1,18 + IGDS(I) = GRD203(I) + 270 CONTINUE +C + ELSE IF (IGRID.EQ.204) THEN + DO 280 I = 1,18 + IGDS(I) = GRD204(I) + 280 CONTINUE +C + ELSE IF (IGRID.EQ.205) THEN + DO 290 I = 1,18 + IGDS(I) = GRD205(I) + 290 CONTINUE +C + ELSE IF (IGRID.EQ.206) THEN + DO 300 I = 1,18 + IGDS(I) = GRD206(I) + 300 CONTINUE +C + ELSE IF (IGRID.EQ.207) THEN + DO 310 I = 1,18 + IGDS(I) = GRD207(I) + 310 CONTINUE +C + ELSE IF (IGRID.EQ.208) THEN + DO 320 I = 1,18 + IGDS(I) = GRD208(I) + 320 CONTINUE +C + ELSE IF (IGRID.EQ.209) THEN + DO 330 I = 1,18 + IGDS(I) = GRD209(I) + 330 CONTINUE +C + ELSE IF (IGRID.EQ.210) THEN + DO 340 I = 1,18 + IGDS(I) = GRD210(I) + 340 CONTINUE +C + ELSE IF (IGRID.EQ.211) THEN + DO 350 I = 1,18 + IGDS(I) = GRD211(I) + 350 CONTINUE +C + ELSE IF (IGRID.EQ.212) THEN + DO 360 I = 1,18 + IGDS(I) = GRD212(I) + 360 CONTINUE +C + ELSE IF (IGRID.EQ.213) THEN + DO 370 I = 1,18 + IGDS(I) = GRD213(I) + 370 CONTINUE +C + ELSE IF (IGRID.EQ.214) THEN + DO 380 I = 1,18 + IGDS(I) = GRD214(I) + 380 CONTINUE +C + ELSE IF (IGRID.EQ.215) THEN + DO 390 I = 1,18 + IGDS(I) = GRD215(I) + 390 CONTINUE +C + ELSE IF (IGRID.EQ.216) THEN + DO 400 I = 1,18 + IGDS(I) = GRD216(I) + 400 CONTINUE +C + ELSE IF (IGRID.EQ.217) THEN + DO 401 I = 1,18 + IGDS(I) = GRD217(I) + 401 CONTINUE +C + ELSE IF (IGRID.EQ.218) THEN + DO 410 I = 1,18 + IGDS(I) = GRD218(I) + 410 CONTINUE +C + ELSE IF (IGRID.EQ.219) THEN + DO 411 I = 1,18 + IGDS(I) = GRD219(I) + 411 CONTINUE +C + ELSE IF (IGRID.EQ.220) THEN + DO 412 I = 1,18 + IGDS(I) = GRD220(I) + 412 CONTINUE +C + ELSE IF (IGRID.EQ.221) THEN + DO 413 I = 1,18 + IGDS(I) = GRD221(I) + 413 CONTINUE +C + ELSE IF (IGRID.EQ.222) THEN + DO 414 I = 1,18 + IGDS(I) = GRD222(I) + 414 CONTINUE +C + ELSE IF (IGRID.EQ.223) THEN + DO 415 I = 1,18 + IGDS(I) = GRD223(I) + 415 CONTINUE +C + ELSE IF (IGRID.EQ.224) THEN + DO 416 I = 1,18 + IGDS(I) = GRD224(I) + 416 CONTINUE +C + ELSE IF (IGRID.EQ.225) THEN + DO 417 I = 1,18 + IGDS(I) = GRD225(I) + 417 CONTINUE +C + ELSE IF (IGRID.EQ.226) THEN + DO 418 I = 1,18 + IGDS(I) = GRD226(I) + 418 CONTINUE +C + ELSE IF (IGRID.EQ.227) THEN + DO 419 I = 1,18 + IGDS(I) = GRD227(I) + 419 CONTINUE +C + ELSE IF (IGRID.EQ.228) THEN + DO 420 I = 1,18 + IGDS(I) = GRD228(I) + 420 CONTINUE +C + ELSE IF (IGRID.EQ.229) THEN + DO 421 I = 1,18 + IGDS(I) = GRD229(I) + 421 CONTINUE +C + ELSE IF (IGRID.EQ.230) THEN + DO 422 I = 1,18 + IGDS(I) = GRD230(I) + 422 CONTINUE +C + ELSE IF (IGRID.EQ.231) THEN + DO 423 I = 1,18 + IGDS(I) = GRD231(I) + 423 CONTINUE +C + ELSE IF (IGRID.EQ.232) THEN + DO 424 I = 1,18 + IGDS(I) = GRD232(I) + 424 CONTINUE +C + ELSE IF (IGRID.EQ.233) THEN + DO 425 I = 1,18 + IGDS(I) = GRD233(I) + 425 CONTINUE +C + ELSE IF (IGRID.EQ.234) THEN + DO 426 I = 1,18 + IGDS(I) = GRD234(I) + 426 CONTINUE +C + ELSE IF (IGRID.EQ.235) THEN + DO 427 I = 1,18 + IGDS(I) = GRD235(I) + 427 CONTINUE +C + ELSE IF (IGRID.EQ.236) THEN + DO 428 I = 1,18 + IGDS(I) = GRD236(I) + 428 CONTINUE +C + ELSE IF (IGRID.EQ.237) THEN + DO 429 I = 1,18 + IGDS(I) = GRD237(I) + 429 CONTINUE +C + ELSE IF (IGRID.EQ.238) THEN + DO I = 1,18 + IGDS(I) = GRD238(I) + END DO +C + ELSE IF (IGRID.EQ.239) THEN + DO I = 1,18 + IGDS(I) = GRD239(I) + END DO +C + ELSE IF (IGRID.EQ.240) THEN + DO I = 1,18 + IGDS(I) = GRD240(I) + END DO +C + ELSE IF (IGRID.EQ.241) THEN + DO 430 I = 1,18 + IGDS(I) = GRD241(I) + 430 CONTINUE +C + ELSE IF (IGRID.EQ.242) THEN + DO 431 I = 1,18 + IGDS(I) = GRD242(I) + 431 CONTINUE +C + ELSE IF (IGRID.EQ.243) THEN + DO 432 I = 1,18 + IGDS(I) = GRD243(I) + 432 CONTINUE +C + ELSE IF (IGRID.EQ.244) THEN + DO I = 1,18 + IGDS(I) = GRD244(I) + END DO +C + ELSE IF (IGRID.EQ.245) THEN + DO 433 I = 1,18 + IGDS(I) = GRD245(I) + 433 CONTINUE +C + ELSE IF (IGRID.EQ.246) THEN + DO 434 I = 1,18 + IGDS(I) = GRD246(I) + 434 CONTINUE +C + ELSE IF (IGRID.EQ.247) THEN + DO 435 I = 1,18 + IGDS(I) = GRD247(I) + 435 CONTINUE +C + ELSE IF (IGRID.EQ.248) THEN + DO 436 I = 1,18 + IGDS(I) = GRD248(I) + 436 CONTINUE +C + ELSE IF (IGRID.EQ.249) THEN + DO 437 I = 1,18 + IGDS(I) = GRD249(I) + 437 CONTINUE +C + ELSE IF (IGRID.EQ.250) THEN + DO 438 I = 1,18 + IGDS(I) = GRD250(I) + 438 CONTINUE +C + ELSE IF (IGRID.EQ.251) THEN + DO 439 I = 1,18 + IGDS(I) = GRD251(I) + 439 CONTINUE +C + ELSE IF (IGRID.EQ.252) THEN + DO 440 I = 1,18 + IGDS(I) = GRD252(I) + 440 CONTINUE + ELSE IF (IGRID.EQ.253) THEN + DO 441 I = 1,18 + IGDS(I) = GRD253(I) + 441 CONTINUE + ELSE IF (IGRID.EQ.254) THEN + DO 442 I = 1,18 + IGDS(I) = GRD254(I) + 442 CONTINUE +C + ELSE + IERR = 1 + ENDIF +C + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi72.f b/WPS/ungrib/src/ngl/w3/w3fi72.f new file mode 100755 index 00000000..5750bca3 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi72.f @@ -0,0 +1,455 @@ + SUBROUTINE W3FI72(ITYPE,FLD,IFLD,IBITL, + & IPFLAG,ID,PDS, + & IGFLAG,IGRID,IGDS,ICOMP, + & IBFLAG,IBMAP,IBLEN,IBDSFL, + & NPTS,KBUF,ITOT,JERR) +C $$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI72 MAKE A COMPLETE GRIB MESSAGE +C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 +C +C ABSTRACT: MAKES A COMPLETE GRIB MESSAGE FROM A USER SUPPLIED +C ARRAY OF FLOATING POINT OR INTEGER DATA. THE USER HAS THE +C OPTION OF SUPPLYING THE PDS OR AN INTEGER ARRAY THAT WILL BE +C USED TO CREATE A PDS (WITH W3FI68). THE USER MUST ALSO +C SUPPLY OTHER NECESSARY INFO; SEE USAGE SECTION BELOW. +C +C PROGRAM HISTORY LOG: +C 91-05-08 R.E.JONES +C 92-07-01 M. FARLEY ADDED GDS AND BMS LOGIC. PLACED EXISTING +C LOGIC FOR BDS IN A ROUTINE. +C 92-10-02 R.E.JONES ADD ERROR EXIT FOR W3FI73 +C 93-04-30 R.E.JONES REPLACE DO LOOPS TO MOVE CHARACTER DATA +C WITH XMOVEX, USE XSTORE TO ZERO CHARACTER +C ARRAY. MAKE CHANGE SO FLAT FIELD WILL PACK. +C 93-08-06 CAVANAUGH MODIFIED CALL TO W3FI75 +C 93-10-26 CAVANAUGH ADDED CODE TO RESTORE INPUT FIELD TO ORIGINAL +C VALUES IF D-SCALE NOT 0 +C 94-01-27 CAVANAUGH ADDED IGDS ARRAY IN CALL TO W3FI75 TO PROVIDE +C INFORMATION FOR BOUSTROPHEDONIC PROCESSING +C 94-03-03 CAVANAUGH INCREASED SIZE OF GDS ARRAY FOR THIN GRIDS +C 94-05-16 FARLEY CLEANED UP DOCUMENTATION +C 94-11-10 FARLEY INCREASED SIZE OF PFLD/IFLD ARRARYS FROM +C 100K TO 260K FOR .5 DEGREE SST ANAL FIELDS +C 94-12-04 R.E.JONES CHANGE DOCUMENT FOR IPFLAG. +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 98-05-19 Gilbert Increased array dimensions to handle grids +C of up to 500,000 grid points. +C 95-10-31 IREDELL GENERALIZED WORD SIZE +C 98-12-21 Gilbert Replaced Function ICHAR with mov_a2i. +C 99-02-01 Gilbert Changed the method of zeroing out array KBUF. +C the old method, using W3FI01 and XSTORE was +C incorrect with 4-byte integers and 8-byte reals. +C 2001-06-07 Gilbert Removed calls to xmovex. +C changed IPFLD from integer to character. +C 10-02-19 GAYNO FIX ALLOCATION OF ARRAY BMS +C +C USAGE: CALL W3FI72(ITYPE,FLD,IFLD,IBITL, +C & IPFLAG,ID,PDS, +C & IGFLAG,IGRID,IGDS,ICOMP, +C & IBFLAG,IBMAP,IBLEN,IBDSFL, +C & IBDSFL, +C & NPTS,KBUF,ITOT,JERR) +C +C INPUT ARGUMENT LIST: +C ITYPE - 0 = FLOATING POINT DATA SUPPLIED IN ARRAY 'FLD' +C 1 = INTEGER DATA SUPPLIED IN ARRAY 'IFLD' +C FLD - REAL ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE +C CONVERTED TO GRIB FORMAT IF ITYPE=0. +C SEE REMARKS #1 & 2. +C IFLD - INTEGER ARRAY OF DATA (AT PROPER GRIDPOINTS) TO BE +C CONVERTED TO GRIB FORMAT IF ITYPE=1. +C SEE REMARKS #1 & 2. +C IBITL - 0 = COMPUTER COMPUTES LENGTH FOR PACKING DATA FROM +C POWER OF 2 (NUMBER OF BITS) BEST FIT OF DATA +C USING 'VARIABLE' BIT PACKER W3FI58. +C 8, 12, ETC. COMPUTER RESCALES DATA TO FIT INTO THAT +C 'FIXED' NUMBER OF BITS USING W3FI59. +C SEE REMARKS #3. +C +C IPFLAG - 0 = MAKE PDS FROM USER SUPPLIED ARRAY (ID) +C 1 = USER SUPPLYING PDS +C NOTE: IF PDS IS GREATER THAN 30, USE IPLFAG=1. +C THE USER COULD CALL W3FI68 BEFORE HE CALLS +C W3FI72. THIS WOULD MAKE THE FIRST 30 BYTES OF +C THE PDS, USER THEN WOULD MAKE BYTES AFTER 30. +C ID - INTEGER ARRAY OF VALUES THAT W3FI68 WILL USE +C TO MAKE AN EDITION 1 PDS IF IPFLAG=0. (SEE THE +C DOCBLOCK FOR W3FI68 FOR LAYOUT OF ARRAY) +C PDS - CHARACTER ARRAY OF VALUES (VALID PDS SUPPLIED +C BY USER) IF IPFLAG=1. LENGTH MAY EXCEED 28 BYTES +C (CONTENTS OF BYTES BEYOND 28 ARE PASSED +C THROUGH UNCHANGED). +C +C IGFLAG - 0 = MAKE GDS BASED ON 'IGRID' VALUE. +C 1 = MAKE GDS FROM USER SUPPLIED INFO IN 'IGDS' +C AND 'IGRID' VALUE. +C SEE REMARKS #4. +C IGRID - # = GRID IDENTIFICATION (TABLE B) +C 255 = IF USER DEFINED GRID; IGDS MUST BE SUPPLIED +C AND IGFLAG MUST =1. +C IGDS - INTEGER ARRAY CONTAINING USER GDS INFO (SAME +C FORMAT AS SUPPLIED BY W3FI71 - SEE DOCKBLOCK FOR +C LAYOUT) IF IGFLAG=1. +C ICOMP - RESOLUTION AND COMPONENT FLAG FOR BIT 5 OF GDS(17) +C 0 = EARTH ORIENTED WINDS +C 1 = GRID ORIENTED WINDS +C +C IBFLAG - 0 = MAKE BIT MAP FROM USER SUPPLIED DATA +C # = BIT MAP PREDEFINED BY CENTER +C SEE REMARKS #5. +C IBMAP - INTEGER ARRAY CONTAINING BIT MAP +C IBLEN - LENGTH OF BIT MAP WILL BE USED TO VERIFY LENGTH +C OF FIELD (ERROR IF IT DOESN'T MATCH). +C +C IBDSFL - INTEGER ARRAY CONTAINING TABLE 11 FLAG INFO +C BDS OCTET 4: +C (1) 0 = GRID POINT DATA +C 1 = SPHERICAL HARMONIC COEFFICIENTS +C (2) 0 = SIMPLE PACKING +C 1 = SECOND ORDER PACKING +C (3) ... SAME VALUE AS 'ITYPE' +C 0 = ORIGINAL DATA WERE FLOATING POINT VALUES +C 1 = ORIGINAL DATA WERE INTEGER VALUES +C (4) 0 = NO ADDITIONAL FLAGS AT OCTET 14 +C 1 = OCTET 14 CONTAINS FLAG BITS 5-12 +C (5) 0 = RESERVED - ALWAYS SET TO 0 +C BYTE 6 OPTION 1 NOT AVAILABLE (AS OF 5-16-93) +C (6) 0 = SINGLE DATUM AT EACH GRID POINT +C 1 = MATRIX OF VALUES AT EACH GRID POINT +C BYTE 7 OPTION 0 WITH SECOND ORDER PACKING N/A (AS OF 5-16-93) +C (7) 0 = NO SECONDARY BIT MAPS +C 1 = SECONDARY BIT MAPS PRESENT +C (8) 0 = SECOND ORDER VALUES HAVE CONSTANT WIDTH +C 1 = SECOND ORDER VALUES HAVE DIFFERENT WIDTHS +C +C OUTPUT ARGUMENT LIST: +C NPTS - NUMBER OF GRIDPOINTS IN ARRAY FLD OR IFLD +C KBUF - ENTIRE GRIB MESSAGE ('GRIB' TO '7777') +C EQUIVALENCE TO INTEGER ARRAY TO MAKE SURE IT +C IS ON WORD BOUNARY. +C ITOT - TOTAL LENGTH OF GRIB MESSAGE IN BYTES +C JERR - = 0, COMPLETED MAKING GRIB FIELD WITHOUT ERROR +C 1, IPFLAG NOT 0 OR 1 +C 2, IGFLAG NOT 0 OR 1 +C 3, ERROR CONVERTING IEEE F.P. NUMBER TO IBM370 F.P. +C 4, W3FI71 ERROR/IGRID NOT DEFINED +C 5, W3FK74 ERROR/GRID REPRESENTATION TYPE NOT VALID +C 6, GRID TOO LARGE FOR PACKER DIMENSION ARRAYS +C SEE AUTOMATION DIVISION FOR REVISION! +C 7, LENGTH OF BIT MAP NOT EQUAL TO SIZE OF FLD/IFLD +C 8, W3FI73 ERROR, ALL VALUES IN IBMAP ARE ZERO +C +C OUTPUT FILES: +C FT06F001 - STANDARD FORTRAN OUTPUT PRINT FILE +C +C SUBPROGRAMS CALLED: +C LIBRARY: +C W3LIB - W3FI58, W3FI59, W3FI68, W3FI71, W3FI73, W3FI74 +C W3FI75, W3FI76 +C FORTRAN 90 INTRINSIC - BIT_SIZE +C +C REMARKS: +C 1) IF BIT MAP TO BE INCLUDED IN MESSAGE, NULL DATA SHOULD +C BE INCLUDED IN FLD OR IFLD. THIS ROUTINE WILL TAKE CARE +C OF 'DISCARDING' ANY NULL DATA BASED ON THE BIT MAP. +C 2) UNITS MUST BE THOSE IN GRIB DOCUMENTATION: NMC O.N. 388 +C OR WMO PUBLICATION 306. +C 3) IN EITHER CASE, INPUT NUMBERS WILL BE MULTIPLIED BY +C '10 TO THE NTH' POWER FOUND IN ID(25) OR PDS(27-28), +C THE D-SCALING FACTOR, PRIOR TO BINARY PACKING. +C 4) ALL NMC PRODUCED GRIB FIELDS WILL HAVE A GRID DEFINITION +C SECTION INCLUDED IN THE GRIB MESSAGE. ID(6) WILL BE +C SET TO '1'. +C - GDS WILL BE BUILT BASED ON GRID NUMBER (IGRID), UNLESS +C IGFLAG=1 (USER SUPPLYING IGDS). USER MUST STILL SUPPLY +C IGRID EVEN IF IGDS PROVIDED. +C 5) IF BIT MAP USED THEN ID(7) OR PDS(8) MUST INDICATE THE +C PRESENCE OF A BIT MAP. +C 6) ARRAY KBUF SHOULD BE EQUIVALENCED TO AN INTEGER VALUE OR +C ARRAY TO MAKE SURE IT IS ON A WORD BOUNDARY. +C 7) SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C $$ +C + REAL FLD(*) +C + INTEGER IBDSFL(*) + INTEGER IBMAP(*) + INTEGER ID(*) + INTEGER IFLD(*) + INTEGER IGDS(*) + INTEGER IB(4) + INTEGER NLEFT, NUMBMS +C + CHARACTER * 1 BDS11(11) + CHARACTER * 1 KBUF(*) + CHARACTER * 1 PDS(*) + CHARACTER * 1 GDS(200) + CHARACTER(1),ALLOCATABLE:: BMS(:) + CHARACTER(1),ALLOCATABLE:: PFLD(:) + CHARACTER(1),ALLOCATABLE:: IPFLD(:) + CHARACTER * 1 SEVEN + CHARACTER * 1 ZERO +C +C +C ASCII REP OF /'G', 'R', 'I', 'B'/ +C + DATA IB / 71, 82, 73, 66/ +C + IER = 0 + IBERR = 0 + JERR = 0 + IGRIBL = 8 + IPDSL = 0 + LENGDS = 0 + LENBMS = 0 + LENBDS = 0 + ITOSS = 0 +C +C 1.0 PRODUCT DEFINITION SECTION(PDS). +C +C SET ID(6) TO 1 ...OR... MODIFY PDS(8) ... +C REGARDLESS OF USER SPECIFICATION... +C NMC GRIB FIELDS WILL ALWAYS HAVE A GDS +C + IF (IPFLAG .EQ.0) THEN + ID(6) = 1 + CALL W3FI68(ID,PDS) + ELSE IF (IPFLAG .EQ. 1) THEN + IF (IAND(mov_a2i(PDS(8)),64) .EQ. 64) THEN +C BOTH GDS AND BMS + PDS(8) = CHAR(192) + ELSE IF (mov_a2i(PDS(8)) .EQ. 0) THEN +C GDS ONLY + PDS(8) = CHAR(128) + END IF + CONTINUE + ELSE +C PRINT *,' W3FI72 ERROR, IPFLAG IS NOT 0 OR 1 IPFLAG = ',IPFLAG + JERR = 1 + GO TO 900 + END IF +C +C GET LENGTH OF PDS +C + IPDSL = mov_a2i(PDS(1)) * 65536 + mov_a2i(PDS(2)) * 256 + + & mov_a2i(PDS(3)) +C +C 2.0 GRID DEFINITION SECTION (GDS). +C +C IF IGFLAG=1 THEN USER IS SUPPLYING THE IGDS INFORMATION +C + IF (IGFLAG .EQ. 0) THEN + CALL W3FI71(IGRID,IGDS,IGERR) + IF (IGERR .EQ. 1) THEN +C PRINT *,' W3FI71 ERROR, GRID TYPE NOT DEFINED...',IGRID + JERR = 4 + GO TO 900 + END IF + END IF + IF (IGFLAG .EQ. 0 .OR. IGFLAG .EQ.1) THEN + CALL W3FI74(IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR) + IF (IGERR .EQ. 1) THEN +C PRINT *,' W3FI74 ERROR, GRID REP TYPE NOT VALID...',IGDS(3) + JERR = 5 + GO TO 900 + ELSE + END IF + ELSE +C PRINT *,' W3FI72 ERROR, IGFLAG IS NOT 0 OR 1 IGFLAG = ',IGFLAG + JERR = 2 + GO TO 900 + END IF +C +C 3.0 BIT MAP SECTION (BMS). +C +C SET ITOSS=1 IF BITMAP BEING USED. W3FI75 WILL TOSS DATA +C PRIOR TO PACKING. LATER CODING WILL BE NEEDED WHEN THE +C 'PREDEFINED' GRIDS ARE FINALLY 'DEFINED'. +C + IF (mov_a2i(PDS(8)) .EQ. 64 .OR. + & mov_a2i(PDS(8)) .EQ. 192) THEN + ITOSS = 1 + IF (IBFLAG .EQ. 0) THEN + IF (IBLEN .NE. NPTS) THEN +C PRINT *,' W3FI72 ERROR, IBLEN .NE. NPTS = ',IBLEN,NPTS + JERR = 7 + GO TO 900 + END IF + IF (MOD(IBLEN,16).NE.0) THEN + NLEFT = 16 - MOD(IBLEN,16) + ELSE + NLEFT = 0 + END IF + NUMBMS = 6 + (IBLEN+NLEFT) / 8 + ALLOCATE(BMS(NUMBMS)) + ZERO = CHAR(00) + BMS = ZERO + CALL W3FI73(IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER) + IF (IER .NE. 0) THEN +C PRINT *,' W3FI73 ERROR, IBMAP VALUES ARE ALL ZERO' + JERR = 8 + GO TO 900 + END IF + ELSE +C PRINT *,' BIT MAP PREDEFINED BY CENTER, IBFLAG = ',IBFLAG + END IF + END IF +C +C 4.0 BINARY DATA SECTION (BDS). +C +C 4.1 SCALE THE DATA WITH D-SCALE FROM PDS(27-28) +C + JSCALE = mov_a2i(PDS(27)) * 256 + mov_a2i(PDS(28)) + IF (IAND(JSCALE,32768).NE.0) THEN + JSCALE = - IAND(JSCALE,32767) + END IF + SCALE = 10.0 ** JSCALE + IF (ITYPE .EQ. 0) THEN + DO 410 I = 1,NPTS + FLD(I) = FLD(I) * SCALE + 410 CONTINUE + ELSE + DO 411 I = 1,NPTS + IFLD(I) = NINT(FLOAT(IFLD(I)) * SCALE) + 411 CONTINUE + END IF +C +C 4.2 CALL W3FI75 TO PACK DATA AND MAKE BDS. +C + ALLOCATE(PFLD(NPTS*4)) +C + IF(IBDSFL(2).NE.0) THEN + ALLOCATE(IPFLD(NPTS*4)) + IPFLD=char(0) + ELSE + ALLOCATE(IPFLD(1)) + ENDIF +C + CALL W3FI75(IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL, + & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS) +C + IF(IBDSFL(2).NE.0) THEN +C CALL XMOVEX(PFLD,IPFLD,NPTS*4) + do ii = 1, NPTS*4 + PFLD(ii) = IPFLD(ii) + enddo + ENDIF + DEALLOCATE(IPFLD) +C + IF (IBERR .EQ. 1) THEN + JERR = 3 + GO TO 900 + END IF +C 4.3 IF D-SCALE NOT 0, RESCALE INPUT FIELD TO +C ORIGINAL VALUE +C + IF (JSCALE.NE.0) THEN + DSCALE = 1.0 / SCALE + IF (ITYPE.EQ.0) THEN + DO 412 I = 1, NPTS + FLD(I) = FLD(I) * DSCALE + 412 CONTINUE + ELSE + DO 413 I = 1, NPTS + FLD(I) = NINT(FLOAT(IFLD(I)) * DSCALE) + 413 CONTINUE + END IF + END IF +C +C 5.0 OUTPUT SECTION. +C +C 5.1 ZERO OUT THE OUTPUT ARRAY KBUF. +C + ZERO = CHAR(00) + ITOT = IGRIBL + IPDSL + LENGDS + LENBMS + LENBDS + 4 +C PRINT *,'IGRIBL =',IGRIBL +C PRINT *,'IPDSL =',IPDSL +C PRINT *,'LENGDS =',LENGDS +C PRINT *,'LENBMS =',LENBMS +C PRINT *,'LENBDS =',LENBDS +C PRINT *,'ITOT =',ITOT + KBUF(1:ITOT)=ZERO +C +C 5.2 MOVE SECTION 0 - 'IS' INTO KBUF (8 BYTES). +C + ISTART = 0 + DO 520 I = 1,4 + KBUF(I) = CHAR(IB(I)) + 520 CONTINUE +C + KBUF(5) = CHAR(MOD(ITOT / 65536,256)) + KBUF(6) = CHAR(MOD(ITOT / 256,256)) + KBUF(7) = CHAR(MOD(ITOT ,256)) + KBUF(8) = CHAR(1) +C +C 5.3 MOVE SECTION 1 - 'PDS' INTO KBUF (28 BYTES). +C + ISTART = ISTART + IGRIBL + IF (IPDSL.GT.0) THEN +C CALL XMOVEX(KBUF(ISTART+1),PDS,IPDSL) + do ii = 1, IPDSL + KBUF(ISTART+ii) = PDS(ii) + enddo + ELSE +C PRINT *,'LENGTH OF PDS LESS OR EQUAL 0, IPDSL = ',IPDSL + END IF +C +C 5.4 MOVE SECTION 2 - 'GDS' INTO KBUF. +C + ISTART = ISTART + IPDSL + IF (LENGDS .GT. 0) THEN +C CALL XMOVEX(KBUF(ISTART+1),GDS,LENGDS) + do ii = 1, LENGDS + KBUF(ISTART+ii) = GDS(ii) + enddo + END IF +C +C 5.5 MOVE SECTION 3 - 'BMS' INTO KBUF. +C + ISTART = ISTART + LENGDS + IF (LENBMS .GT. 0) THEN +C CALL XMOVEX(KBUF(ISTART+1),BMS,LENBMS) + do ii = 1, LENBMS + KBUF(ISTART+ii) = BMS(ii) + enddo + END IF +C +C 5.6 MOVE SECTION 4 - 'BDS' INTO KBUF. +C +C MOVE THE FIRST 11 OCTETS OF THE BDS INTO KBUF. +C + ISTART = ISTART + LENBMS +C CALL XMOVEX(KBUF(ISTART+1),BDS11,11) + do ii = 1, 11 + KBUF(ISTART+ii) = BDS11(ii) + enddo +C +C MOVE THE PACKED DATA INTO THE KBUF +C + ISTART = ISTART + 11 + IF (LEN.GT.0) THEN +C CALL XMOVEX(KBUF(ISTART+1),PFLD,LEN) + do ii = 1, LEN + KBUF(ISTART+ii) = PFLD(ii) + enddo + END IF +C +C ADD '7777' TO END OFF KBUF +C NOTE THAT THESE 4 OCTETS NOT INCLUDED IN ACTUAL SIZE OF BDS. +C + SEVEN = CHAR(55) + ISTART = ITOT - 4 + DO 562 I = 1,4 + KBUF(ISTART+I) = SEVEN + 562 CONTINUE +C + 900 CONTINUE + IF(ALLOCATED(BMS)) DEALLOCATE(BMS) + IF(ALLOCATED(PFLD)) DEALLOCATE(PFLD) + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi73.f b/WPS/ungrib/src/ngl/w3/w3fi73.f new file mode 100755 index 00000000..ec4f80e0 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi73.f @@ -0,0 +1,99 @@ + SUBROUTINE W3FI73 (IBFLAG,IBMAP,IBLEN,BMS,LENBMS,IER) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI73 CONSTRUCT GRIB BIT MAP SECTION (BMS) +C PRGMMR: FARLEY ORG: NMC421 DATE:92-11-16 +C +C ABSTRACT: THIS SUBROUTINE CONSTRUCTS A GRIB BIT MAP SECTION. +C +C PROGRAM HISTORY LOG: +C 92-07-01 M. FARLEY ORIGINAL AUTHOR +C 94-02-14 CAVANAUGH RECODED +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL W3FI73 (IBFLAG, IBMAP, IBLEN, BMS, LENBMS, IER) +C INPUT ARGUMENT LIST: +C IBFLAG - 0, IF BIT MAP SUPPLIED BY USER +C - #, NUMBER OF PREDEFINED CENTER BIT MAP +C IBMAP - INTEGER ARRAY CONTAINING USER BIT MAP +C IBLEN - LENGTH OF BIT MAP +C +C OUTPUT ARGUMENT LIST: +C BMS - COMPLETED GRIB BIT MAP SECTION +C LENBMS - LENGTH OF BIT MAP SECTION +C IER - 0 NORMAL EXIT, 8 = IBMAP VALUES ARE ALL ZERO +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM370 VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS, CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 +C +C$$$ +C + INTEGER IBMAP(*) + INTEGER LENBMS + INTEGER IBLEN + INTEGER IBFLAG +C + CHARACTER*1 BMS (*) +C + IER = 0 +C +C + IZ = 0 + DO 20 I = 1, IBLEN + IF (IBMAP(I).EQ.0) IZ = IZ + 1 + 20 CONTINUE + IF (IZ.EQ.IBLEN) THEN +C +C AT THIS POINT ALL BIT MAP POSITIONS ARE ZERO +C + IER = 8 + RETURN + END IF +C +C BIT MAP IS A COMBINATION OF ONES AND ZEROS +C OR BIT MAP ALL ONES +C +C CONSTRUCT BIT MAP FIELD OF BIT MAP SECTION +C + CALL SBYTES (BMS,IBMAP,48,1,0,IBLEN) +C + IF (MOD(IBLEN,16).NE.0) THEN + NLEFT = 16 - MOD(IBLEN,16) + ELSE + NLEFT = 0 + END IF +C + NUM = 6 + (IBLEN+NLEFT) / 8 +C +C +C CONSTRUCT BMS FROM COLLECTED DATA +C +C SIZE INTO FIRST THREE BYTES + CALL SBYTE (BMS,NUM,0,24) +C NUMBER OF FILL BITS INTO BYTE 4 + CALL SBYTE (BMS,NLEFT,24,8) +C OCTET 5-6 TO CONTAIN INFO FROM IBFLAG + CALL SBYTE (BMS,IBFLAG,32,16) +C +C BIT MAP MAY BE ALL ONES OR A COMBINATION +C OF ONES AND ZEROS +C +C ACTUAL BITS OF BIT MAP PLACED ALL READY +C +C INSTALL FILL POSITIONS IF NEEDED + IF (NLEFT.NE.0) THEN + NLEFT = 16 - NLEFT +C ZERO FILL POSITIONS + CALL SBYTE (BMS,0,IBLEN+48,NLEFT) + END IF +C +C STORE NUM IN LENBMS (LENGTH OF BMS SECTION) +C + LENBMS = NUM +C PRINT *,'W3FI73 - BMS LEN =',NUM,LENBMS +C + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi74.f b/WPS/ungrib/src/ngl/w3/w3fi74.f new file mode 100755 index 00000000..946e50e3 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi74.f @@ -0,0 +1,426 @@ + SUBROUTINE W3FI74 (IGDS,ICOMP,GDS,LENGDS,NPTS,IGERR) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI74 CONSTRUCT GRID DEFINITION SECTION (GDS) +C PRGMMR: FARLEY ORG: W/NMC42 DATE: 93-08-24 +C +C ABSTRACT: THIS SUBROUTINE CONSTRUCTS A GRIB GRID DEFINITION +C SECTION. +C +C PROGRAM HISTORY LOG: +C 92-07-07 M. FARLEY ORIGINAL AUTHOR +C 92-10-16 R.E.JONES ADD CODE TO LAT/LON SECTION TO DO +C GAUSSIAN GRIDS. +C 93-03-29 R.E.JONES ADD SAVE STATEMENT +C 93-08-24 R.E.JONES CHANGES FOR GRIB GRIDS 37-44 +C 93-09-29 R.E.JONES CHANGES FOR GAUSSIAN GRID FOR DOCUMENT +C CHANGE IN W3FI71. +C 94-02-15 R.E.JONES CHANGES FOR ETA MODEL GRIDS 90-93 +C 95-04-20 R.E.JONES CHANGE 200 AND 201 TO 201 AND 202 +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 98-08-20 BALDWIN ADD TYPE 203 +C 07-03-20 VUONG ADD TYPE 204 +C 10-01-21 GAYNO ADD GRID 205 - ROTATED LAT/LON A,B,C,D STAGGERS +C +C +C USAGE: CALL W3FI74 (IGDS, ICOMP, GDS, LENGDS, NPTS, IGERR) +C INPUT ARGUMENT LIST: +C IGDS - INTEGER ARRAY SUPPLIED BY W3FI71 +C ICOMP - TABLE 7- RESOLUTION & COMPONENT FLAG (BIT 5) +C FOR GDS(17) WIND COMPONENTS +C +C OUTPUT ARGUMENT LIST: +C GDS - COMPLETED GRIB GRID DEFINITION SECTION +C LENGDS - LENGTH OF GDS +C NPTS - NUMBER OF POINTS IN GRID +C IGERR - 1, GRID REPRESENTATION TYPE NOT VALID +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: CRAY CFT77 FORTRAN 77, IBM370 VS FORTRAN +C MACHINE: CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256, HDS +C +C$$$ +C + INTEGER IGDS (*) +C + CHARACTER*1 GDS (*) +C + ISUM = 0 + IGERR = 0 +C +C PRINT *,' ' +C PRINT *,'(W3FI74-IGDS = )' +C PRINT *,(IGDS(I),I=1,18) +C PRINT *,' ' +C +C COMPUTE LENGTH OF GDS IN OCTETS (OCTETS 1-3) +C LENGDS = 32 FOR LAT/LON, GNOMIC, GAUSIAN LAT/LON, +C POLAR STEREOGRAPHIC, SPHERICAL HARMONICS, +C ROTATED LAT/LON E-STAGGER +C LENGDS = 34 ROTATED LAT/LON A,B,C,D STAGGERS +C LENGDS = 42 FOR MERCATOR, LAMBERT, TANGENT CONE +C LENGDS = 178 FOR MERCATOR, LAMBERT, TANGENT CONE +C + IF (IGDS(3) .EQ. 0 .OR. IGDS(3) .EQ. 2 .OR. + & IGDS(3) .EQ. 4 .OR. IGDS(3) .EQ. 5 .OR. + & IGDS(3) .EQ. 50 .OR. IGDS(3) .EQ. 201.OR. + & IGDS(3) .EQ. 202.OR. IGDS(3) .EQ. 203.OR. + & IGDS(3) .EQ. 204 ) THEN + LENGDS = 32 +C +C CORRECTION FOR GRIDS 37-44 +C + IF (IGDS(3).EQ.0.AND.IGDS(1).EQ.0.AND.IGDS(2).NE. + & 255) THEN + LENGDS = IGDS(5) * 2 + 32 + ENDIF + ELSE IF (IGDS(3) .EQ. 1 .OR. IGDS(3) .EQ. 3 .OR. + & IGDS(3) .EQ. 13) THEN + LENGDS = 42 + ELSE IF (IGDS(3) .EQ. 205) THEN + LENGDS = 34 + ELSE +C PRINT *,' W3FI74 ERROR, GRID REPRESENTATION TYPE NOT VALID' + IGERR = 1 + RETURN + ENDIF +C +C PUT LENGTH OF GDS SECTION IN BYTES 1,2,3 +C + GDS(1) = CHAR(MOD(LENGDS/65536,256)) + GDS(2) = CHAR(MOD(LENGDS/ 256,256)) + GDS(3) = CHAR(MOD(LENGDS ,256)) +C +C OCTET 4 = NV, NUMBER OF VERTICAL COORDINATE PARAMETERS +C OCTET 5 = PV, PL OR 255 +C OCTET 6 = DATA REPRESENTATION TYPE (TABLE 6) +C + GDS(4) = CHAR(IGDS(1)) + GDS(5) = CHAR(IGDS(2)) + GDS(6) = CHAR(IGDS(3)) +C +C FILL OCTET THE REST OF THE GDS BASED ON DATA REPRESENTATION +C TYPE (TABLE 6) +C +C$$ +C PROCESS ROTATED LAT/LON A,B,C,D STAGGERS +C + IF (IGDS(3).EQ.205) THEN + GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) + GDS( 8) = CHAR(MOD(IGDS(4) ,256)) + GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) + GDS(10) = CHAR(MOD(IGDS(5) ,256)) + LATO = IGDS(6) ! LAT OF FIRST POINT + IF (LATO .LT. 0) THEN + LATO = -LATO + LATO = IOR(LATO,8388608) + ENDIF + GDS(11) = CHAR(MOD(LATO/65536,256)) + GDS(12) = CHAR(MOD(LATO/ 256,256)) + GDS(13) = CHAR(MOD(LATO ,256)) + LONO = IGDS(7) ! LON OF FIRST POINT + IF (LONO .LT. 0) THEN + LONO = -LONO + LONO = IOR(LONO,8388608) + ENDIF + GDS(14) = CHAR(MOD(LONO/65536,256)) + GDS(15) = CHAR(MOD(LONO/ 256,256)) + GDS(16) = CHAR(MOD(LONO ,256)) + LATEXT = IGDS(9) ! CENTER LAT + IF (LATEXT .LT. 0) THEN + LATEXT = -LATEXT + LATEXT = IOR(LATEXT,8388608) + ENDIF + GDS(18) = CHAR(MOD(LATEXT/65536,256)) + GDS(19) = CHAR(MOD(LATEXT/ 256,256)) + GDS(20) = CHAR(MOD(LATEXT ,256)) + LONEXT = IGDS(10) ! CENTER LON + IF (LONEXT .LT. 0) THEN + LONEXT = -LONEXT + LONEXT = IOR(LONEXT,8388608) + ENDIF + GDS(21) = CHAR(MOD(LONEXT/65536,256)) + GDS(22) = CHAR(MOD(LONEXT/ 256,256)) + GDS(23) = CHAR(MOD(LONEXT ,256)) + GDS(24) = CHAR(MOD(IGDS(11)/256,256)) + GDS(25) = CHAR(MOD(IGDS(11) ,256)) + GDS(26) = CHAR(MOD(IGDS(12)/256,256)) + GDS(27) = CHAR(MOD(IGDS(12) ,256)) + GDS(28) = CHAR(IGDS(13)) + LATO = IGDS(14) ! LAT OF LAST POINT + IF (LATO .LT. 0) THEN + LATO = -LATO + LATO = IOR(LATO,8388608) + ENDIF + GDS(29) = CHAR(MOD(LATO/65536,256)) + GDS(30) = CHAR(MOD(LATO/ 256,256)) + GDS(31) = CHAR(MOD(LATO ,256)) + LONO = IGDS(15) ! LON OF LAST POINT + IF (LONO .LT. 0) THEN + LONO = -LONO + LONO = IOR(LONO,8388608) + ENDIF + GDS(32) = CHAR(MOD(LONO/65536,256)) + GDS(33) = CHAR(MOD(LONO/ 256,256)) + GDS(34) = CHAR(MOD(LONO ,256)) +C +C PROCESS LAT/LON GRID TYPES OR GAUSSIAN GRID OR ARAKAWA +C STAGGERED, SEMI-STAGGERED, OR FILLED E-GRIDS +C + ELSEIF (IGDS(3).EQ.0.OR.IGDS(3).EQ.4.OR. + & IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR. + & IGDS(3).EQ.203.OR.IGDS(3).EQ.204) THEN + GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) + GDS( 8) = CHAR(MOD(IGDS(4) ,256)) + GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) + GDS(10) = CHAR(MOD(IGDS(5) ,256)) + LATO = IGDS(6) + IF (LATO .LT. 0) THEN + LATO = -LATO + LATO = IOR(LATO,8388608) + ENDIF + GDS(11) = CHAR(MOD(LATO/65536,256)) + GDS(12) = CHAR(MOD(LATO/ 256,256)) + GDS(13) = CHAR(MOD(LATO ,256)) + LONO = IGDS(7) + IF (LONO .LT. 0) THEN + LONO = -LONO + LONO = IOR(LONO,8388608) + ENDIF + GDS(14) = CHAR(MOD(LONO/65536,256)) + GDS(15) = CHAR(MOD(LONO/ 256,256)) + GDS(16) = CHAR(MOD(LONO ,256)) + LATEXT = IGDS(9) + IF (LATEXT .LT. 0) THEN + LATEXT = -LATEXT + LATEXT = IOR(LATEXT,8388608) + ENDIF + GDS(18) = CHAR(MOD(LATEXT/65536,256)) + GDS(19) = CHAR(MOD(LATEXT/ 256,256)) + GDS(20) = CHAR(MOD(LATEXT ,256)) + LONEXT = IGDS(10) + IF (LONEXT .LT. 0) THEN + LONEXT = -LONEXT + LONEXT = IOR(LONEXT,8388608) + ENDIF + GDS(21) = CHAR(MOD(LONEXT/65536,256)) + GDS(22) = CHAR(MOD(LONEXT/ 256,256)) + GDS(23) = CHAR(MOD(LONEXT ,256)) + IRES = IAND(IGDS(8),128) + IF (IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR. + & IGDS(3).EQ.203.OR.IGDS(3).EQ.204) THEN + GDS(24) = CHAR(MOD(IGDS(11)/256,256)) + GDS(25) = CHAR(MOD(IGDS(11) ,256)) + ELSE IF (IRES.EQ.0) THEN + GDS(24) = CHAR(255) + GDS(25) = CHAR(255) + ELSE + GDS(24) = CHAR(MOD(IGDS(12)/256,256)) + GDS(25) = CHAR(MOD(IGDS(12) ,256)) + END IF + IF (IGDS(3).EQ.4) THEN + GDS(26) = CHAR(MOD(IGDS(11)/256,256)) + GDS(27) = CHAR(MOD(IGDS(11) ,256)) + ELSE IF (IGDS(3).EQ.201.OR.IGDS(3).EQ.202.OR. + & IGDS(3).EQ.203.OR.IGDS(3).EQ.204)THEN + GDS(26) = CHAR(MOD(IGDS(12)/256,256)) + GDS(27) = CHAR(MOD(IGDS(12) ,256)) + ELSE IF (IRES.EQ.0) THEN + GDS(26) = CHAR(255) + GDS(27) = CHAR(255) + ELSE + GDS(26) = CHAR(MOD(IGDS(11)/256,256)) + GDS(27) = CHAR(MOD(IGDS(11) ,256)) + END IF + GDS(28) = CHAR(IGDS(13)) + GDS(29) = CHAR(0) + GDS(30) = CHAR(0) + GDS(31) = CHAR(0) + GDS(32) = CHAR(0) + IF (LENGDS.GT.32) THEN + ISUM = 0 + I = 19 + DO 10 J = 33,LENGDS,2 + ISUM = ISUM + IGDS(I) + GDS(J) = CHAR(MOD(IGDS(I)/256,256)) + GDS(J+1) = CHAR(MOD(IGDS(I) ,256)) + I = I + 1 + 10 CONTINUE + END IF +C +C$$ PROCESS MERCATOR GRID TYPES +C + ELSE IF (IGDS(3) .EQ. 1) THEN + GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) + GDS( 8) = CHAR(MOD(IGDS(4) ,256)) + GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) + GDS(10) = CHAR(MOD(IGDS(5) ,256)) + LATO = IGDS(6) + IF (LATO .LT. 0) THEN + LATO = -LATO + LATO = IOR(LATO,8388608) + ENDIF + GDS(11) = CHAR(MOD(LATO/65536,256)) + GDS(12) = CHAR(MOD(LATO/ 256,256)) + GDS(13) = CHAR(MOD(LATO ,256)) + LONO = IGDS(7) + IF (LONO .LT. 0) THEN + LONO = -LONO + LONO = IOR(LONO,8388608) + ENDIF + GDS(14) = CHAR(MOD(LONO/65536,256)) + GDS(15) = CHAR(MOD(LONO/ 256,256)) + GDS(16) = CHAR(MOD(LONO ,256)) + LATEXT = IGDS(9) + IF (LATEXT .LT. 0) THEN + LATEXT = -LATEXT + LATEXT = IOR(LATEXT,8388608) + ENDIF + GDS(18) = CHAR(MOD(LATEXT/65536,256)) + GDS(19) = CHAR(MOD(LATEXT/ 256,256)) + GDS(20) = CHAR(MOD(LATEXT ,256)) + LONEXT = IGDS(10) + IF (LONEXT .LT. 0) THEN + LONEXT = -LONEXT + LONEXT = IOR(LONEXT,8388608) + ENDIF + GDS(21) = CHAR(MOD(LONEXT/65536,256)) + GDS(22) = CHAR(MOD(LONEXT/ 256,256)) + GDS(23) = CHAR(MOD(LONEXT ,256)) + GDS(24) = CHAR(MOD(IGDS(13)/65536,256)) + GDS(25) = CHAR(MOD(IGDS(13)/ 256,256)) + GDS(26) = CHAR(MOD(IGDS(13) ,256)) + GDS(27) = CHAR(0) + GDS(28) = CHAR(IGDS(14)) + GDS(29) = CHAR(MOD(IGDS(12)/65536,256)) + GDS(30) = CHAR(MOD(IGDS(12)/ 256,256)) + GDS(31) = CHAR(MOD(IGDS(12) ,256)) + GDS(32) = CHAR(MOD(IGDS(11)/65536,256)) + GDS(33) = CHAR(MOD(IGDS(11)/ 256,256)) + GDS(34) = CHAR(MOD(IGDS(11) ,256)) + GDS(35) = CHAR(0) + GDS(36) = CHAR(0) + GDS(37) = CHAR(0) + GDS(38) = CHAR(0) + GDS(39) = CHAR(0) + GDS(40) = CHAR(0) + GDS(41) = CHAR(0) + GDS(42) = CHAR(0) +C$$ PROCESS LAMBERT CONFORMAL GRID TYPES + ELSE IF (IGDS(3) .EQ. 3) THEN + GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) + GDS( 8) = CHAR(MOD(IGDS(4) ,256)) + GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) + GDS(10) = CHAR(MOD(IGDS(5) ,256)) + LATO = IGDS(6) + IF (LATO .LT. 0) THEN + LATO = -LATO + LATO = IOR(LATO,8388608) + ENDIF + GDS(11) = CHAR(MOD(LATO/65536,256)) + GDS(12) = CHAR(MOD(LATO/ 256,256)) + GDS(13) = CHAR(MOD(LATO ,256)) + LONO = IGDS(7) + IF (LONO .LT. 0) THEN + LONO = -LONO + LONO = IOR(LONO,8388608) + ENDIF + GDS(14) = CHAR(MOD(LONO/65536,256)) + GDS(15) = CHAR(MOD(LONO/ 256,256)) + GDS(16) = CHAR(MOD(LONO ,256)) + LONM = IGDS(9) + IF (LONM .LT. 0) THEN + LONM = -LONM + LONM = IOR(LONM,8388608) + ENDIF + GDS(18) = CHAR(MOD(LONM/65536,256)) + GDS(19) = CHAR(MOD(LONM/ 256,256)) + GDS(20) = CHAR(MOD(LONM ,256)) + GDS(21) = CHAR(MOD(IGDS(10)/65536,256)) + GDS(22) = CHAR(MOD(IGDS(10)/ 256,256)) + GDS(23) = CHAR(MOD(IGDS(10) ,256)) + GDS(24) = CHAR(MOD(IGDS(11)/65536,256)) + GDS(25) = CHAR(MOD(IGDS(11)/ 256,256)) + GDS(26) = CHAR(MOD(IGDS(11) ,256)) + GDS(27) = CHAR(IGDS(12)) + GDS(28) = CHAR(IGDS(13)) + GDS(29) = CHAR(MOD(IGDS(15)/65536,256)) + GDS(30) = CHAR(MOD(IGDS(15)/ 256,256)) + GDS(31) = CHAR(MOD(IGDS(15) ,256)) + GDS(32) = CHAR(MOD(IGDS(16)/65536,256)) + GDS(33) = CHAR(MOD(IGDS(16)/ 256,256)) + GDS(34) = CHAR(MOD(IGDS(16) ,256)) + GDS(35) = CHAR(MOD(IGDS(17)/65536,256)) + GDS(36) = CHAR(MOD(IGDS(17)/ 256,256)) + GDS(37) = CHAR(MOD(IGDS(17) ,256)) + GDS(38) = CHAR(MOD(IGDS(18)/65536,256)) + GDS(39) = CHAR(MOD(IGDS(18)/ 256,256)) + GDS(40) = CHAR(MOD(IGDS(18) ,256)) + GDS(41) = CHAR(0) + GDS(42) = CHAR(0) +C$$ PROCESS POLAR STEREOGRAPHIC GRID TYPES + ELSE IF (IGDS(3) .EQ. 5) THEN + GDS( 7) = CHAR(MOD(IGDS(4)/256,256)) + GDS( 8) = CHAR(MOD(IGDS(4) ,256)) + GDS( 9) = CHAR(MOD(IGDS(5)/256,256)) + GDS(10) = CHAR(MOD(IGDS(5) ,256)) + LATO = IGDS(6) + IF (LATO .LT. 0) THEN + LATO = -LATO + LATO = IOR(LATO,8388608) + ENDIF + GDS(11) = CHAR(MOD(LATO/65536,256)) + GDS(12) = CHAR(MOD(LATO/ 256,256)) + GDS(13) = CHAR(MOD(LATO ,256)) + LONO = IGDS(7) + IF (LONO .LT. 0) THEN + LONO = -LONO + LONO = IOR(LONO,8388608) + ENDIF + GDS(14) = CHAR(MOD(LONO/65536,256)) + GDS(15) = CHAR(MOD(LONO/ 256,256)) + GDS(16) = CHAR(MOD(LONO ,256)) + LONM = IGDS(9) + IF (LONM .LT. 0) THEN + LONM = -LONM + LONM = IOR(LONM,8388608) + ENDIF + GDS(18) = CHAR(MOD(LONM/65536,256)) + GDS(19) = CHAR(MOD(LONM/ 256,256)) + GDS(20) = CHAR(MOD(LONM ,256)) + GDS(21) = CHAR(MOD(IGDS(10)/65536,256)) + GDS(22) = CHAR(MOD(IGDS(10)/ 256,256)) + GDS(23) = CHAR(MOD(IGDS(10) ,256)) + GDS(24) = CHAR(MOD(IGDS(11)/65536,256)) + GDS(25) = CHAR(MOD(IGDS(11)/ 256,256)) + GDS(26) = CHAR(MOD(IGDS(11) ,256)) + GDS(27) = CHAR(IGDS(12)) + GDS(28) = CHAR(IGDS(13)) + GDS(29) = CHAR(0) + GDS(30) = CHAR(0) + GDS(31) = CHAR(0) + GDS(32) = CHAR(0) + ENDIF +C PRINT 10,(GDS(IG),IG=1,32) +C10 FORMAT (' GDS= ',32(1X,Z2.2)) +C +C COMPUTE NUMBER OF POINTS IN GRID BY MULTIPLYING +C IGDS(4) AND IGDS(5) ... NEEDED FOR PACKER +C + IF (IGDS(3).EQ.0.AND.IGDS(1).EQ.0.AND.IGDS(2).NE. + & 255) THEN + NPTS = ISUM + ELSE + NPTS = IGDS(4) * IGDS(5) + ENDIF +C +C 'IOR' ICOMP-BIT 5 RESOLUTION & COMPONENT FLAG FOR WINDS +C WITH IGDS(8) INFO (REST OF RESOLUTION & COMPONENT FLAG DATA) +C + ICOMP = ISHFT(ICOMP,3) + GDS(17) = CHAR(IOR(IGDS(8),ICOMP)) +C + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi75.f b/WPS/ungrib/src/ngl/w3/w3fi75.f new file mode 100755 index 00000000..e58cf9c9 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi75.f @@ -0,0 +1,1596 @@ + SUBROUTINE W3FI75 (IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL, + & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS) +C $$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI75 GRIB PACK DATA AND FORM BDS OCTETS(1-11) +C PRGMMR: FARLEY ORG: NMC421 DATE:94-11-22 +C +C ABSTRACT: THIS ROUTINE PACKS A GRIB FIELD AND FORMS OCTETS(1-11) +C OF THE BINARY DATA SECTION (BDS). +C +C PROGRAM HISTORY LOG: +C 92-07-10 M. FARLEY ORIGINAL AUTHOR +C 92-10-01 R.E.JONES CORRECTION FOR FIELD OF CONSTANT DATA +C 92-10-16 R.E.JONES GET RID OF ARRAYS FP AND INT +C 93-08-06 CAVANAUGH ADDED ROUTINES FI7501, FI7502, FI7503 +C TO ALLOW SECOND ORDER PACKING IN PDS. +C 93-07-21 STACKPOLE ASSORTED REPAIRS TO GET 2ND DIFF PACK IN +C 93-10-28 CAVANAUGH COMMENTED OUT NONOPERATIONAL PRINTS AND +C WRITE STATEMENTS +C 93-12-15 CAVANAUGH CORRECTED LOCATION OF START OF FIRST ORDER +C VALUES AND START OF SECOND ORDER VALUES TO +C REFLECT A BYTE LOCATION IN THE BDS INSTEAD +C OF AN OFFSET IN SUBROUTINE FI7501. +C 94-01-27 CAVANAUGH ADDED IGDS AS INPUT ARGUMENT TO THIS ROUTINE +C AND ADDED PDS AND IGDS ARRAYS TO THE CALL TO +C W3FI82 TO PROVIDE INFORMATION NEEDED FOR +C BOUSTROPHEDONIC PROCESSING. +C 94-05-25 CAVANAUGH SUBROUTINE FI7503 HAS BEEN ADDED TO PROVIDE +C FOR ROW BY ROW OR COLUMN BY COLUMN SECOND +C ORDER PACKING. THIS FEATURE CAN BE ACTIVATED +C BY SETTING IBDSFL(7) TO ZERO. +C 94-07-08 CAVANAUGH COMMENTED OUT PRINT STATEMENTS USED FOR DEBUG +C 94-11-22 FARLEY ENLARGED WORK ARRAYS TO HANDLE .5DEGREE GRIDS +C 95-06-01 R.E.JONES CORRECTION FOR NUMBER OF UNUSED BITS AT END +C OF SECTION 4, IN BDS BYTE 4, BITS 5-8. +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL W3FI75 (IBITL,ITYPE,ITOSS,FLD,IFLD,IBMAP,IBDSFL, +C & NPTS,BDS11,IPFLD,PFLD,LEN,LENBDS,IBERR,PDS,IGDS) +C INPUT ARGUMENT LIST: +C IBITL - 0, COMPUTER COMPUTES PACKING LENGTH FROM POWER +C OF 2 THAT BEST FITS THE DATA. +C 8, 12, ETC. COMPUTER RESCALES DATA TO FIT INTO +C SET NUMBER OF BITS. +C ITYPE - 0 = IF INPUT DATA IS FLOATING POINT (FLD) +C 1 = IF INPUT DATA IS INTEGER (IFLD) +C ITOSS - 0 = NO BIT MAP IS INCLUDED (DON'T TOSS DATA) +C 1 = TOSS NULL DATA ACCORDING TO IBMAP +C FLD - REAL ARRAY OF DATA TO BE PACKED IF ITYPE=0 +C IFLD - INTEGER ARRAY TO BE PACKED IF ITYPE=1 +C IBMAP - BIT MAP SUPPLIED FROM USER +C IBDSFL - INTEGER ARRAY CONTAINING TABLE 11 FLAG INFO +C BDS OCTET 4: +C (1) 0 = GRID POINT DATA +C 1 = SPHERICAL HARMONIC COEFFICIENTS +C (2) 0 = SIMPLE PACKING +C 1 = SECOND ORDER PACKING +C (3) 0 = ORIGINAL DATA WERE FLOATING POINT VALUES +C 1 = ORIGINAL DATA WERE INTEGER VALUES +C (4) 0 = NO ADDITIONAL FLAGS AT OCTET 14 +C 1 = OCTET 14 CONTAINS FLAG BITS 5-12 +C (5) 0 = RESERVED - ALWAYS SET TO 0 +C (6) 0 = SINGLE DATUM AT EACH GRID POINT +C 1 = MATRIX OF VALUES AT EACH GRID POINT +C (7) 0 = NO SECONDARY BIT MAPS +C 1 = SECONDARY BIT MAPS PRESENT +C (8) 0 = SECOND ORDER VALUES HAVE CONSTANT WIDTH +C 1 = SECOND ORDER VALUES HAVE DIFFERENT WIDTHS +C NPTS - NUMBER OF GRIDPOINTS IN ARRAY TO BE PACKED +C IGDS - ARRAY OF GDS INFORMATION +C +C OUTPUT ARGUMENT LIST: +C BDS11 - FIRST 11 OCTETS OF BDS +C PFLD - PACKED GRIB FIELD +C LEN - LENGTH OF PFLD +C LENBDS - LENGTH OF BDS +C IBERR - 1, ERROR CONVERTING IEEE F.P. NUMBER TO IBM370 F.P. +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 +C +C $$ +C + REAL FLD(*) +C REAL FWORK(260000) +C +C FWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY +C + REAL FWORK(NPTS) + REAL RMIN,REFNCE +C + INTEGER IPFLD(*) + INTEGER IBDSFL(*) + INTEGER IBMAP(*) + INTEGER IFLD(*),IGDS(*) +C INTEGER IWORK(260000) +C +C IWORK CAN USE DYNAMIC ALLOCATION OF MEMORY ON CRAY +C + INTEGER IWORK(NPTS) +C + LOGICAL CONST +C + CHARACTER * 1 BDS11(11),PDS(*) + CHARACTER * 1 PFLD(*) + CHARACTER * 1 CIEXP(8) + CHARACTER * 1 CIMANT(8) +C + EQUIVALENCE (IEXP,CIEXP(1)) + EQUIVALENCE (IMANT,CIMANT(1)) +C +C 1.0 PACK THE FIELD. +C +C 1.1 TOSS DATA IF BITMAP BEING USED, +C MOVING 'DATA' TO WORK AREA... +C + CONST = .FALSE. + IBERR = 0 + IW = 0 +C + IF (ITOSS .EQ. 1) THEN + IF (ITYPE .EQ. 0) THEN + DO 110 IT=1,NPTS + IF (IBMAP(IT) .EQ. 1) THEN + IW = IW + 1 + FWORK(IW) = FLD(IT) + ENDIF + 110 CONTINUE + NPTS = IW + ELSE IF (ITYPE .EQ. 1) THEN + DO 111 IT=1,NPTS + IF (IBMAP(IT) .EQ. 1) THEN + IW = IW + 1 + IWORK(IW) = IFLD(IT) + ENDIF + 111 CONTINUE + NPTS = IW + ENDIF +C +C ELSE, JUST MOVE DATA TO WORK ARRAY +C + ELSE IF (ITOSS .EQ. 0) THEN + IF (ITYPE .EQ. 0) THEN + DO 112 IT=1,NPTS + FWORK(IT) = FLD(IT) + 112 CONTINUE + ELSE IF (ITYPE .EQ. 1) THEN + DO 113 IT=1,NPTS + IWORK(IT) = IFLD(IT) + 113 CONTINUE + ENDIF + ENDIF +C +C 1.2 CONVERT DATA IF NEEDED PRIOR TO PACKING. +C (INTEGER TO F.P. OR F.P. TO INTEGER) +C ITYPE = 0...FLOATING POINT DATA +C IBITL = 0...PACK IN LEAST # BITS...CONVERT TO INTEGER +C ITYPE = 1...INTEGER DATA +C IBITL > 0...PACK IN FIXED # BITS...CONVERT TO FLOATING POINT +C + IF (ITYPE .EQ. 0 .AND. IBITL .EQ. 0) THEN + DO 120 IF=1,NPTS + IWORK(IF) = NINT(FWORK(IF)) + 120 CONTINUE + ELSE IF (ITYPE .EQ. 1 .AND. IBITL .NE. 0) THEN + DO 123 IF=1,NPTS + FWORK(IF) = FLOAT(IWORK(IF)) + 123 CONTINUE + ENDIF +C +C 1.3 PACK THE DATA. +C + IF (IBDSFL(2).NE.0) THEN +C SECOND ORDER PACKING +C +C PRINT*,' DOING SECOND ORDER PACKING...' + IF (IBITL.EQ.0) THEN +C +C PRINT*,' AND VARIABLE BIT PACKING' +C +C WORKING WITH INTEGER VALUES +C SINCE DOING VARIABLE BIT PACKING +C + MAX = IWORK(1) + MIN = IWORK(1) + DO 300 I = 2, NPTS + IF (IWORK(I).LT.MIN) THEN + MIN = IWORK(I) + ELSE IF (IWORK(I).GT.MAX) THEN + MAX = IWORK(I) + END IF + 300 CONTINUE +C EXTRACT MINIMA + DO 400 I = 1, NPTS +C IF (IWORK(I).LT.0) THEN +C PRINT *,'MINIMA 400',I,IWORK(I),NPTS +C END IF + IWORK(I) = IWORK(I) - MIN + 400 CONTINUE + REFNCE = MIN + IDIFF = MAX - MIN +C PRINT *,'REFERENCE VALUE',REFNCE +C +C WRITE (6,FMT='('' MINIMA REMOVED = '',/, +C & 10(3X,10I10,/))') (IWORK(I),I=1,6) +C WRITE (6,FMT='('' END OF ARRAY = '',/, +C & 10(3X,10I10,/))') (IWORK(I),I=NPTS-5,NPTS) +C +C FIND BIT WIDTH OF IDIFF +C + CALL FI7505 (IDIFF,KWIDE) +C PRINT*,' BIT WIDTH FOR ORIGINAL DATA', KWIDE + ISCAL2 = 0 +C +C MULTIPLICATIVE SCALE FACTOR SET TO 1 +C IN ANTICIPATION OF POSSIBLE USE IN GLAHN 2DN DIFF +C + SCAL2 = 1. +C + ELSE +C +C PRINT*,' AND FIXED BIT PACKING, IBITL = ', IBITL +C FIXED BIT PACKING +C - LENGTH OF FIELD IN IBITL +C - MUST BE REAL DATA +C FLOATING POINT INPUT +C + RMAX = FWORK(1) + RMIN = FWORK(1) + DO 100 I = 2, NPTS + IF (FWORK(I).LT.RMIN) THEN + RMIN = FWORK(I) + ELSE IF (FWORK(I).GT.RMAX) THEN + RMAX = FWORK(I) + END IF + 100 CONTINUE + REFNCE = RMIN +C PRINT *,'100 REFERENCE',REFNCE +C EXTRACT MINIMA + DO 200 I = 1, NPTS + FWORK(I) = FWORK(I) - RMIN + 200 CONTINUE +C PRINT *,'REFERENCE VALUE',REFNCE +C WRITE (6,FMT='('' MINIMA REMOVED = '',/, +C & 10(3X,10F8.2,/))') (FWORK(I),I=1,6) +C WRITE (6,FMT='('' END OF ARRAY = '',/, +C & 10(3X,10F8.2,/))') (FWORK(I),I=NPTS-5,NPTS) +C FIND LARGEST DELTA + IDELT = NINT(RMAX - RMIN) +C DO BINARY SCALING +C FIND OUT WHAT BINARY SCALE FACTOR +C PERMITS CONTAINMENT OF +C LARGEST DELTA + CALL FI7505 (IDELT,IWIDE) +C +C BINARY SCALING +C + ISCAL2 = IWIDE - IBITL +C PRINT *,'SCALING NEEDED TO FIT =',ISCAL2 +C PRINT*,' RANGE OF = ',IDELT +C +C EXPAND DATA WITH BINARY SCALING +C CONVERT TO INTEGER + SCAL2 = 2.0**ISCAL2 + SCAL2 = 1./ SCAL2 + DO 600 I = 1, NPTS + IWORK(I) = NINT(FWORK(I) * SCAL2) + 600 CONTINUE + KWIDE = IBITL + END IF +C +C ***************************************************************** +C +C FOLLOWING IS FOR GLAHN SECOND DIFFERENCING +C NOT STANDARD GRIB +C +C TEST FOR SECOND DIFFERENCE PACKING +C BASED OF SIZE OF PDS - SIZE IN FIRST 3 BYTES +C + CALL GBYTE (PDS,IPDSIZ,0,24) + IF (IPDSIZ.EQ.50) THEN +C PRINT*,' DO SECOND DIFFERENCE PACKING ' +C +C GLAHN PACKING TO 2ND DIFFS +C +C WRITE (6,FMT='('' CALL TO W3FI82 WITH = '',/, +C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS) +C + CALL W3FI82 (IWORK,FVAL1,FDIFF1,NPTS,PDS,IGDS) +C +C PRINT *,'GLAHN',FVAL1,FDIFF1 +C WRITE (6,FMT='('' OUT FROM W3FI82 WITH = '',/, +C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS) +C +C MUST NOW RE-REMOVE THE MINIMUM VALUE +C OF THE SECOND DIFFERENCES TO ASSURE +C ALL POSITIVE NUMBERS FOR SECOND ORDER GRIB PACKING +C +C ORIGINAL REFERENCE VALUE ADDED TO FIRST POINT +C VALUE FROM THE 2ND DIFF PACKER TO BE ADDED +C BACK IN WHEN THE 2ND DIFF VALUES ARE +C RECONSTRUCTED BACK TO THE BASIC VALUES +C +C ALSO, THE REFERENCE VALUE IS +C POWER-OF-TWO SCALED TO MATCH +C FVAL1. ALL OF THIS SCALING +C WILL BE REMOVED AFTER THE +C GLAHN SECOND DIFFERENCING IS UNDONE. +C THE SCALING FACTOR NEEDED TO DO THAT +C IS SAVED IN THE PDS AS A SIGNED POSITIVE +C TWO BYTE INTEGER +C +C THE SCALING FOR THE 2ND DIF PACKED +C VALUES IS PROPERLY SET TO ZERO +C + FVAL1 = FVAL1 + REFNCE*SCAL2 +C FIRST TEST TO SEE IF +C ON 32 OR 64 BIT COMPUTER + CALL W3FI01(LW) + IF (LW.EQ.4) THEN + CALL W3FI76 (FVAL1,IEXP,IMANT,32) + ELSE + CALL W3FI76 (FVAL1,IEXP,IMANT,64) + END IF + CALL SBYTE (PDS,IEXP,320,8) + CALL SBYTE (PDS,IMANT,328,24) +C + IF (LW.EQ.4) THEN + CALL W3FI76 (FDIFF1,IEXP,IMANT,32) + ELSE + CALL W3FI76 (FDIFF1,IEXP,IMANT,64) + END IF + CALL SBYTE (PDS,IEXP,352,8) + CALL SBYTE (PDS,IMANT,360,24) +C +C TURN ISCAL2 INTO SIGNED POSITIVE INTEGER +C AND STORE IN TWO BYTES +C + IF(ISCAL2.GE.0) THEN + CALL SBYTE (PDS,ISCAL2,384,16) + ELSE + CALL SBYTE (PDS,1,384,1) + ISCAL2 = - ISCAL2 + CALL SBYTE( PDS,ISCAL2,385,15) + ENDIF +C + MAX = IWORK(1) + MIN = IWORK(1) + DO 700 I = 2, NPTS + IF (IWORK(I).LT.MIN) THEN + MIN = IWORK(I) + ELSE IF (IWORK(I).GT.MAX) THEN + MAX = IWORK(I) + END IF + 700 CONTINUE +C EXTRACT MINIMA + DO 710 I = 1, NPTS + IWORK(I) = IWORK(I) - MIN + 710 CONTINUE + REFNCE = MIN +C PRINT *,'710 REFERENCE',REFNCE + ISCAL2 = 0 +C +C AND RESET VALUE OF KWIDE - THE BIT WIDTH +C FOR THE RANGE OF THE VALUES +C + IDIFF = MAX - MIN + CALL FI7505 (IDIFF,KWIDE) +C +C PRINT*,'BIT WIDTH (KWIDE) OF 2ND DIFFS', KWIDE +C +C **************************** END OF GLAHN PACKING ************ + ELSE IF (IBDSFL(2).EQ.1.AND.IBDSFL(7).EQ.0) THEN +C HAVE SECOND ORDER PACKING WITH NO SECOND ORDER +C BIT MAP. ERGO ROW BY ROW - COL BY COL + CALL FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, + * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS) + RETURN + END IF +C WRITE (6,FMT='('' CALL TO FI7501 WITH = '',/, +C & 10(3X,10I6,/))') (IWORK(I),I=1,NPTS) +C WRITE (6,FMT='('' END OF ARRAY = '',/, +C & 10(3X,10I6,/))') (IWORK(I),I=NPTS-5,NPTS) +C PRINT*,' REFNCE,ISCAL2, KWIDE AT CALL TO FI7501', +C & REFNCE, ISCAL2,KWIDE +C +C SECOND ORDER PACKING +C + CALL FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, + * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE) +C +C BDS COMPLETELY ASSEMBLED IN FI7501 FOR SECOND ORDER +C PACKING. +C + ELSE +C SIMPLE PACKING +C +C PRINT*,' SIMPLE FIRST ORDER PACKING...' + IF (IBITL.EQ.0) THEN +C PRINT*,' WITH VARIABLE BIT LENGTH' +C +C WITH VARIABLE BIT LENGTH, ADJUSTED +C TO ACCOMMODATE LARGEST VALUE +C BINARY SCALING ALWAYS = 0 +C + CALL W3FI58(IWORK,NPTS,IWORK,PFLD,NBITS,LEN,KMIN) + RMIN = KMIN + REFNCE = RMIN + ISCALE = 0 +C PRINT*,' BIT LENGTH CAME OUT AT ...',NBITS +C +C SET CONST .TRUE. IF ALL VALUES ARE THE SAME +C + IF (LEN.EQ.0.AND.NBITS.EQ.0) CONST = .TRUE. +C + ELSE +C PRINT*,' FIXED BIT LENGTH, IBITL = ', IBITL +C +C FIXED BIT LENGTH PACKING (VARIABLE PRECISION) +C VALUES SCALED BY POWER OF 2 (ISCALE) TO +C FIT LARGEST VALUE INTO GIVEN BIT LENGTH (IBITL) +C + CALL W3FI59(FWORK,NPTS,IBITL,IWORK,PFLD,ISCALE,LEN,RMIN) + REFNCE = RMIN +C PRINT *,' SCALING NEEDED TO FIT IS ...', ISCALE + NBITS = IBITL +C +C SET CONST .TRUE. IF ALL VALUES ARE THE SAME +C + IF (LEN.EQ.0) THEN + CONST = .TRUE. + NBITS = 0 + END IF + END IF +C +C COMPUTE LENGTH OF BDS IN OCTETS +C + INUM = NPTS * NBITS + 88 +C PRINT *,'NUMBER OF BITS BEFORE FILL ADDED',INUM +C +C NUMBER OF FILL BITS + NFILL = 0 + NLEFT = MOD(INUM,16) + IF (NLEFT.NE.0) THEN + INUM = INUM + 16 - NLEFT + NFILL = 16 - NLEFT + END IF +C PRINT *,'NUMBER OF BITS AFTER FILL ADDED',INUM +C LENGTH OF BDS IN BYTES + LENBDS = INUM / 8 +C +C 2.0 FORM THE BINARY DATA SECTION (BDS). +C +C CONCANTENATE ALL FIELDS FOR BDS +C +C BYTES 1-3 + CALL SBYTE (BDS11,LENBDS,0,24) +C +C BYTE 4 +C FLAGS + CALL SBYTE (BDS11,IBDSFL(1),24,1) + CALL SBYTE (BDS11,IBDSFL(2),25,1) + CALL SBYTE (BDS11,IBDSFL(3),26,1) + CALL SBYTE (BDS11,IBDSFL(4),27,1) +C NR OF FILL BITS + CALL SBYTE (BDS11,NFILL,28,4) +C +C FILL OCTETS 5-6 WITH THE SCALE FACTOR. +C +C BYTE 5-6 + IF (ISCALE.LT.0) THEN + CALL SBYTE (BDS11,1,32,1) + ISCALE = - ISCALE + CALL SBYTE (BDS11,ISCALE,33,15) + ELSE + CALL SBYTE (BDS11,ISCALE,32,16) + END IF +C +C FILL OCTET 7-10 WITH THE REFERENCE VALUE +C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT +C FLOATING POINT NUMBER +C +C BYTE 7-10 +C REFERENCE VALUE +C FIRST TEST TO SEE IF +C ON 32 OR 64 BIT COMPUTER + CALL W3FI01(LW) + IF (LW.EQ.4) THEN + CALL W3FI76 (REFNCE,IEXP,IMANT,32) + ELSE + CALL W3FI76 (REFNCE,IEXP,IMANT,64) + END IF + CALL SBYTE (BDS11,IEXP,48,8) + CALL SBYTE (BDS11,IMANT,56,24) +C +C +C FILL OCTET 11 WITH THE NUMBER OF BITS. +C +C BYTE 11 + CALL SBYTE (BDS11,NBITS,80,8) + END IF +C + RETURN + END + SUBROUTINE FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, + * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE) +C $$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI7501 BDS SECOND ORDER PACKING +C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-08-06 +C +C ABSTRACT: PERFORM SECONDARY PACKING ON GRID POINT DATA, +C GENERATING ALL BDS INFORMATION. +C +C PROGRAM HISTORY LOG: +C 93-08-06 CAVANAUGH +C 93-12-15 CAVANAUGH CORRECTED LOCATION OF START OF FIRST ORDER +C VALUES AND START OF SECOND ORDER VALUES TO +C REFLECT A BYTE LOCATION IN THE BDS INSTEAD +C OF AN OFFSET. +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL FI7501 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, +C * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE) +C INPUT ARGUMENT LIST: +C IWORK - INTEGER SOURCE ARRAY +C NPTS - NUMBER OF POINTS IN IWORK +C IBDSFL - FLAGS +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C IPFLD - CONTAINS BDS FROM BYTE 12 ON +C BDS11 - CONTAINS FIRST 11 BYTES FOR BDS +C LEN - NUMBER OF BYTES FROM 12 ON +C LENBDS - TOTAL LENGTH OF BDS +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 +C +C $$ + CHARACTER*1 BDS11(*),PDS(*) +C + REAL REFNCE +C + INTEGER ISCAL2,KWIDE + INTEGER LENBDS + INTEGER IPFLD(*) + INTEGER LEN,KBDS(22) + INTEGER IWORK(*) +C OCTET NUMBER IN SECTION, FIRST ORDER PACKING +C INTEGER KBDS(12) +C FLAGS + INTEGER IBDSFL(*) +C EXTENDED FLAGS +C INTEGER KBDS(14) +C OCTET NUMBER FOR SECOND ORDER PACKING +C INTEGER KBDS(15) +C NUMBER OF FIRST ORDER VALUES +C INTEGER KBDS(17) +C NUMBER OF SECOND ORDER PACKED VALUES +C INTEGER KBDS(19) +C WIDTH OF SECOND ORDER PACKING + INTEGER ISOWID(50000) +C SECONDARY BIT MAP + INTEGER ISOBMP(8200) +C FIRST ORDER PACKED VALUES + INTEGER IFOVAL(50000) +C SECOND ORDER PACKED VALUES + INTEGER ISOVAL(100000) +C +C INTEGER KBDS(11) +C BIT WIDTH TABLE + INTEGER IBITS(31) +C + DATA IBITS/1,3,7,15,31,63,127,255,511,1023, + * 2047,4095,8191,16383,32767,65535,131072, + * 262143,524287,1048575,2097151,4194303, + * 8388607,16777215,33554431,67108863, + * 134217727,268435455,536870911, + * 1073741823,2147483647/ +C ---------------------------------- +C INITIALIZE ARRAYS + DO 100 I = 1, 50000 + ISOWID(I) = 0 + IFOVAL(I) = 0 + 100 CONTINUE +C + DO 101 I = 1, 8200 + ISOBMP(I) = 0 + 101 CONTINUE + DO 102 I = 1, 100000 + ISOVAL(I) = 0 + 102 CONTINUE +C INITIALIZE POINTERS +C SECONDARY BIT WIDTH POINTER + IWDPTR = 0 +C SECONDARY BIT MAP POINTER + IBMP2P = 0 +C FIRST ORDER VALUE POINTER + IFOPTR = 0 +C BYTE POINTER TO START OF 1ST ORDER VALUES + KBDS(12) = 0 +C BYTE POINTER TO START OF 2ND ORDER VALUES + KBDS(15) = 0 +C TO CONTAIN NUMBER OF FIRST ORDER VALUES + KBDS(17) = 0 +C TO CONTAIN NUMBER OF SECOND ORDER VALUES + KBDS(19) = 0 +C SECOND ORDER PACKED VALUE POINTER + ISOPTR = 0 +C ======================================================= +C +C DATA IS IN IWORK +C + KBDS(11) = KWIDE +C +C DATA PACKING +C + ITER = 0 + INEXT = 1 + ISTART = 1 +C ----------------------------------------------------------- + KOUNT = 0 +C DO 1 I = 1, NPTS, 10 +C PRINT *,I,(IWORK(K),K=I, I+9) +C 1 CONTINUE + 2000 CONTINUE + ITER = ITER + 1 +C PRINT *,'NEXT ITERATION STARTS AT',ISTART + IF (ISTART.GT.NPTS) THEN + GO TO 4000 + ELSE IF (ISTART.EQ.NPTS) THEN + KPTS = 1 + MXDIFF = 0 + GO TO 2200 + END IF +C +C LOOK FOR REPITITIONS OF A SINGLE VALUE + CALL FI7502 (IWORK,ISTART,NPTS,ISAME) + IF (ISAME.GE.15) THEN + KOUNT = KOUNT + 1 +C PRINT *,'FI7501 - FOUND IDENTICAL SET OF ',ISAME + MXDIFF = 0 + KPTS = ISAME + ELSE +C +C LOOK FOR SETS OF VALUES IN TREND SELECTED RANGE + CALL FI7513 (IWORK,ISTART,NPTS,NMAX,NMIN,INRNGE) +C PRINT *,'ISTART ',ISTART,' INRNGE',INRNGE,NMAX,NMIN + IEND = ISTART + INRNGE - 1 +C DO 2199 NM = ISTART, IEND, 10 +C PRINT *,' ',(IWORK(NM+JK),JK=0,9) +C2199 CONTINUE + MXDIFF = NMAX - NMIN + KPTS = INRNGE + END IF + 2200 CONTINUE +C PRINT *,' RANGE ',MXDIFF,' MAX',NMAX,' MIN',NMIN +C INCREMENT NUMBER OF FIRST ORDER VALUES + KBDS(17) = KBDS(17) + 1 +C ENTER FIRST ORDER VALUE + IF (MXDIFF.GT.0) THEN + DO 2220 LK = 0, KPTS-1 + IWORK(ISTART+LK) = IWORK(ISTART+LK) - NMIN + 2220 CONTINUE + CALL SBYTE (IFOVAL,NMIN,IFOPTR,KBDS(11)) + ELSE + CALL SBYTE (IFOVAL,IWORK(ISTART),IFOPTR,KBDS(11)) + END IF + IFOPTR = IFOPTR + KBDS(11) +C PROCESS SECOND ORDER BIT WIDTH + IF (MXDIFF.GT.0) THEN + DO 2330 KWIDE = 1, 31 + IF (MXDIFF.LE.IBITS(KWIDE)) THEN + GO TO 2331 + END IF + 2330 CONTINUE + 2331 CONTINUE + ELSE + KWIDE = 0 + END IF + CALL SBYTE (ISOWID,KWIDE,IWDPTR,8) + IWDPTR = IWDPTR + 8 +C PRINT *,KWIDE,' IFOVAL=',NMIN,IWORK(ISTART),KPTS +C IF KWIDE NE 0, SAVE SECOND ORDER VALUE + IF (KWIDE.GT.0) THEN + CALL SBYTES (ISOVAL,IWORK(ISTART),ISOPTR,KWIDE,0,KPTS) + ISOPTR = ISOPTR + KPTS * KWIDE + KBDS(19) = KBDS(19) + KPTS +C PRINT *,' SECOND ORDER VALUES' +C PRINT *,(IWORK(ISTART+I),I=0,KPTS-1) + END IF +C ADD TO SECOND ORDER BITMAP + CALL SBYTE (ISOBMP,1,IBMP2P,1) + IBMP2P = IBMP2P + KPTS + ISTART = ISTART + KPTS + GO TO 2000 +C -------------------------------------------------------------- + 4000 CONTINUE +C PRINT *,'THERE WERE ',ITER,' SECOND ORDER GROUPS' +C PRINT *,'THERE WERE ',KOUNT,' STRINGS OF CONSTANTS' +C CONCANTENATE ALL FIELDS FOR BDS +C +C REMAINDER GOES INTO IPFLD + IPTR = 0 +C BYTES 12-13 +C VALUE FOR N1 +C LEAVE SPACE FOR THIS + IPTR = IPTR + 16 +C BYTE 14 +C EXTENDED FLAGS + CALL SBYTE (IPFLD,IBDSFL(5),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(6),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(7),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(8),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(9),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(10),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(11),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(12),IPTR,1) + IPTR = IPTR + 1 +C BYTES 15-16 +C SKIP OVER VALUE FOR N2 + IPTR = IPTR + 16 +C BYTES 17-18 +C P1 + CALL SBYTE (IPFLD,KBDS(17),IPTR,16) + IPTR = IPTR + 16 +C BYTES 19-20 +C P2 + CALL SBYTE (IPFLD,KBDS(19),IPTR,16) + IPTR = IPTR + 16 +C BYTE 21 - RESERVED LOCATION + CALL SBYTE (IPFLD,0,IPTR,8) + IPTR = IPTR + 8 +C BYTES 22 - ? +C WIDTHS OF SECOND ORDER PACKING + IX = (IWDPTR + 32) / 32 + CALL SBYTES (IPFLD,ISOWID,IPTR,32,0,IX) + IPTR = IPTR + IWDPTR +C SECONDARY BIT MAP + IJ = (IBMP2P + 32) / 32 + CALL SBYTES (IPFLD,ISOBMP,IPTR,32,0,IJ) + IPTR = IPTR + IBMP2P + IF (MOD(IPTR,8).NE.0) THEN + IPTR = IPTR + 8 - MOD(IPTR,8) + END IF +C DETERMINE LOCATION FOR START +C OF FIRST ORDER PACKED VALUES + KBDS(12) = IPTR / 8 + 12 +C STORE LOCATION + CALL SBYTE (IPFLD,KBDS(12),0,16) +C MOVE IN FIRST ORDER PACKED VALUES + IPASS = (IFOPTR + 32) / 32 + CALL SBYTES (IPFLD,IFOVAL,IPTR,32,0,IPASS) + IPTR = IPTR + IFOPTR + IF (MOD(IPTR,8).NE.0) THEN + IPTR = IPTR + 8 - MOD(IPTR,8) + END IF +C PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR +C DETERMINE LOCATION FOR START +C OF SECOND ORDER VALUES + KBDS(15) = IPTR / 8 + 12 +C SAVE LOCATION OF SECOND ORDER VALUES + CALL SBYTE (IPFLD,KBDS(15),24,16) +C MOVE IN SECOND ORDER PACKED VALUES + IX = (ISOPTR + 32) / 32 + CALL SBYTES (IPFLD,ISOVAL,IPTR,32,0,IX) + IPTR = IPTR + ISOPTR + NLEFT = MOD(IPTR+88,16) + IF (NLEFT.NE.0) THEN + NLEFT = 16 - NLEFT + IPTR = IPTR + NLEFT + END IF +C COMPUTE LENGTH OF DATA PORTION + LEN = IPTR / 8 +C COMPUTE LENGTH OF BDS + LENBDS = LEN + 11 +C ----------------------------------- +C BYTES 1-3 +C THIS FUNCTION COMPLETED BELOW +C WHEN LENGTH OF BDS IS KNOWN + CALL SBYTE (BDS11,LENBDS,0,24) +C BYTE 4 + CALL SBYTE (BDS11,IBDSFL(1),24,1) + CALL SBYTE (BDS11,IBDSFL(2),25,1) + CALL SBYTE (BDS11,IBDSFL(3),26,1) + CALL SBYTE (BDS11,IBDSFL(4),27,1) +C ENTER NUMBER OF FILL BITS + CALL SBYTE (BDS11,NLEFT,28,4) +C BYTE 5-6 + IF (ISCAL2.LT.0) THEN + CALL SBYTE (BDS11,1,32,1) + ISCAL2 = - ISCAL2 + ELSE + CALL SBYTE (BDS11,0,32,1) + END IF + CALL SBYTE (BDS11,ISCAL2,33,15) +C +C FILL OCTET 7-10 WITH THE REFERENCE VALUE +C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT +C FLOATING POINT NUMBER +C REFERENCE VALUE +C FIRST TEST TO SEE IF +C ON 32 OR 64 BIT COMPUTER + CALL W3FI01(LW) + IF (LW.EQ.4) THEN + CALL W3FI76 (REFNCE,IEXP,IMANT,32) + ELSE + CALL W3FI76 (REFNCE,IEXP,IMANT,64) + END IF + CALL SBYTE (BDS11,IEXP,48,8) + CALL SBYTE (BDS11,IMANT,56,24) +C +C BYTE 11 +C + CALL SBYTE (BDS11,KBDS(11),80,8) +C + RETURN + END + SUBROUTINE FI7502 (IWORK,ISTART,NPTS,ISAME) +C $$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI7502 SECOND ORDER SAME VALUE COLLECTION +C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-06-23 +C +C ABSTRACT: COLLECT SEQUENTIAL SAME VALUES FOR PROCESSING +C AS SECOND ORDER VALUE FOR GRIB MESSAGES. +C +C PROGRAM HISTORY LOG: +C 93-06-23 CAVANAUGH +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL FI7502 (IWORK,ISTART,NPTS,ISAME) +C INPUT ARGUMENT LIST: +C IWORK - ARRAY CONTAINING SOURCE DATA +C ISTART - STARTING LOCATION FOR THIS TEST +C NPTS - NUMBER OF POINTS IN IWORK +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C ISAME - NUMBER OF SEQUENTIAL POINTS HAVING THE SAME VALUE +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 +C +C $$ + INTEGER IWORK(*) + INTEGER ISTART + INTEGER ISAME + INTEGER K + INTEGER NPTS +C ------------------------------------------------------------- + ISAME = 0 + DO 100 K = ISTART, NPTS + IF (IWORK(K).NE.IWORK(ISTART)) THEN + RETURN + END IF + ISAME = ISAME + 1 + 100 CONTINUE + RETURN + END + SUBROUTINE FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, + * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS) +C $$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI7501 ROW BY ROW, COL BY COL PACKING +C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-05-20 +C +C ABSTRACT: PERFORM ROW BY ROW OR COLUMN BY COLUMN PACKING +C GENERATING ALL BDS INFORMATION. +C +C PROGRAM HISTORY LOG: +C 93-08-06 CAVANAUGH +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL FI7503 (IWORK,IPFLD,NPTS,IBDSFL,BDS11, +C * LEN,LENBDS,PDS,REFNCE,ISCAL2,KWIDE,IGDS) +C INPUT ARGUMENT LIST: +C IWORK - INTEGER SOURCE ARRAY +C NPTS - NUMBER OF POINTS IN IWORK +C IBDSFL - FLAGS +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C IPFLD - CONTAINS BDS FROM BYTE 12 ON +C BDS11 - CONTAINS FIRST 11 BYTES FOR BDS +C LEN - NUMBER OF BYTES FROM 12 ON +C LENBDS - TOTAL LENGTH OF BDS +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 +C +C $$ + CHARACTER*1 BDS11(*),PDS(*) +C + REAL REFNCE +C + INTEGER ISCAL2,KWIDE + INTEGER LENBDS + INTEGER IPFLD(*),IGDS(*) + INTEGER LEN,KBDS(22) + INTEGER IWORK(*) +C OCTET NUMBER IN SECTION, FIRST ORDER PACKING +C INTEGER KBDS(12) +C FLAGS + INTEGER IBDSFL(*) +C EXTENDED FLAGS +C INTEGER KBDS(14) +C OCTET NUMBER FOR SECOND ORDER PACKING +C INTEGER KBDS(15) +C NUMBER OF FIRST ORDER VALUES +C INTEGER KBDS(17) +C NUMBER OF SECOND ORDER PACKED VALUES +C INTEGER KBDS(19) +C WIDTH OF SECOND ORDER PACKING + INTEGER ISOWID(50000) +C SECONDARY BIT MAP + INTEGER ISOBMP(8200) +C FIRST ORDER PACKED VALUES + INTEGER IFOVAL(50000) +C SECOND ORDER PACKED VALUES + INTEGER ISOVAL(100000) +C +C INTEGER KBDS(11) +C ---------------------------------- +C INITIALIZE ARRAYS + DO 100 I = 1, 50000 + ISOWID(I) = 0 + IFOVAL(I) = 0 + 100 CONTINUE +C + DO 101 I = 1, 8200 + ISOBMP(I) = 0 + 101 CONTINUE + DO 102 I = 1, 100000 + ISOVAL(I) = 0 + 102 CONTINUE +C INITIALIZE POINTERS +C SECONDARY BIT WIDTH POINTER + IWDPTR = 0 +C SECONDARY BIT MAP POINTER + IBMP2P = 0 +C FIRST ORDER VALUE POINTER + IFOPTR = 0 +C BYTE POINTER TO START OF 1ST ORDER VALUES + KBDS(12) = 0 +C BYTE POINTER TO START OF 2ND ORDER VALUES + KBDS(15) = 0 +C TO CONTAIN NUMBER OF FIRST ORDER VALUES + KBDS(17) = 0 +C TO CONTAIN NUMBER OF SECOND ORDER VALUES + KBDS(19) = 0 +C SECOND ORDER PACKED VALUE POINTER + ISOPTR = 0 +C ======================================================= +C BUILD SECOND ORDER BIT MAP IN EITHER +C ROW BY ROW OR COL BY COL FORMAT + IF (IAND(IGDS(13),32).NE.0) THEN +C COLUMN BY COLUMN + KOUT = IGDS(4) + KIN = IGDS(5) +C PRINT *,'COLUMN BY COLUMN',KOUT,KIN + ELSE +C ROW BY ROW + KOUT = IGDS(5) + KIN = IGDS(4) +C PRINT *,'ROW BY ROW',KOUT,KIN + END IF + KBDS(17) = KOUT + KBDS(19) = NPTS +C +C DO 4100 J = 1, NPTS, 53 +C WRITE (6,4101) (IWORK(K),K=J,J+52) + 4101 FORMAT (1X,25I4) +C PRINT *,' ' +C4100 CONTINUE +C +C INITIALIZE BIT MAP POINTER + IBMP2P = 0 +C CONSTRUCT WORKING BIT MAP + DO 2000 I = 1, KOUT + DO 1000 J = 1, KIN + IF (J.EQ.1) THEN + CALL SBYTE (ISOBMP,1,IBMP2P,1) + ELSE + CALL SBYTE (ISOBMP,0,IBMP2P,1) + END IF + IBMP2P = IBMP2P + 1 + 1000 CONTINUE + 2000 CONTINUE + LEN = IBMP2P / 32 + 1 +C CALL BINARY(ISOBMP,LEN) +C +C PROCESS OUTER LOOP OF ROW BY ROW OR COL BY COL +C + KPTR = 1 + KBDS(11) = KWIDE + DO 6000 I = 1, KOUT +C IN CURRENT ROW OR COL +C FIND FIRST ORDER VALUE + JPTR = KPTR + LOWEST = IWORK(JPTR) + DO 4000 J = 1, KIN + IF (IWORK(JPTR).LT.LOWEST) THEN + LOWEST = IWORK(JPTR) + END IF + JPTR = JPTR + 1 + 4000 CONTINUE +C SAVE FIRST ORDER VALUE + CALL SBYTE (IFOVAL,LOWEST,IFOPTR,KWIDE) + IFOPTR = IFOPTR + KWIDE +C PRINT *,'FOVAL',I,LOWEST,KWIDE +C SUBTRACT FIRST ORDER VALUE FROM OTHER VALS +C GETTING SECOND ORDER VALUES + JPTR = KPTR + IBIG = IWORK(JPTR) - LOWEST + DO 4200 J = 1, KIN + IWORK(JPTR) = IWORK(JPTR) - LOWEST + IF (IWORK(JPTR).GT.IBIG) THEN + IBIG = IWORK(JPTR) + END IF + JPTR = JPTR + 1 + 4200 CONTINUE +C HOW MANY BITS TO CONTAIN LARGEST SECOND +C ORDER VALUE IN SEGMENT + CALL FI7505 (IBIG,NWIDE) +C SAVE BIT WIDTH + CALL SBYTE (ISOWID,NWIDE,IWDPTR,8) + IWDPTR = IWDPTR + 8 +C PRINT *,I,'SOVAL',IBIG,' IN',NWIDE,' BITS' +C WRITE (6,4101) (IWORK(K),K=KPTR,KPTR+52) +C SAVE SECOND ORDER VALUES OF THIS SEGMENT + DO 5000 J = 0, KIN-1 + CALL SBYTE (ISOVAL,IWORK(KPTR+J),ISOPTR,NWIDE) + ISOPTR = ISOPTR + NWIDE + 5000 CONTINUE + KPTR = KPTR + KIN + 6000 CONTINUE +C ======================================================= +C CONCANTENATE ALL FIELDS FOR BDS +C +C REMAINDER GOES INTO IPFLD + IPTR = 0 +C BYTES 12-13 +C VALUE FOR N1 +C LEAVE SPACE FOR THIS + IPTR = IPTR + 16 +C BYTE 14 +C EXTENDED FLAGS + CALL SBYTE (IPFLD,IBDSFL(5),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(6),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(7),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(8),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(9),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(10),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(11),IPTR,1) + IPTR = IPTR + 1 + CALL SBYTE (IPFLD,IBDSFL(12),IPTR,1) + IPTR = IPTR + 1 +C BYTES 15-16 +C SKIP OVER VALUE FOR N2 + IPTR = IPTR + 16 +C BYTES 17-18 +C P1 + CALL SBYTE (IPFLD,KBDS(17),IPTR,16) + IPTR = IPTR + 16 +C BYTES 19-20 +C P2 + CALL SBYTE (IPFLD,KBDS(19),IPTR,16) + IPTR = IPTR + 16 +C BYTE 21 - RESERVED LOCATION + CALL SBYTE (IPFLD,0,IPTR,8) + IPTR = IPTR + 8 +C BYTES 22 - ? +C WIDTHS OF SECOND ORDER PACKING + IX = (IWDPTR + 32) / 32 + CALL SBYTES (IPFLD,ISOWID,IPTR,32,0,IX) + IPTR = IPTR + IWDPTR +C PRINT *,'ISOWID',IWDPTR,IX +C CALL BINARY (ISOWID,IX) +C +C NO SECONDARY BIT MAP + +C DETERMINE LOCATION FOR START +C OF FIRST ORDER PACKED VALUES + KBDS(12) = IPTR / 8 + 12 +C STORE LOCATION + CALL SBYTE (IPFLD,KBDS(12),0,16) +C MOVE IN FIRST ORDER PACKED VALUES + IPASS = (IFOPTR + 32) / 32 + CALL SBYTES (IPFLD,IFOVAL,IPTR,32,0,IPASS) + IPTR = IPTR + IFOPTR +C PRINT *,'IFOVAL',IFOPTR,IPASS,KWIDE +C CALL BINARY (IFOVAL,IPASS) + IF (MOD(IPTR,8).NE.0) THEN + IPTR = IPTR + 8 - MOD(IPTR,8) + END IF +C PRINT *,'IFOPTR =',IFOPTR,' ISOPTR =',ISOPTR +C DETERMINE LOCATION FOR START +C OF SECOND ORDER VALUES + KBDS(15) = IPTR / 8 + 12 +C SAVE LOCATION OF SECOND ORDER VALUES + CALL SBYTE (IPFLD,KBDS(15),24,16) +C MOVE IN SECOND ORDER PACKED VALUES + IX = (ISOPTR + 32) / 32 + CALL SBYTES (IPFLD,ISOVAL,IPTR,32,0,IX) + IPTR = IPTR + ISOPTR +C PRINT *,'ISOVAL',ISOPTR,IX +C CALL BINARY (ISOVAL,IX) + NLEFT = MOD(IPTR+88,16) + IF (NLEFT.NE.0) THEN + NLEFT = 16 - NLEFT + IPTR = IPTR + NLEFT + END IF +C COMPUTE LENGTH OF DATA PORTION + LEN = IPTR / 8 +C COMPUTE LENGTH OF BDS + LENBDS = LEN + 11 +C ----------------------------------- +C BYTES 1-3 +C THIS FUNCTION COMPLETED BELOW +C WHEN LENGTH OF BDS IS KNOWN + CALL SBYTE (BDS11,LENBDS,0,24) +C BYTE 4 + CALL SBYTE (BDS11,IBDSFL(1),24,1) + CALL SBYTE (BDS11,IBDSFL(2),25,1) + CALL SBYTE (BDS11,IBDSFL(3),26,1) + CALL SBYTE (BDS11,IBDSFL(4),27,1) +C ENTER NUMBER OF FILL BITS + CALL SBYTE (BDS11,NLEFT,28,4) +C BYTE 5-6 + IF (ISCAL2.LT.0) THEN + CALL SBYTE (BDS11,1,32,1) + ISCAL2 = - ISCAL2 + ELSE + CALL SBYTE (BDS11,0,32,1) + END IF + CALL SBYTE (BDS11,ISCAL2,33,15) +C +C FILL OCTET 7-10 WITH THE REFERENCE VALUE +C CONVERT THE FLOATING POINT OF YOUR MACHINE TO IBM370 32 BIT +C FLOATING POINT NUMBER +C REFERENCE VALUE +C FIRST TEST TO SEE IF +C ON 32 OR 64 BIT COMPUTER + CALL W3FI01(LW) + IF (LW.EQ.4) THEN + CALL W3FI76 (REFNCE,IEXP,IMANT,32) + ELSE + CALL W3FI76 (REFNCE,IEXP,IMANT,64) + END IF + CALL SBYTE (BDS11,IEXP,48,8) + CALL SBYTE (BDS11,IMANT,56,24) +C +C BYTE 11 +C + CALL SBYTE (BDS11,KBDS(11),80,8) +C + KLEN = LENBDS / 4 + 1 +C PRINT *,'BDS11 LISTING',4,LENBDS +C CALL BINARY (BDS11,4) +C PRINT *,'IPFLD LISTING' +C CALL BINARY (IPFLD,KLEN) + RETURN + END + SUBROUTINE FI7505 (N,NBITS) +C $$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI7505 DETERMINE NUMBER OF BITS TO CONTAIN VALUE +C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 93-06-23 +C +C ABSTRACT: CALCULATE NUMBER OF BITS TO CONTAIN VALUE N, WITH A +C MAXIMUM OF 32 BITS. +C +C PROGRAM HISTORY LOG: +C 93-06-23 CAVANAUGH +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL FI7505 (N,NBITS) +C INPUT ARGUMENT LIST: +C N - INTEGER VALUE +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C NBITS - NUMBER OF BITS TO CONTAIN N +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 +C +C $$ + INTEGER N,NBITS + INTEGER IBITS(31) +C + DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, + * 4095,8191,16383,32767,65535,131071,262143, + * 524287,1048575,2097151,4194303,8388607, + * 16777215,33554431,67108863,134217727,268435455, + * 536870911,1073741823,2147483647/ +C ---------------------------------------------------------------- +C + DO 1000 NBITS = 1, 31 + IF (N.LE.IBITS(NBITS)) THEN + RETURN + END IF + 1000 CONTINUE + RETURN + END + SUBROUTINE FI7513 (IWORK,ISTART,NPTS,MAX,MIN,INRNGE) +C $$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI7513 SELECT BLOCK OF DATA FOR PACKING +C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 +C +C ABSTRACT: SELECT A BLOCK OF DATA FOR PACKING +C +C PROGRAM HISTORY LOG: +C 94-01-21 CAVANAUGH +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL FI7513 (IWORK,ISTART,NPTS,MAX,MIN,INRNGE) +C INPUT ARGUMENT LIST: +C * - RETURN ADDRESS IF ENCOUNTER SET OF SAME VALUES +C IWORK - +C ISTART - +C NPTS - +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C MAX - +C MIN - +C INRNGE - +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 +C +C $$ + INTEGER IWORK(*),NPTS,ISTART,INRNGE,INRNGA,INRNGB + INTEGER MAX,MIN,MXVAL,MAXB,MINB,MXVALB + INTEGER IBITS(31) +C + DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, + * 4095,8191,16383,32767,65535,131071,262143, + * 524287,1048575,2097151,4194303,8388607, + * 16777215,33554431,67108863,134217727,268435455, + * 536870911,1073741823,2147483647/ +C ---------------------------------------------------------------- +C IDENTIFY NEXT BLOCK OF DATA FOR PACKING AND +C RETURN TO CALLER +C ******************************************************************** + ISTRTA = ISTART +C +C GET BLOCK A + CALL FI7516 (IWORK,NPTS,INRNGA,ISTRTA, + * MAX,MIN,MXVAL,LWIDE) +C ******************************************************************** +C + ISTRTB = ISTRTA + INRNGA + 2000 CONTINUE +C IF HAVE PROCESSED ALL DATA, RETURN + IF (ISTRTB.GT.NPTS) THEN +C NO MORE DATA TO LOOK AT + INRNGE = INRNGA + RETURN + END IF +C GET BLOCK B + CALL FI7502 (IWORK,ISTRTB,NPTS,ISAME) + IF (ISAME.GE.15) THEN +C PRINT *,'BLOCK B HAS ALL IDENTICAL VALUES' +C PRINT *,'BLOCK A HAS INRNGE =',INRNGA +C BLOCK B CONTAINS ALL IDENTICAL VALUES + INRNGE = INRNGA +C EXIT WITH BLOCK A + RETURN + END IF +C GET BLOCK B +C + ISTRTB = ISTRTA + INRNGA + CALL FI7516 (IWORK,NPTS,INRNGB,ISTRTB, + * MAXB,MINB,MXVALB,LWIDEB) +C PRINT *,'BLOCK A',INRNGA,' BLOCK B',INRNGB +C ******************************************************************** +C PERFORM TREND ANALYSIS TO DETERMINE +C IF DATA COLLECTION CAN BE IMPROVED +C + KTRND = LWIDE - LWIDEB +C PRINT *,'TREND',LWIDE,LWIDEB + IF (KTRND.LE.0) THEN +C PRINT *,'BLOCK A - SMALLER, SHOULD EXTEND INTO BLOCK B' + MXVAL = IBITS(LWIDE) +C +C IF BLOCK A REQUIRES THE SAME OR FEWER BITS +C LOOK AHEAD +C AND GATHER THOSE DATA POINTS THAT CAN +C BE RETAINED IN BLOCK A +C BECAUSE THIS BLOCK OF DATA +C USES FEWER BITS +C + CALL FI7518 (IRET,IWORK,NPTS,ISTRTA,INRNGA,INRNGB, + * MAX,MIN,LWIDE,MXVAL) + IF(IRET.EQ.1) GO TO 8000 +C PRINT *,'18 INRNGA IS NOW ',INRNGA + IF (INRNGB.LT.20) THEN + RETURN + ELSE + GO TO 2000 + END IF + ELSE +C PRINT *,'BLOCK A - LARGER, B SHOULD EXTEND BACK INTO A' + MXVALB = IBITS(LWIDEB) +C +C IF BLOCK B REQUIRES FEWER BITS +C LOOK BACK +C SHORTEN BLOCK A BECAUSE NEXT BLOCK OF DATA +C USES FEWER BITS +C + CALL FI7517 (IRET,IWORK,NPTS,ISTRTB,INRNGA, + * MAXB,MINB,LWIDEB,MXVALB) + IF(IRET.EQ.1) GO TO 8000 +C PRINT *,'17 INRNGA IS NOW ',INRNGA + END IF +C +C PACK UP BLOCK A +C UPDATA POINTERS + 8000 CONTINUE + INRNGE = INRNGA +C GET NEXT BLOCK A + 9000 CONTINUE + RETURN + END + SUBROUTINE FI7516 (IWORK,NPTS,INRNG,ISTART,MAX,MIN,MXVAL,LWIDTH) +C $$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI7516 SCAN NUMBER OF POINTS +C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 +C +C ABSTRACT: SCAN FORWARD FROM CURRENT POSITION. COLLECT POINTS AND +C DETERMINE MAXIMUM AND MINIMUM VALUES AND THE NUMBER +C OF POINTS THAT ARE INCLUDED. FORWARD SEARCH IS TERMINATED +C BY ENCOUNTERING A SET OF IDENTICAL VALUES, BY REACHING +C THE NUMBER OF POINTS SELECTED OR BY REACHING THE END +C OF DATA. +C +C PROGRAM HISTORY LOG: +C 94-01-21 CAVANAUGH +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL FI7516 (IWORK,NPTS,INRNG,ISTART,MAX,MIN,MXVAL,LWIDTH) +C INPUT ARGUMENT LIST: +C * - RETURN ADDRESS IF ENCOUNTER SET OF SAME VALUES +C IWORK - DATA ARRAY +C NPTS - NUMBER OF POINTS IN DATA ARRAY +C ISTART - STARTING LOCATION IN DATA +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C INRNG - NUMBER OF POINTS SELECTED +C MAX - MAXIMUM VALUE OF POINTS +C MIN - MINIMUM VALUE OF POINTS +C MXVAL - MAXIMUM VALUE THAT CAN BE CONTAINED IN LWIDTH BITS +C LWIDTH - NUMBER OF BITS TO CONTAIN MAX DIFF +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 +C +C $$ + INTEGER IWORK(*),NPTS,ISTART,INRNG,MAX,MIN,LWIDTH,MXVAL + INTEGER IBITS(31) +C + DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, + * 4095,8191,16383,32767,65535,131071,262143, + * 524287,1048575,2097151,4194303,8388607, + * 16777215,33554431,67108863,134217727,268435455, + * 536870911,1073741823,2147483647/ +C ---------------------------------------------------------------- +C + INRNG = 1 + JQ = ISTART + 19 + MAX = IWORK(ISTART) + MIN = IWORK(ISTART) + DO 1000 I = ISTART+1, JQ + CALL FI7502 (IWORK,I,NPTS,ISAME) + IF (ISAME.GE.15) THEN + GO TO 5000 + END IF + INRNG = INRNG + 1 + IF (IWORK(I).GT.MAX) THEN + MAX = IWORK(I) + ELSE IF (IWORK(I).LT.MIN) THEN + MIN = IWORK(I) + END IF + 1000 CONTINUE + 5000 CONTINUE + KRNG = MAX - MIN +C + DO 9000 LWIDTH = 1, 31 + IF (KRNG.LE.IBITS(LWIDTH)) THEN +C PRINT *,'RETURNED',INRNG,' VALUES' + RETURN + END IF + 9000 CONTINUE + RETURN + END + SUBROUTINE FI7517 (IRET,IWORK,NPTS,ISTRTB,INRNGA, + * MAXB,MINB,MXVALB,LWIDEB) +C $$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI7517 SCAN BACKWARD +C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 +C +C ABSTRACT: SCAN BACKWARDS UNTIL A VALUE EXCEEDS RANGE OF GROUP B +C THIS MAY SHORTEN GROUP A +C +C PROGRAM HISTORY LOG: +C 94-01-21 CAVANAUGH +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 98-06-17 IREDELL REMOVED ALTERNATE RETURN +C +C USAGE: CALL FI7517 (IRET,IWORK,NPTS,ISTRTB,INRNGA, +C * MAXB,MINB,MXVALB,LWIDEB) +C INPUT ARGUMENT LIST: +C IWORK - +C ISTRTB - +C NPTS - +C INRNGA - +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C IRET - +C JLAST - +C MAXB - +C MINB - +C LWIDTH - NUMBER OF BITS TO CONTAIN MAX DIFF +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 +C +C $$ + INTEGER IWORK(*),NPTS,ISTRTB,INRNGA + INTEGER MAXB,MINB,LWIDEB,MXVALB + INTEGER IBITS(31) +C + DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, + * 4095,8191,16383,32767,65535,131071,262143, + * 524287,1048575,2097151,4194303,8388607, + * 16777215,33554431,67108863,134217727,268435455, + * 536870911,1073741823,2147483647/ +C ---------------------------------------------------------------- + IRET=0 +C PRINT *,' FI7517' + NPOS = ISTRTB - 1 + ITST = 0 + KSET = INRNGA +C + 1000 CONTINUE +C PRINT *,'TRY NPOS',NPOS,IWORK(NPOS),MAXB,MINB + ITST = ITST + 1 + IF (ITST.LE.KSET) THEN + IF (IWORK(NPOS).GT.MAXB) THEN + IF ((IWORK(NPOS)-MINB).GT.MXVALB) THEN +C PRINT *,'WENT OUT OF RANGE AT',NPOS + IRET=1 + RETURN + ELSE + MAXB = IWORK(NPOS) + END IF + ELSE IF (IWORK(NPOS).LT.MINB) THEN + IF ((MAXB-IWORK(NPOS)).GT.MXVALB) THEN +C PRINT *,'WENT OUT OF RANGE AT',NPOS + IRET=1 + RETURN + ELSE + MINB = IWORK(NPOS) + END IF + END IF + INRNGA = INRNGA - 1 + NPOS = NPOS - 1 + GO TO 1000 + END IF +C ---------------------------------------------------------------- +C + 9000 CONTINUE + RETURN + END + SUBROUTINE FI7518 (IRET,IWORK,NPTS,ISTRTA,INRNGA,INRNGB, + * MAXA,MINA,LWIDEA,MXVALA) +C $$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: FI7518 SCAN FORWARD +C PRGMMR: CAVANAUGH ORG: W/NMC42 DATE: 94-01-21 +C +C ABSTRACT: SCAN FORWARD FROM START OF BLOCK B TOWARDS END OF BLOCK B +C IF NEXT POINT UNDER TEST FORCES A LARGER MAXVALA THEN +C TERMINATE INDICATING LAST POINT TESTED FOR INCLUSION +C INTO BLOCK A. +C +C PROGRAM HISTORY LOG: +C 94-01-21 CAVANAUGH +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 98-06-17 IREDELL REMOVED ALTERNATE RETURN +C +C USAGE: CALL FI7518 (IRET,IWORK,NPTS,ISTRTA,INRNGA,INRNGB, +C * MAXA,MINA,LWIDEA,MXVALA) +C INPUT ARGUMENT LIST: +C IFLD - +C JSTART - +C NPTS - +C +C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) +C IRET - +C JLAST - +C MAX - +C MIN - +C LWIDTH - NUMBER OF BITS TO CONTAIN MAX DIFF +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS, CRAY C916/256, Y-MP8/64, Y-MP EL92/256 +C +C $$ + INTEGER IWORK(*),NPTS,ISTRTA,INRNGA + INTEGER MAXA,MINA,LWIDEA,MXVALA + INTEGER IBITS(31) +C + DATA IBITS/1,3,7,15,31,63,127,255,511,1023,2047, + * 4095,8191,16383,32767,65535,131071,262143, + * 524287,1048575,2097151,4194303,8388607, + * 16777215,33554431,67108863,134217727,268435455, + * 536870911,1073741823,2147483647/ +C ---------------------------------------------------------------- + IRET=0 +C PRINT *,' FI7518' + NPOS = ISTRTA + INRNGA + ITST = 0 +C + 1000 CONTINUE + ITST = ITST + 1 + IF (ITST.LE.INRNGB) THEN +C PRINT *,'TRY NPOS',NPOS,IWORK(NPOS),MAXA,MINA + IF (IWORK(NPOS).GT.MAXA) THEN + IF ((IWORK(NPOS)-MINA).GT.MXVALA) THEN +C PRINT *,'FI7518A -',ITST,' RANGE EXCEEDS MAX' + IRET=1 + RETURN + ELSE + MAXA = IWORK(NPOS) + END IF + ELSE IF (IWORK(NPOS).LT.MINA) THEN + IF ((MAXA-IWORK(NPOS)).GT.MXVALA) THEN +C PRINT *,'FI7518B -',ITST,' RANGE EXCEEDS MAX' + IRET=1 + RETURN + ELSE + MINA = IWORK(NPOS) + END IF + END IF + INRNGA = INRNGA + 1 +C PRINT *,' ',ITST,INRNGA + NPOS = NPOS +1 + GO TO 1000 + END IF +C ---------------------------------------------------------------- + 9000 CONTINUE + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi76.f b/WPS/ungrib/src/ngl/w3/w3fi76.f new file mode 100755 index 00000000..2a1553f5 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi76.f @@ -0,0 +1,131 @@ + SUBROUTINE W3FI76(PVAL,KEXP,KMANT,KBITS) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI76 CONVERT TO IBM370 FLOATING POINT +C PRGMMR: REJONES ORG: NMC421 DATE:92-11-16 +C +C ABSTRACT: CONVERTS FLOATING POINT NUMBER FROM MACHINE +C REPRESENTATION TO GRIB REPRESENTATION (IBM370 32 BIT F.P.). +C +C PROGRAM HISTORY LOG: +C 85-09-15 JOHN HENNESSY ECMWF +C 92-09-23 JONES R. E. CHANGE NAME, ADD DOC BLOCK +C 93-10-27 JONES,R. E. CHANGE TO AGREE WITH HENNESSY CHANGES +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE +C +C USAGE: CALL W3FI76 (FVAL, KEXP, KMANT, NBITS) +C INPUT ARGUMENT LIST: +C PVAL - FLOATING POINT NUMBER TO BE CONVERTED +C KBITS - NUMBER OF BITS IN COMPUTER WORD (32 OR 64) +C +C OUTPUT ARGUMENT LIST: +C KEXP - 8 BIT SIGNED EXPONENT +C KMANT - 24 BIT MANTISSA (FRACTION) +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM370 VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS 9000, CRAY Y-MP8/864< CRAY Y-MP EL2/256 +C +C$$$ +C +C******************************************************************** +C* +C* NAME : CONFP3 +C* +C* FUNCTION : CONVERT FLOATING POINT NUMBER FROM MACHINE +C* REPRESENTATION TO GRIB REPRESENTATION. +C* +C* INPUT : PVAL - FLOATING POINT NUMBER TO BE CONVERTED. +C* KBITS : KBITS - NUMBER OF BITS IN COMPUTER WORD +C* +C* OUTPUT : KEXP - 8 BIT SIGNED EXPONENT +C* KMANT - 24 BIT MANTISSA +C* PVAL - UNCHANGED. +C* +C* JOHN HENNESSY , ECMWF 18.06.91 +C* +C******************************************************************** +C +C +C IMPLICIT NONE +C + INTEGER IEXP + INTEGER ISIGN +C + INTEGER KBITS + INTEGER KEXP + INTEGER KMANT +C + REAL PVAL + REAL ZEPS + REAL ZREF +C +C TEST FOR FLOATING POINT ZERO +C + IF (PVAL.EQ.0.0) THEN + KEXP = 0 + KMANT = 0 + GO TO 900 + ENDIF +C +C SET ZEPS TO 1.0E-12 FOR 64 BIT COMPUTERS (CRAY) +C SET ZEPS TO 1.0E-8 FOR 32 BIT COMPUTERS +C + IF (KBITS.EQ.32) THEN + ZEPS = 1.0E-8 + ELSE + ZEPS = 1.0E-12 + ENDIF + ZREF = PVAL +C +C SIGN OF VALUE +C + ISIGN = 0 + IF (ZREF.LT.0.0) THEN + ISIGN = 128 + ZREF = - ZREF + ENDIF +C +C EXPONENT +C + IEXP = INT(ALOG(ZREF)*(1.0/ALOG(16.0))+64.0+1.0+ZEPS) +C + IF (IEXP.LT.0 ) IEXP = 0 + IF (IEXP.GT.127) IEXP = 127 +C +C MANTISSA +C +C CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER +C (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER). +C + KMANT = NINT (ZREF/16.0**(IEXP-70)) +C +C CHECK THAT MANTISSA VALUE DOES NOT EXCEED 24 BITS +C 16777215 = 2**24 - 1 +C + IF (KMANT.GT.16777215) THEN + IEXP = IEXP + 1 +C +C CLOSEST NUMBER IN GRIB FORMAT TO ORIGINAL NUMBER +C (EQUAL TO, GREATER THAN OR LESS THAN ORIGINAL NUMBER). +C + KMANT = NINT (ZREF/16.0**(IEXP-70)) +C +C CHECK MANTISSA VALUE DOES NOT EXCEED 24 BITS AGAIN +C + IF (KMANT.GT.16777215) THEN + PRINT *,'BAD MANTISSA VALUE FOR PVAL = ',PVAL + ENDIF + ENDIF +C +C ADD SIGN BIT TO EXPONENT. +C + KEXP = IEXP + ISIGN +C + 900 CONTINUE +C + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi82.f b/WPS/ungrib/src/ngl/w3/w3fi82.f new file mode 100755 index 00000000..838a426f --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi82.f @@ -0,0 +1,60 @@ + SUBROUTINE W3FI82 (IFLD,FVAL1,FDIFF1,NPTS) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI82 CONVERT TO SECOND DIFF ARRAY +C PRGMMR: CAVANAUGH ORG: NMC421 DATE:93-08-18 +C +C ABSTRACT: ACCEPT AN INPUT ARRAY, CONVERT TO ARRAY OF SECOND +C DIFFERENCES. RETURN THE ORIGINAL FIRST VALUE AND THE FIRST +C FIRST-DIFFERENCE AS SEPARATE VALUES. +C +C PROGRAM HISTORY LOG: +C 93-07-14 CAVANAUGH +C 93-08-18 R.E.JONES RECOMPILE FOR SiliconGraphics +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL W3FI82 (IFLD,FVAL1,FDIFF1,NPTS) +C INPUT ARGUMENT LIST: +C IFLD - INTEGER INPUT ARRAY +C NPTS - NUMBER OF POINTS IN ARRAY +C +C OUTPUT ARGUMENT LIST: +C IFLD - SECOND DIFFERENCED FIELD +C FVAL1 - FLOATING POINT ORIGINAL FIRST VALUE +C FDIFF1 - " " FIRST FIRST-DIFFERENCE +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: SiliconGraphics 3.5 FORTRAN 77 +C MACHINE: SiliconGraphics model 25, 35, INDIGO +C +C$$$ +C + REAL FVAL1,FDIFF1 +C + INTEGER IFLD(*),NPTS +C +C --------------------------------------------- + DO 4000 I = NPTS, 2, -1 + IFLD(I) = IFLD(I) - IFLD(I-1) + 4000 CONTINUE + DO 5000 I = NPTS, 3, -1 + IFLD(I) = IFLD(I) - IFLD(I-1) + 5000 CONTINUE +C PRINT *,'IFLD(1) =',IFLD(1),' IFLD(2) =',IFLD(2) +C +C SPECIAL FOR GRIB +C FLOAT OUTPUT OF FIRST POINTS TO ANTICIPATE +C GRIB FLOATING POINT OUTPUT +C + FVAL1 = IFLD(1) + FDIFF1 = IFLD(2) +C +C SET FIRST TWO POINTS TO SECOND DIFF VALUE FOR BETTER PACKING +C + IFLD(1) = IFLD(3) + IFLD(2) = IFLD(3) +C ----------------------------------------------------------- + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fi83.f b/WPS/ungrib/src/ngl/w3/w3fi83.f new file mode 100755 index 00000000..510c61e4 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fi83.f @@ -0,0 +1,108 @@ + SUBROUTINE W3FI83 (DATA,NPTS,FVAL1,FDIFF1,ISCAL2, + * ISC10,KPDS,KGDS) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FI83 RESTORE DELTA PACKED DATA TO ORIGINAL +C PRGMMR: CAVANAUGH ORG: NMC421 DATE:93-08-18 +C +C ABSTRACT: RESTORE DELTA PACKED DATA TO ORIGINAL VALUES +C RESTORE FROM BOUSTREPHEDONIC ALIGNMENT +C +C PROGRAM HISTORY LOG: +C 93-07-14 CAVANAUGH +C 93-07-22 STACKPOLE ADDITIONS TO FIX SCALING +C 94-01-27 CAVANAUGH ADDED REVERSAL OF EVEN NUMBERED ROWS +C (BOUSTROPHEDONIC PROCESSING) TO RESTORE +C DATA TO ORIGINAL SEQUENCE. +C 94-03-02 CAVANAUGH CORRECTED REVERSAL OF EVEN NUMBERED ROWS +C 95-10-31 IREDELL REMOVED SAVES AND PRINTS +C +C USAGE: CALL W3FI83(DATA,NPTS,FVAL1,FDIFF1,ISCAL2, +C * ISC10,KPDS,KGDS) +C INPUT ARGUMENT LIST: +C DATA - SECOND ORDER DIFFERENCES +C NPTS - NUMBER OF POINTS IN ARRAY +C FVAL1 - ORIGINAL FIRST ENTRY IN ARRAY +C FDIFF1 - ORIGINAL FIRST FIRST-DIFFERENCE +C ISCAL2 - POWER-OF-TWO EXPONENT FOR UNSCALING +C ISC10 - POWER-OF-TEN EXPONENT FOR UNSCALING +C KPDS - ARRAY OF INFORMATION FOR PDS +C KGDS - ARRAY OF INFORMATION FOR GDS +C +C OUTPUT ARGUMENT LIST: +C DATA - EXPANDED ORIGINAL DATA VALUES +C +C REMARKS: SUBPROGRAM CAN BE CALLED FROM A MULTIPROCESSING ENVIRONMENT. +C +C ATTRIBUTES: +C LANGUAGE: IBM VS FORTRAN 77, CRAY CFT77 FORTRAN +C MACHINE: HDS, CRAY C916-128, CRAY Y-MP8/864, CRAY Y-MP EL2/256 +C +C$$$ +C + REAL FVAL1,FDIFF1 + REAL DATA(*),BOUST(200) + INTEGER NPTS,NROW,NCOL,KPDS(*),KGDS(*),ISC10 +C --------------------------------------- +C +C REMOVE DECIMAL UN-SCALING INTRODUCED DURING UNPACKING +C + DSCAL = 10.0 ** ISC10 + IF (DSCAL.EQ.0.0) THEN + DO 50 I=1,NPTS + DATA(I) = 1.0 + 50 CONTINUE + ELSE IF (DSCAL.EQ.1.0) THEN + ELSE + DO 51 I=1,NPTS + DATA(I) = DATA(I) * DSCAL + 51 CONTINUE + END IF +C + DATA(1) = FVAL1 + DATA(2) = FDIFF1 + DO 200 J = 3,2,-1 + DO 100 K = J, NPTS + DATA(K) = DATA(K) + DATA(K-1) + 100 CONTINUE + 200 CONTINUE +C +C NOW REMOVE THE BINARY SCALING FROM THE RECONSTRUCTED FIELD +C AND THE DECIMAL SCALING TOO +C + IF (DSCAL.EQ.0) THEN + SCALE = 0.0 + ELSE + SCALE =(2.0**ISCAL2)/DSCAL + END IF + DO 300 I=1,NPTS + DATA(I) = DATA(I) * SCALE + 300 CONTINUE +C ========================================================== + IF (IAND(KPDS(4),128).NE.0) THEN + NROW = KGDS(3) + NCOL = KGDS(2) +C +C DATA LAID OUT BOUSTROPHEDONIC STYLE +C +C +C PRINT*, ' REVERSE BOUSTROPHEDON' + DO 210 I = 2, NROW, 2 +C +C REVERSE THE EVEN NUMBERED ROWS +C + DO 201 J = 1, NCOL + NPOS = I * NCOL - J + 1 + BOUST(J) = DATA(NPOS) + 201 CONTINUE + DO 202 J = 1, NCOL + NPOS = NCOL * (I-1) + J + DATA(NPOS) = BOUST(J) + 202 CONTINUE + 210 CONTINUE +C +C + END IF +C ================================================================= + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fs21.f b/WPS/ungrib/src/ngl/w3/w3fs21.f new file mode 100755 index 00000000..3593d6ff --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fs21.f @@ -0,0 +1,77 @@ + SUBROUTINE W3FS21(IDATE, NMIN) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C . . . . +C SUBPROGRAM: W3FS21 NUMBER OF MINUTES SINCE JAN 1, 1978 +C PRGMMR: REJONES ORG: NMC421 DATE: 89-07-17 +C +C ABSTRACT: CALCULATES THE NUMBER OF MINUTES SINCE 0000, +C 1 JANUARY 1978. +C +C PROGRAM HISTORY LOG: +C 84-06-21 A. DESMARAIS +C 89-07-14 R.E.JONES CONVERT TO CYBER 205 FORTRAN 200, +C CHANGE LOGIC SO IT WILL WORK IN +C 21 CENTURY. +C 89-11-02 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN +C +C USAGE: CALL W3FS21 (IDATE, NMIN) +C INPUT ARGUMENT LIST: +C IDATE - INTEGER SIZE 5 ARRAY CONTAINING YEAR OF CENTURY, +C MONTH, DAY, HOUR AND MINUTE. IDATE(1) MAY BE +C A TWO DIGIT YEAR OR 4. IF 2 DIGITS AND GE THAN 78 +C 1900 IS ADDED TO IT. IF LT 78 THEN 2000 IS ADDED +C TO IT. IF 4 DIGITS THE SUBROUTINE WILL WORK +C CORRECTLY TO THE YEAR 3300 A.D. +C +C OUTPUT ARGUMENT LIST: +C NMIN - INTEGER NUMBER OF MINUTES SINCE 1 JANUARY 1978 +C +C SUBPROGRAMS CALLED: +C LIBRARY: +C W3LIB - IW3JDN +C +C ATTRIBUTES: +C LANGUAGE: CRAY CFT77 FORTRAN +C MACHINE: CRAY Y-MP8/832 +C +C$$$ +C + INTEGER IDATE(5) + INTEGER NMIN + INTEGER JDN78 +C + DATA JDN78 / 2443510 / +C +C*** IDATE(1) YEAR OF CENTURY +C*** IDATE(2) MONTH OF YEAR +C*** IDATE(3) DAY OF MONTH +C*** IDATE(4) HOUR OF DAY +C*** IDATE(5) MINUTE OF HOUR +C + NMIN = 0 +C + IYEAR = IDATE(1) +C + IF (IYEAR.LE.99) THEN + IF (IYEAR.LT.78) THEN + IYEAR = IYEAR + 2000 + ELSE + IYEAR = IYEAR + 1900 + ENDIF + ENDIF +C +C COMPUTE JULIAN DAY NUMBER FROM YEAR, MONTH, DAY +C + IJDN = IW3JDN(IYEAR,IDATE(2),IDATE(3)) +C +C SUBTRACT JULIAN DAY NUMBER OF JAN 1,1978 TO GET THE +C NUMBER OF DAYS BETWEEN DATES +C + NDAYS = IJDN - JDN78 +C +C*** NUMBER OF MINUTES +C + NMIN = NDAYS * 1440 + IDATE(4) * 60 + IDATE(5) +C + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3fs26.f b/WPS/ungrib/src/ngl/w3/w3fs26.f new file mode 100755 index 00000000..bad845d4 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3fs26.f @@ -0,0 +1,87 @@ + SUBROUTINE W3FS26(JLDAYN,IYEAR,MONTH,IDAY,IDAYWK,IDAYYR) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER +C AUTHOR: JONES,R.E. ORG: W342 DATE: 87-03-29 +C +C ABSTRACT: COMPUTES YEAR (4 DIGITS), MONTH, DAY, DAY OF WEEK, DAY +C OF YEAR FROM JULIAN DAY NUMBER. THIS SUBROUTINE WILL WORK +C FROM 1583 A.D. TO 3300 A.D. +C +C PROGRAM HISTORY LOG: +C 87-03-29 R.E.JONES +C 89-10-25 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN +C +C USAGE: CALL W3FS26(JLDAYN,IYEAR,MONTH,IDAY,IDAYWK,IDAYYR) +C +C INPUT VARIABLES: +C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES +C ------ --------- ----------------------------------------------- +C JLDAYN ARG LIST INTEGER JULIAN DAY NUMBER +C +C OUTPUT VARIABLES: +C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES +C ------ --------- ----------------------------------------------- +C IYEAR ARG LIST INTEGER YEAR (4 DIGITS) +C MONTH ARG LIST INTEGER MONTH +C IDAY ARG LIST INTEGER DAY +C IDAYWK ARG LIST INTEGER DAY OF WEEK (1 IS SUNDAY, 7 IS SAT) +C IDAYYR ARG LIST INTEGER DAY OF YEAR (1 TO 366) +C +C REMARKS: A JULIAN DAY NUMBER CAN BE COMPUTED BY USING ONE OF THE +C FOLLOWING STATEMENT FUNCTIONS. A DAY OF WEEK CAN BE COMPUTED +C FROM THE JULIAN DAY NUMBER. A DAY OF YEAR CAN BE COMPUTED FROM +C A JULIAN DAY NUMBER AND YEAR. +C +C IYEAR (4 DIGITS) +C +C JDN(IYEAR,MONTH,IDAY) = IDAY - 32075 +C & + 1461 * (IYEAR + 4800 + (MONTH - 14) / 12) / 4 +C & + 367 * (MONTH - 2 - (MONTH -14) / 12 * 12) / 12 +C & - 3 * ((IYEAR + 4900 + (MONTH - 14) / 12) / 100) / 4 +C +C IYR (4 DIGITS) , IDYR(1-366) DAY OF YEAR +C +C JULIAN(IYR,IDYR) = -31739 + 1461 * (IYR + 4799) / 4 +C & -3 * ((IYR + 4899) / 100) / 4 + IDYR +C +C DAY OF WEEK FROM JULIAN DAY NUMBER, 1 IS SUNDAY, 7 IS SATURDAY. +C +C JDAYWK(JLDAYN) = MOD((JLDAYN + 1),7) + 1 +C +C DAY OF YEAR FROM JULIAN DAY NUMBER AND 4 DIGIT YEAR. +C +C JDAYYR(JLDAYN,IYEAR) = JLDAYN - +C & (-31739+1461*(IYEAR+4799)/4-3*((IYEAR+4899)/100)/4) +C +C THE FIRST FUNCTION WAS IN A LETTER TO THE EDITOR COMMUNICATIONS +C OF THE ACM VOLUME 11 / NUMBER 10 / OCTOBER, 1968. THE 2ND +C FUNCTION WAS DERIVED FROM THE FIRST. THIS SUBROUTINE WAS ALSO +C INCLUDED IN THE SAME LETTER. JULIAN DAY NUMBER 1 IS +C JAN 1,4713 B.C. A JULIAN DAY NUMBER CAN BE USED TO REPLACE A +C DAY OF CENTURY, THIS WILL TAKE CARE OF THE DATE PROBLEM IN +C THE YEAR 2000, OR REDUCE PROGRAM CHANGES TO ONE LINE CHANGE +C OF 1900 TO 2000. JULIAN DAY NUMBERS CAN BE USED FOR FINDING +C RECORD NUMBERS IN AN ARCHIVE OR DAY OF WEEK, OR DAY OF YEAR. +C +C ATTRIBUTES: +C LANGUAGE: CRAY CFT77 FORTRAN +C MACHINE: CRAY Y-MP8/864 +C +C$$$ +C + L = JLDAYN + 68569 + N = 4 * L / 146097 + L = L - (146097 * N + 3) / 4 + I = 4000 * (L + 1) / 1461001 + L = L - 1461 * I / 4 + 31 + J = 80 * L / 2447 + IDAY = L - 2447 * J / 80 + L = J / 11 + MONTH = J + 2 - 12 * L + IYEAR = 100 * (N - 49) + I + L + IDAYWK = MOD((JLDAYN + 1),7) + 1 + IDAYYR = JLDAYN - + & (-31739 +1461 * (IYEAR+4799) / 4 - 3 * ((IYEAR+4899)/100)/4) + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3locdat.f b/WPS/ungrib/src/ngl/w3/w3locdat.f new file mode 100755 index 00000000..d88094ea --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3locdat.f @@ -0,0 +1,43 @@ +!----------------------------------------------------------------------- + subroutine w3locdat(idat) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! +! SUBPROGRAM: W3LOCDAT RETURN THE LOCAL DATE AND TIME +! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 +! +! ABSTRACT: THIS SUBPROGRAM RETURNS THE LOCAL DATE AND TIME +! IN THE NCEP ABSOLUTE DATE AND TIME DATA STRUCTURE. +! +! PROGRAM HISTORY LOG: +! 98-01-05 MARK IREDELL +! 1999-04-28 Gilbert - added a patch to check for the proper +! UTC offset. Needed until the IBM bug +! in date_and_time is fixed. The patch +! can then be removed. See comments in +! the section blocked with "&&&&&&&&&&&". +! 1999-08-12 Gilbert - Changed so that czone variable is saved +! and the system call is only done for +! first invocation of this routine. +! +! USAGE: CALL W3LOCDAT(IDAT) +! +! OUTPUT VARIABLES: +! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME +! (YEAR, MONTH, DAY, TIME ZONE, +! HOUR, MINUTE, SECOND, MILLISECOND) +! +! SUBPROGRAMS CALLED: +! DATE_AND_TIME FORTRAN 90 SYSTEM DATE INTRINSIC +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! +!$$$ + integer idat(8) + character cdate*8,ctime*10,czone*5 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! get local date and time but use the character time zone + call date_and_time(cdate,ctime,czone,idat) + read(czone,'(i5)') idat(4) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end diff --git a/WPS/ungrib/src/ngl/w3/w3log.f b/WPS/ungrib/src/ngl/w3/w3log.f new file mode 100644 index 00000000..fe4fa701 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3log.f @@ -0,0 +1,2 @@ + subroutine w3log + end diff --git a/WPS/ungrib/src/ngl/w3/w3movdat.f b/WPS/ungrib/src/ngl/w3/w3movdat.f new file mode 100755 index 00000000..16cbade4 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3movdat.f @@ -0,0 +1,53 @@ +!----------------------------------------------------------------------- + subroutine w3movdat(rinc,idat,jdat) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! +! SUBPROGRAM: W3MOVDAT RETURN A DATE FROM A TIME INTERVAL AND DATE +! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 +! +! ABSTRACT: THIS SUBPROGRAM RETURNS THE DATE AND TIME THAT IS A GIVEN +! NCEP RELATIVE TIME INTERVAL FROM AN NCEP ABSOLUTE DATE AND TIME. +! THE OUTPUT IS IN THE NCEP ABSOLUTE DATE AND TIME DATA STRUCTURE. +! +! PROGRAM HISTORY LOG: +! 98-01-05 MARK IREDELL +! +! USAGE: CALL W3MOVDAT(RINC,IDAT,JDAT) +! +! INPUT VARIABLES: +! RINC REAL (5) NCEP RELATIVE TIME INTERVAL +! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) +! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME +! (YEAR, MONTH, DAY, TIME ZONE, +! HOUR, MINUTE, SECOND, MILLISECOND) +! +! OUTPUT VARIABLES: +! JDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME +! (YEAR, MONTH, DAY, TIME ZONE, +! HOUR, MINUTE, SECOND, MILLISECOND) +! (JDAT IS LATER THAN IDAT IF TIME INTERVAL IS POSITIVE.) +! +! SUBPROGRAMS CALLED: +! IW3JDN COMPUTE JULIAN DAY NUMBER +! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER +! W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! +!$$$ + real rinc(5) + integer idat(8),jdat(8) + real rinc1(5),rinc2(5) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! add the interval to the input time of day and put into reduced form +! and then compute new date using julian day arithmetic. + rinc1(1)=rinc(1) + rinc1(2:5)=rinc(2:5)+idat(5:8) + call w3reddat(-1,rinc1,rinc2) + jldayn=iw3jdn(idat(1),idat(2),idat(3))+nint(rinc2(1)) + call w3fs26(jldayn,jdat(1),jdat(2),jdat(3),jdow,jdoy) + jdat(4)=idat(4) + jdat(5:8)=nint(rinc2(2:5)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end diff --git a/WPS/ungrib/src/ngl/w3/w3reddat.f b/WPS/ungrib/src/ngl/w3/w3reddat.f new file mode 100755 index 00000000..d15d5293 --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3reddat.f @@ -0,0 +1,142 @@ + subroutine w3reddat(it,rinc,dinc) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! +! SUBPROGRAM: W3REDDAT REDUCE A TIME INTERVAL TO A CANONICAL FORM +! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 +! +! ABSTRACT: THIS SUBPROGRAM REDUCES AN NCEP RELATIVE TIME INTERVAL +! INTO ONE OF SEVEN CANONICAL FORMS, DEPENDING ON THE INPUT IT VALUE. +! +! First reduced format type (IT=-1): +! RINC(1) is an arbitrary integer. +! RINC(2) is an integer between 00 and 23, inclusive. +! RINC(3) is an integer between 00 and 59, inclusive. +! RINC(4) is an integer between 00 and 59, inclusive. +! RINC(5) is an integer between 000 and 999, inclusive. +! If RINC(1) is negative, then the time interval is negative. +! +! Second reduced format type (IT=0): +! If the time interval is not negative, then the format is: +! RINC(1) is zero or a positive integer. +! RINC(2) is an integer between 00 and 23, inclusive. +! RINC(3) is an integer between 00 and 59, inclusive. +! RINC(4) is an integer between 00 and 59, inclusive. +! RINC(5) is an integer between 000 and 999, inclusive. +! Otherwise if the time interval is negative, then the format is: +! RINC(1) is zero or a negative integer. +! RINC(2) is an integer between 00 and -23, inclusive. +! RINC(3) is an integer between 00 and -59, inclusive. +! RINC(4) is an integer between 00 and -59, inclusive. +! RINC(5) is an integer between 000 and -999, inclusive. +! +! Days format type (IT=1): +! RINC(1) is arbitrary. +! RINC(2) is zero. +! RINC(3) is zero. +! RINC(4) is zero. +! RINC(5) is zero. +! +! Hours format type (IT=2): +! RINC(1) is zero. +! RINC(2) is arbitrary. +! RINC(3) is zero. +! RINC(4) is zero. +! RINC(5) is zero. +! (This format should not express time intervals longer than 300 years.) +! +! Minutes format type (IT=3): +! RINC(1) is zero. +! RINC(2) is zero. +! RINC(3) is arbitrary. +! RINC(4) is zero. +! RINC(5) is zero. +! (This format should not express time intervals longer than five years.) +! +! Seconds format type (IT=4): +! RINC(1) is zero. +! RINC(2) is zero. +! RINC(3) is zero. +! RINC(4) is arbitrary. +! RINC(5) is zero. +! (This format should not express time intervals longer than one month.) +! +! Milliseconds format type (IT=5): +! RINC(1) is zero. +! RINC(2) is zero. +! RINC(3) is zero. +! RINC(4) is zero. +! RINC(5) is arbitrary. +! (This format should not express time intervals longer than one hour.) +! +! PROGRAM HISTORY LOG: +! 98-01-05 MARK IREDELL +! +! USAGE: CALL W3REDDAT(IT,RINC,DINC) +! +! INPUT VARIABLES: +! IT INTEGER RELATIVE TIME INTERVAL FORMAT TYPE +! (-1 FOR FIRST REDUCED TYPE (HOURS ALWAYS POSITIVE), +! 0 FOR SECOND REDUCED TYPE (HOURS CAN BE NEGATIVE), +! 1 FOR DAYS ONLY, 2 FOR HOURS ONLY, 3 FOR MINUTES ONLY, +! 4 FOR SECONDS ONLY, 5 FOR MILLISECONDS ONLY) +! RINC REAL (5) NCEP RELATIVE TIME INTERVAL +! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) +! +! OUTPUT VARIABLES: +! DINC REAL (5) NCEP RELATIVE TIME INTERVAL +! (DAYS, HOURS, MINUTES, SECONDS, MILLISECONDS) +! +! SUBPROGRAMS CALLED: +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! +!$$$ + real rinc(5),dinc(5) +! parameters for number of units in a day +! and number of milliseconds in a unit +! and number of next smaller units in a unit, respectively + integer,dimension(5),parameter:: itd=(/1,24,1440,86400,86400000/), + & itm=itd(5)/itd + integer,dimension(4),parameter:: itn=itd(2:5)/itd(1:4) + integer,parameter:: np=16 + integer iinc(4),jinc(5),kinc(5) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! first reduce to the first reduced form + iinc=floor(rinc(1:4)) +! convert all positive fractional parts to milliseconds +! and determine canonical milliseconds + jinc(5)=nint(dot_product(rinc(1:4)-iinc,real(itm(1:4)))+rinc(5)) + kinc(5)=modulo(jinc(5),itn(4)) +! convert remainder to seconds and determine canonical seconds + jinc(4)=iinc(4)+(jinc(5)-kinc(5))/itn(4) + kinc(4)=modulo(jinc(4),itn(3)) +! convert remainder to minutes and determine canonical minutes + jinc(3)=iinc(3)+(jinc(4)-kinc(4))/itn(3) + kinc(3)=modulo(jinc(3),itn(2)) +! convert remainder to hours and determine canonical hours + jinc(2)=iinc(2)+(jinc(3)-kinc(3))/itn(2) + kinc(2)=modulo(jinc(2),itn(1)) +! convert remainder to days and compute milliseconds of the day + kinc(1)=iinc(1)+(jinc(2)-kinc(2))/itn(1) + ms=dot_product(kinc(2:5),itm(2:5)) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! next reduce to either single value canonical form +! or to one of the two reduced forms + if(it.ge.1.and.it.le.5) then +! ensure that exact multiples of 1./np are expressed exactly +! (other fractions may have precision errors) + rp=(np*ms)/itm(it)+mod(np*ms,itm(it))/real(itm(it)) + dinc=0 + dinc(it)=real(kinc(1))*itd(it)+rp/np + else +! the reduced form is done except the second reduced form is modified +! for negative time intervals with fractional days + dinc=kinc + if(it.eq.0.and.kinc(1).lt.0.and.ms.gt.0) then + dinc(1)=dinc(1)+1 + dinc(2:5)=mod(ms-itm(1),itm(1:4))/itm(2:5) + endif + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end diff --git a/WPS/ungrib/src/ngl/w3/w3tagb.f b/WPS/ungrib/src/ngl/w3/w3tagb.f new file mode 100755 index 00000000..a3d77f1a --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3tagb.f @@ -0,0 +1,119 @@ + SUBROUTINE W3TAGB(PROG,KYR,JD,LF,ORG) +C$$$ SUBPROGRAM DOCUMENTATION BLOCK +C +C SUBPROGRAM: W3TAGB OPERATIONAL JOB IDENTIFIER +C PRGMMR: FARLEY ORG: NP11 DATE: 1998-03-17 +C +C ABSTRACT: PRINTS IDENTIFYING INFORMATION FOR OPERATIONAL +C codes. CALLED AT THE BEGINNING OF A code, W3TAGB PRINTS +C THE program NAME, THE YEAR AND JULIAN DAY OF ITS +C COMPILATION, AND THE RESPONSIBLE ORGANIZATION. ON A 2ND +C LINE IT PRINTS THE STARTING DATE-TIME. CALLED AT THE +C END OF A JOB, entry routine, W3TAGE PRINTS A LINE WITH THE +C ENDING DATE-TIME AND A 2ND LINE STATING THE program name +C AND THAT IT HAS ENDED. +C +C PROGRAM HISTORY LOG: +C 85-10-29 J.NEWELL +C 89-10-20 R.E.JONES CONVERT TO CRAY CFT77 FORTRAN +C 91-03-01 R.E.JONES ADD MACHINE NAME TO ENDING LINE +C 92-12-02 R.E.JONES ADD START-ENDING TIME-DATE +C 93-11-16 R.E.JONES ADD DAY OF YEAR, DAY OF WEEK, AND JULIAN DAY +C NUMBER. +C 97-12-24 M.FARLEY PRINT STATEMENTS MODIFIED FOR 4-DIGIT YR +C 98-03-17 M.FARLEY REPLACED DATIMX WITH CALLS TO W3LOCDAT/W3DOXDAT +C 99-01-29 B. VUONG CONVERTED TO IBM RS/6000 SP +C +C 99-06-17 A. Spruill ADJUSTED THE SIZE OF PROGRAM NAME TO ACCOMMODATE +C THE 20 CHARACTER NAME CONVENTION ON THE IBM SP. +C 1999-08-24 Gilbert added call to START() in W3TAGB and a call +C to SUMMARY() in W3TAGE to print out a +C resource summary list for the program using +C W3TAGs. +C +C USAGE: CALL W3TAGB(PROG, KYR, JD, LF, ORG) +C CALL W3TAGE(PROG) +C +C INPUT VARIABLES: +C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES +C ------ --------- ----------------------------------------------- +C PROG ARG LIST PROGRAM NAME CHARACTER*1 +C KYR ARG LIST YEAR OF COMPILATION INTEGER +C JD ARG LIST JULIAN DAY OF COMPILATION INTEGER +C LF ARG LIST HUNDRETHS OF JULIAN DAY OF COMPILATION +C INTEGER (RANGE IS 0 TO 99 INCLUSIVE) +C ORG ARG LIST ORGANIZATION CODE (SUCH AS WD42) +C CHARACTER*1 +C +C OUTPUT VARIABLES: +C NAMES INTERFACE DESCRIPTION OF VARIABLES AND TYPES +C ---------------------------------------------------------------- +C DDATE PRINT YEAR AND JULIAN DAY (NEAREST HUNDRETH) +C FILE OF COMPILATION REAL +C +C SUBPROGRAMS CALLED: CLOCK, DATE +C +C REMARKS: FULL WORD USED IN ORDER TO HAVE AT LEAST +C SEVEN DECIMAL DIGITS ACCURACY FOR VALUE OF DDATE. +C SUBPROGRAM CLOCK AND DATE MAY DIFFER FOR EACH TYPE +C COMPUTER. YOU MAY HAVE TO CHANGE THEM FOR ANOTHER +C TYPE OF COMPUTER. +C +C ATTRIBUTES: +C LANGUAGE: FORTRAN 90 +C +C$$$ +C + CHARACTER *(*) PROG,ORG + CHARACTER * 3 JMON(12) + CHARACTER * 3 DAYW(7) +C + INTEGER IDAT(8), JDOW, JDOY, JDAY +C + SAVE +C + DATA DAYW/'SUN','MON','TUE','WEN','THU','FRI','SAT'/ + DATA JMON /'JAN','FEB','MAR','APR','MAY','JUN', + & 'JUL','AUG','SEP','OCT','NOV','DEC'/ +C + CALL START() + + DYR = KYR + DYR = 1.0E+03 * DYR + DJD = JD + DLF = LF + DLF = 1.0E-02 * DLF + DDATE = DYR + DJD + DLF + PRINT 600 + 600 FORMAT(//,10('* . * . ')) + PRINT 601, PROG, DDATE, ORG + 601 FORMAT(5X,'PROGRAM ',A,' HAS BEGUN. COMPILED ',F10.2, + & 5X, 'ORG: ',A) +C + CALL W3LOCDAT(IDAT) + CALL W3DOXDAT(IDAT,JDOW,JDOY,JDAY) + PRINT 602, JMON(IDAT(2)),IDAT(3),IDAT(1),IDAT(5),IDAT(6), + & IDAT(7),IDAT(8),JDOY,DAYW(JDOW),JDAY + 602 FORMAT(5X,'STARTING DATE-TIME ',A3,1X,I2.2,',', + & I4.4,2X,2(I2.2,':'),I2.2,'.',I3.3,2X,I3,2X,A3,2X,I8,//) + RETURN +C + ENTRY W3TAGE(PROG) +C + CALL W3LOCDAT(IDAT) + CALL W3DOXDAT(IDAT,JDOW,JDOY,JDAY) + PRINT 603, JMON(IDAT(2)),IDAT(3),IDAT(1),IDAT(5),IDAT(6), + & IDAT(7),IDAT(8),JDOY,DAYW(JDOW),JDAY + 603 FORMAT(//,5X,'ENDING DATE-TIME ',A3,1X,I2.2,',', + & I4.4,2X,2(I2.2,':'),I2.2,'.',I3.3,2X,I3,2X,A3,2X,I8) + PRINT 604, PROG + 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. IBM RS/6000 SP') +C 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. CRAY J916/2048') +C 604 FORMAT(5X,'PROGRAM ',A,' HAS ENDED. CRAY Y-MP EL2/256') + PRINT 605 + 605 FORMAT(10('* . * . ')) + + CALL SUMMARY() +C + RETURN + END diff --git a/WPS/ungrib/src/ngl/w3/w3utcdat.f b/WPS/ungrib/src/ngl/w3/w3utcdat.f new file mode 100755 index 00000000..600f573b --- /dev/null +++ b/WPS/ungrib/src/ngl/w3/w3utcdat.f @@ -0,0 +1,67 @@ +!----------------------------------------------------------------------- + subroutine w3utcdat(idat) +!$$$ SUBPROGRAM DOCUMENTATION BLOCK +! +! SUBPROGRAM: W3UTCDAT RETURN THE UTC DATE AND TIME +! AUTHOR: MARK IREDELL ORG: WP23 DATE: 98-01-05 +! +! ABSTRACT: THIS SUBPROGRAM RETURNS THE UTC (GREENWICH) DATE AND TIME +! IN THE NCEP ABSOLUTE DATE AND TIME DATA STRUCTURE. +! +! PROGRAM HISTORY LOG: +! 98-01-05 MARK IREDELL +! 1999-04-28 Gilbert - added a patch to check for the proper +! UTC offset. Needed until the IBM bug +! in date_and_time is fixed. The patch +! can then be removed. See comments in +! the section blocked with "&&&&&&&&&&&". +! 1999-08-12 Gilbert - Changed so that czone variable is saved +! and the system call is only done for +! first invocation of this routine. +! +! USAGE: CALL W3UTCDAT(IDAT) +! +! OUTPUT VARIABLES: +! IDAT INTEGER (8) NCEP ABSOLUTE DATE AND TIME +! (YEAR, MONTH, DAY, TIME ZONE, +! HOUR, MINUTE, SECOND, MILLISECOND) +! +! SUBPROGRAMS CALLED: +! DATE_AND_TIME FORTRAN 90 SYSTEM DATE INTRINSIC +! IW3JDN COMPUTE JULIAN DAY NUMBER +! W3FS26 YEAR, MONTH, DAY FROM JULIAN DAY NUMBER +! +! ATTRIBUTES: +! LANGUAGE: FORTRAN 90 +! +!$$$ + integer idat(8) + character cdate*8,ctime*10,czone*5 +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! get local date and time but use the character time zone + call date_and_time(cdate,ctime,czone,idat) + read(czone,'(i5)') idat(4) +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +! convert to hours and minutes to UTC time +! and possibly adjust the date as well + idat(6)=idat(6)-mod(idat(4),100) + idat(5)=idat(5)-idat(4)/100 + idat(4)=0 + if(idat(6).lt.00) then + idat(6)=idat(6)+60 + idat(5)=idat(5)-1 + elseif(idat(6).ge.60) then + idat(6)=idat(6)-60 + idat(5)=idat(5)+1 + endif + if(idat(5).lt.00) then + idat(5)=idat(5)+24 + jldayn=iw3jdn(idat(1),idat(2),idat(3))-1 + call w3fs26(jldayn,idat(1),idat(2),idat(3),idaywk,idayyr) + elseif(idat(5).ge.24) then + idat(5)=idat(5)-24 + jldayn=iw3jdn(idat(1),idat(2),idat(3))+1 + call w3fs26(jldayn,idat(1),idat(2),idat(3),idaywk,idayyr) + endif +! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + end diff --git a/WPS/ungrib/src/output.F b/WPS/ungrib/src/output.F new file mode 100644 index 00000000..2c802fd7 --- /dev/null +++ b/WPS/ungrib/src/output.F @@ -0,0 +1,316 @@ +subroutine output(hdate, nlvl, maxlvl, plvl, interval, iflag, out_format, prefix, debug_level) +! ! +!*****************************************************************************! +! Write output to a file. +! ! +! hdate : date string +! nlvl : number of pressure levels +! maxlvl : dimension of the pressure level array (plvl) +! plvl : pressure level array +! interval : period between processing times (seconds) +! iflag : 1 = output for ingest into rrpr ; 2 = final intermediate-format output +! out_format : requested output format (WPS, SI, or MM5) +! prefix : file name prefix +! debug_level : debug output parameter +! ! +!*****************************************************************************! + + use table + use gridinfo + use storage_module + use filelist + use module_debug + use misc_definitions_module + use stringutil + + implicit none + + character(LEN=19) :: hdate + character(LEN=24) :: hdate_output + character(LEN=3) :: out_format + character(LEN=MAX_FILENAME_LEN) :: prefix + integer :: iunit = 13 + + real, pointer, dimension(:,:) :: scr2d + + integer :: maxlvl + integer nlvl, debug_level + real , dimension(maxlvl) :: plvl + character (LEN=9) :: field + real :: level + integer :: sunit = 14 + integer :: interval + integer :: iflag +! Local Miscellaneous + integer :: k, n, mm, ilev + integer :: ii, jj + real :: maxv, minv + real :: xplv + real :: xfcst = 0. + character (LEN=25) :: units + character (LEN=46) :: Desc + character (LEN=9) :: tmp9 + logical lopen + +! DATELEN: length of date strings to use for our output file names. + integer :: datelen + +! Decide the length of date strings to use for output file names. +! DATELEN is 13 for hours, 16 for minutes, and 19 for seconds. + if (mod(interval,3600) == 0) then + datelen = 13 + elseif (mod(interval,60) == 0) then + datelen = 16 + else + datelen = 19 + endif + + call get_plvls(plvl, maxlvl, nlvl) + + if ( debug_level .ge. 0 ) then + write(*,119) hdate(1:10), hdate(12:19) +119 format(/,79('#'),//,'Inventory for date = ', A10,1x,A8,/) + call mprintf(.true.,LOGFILE,"Inventory for date = %s %s",s1=hdate(1:10),s2=hdate(12:19)) + + write(*,advance='NO', fmt='("PRES", 2x)') + write(tmp9,'(a9)') 'PRES' + call right_justify(tmp9,9) + call mprintf(.true.,LOGFILE,tmp9,newline=.false.) + WRTLOOP : do n = 1, maxvar + do k = 1, n-1 + if (namvar(k).eq.namvar(n)) cycle WRTLOOP + enddo + write(*,advance='NO', fmt='(1x,A8)') namvar(n) + write(tmp9,'(A9)') namvar(n)(1:9) + call right_justify(tmp9,9) + call mprintf(.true.,LOGFILE,tmp9,newline=.false.) + enddo WRTLOOP + write(*,advance='YES', fmt='(1x)') + call mprintf(.true.,LOGFILE,' ',newline=.true.) + + write(*,FMT='(79("-"))') + call mprintf(.true.,LOGFILE,"-------------------------------------------------") + end if + KLOOP : do k = 1, nlvl + if ((iflag.eq.2).and.(plvl(k).gt.200100) .and. (plvl(k).lt.200200)) then + cycle KLOOP + endif + ilev = nint(plvl(k)) + if ( debug_level .ge. 0 ) then + write(*, advance='NO', FMT='(F6.1)') plvl(k)/100. + write(tmp9,'(I9)') nint(plvl(k)) + call mprintf(.true.,LOGFILE,'%s ',s1=tmp9,newline=.false.) + end if + MLOOP : do mm = 1, maxvar + do n = 1, mm-1 + if (namvar(mm).eq.namvar(n)) cycle MLOOP + enddo + if ( debug_level .ge. 0 ) then + if (is_there(ilev,namvar(mm))) then + write(*, advance='NO', FMT='(" X ")') + call mprintf(.true.,LOGFILE,' X',newline=.false.) + else + if ( plvl(k).gt.200000 ) then + write(*, advance='NO', FMT='(" O ")') + call mprintf(.true.,LOGFILE,' O',newline=.false.) + else + write(*, advance='NO', FMT='(" ")') + call mprintf(.true.,LOGFILE,' -',newline=.false.) + endif + endif + endif + enddo MLOOP + if ( debug_level .ge. 0 ) then + write(*,advance='YES', fmt='(1x)') + call mprintf(.true.,LOGFILE,' ',newline=.true.) + endif + enddo KLOOP + if ( debug_level .ge. 0 ) then + write(*,FMT='(79("-"))') + call mprintf(.true.,LOGFILE,"-------------------------------------------------") + endif + + if (iflag.eq.1) then + if (nfiles.eq.0) then + open(iunit, file=trim(get_path(prefix))//'PFILE:'//HDATE(1:datelen), form='unformatted', & + position='REWIND') + nfiles = nfiles + 1 + filedates(nfiles)(1:datelen) = hdate(1:datelen) + else + DOFILES : do k = 1, nfiles + if (hdate(1:datelen).eq.filedates(k)(1:datelen)) then + open(iunit, file=trim(get_path(prefix))//'PFILE:'//HDATE(1:datelen), form='unformatted',& + position='APPEND') + endif + enddo DOFILES + inquire (iunit, OPENED=LOPEN) + if (.not. LOPEN) then + open(iunit, file=trim(get_path(prefix))//'PFILE:'//HDATE(1:datelen), form='unformatted', & + position='REWIND') + nfiles = nfiles + 1 + filedates(nfiles)(1:datelen) = hdate(1:datelen) + endif + endif + else if (iflag.eq.2) then + open(iunit, file=trim(prefix)//':'//HDATE(1:datelen), form='unformatted', & + position='REWIND') + endif + +!MGD if ( debug_level .gt. 100 ) then +!MGD write(6,*) 'begin nloop' +!MGD end if + NLOOP : do n = 1, nlvl + +!MGD if ( debug_level .gt. 100 ) then +!MGD write(6,*) 'begin outloop' +!MGD end if + OUTLOOP : do mm = 1, maxvar + field = namvar(mm) + do k = 1, mm-1 + if (field.eq.namvar(k)) cycle OUTLOOP + enddo + level = plvl(n) + if ((iflag.eq.2).and.(level.gt.200100) .and. (level.lt.200200)) then + cycle NLOOP + endif + ilev = nint(level) + desc = ddesc(mm) + if (iflag.eq.2) then + if (desc.eq.' ') cycle OUTLOOP + endif + units = dunits(mm) + if ((iflag.eq.1).or.(iflag.eq.2.and.desc(1:1).ne.' ')) then + if (is_there(ilev,field)) then + call get_dims(ilev, field) + +!MGD if ( debug_level .gt. 100 ) then +!MGD write(6,*) 'call refr_storage' +!MGD end if + call refr_storage(ilev, field, scr2d, map%nx, map%ny) + +!MGD if ( debug_level .gt. 100 ) then +!MGD write(6,*) 'back from refr' +!MGD write(6,*) 'out_format = ',out_format +!MGD end if + + if (out_format(1:2) .eq. 'SI') then +!MGD if ( debug_level .gt. 100 ) then +!MGD write(6,*) 'writing in SI format' +!MGD end if + write(iunit) 4 + hdate_output = hdate + write (iunit) hdate_output, xfcst, map%source, field, units, & + Desc, level, map%nx, map%ny, map%igrid + if (map%igrid.eq.3) then ! lamcon + write (iunit) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%truelat2 + elseif (map%igrid.eq.5) then ! Polar Stereographic + write (iunit) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1 + elseif (map%igrid.eq.0 .or. map%igrid.eq.4)then ! lat/lon + write (iunit) map%startloc, map%lat1, map%lon1, map%dy, map%dx + elseif (map%igrid.eq.1)then ! Mercator + write (iunit) map%startloc, map%lat1, map%lon1, map%dy, map%dx, & + map%truelat1 + else + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in subroutine output 1",i1=map%igrid) + endif + write (iunit) scr2d + else if (out_format(1:2) .eq. 'WP') then + call mprintf(.true.,DEBUG, & + "writing in WPS format iunit = %i, map%%igrid = %i",i1=iunit,i2=map%igrid) + write(iunit) 5 + hdate_output = hdate + write (iunit) hdate_output, xfcst, map%source, field, units, & + Desc, level, map%nx, map%ny, map%igrid + if (map%igrid.eq.3) then ! lamcon + write (iunit) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%truelat2, map%r_earth + elseif (map%igrid.eq.5) then ! Polar Stereographic + write (iunit) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%r_earth + elseif (map%igrid.eq.0 .or. map%igrid.eq.4)then ! lat/lon + write (iunit) map%startloc, map%lat1, map%lon1, map%dy, map%dx, & + map%r_earth + elseif (map%igrid.eq.1)then ! Mercator + write (iunit) map%startloc, map%lat1, map%lon1, map%dy, map%dx, & + map%truelat1, map%r_earth + elseif (map%igrid.eq.6)then ! CASSINI + write (iunit) map%startloc, map%lat1, map%lon1, map%dy, map%dx, & + map%lat0, map%lon0, map%r_earth ! refer to gridinfo.F + else + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in subroutine output 1",i1=map%igrid) + endif + write (iunit) map%grid_wind + write (iunit) scr2d + else if (out_format(1:2) .eq. 'MM') then +!MGD if ( debug_level .gt. 100 ) then +!MGD write(6,*) 'writing in MM5 format' +!MGD end if + if (iflag .eq. 2) then ! make sure the field names are MM5-compatible + if ( field .eq. 'TT' ) field = 'T' + if ( field .eq. 'UU' ) field = 'U' + if ( field .eq. 'VV' ) field = 'V' + if ( field .eq. 'SNOW' ) field = 'WEASD' + endif + write(iunit) 3 + hdate_output = hdate + write (iunit) hdate_output, xfcst, field, units, Desc, level,& + map%nx, map%ny, map%igrid + if (map%igrid.eq.3) then ! lamcon + write (iunit) map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1, map%truelat2 + elseif (map%igrid.eq.5) then ! Polar Stereographic + write (iunit) map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1 + elseif (map%igrid.eq.0 .or. map%igrid.eq.4)then ! lat/lon + write (iunit) map%lat1, map%lon1, map%dy, map%dx + elseif (map%igrid.eq.1)then ! Mercator + write (iunit) map%lat1, map%lon1, map%dy, map%dx, map%truelat1 + else + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in subroutine output 1",i1=map%igrid) + endif + write (iunit) scr2d + endif + if ( debug_level .gt. 100 ) then + call mprintf(.true.,DEBUG, & + "hdate = %s, xfcst = %f ",s1=hdate_output,f1=xfcst) + call mprintf(.true.,DEBUG, & + "map%%source = %s, field = %s, units = %s",s1=map%source,s2=field,s3=units) + call mprintf(.true.,DEBUG, & + "Desc = %s, level = %f",s1=Desc,f1=level) + call mprintf(.true.,DEBUG, & + "map%%nx = %i, map%%ny = %i",i1=map%nx,i2=map%ny) + else if ( debug_level .gt. 0 ) then + call mprintf(.true.,STDOUT, & + " field = %s, level = %f",s1=field,f1=level) + call mprintf(.true.,LOGFILE, & + " field = %s, level = %f",s1=field,f1=level) + end if + if ( debug_level .gt. 100 ) then + maxv = -99999. + minv = 999999. + do jj = 1, map%ny + do ii = 1, map%nx + if (scr2d(ii,jj) .gt. maxv) maxv = scr2d(ii,jj) + if (scr2d(ii,jj) .lt. minv) minv = scr2d(ii,jj) + enddo + enddo + call mprintf(.true.,DEBUG, & + "max value = %f , min value = %f",f1=maxv,f2=minv) + end if + + nullify(scr2d) + + endif + endif + enddo OUTLOOP + enddo NLOOP + + close(iunit) + +end subroutine output + diff --git a/WPS/ungrib/src/parse_table.F b/WPS/ungrib/src/parse_table.F new file mode 100644 index 00000000..0eaddcbd --- /dev/null +++ b/WPS/ungrib/src/parse_table.F @@ -0,0 +1,484 @@ +!*****************************************************************************! +! Subroutine PARSE_TABLE ! +! ! +! Purpose: ! +! Read the Vtable, and fill arrays in the TABLE module with the Vtable ! +! information. Broadly, the Vtable file is how the user tells the ! +! program what fields to extract from the archive files. ! +! ! +! Argument list: ! +! Input: DEBUG_LEVEL: 0 = no prints, bigger numbers = more prints ! +! +! Externals: ! +! Module TABLE ! +! Subroutine ABORT ! +! ! +! Side Effects: ! +! ! +! - File "Vtable" is opened, read, and closed as Fortran unit 10. ! +! ! +! - Various prints, especially if DEBUG_PRINT = .TRUE. ! +! ! +! - Abort for some miscellaneous error conditions. ! +! ! +! - Variables in module TABLE are filled., specifically, variables ! +! MAXVAR ! +! MAXOUT ! +! ! +! - Arrays in module TABLE are filled., specifically, arrays ! +! NAMVAR ! +! NAMEOUT ! +! UNITOUT ! +! DESCOUT ! +! GCODE ! +! LCODE ! +! LEVEL1 ! +! LEVEL2 ! +! IPRTY ! +! DUNITS ! +! DDESC ! +! ! +! Author: Kevin W. Manning ! +! NCAR/MMM ! +! Summer 1998, and continuing ! +! SDG ! +! ! +!*****************************************************************************! + +subroutine parse_table(debug_level,vtable_columns) + use Table + use module_debug + use stringutil + implicit none + integer :: debug_level + + character(LEN=255) :: string = ' ' + integer :: ierr + integer :: istart, ibar, i, j, ipcount + integer :: jstart, jbar, jmax, tot_bars + integer :: vtable_columns + integer :: nstart, maxtmp + logical :: lexist + character(len=9) :: tmp9 + +! added for IBM + blankcode = -99 + splatcode = -88 +! end added for IBM + +! Open the file called "Vtable" + + open(10, file='Vtable', status='old', form='formatted', iostat=ierr) + +! Check to see that the OPEN worked without error. + + if (ierr.ne.0) then + inquire(file='Vtable', exist=LEXIST) + call mprintf(.true.,STDOUT," ***** ERROR in Subroutine PARSE_TABLE:") + call mprintf(.true.,LOGFILE," ***** ERROR in Subroutine PARSE_TABLE:") + if (.not.lexist) then + call mprintf(.true.,STDOUT,"Problem opening file Vtable.") + call mprintf(.true.,STDOUT,"File ''Vtable'' does not exist.") + call mprintf(.true.,LOGFILE,"Problem opening file Vtable.") + call mprintf(.true.,LOGFILE,"File ''Vtable'' does not exist.") + else + call mprintf(.true.,STDOUT,"Problem opening file Vtable.") + call mprintf(.true.,STDOUT,"File Vtable exists, but Fortran OPEN statement") + call mprintf(.true.,STDOUT,"failed with error %i",i1=ierr) + call mprintf(.true.,LOGFILE,"Problem opening file Vtable.") + call mprintf(.true.,LOGFILE,"File Vtable exists, but Fortran OPEN statement") + call mprintf(.true.,LOGFILE,"failed with error %i",i1=ierr) + endif + call mprintf(.true.,ERROR," ***** Stopping in Subroutine PARSE_TABLE") + endif + +! First, read past the headers, i.e., skip lines until we hit the first +! line beginning with '-' + do while (string(1:1).ne.'-') + read(10,'(A255)', iostat=ierr) string + call mprintf ((ierr /= 0),ERROR,"Read error 1 in PARSE_TABLE.") + enddo + string = ' ' + +! Now interpret everything from here to the next '-' line: +! + RDLOOP : do while (string(1:1).ne.'-') + read(10,'(A255)', iostat=ierr) string + call mprintf ((ierr /= 0),ERROR,"Read error 2 in PARSE_TABLE.") + if (string(1:1).eq.'#') cycle RDLOOP + if (len_trim(string) == 0) cycle RDLOOP + if (string(1:1).eq.'-') then + ! Skip over internal header lines + BLOOP : do + read(10,'(A255)', iostat=ierr) string + if (ierr /= 0) exit RDLOOP + if (len_trim(string) == 0) then + cycle BLOOP + else if (string(1:1) == '#') then + cycle BLOOP + else + exit BLOOP + endif + enddo BLOOP + do while (string(1:1).ne.'-') + read(10,'(A255)', iostat=ierr) string + call mprintf ((ierr /= 0),ERROR,"Read error 3 in PARSE_TABLE.") + enddo + string(1:1) = ' ' + + elseif (string(1:1).ne.'-') then + ! This is a line of values to interpret and parse. + maxvar = maxvar + 1 ! increment the variable count + + ! --- Determine Grib1 or Grib2 + ! If there are seven fields this is a Grib1 Vtable, + ! if there are eleven fields this is a Grib2 Vtable. + jstart = 1 + jmax=jstart + tot_bars=0 + + do j = 1, vtable_columns + ! The fields are delimited by '|' + jbar = index(string(jstart:255),'|') + jstart - 2 + jstart = jbar + 2 + if (jstart.gt.jmax) then + tot_bars=tot_bars+1 + jmax=jstart + else + cycle + endif + enddo + + call mprintf((tot_bars.eq.7.and.vtable_columns.ge.11),ERROR, & + 'Vtable does not contain Grib2 decoding information.'// & + ' 11 or 12 columns of information is expected.'// & + ' *** stopping parse_table ***') + + + istart = 1 + ! There are seven fields (Grib1) or eleven fields (Grib2) to each line. + PLOOP : do i = 1, vtable_columns + ! The fields are delimited by '|' + + ibar = index(string(istart:255),'|') + istart - 2 + + if (i.eq.1) then + ! The first field is the Grib1 param code number: + + if (string(istart:ibar) == ' ') then + gcode(maxvar) = blankcode + elseif (scan(string(istart:ibar),'*') /= 0) then + call mprintf(.true.,ERROR,'Parse_table: Please give a '// & + 'Grib1 parm code rather than $ in the first column of Vtable '// & + '*** stopping in parse_table ***') + else + read(string(istart:ibar), * ) gcode(maxvar) + endif + + elseif (i.eq.2) then + ! The second field is the Grib1 level type: + + if (string(istart:ibar) == ' ') then + if (lcode(maxvar) /= blankcode) then + call mprintf(.true.,ERROR,'Parse_table: '// & + 'Please supply a Grib1 level type in the Vtable: %s '// & + '*** stopping in parse_table ***',s1=string) + else + lcode(maxvar) = blankcode + endif + elseif (scan(string(istart:ibar),'*') /= 0) then + call mprintf(.true.,ERROR,'Parse_table: '// & + "Used a * in Grib1 level type...don't do this! "// & + '*** stopping in parse_table ***') + else + read(string(istart:ibar), *) lcode(maxvar) + endif + + elseif (i.eq.3) then + ! The third field is the Level 1 value, which may be '*': + + if (string(istart:ibar) == ' ') then + level1(maxvar) = blankcode + elseif (scan(string(istart:ibar),'*') == 0) then + read(string(istart:ibar), *) level1(maxvar) + else + level1(maxvar) = splatcode + endif + + elseif (i.eq.4) then + ! The fourth field is the Level 2 value, which may be blank: + + if (string(istart:ibar) == ' ') then + if ( (lcode(maxvar) == 112) .or.& + (lcode(maxvar) == 116) ) then + call mprintf(.true.,ERROR,'Parse_table: '// & + 'Level Code expects two Level values. '// & + '*** stopping in parse_table ***') + else + level2(maxvar) = blankcode + endif + elseif (scan(string(istart:ibar),'*') /= 0) then + call mprintf(.true.,ERROR,'Parse_table: '// & + 'Please give a Level 2 value (or blank), rather * in Vtable column 4 '// & + '*** stopping in parse_table ***') + else + read(string(istart:ibar), *) level2(maxvar) + endif + + elseif (i.eq.5) then + ! The fifth field is the param name: + + if (string(istart:ibar).ne.' ') then + nstart = 0 + do while (string(istart+nstart:istart+nstart).eq.' ') + nstart = nstart + 1 + enddo + namvar(maxvar) = string(istart+nstart:ibar) + else + call mprintf(.true.,ERROR,'Parse_table: '// & + 'A field name is missing in the Vtable. '// & + '*** stopping in parse_table ***') + endif + + elseif (i.eq.6) then + ! The sixth field is the Units string, which may be blank: + + if (string(istart:ibar).ne.' ') then + nstart = 0 + do while (string(istart+nstart:istart+nstart).eq.' ') + nstart = nstart + 1 + enddo + Dunits(maxvar) = string(istart+nstart:ibar) + else + Dunits(maxvar) = ' ' + endif + + elseif (i.eq.7) then + ! The seventh field is the description string, which may be blank: + + if (string(istart:ibar).ne.' ') then + nstart = 0 + do while (string(istart+nstart:istart+nstart).eq.' ') + nstart = nstart + 1 + enddo + Ddesc(maxvar) = string(istart+nstart:ibar) + + ! If the description string is not blank, this is a + ! field we want to output. In that case, copy the + ! param name to the MAXOUT array: + maxout = maxout + 1 + nameout(maxout) = namvar(maxvar) + unitout(maxout) = Dunits(maxvar) + descout(maxout) = Ddesc(maxvar) + + else + Ddesc(maxvar) = ' ' + endif + + elseif (i.eq.8) then + ! The eighth field is the Grib2 Product Discipline (see the + ! Product Definition Template, Table 4.2). + + !cycle RDLOOP + !read(string(istart:ibar), * ,eor=995) g2code(1,maxvar) + + if (string(istart:ibar) == ' ') then + g2code(1,maxvar) = blankcode + elseif (scan(string(istart:ibar),'*') /= 0) then + call mprintf(.true.,STDOUT," ERROR reading Grib2 Discipline") + call mprintf(.true.,STDOUT, & + "This Grib2 Vtable line is incorrectly specified:") + call mprintf(.true.,STDOUT," %s",s1=string) + call mprintf(.true.,LOGFILE," ERROR reading Grib2 Discipline") + call mprintf(.true.,LOGFILE, & + "This Grib2 Vtable line is incorrectly specified:") + call mprintf(.true.,LOGFILE," %s",s1=string) + call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE") + else + read(string(istart:ibar), *) g2code(1,maxvar) + endif + + elseif (i.eq.9) then + ! The ninth field is the Grib2 Parameter Category per Discipline. + + if (string(istart:ibar) == ' ') then + g2code(2,maxvar) = blankcode + elseif (scan(string(istart:ibar),'*') /= 0) then + call mprintf(.true.,STDOUT," ERROR reading Grib2 Category") + call mprintf(.true.,STDOUT, & + "This Grib2 Vtable line is incorrectly specified:") + call mprintf(.true.,STDOUT," %s",s1=string) + call mprintf(.true.,LOGFILE," ERROR reading Grib2 Category") + call mprintf(.true.,LOGFILE, & + "This Grib2 Vtable line is incorrectly specified:") + call mprintf(.true.,LOGFILE," %s",s1=string) + call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE") + else + read(string(istart:ibar), * ) g2code(2,maxvar) + endif + + elseif (i.eq.10) then + ! The tenth field is the Grib2 Parameter Number per Category. + + if (string(istart:ibar) == ' ') then + g2code(3,maxvar) = blankcode + elseif (scan(string(istart:ibar),'*') /= 0) then + call mprintf(.true.,STDOUT, & + " ERROR reading Grib2 Parameter Number ") + call mprintf(.true.,STDOUT, & + "This Grib2 Vtable line is incorrectly specified:") + call mprintf(.true.,STDOUT," %s",s1=string) + call mprintf(.true.,LOGFILE, & + " ERROR reading Grib2 Parameter Number ") + call mprintf(.true.,LOGFILE, & + "This Grib2 Vtable line is incorrectly specified:") + call mprintf(.true.,LOGFILE," %s",s1=string) + call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE") + else + read(string(istart:ibar), * ) g2code(3,maxvar) + endif + + elseif (i.eq.11) then + ! The eleventh field is the Grib2 Level Type (see the Product + ! Definition Template, Table 4.5). + + if (string(istart:ibar) == ' ') then + if (g2code(4,maxvar) /= blankcode) then + call mprintf(.true.,STDOUT," ERROR reading Grib2 Level Type ") + call mprintf(.true.,STDOUT, & + "This Grib2 Vtable line is incorrectly specified:") + call mprintf(.true.,STDOUT," %s",s1=string) + call mprintf(.true.,LOGFILE," ERROR reading Grib2 Level Type ") + call mprintf(.true.,LOGFILE, & + "This Grib2 Vtable line is incorrectly specified:") + call mprintf(.true.,LOGFILE," %s",s1=string) + call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE") + else + g2code(4,maxvar) = blankcode + endif + elseif (scan(string(istart:ibar),'*') /= 0) then + call mprintf(.true.,STDOUT,"ERROR in Subroutine Parse_table: ") + call mprintf(.true.,STDOUT, & + "Used a * in Grib2 level type...don't do this! ") + call mprintf(.true.,STDOUT," %s ",s1=string) + call mprintf(.true.,LOGFILE,"ERROR in Subroutine Parse_table: ") + call mprintf(.true.,LOGFILE, & + "Used a * in Grib2 level type...don't do this! ") + call mprintf(.true.,LOGFILE," %s ",s1=string) + call mprintf(.true.,ERROR," ***** Abort in Subroutine PARSE_TABLE") + else + read(string(istart:ibar), *) g2code(4,maxvar) + endif + + elseif (i.eq.12) then + ! The twelfth field is the Grib2 Product Definition Template number + ! Defaults to template 4.0, an instantaneous horizontal field. + ! The only other supported value is 8 - an accumulated or averaged field. + + if (istart .lt. ibar) then + if (string(istart:ibar) == ' ') then + g2code(5,maxvar) = 0 + elseif (scan(string(istart:ibar),'*') /= 0) then + call mprintf(.true.,STDOUT, & + " ERROR reading Grib2 Parameter Number ") + call mprintf(.true.,STDOUT, & + "This Grib2 Vtable line is incorrectly specified:") + call mprintf(.true.,STDOUT," %s",s1=string) + call mprintf(.true.,LOGFILE, & + " ERROR reading Grib2 Parameter Number ") + call mprintf(.true.,LOGFILE, & + "This Grib2 Vtable line is incorrectly specified:") + call mprintf(.true.,LOGFILE," %s",s1=string) + call mprintf(.true.,ERROR,"Stopping in PARSE_TABLE") + else + read(string(istart:ibar), * ) g2code(5,maxvar) + endif + else ! occurs when 11 columns are in the Vtable rather than 12. + g2code(5,maxvar) = 0 + endif + + endif + + istart = ibar + 2 + + enddo PLOOP ! 1,vtable_columns + endif +!995 continue + enddo RDLOOP +! Now we have finished reading the file. + close(10) + +! Now remove duplicates from the NAMEOUT array. Duplicates may arise +! when we have the same name referred to by different level or parameter +! codes in some dataset. + + maxtmp = maxout + do i = 1, maxtmp-1 + do j = i+1, maxtmp + if ((nameout(i).eq.nameout(j)).and.(nameout(j).ne.' ')) then + call mprintf(.true.,DEBUG, & + "Duplicate name. Removing %s from output list.",s1=nameout(j)) + nameout(j:maxlines-1) = nameout(j+1:maxlines) + unitout(j:maxlines-1) = unitout(j+1:maxlines) + descout(j:maxlines-1) = descout(j+1:maxlines) + maxout = maxout - 1 + endif + enddo + enddo + +! Compute a priority level based on position in the table: +! This assumes Grib. + +! Priorities are used only for surface fields. If it is not a +! surface fields, the priority is assigned a value of 100. + +! For surface fields, priorities are assigned values of 100, 101, +! 102, etc. in the order the field names appear in the Vtable. + + ipcount = 99 + do i = 1, maxvar + if ((lcode(i).eq.105).or.(lcode(i).eq.118)) then + ipcount = ipcount + 1 + iprty(i) = ipcount + elseif (lcode(i).eq.116.and.level1(i).le.50.and.level2(i).eq.0) then + ipcount = ipcount + 1 + iprty(i) = ipcount + else + iprty(i) = 100 + endif + enddo + + if (debug_level .gt. 0) then + write(*,'(//"Read from file ''Vtable'' by subroutine PARSE_TABLE:")') + call mprintf(.true.,DEBUG, & + "Read from file Vtable by subroutine PARSE_TABLE:") + do i = 1, maxvar + if (vtable_columns.ge.11) then + write(*,'(4I6, 3x,A10, 5I6)')& + gcode(i), lcode(i), level1(i), level2(i), namvar(i), & + g2code(1,i), g2code(2,i), g2code(3,i), g2code(4,i), g2code(5,i) + write(tmp9,'(i9)') gcode(i) + call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.) + write(tmp9,'(i9)') lcode(i) + call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.) + write(tmp9,'(i9)') level1(i) + call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.) + write(tmp9,'(i9)') level2(i) + call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.) + write(tmp9,'(a9)') namvar(i)(1:9) + call right_justify(tmp9,9) + call mprintf(.true.,DEBUG,tmp9,newline=.false.) + do j = 1, 5 + write(tmp9,'(i9)') g2code(j,i) + call mprintf(.true.,DEBUG,'%s ',s1=tmp9(4:9),newline=.false.) + enddo + call mprintf(.true.,DEBUG,' ',newline=.true.) + else + write(*,'(4I6, 3x,A10)')& + gcode(i), lcode(i), level1(i), level2(i), namvar(i) + endif + enddo + write(*,'(//)') + endif + +end subroutine parse_table diff --git a/WPS/ungrib/src/rd_grib1.F b/WPS/ungrib/src/rd_grib1.F new file mode 100644 index 00000000..b5b92cd5 --- /dev/null +++ b/WPS/ungrib/src/rd_grib1.F @@ -0,0 +1,647 @@ +!*****************************************************************************! +! Subroutine RD_GRIB1 ! +! ! +! Purpose: ! +! Read one record from the input GRIB file. Based on the information in ! +! the GRIB header and the user-defined Vtable, decide whether the field in ! +! the GRIB record is one to process or to skip. If the field is one we ! +! want to keep, extract the data from the GRIB record, and pass the data ! +! back to the calling routine. ! +! ! +! Argument list: ! +! Input: ! +! IUNIT : "Unit Number" to open and read from. Not really a Fortran ! +! unit number, since we do not do Fortran I/O for the GRIB ! +! files. Nor is it a UNIX File Descriptor returned from a C ! +! OPEN statement. It is really just an array index to the ! +! array (IUARR) where the UNIX File Descriptor values are ! +! stored. ! +! GRIBFLNM: File name to open, if it is not already open. ! +! IUARR : Array to hold UNIX File descriptors retured from a C open ! +! statement. If the value of IUARR(IUNIT) is zero, then the ! +! file GRIBFLNM must be opened, and the value of IUARR(IUNIT) ! +! becomes the UNIX File descriptor to read from. ! +! DEBUG_LEVEL Integer for various amounts of printout. ! +! ! +! Output: ! +! LEVEL : The pressure-level (Pa) of the field to process. ! +! FIELD : The field name of the field to process. NULL is returned ! +! if we do not want to process the field we read. ! +! HDATE : The 19-character date of the field to process. ! +! IERR : Error flag: 0 - no error on read from GRIB file. ! +! 1 - Hit the end of the GRIB file. ! +! 2 - The file GRIBFLNM we tried to open does ! +! not exist. ! +! Externals ! +! Module TABLE ! +! Module GRIDINFO ! +! Subroutine C_OPEN ! +! Subroutine DEALLOGRIB ! +! Subroutine GRIBGET ! +! Subroutine GRIBHEADER ! +! Subroutine GET_SEC1 ! +! Subroutine GET_SEC2 ! +! Subroutine GET_GRIDINFO ! +! Subroutine BUILD_HDATE ! +! Subroutine GETH_NEWDATE ! +! Subroutine GRIBDATA ! +! ! +! Side Effects ! +! File GRIBFLNM is opened, as necessary ! +! ! +! Variable MAP from module GRIDINFO is filled in. ! +! ! +! Numerous side effects from the GRIB-processing routines. ! +! ! +! Kevin W. Manning ! +! NCAR/MMM ! +! Summer, 1998, and continuing ! +! SDG ! +! ! +!*****************************************************************************! +SUBROUTINE rd_grib1(IUNIT, gribflnm, level, field, hdate, & + ierr, iuarr, debug_level) + use table + use gridinfo + use datarray + use module_debug + + implicit none + + integer :: debug_level + integer :: iunit ! Array number in IUARR assigned to the C read pointer. + integer, dimension(100) :: KSEC1 + integer, dimension(10) :: KSEC2 + integer, dimension(40) :: infogrid + real, dimension(40) :: ginfo +! +!----------------------------------------------------------------------- + integer :: iparm, ktype + logical :: lopen + + integer :: icenter, iprocess, iscan, ii, isb + integer year, month, day, hour, minute, second, icc, iyy + integer :: fcst + real :: level + character(LEN=*) :: field + character(LEN=132) :: gribflnm + character(LEN=8) :: tmp8 + integer, dimension(255) :: iuarr + integer :: ierr, iostat, nunit + integer :: i, lvl2, lvl1 + character(LEN=19) :: hdate + integer :: igherr + +! Variables for thinned grids: + logical :: lthinned = .FALSE. + real, allocatable, dimension(:) :: thinnedDataArray + integer, dimension(74) :: npoints_acc + real :: mj, xmj + integer :: np, ny, nx + real :: Va, Vb, Vc, Vd + real, external :: oned + + ierr = 0 + +! If the file GRIBFLNM has not been opened, then IUARR(IUNIT) should be Zero. +! In this case, open the file GRIBFLNM, and store the UNIX File descriptor +! in to IUARR(IUNIT). This way, we will know what UNIX File descriptor to use +! next time we call this RD_GRIB subroutine. +! + if (iuarr(iunit).eq.0) then + if (debug_level.gt.0) then + call c_open(iunit, nunit, gribflnm, 1, ierr, 1) + else + call c_open(iunit, nunit, gribflnm, 1, ierr, -1) + endif + if (ierr.ne.0) then + call deallogrib + ierr = 2 + return + endif + iuarr(iunit) = nunit + endif + +! Read a single GRIB record, but do no unpacking now: + + call gribget(iuarr(iunit), ierr) + + if (ierr.ne.0) then + call mprintf(.true.,DEBUG,"RD_GRIB1 gribget read error, ierr = %i",i1=ierr) + call deallogrib + return + endif +! +! Unpack the header information: +! + call gribheader(debug_level,igherr) + if (igherr /= 0) then + field = "NULL" + call deallogrib + return + endif +! +! Copy header information to arrays KSEC1, KSEC2, INFOGRID, and GRIDINFO +! + call get_sec1(ksec1) + call get_sec2(ksec2) + call get_gridinfo(infogrid, ginfo) + + icenter = KSEC1(3) ! Indicator of the source (center) of the data. + iprocess = KSEC1(4) ! Indicator of model (or whatever) which generated the data. + + if (icenter.eq.7) then + if (iprocess.eq.83 .or. iprocess.eq.84) then + map%source = 'NCEP MESO NAM Model' + elseif (iprocess.eq.81) then + map%source = 'NCEP GFS Analysis' + elseif (iprocess.eq.82) then + map%source = 'NCEP GFS GDAS/FNL' + elseif (iprocess.eq.89) then + map%source = 'NCEP NMM ' + elseif (iprocess.eq.96) then + map%source = 'NCEP GFS Model' + elseif (iprocess.eq.107) then + map%source = 'NCEP GEFS' + elseif (iprocess.eq.109) then + map%source = 'NCEP RTMA' + elseif (iprocess.eq.86 .or. iprocess.eq.100) then + map%source = 'NCEP RUC Model' ! 60 km + elseif (iprocess.eq.101) then + map%source = 'NCEP RUC Model' ! 40 km + elseif (iprocess.eq.105) then + map%source = 'NCEP RUC Model' ! 20 km + elseif (iprocess.eq.140) then + map%source = 'NCEP NARR' + elseif (iprocess.eq.195) then + map%source = 'NCEP CDAS2' + elseif (iprocess.eq.44) then + map%source = 'NCEP SST Analysis' + elseif (iprocess.eq.70) then + map%source = 'GFDL Hurricane Model' + elseif (iprocess.eq.129) then + map%source = 'NCEP GODAS' + elseif (iprocess.eq.25) then + map%source = 'NCEP SNOW COVER ANALYSIS' + else + map%source = 'unknown model from NCEP' + end if +! grid numbers only set for NCEP and AFWA models + write(tmp8,'("GRID ",i3)') KSEC1(5) + map%source(25:32) = tmp8 + else if (icenter .eq. 57) then + if (iprocess .eq. 87) then + map%source = 'AFWA AGRMET' + else + map%source = 'AFWA' + endif + write(tmp8,'("GRID ",i3)') KSEC1(5) + map%source(25:32) = tmp8 + else if (icenter .eq. 58) then + map%source = 'US Navy FNOC' + else if (icenter .eq. 59) then + if (iprocess .eq. 125) then + map%source = 'NOAA GSD Rapid Refresh' + else if (iprocess .eq. 105) then + map%source = 'NOAA GSD' + else + print *,'Unknown GSD source' + stop + endif + else if (icenter .eq. 60) then + map%source = 'NCAR' + else if (icenter .eq. 98) then + map%source = 'ECMWF' + else if (icenter .eq. 74 .or. icenter .eq. 75 ) then + map%source = 'UKMO' + else + map%source = 'unknown model and orig center' + end if + + IPARM=KSEC1(7) ! Indicator of parameter + KTYPE=KSEC1(8) ! Indicator of type of level + +! print *,' IPARM, KTYPE, KSEC1(9)', iparm,ktype,ksec1(9) + + IF(KTYPE.EQ.1) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.100) THEN + LVL1=FLOAT(KSEC1(9)) * 100. + LVL2=-99 + ELSEIF(KTYPE.EQ.101) THEN + LVL1=KSEC1(9) + LVL2=KSEC1(10) + ELSEIF(KTYPE.EQ.102) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.103) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.105) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.107) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.109) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.111) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.112) THEN ! Layer between two depths below surface + LVL1=KSEC1(9) + LVL2=KSEC1(10) + ELSEIF(KTYPE.EQ.113) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.115) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.117) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.119) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.125) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.160) THEN + LVL1=KSEC1(9) + LVL2=-99 + ELSEIF(KTYPE.EQ.200) THEN + LVL1=0 + LVL2=-99 + ELSEIF(KTYPE.EQ.201) THEN + LVL1=0 + LVL2=-99 + ELSE + LVL1=KSEC1(9) + LVL2=KSEC1(10) + ENDIF + +! Check to see that the combination of iparm, ktype, lvl1, and lvl2 +! match what has been requested in the Vtable. If not, set the field +! name to NULL, meaning that we do not want to process this one. + + field = 'NULL' + do i = 1, maxvar + if (gcode(i).eq.iparm) then + if (lcode(i).eq.ktype) then + if ((level1(i).eq.lvl1) .or. (level1(i) == splatcode) ) then + if (level2(i).eq.lvl2) then + field=namvar(i) + level = -999. + if (ktype.eq.100) then ! Pressure-level + level=lvl1 + elseif (ktype.eq.102) then + level=201300. + elseif ((ktype.eq.116.and.lvl1.le.50.and.lvl2.eq.0) .or. & + (ktype.eq.105).or.(ktype.eq.1) .or. & + (ktype.eq.111).or.(ktype.eq.112) ) then + ! level=200100. + level = float(200000+iprty(i)) + elseif (ktype.eq.109 .or. ktype.eq.107) then ! hybrid or sigma levels + level = lvl1 + elseif (ktype.eq. 6 ) then ! max wind + level = 6. + elseif (ktype.eq. 7 ) then ! trop + level = 7. + elseif (ktype .eq. 160 ) then ! depth below sea-surface (m) + level = 201500. + elseif (ktype .eq. 237 .or. ktype .eq. 238 ) then ! depth of ocean layer + level = 201600. + elseif (ktype .eq. 200 ) then !column variable (TCDC,PWAT,etc.) + level = lvl1 ! + endif + if (level .lt. -998. ) then + write(6,*) 'Could not find a level for this Vtable entry' + write(6,*) 'iparm = ',iparm,' ktype = ',ktype,' lvl1 = ',lvl1,' lvl2 = ',lvl2 + write(6,*) 'Fix the Vtable or modify rd_grib1.F' + stop 'rd_grib1' + endif + endif + endif + endif + endif + enddo + + if (field .eq. 'NULL') then + call deallogrib + return + endif + + if ((field.eq.'WEASD').or.(field.eq.'SNOW')) then + level = level + ksec1(19)+1 + endif + +! Build the 19-character date string, based on GRIB header date and time +! information, including forecast time information: + + ICC=KSEC1(22) ! CENTURY OF THE DATA + IYY=KSEC1(11) ! (TWO-DIGIT) YEAR OF THE DATA + MONTH=KSEC1(12) ! MONTH OF THE DATA + DAY=KSEC1(13) ! DAY OF THE DATA + HOUR=KSEC1(14) ! HOUR OF THE DATA + MINUTE=KSEC1(15) ! MINUTE OF THE DATA + SECOND=0 + if (ksec1(19) == 3) then + FCST = (KSEC1(17) + KSEC1(18))/2 +! TEMPORARY AFWA FIX +! elseif (ksec1(19) == 4 .or. ksec1(19) == 5) then + elseif (ksec1(19) == 4 .or. ksec1(19) == 5 .or. ksec1(19) == 7) then + FCST = KSEC1(18) + else + FCST = KSEC1(17) + endif +! convert the fcst units to hours if necessary + if (ksec1(16) .eq. 254 ) then + fcst = fcst/3600. + elseif (ksec1(16) .eq. 0 ) then + fcst = fcst/60. + endif + + if (IYY.EQ.00) then + YEAR = ICC*100 + else + YEAR = (ICC-1)*100 + IYY + endif + + hdate(1:19) = ' ' + call build_hdate(hdate,year,month,day,hour,minute,second) + + call geth_newdate(hdate,hdate,3600*fcst) + +! Store information about the grid on which the data is. +! This stuff gets stored in the MAP variable, as defined in module GRIDINFO + + map%startloc = 'SWCORNER' + map%grid_wind = .true. +! NCEP's grib1 messages (in GDS Octet 17, the Resolution and Component Flags) +! all have '0' for the earth radius flag which the documentation (written by NCEP) +! says is 6367.47, but they really use 6371.229. Hardcode it. +! It's not clear what ECMWF uses. One place says 6367.47 and another 6371.229. + if ( index(map%source,'NCEP') .ne. 0 ) then + map%r_earth = 6371.229 + else + map%r_earth = 6367.47 + endif + + if (ksec2(4).eq.0) then ! Lat/Lon grid + map%igrid = 0 + map%nx = infogrid(1) + map%ny = infogrid(2) + map%dx = ginfo(8) + map%dy = ginfo(9) + map%lat1 = ginfo(3) + map%lon1 = ginfo(4) + ! If this is global data, then the dx and dy are more accurately + ! computed by the number of points than the 3 digits grib permits. + if ( ABS(map%nx * map%dx - 360.) .lt. 1 ) then + if ( ABS ( map%dx - (360./real(map%nx)) ) .gt. 0.00001 ) then + !print *,'old dx = ',ginfo(8) + map%dx = 360./real(map%nx) + !print *,'new dx = ',map%dx + endif + endif + if ( ABS((map%ny-1) * map%dy - 2.*abs(map%lat1)) .lt. 1. ) then + if ( ABS ( map%dy - (2.*abs(map%lat1)/real(map%ny-1)) ) .gt. 0.00001 ) then + !print *,'old dy = ',ginfo(9) + map%dy = 2.*abs(map%lat1)/real(map%ny-1) + !print *,'new dy = ',map%dy + endif + endif + write(tmp8,'(b8.8)') infogrid(5) + if (tmp8(5:5) .eq. '0') map%grid_wind = .false. + if (icenter .eq. 7 .and. KSEC1(5) .eq. 173 ) then ! correction for ncep grid 173 + map%lat1 = 89.958333 + map%lon1 = 0.041667 + map%dx = 0.083333333 * sign(1.0,map%dx) + map%dy = 0.083333333 * sign(1.0,map%dy) + endif +! correction for ncep grid 229 added 5/3/07 JFB + if (icenter .eq. 7 .and. KSEC1(5) .eq. 229 ) then + if (ginfo(3) .gt. 89. .and. ginfo(9) .gt. 0.) then + map%dy = -1. * map%dy + endif + endif + +! print *, "CE map stuff", map%igrid, map%nx, map%ny, map%dx, & +! map%dy, map%lat1, map%lon1 + + elseif (ksec2(4).eq.1) then ! Mercator Grid + map%igrid = 1 + map%nx = infogrid(1) + map%ny = infogrid(2) + map%dx = ginfo(8) ! km + map%dy = ginfo(9) + map%truelat1 = ginfo(5) + map%truelat2 = 0. + map%lov = 0. + map%lat1 = ginfo(3) + map%lon1 = ginfo(4) + write(tmp8,'(b8.8)') infogrid(5) + if (tmp8(5:5) .eq. '0') map%grid_wind = .false. + + elseif (ksec2(4).eq.3) then ! Lambert Conformal Grid + map%igrid = 3 + map%nx = infogrid(1) + map%ny = infogrid(2) + map%lov = ginfo(6) + map%truelat1 = ginfo(11) + map%truelat2 = ginfo(12) + map%dx = ginfo(7) + map%dy = ginfo(8) + map%lat1 = ginfo(3) + map%lon1 = ginfo(4) + write(tmp8,'(b8.8)') infogrid(5) + if (tmp8(5:5) .eq. '0') map%grid_wind = .false. +! if (tmp8(2:2) .eq. '0') map%r_earth = 6367.47 + + elseif(ksec2(4).eq.4) then ! Gaussian Grid + map%igrid = 4 + map%nx = infogrid(1) + map%ny = infogrid(2) + map%dx = ginfo(8) +! map%dy = ginfo(19) + map%dy = real (infogrid(9)) + map%lon1 = ginfo(4) + map%lat1 = ginfo(3) + write(tmp8,'(b8.8)') infogrid(5) + if (tmp8(5:5) .eq. '0') map%grid_wind = .false. +! If this is global data, then the dx and dy are more accurately +! computed by the number of points than the 3 digits grib permits. + if ( ABS(map%nx * map%dx - 360.) .lt. 1. ) then + if ( ABS ( map%dx - (360./real(map%nx)) ) .gt. 0.00001 ) then + ! print *,'old dx = ',ginfo(8) + map%dx = 360./real(map%nx) + ! print *,'new dx = ',map%dx + endif + endif + + + elseif (ksec2(4).eq.5) then ! Polar-Stereographic Grid. + map%igrid = 5 + map%nx = infogrid(1) + map%ny = infogrid(2) + map%lov = ginfo(6) + map%truelat1 = 60. + map%truelat2 = 91. + map%dx = ginfo(7) + map%dy = ginfo(8) + map%lat1 = ginfo(3) + map%lon1 = ginfo(4) + write(tmp8,'(b8.8)') infogrid(5) + if (tmp8(5:5) .eq. '0') map%grid_wind = .false. + + else + print*, 'Unknown Data Representation Type, ksec2(4)= ', ksec2(4) + stop 'rd_grib1' + endif + +111 format(' igrid : ', i3, /, & + ' nx, ny : ', 2I4, /, & + ' truelat1, 2: ', 2F10.4, /, & + ' Center Lon : ', F10.4, /, & + ' LatLon(1,1): ', 2F10.4, /, & + ' DX, DY : ', F10.4, F10.4) + +! Special for NCEP/NCAR Reanalysis Project: +! Throw out PSFC on lat/lon grid (save gaussian version) + if ((icenter.eq.7).and.(iprocess.eq.80)) then ! Careful! This combination may refer + ! to other products as well. + if ((field.eq.'PSFC').and.(ksec2(4).eq.0)) then + field='NULL' + call deallogrib + return + endif + endif + + if (allocated(rdatarray)) deallocate(rdatarray) + allocate(rdatarray(map%nx * map%ny)) + +! If nx=65535, assume the grid is a thinned grid. +! Process only the NCEP grid IDs is 37 to 44. + if (map%nx.eq.65535) then + if ( (icenter .ne. 7) .or. (KSEC1(5).lt.37) .or. (KSEC1(5).gt.44) ) then + write(*,*) 'Originating center is ',icenter + write(*,*) 'Grid ID is ',KSEC1(5),' Only WAFS grids 37-44 are supported' + write(*,'(" ***** STOP in Subroutine RD_GRIB1.",//)') + stop + endif + lthinned = .TRUE. + map%nx = 73 + map%dx = 1.25 + else + lthinned = .FALSE. + endif + +! Unpack the 2D slab from the GRIB record, and put it in array rdatarray + + if (lthinned) then + if (allocated(thinnedDataArray)) deallocate(thinnedDataArray) + allocate(thinnedDataArray(map%nx * map%ny)) + call gribdata(thinnedDataArray,3447) + + ! Calculate how many points for each latitude, and accumulate into array + if ((KSEC1(5).ge.37).and.(KSEC1(5).le.40)) then + ! Northern hemisphere: + npoints_acc(1)=0 + npoints_acc(2)=73 + do i=1,72 + np = int(2.0+(90.0/1.25)*cos(i*1.25*3.1415926/180.0)) + npoints_acc(i+2)=npoints_acc(i+1)+np + enddo + else + ! Southern Hemisphere: + npoints_acc(1)=0 + npoints_acc(2)=2 + do i=1,71 + ii = 72-i + np = int(2.0+(90.0/1.25)*cos(ii*1.25*3.1415926/180.0)) + npoints_acc(i+2)=npoints_acc(i+1)+np + enddo + npoints_acc(74) = npoints_acc(73) + 73 + endif + + ! for row number i (where i=1 is the southern edge of the grid) + ! npoints_acc(i+1)-npoints_acc(i) = number of points in this line + ! npoints_acc(i)+1 = index into thinned array for first point of line + + do ny=1,73 + np = npoints_acc(ny+1)-npoints_acc(ny) ! Number of points in this line. + do nx=1,73 + ! Calulate the x index (mj) of thinned array (real value) + mj = (nx-1.0)*(np-1.0)/(72.0) + + if (abs(mj - int(mj)) < 1.E-10) then + rdatarray((ny-1)*73+nx) = thinnedDataArray(npoints_acc(ny)+1+int(mj)) + else + ! Get the 2 closest values from thinned array + Vb = thinnedDataArray(npoints_acc(ny)+1+int(mj)) + Vc = thinnedDataArray(npoints_acc(ny)+1+int(mj)+1) + ! Get the next two closest, if available: + Va = -999999. + Vd = -999999. + if (mj > 1.0) then + Va = thinnedDataArray(npoints_acc(ny)+1+int(mj)-1) + endif + if (mj < np-2) then + Vd = thinnedDataArray(npoints_acc(ny)+1+int(mj)+2) + endif + + if ((Va < -999998.) .or. (Vd < -999998.)) then + ! Use 2-point linear interpolation. + rdatarray((ny-1)*73+nx) = Vb*(int(mj)+1.0-mj) + Vc*(mj-int(mj)) + else + ! Use 4-point overlapping parabolic interpolation. + xmj = mj - float(int(mj)) + rdatarray((ny-1)*73+nx) = oned(xmj,Va,Vb,Vc,Vd) + endif + endif + enddo + enddo +else + call gribdata(rdatarray,map%nx*map%ny) +endif + +! Some grids are broken and need to be reordered (e.g. NCEP-II in 1997). +! WPS assumes that the grids are ordered consistently with the start location. + + call mprintf(.true.,DEBUG, & + "RD_GRIB1 icenter = %i , iprocess = %i , grid = %i",i1=icenter,i2=iprocess,i3=KSEC1(5)) + if (icenter .eq. 7 .and. iprocess .eq. 0 .and. KSEC1(5) .eq. 2 ) then + call mprintf(.true.,DEBUG, & + "resetting NCEP2 dx and dy. If this is not NCEP2 data you must modify rd_grib1.f90") + call mprintf(.true.,DEBUG, & + "field = %s , dx = %f , dy = %f , i10 = %i",s1=field,f1=map%dx,f2=map%dy,i1=infogrid(10)) + map%dx = 2.5 + map%dy = -2.5 +! call reorder_it (rdatarray, map%nx, map%ny, map%dx, map%dy, infogrid(10)) + endif + +! Deallocate a couple of arrays that may have been allocated by the +! GRIB decoding routines. + + call deallogrib + +END subroutine rd_grib1 + +real function oned(x, a, b, c, d) Result (Answer) + implicit none + real :: x ! Proportion of the way between B and C. Between 0.0 and 1.0 + real :: a, b, c, d + + if (abs(x) < 1.E-10) then + Answer = B + return + endif + IF(abs(x-1.) < 1.E-10) then + Answer = C + return + endif + Answer = (1.0-X)*(B+X*(0.5*(C-A)+X*(0.5*(C+A)-B)))+X*(C+(1.0-X)*(0.5 & + *(B-D)+(1.0-X)*(0.5*(B+D)-C))) +end function oned diff --git a/WPS/ungrib/src/rd_grib2.F b/WPS/ungrib/src/rd_grib2.F new file mode 100644 index 00000000..c5daeb33 --- /dev/null +++ b/WPS/ungrib/src/rd_grib2.F @@ -0,0 +1,1178 @@ +*****************************************************************************! +! Subroutine RD_GRIB2 ! +! ! +! Purpose: ! +! Read one record from the input GRIB2 file. Based on the information in ! +! the GRIB2 header and the user-defined Vtable, decide whether the field in! +! the GRIB2 record is one to process or to skip. If the field is one we ! +! want to keep, extract the data from the GRIB2 record, and store the data ! +! in the ungrib memory structure. ! +! ! +! Argument list: ! +! Input: ! +! junit : "Unit Number" to open and read from. Not really a Fortran ! +! unit number, since we do not do Fortran I/O for the GRIB2 ! +! files. Nor is it a UNIX File Descriptor returned from a C ! +! OPEN statement. It is really just an array index to the ! +! array (IUARR) where the UNIX File Descriptor values are ! +! stored. ! +! gribflnm : File name to open, if it is not already open. ! +! debug_level : Integer for various amounts of printout. ! +! ! +! Output: ! +! ! +! hdate : The (up to)19-character date of the field to process. ! +! grib_edition : Version of the gribfile (1 or 2) ! +! ireaderr : Error flag: 0 - no error on read from GRIB2 file. ! +! 1 - Hit the end of the GRIB2 file. ! +! 2 - The file GRIBFLNM we tried to open does ! +! not exist. ! +! ! +! ! +! Author: Paula McCaslin, NOAA/FSL, Sept 2004 ! +! Code is based on code developed by Steve Gilbert NCEP & Kevin Manning NCAR ! +! Adapted for WPS: Jim Bresch, NCAR/MMM. Sept 2006 ! +!*****************************************************************************! + + SUBROUTINE rd_grib2(junit, gribflnm, hdate, + & grib_edition, ireaderr, debug_level) + + use grib_mod + use params + use table ! Included to define g2code + use gridinfo ! Included to define map% + use storage_module ! Included sub put_storage + use module_debug + + real, allocatable, dimension(:) :: hold_array + parameter(msk1=32000,msk2=4000) + character(len=1),allocatable,dimension(:) :: cgrib + integer :: listsec0(3) + integer :: listsec1(13) + integer year, month, day, hour, minute, second, fcst + character(len=*) :: gribflnm + character(len=*) :: hdate + character(len=8) :: pabbrev + character(len=20) :: labbrev + character(len=80) :: tabbrev + integer :: lskip, lgrib + integer :: junit, itot, icount, iseek + integer :: grib_edition + integer :: i, j, ireaderr, ith , debug_level + integer :: currlen + logical :: unpack, expand + type(gribfield) :: gfld + ! For subroutine put_storage + real :: level + real :: scale_factor + integer :: iplvl + character (len=9) :: my_field + character (len=8) :: tmp8 + ! For subroutine output + integer , parameter :: maxlvl = 150 + real , dimension(maxlvl) :: plvl + integer :: nlvl + integer , dimension(maxlvl) :: level_array + real :: glevel1, glevel2 + logical :: first = .true. + +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SET ARGUMENTS + + unpack=.true. + expand=.true. + hdate = '0000-00-00_00:00:00' + ierr=0 + itot=0 + icount=0 + iseek=0 + lskip=0 + lgrib=0 + currlen=0 + ith=1 + scale_factor = 1e6 + call mprintf(.true.,DEBUG,"Begin rd_grib2", newline=.true.) + +!/* IOS Return Codes from BACIO: */ +!/* 0 All was well */ +!/* -1 Tried to open read only _and_ write only */ +!/* -2 Tried to read and write in the same call */ +!/* -3 Internal failure in name processing */ +!/* -4 Failure in opening file */ +!/* -5 Tried to read on a write-only file */ +!/* -6 Failed in read to find the 'start' location */ +!/* -7 Tried to write to a read only file */ +!/* -8 Failed in write to find the 'start' location */ +!/* -9 Error in close */ +!/* -10 Read or wrote fewer data than requested */ + +!if ireaderr =1 we have hit the end of a file. +!if ireaderr =2 we have hit the end of all the files. + + + ! Open a byte-addressable file. + CALL BAOPENR(junit,gribflnm,IOS) + first = .true. + if (ios.eq.0) then + VERSION: do + + ! Search opend file for the next GRIB2 messege (record). + call skgb(junit,iseek,msk1,lskip,lgrib) + + ! Check for EOF, or problem + if (lgrib.eq.0) then + exit + endif + + ! Check size, if needed allocate more memory. + if (lgrib.gt.currlen) then + if (allocated(cgrib)) deallocate(cgrib) + allocate(cgrib(lgrib),stat=is) + !print *,'G2 allocate(cgrib(lgrib)) status: ',IS + currlen=lgrib + endif + + ! Read a given number of bytes from unblocked file. + call baread(junit,lskip,lgrib,lengrib,cgrib) + + call mprintf ((lgrib.ne.lengrib),ERROR, + & "rd_grib2: IO Error. %i .ne. %i ", newline=.true., + & i1=lgrib,i2=lengrib) + + iseek=lskip+lgrib + icount=icount+1 + + call mprintf (.true.,DEBUG, + & "G2 GRIB MESSAGE %i starts at %i ", newline=.true., + & i1=icount,i2=lskip+1) + + ! Unpack GRIB2 field + call gb_info(cgrib,lengrib,listsec0,listsec1, + & numfields,numlocal,maxlocal,ierr) + call mprintf((ierr.ne.0),ERROR, + & " ERROR querying GRIB2 message = %i",newline=.true.,i1=ierr) + itot=itot+numfields + + grib_edition=listsec0(2) + if (grib_edition.ne.2) then + exit VERSION + endif + + ! Additional print statments for developer. +!MGD if ( debug_level .GT. 100 ) then +!MGD print *,'G2 SECTION 0: ',(listsec0(j),j=1,3) +!MGD print *,'G2 SECTION 1: ',(listsec1(j),j=1,13) +!MGD print *,'G2 Contains ',numlocal,' Local Sections ', +!MGD & ' and ',numfields,' data fields.' +!MGD endif + + + ! ---- + ! Once per file fill in date, model and projection values. + + if (first) then + first = .false. + + ! Build the 19-character date string, based on GRIB2 header date + ! and time information, including forecast time information: + + n=1 + call gf_getfld(cgrib,lengrib,n,.FALSE.,expand,gfld,ierr) + + + year =gfld%idsect(6) !(FOUR-DIGIT) YEAR OF THE DATA + month =gfld%idsect(7) ! MONTH OF THE DATA + day =gfld%idsect(8) ! DAY OF THE DATA + hour =gfld%idsect(9) ! HOUR OF THE DATA + minute=gfld%idsect(10) ! MINUTE OF THE DATA + second=gfld%idsect(11) ! SECOND OF THE DATA + + fcst = 0 + +! Extract forecast time. Assume the first field's valid time is true for all fields. +! This doesn't have to be true, but ungrib is designed to decode one time-level at +! a time. + + if ( gfld%ipdtnum .ne. 8 ) then + if ( gfld%ipdtmpl(8) .eq. 1 ) then ! time units are hours + fcst = gfld%ipdtmpl(9) + else if ( gfld%ipdtmpl(8) .eq. 0 ) then ! minutes + fcst = gfld%ipdtmpl(9) / 60. + else if ( gfld%ipdtmpl(8) .eq. 2 ) then ! days + fcst = gfld%ipdtmpl(9) * 24. + else + call mprintf(.true.,ERROR, + & "Time unit in ipdtmpl(8), %i is not suported", + & newline=.true.,i1=gfld%ipdtmpl(8)) + endif + else +! pdt 4.8 data are time-averaged, accumulated, or min/max fields with the +! ending (valid) time provided. + year =gfld%ipdtmpl(16) + month =gfld%ipdtmpl(17) + day =gfld%ipdtmpl(18) + hour =gfld%ipdtmpl(19) + minute=gfld%ipdtmpl(20) + second=gfld%ipdtmpl(21) + fcst = 0. + endif + + if ( gfld%idsect(5) .eq. 2 ) fcst = 0. + ! Compute valid time. + + !print *, 'ymd',gfld%idsect(6),gfld%idsect(7),gfld%idsect(8) + !print *, 'hhmm ',gfld%idsect(9),gfld%idsect(10) + + call build_hdate(hdate,year,month,day,hour,minute,second) + call mprintf(.true.,DEBUG,"G2 hdate = %s ", newline=.true., + & s1=hdate) + call geth_newdate(hdate,hdate,3600*fcst) + call mprintf(.true.,DEBUG,"G2 hdate (fcst?) = %s ", + & newline=.true., s1=hdate) + + !-- + + ! Indicator of the source (center) of the data. + icenter = gfld%idsect(1) + + ! Indicator of model (or whatever) which generated the data. + iprocess = gfld%ipdtmpl(5) + + + if (icenter.eq.7) then + if (iprocess.eq.81) then + map%source = 'NCEP GFS Analysis' + elseif (iprocess.eq.82) then + map%source = 'NCEP GFS GDAS/FNL' + elseif (iprocess.eq.83) then + map%source = 'NCEP HRRR Model' + elseif (iprocess.eq.84) then + map%source = 'NCEP MESO NAM Model' + elseif (iprocess.eq.89) then + map%source = 'NCEP NMM ' + elseif (iprocess.eq.96) then + map%source = 'NCEP GFS Model' + elseif (iprocess.eq.86 .or. iprocess.eq.100) then + map%source = 'NCEP RUC Model' ! 60 km + elseif (iprocess.eq.101) then + map%source = 'NCEP RUC Model' ! 40 km + elseif (iprocess.eq.105) then + if (year .gt. 2011) then + map%source = 'NCEP RAP Model' + else + map%source = 'NCEP RUC Model' ! 20 km + endif + elseif (iprocess.eq.107) then + map%source = 'NCEP GEFS' + elseif (iprocess.eq.109) then + map%source = 'NCEP RTMA' + elseif (iprocess.eq.140) then + map%source = 'NCEP NARR' + elseif (iprocess.eq.44) then + map%source = 'NCEP SST Analysis' + elseif (iprocess.eq.70) then + map%source = 'GFDL Hurricane Model' + elseif (iprocess.eq.80) then + map%source = 'NCEP GFS Ensemble' + elseif (iprocess.eq.107) then ! renumbered as of 23 Feb 2010 + map%source = 'NCEP GFS Ensemble' + elseif (iprocess.eq.111) then + map%source = 'NCEP NMMB Model' + elseif (iprocess.eq.112) then + map%source = 'NCEP WRF-NMM Model' + elseif (iprocess.eq.116) then + map%source = 'NCEP WRF-ARW Model' + elseif (iprocess.eq.129) then + map%source = 'NCEP GODAS' + elseif (iprocess.eq.197) then + map%source = 'NCEP CDAS CFSV2' + elseif (iprocess.eq.25) then + map%source = 'NCEP SNOW COVER ANALYSIS' + else + map%source = 'unknown model from NCEP' + call mprintf(.true.,STDOUT, + & "unknown model from NCEP %i ",newline=.true., + & i1=iprocess) + call mprintf(.true.,LOGFILE, + & "unknown model from NCEP %i ",newline=.true., + & i1=iprocess) + end if + else if (icenter .eq. 57) then + if (iprocess .eq. 87) then + map%source = 'AFWA AGRMET' + else + map%source = 'AFWA' + endif + else if ( icenter .eq. 58 ) then + map%source = 'US Navy FNOC' + else if (icenter .eq. 59) then + if (iprocess .eq. 125) then + map%source = 'NOAA GSD Rapid Refresh Model' + else if (iprocess .eq. 83) then + map%source = 'NOAA GSD HRRR Model' + else if (iprocess .eq. 105) then + map%source = 'NOAA GSD' + else + print *,'Unknown GSD source' + stop + endif + else if (icenter .eq. 60) then + map%source = 'NCAR' + else if (icenter .eq. 98) then + map%source = 'ECMWF' + else if (icenter .eq. 34) then + map%source = 'JMA' + else if (icenter .eq. 74 .or. icenter .eq. 75 ) then + map%source = 'UKMO' + else + map%source = 'unknown model and orig center' + end if + call mprintf(.true.,DEBUG,"G2 source is = %s ", + & newline=.true., s1=map%source) + + !-- + + ! Store information about the grid containing the data. + ! This stuff gets stored in the MAP variable, as defined in + ! module GRIDINFO. + + map%startloc = 'SWCORNER' + map%grid_wind = .true. + + if (gfld%igdtnum.eq.0) then ! Lat/Lon grid aka Cylindrical Equidistant + map%igrid = 0 + map%nx = gfld%igdtmpl(8) + map%ny = gfld%igdtmpl(9) + map%dx = gfld%igdtmpl(17) + map%dy = gfld%igdtmpl(18) + map%lat1 = gfld%igdtmpl(12) + map%lon1 = gfld%igdtmpl(13) + write(tmp8,'(b8.8)') gfld%igdtmpl(14) + if (tmp8(5:5) .eq. '0') map%grid_wind = .false. + map%r_earth = earth_radius (gfld%igdtmpl(1), + & gfld%igdtmpl(2),gfld%igdtmpl(3)) + +! Fix for NCEP 1/12 degree grids (e.g. rtgsst) + if (icenter .eq. 7 .and. map%dx .eq. 83000. .and. map%nx + & .eq. 4320) then + map%lat1 = 89958333. + map%lon1 = 41667. + map%dx = 83333.333 * sign(1.0,map%dx) + map%dy = 83333.333 * sign(1.0,map%dy) + endif + + if ((gfld%igdtmpl(10) .eq. 0).OR. + & (gfld%igdtmpl(10) .eq. 255)) THEN + ! Scale lat/lon values to 0-180, default range is 1e6. + map%lat1 = map%lat1/scale_factor + map%lon1 = map%lon1/scale_factor + ! Scale dx/dy values to degrees, default range is 1e6. + map%dx = map%dx/scale_factor + map%dy = map%dy/scale_factor + else + ! Basic angle and subdivisions are non-zero (not tested) + map%lat1 = map%lat1 * + & (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + map%lon1 = map%lon1 * + & (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + map%dx = map%dx * + & (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + map%dy = map%dy * + & (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + call mprintf(.true.,STDOUT,"WARNING - Basic angle option + &has not been tested, continuing anyway") + call mprintf(.true.,LOGFILE,"WARNING - Basic angle option + & has not been tested, continuing anyway") + endif + + +! The following is needed for NCEP GFS, 0.5 degree output. The j-scan is in the -y direction. +! In WPS, the sign of dy indicates the direction of the scan. + write(tmp8,'(b8.8)') gfld%igdtmpl(19) + read(tmp8,'(1x,i1)') jscan + if ( jscan .eq. 0 .and. map%dy .gt. 0. ) then + map%dy = -1. * map%dy + endif +! if ( map%lat1 .gt. gfld%igdtmpl(15) .and. +! & map%dy .gt. 0. ) then +! map%dy = -1. * map%dy +! write(6,*) 'Resetting map%dy for iprocess = ',iprocess +! endif + + elseif (gfld%igdtnum.eq.10) then ! Mercator Grid. + map%igrid = 1 + map%nx = gfld%igdtmpl(8) + map%ny = gfld%igdtmpl(9) + map%lov = 0. + map%truelat1 = gfld%igdtmpl(13) / scale_factor + map%truelat2 = 0. + map%dx = gfld%igdtmpl(18) / scale_factor + map%dy = gfld%igdtmpl(19) / scale_factor + map%lat1 = gfld%igdtmpl(10) / scale_factor + map%lon1 = gfld%igdtmpl(11) / scale_factor + write(tmp8,'(b8.8)') gfld%igdtmpl(12) + if (tmp8(5:5) .eq. '0') map%grid_wind = .false. + map%r_earth = earth_radius (gfld%igdtmpl(1), + & gfld%igdtmpl(2),gfld%igdtmpl(3)) + + elseif (gfld%igdtnum.eq.20) then ! Polar-Stereographic Grid. + map%igrid = 5 + map%nx = gfld%igdtmpl(8) + map%ny = gfld%igdtmpl(9) + map%lov = gfld%igdtmpl(14) / scale_factor + map%truelat1 = 60. + map%truelat2 = 91. + map%dx = gfld%igdtmpl(15) / scale_factor + map%dy = gfld%igdtmpl(16) / scale_factor + map%lat1 = gfld%igdtmpl(10) / scale_factor + map%lon1 = gfld%igdtmpl(11) / scale_factor + write(tmp8,'(b8.8)') gfld%igdtmpl(12) + if (tmp8(5:5) .eq. '0') map%grid_wind = .false. + map%r_earth = earth_radius (gfld%igdtmpl(1), + & gfld%igdtmpl(2),gfld%igdtmpl(3)) + + elseif (gfld%igdtnum.eq.30) then ! Lambert Conformal Grid + map%igrid = 3 + map%nx = gfld%igdtmpl(8) + map%ny = gfld%igdtmpl(9) + map%lov = gfld%igdtmpl(14) / scale_factor + map%truelat1 = gfld%igdtmpl(19) / scale_factor + map%truelat2 = gfld%igdtmpl(20) / scale_factor + map%dx = gfld%igdtmpl(15) / scale_factor + map%dy = gfld%igdtmpl(16) / scale_factor + map%lat1 = gfld%igdtmpl(10) / scale_factor + map%lon1 = gfld%igdtmpl(11) / scale_factor + write(tmp8,'(b8.8)') gfld%igdtmpl(12) + if (tmp8(5:5) .eq. '0') map%grid_wind = .false. + map%r_earth = earth_radius (gfld%igdtmpl(1), + & gfld%igdtmpl(2),gfld%igdtmpl(3)) + + elseif(gfld%igdtnum.eq.40) then ! Gaussian Grid (we will call it lat/lon) + map%igrid = 4 + map%nx = gfld%igdtmpl(8) ! Ni - # of points along a parallel + map%ny = gfld%igdtmpl(9) ! Nj - # of points along meridian + map%dx = gfld%igdtmpl(17) ! Di - i direction increment + map%dy = gfld%igdtmpl(18) ! N - # of parallels between pole and equator + map%lat1 = gfld%igdtmpl(12) ! La1 - lat of 1st grid point + map%lon1 = gfld%igdtmpl(13) ! Lo1 - lon of 1st grid point + write(tmp8,'(b8.8)') gfld%igdtmpl(14) ! resolution/component flag + if (tmp8(5:5) .eq. '0') map%grid_wind = .false. + map%r_earth = earth_radius (gfld%igdtmpl(1), + & gfld%igdtmpl(2),gfld%igdtmpl(3)) + + ! Scale dx/dy values to degrees, default range is 1e6. + if (map%dx.gt.10000) then + map%dx = map%dx/scale_factor + endif + if (map%dy.gt.10000) then + map%dy = (map%dy/scale_factor)*(-1) + endif + + ! Fix for zonal shift in CFSR data, following a similar fix + ! for global lat-lon data in rd_grib1.F + if ( ABS(map%nx * map%dx - 360.0) < 1.0 ) then + if (ABS(map%dx - (360./real(map%nx))) > 0.00001) then + write(0,*) 'CFSR fix: recomputing delta-longitude' + map%dx = 360./real(map%nx) + endif + endif + + ! Scale lat/lon values to 0-180, default range is 1e6. + if (map%lat1.ge.scale_factor) then + map%lat1 = map%lat1/scale_factor + endif + if (map%lon1.ge.scale_factor) then + map%lon1 = map%lon1/scale_factor + endif + if ( debug_level .gt. 2 ) then + call mprintf(.true.,DEBUG, + & "Gaussian Grid: Dx,Dy,lat,lon,nlats %f %f %f %f %i ", + & newline=.true.,f1=map%dx,f2=map%dy,f3=map%lat1,f4=map%lon1, + & i1=nint(map%dy)) + end if + elseif (gfld%igdtnum.eq.32769) then ! Arakawa Non-E Staggered grid. + map%igrid = 6 + map%nx = gfld%igdtmpl(8) + map%ny = gfld%igdtmpl(9) + map%dx = gfld%igdtmpl(17) + map%dy = gfld%igdtmpl(18) + map%lat1 = gfld%igdtmpl(12) + map%lon1 = gfld%igdtmpl(13) + map%lat0 = gfld%igdtmpl(15) + map%lon0 = gfld%igdtmpl(16) + map%r_earth = earth_radius (gfld%igdtmpl(1), + & gfld%igdtmpl(2),gfld%igdtmpl(3)) + if ((gfld%igdtmpl(10) .eq. 0).OR. + & (gfld%igdtmpl(10) .eq. 255)) THEN + map%lat1 = map%lat1/scale_factor + map%lon1 = map%lon1/scale_factor + map%lat0 = map%lat0/scale_factor + map%lon0 = map%lon0/scale_factor + map%dx = map%dx/scale_factor/1.e3 + map%dy = map%dy/scale_factor/1.e3 + else + ! Basic angle and subdivisions are non-zero (not tested) + map%lat1 = map%lat1 * + & (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + map%lon1 = map%lon1 * + & (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + map%dx = map%dx * + & (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + map%dy = map%dy * + & (gfld%igdtmpl(11)/gfld%igdtmpl(10)) + call mprintf(.true.,STDOUT,"WARNING - Basic angle option + &has not been tested, continuing anyway") + call mprintf(.true.,LOGFILE,"WARNING - Basic angle option + & has not been tested, continuing anyway") + endif + + else + call mprintf(.true.,STDOUT,"GRIB2 Unknown Projection: %i", + & newline=.true.,i1=gfld%igdtnum) + call mprintf(.true.,STDOUT, + & "ungrib understands projections 0, 20, 30, and 40", + & newline=.true.) + call mprintf(.true.,LOGFILE, + & "GRIB2 Unknown Projection: %i", + & newline=.true.,i1=gfld%igdtnum) + call mprintf(.true.,LOGFILE, + & "ungrib understands projections 0, 10, 20, 30, and 40", + & newline=.true.) + ! If the projection is not known, then it can't be processed by metgrid/plotfmt + stop 'Stop in rd_grib2' + endif + + call mprintf(.true.,DEBUG,"G2 igrid = %i , dx = %f , dy = % + &f ", newline=.true., i1 = map%igrid, f1=map%dx, f2=map%dy) + + if (icenter.eq.7) then + call ncep_grid_num (gfld%igdtnum) + endif + + ! Deallocate arrays decoding GRIB2 record. + call gf_free(gfld) + + endif ! "first" if-block + + ! ---- + + ! Continue to unpack GRIB2 field. + NUM_FIELDS: do n = 1, numfields + ! e.g. U and V would =2, otherwise its usually =1 + call gf_getfld(cgrib,lengrib,n,.FALSE.,expand,gfld,ierr) + if (ierr.ne.0) then + write(*,*) ' ERROR extracting field gf_getfld = ',ierr + cycle + endif + +! The JMA GSM has two different grids in the same GRIB file, so we need +! to process the map info for each field separately. If any other centers do +! this, then processing will need to be added here, too. + + if (icenter .eq. 34 .and. gfld%igdtnum.eq.0) then + map%nx = gfld%igdtmpl(8) + map%ny = gfld%igdtmpl(9) + map%dx = gfld%igdtmpl(17) + map%dy = gfld%igdtmpl(18) + ! Scale dx/dy values to degrees, default range is 1e6. + if (map%dx.gt.10000) then + map%dx = map%dx/scale_factor + endif + if (map%dy.gt.10000) then + map%dy = map%dy/scale_factor + endif + write(tmp8,'(b8.8)') gfld%igdtmpl(19) + read(tmp8,'(1x,i1)') jscan + write(0,*) 'gfld%igdtmpl(19) = ',gfld%igdtmpl(19), + & ' jscan = ',jscan + if ( jscan .eq. 0 .and. map%dy .gt. 0. ) then + map%dy = -1. * map%dy + endif + endif ! JMA spectral + +! ------------------------------------ + ! Additional print information for developer. + if ( debug_level .GT. 1000 ) then +!MGD print * +!MGD print *,'G2 FIELD ',n +!MGD if (n==1) then +!MGD print *,'G2 SECTION 0: ',gfld%discipline,gfld%version +!MGD print *,'G2 SECTION 1: ',(gfld%idsect(j),j=1,gfld%idsectlen) +!MGD endif +!MGD if ( associated(gfld%local).AND.gfld%locallen.gt.0 ) then +!MGD print *,'G2 SECTION 2: ',(gfld%local(j),j=1,gfld%locallen) +!MGD endif +!MGD print *,'G2 SECTION 3: ',gfld%griddef,gfld%ngrdpts, +!MGD & gfld%numoct_opt,gfld%interp_opt, +!MGD & gfld%igdtnum +!MGD print *,'G2 GRID TEMPLATE 3.',gfld%igdtnum,': ', +!MGD & (gfld%igdtmpl(j),j=1,gfld%igdtlen) +!MGD if ( gfld%num_opt .eq. 0 ) then +!MGD print *,'G2 NO Section 3 List Defining No. of Data Points.' +!MGD else +!MGD print *,'G2 Section 3 Optional List: ', +!MGD & (gfld%list_opt(j),j=1,gfld%num_opt) +!MGD endif +!MGD print *,'G2 PRODUCT TEMPLATE 4.',gfld%ipdtnum,': ', +!MGD & (gfld%ipdtmpl(j),j=1,gfld%ipdtlen) + + pabbrev=param_get_abbrev(gfld%discipline,gfld%ipdtmpl(1), + & gfld%ipdtmpl(2)) + !call prlevel(gfld%ipdtnum,gfld%ipdtmpl,labbrev) + !call prvtime(gfld%ipdtnum,gfld%ipdtmpl,listsec1,tabbrev) +!MGD print *,'G2 TEXT: ',pabbrev,trim(labbrev)," ",trim(tabbrev) + +!MGD if ( gfld%num_coord .eq. 0 ) then +!MGD print *,'G2 NO Optional Vertical Coordinate List.' +!MGD else +!MGD print *,'G2 Section 4 Optional Coordinates: ', +!MGD & (gfld%coord_list(j),j=1,gfld%num_coord) +!MGD endif + if ( gfld%ibmap .ne. 255 ) then + call mprintf(.true.,DEBUG, + & 'G2 Num. of Data Points = %i with BIT-MAP %i', + & newline=.true., i1=gfld%ndpts, i2=gfld%ibmap) + else + call mprintf(.true.,DEBUG, + & 'G2 Num. of Data Points = %i NO BIT-MAP', + & newline=.true., i1=gfld%ndpts) + endif +!MGD print *,'G2 DRS TEMPLATE 5.',gfld%idrtnum,': ', +!MGD & (gfld%idrtmpl(j),j=1,gfld%idrtlen) + endif ! Additional Print information +! ------------------------------------ + +! do i = 1, maxvar +! write(6,'(a10,4i8)') namvar(i),(g2code(j,i),j=1,4) +! enddo +!MGD if (debug_level .gt. 50) then +!MGD write(6,*) 'looking for ',gfld%discipline,gfld%ipdtmpl(1), +!MGD & gfld%ipdtmpl(2),gfld%ipdtmpl(10) +!MGD endif + call mprintf(.true.,DEBUG,"G2 Searching the g2code array (Vta + &ble) for this grib field %i %i %i %i %i %i ", newline=.true., + & i1 = gfld%discipline, i2 = gfld%ipdtmpl(1), + & i3 = gfld%ipdtmpl(2), i4 = gfld%ipdtmpl(10), + & i5 = gfld%ipdtmpl(12), i6 = gfld%ipdtnum ) + + + ! Test this data record against list of desired variables + ! found in Vtable. + ! ---- + MATCH_LOOP: do i=1,maxvar ! Max variables found in Vtable, + ! maxvar is defined in table.mod + + if ( gfld%discipline .eq. g2code(1,i) .and. !Discipline + & gfld%ipdtmpl(1) .eq. g2code(2,i) .and. !Category + & gfld%ipdtmpl(2) .eq. g2code(3,i) .and. !Parameter + & gfld%ipdtmpl(10) .eq. g2code(4,i) .and. !Elevation + & gfld%ipdtnum .eq. g2code(5,i)) then !Template + + call gf_free(gfld) + call gf_getfld(cgrib,lengrib,n,.TRUE.,expand,gfld,ierr) + pabbrev=param_get_abbrev(gfld%discipline,gfld%ipdtmpl(1), + & gfld%ipdtmpl(2)) + + !my_field (e.g. RH, TMP, similar to, but not the same as pabbrev) + my_field=namvar(i) + +!MGD if (debug_level .gt. 50) then +!MGD write(6,*) 'namvar(i) = ',namvar(i),' pabbrev = ',pabbrev +!MGD write(6,*) 'Parameter = ',gfld%ipdtmpl(2) +!MGD endif +! The following if-block is commented out since equivalent info can be obtained from g2print +! if (debug_level .gt. 1000) then +! fldmax=gfld%fld(1) +! fldmin=gfld%fld(1) +! sum=gfld%fld(1) +! do j=2,gfld%ndpts +! if (gfld%fld(j).gt.fldmax) fldmax=gfld%fld(j) +! if (gfld%fld(j).lt.fldmin) fldmin=gfld%fld(j) +! sum=sum+gfld%fld(j) +! enddo ! gfld%ndpts +! call mprintf(.true.,DEBUG,'G2 FIELD=%s MIN=%f AVG=%f MAX=%f', +! & newline=.true., s1=pabbrev, f1=fldmin, f2=sum/gfld%ndpts, +! & f3=fldmax) +! endif + +! need to match up soil levels with those requested. +! For the Vtable levels, -88 = all levels, -99 = missing. The units +! vary depending on the level code (e.g. 106 = cm, 103 = m). +! The grib2 standard allows scaling of the units, so make sure the soil level +! units are in cm (as used in the Vtable). + if ( gfld%ipdtmpl(10) .eq. 106 ) then + if ( ( gfld%ipdtmpl(14) .EQ. -1*(2**07-1) ) .AND. +! & ( gfld%ipdtmpl(15) .EQ. -1*(2**31-1) ) ) THEN ! Some compilers cannot + ! handle the initial 2**31 + ! part of the computation, + ! which is an arithmetic + ! overflow on 32 bit signed ints + & ( gfld%ipdtmpl(15) .EQ. -2147483647 ) ) THEN +! special UM grib2 + glevel1 = gfld%ipdtmpl(12) + glevel2 = gfld%ipdtmpl(11) + else + glevel1 = 100. * gfld%ipdtmpl(12)* + & (10.**(-1.*gfld%ipdtmpl(11))) + glevel2 = 100. * gfld%ipdtmpl(15)* + & (10.**(-1.*gfld%ipdtmpl(14))) + end if + TMP8LOOP: do j = 1, maxvar + if ((g2code(4,j) .eq. 106) .and. + & (gfld%ipdtmpl(2) .eq. g2code(3,j)) .and. + & (glevel1 .eq. level1(j)) .and. + & ((glevel2 .eq. level2(j)) .or. + & (level2(j) .le. -88))) then + my_field = namvar(j) + exit TMP8LOOP + endif + enddo TMP8LOOP + if (j .gt. maxvar ) then + write(6,'(a,i6,a)') 'Subsoil level ', + & gfld%ipdtmpl(12), + & ' in the GRIB2 file, was not found in the Vtable' + cycle MATCH_LOOP + endif +!MGD if (debug_level .gt. 50) write(6,*) 'my_field is now ',my_field + endif + + ! Level (eg. 10000 mb) + if(gfld%ipdtmpl(10).eq.100) then + ! Pressure level (range from 1000mb to 0mb) + level=gfld%ipdtmpl(12) * + & (10. ** (-1. * gfld%ipdtmpl(11))) + elseif((gfld%ipdtmpl(10).eq.105).or. + & (gfld%ipdtmpl(10).eq.118))then + ! Hybrid level (range from 1 to N) + level=gfld%ipdtmpl(12) + elseif(gfld%ipdtmpl(10).eq.104) then + ! Sigma level (range from 10000 to 0) + level=gfld%ipdtmpl(12) + elseif(gfld%ipdtmpl(10).eq.101) then + ! MSL + level=201300. + elseif(gfld%ipdtmpl(10).eq.103) then + ! Height above ground (m) + if (gfld%ipdtmpl(12) .eq. 2. .or. + & gfld%ipdtmpl(12) .eq. 1000. .or. ! temp fix for hrrr maxref + & gfld%ipdtmpl(12) .eq. 10. ) then + level=200100. + else + cycle MATCH_LOOP + endif + elseif((gfld%ipdtmpl(10).ge.206 .and. + & gfld%ipdtmpl(10).le.234) .or. + & (gfld%ipdtmpl(10).ge.242 .and. + & gfld%ipdtmpl(10).le.254) .or. + & (gfld%ipdtmpl(10).eq.200) .or. + & (gfld%ipdtmpl(10).eq.10) ) then + ! NCEP cloud layers used for plotting + level=200100. + elseif(gfld%ipdtmpl(10).eq.106.or. + & gfld%ipdtmpl(10).eq.1) then + ! Misc near ground/surface levels + level=200100. + elseif(gfld%ipdtmpl(10).eq.6) then + ! Level of Max wind + level=200100. + elseif(gfld%ipdtmpl(10).eq.7) then + ! Tropopause + level=200100. + else + ! If we are here then the Vtable contains a level code + ! which we cannot handle. Write an info message and skip it. + call mprintf(.true.,INFORM,"Rd_grib2 does not know abou + &t level code %i (field = %s). Skipping this field. If you want thi + &s level, rd_grib2.F must be modified", i1 = gfld%ipdtmpl(10), + & s1 = my_field ) + cycle MATCH_LOOP + endif + iplvl = int(level) + + ! Store the unpacked 2D slab from the GRIB2 record + allocate(hold_array(gfld%ngrdpts)) + do j=1,gfld%ngrdpts + hold_array(j)=gfld%fld(j) + enddo + +! Some grids need to be reordered. Until we get an example, this is +! a placeholder +! call reorder_it (hold_array, map%nx, map%ny, map%dx, +! & map%dy, iorder) + + ! When we have reached this point, we have a data array ARRAY + ! which has some data we want to save, with field name FIELD + ! at pressure level LEVEL (Pa). Dimensions of this data are + ! map%nx and map%ny. Put this data into storage. + + !print *,'call put_storage',iplvl,my_field,hold_array(55),ith + !e.g. call put_storage(200100, 'RH', my_field, 1, ith) +! call mprintf(.true.,DEBUG,"Calling put_storage for +! &level = %i , field = %s , g2level = %i ", newline=.true., +! & i1 = iplvl, s1 = my_field, i2 = gfld%ipdtmpl(12) ) + + call put_storage(iplvl,my_field, + & reshape(hold_array(1:map%nx*map%ny), + & (/map%nx, map%ny/)), map%nx,map%ny) + deallocate(hold_array) + + ! If Specific Humidity is present on hybrid levels AND + ! upper-air RH is missing, see if we can compute RH from + ! Specific Humidity. + if (.not. is_there(iplvl, 'RH') .and. + & is_there(iplvl, 'SH') .and. + & is_there(iplvl, 'TT') .and. + & is_there(iplvl, 'P')) then + call g2_compute_rh_spechumd_upa(map%nx,map%ny,iplvl) + !call llstor_remove(iplvl, 'SH') !We are done with SH + endif + + ! If Specific Humidity is present on hybrid levels AND + ! upper-air RH is missing, see if we can compute RH from + ! Specific Humidity - v2 + if (.not. is_there(iplvl, 'RH') .and. + & is_there(iplvl, 'SPECHUMD') .and. + & is_there(iplvl, 'THETA') .and. + & is_there(iplvl, 'TT')) then + call g2_compute_rh_spechumd_upa2(map%nx,map%ny,iplvl) + endif + + ! If Temperature and Theta are present on hybrid levels AND + ! upper-air PRESSURE is missing, see if we can compute PRESSURE from + ! Temperature and Theta + if (.not. is_there(iplvl, 'PRESSURE') .and. + & is_there(iplvl, 'THETA') .and. + & is_there(iplvl, 'TT')) then + call g2_compute_pressure_tth_upa(map%nx,map%ny,iplvl) + endif + + ith=ith+1 + exit MATCH_LOOP + + endif ! Selected param. + + + enddo MATCH_LOOP + + ! Deallocate arrays decoding GRIB2 record. + call gf_free(gfld) + + enddo NUM_FIELDS + + + enddo VERSION ! skgb + + + if ( debug_level .gt. 100 ) then + call mprintf (.true.,DEBUG, + & "G2 total number of fields found = %i ",newline=.true.,i1=itot) + end if + + CALL BACLOSE(junit,IOS) + + nullify(gfld%local) ! must be nullified before opening next file + ireaderr=1 + else + call mprintf (.true.,DEBUG,"open status failed because %i ", + & newline=.true., i1=ios) + hdate = '9999-99-99_99:99:99' + ireaderr=2 + endif ! ireaderr check + + END subroutine rd_grib2 + +!*****************************************************************************! +! Subroutine edition_num ! +! ! +! Purpose: ! +! Read one record from the input GRIB2 file. Based on the information in ! +! the GRIB2 header and the user-defined Vtable, decide whether the field in! +! the GRIB2 record is one to process or to skip. If the field is one we ! +! want to keep, extract the data from the GRIB2 record, and pass the data ! +! back to the calling routine. ! +! ! +! Argument list: ! +! Input: ! +! JUNIT : "Unit Number" to open and read from. Not really a Fortran ! +! unit number, since we do not do Fortran I/O for the GRIB2 ! +! files. Nor is it a UNIX File Descriptor returned from a C ! +! OPEN statement. It is really just an array index to the ! +! array (IUARR) where the UNIX File Descriptor values are ! +! stored. ! +! GRIB2FILE: File name to open, if it is not already open. ! +! ! +! Output: ! +! GRIB_EDITION: Set to 1 for GRIB and set to 2 for GRIB2 ! +! IERR : Error flag: 0 - no error on read from GRIB2 file. ! +! 1 - Hit the end of the GRIB2 file. ! +! 2 - The file GRIBFLNM we tried to open does ! +! not exist. ! +! Author: Paula McCaslin ! +! NOAA/FSL ! +! Sept 2004 ! +!*****************************************************************************! + + SUBROUTINE edition_num(junit, gribflnm, + & grib_edition, ireaderr) + + use grib_mod + use params + use module_debug + + parameter(msk1=32000,msk2=4000) + character(len=1),allocatable,dimension(:) :: cgrib + integer :: listsec0(3) + integer :: listsec1(13) + character(len=*) :: gribflnm + integer :: lskip, lgrib + integer :: junit + integer :: grib_edition + integer :: i, j, ireaderr + integer :: currlen + + character(len=4) :: ctemp + character(len=4),parameter :: grib='GRIB',c7777='7777' + +C - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +C SET ARGUMENTS + + itot=0 + icount=0 + iseek=0 + lskip=0 + lgrib=0 + currlen=0 + +!/* IOS Return Codes from BACIO: */ +!/* 0 All was well */ +!/* -1 Tried to open read only _and_ write only */ +!/* -2 Tried to read and write in the same call */ +!/* -3 Internal failure in name processing */ +!/* -4 Failure in opening file */ +!/* -5 Tried to read on a write-only file */ +!/* -6 Failed in read to find the 'start' location */ +!/* -7 Tried to write to a read only file */ +!/* -8 Failed in write to find the 'start' location */ +!/* -9 Error in close */ +!/* -10 Read or wrote fewer data than requested */ + +!if ireaderr =1 we have hit the end of a file. +!if ireaderr =2 we have hit the end of all the files. +!if ireaderr =3 beginning characters 'GRIB' not found + + ! Open a byte-addressable file. + CALL BAOPENR(junit,gribflnm,IOS) + if (ios.eq.0) then + + ! Search opend file for the next GRIB2 messege (record). + call skgb(junit,iseek,msk1,lskip,lgrib) + + ! Check for EOF, or problem + call mprintf((lgrib.eq.0),ERROR, + & "Grib2 file or date problem, stopping in edition_num.", + & newline=.true.) + + ! Check size, if needed allocate more memory. + if (lgrib.gt.currlen) then + if (allocated(cgrib)) deallocate(cgrib) + allocate(cgrib(lgrib),stat=is) + currlen=lgrib + endif + + ! Read a given number of bytes from unblocked file. + call baread(junit,lskip,lgrib,lengrib,cgrib) + + ! Check for beginning of GRIB message in the first 100 bytes + istart=0 + do j=1,100 + ctemp=cgrib(j)//cgrib(j+1)//cgrib(j+2)//cgrib(j+3) + if (ctemp.eq.grib ) then + istart=j + exit + endif + enddo + if (istart.eq.0) then + ireaderr=3 + print*, "The beginning 4 characters >GRIB< were not found." + endif + + ! Unpack Section 0 - Indicator Section to extract GRIB edition field + iofst=8*(istart+5) + call gbyte(cgrib,discipline,iofst,8) ! Discipline + iofst=iofst+8 + call gbyte(cgrib,grib_edition,iofst,8) ! GRIB edition number + +! print *, 'ungrib - grib edition num', grib_edition + CALL BACLOSE(junit,IOS) + ireaderr=1 + else if (ios .eq. -4) then + call mprintf(.true.,ERROR, + & "edition_num: unable to open %s",newline=.true.,s1=gribflnm) + else + print *,'edition_num: open status failed because',ios,gribflnm + ireaderr=2 + endif ! ireaderr check + + END subroutine edition_num + +!*****************************************************************************! + + SUBROUTINE g2_compute_rh_spechumd_upa(ix, jx, iiplvl) + ! Compute relative humidity from specific humidity in the upper air. + use storage_module + implicit none + integer :: ix, jx + integer :: iiplvl + real :: lat1, lon1, dx, dy + real, dimension(ix,jx) :: T, P, RH, Q + + real, parameter :: svp1=611.2 + real, parameter :: svp2=17.67 + real, parameter :: svp3=29.65 + real, parameter :: svpt0=273.15 + real, parameter :: eps = 0.622 + + real startlat, startlon, deltalat, deltalon + + call get_storage(iiplvl, 'P', P, ix, jx) + call get_storage(iiplvl, 'TT', T, ix, jx) + call get_storage(iiplvl, 'SH', Q, ix, jx) + + rh=1.E2*(p*q/(q*(1.-eps)+eps))/(svp1*exp(svp2*(t-svpt0)/(T-svp3))) + + call put_storage(iiplvl, 'RH', rh, ix, jx) + + end subroutine g2_compute_rh_spechumd_upa + +!*****************************************************************************! + + SUBROUTINE g2_compute_rh_spechumd_upa2(ix, jx, iiplvl) + ! Compute relative humidity from specific humidity in the upper air. + use storage_module + implicit none + integer :: ix, jx + integer :: iiplvl + real :: lat1, lon1, dx, dy + real, dimension(ix,jx) :: T, TH, RH, Q, P + + real, parameter :: svp1=611.2 + real, parameter :: svp2=17.67 + real, parameter :: svp3=29.65 + real, parameter :: svpt0=273.15 + real, parameter :: eps = 0.622 + + real startlat, startlon, deltalat, deltalon + + call get_storage(iiplvl, 'THETA', TH, ix, jx) + call get_storage(iiplvl, 'TT', T, ix, jx) + call get_storage(iiplvl, 'SPECHUMD', Q, ix, jx) + + p=1.e5*(t/th)**(1005/287.05) + + rh=1.E2*(p*q/(q*(1.-eps)+eps))/(svp1*exp(svp2*(t-svpt0)/(T-svp3))) + + call put_storage(iiplvl, 'RH', rh, ix, jx) + + end subroutine g2_compute_rh_spechumd_upa2 + +!*****************************************************************************! + + SUBROUTINE g2_compute_pressure_tth_upa(ix, jx, iiplvl) + ! Compute relative humidity from specific humidity in the upper air. + use storage_module + implicit none + integer :: ix, jx + integer :: iiplvl + real :: lat1, lon1, dx, dy + real, dimension(ix,jx) :: T, TH, P + + real, parameter :: svp1=611.2 + real, parameter :: svp2=17.67 + real, parameter :: svp3=29.65 + real, parameter :: svpt0=273.15 + real, parameter :: eps = 0.622 + + real startlat, startlon, deltalat, deltalon + + call get_storage(iiplvl, 'THETA', TH, ix, jx) + call get_storage(iiplvl, 'TT', T, ix, jx) + + p=1.e5*(t/th)**(1005/287.05) + + call put_storage(iiplvl, 'PRESSURE', p, ix, jx) + + end subroutine g2_compute_pressure_tth_upa + +!*****************************************************************************! + + subroutine ncep_grid_num (pnum) +! +! Find the grib number for descriptive labelling. +! Grib2 doesn't have a grid-number entry, so we have to figure it out +! from the parameters. +! + use gridinfo ! Included to define map% + integer :: pnum + real, parameter :: eps = .01 + character (len=8) :: tmp8 + +! write(6,*) 'begin ncep_grid_num' +! write(6,*) 'dx = ',map%dx,' pnum = ',pnum,' nx = ',map%nx + tmp8 = ' ' + if (pnum .eq. 30) then ! lambert conformal + if ( abs(map%dx - 12.19058) .lt. eps .and. map%nx .eq. 614) then + write(tmp8,'("GRID 218")') + else if (abs(map%dx - 40.63525) .lt. eps + & .and. map%nx .eq. 185) then + write(tmp8,'("GRID 212")') + else if (abs(map%dx - 40.63525) .lt. eps + & .and. map%nx .eq. 151) then + write(tmp8,'("GRID 236")') + else if (abs(map%dx - 81.2705) .lt. eps + & .and. map%nx .eq. 93) then + write(tmp8,'("GRID 211")') + else if (abs (map%dx - 32.46341) .lt. eps + & .and. map%nx .eq. 349) then + write(tmp8,'("GRID 221")') + else if (abs(map%dx - 20.317625) .lt. eps + & .and. map%nx .eq. 301) then + write(tmp8,'("GRID 252")') + else if (abs(map%dx - 13.545087) .lt. eps + & .and. map%nx .eq. 451) then + write(tmp8,'("GRID 130")') + endif + else if (pnum .eq. 20) then ! polar stereographic + if (abs(map%dx - 15.0) .lt. eps) then + write(tmp8,'("GRID 88")') + endif + else if (pnum .eq. 0) then ! lat/lon + if (abs(map%dx - 1.) .lt. eps .and. map%nx .eq. 360) then + write(tmp8,'("GRID 3")') + else if (abs(map%dx - 0.5) .lt. eps .and. map%nx .eq. 720) then + write(tmp8,'("GRID 4")') + endif + endif + map%source(25:32) = tmp8 +! write(6,*) 'map%source = ',map%source + end subroutine ncep_grid_num +!*****************************************************************************! + + function earth_radius (icode, iscale, irad_m) +! Grib2 Code Table 3.2. Returns the spherical earth's radius in km. + use module_debug + real :: earth_radius + integer :: icode + integer :: iscale, irad_m + if ( icode .eq. 0 ) then + earth_radius = 6367470. * .001 + else if ( icode .eq. 1) then + earth_radius = 0.001 * float(irad_m) / 10**iscale + else if ( icode .eq. 6 ) then + earth_radius = 6371229. * .001 + else if ( icode .eq. 8 ) then + earth_radius = 6371200. * .001 + else + call mprintf(.true.,ERROR, + & "unknown earth radius for code %i",newline=.true.,i1=icode) + endif + end function earth_radius diff --git a/WPS/ungrib/src/read_namelist.F b/WPS/ungrib/src/read_namelist.F new file mode 100644 index 00000000..b931c7c4 --- /dev/null +++ b/WPS/ungrib/src/read_namelist.F @@ -0,0 +1,299 @@ +subroutine read_namelist(hstart, hend, delta_time, ntimes,& + ordered_by_date, debug_level, out_format, prefix, & + add_lvls, new_plvl_in, interp_type) + + use misc_definitions_module + use module_debug + + implicit none + integer , parameter :: maxim_doms = 21 + character(len=200) :: extdataroot, file_name_namelist + character(len=19) :: hstart, hend + integer :: delta_time + integer :: ntimes + logical :: ordered_by_date + integer :: debug_level + real, dimension(:) :: new_plvl_in + logical :: add_lvls + integer :: interp_type + + integer :: ierr + integer :: idts + +! Declare the namelist variables: + + integer , dimension(maxim_doms) :: start_year + integer , dimension(maxim_doms) :: start_month + integer , dimension(maxim_doms) :: start_day + integer , dimension(maxim_doms) :: start_hour + integer , dimension(maxim_doms) :: start_minute + integer , dimension(maxim_doms) :: start_second + + integer , dimension(maxim_doms) :: end_year + integer , dimension(maxim_doms) :: end_month + integer , dimension(maxim_doms) :: end_day + integer , dimension(maxim_doms) :: end_hour + integer , dimension(maxim_doms) :: end_minute + integer , dimension(maxim_doms) :: end_second + + logical , dimension(maxim_doms) :: active_grid + integer , dimension(maxim_doms) :: subgrid_ratio_x + integer , dimension(maxim_doms) :: subgrid_ratio_y + + character (len=128) , dimension(maxim_doms) :: start_date, end_date + character (len=MAX_FILENAME_LEN) :: opt_output_from_geogrid_path + integer :: interval_seconds = 0 + character (len=3) :: wrf_core = 'ARW' + integer :: max_dom, io_form_geogrid + + character(len=3) :: out_format + character(len=MAX_FILENAME_LEN) :: prefix + logical :: nocolons + + real :: target_end, incr + integer :: il + + real, dimension(:), allocatable :: new_plvl + + namelist /share/ wrf_core, max_dom, & + start_year, start_month, start_day, start_hour, & + start_minute, start_second, & + end_year, end_month, end_day, end_hour, & + end_minute, end_second,& + interval_seconds, & + start_date, end_date, & + io_form_geogrid, opt_output_from_geogrid_path, & + debug_level, active_grid, & + subgrid_ratio_x, subgrid_ratio_y, & + nocolons + + namelist /ungrib/ out_format, & + ordered_by_date, prefix, & + add_lvls, new_plvl, interp_type + + allocate(new_plvl(size(new_plvl_in))) + + start_year = 0 + start_month = 0 + start_day = 0 + start_hour = 0 + start_minute = 0 + start_second = 0 + + end_year = 0 + end_month = 0 + end_day = 0 + end_hour = 0 + end_minute = 0 + end_second = 0 + + ! Set defaults. + io_form_geogrid = 2 + max_dom = 1 + wrf_core = 'ARW' + debug_level = 0 + nocolons = .false. + + add_lvls = .false. + new_plvl = -99999. + interp_type = 0 + +! Start routine: + +! Build the namelist file name: + +#ifndef __crayx1 + CALL GETENV('EXT_DATAROOT',extdataroot) +#endif + file_name_namelist = 'namelist.wps' + +! Open the namelist file: + open(10, file=file_name_namelist, status='old', iostat=ierr) + call mprintf((ierr.ne.0),ERROR,"**** Error opening namelist file namelist.wps") + + REWIND (10) + + ! set default: + ordered_by_date = .TRUE. + start_date(1)(1:4) = '0000' + end_date(1)(1:4) = '0000' + + read(10,NML=share) + + if (debug_level.gt.100) then + call set_debug_level(DEBUG) + else + call set_debug_level(WARN) + end if + + +! Build the Starting date HSTART and the ending date HEND from the namelist +! date/time information. start_date takes priority over the multi-variable method. + + if ( start_date(1)(1:4) .eq. '0000' ) then + call build_hdate(hstart, start_year(1), start_month(1), start_day(1), start_hour(1), & + start_minute(1), start_second(1)) + else + hstart = start_date(1)(1:19) + endif + if ( end_date(1)(1:4) .eq. '0000' ) then + call build_hdate(hend, end_year(1), end_month(1), end_day(1), end_hour(1), & + end_minute(1), end_second(1)) + else + hend = end_date(1)(1:19) + endif + +! Compute the time difference between start date and end date: + + call geth_idts(hend, hstart, idts) + +! Check that INTERVAL is greater than zero: + + if (interval_seconds <= 0) then + call mprintf(.true.,STDOUT,"ERROR STOP IN READ_NAMELIST") + call mprintf(.true.,STDOUT,"INTERVAL must be greater than zero:") + call mprintf(.true.,STDOUT,"Start time: %s",s1=hstart) + call mprintf(.true.,STDOUT,"End time: %s",s1=hend) + call mprintf(.true.,STDOUT,"INTERVAL: %i",i1=interval_seconds) + call mprintf(.true.,LOGFILE,"ERROR STOP IN READ_NAMELIST") + call mprintf(.true.,LOGFILE,"INTERVAL must be greater than zero:") + call mprintf(.true.,LOGFILE,"Start time: %s",s1=hstart) + call mprintf(.true.,LOGFILE,"End time: %s",s1=hend) + call mprintf(.true.,LOGFILE,"INTERVAL: %i",i1=interval_seconds) + call mprintf(.true.,ERROR,"Change your namelist, and resubmit") + endif + +! Check that the selected INTERVAL evenly fills difference between +! start time and end time: + + if ((idts/interval_seconds)*interval_seconds /= idts) then + call mprintf(.true.,STDOUT,"ERROR STOP IN READ_NAMELIST") + call mprintf(.true.,STDOUT,"INTERVAL must fit evenly between start time and end time:") + call mprintf(.true.,STDOUT,"Start time: %s",s1=hstart) + call mprintf(.true.,STDOUT,"End time: %s",s1=hend) + call mprintf(.true.,STDOUT,"INTERVAL : %i seconds, %f hours",& + i1=interval_seconds,f1=float(interval_seconds)/3600.) + call mprintf(.true.,LOGFILE,"ERROR STOP IN READ_NAMELIST") + call mprintf(.true.,LOGFILE,"INTERVAL must fit evenly between start time and end time:") + call mprintf(.true.,LOGFILE,"Start time: %s",s1=hstart) + call mprintf(.true.,LOGFILE,"End time: %s",s1=hend) + call mprintf(.true.,LOGFILE,"INTERVAL : %i seconds, %f hours",& + i1=interval_seconds,f1=float(interval_seconds)/3600.) + call mprintf(.true.,ERROR,"Change your namelist, and resubmit") + endif + +! Check that start time is not later than end time: + + if (hstart > hend) then + call mprintf(.true.,STDOUT,"ERROR STOP IN READ_NAMELIST") + call mprintf(.true.,STDOUT,"Start time must not be later than end time:") + call mprintf(.true.,STDOUT,"Start time: %s",s1=hstart) + call mprintf(.true.,STDOUT,"End time: %s",s1=hend) + call mprintf(.true.,STDOUT,"INTERVAL: %i",i1=interval_seconds) + call mprintf(.true.,LOGFILE,"ERROR STOP IN READ_NAMELIST") + call mprintf(.true.,LOGFILE,"Start time must not be later than end time:") + call mprintf(.true.,LOGFILE,"Start time: %s",s1=hstart) + call mprintf(.true.,LOGFILE,"End time: %s",s1=hend) + call mprintf(.true.,LOGFILE,"INTERVAL: %i",i1=interval_seconds) + call mprintf(.true.,ERROR,"Change your namelist, and resubmit") + endif + +! Compute the number of time periods to process: + + ntimes = idts/interval_seconds + 1 + + call mprintf(.true.,STDOUT, & + "Start_date = %s , End_date = %s ",s1=hstart,s2=hend) + call mprintf(.true.,LOGFILE, & + "Start_date = %s , End_date = %s ",s1=hstart,s2=hend) + + if (debug_level.gt.0) then + call mprintf(.true.,LOGFILE,"Namelist information (coarse domain): ") + call mprintf(.true.,LOGFILE,' START_YEAR = %i',i1=start_year(1)) + call mprintf(.true.,LOGFILE,' START_MONTH = %i',i1=start_month(1)) + call mprintf(.true.,LOGFILE,' START_DAY = %i',i1=start_day(1)) + call mprintf(.true.,LOGFILE,' START_HOUR = %i',i1=start_hour(1)) +! call mprintf(.true.,LOGFILE,"start_minute = %i",i1=start_minute(1)) +! call mprintf(.true.,LOGFILE,"start_second = %i",i1=start_second(1)) + call mprintf(.true.,LOGFILE,' END_YEAR = %i',i1=end_year(1)) + call mprintf(.true.,LOGFILE,' END_MONTH = %i',i1=end_month(1)) + call mprintf(.true.,LOGFILE,' END_DAY = %i',i1=end_day(1)) + call mprintf(.true.,LOGFILE,' END_HOUR = %i',i1=end_hour(1)) +! call mprintf(.true.,LOGFILE,"end_minute = %i",i1=end_minute(1)) +! call mprintf(.true.,LOGFILE,"end_second = %i",i1=end_second(1)) + call mprintf(.true.,LOGFILE,' START_DATE = %s',s1=start_date(1)) + call mprintf(.true.,LOGFILE,' END_DATE = %s',s1=end_date(1)) + call mprintf(.true.,LOGFILE,' INTERVAL_SECONDS = %i',i1=interval_seconds) + call mprintf(.true.,LOGFILE,' DEBUG_LEVEL = %i',i1=debug_level) + call mprintf(.true.,LOGFILE,'/') + else + debug_level=0 + endif + + delta_time = interval_seconds + + rewind(10) + out_format = 'WPS' + prefix = 'FILE' + read(10,NML=ungrib,END=100) + + call mprintf(.true.,LOGFILE,'&UNGRIB') + call mprintf(.true.,LOGFILE,"out_format = %s",s1=out_format) + if (ordered_by_date) then + call mprintf(.true.,LOGFILE,"ordered_by_date = %s",s1='TRUE') + else + call mprintf(.true.,LOGFILE,"ordered_by_date = %s",s1='FALSE') + endif + call mprintf(.true.,LOGFILE,"prefix = %s",s1=trim(prefix)) + call mprintf(.true.,LOGFILE,'/') + +100 continue + if (out_format(1:2) .eq. 'WP' .or. out_format(1:2) .eq. 'wp') then + out_format = 'WPS' + call mprintf(.true.,STDOUT,'output format is WPS') + call mprintf(.true.,LOGFILE,'output format is WPS') + else if (out_format(1:2) .eq. 'SI' .or. out_format(1:2) .eq. 'si') then + out_format = 'SI ' + call mprintf(.true.,STDOUT,'output format is SI') + call mprintf(.true.,LOGFILE,'output format is SI') + else if (out_format(1:2) .eq. 'MM' .or. out_format(1:2) .eq. 'mm') then + out_format = 'MM5' + call mprintf(.true.,STDOUT,'output format is MM5 pregrid') + call mprintf(.true.,LOGFILE,'output format is MM5 pregrid') + else + call mprintf(.true.,ERROR, & + 'read_namelist: I do not recognize the output format, %s , stopping.',s1=out_format) + endif + +! Check to see if I should create my own set of new_plvl's + if ( add_lvls .AND. new_plvl(2) > -99999. .AND. new_plvl(2) < 0.0 ) then + target_end = abs(new_plvl(2)) + incr = new_plvl(3) + il = 2 + make_plvl : do + if(il.gt.size(new_plvl)) then + call mprintf(.true.,ERROR,& + 'Too many new levels specified via new_plvl. Increase maxlvl in ungrib.F') + end if + new_plvl(il) = new_plvl(il-1) - incr + ! If we are past the end of the range of pressures over which new levels + ! are to be created, then discard the pressure we just calculated. + ! This occurs when the user-chosen increment did not evenly divide + ! the range of pressures over which new pressures were to be added. + if ( new_plvl(il) < target_end ) then + new_plvl(il) = -99999. + exit make_plvl + end if + if ( new_plvl(il) == target_end ) exit make_plvl + il = il + 1 + end do make_plvl + endif + +! Close the namelist file: + + close(10) + + new_plvl_in(:) = new_plvl(:) + deallocate(new_plvl) + +end subroutine read_namelist diff --git a/WPS/ungrib/src/rrpr.F b/WPS/ungrib/src/rrpr.F new file mode 100644 index 00000000..09506679 --- /dev/null +++ b/WPS/ungrib/src/rrpr.F @@ -0,0 +1,1399 @@ +subroutine rrpr(hstart, ntimes, interval, nlvl, maxlvl, plvl, & + add_lvls, new_plvl, interp_type, & + debug_level, out_format, prefix) +! ! +! In case you are wondering, RRPR stands for "Read, ReProcess, and wRite" ! +! ! +!*****************************************************************************! +! ! + + use filelist + use gridinfo + use storage_module + use table + use module_debug + use misc_definitions_module + use stringutil + + implicit none + +!------------------------------------------------------------------------------ +! Arguments: + +! HSTART: Starting date of times to process + character (LEN=19) :: hstart + +! NTIMES: Number of time periods to process + integer :: ntimes + +! INTERVAL: Time inteval (seconds) of time periods to process. + integer :: interval + +! NLVL: The number of levels in the stored data. + integer :: nlvl + +! MAXLVL: The parameterized maximum number of levels to allow. + integer :: maxlvl + +! PLVL: Array of pressure levels (Pa) in the dataset + real , dimension(maxlvl) :: plvl + +! NEW_PLVL: Array of the additional pressure levels (Pa) to interpolate to + real , dimension(maxlvl) :: new_plvl + +! TLVL: Array combining pressure levels (Pa) in PLVL and NEW_PLVL + real , dimension(maxlvl) :: tlvl + +! ADD_LVLS: Should we add levels via interpolation? + logical :: add_lvls + +! INTERP_TYPE: vertical Interpolation type +! (1=log in pressure, anything else=linear in pressure) + integer :: interp_type + + +! DEBUG_LEVEL: Integer level of debug printing (from namelist) + integer :: debug_level + +!------------------------------------------------------------------------------ + + character (LEN=25) :: units + character (LEN=46) :: Desc + real, allocatable, dimension(:,:) :: scr2d, tmp2d + real, pointer, dimension(:,:) :: ptr2d + + integer :: k, kk, mm, n, ierr, ifv + integer :: itest, nn, nl, lvls, tvls + integer :: iunit=13 + + character(LEN=19) :: hdate, hend + character(LEN=24) :: hdate_output + character(LEN=3) :: out_format + character(LEN=MAX_FILENAME_LEN) :: prefix + real :: xfcst, level + character(LEN=9) :: field + + integer :: ntime, idts + + logical :: found_level + real, dimension(maxlvl) :: new_plvl_to_sort + integer :: largest_number_loc + integer :: new_plvl_counter + +! DATELEN: length of date strings to use for our output file names. + integer :: datelen + +! Decide the length of date strings to use for output file names. +! DATELEN is 13 for hours, 16 for minutes, and 19 for seconds. + + if (mod(interval,3600) == 0) then + datelen = 13 + else if (mod(interval, 60) == 0) then + datelen = 16 + else + datelen = 19 + endif + + if ( debug_level .gt. 100 ) then + call mprintf(.true.,DEBUG,"Begin rrpr") + call mprintf(.true.,DEBUG,"nfiles = %i , ntimes = %i )",i1=nfiles,i2=ntimes) + do n = 1, nfiles + call mprintf(.true.,DEBUG,"filedates(%i) = %s",i1=n,s1=filedates(n)) + enddo + endif + +! Compute the ending time: + + call geth_newdate(hend, hstart, interval*ntimes) + + call clear_storage + +! We want to do something for each of the requested times: + TIMELOOP : do ntime = 1, ntimes + idts = (ntime-1) * interval + call geth_newdate(hdate, hstart, idts) + call mprintf(.true.,DEBUG, & + "RRPR: hstart = %s , hdate = %s , idts = %i",s1=hstart,s2=hdate,i1=idts) + +! Loop over the output file dates, and do stuff if the file date matches +! the requested time we are working on now. + + FILELOOP : do n = 1, nfiles + if ( debug_level .gt. 100 ) then + call mprintf(.true.,DEBUG, & + "hstart = %s , hend = %s",s1=hstart,s2=hend) + call mprintf(.true.,DEBUG, & + "filedates(n) = %s",s1=filedates(n)) + call mprintf(.true.,DEBUG, & + "filedates(n) = %s",s1=filedates(n)(1:datelen)) + end if + if (filedates(n)(1:datelen).ne.hdate(1:datelen)) cycle FILELOOP + if (debug_level .gt. 50 ) then + call mprintf(.true.,INFORM, & + "RRPR Processing : %s",s1=filedates(n)(1:datelen)) + endif + open(iunit, file=trim(get_path(prefix))//'PFILE:'//filedates(n)(1:datelen), & + form='unformatted',status='old') + +! Read the file: + + rdloop: do + read (iunit, iostat=ierr) ifv + if (ierr.ne.0) exit rdloop + if ( ifv .eq. 5) then ! WPS + read (iunit) hdate_output, xfcst, map%source, field, units, Desc, & + level, map%nx, map%ny, map%igrid + hdate = hdate_output(1:19) + select case (map%igrid) + case (0, 4) + read (iunit) map%startloc, map%lat1, map%lon1, map%dy, map%dx, map%r_earth + case (3) + read (iunit) map%startloc, map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1, map%truelat2, map%r_earth + case (5) + read (iunit) map%startloc, map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1, map%r_earth + case (1) + read (iunit) map%startloc, map%lat1, map%lon1, map%dy, map%dx, & + map%truelat1, map%r_earth + case (6) + read (iunit) map%startloc, map%lat1, map%lon1, map%dy, map%dx, & + map%lat0,map%lon0, map%r_earth + case default + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in RRPR 1",i1=map%igrid) + end select + read (iunit) map%grid_wind + + else if ( ifv .eq. 4 ) then ! SI + read (iunit) hdate_output, xfcst, map%source, field, units, desc, level, & + map%nx, map%ny, map%igrid + hdate = hdate_output(1:19) + select case (map%igrid) + case (0, 4) + read(iunit) map%startloc, map%lat1, map%lon1, map%dy, map%dx + case (3) + read (iunit) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1, map%truelat2 + case (5) + read (iunit) map%startloc, map%lat1, map%lon1, map%dx, map%dy, & + map%lov, map%truelat1 + case default + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in RRPR 2",i1=map%igrid) + end select + + else if ( ifv .eq. 3 ) then ! MM5 + read(iunit) hdate_output, xfcst, field, units, desc, level,& + map%nx, map%ny, map%igrid + hdate = hdate_output(1:19) + select case (map%igrid) + case (3) ! lamcon + read (iunit) map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1, map%truelat2 + case (5) ! Polar Stereographic + read (iunit) map%lat1, map%lon1, map%dx, map%dy, map%lov, & + map%truelat1 + case (0, 4) ! lat/lon + read (iunit) map%lat1, map%lon1, map%dy, map%dx + case (1) ! Mercator + read (iunit) map%lat1, map%lon1, map%dy, map%dx, map%truelat1 + case default + call mprintf(.true.,ERROR, & + "Unrecognized map%%igrid: %i in RRPR 3",i1=map%igrid) + end select + else + call mprintf(.true.,ERROR, & + "unknown out_format, ifv = %i",i1=ifv) + endif + + allocate(ptr2d(map%nx,map%ny)) + read (iunit) ptr2d + call refw_storage(nint(level), field, ptr2d, map%nx, map%ny) + nullify (ptr2d) + enddo rdloop + + write (0,*) 'Name of source model =>',map%source +! +! We have reached the end of file, so time to close it. +! + close(iunit) + if (debug_level .gt. 100 ) call print_storage +! +! By now the file has been read completely. Now, see if we need to fill in +! missing fields: +! + +! Retrieve the number of levels in storage: +! + call get_plvls(plvl, maxlvl, nlvl) + +! Merge list of pressure levels in data with requested pressure levels + if ( add_lvls ) then + ! The merging code expects the user-defined pressure levels to be in + ! order from highest pressure to lowest pressure. + ! Sort the user-defined pressure levels accordingly + new_plvl_to_sort = new_plvl + ! Set array containing pressure levels to add to the default value set in read_namelist.F + new_plvl = -99999 + DO new_plvl_counter = 1,maxlvl + largest_number_loc = MAXLOC(new_plvl_to_sort, DIM=1) + new_plvl(new_plvl_counter)=new_plvl_to_sort(largest_number_loc) + new_plvl_to_sort(largest_number_loc)=-99999. + END DO + + tvls = 1 + lvls = 1 + loop_nvls : do nn=1,maxlvl + loop_lvls : do nl=lvls,maxlvl + if ( tvls > maxlvl ) then + call mprintf(.true.,ERROR, "Adding user-defined pressure levels resulted in too & + &many total pressure levels. Please increase maxlvl in ungrib.F") + endif + if ( plvl(nn) > 0.0 .AND. plvl(nn) >= new_plvl(nl) ) then + tlvl(tvls) = plvl(nn) + tvls = tvls + 1 + if ( plvl(nn) == new_plvl(nl) ) lvls = lvls + 1 + exit loop_lvls + endif + if ( plvl(nn) > 0.0 .AND. plvl(nn) < new_plvl(nl) ) then + tlvl(tvls) = new_plvl(nl) + tvls = tvls + 1 + lvls = lvls + 1 + endif + if ( plvl(nn) < 0.0 ) exit loop_nvls + enddo loop_lvls + enddo loop_nvls + plvl = tlvl + nlvl = tvls - 1 + end if + +! +! Fill the surface level (code 200100) from higher 200100s, as necessary +! + do k = 1, nlvl + if ((plvl(k).gt.200100) .and. (plvl(k).lt.200200)) then + ! We found a level between 200100 and 200200, now find the field + ! corresponding to that level. + MLOOP : do mm = 1, maxvar + if (is_there(nint(plvl(k)), namvar(mm))) then + INLOOP : do kk = 200101, nint(plvl(k)) + if (is_there(kk, namvar(mm))) then + if ( debug_level .gt. 100 ) then + call mprintf(.true.,DEBUG, & + "Copying %s at level %i to level 200100.",s1=namvar(mm),i1=kk) + end if + call get_dims(kk, namvar(mm)) + allocate(scr2d(map%nx,map%ny)) + call get_storage & + (kk, namvar(mm), scr2d, map%nx, map%ny) + call put_storage & + (200100,namvar(mm), scr2d,map%nx,map%ny) + deallocate(scr2d) + EXIT INLOOP + endif + enddo INLOOP + endif + enddo MLOOP + endif + enddo + +! +! If upper-air U is missing, see if we can interpolate from surrounding levels. +! This is a simple vertical interpolation, linear or log in pressure. +! Currently, this simply fills in missing levels between two present levels. +! + + do k = 2, nlvl-1, 1 + if (plvl(k-1) .lt. 200000.) then + if ( (.not. is_there(nint(plvl(k)),'UU')) .and. & + ( is_there(nint(plvl(k-1)), 'UU')) ) then + found_level = .false. + uu_loop : do itest = k+1,nlvl,1 + if ( ( is_there(nint(plvl(itest)), 'UU')) ) then + found_level = .true. + exit uu_loop + endif + enddo uu_loop + if( found_level ) then + call get_dims(nint(plvl(itest)), 'UU') + call vntrp(plvl, maxlvl, k, itest, interp_type, "UU ", map%nx, map%ny) + else + PRINT *,'WARNING: Could not interpolate UU to level k=',k,' p=',plvl(k),& + 'because could not find any level above this level.' + endif + endif + endif + enddo + +! +! If upper-air V is missing, see if we can interpolate from surrounding levels. +! This is a simple vertical interpolation, linear or log in pressure. +! Currently, this simply fills in missing levels between two present levels. +! + + + do k = 2, nlvl-1, 1 + if (plvl(k-1) .lt. 200000.) then + if ( (.not. is_there(nint(plvl(k)),'VV')) .and. & + ( is_there(nint(plvl(k-1)), 'VV')) ) then + found_level = .false. + VV_loop : do itest = k+1,nlvl,1 + if ( ( is_there(nint(plvl(itest)), 'VV')) ) then + found_level = .true. + exit VV_loop + endif + enddo VV_loop + if( found_level ) then + call get_dims(nint(plvl(itest)), 'VV') + call vntrp(plvl, maxlvl, k, itest, interp_type, "VV ", map%nx, map%ny) + else + PRINT *,'WARNING: Could not interpolate VV to level k=',k,' p=',plvl(k),& + 'because could not find any level above this level.' + endif + endif + endif + enddo + +! +! If upper-air SPECHUMD is missing, see if we can compute SPECHUMD from QVAPOR: +!--- Tanya's change for initializing WRF with RUC + + do k = 1, nlvl + if (plvl(k).lt.200000.) then + if (.not. is_there(nint(plvl(k)), 'SPECHUMD').and. & + is_there(nint(plvl(k)), 'QV')) then + call get_dims(nint(plvl(k)), 'QV') + call compute_spechumd_qvapor(map%nx, map%ny, plvl(k)) + endif + endif + enddo + +!--- Tanya's change for initializing WRF with RUC +! This allows for the ingestion for RUC isentropic data +! + do k = 1, nlvl + if (plvl(k).lt.200000.) then + if (.not. is_there(nint(plvl(k)), 'TT').and. & + is_there(nint(plvl(k)), 'VPTMP').and. & + is_there(nint(plvl(k)), 'SPECHUMD')) then + call get_dims(nint(plvl(k)), 'VPTMP') + call compute_t_vptmp(map%nx, map%ny, plvl(k)) + endif + endif + enddo +!!! +! +! If upper-air T is missing, see if we can interpolate from surrounding levels. +! This is a simple vertical interpolation, linear or log in pressure. +! Currently, this simply fills in missing levels between two present levels. +! + + do k = 2, nlvl-1, 1 + if (plvl(k-1) .lt. 200000.) then + if ( (.not. is_there(nint(plvl(k)),'TT')) .and. & + ( is_there(nint(plvl(k-1)), 'TT')) ) then + found_level = .false. + TT_loop : do itest = k+1,nlvl,1 + if ( ( is_there(nint(plvl(itest)), 'TT')) ) then + found_level = .true. + exit TT_loop + endif + enddo TT_loop + if( found_level ) then + call get_dims(nint(plvl(itest)), 'TT') + call vntrp(plvl, maxlvl, k, itest, interp_type, "TT ", map%nx, map%ny) + else + PRINT *,'WARNING: Could not interpolate TT to level k=',k,' p=',plvl(k),& + 'because could not find any level above this level.' + endif + endif + endif + enddo + +! Vertically interpolate to fill in other moisture variables +! It seems that ultimately this should be wrapped in a function and probably loop over +! all variables that can be vertically interpolated + +! QC + do k = 2, nlvl-1, 1 + if (plvl(k-1) .lt. 200000.) then + if ( (.not. is_there(nint(plvl(k)),'QC')) .and. & + ( is_there(nint(plvl(k-1)), 'QC')) ) then + found_level = .false. + QC_loop : do itest = k+1,nlvl,1 + if ( ( is_there(nint(plvl(itest)), 'QC')) ) then + found_level = .true. + exit QC_loop + endif + enddo QC_loop + if( found_level ) then + call get_dims(nint(plvl(itest)), 'QC') + call vntrp(plvl, maxlvl, k, itest, interp_type, "QC ", map%nx, map%ny) + else + PRINT *,'WARNING: Could not interpolate QC to level k=',k,' p=',plvl(k),& + 'because could not find any level above this level.' + endif + endif + endif + enddo + +! QR + do k = 2, nlvl-1, 1 + if (plvl(k-1) .lt. 200000.) then + if ( (.not. is_there(nint(plvl(k)),'QR')) .and. & + ( is_there(nint(plvl(k-1)), 'QR')) ) then + found_level = .false. + QR_loop : do itest = k+1,nlvl,1 + if ( ( is_there(nint(plvl(itest)), 'QR')) ) then + found_level = .true. + exit QR_loop + endif + enddo QR_loop + if( found_level ) then + call get_dims(nint(plvl(itest)), 'QR') + call vntrp(plvl, maxlvl, k, itest, interp_type, "QR ", map%nx, map%ny) + else + PRINT *,'WARNING: Could not interpolate QR to level k=',k,' p=',plvl(k),& + 'because could not find any level above this level.' + endif + endif + endif + enddo + +! QS + do k = 2, nlvl-1, 1 + if (plvl(k-1) .lt. 200000.) then + if ( (.not. is_there(nint(plvl(k)),'QS')) .and. & + ( is_there(nint(plvl(k-1)), 'QS')) ) then + found_level = .false. + QS_loop : do itest = k+1,nlvl,1 + if ( ( is_there(nint(plvl(itest)), 'QS')) ) then + found_level = .true. + exit QS_loop + endif + enddo QS_loop + if( found_level ) then + call get_dims(nint(plvl(itest)), 'QS') + call vntrp(plvl, maxlvl, k, itest, interp_type, "QS ", map%nx, map%ny) + else + PRINT *,'WARNING: Could not interpolate QS to level k=',k,' p=',plvl(k),& + 'because could not find any level above this level.' + endif + endif + endif + enddo + +! QG + do k = 2, nlvl-1, 1 + if (plvl(k-1) .lt. 200000.) then + if ( (.not. is_there(nint(plvl(k)),'QG')) .and. & + ( is_there(nint(plvl(k-1)), 'QG')) ) then + found_level = .false. + QG_loop : do itest = k+1,nlvl,1 + if ( ( is_there(nint(plvl(itest)), 'QG')) ) then + found_level = .true. + exit QG_loop + endif + enddo QG_loop + if( found_level ) then + call get_dims(nint(plvl(itest)), 'QG') + call vntrp(plvl, maxlvl, k, itest, interp_type, "QG ", map%nx, map%ny) + else + PRINT *,'WARNING: Could not interpolate QG to level k=',k,' p=',plvl(k),& + 'because could not find any level above this level.' + endif + endif + endif + enddo + + +! +! Check to see if we need to fill HGT from GEOPT. +! +! First make sure no GEOPT is missing + + do k = 2, nlvl-1, 1 + if (plvl(k-1) .lt. 200000.) then + if ( (.not. is_there(nint(plvl(k)),'GEOPT')) .and. & + ( is_there(nint(plvl(k-1)), 'GEOPT')) ) then + found_level = .false. + gg_loop : do itest = k+1,nlvl,1 + if ( ( is_there(nint(plvl(itest)), 'GEOPT')) ) then + found_level = .true. + exit gg_loop + endif + enddo gg_loop + if( found_level ) then + call get_dims(nint(plvl(itest)), 'GEOPT') + call vntrp(plvl, maxlvl, k, itest, interp_type, "GEOPT ", map%nx, map%ny) + else + PRINT *,'WARNING: Could not interpolate GEOPT to level k=',k,' p=',plvl(k),& + 'because could not find any level above this level.' + endif + endif + endif + enddo + + do k = 1, nlvl + if (plvl(k).lt.200000.) then + if (.not. is_there(nint(plvl(k)), 'HGT').and. & + is_there(nint(plvl(k)), 'GEOPT')) then + call get_dims(nint(plvl(k)), 'GEOPT') + allocate(scr2d(map%nx,map%ny)) + call get_storage(nint(plvl(k)), 'GEOPT', scr2d, map%nx, map%ny) + scr2d = scr2d / 9.81 + call put_storage(nint(plvl(k)), 'HGT', scr2d, map%nx, map%ny) + call mprintf(.true.,DEBUG, & + "RRPR: Computing GHT from GEOPT ") + deallocate(scr2d) + endif + if ( (.not. is_there(nint(plvl(k)),'HGT')) .and. & + ( is_there(nint(plvl(k-1)), 'HGT')) ) then + found_level = .false. + hg_loop : do itest = k+1,nlvl,1 + if ( ( is_there(nint(plvl(itest)), 'HGT')) ) THEN + found_level = .true. + exit hg_loop + ENDIF + enddo hg_loop + if( found_level ) then + call get_dims(nint(plvl(itest)), 'HGT') + call vntrp(plvl, maxlvl, k, itest, interp_type, "HGT ", map%nx, map%ny) + else + PRINT *,'WARNING: Could not interpolate HGT to level k=',k,' p=',plvl(k),& + 'because could not find any level above this level.' + endif + endif + endif + enddo + +! +! If this is GFS data, we might have data at the level of max wind speed, +! or the level of the tropopause. If so, we want to replicate the pressures +! at those levels (new names). The replicated names are to allow the +! metgrid program to interpolate the 2d pressure array with both a nearest +! neighbor AND a 4-pt technique. Those two pressures are used in ARW real +! for vertical interpolation of the trop and max wind level data. +! + + if (index(map%source,'NCEP GFS') .ne. 0 ) then + call mprintf(.true.,DEBUG, & + "RRPR: Replicating GFS pressures for max wind and trop") + if ( is_there(200100,'PMAXW ') .or. & + is_there(200100,'PTROP ') ) then + call gfs_trop_maxw_pressures (map%nx, map%ny) + endif + endif + +! Repair GFS and ECMWF pressure-level RH + if (index(map%source,'NCEP GFS') .ne. 0 .or. & + index(map%source,'NCEP CDAS CFSV2') .ne. 0 .or. & + index(map%source,'ECMWF') .ne. 0 ) then + call mprintf(.true.,DEBUG, & + "RRPR: Adjusting RH values ") + do k = 1, nlvl + if ( is_there(nint(plvl(k)),'RH') .and. & + is_there(nint(plvl(k)),'TT') ) then + call fix_gfs_rh (map%nx, map%ny, plvl(k)) + endif + enddo + endif + +! If upper-air RH is missing, see if we can compute RH from Specific Humidity: + + do k = 1, nlvl + if (plvl(k).lt.200000.) then + if (.not. is_there(nint(plvl(k)), 'RH') .and. & + is_there(nint(plvl(k)), 'TT') .and. & + is_there(nint(plvl(k)), 'SPECHUMD')) then + call get_dims(nint(plvl(k)), 'TT') + call compute_rh_spechumd_upa(map%nx, map%ny, plvl(k)) + endif + endif + enddo + +! If upper-air RH is missing, see if we can compute RH from Vapor Pressure: +! (Thanks to Bob Hart of PSU ESSC -- 1999-05-27.) + + do k = 1, nlvl + if (plvl(k).lt.200000.) then + if (.not. is_there(nint(plvl(k)),'RH').and. & + is_there(nint(plvl(k)), 'TT') .and. & + is_there(nint(plvl(k)),'VAPP')) then + call get_dims(nint(plvl(k)),'TT') + call compute_rh_vapp_upa(map%nx, map%ny, plvl(k)) + endif + endif + enddo + +! If upper-air RH is missing, see if we can compute RH from Dewpoint Depression: + + do k = 1, nlvl + if (plvl(k).lt.200000.) then + if (.not. is_there(nint(plvl(k)),'RH').and. & + is_there(nint(plvl(k)), 'TT') .and. & + is_there(nint(plvl(k)),'DEPR')) then + call get_dims(nint(plvl(k)),'TT') + call compute_rh_depr(map%nx, map%ny, plvl(k)) + endif + endif + enddo +! +! If upper-air RH is missing, see if we can interpolate from surrounding levels. +! This is a simple vertical interpolation, linear or log in pressure. +! Currently, this simply fills in missing levels between two present levels. + +! + + do k = 2, nlvl-1, 1 + if (plvl(k-1) .lt. 200000.) then + if ( (.not. is_there(nint(plvl(k)),'RH')) .and. & + ( is_there(nint(plvl(k-1)), 'RH')) ) then + found_level = .false. + RH_loop : do itest = k+1,nlvl,1 + if ( ( is_there(nint(plvl(itest)), 'RH')) ) then + found_level = .true. + exit RH_loop + endif + enddo RH_loop + if( found_level ) then + call get_dims(nint(plvl(itest)), 'RH') + call vntrp(plvl, maxlvl, k, itest, interp_type, "RH ", map%nx, map%ny) + else + PRINT *,'WARNING: Could not interpolate RH to level k=',k,' p=',plvl(k),& + 'because could not find any level above this level.' + endif + endif + endif + enddo + +! +! Check to see if we need to fill RH above 300 mb: +! + if (is_there(30000, 'RH')) then + call get_dims(30000, 'RH') + allocate(scr2d(map%nx,map%ny)) + + do k = 1, nlvl +! Set missing RH to 5% between 300 and 70 hPa. Set RH to 0 above 70 hPa. +! The stratospheric RH will be adjusted further in real. + if (plvl(k).le.7000.) then + scr2d = 0. + else if (plvl(k).lt.30000.) then + scr2d = 5. + endif + if (plvl(k).lt.30000. .and. plvl(k) .gt. 10. ) then + ! levels higher than .1 mb are special - do not fill + if (.not. is_there(nint(plvl(k)), 'RH')) then + call put_storage(nint(plvl(k)),'RH',scr2d,map%nx,map%ny) + call mprintf(.true.,DEBUG, & + "RRPR: RH missing at %i hPa, inserting synthetic RH ",i1=nint(plvl(k)/100.)) + endif + endif + enddo + deallocate(scr2d) + endif +! +! If surface RH is missing, see if we can compute RH from Specific Humidity +! or Dewpoint or Dewpoint depression: +! + if (.not. is_there (200100, 'RH')) then + if (is_there(200100, 'TT').and. & + is_there(200100, 'PSFC' ) .and. & + is_there(200100, 'SPECHUMD')) then + call get_dims(200100, 'TT') + call compute_rh_spechumd(map%nx, map%ny) + call mprintf(.true.,DEBUG, & + "RRPR: SURFACE RH is computed") + elseif (is_there(200100, 'TT' ).and. & + is_there(200100, 'DEWPT')) then + call get_dims(200100, 'TT') + call compute_rh_dewpt(map%nx, map%ny) + elseif (is_there(200100, 'TT').and. & + is_there(200100, 'DEPR')) then + call get_dims(200100, 'TT') + call compute_rh_depr(map%nx, map%ny, 200100.) + endif + endif + +! +! If surface SNOW is missing, see if we can compute SNOW from SNOWRUC +! (From Wei Wang, 2007 June 21, modified 12/28/2007) +! + if (.not. is_there(200100, 'SNOW') .and. & + is_there(200100, 'SNOWRUC')) then + call get_dims(200100, 'SNOWRUC') + allocate(scr2d(map%nx,map%ny)) + call get_storage(200100, 'SNOWRUC', scr2d, map%nx, map%ny) + scr2d = scr2d * 1000. + call put_storage(200100, 'SNOW', scr2d, map%nx, map%ny) + deallocate(scr2d) + endif + +! compute snow water equivalent (SNOW) for NCEP RUC models +! As of Sept. 14 2011 + if ( index(map%source,'NCEP RUC Model') .ne. 0) then + if (is_there(200100, 'SNOWH') .and. .not. is_there(200100, 'SNOW')) then + call get_dims(200100, 'SNOWH') + allocate(scr2d(map%nx,map%ny)) + call get_storage(200100, 'SNOWH', scr2d, map%nx, map%ny) + call mprintf(.true.,DEBUG, & + "RRPR: Computing SNOWH from SNOW") + if (is_there(200100, 'RHOSN')) then ! If we have snow density, use it to compute snowh + call get_dims(200100, 'RHOSN') + allocate(tmp2d(map%nx,map%ny)) + call get_storage(200100, 'RHOSN', tmp2d, map%nx, map%ny) + scr2d = scr2d * tmp2d + deallocate(tmp2d) + else + scr2d = scr2d * 200.0 ! Assume 200:1 ratio + endif + call put_storage(200100, 'SNOW', scr2d, map%nx, map%ny) + deallocate(scr2d) + endif + endif + +! Modify the 2017 GFS masked fields + if (index(map%source,'NCEP GFS') .ne. 0 ) then + call mprintf(.true.,DEBUG, & + "RRPR: Adjusting GFS masked fields ") + call get_dims(200100, 'ST000010') + call fix_gfs_miss (map%nx, map%ny, 200100.) + endif + +! Add residual soil moisture to SOILM* if initialized from the GSD RUC model or from NCEP RUC + if (index(map%source,'NOAA GSD') .ne. 0 .or. & + index(map%source,'NCEP RUC Model') .ne. 0) then + if ( .not. is_there(200100, 'SOILM000') .and.& + is_there(200100, 'SM000ruc') ) then + call get_dims(200100, 'SM000ruc') + print *,'Adjust RUC soil moisture' + call mprintf(.true.,DEBUG, & + "RRPR: Adjusting RUC soil moisture ") + call fix_ruc_soilm (map%nx, map%ny) + endif + endif + +! +! Check to see if we need to fill SOILHGT from SOILGEO. +! (From Wei Wang, 2007 June 21) +! + if (.not. is_there(200100, 'SOILHGT') .and. & + is_there(200100, 'SOILGEO')) then + call get_dims(200100, 'SOILGEO') + allocate(scr2d(map%nx,map%ny)) + call get_storage(200100, 'SOILGEO', scr2d, map%nx, map%ny) + scr2d = scr2d / 9.81 + call put_storage(200100, 'SOILHGT', scr2d, map%nx, map%ny) + call mprintf(.true.,DEBUG, & + "RRPR: Computing SOILGHT from SOILGEO ") + deallocate(scr2d) + endif + +! For hybrid-level input, soilgeo is in level 1 (e.g. ERA40) + if (.not. is_there(200100, 'SOILHGT') .and. & + is_there(1, 'SOILGEO')) then + call get_dims(1, 'SOILGEO') + allocate(scr2d(map%nx,map%ny)) + call get_storage(1, 'SOILGEO', scr2d, map%nx, map%ny) + scr2d = scr2d / 9.81 + call put_storage(200100, 'SOILHGT', scr2d, map%nx, map%ny) + deallocate(scr2d) + endif + +! For NCEP RR (using the same ID as for RUC) native-level input, +! may need to move PSFC from level 1 to 2001. +! From TGS 8 Sept. 2011 + if ( index(map%source,'NCEP RUC Model') .ne. 0) then + if (.not. is_there(200100, 'PSFC') .and. & + is_there(1, 'PRESSURE')) then + print *,'Process PSFC for NCEP RR' + call get_dims(1, 'PRESSURE') + allocate(scr2d(map%nx,map%ny)) + call get_storage(1, 'PRESSURE', scr2d, map%nx, map%ny) + call put_storage(200100, 'PSFC', scr2d, map%nx, map%ny) + deallocate(scr2d) + endif + endif + +! For ECMWF hybrid-level input, may need to move psfc from level 1 to 2001. + if ( index(map%source,'ECMWF') .ne. 0) then + if (.not. is_there(200100, 'PSFC') .and. & + is_there(1, 'PSFCH')) then + call get_dims(1, 'PSFCH') + allocate(scr2d(map%nx,map%ny)) + call get_storage(1, 'PSFCH', scr2d, map%nx, map%ny) + call put_storage(200100, 'PSFC', scr2d, map%nx, map%ny) + deallocate(scr2d) + endif + endif + +! ECMWF snow depth in meters of water equivalent (Table 128). Convert to kg/m2 +! + if (is_there(200100, 'SNOW_EC')) then + call get_dims(200100, 'SNOW_EC') + allocate(scr2d(map%nx,map%ny)) + call get_storage(200100, 'SNOW_EC', scr2d, map%nx, map%ny) + scr2d = scr2d * 1000. + call put_storage(200100, 'SNOW', scr2d, map%nx, map%ny) + deallocate(scr2d) + endif + +! Convert the ECMWF LANDSEA mask from a fraction to a flag + + if ( index(map%source,'ECMWF') .ne. 0) then + if (is_there(200100, 'LANDSEA')) then + call get_dims(200100, 'LANDSEA') + call make_zero_or_one(map%nx, map%ny, 'LANDSEA') + endif + endif + +! NCEP GFS weasd is one-half of the NAM value. Increase it for use in WRF. +! The GFS-based reanalyses values should be OK as is. + if ((index(map%source,'NCEP GFS') .ne. 0 .or. & + index(map%source,'NCEP GEFS') .ne. 0) .and. & + is_there(200100, 'SNOW')) then + call mprintf(.true.,DEBUG, & + "RRPR: Recomputing SNOW for NCEP GFS") + call get_dims(200100, 'SNOW') + allocate(scr2d(map%nx,map%ny)) + call get_storage(200100, 'SNOW', scr2d, map%nx, map%ny) + scr2d = scr2d * 2. + call put_storage(200100, 'SNOW', scr2d, map%nx, map%ny) + deallocate(scr2d) + endif + +! compute physical snow depth (SNOWH) for various models +! As of March 2011, this is done here instead of real because we have model +! source information. + if (is_there(200100, 'SNOW') .and. .not. is_there(200100, 'SNOWH')) then + call get_dims(200100, 'SNOW') + allocate(scr2d(map%nx,map%ny)) + call get_storage(200100, 'SNOW', scr2d, map%nx, map%ny) + call mprintf(.true.,DEBUG, & + "RRPR: Computing SNOWH from SNOW") + if ( index(map%source,'NCEP ') .ne. 0) then + scr2d = scr2d * 0.005 ! Assume 200:1 ratio as used at NCEP and in NOAH + else if (index(map%source,'ECMWF') .ne. 0) then + if (is_there(200100, 'SNOW_DEN')) then ! If we have snow density, use it to compute snowh + call get_dims(200100, 'SNOW_DEN') + allocate(tmp2d(map%nx,map%ny)) + call get_storage(200100, 'SNOW_DEN', tmp2d, map%nx, map%ny) + scr2d = scr2d / tmp2d + deallocate(tmp2d) + else + scr2d = scr2d * 0.004 ! otherwise, assume a density of 250 mm/m (i.e. 250:1 ratio). + endif + else ! Other models + scr2d = scr2d * 0.005 ! Use real's default method (200:1) + endif + call put_storage(200100, 'SNOWH', scr2d, map%nx, map%ny) + deallocate(scr2d) + endif + +! As of March 2011, SEAICE can be a flag or a fraction. It will be converted +! to the appropriate values in real depending on whether or not the polar mods are used. + +!! If we've got a SEAICE field, make sure that it is all Zeros and Ones: + +! if (is_there(200100, 'SEAICE')) then +! call get_dims(200100, 'SEAICE') +! call make_zero_or_one(map%nx, map%ny, 'SEAICE') +! endif + +! If we've got an ICEMASK field, re-flag it for output to met_em and real: +! Field | GRIB In | Out +! ------------------------- +! water | 0 | 0 +! land | -1 | 1 +! ice | 1 | 0 + + if (is_there(200100, 'ICEMASK')) then + call get_dims(200100, 'ICEMASK') + call re_flag_ice_mask(map%nx, map%ny) + endif + +! If we have an ICEFRAC field, convert from % to fraction + if (is_there(200100, 'ICEFRAC')) then + call get_dims(200100, 'ICEFRAC') + allocate(scr2d(map%nx,map%ny)) + call get_storage(200100, 'ICEFRAC', scr2d, map%nx, map%ny) + scr2d = scr2d / 100. + call put_storage(200100, 'ICEFRAC', scr2d, map%nx, map%ny) + deallocate(scr2d) + endif + + + call mprintf(.true.,INFORM, & + "RRPR: hdate = %s ",s1=hdate) + call output(hdate, nlvl, maxlvl, plvl, interval, 2, out_format, prefix, debug_level) + call clear_storage + exit FILELOOP + enddo FILELOOP + enddo TIMELOOP +end subroutine rrpr + +subroutine make_zero_or_one(ix, jx, infield) +! Make sure the input field (SEAICE or LANDSEA) is zero or one. + use storage_module + implicit none + integer :: ix, jx + real, dimension(ix,jx) :: seaice + character(len=*) :: infield + + call get_storage(200100, infield, seaice, ix, jx) + where(seaice > 0.5) + seaice = 1.0 + elsewhere + seaice = 0.0 + end where + call put_storage(200100, infield, seaice, ix, jx) +end subroutine make_zero_or_one + +subroutine re_flag_ice_mask(ix, jx) +! +! Change land points from -1 to 1 +! Change ice points from 1 to 0 +! Water points stay at 0 +! + use storage_module + implicit none + integer :: ix, jx + real, dimension(ix,jx) :: iceflag + + call get_storage(200100, 'ICEMASK',iceflag, ix, jx) + where(iceflag > 0.5) ! Ice points, set to water value + iceflag = 0.0 + end where + where(iceflag < -0.5) ! Land points + iceflag = 1.0 + end where + call put_storage(200100, 'ICEMASK',iceflag, ix, jx) +end subroutine re_flag_ice_mask + +subroutine compute_spechumd_qvapor(ix, jx, plvl) +! Compute specific humidity from water vapor mixing ratio. + use storage_module + implicit none + integer :: ix, jx + real :: plvl + real, dimension(ix,jx) :: QVAPOR, SPECHUMD + + call get_storage(nint(plvl), 'QV', QVAPOR, ix, jx) + + SPECHUMD = QVAPOR/(1.+QVAPOR) + + call put_storage(nint(plvl), 'SPECHUMD', spechumd, ix, jx) + if(nint(plvl).eq.1) then + call put_storage(200100,'SPECHUMD', spechumd, ix, jx) + endif + +end subroutine compute_spechumd_qvapor + +subroutine compute_t_vptmp(ix, jx, plvl) +! Compute temperature from virtual potential temperature + use storage_module + implicit none + integer :: ix, jx + real :: plvl + real, dimension(ix,jx) :: T, VPTMP, P, Q + + real, parameter :: rovcp=0.28571 + + call get_storage(nint(plvl), 'VPTMP', VPTMP, ix, jx) + IF (nint(plvl) .LT. 200) THEN + call get_storage(nint(plvl), 'PRESSURE', P, ix, jx) + ELSE + p = plvl + ENDIF + call get_storage(nint(plvl), 'SPECHUMD', Q, ix, jx) + + t=vptmp * (p*1.e-5)**rovcp * (1./(1.+0.6078*Q)) + + call put_storage(nint(plvl), 'TT', t, ix, jx) + if(nint(plvl).eq.1) then + call put_storage(200100, 'PSFC', p, ix, jx) + endif + +end subroutine compute_t_vptmp + + +subroutine compute_rh_spechumd(ix, jx) +! Compute relative humidity from specific humidity. + use storage_module + implicit none + integer :: ix, jx + real, dimension(ix,jx) :: T, P, RH, Q + + real, parameter :: svp1=611.2 + real, parameter :: svp2=17.67 + real, parameter :: svp3=29.65 + real, parameter :: svpt0=273.15 + real, parameter :: eps = 0.622 + + call get_storage(200100, 'TT', T, ix, jx) + call get_storage(200100, 'PSFC', P, ix, jx) + call get_storage(200100, 'SPECHUMD', Q, ix, jx) + + rh = 1.E2 * (p*q/(q*(1.-eps) + eps))/(svp1*exp(svp2*(t-svpt0)/(T-svp3))) + + call put_storage(200100, 'RH', rh, ix, jx) + +end subroutine compute_rh_spechumd + +subroutine compute_rh_spechumd_upa(ix, jx, plvl) +! Compute relative humidity from specific humidity. + use storage_module + implicit none + integer :: ix, jx + real :: plvl + real, dimension(ix,jx) :: T, P, RH, Q + + real, parameter :: svp1=611.2 + real, parameter :: svp2=17.67 + real, parameter :: svp3=29.65 + real, parameter :: svpt0=273.15 + real, parameter :: eps = 0.622 + + IF ( nint(plvl).LT. 200) THEN + if (is_there(nint(plvl), 'PRESSURE')) then + call get_storage(nint(plvl), 'PRESSURE', P, ix, jx) + else + return ! if we don't have pressure on model levels, return + endif + ELSE + P = plvl + ENDIF + call get_storage(nint(plvl), 'TT', T, ix, jx) + call get_storage(nint(plvl), 'SPECHUMD', Q, ix, jx) + Q=MAX(1.E-10,Q) + + rh = 1.E2 * (p*q/(q*(1.-eps) + eps))/(svp1*exp(svp2*(t-svpt0)/(T-svp3))) + + call put_storage(nint(plvl), 'RH', rh, ix, jx) + +end subroutine compute_rh_spechumd_upa + +subroutine compute_rh_vapp_upa(ix, jx, plvl) +! Compute relative humidity from vapor pressure. +! Thanks to Bob Hart of PSU ESSC -- 1999-05-27. + use storage_module + implicit none + integer :: ix, jx + real :: plvl + real, dimension(ix,jx) :: P, ES + real, pointer, dimension(:,:) :: T, E, RH + + real, parameter :: svp1=611.2 + real, parameter :: svp2=17.67 + real, parameter :: svp3=29.65 + real, parameter :: svpt0=273.15 + + allocate(RH(ix,jx)) + + IF ( nint(plvl).LT. 200) THEN + if (is_there(nint(plvl), 'PRESSURE')) then + call get_storage(nint(plvl), 'PRESSURE', P, ix, jx) + else + return ! if we don't have pressure on model levels, return + endif + ELSE + P = plvl + ENDIF + call refr_storage(nint(plvl), 'TT', T, ix, jx) + call refr_storage(nint(plvl), 'VAPP', E, ix, jx) + + ES=svp1*exp(svp2*(T-svpt0)/(T-svp3)) + rh=min(1.E2*(P-ES)*E/((P-E)*ES), 1.E2) + + call refw_storage(nint(plvl), 'RH', rh, ix, jx) + + nullify(T,E) + +end subroutine compute_rh_vapp_upa + +subroutine compute_rh_depr(ix, jx, plvl) +! Compute relative humidity from Dewpoint Depression + use storage_module + implicit none + integer :: ix, jx + real :: plvl + real, dimension(ix,jx) :: t, depr, rh + + real, parameter :: Xlv = 2.5e6 + real, parameter :: Rv = 461.5 + + integer :: i, j + + call get_storage(nint(plvl), 'TT', T, ix, jx) + call get_storage(nint(plvl), 'DEPR', DEPR, ix, jx) + + where(DEPR < 100.) + rh = exp(Xlv/Rv*(1./T - 1./(T-depr))) * 1.E2 + elsewhere + rh = 0.0 + endwhere + + call put_storage(nint(plvl),'RH ', rh, ix, jx) + +end subroutine compute_rh_depr + +subroutine compute_rh_dewpt(ix,jx) +! Compute relative humidity from Dewpoint + use storage_module + implicit none + integer :: ix, jx + real, dimension(ix,jx) :: t, dp, rh + + real, parameter :: Xlv = 2.5e6 + real, parameter :: Rv = 461.5 + + call get_storage(200100, 'TT ', T, ix, jx) + call get_storage(200100, 'DEWPT ', DP, ix, jx) + + rh = exp(Xlv/Rv*(1./T - 1./dp)) * 1.E2 + + call put_storage(200100,'RH ', rh, ix, jx) + +end subroutine compute_rh_dewpt + +subroutine gfs_trop_maxw_pressures(ix,jx) +! These are duplicate pressure values from the GFS, for +! the level of max wind speed and for the trop level. +! The duplicates are saved with a different name, so that +! the metgrid program can horizontally interpolate them to +! the model domain with a nearest neighbor method. + use storage_module + implicit none + integer :: ix, jx + real, dimension(ix,jx) :: pmaxw, pmaxwnn, ptrop, ptropnn + + if ( is_there(200100, 'PMAXW ') ) then + call get_storage(200100, 'PMAXW ', pmaxw , ix, jx) + pmaxwnn = pmaxw + call put_storage(200100, 'PMAXWNN ', pmaxwnn, ix, jx) + end if + + if ( is_there(200100, 'PTROP ') ) then + call get_storage(200100, 'PTROP ', ptrop , ix, jx) + ptropnn = ptrop + call put_storage(200100, 'PTROPNN ', ptropnn, ix, jx) + end if + +end subroutine gfs_trop_maxw_pressures + +subroutine vntrp(plvl, maxlvl, k, k2, interp_type, name, ix, jx) + use storage_module + use module_debug + implicit none + integer :: ix, jx, k, k2, maxlvl + real, dimension(maxlvl) :: plvl + character(len=8) :: name + real, dimension(ix,jx) :: a, b, c + real :: frc + integer :: interp_type + + write(*,'("Interpolating to fill in ", A, " at level ", F8.2, " hPa using levels ", F8.2," hPa and ", & + F8.2," hPa")') trim(name), plvl(k)/100.0,plvl(k-1)/100.0, plvl(k2)/100.0 + call mprintf(.true.,INFORM, & + "RRPR: Interpolating to fill in %s at %i Pa using levels %i Pa and %i Pa",& + s1=trim(name), i1=int(plvl(k)), i2=int(plvl(k-1)), i3=int(plvl(k2))) + + call get_storage(nint(plvl(k-1)), name, a, ix, jx) + call get_storage(nint(plvl(k2)), name, c, ix, jx) + + if ( interp_type == 1 ) then + frc = log(plvl(k)/plvl(k2)) / log(plvl(k-1)/plvl(k2)) + else + frc = (plvl(k) - plvl(k2)) / (plvl(k-1)-plvl(k2)) + endif + + b = (1.-frc)*c + frc*a + +!KWM b = 0.5 * (a + c) + call put_storage(nint(plvl(k)), name, b, ix, jx) + +end subroutine vntrp + + +subroutine fix_gfs_miss (ix, jx, plvl) +! This routine replaces July 2017 GFS missing values with the WPS one. +! Earlier GFS files are unmodified. +! As of 2017, NCEP changed 'ocean' values for masked fields (ST, SM, SNOWH, etc.) +! from 0 to something other than missing. We will assume any large value +! (greater than 10^^18) is a missing code. +! We reset it to the WPS missing value (as set in METGRID.TBL) +! Changes described in http://www.nws.noaa.gov/os/notification/scn17-67gfsupgradeaaa.htm +! plvl must always be 200100. +! While, technically, any 3-d field could have a missing value in it we only deal with +! the surface fields which are known to have missing values. +! + use storage_module + implicit none + integer :: ix, jx, i, j, k + real :: plvl + real, allocatable, dimension(:,:) :: f, sea + integer, parameter :: nvar = 10 + character, dimension(nvar) :: flist*8 + data flist/'ST000010','ST010040','ST040100','ST100200','ST010200', & + 'SM000010','SM010040','SM040100','SM100200','SM010200' / + allocate(sea(ix,jx)) + allocate(f(ix,jx)) +! If LANDN is present (July 2017 and later GFS output), use it for LANDSEA + if ( is_there(200100, 'LANDN') ) then + call get_storage(200100, 'LANDN', sea, ix, jx) + call put_storage(200100, 'LANDSEA', sea, ix, jx) + endif + do k = 1, nvar + if (is_there(200100, flist(k) )) then + call get_storage(nint(plvl), flist(k), f, ix, jx) + do j = 1, jx + do i = 1, ix + if (abs(f(i,j)) .gt. 1.e18) then + f(i,j) = -1.e30 + endif + enddo + enddo +! Limit soil moisture to .468 (should only occur for permanent land ice points +! according to NCEP documentation.) + if (flist(k)(1:2) .eq. 'SM' ) then + do j = 1, jx + do i = 1, ix + if ((f(i,j)) .gt. 0.468) then + f(i,j) = 0.468 + endif + enddo + enddo + endif + call put_storage(200100, flist(k), f, ix, jx) + endif + enddo +! Snow fields have a different WPS missing value and must be adjusted +! separately from the soil fields (unless we want to have an array of missing values,too). + if (is_there(200100, 'SNOW' )) then + call get_storage(200100, 'SNOW', f, ix, jx) + do j = 1, jx + do i = 1, ix + if (abs(f(i,j)) .gt. 1.e18) then + f(i,j) = 0 + endif + enddo + enddo + call put_storage(200100, 'SNOW', f, ix, jx) + endif + if (is_there(200100, 'SNOWH' )) then + call get_storage(200100, 'SNOWH', f, ix, jx) + do j = 1, jx + do i = 1, ix + if (abs(f(i,j)) .gt. 1.e18) then + f(i,j) = 0 + endif + enddo + enddo + call put_storage(200100, 'SNOWH', f, ix, jx) + endif + deallocate (f) + deallocate (sea) +end subroutine fix_gfs_miss + +subroutine fix_gfs_rh (ix, jx, plvl) +! This routine replaces GFS RH (wrt ice) with RH wrt liquid (which is what is assumed in real.exe). + use storage_module + implicit none + integer :: ix, jx, i, j + real :: plvl, eis, ews, r + real, allocatable, dimension(:,:) :: rh, tt + + allocate(rh(ix,jx)) + allocate(tt(ix,jx)) + call get_storage(nint(plvl), 'RH', rh, ix, jx) + call get_storage(nint(plvl), 'TT', tt, ix, jx) + do j = 1, jx + do i = 1, ix + if ( tt(i,j) .le. 273.15 ) then + ! Murphy and Koop 2005 ice saturation vapor pressure. + ! eis and ews in hPA, tt is in K + eis = .01 * exp (9.550426 - (5723.265 / tt(i,j)) + (3.53068 * alog(tt(i,j))) & + - (0.00728332 * tt(i,j))) + ! Bolton 1980 liquid saturation vapor pressure. For water saturation, most + ! formulae are very similar from 0 to -20, so we don't need a more exact formula. + + ews = 6.112 * exp(17.67 * (tt(i,j)-273.15) / ((tt(i,j)-273.15)+243.5)) + if ( tt(i,j) .gt. 253.15 ) then + ! A linear approximation to the GFS blending region ( -20 > T < 0 ) + r = ((273.15 - tt(i,j)) / 20.) + r = (r * eis) + ((1-r)*ews) + else + r = eis + endif + rh(i,j) = rh(i,j) * (r / ews) + endif + enddo + enddo + call put_storage(nint(plvl), 'RH', rh, ix, jx) + deallocate (rh) + deallocate (tt) +end subroutine fix_gfs_rh + + +subroutine fix_ruc_soilm (ix, jx) +! This routine adds residual soil moisture if initialized fron RUC + use storage_module + implicit none + integer :: ix, jx, i, j + REAL , DIMENSION(100) :: lqmi + real, allocatable, dimension(:,:) :: soilm000, soilm005, soilm020, & + soilm040, soilm160, soilm300,soilcat + allocate(soilm000(ix,jx)) + allocate(soilm005(ix,jx)) + allocate(soilm020(ix,jx)) + allocate(soilm040(ix,jx)) + allocate(soilm160(ix,jx)) + allocate(soilm300(ix,jx)) + allocate(soilcat(ix,jx)) + call get_storage(200100, 'SM000ruc', soilm000, ix, jx) + call get_storage(200100, 'SM005ruc', soilm005, ix, jx) + call get_storage(200100, 'SM020ruc', soilm020, ix, jx) + call get_storage(200100, 'SM040ruc', soilm040, ix, jx) + call get_storage(200100, 'SM160ruc', soilm160, ix, jx) + call get_storage(200100, 'SM300ruc', soilm300, ix, jx) + + call get_storage(200100, 'SOILCAT', soilcat, ix, jx) + + lqmi(1:16) = & + (/0.045, 0.057, 0.065, 0.067, 0.034, 0.078, 0.10, & + 0.089, 0.095, 0.10, 0.070, 0.068, 0.078, 0.0, & + 0.004, 0.065 /) + + do j = 1, jx + do i = 1, ix + + SOILM000(i,j)=SOILM000(i,j) + lqmi(nint(soilcat(i,j))) + SOILM005(i,j)=SOILM005(i,j) + lqmi(nint(soilcat(i,j))) + SOILM020(i,j)=SOILM020(i,j) + lqmi(nint(soilcat(i,j))) + SOILM040(i,j)=SOILM040(i,j) + lqmi(nint(soilcat(i,j))) + SOILM160(i,j)=SOILM160(i,j) + lqmi(nint(soilcat(i,j))) + SOILM300(i,j)=SOILM300(i,j) + lqmi(nint(soilcat(i,j))) + enddo + enddo + call put_storage(200100, 'SOILM000', soilm000, ix, jx) + call put_storage(200100, 'SOILM005', soilm005, ix, jx) + call put_storage(200100, 'SOILM020', soilm020, ix, jx) + call put_storage(200100, 'SOILM040', soilm040, ix, jx) + call put_storage(200100, 'SOILM160', soilm160, ix, jx) + call put_storage(200100, 'SOILM300', soilm300, ix, jx) + + print *,'fix_ruc_soilm is done!' + + deallocate(soilm000) + deallocate(soilm005) + deallocate(soilm020) + deallocate(soilm040) + deallocate(soilm160) + deallocate(soilm300) + deallocate(soilcat) + +end subroutine fix_ruc_soilm + + diff --git a/WPS/ungrib/src/swap.F b/WPS/ungrib/src/swap.F new file mode 100644 index 00000000..b2a00f0b --- /dev/null +++ b/WPS/ungrib/src/swap.F @@ -0,0 +1,18 @@ +subroutine swap4(in,nn) +!#if defined (DEC) || defined (ALPHA) || defined (alpha) || defined (LINUX) +#ifdef BYTESWAP +! swaps bytes in groups of 4 to compensate for byte swapping within +! words + implicit none + integer, intent(in) :: nn ! number of bytes to be swapped + logical*1 , dimension(nn) , intent(inout) :: in ! Array to be swapped + + logical*1, dimension(4) :: ia + integer :: i + do i=1,nn,4 + ia = in(i+3:i:-1) + in(i:i+3) = ia + enddo + +#endif +end diff --git a/WPS/ungrib/src/table.F b/WPS/ungrib/src/table.F new file mode 100644 index 00000000..127f09ae --- /dev/null +++ b/WPS/ungrib/src/table.F @@ -0,0 +1,65 @@ +! +! This file contains a module, which is used to pass around information +! from the Vtable from one program component to another +! +module Table + implicit none + +! We have parameterized the maximum number of variables we expect to want to +! read: + integer, parameter :: maxlines=100 + +! Each variable has a name. The names are stored in array NAMVAR. +! Initialize the NAMVAR field to blanks: + character (LEN=9) , dimension(maxlines) :: namvar = ' ' + +! Array DUNITS holds the unit strings for the fields. + character (LEN=25), dimension(maxlines) :: Dunits = ' ' + +! Array DDESC holds the description strings for the fields. + character (LEN=46), dimension(maxlines) :: Ddesc = ' ' + +! Most of the fields are output, but some are not. The names of the +! fields we want to output are stored in NAMEOUT. Initialize the +! NAMEOUT field to blanks: + character (LEN=9) , dimension(maxlines) :: nameout = ' ' + character (LEN=25), dimension(maxlines) :: unitout = ' ' + character (LEN=46), dimension(maxlines) :: descout = ' ' + +! MAXVAR is the count of variables we have read. It is initialized to ZERO. + integer :: maxvar = 0 + +! MAXOUT is the count of the variables we want to output. +! Initialize it to zero. + integer :: maxout = 0 + +! Array GCODE holds the GRIB1 param numbers of the fields we want to access: + integer, dimension(maxlines) :: gcode +! Array LCODE holds the GRIB1 level types of the params we want to access: + integer, dimension(maxlines) :: lcode + +! Array G2_GCODE holds the GRIB2 param numbers of the fields we want to access +! and the GRIB2 level types of the params we want to access: + integer, dimension(5,maxlines) :: g2code + +! Array LEVEL1 holds the Level-1 values of the fields we want: +! If the Vtable has a '*' for the Level-1 value, LEVEL1 has +! the value -99. + integer, dimension(maxlines) :: level1 + +! Array LEVEL2 holds the Level-2 values of the fields we want. +! If LEVEL2 is not needed for a particular field, it is set to +! -99. + integer, dimension(maxlines) :: level2 + +! Array IPRTY holds the priority values of the fields: +! Priorities are used with surface fields, when we have +! encountered the situation where a field may be stored in two different +! ways in a file. Ultimately, the field with the lower priority number +! (i.e., higher priority) is what is output. + integer, dimension(maxlines) :: iprty + + integer :: blankcode = -99 + integer :: splatcode = -88 + +end module Table diff --git a/WPS/ungrib/src/ungrib.F b/WPS/ungrib/src/ungrib.F new file mode 100644 index 00000000..9dd7ed75 --- /dev/null +++ b/WPS/ungrib/src/ungrib.F @@ -0,0 +1,419 @@ +!*****************************************************************************! +! program ungrib ! +! ! +! Questions, comments, suggestions, even complaints should be directed to: ! +! wrfhelp@ucar.edu ! +! Externals: ! +! Module TABLE ! +! Module GRIDINFO ! +! Module FILELIST ! +! Subroutine READ_NAMELIST ! +! Subroutine PARSE_TABLE ! +! Subroutine CLEAR_STORAGE ! +! Subroutine RD_GRIB ! +! Subroutine RD_GRIB2 ! +! Subroutine PUT_STORAGE ! +! Subroutine OUTPUT ! +! Subroutine C_CLOSE ! +! Subroutine RRPR ! +! Subroutine DATINT ! +! Subroutine FILE_DELETE ! +! ! +! Kevin W. Manning, NCAR/MMM - original 'pregrid' code, 1998-2001 ! +! Jim Bresch, Michael Duda, Dave Gill, NCAR/MMM - adapted for WPS, 2006 ! +! ! +!*****************************************************************************! +! ! +!*****************************************************************************! +! ! +! This program reads GRIB-formatted data and puts it into intermediate format ! +! for passing data to a horizontal interpolation program. The intermediate ! +! format can be for WPS, SI, or MM5. ! +! ! +! The program tries to read from files called "GRIBFILE.AAA", "GRIBFILE.AAB", ! +! "GRIBFILE.AAC", ... "GRIBFILE.ABA", "GRIBFILE.ABB", ... "GRIBFILE.ZZZ" until! +! it cannot find a file. This naming format allows for up to 17576 files, ! +! which should be enough for most applications. ! +! ! +! The program searches through those "GRIBFILE.???" files, and pulls out all ! +! the requested fields which fall between a starting date and an ending date. ! +! It writes the fields from a given time period to a file named according to ! +! the date and hour, i.e., "FILE:YYYY-MM-DD_HH" ! +! ! +!*****************************************************************************! +program ungrib + + use table + use gridinfo + use storage_module + use filelist + use datarray + use module_debug + use misc_definitions_module + use stringutil + + implicit none + + interface + subroutine read_namelist(hstart, hend, delta_time, ntimes,& + ordered_by_date, debug_level, out_format, prefix, & + add_lvls, new_plvl, interp_type) + + use misc_definitions_module + + character(len=19) :: hstart, hend + integer :: delta_time + integer :: ntimes + logical :: ordered_by_date + integer :: debug_level + character(len=3) :: out_format + character(len=MAX_FILENAME_LEN) :: prefix + logical :: add_lvls + real, dimension(:) :: new_plvl + integer :: interp_type + end subroutine read_namelist + end interface + + integer :: nunit1 = 12 + character(LEN=132) :: gribflnm = 'GRIBFILE.AAA ' ! won't work with len=12 + + integer :: debug_level + + integer , parameter :: maxlvl = 250 + + real , dimension(maxlvl) :: plvl, new_plvl + integer :: iplvl + logical :: add_lvls + integer :: interp_type + + integer :: nlvl + + real :: startlat, startlon, deltalat, deltalon + real :: level + character (LEN=9) :: field + character (LEN=3) :: out_format + character (LEN=MAX_FILENAME_LEN) :: prefix + + logical :: readit + + integer, dimension(255) :: iuarr = 0 + + character (LEN=19) :: HSTART, HEND, HDATE + character(LEN=19) :: hsave = '0000-00-00_00:00:00' + integer :: itime + integer :: ntimes + integer :: interval + integer :: ierr + logical :: ordered_by_date + integer :: grib_version + integer :: vtable_columns + + + call mprintf(.true.,STDOUT,' *** Starting program ungrib.exe *** ') + call mprintf(.true.,LOGFILE,' *** Starting program ungrib.exe *** ') +! ----------------- +! Read the namelist, and return the information we want: + + call read_namelist(hstart, hend, interval, ntimes, & + ordered_by_date, debug_level, out_format, prefix, & + add_lvls, new_plvl, interp_type) + + call mprintf(.true.,INFORM,"Interval value: %i seconds or %f hours", & + i1=interval, f1=float(interval)/3600.) + + call mprintf(.true.,STDOUT,'Path to intermediate files is %s',s1=get_path(prefix)) + call mprintf(.true.,LOGFILE,'Path to intermediate files is %s',s1=get_path(prefix)) + +! ----------------- +! Determine GRIB Edition number + grib_version=0 + call edition_num(nunit1, gribflnm, grib_version, ierr) + call mprintf((ierr.eq.3),ERROR,"GRIB file problem") + if (grib_version.eq.2) then + vtable_columns=12 +#if defined (USE_PNG) && (USE_JPEG2000) + call mprintf(.true.,INFORM, & + "Linked in png and jpeg libraries for Grib Edition 2") +#else + call mprintf(.true.,STDOUT,"WARNING - Grib Edition 2 data detected, and") + call mprintf(.true.,STDOUT," - png and jpeg libs were NOT selected") + call mprintf(.true.,STDOUT," - during the build.") + call mprintf(.true.,STDOUT,"Stopping") + call mprintf(.true.,LOGFILE,"WARNING - Grib Edition 2 data detected, and") + call mprintf(.true.,LOGFILE," - png and jpeg libs were NOT selected") + call mprintf(.true.,LOGFILE," - during the build.") + call mprintf(.true.,LOGFILE,"Stopping") + call mprintf(.true.,ERROR,"NEED_GRIB2_LIBS") +#endif + else + vtable_columns=7 + endif + call mprintf(.true.,INFORM,"Reading Grib Edition %i", i1=grib_version) + +! ----------------- +! Read the "Vtable" file, and put the information contained therein into +! the module "table". + + call parse_table(debug_level,vtable_columns) + + call mprintf(.true.,DEBUG,"Parsed the vtable.") + +! ----------------- +! Initialize the input filename to GRIBFILE.AA{character just before A} +! That way, when we update the filename below for the first time, it will +! have the correct value of GRIBFILE.AAA. + + gribflnm(12:12)=char(ichar(gribflnm(12:12))-1) + +! ----------------- +! LOOP2 cycles through the list of files named GRIBFILE.???, until it finds +! a non-existent file. Then we exit + + LOOP2 : DO + + ! At the beginning of LOOP2 update the input filename. + if (gribflnm(12:12).eq.'Z') then + if (gribflnm(11:11).eq.'Z') then + gribflnm(10:10) = char(ichar(gribflnm(10:10))+1) + gribflnm(11:11) = 'A' + else + gribflnm(11:11) = char(ichar(gribflnm(11:11))+1) + endif + gribflnm(12:12) = 'A' + else + gribflnm(12:12) = char(ichar(gribflnm(12:12))+1) + endif + + ! Set READIT to .TRUE., meaning that we have not read any records yet + ! from the file GRIBFLNM. + + call mprintf(.true.,DEBUG,"Reading from gribflnm %s ",s1=gribflnm) + + readit = .TRUE. ! i.e., "Yes, we want to read a record." + + +! LOOP1 reads through the file GRIBFLNM, exiting under two conditions: +! 1) We have hit the end-of-file +! 2) We have read past the ending date HEND. +! +! Condition 2 assumes that the data in file GRIBFLNM are ordered in time. + + LOOP1 : DO + ! At the beginning of LOOP1, we are at a new time period. + ! Clear the storage arrays and associated level information. + nlvl = 0 + plvl = -999. + call clear_storage + +! LOOP0 reads through the file GRIBFLNM, looking for data of the current +! date. It exits under the following conditions. +! 1) We have hit the end-of-file +! 2) The GRIBFLNM variable has been updated to a nonexistent file. +! 3) We start reading a new date and the data are assumed to be +! ordered by date. +! 4) We have a valid record and the data are not assumed to be +! ordered by date. + + LOOP0 : DO + + ! If we need to read a new grib record, then read one. + if (READIT) then + + if (grib_version.ne.2) then + call mprintf(.true.,DEBUG, & + "Calling rd_grib1 with iunit %i", i1=nunit1) + call mprintf(.true.,DEBUG, & + "flnm = %s",s1=gribflnm) + ! Read one record at a time from GRIB1 (and older Editions) + call rd_grib1(nunit1, gribflnm, level, field, & + hdate, ierr, iuarr, debug_level) + else + + ! Read one file of records from GRIB2. + call mprintf(.true.,DEBUG,"Calling rd_grib2") + call rd_grib2(nunit1, gribflnm, hdate, & + grib_version, ierr, debug_level) + FIELD='NULL' + + endif + + call mprintf(.true.,DEBUG,"ierr = %i ",i1=ierr) + if (ierr.eq.1) then + ! We have hit the end of a file. Exit LOOP0 so we can + ! write output for date HDATE, and then exit LOOP1 + ! to update the GRIBFLNM + hsave = hdate + exit LOOP0 + endif + + if (ierr.eq.2) then + ! We have hit the end of all the files. We can exit LOOP2 + ! because there are no more files to read. + exit LOOP2 + endif + + call mprintf(.true.,DEBUG, & + "Read a record %s with date %s", s1=field,s2=hdate(1:13)) + + endif + + call mprintf(.true.,DEBUG, & + "hdate = %s , hsave = %s ",s1=hdate(1:13), s2=hsave(1:13) ) + +! if (hdate < hstart) then +! ! The data read has a date HDATE earlier than the starting +! ! date HSTART. So cycle LOOP0 to read the the next GRIB record. +! READIT = .TRUE. +! cycle LOOP0 +! endif + + if (FIELD.EQ.'NULL') then + ! The data read does not match any fields requested + ! in the Vtable. So cycle LOOP0 to read the next GRIB record. + READIT = .TRUE. + cycle LOOP0 + endif + + if (ordered_by_date .and. (hdate > hsave)) then + + ! Exit LOOP0, because we started to read data from another + ! date. + + call mprintf(.true.,DEBUG, & + "hdate %s > hsave %s so exit LOOP0",s1=hdate,s2=hsave) + + ! We set READIT to FALSE because we have not yet processed + ! the data from this record, and we will want to process this + ! data on the next pass of LOOP1 (referring to the next time + ! period of interest. + + READIT = .FALSE. + + exit LOOP0 + + endif + +! When we have reached this point, we have a data array ARRAY which has +! some data we want to save, with field name FIELD at pressure level +! LEVEL (Pa). Dimensions of this data are map%nx and map%ny. Put +! this data into storage. + + if (((field == "SST").or.(field == "SKINTEMP")) .and. & + (level /= 200100.)) level = 200100. + iplvl = int(level) + call mprintf((.not.allocated(rdatarray)),ERROR, & + "GRIB data slab not allocated in ungrib.F before call to put_storage.") + call put_storage(iplvl,field, & + reshape(rdatarray(1:map%nx*map%ny),(/map%nx, map%ny/)),& + map%nx,map%ny) + deallocate(rdatarray) + + ! Since we processed the record we just read, we set + ! READIT to .TRUE. so that LOOP0 will read the next record. + READIT = .TRUE. + + if (.not. ordered_by_date) then + if (hdate >= hstart) then + hsave = hdate + endif + exit LOOP0 + endif + + enddo LOOP0 + +! When we have reached this point, we have either hit the end of file, or +! hit the end of the current date. Either way, we want to output +! the data found for this date. This current date is in HSAVE. +! However, if (HSAVE == 0000-00-00_00:00:00), no output is necessary, +! because that 0000 date is the flag for the very opening of a file. + + if ((hsave(1:4).ne.'0000').and.(hsave.le.hend)) then + if (debug_level .gt. 100) then + print*, 'Calling output: '//hsave(1:13) + call mprintf(.true.,DEBUG,"Calling output: %s ",s1=hsave(1:13)) + endif + call output(hsave, nlvl, maxlvl, plvl, interval, 1, out_format, prefix, debug_level) + hsave=hdate + + ! If the next record we process has a date later than HEND, + ! then time to exit LOOP1. + if ((ordered_by_date) .and. (hdate.gt.hend)) exit LOOP1 + + else + hsave = hdate + endif + + ! If we hit the end-of-file, its time to exit LOOP1 so we can + ! increment the GRIBFLNM to read the next file. + if (ierr.eq.1) exit LOOP1 + + enddo LOOP1 + +! When we have reached this point, we read all the data we want to from +! file GRIBFLNM (either because we reached the end-of-file, or we +! read past the date HEND). So we close the file and cycle LOOP2 to read +! the next file. + + if (grib_version.ne.2) then + call c_close(iuarr(nunit1), debug_level, ierr) + iuarr(nunit1) = 0 + endif + hsave = '0000-00-00_00:00:00' + + enddo LOOP2 + +! Now Reread, process, and reoutput. + + call mprintf(.true.,INFORM,"First pass done, doing a reprocess") + + call rrpr(hstart, ntimes, interval, nlvl, maxlvl, plvl, & + add_lvls, new_plvl, interp_type, & + debug_level, out_format, prefix) + +! Make sure the filedates are in order, with an inefficient sort: + + call sort_filedates + +! Interpolate temporally to fill in missing times: + + call datint(filedates, nfiles, hstart, ntimes, interval, out_format, prefix) + +! Now delete the temporary files: + + call file_delete(filedates, nfiles, trim(get_path(prefix))//'PFILE:', interval) + +! And Now we are done: + + call mprintf(.true.,STDOUT,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!') + call mprintf(.true.,STDOUT,'! Successful completion of ungrib. !') +! call mprintf(.true.,STDOUT,"! We're hauling gear at Bandimere. !") + call mprintf(.true.,STDOUT,'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!') + + call mprintf(.true.,LOGFILE,' *** Successful completion of program ungrib.exe *** ') + + + +contains + subroutine sort_filedates + implicit none + + integer :: n + logical :: done + if (nfiles > 1) then + done = .FALSE. + do while ( .not. done) + done = .TRUE. + do n = 1, nfiles-1 + if (filedates(n) > filedates(n+1)) then + filedates(size(filedates)) = filedates(n) + filedates(n) = filedates(n+1) + filedates(n+1) = filedates(size(filedates)) + filedates(size(filedates)) = '0000-00-00 00:00:00.0000' + done = .FALSE. + endif + enddo + enddo + endif + end subroutine sort_filedates + +end program ungrib diff --git a/WPS/util/.gitignore b/WPS/util/.gitignore new file mode 100644 index 00000000..5683bf50 --- /dev/null +++ b/WPS/util/.gitignore @@ -0,0 +1,8 @@ +avg_tsfc.exe +calc_ecmwf_p.exe +g1print.exe +g2print.exe +height_ukmo.exe +int2nc.exe +mod_levs.exe +rd_intermediate.exe diff --git a/WPS/util/Makefile b/WPS/util/Makefile new file mode 100644 index 00000000..684a39e7 --- /dev/null +++ b/WPS/util/Makefile @@ -0,0 +1,48 @@ +# WPS component makefile + +include ../configure.wps + +bad_idea: + clear ; + @echo " " + @echo " " + @echo "go up a directory and type 'compile' to build WPS" + @echo " " + @echo " " + +all: + ( cd src ; \ + if [ "$(COMPILING_ON_CYGWIN_NT)" = yes ] ; then \ + WRF_DIR2=$(WRF_DIR) ; \ + else \ + WRF_DIR2=$(WRF_DIR_PRE)$(WRF_DIR) ; \ + fi ; \ + $(MAKE) $(TARGET) \ + WRF_DIR="$$WRF_DIR2" \ + FC="$(FC)" \ + CC="$(CC)" \ + CPP="$(CPP)" \ + FFLAGS="$(FFLAGS)" \ + CFLAGS="$(CFLAGS)" \ + LDFLAGS="$(LDFLAGS)" \ + CPPFLAGS="$(CPPFLAGS) -D_$(CPP_TARGET)" ) + if [ -h $(TARGET) ] ; then \ + $(RM) $(TARGET) ; \ + fi ; \ + if [ -h ../$(TARGET) ] ; then \ + $(RM) ../$(TARGET) ; \ + fi ; \ + if [ -e src/$(TARGET) ] ; then \ + $(LN) src/$(TARGET) . ; \ + fi + +clean: + if [ -h $(TARGET) ] ; then \ + $(RM) $(TARGET) ; \ + fi + if [ -h ../$(TARGET) ] ; then \ + $(RM) ../$(TARGET) ; \ + fi + ( cd src ; $(MAKE) clean ) + +superclean: clean diff --git a/WPS/util/gfs.ncl b/WPS/util/gfs.ncl new file mode 100644 index 00000000..0ce26559 --- /dev/null +++ b/WPS/util/gfs.ncl @@ -0,0 +1,157 @@ +;*************************************************************************************************************** +; This is a sample NCL script to process GRIB data, plot surface variable (SKINTEMP and MSLP) and upper-air +; variables (U, V, T, RH) in pressure level. +; +;************************************************************************************************************** +; +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +begin + grb_file = addfile( "gfs_150416_12_00.grb","r") + names = getfilevarnames(grb_file) ; Get the variable names in the + print(names) ; GRIB file and print them out. + +; atts = getfilevaratts(grb_file,names(0)) ; Get the variable attributes and +; dims = getfilevardims(grb_file,names(0)) ; dimension names from the GRIB + pres= grb_file->lv_ISBL0 + npres=dimsizes(pres) + presRH= grb_file->lv_ISBL6 + npresRH=dimsizes(presRH) + soil= grb_file->lv_DBLL10_l0 + nsoil=dimsizes(soil) + wks = gsn_open_wks("x11","gfs") ; Open an X11 workstation. + gsn_define_colormap(wks,"wh-bl-gr-ye-re") + +;----------- MCHEN Begin plot ----------------------------------------- + resources = True + resources@cnFillOn = True ; turn on color + resources@cnLinesOn = False ; no contour lines + resources@gsnSpreadColors = True ; use full color map + resources@lbLabelAutoStride = True ; every other label + resources@cnLevelSelectionMode = "ManualLevels" ; manual levels + + do i = 0,dimsizes(names)-1 + names_char = stringtochar(names(i)) +; PMSL + if(names(i).eq."PRMSL_P0_L101_GLL0") then + MSLP = grb_file->PRMSL_P0_L101_GLL0 + if(isatt(MSLP,"units").eq.True) + resources@tiMainString = "MSLP ( " + MSLP@units + ")" + else + resources@tiMainString = "PRMSL_P0_L101_GLL0" + end if + plot = gsn_csm_contour_map_ce(wks,MSLP,resources) + end if +; SKINTEMP + if(names(i).eq."TMP_P0_L1_GLL0") then + SKINTEMP = grb_file->TMP_P0_L1_GLL0 + if(isatt(SKINTEMP,"units").eq.True) + resources@tiMainString = "SKINTEMP ( " + SKINTEMP@units + ")" + else + resources@tiMainString = "TMP_P0_L1_GLL0" + end if + plot = gsn_csm_contour_map_ce(wks,SKINTEMP,resources) + end if +; T2 + if(names(i).eq."TMP_P0_L103_GLL0") then + T2 = grb_file->TMP_P0_L103_GLL0 + if(isatt(T2,"units").eq.True) + resources@tiMainString = "T2 (" + T2@units + ")" + else + resources@tiMainString = "TMP_P0_L103_GLL0" + end if + plot = gsn_csm_contour_map_ce(wks,T2(0,:,:),resources) + end if +; U10 + if(names(i).eq."UGRD_P0_L103_GLL0") then + U10 = grb_file->UGRD_P0_L103_GLL0 + if(isatt(T2,"units").eq.True) + resources@tiMainString = "U10 (" + U10@units + ")" + else + resources@tiMainString = "UGRD_P0_L103_GLL0" + end if + plot = gsn_csm_contour_map_ce(wks,U10(0,:,:),resources) + end if +; V10 + if(names(i).eq."VGRD_P0_L103_GLL0") then + V10 = grb_file->VGRD_P0_L103_GLL0 + if(isatt(T2,"units").eq.True) + resources@tiMainString = "V10,UNIT: " + V10@units + ")" + else + resources@tiMainString = "VGRD_P0_L103_GLL0" + end if + plot = gsn_csm_contour_map_ce(wks,V10(0,:,:),resources) + end if +; SOILM in 4 levels + if(names(i).eq."SOILW_P0_2L106_GLL0") then + SOILM = grb_file->SOILW_P0_2L106_GLL0 + if(isatt(SOILM,"units").eq.True) + MainString = "SOILM, UNIT:" + SOILM@units + ")" + end if + do nlev=0,nsoil-1 + resources@tiMainString = MainString + " At " + soil(nlev) + " m" + plot = gsn_csm_contour_map_ce(wks,SOILM(nlev,:,:),resources) + end do + end if +; SOILT in 4 levels + if(names(i).eq."TMP_P0_2L106_GLL0") then + SOILT = grb_file->TMP_P0_2L106_GLL0 + if(isatt(SOILT,"units").eq.True) + MainString = "SOILT (" + SOILT@units + ")" + end if + do nlev=0,nsoil-1 + resources@tiMainString = MainString + " At " + soil(nlev) + " m" + plot = gsn_csm_contour_map_ce(wks,SOILT(nlev,:,:),resources) + end do + end if +; T in Pres Level + ; if(names_char(0:15).eq."TMP_P0_L100_GLL0") then + if(names(i).eq."TMP_P0_L100_GLL0") then + T = grb_file->TMP_P0_L100_GLL0 + if(isatt(T,"units").eq.True) + MainString = "TEMPERATURE ( " + T@units + ")" + end if + do nlev=0,npres-1 + resources@tiMainString = MainString + " At " + pres(nlev)/100 +"hpa" + plot = gsn_csm_contour_map_ce(wks,T(nlev,:,:),resources) + end do + end if +; RH in Pres Level + ; if(names_char(0:14).eq."RH_P0_L100_GLL0") then + if(names(i).eq."RH_P0_L100_GLL0") then + RH = grb_file->RH_P0_L100_GLL0 + if(isatt(RH,"units").eq.True) + MainString = "RH (" + RH@units + ")" + end if + do nlev=0,npresRH-1 + resources@tiMainString = MainString + " At " + presRH(nlev)/100 +"hpa" + plot = gsn_csm_contour_map_ce(wks,RH(nlev,:,:),resources) + end do + end if +; UGRD in pressure + ; if(names_char(0:16).eq."UGRD_P0_L100_GLL0") then + if(names(i).eq."UGRD_P0_L100_GLL0") then + U = grb_file->UGRD_P0_L100_GLL0 + if(isatt(U,"units").eq.True) + MainString = "U ( " + U@units + ")" + end if + do nlev=0,npres-1 + resources@tiMainString = MainString + " At " + pres(nlev)/100 +"hpa" + plot = gsn_csm_contour_map_ce(wks,U(nlev,:,:),resources) + end do + end if +; VGRD in pressure + ; if(names_char(0:11).eq."VGRD_P0_L100") then + if(names(i).eq."VGRD_P0_L100_GLL0") then + V = grb_file->VGRD_P0_L100_GLL0 + if(isatt(V,"units").eq.True) + MainString = "V ( " + V@units + ")" + end if + do nlev=0,npres-1 + resources@tiMainString = MainString + " At " + pres(nlev)/100 +"hpa" + plot = gsn_csm_contour_map_ce(wks,V(nlev,:,:),resources) + end do + end if + delete(names_char) + end do +end diff --git a/WPS/util/gfs_old.ncl b/WPS/util/gfs_old.ncl new file mode 100644 index 00000000..cb86d3c4 --- /dev/null +++ b/WPS/util/gfs_old.ncl @@ -0,0 +1,157 @@ +;*************************************************************************************************************** +; This is a sample NCL script to process GRIB data, plot surface variable (SKINTEMP and MSLP) and upper-air +; variables (U, V, T, RH) in pressure level. +; +;************************************************************************************************************** +; +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +begin + grb_file = addfile( "gfs_2010042700_12.grib2","r") + names = getfilevarnames(grb_file) ; Get the variable names in the + print(names) ; GRIB file and print them out. + +; atts = getfilevaratts(grb_file,names(0)) ; Get the variable attributes and +; dims = getfilevardims(grb_file,names(0)) ; dimension names from the GRIB + pres= grb_file->lv_ISBL0 + npres=dimsizes(pres) + presRH= grb_file->lv_ISBL6 + npresRH=dimsizes(presRH) + soil= grb_file->lv_DBLL2_l1 + nsoil=dimsizes(soil) + + wks = gsn_open_wks("pdf","gfs") ; Open an X11 workstation. + +;----------- MCHEN Begin plot ----------------------------------------- + resources = True + resources@cnFillOn = True ; turn on color + resources@cnLinesOn = False ; no contour lines + resources@gsnSpreadColors = True ; use full color map + resources@lbLabelAutoStride = True ; every other label + resources@cnLevelSelectionMode = "ManualLevels" ; manual levels + + do i = 0,dimsizes(names)-1 + names_char = stringtochar(names(i)) +; PMSL + if(names(i).eq."PRMSL_P0_L101_GLL0") then + MSLP = grb_file->PRMSL_P0_L101_GLL0 + if(isatt(MSLP,"units").eq.True) + resources@tiMainString = "MSLP ( " + MSLP@units + ")" + else + resources@tiMainString = "PRMSL_P0_L101_GLL0" + end if + plot = gsn_csm_contour_map_ce(wks,MSLP,resources) + end if +; SKINTEMP + if(names(i).eq."TMP_P0_L1_GLL0") then + SKINTEMP = grb_file->TMP_P0_L1_GLL0 + if(isatt(SKINTEMP,"units").eq.True) + resources@tiMainString = "SKINTEMP ( " + SKINTEMP@units + ")" + else + resources@tiMainString = "TMP_P0_L1_GLL0" + end if + plot = gsn_csm_contour_map_ce(wks,SKINTEMP,resources) + end if +; T2 + if(names(i).eq."TMP_P0_L103_GLL0") then + T2 = grb_file->TMP_P0_L103_GLL0 + if(isatt(T2,"units").eq.True) + resources@tiMainString = "T2 (" + T2@units + ")" + else + resources@tiMainString = "TMP_P0_L103_GLL0" + end if + plot = gsn_csm_contour_map_ce(wks,T2,resources) + end if +; U10 + if(names(i).eq."UGRD_P0_L103_GLL0") then + U10 = grb_file->UGRD_P0_L103_GLL0 + if(isatt(T2,"units").eq.True) + resources@tiMainString = "U10 (" + U10@units + ")" + else + resources@tiMainString = "UGRD_P0_L103_GLL0" + end if + plot = gsn_csm_contour_map_ce(wks,U10,resources) + end if +; V10 + if(names(i).eq."VGRD_P0_L103_GLL0") then + V10 = grb_file->VGRD_P0_L103_GLL0 + if(isatt(T2,"units").eq.True) + resources@tiMainString = "V10,UNIT: " + V10@units + ")" + else + resources@tiMainString = "VGRD_P0_L103_GLL0" + end if + plot = gsn_csm_contour_map_ce(wks,V10,resources) + end if +; SOILM in 4 levels + if(names(i).eq."SOILW_P0_2L106_GLL0") then + SOILM = grb_file->SOILW_P0_2L106_GLL0 + if(isatt(SOILM,"units").eq.True) + MainString = "SOILM, UNIT:" + SOILM@units + ")" + end if + do nlev=0,nsoil-1 + resources@tiMainString = MainString + " At " + soil(nlev) + " m" + plot = gsn_csm_contour_map_ce(wks,SOILM(nlev,:,:),resources) + end do + end if +; SOILT in 4 levels + if(names(i).eq."TMP_P0_2L106_GLL0") then + SOILT = grb_file->TMP_P0_2L106_GLL0 + if(isatt(SOILT,"units").eq.True) + MainString = "SOILT (" + SOILT@units + ")" + end if + do nlev=0,nsoil-1 + resources@tiMainString = MainString + " At " + soil(nlev) + " m" + plot = gsn_csm_contour_map_ce(wks,SOILT(nlev,:,:),resources) + end do + end if +; T in Pres Level + ; if(names_char(0:15).eq."TMP_P0_L100_GLL0") then + if(names(i).eq."TMP_P0_L100_GLL0") then + T = grb_file->TMP_P0_L100_GLL0 + if(isatt(T,"units").eq.True) + MainString = "TEMPERATURE ( " + T@units + ")" + end if + do nlev=0,npres-1 + resources@tiMainString = MainString + " At " + pres(nlev)/100 +"hpa" + plot = gsn_csm_contour_map_ce(wks,T(nlev,:,:),resources) + end do + end if +; RH in Pres Level + ; if(names_char(0:14).eq."RH_P0_L100_GLL0") then + if(names(i).eq."RH_P0_L100_GLL0") then + RH = grb_file->RH_P0_L100_GLL0 + if(isatt(RH,"units").eq.True) + MainString = "RH (" + RH@units + ")" + end if + do nlev=0,npresRH-1 + resources@tiMainString = MainString + " At " + presRH(nlev)/100 +"hpa" + plot = gsn_csm_contour_map_ce(wks,RH(nlev,:,:),resources) + end do + end if +; UGRD in pressure + ; if(names_char(0:16).eq."UGRD_P0_L100_GLL0") then + if(names(i).eq."UGRD_P0_L100_GLL0") then + U = grb_file->UGRD_P0_L100_GLL0 + if(isatt(U,"units").eq.True) + MainString = "U ( " + U@units + ")" + end if + do nlev=0,npres-1 + resources@tiMainString = MainString + " At " + pres(nlev)/100 +"hpa" + plot = gsn_csm_contour_map_ce(wks,U(nlev,:,:),resources) + end do + end if +; VGRD in pressure + ; if(names_char(0:11).eq."VGRD_P0_L100") then + if(names(i).eq."VGRD_P0_L100_GLL0") then + V = grb_file->VGRD_P0_L100_GLL0 + if(isatt(V,"units").eq.True) + MainString = "V ( " + V@units + ")" + end if + do nlev=0,npres-1 + resources@tiMainString = MainString + " At " + pres(nlev)/100 +"hpa" + plot = gsn_csm_contour_map_ce(wks,V(nlev,:,:),resources) + end do + end if + delete(names_char) + end do +end diff --git a/WPS/util/plotfmt.ncl b/WPS/util/plotfmt.ncl new file mode 100644 index 00000000..8502cdc7 --- /dev/null +++ b/WPS/util/plotfmt.ncl @@ -0,0 +1,215 @@ +;_______________________________________________________________________________________ +;To run the script type: +; ncl plotfmt.ncl {input file} +; +; e.g. +; ncl plotfmt.ncl 'filename="FILE:2005-06-01_00"' +; +; +; This script can only be used in NCL V6.2 or later!!!!! +;_______________________________________________________________________________________ + +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" + +begin + +; Make sure we have a datafile to work with + if (.not. isvar("filename") ) then + print(" ") + print(" ### MUST SUPPLY a filename ### ") + print(" ") + print(" Something like: ") + print(" ncl plotfmt.ncl filename=FILE:2005-06-01_00") + print(" REMEMBER TO ADD QUOTES" ) + print(" Refer to the information at the top of this file for more info and syntax" ) + exit + end if + + head_real = new(14,float) + field = new(1,string) + hdate = new(1,string) + units = new(1,string) + map_source = new(1,string) + desc = new(1,string) + +; We generate plots, but what kind do we prefer? + type = "x11" +; type = "pdf" +; type = "ps" +; type = "ncgm" + + outf = "plotfmt_bin" + wks = gsn_open_wks(type,outf) + + res = True + res@cnFillOn = True + + ;Open binary file + + istatus = wrf_wps_open_int(filename) + + if(istatus.eq.0) then + + ;Read header of file + wrf_wps_rdhead_int(istatus,head_real,field,hdate, \ + units,map_source,desc) + + do while (istatus.eq.0) + + version = toint(head_real(0)) + xfcst = head_real(1) + xlvl = head_real(2) + nx = toint(head_real(3)) + ny = toint(head_real(4)) + iproj = toint(head_real(5)) + print("==================================================") + print("VAR = " + field + "__" + xlvl ) + + lat0 = head_real(6) + lon0 = head_real(7) + + print("hdate = '" + hdate + "'") + print("units = '" + units + "'") + print("desc = '" + desc + "'") + print("field = '" + field + "'") + print("map_source = '" + map_source + "'") + print("version = " + version) + print("xfcst = " + xfcst) + print("xlvl = " + xlvl) + print("nx/ny = " + nx + "/" + ny ) + print("iproj = " + iproj) + print("lat0/lon0 = " + lat0 + "/" + lon0) + print("head_real(8) = " + head_real(8)) + print("head_real(9) = " + head_real(9)) + print("head_real(10) = " + head_real(10)) + print("head_real(11) = " + head_real(11)) + print("head_real(12) = " + head_real(12)) + print("head_real(13) = " + head_real(13)) + + + if (iproj.eq.0) then ;Cylindrical Equidistant + lat = lat0 + ispan(0,ny-1,1)*head_real(8) + lon = lon0 + ispan(0,nx-1,1)*head_real(9) +;---Turn these into 1D coordinate arrays + lat!0 = "lat" + lon!0 = "lon" + lon@units = "degrees_east" + lat@units = "degrees_north" + lat&lat = lat + lon&lon = lon + end if + + if (iproj.eq.1) then ; Mercator + dx = head_real(8) + dy = head_real(9) + truelat1 = head_real(10) + res1 = True + res1@MAP_PROJ = 3 + res1@TRUELAT1 = truelat1 + res1@DX = dx*1000. + res1@DY = dy*1000. + res1@REF_LAT = lat0 + res1@REF_LON = lon0 + res1@POLE_LAT = 90.0 + res1@POLE_LON = 0.0 + res1@LATINC = 0.0 + res1@LONINC = 0.0 + res1@KNOWNI = 1.0 + res1@KNOWNJ = 1.0 + loc = wrf_ij_to_ll (nx,ny,res1) + + res@gsnAddCyclic = False + res@mpLimitMode = "Corners" + res@mpLeftCornerLatF = lat0 + res@mpLeftCornerLonF = lon0 + res@mpRightCornerLatF = loc(1) + res@mpRightCornerLonF = loc(0) + res@tfDoNDCOverlay = True + res@mpProjection = "mercator" + end if + + if (iproj.eq.3) then ; Lambert Conformal + dx = head_real(8) + dy = head_real(9) + xlonc = head_real(10) + truelat1 = head_real(11) + truelat2 = head_real(12) + res1 = True + res1@MAP_PROJ = 1 + res1@TRUELAT1 = truelat1 + res1@TRUELAT2 = truelat2 + res1@STAND_LON = xlonc + res1@DX = dx*1000. + res1@DY = dy*1000. + res1@REF_LAT = lat0 + res1@REF_LON = lon0 + res1@POLE_LAT = 90.0 + res1@POLE_LON = 0.0 + res1@LATINC = 0.0 + res1@LONINC = 0.0 + res1@KNOWNI = 1.0 + res1@KNOWNJ = 1.0 + loc = wrf_ij_to_ll (nx,ny,res1) + + res@gsnAddCyclic = False + res@mpLimitMode = "Corners" + res@mpLeftCornerLatF = lat0 + res@mpLeftCornerLonF = lon0 + res@mpRightCornerLatF = loc(1) + res@mpRightCornerLonF = loc(0) + res@tfDoNDCOverlay = True + res@mpProjection = "LambertConformal" + res@mpLambertParallel1F = truelat1 + res@mpLambertParallel2F = truelat2 + res@mpLambertMeridianF = xlonc + end if + + if (iproj.eq.4) then ;Gaussian + nlats = head_real(8) + deltalon = head_real(9) + deltalat = 2.*(lat0)/(2.*nlats-1) + if (lat0 .ge. 80.) then + deltalat = -1.0*deltalat + end if + lat = lat0 + ispan(0,ny-1,1)*deltalat + lon = lon0 + ispan(0,nx-1,1)*deltalon +;---Turn these into 1D coordinate arrays + lat!0 = "lat" + lon!0 = "lon" + lon@units = "degrees_east" + lat@units = "degrees_north" + lat&lat = lat + lon&lon = lon + end if + + istatus = 0 + + ; Read 2D data + + slab = wrf_wps_rddata_int(istatus,nx,ny) + + slab@_FillValue = -1e+30 + slab!1 = "lon" + slab!0 = "lat" + slab&lon = lon + slab&lat = lat + slab@units = units + + slab@description = xlvl +" "+ desc +; printVarSummary(slab) + + map = gsn_csm_contour_map(wks,slab,res) + delete(lat) + delete(lon) + delete(slab) + + wrf_wps_rdhead_int(istatus,head_real,field,hdate, \ + units,map_source,desc) + + end do + + end if + +end diff --git a/WPS/util/plotfmt_nc.ncl b/WPS/util/plotfmt_nc.ncl new file mode 100644 index 00000000..4bb93f4c --- /dev/null +++ b/WPS/util/plotfmt_nc.ncl @@ -0,0 +1,156 @@ +;_______________________________________________________________________________________ +;To run the script type: +; ncl plotfmt_nc.ncl {input file} +; +; e.g. +; ncl plotfmt_nc.ncl 'inputFILE="FILE:2005-06-01_00.nc"' +;_______________________________________________________________________________________ + +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + +begin + +; Make sure we have a datafile to work with + if (.not. isvar("inputFILE") ) then + print(" ") + print(" ### MUST SUPPLY a inputFILE ### ") + print(" ") + print(" Something like: ") + print(" ncl plotfmt_nc.ncl inputFILE=FILE:2005-06-01_00.nc") + print(" REMEMBER TO ADD QUOTES" ) + print(" Refer to the information at the top of this file for more info and syntax" ) + exit + end if + + inFILE = addfile(inputFILE,"r") + +; We generate plots, but what kind do we prefer? + type = "x11" +; type = "pdf" +; type = "ps" +; type = "ncgm" + + outf = "plotfmt_nc" + wks = gsn_open_wks(type,"outf") + + + vNames = getfilevarnames (inFILE) + nNames = dimsizes (vNames) + + res = True + res@cnFillOn = True + res@gsnSpreadColors = True + res@lbLabelAutoStride= True + + do n=0,nNames-1 + + print("VAR = " + vNames(n) ) + var = inFILE->$vNames(n)$ + + dims = dimsizes(var) + lat = new ( dims(0), float) + lon = new ( dims(1), float) + lon@units = "degrees_east" + lat@units = "degrees_north" + lat(0) = var@startlat + lon(0) = var@startlon + + if (var@projection .eq. 0) then ;Cylindrical Equidistant + do i=1,dims(0)-1 + lat(i) = lat(i-1) + var@deltalat + end do + do i=1,dims(1)-1 + lon(i) = lon(i-1) + var@deltalon + end do + end if + + if (var@projection .eq. 1) then ; Mercator + res1 = True + res1@MAP_PROJ = 3 + res1@TRUELAT1 = var@truelat1 + res1@DX = var@dx*1000. + res1@DY = var@dy*1000. + res1@REF_LAT = lat(0) + res1@REF_LON = lon(0) + res1@POLE_LAT = 90.0 + res1@POLE_LON = 0.0 + res1@LATINC = 0.0 + res1@LONINC = 0.0 + res1@KNOWNI = 1.0 + res1@KNOWNJ = 1.0 + loc = wrf_ij_to_ll (var@nx,var@ny,res1) + + res@gsnAddCyclic = False + res@mpLimitMode = "Corners" + res@mpLeftCornerLatF = lat(0) + res@mpLeftCornerLonF = lon(0) + res@mpRightCornerLatF = loc(1) + res@mpRightCornerLonF = loc(0) + res@tfDoNDCOverlay = True + res@mpProjection = "mercator" + end if + + if (var@projection .eq. 3) then ; Lambert Conformal + res1 = True + res1@MAP_PROJ = 1 + res1@TRUELAT1 = var@truelat1 + res1@TRUELAT2 = var@truelat2 + res1@STAND_LON = var@xlonc + res1@DX = var@dx*1000. + res1@DY = var@dy*1000. + res1@REF_LAT = lat(0) + res1@REF_LON = lon(0) + res1@POLE_LAT = 90.0 + res1@POLE_LON = 0.0 + res1@LATINC = 0.0 + res1@LONINC = 0.0 + res1@KNOWNI = 1.0 + res1@KNOWNJ = 1.0 + loc = wrf_ij_to_ll (var@nx,var@ny,res1) + + res@gsnAddCyclic = False + res@mpLimitMode = "Corners" + res@mpLeftCornerLatF = lat(0) + res@mpLeftCornerLonF = lon(0) + res@mpRightCornerLatF = loc(1) + res@mpRightCornerLonF = loc(0) + res@tfDoNDCOverlay = True + res@mpProjection = "LambertConformal" + res@mpLambertParallel1F = var@truelat1 + res@mpLambertParallel2F = var@truelat2 + res@mpLambertMeridianF = var@xlonc + end if + + if (var@projection .eq. 4) then ;Gaussian + delta = 2.*(var@startlat)/(2.*var@nlats-1) + if (var@startlat .ge. 80.) then + delta = -1.0*delta + end if + do i=1,dims(0)-1 + lat(i) = lat(i-1) + delta + end do + do i=1,dims(1)-1 + lon(i) = lon(i-1) + var@deltalon + end do + end if + + var!1 = "lon" + var!0 = "lat" + var&lon = lon + var&lat = lat + + var@description = var@level +" "+ var@description + + ;map = gsn_csm_contour_map_ce(wks,var,res) + map = gsn_csm_contour_map(wks,var,res) + delete(lat) + delete(lon) + delete(var) + + end do + + + +end diff --git a/WPS/util/plotgrids.ncl b/WPS/util/plotgrids.ncl new file mode 100644 index 00000000..ae4021e5 --- /dev/null +++ b/WPS/util/plotgrids.ncl @@ -0,0 +1,195 @@ + +; Script display location of model domains +; Only works for ARW domains +; Only works for NCL versions 6.1.x +; Reads namelist file directly + +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" + +begin +; + +; Check the version of NCL + version = systemfunc("ncl -V") + if(version.lt.6.1) then + print("You need NCL V6.1 to run this script. Try running util/plotgrids_old.ncl. Stopping now...") + return + end if + if(version.ge.6.2) then + print("You need NCL V6.1 to run this script. Try running util/plotgrids_new.ncl. Stopping now...") + return + end if + +; We generate plots, but what kind do we prefer? + type = "x11" +; type = "pdf" +; type = "ps" +; type = "ncgm" + wks = gsn_open_wks(type,"wps_show_dom") + +; read the following namelist file + filename = "namelist.wps" + +; Set the colors to be used + colors = (/"white","black","White","ForestGreen","DeepSkyBlue","Red","Blue"/) + gsn_define_colormap(wks, colors) + + +; Set some map information ; line and text information + mpres = True + mpres@mpFillOn = True + mpres@mpFillColors = (/"background","DeepSkyBlue","ForestGreen","DeepSkyBlue", "transparent"/) + mpres@mpDataBaseVersion = "Ncarg4_1" + mpres@mpGeophysicalLineColor = "Black" + mpres@mpGridLineColor = "Black" + mpres@mpLimbLineColor = "Black" + mpres@mpNationalLineColor = "Black" + mpres@mpPerimLineColor = "Black" + mpres@mpUSStateLineColor = "Black" +; mpres@mpOutlineBoundarySets = "AllBoundaries" + ;mpres@mpGridSpacingF = 45 + mpres@tiMainString = " WPS Domain Configuration " + + lnres = True + lnres@gsLineThicknessF = 2.5 + lnres@domLineColors = (/ "white", "Red" , "Red" , "Blue" /) + + txres = True + txres@txFont = "helvetica-bold" + ;txres@txJust = "BottomLeft" + txres@txJust = "TopLeft" + txres@txPerimOn = False + txres@txFontHeightF = 0.015 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Do not change anything between the ";;;;;" lines + + maxdom = 21 + nvar = 17 + parent_idn = new (maxdom,integer) + parent_grid_ration = new (maxdom,integer) + i_parent_startn = new (maxdom,integer) + j_parent_startn = new (maxdom,integer) + e_wen = new (maxdom,integer) + e_snn = new (maxdom,integer) + plotvar = new((/maxdom,nvar/),float) + plotvar@_FillValue = -999.0 + + plotvar = wrf_wps_read_nml(filename) + + mpres@max_dom = floattointeger(plotvar(0,0)) + mpres@dx = plotvar(0,1) + mpres@dy = plotvar(0,2) + mpres@ref_lat = plotvar(0,3) + mpres@ref_lon = plotvar(0,4) + mpres@truelat1 = plotvar(0,5) + mpres@truelat2 = plotvar(0,6) + mpres@stand_lon = plotvar(0,7) + mproj_int = plotvar(0,8) + mpres@pole_lat = plotvar(0,9) + mpres@pole_lon = plotvar(0,10) + + do i = 0,maxdom-1 + parent_idn(i) = floattointeger(plotvar(i,11)) + parent_grid_ration(i) = floattointeger(plotvar(i,12)) + i_parent_startn(i) = floattointeger(plotvar(i,13)) + j_parent_startn(i) = floattointeger(plotvar(i,14)) + e_wen(i) = floattointeger(plotvar(i,15)) + e_snn(i) = floattointeger(plotvar(i,16)) + end do + + if(mpres@max_dom .gt. 1) then + do i = 1,mpres@max_dom-1 + + ;Making sure edge is nested grid is at least 5 grid points from mother domain. + if(i_parent_startn(i) .lt. 5) then + print("Warning: Western edge of grid must be at least 5 grid points from mother domain!") + end if + if(j_parent_startn(i) .lt. 5) then + print("Warning: Southern edge of grid must be at least 5 grid points from mother domain!") + end if + pointwe = (e_wen(i)-1.)/parent_grid_ration(i) + pointsn = (e_snn(i)-1.)/parent_grid_ration(i) + gridwe = e_wen(parent_idn(i)-1)-(pointwe+i_parent_startn(i)) + gridsn = e_snn(parent_idn(i)-1)-(pointsn+j_parent_startn(i)) + if(gridwe .lt. 5) then + print("Warning: Eastern edge of grid must be at least 5 grid points from mother domain!") + end if + if(gridsn .lt. 5) then + print("Warning: Northern edge of grid must be at least 5 grid points from mother domain!") + end if + + ;Making sure nested grid is fully contained in mother domain. + gridsizewe = (((e_wen(parent_idn(i)-1)-4)-i_parent_startn(i))*parent_grid_ration(i))-(parent_grid_ration(i)-1) + gridsizesn = (((e_snn(parent_idn(i)-1)-4)-j_parent_startn(i))*parent_grid_ration(i))-(parent_grid_ration(i)-1) + if(gridwe .lt. 5) then + print("Warning: Inner nest (domain = " + (i+1) + ") is not fully contained in mother nest (domain = " + parent_idn(i) + ")!") + print("For the current setup of mother domain = " + parent_idn(i) + ", you can only have a nest of size " + gridsizewe + "X" + gridsizesn + ". Stopping Program!") + exit + end if + if(gridsn .lt. 5) then + print("Warning: Inner nest (domain = " + (i+1) + ") is not fully contained in mother nest (domain = " + parent_idn(i) + ")!") + print("For the current setup of mother domain = " + parent_idn(i) + ", you can only have a nest of size " + gridsizewe + "X" + gridsizesn + ". Stopping Program!") + exit + end if + + ;Making sure the nest ends of a mother grid domain point. + pointwetrunc = decimalPlaces(pointwe,0,False) + pointsntrunc = decimalPlaces(pointsn,0,False) + if((pointwe-pointwetrunc) .ne. 0.) then + nest_we_up = (ceil(pointwe)*parent_grid_ration(i))+1 + nest_we_dn = (floor(pointwe)*parent_grid_ration(i))+1 + print("Nest does not end on mother grid domain point. Try " + nest_we_dn + " or " + nest_we_up + ".") + end if + if((pointsn-pointsntrunc) .ne. 0.) then + nest_sn_up = (ceil(pointsn)*parent_grid_ration(i))+1 + nest_sn_dn = (floor(pointsn)*parent_grid_ration(i))+1 + print("Nest does not end on mother grid domain point. Try " + nest_sn_dn + " or " + nest_sn_up + ".") + end if + + end do + end if + + mpres@parent_id = parent_idn(0:mpres@max_dom-1) + mpres@parent_grid_ratio = parent_grid_ration(0:mpres@max_dom-1) + mpres@i_parent_start = i_parent_startn(0:mpres@max_dom-1) + mpres@j_parent_start = j_parent_startn(0:mpres@max_dom-1) + mpres@e_we = e_wen(0:mpres@max_dom-1) + mpres@e_sn = e_snn(0:mpres@max_dom-1) + + if(mproj_int .eq. 1) then + mpres@map_proj = "lambert" + mpres@pole_lat = 0.0 + mpres@pole_lon = 0.0 + else if(mproj_int .eq. 2) then + mpres@map_proj = "mercator" + mpres@pole_lat = 0.0 + mpres@pole_lon = 0.0 + else if(mproj_int .eq. 3) then + mpres@map_proj = "polar" + mpres@pole_lat = 0.0 + mpres@pole_lon = 0.0 + else if(mproj_int .eq. 4) then + mpres@map_proj = "lat-lon" + end if + end if + end if + end if + + mp = wrf_wps_dom (wks,mpres,lnres,txres) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Now you can add some information to the plot. +; Below is an example of adding a white dot over the DC location. + ;pmres = True + ;pmres@gsMarkerColor = "White" + ;pmres@gsMarkerIndex = 16 + ;pmres@gsMarkerSizeF = 0.01 + ;gsn_polymarker(wks,mp,-77.26,38.56,pmres) + + + frame(wks) ; lets frame the plot - do not delete + +end diff --git a/WPS/util/plotgrids_new.ncl b/WPS/util/plotgrids_new.ncl new file mode 100644 index 00000000..0a3e3bf6 --- /dev/null +++ b/WPS/util/plotgrids_new.ncl @@ -0,0 +1,215 @@ + +; Script display location of model domains +; Only works for ARW domains +; Only works for NCL versions 6.2 or later +; Reads namelist file directly + +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" + +begin +; + +; Check the version of NCL + version = systemfunc("ncl -V") + if(version.lt.6.2) then + print("You need NCL V6.2 or later to run this script. Try running plotgrids.ncl. Stopping now...") + return + end if + +; We generate plots, but what kind do we prefer? + type = "x11" +; type = "pdf" +; type = "ps" +; type = "ncgm" + wks = gsn_open_wks(type,"wps_show_dom") + +; read the following namelist file + filename = "namelist.wps" + +; Set the colors to be used + colors = (/"white","black","White","ForestGreen","DeepSkyBlue","Red","Blue"/) + gsn_define_colormap(wks, colors) + + +; Set some map information ; line and text information + mpres = True + mpres@mpFillOn = True + mpres@mpFillColors = (/"background","DeepSkyBlue","ForestGreen","DeepSkyBlue", "transparent"/) + mpres@mpDataBaseVersion = "Ncarg4_1" + mpres@mpGeophysicalLineColor = "Black" + mpres@mpGridLineColor = "Black" + mpres@mpLimbLineColor = "Black" + mpres@mpNationalLineColor = "Black" + mpres@mpPerimLineColor = "Black" + mpres@mpUSStateLineColor = "Black" +; mpres@mpOutlineBoundarySets = "AllBoundaries" + ;mpres@mpGridSpacingF = 45 + mpres@tiMainString = " WPS Domain Configuration " + + lnres = True + lnres@gsLineThicknessF = 2.5 + lnres@domLineColors = (/ "white", "Red" , "Red" , "Blue" /) + + txres = True + txres@txFont = "helvetica-bold" + ;txres@txJust = "BottomLeft" + txres@txJust = "TopLeft" + txres@txPerimOn = False + txres@txFontHeightF = 0.015 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Do not change anything between the ";;;;;" lines + + maxdom = 21 + nvar = 19 + parent_idn = new (maxdom,integer) + parent_grid_ration = new (maxdom,integer) + i_parent_startn = new (maxdom,integer) + j_parent_startn = new (maxdom,integer) + e_wen = new (maxdom,integer) + e_snn = new (maxdom,integer) + plotvar = new((/maxdom,nvar/),float) + plotvar@_FillValue = -999.0 + + plotvar = wrf_wps_read_nml(filename) + + mpres@max_dom = floattointeger(plotvar(0,0)) + mpres@dx = plotvar(0,1) + mpres@dy = plotvar(0,2) + if (.not.ismissing(plotvar(0,3))) then + mpres@ref_lat = plotvar(0,3) + else + mpres@ref_lat = 0.0 + end if + if (.not.ismissing(plotvar(0,4))) then + mpres@ref_lon = plotvar(0,4) + else + mpres@ref_lon = 0.0 + end if + if (.not.ismissing(plotvar(0,5))) then + mpres@ref_x = plotvar(0,5) + end if + if (.not.ismissing(plotvar(0,6))) then + mpres@ref_y = plotvar(0,6) + end if + mpres@truelat1 = plotvar(0,7) + mpres@truelat2 = plotvar(0,8) + mpres@stand_lon = plotvar(0,9) + mproj_int = plotvar(0,10) + mpres@pole_lat = plotvar(0,11) + mpres@pole_lon = plotvar(0,12) + + do i = 0,maxdom-1 + parent_idn(i) = floattointeger(plotvar(i,13)) + parent_grid_ration(i) = floattointeger(plotvar(i,14)) + i_parent_startn(i) = floattointeger(plotvar(i,15)) + j_parent_startn(i) = floattointeger(plotvar(i,16)) + e_wen(i) = floattointeger(plotvar(i,17)) + e_snn(i) = floattointeger(plotvar(i,18)) + end do + + + if(mpres@max_dom .gt. 1) then + do i = 1,mpres@max_dom-1 + + ;Making sure edge is nested grid is at least 5 grid points from mother domain. + if(i_parent_startn(i) .lt. 5) then + print("Warning: Western edge of grid must be at least 5 grid points from mother domain!") + end if + if(j_parent_startn(i) .lt. 5) then + print("Warning: Southern edge of grid must be at least 5 grid points from mother domain!") + end if + pointwe = (e_wen(i)-1.)/parent_grid_ration(i) + pointsn = (e_snn(i)-1.)/parent_grid_ration(i) + gridwe = e_wen(parent_idn(i)-1)-(pointwe+i_parent_startn(i)) + gridsn = e_snn(parent_idn(i)-1)-(pointsn+j_parent_startn(i)) + if(gridwe .lt. 5) then + print("Warning: Eastern edge of grid must be at least 5 grid points from mother domain!") + end if + if(gridsn .lt. 5) then + print("Warning: Northern edge of grid must be at least 5 grid points from mother domain!") + end if + + ;Making sure nested grid is fully contained in mother domain. + gridsizewe = (((e_wen(parent_idn(i)-1)-4)-i_parent_startn(i))*parent_grid_ration(i))-(parent_grid_ration(i)-1) + gridsizesn = (((e_snn(parent_idn(i)-1)-4)-j_parent_startn(i))*parent_grid_ration(i))-(parent_grid_ration(i)-1) + if(gridwe .lt. 5) then + print("Warning: Inner nest (domain = " + (i+1) + ") is not fully contained in mother nest (domain = " + parent_idn(i) + ")!") + print("For the current setup of mother domain = " + parent_idn(i) + ", you can only have a nest of size " + gridsizewe + "X" + gridsizesn + ". Stopping Program!") + exit + end if + if(gridsn .lt. 5) then + print("Warning: Inner nest (domain = " + (i+1) + ") is not fully contained in mother nest (domain = " + parent_idn(i) + ")!") + print("For the current setup of mother domain = " + parent_idn(i) + ", you can only have a nest of size " + gridsizewe + "X" + gridsizesn + ". Stopping Program!") + exit + end if + + ;Making sure the nest ends at a mother grid domain point. + pointwetrunc = decimalPlaces(pointwe,0,False) + pointsntrunc = decimalPlaces(pointsn,0,False) + if((pointwe-pointwetrunc) .ne. 0.) then + nest_we_up = (ceil(pointwe)*parent_grid_ration(i))+1 + nest_we_dn = (floor(pointwe)*parent_grid_ration(i))+1 + print("Nest does not end on mother grid domain point. Try " + nest_we_dn + " or " + nest_we_up + ".") + end if + if((pointsn-pointsntrunc) .ne. 0.) then + nest_sn_up = (ceil(pointsn)*parent_grid_ration(i))+1 + nest_sn_dn = (floor(pointsn)*parent_grid_ration(i))+1 + print("Nest does not end on mother grid domain point. Try " + nest_sn_dn + " or " + nest_sn_up + ".") + end if + + end do + end if + + mpres@parent_id = parent_idn(0:mpres@max_dom-1) + mpres@parent_grid_ratio = parent_grid_ration(0:mpres@max_dom-1) + mpres@i_parent_start = i_parent_startn(0:mpres@max_dom-1) + mpres@j_parent_start = j_parent_startn(0:mpres@max_dom-1) + mpres@e_we = e_wen(0:mpres@max_dom-1) + mpres@e_sn = e_snn(0:mpres@max_dom-1) + + if(mproj_int .eq. 1) then + mpres@map_proj = "lambert" + mpres@pole_lat = 0.0 + mpres@pole_lon = 0.0 + else if(mproj_int .eq. 2) then + mpres@map_proj = "mercator" + mpres@pole_lat = 0.0 + mpres@pole_lon = 0.0 + else if(mproj_int .eq. 3) then + mpres@map_proj = "polar" + mpres@pole_lat = 0.0 + mpres@pole_lon = 0.0 + else if(mproj_int .eq. 4) then + mpres@map_proj = "lat-lon" + end if + end if + end if + end if + +; Deal with global wrf domains that don't have dx or dy + + if (mpres@dx.lt.1e-10 .and. mpres@dx.lt.1e-10) then + mpres@dx = 360./(mpres@e_we(0) - 1) + mpres@dy = 180./(mpres@e_sn(0) - 1) + mpres@ref_lat = 0.0 + mpres@ref_lon = 180.0 + end if + + mp = wrf_wps_dom (wks,mpres,lnres,txres) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Now you can add some information to the plot. +; Below is an example of adding a white dot over the DC location. + ;pmres = True + ;pmres@gsMarkerColor = "White" + ;pmres@gsMarkerIndex = 16 + ;pmres@gsMarkerSizeF = 0.01 + ;gsn_polymarker(wks,mp,-77.26,38.56,pmres) + + + frame(wks) ; lets frame the plot - do not delete + +end diff --git a/WPS/util/plotgrids_old.ncl b/WPS/util/plotgrids_old.ncl new file mode 100644 index 00000000..80d63377 --- /dev/null +++ b/WPS/util/plotgrids_old.ncl @@ -0,0 +1,135 @@ + +; Script display location of model domains +; Only works for ARW domains +; Reads namelist file directly + +load "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" +load "$NCARG_ROOT/lib/ncarg/nclscripts/wrf/WRFUserARW.ncl" +;load "./WRFUserARW.ncl" + +begin +; + +; We generate plots, but what kind do we prefer? + type = "x11" +; type = "pdf" +; type = "ps" +; type = "ncgm" + wks = gsn_open_wks(type,"wps_show_dom") + +; read the following namelist file + filename = "./namelist.wps" + + +; Set the colors to be used + colors = (/"white","black","White","ForestGreen","DeepSkyBlue","Red","Blue"/) + gsn_define_colormap(wks, colors) + + +; Set some map information ; line and text information + mpres = True + mpres@mpFillOn = True + mpres@mpFillColors = (/"background","DeepSkyBlue","ForestGreen","DeepSkyBlue", "transparent"/) + mpres@mpGeophysicalLineColor = "Black" + mpres@mpGridLineColor = "Black" + mpres@mpLimbLineColor = "Black" + mpres@mpNationalLineColor = "Black" + mpres@mpPerimLineColor = "Black" + mpres@mpUSStateLineColor = "Black" + ;mpres@mpGridSpacingF = 45 + mpres@tiMainString = " WPS Domain Configuration " + + lnres = True + lnres@gsLineThicknessF = 2.5 + lnres@domLineColors = (/ "white", "Red" , "Red" , "Blue" /) + + txres = True + txres@txFont = "helvetica-bold" + ;txres@txJust = "BottomLeft" + txres@txJust = "TopLeft" + txres@txPerimOn = False + txres@txFontHeightF = 0.015 + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Do not change anything between the ";;;;;" lines + + mpres@max_dom = stringtoint (systemfunc("grep max_dom " +filename+ " | cut -f2 -d'=' | cut -f1 -d','" ) ) + mpres@dx = stringtofloat(systemfunc("grep dx " +filename+ " | cut -f2 -d'=' | cut -f1 -d','" ) ) + mpres@dy = stringtofloat(systemfunc("grep dy " +filename+ " | cut -f2 -d'=' | cut -f1 -d','" ) ) + mpres@ref_lat = stringtofloat(systemfunc("grep ref_lat " +filename+ " | cut -f2 -d'=' | cut -f1 -d','" ) ) + mpres@ref_lon = stringtofloat(systemfunc("grep ref_lon " +filename+ " | cut -f2 -d'=' | cut -f1 -d','" ) ) + test = systemfunc("grep truelat1 " +filename ) + if ( .not. ismissing(test) ) + mpres@truelat1 = stringtofloat(systemfunc("grep truelat1 " +filename+ " | cut -f2 -d'=' | cut -f1 -d','" ) ) + else + mpres@truelat1 = 0.0 + end if + test = systemfunc("grep truelat2 " +filename ) + if ( .not. ismissing(test) ) + mpres@truelat2 = stringtofloat(systemfunc("grep truelat2 " +filename+ " | cut -f2 -d'=' | cut -f1 -d','" ) ) + else + mpres@truelat2 = 0.0 + end if + mpres@stand_lon = stringtofloat(systemfunc("grep stand_lon " +filename+ " | cut -f2 -d'=' | cut -f1 -d','" ) ) + + test = systemfunc("grep lambert " +filename ) + if ( .not. ismissing(test) ) + mpres@map_proj = "lambert" + end if + test = systemfunc("grep mercator " +filename ) + if ( .not. ismissing(test) ) + mpres@map_proj = "mercator" + end if + test = systemfunc("grep polar " +filename ) + if ( .not. ismissing(test) ) + mpres@map_proj = "polar" + end if + testa = systemfunc("grep 'lat-lon' " +filename ) + if ( .not. ismissing(testa) ) + mpres@map_proj = "lat-lon" + mpres@pole_lat = stringtofloat(systemfunc("grep pole_lat " +filename+ " | cut -f2 -d'=' | cut -f1 -d','" ) ) + mpres@pole_lon = stringtofloat(systemfunc("grep pole_lon " +filename+ " | cut -f2 -d'=' | cut -f1 -d','" ) ) + end if + + parent_id = new ( mpres@max_dom , integer ) + parent_grid_ratio = new ( mpres@max_dom , integer ) + i_parent_start = new ( mpres@max_dom , integer ) + j_parent_start = new ( mpres@max_dom , integer ) + e_we = new ( mpres@max_dom , integer ) + e_sn = new ( mpres@max_dom , integer ) + + do n = 1, mpres@max_dom + + n0 = n - 1 + parent_id(n0) = stringtoint(systemfunc("grep parent_id " +filename+ " | cut -f2 -d'=' | cut -f"+n+" -d','" ) ) + parent_grid_ratio(n0) = stringtoint(systemfunc("grep parent_grid_ratio " +filename+ " | cut -f2 -d'=' | cut -f"+n+" -d','" ) ) + i_parent_start(n0) = stringtoint(systemfunc("grep i_parent_start " +filename+ " | cut -f2 -d'=' | cut -f"+n+" -d','" ) ) + j_parent_start(n0) = stringtoint(systemfunc("grep j_parent_start " +filename+ " | cut -f2 -d'=' | cut -f"+n+" -d','" ) ) + e_we(n0) = stringtoint(systemfunc("grep e_we " +filename+ " | cut -f2 -d'=' | cut -f"+n+" -d','" ) ) + e_sn(n0) = stringtoint(systemfunc("grep e_sn " +filename+ " | cut -f2 -d'=' | cut -f"+n+" -d','" ) ) + + end do + + mpres@parent_id = parent_id + mpres@parent_grid_ratio = parent_grid_ratio + mpres@i_parent_start = i_parent_start + mpres@j_parent_start = j_parent_start + mpres@e_we = e_we + mpres@e_sn = e_sn + + mp = wrf_wps_dom (wks,mpres,lnres,txres) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; Now you can add some information to the plot. +; Below is an example of adding a white dot over the DC location. + ;pmres = True + ;pmres@gsMarkerColor = "White" + ;pmres@gsMarkerIndex = 16 + ;pmres@gsMarkerSizeF = 0.01 + ;gsn_polymarker(wks,mp,-77.26,38.56,pmres) + + + frame(wks) ; lets frame the plot - do not delete + +end diff --git a/WPS/util/src/.gitignore b/WPS/util/src/.gitignore new file mode 100644 index 00000000..7062b4c5 --- /dev/null +++ b/WPS/util/src/.gitignore @@ -0,0 +1,3 @@ +*.f90 +*.o +*.mod diff --git a/WPS/util/src/Makefile b/WPS/util/src/Makefile new file mode 100644 index 00000000..1b3b70b2 --- /dev/null +++ b/WPS/util/src/Makefile @@ -0,0 +1,117 @@ +include ../../configure.wps + +OBJS = plotgrids.o avg_tsfc.o calc_ecmwf_p.o elev_angle.o plotfmt.o rd_intermediate.o \ + int2nc.o mod_levs.o height_ukmo.o \ + cio.o gridinfo_module.o misc_definitions_module.o module_debug.o module_stringutil.o \ + read_met_module.o write_met_module.o module_date_pack.o met_data_module.o constants_module.o \ + module_map_utils.o + +all: + clear ; + @echo " " + @echo "go up two directories and type './compile util' to build WPS utilities" + @echo " " + @echo " " + +rd_intermediate.exe: rd_intermediate.o read_met_module.o module_debug.o misc_definitions_module.o met_data_module.o + $(SFC) -o $(@) $(LDFLAGS) rd_intermediate.o read_met_module.o \ + module_debug.o misc_definitions_module.o cio.o met_data_module.o constants_module.o + +rd_intermediate.o: module_debug.o read_met_module.o rd_intermediate.F + +plotgrids.exe: plotgrids.o + $(SFC) -o $(@) $(LDFLAGS) module_map_utils.o module_debug.o cio.o constants_module.o misc_definitions_module.o \ + plotgrids.o $(NCARG_LIBS) $(NCARG_LIBS2) + +plotgrids.o: plotgrids.F module_map_utils.o + $(CP) $< $*.f90 + $(SFC) $(FNGFLAGS) -c $*.f90 +# $(RM) $*.f90 + +avg_tsfc.exe: avg_tsfc.o cio.o module_debug.o gridinfo_module.o read_met_module.o \ + write_met_module.o module_date_pack.o misc_definitions_module.o met_data_module.o + $(SFC) $(LDFLAGS) -o $@ avg_tsfc.o cio.o module_debug.o gridinfo_module.o \ + read_met_module.o write_met_module.o module_date_pack.o \ + misc_definitions_module.o met_data_module.o constants_module.o + +avg_tsfc.o: avg_tsfc.F cio.o module_debug.o gridinfo_module.o read_met_module.o \ + write_met_module.o module_date_pack.o misc_definitions_module.o + +elev_angle.exe: elev_angle.o cio.o module_debug.o gridinfo_module.o \ + write_met_module.o misc_definitions_module.o met_data_module.o + $(SFC) $(LDFLAGS) -o $@ elev_angle.o cio.o module_debug.o gridinfo_module.o \ + write_met_module.o misc_definitions_module.o met_data_module.o \ + -L$(NETCDF)/lib -I$(NETCDF)/include -lnetcdf + +elev_angle.o: elev_angle.F cio.o module_debug.o gridinfo_module.o \ + write_met_module.o misc_definitions_module.o + $(SFC) -c elev_angle.F -I$(NETCDF)/include + +calc_ecmwf_p.exe: calc_ecmwf_p.o cio.o module_debug.o module_stringutil.o gridinfo_module.o read_met_module.o \ + write_met_module.o module_date_pack.o misc_definitions_module.o met_data_module.o constants_module.o + $(SFC) $(LDFLAGS) -o $@ calc_ecmwf_p.o cio.o module_debug.o module_stringutil.o gridinfo_module.o \ + read_met_module.o write_met_module.o module_date_pack.o \ + misc_definitions_module.o met_data_module.o constants_module.o + +calc_ecmwf_p.o: calc_ecmwf_p.F cio.o module_debug.o module_stringutil.o gridinfo_module.o read_met_module.o \ + write_met_module.o module_date_pack.o misc_definitions_module.o + +plotfmt.exe: plotfmt.o read_met_module.o met_data_module.o + $(SFC) -o $(@) $(LDFLAGS) plotfmt.o read_met_module.o module_debug.o \ + misc_definitions_module.o cio.o met_data_module.o \ + $(NCARG_LIBS) $(NCARG_LIBS2) + +plotfmt.o: plotfmt.F misc_definitions_module.o read_met_module.o constants_module.o + $(CPP) $(CPPFLAGS) $< > $*.f90 + $(SFC) $(FNGFLAGS) -c $*.f90 +# $(RM) $*.f90 + +mod_levs.exe: mod_levs.o module_debug.o read_met_module.o write_met_module.o misc_definitions_module.o met_data_module.o + $(SFC) -o $(@) $(LDFLAGS) mod_levs.o module_debug.o read_met_module.o \ + write_met_module.o misc_definitions_module.o cio.o met_data_module.o constants_module.o + +mod_levs.o: module_debug.o read_met_module.o write_met_module.o mod_levs.F + +int2nc.exe: int2nc.o module_debug.o misc_definitions_module.o read_met_module.o cio.o + $(SFC) -o $(@) $(LDFLAGS) $(WRF_INCLUDE) int2nc.o module_debug.o misc_definitions_module.o read_met_module.o cio.o $(WRF_LIB) + +int2nc.o: int2nc.F module_debug.o misc_definitions_module.o read_met_module.o + $(RM) $*.f90 + $(CPP) $(CPPFLAGS) $< > $*.f90 + $(SFC) $(FFLAGS) $(WRF_INCLUDE) -c $*.f90 + +height_ukmo.exe: height_ukmo.o cio.o module_debug.o gridinfo_module.o read_met_module.o \ + write_met_module.o module_date_pack.o misc_definitions_module.o met_data_module.o + $(SFC) $(LDFLAGS) -o $@ height_ukmo.o cio.o module_debug.o gridinfo_module.o \ + read_met_module.o write_met_module.o module_date_pack.o \ + misc_definitions_module.o met_data_module.o constants_module.o + +height_ukmo.o: height_ukmo.F cio.o module_debug.o gridinfo_module.o read_met_module.o \ + write_met_module.o module_date_pack.o misc_definitions_module.o + +module_map_utils.o: module_map_utils.F misc_definitions_module.o constants_module.o module_debug.o + +cio.o: cio.c + +met_data_module.o: met_data_module.F + +module_stringutil.o: module_stringutil.F + +gridinfo_module.o: gridinfo_module.F misc_definitions_module.o module_debug.o + +misc_definitions_module.o: misc_definitions_module.F + +module_debug.o: module_debug.F cio.o + +read_met_module.o: read_met_module.F met_data_module.o constants_module.o module_debug.o misc_definitions_module.o + +write_met_module.o: write_met_module.F met_data_module.o module_debug.o misc_definitions_module.o + +module_date_pack.o: module_date_pack.F + +clean: + $(RM) $(OBJS) *.f90 *.mod + $(RM) plotgrids.exe plotfmt.exe avg_tsfc.exe elev_angle.exe calc_ecmwf_p.exe rd_intermediate.exe \ + mod_levs.exe height_ukmo.exe int2nc.exe + +superclean: clean diff --git a/WPS/util/src/avg_tsfc.F b/WPS/util/src/avg_tsfc.F new file mode 100644 index 00000000..e0caaa29 --- /dev/null +++ b/WPS/util/src/avg_tsfc.F @@ -0,0 +1,123 @@ +program avg_tsfc + + use date_pack + use gridinfo_module + use read_met_module + use write_met_module + use misc_definitions_module + use module_debug + + implicit none + + ! Local variables + integer :: idiff, n_times, t, istatus, fg_idx, discardtimes + character (len=19) :: valid_date, temp_date + character (len=128) :: input_name + type (met_data) :: fg_data, avg_data + + call get_namelist_params() + + call set_debug_level(WARN) + + nullify(avg_data%slab) + + ! Compute number of times that we will process + call geth_idts(end_date(1), start_date(1), idiff) + call mprintf((idiff < 0),ERROR,'Ending date is earlier than starting date in namelist for domain %i.', i1=1) + + n_times = idiff / interval_seconds + + ! Check that the interval evenly divides the range of times to process + call mprintf((mod(idiff, interval_seconds) /= 0),WARN, & + 'In namelist, interval_seconds does not evenly divide '// & + '(end_date - start_date) for domain %i. Only %i time periods '// & + 'will be processed.', i1=1, i2=n_times) + + fg_idx = 1 + + input_name = fg_name(fg_idx) + + discardtimes = mod(idiff+interval_seconds,86400) / interval_seconds + + do while (input_name /= '*') + + ! Loop over all times to be processed for this domain + do t=0,n_times-discardtimes + + call geth_newdate(valid_date, trim(start_date(1)), t*interval_seconds) + temp_date = ' ' + write(temp_date,'(a19)') valid_date(1:10)//'_'//valid_date(12:19) + + ! Initialize the module for reading in the met fields + call read_met_init(trim(input_name), .false., temp_date(1:13), istatus) + + if (istatus == 0) then + call mprintf(.true.,STDOUT,'Reading from %s at time %s', s1=input_name, s2=temp_date(1:13)) + + ! Process all fields and levels from the current file; read_next_met_field() + ! will return a non-zero status when there are no more fields to be read. + do while (istatus == 0) + + + call read_next_met_field(fg_data, istatus) + + if (istatus == 0) then + + if (trim(fg_data%field) == 'TT' .and. fg_data%xlvl == 200100.) then + if (.not. associated(avg_data%slab)) then + avg_data = fg_data + avg_data%hdate = '0000-00-00_00:00:00 ' + avg_data%xfcst = 0. + avg_data%xlvl = 200100. + avg_data%field = 'TAVGSFC ' + nullify(avg_data%slab) + allocate(avg_data%slab(avg_data%nx,avg_data%ny)) + avg_data%slab = 0. + end if + + if (avg_data%nx /= fg_data%nx .or. & + avg_data%ny /= fg_data%ny .or. & + avg_data%iproj /= fg_data%iproj) then + call mprintf(.true.,ERROR,'Mismatch in Tsfc field dimensions in file %s', & + s1=trim(input_name)//':'//temp_date(1:13)) + end if + + avg_data%slab = avg_data%slab + fg_data%slab + end if + + if (associated(fg_data%slab)) deallocate(fg_data%slab) + + end if + + end do + + call read_met_close() + + else + call mprintf(.true.,ERROR,'Problem opening %s at time %s', s1=input_name, s2=temp_date(1:13)) + end if + + end do + + if (associated(avg_data%slab)) then + avg_data%slab = avg_data%slab /real(n_times-discardtimes+1) + + call write_met_init('TAVGSFC', .true., temp_date(1:13), istatus) + + call write_next_met_field(avg_data, istatus) + + call write_met_close() + + deallocate(avg_data%slab) + end if + + fg_idx = fg_idx + 1 + input_name = fg_name(fg_idx) + + end do + + call mprintf(.true.,STDOUT,' *** Successful completion of program avg_tsfc.exe *** ') + + stop + +end program avg_tsfc diff --git a/WPS/util/src/calc_ecmwf_p.F b/WPS/util/src/calc_ecmwf_p.F new file mode 100644 index 00000000..ffde2319 --- /dev/null +++ b/WPS/util/src/calc_ecmwf_p.F @@ -0,0 +1,458 @@ +module coefficients + + integer :: n_levels + real, allocatable, dimension(:) :: a, b + + contains + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: read_coeffs + ! + ! Notes: Obtain table of coefficients for input by this routine from the link + ! below that corresponds to the correct number of levels: + ! http://www.ecmwf.int/en/forecasts/documentation-and-support/16-model-levels + ! http://www.ecmwf.int/en/forecasts/documentation-and-support/19-model-levels + ! http://www.ecmwf.int/en/forecasts/documentation-and-support/31-model-levels + ! http://www.ecmwf.int/en/forecasts/documentation-and-support/40-model-levels + ! http://www.ecmwf.int/en/forecasts/documentation-and-support/50-model-levels + ! http://www.ecmwf.int/en/forecasts/documentation-and-support/60-model-levels + ! http://www.ecmwf.int/en/forecasts/documentation-and-support/62-model-levels + ! http://www.ecmwf.int/en/forecasts/documentation-and-support/91-model-levels + ! http://www.ecmwf.int/en/forecasts/documentation-and-support/137-model-levels + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine read_coeffs() + + implicit none + + integer :: i, nlvl, istatus + + open(21,file='ecmwf_coeffs',form='formatted',status='old',iostat=istatus) + + n_levels = 0 + + if (istatus /= 0) then + write(6,*) 'ERROR: Error opening ecmwf_coeffs' + return + end if + + read(21,*,iostat=istatus) nlvl + do while (istatus == 0) + n_levels = n_levels + 1 + read(21,*,iostat=istatus) nlvl + end do + + rewind(21) + + n_levels = n_levels - 1 + + allocate(a(0:n_levels)) + allocate(b(0:n_levels)) + + write(6,*) ' ' + write(6,*) 'Coefficients for each level:',n_levels + do i=0,n_levels + read(21,*,iostat=istatus) nlvl, a(i), b(i) + write(6,'(i5,5x,f12.6,2x,f12.10)') nlvl, a(i), b(i) + end do + write(6,*) ' ' + + close(21) + + end subroutine read_coeffs + + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ! Name: cleanup_coeffs + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine cleanup_coeffs() + + implicit none + + n_levels = 0 + if (allocated(a)) deallocate(a) + if (allocated(b)) deallocate(b) + + end subroutine cleanup_coeffs + +end module coefficients + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! calc_ecmwf_p +! +! The purpose of this program is to compute a 3d pressure field for ECMWF +! model-level data sets; the code works in the WPS intermediate file format, +! reading a PSFC field from intermediate files, the A and B coefficients +! from a text file, ecmwf_coeffs, and writes the pressure data to an +! intermediate file. +! +! November 2008 +! Note: This program now also computes height for each level, this is needed by real +! modified by: Daniel van Dijke, MeteoConsult B.V., The Netherlands +! Chiel van Heerwaarden, Wageningen University, The Netherlands +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +program calc_ecmwf_p + + use coefficients + use date_pack + use gridinfo_module + use misc_definitions_module + use module_debug + use read_met_module + use stringutil + use write_met_module + + implicit none + + ! Local variables + integer :: i, idiff, n_times, t, istatus, fg_idx, counter + real :: a_full, b_full + character (len=19) :: valid_date, temp_date + character (len=128) :: input_name + real, allocatable, dimension(:,:) :: psfc, hgtsfc, hgtprev, pstart, pend + real, allocatable, dimension(:,:,:) :: tt, qv, hgt_3ddata + logical :: is_psfc + type (met_data) :: ecmwf_data, p_data, rh_data, hgt_data + + + ! + ! Setup (read namelist and check on time range) + ! + call get_namelist_params() + + call set_debug_level(WARN) + + ! Compute number of times that we will process + call geth_idts(end_date(1), start_date(1), idiff) + call mprintf((idiff < 0),ERROR,'Ending date is earlier than starting date in namelist for domain %i.', i1=1) + + n_times = idiff / interval_seconds + + ! Check that the interval evenly divides the range of times to process + call mprintf((mod(idiff, interval_seconds) /= 0),WARN, & + 'In namelist, interval_seconds does not evenly divide '// & + '(end_date - start_date) for domain %i. Only %i time periods '// & + 'will be processed.', i1=1, i2=n_times) + + fg_idx = 1 + + input_name = fg_name(fg_idx) + + ! + ! Get coefficients for model level pressures + ! + call read_coeffs() + + + ! + ! Loop over all prefixes listed in namelist for fg_name + ! + do while (input_name /= '*') + + ! + ! Loop over all times to be processed for this domain + ! + do t=0,n_times + + ! Get the date string for the current time + call geth_newdate(valid_date, trim(start_date(1)), t*interval_seconds) + temp_date = ' ' + write(temp_date,'(a19)') valid_date(1:10)//'_'//valid_date(12:19) + + ! Initialize the module for reading in the met fields + call read_met_init(trim(input_name), .false., temp_date(1:13), istatus) + + is_psfc = .false. + + if (istatus == 0) then + call mprintf(.true.,STDOUT,'Reading from %s at time %s', s1=input_name, s2=temp_date(1:13)) + + ! Process all fields and levels from the current file; read_next_met_field() + ! will return a non-zero status when there are no more fields to be read. + do while (istatus == 0) + + call read_next_met_field(ecmwf_data, istatus) + + if (istatus == 0) then + + ! Have we found either PSFC or LOGSFP? + if ((trim(ecmwf_data%field) == 'PSFC' .and. ecmwf_data%xlvl == 200100.) & + .or. trim(ecmwf_data%field) == 'LOGSFP') then + p_data = ecmwf_data + p_data%field = 'PRESSURE ' + p_data%desc = 'Pressure' + + rh_data = ecmwf_data + rh_data%field = 'RH ' + rh_data%units = '%' + rh_data%desc = 'Relative humidity' + + if (.not. allocated(psfc)) then + allocate(psfc(ecmwf_data%nx,ecmwf_data%ny)) + end if + call mprintf(.true.,STDOUT,'Found %s field in %s:%s', & + s1=ecmwf_data%field, s2=input_name, s3=temp_date(1:13)) + + is_psfc = .true. + if (trim(ecmwf_data%field) == 'LOGSFP') then + psfc(:,:) = exp(ecmwf_data%slab(:,:)) + else + psfc(:,:) = ecmwf_data%slab(:,:) + end if + + !CvH_DvD: - Store geopotential height + else if (trim(ecmwf_data%field) == 'SOILHGT' .and. ecmwf_data%xlvl == 200100.) then + hgt_data = ecmwf_data + hgt_data%field = 'GHT ' + hgt_data%units = 'm' + hgt_data%desc = 'Height' + if (.not. allocated(hgtsfc)) then + allocate(hgtsfc(ecmwf_data%nx,ecmwf_data%ny)) + end if + call mprintf(.true.,STDOUT,'Found %s field in %s:%s', & + s1=ecmwf_data%field, s2=input_name, s3=temp_date(1:13)) + + hgtsfc(:,:) = ecmwf_data%slab(:,:) + + ! Have we found surface geopotential? + else if (trim(ecmwf_data%field) == 'SOILGEO' .and. ecmwf_data%xlvl == 1.) then + hgt_data = ecmwf_data + hgt_data%field = 'GHT ' + hgt_data%units = 'm' ! units on output after conversion to height + hgt_data%desc = 'Height' + if (.not. allocated(hgtsfc)) then + allocate(hgtsfc(ecmwf_data%nx,ecmwf_data%ny)) + end if + call mprintf(.true.,STDOUT,'Found %s field in %s:%s', & + s1=ecmwf_data%field, s2=input_name, s3=temp_date(1:13)) + + hgtsfc(:,:) = ecmwf_data%slab(:,:)/9.81 + + + ! Have we found temperature? + else if (trim(ecmwf_data%field) == 'TT') then + + if (.not. allocated(tt)) then + allocate(tt(ecmwf_data%nx,ecmwf_data%ny,n_levels+1)) ! Extra level is for surface + end if + + if (nint(ecmwf_data%xlvl) >= 1 .and. & + nint(ecmwf_data%xlvl) <= n_levels) then + tt(:,:,nint(ecmwf_data%xlvl)) = ecmwf_data%slab + else if (nint(ecmwf_data%xlvl) == 200100) then + tt(:,:,n_levels+1) = ecmwf_data%slab + end if + + ! Have we found specific humidity? + else if (trim(ecmwf_data%field) == 'SPECHUMD') then + + if (.not. allocated(qv)) then + allocate(qv(ecmwf_data%nx,ecmwf_data%ny,n_levels+1)) ! Extra level is for surface + end if + + if (nint(ecmwf_data%xlvl) >= 1 .and. & + nint(ecmwf_data%xlvl) <= n_levels) then + qv(:,:,nint(ecmwf_data%xlvl)) = ecmwf_data%slab + else if (nint(ecmwf_data%xlvl) == 200100) then + qv(:,:,n_levels+1) = ecmwf_data%slab + end if + + end if + + if (associated(ecmwf_data%slab)) deallocate(ecmwf_data%slab) + + end if + + end do + + call read_met_close() + + + ! Now write out, for each level, the pressure field + if (is_psfc) then + + allocate(p_data%slab(p_data%nx,p_data%ny)) + allocate(rh_data%slab(rh_data%nx,rh_data%ny)) + !CvH_DvD: add HGT variable + allocate(hgt_data%slab(hgt_data%nx,hgt_data%ny)) + + call write_met_init(trim(get_path(input_name))//'PRES', .false., temp_date(1:13), istatus) + + if (allocated(tt) .and. allocated(qv)) then + p_data%xlvl = 200100. + p_data%slab = psfc +! Surface RH should be computed from surface DEWPT by ungrib +! rh_data%xlvl = 200100. +! call calc_rh(tt(:,:,n_levels+1), qv(:,:,n_levels+1), psfc, rh_data%slab, rh_data%nx, rh_data%ny) +! call write_next_met_field(rh_data, istatus) + call write_next_met_field(p_data, istatus) + else + call mprintf(.true.,WARN,'Either TT or SPECHUMD not found. No RH will be computed.') + end if + + + + !CvH_DvD: if tt, qv and hgtsfc are available compute hgt + if (allocated(tt) .and. allocated(qv) .and. allocated(hgtsfc)) then + + if (.not. allocated(hgtprev)) then + allocate(hgtprev(ecmwf_data%nx,ecmwf_data%ny)) + end if + if (.not. allocated(pstart)) then + allocate(pstart(ecmwf_data%nx,ecmwf_data%ny)) + end if + if (.not. allocated(pend)) then + allocate(pend(ecmwf_data%nx,ecmwf_data%ny)) + end if + if (.not. allocated(hgt_3ddata)) then + allocate(hgt_3ddata(ecmwf_data%nx,ecmwf_data%ny, n_levels)) + end if + + ! CvH_DvD: interpolate Q and T if they are not available at all levels + do i = n_levels, 1, -1 + if (tt(1,1,i) .eq. 0) then ! CvH_DvD: If TT is zero, level is unknown, so moisture is zero too + if (i .eq. n_levels) then + write(6,*) 'WARNING First level is missing!' ! CvH_DvD: First level should be there! + else if (i .eq. 1) then + ! DvD: If TT is zero at the top level, so missing --> use previous level, + ! mod level will remove it anyway + tt(:,:,i)=tt(:,:,i+1) + qv(:,:,i)=qv(:,:,i+1) + else + counter=1 + ! CvH_DvD: Find first available level + do while ((i-counter .gt. 1) .and. (tt(1,1,i-counter) .eq. 0)) + counter=counter+1 + end do + if (tt(1,1,i-counter) .gt. 0) then + ! DvD: Interpolate tt and qv from next available level + tt(:,:,i)=tt(:,:,i+1)+(tt(:,:,i-counter)-tt(:,:,i+1))/(counter+1) + qv(:,:,i)=qv(:,:,i+1)+(qv(:,:,i-counter)-qv(:,:,i+1))/(counter+1) + else + ! DvD: No available level found --> should not happen. + write(6,*) 'WARNING No available level found near level ',i,'!' + end if + end if + end if + end do + + ! CvH_DvD: first previous hgt is surface hgt/soilgeo + hgtprev = hgtsfc + ! CvH_DvD: - Loop from surface to top, note: 1=top & n_levels=surface + do i = n_levels, 1, -1 + ! CvH_DvD: compute half level pressure at current half-level + pend = 0.5 * (a(i-1) + a(i)) + psfc * 0.5 * (b(i-1) + b(i)) + if (i .eq. n_levels) then + ! CvH_DvD: use Tv not T, use Psfc and T_halflevel_1=AveT lowest level + hgt_3ddata(:,:,i) = hgtprev + 287.05 * tt(:,:,i) * (1. + 0.61 * qv(:,:,i)) * log(psfc/pend) / 9.81 + else + ! CvH_DvD: compute half level pressure beneath current half-level + pstart = 0.5 * (a(i+1) + a(i)) + psfc * 0.5 * (b(i+1) + b(i)) + ! CvH_DvD: use Tv not T, create T at full leve beneath current half level + hgt_3ddata(:,:,i) = hgtprev + 287.05 * (tt(:,:,i) + tt(:,:,i+1))/2. * & + (1. + 0.61 * (qv(:,:,i)+qv(:,:,i+1))/2.) * log(pstart/pend) / 9.81 + end if + hgtprev = hgt_3ddata(:,:,i) + end do + + end if + + + do i = 1, n_levels + + a_full = 0.5 * (a(i-1) + a(i)) ! A and B are dimensioned (0:n_levels) + b_full = 0.5 * (b(i-1) + b(i)) + + p_data%xlvl = real(i) + p_data%slab = a_full + psfc * b_full + + if (allocated(tt) .and. allocated(qv)) then + rh_data%xlvl = real(i) + call calc_rh(tt(:,:,i), qv(:,:,i), p_data%slab, rh_data%slab, rh_data%nx, rh_data%ny) + call write_next_met_field(rh_data, istatus) + + if (allocated(hgtsfc)) then + ! CvH_DvD: put hgt_3ddata into hgt_data object + hgt_data%xlvl = real(i) + hgt_data%slab = hgt_3ddata(:,:,i) + call write_next_met_field(hgt_data, istatus) + else + call mprintf(.true., WARN, & + 'Either SOILHGT or SOILGEO are required to create 3-d GHT field, which is required '// & + 'for a correct vertical interpolation in real.') + end if + end if + + call write_next_met_field(p_data, istatus) + + end do + + call write_met_close() + + deallocate(p_data%slab) + deallocate(rh_data%slab) + ! CvH_DvD: deallocate stuff + deallocate(hgt_data%slab) + + end if + + if (allocated(tt)) deallocate(tt) + if (allocated(qv)) deallocate(qv) + if (allocated(psfc)) deallocate(psfc) + ! CvH_DvD: deallocate stuff + if (allocated(hgt_3ddata)) deallocate(hgt_3ddata) + if (allocated(pstart)) deallocate(pstart) + if (allocated(pend)) deallocate(pend) + if (allocated(hgtprev)) deallocate(hgtprev) + + + else + call mprintf(.true.,ERROR,'Problem opening %s at time %s', s1=input_name, s2=temp_date(1:13)) + end if + + end do + ! CvH_DvD: only now deallocate hgtsfc, + ! because oper EC does not have hgtsfc @ fps + if (allocated(hgtsfc)) deallocate(hgtsfc) + fg_idx = fg_idx + 1 + input_name = fg_name(fg_idx) + + end do + + call cleanup_coeffs() + + stop + +end program calc_ecmwf_p + + +subroutine calc_rh(t, qv, p, rh, nx, ny) + + implicit none + + ! Arguments + integer, intent(in) :: nx, ny + real, dimension(nx, ny), intent(in) :: t, qv, p + real, dimension(nx, ny), intent(out) :: rh + + ! Constants + real, parameter :: svp1=0.6112 + real, parameter :: svp2=17.67 + real, parameter :: svp3=29.65 + real, parameter :: svpt0=273.15 + real, parameter :: eps = 0.622 + + ! Local variables + integer :: i, j + real :: es, e + + do j=1,ny + do i=1,nx + es=svp1*10.*exp(svp2*(t(i,j)-svpt0)/(t(i,j)-svp3)) + e=qv(i,j)*p(i,j)/100./(eps+qv(i,j)*(1.-eps)) ! qv is specific humidity + rh(i,j) = 100.0 * e/es + end do + end do + +end subroutine calc_rh diff --git a/WPS/util/src/cio.c b/WPS/util/src/cio.c new file mode 120000 index 00000000..63c8e771 --- /dev/null +++ b/WPS/util/src/cio.c @@ -0,0 +1 @@ +../../geogrid/src/cio.c \ No newline at end of file diff --git a/WPS/util/src/constants_module.F b/WPS/util/src/constants_module.F new file mode 120000 index 00000000..1b38c903 --- /dev/null +++ b/WPS/util/src/constants_module.F @@ -0,0 +1 @@ +../../geogrid/src/constants_module.F \ No newline at end of file diff --git a/WPS/util/src/elev_angle.F b/WPS/util/src/elev_angle.F new file mode 100644 index 00000000..d7400169 --- /dev/null +++ b/WPS/util/src/elev_angle.F @@ -0,0 +1,206 @@ +program elev_angle + + implicit none + + integer, external :: iargc + + integer :: istatus + integer :: i, j, n_bins, we_dim, sn_dim + real, pointer, dimension(:,:) :: hgt + real, allocatable, dimension(:,:,:) :: topo_angle + character (len=1024) :: filename + + if (iargc() /= 1) then + write(6,*) ' ' + write(6,*) 'Usage: elev_angle.exe ' + write(6,*) ' ' + stop + end if + + call getarg(1,filename) + + ! + ! Read in topography field from geogrid output file + ! + call read_topo_field(filename, hgt, we_dim, sn_dim, istatus) + if (istatus /= 0) stop + + write(6,*) 'Read HGT_M field dimensioned ',we_dim,sn_dim + do j=1,sn_dim,10 + do i=1,we_dim,10 + write(6,'(a6,i3,a1,i3,a2,f13.5)') 'HGT_M(',i,',',j,')=',hgt(i,j) + end do + end do + + n_bins = 180 + allocate(topo_angle(we_dim, sn_dim, n_bins)) + + ! + ! Compute elevation angles for each azimuth angle bin + ! + topo_angle = 10.0 + + ! + ! Write elevation angle data to intermediate file + ! + call write_elev_angles(topo_angle, we_dim, sn_dim, n_bins, istatus) + + + deallocate(topo_angle) + deallocate(hgt) + + stop + +end program elev_angle + + +subroutine read_topo_field(filename, hgt, we_dim, sn_dim, istatus) + + use netcdf + + implicit none + + ! Arguments + character (len=*), intent(in) :: filename + real, pointer, dimension(:,:) :: hgt + integer, intent(out) :: we_dim, sn_dim + integer, intent(out) :: istatus + + ! Local variables + integer :: ncid, topo_varid, we_dimid, sn_dimid + character (len=NF90_MAX_NAME) :: toponame, we_name, sn_name + + + istatus = nf90_open(trim(filename), 0, ncid) + if (istatus /= NF90_NOERR) then + write(6,*) ' ' + write(6,*) 'Error: Could not open file '//trim(filename) + write(6,*) ' ' + istatus = 1 + return + end if + + sn_name = 'south_north' + istatus = nf90_inq_dimid(ncid, sn_name, sn_dimid) + if (istatus /= NF90_NOERR) then + write(6,*) ' ' + write(6,*) 'Error: Could not get ID of dimension south_north' + write(6,*) ' ' + istatus = 1 + return + end if + + istatus = nf90_inquire_dimension(ncid, sn_dimid, sn_name, sn_dim) + if (istatus /= NF90_NOERR) then + write(6,*) ' ' + write(6,*) 'Error: Could not get south_north dimension' + write(6,*) ' ' + istatus = 1 + return + end if + + we_name = 'west_east' + istatus = nf90_inq_dimid(ncid, we_name, we_dimid) + if (istatus /= NF90_NOERR) then + write(6,*) ' ' + write(6,*) 'Error: Could not get ID of dimension west_east' + write(6,*) ' ' + istatus = 1 + return + end if + + istatus = nf90_inquire_dimension(ncid, we_dimid, we_name, we_dim) + if (istatus /= NF90_NOERR) then + write(6,*) ' ' + write(6,*) 'Error: Could not get west_east dimension' + write(6,*) ' ' + istatus = 1 + return + end if + + toponame = 'HGT_M' + istatus = nf90_inq_varid(ncid, toponame, topo_varid) + if (istatus /= NF90_NOERR) then + write(6,*) ' ' + write(6,*) 'Error: Could not get ID of variable HGT_M' + write(6,*) ' ' + istatus = 1 + return + end if + + allocate(hgt(we_dim,sn_dim)) + + istatus = nf90_get_var(ncid, topo_varid, hgt) + if (istatus /= NF90_NOERR) then + write(6,*) ' ' + write(6,*) 'Error: Could not read HGT_M field' + write(6,*) ' ' + istatus = 1 + deallocate(hgt) + return + end if + + istatus = nf90_close(ncid) + + istatus = 0 + +end subroutine read_topo_field + + +subroutine write_elev_angles(field, we_dim, sn_dim, kdim, istatus) + + use write_met_module + + implicit none + + ! Arguments + real, dimension(we_dim, sn_dim, kdim), intent(in) :: field + integer, intent(in) :: we_dim, sn_dim, kdim + integer, intent(out) :: istatus + + ! Local variables + integer :: i + type (met_data) :: met_angle + + call write_met_init('ELEVANGLES', .true., '0000-00-00_00:00:00', istatus) + + if (istatus /= 0) then + write(6,*) ' ' + write(6,*) 'Error opening output file ELEVANGLES' + write(6,*) ' ' + istatus = 1 + return + end if + + met_angle%version = 5 + met_angle%iproj = PROJ_MERC + met_angle%field = 'TOPO_ELEV' + met_angle%units = 'degrees' + met_angle%desc = 'Topography elevation' +! met_angle%iproj = ... +! met_angle%truelat1 = ... +! met_angle%blah = ... +! met_angle%blah2 = ... + + allocate(met_angle%slab(we_dim, sn_dim)) + + do i=1,kdim + + met_angle%xlvl = real(i) + met_angle%slab(:,:) = field(:,:,i) + call write_next_met_field(met_angle, istatus) + + if (istatus /= 0) then + write(6,*) 'Error writing data to output file ELEVANGLES' + istatus = 1 + deallocate(met_angle%slab) + return + end if + + end do + + call write_met_close() + + istatus = 0 + +end subroutine write_elev_angles diff --git a/WPS/util/src/gridinfo_module.F b/WPS/util/src/gridinfo_module.F new file mode 120000 index 00000000..38af0e5c --- /dev/null +++ b/WPS/util/src/gridinfo_module.F @@ -0,0 +1 @@ +../../metgrid/src/gridinfo_module.F \ No newline at end of file diff --git a/WPS/util/src/height_ukmo.F b/WPS/util/src/height_ukmo.F new file mode 100644 index 00000000..005b33d2 --- /dev/null +++ b/WPS/util/src/height_ukmo.F @@ -0,0 +1,274 @@ +program height_ukmo + + ! This program computes the 3d height field for the UKMO data. The heights + ! are constant in time, and are a function only of the topography and a few + ! constants. There are several UKMO data sets available, denoted by the + ! different numbers of vertical levels. An input file defines the required + ! information for each of these data sets. + + use date_pack + use gridinfo_module + use read_met_module + use write_met_module + use misc_definitions_module + use module_debug + + implicit none + + ! Local variables + integer :: t, istatus + character (len=19) :: valid_date, temp_date, output_date + character (len=128) :: input_name + type (met_data) :: temp_data, soilhgt_data, height_data + + integer :: model_levels , first_constant_r_rho_level , k_loop , j_loop , i_loop , temp_count , date_loop + real :: z_top_of_model , etac + real, dimension(:) , allocatable :: eta + real , dimension(:,:) , allocatable :: soil_hold + logical :: still_more_dates_to_process + + call get_namelist_params() + + call set_debug_level(WARN) + + input_name = fg_name(1) + + call geth_newdate(valid_date, trim(start_date(1)), 0 ) + temp_date = ' ' + output_date = ' ' + write(temp_date,'(a19)') valid_date(1:10)//'_'//valid_date(12:19) + write(output_date,'(a19)') valid_date(1:10)//'_'//valid_date(12:19) + + ! Do this twice. The first time is to find out how many levels of + ! 3d fields there are. Why? The data from UKMO has *some* of the + ! levels, just not all. So we can compute the height field, but we + ! are not allowed to just spit out 70 levels. + + ! Initialize the module for reading in the met fields + call read_met_init(trim(input_name), .false., temp_date(1:13), istatus) + + if (istatus == 0) then + call mprintf(.true.,STDOUT,'Reading from %s at time %s', s1=input_name, s2=temp_date(1:13)) + + ! Process all fields and levels from the current file; read_next_met_field() + ! will return a non-zero status when there are no more fields to be read. + temp_count = 0 + just_temp : do while (istatus == 0) + + call read_next_met_field(temp_data, istatus) + + if (istatus == 0) then + + if (trim(temp_data%field) == 'TT' .and. temp_data%xlvl /= 200100.) then + temp_count = temp_count + 1 + else if (trim(temp_data%field) == 'SOILHGT' .and. temp_data%xlvl == 200100.) then + allocate ( soil_hold(temp_data%nx,temp_data%ny) ) + do j_loop = 1 , temp_data%ny + do i_loop = 1 , temp_data%nx + soil_hold(i_loop,j_loop) = temp_data%slab(i_loop,j_loop) + end do + end do + end if + + deallocate ( temp_data%slab ) + end if + + end do just_temp + call mprintf(.true.,STDOUT,'Total number of TT levels, excluding 200100 = %i' , i1=temp_count) + + call read_met_close() + + else + call mprintf(.true.,ERROR,'Problem opening %s at time %s', s1=input_name, s2=temp_date(1:13)) + end if + + ! Now we are doing this the second time. We know how many temp levels there are, temp_count, + ! so we will use the same number for height. + + ! Initialize the module for reading in the met fields - again! + call read_met_init(trim(input_name), .false., temp_date(1:13), istatus) + + if (istatus == 0) then + call mprintf(.true.,STDOUT,'Reading from %s at time %s', s1=input_name, s2=temp_date(1:13)) + + ! Process all fields and levels from the current file; read_next_met_field() + ! will return a non-zero status when there are no more fields to be read. + all_fields : do while (istatus == 0) + + + if ( associated ( soilhgt_data%slab ) ) then + deallocate ( soilhgt_data%slab ) + end if + call read_next_met_field(soilhgt_data, istatus) + + if (istatus == 0) then + + if (trim(soilhgt_data%field) == 'SOILHGT ' .and. soilhgt_data%xlvl == 200100.) then + if (.not. associated(height_data%slab)) then + allocate(height_data%slab(soilhgt_data%nx,soilhgt_data%ny)) + end if + height_data = soilhgt_data + height_data%hdate = '0000-00-00_00:00:00 ' + height_data%xfcst = 0. + height_data%field = 'HGT ' + height_data%slab = 0. + +!print *,'height_data%nx ,soilhgt_data%nx = ',height_data%nx ,soilhgt_data%nx +!print *,'height_data%ny ,soilhgt_data%ny = ',height_data%ny ,soilhgt_data%ny + + if (height_data%nx /= soilhgt_data%nx .or. & + height_data%ny /= soilhgt_data%ny .or. & + height_data%iproj /= soilhgt_data%iproj) then + call mprintf(.true.,ERROR,'Mismatch in height field dimensions in file %s', & + s1=trim(input_name)//':'//temp_date(1:13)) + end if + + open ( 10 , & + file = 'util/vertical_grid_70_20m_80km.txt' , & + form = 'formatted' , & + access = 'sequential' , & + status = 'old' , & + iostat = istatus ) + + if ( istatus /= 0 ) then + call mprintf(.true.,ERROR,'Cannot open the UKMO file util/vertical_grid_70_20m_80km.txt') + end if + + read (10 , * ) + read (10 , * ) + read (10 , * ) + read (10 , fmt='(30x,i2)' ) model_levels + read (10 , fmt='(30x,i2)' ) first_constant_r_rho_level + read (10 , fmt='(30x,f17.11)' ) z_top_of_model +print *,'model_levels, first_constant_r_rho_level, z_top_of_model = ', model_levels, first_constant_r_rho_level, z_top_of_model + read (10 , * ) + read (10 , * ) + + allocate ( eta ( model_levels ) ) + eta = 0. + do k_loop = 1 , first_constant_r_rho_level-1 + read ( 10 , fmt='(65x,f10.7)' ) eta(k_loop) +!print *,k_loop,' eta = ',eta(k_loop) + end do + k_loop = first_constant_r_rho_level + read ( 10 , fmt='(29x,f10.7,26x,f10.7)' ) etac , eta(k_loop) + do k_loop = first_constant_r_rho_level+1 , model_levels + read ( 10 , fmt='(65x,f10.7)' ) eta(k_loop) +!print *,k_loop,' eta = ',eta(k_loop) + end do + + exit all_fields + end if + + + end if + + end do all_fields + + call read_met_close() + + else + call mprintf(.true.,ERROR,'Problem opening %s at time %s', s1=input_name, s2=temp_date(1:13)) + end if + + ! Now we have to write the height out for each time. + + if (associated(height_data%slab)) then + + still_more_dates_to_process = .true. + soilhgt_data%xfcst= 0. + soilhgt_data%hdate= output_date // '.0000' + height_data%xfcst= 0. + height_data%hdate= output_date // '.0000' + date_loop = 1 + + all_dates : do while ( still_more_dates_to_process ) + +print *,'Generating ',temp_count,' height levels for ',output_date,'.' + + call write_met_init('HGT', .false., output_date(1:13), istatus) + soilhgt_data%xlvl = 200100 + soilhgt_data%field = 'SOILHGT ' + soilhgt_data%desc = 'Computed Geopotential Height, UKMO diagnostic ' + + ! Corrections for UKMO + +! soilhgt_data%deltalon= 360. / real(soilhgt_data%nx) + + do j_loop = 1 , soilhgt_data%ny + do i_loop = 1 , soilhgt_data%nx + soilhgt_data%slab(i_loop,j_loop) = soil_hold(i_loop,j_loop) + end do + end do + + call write_next_met_field(soilhgt_data, istatus) + + height_data%version= soilhgt_data%version + height_data%nx= soilhgt_data%nx + height_data%ny= soilhgt_data%ny + height_data%iproj= soilhgt_data%iproj +! height_data%xfcst= soilhgt_data%xfcst +! height_data%xlvl= soilhgt_data%xlvl + height_data%startlat= soilhgt_data%startlat + height_data%startlon= soilhgt_data%startlon + height_data%starti= soilhgt_data%starti + height_data%startj= soilhgt_data%startj + height_data%deltalat= soilhgt_data%deltalat + height_data%deltalon= soilhgt_data%deltalon + height_data%dx= soilhgt_data%dx + height_data%dy= soilhgt_data%dy + height_data%xlonc= soilhgt_data%xlonc + height_data%truelat1= soilhgt_data%truelat1 + height_data%truelat2= soilhgt_data%truelat2 + height_data%earth_radius= soilhgt_data%earth_radius + height_data%is_wind_grid_rel= soilhgt_data%is_wind_grid_rel + height_data%field= 'HGT ' +! height_data%hdate= soilhgt_data%hdate + height_data%units= soilhgt_data%units + height_data%map_source= soilhgt_data%map_source + height_data%desc= soilhgt_data%desc + + do k_loop = MIN(model_levels,temp_count) , first_constant_r_rho_level+1 , -1 +! height_data%xlvl = temp_count + 1 - k_loop + height_data%xlvl = k_loop + do j_loop = 1 , height_data%ny + do i_loop = 1 , height_data%nx + height_data%slab(i_loop,j_loop) = eta(k_loop) * z_top_of_model + end do + end do + + call write_next_met_field(height_data, istatus) + end do + + do k_loop = first_constant_r_rho_level , 1 , -1 +! height_data%xlvl = temp_count + 1 - k_loop + height_data%xlvl = k_loop + do j_loop = 1 , height_data%ny + do i_loop = 1 , height_data%nx + height_data%slab(i_loop,j_loop) = eta(k_loop) * z_top_of_model + & + soil_hold(i_loop,j_loop) * ( 1. - eta(k_loop) / etac ) **2 + end do + end do + + call write_next_met_field(height_data, istatus) + end do + + call write_met_close() + + call geth_newdate ( output_date , valid_date , interval_seconds * date_loop ) + date_loop = date_loop + 1 + + if ( TRIM(output_date) > TRIM(end_date(1)) ) then + still_more_dates_to_process = .false. + end if + + end do all_dates + + end if + + + call mprintf(.true.,STDOUT,' *** Successful completion of program height_ukmo.exe *** ') + + stop + +end program height_ukmo diff --git a/WPS/util/src/int2nc.F b/WPS/util/src/int2nc.F new file mode 100644 index 00000000..f4dbfe1d --- /dev/null +++ b/WPS/util/src/int2nc.F @@ -0,0 +1,281 @@ +program int2nc + +! use netcdf + use module_debug + use misc_definitions_module + use read_met_module + + implicit none + + include "netcdf.inc" + + integer, parameter :: NDIMS = 2 + integer :: istatus, dim, i, varid, ablevel, proj, nproj + real :: fcst, slat, slon, dlat, dlon, nlat, dxn, dyn + real :: xloncen, tlat1, tlat2, radius, si, sj + logical :: windrot + character (len=132) field, name, cablevel, date, source, units, desc, flnm, nfile + real, allocatable, dimension(:,:) :: data + integer :: ncid + integer, dimension(20) :: dval + integer :: dimids(NDIMS) + integer :: tmp_dims(NDIMS) + + type (met_data) :: fg_data + + character (len=*),dimension(10),parameter :: dname = (/"i1","j1","i2","j2","i3","j3","i4","j4","i5","j5"/) + character (len=*),parameter :: DATEV = "date" + character (len=*),parameter :: FCSTV = "forecast" + character (len=*),parameter :: SOURCEV = "map_source" + character (len=*),parameter :: LEVELV = "level" + character (len=*),parameter :: FIELDV = "field" + character (len=*),parameter :: UNITSV = "units" + character (len=*),parameter :: DESCV = "description" + character (len=*),parameter :: NX = "nx" + character (len=*),parameter :: NY = "ny" + character (len=*),parameter :: IPROJ = "projection" + character (len=*),parameter :: STARTI = "starti" + character (len=*),parameter :: STARTJ = "startj" + character (len=*),parameter :: STARTLAT = "startlat" + character (len=*),parameter :: STARTLON = "startlon" + character (len=*),parameter :: DELTALAT = "deltalat" + character (len=*),parameter :: DELTALON = "deltalon" + character (len=*),parameter :: NLATS = "nlats" + character (len=*),parameter :: DX = "dx" + character (len=*),parameter :: DY = "dy" + character (len=*),parameter :: XLONC = "xlonc" + character (len=*),parameter :: TRUELAT1 = "truelat1" + character (len=*),parameter :: TRUELAT2 = "truelat2" + character (len=*),parameter :: EARTH_RADIUS = "earth_radius" + character (len=*),parameter :: IS_WIND_GRID_REL = "is_wind_grid_rel" + character (len=*),parameter :: FILLVALUE = "_FillValue" + + dval = 0 + + ! Get the input file name from the command line. + call getarg (1,flnm) + + if (flnm(1:1) == ' ') then + print *,'USAGE: int2nc.exe ' + print *,' where is the name of an intermediate-format file' + stop + end if + nfile = trim(adjustl(flnm))//".nc" + + call set_debug_level(WARN) + + call read_met_init(trim(flnm), .true., '0000-00-00_00', istatus) + call check(nf_create(trim(nfile),nf_clobber,ncid)) + + print*, 'OPENING FILE: ',trim(adjustl(flnm)) + + if(istatus == 0) then + call read_next_met_field(fg_data,istatus) + do while (istatus == 0) + tmp_dims(1) = fg_data%nx + tmp_dims(2) = fg_data%ny + do dim = 1,2 + i = 1 + CHECKDIMS : DO + if(dval(i) == 0) then + dval(i) = tmp_dims(dim) + call check(nf_def_dim(ncid,dname(i),dval(i),i)) + EXIT CHECKDIMS + else + if (dval(i) == tmp_dims(dim) ) then + EXIT CHECKDIMS + end if + end if + i = i+1 + CYCLE CHECKDIMS + END DO CHECKDIMS + end do + call read_next_met_field(fg_data,istatus) + end do + else + print *, 'File = ',trim(flnm) + print *, 'Problem with input file, I can''t open it' + stop + end if + + + call read_met_close() + call check(nf_close(ncid)) + + call read_met_init(trim(flnm), .true., '0000-00-00_00', istatus) + call check(nf_open(trim(nfile),nf_write,ncid)) + + if (istatus == 0) then + call read_next_met_field(fg_data, istatus) + do while (istatus == 0) + + date = trim(adjustl(fg_data%hdate)) + fcst = fg_data%xfcst + source = fg_data%map_source + field = fg_data%field + units = fg_data%units + desc = fg_data%desc + ablevel = fg_data%xlvl + write(cablevel,'(I6)') ablevel + name = trim(adjustl(field))//"__0"//trim(adjustl(cablevel)) + print *,"Reading Field, Level: ",trim(adjustl(field)),", ",trim(adjustl(cablevel)) + + nproj = fg_data%iproj + proj = nproj + if(nproj == 1) proj = 3 + if(nproj == 3) proj = 1 + if(proj == 0) then ! Cylindrical Equidistand + si = fg_data%starti + sj = fg_data%startj + slat = fg_data%startlat + slon = fg_data%startlon + dlat = fg_data%deltalat + dlon = fg_data%deltalon + radius = fg_data%earth_radius + else if(proj == 1) then ! Mercator + si = fg_data%starti + sj = fg_data%startj + slat = fg_data%startlat + slon = fg_data%startlon + dxn = fg_data%dx + dyn = fg_data%dy + tlat1 = fg_data%truelat1 + radius = fg_data%earth_radius + else if(proj == 3) then ! Lambert Conformal + si = fg_data%starti + sj = fg_data%startj + slat = fg_data%startlat + slon = fg_data%startlon + dxn = fg_data%dx + dyn = fg_data%dy + xloncen = fg_data%xlonc + tlat1 = fg_data%truelat1 + tlat2 = fg_data%truelat2 + radius = fg_data%earth_radius + else if(proj == 4) then ! Gaussian + si = fg_data%starti + sj = fg_data%startj + slat = fg_data%startlat + slon = fg_data%startlon + nlat = fg_data%deltalat + dlon = fg_data%deltalon + radius = fg_data%earth_radius + else if(proj == 5) then ! Polar Stereographic + si = fg_data%starti + sj = fg_data%startj + slat = fg_data%startlat + slon = fg_data%startlon + dxn = fg_data%dx + dyn = fg_data%dy + xloncen = fg_data%xlonc + tlat1 = fg_data%truelat1 + radius = fg_data%earth_radius + end if + windrot = fg_data%is_wind_grid_rel + + if(allocated(data)) deallocate(data) + allocate(data(fg_data%nx,fg_data%ny)) + data = fg_data%slab + + tmp_dims(1) = fg_data%nx + tmp_dims(2) = fg_data%ny + do dim = 1,2 + i = 1 + CHECKDIMS2 : DO + if (dval(i) == tmp_dims(dim) ) then + dimids(dim) = i + EXIT CHECKDIMS2 + end if + i = i+1 + CYCLE CHECKDIMS2 + END DO CHECKDIMS2 + end do + + call check(nf_redef(ncid)) + call check(nf_def_var(ncid,name,NF_REAL,NDIMS,dimids,varid)) + call check(nf_put_att_text(ncid,varid,DATEV,132,date)) + call check(nf_put_att_real(ncid,varid,FCSTV,nf_float,1,fcst)) + call check(nf_put_att_text(ncid,varid,SOURCEV,132,source)) + call check(nf_put_att_text(ncid,varid,FIELDV,132,field)) + call check(nf_put_att_text(ncid,varid,UNITSV,132,units)) + call check(nf_put_att_text(ncid,varid,DESCV,132,desc)) + call check(nf_put_att_int (ncid,varid,LEVELV,nf_int,1,ablevel)) + call check(nf_put_att_int (ncid,varid,NX,nf_int,1,fg_data%nx)) + call check(nf_put_att_int (ncid,varid,NY,nf_int,1,fg_data%ny)) + call check(nf_put_att_int (ncid,varid,IPROJ,nf_int,1,proj)) + call check(nf_put_att_real(ncid,varid,FILLVALUE,nf_real,1,-1e30)) + + + if(proj == 0) then + call check(nf_put_att_real(ncid,varid,STARTI,nf_float,1,si)) + call check(nf_put_att_real(ncid,varid,STARTJ,nf_float,1,sj)) + call check(nf_put_att_real(ncid,varid,STARTLAT,nf_float,1,slat)) + call check(nf_put_att_real(ncid,varid,STARTLON,nf_float,1,slon)) + call check(nf_put_att_real(ncid,varid,DELTALAT,nf_float,1,dlat)) + call check(nf_put_att_real(ncid,varid,DELTALON,nf_float,1,dlon)) + call check(nf_put_att_real(ncid,varid,EARTH_RADIUS,nf_float,1,radius)) + else if(proj == 1) then + call check(nf_put_att_real(ncid,varid,STARTI,nf_float,1,si)) + call check(nf_put_att_real(ncid,varid,STARTJ,nf_float,1,sj)) + call check(nf_put_att_real(ncid,varid,STARTLAT,nf_float,1,slat)) + call check(nf_put_att_real(ncid,varid,STARTLON,nf_float,1,slon)) + call check(nf_put_att_real(ncid,varid,DX,nf_float,1,dxn)) + call check(nf_put_att_real(ncid,varid,DY,nf_float,1,dyn)) + call check(nf_put_att_real(ncid,varid,TRUELAT1,nf_float,1,tlat1)) + call check(nf_put_att_real(ncid,varid,EARTH_RADIUS,nf_float,1,radius)) + else if(proj == 3) then + call check(nf_put_att_real(ncid,varid,STARTI,nf_float,1,si)) + call check(nf_put_att_real(ncid,varid,STARTJ,nf_float,1,sj)) + call check(nf_put_att_real(ncid,varid,STARTLAT,nf_float,1,slat)) + call check(nf_put_att_real(ncid,varid,STARTLON,nf_float,1,slon)) + call check(nf_put_att_real(ncid,varid,DX,nf_float,1,dxn)) + call check(nf_put_att_real(ncid,varid,DY,nf_float,1,dyn)) + call check(nf_put_att_real(ncid,varid,XLONC,nf_float,1,xloncen)) + call check(nf_put_att_real(ncid,varid,TRUELAT1,nf_float,1,tlat1)) + call check(nf_put_att_real(ncid,varid,TRUELAT2,nf_float,1,tlat2)) + call check(nf_put_att_real(ncid,varid,EARTH_RADIUS,nf_float,1,radius)) + else if(proj == 4) then + call check(nf_put_att_real(ncid,varid,STARTI,nf_float,1,si)) + call check(nf_put_att_real(ncid,varid,STARTJ,nf_float,1,sj)) + call check(nf_put_att_real(ncid,varid,STARTLAT,nf_float,1,slat)) + call check(nf_put_att_real(ncid,varid,STARTLON,nf_float,1,slon)) + call check(nf_put_att_real(ncid,varid,NLATS,nf_float,1,nlat)) + call check(nf_put_att_real(ncid,varid,DELTALON,nf_float,1,dlon)) + call check(nf_put_att_real(ncid,varid,EARTH_RADIUS,nf_float,1,radius)) + else if(proj == 5) then + call check(nf_put_att_real(ncid,varid,STARTI,nf_float,1,si)) + call check(nf_put_att_real(ncid,varid,STARTJ,nf_float,1,sj)) + call check(nf_put_att_real(ncid,varid,STARTLAT,nf_float,1,slat)) + call check(nf_put_att_real(ncid,varid,STARTLON,nf_float,1,slon)) + call check(nf_put_att_real(ncid,varid,DX,nf_float,1,dxn)) + call check(nf_put_att_real(ncid,varid,DY,nf_float,1,dyn)) + call check(nf_put_att_real(ncid,varid,XLONC,nf_float,1,xloncen)) + call check(nf_put_att_real(ncid,varid,TRUELAT1,nf_float,1,tlat1)) + call check(nf_put_att_real(ncid,varid,EARTH_RADIUS,nf_float,1,radius)) + end if + + call check(nf_enddef(ncid)) + call check(nf_put_var_real(ncid,varid,data)) + + call read_next_met_field(fg_data,istatus) + + end do + + call read_met_close() + + end if + + call check(nf_close(ncid)) + + print *,'SUCCESSFUL COMPLETION OF PROGRAM INT2NC, ',trim(nfile),' WRITTEN.' + +contains + subroutine check(status) + integer, intent ( in) :: status + + if(status /= nf_noerr) then + print *, trim(nf_strerror(status)) + stop "Stopped" + end if + end subroutine check +end program int2nc diff --git a/WPS/util/src/met_data_module.F b/WPS/util/src/met_data_module.F new file mode 120000 index 00000000..dea75ca5 --- /dev/null +++ b/WPS/util/src/met_data_module.F @@ -0,0 +1 @@ +../../metgrid/src/met_data_module.F \ No newline at end of file diff --git a/WPS/util/src/misc_definitions_module.F b/WPS/util/src/misc_definitions_module.F new file mode 120000 index 00000000..d50acad4 --- /dev/null +++ b/WPS/util/src/misc_definitions_module.F @@ -0,0 +1 @@ +../../geogrid/src/misc_definitions_module.F \ No newline at end of file diff --git a/WPS/util/src/mod_levs.F b/WPS/util/src/mod_levs.F new file mode 100644 index 00000000..10eecf23 --- /dev/null +++ b/WPS/util/src/mod_levs.F @@ -0,0 +1,158 @@ +! Program to modify levels in the intermediate format. Two input +! files come in on the command line: input file and output file. +! An additional namelist file is used to select which pressure levels +! are to be kept. + +! NRCM helper, WPS toy code + +PROGRAM mod_levs_prog + + USE module_debug + USE read_met_module + USE write_met_module + USE misc_definitions_module + + IMPLICIT NONE + + ! Intermediate input and output from same source. + + CHARACTER ( LEN =132 ) :: flnm, flnm2 + + INTEGER :: istatus, iop + integer :: idum, ilev + + TYPE (met_data) :: fg_data + + ! The namelist has a pressure array that we want. + + LOGICAL :: keep_this_one + INTEGER :: l , max_pres_keep + INTEGER , PARAMETER :: num_pres_lev = 1000 + REAL, DIMENSION(num_pres_lev) :: press_pa = -1. + NAMELIST /mod_levs/ press_pa + + INTEGER , EXTERNAL :: lenner + + ! Open up the file with the pressure levels to process. + + OPEN ( UNIT = 10 , & + FILE = 'namelist.wps' , & + STATUS = 'OLD' , & + FORM = 'FORMATTED' , & + IOSTAT = iop ) + + IF (iop .NE. 0) then + print *, 'Error: Couldn''t open namelist.wps file.' + STOP + END IF + + ! Input the pressure levels requested. + + READ ( 10 , mod_levs, err=1000, end=1001 ) + + CLOSE ( 10 ) + + ! How many pressure levels were asked for? + + DO l = 1 , num_pres_lev + IF ( press_pa(l) .EQ. -1. ) THEN + max_pres_keep = l-1 + EXIT + END IF + END DO + + ! Get the two files: input and output. + + CALL getarg ( 1 , flnm ) + + IF ( flnm(1:1) .EQ. ' ' ) THEN + print *,'USAGE: mod_levs.exe FILE:2006-07-31_00 new_FILE:2006-07-31_00' + STOP + END IF + + CALL getarg ( 2 , flnm2 ) + + l = lenner(flnm) + IF ( flnm2(1:1) .EQ. ' ' ) THEN + flnm2(5:l+4) = flnm(1:l) + flnm2(1:4) = 'new_' + END IF + + CALL set_debug_level(WARN) + + CALL read_met_init(TRIM(flnm), .true., '0000-00-00_00', istatus) + + IF ( istatus == 0 ) THEN + + CALL write_met_init(TRIM(flnm2), .true., '0000-00-00_00', istatus) + + IF ( istatus == 0 ) THEN + + CALL read_next_met_field(fg_data, istatus) + + DO WHILE (istatus == 0) + + + keep_this_one = .FALSE. + DO l = 1 , max_pres_keep + IF ( fg_data%xlvl .EQ. press_pa(l) ) THEN + keep_this_one = .TRUE. + EXIT + END IF + END DO + + IF (keep_this_one) THEN + CALL write_next_met_field(fg_data, istatus) + ELSE + CALL mprintf(.true.,STDOUT,'Deleting level %f Pa',f1=fg_data%xlvl) + END IF + + CALL mprintf(.true.,STDOUT,'Processed %s at level %f for time %s', & + s1=fg_data%field, f1=fg_data%xlvl, s2=fg_data%hdate) + IF (ASSOCIATED(fg_data%slab)) DEALLOCATE(fg_data%slab) + + CALL read_next_met_field(fg_data, istatus) + END DO + + CALL write_met_close() + + ELSE + + print *, 'File = ',TRIM(flnm2) + print *, 'Problem with output file, I can''t open it' + STOP + + END IF + + CALL read_met_close() + + ELSE + + print *, 'File = ',TRIM(flnm) + print *, 'Problem with input file, I can''t open it' + STOP + + END IF + + print *,'SUCCESSFUL COMPLETION OF PROGRAM MOD_LEVS' + STOP + +1000 print *,'Error while reading &mod_levs namelist.' + STOP +1001 print *,'Error: Could not find &mod_levs namelist. Perhaps this namelist is not present in namelist.wps?' + STOP + +END PROGRAM mod_levs_prog + +INTEGER FUNCTION lenner ( string ) + CHARACTER ( LEN = 132 ) :: string + INTEGER :: l + DO l = 132 , 1 , -1 + IF ( ( ( string(l:l) .GE. 'A' ) .AND. ( string(l:l) .LE. 'Z' ) ) .OR. & + ( ( string(l:l) .GE. 'a' ) .AND. ( string(l:l) .LE. 'z' ) ) .OR. & + ( ( string(l:l) .GE. '0' ) .AND. ( string(l:l) .LE. '9' ) ) ) THEN + lenner = l + EXIT + END IF + END DO +END FUNCTION lenner diff --git a/WPS/util/src/module_date_pack.F b/WPS/util/src/module_date_pack.F new file mode 120000 index 00000000..5e135183 --- /dev/null +++ b/WPS/util/src/module_date_pack.F @@ -0,0 +1 @@ +../../metgrid/src/module_date_pack.F \ No newline at end of file diff --git a/WPS/util/src/module_debug.F b/WPS/util/src/module_debug.F new file mode 120000 index 00000000..3a5a2ea5 --- /dev/null +++ b/WPS/util/src/module_debug.F @@ -0,0 +1 @@ +../../geogrid/src/module_debug.F \ No newline at end of file diff --git a/WPS/util/src/module_map_utils.F b/WPS/util/src/module_map_utils.F new file mode 120000 index 00000000..58d1a4fd --- /dev/null +++ b/WPS/util/src/module_map_utils.F @@ -0,0 +1 @@ +../../geogrid/src/module_map_utils.F \ No newline at end of file diff --git a/WPS/util/src/module_stringutil.F b/WPS/util/src/module_stringutil.F new file mode 120000 index 00000000..305c294e --- /dev/null +++ b/WPS/util/src/module_stringutil.F @@ -0,0 +1 @@ +../../ungrib/src/module_stringutil.F \ No newline at end of file diff --git a/WPS/util/src/plotfmt.F b/WPS/util/src/plotfmt.F new file mode 100644 index 00000000..cc7c7b06 --- /dev/null +++ b/WPS/util/src/plotfmt.F @@ -0,0 +1,452 @@ +program plotfmt + + use read_met_module + + implicit none +! +! Utility program to plot up files created by pregrid / SI / ungrib. +! Uses NCAR graphics routines. If you don't have NCAR Graphics, you're +! out of luck. +! + INTEGER :: istatus + integer :: idum, ilev + + CHARACTER ( LEN =132 ) :: flnm + + TYPE (met_data) :: fg_data + +! +! Set up the graceful stop (Sun, SGI, DEC). +! + integer, external :: graceful_stop +#if (defined(_DOUBLEUNDERSCORE) && defined(MACOS)) || defined(NO_SIGNAL) + ! we do not do any signaling +#else + integer, external :: signal +#endif + integer :: iii + +#if (defined(_DOUBLEUNDERSCORE) && defined(MACOS)) || defined(NO_SIGNAL) + ! still more no signaling +#else + iii = signal(2, graceful_stop, -1) +#endif + + call getarg(1,flnm) + + IF ( flnm(1:1) == ' ' ) THEN + print *,'USAGE: plotfmt.exe ' + print *,' where is the name of an intermediate-format file' + STOP + END IF + + call gopks(6,idum) + call gopwk(1,55,1) + call gopwk(2,56,3) + call gacwk(1) + call gacwk(2) + call pcseti('FN', 21) + call pcsetc('FC', '~') + + call gscr(1,0, 1.000, 1.000, 1.000) + call gscr(1,1, 0.000, 0.000, 0.000) + call gscr(1,2, 0.900, 0.600, 0.600) + + CALL read_met_init(TRIM(flnm), .true., '0000-00-00_00', istatus) + + IF ( istatus == 0 ) THEN + + CALL read_next_met_field(fg_data, istatus) + + DO WHILE (istatus == 0) + + ilev = nint(fg_data%xlvl) + + if (fg_data%iproj == PROJ_LATLON) then + call plt2d(fg_data%slab, fg_data%nx, fg_data%ny, fg_data%iproj, & + fg_data%startlat, fg_data%startlon, fg_data%deltalon, & + fg_data%deltalat, fg_data%xlonc, fg_data%truelat1, fg_data%truelat2, & + fg_data%field, ilev, fg_data%units, fg_data%version, fg_data%desc, & + fg_data%map_source, TRIM(flnm)) + else + call plt2d(fg_data%slab, fg_data%nx, fg_data%ny, fg_data%iproj, & + fg_data%startlat, fg_data%startlon, fg_data%dx, fg_data%dy, fg_data%xlonc, & + fg_data%truelat1, fg_data%truelat2, fg_data%field, ilev, fg_data%units, & + fg_data%version, fg_data%desc, fg_data%map_source, TRIM(flnm)) + end if + + + IF (ASSOCIATED(fg_data%slab)) DEALLOCATE(fg_data%slab) + + CALL read_next_met_field(fg_data, istatus) + END DO + + CALL read_met_close() + + ELSE + + print *, 'File = ',TRIM(flnm) + print *, 'Problem with input file, I can''t open it' + STOP + + END IF + + call stopit + +end program plotfmt + +subroutine plt2d(tcr2d, iz, jz, llflag, & + lat1, lon1, dx, dy, lov, truelat1, truelat2, & + field, ilev, units, ifv, Desc, source, flnm) + + use misc_definitions_module + + implicit none + + integer :: llflag + integer :: iz, jz, ifv + real, dimension(iz,jz) :: tcr2d(iz,jz) + real :: lat1, lon1, lov, truelat1, truelat2 + real :: dx, dy + character(len=*) :: field + character(len=*) :: units + character(len=*) :: Desc + character(len=*) :: source + character(len=30) :: hunit + character(len=32) :: tmp32 + character (len=*) :: flnm + + integer :: iproj, ierr + real :: pl1, pl2, pl3, pl4, plon, plat, rota, phic + real :: xl, xr, xb, xt, wl, wr, wb, wt, yb + integer :: ml, ih, i, j + + integer, parameter :: lwrk = 20000, liwk = 50000 + real, dimension(lwrk) :: rwrk + integer, dimension(liwk) :: iwrk + + integer :: ilev + integer :: found_it + character(len=8) :: hlev + +! declarations for windowing + integer :: ioff, joff, i1, j1, ix, jx, funit + real, allocatable,dimension(:,:) :: scr2d + logical :: is_used, lexist + namelist /plotfmt/ ix, jx, ioff, joff + +! This version allows the plotting of subsets of a lat/lon grid (i.e. NCEP GFS). +! ix,jx are the dimensions of the subset. ioff,joff are the offsets from 1,1 + + ix = iz + jx = jz + ioff = 0 + joff = 0 + +! Read parameters from Fortran namelist + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + inquire(file='namelist.wps', exist = lexist) + if (lexist) then + open(funit,file='namelist.wps',status='old',form='formatted',err=1000) + read(funit,plotfmt,iostat=found_it) + close(funit) + if(found_it .gt. 0 ) then + print *,'error reading the plotfmt namelist record in namelist.wps' + print *,'only ix, jx, ioff, joff are recognized.' + stop 'namelist problem' + end if + end if + + +! ioff = 250 ! e.g. east of the Philippines from 0.5 degree GFS +! joff = 140 +! ix = 20 +! jx = 20 + + if (ix+ioff .gt. iz .or. jx+joff .gt. jz) then +! print *,'map subset is too large. Setting to full domain' + ix = iz + jx = jz + ioff = 0 + joff = 0 + endif +! compute upper left point for the map (works for NCEP GFS and godas) + pl1 = lat1 + (joff*dy) + pl2 = lon1 + (ioff*dx) + + allocate (scr2d(ix,jx)) + + do i = 1, ix + do j = 1, jx + i1 = i + ioff + j1 = j + joff + scr2d(i,j) = tcr2d(i1,j1) + enddo + enddo + + select case (llflag) + case (PROJ_LATLON) + call fmtxyll(float(ix), float(jx), pl3, pl4, 'CE', pl1, pl2, & + plon, truelat1, truelat2, dx, dy) + plon = (pl2 + pl4) / 2. + plat = 0. + rota = 0. + iproj=8 + case (PROJ_MERC) + pl1 = lat1 + pl2 = lon1 + plon = 0. + call fmtxyll(float(ix), float(jx), pl3, pl4, 'ME', pl1, pl2, & + plon, truelat1, truelat2, dx, dy) + plat = 0. + rota = 0 + iproj = 9 + case (PROJ_LC) + pl1 = lat1 + pl2 = lon1 + plon = lov + call fmtxyll(float(ix), float(jx), pl3, pl4, 'LC', pl1, pl2,& + plon, truelat1, truelat2, dx, dy) + plat = truelat1 + rota = truelat2 + iproj=3 +! This never used to be a problem, but currently we seem to need +! truelat1 (in plat) differ from truelat2 (in rota) for the +! NCAR-Graphics map routines to work. Maybe it's just a compiler +! thing. So if the truelats are the same, we add an epsilon: + if (abs(plat - rota) < 1.E-8) then + plat = plat + 1.E-8 + rota = rota - 1.E-8 + endif + case (PROJ_PS) + print*, 'ix, jx = ', ix, jx + print*, 'lat1, lon1 = ', lat1, lon1 + pl1 = lat1 + pl2 = lon1 + plon = lov + if (truelat1 .lt. 0. ) then + plat = -90. + else + plat = 90. + endif + print*, 'plon, plat = ', plon, plat + rota = 0. + call fmtxyll(float(ix), float(jx), pl3, pl4, 'ST', pl1, pl2,& + plon, truelat1, truelat2, dx, dy) + iproj=1 + print*, pl1, pl2, pl3, pl4 + case default + print*,'Unsupported map projection ',llflag,' in input' + stop + end select + + call gsplci(2) ! Use a different color for the map +! jlts = 2 means corner points are provided in p1,p2,pl3,pl4 + call supmap(iproj,plat,plon,rota,pl1,pl2,pl3,pl4,2,30,4,0,ierr) + call gsplci(1) +! call supmap(iproj,plat+0.001,plon,rota-0.001,pl1,pl2,pl3,pl4,2,30,4,0,ierr) + if (ierr.ne.0) then + print*, 'supmap ierr = ', ierr + stop +! stop + endif + call getset(xl,xr,xb,xt,wl,wr,wb,wt,ml) + + write(hlev,'(I8)') ilev + + call set(0., 1., 0., 1., 0., 1., 0., 1., 1) + if ( xb .lt. .16 ) then + yb = .16 ! xb depends on the projection, so fix yb and use it for labels + else + yb = xb + endif + call pchiqu(0.1, yb-0.05, hlev//' '//field, .020, 0.0, -1.0) + print*, field//'#'//units//'#'//trim(Desc) +! call pchiqu(0.1, xb-0.12, Desc, .012, 0.0, -1.0) + hunit = ' ' + ih = 0 + do i = 1, len(units) + if (units(i:i).eq.'{') then + hunit(ih+1:ih+3) = '~S~' + ih = ih + 3 + elseif (units(i:i).eq.'}') then + hunit(ih+1:ih+3) = '~N~' + ih = ih + 3 + else + ih = ih + 1 + hunit(ih:ih) = units(i:i) + endif + enddo + if ( ifv .le. 3 ) then + tmp32 = 'MM5 intermediate format' + else if ( ifv .eq. 4 ) then + tmp32 = 'SI intermediate format' + else if ( ifv .eq. 5 ) then + tmp32 = 'WPS intermediate format' + endif + call pchiqu(0.1, yb-0.09, hunit, .015, 0.0, -1.0) + call pchiqu(0.1, yb-0.12, Desc, .013, 0.0, -1.0) + call pchiqu(0.6, yb-0.12, source, .013, 0.0, -1.0) + call pchiqu(0.1, yb-0.15, tmp32, .013, 0.0, -1.0) + call pchiqu(0.6, yb-0.15, flnm, .013, 0.0, -1.0) + + call set(xl,xr,xb,xt,1.,float(ix),1.,float(jx),ml) + + call CPSETI ('SET - Do-SET-Call Flag', 0) + call CPSETR ('SPV - Special Value', -1.E30) + + call cpseti('LLP', 3) + + if (dy.lt.0.) then + call array_flip(scr2d, ix, jx) + endif + + call cprect(scr2d,ix,ix,jx,rwrk,lwrk,iwrk,liwk) + call cpcldr(scr2d,rwrk,iwrk) + call cplbdr(scr2d,rwrk,iwrk) + + deallocate (scr2d) + call frame + return +1000 write(0,*) 'Error opening file namelist.wps, Stopping' + stop 'namelist missing' + +end subroutine plt2d + +subroutine stopit + call graceful_stop +end + +subroutine graceful_stop + call gdawk(2) + call gdawk(1) + call gclwk(2) + call gclwk(1) + call gclks + print*, 'Graceful Stop.' + stop +end subroutine graceful_stop + +subroutine fmtxyll(x, y, xlat, xlon, project, glat1, glon1, gclon,& + gtrue1, gtrue2, gdx, gdy) + implicit none + + real , intent(in) :: x, y, glat1, glon1, gtrue1, gtrue2, gdx, gdy, gclon + character(len=2), intent(in) :: project + real , intent(out) :: xlat, xlon + + real :: gx1, gy1, gkappa + real :: grrth = 6370., phist, phemi + + real :: r, y1 + integer :: iscan, jscan + real, parameter :: pi = 3.1415926534 + real, parameter :: degran = pi/180. + real, parameter :: raddeg = 180./pi + real :: gt + + if (project.eq.'CE') then ! Cylindrical Equidistant grid + + xlat = glat1 + gdy*(y-1.) + xlon = glon1 + gdx*(x-1.) + + elseif (project == "ME") then + + gt = grrth * cos(gtrue1*degran) + xlon = glon1 + (gdx*(x-1.)/gt)*raddeg + y1 = gt*alog((1.+sin(glat1*degran))/cos(glat1*degran))/gdy + xlat = 90. - 2. * atan(exp(-gdy*(y+y1-1.)/gt))*raddeg + + elseif (project.eq.'ST') then ! Polar Stereographic grid + + if (gtrue1 .lt. 0.)then + phemi = -1. + else + phemi = 1. + endif + r = grrth/gdx * tand((phemi*90. - glat1)/2.) * (1.+ phemi * sind(gtrue1)) + gx1 = r * sind(glon1-gclon) + gy1 = - r * cosd(glon1-gclon) + + r = sqrt((x-1.+gx1)**2 + (y-1+gy1)**2) + xlat = phemi*90. - 2.*atan2d((r*gdx),(grrth*(1.+ phemi*sind(gtrue1)))) + xlon = atan2d((x-1.+gx1),-(y-1.+gy1)) + gclon + + elseif (project.eq.'LC') then ! Lambert-conformal grid + + call glccone(gtrue1, gtrue2, 1, gkappa) + + r = grrth/(gdx*gkappa)*sind(90.-gtrue1) * & + (tand(45.-glat1/2.)/tand(45.-gtrue1/2.)) ** gkappa + gx1 = r*sind(gkappa*(glon1-gclon)) + gy1 = -r*cosd(gkappa*(glon1-gclon)) + + r = sqrt((x-1.+gx1)**2 + (y-1+gy1)**2) + xlat = 90. - 2.*atand(tand(45.-gtrue1/2.)* & + ((r*gkappa*gdx)/(grrth*sind(90.-gtrue1)))**(1./gkappa)) + xlon = atan2d((x-1.+gx1),-(y-1.+gy1))/gkappa + gclon + + else + + write(*,'("Unrecoginzed projection: ", A)') project + write(*,'("Abort in FMTXYLL",/)') + stop + + endif +contains + real function sind(theta) + real :: theta + sind = sin(theta*degran) + end function sind + real function cosd(theta) + real :: theta + cosd = cos(theta*degran) + end function cosd + real function tand(theta) + real :: theta + tand = tan(theta*degran) + end function tand + real function atand(x) + real :: x + atand = atan(x)*raddeg + end function atand + real function atan2d(x,y) + real :: x,y + atan2d = atan2(x,y)*raddeg + end function atan2d + + subroutine glccone (fsplat,ssplat,sign,confac) + implicit none + real, intent(in) :: fsplat,ssplat + integer, intent(in) :: sign + real, intent(out) :: confac + if (abs(fsplat-ssplat).lt.1.E-3) then + confac = sind(fsplat) + else + confac = log10(cosd(fsplat))-log10(cosd(ssplat)) + confac = confac/(log10(tand(45.-float(sign)*fsplat/2.))- & + log10(tand(45.-float(sign)*ssplat/2.))) + endif + end subroutine glccone + +end subroutine fmtxyll + +subroutine array_flip(array, ix, jx) + implicit none + integer :: ix, jx + real , dimension(ix,jx) :: array + + real, dimension(ix) :: hold + integer :: i, j, jj + + do j = 1, jx/2 + jj = jx+1-j + hold = array(1:ix, j) + array(1:ix,j) = array(1:ix,jj) + array(1:ix,jj) = hold + enddo +end subroutine array_flip + diff --git a/WPS/util/src/plotgrids.F b/WPS/util/src/plotgrids.F new file mode 100644 index 00000000..60ac6884 --- /dev/null +++ b/WPS/util/src/plotgrids.F @@ -0,0 +1,740 @@ +program plotgrids + + use map_utils + + implicit none + + ! Parameters + integer, parameter :: MAX_DOMAINS = 21 + + ! Variables + integer :: iproj_type, n_domains, io_form_output, dyn_opt + integer :: i, j, max_dom, funit, io_form_geogrid + integer :: interval_seconds + + integer, dimension(MAX_DOMAINS) :: parent_grid_ratio, parent_id, ixdim, jydim + integer, dimension(MAX_DOMAINS) :: i_parent_start, j_parent_start, & + s_we, e_we, s_sn, e_sn, & + start_year, start_month, start_day, start_hour, & + end_year, end_month, end_day, end_hour + logical, dimension(MAX_DOMAINS) :: active_grid + + real :: known_lat, known_lon, stand_lon, truelat1, truelat2, known_x, known_y, & + dxkm, dykm, ref_lat, ref_lon, ref_x, ref_y + real :: dx, dy + real :: ri, rj, rlats, rlons, rlate, rlone + real :: polat , rot + real :: rparent_gridpts + real :: xa,xb,ya,yb,xxa,xxy,yya,yyb + real :: xs, xe, ys, ye + integer :: jproj, jgrid, jlts, iusout, idot, ier + integer :: ltype , idom + + real, dimension(MAX_DOMAINS) :: parent_ll_x, parent_ll_y, parent_ur_x, parent_ur_y + + character (len=128) :: geog_data_path, opt_output_from_geogrid_path, opt_geogrid_tbl_path + character (len=128), dimension(MAX_DOMAINS) :: geog_data_res + character (len=128) :: map_proj + character (len=128), dimension(MAX_DOMAINS) :: start_date, end_date + character (len=3) :: wrf_core + character (len=1) :: gridtype + + logical :: do_tiled_output + integer :: debug_level + logical :: is_used + logical :: nocolons + integer :: isize + + type (proj_info) :: map_projection + + namelist /share/ wrf_core, max_dom, start_date, end_date, & + start_year, end_year, start_month, end_month, & + start_day, end_day, start_hour, end_hour, & + interval_seconds, io_form_geogrid, opt_output_from_geogrid_path, & + debug_level, active_grid, nocolons + namelist /geogrid/ parent_id, parent_grid_ratio, & + i_parent_start, j_parent_start, s_we, e_we, s_sn, e_sn, & + map_proj, ref_x, ref_y, ref_lat, ref_lon, & + truelat1, truelat2, stand_lon, dx, dy, & + geog_data_res, geog_data_path, opt_geogrid_tbl_path + + ! Set defaults for namelist variables + debug_level = 0 + io_form_geogrid = 2 + wrf_core = 'ARW' + max_dom = 1 + geog_data_path = 'NOT_SPECIFIED' + ref_x = NAN + ref_y = NAN + ref_lat = NAN + ref_lon = NAN + dx = 10000. + dy = 10000. + map_proj = 'Lambert' + truelat1 = NAN + truelat2 = NAN + stand_lon = NAN + do i=1,MAX_DOMAINS + geog_data_res(i) = 'default' + parent_id(i) = 1 + parent_grid_ratio(i) = INVALID + s_we(i) = 1 + e_we(i) = INVALID + s_sn(i) = 1 + e_sn(i) = INVALID + start_year(i) = 0 + start_month(i) = 0 + start_day(i) = 0 + start_hour(i) = 0 + end_year(i) = 0 + end_month(i) = 0 + end_day(i) = 0 + end_hour(i) = 0 + start_date(i) = '0000-00-00_00:00:00' + end_date(i) = '0000-00-00_00:00:00' + end do + opt_output_from_geogrid_path = './' + opt_geogrid_tbl_path = 'geogrid/' + interval_seconds = INVALID + + ! Read parameters from Fortran namelist + do funit=10,100 + inquire(unit=funit, opened=is_used) + if (.not. is_used) exit + end do + open(funit,file='namelist.wps',status='old',form='formatted',err=1000) + read(funit,share) + read(funit,geogrid) + close(funit) + + dxkm = dx + dykm = dy + + known_lat = ref_lat + known_lon = ref_lon + known_x = ref_x + known_y = ref_y + + ! Convert wrf_core to uppercase letters + do i=1,3 + if (ichar(wrf_core(i:i)) >= 97) wrf_core(i:i) = char(ichar(wrf_core(i:i))-32) + end do + + ! Before doing anything else, we must have a valid grid type + gridtype = ' ' + if (wrf_core == 'ARW') then + gridtype = 'C' + dyn_opt = 2 + else if (wrf_core == 'NMM') then + gridtype = 'E' + dyn_opt = 4 + end if + + if (gridtype /= 'C' .and. gridtype /= 'E') then + write(6,*) 'A valid wrf_core must be specified in the namelist. '// & + 'Currently, only "ARW" and "NMM" are supported.' + stop + end if + + if (max_dom > MAX_DOMAINS) then + write(6,*) 'In namelist, max_dom must be <= ',MAX_DOMAINS,'. To run with more'// & + ' than ',MAX_DOMAINS,' domains, increase the MAX_DOMAINS parameter.' + stop + end if + + ! Every domain must have a valid parent id + do i=2,max_dom + if (parent_id(i) <= 0 .or. parent_id(i) >= i) then + write(6,*) 'In namelist, the parent_id of domain ',i,' must be in '// & + 'the range 1 to ',i-1 + stop + end if + end do + + ! Convert map_proj to uppercase letters + do i=1,len(map_proj) + if (ichar(map_proj(i:i)) >= 97) map_proj(i:i) = char(ichar(map_proj(i:i))-32) + end do + + ! Assign parameters to module variables + if ((index(map_proj, 'LAMBERT') /= 0) .and. & + (len_trim(map_proj) == len('LAMBERT'))) then + iproj_type = PROJ_LC + rot=truelat1 + polat=truelat2 + jproj = 3 + + else if ((index(map_proj, 'MERCATOR') /= 0) .and. & + (len_trim(map_proj) == len('MERCATOR'))) then + iproj_type = PROJ_MERC + rot=0. + polat=0. + jproj = 9 + + else if ((index(map_proj, 'POLAR') /= 0) .and. & + (len_trim(map_proj) == len('POLAR'))) then + iproj_type = PROJ_PS + rot=0. + polat=SIGN(90., ref_lat) + jproj = 1 + + else if ((index(map_proj, 'ROTATED_LL') /= 0) .and. & + (len_trim(map_proj) == len('ROTATED_LL'))) then + iproj_type = PROJ_ROTLL + + else + write(6,*) 'In namelist, invalid map_proj specified. Valid '// & + 'projections are "lambert", "mercator", "polar", '// & + 'and "rotated_ll".' + stop + end if + + n_domains = max_dom + + do i=1,n_domains + ixdim(i) = e_we(i) - s_we(i) + 1 + jydim(i) = e_sn(i) - s_sn(i) + 1 + end do + + ! If the user hasn't supplied a known_x and known_y, assume the center of domain 1 + if (known_x == NAN) known_x = ixdim(1) / 2. + if (known_y == NAN) known_y = jydim(1) / 2. + + ! Checks specific to C grid + if (gridtype == 'C') then + + ! C grid does not support the rotated lat/lon projection + if (iproj_type == PROJ_ROTLL) then + write(6,*) 'Rotated lat/lon projection is not supported for the ARW core. '// & + 'Valid projecitons are "lambert", "mercator", and "polar".' + stop + end if + + ! Check that nests have an acceptable number of grid points in each dimension + do i=2,n_domains + rparent_gridpts = real(ixdim(i)-1)/real(parent_grid_ratio(i)) + if (floor(rparent_gridpts) /= ceiling(rparent_gridpts)) then + write(6,*) 'For nest ',i,' (e_we-s_we+1) must be one greater than an '// & + 'integer multiple of the parent_grid_ratio.' + write(6,*) 'Current values are s_we(i) = ',s_we(i),' e_we(i) = ',e_we(i) + isize = nint(real(ixdim(i)-1)/real(parent_grid_ratio(i))) + write(6,*) 'An e_we = ',isize * parent_grid_ratio(i) + 1,' might work' + stop + end if + rparent_gridpts = real(jydim(i)-1)/real(parent_grid_ratio(i)) + if (floor(rparent_gridpts) /= ceiling(rparent_gridpts)) then + write(6,*) 'For nest ',i,' (e_sn-s_sn+1) must be one greater than an '// & + 'integer multiple of the parent_grid_ratio.' + write(6,*) ' Current values are, s_sn(i) = ',s_sn(i),' e_sn(i) = ',e_sn(i) + isize = nint(real(jydim(i)-1)/real(parent_grid_ratio(i))) + write(6,*) 'An e_sn = ',isize * parent_grid_ratio(i) + 1,' might work' + stop + end if + end do + end if + + ! Checks specific to E grid + if (gridtype == 'E') then + + ! E grid supports only the rotated lat/lon projection + if (iproj_type /= PROJ_ROTLL) then + write(6,*) 'Rotated lat/lon is the only supported projection for the NMM core.' + stop + end if + + ! Check that the parent_grid_ratio is set to 3 for all nests + do i=2,n_domains + if (parent_grid_ratio(i) /= 3) then + write(6,*) 'The parent_grid_ratio must be set to 3 for the NMM core.' + stop + end if + end do + + CALL plot_e_grid ( ref_lat , -1. * ref_lon , & + dy , dx, & + n_domains , & + e_we , e_sn , & + parent_id , parent_grid_ratio , & + i_parent_start , j_parent_start ) + stop + end if + + do i=1,n_domains + parent_ll_x(i) = real(i_parent_start(i)) + parent_ll_y(i) = real(j_parent_start(i)) + parent_ur_x(i) = real(i_parent_start(i))+real(ixdim(i))/real(parent_grid_ratio(i))-1. + parent_ur_y(i) = real(j_parent_start(i))+real(jydim(i))/real(parent_grid_ratio(i))-1. + end do + + call map_init(map_projection) + + call map_set(iproj_type, map_projection, & + lat1=known_lat, & + lon1=known_lon, & + knowni=known_x, & + knownj=known_y, & + dx=dx, & + stdlon=stand_lon, & + truelat1=truelat1, & + truelat2=truelat2, & + ixdim=ixdim(1), & + jydim=jydim(1)) + + call ij_to_latlon(map_projection, 0.5, 0.5, rlats, rlons) + call ij_to_latlon(map_projection, real(e_we(1))-0.5, real(e_sn(1))-0.5, rlate, rlone) + + call opngks + + ! Set some colors + call gscr(1, 0, 1.00, 1.00, 1.00) + call gscr(1, 1, 0.00, 0.00, 0.00) + + ! Do not grind them with details + jgrid=10 + jlts=-2 + iusout=1 + idot=0 + + call supmap(jproj,polat,stand_lon,rot,& + rlats,rlons,rlate,rlone, & + jlts,jgrid,iusout,idot,ier) + + call setusv('LW',1000) + call perim(e_we(1)-1,1,e_sn(1)-1,1) + call getset(xa,xb,ya,yb,xxa,xxy,yya,yyb,ltype) + call set (xa,xb,ya,yb, & + 1.,real(e_we(1)),1.,real(e_sn(1)),ltype) + + do idom = 2 , max_dom + call getxy ( xs, xe, ys, ye, & + idom , max_dom , & + e_we , e_sn , & + parent_id , parent_grid_ratio , & + i_parent_start , j_parent_start ) + call line ( xs , ys , xe , ys ) + call line ( xe , ys , xe , ye ) + call line ( xe , ye , xs , ye ) + call line ( xs , ye , xs , ys ) + end do + + call frame + + write(6,*) ' ' + write(6,*) 'Creating plot in NCAR Graphics metafile...' + write(6,*) ' ' + + call clsgks + + write(6,*) ' *** Successful completion of program plotgrids.exe *** ' + + + stop + +1000 write(6,*) 'Error opening namelist.wps' + stop + +end program plotgrids + +subroutine getxy ( xs, xe, ys, ye, & + dom_id , num_domains , & + e_we , e_sn , & + parent_id , parent_grid_ratio , & + i_parent_start , j_parent_start ) + + implicit none + + integer , intent(in) :: dom_id + integer , intent(in) :: num_domains + integer , intent(in) , dimension(num_domains):: e_we , e_sn , & + parent_id , parent_grid_ratio , & + i_parent_start , j_parent_start + real , intent(out) :: xs, xe, ys, ye + + + ! local vars + + integer :: idom + + xs = 0. + xe = e_we(dom_id) -1 + ys = 0. + ye = e_sn(dom_id) -1 + + idom = dom_id + compute_xy : DO + + xs = (i_parent_start(idom) + xs -1 ) / & + real(parent_grid_ratio(parent_id(idom))) + xe = xe / real(parent_grid_ratio(idom)) + + ys = (j_parent_start(idom) + ys -1 ) / & + real(parent_grid_ratio(parent_id(idom))) + ye = ye / real(parent_grid_ratio(idom)) + + idom = parent_id(idom) + if ( idom .EQ. 1 ) then + exit compute_xy + end if + + END DO compute_xy + + xs = xs + 1 + xe = xs + xe + ys = ys + 1 + ye = ys + ye + +end subroutine getxy + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!! E GRID MAP INFO BELOW !!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SUBROUTINE plot_e_grid ( rlat0d , rlon0d , dphd , dlmd, & + n_domains , & + e_we , e_sn , & + parent_id , parent_grid_ratio , & + i_parent_start , j_parent_start ) + +! This routine generates a gmeta file of the area covered by an Arakawa e-grid. +! We assume that NCAR Graphics has not been called yet (and will be closed +! upon exit). The required input fields are as from the WPS namelist file. + + IMPLICIT NONE + +! 15 April 2005 NCEP/EMC +! The Code and some instructions are provided by Tom BLACK to +! NCAR/DTC Meral Demirtas + +! 4 May 2005 NCAR/DTC Meral DEMIRTAS +! - An include file (plot_inc) is added to get +! Domain size: IM,JM +! Central latitute and longnitute: RLAT0D,RLON0D +! Horizontal resolution: DPHD, DLMD + +! Feb 2007 NCAR/MMM +! Turn into f90 +! Add implicit none +! Remove non-mapping portions +! Make part of WPS domain plotting utility + +! Dec 2008 NCAR/DTC +! Pass additional arguments to enable plotting of nests + + ! Input map parameters for E grid. + + REAL , INTENT(IN) :: rlat0d , & ! latitude of grid center (degrees) + rlon0d ! longitude of grid center (degrees, times -1) + + REAL , INTENT(IN) :: dphd , & ! angular distance between rows (degrees) + dlmd ! angular distance between adjacent H and V points (degrees) + + INTEGER , INTENT(in) :: n_domains ! number of domains + INTEGER , INTENT(in) , DIMENSION(n_domains):: e_we , & + e_sn , & + parent_id , & + parent_grid_ratio , & + i_parent_start , & + j_parent_start + + ! Some local vars + + REAL :: rlat1d , & + rlon1d + + INTEGER :: im, & ! number of H points in odd rows + jm , & ! number of rows + ngpwe , & + ngpsn , & + ilowl , & + jlowl + + INTEGER :: imt , imtjm + REAL :: latlft,lonlft,latrgt,lonrgt + + im = e_we(1)-1 + jm = e_sn(1)-1 + + imt=2*im-1 + imtjm=imt*jm + rlat1d=rlat0d + rlon1d=rlon0d + ngpwe=2*im-1 + ngpsn=jm + + ! Get lat and lon of left and right points. + + CALL corners ( rlat1d,rlon1d,im,jm,rlat0d,rlon0d,dphd,dlmd,& + ngpwe,ngpsn,ilowl,jlowl,latlft,lonlft,latrgt,lonrgt) + + ! With corner points, make map background. + + CALL mapbkg_egrid ( imt,jm,ilowl,jlowl,ngpwe,ngpsn,& + rlat0d,rlon0d,latlft,lonlft,latrgt,lonrgt,& + dlmd,dphd,& + n_domains,& + e_we,e_sn,& + parent_id,parent_grid_ratio,& + i_parent_start,j_parent_start) + +END SUBROUTINE plot_e_grid + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SUBROUTINE corners ( glatd,glond,im,jm,tph0d,tlm0d,dphd,dlmd,& + ngpwe,ngpsn,ilowl,jlowl,glatl,glonl,glatr,glonr) + + IMPLICIT NONE + + REAL , INTENT(IN) :: glatd,glond,tph0d,tlm0d,dphd,dlmd,& + glatl,glonl,glatr,glonr + + INTEGER , INTENT(IN) :: im,jm,ngpwe,ngpsn + INTEGER , INTENT(OUT) :: ilowl,jlowl + + ! Local vars + + REAL , PARAMETER :: d2r = 1.74532925E-2 , r2D = 1./D2R + + REAL :: glat , glon , dph , dlm , tph0 , tlm0 + REAL :: x , y , z , tlat , tlon , tlat1 , tlat2 , tlon1 , tlon2 + REAL :: row , col + REAL :: dlm1 , dlm2 , d1 , d2 , d3 , d4 , dmin + + INTEGER :: jmt , ii , jj , iuppr , juppr + INTEGER :: nrow , ncol + + jmt = jm/2+1 + + ! Convert from geodetic to transformed coordinates (degrees). + + glat = glatd * d2r + glon = glond * d2r + dph = dphd * d2r + dlm = dlmd * d2r + tph0 = tph0d * d2r + tlm0 = tlm0d * d2r + + x = COS(tph0) * COS(glat) * COS(glon-tlm0)+SIN(tph0) * SIN(glat) + y = -COS(glat) * SIN(glon-tlm0) + z = COS(tph0) * SIN(glat)-SIN(tph0) * COS(glat) * COS(glon-tlm0) + tlat = r2d * ATAN(z/SQRT(x*x + y*y)) + tlon = r2d * ATAN(y/x) + + ! Find the real (non-integer) row and column of the input location on + ! the filled e-grid. + + row = tlat/dphd+jmt + col = tlon/dlmd+im + nrow = INT(row) + ncol = INT(col) + tlat = tlat * d2r + tlon = tlon * d2r + +! E2 E3 +! +! +! X +! E1 E4 + + tlat1 = (nrow-jmt) * dph + tlat2 = tlat1+dph + tlon1 = (ncol-im) * dlm + tlon2 = tlon1+dlm + + dlm1 = tlon-tlon1 + dlm2 = tlon-tlon2 + + d1 = ACOS(COS(tlat) * COS(tlat1) * COS(dlm1)+SIN(tlat) * SIN(tlat1)) + d2 = ACOS(COS(tlat) * COS(tlat2) * COS(dlm1)+SIN(tlat) * SIN(tlat2)) + d3 = ACOS(COS(tlat) * COS(tlat2) * COS(dlm2)+SIN(tlat) * SIN(tlat2)) + d4 = ACOS(COS(tlat) * COS(tlat1) * COS(dlm2)+SIN(tlat) * SIN(tlat1)) + + dmin = MIN(d1,d2,d3,d4) + + IF ( ABS(dmin-d1) .LT. 1.e-6 ) THEN + ii = ncol + jj = nrow + ELSE IF ( ABS(dmin-d2) .LT. 1.e-6 ) THEN + ii = ncol + jj = nrow+1 + ELSE IF ( ABS(dmin-d3) .LT. 1.e-6 ) THEN + ii = ncol+1 + jj = nrow+1 + ELSE IF ( ABS(dmin-d4) .LT. 1.e-6 ) THEN + ii = ncol+1 + jj = nrow + END IF + + ! Now find the i and j of the lower left corner of the desired grid + ! region and of the upper right. + + ilowl = ii-ngpwe/2 + jlowl = jj-ngpsn/2 + iuppr = ii+ngpwe/2 + juppr = jj+ngpsn/2 + + ! Find their geodetic coordinates. + + CALL e2t2g(ilowl,jlowl,im,jm,tph0d,tlm0d,dphd,dlmd,glatl,glonl) + CALL e2t2g(iuppr,juppr,im,jm,tph0d,tlm0d,dphd,dlmd,glatr,glonr) + +END SUBROUTINE corners + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SUBROUTINE mapbkg_egrid ( imt,jm,ilowl,jlowl,ngpwe,ngpsn,& + rlat0d,rlon0d,glatl,glonl,glatr,glonr,& + dlmd,dphd,& + n_domains,& + e_we,e_sn,& + parent_id,parent_grid_ratio,& + i_parent_start , j_parent_start ) + +! IMPLICIT NONE + + INTEGER , INTENT(in) :: n_domains + INTEGER , INTENT(in) , DIMENSION(n_domains):: e_we , e_sn , & + parent_id , parent_grid_ratio , & + i_parent_start , j_parent_start + + ! Some local vars + + CHARACTER (LEN=97) :: string + INTEGER :: i + REAL :: xs, xe, ys, ye + + ! Yet more center lon messing around, hoo boy. + +! clonx=180.-rlon0d + clonx=-rlon0d + + ! Open up NCAR Graphics + + CALL opngks + CALL gopwk(8,9,3) + CALL gsclip(0) + + ! Make the background white, and the foreground black. + + CALL gscr ( 1 , 0 , 1., 1., 1. ) + CALL gscr ( 1 , 1 , 0., 0., 0. ) + + ! Line width default thickness. + + CALL setusv('LW',1000) + + ! Make map outline a solid line, not dots. + + CALL mapsti('MV',8) + CALL mapsti('DO',0) + + ! Map outlines are political and states. + + CALL mapstc('OU','PS') + + ! Cylindrical equidistant. + + CALL maproj('CE',rlat0d,clonx,0.) + + ! Specify corner points. + + CALL mapset('CO',glatl,glonl,glatr,glonr) + + ! Lat lon lines every 5 degrees. + + CALL mapsti('GR',5) + + ! Map takes up this much real estate. + + CALL mappos( 0.05 , 0.95 , 0.05 , 0.95 ) + + ! Initialize and draw map. + + CALL mapint + CALL mapdrw + + ! Line width twice default thickness. + + CALL setusv('LW',2000) + + ! Add approx grid point tick marks + + CALL perim(((imt+3)/2)-1,1,jm-1,1) + + ! Line width default thickness. + + CALL setusv('LW',1000) + + ! Put on a quicky description. + + WRITE ( string , FMT = '("E-GRID E_WE = ",I4,", E_SN = ",I4 , & + &", DX = ",F6.4,", DY = ",F6.4 , & + &", REF_LAT = ",F8.3,", REF_LON = ",F8.3)') & + (imt+3)/2,jm+1,dlmd,dphd,rlat0d,-1.*rlon0d + CALL getset(xa,xb,ya,yb,xxa,xxy,yya,yyb,ltype) + CALL pchiqu(xxa,yya-(yyb-yya)/20.,string,8.,0.,-1.) + CALL set (xa,xb,ya,yb,& + 1.,real(e_we(1)),1.,real(e_sn(1)),ltype) + + ! Line width twice default thickness. + + CALL setusv('LW',2000) + + ! Draw a box for each nest. + + do i=2 , n_domains + call getxy ( xs, xe, ys, ye, & + i , n_domains , & + e_we , e_sn , & + parent_id , parent_grid_ratio , & + i_parent_start , j_parent_start ) + + call line ( xs , ys , xe , ys ) + call line ( xe , ys , xe , ye ) + call line ( xe , ye , xs , ye ) + call line ( xs , ye , xs , ys ) + end do + + CALL frame + + ! Close workstation and NCAR Grpahics. + + CALL gclwk(8) + CALL clsgks + +END SUBROUTINE mapbkg_egrid + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +SUBROUTINE e2t2g ( ncol,nrow,im,jm,tph0d,tlm0d,dphd,dlmd,glatd,glond) + +! IMPLICIT NONE + + REAL , PARAMETER :: D2R=1.74532925E-2 , R2D=1./D2R + + DPH=DPHD*D2R + DLM=DLMD*D2R + TPH0=TPH0D*D2R + TLM0=TLM0D*D2R + +!*** FIND THE TRANSFORMED LAT (POSITIVE NORTH) AND LON (POSITIVE EAST) + + TLATD=(NROW-(JM+1)/2)*DPHD + TLOND=(NCOL-IM)*DLMD + +!*** NOW CONVERT TO GEODETIC LAT (POSITIVE NORTH) AND LON (POSITIVE EAST) + + TLATR=TLATD*D2R + TLONR=TLOND*D2R + ARG1=SIN(TLATR)*COS(TPH0)+COS(TLATR)*SIN(TPH0)*COS(TLONR) + GLATR=ASIN(ARG1) + GLATD=GLATR*R2D + ARG2=COS(TLATR)*COS(TLONR)/(COS(GLATR)*COS(TPH0))- & + TAN(GLATR)*TAN(TPH0) + IF(ABS(ARG2).GT.1.)ARG2=ABS(ARG2)/ARG2 + FCTR=1. + IF(TLOND.GT.0.)FCTR=-1. + GLOND=TLM0D+FCTR*ACOS(ARG2)*R2D + GLOND=-GLOND + +END SUBROUTINE e2t2g diff --git a/WPS/util/src/rd_intermediate.F b/WPS/util/src/rd_intermediate.F new file mode 100644 index 00000000..c5e4beda --- /dev/null +++ b/WPS/util/src/rd_intermediate.F @@ -0,0 +1,115 @@ +PROGRAM rd_intermediate + + USE module_debug + USE misc_definitions_module + USE read_met_module + + IMPLICIT NONE + + ! Intermediate input and output from same source. + + INTEGER :: istatus + TYPE (met_data) :: fg_data + + CHARACTER ( LEN =132 ) :: flnm + + + ! Get the input file name from the command line. + CALL getarg ( 1 , flnm ) + + IF ( flnm(1:1) == ' ' ) THEN + print *,'USAGE: rd_intermediate.exe ' + print *,' where is the name of an intermediate-format file' + STOP + END IF + + CALL set_debug_level(WARN) + + CALL read_met_init(trim(flnm), .true., '0000-00-00_00', istatus) + + IF ( istatus == 0 ) THEN + + CALL read_next_met_field(fg_data, istatus) + + DO WHILE (istatus == 0) + + CALL mprintf(.true.,STDOUT, '================================================') + CALL mprintf(.true.,STDOUT, 'FIELD = %s', s1=fg_data%field) + CALL mprintf(.true.,STDOUT, 'UNITS = %s DESCRIPTION = %s', s1=fg_data%units, s2=fg_data%desc) + CALL mprintf(.true.,STDOUT, 'DATE = %s FCST = %f', s1=fg_data%hdate, f1=fg_data%xfcst) + CALL mprintf(.true.,STDOUT, 'SOURCE = %s', s1=fg_data%map_source) + CALL mprintf(.true.,STDOUT, 'LEVEL = %f', f1=fg_data%xlvl) + CALL mprintf(.true.,STDOUT, 'I,J DIMS = %i, %i', i1=fg_data%nx, i2=fg_data%ny) + + SELECT CASE ( fg_data%iproj ) + CASE (PROJ_LATLON) + CALL mprintf(.true.,STDOUT, 'IPROJ = %i PROJECTION = %s', i1=0, s1='LAT LON') + CALL mprintf(.true.,STDOUT,' REF_X, REF_Y = %f, %f', f1=fg_data%starti, f2=fg_data%startj) + CALL mprintf(.true.,STDOUT,' REF_LAT, REF_LON = %f, %f', f1=fg_data%startlat, f2=fg_data%startlon) + CALL mprintf(.true.,STDOUT,' DLAT, DLON = %f, %f', f1=fg_data%deltalat, f2=fg_data%deltalon) + CALL mprintf(.true.,STDOUT,' EARTH_RADIUS = %f', f1=fg_data%earth_radius) + CASE (PROJ_MERC) + CALL mprintf(.true.,STDOUT, 'IPROJ = %i PROJECTION = %s', i1=1, s1='MERCATOR') + CALL mprintf(.true.,STDOUT,' REF_X, REF_Y = %f, %f', f1=fg_data%starti, f2=fg_data%startj) + CALL mprintf(.true.,STDOUT,' REF_LAT, REF_LON = %f, %f', f1=fg_data%startlat, f2=fg_data%startlon) + CALL mprintf(.true.,STDOUT,' DX, DY = %f, %f', f1=fg_data%dx, f2=fg_data%dy) + CALL mprintf(.true.,STDOUT,' TRUELAT1 = %f', f1=fg_data%truelat1) + CALL mprintf(.true.,STDOUT,' EARTH_RADIUS = %f', f1=fg_data%earth_radius) + CASE (PROJ_LC) + CALL mprintf(.true.,STDOUT, 'IPROJ = %i PROJECTION = %s', i1=3, s1='LAMBERT CONFORMAL') + CALL mprintf(.true.,STDOUT,' REF_X, REF_Y = %f, %f', f1=fg_data%starti, f2=fg_data%startj) + CALL mprintf(.true.,STDOUT,' REF_LAT, REF_LON = %f, %f', f1=fg_data%startlat, f2=fg_data%startlon) + CALL mprintf(.true.,STDOUT,' DX, DY = %f, %f', f1=fg_data%dx, f2=fg_data%dy) + CALL mprintf(.true.,STDOUT,' STAND_LON = %f', f1=fg_data%xlonc) + CALL mprintf(.true.,STDOUT,' TRUELAT1 = %f', f1=fg_data%truelat1) + CALL mprintf(.true.,STDOUT,' TRUELAT2 = %f', f1=fg_data%truelat2) + CALL mprintf(.true.,STDOUT,' EARTH_RADIUS = %f', f1=fg_data%earth_radius) + CASE (PROJ_GAUSS) + CALL mprintf(.true.,STDOUT, 'IPROJ = %i PROJECTION = %s', i1=4, s1='GAUSSIAN') + CALL mprintf(.true.,STDOUT,' REF_X, REF_Y = %f, %f', f1=fg_data%starti, f2=fg_data%startj) + CALL mprintf(.true.,STDOUT,' REF_LAT, REF_LON = %f, %f', f1=fg_data%startlat, f2=fg_data%startlon) + CALL mprintf(.true.,STDOUT,' NLATS, DLON = %f, %f', f1=fg_data%deltalat, f2=fg_data%deltalon) + CALL mprintf(.true.,STDOUT,' EARTH_RADIUS = %f', f1=fg_data%earth_radius) + CASE (PROJ_PS) + CALL mprintf(.true.,STDOUT, 'IPROJ = %i PROJECTION = %s', i1=5, s1='POLAR STEREOGRAPHIC') + CALL mprintf(.true.,STDOUT,' REF_X, REF_Y = %f, %f', f1=fg_data%starti, f2=fg_data%startj) + CALL mprintf(.true.,STDOUT,' REF_LAT, REF_LON = %f, %f', f1=fg_data%startlat, f2=fg_data%startlon) + CALL mprintf(.true.,STDOUT,' DX, DY = %f, %f', f1=fg_data%dx, f2=fg_data%dy) + CALL mprintf(.true.,STDOUT,' STAND_LON = %f', f1=fg_data%xlonc) + CALL mprintf(.true.,STDOUT,' TRUELAT1 = %f', f1=fg_data%truelat1) + CALL mprintf(.true.,STDOUT,' EARTH_RADIUS = %f', f1=fg_data%earth_radius) + CASE (PROJ_CASSINI) + CALL mprintf(.true.,STDOUT, 'IPROJ = %i PROJECTION = %s', i1=6, s1='PROJ_CASSINI') + CALL mprintf(.true.,STDOUT,' REF_X, REF_Y = %f, %f', f1=fg_data%starti, f2=fg_data%startj) + CALL mprintf(.true.,STDOUT,' REF_LAT, REF_LON = %f, %f', f1=fg_data%startlat, f2=fg_data%startlon) + CALL mprintf(.true.,STDOUT,' DX, DY = %f, %f', f1=fg_data%dx, f2=fg_data%dy) + CALL mprintf(.true.,STDOUT,' STAND_LON = %f', f1=fg_data%xlonc) + CALL mprintf(.true.,STDOUT,' POLE_LAT = %f', f1=fg_data%pole_lat) + CALL mprintf(.true.,STDOUT,' POLE_LON = %f', f1=fg_data%pole_lon) + CALL mprintf(.true.,STDOUT,' CENTER_LAT = %f', f1=fg_data%centerlat) + CALL mprintf(.true.,STDOUT,' CENTER_LON = %f', f1=fg_data%centerlon) + CALL mprintf(.true.,STDOUT,' EARTH_RADIUS = %f', f1=fg_data%earth_radius) + CASE default + CALL mprintf(.true.,ERROR, ' Unknown iproj %i for version %i', i1=fg_data%iproj, i2=fg_data%version) + END SELECT + CALL mprintf(.true.,STDOUT,'DATA(1,1)=%f',f1=fg_data%slab(1,1)) + CALL mprintf(.true.,STDOUT,'') + + IF (ASSOCIATED(fg_data%slab)) DEALLOCATE(fg_data%slab) + + CALL read_next_met_field(fg_data, istatus) + + END DO + + CALL read_met_close() + + ELSE + print *, 'File = ',TRIM(flnm) + print *, 'Problem with input file, I can''t open it' + STOP + END IF + + print *,'SUCCESSFUL COMPLETION OF PROGRAM RD_INTERMEDIATE' + STOP + +END PROGRAM rd_intermediate diff --git a/WPS/util/src/read_met_module.F b/WPS/util/src/read_met_module.F new file mode 120000 index 00000000..b061b3bc --- /dev/null +++ b/WPS/util/src/read_met_module.F @@ -0,0 +1 @@ +../../metgrid/src/read_met_module.F \ No newline at end of file diff --git a/WPS/util/src/write_met_module.F b/WPS/util/src/write_met_module.F new file mode 120000 index 00000000..4f0405e4 --- /dev/null +++ b/WPS/util/src/write_met_module.F @@ -0,0 +1 @@ +../../metgrid/src/write_met_module.F \ No newline at end of file diff --git a/WPS/util/vertical_grid_38_20m_G3.txt b/WPS/util/vertical_grid_38_20m_G3.txt new file mode 100644 index 00000000..5c2a942f --- /dev/null +++ b/WPS/util/vertical_grid_38_20m_G3.txt @@ -0,0 +1,46 @@ +123456789 123456789 123456789 123456789 1234567 +(30X,I2) +(30X,F17.11) + model_levels = 38 + first_constant_r_rho_level = 30 + z_top_of_model = 39254.833576 + level Zsea_rho nominal p eta Zsea_theta nominal p eta + + 1 10.000 100000.000 .0002547 20.000 99762.867 .0005095 + 2 50.000 99526.090 .0012737 80.000 99053.912 .0020380 + 3 130.000 98583.358 .0033117 180.000 97880.942 .0045854 + 4 250.000 97182.302 .0063686 320.000 96257.095 .0081519 + 5 410.000 95338.661 .0104446 500.000 94200.637 .0127373 + 6 610.000 93073.170 .0155395 720.000 91734.680 .0183417 + 7 850.000 90411.256 .0216534 980.000 88886.854 .0249651 + 8 1130.000 87382.674 .0287863 1280.000 85688.911 .0326074 + 9 1450.000 84021.086 .0369381 1620.000 82176.281 .0412688 + 10 1810.000 80363.589 .0461090 2000.000 78387.563 .0509491 + 11 2210.000 76450.173 .0562988 2420.000 74363.963 .0616485 + 12 2650.000 72323.137 .0675076 2880.000 70148.683 .0733668 + 13 3130.000 68026.465 .0797354 3380.000 65786.288 .0861040 + 14 3650.000 63605.172 .0929822 3920.000 61322.042 .0998603 + 15 4210.000 59104.640 .1072479 4500.000 56801.240 .1146356 + 16 4810.000 54569.953 .1225327 5120.000 52268.545 .1304298 + 17 5450.000 50045.228 .1388364 5780.000 47767.334 .1472430 + 18 6130.000 45572.981 .1561591 6480.000 43339.071 .1650752 + 19 6850.000 41193.523 .1745008 7220.000 39022.739 .1839264 + 20 7610.000 36944.423 .1938615 8000.000 34854.342 .2037966 + 21 8410.000 32860.054 .2142411 8820.000 30866.499 .2246857 + 22 9250.000 28971.231 .2356398 9680.000 27088.116 .2465938 + 23 10130.000 25304.918 .2580574 10580.000 23544.127 .2695209 + 24 11050.000 21886.594 .2814940 11520.000 20299.517 .2934670 + 25 12010.000 18810.968 .3059496 12500.000 17391.959 .3184321 + 26 13010.000 16065.854 .3314242 13520.000 14807.135 .3444162 + 27 14050.400 13634.172 .3579279 14580.800 12525.597 .3714396 + 28 15137.720 11485.222 .3856269 15694.640 10507.327 .3998142 + 29 16284.975 9583.938 .4148527 16875.310 8721.831 .4298913 + 30 17506.969 7903.664 .4459825 18138.628 7145.969 .4620737 + 31 18820.819 6424.215 .4794523 19503.010 5762.234 .4968308 + 32 20246.599 5132.648 .5157734 20990.188 4563.039 .5347160 + 33 21808.135 4020.943 .5555529 22626.082 3536.758 .5763897 + 34 23542.184 3072.687 .5997270 24458.285 2664.975 .6230643 + 35 25520.962 2266.711 .6501355 26583.639 1925.108 .6772068 + 36 27901.359 1578.023 .7107751 29219.079 1292.113 .7443435 + 37 31063.887 981.432 .7913392 32908.695 749.767 .8383348 + 38 36081.764 481.424 .9191674 39254.834 314.744 1.0000000 diff --git a/WPS/util/vertical_grid_50_20m_63km.txt b/WPS/util/vertical_grid_50_20m_63km.txt new file mode 100644 index 00000000..948eae21 --- /dev/null +++ b/WPS/util/vertical_grid_50_20m_63km.txt @@ -0,0 +1,58 @@ +123456789 123456789 123456789 123456789 1234567 +(30X,I2) +(30X,F17.11) + model_levels = 50 + first_constant_r_rho_level = 30 + z_top_of_model = 62918.64699999984 + level Zsea_rho nominal p eta Zsea_theta nominal p eta + + 1 10.000 100000.000 .0001589 20.000 99762.867 .0003179 + 2 50.000 99526.090 .0007947 80.000 99053.912 .0012715 + 3 130.000 98583.358 .0020662 180.000 97880.942 .0028608 + 4 250.000 97182.302 .0039734 320.000 96257.095 .0050859 + 5 410.000 95338.661 .0065164 500.000 94200.637 .0079468 + 6 610.000 93073.170 .0096951 720.000 91734.680 .0114433 + 7 850.000 90411.256 .0135095 980.000 88886.854 .0155757 + 8 1130.000 87382.674 .0179597 1280.000 85688.911 .0203437 + 9 1450.000 84021.086 .0230456 1620.000 82176.281 .0257475 + 10 1810.000 80363.589 .0287673 2000.000 78387.563 .0317871 + 11 2210.000 76450.173 .0351247 2420.000 74363.963 .0384624 + 12 2650.000 72323.137 .0421179 2880.000 70148.683 .0457734 + 13 3130.000 68026.465 .0497468 3380.000 65786.288 .0537202 + 14 3650.000 63605.172 .0580114 3920.000 61322.042 .0623027 + 15 4210.000 59104.640 .0669118 4500.000 56801.240 .0715209 + 16 4810.000 54569.953 .0764479 5120.000 52268.545 .0813749 + 17 5450.000 50045.228 .0866198 5780.000 47767.334 .0918647 + 18 6130.000 45572.981 .0974274 6480.000 43339.071 .1029901 + 19 6850.000 41193.523 .1088707 7220.000 39022.739 .1147514 + 20 7610.000 36944.423 .1209498 8000.000 34854.342 .1271483 + 21 8410.000 32860.054 .1336647 8820.000 30866.499 .1401810 + 22 9250.000 28971.231 .1470152 9680.000 27088.116 .1538495 + 23 10130.000 25304.918 .1610016 10580.000 23544.127 .1681536 + 24 11050.000 21886.594 .1756236 11520.000 20299.517 .1830936 + 25 12010.000 18810.968 .1908814 12500.000 17391.959 .1986692 + 26 13010.000 16065.854 .2067749 13520.000 14807.135 .2148807 + 27 14050.000 13635.033 .2233042 14580.000 12527.178 .2317278 + 28 15130.000 11499.217 .2404693 15680.000 10531.620 .2492107 + 29 16250.000 9636.960 .2582700 16820.000 8798.261 .2673293 + 30 17410.000 8025.490 .2767065 18000.000 7303.956 .2860837 + 31 18590.015 6662.418 .2954611 19180.029 6063.418 .3048386 + 32 19770.265 5530.648 .3142195 20360.501 5035.617 .3236004 + 33 20951.696 4594.690 .3329966 21542.891 4184.897 .3423928 + 34 22136.667 3818.796 .3518300 22730.443 3478.544 .3612672 + 35 23329.662 3173.115 .3707909 23928.880 2889.410 .3803146 + 36 24537.996 2632.999 .3899956 25147.112 2395.159 .3996766 + 37 25772.527 2178.274 .4096167 26397.942 1977.617 .4195567 + 38 27048.358 1792.660 .4298941 27698.774 1622.245 .4402316 + 39 28385.549 1463.277 .4511468 29072.323 1317.691 .4620621 + 40 29809.823 1180.245 .4737836 30547.323 1055.414 .4855051 + 41 31353.278 936.310 .4983146 32159.233 830.340 .5111240 + 42 33055.089 728.721 .5253624 33950.945 639.542 .5396007 + 43 34962.220 553.727 .5556734 35973.494 479.594 .5717462 + 44 37130.130 408.395 .5901292 38286.766 348.049 .6085122 + 45 39623.485 290.551 .6297574 40960.204 242.886 .6510026 + 46 42516.860 198.086 .6757434 44073.516 161.852 .7004842 + 47 45895.451 128.426 .7294412 47717.385 102.163 .7583982 + 48 49855.781 77.889 .7923848 51994.177 58.929 .8263715 + 49 54506.412 42.149 .8662998 57018.647 29.792 .9062281 + 50 59968.647 19.576 .9531141 62918.647 12.644 1.0000000 diff --git a/WPS/util/vertical_grid_70_20m_80km.txt b/WPS/util/vertical_grid_70_20m_80km.txt new file mode 100644 index 00000000..ce77d909 --- /dev/null +++ b/WPS/util/vertical_grid_70_20m_80km.txt @@ -0,0 +1,78 @@ +123456789 123456789 123456789 123456789 123456789 123456789 123456 +(30X,I2) +(30X,F17.11) + model_levels = 70 + first_constant_r_rho_level = 50 + z_top_of_model = 80000.00 + level Zsea_rho nominal p eta Zsea_theta nominal p eta + + 1 10.000 100000.000 0.0001250 20.000 99762.867 0.0002500 + 2 36.667 99683.898 0.0004583 53.333 99368.609 0.0006667 + 3 76.667 99211.211 0.0009583 100.000 98818.703 0.0012500 + 4 130.000 98583.719 0.0016250 160.000 98115.227 0.0020000 + 5 196.667 97803.789 0.0024583 233.333 97260.844 0.0029167 + 6 276.667 96874.383 0.0034583 320.000 96258.789 0.0040000 + 7 370.000 95799.008 0.0046250 420.000 95112.859 0.0052500 + 8 476.667 94581.734 0.0059583 533.333 93827.367 0.0066667 + 9 596.667 93227.148 0.0074583 660.000 92407.164 0.0082500 + 10 730.000 91740.344 0.0091250 800.000 90857.578 0.0100000 + 11 876.667 90126.898 0.0109583 953.334 89184.406 0.0119167 + 12 1036.667 88392.828 0.0129583 1120.000 87393.891 0.0140000 + 13 1210.000 86544.586 0.0151250 1300.000 85492.672 0.0162500 + 14 1396.667 84589.016 0.0174583 1493.334 83487.773 0.0186667 + 15 1596.667 82533.320 0.0199583 1700.000 81386.563 0.0212500 + 16 1810.000 80385.023 0.0226250 1920.000 79196.719 0.0240000 + 17 2036.667 78151.953 0.0254583 2153.334 76926.180 0.0269167 + 18 2276.667 75842.188 0.0284583 2400.000 74583.133 0.0300000 + 19 2530.000 73464.000 0.0316250 2660.001 72175.945 0.0332500 + 20 2796.667 71025.852 0.0349583 2933.334 69713.133 0.0366667 + 21 3076.667 68536.320 0.0384583 3220.000 67203.320 0.0402500 + 22 3370.001 66004.078 0.0421250 3520.000 64655.203 0.0440000 + 23 3676.667 63437.844 0.0459583 3833.334 62077.488 0.0479167 + 24 3996.667 60846.332 0.0499583 4160.000 59478.883 0.0520000 + 25 4330.001 58238.211 0.0541250 4500.001 56868.000 0.0562500 + 26 4676.668 55622.074 0.0584584 4853.334 54253.375 0.0606667 + 27 5036.667 53006.387 0.0629583 5220.001 51643.387 0.0652500 + 28 5410.001 50399.438 0.0676250 5600.001 49046.234 0.0700000 + 29 5796.668 47809.328 0.0724583 5993.334 46469.879 0.0749167 + 30 6196.667 45243.906 0.0774583 6400.001 43922.020 0.0800000 + 31 6610.001 42710.727 0.0826250 6820.002 41410.063 0.0852500 + 32 7036.672 40217.023 0.0879584 7253.342 38941.063 0.0906668 + 33 7476.690 37769.660 0.0934586 7700.039 36521.652 0.0962505 + 34 7930.085 35375.027 0.0991261 8160.133 34157.977 0.1020017 + 35 8396.920 33039.004 0.1049615 8633.707 31855.646 0.1079213 + 36 8877.306 30766.893 0.1109663 9120.905 29619.641 0.1140113 + 37 9371.434 28563.338 0.1171429 9621.962 27454.279 0.1202745 + 38 9879.598 26432.316 0.1234950 10137.233 25363.184 0.1267154 + 39 10402.239 24377.070 0.1300280 10667.245 23349.232 0.1333406 + 40 10939.989 22394.516 0.1367499 11212.732 21424.107 0.1401592 + 41 11493.719 20521.406 0.1436715 11774.704 19606.658 0.1471838 + 42 12064.604 18754.145 0.1508076 12354.506 17892.988 0.1544313 + 43 12654.205 17088.553 0.1581776 12953.903 16278.701 0.1619238 + 44 13264.532 15520.061 0.1658067 13575.160 14759.074 0.1696895 + 45 13898.152 14043.838 0.1737269 14221.144 13329.213 0.1777643 + 46 14558.290 12654.981 0.1819786 14895.436 11984.241 0.1861929 + 47 15248.947 11348.708 0.1906118 15602.459 10719.493 0.1950307 + 48 15975.034 10120.551 0.1996879 16347.611 9530.724 0.2043451 + 49 16742.518 8966.562 0.2092815 17137.422 8414.302 0.2142178 + 50 17558.574 7883.518 0.2194822 17979.727 7367.396 0.2247466 + 51 18431.783 6869.084 0.2303973 18883.838 6388.160 0.2360480 + 52 19372.307 5921.968 0.2421538 19860.775 5475.810 0.2482597 + 53 20392.113 5044.018 0.2549014 20923.453 4634.511 0.2615432 + 54 21505.199 4237.325 0.2688150 22086.947 3864.583 0.2760868 + 55 22727.850 3502.798 0.2840981 23368.750 3167.226 0.2921094 + 56 24078.898 2841.901 0.3009862 24789.047 2544.045 0.3098631 + 57 25580.037 2256.257 0.3197505 26371.025 1996.555 0.3296378 + 58 27256.115 1747.084 0.3407014 28141.205 1525.544 0.3517651 + 59 29135.490 1314.522 0.3641936 30129.773 1130.419 0.3766222 + 60 31250.379 957.008 0.3906297 32370.986 810.372 0.4046373 + 61 33637.266 674.901 0.4204658 34903.543 562.554 0.4362943 + 62 36337.289 460.272 0.4542161 37771.031 377.143 0.4721379 + 63 39396.711 302.731 0.4924589 41022.387 243.521 0.5127798 + 64 42867.375 191.470 0.5358422 44712.363 150.917 0.5589045 + 65 46807.211 115.923 0.5850902 48902.066 88.916 0.6112759 + 66 51280.766 65.466 0.6410096 53659.457 47.733 0.6707432 + 67 56359.730 33.044 0.7044966 59060.000 22.556 0.7382500 + 68 62123.609 14.425 0.7765451 65187.219 9.063 0.8148403 + 69 68660.281 5.278 0.8582535 72133.344 3.031 0.9016668 + 70 76066.672 1.607 0.9508334 80000.000 0.846 1.0000000 From 40d9d30f7b72d7730383612786735835a129cfeb Mon Sep 17 00:00:00 2001 From: "Theodore M. Giannaros" Date: Thu, 22 Mar 2018 22:44:05 +0200 Subject: [PATCH 14/15] Update output_module.F Modifications to allow for including SFIRE subgrid coordinates to geo_em.d0x.nc files produced by geogrid.exe --- WPS/geogrid/src/output_module.F | 104 ++++++++++++++++++++++++++++---- 1 file changed, 91 insertions(+), 13 deletions(-) diff --git a/WPS/geogrid/src/output_module.F b/WPS/geogrid/src/output_module.F index 5eb0584f..4c2cb862 100644 --- a/WPS/geogrid/src/output_module.F +++ b/WPS/geogrid/src/output_module.F @@ -90,7 +90,7 @@ subroutine output_init(nest_number, title, datestr, grid_type, dynopt, & #ifdef _GEOGRID character (len=128) :: output_flag #endif - + !print*, 'before init_output_fields' call init_output_fields(nest_number, grid_type, & start_dom_1, end_dom_1, start_dom_2, end_dom_2, & start_patch_1, end_patch_1, start_patch_2, end_patch_2, & @@ -273,21 +273,19 @@ subroutine output_init(nest_number, title, datestr, grid_type, dynopt, & #endif call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_open_for_write_begin.') end if - + do i=1,NUM_FIELDS allocate(fields(i)%rdata_arr(fields(i)%mem_start(1):fields(i)%mem_end(1), & fields(i)%mem_start(2):fields(i)%mem_end(2), & fields(i)%mem_start(3):fields(i)%mem_end(3))) - + call write_field(fields(i)%mem_start(1), fields(i)%mem_end(1), fields(i)%mem_start(2), & fields(i)%mem_end(2), fields(i)%mem_start(3), fields(i)%mem_end(3), & trim(fields(i)%fieldname), datestr, fields(i)%rdata_arr, is_training=.true.) - deallocate(fields(i)%rdata_arr) end do - if (my_proc_id == IO_NODE .or. do_tiled_output) then istatus = 0 #ifdef IO_BINARY @@ -399,7 +397,6 @@ subroutine output_init(nest_number, title, datestr, grid_type, dynopt, & parent_grid_ratio(nest_number), & subgrid_ratio_x(nest_number), subgrid_ratio_y(nest_number), & corner_lats, corner_lons, flags=geo_flags, nflags=ngeo_flags) - do i=1,NUM_FIELDS call get_output_flag(trim(fields(i)%fieldname), output_flag, istatus) if (istatus == 0) then @@ -434,6 +431,8 @@ subroutine init_output_fields(nest_num, grid_type, & use storage_module #endif use parallel_module + !TMG: SFIRE modifications + use gridinfo_module, only : subgrid_ratio_x, subgrid_ratio_y implicit none @@ -459,6 +458,8 @@ subroutine init_output_fields(nest_num, grid_type, & character (len=128) :: memorder, units, description character (len=128), dimension(3) :: dimnames integer :: sr_x, sr_y + !TMG: SFIRE modifications + integer :: sgr_x, sgr_y ! ! First find out how many fields there are @@ -493,7 +494,19 @@ subroutine init_output_fields(nest_num, grid_type, & #endif #ifdef _GEOGRID - if (grid_type == 'C') NUM_AUTOMATIC_FIELDS = 28 + !TMG: SFIRE modifications + ! Get nest's subgrid ratio + sgr_x=subgrid_ratio_x(nest_num) + sgr_y=subgrid_ratio_y(nest_num) + + ! Increase number of fields by 2 to include FXLAT, FLXLONG + ! Do this only if we have a subgrid + if ( sgr_x > 1 .or. sgr_y > 1 ) then + if (grid_type == 'C') NUM_AUTOMATIC_FIELDS = 30 + else + if (grid_type == 'C') NUM_AUTOMATIC_FIELDS = 28 + end if + if (grid_type == 'E') NUM_AUTOMATIC_FIELDS = 7 NUM_FIELDS = nfields+NUM_AUTOMATIC_FIELDS @@ -502,7 +515,7 @@ subroutine init_output_fields(nest_num, grid_type, & ! Automatic fields will always be on the non-refined grid sr_x=1 sr_y=1 - + ! ! There are some fields that will always be computed ! Initialize those fields first, followed by all user-specified fields @@ -619,6 +632,18 @@ subroutine init_output_fields(nest_num, grid_type, & fields(28)%fieldname = 'COSALPHA_V' fields(28)%units = 'none' fields(28)%descr = 'Cosine of rotation angle on V grid' + + !TMG: SFIRE modifications + ! Define SFIRE subgrid coordinates + if ( sgr_x > 1 .or. sgr_y > 1 ) then + fields(29)%fieldname = 'FXLONG' + fields(29)%units = 'degrees longitude' + fields(29)%descr = 'Longitude on refined grid' + + fields(30)%fieldname = 'FXLAT' + fields(30)%units = 'degrees latitude' + fields(30)%descr = 'Latitude on refined grid' + end if else if (grid_type == 'E') then fields(1)%fieldname = 'XLAT_M' @@ -677,17 +702,26 @@ subroutine init_output_fields(nest_num, grid_type, & fields(i)%dimnames(3) = ' ' fields(i)%mem_order = 'XY' fields(i)%stagger = 'M' + !TMG: SFIRE modifications + ! Adjust for SFIRE subgrid coordinates + if (fields(i)%fieldname .eq. 'FXLAT' .or. & + fields(i)%fieldname .eq. 'FXLONG') then + fields(i)%sr_x = sgr_x + fields(i)%sr_y = sgr_y + else fields(i)%sr_x = 1 fields(i)%sr_y = 1 + end if if (grid_type == 'C') then fields(i)%istagger = M else if (grid_type == 'E') then fields(i)%istagger = HH end if fields(i)%dimnames(1) = 'west_east' - fields(i)%dimnames(2) = 'south_north' + fields(i)%dimnames(2) = 'south_north' + end do - + ! ! Perform adjustments to metadata for non-mass-staggered "always computed" fields ! @@ -899,6 +933,50 @@ subroutine init_output_fields(nest_num, grid_type, & fields(28)%dimnames(2) = 'south_north_stag' fields(28)%stagger = 'V' fields(28)%istagger = V + + !TMG: SFIRE modifications + ! Adust parameters for SFIRE subgrid + if ( sgr_x > 1 .or. sgr_y > 1 ) then + ! West-east + fields(29)%dom_start(1) = (fields(29)%dom_start(1) - 1)*sgr_x + 1 + fields(29)%mem_start(1) = (fields(29)%mem_start(1) - 1)*sgr_x + 1 + fields(29)%patch_start(1) = (fields(29)%patch_start(1) - 1)*sgr_x + 1 + + fields(29)%dom_end(1) = (fields(29)%dom_end(1) + 1)*sgr_x + fields(29)%mem_end(1) = (fields(29)%mem_end(1) + 1)*sgr_x + fields(29)%patch_end(1) = (fields(29)%patch_end(1) + 1)*sgr_x + + fields(30)%dom_start(1) = (fields(30)%dom_start(1) - 1)*sgr_x + 1 + fields(30)%mem_start(1) = (fields(30)%mem_start(1) - 1)*sgr_x + 1 + fields(30)%patch_start(1) = (fields(30)%patch_start(1) - 1)*sgr_x + 1 + + fields(30)%dom_end(1) = (fields(30)%dom_end(1) + 1)*sgr_x + fields(30)%mem_end(1) = (fields(30)%mem_end(1) + 1)*sgr_x + fields(30)%patch_end(1) = (fields(30)%patch_end(1) + 1)*sgr_x + + ! South-north + fields(29)%dom_start(2) = (fields(29)%dom_start(2) - 1)*sgr_y + 1 + fields(29)%mem_start(2) = (fields(29)%mem_start(2) - 1)*sgr_y + 1 + fields(29)%patch_start(2) = (fields(29)%patch_start(2) - 1)*sgr_y + 1 + + fields(29)%dom_end(2) = (fields(29)%dom_end(2) + 1)*sgr_y + fields(29)%mem_end(2) = (fields(29)%mem_end(2) + 1)*sgr_y + fields(29)%patch_end(2) = (fields(29)%patch_end(2) + 1)*sgr_y + + fields(30)%dom_start(2) = (fields(30)%dom_start(2) - 1)*sgr_y + 1 + fields(30)%mem_start(2) = (fields(30)%mem_start(2) - 1)*sgr_y + 1 + fields(30)%patch_start(2) = (fields(30)%patch_start(2) - 1)*sgr_y + 1 + + fields(30)%dom_end(2) = (fields(30)%dom_end(2) + 1)*sgr_y + fields(30)%mem_end(2) = (fields(30)%mem_end(2) + 1)*sgr_y + fields(30)%patch_end(2) = (fields(30)%patch_end(2) + 1)*sgr_y + + fields(29)%dimnames(1) = 'west_east_subgrid' + fields(29)%dimnames(2) = 'south_north_subgrid' + fields(30)%dimnames(1) = 'west_east_subgrid' + fields(30)%dimnames(2) = 'south_north_subgrid' + + end if else if (grid_type == 'E') then ! Lat V @@ -1046,7 +1124,6 @@ subroutine init_output_fields(nest_num, grid_type, & end if ! the next field given by get_next_fieldname() is valid } end do ! for each user-specified field } - end subroutine init_output_fields @@ -1081,10 +1158,11 @@ subroutine write_field(start_mem_i, end_mem_i, & logical :: allocated_real_locally allocated_real_locally = .false. - + ! If we are running distributed memory and need to gather all tiles onto a single processor for output if (nprocs > 1 .and. .not. do_tiled_output) then do i=1,NUM_FIELDS + if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. & (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then istatus = 0 @@ -1121,7 +1199,7 @@ subroutine write_field(start_mem_i, end_mem_i, & end if end do end if - + ! Now a write call is only done if each processor writes its own file, or if we are the IO_NODE if (my_proc_id == IO_NODE .or. do_tiled_output) then comm_1 = 1 From 7a138b7b96575a957d7564ab02d0c2ff5a43e55a Mon Sep 17 00:00:00 2001 From: "Theodore M. Giannaros" Date: Thu, 22 Mar 2018 22:54:42 +0200 Subject: [PATCH 15/15] Update process_tile_module.F Modifications to allow for properly constructing the subgrid for SFIRE. --- WPS/geogrid/src/process_tile_module.F | 79 +++++++++++++++++++++++---- 1 file changed, 69 insertions(+), 10 deletions(-) diff --git a/WPS/geogrid/src/process_tile_module.F b/WPS/geogrid/src/process_tile_module.F index ccb718b7..ce7005e7 100644 --- a/WPS/geogrid/src/process_tile_module.F +++ b/WPS/geogrid/src/process_tile_module.F @@ -32,7 +32,9 @@ subroutine process_tile(which_domain, grid_type, dynopt, & use output_module use smooth_module use source_data_module - + !TMG: SFIRE modifications + use gridinfo_module, only : subgrid_ratio_x, subgrid_ratio_y + implicit none ! Arguments @@ -65,6 +67,13 @@ subroutine process_tile(which_domain, grid_type, dynopt, & mapfac_array_m_y, mapfac_array_u_y, mapfac_array_v_y, & mapfac_array_x_subgrid, mapfac_array_y_subgrid, & sina_array, cosa_array + !TMG: SFIRE modifications + ! To avoid conflicts, we define new pointer arrays for storing SFIRE subgrid + ! coordinates + real, pointer, dimension(:,:) :: xlat_array_sfire, xlon_array_sfire + integer :: start_mem_sub_i, end_mem_sub_i, start_mem_sub_j, end_mem_sub_j + integer :: sgr_x, sgr_y + real, pointer, dimension(:,:) :: xlat_ptr, xlon_ptr, mapfac_ptr_x, mapfac_ptr_y, landmask, dominant_field real, pointer, dimension(:,:,:) :: field, slp_field logical :: is_water_mask, only_save_dominant, halt_on_missing @@ -110,7 +119,10 @@ subroutine process_tile(which_domain, grid_type, dynopt, & nullify(dominant_field) nullify(field) nullify(slp_field) - + !TMG: SFIRE modifications + nullify(xlat_array_sfire) + nullify(xlon_array_sfire) + datestr = '0000-00-00_00:00:00' field_count = 0 mass_flag=1.0 @@ -173,7 +185,28 @@ subroutine process_tile(which_domain, grid_type, dynopt, & end_dom_j = dummy_end_dom_j end_dom_stag_j = dummy_end_dom_j end if - + + !TMG: SFIRE modifications + ! Adjust for SFIRE subgrid coordinates + sgr_x=subgrid_ratio_x(which_domain) + sgr_y=subgrid_ratio_y(which_domain) + + if ( sgr_x > 1 .or. sgr_y > 1 ) then + start_mem_sub_i = (start_mem_i - 1) * sgr_x + 1 + if (extra_col) then + end_mem_sub_i = (end_mem_i + 1) * sgr_x + else + end_mem_sub_i = (end_mem_i ) * sgr_x + end if + + start_mem_sub_j = (start_mem_j - 1) * sgr_y + 1 + if (extra_row) then + end_mem_sub_j = (end_mem_j + 1) * sgr_y + else + end_mem_sub_j = (end_mem_j ) * sgr_y + end if + end if + ! Allocate arrays to hold all lat/lon fields; these will persist for the duration of ! the process_tile routine ! For C grid, we have M, U, and V points @@ -189,7 +222,15 @@ subroutine process_tile(which_domain, grid_type, dynopt, & allocate(clon_array(start_mem_i:end_mem_i, start_mem_j:end_mem_j)) allocate(xlat_array_corner(start_mem_i:end_mem_stag_i, start_mem_j:end_mem_stag_j)) allocate(xlon_array_corner(start_mem_i:end_mem_stag_i, start_mem_j:end_mem_stag_j)) + !TMG: SFIRE modifications + ! Allocate SFIRE coordinate arrays + if ( sgr_x > 1 .or. sgr_y > 1 ) then + allocate(xlat_array_sfire(start_mem_sub_i:end_mem_sub_i, start_mem_sub_j:end_mem_sub_j)) + allocate(xlon_array_sfire(start_mem_sub_i:end_mem_sub_i, start_mem_sub_j:end_mem_sub_j)) + end if + end if + nullify(xlat_array_subgrid) nullify(xlon_array_subgrid) nullify(mapfac_array_x_subgrid) @@ -215,7 +256,7 @@ subroutine process_tile(which_domain, grid_type, dynopt, & start_mem_j, end_mem_stag_i, end_mem_stag_j, CORNER) call get_lat_lon_fields(clat_array, clon_array, start_mem_i, & start_mem_j, end_mem_i, end_mem_j, M, comp_ll=.true.) - + corner_lats(1) = xlat_array(start_patch_i,start_patch_j) corner_lats(2) = xlat_array(start_patch_i,end_patch_j) corner_lats(3) = xlat_array(end_patch_i,end_patch_j) @@ -298,15 +339,24 @@ subroutine process_tile(which_domain, grid_type, dynopt, & corner_lons(16) = 0.0 end if + + !TMG: SFIRE modifications + ! Compute SFIRE subgrid coordinates + if ( sgr_x > 1 .or. sgr_y > 1 ) then + call mprintf(.true.,STDOUT,' Processing FXLAT and FXLONG') + call get_lat_lon_fields(xlat_array_sfire, xlon_array_sfire, & + start_mem_sub_i, start_mem_sub_j, end_mem_sub_i, end_mem_sub_j, & + M, sub_x=sgr_x, sub_y=sgr_y) + end if ! Initialize the output module now that we have the corner point lats/lons - call output_init(which_domain, 'OUTPUT FROM GEOGRID V3.9.1', '0000-00-00_00:00:00', grid_type, dynopt, & + call output_init(which_domain, 'OUTPUT FROM GEOGRID V3.9.0.1', '0000-00-00_00:00:00', grid_type, dynopt, & corner_lats, corner_lons, & start_dom_i, end_dom_i, start_dom_j, end_dom_j, & start_patch_i, end_patch_i, start_patch_j, end_patch_j, & start_mem_i, end_mem_i, start_mem_j, end_mem_j, & extra_col, extra_row) - + call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, & 'XLAT_M', datestr, real_array = xlat_array) call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_j, 1, 1, & @@ -315,6 +365,15 @@ subroutine process_tile(which_domain, grid_type, dynopt, & 'XLAT_V', datestr, real_array = xlat_array_v) call write_field(start_mem_i, end_mem_i, start_mem_j, end_mem_stag_j, 1, 1, & 'XLONG_V', datestr, real_array = xlon_array_v) + !TMG: SFIRE modifications + ! Write out SFIRE subgrid coordinates + if ( sgr_x > 1 .or. sgr_y > 1 ) then + call write_field(start_mem_sub_i, end_mem_sub_i, start_mem_sub_j, end_mem_sub_j, 1, 1, & + 'FXLAT', datestr, real_array = xlat_array_sfire) + call write_field(start_mem_sub_i, end_mem_sub_i, start_mem_sub_j, end_mem_sub_j, 1, 1, & + 'FXLONG', datestr, real_array = xlon_array_sfire) + end if + if (grid_type == 'C') then call write_field(start_mem_i, end_mem_stag_i, start_mem_j, end_mem_j, 1, 1, & 'XLAT_U', datestr, real_array = xlat_array_u) @@ -826,10 +885,10 @@ subroutine process_tile(which_domain, grid_type, dynopt, & !BUG: This should probably be moved up to where other lat/lon fields are calculated, and we should ! just determine whether we will have any subgrids or not at that point if ((sub_x > 1) .or. (sub_y > 1)) then -! if (associated(xlat_array_subgrid)) deallocate(xlat_array_subgrid) -! if (associated(xlon_array_subgrid)) deallocate(xlon_array_subgrid) -! if (associated(mapfac_array_x_subgrid)) deallocate(mapfac_array_x_subgrid) -! if (associated(mapfac_array_y_subgrid)) deallocate(mapfac_array_y_subgrid) + if (associated(xlat_array_subgrid)) deallocate(xlat_array_subgrid) + if (associated(xlon_array_subgrid)) deallocate(xlon_array_subgrid) + if (associated(mapfac_array_x_subgrid)) deallocate(mapfac_array_x_subgrid) + if (associated(mapfac_array_y_subgrid)) deallocate(mapfac_array_y_subgrid) allocate(xlat_array_subgrid(sm1:em1,sm2:em2)) allocate(xlon_array_subgrid(sm1:em1,sm2:em2)) allocate(mapfac_array_x_subgrid(sm1:em1,sm2:em2))